gcl-2.6.14/0000755000175000017500000000000014360276512010773 5ustar cammcammgcl-2.6.14/gcl1.jpg0000755000175000017500000004115614360276512012335 0ustar cammcammJFIFHH Photoshop 3.08BIMHH8BIM8BIM 8BIM' 8BIMH/fflff/ff2Z5-8BIMp8BIM@@8BIM V4N :JFIFHH'File written by Adobe Photoshop 4.0Adobed            4"?   3!1AQa"q2B#$Rb34rC%Scs5&DTdE£t6UeuF'Vfv7GWgw5!1AQaq"2B#R3$brCScs4%&5DTdEU6teuFVfv'7GWgw ?T^덬·5gd0Á"~K5X~W)He_7H{ݟ6Ϳ!ߣn\O=X0,u8iGP'm =k~[ܶ|39YqJ_嶎Ƈ0}ocQ˦q2ipisY}v4}3Mog3Q42oah{lc A׿}KF~>Gjl%G>\9q"|&=K޶_jexT\}du-vW=j~zóz?D? z)6Znʗu Υf~}M9ߚ֍[U-K?ug|;ᇙ&s&8bkO$v>7Ž35YOgvTG2qݶ^d>zMvh?{ }S]۔\]Apc?  G/Y/|K V_W5G%]Fo81{􋰮X%Wu {,syKӰFOPzMOwW_sX)ŗTW?O|K"AZ=geaul,<:HZhwѷ{?^P~6F%XUYZ8;*`7/4ζ8=.qit_U.nI?osN[$cgrO~g5mZ97wWO=Tt~csg6HA{ "'X<~caz;YA^-r QIeH߹Ե猎5s%de2 `t?۝&n3;E՛,n_s+' cfluV:~㾅]kȐ:G51KGXf2xe TY8qkdc{젞MOs'鹩eWo{ʿs|xny{"ߩx+7*[GKŘ`%V3,4LZ{4y,6~_M>w? k}jnkZ]K u>k}3!Vkx1?& jRЏֿS*R?0<_iS~l2|rXP1,v/K9~gc'SC.jqS%Π{نdFb\>SO O5+ʷC Wb],*COP`R)_BFRܚmÃ&cÎ&G~{M?{{i+NZQ1y#\4!;($gy^SJ"jikH,1rf/<ŤNTux|6ae}Λ6&Yc(o?2MHVk Wb STR?dآϬ{KZW R\UUثWv*Uثǿ5=,&>o0m}2kI+U?-ghaҋ-{9iN&"b9q/.^O̟77d<V=NRSu"z#꽤={z<./}όY^_6\sy}3B0˫͗??;;iV"}GX!2)sՈ1KYhuE?01~:<]i֕s Ŕ[ȇZ6R>'(#ѨD,c0y ~[Seey&η䄘u+tC%?Rk7̈́W_#҄h4Wr=ҏZ:uj׺̻qq-̍iYL)'߻m.4Dp0@Kh*(#C@GKu] +TѮF`~TicyBNĞz jӔs , }͈C_%M|G/;_3?5Z~Qj:^3)؂:)؃;pX /]ٺOOH 7#b7zZ85\ dL\P?s6MN}7Zi&hfK ;CҴK+zM~kK&4==?!?u-x?23P?o8kc'̯FCHn?>X]{V+KU8EvxGL3ϓ1 q2>-zBд?/[ݽ:-\JЍPIb 59ءGSƿRu䑕 7B=OKZ3&v*v*U999k乵 Qok>m!g_En7Y^y5@{WF+LJyu= ':NY<0e/!k:uKo^cR^O3I>àl)F_\:\QÆ[ov*UثWb_X4~c3jV徣!1rT$ʣjkTnXO/~?P0+C]%n_i:~v!fуV$QcNS?H4m G5JᨑvUv.X≜;?><4x䙨s'rXo|5ה.94F ۝ۡFݡSJ} }RL!}oi;1jͪ|y6P }UPUثWb_O6~f_y_XM+U&mz 齜8O)n=?3PDFg/Gy<ЈkZwz6.cBY~'k~`=u+ym+ȰE W֋?糕b3{{Sj_Mؿ݅r<>?؋9ViKv*ʏJZb'Sy@_ǐ| .8"jZ=S}o=s,c&'F%DKZa 2}1hԟ tثWv* {?w|u_:y{e&M]覃?/۽q GG {ajkx)r|#8vCj쨊]T O`0dhnK !s"1IO@l#({]żtgOAGvsY_eqvv?ꗿ=>X䢭 f=pO]$3 ?Ma%½FbjcxIzFQфg8uI#*䉊He4 r Cfx #p~!nER[߷$hLIӕ33.}ä<w?eGy_j}CTvNIى.w~1FD(b"U] Ml?w=?3/_`vDt>^}#&hkSR3~$/0Ayd3#t vOfaMOxx:s[{ RA[_vР~hFRk?Y,C&G"G%; ƹc{{ۺ5y+$@hM9E{  ͆8h=/xS=&G% PH͙]B1PGw)?ZX- =R9Pg/hp'sO {"3=>@Oߦ?ҾqU!!Ux~Yv 1s.Serj{p䝀gz}[U{= CǤ y=O~:ڽ_:92?.gAzgt W3Xh_̨L 02c_ߕOPf!&BrFTGLAӂ!U;Z:>ؔrLCLR FR9A[K'.b"! g/y9@~{${?-TfGHTjivê\68~<^ m" ?"t'^izpFX"%~z>UR̪:}9vz-hc^$C)ɧׯ`ZLG(MCZ't oFotE=K+D WҪ{fX倜 GC#Ò,5ubW?H_4jCzkLp!rݩApP3(aǦ.y$"=5s/5R55j_P׮仜v@|5G0ϞYK$_dfba Qu̟9'̤Kv*4x(j|r)죯swG~2FsaٸϣN~sX=FtψBKC^@4O(R(;dəDGt4@ooUl38kL= ႛ/_ 'yW3蝈Oɯ2[J$z%U \=ўۺU 9Gv7wabO99O[C4FzA_o=3<]v7}ZT@:oqZ~UC 䧆H8/}_QҭEnu+iX(?EkbrL@s&]vOQhcD[7V%-!Q z,c +d2j2}Y$d}6/?ѿZW,fs[oaW٥hsE&9QLɏN_%|$ثj(ƃBrɯNS 6ɴa#=E$5-g1B0)[C'hjr}Y$d7_O-|I1d_y P "Oc5F$֙jiAKEpPk [%3cIjk菻^$o!htdB W5Y R[.˟j#,}G/S5\]^YX'?-s,H|E/mLq_QipQN& (ov*U7iA|Rq`fowN^1>jwk ]xGg5~C2U9@x!ͣU|3yB2POzo-=YTQD@4F̉}W5)vɇE^lo1yWC6'Q}A#!@.,q}}CC_!ipGؾ.>_pA[Y]-|o?+UT'7MG| >OQ!#}5Oq4C$TwLJymsֶ !h<"Wa%n$?Hu,z>{Toj6IK@4/;EY';_vm| t}y;Ob#=V燇lq_qycNX`4ȍ Ⱥi- Ks;ʀBaj0b9%~)vbgv=!R>Q s_+B {0KZn aK/m7nsle|_'vfܣg O/m;Q )(/-Yu=D,|n#!!`|.)⑄c!AwWI~a`DzS~}|4o,~^YOΚShXx3b5quh5>q2>zOlIP*}qW=^yɼHlHA`L8/g(v*UzU?!ifOa/'U*[RiA_O3`h5SrD|_>Utd ?~]X}0K>>(o)cOn\"3?Mq4u Q{Xdv2pp;F1  ^U+hMM8Z@?RdN4|l{KU?o/ϫf֏e 0ADL3WQg c-G@"'rS.ˇ3Rq}ǟy?7bB62Ol3 ?qۑ/΋%k ,J?qҽ^O?hȒ~f:] ڃM? {; 5$wɿ͊rH $DM|_I^Z+@HFwfOѯX; q{M;O+;+8Zkc(؀Tp qI@"h$w.#O.\~[Rwۨ(̦@-ը8OφDyyu?act|wc# ~~.Eדթr@jep LoN_Ur1:-jCWG${~2~{~fM/||MCEPP>#N;~5P2\#`j=|c !8qFϪv>|ҭ$9|'79˺] TP\;gvJG>v/g`2<߽G{5;Gi JOL?5gNSd 4MKQ!#>/m]qGR3~X//ʽ!Um qoː$0F)dK9Eo8bAUUzU??#fgU {}KI@6i!F3x3z7[ Wb7ֺD&!B8Ƽ?^HΧ{xcǚ! rjWن72LH3 rk~Gˏ=6(^66A. U=W7!|9ϻ/h?3$37A(yu=潫OZup#y?"y&Ot,V`7$w'FÊ8`!@?v?hrjuɐ?y@t'~l8zt0)?jp`A# ez}nY|G/k..3]]z1wc$I6yx"`TD2ۚsSQ\hK.#'=HdDDe76vgi~{״vW6^\fW~O4;=ǫh?zUH)OR7Oc"GoLc9P\=_~L?ݗ?E>^X?%1v_?֩櫯<\c˚ 0-y/1"<3y؝JG%pǸu/?wi\. !CvzS:ǩ],ka*zU/G\ߛށD$y`W'LFci_R hKMEcUBM?|G~=l)j7 ?WfO|hyZӾm:!zƄak,ާwsޘcrgqbΚ|m&MZJxHSM 7 YaI91m>EO`৓qHyJl',ɡ3FJ+Pҩ*cvI#~h;?' Pԇ117im_ݑZ+33g3>C^k}?9Ke2h)7_f~ɻw cxvn~3 - "-(z;4\ZqXnwk5eb=1s.{!ӒcȞ@txI@5JOLz~w/i5ヵØmN~gOq]ZN׶i%Ѻu`vQ05!G\ 'Bqt~^p/K\8pDyw,Gw q/DQV0 >-Ohg}NC$:zߕ5ı;hR}w/ I}dih̟~ca&] ON3>ymj|mT}#o)$*yo,~PxUGSVQuF+ETb]QDZnn`o̍&,q~OjDz?>_H(|{rCh'ᬓg#r$|7_K< ɇO<bIʜX>N ֣ _/yI}TjF"E-K$:Ϛ%G't'FOlkJ+('ռ'<4#Am!&>h@G$( ':AL4eou># #GhGu@ecbpWۚfG;MۑX2Yaߗw$iOQп+b?v4[X2`톘=˾IF}*RMdL0%8;by@[+Pp3卞oMZ%.@*ɆLGQ$!w?%ţ9>K0Z Qd#̉}&~ݜ0MZN0F?RN8duy/8WII?=5/o˙Y0<8/f|֣*_f=f|g?.%aG3>_oU?1>Kϗc*og8q ϗh. a e1R#̗_$ ;dWBLt$d_Vh()J QeT)BOpE:;TcV\ yf(n Dd$mC'b~>ˉIRIZ(aN-?+bV}8k q>F4&x g>^@)-d .(\Tvk*Ek^ybՌ`H/(?.a_lI~VI\I9J߆ O.0¶HewHT\m#O`@bd;@ bD6 abym)yŻ8VC9}S.$WM~>ibC~ډ{?1[pޜ;?1[T]z?+hҭSLV+i tXFW]hz/oY>?m _nLSj;+k˺zLV YC~ZY@LU~*[*{dUPHn~ LV[51[wk/ob_߇m߇mzvbE%IkLUUv*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWgcl-2.6.14/readme.gmp0000644000175000017500000000162314360276512012737 0ustar cammcammThe gmp directory is from the gmp 3.1.1 distribution with the following changes: mpn/mul_n.c has been altered so as to use alloca instead of malloc, since the malloc at that point causes a problem for gcl. All other temporary storage in the mpn directory should be allocated using TMP_ALLOC (ie alloca). Hopefully this will be changed in a future release of gmp. However since we need to know about the allocs in the mpn directory (and the mpz directory), it is probably safer to use the gmp here, and to periodically update it after having carefully perused the contents. We only need the mpz mpn directories, but the other makefiles are included so as not to have to change the configure/make mechanism. The list of files here was constructed via: (cd /tmp/gmp-3.1/ ; tar cvf - lt* COPYING README install-sh conf* *.h mpn mpz *akefile.in */*akefile.in */*/*akefile.in *.c) | (cd tmp ; tar xvf -) gcl-2.6.14/elisp/0000755000175000017500000000000014360276512012107 5ustar cammcammgcl-2.6.14/elisp/gcl.el0000755000175000017500000002665314360276512013215 0ustar cammcamm;; Copyright William F. Schelter. 1994 ;; Licensed by GNU public license. ;; You should copy isp-complete.el to the emacs/lisp directory. ;; Some commands and macros for dealing with lisp ;; M-X run : run gcl or another lisp ;; m-c-x ; evaluate defun in the other window or in the last lisp which you were using. ;; m-c-x ; with a numeric arg : compile the current defun in the other window ;; m-c-d ; disassemble in other window. ;; M-x macroexpand-next : macro expand the next sexp in other window. ;; C-h d Find documentation on symbol where the cursor is. ;; C-h / Find documentation on all strings containing a given string. ;; M-p complete the current input by looking back through the buffer to see what was last typed ;; using this prompt and this beginning. Useful in shell, in lisp, in gdb,... (setq lisp-mode-hook 'remote-lisp) (autoload 'lisp-complete "lisp-complete" nil t) (autoload 'smart-complete "smart-complete" nil t) ;(global-set-key "p" 'lisp-complete) (global-set-key "p" 'smart-complete) (defun remote-lisp (&rest l) (and (boundp 'lisp-mode-map) lisp-mode-map (progn (define-key lisp-mode-map "\e\C-d" 'lisp-send-disassemble) (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun-compile) (make-local-variable 'lisp-package) (setq lisp-package nil) (and (boundp 'remote-lisp-hook) (funcall remote-lisp-hook)) ))) (defvar search-back-for-lisp-package-p nil) ;; look at the beginning of buffer to try to find an in package statement (defun get-buffer-package () "Returns what it thinks is the lisp package for the current buffer. It caches this information in the local variable `lisp-package'. It obtains the information from searching for the first in-package from the beginning of the file. Since in common lisp, there is only supposed to be one such statement, it should be able to determine this. By setting lisp-package to t, you may disable its search. This will also disable the automatic inclusion of an in-package statement in the tmp-lisp-file, used for sending forms to the current lisp-process." (cond ((eq lisp-package t) nil) (search-back-for-lisp-package-p (save-excursion (cond ((re-search-backward "^[ \t]*(in-package " nil t) (goto-char (match-end 0)) (read (current-buffer)))))) (lisp-package lisp-package) (t (setq lisp-package (let (found success) (save-excursion (goto-char (point-min)) (while (not found) (if (and (setq success (search-forward "(in-package " 1000 t)) (not (save-excursion (beginning-of-line) (looking-at "[ \t]*;")))) (setq found (read (current-buffer)))) (if (>= (point) 980) (setq found t)) (or success (setq found t)) )) found))))) (defun run (arg) "Run an inferior Lisp process, input and output via buffer *lisp*." (interactive "sEnter name of file to run: ") (require 'sshell) ;; in emacs 19 uncomment: ;;(require 'inf-lisp) (setq lisp-mode-hook 'remote-lisp) (switch-to-buffer (make-sshell (concat arg "-lisp") arg nil "-i")) (make-local-variable 'shell-prompt-pattern) (setq sshell-prompt-pattern "^[^#%)>]*[#%)>]+ *") (cond ((or (string-match "maxima" arg) (string-match "affine" arg) (save-excursion (sleep-for 2) (re-search-backward "maxima" (max 1 (- (point) 300)) t))) (require 'maxima-mode) (inferior-maxima-mode) (goto-char (point-max)) ) (t (if (boundp 'inferior-lisp-mode) (inferior-lisp-mode) (funcall lisp-mode-hook)) ))) (defun lisp-send-disassemble (arg) (interactive "P") (if arg ( lisp-send-defun-compile "disassemble-h") ( lisp-send-defun-compile "disassemble")) ) (defvar time-to-throw-away nil) (defvar telnet-new-line "") (defun lisp-send-defun-compile (arg) "Send the current defun (or other form) to the lisp-process. If there is a numeric arg, the form (compile function-name) is also sent. The value of lisp-process will be the process of the other exposed window (if there is one) or else the global value of lisp-process. If the ...received message is not received, probably either the reading of the form caused an error. If the process does not have telnet in its name, then we write a tmp file and load it. If :sdebug is in *features*, then si::nload is used instead of ordinary load, in order to record line information for debugging. The value of `lisp-package' if non nil, will be used in putting an in-package statement at the front of the tmp file to be loaded. `lisp-package' is determined automatically on a per file basis, by get-buffer-package. " (interactive "P") (other-window 1) (let* ((proc (or (get-buffer-process (current-buffer)) lisp-process)) def beg (this-lisp-process proc) (lisp-buffer (process-buffer this-lisp-process)) fun) (other-window 1) (save-excursion (end-of-defun) (let ((end (dot)) (buffer (current-buffer)) (proc (get-process this-lisp-process))) (setq lisp-process proc) (beginning-of-defun) (save-excursion (cond ((and arg (looking-at "(def")) (setq def t)) (t (setq arg nil))) (cond (def (forward-char 2)(forward-sexp 1) (setq fun (read buffer)) (setq fun (prin1-to-string fun)) (message (format "For the lisp-process %s: %s" (prin1-to-string this-lisp-process) fun))))) (cond ((equal (char-after (1- end)) ?\n) (setq end (1- end)) )) (setq beg (dot)) (my-send-region this-lisp-process beg end) )) (send-string this-lisp-process (concat ";;end of form" "\n" telnet-new-line)) (cond (arg (if (numberp arg) (setq arg "compile")) (send-string this-lisp-process (concat "(" arg "'" fun ")" telnet-new-line)))) (and time-to-throw-away (string-match "telnet"(buffer-name (process-buffer proc))) (dump-output proc time-to-throw-away)) (cond (nil ;(get-buffer-window lisp-buffer) (select-window (get-buffer-window lisp-buffer)) (goto-char (point-max))) (t nil)))) (fset 'lisp-eval-defun (symbol-function 'lisp-send-defun-compile)) (defvar telnet-new-line "") (defvar tmp-lisp-file (concat "/tmp/" (user-login-name) ".lsp")) (defun get-buffer-clear (name) (let ((cb (current-buffer)) (buf (get-buffer-create name))) (set-buffer buf) (erase-buffer) (set-buffer cb) buf)) (defmacro my-with-output-to-temp-buffer (name &rest body) (append (list 'let (list (list 'standard-output (list 'get-buffer-clear name)))) body)) (defun my-send-region (proc beg end) (cond ((or (string-match "telnet" (process-name proc))) (send-region proc beg end)) (t (let ((package (get-buffer-package))) (save-excursion (my-with-output-to-temp-buffer "*tmp-gcl*" (if (and package (not (eq package t))) (prin1 (list 'in-package package))) (princ ";!(:line ") (prin1 (let ((na (buffer-file-name (current-buffer)))) (if na (expand-file-name na) (buffer-name (current-buffer)))) ) (princ (- (count-lines (point-min) (+ beg 5)) 1)) (princ ")\n") (set-buffer "*tmp-gcl*") (write-region (point-min) (point-max) tmp-lisp-file nil nil))) (write-region beg end tmp-lisp-file t nil) (message "sending ..") (send-string proc (concat "(lisp::let ((*load-verbose* nil)) (#+sdebug si::nload #-sdebug load \"" tmp-lisp-file "\")#+gcl(setq si::*no-prompt* t)(values))\n ") ) (message (format "PACKAGE: %s ..done" (if (or (not package) (eq package t)) "none" package))) )))) (defun dump-output (proc seconds) "dump output for PROCESS for SECONDS or to \";;end of form\"" (let ((prev-filter (process-filter proc)) (already-waited 0)) (unwind-protect (progn (set-process-filter proc 'dump-filter) (while (< already-waited seconds) (sleep-for 1)(setq already-waited (1+ already-waited)))) (set-process-filter proc prev-filter)))) (defun dump-filter (proc string) ; (setq she (cons string she)) (let ((ind (string-match ";;end of form" string))) (cond (ind (setq string (substring string (+ ind (length ";;end of form")))) (message "... received.") (setq already-waited 1000) (set-process-filter proc prev-filter) (cond (prev-filter (funcall prev-filter proc string)) (t string))) (t "")))) ;;(process-filter (get-process "lisp")) (defun macroexpand-next () "macroexpand current form" (interactive) (save-excursion (let ((beg (point))) (forward-sexp ) (message "sending macro") (let* ((current-lisp-process (or (get-buffer-process (current-buffer)) (prog2 (other-window 1) (get-buffer-process (current-buffer)) (other-window 1))))) (send-string current-lisp-process "(macroexpand '") (send-region current-lisp-process beg (point) ) (send-string current-lisp-process ")\n"))))) (defun delete-comment-char (arg) (while (and (> arg 0) (looking-at comment-start)) (delete-char 1) (setq arg (1- arg)))) (defun mark-long-comment () (interactive) (let ((at (point))) (beginning-of-line) (while(and (not (eobp)) (or (looking-at comment-start) ;(looking-at "[ ]*\n") )) (forward-line 1)) (set-mark (point)) (goto-char at) (while(and (not (bobp)) (or (looking-at comment-start) ;(looking-at "[ ]*\n") )) (forward-line -1)) (or (bobp )(forward-line 1)))) (defun fill-long-comment () (interactive) (mark-long-comment) (let ((beg (min (dot) (mark))) (end (max (dot) (mark))) (n 0)m) (narrow-to-region beg end) (goto-char (point-min)) (while (looking-at ";") (forward-char 1)) (setq n (- (point) beg)) (goto-char (point-min)) (while (not (eobp)) (setq m n) (while (> m 0) (cond ((looking-at ";") (delete-char 1) (cond ((looking-at " ")(delete-char 1)(setq m 0))) (setq m (- m 1))) (t (setq m 0)))) (forward-line 1)) (fill-region (dot-min) (dot-max)) (goto-char (point-min)) (while (not (eobp)) (cond ((looking-at "\n") nil) (t(insert ";; "))) (forward-line 1)) (goto-char (point-min)) (set-mark (point-max)) (widen))) (defun comment-region (arg) "Comments the region, with a numeric arg deletes up to arg comment characters from the beginning of each line in the region. The region stays, so a second comment-region adds another comment character" (interactive "P") (save-excursion (let ((beg (dot)) (ok t)(end (mark))) (comment-region1 beg end arg)))) (defun comment-region1 (beg end arg) (let ((ok t)) (cond((> beg end) (let ((oth end)) (setq end beg beg oth)))) (narrow-to-region beg end) (goto-char beg) (unwind-protect (while ok (cond (arg (delete-comment-char arg)) (t (insert-string comment-start))) (if (< end (dot)) (setq ok nil) (if (search-forward "\n" end t) nil (setq ok nil))) ) (widen)))) (defun trace-expression () (interactive) (save-excursion (forward-sexp ) (let ((end (point))) (forward-sexp -1) (other-window 1) (let* ((proc (get-buffer-process (current-buffer))) (current-lisp-process (or proc lisp-process))) (other-window 1) (message "Tracing: %s" (buffer-substring (point) end)) (send-string current-lisp-process "(trace ") (send-region current-lisp-process (point) end) (send-string current-lisp-process ")\n"))))) (defun gcl-mode () (interactive) (lisp-mode) ) (provide 'gcl)gcl-2.6.14/elisp/add-default.el0000644000175000017500000000016714360276512014607 0ustar cammcamm ;;;BEGIN gcl addition (autoload 'dbl "dbl" "Make a debugger to run lisp, maxima and or gdb in" t) ;;;END gcl addition gcl-2.6.14/elisp/dbl.el0000755000175000017500000005453214360276512013206 0ustar cammcamm;; Run gcl,maxima,gdb etc under Emacs all possibly all in one buffer. ;; ;; This file is part of GNU Emacs. ;; Copyright (C) 1998 William F. Schelter ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility ;; to anyone for the consequences of using it or for whether it serves ;; any particular purpose or works at all, unless he says so in writing. ;; Refer to the GNU Emacs General Public License for full details. ;; Everyone is granted permission to copy, modify and redistribute GNU ;; Emacs, but only under the conditions described in the GNU Emacs ;; General Public License. A copy of this license is supposed to have ;; been given to you along with GNU Emacs so you can know your rights and ;; responsibilities. It should be in a file named COPYING. Among other ;; things, the copyright notice and this notice must be preserved on all ;; copies. ;; Description of DBL interface: ;; A facility is provided for the simultaneous display of the source code ;; in one window, while using dbl to step through a function in the ;; other. A small arrow in the source window, indicates the current ;; line. ;; Starting up: ;; In order to use this facility, invoke the command DBL to obtain a ;; shell window with the appropriate command bindings. You will be asked ;; for the name of a file to run. Dbl will be invoked on this file, in a ;; window named *dbl-foo* if the file is foo. ;; M-s steps by one line, and redisplays the source file and line. ;; You may easily create additional commands and bindings to interact ;; with the display. For example to put the dbl command next on \M-n ;; (def-dbl :next "\M-n") ;; This causes the emacs command dbl-next to be defined, and runs ;; dbl-display-frame after the command. ;; dbl-display-frame is the basic display function. It tries to display ;; in the other window, the file and line corresponding to the current ;; position in the dbl window. For example after a dbl-step, it would ;; display the line corresponding to the position for the last step. Or ;; if you have done a backtrace in the dbl buffer, and move the cursor ;; into one of the frames, it would display the position corresponding to ;; that frame. ;; dbl-display-frame is invoked automatically when a filename-and-line-number ;; appears in the output. (require 'sshell) (require 'smart-complete) (define-key sshell-mode-map "\ep" 'smart-complete) (define-key sshell-mode-map "\M-p" 'smart-complete) (require 'gcl) (autoload 'maxima-mode "maxima-mode" "Major mode for editing maxima code and interacting with debugger" t) (autoload 'gcl-mode "gcl" "Major mode for editing maxima code and interacting with debugger" t) (or (rassoc 'maxima-mode auto-mode-alist) (setq auto-mode-alist (cons '("\\.ma?[cx]\\'" . maxima-mode) auto-mode-alist)) ) (or (rassoc 'gcl-mode auto-mode-alist) (setq auto-mode-alist (cons '("\\.li?sp\\'" . gcl-mode) auto-mode-alist)) ) (defvar dbl-prompt-pattern "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" ; "(^|\n)\\[^ >]*[>$)%#:][>]*[ ]*+" "A regexp to recognize the prompt for dbl or dbl+.") ; (defvar downcase-filenames-for-dbl (string-match "nt[45]" system-configuration) "Force the case to be lower when sending a break command" ) (defvar dbl-subshell-switches (list "bash" (if (string-match "nt[45]" system-configuration) '("--noediting" "-i") '("-i")) ) "Alternating list of regexp for the shell name, and list of switches to pass" ) (defvar dbl-filter-accumulator nil) (defvar dbl-mode-map nil "Keymap for dbl-mode.") (if dbl-mode-map nil (setq dbl-mode-map (copy-keymap sshell-mode-map)) (define-key dbl-mode-map "\C-cl" 'dbl-find-and-display-line) ) (define-key ctl-x-map " " 'dbl-break) ;(define-key ctl-x-map "&" 'send-dbl-command) ;;Of course you may use `def-dbl' with any other dbl command, including ;;user defined ones. (defmacro def-dbl (name key &optional doc) (let* ((fun (intern (format "dbl-%s" (read name)))) ) (list 'progn (list 'defun fun '(arg) (or doc "") '(interactive "p") (list 'dbl-call name 'arg)) (list 'define-key 'dbl-mode-map key (list 'quote fun))))) (def-dbl ":step %p" "\M-s" "Step one source line with display") (def-dbl ":step %p" "\C-c\C-s" "Step one source line with display") (def-dbl ":stepi %p" "\C-c\t" "Step one instruction with display") (def-dbl ":next %p" "\M-n" "Step one source line (skip functions)") (def-dbl ":next %p" "\C-c\C-n" "Step one source line (skip functions)") (def-dbl ":r" "\M-c" "Continue with display") (def-dbl ":finish" "\C-c\C-f" "Finish executing current function") (def-dbl ":up %p" "\C-cu" "Go up N stack frames (numeric arg) with display") (def-dbl ":down %p" "\C-cd" "Go down N stack frames (numeric arg) with display") (defun dbl-mode () "Major mode for interacting with an inferior Lisp or Maxima process. It is like an ordinary shell, except that it understands certain special redisplay commands sent by the process, such as redisplay a source file in the other window, positioning a little arrow `==>', at a certain line, typically the line where you are stopped in the debugger. It uses completion based on the form of your current prompt, allowing you to keep separate the commands you type at the debugger level and the lisp or maxima level. The source files should be viewed using gcl mode for lisp, and maxima-mode for maxima. \\{dbl-mode-map} \\[dbl-display-frame] displays in the other window the last line referred to in the dbl buffer. \\[dbl-:step] and \\[dbl-:next] in the dbl window, call dbl to step and next and then update the other window with the current file and position. o If you are in a source file, you may select a point to break at, by doing \\[dbl-break]. Commands: Many commands are inherited from shell mode. Additionally we have: \\[dbl-display-frame] display frames file in other window \\[dbl-:step] advance one line in program \\[dbl-:next] advance one line in program (skip over calls). \\[send-dbl-command] used for special printing of an arg at the current point. C-x SPACE sets break point at current line. You may also enter keyword break commands. :a show-break-variables :b simple-backtrace :bds break-bds :bl break-locals :blocks break-blocks :break insert a break point here :bs break-backward-search-stack :bt dbl-backtrace :c break-current :delete (lambda (&rest l) (iterate-over-bkpts l delete) (values)) :disable [n1 .. nk] disable break points. [see :info :bkpt] :down [n] move n frames down :enable [n1 n2 ..nk] enable break points :env describe-environment :fr [n] show this frame :fs break-forward-search-stack :functions break-functions :go break-go :h break-help :help break-help :ihs ihs-backtrace :info :bkpt show break points. :loc loc :m break-message :n break-next :next step-next :p break-previous :q break-quit :r resume :resume (lambda () resume) :s search-stack :step step-into :t throw-macsyma-top :up move up one frame :vs break-vs " (interactive) (kill-all-local-variables) (setq major-mode 'dbl-mode) (setq mode-name "Inferior Dbl") (setq mode-line-process '(": %s")) (use-local-map dbl-mode-map) (make-local-variable 'last-input-start) (setq last-input-start (make-marker)) (make-local-variable 'last-input-end) (setq last-input-end (make-marker)) (make-local-variable 'dbl-last-frame) (setq dbl-last-frame nil) (make-local-variable 'dbl-last-frame-displayed-p) (setq dbl-last-frame-displayed-p t) (make-local-variable 'dbl-delete-prompt-marker) (setq dbl-delete-prompt-marker nil) (make-local-variable 'dbl-filter-accumulator) (setq dbl-filter-accumulator nil) (make-local-variable 'shell-prompt-pattern) (setq shell-prompt-pattern dbl-prompt-pattern) (run-hooks 'sshell-mode-hook 'dbl-mode-hook)) (defvar current-dbl-buffer nil) (defvar dbl-command-name (if (file-exists-p "/bin/bash") "/bin/bash" "/bin/sh") "Pathname for executing dbl.") (defun dbl (p) "Makes a dbl buffer, suitable for running an inferior gcl. You are prompted for a name for the buffer. After the shell starts you should start up your lisp program (eg gcl). The bufferd has special keybindings for stepping and viewing sources. Enter the debug loop with (si::dbl) or :dbl in a debug loop. " (interactive "p") (let ( tem (dir default-directory) ;; important for winnt version of emacs (binary-process-input t) (binary-process-output nil) switches (name (concat "dbl" (if (equal p 1) "" p) "")) ) (switch-to-buffer (concat "*" name "*")) (or (bolp) (newline)) (insert "Current directory is " default-directory "\n") (let ((tem dbl-subshell-switches) switches) (while tem (cond ((string-match (car tem) dbl-command-name) (setq switches (nth 1 tem)) (setq tem nil)) (t (setq tem (nthcdr 2 tem))))) (apply 'make-sshell name dbl-command-name nil switches)) (dbl-mode) (make-local-variable 'sshell-prompt-pattern) (setq sshell-prompt-pattern dbl-prompt-pattern) (goto-char (point-min)) (insert " Welcome to DBL a Debugger for Lisp, Maxima, Gdb and others. You start your program as usually would in a shell. For Lisp and Maxima the debugger commands begin with a ':', and there is completion. Typing ':' should list all the commands. In GCL these are typed when in the debugger, and in Maxima they may be typed at any time. To see the wonderful benefits of this mode, type C-h m. Note you may also use this mode to run gdb. In fact I often debug MAXIMA over GCL using gdb, thus having three debuggers at once. To run gdb and enable the automatic line display, you must supply the `--fullname' keyword as in: gdb your-file --fullname ") (goto-char (point-max)) (set-process-filter (get-buffer-process (current-buffer)) 'dbl-filter) (set-process-sentinel (get-buffer-process (current-buffer)) 'dbl-sentinel) (dbl-set-buffer))) (defun dbl-set-buffer () (cond ((eq major-mode 'dbl-mode) (setq current-dbl-buffer (current-buffer))))) ;; This function is responsible for inserting output from DBL ;; into the buffer. ;; Aside from inserting the text, it notices and deletes ;; each filename-and-line-number; ;; that DBL prints to identify the selected frame. ;; It records the filename and line number, and maybe displays that file. (defun dbl-filter (proc string) (let ((inhibit-quit t)) (set-buffer (process-buffer proc)) (goto-char (point-max)) (insert string) (goto-char (point-max)) )) (defun dbl-filter (proc string) (let ((inhibit-quit t)) (if dbl-filter-accumulator (dbl-filter-accumulate-marker proc (concat dbl-filter-accumulator string)) (dbl-filter-scan-input proc string)) )) (defun dbl-filter-accumulate-marker (proc string) (setq dbl-filter-accumulator nil) (if (> (length string) 1) (if (= (aref string 1) ?\032) (let ((end (string-match "\n" string))) (if end (progn (setq me string) (cond ((string-match "\032\032\\([A-Za-z]?:?[^:]*\\):\\([0-9]*\\):[^\n]+\n" string) (setq dbl-last-frame (cons (match-string 1 string) (string-to-int (match-string 2 string)))) (cond ((equal (cdr dbl-last-frame) 0) ;(message "got 0") ;(sit-for 1) (setq overlay-arrow-position nil) (setq dbl-last-frame nil) ) (t (setq dbl-last-frame-displayed-p nil)) ))) (dbl-filter-scan-input proc (substring string (1+ end)))) (setq dbl-filter-accumulator string))) (dbl-filter-insert proc "\032") (dbl-filter-scan-input proc (substring string 1))) (setq dbl-filter-accumulator string))) (defun dbl-filter-scan-input (proc string) (if (equal string "") (setq dbl-filter-accumulator nil) (let ((start (string-match "\032" string))) (if start (progn ;; to do fix this so that if dbl-last-frame ;; changed, then set the current text property.. ;; (dbl-filter-insert proc (substring string 0 start)) (dbl-filter-accumulate-marker proc (substring string start)) ) (dbl-filter-insert proc string))))) (defun dbl-filter-insert (proc string) (let (moving output-after-point (old-buffer (current-buffer)) start) (set-buffer (process-buffer proc)) ;; test to see if we will move the point. We want that the ;; window-point of the buffer, should be equal to process-mark. (setq moving (>= (window-point (get-buffer-window (process-buffer proc))) (- (process-mark proc) 0))) (setq output-after-point (< (point) (process-mark proc))) (unwind-protect (save-excursion ;; Insert the text, moving the process-marker. (goto-char (process-mark proc)) (setq start (point)) (insert string) (set-marker (process-mark proc) (point)) ; (setq bill (cons (list 'hi (process-mark proc) (marker-position (process-mark proc)) (point)) bill)) (dbl-maybe-delete-prompt) ;; Check for a filename-and-line number. (dbl-display-frame ;; Don't display the specified file ;; unless (1) point is at or after the position where output appears ;; and (2) this buffer is on the screen. (or output-after-point (not (get-buffer-window (current-buffer)))) ;; Display a file only when a new filename-and-line-number appears. t) ) (if moving (set-window-point (get-buffer-window (process-buffer proc)) (process-mark proc))) (set-buffer old-buffer)) )) (defun dbl-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) ;; buffer killed ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) (set-process-buffer proc nil)) ((memq (process-status proc) '(signal exit)) ;; Stop displaying an arrow in a source file. (setq overlay-arrow-position nil) ;; Fix the mode line. (setq mode-line-process (concat ": " (symbol-name (process-status proc)))) (let* ((obuf (current-buffer))) ;; save-excursion isn't the right thing if ;; process-buffer is current-buffer (unwind-protect (progn ;; Write something in *compilation* and hack its mode line, (set-buffer (process-buffer proc)) ;; Force mode line redisplay soon (set-buffer-modified-p (buffer-modified-p)) (if (eobp) (insert ?\n mode-name " " msg) (save-excursion (goto-char (point-max)) (insert ?\n mode-name " " msg))) ;; If buffer and mode line will show that the process ;; is dead, we can delete it now. Otherwise it ;; will stay around until M-x list-processes. (delete-process proc)) ;; Restore old buffer, but don't restore old point ;; if obuf is the dbl buffer. (set-buffer obuf)))))) (defun dbl-refresh () "Fix up a possibly garbled display, and redraw the arrow." (interactive) (redraw-display) (dbl-display-frame)) (defun dbl-display-frame (&optional nodisplay noauto) "Find, obey and delete the last filename-and-line marker from DBL. The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. Obeying it means displaying in another window the specified file and line." (interactive) (dbl-set-buffer) (and dbl-last-frame (not nodisplay) (or (not dbl-last-frame-displayed-p) (not noauto)) (progn (dbl-display-line (car dbl-last-frame) (cdr dbl-last-frame)) (setq dbl-last-frame-displayed-p t)))) ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. ;; Put the overlay-arrow on the line LINE in that buffer. (defun dbl-find-file (file) (cond ((file-exists-p file) (find-file-noselect file)) ((get-buffer file)) (t (find-file-noselect file)))) (defvar dbl-dirs nil) (defun search-path (file dirs) (let ((paths (symbol-value dirs)) true-file) (cond ((file-exists-p file) (setq true-file file)) (t (while paths (let ((tem (expand-file-name file (or (car paths) default-directory)))) (if (file-exists-p tem) (setq true-file tem)) (setq paths (cdr paths)))))) (cond (true-file) (t (setq paths (symbol-value dirs)) (set dirs (append paths (list (file-name-directory (read-file-name (format "%s = %s, add path :" dirs paths)))))) (search-path file dirs))))) (defun dbl-find-line () "If the current buffer has a process, then look first for a file-line property, and if none, then search for a regexp. If a non process buffer, just return current file and line number. " (interactive) (save-excursion (end-of-line) (cond ((get-buffer-process (current-buffer)) (cond ((save-excursion (beginning-of-line) (get-text-property (point) 'file-line))) ((progn (end-of-line) (re-search-backward " \\([^: ]+\\):\\([0-9]+\\)" 300 nil)) (setq file (buffer-substring (match-beginning 1) (match-end 1))) (setq line (buffer-substring (match-beginning 2) (match-end 2))) (setq line (read line)) (and (integerp line) (setq file (search-path file 'dbl-dirs)) (list file line))))) (t (list (buffer-file-name) (+ 1 (count-lines (point)))))))) (defun dbl-find-and-display-line () (interactive) (let ((res (dbl-find-line))) (and res (apply 'dbl-display-line res)))) (defun dbl-display-line (true-file line) (let* ((buffer (dbl-find-file true-file)) (window (display-buffer buffer t)) (pos)) (save-excursion (set-buffer buffer) (save-restriction (widen) (goto-line line) (setq pos (point)) (setq overlay-arrow-string "=>") (or overlay-arrow-position (setq overlay-arrow-position (make-marker))) (set-marker overlay-arrow-position (point) (current-buffer))) (cond ((or (< pos (point-min)) (> pos (point-max))) (widen) (goto-char pos)))) (set-window-point window overlay-arrow-position))) (defvar dbl-gdb-command-alist '((":step %p" . "step %p") (":next %p" . "next %p") (":stepi" . "stepi %p") (":r" . "r") (":finish" . "finish") (":up %p" . "up %p") ( ":down %p" . "down %p"))) (defun dbl-call (command numeric) "Invoke dbl COMMAND displaying source in other window." (interactive) (save-excursion (goto-char (point-max)) (beginning-of-line) (let (com) (cond ((or (looking-at "(gdb") (member major-mode '(c-mode c++-mode))) (if (setq com (assoc command dbl-gdb-command-alist)) (setq command (cdr com)))))) ;; to do put in hook here to recognize whether at ;; maxima or lisp level. (setq command (dbl-subtitute-% command numeric)) (goto-char (point-max)) (setq dbl-delete-prompt-marker (point-marker)) (dbl-set-buffer) (send-string (get-buffer-process current-dbl-buffer) (concat command "\n")))) (defun dbl-subtitute-% (command n) (let* (result (in-dbl (get-buffer-process (current-buffer))) file-line ) (cond ((string-match "%[fl]" command) (cond (in-dbl (setq file-line (dbl-find-line))) (t (setq file-line (list (buffer-file-name) (+ 1 (count-lines (point))))))))) (while (and command (string-match "\\([^%]*\\)%\\([adeflp]\\)" command)) (let ((letter (string-to-char (substring command (match-beginning 2)))) subst) (cond ((eq letter ?p) (setq subst (if n (int-to-string n) ""))) ((eq letter ?f) (setq subst (or (car file-line) "unknown-file"))) ((eq letter ?l) (setq subst (if (cadr file-line) (int-to-string (cadr file-line)) "unknown-line"))) ((eq letter ?a) (setq subst (dbl-read-address)))) (setq result (concat result (substring command (match-beginning 1) (match-end 1)) subst))) (setq command (substring command (match-end 2)))) (concat result command))) (defun dbl-maybe-delete-prompt () (if (and dbl-delete-prompt-marker (> (point-max) (marker-position dbl-delete-prompt-marker))) (let (start) (goto-char dbl-delete-prompt-marker) (setq start (point)) (beginning-of-line) (delete-region (point) start) (setq dbl-delete-prompt-marker nil)))) (defun dbl-break () "Set DBL breakpoint at this source line." (interactive) (cond ((eq major-mode 'lisp-mode) (save-excursion (end-of-line) (let (name at where) (setq where (point)) (mark-defun) (search-forward "(def") (forward-sexp 2) (setq at (point)) (forward-sexp -1) (setq name (buffer-substring (point) at)) (beginning-of-line) (setq name (format "(si::break-function '%s %s t)" name (count-lines 1 where))) (other-window 1) (if (get-buffer-process (current-buffer)) (setq current-dbl-buffer (current-buffer))) (message name) (send-string (get-buffer-process current-dbl-buffer) (concat name "\n")) (other-window 1) ))) (t (let ((file-name (file-name-nondirectory buffer-file-name)) (line (save-restriction (widen) (1+ (count-lines 1 (point)))))) (and downcase-filenames-for-dbl (setq file-name (downcase file-name))) (send-string (get-buffer-process current-dbl-buffer) (concat "break " file-name ":" line "\n")))))) (defun dbl-read-address() "Return a string containing the core-address found in the buffer at point." (save-excursion (let ((pt (dot)) found begin) (setq found (if (search-backward "0x" (- pt 7) t)(dot))) (cond (found (forward-char 2)(setq result (buffer-substring found (progn (re-search-forward "[^0-9a-f]") (forward-char -1) (dot))))) (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) (dot))) (forward-char 1) (re-search-forward "[^0-9]") (forward-char -1) (buffer-substring begin (dot))))))) (defvar dbl-commands nil "List of strings or functions used by send-dbl-command. It is for customization by you.") (defun send-dbl-command (arg) "This command reads the number where the cursor is positioned. It then inserts this ADDR at the end of the dbl buffer. A numeric arg selects the ARG'th member COMMAND of the list dbl-print-command. If COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\" is a possible string to be a member of dbl-commands. " (interactive "P") (let (comm addr) (if arg (setq comm (nth arg dbl-commands))) (setq addr (dbl-read-address)) (if (eq (current-buffer) current-dbl-buffer) (set-mark (point))) (cond (comm (setq comm (if (stringp comm) (format comm addr) (funcall comm addr)))) (t (setq comm addr))) (switch-to-buffer current-dbl-buffer) (goto-char (dot-max)) (insert-string comm))) (provide 'dbl) gcl-2.6.14/elisp/makefile0000644000175000017500000000142614360276512013612 0ustar cammcamm -include ../makedefs install: mkdir -p $(DESTDIR)$(EMACS_SITE_LISP) cp *.el $(DESTDIR)$(EMACS_SITE_LISP) if [ "$(EMACS_DEFAULT_EL)" != "" ] ; then \ if test -f "$(DESTDIR)${EMACS_DEFAULT_EL}" ; then \ cat $(DESTDIR)${EMACS_DEFAULT_EL} | sed -e '/BEGIN gcl/,/END gcl/d' > $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; \ mv $(DESTDIR)${EMACS_DEFAULT_EL} $(DESTDIR)${EMACS_DEFAULT_EL}.prev ; \ rm -f $(DESTDIR)${EMACS_DEFAULT_EL}c ; \ cat add-default.el >> $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; cp $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default $(DESTDIR)${EMACS_DEFAULT_EL} ; \ rm -f $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; else \ cp add-default.el $(DESTDIR)${EMACS_DEFAULT_EL} ; fi ; \ chmod a+r $(DESTDIR)${EMACS_DEFAULT_EL} ; fi gcl-2.6.14/elisp/ansi-doc.el0000755000175000017500000000610714360276512014135 0ustar cammcamm;; Copyright William F. Schelter. 1994 ;; Licensed by GNU public license. ;; This file contains function find-ansi-doc which finds documentation in the ;; standard common lisp ansi documentation (1350 pages!), and puts it on ;; the screen at the correct page using xdvi. If there is more than one ;; reference it successively finds them. You need dpANS2/*.dvi ;; dpANS2/index.idx from parcftp.xerox.com (13.1.64.94) You also need ;; xdvi. You may gzip the .dvi files and it will unzip them into tmp ;; as needed. (defvar ansi-doc-dir "/usr/local/doc/dpANS2") (defvar ansi-doc-alist nil) (defun create-index-el-from-index-idx () (interactive) (let (tem) (cond ((not ansi-doc-alist) (setq tem (concat ansi-doc-dir "/index.el")) (or (file-exists-p tem) (progn (shell-command (concat "echo '(setq ansi-doc-alist (quote (( ' > " tem)) (shell-command (concat "cat " ansi-doc-dir "/index.idx " "| sed " " -e 's/\\!9\\([A-Z]\\):\\([^\\!]*\\)\\!\\!/)(\"\\2\" \\1/g' " " -e 's:{$\\\\spLT \\$}:<:g' " " -e 's:{$\\\\spGT $}:>:g' " " -e 's:\\\\&:\\&:g' " " -e 's:\\([0-9]\\),:\\1:g'" " -e 's:\\([A0-9][0-9]*\\)--\\([0-9][0-9]*\\):(\\1 . \\2):g'" " | sort -r " " >> " tem)) (shell-command (concat "echo '))))' >> " tem)))) )))) (defun maybe-gzip-to-tmp (file &optional dir) "If file exists with .gz added to it, then unzip it to /tmp and return that file otherwise return file" (let (tmp-file) (cond ((file-exists-p (concat file ".gz")) (setq tmp-file (file-name-nondirectory file)) (or (file-exists-p tmp-file) (progn (message "gzipping %s in /tmp for future use" file) (shell-command (concat "gzip -dc < " file ".gz > " tmp-file )))) tmp-file) (t file)))) (defun find-ansi-doc () "Find the documentation in the ansi draft on a particular function or topic. If there are several pieces of documentation then go through them successively. Requires copying the " (interactive ) (let (x tem name lis first chap tmp-chap) (or ansi-doc-alist (progn (create-index-el-from-index-idx ) (load (concat ansi-doc-dir "/index.el")))) (setq name (completing-read "Doc on: " ansi-doc-alist nil t)) (progn (setq ans nil) (setq lis ansi-doc-alist) (while lis (cond ((equal (car (car lis)) name) (setq ans (append ans (cdr (cdr (car lis))))))) (setq lis (cdr lis))) ) (setq tem ans) (if (cdr tem) (setq first "First") (setq first "")) (while tem (setq x (car tem)) (setq chap (concat ansi-doc-dir (downcase (format "/chap-%s.dvi" (car x))))) (setq chap (maybe-gzip-to-tmp chap)) (message "%s Doc in Chapter %s page %s) %s .." first (car x) (cdr x)) (if (cdr tem) (setq first "Next") (setq next "Final")) (shell-command (concat "xdvi -expert -xoffset .2 -yoffset -.2 " " -paper 7.2x8.5 " " -display " (or x-display-name ":0") " -geometry -2-2 +" (+ (cdr x) 2)" " chap )) (setq tem (cdr tem)) ) ) (message nil) ) gcl-2.6.14/elisp/doc-to-texi.el0000755000175000017500000001032014360276512014564 0ustar cammcamm (load "../gcl-tk/convert.el") ;(let ((i 2000)) (while (> i 0) (do-one) (setq i (- i 1)))) (defun get-match (i) (buffer-substring (match-beginning i) (match-end i))) (defun list-matches (l) (let (ans) (while l (setq ans (cons (get-match (car l)) ans))) (nreverse ans))) (defun do-one () (interactive) () (beginning-of-line) (re-search-forward "" nil t) (let ((beg (point)) def (end (save-excursion (re-search-forward "" nil t) (point)))) (cond ((looking-at "F\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package[:]?[\n ]\\(Args\\|Syntax\\): ") (let ((fun (get-match 1)) (type (get-match 2)) (package (get-match 3)) args body) (goto-char (match-end 0)) (cond ((equal (get-match 4) "Syntax") (setq args "") (beginning-of-line)) (t (setq args (progn (let ((beg (point))) (forward-sexp 1) (buffer-substring beg (point))))))) (setq body (buffer-substring (point) (- end 1))) (delete-region beg end ) (save-excursion (get-buffer-create package) (set-buffer package) (goto-char (point-max)) (insert (if (equal type "Function") (setq def "@defun") (concat (setq def "@deffn") " {" type "}")) " " fun " " args "\nPackage:" package "\n" body) (insert "\n@end " (substring def 1) "\n") ))) ((looking-at "V\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package:\n") (let ((fun (get-match 1)) (type (get-match 2)) (package (get-match 3)) args body) (goto-char (match-end 0)) (setq body (buffer-substring (point) (- end 1))) (delete-region beg end ) (save-excursion (get-buffer-create package) (set-buffer package) (goto-char (point-max)) (insert (if (string-match "^\\*" fun) (setq def "@defvar") (concat (setq def "@defvr")" {Constant}")) " " fun " " "\nPackage:" package "\n" body ) (insert "\n@end " (substring def 1) "\n"))))))) (defun do-some () (interactive) (while (re-search-forward "{Constant}" nil t) (let* ((tem (read-char )) (u (cdr (assoc tem '((?s . "{Special Variable}") (?d . "{Declaration}")))))) (if u (replace-match u))))) (setq b-alist '((?n . "number.texi") (?s . "sequence.texi") (?c . "character.texi") (?l . "list.texi") (?i . "io.texi") (?a . "internal.texi") (?f . "form.texi") (?C . "compile.texi") (?S . "symbol.texi") (?t . "system.texi") (?d . "structure.texi") (?I . "iteration.texi") (?u . "user-interface.texi") (?d . "doc.texi") (?b . "type.texi") )) (defun try1 () (interactive) (while (re-search-forward "\n@def" nil t) (let ((beg (match-beginning 0)) me tem (end (save-excursion (re-search-forward "\n@end def[a-z]+" nil t) (point)))) (sit-for 0 300) (setq tem (read-char )) (cond ((setq tem (cdr (assoc tem b-alist))) (setq me (buffer-substring beg end)) (delete-region beg end) (forward-char -2) (save-excursion (get-buffer-create tem) (set-buffer tem) (goto-char (point-max)) (insert me "\n"))))))) (setq xall (mapcar 'cdr b-alist)) ;(let ((all xall)) (while all (set-buffer (car all)) (write-file (car all)) (setq all (cdr all)))) ;(let ((all xall)) (while all (find-file (car all)) (setq all (cdr all)))) (let ((all xall) x) (while all (set-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (write-file (car all)) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) (let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) (let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) gcl-2.6.14/elisp/man1-to-texi.el0000755000175000017500000003311614360276512014663 0ustar cammcamm;;;;if you are in a buffer which has a man page you can try ;; M-x doit, to do an at least partial conversion of tcl tk man pages to ;; texinfo ;; file for converting the tcl/tk man pages to texinfo and suitable for gcl/tk ; .bp begin new page ; .br break output line here ; .sp n insert n spacing lines ; .ls n (line spacing) n=1 single, n=2 double space ; .na no alignment of right margin ; .ce n center next n lines ; .ul n underline next n lines ; .sz +n add n to point size ; ; Requests ; Request Cause If no Explanation ; Break Argument ; ; .B t no t=n.t.l.* Text is in bold font. ; .BI t no t=n.t.l. Join words, alternating bold ; and italic. ; .BR t no t=n.t.l. Join words, alternating bold ; and roman. ; .DT no .5i 1i... Restore default tabs. ; .HP i yes i=p.i.* Begin paragraph with hanging ; indent. Set prevailing indent to i. ; .I t no t=n.t.l. Text is italic. ; .IB t no t=n.t.l. Join words, alternating italic ; and bold. ; ; .IP x i yes x="" Same as .TP with tag x. ; .IR t no t=n.t.l. Join words, alternating italic ; and roman. ; .IX t no - Index macro, for Sun internal ; use. ; .LP yes - Begin left-aligned paragraph. ; Set prevailing indent to .5i. ; .PD d no d=.4v Set vertical distance between ; paragraphs. ; .PP yes - Same as .LP. ; .RE yes - End of relative indent. ; Restores prevailing indent. ; .RB t no t=n.t.l. Join words, alternating roman ; and bold. ; .RI t no t=n.t.l. Join words, alternating roman ; and italic. ; .RS i yes i=p.i. Start relative indent, ; increase indent by i. Sets prevailing indent to ; .5i for nested indents. ; .SB t no - Reduce size of text by 1 ; point, make text boldface. ; .SH t yes - Section Heading. ; .SM t no t=n.t.l. Reduce size of text by 1 ; point. ; .SS t yes t=n.t.l. Section Subheading. ; .TH n s d f m ; yes - Begin reference page n, of ; section s; d is the date of the most ; recent change. If present, f ; is the left page footer; m is the ; main page (center) header. ; Sets prevailing indent and tabs to .5i. ; .TP i yes i=p.i. Begin indented paragraph, with ; the tag given on the next text ; line. Set prevailing indent ; to i. ; ; .TX t p no - Resolve the title abbreviation ; t; join to punctuation mark (or text) p. * ; n.t.l. = next text line; p.i. = prevailing ; indent ; .HS name section [date [version]] ; Replacement for .TH in other man pages. See below for valid ; section names. ; ; .AP type name in/out [indent] ; Start paragraph describing an argument to a library procedure. ; type is type of argument (int, etc.), in/out is either "in", "out", ; or "in/out" to describe whether procedure reads or modifies arg, ; and indent is equivalent to second arg of .IP (shouldn't ever be ; needed; use .AS below instead) ; ; .AS [type [name]] ; Give maximum sizes of arguments for setting tab stops. Type and ; name are examples of largest possible arguments that will be passed ; to .AP later. If args are omitted, default tab stops are used. ; ; .BS ; Start box enclosure. From here until next .BE, everything will be ; enclosed in one large box. ; ; .BE ; End of box enclosure. ; ; .VS ; Begin vertical sidebar, for use in marking newly-changed parts ; of man pages. ; ; .VE ; End of vertical sidebar. ; ; .DS ; Begin an indented unfilled display. ; ; .DE ; End of indented unfilled display. ; (defun do-replace (lis &optional not-in-string) (let (x case-fold-search) (while lis (setq x (car lis)) (setq lis (cdr lis)) (goto-char (point-min)) (message "doing %s " x) (while (re-search-forward (nth 0 x) nil t) (and not-in-string (progn (forward-char -1) (not (in-a-string)))) (let ((f (nth 1 x))) (cond ((stringp f) (replace-match f t)) (t (let ((i 0) ans) (while (match-beginning i) (setq ans (cons (buffer-substring (match-beginning i) (match-end i)) ans)) (setq i (+ i 1))) (setq ans (nreverse ans)) (goto-char (match-beginning 0)) (delete-region (match-beginning 0) (match-end 0)) (apply f ans))))))))) (defun doit () (interactive) (texinfo-mode) (goto-char (point-min)) (do-replace '(("@" "@@") ("^[.]VS\n" "") ("^[.]VE\n" "") )) (goto-char (point-min)) (insert "@setfilename foo.info") (insert "\n") (do-tables) ; (do-nf) (do-replace '( (".SH \"SEE ALSO\"\n\\([^\n]*\\)" "@xref{\\1}") ("^[.]SH NAME" "") ("^'[\\]\"[^\n]*\n" "") ("^'[/]\"[^\n]*\n" "") ("^[.]so[^\n]+\n" "") ("[.]HS \\([^ \n]+\\)\\([^\n]*\\)\n" "@node \\1\n@subsection \\1\n") ("^[.]VS\n" "") ("^[.]VE\n" "") (".nf\nName:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n.fi\n" do-keyword) ("Name:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n" do-keyword) ("Name:\t\\([^\n]*\\)\n" "@*@w{ Name: @code{\\1}}\n") ("Class:\t\\([^\n]*\\)\n" "@*@w{ Class: @code{\\1}}\n") ("Command-Line Switch:\t\\([^\n]*\\)\n" "@*@w{ Keyword: @code{\\1}}\n") ("[\\]-\\([a-z]\\)" ":\\1") ("^[.]nf\n" "@example\n") ("^[.]fi\n" "@end example\n") ("^[.]ta[^\n]*\n" do-ta) ("^[.]IP\n" "\n") ("[\\]f\\([A-Z]\\)\\([^\\\n]*\\)[\\]f" do-font) ("^\\([^\n]+\\)\n[.]br" "@*@w{\\1}@*") ("^[.]SH \\([^\n]*\\)" (lambda (a0 a1) (insert "@unnumberedsubsec " (capitalize a1)))) ("[\\]fR" "") ("^[.]BS" "@cartouche") ("^[.]BE" "@end cartouche") ("^[.]sp \\([0-9]\\)" "@sp \\1") ("^[.]sp" "@sp 1") ("^[.]LP\n" "\n\n") ("^[.][LP]P" "") ("^[.]DS[^\n]*\n" "\n@example\n") ("^[.]DE[^\n]*\n" "@end example\n\n") ("^[.]DS[^\n]*\n" "\n@example\n") ("^[.]DE[^\n]*\n" "@end example\n\n") ("^[.]RS\n" "") ; relative indent increased.. ("^[.]rE\n" "") ("^[\\]&\\([^\n]*\\)\n" "@*@w{ \\1}\n") ; ("Command-Line Switch" "Keyword") ("pathName }@b{\\([a-z]\\)" "pathName }@b{:\\1") ("[\\]0" " ") ("%\\([a-z#]\\)\\([^a-zA-Z0-9%]\\)" "|%\\1|\\2") ("^[.]TP[^\n]*\n" "@item ") )) (add-keywords) ) (defun do-font (ign a b) (let ((ch (assoc (aref a 0) '((?R . "@r{") (?I . "@i{") (?B . "@b{"))))) (cond (ch (insert (cdr ch) b "}\\f") (forward-char -2) ) (t (error "unknown leter %s" a))))) (defun do-keyword (ign name class key) (insert "@table \n@item @code{"key "}" "\n@flushright\nName=@code{\""name"\"} Class=@code{\""class "\"}\n" "@end flushright\n@sp 1\n") (save-excursion (cond ((re-search-forward "[.]LP\\|[.]BE\\|[.]SH" nil t) (beginning-of-line) (insert "@end table\n"))))) (defun try () (interactive) (if (get-buffer "foo.texi") (kill-buffer (get-buffer "foo.texi"))) (if (get-buffer "foo.info") (kill-buffer (get-buffer "foo.info"))) (find-file "foo.n") (toggle-read-only 0) (doit) (write-file "foo.texi") (makeinfo-buffer )) (defun foo () (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) (list (match-beginning 0) (match-beginning 1) (match-beginning 2))) (defun list-current-line () (beginning-of-line) (let (ans at-end (beg (point))) (save-excursion (while (not at-end) (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) (if (match-beginning 1) (replace-match "") (setq at-end t)))) (setq at-end nil) (beginning-of-line) (while (not at-end) (re-search-forward "[\t\n]" nil t) (let ((x (buffer-substring beg (- (point) 1)))) (or (equal x "") (setq ans (cons x ans)))) (setq beg (point)) (setq at-end (equal (char-after (- (point) 1)) ?\n))) (nreverse ans) )) (defun do-ta (a0) (let ((beg (point)) items (vec (make-vector 10 0)) i (tot 0) surplus) (while (not (looking-at "[.][LDI]")) (cond ((looking-at "[.]")(forward-line 1)) (t (setq items (cons (list-current-line) items)) (let ((tem (car items)) (i 0)) (while tem (aset vec i (max (real-length (car tem)) (aref vec i))) (setq i (+ i 1)) (setq tem (cdr tem))) )))) ; (message "%s" (list beg (point))) ; (sit-for 1) (delete-region beg (point)) ; (forward-line -2) ; (message "%s" vec) ; (sit-for 2) (setq items (nreverse items)) (setq i 0) (while (< i (length vec)) (setq tot (+ (aref vec i) tot)) (setq i (+ i 1))) (setq surplus (/ (- 70 tot) (+ 1 (length (car items))))) (while items (setq tem (car items)) (setq i 0) (let (ans x) (insert "") (while tem (insert (tex-center (car tem) (+ (aref vec i) surplus) 'left (real-length (car tem)))) (setq tem (cdr tem)) (setq i (+ i 1))) (insert "\n")) (setq items (cdr items))) ) ) (defun real-length (item) (let* ((n (length item)) (m (- n 1)) (start 0)) (while (setq start (string-match "[\\]f" item start)) (setq n (- n 3)) (if (< start m) (setq start (+ start 1)))) n)) (defun do-tables () (goto-char (point-min)) (while (re-search-forward "^[.]TP" nil t) (beginning-of-line) (insert "\n@table @asis\n") (forward-line 2) (re-search-forward "^[.]\\(LP\\|BE\\|SH\\)" nil t) (beginning-of-line) (insert "@end table\n") )) (defun do-nf () (goto-char (point-min)) (while (re-search-forward "^[.]nf" nil t) (forward-line 1) (beginning-of-line) (while (not (looking-at "[.]fi")) (insert "@w{" ) (end-of-line) (insert "}") (forward-line 1) (beginning-of-line)))) (defun add-keywords () (let ((tem tk-control-options)x lis l y) (while tem (setq l (car tem)) (setq tem (cdr tem)) (setq x (symbol-name (car l ))) (setq lis (car (cdr l))) (while lis (cond ((atom lis) (setq lis nil)) (t (setq y (symbol-name (car lis))) (do-replace (list (list (concat x " "y "") (concat x " :"y "") ))))) (setq lis (cdr lis)))))) (setq tk-control-options '((after fixnum) (exit fixnum) (lower window) (place pathName (-anchor -bordermode -height -in -relheight -relwidth -relx -rely -width -x -y)) (send interpreter ) ;(TKVARS "invalid command name \"tkvars\"") (winfo (atom atomname cells children class containing depth exists fpixels geometry height id interps ismapped name parent pathname pixels reqheight reqwidth rgb rootx rooty screen screencells screendepth screenheight screenmmheight screenmmwidth screenvisual screenwidth toplevel visual vrootheight vrootwidth vrootx vrooty width x y) ) (focus (default none) ) (option (add clear get readfile)) (raise pathname) (tk colormodel) (tkwait ( variable visible window) ) (wm (aspect client command deiconify focusmodel frame geometry grid group iconbitmap iconify iconmask iconname iconposition iconwindow maxsize minsize overrideredirect positionfrom protocol sizefrom state title trace transient withdraw)) (destroy window) (grab (current release set status)) (pack window (-after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, -side) argggg) (selection (clear get handle own)) (tkerror "") (update (idletasks)) )) (setq tk-widget-options '( (button (activate configure deactivate flash invoke)) (listbox ( configure curselection delete get insert nearest scan select size xview yview)) (scale ( configure get set)) (canvas ( addtag bbox bind canvasx canvasy configure coords create dchars delete dtag find focus gettags icursor index insert itemconfigure lower move postscript raise scale scan select type xview yview)) (menu ( activate add configure delete disable enable entryconfigure index invoke post unpost yposition)) (scrollbar ( configure get set)) (checkbutton ( activate configure deactivate deselect flash invoke select toggle)) (menubutton ( activate configure deactivate)) (text ( compare configure debug delete get index insert mark scan tag yview)) (entry ( configure delete get icursor index insert scan select view)) (message ( configure)) (frame ( configure)) (label ( configure)) (radiobutton ( activate configure deactivate deselect flash invoke select)) (toplevel ( configure)) )) (setq manual-sections '(after bind button canvas checkbutton destroy entry exit focus foo frame grab label lbSingSel listbox lower menu menubar menubutton message option options pack-old pack place radiobutton raise scale scrollbar selection send text tk tkerror tkvars tkwait toplevel update winfo wm)) ;(setq widgets (sort (mapcar 'car tk-widget-options) 'string-lessp)) ;(let ((m manual-sections)(tem widgets)) (while tem (setq manual-sections (delete (car tem) manual-sections))(setq tem (cdr tem)))) gcl-2.6.14/elisp/readme0000755000175000017500000000035414360276512013274 0ustar cammcamm dbl.el: mode for source level debugging lisp much like the authors gdb.el gcl.el: mode for interacting with gcl sshell.el: old fashioned shell mode, used by dbl.el. lisp-complete.el: a history mechanism based on the prompt. gcl-2.6.14/elisp/sshell.el0000755000175000017500000003200314360276512013724 0ustar cammcamm ;; Run subshell under Emacs ;; Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. ;; Modifications by William Schelter ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; The following is a "simple shell" much like the one in version 18 ;; of emacs. Unfortunately cmint breaks most code which tries to use ;; the shell mode, and is rather complex. ;; This mode uses a better completion mechanism (smart-complete.el), ;; in that it should ;; find the input you really want with your typing less keystrokes, ;; and easier keystrokes to type (defvar last-input-start nil "In a sshell-mode buffer, marker for start of last unit of input.") (defvar last-input-end nil "In a sshell-mode buffer, marker for end of last unit of input.") (defvar sshell-mode-map nil) (defvar sshell-directory-stack nil "List of directories saved by pushd in this buffer's sshell.") (defvar sshell-popd-regexp "popd" "*Regexp to match subsshell commands equivalent to popd.") (defvar sshell-pushd-regexp "pushd" "*Regexp to match subsshell commands equivalent to pushd.") (defvar sshell-cd-regexp "cd" "*Regexp to match subsshell commands equivalent to cd.") (defvar explicit-sshell-file-name nil "*If non-nil, is file name to use for explicitly requested inferior sshell.") ;In loaddefs.el now. (defconst sshell-prompt-pattern "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" "*Regexp used by Newline command to match subsshell prompts. Anything from beginning of line up to the end of what this pattern matches is deemed to be prompt, and is not reexecuted.") (defun sshell-mode () "Major mode for interacting with an inferior sshell. Sshell name is same as buffer name, sans the asterisks. Return at end of buffer sends line as input. Return not at end copies rest of line to end and sends it. The following commands imitate the usual Unix interrupt and editing control characters: \\{sshell-mode-map} Entry to this mode calls the value of sshell-mode-hook with no args, if that value is non-nil. cd, pushd and popd commands given to the sshell are watched by Emacs to keep this buffer's default directory the same as the sshell's working directory. Variables sshell-cd-regexp, sshell-pushd-regexp and sshell-popd-regexp are used to match these command names. You can send text to the sshell (or its subjobs) from other buffers using the commands process-send-region, process-send-string and lisp-send-defun." (interactive) (kill-all-local-variables) (setq major-mode 'sshell-mode) (setq mode-name "Sshell") (setq mode-line-process '(": %s")) (use-local-map sshell-mode-map) (make-local-variable 'sshell-directory-stack) (setq sshell-directory-stack nil) (make-local-variable 'last-input-start) (setq last-input-start (make-marker)) (make-local-variable 'last-input-end) (setq last-input-end (make-marker)) (run-hooks 'sshell-mode-hook)) (if sshell-mode-map nil (setq sshell-mode-map (make-sparse-keymap)) (define-key sshell-mode-map "\t" 'sshell-complete-filename) (define-key sshell-mode-map "\C-m" 'sshell-send-input) (define-key sshell-mode-map "\C-c\C-d" 'sshell-send-eof) (define-key sshell-mode-map "\C-c\C-u" 'kill-sshell-input) (define-key sshell-mode-map "\C-c\C-w" 'backward-kill-word) (define-key sshell-mode-map "\C-c\C-c" 'interrupt-sshell-subjob) (define-key sshell-mode-map "\C-c\C-z" 'stop-sshell-subjob) (define-key sshell-mode-map "\C-c\C-\\" 'quit-sshell-subjob) (define-key sshell-mode-map "\C-c\C-o" 'kill-output-from-sshell) (define-key sshell-mode-map "\C-c\C-r" 'show-output-from-sshell) (define-key sshell-mode-map "\C-c\C-y" 'copy-last-sshell-input)) (defun sshell-complete-filename () (interactive) (let* ((p (point)) tem beg (ff (save-excursion (skip-chars-backward "[a-z---_0-9$/A-Z~#.]") (buffer-substring (setq beg (point)) p)))) (setq dir (or (file-name-directory ff) default-directory)) (setq file (file-name-nondirectory ff)) (cond ((and (setq tem (file-name-completion (or file "") dir)) (not (equal tem file))) (cond ((eq tem t)) (t (delete-region beg p) (insert (concat dir tem))))) (t (let ((lis (file-name-all-completions file dir))) (with-output-to-temp-buffer "*completions*" (display-completion-list lis)) ))))) (defvar explicit-csh-args (if (eq system-type 'hpux) ;; -T persuades HP's csh not to think it is smarter ;; than us about what terminal modes to use. '("-i" "-T") '("-i")) "Args passed to inferior sshell by M-x sshell, if the sshell is csh. Value is a list of strings, which may be nil.") (defun sshell () "Run an inferior sshell, with I/O through buffer *sshell*. If buffer exists but sshell process is not running, make new sshell. Program used comes from variable explicit-sshell-file-name, or (if that is nil) from the ESHELL environment variable, or else from SHELL if there is no ESHELL. If a file ~/.emacs_SHELLNAME exists, it is given as initial input (Note that this may lose due to a timing error if the sshell discards input when it starts up.) The buffer is put in sshell-mode, giving commands for sending input and controlling the subjobs of the sshell. See sshell-mode. See also variable sshell-prompt-pattern. The sshell file name (sans directories) is used to make a symbol name such as `explicit-csh-arguments'. If that symbol is a variable, its value is used as a list of arguments when invoking the sshell. Otherwise, one argument `-i' is passed to the sshell. Note that many people's .cshrc files unconditionally clear the prompt. If yours does, you will probably want to change it." (interactive) (let* ((prog (or explicit-sshell-file-name (getenv "ESHELL") (getenv "SHELL") "/bin/sh")) (name (file-name-nondirectory prog))) (switch-to-buffer (apply 'make-sshell "shell" prog (if (file-exists-p (concat "~/.emacs_" name)) (concat "~/.emacs_" name)) (let ((symbol (intern-soft (concat "explicit-" name "-args")))) (if (and symbol (boundp symbol)) (symbol-value symbol) '("-i"))))))) (defun make-sshell (name program &optional startfile &rest switches) (let ((buffer (get-buffer-create (concat "*" name "*"))) proc status size) (setq proc (get-buffer-process buffer)) (if proc (setq status (process-status proc))) (save-excursion (set-buffer buffer) ;; (setq size (buffer-size)) (if (memq status '(run stop)) nil (if proc (delete-process proc)) (setq proc (apply 'start-process name buffer (or program explicit-sshell-file-name (getenv "ESHELL") (getenv "SHELL") "/bin/sh") switches)) (cond (startfile ;;This is guaranteed to wait long enough ;;but has bad results if the sshell does not prompt at all ;; (while (= size (buffer-size)) ;; (sleep-for 1)) ;;I hope 1 second is enough! (sleep-for 1) (goto-char (point-max)) (insert-file-contents startfile) (setq startfile (buffer-substring (point) (point-max))) (delete-region (point) (point-max)) (process-send-string proc startfile))) (setq name (process-name proc))) (goto-char (point-max)) (set-marker (process-mark proc) (point)) (sshell-mode)) buffer)) (defvar sshell-set-directory-error-hook 'ignore "Function called with no arguments when sshell-send-input recognizes a change-directory command but gets an error trying to change Emacs's default directory.") (defun sshell-send-input () "Send input to subsshell. At end of buffer, sends all text after last output as input to the subsshell, including a newline inserted at the end. When not at end, copies current line to the end of the buffer and sends it, after first attempting to discard any prompt at the beginning of the line by matching the regexp that is the value of sshell-prompt-pattern if possible. This regexp should start with \"^\"." (interactive) (or (get-buffer-process (current-buffer)) (error "Current buffer has no process")) (end-of-line) (if (eobp) (progn (move-marker last-input-start (process-mark (get-buffer-process (current-buffer)))) (insert ?\n) (move-marker last-input-end (point))) (beginning-of-line) ;; Exclude the sshell prompt, if any. (re-search-forward sshell-prompt-pattern (save-excursion (end-of-line) (point)) t) (let ((copy (buffer-substring (point) (progn (forward-line 1) (point))))) (goto-char (point-max)) (move-marker last-input-start (point)) (insert copy) (move-marker last-input-end (point)))) ;; Even if we get an error trying to hack the working directory, ;; still send the input to the subsshell. (condition-case () (save-excursion (goto-char last-input-start) (sshell-set-directory)) (error (funcall sshell-set-directory-error-hook))) (let ((process (get-buffer-process (current-buffer))) (s (buffer-substring last-input-start last-input-end)) ) ;; avoid sending emacs's idea of what an international character ;; set string is to a subprocess.. (if (fboundp 'string-make-unibyte) (setq s (string-make-unibyte s))) (process-send-string process s) (set-marker (process-mark process) (point)))) ;;; If this code changes (sshell-send-input and sshell-set-directory), ;;; the customization tutorial in ;;; info/customizing-tutorial must also change, since it explains this ;;; code. Please let marick@gswd-vms.arpa know of any changes you ;;; make. (defun sshell-set-directory () (cond ((and (looking-at sshell-popd-regexp) (memq (char-after (match-end 0)) '(?\; ?\n))) (if sshell-directory-stack (progn (cd (car sshell-directory-stack)) (setq sshell-directory-stack (cdr sshell-directory-stack))))) ((looking-at sshell-pushd-regexp) (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) (if sshell-directory-stack (let ((old default-directory)) (cd (car sshell-directory-stack)) (setq sshell-directory-stack (cons old (cdr sshell-directory-stack)))))) ((memq (char-after (match-end 0)) '(?\ ?\t)) (let (dir) (skip-chars-forward "^ ") (skip-chars-forward " \t") (if (file-directory-p (setq dir (expand-file-name (substitute-in-file-name (buffer-substring (point) (progn (skip-chars-forward "^\n \t;") (point))))))) (progn (setq sshell-directory-stack (cons default-directory sshell-directory-stack)) (cd dir))))))) ((looking-at sshell-cd-regexp) (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) (cd (getenv "HOME"))) ((memq (char-after (match-end 0)) '(?\ ?\t)) (let (dir) (forward-char 3) (skip-chars-forward " \t") (if (file-directory-p (setq dir (expand-file-name (substitute-in-file-name (buffer-substring (point) (progn (skip-chars-forward "^\n \t;") (point))))))) (cd dir)))))))) (defun sshell-send-eof () "Send eof to subsshell (or to the program running under it)." (interactive) (process-send-eof)) (defun kill-output-from-sshell () "Kill all output from sshell since last input." (interactive) (goto-char (point-max)) (beginning-of-line) (kill-region last-input-end (point)) (insert "*** output flushed ***\n") (goto-char (point-max))) (defun show-output-from-sshell () "Display start of this batch of sshell output at top of window. Also put cursor there." (interactive) (set-window-start (selected-window) last-input-end) (goto-char last-input-end)) (defun copy-last-sshell-input () "Copy previous sshell input, sans newline, and insert before point." (interactive) (insert (buffer-substring last-input-end last-input-start)) (delete-char -1)) (defun interrupt-sshell-subjob () "Interrupt this sshell's current subjob." (interactive) (interrupt-process nil t)) (defun kill-sshell-subjob () "Send kill signal to this sshell's current subjob." (interactive) (kill-process nil t)) (defun quit-sshell-subjob () "Send quit signal to this sshell's current subjob." (interactive) (quit-process nil t)) (defun stop-sshell-subjob () "Stop this sshell's current subjob." (interactive) (stop-process nil t)) (defun kill-sshell-input () "Kill all text since last stuff output by the sshell or its subjobs." (interactive) (kill-region (process-mark (get-buffer-process (current-buffer))) (point))) (require 'smart-complete) (provide 'sshell)gcl-2.6.14/elisp/smart-complete.el0000644000175000017500000001172114360276512015367 0ustar cammcamm;; This file is part of GNU Emacs. ;; Copyright (C) 1998 William F. Schelter ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility ;; to anyone for the consequences of using it or for whether it serves ;; any particular purpose or works at all, unless he says so in writing. ;; Refer to the GNU Emacs General Public License for full details. ;; Everyone is granted permission to copy, modify and redistribute GNU ;; Emacs, but only under the conditions described in the GNU Emacs ;; General Public License. A copy of this license is supposed to have ;; been given to you along with GNU Emacs so you can know your rights and ;; responsibilities. It should be in a file named COPYING. Among other ;; things, the copyright notice and this notice must be preserved on all ;; copies. ;; By Bill Schelter wfs@math.utexas.edu ;; Completion on forms in the buffer. Does either a line or an sexp. ;; Uses the current prompt and the beginning of what you have typed. ;; Thus If the buffer contained ;; (dbm:3) load("jo" ;; (C11) lo("ji") ;; (gdb) last ;; maxima>>4 ;; /home/bil# ls ;; then if you are at a prompt ;; "(C15) l" would match lo("ji") only, not "last", not "ls" nor load(" ;; and the commands with the (gdb) prompt would only match ones ;; starting with (gdb) .. ;; also if the command is a lisp sexp and this would be longer than the ;; current line, it grabs the whole thing. sometimes we have different ;; prompts, for different programs and we dont want to confuse the input ;; from one with input for another. Generally the prompt matches a ;; previous prompt, with numbers matching any number, and if there are ;; '/' then match anything up to a shell prompt terminator. Note it does ;; this without additional consing or building up huge lists of inputs. (if (boundp 'comint-mode-map) (define-key comint-mode-map "\ep" 'smart-complete) ) (if (boundp 'sshell-mode-map) (define-key sshell-mode-map "\ep" 'smart-complete) (define-key sshell-mode-map "\M-p" 'smart-complete) ) (defun get-match-n (i ) (buffer-substring (match-beginning i) (match-end i))) (defun smart-complete () "Begin to type the command and then type M-p. You will be offered in the minibuffer a succession of choices, which you can say 'n' to to get the next one, or 'y' or 'space' to grab the current one. Thus to get the last command starting with 'li' you type liM-py " (interactive ) (let ((point (point)) new str tem prompt) (save-excursion (beginning-of-line) (cond ((looking-at sshell-prompt-pattern) (setq prompt (get-match-n 0)) (setq str (buffer-substring (match-end 0) point))) (t (error "Your prompt on this line does not match sshell-prompt-pattern"))) (setq new (smart-complete2 prompt str)) ) (cond (new (delete-region (setq tem (- point (length str))) point) (goto-char tem) (insert new))))) (defun smart-complete2 (prompt str) (let ((pt (point)) found (pat (concat (regexp-for-this-prompt prompt) "\\(" (regexp-quote str) "\\)" )) offered (not-yet t) ) (setq bill pat) (while (and not-yet (re-search-backward pat nil t)) (goto-char (match-beginning 1)) (setq at (match-beginning 1)) (goto-char at) (setq this (buffer-substring at (save-excursion (end-of-line) (point)))) (or (member this offered) (equal this str) (progn (setq offered (cons this offered)) ;; do this so the display does not shift... (goto-char pt) (setq not-yet (not (y-or-n-p (concat "Use: " this " ")))))) (cond (not-yet (goto-char at) (beginning-of-line) (forward-char -1)) (t (setq found (save-excursion (buffer-substring at (progn (goto-char at) (max (save-excursion (end-of-line) (point)) (save-excursion (forward-sexp 1)(point))) ))))))) (or found (message "No more matches")) found )) ;; return a regexp for this prompt but with numbers replaced. (defun split-string-gcl (s bag) (cond ((equal (length s) 0) '("")) ((string-match bag s) (if (= (match-beginning 0) 0) (cons "" (split-string-gcl (substring s (match-end 0)) bag)) (cons (substring s 0 (match-beginning 0)) (split-string-gcl (substring s (match-end 0)) bag)))) (t (cons s nil)))) ;; Return a regexp which matches the current prompt, and which ;; allows things like ;; "/foo/bar# " to match "any# " ;; "(C12) " to match "(C1002) " but not (gdb) nor "(D12) " ;; if the prompt appears to be a pathname (ie has /) then ;; allow any beginning, otherwise numbers match numbers... (defun regexp-for-this-prompt (prompt ) (let ((wild (cond ((string-match "/" prompt) "[^ >#%()]+") (t "[0-9]+")))) (let ((tem (split-string-gcl prompt wild)) (ans "")) (while tem (setq ans (concat ans (regexp-quote (car tem)))) (cond ((cdr tem) (setq ans (concat ans wild)))) (setq tem (cdr tem))) ans))) (provide 'smart-complete) gcl-2.6.14/gcl.ico0000644000175000017500000005571614360276512012252 0ustar cammcamm v00h^  00n h!  ~%00 %&6( @Gw||̏txGG|GDGwDLtwxLwďwGĈ|xLLG||̏ČOLGG̏O||(0`GGDGDxtwLxLGxL@GLx|DwDDwvLDLowLDOx\DLxE6XLOLŏ HGwxLGww|ďďHDw|ǏG|xď|x|GwwLLtHHWtƏ||ƇLHDLOlďX\ƏWLLDeL( @mu\20Z[Ys@@m_^{UU  )'!"-,9998! !!+*..""$$.-0/44679:<;==      ##&&('! 89##?@EELMEECCDEJJYZ\\__TUQQXXDDQQQQVWaaghijuwqqwxceddhiih}}uvyyFG__|}vuŎǐ̲KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK5.yzz{~]3>KKKKKKKKKKKKKKKKKKKKZ}FKKKKKKKKKKKKKKKQ>|$>KKKKKKKKKKKKKK:k1KKKKKKKKKKKKKK0 piDKKKKKKKKKKKK>#wqFKKKKKKKKKK1#KKKKKKKKKKK0 `mKKKRKKKKKKKKKKFr"5 7KKKKKK^= KKKKKQWhaKK9KKKKKKKWK"bKKKKKKKKKKKQ UKKKKKKKKF#_j+KKKKKKK-KKKKKKKs\WFeKKKKKKK; [KP7KKKKKKKZwKQFKKKKKKKKgVK=*KKKKKKKKF7KK.BKKKKKKKKKKQhCKKKQoKKKKKKKKKKKtDKKKKQ+UKKKKKKKKKKK'KKKKKK*dKKKKKKKKKKKKKKKKKKKKK(od.uPKKKKKKKKKKKKKKKKKKKKKKKK%3KKKKKKKKKKKKKKKKKKKKKKKK9KKKKKKKKKKKKKKKKKKKKKKKKlHKKKKKKKKKKKKKKKKKKKKKKKKQx;KKKKKKKKKKKKKKKKKKKKKKKKKKQ+>KKKKKKKKKKKKKKKK(0` "' R_U]a |qzmifvyum+*w$$x""q))|..l>>r11y66A@?KJL[[XoGIlKLqBAuEGjOPOPlTTm\]tYYdedmcclkklmkmnnueavbdtefthgvhjvrsysr{{z     .,))*)%'%$-+127:??3369!",,96        %%++"$')))02##..33??ABFELMDBKKSSYZ^^\_CCaaoous{|}{xx}~ZY~}}«hEU[]LdvvLԳZ6hݵ}ڧ;vo!:}v.;w};#1CC+l-A3y} 2;zo:88Ch.4&dvAG̥+NkЙK mj!He((2j?#9}7m_yJ!&1,aN%lh߷^r9GzK#4ǑT+XyWRCqQP@&HwGwz`Nq}\QTV}!Ï'sk\SR}1{NJKW55>Fa?%w@w$JCh)ۦ} ]a$\Pj(  @]]߾햘EE44Ĵ..k&&Ƽ==rtt kkNMNN<:xxͬvdcHGYW מvv((٥Ԣ ( @ P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\'%edsuWV!#35 uurGGnGHP;=LL@VXIutd q gFRR>>u]^pv@x;nNNO<= pf! [{},-w:9a!}b`]_')Qa,+)tQT 0 Hllu| |-/P?@z5AB`gh `$&&&OOu--fABtvS|""j^_::P\P\P\P\P\P\P\P\P\P\P\P\P\\\[\U\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\P\(0` %fV..I\01k#{wwa Pv""Xkko33au3)'|=`}y6SVcr59;0WUj152'?A\UK?RT@ki=G54Hqsh{2r >SU}}[rq=WW/aK O&&: U+-z[ZM~_&$K87[[@ÿr~.1 O  HH@Uii#'($'7; (setf (gethash 'color a) 'brown) @result{} BROWN (setf (gethash 'name a) 'fred) @result{} FRED (gethash 'color a) @result{} BROWN, @i{true} (gethash 'name a) @result{} FRED, @i{true} (gethash 'pointy a) @result{} NIL, @i{false} @end example In this example, the symbols @t{color} and @t{name} are being used as keys, and the symbols @t{brown} and @t{fred} are being used as the associated values. The @i{hash table} has two items in it, one of which associates from @t{color} to @t{brown}, and the other of which associates from @t{name} to @t{fred}. @item -- A key or a value may be any @i{object}. @item -- The existence of an entry in the @i{hash table} can be determined from the @i{secondary value} returned by @b{gethash}. @end table @format @group @noindent @w{ clrhash hash-table-p remhash } @w{ gethash make-hash-table sxhash } @w{ hash-table-count maphash } @noindent @w{ Figure 18--1: Hash-table defined names } @end group @end format @node Modifying Hash Table Keys, , Hash-Table Operations, Hash Table Concepts @subsection Modifying Hash Table Keys The function supplied as the @t{:test} argument to @b{make-hash-table} specifies the `equivalence test' for the @i{hash table} it creates. An @i{object} is `visibly modified' with regard to an equivalence test if there exists some set of @i{objects} (or potential @i{objects}) which are equivalent to the @i{object} before the modification but are no longer equivalent afterwards. If an @i{object} O_1 is used as a key in a @i{hash table} H and is then visibly modified with regard to the equivalence test of H, then the consequences are unspecified if O_1, or any @i{object} O_2 equivalent to O_1 under the equivalence test (either before or after the modification), is used as a key in further operations on H. The consequences of using O_1 as a key are unspecified even if O_1 is visibly modified and then later modified again in such a way as to undo the visible modification. Following are specifications of the modifications which are visible to the equivalence tests which must be supported by @i{hash tables}. The modifications are described in terms of modification of components, and are defined recursively. Visible modifications of components of the @i{object} are visible modifications of the @i{object}. @menu * Visible Modification of Objects with respect to EQ and EQL:: * Visible Modification of Objects with respect to EQUAL:: * Visible Modification of Conses with respect to EQUAL:: * Visible Modification of Bit Vectors and Strings with respect to EQUAL:: * Visible Modification of Objects with respect to EQUALP:: * Visible Modification of Structures with respect to EQUALP:: * Visible Modification of Arrays with respect to EQUALP:: * Visible Modification of Hash Tables with respect to EQUALP:: * Visible Modifications by Language Extensions:: @end menu @node Visible Modification of Objects with respect to EQ and EQL, Visible Modification of Objects with respect to EQUAL, Modifying Hash Table Keys, Modifying Hash Table Keys @subsubsection Visible Modification of Objects with respect to EQ and EQL No @i{standardized} @i{function} is provided that is capable of visibly modifying an @i{object} with regard to @b{eq} or @b{eql}. @node Visible Modification of Objects with respect to EQUAL, Visible Modification of Conses with respect to EQUAL, Visible Modification of Objects with respect to EQ and EQL, Modifying Hash Table Keys @subsubsection Visible Modification of Objects with respect to EQUAL As a consequence of the behavior for @b{equal}, the rules for visible modification of @i{objects} not explicitly mentioned in this section are inherited from those in @ref{Visible Modification of Objects with respect to EQ and EQL}. @node Visible Modification of Conses with respect to EQUAL, Visible Modification of Bit Vectors and Strings with respect to EQUAL, Visible Modification of Objects with respect to EQUAL, Modifying Hash Table Keys @subsubsection Visible Modification of Conses with respect to EQUAL Any visible change to the @i{car} or the @i{cdr} of a @i{cons} is considered a visible modification with regard to @b{equal}. @node Visible Modification of Bit Vectors and Strings with respect to EQUAL, Visible Modification of Objects with respect to EQUALP, Visible Modification of Conses with respect to EQUAL, Modifying Hash Table Keys @subsubsection Visible Modification of Bit Vectors and Strings with respect to EQUAL For a @i{vector} of @i{type} @b{bit-vector} or of @i{type} @b{string}, any visible change to an @i{active} @i{element} of the @i{vector}, or to the @i{length} of the @i{vector} (if it is @i{actually adjustable} or has a @i{fill pointer}) is considered a visible modification with regard to @b{equal}. @node Visible Modification of Objects with respect to EQUALP, Visible Modification of Structures with respect to EQUALP, Visible Modification of Bit Vectors and Strings with respect to EQUAL, Modifying Hash Table Keys @subsubsection Visible Modification of Objects with respect to EQUALP As a consequence of the behavior for @b{equalp}, the rules for visible modification of @i{objects} not explicitly mentioned in this section are inherited from those in @ref{Visible Modification of Objects with respect to EQUAL}. @node Visible Modification of Structures with respect to EQUALP, Visible Modification of Arrays with respect to EQUALP, Visible Modification of Objects with respect to EQUALP, Modifying Hash Table Keys @subsubsection Visible Modification of Structures with respect to EQUALP Any visible change to a @i{slot} of a @i{structure} is considered a visible modification with regard to @b{equalp}. @node Visible Modification of Arrays with respect to EQUALP, Visible Modification of Hash Tables with respect to EQUALP, Visible Modification of Structures with respect to EQUALP, Modifying Hash Table Keys @subsubsection Visible Modification of Arrays with respect to EQUALP In an @i{array}, any visible change to an @i{active} @i{element}, to the @i{fill pointer} (if the @i{array} can and does have one), or to the @i{dimensions} (if the @i{array} is @i{actually adjustable}) is considered a visible modification with regard to @b{equalp}. @node Visible Modification of Hash Tables with respect to EQUALP, Visible Modifications by Language Extensions, Visible Modification of Arrays with respect to EQUALP, Modifying Hash Table Keys @subsubsection Visible Modification of Hash Tables with respect to EQUALP In a @i{hash table}, any visible change to the count of entries in the @i{hash table}, to the keys, or to the values associated with the keys is considered a visible modification with regard to @b{equalp}. Note that the visibility of modifications to the keys depends on the equivalence test of the @i{hash table}, not on the specification of @b{equalp}. @node Visible Modifications by Language Extensions, , Visible Modification of Hash Tables with respect to EQUALP, Modifying Hash Table Keys @subsubsection Visible Modifications by Language Extensions @i{Implementations} that extend the language by providing additional mutator functions (or additional behavior for existing mutator functions) must document how the use of these extensions interacts with equivalence tests and @i{hash table} searches. @i{Implementations} that extend the language by defining additional acceptable equivalence tests for @i{hash tables} (allowing additional values for the @t{:test} argument to @b{make-hash-table}) must document the visible components of these tests. @c end of including concept-hash-tables @node Hash Tables Dictionary, , Hash Table Concepts, Hash Tables @section Hash Tables Dictionary @c including dict-hash-tables @menu * hash-table:: * make-hash-table:: * hash-table-p:: * hash-table-count:: * hash-table-rehash-size:: * hash-table-rehash-threshold:: * hash-table-size:: * hash-table-test:: * gethash:: * remhash:: * maphash:: * with-hash-table-iterator:: * clrhash:: * sxhash:: @end menu @node hash-table, make-hash-table, Hash Tables Dictionary, Hash Tables Dictionary @subsection hash-table [System Class] @subsubheading Class Precedence List:: @b{hash-table}, @b{t} @subsubheading Description:: @i{Hash tables} provide a way of mapping any @i{object} (a @i{key}) to an associated @i{object} (a @i{value}). @subsubheading See Also:: @ref{Hash Table Concepts}, @ref{Printing Other Objects} @subsubheading Notes:: The intent is that this mapping be implemented by a hashing mechanism, such as that described in Section 6.4 ``Hashing'' of @b{The Art of Computer Programming, Volume 3} (pp506-549). In spite of this intent, no @i{conforming implementation} is required to use any particular technique to implement the mapping. @node make-hash-table, hash-table-p, hash-table, Hash Tables Dictionary @subsection make-hash-table [Function] @code{make-hash-table} @i{@r{&key} test size rehash-size rehash-threshold} @result{} @i{hash-table} @subsubheading Arguments and Values:: @i{test}---a @i{designator} for one of the @i{functions} @b{eq}, @b{eql}, @b{equal}, or @b{equalp}. The default is @b{eql}. @i{size}---a non-negative @i{integer}. The default is @i{implementation-dependent}. @i{rehash-size}---a @i{real} of @i{type} @t{(or (integer 1 *) (float (1.0) *))}. The default is @i{implementation-dependent}. @i{rehash-threshold}---a @i{real} of @i{type} @t{(real 0 1)}. The default is @i{implementation-dependent}. @i{hash-table}---a @i{hash table}. @subsubheading Description:: Creates and returns a new @i{hash table}. @i{test} determines how @i{keys} are compared. An @i{object} is said to be present in the @i{hash-table} if that @i{object} is the @i{same} under the @i{test} as the @i{key} for some entry in the @i{hash-table}. @i{size} is a hint to the @i{implementation} about how much initial space to allocate in the @i{hash-table}. This information, taken together with the @i{rehash-threshold}, controls the approximate number of entries which it should be possible to insert before the table has to grow. The actual size might be rounded up from @i{size} to the next `good' size; for example, some @i{implementations} might round to the next prime number. @i{rehash-size} specifies a minimum amount to increase the size of the @i{hash-table} when it becomes full enough to require rehashing; see @i{rehash-theshold} below. If @i{rehash-size} is an @i{integer}, the expected growth rate for the table is additive and the @i{integer} is the number of entries to add; if it is a @i{float}, the expected growth rate for the table is multiplicative and the @i{float} is the ratio of the new size to the old size. As with @i{size}, the actual size of the increase might be rounded up. @i{rehash-threshold} specifies how full the @i{hash-table} can get before it must grow. It specifies the maximum desired hash-table occupancy level. The @i{values} of @i{rehash-size} and @i{rehash-threshold} do not constrain the @i{implementation} to use any particular method for computing when and by how much the size of @i{hash-table} should be enlarged. Such decisions are @i{implementation-dependent}, and these @i{values} only hints from the @i{programmer} to the @i{implementation}, and the @i{implementation} is permitted to ignore them. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (setf (gethash "one" table) 1) @result{} 1 (gethash "one" table) @result{} NIL, @i{false} (setq table (make-hash-table :test 'equal)) @result{} # (setf (gethash "one" table) 1) @result{} 1 (gethash "one" table) @result{} 1, T (make-hash-table :rehash-size 1.5 :rehash-threshold 0.7) @result{} # @end example @subsubheading See Also:: @ref{gethash} , @b{hash-table} @node hash-table-p, hash-table-count, make-hash-table, Hash Tables Dictionary @subsection hash-table-p [Function] @code{hash-table-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{hash-table}; otherwise, returns @i{false}. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (hash-table-p table) @result{} @i{true} (hash-table-p 37) @result{} @i{false} (hash-table-p '((a . 1) (b . 2))) @result{} @i{false} @end example @subsubheading Notes:: @example (hash-table-p @i{object}) @equiv{} (typep @i{object} 'hash-table) @end example @node hash-table-count, hash-table-rehash-size, hash-table-p, Hash Tables Dictionary @subsection hash-table-count [Function] @code{hash-table-count} @i{hash-table} @result{} @i{count} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @i{count}---a non-negative @i{integer}. @subsubheading Description:: Returns the number of entries in the @i{hash-table}. If @i{hash-table} has just been created or newly cleared (see @b{clrhash}) the entry count is @t{0}. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (hash-table-count table) @result{} 0 (setf (gethash 57 table) "fifty-seven") @result{} "fifty-seven" (hash-table-count table) @result{} 1 (dotimes (i 100) (setf (gethash i table) i)) @result{} NIL (hash-table-count table) @result{} 100 @end example @subsubheading Affected By:: @b{clrhash}, @b{remhash}, @b{setf} of @b{gethash} @subsubheading See Also:: @ref{hash-table-size} @subsubheading Notes:: The following relationships are functionally correct, although in practice using @b{hash-table-count} is probably much faster: @example (hash-table-count @i{table}) @equiv{} (loop for value being the hash-values of @i{table} count t) @equiv{} (let ((total 0)) (maphash #'(lambda (key value) (declare (ignore key value)) (incf total)) @i{table}) total) @end example @node hash-table-rehash-size, hash-table-rehash-threshold, hash-table-count, Hash Tables Dictionary @subsection hash-table-rehash-size [Function] @code{hash-table-rehash-size} @i{hash-table} @result{} @i{rehash-size} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @i{rehash-size}---a @i{real} of @i{type} @t{(or (integer 1 *) (float (1.0) *))}. @subsubheading Description:: Returns the current rehash size of @i{hash-table}, suitable for use in a call to @b{make-hash-table} in order to produce a @i{hash table} with state corresponding to the current state of the @i{hash-table}. @subsubheading Examples:: @example (setq table (make-hash-table :size 100 :rehash-size 1.4)) @result{} # (hash-table-rehash-size table) @result{} 1.4 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{hash-table} is not a @i{hash table}. @subsubheading See Also:: @ref{make-hash-table} , @ref{hash-table-rehash-threshold} @subsubheading Notes:: If the hash table was created with an @i{integer} rehash size, the result is an @i{integer}, indicating that the rate of growth of the @i{hash-table} when rehashed is intended to be additive; otherwise, the result is a @i{float}, indicating that the rate of growth of the @i{hash-table} when rehashed is intended to be multiplicative. However, this value is only advice to the @i{implementation}; the actual amount by which the @i{hash-table} will grow upon rehash is @i{implementation-dependent}. @node hash-table-rehash-threshold, hash-table-size, hash-table-rehash-size, Hash Tables Dictionary @subsection hash-table-rehash-threshold [Function] @code{hash-table-rehash-threshold} @i{hash-table} @result{} @i{rehash-threshold} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @i{rehash-threshold}---a @i{real} of @i{type} @t{(real 0 1)}. @subsubheading Description:: Returns the current rehash threshold of @i{hash-table}, which is suitable for use in a call to @b{make-hash-table} in order to produce a @i{hash table} with state corresponding to the current state of the @i{hash-table}. @subsubheading Examples:: @example (setq table (make-hash-table :size 100 :rehash-threshold 0.5)) @result{} # (hash-table-rehash-threshold table) @result{} 0.5 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{hash-table} is not a @i{hash table}. @subsubheading See Also:: @ref{make-hash-table} , @ref{hash-table-rehash-size} @node hash-table-size, hash-table-test, hash-table-rehash-threshold, Hash Tables Dictionary @subsection hash-table-size [Function] @code{hash-table-size} @i{hash-table} @result{} @i{size} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @i{size}---a non-negative @i{integer}. @subsubheading Description:: Returns the current size of @i{hash-table}, which is suitable for use in a call to @b{make-hash-table} in order to produce a @i{hash table} with state corresponding to the current state of the @i{hash-table}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{hash-table} is not a @i{hash table}. @subsubheading See Also:: @ref{hash-table-count} , @ref{make-hash-table} @node hash-table-test, gethash, hash-table-size, Hash Tables Dictionary @subsection hash-table-test [Function] @code{hash-table-test} @i{hash-table} @result{} @i{test} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @i{test}---a @i{function designator}. For the four @i{standardized} @i{hash table} test @i{functions} (see @b{make-hash-table}), the @i{test} value returned is always a @i{symbol}. If an @i{implementation} permits additional tests, it is @i{implementation-dependent} whether such tests are returned as @i{function} @i{objects} or @i{function names}. @subsubheading Description:: Returns the test used for comparing @i{keys} in @i{hash-table}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{hash-table} is not a @i{hash table}. @subsubheading See Also:: @ref{make-hash-table} @node gethash, remhash, hash-table-test, Hash Tables Dictionary @subsection gethash [Accessor] @code{gethash} @i{key hash-table @r{&optional} default} @result{} @i{value, present-p} (setf (@code{ gethash} @i{key hash-table @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: @i{key}---an @i{object}. @i{hash-table}---a @i{hash table}. @i{default}---an @i{object}. The default is @b{nil}. @i{value}---an @i{object}. @i{present-p}---a @i{generalized boolean}. @subsubheading Description:: @i{Value} is the @i{object} in @i{hash-table} whose @i{key} is the @i{same} as @i{key} under the @i{hash-table}'s equivalence test. If there is no such entry, @i{value} is the @i{default}. @i{Present-p} is @i{true} if an entry is found; otherwise, it is @i{false}. @b{setf} may be used with @b{gethash} to modify the @i{value} associated with a given @i{key}, or to add a new entry. When a @b{gethash} @i{form} is used as a @b{setf} @i{place}, any @i{default} which is supplied is evaluated according to normal left-to-right evaluation rules, but its @i{value} is ignored. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (gethash 1 table) @result{} NIL, @i{false} (gethash 1 table 2) @result{} 2, @i{false} (setf (gethash 1 table) "one") @result{} "one" (setf (gethash 2 table "two") "two") @result{} "two" (gethash 1 table) @result{} "one", @i{true} (gethash 2 table) @result{} "two", @i{true} (gethash nil table) @result{} NIL, @i{false} (setf (gethash nil table) nil) @result{} NIL (gethash nil table) @result{} NIL, @i{true} (defvar *counters* (make-hash-table)) @result{} *COUNTERS* (gethash 'foo *counters*) @result{} NIL, @i{false} (gethash 'foo *counters* 0) @result{} 0, @i{false} (defmacro how-many (obj) `(values (gethash ,obj *counters* 0))) @result{} HOW-MANY (defun count-it (obj) (incf (how-many obj))) @result{} COUNT-IT (dolist (x '(bar foo foo bar bar baz)) (count-it x)) (how-many 'foo) @result{} 2 (how-many 'bar) @result{} 3 (how-many 'quux) @result{} 0 @end example @subsubheading See Also:: @ref{remhash} @subsubheading Notes:: The @i{secondary value}, @i{present-p}, can be used to distinguish the absence of an entry from the presence of an entry that has a value of @i{default}. @node remhash, maphash, gethash, Hash Tables Dictionary @subsection remhash [Function] @code{remhash} @i{key hash-table} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{key}---an @i{object}. @i{hash-table}---a @i{hash table}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Removes the entry for @i{key} in @i{hash-table}, if any. Returns @i{true} if there was such an entry, or @i{false} otherwise. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (setf (gethash 100 table) "C") @result{} "C" (gethash 100 table) @result{} "C", @i{true} (remhash 100 table) @result{} @i{true} (gethash 100 table) @result{} NIL, @i{false} (remhash 100 table) @result{} @i{false} @end example @subsubheading Side Effects:: The @i{hash-table} is modified. @node maphash, with-hash-table-iterator, remhash, Hash Tables Dictionary @subsection maphash [Function] @code{maphash} @i{function hash-table} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{function}---a @i{designator} for a @i{function} of two @i{arguments}, the @i{key} and the @i{value}. @i{hash-table}---a @i{hash table}. @subsubheading Description:: Iterates over all entries in the @i{hash-table}. For each entry, the @i{function} is called with two @i{arguments}--the @i{key} and the @i{value} of that entry. The consequences are unspecified if any attempt is made to add or remove an entry from the @i{hash-table} while a @b{maphash} is in progress, with two exceptions: the @i{function} can use can use @b{setf} of @b{gethash} to change the @i{value} part of the entry currently being processed, or it can use @b{remhash} to remove that entry. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (dotimes (i 10) (setf (gethash i table) i)) @result{} NIL (let ((sum-of-squares 0)) (maphash #'(lambda (key val) (let ((square (* val val))) (incf sum-of-squares square) (setf (gethash key table) square))) table) sum-of-squares) @result{} 285 (hash-table-count table) @result{} 10 (maphash #'(lambda (key val) (when (oddp val) (remhash key table))) table) @result{} NIL (hash-table-count table) @result{} 5 (maphash #'(lambda (k v) (print (list k v))) table) (0 0) (8 64) (2 4) (6 36) (4 16) @result{} NIL @end example @subsubheading Side Effects:: None, other than any which might be done by the @i{function}. @subsubheading See Also:: @ref{loop} , @ref{with-hash-table-iterator} , @ref{Traversal Rules and Side Effects} @node with-hash-table-iterator, clrhash, maphash, Hash Tables Dictionary @subsection with-hash-table-iterator [Macro] @code{with-hash-table-iterator} @i{@r{(}name hash-table@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{name}---a name suitable for the first argument to @b{macrolet}. @i{hash-table}---a @i{form}, evaluated once, that should produce a @i{hash table}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by @i{forms}. @subsubheading Description:: Within the lexical scope of the body, @i{name} is defined via @b{macrolet} such that successive invocations of @t{(@i{name})} return the items, one by one, from the @i{hash table} that is obtained by evaluating @i{hash-table} only once. An invocation @t{(@i{name})} returns three values as follows: @table @asis @item 1. A @i{generalized boolean} that is @i{true} if an entry is returned. @item 2. The key from the @i{hash-table} entry. @item 3. The value from the @i{hash-table} entry. @end table After all entries have been returned by successive invocations of @t{(@i{name})}, then only one value is returned, namely @b{nil}. It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the @b{with-hash-table-iterator} @i{form} such as by returning some @i{closure} over the invocation @i{form}. Any number of invocations of @b{with-hash-table-iterator} can be nested, and the body of the innermost one can invoke all of the locally @i{established} @i{macros}, provided all of those @i{macros} have @i{distinct} names. @subsubheading Examples:: The following function should return @b{t} on any @i{hash table}, and signal an error if the usage of @b{with-hash-table-iterator} does not agree with the corresponding usage of @b{maphash}. @example (defun test-hash-table-iterator (hash-table) (let ((all-entries '()) (generated-entries '()) (unique (list nil))) (maphash #'(lambda (key value) (push (list key value) all-entries)) hash-table) (with-hash-table-iterator (generator-fn hash-table) (loop (multiple-value-bind (more? key value) (generator-fn) (unless more? (return)) (unless (eql value (gethash key hash-table unique)) (error "Key ~S not found for value ~S" key value)) (push (list key value) generated-entries)))) (unless (= (length all-entries) (length generated-entries) (length (union all-entries generated-entries :key #'car :test (hash-table-test hash-table)))) (error "Generated entries and Maphash entries don't correspond")) t)) @end example The following could be an acceptable definition of @b{maphash}, implemented by @b{with-hash-table-iterator}. @example (defun maphash (function hash-table) (with-hash-table-iterator (next-entry hash-table) (loop (multiple-value-bind (more key value) (next-entry) (unless more (return nil)) (funcall function key value))))) @end example @subsubheading Exceptional Situations:: The consequences are undefined if the local function named @i{name} @i{established} by @b{with-hash-table-iterator} is called after it has returned @i{false} as its @i{primary value}. @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @node clrhash, sxhash, with-hash-table-iterator, Hash Tables Dictionary @subsection clrhash [Function] @code{clrhash} @i{hash-table} @result{} @i{hash-table} @subsubheading Arguments and Values:: @i{hash-table}---a @i{hash table}. @subsubheading Description:: Removes all entries from @i{hash-table}, and then returns that empty @i{hash table}. @subsubheading Examples:: @example (setq table (make-hash-table)) @result{} # (dotimes (i 100) (setf (gethash i table) (format nil "~R" i))) @result{} NIL (hash-table-count table) @result{} 100 (gethash 57 table) @result{} "fifty-seven", @i{true} (clrhash table) @result{} # (hash-table-count table) @result{} 0 (gethash 57 table) @result{} NIL, @i{false} @end example @subsubheading Side Effects:: The @i{hash-table} is modified. @node sxhash, , clrhash, Hash Tables Dictionary @subsection sxhash [Function] @code{sxhash} @i{object} @result{} @i{hash-code} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{hash-code}---a non-negative @i{fixnum}. @subsubheading Description:: @b{sxhash} returns a hash code for @i{object}. The manner in which the hash code is computed is @i{implementation-dependent}, but subject to certain constraints: @table @asis @item 1. @t{(equal @i{x} @i{y})} implies @t{(= (sxhash @i{x}) (sxhash @i{y}))}. @item 2. For any two @i{objects}, @i{x} and @i{y}, both of which are @i{bit vectors}, @i{characters}, @i{conses}, @i{numbers}, @i{pathnames}, @i{strings}, or @i{symbols}, and which are @i{similar}, @t{(sxhash @i{x})} and @t{(sxhash @i{y})} @i{yield} the same mathematical value even if @i{x} and @i{y} exist in different @i{Lisp images} of the same @i{implementation}. See @ref{Literal Objects in Compiled Files}. @item 3. The @i{hash-code} for an @i{object} is always the @i{same} within a single @i{session} provided that the @i{object} is not visibly modified with regard to the equivalence test @b{equal}. See @ref{Modifying Hash Table Keys}. @item 4. The @i{hash-code} is intended for hashing. This places no verifiable constraint on a @i{conforming implementation}, but the intent is that an @i{implementation} should make a good-faith effort to produce @i{hash-codes} that are well distributed within the range of non-negative @i{fixnums}. @item 5. Computation of the @i{hash-code} must terminate, even if the @i{object} contains circularities. @end table @subsubheading Examples:: @example (= (sxhash (list 'list "ab")) (sxhash (list 'list "ab"))) @result{} @i{true} (= (sxhash "a") (sxhash (make-string 1 :initial-element #\a))) @result{} @i{true} (let ((r (make-random-state))) (= (sxhash r) (sxhash (make-random-state r)))) @result{} @i{implementation-dependent} @end example @subsubheading Affected By:: The @i{implementation}. @subsubheading Notes:: Many common hashing needs are satisfied by @b{make-hash-table} and the related functions on @i{hash tables}. @b{sxhash} is intended for use where the pre-defined abstractions are insufficient. Its main intent is to allow the user a convenient means of implementing more complicated hashing paradigms than are provided through @i{hash tables}. The hash codes returned by @b{sxhash} are not necessarily related to any hashing strategy used by any other @i{function} in @r{Common Lisp}. For @i{objects} of @i{types} that @b{equal} compares with @b{eq}, item 3 requires that the @i{hash-code} be based on some immutable quality of the identity of the object. Another legitimate implementation technique would be to have @b{sxhash} assign (and cache) a random hash code for these @i{objects}, since there is no requirement that @i{similar} but non-@b{eq} objects have the same hash code. Although @i{similarity} is defined for @i{symbols} in terms of both the @i{symbol}'s @i{name} and the @i{packages} in which the @i{symbol} is @i{accessible}, item 3 disallows using @i{package} information to compute the hash code, since changes to the package status of a symbol are not visible to @i{equal}. @c end of including dict-hash-tables @c %**end of chapter gcl-2.6.14/info/chap-6.texi0000644000175000017500000030366014360276512013707 0ustar cammcamm @node Iteration, Objects, Data and Control Flow, Top @chapter Iteration @menu * The LOOP Facility:: * Iteration Dictionary:: @end menu @node The LOOP Facility, Iteration Dictionary, Iteration, Iteration @section The LOOP Facility @c including concept-loop @menu * Overview of the Loop Facility:: * Variable Initialization and Stepping Clauses:: * Value Accumulation Clauses:: * Termination Test Clauses:: * Unconditional Execution Clauses:: * Conditional Execution Clauses:: * Miscellaneous Clauses:: * Examples of Miscellaneous Loop Features:: * Notes about Loop:: @end menu @node Overview of the Loop Facility, Variable Initialization and Stepping Clauses, The LOOP Facility, The LOOP Facility @subsection Overview of the Loop Facility The @b{loop} @i{macro} performs iteration. @menu * Simple vs Extended Loop:: * Simple Loop:: * Extended Loop:: * Loop Keywords:: * Parsing Loop Clauses:: * Expanding Loop Forms:: * Summary of Loop Clauses:: * Summary of Variable Initialization and Stepping Clauses:: * Summary of Value Accumulation Clauses:: * Summary of Termination Test Clauses:: * Summary of Unconditional Execution Clauses:: * Summary of Conditional Execution Clauses:: * Summary of Miscellaneous Clauses:: * Order of Execution:: * Destructuring:: * Restrictions on Side-Effects:: @end menu @node Simple vs Extended Loop, Simple Loop, Overview of the Loop Facility, Overview of the Loop Facility @subsubsection Simple vs Extended Loop @b{loop} @i{forms} are partitioned into two categories: simple @b{loop} @i{forms} and extended @b{loop} @i{forms}. @node Simple Loop, Extended Loop, Simple vs Extended Loop, Overview of the Loop Facility @subsubsection Simple Loop A simple @b{loop} @i{form} is one that has a body containing only @i{compound forms}. Each @i{form} is @i{evaluated} in turn from left to right. When the last @i{form} has been @i{evaluated}, then the first @i{form} is evaluated again, and so on, in a never-ending cycle. A simple @b{loop} @i{form} establishes an @i{implicit block} named @b{nil}. The execution of a simple @b{loop} can be terminated by explicitly transfering control to the @i{implicit block} (using @b{return} or @b{return-from}) or to some @i{exit point} outside of the @i{block} (@i{e.g.}, using @b{throw}, @b{go}, or @b{return-from}). @node Extended Loop, Loop Keywords, Simple Loop, Overview of the Loop Facility @subsubsection Extended Loop An extended @b{loop} @i{form} is one that has a body containing @i{atomic} @i{expressions}. When the @b{loop} @i{macro} processes such a @i{form}, it invokes a facility that is commonly called ``the Loop Facility.'' The Loop Facility provides standardized access to mechanisms commonly used in iterations through Loop schemas, which are introduced by @i{loop keywords}. The body of an extended @b{loop} @i{form} is divided into @b{loop} clauses, each which is in turn made up of @i{loop keywords} and @i{forms}. @node Loop Keywords, Parsing Loop Clauses, Extended Loop, Overview of the Loop Facility @subsubsection Loop Keywords @i{Loop keywords} are not true @i{keywords}_1; they are special @i{symbols}, recognized by @i{name} rather than @i{object} identity, that are meaningful only to the @b{loop} facility. A @i{loop keyword} is a @i{symbol} but is recognized by its @i{name} (not its identity), regardless of the @i{packages} in which it is @i{accessible}. In general, @i{loop keywords} are not @i{external symbols} of the @t{COMMON-LISP} @i{package}, except in the coincidental situation that a @i{symbol} with the same name as a @i{loop keyword} was needed for some other purpose in @r{Common Lisp}. For example, there is a @i{symbol} in the @t{COMMON-LISP} @i{package} whose @i{name} is @t{"UNLESS"} but not one whose @i{name} is @t{"UNTIL"}. If no @i{loop keywords} are supplied in a @b{loop} @i{form}, the Loop Facility executes the loop body repeatedly; see @ref{Simple Loop}. @node Parsing Loop Clauses, Expanding Loop Forms, Loop Keywords, Overview of the Loop Facility @subsubsection Parsing Loop Clauses The syntactic parts of an extended @b{loop} @i{form} are called clauses; the rules for parsing are determined by that clause's keyword. The following example shows a @b{loop} @i{form} with six clauses: @example (loop for i from 1 to (compute-top-value) ; first clause while (not (unacceptable i)) ; second clause collect (square i) ; third clause do (format t "Working on ~D now" i) ; fourth clause when (evenp i) ; fifth clause do (format t "~D is a non-odd number" i) finally (format t "About to exit!")) ; sixth clause @end example Each @i{loop keyword} introduces either a compound loop clause or a simple loop clause that can consist of a @i{loop keyword} followed by a single @i{form}. The number of @i{forms} in a clause is determined by the @i{loop keyword} that begins the clause and by the auxiliary keywords in the clause. The keywords @t{do}, @t{doing}, @t{initially}, and @t{finally} are the only loop keywords that can take any number of @i{forms} and group them as an @i{implicit progn}. Loop clauses can contain auxiliary keywords, which are sometimes called prepositions. For example, the first clause in the code above includes the prepositions @t{from} and @t{to}, which mark the value from which stepping begins and the value at which stepping ends. For detailed information about @b{loop} syntax, see the @i{macro} @b{loop}. @node Expanding Loop Forms, Summary of Loop Clauses, Parsing Loop Clauses, Overview of the Loop Facility @subsubsection Expanding Loop Forms A @b{loop} @i{macro form} expands into a @i{form} containing one or more binding forms (that @i{establish} @i{bindings} of loop variables) and a @b{block} and a @b{tagbody} (that express a looping control structure). The variables established in @b{loop} are bound as if by @b{let} or @b{lambda}. Implementations can interleave the setting of initial values with the @i{bindings}. However, the assignment of the initial values is always calculated in the order specified by the user. A variable is thus sometimes bound to a meaningless value of the correct @i{type}, and then later in the prologue it is set to the true initial value by using @b{setq}. One implication of this interleaving is that it is @i{implementation-dependent} whether the @i{lexical environment} in which the initial value @i{forms} (variously called the @i{form1}, @i{form2}, @i{form3}, @i{step-fun}, @i{vector}, @i{hash-table}, and @i{package}) in any @i{for-as-subclause}, except @i{for-as-equals-then}, are @i{evaluated} includes only the loop variables preceding that @i{form} or includes more or all of the loop variables; the @i{form1} and @i{form2} in a @i{for-as-equals-then} form includes the @i{lexical environment} of all the loop variables. After the @i{form} is expanded, it consists of three basic parts in the @b{tagbody}: the loop prologue, the loop body, and the loop epilogue. @table @asis @item @b{Loop prologue} The loop prologue contains @i{forms} that are executed before iteration begins, such as any automatic variable initializations prescribed by the @i{variable} clauses, along with any @t{initially} clauses in the order they appear in the source. @item @b{Loop body} The loop body contains those @i{forms} that are executed during iteration, including application-specific calculations, termination tests, and variable @i{stepping}_1. @item @b{Loop epilogue} The loop epilogue contains @i{forms} that are executed after iteration terminates, such as @t{finally} clauses, if any, along with any implicit return value from an @i{accumulation} clause or an @i{termination-test} clause. @end table Some clauses from the source @i{form} contribute code only to the loop prologue; these clauses must come before other clauses that are in the main body of the @b{loop} form. Others contribute code only to the loop epilogue. All other clauses contribute to the final translated @i{form} in the same order given in the original source @i{form} of the @b{loop}. Expansion of the @b{loop} macro produces an @i{implicit block} named @b{nil} unless @t{named} is supplied. Thus, @b{return-from} (and sometimes @b{return}) can be used to return values from @b{loop} or to exit @b{loop}. @node Summary of Loop Clauses, Summary of Variable Initialization and Stepping Clauses, Expanding Loop Forms, Overview of the Loop Facility @subsubsection Summary of Loop Clauses Loop clauses fall into one of the following categories: @node Summary of Variable Initialization and Stepping Clauses, Summary of Value Accumulation Clauses, Summary of Loop Clauses, Overview of the Loop Facility @subsubsection Summary of Variable Initialization and Stepping Clauses The @t{for} and @t{as} constructs provide iteration control clauses that establish a variable to be initialized. @t{for} and @t{as} clauses can be combined with the loop keyword @t{and} to get @i{parallel} initialization and @i{stepping}_1. Otherwise, the initialization and @i{stepping}_1 are @i{sequential}. The @t{with} construct is similar to a single @b{let} clause. @t{with} clauses can be combined using the @i{loop keyword} @t{and} to get @i{parallel} initialization. For more information, see @ref{Variable Initialization and Stepping Clauses}. @node Summary of Value Accumulation Clauses, Summary of Termination Test Clauses, Summary of Variable Initialization and Stepping Clauses, Overview of the Loop Facility @subsubsection Summary of Value Accumulation Clauses The @t{collect} (or @t{collecting}) construct takes one @i{form} in its clause and adds the value of that @i{form} to the end of a @i{list} of values. By default, the @i{list} of values is returned when the @b{loop} finishes. The @t{append} (or @t{appending}) construct takes one @i{form} in its clause and appends the value of that @i{form} to the end of a @i{list} of values. By default, the @i{list} of values is returned when the @b{loop} finishes. The @t{nconc} (or @t{nconcing}) construct is similar to the @t{append} construct, but its @i{list} values are concatenated as if by the function @t{nconc}. By default, the @i{list} of values is returned when the @b{loop} finishes. The @t{sum} (or @t{summing}) construct takes one @i{form} in its clause that must evaluate to a @i{number} and accumulates the sum of all these @i{numbers}. By default, the cumulative sum is returned when the @b{loop} finishes. The @t{count} (or @t{counting}) construct takes one @i{form} in its clause and counts the number of times that the @i{form} evaluates to @i{true}. By default, the count is returned when the @b{loop} finishes. The @t{minimize} (or @t{minimizing}) construct takes one @i{form} in its clause and determines the minimum value obtained by evaluating that @i{form}. By default, the minimum value is returned when the @b{loop} finishes. The @t{maximize} (or @t{maximizing}) construct takes one @i{form} in its clause and determines the maximum value obtained by evaluating that @i{form}. By default, the maximum value is returned when the @b{loop} finishes. For more information, see @ref{Value Accumulation Clauses}. @node Summary of Termination Test Clauses, Summary of Unconditional Execution Clauses, Summary of Value Accumulation Clauses, Overview of the Loop Facility @subsubsection Summary of Termination Test Clauses The @t{for} and @t{as} constructs provide a termination test that is determined by the iteration control clause. The @t{repeat} construct causes termination after a specified number of iterations. (It uses an internal variable to keep track of the number of iterations.) The @t{while} construct takes one @i{form}, a @i{test}, and terminates the iteration if the @i{test} evaluates to @i{false}. A @t{while} clause is equivalent to the expression @t{(if (not @i{test}) (loop-finish))}. The @t{until} construct is the inverse of @t{while}; it terminates the iteration if the @i{test} evaluates to any @i{non-nil} value. An @t{until} clause is equivalent to the expression @t{(if @i{test} (loop-finish))}. The @t{always} construct takes one @i{form} and terminates the @b{loop} if the @i{form} ever evaluates to @i{false}; in this case, the @b{loop} @i{form} returns @b{nil}. Otherwise, it provides a default return value of @b{t}. The @t{never} construct takes one @i{form} and terminates the @b{loop} if the @i{form} ever evaluates to @i{true}; in this case, the @b{loop} @i{form} returns @b{nil}. Otherwise, it provides a default return value of @b{t}. The @t{thereis} construct takes one @i{form} and terminates the @b{loop} if the @i{form} ever evaluates to a @i{non-nil} @i{object}; in this case, the @b{loop} @i{form} returns that @i{object}. Otherwise, it provides a default return value of @b{nil}. If multiple termination test clauses are specified, the @b{loop} @i{form} terminates if any are satisfied. For more information, see @ref{Termination Test Clauses}. @node Summary of Unconditional Execution Clauses, Summary of Conditional Execution Clauses, Summary of Termination Test Clauses, Overview of the Loop Facility @subsubsection Summary of Unconditional Execution Clauses The @t{do} (or @t{doing}) construct evaluates all @i{forms} in its clause. The @t{return} construct takes one @i{form}. Any @i{values} returned by the @i{form} are immediately returned by the @b{loop} form. It is equivalent to the clause @t{do (return-from @i{block-name} @i{value})}, where @i{block-name} is the name specified in a @t{named} clause, or @b{nil} if there is no @t{named} clause. For more information, see @ref{Unconditional Execution Clauses}. @node Summary of Conditional Execution Clauses, Summary of Miscellaneous Clauses, Summary of Unconditional Execution Clauses, Overview of the Loop Facility @subsubsection Summary of Conditional Execution Clauses The @t{if} and @t{when} constructs take one @i{form} as a test and a clause that is executed when the test @i{yields} @i{true}. The clause can be a value accumulation, unconditional, or another conditional clause; it can also be any combination of such clauses connected by the @b{loop} @t{and} keyword. The @b{loop} @t{unless} construct is similar to the @b{loop} @t{when} construct except that it complements the test result. The @b{loop} @t{else} construct provides an optional component of @t{if}, @t{when}, and @t{unless} clauses that is executed when an @t{if} or @t{when} test @i{yields} @i{false} or when an @t{unless} test @i{yields} @i{true}. The component is one of the clauses described under @t{if}. The @b{loop} @t{end} construct provides an optional component to mark the end of a conditional clause. For more information, see @ref{Conditional Execution Clauses}. @node Summary of Miscellaneous Clauses, Order of Execution, Summary of Conditional Execution Clauses, Overview of the Loop Facility @subsubsection Summary of Miscellaneous Clauses The @b{loop} @t{named} construct gives a name for the @i{block} of the loop. The @b{loop} @t{initially} construct causes its @i{forms} to be evaluated in the loop prologue, which precedes all @b{loop} code except for initial settings supplied by the constructs @t{with}, @t{for}, or @t{as}. The @b{loop} @t{finally} construct causes its @i{forms} to be evaluated in the loop epilogue after normal iteration terminates. For more information, see @ref{Miscellaneous Clauses}. @node Order of Execution, Destructuring, Summary of Miscellaneous Clauses, Overview of the Loop Facility @subsubsection Order of Execution @ITindex order of evaluation @ITindex evaluation order With the exceptions listed below, clauses are executed in the loop body in the order in which they appear in the source. Execution is repeated until a clause terminates the @b{loop} or until a @b{return}, @b{go}, or @b{throw} form is encountered which transfers control to a point outside of the loop. The following actions are exceptions to the linear order of execution: @table @asis @item @t{*} All variables are initialized first, regardless of where the establishing clauses appear in the source. The order of initialization follows the order of these clauses. @item @t{*} The code for any @t{initially} clauses is collected into one @b{progn} in the order in which the clauses appear in the source. The collected code is executed once in the loop prologue after any implicit variable initializations. @item @t{*} The code for any @t{finally} clauses is collected into one @b{progn} in the order in which the clauses appear in the source. The collected code is executed once in the loop epilogue before any implicit values from the accumulation clauses are returned. Explicit returns anywhere in the source, however, will exit the @b{loop} without executing the epilogue code. @item @t{*} A @t{with} clause introduces a variable @i{binding} and an optional initial value. The initial values are calculated in the order in which the @t{with} clauses occur. @item @t{*} Iteration control clauses implicitly perform the following actions: @table @asis @item -- initialize variables; @item -- @i{step} variables, generally between each execution of the loop body; @item -- perform termination tests, generally just before the execution of the loop body. @end table @end table @node Destructuring, Restrictions on Side-Effects, Order of Execution, Overview of the Loop Facility @subsubsection Destructuring The @i{d-type-spec} argument is used for destructuring. If the @i{d-type-spec} argument consists solely of the @i{type} @b{fixnum}, @b{float}, @b{t}, or @b{nil}, the @t{of-type} keyword is optional. The @t{of-type} construct is optional in these cases to provide backwards compatibility; thus, the following two expressions are the same: @example ;;; This expression uses the old syntax for type specifiers. (loop for i fixnum upfrom 3 ...) ;;; This expression uses the new syntax for type specifiers. (loop for i of-type fixnum upfrom 3 ...) ;; Declare X and Y to be of type VECTOR and FIXNUM respectively. (loop for (x y) of-type (vector fixnum) in l do ...) @end example A @i{type specifier} for a destructuring pattern is a @i{tree} of @i{type specifiers} with the same shape as the @i{tree} of @i{variable} @i{names}, with the following exceptions: @table @asis @item @t{*} When aligning the @i{trees}, an @i{atom} in the @i{tree} of @i{type specifiers} that matches a @i{cons} in the variable tree declares the same @i{type} for each variable in the subtree rooted at the @i{cons}. @item @t{*} A @i{cons} in the @i{tree} of @i{type specifiers} that matches an @i{atom} in the @i{tree} of @i{variable} @i{names} is a @i{compound type specifer}. @end table Destructuring allows @i{binding} of a set of variables to a corresponding set of values anywhere that a value can normally be bound to a single variable. During @b{loop} expansion, each variable in the variable list is matched with the values in the values list. If there are more variables in the variable list than there are values in the values list, the remaining variables are given a value of @b{nil}. If there are more values than variables listed, the extra values are discarded. To assign values from a list to the variables @t{a}, @t{b}, and @t{c}, the @t{for} clause could be used to bind the variable @t{numlist} to the @i{car} of the supplied @i{form}, and then another @t{for} clause could be used to bind the variables @t{a}, @t{b}, and @t{c} @i{sequentially}. @example ;; Collect values by using FOR constructs. (loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) for a of-type integer = (first numlist) and b of-type integer = (second numlist) and c of-type float = (third numlist) collect (list c b a)) @result{} ((4.0 2 1) (8.3 6 5) (10.4 9 8)) @end example Destructuring makes this process easier by allowing the variables to be bound in each loop iteration. @i{Types} can be declared by using a list of @i{type-spec} arguments. If all the @i{types} are the same, a shorthand destructuring syntax can be used, as the second example illustrates. @example ;; Destructuring simplifies the process. (loop for (a b c) of-type (integer integer float) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) @result{} ((4.0 2 1) (8.3 6 5) (10.4 9 8)) ;; If all the types are the same, this way is even simpler. (loop for (a b c) of-type float in '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4)) collect (list c b a)) @result{} ((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0)) @end example If destructuring is used to declare or initialize a number of groups of variables into @i{types}, the @i{loop keyword} @t{and} can be used to simplify the process further. @example ;; Initialize and declare variables in parallel by using the AND construct.\kern-7pt (loop with (a b) of-type float = '(1.0 2.0) and (c d) of-type integer = '(3 4) and (e f) return (list a b c d e f)) @result{} (1.0 2.0 3 4 NIL NIL) @end example If @b{nil} is used in a destructuring list, no variable is provided for its place. @example (loop for (a nil b) = '(1 2 3) do (return (list a b))) @result{} (1 3) @end example Note that @i{dotted lists} can specify destructuring. @example (loop for (x . y) = '(1 . 2) do (return y)) @result{} 2 (loop for ((a . b) (c . d)) of-type ((float . float) (integer . integer)) in '(((1.2 . 2.4) (3 . 4)) ((3.4 . 4.6) (5 . 6))) collect (list a b c d)) @result{} ((1.2 2.4 3 4) (3.4 4.6 5 6)) @end example An error of @i{type} @b{program-error} is signaled (at macro expansion time) if the same variable is bound twice in any variable-binding clause of a single @b{loop} expression. Such variables include local variables, iteration control variables, and variables found by destructuring. @node Restrictions on Side-Effects, , Destructuring, Overview of the Loop Facility @subsubsection Restrictions on Side-Effects See @ref{Traversal Rules and Side Effects}. @node Variable Initialization and Stepping Clauses, Value Accumulation Clauses, Overview of the Loop Facility, The LOOP Facility @subsection Variable Initialization and Stepping Clauses @menu * Iteration Control:: * The for-as-arithmetic subclause:: * Examples of for-as-arithmetic subclause:: * The for-as-in-list subclause:: * Examples of for-as-in-list subclause:: * The for-as-on-list subclause:: * Examples of for-as-on-list subclause:: * The for-as-equals-then subclause:: * Examples of for-as-equals-then subclause:: * The for-as-across subclause:: * Examples of for-as-across subclause:: * The for-as-hash subclause:: * The for-as-package subclause:: * Examples of for-as-package subclause:: * Local Variable Initializations:: * Examples of WITH clause:: @end menu @node Iteration Control, The for-as-arithmetic subclause, Variable Initialization and Stepping Clauses, Variable Initialization and Stepping Clauses @subsubsection Iteration Control Iteration control clauses allow direction of @b{loop} iteration. The @i{loop keywords} @t{for} and @t{as} designate iteration control clauses. Iteration control clauses differ with respect to the specification of termination tests and to the initialization and @i{stepping}_1 of loop variables. Iteration clauses by themselves do not cause the Loop Facility to return values, but they can be used in conjunction with value-accumulation clauses to return values. All variables are initialized in the loop prologue. A @i{variable} @i{binding} has @i{lexical scope} unless it is proclaimed @b{special}; thus, by default, the variable can be @i{accessed} only by @i{forms} that lie textually within the @b{loop}. Stepping assignments are made in the loop body before any other @i{forms} are evaluated in the body. The variable argument in iteration control clauses can be a destructuring list. A destructuring list is a @i{tree} whose @i{non-nil} @i{atoms} are @i{variable} @i{names}. See @ref{Destructuring}. The iteration control clauses @t{for}, @t{as}, and @t{repeat} must precede any other loop clauses, except @t{initially}, @t{with}, and @t{named}, since they establish variable @i{bindings}. When iteration control clauses are used in a @b{loop}, the corresponding termination tests in the loop body are evaluated before any other loop body code is executed. If multiple iteration clauses are used to control iteration, variable initialization and @i{stepping}_1 occur @i{sequentially} by default. The @t{and} construct can be used to connect two or more iteration clauses when @i{sequential} @i{binding} and @i{stepping}_1 are not necessary. The iteration behavior of clauses joined by @t{and} is analogous to the behavior of the macro @b{do} with respect to @b{do*}. The @t{for} and @t{as} clauses iterate by using one or more local loop variables that are initialized to some value and that can be modified or @i{stepped}_1 after each iteration. For these clauses, iteration terminates when a local variable reaches some supplied value or when some other loop clause terminates iteration. At each iteration, variables can be @i{stepped}_1 by an increment or a decrement or can be assigned a new value by the evaluation of a @i{form}). Destructuring can be used to assign values to variables during iteration. The @t{for} and @t{as} keywords are synonyms; they can be used interchangeably. There are seven syntactic formats for these constructs. In each syntactic format, the @i{type} of @i{var} can be supplied by the optional @i{type-spec} argument. If @i{var} is a destructuring list, the @i{type} supplied by the @i{type-spec} argument must appropriately match the elements of the list. By convention, @t{for} introduces new iterations and @t{as} introduces iterations that depend on a previous iteration specification. @node The for-as-arithmetic subclause, Examples of for-as-arithmetic subclause, Iteration Control, Variable Initialization and Stepping Clauses @subsubsection The for-as-arithmetic subclause In the @i{for-as-arithmetic} subclause, the @t{for} or @t{as} construct iterates from the value supplied by @i{form1} to the value supplied by @i{form2} in increments or decrements denoted by @i{form3}. Each expression is evaluated only once and must evaluate to a @i{number}. The variable @i{var} is bound to the value of @i{form1} in the first iteration and is @i{stepped}_1 by the value of @i{form3} in each succeeding iteration, or by 1 if @i{form3} is not provided. The following @i{loop keywords} serve as valid prepositions within this syntax. At least one of the prepositions must be used; and at most one from each line may be used in a single subclause. @table @asis @item from | downfrom | upfrom @item to | downto | upto | below | above @item by @end table The prepositional phrases in each subclause may appear in any order. For example, either ``@t{from x by y}'' or ``@t{by y from x}'' is permitted. However, because left-to-right order of evaluation is preserved, the effects will be different in the case of side effects. @ITindex order of evaluation @ITindex evaluation order Consider: @example (let ((x 1)) (loop for i from x by (incf x) to 10 collect i)) @result{} (1 3 5 7 9) (let ((x 1)) (loop for i by (incf x) from x to 10 collect i)) @result{} (2 4 6 8 10) @end example The descriptions of the prepositions follow: @table @asis @item from The @i{loop keyword} @t{from} specifies the value from which @i{stepping}_1 begins, as supplied by @i{form1}. @i{Stepping}_1 is incremental by default. If decremental @i{stepping}_1 is desired, the preposition @t{downto} or @t{above} must be used with @i{form2}. For incremental @i{stepping}_1, the default @t{from} value is 0. @item downfrom, upfrom The @i{loop keyword} @t{downfrom} indicates that the variable @i{var} is decreased in decrements supplied by @i{form3}; the @i{loop keyword} @t{upfrom} indicates that @i{var} is increased in increments supplied by @i{form3}. @item to The @i{loop keyword} @t{to} marks the end value for @i{stepping}_1 supplied in @i{form2}. @i{Stepping}_1 is incremental by default. If decremental @i{stepping}_1 is desired, the preposition @t{downfrom} must be used with @i{form1}, or else the preposition @t{downto} or @t{above} should be used instead of @t{to} with @i{form2}. @item downto, upto The @i{loop keyword} @t{downto} specifies decremental @i{stepping}; the @i{loop keyword} @t{upto} specifies incremental @i{stepping}. In both cases, the amount of change on each step is specified by @i{form3}, and the @b{loop} terminates when the variable @i{var} passes the value of @i{form2}. Since there is no default for @i{form1} in decremental @i{stepping}_1, a @i{form1} value must be supplied (using @t{from} or @t{downfrom}) when @t{downto} is supplied. @item below, above The @i{loop keywords} @t{below} and @t{above} are analogous to @t{upto} and @t{downto} respectively. These keywords stop iteration just before the value of the variable @i{var} reaches the value supplied by @i{form2}; the end value of @i{form2} is not included. Since there is no default for @i{form1} in decremental @i{stepping}_1, a @i{form1} value must be supplied (using @t{from} or @t{downfrom}) when @t{above} is supplied. @item by The @i{loop keyword} @t{by} marks the increment or decrement supplied by @i{form3}. The value of @i{form3} can be any positive @i{number}. The default value is 1. @end table In an iteration control clause, the @t{for} or @t{as} construct causes termination when the supplied limit is reached. That is, iteration continues until the value @i{var} is stepped to the exclusive or inclusive limit supplied by @i{form2}. The range is exclusive if @i{form3} increases or decreases @i{var} to the value of @i{form2} without reaching that value; the loop keywords @t{below} and @t{above} provide exclusive limits. An inclusive limit allows @i{var} to attain the value of @i{form2}; @t{to}, @t{downto}, and @t{upto} provide inclusive limits. @node Examples of for-as-arithmetic subclause, The for-as-in-list subclause, The for-as-arithmetic subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-arithmetic subclause @example ;; Print some numbers. (loop for i from 1 to 3 do (print i)) @t{ |> } 1 @t{ |> } 2 @t{ |> } 3 @result{} NIL ;; Print every third number. (loop for i from 10 downto 1 by 3 do (print i)) @t{ |> } 10 @t{ |> } 7 @t{ |> } 4 @t{ |> } 1 @result{} NIL ;; Step incrementally from the default starting value. (loop for i below 3 do (print i)) @t{ |> } 0 @t{ |> } 1 @t{ |> } 2 @result{} NIL @end example @node The for-as-in-list subclause, Examples of for-as-in-list subclause, Examples of for-as-arithmetic subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-in-list subclause In the @i{for-as-in-list} subclause, the @t{for} or @t{as} construct iterates over the contents of a @i{list}. It checks for the end of the @i{list} as if by using @b{endp}. The variable @i{var} is bound to the successive elements of the @i{list} in @i{form1} before each iteration. At the end of each iteration, the function @i{step-fun} is applied to the @i{list}; the default value for @i{step-fun} is @b{cdr}. The @i{loop keywords} @t{in} and @t{by} serve as valid prepositions in this syntax. The @t{for} or @t{as} construct causes termination when the end of the @i{list} is reached. @node Examples of for-as-in-list subclause, The for-as-on-list subclause, The for-as-in-list subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-in-list subclause @example ;; Print every item in a list. (loop for item in '(1 2 3) do (print item)) @t{ |> } 1 @t{ |> } 2 @t{ |> } 3 @result{} NIL ;; Print every other item in a list. (loop for item in '(1 2 3 4 5) by #'cddr do (print item)) @t{ |> } 1 @t{ |> } 3 @t{ |> } 5 @result{} NIL ;; Destructure a list, and sum the x values using fixnum arithmetic. (loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3)) unless (eq item 'B) sum x) @result{} 4 @end example @node The for-as-on-list subclause, Examples of for-as-on-list subclause, Examples of for-as-in-list subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-on-list subclause In the @i{for-as-on-list} subclause, the @t{for} or @t{as} construct iterates over a @i{list}. It checks for the end of the @i{list} as if by using @b{atom}. The variable @i{var} is bound to the successive tails of the @i{list} in @i{form1}. At the end of each iteration, the function @i{step-fun} is applied to the @i{list}; the default value for @i{step-fun} is @b{cdr}. The @i{loop keywords} @t{on} and @t{by} serve as valid prepositions in this syntax. The @t{for} or @t{as} construct causes termination when the end of the @i{list} is reached. @node Examples of for-as-on-list subclause, The for-as-equals-then subclause, The for-as-on-list subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-on-list subclause @example ;; Collect successive tails of a list. (loop for sublist on '(a b c d) collect sublist) @result{} ((A B C D) (B C D) (C D) (D)) ;; Print a list by using destructuring with the loop keyword ON. (loop for (item) on '(1 2 3) do (print item)) @t{ |> } 1 @t{ |> } 2 @t{ |> } 3 @result{} NIL @end example @node The for-as-equals-then subclause, Examples of for-as-equals-then subclause, Examples of for-as-on-list subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-equals-then subclause In the @i{for-as-equals-then} subclause the @t{for} or @t{as} construct initializes the variable @i{var} by setting it to the result of evaluating @i{form1} on the first iteration, then setting it to the result of evaluating @i{form2} on the second and subsequent iterations. If @i{form2} is omitted, the construct uses @i{form1} on the second and subsequent iterations. The @i{loop keywords} @r{=} and @t{then} serve as valid prepositions in this syntax. This construct does not provide any termination tests. @node Examples of for-as-equals-then subclause, The for-as-across subclause, The for-as-equals-then subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-equals-then subclause @example ;; Collect some numbers. (loop for item = 1 then (+ item 10) for iteration from 1 to 5 collect item) @result{} (1 11 21 31 41) @end example @node The for-as-across subclause, Examples of for-as-across subclause, Examples of for-as-equals-then subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-across subclause In the @i{for-as-across} subclause the @t{for} or @t{as} construct binds the variable @i{var} to the value of each element in the array @i{vector}. The @i{loop keyword} @t{across} marks the array @i{vector}; @t{across} is used as a preposition in this syntax. Iteration stops when there are no more elements in the supplied @i{array} that can be referenced. Some implementations might recognize a @b{the} special form in the @i{vector} form to produce more efficient code. @node Examples of for-as-across subclause, The for-as-hash subclause, The for-as-across subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-across subclause @example (loop for char across (the simple-string (find-message channel)) do (write-char char stream)) @end example @node The for-as-hash subclause, The for-as-package subclause, Examples of for-as-across subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-hash subclause In the @i{for-as-hash} subclause the @t{for} or @t{as} construct iterates over the elements, keys, and values of a @i{hash-table}. In this syntax, a compound preposition is used to designate access to a @i{hash table}. The variable @i{var} takes on the value of each hash key or hash value in the supplied @i{hash-table}. The following @i{loop keywords} serve as valid prepositions within this syntax: @table @asis @item @t{being} The keyword @t{being} introduces either the Loop schema @t{hash-key} or @t{hash-value}. @item @t{each}, @t{the} The @i{loop keyword} @t{each} follows the @i{loop keyword} @t{being} when @t{hash-key} or @t{hash-value} is used. The @i{loop keyword} @t{the} is used with @t{hash-keys} and @t{hash-values} only for ease of reading. This agreement isn't required. @item @t{hash-key}, @t{hash-keys} These @i{loop keywords} access each key entry of the @i{hash table}. If the name @t{hash-value} is supplied in a @t{using} construct with one of these Loop schemas, the iteration can optionally access the keyed value. The order in which the keys are accessed is undefined; empty slots in the @i{hash table} are ignored. @item @t{hash-value}, @t{hash-values} These @i{loop keywords} access each value entry of a @i{hash table}. If the name @t{hash-key} is supplied in a @t{using} construct with one of these Loop schemas, the iteration can optionally access the key that corresponds to the value. The order in which the keys are accessed is undefined; empty slots in the @i{hash table} are ignored. @item @t{using} The @i{loop keyword} @t{using} introduces the optional key or the keyed value to be accessed. It allows access to the hash key if iteration is over the hash values, and the hash value if iteration is over the hash keys. @item @t{in}, @t{of} These loop prepositions introduce @i{hash-table}. @end table In effect @t{being} @{@t{each} | @t{the}@} @{@t{hash-value} | @t{hash-values} | @t{hash-key} | @t{hash-keys}@} @{@t{in} | @t{of}@} is a compound preposition. Iteration stops when there are no more hash keys or hash values to be referenced in the supplied @i{hash-table}. @node The for-as-package subclause, Examples of for-as-package subclause, The for-as-hash subclause, Variable Initialization and Stepping Clauses @subsubsection The for-as-package subclause In the @i{for-as-package} subclause the @t{for} or @t{as} construct iterates over the @i{symbols} in a @i{package}. In this syntax, a compound preposition is used to designate access to a @i{package}. The variable @i{var} takes on the value of each @i{symbol} in the supplied @i{package}. The following @i{loop keywords} serve as valid prepositions within this syntax: @table @asis @item @t{being} The keyword @t{being} introduces either the Loop schema @t{symbol}, @t{present-symbol}, or @t{external-symbol}. @item @t{each}, @t{the} The @i{loop keyword} @t{each} follows the @i{loop keyword} @t{being} when @t{symbol}, @t{present-symbol}, or @t{external-symbol} is used. The @i{loop keyword} @t{the} is used with @t{symbols}, @t{present-symbols}, and @t{external-symbols} only for ease of reading. This agreement isn't required. @item @t{present-symbol}, @t{present-symbols} These Loop schemas iterate over the @i{symbols} that are @i{present} in a @i{package}. The @i{package} to be iterated over is supplied in the same way that @i{package} arguments to @b{find-package} are supplied. If the @i{package} for the iteration is not supplied, the @i{current package} is used. If a @i{package} that does not exist is supplied, an error of @i{type} @b{package-error} is signaled. @item @t{symbol}, @t{symbols} These Loop schemas iterate over @i{symbols} that are @i{accessible} in a given @i{package}. The @i{package} to be iterated over is supplied in the same way that @i{package} arguments to @b{find-package} are supplied. If the @i{package} for the iteration is not supplied, the @i{current package} is used. If a @i{package} that does not exist is supplied, an error of @i{type} @b{package-error} is signaled. @item @t{external-symbol}, @t{external-symbols} These Loop schemas iterate over the @i{external symbols} of a @i{package}. The @i{package} to be iterated over is supplied in the same way that @i{package} arguments to @b{find-package} are supplied. If the @i{package} for the iteration is not supplied, the @i{current package} is used. If a @i{package} that does not exist is supplied, an error of @i{type} @b{package-error} is signaled. @item @t{in}, @t{of} These loop prepositions introduce @i{package}. @end table In effect @t{being} @{@t{each} | @t{the}@} @{@t{symbol} | @t{symbols} | @t{present-symbol} | @t{present-symbols} | @t{external-symbol} | @t{external-symbols}@} @{@t{in} | @t{of}@} is a compound preposition. Iteration stops when there are no more @i{symbols} to be referenced in the supplied @i{package}. @node Examples of for-as-package subclause, Local Variable Initializations, The for-as-package subclause, Variable Initialization and Stepping Clauses @subsubsection Examples of for-as-package subclause @example (let ((*package* (make-package "TEST-PACKAGE-1"))) ;; For effect, intern some symbols (read-from-string "(THIS IS A TEST)") (export (intern "THIS")) (loop for x being each present-symbol of *package* do (print x))) @t{ |> } A @t{ |> } TEST @t{ |> } THIS @t{ |> } IS @result{} NIL @end example @node Local Variable Initializations, Examples of WITH clause, Examples of for-as-package subclause, Variable Initialization and Stepping Clauses @subsubsection Local Variable Initializations When a @b{loop} @i{form} is executed, the local variables are bound and are initialized to some value. These local variables exist until @b{loop} iteration terminates, at which point they cease to exist. Implicit variables are also established by iteration control clauses and the @t{into} preposition of accumulation clauses. The @t{with} construct initializes variables that are local to a loop. The variables are initialized one time only. If the optional @i{type-spec} argument is supplied for the variable @i{var}, but there is no related expression to be evaluated, @i{var} is initialized to an appropriate default value for its @i{type}. For example, for the types @b{t}, @b{number}, and @b{float}, the default values are @b{nil}, @t{0}, and @t{0.0} respectively. The consequences are undefined if a @i{type-spec} argument is supplied for @i{var} if the related expression returns a value that is not of the supplied @i{type}. By default, the @t{with} construct initializes variables @i{sequentially}; that is, one variable is assigned a value before the next expression is evaluated. However, by using the @i{loop keyword} @t{and} to join several @t{with} clauses, initializations can be forced to occur in @i{parallel}; that is, all of the supplied @i{forms} are evaluated, and the results are bound to the respective variables simultaneously. @i{Sequential} @i{binding} is used when it is desireable for the initialization of some variables to depend on the values of previously bound variables. For example, suppose the variables @t{a}, @t{b}, and @t{c} are to be bound in sequence: @example (loop with a = 1 with b = (+ a 2) with c = (+ b 3) return (list a b c)) @result{} (1 3 6) @end example The execution of the above @b{loop} is equivalent to the execution of the following code: @example (block nil (let* ((a 1) (b (+ a 2)) (c (+ b 3))) (tagbody (next-loop (return (list a b c)) (go next-loop) end-loop)))) @end example If the values of previously bound variables are not needed for the initialization of other local variables, an @t{and} clause can be used to specify that the bindings are to occur in @i{parallel}: @example (loop with a = 1 and b = 2 and c = 3 return (list a b c)) @result{} (1 2 3) @end example The execution of the above loop is equivalent to the execution of the following code: @example (block nil (let ((a 1) (b 2) (c 3)) (tagbody (next-loop (return (list a b c)) (go next-loop) end-loop)))) @end example @node Examples of WITH clause, , Local Variable Initializations, Variable Initialization and Stepping Clauses @subsubsection Examples of WITH clause @example ;; These bindings occur in sequence. (loop with a = 1 with b = (+ a 2) with c = (+ b 3) return (list a b c)) @result{} (1 3 6) ;; These bindings occur in parallel. (setq a 5 b 10) @result{} 10 (loop with a = 1 and b = (+ a 2) and c = (+ b 3) return (list a b c)) @result{} (1 7 13) ;; This example shows a shorthand way to declare local variables ;; that are of different types. (loop with (a b c) of-type (float integer float) return (format nil "~A ~A ~A" a b c)) @result{} "0.0 0 0.0" ;; This example shows a shorthand way to declare local variables ;; that are the same type. (loop with (a b c) of-type float return (format nil "~A ~A ~A" a b c)) @result{} "0.0 0.0 0.0" @end example @node Value Accumulation Clauses, Termination Test Clauses, Variable Initialization and Stepping Clauses, The LOOP Facility @subsection Value Accumulation Clauses The constructs @t{collect}, @t{collecting}, @t{append}, @t{appending}, @t{nconc}, @t{nconcing}, @t{count}, @t{counting}, @t{maximize}, @t{maximizing}, @t{minimize}, @t{minimizing}, @t{sum}, and @t{summing}, allow values to be accumulated in a @b{loop}. The constructs @t{collect}, @t{collecting}, @t{append}, @t{appending}, @t{nconc}, and @t{nconcing}, designate clauses that accumulate values in @i{lists} and return them. The constructs @t{count}, @t{counting}, @t{maximize}, @t{maximizing}, @t{minimize}, @t{minimizing}, @t{sum}, and @t{summing} designate clauses that accumulate and return numerical values. During each iteration, the constructs @t{collect} and @t{collecting} collect the value of the supplied @i{form} into a @i{list}. When iteration terminates, the @i{list} is returned. The argument @i{var} is set to the @i{list} of collected values; if @i{var} is supplied, the @b{loop} does not return the final @i{list} automatically. If @i{var} is not supplied, it is equivalent to supplying an internal name for @i{var} and returning its value in a @t{finally} clause. The @i{var} argument is bound as if by the construct @t{with}. No mechanism is provided for declaring the @i{type} of @i{var}; it must be of @i{type} @b{list}. The constructs @t{append}, @t{appending}, @t{nconc}, and @t{nconcing} are similar to @t{collect} except that the values of the supplied @i{form} must be @i{lists}. @table @asis @item @t{*} The @t{append} keyword causes its @i{list} values to be concatenated into a single @i{list}, as if they were arguments to the @i{function} @b{append}. @item @t{*} The @t{nconc} keyword causes its @i{list} values to be concatenated into a single @i{list}, as if they were arguments to the @i{function} @b{nconc}. @end table The argument @i{var} is set to the @i{list} of concatenated values; if @i{var} is supplied, @b{loop} does not return the final @i{list} automatically. The @i{var} argument is bound as if by the construct @t{with}. A @i{type} cannot be supplied for @i{var}; it must be of @i{type} @b{list}. The construct @t{nconc} destructively modifies its argument @i{lists}. The @t{count} construct counts the number of times that the supplied @i{form} returns @i{true}. The argument @i{var} accumulates the number of occurrences; if @i{var} is supplied, @b{loop} does not return the final count automatically. The @i{var} argument is bound as if by the construct @t{with} to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the function @b{1+}. If @t{into} @i{var} is used, a @i{type} can be supplied for @i{var} with the @i{type-spec} argument; the consequences are unspecified if a nonnumeric @i{type} is supplied. If there is no @t{into} variable, the optional @i{type-spec} argument applies to the internal variable that is keeping the count. The default @i{type} is @i{implementation-dependent}; but it must be a @i{supertype} of @i{type} @b{fixnum}. The @t{maximize} and @t{minimize} constructs compare the value of the supplied @i{form} obtained during the first iteration with values obtained in successive iterations. The maximum (for @t{maximize}) or minimum (for @t{minimize}) value encountered is determined (as if by the @i{function} @b{max} for @t{maximize} and as if by the @i{function} @b{min} for @t{minimize}) and returned. If the @t{maximize} or @t{minimize} clause is never executed, the accumulated value is unspecified. The argument @i{var} accumulates the maximum or minimum value; if @i{var} is supplied, @b{loop} does not return the maximum or minimum automatically. The @i{var} argument is bound as if by the construct @t{with}. If @t{into} @i{var} is used, a @i{type} can be supplied for @i{var} with the @i{type-spec} argument; the consequences are unspecified if a nonnumeric @i{type} is supplied. If there is no @t{into} variable, the optional @i{type-spec} argument applies to the internal variable that is keeping the maximum or minimum value. The default @i{type} is @i{implementation-dependent}; but it must be a @i{supertype} of @i{type} @b{real}. The @t{sum} construct forms a cumulative sum of the successive @i{primary values} of the supplied @i{form} at each iteration. The argument @i{var} is used to accumulate the sum; if @i{var} is supplied, @b{loop} does not return the final sum automatically. The @i{var} argument is bound as if by the construct @t{with} to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the @i{function} @b{+}. If @t{into} @i{var} is used, a @i{type} can be supplied for @i{var} with the @i{type-spec} argument; the consequences are unspecified if a nonnumeric @i{type} is supplied. If there is no @t{into} variable, the optional @i{type-spec} argument applies to the internal variable that is keeping the sum. The default @i{type} is @i{implementation-dependent}; but it must be a @i{supertype} of @i{type} @b{number}. If @t{into} is used, the construct does not provide a default return value; however, the variable is available for use in any @t{finally} clause. Certain kinds of accumulation clauses can be combined in a @b{loop} if their destination is the same (the result of @b{loop} or an @t{into} @i{var}) because they are considered to accumulate conceptually compatible quantities. In particular, any elements of following sets of accumulation clauses can be mixed with other elements of the same set for the same destination in a @b{loop} @i{form}: @table @asis @item @t{*} @t{collect}, @t{append}, @t{nconc} @item @t{*} @t{sum}, @t{count} @item @t{*} @t{maximize}, @t{minimize} @end table @example ;; Collect every name and the kids in one list by using ;; COLLECT and APPEND. (loop for name in '(fred sue alice joe june) for kids in '((bob ken) () () (kris sunshine) ()) collect name append kids) @result{} (FRED BOB KEN SUE ALICE JOE KRIS SUNSHINE JUNE) @end example Any two clauses that do not accumulate the same @i{type} of @i{object} can coexist in a @b{loop} only if each clause accumulates its values into a different @i{variable}. @menu * Examples of COLLECT clause:: * Examples of APPEND and NCONC clauses:: * Examples of COUNT clause:: * Examples of MAXIMIZE and MINIMIZE clauses:: * Examples of SUM clause:: @end menu @node Examples of COLLECT clause, Examples of APPEND and NCONC clauses, Value Accumulation Clauses, Value Accumulation Clauses @subsubsection Examples of COLLECT clause @example ;; Collect all the symbols in a list. (loop for i in '(bird 3 4 turtle (1 . 4) horse cat) when (symbolp i) collect i) @result{} (BIRD TURTLE HORSE CAT) ;; Collect and return odd numbers. (loop for i from 1 to 10 if (oddp i) collect i) @result{} (1 3 5 7 9) ;; Collect items into local variable, but don't return them. (loop for i in '(a b c d) by #'cddr collect i into my-list finally (print my-list)) @t{ |> } (A C) @result{} NIL @end example @node Examples of APPEND and NCONC clauses, Examples of COUNT clause, Examples of COLLECT clause, Value Accumulation Clauses @subsubsection Examples of APPEND and NCONC clauses @example ;; Use APPEND to concatenate some sublists. (loop for x in '((a) (b) ((c))) append x) @result{} (A B (C)) ;; NCONC some sublists together. Note that only lists made by the ;; call to LIST are modified. (loop for i upfrom 0 as x in '(a b (c)) nconc (if (evenp i) (list x) nil)) @result{} (A (C)) @end example @node Examples of COUNT clause, Examples of MAXIMIZE and MINIMIZE clauses, Examples of APPEND and NCONC clauses, Value Accumulation Clauses @subsubsection Examples of COUNT clause @example (loop for i in '(a b nil c nil d e) count i) @result{} 5 @end example @node Examples of MAXIMIZE and MINIMIZE clauses, Examples of SUM clause, Examples of COUNT clause, Value Accumulation Clauses @subsubsection Examples of MAXIMIZE and MINIMIZE clauses @example (loop for i in '(2 1 5 3 4) maximize i) @result{} 5 (loop for i in '(2 1 5 3 4) minimize i) @result{} 1 ;; In this example, FIXNUM applies to the internal variable that holds ;; the maximum value. (setq series '(1.2 4.3 5.7)) @result{} (1.2 4.3 5.7) (loop for v in series maximize (round v) of-type fixnum) @result{} 6 ;; In this example, FIXNUM applies to the variable RESULT. (loop for v of-type float in series minimize (round v) into result of-type fixnum finally (return result)) @result{} 1 @end example @node Examples of SUM clause, , Examples of MAXIMIZE and MINIMIZE clauses, Value Accumulation Clauses @subsubsection Examples of SUM clause @example (loop for i of-type fixnum in '(1 2 3 4 5) sum i) @result{} 15 (setq series '(1.2 4.3 5.7)) @result{} (1.2 4.3 5.7) (loop for v in series sum (* 2.0 v)) @result{} 22.4 @end example @node Termination Test Clauses, Unconditional Execution Clauses, Value Accumulation Clauses, The LOOP Facility @subsection Termination Test Clauses The @t{repeat} construct causes iteration to terminate after a specified number of times. The loop body executes @i{n} times, where @i{n} is the value of the expression @i{form}. The @i{form} argument is evaluated one time in the loop prologue. If the expression evaluates to 0 or to a negative @i{number}, the loop body is not evaluated. The constructs @t{always}, @t{never}, @t{thereis}, @t{while}, @t{until}, and the macro @b{loop-finish} allow conditional termination of iteration within a @b{loop}. The constructs @t{always}, @t{never}, and @t{thereis} provide specific values to be returned when a @b{loop} terminates. Using @t{always}, @t{never}, or @t{thereis} in a loop with value accumulation clauses that are not @t{into} causes an error of @i{type} @b{program-error} to be signaled (at macro expansion time). Since @t{always}, @t{never}, and @t{thereis} use the @b{return-from} @i{special operator} to terminate iteration, any @t{finally} clause that is supplied is not evaluated when exit occurs due to any of these constructs. In all other respects these constructs behave like the @t{while} and @t{until} constructs. The @t{always} construct takes one @i{form} and terminates the @b{loop} if the @i{form} ever evaluates to @b{nil}; in this case, it returns @b{nil}. Otherwise, it provides a default return value of @b{t}. If the value of the supplied @i{form} is never @b{nil}, some other construct can terminate the iteration. The @t{never} construct terminates iteration the first time that the value of the supplied @i{form} is @i{non-nil}; the @b{loop} returns @b{nil}. If the value of the supplied @i{form} is always @b{nil}, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is @b{t}. The @t{thereis} construct terminates iteration the first time that the value of the supplied @i{form} is @i{non-nil}; the @b{loop} returns the value of the supplied @i{form}. If the value of the supplied @i{form} is always @b{nil}, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is @b{nil}. There are two differences between the @t{thereis} and @t{until} constructs: @table @asis @item @t{*} The @t{until} construct does not return a value or @b{nil} based on the value of the supplied @i{form}. @item @t{*} The @t{until} construct executes any @t{finally} clause. Since @t{thereis} uses the @b{return-from} @i{special operator} to terminate iteration, any @t{finally} clause that is supplied is not evaluated when exit occurs due to @t{thereis}. @end table The @t{while} construct allows iteration to continue until the supplied @i{form} evaluates to @i{false}. The supplied @i{form} is reevaluated at the location of the @t{while} clause. The @t{until} construct is equivalent to @t{while (not @i{form})\dots}. If the value of the supplied @i{form} is @i{non-nil}, iteration terminates. Termination-test control constructs can be used anywhere within the loop body. The termination tests are used in the order in which they appear. If an @t{until} or @t{while} clause causes termination, any clauses that precede it in the source are still evaluated. If the @t{until} and @t{while} constructs cause termination, control is passed to the loop epilogue, where any @t{finally} clauses will be executed. There are two differences between the @t{never} and @t{until} constructs: @table @asis @item @t{*} The @t{until} construct does not return @b{t} or @b{nil} based on the value of the supplied @i{form}. @item @t{*} The @t{until} construct does not bypass any @t{finally} clauses. Since @t{never} uses the @b{return-from} @i{special operator} to terminate iteration, any @t{finally} clause that is supplied is not evaluated when exit occurs due to @t{never}. @end table In most cases it is not necessary to use @b{loop-finish} because other loop control clauses terminate the @b{loop}. The macro @b{loop-finish} is used to provide a normal exit from a nested conditional inside a @b{loop}. Since @b{loop-finish} transfers control to the loop epilogue, using @b{loop-finish} within a @t{finally} expression can cause infinite looping. @menu * Examples of REPEAT clause:: * Examples of ALWAYS:: * Examples of WHILE and UNTIL clauses:: @end menu @node Examples of REPEAT clause, Examples of ALWAYS, Termination Test Clauses, Termination Test Clauses @subsubsection Examples of REPEAT clause @example (loop repeat 3 do (format t "~&What I say three times is true.~ @t{ |> } What I say three times is true. @t{ |> } What I say three times is true. @t{ |> } What I say three times is true. @result{} NIL (loop repeat -15 do (format t "What you see is what you expect~ @result{} NIL @end example @node Examples of ALWAYS, Examples of WHILE and UNTIL clauses, Examples of REPEAT clause, Termination Test Clauses @subsubsection Examples of ALWAYS, NEVER, and THEREIS clauses @example ;; Make sure I is always less than 11 (two ways). ;; The FOR construct terminates these loops. (loop for i from 0 to 10 always (< i 11)) @result{} T (loop for i from 0 to 10 never (> i 11)) @result{} T ;; If I exceeds 10 return I; otherwise, return NIL. ;; The THEREIS construct terminates this loop. (loop for i from 0 thereis (when (> i 10) i) ) @result{} 11 ;;; The FINALLY clause is not evaluated in these examples. (loop for i from 0 to 10 always (< i 9) finally (print "you won't see this")) @result{} NIL (loop never t finally (print "you won't see this")) @result{} NIL (loop thereis "Here is my value" finally (print "you won't see this")) @result{} "Here is my value" ;; The FOR construct terminates this loop, so the FINALLY clause ;; is evaluated. (loop for i from 1 to 10 thereis (> i 11) finally (prin1 'got-here)) @t{ |> } GOT-HERE @result{} NIL ;; If this code could be used to find a counterexample to Fermat's ;; last theorem, it would still not return the value of the ;; counterexample because all of the THEREIS clauses in this example ;; only return T. But if Fermat is right, that won't matter ;; because this won't terminate. (loop for z upfrom 2 thereis (loop for n upfrom 3 below (log z 2) thereis (loop for x below z thereis (loop for y below z thereis (= (+ (expt x n) (expt y n)) (expt z n)))))) @end example @node Examples of WHILE and UNTIL clauses, , Examples of ALWAYS, Termination Test Clauses @subsubsection Examples of WHILE and UNTIL clauses @example (loop while (hungry-p) do (eat)) ;; UNTIL NOT is equivalent to WHILE. (loop until (not (hungry-p)) do (eat)) ;; Collect the length and the items of STACK. (let ((stack '(a b c d e f))) (loop for item = (length stack) then (pop stack) collect item while stack)) @result{} (6 A B C D E F) ;; Use WHILE to terminate a loop that otherwise wouldn't terminate. ;; Note that WHILE occurs after the WHEN. (loop for i fixnum from 3 when (oddp i) collect i while (< i 5)) @result{} (3 5) @end example @node Unconditional Execution Clauses, Conditional Execution Clauses, Termination Test Clauses, The LOOP Facility @subsection Unconditional Execution Clauses The @t{do} and @t{doing} constructs evaluate the supplied @i{forms} wherever they occur in the expanded form of @b{loop}. The @i{form} argument can be any @i{compound form}. Each @i{form} is evaluated in every iteration. Because every loop clause must begin with a @i{loop keyword}, the keyword @t{do} is used when no control action other than execution is required. The @t{return} construct takes one @i{form}. Any @i{values} returned by the @i{form} are immediately returned by the @b{loop} form. It is equivalent to the clause @t{do (return-from @i{block-name} @i{value})}, where @i{block-name} is the name specified in a @t{named} clause, or @b{nil} if there is no @t{named} clause. @menu * Examples of unconditional execution:: @end menu @node Examples of unconditional execution, , Unconditional Execution Clauses, Unconditional Execution Clauses @subsubsection Examples of unconditional execution @example ;; Print numbers and their squares. ;; The DO construct applies to multiple forms. (loop for i from 1 to 3 do (print i) (print (* i i))) @t{ |> } 1 @t{ |> } 1 @t{ |> } 2 @t{ |> } 4 @t{ |> } 3 @t{ |> } 9 @result{} NIL @end example @node Conditional Execution Clauses, Miscellaneous Clauses, Unconditional Execution Clauses, The LOOP Facility @subsection Conditional Execution Clauses The @t{if}, @t{when}, and @t{unless} constructs establish conditional control in a @b{loop}. If the test passes, the succeeding loop clause is executed. If the test does not pass, the succeeding clause is skipped, and program control moves to the clause that follows the @i{loop keyword} @t{else}. If the test does not pass and no @t{else} clause is supplied, control is transferred to the clause or construct following the entire conditional clause. If conditional clauses are nested, each @t{else} is paired with the closest preceding conditional clause that has no associated @t{else} or @t{end}. In the @t{if} and @t{when} clauses, which are synonymous, the test passes if the value of @i{form} is @i{true}. In the @t{unless} clause, the test passes if the value of @i{form} is @i{false}. Clauses that follow the test expression can be grouped by using the @i{loop keyword} @t{and} to produce a conditional block consisting of a compound clause. The @i{loop keyword} @t{it} can be used to refer to the result of the test expression in a clause. Use the @i{loop keyword} @t{it} in place of the form in a @t{return} clause or an @i{accumulation} clause that is inside a conditional execution clause. If multiple clauses are connected with @t{and}, the @t{it} construct must be in the first clause in the block. The optional @i{loop keyword} @t{end} marks the end of the clause. If this keyword is not supplied, the next @i{loop keyword} marks the end. The construct @t{end} can be used to distinguish the scoping of compound clauses. @menu * Examples of WHEN clause:: @end menu @node Examples of WHEN clause, , Conditional Execution Clauses, Conditional Execution Clauses @subsubsection Examples of WHEN clause @example ;; Signal an exceptional condition. (loop for item in '(1 2 3 a 4 5) when (not (numberp item)) return (cerror "enter new value" "non-numeric value: ~s" item)) Error: non-numeric value: A ;; The previous example is equivalent to the following one. (loop for item in '(1 2 3 a 4 5) when (not (numberp item)) do (return (cerror "Enter new value" "non-numeric value: ~s" item))) Error: non-numeric value: A @end example @example ;; This example parses a simple printed string representation from ;; BUFFER (which is itself a string) and returns the index of the ;; closing double-quote character. (let ((buffer "\"a\" \"b\"")) (loop initially (unless (char= (char buffer 0) #\") (loop-finish)) for i of-type fixnum from 1 below (length (the string buffer)) when (char= (char buffer i) #\") return i)) @result{} 2 ;; The collected value is returned. (loop for i from 1 to 10 when (> i 5) collect i finally (prin1 'got-here)) @t{ |> } GOT-HERE @result{} (6 7 8 9 10) ;; Return both the count of collected numbers and the numbers. (loop for i from 1 to 10 when (> i 5) collect i into number-list and count i into number-count finally (return (values number-count number-list))) @result{} 5, (6 7 8 9 10) @end example @node Miscellaneous Clauses, Examples of Miscellaneous Loop Features, Conditional Execution Clauses, The LOOP Facility @subsection Miscellaneous Clauses @menu * Control Transfer Clauses:: * Examples of NAMED clause:: * Initial and Final Execution:: @end menu @node Control Transfer Clauses, Examples of NAMED clause, Miscellaneous Clauses, Miscellaneous Clauses @subsubsection Control Transfer Clauses The @t{named} construct establishes a name for an @i{implicit block} surrounding the entire @b{loop} so that the @b{return-from} @i{special operator} can be used to return values from or to exit @b{loop}. Only one name per @b{loop} @i{form} can be assigned. If used, the @t{named} construct must be the first clause in the loop expression. The @t{return} construct takes one @i{form}. Any @i{values} returned by the @i{form} are immediately returned by the @b{loop} form. This construct is similar to the @b{return-from} @i{special operator} and the @b{return} @i{macro}. The @t{return} construct does not execute any @t{finally} clause that the @b{loop} @i{form} is given. @node Examples of NAMED clause, Initial and Final Execution, Control Transfer Clauses, Miscellaneous Clauses @subsubsection Examples of NAMED clause @example ;; Just name and return. (loop named max for i from 1 to 10 do (print i) do (return-from max 'done)) @t{ |> } 1 @result{} DONE @end example @node Initial and Final Execution, , Examples of NAMED clause, Miscellaneous Clauses @subsubsection Initial and Final Execution The @t{initially} and @t{finally} constructs evaluate forms that occur before and after the loop body. The @t{initially} construct causes the supplied @i{compound-forms} to be evaluated in the loop prologue, which precedes all loop code except for initial settings supplied by constructs @t{with}, @t{for}, or @t{as}. The code for any @t{initially} clauses is executed in the order in which the clauses appeared in the @b{loop}. The @t{finally} construct causes the supplied @i{compound-forms} to be evaluated in the loop epilogue after normal iteration terminates. The code for any @t{finally} clauses is executed in the order in which the clauses appeared in the @b{loop}. The collected code is executed once in the loop epilogue before any implicit values are returned from the accumulation clauses. An explicit transfer of control (@i{e.g.}, by @b{return}, @b{go}, or @b{throw}) from the loop body, however, will exit the @b{loop} without executing the epilogue code. Clauses such as @t{return}, @t{always}, @t{never}, and @t{thereis} can bypass the @t{finally} clause. @b{return} (or @b{return-from}, if the @t{named} option was supplied) can be used after @t{finally} to return values from a @b{loop}. Such an @i{explicit return} inside the @t{finally} clause takes precedence over returning the accumulation from clauses supplied by such keywords as @t{collect}, @t{nconc}, @t{append}, @t{sum}, @t{count}, @t{maximize}, and @t{minimize}; the accumulation values for these preempted clauses are not returned by @b{loop} if @b{return} or @b{return-from} is used. @node Examples of Miscellaneous Loop Features, Notes about Loop, Miscellaneous Clauses, The LOOP Facility @subsection Examples of Miscellaneous Loop Features @example (let ((i 0)) ; no loop keywords are used (loop (incf i) (if (= i 3) (return i)))) @result{} 3 (let ((i 0)(j 0)) (tagbody (loop (incf j 3) (incf i) (if (= i 3) (go exit))) exit) j) @result{} 9 @end example In the following example, the variable @t{x} is stepped before @t{y} is stepped; thus, the value of @t{y} reflects the updated value of @t{x}: @example (loop for x from 1 to 10 for y = nil then x collect (list x y)) @result{} ((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10)) @end example In this example, @t{x} and @t{y} are stepped in @i{parallel}: @example (loop for x from 1 to 10 and y = nil then x collect (list x y)) @result{} ((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9)) @end example @menu * Examples of clause grouping:: @end menu @node Examples of clause grouping, , Examples of Miscellaneous Loop Features, Examples of Miscellaneous Loop Features @subsubsection Examples of clause grouping @example ;; Group conditional clauses. (loop for i in '(1 324 2345 323 2 4 235 252) when (oddp i) do (print i) and collect i into odd-numbers and do (terpri) else ; I is even. collect i into even-numbers finally (return (values odd-numbers even-numbers))) @t{ |> } 1 @t{ |> } @t{ |> } 2345 @t{ |> } @t{ |> } 323 @t{ |> } @t{ |> } 235 @result{} (1 2345 323 235), (324 2 4 252) ;; Collect numbers larger than 3. (loop for i in '(1 2 3 4 5 6) when (and (> i 3) i) collect it) ; IT refers to (and (> i 3) i). @result{} (4 5 6) ;; Find a number in a list. (loop for i in '(1 2 3 4 5 6) when (and (> i 3) i) return it) @result{} 4 ;; The above example is similar to the following one. (loop for i in '(1 2 3 4 5 6) thereis (and (> i 3) i)) @result{} 4 ;; Nest conditional clauses. (let ((list '(0 3.0 apple 4 5 9.8 orange banana))) (loop for i in list when (numberp i) when (floatp i) collect i into float-numbers else ; Not (floatp i) collect i into other-numbers else ; Not (numberp i) when (symbolp i) collect i into symbol-list else ; Not (symbolp i) do (error "found a funny value in list ~S, value ~S~ finally (return (values float-numbers other-numbers symbol-list)))) @result{} (3.0 9.8), (0 4 5), (APPLE ORANGE BANANA) ;; Without the END preposition, the last AND would apply to the ;; inner IF rather than the outer one. (loop for x from 0 to 3 do (print x) if (zerop (mod x 2)) do (princ " a") and if (zerop (floor x 2)) do (princ " b") end and do (princ " c")) @t{ |> } 0 a b c @t{ |> } 1 @t{ |> } 2 a c @t{ |> } 3 @result{} NIL @end example @node Notes about Loop, , Examples of Miscellaneous Loop Features, The LOOP Facility @subsection Notes about Loop @i{Types} can be supplied for loop variables. It is not necessary to supply a @i{type} for any variable, but supplying the @i{type} can ensure that the variable has a correctly typed initial value, and it can also enable compiler optimizations (depending on the @i{implementation}). The clause @t{repeat} @i{n} ... is roughly equivalent to a clause such as @example (loop for @i{internal-variable} downfrom (- @i{n} 1) to 0 ...) @end example but in some @i{implementations}, the @t{repeat} construct might be more efficient. Within the executable parts of the loop clauses and around the entire @b{loop} form, variables can be bound by using @b{let}. Use caution when using a variable named @t{IT} (in any @i{package}) in connection with @b{loop}, since @t{it} is a @i{loop keyword} that can be used in place of a @i{form} in certain contexts. There is no @i{standardized} mechanism for users to add extensions to @b{loop}. @c end of including concept-loop @node Iteration Dictionary, , The LOOP Facility, Iteration @section Iteration Dictionary @c including dict-iteration @menu * do:: * dotimes:: * dolist:: * loop:: * loop-finish:: @end menu @node do, dotimes, Iteration Dictionary, Iteration Dictionary @subsection do, do* [Macro] @code{do} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} @r{(}end-test-form @{@i{result-form}@}*@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @code{do*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} @r{(}end-test-form @r{@{@i{result-form}@}*}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{symbol}. @i{init-form}---a @i{form}. @i{step-form}---a @i{form}. @i{end-test-form}---a @i{form}. @i{result-forms}---an @i{implicit progn}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @i{results}---if a @b{return} or @b{return-from} form is executed, the @i{values} passed from that @i{form}; otherwise, the @i{values} returned by the @i{result-forms}. @subsubheading Description:: @b{do} iterates over a group of @i{statements} while a test condition holds. @b{do} accepts an arbitrary number of iteration @i{vars} which are bound within the iteration and stepped in parallel. An initial value may be supplied for each iteration variable by use of an @i{init-form}. @i{Step-forms} may be used to specify how the @i{vars} should be updated on succeeding iterations through the loop. @i{Step-forms} may be used both to generate successive values or to accumulate results. If the @i{end-test-form} condition is met prior to an execution of the body, the iteration terminates. @i{Tags} label @i{statements}. @b{do*} is exactly like @b{do} except that the @i{bindings} and steppings of the @i{vars} are performed sequentially rather than in parallel. Before the first iteration, all the @i{init-forms} are evaluated, and each @i{var} is bound to the value of its respective @i{init-form}, if supplied. This is a @i{binding}, not an assignment; when the loop terminates, the old values of those variables will be restored. For @b{do}, all of the @i{init-forms} are evaluated before any @i{var} is bound. The @i{init-forms} can refer to the @i{bindings} of the @i{vars} visible before beginning execution of @b{do}. For @b{do*}, the first @i{init-form} is evaluated, then the first @i{var} is bound to that value, then the second @i{init-form} is evaluated, then the second @i{var} is bound, and so on; in general, the @i{k}th @i{init-form} can refer to the new binding of the @i{j}th @i{var} if @i{j} < @i{k}, and otherwise to the old binding of the @i{j}th @i{var}. At the beginning of each iteration, after processing the variables, the @i{end-test-form} is evaluated. If the result is @i{false}, execution proceeds with the body of the @b{do} (or @b{do*}) form. If the result is @i{true}, the @i{result-forms} are evaluated in order as an @i{implicit progn}, and then @b{do} or @b{do*} returns. At the beginning of each iteration other than the first, @i{vars} are updated as follows. All the @i{step-forms}, if supplied, are evaluated, from left to right, and the resulting values are assigned to the respective @i{vars}. Any @i{var} that has no associated @i{step-form} is not assigned to. For @b{do}, all the @i{step-forms} are evaluated before any @i{var} is updated; the assignment of values to @i{vars} is done in parallel, as if by @b{psetq}. Because all of the @i{step-forms} are evaluated before any of the @i{vars} are altered, a @i{step-form} when evaluated always has access to the old values of all the @i{vars}, even if other @i{step-forms} precede it. For @b{do*}, the first @i{step-form} is evaluated, then the value is assigned to the first @i{var}, then the second @i{step-form} is evaluated, then the value is assigned to the second @i{var}, and so on; the assignment of values to variables is done sequentially, as if by @b{setq}. For either @b{do} or @b{do*}, after the @i{vars} have been updated, the @i{end-test-form} is evaluated as described above, and the iteration continues. The remainder of the @b{do} (or @b{do*}) form constitutes an @i{implicit tagbody}. @i{Tags} may appear within the body of a @b{do} loop for use by @b{go} statements appearing in the body (but such @b{go} statements may not appear in the variable specifiers, the @i{end-test-form}, or the @i{result-forms}). When the end of a @b{do} body is reached, the next iteration cycle (beginning with the evaluation of @i{step-forms}) occurs. An @i{implicit block} named @b{nil} surrounds the entire @b{do} (or @b{do*}) form. A @b{return} statement may be used at any point to exit the loop immediately. @i{Init-form} is an initial value for the @i{var} with which it is associated. If @i{init-form} is omitted, the initial value of @i{var} is @b{nil}. If a @i{declaration} is supplied for a @i{var}, @i{init-form} must be consistent with the @i{declaration}. @i{Declarations} can appear at the beginning of a @b{do} (or @b{do*}) body. They apply to code in the @b{do} (or @b{do*}) body, to the @i{bindings} of the @b{do} (or @b{do*}) @i{vars}, to the @i{step-forms}, to the @i{end-test-form}, and to the @i{result-forms}. @subsubheading Examples:: @example (do ((temp-one 1 (1+ temp-one)) (temp-two 0 (1- temp-two))) ((> (- temp-one temp-two) 5) temp-one)) @result{} 4 (do ((temp-one 1 (1+ temp-one)) (temp-two 0 (1+ temp-one))) ((= 3 temp-two) temp-one)) @result{} 3 (do* ((temp-one 1 (1+ temp-one)) (temp-two 0 (1+ temp-one))) ((= 3 temp-two) temp-one)) @result{} 2 (do ((j 0 (+ j 1))) (nil) ;Do forever. (format t "~ (let ((item (read))) (if (null item) (return) ;Process items until NIL seen. (format t "~&Output ~D: ~S" j item)))) @t{ |> } Input 0: @b{|>>}@t{banana}@b{<<|} @t{ |> } Output 0: BANANA @t{ |> } Input 1: @b{|>>}@t{(57 boxes)}@b{<<|} @t{ |> } Output 1: (57 BOXES) @t{ |> } Input 2: @b{|>>}@t{NIL}@b{<<|} @result{} NIL (setq a-vector (vector 1 nil 3 nil)) (do ((i 0 (+ i 1)) ;Sets every null element of a-vector to zero. (n (array-dimension a-vector 0))) ((= i n)) (when (null (aref a-vector i)) (setf (aref a-vector i) 0))) @result{} NIL a-vector @result{} #(1 0 3 0) @end example @example (do ((x e (cdr x)) (oldx x x)) ((null x)) body) @end example is an example of parallel assignment to index variables. On the first iteration, the value of @t{oldx} is whatever value @t{x} had before the @b{do} was entered. On succeeding iterations, @t{oldx} contains the value that @t{x} had on the previous iteration. @example (do ((x foo (cdr x)) (y bar (cdr y)) (z '() (cons (f (car x) (car y)) z))) ((or (null x) (null y)) (nreverse z))) @end example does the same thing as @t{(mapcar #'f foo bar)}. The step computation for @t{z} is an example of the fact that variables are stepped in parallel. Also, the body of the loop is empty. @example (defun list-reverse (list) (do ((x list (cdr x)) (y '() (cons (car x) y))) ((endp x) y))) @end example As an example of nested iterations, consider a data structure that is a @i{list} of @i{conses}. The @i{car} of each @i{cons} is a @i{list} of @i{symbols}, and the @i{cdr} of each @i{cons} is a @i{list} of equal length containing corresponding values. Such a data structure is similar to an association list, but is divided into ``frames''; the overall structure resembles a rib-cage. A lookup function on such a data structure might be: @example (defun ribcage-lookup (sym ribcage) (do ((r ribcage (cdr r))) ((null r) nil) (do ((s (caar r) (cdr s)) (v (cdar r) (cdr v))) ((null s)) (when (eq (car s) sym) (return-from ribcage-lookup (car v)))))) @result{} RIBCAGE-LOOKUP @end example @subsubheading See Also:: other iteration functions ( @ref{dolist} , @ref{dotimes} , and @ref{loop} ) and more primitive functionality ( @ref{tagbody} , @ref{go} , @ref{block} , @ref{return} , @ref{let} , and @ref{setq} ) @subsubheading Notes:: If @i{end-test-form} is @b{nil}, the test will never succeed. This provides an idiom for ``do forever'': the body of the @b{do} or @b{do*} is executed repeatedly. The infinite loop can be terminated by the use of @b{return}, @b{return-from}, @b{go} to an outer level, or @b{throw}. A @b{do} @i{form} may be explained in terms of the more primitive @i{forms} @b{block}, @b{return}, @b{let}, @b{loop}, @b{tagbody}, and @b{psetq} as follows: @example (block nil (let ((var1 init1) (var2 init2) ... (varn initn)) @i{declarations} (loop (when end-test (return (progn . result))) (tagbody . tagbody) (psetq var1 step1 var2 step2 ... varn stepn)))) @end example @b{do*} is similar, except that @b{let*} and @b{setq} replace the @b{let} and @b{psetq}, respectively. @node dotimes, dolist, do, Iteration Dictionary @subsection dotimes [Macro] @code{dotimes} @i{@r{(}var count-form @r{[}result-form@r{]}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{symbol}. @i{count-form}---a @i{form}. @i{result-form}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @i{results}---if a @b{return} or @b{return-from} form is executed, the @i{values} passed from that @i{form}; otherwise, the @i{values} returned by the @i{result-form} or @b{nil} if there is no @i{result-form}. @subsubheading Description:: @b{dotimes} iterates over a series of @i{integers}. @b{dotimes} evaluates @i{count-form}, which should produce an @i{integer}. If @i{count-form} is zero or negative, the body is not executed. @b{dotimes} then executes the body once for each @i{integer} from 0 up to but not including the value of @i{count-form}, in the order in which the @i{tags} and @i{statements} occur, with @i{var} bound to each @i{integer}. Then @i{result-form} is evaluated. At the time @i{result-form} is processed, @i{var} is bound to the number of times the body was executed. @i{Tags} label @i{statements}. An @i{implicit block} named @b{nil} surrounds @b{dotimes}. @b{return} may be used to terminate the loop immediately without performing any further iterations, returning zero or more @i{values}. The body of the loop is an @i{implicit tagbody}; it may contain tags to serve as the targets of @b{go} statements. Declarations may appear before the body of the loop. The @i{scope} of the binding of @i{var} does not include the @i{count-form}, but the @i{result-form} is included. It is @i{implementation-dependent} whether @b{dotimes} @i{establishes} a new @i{binding} of @i{var} on each iteration or whether it @i{establishes} a binding for @i{var} once at the beginning and then @i{assigns} it on any subsequent iterations. @subsubheading Examples:: @example (dotimes (temp-one 10 temp-one)) @result{} 10 (setq temp-two 0) @result{} 0 (dotimes (temp-one 10 t) (incf temp-two)) @result{} T temp-two @result{} 10 @end example Here is an example of the use of @t{dotimes} in processing strings: @example ;;; True if the specified subsequence of the string is a ;;; palindrome (reads the same forwards and backwards). (defun palindromep (string @t{&optional} (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil)))) (palindromep "Able was I ere I saw Elba") @result{} T (palindromep "A man, a plan, a canal--Panama!") @result{} NIL (remove-if-not #'alpha-char-p ;Remove punctuation. "A man, a plan, a canal--Panama!") @result{} "AmanaplanacanalPanama" (palindromep (remove-if-not #'alpha-char-p "A man, a plan, a canal--Panama!")) @result{} T (palindromep (remove-if-not #'alpha-char-p "Unremarkable was I ere I saw Elba Kramer, nu?")) @result{} T (palindromep (remove-if-not #'alpha-char-p "A man, a plan, a cat, a ham, a yak, a yam, a hat, a canal--Panama!")) @result{} T @end example @subsubheading See Also:: @ref{do} , @ref{dolist} , @ref{tagbody} @subsubheading Notes:: @b{go} may be used within the body of @b{dotimes} to transfer control to a statement labeled by a @i{tag}. @node dolist, loop, dotimes, Iteration Dictionary @subsection dolist [Macro] @code{dolist} @i{@r{(}var list-form @r{[}result-form@r{]}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{symbol}. @i{list-form}---a @i{form}. @i{result-form}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @i{results}---if a @b{return} or @b{return-from} form is executed, the @i{values} passed from that @i{form}; otherwise, the @i{values} returned by the @i{result-form} or @b{nil} if there is no @i{result-form}. @subsubheading Description:: @b{dolist} iterates over the elements of a @i{list}. The body of @b{dolist} is like a @b{tagbody}. It consists of a series of @i{tags} and @i{statements}. @b{dolist} evaluates @i{list-form}, which should produce a @i{list}. It then executes the body once for each element in the @i{list}, in the order in which the @i{tags} and @i{statements} occur, with @i{var} bound to the element. Then @i{result-form} is evaluated. @i{tags} label @i{statements}. At the time @i{result-form} is processed, @i{var} is bound to @b{nil}. An @i{implicit block} named @b{nil} surrounds @b{dolist}. @b{return} may be used to terminate the loop immediately without performing any further iterations, returning zero or more @i{values}. The @i{scope} of the binding of @i{var} does not include the @i{list-form}, but the @i{result-form} is included. It is @i{implementation-dependent} whether @b{dolist} @i{establishes} a new @i{binding} of @i{var} on each iteration or whether it @i{establishes} a binding for @i{var} once at the beginning and then @i{assigns} it on any subsequent iterations. @subsubheading Examples:: @example (setq temp-two '()) @result{} NIL (dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two)) @result{} (4 3 2 1) (setq temp-two 0) @result{} 0 (dolist (temp-one '(1 2 3 4)) (incf temp-two)) @result{} NIL temp-two @result{} 4 (dolist (x '(a b c d)) (prin1 x) (princ " ")) @t{ |> } A B C D @result{} NIL @end example @subsubheading See Also:: @ref{do} , @ref{dotimes} , @ref{tagbody} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: @b{go} may be used within the body of @b{dolist} to transfer control to a statement labeled by a @i{tag}. @node loop, loop-finish, dolist, Iteration Dictionary @subsection loop [Macro] The ``simple'' @b{loop} @i{form}: @code{loop} @i{@{@i{compound-form}@}*} @result{} @i{@{@i{result}@}*} The ``extended'' @b{loop} @i{form}: @code{loop} @i{@r{[}!@i{name-clause}@r{]} @{!@i{variable-clause}@}* @{!@i{main-clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{name-clause} ::=@t{named} @i{name}} @w{@i{variable-clause} ::=!@i{with-clause} | !@i{initial-final} | !@i{for-as-clause}} @w{@i{with-clause} ::=@t{with} @i{var1} @r{[}@i{type-spec}@r{]} @r{[}= @i{form1}@r{]} @{@t{and} @i{var2} @r{[}@i{type-spec}@r{]} @r{[}= @i{form2}@r{]}@}*} @w{@i{main-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional} | !@i{termination-test} | !@i{initial-final}} @w{@i{initial-final} ::=@t{initially} @{@i{compound-form}@}^+ | @t{finally} @{@i{compound-form}@}^+} @w{@i{unconditional} ::=@{@t{do} | @t{doing}@} @{@i{compound-form}@}^+ | @t{return} @{@i{form} | @t{it}@}} @w{@i{accumulation} ::=!@i{list-accumulation} | !@i{numeric-accumulation}} @w{@i{list-accumulation} ::=@{@t{collect} | @t{collecting} | @t{append} | @t{appending} | @t{nconc} | @t{nconcing}@} @{@i{form} | @t{it}@} } @w{ @r{[}@t{into} @i{simple-var}@r{]}} @w{@i{numeric-accumulation} ::=@{@t{count} | @t{counting} | @t{sum} | @t{summing} | @} @w{ @t{maximize} | @t{maximizing} | @t{minimize} | @t{minimizing}} @{@i{form} | @t{it}@} } @w{ @r{[}@t{into} @i{simple-var}@r{]} @r{[}@i{type-spec}@r{]}} @w{@i{conditional} ::=@{@t{if} | @t{when} | @t{unless}@} @i{form} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}* } @w{ @r{[}@t{else} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}*@r{]} } @w{ @r{[}@t{end}@r{]}} @w{@i{selectable-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional}} @w{@i{termination-test} ::=@t{while} @i{form} | @t{until} @i{form} | @t{repeat} @i{form} | @t{always} @i{form} | @t{never} @i{form} | @t{thereis} @i{form}} @w{@i{for-as-clause} ::=@{@t{for} | @t{as}@} !@i{for-as-subclause} @{@t{and} !@i{for-as-subclause}@}*} @w{@i{for-as-subclause} ::=!@i{for-as-arithmetic} | !@i{for-as-in-list} | !@i{for-as-on-list} | !@i{for-as-equals-then} |} @w{ !@i{for-as-across} | !@i{for-as-hash} | !@i{for-as-package}} @w{@i{for-as-arithmetic} ::=@i{var} @r{[}@i{type-spec}@r{]} !@i{for-as-arithmetic-subclause}} @w{@i{for-as-arithmetic-subclause} ::=!@i{arithmetic-up} | !@i{arithmetic-downto} | !@i{arithmetic-downfrom}} @w{@i{arithmetic-up} ::=[[@{@t{from} | @t{upfrom}@} @i{form1} | @{@t{to} | @t{upto} | @t{below}@} @i{form2} | @t{by} @i{form3}]]^+} @w{@i{arithmetic-downto} ::=[[@{@t{from} @i{form1}@}^1 | @{@{@t{downto} | @t{above}@} @i{form2}@}^1 | @t{by} @i{form3}]]} @w{@i{arithmetic-downfrom} ::=[[@{@t{downfrom} @i{form1}@}^1 | @{@t{to} | @t{downto} | @t{above}@} @i{form2} | @t{by} @i{form3}]]} @w{@i{for-as-in-list} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{in} @i{form1} @r{[}@t{by} @i{step-fun}@r{]}} @w{@i{for-as-on-list} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{on} @i{form1} @r{[}@t{by} @i{step-fun}@r{]}} @w{@i{for-as-equals-then} ::=@i{var} @r{[}@i{type-spec}@r{]} = @i{form1} @r{[}@t{then} @i{form2}@r{]}} @w{@i{for-as-across} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{across} @i{vector}} @w{@i{for-as-hash} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } @w{ @{@{@t{hash-key} | @t{hash-keys}@} @{@t{in} | @t{of}@} @i{hash-table} } @w{ @r{[}@t{using} @r{(}@t{hash-value} @i{other-var}@r{)}@r{]} | } @w{ @{@t{hash-value} | @t{hash-values}@} @{@t{in} | @t{of}@} @i{hash-table} } @w{ @r{[}@t{using} @r{(}@t{hash-key} @i{other-var}@r{)}@r{]}@}} @w{@i{for-as-package} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } @w{ @{@t{symbol} | @t{symbols} |} @w{ @t{present-symbol} | @t{present-symbols} |} @w{ @t{external-symbol} | @t{external-symbols}@} } @w{ @r{[}@{@t{in} | @t{of}@} @i{package}@r{]}} @w{@i{type-spec} ::=!@i{simple-type-spec} | !@i{destructured-type-spec}} @w{@i{simple-type-spec} ::=@b{fixnum} | @b{float} | @b{t} | @b{nil}} @w{@i{destructured-type-spec} ::=@t{of-type} @i{d-type-spec}} @w{@i{d-type-spec} ::=@i{type-specifier} | @t{(@i{d-type-spec} . @i{d-type-spec})}} @w{@i{var} ::=!@i{d-var-spec}} @w{@i{var1} ::=!@i{d-var-spec}} @w{@i{var2} ::=!@i{d-var-spec}} @w{@i{other-var} ::=!@i{d-var-spec}} @w{@i{d-var-spec} ::=@i{simple-var} | @b{nil} | @r{(}!@i{d-var-spec} @t{.} !@i{d-var-spec}@r{)}} @subsubheading Arguments and Values:: @i{compound-form}---a @i{compound form}. @i{name}---a @i{symbol}. @i{simple-var}---a @i{symbol} (a @i{variable} name). @i{form}, @i{form1}, @i{form2}, @i{form3}---a @i{form}. @i{step-fun}---a @i{form} that evaluates to a @i{function} of one @i{argument}. @i{vector}---a @i{form} that evaluates to a @i{vector}. @i{hash-table}---a @i{form} that evaluates to a @i{hash table}. @i{package}---a @i{form} that evaluates to a @i{package designator}. @i{type-specifier}---a @i{type specifier}. This might be either an @i{atomic type specifier} or a @i{compound type specifier}, which introduces some additional complications to proper parsing in the face of destructuring; for further information, see @ref{Destructuring}. @i{result}---an @i{object}. @subsubheading Description:: For details, see @ref{The LOOP Facility}. @subsubheading Examples:: @example ;; An example of the simple form of LOOP. (defun sqrt-advisor () (loop (format t "~&Number: ") (let ((n (parse-integer (read-line) :junk-allowed t))) (when (not n) (return)) (format t "~&The square root of ~D is ~D.~%" n (sqrt n))))) @result{} SQRT-ADVISOR (sqrt-advisor) @t{ |> } Number: @b{|>>}@t{5 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square root of 5 is 2.236068. @t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square root of 4 is 2. @t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} @result{} NIL ;; An example of the extended form of LOOP. (defun square-advisor () (loop as n = (progn (format t "~&Number: ") (parse-integer (read-line) :junk-allowed t)) while n do (format t "~&The square of ~D is ~D.~ @result{} SQUARE-ADVISOR (square-advisor) @t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square of 4 is 16. @t{ |> } Number: @b{|>>}@t{23 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square of 23 is 529. @t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} @result{} NIL ;; Another example of the extended form of LOOP. (loop for n from 1 to 10 when (oddp n) collect n) @result{} (1 3 5 7 9) @end example @subsubheading See Also:: @ref{do} , @ref{dolist} , @ref{dotimes} , @ref{return} , @ref{go} , @ref{throw} , @ref{Destructuring} @subsubheading Notes:: Except that @b{loop-finish} cannot be used within a simple @b{loop} @i{form}, a simple @b{loop} @i{form} is related to an extended @b{loop} @i{form} in the following way: @example (loop @{@i{compound-form}@}*) @equiv{} (loop do @{@i{compound-form}@}*) @end example @node loop-finish, , loop, Iteration Dictionary @subsection loop-finish [Local Macro] @subsubheading Syntax:: @code{loop-finish} @i{<@i{no @i{arguments}}>} @result{} # @subsubheading Description:: The @b{loop-finish} @i{macro} can be used lexically within an extended @b{loop} @i{form} to terminate that @i{form} ``normally.'' That is, it transfers control to the loop epilogue of the lexically innermost extended @b{loop} @i{form}. This permits execution of any @b{finally} clause (for effect) and the return of any accumulated result. @subsubheading Examples:: @example ;; Terminate the loop, but return the accumulated count. (loop for i in '(1 2 3 stop-here 4 5 6) when (symbolp i) do (loop-finish) count i) @result{} 3 ;; The preceding loop is equivalent to: (loop for i in '(1 2 3 stop-here 4 5 6) until (symbolp i) count i) @result{} 3 ;; While LOOP-FINISH can be used can be used in a variety of ;; situations it is really most needed in a situation where a need ;; to exit is detected at other than the loop's `top level' ;; (where UNTIL or WHEN often work just as well), or where some ;; computation must occur between the point where a need to exit is ;; detected and the point where the exit actually occurs. For example: (defun tokenize-sentence (string) (macrolet ((add-word (wvar svar) `(when ,wvar (push (coerce (nreverse ,wvar) 'string) ,svar) (setq ,wvar nil)))) (loop with word = '() and sentence = '() and endpos = nil for i below (length string) do (let ((char (aref string i))) (case char (#\Space (add-word word sentence)) (#\. (setq endpos (1+ i)) (loop-finish)) (otherwise (push char word)))) finally (add-word word sentence) (return (values (nreverse sentence) endpos))))) @result{} TOKENIZE-SENTENCE (tokenize-sentence "this is a sentence. this is another sentence.") @result{} ("this" "is" "a" "sentence"), 19 (tokenize-sentence "this is a sentence") @result{} ("this" "is" "a" "sentence"), NIL @end example @subsubheading Side Effects:: Transfers control. @subsubheading Exceptional Situations:: Whether or not @b{loop-finish} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{loop-finish} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{loop-finish} outside of @b{loop} are undefined. @subsubheading See Also:: @ref{loop} , @ref{The LOOP Facility} @subsubheading Notes:: @c end of including dict-iteration @c %**end of chapter gcl-2.6.14/info/gcl.info-60000644000175000017500000111223314360276512013516 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: boole-1, Next: logand, Prev: boole, Up: Numbers Dictionary 12.2.61 boole-1, boole-2, boole-and, boole-andc1, boole-andc2, -------------------------------------------------------------- boole-c1, boole-c2, boole-clr, boole-eqv, boole-ior, ---------------------------------------------------- boole-nand, boole-nor, boole-orc1, boole-orc2, boole-set, --------------------------------------------------------- boole-xor --------- [Constant Variable] Constant Value:: ................ The identity and nature of the values of each of these variables is implementation-dependent, except that it must be distinct from each of the values of the others, and it must be a valid first argument to the function boole. Description:: ............. Each of these constants has a value which is one of the sixteen possible bit-wise logical operation specifiers. Examples:: .......... (boole boole-ior 1 16) => 17 (boole boole-and -2 5) => 4 (boole boole-eqv 17 15) => -31 See Also:: .......... *note boole::  File: gcl.info, Node: logand, Next: logbitp, Prev: boole-1, Up: Numbers Dictionary 12.2.62 logand, logandc1, logandc2, logeqv, logior, --------------------------------------------------- lognand, lognor, lognot, logorc1, logorc2, ------------------------------------------ logxor ------ [Function] 'logand' &rest integers => result-integer 'logandc' 1 => integer-1 integer-2 result-integer 'logandc' 2 => integer-1 integer-2 result-integer 'logeqv' &rest integers => result-integer 'logior' &rest integers => result-integer 'lognand' integer-1 integer-2 => result-integer 'lognor' integer-1 integer-2 => result-integer 'lognot' integer => result-integer 'logorc' 1 => integer-1 integer-2 result-integer 'logorc' 2 => integer-1 integer-2 result-integer 'logxor' &rest integers => result-integer Arguments and Values:: ...................... integers--integers. integer--an integer. integer-1--an integer. integer-2--an integer. result-integer--an integer. Description:: ............. The functions logandc1, logandc2, logand, logeqv, logior, lognand, lognor, lognot, logorc1, logorc2, and logxor perform bit-wise logical operations on their arguments, that are treated as if they were binary. Figure 12-17 lists the meaning of each of the functions. Where an 'identity' is shown, it indicates the value yielded by the function when no arguments are supplied. Function Identity Operation performed logandc1 -- and complement of integer-1 with integer-2 logandc2 -- and integer-1 with complement of integer-2 logand -1 and logeqv -1 equivalence (exclusive nor) logior 0 inclusive or lognand -- complement of integer-1 and integer-2 lognor -- complement of integer-1 or integer-2 lognot -- complement logorc1 -- or complement of integer-1 with integer-2 logorc2 -- or integer-1 with complement of integer-2 logxor 0 exclusive or Figure 12-17: Bit-wise Logical Operations on Integers Negative integers are treated as if they were in two's-complement notation. Examples:: .......... (logior 1 2 4 8) => 15 (logxor 1 3 7 15) => 10 (logeqv) => -1 (logand 16 31) => 16 (lognot 0) => -1 (lognot 1) => -2 (lognot -1) => 0 (lognot (1+ (lognot 1000))) => 999 ;;; In the following example, m is a mask. For each bit in ;;; the mask that is a 1, the corresponding bits in x and y are ;;; exchanged. For each bit in the mask that is a 0, the ;;; corresponding bits of x and y are left unchanged. (flet ((show (m x y) (format t "~ m x y))) (let ((m #o007750) (x #o452576) (y #o317407)) (show m x y) (let ((z (logand (logxor x y) m))) (setq x (logxor z x)) (setq y (logxor z y)) (show m x y)))) |> m = #o007750 |> x = #o452576 |> y = #o317407 |> |> m = #o007750 |> x = #o457426 |> y = #o312557 => NIL Exceptional Situations:: ........................ Should signal type-error if any argument is not an integer. See Also:: .......... *note boole:: Notes:: ....... (logbitp k -1) returns true for all values of k. Because the following functions are not associative, they take exactly two arguments rather than any number of arguments. (lognand n1 n2) == (lognot (logand n1 n2)) (lognor n1 n2) == (lognot (logior n1 n2)) (logandc1 n1 n2) == (logand (lognot n1) n2) (logandc2 n1 n2) == (logand n1 (lognot n2)) (logiorc1 n1 n2) == (logior (lognot n1) n2) (logiorc2 n1 n2) == (logior n1 (lognot n2)) (logbitp j (lognot x)) == (not (logbitp j x))  File: gcl.info, Node: logbitp, Next: logcount, Prev: logand, Up: Numbers Dictionary 12.2.63 logbitp [Function] -------------------------- 'logbitp' index integer => generalized-boolean Arguments and Values:: ...................... index--a non-negative integer. integer--an integer. generalized-boolean--a generalized boolean. Description:: ............. logbitp is used to test the value of a particular bit in integer, that is treated as if it were binary. The value of logbitp is true if the bit in integer whose index is index (that is, its weight is 2^index) is a one-bit; otherwise it is false. Negative integers are treated as if they were in two's-complement notation. Examples:: .......... (logbitp 1 1) => false (logbitp 0 1) => true (logbitp 3 10) => true (logbitp 1000000 -1) => true (logbitp 2 6) => true (logbitp 0 6) => false Exceptional Situations:: ........................ Should signal an error of type type-error if index is not a non-negative integer. Should signal an error of type type-error if integer is not an integer. Notes:: ....... (logbitp k n) == (ldb-test (byte 1 k) n)  File: gcl.info, Node: logcount, Next: logtest, Prev: logbitp, Up: Numbers Dictionary 12.2.64 logcount [Function] --------------------------- 'logcount' integer => number-of-on-bits Arguments and Values:: ...................... integer--an integer. number-of-on-bits--a non-negative integer. Description:: ............. Computes and returns the number of bits in the two's-complement binary representation of integer that are 'on' or 'set'. If integer is negative, the 0 bits are counted; otherwise, the 1 bits are counted. Examples:: .......... (logcount 0) => 0 (logcount -1) => 0 (logcount 7) => 3 (logcount 13) => 3 ;Two's-complement binary: ...0001101 (logcount -13) => 2 ;Two's-complement binary: ...1110011 (logcount 30) => 4 ;Two's-complement binary: ...0011110 (logcount -30) => 4 ;Two's-complement binary: ...1100010 (logcount (expt 2 100)) => 1 (logcount (- (expt 2 100))) => 100 (logcount (- (1+ (expt 2 100)))) => 1 Exceptional Situations:: ........................ Should signal type-error if its argument is not an integer. Notes:: ....... Even if the implementation does not represent integers internally in two's complement binary, logcount behaves as if it did. The following identity always holds: (logcount x) == (logcount (- (+ x 1))) == (logcount (lognot x))  File: gcl.info, Node: logtest, Next: byte, Prev: logcount, Up: Numbers Dictionary 12.2.65 logtest [Function] -------------------------- 'logtest' integer-1 integer-2 => generalized-boolean Arguments and Values:: ...................... integer-1--an integer. integer-2--an integer. generalized-boolean--a generalized boolean. Description:: ............. Returns true if any of the bits designated by the 1's in integer-1 is 1 in integer-2; otherwise it is false. integer-1 and integer-2 are treated as if they were binary. Negative integer-1 and integer-2 are treated as if they were represented in two's-complement binary. Examples:: .......... (logtest 1 7) => true (logtest 1 2) => false (logtest -2 -1) => true (logtest 0 -1) => false Exceptional Situations:: ........................ Should signal an error of type type-error if integer-1 is not an integer. Should signal an error of type type-error if integer-2 is not an integer. Notes:: ....... (logtest x y) == (not (zerop (logand x y)))  File: gcl.info, Node: byte, Next: deposit-field, Prev: logtest, Up: Numbers Dictionary 12.2.66 byte, byte-size, byte-position [Function] ------------------------------------------------- 'byte' size position => bytespec 'byte-size' bytespec => size 'byte-position' bytespec => position Arguments and Values:: ...................... size, position--a non-negative integer. bytespec--a byte specifier. Description:: ............. byte returns a byte specifier that indicates a byte of width size and whose bits have weights 2^position + size - 1\/ through 2^position, and whose representation is implementation-dependent. byte-size returns the number of bits specified by bytespec. byte-position returns the position specified by bytespec. Examples:: .......... (setq b (byte 100 200)) => # (byte-size b) => 100 (byte-position b) => 200 See Also:: .......... *note ldb:: , *note dpb:: Notes:: ....... (byte-size (byte j k)) == j (byte-position (byte j k)) == k A byte of size of 0 is permissible; it refers to a byte of width zero. For example, (ldb (byte 0 3) #o7777) => 0 (dpb #o7777 (byte 0 3) 0) => 0  File: gcl.info, Node: deposit-field, Next: dpb, Prev: byte, Up: Numbers Dictionary 12.2.67 deposit-field [Function] -------------------------------- 'deposit-field' newbyte bytespec integer => result-integer Arguments and Values:: ...................... newbyte--an integer. bytespec--a byte specifier. integer--an integer. result-integer--an integer. Description:: ............. Replaces a field of bits within integer; specifically, returns an integer that contains the bits of newbyte within the byte specified by bytespec, and elsewhere contains the bits of integer. Examples:: .......... (deposit-field 7 (byte 2 1) 0) => 6 (deposit-field -1 (byte 4 0) 0) => 15 (deposit-field 0 (byte 2 1) -3) => -7 See Also:: .......... *note byte:: , *note dpb:: Notes:: ....... (logbitp j (deposit-field m (byte s p) n)) == (if (and (>= j p) (< j (+ p s))) (logbitp j m) (logbitp j n)) deposit-field is to mask-field as dpb is to ldb.  File: gcl.info, Node: dpb, Next: ldb, Prev: deposit-field, Up: Numbers Dictionary 12.2.68 dpb [Function] ---------------------- 'dpb' newbyte bytespec integer => result-integer Pronunciation:: ............... pronounced ,de 'pib or pronounced ,de 'pe b or pronounced 'd\=e 'p\=e 'b\=e Arguments and Values:: ...................... newbyte--an integer. bytespec--a byte specifier. integer--an integer. result-integer--an integer. Description:: ............. dpb (deposit byte) is used to replace a field of bits within integer. dpb returns an integer that is the same as integer except in the bits specified by bytespec. Let s be the size specified by bytespec; then the low s bits of newbyte appear in the result in the byte specified by bytespec. Newbyte is interpreted as being right-justified, as if it were the result of ldb. Examples:: .......... (dpb 1 (byte 1 10) 0) => 1024 (dpb -2 (byte 2 10) 0) => 2048 (dpb 1 (byte 2 10) 2048) => 1024 See Also:: .......... *note byte:: , *note deposit-field:: , *note ldb:: Notes:: ....... (logbitp j (dpb m (byte s p) n)) == (if (and (>= j p) (< j (+ p s))) (logbitp (- j p) m) (logbitp j n)) In general, (dpb x (byte 0 y) z) => z for all valid values of x, y, and z. Historically, the name "dpb" comes from a DEC PDP-10 assembly language instruction meaning "deposit byte."  File: gcl.info, Node: ldb, Next: ldb-test, Prev: dpb, Up: Numbers Dictionary 12.2.69 ldb [Accessor] ---------------------- 'ldb' bytespec integer => byte (setf (' ldb' bytespec place) new-byte) Pronunciation:: ............... pronounced 'lid ib or pronounced 'lid e b or pronounced 'el 'd\=e 'b\=e Arguments and Values:: ...................... bytespec--a byte specifier. integer--an integer. byte, new-byte--a non-negative integer. Description:: ............. ldb extracts and returns the byte of integer specified by bytespec. ldb returns an integer in which the bits with weights 2^(s-1) through 2^0 are the same as those in integer with weights 2^(p+s-1) through 2^p, and all other bits zero; s is (byte-size bytespec) and p is (byte-position bytespec). setf may be used with ldb to modify a byte within the integer that is stored in a given place. The order of evaluation, when an ldb form is supplied to setf, is exactly left-to-right. The effect is to perform a dpb operation and then store the result back into the place. Examples:: .......... (ldb (byte 2 1) 10) => 1 (setq a (list 8)) => (8) (setf (ldb (byte 2 1) (car a)) 1) => 1 a => (10) See Also:: .......... *note byte:: , byte-position, byte-size, *note dpb:: Notes:: ....... (logbitp j (ldb (byte s p) n)) == (and (< j s) (logbitp (+ j p) n)) In general, (ldb (byte 0 x) y) => 0 for all valid values of x and y. Historically, the name "ldb" comes from a DEC PDP-10 assembly language instruction meaning "load byte."  File: gcl.info, Node: ldb-test, Next: mask-field, Prev: ldb, Up: Numbers Dictionary 12.2.70 ldb-test [Function] --------------------------- 'ldb-test' bytespec integer => generalized-boolean Arguments and Values:: ...................... bytespec--a byte specifier. integer--an integer. generalized-boolean--a generalized boolean. Description:: ............. Returns true if any of the bits of the byte in integer specified by bytespec is non-zero; otherwise returns false. Examples:: .......... (ldb-test (byte 4 1) 16) => true (ldb-test (byte 3 1) 16) => false (ldb-test (byte 3 2) 16) => true See Also:: .......... *note byte:: , *note ldb:: , *note zerop:: Notes:: ....... (ldb-test bytespec n) == (not (zerop (ldb bytespec n))) == (logtest (ldb bytespec -1) n)  File: gcl.info, Node: mask-field, Next: most-positive-fixnum, Prev: ldb-test, Up: Numbers Dictionary 12.2.71 mask-field [Accessor] ----------------------------- 'mask-field' bytespec integer => masked-integer (setf (' mask-field' bytespec place) new-masked-integer) Arguments and Values:: ...................... bytespec--a byte specifier. integer--an integer. masked-integer, new-masked-integer--a non-negative integer. Description:: ............. mask-field performs a "mask" operation on integer. It returns an integer that has the same bits as integer in the byte specified by bytespec, but that has zero-bits everywhere else. setf may be used with mask-field to modify a byte within the integer that is stored in a given place. The effect is to perform a deposit-field operation and then store the result back into the place. Examples:: .......... (mask-field (byte 1 5) -1) => 32 (setq a 15) => 15 (mask-field (byte 2 0) a) => 3 a => 15 (setf (mask-field (byte 2 0) a) 1) => 1 a => 13 See Also:: .......... *note byte:: , *note ldb:: Notes:: ....... (ldb bs (mask-field bs n)) == (ldb bs n) (logbitp j (mask-field (byte s p) n)) == (and (>= j p) (< j s) (logbitp j n)) (mask-field bs n) == (logand n (dpb -1 bs 0))  File: gcl.info, Node: most-positive-fixnum, Next: decode-float, Prev: mask-field, Up: Numbers Dictionary 12.2.72 most-positive-fixnum, most-negative-fixnum [Constant Variable] ---------------------------------------------------------------------- Constant Value:: ................ implementation-dependent. Description:: ............. most-positive-fixnum is that fixnum closest in value to positive infinity provided by the implementation, and greater than or equal to both 2^15 - 1 and array-dimension-limit. most-negative-fixnum is that fixnum closest in value to negative infinity provided by the implementation, and less than or equal to -2^15.  File: gcl.info, Node: decode-float, Next: float, Prev: most-positive-fixnum, Up: Numbers Dictionary 12.2.73 decode-float, scale-float, float-radix, float-sign, ----------------------------------------------------------- float-digits, float-precision, integer-decode-float --------------------------------------------------- [Function] 'decode-float' float => significand, exponent, sign 'scale-float' float integer => scaled-float 'float-radix' float => float-radix 'float-sign' float-1 &optional float-2 => signed-float 'float-digits' float => digits1 'float-precision' float => digits2 'integer-decode-float' float => significand, exponent, integer-sign Arguments and Values:: ...................... digits1--a non-negative integer. digits2--a non-negative integer. exponent--an integer. float--a float. float-1--a float. float-2--a float. float-radix--an integer. integer--a non-negative integer. integer-sign--the integer -1, or the integer 1. scaled-float--a float. sign--A float of the same type as float but numerically equal to 1.0 or -1.0. signed-float--a float. significand--a float. Description:: ............. decode-float computes three values that characterize float. The first value is of the same type as float and represents the significand. The second value represents the exponent to which the radix (notated in this description by b) must be raised to obtain the value that, when multiplied with the first result, produces the absolute value of float. If float is zero, any integer value may be returned, provided that the identity shown for scale-float holds. The third value is of the same type as float and is 1.0 if float is greater than or equal to zero or -1.0 otherwise. decode-float divides float by an integral power of b so as to bring its value between 1/b (inclusive) and~1 (exclusive), and returns the quotient as the first value. If float is zero, however, the result equals the absolute value of float (that is, if there is a negative zero, its significand is considered to be a positive zero). scale-float returns (* float (expt (float b float) integer))\/, where b is the radix of the floating-point representation. float is not necessarily between 1/b and~1. float-radix returns the radix of float. float-sign returns a number z such that z and float-1 have the same sign and also such that z and float-2 have the same absolute value. If float-2 is not supplied, its value is (float 1 float-1). If an implementation has distinct representations for negative zero and positive zero, then (float-sign -0.0) => -1.0. float-digits returns the number of radix b digits used in the representation of float (including any implicit digits, such as a "hidden bit"). float-precision returns the number of significant radix b digits present in float; if float is a float zero, then the result is an integer zero. For normalized floats, the results of float-digits and float-precision are the same, but the precision is less than the number of representation digits for a denormalized or zero number. integer-decode-float computes three values that characterize float - the significand scaled so as to be an integer, and the same last two values that are returned by decode-float. If float is zero, integer-decode-float returns zero as the first value. The second value bears the same relationship to the first value as for decode-float: (multiple-value-bind (signif expon sign) (integer-decode-float f) (scale-float (float signif f) expon)) == (abs f) Examples:: .......... ;; Note that since the purpose of this functionality is to expose ;; details of the implementation, all of these examples are necessarily ;; very implementation-dependent. Results may vary widely. ;; Values shown here are chosen consistently from one particular implementation. (decode-float .5) => 0.5, 0, 1.0 (decode-float 1.0) => 0.5, 1, 1.0 (scale-float 1.0 1) => 2.0 (scale-float 10.01 -2) => 2.5025 (scale-float 23.0 0) => 23.0 (float-radix 1.0) => 2 (float-sign 5.0) => 1.0 (float-sign -5.0) => -1.0 (float-sign 0.0) => 1.0 (float-sign 1.0 0.0) => 0.0 (float-sign 1.0 -10.0) => 10.0 (float-sign -1.0 10.0) => -10.0 (float-digits 1.0) => 24 (float-precision 1.0) => 24 (float-precision least-positive-single-float) => 1 (integer-decode-float 1.0) => 8388608, -23, 1 Affected By:: ............. The implementation's representation for floats. Exceptional Situations:: ........................ The functions decode-float, float-radix, float-digits, float-precision, and integer-decode-float should signal an error if their only argument is not a float. The function scale-float should signal an error if its first argument is not a float or if its second argument is not an integer. The function float-sign should signal an error if its first argument is not a float or if its second argument is supplied but is not a float. Notes:: ....... The product of the first result of decode-float or integer-decode-float, of the radix raised to the power of the second result, and of the third result is exactly equal to the value of float. (multiple-value-bind (signif expon sign) (decode-float f) (scale-float signif expon)) == (abs f) and (multiple-value-bind (signif expon sign) (decode-float f) (* (scale-float signif expon) sign)) == f  File: gcl.info, Node: float, Next: floatp, Prev: decode-float, Up: Numbers Dictionary 12.2.74 float [Function] ------------------------ 'float' number &optional prototype => float Arguments and Values:: ...................... number--a real. prototype--a float. float--a float. Description:: ............. float converts a real number to a float. If a prototype is supplied, a float is returned that is mathematically equal to number but has the same format as prototype. If prototype is not supplied, then if the number is already a float, it is returned; otherwise, a float is returned that is mathematically equal to number but is a single float. Examples:: .......... (float 0) => 0.0 (float 1 .5) => 1.0 (float 1.0) => 1.0 (float 1/2) => 0.5 => 1.0d0 OR=> 1.0 (eql (float 1.0 1.0d0) 1.0d0) => true See Also:: .......... *note coerce::  File: gcl.info, Node: floatp, Next: most-positive-short-float, Prev: float, Up: Numbers Dictionary 12.2.75 floatp [Function] ------------------------- 'floatp' object generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type float; otherwise, returns false. Examples:: .......... (floatp 1.2d2) => true (floatp 1.212) => true (floatp 1.2s2) => true (floatp (expt 2 130)) => false Notes:: ....... (floatp object) == (typep object 'float)  File: gcl.info, Node: most-positive-short-float, Next: short-float-epsilon, Prev: floatp, Up: Numbers Dictionary 12.2.76 most-positive-short-float, least-positive-short-float, -------------------------------------------------------------- least-positive-normalized-short-float, -------------------------------------- most-positive-double-float, least-positive-double-float, -------------------------------------------------------- least-positive-normalized-double-float, --------------------------------------- most-positive-long-float, least-positive-long-float, ---------------------------------------------------- least-positive-normalized-long-float, ------------------------------------- most-positive-single-float, least-positive-single-float, -------------------------------------------------------- least-positive-normalized-single-float, --------------------------------------- most-negative-short-float, least-negative-short-float, ------------------------------------------------------ least-negative-normalized-short-float, -------------------------------------- most-negative-single-float, least-negative-single-float, -------------------------------------------------------- least-negative-normalized-single-float, --------------------------------------- most-negative-double-float, least-negative-double-float, -------------------------------------------------------- least-negative-normalized-double-float, --------------------------------------- most-negative-long-float, least-negative-long-float, ---------------------------------------------------- least-negative-normalized-long-float ------------------------------------ [Constant Variable] Constant Value:: ................ implementation-dependent. Description:: ............. These constant variables provide a way for programs to examine the implementation-defined limits for the various float formats. Of these variables, each which has "-normalized" in its name must have a value which is a normalized float, and each which does not have "-normalized" in its name may have a value which is either a normalized float or a denormalized float, as appropriate. Of these variables, each which has "short-float" in its name must have a value which is a short float, each which has "single-float" in its name must have a value which is a single float, each which has "double-float" in its name must have a value which is a double float, and each which has "long-float" in its name must have a value which is a long float. * most-positive-short-float, most-positive-single-float, most-positive-double-float, most-positive-long-float Each of these constant variables has as its value the positive float of the largest magnitude (closest in value to, but not equal to, positive infinity) for the float format implied by its name. * least-positive-short-float, least-positive-normalized-short-float, least-positive-single-float, least-positive-normalized-single-float, least-positive-double-float, least-positive-normalized-double-float, least-positive-long-float, least-positive-normalized-long-float Each of these constant variables has as its value the smallest positive (nonzero) float for the float format implied by its name. * least-negative-short-float, least-negative-normalized-short-float, least-negative-single-float, least-negative-normalized-single-float, least-negative-double-float, least-negative-normalized-double-float, least-negative-long-float, least-negative-normalized-long-float Each of these constant variables has as its value the negative (nonzero) float of the smallest magnitude for the float format implied by its name. (If an implementation supports minus zero as a different object from positive zero, this value must not be minus zero.) * most-negative-short-float, most-negative-single-float, most-negative-double-float, most-negative-long-float Each of these constant variables has as its value the negative float of the largest magnitude (closest in value to, but not equal to, negative infinity) for the float format implied by its name. Notes:: .......  File: gcl.info, Node: short-float-epsilon, Next: arithmetic-error, Prev: most-positive-short-float, Up: Numbers Dictionary 12.2.77 short-float-epsilon, short-float-negative-epsilon, ---------------------------------------------------------- single-float-epsilon, single-float-negative-epsilon, ---------------------------------------------------- double-float-epsilon, double-float-negative-epsilon, ---------------------------------------------------- long-float-epsilon, long-float-negative-epsilon ----------------------------------------------- [Constant Variable] Constant Value:: ................ implementation-dependent. Description:: ............. The value of each of the constants short-float-epsilon, single-float-epsilon, double-float-epsilon, and long-float-epsilon is the smallest positive float \epsilon of the given format, such that the following expression is true when evaluated: (not (= (float 1 \epsilon) (+ (float 1 \epsilon) \epsilon)))\/ The value of each of the constants short-float-negative-epsilon, single-float-negative-epsilon, double-float-negative-epsilon, and long-float-negative-epsilon is the smallest positive float \epsilon of the given format, such that the following expression is true when evaluated: (not (= (float 1 \epsilon) (- (float 1 \epsilon) \epsilon)))\/  File: gcl.info, Node: arithmetic-error, Next: arithmetic-error-operands, Prev: short-float-epsilon, Up: Numbers Dictionary 12.2.78 arithmetic-error [Condition Type] ----------------------------------------- Class Precedence List:: ....................... arithmetic-error, error, serious-condition, condition, t Description:: ............. The type arithmetic-error consists of error conditions that occur during arithmetic operations. The operation and operands are initialized with the initialization arguments named :operation and :operands to make-condition, and are accessed by the functions arithmetic-error-operation and arithmetic-error-operands. See Also:: .......... arithmetic-error-operation, *note arithmetic-error-operands::  File: gcl.info, Node: arithmetic-error-operands, Next: division-by-zero, Prev: arithmetic-error, Up: Numbers Dictionary 12.2.79 arithmetic-error-operands, arithmetic-error-operation [Function] ------------------------------------------------------------------------ 'arithmetic-error-operands' condition => operands 'arithmetic-error-operation' condition => operation Arguments and Values:: ...................... condition--a condition of type arithmetic-error. operands--a list. operation--a function designator. Description:: ............. arithmetic-error-operands returns a list of the operands which were used in the offending call to the operation that signaled the condition. arithmetic-error-operation returns a list of the offending operation in the offending call that signaled the condition. See Also:: .......... arithmetic-error, *note Conditions:: Notes:: .......  File: gcl.info, Node: division-by-zero, Next: floating-point-invalid-operation, Prev: arithmetic-error-operands, Up: Numbers Dictionary 12.2.80 division-by-zero [Condition Type] ----------------------------------------- Class Precedence List:: ....................... division-by-zero, arithmetic-error, error, serious-condition, condition, t Description:: ............. The type division-by-zero consists of error conditions that occur because of division by zero.  File: gcl.info, Node: floating-point-invalid-operation, Next: floating-point-inexact, Prev: division-by-zero, Up: Numbers Dictionary 12.2.81 floating-point-invalid-operation [Condition Type] --------------------------------------------------------- Class Precedence List:: ....................... floating-point-invalid-operation, arithmetic-error, error, serious-condition, condition, t Description:: ............. The type floating-point-invalid-operation consists of error conditions that occur because of certain floating point traps. It is implementation-dependent whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being signaled.  File: gcl.info, Node: floating-point-inexact, Next: floating-point-overflow, Prev: floating-point-invalid-operation, Up: Numbers Dictionary 12.2.82 floating-point-inexact [Condition Type] ----------------------------------------------- Class Precedence List:: ....................... floating-point-inexact, arithmetic-error, error, serious-condition, condition, t Description:: ............. The type floating-point-inexact consists of error conditions that occur because of certain floating point traps. It is implementation-dependent whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being signaled.  File: gcl.info, Node: floating-point-overflow, Next: floating-point-underflow, Prev: floating-point-inexact, Up: Numbers Dictionary 12.2.83 floating-point-overflow [Condition Type] ------------------------------------------------ Class Precedence List:: ....................... floating-point-overflow, arithmetic-error, error, serious-condition, condition, t Description:: ............. The type floating-point-overflow consists of error conditions that occur because of floating-point overflow.  File: gcl.info, Node: floating-point-underflow, Prev: floating-point-overflow, Up: Numbers Dictionary 12.2.84 floating-point-underflow [Condition Type] ------------------------------------------------- Class Precedence List:: ....................... floating-point-underflow, arithmetic-error, error, serious-condition, condition, t Description:: ............. The type floating-point-underflow consists of error conditions that occur because of floating-point underflow.  File: gcl.info, Node: Characters, Next: Conses, Prev: Numbers (Numbers), Up: Top 13 Characters ************* * Menu: * Character Concepts:: * Characters Dictionary::  File: gcl.info, Node: Character Concepts, Next: Characters Dictionary, Prev: Characters, Up: Characters 13.1 Character Concepts ======================= * Menu: * Introduction to Characters:: * Introduction to Scripts and Repertoires:: * Character Attributes:: * Character Categories:: * Identity of Characters:: * Ordering of Characters:: * Character Names:: * Treatment of Newline during Input and Output:: * Character Encodings:: * Documentation of Implementation-Defined Scripts::  File: gcl.info, Node: Introduction to Characters, Next: Introduction to Scripts and Repertoires, Prev: Character Concepts, Up: Character Concepts 13.1.1 Introduction to Characters --------------------------------- A character is an object that represents a unitary token (e.g., a letter, a special symbol, or a "control character") in an aggregate quantity of text (e.g., a string or a text stream). Common Lisp allows an implementation to provide support for international language characters as well as characters used in specialized arenas (e.g., mathematics). The following figures contain lists of defined names applicable to characters. Figure 13-1 lists some defined names relating to character attributes and character predicates. alpha-char-p char-not-equal char> alphanumericp char-not-greaterp char>= both-case-p char-not-lessp digit-char-p char-code-limit char/= graphic-char-p char-equal char< lower-case-p char-greaterp char<= standard-char-p char-lessp char= upper-case-p Figure 13-1: Character defined names - 1 Figure 13-2 lists some character construction and conversion defined names. char-code char-name code-char char-downcase char-upcase digit-char char-int character name-char Figure 13-2: Character defined names - 2  File: gcl.info, Node: Introduction to Scripts and Repertoires, Next: Character Attributes, Prev: Introduction to Characters, Up: Character Concepts 13.1.2 Introduction to Scripts and Repertoires ---------------------------------------------- * Menu: * Character Scripts:: * Character Repertoires::  File: gcl.info, Node: Character Scripts, Next: Character Repertoires, Prev: Introduction to Scripts and Repertoires, Up: Introduction to Scripts and Repertoires 13.1.2.1 Character Scripts .......................... A script is one of possibly several sets that form an exhaustive partition of the type character. The number of such sets and boundaries between them is implementation-defined. Common Lisp does not require these sets to be types, but an implementation is permitted to define such types as an extension. Since no character from one script can ever be a member of another script, it is generally more useful to speak about character repertoires. Although the term "script" is chosen for definitional compatibility with ISO terminology, no conforming implementation is required to use any particular scripts standardized by ISO or by any other standards organization. Whether and how the script or scripts used by any given implementation are named is implementation-dependent.  File: gcl.info, Node: Character Repertoires, Prev: Character Scripts, Up: Introduction to Scripts and Repertoires 13.1.2.2 Character Repertoires .............................. A repertoire is a type specifier for a subtype of type character. This term is generally used when describing a collection of characters independent of their coding. Characters in repertoires are only identified by name, by glyph, or by character description. A repertoire can contain characters from several scripts, and a character can appear in more than one repertoire. For some examples of repertoires, see the coded character standards ISO 8859/1, ISO 8859/2, and ISO 6937/2. Note, however, that although the term "repertoire" is chosen for definitional compatibility with ISO terminology, no conforming implementation is required to use repertoires standardized by ISO or any other standards organization.  File: gcl.info, Node: Character Attributes, Next: Character Categories, Prev: Introduction to Scripts and Repertoires, Up: Character Concepts 13.1.3 Character Attributes --------------------------- Characters have only one standardized attribute: a code. A character's code is a non-negative integer. This code is composed from a character script and a character label in an implementation-dependent way. See the functions char-code and code-char. Additional, implementation-defined attributes of characters are also permitted so that, for example, two characters with the same code may differ in some other, implementation-defined way. For any implementation-defined attribute there is a distinguished value called the null value for that attribute. A character for which each implementation-defined attribute has the null value for that attribute is called a simple character. If the implementation has no implementation-defined attributes, then all characters are simple characters.  File: gcl.info, Node: Character Categories, Next: Identity of Characters, Prev: Character Attributes, Up: Character Concepts 13.1.4 Character Categories --------------------------- There are several (overlapping) categories of characters that have no formally associated type but that are nevertheless useful to name. They include graphic characters, alphabetic_1 characters, characters with case (uppercase and lowercase characters), numeric characters, alphanumeric characters, and digits (in a given radix). For each implementation-defined attribute of a character, the documentation for that implementation must specify whether characters that differ only in that attribute are permitted to differ in whether are not they are members of one of the aforementioned categories. Note that these terms are defined independently of any special syntax which might have been enabled in the current readtable. * Menu: * Graphic Characters:: * Alphabetic Characters:: * Characters With Case:: * Uppercase Characters:: * Lowercase Characters:: * Corresponding Characters in the Other Case:: * Case of Implementation-Defined Characters:: * Numeric Characters:: * Alphanumeric Characters:: * Digits in a Radix::  File: gcl.info, Node: Graphic Characters, Next: Alphabetic Characters, Prev: Character Categories, Up: Character Categories 13.1.4.1 Graphic Characters ........................... Characters that are classified as graphic , or displayable, are each associated with a glyph, a visual representation of the character. A graphic character is one that has a standard textual representation as a single glyph, such as A or * or =. Space, which effectively has a blank glyph, is defined to be a graphic. Of the standard characters, newline is non-graphic and all others are graphic; see *note Standard Characters::. Characters that are not graphic are called non-graphic . Non-graphic characters are sometimes informally called "formatting characters" or "control characters." #\Backspace, #\Tab, #\Rubout, #\Linefeed, #\Return, and #\Page, if they are supported by the implementation, are non-graphic.  File: gcl.info, Node: Alphabetic Characters, Next: Characters With Case, Prev: Graphic Characters, Up: Character Categories 13.1.4.2 Alphabetic Characters .............................. The alphabetic_1 characters are a subset of the graphic characters. Of the standard characters, only these are the alphabetic_1 characters: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z Any implementation-defined character that has case must be alphabetic_1. For each implementation-defined graphic character that has no case, it is implementation-defined whether that character is alphabetic_1.  File: gcl.info, Node: Characters With Case, Next: Uppercase Characters, Prev: Alphabetic Characters, Up: Character Categories 13.1.4.3 Characters With Case ............................. The characters with case are a subset of the alphabetic_1 characters. A character with case has the property of being either uppercase or lowercase. Every character with case is in one-to-one correspondence with some other character with the opposite case.  File: gcl.info, Node: Uppercase Characters, Next: Lowercase Characters, Prev: Characters With Case, Up: Character Categories 13.1.4.4 Uppercase Characters ............................. An uppercase character is one that has a corresponding lowercase character that is different (and can be obtained using char-downcase). Of the standard characters, only these are uppercase characters: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z  File: gcl.info, Node: Lowercase Characters, Next: Corresponding Characters in the Other Case, Prev: Uppercase Characters, Up: Character Categories 13.1.4.5 Lowercase Characters ............................. A lowercase character is one that has a corresponding uppercase character that is different (and can be obtained using char-upcase). Of the standard characters, only these are lowercase characters: a b c d e f g h i j k l m n o p q r s t u v w x y z  File: gcl.info, Node: Corresponding Characters in the Other Case, Next: Case of Implementation-Defined Characters, Prev: Lowercase Characters, Up: Character Categories 13.1.4.6 Corresponding Characters in the Other Case ................................................... The uppercase standard characters A through Z mentioned above respectively correspond to the lowercase standard characters a through z mentioned above. For example, the uppercase character E corresponds to the lowercase character e, and vice versa.  File: gcl.info, Node: Case of Implementation-Defined Characters, Next: Numeric Characters, Prev: Corresponding Characters in the Other Case, Up: Character Categories 13.1.4.7 Case of Implementation-Defined Characters .................................................. An implementation may define that other implementation-defined graphic characters have case. Such definitions must always be done in pairs--one uppercase character in one-to-one correspondence with one lowercase character.  File: gcl.info, Node: Numeric Characters, Next: Alphanumeric Characters, Prev: Case of Implementation-Defined Characters, Up: Character Categories 13.1.4.8 Numeric Characters ........................... The numeric characters are a subset of the graphic characters. Of the standard characters, only these are numeric characters: 0 1 2 3 4 5 6 7 8 9 For each implementation-defined graphic character that has no case, the implementation must define whether or not it is a numeric character.  File: gcl.info, Node: Alphanumeric Characters, Next: Digits in a Radix, Prev: Numeric Characters, Up: Character Categories 13.1.4.9 Alphanumeric Characters ................................ The set of alphanumeric characters is the union of the set of alphabetic_1 characters and the set of numeric characters.  File: gcl.info, Node: Digits in a Radix, Prev: Alphanumeric Characters, Up: Character Categories 13.1.4.10 Digits in a Radix ........................... What qualifies as a digit depends on the radix (an integer between 2 and 36, inclusive). The potential digits are: 0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z Their respective weights are 0, 1, 2, ... 35. In any given radix n, only the first n potential digits are considered to be digits. For example, the digits in radix 2 are 0 and 1, the digits in radix 10 are 0 through 9, and the digits in radix 16 are 0 through F. Case is not significant in digits; for example, in radix 16, both F and f are digits with weight 15.  File: gcl.info, Node: Identity of Characters, Next: Ordering of Characters, Prev: Character Categories, Up: Character Concepts 13.1.5 Identity of Characters ----------------------------- Two characters that are eql, char=, or char-equal are not necessarily eq.  File: gcl.info, Node: Ordering of Characters, Next: Character Names, Prev: Identity of Characters, Up: Character Concepts 13.1.6 Ordering of Characters ----------------------------- The total ordering on characters is guaranteed to have the following properties: * If two characters have the same implementation-defined attributes, then their ordering by char< is consistent with the numerical ordering by the predicate < on their code attributes. * If two characters differ in any attribute, then they are not char=. [Reviewer Note by Barmar: I wonder if we should say that the ordering may be dependent on the implementation-defined attributes.] * The total ordering is not necessarily the same as the total ordering on the integers produced by applying char-int to the characters. * While alphabetic_1 standard characters of a given case must obey a partial ordering, they need not be contiguous; it is permissible for uppercase and lowercase characters to be interleaved. Thus (char<= #\a x #\z) is not a valid way of determining whether or not x is a lowercase character. Of the standard characters, those which are alphanumeric obey the following partial ordering: A, char<=, char>=, --------------------------------------------------- char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, ------------------------------------------------------------------------- char-not-lessp -------------- [Function] 'char=' &rest characters^+ => generalized-boolean 'char/=' &rest characters^+ => generalized-boolean 'char<' &rest characters^+ => generalized-boolean 'char>' &rest characters^+ => generalized-boolean 'char<=' &rest characters^+ => generalized-boolean 'char>=' &rest characters^+ => generalized-boolean 'char-equal' &rest characters^+ => generalized-boolean 'char-not-equal' &rest characters^+ => generalized-boolean 'char-lessp' &rest characters^+ => generalized-boolean 'char-greaterp' &rest characters^+ => generalized-boolean 'char-not-greaterp' &rest characters^+ => generalized-boolean 'char-not-lessp' &rest characters^+ => generalized-boolean Arguments and Values:: ...................... character--a character. generalized-boolean--a generalized boolean. Description:: ............. These predicates compare characters. char= returns true if all characters are the same; otherwise, it returns false. If two characters differ in any implementation-defined attributes, then they are not char=. char/= returns true if all characters are different; otherwise, it returns false. char< returns true if the characters are monotonically increasing; otherwise, it returns false. If two characters have identical implementation-defined attributes, then their ordering by char< is consistent with the numerical ordering by the predicate < on their codes. char> returns true if the characters are monotonically decreasing; otherwise, it returns false. If two characters have identical implementation-defined attributes, then their ordering by char> is consistent with the numerical ordering by the predicate > on their codes. char<= returns true if the characters are monotonically nondecreasing; otherwise, it returns false. If two characters have identical implementation-defined attributes, then their ordering by char<= is consistent with the numerical ordering by the predicate <= on their codes. char>= returns true if the characters are monotonically nonincreasing; otherwise, it returns false. If two characters have identical implementation-defined attributes, then their ordering by char>= is consistent with the numerical ordering by the predicate >= on their codes. char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, and char-not-lessp are similar to char=, char/=, char<, char>, char<=, char>=, respectively, except that they ignore differences in case and might have an implementation-defined behavior for non-simple characters. For example, an implementation might define that char-equal, etc. ignore certain implementation-defined attributes. The effect, if any, of each implementation-defined attribute upon these functions must be specified as part of the definition of that attribute. Examples:: .......... (char= #\d #\d) => true (char= #\A #\a) => false (char= #\d #\x) => false (char= #\d #\D) => false (char/= #\d #\d) => false (char/= #\d #\x) => true (char/= #\d #\D) => true (char= #\d #\d #\d #\d) => true (char/= #\d #\d #\d #\d) => false (char= #\d #\d #\x #\d) => false (char/= #\d #\d #\x #\d) => false (char= #\d #\y #\x #\c) => false (char/= #\d #\y #\x #\c) => true (char= #\d #\c #\d) => false (char/= #\d #\c #\d) => false (char< #\d #\x) => true (char<= #\d #\x) => true (char< #\d #\d) => false (char<= #\d #\d) => true (char< #\a #\e #\y #\z) => true (char<= #\a #\e #\y #\z) => true (char< #\a #\e #\e #\y) => false (char<= #\a #\e #\e #\y) => true (char> #\e #\d) => true (char>= #\e #\d) => true (char> #\d #\c #\b #\a) => true (char>= #\d #\c #\b #\a) => true (char> #\d #\d #\c #\a) => false (char>= #\d #\d #\c #\a) => true (char> #\e #\d #\b #\c #\a) => false (char>= #\e #\d #\b #\c #\a) => false (char> #\z #\A) => implementation-dependent (char> #\Z #\a) => implementation-dependent (char-equal #\A #\a) => true (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp) => (#\A #\a #\b #\B #\c #\C) (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char<) => (#\A #\B #\C #\a #\b #\c) ;Implementation A => (#\a #\b #\c #\A #\B #\C) ;Implementation B => (#\a #\A #\b #\B #\c #\C) ;Implementation C => (#\A #\a #\B #\b #\C #\c) ;Implementation D => (#\A #\B #\a #\b #\C #\c) ;Implementation E Exceptional Situations:: ........................ Should signal an error of type program-error if at least one character is not supplied. See Also:: .......... *note Character Syntax::, *note Documentation of Implementation-Defined Scripts:: Notes:: ....... If characters differ in their code attribute or any implementation-defined attribute, they are considered to be different by char=. There is no requirement that (eq c1 c2) be true merely because (char= c1 c2) is true. While eq can distinguish two characters that char= does not, it is distinguishing them not as characters, but in some sense on the basis of a lower level implementation characteristic. If (eq c1 c2) is true, then (char= c1 c2) is also true. eql and equal compare characters in the same way that char= does. The manner in which case is used by char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, and char-not-lessp implies an ordering for standard characters such that A=a, B=b, and so on, up to Z=z, and furthermore either 9 denoted-character Arguments and Values:: ...................... character--a character designator. denoted-character--a character. Description:: ............. Returns the character denoted by the character designator. Examples:: .......... (character #\a) => #\a (character "a") => #\a (character 'a) => #\A (character '\a) => #\a (character 65.) is an error. (character 'apple) is an error. Exceptional Situations:: ........................ Should signal an error of type type-error if object is not a character designator. See Also:: .......... *note coerce:: Notes:: ....... (character object) == (coerce object 'character)  File: gcl.info, Node: characterp, Next: alpha-char-p, Prev: character, Up: Characters Dictionary 13.2.7 characterp [Function] ---------------------------- 'characterp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type character; otherwise, returns false. Examples:: .......... (characterp #\a) => true (characterp 'a) => false (characterp "a") => false (characterp 65.) => false (characterp #\Newline) => true ;; This next example presupposes an implementation ;; in which #\Rubout is an implementation-defined character. (characterp #\Rubout) => true See Also:: .......... *note character:: (type and function), *note typep:: Notes:: ....... (characterp object) == (typep object 'character)  File: gcl.info, Node: alpha-char-p, Next: alphanumericp, Prev: characterp, Up: Characters Dictionary 13.2.8 alpha-char-p [Function] ------------------------------ 'alpha-char-p' character => generalized-boolean Arguments and Values:: ...................... character--a character. generalized-boolean--a generalized boolean. Description:: ............. Returns true if character is an alphabetic_1 character; otherwise, returns false. Examples:: .......... (alpha-char-p #\a) => true (alpha-char-p #\5) => false (alpha-char-p #\Newline) => false ;; This next example presupposes an implementation ;; in which #\\alpha is a defined character. (alpha-char-p #\\alpha) => implementation-dependent Affected By:: ............. None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.) Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note alphanumericp:: , *note Documentation of Implementation-Defined Scripts::  File: gcl.info, Node: alphanumericp, Next: digit-char, Prev: alpha-char-p, Up: Characters Dictionary 13.2.9 alphanumericp [Function] ------------------------------- 'alphanumericp' character => generalized-boolean Arguments and Values:: ...................... character--a character. generalized-boolean--a generalized boolean. Description:: ............. Returns true if character is an alphabetic_1 character or a numeric character; otherwise, returns false. Examples:: .......... (alphanumericp #\Z) => true (alphanumericp #\9) => true (alphanumericp #\Newline) => false (alphanumericp #\#) => false Affected By:: ............. None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.) Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note alpha-char-p:: , *note graphic-char-p:: , *note digit-char-p:: Notes:: ....... Alphanumeric characters are graphic as defined by graphic-char-p. The alphanumeric characters are a subset of the graphic characters. The standard characters A through Z, a through z, and 0 through 9 are alphanumeric characters. (alphanumericp x) == (or (alpha-char-p x) (not (null (digit-char-p x))))  File: gcl.info, Node: digit-char, Next: digit-char-p, Prev: alphanumericp, Up: Characters Dictionary 13.2.10 digit-char [Function] ----------------------------- 'digit-char' weight &optional radix => char Arguments and Values:: ...................... weight--a non-negative integer. radix--a radix. The default is 10. char--a character or false. Description:: ............. If weight is less than radix, digit-char returns a character which has that weight when considered as a digit in the specified radix. If the resulting character is to be an alphabetic_1 character, it will be an uppercase character. If weight is greater than or equal to radix, digit-char returns false. Examples:: .......... (digit-char 0) => #\0 (digit-char 10 11) => #\A (digit-char 10 10) => false (digit-char 7) => #\7 (digit-char 12) => false (digit-char 12 16) => #\C ;not #\c (digit-char 6 2) => false (digit-char 1 2) => #\1 See Also:: .......... *note digit-char-p:: , *note graphic-char-p:: , *note Character Syntax:: Notes:: .......  File: gcl.info, Node: digit-char-p, Next: graphic-char-p, Prev: digit-char, Up: Characters Dictionary 13.2.11 digit-char-p [Function] ------------------------------- 'digit-char-p' char &optional radix => weight Arguments and Values:: ...................... char--a character. radix--a radix. The default is 10. weight--either a non-negative integer less than radix, or false. Description:: ............. Tests whether char is a digit in the specified radix (i.e., with a weight less than radix). If it is a digit in that radix, its weight is returned as an integer; otherwise nil is returned. Examples:: .......... (digit-char-p #\5) => 5 (digit-char-p #\5 2) => false (digit-char-p #\A) => false (digit-char-p #\a) => false (digit-char-p #\A 11) => 10 (digit-char-p #\a 11) => 10 (mapcar #'(lambda (radix) (map 'list #'(lambda (x) (digit-char-p x radix)) "059AaFGZ")) '(2 8 10 16 36)) => ((0 NIL NIL NIL NIL NIL NIL NIL) (0 5 NIL NIL NIL NIL NIL NIL) (0 5 9 NIL NIL NIL NIL NIL) (0 5 9 10 10 15 NIL NIL) (0 5 9 10 10 15 16 35)) Affected By:: ............. None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.) See Also:: .......... *note alphanumericp:: Notes:: ....... Digits are graphic characters.  File: gcl.info, Node: graphic-char-p, Next: standard-char-p, Prev: digit-char-p, Up: Characters Dictionary 13.2.12 graphic-char-p [Function] --------------------------------- 'graphic-char-p' char => generalized-boolean Arguments and Values:: ...................... char--a character. generalized-boolean--a generalized boolean. Description:: ............. Returns true if character is a graphic character; otherwise, returns false. Examples:: .......... (graphic-char-p #\G) => true (graphic-char-p #\#) => true (graphic-char-p #\Space) => true (graphic-char-p #\Newline) => false Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note read:: , *note Character Syntax::, *note Documentation of Implementation-Defined Scripts::  File: gcl.info, Node: standard-char-p, Next: char-upcase, Prev: graphic-char-p, Up: Characters Dictionary 13.2.13 standard-char-p [Function] ---------------------------------- 'standard-char-p' character => generalized-boolean Arguments and Values:: ...................... character--a character. generalized-boolean--a generalized boolean. Description:: ............. Returns true if character is of type standard-char; otherwise, returns false. Examples:: .......... (standard-char-p #\Space) => true (standard-char-p #\~) => true ;; This next example presupposes an implementation ;; in which #\Bell is a defined character. (standard-char-p #\Bell) => false Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character.  File: gcl.info, Node: char-upcase, Next: upper-case-p, Prev: standard-char-p, Up: Characters Dictionary 13.2.14 char-upcase, char-downcase [Function] --------------------------------------------- 'char-upcase' character => corresponding-character 'char-downcase' character => corresponding-character Arguments and Values:: ...................... character, corresponding-character--a character. Description:: ............. If character is a lowercase character, char-upcase returns the corresponding uppercase character. Otherwise, char-upcase just returns the given character. If character is an uppercase character, char-downcase returns the corresponding lowercase character. Otherwise, char-downcase just returns the given character. The result only ever differs from character in its code attribute; all implementation-defined attributes are preserved. Examples:: .......... (char-upcase #\a) => #\A (char-upcase #\A) => #\A (char-downcase #\a) => #\a (char-downcase #\A) => #\a (char-upcase #\9) => #\9 (char-downcase #\9) => #\9 (char-upcase #\@) => #\@ (char-downcase #\@) => #\@ ;; Note that this next example might run for a very long time in ;; some implementations if CHAR-CODE-LIMIT happens to be very large ;; for that implementation. (dotimes (code char-code-limit) (let ((char (code-char code))) (when char (unless (cond ((upper-case-p char) (char= (char-upcase (char-downcase char)) char)) ((lower-case-p char) (char= (char-downcase (char-upcase char)) char)) (t (and (char= (char-upcase (char-downcase char)) char) (char= (char-downcase (char-upcase char)) char)))) (return char))))) => NIL Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note upper-case-p:: , *note alpha-char-p:: , *note Characters With Case::, *note Documentation of Implementation-Defined Scripts:: Notes:: ....... If the corresponding-char is different than character, then both the character and the corresponding-char have case. Since char-equal ignores the case of the characters it compares, the corresponding-character is always the same as character under char-equal.  File: gcl.info, Node: upper-case-p, Next: char-code, Prev: char-upcase, Up: Characters Dictionary 13.2.15 upper-case-p, lower-case-p, both-case-p [Function] ---------------------------------------------------------- 'upper-case-p' character => generalized-boolean 'lower-case-p' character => generalized-boolean 'both-case-p' character => generalized-boolean Arguments and Values:: ...................... character--a character. generalized-boolean--a generalized boolean. Description:: ............. These functions test the case of a given character. upper-case-p returns true if character is an uppercase character; otherwise, returns false. lower-case-p returns true if character is a lowercase character; otherwise, returns false. both-case-p returns true if character is a character with case; otherwise, returns false. Examples:: .......... (upper-case-p #\A) => true (upper-case-p #\a) => false (both-case-p #\a) => true (both-case-p #\5) => false (lower-case-p #\5) => false (upper-case-p #\5) => false ;; This next example presupposes an implementation ;; in which #\Bell is an implementation-defined character. (lower-case-p #\Bell) => false Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note char-upcase:: , char-downcase, *note Characters With Case::, *note Documentation of Implementation-Defined Scripts::  File: gcl.info, Node: char-code, Next: char-int, Prev: upper-case-p, Up: Characters Dictionary 13.2.16 char-code [Function] ---------------------------- 'char-code' character => code Arguments and Values:: ...................... character--a character. code--a character code. Description:: ............. char-code returns the code attribute of character. Examples:: .......... ;; An implementation using ASCII character encoding ;; might return these values: (char-code #\$) => 36 (char-code #\a) => 97 Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note char-code-limit::  File: gcl.info, Node: char-int, Next: code-char, Prev: char-code, Up: Characters Dictionary 13.2.17 char-int [Function] --------------------------- 'char-int' character => integer Arguments and Values:: ...................... character--a character. integer--a non-negative integer. Description:: ............. Returns a non-negative integer encoding the character object. The manner in which the integer is computed is implementation-dependent. In contrast to sxhash, the result is not guaranteed to be independent of the particular Lisp image. If character has no implementation-defined attributes, the results of char-int and char-code are the same. (char= c1 c2) == (= (char-int c1) (char-int c2)) for characters c1 and c2. Examples:: .......... (char-int #\A) => 65 ; implementation A (char-int #\A) => 577 ; implementation B (char-int #\A) => 262145 ; implementation C See Also:: .......... *note char-code::  File: gcl.info, Node: code-char, Next: char-code-limit, Prev: char-int, Up: Characters Dictionary 13.2.18 code-char [Function] ---------------------------- 'code-char' code => char-p Arguments and Values:: ...................... code--a character code. char-p--a character or nil. Description:: ............. Returns a character with the code attribute given by code. If no such character exists and one cannot be created, nil is returned. Examples:: .......... (code-char 65.) => #\A ;in an implementation using ASCII codes (code-char (char-code #\Space)) => #\Space ;in any implementation Affected By:: ............. The implementation's character encoding. See Also:: .......... *note char-code:: Notes:: .......  File: gcl.info, Node: char-code-limit, Next: char-name, Prev: code-char, Up: Characters Dictionary 13.2.19 char-code-limit [Constant Variable] ------------------------------------------- Constant Value:: ................ A non-negative integer, the exact magnitude of which is implementation-dependent, but which is not less than 96 (the number of standard characters). Description:: ............. The upper exclusive bound on the value returned by the function char-code. See Also:: .......... *note char-code:: Notes:: ....... The value of char-code-limit might be larger than the actual number of characters supported by the implementation.  File: gcl.info, Node: char-name, Next: name-char, Prev: char-code-limit, Up: Characters Dictionary 13.2.20 char-name [Function] ---------------------------- 'char-name' character => name Arguments and Values:: ...................... character--a character. name--a string or nil. Description:: ............. Returns a string that is the name of the character, or nil if the character has no name. All non-graphic characters are required to have names unless they have some implementation-defined attribute which is not null. Whether or not other characters have names is implementation-dependent. The standard characters and have the respective names "Newline" and "Space". The semi-standard characters , , , , , and (if they are supported by the implementation) have the respective names "Tab", "Page", "Rubout", "Linefeed", "Return", and "Backspace" (in the indicated case, even though name lookup by "#\" and by the function name-char is not case sensitive). Examples:: .......... (char-name #\ ) => "Space" (char-name #\Space) => "Space" (char-name #\Page) => "Page" (char-name #\a) => NIL OR=> "LOWERCASE-a" OR=> "Small-A" OR=> "LA01" (char-name #\A) => NIL OR=> "UPPERCASE-A" OR=> "Capital-A" OR=> "LA02" ;; Even though its CHAR-NAME can vary, #\A prints as #\A (prin1-to-string (read-from-string (format nil "#\\~A" (or (char-name #\A) "A")))) => "#\\A" Exceptional Situations:: ........................ Should signal an error of type type-error if character is not a character. See Also:: .......... *note name-char:: , *note Printing Characters:: Notes:: ....... Non-graphic characters having names are written by the Lisp printer as "#\" followed by the their name; see *note Printing Characters::.  File: gcl.info, Node: name-char, Prev: char-name, Up: Characters Dictionary 13.2.21 name-char [Function] ---------------------------- 'name-char' name => char-p Arguments and Values:: ...................... name--a string designator. char-p--a character or nil. Description:: ............. Returns the character object whose name is name (as determined by string-equal--i.e., lookup is not case sensitive). If such a character does not exist, nil is returned. Examples:: .......... (name-char 'space) => #\Space (name-char "space") => #\Space (name-char "Space") => #\Space (let ((x (char-name #\a))) (or (not x) (eql (name-char x) #\a))) => true Exceptional Situations:: ........................ Should signal an error of type type-error if name is not a string designator. See Also:: .......... *note char-name::  File: gcl.info, Node: Conses, Next: Arrays, Prev: Characters, Up: Top 14 Conses ********* * Menu: * Cons Concepts:: * Conses Dictionary::  File: gcl.info, Node: Cons Concepts, Next: Conses Dictionary, Prev: Conses, Up: Conses 14.1 Cons Concepts ================== A cons is a compound data object having two components called the car and the cdr. car cons rplacd cdr rplaca Figure 14-1: Some defined names relating to conses. Depending on context, a group of connected conses can be viewed in a variety of different ways. A variety of operations is provided to support each of these various views. * Menu: * Conses as Trees:: * Conses as Lists::  File: gcl.info, Node: Conses as Trees, Next: Conses as Lists, Prev: Cons Concepts, Up: Cons Concepts 14.1.1 Conses as Trees ---------------------- A tree is a binary recursive data structure made up of conses and atoms: the conses are themselves also trees (sometimes called "subtrees" or "branches"), and the atoms are terminal nodes (sometimes called leaves ). Typically, the leaves represent data while the branches establish some relationship among that data. caaaar caddar cdar nsubst caaadr cadddr cddaar nsubst-if caaar caddr cddadr nsubst-if-not caadar cadr cddar nthcdr caaddr cdaaar cdddar sublis caadr cdaadr cddddr subst caar cdaar cdddr subst-if cadaar cdadar cddr subst-if-not cadadr cdaddr copy-tree tree-equal cadar cdadr nsublis Figure 14-2: Some defined names relating to trees. * Menu: * General Restrictions on Parameters that must be Trees::  File: gcl.info, Node: General Restrictions on Parameters that must be Trees, Prev: Conses as Trees, Up: Conses as Trees 14.1.1.1 General Restrictions on Parameters that must be Trees .............................................................. Except as explicitly stated otherwise, for any standardized function that takes a parameter that is required to be a tree, the consequences are undefined if that tree is circular.  File: gcl.info, Node: Conses as Lists, Prev: Conses as Trees, Up: Cons Concepts 14.1.2 Conses as Lists ---------------------- A list is a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom. A proper list is a list terminated by the empty list. The empty list is a proper list, but is not a cons. An improper list is a list that is not a proper list; that is, it is a circular list or a dotted list. A dotted list is a list that has a terminating atom that is not the empty list. A non-nil atom by itself is not considered to be a list of any kind--not even a dotted list. A circular list is a chain of conses that has no termination because some cons in the chain is the cdr of a later cons. append last nbutlast rest butlast ldiff nconc revappend copy-alist list ninth second copy-list list* nreconc seventh eighth list-length nth sixth endp make-list nthcdr tailp fifth member pop tenth first member-if push third fourth member-if-not pushnew Figure 14-3: Some defined names relating to lists. * Menu: * Lists as Association Lists:: * Lists as Sets:: * General Restrictions on Parameters that must be Lists::  File: gcl.info, Node: Lists as Association Lists, Next: Lists as Sets, Prev: Conses as Lists, Up: Conses as Lists 14.1.2.1 Lists as Association Lists ................................... An association list is a list of conses representing an association of keys with values, where the car of each cons is the key and the cdr is the value associated with that key. acons assoc-if pairlis rassoc-if assoc assoc-if-not rassoc rassoc-if-not Figure 14-4: Some defined names related to assocation lists.  File: gcl.info, Node: Lists as Sets, Next: General Restrictions on Parameters that must be Lists, Prev: Lists as Association Lists, Up: Conses as Lists 14.1.2.2 Lists as Sets ...................... Lists are sometimes viewed as sets by considering their elements unordered and by assuming there is no duplication of elements. adjoin nset-difference set-difference union intersection nset-exclusive-or set-exclusive-or nintersection nunion subsetp Figure 14-5: Some defined names related to sets.  File: gcl.info, Node: General Restrictions on Parameters that must be Lists, Prev: Lists as Sets, Up: Conses as Lists 14.1.2.3 General Restrictions on Parameters that must be Lists .............................................................. Except as explicitly specified otherwise, any standardized function that takes a parameter that is required to be a list should be prepared to signal an error of type type-error if the value received is a dotted list. Except as explicitly specified otherwise, for any standardized function that takes a parameter that is required to be a list, the consequences are undefined if that list is circular.  File: gcl.info, Node: Conses Dictionary, Prev: Cons Concepts, Up: Conses 14.2 Conses Dictionary ====================== * Menu: * list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: * cons:: * consp:: * atom:: * rplaca:: * car:: * copy-tree:: * sublis:: * subst:: * tree-equal:: * copy-list:: * list (Function):: * list-length:: * listp:: * make-list:: * push:: * pop:: * first:: * nth:: * endp:: * null:: * nconc:: * append:: * revappend:: * butlast:: * last:: * ldiff:: * nthcdr:: * rest:: * member (Function):: * mapc:: * acons:: * assoc:: * copy-alist:: * pairlis:: * rassoc:: * get-properties:: * getf:: * remf:: * intersection:: * adjoin:: * pushnew:: * set-difference:: * set-exclusive-or:: * subsetp:: * union::  File: gcl.info, Node: list (System Class), Next: null (System Class), Prev: Conses Dictionary, Up: Conses Dictionary 14.2.1 list [System Class] -------------------------- Class Precedence List:: ....................... list, sequence, t Description:: ............. A list is a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom. A proper list is a chain of conses terminated by the empty list , (), which is itself a proper list. A dotted list is a list which has a terminating atom that is not the empty list. A circular list is a chain of conses that has no termination because some cons in the chain is the cdr of a later cons. Dotted lists and circular lists are also lists, but usually the unqualified term "list" within this specification means proper list. Nevertheless, the type list unambiguously includes dotted lists and circular lists. For each element of a list there is a cons. The empty list has no elements and is not a cons. The types cons and null form an exhaustive partition of the type list. See Also:: .......... *note Left-Parenthesis::, *note Printing Lists and Conses::  File: gcl.info, Node: null (System Class), Next: cons (System Class), Prev: list (System Class), Up: Conses Dictionary 14.2.2 null [System Class] -------------------------- Class Precedence List:: ....................... null, symbol, list, sequence, t Description:: ............. The only object of type null is nil, which represents the empty list and can also be notated (). See Also:: .......... *note Symbols as Tokens::, *note Left-Parenthesis::, *note Printing Symbols::  File: gcl.info, Node: cons (System Class), Next: atom (Type), Prev: null (System Class), Up: Conses Dictionary 14.2.3 cons [System Class] -------------------------- Class Precedence List:: ....................... cons, list, sequence, t Description:: ............. A cons is a compound object having two components, called the car and cdr. These form a dotted pair. Each component can be any object. Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('cons'{[car-typespec [cdr-typespec]]}) Compound Type Specifier Arguments:: ................................... car-typespec--a type specifier, or the symbol *. The default is the symbol *. cdr-typespec--a type specifier, or the symbol *. The default is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the set of conses whose car is constrained to be of type car-typespec and whose cdr is constrained to be of type cdr-typespec. (If either car-typespec or cdr-typespec is *, it is as if the type t had been denoted.) See Also:: .......... *note Left-Parenthesis::, *note Printing Lists and Conses::  File: gcl.info, Node: atom (Type), Next: cons, Prev: cons (System Class), Up: Conses Dictionary 14.2.4 atom [Type] ------------------ Supertypes:: ............ atom, t Description:: ............. It is equivalent to (not cons).  File: gcl.info, Node: cons, Next: consp, Prev: atom (Type), Up: Conses Dictionary 14.2.5 cons [Function] ---------------------- 'cons' object-1 object-2 => cons Arguments and Values:: ...................... object-1--an object. object-2--an object. cons--a cons. Description:: ............. Creates a fresh cons, the car of which is object-1 and the cdr of which is object-2. Examples:: .......... (cons 1 2) => (1 . 2) (cons 1 nil) => (1) (cons nil 2) => (NIL . 2) (cons nil nil) => (NIL) (cons 1 (cons 2 (cons 3 (cons 4 nil)))) => (1 2 3 4) (cons 'a 'b) => (A . B) (cons 'a (cons 'b (cons 'c '()))) => (A B C) (cons 'a '(b c d)) => (A B C D) See Also:: .......... *note list (Function):: Notes:: ....... If object-2 is a list, cons can be thought of as producing a new list which is like it but has object-1 prepended.  File: gcl.info, Node: consp, Next: atom, Prev: cons, Up: Conses Dictionary 14.2.6 consp [Function] ----------------------- 'consp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type cons; otherwise, returns false. Examples:: .......... (consp nil) => false (consp (cons 1 2)) => true The empty list is not a cons, so (consp '()) == (consp 'nil) => false See Also:: .......... *note listp:: Notes:: ....... (consp object) == (typep object 'cons) == (not (typep object 'atom)) == (typep object '(not atom))  File: gcl.info, Node: atom, Next: rplaca, Prev: consp, Up: Conses Dictionary 14.2.7 atom [Function] ---------------------- 'atom' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type atom; otherwise, returns false. Examples:: .......... (atom 'sss) => true (atom (cons 1 2)) => false (atom nil) => true (atom '()) => true (atom 3) => true Notes:: ....... (atom object) == (typep object 'atom) == (not (consp object)) == (not (typep object 'cons)) == (typep object '(not cons))  File: gcl.info, Node: rplaca, Next: car, Prev: atom, Up: Conses Dictionary 14.2.8 rplaca, rplacd [Function] -------------------------------- 'rplaca' cons object => cons 'rplacd' cons object => cons Pronunciation:: ............... rplaca: pronounced ,r\=e 'plak e or pronounced ,re 'plak e rplacd: pronounced ,r\=e 'plak de or pronounced ,re 'plak de or pronounced ,r\=e 'plak d\=e or pronounced ,re 'plak d\=e Arguments and Values:: ...................... cons--a cons. object--an object. Description:: ............. rplaca replaces the car of the cons with object. rplacd replaces the cdr of the cons with object. Examples:: .......... (defparameter *some-list* (list* 'one 'two 'three 'four)) => *some-list* *some-list* => (ONE TWO THREE . FOUR) (rplaca *some-list* 'uno) => (UNO TWO THREE . FOUR) *some-list* => (UNO TWO THREE . FOUR) (rplacd (last *some-list*) (list 'IV)) => (THREE IV) *some-list* => (UNO TWO THREE IV) Side Effects:: .............. The cons is modified. Should signal an error of type type-error if cons is not a cons.  File: gcl.info, Node: car, Next: copy-tree, Prev: rplaca, Up: Conses Dictionary 14.2.9 car, cdr, ---------------- caar, cadr, cdar, cddr, ----------------------- caaar, caadr, cadar, caddr, cdaar, cdadr, cddar, cdddr, ------------------------------------------------------- caaaar, caaadr, caadar, caaddr, cadaar, cadadr, caddar, cadddr, --------------------------------------------------------------- cdaaar, cdaadr, cdadar, cdaddr, cddaar, cddadr, cdddar, cddddr -------------------------------------------------------------- [Accessor] 'car' x => object (setf ('car' x) new-object) 'cdr' x => object (setf ('cdr' x) new-object) '\vksip 5pt' x => object (setf ('\vksip 5pt' x) new-object) 'caar' x => object (setf ('caar' x) new-object) 'cadr' x => object (setf ('cadr' x) new-object) 'cdar' x => object (setf ('cdar' x) new-object) 'cddr' x => object (setf ('cddr' x) new-object) '\vksip 5pt' x => object (setf ('\vksip 5pt' x) new-object) 'caaar' x => object (setf ('caaar' x) new-object) 'caadr' x => object (setf ('caadr' x) new-object) 'cadar' x => object (setf ('cadar' x) new-object) 'caddr' x => object (setf ('caddr' x) new-object) 'cdaar' x => object (setf ('cdaar' x) new-object) 'cdadr' x => object (setf ('cdadr' x) new-object) 'cddar' x => object (setf ('cddar' x) new-object) 'cdddr' x => object (setf ('cdddr' x) new-object) '\vksip 5pt' x => object (setf ('\vksip 5pt' x) new-object) 'caaaar' x => object (setf ('caaaar' x) new-object) 'caaadr' x => object (setf ('caaadr' x) new-object) 'caadar' x => object (setf ('caadar' x) new-object) 'caaddr' x => object (setf ('caaddr' x) new-object) 'cadaar' x => object (setf ('cadaar' x) new-object) 'cadadr' x => object (setf ('cadadr' x) new-object) 'caddar' x => object (setf ('caddar' x) new-object) 'cadddr' x => object (setf ('cadddr' x) new-object) 'cdaaar' x => object (setf ('cdaaar' x) new-object) 'cdaadr' x => object (setf ('cdaadr' x) new-object) 'cdadar' x => object (setf ('cdadar' x) new-object) 'cdaddr' x => object (setf ('cdaddr' x) new-object) 'cddaar' x => object (setf ('cddaar' x) new-object) 'cddadr' x => object (setf ('cddadr' x) new-object) 'cdddar' x => object (setf ('cdddar' x) new-object) 'cddddr' x => object (setf ('cddddr' x) new-object) Pronunciation:: ............... cadr: pronounced 'ka ,de r caddr: pronounced 'kad e ,de r or pronounced 'ka ,dude r cdr: pronounced 'ku ,de r cddr: pronounced 'kud e ,de r or pronounced 'ke ,dude r Arguments and Values:: ...................... x--a list. object--an object. new-object--an object. Description:: ............. If x is a cons, car returns the car of that cons. If x is nil, car returns nil. If x is a cons, cdr returns the cdr of that cons. If x is nil, cdr returns nil. Functions are provided which perform compositions of up to four car and cdr operations. Their names consist of a C, followed by two, three, or four occurrences of A or D, and finally an R. The series of A's and D's in each function's name is chosen to identify the series of car and cdr operations that is performed by the function. The order in which the A's and D's appear is the inverse of the order in which the corresponding operations are performed. Figure 14-6 defines the relationships precisely. This place ... Is equivalent to this place ... (caar x) (car (car x)) (cadr x) (car (cdr x)) (cdar x) (cdr (car x)) (cddr x) (cdr (cdr x)) (caaar x) (car (car (car x))) (caadr x) (car (car (cdr x))) (cadar x) (car (cdr (car x))) (caddr x) (car (cdr (cdr x))) (cdaar x) (cdr (car (car x))) (cdadr x) (cdr (car (cdr x))) (cddar x) (cdr (cdr (car x))) (cdddr x) (cdr (cdr (cdr x))) (caaaar x) (car (car (car (car x)))) (caaadr x) (car (car (car (cdr x)))) (caadar x) (car (car (cdr (car x)))) (caaddr x) (car (car (cdr (cdr x)))) (cadaar x) (car (cdr (car (car x)))) (cadadr x) (car (cdr (car (cdr x)))) (caddar x) (car (cdr (cdr (car x)))) (cadddr x) (car (cdr (cdr (cdr x)))) (cdaaar x) (cdr (car (car (car x)))) (cdaadr x) (cdr (car (car (cdr x)))) (cdadar x) (cdr (car (cdr (car x)))) (cdaddr x) (cdr (car (cdr (cdr x)))) (cddaar x) (cdr (cdr (car (car x)))) (cddadr x) (cdr (cdr (car (cdr x)))) (cdddar x) (cdr (cdr (cdr (car x)))) (cddddr x) (cdr (cdr (cdr (cdr x)))) Figure 14-6: CAR and CDR variants setf can also be used with any of these functions to change an existing component of x, but setf will not make new components. So, for example, the car of a cons can be assigned with setf of car, but the car of nil cannot be assigned with setf of car. Similarly, the car of the car of a cons whose car is a cons can be assigned with setf of caar, but neither nil nor a cons whose car is nil can be assigned with setf of caar. The argument x is permitted to be a dotted list or a circular list. Examples:: .......... (car nil) => NIL (cdr '(1 . 2)) => 2 (cdr '(1 2)) => (2) (cadr '(1 2)) => 2 (car '(a b c)) => A (cdr '(a b c)) => (B C) Exceptional Situations:: ........................ The functions car and cdr should signal type-error if they receive an argument which is not a list. The other functions (caar, cadr, ... cddddr) should behave for the purpose of error checking as if defined by appropriate calls to car and cdr. See Also:: .......... *note rplaca:: , *note first:: , *note rest:: Notes:: ....... The car of a cons can also be altered by using rplaca, and the cdr of a cons can be altered by using rplacd. (car x) == (first x) (cadr x) == (second x) == (car (cdr x)) (caddr x) == (third x) == (car (cdr (cdr x))) (cadddr x) == (fourth x) == (car (cdr (cdr (cdr x))))  File: gcl.info, Node: copy-tree, Next: sublis, Prev: car, Up: Conses Dictionary 14.2.10 copy-tree [Function] ---------------------------- 'copy-tree' tree => new-tree Arguments and Values:: ...................... tree--a tree. new-tree--a tree. Description:: ............. Creates a copy of a tree of conses. If tree is not a cons, it is returned; otherwise, the result is a new cons of the results of calling copy-tree on the car and cdr of tree. In other words, all conses in the tree represented by tree are copied recursively, stopping only when non-conses are encountered. copy-tree does not preserve circularities and the sharing of substructure. Examples:: .......... (setq object (list (cons 1 "one") (cons 2 (list 'a 'b 'c)))) => ((1 . "one") (2 A B C)) (setq object-too object) => ((1 . "one") (2 A B C)) (setq copy-as-list (copy-list object)) (setq copy-as-alist (copy-alist object)) (setq copy-as-tree (copy-tree object)) (eq object object-too) => true (eq copy-as-tree object) => false (eql copy-as-tree object) => false (equal copy-as-tree object) => true (setf (first (cdr (second object))) "a" (car (second object)) "two" (car object) '(one . 1)) => (ONE . 1) object => ((ONE . 1) ("two" "a" B C)) object-too => ((ONE . 1) ("two" "a" B C)) copy-as-list => ((1 . "one") ("two" "a" B C)) copy-as-alist => ((1 . "one") (2 "a" B C)) copy-as-tree => ((1 . "one") (2 A B C)) See Also:: .......... *note tree-equal::  File: gcl.info, Node: sublis, Next: subst, Prev: copy-tree, Up: Conses Dictionary 14.2.11 sublis, nsublis [Function] ---------------------------------- 'sublis' alist tree &key key test test-not => new-tree 'nsublis' alist tree &key key test test-not => new-tree Arguments and Values:: ...................... alist--an association list. tree--a tree. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. new-tree--a tree. Description:: ............. sublis makes substitutions for objects in tree (a structure of conses). nsublis is like sublis but destructively modifies the relevant parts of the tree. sublis looks at all subtrees and leaves of tree; if a subtree or leaf appears as a key in alist (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object with which that key is associated. This operation is non-destructive. In effect, sublis can perform several subst operations simultaneously. If sublis succeeds, a new copy of tree is returned in which each occurrence of such a subtree or leaf is replaced by the object with which it is associated. If no changes are made, the original tree is returned. The original tree is left unchanged, but the result tree may share cells with it. nsublis is permitted to modify tree but otherwise returns the same values as sublis. Examples:: .......... (sublis '((x . 100) (z . zprime)) '(plus x (minus g z x p) 4 . x)) => (PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100) (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) => (* (/ (- X Y) (+ X P)) (+ X Y)) (setq tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4))))) => (1 (1 2) ((1 2 3)) (((1 2 3 4)))) (sublis '((3 . "three")) tree1) => (1 (1 2) ((1 2 "three")) (((1 2 "three" 4)))) (sublis '((t . "string")) (sublis '((1 . "") (4 . 44)) tree1) :key #'stringp) => ("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44)))) tree1 => (1 (1 2) ((1 2 3)) (((1 2 3 4)))) (setq tree2 '("one" ("one" "two") (("one" "Two" "three")))) => ("one" ("one" "two") (("one" "Two" "three"))) (sublis '(("two" . 2)) tree2) => ("one" ("one" "two") (("one" "Two" "three"))) tree2 => ("one" ("one" "two") (("one" "Two" "three"))) (sublis '(("two" . 2)) tree2 :test 'equal) => ("one" ("one" 2) (("one" "Two" "three"))) (nsublis '((t . 'temp)) tree1 :key #'(lambda (x) (or (atom x) (< (list-length x) 3)))) => ((QUOTE TEMP) (QUOTE TEMP) QUOTE TEMP) Side Effects:: .............. nsublis modifies tree. See Also:: .......... *note subst:: , *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. Because the side-effecting variants (e.g., nsublis) potentially change the path that is being traversed, their effects in the presence of shared or circular structure structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: (defun test-it (fn) (let* ((shared-piece (list 'a 'b)) (data (list shared-piece shared-piece))) (funcall fn '((a . b) (b . a)) data))) (test-it #'sublis) => ((B A) (B A)) (test-it #'nsublis) => ((A B) (A B))  File: gcl.info, Node: subst, Next: tree-equal, Prev: sublis, Up: Conses Dictionary 14.2.12 subst, subst-if, subst-if-not, nsubst, nsubst-if, nsubst-if-not ----------------------------------------------------------------------- [Function] 'subst' new old tree &key key test test-not => new-tree 'subst-if' new predicate tree &key key => new-tree 'subst-if-not' new predicate tree &key key => new-tree 'nsubst' new old tree &key key test test-not => new-tree 'nsubst-if' new predicate tree &key key => new-tree 'nsubst-if-not' new predicate tree &key key => new-tree Arguments and Values:: ...................... new--an object. old--an object. predicate--a symbol that names a function, or a function of one argument that returns a generalized boolean value. tree--a tree. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. new-tree--a tree. Description:: ............. subst, subst-if, and subst-if-not perform substitution operations on tree. Each function searches tree for occurrences of a particular old item of an element or subexpression that satisfies the test. nsubst, nsubst-if, and nsubst-if-not are like subst, subst-if, and subst-if-not respectively, except that the original tree is modified. subst makes a copy of tree, substituting new for every subtree or leaf of tree (whether the subtree or leaf is a car or a cdr of its parent) such that old and the subtree or leaf satisfy the test. nsubst is a destructive version of subst. The list structure of tree is altered by destructively replacing with new each leaf of the tree such that old and the leaf satisfy the test. For subst, subst-if, and subst-if-not, if the functions succeed, a new copy of the tree is returned in which each occurrence of such an element is replaced by the new element or subexpression. If no changes are made, the original tree may be returned. The original tree is left unchanged, but the result tree may share storage with it. For nsubst, nsubst-if, and nsubst-if-not the original tree is modified and returned as the function result, but the result may not be eq to tree. Examples:: .......... (setq tree1 '(1 (1 2) (1 2 3) (1 2 3 4))) => (1 (1 2) (1 2 3) (1 2 3 4)) (subst "two" 2 tree1) => (1 (1 "two") (1 "two" 3) (1 "two" 3 4)) (subst "five" 5 tree1) => (1 (1 2) (1 2 3) (1 2 3 4)) (eq tree1 (subst "five" 5 tree1)) => implementation-dependent (subst 'tempest 'hurricane '(shakespeare wrote (the hurricane))) => (SHAKESPEARE WROTE (THE TEMPEST)) (subst 'foo 'nil '(shakespeare wrote (twelfth night))) => (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) (subst '(a . cons) '(old . pair) '((old . spice) ((old . shoes) old . pair) (old . pair)) :test #'equal) => ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) (subst-if 5 #'listp tree1) => 5 (subst-if-not '(x) #'consp tree1) => (1 X) tree1 => (1 (1 2) (1 2 3) (1 2 3 4)) (nsubst 'x 3 tree1 :key #'(lambda (y) (and (listp y) (third y)))) => (1 (1 2) X X) tree1 => (1 (1 2) X X) Side Effects:: .............. nsubst, nsubst-if, and nsubst-if-not might alter the tree structure of tree. See Also:: .......... *note substitute:: , nsubstitute, *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. The functions subst-if-not and nsubst-if-not are deprecated. One possible definition of subst: (defun subst (old new tree &rest x &key test test-not key) (cond ((satisfies-the-test old tree :test test :test-not test-not :key key) new) ((atom tree) tree) (t (let ((a (apply #'subst old new (car tree) x)) (d (apply #'subst old new (cdr tree) x))) (if (and (eql a (car tree)) (eql d (cdr tree))) tree (cons a d))))))  File: gcl.info, Node: tree-equal, Next: copy-list, Prev: subst, Up: Conses Dictionary 14.2.13 tree-equal [Function] ----------------------------- 'tree-equal' tree-1 tree-2 &key test test-not => generalized-boolean Arguments and Values:: ...................... tree-1--a tree. tree-2--a tree. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. generalized-boolean--a generalized boolean. Description:: ............. tree-equal tests whether two trees are of the same shape and have the same leaves. tree-equal returns true if tree-1 and tree-2 are both atoms and satisfy the test, or if they are both conses and the car of tree-1 is tree-equal to the car of tree-2 and the cdr of tree-1 is tree-equal to the cdr of tree-2. Otherwise, tree-equal returns false. tree-equal recursively compares conses but not any other objects that have components. The first argument to the :test or :test-not function is tree-1 or a car or cdr of tree-1; the second argument is tree-2 or a car or cdr of tree-2. Examples:: .......... (setq tree1 '(1 (1 2)) tree2 '(1 (1 2))) => (1 (1 2)) (tree-equal tree1 tree2) => true (eql tree1 tree2) => false (setq tree1 '('a ('b 'c)) tree2 '('a ('b 'c))) => ('a ('b 'c)) => ((QUOTE A) ((QUOTE B) (QUOTE C))) (tree-equal tree1 tree2 :test 'eq) => true Exceptional Situations:: ........................ The consequences are undefined if both tree-1 and tree-2 are circular. See Also:: .......... *note equal:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated.  File: gcl.info, Node: copy-list, Next: list (Function), Prev: tree-equal, Up: Conses Dictionary 14.2.14 copy-list [Function] ---------------------------- 'copy-list' list => copy Arguments and Values:: ...................... list--a proper list or a dotted list. copy--a list. Description:: ............. Returns a copy of list. If list is a dotted list, the resulting list will also be a dotted list. Only the list structure of list is copied; the elements of the resulting list are the same as the corresponding elements of the given list. Examples:: .......... (setq lst (list 1 (list 2 3))) => (1 (2 3)) (setq slst lst) => (1 (2 3)) (setq clst (copy-list lst)) => (1 (2 3)) (eq slst lst) => true (eq clst lst) => false (equal clst lst) => true (rplaca lst "one") => ("one" (2 3)) slst => ("one" (2 3)) clst => (1 (2 3)) (setf (caadr lst) "two") => "two" lst => ("one" ("two" 3)) slst => ("one" ("two" 3)) clst => (1 ("two" 3)) Exceptional Situations:: ........................ The consequences are undefined if list is a circular list. See Also:: .......... *note copy-alist:: , *note copy-seq:: , *note copy-tree:: Notes:: ....... The copy created is equal to list, but not eq.  File: gcl.info, Node: list (Function), Next: list-length, Prev: copy-list, Up: Conses Dictionary 14.2.15 list, list* [Function] ------------------------------ 'list' &rest objects => list 'list*' &rest objects^+ => result Arguments and Values:: ...................... object--an object. list--a list. result--an object. Description:: ............. list returns a list containing the supplied objects. list* is like list except that the last argument to list becomes the car of the last cons constructed, while the last argument to list* becomes the cdr of the last cons constructed. Hence, any given call to list* always produces one fewer conses than a call to list with the same number of arguments. If the last argument to list* is a list, the effect is to construct a new list which is similar, but which has additional elements added to the front corresponding to the preceding arguments of list*. If list* receives only one object, that object is returned, regardless of whether or not it is a list. Examples:: .......... (list 1) => (1) (list* 1) => 1 (setq a 1) => 1 (list a 2) => (1 2) '(a 2) => (A 2) (list 'a 2) => (A 2) (list* a 2) => (1 . 2) (list) => NIL ;i.e., () (setq a '(1 2)) => (1 2) (eq a (list* a)) => true (list 3 4 'a (car '(b . c)) (+ 6 -2)) => (3 4 A B 4) (list* 'a 'b 'c 'd) == (cons 'a (cons 'b (cons 'c 'd))) => (A B C . D) (list* 'a 'b 'c '(d e f)) => (A B C D E F) See Also:: .......... *note cons:: Notes:: ....... (list* x) == x  File: gcl.info, Node: list-length, Next: listp, Prev: list (Function), Up: Conses Dictionary 14.2.16 list-length [Function] ------------------------------ 'list-length' list => length Arguments and Values:: ...................... list--a proper list or a circular list. length--a non-negative integer, or nil. Description:: ............. Returns the length of list if list is a proper list. Returns nil if list is a circular list. Examples:: .......... (list-length '(a b c d)) => 4 (list-length '(a (b c) d)) => 3 (list-length '()) => 0 (list-length nil) => 0 (defun circular-list (&rest elements) (let ((cycle (copy-list elements))) (nconc cycle cycle))) (list-length (circular-list 'a 'b)) => NIL (list-length (circular-list 'a)) => NIL (list-length (circular-list)) => 0 Exceptional Situations:: ........................ Should signal an error of type type-error if list is not a proper list or a circular list. See Also:: .......... *note length:: Notes:: ....... list-length could be implemented as follows: (defun list-length (x) (do ((n 0 (+ n 2)) ;Counter. (fast x (cddr fast)) ;Fast pointer: leaps by 2. (slow x (cdr slow))) ;Slow pointer: leaps by 1. (nil) ;; If fast pointer hits the end, return the count. (when (endp fast) (return n)) (when (endp (cdr fast)) (return (+ n 1))) ;; If fast pointer eventually equals slow pointer, ;; then we must be stuck in a circular list. ;; (A deeper property is the converse: if we are ;; stuck in a circular list, then eventually the ;; fast pointer will equal the slow pointer. ;; That fact justifies this implementation.) (when (and (eq fast slow) (> n 0)) (return nil))))  File: gcl.info, Node: listp, Next: make-list, Prev: list-length, Up: Conses Dictionary 14.2.17 listp [Function] ------------------------ 'listp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type list; otherwise, returns false. Examples:: .......... (listp nil) => true (listp (cons 1 2)) => true (listp (make-array 6)) => false (listp t) => false See Also:: .......... *note consp:: Notes:: ....... If object is a cons, listp does not check whether object is a proper list; it returns true for any kind of list. (listp object) == (typep object 'list) == (typep object '(or cons null))  File: gcl.info, Node: make-list, Next: push, Prev: listp, Up: Conses Dictionary 14.2.18 make-list [Function] ---------------------------- 'make-list' size &key initial-element => list Arguments and Values:: ...................... size--a non-negative integer. initial-element--an object. The default is nil. list--a list. Description:: ............. Returns a list of length given by size, each of the elements of which is initial-element. Examples:: .......... (make-list 5) => (NIL NIL NIL NIL NIL) (make-list 3 :initial-element 'rah) => (RAH RAH RAH) (make-list 2 :initial-element '(1 2 3)) => ((1 2 3) (1 2 3)) (make-list 0) => NIL ;i.e., () (make-list 0 :initial-element 'new-element) => NIL Exceptional Situations:: ........................ Should signal an error of type type-error if size is not a non-negative integer. See Also:: .......... *note cons:: , *note list (Function)::  File: gcl.info, Node: push, Next: pop, Prev: make-list, Up: Conses Dictionary 14.2.19 push [Macro] -------------------- 'push' item place => new-place-value Arguments and Values:: ...................... item--an object. place--a place, the value of which may be any object. new-place-value--a list (the new value of place). Description:: ............. push prepends item to the list that is stored in place, stores the resulting list in place, and returns the list. For information about the evaluation of subforms of place, see *note Evaluation of Subforms to Places::. Examples:: .......... (setq llst '(nil)) => (NIL) (push 1 (car llst)) => (1) llst => ((1)) (push 1 (car llst)) => (1 1) llst => ((1 1)) (setq x '(a (b c) d)) => (A (B C) D) (push 5 (cadr x)) => (5 B C) x => (A (5 B C) D) Side Effects:: .............. The contents of place are modified. See Also:: .......... *note pop:: , *note pushnew:: , *note Generalized Reference:: Notes:: ....... The effect of (push item place) is equivalent to (setf place (cons item place)) except that the subforms of place are evaluated only once, and item is evaluated before place.  File: gcl.info, Node: pop, Next: first, Prev: push, Up: Conses Dictionary 14.2.20 pop [Macro] ------------------- 'pop' place => element Arguments and Values:: ...................... place--a place, the value of which is a list (possibly, but necessarily, a dotted list or circular list). element--an object (the car of the contents of place). Description:: ............. pop reads the value of place, remembers the car of the list which was retrieved, writes the cdr of the list back into the place, and finally yields the car of the originally retrieved list. For information about the evaluation of subforms of place, see *note Evaluation of Subforms to Places::. Examples:: .......... (setq stack '(a b c)) => (A B C) (pop stack) => A stack => (B C) (setq llst '((1 2 3 4))) => ((1 2 3 4)) (pop (car llst)) => 1 llst => ((2 3 4)) Side Effects:: .............. The contents of place are modified. See Also:: .......... *note push:: , *note pushnew:: , *note Generalized Reference:: Notes:: ....... The effect of (pop place) is roughly equivalent to (prog1 (car place) (setf place (cdr place))) except that the latter would evaluate any subforms of place three times, while pop evaluates them only once.  File: gcl.info, Node: first, Next: nth, Prev: pop, Up: Conses Dictionary 14.2.21 first, second, third, fourth, fifth, -------------------------------------------- sixth, seventh, eighth, ninth, tenth ------------------------------------ [Accessor] 'first' list => object (setf ('first' list) new-object) 'second' list => object (setf ('second' list) new-object) 'third' list => object (setf ('third' list) new-object) 'fourth' list => object (setf ('fourth' list) new-object) 'fifth' list => object (setf ('fifth' list) new-object) 'sixth' list => object (setf ('sixth' list) new-object) 'seventh' list => object (setf ('seventh' list) new-object) 'eighth' list => object (setf ('eighth' list) new-object) 'ninth' list => object (setf ('ninth' list) new-object) 'tenth' list => object (setf ('tenth' list) new-object) Arguments and Values:: ...................... list--a list, which might be a dotted list or a circular list. object, new-object--an object. Description:: ............. The functions first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, and tenth access the first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, and tenth elements of list, respectively. Specifically, (first list) == (car list) (second list) == (car (cdr list)) (third list) == (car (cddr list)) (fourth list) == (car (cdddr list)) (fifth list) == (car (cddddr list)) (sixth list) == (car (cdr (cddddr list))) (seventh list) == (car (cddr (cddddr list))) (eighth list) == (car (cdddr (cddddr list))) (ninth list) == (car (cddddr (cddddr list))) (tenth list) == (car (cdr (cddddr (cddddr list)))) setf can also be used with any of these functions to change an existing component. The same equivalences apply. For example: (setf (fifth list) new-object) == (setf (car (cddddr list)) new-object) Examples:: .......... (setq lst '(1 2 3 (4 5 6) ((V)) vi 7 8 9 10)) => (1 2 3 (4 5 6) ((V)) VI 7 8 9 10) (first lst) => 1 (tenth lst) => 10 (fifth lst) => ((V)) (second (fourth lst)) => 5 (sixth '(1 2 3)) => NIL (setf (fourth lst) "four") => "four" lst => (1 2 3 "four" ((V)) VI 7 8 9 10) See Also:: .......... *note car:: , *note nth:: Notes:: ....... first is functionally equivalent to car, second is functionally equivalent to cadr, third is functionally equivalent to caddr, and fourth is functionally equivalent to cadddr. The ordinal numbering used here is one-origin, as opposed to the zero-origin numbering used by nth: (fifth x) == (nth 4 x)  File: gcl.info, Node: nth, Next: endp, Prev: first, Up: Conses Dictionary 14.2.22 nth [Accessor] ---------------------- 'nth' n list => object (setf (' nth' n list) new-object) Arguments and Values:: ...................... n--a non-negative integer. list--a list, which might be a dotted list or a circular list. object--an object. new-object--an object. Description:: ............. nth locates the nth element of list, where the car of the list is the "zeroth" element. Specifically, (nth n list) == (car (nthcdr n list)) nth may be used to specify a place to setf. Specifically, (setf (nth n list) new-object) == (setf (car (nthcdr n list)) new-object) Examples:: .......... (nth 0 '(foo bar baz)) => FOO (nth 1 '(foo bar baz)) => BAR (nth 3 '(foo bar baz)) => NIL (setq 0-to-3 (list 0 1 2 3)) => (0 1 2 3) (setf (nth 2 0-to-3) "two") => "two" 0-to-3 => (0 1 "two" 3) See Also:: .......... *note elt:: , *note first:: , *note nthcdr::  File: gcl.info, Node: endp, Next: null, Prev: nth, Up: Conses Dictionary 14.2.23 endp [Function] ----------------------- 'endp' list => generalized-boolean Arguments and Values:: ...................... list--a list, which might be a dotted list or a circular list. generalized-boolean--a generalized boolean. Description:: ............. Returns true if list is the empty list. Returns false if list is a cons. Examples:: .......... (endp nil) => true (endp '(1 2)) => false (endp (cddr '(1 2))) => true Exceptional Situations:: ........................ Should signal an error of type type-error if list is not a list. Notes:: ....... The purpose of endp is to test for the end of proper list. Since endp does not descend into a cons, it is well-defined to pass it a dotted list. However, if shorter "lists" are iteratively produced by calling cdr on such a dotted list and those "lists" are tested with endp, a situation that has undefined consequences will eventually result when the non-nil atom (which is not in fact a list) finally becomes the argument to endp. Since this is the usual way in which endp is used, it is conservative programming style and consistent with the intent of endp to treat endp as simply a function on proper lists which happens not to enforce an argument type of proper list except when the argument is atomic.  File: gcl.info, Node: null, Next: nconc, Prev: endp, Up: Conses Dictionary 14.2.24 null [Function] ----------------------- 'null' object => boolean Arguments and Values:: ...................... object--an object. boolean--a boolean. Description:: ............. Returns t if object is the empty list; otherwise, returns nil. Examples:: .......... (null '()) => T (null nil) => T (null t) => NIL (null 1) => NIL See Also:: .......... *note not:: Notes:: ....... null is intended to be used to test for the empty list whereas not is intended to be used to invert a boolean (or generalized boolean). Operationally, null and not compute the same result; which to use is a matter of style. (null object) == (typep object 'null) == (eq object '())  File: gcl.info, Node: nconc, Next: append, Prev: null, Up: Conses Dictionary 14.2.25 nconc [Function] ------------------------ 'nconc' &rest lists => concatenated-list Arguments and Values:: ...................... list--each but the last must be a list (which might be a dotted list but must not be a circular list); the last list may be any object. concatenated-list--a list. Description:: ............. Returns a list that is the concatenation of lists. If no lists are supplied, (nconc) returns nil. nconc is defined using the following recursive relationship: (nconc) => () (nconc nil . lists) == (nconc . lists) (nconc list) => list (nconc list-1 list-2) == (progn (rplacd (last list-1) list-2) list-1) (nconc list-1 list-2 . lists) == (nconc (nconc list-1 list-2) . lists) Examples:: .......... (nconc) => NIL (setq x '(a b c)) => (A B C) (setq y '(d e f)) => (D E F) (nconc x y) => (A B C D E F) x => (A B C D E F) Note, in the example, that the value of x is now different, since its last cons has been rplacd'd to the value of y. If (nconc x y) were evaluated again, it would yield a piece of a circular list, whose printed representation would be (A B C D E F D E F D E F ...), repeating forever; if the *print-circle* switch were non-nil, it would be printed as (A B C . #1=(D E F . #1#)). (setq foo (list 'a 'b 'c 'd 'e) bar (list 'f 'g 'h 'i 'j) baz (list 'k 'l 'm)) => (K L M) (setq foo (nconc foo bar baz)) => (A B C D E F G H I J K L M) foo => (A B C D E F G H I J K L M) bar => (F G H I J K L M) baz => (K L M) (setq foo (list 'a 'b 'c 'd 'e) bar (list 'f 'g 'h 'i 'j) baz (list 'k 'l 'm)) => (K L M) (setq foo (nconc nil foo bar nil baz)) => (A B C D E F G H I J K L M) foo => (A B C D E F G H I J K L M) bar => (F G H I J K L M) baz => (K L M) Side Effects:: .............. The lists are modified rather than copied. See Also:: .......... *note append:: , *note concatenate::  File: gcl.info, Node: append, Next: revappend, Prev: nconc, Up: Conses Dictionary 14.2.26 append [Function] ------------------------- 'append' &rest lists => result Arguments and Values:: ...................... list--each must be a proper list except the last, which may be any object. result--an object. This will be a list unless the last list was not a list and all preceding lists were null. Description:: ............. append returns a new list that is the concatenation of the copies. lists are left unchanged; the list structure of each of lists except the last is copied. The last argument is not copied; it becomes the cdr of the final dotted pair of the concatenation of the preceding lists, or is returned directly if there are no preceding non-empty lists. Examples:: .......... (append '(a b c) '(d e f) '() '(g)) => (A B C D E F G) (append '(a b c) 'd) => (A B C . D) (setq lst '(a b c)) => (A B C) (append lst '(d)) => (A B C D) lst => (A B C) (append) => NIL (append 'a) => A See Also:: .......... *note nconc:: , *note concatenate::  File: gcl.info, Node: revappend, Next: butlast, Prev: append, Up: Conses Dictionary 14.2.27 revappend, nreconc [Function] ------------------------------------- 'revappend' list tail => result-list 'nreconc' list tail => result-list Arguments and Values:: ...................... list--a proper list. tail--an object. result-list--an object. Description:: ............. revappend constructs a copy_2 of list, but with the elements in reverse order. It then appends (as if by nconc) the tail to that reversed list and returns the result. nreconc reverses the order of elements in list (as if by nreverse). It then appends (as if by nconc) the tail to that reversed list and returns the result. The resulting list shares list structure with tail. Examples:: .......... (let ((list-1 (list 1 2 3)) (list-2 (list 'a 'b 'c))) (print (revappend list-1 list-2)) (print (equal list-1 '(1 2 3))) (print (equal list-2 '(a b c)))) |> (3 2 1 A B C) |> T |> T => T (revappend '(1 2 3) '()) => (3 2 1) (revappend '(1 2 3) '(a . b)) => (3 2 1 A . B) (revappend '() '(a b c)) => (A B C) (revappend '(1 2 3) 'a) => (3 2 1 . A) (revappend '() 'a) => A ;degenerate case (let ((list-1 '(1 2 3)) (list-2 '(a b c))) (print (nreconc list-1 list-2)) (print (equal list-1 '(1 2 3))) (print (equal list-2 '(a b c)))) |> (3 2 1 A B C) |> NIL |> T => T Side Effects:: .............. revappend does not modify either of its arguments. nreconc is permitted to modify list but not tail. Although it might be implemented differently, nreconc is constrained to have side-effect behavior equivalent to: (nconc (nreverse list) tail) See Also:: .......... *note reverse:: , nreverse, *note nconc:: Notes:: ....... The following functional equivalences are true, although good implementations will typically use a faster algorithm for achieving the same effect: (revappend list tail) == (nconc (reverse list) tail) (nreconc list tail) == (nconc (nreverse list) tail)  File: gcl.info, Node: butlast, Next: last, Prev: revappend, Up: Conses Dictionary 14.2.28 butlast, nbutlast [Function] ------------------------------------ 'butlast' list &optional n => result-list 'nbutlast' list &optional n => result-list Arguments and Values:: ...................... list--a list, which might be a dotted list but must not be a circular list. n--a non-negative integer. result-list--a list. Description:: ............. butlast returns a copy of list from which the last n conses have been omitted. If n is not supplied, its value is 1. If there are fewer than n conses in list, nil is returned and, in the case of nbutlast, list is not modified. nbutlast is like butlast, but nbutlast may modify list. It changes the cdr of the cons n+1 from the end of the list to nil. Examples:: .......... (setq lst '(1 2 3 4 5 6 7 8 9)) => (1 2 3 4 5 6 7 8 9) (butlast lst) => (1 2 3 4 5 6 7 8) (butlast lst 5) => (1 2 3 4) (butlast lst (+ 5 5)) => NIL lst => (1 2 3 4 5 6 7 8 9) (nbutlast lst 3) => (1 2 3 4 5 6) lst => (1 2 3 4 5 6) (nbutlast lst 99) => NIL lst => (1 2 3 4 5 6) (butlast '(a b c d)) => (A B C) (butlast '((a b) (c d))) => ((A B)) (butlast '(a)) => NIL (butlast nil) => NIL (setq foo (list 'a 'b 'c 'd)) => (A B C D) (nbutlast foo) => (A B C) foo => (A B C) (nbutlast (list 'a)) => NIL (nbutlast '()) => NIL Exceptional Situations:: ........................ Should signal an error of type type-error if list is not a proper list or a dotted list. Should signal an error of type type-error if n is not a non-negative integer. Notes:: ....... (butlast list n) == (ldiff list (last list n))  File: gcl.info, Node: last, Next: ldiff, Prev: butlast, Up: Conses Dictionary 14.2.29 last [Function] ----------------------- 'last' list &optional n => tail Arguments and Values:: ...................... list--a list, which might be a dotted list but must not be a circular list. n--a non-negative integer. The default is 1. tail--an object. Description:: ............. last returns the last n conses (not the last n elements) of list). If list is (), last returns (). If n is zero, the atom that terminates list is returned. If n is greater than or equal to the number of cons cells in list, the result is list. Examples:: .......... (last nil) => NIL (last '(1 2 3)) => (3) (last '(1 2 . 3)) => (2 . 3) (setq x (list 'a 'b 'c 'd)) => (A B C D) (last x) => (D) (rplacd (last x) (list 'e 'f)) x => (A B C D E F) (last x) => (F) (last '(a b c)) => (C) (last '(a b c) 0) => () (last '(a b c) 1) => (C) (last '(a b c) 2) => (B C) (last '(a b c) 3) => (A B C) (last '(a b c) 4) => (A B C) (last '(a . b) 0) => B (last '(a . b) 1) => (A . B) (last '(a . b) 2) => (A . B) Exceptional Situations:: ........................ The consequences are undefined if list is a circular list. Should signal an error of type type-error if n is not a non-negative integer. See Also:: .......... *note butlast:: , *note nth:: Notes:: ....... The following code could be used to define last. (defun last (list &optional (n 1)) (check-type n (integer 0)) (do ((l list (cdr l)) (r list) (i 0 (+ i 1))) ((atom l) r) (if (>= i n) (pop r))))  File: gcl.info, Node: ldiff, Next: nthcdr, Prev: last, Up: Conses Dictionary 14.2.30 ldiff, tailp [Function] ------------------------------- 'ldiff' list object => result-list 'tailp' object list => generalized-boolean Arguments and Values:: ...................... list--a list, which might be a dotted list. object--an object. result-list--a list. generalized-boolean--a generalized boolean. Description:: ............. If object is the same as some tail of list, tailp returns true; otherwise, it returns false. If object is the same as some tail of list, ldiff returns a fresh list of the elements of list that precede object in the list structure of list; otherwise, it returns a copy_2 of list. Examples:: .......... (let ((lists '#((a b c) (a b c . d)))) (dotimes (i (length lists)) () (let ((list (aref lists i))) (format t "~2&list=~S ~21T(tailp object list)~ ~44T(ldiff list object)~ (let ((objects (vector list (cddr list) (copy-list (cddr list)) '(f g h) '() 'd 'x))) (dotimes (j (length objects)) () (let ((object (aref objects j))) (format t "~& object=~S ~21T~S ~44T~S" object (tailp object list) (ldiff list object)))))))) |> |> list=(A B C) (tailp object list) (ldiff list object) |> object=(A B C) T NIL |> object=(C) T (A B) |> object=(C) NIL (A B C) |> object=(F G H) NIL (A B C) |> object=NIL T (A B C) |> object=D NIL (A B C) |> object=X NIL (A B C) |> |> list=(A B C . D) (tailp object list) (ldiff list object) |> object=(A B C . D) T NIL |> object=(C . D) T (A B) |> object=(C . D) NIL (A B C . D) |> object=(F G H) NIL (A B C . D) |> object=NIL NIL (A B C . D) |> object=D T (A B C) |> object=X NIL (A B C . D) => NIL Side Effects:: .............. Neither ldiff nor tailp modifies either of its arguments. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list is not a proper list or a dotted list. See Also:: .......... *note set-difference:: Notes:: ....... If the list is a circular list, tailp will reliably yield a value only if the given object is in fact a tail of list. Otherwise, the consequences are unspecified: a given implementation which detects the circularity must return false, but since an implementation is not obliged to detect such a situation, tailp might just loop indefinitely without returning in that case. tailp could be defined as follows: (defun tailp (object list) (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) (return t)))) and ldiff could be defined by: (defun ldiff (list object) (do ((list list (cdr list)) (r '() (cons (car list) r))) ((atom list) (if (eql list object) (nreverse r) (nreconc r list))) (when (eql object list) (return (nreverse r)))))  File: gcl.info, Node: nthcdr, Next: rest, Prev: ldiff, Up: Conses Dictionary 14.2.31 nthcdr [Function] ------------------------- 'nthcdr' n list => tail Arguments and Values:: ...................... n--a non-negative integer. list--a list, which might be a dotted list or a circular list. tail--an object. Description:: ............. Returns the tail of list that would be obtained by calling cdr n times in succession. Examples:: .......... (nthcdr 0 '()) => NIL (nthcdr 3 '()) => NIL (nthcdr 0 '(a b c)) => (A B C) (nthcdr 2 '(a b c)) => (C) (nthcdr 4 '(a b c)) => () (nthcdr 1 '(0 . 1)) => 1 (locally (declare (optimize (safety 3))) (nthcdr 3 '(0 . 1))) Error: Attempted to take CDR of 1. Exceptional Situations:: ........................ Should signal an error of type type-error if n is not a non-negative integer. For n being an integer greater than 1, the error checking done by (nthcdr n list) is the same as for (nthcdr (- n 1) (cdr list)); see the function cdr. See Also:: .......... cdr, *note nth:: , *note rest::  File: gcl.info, Node: rest, Next: member (Function), Prev: nthcdr, Up: Conses Dictionary 14.2.32 rest [Accessor] ----------------------- 'rest' list => tail (setf (' rest' list) new-tail) Arguments and Values:: ...................... list--a list, which might be a dotted list or a circular list. tail--an object. Description:: ............. rest performs the same operation as cdr, but mnemonically complements first. Specifically, (rest list) == (cdr list) (setf (rest list) new-tail) == (setf (cdr list) new-tail) Examples:: .......... (rest '(1 2)) => (2) (rest '(1 . 2)) => 2 (rest '(1)) => NIL (setq *cons* '(1 . 2)) => (1 . 2) (setf (rest *cons*) "two") => "two" *cons* => (1 . "two") See Also:: .......... cdr, *note nthcdr:: Notes:: ....... rest is often preferred stylistically over cdr when the argument is to being subjectively viewed as a list rather than as a cons.  File: gcl.info, Node: member (Function), Next: mapc, Prev: rest, Up: Conses Dictionary 14.2.33 member, member-if, member-if-not [Function] --------------------------------------------------- 'member' item list &key key test test-not => tail 'member-if' predicate list &key key => tail 'member-if-not' predicate list &key key => tail Arguments and Values:: ...................... item--an object. list--a proper list. predicate--a designator for a function of one argument that returns a generalized boolean. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. tail--a list. Description:: ............. member, member-if, and member-if-not each search list for item or for a top-level element that satisfies the test. The argument to the predicate function is an element of list. If some element satisfies the test, the tail of list beginning with this element is returned; otherwise nil is returned. list is searched on the top level only. Examples:: .......... (member 2 '(1 2 3)) => (2 3) (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr) => ((3 . 4)) (member 'e '(a b c d)) => NIL (member-if #'listp '(a b nil c d)) => (NIL C D) (member-if #'numberp '(a #\Space 5/3 foo)) => (5/3 FOO) (member-if-not #'zerop '(3 6 9 11 . 12) :key #'(lambda (x) (mod x 3))) => (11 . 12) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list is not a proper list. See Also:: .......... *note find:: , *note position:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. The function member-if-not is deprecated. In the following (member 'a '(g (a y) c a d e a f)) => (A D E A F) the value returned by member is identical to the portion of the list beginning with a. Thus rplaca on the result of member can be used to alter the part of the list where a was found (assuming a check has been made that member did not return nil).  File: gcl.info, Node: mapc, Next: acons, Prev: member (Function), Up: Conses Dictionary 14.2.34 mapc, mapcar, mapcan, mapl, maplist, mapcon [Function] -------------------------------------------------------------- 'mapc' function &rest lists^+ => list-1 'mapcar' function &rest lists^+ => result-list 'mapcan' function &rest lists^+ => concatenated-results 'mapl' function &rest lists^+ => list-1 'maplist' function &rest lists^+ => result-list 'mapcon' function &rest lists^+ => concatenated-results Arguments and Values:: ...................... function--a designator for a function that must take as many arguments as there are lists. list--a proper list. list-1--the first list (which must be a proper list). result-list--a list. concatenated-results--a list. Description:: ............. The mapping operation involves applying function to successive sets of arguments in which one argument is obtained from each sequence. Except for mapc and mapl, the result contains the results returned by function. In the cases of mapc and mapl, the resulting sequence is list. function is called first on all the elements with index 0, then on all those with index 1, and so on. result-type specifies the type of the resulting sequence. If function is a symbol, it is coerced to a function as if by symbol-function. mapcar operates on successive elements of the lists. function is applied to the first element of each list, then to the second element of each list, and so on. The iteration terminates when the shortest list runs out, and excess elements in other lists are ignored. The value returned by mapcar is a list of the results of successive calls to function. mapc is like mapcar except that the results of applying function are not accumulated. The list argument is returned. maplist is like mapcar except that function is applied to successive sublists of the lists. function is first applied to the lists themselves, and then to the cdr of each list, and then to the cdr of the cdr of each list, and so on. mapl is like maplist except that the results of applying function are not accumulated; list-1 is returned. mapcan and mapcon are like mapcar and maplist respectively, except that the results of applying function are combined into a list by the use of nconc rather than list. That is, (mapcon f x1 ... xn) == (apply #'nconc (maplist f x1 ... xn)) and similarly for the relationship between mapcan and mapcar. Examples:: .......... (mapcar #'car '((1 a) (2 b) (3 c))) => (1 2 3) (mapcar #'abs '(3 -4 2 -5 -6)) => (3 4 2 5 6) (mapcar #'cons '(a b c) '(1 2 3)) => ((A . 1) (B . 2) (C . 3)) (maplist #'append '(1 2 3 4) '(1 2) '(1 2 3)) => ((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3)) (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) => ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) (maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) => (0 0 1 0 1 1 1) ;An entry is 1 if the corresponding element of the input ; list was the last instance of that element in the input list. (setq dummy nil) => NIL (mapc #'(lambda (&rest x) (setq dummy (append dummy x))) '(1 2 3 4) '(a b c d e) '(x y z)) => (1 2 3 4) dummy => (1 A X 2 B Y 3 C Z) (setq dummy nil) => NIL (mapl #'(lambda (x) (push x dummy)) '(1 2 3 4)) => (1 2 3 4) dummy => ((4) (3 4) (2 3 4) (1 2 3 4)) (mapcan #'(lambda (x y) (if (null x) nil (list x y))) '(nil nil nil d e) '(1 2 3 4 5 6)) => (D 4 E 5) (mapcan #'(lambda (x) (and (numberp x) (list x))) '(a 1 b c 3 4 d 5)) => (1 3 4 5) In this case the function serves as a filter; this is a standard Lisp idiom using mapcan. (mapcon #'list '(1 2 3 4)) => ((1 2 3 4) (2 3 4) (3 4) (4)) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if any list is not a proper list. See Also:: .......... *note dolist:: , *note map:: , *note Traversal Rules and Side Effects::  File: gcl.info, Node: acons, Next: assoc, Prev: mapc, Up: Conses Dictionary 14.2.35 acons [Function] ------------------------ 'acons' key datum alist => new-alist Arguments and Values:: ...................... key--an object. datum--an object. alist--an association list. new-alist--an association list. Description:: ............. Creates a fresh cons, the cdr of which is alist and the car of which is another fresh cons, the car of which is key and the cdr of which is datum. Examples:: .......... (setq alist '()) => NIL (acons 1 "one" alist) => ((1 . "one")) alist => NIL (setq alist (acons 1 "one" (acons 2 "two" alist))) => ((1 . "one") (2 . "two")) (assoc 1 alist) => (1 . "one") (setq alist (acons 1 "uno" alist)) => ((1 . "uno") (1 . "one") (2 . "two")) (assoc 1 alist) => (1 . "uno") See Also:: .......... *note assoc:: , *note pairlis:: Notes:: ....... (acons key datum alist) == (cons (cons key datum) alist)  File: gcl.info, Node: assoc, Next: copy-alist, Prev: acons, Up: Conses Dictionary 14.2.36 assoc, assoc-if, assoc-if-not [Function] ------------------------------------------------ 'assoc' item alist &key key test test-not => entry 'assoc-if' predicate alist &key key => entry 'assoc-if-not' predicate alist &key key => entry Arguments and Values:: ...................... item--an object. alist--an association list. predicate--a designator for a function of one argument that returns a generalized boolean. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. entry--a cons that is an element of alist, or nil. Description:: ............. assoc, assoc-if, and assoc-if-not return the first cons in alist whose car satisfies the test, or nil if no such cons is found. For assoc, assoc-if, and assoc-if-not, if nil appears in alist in place of a pair, it is ignored. Examples:: .......... (setq values '((x . 100) (y . 200) (z . 50))) => ((X . 100) (Y . 200) (Z . 50)) (assoc 'y values) => (Y . 200) (rplacd (assoc 'y values) 201) => (Y . 201) (assoc 'y values) => (Y . 201) (setq alist '((1 . "one")(2 . "two")(3 . "three"))) => ((1 . "one") (2 . "two") (3 . "three")) (assoc 2 alist) => (2 . "two") (assoc-if #'evenp alist) => (2 . "two") (assoc-if-not #'(lambda(x) (< x 3)) alist) => (3 . "three") (setq alist '(("one" . 1)("two" . 2))) => (("one" . 1) ("two" . 2)) (assoc "one" alist) => NIL (assoc "one" alist :test #'equalp) => ("one" . 1) (assoc "two" alist :key #'(lambda(x) (char x 2))) => NIL (assoc #\o alist :key #'(lambda(x) (char x 2))) => ("two" . 2) (assoc 'r '((a . b) (c . d) (r . x) (s . y) (r . z))) => (R . X) (assoc 'goo '((foo . bar) (zoo . goo))) => NIL (assoc '2 '((1 a b c) (2 b c d) (-7 x y z))) => (2 B C D) (setq alist '(("one" . 1) ("2" . 2) ("three" . 3))) => (("one" . 1) ("2" . 2) ("three" . 3)) (assoc-if-not #'alpha-char-p alist :key #'(lambda (x) (char x 0))) => ("2" . 2) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if alist is not an association list. See Also:: .......... *note rassoc:: , *note find:: , *note member (Function):: , *note position:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. The function assoc-if-not is deprecated. It is possible to rplacd the result of assoc, provided that it is not nil, in order to "update" alist. The two expressions (assoc item list :test fn) and (find item list :test fn :key #'car) are equivalent in meaning with one exception: if nil appears in alist in place of a pair, and item is nil, find will compute the car of the nil in alist, find that it is equal to item, and return nil, whereas assoc will ignore the nil in alist and continue to search for an actual cons whose car is nil.  File: gcl.info, Node: copy-alist, Next: pairlis, Prev: assoc, Up: Conses Dictionary 14.2.37 copy-alist [Function] ----------------------------- 'copy-alist' alist => new-alist Arguments and Values:: ...................... alist--an association list. new-alist--an association list. Description:: ............. copy-alist returns a copy of alist. The list structure of alist is copied, and the elements of alist which are conses are also copied (as conses only). Any other objects which are referred to, whether directly or indirectly, by the alist continue to be shared. Examples:: .......... (defparameter *alist* (acons 1 "one" (acons 2 "two" '()))) *alist* => ((1 . "one") (2 . "two")) (defparameter *list-copy* (copy-list *alist*)) *list-copy* => ((1 . "one") (2 . "two")) (defparameter *alist-copy* (copy-alist *alist*)) *alist-copy* => ((1 . "one") (2 . "two")) (setf (cdr (assoc 2 *alist-copy*)) "deux") => "deux" *alist-copy* => ((1 . "one") (2 . "deux")) *alist* => ((1 . "one") (2 . "two")) (setf (cdr (assoc 1 *list-copy*)) "uno") => "uno" *list-copy* => ((1 . "uno") (2 . "two")) *alist* => ((1 . "uno") (2 . "two")) See Also:: .......... *note copy-list::  File: gcl.info, Node: pairlis, Next: rassoc, Prev: copy-alist, Up: Conses Dictionary 14.2.38 pairlis [Function] -------------------------- 'pairlis' keys data &optional alist => new-alist Arguments and Values:: ...................... keys--a proper list. data--a proper list. alist--an association list. The default is the empty list. new-alist--an association list. Description:: ............. Returns an association list that associates elements of keys to corresponding elements of data. The consequences are undefined if keys and data are not of the same length. If alist is supplied, pairlis returns a modified alist with the new pairs prepended to it. The new pairs may appear in the resulting association list in either forward or backward order. The result of (pairlis '(one two) '(1 2) '((three . 3) (four . 19))) might be ((one . 1) (two . 2) (three . 3) (four . 19)) or ((two . 2) (one . 1) (three . 3) (four . 19)) Examples:: .......... (setq keys '(1 2 3) data '("one" "two" "three") alist '((4 . "four"))) => ((4 . "four")) (pairlis keys data) => ((3 . "three") (2 . "two") (1 . "one")) (pairlis keys data alist) => ((3 . "three") (2 . "two") (1 . "one") (4 . "four")) alist => ((4 . "four")) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if keys and data are not proper lists. See Also:: .......... *note acons::  File: gcl.info, Node: rassoc, Next: get-properties, Prev: pairlis, Up: Conses Dictionary 14.2.39 rassoc, rassoc-if, rassoc-if-not [Function] --------------------------------------------------- 'rassoc' item alist &key key test test-not => entry 'rassoc-if' predicate alist &key key => entry 'rassoc-if-not' predicate alist &key key => entry Arguments and Values:: ...................... item--an object. alist--an association list. predicate--a designator for a function of one argument that returns a generalized boolean. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. entry--a cons that is an element of the alist, or nil. Description:: ............. rassoc, rassoc-if, and rassoc-if-not return the first cons whose cdr satisfies the test. If no such cons is found, nil is returned. If nil appears in alist in place of a pair, it is ignored. Examples:: .......... (setq alist '((1 . "one") (2 . "two") (3 . 3))) => ((1 . "one") (2 . "two") (3 . 3)) (rassoc 3 alist) => (3 . 3) (rassoc "two" alist) => NIL (rassoc "two" alist :test 'equal) => (2 . "two") (rassoc 1 alist :key #'(lambda (x) (if (numberp x) (/ x 3)))) => (3 . 3) (rassoc 'a '((a . b) (b . c) (c . a) (z . a))) => (C . A) (rassoc-if #'stringp alist) => (1 . "one") (rassoc-if-not #'vectorp alist) => (3 . 3) See Also:: .......... *note assoc:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. The function rassoc-if-not is deprecated. It is possible to rplaca the result of rassoc, provided that it is not nil, in order to "update" alist. The expressions (rassoc item list :test fn) and (find item list :test fn :key #'cdr) are equivalent in meaning, except when the item is nil and nil appears in place of a pair in the alist. See the function assoc.  File: gcl.info, Node: get-properties, Next: getf, Prev: rassoc, Up: Conses Dictionary 14.2.40 get-properties [Function] --------------------------------- 'get-properties' plist indicator-list => indicator, value, tail Arguments and Values:: ...................... plist--a property list. indicator-list--a proper list (of indicators). indicator--an object that is an element of indicator-list. value--an object. tail--a list. Description:: ............. get-properties is used to look up any of several property list entries all at once. It searches the plist for the first entry whose indicator is identical to one of the objects in indicator-list. If such an entry is found, the indicator and value returned are the property indicator and its associated property value, and the tail returned is the tail of the plist that begins with the found entry (i.e., whose car is the indicator). If no such entry is found, the indicator, value, and tail are all nil. Examples:: .......... (setq x '()) => NIL (setq *indicator-list* '(prop1 prop2)) => (PROP1 PROP2) (getf x 'prop1) => NIL (setf (getf x 'prop1) 'val1) => VAL1 (eq (getf x 'prop1) 'val1) => true (get-properties x *indicator-list*) => PROP1, VAL1, (PROP1 VAL1) x => (PROP1 VAL1) See Also:: .......... *note get:: , *note getf::  File: gcl.info, Node: getf, Next: remf, Prev: get-properties, Up: Conses Dictionary 14.2.41 getf [Accessor] ----------------------- 'getf' plist indicator &optional default => value (setf (' getf' place indicator &optional default) new-value) Arguments and Values:: ...................... plist--a property list. place--a place, the value of which is a property list. indicator--an object. default--an object. The default is nil. value--an object. new-value--an object. Description:: ............. getf finds a property on the plist whose property indicator is identical to indicator, and returns its corresponding property value. If there are multiple properties_1 with that property indicator, getf uses the first such property. If there is no property with that property indicator, default is returned. setf of getf may be used to associate a new object with an existing indicator in the property list held by place, or to create a new assocation if none exists. If there are multiple properties_1 with that property indicator, setf of getf associates the new-value with the first such property. When a getf form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored. setf of getf is permitted to either write the value of place itself, or modify of any part, car or cdr, of the list structure held by place. Examples:: .......... (setq x '()) => NIL (getf x 'prop1) => NIL (getf x 'prop1 7) => 7 (getf x 'prop1) => NIL (setf (getf x 'prop1) 'val1) => VAL1 (eq (getf x 'prop1) 'val1) => true (getf x 'prop1) => VAL1 (getf x 'prop1 7) => VAL1 x => (PROP1 VAL1) ;; Examples of implementation variation permitted. (setq foo (list 'a 'b 'c 'd 'e 'f)) => (A B C D E F) (setq bar (cddr foo)) => (C D E F) (remf foo 'c) => true foo => (A B E F) bar => (C D E F) OR=> (C) OR=> (NIL) OR=> (C NIL) OR=> (C D) See Also:: .......... *note get:: , *note get-properties:: , *note setf:: , *note Function Call Forms as Places:: Notes:: ....... There is no way (using getf) to distinguish an absent property from one whose value is default; but see get-properties. Note that while supplying a default argument to getf in a setf situation is sometimes not very interesting, it is still important because some macros, such as push and incf, require a place argument which data is both read from and written to. In such a context, if a default argument is to be supplied for the read situation, it must be syntactically valid for the write situation as well. For example, (let ((plist '())) (incf (getf plist 'count 0)) plist) => (COUNT 1)  File: gcl.info, Node: remf, Next: intersection, Prev: getf, Up: Conses Dictionary 14.2.42 remf [Macro] -------------------- 'remf' place indicator => generalized-boolean Arguments and Values:: ...................... place--a place. indicator--an object. generalized-boolean--a generalized boolean. Description:: ............. remf removes from the property list stored in place a property_1 with a property indicator identical to indicator. If there are multiple properties_1 with the identical key, remf only removes the first such property. remf returns false if no such property was found, or true if a property was found. The property indicator and the corresponding property value are removed in an undefined order by destructively splicing the property list. remf is permitted to either setf place or to setf any part, car or cdr, of the list structure held by that place. For information about the evaluation of subforms of place, see *note Evaluation of Subforms to Places::. Examples:: .......... (setq x (cons () ())) => (NIL) (setf (getf (car x) 'prop1) 'val1) => VAL1 (remf (car x) 'prop1) => true (remf (car x) 'prop1) => false Side Effects:: .............. The property list stored in place is modified. See Also:: .......... *note remprop:: , *note getf::  File: gcl.info, Node: intersection, Next: adjoin, Prev: remf, Up: Conses Dictionary 14.2.43 intersection, nintersection [Function] ---------------------------------------------- 'intersection' list-1 list-2 &key key test test-not => result-list 'nintersection' list-1 list-2 &key key test test-not => result-list Arguments and Values:: ...................... list-1--a proper list. list-2--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. result-list--a list. Description:: ............. intersection and nintersection return a list that contains every element that occurs in both list-1 and list-2. nintersection is the destructive version of intersection. It performs the same operation, but may destroy list-1 using its cells to construct the result. list-2 is not destroyed. The intersection operation is described as follows. For all possible ordered pairs consisting of one element from list-1 and one element from list-2, :test or :test-not are used to determine whether they satisfy the test. The first argument to the :test or :test-not function is an element of list-1; the second argument is an element of list-2. If :test or :test-not is not supplied, eql is used. It is an error if :test and :test-not are supplied in the same function call. If :key is supplied (and not nil), it is used to extract the part to be tested from the list element. The argument to the :key function is an element of either list-1 or list-2; the :key function typically returns part of the supplied element. If :key is not supplied or nil, the list-1 and list-2 elements are used. For every pair that satifies the test, exactly one of the two elements of the pair will be put in the result. No element from either list appears in the result that does not satisfy the test for an element from the other list. If one of the lists contains duplicate elements, there may be duplication in the result. There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result list may share cells with, or be eq to, either list-1 or list-2 if appropriate. Examples:: .......... (setq list1 (list 1 1 2 3 4 a b c "A" "B" "C" "d") list2 (list 1 4 5 b c d "a" "B" "c" "D")) => (1 4 5 B C D "a" "B" "c" "D") (intersection list1 list2) => (C B 4 1 1) (intersection list1 list2 :test 'equal) => ("B" C B 4 1 1) (intersection list1 list2 :test #'equalp) => ("d" "C" "B" "A" C B 4 1 1) (nintersection list1 list2) => (1 1 4 B C) list1 => implementation-dependent ;e.g., (1 1 4 B C) list2 => implementation-dependent ;e.g., (1 4 5 B C D "a" "B" "c" "D") (setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5)))) => ((1 . 2) (2 . 3) (3 . 4) (4 . 5)) (setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8)))) => ((1 . 3) (2 . 4) (3 . 6) (4 . 8)) (nintersection list1 list2 :key #'cdr) => ((2 . 3) (3 . 4)) list1 => implementation-dependent ;e.g., ((1 . 2) (2 . 3) (3 . 4)) list2 => implementation-dependent ;e.g., ((1 . 3) (2 . 4) (3 . 6) (4 . 8)) Side Effects:: .............. nintersection can modify list-1, but not list-2. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists. See Also:: .......... *note union:: , *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. Since the nintersection side effect is not required, it should not be used in for-effect-only positions in portable code.  File: gcl.info, Node: adjoin, Next: pushnew, Prev: intersection, Up: Conses Dictionary 14.2.44 adjoin [Function] ------------------------- 'adjoin' item list &key key test test-not => new-list Arguments and Values:: ...................... item--an object. list--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. new-list--a list. Description:: ............. Tests whether item is the same as an existing element of list. If the item is not an existing element, adjoin adds it to list (as if by cons) and returns the resulting list; otherwise, nothing is added and the original list is returned. The test, test-not, and key affect how it is determined whether item is the same as an element of list. For details, see *note Satisfying a Two-Argument Test::.\ifvmode\else\endgraf \ifdim \prevdepth>-1000pt \NIS\parskip \normalparskip\relax\fi Examples:: .......... (setq slist '()) => NIL (adjoin 'a slist) => (A) slist => NIL (setq slist (adjoin '(test-item 1) slist)) => ((TEST-ITEM 1)) (adjoin '(test-item 1) slist) => ((TEST-ITEM 1) (TEST-ITEM 1)) (adjoin '(test-item 1) slist :test 'equal) => ((TEST-ITEM 1)) (adjoin '(new-test-item 1) slist :key #'cadr) => ((TEST-ITEM 1)) (adjoin '(new-test-item 1) slist) => ((NEW-TEST-ITEM 1) (TEST-ITEM 1)) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list is not a proper list. See Also:: .......... *note pushnew:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. (adjoin item list :key fn) == (if (member (fn item) list :key fn) list (cons item list))  File: gcl.info, Node: pushnew, Next: set-difference, Prev: adjoin, Up: Conses Dictionary 14.2.45 pushnew [Macro] ----------------------- 'pushnew' item place &key key test test-not => new-place-value Arguments and Values:: ...................... item--an object. place--a place, the value of which is a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. new-place-value--a list (the new value of place). Description:: ............. pushnew tests whether item is the same as any existing element of the list stored in place. If item is not, it is prepended to the list, and the new list is stored in place. pushnew returns the new list that is stored in place. Whether or not item is already a member of the list that is in place is determined by comparisons using :test or :test-not. The first argument to the :test or :test-not function is item; the second argument is an element of the list in place as returned by the :key function (if supplied). If :key is supplied, it is used to extract the part to be tested from both item and the list element, as for adjoin. The argument to the :key function is an element of the list stored in place. The :key function typically returns part part of the element of the list. If :key is not supplied or nil, the list element is used. For information about the evaluation of subforms of place, see *note Evaluation of Subforms to Places::. It is implementation-dependent whether or not pushnew actually executes the storing form for its place in the situation where the item is already a member of the list held by place. Examples:: .......... (setq x '(a (b c) d)) => (A (B C) D) (pushnew 5 (cadr x)) => (5 B C) x => (A (5 B C) D) (pushnew 'b (cadr x)) => (5 B C) x => (A (5 B C) D) (setq lst '((1) (1 2) (1 2 3))) => ((1) (1 2) (1 2 3)) (pushnew '(2) lst) => ((2) (1) (1 2) (1 2 3)) (pushnew '(1) lst) => ((1) (2) (1) (1 2) (1 2 3)) (pushnew '(1) lst :test 'equal) => ((1) (2) (1) (1 2) (1 2 3)) (pushnew '(1) lst :key #'car) => ((1) (2) (1) (1 2) (1 2 3)) Side Effects:: .............. The contents of place may be modified. See Also:: .......... *note push:: , *note adjoin:: , *note Generalized Reference:: Notes:: ....... The effect of (pushnew item place :test p) is roughly equivalent to (setf place (adjoin item place :test p)) except that the subforms of place are evaluated only once, and item is evaluated before place.  File: gcl.info, Node: set-difference, Next: set-exclusive-or, Prev: pushnew, Up: Conses Dictionary 14.2.46 set-difference, nset-difference [Function] -------------------------------------------------- 'set-difference' list-1 list-2 &key key test test-not => result-list 'nset-difference' list-1 list-2 &key key test test-not => result-list Arguments and Values:: ...................... list-1--a proper list. list-2--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. result-list--a list. Description:: ............. set-difference returns a list of elements of list-1 that do not appear in list-2. nset-difference is the destructive version of set-difference. It may destroy list-1. For all possible ordered pairs consisting of one element from list-1 and one element from list-2, the :test or :test-not function is used to determine whether they satisfy the test. The first argument to the :test or :test-not function is the part of an element of list-1 that is returned by the :key function (if supplied); the second argument is the part of an element of list-2 that is returned by the :key function (if supplied). If :key is supplied, its argument is a list-1 or list-2 element. The :key function typically returns part of the supplied element. If :key is not supplied, the list-1 or list-2 element is used. An element of list-1 appears in the result if and only if it does not match any element of list-2. There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result list may share cells with, or be eq to, either of list-1 or list-2, if appropriate. Examples:: .......... (setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d")) => ("a" "B" "C" "d") (set-difference lst1 lst2) => ("d" "C" "b" "A") (set-difference lst1 lst2 :test 'equal) => ("b" "A") (set-difference lst1 lst2 :test #'equalp) => NIL (nset-difference lst1 lst2 :test #'string=) => ("A" "b") (setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))) => (("a" . "b") ("c" . "d") ("e" . "f")) (setq lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) => (("c" . "a") ("e" . "b") ("d" . "a")) (nset-difference lst1 lst2 :test #'string= :key #'cdr) => (("c" . "d") ("e" . "f")) lst1 => (("a" . "b") ("c" . "d") ("e" . "f")) lst2 => (("c" . "a") ("e" . "b") ("d" . "a")) ;; Remove all flavor names that contain "c" or "w". (set-difference '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb") '(#\c #\w) :test #'(lambda (s c) (find c s))) => ("banana" "rhubarb" "lemon") ;One possible ordering. Side Effects:: .............. nset-difference may destroy list-1. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists. See Also:: .......... *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated.  File: gcl.info, Node: set-exclusive-or, Next: subsetp, Prev: set-difference, Up: Conses Dictionary 14.2.47 set-exclusive-or, nset-exclusive-or [Function] ------------------------------------------------------ 'set-exclusive-or' list-1 list-2 &key key test test-not => result-list 'nset-exclusive-or' list-1 list-2 &key key test test-not => result-list Arguments and Values:: ...................... list-1--a proper list. list-2--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. result-list--a list. Description:: ............. set-exclusive-or returns a list of elements that appear in exactly one of list-1 and list-2. nset-exclusive-or is the destructive version of set-exclusive-or. For all possible ordered pairs consisting of one element from list-1 and one element from list-2, the :test or :test-not function is used to determine whether they satisfy the test. If :key is supplied, it is used to extract the part to be tested from the list-1 or list-2 element. The first argument to the :test or :test-not function is the part of an element of list-1 extracted by the :key function (if supplied); the second argument is the part of an element of list-2 extracted by the :key function (if supplied). If :key is not supplied or nil, the list-1 or list-2 element is used. The result contains precisely those elements of list-1 and list-2 that appear in no matching pair. The result list of set-exclusive-or might share storage with one of list-1 or list-2. Examples:: .......... (setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b")) => (1 "A" "b") (set-exclusive-or lst1 lst2) => ("b" "A" "b" "a") (set-exclusive-or lst1 lst2 :test #'equal) => ("A" "a") (set-exclusive-or lst1 lst2 :test 'equalp) => NIL (nset-exclusive-or lst1 lst2) => ("a" "b" "A" "b") (setq lst1 (list (("a" . "b") ("c" . "d") ("e" . "f")))) => (("a" . "b") ("c" . "d") ("e" . "f")) (setq lst2 (list (("c" . "a") ("e" . "b") ("d" . "a")))) => (("c" . "a") ("e" . "b") ("d" . "a")) (nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr) => (("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a")) lst1 => (("a" . "b") ("c" . "d") ("e" . "f")) lst2 => (("c" . "a") ("d" . "a")) Side Effects:: .............. nset-exclusive-or is permitted to modify any part, car or cdr, of the list structure of list-1 or list-2. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists. See Also:: .......... *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. Since the nset-exclusive-or side effect is not required, it should not be used in for-effect-only positions in portable code.  File: gcl.info, Node: subsetp, Next: union, Prev: set-exclusive-or, Up: Conses Dictionary 14.2.48 subsetp [Function] -------------------------- 'subsetp' list-1 list-2 &key key test test-not => generalized-boolean Arguments and Values:: ...................... list-1--a proper list. list-2--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. generalized-boolean--a generalized boolean. Description:: ............. subsetp returns true if every element of list-1 matches some element of list-2, and false otherwise. Whether a list element is the same as another list element is determined by the functions specified by the keyword arguments. The first argument to the :test or :test-not function is typically part of an element of list-1 extracted by the :key function; the second argument is typically part of an element of list-2 extracted by the :key function. The argument to the :key function is an element of either list-1 or list-2; the return value is part of the element of the supplied list element. If :key is not supplied or nil, the list-1 or list-2 element itself is supplied to the :test or :test-not function. Examples:: .......... (setq cosmos '(1 "a" (1 2))) => (1 "a" (1 2)) (subsetp '(1) cosmos) => true (subsetp '((1 2)) cosmos) => false (subsetp '((1 2)) cosmos :test 'equal) => true (subsetp '(1 "A") cosmos :test #'equalp) => true (subsetp '((1) (2)) '((1) (2))) => false (subsetp '((1) (2)) '((1) (2)) :key #'car) => true Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists. See Also:: .......... *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated.  File: gcl.info, Node: union, Prev: subsetp, Up: Conses Dictionary 14.2.49 union, nunion [Function] -------------------------------- 'union' list-1 list-2 &key key test test-not => result-list 'nunion' list-1 list-2 &key key test test-not => result-list Arguments and Values:: ...................... list-1--a proper list. list-2--a proper list. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. result-list--a list. Description:: ............. union and nunion return a list that contains every element that occurs in either list-1 or list-2. For all possible ordered pairs consisting of one element from list-1 and one element from list-2, :test or :test-not is used to determine whether they satisfy the test. The first argument to the :test or :test-not function is the part of the element of list-1 extracted by the :key function (if supplied); the second argument is the part of the element of list-2 extracted by the :key function (if supplied). The argument to the :key function is an element of list-1 or list-2; the return value is part of the supplied element. If :key is not supplied or nil, the element of list-1 or list-2 itself is supplied to the :test or :test-not function. For every matching pair, one of the two elements of the pair will be in the result. Any element from either list-1 or list-2 that matches no element of the other will appear in the result. If there is a duplication between list-1 and list-2, only one of the duplicate instances will be in the result. If either list-1 or list-2 has duplicate entries within it, the redundant entries might or might not appear in the result. The order of elements in the result do not have to reflect the ordering of list-1 or list-2 in any way. The result list may be eq to either list-1 or list-2 if appropriate. Examples:: .......... (union '(a b c) '(f a d)) => (A B C F D) OR=> (B C F A D) OR=> (D F A B C) (union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car) => ((X 5) (Y 6) (Z 2)) OR=> ((X 4) (Y 6) (Z 2)) (setq lst1 (list 1 2 '(1 2) "a" "b") lst2 (list 2 3 '(2 3) "B" "C")) => (2 3 (2 3) "B" "C") (nunion lst1 lst2) => (1 (1 2) "a" "b" 2 3 (2 3) "B" "C") OR=> (1 2 (1 2) "a" "b" "C" "B" (2 3) 3) Side Effects:: .............. nunion is permitted to modify any part, car or cdr, of the list structure of list-1 or list-2. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists. See Also:: .......... *note intersection:: , *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not parameter is deprecated. Since the nunion side effect is not required, it should not be used in for-effect-only positions in portable code.  File: gcl.info, Node: Arrays, Next: Strings, Prev: Conses, Up: Top 15 Arrays ********* * Menu: * Array Concepts:: * Arrays Dictionary::  File: gcl.info, Node: Array Concepts, Next: Arrays Dictionary, Prev: Arrays, Up: Arrays 15.1 Array Concepts =================== * Menu: * Array Elements:: * Specialized Arrays::  File: gcl.info, Node: Array Elements, Next: Specialized Arrays, Prev: Array Concepts, Up: Array Concepts 15.1.1 Array Elements --------------------- An array contains a set of objects called elements that can be referenced individually according to a rectilinear coordinate system. * Menu: * Array Indices:: * Array Dimensions:: * Implementation Limits on Individual Array Dimensions:: * Array Rank:: * Vectors:: * Fill Pointers:: * Multidimensional Arrays:: * Storage Layout for Multidimensional Arrays:: * Implementation Limits on Array Rank::  File: gcl.info, Node: Array Indices, Next: Array Dimensions, Prev: Array Elements, Up: Array Elements 15.1.1.1 Array Indices ...................... An array element is referred to by a (possibly empty) series of indices. The length of the series must equal the rank of the array. Each index must be a non-negative fixnum less than the corresponding array dimension. Array indexing is zero-origin.  File: gcl.info, Node: Array Dimensions, Next: Implementation Limits on Individual Array Dimensions, Prev: Array Indices, Up: Array Elements 15.1.1.2 Array Dimensions ......................... An axis of an array is called a dimension . Each dimension is a non-negative fixnum; if any dimension of an array is zero, the array has no elements. It is permissible for a dimension to be zero, in which case the array has no elements, and any attempt to access an element is an error. However, other properties of the array, such as the dimensions themselves, may be used.  File: gcl.info, Node: Implementation Limits on Individual Array Dimensions, Next: Array Rank, Prev: Array Dimensions, Up: Array Elements 15.1.1.3 Implementation Limits on Individual Array Dimensions ............................................................. An implementation may impose a limit on dimensions of an array, but there is a minimum requirement on that limit. See the variable array-dimension-limit.  File: gcl.info, Node: Array Rank, Next: Vectors, Prev: Implementation Limits on Individual Array Dimensions, Up: Array Elements 15.1.1.4 Array Rank ................... An array can have any number of dimensions (including zero). The number of dimensions is called the rank . If the rank of an array is zero then the array is said to have no dimensions, and the product of the dimensions (see array-total-size) is then 1; a zero-rank array therefore has a single element.  File: gcl.info, Node: Vectors, Next: Fill Pointers, Prev: Array Rank, Up: Array Elements 15.1.1.5 Vectors ................ An array of rank one (i.e., a one-dimensional array) is called a vector .  File: gcl.info, Node: Fill Pointers, Next: Multidimensional Arrays, Prev: Vectors, Up: Array Elements 15.1.1.6 Fill Pointers ...................... A fill pointer is a non-negative integer no larger than the total number of elements in a vector. Not all vectors have fill pointers. See the functions make-array and adjust-array. An element of a vector is said to be active if it has an index that is greater than or equal to zero, but less than the fill pointer (if any). For an array that has no fill pointer, all elements are considered active. Only vectors may have fill pointers; multidimensional arrays may not. A multidimensional array that is displaced to a vector that has a fill pointer can be created.  File: gcl.info, Node: Multidimensional Arrays, Next: Storage Layout for Multidimensional Arrays, Prev: Fill Pointers, Up: Array Elements 15.1.1.7 Multidimensional Arrays ................................  File: gcl.info, Node: Storage Layout for Multidimensional Arrays, Next: Implementation Limits on Array Rank, Prev: Multidimensional Arrays, Up: Array Elements 15.1.1.8 Storage Layout for Multidimensional Arrays ................................................... Multidimensional arrays store their components in row-major order; that is, internally a multidimensional array is stored as a one-dimensional array, with the multidimensional index sets ordered lexicographically, last index varying fastest.  File: gcl.info, Node: Implementation Limits on Array Rank, Prev: Storage Layout for Multidimensional Arrays, Up: Array Elements 15.1.1.9 Implementation Limits on Array Rank ............................................ An implementation may impose a limit on the rank of an array, but there is a minimum requirement on that limit. See the variable array-rank-limit.  File: gcl.info, Node: Specialized Arrays, Prev: Array Elements, Up: Array Concepts 15.1.2 Specialized Arrays ------------------------- An array can be a general array, meaning each element may be any object, or it may be a specialized array, meaning that each element must be of a restricted type. The phrasing "an array specialized to type <>" is sometimes used to emphasize the element type of an array. This phrasing is tolerated even when the <> is t, even though an array specialized to type t is a general array, not a specialized array. Figure 15-1 lists some defined names that are applicable to array creation, access, and information operations. adjust-array array-in-bounds-p svref adjustable-array-p array-rank upgraded-array-element-type aref array-rank-limit upgraded-complex-part-type array-dimension array-row-major-index vector array-dimension-limit array-total-size vector-pop array-dimensions array-total-size-limit vector-push array-element-type fill-pointer vector-push-extend array-has-fill-pointer-p make-array Figure 15-1: General Purpose Array-Related Defined Names * Menu: * Array Upgrading:: * Required Kinds of Specialized Arrays::  File: gcl.info, Node: Array Upgrading, Next: Required Kinds of Specialized Arrays, Prev: Specialized Arrays, Up: Specialized Arrays 15.1.2.1 Array Upgrading ........................ The upgraded array element type of a type T_1 is a type T_2 that is a supertype of T_1 and that is used instead of T_1 whenever T_1 is used as an array element type for object creation or type discrimination. During creation of an array, the element type that was requested is called the expressed array element type . The upgraded array element type of the expressed array element type becomes the actual array element type of the array that is created. Type upgrading implies a movement upwards in the type hierarchy lattice. A type is always a subtype of its upgraded array element type. Also, if a type T_x is a subtype of another type T_y, then the upgraded array element type of T_x must be a subtype of the upgraded array element type of T_y. Two disjoint types can be upgraded to the same type. The upgraded array element type T_2 of a type T_1 is a function only of T_1 itself; that is, it is independent of any other property of the array for which T_2 will be used, such as rank, adjustability, fill pointers, or displacement. The function upgraded-array-element-type can be used by conforming programs to predict how the implementation will upgrade a given type.  File: gcl.info, Node: Required Kinds of Specialized Arrays, Prev: Array Upgrading, Up: Specialized Arrays 15.1.2.2 Required Kinds of Specialized Arrays ............................................. Vectors whose elements are restricted to type character or a subtype of character are called strings . Strings are of type string. Figure 15-2 lists some defined names related to strings. Strings are specialized arrays and might logically have been included in this chapter. However, for purposes of readability most information about strings does not appear in this chapter; see instead *note Strings::. char string-equal string-upcase make-string string-greaterp string/= nstring-capitalize string-left-trim string< nstring-downcase string-lessp string<= nstring-upcase string-not-equal string= schar string-not-greaterp string> string string-not-lessp string>= string-capitalize string-right-trim string-downcase string-trim Figure 15-2: Operators that Manipulate Strings Vectors whose elements are restricted to type bit are called bit vectors . Bit vectors are of type bit-vector. Figure 15-3 lists some defined names for operations on bit arrays. bit bit-ior bit-orc2 bit-and bit-nand bit-xor bit-andc1 bit-nor sbit bit-andc2 bit-not bit-eqv bit-orc1 Figure 15-3: Operators that Manipulate Bit Arrays  File: gcl.info, Node: Arrays Dictionary, Prev: Array Concepts, Up: Arrays 15.2 Arrays Dictionary ====================== * Menu: * array:: * simple-array:: * vector (System Class):: * simple-vector:: * bit-vector:: * simple-bit-vector:: * make-array:: * adjust-array:: * adjustable-array-p:: * aref:: * array-dimension:: * array-dimensions:: * array-element-type:: * array-has-fill-pointer-p:: * array-displacement:: * array-in-bounds-p:: * array-rank:: * array-row-major-index:: * array-total-size:: * arrayp:: * fill-pointer:: * row-major-aref:: * upgraded-array-element-type:: * array-dimension-limit:: * array-rank-limit:: * array-total-size-limit:: * simple-vector-p:: * svref:: * vector:: * vector-pop:: * vector-push:: * vectorp:: * bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p::  File: gcl.info, Node: array, Next: simple-array, Prev: Arrays Dictionary, Up: Arrays Dictionary 15.2.1 array [System Class] --------------------------- Class Precedence List:: ....................... array, t Description:: ............. An array contains objects arranged according to a Cartesian coordinate system. An array provides mappings from a set of fixnums \left{i_0,i_1,\dots,i_{r-1}\right} to corresponding elements of the array, where 0 \le i_j < d_j, r is the rank of the array, and d_j is the size of dimension j of the array. When an array is created, the program requesting its creation may declare that all elements are of a particular type, called the expressed array element type. The implementation is permitted to upgrade this type in order to produce the actual array element type, which is the element type for the array is actually specialized. See the function upgraded-array-element-type. Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('array'{[{element-type | *} [dimension-spec]]}) dimension-spec ::=rank | * | ({dimension | *}*) Compound Type Specifier Arguments:: ................................... dimension--a valid array dimension. element-type--a type specifier. rank--a non-negative fixnum. Compound Type Specifier Description:: ..................................... This denotes the set of arrays whose element type, rank, and dimensions match any given element-type, rank, and dimensions. Specifically: If element-type is the symbol *, arrays are not excluded on the basis of their element type. Otherwise, only those arrays are included whose actual array element type is the result of upgrading element-type; see *note Array Upgrading::. If the dimension-spec is a rank, the set includes only those arrays having that rank. If the dimension-spec is a list of dimensions, the set includes only those arrays having a rank given by the length of the dimensions, and having the indicated dimensions; in this case, * matches any value for the corresponding dimension. If the dimension-spec is the symbol *, the set is not restricted on the basis of rank or dimension. See Also:: .......... *print-array*, *note aref:: , *note make-array:: , vector, *note Sharpsign A::, *note Printing Other Arrays:: Notes:: ....... Note that the type (array t) is a proper subtype of the type (array *). The reason is that the type (array t) is the set of arrays that can hold any object (the elements are of type t, which includes all objects). On the other hand, the type (array *) is the set of all arrays whatsoever, including for example arrays that can hold only characters. The type (array character) is not a subtype of the type (array t); the two sets are disjoint because the type (array character) is not the set of all arrays that can hold characters, but rather the set of arrays that are specialized to hold precisely characters and no other objects.  File: gcl.info, Node: simple-array, Next: vector (System Class), Prev: array, Up: Arrays Dictionary 15.2.2 simple-array [Type] -------------------------- Supertypes:: ............ simple-array, array, t Description:: ............. The type of an array that is not displaced to another array, has no fill pointer, and is not expressly adjustable is a subtype of type simple-array. The concept of a simple array exists to allow the implementation to use a specialized representation and to allow the user to declare that certain values will always be simple arrays. The types simple-vector, simple-string, and simple-bit-vector are disjoint subtypes of type simple-array, for they respectively mean (simple-array t (*)), the union of all (simple-array c (*)) for any c being a subtype of type character, and (simple-array bit (*)). Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('simple-array'{[{element-type | *} [dimension-spec]]}) dimension-spec ::=rank | * | ({dimension | *}*) Compound Type Specifier Arguments:: ................................... dimension--a valid array dimension. element-type--a type specifier. rank--a non-negative fixnum. Compound Type Specifier Description:: ..................................... This compound type specifier is treated exactly as the corresponding compound type specifier for type array would be treated, except that the set is further constrained to include only simple arrays. Notes:: ....... It is implementation-dependent whether displaced arrays, vectors with fill pointers, or arrays that are actually adjustable are simple arrays. (simple-array *) refers to all simple arrays regardless of element type, (simple-array type-specifier) refers only to those simple arrays that can result from giving type-specifier as the :element-type argument to make-array.  File: gcl.info, Node: vector (System Class), Next: simple-vector, Prev: simple-array, Up: Arrays Dictionary 15.2.3 vector [System Class] ---------------------------- Class Precedence List:: ....................... vector, array, sequence, t Description:: ............. Any one-dimensional array is a vector. The type vector is a subtype of type array; for all types x, (vector x) is the same as (array x (*)). The type (vector t), the type string, and the type bit-vector are disjoint subtypes of type vector. Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('vector'{[{element-type | *} [{size | *}]]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum. element-type--a type specifier. Compound Type Specifier Description:: ..................................... This denotes the set of specialized vectors whose element type and dimension match the specified values. Specifically: If element-type is the symbol *, vectors are not excluded on the basis of their element type. Otherwise, only those vectors are included whose actual array element type is the result of upgrading element-type; see *note Array Upgrading::. If a size is specified, the set includes only those vectors whose only dimension is size. If the symbol * is specified instead of a size, the set is not restricted on the basis of dimension. See Also:: .......... *note Required Kinds of Specialized Arrays::, *note Sharpsign Left-Parenthesis::, *note Printing Other Vectors::, *note Sharpsign A:: Notes:: ....... The type (vector e s) is equivalent to the type (array e (s)). The type (vector bit) has the name bit-vector. The union of all types (vector C), where C is any subtype of character, has the name string. (vector *) refers to all vectors regardless of element type, (vector type-specifier) refers only to those vectors that can result from giving type-specifier as the :element-type argument to make-array.  File: gcl.info, Node: simple-vector, Next: bit-vector, Prev: vector (System Class), Up: Arrays Dictionary 15.2.4 simple-vector [Type] --------------------------- Supertypes:: ............ simple-vector, vector, simple-array, array, sequence, t Description:: ............. The type of a vector that is not displaced to another array, has no fill pointer, is not expressly adjustable and is able to hold elements of any type is a subtype of type simple-vector. The type simple-vector is a subtype of type vector, and is a subtype of type (vector t). Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('simple-vector'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. The default is the symbol *. Compound Type Specifier Description:: ..................................... This is the same as (simple-array t (size)).  File: gcl.info, Node: bit-vector, Next: simple-bit-vector, Prev: simple-vector, Up: Arrays Dictionary 15.2.5 bit-vector [System Class] -------------------------------- Class Precedence List:: ....................... bit-vector, vector, array, sequence, t Description:: ............. A bit vector is a vector the element type of which is bit. The type bit-vector is a subtype of type vector, for bit-vector means (vector bit). Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('bit-vector'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. Compound Type Specifier Description:: ..................................... This denotes the same type as the type (array bit (size)); that is, the set of bit vectors of size size. See Also:: .......... *note Sharpsign Asterisk::, *note Printing Bit Vectors::, *note Required Kinds of Specialized Arrays::  File: gcl.info, Node: simple-bit-vector, Next: make-array, Prev: bit-vector, Up: Arrays Dictionary 15.2.6 simple-bit-vector [Type] ------------------------------- Supertypes:: ............ simple-bit-vector, bit-vector, vector, simple-array, array, sequence, t Description:: ............. The type of a bit vector that is not displaced to another array, has no fill pointer, and is not expressly adjustable is a subtype of type simple-bit-vector. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('simple-bit-vector'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. The default is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the same type as the type (simple-array bit (size)); that is, the set of simple bit vectors of size size.  File: gcl.info, Node: make-array, Next: adjust-array, Prev: simple-bit-vector, Up: Arrays Dictionary 15.2.7 make-array [Function] ---------------------------- 'make-array' dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset => new-array Arguments and Values:: ...................... dimensions--a designator for a list of valid array dimensions. element-type--a type specifier. The default is t. initial-element--an object. initial-contents--an object. adjustable--a generalized boolean. The default is nil. fill-pointer--a valid fill pointer for the array to be created, or t or nil. The default is nil. displaced-to--an array or nil. The default is nil. This option must not be supplied if either initial-element or initial-contents is supplied. displaced-index-offset--a valid array row-major index for displaced-to. The default is 0. This option must not be supplied unless a non-nil displaced-to is supplied. new-array--an array. Description:: ............. Creates and returns an array constructed of the most specialized type that can accommodate elements of type given by element-type. If dimensions is nil then a zero-dimensional array is created. Dimensions represents the dimensionality of the new array. element-type indicates the type of the elements intended to be stored in the new-array. The new-array can actually store any objects of the type which results from upgrading element-type; see *note Array Upgrading::. If initial-element is supplied, it is used to initialize each element of new-array. If initial-element is supplied, it must be of the type given by element-type. initial-element cannot be supplied if either the :initial-contents option is supplied or displaced-to is non-nil. If initial-element is not supplied, the consequences of later reading an uninitialized element of new-array are undefined unless either initial-contents is supplied or displaced-to is non-nil. initial-contents is used to initialize the contents of array. For example: (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0)))) initial-contents is composed of a nested structure of sequences. The numbers of levels in the structure must equal the rank of array. Each leaf of the nested structure must be of the type given by element-type. If array is zero-dimensional, then initial-contents specifies the single element. Otherwise, initial-contents must be a sequence whose length is equal to the first dimension; each element must be a nested structure for an array whose dimensions are the remaining dimensions, and so on. Initial-contents cannot be supplied if either initial-element is supplied or displaced-to is non-nil. If initial-contents is not supplied, the consequences of later reading an uninitialized element of new-array are undefined unless either initial-element is supplied or displaced-to is non-nil. If adjustable is non-nil, the array is expressly adjustable (and so actually adjustable); otherwise, the array is not expressly adjustable (and it is implementation-dependent whether the array is actually adjustable). If fill-pointer is non-nil, the array must be one-dimensional; that is, the array must be a vector. If fill-pointer is t, the length of the vector is used to initialize the fill pointer. If fill-pointer is an integer, it becomes the initial fill pointer for the vector. If displaced-to is non-nil, make-array will create a displaced array and displaced-to is the target of that displaced array. In that case, the consequences are undefined if the actual array element type of displaced-to is not type equivalent to the actual array element type of the array being created. If displaced-to is nil, the array is not a displaced array. The displaced-index-offset is made to be the index offset of the array. When an array A is given as the :displaced-to argument to make-array when creating array B, then array B is said to be displaced to array A. The total number of elements in an array, called the total size of the array, is calculated as the product of all the dimensions. It is required that the total size of A be no smaller than the sum of the total size of B plus the offset n supplied by the displaced-index-offset. The effect of displacing is that array B does not have any elements of its own, but instead maps accesses to itself into accesses to array A. The mapping treats both arrays as if they were one-dimensional by taking the elements in row-major order, and then maps an access to element k of array B to an access to element k+n of array A. If make-array is called with adjustable, fill-pointer, and displaced-to each nil, then the result is a simple array. If make-array is called with one or more of adjustable, fill-pointer, or displaced-to being true, whether the resulting array is a simple array is implementation-dependent. When an array A is given as the :displaced-to argument to make-array when creating array B, then array B is said to be displaced to array A. The total number of elements in an array, called the total size of the array, is calculated as the product of all the dimensions. The consequences are unspecified if the total size of A is smaller than the sum of the total size of B plus the offset n supplied by the displaced-index-offset. The effect of displacing is that array B does not have any elements of its own, but instead maps accesses to itself into accesses to array A. The mapping treats both arrays as if they were one-dimensional by taking the elements in row-major order, and then maps an access to element k of array B to an access to element k+n of array A. Examples:: .......... (make-array 5) ;; Creates a one-dimensional array of five elements. (make-array '(3 4) :element-type '(mod 16)) ;; Creates a ;;two-dimensional array, 3 by 4, with four-bit elements. (make-array 5 :element-type 'single-float) ;; Creates an array of single-floats. (make-array nil :initial-element nil) => #0ANIL (make-array 4 :initial-element nil) => #(NIL NIL NIL NIL) (make-array '(2 4) :element-type '(unsigned-byte 2) :initial-contents '((0 1 2 3) (3 2 1 0))) => #2A((0 1 2 3) (3 2 1 0)) (make-array 6 :element-type 'character :initial-element #\a :fill-pointer 3) => "aaa" The following is an example of making a displaced array. (setq a (make-array '(4 3))) => # (dotimes (i 4) (dotimes (j 3) (setf (aref a i j) (list i 'x j '= (* i j))))) => NIL (setq b (make-array 8 :displaced-to a :displaced-index-offset 2)) => # (dotimes (i 8) (print (list i (aref b i)))) |> (0 (0 X 2 = 0)) |> (1 (1 X 0 = 0)) |> (2 (1 X 1 = 1)) |> (3 (1 X 2 = 2)) |> (4 (2 X 0 = 0)) |> (5 (2 X 1 = 2)) |> (6 (2 X 2 = 4)) |> (7 (3 X 0 = 0)) => NIL The last example depends on the fact that arrays are, in effect, stored in row-major order. (setq a1 (make-array 50)) => # (setq b1 (make-array 20 :displaced-to a1 :displaced-index-offset 10)) => # (length b1) => 20 (setq a2 (make-array 50 :fill-pointer 10)) => # (setq b2 (make-array 20 :displaced-to a2 :displaced-index-offset 10)) => # (length a2) => 10 (length b2) => 20 (setq a3 (make-array 50 :fill-pointer 10)) => # (setq b3 (make-array 20 :displaced-to a3 :displaced-index-offset 10 :fill-pointer 5)) => # (length a3) => 10 (length b3) => 5 See Also:: .......... *note adjustable-array-p:: , *note aref:: , *note arrayp:: , *note array-element-type:: , *note array-rank-limit:: , *note array-dimension-limit:: , *note fill-pointer:: , *note upgraded-array-element-type:: Notes:: ....... There is no specified way to create an array for which adjustable-array-p definitely returns false. There is no specified way to create an array that is not a simple array.  File: gcl.info, Node: adjust-array, Next: adjustable-array-p, Prev: make-array, Up: Arrays Dictionary 15.2.8 adjust-array [Function] ------------------------------ 'adjust-array' array new-dimensions &key element-type initial-element initial-contents fill-pointer displaced-to displaced-index-offset => adjusted-array Arguments and Values:: ...................... array--an array. new-dimensions--a valid array dimension or a list of valid array dimensions. element-type--a type specifier. initial-element--an object. Initial-element must not be supplied if either initial-contents or displaced-to is supplied. initial-contents--an object. If array has rank greater than zero, then initial-contents is composed of nested sequences, the depth of which must equal the rank of array. Otherwise, array is zero-dimensional and initial-contents supplies the single element. initial-contents must not be supplied if either initial-element or displaced-to is given. fill-pointer--a valid fill pointer for the array to be created, or t, or nil. The default is nil. displaced-to--an array or nil. initial-elements and initial-contents must not be supplied if displaced-to is supplied. displaced-index-offset--an object of type (fixnum 0 n) where n is (array-total-size displaced-to). displaced-index-offset may be supplied only if displaced-to is supplied. adjusted-array--an array. Description:: ............. adjust-array changes the dimensions or elements of array. The result is an array of the same type and rank as array, that is either the modified array, or a newly created array to which array can be displaced, and that has the given new-dimensions. New-dimensions specify the size of each dimension of array. Element-type specifies the type of the elements of the resulting array. If element-type is supplied, the consequences are unspecified if the upgraded array element type of element-type is not the same as the actual array element type of array. If initial-contents is supplied, it is treated as for make-array. In this case none of the original contents of array appears in the resulting array. If fill-pointer is an integer, it becomes the fill pointer for the resulting array. If fill-pointer is the symbol t, it indicates that the size of the resulting array should be used as the fill pointer. If fill-pointer is nil, it indicates that the fill pointer should be left as it is. If displaced-to non-nil, a displaced array is created. The resulting array shares its contents with the array given by displaced-to. The resulting array cannot contain more elements than the array it is displaced to. If displaced-to is not supplied or nil, the resulting array is not a displaced array. If array A is created displaced to array B and subsequently array B is given to adjust-array, array A will still be displaced to array B. Although array might be a displaced array, the resulting array is not a displaced array unless displaced-to is supplied and not nil. The interaction between adjust-array and displaced arrays is as follows given three arrays, A, B, and~C: A is not displaced before or after the call (adjust-array A ...) The dimensions of A are altered, and the contents rearranged as appropriate. Additional elements of A are taken from initial-element. The use of initial-contents causes all old contents to be discarded. A is not displaced before, but is displaced to C after the call (adjust-array A ... :displaced-to C) None of the original contents of A appears in A afterwards; A now contains the contents of C, without any rearrangement of C. A is displaced to B before the call, and is displaced to C after the call (adjust-array A ... :displaced-to B) (adjust-array A ... :displaced-to C) B and C might be the same. The contents of B do not appear in A afterward unless such contents also happen to be in C If displaced-index-offset is not supplied in the adjust-array call, it defaults to zero; the old offset into B is not retained. A is displaced to B before the call, but not displaced afterward. (adjust-array A ... :displaced-to B) (adjust-array A ... :displaced-to nil) A gets a new "data region," and contents of B are copied into it as appropriate to maintain the existing old contents; additional elements of A are taken from initial-element if supplied. However, the use of initial-contents causes all old contents to be discarded. If displaced-index-offset is supplied, it specifies the offset of the resulting array from the beginning of the array that it is displaced to. If displaced-index-offset is not supplied, the offset is~0. The size of the resulting array plus the offset value cannot exceed the size of the array that it is displaced to. If only new-dimensions and an initial-element argument are supplied, those elements of array that are still in bounds appear in the resulting array. The elements of the resulting array that are not in the bounds of array are initialized to initial-element; if initial-element is not provided, the consequences of later reading any such new element of new-array before it has been initialized are undefined. If initial-contents or displaced-to is supplied, then none of the original contents of array appears in the new array. The consequences are unspecified if array is adjusted to a size smaller than its fill pointer without supplying the fill-pointer argument so that its fill-pointer is properly adjusted in the process. If A is displaced to B, the consequences are unspecified if B is adjusted in such a way that it no longer has enough elements to satisfy A. If adjust-array is applied to an array that is actually adjustable, the array returned is identical to array. If the array returned by adjust-array is distinct from array, then the argument array is unchanged. Note that if an array A is displaced to another array B, and B is displaced to another array C, and B is altered by adjust-array, A must now refer to the adjust contents of B. This means that an implementation cannot collapse the chain to make A refer to C directly and forget that the chain of reference passes through B. However, caching techniques are permitted as long as they preserve the semantics specified here. Examples:: .......... (adjustable-array-p (setq ada (adjust-array (make-array '(2 3) :adjustable t :initial-contents '((a b c) (1 2 3))) '(4 6)))) => T (array-dimensions ada) => (4 6) (aref ada 1 1) => 2 (setq beta (make-array '(2 3) :adjustable t)) => #2A((NIL NIL NIL) (NIL NIL NIL)) (adjust-array beta '(4 6) :displaced-to ada) => #2A((A B C NIL NIL NIL) (1 2 3 NIL NIL NIL) (NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL)) (array-dimensions beta) => (4 6) (aref beta 1 1) => 2 Suppose that the 4-by-4 array in m looks like this: #2A(( alpha beta gamma delta ) ( epsilon zeta eta theta ) ( iota kappa lambda mu ) ( nu xi omicron pi )) Then the result of (adjust-array m '(3 5) :initial-element 'baz) is a 3-by-5 array with contents #2A(( alpha beta gamma delta baz ) ( epsilon zeta eta theta baz ) ( iota kappa lambda mu baz )) Exceptional Situations:: ........................ An error of type error is signaled if fill-pointer is supplied and non-nil but array has no fill pointer. See Also:: .......... *note adjustable-array-p:: , *note make-array:: , *note array-dimension-limit:: , *note array-total-size-limit:: , array  File: gcl.info, Node: adjustable-array-p, Next: aref, Prev: adjust-array, Up: Arrays Dictionary 15.2.9 adjustable-array-p [Function] ------------------------------------ 'adjustable-array-p' array => generalized-boolean Arguments and Values:: ...................... array--an array. generalized-boolean--a generalized boolean. Description:: ............. Returns true if and only if adjust-array could return a value which is identical to array when given that array as its first argument. Examples:: .......... (adjustable-array-p (make-array 5 :element-type 'character :adjustable t :fill-pointer 3)) => true (adjustable-array-p (make-array 4)) => implementation-dependent Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... *note adjust-array:: , *note make-array::  File: gcl.info, Node: aref, Next: array-dimension, Prev: adjustable-array-p, Up: Arrays Dictionary 15.2.10 aref [Accessor] ----------------------- 'aref' array &rest subscripts => element (setf (' aref' array &rest subscripts) new-element) Arguments and Values:: ...................... array--an array. subscripts--a list of valid array indices for the array. element, new-element--an object. Description:: ............. Accesses the array element specified by the subscripts. If no subscripts are supplied and array is zero rank, aref accesses the sole element of array. aref ignores fill pointers. It is permissible to use aref to access any array element, whether active or not. Examples:: .......... If the variable foo names a 3-by-5 array, then the first index could be 0, 1, or 2, and then second index could be 0, 1, 2, 3, or 4. The array elements can be referred to by using the function aref; for example, (aref foo 2 1) refers to element (2, 1) of the array. (aref (setq alpha (make-array 4)) 3) => implementation-dependent (setf (aref alpha 3) 'sirens) => SIRENS (aref alpha 3) => SIRENS (aref (setq beta (make-array '(2 4) :element-type '(unsigned-byte 2) :initial-contents '((0 1 2 3) (3 2 1 0)))) 1 2) => 1 (setq gamma '(0 2)) (apply #'aref beta gamma) => 2 (setf (apply #'aref beta gamma) 3) => 3 (apply #'aref beta gamma) => 3 (aref beta 0 2) => 3 See Also:: .......... *note bit (Array):: , *note char:: , *note elt:: , *note row-major-aref:: , *note svref:: , *note Compiler Terminology::  File: gcl.info, Node: array-dimension, Next: array-dimensions, Prev: aref, Up: Arrays Dictionary 15.2.11 array-dimension [Function] ---------------------------------- 'array-dimension' array axis-number => dimension Arguments and Values:: ...................... array--an array. axis-number--an integer greater than or equal to zero and less than the rank of the array. dimension--a non-negative integer. Description:: ............. array-dimension returns the axis-number dimension_1 of array. (Any fill pointer is ignored.) Examples:: .......... (array-dimension (make-array 4) 0) => 4 (array-dimension (make-array '(2 3)) 1) => 3 Affected By:: ............. None. See Also:: .......... *note array-dimensions:: , *note length:: Notes:: ....... (array-dimension array n) == (nth n (array-dimensions array))  File: gcl.info, Node: array-dimensions, Next: array-element-type, Prev: array-dimension, Up: Arrays Dictionary 15.2.12 array-dimensions [Function] ----------------------------------- 'array-dimensions' array => dimensions Arguments and Values:: ...................... array--an array. dimensions--a list of integers. Description:: ............. Returns a list of the dimensions of array. (If array is a vector with a fill pointer, that fill pointer is ignored.) Examples:: .......... (array-dimensions (make-array 4)) => (4) (array-dimensions (make-array '(2 3))) => (2 3) (array-dimensions (make-array 4 :fill-pointer 2)) => (4) Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... *note array-dimension::  File: gcl.info, Node: array-element-type, Next: array-has-fill-pointer-p, Prev: array-dimensions, Up: Arrays Dictionary 15.2.13 array-element-type [Function] ------------------------------------- 'array-element-type' array => typespec Arguments and Values:: ...................... array--an array. typespec--a type specifier. Description:: ............. Returns a type specifier which represents the actual array element type of the array, which is the set of objects that such an array can hold. (Because of array upgrading, this type specifier can in some cases denote a supertype of the expressed array element type of the array.) Examples:: .......... (array-element-type (make-array 4)) => T (array-element-type (make-array 12 :element-type '(unsigned-byte 8))) => implementation-dependent (array-element-type (make-array 12 :element-type '(unsigned-byte 5))) => implementation-dependent (array-element-type (make-array 5 :element-type '(mod 5))) could be (mod 5), (mod 8), fixnum, t, or any other type of which (mod 5) is a subtype. Affected By:: ............. The implementation. Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... array, *note make-array:: , *note subtypep:: , *note upgraded-array-element-type::  File: gcl.info, Node: array-has-fill-pointer-p, Next: array-displacement, Prev: array-element-type, Up: Arrays Dictionary 15.2.14 array-has-fill-pointer-p [Function] ------------------------------------------- 'array-has-fill-pointer-p' array => generalized-boolean Arguments and Values:: ...................... array--an array. generalized-boolean--a generalized boolean. Description:: ............. Returns true if array has a fill pointer; otherwise returns false. Examples:: .......... (array-has-fill-pointer-p (make-array 4)) => implementation-dependent (array-has-fill-pointer-p (make-array '(2 3))) => false (array-has-fill-pointer-p (make-array 8 :fill-pointer 2 :initial-element 'filler)) => true Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... *note make-array:: , *note fill-pointer:: Notes:: ....... Since arrays of rank other than one cannot have a fill pointer, array-has-fill-pointer-p always returns nil when its argument is such an array.  File: gcl.info, Node: array-displacement, Next: array-in-bounds-p, Prev: array-has-fill-pointer-p, Up: Arrays Dictionary 15.2.15 array-displacement [Function] ------------------------------------- 'array-displacement' array => displaced-to, displaced-index-offset Arguments and Values:: ...................... array--an array. displaced-to--an array or nil. displaced-index-offset--a non-negative fixnum. Description:: ............. If the array is a displaced array, returns the values of the :displaced-to and :displaced-index-offset options for the array (see the functions make-array and adjust-array). If the array is not a displaced array, nil and 0 are returned. If array-displacement is called on an array for which a non-nil object was provided as the :displaced-to argument to make-array or adjust-array, it must return that object as its first value. It is implementation-dependent whether array-displacement returns a non-nil primary value for any other array. Examples:: .......... (setq a1 (make-array 5)) => # (setq a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) => # (array-displacement a2) => #, 1 (setq a3 (make-array 2 :displaced-to a2 :displaced-index-offset 2)) => # (array-displacement a3) => #, 2 Exceptional Situations:: ........................ Should signal an error of type type-error if array is not an array. See Also:: .......... *note make-array::  File: gcl.info, Node: array-in-bounds-p, Next: array-rank, Prev: array-displacement, Up: Arrays Dictionary 15.2.16 array-in-bounds-p [Function] ------------------------------------ 'array-in-bounds-p' array &rest subscripts => generalized-boolean Arguments and Values:: ...................... array--an array. subscripts--a list of integers of length equal to the rank of the array. generalized-boolean--a generalized boolean. Description:: ............. Returns true if the subscripts are all in bounds for array; otherwise returns false. (If array is a vector with a fill pointer, that fill pointer is ignored.) Examples:: .......... (setq a (make-array '(7 11) :element-type 'string-char)) (array-in-bounds-p a 0 0) => true (array-in-bounds-p a 6 10) => true (array-in-bounds-p a 0 -1) => false (array-in-bounds-p a 0 11) => false (array-in-bounds-p a 7 0) => false See Also:: .......... *note array-dimensions:: Notes:: ....... (array-in-bounds-p array subscripts) == (and (not (some #'minusp (list subscripts))) (every #'< (list subscripts) (array-dimensions array)))  File: gcl.info, Node: array-rank, Next: array-row-major-index, Prev: array-in-bounds-p, Up: Arrays Dictionary 15.2.17 array-rank [Function] ----------------------------- 'array-rank' array => rank Arguments and Values:: ...................... array--an array. rank--a non-negative integer. Description:: ............. Returns the number of dimensions of array. Examples:: .......... (array-rank (make-array '())) => 0 (array-rank (make-array 4)) => 1 (array-rank (make-array '(4))) => 1 (array-rank (make-array '(2 3))) => 2 Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... *note array-rank-limit:: , *note make-array::  File: gcl.info, Node: array-row-major-index, Next: array-total-size, Prev: array-rank, Up: Arrays Dictionary 15.2.18 array-row-major-index [Function] ---------------------------------------- 'array-row-major-index' array &rest subscripts => index Arguments and Values:: ...................... array--an array. subscripts--a list of valid array indices for the array. index--a valid array row-major index for the array. Description:: ............. Computes the position according to the row-major ordering of array for the element that is specified by subscripts, and returns the offset of the element in the computed position from the beginning of array. For a one-dimensional array, the result of array-row-major-index equals subscript. array-row-major-index ignores fill pointers. Examples:: .......... (setq a (make-array '(4 7) :element-type '(unsigned-byte 8))) (array-row-major-index a 1 2) => 9 (array-row-major-index (make-array '(2 3 4) :element-type '(unsigned-byte 8) :displaced-to a :displaced-index-offset 4) 0 2 1) => 9 Notes:: ....... A possible definition of array-row-major-index, with no error-checking, is (defun array-row-major-index (a &rest subscripts) (apply #'+ (maplist #'(lambda (x y) (* (car x) (apply #'* (cdr y)))) subscripts (array-dimensions a))))  File: gcl.info, Node: array-total-size, Next: arrayp, Prev: array-row-major-index, Up: Arrays Dictionary 15.2.19 array-total-size [Function] ----------------------------------- 'array-total-size' array => size Arguments and Values:: ...................... array--an array. size--a non-negative integer. Description:: ............. Returns the array total size of the array. Examples:: .......... (array-total-size (make-array 4)) => 4 (array-total-size (make-array 4 :fill-pointer 2)) => 4 (array-total-size (make-array 0)) => 0 (array-total-size (make-array '(4 2))) => 8 (array-total-size (make-array '(4 0))) => 0 (array-total-size (make-array '())) => 1 Exceptional Situations:: ........................ Should signal an error of type type-error if its argument is not an array. See Also:: .......... *note make-array:: , *note array-dimensions:: Notes:: ....... If the array is a vector with a fill pointer, the fill pointer is ignored when calculating the array total size. Since the product of no arguments is one, the array total size of a zero-dimensional array is one. (array-total-size x) == (apply #'* (array-dimensions x)) == (reduce #'* (array-dimensions x))  File: gcl.info, Node: arrayp, Next: fill-pointer, Prev: array-total-size, Up: Arrays Dictionary 15.2.20 arrayp [Function] ------------------------- 'arrayp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type array; otherwise, returns false. Examples:: .......... (arrayp (make-array '(2 3 4) :adjustable t)) => true (arrayp (make-array 6)) => true (arrayp #*1011) => true (arrayp "hi") => true (arrayp 'hi) => false (arrayp 12) => false See Also:: .......... *note typep:: Notes:: ....... (arrayp object) == (typep object 'array)  File: gcl.info, Node: fill-pointer, Next: row-major-aref, Prev: arrayp, Up: Arrays Dictionary 15.2.21 fill-pointer [Accessor] ------------------------------- 'fill-pointer' vector => fill-pointer (setf (' fill-pointer' vector) new-fill-pointer) Arguments and Values:: ...................... vector--a vector with a fill pointer. fill-pointer, new-fill-pointer--a valid fill pointer for the vector. Description:: ............. Accesses the fill pointer of vector. Examples:: .......... (setq a (make-array 8 :fill-pointer 4)) => #(NIL NIL NIL NIL) (fill-pointer a) => 4 (dotimes (i (length a)) (setf (aref a i) (* i i))) => NIL a => #(0 1 4 9) (setf (fill-pointer a) 3) => 3 (fill-pointer a) => 3 a => #(0 1 4) (setf (fill-pointer a) 8) => 8 a => #(0 1 4 9 NIL NIL NIL NIL) Exceptional Situations:: ........................ Should signal an error of type type-error if vector is not a vector with a fill pointer. See Also:: .......... *note make-array:: , *note length:: Notes:: ....... There is no operator that will remove a vector's fill pointer.  File: gcl.info, Node: row-major-aref, Next: upgraded-array-element-type, Prev: fill-pointer, Up: Arrays Dictionary 15.2.22 row-major-aref [Accessor] --------------------------------- 'row-major-aref' array index => element (setf (' row-major-aref' array index) new-element) Arguments and Values:: ...................... array--an array. index--a valid array row-major index for the array. element, new-element--an object. Description:: ............. Considers array as a vector by viewing its elements in row-major order, and returns the element of that vector which is referred to by the given index. row-major-aref is valid for use with setf. See Also:: .......... *note aref:: , *note array-row-major-index:: Notes:: ....... (row-major-aref array index) == (aref (make-array (array-total-size array) :displaced-to array :element-type (array-element-type array)) index) (aref array i1 i2 ...) == (row-major-aref array (array-row-major-index array i1 i2))  File: gcl.info, Node: upgraded-array-element-type, Next: array-dimension-limit, Prev: row-major-aref, Up: Arrays Dictionary 15.2.23 upgraded-array-element-type [Function] ---------------------------------------------- 'upgraded-array-element-type' typespec &optional environment => upgraded-typespec Arguments and Values:: ...................... typespec--a type specifier. environment--an environment object. The default is nil, denoting the null lexical environment and the current global environment. upgraded-typespec--a type specifier. Description:: ............. Returns the element type of the most specialized array representation capable of holding items of the type denoted by typespec. The typespec is a subtype of (and possibly type equivalent to) the upgraded-typespec. If typespec is bit, the result is type equivalent to bit. If typespec is base-char, the result is type equivalent to base-char. If typespec is character, the result is type equivalent to character. The purpose of upgraded-array-element-type is to reveal how an implementation does its upgrading. The environment is used to expand any derived type specifiers that are mentioned in the typespec. See Also:: .......... *note array-element-type:: , *note make-array:: Notes:: ....... Except for storage allocation consequences and dealing correctly with the optional environment argument, upgraded-array-element-type could be defined as: (defun upgraded-array-element-type (type &optional environment) (array-element-type (make-array 0 :element-type type)))  File: gcl.info, Node: array-dimension-limit, Next: array-rank-limit, Prev: upgraded-array-element-type, Up: Arrays Dictionary 15.2.24 array-dimension-limit [Constant Variable] ------------------------------------------------- Constant Value:: ................ A positive fixnum, the exact magnitude of which is implementation-dependent, but which is not less than 1024. Description:: ............. The upper exclusive bound on each individual dimension of an array. See Also:: .......... *note make-array::  File: gcl.info, Node: array-rank-limit, Next: array-total-size-limit, Prev: array-dimension-limit, Up: Arrays Dictionary 15.2.25 array-rank-limit [Constant Variable] -------------------------------------------- Constant Value:: ................ A positive fixnum, the exact magnitude of which is implementation-dependent, but which is not less than 8. Description:: ............. The upper exclusive bound on the rank of an array. See Also:: .......... *note make-array::  File: gcl.info, Node: array-total-size-limit, Next: simple-vector-p, Prev: array-rank-limit, Up: Arrays Dictionary 15.2.26 array-total-size-limit [Constant Variable] -------------------------------------------------- Constant Value:: ................ A positive fixnum, the exact magnitude of which is implementation-dependent, but which is not less than 1024. Description:: ............. The upper exclusive bound on the array total size of an array. The actual limit on the array total size imposed by the implementation might vary according the element type of the array; in this case, the value of array-total-size-limit will be the smallest of these possible limits. See Also:: .......... *note make-array:: , *note array-element-type::  File: gcl.info, Node: simple-vector-p, Next: svref, Prev: array-total-size-limit, Up: Arrays Dictionary 15.2.27 simple-vector-p [Function] ---------------------------------- 'simple-vector-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type simple-vector; otherwise, returns false.. Examples:: .......... (simple-vector-p (make-array 6)) => true (simple-vector-p "aaaaaa") => false (simple-vector-p (make-array 6 :fill-pointer t)) => false See Also:: .......... simple-vector Notes:: ....... (simple-vector-p object) == (typep object 'simple-vector)  File: gcl.info, Node: svref, Next: vector, Prev: simple-vector-p, Up: Arrays Dictionary 15.2.28 svref [Accessor] ------------------------ 'svref' simple-vector index => element (setf (' svref' simple-vector index) new-element) Arguments and Values:: ...................... simple-vector--a simple vector. index--a valid array index for the simple-vector. element, new-element--an object (whose type is a subtype of the array element type of the simple-vector). Description:: ............. Accesses the element of simple-vector specified by index. Examples:: .......... (simple-vector-p (setq v (vector 1 2 'sirens))) => true (svref v 0) => 1 (svref v 2) => SIRENS (setf (svref v 1) 'newcomer) => NEWCOMER v => #(1 NEWCOMER SIRENS) See Also:: .......... *note aref:: , sbit, schar, *note vector:: , *note Compiler Terminology:: Notes:: ....... svref is identical to aref except that it requires its first argument to be a simple vector. (svref v i) == (aref (the simple-vector v) i)  File: gcl.info, Node: vector, Next: vector-pop, Prev: svref, Up: Arrays Dictionary 15.2.29 vector [Function] ------------------------- 'vector' &rest objects => vector Arguments and Values:: ...................... object--an object. vector--a vector of type (vector t *). Description:: ............. Creates a fresh simple general vector whose size corresponds to the number of objects. The vector is initialized to contain the objects. Examples:: .......... (arrayp (setq v (vector 1 2 'sirens))) => true (vectorp v) => true (simple-vector-p v) => true (length v) => 3 See Also:: .......... *note make-array:: Notes:: ....... vector is analogous to list. (vector a_1 a_2 ... a_n) == (make-array (list n) :element-type t :initial-contents (list a_1 a_2 ... a_n))  File: gcl.info, Node: vector-pop, Next: vector-push, Prev: vector, Up: Arrays Dictionary 15.2.30 vector-pop [Function] ----------------------------- 'vector-pop' vector => element Arguments and Values:: ...................... vector--a vector with a fill pointer. element--an object. Description:: ............. Decreases the fill pointer of vector by one, and retrieves the element of vector that is designated by the new fill pointer. Examples:: .......... (vector-push (setq fable (list 'fable)) (setq fa (make-array 8 :fill-pointer 2 :initial-element 'sisyphus))) => 2 (fill-pointer fa) => 3 (eq (vector-pop fa) fable) => true (vector-pop fa) => SISYPHUS (fill-pointer fa) => 1 Side Effects:: .............. The fill pointer is decreased by one. Affected By:: ............. The value of the fill pointer. Exceptional Situations:: ........................ An error of type type-error is signaled if vector does not have a fill pointer. If the fill pointer is zero, vector-pop signals an error of type error. See Also:: .......... *note vector-push:: , vector-push-extend, *note fill-pointer::  File: gcl.info, Node: vector-push, Next: vectorp, Prev: vector-pop, Up: Arrays Dictionary 15.2.31 vector-push, vector-push-extend [Function] -------------------------------------------------- 'vector-push' new-element vector => new-index-p 'vector-push-extend' new-element vector &optional extension => new-index Arguments and Values:: ...................... new-element--an object. vector--a vector with a fill pointer. extension--a positive integer. The default is implementation-dependent. new-index-p--a valid array index for vector, or nil. new-index--a valid array index for vector. Description:: ............. vector-push and vector-push-extend store new-element in vector. vector-push attempts to store new-element in the element of vector designated by the fill pointer, and to increase the fill pointer by one. If the (>= (fill-pointer vector) (array-dimension vector 0)), neither vector nor its fill pointer are affected. Otherwise, the store and increment take place and vector-push returns the former value of the fill pointer which is one less than the one it leaves in vector. vector-push-extend is just like vector-push except that if the fill pointer gets too large, vector is extended using adjust-array so that it can contain more elements. Extension is the minimum number of elements to be added to vector if it must be extended. vector-push and vector-push-extend return the index of new-element in vector. If (>= (fill-pointer vector) (array-dimension vector 0)), vector-push returns nil. Examples:: .......... (vector-push (setq fable (list 'fable)) (setq fa (make-array 8 :fill-pointer 2 :initial-element 'first-one))) => 2 (fill-pointer fa) => 3 (eq (aref fa 2) fable) => true (vector-push-extend #\X (setq aa (make-array 5 :element-type 'character :adjustable t :fill-pointer 3))) => 3 (fill-pointer aa) => 4 (vector-push-extend #\Y aa 4) => 4 (array-total-size aa) => at least 5 (vector-push-extend #\Z aa 4) => 5 (array-total-size aa) => 9 ;(or more) Affected By:: ............. The value of the fill pointer. How vector was created. Exceptional Situations:: ........................ An error of type error is signaled by vector-push-extend if it tries to extend vector and vector is not actually adjustable. An error of type error is signaled if vector does not have a fill pointer. See Also:: .......... *note adjustable-array-p:: , *note fill-pointer:: , *note vector-pop::  File: gcl.info, Node: vectorp, Next: bit (Array), Prev: vector-push, Up: Arrays Dictionary 15.2.32 vectorp [Function] -------------------------- 'vectorp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type vector; otherwise, returns false. Examples:: .......... (vectorp "aaaaaa") => true (vectorp (make-array 6 :fill-pointer t)) => true (vectorp (make-array '(2 3 4))) => false (vectorp #*11) => true (vectorp #b11) => false Notes:: ....... (vectorp object) == (typep object 'vector)  File: gcl.info, Node: bit (Array), Next: bit-and, Prev: vectorp, Up: Arrays Dictionary 15.2.33 bit, sbit [Accessor] ---------------------------- 'bit' bit-array &rest subscripts => bit 'sbit' bit-array &rest subscripts => bit (setf ('bit' bit-array &rest subscripts) new-bit) (setf ('sbit' bit-array &rest subscripts) new-bit) Arguments and Values:: ...................... bit-array--for bit, a bit array; for sbit, a simple bit array. subscripts--a list of valid array indices for the bit-array. bit--a bit. Description:: ............. bit and sbit access the bit-array element specified by subscripts. These functions ignore the fill pointer when accessing elements. Examples:: .......... (bit (setq ba (make-array 8 :element-type 'bit :initial-element 1)) 3) => 1 (setf (bit ba 3) 0) => 0 (bit ba 3) => 0 (sbit ba 5) => 1 (setf (sbit ba 5) 1) => 1 (sbit ba 5) => 1 See Also:: .......... *note aref:: , *note Compiler Terminology:: Notes:: ....... bit and sbit are like aref except that they require arrays to be a bit array and a simple bit array, respectively. bit and sbit, unlike char and schar, allow the first argument to be an array of any rank.  File: gcl.info, Node: bit-and, Next: bit-vector-p, Prev: bit (Array), Up: Arrays Dictionary 15.2.34 bit-and, bit-andc1, bit-andc2, bit-eqv, ----------------------------------------------- bit-ior, bit-nand, bit-nor, bit-not, bit-orc1, bit-orc2, bit-xor ---------------------------------------------------------------- [Function] 'bit-and' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-andc1' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-andc2' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-eqv' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-ior' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-nand' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-nor' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-orc1' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-orc2' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-xor' bit-array1 bit-array2 &optional opt-arg => resulting-bit-array 'bit-not' bit-array &optional opt-arg => resulting-bit-array Arguments and Values:: ...................... bit-array, bit-array1, bit-array2--a bit array. Opt-arg--a bit array, or t, or nil. The default is nil. Bit-array, bit-array1, bit-array2, and opt-arg (if an array) must all be of the same rank and dimensions. resulting-bit-array--a bit array. Description:: ............. These functions perform bit-wise logical operations on bit-array1 and bit-array2 and return an array of matching rank and dimensions, such that any given bit of the result is produced by operating on corresponding bits from each of the arguments. In the case of bit-not, an array of rank and dimensions matching bit-array is returned that contains a copy of bit-array with all the bits inverted. If opt-arg is of type (array bit) the contents of the result are destructively placed into opt-arg. If opt-arg is the symbol t, bit-array or bit-array1 is replaced with the result; if opt-arg is nil or omitted, a new array is created to contain the result. Figure 15-4 indicates the logical operation performed by each of the functions. 2 Function Operation _______________________________________________________________________________________________________ bit-and and bit-eqv equivalence (exclusive nor) bit-not complement bit-ior inclusive or bit-xor exclusive or bit-nand complement of bit-array1 and bit-array2 bit-nor complement of bit-array1 or bit-array2 bit-andc1 and complement of bit-array1 with bit-array2 bit-andc2 and bit-array1 with complement of bit-array2 bit-orc1 or complement of bit-array1 with bit-array2 bit-orc2 or bit-array1 with complement of bit-array2 Figure 15-3: Bit-wise Logical Operations on Bit Arrays Examples:: .......... (bit-and (setq ba #*11101010) #*01101011) => #*01101010 (bit-and #*1100 #*1010) => #*1000 (bit-andc1 #*1100 #*1010) => #*0010 (setq rba (bit-andc2 ba #*00110011 t)) => #*11001000 (eq rba ba) => true (bit-not (setq ba #*11101010)) => #*00010101 (setq rba (bit-not ba (setq tba (make-array 8 :element-type 'bit)))) => #*00010101 (equal rba tba) => true (bit-xor #*1100 #*1010) => #*0110 See Also:: .......... lognot, *note logand::  File: gcl.info, Node: bit-vector-p, Next: simple-bit-vector-p, Prev: bit-and, Up: Arrays Dictionary 15.2.35 bit-vector-p [Function] ------------------------------- 'bit-vector-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type bit-vector; otherwise, returns false. Examples:: .......... (bit-vector-p (make-array 6 :element-type 'bit :fill-pointer t)) => true (bit-vector-p #*) => true (bit-vector-p (make-array 6)) => false See Also:: .......... *note typep:: Notes:: ....... (bit-vector-p object) == (typep object 'bit-vector)  File: gcl.info, Node: simple-bit-vector-p, Prev: bit-vector-p, Up: Arrays Dictionary 15.2.36 simple-bit-vector-p [Function] -------------------------------------- 'simple-bit-vector-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type simple-bit-vector; otherwise, returns false. Examples:: .......... (simple-bit-vector-p (make-array 6)) => false (simple-bit-vector-p #*) => true See Also:: .......... *note simple-vector-p:: Notes:: ....... (simple-bit-vector-p object) == (typep object 'simple-bit-vector)  File: gcl.info, Node: Strings, Next: Sequences, Prev: Arrays, Up: Top 16 Strings ********** * Menu: * String Concepts:: * Strings Dictionary::  File: gcl.info, Node: String Concepts, Next: Strings Dictionary, Prev: Strings, Up: Strings 16.1 String Concepts ==================== * Menu: * Implications of Strings Being Arrays:: * Subtypes of STRING::  File: gcl.info, Node: Implications of Strings Being Arrays, Next: Subtypes of STRING, Prev: String Concepts, Up: String Concepts 16.1.1 Implications of Strings Being Arrays ------------------------------------------- Since all strings are arrays, all rules which apply generally to arrays also apply to strings. See *note Array Concepts::. For example, strings can have fill pointers, and strings are also subject to the rules of element type upgrading that apply to arrays.  File: gcl.info, Node: Subtypes of STRING, Prev: Implications of Strings Being Arrays, Up: String Concepts 16.1.2 Subtypes of STRING ------------------------- All functions that operate on strings will operate on subtypes of string as well. However, the consequences are undefined if a character is inserted into a string for which the element type of the string does not include that character.  File: gcl.info, Node: Strings Dictionary, Prev: String Concepts, Up: Strings 16.2 Strings Dictionary ======================= * Menu: * string (System Class):: * base-string:: * simple-string:: * simple-base-string:: * simple-string-p:: * char:: * string:: * string-upcase:: * string-trim:: * string=:: * stringp:: * make-string::  File: gcl.info, Node: string (System Class), Next: base-string, Prev: Strings Dictionary, Up: Strings Dictionary 16.2.1 string [System Class] ---------------------------- Class Precedence List:: ....................... string, vector, array, sequence, t Description:: ............. A string is a specialized vector whose elements are of type character or a subtype of type character. When used as a type specifier for object creation, string means (vector character). Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('string'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. Compound Type Specifier Description:: ..................................... This denotes the union of all types (array c (size)) for all subtypes c of character; that is, the set of strings of size size. See Also:: .......... *note String Concepts::, *note Double-Quote::, *note Printing Strings::  File: gcl.info, Node: base-string, Next: simple-string, Prev: string (System Class), Up: Strings Dictionary 16.2.2 base-string [Type] ------------------------- Supertypes:: ............ base-string, string, vector, array, sequence, t Description:: ............. The type base-string is equivalent to (vector base-char). The base string representation is the most efficient string representation that can hold an arbitrary sequence of standard characters. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('base-string'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. Compound Type Specifier Description:: ..................................... This is equivalent to the type (vector base-char size); that is, the set of base strings of size size.  File: gcl.info, Node: simple-string, Next: simple-base-string, Prev: base-string, Up: Strings Dictionary 16.2.3 simple-string [Type] --------------------------- Supertypes:: ............ simple-string, string, vector, simple-array, array, sequence, t Description:: ............. A simple string is a specialized one-dimensional simple array whose elements are of type character or a subtype of type character. When used as a type specifier for object creation, simple-string means (simple-array character (size)). Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('simple-string'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. Compound Type Specifier Description:: ..................................... This denotes the union of all types (simple-array c (size)) for all subtypes c of character; that is, the set of simple strings of size size.  File: gcl.info, Node: simple-base-string, Next: simple-string-p, Prev: simple-string, Up: Strings Dictionary 16.2.4 simple-base-string [Type] -------------------------------- Supertypes:: ............ simple-base-string, base-string, simple-string, string, vector, simple-array, array, sequence, t Description:: ............. The type simple-base-string is equivalent to (simple-array base-char (*)). Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('simple-base-string'{[size]}) Compound Type Specifier Arguments:: ................................... size--a non-negative fixnum, or the symbol *. Compound Type Specifier Description:: ..................................... This is equivalent to the type (simple-array base-char (size)); that is, the set of simple base strings of size size.  File: gcl.info, Node: simple-string-p, Next: char, Prev: simple-base-string, Up: Strings Dictionary 16.2.5 simple-string-p [Function] --------------------------------- 'simple-string-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type simple-string; otherwise, returns false. Examples:: .......... (simple-string-p "aaaaaa") => true (simple-string-p (make-array 6 :element-type 'character :fill-pointer t)) => false Notes:: ....... (simple-string-p object) == (typep object 'simple-string)  File: gcl.info, Node: char, Next: string, Prev: simple-string-p, Up: Strings Dictionary 16.2.6 char, schar [Accessor] ----------------------------- 'char' string index => character 'schar' string index => character (setf ('char' string index) new-character) (setf ('schar' string index) new-character) Arguments and Values:: ...................... string--for char, a string; for schar, a simple string. index--a valid array index for the string. character, new-character--a character. Description:: ............. char and schar access the element of string specified by index. char ignores fill pointers when accessing elements. Examples:: .......... (setq my-simple-string (make-string 6 :initial-element #\A)) => "AAAAAA" (schar my-simple-string 4) => #\A (setf (schar my-simple-string 4) #\B) => #\B my-simple-string => "AAAABA" (setq my-filled-string (make-array 6 :element-type 'character :fill-pointer 5 :initial-contents my-simple-string)) => "AAAAB" (char my-filled-string 4) => #\B (char my-filled-string 5) => #\A (setf (char my-filled-string 3) #\C) => #\C (setf (char my-filled-string 5) #\D) => #\D (setf (fill-pointer my-filled-string) 6) => 6 my-filled-string => "AAACBD" See Also:: .......... *note aref:: , *note elt:: , *note Compiler Terminology:: Notes:: ....... (char s j) == (aref (the string s) j)  File: gcl.info, Node: string, Next: string-upcase, Prev: char, Up: Strings Dictionary 16.2.7 string [Function] ------------------------ 'string' x => string Arguments and Values:: ...................... x--a string, a symbol, or a character. string--a string. Description:: ............. Returns a string described by x; specifically: * If x is a string, it is returned. * If x is a symbol, its name is returned. * If x is a character, then a string containing that one character is returned. * string might perform additional, implementation-defined conversions. Examples:: .......... (string "already a string") => "already a string" (string 'elm) => "ELM" (string #\c) => "c" Exceptional Situations:: ........................ In the case where a conversion is defined neither by this specification nor by the implementation, an error of type type-error is signaled. See Also:: .......... *note coerce:: , string (type). Notes:: ....... coerce can be used to convert a sequence of characters to a string. prin1-to-string, princ-to-string, write-to-string, or format (with a first argument of nil) can be used to get a string representation of a number or any other object.  File: gcl.info, Node: string-upcase, Next: string-trim, Prev: string, Up: Strings Dictionary 16.2.8 string-upcase, string-downcase, string-capitalize, --------------------------------------------------------- nstring-upcase, nstring-downcase, nstring-capitalize ---------------------------------------------------- [Function] 'string-upcase' string &key start end => cased-string 'string-downcase' string &key start end => cased-string 'string-capitalize' string &key start end => cased-string 'nstring-upcase' string &key start end => string 'nstring-downcase' string &key start end => string 'nstring-capitalize' string &key start end => string Arguments and Values:: ...................... string--a string designator. For nstring-upcase, nstring-downcase, and nstring-capitalize, the string designator must be a string. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. cased-string--a string. Description:: ............. string-upcase, string-downcase, string-capitalize, nstring-upcase, nstring-downcase, nstring-capitalize change the case of the subsequence of string bounded by start and end as follows: string-upcase string-upcase returns a string just like string with all lowercase characters replaced by the corresponding uppercase characters. More precisely, each character of the result string is produced by applying the function char-upcase to the corresponding character of string. string-downcase string-downcase is like string-upcase except that all uppercase characters are replaced by the corresponding lowercase characters (using char-downcase). string-capitalize string-capitalize produces a copy of string such that, for every word in the copy, the first character of the "word," if it has case, is uppercase and any other characters with case in the word are lowercase. For the purposes of string-capitalize, a "word" is defined to be a consecutive subsequence consisting of alphanumeric characters, delimited at each end either by a non-alphanumeric character or by an end of the string. nstring-upcase, nstring-downcase, nstring-capitalize nstring-upcase, nstring-downcase, and nstring-capitalize are identical to string-upcase, string-downcase, and string-capitalize respectively except that they modify string. For string-upcase, string-downcase, and string-capitalize, string is not modified. However, if no characters in string require conversion, the result may be either string or a copy of it, at the implementation's discretion. Examples:: .......... (string-upcase "abcde") => "ABCDE" (string-upcase "Dr. Livingston, I presume?") => "DR. LIVINGSTON, I PRESUME?" (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10) => "Dr. LiVINGston, I presume?" (string-downcase "Dr. Livingston, I presume?") => "dr. livingston, i presume?" (string-capitalize "elm 13c arthur;fig don't") => "Elm 13c Arthur;Fig Don'T" (string-capitalize " hello ") => " Hello " (string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") => "Occluded Casements Forestall Inadvertent Defenestration" (string-capitalize 'kludgy-hash-search) => "Kludgy-Hash-Search" (string-capitalize "DON'T!") => "Don'T!" ;not "Don't!" (string-capitalize "pipe 13a, foo16c") => "Pipe 13a, Foo16c" (setq str (copy-seq "0123ABCD890a")) => "0123ABCD890a" (nstring-downcase str :start 5 :end 7) => "0123AbcD890a" str => "0123AbcD890a" Side Effects:: .............. nstring-upcase, nstring-downcase, and nstring-capitalize modify string as appropriate rather than constructing a new string. See Also:: .......... *note char-upcase:: , char-downcase Notes:: ....... The result is always of the same length as string.  File: gcl.info, Node: string-trim, Next: string=, Prev: string-upcase, Up: Strings Dictionary 16.2.9 string-trim, string-left-trim, string-right-trim [Function] ------------------------------------------------------------------ 'string-trim' character-bag string => trimmed-string 'string-left-trim' character-bag string => trimmed-string 'string-right-trim' character-bag string => trimmed-string Arguments and Values:: ...................... character-bag--a sequence containing characters. string--a string designator. trimmed-string--a string. Description:: ............. string-trim returns a substring of string, with all characters in character-bag stripped off the beginning and end. string-left-trim is similar but strips characters off only the beginning; string-right-trim strips off only the end. If no characters need to be trimmed from the string, then either string itself or a copy of it may be returned, at the discretion of the implementation. All of these functions observe the fill pointer. Examples:: .......... (string-trim "abc" "abcaakaaakabcaaa") => "kaaak" (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans ") => "garbanzo beans" (string-trim " (*)" " ( *three (silly) words* ) ") => "three (silly) words" (string-left-trim "abc" "labcabcabc") => "labcabcabc" (string-left-trim " (*)" " ( *three (silly) words* ) ") => "three (silly) words* ) " (string-right-trim " (*)" " ( *three (silly) words* ) ") => " ( *three (silly) words" Affected By:: ............. The implementation.  File: gcl.info, Node: string=, Next: stringp, Prev: string-trim, Up: Strings Dictionary 16.2.10 string=, string/=, string<, string>, string<=, string>=, ---------------------------------------------------------------- string-equal, string-not-equal, string-lessp, --------------------------------------------- string-greaterp, string-not-greaterp, string-not-lessp ------------------------------------------------------ [Function] 'string=' string1 string2 &key start1 end1 start2 end2 => generalized-boolean 'string/=' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string<' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string>' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string<=' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string>=' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string-equal' string1 string2 &key start1 end1 start2 end2 => generalized-boolean 'string-not-equal' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string-lessp' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string-greaterp' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string-not-greaterp' string1 string2 &key start1 end1 start2 end2 => mismatch-index 'string-not-lessp' string1 string2 &key start1 end1 start2 end2 => mismatch-index Arguments and Values:: ...................... string1--a string designator. string2--a string designator. start1, end1--bounding index designators of string1. The defaults for start and end are 0 and nil, respectively. start2, end2--bounding index designators of string2. The defaults for start and end are 0 and nil, respectively. generalized-boolean--a generalized boolean. mismatch-index--a bounding index of string1, or nil. Description:: ............. These functions perform lexicographic comparisons on string1 and string2. string= and string-equal are called equality functions; the others are called inequality functions. The comparison operations these functions perform are restricted to the subsequence of string1 bounded by start1 and end1 and to the subsequence of string2 bounded by start2 and end2. A string a is equal to a string b if it contains the same number of characters, and the corresponding characters are the same under char= or char-equal, as appropriate. A string a is less than a string b if in the first position in which they differ the character of a is less than the corresponding character of b according to char< or char-lessp as appropriate, or if string a is a proper prefix of string b (of shorter length and matching in all the characters of a). The equality functions return a generalized boolean that is true if the strings are equal, or false otherwise. The inequality functions return a mismatch-index that is true if the strings are not equal, or false otherwise. When the mismatch-index is true, it is an integer representing the first character position at which the two substrings differ, as an offset from the beginning of string1. The comparison has one of the following results: string= string= is true if the supplied substrings are of the same length and contain the same characters in corresponding positions; otherwise it is false. string/= string/= is true if the supplied substrings are different; otherwise it is false. string-equal string-equal is just like string= except that differences in case are ignored; two characters are considered to be the same if char-equal is true of them. string< string< is true if substring1 is less than substring2; otherwise it is false. string> string> is true if substring1 is greater than substring2; otherwise it is false. string-lessp, string-greaterp string-lessp and string-greaterp are exactly like string< and string>, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if char-lessp were used instead of char< for comparing characters. string<= string<= is true if substring1 is less than or equal to substring2; otherwise it is false. string>= string>= is true if substring1 is greater than or equal to substring2; otherwise it is false. string-not-greaterp, string-not-lessp string-not-greaterp and string-not-lessp are exactly like string<= and string>=, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if char-lessp were used instead of char< for comparing characters. Examples:: .......... (string= "foo" "foo") => true (string= "foo" "Foo") => false (string= "foo" "bar") => false (string= "together" "frog" :start1 1 :end1 3 :start2 2) => true (string-equal "foo" "Foo") => true (string= "abcd" "01234abcd9012" :start2 5 :end2 9) => true (string< "aaaa" "aaab") => 3 (string>= "aaaaa" "aaaa") => 4 (string-not-greaterp "Abcde" "abcdE") => 5 (string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7 :start2 2 :end2 6) => 6 (string-not-equal "AAAA" "aaaA") => false See Also:: .......... *note char=:: Notes:: ....... equal calls string= if applied to two strings.  File: gcl.info, Node: stringp, Next: make-string, Prev: string=, Up: Strings Dictionary 16.2.11 stringp [Function] -------------------------- 'stringp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type string; otherwise, returns false. Examples:: .......... (stringp "aaaaaa") => true (stringp #\a) => false See Also:: .......... *note typep:: , string (type) Notes:: ....... (stringp object) == (typep object 'string)  File: gcl.info, Node: make-string, Prev: stringp, Up: Strings Dictionary 16.2.12 make-string [Function] ------------------------------ 'make-string' size &key initial-element element-type => string Arguments and Values:: ...................... size--a valid array dimension. initial-element--a character. The default is implementation-dependent. element-type--a type specifier. The default is character. string--a simple string. Description:: ............. make-string returns a simple string of length size whose elements have been initialized to initial-element. The element-type names the type of the elements of the string; a string is constructed of the most specialized type that can accommodate elements of the given type. Examples:: .......... (make-string 10 :initial-element #\5) => "5555555555" (length (make-string 10)) => 10 Affected By:: ............. The implementation.  File: gcl.info, Node: Sequences, Next: Hash Tables, Prev: Strings, Up: Top 17 Sequences ************ * Menu: * Sequence Concepts:: * Rules about Test Functions:: * Sequences Dictionary::  File: gcl.info, Node: Sequence Concepts, Next: Rules about Test Functions, Prev: Sequences, Up: Sequences 17.1 Sequence Concepts ====================== A sequence is an ordered collection of elements, implemented as either a vector or a list. Sequences can be created by the function make-sequence, as well as other functions that create objects of types that are subtypes of sequence (e.g., list, make-list, mapcar, and vector). A sequence function is a function defined by this specification or added as an extension by the implementation that operates on one or more sequences. Whenever a sequence function must construct and return a new vector, it always returns a simple vector. Similarly, any strings constructed will be simple strings. concatenate length remove copy-seq map remove-duplicates count map-into remove-if count-if merge remove-if-not count-if-not mismatch replace delete notany reverse delete-duplicates notevery search delete-if nreverse some delete-if-not nsubstitute sort elt nsubstitute-if stable-sort every nsubstitute-if-not subseq fill position substitute find position-if substitute-if find-if position-if-not substitute-if-not find-if-not reduce Figure 17-1: Standardized Sequence Functions * Menu: * General Restrictions on Parameters that must be Sequences::  File: gcl.info, Node: General Restrictions on Parameters that must be Sequences, Prev: Sequence Concepts, Up: Sequence Concepts 17.1.1 General Restrictions on Parameters that must be Sequences ---------------------------------------------------------------- In general, lists (including association lists and property lists) that are treated as sequences must be proper lists.  File: gcl.info, Node: Rules about Test Functions, Next: Sequences Dictionary, Prev: Sequence Concepts, Up: Sequences 17.2 Rules about Test Functions =============================== * Menu: * Satisfying a Two-Argument Test:: * Satisfying a One-Argument Test::  File: gcl.info, Node: Satisfying a Two-Argument Test, Next: Satisfying a One-Argument Test, Prev: Rules about Test Functions, Up: Rules about Test Functions 17.2.1 Satisfying a Two-Argument Test ------------------------------------- When an object O is being considered iteratively against each element E_i of a sequence S by an operator F listed in Figure 17-2, it is sometimes useful to control the way in which the presence of O is tested in S is tested by F. This control is offered on the basis of a function designated with either a :test or :test-not argument. adjoin nset-exclusive-or search assoc nsublis set-difference count nsubst set-exclusive-or delete nsubstitute sublis find nunion subsetp intersection position subst member pushnew substitute mismatch rassoc tree-equal nintersection remove union nset-difference remove-duplicates Figure 17-2: Operators that have Two-Argument Tests to be Satisfied The object O might not be compared directly to E_i. If a :key argument is provided, it is a designator for a function of one argument to be called with each E_i as an argument, and yielding an object Z_i to be used for comparison. (If there is no :key argument, Z_i is E_i.) The function designated by the :key argument is never called on O itself. However, if the function operates on multiple sequences (e.g., as happens in set-difference), O will be the result of calling the :key function on an element of the other sequence. A :test argument, if supplied to F, is a designator for a function of two arguments, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to satisfy the test if this :test function returns a generalized boolean representing true. A :test-not argument, if supplied to F, is designator for a function of two arguments, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to satisfy the test if this :test-not function returns a generalized boolean representing false. If neither a :test nor a :test-not argument is supplied, it is as if a :test argument of #'eql was supplied. The consequences are unspecified if both a :test and a :test-not argument are supplied in the same call to F. * Menu: * Examples of Satisfying a Two-Argument Test::  File: gcl.info, Node: Examples of Satisfying a Two-Argument Test, Prev: Satisfying a Two-Argument Test, Up: Satisfying a Two-Argument Test 17.2.1.1 Examples of Satisfying a Two-Argument Test ................................................... (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equal) => (foo bar "BAR" "foo" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equalp) => (foo bar "BAR" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string-equal) => (bar "BAR" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string=) => (BAR "BAR" "foo" "bar") (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'eql) => (1) (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'=) => (1 1.0 #C(1.0 0.0)) (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test (complement #'=)) => (1 1.0 #C(1.0 0.0)) (count 1 '((one 1) (uno 1) (two 2) (dos 2)) :key #'cadr) => 2 (count 2.0 '(1 2 3) :test #'eql :key #'float) => 1 (count "FOO" (list (make-pathname :name "FOO" :type "X") (make-pathname :name "FOO" :type "Y")) :key #'pathname-name :test #'equal) => 2  File: gcl.info, Node: Satisfying a One-Argument Test, Prev: Satisfying a Two-Argument Test, Up: Rules about Test Functions 17.2.2 Satisfying a One-Argument Test ------------------------------------- When using one of the functions in Figure 17-3, the elements E of a sequence S are filtered not on the basis of the presence or absence of an object O under a two argument predicate, as with the functions described in *note Satisfying a Two-Argument Test::, but rather on the basis of a one argument predicate. assoc-if member-if rassoc-if assoc-if-not member-if-not rassoc-if-not count-if nsubst-if remove-if count-if-not nsubst-if-not remove-if-not delete-if nsubstitute-if subst-if delete-if-not nsubstitute-if-not subst-if-not find-if position-if substitute-if find-if-not position-if-not substitute-if-not Figure 17-3: Operators that have One-Argument Tests to be Satisfied The element E_i might not be considered directly. If a :key argument is provided, it is a designator for a function of one argument to be called with each E_i as an argument, and yielding an object Z_i to be used for comparison. (If there is no :key argument, Z_i is E_i.) Functions defined in this specification and having a name that ends in "-if" accept a first argument that is a designator for a function of one argument, Z_i. An E_i is said to satisfy the test if this :test function returns a generalized boolean representing true. Functions defined in this specification and having a name that ends in "-if-not" accept a first argument that is a designator for a function of one argument, Z_i. An E_i is said to satisfy the test if this :test function returns a generalized boolean representing false. * Menu: * Examples of Satisfying a One-Argument Test::  File: gcl.info, Node: Examples of Satisfying a One-Argument Test, Prev: Satisfying a One-Argument Test, Up: Satisfying a One-Argument Test 17.2.2.1 Examples of Satisfying a One-Argument Test ................................................... (count-if #'zerop '(1 #C(0.0 0.0) 0 0.0d0 0.0s0 3)) => 4 (remove-if-not #'symbolp '(0 1 2 3 4 5 6 7 8 9 A B C D E F)) => (A B C D E F) (remove-if (complement #'symbolp) '(0 1 2 3 4 5 6 7 8 9 A B C D E F)) => (A B C D E F) (count-if #'zerop '("foo" "" "bar" "" "" "baz" "quux") :key #'length) => 3  File: gcl.info, Node: Sequences Dictionary, Prev: Rules about Test Functions, Up: Sequences 17.3 Sequences Dictionary ========================= * Menu: * sequence:: * copy-seq:: * elt:: * fill:: * make-sequence:: * subseq:: * map:: * map-into:: * reduce:: * count:: * length:: * reverse:: * sort:: * find:: * position:: * search:: * mismatch:: * replace:: * substitute:: * concatenate:: * merge:: * remove:: * remove-duplicates::  File: gcl.info, Node: sequence, Next: copy-seq, Prev: Sequences Dictionary, Up: Sequences Dictionary 17.3.1 sequence [System Class] ------------------------------ Class Precedence List:: ....................... sequence, t Description:: ............. Sequences are ordered collections of objects, called the elements of the sequence. The types vector and the type list are disjoint subtypes of type sequence, but are not necessarily an exhaustive partition of sequence. When viewing a vector as a sequence, only the active elements of that vector are considered elements of the sequence; that is, sequence operations respect the fill pointer when given sequences represented as vectors.  File: gcl.info, Node: copy-seq, Next: elt, Prev: sequence, Up: Sequences Dictionary 17.3.2 copy-seq [Function] -------------------------- 'copy-seq' sequence => copied-sequence Arguments and Values:: ...................... sequence--a proper sequence. copied-sequence--a proper sequence. Description:: ............. Creates a copy of sequence. The elements of the new sequence are the same as the corresponding elements of the given sequence. If sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list. Examples:: .......... (setq str "a string") => "a string" (equalp str (copy-seq str)) => true (eql str (copy-seq str)) => false Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note copy-list:: Notes:: ....... From a functional standpoint, (copy-seq x) == (subseq x 0) However, the programmer intent is typically very different in these two cases.  File: gcl.info, Node: elt, Next: fill, Prev: copy-seq, Up: Sequences Dictionary 17.3.3 elt [Accessor] --------------------- 'elt' sequence index => object (setf (' elt' sequence index) new-object) Arguments and Values:: ...................... sequence--a proper sequence. index--a valid sequence index for sequence. object--an object. new-object--an object. Description:: ............. Accesses the element of sequence specified by index. Examples:: .......... (setq str (copy-seq "0123456789")) => "0123456789" (elt str 6) => #\6 (setf (elt str 0) #\#) => #\# str => "#123456789" Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if index is not a valid sequence index for sequence. See Also:: .......... *note aref:: , *note nth:: , *note Compiler Terminology:: Notes:: ....... aref may be used to access vector elements that are beyond the vector's fill pointer.  File: gcl.info, Node: fill, Next: make-sequence, Prev: elt, Up: Sequences Dictionary 17.3.4 fill [Function] ---------------------- 'fill' sequence item &key start end => sequence Arguments and Values:: ...................... sequence--a proper sequence. item--a sequence. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. Description:: ............. Replaces the elements of sequence bounded by start and end with item. Examples:: .......... (fill (list 0 1 2 3 4 5) '(444)) => ((444) (444) (444) (444) (444) (444)) (fill (copy-seq "01234") #\e :start 3) => "012ee" (setq x (vector 'a 'b 'c 'd 'e)) => #(A B C D E) (fill x 'z :start 1 :end 3) => #(A Z Z D E) x => #(A Z Z D E) (fill x 'p) => #(P P P P P) x => #(P P P P P) Side Effects:: .............. Sequence is destructively modified. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil. See Also:: .......... *note replace:: , nsubstitute Notes:: ....... (fill sequence item) == (nsubstitute-if item (constantly t) sequence)  File: gcl.info, Node: make-sequence, Next: subseq, Prev: fill, Up: Sequences Dictionary 17.3.5 make-sequence [Function] ------------------------------- 'make-sequence' result-type size &key initial-element => sequence Arguments and Values:: ...................... result-type--a sequence type specifier. size--a non-negative integer. initial-element--an object. The default is implementation-dependent. sequence--a proper sequence. Description:: ............. Returns a sequence of the type result-type and of length size, each of the elements of which has been initialized to initial-element. If the result-type is a subtype of list, the result will be a list. If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled. Examples:: .......... (make-sequence 'list 0) => () (make-sequence 'string 26 :initial-element #\.) => ".........................." (make-sequence '(vector double-float) 2 :initial-element 1d0) => #(1.0d0 1.0d0) (make-sequence '(vector * 2) 3) should signal an error (make-sequence '(vector * 4) 3) should signal an error Affected By:: ............. The implementation. Exceptional Situations:: ........................ The consequences are unspecified if initial-element is not an object which can be stored in the resulting sequence. An error of type type-error must be signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector. An error of type type-error should be signaled if result-type specifies the number of elements and size is different from that number. See Also:: .......... *note make-array:: , *note make-list:: Notes:: ....... (make-sequence 'string 5) == (make-string 5)  File: gcl.info, Node: subseq, Next: map, Prev: make-sequence, Up: Sequences Dictionary 17.3.6 subseq [Accessor] ------------------------ 'subseq' sequence start &optional end => subsequence (setf (' subseq' sequence start &optional end) new-subsequence) Arguments and Values:: ...................... sequence--a proper sequence. start, end--bounding index designators of sequence. The default for end is nil. subsequence--a proper sequence. new-subsequence--a proper sequence. Description:: ............. subseq creates a sequence that is a copy of the subsequence of sequence bounded by start and end. Start specifies an offset into the original sequence and marks the beginning position of the subsequence. end marks the position following the last element of the subsequence. subseq always allocates a new sequence for a result; it never shares storage with an old sequence. The result subsequence is always of the same type as sequence. If sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list. setf may be used with subseq to destructively replace elements of a subsequence with elements taken from a sequence of new values. If the subsequence and the new sequence are not of equal length, the shorter length determines the number of elements that are replaced. The remaining elements at the end of the longer sequence are not modified in the operation. Examples:: .......... (setq str "012345") => "012345" (subseq str 2) => "2345" (subseq str 3 5) => "34" (setf (subseq str 4) "abc") => "abc" str => "0123ab" (setf (subseq str 0 2) "A") => "A" str => "A123ab" Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should be prepared to signal an error of type type-error if new-subsequence is not a proper sequence. See Also:: .......... *note replace::  File: gcl.info, Node: map, Next: map-into, Prev: subseq, Up: Sequences Dictionary 17.3.7 map [Function] --------------------- 'map' result-type function &rest sequences^+ => result Arguments and Values:: ...................... result-type - a sequence type specifier, or nil. function--a function designator. function must take as many arguments as there are sequences. sequence--a proper sequence. result--if result-type is a type specifier other than nil, then a sequence of the type it denotes; otherwise (if the result-type is nil), nil. Description:: ............. Applies function to successive sets of arguments in which one argument is obtained from each sequence. The function is called first on all the elements with index 0, then on all those with index 1, and so on. The result-type specifies the type of the resulting sequence. map returns nil if result-type is nil. Otherwise, map returns a sequence such that element j is the result of applying function to element j of each of the sequences. The result sequence is as long as the shortest of the sequences. The consequences are undefined if the result of applying function to the successive elements of the sequences cannot be contained in a sequence of the type given by result-type. If the result-type is a subtype of list, the result will be a list. If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled. Examples:: .......... (map 'string #'(lambda (x y) (char "01234567890ABCDEF" (mod (+ x y) 16))) '(1 2 3 4) '(10 9 8 7)) => "AAAA" (setq seq '("lower" "UPPER" "" "123")) => ("lower" "UPPER" "" "123") (map nil #'nstring-upcase seq) => NIL seq => ("LOWER" "UPPER" "" "123") (map 'list #'- '(1 2 3 4)) => (-1 -2 -3 -4) (map 'string #'(lambda (x) (if (oddp x) #\1 #\0)) '(1 2 3 4)) => "1010" (map '(vector * 4) #'cons "abc" "de") should signal an error Exceptional Situations:: ........................ An error of type type-error must be signaled if the result-type is not a recognizable subtype of list, not a recognizable subtype of vector, and not nil. Should be prepared to signal an error of type type-error if any sequence is not a proper sequence. An error of type type-error should be signaled if result-type specifies the number of elements and the minimum length of the sequences is different from that number. See Also:: .......... *note Traversal Rules and Side Effects::  File: gcl.info, Node: map-into, Next: reduce, Prev: map, Up: Sequences Dictionary 17.3.8 map-into [Function] -------------------------- 'map-into' result-sequence function &rest sequences => result-sequence Arguments and Values:: ...................... result-sequence--a proper sequence. function--a designator for a function of as many arguments as there are sequences. sequence--a proper sequence. Description:: ............. Destructively modifies result-sequence to contain the results of applying function to each element in the argument sequences in turn. result-sequence and each element of sequences can each be either a list or a vector. If result-sequence and each element of sequences are not all the same length, the iteration terminates when the shortest sequence (of any of the sequences or the result-sequence) is exhausted. If result-sequence is a vector with a fill pointer, the fill pointer is ignored when deciding how many iterations to perform, and afterwards the fill pointer is set to the number of times function was applied. If result-sequence is longer than the shortest element of sequences, extra elements at the end of result-sequence are left unchanged. If result-sequence is nil, map-into immediately returns nil, since nil is a sequence of length zero. If function has side effects, it can count on being called first on all of the elements with index 0, then on all of those numbered 1, and so on. Examples:: .......... (setq a (list 1 2 3 4) b (list 10 10 10 10)) => (10 10 10 10) (map-into a #'+ a b) => (11 12 13 14) a => (11 12 13 14) b => (10 10 10 10) (setq k '(one two three)) => (ONE TWO THREE) (map-into a #'cons k a) => ((ONE . 11) (TWO . 12) (THREE . 13) 14) (map-into a #'gensym) => (#:G9090 #:G9091 #:G9092 #:G9093) a => (#:G9090 #:G9091 #:G9092 #:G9093) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if result-sequence is not a proper sequence. Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Notes:: ....... map-into differs from map in that it modifies an existing sequence rather than creating a new one. In addition, map-into can be called with only two arguments, while map requires at least three arguments. map-into could be defined by: (defun map-into (result-sequence function &rest sequences) (loop for index below (apply #'min (length result-sequence) (mapcar #'length sequences)) do (setf (elt result-sequence index) (apply function (mapcar #'(lambda (seq) (elt seq index)) sequences)))) result-sequence) gcl-2.6.14/info/control.texi0000755000175000017500000042641414360276512014317 0ustar cammcamm@c Copyright (c) 1994 William Schelter. @c Copyright (c) 1990 The Regents of the University of California. @c All rights reserved. @c @c Permission is hereby granted, without written agreement and without @c license or royalty fees, to use, copy, modify, and distribute this @c documentation for any purpose, provided that the above copyright @c notice and the following two paragraphs appear in all copies. @c @c IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY @c FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES @c ARISING OUT OF THE USE OF THIS DOCUMENTATION, EVEN IF THE UNIVERSITY OF @c CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @c @c THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, @c INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY @c AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS @c ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO @c PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. @node Control, , Widgets, Top @chapter Control @menu * after:: * bind:: * destroy:: * tk-dialog:: * exit:: * focus:: * grab:: * tk-listbox-single-select:: * lower:: * tk-menu-bar:: * option:: * options:: * pack-old:: * pack:: * place:: * raise:: * selection:: * send:: * tk:: * tkerror:: * tkvars:: * tkwait:: * update:: * winfo:: * wm:: @end menu @node after, bind, Control, Control @section after @c @cartouche after - Execute a command after a time delay @unnumberedsubsec Synopsis @b{after }@i{ms }@r{?}@i{arg1 arg2 arg3 ...}? @c @end cartouche @unnumberedsubsec Description This command is used to delay execution of the program or to execute a command in background after a delay. The @i{ms} argument gives a time in milliseconds. If @i{ms}@r{ is the only argument to }@b{after} then the command sleeps for @i{ms} milliseconds and returns. While the command is sleeping the application does not respond to X events and other events. If additional arguments are present after @i{ms}, then a Tcl command is formed by concatenating all the additional arguments in the same fashion as the @b{concat} command. @b{After} returns immediately but arranges for the command to be executed @i{ms} milliseconds later in background. The command will be executed at global level (outside the context of any Tcl procedure). If an error occurs while executing the delayed command then the @b{tkerror} mechanism is used to report the error. The @b{after} command always returns an empty string. @xref{tkerror}. @unnumberedsubsec Keywords delay, sleep, time @node bind, destroy, after, Control @section bind @c @cartouche bind \- Arrange for X events to invoke Tcl commands @unnumberedsubsec Synopsis @*@w{@b{bind}@i{ windowSpec}}@* @*@w{@b{bind}@i{ windowSpec sequence}}@* @*@w{@b{bind}@i{ windowSpec sequence command}}@* @b{bind}@i{ windowSpec sequence }@b{+}@i{command} @c @end cartouche @unnumberedsubsec Description If all three arguments are specified, @b{bind} will arrange for @i{command} (a Tcl command) to be executed whenever the sequence of events given by @i{sequence}@r{ occurs in the window(s) identified by }@i{windowSpec}. If @i{command} is prefixed with a ``+'', then it is appended to any existing binding for @i{sequence}@r{; otherwise }@i{command} replaces the existing binding, if any. If @i{command} is an empty string then the current binding for @i{sequence} is destroyed, leaving @i{sequence} unbound. In all of the cases where a @i{command}@r{ argument is provided, }@b{bind} returns an empty string. If @i{sequence}@r{ is specified without a }@i{command}, then the command currently bound to @i{sequence} is returned, or an empty string if there is no binding for @i{sequence}. If neither @i{sequence}@r{ nor }@i{command} is specified, then the return value is a list whose elements are all the sequences for which there exist bindings for @i{windowSpec}. The @i{windowSpec} argument selects which window(s) the binding applies to. It may have one of three forms. If @i{windowSpec} is the path name for a window, then the binding applies to that particular window. If @i{windowSpec} is the name of a class of widgets, then the binding applies to all widgets in that class. Lastly, @i{windowSpec}@r{ may have the value }@b{all}, in which case the binding applies to all windows in the application. The @i{sequence} argument specifies a sequence of one or more event patterns, with optional white space between the patterns. Each event pattern may take either of two forms. In the simplest case it is a single printing ASCII character, such as @b{a}@r{ or }@b{[}. The character may not be a space character or the character @b{<}. This form of pattern matches a @b{KeyPress} event for the particular character. The second form of pattern is longer but more general. It has the following syntax: @example @b{<}@i{modifier-modifier-type-detail}@b{>} @end example The entire event pattern is surrounded by angle brackets. Inside the angle brackets are zero or more modifiers, an event type, and an extra piece of information (@i{detail}) identifying a particular button or keysym. Any of the fields may be omitted, as long as at least one of @i{type}@r{ and }@i{detail} is present. The fields must be separated by white space or dashes. Modifiers may consist of any of the values in the following list: @example Control Any Shift Double Lock Triple Button1, B1 Mod1, M1, Meta, M Button2, B2 Mod2, M2, Alt Button3, B3 Mod3, M3 Button4, B4 Mod4, M4 Button5, B5 Mod5, M5 @end example Where more than one value is listed, separated by commas, the values are equivalent. All of the modifiers except @b{Any}, @b{Double}@r{, and }@b{Triple} have the obvious X meanings. For example, @b{Button1} requires that button 1 be depressed when the event occurs. Under normal conditions the button and modifier state at the time of the event must match exactly those specified in the @b{bind} command. If no modifiers are specified, then events will match only if no modifiers are present. If the @b{Any} modifier is specified, then additional modifiers may be present besides those specified explicitly. For example, if button 1 is pressed while the shift and control keys are down, the specifier @b{} will match the event, but the specifier @b{} will not. The @b{Double}@r{ and }@b{Triple} modifiers are a convenience for specifying double mouse clicks and other repeated events. They cause a particular event pattern to be repeated 2 or 3 times, and also place a time and space requirement on the sequence: for a sequence of events to match a @b{Double} or @b{Triple} pattern, all of the events must occur close together in time and without substantial mouse motion in between. For example, @b{} is equivalent to @b{} with the extra time and space requirement. The @i{type} field may be any of the standard X event types, with a few extra abbreviations. Below is a list of all the valid types; where two name appear together, they are synonyms. @example ButtonPress, Button Expose Leave ButtonRelease FocusIn Map Circulate FocusOut Property CirculateRequest Gravity Reparent Colormap Keymap ResizeRequest Configure KeyPress, Key Unmap ConfigureRequest KeyRelease Visibility Destroy MapRequest Enter Motion @end example The last part of a long event specification is @i{detail}. In the case of a @b{ButtonPress}@r{ or }@b{ButtonRelease} event, it is the number of a button (1-5). If a button number is given, then only an event on that particular button will match; if no button number is given, then an event on any button will match. Note: giving a specific button number is different than specifying a button modifier; in the first case, it refers to a button being pressed or released, while in the second it refers to some other button that is already depressed when the matching event occurs. If a button number is given then @i{type} may be omitted: if will default to @b{ButtonPress}@r{. For example, the specifier }@b{<1>} is equivalent to @b{}. If the event type is @b{KeyPress}@r{ or }@b{KeyRelease}, then @i{detail} may be specified in the form of an X keysym. Keysyms are textual specifications for particular keys on the keyboard; they include all the alphanumeric ASCII characters (e.g. ``a'' is the keysym for the ASCII character ``a''), plus descriptions for non-alphanumeric characters (``comma'' is the keysym for the comma character), plus descriptions for all the non-ASCII keys on the keyboard (``Shift_L'' is the keysm for the left shift key, and ``F1'' is the keysym for the F1 function key, if it exists). The complete list of keysyms is not presented here; it should be available in other X documentation. If necessary, you can use the @b{%K} notation described below to print out the keysym name for an arbitrary key. If a keysym @i{detail} is given, then the @i{type}@r{ field may be omitted; it will default to }@b{KeyPress}. For example, @b{} is equivalent to @b{}@r{. If a keysym }@i{detail} is specified then the @b{Shift} modifier need not be specified and will be ignored if specified: each keysym already implies a particular state for the shift key. The @i{command}@r{ argument to }@b{bind} is a Tcl command string, which will be executed whenever the given event sequence occurs. @i{Command} will be executed in the same interpreter that the @b{bind}@r{ command was executed in. If }@i{command} contains any @b{%} characters, then the command string will not be executed directly. Instead, a new command string will be generated by replacing each @b{%}, and the character following it, with information from the current event. The replacement depends on the character following the @b{%}, as defined in the list below. Unless otherwise indicated, the replacement string is the decimal value of the given field from the current event. Some of the substitutions are only valid for certain types of events; if they are used for other types of events the value substituted is undefined. @table @asis @item @b{%%} Replaced with a single percent. @item @b{|%#|} The number of the last client request processed by the server (the @i{serial} field from the event). Valid for all event types. @item @b{|%a|} The @i{above} field from the event. Valid only for @b{ConfigureNotify} events. @item @b{|%b|} The number of the button that was pressed or released. Valid only for @b{ButtonPress}@r{ and }@b{ButtonRelease} events. @item @b{|%c|} The @i{count}@r{ field from the event. Valid only for }@b{Expose}, @b{GraphicsExpose}@r{, and }@b{MappingNotify} events. @item @b{|%d|} The @i{detail}@r{ field from the event. The }@b{|%d|} is replaced by a string identifying the detail. For @b{EnterNotify}, @b{LeaveNotify}@r{, }@b{FocusIn}@r{, and }@b{FocusOut} events, the string will be one of the following: @example NotifyAncestor NotifyNonlinearVirtual NotifyDetailNone NotifyPointer NotifyInferior NotifyPointerRoot NotifyNonlinear NotifyVirtual @end example For @b{ConfigureRequest} events, the substituted string will be one of the following: @example Above Opposite Below TopIf BottomIf @end example For events other than these, the substituted string is undefined. .RE @item @b{|%f|} The @i{focus}@r{ field from the event (}@b{0}@r{ or }@b{1}). Valid only for @b{EnterNotify}@r{ and }@b{LeaveNotify} events. @item @b{|%h|} The @i{height}@r{ field from the event. Valid only for }@b{Configure}, @b{ConfigureNotify}@r{, }@b{Expose}@r{, }@b{GraphicsExpose}, and @b{ResizeRequest} events. @item @b{|%k|} The @i{keycode}@r{ field from the event. Valid only for }@b{KeyPress} and @b{KeyRelease} events. @item @b{|%m|} The @i{mode} field from the event. The substituted string is one of @b{NotifyNormal}@r{, }@b{NotifyGrab}@r{, }@b{NotifyUngrab}, or @b{NotifyWhileGrabbed}@r{. Valid only for }@b{EnterWindow}, @b{FocusIn}@r{, }@b{FocusOut}@r{, and }@b{LeaveWindow} events. @item @b{|%o|} The @i{override_redirect} field from the event. Valid only for @b{CreateNotify}@r{, }@b{MapNotify}@r{, }@b{ReparentNotify}, and @b{ConfigureNotify} events. @item @b{|%p|} The @i{place} field from the event, substituted as one of the strings @b{PlaceOnTop}@r{ or }@b{PlaceOnBottom}. Valid only for @b{CirculateNotify}@r{ and }@b{CirculateRequest} events. @item @b{|%s|} The @i{state}@r{ field from the event. For }@b{ButtonPress}, @b{ButtonRelease}@r{, }@b{EnterNotify}@r{, }@b{KeyPress}@r{, }@b{KeyRelease}, @b{LeaveNotify}@r{, and }@b{MotionNotify} events, a decimal string is substituted. For @b{VisibilityNotify}, one of the strings @b{VisibilityUnobscured}@r{, }@b{VisibilityPartiallyObscured}, and @b{VisibilityFullyObscured} is substituted. @item @b{|%t|} The @i{time} field from the event. Valid only for events that contain a @i{time} field. @item @b{|%v|} The @i{value_mask} field from the event. Valid only for @b{ConfigureRequest} events. @item @b{|%w|} The @i{width} field from the event. Valid only for @b{Configure}@r{, }@b{ConfigureRequest}@r{, }@b{Expose}, @b{GraphicsExpose}@r{, and }@b{ResizeRequest} events. @item @b{|%x|} The @i{x} field from the event. Valid only for events containing an @i{x} field. @item @b{|%y|} The @i{y} field from the event. Valid only for events containing a @i{y} field. @item @b{%A} Substitutes the ASCII character corresponding to the event, or the empty string if the event doesn't correspond to an ASCII character (e.g. the shift key was pressed). @b{XLookupString} does all the work of translating from the event to an ASCII character. Valid only for @b{KeyPress}@r{ and }@b{KeyRelease} events. @item @b{%B} The @i{border_width} field from the event. Valid only for @b{ConfigureNotify}@r{ and }@b{CreateWindow} events. @item @b{%D} The @i{display} field from the event. Valid for all event types. @item @b{%E} The @i{send_event} field from the event. Valid for all event types. @item @b{%K} The keysym corresponding to the event, substituted as a textual string. Valid only for @b{KeyPress}@r{ and }@b{KeyRelease} events. @item @b{%N} The keysym corresponding to the event, substituted as a decimal number. Valid only for @b{KeyPress}@r{ and }@b{KeyRelease} events. @item @b{%R} The @i{root} window identifier from the event. Valid only for events containing a @i{root} field. @item @b{%S} The @i{subwindow} window identifier from the event. Valid only for events containing a @i{subwindow} field. @item @b{%T} The @i{type} field from the event. Valid for all event types. @item @b{%W} The path name of the window to which the event was reported (the @i{window} field from the event). Valid for all event types. @item @b{%X} The @i{x_root} field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding x-coordinate in the virtual root. Valid only for @b{ButtonPress}@r{, }@b{ButtonRelease}@r{, }@b{KeyPress}@r{, }@b{KeyRelease}, and @b{MotionNotify} events. @item @b{%Y} The @i{y_root} field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding y-coordinate in the virtual root. Valid only for @b{ButtonPress}@r{, }@b{ButtonRelease}@r{, }@b{KeyPress}@r{, }@b{KeyRelease}, and @b{MotionNotify} events. @end table If the replacement string for a %-replacement contains characters that are interpreted specially by the Tcl parser (such as backslashes or square brackets or spaces) additional backslashes are added during replacement so that the result after parsing is the original replacement string. For example, if @i{command} is @example insert %A @end example @noindent and the character typed is an open square bracket, then the command actually executed will be @example insert \e[ @end example This will cause the @b{insert} to receive the original replacement string (open square bracket) as its first argument. If the extra backslash hadn't been added, Tcl would not have been able to parse the command correctly. At most one binding will trigger for any given X event. If several bindings match the recent events, the most specific binding is chosen and its command will be executed. The following tests are applied, in order, to determine which of several matching sequences is more specific: (a) a binding whose @i{windowSpec} names a particular window is more specific than a binding for a class, which is more specific than a binding whose @i{windowSpec} is @b{all}; (b) a longer sequence (in terms of number of events matched) is more specific than a shorter sequence; (c) an event pattern that specifies a specific button or key is more specific than one that doesn't; (e) an event pattern that requires a particular modifier is more specific than one that doesn't require the modifier; (e) an event pattern specifying the @b{Any} modifier is less specific than one that doesn't. If the matching sequences contain more than one event, then tests (c)-(e) are applied in order from the most recent event to the least recent event in the sequences. If these tests fail to determine a winner, then the most recently registered sequence is the winner. If an X event does not match any of the existing bindings, then the event is ignored (an unbound event is not considered to be an error). When a @i{sequence}@r{ specified in a }@b{bind} command contains more than one event pattern, then its command is executed whenever the recent events (leading up to and including the current event) match the given sequence. This means, for example, that if button 1 is clicked repeatedly the sequence @b{} will match each button press but the first. If extraneous events that would prevent a match occur in the middle of an event sequence then the extraneous events are ignored unless they are @b{KeyPress}@r{ or }@b{ButtonPress} events. For example, @b{} will match a sequence of presses of button 1, even though there will be @b{ButtonRelease} events (and possibly @b{MotionNotify} events) between the @b{ButtonPress} events. Furthermore, a @b{KeyPress} event may be preceded by any number of other @b{KeyPress} events for modifier keys without the modifier keys preventing a match. For example, the event sequence @b{aB} will match a press of the @b{a}@r{ key, a release of the }@b{a}@r{ key, a press of the }@b{Shift} key, and a press of the @b{b}@r{ key: the press of }@b{Shift} is ignored because it is a modifier key. Finally, if several @b{MotionNotify} events occur in a row, only the last one is used for purposes of matching binding sequences. If an error occurs in executing the command for a binding then the @b{tkerror} mechanism is used to report the error. The command will be executed at global level (outside the context of any Tcl procedure). @xref{tkerror}. @unnumberedsubsec Keywords form, manual @node destroy, tk-dialog, bind, Control @section destroy @c @cartouche destroy \- Destroy one or more windows @unnumberedsubsec Synopsis @b{destroy }@r{?}@i{window window ...}? @c @end cartouche @unnumberedsubsec Description This command deletes the windows given by the @i{window} arguments, plus all of their descendants. If a @i{window} ``.'' is deleted then the entire application will be destroyed. The @i{window}s are destroyed in order, and if an error occurs in destroying a window the command aborts without destroying the remaining windows. @unnumberedsubsec Keywords application, destroy, window @node tk-dialog, exit, destroy, Control @section tk-dialog @c @cartouche tk-dialog \- Create modal dialog and wait for response @unnumberedsubsec Synopsis @b{tk-dialog }@i{window title text bitmap default string string ...} @c @end cartouche @unnumberedsubsec Description This procedure is part of the Tk script library. Its arguments describe a dialog box: @table @asis @item @i{window} Name of top-level window to use for dialog. Any existing window by this name is destroyed. @item @i{title} Text to appear in the window manager's title bar for the dialog. @item @i{text} Message to appear in the top portion of the dialog box. @item @i{bitmap} If non-empty, specifies a bitmap to display in the top portion of the dialog, to the left of the text. If this is an empty string then no bitmap is displayed in the dialog. @item @i{default} If this is an integer greater than or equal to zero, then it gives the index of the button that is to be the default button for the dialog (0 for the leftmost button, and so on). If less than zero or an empty string then there won't be any default button. @item @i{string} There will be one button for each of these arguments. Each @i{string} specifies text to display in a button, in order from left to right. After creating a dialog box, @b{tk-dialog} waits for the user to select one of the buttons either by clicking on the button with the mouse or by typing return to invoke the default button (if any). Then it returns the index of the selected button: 0 for the leftmost button, 1 for the button next to it, and so on. While waiting for the user to respond, @b{tk-dialog} sets a local grab. This prevents the user from interacting with the application in any way except to invoke the dialog box. @end table @unnumberedsubsec Keywords bitmap, dialog, modal @node exit, focus, tk-dialog, Control @section exit @c @cartouche exit \- Exit the process @unnumberedsubsec Synopsis @b{exit }@r{?}@i{returnCode}? @c @end cartouche @unnumberedsubsec Description Terminate the process, returning @i{returnCode} (an integer) to the system as the exit status. If @i{returnCode} isn't specified then it defaults to 0. This command replaces the Tcl command by the same name. It is identical to Tcl's @b{exit} command except that before exiting it destroys all the windows managed by the process. This allows various cleanup operations to be performed, such as removing application names from the global registry of applications. @unnumberedsubsec Keywords exit, process @node focus, grab, exit, Control @section focus @c @cartouche focus \- Direct keyboard events to a particular window @unnumberedsubsec Synopsis @*@w{@b{focus}}@* @*@w{@b{focus }@i{window}}@* @b{focus }@i{option}@r{ ?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description The @b{focus} command is used to manage the Tk input focus. At any given time, one window in an application is designated as the focus window for that application; any key press or key release events directed to any window in the application will be redirected instead to the focus window. If there is no focus window for an application then keyboard events are discarded. Typically, windows that are prepared to deal with the focus (e.g. entries and other widgets that display editable text) will claim the focus when mouse button 1 is pressed in them. When an application is created its main window is initially given the focus. The @b{focus} command can take any of the following forms: @table @asis @item @b{focus} If invoked with no arguments, @b{focus} returns the path name of the current focus window, or @b{none} if there is no focus window. @item @b{focus }@i{window} If invoked with a single argument consisting of a window's path name, @b{focus} sets the input focus to that window. The return value is an empty string. @item @b{focus :default }@r{?}@i{window}? If @i{window} is specified, it becomes the default focus window (the window that receives the focus whenever the focus window is deleted) and the command returns an empty string. If @i{window} isn't specified, the command returns the path name of the current default focus window, or @b{none} if there is no default. @i{Window}@r{ may be specified as }@b{none} to clear its existing value. The default window is initially @b{none}. @item @b{focus :none} Clears the focus window, so that keyboard input to this application will be discarded. @end table @unnumberedsubsec "Focus Events" Tk's model of the input focus is different than X's model, and the focus window set with the @b{focus} command is not usually the same as the X focus window. Tk never explicitly changes the official X focus window. It waits for the window manager to direct the X input focus to and from the application's top-level windows, and it intercepts @b{FocusIn}@r{ and }@b{FocusOut} events coming from the X server to detect these changes. All of the focus events received from X are discarded by Tk; they never reach the application. Instead, Tk generates a different stream of @b{FocusIn} and @b{FocusOut} for the application. This means that @b{FocusIn} and and @b{FocusOut} events seen by the application will not obey the conventions described in the documentation for Xlib. Tk applications receive two kinds of @b{FocusIn}@r{ and }@b{FocusOut} events, which can be distinguished by their @i{detail} fields. Events with a @i{detail}@r{ of }@b{NotifyAncestor} are directed to the current focus window when it becomes active or inactive. A window is the active focus whenever two conditions are simultaneously true: (a) the window is the focus window for its application, and (b) some top-level window in the application has received the X focus. When this happens Tk generates a @b{FocusIn} event for the focus window with detail @b{NotifyAncestor}. When a window loses the active focus (either because the window manager removed the focus from the application or because the focus window changed within the application) then it receives a @b{FocusOut} event with detail @b{NotifyAncestor}. The events described above are directed to the application's focus window regardless of which top-level window within the application has received the focus. The second kind of focus event is provided for applications that need to know which particular top-level window has the X focus. Tk generates @b{FocusIn}@r{ and }@b{FocusOut} events with detail @b{NotifyVirtual} for top-level windows whenever they receive or lose the X focus. These events are generated regardless of which window in the application has the Tk input focus. They do not imply that keystrokes will be directed to the window that receives the event; they simply indicate which top-level window is active as far as the window manager is concerned. If a top-level window is also the application's focus window, then it will receive both @b{NotifyVirtual}@r{ and }@b{NotifyAncestor} events when it receives or loses the X focus. Tk does not generate the hierarchical chains of @b{FocusIn} and @b{FocusOut} events described in the Xlib documentation (e.g. a window can get a @b{FocusIn}@r{ or }@b{FocusOut} event without all of its ancestors getting events too). Furthermore, the @i{mode} field in focus events is always @b{NotifyNormal} and the only values ever present in the @i{detail}@r{ field are }@b{NotifyAncestor}@r{ and }@b{NotifyVirtual}. @unnumberedsubsec Keywords events, focus, keyboard, top-level, window manager @node grab, tk-listbox-single-select, focus, Control @section grab @c @cartouche grab \- Confine pointer and keyboard events to a window sub-tree @unnumberedsubsec Synopsis @*@w{@b{grab }@r{?}@b{:global}@r{? }@i{window}}@* @b{grab }@i{option }@r{?arg arg }...? @c @end cartouche @unnumberedsubsec Description This command implements simple pointer and keyboard grabs for Tk. Tk's grabs are different than the grabs described in the Xlib documentation. When a grab is set for a particular window, Tk restricts all pointer events to the grab window and its descendants in Tk's window hierarchy. Whenever the pointer is within the grab window's subtree, the pointer will behave exactly the same as if there had been no grab at all and all events will be reported in the normal fashion. When the pointer is outside @i{window}'s tree, button presses and releases and mouse motion events are reported to @i{window}, and window entry and window exit events are ignored. The grab subtree ``owns'' the pointer: windows outside the grab subtree will be visible on the screen but they will be insensitive until the grab is released. The tree of windows underneath the grab window can include top-level windows, in which case all of those top-level windows and their descendants will continue to receive mouse events during the grab. Two forms of grabs are possible: local and global. A local grab affects only the grabbing application: events will be reported to other applications as if the grab had never occurred. Grabs are local by default. A global grab locks out all applications on the screen, so that only the given subtree of the grabbing application will be sensitive to pointer events (mouse button presses, mouse button releases, pointer motions, window entries, and window exits). During global grabs the window manager will not receive pointer events either. During local grabs, keyboard events (key presses and key releases) are delivered as usual: the window manager controls which application receives keyboard events, and if they are sent to any window in the grabbing application then they are redirected to the focus window. During a global grab Tk grabs the keyboard so that all keyboard events are always sent to the grabbing application. The @b{focus} command is still used to determine which window in the application receives the keyboard events. The keyboard grab is released when the grab is released. Grabs apply to particular displays. If an application has windows on multiple displays then it can establish a separate grab on each display. The grab on a particular display affects only the windows on that display. It is possible for different applications on a single display to have simultaneous local grabs, but only one application can have a global grab on a given display at once. The @b{grab} command can take any of the following forms: @table @asis @item @b{grab }@r{?}@b{:global}@r{? }@i{window} Same as @b{grab :set}, described below. @item @b{grab :current }@r{?}@i{window}? If @i{window} is specified, returns the name of the current grab window in this application for @i{window}'s display, or an empty string if there is no such window. If @i{window} is omitted, the command returns a list whose elements are all of the windows grabbed by this application for all displays, or an empty string if the application has no grabs. @item @b{grab :release }@i{window} Releases the grab on @i{window} if there is one, otherwise does nothing. Returns an empty string. @item @b{grab :set }@r{?}@b{:global}@r{? }@i{window} Sets a grab on @i{window}@r{. If }@b{:global} is specified then the grab is global, otherwise it is local. If a grab was already in effect for this application on @i{window}'s display then it is automatically released. If there is already a grab on @i{window} and it has the same global/local form as the requested grab, then the command does nothing. Returns an empty string. @item @b{grab :status }@i{window} Returns @b{none}@r{ if no grab is currently set on }@i{window}, @b{local}@r{ if a local grab is set on }@i{window}, and @b{global} if a global grab is set. @end table @unnumberedsubsec Bugs It took an incredibly complex and gross implementation to produce the simple grab effect described above. Given the current implementation, it isn't safe for applications to use the Xlib grab facilities at all except through the Tk grab procedures. If applications try to manipulate X's grab mechanisms directly, things will probably break. If a single process is managing several different Tk applications, only one of those applications can have a local grab for a given display at any given time. If the applications are in different processes, this restriction doesn't exist. @unnumberedsubsec Keywords grab, keyboard events, pointer events, window @node tk-listbox-single-select, lower, grab, Control @section tk-listbox-single-select @c @cartouche tk-listbox-single-select \- Allow only one selected element in listbox(es) @unnumberedsubsec Synopsis @b{tk-listbox-single-select }@i{arg }@r{?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description This command is a Tcl procedure provided as part of the Tk script library. It takes as arguments the path names of one or more listbox widgets, or the value @b{Listbox}. For each named widget, @b{tk-listbox-single-select} modifies the bindings of the widget so that only a single element may be selected at a time (the normal configuration allows multiple elements to be selected). If the keyword @b{Listbox}@r{ is among the }@i{window} arguments, then the class bindings for listboxes are changed so that all listboxes have the one-selection-at-a-time behavior. @unnumberedsubsec Keywords listbox, selection @node lower, tk-menu-bar, tk-listbox-single-select, Control @section lower @c @cartouche lower \- Change a window's position in the stacking order @unnumberedsubsec Synopsis @b{lower }@i{window }@r{?}@i{belowThis}? @c @end cartouche @unnumberedsubsec Description If the @i{belowThis} argument is omitted then the command lowers @i{window} so that it is below all of its siblings in the stacking order (it will be obscured by any siblings that overlap it and will not obscure any siblings). If @i{belowThis} is specified then it must be the path name of a window that is either a sibling of @i{window} or the descendant of a sibling of @i{window}. In this case the @b{lower} command will insert @i{window}@r{ into the stacking order just below }@i{belowThis} (or the ancestor of @i{belowThis}@r{ that is a sibling of }@i{window}); this could end up either raising or lowering @i{window}. @unnumberedsubsec Keywords lower, obscure, stacking order @node tk-menu-bar, option, lower, Control @section tk-menu-bar @c @cartouche tk-menu-bar, tk_bindForTraversal \- Support for menu bars @unnumberedsubsec Synopsis @b{tk-menu-bar }@i{frame }@r{?}@i{menu menu ...}? @sp 1 @b{tk_bindForTraversal }@i{arg arg ... } @c @end cartouche @unnumberedsubsec Description These two commands are Tcl procedures in the Tk script library. They provide support for menu bars. A menu bar is a frame that contains a collection of menu buttons that work together, so that the user can scan from one menu to another with the mouse: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. Menus in a menu bar can also be accessed using keyboard traversal (i.e. by typing keystrokes instead of using the mouse). In order for an application to use these procedures, it must do three things, which are described in the paragraphs below. First, each application must call @b{tk-menu-bar} to provide information about the menubar. The @i{frame} argument gives the path name of the frame that contains all of the menu buttons, and the @i{menu} arguments give path names for all of the menu buttons associated with the menu bar. Normally @i{frame}@r{ is the parent of each of the }@i{menu}'s. This need not be the case, but @i{frame} must be an ancestor of each of the @i{menu}'s in order for grabs to work correctly when the mouse is used to pull down menus. The order of the @i{menu} arguments determines the traversal order for the menu buttons. If @b{tk-menu-bar}@r{ is called without any }@i{menu} arguments, it returns a list containing the current menu buttons for @i{frame}, or an empty string if @i{frame} isn't currently set up as a menu bar. If @b{tk-menu-bar}@r{ is called with a single }@i{menu} argument consisting of an empty string, any menubar information for @i{frame} is removed; from now on the menu buttons will function independently without keyboard traversal. Only one menu bar may be defined at a time within each top-level window. The second thing an application must do is to identify the traversal characters for menu buttons and menu entries. This is done by underlining those characters using the @b{:underline} options for the widgets. The menu traversal system uses this information to traverse the menus under keyboard control (see below). The third thing that an application must do is to make sure that the input focus is always in a window that has been configured to support menu traversal. If the input focus is @b{none} then input characters will be discarded and no menu traversal will be possible. If you have no other place to set the focus, set it to the menubar widget: @b{tk-menu-bar}@r{ creates bindings for its }@i{frame} argument to support menu traversal. The Tk startup scripts configure all the Tk widget classes with bindings to support menu traversal, so menu traversal will be possible regardless of which widget has the focus. If your application defines new classes of widgets that support the input focus, then you should call @b{tk_bindForTraversal} for each of these classes. @b{Tk_bindForTraversal} takes any number of arguments, each of which is a widget path name or widget class name. It sets up bindings for all the named widgets and classes so that the menu traversal system will be invoked when appropriate keystrokes are typed in those widgets or classes. @unnumberedsubsec "Menu Traversal Bindings" Once an application has made the three arrangements described above, menu traversal will be available. At any given time, the only menus available for traversal are those associated with the top-level window containing the input focus. Menu traversal is initiated by one of the following actions: @itemize @asis{} @item [1] If is typed, then the first menu button in the list for the top-level window is posted and the first entry within that menu is selected. @item [2] If is pressed, then the menu button that has }@i{key} as its underlined character is posted and the first entry within that menu is selected. The comparison between @i{key} and the underlined characters ignores case differences. If no menu button matches @i{key} then the keystroke has no effect. @item [3] Clicking mouse button 1 on a menu button posts that menu and selects its first entry. @end itemize Once a menu has been posted, the input focus is switched to that menu and the following actions are possible: @itemize @asis{} @item [1] Typing or clicking mouse button 1 outside the menu button or its menu will abort the menu traversal. @item [2] If is pressed, then the entry in the posted menu whose underlined character is @i{key} is invoked. This causes the menu to be unposted, the entry's action to be taken, and the menu traversal to end. The comparison between @i{key} and underlined characters ignores case differences. If no menu entry matches @i{key} then the keystroke is ignored. @item [3] The arrow keys may be used to move among entries and menus. The left and right arrow keys move circularly among the available menus and the up and down arrow keys move circularly among the entries in the current menu. @item [4] If is pressed, the selected entry in the posted menu is invoked, which causes the menu to be unposted, the entry's action to be taken, and the menu traversal to end. @end itemize When a menu traversal completes, the input focus reverts to the window that contained it when the traversal started. @unnumberedsubsec Keywords keyboard traversal, menu, menu bar, post @node option, options, tk-menu-bar, Control @section option @c @cartouche option \- Add/retrieve window options to/from the option database @unnumberedsubsec Synopsis @b{option :add }@i{pattern value }@r{?}@i{priority}? @sp 1 @b{option :clear} @sp 1 @b{option :get }@i{window name class} @sp 1 @b{option :readfile }@i{fileName }@r{?}@i{priority}? @c @end cartouche @unnumberedsubsec Description The @b{option} command allows you to add entries to the Tk option database or to retrieve options from the database. The @b{add} form of the command adds a new option to the database. @i{Pattern} contains the option being specified, and consists of names and/or classes separated by asterisks or dots, in the usual X format. @i{Value} contains a text string to associate with @i{pattern}; this is the value that will be returned in calls to @b{Tk_GetOption} or by invocations of the @b{option :get}@r{ command. If }@i{priority} is specified, it indicates the priority level for this option (see below for legal values); it defaults to @b{interactive}. This command always returns an empty string. The @b{option :clear} command clears the option database. Default options (in the @b{RESOURCE_MANAGER}@r{ property or the }@b{.Xdefaults} file) will be reloaded automatically the next time an option is added to the database or removed from it. This command always returns an empty string. The @b{option :get} command returns the value of the option specified for @i{window} under @i{name}@r{ and }@i{class}. If several entries in the option database match @i{window}@r{, }@i{name}@r{, and }@i{class}, then the command returns whichever was created with highest @i{priority} level. If there are several matching entries at the same priority level, then it returns whichever entry was most recently entered into the option database. If there are no matching entries, then the empty string is returned. The @b{readfile}@r{ form of the command reads }@i{fileName}, which should have the standard format for an X resource database such as @b{.Xdefaults}, and adds all the options specified in that file to the option database. If @i{priority} is specified, it indicates the priority level at which to enter the options; @i{priority}@r{ defaults to }@b{interactive}. The @i{priority}@r{ arguments to the }@b{option} command are normally specified symbolically using one of the following values: @table @asis @item @b{widgetDefault} Level 20. Used for default values hard-coded into widgets. @item @b{startupFile} Level 40. Used for options specified in application-specific startup files. @item @b{userDefault} Level 60. Used for options specified in user-specific defaults files, such as @b{.Xdefaults}, resource databases loaded into the X server, or user-specific startup files. @item @b{interactive} Level 80. Used for options specified interactively after the application starts running. If @i{priority} isn't specified, it defaults to this level. @end table Any of the above keywords may be abbreviated. In addition, priorities may be specified numerically using integers between 0 and 100, inclusive. The numeric form is probably a bad idea except for new priority levels other than the ones given above. @unnumberedsubsec Keywords database, option, priority, retrieve @node options, pack-old, option, Control @section options @c @cartouche options \- Standard options supported by widgets @c @end cartouche @unnumberedsubsec Description This manual entry describes the common configuration options supported by widgets in the Tk toolkit. Every widget does not necessarily support every option (see the manual entries for individual widgets for a list of the standard options supported by that widget), but if a widget does support an option with one of the names listed below, then the option has exactly the effect described below. In the descriptions below, ``Name'' refers to the option's name in the option database (e.g. in .Xdefaults files). ``Class'' refers to the option's class value in the option database. ``Command-Line Switch'' refers to the switch used in widget-creation and @b{configure} widget commands to set this value. For example, if an option's command-line switch is @b{:foreground}@r{ and there exists a widget }@b{.a.b.c}, then the command @example @*@w{(.a.b.c :configure :foreground "black")} @end example @noindent may be used to specify the value @b{black} for the option in the the widget @b{.a.b.c}. Command-line switches may be abbreviated, as long as the abbreviation is unambiguous. @table @asis @item @code{@b{:activebackground}} @flushright Name=@code{"@b{activeBackground}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some action to occur. @end table @table @asis @item @code{@b{:activeborderwidth}} @flushright Name=@code{"@b{activeBorderWidth}@r{"} Class=@code{"}@b{BorderWidth}"} @end flushright @sp 1 Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above for definition of active elements. The value may have any of the forms acceptable to @b{Tk_GetPixels}. This option is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons). @end table @table @asis @item @code{@b{:activeforeground}} @flushright Name=@code{"@b{activeForeground}@r{"} Class=@code{"}@b{Background}"} @end flushright @sp 1 Specifies foreground color to use when drawing active elements. See above for definition of active elements. @end table @table @asis @item @code{@b{:anchor}} @flushright Name=@code{"@b{anchor}@r{"} Class=@code{"}@b{Anchor}"} @end flushright @sp 1 Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget. Must be one of the values @b{n}@r{, }@b{ne}@r{, }@b{e}@r{, }@b{se}, @b{s}@r{, }@b{sw}@r{, }@b{w}@r{, }@b{nw}@r{, or }@b{center}. For example, @b{nw} means display the information such that its top-left corner is at the top-left corner of the widget. @end table @table @asis @item @code{@b{:background or :bg}} @flushright Name=@code{"@b{background}@r{"} Class=@code{"}@b{Background}"} @end flushright @sp 1 Specifies the normal background color to use when displaying the widget. @end table @table @asis @item @code{@b{:bitmap}} @flushright Name=@code{"@b{bitmap}@r{"} Class=@code{"}@b{Bitmap}"} @end flushright @sp 1 Specifies a bitmap to display in the widget, in any of the forms acceptable to @b{Tk_GetBitmap}. The exact way in which the bitmap is displayed may be affected by other options such as @b{anchor}@r{ or }@b{justify}. Typically, if this option is specified then it overrides other options that specify a textual value to display in the widget; the @b{bitmap} option may be reset to an empty string to re-enable a text display. @end table @table @asis @item @code{@b{:borderwidth or :bd}} @flushright Name=@code{"@b{borderWidth}@r{"} Class=@code{"}@b{BorderWidth}"} @end flushright @sp 1 Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the widget (if such a border is being drawn; the @b{relief} option typically determines this). The value may also be used when drawing 3-D effects in the interior of the widget. The value may have any of the forms acceptable to @b{Tk_GetPixels}. @end table @table @asis @item @code{@b{:cursor}} @flushright Name=@code{"@b{cursor}@r{"} Class=@code{"}@b{Cursor}"} @end flushright @sp 1 Specifies the mouse cursor to be used for the widget. The value may have any of the forms acceptable to @b{Tk_GetCursor}. @end table @table @asis @item @code{@b{:cursorbackground}} @flushright Name=@code{"@b{cursorBackground}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). \fIThis option is obsolete and is gradually being replaced by the @b{insertBackground}@r{ option.} @end table @table @asis @item @code{@b{:cursorborderwidth}} @flushright Name=@code{"@b{cursorBorderWidth}@r{"} Class=@code{"}@b{BorderWidth}"} @end flushright @sp 1 Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to @b{Tk_GetPixels}. \fIThis option is obsolete and is gradually being replaced by the @b{insertBorderWidth}@r{ option.} @end table @table @asis @item @code{@b{:cursorofftime}} @flushright Name=@code{"@b{cursorOffTime}@r{"} Class=@code{"}@b{OffTime}"} @end flushright @sp 1 Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain ``off'' in each blink cycle. If this option is zero then the cursor doesn't blink: it is on all the time. \fIThis option is obsolete and is gradually being replaced by the @b{insertOffTime}@r{ option.} @end table @table @asis @item @code{@b{:cursorontime}} @flushright Name=@code{"@b{cursorOnTime}@r{"} Class=@code{"}@b{OnTime}"} @end flushright @sp 1 Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain ``on'' in each blink cycle. \fIThis option is obsolete and is gradually being replaced by the @b{insertOnTime}@r{ option.} @end table @table @asis @item @code{@b{:cursorwidth}} @flushright Name=@code{"@b{cursorWidth}@r{"} Class=@code{"}@b{CursorWidth}"} @end flushright @sp 1 Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to @b{Tk_GetPixels}. If a border has been specified for the cursor (using the @b{cursorBorderWidth} option), the border will be drawn inside the width specified by the @b{cursorWidth} option. \fIThis option is obsolete and is gradually being replaced by the @b{insertWidth}@r{ option.} @end table @table @asis @item @code{@b{:disabledforeground}} @flushright Name=@code{"@b{disabledForeground}@r{"} Class=@code{"}@b{DisabledForeground}"} @end flushright @sp 1 Specifies foreground color to use when drawing a disabled element. If the option is specified as an empty string (which is typically the case on monochrome displays), disabled elements are drawn with the normal fooreground color but they are dimmed by drawing them with a stippled fill pattern. @end table @table @asis @item @code{@b{:exportselection}} @flushright Name=@code{"@b{exportSelection}@r{"} Class=@code{"}@b{ExportSelection}"} @end flushright @sp 1 Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the forms accepted by @b{Tcl_GetBoolean}, such as @b{true}@r{, }@b{false}@r{, }@b{0}@r{, }@b{1}@r{, }@b{yes}@r{, or }@b{no}. If the selection is exported, then selecting in the widget deselects the current X selection, selecting outside the widget deselects any widget selection, and the widget will respond to selection retrieval requests when it has a selection. The default is usually for widgets to export selections. @end table @table @asis @item @code{@b{:font}} @flushright Name=@code{"@b{font}@r{"} Class=@code{"}@b{Font}"} @end flushright @sp 1 Specifies the font to use when drawing text inside the widget. @end table @table @asis @item @code{@b{:foreground or :fg}} @flushright Name=@code{"@b{foreground}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the normal foreground color to use when displaying the widget. @end table @table @asis @item @code{@b{:geometry}} @flushright Name=@code{"@b{geometry}@r{"} Class=@code{"}@b{Geometry}"} @end flushright @sp 1 Specifies the desired geometry for the widget's window, in the form @i{width}@b{x}@i{height}@r{, where }@i{width} is the desired width of the window and @i{height} is the desired height. The units for @i{width}@r{ and }@i{height} depend on the particular widget. For widgets displaying text the units are usually the size of the characters in the font being displayed; for other widgets the units are usually pixels. @end table @table @asis @item @code{@b{:insertbackground}} @flushright Name=@code{"@b{insertBackground}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). @end table @table @asis @item @code{@b{:insertborderwidth}} @flushright Name=@code{"@b{insertBorderWidth}@r{"} Class=@code{"}@b{BorderWidth}"} @end flushright @sp 1 Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to @b{Tk_GetPixels}. @end table @table @asis @item @code{@b{:insertofftime}} @flushright Name=@code{"@b{insertOffTime}@r{"} Class=@code{"}@b{OffTime}"} @end flushright @sp 1 Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain ``off'' in each blink cycle. If this option is zero then the cursor doesn't blink: it is on all the time. @end table @table @asis @item @code{@b{:insertontime}} @flushright Name=@code{"@b{insertOnTime}@r{"} Class=@code{"}@b{OnTime}"} @end flushright @sp 1 Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain ``on'' in each blink cycle. @end table @table @asis @item @code{@b{:insertwidth}} @flushright Name=@code{"@b{insertWidth}@r{"} Class=@code{"}@b{InsertWidth}"} @end flushright @sp 1 Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to @b{Tk_GetPixels}. If a border has been specified for the insertion cursor (using the @b{insertBorderWidth} option), the border will be drawn inside the width specified by the @b{insertWidth} option. @end table @table @asis @item @code{@b{:orient}} @flushright Name=@code{"@b{orient}@r{"} Class=@code{"}@b{Orient}"} @end flushright @sp 1 For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars, this option specifies which orientation should be used. Must be either @b{horizontal} or @b{vertical} or an abbreviation of one of these. @end table @table @asis @item @code{@b{:padx}} @flushright Name=@code{"@b{padX}@r{"} Class=@code{"}@b{Pad}"} @end flushright @sp 1 Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction. The value may have any of the forms acceptable to @b{Tk_GetPixels}. When computing how large a window it needs, the widget will add this amount to the width it would normally need (as determined by the width of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space to the left and/or right of what it displays inside. @end table @table @asis @item @code{@b{:pady}} @flushright Name=@code{"@b{padY}@r{"} Class=@code{"}@b{Pad}"} @end flushright @sp 1 Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction. The value may have any of the forms acceptable to @b{Tk_GetPixels}. When computing how large a window it needs, the widget will add this amount to the height it would normally need (as determined by the height of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space above and/or below what it displays inside. @end table @table @asis @item @code{@b{:relief}} @flushright Name=@code{"@b{relief}@r{"} Class=@code{"}@b{Relief}"} @end flushright @sp 1 Specifies the 3-D effect desired for the widget. Acceptable values are @b{raised}@r{, }@b{sunken}@r{, }@b{flat}@r{, }@b{ridge}, and @b{groove}. The value indicates how the interior of the widget should appear relative to its exterior; for example, @b{raised} means the interior of the widget should appear to protrude from the screen, relative to the exterior of the widget. @end table @table @asis @item @code{@b{:repeatdelay}} @flushright Name=@code{"@b{repeatDelay}@r{"} Class=@code{"}@b{RepeatDelay}"} @end flushright @sp 1 Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used, for example, on the up- and down-arrows in scrollbars. @end table @table @asis @item @code{@b{:repeatinterval}} @flushright Name=@code{"@b{repeatInterval}@r{"} Class=@code{"}@b{RepeatInterval}"} @end flushright @sp 1 Used in conjunction with @b{repeatDelay}: once auto-repeat begins, this option determines the number of milliseconds between auto-repeats. @end table @table @asis @item @code{@b{:scrollcommand}} @flushright Name=@code{"@b{scrollCommand}@r{"} Class=@code{"}@b{ScrollCommand}"} @end flushright @sp 1 Specifies the prefix for a command used to communicate with scrollbar widgets. When the view in the widget's window changes (or whenever anything else occurs that could change the display in a scrollbar, such as a change in the total size of the widget's contents), the widget will generate a Tcl command by concatenating the scroll command and four numbers. The four numbers are, in order: the total size of the widget's contents, in unspecified units (``unit'' is a widget-specific term; for widgets displaying text, the unit is a line); the maximum number of units that may be displayed at once in the widget's window, given its current size; the index of the top-most or left-most unit currently visible in the window (index 0 corresponds to the first unit); and the index of the bottom-most or right-most unit currently visible in the window. This command is then passed to the Tcl interpreter for execution. Typically the @b{scrollCommand} option consists of the path name of a scrollbar widget followed by ``set'', e.g. ``.x.scrollbar set'': this will cause the scrollbar to be updated whenever the view in the window changes. If this option is not specified, then no command will be executed. The @b{scrollCommand} option is used for widgets that support scrolling in only one direction. For widgets that support scrolling in both directions, this option is replaced with the @b{xScrollCommand}@r{ and }@b{yScrollCommand} options. @end table @table @asis @item @code{@b{:selectbackground}} @flushright Name=@code{"@b{selectBackground}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the background color to use when displaying selected items. @end table @table @asis @item @code{@b{:selectborderwidth}} @flushright Name=@code{"@b{selectBorderWidth}@r{"} Class=@code{"}@b{BorderWidth}"} @end flushright @sp 1 Specifies a non-negative value indicating the width of the 3-D border to draw around selected items. The value may have any of the forms acceptable to @b{Tk_GetPixels}. @end table @table @asis @item @code{@b{:selectforeground}} @flushright Name=@code{"@b{selectForeground}@r{"} Class=@code{"}@b{Background}"} @end flushright @sp 1 Specifies the foreground color to use when displaying selected items. @end table @table @asis @item @code{@b{:setgrid}} @flushright Name=@code{"@b{setGrid}@r{"} Class=@code{"}@b{SetGrid}"} @end flushright @sp 1 Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window. This option is typically used in text widgets, where the information in the widget has a natural size (the size of a character) and it makes sense for the window's dimensions to be integral numbers of these units. These natural window sizes form a grid. If the @b{setGrid} option is set to true then the widget will communicate with the window manager so that when the user interactively resizes the top-level window that contains the widget, the dimensions of the window will be displayed to the user in grid units and the window size will be constrained to integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the @b{wm} manual entry for more details. @end table @table @asis @item @code{@b{:text}} @flushright Name=@code{"@b{text}@r{"} Class=@code{"}@b{Text}"} @end flushright @sp 1 Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the particular widget and may be determined by other options, such as @b{anchor}@r{ or }@b{justify}. @end table @table @asis @item @code{@b{:textvariable}} @flushright Name=@code{"@b{textVariable}@r{"} Class=@code{"}@b{Variable}"} @end flushright @sp 1 Specifies the name of a variable. The value of the variable is a text string to be displayed inside the widget; if the variable value changes then the widget will automatically update itself to reflect the new value. The way in which the string is displayed in the widget depends on the particular widget and may be determined by other options, such as @b{anchor}@r{ or }@b{justify}. @end table @table @asis @item @code{@b{:underline}} @flushright Name=@code{"@b{underline}@r{"} Class=@code{"}@b{Underline}"} @end flushright @sp 1 Specifies the integer index of a character to underline in the widget. This option is typically used to indicate keyboard traversal characters in menu buttons and menu entries. 0 corresponds to the first character of the text displayed in the widget, 1 to the next character, and so on. @end table @table @asis @item @code{@b{:xscrollcommand}} @flushright Name=@code{"@b{xScrollCommand}@r{"} Class=@code{"}@b{ScrollCommand}"} @end flushright @sp 1 Specifies the prefix for a command used to communicate with horizontal scrollbars. This option is treated in the same way as the @b{scrollCommand} option, except that it is used for horizontal scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of @b{scrollCommand} for complete details on how this option is used. @end table @table @asis @item @code{@b{:yscrollcommand}} @flushright Name=@code{"@b{yScrollCommand}@r{"} Class=@code{"}@b{ScrollCommand}"} @end flushright @sp 1 Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the same way as the @b{scrollCommand} option, except that it is used for vertical scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of @b{scrollCommand} for complete details on how this option is used. @end table @unnumberedsubsec Keywords class, name, standard option, switch @node pack-old, pack, options, Control @section pack-old @c @cartouche pack \- Obsolete syntax for packer geometry manager @unnumberedsubsec Synopsis @b{pack after }@i{sibling }@i{window options}@r{ ?}@i{window options }...? @sp 1 @b{pack append }@i{parent }@i{window options}@r{ ?}@i{window options }...? @sp 1 @b{pack before }@i{sibling }@i{window options}@r{ ?}@i{window options }...? @sp 1 @b{pack info }@i{parent} @sp 1 @b{pack unpack }@i{window} @c @end cartouche @unnumberedsubsec Description @i{Note: this manual entry describes the syntax for the }@b{pack}\fI command as it before Tk version 3.3. Although this syntax continues to be supported for backward compatibility, it is obsolete and should not be used anymore. At some point in the future it may cease to be supported. The packer is a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The first child is placed against one side of the window, occupying the entire span of the window along that side. This reduces the space remaining for other children as if the side had been moved in by the size of the first child. Then the next child is placed against one side of the remaining cavity, and so on until all children have been placed or there is no space left in the cavity. The @b{before}@r{, }@b{after}@r{, and }@b{append}@r{ forms of the }@b{pack} command are used to insert one or more children into the packing order for their parent. The @b{before} form inserts the children before window @i{sibling} in the order; all of the other windows must be siblings of @i{sibling}@r{. The }@b{after} form inserts the windows after @i{sibling}@r{, and the }@b{append} form appends one or more windows to the end of the packing order for @i{parent}. If a @i{window} named in any of these commands is already packed in its parent, it is removed from its current position in the packing order and repositioned as indicated by the command. All of these commands return an empty string as result. The @b{unpack}@r{ form of the }@b{pack}@r{ command removes }@i{window} from the packing order of its parent and unmaps it. After the execution of this command the packer will no longer manage @i{window}'s geometry. The placement of each child is actually a four-step process; the @i{options}@r{ argument following each }@i{window} consists of a list of one or more fields that govern the placement of that window. In the discussion below, the term @i{cavity} refers to the space left in a parent when a particular child is placed (i.e. all the space that wasn't claimed by earlier children in the packing order). The term @i{parcel} refers to the space allocated to a particular child; this is not necessarily the same as the child window's final geometry. The first step in placing a child is to determine which side of the cavity it will lie against. Any one of the following options may be used to specify a side: @table @asis @item @b{top} Position the child's parcel against the top of the cavity, occupying the full width of the cavity. @item @b{bottom} Position the child's parcel against the bottom of the cavity, occupying the full width of the cavity. @item @b{left} Position the child's parcel against the left side of the cavity, occupying the full height of the cavity. @item @b{right} Position the child's parcel against the right side of the cavity, occupying the full height of the cavity. @end table At most one of these options should be specified for any given window. If no side is specified, then the default is @b{top}. The second step is to decide on a parcel for the child. For @b{top} and @b{bottom} windows, the desired parcel width is normally the cavity width and the desired parcel height is the window's requested height, as passed to @b{Tk_GeometryRequest}@r{. For }@b{left}@r{ and }@b{right} windows, the desired parcel height is normally the cavity height and the desired width is the window's requested width. However, extra space may be requested for the window using any of the following options: @table @asis @item @b{padx }@i{num} Add @i{num} pixels to the window's requested width before computing the parcel size as described above. @item @b{pady }@i{num} Add @i{num} pixels to the window's requested height before computing the parcel size as described above. @item @b{expand} This option requests that the window's parcel absorb any extra space left over in the parent's cavity after packing all the children. The amount of space left over depends on the sizes requested by the other children, and may be zero. If several windows have all specified @b{expand} then the extra width will be divided equally among all the @b{left}@r{ and }@b{right}@r{ windows that specified }@b{expand} and the extra height will be divided equally among all the @b{top} and @b{bottom}@r{ windows that specified }@b{expand}. @end table If the desired width or height for a parcel is larger than the corresponding dimension of the cavity, then the cavity's dimension is used instead. The third step in placing the window is to decide on the window's width and height. The default is for the window to receive either its requested width and height or the those of the parcel, whichever is smaller. If the parcel is larger than the window's requested size, then the following options may be used to expand the window to partially or completely fill the parcel: @table @asis @item @b{fill} Set the window's size to equal the parcel size. @item @b{fillx} Increase the window's width to equal the parcel's width, but retain the window's requested height. @item @b{filly} Increase the window's height to equal the parcel's height, but retain the window's requested width. The last step is to decide the window's location within its parcel. If the window's size equals the parcel's size, then the window simply fills the entire parcel. If the parcel is larger than the window, then one of the following options may be used to specify where the window should be positioned within its parcel: @item @b{frame center} Center the window in its parcel. This is the default if no framing option is specified. @item @b{frame n} Position the window with its top edge centered on the top edge of the parcel. @item @b{frame ne} Position the window with its upper-right corner at the upper-right corner of the parcel. @item @b{frame e} Position the window with its right edge centered on the right edge of the parcel. @item @b{frame se} Position the window with its lower-right corner at the lower-right corner of the parcel. @item @b{frame s} Position the window with its bottom edge centered on the bottom edge of the parcel. @item @b{frame sw} Position the window with its lower-left corner at the lower-left corner of the parcel. @item @b{frame w} Position the window with its left edge centered on the left edge of the parcel. @item @b{frame nw} Position the window with its upper-left corner at the upper-left corner of the parcel. The @b{pack info} command may be used to retrieve information about the packing order for a parent. It returns a list in the form @example @i{window options window options ...} @end example Each @i{window}@r{ is a name of a window packed in }@i{parent}, and the following @i{options} describes all of the options for that window, just as they would be typed to @b{pack append}. The order of the list is the same as the packing order for @i{parent}. The packer manages the mapped/unmapped state of all the packed children windows. It automatically maps the windows when it packs them, and it unmaps any windows for which there was no space left in the cavity. The packer makes geometry requests on behalf of the parent windows it manages. For each parent window it requests a size large enough to accommodate all the options specified by all the packed children, such that zero space would be leftover for @b{expand} options. @end table @unnumberedsubsec Keywords geometry manager, location, packer, parcel, size @node pack, place, pack-old, Control @section pack @c @cartouche pack \- Geometry manager that packs around edges of cavity @unnumberedsubsec Synopsis @b{pack }@i{option arg }@r{?}@i{arg ...}? @c @end cartouche @unnumberedsubsec Description The @b{pack} command is used to communicate with the packer, a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The @b{pack} command can have any of several forms, depending on the @i{option} argument: @table @asis @item @b{pack }@i{slave }@r{?}@i{slave ...}@r{? ?}@i{options}? If the first argument to @b{pack} is a window name (any value starting with ``.''), then the command is processed in the same way as @b{pack configure}. @item @b{pack configure }@i{slave }@r{?}@i{slave ...}@r{? ?}@i{options}? The arguments consist of the names of one or more slave windows followed by pairs of arguments that specify how to manage the slaves. See ``THE PACKER ALGORITHM'' below for details on how the options are used by the packer. The following options are supported: @item @b{:after }@i{other} @i{Other} must the name of another window. Use its master as the master for the slaves, and insert the slaves just after @i{other} in the packing order. @item @b{:anchor }@i{anchor} @i{Anchor}@r{ must be a valid anchor position such as }@b{n} or @b{sw}; it specifies where to position each slave in its parcel. Defaults to @b{center}. @item @b{:before }@i{other} @i{Other} must the name of another window. Use its master as the master for the slaves, and insert the slaves just before @i{other} in the packing order. @item @b{:expand }@i{boolean} Specifies whether the slaves should be expanded to consume extra space in their master. @i{Boolean}@r{ may have any proper boolean value, such as }@b{1} or @b{no}. Defaults to 0. @item @b{:fill }@i{style} If a slave's parcel is larger than its requested dimensions, this option may be used to stretch the slave. @i{Style} must have one of the following values: @table @asis @item @b{none} Give the slave its requested dimensions plus any internal padding requested with @b{:ipadx}@r{ or }@b{:ipady}. This is the default. @item @b{x} Stretch the slave horizontally to fill the entire width of its parcel (except leave external padding as specified by @b{:padx}). @item @b{y} Stretch the slave vertically to fill the entire height of its parcel (except leave external padding as specified by @b{:pady}). @item @b{both} Stretch the slave both horizontally and vertically. @end table @item @b{:in }@i{other} Insert the slave(s) at the end of the packing order for the master window given by @i{other}. @item @b{:ipadx }@i{amount} @i{Amount} specifies how much horizontal internal padding to leave on each side of the slave(s). @i{Amount}@r{ must be a valid screen distance, such as }@b{2}@r{ or }@b{.5c}. It defaults to 0. @item @b{:ipady }@i{amount} @i{Amount} specifies how much vertical internal padding to leave on each side of the slave(s). @i{Amount} defaults to 0. @item @b{:padx }@i{amount} @i{Amount} specifies how much horizontal external padding to leave on each side of the slave(s). @i{Amount} defaults to 0. @item @b{:pady }@i{amount} @i{Amount} specifies how much vertical external padding to leave on each side of the slave(s). @i{Amount} defaults to 0. @item @b{:side }@i{side} Specifies which side of the master the slave(s) will be packed against. Must be @b{left}@r{, }@b{right}@r{, }@b{top}@r{, or }@b{bottom}. Defaults to @b{top}. @end table If no @b{:in}@r{, }@b{:after}@r{ or }@b{:before} option is specified then each of the slaves will be inserted at the end of the packing list for its parent unless it is already managed by the packer (in which case it will be left where it is). If one of these options is specified then all the slaves will be inserted at the specified point. If any of the slaves are already managed by the geometry manager then any unspecified options for them retain their previous values rather than receiving default values. .RE @table @asis @item @b{pack :forget }@i{slave }@r{?}@i{slave ...}? Removes each of the @i{slave}s from the packing order for its master and unmaps their windows. The slaves will no longer be managed by the packer. @item @b{pack :newinfo }@i{slave} Returns a list whose elements are the current configuration state of the slave given by @i{slave} in the same option-value form that might be specified to @b{pack configure}. The first two elements of the list are ``@b{:in }@i{master}'' where @i{master} is the slave's master. Starting with Tk 4.0 this option will be renamed "pack info". @item @b{pack :propagate }@i{master}@r{ ?}@i{boolean}? If @i{boolean}@r{ has a true boolean value such as }@b{1}@r{ or }@b{on} then propagation is enabled for @i{master}, which must be a window name (see ``GEOMETRY PROPAGATION'' below). If @i{boolean} has a false boolean value then propagation is disabled for @i{master}. In either of these cases an empty string is returned. If @i{boolean}@r{ is omitted then the command returns }@b{0} or @b{1} to indicate whether propagation is currently enabled for @i{master}. Propagation is enabled by default. @item @b{pack :slaves }@i{master} Returns a list of all of the slaves in the packing order for @i{master}. The order of the slaves in the list is the same as their order in the packing order. If @i{master} has no slaves then an empty string is returned. @end table @unnumberedsubsec "The Packer Algorithm" For each master the packer maintains an ordered list of slaves called the @i{packing list}. The @b{:in}@r{, }@b{:after}@r{, and }@b{:before} configuration options are used to specify the master for each slave and the slave's position in the packing list. If none of these options is given for a slave then the slave is added to the end of the packing list for its parent. The packer arranges the slaves for a master by scanning the packing list in order. At the time it processes each slave, a rectangular area within the master is still unallocated. This area is called the @i{cavity}; for the first slave it is the entire area of the master. For each slave the packer carries out the following steps: @itemize @asis{} @item [1] The packer allocates a rectangular @i{parcel} for the slave along the side of the cavity given by the slave's @b{:side} option. If the side is top or bottom then the width of the parcel is the width of the cavity and its height is the requested height of the slave plus the @b{:ipady}@r{ and }@b{:pady} options. For the left or right side the height of the parcel is the height of the cavity and the width is the requested width of the slave plus the @b{:ipadx}@r{ and }@b{:padx} options. The parcel may be enlarged further because of the @b{:expand} option (see ``EXPANSION'' below) @item [2] The packer chooses the dimensions of the slave. The width will normally be the slave's requested width plus twice its @b{:ipadx} option and the height will normally be the slave's requested height plus twice its @b{:ipady} option. However, if the @b{:fill}@r{ option is }@b{x}@r{ or }@b{both} then the width of the slave is expanded to fill the width of the parcel, minus twice the @b{:padx} option. If the @b{:fill}@r{ option is }@b{y}@r{ or }@b{both} then the height of the slave is expanded to fill the width of the parcel, minus twice the @b{:pady} option. @item [3] The packer positions the slave over its parcel. If the slave is smaller than the parcel then the @b{:anchor} option determines where in the parcel the slave will be placed. If @b{:padx}@r{ or }@b{:pady} is non-zero, then the given amount of external padding will always be left between the slave and the edges of the parcel. @end itemize Once a given slave has been packed, the area of its parcel is subtracted from the cavity, leaving a smaller rectangular cavity for the next slave. If a slave doesn't use all of its parcel, the unused space in the parcel will not be used by subsequent slaves. If the cavity should become too small to meet the needs of a slave then the slave will be given whatever space is left in the cavity. If the cavity shrinks to zero size, then all remaining slaves on the packing list will be unmapped from the screen until the master window becomes large enough to hold them again. @unnumberedsubsec "Expansion" If a master window is so large that there will be extra space left over after all of its slaves have been packed, then the extra space is distributed uniformly among all of the slaves for which the @b{:expand} option is set. Extra horizontal space is distributed among the expandable slaves whose @b{:side}@r{ is }@b{left}@r{ or }@b{right}, and extra vertical space is distributed among the expandable slaves whose @b{:side}@r{ is }@b{top}@r{ or }@b{bottom}. @unnumberedsubsec "Geometry Propagation" The packer normally computes how large a master must be to just exactly meet the needs of its slaves, and it sets the requested width and height of the master to these dimensions. This causes geometry information to propagate up through a window hierarchy to a top-level window so that the entire sub-tree sizes itself to fit the needs of the leaf windows. However, the @b{pack propagate} command may be used to turn off propagation for one or more masters. If propagation is disabled then the packer will not set the requested width and height of the packer. This may be useful if, for example, you wish for a master window to have a fixed size that you specify. @unnumberedsubsec "Restrictions On Master Windows" The master for each slave must either be the slave's parent (the default) or a descendant of the slave's parent. This restriction is necessary to guarantee that the slave can be placed over any part of its master that is visible without danger of the slave being clipped by its parent. @unnumberedsubsec "Packing Order" If the master for a slave is not its parent then you must make sure that the slave is higher in the stacking order than the master. Otherwise the master will obscure the slave and it will appear as if the slave hasn't been packed correctly. The easiest way to make sure the slave is higher than the master is to create the master window first: the most recently created window will be highest in the stacking order. Or, you can use the @b{raise}@r{ and }@b{lower} commands to change the stacking order of either the master or the slave. @unnumberedsubsec Keywords geometry manager, location, packer, parcel, propagation, size @node place, raise, pack, Control @section place @c @cartouche place \- Geometry manager for fixed or rubber-sheet placement @unnumberedsubsec Synopsis @b{place }@i{window option value }@r{?}@i{option value ...}? @sp 1 @b{place configure }@i{window option value }@r{?}@i{option value ...}? @sp 1 @b{place forget }@i{window} @sp 1 @b{place info }@i{window} @sp 1 @b{place slaves }@i{window} @c @end cartouche @unnumberedsubsec Description The placer is a geometry manager for Tk. It provides simple fixed placement of windows, where you specify the exact size and location of one window, called the @i{slave}, within another window, called the @i{master}. The placer also provides rubber-sheet placement, where you specify the size and location of the slave in terms of the dimensions of the master, so that the slave changes size and location in response to changes in the size of the master. Lastly, the placer allows you to mix these styles of placement so that, for example, the slave has a fixed width and height but is centered inside the master. If the first argument to the @b{place} command is a window path name or @b{configure} then the command arranges for the placer to manage the geometry of a slave whose path name is @i{window}. The remaining arguments consist of one or more @i{option:value} pairs that specify the way in which @i{window}'s geometry is managed. If the placer is already managing @i{window}, then the @i{option:value}@r{ pairs modify the configuration for }@i{window}. In this form the @b{place} command returns an empty string as result. The following @i{option:value} pairs are supported: @table @asis @item @b{:in }@i{master} @i{Master} specifes the path name of the window relative to which @i{window} is to be placed. @i{Master}@r{ must either be }@i{window}'s parent or a descendant of @i{window}'s parent. In addition, @i{master}@r{ and }@i{window} must both be descendants of the same top-level window. These restrictions are necessary to guarantee that @i{window}@r{ is visible whenever }@i{master} is visible. If this option isn't specified then the master defaults to @i{window}'s parent. @item @b{:x }@i{location} @i{Location} specifies the x-coordinate within the master window of the anchor point for @i{window}. The location is specified in screen units (i.e. any of the forms accepted by @b{Tk_GetPixels}) and need not lie within the bounds of the master window. @item @b{:relx }@i{location} @i{Location} specifies the x-coordinate within the master window of the anchor point for @i{window}. In this case the location is specified in a relative fashion as a floating-point number: 0.0 corresponds to the left edge of the master and 1.0 corresponds to the right edge of the master. @i{Location} need not be in the range 0.0\-1.0. @item @b{:y }@i{location} @i{Location} specifies the y-coordinate within the master window of the anchor point for @i{window}. The location is specified in screen units (i.e. any of the forms accepted by @b{Tk_GetPixels}) and need not lie within the bounds of the master window. @item @b{:rely }@i{location} @i{Location} specifies the y-coordinate within the master window of the anchor point for @i{window}. In this case the value is specified in a relative fashion as a floating-point number: 0.0 corresponds to the top edge of the master and 1.0 corresponds to the bottom edge of the master. @i{Location} need not be in the range 0.0\-1.0. @item @b{:anchor }@i{where} @i{Where}@r{ specifies which point of }@i{window} is to be positioned at the (x,y) location selected by the @b{:x}@r{, }@b{:y}, @b{:relx}@r{, and }@b{:rely} options. The anchor point is in terms of the outer area of @i{window} including its border, if any. Thus if @i{where}@r{ is }@b{se} then the lower-right corner of @i{window}'s border will appear at the given (x,y) location in the master. The anchor position defaults to @b{nw}. @item @b{:width }@i{size} @i{Size}@r{ specifies the width for }@i{window} in screen units (i.e. any of the forms accepted by @b{Tk_GetPixels}). The width will be the outer width of @i{window} including its border, if any. If @i{size}@r{ is an empty string, or if no }@b{:width} or @b{:relwidth} option is specified, then the width requested internally by the window will be used. @item @b{:relwidth }@i{size} @i{Size}@r{ specifies the width for }@i{window}. In this case the width is specified as a floating-point number relative to the width of the master: 0.5 means @i{window} will be half as wide as the master, 1.0 means @i{window} will have the same width as the master, and so on. @item @b{:height }@i{size} @i{Size}@r{ specifies the height for }@i{window} in screen units (i.e. any of the forms accepted by @b{Tk_GetPixels}). The height will be the outer dimension of @i{window} including its border, if any. If @i{size}@r{ is an empty string, or if no }@b{:height} or @b{:relheight} option is specified, then the height requested internally by the window will be used. @item @b{:relheight }@i{size} @i{Size}@r{ specifies the height for }@i{window}. In this case the height is specified as a floating-point number relative to the height of the master: 0.5 means @i{window} will be half as high as the master, 1.0 means @i{window} will have the same height as the master, and so on. @item @b{:bordermode }@i{mode} @i{Mode} determines the degree to which borders within the master are used in determining the placement of the slave. The default and most common value is @b{inside}. In this case the placer considers the area of the master to be the innermost area of the master, inside any border: an option of @b{:x 0} corresponds to an x-coordinate just inside the border and an option of @b{:relwidth 1.0} means @i{window} will fill the area inside the master's border. If @i{mode}@r{ is }@b{outside} then the placer considers the area of the master to include its border; this mode is typically used when placing @i{window} outside its master, as with the options @b{:x 0 :y 0 :anchor ne}. Lastly, @i{mode}@r{ may be specified as }@b{ignore}, in which case borders are ignored: the area of the master is considered to be its official X area, which includes any internal border but no external border. A bordermode of @b{ignore} is probably not very useful. If the same value is specified separately with two different options, such as @b{:x}@r{ and }@b{:relx}, then the most recent option is used and the older one is ignored. The @b{place slaves} command returns a list of all the slave windows for which @i{window} is the master. If there are no slaves for @i{window} then an empty string is returned. The @b{place forget} command causes the placer to stop managing the geometry of @i{window}. As a side effect of this command @i{window} will be unmapped so that it doesn't appear on the screen. If @i{window} isn't currently managed by the placer then the command has no effect. @b{Place forget} returns an empty string as result. The @b{place info} command returns a list giving the current configuration of @i{window}. The list consists of @i{option:value} pairs in exactly the same form as might be specified to the @b{place configure} command. If the configuration of a window has been retrieved with @b{place info}, that configuration can be restored later by first using @b{place forget} to erase any existing information for the window and then invoking @b{place configure} with the saved information. @end table @unnumberedsubsec "Fine Points" It is not necessary for the master window to be the parent of the slave window. This feature is useful in at least two situations. First, for complex window layouts it means you can create a hierarchy of subwindows whose only purpose is to assist in the layout of the parent. The ``real children'' of the parent (i.e. the windows that are significant for the application's user interface) can be children of the parent yet be placed inside the windows of the geometry-management hierarchy. This means that the path names of the ``real children'' don't reflect the geometry-management hierarchy and users can specify options for the real children without being aware of the structure of the geometry-management hierarchy. A second reason for having a master different than the slave's parent is to tie two siblings together. For example, the placer can be used to force a window always to be positioned centered just below one of its siblings by specifying the configuration @example @b{:in }@i{sibling}@b{ :relx 0.5 :rely 1.0 :anchor n :bordermode outside} @end example Whenever the sibling is repositioned in the future, the slave will be repositioned as well. Unlike many other geometry managers (such as the packer) the placer does not make any attempt to manipulate the geometry of the master windows or the parents of slave windows (i.e. it doesn't set their requested sizes). To control the sizes of these windows, make them windows like frames and canvases that provide configuration options for this purpose. @unnumberedsubsec Keywords geometry manager, height, location, master, place, rubber sheet, slave, width @node raise, selection, place, Control @section raise @c @cartouche raise \- Change a window's position in the stacking order @unnumberedsubsec Synopsis @b{raise }@i{window }@r{?}@i{aboveThis}? @c @end cartouche @unnumberedsubsec Description If the @i{aboveThis} argument is omitted then the command raises @i{window} so that it is above all of its siblings in the stacking order (it will not be obscured by any siblings and will obscure any siblings that overlap it). If @i{aboveThis} is specified then it must be the path name of a window that is either a sibling of @i{window} or the descendant of a sibling of @i{window}. In this case the @b{raise} command will insert @i{window}@r{ into the stacking order just above }@i{aboveThis} (or the ancestor of @i{aboveThis}@r{ that is a sibling of }@i{window}); this could end up either raising or lowering @i{window}. @unnumberedsubsec Keywords obscure, raise, stacking order @node selection, send, raise, Control @section selection @c @cartouche selection \- Manipulate the X selection @unnumberedsubsec Synopsis @b{selection }@i{option}@r{ ?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description This command provides a Tcl interface to the X selection mechanism and implements the full selection functionality described in the X Inter-Client Communication Conventions Manual (ICCCM), except that it supports only the primary selection. The first argument to @b{selection} determines the format of the rest of the arguments and the behavior of the command. The following forms are currently supported: @table @asis @item @b{selection :clear }@i{window} If there is a selection anywhere on @i{window}'s display, clear it so that no window owns the selection anymore. Returns an empty string. @item @b{selection :get }@r{?}@i{type}? Retrieves the value of the primary selection and returns it as a result. @b{Type} specifies the form in which the selection is to be returned (the desired ``target'' for conversion, in ICCCM terminology), and should be an atom name such as STRING or FILE_NAME; see the Inter-Client Communication Conventions Manual for complete details. @b{Type} defaults to STRING. The selection :owner may choose to return the selection in any of several different representation formats, such as STRING, ATOM, INTEGER, etc. (this format is different than the selection type; see the ICCCM for all the confusing details). If the selection is returned in a non-string format, such as INTEGER or ATOM, the @b{selection} command converts it to string format as a collection of fields separated by spaces: atoms are converted to their textual names, and anything else is converted to hexadecimal integers. @item @b{selection :handle }@i{window command }@r{?}@i{type}@r{? ?}@i{format}? Creates a handler for selection requests, such that @i{command} will be executed whenever the primary selection is owned by @i{window} and someone attempts to retrieve it in the form given by @i{type}@r{ (e.g. }@i{type}@r{ is specified in the }@b{selection :get} command). @i{Type} defaults to STRING. If @i{command} is an empty string then any existing handler for @i{window}@r{ and }@i{type} is removed. When the selection is requested and @i{window} is the selection :owner and @i{type}@r{ is the requested type, }@i{command} will be executed as a Tcl command with two additional numbers appended to it (with space separators). The two additional numbers are @i{offset}@r{ and }@i{maxBytes}@r{: }@i{offset} specifies a starting character position in the selection and @i{maxBytes} gives the maximum number of bytes to retrieve. The command should return a value consisting of at most @i{maxBytes} of the selection, starting at position @i{offset}@r{. For very large selections (larger than }@i{maxBytes}) the selection will be retrieved using several invocations of @i{command} with increasing @i{offset}@r{ values. If }@i{command} returns a string whose length is less than @i{maxBytes}, the return value is assumed to include all of the remainder of the selection; if the length of @i{command}@r{'s result is equal to }@i{maxBytes} then @i{command} will be invoked again, until it eventually returns a result shorter than @i{maxBytes}@r{. The value of }@i{maxBytes} will always be relatively large (thousands of bytes). If @i{command} returns an error then the selection retrieval is rejected just as if the selection didn't exist at all. The @i{format} argument specifies the representation that should be used to transmit the selection to the requester (the second column of Table 2 of the ICCCM), and defaults to STRING. If @i{format} is STRING, the selection is transmitted as 8-bit ASCII characters (i.e. just in the form returned by @i{command}@r{). If }@i{format} is ATOM, then the return value from @i{command} is divided into fields separated by white space; each field is converted to its atom value, and the 32-bit atom value is transmitted instead of the atom name. For any other @i{format}@r{, the return value from }@i{command} is divided into fields separated by white space and each field is converted to a 32-bit integer; an array of integers is transmitted to the selection requester. The @i{format} argument is needed only for compatibility with selection requesters that don't use Tk. If the Tk toolkit is being used to retrieve the selection then the value is converted back to a string at the requesting end, so @i{format} is irrelevant. .RE @item @b{selection :own }@r{?}@i{window}@r{? ?}@i{command}? If @i{window} is specified, then it becomes the new selection :owner and the command returns an empty string as result. The existing owner, if any, is notified that it has lost the selection. If @i{command} is specified, it is a Tcl script to execute when some other window claims ownership of the selection away from @i{window}. If neither @i{window}@r{ nor }@i{command} is specified then the command returns the path name of the window in this application that owns the selection, or an empty string if no window in this application owns the selection. @end table @unnumberedsubsec Keywords clear, format, handler, ICCCM, own, selection, target, type @node send, tk, selection, Control @section send @c @cartouche send \- Execute a command in a different interpreter @unnumberedsubsec Synopsis @b{send }@i{interp cmd }@r{?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description This command arranges for @i{cmd}@r{ (and }@i{arg}s) to be executed in the interpreter named by @i{interp}. It returns the result or error from that command execution. @i{Interp} must be the name of an interpreter registered on the display associated with the interpreter in which the command is invoked; it need not be within the same process or application. If no @i{arg} arguments are present, then the command to be executed is contained entirely within the @i{cmd} argument. If one or more @i{arg}s are present, they are concatenated to form the command to be executed, just as for the @b{eval} Tcl command. @unnumberedsubsec Security The @b{send} command is potentially a serious security loophole, since any application that can connect to your X server can send scripts to your applications. These incoming scripts can use Tcl to read and write your files and invoke subprocesses under your name. Host-based access control such as that provided by @b{xhost} is particularly insecure, since it allows anyone with an account on particular hosts to connect to your server, and if disabled it allows anyone anywhere to connect to your server. In order to provide at least a small amount of security, Tk checks the access control being used by the server and rejects incoming sends unless (a) @b{xhost}-style access control is enabled (i.e. only certain hosts can establish connections) and (b) the list of enabled hosts is empty. This means that applications cannot connect to your server unless they use some other form of authorization such as that provide by @b{xauth}. @unnumberedsubsec Keywords interpreter, remote execution, security, send @node tk, tkerror, send, Control @section tk @c @cartouche tk \- Manipulate Tk internal state @unnumberedsubsec Synopsis @b{tk}@r{ }@i{option }@r{?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description The @b{tk} command provides access to miscellaneous elements of Tk's internal state. Most of the information manipulated by this command pertains to the application as a whole, or to a screen or display, rather than to a particular window. The command can take any of a number of different forms depending on the @i{option} argument. The legal forms are: @table @asis @item @b{tk :colormodel }@i{window}@r{ ?}@i{newValue}? If @i{newValue} isn't specified, this command returns the current color model in use for @i{window}'s screen, which will be either @b{color}@r{ or }@b{monochrome}. If @i{newValue}@r{ is specified, then it must be either }@b{color} or @b{monochrome} or an abbreviation of one of them; the color model for @i{window}'s screen is set to this value. @end table The color model is used by Tk and its widgets to determine whether it should display in black and white only or use colors. A single color model is shared by all of the windows managed by one process on a given screen. The color model for a screen is set initially by Tk to @b{monochrome} if the display has four or fewer bit planes and to @b{color} otherwise. The color model will automatically be changed from @b{color} to @b{monochrome} if Tk fails to allocate a color because all entries in the colormap were in use. An application can change its own color model at any time (e.g. it might change the model to @b{monochrome} in order to conserve colormap entries, or it might set the model to @b{color} to use color on a four-bit display in special circumstances), but an application is not allowed to change the color model to @b{color} unless the screen has at least two bit planes. .RE @unnumberedsubsec Keywords color model, internal state @node tkerror, tkvars, tk, Control @section tkerror @c @cartouche tkerror \- Command invoked to process background errors @unnumberedsubsec Synopsis @b{tkerror }@i{message} @c @end cartouche @unnumberedsubsec Description The @b{tkerror} command doesn't exist as built-in part of Tk. Instead, individual applications or users can define a @b{tkerror} command (e.g. as a Tcl procedure) if they wish to handle background errors. A background error is one that occurs in a command that didn't originate with the application. For example, if an error occurs while executing a command specified with a @b{bind}@r{ of }@b{after} command, then it is a background error. For a non-background error, the error can simply be returned up through nested Tcl command evaluations until it reaches the top-level code in the application; then the application can report the error in whatever way it wishes. When a background error occurs, the unwinding ends in the Tk library and there is no obvious way for Tk to report the error. When Tk detects a background error, it invokes the @b{tkerror} command, passing it the error message as its only argument. Tk assumes that the application has implemented the @b{tkerror} command, and that the command will report the error in a way that makes sense for the application. Tk will ignore any result returned by the @b{tkerror} command. If another Tcl error occurs within the @b{tkerror} command then Tk reports the error itself by writing a message to stderr. The Tk script library includes a default @b{tkerror} procedure that posts a dialog box containing the error message and offers the user a chance to see a stack trace that shows where the error occurred. @unnumberedsubsec Keywords background error, reporting @node tkvars, tkwait, tkerror, Control @section tkvars @c @cartouche tkvars \- Variables used or set by Tk @c @end cartouche @unnumberedsubsec Description The following Tcl variables are either set or used by Tk at various times in its execution: @table @asis @item @b{tk_library} Tk sets this variable hold the name of a directory containing a library of Tcl scripts related to Tk. These scripts include an initialization file that is normally processed whenever a Tk application starts up, plus other files containing procedures that implement default behaviors for widgets. The value of this variable is taken from the TK_LIBRARY environment variable, if one exists, or else from a default value compiled into Tk. @item @b{tk_patchLevel} Contains a decimal integer giving the current patch level for Tk. The patch level is incremented for each new release or patch, and it uniquely identifies an official version of Tk. @item @b{tk_priv} This variable is an array containing several pieces of information that are private to Tk. The elements of @b{tk_priv} are used by Tk library procedures and default bindings. They should not be accessed by any code outside Tk. @item @b{tk_strictMotif} This variable is set to zero by default. If an application sets it to one, then Tk attempts to adhere as closely as possible to Motif look-and-feel standards. For example, active elements such as buttons and scrollbar sliders will not change color when the pointer passes over them. @item @b{tk_version} Tk sets this variable in the interpreter for each application. The variable holds the current version number of the Tk library in the form @i{major}@r{.}@i{minor}@r{. }@i{Major} and @i{minor} are integers. The major version number increases in any Tk release that includes changes that are not backward compatible (i.e. whenever existing Tk applications and scripts may have to change to work with the new release). The minor version number increases with each new release of Tk, except that it resets to zero whenever the major version number changes. @item @b{tkVersion} Has the same value as @b{tk_version}. This variable is obsolete and will be deleted soon. @end table @unnumberedsubsec Keywords variables, version @node tkwait, update, tkvars, Control @section tkwait @c @cartouche tkwait \- Wait for variable to change or window to be destroyed @unnumberedsubsec Synopsis @*@w{@b{tkwait :variable }@i{name}}@* @*@w{@b{tkwait :visibility }@i{name}}@* @b{tkwait :window }@i{name} @c @end cartouche @unnumberedsubsec Description The @b{tkwait} command waits for one of several things to happen, then it returns without taking any other actions. The return value is always an empty string. If the first argument is @b{:variable} (or any abbreviation of it) then the second argument is the name of a global variable and the command waits for that variable to be modified. If the first argument is @b{:visibility} (or any abbreviation of it) then the second argument is the name of a window and the @b{tkwait} command waits for a change in its visibility state (as indicated by the arrival of a VisibilityNotify event). This form is typically used to wait for a newly-created window to appear on the screen before taking some action. If the first argument is @b{:window} (or any abbreviation of it) then the second argument is the name of a window and the @b{tkwait} command waits for that window to be destroyed. This form is typically used to wait for a user to finish interacting with a dialog box before using the result of that interaction. While the @b{tkwait} command is waiting it processes events in the normal fashion, so the application will continue to respond to user interactions. @unnumberedsubsec Keywords variable, visibility, wait, window @node update, winfo, tkwait, Control @section update @c @cartouche update \- Process pending events and/or when-idle handlers @unnumberedsubsec Synopsis @b{update}@r{ ?}@b{:idletasks}? @c @end cartouche @unnumberedsubsec Description This command is used to bring the entire application world ``up to date.'' It flushes all pending output to the display, waits for the server to process that output and return errors or events, handles all pending events of any sort (including when-idle handlers), and repeats this set of operations until there are no pending events, no pending when-idle handlers, no pending output to the server, and no operations still outstanding at the server. If the @b{idletasks} keyword is specified as an argument to the command, then no new events or errors are processed; only when-idle idlers are invoked. This causes operations that are normally deferred, such as display updates and window layout calculations, to be performed immediately. The @b{update :idletasks} command is useful in scripts where changes have been made to the application's state and you want those changes to appear on the display immediately, rather than waiting for the script to complete. The @b{update} command with no options is useful in scripts where you are performing a long-running computation but you still want the application to respond to user interactions; if you occasionally call @b{update} then user input will be processed during the next call to @b{update}. @unnumberedsubsec Keywords event, flush, handler, idle, update @node winfo, wm, update, Control @section winfo @c @cartouche winfo \- Return window-related information @unnumberedsubsec Synopsis @b{winfo}@r{ }@i{option }@r{?}@i{arg arg ...}? @c @end cartouche @unnumberedsubsec Description The @b{winfo} command is used to retrieve information about windows managed by Tk. It can take any of a number of different forms, depending on the @i{option} argument. The legal forms are: @table @asis @item @b{winfo :atom }@i{name} Returns a decimal string giving the integer identifier for the atom whose name is @i{name}. If no atom exists with the name @i{name} then a new one is created. @item @b{winfo :atomname }@i{id} Returns the textual name for the atom whose integer identifier is @i{id}. This command is the inverse of the @b{winfo :atom} command. Generates an error if no such atom exists. @item @b{winfo :cells }@i{window} Returns a decimal string giving the number of cells in the color map for @i{window}. @item @b{winfo :children }@i{window} Returns a list containing the path names of all the children of @i{window}. Top-level windows are returned as children of their logical parents. @item @b{winfo :class }@i{window} Returns the class name for @i{window}. @item @b{winfo :containing }@i{rootX rootY} Returns the path name for the window containing the point given by @i{rootX}@r{ and }@i{rootY}. @i{RootX}@r{ and }@i{rootY} are specified in screen units (i.e. any form acceptable to @b{Tk_GetPixels}) in the coordinate system of the root window (if a virtual-root window manager is in use then the coordinate system of the virtual root window is used). If no window in this application contains the point then an empty string is returned. In selecting the containing window, children are given higher priority than parents and among siblings the highest one in the stacking order is chosen. @item @b{winfo :depth }@i{window} Returns a decimal string giving the depth of @i{window} (number of bits per pixel). @item @b{winfo :exists }@i{window} Returns 1 if there exists a window named @i{window}, 0 if no such window exists. @item @b{winfo :fpixels }@i{window}@r{ }@i{number} Returns a floating-point value giving the number of pixels in @i{window}@r{ corresponding to the distance given by }@i{number}. @i{Number} may be specified in any of the forms acceptable to @b{Tk_GetScreenMM}, such as ``2.0c'' or ``1i''. The return value may be fractional; for an integer value, use @b{winfo :pixels}. @item @b{winfo :geometry }@i{window} Returns the geometry for @i{window}, in the form @i{width}@b{x}@i{height}@b{+}@i{x}@b{+}@i{y}. All dimensions are in pixels. @item @b{winfo :height }@i{window} Returns a decimal string giving @i{window}'s height in pixels. When a window is first created its height will be 1 pixel; the height will eventually be changed by a geometry manager to fulfill the window's needs. If you need the true height immediately after creating a widget, invoke @b{update} to force the geometry manager to arrange it, or use @b{winfo :reqheight} to get the window's requested height instead of its actual height. @item @b{winfo :id }@i{window} Returns a hexadecimal string indicating the X identifier for @i{window}. @item @b{winfo :interps} Returns a list whose members are the names of all Tcl interpreters (e.g. all Tk-based applications) currently registered for the display of the invoking application. @item @b{winfo :ismapped }@i{window} Returns @b{1}@r{ if }@i{window}@r{ is currently mapped, }@b{0} otherwise. @item @b{winfo :name }@i{window} Returns @i{window}'s name (i.e. its name within its parent, as opposed to its full path name). The command @b{winfo :name .} will return the name of the application. @item @b{winfo :parent }@i{window} Returns the path name of @i{window}'s parent, or an empty string if @i{window} is the main window of the application. @item @b{winfo :pathname }@i{id} Returns the path name of the window whose X identifier is @i{id}. @i{Id} must be a decimal, hexadecimal, or octal integer and must correspond to a window in the invoking application. @item @b{winfo :pixels }@i{window}@r{ }@i{number} Returns the number of pixels in @i{window} corresponding to the distance given by @i{number}. @i{Number} may be specified in any of the forms acceptable to @b{Tk_GetPixels}, such as ``2.0c'' or ``1i''. The result is rounded to the nearest integer value; for a fractional result, use @b{winfo :fpixels}. @item @b{winfo :reqheight }@i{window} Returns a decimal string giving @i{window}'s requested height, in pixels. This is the value used by @i{window}'s geometry manager to compute its geometry. @item @b{winfo :reqwidth }@i{window} Returns a decimal string giving @i{window}'s requested width, in pixels. This is the value used by @i{window}'s geometry manager to compute its geometry. @item @b{winfo :rgb }@i{window color} Returns a list containing three decimal values, which are the red, green, and blue intensities that correspond to @i{color} in the window given by @i{window}@r{. }@i{Color} may be specified in any of the forms acceptable for a color option. @item @b{winfo :rootx }@i{window} Returns a decimal string giving the x-coordinate, in the root window of the screen, of the upper-left corner of @i{window}@r{'s border (or }@i{window} if it has no border). @item @b{winfo :rooty }@i{window} Returns a decimal string giving the y-coordinate, in the root window of the screen, of the upper-left corner of @i{window}@r{'s border (or }@i{window} if it has no border). @item @b{winfo :screen }@i{window} Returns the name of the screen associated with @i{window}, in the form @i{displayName}@r{.}@i{screenIndex}. @item @b{winfo :screencells }@i{window} Returns a decimal string giving the number of cells in the default color map for @i{window}'s screen. @item @b{winfo :screendepth }@i{window} Returns a decimal string giving the depth of the root window of @i{window}'s screen (number of bits per pixel). @item @b{winfo :screenheight }@i{window} Returns a decimal string giving the height of @i{window}'s screen, in pixels. @item @b{winfo :screenmmheight }@i{window} Returns a decimal string giving the height of @i{window}'s screen, in millimeters. @item @b{winfo :screenmmwidth }@i{window} Returns a decimal string giving the width of @i{window}'s screen, in millimeters. @item @b{winfo :screenvisual }@i{window} Returns one of the following strings to indicate the default visual type for @i{window}@r{'s screen: }@b{directcolor}@r{, }@b{grayscale}, @b{pseudocolor}@r{, }@b{staticcolor}@r{, }@b{staticgray}, or @b{truecolor}. @item @b{winfo :screenwidth }@i{window} Returns a decimal string giving the width of @i{window}'s screen, in pixels. @item @b{winfo :toplevel }@i{window} Returns the path name of the top-level window containing @i{window}. @item @b{winfo :visual }@i{window} Returns one of the following strings to indicate the visual type for @i{window}@r{: }@b{directcolor}@r{, }@b{grayscale}, @b{pseudocolor}@r{, }@b{staticcolor}@r{, }@b{staticgray}, or @b{truecolor}. @item @b{winfo :vrootheight }@i{window} Returns the height of the virtual root window associated with @i{window} if there is one; otherwise returns the height of @i{window}'s screen. @item @b{winfo :vrootwidth }@i{window} Returns the width of the virtual root window associated with @i{window} if there is one; otherwise returns the width of @i{window}'s screen. @item @b{winfo :vrootx }@i{window} Returns the x-offset of the virtual root window associated with @i{window}, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for @i{window}. @item @b{winfo :vrooty }@i{window} Returns the y-offset of the virtual root window associated with @i{window}, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for @i{window}. @item @b{winfo :width }@i{window} Returns a decimal string giving @i{window}'s width in pixels. When a window is first created its width will be 1 pixel; the width will eventually be changed by a geometry manager to fulfill the window's needs. If you need the true width immediately after creating a widget, invoke @b{update} to force the geometry manager to arrange it, or use @b{winfo :reqwidth} to get the window's requested width instead of its actual width. @item @b{winfo :x }@i{window} Returns a decimal string giving the x-coordinate, in @i{window}'s parent, of the upper-left corner of @i{window}@r{'s border (or }@i{window} if it has no border). @item @b{winfo :y }@i{window} Returns a decimal string giving the y-coordinate, in @i{window}'s parent, of the upper-left corner of @i{window}@r{'s border (or }@i{window} if it has no border). @end table @unnumberedsubsec Keywords atom, children, class, geometry, height, identifier, information, interpreters, mapped, parent, path name, screen, virtual root, width, window @node wm, , winfo, Control @section wm @c @cartouche wm \- Communicate with window manager @unnumberedsubsec Synopsis @b{wm}@r{ }@i{option window }@r{?}@i{args}? @c @end cartouche @unnumberedsubsec Description The @b{wm} command is used to interact with window managers in order to control such things as the title for a window, its geometry, or the increments in terms of which it may be resized. The @b{wm} command can take any of a number of different forms, depending on the @i{option} argument. All of the forms expect at least one additional argument, @i{window}, which must be the path name of a top-level window. The legal forms for the @b{wm} command are: @table @asis @item @b{wm :aspect }@i{window}@r{ ?}@i{minNumer minDenom maxNumer maxDenom}? If @i{minNumer}@r{, }@i{minDenom}@r{, }@i{maxNumer}@r{, and }@i{maxDenom} are all specified, then they will be passed to the window manager and the window manager should use them to enforce a range of acceptable aspect ratios for @i{window}. The aspect ratio of @i{window} (width/length) will be constrained to lie between @i{minNumer}@r{/}@i{minDenom}@r{ and }@i{maxNumer}@r{/}@i{maxDenom}. If @i{minNumer} etc. are all specified as empty strings, then any existing aspect ratio restrictions are removed. If @i{minNumer} etc. are specified, then the command returns an empty string. Otherwise, it returns a Tcl list containing four elements, which are the current values of @i{minNumer}@r{, }@i{minDenom}@r{, }@i{maxNumer}@r{, and }@i{maxDenom} (if no aspect restrictions are in effect, then an empty string is returned). @item @b{wm :client }@i{window}@r{ ?}@i{name}? If @i{name}@r{ is specified, this command stores }@i{name} (which should be the name of the host on which the application is executing) in @i{window}'s @b{WM_CLIENT_MACHINE} property for use by the window manager or session manager. The command returns an empty string in this case. If @i{name} isn't specified, the command returns the last name set in a @b{wm :client}@r{ command for }@i{window}. If @i{name} is specified as an empty string, the command deletes the @b{WM_CLIENT_MACHINE}@r{ property from }@i{window}. @item @b{wm :command }@i{window}@r{ ?}@i{value}? If @i{value}@r{ is specified, this command stores }@i{value}@r{ in }@i{window}'s @b{WM_COMMAND} property for use by the window manager or session manager and returns an empty string. @i{Value} must have proper list structure; the elements should contain the words of the command used to invoke the application. If @i{value} isn't specified then the command returns the last value set in a @b{wm :command}@r{ command for }@i{window}. If @i{value} is specified as an empty string, the command deletes the @b{WM_COMMAND}@r{ property from }@i{window}. @item @b{wm :deiconify }@i{window} Arrange for @i{window} to be displayed in normal (non-iconified) form. This is done by mapping the window. If the window has never been mapped then this command will not map the window, but it will ensure that when the window is first mapped it will be displayed in de-iconified form. Returns an empty string. @item @b{wm :focusmodel }@i{window}@r{ ?}@b{active}@r{|}@b{passive}? If @b{active}@r{ or }@b{passive} is supplied as an optional argument to the command, then it specifies the focus model for @i{window}. In this case the command returns an empty string. If no additional argument is supplied, then the command returns the current focus model for @i{window}. An @b{active}@r{ focus model means that }@i{window} will claim the input focus for itself or its descendants, even at times when the focus is currently in some other application. @b{Passive} means that @i{window} will never claim the focus for itself: the window manager should give the focus to @i{window} at appropriate times. However, once the focus has been given to @i{window} or one of its descendants, the application may re-assign the focus among @i{window}'s descendants. The focus model defaults to @b{passive}@r{, and Tk's }@b{focus} command assumes a passive model of focussing. @item @b{wm :frame }@i{window} If @i{window} has been reparented by the window manager into a decorative frame, the command returns the X window identifier for the outermost frame that contains @i{window} (the window whose parent is the root or virtual root). If @i{window} hasn't been reparented by the window manager then the command returns the X window identifier for @i{window}. @item @b{wm :geometry }@i{window}@r{ ?}@i{newGeometry}? If @i{newGeometry}@r{ is specified, then the geometry of }@i{window} is changed and an empty string is returned. Otherwise the current geometry for @i{window} is returned (this is the most recent geometry specified either by manual resizing or in a @b{wm :geometry}@r{ command). }@i{NewGeometry} has the form @b{=}@i{width}@b{x}@i{height}@b{\(+-}@i{x}@b{\(+-}@i{y}, where any of @b{=}@r{, }@i{width}@b{x}@i{height}@r{, or }@b{\(+-}@i{x}@b{\(+-}@i{y} may be omitted. @i{Width}@r{ and }@i{height} are positive integers specifying the desired dimensions of @i{window}@r{. If }@i{window} is gridded (see GRIDDED GEOMETRY MANAGEMENT below) then the dimensions are specified in grid units; otherwise they are specified in pixel units. @i{X}@r{ and }@i{y} specify the desired location of @i{window} on the screen, in pixels. If @i{x}@r{ is preceded by }@b{+}, it specifies the number of pixels between the left edge of the screen and the left edge of @i{window}@r{'s border; if preceded by }@b{-} then @i{x} specifies the number of pixels between the right edge of the screen and the right edge of @i{window}'s border. If @i{y}@r{ is preceded by }@b{+} then it specifies the number of pixels between the top of the screen and the top of @i{window}@r{'s border; if }@i{y}@r{ is preceded by }@b{-} then it specifies the number of pixels between the bottom of @i{window}'s border and the bottom of the screen. If @i{newGeometry} is specified as an empty string then any existing user-specified geometry for @i{window} is cancelled, and the window will revert to the size requested internally by its widgets. @item @b{wm :grid }@i{window}@r{ ?}@i{baseWidth baseHeight widthInc heightInc}? This command indicates that @i{window} is to be managed as a gridded window. It also specifies the relationship between grid units and pixel units. @i{BaseWidth}@r{ and }@i{baseHeight} specify the number of grid units corresponding to the pixel dimensions requested internally by @i{window}@r{ using }@b{Tk_GeometryRequest}@r{. }@i{WidthInc} and @i{heightInc} specify the number of pixels in each horizontal and vertical grid unit. These four values determine a range of acceptable sizes for @i{window}, corresponding to grid-based widths and heights that are non-negative integers. Tk will pass this information to the window manager; during manual resizing, the window manager will restrict the window's size to one of these acceptable sizes. Furthermore, during manual resizing the window manager will display the window's current size in terms of grid units rather than pixels. If @i{baseWidth} etc. are all specified as empty strings, then @i{window} will no longer be managed as a gridded window. If @i{baseWidth} etc. are specified then the return value is an empty string. Otherwise the return value is a Tcl list containing four elements corresponding to the current @i{baseWidth}, @i{baseHeight}@r{, }@i{widthInc}@r{, and }@i{heightInc}; if @i{window} is not currently gridded, then an empty string is returned. Note: this command should not be needed very often, since the @b{Tk_SetGrid}@r{ library procedure and the }@b{setGrid} option provide easier access to the same functionality. @item @b{wm :group }@i{window}@r{ ?}@i{pathName}? If @i{pathName} is specified, it gives the path name for the leader of a group of related windows. The window manager may use this information, for example, to unmap all of the windows in a group when the group's leader is iconified. @i{PathName} may be specified as an empty string to remove @i{window}@r{ from any group association. If }@i{pathName} is specified then the command returns an empty string; otherwise it returns the path name of @i{window}'s current group leader, or an empty string if @i{window} isn't part of any group. @item @b{wm :iconbitmap }@i{window}@r{ ?}@i{bitmap}? If @i{bitmap} is specified, then it names a bitmap in the standard forms accepted by Tk (see the @b{Tk_GetBitmap} manual entry for details). This bitmap is passed to the window manager to be displayed in @i{window}'s icon, and the command returns an empty string. If an empty string is specified for @i{bitmap}, then any current icon bitmap is cancelled for @i{window}. If @i{bitmap} is specified then the command returns an empty string. Otherwise it returns the name of the current icon bitmap associated with @i{window}, or an empty string if @i{window} has no icon bitmap. @item @b{wm :iconify }@i{window} Arrange for @i{window}@r{ to be iconified. It }@i{window} hasn't yet been mapped for the first time, this command will arrange for it to appear in the iconified state when it is eventually mapped. @item @b{wm :iconmask }@i{window}@r{ ?}@i{bitmap}? If @i{bitmap} is specified, then it names a bitmap in the standard forms accepted by Tk (see the @b{Tk_GetBitmap} manual entry for details). This bitmap is passed to the window manager to be used as a mask in conjunction with the @b{iconbitmap} option: where the mask has zeroes no icon will be displayed; where it has ones, the bits from the icon bitmap will be displayed. If an empty string is specified for @i{bitmap} then any current icon mask is cancelled for @i{window} (this is equivalent to specifying a bitmap of all ones). If @i{bitmap} is specified then the command returns an empty string. Otherwise it returns the name of the current icon mask associated with @i{window}, or an empty string if no mask is in effect. @item @b{wm :iconname }@i{window}@r{ ?}@i{newName}? If @i{newName} is specified, then it is passed to the window manager; the window manager should display @i{newName} inside the icon associated with @i{window}. In this case an empty string is returned as result. If @i{newName} isn't specified then the command returns the current icon name for @i{window}, or an empty string if no icon name has been specified (in this case the window manager will normally display the window's title, as specified with the @b{wm :title} command). @item @b{wm :iconposition }@i{window}@r{ ?}@i{x y}? If @i{x}@r{ and }@i{y} are specified, they are passed to the window manager as a hint about where to position the icon for @i{window}. In this case an empty string is returned. If @i{x}@r{ and }@i{y} are specified as empty strings then any existing icon position hint is cancelled. If neither @i{x}@r{ nor }@i{y} is specified, then the command returns a Tcl list containing two values, which are the current icon position hints (if no hints are in effect then an empty string is returned). @item @b{wm :iconwindow }@i{window}@r{ ?}@i{pathName}? If @i{pathName} is specified, it is the path name for a window to use as icon for @i{window}@r{: when }@i{window} is iconified then @i{pathName}@r{ should be mapped to serve as icon, and when }@i{window} is de-iconified then @i{pathName} will be unmapped again. If @i{pathName} is specified as an empty string then any existing icon window association for @i{window} will be cancelled. If the @i{pathName} argument is specified then an empty string is returned. Otherwise the command returns the path name of the current icon window for @i{window}, or an empty string if there is no icon window currently specified for @i{window}. Note: not all window managers support the notion of an icon window. @item @b{wm :maxsize }@i{window}@r{ ?}@i{width height}? If @i{width}@r{ and }@i{height}@r{ are specified, then }@i{window} becomes resizable and @i{width}@r{ and }@i{height} give its maximum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window's dimensions to be less than or equal to @i{width}@r{ and }@i{height}. If @i{width}@r{ and }@i{height} are specified as empty strings, then the maximum size option is cancelled for @i{window}. If @i{width}@r{ and }@i{height} are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the maximum width and height currently in effect; if no maximum dimensions are in effect for @i{window} then an empty string is returned. See the sections on geometry management below for more information. @item @b{wm :minsize }@i{window}@r{ ?}@i{width height}? If @i{width}@r{ and }@i{height}@r{ are specified, then }@i{window} becomes resizable and @i{width}@r{ and }@i{height} give its minimum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window's dimensions to be greater than or equal to @i{width}@r{ and }@i{height}. If @i{width}@r{ and }@i{height} are specified as empty strings, then the minimum size option is cancelled for @i{window}. If @i{width}@r{ and }@i{height} are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the minimum width and height currently in effect; if no minimum dimensions are in effect for @i{window} then an empty string is returned. See the sections on geometry management below for more information. @item @b{wm :overrideredirect }@i{window}@r{ ?}@i{boolean}? If @i{boolean} is specified, it must have a proper boolean form and the override-redirect flag for @i{window} is set to that value. If @i{boolean}@r{ is not specified then }@b{1}@r{ or }@b{0} is returned to indicate whether or not the override-redirect flag is currently set for @i{window}. Setting the override-redirect flag for a window causes it to be ignored by the window manager; among other things, this means that the window will not be reparented from the root window into a decorative frame and the user will not be able to manipulate the window using the normal window manager mechanisms. @item @b{wm :positionfrom }@i{window}@r{ ?}@i{who}? If @i{who}@r{ is specified, it must be either }@b{program} or @b{user}, or an abbreviation of one of these two. It indicates whether @i{window}'s current position was requested by the program or by the user. Many window managers ignore program-requested initial positions and ask the user to manually position the window; if @b{user} is specified then the window manager should position the window at the given place without asking the user for assistance. If @i{who} is specified as an empty string, then the current position source is cancelled. If @i{who} is specified, then the command returns an empty string. Otherwise it returns @b{user}@r{ or }@b{window} to indicate the source of the window's current position, or an empty string if no source has been specified yet. Most window managers interpret ``no source'' as equivalent to @b{program}. Tk will automatically set the position source to @b{user} when a @b{wm :geometry} command is invoked, unless the source has been set explicitly to @b{program}. @item @b{wm :protocol }@i{window}@r{ ?}@i{name}@r{? ?}@i{command}? This command is used to manage window manager protocols such as @b{WM_DELETE_WINDOW}. @i{Name} is the name of an atom corresponding to a window manager protocol, such as @b{WM_DELETE_WINDOW}@r{ or }@b{WM_SAVE_YOURSELF} or @b{WM_TAKE_FOCUS}. If both @i{name}@r{ and }@i{command}@r{ are specified, then }@i{command} is associated with the protocol specified by @i{name}. @i{Name}@r{ will be added to }@i{window}@r{'s }@b{WM_PROTOCOLS} property to tell the window manager that the application has a protocol handler for @i{name}@r{, and }@i{command} will be invoked in the future whenever the window manager sends a message to the client for that protocol. In this case the command returns an empty string. If @i{name}@r{ is specified but }@i{command} isn't, then the current command for @i{name} is returned, or an empty string if there is no handler defined for @i{name}. If @i{command} is specified as an empty string then the current handler for @i{name} is deleted and it is removed from the @b{WM_PROTOCOLS}@r{ property on }@i{window}; an empty string is returned. Lastly, if neither @i{name}@r{ nor }@i{command} is specified, the command returns a list of all the protocols for which handlers are currently defined for @i{window}. @end table Tk always defines a protocol handler for @b{WM_DELETE_WINDOW}, even if you haven't asked for one with @b{wm :protocol}. If a @b{WM_DELETE_WINDOW} message arrives when you haven't defined a handler, then Tk handles the message by destroying the window for which it was received. .RE @table @asis @item @b{wm :sizefrom }@i{window}@r{ ?}@i{who}? If @i{who}@r{ is specified, it must be either }@b{program} or @b{user}, or an abbreviation of one of these two. It indicates whether @i{window}'s current size was requested by the program or by the user. Some window managers ignore program-requested sizes and ask the user to manually size the window; if @b{user} is specified then the window manager should give the window its specified size without asking the user for assistance. If @i{who} is specified as an empty string, then the current size source is cancelled. If @i{who} is specified, then the command returns an empty string. Otherwise it returns @b{user}@r{ or }@b{window} to indicate the source of the window's current size, or an empty string if no source has been specified yet. Most window managers interpret ``no source'' as equivalent to @b{program}. @item @b{wm :state }@i{window} Returns the current state of @i{window}@r{: either }@b{normal}, @b{iconic}@r{, or }@b{withdrawn}. @item @b{wm :title }@i{window}@r{ ?}@i{string}? If @i{string} is specified, then it will be passed to the window manager for use as the title for @i{window} (the window manager should display this string in @i{window}'s title bar). In this case the command returns an empty string. If @i{string} isn't specified then the command returns the current title for the @i{window}. The title for a window defaults to its name. @item @b{wm :transient }@i{window}@r{ ?}@i{master}? If @i{master} is specified, then the window manager is informed that @i{window} is a transient window (e.g. pull-down menu) working on behalf of @i{master}@r{ (where }@i{master} is the path name for a top-level window). Some window managers will use this information to manage @i{window}@r{ specially. If }@i{master} is specified as an empty string then @i{window} is marked as not being a transient window any more. If @i{master} is specified, then the command returns an empty string. Otherwise the command returns the path name of @i{window}'s current master, or an empty string if @i{window} isn't currently a transient window. @item @b{wm :withdraw }@i{window} Arranges for @i{window} to be withdrawn from the screen. This causes the window to be unmapped and forgotten about by the window manager. If the window has never been mapped, then this command causes the window to be mapped in the withdrawn state. Not all window managers appear to know how to handle windows that are mapped in the withdrawn state. Note: it sometimes seems to be necessary to withdraw a window and then re-map it (e.g. with @b{wm :deiconify}) to get some window managers to pay attention to changes in window attributes such as group. @end table @unnumberedsubsec "Sources Of Geometry Information" Size-related information for top-level windows can come from three sources. First, geometry requests come from the widgets that are descendants of a top-level window. Each widget requests a particular size for itself by calling @b{Tk_GeometryRequest}. This information is passed to geometry managers, which then request large enough sizes for parent windows so that they can layout the children properly. Geometry information passes upwards through the window hierarchy until eventually a particular size is requested for each top-level window. These requests are called @i{internal requests} in the discussion below. The second source of width and height information is through the @b{wm :geometry} command. Third, the user can request a particular size for a window using the interactive facilities of the window manager. The second and third types of geometry requests are called @i{external requests} in the discussion below; Tk treats these two kinds of requests identically. @unnumberedsubsec "Ungridded Geometry Management" Tk allows the geometry of a top-level window to be managed in either of two general ways: ungridded or gridded. The ungridded form occurs if no @b{wm :grid} command has been issued for a top-level window. Ungridded management has several variants. In the simplest variant of ungridded windows, no @b{wm :geometry}@r{, }@b{wm :minsize}@r{, or }@b{wm :maxsize} commands have been invoked either. In this case, the window's size is determined totally by the internal requests emanating from the widgets inside the window: Tk will ask the window manager not to permit the user to resize the window interactively. If a @b{wm :geometry} command is invoked on an ungridded window, then the size in that command overrides any size requested by the window's widgets; from now on, the window's size will be determined entirely by the most recent information from @b{wm :geometry} commands. To go back to using the size requested by the window's widgets, issue a @b{wm :geometry}@r{ command with an empty }@i{geometry} string. To enable interactive resizing of an ungridded window, one or both of the @b{wm :maxsize} and @b{wm :minsize} commands must be issued. The information from these commands will be passed to the window manager, and size changes within the specified range will be permitted. For ungridded windows the limits refer to the top-level window's dimensions in pixels. If only a @b{wm :maxsize} command is issued then the minimum dimensions default to 1; if only a @b{wm :minsize} command is issued then the maximum dimensions default to the size of the display. If the size of a window is changed interactively, it has the same effect as if @b{wm :geometry} had been invoked: from now on, internal geometry requests will be ignored. To return to internal control over the window's size, issue a @b{wm :geometry}@r{ command with an empty }@i{geometry} argument. If a window has been manually resized or moved, the @b{wm :geometry} command will return the geometry that was requested interactively. @unnumberedsubsec "Gridded Geometry Management" The second style of geometry management is called @i{gridded}. This approach occurs when one of the widgets of an application supports a range of useful sizes. This occurs, for example, in a text editor where the scrollbars, menus, and other adornments are fixed in size but the edit widget can support any number of lines of text or characters per line. In this case, it is usually desirable to let the user specify the number of lines or characters-per-line, either with the @b{wm :geometry} command or by interactively resizing the window. In the case of text, and in other interesting cases also, only discrete sizes of the window make sense, such as integral numbers of lines and characters-per-line; arbitrary pixel sizes are not useful. Gridded geometry management provides support for this kind of application. Tk (and the window manager) assume that there is a grid of some sort within the application and that the application should be resized in terms of @i{grid units} rather than pixels. Gridded geometry management is typically invoked by turning on the @b{setGrid} option for a widget; it can also be invoked with the @b{wm :grid}@r{ command or by calling }@b{Tk_SetGrid}. In each of these approaches the particular widget (or sometimes code in the application as a whole) specifies the relationship between integral grid sizes for the window and pixel sizes. To return to non-gridded geometry management, invoke @b{wm :grid} with empty argument strings. When gridded geometry management is enabled then all the dimensions specified in @b{wm :minsize}@r{, }@b{wm :maxsize}@r{, and }@b{wm :geometry} commands are treated as grid units rather than pixel units. Interactive resizing is automatically enabled, and it will be carried out in even numbers of grid units rather than pixels. By default there are no limits on the minimum or maximum dimensions of a gridded window. As with ungridded windows, interactive resizing has exactly the same effect as invoking the @b{wm :geometry} command. For gridded windows, internally- and externally-requested dimensions work together: the externally-specified width and height determine the size of the window in grid units, and the information from the last @b{wm :grid} command maps from grid units to pixel units. @unnumberedsubsec Bugs The window manager interactions seem too complicated, especially for managing geometry. Suggestions on how to simplify this would be greatly appreciated. Most existing window managers appear to have bugs that affect the operation of the @b{wm} command. For example, some changes won't take effect if the window is already active: the window will have to be withdrawn and de-iconified in order to make the change happen. @unnumberedsubsec Keywords aspect ratio, deiconify, focus model, geometry, grid, group, icon, iconify, increments, position, size, title, top-level window, units, window manager gcl-2.6.14/info/gcl.info0000644000175000017500000014347214360276512013363 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  Indirect: gcl.info-1: 314 gcl.info-2: 301351 gcl.info-3: 608702 gcl.info-4: 900342 gcl.info-5: 1205418 gcl.info-6: 1502760 gcl.info-7: 1802947 gcl.info-8: 2100572 gcl.info-9: 2402082  Tag Table: (Indirect) Node: Top314 Node: Introduction (Introduction)41180 Node: Scope41532 Node: Scope and Purpose41780 Node: History42223 Node: Organization of the Document51793 Node: Referenced Publications54048 Node: Definitions57705 Node: Notational Conventions58097 Node: Font Key58726 Node: Modified BNF Syntax60567 Node: Splicing in Modified BNF Syntax60942 Node: Indirection in Modified BNF Syntax63438 Node: Additional Uses for Indirect Definitions in Modified BNF Syntax64086 Node: Special Symbols65255 Node: Objects with Multiple Notations70029 Node: Case in Symbols70473 Node: Numbers (Objects with Multiple Notations)71643 Node: Use of the Dot Character72043 Node: NIL72985 Node: Designators75105 Node: Nonsense Words77513 Node: Error Terminology78192 Node: Sections Not Formally Part Of This Standard85515 Node: Interpreting Dictionary Entries87025 Node: The "Affected By" Section of a Dictionary Entry89424 Node: The "Arguments" Section of a Dictionary Entry89957 Node: The "Arguments and Values" Section of a Dictionary Entry90479 Node: The "Binding Types Affected" Section of a Dictionary Entry91242 Node: The "Class Precedence List" Section of a Dictionary Entry91930 Node: Dictionary Entries for Type Specifiers93106 Node: The "Compound Type Specifier Kind" Section of a Dictionary Entry94248 Node: The "Compound Type Specifier Syntax" Section of a Dictionary Entry95299 Node: The "Compound Type Specifier Arguments" Section of a Dictionary Entry95975 Node: The "Compound Type Specifier Description" Section of a Dictionary Entry96542 Node: The "Constant Value" Section of a Dictionary Entry97093 Node: The "Description" Section of a Dictionary Entry97547 Node: The "Examples" Section of a Dictionary Entry98072 Node: The "Exceptional Situations" Section of a Dictionary Entry98561 Node: The "Initial Value" Section of a Dictionary Entry99402 Node: The "Argument Precedence Order" Section of a Dictionary Entry99926 Node: The "Method Signature" Section of a Dictionary Entry100454 Node: The "Name" Section of a Dictionary Entry101986 Node: The "Notes" Section of a Dictionary Entry104046 Node: The "Pronunciation" Section of a Dictionary Entry104756 Node: The "See Also" Section of a Dictionary Entry105571 Node: The "Side Effects" Section of a Dictionary Entry106046 Node: The "Supertypes" Section of a Dictionary Entry106478 Node: The "Syntax" Section of a Dictionary Entry107115 Node: Special "Syntax" Notations for Overloaded Operators108300 Node: Naming Conventions for Rest Parameters109438 Node: Requiring Non-Null Rest Parameters in The "Syntax" Section110293 Node: Return values in The "Syntax" Section111185 Node: No Arguments or Values in The "Syntax" Section111864 Node: Unconditional Transfer of Control in The "Syntax" Section112460 Node: The "Valid Context" Section of a Dictionary Entry113025 Node: The "Value Type" Section of a Dictionary Entry113666 Node: Conformance114021 Node: Conforming Implementations114437 Node: Required Language Features115042 Node: Documentation of Implementation-Dependent Features115671 Node: Documentation of Extensions116398 Node: Treatment of Exceptional Situations117041 Node: Resolution of Apparent Conflicts in Exceptional Situations117440 Node: Examples of Resolution of Apparent Conflict in Exceptional Situations118110 Node: Conformance Statement119114 Node: Conforming Programs120097 Node: Use of Implementation-Defined Language Features121058 Node: Use of Read-Time Conditionals122270 Node: Language Extensions123421 Node: Language Subsets125834 Node: Deprecated Language Features126551 Node: Deprecated Functions127392 Node: Deprecated Argument Conventions128051 Node: Deprecated Variables129164 Node: Deprecated Reader Syntax129413 Node: Symbols in the COMMON-LISP Package129884 Node: Syntax160374 Node: Character Syntax160618 Node: Readtables161371 Node: The Current Readtable162277 Node: The Standard Readtable162862 Node: The Initial Readtable163399 Node: Variables that affect the Lisp Reader163854 Node: Standard Characters164438 Node: Character Syntax Types169760 Node: Constituent Characters173982 Node: Constituent Traits174597 Node: Invalid Characters179000 Node: Macro Characters179548 Node: Multiple Escape Characters182322 Node: Examples of Multiple Escape Characters182977 Node: Single Escape Character183478 Node: Examples of Single Escape Characters183973 Node: Whitespace Characters184463 Node: Examples of Whitespace Characters184812 Node: Reader Algorithm185173 Node: Interpretation of Tokens191679 Node: Numbers as Tokens192039 Node: Potential Numbers as Tokens193289 Node: Escape Characters and Potential Numbers195879 Node: Examples of Potential Numbers196644 Node: Constructing Numbers from Tokens197804 Node: Syntax of a Rational198605 Node: Syntax of an Integer198820 Node: Syntax of a Ratio199411 Node: Syntax of a Float200691 Node: Syntax of a Complex203539 Node: The Consing Dot204595 Node: Symbols as Tokens205119 Node: Valid Patterns for Tokens209047 Node: Package System Consistency Rules212748 Node: Standard Macro Characters214409 Node: Left-Parenthesis215181 Node: Right-Parenthesis216709 Node: Single-Quote217036 Node: Examples of Single-Quote217494 Node: Semicolon217728 Node: Examples of Semicolon218292 Node: Notes about Style for Semicolon218518 Node: Use of Single Semicolon218935 Node: Use of Double Semicolon219526 Node: Use of Triple Semicolon220024 Node: Use of Quadruple Semicolon220404 Node: Examples of Style for Semicolon220914 Node: Double-Quote221887 Node: Backquote223390 Node: Notes about Backquote227313 Node: Comma228384 Node: Sharpsign228675 Node: Sharpsign Backslash233650 Node: Sharpsign Single-Quote234813 Node: Sharpsign Left-Parenthesis235285 Node: Sharpsign Asterisk236805 Node: Examples of Sharpsign Asterisk238069 Node: Sharpsign Colon238487 Node: Sharpsign Dot239003 Node: Sharpsign B239681 Node: Sharpsign O240070 Node: Sharpsign X240474 Node: Sharpsign R240978 Node: Sharpsign C242440 Node: Sharpsign A243600 Node: Sharpsign S244797 Node: Sharpsign P245904 Node: Sharpsign Equal-Sign246321 Node: Sharpsign Sharpsign246842 Node: Sharpsign Plus247911 Node: Sharpsign Minus248953 Node: Sharpsign Vertical-Bar249312 Node: Examples of Sharpsign Vertical-Bar249679 Node: Notes about Style for Sharpsign Vertical-Bar252661 Node: Sharpsign Less-Than-Sign253631 Node: Sharpsign Whitespace254069 Node: Sharpsign Right-Parenthesis254456 Node: Re-Reading Abbreviated Expressions254756 Node: Evaluation and Compilation255249 Node: Evaluation255630 Node: Introduction to Environments256918 Node: The Global Environment257776 Node: Dynamic Environments258427 Node: Lexical Environments259586 Node: The Null Lexical Environment260811 Node: Environment Objects261325 Node: The Evaluation Model262292 Node: Form Evaluation262987 Node: Symbols as Forms263290 Node: Lexical Variables265379 Node: Dynamic Variables266410 Node: Constant Variables268155 Node: Symbols Naming Both Lexical and Dynamic Variables268871 Node: Conses as Forms269722 Node: Special Forms270669 Node: Macro Forms272315 Node: Function Forms274152 Node: Lambda Forms276705 Node: Self-Evaluating Objects277363 Node: Examples of Self-Evaluating Objects278085 Node: Lambda Expressions278541 Node: Closures and Lexical Binding279180 Node: Shadowing282933 Node: Extent286104 Node: Return Values288370 Node: Compilation289751 Node: Compiler Terminology290058 Node: Compilation Semantics294351 Node: Compiler Macros295034 Node: Purpose of Compiler Macros296703 Node: Naming of Compiler Macros298418 Node: When Compiler Macros Are Used299396 Node: Notes about the Implementation of Compiler Macros301351 Node: Minimal Compilation302468 Node: Semantic Constraints303644 Node: File Compilation307298 Node: Processing of Top Level Forms309271 Node: Processing of Defining Macros313498 Node: Constraints on Macros and Compiler Macros316041 Node: Literal Objects in Compiled Files316841 Node: Externalizable Objects318251 Node: Similarity of Literal Objects319879 Node: Similarity of Aggregate Objects320123 Node: Definition of Similarity320707 Node: Extensions to Similarity Rules325575 Node: Additional Constraints on Externalizable Objects326451 Node: Exceptional Situations in the Compiler331188 Node: Declarations333287 Node: Minimal Declaration Processing Requirements334074 Node: Declaration Specifiers335240 Node: Declaration Identifiers335742 Node: Shorthand notation for Type Declarations336588 Node: Declaration Scope336955 Node: Examples of Declaration Scope338928 Node: Lambda Lists342126 Node: Ordinary Lambda Lists345136 Node: Specifiers for the required parameters347779 Node: Specifiers for optional parameters348629 Node: A specifier for a rest parameter349810 Node: Specifiers for keyword parameters350815 Node: Suppressing Keyword Argument Checking354838 Node: Examples of Suppressing Keyword Argument Checking355529 Node: Specifiers for &aux variables356767 Node: Examples of Ordinary Lambda Lists357617 Node: Generic Function Lambda Lists361535 Node: Specialized Lambda Lists362950 Node: Macro Lambda Lists364388 Node: Destructuring by Lambda Lists369811 Node: Data-directed Destructuring by Lambda Lists371002 Node: Examples of Data-directed Destructuring by Lambda Lists371549 Node: Lambda-list-directed Destructuring by Lambda Lists372262 Node: Destructuring Lambda Lists375323 Node: Boa Lambda Lists376623 Node: Defsetf Lambda Lists380499 Node: Deftype Lambda Lists381527 Node: Define-modify-macro Lambda Lists382145 Node: Define-method-combination Arguments Lambda Lists383015 Node: Syntactic Interaction of Documentation Strings and Declarations383866 Node: Error Checking in Function Calls384617 Node: Argument Mismatch Detection384888 Node: Safe and Unsafe Calls385377 Node: Error Detection Time in Safe Calls388140 Node: Too Few Arguments388723 Node: Too Many Arguments389248 Node: Unrecognized Keyword Arguments389896 Node: Invalid Keyword Arguments390516 Node: Odd Number of Keyword Arguments391120 Node: Destructuring Mismatch391706 Node: Errors When Calling a Next Method392243 Node: Traversal Rules and Side Effects393218 Node: Destructive Operations394464 Node: Modification of Literal Objects394789 Node: Transfer of Control during a Destructive Operation397187 Node: Examples of Transfer of Control during a Destructive Operation397684 Node: Evaluation and Compilation Dictionary398560 Node: lambda (Symbol)399243 Node: lambda400441 Node: compile401555 Node: eval404765 Node: eval-when406697 Node: load-time-value413134 Node: quote418947 Node: compiler-macro-function420509 Node: define-compiler-macro421471 Node: defmacro428947 Node: macro-function435110 Node: macroexpand437354 Node: define-symbol-macro442384 Node: symbol-macrolet444934 Node: *macroexpand-hook*448057 Node: proclaim450319 Node: declaim452448 Node: declare453256 Node: ignore457465 Node: dynamic-extent459502 Node: type465888 Node: inline472661 Node: ftype476487 Node: declaration478021 Node: optimize478949 Node: special481191 Node: locally485670 Node: the487835 Node: special-operator-p490228 Node: constantp491141 Node: Types and Classes494160 Node: Introduction (Types and Classes)494422 Node: Types496580 Node: Data Type Definition496792 Node: Type Relationships498074 Node: Type Specifiers499999 Node: Classes509366 Node: Introduction to Classes510281 Node: Standard Metaclasses515009 Node: Defining Classes515968 Node: Creating Instances of Classes517640 Node: Inheritance518431 Node: Examples of Inheritance518895 Node: Inheritance of Class Options519872 Node: Determining the Class Precedence List520692 Node: Topological Sorting522752 Node: Examples of Class Precedence List Determination525185 Node: Redefining Classes528739 Node: Modifying the Structure of Instances531843 Node: Initializing Newly Added Local Slots (Redefining Classes)533028 Node: Customizing Class Redefinition534929 Node: Integrating Types and Classes536008 Node: Types and Classes Dictionary542615 Node: nil (Type)543384 Node: boolean543840 Node: function (System Class)544640 Node: compiled-function549403 Node: generic-function550242 Node: standard-generic-function551279 Node: class551802 Node: built-in-class552338 Node: structure-class553264 Node: standard-class553679 Node: method554077 Node: standard-method555216 Node: structure-object555647 Node: standard-object556246 Node: method-combination556684 Node: t (System Class)557343 Node: satisfies557709 Node: member (Type Specifier)558878 Node: not (Type Specifier)559889 Node: and (Type Specifier)560601 Node: or (Type Specifier)561435 Node: values (Type Specifier)562462 Node: eql (Type Specifier)563725 Node: coerce564496 Node: deftype569142 Node: subtypep572288 Node: type-of579324 Node: typep582215 Node: type-error585608 Node: type-error-datum586311 Node: simple-type-error587646 Node: Data and Control Flow588390 Node: Generalized Reference588655 Node: Overview of Places and Generalized Reference588982 Node: Evaluation of Subforms to Places591408 Node: Examples of Evaluation of Subforms to Places593913 Node: Setf Expansions594635 Node: Examples of Setf Expansions596705 Node: Kinds of Places598807 Node: Variable Names as Places599445 Node: Function Call Forms as Places599723 Node: VALUES Forms as Places608702 Node: THE Forms as Places609840 Node: APPLY Forms as Places610299 Node: Setf Expansions and Places611667 Node: Macro Forms as Places612087 Node: Symbol Macros as Places612621 Node: Other Compound Forms as Places613000 Node: Treatment of Other Macros Based on SETF614031 Node: Transfer of Control to an Exit Point615455 Node: Data and Control Flow Dictionary617276 Node: apply618510 Node: defun620529 Node: fdefinition624262 Node: fboundp626100 Node: fmakunbound627895 Node: flet628871 Node: funcall636716 Node: function (Special Operator)638413 Node: function-lambda-expression640490 Node: functionp643711 Node: compiled-function-p644654 Node: call-arguments-limit645784 Node: lambda-list-keywords646417 Node: lambda-parameters-limit647160 Node: defconstant647811 Node: defparameter650648 Node: destructuring-bind657202 Node: let658519 Node: progv661823 Node: setq663323 Node: psetq664997 Node: block666963 Node: catch668763 Node: go671446 Node: return-from672881 Node: return675149 Node: tagbody676129 Node: throw678542 Node: unwind-protect681203 Node: nil686428 Node: not686822 Node: t687661 Node: eq688642 Node: eql691050 Node: equal694007 Node: equalp697789 Node: identity701900 Node: complement702652 Node: constantly704343 Node: every705309 Node: and708278 Node: cond710024 Node: if711655 Node: or712902 Node: when714301 Node: case716873 Node: typecase721961 Node: multiple-value-bind727520 Node: multiple-value-call729380 Node: multiple-value-list730626 Node: multiple-value-prog1731440 Node: multiple-value-setq732390 Node: values733989 Node: values-list735907 Node: multiple-values-limit736879 Node: nth-value737705 Node: prog738988 Node: prog1742723 Node: progn744858 Node: define-modify-macro746234 Node: defsetf748708 Node: define-setf-expander754820 Node: get-setf-expansion759642 Node: setf761389 Node: shiftf763835 Node: rotatef766420 Node: control-error768135 Node: program-error768756 Node: undefined-function769302 Node: Iteration769907 Node: The LOOP Facility770081 Node: Overview of the Loop Facility770547 Node: Simple vs Extended Loop771328 Node: Simple Loop771629 Node: Extended Loop772322 Node: Loop Keywords772953 Node: Parsing Loop Clauses773887 Node: Expanding Loop Forms775510 Node: Summary of Loop Clauses778207 Node: Summary of Variable Initialization and Stepping Clauses778508 Node: Summary of Value Accumulation Clauses779341 Node: Summary of Termination Test Clauses781131 Node: Summary of Unconditional Execution Clauses782838 Node: Summary of Conditional Execution Clauses783558 Node: Summary of Miscellaneous Clauses784650 Node: Order of Execution785343 Node: Destructuring787215 Node: Restrictions on Side-Effects791628 Node: Variable Initialization and Stepping Clauses791865 Node: Iteration Control792717 Node: The for-as-arithmetic subclause795631 Node: Examples of for-as-arithmetic subclause799477 Node: The for-as-in-list subclause800227 Node: Examples of for-as-in-list subclause801021 Node: The for-as-on-list subclause801807 Node: Examples of for-as-on-list subclause802560 Node: The for-as-equals-then subclause803179 Node: Examples of for-as-equals-then subclause803937 Node: The for-as-across subclause804393 Node: Examples of for-as-across subclause805095 Node: The for-as-hash subclause805482 Node: The for-as-package subclause807704 Node: Examples of for-as-package subclause810268 Node: Local Variable Initializations810888 Node: Examples of WITH clause813729 Node: Value Accumulation Clauses814766 Node: Examples of COLLECT clause820602 Node: Examples of APPEND and NCONC clauses821352 Node: Examples of COUNT clause821971 Node: Examples of MAXIMIZE and MINIMIZE clauses822292 Node: Examples of SUM clause823158 Node: Termination Test Clauses823561 Node: Examples of REPEAT clause827731 Node: Examples of ALWAYS828256 Node: Examples of WHILE and UNTIL clauses830272 Node: Unconditional Execution Clauses831065 Node: Examples of unconditional execution831958 Node: Conditional Execution Clauses832454 Node: Examples of WHEN clause834159 Node: Miscellaneous Clauses835835 Node: Control Transfer Clauses836150 Node: Examples of NAMED clause836978 Node: Initial and Final Execution837368 Node: Examples of Miscellaneous Loop Features838997 Node: Examples of clause grouping840063 Node: Notes about Loop842504 Node: Iteration Dictionary843526 Node: do843731 Node: dotimes852155 Node: dolist855595 Node: loop857806 Node: loop-finish863496 Node: Objects866312 Node: Object Creation and Initialization866616 Node: Initialization Arguments870528 Node: Declaring the Validity of Initialization Arguments873135 Node: Defaulting of Initialization Arguments876634 Node: Rules for Initialization Arguments879905 Node: Shared-Initialize883867 Node: Initialize-Instance886549 Node: Definitions of Make-Instance and Initialize-Instance889284 Node: Changing the Class of an Instance891382 Node: Modifying the Structure of the Instance892634 Node: Initializing Newly Added Local Slots (Changing the Class of an Instance)893572 Node: Customizing the Change of Class of an Instance895309 Node: Reinitializing an Instance896112 Node: Customizing Reinitialization897575 Node: Meta-Objects898239 Node: Standard Meta-objects898765 Node: Slots899804 Node: Introduction to Slots900342 Node: Accessing Slots902980 Node: Inheritance of Slots and Slot Options905557 Node: Generic Functions and Methods910299 Node: Introduction to Generic Functions910794 Node: Introduction to Methods914311 Node: Agreement on Parameter Specializers and Qualifiers920459 Node: Congruent Lambda-lists for all Methods of a Generic Function921456 Node: Keyword Arguments in Generic Functions and Methods923598 Node: Examples of Keyword Arguments in Generic Functions and Methods925290 Node: Method Selection and Combination926629 Node: Determining the Effective Method928095 Node: Selecting the Applicable Methods928689 Node: Sorting the Applicable Methods by Precedence Order929030 Node: Applying method combination to the sorted list of applicable methods931095 Node: Standard Method Combination933262 Node: Declarative Method Combination938209 Node: Built-in Method Combination Types939120 Node: Inheritance of Methods943201 Node: Objects Dictionary943772 Node: function-keywords944780 Node: ensure-generic-function946392 Node: allocate-instance949695 Node: reinitialize-instance951209 Node: shared-initialize953435 Node: update-instance-for-different-class957934 Node: update-instance-for-redefined-class962063 Node: change-class967328 Node: slot-boundp971337 Node: slot-exists-p973114 Node: slot-makunbound973911 Node: slot-missing975444 Node: slot-unbound977774 Node: slot-value979437 Node: method-qualifiers982234 Node: no-applicable-method983020 Node: no-next-method984136 Node: remove-method985330 Node: make-instance986143 Node: make-instances-obsolete987545 Node: make-load-form988847 Node: make-load-form-saving-slots1000335 Node: with-accessors1002278 Node: with-slots1005210 Node: defclass1008569 Node: defgeneric1020992 Node: defmethod1031724 Node: find-class1038765 Node: next-method-p1040735 Node: call-method1041835 Node: call-next-method1044841 Node: compute-applicable-methods1047897 Node: define-method-combination1048950 Node: find-method1072775 Node: add-method1075420 Node: initialize-instance1076645 Node: class-name1078428 Node: setf class-name1079176 Node: class-of1079796 Node: unbound-slot1080787 Node: unbound-slot-instance1081455 Node: Structures1082018 Node: Structures Dictionary1082163 Node: defstruct1082343 Node: copy-structure1123250 Node: Conditions1123841 Node: Condition System Concepts1124016 Node: Condition Types1127625 Node: Serious Conditions1130192 Node: Creating Conditions1130573 Node: Condition Designators1131126 Node: Printing Conditions1132964 Node: Recommended Style in Condition Reporting1134307 Node: Capitalization and Punctuation in Condition Reports1135436 Node: Leading and Trailing Newlines in Condition Reports1136159 Node: Embedded Newlines in Condition Reports1137121 Node: Note about Tabs in Condition Reports1138294 Node: Mentioning Containing Function in Condition Reports1138919 Node: Signaling and Handling Conditions1139404 Node: Signaling1141672 Node: Resignaling a Condition1142872 Node: Restarts1143932 Node: Interactive Use of Restarts1146109 Node: Interfaces to Restarts1147305 Node: Restart Tests1148314 Node: Associating a Restart with a Condition1148794 Node: Assertions1149692 Node: Notes about the Condition System`s Background1150197 Node: Conditions Dictionary1150688 Node: condition1151703 Node: warning1153497 Node: style-warning1153854 Node: serious-condition1155058 Node: error (Condition Type)1156291 Node: cell-error1156656 Node: cell-error-name1157262 Node: parse-error1158252 Node: storage-condition1158722 Node: assert1160308 Node: error1164258 Node: cerror1167945 Node: check-type1173062 Node: simple-error1177338 Node: invalid-method-error1177837 Node: method-combination-error1179389 Node: signal1180514 Node: simple-condition1183070 Node: simple-condition-format-control1183999 Node: warn1185367 Node: simple-warning1187791 Node: invoke-debugger1188264 Node: break1189761 Node: *debugger-hook*1192196 Node: *break-on-signals*1194690 Node: handler-bind1197327 Node: handler-case1199912 Node: ignore-errors1205418 Node: define-condition1207307 Node: make-condition1218846 Node: restart1220148 Node: compute-restarts1220780 Node: find-restart1223539 Node: invoke-restart1225537 Node: invoke-restart-interactively1227272 Node: restart-bind1229585 Node: restart-case1233660 Node: restart-name1243486 Node: with-condition-restarts1244446 Node: with-simple-restart1245778 Node: abort (Restart)1249259 Node: continue1250253 Node: muffle-warning1251413 Node: store-value1253030 Node: use-value1254265 Node: abort (Function)1254902 Node: Symbols1261190 Node: Symbol Concepts1261346 Node: Symbols Dictionary1261959 Node: symbol1262389 Node: keyword1267402 Node: symbolp1268002 Node: keywordp1268744 Node: make-symbol1269613 Node: copy-symbol1271217 Node: gensym1273635 Node: *gensym-counter*1275934 Node: gentemp1276704 Node: symbol-function1279543 Node: symbol-name1282489 Node: symbol-package1283184 Node: symbol-plist1285017 Node: symbol-value1286216 Node: get1288207 Node: remprop1291439 Node: boundp1294044 Node: makunbound1295027 Node: set1295785 Node: unbound-variable1297509 Node: Packages1298080 Node: Package Concepts1298247 Node: Introduction to Packages1298460 Node: Package Names and Nicknames1300364 Node: Symbols in a Package1301135 Node: Internal and External Symbols1301348 Node: Package Inheritance1302263 Node: Accessibility of Symbols in a Package1303213 Node: Locating a Symbol in a Package1304826 Node: Prevention of Name Conflicts in Packages1305445 Node: Standardized Packages1308809 Node: The COMMON-LISP Package1309771 Node: Constraints on the COMMON-LISP Package for Conforming Implementations1311106 Node: Constraints on the COMMON-LISP Package for Conforming Programs1312652 Node: Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs1314763 Node: The COMMON-LISP-USER Package1316610 Node: The KEYWORD Package1317209 Node: Interning a Symbol in the KEYWORD Package1318072 Node: Notes about The KEYWORD Package1318662 Node: Implementation-Defined Packages1319585 Node: Packages Dictionary1320154 Node: package1320826 Node: export1321279 Node: find-symbol1324350 Node: find-package1326759 Node: find-all-symbols1327777 Node: import1328760 Node: list-all-packages1331258 Node: rename-package1331926 Node: shadow1333203 Node: shadowing-import1335565 Node: delete-package1337486 Node: make-package1342466 Node: with-package-iterator1344509 Node: unexport1350151 Node: unintern1351699 Node: in-package1353784 Node: unuse-package1354752 Node: use-package1356156 Node: defpackage1358234 Node: do-symbols1366658 Node: intern1370217 Node: package-name1372552 Node: package-nicknames1373598 Node: package-shadowing-symbols1374371 Node: package-use-list1375592 Node: package-used-by-list1376482 Node: packagep1377348 Node: *package*1377992 Node: package-error1379358 Node: package-error-package1380017 Node: Numbers (Numbers)1380709 Node: Number Concepts1380875 Node: Numeric Operations1381253 Node: Associativity and Commutativity in Numeric Operations1383468 Node: Examples of Associativity and Commutativity in Numeric Operations1384591 Node: Contagion in Numeric Operations1386251 Node: Viewing Integers as Bits and Bytes1386768 Node: Logical Operations on Integers1387022 Node: Byte Operations on Integers1388140 Node: Implementation-Dependent Numeric Constants1388967 Node: Rational Computations1390246 Node: Rule of Unbounded Rational Precision1390658 Node: Rule of Canonical Representation for Rationals1391113 Node: Rule of Float Substitutability1392224 Node: Floating-point Computations1395202 Node: Rule of Float and Rational Contagion1395682 Node: Examples of Rule of Float and Rational Contagion1396579 Node: Rule of Float Approximation1397637 Node: Rule of Float Underflow and Overflow1398819 Node: Rule of Float Precision Contagion1399261 Node: Complex Computations1399612 Node: Rule of Complex Substitutability1400099 Node: Rule of Complex Contagion1400500 Node: Rule of Canonical Representation for Complex Rationals1400907 Node: Examples of Rule of Canonical Representation for Complex Rationals1401771 Node: Principal Values and Branch Cuts1402428 Node: Interval Designators1404479 Node: Random-State Operations1405994 Node: Numbers Dictionary1406361 Node: number1407732 Node: complex (System Class)1408894 Node: real1411134 Node: float (System Class)1412289 Node: short-float1414947 Node: rational (System Class)1418992 Node: ratio1420024 Node: integer1420623 Node: signed-byte1421991 Node: unsigned-byte1423024 Node: mod (System Class)1424150 Node: bit (System Class)1424892 Node: fixnum1425253 Node: bignum1425744 Node: =1426050 Node: max1429657 Node: minusp1431700 Node: zerop1432619 Node: floor1433595 Node: sin1438404 Node: asin1439217 Node: pi1446395 Node: sinh1447503 Node: *1452173 Node: +1453003 Node: -1453795 Node: /1454940 Node: 1+1456552 Node: abs1457502 Node: evenp1458937 Node: exp1459840 Node: gcd1463019 Node: incf1464041 Node: lcm1465218 Node: log1466321 Node: mod (Function)1468475 Node: signum1469773 Node: sqrt1471430 Node: random-state1473492 Node: make-random-state1474337 Node: random1476274 Node: random-state-p1477768 Node: *random-state*1478532 Node: numberp1479960 Node: cis1480624 Node: complex1481194 Node: complexp1482836 Node: conjugate1483483 Node: phase1484250 Node: realpart1485801 Node: upgraded-complex-part-type1486786 Node: realp1487765 Node: numerator1488388 Node: rational (Function)1489436 Node: rationalp1490984 Node: ash1491644 Node: integer-length1493141 Node: integerp1494787 Node: parse-integer1495428 Node: boole1497537 Node: boole-11502760 Node: logand1503868 Node: logbitp1507989 Node: logcount1509172 Node: logtest1510574 Node: byte1511637 Node: deposit-field1512870 Node: dpb1513891 Node: ldb1515329 Node: ldb-test1516924 Node: mask-field1517755 Node: most-positive-fixnum1519081 Node: decode-float1519755 Node: float1525479 Node: floatp1526406 Node: most-positive-short-float1527031 Node: short-float-epsilon1531332 Node: arithmetic-error1532717 Node: arithmetic-error-operands1533471 Node: division-by-zero1534382 Node: floating-point-invalid-operation1534860 Node: floating-point-inexact1535648 Node: floating-point-overflow1536403 Node: floating-point-underflow1536912 Node: Characters1537395 Node: Character Concepts1537571 Node: Introduction to Characters1538065 Node: Introduction to Scripts and Repertoires1539529 Node: Character Scripts1539837 Node: Character Repertoires1540850 Node: Character Attributes1541761 Node: Character Categories1542769 Node: Graphic Characters1543992 Node: Alphabetic Characters1544919 Node: Characters With Case1545582 Node: Uppercase Characters1546036 Node: Lowercase Characters1546491 Node: Corresponding Characters in the Other Case1546965 Node: Case of Implementation-Defined Characters1547496 Node: Numeric Characters1547997 Node: Alphanumeric Characters1548505 Node: Digits in a Radix1548824 Node: Identity of Characters1549552 Node: Ordering of Characters1549822 Node: Character Names1551612 Node: Treatment of Newline during Input and Output1552755 Node: Character Encodings1553306 Node: Documentation of Implementation-Defined Scripts1554104 Node: Characters Dictionary1555575 Node: character (System Class)1556078 Node: base-char1556689 Node: standard-char1558673 Node: extended-char1559213 Node: char=1559674 Node: character1565738 Node: characterp1566607 Node: alpha-char-p1567533 Node: alphanumericp1568695 Node: digit-char1570080 Node: digit-char-p1571187 Node: graphic-char-p1572675 Node: standard-char-p1573552 Node: char-upcase1574392 Node: upper-case-p1576811 Node: char-code1578338 Node: char-int1579058 Node: code-char1580045 Node: char-code-limit1580800 Node: char-name1581460 Node: name-char1583367 Node: Conses1584236 Node: Cons Concepts1584384 Node: Conses as Trees1584933 Node: General Restrictions on Parameters that must be Trees1585981 Node: Conses as Lists1586415 Node: Lists as Association Lists1587871 Node: Lists as Sets1588406 Node: General Restrictions on Parameters that must be Lists1588991 Node: Conses Dictionary1589648 Node: list (System Class)1590410 Node: null (System Class)1591644 Node: cons (System Class)1592136 Node: atom (Type)1593362 Node: cons1593602 Node: consp1594506 Node: atom1595216 Node: rplaca1595909 Node: car1597033 Node: copy-tree1603439 Node: sublis1605051 Node: subst1608774 Node: tree-equal1613121 Node: copy-list1614893 Node: list (Function)1616197 Node: list-length1617800 Node: listp1619699 Node: make-list1620493 Node: push1621445 Node: pop1622678 Node: first1623966 Node: nth1626733 Node: endp1627775 Node: null1629168 Node: nconc1629967 Node: append1632083 Node: revappend1633205 Node: butlast1635378 Node: last1637185 Node: ldiff1638932 Node: nthcdr1642556 Node: rest1643680 Node: member (Function)1644647 Node: mapc1646928 Node: acons1651120 Node: assoc1652126 Node: copy-alist1655345 Node: pairlis1656609 Node: rassoc1658125 Node: get-properties1660236 Node: getf1661608 Node: remf1664450 Node: intersection1665796 Node: adjoin1669716 Node: pushnew1671648 Node: set-difference1674378 Node: set-exclusive-or1677734 Node: subsetp1680812 Node: union1682826 Node: Arrays1685909 Node: Array Concepts1686055 Node: Array Elements1686243 Node: Array Indices1686800 Node: Array Dimensions1687215 Node: Implementation Limits on Individual Array Dimensions1687805 Node: Array Rank1688230 Node: Vectors1688715 Node: Fill Pointers1688921 Node: Multidimensional Arrays1689653 Node: Storage Layout for Multidimensional Arrays1689864 Node: Implementation Limits on Array Rank1690378 Node: Specialized Arrays1690752 Node: Array Upgrading1692213 Node: Required Kinds of Specialized Arrays1693595 Node: Arrays Dictionary1695222 Node: array1696037 Node: simple-array1699085 Node: vector (System Class)1701034 Node: simple-vector1703130 Node: bit-vector1704139 Node: simple-bit-vector1705180 Node: make-array1706162 Node: adjust-array1714817 Node: adjustable-array-p1722816 Node: aref1723785 Node: array-dimension1725459 Node: array-dimensions1726318 Node: array-element-type1727164 Node: array-has-fill-pointer-p1728548 Node: array-displacement1729698 Node: array-in-bounds-p1731369 Node: array-rank1732539 Node: array-row-major-index1733308 Node: array-total-size1734825 Node: arrayp1736094 Node: fill-pointer1736845 Node: row-major-aref1737986 Node: upgraded-array-element-type1739073 Node: array-dimension-limit1740675 Node: array-rank-limit1741204 Node: array-total-size-limit1741698 Node: simple-vector-p1742466 Node: svref1743218 Node: vector1744277 Node: vector-pop1745173 Node: vector-push1746434 Node: vectorp1749247 Node: bit (Array)1749944 Node: bit-and1751266 Node: bit-vector-p1755663 Node: simple-bit-vector-p1756459 Node: Strings1757161 Node: String Concepts1757314 Node: Implications of Strings Being Arrays1757530 Node: Subtypes of STRING1758019 Node: Strings Dictionary1758426 Node: string (System Class)1758765 Node: base-string1759833 Node: simple-string1760779 Node: simple-base-string1761818 Node: simple-string-p1762728 Node: char1763481 Node: string1764998 Node: string-upcase1766257 Node: string-trim1770275 Node: string=1771901 Node: stringp1777370 Node: make-string1777983 Node: Sequences1778920 Node: Sequence Concepts1779117 Node: General Restrictions on Parameters that must be Sequences1780930 Node: Rules about Test Functions1781315 Node: Satisfying a Two-Argument Test1781584 Node: Examples of Satisfying a Two-Argument Test1784144 Node: Satisfying a One-Argument Test1785436 Node: Examples of Satisfying a One-Argument Test1787366 Node: Sequences Dictionary1787959 Node: sequence1788398 Node: copy-seq1789105 Node: elt1790257 Node: fill1791330 Node: make-sequence1792716 Node: subseq1794821 Node: map1796902 Node: map-into1799758 Node: reduce1802947 Node: count1806240 Node: length1808318 Node: reverse1809299 Node: sort1811428 Node: find1816863 Node: position1819099 Node: search1821241 Node: mismatch1823167 Node: replace1825470 Node: substitute1827776 Node: concatenate1833684 Node: merge1835854 Node: remove1839996 Node: remove-duplicates1846346 Node: Hash Tables1849840 Node: Hash Table Concepts1850016 Node: Hash-Table Operations1850248 Node: Modifying Hash Table Keys1852287 Node: Visible Modification of Objects with respect to EQ and EQL1854196 Node: Visible Modification of Objects with respect to EQUAL1854657 Node: Visible Modification of Conses with respect to EQUAL1855252 Node: Visible Modification of Bit Vectors and Strings with respect to EQUAL1855739 Node: Visible Modification of Objects with respect to EQUALP1856400 Node: Visible Modification of Structures with respect to EQUALP1857010 Node: Visible Modification of Arrays with respect to EQUALP1857491 Node: Visible Modification of Hash Tables with respect to EQUALP1858095 Node: Visible Modifications by Language Extensions1858804 Node: Hash Tables Dictionary1859564 Node: hash-table1859986 Node: make-hash-table1860763 Node: hash-table-p1863671 Node: hash-table-count1864408 Node: hash-table-rehash-size1865794 Node: hash-table-rehash-threshold1867305 Node: hash-table-size1868350 Node: hash-table-test1869123 Node: gethash1869981 Node: remhash1872121 Node: maphash1872958 Node: with-hash-table-iterator1874789 Node: clrhash1878221 Node: sxhash1879063 Node: Filenames1882037 Node: Overview of Filenames1882241 Node: Namestrings as Filenames1883040 Node: Pathnames as Filenames1884133 Node: Parsing Namestrings Into Pathnames1887573 Node: Pathnames1888315 Node: Pathname Components1888553 Node: The Pathname Host Component1889041 Node: The Pathname Device Component1889349 Node: The Pathname Directory Component1889730 Node: The Pathname Name Component1890079 Node: The Pathname Type Component1890396 Node: The Pathname Version Component1890809 Node: Interpreting Pathname Component Values1891458 Node: Strings in Component Values1892662 Node: Special Characters in Pathname Components1892933 Node: Case in Pathname Components1893835 Node: Local Case in Pathname Components1894626 Node: Common Case in Pathname Components1895425 Node: Special Pathname Component Values1896218 Node: NIL as a Component Value1896486 Node: ->WILD as a Component Value1897030 Node: ->UNSPECIFIC as a Component Value1898061 Node: Relation between component values NIL and ->UNSPECIFIC1899452 Node: Restrictions on Wildcard Pathnames1900299 Node: Restrictions on Examining Pathname Components1901162 Node: Restrictions on Examining a Pathname Host Component1902210 Node: Restrictions on Examining a Pathname Device Component1902649 Node: Restrictions on Examining a Pathname Directory Component1903353 Node: Directory Components in Non-Hierarchical File Systems1906956 Node: Restrictions on Examining a Pathname Name Component1907604 Node: Restrictions on Examining a Pathname Type Component1908031 Node: Restrictions on Examining a Pathname Version Component1908459 Node: Notes about the Pathname Version Component1909438 Node: Restrictions on Constructing Pathnames1910050 Node: Merging Pathnames1911592 Node: Examples of Merging Pathnames1912370 Node: Logical Pathnames1913247 Node: Syntax of Logical Pathname Namestrings1913486 Node: Additional Information about Parsing Logical Pathname Namestrings1915466 Node: The Host part of a Logical Pathname Namestring1915856 Node: The Device part of a Logical Pathname Namestring1916501 Node: The Directory part of a Logical Pathname Namestring1917032 Node: The Type part of a Logical Pathname Namestring1917630 Node: The Version part of a Logical Pathname Namestring1918125 Node: Wildcard Words in a Logical Pathname Namestring1918777 Node: Lowercase Letters in a Logical Pathname Namestring1919292 Node: Other Syntax in a Logical Pathname Namestring1919732 Node: Logical Pathname Components1920247 Node: Unspecific Components of a Logical Pathname1920554 Node: Null Strings as Components of a Logical Pathname1920986 Node: Filenames Dictionary1921348 Node: pathname (System Class)1921904 Node: logical-pathname (System Class)1922348 Node: pathname1922971 Node: make-pathname1925689 Node: pathnamep1930205 Node: pathname-host1931073 Node: load-logical-pathname-translations1935777 Node: logical-pathname-translations1937628 Node: logical-pathname1945662 Node: *default-pathname-defaults*1947029 Node: namestring1948249 Node: parse-namestring1952181 Node: wild-pathname-p1956931 Node: pathname-match-p1959054 Node: translate-logical-pathname1960272 Node: translate-pathname1962950 Node: merge-pathnames1969567 Node: Files1974203 Node: File System Concepts1974354 Node: Coercion of Streams to Pathnames1975365 Node: File Operations on Open and Closed Streams1976302 Node: Truenames1977550 Node: Examples of Truenames1978465 Node: Files Dictionary1980035 Node: directory1980352 Node: probe-file1981901 Node: ensure-directories-exist1983162 Node: truename1984788 Node: file-author1987420 Node: file-write-date1988445 Node: rename-file1989708 Node: delete-file1992235 Node: file-error1994031 Node: file-error-pathname1994790 Node: Streams1995334 Node: Stream Concepts1995484 Node: Introduction to Streams1995770 Node: Abstract Classifications of Streams (Introduction to Streams)1997026 Node: Input1997281 Node: Open and Closed Streams1999009 Node: Interactive Streams1999965 Node: Abstract Classifications of Streams2001361 Node: File Streams2001593 Node: Other Subclasses of Stream2002297 Node: Stream Variables2003645 Node: Stream Arguments to Standardized Functions2004974 Node: Restrictions on Composite Streams2008023 Node: Streams Dictionary2008530 Node: stream2009807 Node: broadcast-stream2010400 Node: concatenated-stream2013185 Node: echo-stream2014430 Node: file-stream2015186 Node: string-stream2015754 Node: synonym-stream2016377 Node: two-way-stream2017201 Node: input-stream-p2017757 Node: interactive-stream-p2018860 Node: open-stream-p2019944 Node: stream-element-type2020838 Node: streamp2022189 Node: read-byte2022844 Node: write-byte2024279 Node: peek-char2025398 Node: read-char2028204 Node: read-char-no-hang2030033 Node: terpri2032230 Node: unread-char2033786 Node: write-char2035753 Node: read-line2036631 Node: write-string2038643 Node: read-sequence2040229 Node: write-sequence2042524 Node: file-length2044145 Node: file-position2045180 Node: file-string-length2049033 Node: open2049809 Node: stream-external-format2059560 Node: with-open-file2060490 Node: close2063775 Node: with-open-stream2065934 Node: listen2067178 Node: clear-input2068292 Node: finish-output2070138 Node: y-or-n-p2071814 Node: make-synonym-stream2074450 Node: synonym-stream-symbol2075547 Node: broadcast-stream-streams2076067 Node: make-broadcast-stream2076608 Node: make-two-way-stream2077665 Node: two-way-stream-input-stream2078733 Node: echo-stream-input-stream2079574 Node: make-echo-stream2080330 Node: concatenated-stream-streams2081397 Node: make-concatenated-stream2082176 Node: get-output-stream-string2083073 Node: make-string-input-stream2084652 Node: make-string-output-stream2085812 Node: with-input-from-string2086933 Node: with-output-to-string2089485 Node: *debug-io*2092171 Node: *terminal-io*2096865 Node: stream-error2098379 Node: stream-error-stream2099028 Node: end-of-file2099768 Node: Printer2100572 Node: The Lisp Printer2100773 Node: Overview of The Lisp Printer2101056 Node: Multiple Possible Textual Representations2101758 Node: Printer Escaping2103947 Node: Printer Dispatching2104871 Node: Default Print-Object Methods2105437 Node: Printing Numbers2106348 Node: Printing Integers2106542 Node: Printing Ratios2107275 Node: Printing Floats2108025 Node: Printing Complexes2109660 Node: Note about Printing Numbers2110160 Node: Printing Characters2110508 Node: Printing Symbols2111447 Node: Package Prefixes for Symbols2112970 Node: Effect of Readtable Case on the Lisp Printer2114863 Node: Examples of Effect of Readtable Case on the Lisp Printer2116716 Node: Printing Strings2120133 Node: Printing Lists and Conses2120764 Node: Printing Bit Vectors2123210 Node: Printing Other Vectors2123859 Node: Printing Other Arrays2125357 Node: Examples of Printing Arrays2127618 Node: Printing Random States2128341 Node: Printing Pathnames2129226 Node: Printing Structures2129813 Node: Printing Other Objects2130755 Node: Examples of Printer Behavior2131631 Node: The Lisp Pretty Printer2133132 Node: Pretty Printer Concepts2133432 Node: Dynamic Control of the Arrangement of Output2135046 Node: Format Directive Interface2138088 Node: Compiling Format Strings2139476 Node: Pretty Print Dispatch Tables2140109 Node: Pretty Printer Margins2141713 Node: Examples of using the Pretty Printer2142210 Node: Notes about the Pretty Printer`s Background2153911 Node: Formatted Output2154432 Node: FORMAT Basic Output2159127 Node: Tilde C-> Character2159454 Node: Tilde Percent-> Newline2161259 Node: Tilde Ampersand-> Fresh-Line2161613 Node: Tilde Vertical-Bar-> Page2162023 Node: Tilde Tilde-> Tilde2162314 Node: FORMAT Radix Control2162523 Node: Tilde R-> Radix2162836 Node: Tilde D-> Decimal2164101 Node: Tilde B-> Binary2165416 Node: Tilde O-> Octal2165853 Node: Tilde X-> Hexadecimal2166291 Node: FORMAT Floating-Point Printers2166724 Node: Tilde F-> Fixed-Format Floating-Point2167121 Node: Tilde E-> Exponential Floating-Point2171212 Node: Tilde G-> General Floating-Point2176329 Node: Tilde Dollarsign-> Monetary Floating-Point2177696 Node: FORMAT Printer Operations2179962 Node: Tilde A-> Aesthetic2180261 Node: Tilde S-> Standard2181500 Node: Tilde W-> Write2181927 Node: FORMAT Pretty Printer Operations2182735 Node: Tilde Underscore-> Conditional Newline2183173 Node: Tilde Less-Than-Sign-> Logical Block2183665 Node: Tilde I-> Indent2187183 Node: Tilde Slash-> Call Function2187549 Node: FORMAT Layout Control2189409 Node: Tilde T-> Tabulate2189744 Node: Tilde Less-Than-Sign-> Justification2191969 Node: Tilde Greater-Than-Sign-> End of Justification2195385 Node: FORMAT Control-Flow Operations2195718 Node: Tilde Asterisk-> Go-To2196207 Node: Tilde Left-Bracket-> Conditional Expression2197100 Node: Tilde Right-Bracket-> End of Conditional Expression2199603 Node: Tilde Left-Brace-> Iteration2200004 Node: Tilde Right-Brace-> End of Iteration2203282 Node: Tilde Question-Mark-> Recursive Processing2203637 Node: FORMAT Miscellaneous Operations2204990 Node: Tilde Left-Paren-> Case Conversion2205353 Node: Tilde Right-Paren-> End of Case Conversion2206635 Node: Tilde P-> Plural2206989 Node: FORMAT Miscellaneous Pseudo-Operations2207768 Node: Tilde Semicolon-> Clause Separator2208166 Node: Tilde Circumflex-> Escape Upward2208551 Node: Tilde Newline-> Ignored Newline2211983 Node: Additional Information about FORMAT Operations2213395 Node: Nesting of FORMAT Operations2213839 Node: Missing and Additional FORMAT Arguments2215230 Node: Additional FORMAT Parameters2215723 Node: Undefined FORMAT Modifier Combinations2216124 Node: Examples of FORMAT2216535 Node: Notes about FORMAT2220515 Node: Printer Dictionary2221157 Node: copy-pprint-dispatch2221926 Node: formatter2222666 Node: pprint-dispatch2223856 Node: pprint-exit-if-list-exhausted2225386 Node: pprint-fill2226979 Node: pprint-indent2230407 Node: pprint-logical-block2232263 Node: pprint-newline2237752 Node: pprint-pop2242091 Node: pprint-tab2245302 Node: print-object2246687 Node: print-unreadable-object2251444 Node: set-pprint-dispatch2253262 Node: write2255448 Node: write-to-string2259749 Node: *print-array*2261941 Node: *print-base*2262789 Node: *print-case*2265097 Node: *print-circle*2267453 Node: *print-escape*2269073 Node: *print-gensym*2270212 Node: *print-level*2270862 Node: *print-lines*2273942 Node: *print-miser-width*2275328 Node: *print-pprint-dispatch*2275874 Node: *print-pretty*2277184 Node: *print-readably*2279094 Node: *print-right-margin*2282865 Node: print-not-readable2283743 Node: print-not-readable-object2284589 Node: format2285160 Node: Reader2286919 Node: Reader Concepts2287079 Node: Dynamic Control of the Lisp Reader2287365 Node: Effect of Readtable Case on the Lisp Reader2287751 Node: Examples of Effect of Readtable Case on the Lisp Reader2288796 Node: Argument Conventions of Some Reader Functions2290317 Node: The EOF-ERROR-P argument2290638 Node: The RECURSIVE-P argument2292267 Node: Reader Dictionary2295038 Node: readtable2295558 Node: copy-readtable2296367 Node: make-dispatch-macro-character2298260 Node: read2299513 Node: read-delimited-list2304716 Node: read-from-string2308419 Node: readtable-case2310892 Node: readtablep2312085 Node: set-dispatch-macro-character2312749 Node: set-macro-character2315815 Node: set-syntax-from-char2318369 Node: with-standard-io-syntax2320481 Node: *read-base*2323161 Node: *read-default-float-format*2324515 Node: *read-eval*2326054 Node: *read-suppress*2326764 Node: *readtable*2330412 Node: reader-error2331464 Node: System Construction2331998 Node: System Construction Concepts2332214 Node: Loading2332466 Node: Features2333423 Node: Feature Expressions2333932 Node: Examples of Feature Expressions2334955 Node: System Construction Dictionary2336740 Node: compile-file2337147 Node: compile-file-pathname2341905 Node: load2343950 Node: with-compilation-unit2349533 Node: *features*2351754 Node: *compile-file-pathname*2357191 Node: *load-pathname*2358503 Node: *compile-print*2359725 Node: *load-print*2360327 Node: *modules*2360965 Node: provide2361523 Node: Environment2364364 Node: The External Environment2364565 Node: Top level loop2364832 Node: Debugging Utilities2365701 Node: Environment Inquiry2366224 Node: Time2366959 Node: Decoded Time2368260 Node: Universal Time2369831 Node: Internal Time2370911 Node: Seconds2371529 Node: Environment Dictionary2372078 Node: decode-universal-time2372784 Node: encode-universal-time2374722 Node: get-universal-time2375884 Node: sleep2378019 Node: apropos2379099 Node: describe2380635 Node: describe-object2382478 Node: trace2385370 Node: step2388238 Node: time2389565 Node: internal-time-units-per-second2391440 Node: get-internal-real-time2392052 Node: get-internal-run-time2392902 Node: disassemble2394235 Node: documentation2395612 Node: room2402082 Node: ed2403175 Node: inspect2404633 Node: dribble2405524 Node: - (Variable)2407399 Node: + (Variable)2408041 Node: * (Variable)2409103 Node: / (Variable)2410639 Node: lisp-implementation-type2411783 Node: short-site-name2413000 Node: machine-instance2413949 Node: machine-type2414747 Node: machine-version2415402 Node: software-type2416108 Node: user-homedir-pathname2417114 Node: Glossary (Glossary)2418420 Node: Glossary2418561 Node: Appendix2579627 Node: Removed Language Features2579765 Node: Requirements for removed and deprecated features2580128 Node: Removed Types2581331 Node: Removed Operators2581564 Node: Removed Argument Conventions2581943 Node: Removed Variables2582261 Node: Removed Reader Syntax2582625 Node: Packages No Longer Required2582881  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.6.14/info/chap-7.texi0000644000175000017500000067740414360276512013722 0ustar cammcamm @node Objects, Structures, Iteration, Top @chapter Objects @menu * Object Creation and Initialization:: * Changing the Class of an Instance:: * Reinitializing an Instance:: * Meta-Objects:: * Slots:: * Generic Functions and Methods:: * Objects Dictionary:: @end menu @node Object Creation and Initialization, Changing the Class of an Instance, Objects, Objects @section Object Creation and Initialization @c including concept-objects The @i{generic function} @b{make-instance} creates and returns a new @i{instance} of a @i{class}. The first argument is a @i{class} or the @i{name} of a @i{class}, and the remaining arguments form an @i{initialization argument list} @IGindex initialization argument list . The initialization of a new @i{instance} consists of several distinct steps, including the following: combining the explicitly supplied initialization arguments with default values for the unsupplied initialization arguments, checking the validity of the initialization arguments, allocating storage for the @i{instance}, filling @i{slots} with values, and executing user-supplied @i{methods} that perform additional initialization. Each step of @b{make-instance} is implemented by a @i{generic function} to provide a mechanism for customizing that step. In addition, @b{make-instance} is itself a @i{generic function} and thus also can be customized. The object system specifies system-supplied primary @i{methods} for each step and thus specifies a well-defined standard behavior for the entire initialization process. The standard behavior provides four simple mechanisms for controlling initialization: @table @asis @item @t{*} Declaring a @i{symbol} to be an initialization argument for a @i{slot}. An initialization argument is declared by using the @t{:initarg} slot option to @b{defclass}. This provides a mechanism for supplying a value for a @i{slot} in a call to @b{make-instance}. @item @t{*} Supplying a default value form for an initialization argument. Default value forms for initialization arguments are defined by using the @t{:default-initargs} class option to @b{defclass}. If an initialization argument is not explicitly provided as an argument to @b{make-instance}, the default value form is evaluated in the lexical environment of the @b{defclass} form that defined it, and the resulting value is used as the value of the initialization argument. @item @t{*} Supplying a default initial value form for a @i{slot}. A default initial value form for a @i{slot} is defined by using the @t{:initform} slot option to @b{defclass}. If no initialization argument associated with that @i{slot} is given as an argument to @b{make-instance} or is defaulted by @t{:default-initargs}, this default initial value form is evaluated in the lexical environment of the @b{defclass} form that defined it, and the resulting value is stored in the @i{slot}. The @t{:initform} form for a @i{local slot} may be used when creating an @i{instance}, when updating an @i{instance} to conform to a redefined @i{class}, or when updating an @i{instance} to conform to the definition of a different @i{class}. The @t{:initform} form for a @i{shared slot} may be used when defining or re-defining the @i{class}. @item @t{*} Defining @i{methods} for @b{initialize-instance} and @b{shared-initialize}. The slot-filling behavior described above is implemented by a system-supplied primary @i{method} for @b{initialize-instance} which invokes @b{shared-initialize}. The @i{generic function} @b{shared-initialize} implements the parts of initialization shared by these four situations: when making an @i{instance}, when re-initializing an @i{instance}, when updating an @i{instance} to conform to a redefined @i{class}, and when updating an @i{instance} to conform to the definition of a different @i{class}. The system-supplied primary @i{method} for @b{shared-initialize} directly implements the slot-filling behavior described above, and @b{initialize-instance} simply invokes @b{shared-initialize}. @end table @menu * Initialization Arguments:: * Declaring the Validity of Initialization Arguments:: * Defaulting of Initialization Arguments:: * Rules for Initialization Arguments:: * Shared-Initialize:: * Initialize-Instance:: * Definitions of Make-Instance and Initialize-Instance:: @end menu @node Initialization Arguments, Declaring the Validity of Initialization Arguments, Object Creation and Initialization, Object Creation and Initialization @subsection Initialization Arguments An initialization argument controls @i{object} creation and initialization. It is often convenient to use keyword @i{symbols} to name initialization arguments, but the @i{name} of an initialization argument can be any @i{symbol}, including @b{nil}. An initialization argument can be used in two ways: to fill a @i{slot} with a value or to provide an argument for an initialization @i{method}. A single initialization argument can be used for both purposes. An @i{initialization argument list} is a @i{property list} of initialization argument names and values. Its structure is identical to a @i{property list} and also to the portion of an argument list processed for @b{&key} parameters. As in those lists, if an initialization argument name appears more than once in an initialization argument list, the leftmost occurrence supplies the value and the remaining occurrences are ignored. The arguments to @b{make-instance} (after the first argument) form an @i{initialization argument list}. An initialization argument can be associated with a @i{slot}. If the initialization argument has a value in the @i{initialization argument list}, the value is stored into the @i{slot} of the newly created @i{object}, overriding any @t{:initform} form associated with the @i{slot}. A single initialization argument can initialize more than one @i{slot}. An initialization argument that initializes a @i{shared slot} stores its value into the @i{shared slot}, replacing any previous value. An initialization argument can be associated with a @i{method}. When an @i{object} is created and a particular initialization argument is supplied, the @i{generic functions} @b{initialize-instance}, @b{shared-initialize}, and @b{allocate-instance} are called with that initialization argument's name and value as a keyword argument pair. If a value for the initialization argument is not supplied in the @i{initialization argument list}, the @i{method}'s @i{lambda list} supplies a default value. Initialization arguments are used in four situations: when making an @i{instance}, when re-initializing an @i{instance}, when updating an @i{instance} to conform to a redefined @i{class}, and when updating an @i{instance} to conform to the definition of a different @i{class}. Because initialization arguments are used to control the creation and initialization of an @i{instance} of some particular @i{class}, we say that an initialization argument is ``an initialization argument for'' that @i{class}. @node Declaring the Validity of Initialization Arguments, Defaulting of Initialization Arguments, Initialization Arguments, Object Creation and Initialization @subsection Declaring the Validity of Initialization Arguments Initialization arguments are checked for validity in each of the four situations that use them. An initialization argument may be valid in one situation and not another. For example, the system-supplied primary @i{method} for @b{make-instance} defined for the @i{class} @b{standard-class} checks the validity of its initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid in that situation. There are two means for declaring initialization arguments valid. @table @asis @item @t{*} Initialization arguments that fill @i{slots} are declared as valid by the @t{:initarg} slot option to @b{defclass}. The @t{:initarg} slot option is inherited from @i{superclasses}. Thus the set of valid initialization arguments that fill @i{slots} for a @i{class} is the union of the initialization arguments that fill @i{slots} declared as valid by that @i{class} and its @i{superclasses}. Initialization arguments that fill @i{slots} are valid in all four contexts. @item @t{*} Initialization arguments that supply arguments to @i{methods} are declared as valid by defining those @i{methods}. The keyword name of each keyword parameter specified in the @i{method}'s @i{lambda list} becomes an initialization argument for all @i{classes} for which the @i{method} is applicable. The presence of @t{&allow-other-keys} in the @i{lambda list} of an applicable method disables validity checking of initialization arguments. Thus @i{method} inheritance controls the set of valid initialization arguments that supply arguments to @i{methods}. The @i{generic functions} for which @i{method} definitions serve to declare initialization arguments valid are as follows: @table @asis @item -- Making an @i{instance} of a @i{class}: @b{allocate-instance}, @b{initialize-instance}, and @b{shared-initialize}. Initialization arguments declared as valid by these @i{methods} are valid when making an @i{instance} of a @i{class}. @item -- Re-initializing an @i{instance}: @b{reinitialize-instance} and @b{shared-initialize}. Initialization arguments declared as valid by these @i{methods} are valid when re-initializing an @i{instance}. @item -- Updating an @i{instance} to conform to a redefined @i{class}: @b{update-instance-for-redefined-class} and @b{shared-initialize}. Initialization arguments declared as valid by these @i{methods} are valid when updating an @i{instance} to conform to a redefined @i{class}. @item -- Updating an @i{instance} to conform to the definition of a different @i{class}: @b{update-instance-for-different-class} and @b{shared-initialize}. Initialization arguments declared as valid by these @i{methods} are valid when updating an @i{instance} to conform to the definition of a different @i{class}. @end table @end table The set of valid initialization arguments for a @i{class} is the set of valid initialization arguments that either fill @i{slots} or supply arguments to @i{methods}, along with the predefined initialization argument @t{:allow-other-keys}. The default value for @t{:allow-other-keys} is @b{nil}. Validity checking of initialization arguments is disabled if the value of the initialization argument @t{:allow-other-keys} is @i{true}. @node Defaulting of Initialization Arguments, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments, Object Creation and Initialization @subsection Defaulting of Initialization Arguments A default value @i{form} can be supplied for an initialization argument by using the @t{:default-initargs} @i{class} option. If an initialization argument is declared valid by some particular @i{class}, its default value form might be specified by a different @i{class}. In this case @t{:default-initargs} is used to supply a default value for an inherited initialization argument. The @t{:default-initargs} option is used only to provide default values for initialization arguments; it does not declare a @i{symbol} as a valid initialization argument name. Furthermore, the @t{:default-initargs} option is used only to provide default values for initialization arguments when making an @i{instance}. The argument to the @t{:default-initargs} class option is a list of alternating initialization argument names and @i{forms}. Each @i{form} is the default value form for the corresponding initialization argument. The default value @i{form} of an initialization argument is used and evaluated only if that initialization argument does not appear in the arguments to @b{make-instance} and is not defaulted by a more specific @i{class}. The default value @i{form} is evaluated in the lexical environment of the @b{defclass} form that supplied it; the resulting value is used as the initialization argument's value. The initialization arguments supplied to @b{make-instance} are combined with defaulted initialization arguments to produce a @i{defaulted initialization argument list}. A @i{defaulted initialization argument list} is a list of alternating initialization argument names and values in which unsupplied initialization arguments are defaulted and in which the explicitly supplied initialization arguments appear earlier in the list than the defaulted initialization arguments. Defaulted initialization arguments are ordered according to the order in the @i{class precedence list} of the @i{classes} that supplied the default values. There is a distinction between the purposes of the @t{:default-initargs} and the @t{:initform} options with respect to the initialization of @i{slots}. The @t{:default-initargs} class option provides a mechanism for the user to give a default value @i{form} for an initialization argument without knowing whether the initialization argument initializes a @i{slot} or is passed to a @i{method}. If that initialization argument is not explicitly supplied in a call to @b{make-instance}, the default value @i{form} is used, just as if it had been supplied in the call. In contrast, the @t{:initform} slot option provides a mechanism for the user to give a default initial value form for a @i{slot}. An @t{:initform} form is used to initialize a @i{slot} only if no initialization argument associated with that @i{slot} is given as an argument to @b{make-instance} or is defaulted by @t{:default-initargs}. @ITindex order of evaluation @ITindex evaluation order The order of evaluation of default value @i{forms} for initialization arguments and the order of evaluation of @t{:initform} forms are undefined. If the order of evaluation is important, @b{initialize-instance} or @b{shared-initialize} @i{methods} should be used instead. @node Rules for Initialization Arguments, Shared-Initialize, Defaulting of Initialization Arguments, Object Creation and Initialization @subsection Rules for Initialization Arguments The @t{:initarg} slot option may be specified more than once for a given @i{slot}. The following rules specify when initialization arguments may be multiply defined: @table @asis @item @t{*} A given initialization argument can be used to initialize more than one @i{slot} if the same initialization argument name appears in more than one @t{:initarg} slot option. @item @t{*} A given initialization argument name can appear in the @i{lambda list} of more than one initialization @i{method}. @item @t{*} A given initialization argument name can appear both in an @t{:initarg} slot option and in the @i{lambda list} of an initialization @i{method}. @end table [Reviewer Note by The next three paragraphs could be replaced by ``If two or more initialization arguments that initialize the same slot appear in the @i{defaulted initialization argument list}, the leftmost of these supplies the value, even if they have different names.'' And the rest would follow from the rules above.] If two or more initialization arguments that initialize the same @i{slot} are given in the arguments to @b{make-instance}, the leftmost of these initialization arguments in the @i{initialization argument list} supplies the value, even if the initialization arguments have different names. If two or more different initialization arguments that initialize the same @i{slot} have default values and none is given explicitly in the arguments to @b{make-instance}, the initialization argument that appears in a @t{:default-initargs} class option in the most specific of the @i{classes} supplies the value. If a single @t{:default-initargs} class option specifies two or more initialization arguments that initialize the same @i{slot} and none is given explicitly in the arguments to @b{make-instance}, the leftmost in the @t{:default-initargs} class option supplies the value, and the values of the remaining default value @i{forms} are ignored. Initialization arguments given explicitly in the arguments to @b{make-instance} appear to the left of defaulted initialization arguments. Suppose that the classes C_1 and C_2 supply the values of defaulted initialization arguments for different @i{slots}, and suppose that C_1 is more specific than C_2; then the defaulted initialization argument whose value is supplied by C_1 is to the left of the defaulted initialization argument whose value is supplied by C_2 in the @i{defaulted initialization argument list}. If a single @t{:default-initargs} class option supplies the values of initialization arguments for two different @i{slots}, the initialization argument whose value is specified farther to the left in the @t{:default-initargs} class option appears farther to the left in the @i{defaulted initialization argument list}. [Reviewer Note by Barmar: End of claim made three paragraphs back.] If a @i{slot} has both an @t{:initform} form and an @t{:initarg} slot option, and the initialization argument is defaulted using @t{:default-initargs} or is supplied to @b{make-instance}, the captured @t{:initform} form is neither used nor evaluated. The following is an example of the above rules: @example (defclass q () ((x :initarg a))) (defclass r (q) ((x :initarg b)) (:default-initargs a 1 b 2)) @end example @example @format @group @noindent @w{ @t{} Defaulted @t{} } @w{ Form Initialization Argument List Contents of Slot X } @w{ _____________________________________________________________________________} @w{ @t{(make-instance 'r)} @t{(a 1 b 2)} @t{1} } @w{ @t{(make-instance 'r 'a 3)} @t{(a 3 b 2)} @t{3} } @w{ @t{(make-instance 'r 'b 4)} @t{(b 4 a 1)} @t{4} } @w{ @t{(make-instance 'r 'a 1 'a 2)} @t{(a 1 a 2 b 2)} @t{1} } @end group @end format @end example @node Shared-Initialize, Initialize-Instance, Rules for Initialization Arguments, Object Creation and Initialization @subsection Shared-Initialize The @i{generic function} @b{shared-initialize} is used to fill the @i{slots} of an @i{instance} using initialization arguments and @t{:initform} forms when an @i{instance} is created, when an @i{instance} is re-initialized, when an @i{instance} is updated to conform to a redefined @i{class}, and when an @i{instance} is updated to conform to a different @i{class}. It uses standard @i{method} combination. It takes the following arguments: the @i{instance} to be initialized, a specification of a set of @i{names} of @i{slots} @i{accessible} in that @i{instance}, and any number of initialization arguments. The arguments after the first two must form an @i{initialization argument list}. The second argument to @b{shared-initialize} may be one of the following: @table @asis @item @t{*} It can be a (possibly empty) @i{list} of @i{slot} names, which specifies the set of those @i{slot} names. @item @t{*} It can be the symbol @b{t}, which specifies the set of all of the @i{slots}. @end table There is a system-supplied primary @i{method} for @b{shared-initialize} whose first @i{parameter specializer} is the @i{class} @b{standard-object}. This @i{method} behaves as follows on each @i{slot}, whether shared or local: @table @asis @item @t{*} If an initialization argument in the @i{initialization argument list} specifies a value for that @i{slot}, that value is stored into the @i{slot}, even if a value has already been stored in the @i{slot} before the @i{method} is run. The affected @i{slots} are independent of which @i{slots} are indicated by the second argument to @b{shared-initialize}. @item @t{*} Any @i{slots} indicated by the second argument that are still unbound at this point are initialized according to their @t{:initform} forms. For any such @i{slot} that has an @t{:initform} form, that @i{form} is evaluated in the lexical environment of its defining @b{defclass} form and the result is stored into the @i{slot}. For example, if a @i{before method} stores a value in the @i{slot}, the @t{:initform} form will not be used to supply a value for the @i{slot}. If the second argument specifies a @i{name} that does not correspond to any @i{slots} @i{accessible} in the @i{instance}, the results are unspecified. @item @t{*} The rules mentioned in @ref{Rules for Initialization Arguments} are obeyed. @end table The generic function @b{shared-initialize} is called by the system-supplied primary @i{methods} for @b{reinitialize-instance}, @b{update-instance-for-different-class}, @b{update-instance-for-redefined-class}, and @b{initialize-instance}. Thus, @i{methods} can be written for @b{shared-initialize} to specify actions that should be taken in all of these contexts. @node Initialize-Instance, Definitions of Make-Instance and Initialize-Instance, Shared-Initialize, Object Creation and Initialization @subsection Initialize-Instance The @i{generic function} @b{initialize-instance} is called by @b{make-instance} to initialize a newly created @i{instance}. It uses @i{standard method combination}. @i{Methods} for @b{initialize-instance} can be defined in order to perform any initialization that cannot be achieved simply by supplying initial values for @i{slots}. During initialization, @b{initialize-instance} is invoked after the following actions have been taken: @table @asis @item @t{*} The @i{defaulted initialization argument list} has been computed by combining the supplied @i{initialization argument list} with any default initialization arguments for the @i{class}. @item @t{*} The validity of the @i{defaulted initialization argument list} has been checked. If any of the initialization arguments has not been declared as valid, an error is signaled. @item @t{*} A new @i{instance} whose @i{slots} are unbound has been created. @end table The generic function @b{initialize-instance} is called with the new @i{instance} and the defaulted initialization arguments. There is a system-supplied primary @i{method} for @b{initialize-instance} whose @i{parameter specializer} is the @i{class} @b{standard-object}. This @i{method} calls the generic function @b{shared-initialize} to fill in the @i{slots} according to the initialization arguments and the @t{:initform} forms for the @i{slots}; the generic function @b{shared-initialize} is called with the following arguments: the @i{instance}, @b{t}, and the defaulted initialization arguments. Note that @b{initialize-instance} provides the @i{defaulted initialization argument list} in its call to @b{shared-initialize}, so the first step performed by the system-supplied primary @i{method} for @b{shared-initialize} takes into account both the initialization arguments provided in the call to @b{make-instance} and the @i{defaulted initialization argument list}. @i{Methods} for @b{initialize-instance} can be defined to specify actions to be taken when an @i{instance} is initialized. If only @i{after methods} for @b{initialize-instance} are defined, they will be run after the system-supplied primary @i{method} for initialization and therefore will not interfere with the default behavior of @b{initialize-instance}. The object system provides two @i{functions} that are useful in the bodies of @b{initialize-instance} methods. The @i{function} @b{slot-boundp} returns a @i{generic boolean} value that indicates whether a specified @i{slot} has a value; this provides a mechanism for writing @i{after methods} for @b{initialize-instance} that initialize @i{slots} only if they have not already been initialized. The @i{function} @b{slot-makunbound} causes the @i{slot} to have no value. @node Definitions of Make-Instance and Initialize-Instance, , Initialize-Instance, Object Creation and Initialization @subsection Definitions of Make-Instance and Initialize-Instance The generic function @b{make-instance} behaves as if it were defined as follows, except that certain optimizations are permitted: @example (defmethod make-instance ((class standard-class) &rest initargs) ... (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) (defmethod make-instance ((class-name symbol) &rest initargs) (apply #'make-instance (find-class class-name) initargs)) @end example The elided code in the definition of @b{make-instance} augments the @t{initargs} with any @i{defaulted initialization arguments} and checks the resulting initialization arguments to determine whether an initialization argument was supplied that neither filled a @i{slot} nor supplied an argument to an applicable @i{method}. The generic function @b{initialize-instance} behaves as if it were defined as follows, except that certain optimizations are permitted: @example (defmethod initialize-instance ((instance standard-object) &rest initargs) (apply #'shared-initialize instance t initargs))) @end example These procedures can be customized. Customizing at the Programmer Interface level includes using the @t{:initform}, @t{:initarg}, and @t{:default-initargs} options to @b{defclass}, as well as defining @i{methods} for @b{make-instance}, @b{allocate-instance}, and @b{initialize-instance}. It is also possible to define @i{methods} for @b{shared-initialize}, which would be invoked by the generic functions @b{reinitialize-instance}, @b{update-instance-for-redefined-class}, @b{update-instance-for-different-class}, and @b{initialize-instance}. The meta-object level supports additional customization. Implementations are permitted to make certain optimizations to @b{initialize-instance} and @b{shared-initialize}. The description of @b{shared-initialize} in Chapter~7 mentions the possible optimizations. @c end of including concept-objects @node Changing the Class of an Instance, Reinitializing an Instance, Object Creation and Initialization, Objects @section Changing the Class of an Instance @c including concept-change-class The @i{function} @b{change-class} can be used to change the @i{class} of an @i{instance} from its current class, C_@{@r{from}@}, to a different class, C_@{@r{to}@}; it changes the structure of the @i{instance} to conform to the definition of the class C_@{@r{to}@}. Note that changing the @i{class} of an @i{instance} may cause @i{slots} to be added or deleted. Changing the @i{class} of an @i{instance} does not change its identity as defined by the @b{eq} function. When @b{change-class} is invoked on an @i{instance}, a two-step updating process takes place. The first step modifies the structure of the @i{instance} by adding new @i{local slots} and discarding @i{local slots} that are not specified in the new version of the @i{instance}. The second step initializes the newly added @i{local slots} and performs any other user-defined actions. These two steps are further described in the two following sections. @menu * Modifying the Structure of the Instance:: * Initializing Newly Added Local Slots (Changing the Class of an Instance):: * Customizing the Change of Class of an Instance:: @end menu @node Modifying the Structure of the Instance, Initializing Newly Added Local Slots (Changing the Class of an Instance), Changing the Class of an Instance, Changing the Class of an Instance @subsection Modifying the Structure of the Instance In order to make the @i{instance} conform to the class C_@{@r{to}@}, @i{local slots} specified by the class C_@{@r{to}@} that are not specified by the class C_@{@r{from}@} are added, and @i{local slots} not specified by the class C_@{@r{to}@} that are specified by the class C_@{@r{from}@} are discarded. The values of @i{local slots} specified by both the class C_@{@r{to}@} and the class C_@{@r{from}@} are retained. If such a @i{local slot} was unbound, it remains unbound. The values of @i{slots} specified as shared in the class C_@{@r{from}@} and as local in the class C_@{@r{to}@} are retained. This first step of the update does not affect the values of any @i{shared slots}. @node Initializing Newly Added Local Slots (Changing the Class of an Instance), Customizing the Change of Class of an Instance, Modifying the Structure of the Instance, Changing the Class of an Instance @subsection Initializing Newly Added Local Slots The second step of the update initializes the newly added @i{slots} and performs any other user-defined actions. This step is implemented by the generic function @b{update-instance-for-different-class}. The generic function @b{update-instance-for-different-class} is invoked by @b{change-class} after the first step of the update has been completed. The generic function @b{update-instance-for-different-class} is invoked on arguments computed by @b{change-class}. The first argument passed is a copy of the @i{instance} being updated and is an @i{instance} of the class C_@{@r{from}@}; this copy has @i{dynamic extent} within the generic function @b{change-class}. The second argument is the @i{instance} as updated so far by @b{change-class} and is an @i{instance} of the class C_@{@r{to}@}. The remaining arguments are an @i{initialization argument list}. There is a system-supplied primary @i{method} for @b{update-instance-for-different-class} that has two parameter specializers, each of which is the @i{class} @b{standard-object}. First this @i{method} checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see @ref{Declaring the Validity of Initialization Arguments}.) Then it calls the generic function @b{shared-initialize} with the following arguments: the new @i{instance}, a list of @i{names} of the newly added @i{slots}, and the initialization arguments it received. @node Customizing the Change of Class of an Instance, , Initializing Newly Added Local Slots (Changing the Class of an Instance), Changing the Class of an Instance @subsection Customizing the Change of Class of an Instance @i{Methods} for @b{update-instance-for-different-class} may be defined to specify actions to be taken when an @i{instance} is updated. If only @i{after methods} for @b{update-instance-for-different-class} are defined, they will be run after the system-supplied primary @i{method} for initialization and will not interfere with the default behavior of @b{update-instance-for-different-class}. @i{Methods} for @b{shared-initialize} may be defined to customize @i{class} redefinition. For more information, see @ref{Shared-Initialize}. @c end of including concept-change-class @node Reinitializing an Instance, Meta-Objects, Changing the Class of an Instance, Objects @section Reinitializing an Instance @c including concept-reinit The generic function @b{reinitialize-instance} may be used to change the values of @i{slots} according to initialization arguments. The process of reinitialization changes the values of some @i{slots} and performs any user-defined actions. It does not modify the structure of an @i{instance} to add or delete @i{slots}, and it does not use any @t{:initform} forms to initialize @i{slots}. The generic function @b{reinitialize-instance} may be called directly. It takes one required argument, the @i{instance}. It also takes any number of initialization arguments to be used by @i{methods} for @b{reinitialize-instance} or for @b{shared-initialize}. The arguments after the required @i{instance} must form an @i{initialization argument list}. There is a system-supplied primary @i{method} for @b{reinitialize-instance} whose @i{parameter specializer} is the @i{class} @b{standard-object}. First this @i{method} checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see @ref{Declaring the Validity of Initialization Arguments}.) Then it calls the generic function @b{shared-initialize} with the following arguments: the @i{instance}, @b{nil}, and the initialization arguments it received. @menu * Customizing Reinitialization:: @end menu @node Customizing Reinitialization, , Reinitializing an Instance, Reinitializing an Instance @subsection Customizing Reinitialization @i{Methods} for @b{reinitialize-instance} may be defined to specify actions to be taken when an @i{instance} is updated. If only @i{after methods} for @b{reinitialize-instance} are defined, they will be run after the system-supplied primary @i{method} for initialization and therefore will not interfere with the default behavior of @b{reinitialize-instance}. @i{Methods} for @b{shared-initialize} may be defined to customize @i{class} redefinition. For more information, see @ref{Shared-Initialize}. @c end of including concept-reinit @node Meta-Objects, Slots, Reinitializing an Instance, Objects @section Meta-Objects @c including concept-meta-objects The implementation of the object system manipulates @i{classes}, @i{methods}, and @i{generic functions}. The object system contains a set of @i{generic functions} defined by @i{methods} on @i{classes}; the behavior of those @i{generic functions} defines the behavior of the object system. The @i{instances} of the @i{classes} on which those @i{methods} are defined are called meta-objects. @menu * Standard Meta-objects:: @end menu @node Standard Meta-objects, , Meta-Objects, Meta-Objects @subsection Standard Meta-objects The object system supplies a set of meta-objects, called standard meta-objects. These include the @i{class} @b{standard-object} and @i{instances} of the classes @b{standard-method}, @b{standard-generic-function}, and @b{method-combination}. @table @asis [Editorial Note by KMP: This is said redundantly in the definition of STANDARD-METHOD.] @item @t{*} The @i{class} @b{standard-method} is the default @i{class} of @i{methods} defined by the @b{defmethod} and @b{defgeneric} @i{forms}. @item @t{*} The @i{class} @b{standard-generic-function} is the default @i{class} of @i{generic functions} defined by the forms @b{defmethod}, @b{defgeneric}, and @b{defclass}. @item @t{*} The @i{class} named @b{standard-object} is an @i{instance} of the @i{class} @b{standard-class} and is a @i{superclass} of every @i{class} that is an @i{instance} of @b{standard-class} except itself and @b{structure-class}. @item @t{*} Every @i{method} combination object is an @i{instance} of a @i{subclass} of @i{class} @b{method-combination}. @end table @c end of including concept-meta-objects @node Slots, Generic Functions and Methods, Meta-Objects, Objects @section Slots @c including concept-slots @menu * Introduction to Slots:: * Accessing Slots:: * Inheritance of Slots and Slot Options:: @end menu @node Introduction to Slots, Accessing Slots, Slots, Slots @subsection Introduction to Slots An @i{object} of @i{metaclass} @b{standard-class} has zero or more named @i{slots}. The @i{slots} of an @i{object} are determined by the @i{class} of the @i{object}. Each @i{slot} can hold one value. [Reviewer Note by Barmar: All symbols are valid variable names. Perhaps this means to preclude the use of named constants? We have a terminology problem to solve.] The @i{name} of a @i{slot} is a @i{symbol} that is syntactically valid for use as a variable name. When a @i{slot} does not have a value, the @i{slot} is said to be @i{unbound}. When an unbound @i{slot} is read, [Reviewer Note by Barmar: from an object whose metaclass is standard-class?] the @i{generic function} @b{slot-unbound} is invoked. The system-supplied primary @i{method} for @b{slot-unbound} on @i{class} @b{t} signals an error. If @b{slot-unbound} returns, its @i{primary value} is used that time as the @i{value} of the @i{slot}. The default initial value form for a @i{slot} is defined by the @t{:initform} slot option. When the @t{:initform} form is used to supply a value, it is evaluated in the lexical environment in which the @b{defclass} form was evaluated. The @t{:initform} along with the lexical environment in which the @b{defclass} form was evaluated is called a @i{captured initialization form}. For more details, see @ref{Object Creation and Initialization}. A @i{local slot} is defined to be a @i{slot} that is @i{accessible} to exactly one @i{instance}, namely the one in which the @i{slot} is allocated. A @i{shared slot} is defined to be a @i{slot} that is visible to more than one @i{instance} of a given @i{class} and its @i{subclasses}. A @i{class} is said to define a @i{slot} with a given @i{name} when the @b{defclass} form for that @i{class} contains a @i{slot specifier} with that @i{name}. Defining a @i{local slot} does not immediately create a @i{slot}; it causes a @i{slot} to be created each time an @i{instance} of the @i{class} is created. Defining a @i{shared slot} immediately creates a @i{slot}. The @t{:allocation} slot option to @b{defclass} controls the kind of @i{slot} that is defined. If the value of the @t{:allocation} slot option is @t{:instance}, a @i{local slot} is created. If the value of @t{:allocation} is @t{:class}, a @i{shared slot} is created. A @i{slot} is said to be @i{accessible} in an @i{instance} of a @i{class} if the @i{slot} is defined by the @i{class} of the @i{instance} or is inherited from a @i{superclass} of that @i{class}. At most one @i{slot} of a given @i{name} can be @i{accessible} in an @i{instance}. A @i{shared slot} defined by a @i{class} is @i{accessible} in all @i{instances} of that @i{class}. A detailed explanation of the inheritance of @i{slots} is given in @ref{Inheritance of Slots and Slot Options}. @node Accessing Slots, Inheritance of Slots and Slot Options, Introduction to Slots, Slots @subsection Accessing Slots @i{Slots} can be @i{accessed} in two ways: by use of the primitive function @b{slot-value} and by use of @i{generic functions} generated by the @b{defclass} form. The @i{function} @b{slot-value} can be used with any of the @i{slot} names specified in the @b{defclass} form to @i{access} a specific @i{slot} @i{accessible} in an @i{instance} of the given @i{class}. The macro @b{defclass} provides syntax for generating @i{methods} to read and write @i{slots}. If a reader @i{method} is requested, a @i{method} is automatically generated for reading the value of the @i{slot}, but no @i{method} for storing a value into it is generated. If a writer @i{method} is requested, a @i{method} is automatically generated for storing a value into the @i{slot}, but no @i{method} for reading its value is generated. If an accessor @i{method} is requested, a @i{method} for reading the value of the @i{slot} and a @i{method} for storing a value into the @i{slot} are automatically generated. Reader and writer @i{methods} are implemented using @b{slot-value}. When a reader or writer @i{method} is specified for a @i{slot}, the name of the @i{generic function} to which the generated @i{method} belongs is directly specified. If the @i{name} specified for the writer @i{method} is the symbol @t{name}, the @i{name} of the @i{generic function} for writing the @i{slot} is the symbol @t{name}, and the @i{generic function} takes two arguments: the new value and the @i{instance}, in that order. If the @i{name} specified for the accessor @i{method} is the symbol @t{name}, the @i{name} of the @i{generic function} for reading the @i{slot} is the symbol @t{name}, and the @i{name} of the @i{generic function} for writing the @i{slot} is the list @t{(setf name)}. A @i{generic function} created or modified by supplying @t{:reader}, @t{:writer}, or @t{:accessor} @i{slot} options can be treated exactly as an ordinary @i{generic function}. Note that @b{slot-value} can be used to read or write the value of a @i{slot} whether or not reader or writer @i{methods} exist for that @i{slot}. When @b{slot-value} is used, no reader or writer @i{methods} are invoked. The macro @b{with-slots} can be used to establish a @i{lexical environment} in which specified @i{slots} are lexically available as if they were variables. The macro @b{with-slots} invokes the @i{function} @b{slot-value} to @i{access} the specified @i{slots}. The macro @b{with-accessors} can be used to establish a lexical environment in which specified @i{slots} are lexically available through their accessors as if they were variables. The macro @b{with-accessors} invokes the appropriate accessors to @i{access} the specified @i{slots}. @node Inheritance of Slots and Slot Options, , Accessing Slots, Slots @subsection Inheritance of Slots and Slot Options The set of the @i{names} of all @i{slots} @i{accessible} in an @i{instance} of a @i{class} C is the union of the sets of @i{names} of @i{slots} defined by C and its @i{superclasses}. The structure of an @i{instance} is the set of @i{names} of @i{local slots} in that @i{instance}. In the simplest case, only one @i{class} among C and its @i{superclasses} defines a @i{slot} with a given @i{slot} name. If a @i{slot} is defined by a @i{superclass} of C, the @i{slot} is said to be inherited. The characteristics of the @i{slot} are determined by the @i{slot specifier} of the defining @i{class}. Consider the defining @i{class} for a slot S. If the value of the @t{:allocation} slot option is @t{:instance}, then S is a @i{local slot} and each @i{instance} of C has its own @i{slot} named S that stores its own value. If the value of the @t{:allocation} slot option is @t{:class}, then S is a @i{shared slot}, the @i{class} that defined S stores the value, and all @i{instances} of C can @i{access} that single @i{slot}. If the @t{:allocation} slot option is omitted, @t{:instance} is used. In general, more than one @i{class} among C and its @i{superclasses} can define a @i{slot} with a given @i{name}. In such cases, only one @i{slot} with the given name is @i{accessible} in an @i{instance} of C, and the characteristics of that @i{slot} are a combination of the several @i{slot} specifiers, computed as follows: @table @asis @item @t{*} All the @i{slot specifiers} for a given @i{slot} name are ordered from most specific to least specific, according to the order in C's @i{class precedence list} of the @i{classes} that define them. All references to the specificity of @i{slot specifiers} immediately below refers to this ordering. @item @t{*} The allocation of a @i{slot} is controlled by the most specific @i{slot specifier}. If the most specific @i{slot specifier} does not contain an @t{:allocation} slot option, @t{:instance} is used. Less specific @i{slot specifiers} do not affect the allocation. @item @t{*} The default initial value form for a @i{slot} is the value of the @t{:initform} slot option in the most specific @i{slot specifier} that contains one. If no @i{slot specifier} contains an @t{:initform} slot option, the @i{slot} has no default initial value form. @item @t{*} The contents of a @i{slot} will always be of type @t{(and T_1 ... T_n)} where T_1 ... T_n are the values of the @t{:type} slot options contained in all of the @i{slot specifiers}. If no @i{slot specifier} contains the @t{:type} slot option, the contents of the @i{slot} will always be of @i{type} @b{t}. The consequences of attempting to store in a @i{slot} a value that does not satisfy the @i{type} of the @i{slot} are undefined. @item @t{*} The set of initialization arguments that initialize a given @i{slot} is the union of the initialization arguments declared in the @t{:initarg} slot options in all the @i{slot specifiers}. @item @t{*} The @i{documentation string} for a @i{slot} is the value of the @t{:documentation} slot option in the most specific @i{slot} specifier that contains one. If no @i{slot specifier} contains a @t{:documentation} slot option, the @i{slot} has no @i{documentation string}. @end table A consequence of the allocation rule is that a @i{shared slot} can be @i{shadowed}. For example, if a class C_1 defines a @i{slot} named S whose value for the @t{:allocation} slot option is @t{:class}, that @i{slot} is @i{accessible} in @i{instances} of C_1 and all of its @i{subclasses}. However, if C_2 is a @i{subclass} of C_1 and also defines a @i{slot} named S, C_1's @i{slot} is not shared by @i{instances} of C_2 and its @i{subclasses}. When a class C_1 defines a @i{shared slot}, any subclass C_2 of C_1 will share this single @i{slot} unless the @b{defclass} form for C_2 specifies a @i{slot} of the same @i{name} or there is a @i{superclass} of C_2 that precedes C_1 in the @i{class precedence list} of C_2 that defines a @i{slot} of the same name. A consequence of the type rule is that the value of a @i{slot} satisfies the type constraint of each @i{slot specifier} that contributes to that @i{slot}. Because the result of attempting to store in a @i{slot} a value that does not satisfy the type constraint for the @i{slot} is undefined, the value in a @i{slot} might fail to satisfy its type constraint. The @t{:reader}, @t{:writer}, and @t{:accessor} slot options create @i{methods} rather than define the characteristics of a @i{slot}. Reader and writer @i{methods} are inherited in the sense described in @ref{Inheritance of Methods}. @i{Methods} that @i{access} @i{slots} use only the name of the @i{slot} and the @i{type} of the @i{slot}'s value. Suppose a @i{superclass} provides a @i{method} that expects to @i{access} a @i{shared slot} of a given @i{name}, and a @i{subclass} defines a @i{local slot} with the same @i{name}. If the @i{method} provided by the @i{superclass} is used on an @i{instance} of the @i{subclass}, the @i{method} @i{accesses} the @i{local slot}. @c end of including concept-slots @node Generic Functions and Methods, Objects Dictionary, Slots, Objects @section Generic Functions and Methods @c including concept-gfs-and-methods @menu * Introduction to Generic Functions:: * Introduction to Methods:: * Agreement on Parameter Specializers and Qualifiers:: * Congruent Lambda-lists for all Methods of a Generic Function:: * Keyword Arguments in Generic Functions and Methods:: * Method Selection and Combination:: * Inheritance of Methods:: @end menu @node Introduction to Generic Functions, Introduction to Methods, Generic Functions and Methods, Generic Functions and Methods @subsection Introduction to Generic Functions A @i{generic function} @IGindex generic function is a function whose behavior depends on the @i{classes} or identities of the @i{arguments} supplied to it. A @i{generic function} @i{object} is associated with a set of @i{methods}, a @i{lambda list}, a @i{method combination}_2, and other information. Like an @i{ordinary function}, a @i{generic function} takes @i{arguments}, performs a series of operations, and perhaps returns useful @i{values}. An @i{ordinary function} has a single body of @i{code} that is always @i{executed} when the @i{function} is called. A @i{generic function} has a set of bodies of @i{code} of which a subset is selected for @i{execution}. The selected bodies of @i{code} and the manner of their combination are determined by the @i{classes} or identities of one or more of the @i{arguments} to the @i{generic function} and by its @i{method combination}. @i{Ordinary functions} and @i{generic functions} are called with identical syntax. @i{Generic functions} are true @i{functions} that can be passed as @i{arguments} and used as the first @i{argument} to @b{funcall} and @b{apply}. A @i{binding} of a @i{function name} to a @i{generic function} can be @i{established} in one of several ways. It can be @i{established} in the @i{global environment} by @b{ensure-generic-function}, @b{defmethod} (implicitly, due to @b{ensure-generic-function}) or @b{defgeneric} (also implicitly, due to @b{ensure-generic-function}). No @i{standardized} mechanism is provided for @i{establishing} a @i{binding} of a @i{function name} to a @i{generic function} in the @i{lexical environment}. When a @b{defgeneric} form is evaluated, one of three actions is taken (due to @b{ensure-generic-function}): @table @asis @item @t{*} If a generic function of the given name already exists, the existing generic function object is modified. Methods specified by the current @b{defgeneric} form are added, and any methods in the existing generic function that were defined by a previous @b{defgeneric} form are removed. Methods added by the current @b{defgeneric} form might replace methods defined by @b{defmethod}, @b{defclass}, @b{define-condition}, or @b{defstruct}. No other methods in the generic function are affected or replaced. @item @t{*} If the given name names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error is signaled. @item @t{*} Otherwise a generic function is created with the methods specified by the method definitions in the @b{defgeneric} form. @end table Some @i{operators} permit specification of the options of a @i{generic function}, such as the @i{type} of @i{method combination} it uses or its @i{argument precedence order}. These @i{operators} will be referred to as ``operators that specify generic function options.'' The only @i{standardized} @i{operator} in this category is @b{defgeneric}. Some @i{operators} define @i{methods} for a @i{generic function}. These @i{operators} will be referred to as @i{method-defining operators} @IGindex method-defining operator ; their associated @i{forms} are called @i{method-defining forms}. The @i{standardized} @i{method-defining operators} are listed in Figure 7--2. @format @group @noindent @w{ defgeneric defmethod defclass } @w{ define-condition defstruct } @noindent @w{ Figure 7--2: Standardized Method-Defining Operators} @end group @end format Note that of the @i{standardized} @i{method-defining operators} only @b{defgeneric} can specify @i{generic function} options. @b{defgeneric} and any @i{implementation-defined} @i{operators} that can specify @i{generic function} options are also referred to as ``operators that specify generic function options.'' @node Introduction to Methods, Agreement on Parameter Specializers and Qualifiers, Introduction to Generic Functions, Generic Functions and Methods @subsection Introduction to Methods @i{Methods} define the class-specific or identity-specific behavior and operations of a @i{generic function}. A @i{method} @i{object} is associated with @i{code} that implements the method's behavior, a sequence of @i{parameter specializers} that specify when the given @i{method} is applicable, a @i{lambda list}, and a sequence of @i{qualifiers} that are used by the method combination facility to distinguish among @i{methods}. A method object is not a function and cannot be invoked as a function. Various mechanisms in the object system take a method object and invoke its method function, as is the case when a generic function is invoked. When this occurs it is said that the method is invoked or called. A method-defining form contains the @i{code} that is to be run when the arguments to the generic function cause the method that it defines to be invoked. When a method-defining form is evaluated, a method object is created and one of four actions is taken: @table @asis @item @t{*} If a @i{generic function} of the given name already exists and if a @i{method object} already exists that agrees with the new one on @i{parameter specializers} and @i{qualifiers}, the new @i{method object} replaces the old one. For a definition of one method agreeing with another on @i{parameter specializers} and @i{qualifiers}, see @ref{Agreement on Parameter Specializers and Qualifiers}. @item @t{*} If a @i{generic function} of the given name already exists and if there is no @i{method object} that agrees with the new one on @i{parameter specializers} and @i{qualifiers}, the existing @i{generic function} @i{object} is modified to contain the new @i{method} @i{object}. @item @t{*} If the given @i{name} names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error is signaled. @item @t{*} Otherwise a @i{generic function} is created with the @i{method} specified by the @i{method-defining form}. @end table If the @i{lambda list} of a new @i{method} is not @i{congruent} with the @i{lambda list} of the @i{generic function}, an error is signaled. If a @i{method-defining operator} that cannot specify @i{generic function} options creates a new @i{generic function}, a @i{lambda list} for that @i{generic function} is derived from the @i{lambda list} of the @i{method} in the @i{method-defining form} in such a way as to be @i{congruent} with it. For a discussion of @i{congruence} @IGindex congruence , see @ref{Congruent Lambda-lists for all Methods of a Generic Function}. Each method has a @i{specialized lambda list}, which determines when that method can be applied. A @i{specialized lambda list} is like an @i{ordinary lambda list} except that a specialized parameter may occur instead of the name of a required parameter. A specialized parameter is a list @t{(@i{variable-name} @i{parameter-specializer-name})}, where @i{parameter-specializer-name} is one of the following: @table @asis @item a @i{symbol} denotes a @i{parameter specializer} which is the @i{class} named by that @i{symbol}. @item a @i{class} denotes a @i{parameter specializer} which is the @i{class} itself. @item @t{(eql @i{form})} denotes a @i{parameter specializer} which satisfies the @i{type specifier} @t{(eql @i{object})}, where @i{object} is the result of evaluating @i{form}. The form @i{form} is evaluated in the lexical environment in which the method-defining form is evaluated. Note that @i{form} is evaluated only once, at the time the method is defined, not each time the generic function is called. @end table @i{Parameter specializer names} are used in macros intended as the user-level interface (@b{defmethod}), while @i{parameter specializers} are used in the functional interface. Only required parameters may be specialized, and there must be a @i{parameter specializer} for each required parameter. For notational simplicity, if some required parameter in a @i{specialized lambda list} in a method-defining form is simply a variable name, its @i{parameter specializer} defaults to the @i{class} @b{t}. Given a generic function and a set of arguments, an applicable method is a method for that generic function whose parameter specializers are satisfied by their corresponding arguments. The following definition specifies what it means for a method to be applicable and for an argument to satisfy a @i{parameter specializer}. Let < A_1, ..., A_n> be the required arguments to a generic function in order. Let < P_1, ..., P_n> be the @i{parameter specializers} corresponding to the required parameters of the method M in order. The method M is applicable when each A_i is of the @i{type} specified by the @i{type specifier} P_i. Because every valid @i{parameter specializer} is also a valid @i{type specifier}, the @i{function} @b{typep} can be used during method selection to determine whether an argument satisfies a @i{parameter specializer}. A method all of whose @i{parameter specializers} are the @i{class} @b{t} is called a @i{default method} @IGindex default method ; it is always applicable but may be shadowed by a more specific method. Methods can have @i{qualifiers}, which give the method combination procedure a way to distinguish among methods. A method that has one or more @i{qualifiers} is called a @i{qualified method}. A method with no @i{qualifiers} is called an @i{unqualified method}. A @i{qualifier} is any @i{non-list}. The @i{qualifiers} defined by the @i{standardized} method combination types are @i{symbols}. In this specification, the terms ``@i{primary method}'' and ``@i{auxiliary method}'' are used to partition @i{methods} within a method combination type according to their intended use. In standard method combination, @i{primary methods} are @i{unqualified methods} and @i{auxiliary methods} are methods with a single @i{qualifier} that is one of @t{:around}, @t{:before}, or @t{:after}. @i{Methods} with these @i{qualifiers} are called @i{around methods}, @i{before methods}, and @i{after methods}, respectively. When a method combination type is defined using the short form of @b{define-method-combination}, @i{primary methods} are methods qualified with the name of the type of method combination, and auxiliary methods have the @i{qualifier} @t{:around}. Thus the terms ``@i{primary method}'' and ``@i{auxiliary method}'' have only a relative definition within a given method combination type. @node Agreement on Parameter Specializers and Qualifiers, Congruent Lambda-lists for all Methods of a Generic Function, Introduction to Methods, Generic Functions and Methods @subsection Agreement on Parameter Specializers and Qualifiers Two @i{methods} are said to agree with each other on @i{parameter specializers} and @i{qualifiers} if the following conditions hold: @table @asis @item 1. Both methods have the same number of required parameters. Suppose the @i{parameter specializers} of the two methods are P_@{1,1@}... P_@{1,n@} and P_@{2,1@}... P_@{2,n@}. @item 2. For each 1<= i<= n, P_@{1,i@} agrees with P_@{2,i@}. The @i{parameter specializer} P_@{1,i@} agrees with P_@{2,i@} if P_@{1,i@} and P_@{2,i@} are the same class or if P_@{1,i@}=@t{(@b{eql} @i{object}_1)}, P_@{2,i@}=@t{(@b{eql} @i{object}_2)}, and @t{(@b{eql} @i{object}_1 @i{object}_2)}. Otherwise P_@{1,i@} and P_@{2,i@} do not agree. @item 3. The two @i{lists} of @i{qualifiers} are the @i{same} under @b{equal}. @end table @node Congruent Lambda-lists for all Methods of a Generic Function, Keyword Arguments in Generic Functions and Methods, Agreement on Parameter Specializers and Qualifiers, Generic Functions and Methods @subsection Congruent Lambda-lists for all Methods of a Generic Function These rules define the congruence of a set of @i{lambda lists}, including the @i{lambda list} of each method for a given generic function and the @i{lambda list} specified for the generic function itself, if given. @table @asis @item 1. Each @i{lambda list} must have the same number of required parameters. @item 2. Each @i{lambda list} must have the same number of optional parameters. Each method can supply its own default for an optional parameter. @item 3. If any @i{lambda list} mentions @b{&rest} or @b{&key}, each @i{lambda list} must mention one or both of them. @item 4. If the @i{generic function} @i{lambda list} mentions @b{&key}, each method must accept all of the keyword names mentioned after @b{&key}, either by accepting them explicitly, by specifying @b{&allow-other-keys}, or by specifying @b{&rest} but not @b{&key}. Each method can accept additional keyword arguments of its own. The checking of the validity of keyword names is done in the generic function, not in each method. A method is invoked as if the keyword argument pair whose name is @t{:allow-other-keys} and whose value is @i{true} were supplied, though no such argument pair will be passed. @item 5. The use of @b{&allow-other-keys} need not be consistent across @i{lambda lists}. If @b{&allow-other-keys} is mentioned in the @i{lambda list} of any applicable @i{method} or of the @i{generic function}, any keyword arguments may be mentioned in the call to the @i{generic function}. @item 6. The use of @b{&aux} need not be consistent across methods. If a @i{method-defining operator} that cannot specify @i{generic function} options creates a @i{generic function}, and if the @i{lambda list} for the method mentions keyword arguments, the @i{lambda list} of the generic function will mention @b{&key} (but no keyword arguments). @end table @node Keyword Arguments in Generic Functions and Methods, Method Selection and Combination, Congruent Lambda-lists for all Methods of a Generic Function, Generic Functions and Methods @subsection Keyword Arguments in Generic Functions and Methods When a generic function or any of its methods mentions @b{&key} in a @i{lambda list}, the specific set of keyword arguments accepted by the generic function varies according to the applicable methods. The set of keyword arguments accepted by the generic function for a particular call is the union of the keyword arguments accepted by all applicable methods and the keyword arguments mentioned after @b{&key} in the generic function definition, if any. A method that has @b{&rest} but not @b{&key} does not affect the set of acceptable keyword arguments. If the @i{lambda list} of any applicable method or of the generic function definition contains @b{&allow-other-keys}, all keyword arguments are accepted by the generic function. The @i{lambda list} congruence rules require that each method accept all of the keyword arguments mentioned after @b{&key} in the generic function definition, by accepting them explicitly, by specifying @b{&allow-other-keys}, or by specifying @b{&rest} but not @b{&key}. Each method can accept additional keyword arguments of its own, in addition to the keyword arguments mentioned in the generic function definition. If a @i{generic function} is passed a keyword argument that no applicable method accepts, an error should be signaled; see @ref{Error Checking in Function Calls}. @menu * Examples of Keyword Arguments in Generic Functions and Methods:: @end menu @node Examples of Keyword Arguments in Generic Functions and Methods, , Keyword Arguments in Generic Functions and Methods, Keyword Arguments in Generic Functions and Methods @subsubsection Examples of Keyword Arguments in Generic Functions and Methods For example, suppose there are two methods defined for @t{width} as follows: @example (defmethod width ((c character-class) &key font) ...) (defmethod width ((p picture-class) &key pixel-size) ...) @end example @noindent Assume that there are no other methods and no generic function definition for @t{width}. The evaluation of the following form should signal an error because the keyword argument @t{:pixel-size} is not accepted by the applicable method. @example (width (make-instance `character-class :char #\Q) :font 'baskerville :pixel-size 10) @end example The evaluation of the following form should signal an error. @example (width (make-instance `picture-class :glyph (glyph #\Q)) :font 'baskerville :pixel-size 10) @end example The evaluation of the following form will not signal an error if the class named @t{character-picture-class} is a subclass of both @t{picture-class} and @t{character-class}. @example (width (make-instance `character-picture-class :char #\Q) :font 'baskerville :pixel-size 10) @end example @node Method Selection and Combination, Inheritance of Methods, Keyword Arguments in Generic Functions and Methods, Generic Functions and Methods @subsection Method Selection and Combination When a @i{generic function} is called with particular arguments, it must determine the code to execute. This code is called the @i{effective method} @IGindex effective method for those @i{arguments}. The @i{effective method} is a combination of the @i{applicable methods} in the @i{generic function} that @i{calls} some or all of the @i{methods}. If a @i{generic function} is called and no @i{methods} are @i{applicable}, the @i{generic function} @b{no-applicable-method} is invoked, with the @i{results} from that call being used as the @i{results} of the call to the original @i{generic function}. Calling @b{no-applicable-method} takes precedence over checking for acceptable keyword arguments; see @ref{Keyword Arguments in Generic Functions and Methods}. When the @i{effective method} has been determined, it is invoked with the same @i{arguments} as were passed to the @i{generic function}. Whatever @i{values} it returns are returned as the @i{values} of the @i{generic function}. @menu * Determining the Effective Method:: * Selecting the Applicable Methods:: * Sorting the Applicable Methods by Precedence Order:: * Applying method combination to the sorted list of applicable methods:: * Standard Method Combination:: * Declarative Method Combination:: * Built-in Method Combination Types:: @end menu @node Determining the Effective Method, Selecting the Applicable Methods, Method Selection and Combination, Method Selection and Combination @subsubsection Determining the Effective Method The effective method is determined by the following three-step procedure: @table @asis @item 1. @r{Select the applicable methods.} @item 2. @r{Sort the applicable methods by precedence order, putting the most specific method first.} @item 3. @r{Apply method combination to the sorted list of applicable methods, producing the effective method.} @end table @node Selecting the Applicable Methods, Sorting the Applicable Methods by Precedence Order, Determining the Effective Method, Method Selection and Combination @subsubsection Selecting the Applicable Methods This step is described in @ref{Introduction to Methods}. @node Sorting the Applicable Methods by Precedence Order, Applying method combination to the sorted list of applicable methods, Selecting the Applicable Methods, Method Selection and Combination @subsubsection Sorting the Applicable Methods by Precedence Order To compare the precedence of two methods, their @i{parameter specializers} are examined in order. The default examination order is from left to right, but an alternative order may be specified by the @t{:argument-precedence-order} option to @b{defgeneric} or to any of the other operators that specify generic function options. The corresponding @i{parameter specializers} from each method are compared. When a pair of @i{parameter specializers} agree, the next pair are compared for agreement. If all corresponding parameter specializers agree, the two methods must have different @i{qualifiers}; in this case, either method can be selected to precede the other. For information about agreement, see @ref{Agreement on Parameter Specializers and Qualifiers}. If some corresponding @i{parameter specializers} do not agree, the first pair of @i{parameter specializers} that do not agree determines the precedence. If both @i{parameter specializers} are classes, the more specific of the two methods is the method whose @i{parameter specializer} appears earlier in the @i{class precedence list} of the corresponding argument. Because of the way in which the set of applicable methods is chosen, the @i{parameter specializers} are guaranteed to be present in the class precedence list of the class of the argument. If just one of a pair of corresponding @i{parameter specializers} is @t{(eql @i{object})}, the @i{method} with that @i{parameter specializer} precedes the other @i{method}. If both @i{parameter specializers} are @b{eql} @i{expressions}, the specializers must agree (otherwise the two @i{methods} would not both have been applicable to this argument). The resulting list of @i{applicable methods} has the most specific @i{method} first and the least specific @i{method} last. @node Applying method combination to the sorted list of applicable methods, Standard Method Combination, Sorting the Applicable Methods by Precedence Order, Method Selection and Combination @subsubsection Applying method combination to the sorted list of applicable methods In the simple case---if standard method combination is used and all applicable methods are primary methods---the effective method is the most specific method. That method can call the next most specific method by using the @i{function} @b{call-next-method}. The method that @b{call-next-method} will call is referred to as the @i{next method} @IGindex next method . The predicate @b{next-method-p} tests whether a next method exists. If @b{call-next-method} is called and there is no next most specific method, the generic function @b{no-next-method} is invoked. In general, the effective method is some combination of the applicable methods. It is described by a @i{form} that contains calls to some or all of the applicable methods, returns the value or values that will be returned as the value or values of the generic function, and optionally makes some of the methods accessible by means of @b{call-next-method}. The role of each method in the effective method is determined by its @i{qualifiers} and the specificity of the method. A @i{qualifier} serves to mark a method, and the meaning of a @i{qualifier} is determined by the way that these marks are used by this step of the procedure. If an applicable method has an unrecognized @i{qualifier}, this step signals an error and does not include that method in the effective method. When standard method combination is used together with qualified methods, the effective method is produced as described in @ref{Standard Method Combination}. Another type of method combination can be specified by using the @t{:method-combination} option of @b{defgeneric} or of any of the other operators that specify generic function options. In this way this step of the procedure can be customized. New types of method combination can be defined by using the @b{define-method-combination} @i{macro}. @node Standard Method Combination, Declarative Method Combination, Applying method combination to the sorted list of applicable methods, Method Selection and Combination @subsubsection Standard Method Combination @IRindex standard Standard method combination is supported by the @i{class} @b{standard-generic-function}. It is used if no other type of method combination is specified or if the built-in method combination type @b{standard} is specified. Primary methods define the main action of the effective method, while auxiliary methods modify that action in one of three ways. A primary method has no method @i{qualifiers}. An auxiliary method is a method whose @i{qualifier} is @t{:before}, @t{:after}, or @t{:around}. Standard method combination allows no more than one @i{qualifier} per method; if a method definition specifies more than one @i{qualifier} per method, an error is signaled. @table @asis @item @t{*} A @i{before method} has the keyword @t{:before} as its only @i{qualifier}. A @i{before method} specifies @i{code} that is to be run before any @i{primary methods}. @item @t{*} An @i{after method} has the keyword @t{:after} as its only @i{qualifier}. An @i{after method} specifies @i{code} that is to be run after @i{primary methods}. @item @t{*} An @i{around method} has the keyword @t{:around} as its only @i{qualifier}. An @i{around method} specifies @i{code} that is to be run instead of other @i{applicable methods}, but which might contain explicit @i{code} which calls some of those @i{shadowed} @i{methods} (via @b{call-next-method}). @end table The semantics of standard method combination is as follows: @table @asis @item @t{*} If there are any @i{around methods}, the most specific @i{around method} is called. It supplies the value or values of the generic function. @item @t{*} Inside the body of an @i{around method}, @b{call-next-method} can be used to call the @i{next method}. When the next method returns, the @i{around method} can execute more code, perhaps based on the returned value or values. The @i{generic function} @b{no-next-method} is invoked if @b{call-next-method} is used and there is no @i{applicable method} to call. The @i{function} @b{next-method-p} may be used to determine whether a @i{next method} exists. @item @t{*} If an @i{around method} invokes @b{call-next-method}, the next most specific @i{around method} is called, if one is applicable. If there are no @i{around methods} or if @b{call-next-method} is called by the least specific @i{around method}, the other methods are called as follows: @table @asis @item -- All the @i{before methods} are called, in most-specific-first order. Their values are ignored. An error is signaled if @b{call-next-method} is used in a @i{before method}. @item -- The most specific primary method is called. Inside the body of a primary method, @b{call-next-method} may be used to call the next most specific primary method. When that method returns, the previous primary method can execute more code, perhaps based on the returned value or values. The generic function @b{no-next-method} is invoked if @b{call-next-method} is used and there are no more applicable primary methods. The @i{function} @b{next-method-p} may be used to determine whether a @i{next method} exists. If @b{call-next-method} is not used, only the most specific @i{primary method} is called. @item -- All the @i{after methods} are called in most-specific-last order. Their values are ignored. An error is signaled if @b{call-next-method} is used in an @i{after method}. @end table @item @t{*} If no @i{around methods} were invoked, the most specific primary method supplies the value or values returned by the generic function. The value or values returned by the invocation of @b{call-next-method} in the least specific @i{around method} are those returned by the most specific primary method. @end table In standard method combination, if there is an applicable method but no applicable primary method, an error is signaled. The @i{before methods} are run in most-specific-first order while the @i{after methods} are run in least-specific-first order. The design rationale for this difference can be illustrated with an example. Suppose class C_1 modifies the behavior of its superclass, C_2, by adding @i{before methods} and @i{after methods}. Whether the behavior of the class C_2 is defined directly by methods on C_2 or is inherited from its superclasses does not affect the relative order of invocation of methods on instances of the class C_1. Class C_1's @i{before method} runs before all of class C_2's methods. Class C_1's @i{after method} runs after all of class C_2's methods. By contrast, all @i{around methods} run before any other methods run. Thus a less specific @i{around method} runs before a more specific primary method. If only primary methods are used and if @b{call-next-method} is not used, only the most specific method is invoked; that is, more specific methods shadow more general ones. @node Declarative Method Combination, Built-in Method Combination Types, Standard Method Combination, Method Selection and Combination @subsubsection Declarative Method Combination The macro @b{define-method-combination} defines new forms of method combination. It provides a mechanism for customizing the production of the effective method. The default procedure for producing an effective method is described in @ref{Determining the Effective Method}. There are two forms of @b{define-method-combination}. The short form is a simple facility while the long form is more powerful and more verbose. The long form resembles @b{defmacro} in that the body is an expression that computes a Lisp form; it provides mechanisms for implementing arbitrary control structures within method combination and for arbitrary processing of method @i{qualifiers}. @node Built-in Method Combination Types, , Declarative Method Combination, Method Selection and Combination @subsubsection Built-in Method Combination Types The object system provides a set of built-in method combination types. To specify that a generic function is to use one of these method combination types, the name of the method combination type is given as the argument to the @t{:method-combination} option to @b{defgeneric} or to the @t{:method-combination} option to any of the other operators that specify generic function options. The names of the built-in method combination types are listed in Figure 7--3. @IRindex + @IRindex and @IRindex append @IRindex list @IRindex max @IRindex min @IRindex nconc @IRindex or @IRindex progn @IRindex standard @format @group @noindent @w{ + append max nconc progn } @w{ and list min or standard } @noindent @w{ Figure 7--3: Built-in Method Combination Types} @end group @end format The semantics of the @b{standard} built-in method combination type is described in @ref{Standard Method Combination}. The other built-in method combination types are called simple built-in method combination types. The simple built-in method combination types act as though they were defined by the short form of @b{define-method-combination}. They recognize two roles for @i{methods}: @table @asis @item @t{*} An @i{around method} has the keyword symbol @t{:around} as its sole @i{qualifier}. The meaning of @t{:around} @i{methods} is the same as in standard method combination. Use of the functions @b{call-next-method} and @b{next-method-p} is supported in @i{around methods}. @item @t{*} A primary method has the name of the method combination type as its sole @i{qualifier}. For example, the built-in method combination type @t{and} recognizes methods whose sole @i{qualifier} is @t{and}; these are primary methods. Use of the functions @b{call-next-method} and @b{next-method-p} is not supported in @i{primary methods}. @end table The semantics of the simple built-in method combination types is as follows: @table @asis @item @t{*} If there are any @i{around methods}, the most specific @i{around method} is called. It supplies the value or values of the @i{generic function}. @item @t{*} Inside the body of an @i{around method}, the function @b{call-next-method} can be used to call the @i{next method}. The @i{generic function} @b{no-next-method} is invoked if @b{call-next-method} is used and there is no applicable method to call. The @i{function} @b{next-method-p} may be used to determine whether a @i{next method} exists. When the @i{next method} returns, the @i{around method} can execute more code, perhaps based on the returned value or values. @item @t{*} If an @i{around method} invokes @b{call-next-method}, the next most specific @i{around method} is called, if one is applicable. If there are no @i{around methods} or if @b{call-next-method} is called by the least specific @i{around method}, a Lisp form derived from the name of the built-in method combination type and from the list of applicable primary methods is evaluated to produce the value of the generic function. Suppose the name of the method combination type is @i{operator} and the call to the generic function is of the form @center (@i{generic-function} a_1... a_n) @item @t{} Let M_1,...,M_k be the applicable primary methods in order; then the derived Lisp form is @center (@i{operator} < M_1 a_1... a_n>...< M_k a_1... a_n>) @item @t{} If the expression < M_i a_1... a_n> is evaluated, the method M_i will be applied to the arguments a_1... a_n. For example, if @i{operator} is @t{or}, the expression < M_i a_1... a_n> is evaluated only if < M_j a_1... a_n>, 1<= j (find-method #'gf1 '() (list (find-class 'integer))) @result{} # (function-keywords *) @result{} (:C :DEE :E EFF), @i{false} (defmethod gf2 ((a integer)) (list a b c d e f)) @result{} # (function-keywords (find-method #'gf1 '() (list (find-class 'integer)))) @result{} (), @i{false} (defmethod gf3 ((a integer) &key b c d &allow-other-keys) (list a b c d e f)) (function-keywords *) @result{} (:B :C :D), @i{true} @end example @subsubheading Affected By:: @b{defmethod} @subsubheading See Also:: @ref{defmethod} @node ensure-generic-function, allocate-instance, function-keywords, Objects Dictionary @subsection ensure-generic-function [Function] @code{ensure-generic-function} @i{function-name @r{&key} argument-precedence-order declare documentation environment generic-function-class lambda-list method-class method-combination}@* @result{} @i{generic-function} @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. The keyword arguments correspond to the @i{option} arguments of @b{defgeneric}, except that the @t{:method-class} and @t{:generic-function-class} arguments can be @i{class} @i{object}s as well as names. @t{Method-combination} -- method combination object. @t{Environment} -- the same as the @b{&environment} argument to macro expansion functions and is used to distinguish between compile-time and run-time environments. [Editorial Note by KMP: What about documentation. Missing from this arguments enumeration, and confusing in description below.] @i{generic-function}---a @i{generic function} @i{object}. @subsubheading Description:: The @i{function} @b{ensure-generic-function} is used to define a globally named @i{generic function} with no @i{methods} or to specify or modify options and declarations that pertain to a globally named @i{generic function} as a whole. If @i{function-name} is not @i{fbound} in the @i{global environment}, a new @i{generic function} is created. If @t{(fdefinition @i{function-name})} is an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error is signaled. If @i{function-name} is a @i{list}, it must be of the form @t{(setf @i{symbol})}. If @i{function-name} specifies a @i{generic function} that has a different value for any of the following arguments, the @i{generic function} is modified to have the new value: @t{:argument-precedence-order}, @t{:declare}, @t{:documentation}, @t{:method-combination}. If @i{function-name} specifies a @i{generic function} that has a different value for the @t{:lambda-list} argument, and the new value is congruent with the @i{lambda lists} of all existing @i{methods} or there are no @i{methods}, the value is changed; otherwise an error is signaled. If @i{function-name} specifies a @i{generic function} that has a different value for the @t{:generic-function-class} argument and if the new generic function class is compatible with the old, @b{change-class} is called to change the @i{class} of the @i{generic function}; otherwise an error is signaled. If @i{function-name} specifies a @i{generic function} that has a different value for the @t{:method-class} argument, the value is changed, but any existing @i{methods} are not changed. @subsubheading Affected By:: Existing function binding of @i{function-name}. @subsubheading Exceptional Situations:: If @t{(fdefinition @i{function-name})} is an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error of @i{type} @b{error} is signaled. If @i{function-name} specifies a @i{generic function} that has a different value for the @t{:lambda-list} argument, and the new value is not congruent with the @i{lambda list} of any existing @i{method}, an error of @i{type} @b{error} is signaled. If @i{function-name} specifies a @i{generic function} that has a different value for the @t{:generic-function-class} argument and if the new generic function class not is compatible with the old, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{defgeneric} @node allocate-instance, reinitialize-instance, ensure-generic-function, Objects Dictionary @subsection allocate-instance [Standard Generic Function] @subsubheading Syntax:: @code{allocate-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{new-instance} @subsubheading Method Signatures:: @code{allocate-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} @code{allocate-instance} @i{@r{(}@i{class} @b{structure-class}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{class}---a @i{class}. @i{initargs}---a @i{list} of @i{keyword/value pairs} (initialization argument @i{names} and @i{values}). @i{new-instance}---an @i{object} whose @i{class} is @i{class}. @subsubheading Description:: The generic function @b{allocate-instance} creates and returns a new instance of the @i{class}, without initializing it. When the @i{class} is a @i{standard class}, this means that the @i{slots} are @i{unbound}; when the @i{class} is a @i{structure class}, this means the @i{slots}' @i{values} are unspecified. The caller of @b{allocate-instance} is expected to have already checked the initialization arguments. The @i{generic function} @b{allocate-instance} is called by @b{make-instance}, as described in @ref{Object Creation and Initialization}. @subsubheading See Also:: @ref{defclass} , @ref{make-instance} , @ref{class-of} , @ref{Object Creation and Initialization} @subsubheading Notes:: The consequences of adding @i{methods} to @b{allocate-instance} is unspecified. This capability might be added by the @i{Metaobject Protocol}. @node reinitialize-instance, shared-initialize, allocate-instance, Objects Dictionary @subsection reinitialize-instance [Standard Generic Function] @subsubheading Syntax:: @code{reinitialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{reinitialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{initargs}---an @i{initialization argument list}. @subsubheading Description:: The @i{generic function} @b{reinitialize-instance} can be used to change the values of @i{local slots} of an @i{instance} according to @i{initargs}. This @i{generic function} can be called by users. The system-supplied primary @i{method} for @b{reinitialize-instance} checks the validity of @i{initargs} and signals an error if an @i{initarg} is supplied that is not declared as valid. The @i{method} then calls the generic function @b{shared-initialize} with the following arguments: the @i{instance}, @b{nil} (which means no @i{slots} should be initialized according to their initforms), and the @i{initargs} it received. @subsubheading Side Effects:: The @i{generic function} @b{reinitialize-instance} changes the values of @i{local slots}. @subsubheading Exceptional Situations:: The system-supplied primary @i{method} for @b{reinitialize-instance} signals an error if an @i{initarg} is supplied that is not declared as valid. @subsubheading See Also:: @ref{Initialize-Instance} , @ref{Shared-Initialize} , @ref{update-instance-for-redefined-class} , @ref{update-instance-for-different-class} , @ref{slot-boundp} , @ref{slot-makunbound} , @ref{Reinitializing an Instance}, @ref{Rules for Initialization Arguments}, @ref{Declaring the Validity of Initialization Arguments} @subsubheading Notes:: @i{Initargs} are declared as valid by using the @t{:initarg} option to @b{defclass}, or by defining @i{methods} for @b{reinitialize-instance} or @b{shared-initialize}. The keyword name of each keyword parameter specifier in the @i{lambda list} of any @i{method} defined on @b{reinitialize-instance} or @b{shared-initialize} is declared as a valid initialization argument name for all @i{classes} for which that @i{method} is applicable. @node shared-initialize, update-instance-for-different-class, reinitialize-instance, Objects Dictionary @subsection shared-initialize [Standard Generic Function] @subsubheading Syntax:: @code{shared-initialize} @i{instance slot-names @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{shared-initialize} @i{@r{(}@i{instance} @b{standard-object}@r{)} slot-names @r{&rest} initargs} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{slot-names}---a @i{list} or @b{t}. @i{initargs}---a @i{list} of @i{keyword/value pairs} (of initialization argument @i{names} and @i{values}). @subsubheading Description:: The generic function @b{shared-initialize} is used to fill the @i{slots} of an @i{instance} using @i{initargs} and @t{:initform} forms. It is called when an instance is created, when an instance is re-initialized, when an instance is updated to conform to a redefined @i{class}, and when an instance is updated to conform to a different @i{class}. The generic function @b{shared-initialize} is called by the system-supplied primary @i{method} for @b{initialize-instance}, @b{reinitialize-instance}, @b{update-instance-for-redefined-class}, and @b{update-instance-for-different-class}. The generic function @b{shared-initialize} takes the following arguments: the @i{instance} to be initialized, a specification of a set of @i{slot-names} @i{accessible} in that @i{instance}, and any number of @i{initargs}. The arguments after the first two must form an @i{initialization argument list}. The system-supplied primary @i{method} on @b{shared-initialize} initializes the @i{slots} with values according to the @i{initargs} and supplied @t{:initform} forms. @i{Slot-names} indicates which @i{slots} should be initialized according to their @t{:initform} forms if no @i{initargs} are provided for those @i{slots}. The system-supplied primary @i{method} behaves as follows, regardless of whether the @i{slots} are local or shared: @table @asis @item @t{*} If an @i{initarg} in the @i{initialization argument list} specifies a value for that @i{slot}, that value is stored into the @i{slot}, even if a value has already been stored in the @i{slot} before the @i{method} is run. @item @t{*} Any @i{slots} indicated by @i{slot-names} that are still unbound at this point are initialized according to their @t{:initform} forms. For any such @i{slot} that has an @t{:initform} form, that @i{form} is evaluated in the lexical environment of its defining @b{defclass} @i{form} and the result is stored into the @i{slot}. For example, if a @i{before method} stores a value in the @i{slot}, the @t{:initform} form will not be used to supply a value for the @i{slot}. @item @t{*} The rules mentioned in @ref{Rules for Initialization Arguments} are obeyed. @end table The @i{slots-names} argument specifies the @i{slots} that are to be initialized according to their @t{:initform} forms if no initialization arguments apply. It can be a @i{list} of slot @i{names}, which specifies the set of those slot @i{names}; or it can be the @i{symbol} @b{t}, which specifies the set of all of the @i{slots}. @subsubheading See Also:: @ref{Initialize-Instance} , @ref{reinitialize-instance} , @ref{update-instance-for-redefined-class} , @ref{update-instance-for-different-class} , @ref{slot-boundp} , @ref{slot-makunbound} , @ref{Object Creation and Initialization}, @ref{Rules for Initialization Arguments}, @ref{Declaring the Validity of Initialization Arguments} @subsubheading Notes:: @i{Initargs} are declared as valid by using the @t{:initarg} option to @b{defclass}, or by defining @i{methods} for @b{shared-initialize}. The keyword name of each keyword parameter specifier in the @i{lambda list} of any @i{method} defined on @b{shared-initialize} is declared as a valid @i{initarg} name for all @i{classes} for which that @i{method} is applicable. Implementations are permitted to optimize @t{:initform} forms that neither produce nor depend on side effects, by evaluating these @i{forms} and storing them into slots before running any @b{initialize-instance} methods, rather than by handling them in the primary @b{initialize-instance} method. (This optimization might be implemented by having the @b{allocate-instance} method copy a prototype instance.) Implementations are permitted to optimize default initial value forms for @i{initargs} associated with slots by not actually creating the complete initialization argument @i{list} when the only @i{method} that would receive the complete @i{list} is the @i{method} on @b{standard-object}. In this case default initial value forms can be treated like @t{:initform} forms. This optimization has no visible effects other than a performance improvement. @node update-instance-for-different-class, update-instance-for-redefined-class, shared-initialize, Objects Dictionary @subsection update-instance-for-different-class [Standard Generic Function] @subsubheading Syntax:: @code{update-instance-for-different-class} @i{previous current @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{@i{implementation-dependent}} @subsubheading Method Signatures:: @code{update-instance-for-different-class} @i{@r{(}@i{previous} @b{standard-object}@r{)} @r{(}@i{current} @b{standard-object}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{previous}---a copy of the original @i{instance}. @i{current}---the original @i{instance} (altered). @i{initargs}---an @i{initialization argument list}. @subsubheading Description:: The generic function @b{update-instance-for-different-class} is not intended to be called by programmers. Programmers may write @i{methods} for it. The @i{function} @b{update-instance-for-different-class} is called only by the @i{function} @b{change-class}. The system-supplied primary @i{method} on @b{update-instance-for-different-class} checks the validity of @i{initargs} and signals an error if an @i{initarg} is supplied that is not declared as valid. This @i{method} then initializes @i{slots} with values according to the @i{initargs}, and initializes the newly added @i{slots} with values according to their @t{:initform} forms. It does this by calling the generic function @b{shared-initialize} with the following arguments: the instance (@i{current}), a list of @i{names} of the newly added @i{slots}, and the @i{initargs} it received. Newly added @i{slots} are those @i{local slots} for which no @i{slot} of the same name exists in the @i{previous} class. @i{Methods} for @b{update-instance-for-different-class} can be defined to specify actions to be taken when an @i{instance} is updated. If only @i{after methods} for @b{update-instance-for-different-class} are defined, they will be run after the system-supplied primary @i{method} for initialization and therefore will not interfere with the default behavior of @b{update-instance-for-different-class}. @i{Methods} on @b{update-instance-for-different-class} can be defined to initialize @i{slots} differently from @b{change-class}. The default behavior of @b{change-class} is described in @ref{Changing the Class of an Instance}. The arguments to @b{update-instance-for-different-class} are computed by @b{change-class}. When @b{change-class} is invoked on an @i{instance}, a copy of that @i{instance} is made; @b{change-class} then destructively alters the original @i{instance}. The first argument to @b{update-instance-for-different-class}, @i{previous}, is that copy; it holds the old @i{slot} values temporarily. This argument has dynamic extent within @b{change-class}; if it is referenced in any way once @b{update-instance-for-different-class} returns, the results are undefined. The second argument to @b{update-instance-for-different-class}, @i{current}, is the altered original @i{instance}. The intended use of @i{previous} is to extract old @i{slot} values by using @b{slot-value} or @b{with-slots} or by invoking a reader generic function, or to run other @i{methods} that were applicable to @i{instances} of the original @i{class}. @subsubheading Examples:: See the example for the @i{function} @b{change-class}. @subsubheading Exceptional Situations:: The system-supplied primary @i{method} on @b{update-instance-for-different-class} signals an error if an initialization argument is supplied that is not declared as valid. @subsubheading See Also:: @ref{change-class} , @ref{Shared-Initialize} , @ref{Changing the Class of an Instance}, @ref{Rules for Initialization Arguments}, @ref{Declaring the Validity of Initialization Arguments} @subsubheading Notes:: @i{Initargs} are declared as valid by using the @t{:initarg} option to @b{defclass}, or by defining @i{methods} for @b{update-instance-for-different-class} or @b{shared-initialize}. The keyword name of each keyword parameter specifier in the @i{lambda list} of any @i{method} defined on @b{update-instance-for-different-class} or @b{shared-initialize} is declared as a valid @i{initarg} name for all @i{classes} for which that @i{method} is applicable. The value returned by @b{update-instance-for-different-class} is ignored by @b{change-class}. @node update-instance-for-redefined-class, change-class, update-instance-for-different-class, Objects Dictionary @subsection update-instance-for-redefined-class [Standard Generic Function] @subsubheading Syntax:: @code{update-instance-for-redefined-class} @i{instance added-slots discarded-slots property-list @r{&rest} initargs @r{&key} @r{&allow-other-keys}}@* @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{update-instance-for-redefined-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} added-slots discarded-slots property-list @r{&rest} initargs} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{added-slots}---a @i{list}. @i{discarded-slots}---a @i{list}. @i{property-list}---a @i{list}. @i{initargs}---an @i{initialization argument list}. @i{result}---an @i{object}. @subsubheading Description:: The @i{generic function} @b{update-instance-for-redefined-class} is not intended to be called by programmers. Programmers may write @i{methods} for it. The @i{generic function} @b{update-instance-for-redefined-class} is called by the mechanism activated by @b{make-instances-obsolete}. The system-supplied primary @i{method} on @b{update-instance-for-redefined-class} checks the validity of @i{initargs} and signals an error if an @i{initarg} is supplied that is not declared as valid. This @i{method} then initializes @i{slots} with values according to the @i{initargs}, and initializes the newly @i{added-slots} with values according to their @t{:initform} forms. It does this by calling the generic function @b{shared-initialize} with the following arguments: the @i{instance}, a list of names of the newly @i{added-slots} to @i{instance}, and the @i{initargs} it received. Newly @i{added-slots} are those @i{local slots} for which no @i{slot} of the same name exists in the old version of the @i{class}. When @b{make-instances-obsolete} is invoked or when a @i{class} has been redefined and an @i{instance} is being updated, a @i{property-list} is created that captures the slot names and values of all the @i{discarded-slots} with values in the original @i{instance}. The structure of the @i{instance} is transformed so that it conforms to the current class definition. The arguments to @b{update-instance-for-redefined-class} are this transformed @i{instance}, a list of @i{added-slots} to the @i{instance}, a list @i{discarded-slots} from the @i{instance}, and the @i{property-list} containing the slot names and values for @i{slots} that were discarded and had values. Included in this list of discarded @i{slots} are @i{slots} that were local in the old @i{class} and are shared in the new @i{class}. The value returned by @b{update-instance-for-redefined-class} is ignored. @subsubheading Examples:: @example (defclass position () ()) (defclass x-y-position (position) ((x :initform 0 :accessor position-x) (y :initform 0 :accessor position-y))) ;;; It turns out polar coordinates are used more than Cartesian ;;; coordinates, so the representation is altered and some new ;;; accessor methods are added. (defmethod update-instance-for-redefined-class :before ((pos x-y-position) added deleted plist &key) ;; Transform the x-y coordinates to polar coordinates ;; and store into the new slots. (let ((x (getf plist 'x)) (y (getf plist 'y))) (setf (position-rho pos) (sqrt (+ (* x x) (* y y))) (position-theta pos) (atan y x)))) (defclass x-y-position (position) ((rho :initform 0 :accessor position-rho) (theta :initform 0 :accessor position-theta))) ;;; All instances of the old x-y-position class will be updated ;;; automatically. ;;; The new representation is given the look and feel of the old one. (defmethod position-x ((pos x-y-position)) (with-slots (rho theta) pos (* rho (cos theta)))) (defmethod (setf position-x) (new-x (pos x-y-position)) (with-slots (rho theta) pos (let ((y (position-y pos))) (setq rho (sqrt (+ (* new-x new-x) (* y y))) theta (atan y new-x)) new-x))) (defmethod position-y ((pos x-y-position)) (with-slots (rho theta) pos (* rho (sin theta)))) (defmethod (setf position-y) (new-y (pos x-y-position)) (with-slots (rho theta) pos (let ((x (position-x pos))) (setq rho (sqrt (+ (* x x) (* new-y new-y))) theta (atan new-y x)) new-y))) @end example @subsubheading Exceptional Situations:: The system-supplied primary @i{method} on @b{update-instance-for-redefined-class} signals an error if an @i{initarg} is supplied that is not declared as valid. @subsubheading See Also:: @ref{make-instances-obsolete} , @ref{Shared-Initialize} , @ref{Redefining Classes}, @ref{Rules for Initialization Arguments}, @ref{Declaring the Validity of Initialization Arguments} @subsubheading Notes:: @i{Initargs} are declared as valid by using the @t{:initarg} option to @b{defclass}, or by defining @i{methods} for @b{update-instance-for-redefined-class} or @b{shared-initialize}. The keyword name of each keyword parameter specifier in the @i{lambda list} of any @i{method} defined on @b{update-instance-for-redefined-class} or @b{shared-initialize} is declared as a valid @i{initarg} name for all @i{classes} for which that @i{method} is applicable. @node change-class, slot-boundp, update-instance-for-redefined-class, Objects Dictionary @subsection change-class [Standard Generic Function] @subsubheading Syntax:: @code{change-class} @i{instance new-class @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{change-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{(}@i{new-class} @b{standard-class}@r{)} @r{&rest} initargs} @code{change-class} @i{@r{(}@i{instance} @b{t}@r{)} @r{(}@i{new-class} @b{symbol}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{new-class}---a @i{class designator}. @i{initargs}---an @i{initialization argument list}. @subsubheading Description:: The @i{generic function} @b{change-class} changes the @i{class} of an @i{instance} to @i{new-class}. It destructively modifies and returns the @i{instance}. If in the old @i{class} there is any @i{slot} of the same name as a local @i{slot} in the @i{new-class}, the value of that @i{slot} is retained. This means that if the @i{slot} has a value, the value returned by @b{slot-value} after @b{change-class} is invoked is @b{eql} to the value returned by @b{slot-value} before @b{change-class} is invoked. Similarly, if the @i{slot} was unbound, it remains unbound. The other @i{slots} are initialized as described in @ref{Changing the Class of an Instance}. After completing all other actions, @b{change-class} invokes @b{update-instance-for-different-class}. The generic function @b{update-instance-for-different-class} can be used to assign values to slots in the transformed instance. See @ref{Initializing Newly Added Local Slots (Changing the Class of an Instance)}. If the second of the above @i{methods} is selected, that @i{method} invokes @b{change-class} on @i{instance}, @t{(find-class @i{new-class})}, and the @i{initargs}. @subsubheading Examples:: @example (defclass position () ()) (defclass x-y-position (position) ((x :initform 0 :initarg :x) (y :initform 0 :initarg :y))) (defclass rho-theta-position (position) ((rho :initform 0) (theta :initform 0))) (defmethod update-instance-for-different-class :before ((old x-y-position) (new rho-theta-position) &key) ;; Copy the position information from old to new to make new ;; be a rho-theta-position at the same position as old. (let ((x (slot-value old 'x)) (y (slot-value old 'y))) (setf (slot-value new 'rho) (sqrt (+ (* x x) (* y y))) (slot-value new 'theta) (atan y x)))) ;;; At this point an instance of the class x-y-position can be ;;; changed to be an instance of the class rho-theta-position using ;;; change-class: (setq p1 (make-instance 'x-y-position :x 2 :y 0)) (change-class p1 'rho-theta-position) ;;; The result is that the instance bound to p1 is now an instance of ;;; the class rho-theta-position. The update-instance-for-different-class ;;; method performed the initialization of the rho and theta slots based ;;; on the value of the x and y slots, which were maintained by ;;; the old instance. @end example @subsubheading See Also:: @ref{update-instance-for-different-class} , @ref{Changing the Class of an Instance} @subsubheading Notes:: The generic function @b{change-class} has several semantic difficulties. First, it performs a destructive operation that can be invoked within a @i{method} on an @i{instance} that was used to select that @i{method}. When multiple @i{methods} are involved because @i{methods} are being combined, the @i{methods} currently executing or about to be executed may no longer be applicable. Second, some implementations might use compiler optimizations of slot @i{access}, and when the @i{class} of an @i{instance} is changed the assumptions the compiler made might be violated. This implies that a programmer must not use @b{change-class} inside a @i{method} if any @i{methods} for that @i{generic function} @i{access} any @i{slots}, or the results are undefined. @node slot-boundp, slot-exists-p, change-class, Objects Dictionary @subsection slot-boundp [Function] @code{slot-boundp} @i{instance slot-name} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{slot-name}---a @i{symbol} naming a @i{slot} of @i{instance}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if the @i{slot} named @i{slot-name} in @i{instance} is bound; otherwise, returns @i{false}. @subsubheading Exceptional Situations:: If no @i{slot} of the @i{name} @i{slot-name} exists in the @i{instance}, @b{slot-missing} is called as follows: @example (slot-missing (class-of @i{instance}) @i{instance} @i{slot-name} 'slot-boundp) @end example (If @b{slot-missing} is invoked and returns a value, a @i{boolean equivalent} to its @i{primary value} is returned by @b{slot-boundp}.) The specific behavior depends on @i{instance}'s @i{metaclass}. An error is never signaled if @i{instance} has @i{metaclass} @b{standard-class}. An error is always signaled if @i{instance} has @i{metaclass} @b{built-in-class}. The consequences are undefined if @i{instance} has any other @i{metaclass}--an error might or might not be signaled in this situation. Note in particular that the behavior for @i{conditions} and @i{structures} is not specified. @subsubheading See Also:: @ref{slot-makunbound} , @ref{slot-missing} @subsubheading Notes:: The @i{function} @b{slot-boundp} allows for writing @i{after methods} on @b{initialize-instance} in order to initialize only those @i{slots} that have not already been bound. Although no @i{implementation} is required to do so, implementors are strongly encouraged to implement the @i{function} @b{slot-boundp} using the @i{function} @t{slot-boundp-using-class} described in the @i{Metaobject Protocol}. @node slot-exists-p, slot-makunbound, slot-boundp, Objects Dictionary @subsection slot-exists-p [Function] @code{slot-exists-p} @i{object slot-name} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{slot-name}---a @i{symbol}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if the @i{object} has a @i{slot} named @i{slot-name}. @subsubheading Affected By:: @b{defclass}, @b{defstruct} @subsubheading See Also:: @ref{defclass} , @ref{slot-missing} @subsubheading Notes:: Although no @i{implementation} is required to do so, implementors are strongly encouraged to implement the @i{function} @b{slot-exists-p} using the @i{function} @t{slot-exists-p-using-class} described in the @i{Metaobject Protocol}. @node slot-makunbound, slot-missing, slot-exists-p, Objects Dictionary @subsection slot-makunbound [Function] @code{slot-makunbound} @i{instance slot-name} @result{} @i{instance} @subsubheading Arguments and Values:: @i{instance} -- instance. @i{Slot-name}---a @i{symbol}. @subsubheading Description:: The @i{function} @b{slot-makunbound} restores a @i{slot} of the name @i{slot-name} in an @i{instance} to the unbound state. @subsubheading Exceptional Situations:: If no @i{slot} of the name @i{slot-name} exists in the @i{instance}, @b{slot-missing} is called as follows: @example (slot-missing (class-of @i{instance}) @i{instance} @i{slot-name} 'slot-makunbound) @end example (Any values returned by @b{slot-missing} in this case are ignored by @b{slot-makunbound}.) The specific behavior depends on @i{instance}'s @i{metaclass}. An error is never signaled if @i{instance} has @i{metaclass} @b{standard-class}. An error is always signaled if @i{instance} has @i{metaclass} @b{built-in-class}. The consequences are undefined if @i{instance} has any other @i{metaclass}--an error might or might not be signaled in this situation. Note in particular that the behavior for @i{conditions} and @i{structures} is not specified. @subsubheading See Also:: @ref{slot-boundp} , @ref{slot-missing} @subsubheading Notes:: Although no @i{implementation} is required to do so, implementors are strongly encouraged to implement the @i{function} @b{slot-makunbound} using the @i{function} @t{slot-makunbound-using-class} described in the @i{Metaobject Protocol}. @node slot-missing, slot-unbound, slot-makunbound, Objects Dictionary @subsection slot-missing [Standard Generic Function] @subsubheading Syntax:: @code{slot-missing} @i{class object slot-name operation @r{&optional} new-value} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{slot-missing} @i{@r{(}@i{class} @b{t}@r{)} object slot-name operation @r{&optional} new-value} @subsubheading Arguments and Values:: @i{class}---the @i{class} of @i{object}. @i{object}---an @i{object}. @i{slot-name}---a @i{symbol} (the @i{name} of a would-be @i{slot}). @i{operation}---one of the @i{symbols} @b{setf}, @b{slot-boundp}, @b{slot-makunbound}, or @b{slot-value}. @i{new-value}---an @i{object}. @i{result}---an @i{object}. @subsubheading Description:: The generic function @b{slot-missing} is invoked when an attempt is made to @i{access} a @i{slot} in an @i{object} whose @i{metaclass} is @b{standard-class} and the @i{slot} of the name @i{slot-name} is not a @i{name} of a @i{slot} in that @i{class}. The default @i{method} signals an error. The generic function @b{slot-missing} is not intended to be called by programmers. Programmers may write @i{methods} for it. The generic function @b{slot-missing} may be called during evaluation of @b{slot-value}, @t{(setf slot-value)}, @b{slot-boundp}, and @b{slot-makunbound}. For each of these operations the corresponding @i{symbol} for the @i{operation} argument is @b{slot-value}, @b{setf}, @b{slot-boundp}, and @b{slot-makunbound} respectively. The optional @i{new-value} argument to @b{slot-missing} is used when the operation is attempting to set the value of the @i{slot}. If @b{slot-missing} returns, its values will be treated as follows: @table @asis @item @t{*} If the @i{operation} is @b{setf} or @b{slot-makunbound}, any @i{values} will be ignored by the caller. @item @t{*} If the @i{operation} is @b{slot-value}, only the @i{primary value} will be used by the caller, and all other values will be ignored. @item @t{*} If the @i{operation} is @b{slot-boundp}, any @i{boolean equivalent} of the @i{primary value} of the @i{method} might be is used, and all other values will be ignored. @end table @subsubheading Exceptional Situations:: The default @i{method} on @b{slot-missing} signals an error of @i{type} @b{error}. @subsubheading See Also:: @ref{defclass} , @ref{slot-exists-p} , @ref{slot-value} @subsubheading Notes:: The set of arguments (including the @i{class} of the instance) facilitates defining methods on the metaclass for @b{slot-missing}. @node slot-unbound, slot-value, slot-missing, Objects Dictionary @subsection slot-unbound [Standard Generic Function] @subsubheading Syntax:: @code{slot-unbound} @i{class instance slot-name} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{slot-unbound} @i{@r{(}@i{class} @b{t}@r{)} instance slot-name} @subsubheading Arguments and Values:: @i{class}---the @i{class} of the @i{instance}. @i{instance}---the @i{instance} in which an attempt was made to @i{read} the @i{unbound} @i{slot}. @i{slot-name}---the @i{name} of the @i{unbound} @i{slot}. @i{result}---an @i{object}. @subsubheading Description:: The generic function @b{slot-unbound} is called when an unbound @i{slot} is read in an @i{instance} whose metaclass is @b{standard-class}. The default @i{method} signals an error of @i{type} @b{unbound-slot}. The name slot of the @b{unbound-slot} @i{condition} is initialized to the name of the offending variable, and the instance slot of the @b{unbound-slot} @i{condition} is initialized to the offending instance. The generic function @b{slot-unbound} is not intended to be called by programmers. Programmers may write @i{methods} for it. The @i{function} @b{slot-unbound} is called only indirectly by @b{slot-value}. If @b{slot-unbound} returns, only the @i{primary value} will be used by the caller, and all other values will be ignored. @subsubheading Exceptional Situations:: The default @i{method} on @b{slot-unbound} signals an error of @i{type} @b{unbound-slot}. @subsubheading See Also:: @ref{slot-makunbound} @subsubheading Notes:: An unbound @i{slot} may occur if no @t{:initform} form was specified for the @i{slot} and the @i{slot} value has not been set, or if @b{slot-makunbound} has been called on the @i{slot}. @node slot-value, method-qualifiers, slot-unbound, Objects Dictionary @subsection slot-value [Function] @code{slot-value} @i{object slot-name} @result{} @i{value} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{name}---a @i{symbol}. @i{value}---an @i{object}. @subsubheading Description:: The @i{function} @b{slot-value} returns the @i{value} of the @i{slot} named @i{slot-name} in the @i{object}. If there is no @i{slot} named @i{slot-name}, @b{slot-missing} is called. If the @i{slot} is unbound, @b{slot-unbound} is called. The macro @b{setf} can be used with @b{slot-value} to change the value of a @i{slot}. @subsubheading Examples:: @example (defclass foo () ((a :accessor foo-a :initarg :a :initform 1) (b :accessor foo-b :initarg :b) (c :accessor foo-c :initform 3))) @result{} # (setq foo1 (make-instance 'foo :a 'one :b 'two)) @result{} # (slot-value foo1 'a) @result{} ONE (slot-value foo1 'b) @result{} TWO (slot-value foo1 'c) @result{} 3 (setf (slot-value foo1 'a) 'uno) @result{} UNO (slot-value foo1 'a) @result{} UNO (defmethod foo-method ((x foo)) (slot-value x 'a)) @result{} # (foo-method foo1) @result{} UNO @end example @subsubheading Exceptional Situations:: If an attempt is made to read a @i{slot} and no @i{slot} of the name @i{slot-name} exists in the @i{object}, @b{slot-missing} is called as follows: @example (slot-missing (class-of @i{instance}) @i{instance} @i{slot-name} 'slot-value) @end example (If @b{slot-missing} is invoked, its @i{primary value} is returned by @b{slot-value}.) If an attempt is made to write a @i{slot} and no @i{slot} of the name @i{slot-name} exists in the @i{object}, @b{slot-missing} is called as follows: @example (slot-missing (class-of @i{instance}) @i{instance} @i{slot-name} 'setf @i{new-value}) @end example (If @b{slot-missing} returns in this case, any @i{values} are ignored.) The specific behavior depends on @i{object}'s @i{metaclass}. An error is never signaled if @i{object} has @i{metaclass} @b{standard-class}. An error is always signaled if @i{object} has @i{metaclass} @b{built-in-class}. The consequences are unspecified if @i{object} has any other @i{metaclass}--an error might or might not be signaled in this situation. Note in particular that the behavior for @i{conditions} and @i{structures} is not specified. @subsubheading See Also:: @ref{slot-missing} , @ref{slot-unbound} , @ref{with-slots} @subsubheading Notes:: Although no @i{implementation} is required to do so, implementors are strongly encouraged to implement the @i{function} @b{slot-value} using the @i{function} @t{slot-value-using-class} described in the @i{Metaobject Protocol}. Implementations may optimize @b{slot-value} by compiling it inline. @node method-qualifiers, no-applicable-method, slot-value, Objects Dictionary @subsection method-qualifiers [Standard Generic Function] @subsubheading Syntax:: @code{method-qualifiers} @i{method} @result{} @i{qualifiers} @subsubheading Method Signatures:: @code{method-qualifiers} @i{@r{(}@i{method} @b{standard-method}@r{)}} @subsubheading Arguments and Values:: @i{method}---a @i{method}. @i{qualifiers}---a @i{proper list}. @subsubheading Description:: Returns a @i{list} of the @i{qualifiers} of the @i{method}. @subsubheading Examples:: @example (defmethod some-gf :before ((a integer)) a) @result{} # (method-qualifiers *) @result{} (:BEFORE) @end example @subsubheading See Also:: @ref{define-method-combination} @node no-applicable-method, no-next-method, method-qualifiers, Objects Dictionary @subsection no-applicable-method [Standard Generic Function] @subsubheading Syntax:: @code{no-applicable-method} @i{generic-function @r{&rest} function-arguments} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{no-applicable-method} @i{@r{(}@i{generic-function} @b{t}@r{)} @r{&rest} function-arguments} @subsubheading Arguments and Values:: @i{generic-function}---a @i{generic function} on which no @i{applicable method} was found. @i{function-arguments}---@i{arguments} to the @i{generic-function}. @i{result}---an @i{object}. @subsubheading Description:: The generic function @b{no-applicable-method} is called when a @i{generic function} is invoked and no @i{method} on that @i{generic function} is applicable. The @i{default method} signals an error. The generic function @b{no-applicable-method} is not intended to be called by programmers. Programmers may write @i{methods} for it. @subsubheading Exceptional Situations:: The default @i{method} signals an error of @i{type} @b{error}. @subsubheading See Also:: @node no-next-method, remove-method, no-applicable-method, Objects Dictionary @subsection no-next-method [Standard Generic Function] @subsubheading Syntax:: @code{no-next-method} @i{generic-function method @r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{no-next-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} @r{(}@i{method} @b{standard-method}@r{)} @r{&rest} args} @subsubheading Arguments and Values:: @i{generic-function} -- @i{generic function} to which @i{method} belongs. @i{method} -- @i{method} that contained the call to @b{call-next-method} for which there is no next @i{method}. @i{args} -- arguments to @b{call-next-method}. @i{result}---an @i{object}. @subsubheading Description:: The @i{generic function} @b{no-next-method} is called by @b{call-next-method} when there is no @i{next method}. The @i{generic function} @b{no-next-method} is not intended to be called by programmers. Programmers may write @i{methods} for it. @subsubheading Exceptional Situations:: The system-supplied @i{method} on @b{no-next-method} signals an error of @i{type} @b{error}. [Editorial Note by KMP: perhaps control-error??] @subsubheading See Also:: @ref{call-next-method} @node remove-method, make-instance, no-next-method, Objects Dictionary @subsection remove-method [Standard Generic Function] @subsubheading Syntax:: @code{remove-method} @i{generic-function method} @result{} @i{generic-function} @subsubheading Method Signatures:: @code{remove-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} method} @subsubheading Arguments and Values:: @i{generic-function}---a @i{generic function}. @i{method}---a @i{method}. @subsubheading Description:: The @i{generic function} @b{remove-method} removes a @i{method} from @i{generic-function} by modifying the @i{generic-function} (if necessary). @b{remove-method} must not signal an error if the @i{method} is not one of the @i{methods} on the @i{generic-function}. @subsubheading See Also:: @ref{find-method} @node make-instance, make-instances-obsolete, remove-method, Objects Dictionary @subsection make-instance [Standard Generic Function] @subsubheading Syntax:: @code{make-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{make-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} @code{make-instance} @i{@r{(}@i{class} @b{symbol}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{class}---a @i{class}, or a @i{symbol} that names a @i{class}. @i{initargs}---an @i{initialization argument list}. @i{instance}---a @i{fresh} @i{instance} of @i{class} @i{class}. @subsubheading Description:: The @i{generic function} @b{make-instance} creates and returns a new @i{instance} of the given @i{class}. If the second of the above @i{methods} is selected, that @i{method} invokes @b{make-instance} on the arguments @t{(find-class @i{class})} and @i{initargs}. The initialization arguments are checked within @b{make-instance}. The @i{generic function} @b{make-instance} may be used as described in @ref{Object Creation and Initialization}. @subsubheading Exceptional Situations:: If any of the initialization arguments has not been declared as valid, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{defclass} , @ref{class-of} , @ref{allocate-instance} , @ref{Initialize-Instance} , @ref{Object Creation and Initialization} @node make-instances-obsolete, make-load-form, make-instance, Objects Dictionary @subsection make-instances-obsolete [Standard Generic Function] @subsubheading Syntax:: @code{make-instances-obsolete} @i{class} @result{} @i{class} @subsubheading Method Signatures:: @code{make-instances-obsolete} @i{@r{(}@i{class} @b{standard-class}@r{)}} @code{make-instances-obsolete} @i{@r{(}@i{class} @b{symbol}@r{)}} @subsubheading Arguments and Values:: @i{class}---a @i{class designator}. @subsubheading Description:: The @i{function} @b{make-instances-obsolete} has the effect of initiating the process of updating the instances of the @i{class}. During updating, the generic function @b{update-instance-for-redefined-class} will be invoked. The generic function @b{make-instances-obsolete} is invoked automatically by the system when @b{defclass} has been used to redefine an existing standard class and the set of local @i{slots} @i{accessible} in an instance is changed or the order of @i{slots} in storage is changed. It can also be explicitly invoked by the user. If the second of the above @i{methods} is selected, that @i{method} invokes @b{make-instances-obsolete} on @t{(find-class @i{class})}. @subsubheading Examples:: @subsubheading See Also:: @ref{update-instance-for-redefined-class} , @ref{Redefining Classes} @node make-load-form, make-load-form-saving-slots, make-instances-obsolete, Objects Dictionary @subsection make-load-form [Standard Generic Function] @subsubheading Syntax:: @code{make-load-form} @i{object @r{&optional} environment} @result{} @i{creation-form @r{[}, initialization-form @r{]}} @subsubheading Method Signatures:: @code{make-load-form} @i{@r{(}@i{object} @b{standard-object}@r{)} @r{&optional} environment} @code{make-load-form} @i{@r{(}@i{object} @b{structure-object}@r{)} @r{&optional} environment} @code{make-load-form} @i{@r{(}@i{object} @b{condition}@r{)} @r{&optional} environment} @code{make-load-form} @i{@r{(}@i{object} @b{class}@r{)} @r{&optional} environment} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{environment}---an @i{environment object}. @i{creation-form}---a @i{form}. @i{initialization-form}---a @i{form}. @subsubheading Description:: The @i{generic function} @b{make-load-form} creates and returns one or two @i{forms}, a @i{creation-form} and an @i{initialization-form}, that enable @b{load} to construct an @i{object} equivalent to @i{object}. @i{Environment} is an @i{environment object} corresponding to the @i{lexical environment} in which the @i{forms} will be processed. The @i{file compiler} calls @b{make-load-form} to process certain @i{classes} of @i{literal objects}; see @ref{Additional Constraints on Externalizable Objects}. @i{Conforming programs} may call @b{make-load-form} directly, providing @i{object} is a @i{generalized instance} of @b{standard-object}, @b{structure-object}, or @b{condition}. The creation form is a @i{form} that, when evaluated at @b{load} time, should return an @i{object} that is equivalent to @i{object}. The exact meaning of equivalent depends on the @i{type} of @i{object} and is up to the programmer who defines a @i{method} for @b{make-load-form}; see @ref{Literal Objects in Compiled Files}. The initialization form is a @i{form} that, when evaluated at @b{load} time, should perform further initialization of the @i{object}. The value returned by the initialization form is ignored. If @b{make-load-form} returns only one value, the initialization form is @b{nil}, which has no effect. If @i{object} appears as a constant in the initialization form, at @b{load} time it will be replaced by the equivalent @i{object} constructed by the creation form; this is how the further initialization gains access to the @i{object}. Both the @i{creation-form} and the @i{initialization-form} may contain references to any @i{externalizable object}. However, there must not be any circular dependencies in creation forms. An example of a circular dependency is when the creation form for the object @t{X} contains a reference to the object @t{Y}, and the creation form for the object @t{Y} contains a reference to the object @t{X}. Initialization forms are not subject to any restriction against circular dependencies, which is the reason that initialization forms exist; see the example of circular data structures below. The creation form for an @i{object} is always @i{evaluated} before the initialization form for that @i{object}. When either the creation form or the initialization form references other @i{objects} that have not been referenced earlier in the @i{file} being @i{compiled}, the @i{compiler} ensures that all of the referenced @i{objects} have been created before @i{evaluating} the referencing @i{form}. When the referenced @i{object} is of a @i{type} which the @i{file compiler} processes using @b{make-load-form}, this involves @i{evaluating} the creation form returned for it. (This is the reason for the prohibition against circular references among creation forms). Each initialization form is @i{evaluated} as soon as possible after its associated creation form, as determined by data flow. If the initialization form for an @i{object} does not reference any other @i{objects} not referenced earlier in the @i{file} and processed by the @i{file compiler} using @b{make-load-form}, the initialization form is evaluated immediately after the creation form. If a creation or initialization form F does contain references to such @i{objects}, the creation forms for those other objects are evaluated before F, and the initialization forms for those other @i{objects} are also evaluated before F whenever they do not depend on the @i{object} created or initialized by F. Where these rules do not uniquely determine an order of @i{evaluation} between two creation/initialization forms, the order of @i{evaluation} is unspecified. While these creation and initialization forms are being evaluated, the @i{objects} are possibly in an uninitialized state, analogous to the state of an @i{object} between the time it has been created by @b{allocate-instance} and it has been processed fully by @b{initialize-instance}. Programmers writing @i{methods} for @b{make-load-form} must take care in manipulating @i{objects} not to depend on @i{slots} that have not yet been initialized. It is @i{implementation-dependent} whether @b{load} calls @b{eval} on the @i{forms} or does some other operation that has an equivalent effect. For example, the @i{forms} might be translated into different but equivalent @i{forms} and then evaluated, they might be compiled and the resulting functions called by @b{load}, or they might be interpreted by a special-purpose function different from @b{eval}. All that is required is that the effect be equivalent to evaluating the @i{forms}. The @i{method} @i{specialized} on @b{class} returns a creation @i{form} using the @i{name} of the @i{class} if the @i{class} has a @i{proper name} in @i{environment}, signaling an error of @i{type} @b{error} if it does not have a @i{proper name}. @i{Evaluation} of the creation @i{form} uses the @i{name} to find the @i{class} with that @i{name}, as if by @i{calling} @b{find-class}. If a @i{class} with that @i{name} has not been defined, then a @i{class} may be computed in an @i{implementation-defined} manner. If a @i{class} cannot be returned as the result of @i{evaluating} the creation @i{form}, then an error of @i{type} @b{error} is signaled. Both @i{conforming implementations} and @i{conforming programs} may further @i{specialize} @b{make-load-form}. @subsubheading Examples:: @example (defclass obj () ((x :initarg :x :reader obj-x) (y :initarg :y :reader obj-y) (dist :accessor obj-dist))) @result{} # (defmethod shared-initialize :after ((self obj) slot-names &rest keys) (declare (ignore slot-names keys)) (unless (slot-boundp self 'dist) (setf (obj-dist self) (sqrt (+ (expt (obj-x self) 2) (expt (obj-y self) 2)))))) @result{} # (defmethod make-load-form ((self obj) &optional environment) (declare (ignore environment)) ;; Note that this definition only works because X and Y do not ;; contain information which refers back to the object itself. ;; For a more general solution to this problem, see revised example below. `(make-instance ',(class-of self) :x ',(obj-x self) :y ',(obj-y self))) @result{} # (setq obj1 (make-instance 'obj :x 3.0 :y 4.0)) @result{} # (obj-dist obj1) @result{} 5.0 (make-load-form obj1) @result{} (MAKE-INSTANCE 'OBJ :X '3.0 :Y '4.0) @end example In the above example, an equivalent @i{instance} of @t{obj} is reconstructed by using the values of two of its @i{slots}. The value of the third @i{slot} is derived from those two values. Another way to write the @b{make-load-form} @i{method} in that example is to use @b{make-load-form-saving-slots}. The code it generates might yield a slightly different result from the @b{make-load-form} @i{method} shown above, but the operational effect will be the same. For example: @example ;; Redefine method defined above. (defmethod make-load-form ((self obj) &optional environment) (make-load-form-saving-slots self :slot-names '(x y) :environment environment)) @result{} # ;; Try MAKE-LOAD-FORM on object created above. (make-load-form obj1) @result{} (ALLOCATE-INSTANCE '#), (PROGN (SETF (SLOT-VALUE '# 'X) '3.0) (SETF (SLOT-VALUE '# 'Y) '4.0) (INITIALIZE-INSTANCE '#)) @end example In the following example, @i{instances} of @t{my-frob} are ``interned'' in some way. An equivalent @i{instance} is reconstructed by using the value of the name slot as a key for searching existing @i{objects}. In this case the programmer has chosen to create a new @i{object} if no existing @i{object} is found; alternatively an error could have been signaled in that case. @example (defclass my-frob () ((name :initarg :name :reader my-name))) (defmethod make-load-form ((self my-frob) &optional environment) (declare (ignore environment)) `(find-my-frob ',(my-name self) :if-does-not-exist :create)) @end example In the following example, the data structure to be dumped is circular, because each parent has a list of its children and each child has a reference back to its parent. If @b{make-load-form} is called on one @i{object} in such a structure, the creation form creates an equivalent @i{object} and fills in the children slot, which forces creation of equivalent @i{objects} for all of its children, grandchildren, etc. At this point none of the parent @i{slots} have been filled in. The initialization form fills in the parent @i{slot}, which forces creation of an equivalent @i{object} for the parent if it was not already created. Thus the entire tree is recreated at @b{load} time. At compile time, @b{make-load-form} is called once for each @i{object} in the tree. All of the creation forms are evaluated, in @i{implementation-dependent} order, and then all of the initialization forms are evaluated, also in @i{implementation-dependent} order. @example (defclass tree-with-parent () ((parent :accessor tree-parent) (children :initarg :children))) (defmethod make-load-form ((x tree-with-parent) &optional environment) (declare (ignore environment)) (values ;; creation form `(make-instance ',(class-of x) :children ',(slot-value x 'children)) ;; initialization form `(setf (tree-parent ',x) ',(slot-value x 'parent)))) @end example In the following example, the data structure to be dumped has no special properties and an equivalent structure can be reconstructed simply by reconstructing the @i{slots}' contents. @example (defstruct my-struct a b c) (defmethod make-load-form ((s my-struct) &optional environment) (make-load-form-saving-slots s :environment environment)) @end example @subsubheading Exceptional Situations:: The @i{methods} @i{specialized} on @b{standard-object}, @b{structure-object}, and @b{condition} all signal an error of @i{type} @b{error}. It is @i{implementation-dependent} whether @i{calling} @b{make-load-form} on a @i{generalized instance} of a @i{system class} signals an error or returns creation and initialization @i{forms}. @subsubheading See Also:: @ref{compile-file} , @ref{make-load-form-saving-slots} , @ref{Additional Constraints on Externalizable Objects} @ref{Evaluation}, @ref{Compilation} @subsubheading Notes:: The @i{file compiler} calls @b{make-load-form} in specific circumstances detailed in @ref{Additional Constraints on Externalizable Objects}. Some @i{implementations} may provide facilities for defining new @i{subclasses} of @i{classes} which are specified as @i{system classes}. (Some likely candidates include @b{generic-function}, @b{method}, and @b{stream}). Such @i{implementations} should document how the @i{file compiler} processes @i{instances} of such @i{classes} when encountered as @i{literal objects}, and should document any relevant @i{methods} for @b{make-load-form}. @node make-load-form-saving-slots, with-accessors, make-load-form, Objects Dictionary @subsection make-load-form-saving-slots [Function] @code{make-load-form-saving-slots} @i{object @r{&key} slot-names environment}@* @result{} @i{creation-form, initialization-form} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{slot-names}---a @i{list}. @i{environment}---an @i{environment object}. @i{creation-form}---a @i{form}. @i{initialization-form}---a @i{form}. @subsubheading Description:: Returns @i{forms} that, when @i{evaluated}, will construct an @i{object} equivalent to @i{object}, without @i{executing} @i{initialization forms}. The @i{slots} in the new @i{object} that correspond to initialized @i{slots} in @i{object} are initialized using the values from @i{object}. Uninitialized @i{slots} in @i{object} are not initialized in the new @i{object}. @b{make-load-form-saving-slots} works for any @i{instance} of @b{standard-object} or @b{structure-object}. @i{Slot-names} is a @i{list} of the names of the @i{slots} to preserve. If @i{slot-names} is not supplied, its value is all of the @i{local slots}. @b{make-load-form-saving-slots} returns two values, thus it can deal with circular structures. Whether the result is useful in an application depends on whether the @i{object}'s @i{type} and slot contents fully capture the application's idea of the @i{object}'s state. @i{Environment} is the environment in which the forms will be processed. @subsubheading See Also:: @ref{make-load-form} , @ref{make-instance} , @ref{setf} , @ref{slot-value} , @ref{slot-makunbound} @subsubheading Notes:: @b{make-load-form-saving-slots} can be useful in user-written @b{make-load-form} methods. When the @i{object} is an @i{instance} of @b{standard-object}, @b{make-load-form-saving-slots} could return a creation form that @i{calls} @b{allocate-instance} and an initialization form that contains @i{calls} to @b{setf} of @b{slot-value} and @b{slot-makunbound}, though other @i{functions} of similar effect might actually be used. @node with-accessors, with-slots, make-load-form-saving-slots, Objects Dictionary @subsection with-accessors [Macro] @code{with-accessors} @i{@r{@r{(}@{@i{slot-entry}@}*@r{)}} instance-form @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @w{@i{slot-entry} ::=@r{(}variable-name accessor-name @r{)}} @subsubheading Arguments and Values:: @i{variable-name}---a @i{variable name}; not evaluated. @i{accessor-name}---a @i{function name}; not evaluated. @i{instance-form}---a @i{form}; evaluated. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Creates a lexical environment in which the slots specified by @i{slot-entry} are lexically available through their accessors as if they were variables. The macro @b{with-accessors} invokes the appropriate accessors to @i{access} the @i{slots} specified by @i{slot-entry}. Both @b{setf} and @b{setq} can be used to set the value of the @i{slot}. @subsubheading Examples:: @example (defclass thing () ((x :initarg :x :accessor thing-x) (y :initarg :y :accessor thing-y))) @result{} # (defmethod (setf thing-x) :before (new-x (thing thing)) (format t "~&Changing X from ~D to ~D in ~S.~ (thing-x thing) new-x thing)) (setq thing1 (make-instance 'thing :x 1 :y 2)) @result{} # (setq thing2 (make-instance 'thing :x 7 :y 8)) @result{} # (with-accessors ((x1 thing-x) (y1 thing-y)) thing1 (with-accessors ((x2 thing-x) (y2 thing-y)) thing2 (list (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setq x1 (+ y1 x2)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setf (thing-x thing2) (list x1)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2))))) @t{ |> } Changing X from 1 to 9 in #. @t{ |> } Changing X from 7 to (9) in #. @result{} ((1 1 2 2 7 7 8 8) 9 (9 9 2 2 7 7 8 8) (9) (9 9 2 2 (9) (9) 8 8)) @end example @subsubheading Affected By:: @b{defclass} @subsubheading Exceptional Situations:: The consequences are undefined if any @i{accessor-name} is not the name of an accessor for the @i{instance}. @subsubheading See Also:: @ref{with-slots} , @ref{symbol-macrolet} @subsubheading Notes:: A @b{with-accessors} expression of the form: @example @w{@t{(with-accessors} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* @end example @noindent expands into the equivalent of @example @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* @w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* @end example @noindent where @r{Q}_i is @example @t{(}@r{variable-name}_i () @t{(@r{accessor-name}_i in))} @end example @node with-slots, defclass, with-accessors, Objects Dictionary @subsection with-slots [Macro] @code{with-slots} @i{@r{(}@{@i{slot-entry}@}*@r{)} instance-form @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @w{@i{slot-entry} ::=slot-name | @r{(}variable-name slot-name@r{)}} @subsubheading Arguments and Values:: @i{slot-name}---a @i{slot} @i{name}; not evaluated. @i{variable-name}---a @i{variable name}; not evaluated. @i{instance-form}---a @i{form}; evaluted to produce @i{instance}. @i{instance}---an @i{object}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: The macro @b{with-slots} @i{establishes} a @i{lexical environment} for referring to the @i{slots} in the @i{instance} named by the given @i{slot-names} as though they were @i{variables}. Within such a context the value of the @i{slot} can be specified by using its slot name, as if it were a lexically bound variable. Both @b{setf} and @b{setq} can be used to set the value of the @i{slot}. The macro @b{with-slots} translates an appearance of the slot name as a @i{variable} into a call to @b{slot-value}. @subsubheading Examples:: @example (defclass thing () ((x :initarg :x :accessor thing-x) (y :initarg :y :accessor thing-y))) @result{} # (defmethod (setf thing-x) :before (new-x (thing thing)) (format t "~&Changing X from ~D to ~D in ~S.~ (thing-x thing) new-x thing)) (setq thing (make-instance 'thing :x 0 :y 1)) @result{} # (with-slots (x y) thing (incf x) (incf y)) @result{} 2 (values (thing-x thing) (thing-y thing)) @result{} 1, 2 (setq thing1 (make-instance 'thing :x 1 :y 2)) @result{} # (setq thing2 (make-instance 'thing :x 7 :y 8)) @result{} # (with-slots ((x1 x) (y1 y)) thing1 (with-slots ((x2 x) (y2 y)) thing2 (list (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setq x1 (+ y1 x2)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setf (thing-x thing2) (list x1)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2))))) @t{ |> } Changing X from 7 to (9) in #. @result{} ((1 1 2 2 7 7 8 8) 9 (9 9 2 2 7 7 8 8) (9) (9 9 2 2 (9) (9) 8 8)) @end example @subsubheading Affected By:: @b{defclass} @subsubheading Exceptional Situations:: The consequences are undefined if any @i{slot-name} is not the name of a @i{slot} in the @i{instance}. @subsubheading See Also:: @ref{with-accessors} , @ref{slot-value} , @ref{symbol-macrolet} @subsubheading Notes:: A @b{with-slots} expression of the form: @example @w{@t{(with-slots} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* @end example @noindent expands into the equivalent of @example @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* @w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* @end example @noindent where @r{Q}_i is @example @t{(}@r{slot-entry}_i () @t{(slot-value }in '@r{slot-entry}_i@t{))} @end example @noindent if @r{slot-entry}_i is a @i{symbol} and is @example @t{(}@r{variable-name}_i () @t{(slot-value }in '@r{slot-name}_i@t{))} @end example @noindent if @r{slot-entry}_i is of the form @example @t{(}@r{variable-name}_i @r{slot-name}_i@t{)} @end example @node defclass, defgeneric, with-slots, Objects Dictionary @subsection defclass [Macro] @code{defclass} @i{@i{class-name} @r{(}@{@i{superclass-name}@}*@r{)} @r{(}@{@i{slot-specifier}@}*@r{)} [[!@i{class-option}]]}@* @result{} @i{new-class} @w{ slot-specifier::=@i{slot-name} | (@i{slot-name} [[!@i{slot-option}]])}@* @w{ @i{slot-name}::= @i{symbol}}@* @w{ slot-option::=@{@t{:reader} @i{reader-function-name}@}* |}@* @w{ @{@t{:writer} @i{writer-function-name}@}* |}@* @w{ @{@t{:accessor} @i{reader-function-name}@}* |}@* @w{ @{@t{:allocation} @i{allocation-type}@} |}@* @w{ @{@t{:initarg} @i{initarg-name}@}* |}@* @w{ @{@t{:initform} @i{form}@} |}@* @w{ @{@t{:type} @i{type-specifier}@} |}@* @w{ @{@t{:documentation} @i{string}@}}@* @w{ @i{function-name}::= @{@i{symbol} | @t{(setf @i{symbol})}@}}@* @w{ class-option::=(@t{:default-initargs} @t{.} @i{initarg-list}) |}@* @w{ (@t{:documentation} @i{string}) |}@* @w{ (@t{:metaclass} @i{class-name})}@* @subsubheading Arguments and Values:: @i{Class-name}---a @i{non-nil} @i{symbol}. @i{Superclass-name}--a @i{non-nil} @i{symbol}. @i{Slot-name}--a @i{symbol}. The @i{slot-name} argument is a @i{symbol} that is syntactically valid for use as a variable name. @i{Reader-function-name}---a @i{non-nil} @i{symbol}. @t{:reader} can be supplied more than once for a given @i{slot}. @i{Writer-function-name}---a @i{generic function} name. @t{:writer} can be supplied more than once for a given @i{slot}. @i{Reader-function-name}---a @i{non-nil} @i{symbol}. @t{:accessor} can be supplied more than once for a given @i{slot}. @i{Allocation-type}---(member @t{:instance} @t{:class}). @t{:allocation} can be supplied once at most for a given @i{slot}. @i{Initarg-name}---a @i{symbol}. @t{:initarg} can be supplied more than once for a given @i{slot}. @i{Form}---a @i{form}. @t{:init-form} can be supplied once at most for a given @i{slot}. @i{Type-specifier}---a @i{type specifier}. @t{:type} can be supplied once at most for a given @i{slot}. @i{Class-option}--- refers to the @i{class} as a whole or to all class @i{slots}. @i{Initarg-list}---a @i{list} of alternating initialization argument @i{names} and default initial value @i{forms}. @t{:default-initargs} can be supplied at most once. @i{Class-name}---a @i{non-nil} @i{symbol}. @t{:metaclass} can be supplied once at most. @i{new-class}---the new @i{class} @i{object}. @subsubheading Description:: The macro @b{defclass} defines a new named @i{class}. It returns the new @i{class} @i{object} as its result. The syntax of @b{defclass} provides options for specifying initialization arguments for @i{slots}, for specifying default initialization values for @i{slots}, and for requesting that @i{methods} on specified @i{generic functions} be automatically generated for reading and writing the values of @i{slots}. No reader or writer functions are defined by default; their generation must be explicitly requested. However, @i{slots} can always be @i{accessed} using @b{slot-value}. Defining a new @i{class} also causes a @i{type} of the same name to be defined. The predicate @t{(typep @i{object} @i{class-name})} returns true if the @i{class} of the given @i{object} is the @i{class} named by @i{class-name} itself or a subclass of the class @i{class-name}. A @i{class} @i{object} can be used as a @i{type specifier}. Thus @t{(typep @i{object} @i{class})} returns @i{true} if the @i{class} of the @i{object} is @i{class} itself or a subclass of @i{class}. The @i{class-name} argument specifies the @i{proper name} of the new @i{class}. If a @i{class} with the same @i{proper name} already exists and that @i{class} is an @i{instance} of @b{standard-class}, and if the @b{defclass} form for the definition of the new @i{class} specifies a @i{class} of @i{class} @b{standard-class}, the existing @i{class} is redefined, and instances of it (and its @i{subclasses}) are updated to the new definition at the time that they are next @i{accessed}. For details, see @ref{Redefining Classes}. Each @i{superclass-name} argument specifies a direct @i{superclass} of the new @i{class}. If the @i{superclass} list is empty, then the @i{superclass} defaults depending on the @i{metaclass}, with @b{standard-object} being the default for @b{standard-class}. The new @i{class} will inherit @i{slots} and @i{methods} from each of its direct @i{superclasses}, from their direct @i{superclasses}, and so on. For a discussion of how @i{slots} and @i{methods} are inherited, see @ref{Inheritance}. The following slot options are available: @table @asis @item @t{*} The @t{:reader} slot option specifies that an @i{unqualified method} is to be defined on the @i{generic function} named @i{reader-function-name} to read the value of the given @i{slot}. @item @t{*} The @t{:writer} slot option specifies that an @i{unqualified method} is to be defined on the @i{generic function} named @i{writer-function-name} to write the value of the @i{slot}. @item @t{*} The @t{:accessor} slot option specifies that an @i{unqualified method} is to be defined on the generic function named @i{reader-function-name} to read the value of the given @i{slot} and that an @i{unqualified method} is to be defined on the @i{generic function} named @t{(setf @i{reader-function-name})} to be used with @b{setf} to modify the value of the @i{slot}. @item @t{*} The @t{:allocation} slot option is used to specify where storage is to be allocated for the given @i{slot}. Storage for a @i{slot} can be located in each instance or in the @i{class} @i{object} itself. The value of the @i{allocation-type} argument can be either the keyword @t{:instance} or the keyword @t{:class}. If the @t{:allocation} slot option is not specified, the effect is the same as specifying @t{:allocation :instance}. @table @asis @item -- If @i{allocation-type} is @t{:instance}, a @i{local slot} of the name @i{slot-name} is allocated in each instance of the @i{class}. @item -- If @i{allocation-type} is @t{:class}, a shared @i{slot} of the given name is allocated in the @i{class} @i{object} created by this @b{defclass} form. The value of the @i{slot} is shared by all @i{instances} of the @i{class}. If a class C_1 defines such a @i{shared slot}, any subclass C_2 of C_1 will share this single @i{slot} unless the @b{defclass} form for C_2 specifies a @i{slot} of the same @i{name} or there is a superclass of C_2 that precedes C_1 in the class precedence list of C_2 and that defines a @i{slot} of the same @i{name}. @end table @item @t{*} The @t{:initform} slot option is used to provide a default initial value form to be used in the initialization of the @i{slot}. This @i{form} is evaluated every time it is used to initialize the @i{slot}. The lexical environment in which this @i{form} is evaluated is the lexical environment in which the @b{defclass} form was evaluated. Note that the lexical environment refers both to variables and to functions. For @i{local slots}, the dynamic environment is the dynamic environment in which @b{make-instance} is called; for shared @i{slots}, the dynamic environment is the dynamic environment in which the @b{defclass} form was evaluated. See @ref{Object Creation and Initialization}. No implementation is permitted to extend the syntax of @b{defclass} to allow @t{(@i{slot-name} @i{form})} as an abbreviation for @t{(@i{slot-name} :initform @i{form})}. [Reviewer Note by Barmar: Can you extend this to mean something else?] @item @t{*} The @t{:initarg} slot option declares an initialization argument named @i{initarg-name} and specifies that this initialization argument initializes the given @i{slot}. If the initialization argument has a value in the call to @b{initialize-instance}, the value will be stored into the given @i{slot}, and the slot's @t{:initform} slot option, if any, is not evaluated. If none of the initialization arguments specified for a given @i{slot} has a value, the @i{slot} is initialized according to the @t{:initform} slot option, if specified. @item @t{*} The @t{:type} slot option specifies that the contents of the @i{slot} will always be of the specified data type. It effectively declares the result type of the reader generic function when applied to an @i{object} of this @i{class}. The consequences of attempting to store in a @i{slot} a value that does not satisfy the type of the @i{slot} are undefined. The @t{:type} slot option is further discussed in @ref{Inheritance of Slots and Slot Options}. @item @t{*} The @t{:documentation} slot option provides a @i{documentation string} for the @i{slot}. @t{:documentation} can be supplied once at most for a given @i{slot}. [Reviewer Note by Barmar: How is this retrieved?] @end table Each class option is an option that refers to the @i{class} as a whole. The following class options are available: @table @asis @item @t{*} The @t{:default-initargs} class option is followed by a list of alternating initialization argument @i{names} and default initial value forms. If any of these initialization arguments does not appear in the initialization argument list supplied to @b{make-instance}, the corresponding default initial value form is evaluated, and the initialization argument @i{name} and the @i{form}'s value are added to the end of the initialization argument list before the instance is created; see @ref{Object Creation and Initialization}. The default initial value form is evaluated each time it is used. The lexical environment in which this @i{form} is evaluated is the lexical environment in which the @b{defclass} form was evaluated. The dynamic environment is the dynamic environment in which @b{make-instance} was called. If an initialization argument @i{name} appears more than once in a @t{:default-initargs} class option, an error is signaled. @item @t{*} The @t{:documentation} class option causes a @i{documentation string} to be attached with the @i{class} @i{object}, and attached with kind @b{type} to the @i{class-name}. @t{:documentation} can be supplied once at most. @item @t{*} The @t{:metaclass} class option is used to specify that instances of the @i{class} being defined are to have a different metaclass than the default provided by the system (the @i{class} @b{standard-class}). @end table Note the following rules of @b{defclass} for @i{standard classes}: @table @asis @item @t{*} It is not required that the @i{superclasses} of a @i{class} be defined before the @b{defclass} form for that @i{class} is evaluated. @item @t{*} All the @i{superclasses} of a @i{class} must be defined before an @i{instance} of the @i{class} can be made. @item @t{*} A @i{class} must be defined before it can be used as a parameter specializer in a @b{defmethod} form. @end table The object system can be extended to cover situations where these rules are not obeyed. Some slot options are inherited by a @i{class} from its @i{superclasses}, and some can be shadowed or altered by providing a local slot description. No class options except @t{:default-initargs} are inherited. For a detailed description of how @i{slots} and slot options are inherited, see @ref{Inheritance of Slots and Slot Options}. The options to @b{defclass} can be extended. It is required that all implementations signal an error if they observe a class option or a slot option that is not implemented locally. It is valid to specify more than one reader, writer, accessor, or initialization argument for a @i{slot}. No other slot option can appear more than once in a single slot description, or an error is signaled. If no reader, writer, or accessor is specified for a @i{slot}, the @i{slot} can only be @i{accessed} by the @i{function} @b{slot-value}. If a @b{defclass} @i{form} appears as a @i{top level form}, the @i{compiler} must make the @i{class} @i{name} be recognized as a valid @i{type} @i{name} in subsequent declarations (as for @b{deftype}) and be recognized as a valid @i{class} @i{name} for @b{defmethod} @i{parameter specializers} and for use as the @t{:metaclass} option of a subsequent @b{defclass}. The @i{compiler} must make the @i{class} definition available to be returned by @b{find-class} when its @i{environment} @i{argument} is a value received as the @i{environment parameter} of a @i{macro}. @subsubheading Exceptional Situations:: If there are any duplicate slot names, an error of @i{type} @b{program-error} is signaled. If an initialization argument @i{name} appears more than once in @t{:default-initargs} class option, an error of @i{type} @b{program-error} is signaled. If any of the following slot options appears more than once in a single slot description, an error of @i{type} @b{program-error} is signaled: @t{:allocation}, @t{:initform}, @t{:type}, @t{:documentation}. It is required that all implementations signal an error of @i{type} @b{program-error} if they observe a class option or a slot option that is not implemented locally. @subsubheading See Also:: @ref{documentation} , @ref{Initialize-Instance} , @ref{make-instance} , @ref{slot-value} , @ref{Classes}, @ref{Inheritance}, @ref{Redefining Classes}, @ref{Determining the Class Precedence List}, @ref{Object Creation and Initialization} @node defgeneric, defmethod, defclass, Objects Dictionary @subsection defgeneric [Macro] @code{defgeneric} @i{function-name gf-lambda-list [[!@i{option} | @{!@i{method-description}@}*]]}@* @result{} @i{new-generic} @w{@i{option} ::=@r{(}@t{:argument-precedence-order} @{@i{parameter-name}@}^+@r{)} |} @w{ @r{(}@b{declare} @{@i{gf-declaration}@}^+@r{)} |} @w{ @r{(}@t{:documentation} @i{gf-documentation}@r{)} |} @w{ @r{(}@t{:method-combination} @i{method-combination} @{@i{method-combination-argument}@}*@r{)} |} @w{ @r{(}@t{:generic-function-class} @i{generic-function-class}@r{)} |} @w{ @r{(}@t{:method-class} @i{method-class}@r{)}} @w{@i{method-description} ::=@r{(}@t{:method} @{@i{method-qualifier}@}* @i{specialized-lambda-list} @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. @i{generic-function-class}---a @i{non-nil} @i{symbol} naming a @i{class}. @i{gf-declaration}---an @b{optimize} @i{declaration specifier}; other @i{declaration specifiers} are not permitted. @i{gf-documentation}---a @i{string}; not evaluated. @i{gf-lambda-list}---a @i{generic function lambda list}. @i{method-class}---a @i{non-nil} @i{symbol} naming a @i{class}. @i{method-combination-argument}---an @i{object.} @i{method-combination-name}---a @i{symbol} naming a @i{method combination} @i{type}. @i{method-qualifiers}, @i{specialized-lambda-list}, @i{declarations}, @i{documentation}, @i{forms}---as per @b{defmethod}. @i{new-generic}---the @i{generic function} @i{object}. @i{parameter-name}---a @i{symbol} that names a @i{required parameter} in the @i{lambda-list}. (If the @t{:argument-precedence-order} option is specified, each @i{required parameter} in the @i{lambda-list} must be used exactly once as a @i{parameter-name}.) @subsubheading Description:: The macro @b{defgeneric} is used to define a @i{generic function} or to specify options and declarations that pertain to a @i{generic function} as a whole. If @i{function-name} is a @i{list} it must be of the form @t{(setf @i{symbol})}. If @t{(fboundp @i{function-name})} is @i{false}, a new @i{generic function} is created. If @t{(fdefinition @i{function-name})} is a @i{generic function}, that @i{generic function} is modified. If @i{function-name} names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error is signaled. The effect of the @b{defgeneric} macro is as if the following three steps were performed: first, @i{methods} defined by previous @b{defgeneric} @i{forms} are removed; [Reviewer Note by Barmar: Shouldn't this (second) be first?] second, @b{ensure-generic-function} is called; and finally, @i{methods} specified by the current @b{defgeneric} @i{form} are added to the @i{generic function}. Each @i{method-description} defines a @i{method} on the @i{generic function}. The @i{lambda list} of each @i{method} must be congruent with the @i{lambda list} specified by the @i{gf-lambda-list} option. If no @i{method} descriptions are specified and a @i{generic function} of the same name does not already exist, a @i{generic function} with no @i{methods} is created. The @i{gf-lambda-list} argument of @b{defgeneric} specifies the shape of @i{lambda lists} for the @i{methods} on this @i{generic function}. All @i{methods} on the resulting @i{generic function} must have @i{lambda lists} that are congruent with this shape. If a @b{defgeneric} form is evaluated and some @i{methods} for that @i{generic function} have @i{lambda lists} that are not congruent with that given in the @b{defgeneric} form, an error is signaled. For further details on method congruence, see @ref{Congruent Lambda-lists for all Methods of a Generic Function}. The @i{generic function} passes to the @i{method} all the argument values passed to it, and only those; default values are not supported. Note that optional and keyword arguments in method definitions, however, can have default initial value forms and can use supplied-p parameters. The following options are provided. Except as otherwise noted, a given option may occur only once. @table @asis @item @t{*} The @t{:argument-precedence-order} option is used to specify the order in which the required arguments in a call to the @i{generic function} are tested for specificity when selecting a particular @i{method}. Each required argument, as specified in the @i{gf-lambda-list} argument, must be included exactly once as a @i{parameter-name} so that the full and unambiguous precedence order is supplied. If this condition is not met, an error is signaled. [Reviewer Note by Barmar: What is the default order?] @item @t{*} The @b{declare} option is used to specify declarations that pertain to the @i{generic function}. An @b{optimize} @i{declaration specifier} is allowed. It specifies whether method selection should be optimized for speed or space, but it has no effect on @i{methods}. To control how a @i{method} is optimized, an @b{optimize} declaration must be placed directly in the @b{defmethod} @i{form} or method description. The optimization qualities @b{speed} and @b{space} are the only qualities this standard requires, but an implementation can extend the object system to recognize other qualities. A simple implementation that has only one method selection technique and ignores @b{optimize} @i{declaration specifiers} is valid. The @b{special}, @b{ftype}, @b{function}, @b{inline}, @b{notinline}, and @b{declaration} declarations are not permitted. Individual implementations can extend the @b{declare} option to support additional declarations. [Editorial Note by KMP: Does ``additional'' mean including special, ftype, etc.? Or only other things that are not mentioned here?] If an implementation notices a @i{declaration specifier} that it does not support and that has not been proclaimed as a non-standard @i{declaration identifier} name in a @b{declaration} @i{proclamation}, it should issue a warning. [Editorial Note by KMP: The wording of this previous sentence, particularly the word ``and'' suggests to me that you can `proclaim declaration' of an unsupported declaration (e.g., ftype) in order to suppress the warning. That seems wrong. Perhaps it instead means to say ``does not support or is both undefined and not proclaimed declaration.''] The @b{declare} option may be specified more than once. The effect is the same as if the lists of @i{declaration specifiers} had been appended together into a single list and specified as a single @b{declare} option. @item @t{*} The @t{:documentation} argument is a @i{documentation string} to be attached to the @i{generic function} @i{object}, and to be attached with kind @b{function} to the @i{function-name}. @item @t{*} The @t{:generic-function-class} option may be used to specify that the @i{generic function} is to have a different @i{class} than the default provided by the system (the @i{class} @b{standard-generic-function}). The @i{class-name} argument is the name of a @i{class} that can be the @i{class} of a @i{generic function}. If @i{function-name} specifies an existing @i{generic function} that has a different value for the @t{:generic-function-class} argument and the new generic function @i{class} is compatible with the old, @b{change-class} is called to change the @i{class} of the @i{generic function}; otherwise an error is signaled. @item @t{*} The @t{:method-class} option is used to specify that all @i{methods} on this @i{generic function} are to have a different @i{class} from the default provided by the system (the @i{class} @b{standard-method}). The @i{class-name} argument is the name of a @i{class} that is capable of being the @i{class} of a @i{method}. [Reviewer Note by Barmar: Is @b{change-class} called on existing methods?] @item @t{*} The @t{:method-combination} option is followed by a symbol that names a type of method combination. The arguments (if any) that follow that symbol depend on the type of method combination. Note that the standard method combination type does not support any arguments. However, all types of method combination defined by the short form of @b{define-method-combination} accept an optional argument named @i{order}, defaulting to @t{:most-specific-first}, where a value of @t{:most-specific-last} reverses the order of the primary @i{methods} without affecting the order of the auxiliary @i{methods}. @end table The @i{method-description} arguments define @i{methods} that will be associated with the @i{generic function}. The @i{method-qualifier} and @i{specialized-lambda-list} arguments in a method description are the same as for @b{defmethod}. The @i{form} arguments specify the method body. The body of the @i{method} is enclosed in an @i{implicit block}. If @i{function-name} is a @i{symbol}, this block bears the same name as the @i{generic function}. If @i{function-name} is a @i{list} of the form @t{(setf @i{symbol})}, the name of the block is @i{symbol}. Implementations can extend @b{defgeneric} to include other options. It is required that an implementation signal an error if it observes an option that is not implemented locally. @b{defgeneric} is not required to perform any compile-time side effects. In particular, the @i{methods} are not installed for invocation during compilation. An @i{implementation} may choose to store information about the @i{generic function} for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen). @subsubheading Examples:: @subsubheading Exceptional Situations:: If @i{function-name} names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error of @i{type} @b{program-error} is signaled. Each required argument, as specified in the @i{gf-lambda-list} argument, must be included exactly once as a @i{parameter-name}, or an error of @i{type} @b{program-error} is signaled. The @i{lambda list} of each @i{method} specified by a @i{method-description} must be congruent with the @i{lambda list} specified by the @i{gf-lambda-list} option, or an error of @i{type} @b{error} is signaled. If a @b{defgeneric} form is evaluated and some @i{methods} for that @i{generic function} have @i{lambda lists} that are not congruent with that given in the @b{defgeneric} form, an error of @i{type} @b{error} is signaled. A given @i{option} may occur only once, or an error of @i{type} @b{program-error} is signaled. [Reviewer Note by Barmar: This says that an error is signaled if you specify the same generic function class as it already has!] If @i{function-name} specifies an existing @i{generic function} that has a different value for the @t{:generic-function-class} argument and the new generic function @i{class} is compatible with the old, @b{change-class} is called to change the @i{class} of the @i{generic function}; otherwise an error of @i{type} @b{error} is signaled. Implementations can extend @b{defgeneric} to include other options. It is required that an implementation signal an error of @i{type} @b{program-error} if it observes an option that is not implemented locally. @subsubheading See Also:: @ref{defmethod} , @ref{documentation} , @ref{ensure-generic-function} , @b{generic-function}, @ref{Congruent Lambda-lists for all Methods of a Generic Function} @node defmethod, find-class, defgeneric, Objects Dictionary @subsection defmethod [Macro] @code{defmethod} @i{@i{function-name} @{@i{method-qualifier}@}* @i{specialized-lambda-list} @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{new-method} @i{function-name}::= @{@i{symbol} | @t{(setf @i{symbol})}@} @i{method-qualifier}::= @i{non-list} @w{ @i{specialized-lambda-list}::= (@{@i{var} | @r{(}@r{@i{var} @i{parameter-specializer-name}}@r{)}@}*}@* @w{ @t{[}@r{&optional} @{@i{var} | @r{(}var @t{[}@i{initform} @r{@r{[}@i{supplied-p-parameter}@r{]}} @t{]}@r{)}@}*@t{]}}@* @w{ @t{[}@t{&rest} @i{var}@t{]}}@* @w{ @t{[}@r{@r{&key}}@{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword}@i{var}@r{)}@} @t{[}@i{initform} @r{[}@i{supplied-p-parameter}@r{]} @t{]}@r{)}@}*}@* @w{ @r{[}@b{&allow-other-keys}@r{]} @t{]}}@* @w{ @t{[}@t{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{initform}@r{]} @r{)}@}*@t{]} @r{)}}@* @w{ @i{parameter-specializer-name}::= @i{symbol} | @r{(}@t{eql} @i{eql-specializer-form}@r{)}}@* @subsubheading Arguments and Values:: @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{var}---a @i{variable} @i{name}. @i{eql-specializer-form}---a @i{form}. @i{Form}---a @i{form}. @i{Initform}---a @i{form}. @i{Supplied-p-parameter}---variable name. @i{new-method}---the new @i{method} @i{object}. @subsubheading Description:: The macro @b{defmethod} defines a @i{method} on a @i{generic function}. If @t{(fboundp @i{function-name})} is @b{nil}, a @i{generic function} is created with default values for the argument precedence order (each argument is more specific than the arguments to its right in the argument list), for the generic function class (the @i{class} @b{standard-generic-function}), for the method class (the @i{class} @b{standard-method}), and for the method combination type (the standard method combination type). The @i{lambda list} of the @i{generic function} is congruent with the @i{lambda list} of the @i{method} being defined; if the @b{defmethod} form mentions keyword arguments, the @i{lambda list} of the @i{generic function} will mention @t{&key} (but no keyword arguments). If @i{function-name} names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error is signaled. If a @i{generic function} is currently named by @i{function-name}, the @i{lambda list} of the @i{method} must be congruent with the @i{lambda list} of the @i{generic function}. If this condition does not hold, an error is signaled. For a definition of congruence in this context, see @ref{Congruent Lambda-lists for all Methods of a Generic Function}. Each @i{method-qualifier} argument is an @i{object} that is used by method combination to identify the given @i{method}. The method combination type might further restrict what a method @i{qualifier} can be. The standard method combination type allows for @i{unqualified methods} and @i{methods} whose sole @i{qualifier} is one of the keywords @t{:before}, @t{:after}, or @t{:around}. The @i{specialized-lambda-list} argument is like an ordinary @i{lambda list} except that the @i{names} of required parameters can be replaced by specialized parameters. A specialized parameter is a list of the form @t{(@i{var} @i{parameter-specializer-name})}. Only required parameters can be specialized. If @i{parameter-specializer-name} is a @i{symbol} it names a @i{class}; if it is a @i{list}, it is of the form @t{(eql @i{eql-specializer-form})}. The parameter specializer name @t{(eql @i{eql-specializer-form})} indicates that the corresponding argument must be @b{eql} to the @i{object} that is the value of @i{eql-specializer-form} for the @i{method} to be applicable. The @i{eql-specializer-form} is evaluated at the time that the expansion of the @b{defmethod} macro is evaluated. If no @i{parameter specializer name} is specified for a given required parameter, the @i{parameter specializer} defaults to the @i{class} @b{t}. For further discussion, see @ref{Introduction to Methods}. The @i{form} arguments specify the method body. The body of the @i{method} is enclosed in an @i{implicit block}. If @i{function-name} is a @i{symbol}, this block bears the same @i{name} as the @i{generic function}. If @i{function-name} is a @i{list} of the form @t{(setf @i{symbol})}, the @i{name} of the block is @i{symbol}. The @i{class} of the @i{method} @i{object} that is created is that given by the method class option of the @i{generic function} on which the @i{method} is defined. If the @i{generic function} already has a @i{method} that agrees with the @i{method} being defined on @i{parameter specializers} and @i{qualifiers}, @b{defmethod} replaces the existing @i{method} with the one now being defined. For a definition of agreement in this context. see @ref{Agreement on Parameter Specializers and Qualifiers}. The @i{parameter specializers} are derived from the @i{parameter specializer names} as described in @ref{Introduction to Methods}. The expansion of the @b{defmethod} macro ``refers to'' each specialized parameter (see the description of @b{ignore} within the description of @b{declare}). This includes parameters that have an explicit @i{parameter specializer name} of @b{t}. This means that a compiler warning does not occur if the body of the @i{method} does not refer to a specialized parameter, while a warning might occur if the body of the @i{method} does not refer to an unspecialized parameter. For this reason, a parameter that specializes on @b{t} is not quite synonymous with an unspecialized parameter in this context. Declarations at the head of the method body that apply to the method's @i{lambda variables} are treated as @i{bound declarations} whose @i{scope} is the same as the corresponding @i{bindings}. Declarations at the head of the method body that apply to the functional bindings of @b{call-next-method} or @b{next-method-p} apply to references to those functions within the method body @i{forms}. Any outer @i{bindings} of the @i{function names} @b{call-next-method} and @b{next-method-p}, and declarations associated with such @i{bindings} are @i{shadowed}_2 within the method body @i{forms}. The @i{scope} of @i{free declarations} at the head of the method body is the entire method body, which includes any implicit local function definitions but excludes @i{initialization forms} for the @i{lambda variables}. @b{defmethod} is not required to perform any compile-time side effects. In particular, the @i{methods} are not installed for invocation during compilation. An @i{implementation} may choose to store information about the @i{generic function} for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen). @i{Documentation} is attached as a @i{documentation string} to the @i{method} @i{object}. @subsubheading Affected By:: The definition of the referenced @i{generic function}. @subsubheading Exceptional Situations:: If @i{function-name} names an @i{ordinary function}, a @i{macro}, or a @i{special operator}, an error of @i{type} @b{error} is signaled. If a @i{generic function} is currently named by @i{function-name}, the @i{lambda list} of the @i{method} must be congruent with the @i{lambda list} of the @i{generic function}, or an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{defgeneric} , @ref{documentation} , @ref{Introduction to Methods}, @ref{Congruent Lambda-lists for all Methods of a Generic Function}, @ref{Agreement on Parameter Specializers and Qualifiers}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @node find-class, next-method-p, defmethod, Objects Dictionary @subsection find-class [Accessor] @code{find-class} @i{symbol @r{&optional} errorp environment} @result{} @i{class} (setf (@code{ find-class} @i{symbol @r{&optional} errorp environment}) new-class)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{errorp}---a @i{generalized boolean}. The default is @i{true}. @i{environment} -- same as the @b{&environment} argument to macro expansion functions and is used to distinguish between compile-time and run-time environments. The @b{&environment} argument has @i{dynamic extent}; the consequences are undefined if the @b{&environment} argument is referred to outside the @i{dynamic extent} of the macro expansion function. @i{class}---a @i{class} @i{object}, or @b{nil}. @subsubheading Description:: Returns the @i{class} @i{object} named by the @i{symbol} in the @i{environment}. If there is no such @i{class}, @b{nil} is returned if @i{errorp} is @i{false}; otherwise, if @i{errorp} is @i{true}, an error is signaled. The @i{class} associated with a particular @i{symbol} can be changed by using @b{setf} with @b{find-class}; or, if the new @i{class} given to @b{setf} is @b{nil}, the @i{class} association is removed (but the @i{class} @i{object} itself is not affected). The results are undefined if the user attempts to change or remove the @i{class} associated with a @i{symbol} that is defined as a @i{type specifier} in this standard. See @ref{Integrating Types and Classes}. When using @b{setf} of @b{find-class}, any @i{errorp} argument is @i{evaluated} for effect, but any @i{values} it returns are ignored; the @i{errorp} @i{parameter} is permitted primarily so that the @i{environment} @i{parameter} can be used. The @i{environment} might be used to distinguish between a compile-time and a run-time environment. @subsubheading Exceptional Situations:: If there is no such @i{class} and @i{errorp} is @i{true}, @b{find-class} signals an error of @i{type} @b{error}. @subsubheading See Also:: @ref{defmacro} , @ref{Integrating Types and Classes} @node next-method-p, call-method, find-class, Objects Dictionary @subsection next-method-p [Local Function] @subsubheading Syntax:: @code{next-method-p} @i{<@i{no @i{arguments}}>} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: The locally defined function @b{next-method-p} can be used within the body @i{forms} (but not the @i{lambda list}) defined by a @i{method-defining form} to determine whether a next @i{method} exists. The @i{function} @b{next-method-p} has @i{lexical scope} and @i{indefinite extent}. Whether or not @b{next-method-p} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{next-method-p} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{next-method-p} outside of a @i{method-defining form} are undefined. @subsubheading See Also:: @ref{call-next-method} , @ref{defmethod} , @ref{call-method} @node call-method, call-next-method, next-method-p, Objects Dictionary @subsection call-method, make-method [Local Macro] @subsubheading Syntax:: @code{call-method} @i{method @r{&optional} next-method-list} @result{} @i{@{@i{result}@}*} @code{make-method} @i{form} @result{} @i{method-object} @subsubheading Arguments and Values:: @i{method}---a @i{method} @i{object}, or a @i{list} (see below); not evaluated. @i{method-object}---a @i{method} @i{object}. @i{next-method-list}---a @i{list} of @i{method} @i{objects}; not evaluated. @i{results}---the @i{values} returned by the @i{method} invocation. @subsubheading Description:: The macro @b{call-method} is used in method combination. It hides the @i{implementation-dependent} details of how @i{methods} are called. The macro @b{call-method} has @i{lexical scope} and can only be used within an @i{effective method} @i{form}. [Editorial Note by KMP: This next paragraph still needs some work.] Whether or not @b{call-method} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{call-method} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{call-method} outside of an @i{effective method} @i{form} are undefined. The macro @b{call-method} invokes the specified @i{method}, supplying it with arguments and with definitions for @b{call-next-method} and for @b{next-method-p}. If the invocation of @b{call-method} is lexically inside of a @b{make-method}, the arguments are those that were supplied to that method. Otherwise the arguments are those that were supplied to the generic function. The definitions of @b{call-next-method} and @b{next-method-p} rely on the specified @i{next-method-list}. If @i{method} is a @i{list}, the first element of the @i{list} must be the symbol @b{make-method} and the second element must be a @i{form}. Such a @i{list} specifies a @i{method} @i{object} whose @i{method} function has a body that is the given @i{form}. @i{Next-method-list} can contain @i{method} @i{objects} or @i{lists}, the first element of which must be the symbol @b{make-method} and the second element of which must be a @i{form}. Those are the only two places where @b{make-method} can be used. The @i{form} used with @b{make-method} is evaluated in the @i{null lexical environment} augmented with a local macro definition for @b{call-method} and with bindings named by symbols not @i{accessible} from the @t{COMMON-LISP-USER} @i{package}. The @b{call-next-method} function available to @i{method} will call the first @i{method} in @i{next-method-list}. The @b{call-next-method} function available in that @i{method}, in turn, will call the second @i{method} in @i{next-method-list}, and so on, until the list of next @i{methods} is exhausted. If @i{next-method-list} is not supplied, the @b{call-next-method} function available to @i{method} signals an error of @i{type} @b{control-error} and the @b{next-method-p} function available to @i{method} returns @b{nil}. @subsubheading Examples:: @subsubheading See Also:: @ref{call-next-method} , @ref{define-method-combination} , @ref{next-method-p} @node call-next-method, compute-applicable-methods, call-method, Objects Dictionary @subsection call-next-method [Local Function] @subsubheading Syntax:: @code{call-next-method} @i{@r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{arg}---an @i{object}. @i{results}---the @i{values} returned by the @i{method} it calls. @subsubheading Description:: The @i{function} @b{call-next-method} can be used within the body @i{forms} (but not the @i{lambda list}) of a @i{method} defined by a @i{method-defining form} to call the @i{next method}. If there is no next @i{method}, the generic function @b{no-next-method} is called. The type of method combination used determines which @i{methods} can invoke @b{call-next-method}. The standard @i{method combination} type allows @b{call-next-method} to be used within primary @i{methods} and @i{around methods}. For generic functions using a type of method combination defined by the short form of @b{define-method-combination}, @b{call-next-method} can be used in @i{around methods} only. When @b{call-next-method} is called with no arguments, it passes the current @i{method}'s original arguments to the next @i{method}. Neither argument defaulting, nor using @b{setq}, nor rebinding variables with the same @i{names} as parameters of the @i{method} affects the values @b{call-next-method} passes to the @i{method} it calls. When @b{call-next-method} is called with arguments, the @i{next method} is called with those arguments. If @b{call-next-method} is called with arguments but omits optional arguments, the @i{next method} called defaults those arguments. The @i{function} @b{call-next-method} returns any @i{values} that are returned by the @i{next method}. The @i{function} @b{call-next-method} has @i{lexical scope} and @i{indefinite extent} and can only be used within the body of a @i{method} defined by a @i{method-defining form}. Whether or not @b{call-next-method} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{call-next-method} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{call-next-method} outside of a @i{method-defining form} are undefined. @subsubheading Affected By:: @b{defmethod}, @b{call-method}, @b{define-method-combination}. @subsubheading Exceptional Situations:: When providing arguments to @b{call-next-method}, the following rule must be satisfied or an error of @i{type} @b{error} should be signaled: the ordered set of @i{applicable methods} for a changed set of arguments for @b{call-next-method} must be the same as the ordered set of @i{applicable methods} for the original arguments to the @i{generic function}. Optimizations of the error checking are possible, but they must not change the semantics of @b{call-next-method}. @subsubheading See Also:: @ref{define-method-combination} , @ref{defmethod} , @ref{next-method-p} , @ref{no-next-method} , @ref{call-method} , @ref{Method Selection and Combination}, @ref{Standard Method Combination}, @ref{Built-in Method Combination Types} @node compute-applicable-methods, define-method-combination, call-next-method, Objects Dictionary @subsection compute-applicable-methods [Standard Generic Function] @subsubheading Syntax:: @code{compute-applicable-methods} @i{generic-function function-arguments} @result{} @i{methods} @subsubheading Method Signatures:: @code{compute-applicable-methods} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)}} @subsubheading Arguments and Values:: @i{generic-function}---a @i{generic function}. @i{function-arguments}---a @i{list} of arguments for the @i{generic-function}. @i{methods}---a @i{list} of @i{method} @i{objects}. @subsubheading Description:: Given a @i{generic-function} and a set of @i{function-arguments}, the function @b{compute-applicable-methods} returns the set of @i{methods} that are applicable for those arguments sorted according to precedence order. See @ref{Method Selection and Combination}. @subsubheading Affected By:: @b{defmethod} @subsubheading See Also:: @ref{Method Selection and Combination} @node define-method-combination, find-method, compute-applicable-methods, Objects Dictionary @subsection define-method-combination [Macro] @code{define-method-combination} @i{name [[!@i{short-form-option}]]}@* @result{} @i{name} @code{define-method-combination} @i{name lambda-list @r{(}@{@i{method-group-specifier}@}*@r{)} @r{[}@r{(}@t{:arguments} . args-lambda-list@r{)}@r{]} @r{[}@r{(}@t{:generic-function} generic-function-symbol@r{)}@r{]} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* @result{} @i{name} @w{@i{short-form-option} ::=@t{:documentation} @i{documentation} | } @w{ @t{:identity-with-one-argument} @i{identity-with-one-argument} |} @w{ @t{:operator} @i{operator}} @w{@i{method-group-specifier} ::=@r{(}name @{@{@i{qualifier-pattern}@}^+ | predicate@} [[!@i{long-form-option}]]@r{)}} @w{@i{long-form-option} ::=@t{:description} @i{description} |} @w{ @t{:order} @i{order} |} @w{ @t{:required} @i{required-p}} @subsubheading Arguments and Values:: @i{args-lambda-list}--- a @i{define-method-combination arguments lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{description}---a @i{format control}. @i{documentation}---a @i{string}; not evaluated. @i{forms}---an @i{implicit progn} that must compute and return the @i{form} that specifies how the @i{methods} are combined, that is, the @i{effective method}. @i{generic-function-symbol}---a @i{symbol}. @i{identity-with-one-argument}---a @i{generalized boolean}. @i{lambda-list}---@i{ordinary lambda list}. @i{name}---a @i{symbol}. Non-@i{keyword}, @i{non-nil} @i{symbols} are usually used. @i{operator}---an @i{operator}. @i{Name} and @i{operator} are often the @i{same} @i{symbol}. This is the default, but it is not required. @i{order}---@t{:most-specific-first} or @t{:most-specific-last}; evaluated. @i{predicate}---a @i{symbol} that names a @i{function} of one argument that returns a @i{generalized boolean}. @i{qualifier-pattern}---a @i{list}, or the @i{symbol} @b{*}. @i{required-p}---a @i{generalized boolean}. @subsubheading Description:: The macro @b{define-method-combination} is used to define new types of method combination. There are two forms of @b{define-method-combination}. The short form is a simple facility for the cases that are expected to be most commonly needed. The long form is more powerful but more verbose. It resembles @b{defmacro} in that the body is an expression, usually using backquote, that computes a @i{form}. Thus arbitrary control structures can be implemented. The long form also allows arbitrary processing of method @i{qualifiers}. @table @asis @item @b{Short Form} The short form syntax of @b{define-method-combination} is recognized when the second @i{subform} is a @i{non-nil} symbol or is not present. When the short form is used, @i{name} is defined as a type of method combination that produces a Lisp form @t{(@r{@i{operator} @i{method-call} @i{method-call} ...})}. The @i{operator} is a @i{symbol} that can be the @i{name} of a @i{function}, @i{macro}, or @i{special operator}. The @i{operator} can be supplied by a keyword option; it defaults to @i{name}. Keyword options for the short form are the following: @table @asis @item @t{*} The @t{:documentation} option is used to document the method-combination type; see description of long form below. @item @t{*} The @t{:identity-with-one-argument} option enables an optimization when its value is @i{true} (the default is @i{false}). If there is exactly one applicable method and it is a primary method, that method serves as the effective method and @i{operator} is not called. This optimization avoids the need to create a new effective method and avoids the overhead of a @i{function} call. This option is designed to be used with operators such as @b{progn}, @b{and}, @b{+}, and @b{max}. @item @t{*} The @t{:operator} option specifies the @i{name} of the operator. The @i{operator} argument is a @i{symbol} that can be the @i{name} of a @i{function}, @i{macro}, or @i{special form}. @end table These types of method combination require exactly one @i{qualifier} per method. An error is signaled if there are applicable methods with no @i{qualifiers} or with @i{qualifiers} that are not supported by the method combination type. A method combination procedure defined in this way recognizes two roles for methods. A method whose one @i{qualifier} is the symbol naming this type of method combination is defined to be a primary method. At least one primary method must be applicable or an error is signaled. A method with @t{:around} as its one @i{qualifier} is an auxiliary method that behaves the same as an @i{around method} in standard method combination. The @i{function} @b{call-next-method} can only be used in @i{around methods}; it cannot be used in primary methods defined by the short form of the @b{define-method-combination} macro. A method combination procedure defined in this way accepts an optional argument named @i{order}, which defaults to @t{:most-specific-first}. A value of @t{:most-specific-last} reverses the order of the primary methods without affecting the order of the auxiliary methods. The short form automatically includes error checking and support for @i{around methods}. For a discussion of built-in method combination types, see @ref{Built-in Method Combination Types}. @item @b{Long Form} The long form syntax of @b{define-method-combination} is recognized when the second @i{subform} is a list. The @i{lambda-list} receives any arguments provided after the @i{name} of the method combination type in the @t{:method-combination} option to @b{defgeneric}. A list of method group specifiers follows. Each specifier selects a subset of the applicable methods to play a particular role, either by matching their @i{qualifiers} against some patterns or by testing their @i{qualifiers} with a @i{predicate}. These method group specifiers define all method @i{qualifiers} that can be used with this type of method combination. The @i{car} of each @i{method-group-specifier} is a @i{symbol} which @i{names} a @i{variable}. During the execution of the @i{forms} in the body of @b{define-method-combination}, this @i{variable} is bound to a list of the @i{methods} in the method group. The @i{methods} in this list occur in the order specified by the @t{:order} option. If @i{qualifier-pattern} is a @i{symbol} it must be @b{*}. A method matches a @i{qualifier-pattern} if the method's list of @i{qualifiers} is @b{equal} to the @i{qualifier-pattern} (except that the symbol @b{*} in a @i{qualifier-pattern} matches anything). Thus a @i{qualifier-pattern} can be one of the following: the @i{empty list}, which matches @i{unqualified methods}; the symbol @b{*}, which matches all methods; a true list, which matches methods with the same number of @i{qualifiers} as the length of the list when each @i{qualifier} matches the corresponding list element; or a dotted list that ends in the symbol @b{*} (the @b{*} matches any number of additional @i{qualifiers}). Each applicable method is tested against the @i{qualifier-patterns} and @i{predicates} in left-to-right order. As soon as a @i{qualifier-pattern} matches or a @i{predicate} returns true, the method becomes a member of the corresponding method group and no further tests are made. Thus if a method could be a member of more than one method group, it joins only the first such group. If a method group has more than one @i{qualifier-pattern}, a method need only satisfy one of the @i{qualifier-patterns} to be a member of the group. The @i{name} of a @i{predicate} function can appear instead of @i{qualifier-patterns} in a method group specifier. The @i{predicate} is called for each method that has not been assigned to an earlier method group; it is called with one argument, the method's @i{qualifier} @i{list}. The @i{predicate} should return true if the method is to be a member of the method group. A @i{predicate} can be distinguished from a @i{qualifier-pattern} because it is a @i{symbol} other than @b{nil} or @b{*}. If there is an applicable method that does not fall into any method group, the @i{function} @b{invalid-method-error} is called. Method group specifiers can have keyword options following the @i{qualifier} patterns or predicate. Keyword options can be distinguished from additional @i{qualifier} patterns because they are neither lists nor the symbol @b{*}. The keyword options are as follows: @table @asis @item @t{*} The @t{:description} option is used to provide a description of the role of methods in the method group. Programming environment tools use @t{(apply #'format stream @i{format-control} (method-qualifiers @i{method}))} to print this description, which is expected to be concise. This keyword option allows the description of a method @i{qualifier} to be defined in the same module that defines the meaning of the method @i{qualifier}. In most cases, @i{format-control} will not contain any @b{format} directives, but they are available for generality. If @t{:description} is not supplied, a default description is generated based on the variable name and the @i{qualifier} patterns and on whether this method group includes the @i{unqualified methods}. @item @t{*} The @t{:order} option specifies the order of methods. The @i{order} argument is a @i{form} that evaluates to @t{:most-specific-first} or @t{:most-specific-last}. If it evaluates to any other value, an error is signaled. If @t{:order} is not supplied, it defaults to @t{:most-specific-first}. @item @t{*} The @t{:required} option specifies whether at least one method in this method group is required. If its value is @i{true} and the method group is empty (that is, no applicable methods match the @i{qualifier} patterns or satisfy the predicate), an error is signaled. If @t{:required} is not supplied, it defaults to @b{nil}. @end table The use of method group specifiers provides a convenient syntax to select methods, to divide them among the possible roles, and to perform the necessary error checking. It is possible to perform further filtering of methods in the body @i{forms} by using normal list-processing operations and the functions @b{method-qualifiers} and @b{invalid-method-error}. It is permissible to use @b{setq} on the variables named in the method group specifiers and to bind additional variables. It is also possible to bypass the method group specifier mechanism and do everything in the body @i{forms}. This is accomplished by writing a single method group with @b{*} as its only @i{qualifier-pattern}; the variable is then bound to a @i{list} of all of the @i{applicable methods}, in most-specific-first order. The body @i{forms} compute and return the @i{form} that specifies how the methods are combined, that is, the effective method. The effective method is evaluated in the @i{null lexical environment} augmented with a local macro definition for @b{call-method} and with bindings named by symbols not @i{accessible} from the @t{COMMON-LISP-USER} @i{package}. Given a method object in one of the @i{lists} produced by the method group specifiers and a @i{list} of next methods, @b{call-method} will invoke the method such that @b{call-next-method} has available the next methods. When an effective method has no effect other than to call a single method, some implementations employ an optimization that uses the single method directly as the effective method, thus avoiding the need to create a new effective method. This optimization is active when the effective method form consists entirely of an invocation of the @b{call-method} macro whose first @i{subform} is a method object and whose second @i{subform} is @b{nil} or unsupplied. Each @b{define-method-combination} body is responsible for stripping off redundant invocations of @b{progn}, @b{and}, @b{multiple-value-prog1}, and the like, if this optimization is desired. The list @t{(:arguments . @i{lambda-list})} can appear before any declarations or @i{documentation string}. This form is useful when the method combination type performs some specific behavior as part of the combined method and that behavior needs access to the arguments to the @i{generic function}. Each parameter variable defined by @i{lambda-list} is bound to a @i{form} that can be inserted into the effective method. When this @i{form} is evaluated during execution of the effective method, its value is the corresponding argument to the @i{generic function}; the consequences of using such a @i{form} as the @i{place} in a @b{setf} @i{form} are undefined. Argument correspondence is computed by dividing the @t{:arguments} @i{lambda-list} and the @i{generic function} @i{lambda-list} into three sections: the @i{required parameters}, the @i{optional parameters}, and the @i{keyword} and @i{rest parameters}. The @i{arguments} supplied to the @i{generic function} for a particular @i{call} are also divided into three sections; the required @i{arguments} section contains as many @i{arguments} as the @i{generic function} has @i{required parameters}, the optional @i{arguments} section contains as many arguments as the @i{generic function} has @i{optional parameters}, and the keyword/rest @i{arguments} section contains the remaining arguments. Each @i{parameter} in the required and optional sections of the @t{:arguments} @i{lambda-list} accesses the argument at the same position in the corresponding section of the @i{arguments}. If the section of the @t{:arguments} @i{lambda-list} is shorter, extra @i{arguments} are ignored. If the section of the @t{:arguments} @i{lambda-list} is longer, excess @i{required parameters} are bound to forms that evaluate to @b{nil} and excess @i{optional parameters} are @i{bound} to their initforms. The @i{keyword parameters} and @i{rest parameters} in the @t{:arguments} @i{lambda-list} access the keyword/rest section of the @i{arguments}. If the @t{:arguments} @i{lambda-list} contains @b{&key}, it behaves as if it also contained @b{&allow-other-keys}. In addition, @b{&whole} @i{var} can be placed first in the @t{:arguments} @i{lambda-list}. It causes @i{var} to be @i{bound} to a @i{form} that @i{evaluates} to a @i{list} of all of the @i{arguments} supplied to the @i{generic function}. This is different from @b{&rest} because it accesses all of the arguments, not just the keyword/rest @i{arguments}. Erroneous conditions detected by the body should be reported with @b{method-combination-error} or @b{invalid-method-error}; these @i{functions} add any necessary contextual information to the error message and will signal the appropriate error. The body @i{forms} are evaluated inside of the @i{bindings} created by the @i{lambda list} and method group specifiers. [Reviewer Note by Barmar: Are they inside or outside the :ARGUMENTS bindings?] Declarations at the head of the body are positioned directly inside of @i{bindings} created by the @i{lambda list} and outside of the @i{bindings} of the method group variables. Thus method group variables cannot be declared in this way. @b{locally} may be used around the body, however. Within the body @i{forms}, @i{generic-function-symbol} is bound to the @i{generic function} @i{object}. @i{Documentation} is attached as a @i{documentation string} to @i{name} (as kind @b{method-combination}) and to the @i{method combination} @i{object}. Note that two methods with identical specializers, but with different @i{qualifiers}, are not ordered by the algorithm described in Step 2 of the method selection and combination process described in @ref{Method Selection and Combination}. Normally the two methods play different roles in the effective method because they have different @i{qualifiers}, and no matter how they are ordered in the result of Step 2, the effective method is the same. If the two methods play the same role and their order matters, [Reviewer Note by Barmar: How does the system know when the order matters?] an error is signaled. This happens as part of the @i{qualifier} pattern matching in @b{define-method-combination}. @end table If a @b{define-method-combination} @i{form} appears as a @i{top level form}, the @i{compiler} must make the @i{method combination} @i{name} be recognized as a valid @i{method combination} @i{name} in subsequent @b{defgeneric} @i{forms}. However, the @i{method combination} is executed no earlier than when the @b{define-method-combination} @i{form} is executed, and possibly as late as the time that @i{generic functions} that use the @i{method combination} are executed. @subsubheading Examples:: Most examples of the long form of @b{define-method-combination} also illustrate the use of the related @i{functions} that are provided as part of the declarative method combination facility. @example ;;; Examples of the short form of define-method-combination (define-method-combination and :identity-with-one-argument t) (defmethod func and ((x class1) y) ...) ;;; The equivalent of this example in the long form is: (define-method-combination and (&optional (order :most-specific-first)) ((around (:around)) (primary (and) :order order :required t)) (let ((form (if (rest primary) `(and ,@@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@@(rest around) (make-method ,form))) form))) ;;; Examples of the long form of define-method-combination ;The default method-combination technique (define-method-combination standard () ((around (:around)) (before (:before)) (primary () :required t) (after (:after))) (flet ((call-methods (methods) (mapcar #'(lambda (method) `(call-method ,method)) methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@@(call-methods before) (call-method ,(first primary) ,(rest primary))) ,@@(call-methods (reverse after))) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@@(rest around) (make-method ,form))) form)))) ;A simple way to try several methods until one returns non-nil (define-method-combination or () ((methods (or))) `(or ,@@(mapcar #'(lambda (method) `(call-method ,method)) methods))) ;A more complete version of the preceding (define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or))) ;; Process the order argument (case order (:most-specific-first) (:most-specific-last (setq primary (reverse primary))) (otherwise (method-combination-error "~S is an invalid order.~@@ :most-specific-first and :most-specific-last are the possible values." order))) ;; Must have a primary method (unless primary (method-combination-error "A primary method is required.")) ;; Construct the form that calls the primary methods (let ((form (if (rest primary) `(or ,@@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) ;; Wrap the around methods around that form (if around `(call-method ,(first around) (,@@(rest around) (make-method ,form))) form))) ;The same thing, using the :order and :required keyword options (define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or) :order order :required t)) (let ((form (if (rest primary) `(or ,@@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@@(rest around) (make-method ,form))) form))) ;This short-form call is behaviorally identical to the preceding (define-method-combination or :identity-with-one-argument t) ;Order methods by positive integer qualifiers ;:around methods are disallowed to keep the example small (define-method-combination example-method-combination () ((methods positive-integer-qualifier-p)) `(progn ,@@(mapcar #'(lambda (method) `(call-method ,method)) (stable-sort methods #'< :key #'(lambda (method) (first (method-qualifiers method))))))) (defun positive-integer-qualifier-p (method-qualifiers) (and (= (length method-qualifiers) 1) (typep (first method-qualifiers) '(integer 0 *)))) ;;; Example of the use of :arguments (define-method-combination progn-with-lock () ((methods ())) (:arguments object) `(unwind-protect (progn (lock (object-lock ,object)) ,@@(mapcar #'(lambda (method) `(call-method ,method)) methods)) (unlock (object-lock ,object)))) @end example @subsubheading Side Effects:: The @i{compiler} is not required to perform any compile-time side-effects. @subsubheading Exceptional Situations:: Method combination types defined with the short form require exactly one @i{qualifier} per method. An error of @i{type} @b{error} is signaled if there are applicable methods with no @i{qualifiers} or with @i{qualifiers} that are not supported by the method combination type. At least one primary method must be applicable or an error of @i{type} @b{error} is signaled. If an applicable method does not fall into any method group, the system signals an error of @i{type} @b{error} indicating that the method is invalid for the kind of method combination in use. If the value of the @t{:required} option is @i{true} and the method group is empty (that is, no applicable methods match the @i{qualifier} patterns or satisfy the predicate), an error of @i{type} @b{error} is signaled. If the @t{:order} option evaluates to a value other than @t{:most-specific-first} or @t{:most-specific-last}, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{call-method} , @ref{call-next-method} , @ref{documentation} , @ref{method-qualifiers} , @ref{method-combination-error} , @ref{invalid-method-error} , @ref{defgeneric} , @ref{Method Selection and Combination}, @ref{Built-in Method Combination Types}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: The @t{:method-combination} option of @b{defgeneric} is used to specify that a @i{generic function} should use a particular method combination type. The first argument to the @t{:method-combination} option is the @i{name} of a method combination type and the remaining arguments are options for that type. @node find-method, add-method, define-method-combination, Objects Dictionary @subsection find-method [Standard Generic Function] @subsubheading Syntax:: @code{find-method} @i{generic-function method-qualifiers specializers @r{&optional} errorp}@* @result{} @i{method} @subsubheading Method Signatures:: @code{find-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} method-qualifiers specializers @r{&optional} errorp} @subsubheading Arguments and Values:: @i{generic-function}---a @i{generic function}. @i{method-qualifiers}---a @i{list}. @i{specializers}---a @i{list}. @i{errorp}---a @i{generalized boolean}. The default is @i{true}. @i{method}---a @i{method} @i{object}, or @b{nil}. @subsubheading Description:: The @i{generic function} @b{find-method} takes a @i{generic function} and returns the @i{method} @i{object} that agrees on @i{qualifiers} and @i{parameter specializers} with the @i{method-qualifiers} and @i{specializers} arguments of @b{find-method}. @i{Method-qualifiers} contains the method @i{qualifiers} for the @i{method}. The order of the method @i{qualifiers} is significant. For a definition of agreement in this context, see @ref{Agreement on Parameter Specializers and Qualifiers}. The @i{specializers} argument contains the parameter specializers for the @i{method}. It must correspond in length to the number of required arguments of the @i{generic function}, or an error is signaled. This means that to obtain the default @i{method} on a given @i{generic-function}, a @i{list} whose elements are the @i{class} @b{t} must be given. If there is no such @i{method} and @i{errorp} is @i{true}, @b{find-method} signals an error. If there is no such @i{method} and @i{errorp} is @i{false}, @b{find-method} returns @b{nil}. @subsubheading Examples:: @example (defmethod some-operation ((a integer) (b float)) (list a b)) @result{} # (find-method #'some-operation '() (mapcar #'find-class '(integer float))) @result{} # (find-method #'some-operation '() (mapcar #'find-class '(integer integer))) @t{ |> } Error: No matching method (find-method #'some-operation '() (mapcar #'find-class '(integer integer)) nil) @result{} NIL @end example @subsubheading Affected By:: @b{add-method}, @b{defclass}, @b{defgeneric}, @b{defmethod} @subsubheading Exceptional Situations:: If the @i{specializers} argument does not correspond in length to the number of required arguments of the @i{generic-function}, an an error of @i{type} @b{error} is signaled. If there is no such @i{method} and @i{errorp} is @i{true}, @b{find-method} signals an error of @i{type} @b{error}. @subsubheading See Also:: @ref{Agreement on Parameter Specializers and Qualifiers} @node add-method, initialize-instance, find-method, Objects Dictionary @subsection add-method [Standard Generic Function] @subsubheading Syntax:: @code{add-method} @i{generic-function method} @result{} @i{generic-function} @subsubheading Method Signatures:: @code{add-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} @r{(}@i{method} @b{method}@r{)}} @subsubheading Arguments and Values:: @i{generic-function}---a @i{generic function} @i{object}. @i{method}---a @i{method} @i{object}. @subsubheading Description:: The generic function @b{add-method} adds a @i{method} to a @i{generic function}. If @i{method} agrees with an existing @i{method} of @i{generic-function} on @i{parameter specializers} and @i{qualifiers}, the existing @i{method} is replaced. @subsubheading Exceptional Situations:: The @i{lambda list} of the method function of @i{method} must be congruent with the @i{lambda list} of @i{generic-function}, or an error of @i{type} @b{error} is signaled. If @i{method} is a @i{method} @i{object} of another @i{generic function}, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{defmethod} , @ref{defgeneric} , @ref{find-method} , @ref{remove-method} , @ref{Agreement on Parameter Specializers and Qualifiers} @node initialize-instance, class-name, add-method, Objects Dictionary @subsection initialize-instance [Standard Generic Function] @subsubheading Syntax:: @code{initialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{initialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @i{instance}---an @i{object}. @i{initargs}---a @i{defaulted initialization argument list}. @subsubheading Description:: Called by @b{make-instance} to initialize a newly created @i{instance}. The generic function is called with the new @i{instance} and the @i{defaulted initialization argument list}. The system-supplied primary @i{method} on @b{initialize-instance} initializes the @i{slots} of the @i{instance} with values according to the @i{initargs} and the @t{:initform} forms of the @i{slots}. It does this by calling the generic function @b{shared-initialize} with the following arguments: the @i{instance}, @b{t} (this indicates that all @i{slots} for which no initialization arguments are provided should be initialized according to their @t{:initform} forms), and the @i{initargs}. Programmers can define @i{methods} for @b{initialize-instance} to specify actions to be taken when an instance is initialized. If only @i{after methods} are defined, they will be run after the system-supplied primary @i{method} for initialization and therefore will not interfere with the default behavior of @b{initialize-instance}. @subsubheading See Also:: @ref{Shared-Initialize} , @ref{make-instance} , @ref{slot-boundp} , @ref{slot-makunbound} , @ref{Object Creation and Initialization}, @ref{Rules for Initialization Arguments}, @ref{Declaring the Validity of Initialization Arguments} @node class-name, setf class-name, initialize-instance, Objects Dictionary @subsection class-name [Standard Generic Function] @subsubheading Syntax:: @code{class-name} @i{class} @result{} @i{name} @subsubheading Method Signatures:: @code{class-name} @i{@r{(}@i{class} @b{class}@r{)}} @subsubheading Arguments and Values:: @i{class}---a @i{class} @i{object}. @i{name}---a @i{symbol}. @subsubheading Description:: Returns the @i{name} of the given @i{class}. @subsubheading See Also:: @ref{find-class} , @ref{Classes} @subsubheading Notes:: If S is a @i{symbol} such that S =@t{(class-name C)} and C =@t{(find-class S)}, then S is the proper name of C. For further discussion, see @ref{Classes}. The name of an anonymous @i{class} is @b{nil}. @node setf class-name, class-of, class-name, Objects Dictionary @subsection setf class-name [Standard Generic Function] @subsubheading Syntax:: @code{setf class-name} @i{new-value class} @result{} @i{new-value} @subsubheading Method Signatures:: @code{setf class-name} @i{new-value @r{(}@i{class} @b{class}@r{)}} @subsubheading Arguments and Values:: @i{new-value}---a @i{symbol}. @i{class}---a @i{class}. @subsubheading Description:: The generic function @t{setf class-name} sets the name of a @i{class} object. @subsubheading See Also:: @ref{find-class} , @i{proper name}, @ref{Classes} @node class-of, unbound-slot, setf class-name, Objects Dictionary @subsection class-of [Function] @code{class-of} @i{object} @result{} @i{class} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{class}---a @i{class} @i{object}. @subsubheading Description:: Returns the @i{class} of which the @i{object} is a @i{direct instance}. @subsubheading Examples:: @example (class-of 'fred) @result{} # (class-of 2/3) @result{} # (defclass book () ()) @result{} # (class-of (make-instance 'book)) @result{} # (defclass novel (book) ()) @result{} # (class-of (make-instance 'novel)) @result{} # (defstruct kons kar kdr) @result{} KONS (class-of (make-kons :kar 3 :kdr 4)) @result{} # @end example @subsubheading See Also:: @ref{make-instance} , @ref{type-of} @node unbound-slot, unbound-slot-instance, class-of, Objects Dictionary @subsection unbound-slot [Condition Type] @subsubheading Class Precedence List:: @b{unbound-slot}, @b{cell-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{object} having the unbound slot is initialized by the @t{:instance} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{unbound-slot-instance}. The name of the cell (see @b{cell-error}) is the name of the slot. @subsubheading See Also:: @ref{cell-error-name} , @b{unbound-slot-object}, @ref{Condition System Concepts} @node unbound-slot-instance, , unbound-slot, Objects Dictionary @subsection unbound-slot-instance [Function] @code{unbound-slot-instance} @i{condition} @result{} @i{instance} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{unbound-slot}. @i{instance}---an @i{object}. @subsubheading Description:: Returns the instance which had the unbound slot in the @i{situation} represented by the @i{condition}. @subsubheading See Also:: @ref{cell-error-name} , @b{unbound-slot}, @ref{Condition System Concepts} @c end of including dict-objects @c %**end of chapter gcl-2.6.14/info/chap-11.texi0000644000175000017500000026104414360276512013762 0ustar cammcamm @node Packages, Numbers (Numbers), Symbols, Top @chapter Packages @menu * Package Concepts:: * Packages Dictionary:: @end menu @node Package Concepts, Packages Dictionary, Packages, Packages @section Package Concepts @c including concept-packages @menu * Introduction to Packages:: * Standardized Packages:: @end menu @node Introduction to Packages, Standardized Packages, Package Concepts, Package Concepts @subsection Introduction to Packages A @i{package} @IGindex package establishes a mapping from names to @i{symbols}. At any given time, one @i{package} is current. The @i{current package} @IGindex current package is the one that is the @i{value} of @b{*package*}. When using the @i{Lisp reader}, it is possible to refer to @i{symbols} in @i{packages} other than the current one through the use of @i{package prefixes} in the printed representation of the @i{symbol}. Figure 11--1 lists some @i{defined names} that are applicable to @i{packages}. Where an @i{operator} takes an argument that is either a @i{symbol} or a @i{list} of @i{symbols}, an argument of @b{nil} is treated as an empty @i{list} of @i{symbols}. Any @i{package} argument may be either a @i{string}, a @i{symbol}, or a @i{package}. If a @i{symbol} is supplied, its name will be used as the @i{package} name. @format @group @noindent @w{ *modules* import provide } @w{ *package* in-package rename-package } @w{ defpackage intern require } @w{ do-all-symbols list-all-packages shadow } @w{ do-external-symbols make-package shadowing-import } @w{ do-symbols package-name unexport } @w{ export package-nicknames unintern } @w{ find-all-symbols package-shadowing-symbols unuse-package } @w{ find-package package-use-list use-package } @w{ find-symbol package-used-by-list } @noindent @w{ Figure 11--1: Some Defined Names related to Packages } @end group @end format @menu * Package Names and Nicknames:: * Symbols in a Package:: * Internal and External Symbols:: * Package Inheritance:: * Accessibility of Symbols in a Package:: * Locating a Symbol in a Package:: * Prevention of Name Conflicts in Packages:: @end menu @node Package Names and Nicknames, Symbols in a Package, Introduction to Packages, Introduction to Packages @subsubsection Package Names and Nicknames Each @i{package} has a @i{name} (a @i{string}) and perhaps some @i{nicknames} (also @i{strings}). These are assigned when the @i{package} is created and can be changed later. There is a single namespace for @i{packages}. The @i{function} @b{find-package} translates a package @i{name} or @i{nickname} into the associated @i{package}. The @i{function} @b{package-name} returns the @i{name} of a @i{package}. The @i{function} @b{package-nicknames} returns a @i{list} of all @i{nicknames} for a @i{package}. @b{rename-package} removes a @i{package}'s current @i{name} and @i{nicknames} and replaces them with new ones specified by the caller. @node Symbols in a Package, Internal and External Symbols, Package Names and Nicknames, Introduction to Packages @subsubsection Symbols in a Package @node Internal and External Symbols, Package Inheritance, Symbols in a Package, Introduction to Packages @subsubsection Internal and External Symbols The mappings in a @i{package} are divided into two classes, external and internal. The @i{symbols} targeted by these different mappings are called @i{external symbols} and @i{internal symbols} @IGindex internal symbol of the @i{package}. Within a @i{package}, a name refers to one @i{symbol} or to none; if it does refer to a @i{symbol}, then it is either external or internal in that @i{package}, but not both. @i{External symbols} @IGindex external symbol are part of the package's public interface to other @i{packages}. @i{Symbols} become @i{external symbols} of a given @i{package} if they have been @i{exported} from that @i{package}. A @i{symbol} has the same @i{name} no matter what @i{package} it is @i{present} in, but it might be an @i{external symbol} of some @i{packages} and an @i{internal symbol} of others. @node Package Inheritance, Accessibility of Symbols in a Package, Internal and External Symbols, Introduction to Packages @subsubsection Package Inheritance @i{Packages} can be built up in layers. From one point of view, a @i{package} is a single collection of mappings from @i{strings} into @i{internal symbols} and @i{external symbols}. However, some of these mappings might be established within the @i{package} itself, while other mappings are inherited from other @i{packages} via @b{use-package}. A @i{symbol} is said to be @i{present} @IGindex present in a @i{package} if the mapping is in the @i{package} itself and is not inherited from somewhere else. There is no way to inherit the @i{internal symbols} of another @i{package}; to refer to an @i{internal symbol} using the @i{Lisp reader}, a @i{package} containing the @i{symbol} must be made to be the @i{current package}, a @i{package prefix} must be used, or the @i{symbol} must be @i{imported} into the @i{current package}. @node Accessibility of Symbols in a Package, Locating a Symbol in a Package, Package Inheritance, Introduction to Packages @subsubsection Accessibility of Symbols in a Package A @i{symbol} becomes @i{accessible} @IGindex accessible in a @i{package} if that is its @i{home package} when it is created, or if it is @i{imported} into that @i{package}, or by inheritance via @b{use-package}. If a @i{symbol} is @i{accessible} in a @i{package}, it can be referred to when using the @i{Lisp reader} without a @i{package prefix} when that @i{package} is the @i{current package}, regardless of whether it is @i{present} or inherited. @i{Symbols} from one @i{package} can be made @i{accessible} in another @i{package} in two ways. @table @asis @item -- Any individual @i{symbol} can be added to a @i{package} by use of @b{import}. After the call to @b{import} the @i{symbol} is @i{present} in the importing @i{package}. The status of the @i{symbol} in the @i{package} it came from (if any) is unchanged, and the @i{home package} for this @i{symbol} is unchanged. Once @i{imported}, a @i{symbol} is @i{present} in the importing @i{package} and can be removed only by calling @b{unintern}. A @i{symbol} is @i{shadowed}_3 by another @i{symbol} in some @i{package} if the first @i{symbol} would be @i{accessible} by inheritance if not for the presence of the second @i{symbol}. See @b{shadowing-import}. @item -- The second mechanism for making @i{symbols} from one @i{package} @i{accessible} in another is provided by @b{use-package}. All of the @i{external symbols} of the used @i{package} are inherited by the using @i{package}. The @i{function} @b{unuse-package} undoes the effects of a previous @b{use-package}. @end table @node Locating a Symbol in a Package, Prevention of Name Conflicts in Packages, Accessibility of Symbols in a Package, Introduction to Packages @subsubsection Locating a Symbol in a Package When a @i{symbol} is to be located in a given @i{package} the following occurs: @table @asis @item -- The @i{external symbols} and @i{internal symbols} of the @i{package} are searched for the @i{symbol}. @item -- The @i{external symbols} of the used @i{packages} are searched in some unspecified order. The order does not matter; see the rules for handling name conflicts listed below. @end table @node Prevention of Name Conflicts in Packages, , Locating a Symbol in a Package, Introduction to Packages @subsubsection Prevention of Name Conflicts in Packages Within one @i{package}, any particular name can refer to at most one @i{symbol}. A name conflict is said to occur when there would be more than one candidate @i{symbol}. Any time a name conflict is about to occur, a @i{correctable} @i{error} is signaled. The following rules apply to name conflicts: @table @asis @item -- Name conflicts are detected when they become possible, that is, when the package structure is altered. Name conflicts are not checked during every name lookup. @item -- If the @i{same} @i{symbol} is @i{accessible} to a @i{package} through more than one path, there is no name conflict. A @i{symbol} cannot conflict with itself. Name conflicts occur only between @i{distinct} @i{symbols} with the same name (under @b{string=}). @item -- Every @i{package} has a list of shadowing @i{symbols}. A shadowing @i{symbol} takes precedence over any other @i{symbol} of the same name that would otherwise be @i{accessible} in the @i{package}. A name conflict involving a shadowing symbol is always resolved in favor of the shadowing @i{symbol}, without signaling an error (except for one exception involving @b{import}). See @b{shadow} and @b{shadowing-import}. @item -- The functions @b{use-package}, @b{import}, and @b{export} check for name conflicts. @item -- @b{shadow} and @b{shadowing-import} never signal a name-conflict error. @item -- @b{unuse-package} and @b{unexport} do not need to do any name-conflict checking. @b{unintern} does name-conflict checking only when a @i{symbol} being @i{uninterned} is a @i{shadowing symbol} @IGindex shadowing symbol . @item -- Giving a shadowing symbol to @b{unintern} can uncover a name conflict that had previously been resolved by the shadowing. @item -- Package functions signal name-conflict errors of @i{type} @b{package-error} before making any change to the package structure. When multiple changes are to be made, it is permissible for the implementation to process each change separately. For example, when @b{export} is given a @i{list} of @i{symbols}, aborting from a name conflict caused by the second @i{symbol} in the @i{list} might still export the first @i{symbol} in the @i{list}. However, a name-conflict error caused by @b{export} of a single @i{symbol} will be signaled before that @i{symbol}'s @i{accessibility} in any @i{package} is changed. @item -- Continuing from a name-conflict error must offer the user a chance to resolve the name conflict in favor of either of the candidates. The @i{package} structure should be altered to reflect the resolution of the name conflict, via @b{shadowing-import}, @b{unintern}, or @b{unexport}. @item -- A name conflict in @b{use-package} between a @i{symbol} @i{present} in the using @i{package} and an @i{external symbol} of the used @i{package} is resolved in favor of the first @i{symbol} by making it a shadowing @i{symbol}, or in favor of the second @i{symbol} by uninterning the first @i{symbol} from the using @i{package}. @item -- A name conflict in @b{export} or @b{unintern} due to a @i{package}'s inheriting two @i{distinct} @i{symbols} with the @i{same} @i{name} (under @b{string=}) from two other @i{packages} can be resolved in favor of either @i{symbol} by importing it into the using @i{package} and making it a @i{shadowing symbol} @IGindex shadowing symbol , just as with @b{use-package}. @end table @node Standardized Packages, , Introduction to Packages, Package Concepts @subsection Standardized Packages This section describes the @i{packages} that are available in every @i{conforming implementation}. A summary of the @i{names} and @i{nicknames} of those @i{standardized} @i{packages} is given in Figure 11--2. @format @group @noindent @w{ Name Nicknames } @w{ @t{COMMON-LISP} @t{CL} } @w{ @t{COMMON-LISP-USER} @t{CL-USER} } @w{ @t{KEYWORD} @i{none} } @noindent @w{ Figure 11--2: Standardized Package Names} @end group @end format @menu * The COMMON-LISP Package:: * Constraints on the COMMON-LISP Package for Conforming Implementations:: * Constraints on the COMMON-LISP Package for Conforming Programs:: * Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs:: * The COMMON-LISP-USER Package:: * The KEYWORD Package:: * Interning a Symbol in the KEYWORD Package:: * Notes about The KEYWORD Package:: * Implementation-Defined Packages:: @end menu @node The COMMON-LISP Package, Constraints on the COMMON-LISP Package for Conforming Implementations, Standardized Packages, Standardized Packages @subsubsection The COMMON-LISP Package @IPindex common-lisp @IPindex cl The @t{COMMON-LISP} @i{package} contains the primitives of the @r{Common Lisp} system as defined by this specification. Its @i{external} @i{symbols} include all of the @i{defined names} (except for @i{defined names} in the @t{KEYWORD} @i{package}) that are present in the @r{Common Lisp} system, such as @b{car}, @b{cdr}, @b{*package*}, etc. The @t{COMMON-LISP} @i{package} has the @i{nickname} @t{CL}. The @t{COMMON-LISP} @i{package} has as @i{external} @i{symbols} those symbols enumerated in the figures in @ref{Symbols in the COMMON-LISP Package}, and no others. These @i{external} @i{symbols} are @i{present} in the @t{COMMON-LISP} @i{package} but their @i{home package} need not be the @t{COMMON-LISP} @i{package}. For example, the symbol @t{HELP} cannot be an @i{external symbol} of the @t{COMMON-LISP} @i{package} because it is not mentioned in @ref{Symbols in the COMMON-LISP Package}. In contrast, the @i{symbol} @b{variable} must be an @i{external symbol} of the @t{COMMON-LISP} @i{package} even though it has no definition because it is listed in that section (to support its use as a valid second @i{argument} to the @i{function} @b{documentation}). The @t{COMMON-LISP} @i{package} can have additional @i{internal symbols}. @node Constraints on the COMMON-LISP Package for Conforming Implementations, Constraints on the COMMON-LISP Package for Conforming Programs, The COMMON-LISP Package, Standardized Packages @subsubsection Constraints on the COMMON-LISP Package for Conforming Implementations In a @i{conforming implementation}, an @i{external} @i{symbol} of the @t{COMMON-LISP} @i{package} can have a @i{function}, @i{macro}, or @i{special operator} definition, a @i{global variable} definition (or other status as a @i{dynamic variable} due to a @b{special} @i{proclamation}), or a @i{type} definition only if explicitly permitted in this standard. For example, @b{fboundp} @i{yields} @i{false} for any @i{external symbol} of the @t{COMMON-LISP} @i{package} that is not the @i{name} of a @i{standardized} @i{function}, @i{macro} or @i{special operator}, and @b{boundp} returns @i{false} for any @i{external symbol} of the @t{COMMON-LISP} @i{package} that is not the @i{name} of a @i{standardized} @i{global variable}. It also follows that @i{conforming programs} can use @i{external symbols} of the @t{COMMON-LISP} @i{package} as the @i{names} of local @i{lexical variables} with confidence that those @i{names} have not been @i{proclaimed} @b{special} by the @i{implementation} unless those @i{symbols} are @i{names} of @i{standardized} @i{global variables}. A @i{conforming implementation} must not place any @i{property} on an @i{external symbol} of the @t{COMMON-LISP} @i{package} using a @i{property indicator} that is either an @i{external symbol} of any @i{standardized} @i{package} or a @i{symbol} that is otherwise @i{accessible} in the @t{COMMON-LISP-USER} @i{package}. @node Constraints on the COMMON-LISP Package for Conforming Programs, Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, Constraints on the COMMON-LISP Package for Conforming Implementations, Standardized Packages @subsubsection Constraints on the COMMON-LISP Package for Conforming Programs @ITindex redefinition Except where explicitly allowed, the consequences are undefined if any of the following actions are performed on an @i{external symbol} of the @t{COMMON-LISP} @i{package}: @table @asis @item 1. @i{Binding} or altering its value (lexically or dynamically). (Some exceptions are noted below.) @item 2. Defining, undefining, or @i{binding} it as a @i{function}. (Some exceptions are noted below.) @item 3. Defining, undefining, or @i{binding} it as a @i{macro} or @i{compiler macro}. (Some exceptions are noted below.) @item 4. Defining it as a @i{type specifier} (via @b{defstruct}, @b{defclass}, @b{deftype}, @b{define-condition}). @item 5. Defining it as a structure (via @b{defstruct}). @item 6. Defining it as a @i{declaration} with a @b{declaration} @i{proclamation}. @item 7. Defining it as a @i{symbol macro}. @item 8. Altering its @i{home package}. @item 9. Tracing it (via @b{trace}). @item 10. Declaring or proclaiming it @b{special} (via @b{declare}, @b{declaim}, or @b{proclaim}). @item 11. Declaring or proclaiming its @b{type} or @b{ftype} (via @b{declare}, @b{declaim}, or @b{proclaim}). (Some exceptions are noted below.) @item 12. Removing it from the @t{COMMON-LISP} @i{package}. @item 13. Defining a @i{setf expander} for it (via @b{defsetf} or @b{define-setf-method}). @item 14. Defining, undefining, or binding its @i{setf function name}. @item 15. Defining it as a @i{method combination} type (via @b{define-method-combination}). @item 16. Using it as the class-name argument to @b{setf} of @b{find-class}. @item 17. Binding it as a @i{catch tag}. @item 18. Binding it as a @i{restart} @i{name}. @item 19. Defining a @i{method} for a @i{standardized} @i{generic function} which is @i{applicable} when all of the @i{arguments} are @i{direct instances} of @i{standardized} @i{classes}. @end table @node Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, The COMMON-LISP-USER Package, Constraints on the COMMON-LISP Package for Conforming Programs, Standardized Packages @subsubsection Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs If an @i{external symbol} of the @t{COMMON-LISP} @i{package} is not globally defined as a @i{standardized} @i{dynamic variable} or @i{constant variable}, it is allowed to lexically @i{bind} it and to declare the @b{type} of that @i{binding}, and it is allowed to locally @i{establish} it as a @i{symbol macro} (@i{e.g.}, with @b{symbol-macrolet}). Unless explicitly specified otherwise, if an @i{external symbol} of the @t{COMMON-LISP} @i{package} is globally defined as a @i{standardized} @i{dynamic variable}, it is permitted to @i{bind} or @i{assign} that @i{dynamic variable} provided that the ``Value Type'' constraints on the @i{dynamic variable} are maintained, and that the new @i{value} of the @i{variable} is consistent with the stated purpose of the @i{variable}. If an @i{external symbol} of the @t{COMMON-LISP} @i{package} is not defined as a @i{standardized} @i{function}, @i{macro}, or @i{special operator}, it is allowed to lexically @i{bind} it as a @i{function} (@i{e.g.}, with @b{flet}), to declare the @b{ftype} of that @i{binding}, and (in @i{implementations} which provide the ability to do so) to @b{trace} that @i{binding}. If an @i{external symbol} of the @t{COMMON-LISP} @i{package} is not defined as a @i{standardized} @i{function}, @i{macro}, or @i{special operator}, it is allowed to lexically @i{bind} it as a @i{macro} (@i{e.g.}, with @b{macrolet}). If an @i{external symbol} of the @t{COMMON-LISP} @i{package} is not defined as a @i{standardized} @i{function}, @i{macro}, or @i{special operator}, it is allowed to lexically @i{bind} its @i{setf function name} as a @i{function}, and to declare the @b{ftype} of that @i{binding}. @node The COMMON-LISP-USER Package, The KEYWORD Package, Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, Standardized Packages @subsubsection The COMMON-LISP-USER Package @IPindex common-lisp-user @IPindex cl-user The @t{COMMON-LISP-USER} @i{package} is the @i{current package} when a @r{Common Lisp} system starts up. This @i{package} @i{uses} the @t{COMMON-LISP} @i{package}. The @t{COMMON-LISP-USER} @i{package} has the @i{nickname} @t{CL-USER}. The @t{COMMON-LISP-USER} @i{package} can have additional @i{symbols} @i{interned} within it; it can @i{use} other @i{implementation-defined} @i{packages}. @node The KEYWORD Package, Interning a Symbol in the KEYWORD Package, The COMMON-LISP-USER Package, Standardized Packages @subsubsection The KEYWORD Package @IPindex keyword The @t{KEYWORD} @i{package} contains @i{symbols}, called @i{keywords}_1, that are typically used as special markers in @i{programs} and their associated data @i{expressions}_1. @i{Symbol} @i{tokens} that start with a @i{package marker} are parsed by the @i{Lisp reader} as @i{symbols} in the @t{KEYWORD} @i{package}; see @ref{Symbols as Tokens}. This makes it notationally convenient to use @i{keywords} when communicating between programs in different @i{packages}. For example, the mechanism for passing @i{keyword parameters} in a @i{call} uses @i{keywords}_1 to name the corresponding @i{arguments}; see @ref{Ordinary Lambda Lists}. @i{Symbols} in the @t{KEYWORD} @i{package} are, by definition, of @i{type} @b{keyword}. @node Interning a Symbol in the KEYWORD Package, Notes about The KEYWORD Package, The KEYWORD Package, Standardized Packages @subsubsection Interning a Symbol in the KEYWORD Package The @t{KEYWORD} @i{package} is treated differently than other @i{packages} in that special actions are taken when a @i{symbol} is @i{interned} in it. In particular, when a @i{symbol} is @i{interned} in the @t{KEYWORD} @i{package}, it is automatically made to be an @i{external symbol} and is automatically made to be a @i{constant variable} with itself as a @i{value}. @node Notes about The KEYWORD Package, Implementation-Defined Packages, Interning a Symbol in the KEYWORD Package, Standardized Packages @subsubsection Notes about The KEYWORD Package It is generally best to confine the use of @i{keywords} to situations in which there are a finitely enumerable set of names to be selected between. For example, if there were two states of a light switch, they might be called @t{:on} and @t{:off}. In situations where the set of names is not finitely enumerable (@i{i.e.}, where name conflicts might arise) it is frequently best to use @i{symbols} in some @i{package} other than @t{KEYWORD} so that conflicts will be naturally avoided. For example, it is generally not wise for a @i{program} to use a @i{keyword}_1 as a @i{property indicator}, since if there were ever another @i{program} that did the same thing, each would clobber the other's data. @node Implementation-Defined Packages, , Notes about The KEYWORD Package, Standardized Packages @subsubsection Implementation-Defined Packages Other, @i{implementation-defined} @i{packages} might be present in the initial @r{Common Lisp} environment. It is recommended, but not required, that the documentation for a @i{conforming implementation} contain a full list of all @i{package} names initially present in that @i{implementation} but not specified in this specification. (See also the @i{function} @b{list-all-packages}.) @c end of including concept-packages @node Packages Dictionary, , Package Concepts, Packages @section Packages Dictionary @c including dict-packages @menu * package:: * export:: * find-symbol:: * find-package:: * find-all-symbols:: * import:: * list-all-packages:: * rename-package:: * shadow:: * shadowing-import:: * delete-package:: * make-package:: * with-package-iterator:: * unexport:: * unintern:: * in-package:: * unuse-package:: * use-package:: * defpackage:: * do-symbols:: * intern:: * package-name:: * package-nicknames:: * package-shadowing-symbols:: * package-use-list:: * package-used-by-list:: * packagep:: * *package*:: * package-error:: * package-error-package:: @end menu @node package, export, Packages Dictionary, Packages Dictionary @subsection package [System Class] @subsubheading Class Precedence List:: @b{package}, @b{t} @subsubheading Description:: A @i{package} is a @i{namespace} that maps @i{symbol} @i{names} to @i{symbols}; see @ref{Package Concepts}. @subsubheading See Also:: @ref{Package Concepts}, @ref{Printing Other Objects}, @ref{Symbols as Tokens} @node export, find-symbol, package, Packages Dictionary @subsection export [Function] @code{export} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{symbols}---a @i{designator} for a @i{list} of @i{symbols}. @i{package}---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{export} makes one or more @i{symbols} that are @i{accessible} in @i{package} (whether directly or by inheritance) be @i{external symbols} of that @i{package}. If any of the @i{symbols} is already @i{accessible} as an @i{external symbol} of @i{package}, @b{export} has no effect on that @i{symbol}. If the @i{symbol} is @i{present} in @i{package} as an internal symbol, it is simply changed to external status. If it is @i{accessible} as an @i{internal symbol} via @b{use-package}, it is first @i{imported} into @i{package}, then @i{exported}. (The @i{symbol} is then @i{present} in the @i{package} whether or not @i{package} continues to use the @i{package} through which the @i{symbol} was originally inherited.) @b{export} makes each @i{symbol} @i{accessible} to all the @i{packages} that use @i{package}. All of these @i{packages} are checked for name conflicts: @t{(export @i{s} @i{p})} does @t{(find-symbol (symbol-name @i{s}) @i{q})} for each package @i{q} in @t{(package-used-by-list @i{p})}. Note that in the usual case of an @b{export} during the initial definition of a @i{package}, the result of @b{package-used-by-list} is @b{nil} and the name-conflict checking takes negligible time. When multiple changes are to be made, for example when @b{export} is given a @i{list} of @i{symbols}, it is permissible for the implementation to process each change separately, so that aborting from a name conflict caused by any but the first @i{symbol} in the @i{list} does not unexport the first @i{symbol} in the @i{list}. However, aborting from a name-conflict error caused by @b{export} of one of @i{symbols} does not leave that @i{symbol} @i{accessible} to some @i{packages} and @i{inaccessible} to others; with respect to each of @i{symbols} processed, @b{export} behaves as if it were as an atomic operation. A name conflict in @b{export} between one of @i{symbols} being exported and a @i{symbol} already @i{present} in a @i{package} that would inherit the newly-exported @i{symbol} may be resolved in favor of the exported @i{symbol} by uninterning the other one, or in favor of the already-present @i{symbol} by making it a shadowing symbol. @subsubheading Examples:: @example (make-package 'temp :use nil) @result{} # (use-package 'temp) @result{} T (intern "TEMP-SYM" 'temp) @result{} TEMP::TEMP-SYM, NIL (find-symbol "TEMP-SYM") @result{} NIL, NIL (export (find-symbol "TEMP-SYM" 'temp) 'temp) @result{} T (find-symbol "TEMP-SYM") @result{} TEMP-SYM, :INHERITED @end example @subsubheading Side Effects:: The package system is modified. @subsubheading Affected By:: @i{Accessible} @i{symbols}. @subsubheading Exceptional Situations:: If any of the @i{symbols} is not @i{accessible} at all in @i{package}, an error of @i{type} @b{package-error} is signaled that is @i{correctable} by permitting the @i{user} to interactively specify whether that @i{symbol} should be @i{imported}. @subsubheading See Also:: @ref{import} , @ref{unexport} , @ref{Package Concepts} @node find-symbol, find-package, export, Packages Dictionary @subsection find-symbol [Function] @code{find-symbol} @i{string @r{&optional} package} @result{} @i{symbol, status} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{package}---a @i{package designator}. The default is the @i{current package}. @i{symbol}---a @i{symbol} accessible in the @i{package}, or @b{nil}. @i{status}---one of @t{:inherited}, @t{:external}, @t{:internal}, or @b{nil}. @subsubheading Description:: @b{find-symbol} locates a @i{symbol} whose @i{name} is @i{string} in a @i{package}. If a @i{symbol} named @i{string} is found in @i{package}, directly or by inheritance, the @i{symbol} found is returned as the first value; the second value is as follows: @table @asis @item @t{:internal} If the @i{symbol} is @i{present} in @i{package} as an @i{internal symbol}. @item @t{:external} If the @i{symbol} is @i{present} in @i{package} as an @i{external symbol}. @item @t{:inherited} If the @i{symbol} is inherited by @i{package} through @b{use-package}, but is not @i{present} in @i{package}. @end table If no such @i{symbol} is @i{accessible} in @i{package}, both values are @b{nil}. @subsubheading Examples:: @example (find-symbol "NEVER-BEFORE-USED") @result{} NIL, NIL (find-symbol "NEVER-BEFORE-USED") @result{} NIL, NIL (intern "NEVER-BEFORE-USED") @result{} NEVER-BEFORE-USED, NIL (intern "NEVER-BEFORE-USED") @result{} NEVER-BEFORE-USED, :INTERNAL (find-symbol "NEVER-BEFORE-USED") @result{} NEVER-BEFORE-USED, :INTERNAL (find-symbol "never-before-used") @result{} NIL, NIL (find-symbol "CAR" 'common-lisp-user) @result{} CAR, :INHERITED (find-symbol "CAR" 'common-lisp) @result{} CAR, :EXTERNAL (find-symbol "NIL" 'common-lisp-user) @result{} NIL, :INHERITED (find-symbol "NIL" 'common-lisp) @result{} NIL, :EXTERNAL (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '()) (intern "NIL" "JUST-TESTING"))) @result{} JUST-TESTING::NIL, :INTERNAL (export 'just-testing::nil 'just-testing) (find-symbol "NIL" 'just-testing) @result{} JUST-TESTING:NIL, :EXTERNAL (find-symbol "NIL" "KEYWORD") @result{} NIL, NIL @i{OR}@result{} :NIL, :EXTERNAL (find-symbol (symbol-name :nil) "KEYWORD") @result{} :NIL, :EXTERNAL @end example @subsubheading Affected By:: @b{intern}, @b{import}, @b{export}, @b{use-package}, @b{unintern}, @b{unexport}, @b{unuse-package} @subsubheading See Also:: @ref{intern} , @ref{find-all-symbols} @subsubheading Notes:: @b{find-symbol} is operationally equivalent to @b{intern}, except that it never creates a new @i{symbol}. @node find-package, find-all-symbols, find-symbol, Packages Dictionary @subsection find-package [Function] @code{find-package} @i{name} @result{} @i{package} @subsubheading Arguments and Values:: @i{name}---a @i{string designator} or a @i{package} @i{object}. @i{package}---a @i{package} @i{object} or @b{nil}. @subsubheading Description:: If @i{name} is a @i{string designator}, @b{find-package} locates and returns the @i{package} whose name or nickname is @i{name}. This search is case sensitive. If there is no such @i{package}, @b{find-package} returns @b{nil}. If @i{name} is a @i{package} @i{object}, that @i{package} @i{object} is returned. @subsubheading Examples:: @example (find-package 'common-lisp) @result{} # (find-package "COMMON-LISP-USER") @result{} # (find-package 'not-there) @result{} NIL @end example @subsubheading Affected By:: The set of @i{packages} created by the @i{implementation}. @b{defpackage}, @b{delete-package}, @b{make-package}, @b{rename-package} @subsubheading See Also:: @ref{make-package} @node find-all-symbols, import, find-package, Packages Dictionary @subsection find-all-symbols [Function] @code{find-all-symbols} @i{string} @result{} @i{symbols} @subsubheading Arguments and Values:: @i{string}---a @i{string designator}. @i{symbols}---a @i{list} of @i{symbols}. @subsubheading Description:: @b{find-all-symbols} searches every @i{registered package} for @i{symbols} that have a @i{name} that is the @i{same} (under @b{string=}) as @i{string}. A @i{list} of all such @i{symbols} is returned. Whether or how the @i{list} is ordered is @i{implementation-dependent}. @subsubheading Examples:: @example (find-all-symbols 'car) @result{} (CAR) @i{OR}@result{} (CAR VEHICLES:CAR) @i{OR}@result{} (VEHICLES:CAR CAR) (intern "CAR" (make-package 'temp :use nil)) @result{} TEMP::CAR, NIL (find-all-symbols 'car) @result{} (TEMP::CAR CAR) @i{OR}@result{} (CAR TEMP::CAR) @i{OR}@result{} (TEMP::CAR CAR VEHICLES:CAR) @i{OR}@result{} (CAR TEMP::CAR VEHICLES:CAR) @end example @subsubheading See Also:: @ref{find-symbol} @node import, list-all-packages, find-all-symbols, Packages Dictionary @subsection import [Function] @code{import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{symbols}---a @i{designator} for a @i{list} of @i{symbols}. @i{package}---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{import} adds @i{symbol} or @i{symbols} to the internals of @i{package}, checking for name conflicts with existing @i{symbols} either @i{present} in @i{package} or @i{accessible} to it. Once the @i{symbols} have been @i{imported}, they may be referenced in the @i{importing} @i{package} without the use of a @i{package prefix} when using the @i{Lisp reader}. A name conflict in @b{import} between the @i{symbol} being imported and a symbol inherited from some other @i{package} can be resolved in favor of the @i{symbol} being @i{imported} by making it a shadowing symbol, or in favor of the @i{symbol} already @i{accessible} by not doing the @b{import}. A name conflict in @b{import} with a @i{symbol} already @i{present} in the @i{package} may be resolved by uninterning that @i{symbol}, or by not doing the @b{import}. The imported @i{symbol} is not automatically exported from the @i{current package}, but if it is already @i{present} and external, then the fact that it is external is not changed. If any @i{symbol} to be @i{imported} has no home package (@i{i.e.}, @t{(symbol-package @i{symbol}) @result{} nil}), @b{import} sets the @i{home package} of the @i{symbol} to @i{package}. If the @i{symbol} is already @i{present} in the importing @i{package}, @b{import} has no effect. @subsubheading Examples:: @example (import 'common-lisp::car (make-package 'temp :use nil)) @result{} T (find-symbol "CAR" 'temp) @result{} CAR, :INTERNAL (find-symbol "CDR" 'temp) @result{} NIL, NIL @end example The form @t{(import 'editor:buffer)} takes the external symbol named @t{buffer} in the @t{EDITOR} @i{package} (this symbol was located when the form was read by the @i{Lisp reader}) and adds it to the @i{current package} as an @i{internal symbol}. The symbol @t{buffer} is then @i{present} in the @i{current package}. @subsubheading Side Effects:: The package system is modified. @subsubheading Affected By:: Current state of the package system. @subsubheading Exceptional Situations:: @b{import} signals a @i{correctable} error of @i{type} @b{package-error} if any of the @i{symbols} to be @i{imported} has the @i{same} @i{name} (under @b{string=}) as some distinct @i{symbol} (under @b{eql}) already @i{accessible} in the @i{package}, even if the conflict is with a @i{shadowing symbol} of the @i{package}. @subsubheading See Also:: @ref{shadow} , @ref{export} @node list-all-packages, rename-package, import, Packages Dictionary @subsection list-all-packages [Function] @code{list-all-packages} @i{<@i{no @i{arguments}}>} @result{} @i{packages} @subsubheading Arguments and Values:: @i{packages}---a @i{list} of @i{package} @i{objects}. @subsubheading Description:: @b{list-all-packages} returns a @i{fresh} @i{list} of all @i{registered packages}. @subsubheading Examples:: @example (let ((before (list-all-packages))) (make-package 'temp) (set-difference (list-all-packages) before)) @result{} (#) @end example @subsubheading Affected By:: @b{defpackage}, @b{delete-package}, @b{make-package} @node rename-package, shadow, list-all-packages, Packages Dictionary @subsection rename-package [Function] @code{rename-package} @i{package new-name @r{&optional} new-nicknames} @result{} @i{package-object} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{new-name}---a @i{package designator}. @i{new-nicknames}---a @i{list} of @i{string designators}. The default is the @i{empty list}. @i{package-object}---the renamed @i{package} @i{object}. @subsubheading Description:: Replaces the name and nicknames of @i{package}. The old name and all of the old nicknames of @i{package} are eliminated and are replaced by @i{new-name} and @i{new-nicknames}. The consequences are undefined if @i{new-name} or any @i{new-nickname} conflicts with any existing package names. @subsubheading Examples:: @example (make-package 'temporary :nicknames '("TEMP")) @result{} # (rename-package 'temp 'ephemeral) @result{} # (package-nicknames (find-package 'ephemeral)) @result{} () (find-package 'temporary) @result{} NIL (rename-package 'ephemeral 'temporary '(temp fleeting)) @result{} # (package-nicknames (find-package 'temp)) @result{} ("TEMP" "FLEETING") @end example @subsubheading See Also:: @ref{make-package} @node shadow, shadowing-import, rename-package, Packages Dictionary @subsection shadow [Function] @code{shadow} @i{symbol-names @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{symbol-names}---a @i{designator} for a @i{list} of @i{string designators}. @i{package}---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{shadow} assures that @i{symbols} with names given by @i{symbol-names} are @i{present} in the @i{package}. Specifically, @i{package} is searched for @i{symbols} with the @i{names} supplied by @i{symbol-names}. For each such @i{name}, if a corresponding @i{symbol} is not @i{present} in @i{package} (directly, not by inheritance), then a corresponding @i{symbol} is created with that @i{name}, and inserted into @i{package} as an @i{internal symbol}. The corresponding @i{symbol}, whether pre-existing or newly created, is then added, if not already present, to the @i{shadowing symbols list} of @i{package}. @subsubheading Examples:: @example (package-shadowing-symbols (make-package 'temp)) @result{} NIL (find-symbol 'car 'temp) @result{} CAR, :INHERITED (shadow 'car 'temp) @result{} T (find-symbol 'car 'temp) @result{} TEMP::CAR, :INTERNAL (package-shadowing-symbols 'temp) @result{} (TEMP::CAR) @end example @example (make-package 'test-1) @result{} # (intern "TEST" (find-package 'test-1)) @result{} TEST-1::TEST, NIL (shadow 'test-1::test (find-package 'test-1)) @result{} T (shadow 'TEST (find-package 'test-1)) @result{} T (assert (not (null (member 'test-1::test (package-shadowing-symbols (find-package 'test-1)))))) (make-package 'test-2) @result{} # (intern "TEST" (find-package 'test-2)) @result{} TEST-2::TEST, NIL (export 'test-2::test (find-package 'test-2)) @result{} T (use-package 'test-2 (find-package 'test-1)) ;should not error @end example @subsubheading Side Effects:: @b{shadow} changes the state of the package system in such a way that the package consistency rules do not hold across the change. @subsubheading Affected By:: Current state of the package system. @subsubheading See Also:: @ref{package-shadowing-symbols} , @ref{Package Concepts} @subsubheading Notes:: If a @i{symbol} with a name in @i{symbol-names} already exists in @i{package}, but by inheritance, the inherited symbol becomes @i{shadowed}_3 by a newly created @i{internal symbol}. @node shadowing-import, delete-package, shadow, Packages Dictionary @subsection shadowing-import [Function] @code{shadowing-import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{symbols}---a @i{designator} for a @i{list} of @i{symbols}. @i{package} ---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{shadowing-import} is like @b{import}, but it does not signal an error even if the importation of a @i{symbol} would shadow some @i{symbol} already @i{accessible} in @i{package}. @b{shadowing-import} inserts each of @i{symbols} into @i{package} as an internal symbol, regardless of whether another @i{symbol} of the same name is shadowed by this action. If a different @i{symbol} of the same name is already @i{present} in @i{package}, that @i{symbol} is first @i{uninterned} from @i{package}. The new @i{symbol} is added to @i{package}'s shadowing-symbols list. @b{shadowing-import} does name-conflict checking to the extent that it checks whether a distinct existing @i{symbol} with the same name is @i{accessible}; if so, it is shadowed by the new @i{symbol}, which implies that it must be uninterned if it was @i{present} in @i{package}. @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (setq sym (intern "CONFLICT")) @result{} CONFLICT (intern "CONFLICT" (make-package 'temp)) @result{} TEMP::CONFLICT, NIL (package-shadowing-symbols 'temp) @result{} NIL (shadowing-import sym 'temp) @result{} T (package-shadowing-symbols 'temp) @result{} (CONFLICT) @end example @subsubheading Side Effects:: @b{shadowing-import} changes the state of the package system in such a way that the consistency rules do not hold across the change. @i{package}'s shadowing-symbols list is modified. @subsubheading Affected By:: Current state of the package system. @subsubheading See Also:: @ref{import} , @ref{unintern} , @ref{package-shadowing-symbols} @node delete-package, make-package, shadowing-import, Packages Dictionary @subsection delete-package [Function] @code{delete-package} @i{package} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{delete-package} deletes @i{package} from all package system data structures. If the operation is successful, @b{delete-package} returns true, otherwise @b{nil}. The effect of @b{delete-package} is that the name and nicknames of @i{package} cease to be recognized package names. The package @i{object} is still a @i{package} (@i{i.e.}, @b{packagep} is @i{true} of it) but @b{package-name} returns @b{nil}. The consequences of deleting the @t{COMMON-LISP} @i{package} or the @t{KEYWORD} @i{package} are undefined. The consequences of invoking any other package operation on @i{package} once it has been deleted are unspecified. In particular, the consequences of invoking @b{find-symbol}, @b{intern} and other functions that look for a symbol name in a @i{package} are unspecified if they are called with @b{*package*} bound to the deleted @i{package} or with the deleted @i{package} as an argument. If @i{package} is a @i{package} @i{object} that has already been deleted, @b{delete-package} immediately returns @b{nil}. After this operation completes, the @i{home package} of any @i{symbol} whose @i{home package} had previously been @i{package} is @i{implementation-dependent}. Except for this, @i{symbols} @i{accessible} in @i{package} are not modified in any other way; @i{symbols} whose @i{home package} is not @i{package} remain unchanged. @subsubheading Examples:: @example (setq *foo-package* (make-package "FOO" :use nil)) (setq *foo-symbol* (intern "FOO" *foo-package*)) (export *foo-symbol* *foo-package*) (setq *bar-package* (make-package "BAR" :use '("FOO"))) (setq *bar-symbol* (intern "BAR" *bar-package*)) (export *foo-symbol* *bar-package*) (export *bar-symbol* *bar-package*) (setq *baz-package* (make-package "BAZ" :use '("BAR"))) (symbol-package *foo-symbol*) @result{} # (symbol-package *bar-symbol*) @result{} # (prin1-to-string *foo-symbol*) @result{} "FOO:FOO" (prin1-to-string *bar-symbol*) @result{} "BAR:BAR" (find-symbol "FOO" *bar-package*) @result{} FOO:FOO, :EXTERNAL (find-symbol "FOO" *baz-package*) @result{} FOO:FOO, :INHERITED (find-symbol "BAR" *baz-package*) @result{} BAR:BAR, :INHERITED (packagep *foo-package*) @result{} @i{true} (packagep *bar-package*) @result{} @i{true} (packagep *baz-package*) @result{} @i{true} (package-name *foo-package*) @result{} "FOO" (package-name *bar-package*) @result{} "BAR" (package-name *baz-package*) @result{} "BAZ" (package-use-list *foo-package*) @result{} () (package-use-list *bar-package*) @result{} (#) (package-use-list *baz-package*) @result{} (#) (package-used-by-list *foo-package*) @result{} (#) (package-used-by-list *bar-package*) @result{} (#) (package-used-by-list *baz-package*) @result{} () (delete-package *bar-package*) @t{ |> } Error: Package BAZ uses package BAR. @t{ |> } If continued, BAZ will be made to unuse-package BAR, @t{ |> } and then BAR will be deleted. @t{ |> } Type :CONTINUE to continue. @t{ |> } Debug> @b{|>>}@t{:CONTINUE}@b{<<|} @result{} T (symbol-package *foo-symbol*) @result{} # (symbol-package *bar-symbol*) is unspecified (prin1-to-string *foo-symbol*) @result{} "FOO:FOO" (prin1-to-string *bar-symbol*) is unspecified (find-symbol "FOO" *bar-package*) is unspecified (find-symbol "FOO" *baz-package*) @result{} NIL, NIL (find-symbol "BAR" *baz-package*) @result{} NIL, NIL (packagep *foo-package*) @result{} T (packagep *bar-package*) @result{} T (packagep *baz-package*) @result{} T (package-name *foo-package*) @result{} "FOO" (package-name *bar-package*) @result{} NIL (package-name *baz-package*) @result{} "BAZ" (package-use-list *foo-package*) @result{} () (package-use-list *bar-package*) is unspecified (package-use-list *baz-package*) @result{} () (package-used-by-list *foo-package*) @result{} () (package-used-by-list *bar-package*) is unspecified (package-used-by-list *baz-package*) @result{} () @end example @subsubheading Exceptional Situations:: If the @i{package} @i{designator} is a @i{name} that does not currently name a @i{package}, a @i{correctable} error of @i{type} @b{package-error} is signaled. If correction is attempted, no deletion action is attempted; instead, @b{delete-package} immediately returns @b{nil}. If @i{package} is used by other @i{packages}, a @i{correctable} error of @i{type} @b{package-error} is signaled. If correction is attempted, @b{unuse-package} is effectively called to remove any dependencies, causing @i{package}'s @i{external symbols} to cease being @i{accessible} to those @i{packages} that use @i{package}. @b{delete-package} then deletes @i{package} just as it would have had there been no @i{packages} that used it. @subsubheading See Also:: @ref{unuse-package} @node make-package, with-package-iterator, delete-package, Packages Dictionary @subsection make-package [Function] @code{make-package} @i{package-name @r{&key} nicknames use} @result{} @i{package} @subsubheading Arguments and Values:: @i{package-name}---a @i{string designator}. @i{nicknames}---a @i{list} of @i{string designators}. The default is the @i{empty list}. @i{use}--- a @i{list} of @i{package designators}. The default is @i{implementation-defined}. @i{package}---a @i{package}. @subsubheading Description:: Creates a new @i{package} with the name @i{package-name}. @i{Nicknames} are additional @i{names} which may be used to refer to the new @i{package}. @i{use} specifies zero or more @i{packages} the @i{external symbols} of which are to be inherited by the new @i{package}. See the @i{function} @b{use-package}. @subsubheading Examples:: @example (make-package 'temporary :nicknames '("TEMP" "temp")) @result{} # (make-package "OWNER" :use '("temp")) @result{} # (package-used-by-list 'temp) @result{} (#) (package-use-list 'owner) @result{} (#) @end example @subsubheading Affected By:: The existence of other @i{packages} in the system. @subsubheading Exceptional Situations:: The consequences are unspecified if @i{packages} denoted by @i{use} do not exist. A @i{correctable} error is signaled if the @i{package-name} or any of the @i{nicknames} is already the @i{name} or @i{nickname} of an existing @i{package}. @subsubheading See Also:: @ref{defpackage} , @ref{use-package} @subsubheading Notes:: In situations where the @i{packages} to be used contain symbols which would conflict, it is necessary to first create the package with @t{:use '()}, then to use @b{shadow} or @b{shadowing-import} to address the conflicts, and then after that to use @b{use-package} once the conflicts have been addressed. When packages are being created as part of the static definition of a program rather than dynamically by the program, it is generally considered more stylistically appropriate to use @b{defpackage} rather than @b{make-package}. @node with-package-iterator, unexport, make-package, Packages Dictionary @subsection with-package-iterator [Macro] @code{with-package-iterator} @i{@r{(}name package-list-form @r{&rest} @r{symbol-types}@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{package-list-form}---a @i{form}; evaluated once to produce a @i{package-list}. @i{package-list}---a @i{designator} for a list of @i{package designators}. @i{symbol-type}---one of the @i{symbols} @t{:internal}, @t{:external}, or @t{:inherited}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms}. @subsubheading Description:: Within the lexical scope of the body @i{forms}, the @i{name} is defined via @b{macrolet} such that successive invocations of @t{(@i{name})} will return the @i{symbols}, one by one, from the @i{packages} in @i{package-list}. It is unspecified whether @i{symbols} inherited from multiple @i{packages} are returned more than once. The order of @i{symbols} returned does not necessarily reflect the order of @i{packages} in @i{package-list}. When @i{package-list} has more than one element, it is unspecified whether duplicate @i{symbols} are returned once or more than once. @i{Symbol-types} controls which @i{symbols} that are @i{accessible} in a @i{package} are returned as follows: @table @asis @item @t{:internal} The @i{symbols} that are @i{present} in the @i{package}, but that are not @i{exported}. @item @t{:external} The @i{symbols} that are @i{present} in the @i{package} and are @i{exported}. @item @t{:inherited} The @i{symbols} that are @i{exported} by used @i{packages} and that are not @i{shadowed}. @end table When more than one argument is supplied for @i{symbol-types}, a @i{symbol} is returned if its @i{accessibility} matches any one of the @i{symbol-types} supplied. Implementations may extend this syntax by recognizing additional symbol accessibility types. An invocation of @t{(@i{name})} returns four values as follows: @table @asis @item 1. A flag that indicates whether a @i{symbol} is returned (true means that a @i{symbol} is returned). @item 2. A @i{symbol} that is @i{accessible} in one the indicated @i{packages}. @item 3. The accessibility type for that @i{symbol}; @i{i.e.}, one of the symbols @t{:internal}, @t{:external}, or @t{:inherited}. @item 4. The @i{package} from which the @i{symbol} was obtained. The @i{package} is one of the @i{packages} present or named in @i{package-list}. @end table After all @i{symbols} have been returned by successive invocations of @t{(@i{name})}, then only one value is returned, namely @b{nil}. The meaning of the second, third, and fourth @i{values} is that the returned @i{symbol} is @i{accessible} in the returned @i{package} in the way indicated by the second return value as follows: @table @asis @item @t{:internal} Means @i{present} and not @i{exported}. @item @t{:external} Means @i{present} and @i{exported}. @item @t{:inherited} Means not @i{present} (thus not @i{shadowed}) but inherited from some used @i{package}. @end table It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the @b{with-package-iterator} form such as by returning some @i{closure} over the invocation @i{form}. Any number of invocations of @b{with-package-iterator} can be nested, and the body of the innermost one can invoke all of the locally @i{established} @i{macros}, provided all those @i{macros} have distinct names. @subsubheading Examples:: The following function should return @b{t} on any @i{package}, and signal an error if the usage of @b{with-package-iterator} does not agree with the corresponding usage of @b{do-symbols}. @example (defun test-package-iterator (package) (unless (packagep package) (setq package (find-package package))) (let ((all-entries '()) (generated-entries '())) (do-symbols (x package) (multiple-value-bind (symbol accessibility) (find-symbol (symbol-name x) package) (push (list symbol accessibility) all-entries))) (with-package-iterator (generator-fn package :internal :external :inherited) (loop (multiple-value-bind (more? symbol accessibility pkg) (generator-fn) (unless more? (return)) (let ((l (multiple-value-list (find-symbol (symbol-name symbol) package)))) (unless (equal l (list symbol accessibility)) (error "Symbol ~S not found as ~S in package ~A [~S]" symbol accessibility (package-name package) l)) (push l generated-entries))))) (unless (and (subsetp all-entries generated-entries :test #'equal) (subsetp generated-entries all-entries :test #'equal)) (error "Generated entries and Do-Symbols entries don't correspond")) t)) @end example The following function prints out every @i{present} @i{symbol} (possibly more than once): @example (defun print-all-symbols () (with-package-iterator (next-symbol (list-all-packages) :internal :external) (loop (multiple-value-bind (more? symbol) (next-symbol) (if more? (print symbol) (return)))))) @end example @subsubheading Exceptional Situations:: @b{with-package-iterator} signals an error of @i{type} @b{program-error} if no @i{symbol-types} are supplied or if a @i{symbol-type} is not recognized by the implementation is supplied. The consequences are undefined if the local function named @i{name} @i{established} by @b{with-package-iterator} is called after it has returned @i{false} as its @i{primary value}. @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @node unexport, unintern, with-package-iterator, Packages Dictionary @subsection unexport [Function] @code{unexport} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{symbols}---a @i{designator} for a @i{list} of @i{symbols}. @i{package}---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{unexport} reverts external @i{symbols} in @i{package} to internal status; it undoes the effect of @b{export}. @b{unexport} works only on @i{symbols} @i{present} in @i{package}, switching them back to internal status. If @b{unexport} is given a @i{symbol} that is already @i{accessible} as an @i{internal symbol} in @i{package}, it does nothing. @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (export (intern "CONTRABAND" (make-package 'temp)) 'temp) @result{} T (find-symbol "CONTRABAND") @result{} NIL, NIL (use-package 'temp) @result{} T (find-symbol "CONTRABAND") @result{} CONTRABAND, :INHERITED (unexport 'contraband 'temp) @result{} T (find-symbol "CONTRABAND") @result{} NIL, NIL @end example @subsubheading Side Effects:: Package system is modified. @subsubheading Affected By:: Current state of the package system. @subsubheading Exceptional Situations:: If @b{unexport} is given a @i{symbol} not @i{accessible} in @i{package} at all, an error of @i{type} @b{package-error} is signaled. The consequences are undefined if @i{package} is the @t{KEYWORD} @i{package} or the @t{COMMON-LISP} @i{package}. @subsubheading See Also:: @ref{export} , @ref{Package Concepts} @node unintern, in-package, unexport, Packages Dictionary @subsection unintern [Function] @code{unintern} @i{symbol @r{&optional} package} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{package}---a @i{package designator}. The default is the @i{current package}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{unintern} removes @i{symbol} from @i{package}. If @i{symbol} is @i{present} in @i{package}, it is removed from @i{package} and also from @i{package}'s @i{shadowing symbols list} if it is present there. If @i{package} is the @i{home package} for @i{symbol}, @i{symbol} is made to have no @i{home package}. @i{Symbol} may continue to be @i{accessible} in @i{package} by inheritance. Use of @b{unintern} can result in a @i{symbol} that has no recorded @i{home package}, but that in fact is @i{accessible} in some @i{package}. @r{Common Lisp} does not check for this pathological case, and such @i{symbols} are always printed preceded by @t{#:}. @b{unintern} returns @i{true} if it removes @i{symbol}, and @b{nil} otherwise. @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (setq temps-unpack (intern "UNPACK" (make-package 'temp))) @result{} TEMP::UNPACK (unintern temps-unpack 'temp) @result{} T (find-symbol "UNPACK" 'temp) @result{} NIL, NIL temps-unpack @result{} #:UNPACK @end example @subsubheading Side Effects:: @b{unintern} changes the state of the package system in such a way that the consistency rules do not hold across the change. @subsubheading Affected By:: Current state of the package system. @subsubheading Exceptional Situations:: Giving a shadowing symbol to @b{unintern} can uncover a name conflict that had previously been resolved by the shadowing. If package A uses packages B and C, A contains a shadowing symbol @t{x}, and B and C each contain external symbols named @t{x}, then removing the shadowing symbol @t{x} from A will reveal a name conflict between @t{b:x} and @t{c:x} if those two @i{symbols} are distinct. In this case @b{unintern} will signal an error. @subsubheading See Also:: @ref{Package Concepts} @node in-package, unuse-package, unintern, Packages Dictionary @subsection in-package [Macro] @code{in-package} @i{name} @result{} @i{package} @subsubheading Arguments and Values:: @i{name}---a @i{string designator}; not evaluated. @i{package}---the @i{package} named by @i{name}. @subsubheading Description:: Causes the the @i{package} named by @i{name} to become the @i{current package}---that is, the @i{value} of @b{*package*}. If no such @i{package} already exists, an error of @i{type} @b{package-error} is signaled. Everything @b{in-package} does is also performed at compile time if the call appears as a @i{top level form}. @subsubheading Side Effects:: The @i{variable} @b{*package*} is assigned. If the @b{in-package} @i{form} is a @i{top level form}, this assignment also occurs at compile time. @subsubheading Exceptional Situations:: An error of @i{type} @b{package-error} is signaled if the specified @i{package} does not exist. @subsubheading See Also:: @ref{package} @node unuse-package, use-package, in-package, Packages Dictionary @subsection unuse-package [Function] @code{unuse-package} @i{packages-to-unuse @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{packages-to-unuse}---a @i{designator} for a @i{list} of @i{package designators}. @i{package}---a @i{package designator}. The default is the @i{current package}. @subsubheading Description:: @b{unuse-package} causes @i{package} to cease inheriting all the @i{external symbols} of @i{packages-to-unuse}; @b{unuse-package} undoes the effects of @b{use-package}. The @i{packages-to-unuse} are removed from the @i{use list} of @i{package}. Any @i{symbols} that have been @i{imported} into @i{package} continue to be @i{present} in @i{package}. @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (export (intern "SHOES" (make-package 'temp)) 'temp) @result{} T (find-symbol "SHOES") @result{} NIL, NIL (use-package 'temp) @result{} T (find-symbol "SHOES") @result{} SHOES, :INHERITED (find (find-package 'temp) (package-use-list 'common-lisp-user)) @result{} # (unuse-package 'temp) @result{} T (find-symbol "SHOES") @result{} NIL, NIL @end example @subsubheading Side Effects:: The @i{use list} of @i{package} is modified. @subsubheading Affected By:: Current state of the package system. @subsubheading See Also:: @ref{use-package} , @ref{package-use-list} @node use-package, defpackage, unuse-package, Packages Dictionary @subsection use-package [Function] @code{use-package} @i{packages-to-use @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{packages-to-use}---a @i{designator} for a @i{list} of @i{package designators}. The @t{KEYWORD} @i{package} may not be supplied. @i{package}---a @i{package designator}. The @t{KEYWORD} @i{package} cannot be supplied. The default is the @i{current package}. @subsubheading Description:: @b{use-package} causes @i{package} to inherit all the @i{external symbols} of @i{packages-to-use}. The inherited @i{symbols} become @i{accessible} as @i{internal symbols} of @i{package}. @i{Packages-to-use} are added to the @i{use list} of @i{package} if they are not there already. All @i{external symbols} in @i{packages-to-use} become @i{accessible} in @i{package} as @i{internal symbols}. @b{use-package} does not cause any new @i{symbols} to be @i{present} in @i{package} but only makes them @i{accessible} by inheritance. @b{use-package} checks for name conflicts between the newly imported symbols and those already @i{accessible} in @i{package}. A name conflict in @b{use-package} between two external symbols inherited by @i{package} from @i{packages-to-use} may be resolved in favor of either @i{symbol} by @i{importing} one of them into @i{package} and making it a shadowing symbol. @subsubheading Examples:: @example (export (intern "LAND-FILL" (make-package 'trash)) 'trash) @result{} T (find-symbol "LAND-FILL" (make-package 'temp)) @result{} NIL, NIL (package-use-list 'temp) @result{} (#) (use-package 'trash 'temp) @result{} T (package-use-list 'temp) @result{} (# #) (find-symbol "LAND-FILL" 'temp) @result{} TRASH:LAND-FILL, :INHERITED @end example @subsubheading Side Effects:: The @i{use list} of @i{package} may be modified. @subsubheading See Also:: @ref{unuse-package} , @ref{package-use-list} , @ref{Package Concepts} @subsubheading Notes:: It is permissible for a @i{package} P_1 to @i{use} a @i{package} P_2 even if P_2 already uses P_1. The using of @i{packages} is not transitive, so no problem results from the apparent circularity. @node defpackage, do-symbols, use-package, Packages Dictionary @subsection defpackage [Macro] @code{defpackage} @i{defined-package-name [[!@i{option}]]} @result{} @i{package} @w{@i{option} ::=@{@r{(}@t{:nicknames} @{@i{nickname}@}*@r{)}@}* | } @w{ @r{(}@t{:documentation} @i{string}@r{)} | } @w{ @{@r{(}@t{:use} @{@i{package-name}@}*@r{)}@}* | } @w{ @{@r{(}@t{:shadow} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @{@r{(}@t{:shadowing-import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @{@r{(}@t{:import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @{@r{(}@t{:export} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @{@r{(}@t{:intern} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @r{(}@t{:size} @i{integer}@r{)}} @w{@i{symbol-name} ::=(@i{symbol} | @i{string})} @subsubheading Arguments and Values:: @i{defined-package-name}---a @i{string designator}. @i{package-name}---a @i{package designator}. @i{nickname}---a @i{string designator}. @i{symbol-name}---a @i{string designator}. @i{package}---the @i{package} named @i{package-name}. @subsubheading Description:: @b{defpackage} creates a @i{package} as specified and returns the @i{package}. If @i{defined-package-name} already refers to an existing @i{package}, the name-to-package mapping for that name is not changed. If the new definition is at variance with the current state of that @i{package}, the consequences are undefined; an implementation might choose to modify the existing @i{package} to reflect the new definition. If @i{defined-package-name} is a @i{symbol}, its @i{name} is used. The standard @i{options} are described below. @table @asis @item @t{:nicknames} The arguments to @t{:nicknames} set the @i{package}'s nicknames to the supplied names. @item @t{:documentation} The argument to @t{:documentation} specifies a @i{documentation string}; it is attached as a @i{documentation string} to the @i{package}. At most one @t{:documentation} option can appear in a single @b{defpackage} @i{form}. @item @t{:use} The arguments to @t{:use} set the @i{packages} that the @i{package} named by @i{package-name} will inherit from. If @t{:use} is not supplied, it defaults to the same @i{implementation-dependent} value as the @t{:use} @i{argument} to @b{make-package}. @item @t{:shadow} The arguments to @t{:shadow}, @i{symbol-names}, name @i{symbols} that are to be created in the @i{package} being defined. These @i{symbols} are added to the list of shadowing @i{symbols} effectively as if by @b{shadow}. @item @t{:shadowing-import-from} The @i{symbols} named by the argument @i{symbol-names} are found (involving a lookup as if by @b{find-symbol}) in the specified @i{package-name}. The resulting @i{symbols} are @i{imported} into the @i{package} being defined, and placed on the shadowing symbols list as if by @b{shadowing-import}. In no case are @i{symbols} created in any @i{package} other than the one being defined. @item @t{:import-from} The @i{symbols} named by the argument @i{symbol-names} are found in the @i{package} named by @i{package-name} and they are @i{imported} into the @i{package} being defined. In no case are @i{symbols} created in any @i{package} other than the one being defined. @item @t{:export} The @i{symbols} named by the argument @i{symbol-names} are found or created in the @i{package} being defined and @i{exported}. The @t{:export} option interacts with the @t{:use} option, since inherited @i{symbols} can be used rather than new ones created. The @t{:export} option interacts with the @t{:import-from} and @t{:shadowing-import-from} options, since @i{imported} symbols can be used rather than new ones created. If an argument to the @t{:export} option is @i{accessible} as an (inherited) @i{internal symbol} via @b{use-package}, that the @i{symbol} named by @i{symbol-name} is first @i{imported} into the @i{package} being defined, and is then @i{exported} from that @i{package}. @item @t{:intern} The @i{symbols} named by the argument @i{symbol-names} are found or created in the @i{package} being defined. The @t{:intern} option interacts with the @t{:use} option, since inherited @i{symbols} can be used rather than new ones created. @item @t{:size} The argument to the @t{:size} option declares the approximate number of @i{symbols} expected in the @i{package}. This is an efficiency hint only and might be ignored by an implementation. @end table The order in which the options appear in a @b{defpackage} form is irrelevant. The order in which they are executed is as follows: @table @asis @item 1. @t{:shadow} and @t{:shadowing-import-from}. @item 2. @t{:use}. @item 3. @t{:import-from} and @t{:intern}. @item 4. @t{:export}. @end table Shadows are established first, since they might be necessary to block spurious name conflicts when the @t{:use} option is processed. The @t{:use} option is executed next so that @t{:intern} and @t{:export} options can refer to normally inherited @i{symbols}. The @t{:export} option is executed last so that it can refer to @i{symbols} created by any of the other options; in particular, @i{shadowing symbols} and @i{imported} @i{symbols} can be made external. If a @i{defpackage} @i{form} appears as a @i{top level form}, all of the actions normally performed by this @i{macro} at load time must also be performed at compile time. @subsubheading Examples:: @example (defpackage "MY-PACKAGE" (:nicknames "MYPKG" "MY-PKG") (:use "COMMON-LISP") (:shadow "CAR" "CDR") (:shadowing-import-from "VENDOR-COMMON-LISP" "CONS") (:import-from "VENDOR-COMMON-LISP" "GC") (:export "EQ" "CONS" "FROBOLA") ) (defpackage my-package (:nicknames mypkg :MY-PKG) ; remember Common Lisp conventions for case (:use common-lisp) ; conversion on symbols (:shadow CAR :cdr #:cons) (:export "CONS") ; this is the shadowed one. ) @end example @subsubheading Affected By:: Existing @i{packages}. @subsubheading Exceptional Situations:: If one of the supplied @t{:nicknames} already refers to an existing @i{package}, an error of @i{type} @b{package-error} is signaled. An error of @i{type} @b{program-error} should be signaled if @t{:size} or @t{:documentation} appears more than once. Since @i{implementations} might allow extended @i{options} an error of @i{type} @b{program-error} should be signaled if an @i{option} is present that is not actually supported in the host @i{implementation}. The collection of @i{symbol-name} arguments given to the options @t{:shadow}, @t{:intern}, @t{:import-from}, and @t{:shadowing-import-from} must all be disjoint; additionally, the @i{symbol-name} arguments given to @t{:export} and @t{:intern} must be disjoint. Disjoint in this context is defined as no two of the @i{symbol-names} being @b{string=} with each other. If either condition is violated, an error of @i{type} @b{program-error} should be signaled. For the @t{:shadowing-import-from} and @t{:import-from} options, a @i{correctable} @i{error} of @i{type} @b{package-error} is signaled if no @i{symbol} is @i{accessible} in the @i{package} named by @i{package-name} for one of the argument @i{symbol-names}. Name conflict errors are handled by the underlying calls to @b{make-package}, @b{use-package}, @b{import}, and @b{export}. See @ref{Package Concepts}. @subsubheading See Also:: @ref{documentation} , @ref{Package Concepts}, @ref{Compilation} @subsubheading Notes:: The @t{:intern} option is useful if an @t{:import-from} or a @t{:shadowing-import-from} option in a subsequent call to @b{defpackage} (for some other @i{package}) expects to find these @i{symbols} @i{accessible} but not necessarily external. It is recommended that the entire @i{package} definition is put in a single place, and that all the @i{package} definitions of a program are in a single file. This file can be @i{loaded} before @i{loading} or compiling anything else that depends on those @i{packages}. Such a file can be read in the @t{COMMON-LISP-USER} @i{package}, avoiding any initial state issues. @b{defpackage} cannot be used to create two ``mutually recursive'' packages, such as: @example (defpackage my-package (:use common-lisp your-package) ;requires your-package to exist first (:export "MY-FUN")) (defpackage your-package (:use common-lisp) (:import-from my-package "MY-FUN") ;requires my-package to exist first (:export "MY-FUN")) @end example However, nothing prevents the user from using the @i{package}-affecting functions such as @b{use-package}, @b{import}, and @b{export} to establish such links after a more standard use of @b{defpackage}. The macroexpansion of @b{defpackage} could usefully canonicalize the names into @i{strings}, so that even if a source file has random @i{symbols} in the @b{defpackage} form, the compiled file would only contain @i{strings}. Frequently additional @i{implementation-dependent} options take the form of a @i{keyword} standing by itself as an abbreviation for a list @t{(keyword T)}; this syntax should be properly reported as an unrecognized option in implementations that do not support it. @node do-symbols, intern, defpackage, Packages Dictionary @subsection do-symbols, do-external-symbols, do-all-symbols [Macro] @code{do-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @code{do-external-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @code{do-all-symbols} @i{@r{(}var @r{[}result-form@r{]}@r{)} @{@i{declaration}@}* @{tag | statement@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{variable} @i{name}; not evaluated. @i{package}---a @i{package designator}; evaluated. The default in @b{do-symbols} and @b{do-external-symbols} is the @i{current package}. @i{result-form}---a @i{form}; evaluated as described below. The default is @b{nil}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @i{results}---the @i{values} returned by the @i{result-form} if a @i{normal return} occurs, or else, if an @i{explicit return} occurs, the @i{values} that were transferred. @subsubheading Description:: @b{do-symbols}, @b{do-external-symbols}, and @b{do-all-symbols} iterate over the @i{symbols} of @i{packages}. For each @i{symbol} in the set of @i{packages} chosen, the @i{var} is bound to the @i{symbol}, and the @i{statements} in the body are executed. When all the @i{symbols} have been processed, @i{result-form} is evaluated and returned as the value of the macro. @b{do-symbols} iterates over the @i{symbols} @i{accessible} in @i{package}. @i{Statements} may execute more than once for @i{symbols} that are inherited from multiple @i{packages}. @b{do-all-symbols} iterates on every @i{registered package}. @b{do-all-symbols} will not process every @i{symbol} whatsoever, because a @i{symbol} not @i{accessible} in any @i{registered package} will not be processed. @b{do-all-symbols} may cause a @i{symbol} that is @i{present} in several @i{packages} to be processed more than once. @b{do-external-symbols} iterates on the external symbols of @i{package}. When @i{result-form} is evaluated, @i{var} is bound and has the value @b{nil}. An @i{implicit block} named @b{nil} surrounds the entire @b{do-symbols}, @b{do-external-symbols}, or @b{do-all-symbols} @i{form}. @b{return} or @b{return-from} may be used to terminate the iteration prematurely. If execution of the body affects which @i{symbols} are contained in the set of @i{packages} over which iteration is occurring, other than to remove the @i{symbol} currently the value of @i{var} by using @b{unintern}, the consequences are undefined. For each of these macros, the @i{scope} of the name binding does not include any initial value form, but the optional result forms are included. Any @i{tag} in the body is treated as with @b{tagbody}. @subsubheading Examples:: @example (make-package 'temp :use nil) @result{} # (intern "SHY" 'temp) @result{} TEMP::SHY, NIL ;SHY will be an internal symbol ;in the package TEMP (export (intern "BOLD" 'temp) 'temp) @result{} T ;BOLD will be external (let ((lst ())) (do-symbols (s (find-package 'temp)) (push s lst)) lst) @result{} (TEMP::SHY TEMP:BOLD) @i{OR}@result{} (TEMP:BOLD TEMP::SHY) (let ((lst ())) (do-external-symbols (s (find-package 'temp) lst) (push s lst)) lst) @result{} (TEMP:BOLD) (let ((lst ())) (do-all-symbols (s lst) (when (eq (find-package 'temp) (symbol-package s)) (push s lst))) lst) @result{} (TEMP::SHY TEMP:BOLD) @i{OR}@result{} (TEMP:BOLD TEMP::SHY) @end example @subsubheading See Also:: @ref{intern} , @ref{export} , @ref{Traversal Rules and Side Effects} @node intern, package-name, do-symbols, Packages Dictionary @subsection intern [Function] @code{intern} @i{string @r{&optional} package} @result{} @i{symbol, status} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{package}---a @i{package designator}. The default is the @i{current package}. @i{symbol}---a @i{symbol}. @i{status}---one of @t{:inherited}, @t{:external}, @t{:internal}, or @b{nil}. @subsubheading Description:: @b{intern} enters a @i{symbol} named @i{string} into @i{package}. If a @i{symbol} whose name is the same as @i{string} is already @i{accessible} in @i{package}, it is returned. If no such @i{symbol} is @i{accessible} in @i{package}, a new @i{symbol} with the given name is created and entered into @i{package} as an @i{internal symbol}, or as an @i{external symbol} if the @i{package} is the @t{KEYWORD} @i{package}; @i{package} becomes the @i{home package} of the created @i{symbol}. The first value returned by @b{intern}, @i{symbol}, is the @i{symbol} that was found or created. The meaning of the @i{secondary value}, @i{status}, is as follows: @table @asis @item @t{:internal} The @i{symbol} was found and is @i{present} in @i{package} as an @i{internal symbol}. @item @t{:external} The @i{symbol} was found and is @i{present} as an @i{external symbol}. @item @t{:inherited} The @i{symbol} was found and is inherited via @b{use-package} (which implies that the @i{symbol} is internal). @item @b{nil} No pre-existing @i{symbol} was found, so one was created. It is @i{implementation-dependent} whether the @i{string} that becomes the new @i{symbol}'s @i{name} is the given @i{string} or a copy of it. Once a @i{string} has been given as the @i{string} @i{argument} to @i{intern} in this situation where a new @i{symbol} is created, the consequences are undefined if a subsequent attempt is made to alter that @i{string}. @end table @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (intern "Never-Before") @result{} |Never-Before|, NIL (intern "Never-Before") @result{} |Never-Before|, :INTERNAL (intern "NEVER-BEFORE" "KEYWORD") @result{} :NEVER-BEFORE, NIL (intern "NEVER-BEFORE" "KEYWORD") @result{} :NEVER-BEFORE, :EXTERNAL @end example @subsubheading See Also:: @ref{find-symbol} , @ref{read} , @b{symbol}, @ref{unintern} , @ref{Symbols as Tokens} @subsubheading Notes:: @b{intern} does not need to do any name conflict checking because it never creates a new @i{symbol} if there is already an @i{accessible} @i{symbol} with the name given. @node package-name, package-nicknames, intern, Packages Dictionary @subsection package-name [Function] @code{package-name} @i{package} @result{} @i{name} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{name}---a @i{string} or @b{nil}. @subsubheading Description:: @b{package-name} returns the @i{string} that names @i{package}, or @b{nil} if the @i{package} @i{designator} is a @i{package} @i{object} that has no name (see the @i{function} @b{delete-package}). @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # (package-name *package*) @result{} "COMMON-LISP-USER" (package-name (symbol-package :test)) @result{} "KEYWORD" (package-name (find-package 'common-lisp)) @result{} "COMMON-LISP" @end example @example (defvar *foo-package* (make-package "FOO")) (rename-package "FOO" "FOO0") (package-name *foo-package*) @result{} "FOO0" @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package designator}. @node package-nicknames, package-shadowing-symbols, package-name, Packages Dictionary @subsection package-nicknames [Function] @code{package-nicknames} @i{package} @result{} @i{nicknames} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{nicknames}---a @i{list} of @i{strings}. @subsubheading Description:: Returns the @i{list} of nickname @i{strings} for @i{package}, not including the name of @i{package}. @subsubheading Examples:: @example (package-nicknames (make-package 'temporary :nicknames '("TEMP" "temp"))) @result{} ("temp" "TEMP") @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package designator}. @node package-shadowing-symbols, package-use-list, package-nicknames, Packages Dictionary @subsection package-shadowing-symbols [Function] @code{package-shadowing-symbols} @i{package} @result{} @i{symbols} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{symbols}---a @i{list} of @i{symbols}. @subsubheading Description:: Returns a @i{list} of @i{symbols} that have been declared as @i{shadowing symbols} in @i{package} by @b{shadow} or @b{shadowing-import} (or the equivalent @b{defpackage} options). All @i{symbols} on this @i{list} are @i{present} in @i{package}. @subsubheading Examples:: @example (package-shadowing-symbols (make-package 'temp)) @result{} () (shadow 'cdr 'temp) @result{} T (package-shadowing-symbols 'temp) @result{} (TEMP::CDR) (intern "PILL" 'temp) @result{} TEMP::PILL, NIL (shadowing-import 'pill 'temp) @result{} T (package-shadowing-symbols 'temp) @result{} (PILL TEMP::CDR) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package designator}. @subsubheading See Also:: @ref{shadow} , @ref{shadowing-import} @subsubheading Notes:: Whether the list of @i{symbols} is @i{fresh} is @i{implementation-dependent}. @node package-use-list, package-used-by-list, package-shadowing-symbols, Packages Dictionary @subsection package-use-list [Function] @code{package-use-list} @i{package} @result{} @i{use-list} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{use-list}---a @i{list} of @i{package} @i{objects}. @subsubheading Description:: Returns a @i{list} of other @i{packages} used by @i{package}. @subsubheading Examples:: @example (package-use-list (make-package 'temp)) @result{} (#) (use-package 'common-lisp-user 'temp) @result{} T (package-use-list 'temp) @result{} (# #) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package designator}. @subsubheading See Also:: @ref{use-package} , @ref{unuse-package} @node package-used-by-list, packagep, package-use-list, Packages Dictionary @subsection package-used-by-list [Function] @code{package-used-by-list} @i{package} @result{} @i{used-by-list} @subsubheading Arguments and Values:: @i{package}---a @i{package designator}. @i{used-by-list}---a @i{list} of @i{package} @i{objects}. @subsubheading Description:: @b{package-used-by-list} returns a @i{list} of other @i{packages} that use @i{package}. @subsubheading Examples:: @example (package-used-by-list (make-package 'temp)) @result{} () (make-package 'trash :use '(temp)) @result{} # (package-used-by-list 'temp) @result{} (#) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package}. @subsubheading See Also:: @ref{use-package} , @ref{unuse-package} @node packagep, *package*, package-used-by-list, Packages Dictionary @subsection packagep [Function] @code{packagep} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{package}; otherwise, returns @i{false}. @subsubheading Examples:: @example (packagep *package*) @result{} @i{true} (packagep 'common-lisp) @result{} @i{false} (packagep (find-package 'common-lisp)) @result{} @i{true} @end example @subsubheading Notes:: @example (packagep @i{object}) @equiv{} (typep @i{object} 'package) @end example @node *package*, package-error, packagep, Packages Dictionary @subsection *package* [Variable] @subsubheading Value Type:: a @i{package} @i{object}. @subsubheading Initial Value:: the @t{COMMON-LISP-USER} @i{package}. @subsubheading Description:: Whatever @i{package} @i{object} is currently the @i{value} of @b{*package*} is referred to as the @i{current package}. @subsubheading Examples:: @example (in-package "COMMON-LISP-USER") @result{} # *package* @result{} # (make-package "SAMPLE-PACKAGE" :use '("COMMON-LISP")) @result{} # (list (symbol-package (let ((*package* (find-package 'sample-package))) (setq *some-symbol* (read-from-string "just-testing")))) *package*) @result{} (# #) (list (symbol-package (read-from-string "just-testing")) *package*) @result{} (# #) (eq 'foo (intern "FOO")) @result{} @i{true} (eq 'foo (let ((*package* (find-package 'sample-package))) (intern "FOO"))) @result{} @i{false} @end example @subsubheading Affected By:: @b{load}, @b{compile-file}, @b{in-package} @subsubheading See Also:: @ref{compile-file} , @ref{in-package} , @ref{load} , @ref{package} @node package-error, package-error-package, *package*, Packages Dictionary @subsection package-error [Condition Type] @subsubheading Class Precedence List:: @b{package-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{package-error} consists of @i{error} @i{conditions} related to operations on @i{packages}. The offending @i{package} (or @i{package} @i{name}) is initialized by the @t{:package} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{package-error-package}. @subsubheading See Also:: @ref{package-error-package} , @ref{Conditions} @node package-error-package, , package-error, Packages Dictionary @subsection package-error-package [Function] @code{package-error-package} @i{condition} @result{} @i{package} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{package-error}. @i{package}---a @i{package designator}. @subsubheading Description:: Returns a @i{designator} for the offending @i{package} in the @i{situation} represented by the @i{condition}. @subsubheading Examples:: @example (package-error-package (make-condition 'package-error :package (find-package "COMMON-LISP"))) @result{} # @end example @subsubheading See Also:: @b{package-error} @c end of including dict-packages @c %**end of chapter gcl-2.6.14/info/sequence.texi0000755000175000017500000005661314360276512014447 0ustar cammcamm@node Sequences and Arrays and Hash Tables, Characters, Numbers, Top @chapter Sequences and Arrays and Hash Tables @defun VECTOR (&rest objects) Package:LISP Constructs a Simple-Vector from the given objects. @end defun @defun SUBSEQ (sequence start &optional (end (length sequence))) Package:LISP Returns a copy of a subsequence of SEQUENCE between START (inclusive) and END (exclusive). @end defun @defun COPY-SEQ (sequence) Package:LISP Returns a copy of SEQUENCE. @end defun @defun POSITION (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST with ITEM; NIL if no such element exists. @end defun @defun ARRAY-RANK (array) Package:LISP Returns the number of dimensions of ARRAY. @end defun @defun SBIT (simple-bit-array &rest subscripts) Package:LISP Returns the bit from SIMPLE-BIT-ARRAY at SUBSCRIPTS. @end defun @defun STRING-CAPITALIZE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case. @end defun @defun NSUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed. @end defun @defun FIND-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists. @end defun @defun BIT-EQV (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical EQV on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun STRING< (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically less than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. @end defun @defun REVERSE (sequence) Package:LISP Returns a new sequence containing the same elements as SEQUENCE but in reverse order. @end defun @defun NSTRING-UPCASE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with all lower case characters converted to uppercase. @end defun @defun STRING>= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically greater than or equal to STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. @end defun @defun ARRAY-ROW-MAJOR-INDEX (array &rest subscripts) Package:LISP Returns the index into the data vector of ARRAY for the element of ARRAY specified by SUBSCRIPTS. @end defun @defun ARRAY-DIMENSION (array axis-number) Package:LISP Returns the length of AXIS-NUMBER of ARRAY. @end defun @defun FIND (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the first element in SEQUENCE satisfying TEST with ITEM; NIL if no such element exists. @end defun @defun STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING=, but ignores cases. @end defun @defun STRING-RIGHT-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from the right end. @end defun @defun DELETE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by destructively removing the elements not satisfying TEST from SEQUENCE. @end defun @defun REMOVE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with elements not satisfying TEST removed. @end defun @defun STRING= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Returns T if the two strings are character-wise CHAR=; NIL otherwise. @end defun @defun NSUBSTITUTE-IF (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed. @end defun @defun SOME (predicate sequence &rest more-sequences) Package:LISP Returns T if at least one of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise. @end defun @defun MAKE-STRING (size &key (initial-element #\Space)) Package:LISP Creates and returns a new string of SIZE length whose elements are all INITIAL-ELEMENT. @end defun @defun NSUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM. SEQUENCE may be destroyed. @end defun @defun STRING-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Given two strings (string1 and string2), and optional integers start1, start2, end1 and end2, compares characters in string1 to characters in string2 (using char-equal). @end defun @defun STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING<=, but ignores cases. @end defun @defun STRING> (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically greater than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. @end defun @defun STRINGP (x) Package:LISP Returns T if X is a string; NIL otherwise. @end defun @defun DELETE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by removing the elements satisfying TEST destructively from SEQUENCE. @end defun @defun SIMPLE-STRING-P (x) Package:LISP Returns T if X is a simple string; NIL otherwise. @end defun @defun REMOVE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with elements satisfying TEST removed. @end defun @defun HASH-TABLE-COUNT (hash-table) Package:LISP Returns the number of entries in the given Hash-Table. @end defun @defun ARRAY-DIMENSIONS (array) Package:LISP Returns a list whose elements are the dimensions of ARRAY @end defun @defun SUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying TEST are replaced with NEWITEM. @end defun @defun ADJUSTABLE-ARRAY-P (array) Package:LISP Returns T if ARRAY is adjustable; NIL otherwise. @end defun @defun SVREF (simple-vector index) Package:LISP Returns the INDEX-th element of SIMPLE-VECTOR. @end defun @defun VECTOR-PUSH-EXTEND (new-element vector &optional (extension (length vector))) Package:LISP Similar to VECTOR-PUSH except that, if the fill pointer gets too large, extends VECTOR rather then simply returns NIL. @end defun @defun DELETE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by removing the specified ITEM destructively from SEQUENCE. @end defun @defun REMOVE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with ITEM removed. @end defun @defun STRING (x) Package:LISP Coerces X into a string. If X is a string, then returns X itself. If X is a symbol, then returns X's print name. If X is a character, then returns a one element string containing that character. Signals an error if X cannot be coerced into a string. @end defun @defun STRING-UPCASE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with all lower case characters converted to uppercase. @end defun @defun GETHASH (key hash-table &optional (default nil)) Package:LISP Finds the entry in HASH-TABLE whose key is KEY and returns the associated value and T, as multiple values. Returns DEFAULT and NIL if there is no such entry. @end defun @defun MAKE-HASH-TABLE (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7)) Package:LISP Creates and returns a hash table. @end defun @defun STRING/= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Returns NIL if STRING1 and STRING2 are character-wise CHAR=. Otherwise, returns the index to the longest common prefix of the strings. @end defun @defun STRING-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING>, but ignores cases. @end defun @defun ELT (sequence index) Package:LISP Returns the INDEX-th element of SEQUENCE. @end defun @defun MAKE-ARRAY (dimensions &key (element-type t) initial-element (initial-contents nil) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0) static) Package:LISP Creates an array of the specified DIMENSIONS. The default for INITIAL- ELEMENT depends on ELEMENT-TYPE. MAKE-ARRAY will always try to find the `best' array to accommodate the element-type specified. For example on a SUN element-type (mod 1) --> bit (integer 0 10) --> unsigned-char (integer -3 10) --> signed-char si::best-array-element-type is the function doing this. It is also used by the compiler, for coercing array element types. If you are going to declare an array you should use the same element type as was used in making it. eg (setq my-array (make-array 4 :element-type '(integer 0 10))) (the (array (integer 0 10)) my-array) When wanting to optimize references to an array you need to declare the array eg: (the (array (integer -3 10)) my-array) if ar were constructed using the (integer -3 10) element-type. You could of course have used signed-char, but since the ranges may be implementation dependent it is better to use -3 10 range. MAKE-ARRAY needs to do some calculation with the element-type if you don't provide a primitive data-type. One way of doing this in a machine independent fashion: (defvar *my-elt-type* #. (array-element-type (make-array 1 :element-type '(integer -3 10)))) Then calls to (make-array n :element-type *my-elt-type*) will not have to go through a type inclusion computation. The keyword STATIC (GCL specific) if non nil, will cause the array body to be non relocatable. @end defun @defun NSTRING-DOWNCASE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with all upper case characters converted to lowercase. @end defun @defun ARRAY-IN-BOUNDS-P (array &rest subscripts) Package:LISP Returns T if SUBSCRIPTS are valid subscripts for ARRAY; NIL otherwise. @end defun @defun SORT (sequence predicate &key (key #'identity)) Package:LISP Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument. @end defun @defun HASH-TABLE-P (x) Package:LISP Returns T if X is a hash table object; NIL otherwise. @end defun @defun COUNT-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE not satisfying TEST. @end defun @defun FILL-POINTER (vector) Package:LISP Returns the fill pointer of VECTOR. @end defun @defun ARRAYP (x) Package:LISP Returns T if X is an array; NIL otherwise. @end defun @defun REPLACE (sequence1 sequence2 &key (start1 0) (end1 (length sequence1)) (start2 0) (end2 (length sequence2))) Package:LISP Destructively modifies SEQUENCE1 by copying successive elements into it from SEQUENCE2. @end defun @defun BIT-XOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical XOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun CLRHASH (hash-table) Package:LISP Removes all entries of HASH-TABLE and returns the hash table itself. @end defun @defun SUBSTITUTE-IF (newitem test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM. @end defun @defun MISMATCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) Package:LISP The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the result is NIL. Otherwise, the result is a non-negative integer, the index within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within SEQUENCE1 beyond the last position tested is returned. @end defun @defvr {Constant} ARRAY-TOTAL-SIZE-LIMIT Package:LISP The exclusive upper bound on the total number of elements of an array. @end defvr @defun VECTOR-POP (vector) Package:LISP Attempts to decrease the fill-pointer of VECTOR by 1 and returns the element pointed to by the new fill pointer. Signals an error if the old value of the fill pointer is 0. @end defun @defun SUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM. @end defun @defun ARRAY-HAS-FILL-POINTER-P (array) Package:LISP Returns T if ARRAY has a fill pointer; NIL otherwise. @end defun @defun CONCATENATE (result-type &rest sequences) Package:LISP Returns a new sequence of the specified RESULT-TYPE, consisting of all elements in SEQUENCEs. @end defun @defun VECTOR-PUSH (new-element vector) Package:LISP Attempts to set the element of ARRAY designated by its fill pointer to NEW-ELEMENT and increments the fill pointer by one. Returns NIL if the fill pointer is too large. Otherwise, returns the new fill pointer value. @end defun @defun STRING-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from both ends. @end defun @defun ARRAY-ELEMENT-TYPE (array) Package:LISP Returns the type of the elements of ARRAY @end defun @defun NOTANY (predicate sequence &rest more-sequences) Package:LISP Returns T if none of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise. @end defun @defun BIT-NOT (bit-array &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NOT in the elements of BIT-ARRAY. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun BIT-ORC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ORC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun COUNT-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE satisfying TEST. @end defun @defun MAP (result-type function sequence &rest more-sequences) Package:LISP FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that the i-th element is the result of applying FUNCTION to the i-th elements of the SEQUENCEs. @end defun @defvr {Constant} ARRAY-RANK-LIMIT Package:LISP The exclusive upper bound on the rank of an array. @end defvr @defun COUNT (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE satisfying TEST with ITEM. @end defun @defun BIT-VECTOR-P (x) Package:LISP Returns T if X is a bit vector; NIL otherwise. @end defun @defun NSTRING-CAPITALIZE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case. @end defun @defun ADJUST-ARRAY (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0)) Package:LISP Adjusts the dimensions of ARRAY to the given DIMENSIONS. The default value of INITIAL-ELEMENT depends on ELEMENT-TYPE. @end defun @defun SEARCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) Package:LISP A search is conducted for the first subsequence of SEQUENCE2 which element-wise matches SEQUENCE1. If there is such a subsequence in SEQUENCE2, the index of the its leftmost element is returned; otherwise, NIL is returned. @end defun @defun SIMPLE-BIT-VECTOR-P (x) Package:LISP Returns T if X is a simple bit-vector; NIL otherwise. @end defun @defun MAKE-SEQUENCE (type length &key initial-element) Package:LISP Returns a sequence of the given TYPE and LENGTH, with elements initialized to INITIAL-ELEMENT. The default value of INITIAL-ELEMENT depends on TYPE. @end defun @defun BIT-ORC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ORC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun NREVERSE (sequence) Package:LISP Returns a sequence of the same elements as SEQUENCE but in reverse order. SEQUENCE may be destroyed. @end defun @defvr {Constant} ARRAY-DIMENSION-LIMIT Package:LISP The exclusive upper bound of the array dimension. @end defvr @defun NOTEVERY (predicate sequence &rest more-sequences) Package:LISP Returns T if at least one of the elements in SEQUENCEs does not satisfy PREDICATE; NIL otherwise. @end defun @defun POSITION-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists. @end defun @defun STRING-DOWNCASE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with all upper case characters converted to lowercase. @end defun @defun BIT (bit-array &rest subscripts) Package:LISP Returns the bit from BIT-ARRAY at SUBSCRIPTS. @end defun @defun STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING>=, but ignores cases. @end defun @defun CHAR (string index) Package:LISP Returns the INDEX-th character in STRING. @end defun @defun AREF (array &rest subscripts) Package:LISP Returns the element of ARRAY specified by SUBSCRIPTS. @end defun @defun FILL (sequence item &key (start 0) (end (length sequence))) Package:LISP Replaces the specified elements of SEQUENCE all with ITEM. @end defun @defun STABLE-SORT (sequence predicate &key (key #'identity)) Package:LISP Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument. @end defun @defun BIT-IOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical IOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun REMHASH (key hash-table) Package:LISP Removes any entry for KEY in HASH-TABLE. Returns T if such an entry existed; NIL otherwise. @end defun @defun VECTORP (x) Package:LISP Returns T if X is a vector; NIL otherwise. @end defun @defun STRING<= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically less than or equal to STRING2, then returns the longest common prefix of the two strings. Otherwise, returns NIL. @end defun @defun SIMPLE-VECTOR-P (x) Package:LISP Returns T if X is a simple vector; NIL otherwise. @end defun @defun STRING-LEFT-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from the left end. @end defun @defun ARRAY-TOTAL-SIZE (array) Package:LISP Returns the total number of elements of ARRAY. @end defun @defun FIND-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists. @end defun @defun DELETE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns a sequence formed by removing duplicated elements destructively from SEQUENCE. @end defun @defun REMOVE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP The elements of SEQUENCE are examined, and if any two match, one is discarded. Returns the resulting sequence. @end defun @defun POSITION-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists. @end defun @defun MERGE (result-type sequence1 sequence2 predicate &key (key #'identity)) Package:LISP SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type RESULT-TYPE using PREDICATE to order the elements. @end defun @defun EVERY (predicate sequence &rest more-sequences) Package:LISP Returns T if every elements of SEQUENCEs satisfy PREDICATE; NIL otherwise. @end defun @defun REDUCE (function sequence &key (from-end nil) (start 0) (end (length sequence)) initial-value) Package:LISP Combines all the elements of SEQUENCE using a binary operation FUNCTION. If INITIAL-VALUE is supplied, it is logically placed before the SEQUENCE. @end defun @defun STRING-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING<, but ignores cases. @end defun gcl-2.6.14/info/gcl.pdf0000644000175000017500001137737514360276512013216 0ustar cammcamm%PDF-1.5 % 5 0 obj <> stream xS(T0T0BCs# 2PHUp Qw3T02330UIS4300W537TIp 567pσ}2 ,> stream xڕYYo~ϯa6Z"ZgW:fN"vhovovQTQvw;kmxLlwW#P ֩JCb뮬NhLYYy':i/L}wqrڏU.DlhlHm9'lUO吏mɍTO yFKfyɿ<ABq#2H {wQ IW4K~tQ{j5آf.[h$8W*eOzMVޓ :X+Y |;}IzKKv֝GyF6͂c<_h\98K& 򦛐A:s7##zz'~5C?㫿~jWmDm/F' v Y/4IX Bo}p}Q[ aKզb VEL7 '^ܜQs\怖8gB# kpx TK'`ojK֞a^I bͭYLV7Qa4๬IH7X믧G Ոλߧz&D8z}w}o_] \wn [ `I%2Y%|0"t$1\=USO *~Y0e28M;x|. "K"un8|QW? c-UQZ886UFh2ˊ VabSʮb~}\)4+>Ș xxBC Z#!= ru88[n`9LJΨ;I#z yz򣴺j +4i}HC3䒻џ]?[16`m1|hWQfJLG0IpGY\t㻁O7ģQ$@[]KV$!7Ŝ;@eT<_[JP9D 0/&nZxBM)ykJ0G8M:)'{ *4w`,hNL#bA[)dH.NUd>S,AlW_;!g5%Xs&VAhI5pGߞ3;[ RHO.VemMG^$ D+9@ôGm81S jn@6->WixdcCt{zlۛ 2,u,JK[[I1`7 ؇P0{];T)}p}UCݙ*+=MU^a MI&Ǟm@H9\4V~ĵ1Z3ШHZSF (5\"L N;u}5L,6v1dy_ph!LrR֢%| qh ]=Kkr$mqF*p8QH<(ho-Bk#g=dFŲפGFӱpC**ʤgObBLAx̑9He,/(* ذRxaџD9hB3 H2\ dUQ ]<)bbvD:^=WĻ?N5NR>XRFsŤaIaا<)$W o&Y$UBY8@Y-PXy0Đ +d)PO9')jBNP9YA;u4i+;gNť b_ _(I$5}ƪ2&gD_*k7r@Yz,V,up\6Tq<5䈗{!lid(`Zw'R"ll2p dÝ%IeZܗ=ԯN/^fv/pr6od߹rj; -t> Ȯ^.΍o 1e$ endstream endobj 16 0 obj <> stream xڕZYo~ϯPKW޴r,iI9 ɱ%oO]CCaw!A,VWUAm7ět:Qް ԭ4Ua֯؆v-;a}رPs T\fџ{8<;[/-4K߇/NY.v}Bd! My 躄vrN ; ^P*t&#8ضgkz^J^*43c+55-`?+C FH]mdlWd gmԚS9Nz' /⚺C*|sB#<a!EP;yOXzt`,<:~Ru`~.>>Le'o~=w ڐg?>z(Y88_c^$ಲFjt*dj$xi㋄ yÏ=K#ܐί]sl_Rypu?ԕacvaP"iEnBҤ)aW/GhUܡs~tZM4;l];PYZ T&ӄC2pxM{5,5(ڢ)HL$LTr<4{2u`Ȋيr #Gp5˒;[&_aX+#w O Wf2*k2/uZ2 իן ѳoi\ iy[60 mN0V|0 B802FQ+I)Nji ܊sg Qx? "YkwrהJ`r 9,d}xow+ =!['EDD-^7F>§C=f9 I| :d扒br $ g` \Kb$%+pDYx50l'B,`㷏mE [zO[ BRWYmՃn:a#XF\'z{Cҋ4z8sqճԛ;S{d4 $%+W>X[hQh Дrb&.\StQiAkZ0);XUT nVl 6^b:w5;fgP8` MJ@z)ҝZ>2_yRM3,RqeOKAݻ5֑/X>95߬XJS^sf@e^0 &o&4l4 M'aRxL~Yyj" ܄G6&=3}iwPRsÊ;dZ2+[a^Z\+@= پð# +ʣ@jEU KL;<x{q0,CЭ nd,n?Ra i??:NBPq]0ӽ+"%R;hxgZ1'90(*,j{{ۍ2`TLL8hjyc?$O(9Z{Å47#Ϡpԋ5-XWaզA"wګӘ+W S΃9gfIǏ)u߼J|b.ZƔ|q!ͱ?IБsQ)Ws߬H|[鎟އa]+j>0T%&V~߷2ػgn3=H`3WySP,XztI!)*m8o$^N'!+Y*wV*a /Ѡ/B!iLaȼcnKZ+SJxޛ=Ȩ02,Tx)rvD&8r456F(8qEB$!_rcQGp1dưFŋ;v kAȓ?hTJ%:Z<%oqisϛcsM^oOLb\](Sսg+mIh,΢bρ}7QK$Uhm֕iXAR|x[4U(/K/&8e=C$JFV$?{0@ek*As WJy)f{nZoZhz*7nb%9|sZaЕVGbq. XulAfr阆-\z~_O! endstream endobj 19 0 obj <> stream xڅr=_1oTihiGXݬIDB3򘐜|{PhFg6M)wޅyFe6w?smEQ䩿lwZk݆7vo&~8G9N~4M6 ֩7XK߽snluo߾w;4}{zF˘ 8Ǿiv7ݟB*?f7 yzfZ hN~al/A01H,8 -KWT#H"c\^cU>_ʹ @mFT8~Ÿ,"x,-qhz:mC2xUN^h9IlM5. xC_]1AaT-Jk?]h/<јȦ{-<Ēx4دt|#T?= NgRxax0fq{Whۄy왖.ؚG-\tXi,衁X +uw$Bg'3# b檵k5U[{;<\ȏ i[Ƚ{mLij{whuz-$ O%৖mI& G od~ʖ~~ty;j֢n<'@?EԘ4F InEm|x/gDz_KE>8:!z8. 4dE!8N&I )Q"I$`8E`IHxBʇ}RRs,֩ sHP}*@,QT"]#05}UV_1 ۜ@6~ԮI{Pkqeu\ {?U@*;PcH,yh SvP,AXb%!3 "88nv+LjMx[hLt_j 7MW.߃DlRq0c^7.h()[kb wn5ؠ;#00{@|Dfva=/WŐc eHV 9M|>J"bp'NL{+7{qp):SV)=S4YG\37X*v 栞l0i> ){ώؠM=Fc 9qI|OS#7=%ʥʊ)j2!$O$+lk $2BhSMf cǶ##ODDDž(Ÿ|y{ܣ endstream endobj 23 0 obj <> stream xZs۸_R!@ {O>qc!C!2[TI*go.(Ğd,~L$|'ra'7'<2?rDDiZ;>΢( jN_qX/umzL$A^j*t]_ÃgLY¥=knnC.+3ygI%*[mEXMXrtk83R&AVOyVD`TA^Wp*PxghMQ=t]78z*MghYYן -' Y0 c;kN0ۭ1nNEf )܄u)m& wsQiD{>\?,Q{eK)*"2ۢŻ͸UY>{A0-E5)g |ý_wWc";tW1gnldTm@yk?m fxt|nqz\DeΈz.A=m<0Zj|"a3jjK17+P#ΤV%DڣnwA4 !/ A#_b|C.j.8ر]p6U1̷`ZаZ7iQJ[b` ]1;4Sr؉ʳָ@TmSW fgh][V%7oY|Er?:4xU(X5EVG}%PGXRgÎ_;z.(쵦VN^}i:)Tr2EJgNt ehS$e*T/hHqa_6bg(l fw<8eȧD9nd"C [sLcKw=8Z"h֟Zӡ<i?O<>gbd^m7|?D6aCh>"l^T }M#cHTqDccLe!-!'%(y (]U9nF) Jm2m^ό/6/}t$| HbgG4n$u7rz; yeY[҆H#c!a# I5/eBёWr9/f!z~M'*ArwP@<ќ7%}G^T-֙¯+@+GYe+RPBZ 7p;~zo!;u1UT եdA-ߵ*?mM G\ZXz,6Ev qg)ƀr\ %Z?kL>\KXQm`զvJߛs ZoHf"6?]ePĆ'WjOCm Yo=/uX'bK&/|`3s|Q:'bm Og;!P/1-l\3N@2-@jPѷn Q%mHF` S0vejYz{7sS-'X$b͇<ܺ-'%]!MļH[7+_&=3UN~ bk;jvb9 ]n%jj,*#j6qE77Enifʺz}+ Ѿ> stream xڭYms۸_~(1M>٧Xuv E$3bA 18I&۳"(?|nBx 㣻#x2kt30۱/.H>.wyWwW#)b6ɑ{s/3ri$j%+%, F"oѩj%}}liQ:/ZuEc{uNǤ7in]M/bΒ0O`Zy1D7 \ wY]:MGy)rUR?\4PWEZjUTZ7~>_8Oc+'`z0B@g8~ `[˥"GYySـFHrN&Њv[ΓY<A'!r! kANhzznt̻VFdwYtR»[Fu0V.Zp^3zwx]tܨJ@R li;tGsUig _H8ʚ]MV&G]T7&ֲē􅈋o!y ^qb#W> fb#p238 zq/tۂG[Z|͕M_6kA vs^IpiuT m̛Z=`aC#k|U]ފλ][ I,>a-S!~pX<*̌`o"jT?A2a!wHdwU+Z:k\HO{SAXt/in9٭vm'ϚKi';PC2JM@ R5:Id&V3'MW\2WPcvybR7! ~>ծugMʀ%nW.qCD30 q=m͓0op[^ $9wwυ s4J쌂Bπ"'NiڽfB<MHSVAb1כΒ@|Ua8Bh(Va"_I7ZՄ"(>!E1?Q`hI~Ǎ9~i(*0&C/!l0 ^XHL$Cxǐprg#$Lp@(e)y0Z}t!ۂR@a9=;FSބ&HĔ(5 Gj=o*/_M~Ut߁%L8mQc40u-`_R|6`$Y8 2Uڕ/a%]5l%|5J0tH'[1Zh^tTAd+uE-ŢIEaQ}{ 0AgGB빴!=E00_1)WyE1r)) X9f+ШjdCl!iC@+~( AIG%ߡlwE+?=pll6 M e?[ :kTH.eTFdIc&:lȄ[z?p_*E{9X5njuu9>U zm!_|q-H||Y-Vض-(O?dl'=C|qyd`MƜqi+MMCB P4r.oA~'ܧűϱ'ukw? endstream endobj 29 0 obj <> stream xڭY[o6~_!IxQ(iQhȶqZ>y5]&d{X";ύ߹c^D?{u㽼<Y1cxԻ}ͿGAp؋c?]]l9羪wOjn-ߊHo6J|t7d2‹Ȃ s foC&/tޖeCݝquWEmW8Ŋ/knhwpTʞ=tzGɪ.A$ &I!`$9I 7<z<3JɅ&JlSQϥP#PZdlahOl-{w_n27(J@繽ܤf4E,$Y}VF~f V^#?{{A _\Rcq4z:4fUMlְ ].p~)S&`<}㪂  qK$"sQ$HД7+/Fz OcsuLnޗEwpFZe Bnn*L, Þ&NFZvC7uy[{O@vƈk*dpY}󸉙rK `@}<*I8Rz+$u2$-E x>"xpw0e%|0!Y6"Ywq]m'y#jRn~U,i?yu r س!@rLVb4t<zNGvfh^Ya+"Ü+E"pdF+/X* 4@ITJ&T_y ~b`$O! {T"3M^ 8<9-SNY2ˠE)!Ss!JEb KXt[uʳlNVw},$Xrh]߱-1C6֍?~8i~'04s |G qVR95= yUȽk[^qt4$#S?Me)ͅ NZ@(ݻDYg۷b!VW E|g59>|Z`n4#'5N `1Erp{eSѼ7P>g endstream endobj 32 0 obj <> stream xZKIﯨ=m;h-{A#v5]`[4?~"QdfÊ/VUuK^1Ju Nznvu[\1cO/R٫7ݶ~kŇTkMeiq.LG bmp gX֑?__p;7b4yKjMX] Fv6[f g@z[Ϋ߆^;M]{2f)Eb_'VDjgo(S5#Nj]q8!+Vo #5'LϟycBGpHse$ xw. f|VZuZO.s܍K1:jmG [PV! q "Yd SYCўkwmÎz{<?zt1MrL$l+EޖN n V:BE 77~Ōe&N[6M߇w?|uSo2XϪa5a njKGȬ0N8x8,Q:GC I}6qDH +f[nۀ$ƒQ/t"k)_ Q'>ɠ?>AOk^mӢ(C97 9x:dzsJq찬F w5 5*D2gwv5@[`]vkE@ m Q7DC}w.j؞bN栱M=`9l#0$qRf{{h|eӂh\q -sEќLLr'ņfp_Y_ao<@Q:g3RxB0 cw}\6MY Kg3ŏ|[ޔv4z 6G?l|jXLW0f"Iew>jڻי_--^bǁ]i2ȯG>{ > ꛧ~ wLC3A/EmOL]ec>! >dUަٵ96E&<ϒWǬuo!qgf)[ ,ާ8nm1)Kv,汢 WBjXWdQ].̺]HvI}CԵN#'.:d_SvukלU#@4f]br4]b6]L]P%)%Tj3)%dJΐ^U?-%! c鰕kY$t(7r(.xn*bn+K&4{sgm-B.}$}Mx(@{#7y!)\/83|'Q(Fol8v\'c /#olz%$1DOX2|B ۸eL{`A\VBÉXdq_HcU /I}x>~;X :GrXw!B.0H,4,,vM7ZPg`¯/!~ UHW9GZc ?Ի3brAV Yꄖ1p\.w2lIAeL<ς竾> stream xYYsܸ~ϯ'AtU$oU*q*eisYQ\%W*{eg]$xUW׫lEc9]]߭h"[]o?EV3"%fǫs#6޷}ۘ^~߮7,a5Qon<ٍIF%^ W^aO=e_?c)o ~gx{ɧ7$L64%1|i7z0O]=~o֖N {8 y?ۺc^V O ]П=s^RdtJbYj Q"})mթ,dUm ܬyœ;uyø$)G;V,{[i` eJ&pm`/Mi#640R0Yo;SŶb9T߹&3؛?C0HƜq_݅(QJ$c_ds_/cNLN\a|87d|܏ZilYh~b% ÀhUÈ?݌;^cvUwq*gMfȰq¹x3BZ@pI*: 8zAS`SQa ;CsǓvKY nBZ=Bh ,-AY15sfTZe.*dB,zLݺtNPpw=asd3J9SsoM Cl$M0+tKwl.ԭpz)#|6a$2^SzzjYp^8,pѓ,džlCd$2]1y A?#hy3gDE4>)s)G`9Z'I7X/,qHusrp/7x4,G=fZf 78cS\rWn5.oZ7y|"}˄N;LCK=ߝkTGC[Fu|1/3A8dX l(hRu;Ce?Op2`wH;uZoJ]+Qhl.ãU5`wz~Uy>u6ѹ;Pwg `  ٷ#=EIr9 N:q1Vvm Ǣ &;üp/fk~JIwb;}[!_2%MIo o R< TR|~<ا*+P780Yܵ:wĄX֏4" q4qA gfHvm }xSMLAh297Ep_F`UG`Y2Z<v>ETP+_w %23?T]]qa:L,m@EzciY׊ ȸP?a5I`(GԔZ<,4h Q?h0MTX$N&KKWYLIMqE֛XW<- G xWG).lgglD|W&2 F4Y ;t,Ʒ~kt0@Ä́,zǨ'~w.OiŴI ւ!9 ,E쭙{vEÕЇTՃqTEP`\ДOpAr\w endstream endobj 39 0 obj <> stream xY[۸~0+tه4Ht38YJr&﹐䑛ɦA1")\zJbTV?ެV2yJf+EnM8[o֑a1D?5kFC׮7,Ojo2*$ ~SR.Ԭ6&6ivTDF(mi\o2 )xj!y| B]18Fv\~.Z^\&_& `E2 ES]vcHֵBE*vh=X8ͣY { dvZeþs纏X?z6*jVlJaiXpWmci\v.j8jfgMI S[{" pi 0df1%ojz1Z*%QSKF-O]B,!' ] =d􈯨"|9=j#gFeB QLB37w;°= $aع;׹f$_7^6XWjƩ"@"6Hl8W$c`j~HMO`R!-?;߃ L522si}jlT}}qpQFGי$}잙!prӂ#[3;0C4!X#pK0>Bd#s)5ކE`Ptݞ4[;ӓ91.W L8rX}Ux( Gy_/u8Y1,j$=nWz iU<ݵV C 1T{Y6sۛ%* zsؒ2gHL2)&d2ےFd [%x2ܞZ(1:#ؘ!WǮ8z'ɦ8$|dSwNc2t~9'tq_'VR{2LPѪ>tIߵGϊ'+J R:5$$]Q g+OYT_n+A ;=T9xΖ{<{S b8ܖ2Hևm|`ۈy}Ă L MDD1 `$Нܕ0c^l}+J޼~Bz|38|tf2%U|d*ųLg=g\; DoxG!7v~ȞFްRooPo d*T+J{+wY!"q+$ >h9Rħ] _Ee6ât!K_2+u²JpUsZ hOɕ: ~ }[5*.<\W쨆E޵Pp6k@ VG︳tCQ6 :})/ěTQ[PBeX뷾bi>qi v|Tm$4THTFsɓK;'IDgW~ ?Rhl e:O#s{³g:~}gy6P:uG Ue ΂a}IQO8z.Tn  AWKd*E*# H:JZ~ujّ endstream endobj 42 0 obj <> stream xڭZ_sܶ笠C{rI'M&Ǚc#$OZ?{wpfA\`vǙq3#V_.g_3Ys1D6 U6\ ~3HfL/woxHd^kͿh}55uiBfagsi潣&e.T2ۭu>﷖K.T]TtU+{mpd`;5=k<.uS/J^b՗7p&G6;vHS9&]_J2Jbgs]]S(RzlE_6uMDJ½A+eQUo8^PSLȠra; 3@} QHJ[A b=RP 5Sq%d[ ))uz:u^sٗ?/dr(Iy W_lޒqI4 uC!|D w ǒ A4\Ɍ3_X1<@ـ(WO^/Q(_)bN_JJ4;E\9g̣]+XN^g]۾(P'fU3΍dR#呡Mrxj+g]}VEGRݮp<eEL8*g< ~s"( jN221 aL)S;5˝extQMxD፿}mgs:emZב][#wf* dXH/b4 x*4BbyL/Agi]DEHK#U\A Ⰼ=/<Rba ?_a6ŮzK]MU_] woGr j۸IH)x"Ņ38],')[~jznMO]\SЫ\ ~Xcي/ueOZ1.ekʕC]40*KOs+B>[z.W=â*,ypUB:%'N0;jNkЙ'(kK46Mioha(]lpLGl:#ͺ|׷w󄣁ߦz ۖ=QbIMgO|mFAwu8SxsN~lC.|DA$wԐk}Aw±<.\wB*|2jTY (3/Xu8/Cs(WXŦuQI ݮ{ۻp7uX<)g9RyrBdo N3-T7D3&mTÀRu56uz#V y<5O}iDQ5 thwlz/Kcab*]GG WnAaiЯAHqgd y7X( 6 PVڷ󡘆r*ڦVvӚ¯rUNjm `ܖ2PB OXlJ9G ɉѣ/@O:_P`7 `O"74KI?0s&A.K4ErXm'97(N4|ʵ`driFLs X/w PS~N,ϴ/q::C 8wݴs7'-\kgNdO6<> stream xڵZm۸_aKd 扯$)rEU+[$go3|E-MP(ϐ3>3yyEW9U?_m7W޳ItuuzE9)^]cݯ7~!5+N۱^y%%('7`JS8wڈh*lW"%z#>kg70jWZŹntwͲ~2p#>Ye_|YKU}SѾn|V'w}:4S[{~x*8wNfavfֵsp#`K)m+Z -+*-YV sBY )\"K V8X)Id1J$&’H?ӱjژf_coh I}],HΟe9נ}=8=cUN6Ma^)ز3"7NwW};F+PY^so0rޯ5~Ƕ~uW)k^\g?;{y/a> li;|jma-.F c}lss|2Ħ(Y,Ee ļ& Zĥ "m0xTf#{J28fR=dݵRP0dlLa8Rb5W̛A\` K7L̻2Ħr犊.ty}.a'iKRAB>PΆΎPً#߾qY}jZ bۚ0):\_}}غԘ s5ԯ5΁b7ri4΋P͜m(%E[șY],Vl 3S6`2ۡq@z&ڢ PS8_&i+7̱G^(1( L ,/0J$]վnWI>|md&I= W ,[ l=I\ʾWxLʉDfT $T~K)KgsE4_R3w7Ķ/HM'c(l|尦}7Yj) ՜0?ދy0 mrᮮn"O۩njѓ-r:wQ9TBN.ul[xyK8D/ g6$4MgΩcO9&9q Gهf^r WYy|]c[H1 2-mC1,{N'͟ )}û+#lG5hKwW+"TYV 7UW{dq ==iW~!xN4/ A@hbj"'"N@B\ @v@8)Xj-S`\ŒJ+JSCQ&M! jN!4 4b (Bh<@4y yCC)PH~@$XjOq'1Xs!"dtBX xHHCl~@>'!j>/AscA $i!ʗ:* 4O ] F!%1y$[` 3'S F#0oALb'6(S8P$ <'me: pH) JlA2Lb!0:ܧ)SH` lX$0pA:LbC@>LaĨ'6Ȉ)DF!Fw>^8 6-,z\.$HitC\z^ s{P{yI#a>NAg vN<ȤRʯ]N,QkS1oV&TP Ń.|~WUkl&wry[|>jBAfa#0H]J!V$Q iSf@?[–?*­Z4(A &MHOeCwhqCċU`R).sS0EaСcHKr^}*.|/SՀUa3@,R*$%ʆAm}ыDj>IoY:sk,atͮ޹c_5v`؏RĦQK'@`#* i8R41EAN#-M|9/&' endstream endobj 48 0 obj <> stream xڽZݏ۸_a%5V/Q56[MȒ+lp//"d7C-`?Yno?Kb.X`"62[l1͟\Xk?w~eBDyϿ±\}_/W<ǽ\G[G1b&L+iIG6T\Fݮ o40p{L6' s?~l~rț|o;mY]XEV A~8XdWy=vCOtʊq*"ǭ 19쎯/$AFA3d0 /U*UQtdh޻hCL2b͟%oS]6fͽܼvVuY7svNqWo8WNj rwM5ģ<]0uWSV2 ؇LL`-K6/64jz 1KO('֭sq}b-O>"&6d{4Z ˫TscLĜ)rRU9Nc\)m=l5ؐ42#K76Q%o1$'w\t e/ř>e˙n}.kCT2Э=4ݹBXHBΒ|AtgnHbn`(SyT,ݟ%D$$/X'Q!9T{ vR꾴mKIxm%OGIZA\_ci"םY  Ha(ͳb*%W3Ukw &Ё3G{7Qё>%}y̘86~!($߷wR7Kɝ1(#î[#b/okM>CE!zE^ž+.ɡA'^K0ǖf0 Nѣpqfu mlwl_ivl4ً˧`;Ez :O{1d" ckT)RH 6,s&cHM1`ʕJy޶=hn&F YNſ DE6I_Cr Y H.۰^\`ݍe"5O"&bL$Lafh@ ݠH\m_!q{Òlj(+=` &y Ve+c1 J#eY=} ҘYĽm!Ŕm )VtPId "Ṙ,2c{m){~Z{ԂϿ.Ҽc?~ ^hzDE;%MX|Sg],NtO^9s dө3lfy!IȌenHiyzsD\Rd8s1tȘJsznzC@.n&4 l+(X(9͍g!y]ͧ?JXXQjC-!z3!^*8ٸl Lxv' \s ,+Ph@5ގ:p_ ?YKιꈛhZK̇o 8&+dsYm<Ҵ/J薓 𭰵0LWHA^+첹81/O++| jKY~ -JsŀqU|#^ڮWށcU lg;,7yYp ՙ80->59{@0IqS"Xeүub1CFE%: N9?G@]&88Lfˣ Mh_n`!2kk*u Y./9%|>RΝomC]GEwj)(:>!vuY뼤LXK#b}$`9D 8WغJh%֖͢UrzTYus0lO]u{N~T)oF.9]m/>Yl/?ʷ ٶ.y'm~xh&MF0CG'6Cɿ1UáNz;:sVĆ ),#S$$דi2<rN:EO@n:@Һnhl a*Q1`^'&YuA%&_X|֯˵UF*_oSE-FR{Zl{@Ɗ|}o6+r-:/}A>Tg~{| >HN}य़d{~_>V2o~}0gm*tvR ^CtQ74xɧv X٧,$.C3$ lҨPXw97CzRv9aŘǘh.R OT؝õ[Hn0Pz+'Ì4OKԀp6/GI 'L7~b2dRǐ&mo=*'|8ki'ɦy6xP}r T|@B&@7Ѫ@qMMAbYz}V~jksQ>T/k#S3ԴHYjU#Žn|BiE#,!kr8 [}f<) {W#vlH϶jM,U{53F$V'mQ M7 Y endstream endobj 51 0 obj <> stream xڕYێܸ}W45EꖷdaNij-Q"*VQf֋ TxTgy'w1]o<~|d,ʸN;D_OssR>$\P]_w:b|%n0KQHMSRC%߻v }? JxwȔr-XP%؊'Ynv4ۃqT8bO;ث@ ꁆzy0dR2+Ʉuaţؒ_f"Or/g>뭱}w؟4A%PM(!S鷪.R],UV7i? 8iRD؝Dq]*^z@+3¢o_6~F ;fq|oq9 |`[E U+kBؘuN<DGJ O}@'*qCuH Eqw$S+L#-QK|m|6N5AG5C.].^}"h08 #j7:n?{j/k׎NtI X]?'-ߪ)zy- og{FʈcGSh{8yhi >M#Ә0ṣlr4Z;*nnX3NN85EI2f VGϡ(C?U{ 3NE5;îg7v| aߠ]|/f8ܶsb'6PRu5kDO`jEzZ*x!)0 r/8I͌7 0~*o]g2KCCؚU{>١kyZHCkئObpVz='=J=*?GaCI0 [^ff9zִ 4~{s4)_M:DX<426nL@\!= Q&D?3/rR͚xLps灖}* I Dt.Tsu&*x q$&8X (h'rv)1[Px{23e:a[6%ߦ~0tRq~it`;/ {ׯyy2KƁ$GPHR\DO'Ry@wc;w.}mCxXHZܯh*dS<ʑ۷EͯH}V.;ΦrT#Y1XlRP 6I8+X1]Hu0ge(Ŗw3r!s%?dǩL2'顤&K5cB\x bCP{3 NF L;i-8xO7ߤ|UK ;?֤Wl3,= D` BbJ&a<c h]x vMs f5=9Db=d)ևr- /Aozpf tkx "Gp 2@1W1ڞɞظ)k݂DZ, L"-҉i^R S^V^:$H^~C4B ER#N${Ğ1N= G3w\ge+g `uSJ@ZH9=!NǗED*8Jgw=HH%rFV3a1_O/ [[a+zgB}ѥQEU~U]-q+y^c~JpPJoX y~~m "0 +#hҭ=@Gl `C&)‰f}7)VYwɟ*O ?M vuM*O{cg8̉/UDLDgg tcߋw>Rdq=GQB+yo {Mbp>^m,f%fx5ظP]phO3}j" u<YZ?0_z})|fA2و K(: gY0fFė1T5#8øm]T8?\T򡚤2,[kqJ>="'F2PiE8`TabF{W&] 9'z= VǦ!~54t endstream endobj 54 0 obj <> stream xڭY[o~P5;![mES]4P63g"evEpt8sܸy%VWǛJpVBn+bW7gBsוT9`1?zfG| ~jVDS<YK a׍p v 6Z dmS?f_>x|x|{h#&lG3F+b8aX{`b(MKf򻜉洠'fZڬ\O;TwҳqImn6`a i"%6˽5 1-jLʂɢ44cIqZ ޶M̹fE.f–plv  9^f:WYPUV"\Ty PV@no#z}׉v$L褖=;.YO=v$8X2RG8l" @jLK"l^f'7f@\<ūÖl;Qi{0n9+U!k赆.nځ3]-)u۬Kg)nwtŽܪ?? J jr!gL6S:<Fn̓_vgm n پb>4ه,豽]߮4Ƅq]y1o--I s}fjiͲYP ޟNFޓ]d+ 9"Ʉj…J\L|1V&A JHbB1]=?>XBMW"R%gioS}SKG* LWU^Ħ,c/b}}N"8% ̞J)YnNZ^ ࢅi?!bPjsv`TM5Te]]A;ˑrJȠ<";Xg#Ϛi w7T;tggfL-AqeC*Y\J3T rI39&Br]oi*ddv3H&it_vݢ'o{Ua=<ɲDgG"%sf$48ΌyLS+qߵyӭ_<C/ea ){$T?s``+`'ugh䬟@GqrLlILCJU umaRޢT6m9;♕,RJFuiR=hbv{XzGFfazeIy)QT-Ƶe:&-KvM/&Z|<ƣåpurH9⊃o(LD˼ull7XWj檋l _GWXN6yg7W#sQ6)=e_`o (Z'! = bL ?w~[O[8sT̹tw~zs3Svv8pCGb5gu{1,{T;T㻻QM?(_M)TtU̴$iX)_?Th\7:V5rhԋ8MqHq2 wL "a*$L"_K]B[<ןxdWoD):"}~O֬+ ߬{lS;&\'>.e=1O:G lPa9>x$Tok&A8bXE{&Gf2Y endstream endobj 57 0 obj <> stream xڕYKWsV(Jʞ&mdr@qjؒGL="^_K+JVdATIV*V*KS>&MHy1D_ΣkxP[b\'*_LmLƮuf<::! {DfdylW`FeG 2.j9[E6~9^ְ@ Eu<{^p0Ev"Yxr1N/C]6δ" l 3a\˦Sc{Š"ڮOwqBɼ̺Gj28|r,83ugVf(ٹi'wfKhn4LTLg 1L8l`ѵk]uήB;)d£o.˴(?*:f_QetjQ(:] O(Jۭ3Qj#>(fV\7G5 Z3FY*2D9le:Hꆇ+^prǯQr} 1Ę-Tj-͒M2qC9#>Ȉqy]bψY*Fu0c@(Ǧ:3F\Ne1gOSvMR{hdEڠlR-W>aaLQ)8§VFJF`|-Xi5D@=>F'U.2R3+{X\LlnL4RF8DP8̨.x#9IЗ+OcAR"c݇ ǻ*CMBB,ldw_+!"phNyuF=!+ ZNֹCwIg7Q^Bk`$lPѼ`K U3J)*):L0ic*M.kYA j )hi8͂,ۤrn YQgĠm.OqlG'#VӋ}]H$Ɓ@rJ!X,Dִt2nDۦ-Ģe/m\|9 BMG@8I_@d全TNcɲ-"!7Z~F UfqŤEgLZN[}ZJ[@'VЄ+ƹUagأl$SH%nbl̲!rhB|/ B̸dP5 2u!#8Oy vB?>;^hjx ḯonӛs~9Gx/$ր#:ݒb\41;^gi8Pp߅S̀SPnnaU)(~a0[SNxkʌvƋ,X7ҝ4SaA:ӎ]u$. S_Sá3!] P!*Wqf4Iu FɄIn~v!],U{8t1^lXHA$8` ˵>ék,bpJoiW`(fy;WLFwJ4.UM !v؆ 2bT&֛ w94pa]_1?n?L'~*_wljnbRR Tѧ=$h~|"c'XDIC{2׍d+aRh] NW][ endstream endobj 61 0 obj <> stream xZ[۸~02sŋnMRX-}D#D' %MH/sf8 ߤo M}ؼFlxʪ⛻.Y]u#`E!a1׷۝2}C5~ǶJ~i#;Q&`(`6;U+"l;2y5>=yckCL9znmۺ`j; i+a\J3lvLz8u 6%H uFs߷LCi8ii>mH+`Oj>DH;ft dد6H4éop2:ҹ}!(ؘVΠH*mNVh |jbOAwljk"H1c(,)qyn'%1!y߿L?"/˻a vgӴwR7Kh~i~jAUObhFfg R /xl: و"i7&lߙ߭GD5U9*'C Q۵fޢg~Dc7e&m"HQv5l|B?H"0df=A_؏`Sхt2*(æ&G +rtGcT>->_\*| PǴ\+*ƕϷ~휳Bz 8@1螰$+>',WkheP'PD X* GDRW.z\$+zfy<Ex'>L 2nDmNÁ0sG;a[eHF x@@KbȖ2bEa#0ͥģ\L3 "z`lVR%NxZV+RV%27cD0{S3[ T 8 齥-U@Ի4'5Fqd(.V Ƨ&>f!L|Kmҏ,@yɲʓl`Q2 @czl]6n'|Í q%?Ukhar@9F(lDVji:o _) >aJy@Rv,ꋴ.PrCJzkݙ^p+hcs=-ڣt#ژH{CPGJ6ݙ&ʹds"8J/*\,S#`VJR;v'cr*z+0PV8"@)pn9cD޲#m %(6""ּLA M }dq>gu `ņ/.(W3]y2ӫE>-S)OmV<,+\brXh P&z5NXȽx7fm7};ps'm4gosO._<;^|o0 vw!C{Xu\;,Sm4c-UO)e6:ή*1G;JsO*gc av> stream xZKoWF̞fwfMNaJmn$R!x䷧jRMYL fuuW_=ſl[b_|x/XYw /H /_ñ+!D\I)%7ɱk+8n7Ǻm?u!9KQNff\LL8)ҜIۏGixYyRumG'U}|5Pr//R]EeJe-]/WJ%T{pPSR,Vsm\Hs5z-9K57cKK)n[[V aW]y*eXL9~LtyjΟlp ?d+7HReIT<,3l]<} ';igAƱw;*+o=+8 Oѥ\r7VM :ʹh~/w׃:.TڸNC՝qj-R^ ew(.+'YH9:{ERtv>^n<"E|.v_vz׳3L$Mfnk]b0]1 {$GqoYFB>M`d_ڽF?ˀ㌟,uӋh$Џy 3vEY(`B"B_Ǜch{@w*%-X5LpaIJG*7ފ K 1g܎vwG@ՍU;Sl}Eb>'dt_hL .XA<]31@_K\ׁtcSTdczaD`eQV`,ep4g͓5n١Bӟ u+wHan)yANnTE`3M~7$Й{j. dbtf{N}iN@N1hҤfQ 6>SMSQAsG޵<t0&]4˒ ܞv 0)g\.KY8bX}wx6[Ǎ2tR(n_n{;1RY,@ m~Շ!d#@-yΓ^`spqUw耎Oe<-_kܶv%;G6MJYJ oS4h=`XSģ)Uc ZUc B#Ɖ͂)f;-N!&MaLA$Ht'=6$Y|ʥ P(ǘJ2lBWW&]gfgB`8g ^\,(΄f8"15) 3cn+]"4č,avC1'ް689,`NX8,IUU*%P|f@|H[4ȟB(*Յ'd ")Σ``y,*Bt" P!_pU2NɌ!1踢 m 6`ęBBV5'(+ly=oNKzx`!7@`Hʽ$xl* uWcITyl? PGw?t{珔]@VQzĝoNd W`JΟ؛a\B\σtP:yL }bpi zqPXҵdHsS =Guh! ۅ 8D-y2 ]rZZH]VZ &q#1 =ݛ,C^_LEҗTށܗz`&Цv*nZͦ>*G1PhB4;GB)\x`'v屺X3c=W*fNUG@N!r7^֧o BeoX(,]5]Ngخ;uO2j`A. 085{҂aK9ld:Pm|>Ç~IWkHxOyohػe1YBw6Ci|'sXU h芖fʌxBu:\)dD3ա:fZJ쪯 L&MSyƧ>A.=> ƤjȝJ A{fL&1@6e9?*f`'C}877s/[%e)Az7ܥMuO;6mg:dWFp'THQmS |I|͙g}W'CpqRdbv8s$E}yR:$.3cm?qTN-7Z3[ m2x ^5+ݞyc|3Fo XFĦy=oQƔc꛿hC>-~} endstream endobj 67 0 obj <> stream xZ[s~!v HZ8:HKD$`brsuuA9Ѕf/_w]/y4'E^킚fq]Qhc\|r9ʶrx~۷x-6[}_և].K7akyvYqAv?4_bFkW)Ҋh !rErevZ+nnr*έu ` MOqB)QB7%Eu{+$,VT5}uc/ey6ibHRMQ.5ە~{ʊ줳wkævom;jETeá=Fu7[>ZB؉&H Rnmi *ӶcdRՃCd)ŜOUԖ$l@(b0ȦgEve`@/ p!I9_bL 0Yjc`B4;kަln79ލ0B04S|1ND|#[bAg4;dԿeUrAkd'55mrMFD;# Zp/3 Lq `$Yv;Kop=DeLLd4D`OþKm,)R/[wѸxSUm!LKT@ xX.2ه6ѷ^}>j > MCe'lV֮]׾jNݣF~5P޽nn@qWumAWn}$oRBkP$σ[Ú4`ɣjoIxp,~FǺT`%> W)AщWEF!hqG^BlNE'L@-.v"'ܔ_ƕ5 Yƒܕc40WeW}{ZUuJHECna5SZMz9(gok*Y@`Ժ>8W yꘊ\8/24yNVYSŽ%>mbp1OqVG =@) v!K5.]%}شGA_N 3J[w;,>{}mΑ[" 5YOA GRz:>zMsʑ(B 9]P〇qIhyPW$%,4 Waev9PVۗH Z}КHIruF@(V2Pǔ2 YxhQO" U \r=2ڴ/ T:ݓCʛbe(9O˾wM6}Aq:s ' j_GZIUD22Y@Q/8#K11ln5k%rI3, Xfk3TCAzIV?|@/? CL{:+&Ie!%&]' m VRAD;\o$$ ],҉ITS#&ЃRI!ǣMXvBx?8to*ǝ ʻVYiQυeHTMBp2ɮ!mG7Pq &fa5WGЊOla`%z6,@5BM1>V5gΡ!T|5sI UYeؙ[یLfk Da(8 RO顑!i ɏ 4!Yct'iRD;3g61`Reo[wYY}VcFc%1L/B endstream endobj 70 0 obj <> stream xڵY[s8~_'\V f斩ڙNf0Ucptё$)IX}\U ?ūvhL8$ruo}qUp#z#kE}۬7pݝ^7X F'47ɘOڈH*piШhQ!EXm00q"qLqmQ?*"D<_mC24KP~M`.B9c>EFb*D@dt$\5V:]tY3In 7Fӈ3>Ks"dK Kx*5 ĩxjhav9@2&[g GnB`#ݢw1d$˽glhΉ3IH:%sF( C'Y9~ ,B9}磪ྒһZw>*t8[Dtm?`ԧf4 RxY<3՝0brc !b0hvD"QsEFNueOG3`x(UHCw>y$̱tPju 2ڟK, LPC(a$%$ވB||P0'^||-AL9ŀ[evLÞsgw{YHnz{ԕ D)xAF {7'*e|xffF!%ZKܩvs$@4dib'agUk"$1`׃+C¸`btw<#19,J5֕U{}vwkVRSİ I$#3%~T7I ;{Bd0C[_cp1Mw›e3x@Jˏ ?k PPYdlXl!}])LnfF3 "i)ȡ2zE:P!p)R;\J'gӢuZUzMS~`Ad~ ? Bw.ո\LJ`"⪝+D @nZT}u}QV{1+Z]gНP@:f (p#F~Sg B cצJcnY-xyR 13f pO4@ݼHa_â$%YJLc ]w )2V+WѸ{7n:N;s۠ĺv,([ETݾiA%DdyLs^`_h5Yds@~+\ΰ >2y1w#<=1g<{;ٚG3_k_ufd9H|94h˻Gx\P}m"޼x)K.a!v9ʯx= 1Ka;N[DNEW/&:jؐyJd3ޝ*L,F*C( bl?2ݥj*MJD69ioQG:]_SCW|(@5!zuXnBIGv?r22{UGe9f{;r;vr1V\NcjJ1clyTI2oYW~a$9%l~m§Bɦe˒lr:2*x֭?1bMg|{IE1Ct9?ݮ~B endstream endobj 73 0 obj <> stream xZ[ܶ~!7T6v 5Zi>h5Y53DҬ=R+rp(n~kQRT77ʈ?2-6Z8gc|ݛ1&7'n?6O}>Ǧ.h^K(ekK%Y\ݟr5rs'RvoեDRxYl>9 d6xQ6Cje!}X ~kN۵ݞFjwmwjjMU_->٩ޒNrz>T;hybtvmgnk [t;5_CD #m@ORS*ra\I8 Jb cS8"{iC8ae-7Ϫ"2/2w ߑ,K24D(Vv=#K82!z v -4/NzϬoRSUɷԌiMm `/|һjWݕN i!5xGa YR.@WgXl6-Zfgه[8+-qbSvᓩ_L8|B'4 UfMUǤ,dy/`馉Tg/tC "QćP/܄H7+q)A/hߨ(VSŹCtGD||AGOs{u\SYܹ E fǞp@`(z [FVtwEzu>D6KxyK@aK>E2ێf P`7? {pmB>[T'3Ca7Q_WpO6 !qy@p}#63vw3ʺDzBͺwfŃ|1 Ak&җOMCp 9rM"#$I@?T#Azo(f0  8ɟ!I=4b K?'TvHdf1gFP_s.id"_y>KE)GgGDx:· ص9-iV NC41j؍. TS! hFhuF8>;J \fOCN%uF? {fq?{ B3R@n)NEq2/q$n$۩ǵCanRT 8dDE+%[Z&&_cTlxk,hWș?I(, dr$. 5\?*%dq*VB||OZ*E'rQmUa(K P>+eF(d."iշFX8_p-N"$KsmlM TW6RM|]к #e5b̂V#Ncs˟aN R> ~/ڟ'Mb)QvXF u xSؔ-'"iY¯d ??yAU5GJL:X"Zs >bm XrެZT9 ,;܈ 7nǪ&)}B?qi}u˥EG/۪ N 8#t2WR ߗ!{ʆ~Xa9swFGH@f?VV6XSkDFOB̩f?X6Psk Let*`9\m> h]M/)0P\׺Bl뤚r8p;[~xHʹa1}{$+L t},cbkgQvm 壡ythFK> stream xڽZm_aC gSMl pmzW,$ygCҒKpJpaVV|?*w7ĊkٯxժZ~ɾ0더2n-lvjn_VJprr7Xp׸Qy*fWۻu%~p޾ jj򜻮֚g{/dۥf"WgeZmL +ECcY7!9cY\ٌop[D6~}1w3v7n;ɳn_ۜ+1߽G_~2^b(QêyU)jM0fRlεtvN\z6*?ᗿz|&q~Uv4ErY! g֠ ϭa.7Vq`O; Iب `-|Oĭ9!wf 6YیSJ.X)TX4u+pN}[x olQ?=PGvD{=(@j,YpA7h@9  yA|h 鎩kٽ9^Z̴'KcnK=0/ r! !4L?a_ |Y2?c9R}d@"OSɪ|NP%*mܙ?u W]ֆTa /dؓ GӓCs>5kRxh8׻q &uX@8#LO{=p:x|Fxpk%~Cl .U~L5evŴp18q9[&@DV"4wvJ.}^$Ji؏M<nQa3NC kR3! :)b#Er0ךC8.3<`V׌n]z%({7 t=_\t> ̛nXl3%9> /%w N՜289^4K^gF%"P"~ߐzsz0o#Ycnd~N]|gꁖRѩ8:\ K5ӡA8K>(dX6DHxj;˜7N A#mUK +H!`Zť/+ 8 =F Bfvj6s0-r1H@#*'F֞d_Ȯѳ_V RA8  HÀjEO>d&(x8׬<^!{ *W(egvMwO"z/'RIKx0+QM\ SzQ 4sm(<` #-g) rس7$ /Wl$xwT"\S:d.0|v24tCɱgQw$aTBZ/ؐ4U:ʇkhuZljm >И2kp,$oV@uʾ/T; Ys(bzsAwmlkrAumKGBWčVw8Ar8zR3K(j> stream xYn}W +/"^i%ii̐$G搣$死.N~_?$ꇏr%8+x!V7w+bW7&RuTeOR*)-tS{8 䗺?z#:lY28 v Ͷ0#ɰ+itirMLd8Bˆʡ&$r\BgofRZѭH,>?LkÓҽ.v][saXMb\s,Iqc&ҮbR&tqV$f} cSAƅRDL,LtEmTr ygH&j3 dcS+ hDގ>.8}WTL!=bP!5@H1&Lk%YBt k[ 5X)"< 0"a\&M5 5VEi,b|(9TC=@"1]![T ,`}y>'mQV;mc>C\L7`ɞﰫ}x܂?I@ d S2ḷW}xNǏqbxa4A Ɋ݄8s,Q)z1OK4, gԆI)/6nX:&,uAa0AzgñJD9q3.t6QzA̍1,4x5d cQDU@*F &8AMՂ10T"ve΃}%U~]kOP֤LAsEvR81o{ V3޵L&9Ť;  Jc >-]if M>) '2OJEy!%q(ϩ{uӹe#BVn1q!m,I}#K/ck,&1ޫd2uN'^]`<$H XHgoQ[+q.8f^5.jghOBU(5-l^DJ.wyo_ti@=^['md[?xl2+2$ >6tMXsJ0A'-K݂3k] 4V01~|vpn]!wJ~>Y'<\ITz3u7c7`|}dc{험0ቘ˂S3,Bn3יl~OMy}TW_Q8=DN?&{-Y`3NSEcmnJSi+eCBQ|0w tNҸ1;: V9r% ׃X:1R9,BYge)u9ctN;)*O>5~z` ;mohYSL0?,w 2)c $Ő쟂1,9G(=ZPPpPw~x%q{+s8Ԟ}M7nR@q:E #3tnɈܖٖ7xH`K(//ޖZs^ޅ“4jڒ:|pNp: PQ\><:q?[ ?(rCO|Z0K:ز࠼@ѝez1՛<"e]4H?N詢{:(=px3|r} 3'v?^q8mw9JPutq9;b zz> -kHlh>10=$ l{=@@8r[ՈK@5%%G<:JGt;Ϥ7"R b);cm}~+ȨU = X9D,\\^~Yq endstream endobj 82 0 obj <> stream xڽYYo~ϯcXq @"EyhMSRcggX}X>F-K6 ]u~U,~ݩji/w/;%E! }ة|(l*/cL~fdj<usJ92X@PJаC±{OIKH/q_?0he-:>w-6 Ne8WD)d,?;;,tr5+*jcpo>5 |r^Y fʗfӃ 733MgS:#1^ / ƍsm6CϏ P d8e nDU)PsQaDzC|3f)H X7J+P%Hg(Ke`K&}3e2TOP81[.o ,/߷1f 7` }5b-u?p_sD$j6L}?j^e=rSR^ ]^ :ŞwMv - "E ZpÀT| B<½}22cV1dr.E\A=pc(Sץ;C kE`~/uX|KLExw@`ӅB*~+sfPMXPS9.άaA8ж[wjLWt1f{fZm B%C*l.RpXN"\yAZB+.-Up0=(®.f#AcKgZ()qؖ+5GGb7oɭO}V-D(R&)^b5nS-l`xO`}QL8J R.5my'3(ވj%)νȅ{5m۰D>V+Yid}6UBONLNgd A܂;j̩z3fSg 0 U˅zY}TFqQ ^,% WֈQO##tαE`an4 jc4 PiJO"r@9xԥF{*iQs1T3<` A'XBFX9F[Runa$<=P׍`l\x, ) yS #~G%^ZvSרBc.t.<ȁ/{Kڂpn+]SF]{tun.:\>gݺ԰\i'QW_jhW˹j#r<&ѯybEmC!*ʀ/˭J o6_z̘AIjއYkN(9vx|# )ht:Z):81S ȯ z@?",(LܴC{:>Yto4>]@wgJ6X@Z|u/ endstream endobj 85 0 obj <> stream xڵYKsWjmcyC7ޔqC1pЮ==򺒒8׍͇ $7Z՛?n}+6іhs\n0{b:csA=fR`1.Ԭ1WHė*>Ox ST*:Ѝ;G/-$[w+;KC=TՀOtp%sj`ҸK8!-,x8BIKֹe:w CV'W O!9|2Ng!r:W2'ߝuSjgnA]CPL%{h PW4Dsqܞ!/ALC]xm.]\μ )<ɘgYuX,ezܦiTG|g{$>,#VR̄Z~hN2B':T2 q+\&cQvTxKgK*o*f6嘤DTΝ ٗ 9H}(gsC&>Ǐ4,zZrO}qi_~6˻!\@ {1E_ń*T_0x2a٤ Rm(L$3 z%-iU L0 1O! vCq\@D`G]5 yH{Mډv Z^#\",C 139nl8p5?E# ?z88oA.zz TqItW)jI~ { ʹ< e+t+?U]'mቝ@Ă`Nv [< î@’'SUKiq&MR%;$wOPM:[LՑPҽ9-/]kJ0V .Z uys+J_"(z"hw *]ZգէfljYd&6 /L%i|eȥE93&_.WJ9dҿ*蹝E ,bCџǪFJEy D}*/X7n\XE_ݬh84/Aa+ [\EVPVxQqڟ˥׫6ei.7ytԫcf z C"qhkb͕Ua,/hlߵ5 hK|fyL)X`> stream xڝYYF~_! ,}Z z>e{fH[WSc}Wu_Uvvjnީ$.Rw)տG??W 1&Rчnh|q*sڬS|^픍48E[ƅTf:<~:nG9ij;2VY}2jmFIT ^pjG㋹Z:.L֜έ S?>QsTEuW6$9\!M?0{#̀'QW\22MLRatM(U4NUWWCǫ?SUCp*ǡ?xosxyt`DYWTe>ͮ;G$GVi&5q/g Wwf oNw;ڑ/;`uТ3HS"ڢ\ !SI~_`Z: j5Wd nGzzyhv6+ aѵ,V/Hۚbܙz^"3* Ri-ť&v~8A`U~½e%_џT ci;, bHHgY"Jo&B#B33etO4G?Epދ,lwt)ay蟆ĝډzDR+okvNsIe"'\k_|\K3=cKƈ8-g kOnP'ۖeB0j"7^<5m(}S4IPmƉ'}\G^47uE 2:rztC'&X=*Mj߾WNb]r Py!N ┱]0iO8ې~:Rp`'-2 NՑ!g% 6 p#TxRPɠ]q\/(yVy^VizG|d鵇h<<&HLVKUzZ' h47`.I MU\ (cO` 1O}W%R[c@5gNSu#N2w#iڋn5j!HڤI, *0`w ?U"?@iӘt%  x brT-Q}xХG.|&G<4.-/H`6,[-Tҳۇw%+mLf %^"Va/%MZBjk00,p[r]90-C,ؕ+(!'!>Q:7mcXW":G *dUceFs:oUIFOF)${K 7C(0zISNqGu!CF{Dp|MEvǁ  3TS?IW2/m[%JF_^ B uȴLlˍCݖu5xq IfʺDM&\ػ)-"r1ro*ƑP ko,']1 vb۾LBot׃'-ɺH6^},?iHH{Vz KpߔA :)NrfoJòix=h8it7R%t-,QJUF8D("9R hpɉjcY/л ־^&6P 9k32w8/$G0\~I!-PiA"ȀŠ2=/NyiR]!AY%~[_W+<\6[i3_b%Q{?Ȁ86>WD> vnƪFIsq>Z zX?ڠ2)`Aɿi/q> Ob~!*K**x'? aӃ"31ÿZΏ%c܍ endstream endobj 91 0 obj <> stream xڽXKFWAq?ZN؈("JB8xޙ ʟOUW3E EizU& ?< ~nEcV.Y`[E9R,p7_}fI)òi?hkŵ 1Ñv_uHa55݈,-[pŤJJH,,DI*W5J̒MN.ǩ׃>*"^0.Ȫ%ÌO>n3XFjѾqtʞ^aNIk"\p5̲VTX2X}&xJ'ӣx3+wﬗ; G:]OWuS;`=ƽ9<&y8h|.}+$qɱ_sbB w`jkWU :)wgXDƲ$wg`-n7)oW f ܁\ƖC, ~I3)o86wa٬s睼JT8 Y;އ f'\ݙЌtS!S:[nwU2B2)qR}9Bٌ%~B}:Sq xfSV)xu #,Wx nN5Gsнt@]{*(*2a$e!,e߂!EwKV,2,(L7 BD\xt1td4~-T|p}7j:: h;wLqv؋" `R-ϺFC=BZةHgcCRd*mF`j+|3Jj(j`J(qfܚw\뎴*25J9T(@s1@QE>͆qt7@<+|( ai~B/QtAKSLvXjOW-XGX@W%YJUbw!0C$kt0S8-!dd , t7,b*==R3E&`y.ESCG 6(J;s0D-G;B?v֪K ei;Uw|pA$Qg|A/Dړ٥1v5zUB,ec=у|nF 93Ix.D 1J|$ŷ;׾\d9Ewﳔ18-HTu N]ҲOG y՟4Wةί>^LIbFf֨|nkRhHIvfWwO #W,OZ< nWk~#%=%23yE$]R)xtE[zʓ|Q 4]B_='p)x8ZG ˃rkՒД" =}$ya~{ vMGۈY|EnIzm--5s Ҍ4SΔ~,*u*OZ[69G'|~\ciؓ5($W?a bFḃ>X$tr ~swi岖> stream xڽUYo@~@" {ۼ5^icKU:Fnnʖvq3"Q eiTwF$:$/""°*d c q9GML34tmYnjf>`'u4s£sbC&HFkw+DHNͺ3E>f]tymb!"@OdX2BΗ&}#qʳ,HLXd쏇5Gq)RLE'Eѽ->T+&_Wa=ξ:q~qߙ),é $h*0r9cP4?RhD,.!ȕj*P%b*+Dgy=[ݺLX?^ X`IP=ƅɇMgTli,’mg/ЁHNBD AC- B65^WB []*zuft aQ v ~l~);|)vYbu샟"p''a`\^2? /M]Xkx&=x%+$|')M_uď`ô! VEmWvUv  Nax8sb X/h; W !q{s2]e+T昨q85yhz\5 B2kioL)oMp˃d-W F~ endstream endobj 97 0 obj <> stream xڍV[6~"ͽjWmvg[MNp֘k@[%Rsα/A^7amﱇ9ve aeޮݯ1LP?<~؀0 }Җjj#kXugEvS_H0̓h5y# !ʰv+ת;Em@b7Ń$-Y-3,D˩f{Yʋa 10^,B*FE2Rq֎t"ݲrRVoNhƷF %%דg 7#bgQڟ`:TUk f1rԗ u"jj֘K5tw@ RS+!z'5ԏa|fWk3"4g*v3.c6%tQVl8)Ngl]/MΖAAܨ ֜GGjԒF<Й \Y ә,F[^=_)L8떈2Z eT=3, 8L:M+(o*CGs0h1R0 /%99ubjf<+> 85; h`0nFF[ûh, 9pqз+5>P"z)X) CLGM7#mK +Qna&4@ak8$5 3O-u.BqͷPZHuIS4'*Z0Kn =ѐ+!ӷlN%E402ӻs*S5]Q+)2튠M̙CV7q#]vy;vhʀ[N 8=NЂq~% s]SȽX9n'm/̱1v2ї&.^O& remE-q6drjHLgt@5m9mX ˠW)^ m% \ I4TxWG9g}VfxNݩJ_}\?|,m6lbInզ~ŀUPyݟw_`Z; endstream endobj 100 0 obj <> stream xڍKs6pF,n< 0ɒC|@N3Z :2'+Ğ2Bq4ldh@2U2vۍk!=ʞ\/R^-b/(A7ԎT8~[Uuʓ*DlP9uH@J14IR'y-a,!=Td$wI I+2f1,)+R. 7g#&NWYTT p-[+ah:4zґMhd"+9{(PpHYv[h"dbrh|K!I뼙fZ5YD@\ Q*3Q>*H[,jՆ > stream xڭWn6+YPwhӺH8-.h3F#%c9- Fs!QpTKp"N:qt{p4*mإ_",S,_~}f4ѡ?_^8l'qHk3 #CM}$R&I@ ^ϴG; Qߝ;r)Ξ*yyA7kD2qPggٳOjVV8̂%|i?{XhpM  wԫGΨ`|]CtpLLAwX'B\ fdAFFe[qQb^~e.<#. >lVL;l&TQ$u T6TPR+Jܢ'Յ׃;/vRJWW?<KoxLvMXa2l]_҈$ y0?i`T@c! 4dWn\_Y߲=iB}A5%R>dř ֶki9,,q>w%E*W L1+AY# d&_F_ 4qP 70*1ISvQS035h$?f^)7#%ŤLqWP.oPR`23{Xa׋ ܦ2lfBBp[\ )K`w1QQQ Z _Nꅊ㢆77fu_맛 zŬ߽{޾UqI\ح*QG-?} 6Bk endstream endobj 106 0 obj <> stream xuVˎ6+ E=l EK%f*3s)`{2$?TIwM8$e Iq6$9R'&Cuf6tG^QbUy{~f.Ç$V<SQ52Mk[τrrNf**d? ҭL b7$gCo(2i{rcF~<̂3̃ÍH}gl\utsTƲdAe⌎\سUHʄ!gSI?2[lOF7ֵ[Ϧ³E\fr\Tc{nFPCO>@F&0tqHWcipg+:p [ct&vU~% ph3< ?^Ara&h.qHkO dVx3̹ar'*b93ѳ>6{5n;t\Dc^ =umUu˕DhiIUۑs>ن&N)skstC֡!:?͗shv"Uc'΋<`v/>2b^-_4an|M3kS,"6tkj^MݎliygvpKZͤ@)"y/B6=Ji ?OU#FY׵SC3}'CxDꊈ3>m9(gv3,\搆4Mchgz?־3NSڗ;Soہ/:AU% pKd@/Fܣ0Dg9 -V8TM`nkg\$OȤ಩b~rcxF7VaLODB :|\sr'225Fgbi-&*9n`j՝93F"Te[{a͋L3keMvWC}Yϟ>}}|/-hnX5$4'qPmuo߿ endstream endobj 109 0 obj <> stream xڍVr6+x9!sK8-'%%nA[>T\R9@kuGD8JGU IԌOo'q8z8G,SuEiU\eYv S_~Sq{~xE<Qz:4HcZBEiZE4\A?&8Z <(k1.QƢ|"ۄF=7l€VqH>F"-6䫁Jb w*8%|3XVc96jy\E,(6UP*eBM9>d&2> stream xڝWKFWpd"uhhX(ynz͠zzϧ4쌣]iV]U_}Z ~B/7.Az/^y!yy.D7DZ;D/{q@Y^ YW/B<ʘb4VZc^I3 z4Z. ѕq$7?y?85u SF„4Ig|iyw ?곦.Q٤!`?ZJZ؋G*ZU܀^"4ŠQQ`z>HK}*7&AwD( ϣo^LNBLf7|,8O^,u]fWE/hr,X96;/&{Ԉ.XyY74Bl{a'=`A7P"IJh%T;r=i)pM]h +w^ U}u`Y2Wvnr4෵g:tXW:c! )I0+BZWZ{+y;m'.y+The$ThQW}hS~Bb\'Rzg-2:^1;vS&٤G8̢s6Zz#jMW=!rmtoau@D1K7EفZ3Hބ繂v\@Ғ.I)qWӬ v+J$\QWV4JȊ64f̰Lm>k𽨛$ P/Cݘ%'zj{Ql{Anp::N\j=yԉzZn0!6W} YFo cs; Nk-5gxYwd-P)wuuF/>~{.U:]c?3\xtiMEQ_gg+?ȸ@ endstream endobj 115 0 obj <> stream xڅs&+tP{k_:>Izjz 25&Y;Ife]VKB7M!>#MH!SBd~&˷Ќʬ[ݧ-ʲl~'<| {7;}՟zӎ[ZmDEHPIqSz`{G[•,ω,~F)yZxo0)H)Fњ&eYΘ jߎn_Ƀ>ÏV+BjL Px u[!渮KL$y\ {r,І6ӥ_TC{8G*( Krsӡ2욙wG&.2_RlF gO^6jSݟ ^;GFo] í(7EUVｴ<X\lmQn؞J‚>HeM,ˈۀnY6KENlÕ66o€?Ni"u7)WI󗑟*A䚕Y5f(y5.W 9k_$,ѤikᏜr;i')TqeJ0 w]k]ê$;njqeҏ*D:^)i~uTrOB" aInC57/ ⫝CjdM:s0'$s%:kcXN5u> stream xڅVɒ8Wp$91xps@](m@bdja)veg=2CPo94 ޡCC?R\~wWy/0 ]G(r?;r<THѵ޿翜Qyce$KgI|$|e8q+'|A R4\{HA5EkVm;}-RspY4=$!mMxr gxB(N #?g8Vy!͓hd|i{ݮM;WU|QG2%WFNj1`9XGD7\05+= Qhulޤl8^tm1.9n_R ) 6qel`^ɓKR|m%8Hk'X\(tn"4IbW@A2e,`PJ'-Qz*5Qo^]c-V@#dgqtHO~Es J{t1nR"L؞{͓a̕#Y Pz0/!XIjoQ+]{ s$3C\弎]+ѥU^±2|$[Oܮ2b^ h<@`[V0/KѾS]kXCTYv\Yu mĶ,KT,teUȊ]N ri69h}P9JLYXDn^mY50jSLfa"M鞉? 5o|%/D&}L6ؒ%602Q\\+l z~T?wcEC endstream endobj 121 0 obj <> stream xڍK6:J-HlZs@KVd=v˗OX+q20H JIPwc `WI9qcg_,S.o?F MF}U}뻮g; ?iPCX/a*YRBy@qUd= #U`'isEZGP +7̡Lcփ+fT&GBIP\LCZљ4Ϙ)e̿.) U񶹆y&!nss Y֘װ 68ś|$8$>]Cn)7Mczej(pܢLDO|US{#/$koJSgNc!0#nme^n" {oظӧ(lӐՔ+*RX\p[hzj4[s,&_Dp ƵjsOI8Q@LƗkjg;5-V &ƍw.o|U]]`rsu`jz׋yA]/vO"gabt/C1 Ҋ&Fe&߃_~V:Uw\Nj'|Պw_>>}|] "*lA>NR&^@Ҵ?Ѫ_?N6a endstream endobj 124 0 obj <> stream xڅV˒&+(BBYf*S5L&n: Zƶ2z5s @n']e=:=E8JGUiOYӤI#' Βy~bD9|:H>>OK+i< ' ']j]DkEe4%Y4&7 ά膹g豓YZ9q e @(I%;"!u_@hP4ZƓWP;n Y`Âsƨ 8- ̫$:O|/t98L瞶P-! jenPmqPA zfRO)wźkdAe'RL0 =WjzQv. mRFDg|۠( *+[㷧2 k#T2}W^S>[Իӟ643NE1^vB"ݴ c!6&X'FvI!XJt7g 8 lZJi1Sr ZmWI-p^JwA!M,g̶N+P'Uս$zԊ h1sa W1qQֶ''^:!`xՈ4l2d.{۲z98yM[dpzNo\.''eSΎA30!BWw|@y7^Jӕ=cRHtzNG^/wx$DGt kwƳ¸pWߝ u#L>ƾ[GOQqwg޴[owJ^=0Ӗ9ٻ)ΊL Flz?{S@ Vk04!}$C#H9vrO 0h e^Pfl) >lW˰mS6a (xӧϿ_?~]/@0> stream xڥVn6}WQz,R Лۧb˚l]ԮASذ9Ù!Ao4}.GL:a; `Yi9@)2rۇ7H4^~qYN'Tܓ!Be*@((LAO\@bMIyAe^0k# 8CéT ȳ Oz[ɶ z{eh~"d7&"៤FEep+Bd&i,ŋ`m82|$=UȝEQ !SY0ϜX:ںMyt I:4'+YH$s_!l8I$`/6KKG| GO-[M@W^|R,β,FKkzP'qG6Q ㆍq}$~aO;m-%{[io(yqgo)?&_Ey~:d(C $)/x|Z:A2yJJ u`ّi:nI4P@VS:srFՋx ׵XhZ lvrTWֆWtrq#ck&ɒ,NBI,?DAQlcBC Jܾ6vX\xck .cL_Cܽrev)E儹O*㴰77c(8s;1j7~Fh -,+~ƾ6n.Rߺ ןOLx߹y%gcMMÍ{h:9sgF\ZX"#t6Xhz3x_x"/hk&Ta G`+ju|w).f6T==|74f_1Ujݲ[w7kO,Xf\֋D&kQ!݋!w_ ouX endstream endobj 130 0 obj <> stream xڍK6:Dzl E|h^$Q`kf{k~pP$uz ~~8WF)c9Lw"e$reR}M%d) Po, i; |Tp !)\$!geG>bDZ,=E%$YliVAX Vj,a (JQsCE#l*r;٫TgYV%$'Q(9aem '$" Axvk:}r.$4JmF*/=ri*[+Գio%../5AL Fc]L$i_n=t#oC枻).L1gUo oT} {1aN1- >2 caKAmrC~BFT~i,zTD˖; z$NS6kY=/B׋bv; VT.Ԯ GIl#_Ym<볞wܶĻjj;.uMl%(SxC p 4yb&r :G6`*!W}uNm pQ V%dr 0--Njcs謔 f@uKP:lWXɳ BPmuʵ\ZA6-]Z ݹf,Jp'ufn"ú&Vm|=7]/^4Yq*{l5+s1]5\,WM^ p՗iÂ3[eը2uYWQ%ZgVN/knXd~Oʋ=>޿yYIGw;~ 9O'/!~ ?W"p endstream endobj 133 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 136 0 obj <> stream xڭYKWHfvN읛⌘Hfg?~ .0d_=эfT_6mhAlai#%H9lven;ª&J`QC#e\*}~ku)7}ڗ}Yu͹ϸΠPf:%hZG3BeVY4+w-qԤ٬}yr~U+ D)\nIRDOE&ɋ;S)sι0L6݇Pf\Ʋ;ecd3{zJ |<$qGt/܌zp K}㖦}QG0 =K)..?KAEۍN)U("l B!Je ˱so_(.۝=x>%X1,X]$OF @4/$0noֈci礈bߒ/$̽߉BŠ%ܐD_r!%<鵪O#Frӡ!q 9#Z8%2;q˸;6>i:M2*6/MD=FkA5 J!H-eL1Ek9Y})y f/C/[CDyTI@nuP=Щ@*d>DUCs1'@fVz=-L~wJ0Cޅ#b<+ t(de㲪`!f}9`D*uY'@%jo_y0ߧF>"p|;9m$A p Z\?7/fF)."K5m|vO/;raqVs=_2j?B٣` 6fIxynEZ:6Sw!t-*{aÜ t Ѣ4B_U,O͢b"+J|ObB`;Rp9WPþ>PHc7/0N7!+1Gp;KdcZ:l>o~I HR mo!Ne?D6 IDUD `%r=jń:z`pQ0 TעGT|mЂ*)"HF%!9XMߺ}i=0 [s( o)AG[sb%MDa_=Ή2)X,F9A ^ 0Jv6[6;䢦&ڼTLR 6UAuSI pݤ]@/U 充35S&b*_צSVve [RbѫLoڒ(DOPf\U!phθ/Syɾ`fz[{`Op5[ܧaɶ9T"*sp>W b~>M(@:͍T}Ye -ň~v+J_v܈04b,1 pU+6(kr{TWh{_ E|l&[:ҐK __qʟbudr\}A>.Q%p;Rcd~Kå) -P0,RZ8UJu&;2v.Ț4JGiV&SymӀP /&ߌ+/ Û6LuOR endstream endobj 139 0 obj <> stream xڕVˎ6+×D*]iHQhfvAKXDM0!re' `< er-T~)!) #d ugs ]ۄCǙm\^W:mBro$aB 2CšoF Qֶtwd:5i3&9LFw;\ ì>Ms&%gu&qͿ$ endstream endobj 142 0 obj <> stream xŘrHAtm7K"ydn/2vY)1aGX*?Tֳ-p/&Vgl} 3'`Ʒ-.@xݝdRJ[|mR%<; Z-%-fJ./UjOpvp1&^wgf/8Z$c~a,еٮjr/l1/]xװ[sW/}}j Ƙ=ϙ|#jZ4?bQVIjZO*zQ>,ҌAt\-t2: UuC 8pp^B dpGjYApTutuԼ$G8~dYZ]q&aG^:x%jE]׺C"%T \ԑ|$76|&M)HM|V*:z4 & '4'E9F$ ֌ 9 क़B;6Y"UGѱM6 9=OiO+jRVtE 0qt-> I0$̑ *׈f|T /w%=(~$-_cdN'≙X9ZDZ4/R5hKT?!d-$U){ +$ WɗМ5~5454xϢ=_ RhԲOs~^<5Å)ɫ3]2cv, īٲ6Zۆv2h><Jxa|tI3~nJ. БLK{Jܛ/+2NIwH[ˌuj]m+3ec5y4r^@AhNe7oaZχCg̮A> stream xڕXis6_Tw7wR7b(HbC &qwq)L 8 vbC^?K1rx<<ʑwP!4.}Jgח?{0M L/f!/n<9]7M6VVg~oX3é/Ԫq{AA4k'! ,~إqHB3J(%Bw!/S$/S8#Zzl$ #Jv׌/+Jd[0I2[vbWVl ƴ#+]rt/Io=1(|Àd ȁB#m@Vtcib%o%-"UVU dJZ!Iҡ[Y7)`[MR"^ndP[X~JaCU3B$L3d:G&tpF{D>ɺP$PQYLrSeCQ6tn] (SOS endstream endobj 148 0 obj <> stream xڽZm6~B޵r.fw2ݵ EQ eWqo )ɒڵN (r8|f!׈F f7f賳Kф2&Xat]gd9T:};H0JppF}ӶTXbp]e^pgX$+-ϮtN]i˼ZΚD&q64Nᩤ!RT)30ֽll ~Ah_|.oEi?U/WY ]Noʼ)8!8|} U,\+4;ա*r֎Ʈ09@(m5<AH;x..@d}ФI"w-c}G.+(xZ(!18$R0s|,0.! +XQP,mE7*\G>mzA$|MkE~ ze֤VJR d#vM3S5W㠇CiW?Wa=:G#Ąa3ņ L5Ń̩EBgozSsw a>d?ԭiJ:ܣEAWnj,%::釡"aA"PD9m5;0t;?gvp״)qmgOih>,! {{c٘B4kJ# -hgG$ ٚX#1 qٮS[ό \h5rF6YCޝh8 NV B V۾KA{vK?3%lŰ`4Әih:$\))~7%|Dcc{%'PlPP_e'|7+m$1ʏ h)q=t{z qMnh9Z~Hb@6˒#="wƱJ`I؉~ˬ6Wqs$.=WyA]<7A_6seEcw.(\k<S!J |nrׇi;MnYyE.ibXnԟr_#U_g۽UݜBŁ }6k@Qκi{\tyZ.WM| PΙA> stream xڕY]۸}Cz/$Ibvf4bK$g2(璔,g( bqB,8aBpDž vquJ2c^η?򏻕RjYԛO wzܭ]OfUWò+/J?ÇB,Ǵ ƹӎ]& p(Ł=WYH꿧Bs3Yp:'uӇƩ+7U D#u[in0ޖ]~!7Ųo vILKwۉ}j5lSj9d4mhe::M?TWk?ܙj -30aa 3_9[sȃN2% DY2l!i])×'raPhDc=ž.e[x>Ӄ\v=Q04K'q0ؔuIǢ2wN.ϩǒ[d9U} ޼64,X qf;2)>q^)4`h*7F =B;C(T´`/ {UڧնnrԀ)!5uW$8~>֥Jje5Y>=4WZr +8%1Jj9޻`=H*X} Г\fLI``]V|aB0lm9Viia2ɤM}:H; Դe5Sv0jVmU\kABM*1!V2#mt:4W,뢯h`I*m0^i`jg~\MUP]uq_w!e+aČ]P֡V+Ǧ=}hㄢzKDR6˕}fmb쾩TxIK OQ7ݛdH+..rvR+ׁB" 0n+K8ԹA68zUd;֒`0vg2slm0#R+@M_&8eRw>gv.B`NhݺlV["-!|v28T3R#}5H>U&ூ3JNj,Q[±$L3qʐϙNAbzr( TңoA_& "iќS$͐6s>*zvƯs.^sY6Jl##*gx:d#]$B#l}~WBAPn<]^%eP}GVu.aն#MkFk$"!}ȯ}]s@0s+L$.=hbQE(5iJy*˩.ؒOD`^y ~w Z&8*~۲lt'~6%I=|bIa|*C Kr=nBCxdz+Eq8p;e@XlGў~U: e1Ak׻B,rP91 ȃ2/ `(!, D)ޡlIrXp1n([2[R^IwteRRB\&FL`ƈu UjY_^=6d -J\"w\6c(mOb75!Csr}שi*#Mvwę 5gG{NF1# k>Dnm6ڲܢ é& /&kMeXÜ9*q>BFሢ9i/)Y._qDń3/Odid&ekHf"LL`\d,ofe+C~Jc^s`D:նaDLG6M?uu(;=Or[,cļ+=࿔-+@HƎHK6Z'ՅH5[/ž̰cc MF&#M ȈSO6A/6!ШnQO, `FxCLᾹz ЛMK8DN\I®f%/LiP.׆RPwtv?BUw y6TpeGچ;}inf.1g;&530ǰ\p 9H3>=eoOS~.XT ?!G=L^M:w]m5d"ۑp%:2<o~ha1WeHGbNmAª>b˚4LH-?oܞ؊T ?j2*/w 2V\/rK bH#Wܝ-^tf8%wGəCFz沽42s:]ȫ^|6^F}y?@S%FI.!J,d GT_N3|,0P,oeata$+g6'zeamIu/uq}.װm-o8pYK)7%nn rA%+ endstream endobj 154 0 obj <> stream xڵ[kw_R*x?>m4m%ZKerYM+],'9$8ĝ N4d<>.'J/݇}$|C Α, - tcF"X$g͢^/ OEGYPҹa+o3S&Y\]}j] iǜUu1}#lPa|vtAYvZohYe wX^Ɠ9@Y@P@ ɥRr?4(-g ?D?}Ue7bM1Rhޮz%A:L:דy=t, ˄< b믞)(QgS6\(tYn߄085_8!%WJ{]ԗu)\'npz<=< Kwڡ!ɞ­JHO_fPO|Ȩ.nϬT pw`y! }Qs;4BJo < D~/1^AQ ݀vT~tq/NWjvN\Mo^掼<IWժ-V"z]E= ,VvhTP0Ho!U^:P?a I`Rozx T{aE& 1Jl> lgsh:B=fGC D o{{2K#F[Q;4FoSyOCCX.TT+O>YOf?0;x'(N! ˁ(߰F^6od֏iςVsA+BxEx/?6sx=8wۡECœ}'MO~sp;uG&h|cV6<-Y}ySߚw>~Mݽ_M(~?iaY0l͏v7=_ή`nBɩ3ͶjFc~$7mW*7ŭ^W` >D9f3>fj)kf&v[D;mn"Ӫn.ywdhaIVde{I#ECSm]K sMUM\+ owwo'\]ЙNW\@_udf}S!"}w*ad(58>އ irռU~ /E5>f^6 vjwGb,(Bטd}_ 9.:ˊo]{, ,˺vns?{$S4K<^nrx n%?e9w[IXL5d×>=.ޯu9fϾue)mPaT7*, +W>خ?>S2\sB? |KjKڿ@ž𚈞oBgWI|UKꪪ+DU;'eր%* x Ճ endstream endobj 157 0 obj <> stream xڭ[[~0RN6O4[h٠Y^)2~uFU٬6K+$ӑFvJ-h&}iFfG35~}ڶw^WvBӯ5n~;$Ÿ?v_`(ׯ I LG? 7Dc\>^ʼnj}|YJܱObWJ]wu@' acDeyKIo8oi`q_5 ZzVY؞S-ghoެ~[^}\qnIijcxA ̫aDǨ{e|Hd~%Fɂ[+2+gBdj۵"R)'kTp ˒! Y8_t[Ҧb$mSsBF-J w5L06IOpp8B6n@9ۙh7*nJƼ}5xq TʹYxPE{ m~wۀoᏐjNi;y˫~ئ ȅ8&zߜ괘QCth^^(KmIɴ 'e:2B4UHu!Se. @~qnL(K@4 x}=lqōhZ"vIJe3 ;j&q8 Lzb(T|l\Fez>BKd4 x;kMrav@yN`ܥ@R븻@dG@ԽU*`?ُapT#f@+#(~CkJ,?#"OFj(8d$[*߱`W*Adn2 dzͥ y*R\ԇ>BԦ\*PA\>S\c B|Oah8A!=AOqFPX0f&<":&m\`jC\~2],H+Q4OKL+TYlpBM0,X~xȲ٘^]:g&y4[t`\Sbu,f+L?^ۿ;úfG뛫TEX9oX5Ka(`#p@6ޤz 0s!/fJb,Q D }}◲}SsTP%dT\yLIB!=QtgSMhZ&%a\< 3!' P44r:SvuboL`''!u9 7d,L)D4K3P\{:$Mb)fS V^L~n)äf,Xow[ϧTaxQN5H*S\i!7w58xj)tGf71b9{o^>cF0@A╢g$r4b.12-Ʀ-8u!N!̝t_[Ȉ8sR nyK8vYPX@T-అ@N#ٓ(4g[3u' IOsKDE|hHF?+o!y_uXV ƚ#KT 4 &*Z)󗲘%߮ݑ"<9׾w/.gVӊŴad@a0T2{@ƁpJto, gG&4 %TRn lNa-ncC9NEݏǛl+\:֥X6<#!KT&_8m/ j٦T# %9OڍU#X**a^R,+,3F_b,2F\=ՁWs9vaܑu$a8c :PU rVm9YrWa4ơ,4m^RX/CyāSqT*?Մ߯ ,^.tws 8$ pek2\ps0T6CU #b'8s=K tW!e1]HQum{$fJ¿/DN}vXM5&cP+OKJlDe}˹QJB캔(3U]xr'@F>·ǢI.pv~gx/zG%"..lvs2A^CsveM0ŻK:+$ J$:I> stream xYM6͔BINU9dg*9D{$j,E$+@%ݽ*n4G,EmћwA t~Eg.[s uaK aM4Ǧ%ҋmۻoOG@&Vq"[o|Zx$c)~u?KO\~Zל򐅗zr FAa ^:A$qͮ}~y邙im I$&څ a [/zt!XJ"Ƨ6ߺvϢmu}^cTM1pj\Y3uz%Hc/d蜚!RYyghr$>z=FRlTZ`D2~ P'p#Q2qJ'~׍q 3.t\tmH$7ݸ sl6o> W @B4>dMPsxC ًA\O}Hr9WI ';M$%s Wt.g- 2$\Ch}о<Z2/OXj(.$r%}\v4Od=\cpFD3ΘN!%C$qbD&|DgMP?*V?$B]C@!_/U#n9UȆ0:֗EtE]ᇌC7N1K6lozX}r3|(ZLXmё[ چt/g8)@1mP ^jwބKzh5?V:?fɕPbhi7jZr,RT3x;@s+ǤE)O[*F3?z ("Z0+#M mm`mfeiOjlc[;Y =5-Ƶrͳ>lM>h0B'ɛLY aw luFԮJz8Pځ& .ÅmGfe9S?l'.ۙ,Q5cnPH(1se)z)׃g3>t|3!դg~*{ʡ vP0˖[7h_0813:G~c4163{̘C ]7q 7ޮ(@@m*E~u309=6~m `VϤ_"}x85 XeS29 K *)[`[dj?t9cn(yF7ZqeQpCB6ꊬDWtĮuN_Tc>Mpˁ 'e*9sDљiG+>>,ESp*8W V9pCLdM.(n``XUc~ձGU3_ʜ +;9N Ձlg(Uf endstream endobj 163 0 obj <> stream xڽ[[ܶ~XiOe;Vlxʢ6\R[]!Vn'V.?kZm NTwnGNp˜(7;U2Ǖc>>t}3>>ž>aю wwoC݇ofm Zex?|f$9Snv03+hFw2=|/m5b? vśc r|w=Pд+BSEAoa WKg\CNG3.xhvJa1i zvmvٔaceڏuR* *ןaCvYax%ي9dB7M|V؞rKȻ`l5qTƾdx2ij>=g6'T 0ל pʆ"DC{X??aP;nJfٴN-'*d2y~L&*)i żJߺ>)%gIb<d˙kR93̔lCVG &^8V{Vg?6c=-( 3N/Fݺ|,M-PU SVcg/q)Y<жkw.`ۧj}uF3kBhYp6% 4XrR[v=g>dSkd3Wc4FN@. g|TsꘙeKEhy)nȃ tZxrDZl -lܡh%^2CZ)X+  saJuOUs] XŹ>A^YUhnY u% b `M,(m0v@8^,}HS%ds<,aeJ@KR FBkc!:(W!ًOkЋ%K @*"52OiTW΄:h) "PaͤXBenA>K$C9ŗti0 Nov?}%qigeg4)]B4o4%O|vQn^YՊi1#AFH&9[qJS+pϽGZuJ /ƏVmø ҷ,2EfAyh~w.g߀Y^N27K蘐snkWfNQ;<7^t ò{c 3Q 0(W"XؓL];xy+M7`ϊ2A'x?<&;f7V&z`$.C9uil8j GklD-55bk/*? FI.+ Im -t hwu6' =V87u2º!s;[j0p߬SA\]@ه\_\YBAB.ȱ% |<\S7 fl5~gm7r/HR0Nt5*;˨_SJwjfQ. ܗa ev.V(>\fJ|=hw=+r(L-U`xiI/Ijh8 ~Y%/j`\q|~lTVE\`jbউ& RxX7DേK?"zb|8 ]6apRpAp 05[͒&M>Ľ\*Mn:rfdyl t5/>rxޤaL[RTL7JoN)'+!f5Uä c 3@.UKf_0b+}}*}W )oXg ]GFqx#]ZqS,lK1=RSj2_%2Ug5d2$aϫYhe=5qyt +cZxHôvI\nȀ`fsi=?IQCdh~LzG^1R,?2Vo=zK'/pi(b<ޟz'2giQ夫!eNaEKRRi13:dU63ѴdAXoNyŏu?~]yě^9~~A6؊sPJykijؔ ^ԃ~5f˜Ϭàg:#5jew:qzz-!K@+:r{h NqLS>Oru=씬m_`Vɱ91D;=Gd ^ўoM>-ugMafyEТz&KI. Hc0YR&>O~ 2Z%iPg;Ϣ(7^εu)to1KXKn>'KBmqRJlW'(+'3a"a"Ϸ%~/V-  !`+Ѫ ĽnH|u*$V,!Oz< ""b d1/ry1I)zIB M(]@%lgxW0(b5ra*"e)բjBTF 2TxP<E 3K-PBpp|22N@S1ϑ2> stream xZKW%9$V,"4J^ϧ{fԀ*{qE- {~XF ?m?e߼QDz]lqfw?y,Cm !DοRs&_6?-|7󋅠XX-#I7蛷jP)pӿ⦥TXӦ"æ6!, m>V)viՉT5)|8@z?pZ1fi6;m<^Pλ:lxrHG)S{zL #v)2*nyNpDqLrD8w}˫~QQ,5cc-Tj#7֢ 7Mː8fl= g$AfKqРC N!>XPoR\ڼlµ꺰6i3 Fblxj mѿMaQ=er_%}(L_h=~wAr6A$\QmNUg Qxy_%MÛr;Ql1sTc`8Z7pј!E>L7j(J.,̝aN+82G:cb{"B'h98RbL#bef_T,0Q NJ vN 0RhŐ1Sp|;̵CE:@,Sij;` bPtaa5r D)s誾>|+m)צӢpI%aϲwsN:2۟|A CjR汄Cy qcJZ%MXvq[29ׄ)`4$ ,;(6q2:xLXQ aP78G=!j'M4/YHM]&V.3j G)lu/`z0zVݧDZf4_g)+]( xÒQ km h"\ Xص}z%j3(5˰Ik}@izHfzKyzl Zoe`DWW+ыҗLnB ʅ2[/>)nITeW _E(N<ǥF|o\gcjU3ui}6+b}ry6 XdW7 ]0uLzu~/ gV8U)OK@O8U<ѻ @Ӧx~cNymc?iEQHQ=f:e)Qp,{;{>Nplq*C| T˯171)%mvZZc!#F "cJC;,l~gP;Rφ@aK0kݥ'AXF bg*$ne x?o_hhNm=9zH |zEԸ½苾 5$m35=p &;pB{ߡ/6BjWb7&auh#TXŌm"9^TXzx4]4fv7mdqd~H4($b?4_cBil8s XN8^Qߟ64'DHB> stream xZے}W0o`a(;RNTI)?Xr "%mO%YΥ%==ݧO7~W\_ܯ>^={!Vd4M*z-TPg$n \AOڠLMY^ϰD?:O' (쓊siCg@uήKѵs0m!Z;Z6ϢȃZ0.f:3Ǣ!LRpWEaL>%;sܠnԢNsϘ Z0E}*RHxNR׏Zd(?ܴ yI v\LڷkaAkpݩ  l:F$Z,iY.w0qP >xWYRu=IBXx v ʌ %LRv-ce}M '766\v۞.XٽFJ' pa?Fܲh5qob ҂t6LoЁм13!Vݓmj*leVVtFtr:_۪:'6VWš5F rX(-b Wx@cSBLL$lďr{4j5*Qp7p'7][ ˮ~_wG; vV 5W:?3a FݴM_"8e@#idJgS*6O/~/05imTe֧~vXya(qIZh$Js!GkyRj}52v1upоvxAweWnx/S?3aG%(_l.gd!î@<@=X*A_~Ij" ; ɒ8#E=R}0ÂH]q[@23З1< vA h3mq@:p^ xڃDl}k%k 졊S^}:qi(.A4}U"o܋1V1rQ|ݠu… S0+CȥrC9 IoRB( }==L|v\.tS0c% *\ѡtp,y0^Py_wu~_(5^3d>fe`s1~_m Ǜ6Uߗ83~jbx0y`wi yd:GNuz膎%6n|219y.*rE<6&)(#FEu(7Bm6LlzHryQYBѾݽ8&chUav9I'5eڞc=%铯-Z 8q/HN;iT"EeC{ nN bbj6UO8{/E)N*G!W3\s~ t ~D( 8!@/Uw2:u.P!' U>}r5dcԚڶu(/27= wOuSv{h s۶%}fsUw\)tk X9Vh]əο|W$'E_h4*Ύf}:Zs3:eI=+7s0 )Ec* 9HfM?Uþ m4E"A,2L|2vu0 _ov5P]"nHg2 {4ڵxO! غ7# v Nb鏧 Y=u;>]> ccоƧp q)E!Džۅ6_Ƕ* 5PigPѩ" PX[(Pz\dl_KWu"<{SRx=0Pqb ZV-4/ jr NXp(ajpZ\@Am/iC|k NI[;6^\ UeO$ r^dwSnxZ:{'4\!(eY ĭiFn|D~r.1sqaM'WH~`q!i%] 1IoFʵ72]FЃMٜ@𥹣UG@-Kz/qI@lX G&V;g)1j~7<2Ʃ]FfWuAqjlFvԧ9Nck6MN`e D̗B>x> stream xڵXK6WEFhI͞ 9,LtCnml-əidߞ*>lnw;=)b=XWU̞2Qcf6m63FIIKݮ3f3&H)mv5XǦBRs7&n$g? %d!&L2ܰ||ly^uθΗág8M*,w~ٗ7 M3qjx6+?ycTc A\ ga&yZ&e~aٺgn;GBHg>‡j/+"NӡpXxV4+ Bypg<8gh0 Oj<[3At3X<e0S8+ ?uN Cc?SI R(˻v9S4 <|]W]9Իm ҠJ6i*i<&wRz0آ []JjVad)1?X698<"AK=DG\CZY\sl`@ p8%CiǶ!4(רTǕ SL|7ʢ?Z:w\\6{ʈԥɾdh.e[ sd_ć -e=*54 ߜ ]r'C* F c` iE-vixYʩ`>Ҽo}34zc~%-d U}`/oz60Մ#x;& IHEX΋BzH&T޻h! 1]Q0hsrJ`BBKrȌG1JX, ?2Uwb.'q[JQ9QVi#aYMUS] :~^q[c` qx C8`3AI)13o(d{gY4:>;XGB8I0Ϲ܀8掕^(q'[ PD=/UsZxWHqӪ"Rusƽ*V^ޔ {/nm {4B*H pYYV1R ͈<|MǚP╙ p*Tf~Tũ T^"q^7 :QId"]CqrSX㵜2Y1=ӱiVALՂs,ȘCa@d7>|Mwcг_vaY$ʯ3w`-r 4 4jЋ[ _Ay[lYc\xI1 .{JP85]HP%Rھk/B҅Hл dyAmwxʿ@pT'2OD f:J*/ϫA7-0;KC ہ+0^j^'{-1& ]ttpڽ%%k-u.WݛLz\ze*UxhrU[͗~~]j?-goC"e+X=0.QM%*9~}t{Wv~D.$0^-ū]!pYYL)z_AqFK<|٭ދe+=cŤPPsJs4ָ0'"JsRPF2 =YCmxgp._-R+g=5Ipz5dA  a6{$V<1*zA4yԍD˱M;IK;vQ.y"$8'E186.}L$2.8tX6ۢ6yY6c8[hiCRROt3/Noj endstream endobj 175 0 obj <> stream xYmoܸ_@@ߩ.Ih$]Vow哴so6%@/EUp8^}8#Zs;z{ysγjج"|,g&[lvst;9VrQC~ukBj1F3RMk$,W-m "[W . x,AS"K9GOiDH1-4%K#M,^QQ:4Q92!X蛤PIlhj5X'wv&vzƗj۬VwvuGZhyS0DJӀm@nSNw}l`e$0j_j;<dž:;q0P n6)=LnCA.S„"Sx2{[w]}A훤$%UMXӔEM\04 DkgCs(ZSLPO^ޝ`ts,EasG+I!<& I '?|.SօTY*{*=no4TcBZ;wg~Cc^Wm >kv$ SRuӦId]rMy^!̎ ).F0%0L%=bFY.ނZji5XʬścH]2Îi5H 8w/7D7{-Ek]c~ge_ںmPlfa} 4M(Drpe}SIU\ӵd%H6[}+ܵvaAM27'4A11G;63-\+Na;7M "_)P-g/ez]|ΡNBbwRCx<4I4d$T0G EU߷C͆1K N{ڠ4e{lr0f;W?aQRD ]4T9ہ|\𹟂,R6/'K%a`IY)=+I9^ygLh5`5jnn;%eoϣ9n߫bp[l[K[Yp:P!@߹Й$\ !w+}/yvuxcVKeQ]*0} ,Aiq?-C{]q}Hs\Ge`zf鰆(Xvʿ8;)K/cAe?5jW_ah;6&>37kW B`Wg~Wd#}} ݪ꒾(\πˀJ)NMXRߖ-ݫ<ƁUx F˦}/.4ukWaz9jۦ(O}[ (=}GZR  `);0 a|>yMA#DD2%J ?m/: 3˗.x@W.`E' %A.=vOW's`,E g_bi^dw?ʣ) מ`bs8O_89ij ⊒1RMimJ`+)Ch=5%FݽB9_PߗWoyT endstream endobj 178 0 obj <> stream xr۸_>-X\yI:iLmه83EZb#ZJn",Ѧ}ى'q98?-؂?9j`dۇ+LR}nS_B^R䇧P=.?i!9#0'MeI &>,S8ج;ʤijeer, KW9l ,_Jy<,7Nʻa1=\Ez:6L) g`r"U6vH #R#GԖ~n㢡ܮ>tp5<+FTY,R0SxnvH!k^gNk 5qDJXݴcod((e' xX 2gf{*%79П 8 ö5N4h~άj'@@YU5`v]c[|"Bx*, G@j$y6F%nmVCɠl< XOKE,Sj)x r5 UHn,6~-=|=oA*"'b<V75̹no<"Ș #Y%%*v1aSF v B"J0!֬;vzo6`;ѮA9 `a!ɋ fGnP<@zӕ0*N1ު_ʈGas>JhT9Ʉf 霆"1j ڑVFvK&^_[;+/R鴎V;z>/c D#6q8GG&Mq[eKګheGȈ Ȃ LL_'S?sx׮7B"GOhv3®EQx5^cH:n;I}4/=g,7SH d`ZTfUf7 \D**'c4#Z+UI'W6+BIOI9Q2{z |6K ,}0~}LlJFA{̣3Do]t8<'ĸ Eu^dvlAicog=21i˺@!|-br]Xʐ)DrOϫCU>F{ Rs.Juf{^H,D#\]^2ˢ> M4 qL,S^!@IE9ZSfcdw%7E>xB[Wu}g(jxDq2ט`Y a1r zbH^zRʷظ h_{bAmsc*n߯i#*9K3~C/(/z, -kuT|v׍i+: ͼ1`@٘##_NQ EQ:f  (Do_$Gk/313!dX $6 !*'&LU81Wϻcnm\ Xٶ,8G4I-[4hѭmj2ba+n4FoOJ1x^GwVpH >OL gv3 K LL_<N$Dɾۡ[J_9Kf8{q&$ةJ n}.Ě8q=vg^]Olsf 3Vekee##Xd]z7VC.e%UǿF^7wa%԰F2OA~2f[W§rLz%QjUyl fʽ/G/IS:m͘ERI*:+bNfyuiIznnՑB;vm8mY$`l;8;Ƿ ( Rj ,c F8!WCM`w1;;/c4y{"p]}D45w3M)4o>LtQ~*ų/_( endstream endobj 181 0 obj <> stream xZ[s~C;Iq'КDB$%Y Fc\,vYhq'f|^;y'gbvu3L(dv;3$c/ŏ Tkˏo*^G?͎F D6/2Z[vSo#'mi߼SCf43ƹp/,UmHY[TeYcx /٢h@D԰9șmkXrHcI:yUh:n51#ebmW!B)=[*ܐ7(~%M緐0BZ&uls OV<7&6{ې3 S=/(U`-DtрC7Uux #FFMńIKB"kN\/ ]j˸5Кx˻5mI|kRe%O+tMo_ Ұ$_A̅1M2?>-K"  ڛbv"R$SV=i",NCX rJ )3+;L؀eC6bfA{ p&DgeR?g71ITJﳮi |_w4ZV47lh +t!Kl4ҿy]#<(ޣQ չ_QL~:L*fgo* MF&_Z(X;4FqתfUM 9 ;.řQcbp`lk8Z# Ew&ĥw8ʳU%{1橌,a:@!ʼn8Et;kVp1"3wIWVm`u\8Vh}"B[?C6qpm7'fC8)-|d`@rVt;5}!__QCط M{h]NhwF8>ߴPƂQ7)CC:ik\Qi3 yٜ  Anl] YbKmVm^T.4\@)Ա? `M}Bt{Wc;$'"Pl IO(fe<Ҋ'!,dH&xˎ'a}]#lhuϖ0p 0%k̯fxE#:\l+~6\q-cS$ dCӴ`2fb"G$Th*Bl+!aE\`¯ˡְ3zyD}RAml 4ɪKkc載ޒDt9NePIjc@!nlʣ VY7,T#7Q*:nyHx 4Zf[?Dk  cYDeto|g *ᄐP:fu9"M6_d3$&yWk/.XK*%0wp2< F1 Y :'O(f.̚f鞀Lj mvUGj5V6CX. /PMYX=3 [!31,Plzge.6Mub*}q){4> stream xYmF_AdW.D-VjJYةٝc."q3ϼًlA/[hONR'g fL+d{+eM[|' (DV? גH%'X =.&h6m:$@&[q.xg\%Bb]t#H*O@_?]_37zz/E~,0# D)/ie)=.뀷NfzcJ[.eWM8 hX=ƫ#BZl,Ħ A܌T$fYSf,#v}Jݚu I۞ɓW5C-dvĮ}!Z͔+!Gy.X}K%QR'~Qi01mpekr}f:^q֎`QCvBc2!]ܒtku0q)RQv=JnjGh8O}P*pc*^6!?,}e}N> M־)pHηx x*L]QWNܥ%9uWs\7>`S\{N~Ш*!-qBi]d1_1.!Eš/JPS& .6߻j \pi8Σ)I 8a6_S&ܩ\ _Y5eѦ[jz2ܿ.('Ihvx4}"(ٜgS#"f~3~Ī gbbYy%u|ÈOIB!,Y]hтȦ){KRu}H>  9=>f.4i0]<#/LWtYIˠ.sJApQ=c]bL6O+w`lh0f#! FM޶{!IY1=)6HP+0 (<|[?No&1rɋ3y>6Ô4ᐄx1Cz[/ *Z$Icqjlz&ϰ_[=\ݗVn6XmΆ zh黁*^zQlHܫFQ wΌD붹ͱ8;]\G+BQhfkoU!n 1p 7q,mqq}M;JFVGy#L-Oe6 <wLfG.bIÆ dRKв#B n({UؠH6Va(WюyGz~CRZ3 8Pi T,MO} F5=CB̽ӥ 1a)΋o./K ɂz)y)-*9q+닥p> stream xڵZm۶_Ԍiێ=It~I<kTlO|w E@IcA ],v}Xp#N_X?,{)bqs~!˵_l_RI朂ZRYQoƟݮW,Wgîe]n,y%afVI5~؉.gFOGaԇ҈'zϬ[/~"65LZV5/S*}XOKeKóbx׿&+2-dS0I`o?7RCrPNO0.U<!*edR~}]liɰ|ưαܻp.ZJ6V'&9'nu͒Fi/ZM]an" &{Liμοm4L 0qM ]4~MUo%y~X seIdrȷ`nwy/ts>epO&!0+H˺נnSzskA^R1."T5$^R!^v<({̂!W^4C{'-[jz S$3TȬ4d}oSX@fmP-[٫ėE[>és`aвSZIP) 7EC4nm/C}l =˶F&PhVE:W[6R~-|15NXxu+n%qum\1Σ%.)bQD*GR6tGYeh½ahi G r' 2xƯpBR ZmP~ISέt>(Xx[ҰƀmQ~q9xs׫ _&YeA`NSB 4~Nn%iBƇ ahat{-%6jRbL֠NsUɖ%#J{pD3mP-zݹ Q:j <ЧX4C ̈ؾc?l?dWW$ܢZmKzxBq>HhIqו)32g[nVeon0Y8,$P4 E}.xC 1z~[$?gH5L!D)N vTa&7F6/~IBX{'D b`EdzKg`01S1@K՗I.SӂpUC\Yd2hͪ &\gs颸nЄ(&P|l8@gȪ? ##Lȋi9 r0P;( a ϰڷj\W8 E yeob0,-c^=r8놣5}KO -@͊jy)qEYtʁʿL)@Hc:4fj̼k9$9c:& jP*}(i ϣʸ5S}pʌ"]H v<&"B_22u. vyp䑓2A&zM28&BzXrU{>y/B0Azz3];87> \-_E(uQQ^ 㒒 Mrs|8hc*RktvU9vi?z|5DJY?0;Ih뻏Q(IK^i],W hMϋIsvh|VgPKD$`^N^lXdAfCH{PnZull-olzhFm\5}FW^WicHlN~ ]mqcot_Òsu<,B"δ^>!qG|tOdžTw|_M xF#>=ݥItG2\zVq'i?8S8:;a^+q`zE׫Ņ/WO~PYz$䧛?x endstream endobj 190 0 obj <> stream xڽZs_G)sBI7Ӈ$ͤNҋ-6{w r9ωAb?ꏕXq'VV_펫oV~+Ys[ ڭnx(lRk~Z}7Ү _ 09sBgE[nb_~Bnoqgvhz_Üq J]z.`{uj8x(e}}1b]{ ̄V؂EN]hZd0K0aZ˯|:!EםU}O2Ų m={_CΏteek.]$rݩ%r O8x\.2:, )j% 3ޟw kVKv,A~^}{+ԢN0A%_ %Xx/U~=oQ2!IP3)uq MlE9aÏ"Aa#=9"0"uU_/{}.ߪ0kΗLAԢJ UX *>(>=n*+b5@"7vZ8| ZL'] *e(hY1+R$g䆗(7iH n]eY_7hqf,ӴK,k$7שDd8^5 tI*bD#H,e!f/UDc9&Q bJ=R|vzNXo\v|'`[2l! 5m[BmӂSb .p)5(bEg1D, X:Ծgs;6* [0_ "Hc¥V޵b*)~P 83 &_6 lE?o U!fCSwֻgxbAuw`b~"q DK㣷\xЁC#}xC;/E_9,f}2Z˗pJV怋ĈieW 9&Y~1X搭J5ܿOK[t(rDo)n@S3b+F]6!H˄Y%E3e b-ObDtCrF09ႉ(h^&ggN_%+5Ȗ3CK[owur` /h{ M5Q /idwa(OWqKCZȟĢ5MƋ8 tGsUŠC ѫu+ a9m](n)cM f'vhGdN{锕i0A} V(KK^k057|C2M@tx|.,6>ߢG#!q2'`1cQN}bb@Ēd\  Um).[1nŌegF $$Ѱvp=#gʨcj#q=;]jH Yqm9) eɴ5<Á9$}Ajf)$Y[dpyE4^hxѷ餦W!Zwު]ӔQX*.PP#KPy\jDʬ!{#O;d %T ѳ$`8r?R HQ2mf۴:&>AL:aUW: Ә|:wϏTW :']L,5; @ƈWc._(b\g z7P`)KȘ ܀;_Il3lI|SGw_|A{Gu, Ux,+o2@Ͱp+jҩCчhp~YLȅBrlL]R5oў̉|ښXaXvRϨ%n)-Һ^MIX ?tPYjԠC `3)$6 kw=MxJS`8Sw*AIwz7fkb*Y[:ENcBZPPl٨SM]5]rP~|rQ9TPI: M7ˬ,¤Hz  tmh'/SWn}z͋U+[.ȡjf ௄oT;Vou8 o`IQލ͏7Ӳ !kȘ *4˵:״/mλױcvMMt 9l7Vc'ާVUe+֍v Vm`=_ $ye[:Jh:#MZyX.XPBEto"'|%o<3 L<[!= .w}يuxRmLPt0}<ăR,vmcKh3V2D^`ML`Nx@P d7_ Pq2U@+o%`xoCM%{O^HN>z"ű vS ,o@!G {uoetz&Wuj kи$:(N6H&D[@Y6yC-c:˙˜Ulyl6e~m:6EBgcTUgK^tJ.Hxx~"3bj=*on?,sj&W]9&mۦ[;)ꪯy&e 7I1dD5߅سВ!-/έfLΏ7` | endstream endobj 193 0 obj <> stream xZoFBS@~l^rH4M>}ŜD*$.E+[%Zo>ŧ_/2jbSV_\.x*_\?$&]yBHL˸7˕2)5?vkWۺJIuf)dpT{͑W *pY\9^)Ɨ+mDߖ2MH ׽5;EX)tv<jḰ:6gźlGEr]7w`ҤkcSɤbblBߡ;r)7 YL؋Zۭ]]_F=mc};J _2c|jS$܁" 4< 9[;g[kܶ疦l/Hftp~ pY,+e0\0aiHA\9GrڼRiRgp#) rPˇ@]Ψ+Eokk*NeLWҿ23A LkL `FViT`t6XٚՀZ? SO4w7HFe'>"F"cB 7(d#3R"@zN%F@:Mt8^axCj@3GlZxWԻ]#"*mݶH >K natjbtvs.+ Ml> #Bl,h5eNljHo*|ӂ)e!A-R(P _Lٸ]\.G,0ж2)Belʮy dlr+^h6Hr)LrOʮ-O f_ VٰuGzJ9nKlTG`r l]%-: )@oJb1сirD[IcLyLa4ϕ{b)n83No,p696eQ̌epw2QM5=Z@ }/md"aO{ -s` $q>u^b eJOx~1±a~ YD @HpO8O?E?/,xz:i9:cO@gZW~Qa1rF eQ@)'1-,Hy,Y`smkS_>s.£*4ę[I_C|MŽF7dr% r 5 yIJYY 4K8x[sytsjBQK[pAb>\}UG6?U6&iuYphkC©ͳx 4>?]Zlۏت}:Kڽ;h9] xDZI4`2<#ίuUqb> stream xڥێ_a2:V$fuMEZ)}#іYT$*m˫)fbxHM7MNo7_W8 ˨7MIXcFΌ]$viߪ"p?ؤ*rD7z#"՝GڥeSBUa xr|IL{9l/D[Q4TE' | T$d;^\3C$7ރ [t'} N)  8g59:خG8`rg_tWD \Y7`5v>6$NdU3X!Mh8s2q]yJ%s'spgg8RY"VWYJVߋqn]Ðeb+~KMi GPx3\`cSxÁu'Kiw҇KE+ߜb`k2IWEJZkk&W U.j4Z(\jZ-0+Xq(  v)VH3\};c wD)e6R5F D^SDyPyO A:oGw0HW h7QI^OmV¨+n$Q\`FeY@ym3Š|F0Tc+ERF$g6_U!xH^uK`S>ܕqJi[,xAY5r3XrTUp]CF.Jʅˀ ;Ri@Gh[vFKm0ddJI%}72-$вT_9@WY<ă eo/Ҽra"%̾ F}|#ĈF$Fp3[gXb! xkŒX܎>$b&,ScGКHpH,HMG7ȽR?-uBpFN*K-WPF+K@ev;F8&#_h)&`]x|q  #UL>6cMMw:MiXWv.B>ŪW7'U?ȼK *?5~z5,*26a%}ga+`kk }4w_Y a^W8~ SףUcwe0|"3G3;+ӊ5+l4졳%;9<.\5 3ў4+OhDڞHB2w֥߉& ~_-R4͔?{C休R%ٛIpn#xIj܋ ZͧTݛ~Yw-xkZY endstream endobj 199 0 obj <> stream xڽYo޿/5"}i&*\FV:6w䙏XBٙӞ`E-C\.ww^yhi!1E&o^Ʌ".v!PQcR(l7?[J4/8OUwe(`3LYSRSʡHdeuB[Zm.D&ջ4kzz?k~wH.^-WKK5LLf@ME"a/n$T)m߼- pZܼD!Jv;CΔGa)ն~a%-'ޣ7д|pQ Xc mgGx* @$7 '*ҁ e S/GqV}UҴa_ZbJG*,kbQu(nV!Vq" P88$a7/CޮD eQhoy:ūW&9X\{}AJ￿53O $*DA&hnIOg2JeʋQ2SЙ-X2@#0wUM pXRGru}p!QMEP~ݙhxY$SHiM3Mk>*JESoveLDPn`c磗(IT18c4mh0/"!p}DY*\&q`,WTx l Sn Iiv`kmFi: '@E# s%a4 K6wN1Ǩ@3ar:`^%- ۪۔q9c%TI 爬#<Hkw >FTNP9Esn4 -LǶ6"ܝB82TY1SiyNIuÃ쇭ͯ[nap( 2{ _s8`48q\XY.3d)x8"H  d>՚~hk=JIF٥@7ΏO#Qq :"!rz S^"* ϻ죣b =H 3^@=Y)%)U{!|%es TQHʑtC[_BkW\CQA|l"6]G%KTo|ÓV6%ӱ/>(#xfJ QH@tU nNK䑷=!¥UxR, 0Us"bWg.Lij3Oߋ?J?ݠ $>ugV(+'bb5q%ҍ C& mdp7 .S}GC'^Pk$7QCǒ.=P4q"*iv_Dub!A1Kh["sVHWPE63q (Bv=Jb03/!`YI SPČ: 'qxhI9r%<)g&xzm66#H#b+Fq&a@,=!YՓ#&eN:+UVTc TCn_ԠY&3%`Grxud4]RwX>Kl^\ӱy{$dz(,VX?i‚ǟT?H78P'BOXOaHsC$")5DޖƜyG\[yNk* -n 4 ڹ[I yT۲/\8lzN'ι}oCNc֍)\r*m\^WlVc-%H-amZ]޻npy]ʭ.\g,&Um3̧}i)=$VCŠ{_; ) ^̴2JR4&qڨaM:L_w7RL"r}SKmب*E_)cKn WQQb)xH^+fі\O2!+@(!tB)koVıfOیgb4LnugZf.g==9#STp@MM nK1yXE]ٱ ~N]4`z*M! }[Mk4< #M!LR\x$P1 <=?p^_*|,lxZk:(T С<s=ܤ%??$ endstream endobj 202 0 obj <> stream xڵZs6Bs}(u#7٧n.3wo-LhJBRo(R;I'@`wriEW)+/]?oV?c+ԕ1PB k9u=a.g!vkp[NxTʂ! z$TG辷>?>c [Y<9At(nl-Krc}!R\NE;Q,ٷs {1bvb(sי4=Zoٝ4ne_Z;t)AL^LEFaz *d%|DmQ}QB^sS۔Ml|:;-Ɣ>P_Q iXPc(#]Ӂ |h8ƣX>E!N'TH{Og3wg#ʣ ޒZ7wGO?3(";MU`&]> 7ahhS$~%'x F3c_&*~ e5BnjChJh: cyDD [dP>&n}\DOEIS= nzO>7u*[͝&aHvs?t!N;֋gxi+ԃip`,AJD&j! }K N 9_!Q*E-`Hdƾ|_BX wDFegA9Ռw4 Ziж|thBWޒ=SK^<<П,x hC18ȫי (Lu.rL=́ț={+,(dc-_x2wӹxeWQc{I`Jd+ٛ 1ZH-8A0ha Bť"NК?>w⨛TFӫ(SqgJL F0m"!}O&.l`kyo`9qJ(!J LQasts4{.1mq8#Y_x0vǺ뻃^tЇb0zP A`P? `I6!ER\M/\w8wk&& jLU>]},B^P|# fE!Wgxv S/4J`T7 oz Voχq'P^=8lqb+Zd*_ApuX%_2*F?}:_ А *­-|~a3b[4elV㴉m=Hݷ"|`U2g=0À] 3^0LɭK$c"rǚ]Wf}:d6yW,X{/zA$ <m? lmM}^UpBLF!w2{FԮd3]6 ) <ӄX"iHhET6,ꩰy4wOFfQ[6邎A7rp'ı?yX]>U{Ԙc} \u.0i/ˣ^PU fRzIAc(vuCo;pwvYXh8ES{ n}C6tl'7ۏM<, endstream endobj 205 0 obj <> stream xY[۸~0+QE>5ۤMȶigrd-DI$﹐dI[DQ$|#zJV1%\*wo_U".*1$2ϑV_ydÛכ4M#l76VяU?4Qy:f-hU72Ʌj aE?Uu͓h㗊عTٞU~ϧԑIU:_!2Xd7yV2୮K6bםB3/ZMEK2UbSՋIď_/)C3L_%&c!|f07xٞj [UCu?h -?6!Йww,㱭ywEެjido}šb˶bek;}v/妮+3YȖp%1&Ĕ1"M )Z$0SM;8$BIRF [8zcw 2ZRAjR}}4n7z>3fl6eF:!$[XyAL<Qzd@-E,rp}_͢0hpkHpȒ$(oi@JnIF2E b|ܽqI풚E&8Ȫ牌v5\Yljr؝0Pb:ᆁr(*9-Zxr(G쉘$Q{_™c3ao}A)C3f߶/ @ ]nQ3B[r|,H ` F%!Jld@&sw;/ܤդXx@)|@4 )Ωw}G,m vRxxv{Q}rnN ޹GB؄Q4^|;qOYckw=GNvX,2|KN `QbGHq*yj$,"V`?mi0 E1NR Rx~wń~_(kU= pWkЂO2{jػǨn.@S0j9 zkiʄj- ~a %V#S}EihMB>QaD9Ai I$$LH/NMrH$H*"k~CR=u>l{tAiOˬnXDcaWX.̈́ȂQ[@E=XJϊA"?y[SiEPJωl,ѓ"$x*?5[8Ѐ+VSZzdU4/z7[@KMEKbbɝA `7C9ğ5^g:u_yV(>z wVMNP֘ ~M"f)XM,r#G?N~sPG4/ã2J_29 '۽}[d‹}`n X<f38UK&2HsAV@p]F lfB"z=b@mF(jjkCU!C@4mL55AL-H8oquUIL>ArtO]-Z;  ܏UT*"lX;5 0l.eĘ q{B>s(~N$ή`e$9wpJ 35De / lzꦬO[v띡;gH:SIUW-h=; XoM]"8 ㎘-8W0~8ek 1rxSJLy& kRς) ^(_d13(9mܶۍ O&&t ##w(Q矚<UÞ[7^K\ LS Gsf6B|RQ_m<h؄ PJ;z ]ϐNaޫjw|6"Q/Vݿ̗ endstream endobj 208 0 obj <> stream xڥXi4ί,S6%W{AKPlmc~;#؉Ͷ}W蝙wFA@3t@;r"2 H8 p0N^Zwf|Qr8r]ע#Ƙ2Qb͎{jp@JF>#$I-}k, J PnGf!QRnsdb8"QYU:yV1EYہ&vȌ5ozonW,D;"P,:kZXj(ڎN69vԢ#q9C%{GZ[RdTs2"O:-@1S0=NH(gQlzFjcWM0:xSa\nOmʍgCϳxm UL2Bumnjv}w3̉Un-<^!Nsn3˒K(/W^.nbm7&F󘞚9//q-/JGW:a6eTfxv#cV\yŤXk UZR 6:MR䱎߯'E"MJj].Ngv@@5b(y`x >vZ Z<D%Dlni©;?R]+CmF2`M&8K`' uδVu9P09-`qoZyj ߞ ʛֹa=Vm7VmC;n\ٓނZ6._}qz֗N@V}Qo)LܪZr.LX+ak3=`#q A^ #K%_vGyk-+wR \\CQywSW,ue|"CdRdY!vStcK[ dQ~ Tf }l)< ˦*V$=,rз-ϵԦ#rCS'V5|9kwDc69W:\xCV-Y![xumL~94=1:[ vf6Ng*͹Dg&.x"tt֗,t]/Wگg\seP_~i2ZE.m{O<[j\w5$ 4t*9qޒ~>yRpn둥&y\8[twgyDZp-1T蜗J ^7od )[7ĉRXdi֙YJgmz$WƜ%.:΄.*bxOrx:hzu}_Tsдkcvp a< Q/1!6ds9}pm:tU9iߒEb|Wi+rr`Q Hu~e dd4gޥusX/:R!KZ>aI#ev4&^q6Q&*}Jǁ֭B\L5r>Kç|fr0+0ᣒ]ZU?p|Na}12\O?߬ f̪Uk*W0 ًYfkɇHh_E]EKkzMIR:{`15G xGy (> stream xZݏ6¸}Ƭ!l^SPZ$=yڵ.Xr6fֻp0-Sp7ӂ.RG9b_z5[ДTŻU ʉjn>r3^Ƈo\qΓⰵ_i?5}sH~ڣ}fb*ٜa3RW^Jh0or%Rtu6ԏKX4ffWMMW L*.quܷ 5k_]յdB%%V4)c]pK8bd*cYKx^³ZUk+ǹu61E2Af=cKI&b'N3;vp?7$(M)a; nq([ 3J45[IDEІ%oḏmuY,y|l9bb "s"u_6/v ҁ_?fY5`?5=(' vܕ+-\?DsvG.40v{JhDAh]_MZ+T7 S[~wfPW czPT:*7"*)x>X6ze\8KƬԖQeJA T4Mb BÜJC;WGm*89aؒ%_Ƥ( $zsYsbV?myh`[Sticz:4}Q~GM"t@LE@&@pb;s4 X5 !`D-RhV&xK[O8#B )zNX Cyf~BH8x5*w @ sD!|w=˹EYrc]ߓ%>)_aidyHЯR"o[TAj\υ`؅ =@Ig0|s 0LhY1gceP N44Ɂ#;KFN"r#bdK=O4<VPuU1ZG?gPt\A"k7MHGrCAaNw%dׯ酭pʦr5n$,s+aoOVFҸ+n([:tP5%꺇RZ LJf e& P sKq]Lp2rB-N?C3*?3Į㳷K T>y* _7Ӧi,6]%ПgGE22l|,0 L#x "3xPeRV`Arھ>2q̆<*(aK!jRB` !'Z%CPX "DGcӲ;=Դ ku>n NեjSlKs$LHLg,SFn(Z(ހ+#ʜ^{c{ sX= و^*.`%nkW7 ˨sg2_rIg{m"SjӥZ̻ 3el2[K^b [Y ;:߽1,#E M4ȵH3vXg#+h*2NBiV~9ZvӶҧhprSbű|73]R~D5כDaP>u̯$ kYӜtt\b1Wp|j|+gyQoE3l1`=٬ 5w7@$h@p :Myss*?WLASr:qugqԸq[kE,PzRe*N8ur{>l|Έ?ʟ{WL}/lhBC*w2íc"+T*d %͏do}Hv$'٤oSF [daR/>| '$("ɣv~Nj;8Rc, 4E4\cuتEi,0M(" kѕ6Zm 0cMlxh_ߔusO- yC endstream endobj 214 0 obj <> stream xZ[oܸ~wRbd-%aeFhf%9ġƔ)i %<<|Ћ_lA/[b]\|/%-z RH\x[]BZRC&]H~Lڸ߽񬹰(-,e ʮn4R^uYxja9SZy엷e_\ZGя)lQ &:?w+:y>W֐BwRln'^aaans҉HI?;x; #nD %^{"seMV7׻vul6^ow{?}'6\aɿ,۷uRU8y[]HBcvi'F٣n5 Qh=J㴷$lJ ͺL6:5D֩VQCcpx [ Ht7}nch/o1J%mFS;25cD 5<.͵ٛ7?/?/^(B 3c2U.+M~ fFB C8Q2U~K EDr AJ YxDK$۲w &[}&jLd~c6}vJex 3 >"&~!H 4T:ꐯҮ7lF90y΢,#טxvM׷UfnCާu Yi]>|* (X#yvʒj5'J"lj)ĺkնAtИ%=*=HJ&UmgOei(@,L : T_kS.R:&1Ƌ8v۽K;7 ȯjlQUb hു;?dsD ;DS"ԮhMNZ؄ ͆fAC7^rnQ)[1?+cnb\ĕ. ukٞ` :v.= )TFDzX{P<pT`8pkaeυl әWj D}ZH5,$zhey`e.Cqܸjխ0b ^Y51]^r9(C=lz(33ǸxZHC)EH+p[κ48Чkx=P1m_c2i_ x '*x }5E絯z-#9`Ţ0ؐ-vJCL'f98h \[L^o՟?dATQsP%:pՙ!oT/g:_`o<}tb(nK7( $1mU6'gWn0N9>:g: "jSMTt\SQmx_YuB6:F,x5bCw@D¸_aq:> stream xZ[o~ja>CSEf] @],hidD-I%6̍8C[κ@H s?9s32x̮`Tn3geFEJ1/cE_ş/vޮy׺;?639UE^] ky,x4Ei !ij]}o+T#6D!ɘ#phI+Mjۙ)$:u<@O0dE սX0L6ߤrq Qѷ<(ɦ4 6“h")џT[`>ĨDT]5H%23 ,σXG݂( O?(ŦynSKH;0 %9ڗ!LI ':$U ʀeCR|Ȳ-Bh(<<ñ7SLs ٖBy;UL:vTGoj%jblWGŻlʌ{IQجɢ@P[HjhUOo硠An!C;leٲ A4N̋w.N'cSaʋ-ɟ`PhZUryvhUqrtB}Uh)mw#6h -}|o޾E ;ݯw;lƺn{KیAH7e(t 'V2;||!Ak@Xv,rOV#3r| lfK#J$ IWR zYpz|͠G6{@^ SWDd!DA@\V,8THsF"0^4a#X@9T[@u&NMw>/!ݵ8$X Dz΂է37~=XQp$XUb2_AK:+x ҡ$eު=g߯lCI a2 8ufIiaEIek%5mEsʣ=sSSڄvI..nO ovņ{BsUqH&Ks諻D4FYxT1~,gf5J2*DTOm 3e]+r#|&KT ir gt?>Gc|3a {[t2!2謵|)% #!5 ZOt>=OIy!л)rl 7j].a]!]YL #2-luZ'h/>\:_z77)$ ab?prHj` =.|qn8; +4?URШ?37nA؅a^8RDTZ+>8Z:L‡X~ Ep?cUic%YL-Nhk ޑ"t+ LXW֮VX=FcZ|ik.W")qq5j6F"3Viލ B>iȹj:Š)&ۍˮ?)UGFLLa:RԶL&^lM%?6}56PjH .4>:mU@-gYQպ2?M l>$Qx[^f" $Vȷr`=:@ zP)6  F8R'=r@7kuMF.e7@?VB_O]\ww*hoD秙yr3& gPϷb"5?*] endstream endobj 220 0 obj <> stream xڽYIsFW m:i${99@` Q?zќTel6xޢ]$Cɢ/qx-hBB䋻f[>[Ɯ]BsdY4ow?-_NiyϧTcDsW_Dw/zMHJ3P˒cXD iUU]P$m/)FW0AO/7ZZB0[IR^bUҹ%Ǘa)c1<#Ʒ}+<(@Y?˻aMr ay6,F(L2ހFjSj}>H qL<O 9ѮĽ"+ V[PPL7 Z D=rFt2BS=M9XDZ ö dNۅB8 (7t;l9bpG|(u*4lNX #uQ(gYH&g5GX)3dlfnoBޢLYL^r~oq,L%=5p4BL/:)1BדFCft-e\8sVIoVHcm -~\Y.OK QݷA77przzgۯu`=*ĴGXEPϹt1&}mO͙ʓɳÕ kN{TCƕA"c47YImX23{R!вm vY*\a֤#rV_d\Y~0EnZP%SZV2/bd7U3>n&tY#gʯK  <%%M '#ǚ{;T8DFnhhzyT8uWM?]`yҌȱ.;zOMDdЌ~y*v?PLKnw`[7/t2怹"˽~[C5] 2+Qnskb'O*]^Kh_&Pd]@%|R9~# ^EʈiFg{.v<1'&N<53ǥsc(l]}|n2kS._o (+ww}'X!B endstream endobj 223 0 obj <> stream xZms_l\\6\kNśH@,`مlA- t^|u%_0J Z &H!/]p1^?}\ !ٸƷ?5^_ e}߸ޯz]5KnK1bENԋ,HΤu⫚ˌw FP B)_dvXW٦Xtb)wBf֭+4,M0 {q2CX۸p&=_jh¸U7]{MLдKM@OaiRl=]J`@釶rCvUs5lSxa<JhݶH(0Y*@91TD0m%'e8fWXATPŻHVV bzR 3(Q]mjP{_MKUrR:€oSpIp袝{f*)J$QVP©KPI# CD'1%Qq8; t,x.l;8@?｝})`1uRR&CIt]:62-՛iʌzVWxt)x6MȌ?Jv!bX1UdXTΪ4r4'47 JR\Qr[XN^!qC$35?4h($x\"/\u{ ;a· F'id𦫛Jv3L)>®1gšd(PLM: a.8beؘL&5:NM Wa`k urp!ꦼJoDom#NSS r41RW5.h/{Y*yU(i$4*RZ̼:.Lp`})%j^B{;)ٮ,(bD oƺ}u%~yjN3x!C4RD @\>N$Ɂ E-RQY*Q&R.vYSٳ9Jkܖ}GݾMI(-T@f+$YtbGk?t,Qb@ H j/=s$unݽQ/b *$UWTZn OrՉ-Ln:Ier+ p\0"F宫ͽ[V%da$aե[ARߐD& {a2 ۖ}`^&t0XUm'V22FY#(ò!]IXE굾NrMy]`&ٹ.~2gytwڣR[d*.PfgO*z]m#dW|S!U!\k\6(=V:و͛$f}ӜY*w>X}\2ppXEf9yt &87RlV7--jTO,Tu4}۴'=%#AG{ý =uew=pevc@ܫ-FR4's]3Ku pkwPukeUnr6cx/?-F^-oao` |֯i?] ima~iOV/?LR̂C󙮭oתS y:t Ets)Ah >q㓏4Hl?,V^8~ɴlULlƎRI_w&8~w[k.FW!7&yAÈa2jII `Uΰ_Ԯ)lSDHCBZzcD9`{C; (o& "shDSUA+O0~&(5)`sChBAL!d6L8:dϫYܳxSn⍔;n | SZ?>x^8ﶵ@_aᑋ>,Xn%yI5ɫ/q 0:=e/g,ո#,ZImnIa3A!7޿!<4}Va ׿f?sw#uz~] p$*'WYO#}.\H &!BT=S< OxŴx@B@!M( R 25'ㄒjS#)V@sdbuaP vg&OF ;[uq yyQx> stream xZݓ۶_=r,_$xдL鴩oXyQ %Hw.>uJ{i9I X -lA-R"-^|/%z`jɤZ\oGՇh+!DĿ^O%ON?,~!9#15_4|JfD1iuШ1!xA(e+)t")O>8h ~G"U躗5W{âJ4**\C;_6E^tt4 M<.@h_p§94'rS8,⠷maǘk[.%We}#BR$ETc,,)N4@nڿ-AރYZn߼^-́a/X`vu$j& 4{bc:@]DQ1^p va-ܺ">:jPAI U2?rPV?o)W͋%IM s}< ;BgY@xN+ր6H }P);0YvAp&txo([T TkF4Omޔ`Njm]-ܠۼRɬQvSm31*f1d2aLdkA=!P C6\}IԚ{BGA. r /X"KaeԔfDڻbs 芀& ̍qVxМ)TsBC WZ;3:n.^K ksAdȉvAWCVl" G,zZ 1EËeBҰn|YoJ"l̸V`,<[Ydr2;9H`j "g–JN޿v: WX?| CˡSAiR : f>#htQj N<U&Qr9`18ttɠ3,2𱤯K^;6?{bxa-(\{rNHNh⊁|\1]&/}6YC@aFژF!>*Q5/x8U@L\%NeEӕVxL I5YK:Uts?oK"M za,?wmac]r+픩=|t w_\>0ϵ<0? !] \;1(=\um72_{ƍ/}?kWBޏ~=λG~UBGpu~O) endstream endobj 229 0 obj <> stream xڽXkoF_AaU3aw-Ur\l0E JV~{a`'n{s h4l#΍k2 ";zgЀX'Z@Aw+qv^ ^pQQ- Czwr ܫQZUz mR|v/|GJXRzlRZ0+B88;cu¤ђ0E$ msDUhYƅǵj Syu#̕Xb(3MW@ߎ"դ Aaxsֺz_Z[R arʂ㊽oxX=뛹'~뽉r֣Pi;zIW+b:6ER' & n価Z@4B>tZ;|RG-f}S=*)ӧ.I20\Df,N!fOHpqT[{(D떌Ľr8RBmBIϸ>1̉"J((^pW_bSǩ*ga:I+Fxf/B.MQp0 3V5͹U4v9x]4{>BPuְzTҐ.B ]y\]7ތd;g|Ϻ  /nv\ 6E-C?V+}LV,&6A >ZS! Z߆qGuz1~ PҏYkVvBiOpգg v?iNi^RVc>w}i2R7O|j8kෲ6(z y@?A-b?/lz|? 7 endstream endobj 232 0 obj <> stream xX[s۸~`Piv;;Mff>T}(F"=DN;$A;9@9A x 6~~'".x0xp ?zכvI)C,RJWz&_g)P38_dv~'OWd0΃H,\M,JDŏMµ .]G ˵Yk_l6Ծ1v~1X3'Z:؆`OHO !X* bBҴ?0ѻߛ|cxxڂ%y[SUSG{eI'3ﾛEJ^"+1|H),ѲKuiVNf]"/2霟b[qZզs jV׃5́nQz:׾@s\ƶ~W1]il`kzW%x^p!YUF0pgi: v- SڅD-k+h ZSq!Qd1'HSqj|K,9,:!tog   8sKRozh6jMSIgH"L <7BXi2cƢ,"5vI1Ȃ > @MF[᧎FNBF81 +rAC,)<{*`FV% F1q`hR2|H ؿ~mu&~ښ+c+>YW)',sG j!+z$Cp&8# $]=m|W_fHBS}Uf LU9ɥ7qz%%{Yhut}gs䖜m,O`Zm 129@,-2ld%#xDK@A 6/(][OӶMXmvtSBÎ&I%D2At>erO`Ra2i(,gi<0q[an9`Sv};dGd]Cܑ6v#$A]k:G*am߶F:eyMf:sd&l;^0m"V5X - +w4cb8& u4(- U S,@BR9a[FNyy9` C6`"Rp$W*Bb")]*s9 b!i7NduDqJ8>M"b A Aˊ!,(49)G#ؑmAA.kL!0l cT}c[u54X+bݧ,|0^"e"RfSXkru.Eno**/җxFN!;$^v2X>K,LWuOOKӭD"SR4s&iA; Op㍌8 P?8^CVAh`qflL +xsn Xb"ԙHKӧX4"{"ґ$`S uD Y$r$[:j<?Tmgc45:ӕ $ .&׍g*&Y8l0  t 8`!>vK98Mht$5a.^ ꅯB87%؃DSMv}G{t&ž=@*r,#g/.Or¸KDv{|[fL I#Xbdr\Ӟg\_OBij}ɻ[|b͐P%Şd ֙3Ùn_]>v/Hu0$ӢR89s*aPJ0B:<g4/R_ y]_dy1X endstream endobj 235 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 238 0 obj <> stream xڽYn+QbUϠ$Hx= Zmsn=(.jg HsKm&?1n󗿋 ϙ-=l\2Sfa"&V4qw3wʲ+7Unw-VK56]I=@gtssounq'[ƅzy̦/՜YcR+J0eOuP"έ&DtSf~ՏT-|S+yuVM=nqA6y軓ޏ݊"~Ykj'繯Em#$ar&eTOI#uKJNViʕ93҆dG7{)adf GWe\,L‡4'Ċa=6~& d!A8zIL1NH, Ѷd oaG}ӎ2e0"9+Ou)Mߵ'k@ :JO*>6=PEM& BaZ Fʅ/ejFIRtF?DRra̼ӂS5M}Kѡn !%IBs&@4.eJǤASݻ6 f֦)BbF믍#R 1;E|E8EA2kE'o0'9,!U>iaK(&5 ?/XraVmdeZEЦ$P358`pg_tҭ3/sMխq:f'\C*%Y2 NaY3,::ckr‘H}i'>oiYy+fs'z ns=uy zW<_R;Z |63TyPTh-(Hp }͘ZК!@^8j2 4O3Jծ#@yhuah_RTTQk힆m! N/G^k޵*7 V{XԖyMۀΦMp=|\K[&?^ ݺ{_ar(skO6%OyP'Ǹ@ֹWX3?rIhVJ0(~96/$/⟢;9ȏ uRߪMW'yٜ }qn[Gg_b\mN l/(^3ӟ)͊ǍZyM"b9N蔿{ڔצ S\h,~gtyK+4xS1nъZܦ؏:TnʹcE?w*}Ok CHhC(CIa$MWiǻͯ?I~( endstream endobj 241 0 obj <> stream xZIW>Q\ہc Ɂ-Pdz}^"5EcO&0).Uo؛_7d( `d! zswPrm(H)/ۋ߼c(ۃ?tcs^XvGu?vKU1Uؽ0lmw]v Mۋ!v'$-}mc5(k /uߵvUFq›QH2eqqQVm2'X Ex;tܡz)S9`z",ex@nsه Zv`5^ rE ;ﰲn6#ahxnuuÎgKqϿj {/Զ{6ݩ=Txyh3)#.O`*\p}j F+SZ: ?*_@,` s (@+r3QI$8O] U} KC`32j(8cw LM :BL1'lj?/61tr?yU2o NfA &MӢP^guoC_֟*Pk|1hb8!}xASrHC?FɁEM TFu6k>oz&rfq2;wz[[90[$"jUm.[ ⫿h߳]O5?R{K%[Cs}BWɕ!L 2HhD`=x='E_=T}~?c0Cc5yj'-ʰлws'8Cs8v`ҿRAMSx;WvKh*zX T9mUӎi}Vy3BfUB(' B\־p{̈% T:2[S0&-GHE,MnL:e}Z5,T3ػw>3ߋ!.^H٨5٥8U2HkhwœfQc)gҸ+~0tr:6!ugČg}zΐ 17Al1\2$) ƴLekNmY-Oeζݬ3.Η29jt.fuӀ9-erp$6 ųog^^$v5 c'rVKbJ)+aJ7X pT9jQhk[h",e&gi&hjF#jD\BhZ N ђ(U0K֥@"c(ΪvWPPBͳ ip^13~Pw*Q=5T;+8^S'b6[kW &OcuWa=΀0'g 7 # Sp|ڪws~ʴW깯D$ {m1 ܰ$/&I[\avN),dR*OMrH+o@u k:./ɈN]89cϜ9C5NT bb3|lp‚ɒdttCTӲrN Zק?!X]釓ϒ ww?fm endstream endobj 244 0 obj <> stream xڽZKW(+n:'8 GhS䘤v<ȟwUtK5,EuU㫯cEV%#+Er;]ʊVD+*W_ꗹ7[ؚ}rl_ݩۡKo~}׊SRҥYO)sO enC[^p(+t߰r5] N7[ֿ5yrK/SD1ñqO)Zi8lYÖ ޙcm51ٺY'CK,.Hpo;)vˆJIm{JX$_Xҷ m_1hZ0~8`z*&^kଠD[5ӱ ͈&2(Y]::LGGmXPnYPq+j4:DLP !\½z7 _ߧHeOKsnjkh/]!S E4Is0kX=M10gث  fCɝGBǶ~|}}LkJ9tB,{+<_#.cqX;38FADK2JV`%l Tű}> N²(EPMv]}ZyKVn$R1* xhYiU~H$7[â2JilI~J3Դ<JXn Ҧ L9\v؝L ITٌU*Ś61aZ aj˚ PƤDB*$,v ^(+lrqRP.M PF(0Y tO[ߚЁ:4I&W$nW E2mU!(tnٳR?q"q}n?<7Oٲ5gnNt^[sd`L,򵵙^;R5s~@ |#ɆWY~L)"q9\i*~hS{{ꂩ5#WYvn(Xc;$S6K߲ l 􈛁 ,ɽ#@PB2 0Q}MQdL/2 3Y"$p8p6?ԗ8YEh1[j}3`O~9PUϖmaӨVX67=?1R%/5ɍ(AzSQ.{5.y6Lh!ĝql*Ja•F8 գ';*"IPf0jc;P\Բ'Q.Xr3-KnLM`7t 7+_왅ya7{G T/raXrnqdXٔ1t B(x9B=4,514ۻ]> A=QM:F.13kN̻.B`¡"JќR9""i4cjH(HH8dNL2R Avܻ" xe*6Z] TW =p:ELL%X@iq8Kcdahʅ('9( RJ nKl \/h́ڕ"l脿ӭ~^z?xf!, G{g(*" ١Y7*U%k). VfP/пW(|dqXG̽R vq/ )ũo@>r c Tqj 4+̫@H8:,ASWؼ]@b ! afAǡ.Z01؁Ѧl2XQ<`"H 2XݻX㛐gn/RZ7f#=I,O;]N1 Uȼ IŠF1|eCno:y ޱY 3=7̙w;AOyq@{iv)z+Unhj&z (\tοH7!qn>Pi ˡ˩>O = endstream endobj 247 0 obj <> stream xڭZKsWrVXf3;MmM8!-3){\ Prאn_7b+ p~|(iV+fWL\7ˊ N1כ"+[7j2jfm9 7Y種9WD֚\KG晬9%du'3 K&,<(GI NuW=^鬨OBat ٶ";<5G}):|8G9= cz8KFo3ePn?Zc]m:?o7,Xq4D\)\;}S :<Ϫ)mncWyYsߗ?TD^dAnĭ +=#HSI NZiV~ @(V~3BNwa9f2XPo0@=F(mNBƂ"<8#TVDR2b~b+:OtSMf8~ w*)\yJG B@ MdC t+:03< | a;6 <AYbX!X(6S5{X94z WWF;rJjȘ_^DlZ+Yk_|AtPi 4Q0( 8_qģ8p\ yx8'9334x ӄs>x9-v8Ah[fĩoxUǕt"WSuta_(jI ,u{Bמ`2{z8F$K&P|D"LCIic@H žQh&zc`%v,ԤÎDWvJg\" ,MB +$d(U! &*+ 6`tj O6q |޵{O]oG;,v隔9Derй`,%gIJ8ңKf]exvl_[ 4'HS ,0l[=4^kKT+*g|T4ŭeH&kc4ӟ*m|* QXb߶NmEpv +\`ug] B^b~k/Vl:sr0AA.: פO+ U;˓Nt^ HvdN\/sGF(jszo fL_v^~,$CNMbhT$".Q@ZaJ(:b%윗Ϲ7 AD{SiQN`qGyCڵlt_#8NDIpϻ4: %{ڀ/|% C},pd>d:$C25gn{ 71!|rgb6D%q0M}27=: :KeZE~ _lmN2ϩs|SjssX?al8~`sQwVD9QRsȅ[1JbrLigUG> DJV9o_詍mbdK`ʠ:Ìϟ}SNG?J] yxB}›c90_9?rl endstream endobj 250 0 obj <> stream xڭZmHί#6nr+NH!$*0|[s*n\x?sТsT8p6Ϛ=^R.H]r kN_>~=9 +&@\Ike8>hEgS%&͝3 sy g m»]fb+i g7γ6S%txyF3^cٖoK2_Zg_&.ْ_EL=<ӕw.K"C@7M MgO)=/ެb[Ljn y&XPˢ {YM5ݫ8r'ǂe3x*{<D2;J!A.0 w%"o CBP;2X a9uWl/WBE>gqFεΆ˧ϥKC !H~,#seN`/6Gʔ!qh/gGPTH\+T4Nm2$*W#$*iܴm.- $xH,"~.[wʶr{XGVvw&=sT= [Th^ `C+/.؏1Uz zy%kuª~7;CckХ=7`1 @cir8 sIDW>m f˝!@aS=oґ{. ?\BEon4k6:YSHюEbFW'Z0odĐ/X>(Lb4^,^7&D0i/.#CGcuJqG2}pyYv\ZB:( $bkp/YZ ~~.ː+>"ykjbQS[n 6P-2y^q%Q[7=.$ {p{.\^% 6X%6Y_@h?knЙ`9"%qcA<'49iL7DG ;5 P2k ]/K'BN2w~xᇶ(0DGLkȏ\żoePYvV64.T@@!XgB|aŻ'*+~K·# 1C7`E%g {9Eʎ;Il42a9Y0̠5ub ,ߑYט: 9[&4B2zo=9)bRnبzH &z$mCs2.)TU3*Yzhř,q~S`>PSpv댝"4qƀq-]YtqI=Ϥ Ď+0Sm80}(+zt@Z 5|PP5(v&iU`^ԳAx3 t7O37Rxm\ YbE 8,8Fs]1gktka?#کA؜= M̦!@z'y SуJrrz1ք? A}3 cK W!u37!ĮuN5Zi8P 'ߍ4L"QR+SbY%kVBYeBD9&u3:W Cɾ5ృ4b i>WQe6NuӅ. vNJ59]t ^`0$iRsw2l>WVvڠh?O:) qOw_ŶnJbl /͖h;_>5}g#ή&/L][#ǂ-,[-189@{>YLa \EEA9Qg'i; 5]gj}%=d惹Yd$?lc?eU5}-BYwAv% YLT9a%T;M~7^*AgN\VĐ &;js}/yܽŦPu=>uu8FCK40 THG 0C;SqK96;/Vz #|QΝy`ڰVBB(j4A؟'<jREk Ql6a?x7t Ms x:D>m4 ?oj׫o%S,G. G).ظz]el6xogե?X>'Cj4X=s}S|mC)pبrIUXuޘF&q=e//N*6 endstream endobj 253 0 obj <> stream xڝZr+xbM}/gO !6J;6TMOtG*+/zeV6V}+FV̮ N_w~ N1?ܭUm/?3 }cY5o;nϺj-L??Ҭ̿S+V5ϦwwkIeMZ5G[q3vhz3mM=6 U׼npZ{WMI<&-Nkw(D1>)$ڞmKQ3k! c*ZN؂) *A쟊{+_N ؾimB%A#V4PLQ`'#wk`ͫk?~l$qBƏw芦ڠRZ 7:\G c:0 a^E\O)jYƗzIZQ}Qn7Qr]żqڼ)$CgBGlXK.RvƷv| ݶQP穋NO-a6ycm1 k pæN/_,16H̉ pKCx(<-LXv)!咒. 7BIx*8>e|୤D54cHqSR^Eb7Nׇ3ek ?|Ib1&G0í7E}Io<#Լ0# Ѳf![ozn EeɃ 1OV ^}jOǸ/];@^ va~o'R9KdHᮜq(#!R{%N5K5BC z u0P=&4qa&ZRNZ3d&x:vkq>:4/iޮv߬6EI!94 pֺJ⁑ߣH@Ɯ9 W|4m7Owk9@J&ivabtctWNK1S{UX)Ea%̝g/&y7mZpص> Ԯ=ɀk(X. 3;6ҜEbn3E _ř䰫=cS&>m~Z;@L'*/) xvFY>n A$`""XєnEf t/[KA4%$kO/+Q-.YM#M%.R8t6M>% u>:d_:s^L4OSS;܌ʻYՎ.0!$X4$ qP,ԓrXstYfZ೴@2(#{r.ڛ- %;1 6y P[}Fub0\ ۇ9]eܴqC fyePJZxsFvxZ})c,4[MF  0~ 1^zQEK%VqQ?|ρytHx$$FbBTՅ (ٙEGu)CDDa ޫ"3YQ}PA0ȅbiP2RBM0F0RFL%Lʅ@OzI2F-YwaQO}zq6> JWZȹrٍ!Մ洃6>ՈXi. rm^ν$aVoȔROSHA$\g+E^A@EFK":KCI--=dgu7%Kʄ[<]4泴˲(3z-6UUǬ:oX͝_;(MpWi]T*Stv ?b \oe@`U<=m1kC[%>R!&{πQP1Sx{P͗Sm<+7MԝۆwۧFQ>Ůym3wߡj[cė'Y.95vcfC<7id\qzg_!>8 r1"I%zlȅ?d"E%R*/*<.ch Ẅ{7^Lrrbӡ)3Y}9/V" g8eS$NJ}mξU<ӾV8K Rl&Iy(G>Km\6#Bi0(Oc{H3lw莇 ɱè.x0=vlOMzgK@pکQKo)t q,:';0[8S X29y㏉O ,./NQ$El> &+jXДrst endstream endobj 256 0 obj <> stream xYKWaovoNg $ 䰳JHl䷧_"Xw[əAw hy۝jUV2ܸYn vXE*Ǭ>C%hXȢmɯWj:p30a68#Zx~/^Zk@Ql/c~v\ ϗƹGxe6F8>3ykMi7RolR+ t[*"Rb" G_-9?x#BxPޤ1.]Rg,+ c ^K{{XFk[cUm O5å NlN=Ҏuܮ^3;gK|+'TjB5lpW>U>R!]E}w4@?չzΟER Ffx V," bF9pjBJӐYڀecƇzpJiK"2{E)W%& /p^lMөdj+ṭmׂ4P"%S;:d)#Fi囐Dq"yiR()aFև BVNsFb &Y-ՠw/9ڋA=fX+Q&6O+fm dĜ%IV48̋Z+/8E ٙDe"\PXN@I/)6ǬfMZu?̸0OnuG!lNK?g& 2\mF\7'OWzZ\L^Ē2hbEehnrRZȾq͵ ~~#pk>R,^)_O }w>>:W7$qC_l]#IX2`Q [ ۺ]ab6sՐ2FbP@ b:3Md"p[0ĖXSo;lI@+6+s([4e<qEpd x1]"6ƚWՂBWz&YWɈv~XmQhG֋z%:;N* Gx#e&}\|OǯX.':R+峆&[tW.8 Y0n_=Ъd͑-XiTwewuW+~U̿'`[ZǢ9> stream xڵY[oܺ~X$/Z Eӧ$F".P ΃mI3l^+i\uC7 <ɦj76g&H P\nv"n_u9_?mcXTv;s0;e=?8QuhUMhR4Dl,%EƵroR*xS ]=(<˲-FfaתirjǸzB "BKHHVV^}v-9oo@ZtVG{k{ȷq*pb ~pwۘE#.[SwSC]1<1>֩M=؅'Z5=;#.'"N(ƽET⇭Ȣ9X[ntgi4V>1;Tj5f=z}o f,Pdć}|lgjb#Yp7.àL׾UxPM9)[+6mWj:.(^H(ǘI"I XditY[wWG.m~hEu'dH{oVl5E݂܌"xgUM v! 6=g]P<=R8]}sd$BQ /]^~r/WoP~k"@^X ^cDܘTa_|ވ`t9/V#?[A{_ly(C)<#ٌ'%Lʕd#'(+ rsm ?#j۽ mp(XO&rptШz0ϐ݋X mg=cܟ08*w;OtxMpXMV'١LU= 7*l!"zݳVC`"0N#˩|AgAU苪 O o5@ѽȱ )NPз D%s⹣$s9 m<:?g5a^2#[_m/G endstream endobj 262 0 obj <> stream xڵZYF~_!>z:}w3y6GX $r,R8>U}pS#1Ӽ:ͧ P6ٝ6o~|7lsav)+>oi{',}*YTK54]xQ{$M=+;I5a$I֊C^Opp(Mgݓ}_߫nl}~û3 K/W:Kӂ&HzXϑV(%&{6g]rvNOI[!l QE_G6z:LY.ॽ 4<^1Lg2/*2Bce5>T'tj}cV)FaK (EBWŖPͮ- ۆY (X(bKo{;SS* M0aUQϖDyFmWD_==]3 @. l4۟KڸA!<rn/ݰY\3zWVĚybgEdu$0Rx߸c$2<{@B"wJ/u3*$UX|_]uTO!Zl(颊H[Yd6<9dIMEI=s8T'tsUCUF # PT]CTģ~YaV,`-1\ԯu z?UQxΧlP`2zf3LC2\l3yi;1oA`1]7K څVl vt1ӑkd%SInbrf !gW+][K' \1S@D(𥻃20ehL|R=u't>k-W,JhʺP.Li(3p%K&UOhx^%TCڇ^q:,zw:Bh3?dҩKÒ_o=F",:P%fCoa-)Ź f(Z*51y3CUNJCc#j2TLfEun|}J4u:h0.?HE{tw+&hRU:_:'0ɰiҢNaLB3Pn";ZP“.yTlǃl~Na2?u4v4LZp{V=ܝ4_ r^B\•$kϥa{8&_\Iu̲PA(gC'"kG-|HRbSU| -zF$ֈL.i#Uv34nU~X!^.P;3Fv||5g9eLq JW]iaLps]p׌/aET7[W&7,NMW)Tߥ1L4Ro~6zAjfT9MC%$tU0P1 {Vkae%>T >0ך LڛxӖy(2|hhۉMwCR|ڣ+\N8-1*\pj>Ce\ @ICi,w+'Jf>Hio83;XUXߙoK(|~vfV@PNCZ#Pa5務TP _|xm}@b (v&0 -ȍa$IԜ84 4bzWP !ٯl9aB\œAxv;ֈ`@Y\~w\vq؅&xڿY<4aXo歜y$9$Z )+WqW>׎b:c^7_p endstream endobj 265 0 obj <> stream xYY~ϯ[joĉN2yP ϯOU)5%byuUWկ+J]iG)1V#I&NJqF1O <[phj\䧪{vwҬ7,KPk#JPfd0$Šz~ň1^~I6LN]ER[Ձ:w_C4v_u}lwjMytpȆ%7Ю%M.1ׄdHޠ^`%fIU{ɻp"J!5Sc{ݕ1uiF Mk&E_s2>ν~66"M{:Wm˺ cb K/wIY=;UIh]Lf4r7Toʭd=}wĔ}ꢏZ f&h_۪~ψѓ( e_D|5@tQHIsp'y*$iz9hCkմ~ 1ovG7hF g6y`a݌Ў\h 䵷> ;m{eɧmiܖ"2@¦͟.uXd ;EͯK̉h؊f؈PXi$fE0&9Y+2eQ|,-~wщ:^npvOKYB ts&,}]D'j^񁺌xed4)'oCc.VC>}Ƽf>CuA 3Hx"J߽C\):# b/Kd{pyD:"qfa@Т`f|S#@pW!lIWH( Pd]- f7 T JKΖ}NQny^MhGIil ?xʾ@EjYF4Qs8?P*UJR}D{>C(Tp x.Q?tE{Xms :1-lpS,<:̾87crnK@ָBmwkJ!~C=2\%J}FP~X;f&-k[R5 |??>pOQEm|h,;tPV>3g4Ã7YFCw6P2`qIToK[}q32 OZ({5XC{{_N{udl榉- Gn(3r|Z)fq QEmy GZ '5\(jK0R1(kHp t*G8p!4@Ic)_,ztu׸ۭiT1{Sh,7@^ iRDN#g?(_Qmײ0Dp zEP醔}ڟA,]'++t}ӂ6~P2WN_z ST endstream endobj 268 0 obj <> stream xڭZ[~0+ ФY } ЇNhl͌H\{/Y$Ś(\s~[UJ37ي斮nWԬ('V?ű/sO"i-EVOE_55cYQñ7J0Jpgp- PVfz#k cjR?bDž" 󰆆Ewf/y,ҭPf HǶݦ|)}_<&B1=|{ݮf@Qث-S[o)n$n o>A?A]nXn4 X`/ʫj:1Xշ(,MU !lG+uvXuc۬7dӶhb hVÙ_jÕ Jͩc$#S;_#F8`& FQ+"D!L vM%!G7!y"ڪAdX]u}0VQY"NTgst.b/rJb|Ǭr˶ h*T+87pJHTDԆȆd#{|HQxmEAhto 3]` {4_kK"%f P[gh9l~%z2X[[Vݘ0hf?ni?k96Rѧ%$ϯ$/_ܫ?; ~ ^x0fׄuDF})]+F>"sl}][>Us=<5R!Fd:,GQaxUӈ+;,?7mˡ3-@?\0AAw+גfۤ2:c4B3+G>/1#c(FΩ :4?@;ϝTA;fayͩzYh!Χr A+d3ci.ƴLm*M!NY{. EyB`uz{$ZP]VDZ< $ 6Ҝs \7*D0̝gNLƶ8u h5ŃKF envC`Chp~@@6\`rjN܆b7x#It4>&ZCJÑ!WFh5 BPCCJ]W0H Qn1R ZT#BQV ۹ph.v{jȁ,3 sC!(.: zCb}ʱ] u>/bl`K6H#UOw]%[t 2dy)Kn0xsEU6/? endstream endobj 271 0 obj <> stream xڽZK۸W*Ya7=98VjSOɁ#rFLI☤<ϧ !C#O*5. AtVW|_YwbsV_ܯ[q V7?3gi%`Jx;z#cE?j*k?RFl{:ǵgi7`+?9ME|j~\E-wjWà: ƥ]mAîy?NM LSKSOf}tv[Da&; Gج &kz:ilWXWaEkten8`KW?ԟN-ihc`"[X'7w@;n`}}{l=3k[(V/\us9=59}JY [txiW}B'EÌ3ap|,^HyCJb۸􆴄xYLOm@#}ѧSjPޞ aI+0}.بmKʆ% q4m gVmwi_y8`XfyfA Y2l9FeguJkX.#o[ڦoHDZwyxV2۵WkuɱHk{͛d[iu}Q7n:vᦧTp P}(tW .ߝ15wOQk!5yE@^5-2~K"V1bR+(1 rHIP9?ؕaa:e+UP6\J:dĆ?A-ȕLZ5}Cg{ƶ|Ƨ%}DJB).\]s|fCI)&Cuʔd'(⺷hrHP>$*H-!z,us @Nn"gBl̸hSѼOME89ZN6uTnDS,$7Ir 5[mV'b-T - ݟo~paFn]_=5$Mw 菶39R'}NirEQCjEdK&v]&_FIg; r$~/Ht }KU1e܎2 &B?j7}JLy 6PŒ[d"wy MK9!h]dkpȨ yI(Hf+BwrE֞8 icyj]x{IɆwĂfAczˆ:P|sccuup aG \໐з3\\KT MQ/L 'e&ή{g%3" E55䟝%t% ,,Y~c$ `VCk X+FdX.O# HISQvm<'BOLK>r3xϥ#( dZ"z_{op&Ϛ4cXT={p\r^w) _@UbxDp|?%slRj΀qEgjÅd쌀T(yEWlk!lLP}urxH v =coK)rsz0G'~K<=#BgyM=.BG$mUK@I/*gb#AIz OWF![,_@8Pb>|zSHV>L;A`iO+)wrQХ_h\4h"WO8௷߽N3p,JliJpOw3x|>q;*gvLA\ C"WRɫMDS/* BeA yu 4˗gтOaP*!)wE!hxaw,Wo Z aK@>] MQgBfG+ߔ/,-PP P R Q_||7n_ϩ6W&X,mp ӌ]1Svfa*i% zF'^Aa-7`.8QO=POE@P0u>-At=@s_cO i~HߚH@ebb}ŒNZuhF!^(??p#gheK9P "|J`Q]SB.9)RC.붝~Io Il\ endstream endobj 274 0 obj <> stream xڵɎ-l`D׾8'a-[%RCR3{T2`#ۗ| tG fPǺr VQA:^ZcEӹ9_8xFm [*xvP."X`b<7?ĖRMIu@}sWH B-yfꞳyi`?wqQJfuh VX%,RX=$"/㖔4~tsT "ȋZV8!/DZ9-Zy^oͩsRBKU1l2(kLP,PK ˰♸P WldR軏991Tɉ_t2-ˋ?5mw^^s$^oA=wc4i_Z3@0 fk/CixsC3d8ӆAcp$mv\9ZKƂҢV\8C5j q=;ڿYEꃅ(y DTcv_PV8)B :ǣ%/N၁WV<9k`C1wLOֿ׻K!T\ Fn%A x;ƖidO_?Q@6x`zt^4PJԂ<ϗِ]aJXcE,RՐ4Θ݇hc"n[ ( AecWE_u׿٢czGZ/sA*#[R7$R$jḓ_Y9qА6fNxhX[2EM _n#_D(T^{QO_leTeԍK ts$ vIKz\ݠ-i<8?( TdׄTVCYϗ(w`[LVT+@C}|FBCQKNy՚6`dIs  Bty^fs38CΕ6^M,뻼I-]:qUK7S^(Q QoxO姒lVBaCMFK raq ZcQ-o!L;8XJ`, \.糏u/8"@PﲖLN! G@H'v9r%dF{ɺdz$ [DxY\Ӆf xjލy$ SX\ps5'Yh پ{֠H;\*:`Cî! W %\Aʨ eԮGwP_yyE`)7)HeпNyj{'jF\Mjŭ?`,{d UJsّ] q9s4gADpLvxOjqM^,"h 2{pТ}y1C7 В{,d¯0ļ,56djʻn%sFF4OMۜeXו`@ Ra&턇 c iN\FF`Y"87ۖ-53U ҇`]6Mv2E-bui'&؊H&fp0T _?Zڹzf 9Ra]&ʢ6av(pw{{$kum7ru7g[.^k0̑I}K.)+r/dyYc}xxXYU){V1]ŌW5scs\%D@2Aɦ*ʪ)hBן/M_y%XQ,ĮYQ嗄.g]oJ([XnLWEA)*EWjjX;GߠcL=兰KW ֒$uzMERƾ:<\ ~D21nz qxء Wa||چ*P ;@&Ru&KqT$ilw5; CSpB%$8L`xף-j ^Әcera.z66"gk2߫:64]sI0SC7R쑂C5x,YKeEz efu>cb7mA," h̀ z-X})̙/Rzw SC_oݷycEQNY/b~5&XtkΠ&a[?M N}lLHYr_ۍe;3CxfiuDHؒW$Vjفp N5A!TN qCnx@R))7}o ԿAVB8`GM,Cƒs[[4AL^_ f;X)3ѥ_+qzfLX:sH@xjtccd-tNUY F{k`'am kκׂN5~Onqܻྮ-ӦtkxOJX'J4^G$}AJ=f_k WTRL+2Nw ΖC#q=C_,;g|v^fՎb."ir~xB9VEKW[;I$uW:[vg!920QRCRzBbLY%23}Q*Y~.!]/!N7 U)2"J12-^wtqW endstream endobj 277 0 obj <> stream xڭZKWȩx?'N%)WXDvv} A N[&ģV؊le8aw?QV/+fWL'eڧc'/?ߟB>nCo?wCwĶ/Ӛjs94'nu͙!Z:bT.K"2mXN>~Aɫ#,t̷1fVqk<T}wsY+͗z20F8 0Ө嵥&uPu2$pqⴊ┎aXo5D4 &JUw/a][U67yZKfmfPT0'fj^+7Y, ZK2u;I*:HMq0ѼZ4/KvpAFq̼c:P2MkI9k\YX &!]k҄j˄$r~܄^kLPZVQc2 pdչ=4=jb釸LiƋuTaر>_  W;!1Tf^@Nl.4Ŏâ'W^AK%VQ(CLEڇ8ؽ8Gr_|p) Dca<xx~3 վ>g};2m.'Z˹YXm"{@v)؄K'n6˹قhh6 ~51_\Mr`({)a4!6hXIykw`\1u#1{P.v޸V\9"$XFozJ¯ 0 1wb}&cD2UR c=*І5'V&aw:ȊJL$o`cѫxm^4fi3e\Bsg CTq PO5_DY 1%?W)P$d8@%FAFzALx3BqH Q/ecyeՏٻqTlEf!9Ukh瑘lsGO@ _9.#}K?2wCaZ3)D3fǧ\7C*B Mbp"G;1 sV pVN*^6! UGaH⠓ C 9=t,q@oZS}a:GFѓ;Dṫ" 2_gISii!tZQ% t6u?|d")4ĀtǺ̾!7c3=NCXb)~E ظ"1>#XAY* *Iϩ'sDCd"~=W\ұɷȪ[ᄻ.ؒ LˊYAhiNA32U}Sb(cs-ZV!N̖O,/o HWqwc?P`Z98kw4x=ĭ[תsĀs)8O"E\sueK81;h" I:ֻ )bZ,PwCwSڦ̤\إVIf$'S-z&ZF8@,a(=cjEed^mpuǂxp/(7r6&@;f>9%rV}MhS2^C]m/VxdVo+8_:_+ x 7ϫ Ґ3L %j;1PrA9#Q=r%f/'\i9UJ)TE=e)S/*I@s8%C%)X;3G zܩ>5'aH /ΞDyWZܕIHuS$=WȘĴ#T_}Ƶ JvԠ/1&̠rL 7Wp_OBýv7_ T*ml'..> [{~8ǯ < 0-^koIyKJ-hd'T@qJ/66fHkeDo6:-g y $\*G6MKCtLE}B# }@v0z\ps/`"\8&{L E94*>uJFȯt9t]UL̯hbKu RBRGlF!q[0+{^m%l:2D__A d)OϹ:Sp.wCr~ rE*;75sXH_ͯ0Y3;/\>V<޵lCE*!q:<$SM)>ONvD EF.E"\d29Yv*h/y eKO,{Ӿď^|o?r yѻ.͉bƧ!/O:a endstream endobj 280 0 obj <> stream xZKWQcho'"ヶ[3#X#%7bQKMON,)bՃ:~(_q8|=?s+J/y\or)e;%TSwgUwI/禥' yp¯gKaT9sZg_Tǡ˹?ΰ`W6.dGv=~fxā:;E):OM8&7OF tK={>ͱІw~gj4˓=ͯߗ(r͹rȅeF)σ`rye8"e֏H¨WpFu!/ ӂy pɳ_8;0N0Q:`Zf~wF1#ëձi Y3¨X)3i{xYX5#S;c5=>y4T/H&y5`%ɹBBgyj^dc)#RJKB`ΓMɳ=Rfk^w&WztOspc=hx!& (X!xeI]?ܽmLծl@%oDWSG73{3I[ݰU@+*{%Mؔ[I5KErXpp&B)& 0NP;`Fgy xi'oxck 24L.yD.b"{teT- cBD <5Pppi`̫~8(fj@$U@dOk˹/FHJˤv hO{|k,PCЫ/-EX ĽfK;nh͆|9JͬBN"l+-HĖo3-9DPՎ@_k,cy尤 'w!n+KMɀ/Xf`TaW얅el&m0ZǪM:,,+#0mX9 >6F y'ϝHz\1Yc)r5 92,!mt_a RKvۦQN ?<;x|&\/.CGaUT&\M4>"ܮ7Q<=o"YE ^C{S|-C]lm VtcW \ ]Q9O|҆`aly$5>4\y0 GGk^(dOy5L4͂0W-^WzA-Xh04TnFv!~ȃ<\ĆmC7RfDy_ukeN(|fm$2!3Va) TCFLo{|OϧB̎5CoJs{kz mͽqk<͐[`ƈ(_%eЄ{eRLcOi1~يH\Uy~{V>ͰֻKOYuP0~BV|FuE)UjABPsa1Н%Ҩݶ$xm|l*,u3Rl+SJ$ ~ #YoڛG)Jdx E|k],ĦnOtѦ6TaG~z@cty2 qN([ 鉒եI\9JMy0liLpH R;3Xꔩ=3Ǻšد,Ӌ##&0^( @56I_ZAZM2)#FnG).B= h;4|%eLz7?UlmrxqU\v_\Z&0>XwTku'Oam- kɻз2ơA){s2f|8K F]l񗟶RGxN@^]φwt\=%XZHm+_^jj!4BFmmAm+ YV3;l9rʢ/ bk:\P{2e:*,S+ -̩=VNY[qqJjO%L9;צ{ĈdI]V˧ۻ_6jZ0L l_n$zyG?H?6j>εJ邲?HX)x%VK/C*|I\|XTY ~*t&#t=l-|˥ Im D G ;b)aBv In{YkpOchuJFJ`/]JY8_vL-5 Ni ܾo$q `ˉ -'J+G`n&3[ %ŷkn4;U[&ZJZZ2+>V;8}* M@ƩN1ՈN3rLpv"n~s@~ 3q(ڲJ2eL/g s PuO,a#LߛxX`ϿZ@' w? endstream endobj 283 0 obj <> stream xڭZK۸WIYXdSʺI8#Rv@3^'e B 7?oFFIQBm7*(# oh~ngٖ/|۝N]c{=yNTwoGuB{\귇 tOwxYVix}?9v܏i>lMu)wR (Qdv#T,]\7tX^lO徿OݏuaNvMv=ȲO(^sXɌ0YفeTFtX񠯆K3Ve;uX^|=A!R+lߤrT&S WJ3p5TrBy+&m)/gT\ ' &%RT넗>,}waPVgk;'x?:[.=>}5 x,Gi cayפx; 7.sKm|im[]("(hg|v#վ)xF#umD.x/v>ʩ~:r!/9Y;cPzUo>!Q BB$E_{+<}n}XΏt}Tet,1M!,!1"um'g2:Igoz>4f&tYp|0IE_SgBF6aJxV cH)Uko"3UIW 3Wjj;%2=Uk ;1;FDoxg^cn"+s 4A`6S OkO5/=վLۯzgWx69_TC?bd<75?X|R(edSO)dAZV¦2}A{>B[dl]lL ș/4Pfq0],K]js@<)PSñɍC|`>h[EQ%т#1\pC3dGp`x Y Dyn-d|'CJ"vY0tn*,e2Fog5IH p~ߌ)SFׁcGײoiՊ0`U5'YOɼ Ce!h-APm W@1/ASX*YyϿ$˳2 ߊW"bbm'cʘeFeSqamCubV0!qC@׊ !A6 F3 0ϠjrW-*A 8"'cTUO\EJ(WoElLn*YHMSu57oxB ñV=P>ÅLpZ6o M6*)}ȾhM iu(e>1$}k_ЦJF:$Ր צz\mp)CH#5b:upڋWivASꖃme)JOhuJ1Dqjb; 2L?vMC4yH黸oߧA&lm:ʟP!ig7Ӹd](֒<K²QMY.0Ы|5 OyB:r39 }xw+?Ng=Mh50ge'Q&[ȲN$iNqHO>hfI=c2JᣁM@uK~ Ϛe[s!l+Cl7q"T@L 3NؐWY -" 9Q0 ͳ8/_S+Bv*HvM5& ԰r%oɩҳCjv3$#6sZo؋F)ܲGz q^2fȎlYC7]3cN|WPeR,òԭRWuiF6cX).L6"돾O{fz凹A?h}NS^?${'qbAlU,>_1W15]yxʄK(_8W ‰BYd f*!^Io( oΦk۫h8`搅r~$L5 endstream endobj 286 0 obj <> stream xڭZKsWHFXEdjsKr@KD"$קDʠƓ* G?On|;nt\Ty%7Yn)7g w[uc_ùھw*=wO/sԸՅZ4b=JlDKռ͝j_Sr\#ʢi tNZJۥQZ(}eNDDYOIO 7iefq&{WY|,f-n˥9$Wx\lNJvRe0S3“ɳ77L=??.ʬI+BߩRhr~K`oyIF-Vrtq ]=6VmhUdA^,9zZDracͱ9I<4ډvڻ)ܜGnR*ߎ|mLz(ef(j!))rA`EU!*Y|KLA_Ɍvg]p{?8\]VVVʠ i Nѷ;|i-4˘8(4!+'1xu({BvWscr6a#՜GrUG_6A]ܗ*`_6 gT~}3O zkJd1p$ڷmLA7V|MopozGjZљfJIkڽ1ｭn [rѡ@C! DChrȡh~XENi\uʼG]4CN]f7L"mX/K9B/ӡ[z8қ+%l&qSJ-KP#75?^9j(fB3!a,d 'ݡt|Y-,!M3cw :t/(3#FM[g5A4)D^S߀MLYBG~p#(Yx-{8{0'RHF|se2y[R䯧Tfw(6a;M9}tYb>xp|!=.g$ [ TWÕ4PA}큉[]6~DB1 b`"87frdΟJJi@^y-VG~&:LQ0(\Im eG*>,i@LOʢr|V '9y-VeWEƺF&E)"6>72׫Tf~g^Ekz>=yc-I`A{eL{#,aXѳ&ZV\]%+E21֟d NBuwyY=kf I'V-L02Vpo2BR:;Bg@ƇKb&¤6 ϓ\,Mn4lpUJPiWjc evqD@Nj7CSL MnEwuLmHGnzRe2UJU4bԗ_jPZv68 ~r4¢דFyR@R%`!ͱMh[hM$[(CCIt0 mPW+#ruGB\XAnM9P<.\7EҘك1v} D~w=_1,1,pDϖ1X<ͰUrrv<-Zʔ5rXͺ,q+-D <5VyEY:y<?P"?$Ackح! }hl ƕu`l!p Al|H)طJ:)Z 0dY7n||و1OE #3?1"8HKmHR1Y!=*]M1\mȿgz;̀3CGejI[^@H@ l>NVӸ]cKK1چe%forEak~'Dp؎cggLtkKwt)Nbo~7Oip??S0:Pct!UMF!03&n;pc =^u:YjP>~?OK endstream endobj 289 0 obj <> stream xڭZݏ۸_aܓ\y(OҦ8Wd>ރ"klɕl (N6EHh7Mo/ߊ YW|sKVrs-l /xI)oEiq_L;Qf[aٞ[߼TJ]t;W4jÊ sni3\LժCKS7_ct֏4{Z?&>mtՎ!dRmvKU)d.CUOWNUTLk]~;,fjڮ۝*Lqy6 9Esƥr@RJlюn¹y_j"g8nwlGfxQ0o%$D${bkR7L1Vd㥧ܝCVph7ӚxO[;N,Iq4^? U-׀?YӔO±1f|*2}0x_-7MVOtvbwәÅB1"6 *Gƌ<[@2pU\"bWXnCi_irh!};dxNXG֦¬0B2%oT xr1,<VMsiCMDqRMϑ ~ϕ2{<<:P.q8wkoR2NfI傜EIkk# WZԊs8:3}c$<\DqoA38F%(| +u3(%hx\@+"V=ATViVVb&7nyljij'LlJVH;)t91χaJ.937B6#ApG⦝ e/+iQB@rOB#6 >q9|(D2۝.D5!U$׮ % ߰tp+\rT4EPxe`5'Jq0!e2gZXaM;*tF)[GiL k $鐗UDM"T6Ʉ &S YK˯JU}hOF殙~lt$Ex|؝K$h?/ jE=8|i.(C0A4>uǡ{ %Tr /C=[zGBY5UU{0R)Q7rO3|l?G ~kB>;_GKQ-"){zzCR&jROh@|(BdbRSIH R JQy&*|vg1U`# t!qE'+JPX,rkQq kM=Zsq'myܚ'ʖ8Cu[`ZRLĒk2{: P\~4̉C7 E_zXtaf&"G yq%]3:O!Z,g:,oNhǡ\ALQ#-] VtQ( d 55G/另`"+m[Uu($u%D(unyXKyxc8z%G?L(460͸AϷ™+f.v"Y-:JomI`i mi00hLW!“&,Ù  dġ+xjy%\C'M F7綹f%/Cք]eofrsrf V]lؽœIyIPXJm~fP.\|QK5:'d2ʹl~$ <;rp=Z^)Wq:R6XH QL&Rm_^xǧw|DZPpkǴU(|#bDkpU0H{L?;( 6k=&( B R#n {%V|^ "!;\i-Jc%[ ᪐k-a*"䡕ZU*ԁRUtC?r>pF7:֢>xj!5t%M~y[s4w\A Wʾh A000q0\:7f Nx6-~0;>P0" 1$ td+Xl 1] |><ī;ȓlåQd N)8hD%Gd;Ȑ  * (b(ڃkx Pn(RQRGQqd@x VJK G489}ʸ).LWi"UAO %P΢o]eHo( {IkAȂU 41wއ%MB@ W.BGG:$+Uu eYNn QƩ%+-7;jCo+QV/D6<vstQs^ԍeQV: aS *F,WQ'YW(8I=$.dtyE":6IR+TV_}poݸx9H9~y8QQrǮO -=SOXo7Zu;26]CJVPv#,yj=uOG"$i'80xLQۆID9}(~ lxfI P%a{< go> stream xڥZ[۸~ \/ӧ4)v]tbV2BeٱLMe;@A,H ?jeEVWO`CVVDC_ջxnN cbw 缺K}nU|w|Ϳ 5v 7L2ġt ҄a50 cu]5slpἙ6{\FQS}gk]7;nuۧ]^6"ύv{mj_gm pu὘bTAW}hXR9 ')P'HKj aB=sRQg I (cuE8jJM5gush]G)G\]UX92ͳЈk;vMY#Ȳꄁ[ "uC0<<9E)`xU]ЙScN)Gu19z} ##Ɵz6!XON6GLxd S#!cf8O];<7` Cdx"U}KOm}Om,?4rd\_)qk]f1kLi|k^ Gi}g &t@/zsn`a8jV4WSKg,n fb*1% SH4PVfހ4pɂbȎP9\,F0?aS BAAMžo02NMY8D`t6Oqڋ0s\{jHN'x-57ۋ{PS?se=F–idy]U~Fpڄs)wxFp18IvԎ0jk=:6;{tA{dcGpY6 6y&h*6#Z(D˩h{F4XQ4$e<%SH1VY {Hq|ksNڊmҘLշs3fpY`nѶpL5j_'@T:~~{\u,ÅܘdFe^i,@.l/D#$0fvF'v&YRء3uNSj7pM &Dya[3ӌ)<0V.alYb> stream xڵYYo~ϯRO6{4$l VZD~Mw(]66BYqM텱~%T4a'>>^6ٱncyHTXo\n*/İtG.%6zd*Ue|M6S9T_*lc@ x*7c4$x~lۨBBSϧ=?;#:LjC*4* )* ؆U᳠E![NB1HJ;0r&!#$!$oeB@$n{|A:O  Axc+ 'aAypSonh@xLW0y9y՗5IQH>Sg܂w~h8; ˙Oem]@qM! G vy>vu ᎙4l>=twQy HXfCjظܠAEjpoٳ=(9cvŁl j a`/N[-r#B;ŹGqМAN_"HiD*=uC{JAEC4ZK)D crA Y O3zz*XoHԟ{~/zX(T&Gz G*@oq]F3A"ٻz#0A9ԲY.F'!G^L ݂2!21yrm﫯|vؘ"P&4$J99891Ʃw5@ nɬ]?/BM26wn sm]X(Wf5_M |v̠D^W.DmoƋFh-sW0 z0qSaƫ\º=\Y'!𝅳8VgAk~w,hxXh?^{2oA"ւбʖ5! ݂N1 vg(.z#KW_L,l-q-T &%Nבçhzˎes}z$]#E8U] /_lߒshD'wYfzL)x<Gsآ.,}Pڝz~8qCg~=!-F=(j-<ď20_ !-t[tz? $.:lxX0xاcp,`" =5_A\z΂Sc%ЌQ 4aaF3z& r) !MLtu.=׬6q:a.]֩m.sY2)@':ǜ,yb+Si ث;-N58T-0P7\yh#Knz@1w*MBa{â5sc!KUq&ZYTyA vp7Z .뎎[KBK*PSK")AA^7M2X@0!-XKS%r5Z7#PD(cO/ `Ϗˈ^@%)Hk *0l,ؙwք 1JH1JOhFo3"8a<lh;|^c}`ȨUҷ"dH: vG ի 2wX rH"ik E&hKtyDمTs;5ꃭ g)yR<5X]oI 8pp2甅"qq"®AP 3s|3btqt:2c)Zq !lt7/5ﵟYꓯu~(;Aktfrz>ڎ:MpBWV:wOpNﶘ uǫ28\3;\.?AE`>>9gޞ{qX\rQ <%AJ\CD ͛I8-z"¹ 2E+ߣWX>23.P١)2#W 9A Da84Y7Z#G&_/Ez8ꇞl6P[HSJ_5_j c՜܀kFf?a.>;׵xl(Ɨ `ӱ;#ETT-OC&հbV'_<z(sqmjIlGR\Pu͔1ڸQ4 k%υ#Se] %gM, e}3gPy$^磫LJ4!ĵ}@%զkjJBLn0*_%˰m6\ k*cr $&p߭t endstream endobj 298 0 obj <> stream xڝZ[~ o0}J] EV(%G3|=nELI9f;])5ݟv߿;FN;QbFW?dA)ue>;|&;Ҥ˵=ӓ=e`4w^ uu¿^g .6~2LcO@$@ {iEV6+a38[_dp؜gq9(g  ^F`rh|UV |BV)zפaBn\m*T mtRDۈ,#ݣ^|j"LZJex=H8炇 Hb=-4 ,)D.^ͭcFoaL194,`rEb%>+P/}  4?c#⠩G?OI (Rr RA6D4?Jɜð|b%UˢKlaRyUmVŷ\I*8)`QcTnv L70VhLJ2Wt7Q:z}`; X2oi{,WRmڪ.-3 Ԭ1M'*&#Ǽ!"HV[b=M:NغҰn +Bs:eV0#$莶}g@8z8:HN6JƛM`E=_zZ/h~;G ^+WK{vd{PPVuFy'Sʇm7&:vmˢ%ꏭ)Ij7oq<ʦ$A=VҋC S;LG(f2&c汔Cy:ǘ@^':n#d).?Shfh}9uwR̀] F *?& -v1o[RȇgGV#&ӕn! ݹAR0vW6Q>XjCy[xo*d-ћ4\yEiA ehS]U Qps&͂X'?3iT ~Q0S+Ut3)\o|zU3w$k  Bo0Ə'}p_4/onpvY) Pc@Cò7<ν;) e Glȗvb"E'Vљ3ۇiޅ6;[s⳯o=j)Y{x~Wak:l:pV37nyMhG g,=Hpe{ F$X+W2 !Ǝػ_Kz endstream endobj 301 0 obj <> stream xڥZ[~0$1ëD=HQ(v>t5c%Hr&_sxHZR`+Js΅Z+ĪWOo+YKzz] ڮv|ߧ(R* h;:{3wz#m=v-ltn²]2+[i%SoǦ}q_`W?sfl&0{ SFۮ֧\hƩwͶ,v껷:&n~fۜ5}_| 㨭.Ĵlj{3nn)r/zmDԙ"`"CS>XWxB KWD9pQ Ϻ9TN j Ta^}E$H2IyO RZƠĮfR]y^%{RTg͸ǑqNAMpP.MҌOmZZwdp0ܶH#z!j=P{iYN }_N8K-*Ȳm:4הVJp̣V NzАP7JQa "l ' k%025% <,i ?9a e~ $RpK <45#V0Tk˹{|%x6h"B \$1 !ɵa \{ۃ1R7r|'|iQL[3%mwCMv=={7?t .as C Z0_т.\ՇzᡔpT[jQ҂LF#t)Bnj3$7 /PVO(J}q1d-(R$ NKNjCn@R d1w)B6hAx~Yn}s[w2'%d.^d0iq^mQfz41]q\ QЦ pr=Rt0 @ED" D / 9B" 4 vInޘ\fI ͸V` jc 7Ʒ݊NHVu?ઐŐSRU.cΡ-mbwHKi9隟ѓuu^'e s0@UpAO=\>Yi@sY}`PH?6uR^"TBwe(/\ 9T nXfH[ ).]hΆM!/2h^fe3Unx.jg& Ϲ?նgs|'BdP@v!Rڶ91OS!ps~ܪ\loeƃ32:(+CWSMNDI \U%[j/C-d#aCE`Z\IА` 0@YY{jܙl`3I>{r/TW"iG1"BF4];gcl]'{]ձI0s BM+c>TQ39[*xrn',kŔ,c˭J@auߝγS"-*"Ad1GwH`Ӡ^I ŀ6L3q?zJ&' u2*@C0iZ5܂>\ ' x'ߡ藬,GW7Hn,*j9nLVcR":wF@ԉZշ@N$pvAEL%;i"?*p:ɋGR\Eu5x>BrI &p]w^7qpio~'.F: }Ц4:wbnCRHfI[o۾~{x1G;׿|ϮQ /tr*@ @vm 8(TBY e}]wJ!um2|c0p?r@B36@y.&> stream xڵZK6 ߏܲ 6A-vƶz$y&~X%)'"HMd"W_Vb?rՏJpx+WBSF)V?m_7'&iG@_+-åy\/8;=s3Lqj K6MW}~4#8fWU8;MjSaҸDB{g: td?{O|=>ºjҎV1Bi?D3c|V]7CЁ#北綹Hޝ5:e^$Y "rO#)úysWwͦMnw>&aĭ붣/,/bZߢț8/+mpo+$"6V# a`2X XLX1sv>ۧWdYlHJif5F[|O}Ѹ,sV{Pf!>O]5KVgUôaw?}BBc9=hfGybZ<^OxRW[m,.aaJ8 Z9bz|jѨ=SjT>Iۺ0}kX )53\Ct8F1EW7`ϣнZtjDi&ݪv X*N֬FI`o٦*7f҄ߐo[ZARVUiM,Aߵ&$c#ᵏM{L t]M5(M؇b.R3!  #IoSG3b+řab$t /?7d ݹi\d:LHkc| Z(N+0{Ìb4<[DlIQ#J$j v l+9LŶ'lo0WuS ^; |J@P=cʀ8D4"VAxx>cAgTleGؖ-gƉɫl߳bhj[t7fNfܬ&vR:BF?`.zD:q`!8&] ''a^ ;5,!IӚ=ʆHq|$Xy|9\$k6<[3hWm3 Iz, F@;11/hbJH`Fd@ĢM**F|53= ~ye^-FOXOIR%NKj$s55i(&cakA`6STۦm`Qs!/lb!ڢ@KQ0䔙1mG|Q Rdp-ybij`9fZl`9Aʢp Z6J(GBL &'B"<7.8( Թ-,?kJe^%ۀ͈iEc+BFUsJ,d|@2bw`-RCAY=N Ih$Z#8BeYqq2&\HޡXЋ h?,C`'®XT3<.=`iӂ]  O#"RMު3Xav-0c+axÂrЃ%1ABi wZz3|5J&s.%.][J\buⵂeS>]U ii;F_KRL;-sb !"UbZ560RfK{>T[©X!:M_DRڤ5r>f/4K.̷kZm) 0$v{l~y;޹u}ePD0 l:iI{W`Un:Nr@OEnkp0U˭9;aiZ"^eE<%% "cH/BoǺi j0 :q~[-v://y8QW}Sb<R.S|KAF<ŷ>@<7g}bŔ zSzLL .W);bn ꪁH&ewlK?, Ml*˹w4:)\2)E8sت 2tvyRxk2 u s?,[eZ Qb!9b%ۺmnlC^%hRC)Ԣ'dtG|/aŏK- s-_H0[:cEAB?(^m.\2Ԇb?j,XF0 f % s@`<@T^ۢYh*mu> stream xڭZKW訩`)RqO*8ęW"ק/pqR5_h >؊?2oQc+&vuٻy'o~!U ?uw8t-/p wm]oχf}~-CYDMX&,A8Dmo~9t>u쫾9 ~{rj Bu|KM(ㄻ;SGI9_L^-NmP!ar&~6zTETYLxCNЄk_jwḟYk,3Y b/W}v&ְ}[_qаLE%3 Ce޿T , L1j?R&x;fu݆roj wSMd^M}i"d桚ðz\p:BUo ,7F }m%lڒ}]wgWFUD#IX%]!hߡ *A^YN+(z!T0!MI`mDa/h_Vo-Vga]6.zf\7t@ IIb 4hpJᄢZ K@s@ u΁}>>2]UbHaTCsX &_E8TE9#)>xo CIzt}_v>\{"_H5 ~sp{OT$N(X{"})^ҋjĴ`4P* :f7!| ϲ%˨?_Jd@?;FYMM"HEhuU˒5xdQoQ%AO^hAa}_v* ZFRS|c9c ; P2p 2&gg -!)}siH/bLuOaz? ԑ;pZN`7da|)D'˒5)o 1"sC4abxHLHD?d2/<}+ӗP`Z;SVmtY-Q~+ȣ'``%y.Vvb+&zQrct}cVɥSmf [@'QRҷԄWla h^|<+ӤOjx|9 u%!# t ;"oChտ4߳)q9EH1 A=Âl}_a..fpw*O(ڋ*M]>T>2UZN&xpB7( <0gD&v;:)ZrbB /xt>KX Ss 7vywO*vթ \eX03'?h|0m&rM+*K` IT>+2L ļ v .QEdkz0 ,HwD2N$8)XbI6lyc4:ۀ{<ݱoFO6E.dT}kȓˉ'C]_TτTHzk.]DZ/J bkhA1e.7-laTT- y!lfbvJ.%nܯ u endstream endobj 310 0 obj <> stream xڕZKHБj v3Z[h73tR;hP#2;Į?~Mg%/N؝PvLWJeׇ:j>Y]Ҵɟ_R0xeI7M/ܫ\1 .Yd{۷WՂiavsA*#-lGNG5+Ȃ㸇#2X-*BZX$9PvlVUI=NViM40ԇ}}*3uF\3 6ƽBBt&:xD[ .YW{V=E :P Mf\d$}*lX+]wc3NH#B؜}@۾:YRX2a_{s=k.Ãy A*끅 lՙZ6ܖiRCnж襵4 s'Qv1B-0lY/8XA`eQDQl 81 x/\МOÐ~ RvZ݊CI[۫g2#y8;{w$liWH쮇V8RG 2tf&EuqAS] .hUDPӧs(rlnQ`lXJ ~$B ĮAQ]Ǵz 7+"Y/ {gri0 irȡ"R0W.B0~Th.G)(G!cm]r3NPJLjмx(L2S8 %ǫUISM,-Ҧ zhEԖ!7Բ|c]D2BI9XNƷBbm8x3nF¨5_10SvR~ߕI7_Y݀9ѷRHF"#+V#ScSqdx,>A%L 0qad e9=o C 7n#i[쨢ﱣ`6z dAH\h6K~\-3b0]}/߄q(/%9gn]*By_ɹU^'-pr}S#]GrIf7)i?1;&K|zSBh 3d#u2:&ckȤpҪ坝XtX9 &fRjQ\7➠8Q 73|Q"tk0/@_w KkC<w]0a=~ frX%8˩qḙpObύ>Wg6AˉXk_RaI8BwǷb9)F]膿vTРc {1f|ibRh d~LϥZcLD{ r+Kąs|x xPߛ~;xadsj@@V x/?Z*7O rof#&V,\J/٭X3JX;(cT7$ѵ].~:fFqhkk` ə\ДX:pG&|ۡZ0GVڽ;1RÍ_r?cLf\ÐzQNÍjH'ax^ 8-Vҵ#'M}-"Pon6@䠐s0] FevLnc"Jv>pŦ]t<,Y,q,ĂWA,چrb.Dlxlƪ #j@[uYJb=߄d0!*>`9}J2V768:qb*W, rdG^vW.~(e@6= ҕ';dc=7F.<m55¯*꿮U7Ƶ[|})?0XHõN> stream xڭZKsܸW̑`wl%ssg %9_n4!G-RvՐ M~] _ݏw?,vduY;.Y/˛}NH6h#]?O4x_F 7{aaK nnjf?;[vn;S>xAn<46qtvt4cwk>7L3N 6H95fԅ=5aat@Y ~%D-P0NgT2:hs~zѼpaZNiML{l8]xke (xvW?}mNl ~e1߷adjsftbC GXbtG'e0$RN6~Oɿ#uϱQҍ=`OxGSő7pYtI(%~82g85_knd?ߖݡkƋ)VTYÃ)ڻ~]b#]E;q bhˍVRr5ߩ<[T1C$X/-R `˜oo,[!E͌-c`y*AqbbVY]Lq=YLsxNwgCJ?tBP@8cPnna\/I4C>ᖸ|)Qݑx[i{d=N$/nV0#lEP7`rf-@,# UNp7x>Hb4ܝ#u$S >fӀEF*~_(Tb|pL%?caGH S Xť(DΧf +(wf/Zc*O<4 9 =S@ iO-yrt9J4"|p`Ty3'xp1/.),Tdl~z槿Uҍ._rEt "/.-TY3c, {_<r@[bOuf+O>GM_2.g|ub9m^aHm#*JP w9vUPzpsؓ>n)pn+ٱX]q }&A¶toKEMͭK\4mmiDգ WU巭(Yz5dzy>P0KyM%l۬05|%h&TDVʪb0BݳƳj<Ìs?Bw׷I-g$p|!=.;$gn[f!CZ"?x1JШt>Raa4åbx%ו+gݣ.K[e {J R]Rw; XKC_;y~\m`ƒ>w%K ؼPfzyrZ"X‘zGN0Sl.%5=u-|#e7G1 0" P"^ַ>+ﱝ vm>,, $dbj2#ҹ)xЮT%<ڨߴcVX*:L :5ᖺ҆=.wʈ^\?M!#$Cʕ.SCWK190vp\'Rpytq։T1 ;{/:pw}I?⑰NH=Mך)cWA |#8/k>2}ȵY[Sؤn pL㛥3vJ5J؇_oru%v+X~D2Wmp2d\m6 }oJE/VO_oc)jbEB"v :E14.s va:bq#t>/+]9U2*ׄ$&|E?'|[D^h&F q2UhKԌl*im ߃zE$?~#8&Ч e ?1@(BU Zx!v,}V]>yj(XP$o/ endstream endobj 316 0 obj <> stream xZK۸WH,, STU)ONqcV"ػ=H HI)?G_ hYaCV_Vz\@W#5Y=>H" i^?МXޭ7/kjӵ-f/+NL?`OmF%Yz#$-~jSsݴk|„7>:Y ^mn|>ߴonMU؛~~bb,qqu3qBf8 )ʠ!PIiξ6Ov߼,_jrYmhb鈔0?ٚʯ!"[[v|00޴vf҉r_#i0[ ;po< 7iR`4ӈ ʃG*+j욭[Uv_{BVq; pϧNEb|N ;_Ч"1 XqH?&b!oZF(#rÚ; oc>"I/h~e^%jujM.]p3Oag컭&9i֖X ,"lMXO}aΌH&Q5첨}Y7|!l'kG ]e(ŀPe=5IdM%b2Zx`Z7V4 q"eG}ҴBGʬ֩/M9ݏcɔJ'@\x 4!JdutvK(HI5!%!rbo<iDlYD~OK2ʚ`!ZĒD lb_~9Ye>ssQ1vZWˣGd$jHbf!s>4⤿R@3[}($Sy[/cchc֮ૅVn9I2[nMC#bH!$e I>#C?n;xr4~z lpJ Rㆍ㆕@{/?:`Sڥw= Ӓ{ =Vu<]]"$ :4]'S 7iP٘:퓍|nF  "?5@,֝KvcNf#s~lL@F 8$3 4RkT]ϲ)XEk욪-Wٗa}  rrB:Mio>̢CT,.W@E"R^^%őUmLQQɽ3K(e)=eS t {r*lLpaSJ0D -A v~ّAħp]tl: 0ǘ 4B*Dc h FFynNMmBb o#cu8 )PU9CoBvnIHk`Eʅ`T &9lT #ܒhd-0C@4;Mދȡ!qwHк1*js [;uMBG,煀 d1e.v~(hge  [PA d!][A TmhΙAQ|v҉Jp_&;*`wНzW]6/6.ꆽv#K~tzJ{SAp/L\' K( |/+@bkG@Hyp9vYjx \O/t W5нT"Lȴn) XBʄ#PS%M>x*DEw$$rddzZY&mfRRlB/'詾 Kd®lT ?{S 8¹m7 9‰Lk`\kZ|>D"ǢF̨/ =۞+6栅#Ŷ dQ66aF; 0GPRL\ 8Uetļ-DrPm_yѴfp.K13Zyh> stream xYK6W]r3|jV3f8 ][7 KKn|2%;m bZxx^wx0vߟVo()Y=^RWO t_+(R~zKj77G}<֕EsrOWk֮=)"Mɇ3Br0&vʾ.&8RJDZmobI$h8Ml=z~RH_$ɛKn^19a (Iosy=>}URmKY~*.VO%\|,*`˳V~BD2.`Dp1Gd&?]oI>wev5CәH. Qv#f6C5JugB)48ٮw9-T'F}ܚ + w@̖ iC$gy j"!vm #&C H>ɤizyyoibx{O6iNJ )>O)5/{AcP7tc^7v? 6g]7N/'տr/ǤbOW^77+^xT(Mӱ5^3^3ww|LZh s64奨Ǥ}/G (%҉^R |CYu :^Z"5̳'`Tl1gO*,a mvAFÑkF"yf`CD@R:Ȣa*;;Pgހd $bƊpD1AoИ(ed#S43}jD "@.CnԄ4 UV"!LTqt- /qG<0IjK,~OPϾC>z ̖BHb~Q̯eLL.LHA !C Œ4HjL~Cmc8{4 J!HAHMِ0`/nK% 8b>Aܻ]C*=^גu8n2D A3AI[%Ձ%ﶀv[)JUe!R*$GQw $bT`::*Vcz1sQJjE {-H˲6i\CƠFOaywl#t9&ԃ^Y /aE<HK{{=PukXCbl0`>h΀N3ꦎ.C*GaMY؝烻ˀ49ڼeG/ˋE҈ -=jVDg">ř{Ǟ mK!8=߇E,(ꈳ 겂uǾ6 5=\x.|şc5bbd"NW7r+c>DW~z|s9[K *\~SthM$$~fltFm30M6/HP5zƠ|cxya:(OKC!YA%B2lhShiU5$OI"kQ6qGe6b45z5^G~B,S5BE?īvº. ePBQ"Gny_Tք%o\z|Ǘo&7W4w7u/(E6P2{+6sڽaI[ɥ;{K$9~zZ endstream endobj 322 0 obj <> stream xXIWHV8VeŕI`A@iya4g"A[G EM{Z 6D!uqe]um-cn[r7?~ s56= D?tSӆ'nYp"d ufwВqWE ҄{ڏ]76;lKA9l܅ǯ[ϊH˜OJ5!"Hjmq3lT4mKnSYDQ0dI(2DۜrdQ"D0Bk$~ M=?q%ٌwWSk~oGLx?{c]N(XD$2H~$}wǻpmnΜg:Qed q>`mn9~Ή(R%Yŀ*9:anf. wP_4}|ERb{juK~=c<8غ;&h'Y=Hk񴃌Xg)(olq_P1W=':w^N3;) I2>%SRv .|iBVP${omnon+jc<{1Dh'J BS(s;?D`v@UC@2D [9c>)O9)D':f'A#S񐺁$ =d/H=0?] EB(pp9kjRPqu&H ʄ xE7.ɣbpU BJ?`L@N\_MrdS?2q[Tݟlv\o*S}(W xe+g.d9TueC!>E,/)˾?#K=nKWS޶Ð+ l#U#yT3Ov"9+Q bʶpYfAj\Qm{)*vm=G_:{Z/TK/*!wΆf<+;WF_T*uuuեzߢᾁ[ջ% Z]/0Ezhj) eEq:#V||6GM@Xkax_?ؖPfH^4M]"0zP붚~W{Wl/kj:̬ra*ruҀn sa, %[bQ``-ï/m:lԷMiXľݏڛ~Tsb"6d* YQKhG/x[&c1 a}|>wgqWiϏ[D@,@F8Zܱ$\ {kTՕ"b>TSn3i=^"i6(6K;V1,u}w)y> stream xZ[oܸ~ﯘ@SD\**>lӤvE\!<#BfF4CJԄf  0E U)WX}Zx⫋+.Yb6Z_^m%`e)k7?s)eV4n8VOpGֹokQfGw9VxtNU,W,\oCÖ~kYdWTdOq{*V9/85zzɊBx~yVfzt{RGU%۴,"; G2;vmM^944uۡl>5 ͑ufڟV;oPi1hdhM~\  t{:*+fN j BkV]cRtɊ:WJeM`YayWpuh`I^r._7ުiJeno?ݶ-=>0SB%mm=/+/ ( *$G8LjAee7iscLv κk|S#OƔXG¶ 0iw;yxM5@n=*J[eDhM`5Lib\1/hLԀ5x~#cAmqR- dϤJIX)67MGHY *ir%M9#ad'$Y08@<tZCXݎ;`߯QkAe&,Y}mgZyKƵhA@o4WǙ,7f ΧV,*K%` Y4XmX)tEpEXbŸ4>YLP˛!+v7IFu'=LF< ˪2ƬwNvhR x l] 8Ϊ?Ưnۙ5aSGocZ1`*{-4D&툄/B!8]?^s׆)N\_z=k@Jjk)}tS4^w[)" ĜL:\G^şe~ E'sT \c'7"lr$6 z_ ԾMoQr!f̨n,T'x FΎ8*8F,=lqOv8f1ëw&JsQ!Uĺ h+*g`SpUds %TZO,N̘$D[YYs1:V(c q.Qo+~%Sc wG mR&Xfc֋og0 2% cFG ^]>*`/}4>-!VoVRgN.$Y(h!?*/$L=X* sOBq^><9`Z΢dUqڔ$[RPRHΈR`\Jwr>CtQ&]2hŌ\ tPL5 vl;Y.EŁ7aJHUUc8 lSsr9 5IZ Y #=WR*fD|֋P<RSQ'c.e94]N_͍Kag8G+N"0uЈ77;eL$m )yI dK ʍeR?&op})t7N:q,ʈ^xgxY+o˸d\i5 Wbf]#MPjA*E\K/48Duv5qe vC‘*a $c,JԔĪHa7{"݈o TtFV`t跣REf|CԬn0WΡN9vKw'$_%vqO̻s`ޭ TJ=1TKdpBT O 1xp1P]cBX;rŕRSǔJ/ d ҏ=LgTK(WB,5 7u䩵[QҌ=.,a`~Ph;I ?삁ȸlCT:}W>/cL)t3qA כSI&i"[Ca fe8@ \Gm?xZl9w]Nkt'k<";M}/hᝥk};9D6Qn^(md0_jm!WcPObdcV]t_66x}4E5<={ .I-#-*~/VXRd`}1^k7xGϧH?U:DQb.g*lvڦ"n )G5_q7{1]0}u<~~ྲྀ*uUF_zA:nǮ L,BNt%ܶf4h2eC=V,Gb0`RRVڷq&!V|NY@P7NOܱE1SbZLL4EVTꌘ-͎~fBSgϒ= kY!3g@X 2ҳ =]Ի+nt_ ^;pm6D],N)}Tf^bBkbR endstream endobj 328 0 obj <> stream xZݏ_T )6C^km<ڳsXm}g8DHS"E 7C.~Y?|ae// J_>,xtZܮl9-WRBiRJo>-*ݥ>o>i7QO[(K#-qەb4NBÕWί954E 2%Ұr(C4愕-VSe{jִȱ>xh"[:~Jz)lD _!-o=~p'}LCvM 9+[jk~#Ǻ@f8Xs{Ӈ˾9 U5XItS#(Kzkb CxnygNM6=ϙaD`+0s蚨P&c%* " mr(%ZP's*S2&Ԃ){$b{oez~ N0QJ0\Le[BZODaJpN&x%Bu<>j|w鼬$>Ctj4 stx hGb%DY9HT%/r(~8$h( ӄ`n/ƨ^*H~k7ڂ. ڟ sîP?0U$\(8oڮn ( R1yZmO]94FǡGҺ8޿_j^knV8Y|la5+9.Uah\2-=6{p|%j~ uxJ%>|o{YR/ .-U5wP=Vm9 {e1}&vHԞ`?y9d'I=, $ASQhY^ݐ6bpӶ~k{ ލ}OhT$,T@0{J-b }Ӿ3LO._9b\ħcW*2JF$bІ-N?Ocܠ&qJr؞W@>k&ԛJJS^JM7a; ~G|R8e "]p}&)zmc _)@&@) FA TO/0$&{IT>q[چ_OJchIy\qHp82e@!dqߞUhM,.S=eP ү*% w<5 ~91|7EA^ f͐K5$mqHH41 cPR^WGğ/EǸ@fA ;[=_N @2#?W+$ϲLappگT< pl 4㲤@G8 18|W=GKfiJ!U*~ KANQ\DѕͥXRU`I b;yM_֠!uNvpԵWjQn/9%E|Ȑ`%'GH+2>d)dqB0CPQdN8c ,* ys^Ō$7`aAp.U-LuaJ W P<ū5|iSbTj,&oOD3;ા͘*$ok-tnBadYN٢/6CB$N,dru=BBP`i/5ub0֕JIΘ\uL`+ҘZ`XY%2.?.">Cϸ=&J;q]Sry+"B+ v|RkūFQ>3): xЈř0xmYOW+RA.y0*@yӗ诐\EB&urHwO3 Vp,Ε ו?.%+w,aP{~ (uM_|D4Y%+yT516FIUekϗ*Η\l.U3B}L!hqQ4,p}ū%x:%*^xZ\QWbgL$uI) &XO/ r8FsI)(aO_X eyblH9FuJ :!L,kMgj 8gÏliu5Ҍw߯}`}~1ɄԺ~ :5ae_ ܼtmwFʡv z_C=tuE8yz{B'$ v44r\ږ8DM?nNxÁ5>󧡕PgLYjxo /g}g~##m`|}h@Ԭf}>%Vf`drAHR%R3>ƪ.'Bn45+:GK~%xuقk{{GaXݢ:3Z|qmljԖ)ڕ!Mp1kyիbebeK+ ;|<ȴooP^,[w}f\Uއ:U)%C l(Xiؤ" >шq8^ ~\'9pD6:!$J1 ;_` bLWZ ^jذ(1řcToDa9 ',\I`ےt~6kGyX&T}z,wV)K[ ۃiۆZ\^ mf&?.q'{P IVdҟgd.t5';)MTQKb?YJ+{fQoF+234 Az<ٛ?\_ endstream endobj 331 0 obj <> stream xڽZے6}߯SBUYI)8[ŕxRT&DI1Iy<[ ǛԖSntco""_XY|\$>,AjnxJ]kf4{,5ӗL2R-D'C.MP۾sfdP]\XImQ=ej_aV)'«.(<=;XdoV6Jx#Dpbþrq ˷6z7%>Ȩ%Kx|j5J*qU(VPȤqyAw.hBjƊnW[|ݜڮ$-%w*7XX?Nyf'ǪX?W|J剀&[KKRO)t.emux7]yخwKp*٨khKz}5?>칅޹Q{zWZΌt\|QwjKFyDݴ-W* (st>s>0 ]zA; Mv7{^v'0 6%X\m`@gpʹKn^}+%B=BxΠ},έb`{>l'Qs^&b˿ސYp/ t-i~`]WqyS7`㔔ѡC/I"3R/Ÿ%<0t1p!| z6Ggѡis:V=ՃԀo#yxYx7OΉ(OGQؒK:DE~HI}7;xv9TSLŒ~FtDq=GB 1ooCf.Ǐ,}NUP:^BϖaKe7è}^ZsǮ9!A~/rKv}yqe1YQ\ 0~Ilɴ&ҖPħla`kD7 _!M3s&9qET9Ie|U7]"I61xΪY3LCıM60_nCөH~69^2~K7<ӍSg(9d "2ɠdI-""nk8v_= JHAnCuK-bVJXE.ESNdr~D ;ccc,J=#)j`g(dܱıdm^I)Nad>Ia -TM}D4بgx4]#u"53YlXm8k-]Xu#~R]53Vk}iÄ}`s84 k$`AUKA.» ?Or r5?IQg1oUs"~% `gCB:-]]<$3_NV7xEJd[V1g+3%dCfN?@Hc>%@$vS;do 6 ݯ\j{zM t}5\R>hAcʱ1j.3g3 JaJa1RL6d9#0|Z0UYn.'Pm0-Og9MZ 8oco\zGcܳ: >DPo~"!.M/A|kNU8QG#[3n+o%pDI\RP 􎕂cXp\RxgN@ jeQh^p:bGʁSt{BBCUgۋF] ,7B.&k&L_P"ydjxOKA~LMqz:Rep܎!D_5*fJXkBSuڥ)QY'O\EȰP1re}(hS?kTB#";=%TC#j fVXH4s5:E-hD?űoxð"2'|^ 2& 2zv8m1WOB1W&3G&ʱ(h$ N3V'$-A]g7#%RCXOJX8e}q? 1FA:3:/^_Po}57T?իo_ﯹi@3h)e%A$> stream xYr6}WC&Bx܌ӤuLS T(ʗ PBɒ:MAك}b7y?oGC)c&$忙dZUs^ o{RtyYwϊNzST WG،~ׅշv+V 'j1/n/Ib+>nA0d iڶ__`'dӻ9zY^j9F; r 4*Dt0(%4Na8z=vAY L+{cT`V.j WWF[v͔]|7&BaeX Gr7|PT |{8a< pkP';xo66&- SH9&[7E6ubǫ_+`~Y~3'a;͍= h(C E[ eP*eܧ#5΋R2 Ms!ہ(4YN/f5vϔGu`ω ]sHW|R*Xv=n{z V}֚X7Q:zG"G*V<<p@  ǝoeIIBn=ٓIOstce85ˈe]aKLݬuZ=&h&i Hڲ1_4s0 -L0<p2 FN&.VNuOq$+xT4jԎ4 3y[ڇbS{Х `Pr@]c,=?(QCd~6 _rou|1] "qF m/~Yٍ.䃨c |HdB}tM$Ig ٷ%&sLlIj"x_5 h3cN]΢)dZ <.RNoWA#IB6y9ח [2:smyХ fAejfS_N9%x]29zE[ ZT A`#I\y> stream xZYo6~_!`G I>elf rz$=[Cն$ FY>G4Ji;DE4%y::BGb/1ΈRfc7~|I8qQv5CScYWѵ$Lǻޮ|uBsMQ"r{}?pU$cjWs<}ʏWyU׻|82g[U?^h'iF㙓xcDrPm6aS6a~A, r4^)za p_myf`$ 8r߽u9fXiW Q (>G>yJ"J0Hײ~~posHhMԯv~V~FTy!F14Ǿjb H7Y l2ӛ[3H = 0 wPPM+[HKow\(̕vD$:775v52JtM_;ʃa^&3ccVaEPXyeæuq??)ǖC T@ <߿yʩeʗ+*g :9;ƥ]9ƃr >y>MsG` v%Ō`|V侞bE͵kNq-63J(<0boH' J)*)0%Շϭ H>򿌦񮩻4ӨX Wp-TjfWקz&pсHR[Zd[05K7ho?ܢUg.]1 .ʲ(9^oSs΀+d\Xt)݋ XU{,ha#s"MBuP.qiPIst} . TWQ$Ǣܝ DOqBv:LbiC(&18>+@!0' ө۪s-8~tՙnDbK{Gv~6Ԏu6Z֜OSҹ8j(7՛8ps氶,K> 8vA@@xhj-xnCa ~[ӟ:HRW:! N^W}F<ܦݪx˦p﵈ŮRa2G :w\;[6ym ip}Tun8n'[CY <}2[κ׎V$To0x. 6| aMUyp+wBXdtFrmU#<׮)|m:`wv?ᗋR SAg * "[= y\QjTe+z>E߉dFgF P"ށB;8L1Xֆ]$:;"@Og8ٙ3I[{w@:'1RΗ=sDK<`lQ\G:J40Wd&vn"aK?I IzR`CR1Tw4)TY|8 W$T?C!D|ŋIx$u*i޹d0QcMm  j^X0AaXu[O!_bkP\{f%NuL8%|Du=>(Q^&ߴN!hi# 0 MpV̀]3! l\E? KAc1U d, ɬ-' Rm20jN0Xk$amQ;d¦i?cڞs^J>xz)TO~MauV>8$'.,78a"?u  endstream endobj 340 0 obj <> stream xYKoFWP'tCEAjZl"萒RvEh\gD"Q"/9%9YtX1ArEmqE""R?/ؖfsW훫_"Ix}uΐ H4IsVI"Q)U[/V"~tĵ5<Ѹ,7u4JjPQ%ayyUOg<^녲4hH2!SwaijU%XkoYu˶ʽufu|7m^+:t:hoj' Udshqw@T! vUެ8:h!O!lpHsCIZqk4RN4R!3{&W /on0Y$z{cG糠3Ejbgwbw*V3/*D_|hC$.IH{%K;vP̓ybn&(%OI$$!R"{U;!i]#2|Vq!ij)ՎŽ4TXPhޭ&R|03ڛ|1 ǐxU>eTyhYs|9>FE/BzL92S,r9hxi, ~pyHȪm҇kEUN1T2gLDFDjH,ڌdG"z#rO<=_8Q¶`PRI·JRz]9ĝ`)Tls$V?=MÍI'hF%Iښxy}oLJ{&hO$ M8!AjpCû:INLX |4$'%X"rsn;alc%Rpm MG!d+7mσ'6xq )*8НA'0X, XS`Izemn͚UlƻKh1`;>!E!S[zcw|S@Pq6Qzoէ}z; |fTk<o6"J[фP8 U.R*=؆T vo}-l{z΃34)juW/NKv=ϟfx%J2cc:v#)Sf/$6aVx Oy<+UZV=b=;_0%'WyfJ1IG]r[ z I'QJQ!\ Хp%M H/l4 y0 [Q.D8 ꚍcc P⮪,vbg + l๲8>r126(*c:աb3ufPss!je}IDpFGOa_°hKbaCmk2caZ;.z grSYRrWa"8J?&Hlq!~m:.Likg3|bBҵi0DCwF endstream endobj 343 0 obj <> stream xZ[sF~ﯠ/)ddNl?` 4(7v߳EBcn;dXٳ}8/΂/Ic ήLQTp81gg$%_z,i\B_ZѯYDT8]eŌȰ6Rdݩ#B8A$J33=KR}T7&z;1}5᳷Yv)%MVYq*0NVxV,ҥӥgȽ1N^on7]t%dH`#|ݿ͢#$}vkcll.p֕Z"!AIvS1JuO83K_jc;e^>X HB{; ,ҕJ+՗ :wˍQ0/qZ& qܬ;gN[ߤ a%{sj!i-6h[r) ]gXJx#6ѹ4ʄIeT&Vt{54?_>D@}(qS ʫl(y@1kgɝm< 4=ߘMǍ "1op)dG2! X&4GXXm4 UΑP/>[_l7=$icsq:y "i1LCF9 (x^,AD4뻼$no^rDH"GIOn.EkyAήl':ne-uN76.G\2BKg;XG&8$d` 4e:xeANߞP~O1&ݶbNRx pjWq3b xLLtOXb,:@ Qa@X+Ax_=}chѮF-ڷ V%{_N*,]uN#R%D&dᒰCA&%?trP>O6` -_s`B|9Ce>*5lu+ `,"zmG * |Jn5 ּ‡\H`*'+XwȏQpioxGAMP EY%iyψ[e!t]nvQ(mCCyZK9+SMu{'e#*n }\:jN3f؆q85't%Ҳ\}.^M>C͛F&ȪIr˲Xeah eӵ3M!j9G\rZ齟NTԊ/+cɋE>|b'Mߤze pNzJ]bO]d,5 ڮ>>D,Ѯ! 5= K'5$D ;;<qO Ӂp,|+'zAҷ$Pcz}HuN f^m[ /1Zڢ߫Ԯ#Cb~ RB!҆2VSgo|/g6^=vx`$}T?><|FA )6߻h,xO{FTWۻg1}y v?kb ^Xk4QaāO߷݌n{|dLlO -WLFf6ot $ ~m tpxboLq՚B> stream xZݏܶ_O2(OM)R-΃nU6p=|.о>XE g]wݷĎ+r%T?}/RLn~xUVzjνYiҴ׬u88;/WyΊJMJpGn<<;ͳlZs;iϚNl=\׃u*{pOɤԻL>XRewI*JtLwG_#ieΆ"~Aҽ,8J`k/n}J*3e7$C팀^z P9pN˫“=w(>?vj܌SR2] O[Me]a.;~.HQ2QJOoJÓ[Z{V/R)+0p]?s^ä 8uhk;5]35u{>=yfǫ[ ʷڼ+eK0%y2l$z@BIG9ZFsP:>^ׁԧB\-f+su"D둝b0zƉϟ;#:z/+W@,HS=ыdihgX0&C2#)MXyR"fK,"xq4zEUxMЊ]~\N>Cĝw*kG﬿yLC!L `sHHєL %9SUXLI)ޔ`wVbXz/@ϭx޶oYAĵa?*HXY)ʘP9W=*EI3Ao2\u k@0K&곓2WMA'ohMMWHP1W mV5f*t՗ uUUhx f)@n9>~LrQF$ʸrcy+ɫg0C]rJã׎z:KYy293΅fr/ eo U8kCt[RrK"(sz>9Š^90ir`P=@6G`d._1g3VwL7.+@kO™pΆ3أ >p pT:jji=kRm%QGf "`rїS5H;[F"H~$Vc:mV.l.˾^rN%rUDc i$T*-hp)[JsfxK@:XS`@rŇr1e6c` u$A^ᮜ@ɊB@y\*g`&^hDnLyV > stream xڵYYs~ϯ.Xeb1zS>X$l@ _(P%g0GOOO_7W*?J5V~w?蕊N; |dKmTB@kBCI8F׹}90GXk5}5P]T,\1'qIӄIz}OG5I,<4Dq ,ʲ\=8)w8֔+eЕE_[|3(ZO\>W'ayA,4Y P~wI _ݾj[/ױMɬǞ H8wCYP H78O;q=9tVrOm \p66KM) :JU[΢ jzH럭]5]EProP3(_[}{/(qY\nP{/?x|ӭ>;Qo3g ,R;NB03]*tn#ex)YYȱX`ho"X#ǙC]g>Xma,$ odAKAk~!QfWi-8w ft%if#swO3;;t)aאBhY\%3pEa-MA2 ֙ AD:xkGN퀯̰\s`4`cS6v_ҫu%-`?]I\d!dxSMpx' &"+L2ڠan@9X8r藜 0 #Q$XRRQ]Rj &#D, 4S4\@".M0w0ͭSA 0s+S9WJ8̙,"ݘYsNJzRnr9#ȜVIՏ8 1 O^lRh' ]?JsB S9]<8+UHE[ rakŘya i^K;bб#(()kHqsg I#j?SU P}2:5~a Cy^3+~Ym,lB0AvIEEkPZ .9~%hUpF<B_ODضGH>plQf V4ZÛTj =f|VBrBܘ(Hsgq OUn[zcrVyH[_'/,WLF'@8c-ó?:.TDxR2 ^8/* e/DQ|(TCaY+DM} ^ɰ$Җpi.%ӹ qm_N-c~2I $ɻmvEp Nՙue AI(2NkuUfZA:Ih86X9w[ @b׬:UP`3%7ۈv3ŎVZA$Gp@mEI}]Ȯ)>zD3<[ IWp p[HnX7Y'r;Z/jյd{0.Z髍԰{"ֈ[گ1/R]4tu-Ni$8lH&Ţ-WmGVl]veCe]Ϟrc=E4Ȍ:XHM>QA:4oY)c˧Zu {oX%#l2=,s(Ą``vbu/wdwWu\zLxaR93_Vz+λ뵘(AB@C{mhcɦ?N|@'Uvo}7sڈ_)+.ﯕx\;6S7f)y_WD%. I\W5i"-|5z ^ ]: 33@OhW~ALf?_%7u 5szN'we'Ʉr{׵ LWYDcQl/cﶙx;:`c`Ļ?~?~ endstream endobj 352 0 obj <> stream xڭYK6WQ#F")J-u]-v!:z3뷊E՚,J$>uH K9px~HV&ezx VXo鎱"?c)e1G=ض9馢E?כi?>4cJp.KS2I* JVMN4g1>Wy nd+Sr^XPcF2YնrcvTe6?E82͹E23Ji_y=c+ۙ`VYFn<cgO,"[yQYihYAЅV7ힲTu%<K;uɌ`$k$=D& D#0Rm쉃M ;yE?99_qJCw>E_ L#4=OV[$#a 2T2mbԠ:ҧY448hDO)Jz *WolEd?oq8@QEdV#]dJ+]|MܷPZ sUSr.:EB d{|. LĤ\yPࡁ )hOq>y!]8'sȮifEM["gER?8OppnMa2=>RP\)>NpNߏ\B5kT>yP?kg?#4ϻLX;T|3AVXs5=jDz܍Y+=juL01dPBt|3I;$= wy^Rx{MTW2ubB ,]BCTRя[mM}4-T #&CX=Q^ K@k 3Fb1㢵Đ~ =J]+ħ*WB3ϊt) sYS BIP3ľ dòEUKg 8昁5DQpfp L\ Γޟ 1 K˧c<N7<_،C CAa0#%},Wa@! CJ7+,|7jsDqc 񪱻 }]Dh*20(x2X윜qOdw)2-v_mo1 ₒ*^: ] G~8^ Z,+{8;bk̋|kʑr*空a\Eg!$^|BfoE VbѪ"qY,yP[Bl*C*sGz}$XƆQ`g}XE̅>:K!DQݸ0F0/BlBAnғߖ y 9 982Jz<5 ~rNJZO=u)XcS>T{H@ȿS\qCBUL7J$[x"ٶxOP^J]BwI _ i@Ptt3vܵ6\T,H`RC!#4˭sϾ9gS>٦ Wl[a9! Vkix؜ eb/L WFmc;v,1ٽ [WS+>>~0? endstream endobj 355 0 obj <> stream x[[۶~P:;@g$v'44'\r,v{p# v[3ӱǢH 88|^ BQׯ`,w MF_2bksO\1Ʋ޺/w]s84ُY6^Ruvԯ_+J4_x4vco-W\l_ng|پ:vG?`Ɛ` 1cm y7r_r_t}隔dkXŦ] 5)Ao+tv,KL5TfM tޖkLx KJ%’ƬRc8UH X375z!ُM_/"+%DDO: C`I)_NGc 3&>G ,̸)jM {gw[&1fNQ^/  L'A<;Ll?KfxvڄigHR~ܔwtR>~_yxAƇmj :Kj^jg|PRNBe;M4:RKk.uű8#Uay\s L*hdHuϫNb$h RCԄ % gf;s:ZX3;O]qxk1 '@w;5nQJ3ubu,SVn#!@@r@cN F^aG^)foZ<"qD`MY~PI}0o /^5  .;I/L( $GLsj0#'q)9[PE@wAyJfsjS\mmYߤR48V5uO^~Vìdz$G›nIܮVwE pߕ۷e2$Oy[«o\>@6ٓ(-ZF"RHů_5GsL8vArj8jKK_@fWaD`ZIDcۼgRE&)b?)'.1g@f)GO8`7WM:)r ,RgUAa8`BFl?%p^1_ <x:Dٗ3 5K tegKz8BHyi ~!(ٯفً#OL4-:/2Ky@ TuQ3 dbL*?+Ɓ%2 c|zj=QfKo&[Y\ΉҶ1)Ծ LJH}^oM뛅pؐ"lIq]:ɤg[OTA i#yOj_T]lx=/fs[;D`i!5| mgtdfǦ;*+zc3\X(C#|"̍UMǂ|^%{m(iƢ*1Ke&Q)extai s]Pɑz~#>1U}՘ jWnm;ێbEn^-7ͻ}.J\>GcEIB>٢JceN;ѳ򀖎g6{k8Gm S2 6~C7]|D5e7E$>c @Ia:xB##⾲iJ S)9ݾD6f[=M[9)nTI7޽^Rc4w^|g$ pIB8U:%q[@*t:-\80b_76cYu;U]g;r[/͟d5̙O Q*cHwzcN,t<f7w4˘§C6tă`[=!+;7$p4b/n$Gslwc/=| `2?Ԇ9kdH̴\,8Ű,u&:Gϸ;p<>,ۋ}F{W}ɶv_ҟrr=nϺ4Yal:Qٮ_#ĹP" XU0);c:ecK>fͧAj&6>˧F>odyf$>Uh+lN5{ 1t!3!,gMݜCxnkPe@ʥٳD9״*"L8Yzzx$D҈M1`_eCѸ䄻##rvz35%4Jʓӄ1(RMYCaUuC/ZkItg2@:?y0x$]ad(ov3-! KiJoy#soXpw}H}")ƐR*NkGZ<Ç,Zgy FP`܏:=Nڄ~d_kHa Y!*!K|15-D?_~zgcXXUuW!HDm$nn"U^VV= endstream endobj 358 0 obj <> stream xn_AC s!-X@l?P"eDݏ9sfxG.H pkx&/VǛuq΃u ,)oÏW"BrI)ëDža=}q/ }I>6C+E x>ΕS9JYƥ9{H%*w Z܅KZ$YDgJZRB5-`HP9JQ%`VE_E!t<_)9eD(r2I@pϟ&Z>XfczHzHW'+z\YlL:fB'Vvաڗ⣒ )ȸ<]_)f1+Ғ)~7BA0XT1&-+w[]Z=+ʯHJ6a9c\Td%)sˑPpl '䚬`"E"¦- XG @=o*\iw^ڴ`Flyz9'?C_gc1U<]r[Fb(uqȓ֋Ĕ`iЯPI;,"PTgF)t֕%‘mcRhqE/v3;]ѯ66UIa7>Ҝʙ9Qrc5˾}7%h/> Ft@Jgc8bΆly {ګ<wn5hVc;8ةVu55n%A&sj'7}lA z+L6E7o2Й$ p/q(<6&y1Ͻ`eC,Q+νj`(]A;4, teڂIዻHlo QO%` SčD.œ\? :ә /LU (fEnݸleb g[⁗_z,|p)`l}2QDJߊyW|tmEWpPT;as'桥D#DaBP6Ѱ{:n]ѓNRb h[Axg"Px $ #ʤqrwI'&x0+,n;Z.F%5,v 0caĹEL~}cqGLYqII]^1[xhY2k,0շ D"n$>=SZHGkCsLg).0gx1EL;C8w=6c-ǡ*/w+lಓWmk^O:x#30 Y Lg헫33=$݄ž]|fj-LZZ3Z FP|:uA&㾗ƌma6fDYW/cg-b6Kr`N&M,)*r=T/  =jAv~9Ӊ3 1RqQ 2~q2r0pq,:1A ?5Z[D\Z<o!Wgav(qaĆ:ظ ?35҆G1+3#\$\ L 걦MUbL`KtoMAJ-QO c rJisBcqW,s&O'9jFsTuxYAiLv(1gih'bhJ1 ߆QQY9rް0 S(}2;=K䒿 f2U'Ó+ơ<ԨiUw%%b(?ZZ7o^;w"36q!:-{'+2So)A-J?'vF3c@qGD-6ϒAsb9v$윹f1 kVO~oPz+ 23JSNMcn`U6 Ps䓜m(F"ވ@U:P#fL "͕*M3 i%o ~qUO C9Z)#0qIK5rP!d~*MR;b `[X;;N^H endstream endobj 361 0 obj <> stream xڽYݏ6BO|8[r)zW(t֖c!lodɡ-@ g~3:5c,3l}}gGI=l3W<+c|oBe ~O=2vUpOYq~ׂ3C,wY!LyfZ1"/Tۮ그9qh){qѬ#謸RL|Ge=0*ϕh+`<_ 1Ѥm n³ߕ}Mam8z*HUDnbr4Ĩoo)"ooGu|NRqKEm9A v)%(mBBCg<v.u2` Gt9~!ɀ A̬pDMT`HJ7ʉ:uV)R*"p] ܅0sHo}XZusuT8; bFjqa%f_QsK( cJ9V`dO3) SF#|8M}iJB<4 ;܇!#Ð!dž].5 j0]8!Ç 塷نgӦTq/Td2 %=xK.ڝ5 )EۅBFhm=b_MNCޖ`acˤR,œZƾbɏ=nhLD Y}JT )s>%#%b6J8T^ՎA4j8pwj"$5B9?5=44>8a|v.\~7~6$s9,"]M"2&~=1>#ͼ`.XhxViECH {t|)V -^½cRuv #qGZ%QH 3`ÔB~sIZͱJ*𫨀 6 c@@'١77],2?; -h4f5^b,~ٙ 7vLS2m¥ɻP! I¬lmþH;5K1O}Ux.+۴=ݓ0DY>mS?/pRxm%(F_SzFؙBJ0:U؅ׯkWȰ$_ZYy`4>aaLʁu'0^Q#$P3~튫z~/sy}𙘃Ok&ut$e̎Jܜ1zrg?s1A>'JBsH_*5;3xhpg m :)d A5Nqm}`> Ǵ|w)U$,T p^_^okA/]qFM")m`4d lؒta3}P:e^)7ᢙ+ͽvNz/j]uCRY\R^.Ͼ))mbf#1}'Tw,+J"B; ŋ,1)_r:։@hj.@7]Zk rr&T 9L$){iY߇{E .NxslW&'{"~v?EӴƇu>CkݛV9*.B9ta2e5gCSmf~Ns[R_QZ]fVT*9WM뽐B6el'ɦzޮh}lf#O&OEp4yd=?Cpey / endstream endobj 364 0 obj <> stream xZKsW-GSCJ)PcRUӍZpfRvA7}7_6lC1|(i6wf7L\هq۝";)eVɬhZƳIc/^u#"Z1f۟?3CA* Y;!5n 0)ͳv+h6P x2 9-ewO}ɳPi4j8}'NK1 ۖNǪlQ]iPY l! xp[nÖv1Z~8o'4)z)jq`}Uo)nG n;)%0eu||lVAP+VW}u޿r%b\|U6!0q37S׊jTt!?IJ]w<$q4UG܌ӔH OE,e9s˳, ΐu|NS_[#М!Y)M0'ZpC#~u [:0`*8ϰVY}e!C(cN*]jiA!Z89(2WT;F(@Ӕfף Y nbrNڅ+H 6>,*¼2XץF9DmqtQ׬L I0cq¨j uKwC8k"(lBG(K].AW86TU LsSwï~hɲz.UP"r!f%#AS V5r oXI֩zv a }.X"2FBf _xܧ1|OS7ގuIhPm7M]Cr sR%}di1r:}!Afǎ`F*W@r~~gM*q7&&R:뷤) RΊ?+w[wdb(GKGby աX6b8jgǡ>T_@}Iy@nxYi 1V, x9օZx%ξǮ "?ë_]eæB/LNHO,S: >KSbzVE^=}|¿1첤"ܫwI-ketG쳯x3:̨|Ojݩ=3 jްՄ9Apك$J,ċB#I[uU `qeAK!IZrz,p:'K&;'8M8cW8 ]/fHOxY")Ox&OL#-? f7(XoܑZԅS 5F~h2 HPyILYR_uМ FjfCS 5.wezE.SET3ORp)ZYUUcp[ uFuzik %,?( H@9AzI4>9e\Ot[SȆQ1xGC0UX45^Tƌ6J/nP&7MV9 Mp򱾯}zUpXD;_3v RfL7s)Df5[ha}G=>ⵀw) JrW m:ju57j ;[13Nh][}v~m++?왮St8 ]'aW%Bjގ ,}> stream xYIWdH\{i2$8i8Ru7aI*=J|ޫ\V;̠Y,-Zb+ pOWOw%[ݯXbX\3Vl~ Ng~f+XW~=r]ݟ7fˋ|͆N2c$O"277cMDfGFQ1xQ0MrpMI3JPᘉBmrf.2$+Fbn kP?G3~ 6]t_[NL ‰4em|7cwF)AӣlT8axwRKp ~붱Eu_uS[v5 F[ܰ:m#Y#Vx:{?r*bf0RH[%zGKl+k[aQ R{č<‘YAP|j%*=[%ca @U@(~OXcOo-r Ȥ(&Nۦ?waGR,Y̅kE)Sd*9 6s8j%7D|Eq'[a #o|sXN4cX|kYD9H؂ɂ,ns (J?c&f{yBf ?j0!OhnUV\Lͨ=jꥌ6$@U/bB"g2.$b5l r;I`69Y47,>y nWR. @ڠŻi0QtG #)|u0j.zWa棧F&7>`|Ͼ~ f¬+ OyWˁL0qCŽ4}v^HR, 8dϢq؜oT v6^81A.L nӨ)\fwPxnE~k9)O<35`|afjGmط?wPل~H*j#yX($T.ZJc Pq08^:>;2!u]zm&X$4`}?t,_gw^˧FNJ_J_.f}CSjG5UQʜXc`>OJI9dڔJ wH0P`;/r{p%-"ht8#}"۞B+KJтci~B S-LTJK 6ō `m~NyRW퇅bLTBZyА*//QN~,,eɘ }_."L0-y*xvvgkߒ /f$Ah ݘ9C&I),v%l^öa<}h l^0J+/jgÂLeB+ߌ*@1Bg^g Ke.Hn2߹ㅁwXl6c0`N =oOΥ I[nT[M`Uahwr u1Wa~o]W&!e3HM͏Y h4/YNǙ:'"ϼs1N> stream xZ[۶~#5c1ĕDΌ6g`KBR9HuL$sDA vm9e [U*5ѻ-GdSVpLWg{s:X 'dR$'=R%ubh%/U1a%=̃W~9O9~dA,0lڦfUĤNhOȂƧٵ#z2Y#ݹQK.sc|w8mrϛDZkSFI xJគ/H*xsr`_VgEŋQao;}j7n\KŎgtHhH0fP%rWC;!^C.OBc.lzgUNoҘް Q pvOC8|VL)wsi9 p'e v@T4Lߘ|Amx:ĚVHzڕu® WϊA\Oxa'A(]IX2B7vטa; M$Ķ1ރ AQ[u֠!2zywz^:*/` |pg+E8w.܋9{!5'0NUxr60ٺSj(DAFt>M5;wXW@!㒒c\.7t@83jvh:ːz-Ǻ?e Ε'hFcp[ t٩štE.>yD#>F3;g`6{t@i * ۚ8fxaibNtE_f* nʄʴ2 F  ^8_Y|Tt@Sb[epK/T ,mg5*Xv"g5Y=Z8˴a.wO n@r}M8F'm0ͧ_]OWaG94AC=dpsGc4 5-#5f>1$ڍͮ+oܷx;"\҇;'tyu?{G<@ \g\7N3(pxnp ѳ|}Ɓj}>máqʓǮ NZ?%/~+c@=sK,/W΁|CX ":4E!%> stream xZKWVcbGycǥ) `H@Hߧ{xr咪_|Ih?hYR?=$߽c ͈ M'#WJYњӸl9iV/?.k f<vtzR{'[o.[aHNŰ}$|݀0Bj-Anra!r`3FM SK]ltVK}0꾴]<:)KQU5.U VgDimV qW+W[ j.][5 2jPFFs WW'R2Zc%m}g ŭ>t+jC8e#E|HϿ3saaysFRn+(7&wyǼE~HYq"jLbRE471i"e{zt!! |@vC1< HD/,(3Ѿ$!";aI"xM{M薜d"e=;3x.Q4CA6"\ihRP9m9tƾvq6JXhYY=dz "+j)EV;՞vz꾮0Ng"xgk tlHcwXՂiB6f!$ 32cr:5 ttjKc(J)Mq~ z㪡 sNȮ۲UsĚ^R*pɗetbHIPC f>-/iBOh)g)G`u": nc|ˠu['1&BUb\H5T|$^ vHS| ccU0o]Hߜ0jMi|xF)b4);З]ؽ"nI݀K ";AϠ,; ưw lnf3^9z7PSn%%G%\9NIn+7n@ݛqAgfXS}1gk~ddȋ_7RB=q}CnM'4?WLgsr#Gw<)Cp-mC+*M㶕.Feir^ZuL_žm:UߚRFr*$Ԃ1C(6Д@!o^#ky3h/NeNTRjYk ,a(!(g'S5(8Bd5i_?}!`9ْxhWCWNE qrSQO晄xVӀۨ%6!u2F3;ԙUtB!{3c7?L-~ˆv֩Q 3M ?CRUnoDG\^/E˩4CaH0g/گL4){H/v!.uGy$RnFܽk/ R-?QP S,eKZ:kv<բe6K _3ULKݘèғ;!5̸64%1Eo`IRwEk^4;*Q)5(䜥EMmUsőNJ=\+|V{ P*oL2s`.Ƨvг=@b0s0pwbuu9N`aY/ny4#*B t xzg16GIh@4 Э6!̤b'~7a <{61|f; #"Gy(>4:3یm, e-| !Po0zݲMQ"Ex²=E'bIYRj̙Υ2.^]l"Ym;1&LPMdLE71SW1&;Tz(ιU'2hN|q(g<.<=G}cg;GCZs!eN+= 0U Bo+;ȱ-L6w4~ > stream xYߏ6~B=T.*F)*- z о,Z[u'K$'" 9,e!@AdKǙo3菈F)(c/և7ѫw,)ӜF7ۈr lnq(U9U"~\I1X\4\S{8V5>%T3kQFWTiW%"' 832#*"iJXݶUC8?zp*a[D)ba_:rf% ,JFe%i\8%P9]HKI'u! |A/r ki#.JJI4#9lIA X[A1+SC% c$s`oV96f¢䙄ӴY4S<,fiރi9 NmWTLr+*MBb4s̃0_QwHXI*Z{'.Ԍԫ,ɎiM6\ܡu[rzˮk{b09Jwhn-6/n˝%"YTx=`lJy[D]!;T3d7ftzTzA`[zĠN(lX ͯE2e, IC[COVPz\P X =WmށeTbB1œg/} .\P:UGSd׮[xvé )c \ ;'V }Yo=`{&swRa'r%)wIsB"E-$)%Baj״]ؐｶ60Ip7_S)} Ø*Ե  &K6gUl Ax3M/ps05nbѯҭD3u,&ص;ƶm{)2ܽ.! PɄwgٙ@z@wجVnm矎..~x9#ۛ23 B.M֡0%V}~NV ,Z\u†# V,Exp15}Cq T̢zG4d"wŁv?,Y%[\KxW.s I1/> tL5\p<>C]ܘb(_YƤJFڟfm Y|{򍂈@!XGBcym;i3*- 鷡=.̗CrGZT.Y%CtJ8^fF!)Иվ](fu{., rӡBTzS}.]/zA%\E?o61M eRER}.ӌtgI[V>qKqX`64˼,m8':F58gd"<&”R4GA|ե3M-ċ2g (%ga=ںƔc<3x=MfOgxČDiK46þPv~~9'7*X_1d1Β~F%CG}+CM̠&v07Î􀊦: E*L'cy0L XW:6&why 7omg X~h[\E_: MIm=|Me/1.qC)>Z(7yn׿E endstream endobj 379 0 obj <> stream xY[o6~߯0TԭС+V$ۋ`d+4ACRRD.0$)<<<;t>") 8-hD0JqJ0rӘP:995"6o=|=IcqbQ/͘o½}QOfQ,'Tk++1:D!M()҄۽` n:[ ڭVa"1fplf*y7|x=/܋Xko@$bBDI/lL:YҨpj$fMVUi*2xҮ&ͤ8%E-c 7U<K0F֣B1̱us*%<,pLyϞP4 Iڌ`!34"is'J& xt1Ȕ"xjX |y]}:pd&H2كT|Vǽ$lz>)}oA-ds1$ؑ$4:, v3Z(zOGsJ]/еPŅ®MYTE;w!SMg`aA  ߧNsPa(űI^^ej7=[4ĩwZW3}0kv5L |з \KDt3.{]$ݷqs=XQWc[?4n87Uҩpqnw!_OuWǐgF߾}UllѣUaz\3<^M&1ENU/U1.=PO&uwF endstream endobj 382 0 obj <> stream xZَ}W \;S2qY'yq-Q $RCRnw0{k.J2 $({--~^lsOw|()h3 &H!~)< U\ !2aRf,ݱxV6ЏP7L-rc\ػNCaVtZɂ&"+yV0COwBdfs|ÉbrOqA5~P 󰶦܇&Q~prN1rTɦx'sD( \>,SC2ITU|l7욺yW{d۲Y:$m U$Y =YzoW%kVDjmKSuأ܈e_޹k;LO6.5 I-o' 4Qyy2Taʶ A+KŲMY33Hrå9pb@Q!VsO)<7MݻVN&wmҮ\o/ahH0-ŗzdi @P έiqk H8,a_;a (}qܐ܄VQQofi(dBb#>葷髟U1?ˮrƇG.Z5m@MGV@Vo ?s<vujՌClfvJ؃wC91(c&/3{o<V7­u90,Oe-́Tq3BK2ꌺ TCT#Sc*HݘW ST6;][2~+EFs1lTӧq9cg CK"0?V-y4G##l4I܂`2!xi5 `o"bySF9K?⡃ls(NglV\@UĶkIx79٪:;qGf8ct(tM0nͦrŲqA˛fgP61 myCkME>r=c^`O r$S <WR+'ZPQi {u)Fc\xX^JB 6vGvM1 O4Kq C0(mCĢ2{ƺew0=W!bî4Z׺lmO(OJ3!0j<'1f3ŠF; *|*4 1󁨁Ȱ-2z'*aɀ,uM=P(Pw]s/*$2 ۦ$1Nq a11vӀl^S +T a2vX ۿ|JZAla؂zw:k0&$ [,Wp"`(r]jSOV70߶gah '_lx~ޕبfdA;xށr(ʏkyTG+b/7 TϺd(wj 6R * Bͅ|Öұns`N.f3WV7l$&#3OΉu-.5d'zo8o^ mnt9Vɪ]?Ϟ-%2c=[@.9c;l؝$>$CZՆ^.eS.:nZ>9% s|-]N %F^]ԧJ87[G G$yA䚌+wҪzt4jox䁫ݧ S90 ;qHM܀ q%#ɥM9vkx]埱]S6 _ܗNA#UX~5Ue׺QFUxJ6'2Al_|Z].IV.)IcDMm]f>ѸXaxBxCVs(rVQ YmualF=:L(& O4Qg.H!d*5M56@f&xս M`^~C7X}zMa-FY2N Ѭᜃ10`fҌDo8h=:{xwCDcRȞ"豾Ѡ)"}h́= 'U^&r5:hj:?T5t%cR4'A* t~ġ#;}tӕ0 O7G(m j׶mB]^Xv?)PR *raaqV'=~ O2>knVfV=(}JR Sjbr^[ h'þTX7JF{Yjغ<؞P[d4hG endstream endobj 385 0 obj <> stream xڽX[o6~߯]&Q,eذbӉVYru?~<-9t h\F#QHqj=;Qf&by2obo(%m;_".5~y7mS۱/ξh հ5wRe么IΤӵWvWVf\uYA?XUX }ߚ]U~lsA2!#EZ qTs:9U_6E8u02Mӄ {&G˙|5%#YZR&̪7KJn<ʩ& Vnm6i~7Y(FQHbfͰ\QX6Tl> t+ ]P *jz >2ft^f^ȵȺBx *43rjVfg(*Pqi ^w`OLѺx֝+r=ygDJmWj7vҸ!#"t졬/?ViƧHHDqaߠ gHTŒbn0τ5ׂgq_֗vpr4c;K'9A[_xI5iCt6Qf ZLXFh6z^8YHMOr"!O!T0dS)rm m xqy~JHyȅ՛Ma ng>צ> - {40:8iጓ  9&~*CQi>7s :>5~|j>U\pD]_|Sc@1 h>fi~R$W/x1'+s5'i ~\ N%"Rcsczs<6H0fK@U*E=68&!%282P'| ˻d= |%j/DZyJE5COCF*"hgz@[ i^=/OIjrl@4.4^ZO ZFሸU|E*>6 ;g/LjKa/.Uh=4*ǏynތI-0H`i⎖l=3^c׃mX\"Z)=5敫#[ -21([9C:KmQ.і؀pm~mZO`?3[\u6΢:Ra3~y??t6)`%!Մ7^lNmNMT݁gbC_xQtRw&ٕ9MdY{@>y_0֝V<޴֎4zNf5 a?1 RP@ԏiƴhj"8QmH=0[)z>]+2m ^yqX]KkibP)X7M _(Fr"wof=AgkfRTjm뵃y7 gV2=` bʖo3Tk^xC{> stream xڵZK۸WrYjo{J6v%9d+\,8fDjIcWǧ@INmS&@ ~[U J3KW޳MItيrlR:Ӭ7]oɻk)p.Kj>ʃ+A%Q\ü8e4)̊n6"'ԝi߾OLWn|Xgb# Ah}ٴݛКZc`q%QJOϫQ`L+LgI"~vU{gZ{ fOU]WѺ^F}>$;^L%0CW4"T̀M~x1q H㿭vѝȼ;G1еSSV>Ә 阡 &MSNa7AGD׭ D~KrXO9\K#^`Dlb'v`x[)ŀ!HR-jay*aTT4kdQX( Hޯ3X`aOh!' [&Eao\k a ~;@nAq06O'+¸sVc:pp\ɲq*L2}"z%?h)հ9ւ<94{bcj< )| ZsPΩrf@E;]e ZJ3QYt&PQ\/Q=9~3 6[Xǭ ` Elzh@N?`c@zӢ@_J|3eC[SbL [OQCYYBvQy/g˳~š13;d(2ݗ+A*u>Z"y:x|js? KS(I( *FH¶hEw-4i|g-*/Ktp*7'G)s$)F10?&9`쀂2_6ΏH>~8!SZ2{(]tu)f}+clo ,xJ4?DnіЧ#10ǸWy`<.g yK\yQ X0[1643q?Ё"Zw;BXU鴲`[|NMQS0sn CE."آE|L)Mx]4\D޾llgOR+J^disou:^Ù/fw:TqBT3\$x,E&1nbAJ$4CK=RGn<.1IwVաn+K.J4t=½95fDs~*S Q|[M7gG%gQjZkUAVQ-yrA^ 91[<_P;R@z?l-)e2H1pK6p#,y232̴?vv{(ۮhP _ϕNǤk?W,+!QYG>zh˽\@nmػPH h1ns֕e֕Bs'n󢹤Vt'LK%C3R"A^3 ;Bn=7z{7@&'4-'i۝_-W?q}p7 .Iǫr ʥ)H1$$jԌS8&8{`] ^|pzO4]p-63w kȦj$_tۆVq ʢ8goSl0cs]ZӢn/G_ FlIkSvQAH,Н_St> stream xW[o6~߯oO8k,AWw{%&$'ߡHɦ2tl@9C糃~ =')Sq"/tE,t#LB  UcR:T7~odQR*W$%Bcvtwk> ",B!f^Q-J2儏fߛl<;Lj*ꍍԴٸ>sA*; [w]dǜ = 8Wf]z#>f7c8#qR]d^ti9+B+Mѐ%vy>L7\ʳ}ݗ{H4Y _+חWD4>^UYi Jt[Se1 E!>ۭ Ydphk.tTttT:Hҕ3%sv~?Oq搱mpԈfo N  }waxr:bݍ܉I*ǪUV|v#8P)|*?Lye 'գN8#7 endstream endobj 394 0 obj <> stream xڽXI6W!r1ŷHZ4=9cZI=nmDoGE#Q/.*zE4%eZ&ED9)E]m?ĿU9z!7w+)=Ts3U5~}Ӛ7~$9(諷tӄP%$z&VwUl!zPaV,u;TdSfSJQ6P#QNT.v~lhf  J m̉Y0Nhsna˲SS0wv"(0 VmR*z II3j6!a9)N<[ ⾺U!%#9g5_KSf/C kuNH/%Oe &``HH?YM>I$)cжÊ}$@ &F;njC=|P}Ƽhk0FO1S8Tm klcrSudIRhDKBS?dA ȤUeX(b.xU!˒"XRHQMӂd~ěkoXmj6n!A8 ;GqU=$)hTJ2ql?($؈7Y|i~I`ekx7 *C raWNڭ~l9\N4[h ȔIQNMQ(+3tbY]BJ3e.wϚt;` 󇬒Dk(̓jm:}?̦`ÓN0 ȒdZU6ꀠׁyqo%, \U7xrrZ1vVi9$B ujnw:ӿtIc{+xiUL}Hdӝ 13Fw3^fvF ZB]A`)2 nj-NA~X`:8k0dKݳ,Fc.y @cf}4/<',?UXWHƙTecذrG;gEH϶@Ë[eF~{5}t>ĐE\LGpT-nhp9'J'`pIh֕f  Q-gVEXna46q0 R4&I*űIiۃ Jp 2cK}]-i8,j2P -wu3-HRN!^Ys,ܬ90:̱pQ@˜>V XrI_;8*284@Gt$bfy`x<όѸβ)H`X<?DOgLmk`7\_T(EEh,W=, }kR> stream xڽZKܸW)P\%O>b(QKmI=THC͌7H`c$X"&o͟nIng%/FXûLb_7RI ?vʪ@5Ǿö֌'dǺ<ܨ$p2sԻ0NͥXvgھ:XpYFu N#zT-v#z~gSN*妙ƥdF~8ꓖȔ&r? Fߵ_v']3ăIEyM,toޯ`Nxg t8e5R9}?hV?)d^J $sڞ\~US흳PqGRbTq',3y` bFp78Z4rRiV@t.e:,> lW K-yXtY2[NCs/ ɳy@-932ds;5-v菏wSn |W$: KBQn"~p>8z^9F3=4dgٱkFT.pq8m7Ơg`o :j7- >D?p#NC & @p&q6>~]h ir兇f;#l=u O^O-A3-~{.tM[7I"";Hru IybŰ 9+Hre ,Ӄ6w>`؁.sԹ:D3ľFpfiSDvTu8 |!XFeoS, VʠiE&XZAÝ\/K+Ax]Ss#lrQ۠<묹,zOm q6X-LO EiHC)JW4D;q[1t19V- rCJrQ a>Tt4@wX܉xFp6]M{oWO| `d.K鳀8O*yRK<o_gZ,/( K,^bzIVy"(rTѝY-sӗB.4\w(cJz&$bfk3qhzE) ~1g6c:(H:C$ʩ%4Cj: ,ijLp+W M"mc<_,~tj"Y<{%ZЩDPNr^zObG0]kۖm=SK" GB'3*:ǦAI<ۖaw@ PѶ0I J99-k\lwJ'r}_aV VB/mb[?-'a|*e(#."xGW@ߘM%+yPaBD(x`z?Q.7\憬AwcrqOՀpkG[6.ܞ_@W3ʺ L="7>!$]P09<8^(`]A7኎ _C˹!r,6qYQ:f Y?U E~yK ]lʸ,uGFܚ\Ӂ.Lq 6_.GW*-8Z(TVbH@f:Y b0Pb-n)#$_"$Ҫx~LGB"_b$+V.cr*nNMv$m x \-bC;ڣ#οG=ț}3,n̕ة|0y ՚&]^eGu7OyI ^n}lʙf~ΐ /w [JeGփ- C l Ȑ/H<]XT^b?(ZkVɖ qlqJr~-_웂ԧÃa29fܢB [db=CM8hĊvDBw=m-ᚘDCg:l! L0ck_z<:q޼ aҝӥ4I8wIY;1K_+E65SעZk Jq{D Q '^)J"tY(gsƱ"o H^wHUjYLa(kI@ZPlD%EAG-T񦤀W OmIH'botE,]._bcejB;cn;-( $W,7/fBfV+!F +6ř4iY?w5tȒsP-X5۟CQn@mK l~B*I~jn/#Uac!6փgG/߾:-.QW<~җԚ!h֟3+=;'ɯ(3Dxi8)QO5 1 ;$nh ~HH +[ىq+\ ynj!%~V>.4I`5㐦t!'%Y'HTs ?.EqRDWݿ3j RڐԠɃ`4 zEPB1c61hrRؿ?\=wpWM<L|vhwam(xs ^| S3uX,>y&x4}7z jU=؎poCCk/ >VwuPn>BͧJOY5vf?w endstream endobj 400 0 obj <> stream xYYs6~4/"+~rR{ƝGL'$A Iq}EQ崎g~ `LJ?D}g;/γ `%~)JXݗKjD5(.}>cf0gkޤe!s=eL4a8@!`])D>E=(QKP{zz:RF.L/).߼"ɳ~[v%uUNynZn:ӓZŮz{7|}yy'%5}2(v4~X8Kδ=UQzG=iQ!&!YpWc *EBc+vZ͑'gX`"u4RDP%n] s?a欋ƣ{`08H=L OJ'H$ ݕ@jAv6ȞI 9"lѣA|Xm7Puw9t'bJQB*UlFU#,ժtkU2dQfy,aFn U.XHK=ۣ!T> stream xYKs6WhC%d{rS5dRD9m3Hz?H2[INކ)IT6池:z{;7 'Zks5ޗ2f~eBE~UBKUBWp >R6M^EF7 |]X)10Syu[d^>À]oۼ?[nJ ' (zkOӣ \ *h]t}[/nb^w&aƄ'G筋ͶĤ8=. 1d2c>&AA:~7[(Ft-̊f Iޟl2XGngƔʔyP7&DZh"8Y͹U#g) _rqa!< o?Fx``&f(.e ng;I^{'&>갉#C&9c DO"L|fퟌs&K(|Zў;E_t 1QlNiZT4+_^7͗0S~Xj۽=,C?Bb&̼8Y]gˁIWx֧"c:p4iA{[ }-.7 &_}3;-ک}p!eQ*oC@Ax8oC4-j1x} "o)qAX3 t:Yps%Jf%"~-g6 >h*+l j.bBnʺB#OID?a#2{/k{>j,닿@nz d.̐T 3'HwZ6dd;ە./`#r5![4ar_ O`3谠J PKvbX O`14/ T<$AEpj?m\b:\Kk&2g' WhRDCwvo c=jJou(F > ]?lw;Џ<#5AQ1: D?5sbGѴBH"TA!t2 6\C+F'D,ق3A/FFdѮ36m]"|۶@Fh ok767mpdZs ͮZ[qr renI)gH,+|4Hh9i4r,W6>ڐT=idSa3(xv-bN(xwHء2̸OoY+;mW IBSBۃ{{}R\Dmb}q fbs^ endstream endobj 406 0 obj <> stream xYIoFWTPE83M-Rы-lT ?oR<6]"F,޼{w I0#IN'mUMFk\*Z]/41E9O__]ѕueѴVE}(7Տ 'Iýaĝ>E5nf=U5R;ZRLH.SdbzW-չH/KӶusX>8H9QL bbk\T#!H ~܊M 2P},Ijk.1d 5OeoQ)9\&@vD،1*IhN<ߴ5;m3!+$9_ȂB#U9+az02$)D4u_lvpςk-x<f6L{q ?n\Q^@BBD1, a?Q:Xgeسe=#|.Q&C?,P")D5IԶxNq5a6t^~\p|w/ t>^(/w;k֟MxV-&AO(@XQP#-WW @X}c"y@ zm_.{]?s4bfN,q.%✚Am0&0Fxc妭yG3$n|\phIڇu+R`:}(L~̂hϢrHL%_ kVlo2xp,` /6j0i?`'cgb+.5V¦*Mv:fiP3slK7˝(9ȃN1&f>>8zWʎ!]sDSw]7($4 NXdO!XxB#OHOSb>zؓ6ʘU eFUwM`ȃ\dv׍Y?q7`:k4fA9u4LmVe?gz,L? _J 6~oNTk/=ֺpk֪EU[a?xm4 Jut*Ls}<8iD_YqCU嘂$al"ScK!˸cG-ڮl\*"74 S*g64z7a: 79AOH.|}j #aYL)LR蘎8,Wɯ_؇ endstream endobj 409 0 obj <> stream xڽXnF}W(Px 7q  *DD(R!D(Rm4)Kq8s١/b8/ߦ$1g(gY0]bJ&O%(M)-=DP ^l˦k)U3Hˢ48tdD,Gf*3c)JXL cF"NY vO7UbtQw;TN^yxh2oy7 izu褿~fݭDUNpAy08f*,\y;qu=K'iSpLM$ihme]w6 +p!zd%Z,h y91,%F!:閄孼R`J)WF3 $a\ql8zU֟QB9ťhLe(ͬjy'kQΘpp8Kd#(E)c` ?03pfm{d$FOĈsc֌\M}2uQ4obhoN-ɲ|x(FI3QİE׷k@] ɫB*%˭DT6JTVneօu78.M j\Yi~LubI32P3G5jF#iB@^xP t\(^%I2D}⋜cDAT"F*@&=p2 J|CSc4 .녯%e+Fn#0᨜MJĮL9w:= wo94ၫ=},T?Yp)vQ֢z#X(:H9”v7GZ J(#|(aBsjżEg#$+1\[lV,3;j,B47j VƐ`dTmñ]y 4fpݴTw}S'z1JH͍=eH[-Z=+gfîMlcY Tc? -|UUt/^ACRxz2@/k5pF`z2S"qJgy`İ2AhE^A)g0pehTȃtsoԽ1lF蛃W|v ,^ m+ YjUQc_6гo'̛s|uǁGA[/z)ڕ5'#ǦO9HND Ӏtԧv؉mwpkv(ph062CSu5*[h0O]4hFy8Rg65_ _/ +?F/H 6azQRCq‹閭Wyc̛)mג=$A4&3ȢzQϋhtMT@bskm{ÁfF:jь+g%Z%Wѻח˷WoNta2\lɌwIn:$e$~ב:0N3vl<`pT> stream xWn6}W([)flit ,oUUd:[$%kח/.iLS3s 3# w V O1*ZmL۶ {1 !!F>GMR3lD Y_ p;{ȶ;[5kC$eC7qBݯe XLdžld;HgB ?DiZ|1VߴG6 _378ې6Aǔ6>dfVə\6Xh{9R/,,Í$좥Q A%QfpkN2; 1 q&J`jU> dX:QTp\uM)tG(vXwy6%fE:#{ҝkHi ? K,IX}Շ"\y]_8Q {_ŇCՃ(Nq$OGڝJLE\.Xjd|%R^eF{Zq{\N/l!kޮ3’ 邽1Y}TիsφZpJ?IHvCɈ??F\z؛Aks9s\ Zx¯ײ,> stream xX[o6~߯EK ȭ4ioAD,CT]E0/{3^( f=Pco8 㓳/eEjwx: c~Z,z[.e?+'z) M^޲:Yݤ\NAuK"5ϭ;8T-R{,勁CD<íOhQKӰ WbBV@D⬪hSb]_BoO?Oy<gݩPn{:C=iF5M-ҝ{ Gm?FZd'n{{nbv*ِ[zJ=:ΦG9~hMW> 00 cW_:}z|F⁖_mCo< v'DkYze,fKDeم̎`VAY n(!U(E! Q9sDe 5A"{\q=P[X.\r(EA+sdP9XSLx!.jFU ղl5WiϵN].Kd s/NrK{8X +C(hVi1&F]*B OZ'*[Hz" r1V&;}ƨ`R~aO쐫shk%{,L Gc愷J e…JLTH7wEl|NC2@~Rw0Ŵ y2hFZo@Yee"̙IYQu;7PܫCo4"wr:9DqAxC$ }C浼:T#C=֕Fm*=+i*FYwՅwE+gjzxfb  eicؤ5pe3 qA"Wb5i+7(K$,\$9)Ӝ<76d&F܍ :񛬹=+RO14A47Bz =)_gUY,M?7D%+ endstream endobj 418 0 obj <> stream xڝZrܸ}WLÚJ4X 8O/USUKq(1g%9O7. #.jH$ݧO7c6M?ݔ߯6?Fmn6l Vmq7TV[)e˅Yќngq'iwuvdhú=&JJ.,1LW{{5 BJv(Bihݜj3yN6n݃&Վ2y>$p}qHZ9 Tu:~A<!=9R WН9S0dmP{I[N1`ʢiJO XUwűw`` \g(><ILgE5"iH5r$!re!V0\l5\zz% #BrS3jWqqC m9nw=n_p1c1 a!U53{F4d=?tRmʹ%Fy/rƙ/ IKǪ< =Evs:SE~#pg;h*3&ʨTܫȈj}g9-b%!K9х؅J@r9k7)-abi'2:`Rk琁!SDEw.昅fviɈfNw9% \yp}kAcٴ}DD.Υ ;E_[X S_O-sGo9N|`q 7,U)=1 BM/e{M80+ryBħ/ڣkNY/VcnSș *5 !NR5bGG6>̃>+z@goޤwŧ*%Hܞ7=!T XF0O[<5Y1 EƾEHc>d(SW "FT>DrGas @ރC QN,>S@\zŖ:G`EꗨljZ諲x 8 LX4dBm^)&WLQJGa u(|nXe#=-Z.@Yd0`,u9Z2z6ӂ.ϟj"B}!O2Pc1TX9p esڣɃ6!!35X tx4i:1 O.6^wܟ"Ĺ6+BtVhI_±ڎ H "A BV!q<s6\tUjnN#H0#ss[""J 6Q Wtr1灲pҵ \<54s|%WcJ:STX/0eUEdR56"BSs{ W*5#_80YяT3v{2x,- ӆ6mT_*QzvQ Ɛs! Gw/nj\XE-Y)sQ LmUP^b3. L_n&)ǚuܴl}\LI\1<{w+D)p2;9ʡt wձ?9%uؔrC!8&" eٗ9rdMf\mb+}WjG9VE܍/a,oWTl{ C}|aO Q.|RMlYbL:3q^g/Y#CFMEs|ˁ"IE=PTW2 HD K4&+T_\#yƋ>j޵~ֆj2q]~]0p-FC%\yaIZViEך_LzTzy-<36PoPP]T\(ī"/>#\\VF3ʗqˡc_GޡȘy(+0 >>H/v2R.Aˇs[{wW?FQTIxPf7ِCߛ_X5ɜJ kRw1,vZ?/b.830i)9ģoU.~})UĉsX#o[x`Q:( #/Eg n t&_Z,bUܡ# r%^L SFHWu%NIv)ћDogvD_E`gU-Ty6;2T$Q!~AY "ϪY7䲡i*3P:)S ?of\6gDYyWw!xuew0zF-0:lF-e3OF%jl| V; SƞG^cIɳ<^cٙ*I9U8%w>,z[[qUt!tK<O'،+čtǛRf hxm9#YgB2y[a<颻= `> e" /X6T2FB"_uԧk JM}:1 t36Ǿ> prYҽYJ xkP+X:NRd(p@;fy6ksc:t-2d>[:";#_@v j\5C0'|,6KIoHI%aGLa~V endstream endobj 421 0 obj <> stream xXmo_OgDާMorRVPYrrHYr$wH(3ό;:;9#SgqhPua]DfA&E'agܼQۤEv+qbS;}F`!GkjdpkPṏyn/r-x>leKx|PxS˦@[V-^<[͔al\+љ>p&ďyh뤔U`Ny nUL9-fNԌr /`E޴(@ݦB 090[sBR*ݴk-Jd9*al(  o ܑn&7$ἀq̀›jUv~ĵYt5[͞>pTb^yxSbRyCj*1t٢RBI_[7rWX .&R%ǣL<\y glؤ((@RI0k4) .U8"u5oq_UD'\8dLkmC>GPP !z:\UMd JB B*~+DmvSdmOᓘ\p V' hzQ-4o0)kXSeA"cODLǎIZb<}6ֳjp?fO1(qGS V19*#UiS=`r_LLsr2$Ā9&Bp1L*y2Uy{OZ (<HUiwA툧*_ϧ%1BLVe0H$fܴMNT6\a򩙬5t=͛S` G\_'G TAUZM žZʱF(7]Q'j阭jX uS`ʜrJG "[MZKcDaEV@Lu OMzTw6N\DRwySۚoe71[]3$>Eb)U]qZm컺vڦn5 @ s SՠRA%TĮCo%v&@E:7TLXlSlg^P/"7<$}!qP-{ ߡh*H_Dxy)9%_@y< Jzۧ =ϔ ɋ0Iَ&1oU!o^9(6+L!a꼁7Ñ6q;~ٸ0PN_^~a}8,^a)GYUM,$G/9n=Օ;7Kf|[JOȜ{W/>L?;|EEn>~D6 8ԗM P ped~D4m10vмϴَM9~ K' aϚj1Ip|9du!S!V~E[χLY ;gKyT= 0 2~IQ 8d}xl}Aט\W܎ʽC^W%t焉8 2JjyOW5 t ,{8P贝EPS s?"`!$_?O*zAh{`VoF~"C`^PFb`rXr/?Bik3kzg4V# <.rw=mVwM|XڕvbreE;C =xԔ]ĎWd2AB![ڟԪ3*/dkvՃDTz- endstream endobj 424 0 obj <> stream xYYoF~SB{~s|)€eJJR w E+R;Hno@e p`Rח<[5EҐ"XxiY-YF¬DGr/엫_9T¾Ҭ9M#*R$"3C;ٴ*EpxYep;ǿ4 _ògv1΃^%I_fg~Eo7b!Fba7o =ykHyvǿ٥N 'EO 'pr$tf'nx4qxtx6x@kx'Mg-C LPE 1)%Yx˃cPHm "qY}ܘ@61(#lyESL^no̴6;ey}^Ne1hX, I*}IZOu7$/5仭I9b}͚M>3'לשO&֖NKUS_wYsٕũ߮4O&V8jXVݮ2 ǻc32#ؐm~KWH1RtxG$f5t$FX*8$rh.."naPSݵdOZzԨw+CAE K) M uef`$Scٍ39a;h!$`'v*nfrfӱ-JXFھtCѱ.ʐQJ$9̇*9 ODpX5Zt꺬|o ᶜwɈ\H0nrYf So'Wk^m|DxF>V9t(mjᶞCjg>J:>zz<ѺPZB}$1 Є aSЦޟ.nXC+cKF⇙\rB>FHc%K6OrkSi{HC8W㞦(amr-Hi[9ʋzwb{ > stream xڽYێF}߯ӆ F'gc/$vO85D*$5T_ljfo(vT)-I8 ˒>6IpTprIL0Ev>T.>~JPSx[}ŒR^~WY,LW}Y/HFWhzB$K̨n䥜!,q$eBؗ1 AEDr'Œk3xHEk r՗<~uL_r0+V}jXiHz=G`}`]nԘ(FdK򁋈$9+L N#,C'_~^mt{WBɼo%QPv,U;E:"j8|_GevqԐQvW]Tf("R7v1QT"̆bjg;~h6 q.ݫ&bCq9ph19A8g͈D*TʻQ~_1m47"i 1h>8eLĈCad71I}@۱놤za!gwxɼ58%< :4}9bѹBX,3} ~S0b\_9b|Z~(b8%8 "GطdcH5~Nrݪ!e]釢M2`*X FȓNIUi3a\҉l`X:Hږӽ0Ǯ_.Y6\DAoI]i:m{UwO]w wj)&.Ą+H]h v\sMTIOAָU^iϮ/χL\Mh+m8g"QYо~[u9(Řea> hoוQ'6sh4Jm`Ψ@ݣ-krїaiXCUy4|o!uN9XL$܇|cgN(O:YOw=p`( *4.1sD贍VN*3{Fh'!>\kNn/Bԝ!ȱ"-LNV`]S빽/w!> r*S,cR-8J2$;x`Y䩏s S譓t#uF [eik#8k>JhR;BN ߖݪL_33xΕN}_ЏcVmh0"Yq*{PoHo2ԎSƍLa2#I_of&b\S?dĜpOct)Fp@;dfhF|6ݩOMLjBְ]Ҷu>}0Ss :>Gfh[Ƕ<=4^M5f)A$[h|qOP<Pbkujߗz4puzfa< )!x$umFΑ%BgPEeY-|8͡ycbJ$jPF +|qZ3'W.")쫂E`3]:XP I֍5s\/|(e<(oW9turRەھ^Oriu6v0xD0m_]% p endstream endobj 430 0 obj <> stream xXYF~ϯ)FU˘~9ٔvl=*JUV$H( 0:-v_w89;LΫ qB?p,p?hUyϣEcM37JQdKFh95^gU; s$J#R(L/XI#;4V v>oxZ)Xg"*m7g3qlXA[]*Yf1~XEb'a qN3ȧfʍ@ل#˚,_t%1Fk DKǃcM , BO %49@My\el4˳Dq2 3gf`-WKGsHP> k+@4 /,ɅM.]E4{Y'(WafK-0ڒJF&lf|RS>pKY<#)@ &1ePfMwCp`RQF4)*L`KL A*:a N 1lc-rNk fi\vd, n)J"p;$:`Cm3<6Od({;S ͖cgiL1ǘ MĆbZNP򪞊*lT@ä˰(Z&/`ntzF>NS-۵zǖaE5ti$M flM CZRYcwk`70ED]9VH 9,=gq\z˰ 1ApAvmA՝᷾,h0m΢Nim3 5-V#6yG:F>RbKTif`ڀ1bX2z⍓A *㩷 EŢ%GOc)x*M:8QQKcקDU S^ͯdM7?Y6Ai-@)lgzI>0.FcdJ7_z742߾r48]qyQ0Ϙk<8QX:3n\eû_ww'NS8M^;/ ; P_/}aNj׳eVzyn{?]EiǓVH>\N:Vm9q30I}xپ BH:Un^\0$$PhCm3IG,꒍U,zo-+wJ}.@U& <%]DG}wRw> @@OPƫa",xHTɷx ZIRg 1zlb\vmmTfI^~hK/~A7? )5z UP}OrL endstream endobj 433 0 obj <> stream xYnF}Wdjnw2y['m--,%""H%6ЏW^JN\ Ô9gfVx@K28 "NPd88 0EKUY]_JVwGD14WS͏rY{);s*IN6b6W?uSdFe(L5Md]-&9p{Yq^<ƈqf)V;8',>=pH2d">& *6:äcL"b,_ԅaz1`|q7ܛ.lǨ!f iXo?qF2=YoISeKgD."L^޾'3vp1$Tsnll3l'#"I"-mDXJ8@41|i&8ϗw6T3sPn*ZkH;X\䋦->}#;\= ^8=X; @Y(n؁rSؑt?MrE8ܷ-ʶN I̅859z쀇|/[egG*`&Vv`U&0ҊT ZL'P%dËa֟%QY1OFَtjcFQ2'>[ !쀺hf>+$A`iY6ISBe( ‰8S![!$IFj R+飈ɨhEa-)<30-5榳='q $0v "&մb+*1km_z=º1#h>b.-|v.>@Ӟy# _;b)k[tnPH!1n+_bG$>[y\[/Iɀpn}`ɗZ`0ϝjH_9|e,Ď:K-K%Q*[ͼ:{q(- oJ PNpƿ<'MʰSߜWMQwIXͼX S_zgY@ڵ*Q(p2:`3^RI;d2 s}``>E9)y;Me ciϳjAp[Y^>Y^3k.BpI' fp &DԶJUQuѩ-;As.N[y*Y*. 70 /6s3{<;-۹9dYFB~f>Ӱ\ZΣ]"Ul!/Y#cc(V򮏚@S= 'ˀƵP endstream endobj 436 0 obj <> stream xڽZKsF-+`3ޓom^kU`-Pv DU0_7<8љfϖ7ް͉-ݬg('VCæ8te3_p3zBds)b{,j_3Oa;T[䏛Dq zTPw7aWtg-% 7_eluxk$j>[P q7f?g:{Ved圩lSUOvWlx*攗ˮnSƌ$4+\lHs mLlÉz zU-\Ն#ëmMm)y܅ x.g F =z;@yV]qڍnxTRA!w{}pЄYSp(4K@cԿYr巼ã~Lm̗`\g7AK+01Njeh+Lp3Yt^\>ΈPV>TMISig0pk;{?-A pOrADcUJwRq*'J3y( \\9*rZk!#LӰ6*:iJ8!P Diy:2 C^Ҹѕ@tfwKIF}l")mʨ9,De&y*Q# M=;-&hUyk}xC-&7`ص`<I(ts:J0Y, tpuJ'R')Q4k.\v;w}l\IZ2jUW갩p)HFږ%Ylæ>O&Ev6(QV]E eB+?Η6>~l}nOdAbH+ìG3&|-?QVGj£cOSjvӂk`N>hέF!TA O J&/ab`q=ǽ454'2yA} R e8$DJ?T)i3A5+'ki! bDkwĉXFv=Ђa` GTUv<=< Oxdp 9pϸ39\&u=Al`~zNlt{ijr1t\=}$Bj : hx'V hr%tmR ,ڕp .1r3Ks 81;Q$bb8L%Jke+ꔄ`U:.2.rcI9ƭqĊ<:*zv cN}V:]L*)ԜBuyt 8+ `9Q=t$RIjZ@IqT@UC$ژT+Sg[K i(\%Q(8֥%QNk2*HʼnP|sI~Hia- EAƖpJۡ"SkA6/І?oo "eV91Ld 6+l[Sl".ݮYǤ/u&X\ O{u㻟߾oA쪆0:8h`]5Qܤ`&:aid4o='+% K@xؗ ˂܌8s(+\5+?|tǐd >.d;Fe?7|yFnEb1`VM^&{ۭ)͕駫Gl.&!_;tnGfsp|"uqirʂ8T(T#y/i((GcM0'G\|sCE8?Q܌!<` 2w*YI?>RnY8a <\K}ߟrq[uD2{&zC.lYi c1gC'ٓBŞqܪe8ߤ/G-ɆOb˧ siM[Y).ca,hնoN^>>L9Qjq(b5OR ?F?}-FHB,9u.8M.P b endstream endobj 439 0 obj <> stream xڽZKW*zodAAHLRY`|ifA`jͮW_57]_nV߽+2:_l%s*[l?%\盿Z o?z#L'>#U=FdIq>ǵIW=Ga)Fћ^F9qeI1mDrX45ӤoykOQOʢtNwu9ȔcuՆ[f@x]zab1t0mńa}l ͔~^Z7eMʧZ`CǶA~>w ښe 2%jXdM-n|cʺkR9aoĥc@ +b&~5,nl k1E5Py ֵo*$k?i 5!cyLJ,833,5d|ntSqn!SCFƷcԕrF̷ۖ\/-†y`rF"p;k0<ƵJ@j&@QǨ p:i_UG@=A!? ٬B8rկk]]oGQѵTMٝc*_p,!6(DV60ϬtLPES0<,P/bnj0ɵZ Й}jj|ږF%9'X,M,:>Ѝ ,c {0`'_Q*j"@US=ʒXhIsZfshSXʧ@-*L]~ڝh`y> )'ZKy9ER&8g# XR`Q c~eLNL)'LAcc9b 7]G4r*y8MN4=SeӅ/+0^L`wC5Ba@ #~Щ!&dtn#$k_wE8則IzGWͥ\pRB_ȖZakT0nHpHnoLhF v{({rh>6.h$OyU**ߪVtB}+6ғ]Јcd(P*#ݴtEyAN %#LK1Q0B ].ŁTFv,xgKńM6}ٔ7^ZI_Gm-X yKBrZVS(kc 7G-W}P@D7Bm X*5Ҭ;j^!3PIIhz4x4&( #d>(c=P4^"Guj,mUc:ϰ=` ZEb=|~8--m>יH}~cf .zAwM-5sJRf<7@g&ϓJK~M[M;+ Kex.@'h畿?< )yj\ه) A"xcy<-=EG|[|_?^M:? oz:ftGc4a;} M EƊΖQͬŷ_7:ʿ0o5ϳ랆&*A k>1 N38xCSx3BbCSj [qCǶh'綗s8:4/t؅Ku}3GI/vB3q]r`'3]xY7mM$,v35 :޸ln7D$@*ܘ({1>pYC0i(nj퓫-/Q.,&yƯFf@~!GH)5JPCbn UQay ެfS]ð,Rm%i<>ςvoA./u8 YhƔokvfci$|%QA-Dl;'`onIZN;36Ӓ!ҁb :ގ-lu9 DAY@Pbp"2RT%j ڴ)/E\y ^5pWG!څ_si\.֊eN|[yT#H-Hlwg g 4e$K A@ @>mnh2p?i@&vUw|tʞSƷmōwB}/?)y"9K*u9h4 gJH?UGwqK" Cu^0aZ ֭Ͻ |+ T> stream xYmo_aט+J?]ź/z*6g[>Imo _!lk,3yfjr>[f[޼g32/lQ=BϖO]uM;_p3~=_!ws)j9;UǍ9{yǙ(^\\ n} ]pQ QMfǪR[(>vxmfL`SpU~qm7/x+ode5?V؏ʰؾ؎AYHIcNѮV'#(@RR)SڜKWc;v~ 0rЯ9oa+xYpCݹjc/}㮷 N2kRQ\Ҭኰ\ݺN6fSq4_R.KݾR]$n&ǕOEL6m1*'Ra' >R NmsVѭ`D`kή q9t/TPuZk!/OY~_GԄNu] 4tB}BB="hms4fD8Qv15DNnέ3W 5h9 uR9$S% 5%\pIIWq_G,/,rX"-L 1:޶A$,ޛ'Kl@kEL'q|$͌'͆bٷ>Wssb瞚E/%4zle6$` ^ .ER<>y녫\ρ6Mlg]J~UH RP\`Up{ZO Pm6?l[Ƕ!Mq c* ,ͺȡ:':ߛnp5i쯖DuwfkWMv[I#7"Kv8/,4@!hI< "CS , KH_noXS@}*/<ٟ;9؞ţ#S4Hg*Mr>>7aPQ{p37SX<׉"O,_c`Us6ZҰñ&pT7cBO#l_` fɪ*q"R^J_rxN]Ep5lGSVK9)I+X P4D)49˄4 {r]zS)ϻD_BȄ1cu#20:w`OX)\ƅ}So݋$IC + 0ʼnVkmby͹G6qLi ,͈6#Dl\prx %:=2 ";QF{Adx10%A+s@zk#* u6Z&|HqC '?׮Y t_&%ls_;nnSs`scYCyWvl.$ٛ7o͕s5 b ੋ7ގ80݂7^ 9㲯ASqNgr_49A endstream endobj 445 0 obj <> stream xYYs~ϯ`U0T)vM6/ $'!.iO!mW6I%\>\ "/wBpL,n .bNzyT%?.WJ(6t䛺, ugr%hݗEI9ߩ+LjX錥BC-Wpz*uS?aվ ѯ‹ݒBZAK*ADv˕:n'ZJl7^ƙq1q %˄!Ӗ!/HɌ0b~_prE%SQi>h]~s|伮fDXIT־/ [C[y])/AIC0߽6*6!i0n_kC„`6\pRre8:"$_a_V}rhZ0)_ڴ! FNB8ŧL/fWp'V*N]J+֜ _=vEU*N/j%,M~x(?ygީ):0X">+,7uWcA +2Q_)H PVkUoѺ$Zc[mQ{ppi[rMǿk]wz\B6  if$2J5N%ROt8uSv3CfAYÚz$݅deL' Ԅ߼ٍ<ӻ>op%\OAn:KnGosA7sQ"=9\@s;Aa*o#Q Ga-bP [M*Z#p* ۢHo0XϜr9Q&2EPރB K>$ Uݑn]8MɶM_щuG7ڼ gsLpǣ 0QZZ+Hdѻe*]A]G?Og-)򶮮z쏾,o , nR pQSnPJ 0{w;.#˼E~ݎG&֮Trlʒ u_1W1=8E-!}6'8+: [|a*Ӑֽwی(Oj@jT4w5u{2f/OQM]p\BOb)1'bևܖ@BqdDۡc¬(~պFG,b| 4T-N2ZjPlDh=IN!xzhȠnّ&t&HN2 V@4 -X2* z[EgK`$1rCpԞ,0ISqh#\|\yҮe&l?*T.}i#yhVq>" @dҒ fjwv7_Rzf'{ہ%wY>Pm%LVH~mp'񀸰o 3)'XLX ?$m.c0CPJD54Z쀏ܔ1Q[f|A CDj=8jM:GzSTaQ4&^!Kd}$~I\9 P;5tQ?@E/`0CC? B@7a2%EfatC a"|6U!+Vm?VbG3\?6PVhWTp_.ֻ⯿7T;o endstream endobj 448 0 obj <> stream xڵXn6}W-Zb$^$y@4A/qZW.[IE?C)K6A,%f33g$A et>A<Γb$2Hɹ .֟÷b7~1Bv8JXu~Fâ]ۮU5>rKAR]/}}F#$iȄpwe]T*T^NlM˕Ql F$!\ )a15߼*x-q[ t5o܏j}D;۶h/~?szF/ŭVvXT}`}b$ MZAz9]UQ׷hQ^]GcWM{}.2# hlQ')ZRH)H(ݝxza%DQeBXB"42'bO;99m<%qXʧLFl[5_ LpW\+L9!{98e:r|q9<%>}r }#>YUy* yF$  _(=??s@!ݨ 0Oq<6_WRIhBk% I" j.|9A(+HuN4wTm`иS8]$l*9՗2 +;Rx̧DtQ9Q[z72T$aۍhARE/n8fg{UvmKy8PYaQ12,08#b gOaIt[SHo/B5:hCJM RM#V] {^lת'\@oV4 UT,|nkMnIFz)B/| :B" 2DXDCJ$}LH uCޛGcU[IFYuFLՀ_x$Ҕz|\Ym[.HM6u6=x1V] b~(n&fVCknkA2b=Uh}*/n,XM15^AAmW]Y4ZyQT/)琉exbG$RB'K$D3syׯoBudoK;A);h{4ai6'\ˢub7iVeB5QqKRP=HrS:%Ͽ߱sy$Т|x9.db:Q= 'r"z# XJ×ǿf0BJצFtg]+h;zsd*``z:V, M)θ%?V9Jr!tۘi|8Sbm+~-7[KϘi)ZL㜤9[g5}ӾB:*wBNLf*:?u`&a,a%PچI3"cijWmN;=>aݘ(E=tj7Djc˩}k5nqՁ-c`8ctFpm U4;ܷ#Y#paxdp_4 L5N]0L<@tj>~*!h1"rdQ( bVRdD}^)AS93gȺ]Ӊ3G_8ח9g_f^O=03>I1f2Ka{rLlmb.~,# endstream endobj 451 0 obj <> stream xڝXKW |!~cEdž5rrh=38n~p1Wb_#NRwy˷tGL;ve]b( Ƨ>e%o??ts'??}Sr:vOe2]_%6B%:S;힑d4^R|q*te6KA2 R !"Ip3kC!'[@gG׀^l2A.e2#J{f252+?@p"?E V~#V<1dF[e^l;}}A]fL}D*HFa|ñVD VA>\ v d@[ ay2tg;g;`4Mc+^L o I"ָi=Jr}< dǺmOBR^d HIP @UGeҿdMnVq7vu<*3‹tSpbУYɥ~# =A-42W78_Ny<<.!^ɞl2BgӨh\˸ GoCr<.gy❦?8%g<G!8)M沸9QAbEsu }or()dhƜ?"be: tl%S|] PETtaEʏǩVeOfԕiB}]:cMi'ؾ5M:<`rE5Hu1ExuEe|6-nlMكw]]B1ENEv :*Dsm( z; 1 72\uUm~mP]yhŘVU `is?.W\~KCqpi{yW,.*4wrrSVlpR%4߹A1vu"iѫ ˲p'W&p O[= JO. &V6l;!>lyL yS9b&]"qIqALZe]qn 6BRl5*LO~>WP~Dգw"cL@[ [,#ki P7icTd40e$qLsA9K=KۃTd_W.v7U90X˯}$+ױa{Ԗ0E3vALCl.\-񵟭Ek(׻/n_Ź endstream endobj 454 0 obj <> stream xڽYKs6БJ^)TewJʺs%z E*"='xP$JJewk<Ňn/+4?W߬zWC [mW,_1AW]Sq:B$fJ)֙L諶xR4;7vj?VeD zQھM%͉Pr*N \kSmZe:שRYR}hcNR:i}>V ]X1;IuU(I^yU䨤ayRnvKc⡆I7״}2@ CdwՇg\7.oZz .2EvO, 3Z$P{Y;w}< -uo{ݛvAջli^SJ\)dgO݊10~=TID rb~l^C9Eʺ&~C0g~ XHPR滛?CLtHR=֟q .t%S?}t7/#hlm(?' ֌e޼]nl梨 ^Tx uهu'?AG'5ߖyj#{ ) *RdAĝ ҩܫ^nwp>˦S$eh|ؼ@a\lŽ2唓B%} R$/I3x_zYraUUp+ c@ȁ^P#sWv,W0&/>Z'`Xҧ;YfUQP Ɍ~F92y~ JC^xs,clK7&L2p9,b J?,{1f-6dH-R\u "gQC +1 p*..$f vqGG!/=',bZdP˅9*G5T|Ks_bY Wf\E=e" +Ú=zF9`X8Cqǂk 2'(V al1"0g83+Ts˲T™mFLTcjXqt/ldPRG% %jS3 OTD 4fXzhswPT$rU!8d,Qnq%(\𼫟\д|Z㳬"Lp245z@ؖE0LnN=&:i'P"k򌴉ővx폯eK!xg9oYNVIq2DWTv]YO3ih)#fEWc'#fl4îOgܤʨ'C`C&tvfO9=߽U}{-ihC[ `>{qo<CgpߔH8m%]D&Z'op`³=GSD֧tXXC/#,ۑ1ޭ_ކ&u)U4NUL2<;}Z=`‡2&[PĨ8}<.-Ke]/ȺLvS_B}Sb^*Q=q8ʫxPxF gy'9CJ]6}N"څo4A,-i9}mյ(M8%?3sC 96VÌQ)|}GzzڐU%u}ڬ|!| r֋]OEh;=jUɥUA9Ůt. =6/a/jW'%• ;/<4"⿈L꧿E endstream endobj 457 0 obj <> stream xYݏ_aIN EkE6=hmZ-m,Mΐ-(n]@f3q8\b+ lUqaQbe3+&fuP0ioₓ5}K!DQp 7{Ywݺ؜]o`nT]ZJia2:>+wjj2]"Z祉&N:'3h껽[.'QWJ?!91D36k%Ywj7C>.[g SºD2~'Vp?k Q7JB4ݗCnXCZ{+3iT<}n!(Y Z(@(Q@µsV؊06:?" ˤ($&%@ :ⵦRsVU%aFO"/?!:WdAEh4ipT"D0%V 6/tֲ%٥48|X3ܦ" qW jE="07fX*]mj .~-FnP).nRqݜs36.Mǹy@ 1R1SJC/EoG>`+!R:,K>"VJMTb27(14p OCu}<.BVMYlcwЅk'5E}lJ /;4OwǣQz|,5F2yy%HcrRF&(OL*JLn09N"1ǯKLUܥ%Hp10b,3K//3d܌a5ct T3q75xނ\m.*rڷ ')]{Vg8}^|9e's7k/{+9_A";z?fph @ {q. ,\p6VH/Yh_dwQMNYA i9&F{Bh$oˌ)3ðĞTHy@#n0\ۑ\:_Ax-_UTº\^/ Y]ne48TD6 ?SpSlD#h&" 41Z^V ݃:/wtϡOs{{O ?eiYK}2`ݸ'F[5P%fw%8N5e!i=yw7Q:zQ x|VfVP]!Q*ȂP J?Q3F>!a?_\Lfmlr֒+x&ESZIVJIs]gψTHNZt^JKع-L](viWAϩc[0Ʒk{ }[܋i{‘}ߥyp(!A`؋=ٔˀwѨû)G/e("i@ppUIenz"J}]3 ,> ̜%c2v/ +&Bg7? endstream endobj 460 0 obj <> stream xZM۸W_$[vcW6TjkɁ#Q3%RKR"5F=2Aj_7mE7[?| &3lq]0`"5R/6M~z*C-WBD|\ɧoK%rw,mOf&ν?4%yLόɰ*-gI5vuG-drYzMT==S3&Pm>~RTlb +[î3gJ<5=~<u&"ͳ|0Vv߫~I(m3LʕJv_(OXP $=Rqm-y*Jh1 E8 .wT]yLЃno)75)[)<+Ow`ybdXg)Dx[!{&-1O9|q->y~MUmF褚޴G^ EBHk)Tr|>oe\r!RiwG\2|{klkZhe:̀=v=R\xyn4㨓J_̈ǘU b#\_g@Su9)cΥcQsm2>j;_l@*i{ť/x ,~Z*N)X!B@6S9dUEn=UNkXK̼wbzu?>JhD\ \&u{蟪kJ x#ReI 0ӬCCUkS̥rf|]K6DG] ƙs=Jc &LmLғrD*z&K/S֒10}Spq 7Bq]#7N{YH%><2Xq-Ia*RTKL$* $R!Ռ `we&r::UK>z* #l&l Clj "b%]m!ύpgLJ6AkV%%K b%"u/-SϧFS*(= el!(,Fx?PmC`=爛3ؓ,R ,c%WbO-8K0tq}|eI?ԻƓL?;OR6EI#i2yJRg6Ǯ\9LEɓdTD%1¼olpbQ7 YkH& nf`Ծ6f[C)ػp&S^1ܓ<2 ȃt:uot):A$Uw6iޏ3Se4ZoE穱p)(:vTӣ@R 7ǕS%F7.0裖V)W#z۰n Wnc ?Pp$2vF\%k4{2UH@%2=Zw=ڐFuCmu^̉d gK~u<'[]{jp?׊AyLNN?} 夭3;(mYSlZg~F$uo3굟>rSjP{P&!ۓ3r68z^1Hn'ĺl`q&.GJɊ[:1"z ]20q}[ 2@ǚFkpa]N.*I\:OB2 Hne-*{-x} jK!i![dw':čN庣k Z nY >&P*p*JE4E"A6q?%[:͚bA]Jijv.J,9tu)pP;tZV[މڴٶiMbChDvb@7Nk䮻jy^. 26z5SP%TJ..Aǣlp+'5d[̂Sg\c.cX5U}uxN )@;/+&UE=kwU]gi$fŭ~:>ę @> LZp䩤oK$68kz=P*/mq$'OR"TUZY9c*?&C+3֓vmx>.ܺ|C5aK= >FlQ&[(= s%yHB2cI~cx (E|[Y endstream endobj 463 0 obj <> stream xڭYmo6_!&+Z`@ַe ɀa>Ȳ %M؏ߑGʲC'YZ(<{xzx z1/GC).Mouea tUmM~V粇dDrM}O'36=坑%&ͬ IRx_إoMe&2~3G79D:p +Dr Z#I4v h#mn "XtPPun~i;d/y{3CPMOdOݰ)`ltҪKAzNcT y|OkTAQХw`gMmuuXULu7z~&S>^| ;d#[8Y@C{jS=SG:}9&-RPo&o=7KiL!mMyqԗgЅ^Ձ`3ncR!<sZWl;shg ['.:c e_o T1Ċ#D,+l_?7(8KXz"QM[A,Ӌ,x旓.>nc;l nFAXHᑥpu0.c}5;&?#J~(XZ}zwy endstream endobj 466 0 obj <> stream xڭWmo6_!t**^a@֤@6~`lW"HH=wGy{2PQ땇20'w|(Fv`}|b3J|VnMbKESmDi|# Nև(VCN0<d/JY@c׬Y-SyG-r>l#[``~%F]Pj"R^vQe^\ysy~uYҖ@[`'#6 PD=G :Ⱥ<ڳEͦb cl ]z=3 qd>n\s8jS ե4X/FBƂJG2 URALaV͂)>enнq˥K)! 3i䟚56ܺ3; +Y4rio c8LMRXHIٿ;ĽRaicW[\nH.rc> stream xڵYݏ_RO.7nE"׾}I;)χ${g,)lr73[QVV߭%5aŪn)V\p۟~~!ŏ?.2CkYaU=~u1zldM*& _`|;奫 ӤPL/>!(i<Aňm%GJ+SsXܞ߾66 t_c0a KԊ0I mh{T=ҫVux QKk#lKl#.2ucPR 9F%Q'Κ L U&.=+iU͡ʧ KR0V!ZאRKEtwvl{PT N9 (GCnp1T&Jqş~V " xxgx >vjwhaOq{(k ̯bT\b/ŧE5RPV1N(` "WօhyNOWYU Y` %je[_NA YX``XA:`e#.cb86۞!H-/qvgO丰ۭ h'L&!svHMk*faex8.$n},^xY+2 ֿ¡.Ph8Yb kǫ3Ήl_;#JƽbE$4h5Z5 ouF^6Ep+ETՌ+} fAG#BM$b-I]kWlBK`ƻB*v_dcT8M)g E1VlNC_ po4)Ǯ>Oi?;{S!aPNv798qBQ<y~>Z@"J%Ig\0{xQu1AmצIUu,ƶ5[9\ՑsݜBEbkAA$.)נo7-M֑ېw[QZCo.:óO}3hBXɹ!;$1L-:z]ZUɤ00!#$ WA2Z6BcK4b -l CTHcEMtL|z,9/"a.r1 ?Qr2ҋDFd!B*rRՐTԭ!!n]$EHu Nt$/b⽙著٢q7hFԏxiԩX{?.KEH@-J!UKN z7Nc{XJ(Cn <92>p6m)oBML::v9 jf XxnV1la _GQPAJYe>2n bx=[8"Ck6~6Whs̄PLvׁ I%Z*g_SkhO~>邅TIt<?!0xN KYTu{y9!_1:~).=l:x.2zAk zS H& 'ɤSJ\bicb xĊe> v׫wL) endstream endobj 472 0 obj <> stream xڽXnF}W-TnwyJSEZ@QT}UDT"r|}foHKǎA%3ggΜ:(p$ K>6z{C"CO=b#A%06v4E"p 3[X&P CYJ#ؼV]׭**{qV [9LDIof,8  /xksaĤM! 6rxGxHl̦eBF g5tYyyjR0L$m2'A@r]iD4 YބHU5UwlfJ̚V&pպEr:f@ [U=Q.wf2;'fڅWXĻgCd?#P}V;M/W>rxc-?V[tTԍ"b3ݶ4ܩPA"ە־z>{""ɄR 4EK3r:[.q|N?FmTjݡ렴 ('X^U]6*/9&FhX ZnJڱvsr7)@=,ֱ 1Jt(”W:S^ rՇ)=<2]bGÈz-TO`$s:Q;b\@Il,dV"Eר'm[QnUdO{"3P(Ocs8tXl@ݰKIXiKPD9t*L=I@Kq [ D\@g5A >)jGP0aáMYtT`[OŐi(ٻ=rR_Ѕ}P;^]$v q#0QJl6G 7ý{qZ. = /*]oʇ긷0rұ-A;o`?_r7VuL_sQ(w!&X7_۳'2{I?NpVψ9`Ӥ4Δt4'ܤfNk7j<"7֌3$| ۿuv8'c_~ M/_M^p4m:8&`DR>Qюc5h=^ ޞV/G{xN=䴙<ߗhQ"p}WW*) endstream endobj 475 0 obj <> stream xYKW9Qb9xA` z$b%Rcrn9Y86~ګ*?|eMVqՏŊ',Or{Xl%U~Vw[ )1w>QQoR/V߫D?5XdQ9m&17IiVYƕ>lPC`C`Un͹C~>Pm3u5!V\F)zDͭ;_US}?~=3v1#ro/pTRq% wSmsOl#j8.%S&lܫ]kE$Zkݺ/bLehMɸniߐcQ[αɘPU i7$9 6ás?Uf87Gm?CPᰤH8\_Rb h|9:="a x uo.x}{JQFypt> hF7xKé,آݸ`2/fv;L4^2'|Dr= mv1=>ktDd%Y q/Iz,%!0a9IHBRUlZX V>.h ]- |*1Mƻ֌iǜx&h1 LPL+rgZq-nz S2X.'lf;M]Ypnips;<^er> =2OȆR=[J]$"aENX=1 =#*p+1KBa{7OI@Qd]"30C_q+q!zO SKsn}+WPGXlhq b"uWm"ȱtU_=xz XD$+b b [!;tbāI&cy)l9U)+13ZF%NA633 !m-XYqAȀɇC(~W?f۶ /, *#Jƀ26mkK Mꡭ$oã} #qY5.,|z(xb!C\j#`鏴SYt.zVO'}2GK>b\$ FzW9Ab#6Ȁ~\k,Kp\SKp0יڢYb yBC;1|Pm;n> _gXL*<[@l/F ZӖ˴gC F2jN}L@ "=Uiu3)E,hѭK*pZO-@r}F, wCKS)ĦMu(K@TcUW+@P"УuhGvj=ᆜ k_0qtʥ70(z3s Eh[i!g|{z'_0P3^!SNBWM^,_,I\[~b l$"իQCoݞT%Sir) =͞C az7LOM|+d dk[nQGWN$s5IF0>R` iK@U?S"6)}B|?IfM/ys>dz q"a=85r*3` J@Ls @So9|E>7w~]"sDx ꮷ~jW7B٬hz5n45T dHƕԧ.pJȆʚ򺇦 OT2}L Uv\G$ި#js=+Ohn{|[v endstream endobj 478 0 obj <> stream xYKoW4rR#.)z8.0Cv QKz<S"iIC^`WU}Ue'v].wgNHVrwWùNfاRDST㗽VI;|%uwA?kқmf,`_\Ohm{I6vMS?*U+c?OR$xwa.Lvpߴ/ _ȖWLq:bkHdsŒ2sSXT4 Vrf+#$(A tFRrbfErh_U:Ι(Kw~ 甹rCvޭ}Ԩu;6sA3j g} C/SBY" Q=Q('*" &Ai)NEUpzh:Tdzd%h5rM`OV^izp#TtB9lg_O[79Er0@BAV aL&q` Sُ; :60eR3.3¶e˴lёљ/[{ʼB/(xtj>SrGQQ<$Z)| LzQgp\2>䘪dRI-,9#TOk6h{փEZ(C#]k\J֔ɥ>:y`aTd9+^hf# :,Vcۨz̧ه'tZYu?ū9 o>4CՄoj૮֫j<#,`Q j3&!m!-8+yn0v} YJzl j^l`Q'ҴIYUx6. [3 Ɋpz4S`m4C|sV.`tǨO RzWYNqI6/ZiqY` @J5B ,ֺo(c9sL&8y:KgfI/vz?죡ssӶ䦗?x(FCU*(1mwI- 4naj.6,/|s5Iŝ8Pjpofe64JއԺL`<$Bu*4)${dTU҂ʈqqD9x:"Vz_@GzxZJhϵ[$$@>+q7eF,U[۪ expc(_Z8JK:lYN^K:gK:l3*]N 8g/Tv:2sڟRHvGWNӳ=&RR]*;<6 ~ʀ[aoWI|^ AK]~}o r<, 6HQUL"D9(Ms|]VhX[H ۊ-Xv.܌9*>wQ5 Gn .Dt'pxG!׬Hmɠp߆P7 F~v!t|Z> stream xXMo6WV(IbK"ѶYreyCNRt"ALZfL_keջ&]='7a)?2ĝc42!k8(OMSǢ=uNR`g hn_D/S8Zr։]j.gdC_"o& ]>S.9r[7@|~R#s]XxhG" Jb1ny#Wd6}.T UPg(WPm4\mCܱ"> stream xڽXI6WT.ƌKeES"F/h3ŕd{"%Kj:AD>m(4 'Ѯ^oYD%67M#I&h9cg՚s󗫵"~e%El=j1/ϑ(/GW_Sk2""#)=u|j-Ss$^ʭmWM7yeӮ83]ךhMI x\\q;ʼnzmH SZ1#E)L8Sػ|gޯ܁^Y넊*^Qh5w'Kl{/2E/tNH]H ҃u B3I quluW0O{n`tPEФ7Z$h+L㡇;`"tnej%ܙ[ )zVUwXp[[^+M&.H.$BvzAJ۠iRB[Ǯ_7B^ pf[1L 8ljWa sKqkm(hdV G;C9dCr^`F9"F!e l}ueJTY0hSxAN!v2#L[]4C8' dg @搷N(Uf(QoҤݙSkC"KO/OF> f y Q&ؚ2<]Q$p j !8 L8ïq?.ߝ@ oI&4鵧<(h43gR{3BA+yvgLrs.cl|-(p,d$!j'dMC6Pz,2E26b7uv9a!P}L0F LޞW>7&XH\x_8;s7 _9,%/861LW dŖ!TPC 6\nK`D&dBLV8e7 2Z9g'Yj/$JxUTSvGw-j%oݴ ~ڂo>K(39<1=_nVz乺:_ōHRAk;hMwS否xA͢Sٴ~{T;qq(]$;ܙvT'Eo̵2{=Ww_ W7@η]qyOPS|i{j~QTG|~~Dq_m"[;Zs i,Ory> stream xڍXKs6WH!C"9Miu-&N߻xQ {F ~Z(WHZ(_ /V?bկ Lp9훫,cBHT49|9m4v<*ǽlG=RRDNJLE#e}oECqꕽD|}ExQ{} 14jpJ!X>Ě2"tCBAZb7sNʨ^zI!QI07n[+,qn8&& gI!Ks/ag@_$7F(Or<-4?̒;}ki26Vd@v E7G .Ӑ,C""K,'&$DϾ~W$@+:Y u5ˠu3&\>4|e"a }uc27Mu[Ie?;Nu1(m|84Q*߶27T 7%X Z1ʣ,ۮ|봵X+~eN%Fy.7"GmYjOuMؔ1]p AY^cym؍ dG<h@^3rS5 2h>=SDS>k OB3HTm4Ԣh@1nf@YtU0U)P>wB\b6䰊=&`eft$+ཱ I@[aj ,_>n zY$V5",eBgG>q$C+r\%7M0Y'mP߻9{ˎ ƹKd&[kUOgEV(q&284\֚!eNj;ݽypUewZ0Ґ;14)g>D\6ߢ n cMآAC`J49vxC~ivy"QdU] -n%d@&/ jNa s1m8t<4%!1GC7QjKs^SEcc"f[40S!{å|N+$`+S+W dtx"lR~Zs%O]lk;|4dEZw jrmZ9ve7X֣}TckAmB}m*~du΅/ăBe6J=`DI\ dbՕ0^6<ʦTŪG[&ilZ> stream xYK۸WHm ěOCRJ;>p$ŊD*"ǞI6=3X[-,t5\E h+hMں}ArҊRvWoVJ=ts?8nظE߹O7-Dq rq?*[; liQ4Tصە_LQVRUQ1FTvGc@n߼XF]TT*nYﺣ pA)|Wx"a~6 L, &PV>&LswtXӔ9R|KET|Mx/XoLUqty=Dzo%V ֐VCrBkvq{@xq=ЭA9R&`RtuQ6f H#C.G3~'6B[G8m|YAZn;v<_[-;/B&(ww2Pj|mO[baX;]?ls6U=>gUO j'{C"YArهݓs^ĴJRXo e%k;s* [xjx۝dI%(a n`Mrw3 ތdaj*@VT0GnY#@(kR|1wXy` ~sD_X)s–'ΐ*-,c>~~ yO RA_ <~zzalJS"k)RUˁGߍ$8nȁ|3%9W v{̠H~k͹Y|XK[ !3Yfs*B"N7PKr.bTTNԢ݌Ox&;74޻(dY ӧ0r!Zy~Gf{&P^ͣ/G5"PT MO4GsofX`iٹׄWB&P!.P Aþ'Kp/W)F/8J]mzqB) a|V>{ ˠKKzֶBJ&I|Aόk!/J}$4y_ge^&cAq޺ΏB_/1 ,b(F3Z_V]ZZ] 0KHE\Zb]y%<8m]*tz@[c(o duwp6D?޿i@iFPh;įB]l;[ d2C>?/{WE] dT WJݣw2J@QӋZPjif6>lh5s/+{5 <ЯdY3qXOB_^ endstream endobj 493 0 obj <> stream xڭWYoF~SC{)է(4 PBQ wȝ]ڨNP؀x7;}bo?ދ7̣!IÔzˍGr[?4 y3o-ιUk}}qYou] }駯E??lU`ZFc DJ*z흪P-ZTTy!Tߡо7 xp/7MyH&|u̶Ru7W }IKoVpkɶU H 1ytiN ^kIl?"(ymg ))4@ku{Uc\cg! i!O%aq 3փ_t[182kT<" E4!]I'ԷT^~L/ @C{ZzeziB(UH~m :n&ȣsCž5g\0qAIh^WoĘЄ:#Y$( )YOİڻwQ<$Ml&{nl=no2/QCozܙ0L2x6f@ ]STǧѠv3Gi IEDH>3.㏃i5Ϧ8侪r2Vo-! &@0]JEE.f4^y,GsXb1TMiАm(xWy]ge!,~z D7W_-΢Qfo,w mh#sG9L؝JOH) y<..Ϭ08Jӥ8{.3аT4pvݢ_wS>7|gFr1t EbZvV#XWquPB7}( >|<$I ͅ] ˆ0uԳa1X*@' s@5~g3j^JEzZIJ*^kSniLaS5W LJ] 89Jxlo5bCu'I?%FGZi>Yi#y>[|[*c_1>^NC mx>='}L\ |+ w:kޮד@CS-χh1~ endstream endobj 496 0 obj <> stream xڵXYF~_>&=O^g 8xdaCF (R&oU<8V >4 $((vnްF$2nLcz{.\,"a^lj¼^n_V˧_Acp rM~>)%K M ˘p6qتH<2 r0O_$1TIBjsaIYDeXBxD-ZU^>۫+ZTJ a:3ty%?ٵe@Lo (ss uwJh''SaLӠpt&R۱ Ogr!.}[ֽU1"is#1|UiIygc '}?|o--gKIs0,!Yil)2ɰo^ݫ^5d~l, , # k0$2,ھ73SRIZߕ;!Bo6>PF$$' W@ 5]|W/L vw 4 ryi60CRDz\Tn_^k漽?q~g4ޘ?leB8.W媵2 hB&aS;!APALc:Xzy۲@8l M-cZq1@UsN13Ν952pRYPf:i:5n >1Qb4b$ [5f#A+ > H8WaK8do>VT!@5a#.uAS81uՀFP5ʺ(mC(Cdk66X;msG>s^ۓ)*gǰJTj9'x*+u|c^$)<\O8g#0HZ,T7<$Mų̆qᶱ|dw .CgwhC,ZDŽM+Q4o7n6ς,"[a T7GmO.2bs9uh>}$seX<)wbNJ&BHhꚗ/}g6 1fsEeV4\AE3n"!Q\Uɉ- HO/Q4z甙/%{lAF14$4[% ?nJÏm{|9t;|puZk*}Nk+2ӊ TL1eZ/6gLcFy)?xo0DjmvE95e3fŴ(}`=Cf2L3d]UΐʶflͰ cq}wCQ//F~ޔ@.eda&srܨ: n+uӛojM|ҖT)Y +t0^ f.e{XhK3t5&I2D N _݅w d(^^VBN*/( wedK$X YuE[eP+Myeq[xtU?I"kMӼ!9pemz\X:gꔫP ԇ@HL" ʈ =.Khz+E.A>eA6G!Q3s1qE pd"6#4N7.tO;uz ٙN4][7#ت]AoKo /H`p gLdoyZ{HЛi0LMs&l 6ijMxʚ8V(of<=6ZJAhSF26~LI-xҲȃ8eWBésfdr65߽&&Ӹvl(Ph1O0+b~K T0*C3cf+WX|TUEO/ѠЖ$zI}E~fp5,LzMYNbA Cg7 ^ܵdm2S-hlOuv2޼?F'3|,몬Ϫi.cȭź}}N,D/ endstream endobj 499 0 obj <> stream xڽYs6O7ҍ@^\q<dqJ Iu-(Resb݅/0#YN?Ζ Fkݮ32*]}IoQFQ3ξ}|/~zwvg*۽/-[|9onpd "u7[eU4fcm{v_,n.GLruU׍_}7[a|Va ȑY8C\ QSGI&E _y׏(V0HBگݔWVlU<~ Yu+>a<6EGb,f_4]f?y(ބ*>eF?xw߿+wAm eQU8鱎@N}r!0Lj/u7kvĬ1+!kAz$k>x ꅍjwEW|0FVl=l?d>M6DEˠ#z+ T"oUj`ߘDz>*>-;;E ]DY$BeR5YH&5_f^؆Ѳ˪8FDQf%DDQ~̑5T %tZntOO^ 瓸)s$ꉵ*QL+RXACnGڱVm73>oM>"q% ه3m/NKݘԶ TH6C6I7:,*dS!m 0ZPϞnRpEWSyJb'&&ݨ1kӘҴmW_YtoL|1Fq,ݪMLpr2dJJǢ) mR*'hgO dTN[[cH)BrڞĞhoRr:>[m3Ht U@3's*U$ ʟd<jpqFJFߺoB kZ[+91FWTBj%=0d`dy#UjGt& Dyح i x2L ˑ#?ݔiCS+?/ $$o$ISQ.ԈK! BƐÎbu+ >Jcz:E bi= dt[1@Ŵbv"+ùq{B>k~4&ytǴ%KbeY'ǖ5S쳐Mi='2DKmmuh-ck`R@GIHSN\,vxoW BKQPWkgkLՔPnOi^';.uG;ܗ`Rv`i ЕQ֊!/ZA%'!5I(L a~4< PW( )&E2g dA4ܘ+xȵxJK4+%-d04ds'<@N4PBo!Uk\k^ "wZ줵텀"ݟ\A}?Jei5 j ΩLI1Enܳ8r'}H7۲mKY{2QoW TԱ9L k_ϥV0]xVk2x r e ))P>G?mTL;x[ԙ[0=U>Cm˕s?Ǒ⃓Y,*9iv)66I|Gr$@D? -N:vr^ kEX TFx[6}MB L@Ui~~(|vh|q/w7fikuDe:,% d`5fGdy(U}8ho25wKj,Mvyv<@]?'up?LOKa_#X4M{Cq QB8jty V"=5cH %gK.zݎ;*'yY2H=,rg>ǦgcS~(_9^=.lB!_ A^9 endstream endobj 502 0 obj <> stream xڥXKs6WpPM =%iii%΁ STI*3]"'H\ OF,ζ#dSۑ,m jqH%x\kob446CmIrq^/략(+u[o΋_挟_ZXu6m;p x Ĭ0e;.Heі|D|aZِU:qS1('C! (w*N}CO ^Ds BQeMx7maS(Kϱ|]ωqHvàu]EzutԐpjQE2/ŋrSE5 'M{߂>}E E<}A #CQ)ѣB$;(9ts:yfs Gpm4\9RnB ?:-LohEαpvobp@gRf' 4kSṕ!=%K `kٙW=m\|(=̉t:í BH(':z3У[ endstream endobj 505 0 obj <> stream xڵYMWSɈ&im&N*I.8fD/EjIjgƕnH (.fk >_~ .>/"?PentA4r}X ,͹^n~L˟nJ1x15?]55yϲۻ73~^\Ŋ&ut{.jM[M1W뢽[d>#L1^j܋T2,t{(,i6غz'v]4) 2%=;/'P?tmwjW>(>~G:x8=\ʴm4͵n<#8#n*&6{p-~)HT0iܢR,~hzs^vr]TRf"K-n=~=f H%G4I ;{h .&Ȏ\)vkܜu3nB]er^e^c9E A@𻲫iO`; Pfp?8ۃ3q4e*<f@7o 4p3K`5p#G4ysDXlF =ɹ IT\GNR 4YCEd/sx ~~۝aw>(`?7Ć#) 5z!Jf S\hjߪzcrEczʖo=0X&+;+]TQycϚT _hv N4b%2Hbrz SNmL&:5i.}eVd bo"L^8 'dv /eoEXt6l l@fA0Lgx ` L>)av%$aޱhWTW~tÛu~[CkƧ4r" 8$|HXD؈uQf)b*+(!("1ˎ#吝 yr21ϜЦ( \ocΦ 1$YTUɡ!GX(YUU&8ARnj)@g[dgʴ(y(˙@h|Y N,C62QP3B޺ռķD]1)9ń ( 2D M( @mU*>ǢaM9fG9.E39L$FV^ Ё}2}[xjƵ^[SW-Acdwŧ@Kv3,]Smɡwdי <%~EL0@tntU,T̜+3t9-G"$@#@c rQ+>R:*22c5) |TM̏-0 =@}ۗ䙞g7!$# "mT\2cu#~un[['Un|$C9Դ_ #CUw߳k*;i<"IKQ9= 94|RZY2s-Rukx#F |Ar˙=_xݖ {щU+ϕ 5yFQf?q=GzT습[\Bc Rq}ȐUYgVtTk#}sEs.sRV1_w2UݾPXٌ"#,Mv?Ac endstream endobj 508 0 obj <> stream x՗Ms8+\ AArjw2L2#T10"؉}jujz p IP샏y p$A~4e, TݠQL) y3«PjƼ#jwUm|HP XOLfxYRF۫Gjݟ!tI` 8`m(愅xb>4M,@ډVrnE8A|4GĬa(gw~3 bxy٭ Q9( YPb$*!19,PV} yx}R5Ij't!,|SH gt-A^hj׋(I]w&tپb1DfÝEQ6#("<+u=)lR{ V ^) )-H.Tju3E8N7[tEBF܄x6K d+ȏ jR 3Wu1kzBa-zJGy]o-1|ĚNѽo (IX4.Φ?/DSkOkUgtQf7NMry"ʁv; ,9ݿCrIӔh&T6ͳdǧc{Ҕ''}n^(&, !x={UkDDաm: `@$Ե퐏 X׿Ua*}n)|Έ7a[>4C\2g[`u, ,e\V:Ck:oav1MԨ,R5C} bd"/%N}, uM 7v!D4^kmsQQ>'M.}s3Dؔ{05R7&P"|$Je |MN;lQN{{TEl _ endstream endobj 511 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 514 0 obj <> stream xZKܸWp3|?z8Hv`nnδv1+ǞoOEQRvM0H*뫢-؂[t/t{`8~! ZI|\2mn>f33%̕d*N]IG,qY)͗7.oVp-\ZV F3MI<Ф0Cr^#iC{=sqdmS'\ftbK_u-pOKm3(npZ;9YH.ǻ_|`fݵ%v#o%) E,: wQ6;/Ƨ-N(D*q>3K2Y0ǀnaʼn7F/~QKd7tyO7,}-]o!({T"4Ͻ ԟ=r\uL6o_ið؊s noxP`(ax@oNmS(.WBe Q:ؿo;O$j_: < WX]ig+UF;\hǮLg3@2;1S!TsW?/EDIuBaQm%{qb ګQ6HjﻨLLYIhmלʑErb͒1YaF܈\R [7,j}EaZSs]=s83i^P[D3F 3C:%}sdv[D`.x&ph.Pd(rhB0FS2  \T6`A_8^U΄(_Ss{^vUSiB2t\>ɚWeԯ2> /׏v;0kvj;\h H9{q7 ^B #JhF4]Nz#N|ہA-+"Zw>5eעu*C6D錩3\"3r&iG ;uEZQ\rܜ;YXV7(|LƬT2mI -3'`ޏxѽ Ѷhc Poh@B#;Wx(ξ -?G #LQySݮWԐHn`O7hB}X_%?}:r\/d"v5^[Q Z =$\XJ;WGy E@rLV/ нΖX{qYwL~|: -1I65Fm)CMg l&X߫q!O}> ZܺPn}VRWwtUNb!MV;ޅ8>㬙>'c`<(;: uD;!X 69rj@D@71xcAu>l#},l2ǿd.dzR2Fc|6Er\mW[ X5~TA4&Ц|4Ph;7KQe:oi|>Wt cC̗#"L TɥOz9Z7q lC?ZtBF껶4+o]+k *6*YΔ==Ί= fLq,RL~CZM""cr7|/^_a(6`ʗ.n14G-.C΀tcM4N& t91Ko7EZй KǁYw P C0biF\(N7kJ vԞP& {F̻ 5e T 7 pq8h|-7CnF†oJ%3f IE|R,હa;Ā~?)Ww,ߊ:FMKSHyVתunlv2d8/wCjƨ5̎i^+%%V/~EdL{զ_ 6w>}u+P'm&Fk]@b]yjtExʗc\f]a3 `9(ÏA@!N͘Qq\?Ud͙iKaΎ옙UE〰.5}c!(C@45S@QSUj?( }aS[!r Q8n}W7Օu 5_vsh!8ș]|g% EgJqÈwo'< endstream endobj 517 0 obj <> stream x[KWrҤ0}^&c{''{3-Zzt|Ҧ*-0+J? ago؊$K3\Qd¬?2wb9h߾{{pqop,){eu0ޜukG:aLJ#t8QI Uҗy{Ga_}X2b\Pq:XFx /w=yõ'1yIT(oLxI\DeqGVig`qJS#k.k֗7 ]7|yF g4jo@^lYހ.8Cx b fj5Qn&PPQ9b[lebb[@l 4Dl 5ۢm>7dLC!2nBl 4 .khĶP텆m|Od&ZZr7w []y>nR*Ŷ DΦh'[ Y'i+ȞbnThxڷ)WpHu7wM[@'ɠJ$OWEroHcNhn-V3r |x @r.E]nۍfM(2FnJR5j5]kT3e! PN+芤1-GuܖvMqgjk/y/9Y+Ԛ9nҟB¯pT$)Ǎk!i&%^}S6bϏEun t|)$Y6&AeI {voOl x~?|;<"μf0xΙ&yZ.μK/w3y< />2e.m׎kE<?p0-?n=]y7́XJR0 H>e0 bzla?/yT_SFV=? 27E{^5.qܤG,\D@·M)!bB4{4! PAH͸x[Ĝϲq3{~K 5f%1OMo'[.<Σi}9kYqo;Na~H>1]H&xE}1~ R= &|kדï/6N<:isso'伪Ԝ l$ZۤTCO8<>IBJӦ Ak_wom+4#x/YvsFcW8ۏǯܻsЅCoW8ۺ~隲ܜBtqkPa1QC@֣^@ =3&b !⩊!@RT\QX z͆TO ⠄hod#s&ig׻fpn\&g_KQ:cYOG;G?SoO媉H+@DH.}CS==Akk2 3ۭ{X$xe ¸kf(gtP m`QJnExFވ91Ӆ!WlHLj%/0h@KS zŶroU~-}vs&k^ha& 2PI>ORM?Sù .ۑSwkcG.ܸȁWc1r`1rC:/KE|?=`| Rq-!@K"ȉ|`oZQhk  NߊNE],Bt @kE> 2.ܞ? ~3\Ż?)_(7T` ahS(ɆcXbq󭰽bh9km4_D~%r?I&ƌVVKTUlaCv[2@H_wG<"MԂPgRfs/KTQȤҫIH"Z0=Ydwna>)DAe%p'u$&ZhL,{鞕&M6lЏ4&2ÞGu{(1#L6+{{rnUxRiVT.vp2wm.)Xfk: m˿'kݿ\i endstream endobj 520 0 obj <> stream xڵXK6QB/QRn doNnk#KIiO[ER)I_6UWO;PrC}9t?0d+L,O#B$#R&OG'#zdR=SWM|ӿe9D,J eZ0iʔH2AFo%/Bpz ,`aB!*DO8!yp6UAX_BZ.L E .tgCӲd-K{ "3  )0Nv4"UyN{84[Ծ\GK=*"h=,%h]RulH>Fdi-gs5[VS%Z'Hk"e3_7iĐ9Ky5nI悏p$2 Dd&(\ùK=rOTl  2Sf}uy44et reeX AXxvNhS8Dgfɒ]I=^MA_vJy+J0R&J LQpoǃд ,pq"eFʤ;=u~4gwn ѿx)i!N+S2 2bIF?~o/ d$5: ]"`f1yniKw@^yݾGR̾g+_H1`ebBAT|蹭G' h׾ ߿m $)]EdT5s8^tG吲,U)܊p;2P\Mg2We0i7zG:U*:V2䎗9BK80PR1!}=b;0o7s&:/FcM`Bo>VkدQ١P1uՑj>c>F)M00yqLqQ,s5׶IP]!P4MĽ|!Zh[.LkH T F.Κ̈́*9|U=5I 6:'' /g8aN]̈́&Bt"`^l?jh"EEv5N,VߎJʃrJ_^w2:}d73F i5 33%HJ)s J$|Nç"oAIC5>Rw^GWcI? N*'^Gfr}m!J<^ez*r@OӾCNoz 1?\nܰr7z Ӧf:k-`tf ɒ[RP)=D1L.-ӷ"0Š!3:ηnt}p"Iͬ6bنoJ-Vf8$Cf5%lK?OS%fs5Z:pkXdꆅ4)4Ɖ }oE&UPގPalpT | S:5`Q|77fԭ9u ?q =$6cg/b%N.~\Y`0gf^ GaеC.pFLۘ@ai n#xun'ZTы˗XtiPۖDR?mM¬lY/yXf~TvvEP Vi_C{@pN6-v+r9{|pXu|W9, .({R_}jLArPx0=#6??( endstream endobj 523 0 obj <> stream xڭXIs6WHeB+4q@ITHK@6m&޾|J8\_mV.JpVRWX J]v'"?~ZI%Y+8^~q*h:}Nel{ۮekئdЎ9[TLJ=kjJá<0VѺom_:5 ^=q3Իzn6N;آ?sΫt,QmJE8u=u~y1^,.vWo|ݠgyX7N޻ GHŌ>o<,2V&X2znAW)H6^}LdVz_yL@pA ٵv ʂ2e~TEiS Y8<≦xKY3XJLXn=pF.O)l)R&! 9+r>h'65R'ilztՈ;&^/锊Byf1 ~C=12K֨@{~{^Gl-o^c,UuZ!t<.݀}c~4RPSuNuj) O(ɤ~X(LM{CJgRPQD?﷮jً+~RP^0"\Rf`%q0yhuuBo-!:m7IBpC%#`Tr#F/1VLJjpj&RܷiP FPR )t\Sb[0|X~G Vx2(Z-[TZXf 3ˮ^Ԏ<0*8d]YTMC"m}oۭK Q]*C4P <̓c3$nHdpL'% s8&L*q,С^ QPG  6ЀBRPӵ:~T:J9 n(]Dsv{{h-.B">`ubqfL@Z{8,4-0=5BGNGn!k)NX D3?yC!6f9Қg,[<$Le=6\FXR@tΔ i|\BX> TW:cVzc۾$*OX,NL.Z^eГ\5]{B5.o*3Ԙl:}ؤ\䵪+_,[3!B2^cz dp,0uɒ zf,Ife}2HEs'B@xD~5:J J R"mLJeX[ߴvRI/$,_<]3_jʺ[(h?rb6Rd1J8ybV\-#xc2!L*fo\b}hO)JͱzOO#L?C'wIuridzڽM^צk\ -Bw%NeENb_ "$}o<858Ǘ~C_3=r(`,w |LL+=.:؀!, dfre5vz &U7]KO;s21yc)g.j4Q5'N5w!uE} .<d%,´^WA:RG7@kDGw+k W_ endstream endobj 526 0 obj <> stream xڭWMD+|A?,R=N%`;;o۱ڕ촻^zUSU?Vi??lwx(qԱbX0[0AkX?MͰ|TRr|yThFMuwMO8۟ 3, ViW%Lĝ+ה! 7dv+a?\9Ne?]6\/ݔoFrrVTCr~HC۫'t/c 1"Z\0<5 Ec|}Z5Va T @k W*c>9g!Lk(6_UJ'WMKJ8b4Mjwvj.gR\:R_\O>2j6gJI î>7~{`l{, 4z\Al\:8UpcX8gV$_;?p"V!@B#Uʻ*s:- aGLb; h i:jؕ C9M8p`~p,FVv;s5n74ۺJQD'51ѣ ،$μ5@wA]1+,3}Z3+$5eoΪDu\da>~鲼υOsPxl[/cx Q̬ ~NtԌPflgLfshqrVFĺS{w" bBS0vukSJ{ !y߾ 'J&OF,4*I<O<4A?#8"2,8&6q> stream xڍXߏ6~_6`omګZU\Շ>ַmm(,7 |LH?~;'?'hB[?&IHeޑ-꺀oO`/~yxg5u]Ojfg1iՔ6#Ef-+q47 ecs8$0ު wFy"Zs|u*&I!RkYtRMQg] 4Rく"'-`5mOzpm )}SJֶ5=AK 8 {f/p@ Ocԉ/䅳o=Ri[rqbRRfx̽-5XkNDCig yG0*ް:ʎO Ua(9Ь?9:j'd\K IlMoJ93~'*+2v zX"UF Ҋ:>NX[n:a;_mhfj80g8YS*8nzmxhׇb%t։zq\b |EhY-y7CAvyB[be Ustno:ًC{qcw,PvQWz]F3.m B`^ Q7rmBC'|"&4KjM> X 2g/pþb;Fg,# 4#FhWRr۸3D ; >&~zV)cY K#|#>~Z9,XJ48i"j4ZfyAB`j~h c*幍K/R`kQa* ml'NI\JaƆ&pm1~k,uP{WNk7=->~"t5]`׻[CK0<,U(ghσ8lwe'ОOelI Y8UГ-O\"EkL$ Yx\<[W_ }<McZWUdzyڃTöl0v%e#F#%5 p ް)jM)tRcQVlxCIi9g1t\$XaZ5 v6rdС:?`ly &Q =*<ғ@+ r9M cB+H u 66#¾W܊ ?} =t1V~f0dIS;nTǠ$\.%-_'iCMv]{b,Z,n W(ycn}z}WQuj_ |Ӳ.x;)x!riR&զ)渓rv.T] m 9?pn[~{k>WH-`cGr މT3"x[~w"0/ߟ \[%%0үS t*N ]tu}E/ lN§ivC0la{˰NƬ7>3|!/T endstream endobj 532 0 obj <> stream xڵ[[o~PDքsC&E` !DLeɑ:F~g.)H,9so2WϖO?ξ^x͚w3.Yvcux>R__͕R핰=Sb n֋OLq͌Igq+ӹFFK>̻|I߿s:=ld]v@ W/ LJ(`!;A8[HPӂG:srLΎ܁Uۻ+ͫȑS`8sW-txh޴aѳ:| ʂ]Сŕ0տ-)Zc}"=] e uz,i$gquTMM/c${$" r^]`MVJ݆duIY,*â4 g`EfA(`jva)U'xN)8SXy"HPDO/lϺvDWMSYjr]{[`pA`$z~P%^ePy#×㪋jwd]k~loK/w^kJU 6Ũ8 #.z6\FQe0A& ?ʉMu=[AIĞՠX}txg.32 :ߎNk~u3g Lb[_$v={뙖k{dOD,a.*`>5`U *.p}7_J*$_KO 2-s:,,kEKDK3޻> H]P#0/ך9Q fRȑi:=_]ސka71Cx&a~&Y*0.s1eh˃|@8}bY9"S_t1Å<BɛmL@Az1+_Xj|c/r|0#wAy$Ow~{:&2S8fJڑԶJ-N.F=( ~>$ {үj"Á%anDžwJ&kBj=@0c_ 3"5SVLV>:fw!C]>l iC:sq(MQ.d66Ak,5RlŮޒ7Pa)^LE m r $OHorG*O4Uu*)fH MHnd^4A1QMCc_iRL-mM4Sq3EdBzz|'#<\o䦵=spr̕ K[2cjU`x@$l<ȆRgg?d  &oʰ`mF JV bؤ0991˗]uIc|j0{_.z dIRp_SlHS}R*؈WY/`җ>Fz&烙 jmDB[CH4i4O! EN*GG$ yT,y>{9,`jTNB#)ّP21ʁlp~F dLNf!>ewX}b_D!S 1Q'ȉxeqNPFo D'roeR4RE@&:`WZڀVib!L0%IvnTȔ&FZwzʹ zN$\V 0VOE c7c 3Q4kA4'fJ] ]&iKG9/qrG%Px߀Z餹q1#-_=Xow]X}Ġ72}nK{ѣpO ;#j3f]CRPG$A,$3[!z6sCxCG"˹h.JN xnH7'˒/H?]6c=)g!_oP+m`Bã@¬ކ70vgc -1TWI&}ڏ^uaQQuTS2{HETTK&e Z9$y82zb_x!wT B.PIֵ?#*xsrP)q%nr>Q3>tMI-T΄\*n-}eMVf9)v }aiP ]EPhN*`=5jJ1U٘*oٰRq%ֆ 7!W=C$Z\(%B63f-X 55\ Z5M*U%o m7.ľF1H")/rqN4mee$OnIU+i} S'X! _eNR}^ )~B;sMDp!4b&[^aj^Ȅ\2rJP'ʾ*6ǑY}ts2XB,o"/a94Oi(ɝ0E7BCU͸>*rM,q8 D{l@d 龮Jzh"Iz hXv mEpߜ9'G QeOP$JV+Je8D y/(i|hkƿu;/Fc㣢a;z4vAu)ܾ֮W5{|a \'uڸ5΂an(3 Hjvn㔬qHTɦz7Lowa0z/MO^}tʿV5GAJévam ӨF7cGzRw }P+d|i29ŎlvA>Y(*rSF11#ooRq]]F`E3PIagN̾]f̘/ K?dCH#DZQP1S|P>4'Sl(°s ƇI>r!mdXA;AY/'Z`10.Z_ҪO O30YjJYÝ^'&y/`" {JMU^QC%^/zժ u~@*7#;?rR#fX| L#83a8G) b$u (!}_h>Y&G B=c4h rt"_nÂK+8Ĵyx7U~vBV28巻@Njè/j!5r?Ū~"jgTR?CXƞ Q/@}KRKu^j)!j'GxwjtR3ؗjƶBнy"9fqB~6SB:>ehBhsvK UnW~x8Hï)c܉3iFZG\Eh0B:АU_o=0c6E^˦s)'MӎZ_Owi!onhqU˿#lbm_@SҪo Pϋ6RoV endstream endobj 535 0 obj <> stream xڥ[[۶~#c!č8qǝ63mӇ4]1Ht DrAJ(\Ѝb7No7_}dy|P7O0ΈR~Oç-<ɫpөZ$)۳{me:]NETQ(SoUD3 C4v1oۢDސ4ռ)`6&uWݖnJSl]׿^wrn| [!P;ܗmWVϗ=qT6Ⱥ,Je/m`*7U~ ykuI4QLЈA#Pf??lL~Ua80N2AV"Yf[s0&`aJ $M]g ? 4uyl6!g͵,FP?ᚲ5:#Z5:6s.8>29gVC wͰhU@CTp+yӔQpůWÏ*yƇ_ExܟށYR"(^AkKFf-lT7?,P,O5An3ĂiC_`c@nzcԟ.,横fd{`05 @Wmt6M OhptzAј&4$tJlx̷DDgk fU7fK5~0,gom7~)bz5s"g"u @^ضۑMĶNԿ%G*F$<͋S\v LX%T$.m[~>-◨˥Y^LJ,ƽ\kggSfmpI&aC",t}H#flLq5+ %IC 1rEF@UBh’`]nNʺ6|UVKԖz:+vPs{͐gR¨QNs4HU&ᦌIF8Ǩ^pt6P &`pC u[voF= sc`CTggQ=|)QRDS_єGܩT ;@w12>۽ TпEwV̑㚞s7N@H*D;`$/e ѼwǨ0T2Zp=ׁ=w}{p%V;0V l 0?4Ɍs23l? |RvHt Ehlazlh~^E Ny7NQ044sUq%0HZewx( j_bMٛѡ)ZfHflH(_DggL1X ?v_8#W{xݫŽ׃i"IyR;!CQ: ]8ae)( Ї &if.Ȱ7uhd)ՋuS7w :p^jC)h P?8P8SF'q酾^V۬*YIVnbK/-eWl9;lÝL C: 8 ^Nr7pܧQ/1I@wb{\ȵ xNs]y ј6lpfqBC;y;pvЁml 37U+)#޹32=`vPdjECĮV)S3,<]|s ӳ3T x}ɾ1"zP{&9{8yO0ELW 1G):'"=hϸ2I1@eU7Rfw=9N.N7CUMء[1\r* 2'Æx3#DOZ~$n#MNud oM >z=y\Usp{jԉHetyiH_WW-iv dm !hit΋')❊vA';œRI%'BmT67~aƮrts@nst6ȍD\s}<1qv޻-kkmy[iwO]?w^jGP g7r/ endstream endobj 538 0 obj <> stream xڵZK8ފ9|ʜv&Un6bۚIc$EQ6eT,W؊[ew|(iVO+fVL\áxnBVJ~lehnC]=<_+"9Q˔} ȉa~x(?S6\*̊P찾n?n5$r ۗjPNfKלh';T=))%dr& 4˾|ZH2&zjҵhվt},wP4U.[ ZLyume}^ AaxF'1n総 a"R5[<˄eKnW"qwe_vzri/Né+0*iܓR8`Z=ܔ_ُi>ş{N`M%TLLloT.浵g&T4V0=_.dښ ng\iSN$ Hb lR> @ XFuqRip®hzwSv9HFޛ8IZƒ&P&AEؿdta hD>CyDӶ e;@llɧy8D?<<8f(ܳS<SZ| ^6{۠1L_ @ _ L o@gl}.#7sC ƅ ԋ\8bL"\Љ#^I6ou( L>\Y@c@@J'*`D83 NU\P>WƊP8sbq'o(.es:~*;/ 4^TQa?G ("<nBdοL_;(${dt~ѺϜ ᶯ ΄oq֌hә;5zoϳd]\H0GT5?d,1Fur8^!4^ƿIwg3tfWg|߇#@z&RG~.OFC9-/hͶMT҅MȡdAV eTwbA{* —GGHGQK+k*CѹbZt< >SH,K#gh?sɍz<ϽM^D>EV5wv"xtܕC㐇{Tz3qakF-M/1o^aIWaÙ%q7rA5ayz@43#|tp%D&<:T>p35\`~2QĽ'ҔܯŁz`#d ).,d[b HEXfyU0ɜ`R@LnA\n> stream xڥZ[o~$քsInSlE/%S秧mMjؽ,Pr7iư'>RaBiwVTWNR{a]M\Y_MRNHe;-X5Li?TYI5,JKp=oI{Иg|ʂ1mᄗ)v3(p#Aɗ#ZI35N%3g$۱*!d5‘,3taN (g~ˌ.(]emo'պ+Yd^yHlYʃg>~],+q2wtkr[)V#J=pdW'0)&ebrhRJpW X|4:Z- :d`;)y -w Z4FB" 9nh:CN@)M6"f<~搖L I.-|:nůFa࠭rvofLC)ae:Vlxs'p㟇j]uG?Xf{%V"`jk P Sd z(=kcH@Q8G@ < Ov߁izE\pbO< t@K &7NQ-!B>xlKEb.[ *>@tQk" #G1LeF_ #sLq:+ܳ0Hy7!⿺R믁?n~N; b F;| "o%:soR۴ ;d``~yaȒYPwaI+bB]"#Ȅh jRTswqu8`Mga͘\c;p _f8ˌKD$T rK~TDB CIJ~+~!7CLR"*Qt^7o]A h6C*r.wKL|6x ӕCDyI%,s|qGZhcZ#a`p舨T@?]H*.B1!cΛ7.՟҅9\xCOzL'ʠߧ"dtL/꧶_\,TIh7*J,I c;Ąngy!xwWw J "~HIA9_p]D;&4%G'GD@ y*0f3!fDP$1DQLSs\ NbJN%{5^28(;Ah=䴀_)?'¨JQ3kvz(K uAbDuyfqu6d %uz*0f穀Rc* KSfv+^+_H&;A !]6!:DEcư3/85o 0F(?cEz@"$D_2SY CTXt ie2=:QBeCe+t[a'?WG`'<& -ô 4浩YkD4,|w?A1. {MSDO%:#^v}遷tr٧ASy3:Lj%> " /PN=سYld( \JP2(| d.E6tX*z~zGwOl9ZLqѯ'uwr/A=ǂ(e?yk=.mKzoSCLA+s@&7`րtSsa :9TܟW ҡ;t(-Е- Rwﲿl6'#9v O5ȳ?5_Ԃ3o>˃#qCv1LvGd2\ C2aI#+;V>+&d󐞧>q}N R]DԹ;b6fqz+$^Eq{=t'y@7Mp<\ e!AqM MD=?#Їn>>MVOYAs;#ePzR0YW"l~BFrq\6}cbY7 G@ۜe$ifO> endstream endobj 544 0 obj <> stream xڥ[m_zYIZuF4}a-[$]E~{pt\IN`r9pg1)GLrL0{9e &'BA7TfJzv>̤>3=Kf]hۉA&%M:>sLs~t7o(=L~74{E A-O WXb?o-(m1e!.1i^3ߝ*E'_JY4KTE)@%^^ЭxWTo UT;]QZ?MIQ"͌~4ӟ9麁Dcυ@O7o01! z}{º.4:GiT#H`P=3ٜ=[y0d,VCeG E@atea]QE^`>CƓM}Zm][Pe~z! :i AyXNx%{<6,}fVwgiXkچQպp@{ )^O3_mw,{r<bvosˏNϫEul'>bhB6,WfseJIIǗ3#X9jaLt'J q&uN08-!)uMīeM7SN׫)7%Q@ffrKzzH&e}𒶲ږQKUw̒p.v#F#/3NEȉ͎ޥ+1ޘ)Xэu}E>4XRh"1w1À"4$ UtM$@=HKǵ~q}ID %I`@j(iI4tCd--x.O'ӈq,ƘKa Ѩsl!%Kl~n7,]'(S(mGyd#>JX݂IP膩i1D?^&ٱ,&I3H3XsCiWYpx|gDz. wEAᦇu; ZhݕK-oJEk)Ũ1!o)p>z c^ LdJ}j_ë.Қڞ<K/[ We4Wj">Lė!bj st Vd&B\O$}WYv\'`jb;Wn;HP?4ӡ?]d4X>Ic$fy9Ϩea[ψ18La;r?Wdjw)zYC7LS>dIƤ^ꚆeSոi#"N9k"UQGX%C}(&#3(Y`GkqlyWmj:ҒkDm6-wZRB[go nzgJμ J::})8[U#$^2*%I pq]h&C (;MsفDnH&IɮPoF*)Iܤ՚>Z&M c7U^-!;=t?P)-buIZOT UAGD*E "TT>) jHt?dsЗH#~\I#ʬ=XP7r]%̔@nuЩ5QGl@ 4d҉SGto5TLNCp2+_xM b^ R(e:vVQQx m5h2ť+{Ik-q5.#cmf*$!\!,U(b 4dwLu:QP-+.SHyPjJåxu򓣗00/ϫIjTMҮs-!O!&NLdo;f]KCduOSƢYB3Acp3Cb+^,K`QEO$mskNGN-iΈ;JCDG"@t@an2Mh P™&浙9bƷ˷IHt&2/W6//Rbcm#){)J8?_ln_|&]|*5HvܤKj ѫ(SNB7Nͣ)^3P 'kPpn#D/`^ȶ_^0G˔IP۷OY3w*U? ue9,Tzus@}kg̱$ϋsƘO/Ӆ!DvFvqZ_An.%Ȧ?ׇhO_h.yc(l;q>{#hN_~C^5wݹoz1 ǾY1\\K8_vy w9 :4lA:> stream xڭZK۸Wȩ` ڕw'lUv'CGfH䄤&sj?{􃦇ɉr~~8sl󜿦D3MBmymm4%O?js6پ;#*{)_gh 34}1.7>e[;PZE48R88Y CE^Q6y݈*tds^J\gfD(u SPmeW}\RkSjMPe ?-1f1B` #㨲{l"{mvᎩ+6uxGďoGxԶ\K= U( `N`hA-=IT݌cކ?aXYKMmyԼ Jط*QZd~Uv``7-eu6"4:/GvjK)lRp:S-MP(@)"Ӟ\OlB?zsֳ3Ⱥ&Do JG 1% o`љԐB00̩kF"lIqY$DAhn~#<8OhCL؃IMr* II#t>֣?|} є)܊@vzs 9PcӛX/=uu.U-o%}L !z\\:EЋQyCt~ȉc9CVJ^Sa RPM >3Us1tk\Hǚc=̡ "@?lA < %otĎA#_p,T܊zҀw"09 1!ٺbVpsN0.Ft@xpu6̵P"\-~F^rXnět# oNaJU6r"7E>9z*8S~bn.sʔWP[&ݧIMQM'j 4x@Qtjȉ‚~F`IrI)ɕX@p8VKO*Mϻ:*ڀܺ{%wbR(nƝ$V=Bz:[j(%M8: v,1ӻjC Y +B}|Z)bl!;SRS0uZR)BiSc4E/@pd`_ܼpX+Kmu'R~5s*LI@ct8cZοGqmWC:˫S]\LKL[£H6O}kmoF7 2N*tnX O%pz ;\㯅4ZHg77 LO!'o+zWmtDHfb ?z_nU߷9$E(cBeyΠU5GS͐"oAX7dƀ}av78nv]w69PDA!xJ!.=4n8_*\?\Y2x@_Rgy 싰itcqNypo 7 endstream endobj 550 0 obj <> stream xڝZK6 {Yl 0l"lj[=-mw,y&_U|rn`-bꫯZb+ pOWۧշW߼+F>>]1A_=vS!w)7?6pG|'a:}Zdha`N[7RG,Ϗz==xc[)~.C|vO^NqM.b0i6rɿk3I$5o`#%ƺ6a2rccm؃u0MJGp?v)L6(c2S0*\Wju|VݞOc`«hL2vxzOaiͮsvTW45DXP4uy L_߫#1]WYPicǪtqS,*es1|];%~9 @/A\j"3( ڟM;tzxΛ1iwn ׌=BG{W  <[4S^ȭm^[Z r@s@_5`PB8O]\Do`hj DZ^Y[?wi؞ݩ:#JP);IŃ2DMTnX'5:AN%:eM39m]Ƿ;'h<F KQm؁WZH)!\o9 vC$,-} w(8DK$> }Tc  R!Ack0'!I9ѭ WFVb{ f۟SkGPsXRxC^1xSp=Bk>Ŷ1p׀c q hO*mi , %8S7BC#hLO(ocu?>AumOw0s>ϥ"8"M&bpA~1p - AVk&AH5Pv FV GdߣK2iIZ{9/Bd 7fdA5o#o!7i0!R ?_F>X Jl>pnB0QQLjTDLߥw rrgrBfs^7E78H֝ͅ6r5~ OrjTx<_H`ĕ;p<=5l$BL׹" #륳IQp]/fKG`ɀwCiKY:+絕) h>|KɡZso,{WkVKL no/cwϽu2K (mdj7oJ`%IXY%2Es.*!FIYv:H[sUvL;NC-2 p~2*\ڀ"xaW"}ޟ#ŗ`~p܌$Zj7a+%C jd7SsClQcùZLjmjrw>'__[2.j#y?li_Mgg߼uJs~i؆AUZ\ KDMf.Ra"#VmZ>YB&5f!ʽ4es1شNSzkL*ԝ?fo|Ή QA~Q~ Ur0bc䱪F|lYz k<G򌗇&M@ٖtfOyNX1\7>URb PFз`L> GihՒ%M@ͯȄcolU(%Lܶ@WY`<*ŏzl͋>< "ȼ|6|w 9;Pu5Q,`8w!Lh!]2LgR+uXA/Z6h6m:b-Urt4r2 jkE vY^6oo,($r$rT75 f^$^u S ,Bϧc)]G7YQ/%I<uM8 JwtYXFlʟcr?)cN63Dž7o(swLpܞRwA)d"1F*R-#O5Q@%6h3qY_O}m:jЊ8@M"-K0jy1$\ eTu62O_crl?mq: <=c;eP-ղmY<2g5,2`zYz*;@n g<ޜ,.06w#b$.j,SÔ'Q*r6 8vWΕgZ_5$m@v]Ʌxȅ>\5gBn"rxG\( 3 f2v L:fV\^[Kɣ|ϝ͆1_|9P+ލZ~s6:!%K(ɂkY)8ACzUZ}[S|[R×տ.C1 endstream endobj 553 0 obj <> stream xZݓ۶_GjƂ`8qǝ63F|L$Q!%_.}wHܹo,a .~_E/woł+.Yp*ew7B V~WJJՇ ӿhUv8Jl}7([5]zWYZ]= HPYî9Z2}PY;nlp\d4\w9(1>m龡ǜ~8nOzmc{ӹo}ҧ'V`~^Na8ՇY4, OKd$ޡDRsshz||X[97nSr"5mׯfӠf5(+V:տ{$vm>ou9`eif4@4Yڔ"g܂lS?U!_/j+݁l\d!+@4ˤ1妸AO},oIEAiGෝK_PHSKk#JV^TV2|B[k+INyl0k0n]%¡yHC4U W|_T._//_JPF,X֟d#B>\Q4ђg #Diw58[F(dqw1Oρ>=/.]sܚgLy5IHݐH Q] bSM_5d!#c 2ȍ׿Pm*@(>:?k Sk)xطLY%=pަMLV>4`EB@\Dx3Uqhoon0eI, Z4}rd\+U+Cč1vvV*\B/\*6aH&SE>gid!ڬ,ظ2Zgo[by%6Jrj0:[4k\! MqC%&c@ātC޽Yx-XT۝۴{{t(Ln["٧NPٸl܄ͥ:]4?Xێ֝]ʾ!;DVJ >Gǖ/N!'Ʉ e!l FHSm:((|*KZ.}bƟ~7 ^w>֟ \ۘk˯9էsK;Bm:>Z:1#1*puKVɈdrpQ %۶] ] UA2 8P%ZJ1R2LS{tz3C+TufoJQɭw3K u~lБo9r\ m-$hb4E<}u*X.{cӉs;YUnv|͗q%ISwj'ׄd+9_$Q_D$P5{Qu`KɳGm1<ʐg9@g V|VR0-RqHjOC0׶ {bC lCan啮;OG|b뜫 p7gخ"֥ݯxK&lî7/VdTZ)Eo,BOŇ[1FƖdf8󄑗*ӫ@'} 9E>i6KnMY>yO#F'62)݊| '{'va endstream endobj 556 0 obj <> stream xڵZߏ۸~_G-d A[ }jk5^'K o IQ:.%3f曡6?o覄F3Wnvϛ?o~6$tsfC9l,>Pww[y!mŷ=Eu>FPI ע[QDY,1T?V'*,up)N`xWGw8ι璊SwI6RmHYR'j%-}5La]tIm\P_qK֕Whv]{}szʪUJbڡr&DK3rK-JP_=Z ~,)Y= @ࣦn@H&}{y8c -wY cF޳LsTL5W3s-2K 3,lb}Ⴑ­f63#|w5"$AF1ɂW|K*R JttRP9˙ڡCV Ko ,PZ_,RCvŎb;4 ?h0>>SlO)Έ AJ0n8tu+YG[UE}Ӄ= O wuUO;dOm7_4]@C۬ZwRPYV%PAtݐ-79T)`趁e%G *3<-P5z0`AWSKs?M+Pi>E$CgɧױO=:9w.B1Xfbuc34u(&:Po] ާ`͊R'^,`gՂRO9yƢJXu89B,#˃IVI5 lnoNձ:D~\Rk;0]TTgZ'$N5ٲï֤Bc4R&lڜ &|U&SIXuK"y҂]1>E+ ׬oH)"Žz'%ݳ;#‚%jb|+UuPʵz"JG3!9ė1l!+\WNC_G hXdGpWJL&8K.y:_i4iC(o߂ Y"B@!,y<K. z6]X,ZUٜ$֘L[KF кѯ444tvC1dƚ0e M{77Kd#{ss _ F樶4oiMl_kkvBI2qY9 \] dhhb$u"]gX2zw$"uIK@I1M0biZSpafb6jp'pمNW %16 dL:m v+7R6YJq!l_x=t:|ZSXߴ+X0-6-^69iZhyB`Q ӈ񷞾#9Tfj=BGǩ:./2k_h#Dp |gG =NJB#n~܌]m ѳy\6mKGCuqhJ)+ <4W燶mO ,'6NcLIC"0gj>~ߜv~/!FBR]z,݄tJ+WϾ9 8R3dPl e,oIV,&&( ęp!JەT8] ⳙ瞺1Ts.ecY7G,P6q*,_95F:}[WSBU27\"U {vn nә, ["LaVǢi-Zfr_#e<7_+weW!-UԔWv@9ck㷱]:wB=6#3 ( "{xI|=W.*px8 N)؛ p k3HJ|oũ$b }Pd^3 8\`vZ^\ȶa_F1*vZPF,Bx/՟*|~=?`ZoY8UW{$ݗ^YL֋1GltҬt[d2zH9_sI|J9P*a\V*Z/8 WqJ <~s/Ox2Se0;67& 02KsǾyJi3[O嵸5̵8d@yUBn?U~/}x/]3$퍁`Cܱsܜy sp/zBWlXFG͓sv%Dǣ /i"^SY+v?S5\Hh|"*N+arod+H8yl3jNJh`鐛){ӂf)vџ36sZv:*34,vSrhbNr4ynpF ~ /eDB[zݯw $>bSl{X;ٯ -/SGdZ_L["_ql̍^.7 |h [DRߌQDV3|w47Z endstream endobj 559 0 obj <> stream xڍXM6W̑  )RJysr|`@à`;ɟOZ.!ۥJ]{t{Xivw;VXy>DwxƓ`7ξz>β,jƎ?I8ΣL>U^Nr2Ԙ:aYOjI}K6+aQ"2sXԟ΃ vn V0+_7h•st0H0k'rs],X*C~Qlgg>'䃤H|h5~%BIjitm34kٜHUu$m'Z>c5ۡ&+ H.0,ÃC6C|n؜4M:8ij0TYSFZe Pj}*NkcvW,ׁU'tX6uE};ũز,/@Is Ǯ /+ɓ=E\`cϊn1rfpn-U+H1h/D&4Xh1“"Š4 ɴ k%wq3/RO^BXA9ceY(PUfy'X LxSH-Ҁas&!EB>5n,E[!/@iPD zG(v ,iyil4e+KYrE<^=)2HmVЩX~ȱ>DV N'7#e E`;(2&t{nKбee $vY ҊX;}?@"V/miRNEG`n/M+\9+z!yNjeJ'gT0 *wGrɋ7EsyyqԾ/RPR02xԁcŬت$U>YX[<磤u{I #M{q>a^YxD9m0tf7FIJhhsfܮ!z|Fj9N햙,O'9 iw)t7dof$OPF'>M}./$a1L;QG2X*,yj帒bA Ѫdõd^Md<>nx9$6 6ΠVNXˁlK aڐp/^^#j;C!ЪvF ~>:^"`vG$мվM/_nc kA>__vsj endstream endobj 562 0 obj <> stream xZK6W蔢R#x=dRVjF8fD*$eG R%q9[v_?-"?t1._߳MIt~ZPB/֛KM\qq\ !eq\tHz]O?.D d^Ts)HA" \ V"' [ӕm﫦oML+k._H1N$p{XdX(& uIhj@u@*}3BŠʤܵOb5wNփ 41C23Y2ɂ}? fD( >_j'L$OY;i1)&Xp'!Cr_9LZuO!/%#4P_;<XA+0B ,3WA< nzӝTq6RL\=0 !bsQ-zy1Jd2;ΌhZ̓';l3/q?D9 pj$-WRt $2X5E wHK`7{U㥯'}V,ʴ©ȦPwb9QyviÐD`jAp̫+D, nD^2͹(}E5j]4Ps0~"+6X!ޘ\2fߚθSws| $-+WǥsI,3>;c\|M50Hohs*+ڪxFӵFt˨m*/Y@@ϫU% Po۔lb 9f(3& }J%7R%D7% ٟАSqL&qϥJ̖qkx9$ =T,v|;Cr_6|NsYrR~u?8DlJ?K}ԛ KkovMr͋[SDE:Ow*%n oWa[ [/͡3^(Q{lj mmy-KOk\mϋ:Is`TMUs&hˡ룙X+W@!%A1j2ʾC,nԫRD[n)R̍Ԟj|6q#R)͡^')Vrh =]Y23j*D ~>N]<ȚdZN=NY+54|qG ׮~:kzh=3̠Gf)UԄܔ8LUhuz7"X>ڎ /csXB"` zȼ_Z$}㹶J3kڹ'Uߙ sNywPhhL]ov (9ZSjο?׺_O,4U C?fBM|ktO^Lctn'ig2i(;7+`"+(ʖ՜:#B^zTހ︁gG?ktB#j O5^\~25Hk #>ROaJhiLs?DCz^ q*'H;au"Cds{e.j;It䗬LRi{F:iPe|D+_6{OcgbJHзs?@i}@|@|:Wү(ca^t12Mm_y+/!s*5uP⒡IBn^ endstream endobj 565 0 obj <> stream xYY~ϯГC^A68xx`5Ø""55"l6ɪC_V|_iU_z;1㜯w+dV۟#?Lk _߯7RʨhӇi*KhMވ,*O{ӬzKwYo'iY;}9:؝V9@#ZEWxھ ͩ}V@JDN+XFkx z\۝c3huPy Xm *b_%qO~P`>\UjjwtE j f@;5d"Zf0@teБF3m݉q5ІK;`vL$g"Sm+Ą}Ր"@oP!ƚ4E8aCuBeKx H/w/bH,h˳ /!}2[ei}G^8&>E2na@vRɔNܲ+Ơ{cĽfe1Di`g)2j؞N(sCb:ix&נ1,*1wMgJo-(R/HY606Ϩβ%HPd1l0E]˦dnݸOLőzt ^J#mTctfIf߱YUYLWf pjzT}Ќ9x; MI9(%(*iN)J=eEk |8@UI6 D'lGӑv( ;W lAQ>ν Tz(+PW=*niSe$$n:4bb/!w)#v!jª&ąsag\wz]I1IL - f&21xpՌp Y2&Xʉ{.]8,ͽ{ޞzwL49!ӫ$LbbP}#H*f4g~/ J($~>rdRgh2ٞAT[y;Y Qm Ym H%WCӳ9FBgPC1nB`wk|@om`|@uJd'J߹Jd '0bqq7Rdlgo-(xu}RV];D d "AIX{*iJ/F|fmU$X-OcK7u>Au>u~tl@x_HOncA|W1ARx坭SXߑ4xz 롈&*?1j+87.UrSHFm8ا JI3 *Ѕ^՞Mm Fr[VzW%k7geҸYPϜA$ih Svnzo"rN $1<?"lܝ iQ:9Suȭi[ |K',ΗDM(Q4g2zHd73eziӈ>g-޳#Hg?N X6t)rqiGu8&ƺ+\q/8d $=|H&Р!XgjO<*#2c2㷩2pKBoW; endstream endobj 568 0 obj <> stream xYo6rf)Qۧ-wEŦcMsC*I{EQdHf7늭(U]mOoW+FIIKݯ^1AJWCuM!2~Rfk^dO~Lc2ꝟXu~J2ErQn$$/4Jt +ImScU)^<έ釙&T;h"{ֳmRf?0;CNh&(~aʉm|zVF].lwIv' ZX@H8- σVG^"I^D ߶:(h ߪڇx?+༶-R7?az%LW/ TJӨCQ, (% ?Vc{{[?}ۜ ۀM߷mlG@\UY?FxH'\ %tJTq&PgޜHYxFZs*؍Mr]#vYQmۻM+?wvf;̐W NQ9Qm(U]|Iz}s<6(c>ep K jR[D>"vր&dIw̬AwSqz4yf`䤂$T!F\mp>)<:1lL[f(54nHʋ 2Of6Lb(1]ݻAEA 8tgsfrb!y@gwv3sS|v4ϝ8IٞQFD>er4a[Չx׷qm2 Ǥ~v a750 ɹ;ODANfIOzKDyqZAǕҐ}9DbuzX{Ϟr{A l8D8&A6yug~@se_)  =~Gp8MfҸW90Ģ@ڗV7~u>mEQ@|.V鶭=㮃|Y >x ѭO_D`f ҩڶNnhau>{zP0d~=CqOR ^ }I| 14EC.`7 ,&O4a0^u1n̩˻X3HS2*Ӕ+'qCQ&.,Z8Fz<4H͂6sU;W,ɿ) /\9np{/I/t-j*nJ =C,kT >W%DwKү M[iUkfE#Erg*;@Ọơgwzb.1y,+_PF)$DǬʷf{ٮ~]L(n'>To'3>d.zVǮI_&O4Ɯr-H^s6<~0ivNoޜOj7sd05we-|C2:IZv>XL)Ջ s=ӧ\en10 ;:<f]ϰ wm/\CT +364?EsP$[uW JLR]8ѧ,'r>uvkN O X _|]S?*;f# /8Q3Lpyu&ww[<4N> stream xYKWHU-aA8:ΣR.'TMק)jȱ]Z6_vlG:pKcXj~NJbww6cw#k|oυYşgНN]2[=<_tYu>vM6z}[.`un+]%T/%{PfztY_w|o@ gu}]'Fl*R0TM܏:n/ͼ601\wQqHi˜$ UNn|e!p/ ]4Fn vUSK$4lBzG(w,){<cLϸ"g D"VO[;mu)g>J"pdoTvFu|FCy>aJDO,*ǰ*HU`cݖsJ{QGE4PSYT 5}0`ʣ7x7e*y_ c`цB}#^8ʶxlWIXÅF++A TOPFK 8-yzjS&MV!AIC\0ƕOM~. @A+k `:,Ϊ|z k9.xCX RZK{[`|X[ \)+-u3! l+ ~=`G^k#cp;c~Kǻ_XZ endstream endobj 574 0 obj <> stream xXKoFWV 6nni(ZEtssŔ"e>HV&fg%8N$,){ Lds``4Sfw޴54eWkXY>Wk1}ҼyUuqs0GJJW"Aj4R}P(Y[k 3ua=O)렉MMϒ5:]ߞԚuf =1*R !DXTC0J=f( \ fy[7՚)vڃT{ 5fY E h-}cTI,^ B|@h@f :XkL^d571BQэvlK&wwH: ( C $(,˜ec^mmbmaCTi*ӶsG5xeUC_k4 jtYߞnECSFH }qd`<}ր7Op.ATt<[W{ ڢ8f0}1Fkl\f["g? Ek$26X*0(rw8Č%Q q$7+X86:| oXl=&G jP AM F0 < 9BFXΧލ+,d0 6UeAeg*S jAJ+T~ޮiw.LUY}9D&XOqhOEPH.>`ɫEXp9@}`2 u7?7> stream xXr6+fLo٥ytdr(V"Uj$8$ 9\$%$$_;rfrmJ^|-"|m߾z"cr~yx]vUiyoEFuZv\Pn= ?%9҄ޘv[/_v_($soMH(Ea4*~J!UM -u35_Z"eѶe`FNf<<1$XNTmb9o :gPѭ]?1Y{W *сH$ͅtږJdnj8A%ALimWPdwIx+EMJe1lA-2!)T@}(CmjgS6"}m H"X EB. ܃(v1d8tdyh+kc,}'U~[s$ŐYꡩnr='PEvКGm#z.坉وIs:v G~NfG~Y>+98.S#[djC┦=56S$ 9p⽰ꤵUlU>N6TJ,'/ ]~hz[JkCxkQpZF9ԘV:*W!#yJ=̓kݗVm5 ꮠöw$}!˕}"|1c`$(8+ndh>u <8C=Cnb jj*B#P4s *8E峳>yqbUa ׿_0y䥘<9\v,ᎷN-2nَ~,xNR>'[ uv"e9&$}/~Tv1p ?x8D?/\NIT[LsvL ;'#xuSŠK;W0\ޗ.h[z۲x8;A-AMcB> stream xYK6WVy3LO۴{h/-[lӻ*lɱMȏ!Z "ADKp|L>N$?x" '\|3j)LMۇbߚtF)؛1ͧDfO .XVTkhaDŽapvw_a{D'gݮHa2$kl9f,ɳ)͝p1; gfU|2# }[贅@$ϲZy8  gu0rW(eՈ!{5Z-0D qNޔ!pD#Lj3vn>؁6SnRfV;- ʻ7SX,lXLB Z7;p&Yɘ_tway-zD!.yAv s7Ӭ-ꚴ?d xTuꗐ}0ncZkݦ܁@Z`hyz6IpXv>m8%I9R ){_n !_Y h^$"{?lgǦ*f :d9HFyK0Sv|zoe 4&f@J4ZNU p2"g=z5ȶν)Xf' ևd>IXkjvIVZ-|`.:3C4 x$Z w+7\>Mm~ARnv C~k ͘Mt, (J߹icrO4iI^x!e՚{"wT6?$bkb?/.@fFܧކQ'rGtCnO%G!M1 n(7>L & <kLB"𩡻|h*ikj \qL$gBjЈ]{#U!ycxÄ **ONBo<.kn6fbg2@xQ$3Fx+aqX޾yp0 GѱjPg=.I)qs(+y-I7 Qꬊ-*f1\;d{L.r"`,#nR~ڙ%K?988gpeWTe` Q5Mr G2wlv7`z_.".RTɉK\1IO] 3\굉\ ?sbU{ .\mW.Kɔ"+G1;)`_"Mu>$ntfMJ>%JsMIKM ɯp`ن) Y0>hQv^cr@p\Wa),6uMIDQ3 3+]7LV'x5Iꙣ'8!̊EcA`Q$[Ҁ|Aœ[jWltlS $fKbh$/7!kr\h@ mҳ!ۄ .5 3JH(=5s0p';~Oj'~O$@37ϲ܍4Ҫ ;M#%xQ\:H1?a@q^)`~_0X *F\cYO>p~q%)+g)%RA։fu\zʁ>0^gg\fac_dJ7(v֠TP:|9h?>ӿt endstream endobj 583 0 obj <> stream xWo6~_GXHdߺuxOMdI4R*) Qdɡlu($MS>a (_lv7kH%Ɖ:Ymߦ88~|sCsӲo~oݮZ?Wݝ}d9tsu*_3猢o: 9,m_J ~.)?UŋjqKLч j]U}MbyP1]Ӵ/?eA@@E݌X4*x*)Á#j?U,|:eͲDX@&LiL\\v2fTL1ֈro!J1C(>XlijouSufCc*N WR6<6}Ž 7eLc© '@Y.O(`9'Cˀ>8܁(־ZqnzJˈ[CyvlʁJ)}61v4K@1.J`- J!nqBWwAuˠePvzUdΐ&XđQg/]Ȓ%@45`5=1+Hx4: Z>f^`\Qyнz ?$ H@H% u|8aXĜg:@: a\ .[`3 N{s7p"zUj%QNUy # 33OG}ra8ph_*?ᾑ endstream endobj 586 0 obj <> stream xY[o~`_"IڢDl)+RvT̍"WA ;GdLQ>:F]gDg!uvx,)c9zCU~zR3o)V?]=D ȴgCAX]7Hv{8;W+1ַpwMXKoPwU8SgQ 9Q׏5)wU Ux3<6 :5y{?rOۮo7{i&#|4 6Ra(x@H1$ чx{,C.۔# I 6D!%ϖJP=T_n! EJM!sU(y@XD5ΫyHل$Htn'B@~Bɚ"D0d"?kz(ٺB2$`ǣXEafĘY/(4AhF\[OhħlUKfaB)z !3h~RgjK, 6BI"Hp:q'A@-E>"_*o,+dB*v;~C%dvMJ<#c'|">g.Sv:23ĥN4|4MkO)4R3ƫwv?POMs)tup GO;Tu˃r?4OCU_v ja4KJT"**yl-V<=q3D铓 Sme| $r[n*㙮_sւ1?_ o)mRq퀋I%K -?J0,&"ÃsW" _Ջ+?}gɯ~_!4LJLwi*S b? H]]9&d0奦F}Ӧ&}wx&u'i Fp^wƗF,>$a֊dFEuQP:+,;+A)Y!1ӅG: ho/ (35cɒXcgIEHhqe: ~M z4fKS\1R*%@#oGbAx5Cv~'pZw-/]" [GA$wMȏİܵɯ9v k= ! `sSॕ+Un'] WC&@ W )p ݄, ,'ARͦ,#T< =_U?׻c8m%0T/UEHꧦΈμB 'j~ۤle׸jp87^qȄMeMڱ?a)/tFk;G$| )~n0,W 'KEVَ+멧(tWoKK;7OۑzTA6X@Q. D8OG-]lIM`{`g 2oSֲ҈>]t}L=O\,EʦFãa:w;6a mw8TQ \acW 6kPJ . <95l-w ޴:#ٗa`i/5`Խ^u ljdxXNv)9vAor#M=c6#$*Owk7 a@2vPDa.>vJ##2hzy18b(\C{ŦIr>GqsyzA}42w =~`~P}n> stream xڽZKsW-TJ99vrTl%JbjD$grǧArnת!c; pOw/;FIA {1c?e7cwoor!DV6Oje]ݿ_79\57d7 6. IC,kOn-|w+pR&]2mMXq!,-[ꥫ`lx‹jAm BN pA$+9*MgX]+Fu"}7ʑqOciw?݁2rhVv\BMkɕ$~W|@nrm[7DK}Q;i (1C"R.p ; pG?փ?~Wh97")ϨkWg10Km  'Ț0<.n;xj0txx`5qEhǔxஅ`3?Bj#odI i. ʡ}2>=pՇ t1$,4.p <۷>u~`=fwH%8K{7!Hs㐟9}T;!cK$IԻ<>9H=QX r쟨t>{+9jLʿӎ5mOK wO~@F^j)ᔩ3A"gڳ\\0Qnڬ}HaA8eC2~k1!^0\/éĨ!Po^ݤ")p<147dEڭ jruRRt UHRHIʦm}y .cKx=Qw t-,)0'NB(HfRBub## đ}k~2K݈|1m `giF| R5z l@cwŞiH]U^E:%(@Y2,GaTi9ck0?_QQҮN8{Xp>GFɊ & =f\UC!8Ǩ. [:Xfぉ"zΚMkʬ?^&ղyYu=ƉA?>u khk1ו@ݚAY(;ï1uQ724Dy,Ct\qd2@‚GQS_dWYۗ!~à* gܤl2Cf}Ƥ4>GWwE59/=S?/WIr _ALzrtcP7=j?F1-q,]=8ꓕ AGW#N P9ⴑS'hz6_Mo<5:ך_ < QOJw=Hb 31r((@8& MX%2._Gw}E:VT V@igQ MlᄠYsh|\R`"2= j|YpN$hi5 Y$TQSSF Xz&e-i2wĊI X^\U(Q갡S ⾀Md\ \P q9?FH~<"U}uJ0'geءLZK=zzZ£8A㞔>q{qṢP U\73}/s}܎&Q_?6wRp?wT,;@ P,' E?jYs&*1wjޮvykN;n_Q4J%aS|ؔ[m}"bᲔ#ORuî_q31lu7]3*eXaJqF'bF3w Bq|ሦL J (9o|"ơń~(k`ÑWo~NM2$8QKt%R]p,09M((ۺ o"~8/|.1Hn.,b(aؖSGĭ?|o E98!E@ r9}N9(}N|Sjiُ̍m`!1D#~t1yKݦ0j oOLre& Y(##h6~7@*C}<3b S!E(g_H /YdhjahA]J:: lCX QIg(M<, -[QT|Fbϛ"=/.p-,5j1; 9:Fm'X]іowhOWi"VrǶy(,@x/I'ui[~֞Dn4O,xb|$ endstream endobj 592 0 obj <> stream xZK۶W"EM14h^tSdvq,UTEf([37I؁ff1DwvMe`)b`;vN)CjD5scF[X[ט`:E a-ݜuCT.Ғ2k s7ΘJsEčiT՝ -<=دAgȼuM['Ha0BOčl4-԰<z@uH1Lç?UL5\@-_`[ļR/eDɩPDvHc;)&JH$uX 3-άLC@q[>Nw !:v{rR')۲ަe`r5^qؑik?VHӬ7ܜ٭K8Tu_ZƔ H)>fG{໾sdc#C';)܇|MS|f0K,{`>|-6Fm<Ÿ|ɋ⁸4M&&Ax)c碌hRG+@)(%Tˌ2fy&SY f17QVM%&S Z?&zofDH/:;Mu4Z/æ&671 *0a* Ư#* 2eRlB.҃k$$ I/So"pT"ȳ d7$Inx_¹3%"ܟKP^H.!!z X]aZ bwg3,j&"0}4xYe_em78G9W93E&tQӑKKyM0UM1/o֎:R)u)#fM$XYs .x0EN 7zԈ6 MZ>g J#-m@F|A#SD50Nm@L+<} 7dJ 'L:?u^izw|#tv GyryŸtLCb٨8jhߐ߭-ۀ59\33)an5ϋ#a( M$qOE8avϭH8/ܝc5aKV{`s6 ,TK3Eeng *HB=f/hh endstream endobj 595 0 obj <> stream xڭZ[o~["p[llK4PBRN\9s)mY$/Μ9|WWt? ~يKޭhX]o?d_1ΈƷyO+yV[wr7w}~{[_"]3vַ?R\,q髰ʕ(IA]}7j8%tfMݵ,+e뻽RNԊp.nnr*Y5e#Qs/(N$RjȔY驄/[ . 1\O |=E0, _`?ܘ5pj4g ~ɧSW3 BiADNgO- /Y$C!}Γ;3la,O@H01%CEt'e5%6~֭.bl*JK=DTӫfm bhj훎I 1Jf.b.^3 }*.9d m\d-l"wX l tSQ :"4 PS{3/HQ[mh-Qt!P*'Xk`z8lPz:J7IhMgIZ,yi9ZO#C)M;ΰzZ)'/)d6l|7B#T22TH 6iNGuFQR=PfѡMO-ڟ,Y)4LK9kdzw N&^Ƨ߳ZYXRY0 VMG)o7ML>SeR0}{۸N§%CF*;oBUlZPDi_B܇xre,4́rsxد.)Qa}4m\ruQƣڍ Qfе6X1rgoΣߡA]o&U3Sox_ _lޛӫT [!3.Y@UGX |F)3ݪ *Loxj`?n FYԸ\G0'Cl٠=똽ػHWxsu 7Âx,sP`"RaEG jr(E5 ([VDβDlԢĭkD,p8X_" RulTGQV&mu+3J=.-"Aִ@֣|fuC,Ġ;1k{Po+dlًt"X_ApC=6r_7%ieS=&fbiZ%ԵZbǭͩ :E;I%JUH?\~F endstream endobj 598 0 obj <> stream xY[o~Ps¹탻q]d- h]TH*=gfHP!)w.>,"? ev7lA3b3Kw j+z.!uEL9xLqLPHjn-}(A'ʢVi;*܏1fłduϬnP"21""޹->%'p0rB4>:Nh"˻M/r;<Ҥ{#֌\mMf z+h)U ->j 뢺8Awq!d/R8Rgɛ+%KWX;)>'e~ϣ)>9='\&@Se/H;u]\7`OxFt§nQc=eL$"~}oe.6ܬ]W:q81]httF`(HK>Y|OImK:,z`'yx^GW' Q]qpz\@~V/o'A vD"(Xsk_ o U E, {0Q2˕kHcF2 O7K'R`l1ǍþM?M^N> s4 9!c|񗩨vj21A2 Aq۟/__~?=Cj&qWxk)m5?ջni y/79/n3╟yyA"+>c{0R ;Wo>"FQ˴$XG*pjozE jZw1_{g1~q>Dy:&Ձ""x+JUDNlUSG6̲d1!lcah(d;SϙYGvj }#R#v643#>oE%n1Xۙkӛz2!Yrjg#_Zׄ*My;ڱL)|p' ^7_.:@c zj1%`o5&€L1Ǻ%PPAݛI~jմX5ViRP$)Г鞹]@mOE2q-s-[(_d>$ᇂμ 0t/Ia$ͽc  ;SG}hniD[}1GNmHOa@`_pax0AD˭,OfPCgP n_X= k7: }ttx!a}zML訶 jftGcN”I6gmvSav_LaV/Q!NV 5T쒺OJvDqh=Є:fҜ*o7N/nWlw۸y5Qf|+G>Ln:)0"74~ʻT*]5!r]|c˾,foY9h c}~w_巸K,i[$S/lj<ΰ 6mtAbwlX}"8r'jr U#b#|*YO%}Tdh&5c>%w.ߴ0@bx* L=+nDxځHIR1 #>|9j+7Bfԩ#Db0*M}]@}ܞgEϰ Sϰ X2L֞Sjd ҊU]E7܅$=t>h4hn'L^'W7ׁÓG020dI9$`Aw$R߫s86OǘPV spe?> stream xZm_o''-}"E-Ua[I3$EK6AqKQp83C_le8~QRъW̮ ? V?~c_}ץݷ _}{,/7%犨U9Smma{`Rk|C7>4'?ttU.b~ҡ7ehJgVĀŽ>c)fpQ!Zn|K1qlq"CƹJ["$7Yɕ&zw=ER1*S~UEvՕ5 ug2XUu{S5<%'46q:n\PBvдyyJIRjv}Օ Y AOi<=/vAЭ$}0VÔ\ b^"Rq]tO՗gwѺ}<4fh\G,tpMM;yE,Nl-% g6 mp >{`3˟I)Q|T'F̬ʫ8fq&ԣIgesu sYWTnNQ*5ht6'``f5%A9سi]gua3.;e31YpWqﲓ*Mq@Ս-}Of%eA #Z*4uNst:g.o =_t?yTc?p6kxc\E-pJCN5 P0 ,}2G?ԫ#76m9gx幮df![+ھ^zZvGP@K_7nc!?q!IM(7X@1M\ PSdqݖܯץyGwa-On~ETc"Vex6;%O'O}B$j .*"B$U&8}`[i9k+"+<G=hқ1 ܜrwπ 4R_/u74QT[lGZׇxd2)0:&BY^0 h#&|\MJ }'Juwf~ k,Avv2hmϒ,=\( \w,BR ?&Az`ɓLd/9k|\AR_1Ye`=qH$F/ (7 !)@+'L|f5tSccڶQēfsc@vquyV-N 2+ ig#Bݴڹ)zcI2t=zKBYlŲ%CWԞ˧L 7%Ҝ8r~E&+) rbp vv$qȌ-Ü{zn|yyU+wxQaJ`Rl~;~ mSx%CsahJq|pe:E`T XmR)·{dcygpHbh]n?^#>VKeq|ͮ|@_AjQ% 14[gk9po2m\Hn.p7(Cm !a͗.' R߯Uj-4 :M^00Ĭ)Eq/:GN'Uw]="9u ^hRVXi8Tqi_bQIbʼH^Z6#p]lab53Zuz祫>x2"K2SǖMg^ d'Np=sn$'zWH,E|T ^JMUiSuu>A?YjR"o#  TjJ%JrL'8_ONN"S <";MXL4^c`ӫ%NFI:b61EbޜqbxF&9Oků/x/{gcEH$(&6ClcsJ(Y{qۦuZ9᫲oy/el\6@bE;;of|^z \ў*LÖRM@>f^i>yR nF}@a*b^e72#S"A:K ʒ h> akx mg ~iX`Fc5SNF| V h'm̅jRaYLiTU"ty.D&qRۧJNiP{ 6-~ 2&KB~&GSm6?4oVF endstream endobj 604 0 obj <> stream xZKo_] o1-h-5](1T'q=dɡlgLK4ywo ]hflA3b2C#u*'*B$WL'>lDRl~ҷUѶJ=q-j{,#pS^ \,RM!q>|ǂJMTX SM$R^"̔㙰W$MllU-UL2ʈ`EeDH\{& %Z;ha KvOM{PU]اƶi$bFT!rFs$v601& 笊&ZCWG;5BH 06ekI_na@j䀀ȫDm y }l+/o[n+|F>^Ɲ%lݠ=w-Ie#] d,U%ʹ{Pa*Ahbь7!icpuF}V{ aôA'en)pq6`G D7PPю>Ge|W 9Y[7&#@5V"^%P/e˲C7~J$*7CQIua{:=}E`s*t;w/6H @GS\=Y@asua58C8tq9-1Ni#]y8v3$H ۥ/_քnS vԭ?GRy8EhΕd4P\0G (Pyɦ(U@@r9NT8Q'hDa~)3<ɰisxR#zFqTQy#)l?ˏ(uOc5ƹVIuRLk/'Φm")'p!2<1Qj IaP8ܠ pnyGHŲ}Е p@0Jq~K\Z"ΒLNOP]?8+}eCy#+7s!<0aN|'Di|ܷR(z=!!?{9^.6{1-zʦ5iFf̀HcP)9* ]zjuT=Brl K!oO}6Aa3^yŅ%-snPw 1zWe6KCI׮:;,/0'NTY»3ګi-9UU.>|;yB?pƿl:?G~Α[r|(?AF;`EGČ endstream endobj 607 0 obj <> stream xڽZK۸WHUxlr*dgs@IԈDΒgʏƃH&EQ`udY( x9.]4d[|A<_֫a('cY ųy?'cbE~H*(S-0uMQaI*EL\iIeVv_/s".ƒgeI9^ ?5}MӔ=2upp 8fe[֛3H/{ץ$>rAsxwZA*+_JD+7)+hP~Ѷ6Up90hb AbM6Pd79bFRkCDu j,zP8u&0ΪݪiKTo7(ǫb>ȴ$sr Du_ml{C?_]`]XY驦P/u+.Ċ9U=Y):gd|) #w$Xp` k m_dxb<.sϫ>lrW6~<)%鸶¶3R7EȮ=֙8HRRˈʎvLۚ^6<66k~!L ƙT\ |X4k/ؐ٨Qa9t0  A8,|p' TPiLr|X_x^KS9̷Kqsı8P(i6D>G'C)g\!gl4Hсљ 4P K_ Ftls`ըٜy|Fp&!$b#qJcKȂK@ &G@f_RcS>!E,ЬU7} AW 6_ldj'u0CCƪx>[ptitPNhBrԠuD9+LZsLo)jc9_Mn O#lN:+OA~K@V=ei-# [2z)gA-AxH1=$bL@>iI rwdJ&{H+V=i"d PWDëH塄@LEI $R$M'ߨ #B}w.v̀R-bI]2$ΣH/n :Yr4ćV87Mp膈|ɮ9:+@:iO4 { #]*.97U1~im(%2 E.eEs]X\5y`wб5dJqix%@qg:vq}ᙜߣb9P1Dqu3Vkz QHaJz@Eql/AχNګ 6nn62cKI2B_К6IɃmU7uBj% ^I6Sd efWPh>Y< $!eO<.T.niin @ Q&,nM?znFV#զY*?bͽRl.c/Q)4Hj4c2SILK]ںviV>=qr1U2Ѥr"g6K6~c s~f: 1t$$ !LUS("o88E]~S&Jy9Ҧ ɤz!vB{'ڻH@pЦ)B"tۨN S aB܇87ѐS i<;.ġ躙`!ON}#0bǛiGc4Ӭpp 11' iE}p:3|3Zp&꾲CY(O|+PpPE'[f]_hFgCYGv4`gh(c1ʼϒ}ԓlTQo+SH)ʥÆ:;Pgr.@%WDŦşԬY]%ad}e(8Zb;;T@pWW Ekgʍ̍">p݅$ްvxC1'\5|Q*BW]y b~}sWmN\͸713pq#| ѵ9քh8G|ZYdNϯ]_p=c[d 4S+-39H78(ޙ7w#B{kgɄ!C`aGc%{<.YL nׅz#0\XCq$8ſ-@^m,|1GD{D擃~vj{!e ]\)y^IShgAP ^q)` 'I,Ɋ훶vTucLl޶9oГ7'Jؐe)TI ` Sx %j{ә3h̿[rbϏW)> stream xYmS6_ig+ֻŷ$ )\ކ9qa_m_J2]Y|!>z]I8 wLW. pTp0p`KI2]VEҐm"X8~]"xivn'^e 9TOc +UE è1;rm b q/` /IX}](EY:7EMɐ$"@Z?}B,vWo멑 ){OBl>p"` &DFm`Dٳ3U8x#k ,^ާv3bAu2}v߽TY:;ovs/ʪXM+J}|%Aq;R5޿[X7 ҿt:B,d yTIӳ-$wf&fyy:VApl!Կ@c㏇ãߢuJlX\g>aI3] d,h'lc /ia׼u[vEc[/Ϊc tt-*| g,MHz!6;N9[:N4Ս&ڗh ' ƤbE% _.ʼ=A`lnJ a }IY}֘@ngL!S7(>BEV# rhNUatR gYOYV[zG86NnRpR""}l6#8qx JA,|X b}hUpk{:9u9MтdmbΞT{iZ njr7ϝac"/SGDI"Kè~bTz!OS&u_jȣiG_ԡOԯfON?ȫ=!{Fn2򢾸$aZhˁΦ"έ܎nܤpXN;#yQh@ߍBW"sQ&aWJ-uIUzpF^0C1GeNK 0*yx;Rb:yv۷Ž X{xoišGjriqpK3l67*҅s$k4҅-piBg_慱g@:pu_*\tkb՞z(ͼQ1v򲘭FaRvk!$LDLo·ҡC$X6% :6wX$&e:w&ϼÈ}bWZmtCT/+_G+Xi~XRo,Mȃ-f1/+˼tü[q2ikt%r^]jo4+"Ol⯦=fLVv[% 9M> stream xnE\qMh3V<c'x茋DL9C.:].ըb/F@FR"'i-dK]I.9F9*-T.ri咕LB t.7=eUW|SvGޛJܻ+y(ĠC~JUɦ&=T"@xy>`aPT!%6j.:]* mssc\@M)}*nU2JM0Z$u IDq{ % D@1\ρ5JI܀SL_BYWֆmpIMl%_/H5q'{Ja "E&ACPmB[&66 }Cg6x ^ ̂&Ά즒orp7~DP:A$*!^1DjlH*ɗ.d#)j҈+J<:u_K=/=5އi>{j/#=1.wAg4+ǦOW ΣÒHTDۋ0QX.p^|Q;cExc`obĚN+mY9eOTMγre\NWvLKPl2h-,W@ۉiBkt3p|gDM%k\υIؚ+treYRn LvOgnJS3؄^MQtoJuM:sO0T`#jlMՉޙlOK`zjmfځr5l<]g5NLEI"50`a{#iT? =TU\)xOzCx )Q. .NÜ+=[\њ)Yك][f9sfz[]f0˕ٓɣ#l:be{h ՛L&{DD3szcJgǖ{N /VkV G59֟,ڢIYѦQj:x2m5;1LgB&Y=\Dj5InX@faUtg:[}B kj{ly-ImK3yfҦ{o1Xr3XrO;VۻO矖_ Oaط8*+;6`Ͽcۮ:0@ endstream endobj 613 0 obj <> stream xY[~ss2["0PgdW$m9sHz+o-0)j83Z BQËa`,6 ]B1 (R7?&e%yv7{>䧲=7)t(͏b(:D!ME3 EU47$Oan齹}W~)FD˜حǤ#~ID T""u /"ƩVy;9Bم)]YWAKdnۢ;5UąSۍ2$DgCxvb)ԺpwvETE A>&77Xr /cN!"RK3dI֙ i>m}n惐 )&߷q' %eRmt -S!`I,Qɦn-6r(,6vSsAy7є`D&;({B[TB?}UTLn"A^h^tupJ\8W@s:D2 Z/WzuXɪ`ˋe7M~n' b!kbjS.þ˛x4.9/MQHh3 O(apCL: Ul7ʎxFOF!ݭccWpo)LPD!s޿8 .=l0rc9\$OvQBJO=K5)m ݓnW Вa2JD#b ne3>xgCR Ik[IAd L 29Kϼ VhY3$D2Z獓WV* !!IRk&m#<Eςf:a)FKy1z%9)ebS. b۔K Y> yڢL&M|gB9J؃̾l ?6*-B*=1h9d: FP"$T({ԕ=,ZN'- ܝr;Vl0BNb5L`n7Zf>'$:J:Ք#`XEyHQ_kڄkɜ'v.81G" At{d (u{dOJ9)Xk}SZ-y߂ړ"߻GnYh ۻo*oΡ5$(!œ2J栩yvgxʉ>/}rMh9/:גW,_5׍{}:e*œT2|0=gȝbHi,4`ǙOHR;T뇏t6\̓IB˪+MjL Q/Ne6m.ذZ&kءnXeW/M,HwJ#:SOMљ_3qB+sAaY{XW h}U^4yv>pX1:#l`vtЀQ3ch弿ZIKe?/}fNu1ϗ0f }WN]M۴e]},\x>ϲr"_b1}ZAXԠx6oʙ]tl_e]Tu绘y? L]aФP_w#l1ؕtR2؄MA6XB.n&g>_/z}sCܞ]k-(SyU/)B #L׽4|eN!B BYcWF|gNe3cE9\0yY~[/! endstream endobj 617 0 obj <> stream xYK6W=_4ME"F/=(6wW-9Iΐ-i&AE$Qpz~A _?/ްMHt[PB-VۛCqt9瑸^BhdYaENDE^튶 A%Iyk,P3 %XYȉ}q]YWf"z[vk'evibe_vMS;~&r v'I#&DƉS7ъ hISfU-azk(z0/#n>ߦ\'TiJDٺ)|dUJdnc;6$ S] s!yBROy"T>Hk+΂n!@ A2Jj桸L;`xI]v~ё5i"YݱڠkdW RF伇Lr4zvopx 4{uqgv tTT_J^ T?9x2/Tw3f`f[mxkk*PP?N74:'$2BY?&R ~ X{ZDQu"f5KQ3% ɝ?Zx<7Voi i'uq[}̔4;9!)J}!s@B,  zh j7e!PEˈ9$KoIEϔ-Yw>q(*$,k't1ҾK6M}_hh+@4ni7E.`=ƷC4KP<U<)%["H,|#qVL>PLzXB!e8|VIuNT߭v3 cn7Mi{$?>ӉfZa$(C[1б%Pw]6>ffCEb?-}&N& )M* vف]'؊ A_5:={ʣm{{z7]+kh ӆMY;n;pٮ_5"{oT{_G#u]m1V$QC5`װq Y0{FE5 O_<PE9W倫5Y5N ?cI$Hs65]!DDeA G;=1`ϔ 2;i?6zDgXc[+sdܯΐ8_vT"K,K^Yzot0ΛeS&nC gN f9$w"l262CKO>76(MGsCIs=gGΦx!&AQ#phM`?аXMsJR8',y4uʠ.ȕI'jb؋bOG^4_!C)L0]>ϵXFvb%.5>j]h/u LeXe5L=%ݱ;E6h'Xa5^G!Ny%D=RT'CgAxcĬXFbwC yլhuN/c62f| endstream endobj 620 0 obj <> stream xڽWMo6W!r1=mE")AXX[Jrw(ҎmDqf̼ 0@QA ~W4 %8!t8 %<MH1N (H)f_'c,L>OpYVUiy{Ѭj86+]N N106#g% l}ܦR7"lq$ "do<(/1>fUmQI Az Bg_iNȾ=np,Kו}JmaJuos^mNyB7[ ̋^)vwtN>Egd$&#!]W(Oj/[3xP1g4Fr`s>J۵Z3q| 8Jb‚ǀ+K`إep|0bX#;~PıXVq.K*˪rmqZ:+\fxصϞyC=y wmes{dJh JN|&:#ʬ{[ HQ]ɵ)$x~Tq8liMczRZQxwssI) D륛23Lxs..v .b\Rhnm]ڧ7NK +@c({ 2G$FgN0~v%nߧÍh-.iXQL̴c=0;L'&fH$d/|7~>x|5OUzP cuQmŘ*l/:)wѕc0C~MVkcuq=ϵ(bҹ[}꺃˕> yczL:HkmpY|1ڇI ~R|vP8L[jHwO{P!E2:'0Ӂ"7M%0/alu]+}pw= ad󧢼_W0"侘{],^se1YB+B7!;F~26{D,`J|4 q¿s"oy(TyNpj3KDXFhw#,t7Za6H ՛Nm0U^֜i}z;] /×H\n<^p([#qv<(@8t{&~ihRwQߛOe endstream endobj 623 0 obj <> stream xڕX[s~#5"LN;$MܧYlyQH>N|X"evx@b˷эfWlv滻ןن,J;lDqlX;P ՄQ)e.(m.RM6ZfU}E6 }^so9͞/B1ǻJ#SB_mg` '%0af&3&vx3OMJ]^귁D.I(%BGo%ͼ! OJ - "̯tn!JF~hS#B@p&NukGdƙ馠Reqs<ӄ2V1u8K=iLC->%k4S5CR0Xc8ٮ?7{\>8V5,zlG*;d0hC8(֜0D>\CF}Ka8Ni%d@M)3۩8ֻ-=[R@._@nd We9WJ̯!KK"7CهobQ'xp)SiIm.ޞnRAV)WZA-~T߅Xy gz 8\=zΥڹs6sᘖ|v\NBO\?Rfw}OUݍeT#{ǖ~KEIcV r+ Jv:ux !$RS[a.jܘ/FJL;7֯+ΨPpLf- \ ,t#Ԙw3Vm v̳;cx?8_F rZ@Z7N΋ O ɡA%Ɲ:ܭ`f /UI)Z޿HaN0V;5=U7HJ,ťc2$R%, t80*6Ģmlzpw P,(AI-^%3A_g^6Dd`5bV^^+ "Yy9w9x.x U g}5zolV8?q$jݹHGxNݥj6 wp`Kקnaʧ>ǣwyE>:Cw}2(t 7SR(Xh<; vŷ]9ElTt4=Pw^uqD>LS,U WJm9/^>4BlICg8#~ssClTdZEEIt$+&`0֯!ZFO4b.02#~ ;-Q߹"vܖbn2F(rpY+V2#3陽VY/b~i&V:5NKq?ftCS׈C썜7Wb+tI~qh(4*֌X~`L%0 z>Ds: ) ݃m2O J\:89Hώ,/ɫ .ǯ&JMW "F\e L'{{ˇy<(ʁݮQZd3]V.E<|6-}**Uz<0+i^%p*.U +.8#mV^rV `X"߰}1|mv*o$ <8a܇:t n. `;^մ6\aLiǀy藾jr046qV]}FeJ [X?b:xAг$FfޟIJℐL \u͂#?6~(kpѶoHXE} fR:C9M\wo@wļ%^$4եWG^I|u r1rE?_zvzqM2'7Q܊pe9ԼTI)*PE2879eˉu;a|S|O endstream endobj 626 0 obj <> stream xڭY[~ϯetH%VDy# ZlϜShD3iX J3VwO>Ht_|E9)Dz3aX+њ8:'qg/á=HR';v<ٞqt2TᔘgR"YFkXTR$es.,cmKeI7Iζ3(4;nBjV[IROM]KT1LI|[ѻjC}vv'hwl0f5aY80*ݮV7V$q%?>DVsm$Z_!aV_N>r<ɞuBa9ͮS!h5'GGs_tWmP7^9x/ uO6I$nAʹ!fҜ J KivQ!8%]O.g/rNf3׫g3 T!ڴ_^M[xQF?^+|Mȅ 0S^w4r-f@&bg\۸5 mڑу?}ጁOsS~< UIV8f n:_ ˚%w>bx1raŮ=uu9T1CL,ʼnBX̓󯷃MuXb#hǼsQZ+Ӛܯv1Y63CW*++WQ\\9=q񂏃k{g&ھͪQDO FW})gNz\»Y(oES6/ILN%[_R$Lb/7k{)s~٬aBĚid'Z1_,LQV}_dzY T*uiM򎆇U0 Vs8VP:pf³=u8#t ZkMN X͡ƻ#kÏ*;Ԏ9!B`xߑsӹNٲ >W1]E)f[vP(wtN |LQ9)הp= ŮI GM4)xf$ %)?mB)H-;nO <`"0)iO@" y8W/L9dX)X[:|X]'f,ݵi3=Z.9`An(-RN9*= MDf7Y &ھq t߇VZ>p93z`EҶ]j5!ǘ_ww~iʥh ;0t u-,aUa~]9t9:uV]S-q X$452WӲ5N;ת/Jio'ӵcչ9 "&AMͪ4 'twaɌٝv08٦bE|^^\C(6&8Nߗu; N(gҴ_P-)l}覣.._fw2V7cL0'rg/~a)aK &XzeZ63.AˏA8=w,+?3}!kL0~l]2T, >ùWal? ue88S $s-_9BCfp⅜wMNGQe/96Edz (<~7]) &)bG тZ>L>~^+=z;C;#Wqʦ,x{-> stream xڝYKW9hsć(qo35 `A~קEʒ.Qdz}UE/~,"?qqe-R1=mم>A>#(@B=cegr)+ ,cx2!=Vsj`G((]d,@O)W *rؗe%e}.NQ,|:jMDWZaYpC H9wcr:bd8Nr #jsKtnQx[$ 'Ic ɮB#lasʦd8"Nep؎)^WK(04A'6*8p7ɢN޿o!,S^)jҩ_of\G1@&w;8yv*j>W tۣӮ)jOn@զK%-M\jcfu 8@;cL Q#S]:(0,+xs=T' ?$m{:0vLkAZ?m5vX a'eToe&d[|o}2+\L!|ޯQ4ږ܏ )Z'VXܶumdF) &TKwfQK@x>0@$ă&8WE+/mޅ{9pR]UKGw 0B8ʈX!Чn=^S"r'pçdp=Uۋb*{N 672LH]p 1!CZ#`aZGh꽲n~:7w^nfv'rfA`/%X=.3`=CƟΈZО)<Jhw:QB JLQ2:: i鵎Z`mw(}ZuD%MH7k(>[%SP:;h&r%ϊJȩ:q%I_4l8ЪS\9.ι~rB%Eqnf}ؙ GqKBzH6G2dr ꪁJJ^v<|K管1e2''Hs%Hj=h!V+)/;^wfb~+TƦÕ{1LPQXIx4ٽ}p}@q.o'\4qCٗZ0G nLo/z>8Tw$^~77>%NhKuvtHSqR]+ ٵ~$P.O64jO3y\ *ǪKUk:/Zc%?T|#X*9&k+XZ~;<Ƹ 67-} `6çz_ }m*pISh ++7D/ԃ)S1ࢥ&:|>ڑi^BHcӏ_طxGiŏ_oFhH,J c2J3=٘5VW(gk@\cD怚4/cŲCUs7!tpH{dn"V-)V19bvOisSCf^uJN`N  64寧[iqJQ,eب7ř)=m=H27iv_l| X bیKK+V#ʌ >:} |x(_QAwj |}2:|K<۷ի'趜F'}5nTU(̵ΪsD> stream xڭWo6~_G X7=]2t tvATm9y?HRBM$O}1Q8hͣ7w$ʳGuU)ʙ/1Du{D(ARRxۮ8Ҹحx_m,4{kDV"E}sm bi%e9R8ǒ ~ JWk;ӍnbgjgOB\ _D2}³x"sɑܿ6FP\!wUKv..F9Y1@T2p!U yw'A,Mi'};3U]5v`=j S!kp6트 b>dYÁ%󖅃{0džzrL`[`ho&\\NJle 8ﰋR=n)/%8kێsP^)ƵTgH 9`"ˢ5@*@I"HGIJJdN|$aD8mfvI f j0ðM=_^.`t9aP7ŲO5dG|IQKlս4j6pE~cgW?3.((bĕ'9, /Pa՟HuF!,Jal;NMח;KzJlЏ@iQŔTILˤMIڠO]f'S:4EӺ^==[aBߩ'Wnj꧕=Krjp@&{U(SjïPwO!P5қMZF*.v^W\WB/3ŠEtU] "HI=$%"9(gw$aћ)|T{49]1ƇiVl-kۛw[rJ=U@t|i{$tRmdC݃knB7A9ȁ (uhc& S .ت cYS٬o sRsR> stream xڭWY6~[fx<%,& RK Ep%9p(هbh!梣# Q6Mr=QHԼ0y,?ݏZk\ c {eG;ٶ$u*ccոM*ewo OuQ}v/ȹNMH/gWV!E'*/9EP𼮆]*g]o'A_uY" ' z k~N6gI3qgm7/2=Q?H@uazd4R%VvcqPt\r>)۟][wvc޽“p%X6yQ3 ,D7Wn􊨏aT*ы`"~%o\@}0s.s&d\@%Lj^g I11.| J[G&Yʢ\pO%'ͫJ G Ėn%i]I5 ka1BqW \0ޡG75P5[- @R\ qYGזDQ0q \0kGFB+GHm?AJ7XLAM2$ F<2.) =5۰q!^rnAƷ1DMiWZdՌ zjφQ\>E sxk> !О)ŕtBhAɓ̄1 㡝* xm뚢y~yӃJ|h=kC)7hՓxK9b j*zlu4"y vi qlQs.$ϠaxK~5ȃ/ WGSwnpDbu {G$BB'kе{8E#.&xz9J3~> stream xڥXY4~WD<Ǝsr ZVB O,H'9f-?*)U_Ǽ~q}z"*xX8,D=V<?Yn}7 c_ ?okQOpCs=5j,, a -{u: z,̳œ~Vv!d ӓziva’yE`F%-J\"(MwK79^ZyUvhXw` 4 U}D0eVl(42 sp!A5LnPmJ5JWt[d5cRb{${9da;1@o@n7Y\!HGunW-aAqfhR#/Ii8NnI9 RΘIZ(Uvƴ4zd8Ojnm5r-qY"9-ϗOhLO$l&5[ Wokd,86ZޤSEL|1L=M9 ]\XZ/W]f՜Mt=љW39s4­)Uœ;%/pGIblybpYrF7^F8~S^%Hz87pirPJ])[:jiP?oF 7-"AH-uĬWbY$|ɛjƚKT-խr%#&mUt̤nd> s0!ll?_:{o8LE#Dti RIGuK^yximtyynRs384a:uf0j;3w^)4H`Wu%J?1 tebBd5ZsL1?5Dn:4hUϻ|&--U.E #Koo):|j`g"̓GǼ홲 ޽VrTnDgP endstream endobj 641 0 obj <> stream xڥXϯ4WDJLe%8 !=N,miM},3Ӥq7ߌOx?d{J}H^ YWm~{1Q\3# Ѝ2E^LF%'~|)ezS>MfL~3.'KHtY;ѯMd0^S뗮̗irdkWO/6΋PK5KdHPV{%+"y̥_;pRѩ\vh _ђ+V3^⃝wl2 VPAss:> 7v0SqQJh@WŔpkDHX xR0->ޏ2໕OtGxD V)\;ژ2;;93" yqFb6RX4F5U_ZJ;X>m+ŸC8Z]&_Ki?쐍pHy _sm`0@,v080__aF$.K cΎq6pi:t|}Пb>5F}}ے_FvO7@rVB%B>-9RZk/H;sZh_u+ |8l<-@9NQĹbZ@=d!e/~}q%Fښ2h |B *S fy1\BiMXuS:ܕvOFR2԰*+W⎩ ƕYz.A+B0]YSi{i)ɓy v=n+4rSez9;~efXc~DŪT3qӗ ڈgTU<5ػ$fl {6v;u#PHy,BHxH3{EH2J|;ZJ#a3fiV%K*x/gC y sZ=zN|iW6$<(^PiJ166{ø6LUp.*UO퉰i2TY`a3Ѿ"bM8!~T y}*˲DΔ(1lsI7-^^ۀI 5ydaօ|gxz }l>tK\,Uo.v g|,:uЋ ћ+ 26}϶kts2=; ՜s,bqV<^ qW784Pf,Gp\{VArkqM.lXpquya4yhbћ7ZgDd^᪮t@tWA58ٵJݫUdրMGh8@&;4D}6~f_ T5S-rQҩ@;3*ؒ[vYp%A ?i&7#>!z[B5>+)%RUHxhgs?p\ċ^{upU1q"n]m @E[m}k M3P4SN;b@>ߟ[`MH56I?Y"AIPBC++ւ4$m& */BiQGzѢ]:7rvxŐ8.W64`G +[φp _Iz9\bux =ùK9=߈m埦O|^B":@_6/CP'+ޥC?A붺SCLv9P4@r~F21^Pf!q H~_V endstream endobj 644 0 obj <> stream xڭ]BKlĈzO$W\,צjd'ɷpHY۽É8'_dǓ\,E3Vf%O /.Y~$B Fw?S)6;Z=jK՟SNEڞY|5S(ӢDRU+OT ?T=a&júgdO@Us'5W/beehPGyʂ29^d,:JÍdE"i])tk pC\Уk\g?nGCTG_@f4gJ#@ &ɯ\sc_Yھg֛5mN]@ Sixh*Jx)=a*I9YgGn2W93!F_w"" ǰLzDp"8UΫkZ!W::htۡ_ݰ2o# ܟwm)3 gXͪGzw&'DQSm.%!i@g%Egw8ЁzuLMP8 )KJN]axK-}.CZs8X4̌Zk:b~DhEb~½]s<{ W\dKib $#B2p"dؒ AgqHU.pd \T&dSA:S lm'o5d{*R\!50uEeJ٠Pbr(5Qi2xI9NݢQ u7RP1T3|GFYRP[7 Q ė3m(ar>0.$5U2e"cFH\?dnfRڵay{ބr^jJS\2+'0fPj/cyYj[5X̄]g"7_;$ލ9~r+(RK/!*E ӡ77% ">K_Qu~I2hRo.]~2Hy;T_谲#sw;PGE`^ʏ1S -2MxB"s`0%a WB,L`oU2/Wa=w锱7C0WȤqz;Ź$̗}aR yBMbagso$ =v|s/hƬv4Q(FfdB(Rg mإG;Z?XWvB'Ť7yk|U:X -OC* ,3XE+!)%D*/½@mͤ Jmh%0'B57e強&;\r xB:xʂ{az6˅`Q(妁J2 b6~)4&.G"½}`!8P4SA,cXl-xIo5ݵM@uX 78-_dvradoY.ֺsO;`=`_s嵁(7."3nq(e1^ѸILii`0~ך|X5d/^EMv k38xo\~Hvw!Ft ams|;7uq\{q6mȾAw]@77;KOaܬ/dfAHz>`􂆗9)0 4!2=0Exys[eҠZO`i36~0Tjw[:<M:':53]ýtw~'[iX$C>ke;_5u3Z"ˏO6=䉫S6қ?%|+"/ endstream endobj 647 0 obj <> stream xYo_!MO%JwOM[@rmZiO3Z^6A[(l@% {~3}hV"?\g__.j]2ZeZTw0asW:B'mwJw[|Lo[]? ζ4n+<8grQ 7oֹdb5ﯯpuk68n~^>*ըﯳO uEyIK%i:۟6XMh]gm1UIFK*h =f=< F߶^=)kyW]woHTT2!LaC0E*E:1׌/ شm:^3 vv4$~P25#%)$V sNα6pLm@ع2]L2GXJ@uV]Wo+J5_~[r3zQpXy_he#a-gjr*D;#u$SDi!duΪ-2qU A:p-)Hlp"0ḷ'<-xvn3%eSvN 6(E6{JQZ\"d. dnC!_QpqJ$`.:;x{wzL“@7L;,UZх&Ofn!!_Kl)I K bW:EBA(@܈|L=+;BEJނuAf2rjuMA&^;ry)ZOMQxa?ۖl) ꢐSR=xMHw[Pݵ5)|h]~ؚu3fk zD#b\rnHɱ؇άvqSP16 i?}8Tcb[0iPA`ک9=uoGӈ (ǡÇt-/[E#Jط'qm3~f[**:_( 1'$6Ot$!;b'\da-,4n>=epgg-tGD {'|Q _F7.j|8Z9-$@l-*Ϡ 2n{=|=v{z?q gۻp eºZ)C{W"ljU<0/8 B 1ٴzp=8~xR C`bi)B3;B@WY?x*@tpQO@\]1ۧ-qպbJPg?XQh#j;8 ӎ]܀~f =.GNc,[ Ld1`!`ǵa&%\XH 9y͢]d*ۿesDc3]<snXSsxG3\ЇCtݩDGUf@ebʸ9<*n~;%l,*fQA?ΏJDńi aJtq_%RNF8(L19$,/P:ՄE]&dܴfoIJNcD/1m3%E-*RQu +j5:fȺl56/x0AMd$,\Mf-N˧\ZηcbH!nDc^0l:מ=vkæ ki^Lϕ cmr0"9s.9dyhe&>`@[0_)o.Ds¥ <^`eP!nS^EDXD8'{{-Q8O8JH_d5ODwH'$p B(4gPScE0.)J˳l a47>a:,Hww MgZx98knֹ_!> stream xڽZKWʇPLIIu%vr@#U(Q&}8n4@pvfJy_ݘO+?qշoĊK٭x⒕X3\uJH5>}FJU{9rOz#l{9ZجnjJVp'.dִȳ~:]dkTeHBͤyVLɉ\r" ɶkEɸIQ6Ü~9yzs{C7mRAIJ>Âie'nvZs\y2xN(gƾGD>6S M@TX!\ Z7uۋs}ںs@s.BO+cFo*C>s ~͹mh#nofNc$T!%͎jgfxsf;ps0BGl.8n uU3:a;pYU|^K,gdt#w&L‹y$1x}񥉆i2r#43enf`%Õ_2XƜ֩5L?Gh8J,B1S`8̀M{Vg:W"{"ipںO3K0fa"Șesh|\@rH&!{Zph9@/aUIb / +"q`M%]B{7sΰu^)j 9U&m\bK71qo>M# M&x눷\J.@.᳊ȥz9OV1h27W#rJX硍(-E_aͺĢ:8ϳi'c*Z$rDkCVt"=fA&1 $͎(^S)W#AFJ. Bd ."Y'D8^!zq7<"}3"Ntó> M-DJ(=V} H!>v8 tJ~-xF>XͤزQJ)W} {w&dL,Ѩ4B ?ŏ>2G75H^ !2^J ~<w:@'*S Pe[ǍeZD^꺾~TK6BŒrY?րZO>t"44kq[d^**5 &l40nkiEQ!DeFMT5 @nK$5-$\O -H2/"H103S,vxiʵ 77Rc˶_($n-x.)~#HDmeFFi ØՒȣFaBkEjvKU h<^Bݼ=hC׮ ǽ[[/=y,gP+ E4jTO36@kiܑ6kM' N@iSQö{ij;5M]t5(RPoܧ :^%mXDpFV+\RO/#3z5 f 壚81_bct߄vK '=Qg4cdS3D%^2 ooâqs5*:r ^E=\?6m/+*ѯ0 m@^LηuŰ"O|60tGi*FcM|<)H2|QGC Ar'n8*LA\aTF$oV/9 endstream endobj 653 0 obj <> stream xYKW{%d{[$`Q%1HlTuuS丵l [d]Uq[ U}ZၯXyV3+&RCumNzN;2-=zݵk^$cOݚZI2- gr&ʁ2NîTaU:U'R$Ɠmׂ%#*d𪒿',hS5--Ew}3<_6"D^j#WHڦ~d}3<Pp!2tѝ׊%8ƮbI7h>4KO [ xkG?vیMV8gE:.S*J&dWv3:"yBx5*B3x&zgO9@5esehڽ%绸] p`U5 W؏=g3Tm-_F'+:zrĝJ7+nL.= x<}%W~C1XD@q@XgfS!VY߽RN~k{T2ɇfBXc@΃Q B|B%TxGT=ChdY~%tǭW#(Tp#0BcCIɮNҤog&g#XvELmہT;8±Gm"/.` 8Wh F~F~ERL!RsW pRd%ُϧA?v4p%0*|;^(c3꯸`i5DO:]^Ɖޭ0'6cS\JZG'>r NOvm: a PQ "9O&dS){ю))up-\d<|J3M=!]!-45ުjΎ :c@^-&e:XN )?wcx p.jTRE0F\U2q\5xJ%L,Tr̅V?jOѢ)_=iΧ:?58Ong& ftS^ꎣi{ԓo@ R.+CQ7'(ؖKW枫@Mr&a B׆v{crh9&|tQ.'Pd#J B~A28iv@/qaP4/.k7TWGљmݸ4, h^Pbew?RR{̶rY|gRW5Szjd]ka˯3L"5nn%M;7}K>c?7&8{t۹)K:\׶8߽}}1aqUhOq~s9ȣ݄ 09i\g g˙0Z}.#L_|qYA#mz񹻆(T'<'Llw |]⋜Z@jSSGe.2ç׸P72+L"4I$,1nrv> pꚆ5">RoM+/PAr~(f2 zrE\~ ~G\,{3u@"IӦaxfi2!JX21fDOodϧ@ Sˌݲ~2JHL;iJRR[L)@KR$ẓ~oGR~D! endstream endobj 656 0 obj <> stream xڵYy۸hc[&;4Eg[q hdz–IHYг"Dx|]ٗRY}3Zx8糛g3.YS$LHTi}o?RʨW4Ӈi*4/D"zKu!x2*gWvvD{rvݴ;NTGnMsVRR\,L`Ӯ#8W6mk"nAK3݊:RiOWމS$D rO၎mm2AōBiʞ~Yo^ G3EGh 갚9iopM8x#"xdKW}Y)ӉrG:cÄ|m]hyI>? e91(~hA'"z_I`Apw4UKjW%摢}:^&Y D´5E~/t=ȱѩRH*,h8ފ{ (ލ~YEs_oܖdE31!)2,vB+01yˆ>t :\hYlsRL 0VPي̎>hb{0w߅n%H(_1ӕ骻6D|La!J39ɩ''sqݞlfઠ0<#8zu%d*;~EKD"=hQ:b'(<9N}AZ 巵?t):p ?1!Ate[%H} a:#0{F(g`$>kN3׳RpHgCOL2ż7F?(Ur}B3PeRA֔т+:p3[Pbt JӐ7'N=!^VK}q:_'2=u--r!yŠ,9.BF'MHClTT֠tfLd680v$[P#k|D @"H3bPU&RRM8 wZPpL4Fp(P<ÖF@@ӹqi]P}+c"m''hs#+S0 ~L+Z 0T\EM3jBSwC5]B/pNeJ1np!@vF<Hڷ%mRQ׀9[)g )hk JcD$PuKSC3!,BPbRFh$Zܹ\0ccg{Q[yD4Ҿiav. ,<m1,Rzu/uLXuppkru.wP-|tS2S|07U~}fҜ4ZXZ`AWi!֙~i̔c< ?1GC;n%TH]4m_ ?<~sB'Pw#!k_bozP = 0@M%,N5)'cʬE{ٙGnS 'CMd:|3x> stream xY[o~ ΍3>eC-R(PX~)*f-Zv{Jv7F6|;O H/"-YH8A*QxqY`)&7CfSJ#~cue jmPWK">n%I͟ sRLy#*E>[2Eo2}ћ{wWK{PMYk1PTy"5YN~oo m[x[_%EDP*fSW-Uoc| n]l{(X/Jlݶz]詿>sy=q4Ѧ"x`jڹӎrce_hYWTԽ싸؏O}bBtLز9ʪlN9@ K܅t5s*}LG"\>Pb)M1".frm/ƺ>.Pl[S۶ ٮSUܒ0Dq}`> (I[[ $i*!Ժ$*gTA\oks}vOY:r>pNt] #I_a篌NV3Kİ!]X"|G7)s%Q=d1)gH2|'↿9ǥ? b\DDuk\UiA4Hq̅pӟLFT@}Jz@nM}*cp% Ne\e;# lwI N 6!3_K|5 |$y!øivP7v!i/a]; ]2b9LW&sΧc>+A28OBdMg%őYKE5*#hR})G2[>,uA<H9_FiѶ3ZaDfUwfl-3s&1vB痥X5eD("f`>pÜۘRULkߖyٴ[D&6!Ia3g/0a6ޏx3AJw6pB_d3(FvI\pIt<]mޔ{-ڃ"׎hhM_ߣx9ԁ`}Q$qu0l=\<c({WYYC"M@6 fIJuK5J#sD7=1>3>oMLӐCFy&|Jy#< AK&!EBm$&6}oNdeĒDڬ1_d!))Jz7ğ f ytrªR{HCwK L).%EγʊcDthMqW'}OT2fp`gxevੵ)Pj ٶ)K<&p1Ri>e4- @bb!|/S0^´@+ (̐(!S67ǑR} #EPڳcm5|q CgHBdԇCgn/5TJ:f12OQ\WHZc0ʇ]$_ڙ?0B*rKxFpQ0$0"F[$Yitk :;cl'`rڛAF@ z{+gjD]ϑU q>P: ڱ8Oԃx2NAoAm,6MqM;46RlhȝӍ;*-T"J o~`o|Vؼ_es+vy2Gk7#u_ybAC t/t#>w~sG~?vcG:9f?#UJ~0>8hN߂*/r{AHMG9  Svej_܏:h-p?ʞ@0:Ұg-˒Eg.;ԕ#;m;~^9v4Ѥ*GrW I?,z{ endstream endobj 662 0 obj <> stream xY[oܺ~C-"FpsE"(̓VKǂFs9VZK7I؀(.9 ա Nut޾gIY84r('e4X|^a00[^\/<ιl6ޕmYp?d{+ܴݪbB1R߾å=FCDL"*Zuv($c>5z pэЭ6ߚ;DU7e "ݴ\yMU86V>*mj"!ŠL&K$z%XN35FmVnyj Ml5 $ߞЈ0gݬ1* cs~4D q4g8!XP%m2|`.C: tPL8!Z|p|| l̝ (i5= kJXEIH+dyvėN'Wx&=c2}M)  4R>V=kZ*T~UYf6,Tװ؟6>*rl7:wpLa [L䏈 X mYeK-Io̊nF 3L@MVU͊h_:{A)Xut(Dh!V/PqFB A PI_G1<1oD*XWGzoW.u~qzďbا6 xs![Ȏ"m!3JLJ9|WL,vxPʳ4k @1kuSv GS`ȇȪ1ΖWG8Ñ>R* B8Fɝ+#]G 1$'B5HisCU΢6z{ 7IURʇ|{&CVTsF>a~l(;<{7k3uD:O:  g|]y]ߞevE`rЄ49IpNr I9@2w|Qe/h ?)CYu'y4Q* *d2(N s*\}:#x1~ҡ0&o#.u`&HDhgxY{j9>IIdBDH|]mz2v?$[q3$E_Vi t52$̟aY{vWxפcw@Jc 95azN^w"IĢ*#ƜwW[OqQ U †EE n|19V3s:|iR 3k^/m]ߛ \XJmxUl;JfX2/ {-sԁp '?/@? U endstream endobj 665 0 obj <> stream xYI6ϯۨ*@r0pc.*VTT`~GRkS,Ē򽕻_vlGۥp}s=1J4lwsڱl2?FKg},ԛ},ͻWdWGӻ4ꚺ/=Ov)Fv5D $cx,rùhN|LC׺sqw;t.0Rý]>% EusKn␗#u4׻s<3 p)̧F~ fQ}swoZ~#$_QѺkcus4Gb7=CP0Zb`wmWDU£ӂ`oӶuSS[%eS?v/Io&ކ q;`q…&@dffkSeYhGNNs?(猡DIe$3;,D& Ȉ` ,B1U^MM5_ENjFTR̈ʸ@3{}_-ܢ6=A9%Ɓ]9z[H= x__DP¨/1(\6aҌdiOtW BX/"EQ=˱`Dwem cC[ע+ iBӹY;BD#Z+e\Q|ϻkQ䆰fccODjyGϤ^ i+='0` !0߱iMqAC φ'⨅ѤW~@t o6hy[:":xؔ =$6*R³!`To$.'"I}"gOox33wOA&˃źyqp 'ct)ژKcZX͂¤ߢXD]>`T4yT0.si:`h4Znv)쭊!Y?mփ{&yLK!jrZn|&!;^p v_甘%@Kl?S}bP9j 'cbhxM}ɾ=pamzI{ z^}ӾH{/H`-HNS;/'Z&&WL+*?ԫHlyBJڟ|(WOG,`Yō!W+W(au[>+FH7ܻI=?ٚ®_zzp3'LSh'A{l-NG.R`2wؔAyJP2FsCx>0̠6h*uU>.0OΆyb mMxr&i64$q%adxPt 3J!MliBWӟ>(?>gF?pVt4I .ٕzCUO*'i=ne[ν`Gp%.Y/[Gmfj&EVP0ehPuY9Ʈg+W@V++68MYp9uyjWDEgHNcn Jo3BVcd^|Pڦ³jB7?G 8#aZࡷސ!cUwJbmùt&sqv _{}g*ӸV]!./d endstream endobj 668 0 obj <> stream xXmo6_!Km bw>dm3tXӭI q)2%Ot؏QIl8hY{9#<$x{~F<(wpa"z˫OIIm}ܧ|i?0fSzf?}U}ΒFs"guc]E(ĬK ($_`%6/mP݉ZxBZ;t>HMGH &"uHȰV!Y$6l.< pFb"]H`^=NE"l AG4*Wc)[ҿ֗51k18ܘpWp0BMI Td4dW+W$ #ƹP;wV)-t岃[FHuXkr@Q;W&YT\ @Ḅߙb*Uަ:1#sg;hܛQLy}oYMP, V''l,ܾ+sE !By}J`,<{T:*Bs'?iQp#$@1 =|BNL)**Wi6 <UR؋kߦUR?. k@Y g^e9lw RJهoޝ7EYQEHg(Tm-Sş<W}\وaӸZUpfI4'}e;eJ$Tjc?"BsoLQ/QBTh&`6|AlXpbE8)oRT5 N'ӗԇ!DhBZx|Q %BGI%Q gtC%inR.zlc݋b-Vfh, w3 mX^F1mg\}%Pv_Ρ>JX=knrVUz)s.'q4޳W_ÙR[D;##s9T~uم b؀H0iOhk-ޭ3BɨӍ_w9d6tXwqY$rՕp璕5 ;\ sX:&lo;g0$.nRbMlz=(C/lks@i6n$fnɈuW#)*Qުʲ0]J/toCp")>@h V&44׮3 ٝf&3UDۉTKCAcɂeqȫ v2aov+L̈́+;a맛p>LJ$b㝹חޯ V endstream endobj 671 0 obj <> stream xZKs6W*5A&C't֞^lh 9DE\{?  (#=6%ow]E$C"EGW2t4" e*xB;^+m_]Άʙ?·pn*0Y;?'VPk 8pA&1Wnij:g(=Xk]hZE>!)L*;C(vg/ԨD" J 0ϜyU}k_z^X4ֵ F AL(Y` W qCv1|dcp9u?I!,4s&]x0"SXF`a "벺4^``+Vt9&(es|,QYRl ?&u''# @Y(N0 AA%?(ˌ b8Mg(ӥMjjC & mTs?ǔϩ Vp'HvhOl&cI1:P"?/uA&T-յ~R4ՇM.]=k+RI[jՕ0Jd/MwsN`1Qb2tbg A vRY/vjA>yp) D%"5No\ok })_[a从br)%{K7v~?H9&u[&1ŐI sQ6x?uՇۛ`Ewh ! HL:"hJU.@mSd_hPϯPkd/_K& qce`d=ՆRj1.tsd2Ke1]Pdi܂o($IP3ơt-yh lWEQn_IYAE }4-HCMaiʶrW;يs=F7m/$kݭ{D /[jOfic#v>ّzj0dVh7Ezކ!0bUs͑"ž`*D㉀ro9 z+>J@4s9X :}z]6Am%JQ`kupN0)0Nd&9Q<8!wR""J_^9 ''ĽrbwI"NJb/+zkTbC =ΆO{ĝl$l#lʆ#_T)o.D5L4L`?K u=ҩuڽane(A,Nai-6ߋ4{)8K`9=bi&i +~bx*R&e+-ő UP28.xbҌ-Pp9x4p|u ˮـF!8D N`QoAUJ!2T{ ǶNL4GLLa 3H>a :D̃6F\U ^ wKǡ4F=Dpwy#B{hW^^{ERh'w>bmV"URӌ< ̜c:z9[k#Q1a*d+mϗeqզ?Ҿ3`,Oߣƣ)fdӬ@3${m6(f^}=K~>\ endstream endobj 674 0 obj <> stream xڥZێ}WQ v([*{0IW֓&0{OΘ&ٖ[lQYҚ۝}}~BKzX8гa>Xۇe4 ^|whꬅ!RuEo-T6IDZqk7k}menP.pw;-}TYG!o VF5aU,]`)_3VxilEn_`'p89;7펵i h;Na7SjESc^?;!c_x$d\+$m՜sq(!?tb T@.pa:9Ԙ⧝K'vѹi12\ȫsn9Ҿ|P槀> }9 o c! Κ)(g̝;ѦBî;°_xud}+32@][7 df@ޠQey¶܂`U ?p ] {,"޺c wl/p*tܽELBMT;@n`HP/\WHL )p\!?&xs# %ؒs }ӀhB~ͱGOt!\}xg7&DRFH?Y$V4RbVYe$-uK,"~5i%*oL/Vڿ p$ۀB}UZnS բ$`s!_v 6<4,/Gt&qi^gXγ^,@s3}BB!ni>R1qMA =m1CHL[MxRKtZBt.KlNt0ܤE7C34}W0z'-~O ׎E(Jb_ E~"15cuT+`߃){B&s?w.srDkU~[qGB~VE|g_nڿRF_&%u'4bR[fݐD:c–G2L>\Ubo ^X=^_aK!ó AC."v'"+DMiH b#˝V$ ٽxCƐė`xzlE"1VF*Iacm*9Q[;$̤Sz,O,w`&=^ipbYrSkQ.g5Nh$qGT4K4 x(,(Zq7)#ۄGo~lUf1m֚$ 3W"Y6O n ҧe*1n?pgv[ pc7{iZV}!'m+㱿f >?S| &P M#Q[WNyECAl&OKr,ʴfVyм'ڦ2|y<`[4PYʌ-"K0hB@ Hp8R,Z ZHzC&ok*{WǕ^۫ߗwuÑ$,JkΡJ q?L/f-ԿQyni9G hBT7׾\7eد_ILϾF[# rčD@!,u ~oz xC_ Z/]NHWn30]5"V$ӵt,h5&sPi9PZZEA͇ՍJG\j' ?aV,ZB  0yQ5O ۀ\|qw4xy5sȼ4-R/ʜm$69ɮw;u|.= a}Ƶ]~!h8^ TJ0XX!~1HrSRuhbe˕(P ;ll[p{3:ZQ{~B d9cs*7_ \uo;۷:704LGY\3;|IfbKa(EWKbsNŜQBD7y{.t9 z!uZ5i endstream endobj 677 0 obj <> stream xڥXmo6_!`*CR^O]fk2`LBeɕ͖u;$$xsoO0/|:.G0JqJ#GBěϗٺ$&cu\a~V Կ( ?7d!(&&\ hP]DչB(4AZY HX7/Lh!sX0Oi[ud+m[ F5Aߩ7Um,fy.Z]H1ݲhu]T}/dzS<{M7YRQݵ$^XQC翖b1`g{wwOuz;%hz%sd%O5حΣQ. fk b9ʫD;s"n"̇B !敖:iAe=wAqRs WGH DIE Q5ƅ>40|]gU MOʘoUp[@Al' Sإ?ECPdE)Xe(?k̪ahz tQh},e]i!êحxYzx}E)|@|4D]!> stream xY[s6~L,mx av:L^-77~},ɗBg3Xssι~ yNv^Νg ;S/?N!OB } ԥNlЃ|35fIѳKI]lJIUS}v@G8qYN'.'U^ߧEX$ӫөՄ1FsCfE.65˜)]t6?;=@bAR! A mv6?W8d'ejNAV'Fȯi5K@/|L"B[i!HH0G,eyшpղ؝Y3 ^ФgR_mJܖrif̗2׃MŲD7e?lk' F(M~}t:zD3Ja֘Ó("bSc>R~Z$gYRVLޗKK-eF; 5Ry;(쪮7EqN/;V(]jfӱ^x mKv(z% )wJg޿;wvK=xwvz_̎j͝s0Թt0~1ug ΉA1Xu.@фkN$d/- p WWJ:^ ܪniJX/8"a,fKyaA:@ ݞ 7?B|OOAZJ"x([aW\ n`ܪ,lm-Nwe~ $B|6bRE3S6(CKLX!/<{@B6 2ZW-m8_p3L ۽:hLbʡH=Rǣbv0dɵ*hP"2. |7.jM GCeIU$rUs뭥rT[tG[ jTc#?5Gy%˦ a\˫3Ħ6/dJ[5Ui%oE\k=L`oAa}52Ά%DUychag > stream xڽYYoF~ sýI9@F_%J"J*I9ً )XpfvobI,_WIc)NLQʒjuf.o41ͺL0V7u 2욺T$|_ "ϋOW s$ي'!Tz$+X4-GE jEJC銺d9 Q=lt[[pbFP Mv>v4F1*k1!H$@,4f3D'#ƙebJz_)]p _7]^-(V8/囬ŅOs {4n_33.\-6UՍo}F $  |ޜMҔ8M},rʄ2wIn{# L  ֌ΝWQf.|ΨHR$R{^^Ț7Un ̭*/S[fV;L@ИM"m.baLCUv1u@S*ESCI"m5x͛^~Αd=;4Uk$j놑Ǻtn}2ܚnghH\«g /9tbϹ;888mΰ]٦mTi@ J$6S~aNM1 3:1~ƨ$ݱ5$l{2+8ff5;Uh4]pk}Jqۥ\]_pF `?D c\xj$?7aaC/'~Q?(@59aE|phl3FGh)&˓7{)bVIqC^ C"sÉLQy ԀxE)믶 ,0 ~7y;j՟<%F/ B\I2nYs0߆8P T+<ӂSn <\i{j2\UfpK  TFd~ ̀p?ڈ7u:?7ʈ[eQumQ(μEծ(|`.y*&POOv0ӘCx"Bk.ѧsQ:b4mçJĨڝFG_Tx7hR_ew&GcsFӅgVM侻 ?Gg- endstream endobj 686 0 obj <> stream xZ[۸~0Їh⾥M"L2ɃlcmmˑdR% 5,r)&)Z}*,?: ~w،n73Z('F]ƘqFkO<+k\?qfov-?4+y_Lg'ww%mKz,!Hw?4;upٿX؝/K>[PMC]"B^XޜSzD 2pbӦN ܕ\l]ñZ*Ѹ,e\Jr̈`oD@A4 l61W(" R-wIns+qt>RÅSXv !]P,}w0l%V SZ@VWմoeI`SC}UA?ya.r>%\79 ;`7yږ'dr{;T.wuָZ9(,8:]Uo^:KG{N]Շ$uވ"JZ%&'in 6ӄ2S+DA2Jr6*T-&i},8`Cul+ԗ l50/up<~,  @ w:LZPHӒ:C. ʞ"cT =vA0'.E.|BO'Dct߀ʪji6܈T$chR=.\H 'էsi'Զ֤`-'UAW8lx?ҫjA.Nvѹx#8:pH& <:>!`$W!`-8;ϖ-փF4o*pX7EƇɦw_8aDK_ޜwi]jS2x"4o@ pL̀]Jx3Kk[>^n3. iYAθ D(Ug\8OӓrX{ ϝ>qc67FA$@~ T0i'(7&7 z Ń{FQCĢ!Ύ-Ԁ{9#̣*G͉-"mg;bdhg6J4oVTMIZ6k]K"]t+"iJx9ܙ+*5M33iJ5>gЉyqd rp;0 ñRg*E&SlHdPq/MrMy1gQ?wak[vcdZ ЪzRR@7N"-c $,/~2L~ExKwB,ŤY(`J)9f[U4٫yag>ΩZiU3 `zxBWe{w-ۣP7ůghzXp;@4 Hй'_M ?.3|}/aߪ {hTJhY vNC&oяnkUvXci5GCe[cM/ a ilGu ){{Jg٬fkҽu_N˧enF2> stream xYMoFW!n$shhCZZY(R%)]ҒdN /1ofYz"GG1h4[&WlD#F)M#('HFenu=9|=ͰGY9VA[Wv༨LL~ *1k2&Ms[E3nvB 3nfun|174i M]6֦\T*ù#, MV;9%q8#rffzHmQ9>7Аp10x&KۛqV\*o< b}F(EMy[4&1r,i0B}f_"H e)J1U]_[4+ڒ$U̇, ,EXH{JR j`/ BHX*/Sh%hj 9q=*",41eCiAӄ~RJ޹parZ;z lжRC>kt`=9҈H9?X7MҶQfm @*uզvW]Ž-uW =J1JM?H u{ow5-H%UF /M;ܰHj7w/"d^;Mkbu&p?س/tf9 qՈA䖾Yf`Y~Su2b JbW,atlЀH$?DAbÕ*g[v-G?Sxg`l.zBaE߂a ‹O>0P#zHq'"TA~qLo8{1  /@8(Rc<_ b)#z8 hvNVv\c ;o|R~C|C&TAe/aYndӄI9,TNX@^˓DB3yBSCbⅈ# J},D勢.tw@I Pw)vinWU2x;բXюS:> stream xX[o6~߯ڇC*ٓ6C,lPADmy$~)JM6aE s󝻢?"aG"I?*zsB#ƚDWӈ0&cJ"(AŤ>|K}x[žy|Ww *f12^9oNb Z"麸WJ$L[:R{͵ODP\\؃ (wJ" K#1qB٬2!Tl !E3]/j\Ӣhpy p.xh̪_ge1 hP5i] xdͯ'Yb@Gj+cY*A2/P],Ǭ%{n%COaD٦堁א\ZA Λt.6(S0IcU>Nϯ_6pf=v/ZƆ-hGOgPI%.KN[uSV7DzW+/gz*ճ IVNhY@Li<-;xUKZ<yI#I!/iBڠJZSE 4R4)w>)O6;fY}gTpkϥ',źn7/ Iû n ,dPQF7$d. } أ '1-*ƐX]<+j=YsaŻ>ݚ7ẳ ۥa\lFM?/CgRIq1_泠QLT7_!I&'y DGH%(my.K7{Um({7۴=|G)Q4+ld+%dD7U*u -{0<0a bhZhS]u*@p-Ö?Q]@)Typx(GwfWà퀟.[m,L\0YK\:5" 0 w[g #񪲄p3Zblznz呵t{aTпZ|yഗ8 D K8$4?nsjcs@ *$/R1Av\+ߙj\KO问=T^L{"h)e4ItJ J naiP٤lOE& nh$]^粟*--f(ס k$58}fǩMu@eǥfWriJ  r;B;Ybb>r?&gc)^=̯YƉRnmg=:{1z=N_v@<iއ>׏crM(_G p&P +: GmS2\FR7 VX#?oB[^na#z74I_Y:x1N6gkNO@IazM-zW0Ky;xK7Ҭ1%(,MBeTV3(jlAtz-iv.!A+' vصίsYx߈CP endstream endobj 695 0 obj <> stream xY[o6~߯0 RԵV 􁱙X,y2ɡCXfs>~NGE$C"EGMYF g$:H2Fg޶^$X\$n].W_rAUUah|ZT *dz_"NLn+RV_cd!C)n)A .}X%r ^ F$M#1q!@C2n hJi *QXJ1r礄#9)EToLmW˗!ɀ(г޴]]6p=mݙ4ʐߔ_ӝxن$1%5DP2> Z:2ff\v]'chצܿS y&Lqބؕ oԮoof[f4*ǑjfxeऋDP_k h 9;GpuʼqL Nݮ? !"H֣eE"%9arg2}HyH89$$fxcIZG`=0済J`s\( hdW1zb}SH$}2{D _vzkfByDž\t(ϗ 4/[|P0@gNסcǯ+vC#i_re1Yq9<سAA*Ϗ-W$+Ls) q*GN1lӯϢBvX}/Hb[\_b02_Ih(r5"avu09P6Cre1%!9vs;O .ܮGq =R2aW V ~-iEۘrp6Io'027-̑ƺQa3F> TQ\ٹ.U @iܮ!w<|T !0Q`>wI`^ :06zg pJ%tpm lpv9Pw6F<iVJ'[]iM=.tRNZR;RN{<̭^qʼVfݥ:_ZkV&3~nLpV]?]C)è$QYbXg̔v8uIe5=Bi\uB >{mi@rڅVEbۄ 8"gxv[& T?+RS?-Lc&* &q^YN%Iɖωn- WpW+WVwB!G2뼮J۵ؠmeh\'QOr͇.~ 9GM8LdDe6 /8Exfm$ BΪ۳@7| endstream endobj 698 0 obj <> stream xYێ6}W^E*yqXd4-Ό`]:-㷊҄8ޅ%Q,x) P6?n6_7lssaf)Էf h-k|ͯ"77v躡Ƕ~nƽݰ͹v[ɍ QJ.Kbtf:|0LB?E fR㰒PBhVoL65,Hy䪻*|Za c6儳q+nGMo-xwU)#Z"t0=Mp Uu(UK)=m.[w[^dSs6];dž| R˫ɾY,nH3;~8tI?spX4Nd&LFIe"BǔqOy p]b4-ؼ Q\?oaS%پz1 ?AL325TiO9 na$e''\rM4xPvօ?r Nkv\9P^.hhm21HFttdr/ RAXq6[ _=3nm6IE8/YCs@po/ӊw/)4?3;X/d*W=ytK*vǩm zTw},sE$`/ڣ)AO vς#L/ i8F?L^bH{OjNb-/J aEd[u15r p/g.{iuz%2\OkMi '9kp4#^W68iIo܎li5ǾE Dcb\iݮWNxXjzI*\)o; U MAI73ҰJUˊe%e8)A+)S=vєWX'UgUW2M K&;^Sׁ F #w4]uwg՘q32>c ;)OrF?,CK"ro8ll a$#I t/ 'RޝS 1$ OU).b$F^$z@pEx{F9z> ad(  HܢWb W!1od@5)|aiU)y&AX*Ӌ̂^ٚ 7uNL&uu z$G͖Q ˯ CԕxXOPkԐ&gbOԳowqS^/GwU^0[wh$y&4BjI)?ij.|?h )ۮB^Rv< `99:%1Qr=L +px-d2VX@e> stream xZo_A( ~L 7ݥEܻD[(R&)')wfw$dmEZ-wg7U 46uO,IMI*z9|v],PY,ỬpDY6_îK`Oe`*[ $ǰ7XG"J9<$ByKpUWmϫUla_󛈊*_6y?Mδ`?$Ge,!"7+uQ=vD/`&FncwzZHܷJ{*"JAiJbR[> @_p 24@K -I{ {Togt6 JEkο}[-P NrW߮':UXġ1T9]}p 2=njĬߦ~w~PېI_#a8eW[ ʙEYBҰ..Nvo;p8:XYfV1eXe&J%[,V|K W,Δͺ}fpCG4+ͼИ)§.d]P_>'T^1Qg Nomnc`}CYisV8v* bOq|׃Og-} FD[oT%a/㾰jz|q yvcA8zA}_6UXZuƞOKw&Kބm’ |{h1`׉'faq#SG;f]! `, - .!%(Izi]ۼ2$Mshw.Ϙ_i6ͦr OIX70yc#!2JN<ˆ^`9n:%4' Q{.%⫩yK|[*AXFDu }t4nwE7#>|U?T?{d^iNFH#\L  K(03RQ^Tfb+48 VMns3q/ac}lc5Km%OmI21 bWi 6M²GHpȀ4j<inyV,:2i^ i~āΒ/lXVV BpDRkD=F#MI6C֬;^%R9Kp1tc8-/ʒ$qryDôT-` 5& 58o|غU-:4&Br6xKySr]t5ki޹;]q1OL*-;ld}S;yVYXkTd[˭1{TZqB*31`x8UWo +2\[. ~| mTðqS+Z3^l9/0ZX[:N9xEqiסDuO--#d$^kؾ9M Krn)ǐU;M. 5&4oW(7>e8dʥ5$a\LI!¾M%X닫ku8| $)c#af >dG rḥyhdH*w 3˷\\>7c Lm<#N)HL>KX57U(z t/nV`*_ q,a|R®qmP@=6@䏹M4e[(1޷+ahNg5pH,%;D>~֥s}= wC[5ƚ/".PB&ց!tysN}4Ɣ:'(ĔR1JAe"Rͽ6Q+;$k :+~8pjh~l]cUك)&=_K>J#pЇY~UlDL~GJٻPC~Z$5XoܳN٩pǦ=*1n+"A(29Uzj&!rk * 5dTz!?d)5s>T\+$%rmȵ~j?M)uvo"cP9psMKpĒNj>TtO5ASWzJ%r|VHj NgV w1C$AF2̓蜆mDEu?r.Lz59=^ ;Ý4투Bkטg4=צz4NG#L=xr؋5+ %7|ԌgQPN:ZyljRv˙#aÑNp` "؛Aۙn\;sx< It}(?8jsլll-JHD:dܮz;m[1ό׮O>B$XXE0]5w$^SF2i> stream xYYs~ϯP.$4d'+ξD ,3<$%g} Mj!ٓJUA_ ~]?ն^}sXqૻ+.BlϻIK؍ۇu,L; uXE-]BGcmȣQ-UDsxEԴnWDBƸ[]6P*>h%ByGOPvww4KlvNt!(A5`  @$a0۵Ȣ@h-.5(dw>Y hɋbe]3}#a\ڭ+  Z/O"UbR8h0qۡ2[?|/OTÐro8`:y1\[3WX1XB *} ocCe°U^HY:W npF|dY !)OБ]u0.FNyXa@8񁴪y>96`VM?f878@!Um1M|{vL"| p̟+ A8Θ_ѽ=tT/Y"!NpOfzn>78Ƈ,KF~1fה._RzwuM h]{dž>-݌P:Keiٳ9?%6tڬ3Ra gc}^YZG^֏*hnKgS6֓۱3TP^< Ohz2nХR3vK "85u^5d1&\oOΊ  X7v1~/f۵DRcv1ˍUȿ6f|4}p;p^cwǚm59J@t4-hxۋLEm}I/|Zj͔Eo*xQ @. ;gR `)nCP.36QJ)`b(\!+⯠ H~נv)&8r{8no7Eb=QBۻT;,7j-ٻG薊G]p5 kƭk UE0tUG3"T>ƵV4|(?g,az]PPr#E8n0?ufzo^m.Bxc/x 17 .CMEb4猂dz%8ghXCeSeƇl?uGOۥ->NyK_<˩\( WX?֖[ endstream endobj 707 0 obj <> stream xZ[۸~0PA/nhQtv8YJL3E"x;jRWZt=~Y}Axʴ䫛/V\RGۯ7R${(`JL[ѫ]:|hȓǛ_Wg,5j&ڨ\5-k{;u"9zlւR1]KSp.@0;5xn."EwckVo6:g_21UUuךnM ~nKOv8z㏹NzrXY7ziE8vQ$5A$ h{} *b~ #[or&hJ>2vPWtAո<I9ʾ“sI2jsAW``6fB%o˜qsgqNd]G84/1:Zj6]9g*S~~7;ejj0 bT~vJUU[VybP7O]̮n:N p,n\d Kp:Ӝ>& W6,(S3yfi͙36f LEjD/AFCc2;֎O{:aJk1)<ӑcε`>ybѫD= ሄ {a zNbZz~-L#\2"E(ŤEcۼȋIdv%oWCxӀ%`\ɢQ`2 xr^X@OOgs8%V%SZ/:Gg/݀gϹw"O;خco*j{[YV4ô4 ֌~Ф&13Q(O#Q :%hO!hWxphLf oq>A{wgoabaeThsk;8maG K9vkQRJ6ac0Z -(Y='ƽ*svn@Pćbqq[&53w 8FຆH=˓X?BF<{ ")zy'UU. F4iᄿA#-:e\yI31-[fZA#čm*rq0>=5=\c"X!|e>WW7QbNau}0ZN Pmkx9.KTq(xu[{T)ln2P&S qrHBaClWJ=Hy39!htqzJ.爽@}:&4W VfJބ[ey 2e!bK. CkXEphL_tjTeE dsn,fX™3U(UX*~hng~gqN7QT>Ӣ: VY>T'GU5\=Z'6WtoŸ{D#x#10 ǔ~]Cs1KȒKBxӒahL0)<֫ޅu (r+ǜ/߻Ѿ.)[KTa Y 6s$< / ex´Ù,ΨPE=||JtH6Ʀe bTEoHGi(#gy9 WXJ5+.oߓ=Ast*_t֣K4^9f_XL!p dN&a]SB>1T)O>/@m\|/˺}f!; ;`c_o͖<! % x`S ]ebZ).n7]#4"跘֛ `Ν.`V#"L_1+FG̘MDc\aR [/d~['Z+* ޫxۜ\[7jbAXK>CZoQJH bw:{4*J@=L啹z % S?/<.h^H,6Z`,NrUgȓLuBdx ,OB":!C-jjKBXΖFD/:\6߉,mӗ!?ݬv endstream endobj 710 0 obj <> stream xڽX[o6~߯*+ti_֡+64K\MdQwx,*tEl\?~8)8Xg$1g(gYp %׿DiJR,~}Y"Y5 _]c>}. I^K}NUG8KP b90Ӻ-æ; F< ]#eQ׋8b!Hs- ~2xX*-0YVZY=6;Z2|ڽKYGގS3ywB3=55îo,Vhգ mҚx~jP[i}[P8v2G(mh(%L.#.mffy(&fM;^}#xrNASB ]-]*51c5-n;wcg 4¨<5T-{ ^lCPlt Aq2PLyhr]Z3'C;3 Gx؋aL.jD0~ް%G](@R ޮTQIxFIi:? , uɄM\t=Hs=9i0PꎍUu6!t^B¢3ύG+vS$džbljBi!Nm8;n;.\'r7y%Nb᭦ #F}o4T~ÜPb&Mӽ|㴅qd_0,JJ;pj]W+l4O;eUuoόs 끶EՈ֦~5N*eXaJIڎ]{kio0ZB Ulgs1}1?/' ڙ͈6+#DkYM&9{sjMY~&ϷWvit>6;3<l^k1Yoސ q|}Uc  > stream xYK6W(+F|MC/EE/6wWm9I_dSL|30ه g%$̖[R.*iջCM((9(c ˫ʿzlD}۬߮39Tn+PV_VU "*F 3#Z\|m+.}ze]/a}4ѱeV` S¦IH F`M#a]8b UÞ/)C4Xzl?6h!Zޥ9Dݤ$1 DIoHPr../RZ8RD:Œ_Yp/5!9~bzXLsfB!Yv:Cq1C"fOZ*"NX)@dZ:><&?كb(&S w0e$']'i#L! { Sovl: Mj7ݫW)߲OE*%uyskd#!bࠔJ99v6T4' !m-G E`$Kpe8,:I hƇ{2mz`̨zJ9RL ߸/Ig,Gf2/C2COpI'Y}k)gϯgH5nLk„Ԁ7[&t6bmwt[CRJHͲ hbH2OϷ}9ϫnhzɈ1#",^+љuMc=$jO#Ʃzs}]ҫ "sTl`S͝*-} 2մ77)`P%@̀Um^6K \@bql7^Ag>썟sa\^(U^dkpnT&<on\|?1xD:>PKlwC*pJ#Vh !MdVNá#Fr=>1!,'96ds!u>87Ioqk2wprF.кgֿj%Dm#:=#u)1k t~DÓ.Y2mxrfdABadV 6۫XbKۗpjB2uU9Z %57 o}YԁCu6se՛ڎEE ) P'R4N'ErŞ5|Z`I$ }fs47ٛ D!XF&E̥;CG0Aq E= Oܷv_׎@:@U5w&$obFi*x}g#mULC)c1A!fSt*$:CaTt:4 D3zGo9l?%?Hk=y endstream endobj 716 0 obj <> stream xYYoF~ϯ avہ@ΐ1;CI,!X fYU]WC 767/Ec9/\\ey.Rޟ)XJw>{aє[Z|mkX}ޮ"jV" Cuij"+ë6+mIƵ|}ay91ƘO{,)D&V%+{dH,E\3&t2UdV+bw,CW=\ܒ ;)x-%O-'@^kuݔ=-G .ֻ^hg%y]t^"agֱ(ݫH&I'!уꁞKy$S^W/)їIBaaO!bi]6`D}K϶asT=Lv e20|4ALj g{lΒ~z]YuOQϓ_z{ݎ#v$b/͐AȄ7,)w\XG1~µI'4,oiD!]V$w>ӻfzS>I¸pum%$OL)ZYg"$(UKW>J$'*W?,SrRNCIX_+cBX= ޴mԕ,OEۍ, YC$>eZ%r* z$z<w][UZ \D ›ze)fg} ~֜/\COcUL ,so؝*zAyHC,Xv݀1𤷮@䮪!P+ode,N\4)v)nRZ+RlvDz J7VEc"pƥ+*z*1Fi>{j{ 0>H-brLlk3ghbF75z)`Xtվ%Vu9 LY.=f3%f<\u_}8:hHv3fp t& 7d[iT%͋H ZB_awɝ8Q%\Dapb4;O(\޽<6Ŀ<n0Ĭ LeQuY9.vY!-1B(:Y,FcTD$BҙF -Z#W%J. hP?z@Ae9mH|SImqgԗ;-U)2_}l\~/80m~@1@fZ6J!IY {`P_V>;N<37sfVޜ4p}ݔ%1vחŨB 2j3@; Rʫ X'7^HN< Q1{T.քtM+{:U BZo#Ӻó ,6˜غ: Q;@$E^NP!dA\y>Ghkt2A}zFW9\[{߆AOfAIE'p߄O{f"]2AsJH@6%Ĵf6QuV!T0*;.ԕ.|G!XS>jxs18æm壙@9sbO|*}xziD9b"(wg8Coí7vvO9'5O\ݯM3@pbxTmH]v飬MGj.]n" vc{e#"LOwlC{-.+fZ.,ۚ8NE{2B% Ơӧ-eMʅKoڻN endstream endobj 719 0 obj <> stream xڽYYD~W^AIA<,BĈ>x!폧rlO'EJnWUu~}p?IhSE?D]'(K2E80EK]UXQJc~X1wyk zkD}۔@Y?.>1̑dkrCkQ HւW~׊e(}M[WlnϨپomr* K'~ӪWIp\G>yUl y[䷥rF"8cx[ۢBra#maIm*hBI>k*$$S̡U,~tA@)^=PB>d6IQ>a/O$_>@)FN(,dEmMU- EJkQPO b#AMVƏ]t IY6}S gWM(h8:qYFKs᳥.V/[IZ5Xx Mܔ=vB";,A8I/P$c T8ƅzIǢ9vʒ*0acd0l恍y!0u*<̼[vA2|7`osӴk ET,xfޤ`  &1o%?%j!N= p]CJ9ڊa/ ]+D-UU^'"dKMMSASgbn`Zڒ|ϝɐ|ԍ}( 9t.mGM?ruz2$Ir~5nbrfzڨN5Gݻe⾆r<مO'u*>T;+&$+._ԫV2wٲ릶OTvu6Ul!qƞ,Pjh&]i$ܖVvhckw-C='?a9 ЩCiE<:x Da}Pj8my}tUU8l *M\ZtݜԻLiHPlr*j;^JY $f12<,ìڹ9 p\8<*'kTß)X"b1T9wO(<< Ӧ _5͋DLOS5 ) 4Q[eoH^ΦcTo2{@[NFm)"3{ :ɝΙL(a [7r9 x#|vfm2g;0\5ԇSӧEs̺,T4*`t8NLWVC8_c?k7&Y}`h>yOuch{Alh]aƠx,_^]><͑ `U>{jTzKc+e*G0UfXPk%.ъ`Y8=avYCr}NL||}MM9OtH}NkW&&0ڮa ʇvziB[&XOVrq z@$G" ,AZ'o GĄczH񽟦$qnl믆RUWcanDG8{ IkpC,f O|⚇%ԙx˔4nm0DaG-}]saL|k*-tM/-0r& endstream endobj 722 0 obj <> stream xXo6_=MjߔR![ӢV,lɕ".%K.ݤC!HHD?m,zF$"D'lyS&'fEQW)c,Ϊ|v~ۺ}^;y=$ۢPwFԋ%Ňqg]KHwvo:;vuS ee?}!F6I$˜#)D~Q[vU79 |(Aq$hz&Loٺouv-oޗfMr>MbD1ad[quDz)<ۜPe2S4e5p@qV?dؽ\̅ yXMkv,\UZmH:Kn6[Vb r 6m7BzTIkLYg] @7i  Ac Y( .I5 IJ@(NĢl9-LB((3N5`tIJhYWwvp u|`6<{6 K݈-rcmve??@j*Z7i?b]=2;tbmmr0p5K_X(ޡ)%?٤@AJ-q=O}bՀ!=,Q h1#*ac%T"Fo~0`~_T]'a''QGLǑ̏~+P _9 ma}50%|`m.tfv }0dȡ-j9S˂h(ߝde/kHr&'c;DˤwFS8uS]}N#⣏#^/;Ћ:>P8 (JiPW(=z}GzqR)8RYv]Z9&ȻcUk<3V9Ldה۬ьU(䂴Blhj_dU c(~mH%b`8m^7pmQ ##S?'L[FA*pGqiSXtsD9uղc4.̕!a Rtʙwm)  s;{̿D޷-5^ipU}SGsڣmkʩBJn72U*>Qzև¬ pf72I;[ UfUJܢY &Y |zOԏJX ;;"{S+pBF '|rwq{rqD!a+ #F*yue]Ȼ95!dPPt_v1h\j"}0 sDP6XC.[Vt--9@$eyvvsҼRY >P||+Yc7WMP}m %}w`SdRU/~Un6]%<90ϭ(gbJx>Kc _a=+8Y\6-AyM3|P+dzmL+D a{\j_rLr endstream endobj 725 0 obj <> stream xڽXKs6Wpz)X#9%3Nm&) %*$e[] !yLo.D4JG_-Y-hBl<"fwL9|1 !_TLnԻ ⮩+U=ai|345Tg `2ީHɩMB\*?LmW?+jg)aHP o F~@Sۥޣnl ѮKmyjIT LLܹjTUv!%*{a3 USC*dXmT}z"%TWFBs`Ucp!4ZT8vsp2] VݒT<~Ip#֝mJG5ay|:!=eXR4MY(dWwzo^i7}YoNueCIk\@;Hhwta\C€q.ۄxMSNx*0tcuRटZ/4a0,$](e.Yցvn7N QjBiZ7u2$ KسHqբܭ  ijbȘBHoh[V-!yr$FWև.Rf [(mm :#CPR:L{`:(  m`|ǽB/\HjCW9h@$rH|d^Vm^||A$4]%d&W!4]jk.n;H&eq66\߉X<.RU=BX ?;־(17.a1=mU|fh)μ‰.7[csGlD6^#ɼ,ޠ7 m`{#ǽא#/`,EAc鈔'p"¸$1~~3 PaI$c.:1@x,bQ ` 'a0JyH(?#F9Vϒ˞,D~p̋-}4!,B~dq+%L'sszr! fJ|07RCtO%G\*Nޓ4D~2\7k 7bJd|5PjCėX\n r2|x*\*8Ձ+CUz@tx F3A";U(2 i.cciϫ{ӈ9_ q*&6!AEaۋ1MK$Xe$y+폆՟.JЉgcߠ}L!o$]pm9e29'gŏO/ݧL`O vw#ة6g%Ԧ?lh?/|0=sDw ǼEbE endstream endobj 728 0 obj <> stream xڽY[sF~୨cm KҦq&c/Z[L(| EQZchwn9_`#AL:2x'$ C *Ln.((>03´\ojJ=Ǽػoٜ0ۮU9q/n9O$ܮUߙ -Yj^tPI"ƌ2]+7k1S'byZ/fU3 G.W&fmUqrIqN#(d*f[j;`Jy%(V݂_D_$hnNymGQf --`Z{v[>1=`8̲mݜZ/)CU4bqڅzy !!"$1@GU|~IjhiܪVKMl)QPHp1V5Yoڼ*4(fz/ހ5doǦMEެZ dE7:_"0a0GaDUǬҎLpwi۫5%g2MG6؄ژ4'J$z %p-pe~PF4#/:OyƤ!EMG /. \ *.%jۺoD\4UK՝*+{wSW}TFj7m`)<77 gi(r^k-^`tfyi&8h.bT״Or0W$#wNYa:eipV[0]cP9#Þ^rG*]Vƒ1+5.ў&)JTrDNQXy!P(JJOݢڿ*3Lysu%}۶c }s|[U* H2.L;A0.u"b9pE:bî4\d@U1! `91܇14a8M6dǦtxblDK`CCNShT6H457 P~k gtJk}8q^'gӎE:x +Mh=x ԁaݚ8 (ɧ>>@vO/ɞI!W,7Uij3>1PW e^fMTR3;Ao^_kMByxFz}1ֻ[,/YPg{9ZPv!tu# ,H? -m!CEd'xS[mY4[AGXǺqa to~ZXAXB]^('S m)Pʞ߾.WC{UmTטoGҠ|=t]Ktes"Mz|BB)&B8T!; = ;f[Kbw22!v1Q J KVGWﺭ~OIo.{ʶ2߶Rz>ھdMDDaCf3XՅ=KܝZxjL%ZʻM@DDst_@0?p]&/Reۦ9KށSsۥ Nbfw:*''DhZޥ{W>!>58}}Ï?C+\ endstream endobj 731 0 obj <> stream xڽZ[6~_@̊7QL4vآM$d{CҒ-yp|%4#:4$H('Z|MXrSnB?}igDZkcS/J ~5 On*Imd\>Ke$TBt]gFrJ 2ڠ`L5Q%is; A\hU=n]#n(X9(bpc;8a6k<Κb *51E(Wp%~mcO}BŒjuhq%XwꛋPF} pTk.I"K/Ve {Ek63x%$(r"~0ݪ߽O< 1WeGl'ݡIq/_A,=tѴ3nbmK{6lJZ7rU090*nckB%Qz!&(HF;Ȕ`8+n*OPh=M̅c2ͨpT䃸$bܼƂk O?ᾖ3Gpɮ}gN[|dZțܺujͦi#jH^#[ڗ1; .4D3km @CCuvzdy0#BhUD28 +7weG +۠ XR8c>m=5:fY0,DR& bQC(\RМe̊ AH'AF`8q!!v7kGδV"זݱ˽81chouMJ|& ld(|dD8V*vJKîZRWB7_zر3:ˋ! f<1øz 8M8`E6f ,]B ŝ3bf+EÂd )m#m"mBqptcVHe!UU>c@\dBBA,[KY,)IXFº:"CگgyCaby hڹz- MgL_נis)HڸdFDK 9 wp@`SoXFXqc0%3ɔPy!-FϪ3]t|t9QW2 >{`ln>E1Vǔi TZ,G<>;5gK_(pNʰ;#ɕ%z`%*SRjI Aћ6Nv5st=eMgߞUY.D]U v[.nq+:̽V^,t]e!vtT]ޢR;.Bx'MOA"Gp1k#M9T|>SQTqsa$Cĉc~v}sďU#aSmɛ$^*\V$N.aT6>Vttʒ5Zl}`[ ?<'K"^* m a\uN~r'˸| G EѨDSф`u)l5欶+WG;\#FŌ[Y׽֌7Z~x'oO C/L㊠ ȶV^+r|4QۙQʏM 6{ٖT83½ kG>g} }Lt|My]gPs`JAnBK${ő֒aF q=ሕ;B#87;34C탉a#{m*/*lMs֔-0 wFH}uTQܵk ={*8DzrFvvJ+Тm*%W%bXN"Nop#4&=Trx -ZI}r5`v'CEI\F=yP=7TF#$W\;ėsѭV/`0uM |%$}E`zmHG5ɓ}[彙BC8BJ&v> _2 w)KY4/!| endstream endobj 734 0 obj <> stream xY[oD~WX<1BHZ]'16?3׵q @B~2.Ip" ͒>"%Ip,uU)ʙJ.v)aO IIkjM)Mfg?fߵ}5K_U~߮DlVDKe [^{)k#ueW~jDRCx6Lisǘs2wRb"(E8a*La(whV?:\WwḦX %$qlXnm{Vvp4~\-` hEWa讟 l&6 a!\E]!<P1;SlOMUW+Ǥp$ԭvAD{n!57h5o Ż lwj/oMveTb[eKy-cvDT_S WxP+ZsƦ1DLuϑ@C9FrDa7`!<|)VF:lvbh791" [`sW!ЎF̪y ^ g"Yc:#q_G}}2Ƌef`D݋3>nL/ ^N}[yc}Ef>=U?&V`)~Uj`[6# cO*| ]׶xaȸֶ`´DVkXL!o+ )Oc"[|{}luT؉>_VX'>L{+.\GM+2ʙnk4/M1 'բ:|=SăSZs39iv]0]?NJTlaQJʳY8!sa9^L5]rآYQ5K'P?9䎮S&VqGUZi=1L ڟیh{e$Q3]WaZ u%`g _b?_:x [t8ttB 38/[ >,ݛiDPχ3nt| "lӢRљ 35S[Ěg:_9h}ywjz(}lv% ̺ SJJ-){ȅ!G})r0aejS;vr*  A=1^ J*d7CHNyL IaG6NW U1hSY*j?qN*; D+Fڤ;3(C{̀P|2]=3@#)AJ11J K?meQ0؆kb<0;Q`W,4QCTqSF= 8b<1GTQ<^@ :ԣu20Sщ~WAfMt& wWqGlFY>|m3V4ʪ>طO*A&N͵]"rPөP*g\>C×DL4R#·"JDXY+r9􏺶1%FOmgC;=rۣ,9+FBMUgsS6Q9FU;YU;p5e'hKS 4h1X^ioi5U`7IY;_bA lcFwGu dvYA>SzgǔޚbJ\yd& 8dNo#Ae*jE:AiCrĹCh: DOjKgp(RCaS۷nY2g`5f< lizu95eiL}X\/F/ζu֥D$ƿٳU=:Іxm{1Ha 5zP`\v_؀ɝ/u'H'}s2($6Eg޺b endstream endobj 737 0 obj <> stream xڵWmF_o8^^J *io.~ Iξ8qz<3nbAB_lU pd,q8 0E*eNRE _f]wXչ}$ ) _͂vq[0G&[$ gCd8"&Q}+U/(xN ZHfQC>$"Gjf7> }}?Z~꦳ eFu*GhQBK0Ii::n&ǥm")hXMW;e_ji<88l"%"Q{na @pr×i}W4W|+;ݜkU+Ù Uk/#;r|@B2 ny$\@X$A`I:r*?wƓqI!mʮ\dey*UoP7<0@1}*bRbIPQ(h?y ߒdRKRJT8e#++Q|?Furkw{$HIRO}\7Fխܻ܌kkHT IPg'"ɱ:Ƭ>5}RY`+aN Cwp;sc w;jH>>F ɷrPc_3`jUb*8%Cί!NfXef˼]/$ojɌ'}ZΕ8_q@hd* be1~аO{tQ1qpiFks0cHe7]QIA6%?lශ[7yb0.z<  Kk8 dJ ܖ%Sվw'nV'gdlF`\-߼ L{LL_q5]15`5A9z7۸ Um~sf[2g}:h)ظp8x x ߵܐ9S"F@mQѾm:f>&'r;\d?!gA03p2qPubjO9> stream xY[oF~@C@2i)m6Uj0;k6ae6wsQȖv̞9|s{={")~Z.jJf˼٘Ϫ $mת NtK(^cֽk BN,^r/E1`/E;*+Z 0;oǝQ y 7uժ$DۓWFH΅_v[᪮Q#1nl'vҔ!*K'oT3KÓ K|nW;3= yR0pk F^ ǐ $>@ \Eo UE wq&mB7jaVΪQﶪTc\u1t [l@0 B3淽 8ʛZoZDΌ$W2# ގYcBާe:dс\R{ϴ4zu}tZw'PqCXES=~ sؔkmLH ]$".p- dK 쐽Y&xxP.],BtdF8F]Ԛ?-V?!wtDb3w;fDNϽAB endstream endobj 743 0 obj <> stream xڝXK6WaEĈoj 6 i6==A~_ ZU**f2g2۝o? *+22LQTv-/646c,Q\7{釶]{$pj7D71̑d[QlE ."U*0sQD~8oxH$7ZNj0 NOYf :)s <2$Rp8 (% WT_)&4CRJ-ubKE M*6b3#YS^Ü# U{xlCo]#|릢>=ݻ3layrU4_:ŇJ6\\cE*s~a6Ye#{bc,$@6|qGg@8ǡ)Β!RIx<ҽMjH(-ԕgo)f uیN%?Mڕ?mgR%GJe)_ƋJ[@y2ϵ3"en2o5V Iz.CzOz΢hi7N7t( OR0Ecϸ>:Ⱥ׻pLۑpD0bV҂X!!@cDAipK !HW|F_Wŭ)` J\Iah̓O &J-m =tٯN0Cw7%͡ 0K&"=9LiE h焒*!I,uӠ.Z(:@Cx61e& KotnjPߤ/4Mfՙkc*"k'1!rcUPgEC7ݻș ]1$X9`syݧ)N_  &yhAB>/[Ew_'rsz8+($Y:dPXV+6 4`cA+$Ly8" /R#pOH]A704tߥ#VzQ3@>ޟt"VCCߘ{jWL^*߹ t) 6:wpQP K 1Ji `N Yٙ$胫 +6 > stream xڽX[oF~ﯰԇ/uSlܸb_yF#zN݁,戄eBN* G֍'-N||8c*&A8̿D/!i#3l 31NWU-YG!92."":*ìV!jLL`(7\M$et!VC +of=Td]rںQG~aF+.8}&bԠu;7rch[$D W%Hjo*+6 bmYUP#%F[!%21Qvg햘iu;T][4iagWĺT 'zDTtG x'ejUŌ!Hmgۑ{hpbpxM^{3ט5Niq ƩD!$ y#GK`f񍃇W*1K<ůtŠ7!`2 Zi78 r4`ʋ W!]nVɐ$yǖl[xtǾ:GBd8~84*Defc(? BfOm-CZ0D9~w0OÈ1bJԘ d~4] vJ RDh. FbV($ԁEx{@y?Oc O4]iF, g +p3Kk?Ժ*Ἲ3|PͪPLyS<-  R/3NQiRHyW]Ioyal}j52O% aS_aCA ooԅ~p*ש`Һ݄@Ǜgꞩ|bNe$8bǐ*AgAn^e>qUZ,Y@~1n]5vYDHyMuw=(9eM \!]% D(XC_w5dF+2COhJlgrV{\Z݆C Ur*=P 9!USo~f{tS5w?:W&Wڿ~55m;KoZp{D(!!1vOCD.:+[7.+3L_ ܯTdEW@ endstream endobj 749 0 obj <> stream xYKF@V&@KҸ#)ۇ9]MAd;"T'vgꖀ$",x1/{z}z$8##GXl}~.cBιM>8Wm꿩ۀJ>xDD%6ʤ\ѯް!.ͼgQJ{m{ BAWMqv<|W g];#pyviZ2$"bG$T72o0hc,7G;rLkkbvz(̻ٖ71MpIǾRI@F_},PMD9js/.\A;̲̔x+ufEg#yZ$zR$QUDZU )"qŃe=e?ieol֏%ccR.jVj~` D=N@Vnq-LIyW|ߵh7d:SnU=Tm_z5pIY~d#Խ/m΀ z^((PjX/}$;,*݂ ޻e9;?p(e|B[t:I,ebʣ 7őKӽbx\(i$ݚDvq8r: xR_ AMS3M Co1ۍC!`jK?ZS>. :d ?sylyE8?Z endstream endobj 752 0 obj <> stream xڵYے۸}WƄ웽GSTFH-/L~|R %')Jh4Nwp/"x!qfx,pTb_`)&ݿ% !(6O_*.rݻ/Xf̖͛{ZED.z}HB3VVǰPwU}'1'q)(Gr;9W  cb XDh_fG{JF_Ңa_֛U{KX`mO6Ȫfc7D48`ÎL܁q`U~-n uY>|]t! "bXK'm&f Nhӂ"حKWÒY{H,1F^7x#$v Gu#:0[H)U` Q;e9y8˯ Wb3(c^3K^ZO[UϼqRnU'[tY@cL!~.%[8fo!JX%Mun1NކHx?l,TrgB+V9G׸1,enS 0Hb1oJTvE8ݷF؁ 2(wŚ ClV2ABT*_:?f2:\!bWVeTTvqULRu&s^UY1,w]nra`A!uSf'ɨB2&"7dDf}.oU1J&DX4dTb$5@0MӫSHp9)nj^GlMj=9F*Ěo"lΆ#FńWw!G=>({M>zrvc8 g"JdA tgUF$RbBBQ6:+Ġ=5Aɐ4麮fFF?Z7mZq$[e4:ϩ)yNC]Y:&<}F~CS#{Q/j9U%h0宲UͶVcquFˑ W:h=N}DBBDAjHj|RftHO''=ɽ aQ4x"kDvz(^=sϡf2dLyfC"|y <)A@63;̰.YCŜ-%_l/KzdIoG+E*@:w}3-AE +OdIbLo szPЀ4i3M_챀A;QH%7$I1̠_ aIPEUӝmi&c71<ߒT $bl H&0>ecy-e({ /y(O]*L!>_b qdqֻ\}\XSSܛ2N/nP$ ʶ=Y{ wS& 'mq0,ݐnVy ҕl{ڛ{[]Gp%bGU+ѣ1f9{:Uwq>p' ԸCRyGIi<\_RRdӐ0j ݰyO^ @%Y׭M/l%+RnyGN󦺸BLcٟb$*2tzp7yN!S-}vW5s|.xF;; Eݕ%v%$h{c_t[>_]*J#7k6%am2WihUHB\n fo?~gOwфL3kφV ]3#Hs$Ǩ9kA4NnE/  H0!n>7>okD& HnB݇_r\v%F |6;rzLj@:"BͧwoM'ep}U-d9;o*-;ɪ3 *t<΍zp^f{7)2(QVueǃ,9)5']90 ޭ endstream endobj 755 0 obj <> stream xڭWr6+8و̘|ثı'$tQuAQũD$ٛ|{/HN<: ;1wΧ88@ibgvp4q櫿M ya)LfjY2Eؕت nG"w=͡(Ihw}(JCxIQMx>I endstream endobj 758 0 obj <> stream xX[o6~߯[%bx)ME` t,L]I^"Hx@y.s|s9?$k9 r&K" 3YL]LCnΉo/~|B 373rc޾C7ٮEaVֳ+5#!iBDk[3w?I SGLJV˫yY `_<-#("Y;m hdO!ks#2Y #Y&*.`/2|Md^o['N$ޖVKըJe:Jˋ_auVJEozN>|**:$@=yof'f 륔{cҍ<. f@8I,fGt^;wSMd^v>UǕBT"y{{k!hm_,RLeI,Jż!7DnDor*+ay Ïc_êװe_rt) ?w/3b8 [jR`& ?KQdEAxˬè]P3aZ(M_A 1Vr8!ե@Cߟ  k8*݄_rz!UI^ zhxLpXQ-[z@Ӯ?~u5Pۄ/K{՝M2ŧSBOx?q~_> stream xڽX[o6~߯@Ntml(:l b3Yr%i^H e;E74d<\sI>%$$NVMFHr~2&uY,cxXryzUW ҮK@ӳ^P,>p"d x[gn0p%ϐ&!FK!iZV"pXV]QW-6ND1؃~o ԗCNt&$Ayi.1:#E].Ik_i#),)أ/T FҮu :/}<&Gi>ĸ17'+%|6 _[X1MXe iHc82(F|Slۨ QӬ/reVO^,P(4^$",;b }Ƒi>$&4AQ"Ep*iWM28wMo6ląJUHgh{GD\GYolMԶazὦ6)Zg&xTE"BvN$|ɷr}U'( 4)=)vO'L]K"gc+Nc+Ng{UgMEm99$ACAװGI BfF6RTΈF~osV_l \)eCy"f>P\`+Qa9 ?4/ˏO}ͳ˯MFccbO㺖)Ǻ~Ww#T:+x!r/: hW?/KSk^ *lg>+wPvOӅϮwy!M_[9W#-PM4))H`ɕ, )F = Hh&Բ'ѻi4QBI:1ڿ3vclb .uU7aic j5]wkuҲhnj :,uir[eytp>D&{̻ت;B5l9Whf+Zݾ3 /m5}Eon62xlq*ePeaͻOsA`)w6nKO8]E}wYӵ(~)c 2=y t3h&:< (cDI~4f5> Tm*3򪮊U^c#! (CBz/t\,Mɕd'"ԓ`QW{f^#:d PvD!(Qb.oo(z p 5$vCY+}zpQTN$V[7tִ7}siξ_}u^< A-Scx0l$/uޜ'}/VX+ endstream endobj 764 0 obj <> stream xWo6~_!OٚkDyPl& K%c?~'R$h 1tGڻx{{sF=Qcn<_ڬ[($"8 =C膱^;Y&t[l Q_7 ,YY\혷1`} PcY@[,UQH&|Mp .L7Y[]u ?1uUyN&B|t#n]D"d|Qa+}\B|>!Ƞ"ш~K`"E ,z1FD>n_;ض\\ Sܸ()Wl4jVfۇN']oE媄3z-zN ٍQY H+5ܘ]{" 8%Tm5tہ-C*lLbR a)[mΪ.zX[}敛32",Qg6]T I;ʑ N!w1Db<G@kz2&=*A> X44!Mh{ Hn5A*~8]3%vj9O:1B͉iY!-qśAJ"Nv o%\A:1A"BBz@]-۽xv: 7qSoNshp1:?h2I 1w62^&I;Fm]뺓1yqV/lybŚ%8PAo3Z endstream endobj 767 0 obj <> stream xY[4~WxəuJ0Nal N xΑdU2CL;>h?e Q>dMN5#ʉyty?ts˧DU h6ny۬X][/vT|z}m$$g7d/|P%B tD2_\>J,]һ)֫KUaNJee*%ӲmQ&朰 pՕyBtOcb }ARl)M2]?)NdPfp'-(}ޟH.Q9DӿyqS:~ 򌒌eC>PEKqނψ@PLE]1\}iF P\}v~ayW<6Nh&$M(*V!a9ɔ ^'" 0(9phͅydO֓DzcqVoJ]o`Ai D*~*HDda 2"dBG{΄$9WlPPk.J)27e<]dSf3՛_JҸ\;]<.0k+Jaʸ7t3{:@IbJ_S/0B  T<8N)JyZّR2`䧻I[up-penDvZ|U^305OԾ.'`Y;1Vىaw{b7Y,n䋙\FvMAPǦD#@L鹿}ݢ"}gvOBQt̼tA{ (Nȝjء"kpa:z=D.td>Pfl:a](QjYW U."f(Gѝg V"y\Cr؏ǘn_ 6t-s_+kh*_IoLإh:܁f$p7.Z)$H8JB$op {zPe`Zkp>L&ܔaӇ ܶGewUp ,oEWx6nJ PXsAI afЩUlSG+|ɾwWEwsp 3X-< ;h/܂j;9eY?94H \ :1O=y^K\A XZs-BoTL ~<О qN؇#&ʉ%PAsB1uOS ӄJdCWB/-LۡTi`JƦ͈xd$ -5z/F6g/+m0.CstJP2;BҲ:t2 P[i{Bɘ 'DGqk *T8K%|Ǹd}M Oh.gC!'AIN3(q2jAEmͻiMEc4"Ęgw|?! 1Dk [> stream xZ[6~_aT}vmEӧk[IM*dgEMQ y3 d(b;+:!8'Մ a(zr|QA]8"|mg_tˊW?ne3akvSQE3#Mg; |r/^n8u*z reeNQB{R@<ѪWWiʾz*Hf&ĮG&hׁYSlMHp>'lK3Y9r$hg=hH!KZ\@S,Emu(Z!v]UmiN1-kPQDrt·]٘|& .1WWaŪ4i56#iChІ S7&Ffі>~i{uwS{ܜ䁝)hqT lrhS'yw+ ` fN b:g3ͧIw k]R-P4VGgIY`DyƺOiLDZG$Y"^1(T,= &< L Zˋ( Z##CCD:gDP'T)Ѿ# "}}em}HXS|۝ V@Qv;]V~_ؐl&&*$ȳ ם~r%̛[v@n%qY߃rK RO*NHs* 󲰴(u .No0Q~I;:\𧃇`#j18prɴSQr dPG ^5Ogcd/9&<[TB@%.FeD)8B)C|_Hs< 2!NI}ػ>i qg?TvuOL \$ZM::v埻*L@µߗKc'd昈 nfNm ^3\/̾ Y:^7kVX? @U$i[.OH*w;%)Bi1#{4e'G WbQmcitZ#X\KB˽<ʴfi,wkcy`ɝ=U)4-Qu-$xL.V6S"dHrz8sM]s{A?ar=08jY$un ] !Q.5γ׭0> stream xڽZ[~0X3ZILۇL4f֖II{IђC`Q$ؑ(<7~;G^` ?]?/ FINsZ0`.7?eš/J˕2 YQoOM&f<5K]H5n;9x%)%:pˤ[ sBpA(en־`gògYoD<|u Sl4Q`U2,ˊK %(Ҝ*_pbnl-߼(myhˮ࡟ RK21OIq> Wu~cWnsXgu?mo TbG@B$켈L{$ns+*4װFnsJ @rv;хku ZIK3' jSGp A Ü/ fZO[mpw~JmƾcCwN;zYM 7U⹪MB `8͈BL_Ekqreg *P~.Ёb+UOad\+E>xKeND` s12oBtGH. H'NyS)5(\T캴R0;rh0WjW4!0JkM(j2R*%I_Zdb)'tJ/8%R_284?8DCrYx|g>٦(gC.sZܰiFq𫳲s[u 5`ڥq7{zK•(OFvJ ]=<e()u[0?u2KF9U'X'N2eTQsҋ(1SYbAf]vE?6=l ETQ`LW"LF#V%.E6ijyjv2£i_IS?Cr m!!‰?ڥu8g9\MBA~1,KS #q1Ɍ8̧mO?3Avh&B1s *תe;ץ,4:8:m\ ,3XÉ瞽״sc;Ypˡ=Uje9/=߇%Q$˾}`2 \:p?"^&"PZTa&&H[.Cٖ0XW})C/$TC"Ff@QwkWȘ 5M&F6%Vil(O *szn];&W\ncLc?-XtbzoIX&v\ϋExUZ>M ?.8g.ӑ} k"c5Prs5/+}OӣǑuӶewpz` xp `$ mpt%^untmiC]>F4򿶥EbMcv!a|F \L/ ˙éWLO݊C8E|V]&B{A4J>nMjڔ.HzCs64X~r7o'% b$=msmW R)t];(~Sag8zb;ʃ2!)zM3 AܮqGzeF m MsZy- |MTUuf)yM2:atIdE4xaf ZuA3jNftCU/Hχ]zWQ“,}p;x{q}S]| _1g3/ATYwd~}\TS@h¡oa]!p, M˹ ; 9iݙ]CeմU?V #Wۺ4|m ~ Xw՜`H3 Ve<'4c_&-_ of{ endstream endobj 776 0 obj <> stream xYK6W!21K٢AEA[d?CPkip4nA?]j< Q8,LQd0_]P[Ͼ|YD) re~vc]4{;G5 nakFpă(!(M=OoaIBe%Jm2cQ >D؀96{nq~ބ#‰5qpEfU-%b17YUgy;='hǴ's[ZsU6>\ ){RWUjrʡUˢr8kOa(NaWu4m] 'B+3M҉^,]EUf cugVDZ '(4rD_5Fq* >9d.ۍgj>4#wLԤ% :e5Om!M49y%#0n Zje ;|vY};J,אAK|.z)@& &TR' N<#|2T\<4PbE~I;*;+;rQUO,*3 HXσ z'm8' a.<ǐ^^ Oa\Q5Md_w{|)?N'O*TNlwV$ EԊ.{ _B~(G8QlPwJ-bJIc>er1UGR7e" ٵI`Io(!{=Cm=Z#v6gF$+sr@' paaB<_Sthw\v2c%_=W6kLGJa#STR .iJ\ J}?k]4٣1KH> ?Aڮr2diIG ?vDo˴+nc [وf81È:lzU[+e2ntMrؾ{d7yvR])&m-jM;>]]Q v\5@ n+j 𺛫[>7IYiSu_%+Nmo]U k ׺վ!,a7FKf}]"kUN޼yXϯ}VEnzkޯt|CAdu[ kS>k2=?(r??G= endstream endobj 779 0 obj <> stream xڽZKWH6Irvqb8#%'?>U"mJZcxi6ZLjF)G4w7,))҂FO#I!aKT}{^xߏ3]=ԆөƦk/KyI{(ӡ6Gs_nVMϑF HJ[dNNEꈊ!Ѯp2QUwL)y}0/LZtA73  Iq, &"2A 0SbZ]92` 90 'kBf)H9PSn}/TWͯ)UT;qm$~9n45b@rˋfk>SD p  Ƌ~|Y︊Z8xw6hNcMHlbƅ7K3m :P_G%^.d9u?'9MBb}堉rn$baL1PbS:"9(cs_G`:\ur Kg}aP]vZ@w8H'ܔ߹^haTOui^R @K!@<AzL@΢`JQg{\b`9P2$z_ 39g.ee9@1Njad)Q9?,J,dS)Aƃ%CeE$\ Õ-CJIklV]|Vԟq_ߙ`aA%0(uAiEKI q.ɠ y$V6PA<ڎv 3++5Ra)#MEP F3*OC#)dԃ5q#E63Cmd3_^ (@`=P`]Lߘk8P+iW7m6|(cX#-eD 1F ,-D?n; J^ME܁3Vڑ#lG,%t2[FH(s &[ /j_$`‹_6R&>>inAů 8o|N#ڂ X5ؓ36ΌNG{y ??+2~u2BC!.ퟬ endstream endobj 782 0 obj <> stream xXK6W!2P1|K2CfEES݃j-kAr$h! vr7IGNf!H@TPԨ :＆q]vԆ̞ ʵ6Rl"qD]5>"FIұ{\UwW;)Zpa^7E x +ٷѴǢNY<Qr0qiwUV*od26۽Ŵ1|)oO&K8ir4fbc Lr쟵` cmw[K m*}(S"^ vY9fuOg4y@ &EԃOMb9$ KY-ySܟ.?-ݩ,yЇyx8Bg,B9f7})}:`b5Z8LjwVY.6#AuH2םHP()}HB(h@x2.bl( [dX#Y!AWDb~<1$ÓBp%W _ ?SÖbDcc*`̮XX66` VJ.Q W]޸"3~Ss1c$̍!|_ׯ\~SƧ]n}T3 LGJ@x{tQ> W~oo;_@X:\j,*ggXf,i+xQ{>(WEժ{wm^߉/ .s>ޮ Cgm8, vJS);_Lj?fͿx3 endstream endobj 785 0 obj <> stream xYMoF P@a7C6 F.9-1KnRܴaalUկ^QѧF)H3O>M{єdiFr l>C_swD9>q^oܫztܷMXjVL7Dq {L&}{[3n CyZV]_ QB5,vO$~7mJE]lB҄"~nÔe~ƇǯWY|ȷEHD1My;I4ZqZuk(R/7;D0M4qNsT04؁fK2.LR"&>9pUS<.yI".GyM1x':Q!6 (=5]Z\c]82;99@ 4䳄CiE7"Etk4^!@X zZ%,cquӻA.^iq ]q]n /?cQ=eX־D{m[ mӖnO|:] Zovv49euuas_zncbSa]3bbfu嗖v*EKbOGTd㌺(65%%)f"۾\mmsC"Nvށp/oFe^{9zl"o}lVnƭ6`@΁k7l7o-`dz^a) NIBgSIg|HE-q0Apb`2Е_CS`2|$A֓#ޯ ~A~Br;Ms fSH3"";EoW!TQQ2N{&tn~&%o=8s&;|iQ.5/f7@KLǦi8cȩݺ-xAl٠} 1t&) # L1ɩ` &ܞ`H&bP3>v` $ @+ 4@,`S9nׯHx[]|L݅ EXtu¿ 38VWY'ܺŸ<7L8~ ^WXM$6)z$8}ִqgH;MrѴ,~NSӄVA㼃9HE/Y >ehg&:ِmJ5~W]س(1aWǥ֑ҳ 9=9>0Um6x~%K@u(Ĥ%0I|ߗ"ͱpdxs;KFCUYH.㐪2$FՉG Vgb' Ư`ܛe볲pS2!`7pg">z捷 dbz8ucظ"̓x&%1Lg]4cgg!ρy5_s( /U09h:t~⠃/E!Sc~`u,suakP1Bx 07|fDYU¤ ,w_UbkΥEvl ۏ8ݥ++T*Cxz=lf[r[375l\CYJMeXl=ixfTfs6\ R~3 a4̄p ގo늍[h Nʝ0cl }d*~BTtQdǜHƑh26:G=q,"Fk9<)QZ^f)aGnԜ *F¾j(M6~ a8T7}Ȁ+h"c)~P0r9)G Ɓ,T3Ew{3@͂ZQk?_>Jw8+X91~HySͥH$?D?忝 endstream endobj 788 0 obj <> stream xXmo6_!@++J9ketu)2x%Wt؏MR*qːxCx8%Qg8-l6$<JPPZN/.&4˅p|_m6U,<_5[3D$ FbX[-U"3Mٮe qNT0I עR `Vd]ma`4a2D B!X#AԉN,ls|u^E+o3!B96enF`t>\k#_i'׫?'D0{θ˼( R|jr4lbO̪y-1\\2OJ/ta1l;3IY=d3e88Ĭ*ͳ[/r &`>6Z <^o9J {+#W.^:2{/m0r\DQM`s:IiX&GXd~9ְ*.wOv 6#c'Mؐd4N zcSm2SzԬBOr,;82|H0`}Rpԥ>i\a@*19 MO !s7\S1ƈe; eǑ]ZIX-,AbX3)`vPԁNԳ"Ԏ`QӮs 4bM_@uE?1~? 7Rֵ\ ?(pQ(Բ lٴy9qCG6t|q cx{@w^Oc Sf5Ocԅ\ݡؔxk .嵲o}OԆySE98,] "HP[kRtzoЈ2K`^ɦW[ 37tQtEh㮊jjb $5z].AC#mҢ[]ِC0(|a8n3U@ ZO42*>4(q[L4YBkL4E,>ݢٞ.֟2?7 "' gߎl9-;nm{# cw)e(q DP@3b>T3Z&/ʸ@1GgWºMc3@38Zs~adaZ;aw :H`v61z3Ҧi߃0ɛNcerۼ]hd^= |;5ٟ֫ڢ;<ץ^O>~5uޒ˓k38uPeq~v9z'G>Jpw6~k֐wiHKÓYV+ endstream endobj 791 0 obj <> stream xZYo~ϯ@x}Hl/< rjHZF~|/Tֻ@ 5lVWWUU7?m?Qa`d! zsu!>fcev9Ͼͻ,7u*h;hXo>l$S0Iq_#v* 3ۉwqԎ wcVwEmNJ͎(xj+q| ' IuקcPf:+͡ƄWE =X܎hJDL{S ʣBVw﮷N! :CD|sC_mSɛCQu-: -2lvxoJޖ4+oΊikxU w) `a~?}WՏ)#M}T01(5V9{]r(QUJ6FX0ub:\)9GZƿ~&^!ʼm{/L& .6~]Qnuůpwc9.0q2ܤB\IY&MٓXhO̞~_Y{:vi)dԽB{& wxcOah 4[ʚ3o֔)S-#Yzipi<.7:EDW'OB E[UyW7$ː~[␖(АE1$0  K$FI$wEA$VC^D:(%sS?M|ÈӗUZ'x YrҔJV3 ˈX80/ 2TLT\i' qp$h 1Aw!Hbd !)Z"uW)a "1()Y*y 54(JȄXA.&RBDCʸߋc1 '8jR r` ^afmޕmXmnݕޚUmBBP8 Eή3) jl coB *4&Uk {Ӕm3. i>?ښԊJ 1%ϊ|omum՞8՝{@"ഩm^

֯.xwuɳ)k e+SP*/B!G&Sb҅L*ݩt㢇nc[ Zmՙbpcv7Ea }p}8gQfyDF`2(%sz= "NH\@*oI6q4m4] 4LLil$I*M_-uz_,tX}l$ it1 %.ş6/]  t?ᾌ6X~+A76<yGOY0Ƭf$>a=,90C\AEUb4z|c|񅉥 0Oz)g99HՙJ1]_A7kk5 S L2 f_-V'#%HRUKEe4U=;d&)M*>rJYg7ݎ(OcCЅ h_ﾬicG Ty2TÖfL 5̍(rKYW@UE!7$^)ceƀe'_I,WSb{ t |lzZ lQkPK0*>*Yy~,mE,? \o >-A'+Ht$B?]  =MGL{l)TYRIk|".\sPdӔMSJ;:8=Dac 8Z2i*Yo\8䒳e5u} z%"vD3'FGZ< ]+ T"|w5CR*iw?яK;7O/&wE?"fp1|_#$0Z0 'kGԛ+@qbM"oyK>(]9Tg>am狒Qѣ&,6H$tvJP^kfr%.Ykh*6g endstream endobj 794 0 obj <> stream xY[~P*0';\.ZoWH6p 'h8͖㤭c"Qr.Ѧ,(YR QEc4xU$6:}4若9"̱|ӫIwJր0րϦuqK('ʩ3v8ƀ d(UAM-%sdЇuq/ sXO:v]R_]oc# ѱ]g(A$k8ۣ(诬6B q4Fu?]%b\U$k#ng%G1 j jۿ}eF̸LC p8B@ޮQ>*ZAAa g z/hAS $(_o0o;Kqb@U~4u531Y5Oq=tSH 6# 44ɢ}t2CO+f}7ƈh8:X'=ڕր﷜i"~N cm`t^ ;(Y  @Ǧ<3Ʒ*:a]4EȤ $ҥȖu7W&sbߩ~Ufz|ǯ,OŤtα٩ƈF{[UƽPb %F˷(+`5CuTv  ;3ڢmʊ,yoM=_Lm\{iDkb`X,/DBdY.ǬaUR Ggڳ$smM=Աt-=)]'t5xq෤C}̅/7gP3bxnC'ob#Fsfꫂ'Ai^Jtipm>bÐ4M'7@:DB㘢YyaU K96U}iqP{JG$pjaż9s[hA!|Ѱm [B)e ?S,!5h+HŌqZlst}r3qCsXN4e0|vW D/uVqL=ŒrcSJshƂ\Ҁ5tp0:qW,sQ q9zzXls'pR4@NJR)`[b R.:uҫղAOV+wȃvwTXJB_B4a+U*P#,Ϊjx!%* [*8%=3, Ak"9²h"h"f"r eݫaE2s)FRAփK\1> stream xYo6_CĊT>tm lؚ AXb4@I*v6-ZDw;^ggx<fًd3g9]ͰarfgvRJ~A e ^O+e{sH?RF$\)[VWT8PI2r~t`.ճyP!LM{963Xl'׻U5pf P0Cl?97p )[5}BG'2ĉj-Jٵ2\KqPjڛ@Bb 6 sER<*w@aʥR" tUK?ؑB!IKh0yG4lcBD`# qeLF@3N&&G1NxrwhifKġD θ|X1M|Jr'(ܡA#By;̌WvqRvX4MS0ͭKC_zˋxOl&5ֱ9;""Ȥ]I_כH"}xqu1t-ZS0sR2&O&PV-kݤ'S" [OVe QJ4]Mpu<|WͻUM*-*Sz_&CEа*iGk80٨|޶M>m(j IH2V+&2\Pm~v&v(y Xl{H 0I7Pl$ike|zuUBL8$n)c891dVqQo- L^T6)\y~4.P,\Ψ IF! PGCl +ҞZ}"s?~(7(bUDaT,H.M7J2JMbtRQy"k9F<22d:QWʃJpd悳L)!ugUv!>޼ps벼FL.}ژv Nb5SaY>þalڕ7to<E(E쁔bMUήr2mn;gع;{8$C`_'8}~.q$_X&c>U;MǨk'KIZqcu36> stream xXYo6~[bxJNb)R7Cʮl %W;)$s9`o 9 F NHC b6FW_(RiU3´\ۇ_.؇]UgΛ{eT]VFTm9106^J d]fP<<-3wNUALun*(NMΖ2[q$61SHͯXĚ|d^C__Eì։ x~fjM#PU%X犯lVp7N"q"H Bc i5]f54`ji/fUm^n#Z,ܴ(*cӇfkTgi1[m[Aյ~ %+DDm;ԌCۯ0 SW"dM^3Xj 1D;Bxk΁ΐafmB Cmf<`b _;?R׸+;1)Lԓ]MVd+0jNHvFdl:&HW-$SmȢpnYtm| DդBݤ)(7.cWb3’dFlnw5Jԯ=4 C NKf/q tқ%d/)tTEoo'ލ*[4aُ22[I"}NSsu <3; %y aI9*rF(ArW?G1 I͙5i1!Rtd^ǏG OsX Rh4QU.\K$2YclJPtFpͬ87wsMHt$AvQm`Txps o,7H"J3QDM cJIeh*pif`uAgyGK0cmH%vVUo骮a_Wv.ët7.}hg۟i{*TONwugoQEzJ/J~lÿ endstream endobj 803 0 obj <> stream xZYo8~_GysxO3@/b}:Vb40?~!}}ZtdXW*?\}`Cۇ0d.n7P5cVkyc5T /v?kWTC Z~u+*˗՗ۿ$ޖ&̽9H 4noϻ0~'D8/mm) ,U7R4I$Q ɮO$)O}opx=qi#f!~WzJ_.k6UܭޝiCJnQЀܶ7Ð9Ѡk*`^ߧ"G#ֿC=V 4D_h]((P2Ab]'QHZ)AF{>͓=)NxlØ@</j.M)NqAO"ΧM7 UY .+84mᣍ]0w~wn5.SnRĔU ve>UuANj%K?0),:)i)T?ƦGHVX%&*n}}IyWlu'Iҕ,m> 0=VQs+%YU[<1GeI|p0 W0ʸxA4eJ&'tlNb;svb~߫frŬSRO=,*$83)@157Ի<7bgF,3PתMtl?,O@Ep`gu/#d^&%豿4QCgz{ (Z)ZرW_d.QBS ګڍèI ٶXk(U+;77?B}G^}5vqW;"CubD^3 z }",hr式ACd3LBWt XMe.!P~VA2e!Hic4FbFfDoܘ wڗnmDejL@+"sjl/-fKj1%]NYx 5 +vx~8ÅD;Q,mN soF )aZN % cV|%s/y1:T&cK^QOq%s}ut5 R25ue*#}dfaYPF׮$])|tq> stream xZmo6_~Ux|U ve}3ĨlyXw(EO:qs;&;A8NN!1K,68e0cힾ\O&ԭex<^ʧ?l8pYP};f1vK$f,xLfY8:&Z!D0-DB?|L"/~}fYy I!ḴQw }D_^^8GRB0q=EЋaX0PpGͱG%IVq(Ul5j$äXҜO~#]ӜMmůB?S^S ~[}X&!AI)ԇr~e^x;- q&;A@H ]:+QS=-K`}ܬ"䜈l2[Ѭ\ߔ;P(Ԭ@ cڅzi/'=xOw/I~xt%H)Ŗd9gJW_ikW`%PւoO#×"+ȖD8T)R:{+\m_2r^"%'53:]Uhbf &Æꤥ}Fjw_% iI+5Od<$~a&ro|;tXIb2^TEq@M䞪LnZF`hv%Tq¤ F=n!k? upSSrj!LI呾K?4$jw&-(Cró)d0\/ȶLʱ.7jPwE5]U:?^mLgPq<'G L.9TOu{:[|,M+iSa]2@> |@}` B M ws#\a2+֯mv]x$.PL˝ifWAL"HQD" ,έ (JT|t]?|!c1eV pii3@2*ɛfkThHT} |uB1h,v>_|s? endstream endobj 809 0 obj <> stream xZm_2pfwꂢM?Aƒwsΐ"%H(rM<ȋtQt+ۻWق*+_PT,?=O=.WB]u_Qԇ]{X2]v7X~.*^y!$kXdJ_ӅW,8\TPnv𙝜邔%u#߾=j>D3X/}N\8q?KTwTPJX1IJ9>;ҲiYޝlm%Lg {[ (Fk?שMbsⰯ祔hj>႙b{X'8LL,mׯ`S IR)1AXaΕS4xiWoiTDj:0'Ts9 '] KT͡zViy4DX00@rUf7`Z7]Cm.زb%j6t ]4h1{l$2%Ȇ.9 8)Ҍf?A N`f ZF+jL~&UylTyz91^{d|oͱy; p4&*;6M$:ݿ  ZUIU7sHJv\;3OqHb %[̀ b3%'$*bBYLj4c)q#X8@hqpa&)Ŵԝu .txuݡ=zWHYd񷢥&43@I'2WI&"eCLVxFg_ ||@dN +9U%:]QWڇLU2Y! xv{@v#) `KBsӍإ{&dBoWs\Zʰr=LX<FJ*f1Bii J 1p)^ $B >c*A ]輊b[!5G5r=(ȴ2T}`q"<Vo]Ħ OgxAb(A(b  :x:T֧ bbԎ".1 6i1qLɀ| c!т '9.YRʨPnTުjv͇rW~Q5gA$p8X\aztА _~ q+A1e}kܧ`3m(A] e߇15Hka[ *1tA`ᲘC3& Qgs4)J!U*9bTD9ܲ>&Bէ]7бT8O*)<=K dZ\Jr⼋rĞv.]@E\MEμTƴ:ñUW+ҝ`KAsӖt .`~.b.pݸ}럻t13ouMI#T Q|H_!*#J꿈L꺖ְY ٖ 0fCKΛs/C5H(kY39&۹s&. 4Ƶ˓Gz3}$sgG}muTB]iZ܉,t* ltw"A$n` 2ɝk\@кغ+mݟMKtkVӑ)yv[|ȅxq/:緶d&i IA=Tw_7I" 2|Rizg"&/5:ߧBΏ+>53pÙofWzt<\c8**1x4z߿;@vD6W@{|k:[ 4R p HPTU>w G?c{ m ?_B_nIÿqSpp;edIǶAvxqd> stream xX[OF~ﯰ-z.Xn(QIXDxpvRP{8N+hZsw.>^/X!VHϚέc'j{}bg,>qre ](n2ЖOG=1fyx8."gn=Ft9yvX}Hg}7"5LTJu24cN,Sww{`V,K<24'="{Pս~:X^"E"C ai ],H7\эRJ2/4-dWJ6)*-KwkRl ˸.[(i䲀+!dp<<ld8Z7ɇ$WŠߎ/CYQZ[&*r0kRBWwu2U/D,M;nH-ൻkp"-oQxx>>=F9/O2VOb#AuvfqAzޥKC\7FW hL<Ĵ^*ߔ,c!L<`Fx7Oonq?lM$\ps:}:C-x*|s\UU]Y@!|-:.kS8w_( $m zd!nx wʕU׆/Ohl!0B%{"M&{3۠vgTp7B5Vax%q A$Xڊঊ@-|܈*4SԃLGJF& Cy`Wi>([fWq8G!oc#RVY:HoR@&a]OS^DF=]8η#Т⌸Pe]ӇNZ3}kz@%Í2OŢN:Y끿Pr!ckc3w][?, T7A'&ҁHg>!$ 8֑;,ssd8ܠɆ-*sbL:ORB*dykai<"<\/Г<54W"O99#"&{Ogu)d=^Af$mFaʮyC\uކCZ_:G Ͷv#n'pF*QC}3er 21n wE.8K. Axu_+Ȼ$E^O~ endstream endobj 815 0 obj <> stream xZݏ_"1oJ[Mr@4hE_nAZ$eRE/e{ p%z8oF-(a /]^|/%~Ccl\ ! u\I);wѷvM1to]r]|Z~q!"Zermݯ3܊θ*ZɊL?b(/IX1nM{;.5ӥBŸ=V/9+ sɿĎ+?_,+匼΢ǵm=tS:9 hPβgDr\:Zsc,4gx׆@YöH%RUu̅*<٧[ E_|1&1\9'ݓDћ`eb*~qh+.YvP&x?}_?W29N2%щ9Hp֬OH\UTFA/ 3Pc?ivd}Q[2\qD2}3bDv_ ospW2cqjf73~&OXЌ:I)n _w]0.c`i6-^s.P+=Ih"S3׏6W|^;ysD(Z)ǹTIAjx?one:n5$%0glj>ecD20H7>nZ?\ ͜&#i4&!)Rmv bJ X\CQO\MLtrROJ2I@|ͫr|B΁Fہ_q5^w$y8W~"W Ґ}\XYQ$ E6 Ӂh ol^9\Q8Zpp&.v=Ҟqpr*Jyv/ƩQ)k=s'&_$NlK3?k:ժR>_0#]B+"ɮVpGE^] { ݄> stream xڵYk_!@L1(`d` YjK"eoϽHh Z0GgERY}\}b32Nh4k>zi]`3N89kČdة+ojYo-F(C1X\܂"JfQUYߘ+6f*2UׇG}HPP[]{6jeZaq(  SuWA$gW#.q{W|+ql,Np7Fy%d>IFR"CY}fNpZz GgM»y -Q)cF.|^h$.863?eWfQZ ?uB1e*7$Dp:©˔d<} Icv I2 `GAnn7R0)qP"M 2g*o{*!29sɾ6P435`E}:9'!y2fq"FM'Yʲ\{DݫS.hV#]2 YkZox(C7v_ >DaKƇHka#YY{s LLk3 PgV]Rq~Έ>p{;O&oKRp .4] ZE_ VC@EX#fedm6 Z74#RAmh }lb9v`ƕd8ũ \6ͭ  )07#Fynj5ئ1] ۦZuKJitI4'6c^$ў =H"1w !@S*9R{DGz(&bHQ&gB$/PP1= ,N0zL8ӕˀqOh(ް4fdGihf&Q'V9 p`(({ND<2Q 9{2tG)n2xjzF F"jt;00}+;eP gRf"xb :YV|F `^y:>oFŮ!}gVְz\bt̳QFq[f?{i$vs)HJmaO2*eR]mò K2xQ V^Ysykuy2D&> stream xY[~ RF88& 8v qxf%Ԯg.z I E|:9 ?8Aq ^&Qg8p`2w}~e(!XEּz+"¾m*fEvuu]0G IL?}7hA2b~re7rsN8;g-`zoROm ͱ7~!݋׉1AAN@"$A5{T/@8Ŏ.};a#.*cXa')J "1f~1EK>_\O|XCNӢWA"oR6 Kb'v{r~@Xve] ICȾ;.R꧀5:+ TedaZ j4lziJ\W,gR7w`eɹ.X8uܽŔ㰒mUA]L0FxUIs8ć"My`(۩y[\=~H#T%O ԰_ Wrj[ǥ1֠ܮ]  6M|Q^uA8͠; *?1JԮ>}egф FpJgЫaۗ ,XB.$fٸ6(T<7:Uk)uWײ!BIɭ4okM98qޡbNgSI}<$6}@2H^۲Zެt!˸S'6& d5kT'cTvf}d/USϻ}mԆZI9Ui tj;e⭔<|UuX°"l0J[41X KˆxJTzO$?!'\Fcp ?jM`e~ll#pvr 2J? #7"N4X\ wY6_*we!/37UTdpԻ ̉AlXS+׺՛Ď@D >}/[Qgu mrgqN]/4ݼ@[ze'?+t X⬃[{5[抮gcp=q{0zeþGP >-3 8{s;-{1n#1A)g0J .$^$+ԏyu*`g90Ξ H pcR T@+U_(tIT 0wo,f;ơ0v/uhJ7Awq􆒠>jڭ&ܞ/x7lgZil)6f/tO/& x(3=K>sQ۲ߛ} ѝݖJUK:V=XEk ژֳn?P2x6Ƕ{#AΡqPHtX/!UV'mNms .?R& #aLfgx$K,yYpS?AtzwKB "*o 0p]4+wtl ³{PkUW(A|lJ#"k$YzI9.2Jm8e@ӈo<>g>TMv^ J }*\āݝ(d_VI\b,G\| M>$$Q󃙭Yࡺl*ԍ&HSGnw 4ɰC>MrIǑ-p ,l!,rA3/Tc5`/o+Oq֥H8 +zΪͦ8\J8lB;2@ޒ1bPS^Ca~{aPGذ5-lM,[rԱ«ǿO endstream endobj 824 0 obj <> stream xڽY[ܶ~` WQt7ۼxhgHkIc;h{Iq$- FVP<\|HXB?hhR]%/^Qbam bd\ޥ\'\pq՛?lBhv7rߴcLQnvyZU:/^3$F6ގTҐIK۪/~KՌal&v7]U UJM LqTZtuqsj&4UD0Ż]5)ȥxvp=Vh¸?]D&O<\'/I z z1J̕bpgyD[ t.S좾!ttb7l$4Cxn/W?' E&b'du EiuY˩9Txs" UY×1yh7Ptn nkd#QmL\~,-ߢ}cLdw54n'Ts\|RVEay綂oٿ+n3_kAr/R'G(`*hf?"O{x5`SRQ+_cEIDDʳ8Ԑ|[*M kǶp qIk/;NQ|-pl=ˀs sD2SĨїx{oXК@hE8Z=ud{)91Fӽx ׬Tuրܳ+bvBu.6ë{w.xJad@oxf!NjṨadQ}}('gFOKd>%AR,)0[ é9n  DQbb0C@\a6{ĘVlu \Ĩ#L| X0(4G'Rezg;s; >lWx'9YqiZ\|;0#M"QTecDUP?(b %jUR0n#%lV1q}^7AFۙ)6My8c,E(H&'߀Mq'sXR3s ו\a᛭egl->޸މ[MZ J >`eP)5Ů_ >2Ila=oG&|1W-jm2}u۠,֠9*wjp9/ k,A u0= wjx}b'*:aӬ=0fZ;"(pl[:8mUm2geuΘJ+׾i+s='.1Y!"J WO,^f|ɆS<\=`+[tX39Q΢BOlFe{YCPUq۵h}xƳtݿ)fmPR-Aa9`K}E͠:ALcb>xu'%%bh1"(љC7=5%JyC&BUu Ȑj*'fNMasPG߯dta.Gf q+aQܼL8QPbX!5epzi" FK/\}͜w2^3 xڈA+,c‰yPH:lFt'_kҾ|mlѺln@UЈzXz,eވfƉ&G60فݕ& U0^^*@E瓢K}y6 P|˫C|0OU |x>0:tqٵ=Pl><77#I7?v RCU :ܾkO_׮ert:k.'>U!! fbI!qtH&?F.$DKq*ItP&4%9ӸxI(z3ҊQrC]3:CQG'R/2޸ On'f(/w+Y胖|0{^0(W y%y/x/=d}/ja&K -M Z endstream endobj 827 0 obj <> stream xYKo6W!R>D=y-^l]ʑ8;$%vpmEȦ7oK)i4[G?G'Y4|\|~)n۲NRy,OT/¬ݫw&a*njeXqU%,_"d\F&S`WO>ߕhvovU6>֕ "=pVϤ_]Ί$Z6YN2s~w=\_yK$HGPQ*%əVVY$)4LB0@dQJy;j NkgA{ { SD*х%eDGР CSК(#9d΅܃{@i#<)t[=B`q<,g@)-(+%V%ⷫSvpm Lػͼ 6<$Mdf]w6lo"Ԏ7I3-` s zO=FXU  tC.ŏPp~^nWNYC{961DHPkꅷ$,c:tdzƷRbVWW s`X gNA3nm{DUS|tHn:[C6XHrĶiGVxa0wU1i?:&SbJ^і)ͬ^~NR]a;*'!5L̐ PX.l3gդ MN ŠDrJͥ.ۻz 3$[TtFa$_ A1{޺]V!Ğ!tN$ iCvs%sy+xB-s%0+RNѥL#s\ۥu#G:YH:s.[tՄeS3~)?(a<ӎpb'ʥB'j/\I)H3lz$`h_# /DY2!,}K9 fIE.{VeؿU({p*y-ϏLI=*겫]{4Kx_{bf^߸o!⚄NZy`O2eb29XwF̆qbޗҌp{_o:|v?@\Ζʱ CPFaj A)r\1yMȱ$/D)̓Iz}H@`ieh6a/H.3~D0 RwV@$3x9~MXo{C'H)G=+kgɢ{, {+PrPo$CgWnCSeXcCcӄӸEۦٸ%skvq5k6Hw39hك 1Ϗ?SgHQ?Chmy&l~(\G ۀ^ݥ^^ؿqWϗͬC2m2OvJ] endstream endobj 830 0 obj <> stream xYnF}W$`n7.7IiN^⠠M"Jb  ɥ$# P$iiwvfΙˎOA+I˛g(gYpA$Rʼy]FMo̧/(&YXnײ-+Klut<e^~-֛Zϟ-Ֆ2ĉb,PJprŜpzW!6o3h3/8N No',J,;dAi#f%Ic)JRlV>ae" >h>o[铙2gˏWv%Q$'%:I83J!G *ʮ ˵/E*z8>'1Hy q]q({i[X)p& r97q+l.m[CR, x}&rE[{5bȿ]IP 8}Zݽo/n22öSyMZj?%2"\F⌝&t/d_vff _H&S9nF[(3DQۦ7f^n{h}g(HQ:eMd #*\"SmOXL`ʄb+Upn"BYSwKxtjQ^9H¹R{f7nvTM*6!Ķ$CZk(< 9mβ> $|}D66g2"a(aNqhj0s`L 2ݬ88D'g MO"7yd C.F}-`)r:0qH6yTjy/n%W6sV38'#hΒU*Kܤ%\*V9ihƣ1omМ!Yl,ʻ'irknJQ-"=De.HeQQFK]vdj.LD'W" #G9lxB"T:׎B>e'In )ENն;^c8'KB8ql:65@l w"g  "=H)Vp#G> stream xYmoF_TRa!*i,vq6\m)?o\.J\1 <3; >8o p8"I)JY×7ٺ+YD) Y ȺL0˺vMT$gOڬxuŌXQS 8;s/?1m$.A=p &diK®6׶]cO+\ {D&lߎLb'fIj\p^,8HĥkĢnh'/iQ’(|=/7o@M5/.b*pG'fҧlh8<~ϫS'u[Xs^uv]P_P?t1LuPvѝ@D݅%v@d6l0|X`^/BFG ( tgfoZ\ ruؿ AByU*5tccU]xHO~d#RHs~[pkAc'P0s~E>m2̬ܚ(*bSuExgn]u)>EQmݹFЙUwaH|768EdǗn4MtU8b[JmmyW-ѱRR#,=\ $=q&Zb--aRQ{Z\)_Teg9e]jA =Weu*2/录:&3\ Vj㺲ZY3h8۝4#L㯪s?q :A,z.uD3~x3ɛ7Y@y %}QbvUTs6sgJ 3(8u,ݹm{ck@૰ĠaĄ`៝\eJ~kO=8im7v-ZdyYEH1"*L>N1-U C3LdnTE${5`Y[ ޖVlKRWUmvvʼ^7*!6,Gozr2AݘԜ6S['6U{د$`j>S8mi!/邨1õLC!Ʌka.kNQ X:)& =:L@,dTfri+ 4y&ań"ѷV$&/,WqSmA=2Wn'RUCִ62s^9o1YI]yVKL)}v1AѲl;ٲtƖ`c}e ;D"Rka_>%A`F&`KG@Q4 :,O|RhfUIN9yOdf}?SȦsRed?WO =Z}w endstream endobj 836 0 obj <> stream xYnF}WC"pܠ(IFZDR&)񝽐"lEggggΜE7R#I׳;T2Y)R,1lqqGD(ARRx=p~PJZ?.eYW^$$WRW "j}RX,$L 3և^~bj%X"A<-bl,FJ.8N!"̥-Z=q%D)F`/yV]i/4*WugT˰j*̿Qfq\ud݄ٳ7*"a/ )MoxnJ u6nʄ@>HUuTw: "A`N ۷MQyv%D}b{ &D`>i㾹5 =w,35(va-.+H6Ek|/Y|nH#륡p t;R؞v{(MGrb (TW\X)Z%p\-lh2}՜>Sػ,C6IcnAqܵΟ$Y(= wOS(#gu0Dpv:~',(caؾdPQmqLgF)d\+ğ&v[+;tk"E!8΀9U MWl7ֽ=n"p3)PeD "VY>ްL{{`>Arữ R%*6f( `B@~Rr &Q_nIxT ("O*Q`;/1^.v<+hCc0Ic 0W<&vǞnKs zy߷[GВ)J[`14ɔӢF9wOh 0S!!z |ٰD7@$ W㾾Y's `ڭ-6``IqC2Ncx8dփG<.`ݯzbVuH@zrYPZz^zMk$j}Sͯt8Z'Y ?fX G@,RQ4AuጅؔMg{9XYX!س9J ږqz6`foi9~ȡ}0b@?'I'ƍY7 Ӹ''dYhPq۶uBtZcRkX)OQ6]o#f(}x_֍LKlt*@Sf3Kq a((QJr啑H)OF-@JG٬0oǰē*$T!t R5 Kgأn*!Yİ Igj>_ nf[\W[̯*knH|.V,]E{BkzFs[㠀Ui& ,}>qppfLS[;ǶfIdꝝ*ç|g뵑2 endstream endobj 839 0 obj <> stream xY[F~xe&̝IՇ\TiYx{{&ld 3߹38$8Xn$1RmSX\tf,,b/6wX+EUΈ ۺ* ./ *amHn>yR1:)`fdUm<}G@ ^FvWd̢ƢHeuߦ7T{Uۼic_)z op7HVM/ !,5Q,₄ư`t7kՒW˺q~׼gEPs]f.۪:Y1)NDy=i q&e3e &RV:Dmc͵ $yLY7}3g'!.>6@eUFeNΆ٣9a0^X,A)N'Zw35Vȷ8C!kDX y{"~#{|qfY 3MW ?qzc\ !F8bѥ uŌ8QoEJ L( _kwm^4W5>Э}yAdF(nuCJ@ hYd/v9Bw[T/ؽΑnEڶZMg0Um.2 ay1&$; nXr T"ƻ`;:0̐h9Nh4:f]ܗLIJo_#mlHr2iښX9t&؆paZgTM{3t;&oMs斟νᛣ9n<7LJ}n#-%n+΍T~aRmUmFya^i6 厤 3 o7~5"a6?$>e9/U-PU2w w@k4yis~*Z҄RS_m3;,~y[[j X2K:ݞma;f-"}0= W@KWpt{='҉Yh:&اG c|%!\'FyMmo <7 Xl}1M 5IMiSQ]h~NҪMޚS(NQNp躦z3TBTWdL @5G'θ?Մi؞m[M2H'j8>JGK*U⌁y@8WyԋPy\FLԙn,'{>WpGte&~3AL~[8~&H-2үI endstream endobj 842 0 obj <> stream xYKW{Y*/6:p0drrH 1)ԼTuuS9ذf뫪ۊWFd=pYx$g+.Y0^ )1ݟ:RFEşl~#ҮcEӡlD᳞7,*V9˸vZh[CۙZ0Ŋ% p(Gv%R-CHÌ0gjѲ/~?HE6)޴-ʇVQQܱ\ډEʤP܆qx1/t׷`{)4sGSŲTd82,$ߢl;(Dn暠+B]oƥcqK3)Әǩd39t'vU?TeH=Z΂]O %f [ػAÀgX gc׆!@<҃X. s#Kr׳9 ׮``JӮ*n,e PI-d'a2#˘I|.v(54[|F>HJ&dJdy&=u3:N$ٱpдVslߎ 0Xk^W6Y\Uz93լ^7T(0R hM>Pм]Lm9X$5عX)[mKd&` dJ?%-!Z9ƛ29z9I<RĹ JԴD"]ۄ)41bvtpP90EnHeh:-{{d·jY6kqACowf#]C՞\7obht/09l\$t87ѓ_lɳg2 pdA|O9* :5Jsޒ.$ʧ[?Ӵ ?~g2ecB$0e-@_>FJ7X1ݵzU@;sw0dΙ^@l<{qv - 7wv(>a3KO,~t?~4 Dufnt'YI.^Q\@ǿKtW㵤4mL7, GLwő/^cɥ=ШO?+uM⾜xk|q{g+.D㦞\VΣj.Vv)Miٌ^d2j N֚ :/V;NOW+/'X endstream endobj 845 0 obj <> stream xXms4ί0UK>0B{0|p|ϾھMʒ|EnRڦ0$3Yv8;VηS!q?tJhL'yny= pģߥm*P7-r*'$rۺ* ՄtC1Can!DQa0T#8MPit6}3a|,j6[bjI#Dp<8fԢݜ1Ƭfn) _k5o7u)]0ؑ6p׵دme"p9[kgn:Iz,o;#vN*^Ff2nT4 B%H.suËNs5ï:-yQh-_5{9[<4lEެ6;'eˉ}s[s. yxz$eA$PNl@Ax^z/}}X2"!AQ 8=YZ#4˪պțs>j5 fg@Q{EU(hm ba̝Ŧײ2^"w+ VCRHr+yӪTSjwX4/%u&0Ȱ-/ mٲ6˥ֶ6_y} i-2( d z{'t2zf`ۻ'.9.[ߵ`ps^j&֐?d" `&e":`N3?::>xO^MP()|D%$@ nk.8#m& ?@dsQD(QEƦi dFCXmb'ZprDA} 8}"]KnBC!ҡβIq=YoOmc1X3/x-x(hᣁQI.::頌Q(!|1% h G թ2m%d5&lrN]^$FV0s(-` #`>0(ڊM*'I_|grF[& d4?2RqOtHXTS?-3pZ[Tr M0)IH1)څҀbͦh=_EX 8A8n20V|g'мtH` M ׳zYA`W| Q$ D76 4[{z](Tߨĸ-'trIaΛUIU% d3Ë#UV0ch8#1$VĽI&hĒ?W9*P|VӺT M~"ڧOxf#^kaLaAt޶zdVuJyK9ւ؇f fWJFk 9/*+EAFf{Ð6&A!#(Q~611~>u~o w endstream endobj 848 0 obj <> stream xX[o6~߯[by> Ho64{r"@Jr`ߡHʒM6nHQѼw>$[{bf# eI`꽺"`I֍׍7UQTjsCֺmh䯶EZ.^D)à[("6mWMVwYUzeV D!c&@48~Imҥ"LKLxvj vI#Icw wCPEfٺd.9b*}|.I"Τe]~UO."D< *G0TYKň`ldE<0 Xȑ$1Ċ!"Ωt!vQD{XtHʹc09#" 04FBʁTI*"LI)=N*dR,mJWYB"LTޮ(S7D2<Fek,sU8F܀c$ /_&UoIi$lclwIQi;K6GJ3u]ϐ )UKd0IV {2 0kRtNVƏ4){ONPݠ dj?X`LÓ ƢAr=ky'KD"28 Y>xg CBzv\,P [qlZסFy>h] ,z۵Ch81o8K?ZC|w5C=7WI1ضsE(GFJ#@%9ӬygA>Y;m ATUy0&ԍ'#)˂d襏f)Hj9>Hp㈺>0?CR= FrSU,n/R;@q6NWyҤuʒ\p:/F.^/r)u ?/IT¦dcRS5{0W& 18C3dw 1siPȃ:bI&)0&pY ]NK"^(:U2]q8B[eΚ 㷅n.de!B_ai*ur:c )f}{Œi/vf`0 naFz?p,c|!MLv oFEJLժQAa$uqlڶ V΂ Q–Nܠͼ4F}_T ѷ"F+׬{lj,]o>0` MmҼ9@Y$א%ޅN 9Q(՛_WUQo<h´djtlW[uV?ւKJ aGJh ʘ?%.IDpx^~1$]2ǘt"eWSy͍<?p r<1E7Y-[⚶jvR>ݍw7 endstream endobj 851 0 obj <> stream xڽY[oF~[Oΰ}jYURۨ/>$ ^Z378CbKmp/>/?H)NjvtA0pF7Q P⦸M?满+X"-W|Mao%Mkk}&vIet$KIѬ0p֌WԊgHn=ed$zzH^f,}ٿ{&x")PdҦ;(LSf5obDXwj] H]8i$Mw @YXzJ"S:?+*ETFvۺߪ~7>>GȤ?y,ba^qLn(^84m2C|!h!hIyPe0AS)y֓X#[Ƈ/×XbHb&AVj֮n?O16T̄B,5ɷ5M@Wuջf߬T!`#Wn[.4z z 9s$u#w~V1M2N!!7v针4Zǰ{l k뙄/R>lFX#rqbFr=UjM]ː6]F -wVQ!Δqf?eB[\f// KX0a|Q+p="{jZU-7Z0V)-Z?SAɋfI_#r4&F3+ZLM! R,)h[4:#[Kg9j-hG-b]M*0WX5=8^h.ۉs/H&9v+ <;qL9uQV%&AYG > stream xڽYn}WP˾'L &a%g_qo`ftusD\M#{Bp2sl19hpD#ZRɣtK 'f&uvx(^q}1:=5#cޜo=z)`p>nS9JN`f Av7PC#x)~Φ|굟WGn#f?t endstream endobj 857 0 obj <> stream xڭZ[s~!ĝLڜf}m1dDJ1-ӫ-EA)Ѵ^kJJU++؞浐$,O?LBHlvTg|aGYz S2 RsPHk ȴCV5Zr63ͩVTNo\hR~\)+~Z䒔FZĬAR؎KH>@% /7ER"bѳ%2o`i{+ W6o3+)O, 23ӵ)&h9r]ɼMrfhn0@ {Q  fy4PiED*Ql|G]P* *ui?vgʐD>5 R//8ٌSi0o!޹rkpFݠ*x1&Ci xdOPkGL*Pf 1Ybϥ^V #V< :<ϽL>. }M~mÝHP; #)!Hc{jǦw _ߧn·;˶ˎ5)EO1tq4/YZUΦ?jH2I%!PJy[z/77B1ڃߎE=SH UP4Ĥ1}Gِ;`Ftɜ2eS O$Pk!rVBЅ0⾁7o~:JV 'ai q r=l |ry?= Oo9}p#9K~m#Mҩ̥ZD7y !,Lb~9 5qUJrk9åM!/H4=GXMQV©\ZdW&ejQ(<+R*A A,Wɜ BNĻW8UyqzD2*в:H|bt4= luYyML?+֒pnK2̊i,#‹!5]AN?4`|'[:Š# Lt'06G2nE^DF-a#ص^3@#(gE@ZuԬP 20CQ%$VT=JT~-] `qTѲ kVԤTK#? rn]P^7 9}%`u8z\X[K BUԦb 8V\؃ C(ۺޝ3VLbz0WQyȔyskj' gTV8Ǡ(7H3+ ΩN 2_a/-0KqL89xaX( QUMHMoe5e>Wh+j9:7N!oNjM113z7X+ߜ )&O5sc˷M;lXZXF׸HW P**Rv9r=:>yJ@]w endstream endobj 860 0 obj <> stream xڭXn8}߯P )淶ImE\`+tbTGwxEmy93sf8s`LJ؉ tN})vK'PJg% 3䐀84} ͪ|]eYW|Lϫv-g/G7ߔTOhL.׫yݪdpO<+VZ|}8q:ecuV+$&) Cx[VI=U'  {=ڮQݺ:(@A<Б57{'])2َ͊2a9[mvPNKc'Ap(-/ㄨb0vףh|:+Y)ȏz`SH0 qvY.d@ SЇ-|lAH/^r]v2 P@jz$T6qNpE!xI*;sl4BBׅ! IldQ4mJSwY$j+1:XfmJ4─iZ\mZRtY7H?A$Hg6.yo +8ߤu & ,7v!)d!JFoa Y!@%SZ$2\Phk12YgC` rYY=zS?w.J#NIDtR;^ %P/POZYZ)kXi*SE֪aB6y;mSIŢ`7ͶdVݭvͦʳӣbv^hD^":@~ndlWΝCQGȇ#p PNT\;]k( ,6cSr/ w39*Pp윹 cۻvSk! REW}#]N~.5l*S}lդ9=oGJM!FF'=.~7JnG5+Q%u?*"GO= " ~Ql-pvaU]֨^wUΪŠyb>8ߙnJjP1uCB <;@*_xRM:mT^{}M0~qëre?5MJpWQZLueO֏o}g0X/g S=]D:sԿTW?i3y7s0mˏxly"=S~:WOǺ'E?Xl}J[B9I&a௒> stream xYr}Wؔ1;IS̒ DI%6咪AOϙݧɿ`G仫w4!$!!EB*y\5ì]Kś]9OJ?i7Cy:C]7L\%D r[ۤ3Oyǖg $%*7C]&(OEJ;\~,r$He~MA)!, ǿqY)`nX:qI;wCxKXo#(ҹC^ ܩO+`޺G)x:cĚwv̜5|O̒VXKn.ʈKQIgAv$O,%"X_i 9:y#$5b@#Z^)9OvMlݐUrʩoޫ&fK%qcۘy\7MQV|mCuϲ2 xiyu-mŎob'EjN.=ԥɒK$hJH,leL}|«F ('OqT",NFpA_mW@ީyd#$OrJ[RM*Y!_Uƪk 2 CԨZiRY9FB/j,;+?Sma `[2)f+1,?~ի^VǶ@AԫF3lzrcEj0h)Aʕi) e8Ι4ĶSNiv>SlwOc[{M=g{a'@v'e?ޟX'/*D0RSz 9>`ITen;%*GTvAӫęL=I@jDH@{ݒNUaR#\¯Q#HbHD[T]&V&:Vy9I>F]MJ_Z/nM,6}WivPWrӬ4>&`,pk` 󩵌Wi#&rd lhNP bhS-s 0+ $r+U@xF@ P,&Ji`^{pQ ylm>M١&5U锏j6k(.sT򳦆-DW~V ӷ,7Q Ų@Xo^Mu z,E:|CenLP8S!QN<~r:=#xFMخza?;8} t9gXhx;gQ!T )vPLPQRiCÏMr}: jknY¡U]cF/ #){Pl739ȉb'6^}g-q{jR`؊s|RǾ;gƍtڍُ iz U/ GK!LyNE-b"a6<)$pVhMiZnj}:TxbHRoI6&cHVpcZqۍ9m&:xx\@:&C=f=_cS fA_ZYb sLj12?|'&Nҩ d&w`s m&!Z\]EK^;y~$Sq{} T3s綝jf > stream xYm_aC#'F|KM.Hq ZEq gɎ$pHdSm%Q< }W U&_՟nV߼+")nPf)Zv󗕐ew|iK)_~MshquֱȣԘv-h~󞣰dKUrM_uqߺTdR[sp՚7]lw+8w;B=A-SᮐpopƔ{Ap,/u!̙.r/ i!s&Hm9x J~ve<23df@nܙδ NLKb.HIzwmH ΈE Ҭ}{ӆ(9 po2ɢ]id0tfH] BHXNᓏ᳥uKtx !3k@f!S|Zܟ ;tN{23i"rܵ'pI耢? Pζ0r&[棅;h6f o Mfe!e]0>$OGC7i&;Ué[\"htx~PCmZ c"\M> ev=#{J2.4(2]pWB3lSX0S΂ &֣Z9-k1a( )s@j\oiQ^\0f/["B`$ă@nANY]A`b'I&9:K#ށ5b2JV}D{b'zwrT1k6@NEڐ̾s[١+E6N!quhV{YPC1H%ųJRJ&&GU TZ,0W DO-\o+e$S.5Ğ< gH$Mr | P V83o$`YԘwr ؽA_6 01"<i>>8% 9>Xg P H t&A 6`V)Ak): de*KޛGSAo"e94 2=>)h ͑Yu8YJ/Ȧ5 )zbm8}usU=|m;o[)ަ޲= `$F}da$!bݿ؊+Ȅ2ĔhT!9pG+84\@+V' Du?" t5/06n=o)CH|©'O?}X:0`SA=B"Nyt7穛$sזx偲F $@NP̞KB鼵_KlF  U5o4cEq"ܕ홍k Pʡɤ#ˉJRޒ(R r sXs"`d4MS~OtCͲ'+5y{jlѣ9: #tP409sx+{9=%l12̀OT+o}ؾ gUeK;(I^ӫ")R7+V-7Ų`9UCub1ӳ%^ny$=/?֥b^KqK11bHFb0B\gF;3NJLȳcKQ q"vS'8 )p3ä,xrGިE=Bk|E uG{t-:Q4{g*uw0^v6 *ۣrC3CCAO2~v>eLdSVI3> stream xXYo~qKqڼL2AjAJ]v_۝!?sjql ЌvU*@ e?}24&yr," .Wۛ0nqCz !/lmKákk\`yݮX~X_ $ O7dԫ_)gPD"':հ[E x~>\ze_ٍo dʍɔyƥa x?]͛O"pJc'$e_fόޚn? <;՟l^}E9Q(:O Z:8R"wzzj]XP~"mڇF+{ݗAU+Y3S~PeQ׎r1,x%kЫ j(6Z}幑CjsOjW5*Jn3f ,X+k3 ~=TZEE}TѦ´`X j lڧ~h;zYLY 4 I,tVDᾂfj~k?`bbX>kC sUuj_I,qX`EoTJu'{:fǘ ]uFUo2Q˶&qb.t2S[n4y١wH)[ǘO(}n}YP_-NHx0_tOCi{ꤿ'z21,?:@3:dYjv2SIy>էjmQbb9k>ʘgV2bc`47r\(OExV׾:j ~pcAATSc#uLE>j"!qBG,%wLi[8<GWBzGe/%Taq8a2yIm96^O%?7ދ.,% ,=$y4QRE|!?EþFJm6a)l)#vuqgXhfEu].;YA-Al\ XzsЌ*z=Q?q ;*M|=i$IWyho[u'/}Nż䑃Ɣģ CIڽ1n#qn㒙g |[8s:C#̙HMU+F@e{g6~1=y%czUyukF,94xl^1H<.ᶈt! =B<&DԪ}lT ~(7KGz˯e1 C](ZUݧ_$ش^kӭ_$]{+ fĥS2 ?TxπO֋7#O{cfA:z,1ܘUm&)IH( Sljɲls*rNEd"E?'D 7#][ V,'s ڼ`  .M5H_d^p;LYfw=?!C1@,u"<vj9 :YLHBځb0_`O%I8dy/x*ëUCSW¸0Nu2?o(GQhhC sh01u2#+!rrG ǦEB?f"b%o ]`=eO;irLgݵn8dզWt5F>;@,~89IFR9}ys瓻? /ش]$_J/Bf_xI44g|Иy2C:RDd|W> endstream endobj 872 0 obj <> stream xXOFkթAFW:6U"H59v;Mܛc3~h+>^?~Co^{/C g=LQb|z8]Jg'RT/^VEU5RﾪFz#"FQ}q%xKցŘ)^zʗM^櫞`"J&[-21a8Fr7#XY7y9;uf>.1J0Y3,rC ] XF|7VNBb,t2\Ԉbs2/aeMԪo\$yĒ< rzzC=.Y,<LEX)8;AEH́3m pR;tc? r,Bak!bHcco *ԫӢjxF<[qjDY5zQ"LɺD..gX 2xB9H!/H+PA,'6u1 @SKlOT ExX&3"zFB!wI"ۜCT):<5Yȼd AxH(6i@GōȀ0c/K ڵ#Vҳz$>u H.'"wDF~{V@8}%2ޥ0ժ2O~MgR_jn\j[&V;"YkIğ4DvwL'Ŧ=\;.VՕerWfI>-.-=C S=.c}i> stream xY[~SBdCOEh4ZHU}(zE /p\s0#+E6w7o_(9YV$[rnoű:e%:'?}afxR[^SmS 5o7?8H2 M);kbXalaUsnM[_X\Jm.t&JQ$%H/{9YxoPT'%!(7B/9Vf-HP_7δwfITBM a?. )"F~H)Hd2jW:r+6C1p]xʑA*pCgyR:4t U-z&vM{p~_nq7nfNU&?H@ #.;>jaA1(iE-r'$0n;ݶzkްwf9 ! .N/!N*`.JΉT`k*xN%>R4Ty8o6Se3*ڽ56ʽ頝;PP`n@~t S~EW{(b$LçA ,e"Q`̳FD'OV]NafKJcrAFTNAּoqϺB.[\D`>(,-}y%SNDgB_cQq:ϳd\qLc4uz9BX`X G0(f}El3 - `Dfq "ٟBB*c9D48V0c@EU6s`^55;yꊻJ~SB]aQ\)/:N]|oٱ~ZɋV"pxm]a%iiJiF`ڍ:3RE.}`hChv*E`etEЗZ/p˵;PUunF&cHl$~dڀiɩGri$#&ofDq9xıu:WN 4ΕD@Q qGV`%x9+V:J[,P{3[2^m':%*>3 %!*], !11EƮA %I t=ܠeO箍`97p9iVv|+N{\0({bSWߛ֌Z)2Vy7ӝk VBB@W$rvU F{Y,7гgɢ#^=SPlZ\ k wJ_u) o98*yn[-t rtvn>p}P싡yiQבTh[c"_Q<}[vAmۥdns;J_CA<m]K`4-t5+lu_5*Vb?6;xgJx gm RR<5 Bkg#>Cińz#%җ1bpZ-~d78C > \oG}T)F"cb(z!EH i~|(Jwm`UJ_j{W\U5Ǥ΍.â4K4)/[ٌ5W^leG} dD.zly}ѱ1~Bҷ?|Pz0oD'Zr W_3+3 =1(ߝ?P&Rtꊕ6pvCV7#脒͡ش ݹyM,qhd4_v6yUu`l?hzi artIETsҁ.U*qSfIX_ V=f-;қLAA3dirfWߥ9?M';|;Գu]/wz^2'u硙9'nNFƞ jt/mQ 2?Cz;ΐ_ f7L endstream endobj 878 0 obj <> stream xY[s~ϯX`I؝6j"3 JhH@ E $Cc .;o^d/$l/^/yC8CyvS38\$D_$%_뻧?~xL)IQoa7}S5KZufe$2o`,Zu굤,G 3#_\$J\XͥC.dK$(5܏>1Gr8snwzqR :f݆)&nK]z_ʘD/@EgJc3Hmn)y0\QB&X'}!g.؀?9u~ISĤl" PLN!01eAHd Qymv?a~ɹMR%48D 4W.5>&bʗ*oJk;X0"I@^ $2ڮV"EYI0ΦŻ&[m_5lfK H 'M}+u&$Y`,"HnM3D<($[r{M[Q1 ǻPXқQَX?x4FXg71~T((Q96R+@Z'qu庱Ͷ91 95fԴ徨\̏Uu| -"l"9' ʆm]߭5 2|ߴ^a#L@2߀vI [ggCVծ sAʇ- ,㵄"Wa^T5ȇΛ\L@ 24t@ 9@d[]# T؀ܴ8=,8p_i}uC%,G$'cېw@\ykz E]b`0aIephfpY/F3JaVsNXb kVbb ˱ڊ=ʂP0hd|0gJ7HJB4&JRQ;->v]GLc@OT^\k"Wl&F-Yt.%ʍnܶ6 Z)U֪ i,g/vN>g2‚.)< WvЯފ~Eb/atC2ge7ve:ƮˀLj5'WuB \Q#>4eT&`꣨Nu_ݛ{\BtW ~4ꦕfyC JQjM˶l$p>}djBҠ&@g ^m㬲dESAt 蹜 ~f0$p$L tP0Wi7-ӛO,B\NIE&&/yߵ?ڥ4cHʐwYœ7mB!/CLZ;dabZHl+* 7p[+mS7e=/L=gCDM4jM]sY P.s#R M.AZ`9]d-~b#>XVs'=1 >{( zT)J͏KRUnf׎{@^^nfaP0ހs#bg|?5,GHX _oZw[bTvij9a",sń0#vՅ | 3at<P}{xٱn"Ȝ\zQ땻'Ao^bvTH:ŧۄyDCٳ{A SEO ϵgL3qdV iHkw X<ۮ̪6U5zVEfDW LQ>(xs >ccj$Y{򈍋>1Ū1xyHӑp)@Mˇ[@#<#gz@,gۛr%N`sr> stream xڵX[o6~߯[-bśD aÂ=bӶGJeIЎbh y||Nh? 6ysd IW4Z&T%Jj1}2y*_2!Dj#Һ]v팕wM7cEz?tK"$/Tew_^R*ΆqOe" {nW@:9y^47qv𨭎;} qۉhy);:ih ?X8%8N\ߙ(4ֵ]A8w /GsLe,/U5Ê2!jjZ2$1/ TJ\*đR})&DX[7 n߄G<٣)?F5+aj8#  Pxm6QUD2_-Ho3Y RM]Sſu<QjH1$0 ,|_"$t0cA%.pJZz;VXꚔU)+x?1o`~yJ޴Q ˾u:.g`!@='Q&}~*O~f穡"» 7d77z|eejAݡ4-hdG05^zk ͪ >XϨ⪀̕:<]j[aϬC9}1>a0Wm:߫,"*J8 Kǀ􇋱 S("Kw{h PFXȠ(! g)Ej*XZ]R_C7~'o>t4q2'nH(16adbɨTӚ yQF>I>)YD JmvE'6!x7 E1"!7T% 2P!lc|M݆hXIG8,plv  %)|葾qN1N;CCȗr癄 A%pd4lpn OE{b v -mp2F-{ֈ ׆xw-aKA"p{iN,Ck`p:dGC;v橣Rq'7RLƚ2."% KG5mZcvftcޠn7o#iL0lF]Wn;rC$̴ !J lΛd<֨*;VFȼFlff-ZvI o&F04P|?F z}'1'ʟSҊ#y}[;Lg:ipǟ} ŋ/qGq}?h4msW0λ|>ȴ-74 ?n?|B" endstream endobj 884 0 obj <> stream xY[6~ȣ`am(Ӗ(ò=X%mҁ!-˧ss$x&bqx,p$Ëf(cb~,Y~X ))o_}2Fy7o~z̢_`߾j1IWȨ7RZYx ]E/yܭcE%;7eCg^ZCҘ@nn!*S&V_j?<]K΢ҽGdH7!1!1 1h>'dpDCf k.a[\" !LPd,wq);W9Vk;[?B7on>I,E"כwlBj'B[]y$§4tQ!^q&3OL/A 4h@y&Cw hP$R""¤ b;E1FфD˯0L8:Ǜc]{bКdڂ죪 >YbNJbs,+rN8QLgrwndFy#Lrhi[,*̃gЦ)hU:c^kaLRij" P1ݘkHi{?#+;c(eWhkbJb9 --\;$jj sO~R>T. G$ =Knvp} sGRGFցkn}2_-?74N endstream endobj 887 0 obj <> stream xڕ=O0w~ōT>B6Dj EJ8== o A0*^ l*X P 'B hpdwl{!ZUq"b~ㄘoj۵2lf(V6]r{ \\=z*tY%c̿)NNX} !b+˯ KhPOcB~"?:> stream xS(T0T0BCs# 2PHU4g endstream endobj 893 0 obj <> stream xڵZKWt X%N0/:9*JڒKĒ@]1>N%e1=g||fgf_>Y|v4SRD&3.Y~k$R9oϸak;kuRfr{B'"M֕bR%_g 2)48s. ittZ}2*HM$%j}~8*xAr*l7pʣzwD?tH:.LxL {qOLA&SOv,o (m;GhfӂRE8 )iaDBL,ZnvU疮wvY,Ou8T+NT:.,we H&vYӕxH 90ꐟ+޼̅j9ϺbU7e0_(2Y,ɍ6StO.N"$ 6Y:Hִ+JX[nqGI}AJ3knDNz˖"h:Z&_Y^Keܮ<[3pbws=\u `>d92_IVMK0:8m-j/CeR{i!R7n%гxF%>iکixuѿEy_.2!Cs dcI-m0>\?r^\ &9mmvٖH?X 6|~V !Ov> &cl> y|=paM Und&Q}x-2`Zz.GʳbKQ7a3Մ5 yzxH#>MP%[zC] 108k˥+{Xftg51|P|0 ٔX08 ̄%Q5u&dBjgָS.!b6?a%f2% ]f}+/M`nCajT/aq¬( VTa,0xvByA2@7eWŘ m!W v昨5d8Q[HFք3;֮!9@U%q{`҂ܠLy "]=ё7zg>}åc;c@)ҞlZŽIl+mq5dvao{#@ ewPՈ2)W椐NpgȔ-=ȱ]fͲr>]"ٶl7}wK]?{jOM_f|mqZD.[ )/s'|KQ X[qx]0-q$NI G2uP]/,X[s45jkZhYo,IafS}2Ca|n̫ <ř3t6Xx ^̀fA.n mBx Y׎!s(0P{]ǓAx2NK꫇7x7 uG$'zp?}35hxف/p 9mtjuK`rSʹJhQ;<ǚv ){SQY,(%a4Ug]:m~SjK)@F5`AwIP+B[X8$;ɫpaY/ݙ񝍇nrYP#08ĴV/"80zrlC{[x=Igb WnaTC@ى)ҔR\~csB G@aw=S?ߢb5PB\ f݃B[* Oڀ,s: y#7tC\XUzR!DL'72Ѫ H0IEfhX԰t!thYE|sI /@΄hB9iy8?ݧ_54CY;ɨsF@SFrrΊǟ۲'~7)[!VR /e>ŀs C(q';2b,A_^PY?7T|ޭT 迾:#i ڪL[=*{h{#vh~'TdlPZ_oo|sw 'yA- 6|Y N{lC_HGw-J O+.F2i֡ۺ4a"#cS6\i)[sQ^~Wp;*-uv-Ȩj. hxX{TssKw4?< 8I- QUnBf-?A7Ս\W>9q=L^?!#"73 &C#& }A x}!עw T]<C -I:?dOm n endstream endobj 896 0 obj <> stream xڝZKW(>IUCxd|.S.o*L 3bDjGƋڙv`7ϯэb?4͟?m64'U^ͧ -7JOmY%vӆqF5~w|[w{;/SXlndze6Iw;GhIYM&*RRax=ڣe'J]4IU$/+G>:rVv?e{n>DH:}dᮟۘ~n?~ʄVq/(!œ"|Cݠr/g˱IA*S?dݧ [ekj@/+#ʭnpPq~F_NWسq?XB=ͯC=9pY]PPJ7d{e)!%UWr%SNTeᾼQTO;عUۻŎkYI3R;J F́+"ߣSsqL@j2R7/۬cX{oË}͠a? #k":ZB,KP©+zLFL{ӛܤs!DRE} em*5d!vԚ0 (X\'(3EhEI $M&e6*U)CKS9f}A#y:W=.\NCC?;<94Z7D*G mӢ_H=O2]Bqm BGrCLTVFeMM /UR*j.ُP8p޾:ڥ߸* q" Uטnِۜ >lc<̬Q`hvqޛTv®S~?@vF4tOwF>j/eX0,AVw{g !{]B[kT,km­zCd20 )mA]Ľ%7v֋0SF^x=`ejK:w,+#.%&JqZ z@-{AȤXp3h\I!qW0(+Pnry*^qk0KBf^!UP{[@#J0*f:k\qڦ3KE8Јm;fuX$#$8#ZTy EES-#>f]|['M;RßW^DbNʸ}SGyj% z)O8xmUPdȒigA0GJ';´ma#ͨ!mF@+*zJ& K; >뀬 I# fr<ЂG1GL?T Xy;=uy'k4)STrE.rz{jB$tUkN+cc1 Nc9QMql.žF*cjS4^;@a|'cЊ2{SpM7-",Z+\o:ENW>3٣Qv]Δ1Xy; AR.aKz9cJy VR-K7˪[ nWA>^3DavfPRL;S K\q&W Q~/WD.sXuf<(Δivs['+h؈k&FMҡQ!aņlN=L%Oh> $ %pZQ?N Q@=CN zBBd|V,S%TefA-n8ksk7d%)KҲiyѲX }d2kjW+,ǹ(ߢY=j4f rW*KPފ "4W&i՝CGL|WJXVbGF-d;:8~ƻ$ !!  7@lecBelb4=֏ॐQ1*JV*t!Qƅ/auBpѮ3_^)?F7U2uײGS 5Ԯ:*Jh~b]|MIz5R Pa՛qP.c+TI+Yu$- qwZɔ ŗg*DqT&Yͭ*W$R!b }S>|9EEX@(_1%ɘk=6#"jO02<ƀ=AFf\~p,Q9#r.+ufs/*Hoo.P[À2EmSAU"BűM22$q iJ)qu3J \[Vl ueU`/ٷ=v Smƾ}.p(c3mo'"W\fHᏞQ*Ah] z-9.D}9nKoTYC$]n2^WU"vmzUE=뱟&m̙¿u E4=i BRT7-ZRT ު>}B-o6*pͤ!t&!U!|[U?O/ cjཅ1|9$.2u5TBnaʦ7J<_?q' endstream endobj 899 0 obj <> stream xZYF~_G `>OI` u~2Ř?daɧ9-9tqV5U0ℍ?$F)չBC_ǰ`ݾ9T}ݽb6L "1?7lQgu30e~-).%2yfVC7j(+Ίu|SSxa^fjmӇW·pN)? |<XA3 b.mY,LSI^G_ba71Yb>DBx?q8ob<*J(Yzna]#Ձ 'Lw\c)C0~j%>8¬pM``* mU|ң0mqix! Uɟ{J+,љ,1<']]GW \]S"C`mg8K¿2 ">=W0ytPıR7.]("r|AEk?Ǐ<5^I?"V85 MAasZ*X6E\H ~?􏖽.J"10u$b (F]x[d(}2DH pqcgc»̘^5&KF lޒ:5K&M_ə͟ y+!o ijm? }uaT@&ɯX pcL 0=%E";5Ǫ :xM c З1Ȓ[HO43;+vr 5E(雪mHtF}}:]n[1r9'2 i [ͪI1?d ke73ǂzl̫6@a9ŸqEM(8Hs$OuaR^_>vu턻vS2L.9>ȥAp7kp/BQSLcQ)&~RكoM'l3?xJ$-]KcĈL;uQ KPWWBWH%z #M4ӣvasg@#[7yF9uͰFDeh: PЪb;A7mxzKvn5  A웶:PO-CFm/֘BzI@1/fԩ;XL0nR0㷔rM4xjui*cট W@sVD^Iԓ,Y@l-'ܜ,ڤƆ(I{>)ypqlaWOKXhl/zSfz8j 4Z_4#<-⯿cC.^LTF*[zST4Y[OV曶Uʀ};iG &og9q xe-&=ʰwYXs6,!Z>5_q|}*R:bFJof0M[p2븻fcJh>{WG- gI(mq م AF9fp jއ@J^jh7ߖ Xj+CnbsZG_þ&^$*%> WGsASn)HCO\`Ľ0p\K0$U#E#0Fr"(1dJd8BG^p]G,ఋn"5-L\>X ʘGe3d-.)|"ܣDQ8}KB^6 - W(5wד9a-(cT\h"> stream xZ[~#X ><9n\(R-q%rCRqdNbp89lj?m~|nHUʐ azswx[P#uC-b4ξ7c_U:yv|t;t[D͎Rn7{h^.JK̦*bwXAT v۔HdӶ-*).v i^n~rSylFdE"JFj>Nc*JNm;wL;c}7v v@@=hIF'7q+DQ~~a'Y=4ae=PO9)ބV%NpU;48+P/=zYA€ LqVhFS ) ,ѦA8Y>C*»v|hґB 6"0]z28C0v(*o߽pMM.^R#rDXnSmUDȁ{@URf_Y;|<ֿQ<93nV`+pS]2)eI|:کE~ﶆAqrW^$9*UJv+j2C*kU@6`&N%BKxzt C&j1Ŵ'9B/aG$z`gIYi:5 ?:s)plN],R&Th B*ppŊS- `)?t?*!D6 f;)]t7)kdea+LV JQujrshGwk? nZz紃HKG9qeB9үT#?=l͟jCTH4b=HW%wƀVsAaBiVaXd{Crt(7f`~ ^O+8eLB>!+9CʒU86+h=|cx9'UtfXge5\RוUZҀ+d07RDzΆŮ"XDK=t]_ȳِ4W0 4E_&0-o&(4^x`Զ30a.ndY=.!/yml`#RfBXt\r K*U2_Lrnnfg6d.v -a; t=, t!mيg-ѱ>|U,kt^jir ZOT{-I g3+a) _!N#'/QfiS𜊯 PW.l/Uǩ}f'r$p7;E=4{CnK8U@:H,& z.η"C*+f84E3I{ڗm~Pz  TķU'ϴ Zԏ9?;CҞQNe0T܃r:m\x̦vDJw|A {É'=|[tIm?Vs|IƏ~5V7umg;3ֻd#DGJѢ2痵8^I/,bݸc{:5lH7j͟_24{<1!ekTHnf7svcyw?\ RMîO >͝Js٧IJ|5Bb21P|=dULw"l  =DI̲pp,٠5VYfyÝky=|naY\'ZBٽ<3.?fe BZa뙺|FnX5FJķ~r?X77tq}Y>f+D 6"*`#N 6 D9|['+j7v}z§7:?дsԺHףslF/*fS|yҠتWX!)cF38o9P4w< Fw] -W N n+#61Vv 6qj endstream endobj 905 0 obj <> stream xZKܸW'ps%ic rp 9ʪ$>U,Rzhb=N8w?|;Y |N(V|eT>;(z3cݵw|N 2a Gs '?N 8~YwaZ,֌ ;t!ʙr[u0jqPiphp\gUH˴o3+fN]Tf,3yBU[Y#Uw~l܁.eԻXQO #ʫstRPz߻ҌS3fynie_׃dakڰ(Qrw(·)[Up zb(}i_e Et~+B(5*6.4ljAf$821^ĥ8e\DVMy;d~oHomTk< L(Ò_%U-Ue`yEvq@h*sTagnp)r sP9)ȲbMk-0L@? g!)yV * 8k&n 4VoM Zn sq&Zcy1010e+ϡqch{q/gIkrYJ?w=(;n4͖-"tAr ;u5jzk F_>${>zTK c.hMɐca@p`SJgL;Lz9\=-լ8:ek'GGcE,&`8C`f<>65Jo_gb:m3 &tCB``rJZ&LĔm&krLzGt ;1@$ۭЊJFVL C0F_Ect L<>:譼Cx]Zl>S ꁺ$z;O"fԛ$ 1\g6`3۵d]ڡ-Bnܮ)?$u+\yZCh9h,aL07t}ejS=({G=tJ3a;>oH0'A/<Jh]`G q`.}uօȷ4w E- ]"ZY)VׁNLfMy^3&e_ճ +z7^UGQ\]e.Ft~V_]Db$˫Yk:J0=$(Ag:8ݿ&ACiNqVq~-DP>ި$V{34 Un( ~힨BD-+^3͵#"zcam:bΔo:dbcG:qD(ݬS=1ubْEKcixO;;TlHVԾ;Lh`wU]HLKRj%[ *hk9HFt%0ҍg,+PQݡᐹ1 (0Tŵ ߁jEF!q2>(Z ,>8l^X@9]LU26hn].-k6OAr1z#~SZo~]wxaqB2+HNuj窲лwOjyn2qJn~`0@Aw/+yyknjneY(ErKO׷:\ۏ![\,RS{G2rҕ.Cۼuȧjq; gr ]h+M]s E(^UYLbhsJÈ`1ȃSEN!_u IW +? endstream endobj 908 0 obj <> stream xڽYYsܸ~ϯpR8qacSJJM6做H吳$G} ԑRAll~M ?Iśiۏbc9\7tjjewNdr2VQoqƥw*;+fvh}0]^-[Gc?xʴ;&%IB2!aMxdv]>DDHp9BÄ D! 9nf]V!b\0.OmҬi7G4 L :5_ךf[ W;?%O/oʪBGdg{3.FcSUAb'|e%"ܚ;5iD]q2 0c45QKnjG>@4b}ciڎYn9 #,ְmX҅1v%ptQdj @HZW b oz3߿__Dcݗů:r|Y:dRZhPDf%*$,&>AQ`ұ(Z|L2_`&xӜ֜t=n8Et[~՟u6|:s_|:BX9vw E|/'Bni x 1TԦ0"Lpf8>E{0?T^j `C)auLX87]KT6xlز 1o;r p<̵C@ş&LyNe:IUqm7߾`k #m`+'3qh q//'kPSSƄǭT%E8]0XExh ^G 4]2&W rzjNU*Seݛ[@XuG\k )wTxx}Q\ᑒO+'}7]Fe Ũη\ŖC;Bl- :Jj&dٛLʤgdz [@~H_4D΢:έ; 6}sD#[7и{ِ'4Wh c Kmvl>||LRFNNAS-Ȃ!e\e;(B- n|Si?%R<޸Ӂx4ol(J: y盋SlS'+(ޠ?(DRMe妪X'v,IҧJU"c"Qav60ͨf'wM*òxd'#ZܛC7&rU08|-N]P, c&s{VRx> stream xYKWfi$#8h.g1]}qBGuu=.EFƯNvY*RdA8qݶgbvJBek{#oqk"KŤ=F2 ŹO< f=`tzJ~ 6pJ}P5 qrED s|>1£F)Q[ɳxfXnI0YG#'M W C'1"JdI2j?A>`3%>YE2%ŠDóݩj Ń'~I2f'/.2seUWr)G#Xei_ _]uҔSh&H1e5,ԣxٌ2_2ZJuI\L%٬tz:ҙqR˺}XG6Ty dH6P$y:O#URL\}l!Ma]dɫT/]楩XS#o*gHudt% $9{i[8CS; R~,/J "9F LQ8T}a+hۦs[Ax9~ӿq endstream endobj 914 0 obj <> stream xڽZKoW4riķ}MAb&a[V[q*IQ6v.EɪW_}SmJ6ÿr;m=T%˺|TvS VKeyǿmoc7?}f+(~Otp: =^t-rjnI[Y3[I'|>43$صx2_ѡuz/WI.7,+'0pWk%%"f7[ܞ]jԇL4fllө:hÙh&m٢FZζRnBJI5n`|Ab_Jx NSnŢbR(ߋVj?(U4K3ޮn1K i,7c8LX3%_Z W0]sw-iׂ#߹ܭ*vpu1D;6w $i/2:c7h\΋owzKp}N_ҽW&mr6К ;7'aQ09.Ыm߁>u$6Έ +yyP]}sjr a ^>QK&wdΗ&5+uˮF j# 5ӵKoO-[T¤oWD $VF%5 FQ0w91*thRUἬaܰB]6s,+epw$.@G1ТC*oq9j:7af12 5M{/ҋnA3k.4Gx5-n^xc zBR7-ӘKX2+< kƊNZy Lb>n~0 fQgV6FW(76?gLU)M0]Ld5&/~=.^y0;`,PkLX,Lu>+< ؇0DZ5l oYE8ά}^MnL;V?ּ8{Uvy@ANe^C Grl }Ipp<k  ^vkA rO&(f1swhlpu_Cדz9rڼd;/iL4RM~f7K˔ Af* PۥUّq?ef|Trm9 W/3@P3C]ڗI 6sنz_j&6-Pp;F.ý}vS&K B ԯ`'=Pi8tվRagB?d1K"ZsbFJi4i4] HvMέ;˶١=ˆ<sYXmESVU/laԄIC x0H`Tuq eL9,WCg_ͯELz͙bj%,U}K B"̘R.#L2^ѿr mBh,v,Hc5R:܂/MȅٲŽw WAvu]큏PyCbe;4v, ){41>i>x e)*e*) Wە}.d9 )?L:Z!wk#։H)>*+Zdz¾dt$W 7aHqO{ /Ǟ52jBֿj\m;t"lO-h ؓDT# BKNZI9nv$4Tfv7xZ;h.wX ,xLB'GfroM0 5.W>L1œ'[eDS9b"),ʪSr|i&#f^r}J\1! *[6Lqcl]%e&J6ꉿ:+&⵱k~0ڰ&?+u2FiM Z_`S3ti[1tzi+} M 2CՙZu"=v/;)T[IUmLJQ 2r>*qW~)gpnx$WѲt_-#!^tvmMyVPB~sJ(Db'h ehZ2'e8VSpa p״~4T6%v50*o-S.ie-l!Κ)K=HYULe yx8@>,'0ru oTY`+f5#v.6y|1Y.m>о.IONh%%rWuzR+aWT>PfAS<1zx, EMCy5,βfA.CV R'{:D{r4~9 '1YV*O)祬xuV޾~fgU&gΪ qMrz^:[c8?T+06t*#wqi|uMRGtnYf\ˉ_^`aܷ#mcֆ/r |l]!f_&\|G^뤌Ereŧ⬮`;}S7το%Xη#{c{?oa;v7?m+k)Wg.^sΧh ߭<;Cw<>+DJ:?Pf5u\:~p?_ө[Lֻ?( ]BC3,^t r[Q /wڝ9n7b$+3@SQJY?2._XE(1S{)@~! endstream endobj 917 0 obj <> stream xڥZYo~ϯ#z>vI le@KIԊxȏOU_jMKH}W\b+ le8QVW̮ Nݿ=;7BFH)_ǿ$SD  2/u#&zm#ISFq oxiin0p7}<|O}1K/>Cl ip}~ưj]pԆq +^6ǹp5<,EMk41Z„pA ]7n >1\E6sƾ[4?Y7LzqG\ŋ S$EajWAX5_Ϡ$E]MJ\|3B:;tet/|]+ٴL:-n8ʤ)tꏟ}ϟ?~_Y=YpXMJ8Jӹemϊ Lj zq-?9wiw;P&{m?kXp>\-١4oR@A*P*?,I3CeU n=w;=6o~"E5>v]zMj6Kҙ+TRW E3s}I m3J62,mQF؏JU޹;?w;0 Tgh~5b [ G@H~NZ ;H0|qbij2N^;,2zӅ~: 7Q.p70"Lk}y{iI  IX$jhAeQh +X0llz/ѷR%U"  bV,~t84&-I-o".(*oKhKweN]m'EMɹoյ3_sUczkcQ{m\)+RYzs%3@YETWf)MY n* arK[( UYּ HO9$x PH -Z0( fqs|#]yt){Im=4'% 7`F26lͯ$ q @+$X JAxɮxE\m%Һ?t^SAˬ1侸bc ڴGy3y&1^_1'ɯI9!I9-1'Էi( [nP(noP@XÂ!Im!| 4Hx5Mv,Ӊ"فAwt,s~%MwDMAHwE̞< }$9x eܶ61 pޅ.Kڀqzr<85 E^ u = U71N[L g,!«4Vp)´H ߽gm fjI@ݓ:8мKl$ͯ0C(0O%n|c{.a!_>]l?k׆_Iz,DRQUJ_ aZp .@uW3 &s.h·%wy~yM(kf2mԎc7ηvbfceB&f7HkZОm9RLD@̊[I 5 P92QD9<iEHﾣI,CJ n:o B[]|ʱNSSx1sJÍ%L=DXDz_ nG蔁ʜ1hy (X6շ}]{ +rB35)R_zÚrX .gu"IjH or~<\U0yKc]A޿7I.Tkf^kkk+Ք4tm6PykЦQ;w]RX$b[" 'ЅhI C?l'9\Zc%A{Qpb$й7^T$/f}e @9 ք"$3`0X.;lb> stream xWYo6~Ї#@RX-} t--@|ҖƦ gӣ^KG^ͼ[шQNʣG9E͖ [(&dP/e,(0nMemI&#8hbl>>hbni8j.3涮}o^^hqz5w 14vCoΏ _??CM߿*6F2K Ikl*qjwzn]U~ľlVaIG؍mG:9tGCBh;|y|7 endstream endobj 923 0 obj <> stream xڭY[۸~[e4fx 6HQNd[S %GL<,y$(&i<\P ~cv}yo|>V nżc6jΊ0qlTe{vD%B3Տ-g%"KIn"*B}$d[W4kP9٧+(TՖmzfX]@HLE,E2]T4DMtHs[1sE_U8*t+}͛ItӔʼnޣX=<|ю:zԄ\ 2TՈvCY1xaȹ4•cX=I`8^+@(^A/Й`Ƚy }s<ΊB.wnػFy>5.cuߐ#-;B5Zܸ}WF/{==~{mxe#G췶'6yAڨת?'T]{_3&w~Th=3w۾WUM$M39o fغ?Q$#R?r?z@q:zգ|)ݦǺ]y~v!vz(]'M0PNCs _hZC[-:t%0̠\,aA,J\oXj]>/%r`RqI.pd2v}UVa\mz`UTs7&,&KT9#xR3H1}m{8qwm9W"qk#ќfB.{d}ܿ P"J$HM' '=IeY4(&` 4P6g3 1KFS<`6擀L9 7t \Us@F-r -.-hE#ẒeDwçK* _L} i~n{@]b//kO260 lNԗӶl@d\SGۭÒ@Y^c> stream xڭYo_'~jqW8P\Ak3ͦ~);w(6X93fMO?omhI겦 I-𯂗bog8?v9/韮t;lv|q;t[V dw& KLӳqؚ]2S!eIfͻfgOxr``9NZܟr4a3݈xqjLf?u^/HU՛D.'NJ75 2}nU 3jJLT~k 0uf0ep{x7r1%U6;bQ4}R&Iघ [P۝T[GW/ȵk]_@9ؼA |3`*YVɬ2!s[>bs&Ƕ;Nf't9>lV_wnf=iNʹ&9[ߚU܌W0r;41UMl7Ys`0^A2p#lsPR}3PIxgu?9 d-$ֿ΋ڣ|23lp*؉бSla_,8qgJF`Yh_JR 0}75S(HvWl%ZnŶZк}zݿڀ^㐩[G7yB``5Nb\&̾q-$DkBU=o.@C,^ EmV/35G$vxk=.{v`7Olp>mRDiy5* .@Ice;Gp~pX'2^͒!6x5 ?:6)sY%CIFt4^A%oT&X477k^JWpN]kM |, w骸C( S',mD?pMw5-{sZO&\jwAK,0hD 63~3%^^ؽβp#냖vS hVMD>QI6e_$.ot܋ș)f㒒oa$ -n}uO+DTJꋺYVRIгLosT%#uٟ,qȯʂGz1'2E) 98єzIYF*?z(0u?w#}ӽKb*nBl k6?0D@ `XɒGOolvZ,o |M7ƹ/NxiU{įxy^-9Tbkߡ_g>Vzkvc k} lLf ͯ][3(J@s|?}y1_se*[F\}*{]KiE/߻؅ϻ@(w1E]l1,^xQv3wr endstream endobj 929 0 obj <> stream xZ[o~0eŊ#]t1fۇ.oM4%L`~|y(ręSQ8$J"Ρ}AB3+/OlA b K킚 Xm|[U9q !+)u,e!$+ؽ Ga8*m3 }YJ]]~Ud,Dj EA_.<6f˻%Y2 ?q]K[ʵ{6% e(??/%K:>?vuIT:u]ySͬ#3lvnnR \b]s*$SHUOmES2(K3}}w²Ǹ V78|*kEᩇxXSfW'm'JdԛR zNnZpo.(XjkAQm.$z_G1ѢId=Fd/S1ʈt0;DL4 4 G)?}i 䝡Qm 8rNp"Iy\I$>0w7CP8of1`2 D"1H)Vqa9-xA8lxJ-`"EH¾=T(Jχ.8mDUj,93Q>s 78Q@υBB‹m07iM%_@z[,fi)jIs"J,9D!fR 2Ó++N9ξhnND:&B˜H_]-fy7`t LYD{r7bZOʳͻSMzObqvB٤l"d6c{R3x1î {?]/Tw+{PC+ 5p ^gYq nH0cV[?cN]//P6~·>pRmA?EݸW(HCEE};R(uox1?I{|$,&]C8(nT]=4{'P$P}'DQ֎?P9=txK˜K||\-~. endstream endobj 932 0 obj <> stream xڭX[oܸ~ﯘGMaċDE tM׋ "n郬mudECJL'ECsw?4on6oފ ϙ mxUmnd^n}FHNJ݁{wj|;l];_NTYsyVlty+G︩Pf rgOϕnpV0Q2^ x܏y[FGLҭoS J 1!< a"mșΫN(&P2Hށ*$Ϛ5s[-~Qu׎m}l[m JxI Zݩd`d#ZBg,[*3clI@۟ls dュGoxyi[~i}so>ss3K4cCh;S-E2+S쀚y$aZH'9^FSJU>_r@ɴ 3ў =]= ?gß#:ZM>S!rJePrhTEvx:M;i< !FAY^ D=Goey0C*`m7H(v-/{:ch;` ` v9+HdcQ%+ȣnBBpeO4>@\=dϗn»rGeP?-=`Vbw pCqO5f؃;냽}Ėy[ Ҡ% u\ؓCѥW|<~OҧҌ|?g8"| ۉr$[:|J`MS}N ƍ"aC`ODae߮߳D@.$I V;Mi2"U Dw-էӹ?5UɔK=ػr1w8bdF`]CR3E)yQdoe fPu|3k8"Cݥbm&LLB\Pq?(O & #Kż2U>E_'S-'EE1(x LM 3P"W *aJ4&ThpNM?_.Z?~}tM$\]Wξy&Ed Xf_d9@5D?-qaӋ !TJ`ɠOB/UM61wOAˡET:0}d&,v}HktZQz4ẗHmʾ1"laL%U82|^ʃ\RP`>?AVSw:cԊӬyIաR},yQIZ2 ݔ,<[*>ݙMv@ b|sr[쀵M"zϴɔ! JtG+H,P0zڻ4>pE9%gU&+dy:0@@ivӑyU 9=@5x [_ugˀMe," I\v z P (p |ro4Fs Оo3Ҡ ƿ֪ux@Աn\v藴1d槖i,敢y*n4T)dR`@LRqP?A>sh t(֒|rD_E3uv%"]>y \zAZH釻XaBi }T_YݤWMjgȜh9=R-NKvzό>%>Vs 觜 Ż9=xE.$Sm'7#ͲE)>^ZH@IqZ\ tӁJ<$JWܐC, j=͏dP3qT?ށ)`pYxʞA2{Gri ܎"Z8x%8$Hv!Pٍ_ƫgX9y%s?a9\);Bb2d =F%{^7+KP5:k/8z[QgAzBesMby?Zr*J15>gwb2ݳ!JGO="֩+s\'D,sRk:"^fifId"6q|{7?y-$ endstream endobj 935 0 obj <> stream xXKoFW>h rHMoP@Q+(E$G}Pʔ-n@vfvጣD~$RpTgћ4"8'l," K7=y,nfvu7NꝸV7qQƈ pC,^52SY: v;ܗn˿sxTF8!"\x M&Ivaer/Bry1/5ywCZθNۮf{UN#Wƈ|p+~-gqp$KA>QD$4tW76PE?~q.dz+Yw@[Z5 FڲvnZyEݔY )=ˁdU0nߏA1&~w9{^ :{8((#ƽ8"7 T"]Q׺>^ןV&șyqΑ v'.?Чhg$a't.} W3"-dhݸАm:> E7EWsy4pG/&Yjԝn~ǮUnZhE zݱS_p/n=ϡ\|&[q#vzcÑ. :: a!Ra\{3(4dT<_up _YG[eS1j [Kl̦m9S0%T9*'^Ɋ#jd 0)}lty1\Հ_)m҉8GL²to> stream x[[~Of;hmPbٛ=rHRN@E p yV?誁J3׬߮hClc zך7ob9|~>m8Ë|p8ݵXӆvOL/yӛFXbmmO?>(*$3+4ԗ}S!T~o]D& *oGQق*EVp;ꢚPC`6wJʲlSǚwplh 7(kVp_*vކn@~hk o{yɗz|Ug/ݻGlIuuRB17FPkx_K{OG0 Wz8\/u If۞n{Z&,ΨǢ + Y6:Fk'1".&ew#4Ru1&O_V)~X)y(*9G8s& ν|2Up>ײ%8D/v'o=-nxCV2^&V.ᆮqФ 4Ds674 y 'u;lg\P_JsՔ0.IeU# ]cS Qq<.\\u?NÒc`0M(,'k8T D5,ۜUVmo\jd]!۪ #Ъ†̆q0& }9~aB{LGmstr0lik8:k`, q/P|ӴVhg7 5h`~iWƧp*Ǖ#| xTxxE&!7WZ4)&_?T{刲Bw7n:==|9q}w5^_:fp;VD7חnbusAV 2Ϭ"Ex l0~z1\q$8;Ӳ|b@ߖ 4LGf ?iD|( U4[bͨ(" ZZε!xM4FNTK`ڋ7 _McE-ʸ&G4 n~[7\եH1[o uM3"|^PAi2;|;ZEL_"CKw܆%Yaraֲ Y$84\% (kAXL.bĂՇdt*QqM;va =Ͻ\OpI`r]r뗻vtC{yw[:{ _\pt|C]񁝅!ɬxĄ]@Jk ԯӇ͘HQʸȻ4`zQE6AD8 'MeFf5,#2>A4@R^1[1P} u31^(蚩,b"a%f8l1wEWca[qc+cС8$*NC(yn[?,I)=~Z} Qx~߽6\[|uQA`Լz$,ں `V8zeqE-MPp69s:19<)Ů{no:4 .mUI>DTpw`,:t2g^~HOlxC- uu}O.+\RC}& 0\E)2:+qyweq7%2q{ ͜hO9lddC'&e8f;LX{õIqP;U}ZJɺxg8>nb>Ogp:LU.Ib%,TG>aCĕ Z'2[q J~Bl%*k2?Wd:X&ni*_D&%, af(UMoBBɄJzj.]V:awơf~KpmQy2W%<dyUx1:Y:%fܤJ).X$0QaC![U걹ϴb>q@%4""}k.W]z?00._fLy˘[`Ҡu܋:.|>5SfW`fbf"-ӄw߆{?S Fqq/l:Š4쵧eL]Nfw%Vx#]Z.!me\Z%XF3&~YI &MX6K#Oᓀ*W0׽I\- .y^6%FSmq8K\ A/&%&L!3W\59 mFήGۢ)alq[gmL= Ehdձ CEt/ 4UZxnJ>`p0)̔ d ̳/\!G7Ҙݔ[Q 3K$1&0Qى>xOFzF1Ǚ}#+_uK@RKij?t[KҤ|Y&9]Z`%`i3fgQjlLSqGgBduD 8^wb@љu$SATB_zT9K klbqgs q huJIr \giR.p%1L p#Zx'VrƑY\Z# ΀,¬.m+ú߶ Qq> stream xڽX[oF~_!`Bm1[,6ְ[GyZEQTxI3g"Epxf;g,.fb)-3̸dJfտMfK)臹n`%ʺ{LE2q Re_,J̪'8-^UEf~U^^}xEVw+VzYK嚞ѹݦ\\cJW|Ƃke}F\\1,|Bp a{7k׉!V㻧<^1,PrÓ! RqmoqNC+Hc6$LP!Nۚ$dH]Y{+40(,´9  VP_퀼| kD"#eTL?^rZ8dHSLW'2X7|\|$j0v6 X$8tڀ`^^cԗiGZ  ]A>k2:8y7U^F+ +-+'Lr,41BrQH-@ݙiLvc?JY 1Ќal!dEn8D%!bQd:)Hs*Į*d2$n`q^x"&t(uoF?He_]U:4jt};.M%XMJ Z$>NB\ⳮ̧mٚ栾Ŝ=MA۫ő7zu#7>zΩVWZ:|i{k϶ Gm*4*9N>#A9 ޲^Vc$=)[MnJ-t2 Gw"OyL :.IT#ȇ.m ˹2~4}{_xҐ?◇wO7w }zaz<μ~sIbг\M % hą.? >ַ'?,x56ng4Ft9tI spb/:P|qv$`*yݘE}pUWg Mg*C x;:k3Wdt >`Hs-'sqWXg`2x1$F»5͔ϡ\q+.0FiGU&;ӊx 'jY6Jz(#oma+'[6u<\ՒPySTɣ1go'cjeTŭ)9??3囅9  GD'󱲭3u[Ū-enJ)xL iH_w. (GL[Zvn@5|[IOPћ}z՝hWb0lFj*_s)0iy'_IMt lJa3 ÿ[g% 9uT> stream xVo0~_ȴԧ6kLmTm%fJpҵkDٲ?}w~p[FKhF l! <10E=1&A(AKjdq5)lX1q,ʶsIdbe̓q͢F=cİgmM]ߵ6#) #ʬ2A$0_mzyd`=~Fԡ"04U 5u4s:n 1SyF}cD(ΟiїY5:Z| .)e̵UD"/r/nyFcl1\B+n,D`Foyh#K%𣨹,?P܈P 0F6;hi0ilk(OP} `|ē2 4=OR T6_m="Bڥq4UZT 0ru])ˆ":3s4).q0ͯ i w%\Frg¿v6oe5Wg dP΋;@y F:/6ҹP) \ST{ސnUXn?L)֧Fe8.RMg(Iy9=FT`ݒvv:_0]Z"|b<{_:A񼌊tA(T N ϋ2K`I"{J}YHea^*oP+ZwIWwu'oP/iIYv^t7泥]& endstream endobj 947 0 obj <> stream xڭZKsWHFXAlnVM.T8L[I/)ͬ}"(C2;5S xu_7m6nϛm~o%Z{ܰz=мqBTNJY} wH:cuNԚ(-7;i2ֵ߆"oʹnGPА(t}*F 7;.ڵՄAҼZQsp:yjbf LDn합 mN!Vס~x~K : 1V^;^WL]:?o ԛ*~5v>T-'T=h%B7OЫշC;.5t.OKt_JU^ێE}NS0z\0>&:+f3)ѢCn PlԌO뛳مp݂z%4UjQtퟺ>BA&v|}tnq->?^46ͨa"N/1t1-AEz៟lC.ٝ$vc0< ZcAg-Jŭ$~9%T1M -`-fF,9~k^+IJr͡Z ^g(}['8 lmGݱ9:j8B51ڄϓGn:FTXV'G7 "Z!(C .x@KN.<7s `G^s6ھ>˓Uq#BW) uMU)cg|q:[_?4O< ŽUu~vG@+-1[+R}8V)]#ͺ Xa@e@cw.so쪂5緶2۩҅U^ehn"]Fx ŮEO7!\F(Y j~u_1*(ދ4G:H5v~xuq5cJ, Th` !52 hy*s*rih/+`9QJ<.Y Di@_Qo*z ̲x(uortP;:&,P>6OWd'o}kh(Yj"X Y>C&,e3h]ohMqF$ix藁T8* *3+J =+yPgU$cd1D$< ~=\Pߒ/MnK&g!f d2os3pc6mmm8 za!Joڕ&|_{pk> :&"ɵjo[!MPV${K{3L7NiuѠ<)%2>#i>yK?#4E^ɗ̊=(`B`Bt]̠aaS3d^&O;ł=D"! 0CT+FfBU|&gZ͎''yMDP E@d{p9 G3zG0 J2(5cfϱVHSh2\^H]l9.\b.XLo"lx nlǣܰsy3h|X"=su>vU΁T̅,ٽ07h z.;G>erNe8@շɿgdVR w=zwϡ_=#bn~d.b~HD%>6ǩ|t`wk6FdfF]l2!u*_{<~J5)g!xmnH0]؎UbSOb;Uun -T-|Vf"K.6)[ &?7[m.YԭN2+xq1"?^Yζ/NΟ iґǑbyoE "PVdbE,/H@CX];typ/tpG_yyy}Hq9Be/ endstream endobj 950 0 obj <> stream xڵXmo6_!&5+e teȲ-V>6S %Ow#)dm^tOx&v<=Xe<_< dJPr1kS `I"a5ξ8=?La^.i4l*<)-~_M" )'" [uNURrT_>=}g2 Xq+_kFx0$Uٴn6`]cp7EEU>-QؚWWk.ܪm4fUrz]%Y-՛q:+S;jo%KZ~ 7c^*t,RC5^[ kصf\Sw!j;31~Т{@E% ƋДnʌySd2DqA!p2-5y[8|=jeBƴN|Q!X$ZYAP$\0"Kòriwu鴩Ap;m~ ӑvU=e#ɼ-72>ja$lv0>z N'ΗU3H }hjӈE BY%ԃp'g,@``*a9xd`R* 3ّ]P,˲A2ޫu61P{>l蒉O{@PbW;-wZ6Db;J|k¸TkڼcklL CC@dV/О|QWKdžHi=;:@Ut(z[#Z9/f"21 ^HLԥV6v+$R> (bTL2>C1ydӡ4C)@2 M󽳦JRDQZi |pqDvUj h5 ڑbSȻԡ,%غip7{r W <28#:l׶'ڞKy6uby] =TLۀBitu01Z(e[] JX3/ӣo̪6 :=a[ߋ{{}>AS+z[3-p1%qrćm l:=>q .avq88r5`` AA­7Վ6]FfEvq(=x~q$#x^L8>e`0qv6;>~kv9="j3@e7n {0sv .&#fGѠw#4n !C`8OAGSDn}Ǻ@$C8aDy?F3::ǞJt1,-~8\/Y6$ /wec ;=@|Td]2E<*ӄ|O_rt7~97+[{L7F~r FLl=:MvM yDZ<ݫ~ endstream endobj 953 0 obj <> stream xW[o6~߯Xdk$x U1Tɢ+QMǗCYl7h"x"G`Ǘ?;s8/}1vG(FN2^ҍ`//w""O'!h$ SuԶQ(p F0ֺҶ*!ڜ Vyx˕"lnf$p Y I OD# X/"90u7eVslk#=>VUVM b4i0A1Ċ,Èzki^%s҄\#D}ɫWF-Y7Fe=deԂUPvZ]޾yZWLC; E@KWsC4$c]p, `jzBU=:/Ŧ^ǧ>t vOQ5 '*>YrJu>7G$+7&TͩB {LכlTW'hڇl M ;P JdynĂvD]{߈|0 T fqM1_JT'o۽͊T[m ȷ&vǨ̖+º6A u#F':ۍ'nZI:;év1ṫ;E<tiA8"p{F@Hncj q̅LDooA"-qtҷ?@^X|ELH#Mqd3i@hqfXdthNLnFL)]"OvХ~)D4aɟX[oc32MfRcvwG )>ٻ>ՙd(f,uh jq_0 q0kz.7(e344Xa6֒8 y7<nd\j26É;{ Ե:]#BQCfm M2N?}kp endstream endobj 956 0 obj <> stream xڥYYo~ϯ#zl`w֛88 A<eH )m ?>U]$[nI f늯bWܯ~_}XqWV\\e"Y )XJ؍?vRFE%Ow_]>ÁFE帯ڵH/ryFp2Q9˸2gzcő ]Y@t;V[[7wY*.ɵ9!j@:]֎{Ka$a 3n=X^k"ʮiN@&?x5!%$*+>J~`LV& _?,5qaW"/mٵXwm;:ySSC5XޞSGNasnۅpt%h!6x >ۧ'4. ~,^$ok ՌZLS,á+wX&A]Hr*'A#GY֋nwzۘ`d)1ng%RK2ΒIc F#Edn֛\kzڐ)*Y(#/cv'ӌ .ʢEBFF> =3nauygDұ<+KYSn7Eg=RJ d%K{mEG>0]^2*G?U%]pmC6e3q8Gzrgg)ɠyT:!$1s܋4 />kFtxk &L*l<#$G($;;:)@zOvgCX髯cW[f/(@.!_:}DI'@>69a}QSJ&x%r :u;O oGa҄ɒ 5!LEj Z璳@@Hh_eKF[=_ E fvqoފ!1ǬrҰ5e6+uksm<0aڦ``^Nqwuǎ~csiE^L-Df>Zx&hZ{~^cabEzc1hLsFuiR^%͔u,R,~X#9~'d I] $*׻ 4pse&z.?3o/qv8N1=7i0=4b-1ƶ(D]|)qRȌR^ÁoW,l}{3dwmm%)8EA l~26ӪCY8yvWs5Cu1UPM]KiixAj%Zv'@R3X%&S8Ph-LX:p\(TJNK&)€8:v_* MSKhTa;A1$?> stream xڵWM6W!21D#A 4I-A5HTvrHYhI 1Hc͛!{Q/K#z{]E I9IeѠQ| [aOVWd.3bؗNl{:sk8(\!(CjN XB(:Io +N9ڇW_g?p3tlX^צ^݊Raʆ9I :n6I%Ng>{6 ÆKH3E^vFf=t^tژ"EPC׸:w%sa~#nBm%:YNfc~ `.Y9|ƂCB0͜ ܉wz9# $؅[+۴ơV \n͸^EWyD3 lؒjn4J .Er)3 彜Lw1 315|#6Lhs^quy㨾=8Ts,%PcN<)JY].sSD3@ec@U;kZe͕Ǣ+=pv~8\QXv~6j՘dgTТ;*y?V"?pb?t} ~P_=C`oޟ]Mw ɉLϞ꽀zCaVG5&",fE}Nc6%R`=Jwb5Ph̭o V0"$Ԓg\K(>@@Z\a\όUlp8]jSUQthmjf2p?'k;?A4)66c!{$o&O}$. *ս߫{;եŔ` |wC&p m3G_0vvXݟ}SĶz}^ endstream endobj 962 0 obj <> stream xڥYmo_o5/")})Cq駦YI%W7ɡ?3RMp3/^g%VWnכJp\nW"[ 4[l(ay%d*xWF)O|vq[od]ծMF'77n lҜe"u{&]o/PVMSUw@ɇ8 q7?F'c5^ܬsE;W=ĒNLeFB7HIRzŮ.Ɍec(GQ5]SK(y^]LH׻}S5 6kIV22pn67,=QSm6K:ՙ`T9},PxA9&ʃ*֜,1:jdfaywuS4ql9 ^^#[d~lUdkjO9R&Bۿ[s3%xwۤ\Ռ .ݷ. qp&AJ6ҤB\ȗ3 hۢi^tJ2Iz:yRʢIJ ?=&U>_>}7f,%?2~#(xq@ ]?3`,dC1ʽ+ ]eT3.#ħkz  @vSrhmG/&n⣱Oڹ%nͷ/iʑAJH c}&6 ~˧pSʈ_bU19 5ázGc]I[ VeꦡA{RѴz.Hc9Қ`qZqыf|`\QdwKb 0OTm, @fay BūQW+(YHr2uT{Cm1eFƳYH|?}-}Aߺh#XEKgЛtW+7qu~O}ˬyRf= 6XM(]ye $|xA= wG[g I Ծ9715MUaטUP ݝ-B4[`)0!0󁊢?.u2f#@$߉bx mP+Vz-Mf)upl\w*A=S~%5a6YݜSZ&ޑ;/gztּޒIlKͤ+Wxp̩5>i"i{*8 :LQGl,}pEcNZAUz92&V<//Vl`=M_XU=ގ(ڸ/ᴗ6bʸoy%Haqwwf.N:4nyJgi@O`f=ق'4tP BK fP\ZRU`<9u&m1ɧ4 > stream xWKo6WV Xqŧ .6Em=((%WI!Ĉ6R8ijf8(#Q h^f ]o##I!tt5pWORy%"r6HPIW`(pݷ|n5RQMm熐 #e^ ,,d\];]]?$5ꀿ]wpvEMy<D 5WoCFSL(PQ(D"X;\ 'mBTFcN>`@6ISc.q+4b[-E(I*?>}c˸Oa]5MV=yL W%x ΂%3!SW|Om2V*֤(%ŚΜlVWO~s_5d#!:Wg53G-k8{܎3ⓈHL$1 Q#x!{"9:u=7AB)R %~MޭdXeq}z6k_"4WDS%ɕWƔt,m|[%q7|DBNQ X#C$sP,*À)q,Q@, a;Jן#,&݀mHL=oN$vBRR0^XQp 1=ᕧ)۪9t5 sXN$}*~~Q:囿PU endstream endobj 968 0 obj <> stream xVKo8 r D,@M,oquM5$ҕ)KiHT'F pHqfy}EGД%z@//)"NEH bH<QFt4w{:\M|Ƙ 矀xRɖu^o4ֻR zM'%;T퓈8f tUQu3CʽYN:N8Ibt^Bjk%2Q(8[Z _´X/'@hR1Ri GL_Ĕp <%2|ZfaP0`-+W2 @xJ"Ī.ڂLUVʋGf[!A3= hvyfElB8uR|Oma6y kyWj,wU l32V%<ѯ8k%7y+Hw:X/ƚ*w]`lÆH},]jLT~1WVԿC>r@Dݴ޺%ҩ Pi3<lv2|^CU1@:܌>X3 4p:{A6o]P]$v1ר{}ḱCJc@'/wsӏ˜ ~=q6~7 SEkP mAo+]F+$}j`G¾ZmkSyƿgmf4s!Bu2pē6(Vgۡi]ލH3n}CCvlB3dO~̯mIq endstream endobj 971 0 obj <> stream xZKWH6M8$L8dD"i1SMI3H]uWwϻ?p8ŻNv%}S(x?0ƢI6M *`bũywXôzփu`)J03c( _AQ8j.sc[7/KXL"zmG0Pƈ:A#,Gd KV*WMg/*$ZsqAή̞*#S~Wn܃Zծ04Y^g!hLgNV f2~Y/$~c8P. sl^~2/]Y-}R!#!E$s"/+dôdf^fGc27]Ah4 v? ;IYCUvEpׅcpJXz+.\dU+U;(mYyiڡ!HսYLodrW\d-_ B\}H2:>lVxk~PL:[·c6$VOwWu5$@?Ե *d#o0RmO /הOGw\.?_rsN>Wb/"Mc0N }+Kd`R䠇[ZZA:4`G@[S}NZI"+₼"2i2 IR{nLUn_͍z{ȑs*%Dz9Mz)ɦ!xσ=!:eݠ?F~#J*BL-)/͞h0 nu4?)5 ߩ)`Q!K,|1V0%rQ\Od&7d,bT H#΋XuGX![g`c!ca: sV3d'V27t([SڛXo뢳-sMr%:˂JO6=S3D}jpƪ /92m[UbCa$^r'^`pr'SA~6 vK.ĺ")OPٴ\fGO&W57\ǪP}ޕT,JU%/[f!o-f#VSکM2|k[t<ݰ3qE㉽ >Q7 >g#R1{.(:ctm~lٳB *$-Rhjt/e\=4)Ŗۦ~R'$.v6,C!Tw|boɷ5<}v >OL?id>3DqҺ1 leUgHR˩4gJ:ySk*zvcC;N6vg Y]tCڬ˪JU@%ȉGb$Q=Mz{{F62ņs4R٤\.~ ᧄMIs&8I]Ik3okkp/4Q–3x$ peٻ#}r q.M|ihcןKcC%.P |m_)# 9f~7`Vo7u endstream endobj 974 0 obj <> stream xڭ[s~_G=!OI_.MINCYm6w Jrs7Cbo7<|{͏WU>p{%snZ7B VƧJJXtA7ꞟ=ޫ-W.6fbb+w><5˕joԂ U24/܇֓YU\߬R5F#@Ǿ=?<ϡco!H7/Ka ݱMwހ"pcZ $EM =\SЇav54RV֛nmW h{TGxny98?xG{6_q{~ &wb E;2RTLZ+hAS}6caZp+ M} ;MbDUFUbŕau0bm36+!jyvocJVXphۮ4LyiVfaelf_ֳ8!ڃOO4`X-EP^QńQqCC]xkhޮьWv hԮw^R,$ Y'/4mv\Pɲ~( 6}U\&D/?ӄͶݷ6D0bxYnhTSqh0hP9siq#J:5(&hU{ Qtxv3 ֋qNVT?.'Yhe6[_cEYϪS/) 8nW1d~Z>5+e%h>3iU;԰m$fU2h>}&59aZ^|I+ZJ ^w.~D%ĒYZ_,47PEcXI[ S.:rD;NDdÄ;JЦ|J:s%LK,3g&,غ!E{ 3]l$A]V j>Ql#3P_2Зoɂd?,>bfS_)Y:6uX G\Lj%;´ LD52-} .h)ڄ7gd20hbl=9 :آ'2Ó`(X`R[tD'VV lO{L8 OX&XP2.C=QtP%t y;*_vΧ_BD-Z,!24郂_i2H.ݘ}J7y] R o(+Tr&(sB( lOyAPN\NĐ[qXeKq4F.ä훠"\`% x__P-w)=խ )OmX?HK% ڂJ:w!B:Ckʍ}@۾@2Zz7E[[Sv}4lCE"A;郙qf+XG ׼ 3:jnIREtMf )gY_1 Q(C^דO;=]0Нrzh|[K&<aaW_Bs?ׁSh>W\Mb Xy..<2uw;2MVbˊUYtYHWKJ*-[+^єyB0.EUS(G2CXn38HbmE7|,d\+L:'ӱmNJH2C]sS~+Y7$  #؇zʙCLG@&+6Fpl~ =|ֈI\^1!Aez@QG R;þKෞF^qG/ɴ9UEd0J0[t.Д<嬮5X֠Oõa8JJI%HzeMmhhfa:!zV(& % vuߪ2ߩ5;" ׾u7JI^_Qʌp dWyT.i0No'DO=)Ȥ G9Q ˾:Y*m>/M; PzH vI5V'[# rP\B=H aI}(kVwelz& A>"S2\61K咮>Ȁ{EEs۞\h OǗ%XIh 0P^DK-##pMbYkH~Bʩ.6Ȕi2|;)h |U-(wEvK|}Ú9B#!$N|>Ƞ|^pZ3JTt!%0X?'bbVqLM'Vj0Wu݁*l:~ _@>L^4Lqp;F Ad.i +>~Yx>z.0d583ʞ܇{ XO Np??NDL$qMOp`VVge_R?][_eyWh1h?# te:<3m|-˳g$cH*'*M?ƪ3-}%ÅLQ8Ӡ'TF9{X8J|j*15aߨhb!4_l6 ih@48O\%Mi,>(VdR̪+3jܢ|639bdYŸ;Ɉ2B_8=יӉ:sɦ)WUq:f%p~g) @̆e9NOg]VU[V)+4$#% S uPG7 ._HPIJoʊ X@;xPe+Jx`L 1j )/gH\^OQ=9Uv{4% :vH :_0; $NRYdig+M1/ cb8?q9:[L-̳&$8M%+A3 V^wݪo> stream xڭWn6}W Hm[HQ->+nB+m$kER:b s9sf8>{C^Jy{xE9ʱwpa,΋7|׋6)~<cl_=( (({jk iL"R/dya6]eƄ"v6f,̶Ue/G4^Dhl.S/aWH2`H"hX=V>( |F OESՄqTAE)n 郱+D@cPy6RÑ+TٽJ, i"@c+>(UuYሮʓƦiŕh#N1$سD=}yR*?W~ ؙVrfqRnLIäBjm-qm]7m}ݗZE'DM8e }ׯo٣Y6Xl8] #Q!|ykxe*1g_ ʏSrD o7mL*^L~dc. jUrL24!Nxx%}Ӛ`7ݐjC":9F %[KJ6`}r&zYYGmgVfs{oDh~g y0ǰ(Ao'/lJtEGTO}})jtEl\(' )D4MÎeٺdhm#P, ^,[o+G4c#2'HRxd2 a;\i⠴ݴ0eNG/8FOS!)`JJk8J(B wU%*O5P< lR& E>˺u*8m/*ErE_j +YJZA|gfQUfAtCY/p*bّGU{qq}XPjt8| )U.y!'|_@J}!%>mQs臔b r-3u(:OŐֺz-DQ֟ԉfBIw29gKe@,׹o@b);;Hn|7fFȊ; 'fF S=R{bX7[G ،-9m2ˆXIZⵞQif'ml Cg8Ӑb׽q5juz i/ Bgkm3OT{dxT6;s0>{@A|g~Le^fUA])i~wÿqgZ endstream endobj 980 0 obj <> stream xYKs6`Ζ!^=)Y'l٬4,s1ɑ 4a4:8R*K@hGA ~ ~4"i&I@9IE\Cկ(a|j9/OnԦ-nnVkaSao3o2!TZ$ X+&fUv0-67 MHA J''}RVҦv6ƃ$%QL9ԉ܄.UbuˆLHIIz]J>+<] +{f} _BN>pm׷?Ndz'hi*r h{P`GpJ4uu#BM%7.ajF rO2Vk.D "'IDEG<К 7{][*?0%{?BHɋӈ&;DQ/f]mF p,oee]ַ$2Wma8`.ܸ VUu1wT ,YxGMkvGM 2d:}OCuRKK8jn^/eQʎaHNGkܴNw G4V'PPe`bzg]W^٭HKw9Թ; ݄&gV<8&8FîݢDZkOpA%hN`Tux7̋ܝN#f;!і_6_Iax99^17m{r=^ppl$̘i{O]v۫K HP| DWATDEfCCs s`>hs+/yG)n{y`w 8|ab C]MDE &b>a Ch ~rq\38&Fq^$Jn} 9DD-,&bs&`#"DRAM0ut'1"1/=@ !]ch[Ib8 Eji`RCqB"LE"&l9ّs [Zں-(ƔWhba\ljkk%6GYؒ,E,J>&IݐD&߽qm a" k,ČXT[@ ña_2IzDI6JT΋q2`)Lg0T=bl.(kkאJb(챛[`PIw:sm0@:ONO0CcTQtЃ(K'EA1x! a2>~[ 5T7LE;K:ZlV« ,}̸ߢZ񓀫3H$_4,#屝#;MTOT,\V!hWYYo&-k|Ci?[hMI6 3UŁԀ,‹'TLCS'ϳW\9O)=W̘ ~ {T@qd8tYo[yWy*;!K&|{%P$u.Bkֲi*sS9B^A(G endstream endobj 983 0 obj <> stream xڭZKFiA-MzNMu{Z")᱃T?IMI,*x% eiꇟ g W8_a 6suJ)MuKÓzqˊa@X@ 5Ok:TS*e13k"S.Hk:#yr6:.[X!j6EH'cDq+>z\&5ϒftߴePQ0݇a6u5lj2=N~ǵ[#fFK}'G{vJsK}Q`̹Wa(w #Q &[by }y#R/{uRu27\ :!*Ev;Z>ƋzK\v!<~DUJ3זUd6? 1:N @m8UzނץmTr|RZh4.$p8ߧ`=>\xd,xh dܝNpiw6G![P^XPp3nzbA)7(Y`ZxMh7v;z9CL <-Πyz2PV~%u{]ɀKlk+*00!ŞbGHo{K"$47 u\pL4vz- ^\7Ӟ D$IKքhnM?hBo3 D@ocI.ar,Gy78*+YeI)>ps-`#VxHI7(T~^×T,&r|$dd}~}heԅ(\-:0:b3 gIMХɌurvF#I|Gmcޗ2bD`.(a_}S>%<́, ¡a4T?D gke;>߁9|ZmHB;n:=|"ZN,R2303¾¶=`+YNg~+Bk£ܡCe.%2{ p"w1i>܄ErtU`lf0\ZO!:HMq35p[a geR^$RYb̵DP(c=%WPiX(Ѓ^QfB+ CL.n  ʼn5B [WyXq ߧ6h 8զyAnNxƃ,PiS+}_qpbx2zͩtXmÐβ*fɊe/&[!ӣDr r"C:7NQgDe DzūUqVq27)v|r.&π{15n6SZgjΫsrOwC-\wIq.tevp݃վx޺7)ڃlf\!GIygkU.ɖ=$ї LnOwqm 7zp{Kgw*?3.8hC7ৼtQՇy#A61:Β endstream endobj 986 0 obj <> stream xڽXKsFW6#ŀuH)r⨒XEa;+QV ,qIU ׏a/? 7ϽOc%aӥcS;] AmݛY@)e0Nޛ/e^3mZ_Y@bU1#oZt:qDB%(Ƭu/&U= 8p{-YYVMW~R7jgt D+H(jY{%kYZf'*-?̪!θUNےEo5kqV`CdK`uUE$Fƶdʼwt)NZX8,^grj98$,E"ԪMo;#'[V:@ ,J*~2̂/)Ԃ#,g>yN?N^ު ]E}/յ ([#;}ɚ.Z6iY  C." 3;R땭*h"?ى|q]0/ n 5!IĮlo2c: GV7g΄7?*ʲW zDً"!ȦDCm"o7!xߒo i^8cY̵HgANAP._r\(m_[FC[Bj"1u Q1lQ^sE,W%c(k YdNABmx}8βn- _ P}1g$8yu =MTwJ!;LC2lTg8seiӯJR8X }`q=C$׺V K0|ْZo,ͳr邅9DCHuJEJئ@) ETQ4/R4?Hs޿Q`ȤAάˁbᣰ"QXATMJSƛMeD(o]q)Uy:#>/9˹2m{z(Yr@x%ǙK&Jf^g9Av/&N W.:nBiLyy5%;~pH䉰6Cc=¤KHz»nܥf'c $ŨC%yڍgbB wG?"(;~SF|dwP_fÂ]J}rV v/5 P\V00i[(i7> #4hSdaP1E1liAgx<-dt) ȜJS'YSWzBkۿwthzv u;L+$m/ C1ԩaOsUiN QP#0G Ql1Eǂm̖ypSbJ`?PJm`뚉R7w~Ĥt'f|u&qg WV"*HRqC>7Yt?~6mk:E?WV6 )mY q=9H`FuʎViF61eRJ&ă )8BQ?M{wifuDWvY<Sz(]!CdSoz) endstream endobj 989 0 obj <> stream xYYo~ϯ%`f_즀H 8;o=P30!Ɂ|Oi4:(8h{]G_@"t0vMpbBO%4SLE<2ԝ41o:T >jS{tN͓|uCVeKhr4l;᪹UDn>\]ڿ5/KlRj 9HH= 'HTrBr/O*dT*pr$aq$y(S_$A}ɔa(˖PlI]P:ϒ4&]i|U8A.LFv|k6[XC˗:FŦ| ,`&B,;c 6F2]zG9^ߡBMT?TCF_l;0d} UÆ zi=|`6.5WMzũCZr#&!W"Ζ/;N2r?q*ѡv3 ͇PY{*T~$@O(Nb.r<UO<&ެ6+K';m $$`3I@멅_ & l\4jY6F)4s€q»M|7OjZ֎B;Qigl!1`u1(~k!aF7u!̘|91NBQ%.x1=AbhF^A117_vaܽEbe.$Pg% `!o_c.f F4'oݚ\vs;|ZotoX%8e9Hzݷ|?3}Og`QJLyco, 5 h MY54sD"&fѵ}$+͉Y"F/&։T_2rPUCɗiِvhg)`L6fK,[/G땄ζPGzEmn;ۡd| ;42֟PĜSO0+{ߞ`4N2ѤtS ={S}4SmyHg,?|@Uv(h;ݹH}fCP= VɥTC؝|8x&#yr 풹3:F zRDC \vMҷk7lzo}&q3ְCߘ&`9Te0u9ԁP;XdSfHtГ56O< sd Hg"Q;UGe3g\s0cӑEF4. .,8ȋ.Qcd[#l7& Ey(OX.aHxw$MeE|BH‚LX3am*<AWWAV>H$}2[el` ㆜ԟ܃Xo'ڞit0[eRUM5TE躧 Ig9K\wZ8 endstream endobj 992 0 obj <> stream x[[o~о-Ĉw*@zK"dX2#yGCitP2"A~W?eC3:djsܧ5WU=w?ʡQM PPQz̪pKezT((1J)dvi1U?ߧ@1Lc`l6N"NɪkIҰll#gߘTg `[1vmRçQJf)C,0"W3&ZS.s)_bL|c:@! {7DSTc'Y>H< 6-8C|cXwYyv^z_|Ƅ)y E/wԄ&p-jNxJ,ViYa %46kIrX\ ETKc Hl(S8I B#!.5P@#6F"eh`v;-߅֡i 9r!!/͟-G]k*EIEIrH*>`g$pʻ9{=,n><ݲDX<:rlY$=2 w2F[/)&[bɘn.+p I8kQ`!CGt)=WU)vtS9P:Y'3pf`|SZx3\U5q*!1DH aa(S\s), oUЮ4\uޣ䩠o,I/^9S<bjRStJ-0O>gߩ#48v=~V3axjx+ (Մ~J5pi/)w}(XUx? 2:kzMu`x.-KLN,ٮOr0d^25F[Zhtt3Yڠ/!I yoSE6U7D˼$%\,^dr,6>70O* uk%T>j܋ۖ9Rȱfl}KQ a]TӦ.;lFDˣ!}He-ЗLr)SzxٺGCZ:ux7(yVgmMVJS O$YVn鴁pdpD m ~ǧa{6ջ_UMI b/ <5;74qrȪ}Ze!S/,m 0'j$1jhwXdWͤ1B/&mAm삤OQ$"Փ͡]?6Wskk&VVlCzjqCj]NFjg֞5Ϳl֍NH5?c89<"L|𤮼_LVqwcjpDQtdm\F]*Q 1PŹl:*-;#RZZpoۄ;>CX ft(ZChRfת tmtWtȲSW=0XDs"9;8!S~v‰l](7Bq8x ʬ5W4|;eH_CJil߃tnJ5 U _1U_( U_z v{J=0r @B1:,f^8+R%[ bH\G1\eoͳ1s:&{X<0o[gUXjLWxOîf]"}Ml&{'{1R K?o#DO(|5uqQlQA3[j'-xmO  e̻ﮰyp;.S;G~lݭ`0B[ ~?[4=Rt?S= 6 :@,re76VŅuԹ9p;sݹ"bwZfHEΗ/wl -˧msICe;Vl)_; 8eW!2U9rzz*=cNqj>됦?l(I8 'RrtrJe _.-qSԻ ]B*M#+`4%4e0\>zDp58M79ҙyxe R?{K0/j ](F]/g( z)LGK0p5̘^S^Yf~Bx endstream endobj 995 0 obj <> stream xX[oH~_a!ʖ0B@7qCb) =3cvWJ%;ܾs>$Pp0[Mh@0JpBI@t@J&ɪ(f]Ó":8H2 F}18` jܭy4vaج"b$ljVW>$Fl/1PȈWOWY|V>LrQمcz 5@(OW^qX"څƱhG $T5J)✶}pB0aCo#0 W+9fFqb5i|)٠$JH2mdegFO&ݣtW> НrtlP^剃,ek,6^`{K#ev֔ծ+rw%5%ښ(\LeT =&~d\aXN:ݑL ,Hl#Kg҅)OX}C/E#YtگKTJD5>Y\| ϼHN.IC&$4+lB 1,,sBuXF|qSm7߲YڱKmbuGgI`pH}nk_(R|oҪ w5RX/_cv\P-țc$йݛ^u H4j^w|$D[ǢeF _-x.cDnѣG[`_1|b= Xj4~_1|1ɕŹ\ s$8[Mܲ]jCa}ZszKiB0g_ Zjoy3O\uU.z]%%tQw;wxhsv^oib'LIFۧ{d=rC`O'SAE endstream endobj 998 0 obj <> stream xYYo6~ڇj 1MRpqmZiѴkW lHK |Ό 0#AB?eq FHp|4 e< '!2j1t~ ^\C8*9L8'`fJ fߟn"!Љ!$4@U~m,W ܵhdr'(:ܢ9ěU 0s'c%6* Ugj;bC*73# OE^mN]Z6Iz zk;Q@D~#XBuiNV+MP ^LvǸ>eZ&_fRin+M5ͫAdGfZV7hU_68rU\{JPnq˵Աt `OF'^^ O6.^ IVU7O˝+c}u{17f^˲jp"؊Ts3װLclA_F`a)첰}ݹl;3,SlJMVԸ]2uM4j.* sIIʺ,e dh<b )Ud{10Wog,uWМUMGBcHʢʁFTٴ ɢcw^Ư3&U&St5:ÀyQ aS U|]kSh(\xs&ILlU>{BSXM*Z].+YIa0I6YSf:!4+ߪzጰrK͓? xH͓yJtj-\xYkZ򏼒u wLd jI_#z0 endstream endobj 1001 0 obj <> stream xX]s6}`܇gfS:o'3f& ޤWHh&Cڎ=Ft]]wv"mWqp j%,vVKIzz> /=1^Ó/{a`X.$^\ѩU!ac6}9arszy}z3ȿoRuKRMqbn!~?Di;VUlNOx C!ZaMk-<7jp %z6oْþ035fH7;T܉g@XjgӋ_Km/LMNR jV&>f+N')k}?au;:hlQ!5e6j :E?K\F tq%>]%.@E$@f_u;QCj2qv}[o`c8rvi6͂Y͓l+/iSR^р·UAˆ.kD{nAm3ry4MvPOq F3#dr逸/Fk6~H'H6(|t46@ ѐZ6J-ޫ`ȪDր2m7j+Yab357Ä-&+KU2̼]zd[b#(`9 ] (Ȫ)+>m@5Pv#J#R>JbU$vln`x[K7؄T 1Àʩ7wUV7-.rX>Y(2[DG1[{3ɼzrNA&H5A3~}6s8L/B[BClc;`\( @4BAmCl4bb` fwy[mh00R)mZwPlF GBC yXv!;0~;6zqJVF_Ajz%8 pD.*3qFO$(I"=cmu>g he7*Vc*I7VV`W2D"Y(փ9W Fq=w)ik Nt<&a uU&GbW [& tER_iM.TnT?)ߥ#6[8Fh"͛<2JQĘ?8t"ʓ X%\/I[ ۥ[n=L ЎbqtUusF Y0ȊIҤ>yf?}>%aǚHw[1 72y/InjyZt _8PC~2B~2aq MpŰGW(&ćb׉{Yv;-iߋ-6ٚ{B)³ 3}Hyw+3>x0#se%h Q[R䳕'\XꚱKl f2A1g 9cGˑW*?{[vyXlTAN+,_eq*0?ʋeeP?*VIV1 P9 s,xڤ,^vdr~! Z endstream endobj 1004 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1007 0 obj <> stream xڭZKsW(l6T*%9p$z]rHif>h|]%F?~n?O^2_zy|()f%mJ772‘: -g0>ڈ??k;\Ť2疛Bj؀$Ƨ jͩ7==6:4S'm29 l=‡M8H 40|ۺkvR~tiwx&igEKXvqTt"|kCVߖR0)q \[[)&OOqnoyN TfoJJP P +wUןpXȰ" Xea"s JF:,pmu\LfCW8X(w886cմMe*=īSw5~cb)`y~6C"Z /xɳ97ͤ ~BCgMf[Ld8='v}WwՁ:0iZB~A(mwLgw)f, ڝ(Gi%-U94|x%d//PG@ZKOMߚ3MOQ:\8 G%3(&yi/VOFvo5o0D"}szʩPL,P lYagЋ|/5#Ês %ZL֕} X ꤎt^FìHH@T`9E #: qe8񥯻" o90XOx}bIF%;?WS !j9T Ilv(FR`ЃW VTR)ʱ_uȚBlag [fL(r٬Yn/];NۅcMڦ?R..wQʹH/ >ԙauLn/7v_s_yo(GwIkysiN"d"O[T^}rO t WI+SS)`+H}]B<aB6Ǫ{]T!#@ҩ3> lRXk#Y)F 6 HȌY,CSa;jž[dsEaSz / .Ơ=r*bm\g:Ęȸ<.iIcآ*?E hpѝ:S?Fyfa!KR|!.ȢKl38ȧKM( ' iD:߃$ĥS = T#p!z7=`X,mDin"XK5c̾B(> %g; 1P|]RR-fTG _E!a b!oaBKq8+1b+\P Hb߅ =w7+ (7dzN$ "Td]YLs|HA@"ilZa=Ĺ% >tĆ 5)`W8r'eOPH`{,lɺKP,ڪ5To]ǃ[eJH xI!LqsTzT(6E@FPb3֮(d6˺v;B[92!? D.lY,OjKًf:iKȟH}1,h2Uߨ U.-+G4rL¯]D0G IhʌHpl? 8㮊F] ɜUWr\*cޖcI|u81KI{aBsȲ_Z/~LB~Q߸gFR!(LnqΥܾT]h4Jr2CϹLqt%?OTK?ܯE)~4 qzYWR~gW_M1T>3w?7P9@5}n!OltD)=gGZ-2w|b%sa2j$&> (o' p7q+R߀sy3&mDV T"!{ނHջPUN]Jח0wţ.P9Y9s =z=5sﴗLg]xF> stream xڥZK۸WrrRx؛7M9ڪT&!΁8f%Q!){'>hOpf.F_7rwp}G9s;.SvwW&wB V޷?^J#5ߩ|n.V_J?4w{a\]D~oXk^9fk3~Fd.u_e_% m?9e]t|3RZz9ϳ2L }kS[tULEJ?՝١O!9Sڄ 2D`.+YdC_|OuQvT9g]~پLv*j|51B1SD⨏#]sXmt3SzlJ9h밎?!A<jr(^cR)fs1d?)Ѡ:GT;gDjW1NJ1cأ_R]`Zک= d) Aϒg]kL}(XqL)Xm^8 UV^\o`Aypaq-ď) #S呙F1Y.>`-T_E=F(*)DV?а2 [!l)l;Ɵ _ZDgs7{p"Uˆźz$N)!"c#{6}0L1#`њsyBO0k(@Մฮ Wíp/pPvr{i1`Yы[GZD" 1e .4:=mKBigOK 7a{… & Bw=k:Fle̙r3Aq> 2\J21p#ɹ2_fLnڶ9ٖ3hLxK,S'` R2(pk(oiޑ A0gy*Y)0ҊP8'N\;ejGn#ME bS_ @+|I68k.7BCcj\rxpҨ_#O !z*r>1T7+&:~1:~RFEirrprsƕUepUBI9`{iALFC#g};-uY/g`R7D7`$ R0dR#_ixYY消ЮI1*ͬL=CK'.O@h^QԓGv:+q+qDG bC۱UW W$.duWUF4nY&9f!#*@ĺϏ3k2A sAسMC  J׹ qo[&w*,w,VDƔ5UDZz(o( ga&j'䥗uneC]x vSROW7?  w82"W\I!E-+$|)Sj aZ۶GqzCˡD> &Zleer5oˡDjJ$|03S8a7ɛu݄X\Qr4 !&Mt Cg#+> 0@VhUsfS~X4P67CI7$3,mQɇ)trz<[xWJu@Y MQ@P I#u)4 UX \PdƥRgsRQUTgoG[#IP]P淑ڗ}Np%@[trȜ I/ƛNA7?T0yKfYhN w}7bD Ϻ< }Vm#i άe \-rxщۿr^UCdtW*BO|Kx /&ͮLUO}* 3VvЇ## 9=3_P F*&cp>ȶ;S*נnu [tn\ >beǨY>dzBaډvq: i܋ 1ǂBbtȍ?5\HǙLsV/bG1-? I]}1T*}/ rKP%* >Z. f</wvIM endstream endobj 1013 0 obj <> stream xڝZKWo&&@$䠶cem#3ϧ(JGW?۔gaXjy̆ bELFΧ^ {WRQ :Wv+(aꗠ~n*,4߿#, gXp@<TozۃRf ^_^w5/P#v6L 8%k$܏`A3P9 tC'?=oܷz%蒚N kh#*CihUjM7Z#ԎZv G)ϗ]h"U93ff2JAսQ}|nRR^}}C'-Jjës v" :TIFKS-:afHqR =BCrfcv:7B9c="9UC]Yrp6W.FlRpU y[38?fŴpv!G FʞoU\ |T[I+1 )^J>_u0S5yW2G+hG1*\y2r1kCC-h];7(,Q%e? ctPG7l~ \" :xvÈ. N.)Pu&WKs]sk"8{x CpR92Ŕ*̿ d'H+W%ćvGOPZ8_7b=nϞU.oboZD^GRAd/1U)PXX¨7{Y|ůzn܌WvQpmͣUa'kfEj6|՛ >9M~wryC=r reѢo#Ki@~՚[s~zdF91^08 !nL= 2CV : F1[3jJt:_b-G-Ҏu"MI7uJi4j|^'w_i=6iV~U%ر*TpL. %"w4)qɦaߨBFsWbéS{0t[}1liBFc7):golB:s;2}$&a?Ef{\V2Zŵ^GLvI0\j|ÀKb8 1sjnqoT:ҹN\A╎mtl)+5){E}ot7u6(I/G{̫kEH& v-5Qȟ ^,݅+uӌM=Q_ͻkpm(qsȐC6Wk)jn@X£QҤEI?/\ ߼@̙HIvFŒQ@ْquv]b{'D$#](+BFc's,ՠυ?>1l呇<˻c!ƙ3գ̕i4S0gkl Ra1y92q?TU \Q)#Ad E]|`\7_'Z<-GGozT_DV7j °r ^#1􉄧f~=0X 2G˯y0 endstream endobj 1016 0 obj <> stream xڥɒ۸Pu999Lʩ2s%͌D*$m@$KRvzM_1gyw?M"+qM.X!Vy_7\pfq| !es_>j/C{v掛؝,ͥ^;(!f"IA:Dn46gw;} *c(2[,KlčgpyU /}q|$Ǎx(js@["0#nͤܬtfCt9+\7X B٣K `D>GBD_܌J<2À%! Z0Vƪm.|\0'E)ufKXP'D(r$79JTOd172ksQ38T.8Uɀ#4k!F!&^c' !YL-=r_ W@dIrTm@=axt˵#ll b汌`{54%ɑ< "Y h}8 {"wҐp'^=9jFpoy{]Ȱ^i/)!pcj$ (PDXQ0 Mo)rcPxu73iϱՄK貁Qq2%H)CBo @]>"2ATEd;hm8<9 Oф4WBO!ݑs>gF#C((9eɻ,h6!)Xz-2 }8;ȉX2b“oQGy.fI30T 'ɪ-6L | _m&ㅣKNWoKlQw`׵w~>ҼhPh;t>KG [Vgdq 8~hRKAW[9"K5r)#x%y%(4J7^ wdv"[j<@?|iupW oŭjB0eLm* jzv0&b!dcq@W܄dL1zHut9()csmpi RaVe*S &faY.fR[tPElpSu-Q4Ŵ0iL^W4L腗ߔ3-1ְlثWh>j#ypZuo3;[{ B{t +T%zz%hj7W$D:UD LK*vbr\jdS˦:G"踥]}߁:K*q0BjpYv.="oP \'/&6 wd\ĤwV<0+G2՝-E96 e+|TeZkl04RP3Nr<cDK0f,jTsUZ-}EcpV%P$=oT̓h)߱YyB(D $zVF}۶)M'D`P0]"SoMr<Rg̽C62n@!#E0 䙭ُVݚe*i{So藨3kUB<`q5g,m$ߵ< #dIp~Vș*_ PPܐĝoqb קye,Tv8P .D1Ȳ3[6Մ"n־Yv"Ü 矪ǺzrbEaSf)P*=)0@CW+t塧}5Nr*a o?}r !;-]v1wn:i4'>E8ut|AM"W 4S\SޅVuk[9S?B$v8~aҏ4D+|]\jx3ɗYwhDG{){*)ݡÒrՑ|TG̽2̈́G뗻|U{!9KB鿔jrRo<8uNtbVϼ٫k̚^߫c}lJNoWTWӣ2N pz5NəY<-lw~896ޑ>WSZ 3ga>%_!6]VvR_-@27[‘x<6 DP PAEMR{h#Ys._JxB⤤3$O_䫿c7rh&d@$t] fM>? , RH40GWcufEVѫg@ k8KuxR[4Xi%\r ;.wq _ ATٟ:ȩ9=ˇ2~PP(2rn7F ?ן76v, endstream endobj 1019 0 obj <> stream xڭZ[۸~EdM7@6P`gQh<]"i2ËDzhDE~skEJ3T]MGVц桢Xa_8vb9RQnOo7Dqk7K7Ka½ndZԛfܴqs kXx=䃰7C܎?~)+Lr"9HP=ab3kмZN_zGru{O^ݬ699 U*9z<DJRDĺkw/7alĉq,-/&ma_xDC~(mMJ7_ma;^x?<A^_FQxrym!enwopMuZ yŏ.N>.ZBe,sJ>#'AF (~:5}a_0Ԕ75xLMx 2|f]1#U]eX!lxD#<s:S,=5裻&D pU~t0t~. 9sAyQM"BY]=U\%! GByX7O + & ̼!IX8oz9MIh; +}ˀ _77 ]S# `7~3nlpw$kx ԍ#!% 9؇Ŗo`hC>NC$-M~nq+alCFݢuY5@@r-#y0hi`ƟPz a7ީ-_yiLV|hbDޡCw!]?=O( 'W:98)6xTS<<1e&C"2 <?ab9-_4^-*' Ň"| v6ݓ|?;4g?S>|?{-& {\]X헾=rµ'9Қ㢚B(~C Kh hvy0YɶMM Dڴ*T;ٸ:h>liy,Nuz{*4qtl5Xqh6hOyTWfh?b.C! Y n7N#<+:R͕0MJa'c5Y[B&%&ƒ61qJ!D.fv*H( 5cpn(P岰@cK~owmWѫ R `gܢ+EbS{SHqfWzqѻiI '4YOаߕKN +I2yrDqs(l͙pt QMP\s-1UM"}L0]Á]~vqUbnpG!P6ʑ矙\H*!$æoj5Pry"X $q>D۳TL_P LW`e!U=u?by*/ZEs^%˼@}m@8K|yqxtƋaP`\ BG6|B|_B@KsPJxx6`}O Ơh `0<`u tiR%{0.Vb~Z`+Jp=%yӀ/\ 56&hnXbR<(a ?"0Dۨ`5X5,ehfҁeR™%s١pf\ sbK`(8Ac%Vm8HG];:?{nP ˝Ֆ!SGi+}7 D=#'x6Iam3p q4&ɔóO@ -s{.r%M8τ \nFF7 |>yjft_H¹ͤ PG8xf[p-N(ͮ6U@@jFE-sMT5! ~(& "blw],K,Lek :Cv%+OV_ v0`Xz9`bP-XjK"2}qPf8x.;Kmj,d E)OF \'f e!Vvљ7=8.V}lOdL endstream endobj 1022 0 obj <> stream xڽZKWI`sr8UI&'Y1ĉHywӍ RG*-I@_ XX b_iwr!8܋BPkxT<"B0=C[Cgm`mxa2lD5уqrf\M,LPeUfk$PiaRj@ͺ'QI_jYN$Jzb4#z(@s&&w]Y,ôNqBOb]==l%v4bN կݥ9Di:Gm(_;6n>k` R,7y;b~#F3!qm⠏deV̕`:omP4rL4,bӁ=˧m\Rzh6eVFN*jhӼVjৎq' >o5}U1h=iu=4>t=l㘾Yw .@It^ZLOf]-,Ye hJي9!NA$C4#3kF`hxPq>-`p@ KQE8徨{p*y#1\~2vn@'tӟ[p΄QCdH'U5]{pğ(v}wJ,wCf + W%e`J=ort)6zWŰo7,8F @״eJxF;藹<2¬g R_vM0|I s g'UTfDN\0o0Rfde0.l 5ڪ1W+>ΰ9+ ;5;9  (R$DG5qS\@<{kF,FsO.2` ֛w:U:2^&<^Oac?0컜U<-w@l%'*H'rC51aKZ y.BLύ3Qr ]xۏr2-D &Ld~4 ܈AIT&?~ pQ@lʄ#b.8maX& q3ѹB%smU!$= $u2f.UԗA+$s6liU aK͵͉vD(ϺyV6kYV"d»yAfrUb XN)@W%^tQAHJeON1ϥo.s sI泓CƦ\70x E~otL@BuY5wN[u>!eb]N 5bn7!Hal< |J9"C 'jY&ebՇ7L C3 ZX!J7Aawzc&wikw>cT 8"7Id[QŒ\E8:+zj7%W0cJ0LY"ߞBeꢘUVVc@B#Ԉ?CsK"23nY3pͶΓ7UsW =-]8wsrQmyvbq)΁7QtsE?=J - /%_ C=ҶPR(Thߝ‹h7Uz r..啌y&&5Jc;&cDŽje5jڤ5 5DpA4 o0'N =nw;C09}ӡ)\J)lUwLSN9y)<&>dplt;abYX >YɨCiu@=qRqEB͌A[yEy|FAF M$Mie 5pbY&X\7[ g(7Q; H|ƪh8ѿWk6B &EUv|0ɜpa"߬f=N*w4- *w*nˏhpas?VPZ1Io&:v{ZWKC?kR0!.-r/sԤYI텹Nx|ѩvSE0f+nC0S|f>76){o|=&\G8 a"7L+@G&}YB—o J|jF*dʽ;˱M_>+J>oE A)çnc","ů\呼71d]0/e SX\z#r|;޹S(P8q&7y7G8.7 3q.2#g꺍E^y&HL=h/cOv(;5e*w0j>::)Uo 5( endstream endobj 1025 0 obj <> stream xڽZKW7-,"}䠱2+ә=䷧EʒG=IEW7?oĆß8 f~r#8+x!67BBoۏq]ںLk]f~wF ì06~`gsf 7˅}c3b[ᛕ0Z3Sl>CW";6ܫ隩):kq*};wJu|_vCs*$7 h4vjI`2 Ug}MA.L b 5t_VrvK$|9)J<=צgΙ*; Ţ9sF3 %,̍c @q-gEN;P ^4+=gd@R4]<$J$Wt:Gm!iDd.׏aYn/%a*1ǩ9r&fCXZq҅OBaD6@Ag }A>GzWU9To 8-^9<+B=c|O۶.3^PFm ļT/AJŰMbmZ OyLJ\!r~g]y mt~BiJRk:% ƕ{N"1-dLCBTӣpBX̅_C<_ݠm@+pkE̶SM}NOn@Q 7+$1P}Y~d٢͢"Ԁ苄`YȀ J'_x&gC <a``j05l^rKU &+ξS4\,_Md`8l#.>\JF'ۮn.㣇m ,̙uׇg:U%\vWDB\_zPs HIV*ZW~X9Sm/^{"޾ dfȾ6ϯYa~̾:pTW"b'(׆ ٗЙ˅x]cpP_eߛ yFps7?ov yh\n ;כӢSS'ڣ\CQdv*[T 4:=O)oI* T}'Sa3AJ G˼a*{)/ +QkCKrN"&)Lj.9~~κ5t=.fwbndX&è+ _.3bkj@QBcJlwz{1P~[2Bُc7M=u,ݥCH]Wlyξb+bT=DZ2!j歮h;6Dђ綢&A]''>l^{s[,A>o=҄j3ʗy .Fh/f 4uv3~_V&@%DQoEE|QwGDž3=[ˬQO*'|DfI13LTv<[ >mc,,A ) ĥeQyثS,Sg%Ӟj^yB8zmiA'>Z2]c!2/_/yg~ co3^Sv̍}` 9ݽ|<saWḯ"f~:ӎGG|! ?ƮK60;_5J:lW{JS,MP|=Xsϱtۂ@1+aG,:~տ endstream endobj 1028 0 obj <> stream xڽZݓ۶_Gތ$ڧi:$>$y%F"/$w 9vƞ# l~݈ bSH7毷VlnQnbVRϷH%YQ({~V)UOjNŶξk{2۝Ou{#ltn(X)f-+vfƻjM!_}kf%La 7X 8#STmh]WZV5۴X#ziz,dS$|5xfVi؍ϙ6h=S鹯X_q0nב˲k\auc28g" g\aoΤ CdFXEVPYۍԈSӺ8k`3z8?q[|г _6 -er8 D `*'n lnW% f  ${odvjX|ᬶ+"*"R%+_eV#Vc}Oktg?~oծl3m"EޡsDa$N4Ns  cލt//LJqk:UXW2=XV*·p UGuKus۸ʾvUV]X ج"uk¶,X’7 q&k  cOIBA?4]KS:KFD{0M^f7[>lw]7mmsATfM/ٜb*z ++o8PPvEL]ҭW?|zjB|귉3tc!h^CM/#%'Bi&N /ˣ t̗)#0;q(%tX+ *w;)de=N9|.a 'jҨEmηJ EBB<;¡9vlrVL遶,xUU|Vx`r2eH ][Z _ra fe7dD&4r-4)Æ\Qu!3'QOuDPBC[L*bJ̝b♌(m"9ɘL% #  ,+ĈES Tw) M\hUb:`V'YUXBC+OBV ;mb4FD 5pvR3yyӡ9qg{CppkxZqi~-,1@*z)SF A.y0$(iՔ +5 Ȣ,|rtN8jWqƺfĪU<bE.ΗP"n6){o~ &^pB<\rS_rPȝqq_0ndu*6x|Lg"{kf%.ԃtY{0\r&)R~;.,Q:n&y @;d/:CfVJ@K︽4 .ECn"T;l648Џg|ϏK.ψH>߂']ߚKc_(0# <ϳooJEkj5m % `On{;MRͅ *XlEe Sv7XUiSJʥJ Q*:u?;~X]X?Ez:$ww֛UGR {@S Ix 4L>~;;I@-!~tg~i+wxDi?6+:h~\k8_WV09t$7"ӜntDq"jz3Y>_)YHK 8_kQJg}BCs<ҽW_fflz_9rWMǣ% N %L<*6709+Ɇza<(JJ/]ʃG^Cf}zp6~.`IݍzڙÒ?(9t%ex #φ.8"&g5<(D\ c`(| endstream endobj 1031 0 obj <> stream xZKWgK()ىLK$@m}TRvp0ӏo+[w|()hV7+&H!f9a_U΅yΥO?s_M߭}%"ZhXp߽c+&y˂X&\CųU}]3*+Taՙt0ŽW VM"ݹ %V y; Qpα\s=mA1۞j})(Yy8W~څ]4âԿeUn6v*ř(63fphӕ+jP#n h LgF ]{rT]Gsظ::Wμ>Ї:X4 5(bԠfFkw`6(: eA[ @x@P =l;LjNaǷxoϛV~i@8R`swXt^ a7>H݆} puABva֫(֫QRpdֽDT &|4o~O1JP}&MIa6R{Y,$5` ڼH>vr7qX6BIbT#^Yp.%,ue) ҶnkVz}+3OM8E[v9@-YL1 >iB?ӫf!/)4I']oK.BuרVⓁv[&Λ3Z.4.U?ᡷI'M !^.ӷ*$_A*ZݾBhVGעEN17< _8mjKUr(f `4yCpOI\SnM֊fX9԰vB5bl`jdu?K=t}u̻ݡF>mQчFKYA Wߟ$"AޡXĮHq$tDݝ9ɬH!J >qC,aPv]J%;*& eOHDP1dn19~_w)ٔ ҊɖW klrT -=; l@8偐Qum">u(DaGG/_w10p^/JSxV`Ј/t.=,=h cd0WPxr1 :D'< XUѧ-D@!b5*N#*BBT7dlFB;^$|;JB{%h-|k&+ <P#!BOVU QߍHq$izT$ՍzOi3Mj}Z]ffC9ivsW;Lz$;@3dTJalD4n,-?`ҧ :/d !",QF v?IE{nC<' D|%rEWI"Sv^F fw>[\wH&Pá|~& 9 ܕCh#ݻVno[0YBؤbtI:Q`;<4<^u'G=3d #f-.$ N%(3SjZ;#Xj12*agT)Bs_ Y౉zɛeL %"Ġ|J߄j&8q<7Xo/ݡrIX?*b_d x@Dz ][*\{URHOgޢP+9] @㲓 s3uA#ԩ09tҡЙKKqs([MBV:eTC%'%ȡE~.pFVL39w3m m^afqYWîRXT\{`cPUZ(SjyE̕MP^*B W᪥4Sv-d|\l@SD t˗ 7 |ݻ WSB5D"˱GI,vʅa>\d\>֒/[>5nq ][=q2 Va|tWñK7tTBnA U0 p:eɘl?>~,z럀xk5GgDR\SH3t"7pۛ|M]|  ؏{jZsIWCźyIbb^S-S.َW-;DQjvq9S$‡ۧ$R>6]diF4^+|[!^|x{1@ P#bnR<D 'cipB4-#Z-eMFD̺j4\ףnpcAv^a z_:nf?7| endstream endobj 1034 0 obj <> stream x[[۶~УNBp>d&IƝѯTm/߲t]Xe+ kϜmR($7cb96~H'Q*8.w8Q>5?G8PN/[AiĵVhGGEٝ DLi{Am#ρoBLGG ÈaU řx"/FQ3oDŽDr#Z)rɞl[\\x0okϹE8nG%_ Q`D CiQVȁ R ?o®/c=z^$sy-5NN˟ܔח,e͝p D4m7d`8l\!Gi> շm__ZZΠa@:iQ6m7&"SC6]&zDm"p}_ZsFApԐ,IXž+Ò: "(ŨF($ ngAl>0_"f#^ΰw=:* 7%9+ː̅Wy+#+4V6Y)'(UZkôXpvܸ4ͷf ;jwR8D9KP VX`Ɏc^]}eCsiΧoC2SD8 ' l?<7|%w|᬴ѯ>%z o>hF< Gým׸#2LljVkit[OԽ&:iqӹwCތl15Ί~ˇbユ[4Hh8sX|S_ơsAh l/ -'A ~KH -ϋT1’$TO6 ]vQbeπzXe|v̯!{+u`eiw74NG͂EtPǦZ@V(hpE?\y@jR `jyERWrVF3֖}b*f]G2 6kzBBOo-v0Qj$ѥ97DDI/bsm\bڸ$1hy8) w60z2/5-x5}sn@ 'm84 D;v?L1{{&pq_V_ [uZv<^򽧮.-p9-8Z+Dؑ\R!/'Y5\ Ey),| %9wW"zO:S0)'1;7( #ƛ'˰ ށ*  UxG>FpDB\\Eg ׁey,Bx Y* k!io/mݹѮv2:~rM#V**2?1&&#_S$@پf.atWv8*qv!1sb Ж߂)7Dto $n6~7hw~zN`-"MP_r9z횏mC3 P͇csȞd˜eje8.Y1W-@.Ŕcل$t.SkuD۫gVS%9xfso1v>t͘e@:e%!b\dV1KXRbQn rucR m~P6*B]FkvAT7 ib&yg MP$Fm|ʥ19D'!ƥM*IO'e{׾bL87^x?S.{"H)? V@^cv<91)E6ϣ/G❢K \j/Y)"Cxx8x9i>o#UG |ytb |j D5ydX#xo(b*TuQ&O]TUD^I}&}%|λqY^ 4Y,`,`LqCUЛ}86SQNC oPV1i)aܔy(MaQg qW 8ү/= '0 ^_aվB1GHƧطFt9U2dEsqq88J"y oTکOke lID!nJ}+n҂, zОN͡k *qBf8Afw]>1-`v lj__c0M&fsT 7yqxqG;x^OY}ncpW%Sq-v,״rE<6㡩.֩F.NsMMYM! wU|'X%ʛy/wG U<3(EYVT,ct|d Ȯ爾BjJWSBo-)ؙJnMQvr^.nEWN0t-&B:&+̛M"CsWA%䴙\-t:,M"J,~dL!<SXϺK,vO]"_un|@O g;5fJkVdm̧D0B>1^#,W1ea`%jV||p/SeXfTTsiVhZ+`ĦC)rWe p;憾r[V7@ꋋ&_w`x{cBm*ʷM:rWI2I- 6gczl?6>G{_+$/|w +'r0`zۭ'x}){ )iYY6IH܉ś20fEA-^ԝzfIs'geolݭd endstream endobj 1037 0 obj <> stream x[M۸Wȩ7[VmJU99YI5ߧ =v") tnl~۰M6GaM6-||0an||w{92R[Hj-4[4n9\e}w_𣊥r^ k6u0qwƣWJQKm6ۯJUu>Yu uGXo+X UkשoEnDE0kffpV7V,9v~" Mi7|j'4/%'*ai)'}+ZUn7[4St +D[3μ݃bϋn_ӕrR1KqJ kPGy}ȦL hLmM^ݑVyc . _!}Vjo&0E)Ȁk-_NcJ 8ws`N%| ;؟I .ԝ㗬H,ПGcv йO}HW_|; 笻Y]F`+]BOOk`;rĽ'5flj3Oprm`^?Co`~2t ZĂd/{=Ү`8'3(>u5Sj|SA?-`֬Uq<)E>ֳN@A~=ㅮ#Yͭ\ 4+@T5Ǔ[##Z!kB!Ϡ<ďh ?X F?wbPX0Xe@5 PRgm-#וG*[[I^8]C:XC H =Y%by NT( 1jX2zbX-+lޭЬ61!*-), BxnԼ߸.f2YMF]H YtPLE9R)uN^e3[]k63OڦVRMX'=^''ˁ^/!eEhW5l)_F=+2Y w?x~ "C,9 S@0) p\C5YF~L"Ht{K 0qV}{!`2tKs2<=z-Z=l~7`e"9|N:i\ڡP /#~Vs_ qLbp  "e03e !g#띾6q 4u0DiŐ,'EqSWVY*~9]@hjuwd p #u\Iypb \+<;> y!$XQHaEBZ˃2@ݯ.u\,7t/s?lu×otpD6ϻ-r!`{Fo%FZR]@ܝji=$if$}oϰtGC&k$6ZINehZL!w18!OVr|MUURJ멱UV,)6Y6zkk-S+Z~S~p@q]#X癮fW* b  .#i]ϣQ*q2MF`SjU1S.5e:Wd-_}j=hcjV^oBvw] ,Cx0X=V{ ^Vs}BT*Q7 .ua;̩y?x?>e|7G6)R,h~At .ܩo@ lUbsq~L[pGkݩ&SԹڦ&XZa Qkdc}@+BmXDVae覔gˈ踪hSg 1 z>6)I V2a;Z":[ڒ G'@{LjeQ_!KXfcSR9(ѻ: 9zUՖذ~G?f30KҽA .s|c|ag{a<XQb'ɼ!U2ojz24K  |`앸)OꍌI=R.dPa(67 PPt UaͪdFmW^,z>pᖨڟ4zo5JR j<&5&Ӯ! 0Y]Sqggr=ɒ{bi)IgjۥzB;/{> stream xڵ[o#޿B*gG%iMHE?$A'pr_IK>Dp^jB,8 '?_vo_ YA,/bA槻,9oӯớ[ԲۯivzHOp~z閧WUIvrBGZK3'Lq.x<=i)g+Ǽ°=nn5Kecr AÑHvi n 6Wo,g+T`6TݮOdip8c?v#;ENh;+zx:Drkƥbmww}~̗jT7O8IZ D͞CMR&Em7 0?| 7FhWdXn7CUh!0emZpO 4A2>!WOԞY&r:=t(&a1Qv I0)W\NisvӸgޏ$ VZ\N>7]t~fAɆ?v,ictXaDMEaUF{+9V^0mhvGwڠsxIKp\0j&Wz@䡎 }'p<:C$L6_ʐL.kWJ`6htvF3LYI!G&Iʨ Zkyy7j@3!q1JCW v.`O"-{Ttu6ynbV>< 諸D`dFD6ԁVoih"]]XVS`Ԕ{)P !T*EPD(2RuJ~wO!lNnKrcSsG4nàPK6̙ 'b#iSF1~_ٿ7#G=!ZfL uVIͤN1n#d LpyJfh%) zr1i0P=΄ u( )2Іn"&T,b4%F|.3c6QoX4L;vTfc헧xʗ˻|HCbD(CJCkr ޏ94˻ 0'ojLǵ9yz~I*wq?/-Zs r`(GŇmibDRhAOAdy_c# &R>N $W Tc 9ЌX8[c5b*ŌӠG9 L iPpY^eAjOY0r#9Ҡ %଺'D:wBGXz:ˣ]:r>OO.–.^)$8++΂爞/P YzH& YŔCők<`~C|ND1M^_5P2Kqe$;RXpC^?̲6\Lr&X-t1TQ JEL#^7"c@]b OŠj3EFm~ʵ+^$aO^H+vΫE!AF\GȾ("T8x'h!T2aK0(1|6>ZmL}6rƯiDusD8 Tg Gt55ê|T;~Ťg 9FNXL39>IQqLp;ѳ1Cp<ډ-mUVW65T*_G$$eU,^ٚ,)HKDؙ` F8`NFAUXʖ*?tJf͘E抃R I_e>b LՔWr'.' -Jlh2!JČ(8xQćǧm:V%0 8h;fDžڦ $B9\uL5OXp(ωN1ju |2Vo_tĦ(K:2kA1?y߾D>|fOZ>28 R"1HT7^VRF̚|COiЄU;uv7*7LQ2 (wt5ؠO~ Du\mUڻEEZ`4rѭRwLb6:-]}\wJ%_Zbܓ5xɠ (5㣖Ji5nYoT,vARg&6̜/=(vK"lGDd/;DM%-<ب*%O{Ytsr2rHۯBO5rˍ,JXB a!\vȊ`OZ6AӔ>YrÁn)~le+s>k: ^:[QV]/mR'rzW8& Bj }Ni&ٲ-,;8EШxM֓zO'-)ryډ'zek ۝ ZCO#aďU&DMa>q2٨ 7Xl:cY* aȕؾ: 5waw y81*L%:I;0!9/ Sq'(w"sF۾勮HyO-uFe PR.߷|mDeSb*uȰ0QSab&Z1m1$&[,,F%9n<PH|W!X74JFvk1D㫁ֈXh^Y*<"a$Dr!hs2Q:Ǘ~կ[pҋ Zî} R ޼[^4jvJ sZ@uWĮA =k{tڛpI +ajduouTޥEFĄ&^<'==6ٽZP^Yu _'qsAzanˑ(=V_L|h;1o$CKY= q‡PA5&^A0R!T]O /WBuZ> @WXvS<8L@V2GH6ؗ*Z:K,]8T6{O,fI9rw/WM/x ߲h*AgU|FrjVm^=vO㮕\wzc1#MFBtj*v!vԬ#u|tu~ MQY+ב+eE 5;;dbrPSXm@@h&[0'sX'9.FHd(=4Y 7P[ l.{ljk}wǎR9-[SjSa endstream endobj 1043 0 obj <> stream xڝZKoW9Qޜ6A& b @KōDzI'>U)7%`0z|UV誄t/WOwo?---]=YQN0ݿ?y[oOTůvJPIW07~wODqfƉ7qFXbpc5Ql]+i;6] ZcnOkˋS aNՆClhfOivYaĆnt&I߹}7tLQ5KӡN(vD[U:'2XWa0&8,]ݢc36E7\¬mrB%uUZt1D,>MuΚHWYIx4FLT,DYtk0v̉AA[@Y紾mыŋf_r a܄P'1 6ti[PKV3mホ%84Cv*WHɇ΢ٷдUܭ~[ ^"0lj-JV~΂_ǙoEA۝∢i N 6$ f{i4a̓۱` 9Gn6ؿ z +.+jA-e?02|5V~+C6a2:(abQ@:< @(xwE9M4tڤ!k I_ 7~<3&:1iT}Lhܚ1D$Y^;TՆ}:cݛ faiXoQ(yuv2ZpWGz3bWP޲)esKmOc=3p[Bf<5´eAáޡ mO$x%n=F[VhM6(l Z"] ̜":zƹ ։Bwm*>v}Q*xF Ό1xɜPe1ZMFMS7Z*;{ʊk'N6-PѢ,PTnirV7NT;|̃*A29X=7a~@"k_֞ pyqĬOEK1rY9$x1_JPAj+|ؘEݾ@Goǂhkr$ QGכ`5+SI%ZB%gՏ>duxKE{hχfیcTNXQ -ݯq ^$v9 I>\HUѐ`B칠_5zzV;;AxM:@b . iQvW=sOԞPBݚοY"P  *͔cgn$:x a\B^: tFRe0ј'ݛl,3@kebL`l*wa {$, !2MT?ع *o 0PLYǼ|96O{HDX1aNrֹB%)&a$& K Ga>Z:u_0O=<;HWwLN{"m+J Z l:IJd@33O\ɀbx.5 *>=F jג{^9Ǝdݡ)Rb;W*"6>/jgKqYYq,oR]soJuHtbJD@֔`b6ntkjf5&-3χ\U}T 橭Bw}m^2w+˱Q2ޡ8r ڵo;?~>w8"2Y@&,wttL|4Ή``kf3VKwW憈T&vMG;zu`A mC347i/;'oabUTr s\ / xKo!rĈ]8D%Mӏti 'uQ*i"}`߅&Ĥ7zNgWN0+ߺ 70F8(,^`z>fT^8W s>(TYį?mkAM` 7|׏MF]<+ O?9 Na:a7MmsXg[Շso:0?N3Ç~02P~;+aeepKCDP姶ʍWZ9^,=.?њ0&t _tD+Rr4Cg\0}8˩mw -BB@ʽ -t͡p`q HV^JvExg$-fSt?#wQ endstream endobj 1046 0 obj <> stream xZIWr &%;7ǎ\J9r\RI`Rׯ9r%F/oނ|M o)N?|Rlx\~ó ̩lv.J/!VnWw[)e;|49*in+8NؤnLoF0g?zWʺl6cpTcq8]I7[ kOmԻpL׷Hǔ~ܖDFoz`.owտ_/tl{X6X<:mnQ.MCӨ3K=FT (\^t{N&U6fp @s||9 >Q W"?(5v= Z_g"9V]Ԫ4g"%"!dɀu׈3u~8їWDr'1\P$e&^@Ojl l !cгcѴ'B#6 ,hɤ4q0)8'rTIObИ 2INc}ƴYHN|`r;C0eV7uI1É}snÚ"${z YlA.3܌iC}?Fc `,!͌!*:]P[^7/I?yRCR#gV2`UZS=<3M& Fr#9ŠQЖe)hx_Ҡ.?QB֭'w2ORnZGeŴ%3 [lW$K.%lڳ5S6 j2t`-yů c8> z5z)}b^rBe qs(qPWQ#jπ6}C ܔU0;fr/YD)38DcblwÔajSP[}{Co7y;^KAsDi"C =0 P;&8 J^%K{=p'QOٴi v 4NlI5{(5ӵ /eؙW 0WK00c00a`3/f-p-:*ԟ eV Jd_ jbIn&J*^YQOj;*Qm'&f[$ /+J rz%يr3 <Ԧ_J>kIWv ;d7̚衖7}3,*0PtopZpw_nL'zRYzuҍRb8m2SH[~T* ~`S ~Ҏ06cbl+/9ޫ^NdY5|޳DGu 6MVN*mKHgN`@˧bWʹ:c-.ͧ_9INN Q?SWCg5lrLn &_ ƙK3wsׅ|9[`Aܗnޔb)6 $V, VgP $xUCN]=R*r]8EQ7͆*XRd|JMlfR( endstream endobj 1049 0 obj <> stream xZݏ_a ~EHM-ߪ=wCҢL:hTaEQ4?3͐+O|=zռwp+X?5QJۇzæ2wZiQ1 Q93B͜A؞tVS3R]|M5[m Pu]s~Eʊ9>&w9t/+fYmRoOOĹZı0OOmOSszMhk[[6 iQ1CHXWqdrʹ__\y*BK¯ݿpZzӠ(MLm|QImbwTl@|Hz͕XH]״AmaOSK?5xNmsTvW=m&@Vij(OEQޯC huܢS< :wd͸[8 -5ȩ-)28;ˍע4zgSˆ(0`nԚP ==*pP?uQ6A%bX&e8fx׮sTk$#mB)[f%#U2 Pq, s p[v#\oKJ#8Ql%=c{سa9&ۓHm㡄)M~8XxUM 6I_Z }ξ }ίҗH_2W[K }4n|υYb}?ʧJ:d4R$ G#RgJ3e/goOYl&;/7 ppJS?V'gLŁ'?ʉfΚz60 i޷; lj/)!ڟmsuI4G,>DTÀ%Nfע(E HUlj '~"6@TEBwlgU98HXv55hq4]nT8Zh/K=wCOt!b2lW3H9FU\=BWLDl87ˈRgQMylaLus|+h>j tp`cilAjdyv "qR4 4Pzb}޲<9d ;@ql(I1.xW1j Ph;a`]HĦH('V܇2 4eXI *E_=BkM7~њ(wl\z֘DoF#}n{XDOz撣e*Y cp9H? t=]g;QgCdnۘP)0SEX|:>DKJ5}HRђfT-+ϸBA HT55;7 ;m9ęVѩm/VWL VV 4W=u8V]PHD[Cq 4l1&_SAbx-%TR(-BE:3 jφZ\A ^&$(Ԁ3ZQG&SR $[9C+ȪJ5YM\kĬ@8\";V*l- Cp[|! ξ>U"rqcK;Kl#*5`+BƌTqz) (ׄsCaCC*0)0-MI y'9;%*G- eLYO7t¨W $[:yD+.O K>7q48R9geoW)H~yI$U ЬbҎOŸ[)$!D#DxS̱blmN(mtJ`ҷ8\ƛ`׭}Q]NމXPYa2%XT"K et4k iDY䧀o9uGe})4(\HaS#-soMɇ sxH/g"frsfG]l+k8,S\DaHRwTz`Rbɧ~|H aǍx!h*Drl-g-Cpv] ͟O lġ|C05c\v^ԍxPpƧ%s1J-77xxlBC5Jx[:=D#Z2 q^GqZ떩6sRCU8 G 9KF@ŧD~Xr̪7=#B$ &d<ᥟ~"\ R%6(o]ZBjҸ[Uor5(=.*"ݻ a65 HjMkퟟE3r2L0S}~DWhFkv(z`C/m=q1x(\1P1&4 ١FqU[)vƟ,w)Q~x4^M ZB8lRΘ!Ti47+*ʐ(5쨞tzU; SP+K'gm{2kے:(zJ#lnPQ(xeF|YEGDAa_ؗJ:4\i>17ҧi}lWvrф|[Jʷ\^~vCxbxg /g`7ىQƔ# 96;I+0r=mկ!5&l'D`*%1}E\ nq-B%9կf:x5Op@rv7J9sVY` svt< on/# p:S1:y514? wj&_ֵ!GfysYT ۷FzEW@Q#JeOX_Hs endstream endobj 1052 0 obj <> stream xZ[~0T<$i$H,v) -Ϩ둼Jl$m,R_>ja&fgٗ7O3Ys1Yτ rg7gJ?nI%s Ƨ_B)notUxvKOgcYϥaEB  c~cd1EUy*C37<[7G 9njE-)t-Ć1 w[jS]tO=sEIT4 M~yqʪBվB✧jPգ+u,|] H 0iEY6]URa^"oMs5*, Bbj0Vf_ի8PNgaQg +rGC0dV.bSܵ4 n9C 6Wd37OHv#К[ 7j d\Tt7ؕHڢ Dp*ݢ*,HUTq.<f[$؅;)2+QP ϙ𶣼^%%!@^2|cE&.ZY6I.n6%TdL˦^m곰/(# (4ebNfQgD<PP £edP8Ь+?]_:[6_xkw6ڴqE$!U>FBһWB<̣Ti,' FM` GC#niJZ)ÌiLqδBzi=Gٻ[ v U,M4t~F)0a 4O2dCC J&G0q{$GV8 t2pϠGZHƥr_q+^#[(e SbuL*$Ӈ<<Ӿpz*ߕ6q'*fy }j/Oq;Ojp{!jYPRs&yYRp ~Y@^c?<^3[~R+A,!8 +k!M$4 zII;Bܐ҉ҶsŐSāzzPU-Zi5N4T!&@F#BwKdbAbEtZ ۲.w2ІpС!؈ nEH}(C\y;lʀ.!~0c\Ɓ@\ n}< G0N.h UVvSN7j!g}WOD<Ǩl<דp\NxE~>vJϧؒZKs>z,/SO)&}#I")94Sr~C]S`ே>R[tٹ~ힰL ! UUvUƁ&wDAL<-DtkHUZm4׎>ʜH6MӇl@ӕ˚-t; -]>*(vdNժ\͞FfùdKOHQA旳wAxZƒi 4D{Mx(NJKCNkOvezIkDSOW|wDYAQϦd ~ I"6%!eB/Yۋھp"7pJ)ƥsL$o}Df1!pN A@{Qh kR`{TeV$^ܘQ\]d**4w+Z 2+t&\kv!"Uw侴]- 8Aw/MqUQ:,n5-8eOsk&ذhU'EwNċ!>'rG ~@U$z"|>SAD0w>ywV~ך#$ 8)(̌Lf(+hPlgXsH>0>UXݵ(.x*x5uMa@dwg.ytym* _C#O8FUV]փ}]yC_h:5U>Ub29 % . BАhh5]V8Wɶvúkl_`}:Y`%8f-9Bt폷Hl?n<9ĪK{h&f'IkrW 5NU0p@ ]W#M S%Xn-WSѤm0Iě'զ3r=u, v!6H=泅z!Ik״Ir[N\h6-hmya>H0 䨔ׅzHumJ]7p:QJ̊Ksn]K?F&zuU2xf^$V@'5㨊$ +:3=P : %R,8QѹZzXt2Le&,,*8? o2 &) s9y>v{;:xC/0P5r9 P.;rp?4,AGΘ4 LF|lPy98$`1 <{Nh/}d[~'12Ǡtc h_PAQsKS7њ 3>:l_W endstream endobj 1055 0 obj <> stream xڵYY~ϯ}p$AXyY ՚a,ZQ{SGHx >:u!)E?]_}T 2-nBjQbq9:iZ'^lnFZ hmrDR)PF«~ʔ"RI{qIޟ.{wXj94k;55w>.K\i~]u?L6TmXIt=:<@Is`lW*OnЅa՞WOSlLx#Ka^o>blTXM}U~v]l /CkΤV"uv23˦`CN8C#hAL-OQTʦ6y`b\L H4Bߜܴk)di4٤*9)5*7h&D@20q GPiih%- 5ęm;@ĕL4EG6FpcEЄ:tZE @=*6^``&9#utZ zS͆-@Ax~acIqb  p1nO cO!ɼlDI5{KOʲ)]"7aUt}nYtmCE Lw%ԇCK(ÚL4H3l&-dCϓը\;49^u}rfCрLgLĖDz18 3$Aw04D Aa+60G "VFE{>(tX;0~kWl_*='?7Yb'{)`u7Kl6[KB~bA<"e+ l&k !w *L^ YP2ͩ(B `H[ߎ S{CFdc#~r;ׇ~cn\F!ZJ9G!ɣd<* {\0TN VTt/\X(1=^38x}spEo>r]g9Rx"4.՗l]d32@yr?LETZ%Z,@PO} f3/7Z"kOy/ Yy%DALOJBWeQ$ɐRT !l+JJ›si,n5ym!5 @W"䥕 k'RpPx #8ZeM'PS`" k.S?2Iyيb4G<vTģ:4LVH9S$ȕK&9HTB>fV>6Y&VcĽ KI e 0?QE c=r3$R٫a.iP ޞ}O jޙp'@C:thty,0p!5\K>-~1؋ endstream endobj 1058 0 obj <> stream xZ[s6~_Gj&D/{I'{w灖 D*$'evfvA\+_V7b3Ve_]V\q*U뿯($W?{NInয়ákq6ЭSQ&kQ$#mSU+|7T;zǑJT]{PkV bYi;Ӛ:Kvv36 }szQRtzB H޹WT ʭ|Vۥo6ޤ3ޣEdz ?:f8fck.9S<5Ok%O68so68'MlqDo80O̗\[&O ߂0Ncy%vqS1[pj&5n*gY&Y p.fBT:񜕅5O>20D߬K΢_Αe>s.j^W_fp3JLhH+^1]{Y)*ʢHi"INc CEĆ3$Q4Kx?˽`7t7hCʾh5n}N\@fPY0YNG5(. &"CH&cahJ;* OoܜspGAsbrgZ'>vT.X>yS?R1%7f ZeG|N/`SߑЕX}}MEѽ9Ui/ΊJ@\r'CrW!vf+G>L>%?@.Օdy[k%J5*DQ ئP? MCIuUr4;2n Qn->7Rt/DmNc.. *,; 5wB11 [+_WM6G_!%~ ٖ(l+usFh'-r5abyز\@1@b9ƀ41P_Z JvÀM&Nv.Hq nB kkb ,(+θ,z^~عik$iE4ékZo*=\^Q%N&w#PGSB/~7_mS7 `;iDjKu8kaq3B~.SBɘq◂n,]<ں,AtEm=sLBR*OCIy\q>BEԧ+\3Gk[=7Ǥ/53 O=Q4p ~o Ciɟ ) WO j5Wbbnòv\UMVS>0v?R-.Ni0y69;OƋ\'ϓ?,1^(>x`_P8;7?JrWu=gd3}ݬՁwlD."PUr|} ) ["')(Uu:-?st!/N!g""ퟬ@+ҵ|qY%& Tu]x#e>1B:Pp ,;W zĴӈPp,5JUɦƉM9v ԎeRj#WlQd+ʥw^4xo endstream endobj 1061 0 obj <> stream xZY۸~n1戛(OiR`0][VǶ<<7),$-tr.(D4I΢~^U)6߭Nd.w,WRʔw7<6ZkWkcLLJ-4qxWFZQw$.ʸ:Zk#JGS(T|>|lOOٱ4eMw|y؞NiqpcoaVc9+\K4$A a[mzq ]kZ- K/D=v3>m~C~/Ufy^O5|pug<}CAr-$ouKY>nEkn,ecGpͦ_*mwzM} 8)xRf-}l x}e`| ;iWy. ]4әƈ\~"Fa'@VB@=,A= g*u`H鼪P#^ps78/}k d[;ډflPBcW t& )d礝B Y9КaēI=a"F v} ri0|.evRεbKoӝ7Tvn$Gm֪(E5;>6S<~=l/Sӷ)+"] ^tpxs& ̺O(!oWmr/g}Y|[3KƗqk|ѿwx WR6LpRXt&mM> Yfu1]&SI#ssYHcݞPM~U=]=LرOsn /`ߌtKl{Շ m{i4 ĦGv2ie*l3YmCGw5 6,c8}"(U3ԛM3 -+^0ꚮWJ ]?Fŝ5 b72;x7( Z10ق3 ĶǖN`*a|DM X `"6רb+ nɶ#d$Rx5]Qv뤿9 S ܐ3~ȡhqIJsI N53 p$EeRzɭ x2)|F.1b~՚hb؜E!QW=kl/}ßao=?g2=˩o6өgM*p/.XUḰ?.l:O[3IȒ2|Oʖbnn }sl@ttC;\x Z-}ߜ89mkhI<#'4vcvrEJ`r['nT I%'dAeML}mۊy\p4JL.-^9EV3ȋ%݉p1o+_J~IQS<7]̳Aa)KB5!H*Uea9 5fwO=70E(ѯyl$&:zק4poqdۮA(LB%RpAk =D)ֈm Vba[[uA`;$ÆW?y؁>nOMvu;xM2$y͐hK)\b*p-̞;-iXGI:ݳ>.h5 2]~S FSW;nP+ 8eWc =|#A+d" xYB\(l)doRTd.mt"Y$6⧵Q˵+a9em͢6"%K.{s&d¡ErfR+yfVB԰9ÐL5@X ~w e"B)8ߤn=0 vQ Uqq]کI'Gwj:nKJks |!qMAmMZJOBT&k1I9*]^94K(9f>hF2SE4ʲ@RDYz,oYwl #_d[{@vx0 N^2DXٰ-EU/*> f?TƦӃl HFG$en4LW r0 dYYOVۧ=}UB3w4PvLJ j ,‡ܧlXӸ(-G{n1s|wQ엶NF1ӽ`Vû_/7 endstream endobj 1064 0 obj <> stream xZKW趚`#7 8""Q䱑?ni4gu=_0V_X~XXpVyi݂+x !EeϟVRemIa[-Jo;aǰJp[9++UaК4]%'x8u7-;և={l1r}:v;a/ß5?$sF6($'8me"c>!} (6}C͚nIwwUBGi<g-lJ[ҧa ukT( `6vCsD:PclT41zӜJ"QhoeK 0vIPv\%#m4㪎AW< ͆Z QJS룼H ,r*])[#EEZ忶 RfD>4vК4 /ȝ%Y8y]V3l5ӱI*#L  "4h~hcMtd WFa0 E-Q_ |UlhDOFTRUZ_;ܤsWkSۡOz&Omwvp\L-مDZfuE5~%E /šTA!eoINAD:Nu38ĵڇ%82V#+1Ppq𐭍  5TtH d},tD<h݂$Mg:#6n /aBVo".q1@8!^yЇmGb͠vl%0oХ4Y&Hy )^7W`0EB;0Y,R-.%_m5P_Yv0ZQ`Xƌ: 3hϫz8հ424J+#yD9nU6caQO٢H/ d%?E}T,!s:b֊s]!SN)i_1 rcjz!63I5eRL/Q mEg цl| 9)h|3XX? (z).g&.Q#5ë1t.~f/0+=%Kr^hu om<.ܟX )Rb)XmkZs-z56$Ej egr._A*= ǁMvtޅ!Znp_ J׭zzAQ:{vynw_)}i[!o 5sif=\O Vaǰ+o/M"=t*һ ']=i"3Q'x:mېN(051% wot ,Z%kH*k{~ Wo6mҭP##T E2+,\2sj'h@B('g$9aBt6/i#!p9Q6dsQ40aւH4tP4b~M7cENQ6+PZoGL 8`aUz}8)xZO6v ~>hgIdMސAgE8!d[P=t J{4!zװi$h;f$'GhʀMAW.uI8zO"p.?y9+agEN? R_y4Rɔ@ȋ2 Μ=LW?$9"C /@A{ī s0IN'$'~^ntcXo΃)9)%zo> NV/RQ zlՍlP]<D6wy7q>. endstream endobj 1067 0 obj <> stream xڭZ[۶~#AOuϤL퓛ZVl$rCJ^+= ]O=D0@?|귕Xq#VN|9߯ Wbu[|%+t~̾ߗ[+2nnmljs~J ì7k9Ar %Mi;SW74U>B1iq.ewgD֞-fxvN}x=L ZwAk*(*+vha}+ĕL&2 !jNؾܶS`=TMՕKT= ^X܄^⫵Pdc`js(TS<]~& f:}qSP {FڥÊ܄m+^o@( *fJ.=n'@\ j>0(~ctӉVvM" ΔI|(SChK9Vm_6u)Jܟc{<%/̠y ) "yF'evQm+t> M=|rTNubڕ89Ҁ7x:F&P憜/\3Ux3|ۘ"x@၏?Tp&Xk  gZIrAnb٠ ~A8C9s>gt/5zU&Z(V<.¶61$!sV*@l;T4 %*MQ}Ů됬R ?ʳ#c9؏""nG/U<y W_Aރtq| %D hTD6FVck!]5 I׋!Kt -Ѐ3:_U褦gzԬBo[C ۷‡-j &F8oр,GB"RA <FBΣ =~PS ]0> stream xڽZ[۶~УԱ 4[wt2N<X"eRz}d:ޱ }->-؂?8f7|(ԲJ~ׂ NJ8wޮBemñ\~ӎ?uZsܜMvHI#0h1*R於viLJ0xz'Ptgu6U.b=m\+Ŗ ._Fҡ%JX%ݟͱ#m MۭqiAfEFm-?>{-8%̔g(;sAB x#Ӂr)!Q:DVknf2 nd,,tn9v~k|^{ дZ]PEE Q>'> "ɫ{2`AE0mͰoO?>4(.w 1X/ea58 邶#VGK%,FeG# GROC7%2U$n B Ny[i>71Xܾ ոlx -יa2!,@!pDʔ\w<6aOLo8qj~nj\Ht;<s^8d=)/Nc ]^ > NJ"t4z#1: {{%|&@1#QZyĥ4 ,ʱR}*ŧ =.n5|25cBu .䐳 FVY&0yBMf{arZݏJEo-V}~ F50(}A{XV 8Iהn{E( +<36O]T,qQZ0L ^Ԭz)@ 3RA%s@Rj#Dpq,vQQiTؖjwZ$&pH[p,rS8dk`S_uʨ qIPCaˆ*W5hJILq*ZnST Q7+H] "h>/š$48ؒT0BOJع .l!L!oRu'7¬RWy`'cY LI&lK4&q Kau,RlrR2b 礮ZZ1ń&+\h+SM% T:+h}{orbխ B\I 5l* ٮ4L?_T37H  2WhY`a2wu61*@;hS7wX1MFwJt6jjv0kwEa>NvP]nsmT+1?0:Ws3eh)?kخCik㱌a9_i1">@[m/Mied S_FZOCAK !ąi(!`R& ctVi *7,NO9 {{B׼`Wٮ0S'n89 Ʀƛph>!l x_^laEө޹qS7<;r)Lm~efy$;j@z lT= 9kj؛t2#S6DEB[;Cjd} OjY8o8~0N=\~ox$m ۶y嫈4 O}w-gpN[LS H;IDY˷(GZK|^=nQ_sī&Ʀ0$I,op{ C!}&8FKpnaVWak1,N_tJ[A8bE/ȓyw (9.KLZ RIR"#y"$] |nq3!mczuW(\=E.@/)mvi- B~65&^'a?T~SB[cK:E@GPi|GLq_a`1`]1s+(+UI endstream endobj 1073 0 obj <> stream xXmF_a^o^;*\B[ \/xsqq`;T}ܵU!^33{؋{'kx8BibopaRxt;! 2y.]]1QLcPNV"=UR`in_WEqUeݩbaбzbl>;Uۮt]7ykL-`Voi!¨8hRP1%M{Ҷ˪O_._e_πhsBPIEkK;AՍnu6'uʃj}*+\1 ^YY*C)Kg-bbO܈4h"m}!(~i\*)U2ǝn4a2*ˏX]Ph9tۀV W;lzYT \AY)Mxi,)L''ޚ5ܘȥ4y/ Yۙ&Pl5`+[thZkqk޻U<ΐ!&(:bZ D1/g/^ϗ_QV{y^>[1bO*gQ7 p==жќ#nt=| FriWwZmG6w*!m.aNiڭ#gc3"",q+5sC+&zn G 0f.Wf R(Ǘ'Ԁ2Xt4zgJKǒ\ ߾j/0T0~ꚓt^֪0'XJxpqdܛ&R.؟m=]PTD.nGq?).f%G=ov]I$A,{ox0z" Sua0R Ub˪=52ԝr {!JMv_昹N#BzH;Avg;m9tL7#An*y<0H 5tB=BF#?)Ĥ(Q >_+lO_IevГH,)>NwNpYT2Qdns0QaOW2s'2 \2}_@ endstream endobj 1076 0 obj <> stream xYKW)P4ŇHOvx <^4{FN4;;H~|Hz^_ћm ҍbn߲MJINtsߤzr ~J۟oa8|_sM~S{< E}?o<Me*,K,DNt*,'|,)@wʶ 2Gdh!/[2\BijC b pADmv Xbe&Agģ2{Ә.c|&7H;Ķ<m 9(RiOWK,ws4C[C1)"4Z7BQr5RWOM:\*s1~xF,\3j9X2C~1[Ir` ri^9'4^8D7QFw^n5J)'F*DP@n%)_L9DeڍRm>]ۀz2Ù0"ne=Vc*Z3u rV4>X]0w7ZlijoSoUP7p/+(JoLXn^h؝-E槷U=]];};\e Pyv}#B+ipo*t!5bn wvM}t'] Km4AiU4;K!IeO*L_v^ɇj Ρgr6x2GtR@)}^Rc,G)XJ@$U.}3&Fmc҃5 i;gXx43k4Y\:y6N\2h**ó ҙxKaJ/|0v)K6Ƌ #+2MhBǫ#k/LykSgN{^<:h\W6ە I4kcS?6/Vu%a]> ` e? xzhx :S6qw(v4H`!zCNxp=ZfY)*zjF,CiG5x|GXϭ9%RRJ0"(P(4)/v-rNzF:{)SA:P. V|HPM=$`Uz6)T9 xD!1#i|I o(+0[Hc Ž (UI%I k > 6x]XT р!% ʲOu#G}S\$L_ b` Z΃Xf+:~S(f&tf,URc*[O[bvǨ3| 2lxb1~ \ѻ-#.6^ mc:C2"əC L(ĦBtC:d7{M`E;P`ot%'Yto| ȭwOE 9!O7{D2n!j 7z'眰`D}UAЕ{Δ2MivmW.G*R Ψn\8!@%d1nֶ)j)IJ_w3)G샤>@T'P?L+")y5Qw)bϱϤ=^/A,˾PbܘtX̕ȒZ.lb mh5SHTu"Jn.hZ[n4>> stream xYYoD~WiHqovxZfq'cvbgmφ ~<՗N3aYJU]W_w I0DR&*wMmsjU+D|7+!;ٲ;sb X鹘^`}~-0B6Pv&KBvr⭁}vDa u]wc$v$A9pX-@ c/2|;A.*g^^3OBrv4 ө#C>: ue![!E31vk(&\IWX\ 4ph" d#L,GrC!,Be%F52rhCG>_ieX//iEA ܓOBJ)2QR:YW͞A F v#Җ0 $߶"#tѥ@ik.͆EsҌ!s>ݕuCb=0tP6^"&>x]ڗݠ N ˻ Q9=j{J:Pry#'>Z;}Pp3G;Q b5fQ*JNs߃ܥu7-ww-`Su4F}Nb70%r;ӿGEX  R+@7^}%9rǗf1I7k HD&)y-eu^vD[uH6Ǻ]yNd.OtgS8>kBaG.Y4eS@:6?v{|0Թ )-1&1eklll -SNu4-It犀e1 ~p(&1A2 0Y)Sk/"@Xş5bXCpb9 >VA~* Hk5EF*`h'6:aX A}@G}+SLSЇ? ]PN>ׁCޡYeH9{cC?ϓ? G7 endstream endobj 1082 0 obj <> stream xZ[s6~_ 5[I:Ln_?mD EI[O s·\/3:ilj{653ʉfvNTgDkoo?\^Syo}z7ɿ}[Sfv]lL''`n:gI% ?Ws^4ZL0Os KEMPef)DqF*7mosI"ޓ["5 "ob#2E2o.pEi `0+.op6FE8g WU{ޕ*R'8~8vNUQ( %&81ZBU^Ehq [jUD`DdŦh.W%w‰ % jA" 揚*tEK[ض:KY W>V\JKG5#j$/PLUEAÂ`0hz;A%N f:tY{AMNY)Tp( AA}e9ܭb?`*yv7G}ʤ$VrmWvPn ДyXuѭQhnb Ȓbb Vg%\v{'@ "Ԉ}ҀN@{< ۣα}%my+\]FgIMZqnx[D0{ \mg w{ޅyÒ6u,U()ڣL[CAuU8X718R [#\v h sHf!A\(F3 6|MYE`ϫo`MM8Hɞ&Yxm1G^'`o8;o۠òٽ̱n?_ "ԙTG[<6Ţ(EUhA.e#w3ʋE3Q *~zL1.hC &P0͡ (0' !;q Q8^{ۢpњYv[0!`#@\Gh2#/Qǀt>a1U{@-j埋j`6S^a}[`n5mUy n_)8*tˁPzs}3E0 ՀMA+_xױ@̈g[־/ ߩƯ9 RH_T&]Id':dw;IRPt?M mozZ%#bCyE aϷ`:1_.dhB,: V;})pkB|L//0#uaԦvu1nB[3KA|[RbNr͛iqEϭ/#F2ΞOСL{] ͔4y.&uom *Si.JZXyv=MTiH3J풫T=_uǰ 7Dܰf/2=C`bpd>'")_zBaT,Pw\߽K~ M,3WCuȤnVwˍNJ9 ][g^g}3Q a՟ĎcΞUiGnxNi L|> `5 6zDC2 {t=G{ ;_ŋ؁ݖ/جF5lq4wљ9p:j'ְJE~[p߸H WE>X,&|P3PqSb LB^J`\*B ˗pS4vdV6n^5E@R}jT=' |^LZ4'ⱍTm0q CqA]2`l8hxnیW؉Z;d;9āCLH5}@?/EK>!A2̕x ;]fC};f?q~} endstream endobj 1085 0 obj <> stream xZMsW1{99lsI%E"!kP^=3Ԁ"6rIU$@V^Ut7?--,]ܯYQN0mӮ|ns3a !߭s_Яm%$+p)*@2 dzra{8%)R m8I!X8ZAGE:M;S"%%\aR"}R-j1v )p%)I!0ϚF MR86=4+"=ͻOɠ6z:a(AdI=euZQxh^]6ʡn~ tt.P6Zx.wOFxs$E c^T4MXU)H)iIbܦ;,J!BN4C_DZ{y>rn!-Jz7|&Jo$@TxROֹ<4s@pmʦ]wrW?k;8R,^Uzv W鬫ri D*{*饚.i3mQ! ~nڽ;m\,!kMS(Yv4Ƹ2D3 _A}^&^0KiXm ;a cP=驩3잓n`ob|] =Vx .Fqr SB&U|ƒbŀXs.'/FUjvS_`#e۞D[3B\PX7lpp>)ڈrgWԽ,g4*޲mvߦ\GR= XŒ(p lPjy2yDdGj#6M/Xts<zMjRιuxkтAaW&K¢#^m7&<@,=ܖ;U7F gS_p'B X!:"ŵ`vDd0;CXų6Y((}ӜJ,N$d=)-ʆ̰$?](>D|3 J)~H*u(پSiCȃL)ziQ>^His%a^=cDfv">3;[d? s[2 "Wg=fh ;9Nrdy6Hc. #UC q"$U>C9Dճ:qkq?):,ceOdk`H!ƄV&)_py!;}eDvqI>p+/QQ۾cǠdx,js`C'יi-8F@IV1^ScJP]i606tRQH@v N#Ce9yb0&:q|Q{UtB7ǏΗtʇ*j+Ʊ1=; DA78m nF :-h[ɓݜӹC. D(Q朅Y[!i[7x\/ -QUb.:vxD-9P12\ET}3mXC۠pN۸>/&ry 瓝[FE+lacj~z[З嗑-+ x?jk?$FR;hQSGWx&a8澾M70oz/ 2Ԅze9M}2=?Wk&B/X et~/Uxacӷ zB]ucO34(Y*rnQ_~Ƀs]zQbz}bX*d 俧k)JŽp52.qe`GGRISA o7U'ׁeE+n2$ś]3)LnuH=|{ JQ؋-< ^Pc:>_=|])] ~X\ {s6.8ܺ{X9nGn_m<XKPuKfҼE]wx_oV endstream endobj 1088 0 obj <> stream xZKܸWi\%Qmx 1xY(-M$gO656$G=8.| 7_OY|wsf%+_vB ~?}fR&eWSƟөﰭa|jȓɮzT Wv~Γ7];Z\~CeP5v_gdinŠ %v0͇cb5_V*X.E߿jc9 yoވ4PG%T2c`!J*C2)Ŷ4ǶMxCNsJWJ)&D154S&3S3|)#gA<ÚY/eR[ulS%Z[e'jG;lh#v)r}sŎi|ң]wt)N>F*3&$x."q E{Zu~Otߣ븐%Z]"i9=JzcnbWeDptɯx#~j nە'5xlj/20s#T x _7URmGAR8A53zu'+V/؎S63^B)^dY:+)j9f}nwQL4fXnG}Mug\(0ѣli/آUҗ 625;f$ >޷`x/&9Js"[H՞VcÜef fJ9=l% NjH t;@Ekq>K4V0vîiwxL}9SIoS?qt ~;aow 2u(EEE9x/<'8ESEsCk{ofo-oFoacRU[:#`.ؚQVT醫 `S9^{A򅁀 k)8[H 7s8}wr!YVkC>8iB|;4U~;#Lx$xb< 8ϔZQp"i(ԇJtC S_6LW RƄ(E*@K*Th.KjR. x m/|slEGi,`U xXJ޿s]t"#H^ Q eن%x)>`?o!̚S'p~ 3OU0'3~-(8/dmM4ɧ`P$fu]L뺙5`bmO:svn]>=SyȋzxYMD xDFl2_,v*4~B }9p 4wCy:5R#>~U]#ǡF28s\d,i>NpWy?@z.t%kmO"ZESY;t;D_3p-,ḛ*y(DMUH:JN 2<0\.PWby xxǹ ƥ 1o}|$),7燚-|JCװԐy_Z%y0.؛mőY1GBe!-csӖAy-L@KCBn0ڳ@?Z'_t2M^q#"8Sa]W }aƻYѢM3l5O{z}7g z7ƒ2{rFε ^X?"scR ^*dbqPyl endstream endobj 1091 0 obj <> stream xZ[s۸~#5w yڦN:nh HJRɺ Eڠ,zA\s]EB3/ևo߿g [.YPN0mnW;,WLYOw˕TܺknTpixs,% KIM#\.HS|[7qЬr֝٦ܪڮn6s]%SYZ6y2UHG i39|`~r=ErfuWU;]vt\-V ~*á]y+h.d$DF5DQ.)[FAp nCH.C-%ۈj*C19*5W4蒰Xf{P.Yڬ۹k߇р|hNUD1> a՞}cS&)Wf\D`Q~*ؗ+{A,\LR)* kOjk,2/ Sep޶.aU /=|i?imJ^A(@;$ݕ"FؕMٕJDu5hKٻ <#c br㞗v_wi)*"Xo=Q"^c#+nemCJJ?D5~+{7/\-ƣѪN(I2,ajS=)ɛ0WP-H>cabpŸ́"MLm@D˩n!eub~0jRI{H?">[h* PX2/1a}ل d|Arx-t<$_a*TVOP/4q/#>0y[Aԟ,xMNo,RW7L#xV1|$ݮ蒾V~mRbަƐ|B'Jh4bqFpP7%yOrl%AMqv TIPn~'| ScZ=@"0bz|1ĈS;qTzǡ#MeoaMa s0('1'JR?۟\{44),!ȳn\&D,2PO+~ %NM\VZH^@8; 5CXۭ[ט'Jzi.! {@0>5$!AecèI\[qJ*G~OBN;tr+j5n5W:ǣb^@&$sNʩg'$5LS}|j&ɕrh# ؚmjF+y̋ Mb2^-AUA/wt{2qX^w AEu7~&n b1Jg_8i݇D{ =_w&'Om'ou7J|Dy8og.U\$bUp^@P5 U(OSgSoJO}2ccUR/9mg+l_e2\KG^U q‡p_M(q6? 6'l]DhIr_}alBT:V¦rl&ta4k;Kj|<*LV }q*l_ɮ4218`v  [O?]mHO1%kz`&ziKy=\JeLSF8[@spt3oM6iiFࠧ| |w kXo]hJPו;;dS"h1kC;/(6=}ՒSzV牁Xm_Y!AS 23DD!!$o=g@mo|jK6E-9> stream xڵYKW4o}g0A2H0كƒڵ%G<=nD+jYa#?^moW_HW#5YoWDC}I+(* o߼{v3ƲOuCך1 GwnSmN]"_Hf6[ak{n׌dctw_bSy*'٧cUu޴X:v}Umں7r"b1UxkAW4+^ Uݬacni&}B!(>yD+śg2Qft< F|&ؾ~ޔ}2{̻qW9LpPZ w S١+7c҂J1ԖCm`#Q3z$|Ą$Eꚓ|5+ٜ>Xg=C7c!ˀڹޘۻmǯk` }W%P@<աtd2*6 }=&!imo@)r^g0և|8J7}s($$8@"r3$OԴ# pBFQsN0P/&9y@$w7U3WL)ui 51ZDݰ. ߺMPaRN  I2GqWn FU0,XRt]@T 5xTHIUNnP@1ز=6έq]MWM.MfF(}}+4mʳ %g[BnqWR+%JQ fs,S]@i;!)XE00Svt{TIblT+IF:NMz.]zRr%`h"n dC 6[o;{2P3kG &o /@o&B~LsAY餰Ҵ!̋f[0:=`=-|%ufFpt3>3a7/:L}؛]in>Q %.eC"JAá.mu ޜӰɡwLdJqՕ6)i$'30m^kQOV_n_~?؎ʈ8];y(q|D';q[Yw/SAC>ih5V*V}s`hŋz+P1ڕ~oߡ'=fwNA/0. +vRYY}BRy u.fO֊ 6}=\8*eoG{n`BN8aLlK0_tn#< Oȕ0Ӕ kA'[<4@pI8L+\PA׼m?mKd%0 sMv0:n ozt0y:0ǧj v#1ThG\Ƌ9OI:J,,V"ud, B }.!rs:ݰ$[8S+oĜ^fzjq¨O\2)>;q۾3Gz1dp/&6X{b(4L8A8(*4ޢ3 XO>NQ{-8LLc[}Cƃe_S%/ b{ɧ[(yO GPWZi$kG&2HݶҒ%Qq~>{3pWxIxpY s;MB&7qˋS;yLM.`{q,J0>-~y kڮI?::PSy8>3OH[[_&ٱDPO?##r0I.?痋k0M"|8fط+7@eX1kp endstream endobj 1097 0 obj <> stream xڵUr0+jp[WVmi7xWwi 1_ݸ3cA=s# f AVK`,9q@s~zq{Gy&~2~Tɯ7`Lnr)l^]`?NbE0]{Ċ,h!rVm )Uqx! Fz=i>5~x*aiQ_rud{aJSƪX+{N2u2Nl0U[\ɔB>6ɠJiĊ* iO+L)\)@lu.%O%bòa8H I0fzPFrL LS˥>d~Zbw$ofYЭp-?r*׾Y\kW:f$<ʂ } a0奣v!v=\l)CTX[{a`D) ``v";zZ"> stream xZKoFﯘMkǁYRr}fZ+ osqSYy!gwuWU_Us +IXmv_{OV@Pxuy SX^eT%HJ og.94ڭ;Omu9fُp﮾9)~5hG=60:L3;oXwmPe̅?l* Jwf*Qa&zW~>+įxǻnqMMI%bRGa6a#{ (a[:aڍo>V,0k640fâDBJ?P߂jȪu}ݜ1%@)a;M^jÃau[UoV~\9G +7AlFwE8$InX2u|l&ncn+ 2?-rj0`}aZ㾟|1I,cZǔ/&0  ؉ aų_f\&/.EҲ` sIb,AHbF2%'> stream xXKs6WTS/>SIfK'b(H,R_ qtlA c~p.s|Dw>o4Gyp4{R%ce%gmADmz%̚G b$F,j5+ꕤ!42rS|GP9JT U]:@Sg,X#fp-UJ[T ))ِRD`ꊃd*k,I CNQBrl0~<Ve(͘Y)*',7mUAx 䇖D Dc5pԈyle`a&1Wzo'mI%AvΒ';l0ߏ>K^G׉R?ˢ^u"SQY .xB`ĐٖNvq< S eH ebg}6|Qۀϔ"SxiT/ ZKRES>!{~gghQ{sBsϪo%a+F٬N߮QOy+KCK(R*ïX&Bm4i.܊n4mE?Q8Yxu4 m_1+wʅM [+o Ќխ}< 4~7ߴc;4Xi``>5֥cL sgߨij!UkY1kz"<+cd)8Vqa"Aq۪~pp`6wRƇMJ\Wϣ1ת f+jM؀\WZdcyauqlRߟ"ݘͱ16镤"S>ryž1F)=IbCu q,ރǨb[39mtAhY|A`خS˳Z6jlk81Wg,E96o}PKyEڼoi/9s~ }ض4k/,o|+ˢ)k.lj^bZuJlJ+|Nͽ]L\g endstream endobj 1106 0 obj <> stream xڽYK۸WTK99uʩĕē`f)RcǧIP Jre+I?Q %qo؆&$Or?lh"?D<O0ΈR޿Ɯn~M"Sٝ6fY2P$m$Tb C]+j")fB%ѣu[aw} B$%)NTԏ:UEׅ(lOEgitmQB±b6`e_~Lhƙћm,= eN:4ќN04'i*`@>KTQs2nܰ|<}f),%Rn,j~=K?iDa2!2uxS4ڇsL[G֊:t,<,/C NT>;KEBC-K1x4x\*CKHa pmc\hDF|0:ĩ!BYFr9_ AE8hYz͊qmH„_?X/,G,%*wqCY=S%`#بж.T/wC|k5].,u/[Ex;x;v2H;Ɣf$jxTB55*suQۧNbRg&ѯ9ͧi-TV~ޜX<KzrD pfd %Wj*4(.uhP0@ AY@]!^x%10T?+Y1D;ieAR$l3SߩfszYF\ 0? /G*(jJ́)A Ʈ"ʽ@ K[򹴄|y52$>8߷y߂`ei7@f봲_w; Dvmi 憿~h.hRhܐ$qV K LLÜCWe>}~z [!] +x(jar^/e±j A5z:PT^tvEu`}@o_˅K],113c}_ˮw1]:)@^+uZ* A?D|,n}LN} HQU͆ 3MU5ntB@ RIX~]5@)+*ԅϘ!'88, '& yn_ywЙH/9Q8CpI%`0ۋy Opb ˧7/y++w=XdHF{TC\T׊ 0w+y[-Eb<#A}sw\غ>Dg!18bԩgH$b v ոsAqnLdF-v^pIF5n"1M՞p*WڲJB%N#;עX̃ j/%ABͼQoHȌds!/DN#v *aU-*;İ}qk^0|~ޢ32_a(>. IZc!qUw!7wvt,_tvaE#BekD`h^O+-6a>ߘ-u7YrNRjg\%vӌ_f7;෷'w@RJsA{*ھ Uaq,eN3EeUrthڵwcޗvJh6 T0!6cSD5)MH@&Y~rqHk$Lﵶ@u5M!SG:s 2 lL>,(~WV|x Z(WLcUŴ]/N2Foltiq5bnnb3v3DBX 0s_+?zdj7ي ӄbƺtX~܂AvlnKi-;/obz{Œde Om4gYL|3nФ_@k'Hߌ%IN2b6k*ˮ ^\C2ݺBgϢju'Z qƖ] XAi+}ʈxfBB(pR{<tQBHӁ<}{uPj}찈bԏՋ} m8OS\Ws|y KgmfHNzlK0"g+bCcR.)i*3\4绶tcof*7&3`4o>nitot:ppÏ endstream endobj 1109 0 obj <> stream xڽXMs6WjDI9m2δMO/IYL)G7]$EȠM&ˆ۷G$Dѳ V$F$Cgu.tJc\%כU"^wO', 10X6qW{%`cmYwT]܁G)/V}z;Xepq f5p| !^ ;p&{zx0?1e.7y‘piۭ=p_&1Qڥ E$G(~#1`qxz`n//CPӻ^PI={4E8% s:lE!cIh YB<<"RSu{w!K T^p_Yϡˆdyܸj_ _BLuFjyƼ:A릸3n*&\Lo6tG!ɤ 1:v:Md&*;Ȭq[wy V4 2VM:\)NFPy70^q~J_NFoe޶A9A~+]We[O, } Gp "dLLy{. cNc"Yvaym[T8\X | >*T,Rf]ݮow HWuR 5RJ+5t.7V!<}јΉڭnjw[_E'+*aS3<7z5uu[޻e]뾁,9d!3C CWX6( Z΀vl!*o|b`PIh7uv2 .D΋"^EL(5\.AL@Wlcn9uїed!! ~^Vx+1~(+vcjE͚mQ]^38X.pI#lKm*HgW53:GAДyzIAӯ&SEO^/H? bV1NvMnNh*ӗˠ&TÃxR֙3`o0%LHԑ#6Qnxf{y$|t1n68nƆ>2!xtVW$?-tU_Փp7S* /g).FxO6 TϏA'FG\CVd&KL,]ֶuY+H2%<1Vhob{ߙܕ!/PFk1 X7̼װg{_AbL@ k) SFgEA,w`0,vqwզu c4CiϽ{q||!B(ӹ &0ID*ijÆƝY>+Ql!CvvAH`yXn ު 9 GL&o6;p !1Hg^~\ ؝۰~S$a BȆn쒢: ]` V{/((5tP$a3,bV5Vl4s;{7s5(5;(P>#Els^9/ Wھ ,U)&rUwn} ǡr_%s`I Wm&{+}7㳹uD1xҁLDۺY4sSb)f H>yx:DלM_o_AI L  S8:* endstream endobj 1112 0 obj <> stream xڽZߏ6~OXooHwȶ/IUIv"MR&(DE3|CeiW+IoV^}p,ǫ (gju}P!^Jf__}fRJڛfomYK?딨ds:͚d0RbN*)ˑ̬,Adɫoa'BU% ɮ"ڟm!ì)1iLLql&8}_CzI ޏžϙgJ/uIP֕uULx]Z=6u\0&)5CaWQ2{."oۡ=RI گ=oiNEҴ >1@,wǺ,ὕܕNUF'^o8Sҋ7v+ǁC6ެb n(\zeiOVXff)Sm09lp$'`Ig⏓YCǣ03R#́DnY%x\#LiNP.Gh}R^醹BD:Tn~U6[XȌ`>U~-8ـ)5ϒ|uJ()ň)~ j$:$ah$Γ(E?MUzdG (SVfMq25Y;f'p ͺØǚ+2r⠫WI{/K!If)R?ۣX158Dt#.\ԧh+Dk3 3_]t|ZTe@8d. [H}S .ȕ̺C;`aM sfnul!0s.}}p p" }4=ZsP3\!h:z˺,wSK;ϓ\~a$ȈCR6 {LL"&MńAԾz9} emKD7ҐgHuo51Yꗹ{/T|\U'p< F^ֆgۑr5"1:nM0RJL=~4s9dC/mSZn҉;XY/]t?`12 9T$r#I299NJEstvY$tSWpDZ ty=2%o\ &@|Tl_RN J9ϔ h諩W釮!*t]Jꇥ@[e3CmAkWJ_ͲIΒ[fHP~~؎: +Tb9wi h8> @꼏Xaϲ ۶2JV}lg91;;&g6=v=Lws.! @ٝ 4Cc \vOTRp@jФ j,!`1j=Hu@ޖă/n/bUP-}UҝGݻL{-xC'lm> ONa99AaMOC h橡l:A1jVs:)/`ƽ|}We׃y%էm:nVf`kC1$w]5n2F< mvUެS Hs=xPò)?yޱ : p_aXJh&dX dx ?O tIOedZ|I?/8̛F nkecOJ >{4ZѶq]o4]ln )70 veo'v l{4 lҧ $=%ӷ /Б0XeSB}࿼kR@ 0DMަi򙝍9?v)!qIY߯Yu \@$KG?WVy 'S `` $9[Sϭmln1h#> "B5 ieG"Ψ}N1D=u 6enf.N]_-2{@7ꪮs[bpqVcஏŦ^5!5UQ7;{92De LMmŌ3޹ݑkGLí:/V(BGang߀ٙVHR2I`t(rʋg PJBTX)j(UNfS̐oFa#.a.3W8A\Lk &w6cS)т[D^ &@x"@9u7s>bzG NlBHx.JT Y›wl;`L'+x>Tۑ:hM M5 \Y:W& & endstream endobj 1115 0 obj <> stream xYKs6WHuBomig{zs%b**Iq'?iReٓḋŷ.τ$DQ.2y&#5I. yrz~)ic,Umf9"9v SDN $NAr -HX0 1(e<J'sݙG((X5 2w-T ҮcҲZn+˗nL11#ZVԎBTjdU\-X۲+`aEu0 ]d DGXחUx z =ɡJ.lQ> e:U{lGFpω %ฝAdh?/9/t|7UQ;t8čj$CJ?@cs4Mӊ-G )agP4br^m,֖+6J`@poꛦLBH_:@\ I$vc@E6eoT0Tjsmľvǐ,1ɱ-}dtJ@&5 ,% Bt{J,JY_+0D/ 15֏?#0V u-~)wEc'<zQ/peW7 endstream endobj 1118 0 obj <> stream xڵX[OF~ﯰR=mTUT)e>;|_ ֛j].#)MDIT`:ʨ.J+D!qdE^ƥsfޤ>(Ie^TDAy!fҬfcJ}$FLxlR 'D2HLH ss78.SA[K2t,Ya^ɆS2LwAZeUM߰.N{WGkc'q*O\Od|)1ňP?9#g m}K\s a~{!bn%A?(i|0|suFB)mM <"z9#NQ%I61Hb&8maS_7 eWvI>k(x`W?eC8DQH (CrU6S1u0ww4@c7W\ ħA9t1҈fn[T u&FDG˦ ճih" ٤9U)LU}X@4u d50@w[#>QX`|,G'ot88(Bͮ\E&`U7.IaS3 F\:F 0' #h-j =FN_>&1&<2z]j̚tn}e4Zz54 &ŀ?]puiظ8AG̛֥(*rIqcUmcCE5(hf/E2Gbgnݛt! _l TT`)YOuiVU9W:hxiAHae]NhX85,p$'t6qq c Ɩx}+<BR2yn$< 򢪓"QcȚ8ٕƠM27[X4sy8ԑ[G2f% (de]^Y3Ɓc׎ّ~[;ÊVF >Nyq@/Nև $(%6J!lpn\fݻP [j.8sgAa<1m- ޯJbF$ <NCMV&RD9(ґ''W8`CI6d*wZ8Ks6 #:ܩs9&YffEXfҬ'? \h7yG3C]"B18:L=Um.F!sqD E<}V=jVz]*P9yUb}-j ͕ 6 НDwcEmnCU 1!h'ZZK*I0޹srQ˙\fgp(?YuQnoWs6y _bsT_p#sGM->{| endstream endobj 1121 0 obj <> stream xYmo_A*̽}_( ;I/Q>"I/HeA{-djvٙgfLjD>$RpG?-ohD0pF6"iDx-7CE"ozݵ˿E$7Lfv6#QxPJde$+:?tf@u|LWTnx#fZK"1e3(AJ(mQ!Le;n )XwH&gp6E.ΣVT]p)#QKSW$^mRsO¯3ݑ/z-IKm]"!cOWA9̭˼m8 'E<N 6S]^uh?.{Sp Kf`,kx v3!? ?_VS^A3S\XĬSL_mCK̾8Mٺ+<Z}a^/P'){63c9F]﫺qH(7M _ڐjb _I߹]n\SQr,h8uiݯ*Tz/~Jڠ8a^wu,b>32DNiƙ]`³ҟ}[nThT3 $ 7pt Ǟ_E0i0,xE%E8gE$4#.Hhu]cZ3#\A"eJE#(vPCl Wձ'ŌN_d1o}q3aҙ!ƃغʬd4bü0lq;$ |yWԕ_;=]KCtź/fm oz/5WY7K)hm6!XOXS1X~ )|GŧnbjY 2nP0VTʶ yiM]O F%* IrB#+H g|C3jNjNy.BMӊ=Ca[Jp9 I} g :-LCn94SdC4O)BL1â4.*]'KSC,iq`ٔ@pٴhl϶61 n쏱/tͺAvN(:ТeҕZJ ԌNY%™'-ç0%Ury-蘐DV}aTH EBJ 6]76>PSH~ MPi`DIƪȆN[Ly9fTksC0mj^MO5w >EQ>tž}`p@c#w (ݡs-_QgnJ8JeVY )DQSl|ěc 1DnRW)npͻ̇UIbK]\~^maletg8y z]Қ'q Dp9֔PM;lm_p'1 wpMHxݨ5bUsߛ1к]P0Nd/"F#@Mmw6ӽzuR|NoCmNY"8AX?#hPx6)9PDgrC)> stream xXMs6Wԡ:CęvL;v{Ir%V+.I4?/ ;m&9]}ɟ I0#'Mu&#5I Q aHs\/ޥLه(n1-޼-72kjW,*o7e52/.11+HnmI$giZYq^͋ume$5>HoʪlVsp9,VnUWq 8R]S5˗76 |M$ʙs*`">lΡl;FWTo).v. eE3$51Z-n9"%2awٯG$/c6Ikl.fHрcgq7Q(0 _3J!G~~¯VUm!JL=iQNOJ $!z]*(B!/DSW^CӀ( U9yڕ¢B*K?;)a\ιoۦlʦ FK?r Cͪ+S-ʠF־/Zuq2!rM㼴\R]Zu¼hO fRlȬ&< 3G}e!ܱ1v)>҅b>a;i!{iQKT觉 Q9"uO3h>M^"*( 9UqAOɨ/(6nH`@zhfS1`4<H e~/F1-4hz v,s$t!? y_g4,;sHΏAS=1| ucX=2s#Ms;S}폲c}yT*3?Wm١¿S8y8|= GAWz4 uN4 ;8RMX# L:31a^Lz4=`zg LTAO#cw1&G6A>~ q7ż4*= PWg5s" Z\sY> stream xX[OF~/-Tj/I&%'حZcf9|M?`!*v`C< : :>ylŌPG1<. Ӫn'?$l)R}Idwbn&^{ gSFFviK9%YgԘ*?ƈ΂2]ec:Eͫ|$HWGGҦ[z, .Uh/fi)Pv8c^s^&)"viӧ_ ҧlL!*e\í/M`*!h}ΕM^|\yҗMB.lfo0Y%4.]}j\OwmAFJcb [AV9B  ]S$UUdh?`3[ed0u5ㆰMRPmrP-ك! Y" 4<RC^^f0tKci=uuqJanKXeKu+&Qmec ƿrzc5XON7S$j7)9Y:ߤ٢Qb0\'EF4dvj2)67Qk7 jtYb=P*0L:Xp(TNՓLt ~oG;)ml?s = 3f.wMW#^#`#7z L#VɃs6N37-!oq : 97]&7;k3L_VIfd xװ\v3Ёd9ΡDү#$)vtdkݐZMŠPDKJ ɾreW*b+k4NFtP6TOI6`L[Ҩ=Myx„14%:B+m-)K*?$0M6w.0#COV$+[9AJ8p#& ;_lZ*e{ɼ!dl5UfYw;As⠳w^NL`>b ^ yW9o  q*9x oX endstream endobj 1130 0 obj <> stream xYr)x6z|xf\r%N%Rr"[l`ؠGJJjp$ǖ\3Uj6zſxQ?v7**[r)X^dT$%fݏW˜R n]/޹2'e:lU$2|6WᖜU^վ M}5!XX"A]~}">^Dby7Sfq9b]%F~׶PCݭTXU=(}".:AuKjL*e.9Βw3H6/.u"mu"- "g s̑~Yݬ Vްo֚Fo,@LAEV ZHIĦ݅Zj5_I"ܓV0lIФ*LZ;/vR >c-o"E0O]ӭx(A )ۘI/ibBToH)F$tP7I-S8Ss$F.u9?u_2jee]d_IF f  SD%ꔋ(hy>EVHV͆ǥ1̹qf622ڸ!o,c8tkSiLB: dL (< BP#Eߙx~/'fJr)@P:ba?_v凇9nɲf8X,bKC1?\J"!N?Zo]?&}pΰ%N__DZE Blx܍3.;u*;7!>1ǦX X)Jܖ+*޵JJmK*ƞ: 1H_@? H%ĞJT=_rVlq)3'>1/> o>*?徒)͘J !NbP2[Aӛp#43xf".3DkX1r"b^b({8 t 娱UV#_ێS q)&iM" m+/Di1D!*UO}7W0FgF~|\V45g{ɟ Ul|P CLt>y)I2)X i)_ BI'Nnθl|TX $Aci695ʕ)0^k2,|L(po> B@i9a Zh 2iޞǭ)jom>dCKG(LX☜(uk(.den#yC?[';b" Ag/]K0g{xlDm1 ;+3bhW)eiM43ڨoMhf]_44dnaTtag?OvٌK71`-CZVh\<Ne{G>Œg >FsNw]ϡ ua\i[i#Ф g!`=TG1A%*Tpw`oA++ia^Gf^B ^A1(&AMTe1٤CLf4nQn+C?_X:p޽?@L6 0A|uDHusۦ|`nk ?t|߈A 0ʺXE9c VsiB-89ıy4iujw$*< REIʊ%K`kU3!g#; b郅o,F4Đ<# οWh"/|hK|`)i9 8@=W~sf*Q (ɇzkcuv`;o7ʠG`O3&Eois XV#0 /Rl~#d֗L~" / endstream endobj 1133 0 obj <> stream xZ[6~_ᧅ ,o%}Jd.EE4kSIN2=dj{D[PX]-yK-[\]/Y0A4͛muۻvBr%,~~\ín_ J+KQX^ Vä&rW] ZPmVׇvjYyWͦj78,Ƶ: ^-(ͺ[+]xI$ 뿾k}(HO l =/F&,Yԉ"\2NEvEKFukU:_ /1̭$)%h{z+&=Dre"&6XU8XE}]_ۂշ3~‰1(bA~{Xu}Tu'?0r^- brF$]tQ@DayWncQdŅ%3Ќ"F~ik4YhR>Y1))A!Qlj<^nW k˪0ըcWu]nGΈ6[S,j^7Gx.(K`>v, փBW58EkB$J)Hjb=XyMo <<*<JO^m]V:}1^\GCI9H AtpuAr#Br#Ai084.^aZ89RGPhQ u%}a%/I|AvH"JNQRmՇ}\S۹ٔ%t͕U\’'9 8 Xc~ ,v9pU[<ƥMƔ3:NJZAW #hU߂(inpk孄"g4T#D8z.Ja[X$7VB2 ; U R ZPv}p׮܆DIJ#́FfObX{}oTǤv.nI0 (x}ª)ÝkG!L ˫cDuNzv5vav3*b#vVtfX1m`Itsl6-ָMnI:ibFzbh}{wa0C|,^~M4g iM\_ 4yC9e?р1}Ї: \G-=<K0E3.&jM݂wwK э=F惄+yYX<{ e0R._~MD'NJ)n#gAA8CuDJϲ!'5hڃX8Yd:<xz+!i`XŎd![ÝẤ9TGօG۹f@r7ql- IJk23nX]ܰ~q&8FD.y&s$`+p n2%n7kI)?l!t~TEC}gwDh+Y~*A9տ|A ;& .v*x璛0z%Yдhs)Ok9YJpiOG]agu @6E]ihD]\E(+Y@we⋠ ;F'eWڶ90\ P lɼ 9;am ~C7{1u2`1X1B㙙;̧Tlxq>F\0hZgf3bc1(ur'K,*ZhgbvcATL f>`JW5`< _`p0!")HE.umQ}CIN?}w}d=e W= }>|*Zu.:?[վ?oڵY^a] aatPk51fڋ:P-`M ]3OiFZ>è9ċSmD0ǮqWQ¾Aׅ.$ `{iIGu֟ CcBItp3mP#LBF13{3V“ &!#JÃT)Ӧ*QWRCgD<izCI=|$$R#9 AW3MH dʤ-+-MNW%f Ӿ+pFW%K$uNU:]pHb_V> wc 6HtTicy|%q|X;8>~Q4b4> dBVb~#41>]I _M> stream xڥZm_a)R( G(nte'|`l<ΆY;n 'Ѭ4]OUa&/lOo7_&EZ~ I!ݿp,6w"*]ŷ6x-FkbGjx jYIJHr& Cs3UP#-ѾN4W4T6WՄ'g$M!>R)m;}¯` czuO˔ϸ{V2ѹ>s9vKk,* zĥ 81_7PE0aik1WY"8ĠLnϒTr.\D?*4vfdnl wǣv>pzWjUOOZSDqd_ԫJ\/X2nOr!-?݁Vh~KLđJTN]KjqVxU/ aJJ0l挻iٞp[eL}_?AGлmMq lYKN.V2`2U@T yQ]ʡY`'d{B1fňI-#9oB,ܷP6g 0(gV7>XXf8B8B[Vq>^ʆBʽh (UuC\]_&uhc,e5T__ӞFOwJE;OjNt|nb7P& -SNY.dqHh(TPyA4hƷ%OKD[M%*<319[ +|+$K@/T*z4טR c_jvn*!]Ҽm-H.h5AMQaF*Gx5c &lIe?ȃ 21Zj(Tj xbP^S58MT#}|͊5| " kѾ|DQ( pqngKblhvFf0dK9dg(m؏~MX,c t%(+Bj^ae7m `s[k]b/DXPLP(" c/x,yw\UWP|-@҆TeE~snWsX+vV,ӆV0 攬ᷴ`i tըcԞ{z"…KTBa#P$+4^L; `,SqC}hzC8 ؂NoW/WMx#/HCej8ԂM\iu=AG]2;Nf & krΣvm;%4*>u%BBha'sGTA2ŢuK+={lڐ?8΂'(oAb?b,Bg jtW&$FsmZP*H7Ͼ7'9S7^n֩~:q ЕM;dL&gW:ws&23ǵ ^<#.^W_h{6 DB*B4l϶TZ;ȀGb&}15٢!`&R1CO]3pW܊I;oST>eOܩꞻrAɔ3?;*zXP1ط}מ `-T`lF׹Azt=` ,-ksJ`jWTd,%kbP庘d(Q*(RYM‚1.aDz_˓~?CзIwrvD3 HML# 5Z 0RxW B<͵xU YVj8"8[<EzXuX@e9ͅiS_%}eV:ppFjW>${ jac {@ zH1J,Mk]*).i91,w ;$}HP\#oUb,K)Hck apb^8V̋*iy=kt:3BgcYVc},+`RL#kG2f)xާsv K">tI)L1"}z_bGݒ> ic%B;i>?<д9UvO΍ӘK '9HzY!b j3B;m>|?+=ڹ F4[=D?ܿ黷.Ƿ>В*MyO E9Tb;}((ǖ=af%#cL|=B@V/'q`]8к9U"s;2--ߓNXjؓD GEl npo> stream xڽYmoܸ_!@"HQoNq^b|u➳--p.E+9֎}g8:Z$Rp83gh#I'VwV[绅͙r/R?bđHu,v_fwg^n|2 #Wj?8Z" "{8ߜEC^D"Tqji3& JYvPAh77o@￟_ߝ/:{2?[^s.9(֞XDo $tf5mfWTTtSl諺cͫ2+Ӕy][SBWEVw~SV׈G_"wU{۬FyCZRyl,sY<衪?446l0'+4~U;f$˪*, g?[6Swg,vՉocv-Z^eۻt+t|tH8N}plkS)P)Ώd;qleI>M+>˥ ^4^$.61oYuO=v|sF!]u%RvSr;z;aLab ƴIcPEvL?$ pWQ 񭜽NV}@X bmT$ױΛhZOZ4&Sׅ0]}AHX>Kx Ē.:Sv׽N8?诇3 {?|;gJ#a9T9LEL%]C>"Q~¶”Hq "-RB 'J@$Z kAp~ܑNpQȆĭ 榭wsN]@Gq́=@; L 9)NS`A"4CEBΐ./MQ5!S # 9OKBz9}A5?pGx1)1|LJL Pɐ;?3'NRS* +~&4MP]pM&ŒRn gҗ1-4 ё{XϼԾ^!z.\%Ba4MȽޡ01͚h38k VLPnm \O)lϺ+C)A d;ʍ,s` qv\{>P]v]9_Se|xG t /.ÚǃnRo@>|I"b|Zaq~.#Z|,$@[_SF`Qy_M@WZ' ZhY9&ζ[ &6hS-E m1 SyBőb0_>)SE!gΈ/(سo]~E@?tBQ.ujW f=!*:<|X0 x7(E¾0`(aNl`|, s\L?|5aۋ ,FG,VK6޺2gݒ FQqD{AYСdL C𐠓:k3Qzvb{ЌԻ}i}Wyځ==ftd!z^xg g &V k 6M -q6,ֵ lߏqi ({iKdڝ  f~ 4ԃ&- qbS*(> {a[8_3٢izNR7Ξd9/7RF* yg̚.C-O׳#z$cD.(݆ۜ*xTh4>A$_:Z+Ìz5~k]Ǔ%nFG6kݓa;<{8G0lP5PPy7ߝw!* ԥ6Bdj [^\H KTOhW/υBMpP2AaɄOo[2Adurp~JU endstream endobj 1142 0 obj <> stream xYn}Wim>9l8XHy ") w9Lr,+_pqS04N>F4JFϗw,)ӜF"I.貺VgDk_/~%*{oáZo{/.aY\uc:̬69ɨ07]35E3~8N딊Mi_ۋbX\5QJG$MYjl{?pmEȣd}SYvCO '`|I-ʗmȗ5(=Z$ˠ`;JBJǚU v0J`#4xoPRt;Y}[^houEvP۬SjzX8Y%αU!o5oqF3#b*8 r:dPd{Sqx׻Y {6LM#h-k6t#BP-%uΎXP]/k3ODOgb63=%Y3Nr FK`9tyLN`scʳ0>·#&\'0pbfq?mwI 2@!Rp&ײzk_4UhRci]gcELhxZa sd9x.Ds(@EbVƿa.S/_tN yn lvH,4y\lJ|8C!0e aA)tz `L|>=ZA촡(e5Pz Lp$!II{ k׫*VNj"-"Zb8Ղ&Lxagwu2Ѐ "clv S ?[R"g>>SԖ~P͍zsY x:7nQP "eҖ\P%_9 r%a= Z0U,k3m0sŦFWWلŻĕh&?HE]'וd:UC T$ԩ1Cgb5`IPLebCt#) qlͩk!2B1a7|H0fX)A( H\',]T.bGޚ6c)Kl RC̹sJŽ0#Y9J,ڢBEM2G3ǃmQUOEc;K[ =۞&ixV{36J7ougX|b*1;@!MVʆac@ʜъ(~J0ynYm~CPبao=VHzUB5er{ʭ3tRjbu} VAg$_[Wu5aXPyzE|q,dWi%Ǹ9v<ۆmCl Ws9gǦ}*c@'+? ->t` v547>š98gxd޾\$SDgM쏖׃m!GSHOq9mUjf?XCnuhQnPC1*&zek[}"Ζ d {Nu8ʿ(W'TfP U0xz^Vr/hջ]bEBm5z  '7" 5VZ٢otԶlvy?aLHNm-NmDs]z(:m? endstream endobj 1145 0 obj <> stream xZݏ_Pq&C&@ Ek`NL(R]\."Ig; 8fg~; $n4ɦ8lx; ɒn74PN2nv?com96BD~2Emu#$+Zۧ_GQTQp<TwiF +ZDy {(ގ\dS Լl%~|waKI:$)(:sA&`$$,V04ԁUMt!.W1a2~\]P/*Ş+Dj1틦~,[4a/eF,}~2c.jj k$+O$ ݬ/:oCH$u` OMuٗyUyRnTSK|W)MWBbں i((Qϴ z:6j[>o=T7AǒY69#PBޅ N$*pno:$ŽQ*"S2:!n~ǭ@Z`K-7UX}x}3AiJ(EJۯNЗw="!P޷bnoBs>ᇤtdS`BDy Rm {[htm ``_eYXz@Hw<HRv Լ5 [:xiė'Kx/9vU/qI~r 3~z7f2ȺAUd;b;)OH"? ah6,-ӑ& w9R#lw %hOO(i Y,L{y]tb^qb>dS, ϙ ev7XVJ[VIzD&c(W|B2[r?<_)})1xtu;s N {9,)"$8GL>ZhG: T.E9G ċn8n\r@dJ1@_2r|ۤ.`I6mWؠdt*!)c>ࣃYA;Va1@(υ7>S f:L[ ;Qo pϊ-*osO3 `#? `N+w_*\0Mೡ3C宑]3 XqԻν:}t`aub&~ՅYU6Tڦ=:f)Ay؏ud(ʆz\v|hGGw~BνXŽνÀr{fN&58\4C^n6uNZXc!!V~/<}/֢36,wsl{[3pc⛪k|}KT2;&eB7e0MCy=10(WP ~{uFnz>Zjı21L$t%cm '3f@AKJ <ؖC=遤 \ +rO—RN^kAWM_vc_$S- lFBX s3E䒡89]d5l.3GW N-k) J{T)<5g;ӰyD/AۘFU'gE,Q뇘N І0\dW6Eq )o=bhl̼-gvx ϧx,a)_NK}u>x ڴCC &2y=Lv(y6oGA|=}9|& Y zbF`>(JBM'5l|@B4;!EUvIicl!ٙ bf_uIzW8;Pپ*EѭU$åx5ƛ/.vЊM 8Ol]er S-k0@#sB$Oܜw$ƴ8&/w+s(V- ?eaZ;W}S̑) Vفo'CK͔nQ9Sz*uyEPAq!f_cw+BLs;_GIDV߶ZЖ$ʾ+R+=qڏ(YfndW> stream xXmo6_!l&c+T0HP~P:jK$/60"Yr4}/&{x9 87E p8b``R& 9{5 !(ֳW7Rfv.ͦ*uofkg/YDd6FWX+AVuZ""u.mQggnpDXRVYnXV"v`UUiHbmWE>#IC+e76m\wkQyqcn !D")”8Hm}$\Ylg`dƆaV2iLDZѮjw0*1EmYFe5vX+{Ki z* AH$\ܗ,+gEcb,k}Ѯ~ 'nya=]U}Uctv qFvgm]mhtC)öy cǡ[}@)D/nyTD7FGǝb`b``"|.YivcO3c$v~6 wrjZo9zzmpq> Ӈ'1fXSP*-ܟf 'Oet7Clo2_g~'ڨ]_]ό.Md];Ίhm:ۻ;vhFN ,Nܾ4}xDz?dhhHXXRX3%I!|n5.~ysv ccA_ؠ2'ծ[kǵ*i7jYg)/}gno.μNZ6~bw?mEmlۍmesɨs-!ug r:fG`2g(wl**ʦQÀ..ZTX$HO bbF1HIJP,/4H _ &`^='W jpjħqQ.caz[dJ9pw8''NSɴlbe3g_1VG4y41QF<ǿƁs ~';3ſ_"4|3nwkKß/CN]iGJѐqdԈQ#?zD :2bIS(;ʇ% w:D PXP,X?I-I@`ѯB^s胠K$֑yfZK%J'#(m=˴gY/y?/ endstream endobj 1151 0 obj <> stream xڥYmoDί‹}^@y*$ھ6̾Ed;3;3uL[fuw$% g ST1/̿fX\ XŪ"NO *@Cee~֢J~U*03kS3!eV` YxV SnzmƱƔD -oX=\eMc_Fb ΐ`YA*DnsהDTx+]?M"26g޵J DmVn/"DEm7Num 휔DXazĜ|N Z_:{1T)L藌gO ErDvE:# L8]-JZ^"<,o^7+zC),eBOf h%p$'" 1*.->>^̒TpS}ҬSŮ)I;Up (}D+ƍOSvYDJ9d,8qu%F6 Ř.vT㯔j_ء.ٍ3rpl48Y+]/^$.E01-8#jSOwhI]=g= !!IJD|Ԭ1DBJDVˎ&2%UXoD(ۚq }?t@.@am@ :;Ҭ^bk7N&G.KO8QD>\oxSۜg9}* }?]20v8{[rЂC;(M"|GwGazj.QJSQE7 z'GLKe=\Og?'h(V H$Cg`wn~ۤ!%&[=CInA5ߖ$䤕AB2g$};O#Ȓl߁'Zq^>\(*_d#ݮݶM9}2$p`PXVS =Aq}KJ aפ,H1 ʹ:X.p%H5,y!./2*Ϛq;wg.m){V 3Iy#fXh];ޤ]ȡ NSak[CDtoZ *d2ϡH:ۃU3 mwmj"4tt1 `֌D ɓ V.1 6+f'm\5\sӥJTGKH R^M@SvE &B GߤF /TI?qƣdo;Plv"k~/ O3pËq)O*՟n[wV)?_vSbf RӻLt>կʄAj;b"&k Znh6Ղw TAĈ`rz)äкLiaG#9#>(B ETBço#iq} , e^9Ճُg@s9gL(g7?|i5$%+?v|i endstream endobj 1154 0 obj <> stream xXo6}U GC!0.աcXJCEJm*mHywGER(#FulH GEe)RLFӋ1Pl$yyao^foWuU{RWjoֺ,nZGt`%a"JBk_Z7 8aYer;zQm}ťvf'0F3s VyF˷w?_eowbS틻nB?{>Gw-"tAPQ硝7<"Ks=ſ?(&/玡B{S1eGPG$RB~w?M_9{e┳ H~*>2WUSwwn;~0rjh=03o򾣔T;X?:vL~Q?)3)GEųy`<aX0<`=r-5Bvl3][|'L@'`H]} +aHB2@> stream xYKoFWRC@m Ej=F@˔̖a?$MRKQHHpvfo^SD" H(r޼`C*":" e.,aj>K87DlYg׋#NLn=}u'l wWis-Mm͔ZC40&c4ZDI+ BGLsW2JenrDyc3޿faSj0#FJK'x2ûE)B\=F '*D",U..fĉIAA?$)B$O!!'RT|*Uq{  .j񏹏U\'QHxoXjd^׾ c+γG"E@F㑯|0Slk9`0S1 J @s@مz&H-F4-oRpՙ<"NwyzSdInf)RwI;PQ3Kw |H:>g]BO&r#՝+"|N%8x<`j!b{$iX 0'BT6Il,ҽ /]N`ؾH6\4: 8eT6Բ QjU89mpo3f^ ~o=0 j %D?aB8A(bZOyKǽ9_afa38Í Hۡ./WJuȴa8Gw=0A^fI`O b,m"@ɚp?R  }J`h"nW KGACʠUVcRG&' IiKM[ 5G7ė[Z6czx%A XwYzN)6ݬxz(ֆA0Ԯu8 9Bp&C珻:c/v)>xvPotmW!.&Nvv_ &m7-˓غ6wnWOuw lM$͐&XrGbUˆ*!V;=V{1;{_1NU^5H-YP̖rJcP +O ^a*?%}(.3r# |~[o|_Lota?V:;kLG> ùT݋@ĂtgdA6ee,-mTt|,co9L f@#w&shv!'GSs{9C"?6X) endstream endobj 1160 0 obj <> stream x[Yܸ~ϯGuҊ79yrA` ɓrfFV=|H:nd*ʫ_WdR~o Y?^W t_VL)oWv2ƒuzwU{tW)/kΎ1:DeUM s$)b[6}ʟ0h x* pjNIyRbSc 2d4]ٔm[7È5iѪt'xU֝_,*q 1p>jD$xF]E-3O0).M)Cd8z"Mw5yck=cz'l_?$rdR61+)m+wա TQsmvE&2yڗp0p]Al<Yk[?ؖrd[U{!%hٓޞv}vΐQjrQYj\LPuE{\MIqp!.{ld`3'$Q#ãpjc۠Q;7w90hl7k%dž2D_0EG8D7!]K⡾97,"3J3D{3(=Zzp4Trh:".IL]%8A sDHUd<?טdR ۔eӺOelJ%3ҖRD.PxT{< 9U3\kQ`~f?c0|(Nn2ZT A8cl%07?/S`'pl bb;,혚8 %đKz*}eW,ɷ_P LP=C9] D!} N1SNz~< f#X1 ki *(MSYD{*ie'PYuX݋JaZ1%֍^Emr\lgT[MٝCNmȢm BMm d J)Xum/@ jr!r:,;dˆ3j#X@S6ѭS)pt1HΧHG|%+f1:3e)͕z))^ )+Bl2A^Xy" m_a˨x>\t|Ԟ-r(ŸTZR%IAcɼgG9B!q!B2Iv'?0 k܎zdah"p/[}f1Hbq-).?h24MJab 4J$ Ro䲔Z[m~z {#״{UؐZ7d4\Z/Z4a?-r 2Pl2R;|*zQNBFh6ރJ|ٖ}\򍁜9yb`!8eVͶn<4}-!K͊ub;$%Sʧnm+ГŁ=*^>VSAsAvf;*ctҌ|/d"3v=l˰-=<'^/H ZŹ=B[jB$Z03m6>Ų7%Mud݇A-Дb|I~+LOeSEOsR_ʍcNAKho( @!I˽tx򆵓~V;FwSiE -oj ΅MUmBAD$E/P9 aT> stream xڵZKW)79[vs}HԎI5;ϧ J3SUCB ٗUϬl}{7{1系͌+7[4P?b)RjR-~Lq͌46~# |/iRy sgHЖ*=4gٲ^k%:[۵Rx5oO@#ufhPz^z1)rR_-| >7v+x/B $n-'e⇆VZJ0퀵 :{<ossh鰢Oz߬gӂUfNT2KGaΤ ٱ#BwwOv3'c޸>o.7EY .6N@&.[9_$-%i|LČ۶ fxW*znFzzi<9&bvR]sYl42DhiJ%bVdx`SOC\BKXVhp -F6n^h Kpup~%"GI7dC'D'9&^ S*Ŋ6W ÁcnꖁuI;׻]0d df[e4gPZ0ԝcA_撇0.:Ǹӹ6-:3큇v(}\ZD7noZnP:IlUh{FqZS`> xNaJ]rkr+Dok pU̷I\ܞf6)@/HOZ:.O69 jLJ15bʿ^e{,Q%ZC}, oߌaEyڃ)#$D؄=2!K1#zj3^!_N_Ag[|Dz9u伂mD;@]njd,w:>*t[eP Fó b {F[>8й>ų4"W$)o0qr!ˌ)yA@NIt;H=8enicb4,܂9NcG겭vxSd?JhJe-:3lNTT *0868Ȝfy-!SE+F\PiR)WR7b:*:jT͆4"Jl B>v7pT[Ĩ(3Zk dInݛwV,k~ۮmH!D!T\rhvSh4X 5˰☱bb!#d]R{^tsq cU w{_g QGRNx2S? 0kR$:ciM"mOJFŊq[BQ6'u4FbyaH1d C*hg&LYDM.Ί$ NhNp7R nQwrtOM׌ (E'}gtܣ>[Mp}%XvbOʁWPZJgjqLHǑ'%֌9StMRQ9K}\c>10a;I8L痱1&'M%S\**!Q+ZpWzچ1y(+wIUxޝ7xj*%AV_cgaLD,>: bڲqur s5dr2+BKszIKt1ߧYWEȋ}HI-}jᶂ-yRWD |b '~*5Ҥ)Y; ʵRwTߧ,Ǝy:R7!&qiv~7MRM "GuszGT+ …uu6࿎Vq="U5y'+Ėx%6(-|f'\ )_E`_$B$X6"NFp|(YQ*c-8̧.02ݬY LA~Uf e@i_P]קN!&ID#Qv/eTs eUm, ]hS 5ȑʎ/j*] oM|w[ {R,` ײ~f%[N;^ /OXOQ Z(z50{.U?(z j։LWη2_lNr ŧ[!$0^^L)8砨L?~ endstream endobj 1166 0 obj <> stream xZ[۶~[Nw}$i:I-a-&!);_sp\SZ鴳;Cܿs/+*Ꮿr=[}X+۽.Sw߯Z ^\oEIom]o+chC\t qeҘ&of<79'G/C1BUO֬H[20_3|Cl+ 'َÈ֏/hC>,Lpa U[ΤjMti毋Z#$XjC.uT\Uo:xR4y-#$bۙ%y6laP;K:[NPҍ>"Wðp~:+ݜuY~:F#9AvE5ځJV!t 22#i?ePW_ɻ(さ﯆w^J&OT41,+ "ep&zA^2x8|uhtiQO'k20M}A.=SBl01R(|9GFӈ]x갃c:b h}~F(gLNHHT3~ZMb9YnJ2_/\E9HQN.HU]!`4D|vXs@kfg,0/c:RO@f+Sp"`3XJ7x sf)ӱzWLx,qc>J\@67`l;mbyI-7*F+e,3)RD:[ɴ4Oh<}=G8J?+--c ˢ'9r_؁ArDMNkskÓh=ҕ6BOE5ċ x=G}Lro9 =Kya}D:Z|IނfwTOv'H5#Ɨam,X{Sn p}TFYϩ LÝv!U' ]j, |b Z<9fdS3yGȘGwVLVW#[}N:ՔtDER 4SE.݉SB}uY-UѨCVv$]].8D,(/| npi}ܚ-[gUU|vXFX@ BvS?/t|Z5ӽ6lʻi;O۸TPXv]BZYpo$_ǨK#1jI׆Jm&w^wY#o@yq E'`OlM)j<j"LJCȵj> stream xZ[sܶ~ؼQiW!MwzK鋬PvI]g{n,]ejc%A;߹ؼM&g?l߿|ЌYA77To('Л׻价PuW)<ɯR!D׻T_vn_q#$+Z2 7T+/WR&O -\uW)˓j[OmWOec=rWu_&zp?nos7Pð?Cݺx+wpJ#@4-ANc;};Fsv EI;5`í >:LDtRN q=gyWˁvUj3•&хt@P#HQu]at ׾~h}#"(1D}­/3\Gɨv}(#\(ȢjEVQ$`*QJDZ ƒcI!yJXѲz'q>)@GjtuP@|B1ck˔Az_uk*Oأ<9ߕ2X.  +x,iCT; j&,!pWmۇS!j/a#@L-l4&T'pxW޽3 u&V7A`Ȝm9Ĥg+7a1{`&2/f9k e&٬I adjxۚGEd(0҉L` Y51O p]3!B`=jHp>'ayʩ*%+c^K{Y,guL&@CN;yXpLS =p |FGU2L3f\.~v5'.ġΠz_ޙ$s aVtpcUoK9%cdإ" 9?+@= )Q5kC북K ѳĤ =F&ɴaRC@U7ٹvCs˜~vؼYw"o6I5`}k-Jx|f}߆PbF32T=["]7vFݾ \ٚe{5UF<Ul s,?dD "\\s,_|J_5Pgs:yzoAqπbU"!OH4PRb r)׹ =+ԋ;eYq3 x缻J",V.q阫lHFT?TPP|o|ki6Ax/= <_7 P L|y?\F_.p̻W~ \d'aҲ#/4d3фJ?4.j%$ʂjoLʕ*S6+* 7دEPɗgf_g 05w]U]ņWE[pd/1(TTåG@&7.]{)tcovG'pkt_/\I[S0ܧG{v{$UN9B-gp/ooΆKm_!&^׿{ġA_U!} 'm]Xws^BpRO6ɪxu߮dKl>wS>Fl|be,R`#;s3xS ><8T1Cכw0BS<i(&rJ$O#Ǜ5KZ(8kiK[3@5767"j z{s8]mwu: cTāŷs'VLXr}}E'H8n]8xzMeD#9|}m2{1ۜ NC@[=B9};<0y OqiyM&cbu[>#8]9y{2E> stream xڥZKWNjOCqUGFL$rLR;|h$5Fn8$ n~M`?N/7}64'&7tsP7/63R޶wﶜl+WԵZd?62ΧcE6Y?VEo-ffh*S=;Ij;_\YDs!yN;a8mﶂlx9=<뎩 IrԴ~)AvQ虰Յ3Fx>%LH%1zӝVVcJ(›M $*t픻׷EN$~AB$Uq%+Fh#b#Sa di,zd˓Axڄ\hxSQI?9!ޥ" bhOB%j*fHF?AP2pN[KE(YNRhTT:O+Hattn+y=9{XZRb$'Tz=і[@*_I4oc}KNZ1xc2!dv>s_^]>5p;(W;(&ŭ` 9WYTzRRD !۹Qa|cUN 5-.bJ]s [IE!~)/]0pC6web׻]*%*` ݇2YjѬzgoˬ.w6R{Q7(߬xJxJt 1qpjS0LѫЩ}bN=8P'C]!;/wowx|tRXs@O0.|cz9 ByQrƉ̍v},}jm ?rw)B pj𷪭N.KkbTҥL/N;_F[A~ k;ex L9}]s @G$ Jcr?χX!%$AAS)=30kӄV# &~3lS ڿ\2x"aYB 7-)!1lX@g *&':,I=j_XWmZ QβK[L/ Vofk5I8$QB ($O1PQ$*?Md&d{mfF)&-|uM_/.fUK#Cz7d |_(m$[FwxvB婅 AWpx> SX{J9,C< }\%l.ul7'PΗSvȋ9$Q,"; H뒼lXwXp̡ylc 2%P wqd&׻rN\ wd,NEkSoLpcM-Ϯр/w'?Sy@Ǭn3M]^d֛a|."ɚVGg2ɑ=5 +CJ*XBҡ i\ m"rTONZ=M, /mn5 ~Y"~>tcyq\, `{w[eԍ|R`v8uCr;`<=(vhW fukkL,-*%>X_~nD;+TI'tlhqH*I 6ܙ_'viP."[ca\)}a32чVSѕLhA/":KM$:B¬ߙ TML,\u_U:IoBoMjֻ@_7 WsQP5v{ ZSK\Mg?@TS<+s3jEÔK\4 oM25d*Wdb𸿥{lSx&RkV)ÔRpzLNZca|x16@' .ĒP'W↠ e:HD$jf8I, >P!M[FۊjI9u')bPn:1V<Ս6yL*CDq)U-X)$~i!X]*En? KH : I;ҷbຏ:?\ہҋu}LL1 TtE=Ckm=;$Ӆm3X]J)Qb=؆ke]4ΏyY}n:cdw͔PfeYW';\Oȅ;!';RL' VO6tumSf^c&-!2 @9i[ZJ\_gd(/pa8;R?;& ׶+P܊1ïcc>;:r~dÈkdekF;7] endstream endobj 1175 0 obj <> stream xڭZ[ܶ~È7]܇ i -ڤ}vU:#%7_s!5Zoj ER|Bm>l&r*7?ErsFjls[XjtIKiEXYJ[m3C"fR=>ڨS |(:Z8$ǒ;Vc{ceT鳳h-R7q(}_nT=:纫JGG?FFʒ'|]}K_y*DV&Z \JKdxOtC! OSd#>ݭMtϴC)4_px懶Ucol`wH`ym Uy*Eb@2cb5·ƣs{SW"qRەج{ϧӡJrvmSC6Dx<#砎7 8l {k%lЈzүhL5Ǻz“P]ֿEXz(7J-2O?$EXꚹzO~6SrGj76@4-XeA" ${)d=ϰm3*#Ҧpxa/Eo.>:q"_o_6ڦ!oXM\;.0@ i6IFC 7A= (gd.Y]OD +͡n$B'ׁu})D^HFcP dz.I"0BV0٩Smd6Fwz. ']_ Q_&v&+@"EV۹ (9Cpa AN|02a2c+674޷)9l S6 5l~/:LLsL2?9h*үʉ|ύiLS%7"{4xxy >0a+c# ҊJ,Ӵv!ʗ$Ëyc/ hw%EbU IƠD䵎*^% R" ʹME+ έ?W$Nk@۱ +ނ-"J I=}gZXcAJ{gGXqѥƅOQbDTK4+ҟz7Ds{μ0{̘81C/Ti&@,wQ%*] OԱN1!vB]Ŝԅdo0-ęUuԵnB̕D)LKDWxpJ+71g2+WܔYgVZc\Z٫тV=S| ^Wai~۹SH,ubV[Ƨ;TbeM Q /eJgP؁ܞ@P&+:M!Q ww@J gG0v*:T3f`Asea t-vML4}IURl*"XT$Otbe\2M=3!$ͨ"&QgYK:]o=RJՋ i2pT%4 w7 ̄J񺊿.[ߑ`-TE " ! pN5}L2e!gqqh['H=XYmDe DV 2>R*,Oj,"5{!>Zl^1>ްHeM6QB(PM/_]$&q2 a{|}1b^GI E+5EeOK *RdpN'j:' fN"}s56BDb3O&dCK2*PayBWw^\؀t`JDgNMR`DnpRU6"(0l\&X,LΥbhbl46Ԅ^2c.X W(oֽϜNmlOc\%nlPk"Q9PP4j;=YϮ8/%/yeOz;Gws ]H_"?rtM|hα zRI T-|~bT*WDjQGY %q \̴#RPRXi_~gfЃ endstream endobj 1178 0 obj <> stream xZKW(7*eRvb'JmUGfXDvwӍ Rw.WN4u_VlU?2a+n슉vnc&]+.xa?4ѭqrv^(R("vf y 6+ֹcVv}y"&ǽ9vnO?(Sri8OޗLZ9aN{T(M0ưx>`~MFPKW74Ү5 i\֨}hHbqV۩vJT#MP%8@4]}{φۥ<`j.E[Ը [J4(6æoOK6 3w P@0Ԏ@ZY&eQ@\\آRBx`Mb7@hzD3PVQdSjMn@Tvf²|G ߲so]i`Yʀ+cҽ9`g_]I.rg---u4 bf,SU"雙1lbIʂG nqS,ld fu*m0x;ťz2né(2vxnmQj0c祈 #J.l%]pԜ=:JࠋJp\mWΥLl ?t*^L#,\䕚6qv9kQU ]8<F0 UThtK: Ku5P7IE'DׯJE;DH9|s1@: ŠwrDvSz9yTA,xP_ t)T%^@j1A5ؘ,ϘU#Հ_[qvBn]2 %9 PⲎU_?!Tnܞ%Di[`qiv|$eS=!mҰ[E>Hl=0wu0gaiQjUE@0ʴ fZ.RKYw);s;?I!@ )'UHQ`OyHNS/bc>$IE┅Tf/>- R T^E>9lL^FT~0XL87& &fʞA ܛh_-r!gpf%r'Bb@TT.tǧ ]%͗yX\4/r^VG` QրXsӲX*! k킕|a,j Poo+H+IXPĆFQZÕĻ$ «񸥱;UQV$rer%x]q,[6”ڧ6[*sn_ s<H|/B5h\YLm~d LHlJsw~ |$4[0 SRi,`S0f3縅)z!ӢKŢP8tL>ߜ8R`.jςYor%> stream xZ[o6~_ᧁJT}h;]lQ %Ƀb3Z[Hv)Pi&mg]L0e\sefgd~l}{=*\Ìarvɾ{7[sXV^sy<EZlgTh=LVۯM eM8r^!I'vɳoVCwu5+|,'%ldㆧiI3G]TV-cxpAMXnaO?KD76< d$"nAڣMўYpGrǝ8g׹Y.l󳗬i3Gqim6f& c!*S.ZR9+fV v7oz<RLSWqmX-٤vt MY,<ҏ)pA"Z =@tPZw^VPЁ.(>ɧb0ޯb$1J~;ez(N*Q!d%SM8;iNɳFC?^vjpnqji[X ŮT%JxĩP o3nkT{\ ZoŁ9 o~(8mߴQWb|z"$"RP1_)hQ̒u%PPş gO}s!y0}7/,E V.^Fש*C gpEOr%FgO(&L۩Gїƪ?BU3yzVtNI1gEtHQ$#D]俫a7c4MkZOc P&J#&v>3P ZEd VU6AdMӤAnDx$CuRZ7]fvs>[rr9^6C̈]e*^$yH}k.ɣ8ZN`󓺕:W{sNiNMs}2Ozښ6a2Hao7]7 @O l e2 徫9!',xߝ>Ź[^=/Wغ#o~l h Q&J%zSuF&41}֣qmZSUI;p*Wv )FNmLP]ύ}i+h_͒K~5[Gq=/ZO endstream endobj 1184 0 obj <> stream x[KWrj/tN_ɻ)YRɯO7A 0M%] nxnFb}Xvwb+T _-]pe_ny!`HGnVRe{?jn|ooYܪJ5r wn`~?,> Yic?ܹeN(UR.XUq>:Ōf#v_w@an8ʹE?h5M4d+66KMlshn>hx@LaY1R߀`޵{8.V\{i;N{=2' «ͫ3w.PHC XekS3ciO9(.:ťc7ְ0KbZ5+< >W#)z_|1H$|wC7@O1SomRa" sL<(dT5z:TH>O^'_PČ:eȌQ/2`=2HE27Fƚh%Tq|29l(Ly`6dj9lX1:ADntpql.{8rô ˷p?@) RB)OD Kf.Af&/ۡ?7/0 U x'^QAjH{ORwV%+Șd6 H8;D $TrKr0SWLvÉv>)0Di>O,( u|kޝwC]C;נww{طM0m ɪ7Wl&@LI 2ȵ5i NY҂+^/3 3"8-lN¹4Aoc8뛬mJqH矤ڕg𨞇InzC7lTJago-%&85.=Sg-&UdL5DiKm4'?\1k<8$y1Uti! }pҺ DE4aDZ;1= (&~n~@ hVpP#GKr(积 Hdɥ\úJi|DP[>eԪn&Ҳe}\wJVhR0溬C:V|Db |eO -=:DsIer5Hcia*6n)fav:W%WMJyU(%0trCC$iڡ C҄@LJ8RD (!6h4(n*, tS4IR$,)IM%%>CU:$aW;lY9M/ v&咅 J(LGIȇ#PY Е&jT*%Tf2R,4^`KNֹfUȩPIЀp$`pn\GRW}U~ ?.ޜ׾(ceJf)C<%31Ox4Iɬ$!)92PxшLȰ$ {;p<zĺ/# \pco:.Mpm 4ݤn}o 7_{;`lq@{lD0V1 + 3:-zHn C^/z%xHk6H!!՜})@K)Q'D=oKP֠em5K$)H!X?]=9^]LMԤҦў *imD t ]z"ժWK\k^Pդ5vi\6kε$f F|nsLY ȗ>63}&AUH 0_,5 Nap65'vfM$ =nMG IJ\ U[pr^D2|K ׅ 6nR]bU DҲ΢xpSGf"YHvBl+kfVzFu~1/4COᔷօ^e;Arx},4/tK8Ph%^0?\)fcEe'ⲱf21b."w ԠVN pr;/˙jgwov~ a|JM]43 >oȤ~(~NUL|5j89V7682.[j_;`|30H|7zU@釢Ş*@g:ݸvޞ45 g1m_qqint]7) .l|$O}jQ*UA`Sݑ7CFTC7'[μF5nRG+6gnDUB^ DgW<\ qȭ٦ZQ%=uwW >kfi -:7j;-F\a@9k3X|ըg*Cr31b!q}j >G#r!jqLې:\{pJ7΁[nHX3墬N2V]8Hhkk8D..iBI@pÒ^`K(̴{zisoQtgu߯`^P9Qu(-yP5WulKBx)aD7;1pψ, qxoo?_,b endstream endobj 1187 0 obj <> stream xZKsWV']SN%"G"6$@㱲tO@Ԯ*e gc}x?'p}^DY%Ul??cgZJoWkTZg?Gkf̹]k+7 4ooܺDʒD,I{n_8۩0(D_U+`,L\1=rWV۲z2R%fʨGilLbrte]`6jZjrfS~j'mhb<!"a)&Mʄ!pVCl { 8Ãv/HѶfSnGOmABYΤU)Ec@Z_mhW{t}2y=FD ,8ciƣ(&@|>>F9OqT3-= ZUws!NO/A9u,w37abU ʘȕ_ R”}Cܟ%фpЛQ`E/*$bKCca``&o9&7VglΨS*eD ˤ&j%5H/7eGS{"^`vkor33[g%N6UkQ(LUbt/=u5}VlbM}8{ʃZZ*M!E^RÆt@7 whlp$b*JL }iyˆPj & $K4 ʃ޾ QGP71qǘ tlml۰sGEq>l5ucHˮ%'/1vFڸd=*8*q)T AŇXP yzS6 ǣ9RI:/1*c_?)[IMP`Atv:p.f*{&,g`Җ`WvˆR`88]ɲo_rKo]mi"sh RYԔ ٤i: p}L+fS6\׏n2AQLiqp󱈪M]=4,RC%Ys|Z=qDblcm5"f&zHSw>Gq'xRR}bFν )_[K~o2Y8﫯|׌v[ʠ!?AU x!>.s{"ąW.ET}Ioc~I-}9Aj'F@mJ>_)_Oܘek-/E23/hcH">R0ܑ+%;kbdTJ%~OS7p }i =|x@4]TŤ!액'@!Ey-a~0ptX{\ gY6 dLnFd"ݸm\&{ Ôs+(±17z1 @!|~yCfA&3Ow(Nf)%ek8SY=4UJ Eop7?]m6m泧'sr|748TO9 wVc]=Tژ3Shb{l+l҄d uĄ$]-q\6=㼰J|Zƭ!1JxKNR0@? CG:(3Sc +ߟ'1'C ޞ4z/Ha "y9MgKC4}\&S|UvEvEo3{IC^E%ǞWMOZa i3Fg$F87\-u"f)hEwqyc*&c/R- ,cQ7mZ%$b(-1B:/ݬq^W8Ւ?aSsc&߄e* ؍'i"@ч8}KoetDoê~7RO]4&& "zvkk {gP)YʩNY|}o,E$OYH.I.d.o d>J gƃVg1 9ٌʼnDIIoLv:̶*Oop㕏/]Q endstream endobj 1190 0 obj <> stream xYێ}W^ݻAǻxI<}Z#&%)gOU_(RnHġZ]u9uz.rGb}XfK91ټ˸a7^0HQp5}s?Ëphj|;7tYv%Ea9Fѫ(e% T8YnVǾjo (/V so?uRs;~!ǿHޗqW}D{oR; aJ$|g?LUMt%X mSgԠRg5V"7D= _LCe7B5$e ɣgHp;Iنzc]{>8a+:}oǸEOHGE(|lB] R^^Y e)1Ɛ O᱒:5QZxjVG Fg݀ 0pGۦQƔ @De8bB%@8hwuaw*lKhq%6*ZJm@+R] `IJGXM^``C(.}(ͮ9S=v^TD/;])C#55uk6'j8U4$MGÔݹ/+2~,'HnI*_QBh_3a:cX#ڤ=VC>-?pdy1 @5Gf\.2$ˠ'%ɵqv=TH`qlCVāCOi#bȪT/4<nҭ]2AH3i7Ty\ uE'1`.D+WcfSBq7C ;UŽ+uñU_®aE{p3O'8; I 0:OkZrr cH53oXBH7q.4k~<_Kʻ0l $u'UVu3-81=T'Él&Lo䤒]NaP'} # pnm5-gYӳ*iOv.ٳ$~u.3gMHMyA ӠBj9g~WN͟ ua`J2SjCjB]kbUf/EFt!՛^nxf]Ajs1s4 ͫqoq3wwΐ7և83-Yh2e~eo:w+ 8#ʥN p>¦f >fJ+7yukfVg2^Qj0YbD+nI^e/$|R.f9Tip0mMUeyϗ:,b _ zh@fxgO(gO8%\хzDW ak7.6}1|mjK e(G`ͩMP+af13cA1#;u⯿7:w endstream endobj 1193 0 obj <> stream xڽZMWS 'DZXm.aĚwU/ L.$0yucg,tg7`32/nFf!n]=~g|!Re?˾LPIW07>Kn~ũr'^Q Q 3}]Zdn+ g AnX!#aU1bWR ErE&5Yne,v~u;_0>}~u*EN3¸ǹE"\KH@܂{\2L?7_R>wR?ߵm%=uT#*H-$j)r#~?lk j@yɳjs59 3JS.WU>j4DrwuJB"8I R~֏Ygr>2Yi[Oe2X8T>zERj8>/n5忻,I,W{[&2"8.i!$G7ݹrs̹`ףs($_u=WUj7фcr.Yaρl:.w& "=~CP\01tք4Vw}cI 6M27`B/F]B@;ISH AtvCΓO?Ke36;EY_7_NLo79iȥ_#i @QK& " 1c>ז8R'8H"N~lr EQqQju%?u%}KAy6f@m% uK1d?̔cMn"Ӳڹ4<[ڿ5xjuC)’(Ycڟ@),cf̱*P# tUӷLm$vƈ0TDUWk{ƏWԵ[7N?f#vź(IJg "";0t[t Äug-m;ߴ}2T{lD/7GQ,x` !zWM%.+qX7j *ݺZO~D0)5` Uef\p ٝaUq&@t3YSRoL8ۤxI$q8G@j߽{ŏ,A$QkPP-? y==kk4$Xљ@DqC98'DRxxQӝ*xu;P LނL@od_%"qdB2(AhcI$(@~ 1 uzi@֩@RM\bI /;Z|tZ[6hkdCԗ _;k٢veLv56A+y-c$E7~X&#C E'VXӎ|0UM!%GoU ^q`y2p" jEV-´S6;"a RPtSïYcGRĄ]Z'Z! jQ3u!u3@84XScs { l3N` ) G׻zw-2?enŎÅ+> */7VFᒘܔE )'`3V)y&/1Y鉾S1'-0:N }. 8"4pj +RDʾ x_9j ;'´} Rlk, 7&NUP" v80_@ ([>4tW2eIXVH8-Su5>4 Ua%}fcq9*M\КC/Cďӽ`9yq QRy)DdsۥCۄ$:lաFZՓ-ZQ#1-]_[ѤtoB y }{> stream xZێ}W);yrvׁ7'Ƀ1+Z=~|FRӜ  UNg늮2GW9jsXj5[ьL͊+ʉj!Z?]u8#ym7s?6x,uWh)+P5k'5e4'ӫThRPasc|-gf1|Ea׮%Ml9%<4XTmM;L񸯫 8U4vGLњ肏o>¢Q$ɩpsj6C嚩Z6 B&bb 6uuAW)(m=Ugk;k̼R"Qnzv*°,ŢE9tS=oΣnElđIЎ r*ѿ,΀,P;"Բi Ќ{" sգq͔1ғL@`L۪zc'{(?Zx`5zVG̫$ !ve?8%'.@0דds;M/;X4$`mԌꬵv-jM MC!)('dnx1Q.7ڱnJ(L رݜ)@=k QLh܌- K5ԮxTb&ho/9OcwUaTiSn:O3xuHťXv\/@*rѮ CB_) 12`S)ҞcI6tUR" x/ ]9qăg^z^ C~: zAqb^ :bo|zP#kWuCUW(1 2\}dgrr0"[>|=TvXH?G(cgA2͑/\I` fD"޿L"JxxߦdϓUb`_#ΘcaAvT nCGT ͳIv^{%U%IsXB T]nx_q,SO =ϙʆD|bS~B L`L?`^v(], p g{ ! j]+ܶ_F>ENPN; V&̅.3mHLnŸNȳ?J _;Vn%24Jѽ/mXZ*??ҷo-P 9f/sek)ʠK 5{+TUKZN bJ^|+|oOկ` iP=ne=wj\=Bǻ= }u; W;t8cX\ch[bjH endstream endobj 1199 0 obj <> stream xYݏ_7{Ks`ZVjK$'E?$K:j[4M oeEVꛏtE0pFVw+Wn|Oi)c,Q)<~ l]o~Xq"ddwX&7AR!M[3& lxݻ2kW)Q6sotzR)FMLDR%E=;KM2/+* a1̃ő$V0̭KaNVh~@ޖ ؛ Yrj5(k+G?7#`o71WH`22_0ـlK<ԇA|0~<} x%Ix÷γ`mr;Y"4[qR?MXS!4NkA`!FP)ªv_;$$mV5;{$|LOLfmt)?eau'DϮiQ$z>~aW[HqpuΧ8ɜܘSap}%_T [hh@*̏a*oL _vFG!*GKDd}cPA;AtN.[Y_ވi,Nj4i@+#C[1\.}u4l}Ia[&'>lSRl$5INIG '.US&&VWvu\loBP\%TЃ/p4jS{CPk5MO[^vMQLz7UUسh*[>.I!7CᤈM'P 6s"j+t BUN$8)4JσՋ{̫0N/aN1d؁qH7 qf@6Af*jG9xL!$%oe|M6K")hK5wvՓ-ebm(, #K\u 7 XNuEUk_j-WK oJP)KxU0>yݔÞ/X QM,Gv+scQbסDQ5_atE;҅7鼤O@3$[gj= up'5!; x k1)>@zِroA2FɁ QMЏ;=8Bc|#42p 8nyTȠ <0C!DK}M>] gwQ2uۯg*D֍~.q2$DBE+]4950;SSə"(Xs͸(ի2Gv)¹\f\ 1\m6ϜBT`גOa Q&}~Q_'{IvgU@8faIgL.h`ޥR3|NΒOyۗK{d>Ίl4+}dfv*vLCdXz9) +z]꧿eB endstream endobj 1202 0 obj <> stream xZ[o~Pߨ6܇^a-(, eDu3W^<#9A"FHÙ3riW+IXm?߮pʢī dju}Rn" ))VzRپ:ܯym|^q<SꁳZi>]l=\(W|H&+!EDfPΈDU{6?D$8M=h}L & ETYi#<h"Bn%K F8|PqtB!{dD?[ }YbDW$Y}vi.(+Ip LKl 7A>Xr)l@kbb:s)FXLb/ qHx@Unȵy{gBJ!)fmڍ=b OΕRMG9jǼ !J/dY-)EEpTf?ݮ>Ж J@rdC+^ٯޭ~l TmʊiOuW mu]r*ٛ~ /(W1n4\ݺna(TH!DS?ڴ%1N]m6E]qȾ=>\ :P_ww.k@L+%So 4d3D\ P!W!AoI4عeL9u4>IEm#ż]܀SD @݅[`8MY lL.Q{ib39n: ,Э)΀T2r%.us@3IK]콊H8ѕ!ױ%%5yتgcg9ҳ.̥"KIF(]Y9C&csDLs(_L"lWOWDx{e:L'V'X~o}l{R^s osP 9K/lQ`E(nTE5X;mХdH qB z0wW9Fq@) [ L0k%@REQ$NfhqpLnHU(H.lϽ i0Oz8CsO֩ ( ɪ2zэ^hўIJ9p٬Ta%hF Uu`sr@D%oƼa4Q#CJC| ,vQqq*!K˱ _ű"y٨MV.4n*NgJD9b]"OB8 9d28Ep S܏[0*w3zxނF"F{X??9}DԔ~olR"acpc0!/%^Ĺd_wU9hU&[SIH:./zKAq\0lGMTeujFP^]H iFL dTV( 4K9#FFxb<}lz?sIJwy?\pvL YbA|ՀmrA>u YR$~ZNKu(<"OeOR]Ps9̙s=M fcNvV^+4:(jJcD:<=z-dG(h!)]Ag^;[^%!0 y*qfUT U@1O3;;EgG.$ x 8%"Gդ;;H0b)atN$&NGD%n0(~+ \djӵ1̓oXfGf^92uV(aM#۫?z`a-Den8Vu?3"fƇ,HtŞ02k[B{. \Hp 7a hW6 쩩YĪ]j XĘjPmwROLjq0ӣZ{7|MgpǺLd_S>ݚ>kz?_ۮTl! Og;آk8 꾶}Ծ\#'MChWG;ӣ9s9Q>kfpc?e{SKpa{}%';jMtnmPz9o;e"]d?pEOQߺ~o> OAcS r&)8)I-Z.Mݾf#Y4V$K؇ _2Fӏ>럭5iF|{>>N$z>![nDO2!|,4{x*^ QE#k" DS|6t}}clP2rчP#8lÉ~;_HY_F zE 9SȠu`N$Mu& 7-:(QcdBHEVrඏyS1=s`KOiJd=Ea  t黱Hүa1 mM1H}]ۀBE/4Dutn8<(K.'Le ¯y3uI)'"Nv6}a&'lKjbLf %3oacu%Nh29`CWyCzkܮ53`/.ooj#&Q0g;7ξ8~$6GLoF b7?ݮ~CA endstream endobj 1205 0 obj <> stream xڭZKWI4"v쪼*>`DjĄ"$_n4@3vk htuswvliYWlxرrDVrX|4R!D?>R_O*4yzo;TVwDmo*TН*+o^_NEy2v'0حd2Ꙏ8/'5]xG7?\.e:bMY]̟,"XƵrs>rj b V<+M> 6Tr̓뫡.'T8ސȘN U$+NMC i?g?[$Á~)^"y5od1=V<ίK;ӡoR3>+Tب_*iz5=׉N&u:.y tN?J^kD ,JA?dR+r21'<^pj{Y9lQ7sfqtgJtS| 2k@+~clb/f?wYV%Nܵ{.={,;JvM#L}~c{2+oQhf^[fX\)cNj"i~Ιj?pI;]b3bX%""+['S?̴t]S(~:YD -MY4#mEJpݾAB ̍MzFI+,|%tbu `3SӰE5QM)p4\(PO'n ھp}@; DIHHH0L8`6]h\G_U1 K8ƖX"Ƭ*ݛSi(PmB]ksK/% ζ eBМ YJ{ra֑lmZ^OOEY526٠;EyB9pP)ޕܾ9_CTt "Ofo> ,I2r{5Ž!_bW\60w9maɧ'06.0s ;!v< ˟tVw-uTNq-wT.۞T֌?i~1<=$hR*@1p!zeUy{)zhr"'!j`j!@,Nݧ^`;AFQעŸh+.nMeKspwRy~\m,UT)jꋕ&s@t{꞉/@˦D`{0|ӒZc:r&( DmRWyp쎋p]wFS pVJJNQ?i qOܦNV z:r=ұ1 DZ:f!@"M}K.ȢKԪTFט5m+T>akz%6_hhNjL7@0wq%I"T/.| ^DrjErm~k֙, j8**&Ţ7.)PC.7xU`&bJǠFIMW^I9xH[ǥC!uVuVv mibKXɗ[[[aUrS͵aj2U<7}3ՈLi7`΁_ɷM֌jгs0 ޙ6ffo:y֋0^sMg%> stream xڭZK۸W*,,E$c+LNh1+ );>(Rک]5M_7Jr'WN|9~{(Rw+W~JJ8W."- ,;eNa|AL3B°k] /5 ~7{3ULBYy.ߧo:-Bz;Ðk#]PmevC3Yv⼯Sȼ:/{02IprP{&P-yI<J ]B _iIb+B.l.=?_,tpsir-~~AYMlY6VZ|=]ӹZ.)؅~%%Ei4TV_b\mj^/EadmU rQVrwb(! gƺ #3|_#BmD!L2u4]ٱ:op}MkI=[}Ũ~a+}8 Ltfp4AһkalZyq꺧 h|tL Х M:*H;+Eu}7 _ c}Tᔂ5q~$=pN%Wo8g hS%|GqP}~z*\$ w9Mn*4)C\As<(/opPϰpJa״樏3W|.U}Vd-FML >.ZQ`w3J}a> lu04 ձ&rhQ. gPe\ 3%tvg̰N5 >*X#ZI%Dz]Lb8mp@8hp=R}j쌻Zzz~SmG|;FZ,Ɓum# ËR/, 毰o5/fnAEY|}`unNW78I(gS@]VNfCD-OCЭPi/Fc|(Tr)~ Ș-d+>néF>h:m%dFp 5Ps=S8 |6tcIgX&r:V sZ%_TP%S_/q!sQDr2f.Fg~ l#)pF:">r,/Ӑzy] N>Ӷ8.=zb,miK|z~3a]AiCc'gH~t^5h9g<)]{xal^?%ck,{ԣ?YWC&Eۉ%\G[pR+EQDab H4 չv/Wը^-RH@5kK㓂N W˜ȇ`9awS>ᕇFVƳ"oJN@X/E^  _ ?V* H!5 K$"St]7ɬ }, Ll@+@ۥ-q{$q4Q!B CC9c!PТX2/9 u;~B͍Wa`\}H})7}9p cP|ž4þ/tUxbQ?e"hyPuP=3Zp}O+CajS!ʈlmRʺÐ}WbuA2KB eF1OZy-aH[n\$B [;q#*żg/cJX R6OJ~0[WaMA1XXR37n M0w`ch9] ! Z~†36A~&\! <*+Gt GćiHyBQXaȕ﩯HDCgZ%^i(@7@M $(}9tZU+e#( !T+U @Y%qPh0ۮartc(Nz 4Oh' F. xXG^<0^mx ˱n&J鿠Ѣ WjRziroS5^trg"–SOKlklS|?:hѮ w8,cnAF=ƏfЇobo}W#hTSNPkkWq0/r4@xDd1s_W0%)߬7]{G.ngoOlh\ pr%5N>=<=$H ^D+i…2&cդas3PAss?l{૑a#Xm R;<<@:X,IE'x"9Mg]YH"gS䝡C ?QϧwLk[@&ę54+(u ?XK K8.¬*j0a'b׈}˵ɷmjw <3NR8Yrs@A(.F]ARA }*͛Oh0=GyB!cD hs`c:aL$}h]倯 tL%|0 q}ǠJjv[27Qh\+!XЦ>V*=CA{,bZ$] TT+hv/4) \ǿuH?űnbnmx.Yk^J7_- ;KnPXs?-h/>Hc 7Kv˜p5ZʍBqEw k6]ӧ Jk+9J]#T07YL#nƴxkθp!?z+x endstream endobj 1211 0 obj <> stream xڕZKܶW̑iE)q)b;!;2#>t>f1Һ htuc?v(9O,t]Gsp !]*L~KU?rLe(`n|GhzS癄Tb=4+C?`L3J~:iQEtyC Vd ^ehX'Zz/ymOfnM}LEȘ"Q8SsLO0N1+O_Ml2UfAml.+?`?`\EVTҏ/Sqɒ%.e{3iGӣ:p賵f;8øf:LʳqC:I1Ž/$0YIL#tTbo[ĊT46PcMe퍃I%v ;vEbϗtLaFT% y Kc ܷ5ˤtii*EٴtQ7J荥__*R ^x@ɾB9'?O|k70ȸ*^ci=z4v8;_ "xW״Q_l)g,LYQ%:OԱ|- 9F /OMm]Oz^5𥮱6&?׳{6}}m}%uwj NWNEXLw~g5 :sxpn*ю,m+\QYnl^B@K) Uy<"Mg-䞴Acn P1a)ڜ|,%i]%m @uQm!bW x$i@qf~d nVa!5 u]tմHJ;ByQ `!؋"D\9g7㍘/8藀 3gOK譽7n*̠BX`Xn:fhurPOn|"(O{t ^yÊ._8~7`])A@`f<@xV'bg'ΙasYKJ8/^BB@I'hk .AO 3*{>{jǘ ثȃo}G\ڠAsM }FTGI/w &آ%g=xH,|LHt$=&obR2rQ1>O׶^E tw :E`PuԎ8o mebF,S?@镹 x5XU y 6aha Rn9B|j^P0li>¤r-NU$fqJeνBجPqF'az` 9@Qٚ؉ꖢ! - jgTOζ 3C1/ 8Prh=Mq 6kԈ\hazZ>N_0D-k^@.M"o% H(^Ӄ3~! )FrK2H6!it+L 9*ɷ?/_o?1ɴ̄ l?Dȸߟ wD }~-HҚ qZNeAGbVFb\lW :b,J`Y6#Pbp~^H  :/x+6]<x<1KÍ3Sԃ!r¸ _ɬ[ wևUFv\R"c*"ځ>c-F9 ֆѷ\Nl z$Y8}Tpқ820%ay  )1>,g0KvU"I_lu  ӱZ |{HoIg0ɦW뜝u8X3& zKRq .}bWTppc+B ,nrZ\)FQ_)ՖK@'o0cց{\-o..L{2eIo_p?]TKh <<3P%,t!—[[bӈT+w)wvu<[ҹ 9"*CPNa'L u`uU ݂RN=nHGzHA/f \:V)]W*oLbN}pyة  vdMՏhU/> ꣐KQ>Z:+AV / DuA:”kbbAWRU!%Ec%BC;*amSX'q>낖4h;+Bg{^uMWe-}fP/i)Z 2~BgҚ|дlHA6{!~DtOpU!8^\; U$XZ*ڟ)hqȁ |+Yl<(+Tp!a}7!Rޠ!UAipbz:ŋUY\n'ϭZ >r~m3x'P e\hk:\ުq6 #7pUzu&~`-zzc./-D0wαJ =$h-*qX dq|Iҋ+C7x9 <2~.t㒘!JnCA3p)Y {ѵtbڭ+iH|S?I/Uϴ`;ݺazpB/cI]Ո"^W"J~/sm`_B *Wܡ% } l30xG %k0^댱/3V/ ^+xwFb>&'#©BףE&Ӹ_}df'琨ĖgZ\w S endstream endobj 615 0 obj <> stream xͮ|?Ë$0d7EYMǟj}cR,,U[,ԩ"YŒXs+\Hb.|Wrs%z+z1ыՎ^uRpu3($5hٕl"͔Nr1WwV-yKq ]͠\ \ ׎rK.rwe5йܻ2F+cBƠQf. 8rGON %P%+(R(h]*(\UMRK(rꌲr}G9q(ӕLe~s W ӄ\nV[C-Z*V3Uf(wQM4Cy7zd&Õf[h&iA2 -s2(e ʱ [r_ uϘZt!=Iz,\/jTkC 2d2=ySjG 2 kH݁ÐVK+q`Ft02lǟ"0ف@_7Me]h.nfbLan6b#x|ܱM-DՉK t"BzWlEz߂⼮ Fug谤+>#C8lDPF 1bEҹ2҅Ӆ5RޔR%S_ %:IVRJYRx #IM#b%MbueS,oA'(-+!iX"$$ gJ_l=Y1mAgunsVR(dQ裔1J7~I2!Fz1*MWFmĹ"t sG^d^mZ 4iF8Q'2'KV3M.G]دvt> N!FЄVO[ *#Sos8f r4xRsx( 8 1oGn&#֭g]E!/ {@B 88h-h##"LkE0l 6 G ,!&ÇO￾|Rp_$ :]$f|ԩ$>~|~~O/Ͽ__|/?g޵ W+>|w,Y{֌􇭌a|w |]r㻆"J\5WW3L0=DF}תty& w;6FZev)e5gN-(;smfqhj*Kͱ-šuje  w|x7cU[=ҡ)=-g q^T]Vz 5KǍP^cF:4)q3LܥN|w|3޳zs!œH˷LOP^^yܘ(0'<xwd>&xndur;z\_sh3c|:WXEC'`+rG-栙 ̃OƯ.-'?;S#`tacXxuB;Nt{[ ʔkdфǫsMM3 ]mӱ7N/G?$qz:עfw,:cCBى58/sXtV05uFA3I%ĥ endstream endobj 1214 0 obj <> stream xڽZKsW1p);^;늷*^r}HH\t 9RI*ej8̣_݃ŧ[P-rzvw|()h fLBLR乀/WBo\?_ݮc[f]֧]_<;YW,W+YäqȎ;5ޟ`Q 2;W]eO݋JU|s +%`L tKŲ txnƲRѬ:V]Z7p*.~&"z@Ak)NWHVB2Ht̔}nFzY ó]i!jlX.MTQ'*[sJ*HagR#HQ nprvF8UISdKy v/?&wy&ɃV?:gAop?'"|C+8f6W XqB2sUæ9/es"zMq81 0[OLvH)@QPWǤ2?)wws˕׷ȉ/9CSGm"L2+4~b?( {@hG$AuxS4vhzs˂(*5LiNaJK kÎ 4?mɮҟRsjRH|F&m +ǮL?VQ(|ط` .E^\j@mGOSZi1 -u҂5=[c@OFfJ4XODEvd>Wfm}:tVOK9G:n%9T9_j_7IЄ0 ϋMi=*'ƘAVVVB@KT£@ITBW ΀7bdr,Ѥ ,kYZ6s`\|y)= #F,?bd>vȄq.a]=vL#Z› ބŀJ c:ZAUPpe ;‹35 ؟;j[O <EW!,{Y09j%BMWԮ!A`&xeӴ8yՂգKRSFn*! (hd& 0f잷m6% "XSdqq]ս\`DS{+ewYd#"oqOwlDvp>W JNZT_w|R+@`7 (f3~wJ3>nS*)>ڶMv ~uz_!V. U%RÍC&%H4zҠzf~ 06]8Iip9Ɣb?oٽ ˋd RǓ2AfQ,K_| gi;\r]I zqŲ=t5.3:ќZ;c|dg9YB.X©a08ڸ. d?nf ʘԶ֟ Gtհ\t.6 h"xb6U: Od="/TkDb yHJ?T=Օ #ϳ-f2ߔ`_WUuGI nl[C ǡY4'|Ę&oxhmnʮ WRmUn\˕/}W1ӲWfs]t]$DǴUK$2hH\(t!i`I4󳻙Ux.)u'.<&rAq[w6}l9bLey;q5bE>bܯ 짥0@.2oANQEٽ~+s!H˘ot)=Bk(mByv[PPYW`ZC.Z:s ^ㅴҗ6QmhVS^AKr4êc,0:3|H߼z쓍5Z`k?7t? `˄ɠt(r6-Ae {͍#}Il˃e{S;O|v&sM4gL^Ӑ|ĉ3U1fyxTl|ѯ&>D ،A\i==^4iMs7{NP(B,3rs-;I.?Xc Jzĥ:'rԳP730 |X| 0gחH kwYF 9aTΉ_ǥMIEcC1v/ƞԟiL!K] MydAZ,T@ꔬ *]|S?U+r5u念v?J"Z endstream endobj 1218 0 obj <> stream xڝW[o6~@Ԃl`&/U݇JUUi:ɸ2&=6VDs&ޓe1E^x?bGw<{8A{O $I /!G0EioiC"NC{1Q_~$/\],]" J~0iyaeXtMh(N EɼpTu}cn:9b2GNmlS쳶WH"a<>gF*B4013:xa^qA3}+)OQeLV3N8KƛbF~׬0w$Ϲg fqDKE`#M PUZx܋r[7p q%~WOE\]WJ.H))6u|FJaNu}^)IPJ]+F |.s)r$EɁHL].zEK`a5J^ .ٌ ~ QQBķII ™V=̤Lґ;r*7.[. J^ ˳ء, b7U+*52#؎b| ?v`[&sD&hڡ$SL|K}0xR@ᶆ ?3f A4ވv3a17c1fg*ob|[) p全DVg9 Qo2|ڋ/:˳~\dL(Imk> P}QUχQ7߻sboص`&`y(00&d VRwVDze)M{GeJWn]>‰~AQcE,J+i<8L cu}O< %Jr51vzkAwBݛAզfƗi0 cϳ/p6&ඥz_So|ךU *-ݝ 3lR!ԭqn}VS^+0W^g\NE7δi@z%ލQ2qoHyn9”,%w) B{;??u! endstream endobj 1221 0 obj <> stream xVMo6W.hEcKܴ Z4AoC YkRK~{IE؀%yͼ!D,V(<uF`(5(^}b,zU1h[o4/yV?Z_*֮,u0AH0GdtJ߇ v0IP1!~M(Vg QQT"(p` ylk!;ruCŃy#,*x 0(ixvO4+ϓu̘> stream xڥVn6}WCTD$^a~ Th%*Kt(9i J<{Hb K/6 nnQ88  i~.]Xŗ4ZKsHoonSI% )1 {J1!(dcltf=+O\Ȕ+uO|F dX L˰ey ɪvTe  8gs: n#$Z@ԥJS_Y89`9HXIq1p,+˺NIg)tDZTxeI> o;6WxB՛GPQ=,4NƐ8To4C324ܲC K:!6)jnM{a;9bw35 gHW$`J%^^a9>PcIb%N3:gx?_l\#W҂5|V;T쟪ahsωf>nF,B|Z^> stream xZݏ۸_ D<[^{9(vۗd֖InLԮ6ELQp ,>/"tnwlAsbrC-#RO њ{U9_5~WC۵ uwl2V,W]\1Q,q,̒ C *\?}YUnr XáĎ[/e|QM_KPT0\;Tn,@O+T>T4_Zcc ikuC՗r5lCT^_5#χr[UZaޮUDRJjG쎫'n W]۹fIe Fe_#~P9Qu3e_?Yaԣ޸_f96m*9,X{샭MqC0)u3^r=AyJYͅ3rlbSX])͒^#V:Bg9O=uJsI~[of& GޕݓsĶP W !q(b{yi_%yȷgɉ/b1q@Lϴ!u-Ite CXw־ۭؔk (Τ=taF9`gηXIQA^LBL.exk/[0nրP7RnM;+ PmkRb>ݢ@8,o"GxR>W#SZpJۃ}̝V[S8J;v >eE8oU6c/e ,’pvU,S0)7ؐ!@gI"$<8o{ae;q>͊bm9^xL z_M jP5UWs"N9vANg$ܼVc.1)M!}V+4*T5M7l5ѣѾW$lz;d8 .8@S/o'ox&r/y|9./JT]x.+o+ 96`8 ]< Ue.>r_0Mle48gPpΔSD1>6:SHD.Nlz\qH\':qC%{la{W:“c+d*ӥ,;V!V_B 6f5z2c{؂r Bٗ0sϓvL[4rZ1ng?AaUWc_:Fm(ŀZI[\Y\!\r,rJX\K'w v!'3n fLHWʺqUt)Z}pل_'C _'N 3 |CĔSi qsUS>2|){gC|C. /c󷽛:̿NZԓa2.d~rbt/wMU /J`6_'TБXƣۧ0Y5O;^\cBqq]K4I*-NIZ&o,,VP zp.&̢rPhl`pD~G2f> stream xY[o~ps٦I,%-ln%Q&)rDCKޢi# r߹pyB'/דg_ Ht2[NPNra&/Ŷ4'4B$WT7;ovOMDqgI7+Gep2vRC[umjEk@N6Im-v/bٍܴ9ldv20-]7E}5MN1j#TvKSc R*)bqMgPP&]f褶;޸L% 3#) %ov*d.E&Hf *h`IqW[dǁݒt:/V%ֻ]DRmlvWhBdEv,NK_#QJIͽcDBw,WF.39lp2:l AuE}_ Zdj"1WγziQW037Oݾy/Ma#4"~="V~1Y겪;8~kQ9B= ]TL|/aS%I&!C .cy[@̼k`P3DdY;`T ܺIsLx: #2 "|R x! +&Xic2u[׸>]DvfpEZra~Du A 5 U{Iw?].M$ P )fF) <Т gNp෮]4,5_]ٞpp+1 m:WnK9"wf!v~H>) bn* @ QòMs<>*@*᧲XJTLF q?FՋ6s jBxXPr u3, 8{}k$`-$}v`oEX@sci?F/EXec=;r9)Ɠubz]6{gw.ɟZ*yX>CQO¡3÷X+U,Cү<w Ij[0FG;1`1?P]Fp*4$}cvF|k+#C˴ }PM^gw\7dnw |,E'ST͉bl~v*B ;*IT)At##a ᜞gY.ODX!MtZKz> stream xYKWb[.]e.a ʏO 7D<3=_wݳ}A⯷oHcM -Cg]±\mAEJ1<}͇eKj.~z+s͓=^4KV]Q-J:;Y f4r2Z)]YWo&EJᷛ­XTESáZ|aLo-_]m*Ya"W+cGK?+H|Z!g&qaBs2RgAldGb1HJ5 A$cnD)ѐȒ/eqWIlzUK P$u6UZzN_sV9"Xwo?H[4 ''y*micˁ-<jA~Y?bg&S:.x9HN=woUFQ_'2Cv)G;_W| S(ܔ!7{ߏm':c @K5 d8(<xgEɮYcs!Պ̋Ieԇ2ʸ:5 -) wMh ^Y #ϢhVGtdR ġUԺnj@P[J`D5=M@T Hq n k򆥳YYR-9ԖŸI) mۺOr>>mպ0*ֱ8(PrGsD0n]<=c\vIPܬ$oJ&'2XW(p?{/2p=rQHںK9RuOyLJm ; D={_%bk4Q`Sj?/M" X=9R.q, nl)fQ3J(/T Y,wPӔKjH?g,o7n ގ尹eDDBLa3$rB \RVeU&H:oǾdK4)V-ps$]Ol>D֖RE9i"OK}jhQ4=zXq45L-x<076f D2]4SBsLwc(Sw1Иiz1m% /@h#2"Sc.n3,yd.Fr=©O1$O]he㘮J|{)]SyhEqGtH]!Af (6Y D+|e1*"mW .?5Jܨ—(<щ[4Fk>QfȠ?F1 ᗫ[V㓒v h5*lryWM8I Hךņ2d)-ь`3ք\ Q}i1Ioijv.m4d)wysg W=4g |xE vR>s2v[w(boTzgff(fw@䐵?/MkwVu6VL4Rpfafvhf懺E,FA~'VK Eҩx@F|y氶mafbJ F a7p#c|8HPzqɛbbe,j ߬үP[F hߞj F !\ie>!S.^RǠk 6y@qMVS|lJ2*$ I(5ˏUꆃܻ}crѦ-.nև7ۑ^t8M5@U&oNZgm~_Y( NO!i2ݹ 2.SS;~E<$L~UdaN T)% iGFnq`~Ӭ*0 Ul BڌdTֽ;tȢ;V8((UfP@g `A|)['ɀ|x~pE:^&.tJ9aN2gb 0)Q\zo Z~pU]CF;%(F`O&bN]p1Og2\BDZO( ݸׁms-MWs$ke+ItuMIO6BZ0Npf#m/|#8 R~y/DOxxt|A& ,14yv_ vb endstream endobj 1236 0 obj <> stream xX[oF~00:uJmx;x%Zva:`]Ȗ̙ܾCW@ ?$P~q0~oh@0X` H4O"<]:E1c,T'Q9b!/ټϳ_NLn7ns6]evoK<@+ndqaA Ev /O%Kr3I{:QG!Hk#3z@X{yx:/  sE^&f?%>Q" /x4I㍋Xn h&fL79AXt IV묈 CL"Iy#yOy@wCl|bpI$Ս_?E E^G4 o\*z-ٺ $<>S1HJpLAB 1e 5 :)^P"=.H3yn ^ҁ{~SDuIc [ s德xѬoP(sy{tnwbMhH+-fuic`rjL:zg}} HWR(A*I"?05Lmdb"{`>Z)[M}(PEy9ATq|`G4@ 07z1}9r@q@LzO"]u\u(W|n^"*ܴ dg~[}iMUO~fSH썷8SH[ɶ;[R#ocs"j"R1}4Ecf30eg /J?ς?kI endstream endobj 1239 0 obj <> stream xX[o6~߯@N*!kS`HJƖRKna?~"%K.8]V -F >$(}MQcPu0\׀2by6<D0&٥=y3Oţ}z"rf²0m["#MxuB x I,)(JW1 ٸٍں " I*IM~.;@p\WA !,O HpDk^cAiJ}#aYmc~gNf˴\+tM5J9N2<*80UI H(#+f"nyag+$D8`H7*#Ac/i?i\du>aQ:}$HYwV؄ѽ^@b+UN]c:=a2] NL@JjFQ&Y; ڨDu+[Wwtj'cDt#6(:9OCsvp~jϒ`FJ`D<⤻̏RKD41(v(E/J^N[ 5$_è$s!f>ќ H2jo]uGgGGmoPb(W\Yڱ%:'i\4b^mzxk۱SB@fҳS:d^J0v _zS_ԋ>P^{=u+r4iȳ~,aߜ P' tkQLԑocptyqv u!S̈SCp bq,om{)6 0Mm{?+6|+I q]$Ƅg'O"v/\L^͎-ُ:X A݋=&mY;xa1^:/0GT<W*4^ELͻ4zN$Rwz3plG%48p奛sl25}d4=Z %+f}IZ%\-Lde&?LՔplus5;bu=Ng(],C>%^1.Ti,qCG,ٶ6%ۢ뙒%d@ jہAĵO=x%<r#UyJCj0?3`,MJ+Uj%W9ii,|3AsWB Hܼl& *}&otHMngm2-|vaPy5ɸJ5wEeX5iۏ>Ef>;U r^e<m)p Ig-08ɒ;/H&GʩB??ڙ{,F}/yٸ WW+"zC#X\ڎ!Ϧ`FgԟvNgl؊~Vc3\ b(,\7~)t^h!6e^2} }ɮFFR̐.lZ3緬mof|d6&1Ձ.{fFzbm{rdZyT6SK'7f^lE _&s¿J63ۥcnCN˵; osP endstream endobj 1242 0 obj <> stream xTn0+|4Rxlc콵isj-́N5{Ukwc޼y3oxxjCo9F 3'FjToM׌NBjS)%XR៶ x?# %UBE#^Bb9#HC5vnYgr"P41ÿprˡw>4o ^.w/ϱ.!^EkEܫáI״KEAˌ8Yonq)z^Ney$i jJǘi?3hBug*prG٭rs8lt8/ c594L5{pLR9k}M]e<#PwSͻI\aW'}qor3q=hqKj|1ŗmdTlLO5vBLm endstream endobj 1245 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1248 0 obj <> stream xڽYKoFW07)(o=hz(A^h=\HtR]I풔cA|&P &mm0J,,]'sJ'Vvy7o,aLh*,1LfJiQ>Vp=Iݳ]=BC)r[(] PkkfZ=Rrg8O+B>sq~:*G$8"ۮҬXֱã1"p]U5r7lxڮ2s!He`D;:>ٕru\}F:=oC)g !@,Sy }D ǎ'pRǻp4{\O%'Ion~[=´Y1ބ4Ea ͝߇iC9mJ@ 1 d9pv ߉q:_5B_d<9&IRVr3cLقt>\( ǕW"@ 8x}*0iNNLy<-l&;$a6Y's}a^&}WVzu^fri_}7uVrȡ{FfӬ?E9bheFg|JRJI` y!}a͢FRtPM hhR{TpJ!55n.XvQyxL5hNG;<gDJۗW9qOjWjwF1s]Rw' /d OSm[bM!y0UCˍs%Bۿd>?nc4;E\]ee{9> fSj #C)XsXU9(/5COBdD+=|ϘnGry.KbVb*>"BE3udoNAo>8ۛJI{ߚ4s"/C~hg92tgu18"|kwSRYN$d2$&ĜgJѶKq|q!~+Dߢf߂6v70k^_w4趇YF؉#l0rhյ-ZI;|#& )55 ]k4K(9/+e"R)Ae]l=hl+ig5բSmpq{Frlwm$of,m}ae1G81 CDɫpԋyޟٸvvsXe9X.nMOk( HVo~9i~Y\,Z+B)c?o+56ͱlr@slit08We/BtiCPoS& h.9۸0~ZUHZpg^Ɉ^ n ^篝YOVO(YpF뼿\ 4UBgސ:6cu[;]g6?GFsP3LNUr? *)Z1DTyD+5xۈ' p#M??t endstream endobj 1251 0 obj <> stream xڕYKW7/Q&`` S&,w+cK^IN/SU|rSN1$XW_Q_w|?3]sqObsV=wq*U+.#/!R`v|z_b0ho 58+ݍdٱ<֩U`Y- OoG|0}jŲbReI/%@ۚk3_Ʋ> Y}s;zlMIoCK~7NK]bM+ ,ǫpM-SpVh >J!XdsՎV"*Vp'MsR9 !ܤRV~Wɶ1%KTQ 3Ii5i L̽c' 4!p=TkQ3i8{+Ɣ/f6e4|ƻsSjMľuhc'rj:zd"GAiT].pzn7_LkA֝s&~gc?%U2`uگZH]AW#R"L* ( WMR~hf.(-rN:ZXJ o9ai]8L/'LP6R[JA=dRj1n(5^nĮfgz Aa0Mt!M" " Dوrث)`]S2d?3afwj,oT̽q=^@z]p*H /"3!h0uԺǀj &kc2pJ|A {Dj' o! N}N„!+܄5P!׾!xA?YAXP;ڞ&n$^.~]0ao1kB >s"]Ҥs9ߨ hTrwkוLsRP-hMUAh7mGrAx[8\ҵm3\BMqyD(Pde'MEJaƐ:g(oM}TGb7!b{z$_;C N|hSԋUg. ﺮ?u}A*HҾv'Г=uR PxyPL\r r?LW>6 oM FX˩k<ABP*sb(eܳB%sӉ $25"ЉXzuZbiYz#ذw鰨@‚VNTŁUMzBGHD\*CH 4 h)RC-^On̶˜L?T\iY轙,4dcg^YJc$U`d{ryUOհLIUE-ӃNK.xn1 }]TZYz8L~ 5ޝDdCjs(.QxO+I[9HbKzѳ-6aŶj*5Qaa<;J[- K#R>~`6b}`&deʪ8i"".Uļzz8\g{8ڧxW߸ - `` t`}}CaB0~dMc2+4"gğR$#*ݲ6`1<գG:~}cf%HR?P1swK FpyN|y&$lql'CS{LWE?u1=pJR[ۧmK@|-n dDǺYfQiK8C!͉.G,X/qܝヾ;fustU[)=03ׂllpoBGj/uݥ?58ɃX DT t1PIQ'Uvݹ]=R fi@m|&$d7̫ G0Ns+Ҽښ3-\k}_7Ѿ E3=_f/ts}( & _g+P7-~!24FFT|ػ[i*Ls_8nٞi=)/<#6vbE@Һp.m , $*$"rDȓQ>"f.v[٦p=/+Y:% ) }u{] Jui"aj">d+ڂ$bZB+(tuTR8)2իB=yj#Y745S=|=Til1$"bJ5:k=i.-(42`)d{]Mz8N[o:Fe)w܁OWAO`,H~.|YW[%>py~B᫩'Y~?& endstream endobj 1254 0 obj <> stream xڥYKW{kfN`ؽi`s0bztA72GXWˆor+?O>l~ 6U$duF ՗KiL6/4xԔHҾl0@-eXg^ɟ? a^PN ~Z5lSEr[ލ/@֯̒q̧sSٻy~q῏ =Nqoh\=Y#F#Tz9LpCӍcןƲBy+,&Web9$L["ucݵtw-+iHŜkh3ʥoO.]ʮ;^yks@KqZpDigaGԮkI<|2ZuI/w^ +_ eJAԀkk>ݐo, ڋO'<{*-̅w 2ٹ|þ)xV* s:f8{k&LOeqP=\."Z Ch GG(vI[QCggV(O}8:TZ;$f҄z$y BuK9<>i*y7Eo7Wj1Y~r'fY&vԸ*AX*o*sNI?tB\iP5xp<%2Э;BlMqxM!o1soR| b^nJ`{ЎVn!g|7qLJ) V*ޕ2AxMb?0"?f$/4p;wR1uNETcYio'^p&t-w y~ y(8B6q7d:۔{KeQſ{fsXB|He]A-K-k@z 돦4L_#4$/ibarqX^ z@'ZƶzN$j^rTe9ӹ\+Z]p! /y}}~䅝C>e6por4,z+!D>P˟UlI('LO u~/TL`-Tbe_K uRr!͔DAz@!b/q.>Bg1/Gj$G\XQ 9ŸW@ /"6qP@ft(x΅63,k-#ץ C}]M:#IU0x"F㡼Ġx <'.ַ4Bbb~c 42Y9iIUP. 6tDtwN6!]4Pm{bvbn)x *UW0b4n<'^&uQf/х%UC Hfd 4W\E"*$U$D?F0Qu5]Yj5 ߼NYSa !S\(S&꾂#Cemt ) I^8 uhhہgIpPA f>V#5cm)+xC, G:0/[&WhMC49e=|)XJOPIuD{.ωk 璷4@Tý*龩" ﷜bMk_&:X@v $CZ]&NoJ^b1RAFx9KF@ Σ}X(!F&x>]Ze=so<#Cf Cju;Izqt_jkp:"ϔCZ̔7pW=D~6hLJt=x/̴9d-#}ByV"}ք\:r9RYD_B]}/v076]̃Ғ1BƯΆ#ta>IO2e)R"`KrNLrovq㿣b%^r=\:I7CNFhaWUIjpʍQPٮZWv!t9 ` s 6XR8x˥Z U%FH XXo0BPƯҥu6ZB_6Z endstream endobj 1257 0 obj <> stream xڵZsܶ_q>nd AɉVcOduҙcuG*$ϲw?yБ.A`؏.c%W*S/Vǫ?q.r]IIkk+8x}DIzǍ7~jǦƶ^n6X{5F:4x xe^_MXwO:_6-z$NVݕ]ߞ=Y,_EC桯wյIٺ۶9r<=Upܝr^k|CGxi&x41C,֋752ԕ|XT?/?nYSї " !`GTlsވۦFuq,f8uԮ4C {](|l9}=KTwHy-gOoJSvcğbWK&:*wݯ׃LYlr-G?e-ܸDD TT:D,NonDu/P>V1}3vWՎs2&0vZb&AuBaJlƙHCfKW;)} =ӏ8ߩsw /vơJHB mяV\.^e6NW$/bmZu_F{լ0Ҁzmw JRY2Y2$!E.d U_Wpʯ)ڧ@3_::9-mM,__1D Xk f[#> qx}X9lߠlRbcZR zW}-)k#[DX rlge $_iϾuNDzrNK!Д"ҳ_#;Zp'.:"a # ackbT6 "Y{&I{ph40Xea K;mj/xrlg"-Y \ ڛ}q1ntC#Fڞv4t \$|lٛz $ܜ_ilA[!PK @OWH N` ]U:)?O|zs #:Np`|0ݴYfB"3d8¸QHMDl:: | VőҺ< ReLBa@{"B:d*3l4񆛳`eΉR3%Z҂*!U Y2潆{뿕팍U~**E!u`Q (@ሲk lh|jMPteNҩؗ`$lw{%u|scA.WvT1$P>>~{j^Ж &QD$N&8OQ(cq_s|ߢ:У@&$QDTi5K|˻?F?|1뫿 8⯯\^z˷.޺YQ7 Vu>fz|?֦b1>q5Wπ0C:302fpD_Xf`%eH=s} ^]2-䭁0̩V?/P}M1L1Pm,P 6H=ziiOl̖2]j A1ն@ we]XhY3[&W_+^XbZhGPkӰ|a B<R²f_rZb'" ;/,Hynim>6iaOrYG 2z$vì8S EsH; .Uĵrs[i%,0b9v$ }"1 cYŹj01-}P誻8%_m`O z+/Lj I>!~ayZ=m V]RK2ľÁ@ýGVI*Rbgrp=E0{6HMJÚ=G?Fu\ĥ0Fchw A=Sy5|p(s%nvC;Q k?䀐}p^nXrwҲz h#/Py:$m-M@ WzȾ&VVvbs5LrF&ObZFKaG1k9 GgwOcq@i0^fy$Ž(")Ǎ|X`V)$j zM~ tiwnyMĴf lR ,4t|Jo|z,ue=դ঎UMIowz6 $S<]OV!hg]ue,$IQJx FN:Cdqa?2۶UY@gK/rr\Ǐ} aM?\HsN$7;]):OoegmC; H'i|9 6(Ͼq{fQtKyM~gXi2)V endstream endobj 1260 0 obj <> stream xڝY[o~0Ryċn[E lQt۞EơcaeG$ )޳[$!5z늯RBVW?}+*~KVru9yoRʤ|wVJ% _Rg(OdxbJXr+vzX!z^tcg yf=\g:FV ' V[-^̩bY΅yozB*ʥHvFhv qoebz=jyѧ\0shɻ 2G,\( 56t33b~b}D$ڒg7+Nރ3YnKuA"2ӖDDg"g@Q)+Jxf!3KBLe‰>ʌOzՂ#-faeCbbEۑ3>']h'beuKTeNfM/z\X]LL,ϿSf%ޠXBXv."k)ݦNx$$!T2Lǵ;Xt ^lhv5%}>&}>`fw"W_Ue! w 2WS>i\{3ߨ8 d˱T`i!6*Ү%5vB(> TYQ&㧰@zKj(C!o8(q9)M+"/ NȽBa_ t*[͛ɢG|VE8ULۍ~~mBxtKN4zL㶳MZd̙*e{%<_?NXT Bb 6* YvDСk$=-ERX/gp832E~%ad)| cdđ0 =!!< HB'c}7`4!r! 4˨ھ *QAp3E1)S] ɍ[$0C<$$6K^]p3uY3dDX^[^vA 3oLB1c˹;M?X$\ jۮ}(>cO2䋟$9q=ϥo]q3Ѭ38“QO3ܯo endstream endobj 1263 0 obj <> stream xڥZKsWjɛ8F9@$$ 4JS 1(Q _0V_Xo?^.} Ҝ|qyق4WrDq/ !Ej8o+)eR4wn*{hor%dߖRdp(W)[V*O3]Uoh<"ebߗvd+i~=;(k&eb\5oki@*@sy|`Gu;\kJad]ӛw6iۯ;|bIA/p@Bib+q4JMO&^Rs)6e7'e)S#FP'JKM5"muȱv_  : ڗ9Mf^:h$3| Q8*]]u¢3HnRG m0k2W] A31l ÈG g?˕eܛA J?&"~(55ED ;3gI_" %<9u {r=ԏL&IœPڽ-6\K9 UͬV5Ɠw'u9 B֏+48yHgq0>L$_v :V$Ac' hkr =-zoƝSi79KsK:8&邥FcXr*?ŗru^4.Uww6UZF^%tezݗ0:.z[ZjI0wj8}4S"h oXe?zՔ+˗g4Y~`xoru]ޗ] Ra.?dB?2{#G?JZv7~롨yCQ7G ?]..Dm lj8 (dJTm+!w)`!O=}u]{nx|j~s_~ݗͺYBKE"&T% $:1 F ԭ=`9X_`M2$L(撛̜j25;ATs60fH,FhSL94ꀇLR{ đɆ,^2/c$HҌRȡUk-s@2uQ4{>p~p,yل+u Y2#QJe(]%>8B'S+Yhh1=l?+c-^;H",_h'<,#9 qщ%_X Q|@mm{?zF4=zͳ [LQY|-K`k*R-$@NMyC@h8A+sHKROxp8dCs09 cqqa[dƉ%LoQ{'n-9PTtgvj=zHܠq`3"d K$+jL/ˣ>O9>M{ltq7+1 BIC*sBh _;@gG d,х']+BЫ@e/r#`!BƏwPhA5`H8AńvpC'UԡG*`P1k ~d(v^;xej9-|D+++cjF`QLH-k=`M)f1"kIIl^I JX{q׌-Bw3l@Rø64p^| x`Ձ 5j&LP8|\`r7wQ"x8Stq.j)GϹ`xlN>d8)(#.6MR'-9(sP;ebCn!){Peuwm7A @:m`Q-|i7pyyam^KEl("2fS!b{yQ(vIo/>A  X`^4G_f*w!Q/(א-Ĺ 6gQ(% d8 PuzkOn lw~[+J=$Gq8| yho'7]]ۗ"YQqG\`1<+X(Ҩ}sKV'g<ͧʼnfP7kn,^[E"] LSIѓxSM > stream xڽXoF_2ҡKJENg 0ufΝ.j)_}w[ģx Fcn}^Dx5&ɔ?^}TEҔ[UFsؓ8j>1׃S|:5u]O)t[X,GAFG `)f'kX|Ұ\y@BXədK jWߤ\!R*k)]뙡,(\)&EƔ,#9Z<vXHW:ftݹ=tڔoזgXtrijS:LiXNʴ!yܝ5&6 3ݴ@rꇮq<Ņ,r9Vc2Կ%ӹćJnwRUf,ۻI,O 'i:M@" ""VY?=.ǤVxn8өW;uעtA[CN8:H:#_Q: Fo:,e">S#>N<+KKԍUSu * 'X[Uw!Dn4ۅ[DhPpDΈ-tר}R&}u1LGA$0TcA3] Qekoy .Վ^6Mg[6:\Ň;zHI_v:TLKnӔ9l؇Fcj#>,.2ĈZ#vkEͿSd\F 6 -G2poEd&Wy۶ثдd)tTr0O]'G/>uÃSnWjz| Ŋ¼ |ok2T@* ⫕|M S^]ssJ #BXz, ^A碣(ΖI.3xʴ3K6q .Jl>c1{y3*LCp-lB|5N zAUҲgfj. ۡ3pF9;#BD} 3&iUB\2n^œ_Eҩ}`J,_V2-%_IH#v(\,uMW3y,l$ l,:"44͆i -'S^0x_38d ȞlQm^ ͔i(8Ȍ@f&4_e0z4+H?ʷmq:(ŮyR[kXni'Йx]8{|K{0yE0-x{2orn6v};튟^w#*KtoߝzndD_ 4{ɚ+b1U6̡w24h2.sؙ /:ygB !bHjv6VІݵQM`ntBhG+cٻѰI.,`Al@M\oNN_BHŃe2%S96:/L*g)eFzWqi3Yzw2Z0T tgNO}2 P 4_.X=I&jK sL(RҩcU>pjҵ[gotI?l. endstream endobj 1269 0 obj <> stream xY[۸~[l"RMbv)PŦc5Hr9<,ГLE[d˹|;Nj (_TfK%s㋛)P.~DžUqo^-WRʢ>noá=b[?5F.W*/tW/V1]2NөB0#Ŋ iZO˕*5t=JWZq+)O~9'ZE{\n%cEڎ~6n~ְ͔`o3z}5%rVvլ<,wKj:q/5qs7vMI(VVg U%ls78fOfIМN-Ud+YqNywGYU0<*4f_w8&d (6mw+YWnw5t^ w'O}/7ؠJWv2zjv&{ٮ;mqrjs{/g #콀u,1,?9\rfH1)jH1MDjh(z̮FlPBvQKJc*\!戀CyYޠQΗHB1g\|ZhT-L8L, o?SC<9z(N"abOZp`ďzA׶kt\!t<催oInk2cgèeL(Ù7ŅFp;uw ̣Yd*iEq ƒMX$:L!(zA7L|o"S+Ł)_AV'1iAgXS\Ailt ͣP4zH-OhęaEj| t.{zbi}_!]OA+"KLyB,peѐob!P3W ;|o%!q %2YU4QD›O}$B/K>0ݜyVix,+;IJ~-\B]Z|qi@SZ0Wm*@ N <!&v#6}4Ftabou=c pvMΘPus>!dͅ9#-fcÜ< Bud0hdF_eD @.fZ-}d@zn?t0fiy H͓!z_ vLA^4#1k$Sbё8o/fGYAxG|5C$7$VFj:BOgxwDϻ ݻbr P(uʼnabD!KI0O=u P/0v-/@-(E=-:Qk`f~EVp zZqZ٨LBEB+kÚԨɜ!UOkN@N:EJ,SiPMK8JiPǺ$ ДŽlˈj݌W ).]Y@ᾩ,hƈeUCn]dcxκE=}('p:~ϽN7ޟgXpD cXqĤJtǣI[`apz~dvtࣷYDK` ӿiUR}m4꛸x+ܣ,Z.gfj,^Na/v): P0?uuc7QQԝ5T8`>E#:3M(*r.yz;XX9>hG3n(iw5O>w5d,#dPg4Zj ?!o6puh!uӸpfKOR!4Ên,e>?D()+*|!XlaX7DKIPjp37R]?Gdqc\EcϿv endstream endobj 1272 0 obj <> stream xڭZs_KA硓4d@K͞DHl. }m7Gb?R\t=~Y}XiW77+.Yf}yj-LZ)>tp7])1-5+/Zf0V3\ٗ_yE4Z2MM2ܗ4pfW"ONɓjsEoeCooa7uy{x9]mq+U;w"ʈhI^(]<$MUS`NzV,3B:^\O ,%YfnwkƸU4*l0Z~sW߶g8r*Z$A@27VJ"ymLI_D]94?CudN*TTKMkuR%Ϲ-g*y"<e;; vDK7Z]HYjw.+P4V higʆ|2\7ITQ^Ȯ2e_ۂ DdrJNh:wMɅN+JO8-APTreIywQv cO'Y+jHpJ hhr߀R $/&]2yl1ni.&)5VYQfN^e*cJy7X1y)Y ϗLIX_ǹƌT>ޚvI>KPȒDd,gH@5\%I^y0h?{'e'ӊV(\Y*RnWaP܇ hZ=kځgJ.Z=7kgE!F ]Z'!\pUX W0L͒gy[jy"Bn*Nh~4m`"(WrMymlrk]˘ XfWmi!l?7[ ,`S\zpl(kk-8}`&T,"%áE=>YAdq֦3{{=dߵG@P6[Fd48a R4;װDzAAx}urj-^ؠ3 !νX^Mwc3J=P`#res`Ƃl_!C1;™t# ]%=zhahSmQ5?Y-m&eR ;+Y<>IaͩroBC$fSƋWbWL)DfE4ֈ&rMH}fOj0Isgy+9LAGF>BB\ w5׻'_VO^% `{pfJYVQ /ۺiOS<mߓ̝qe"HErȻ`mgkY7yWHP5Ƽ"@#@q:,򀃛Y:q,j`c6s*@+?uv=-Bq۵n͟MC/d㬐id8cX#!SJ 1[#8co eSk @~f3(xR]l(5&e\^EBSjff嚱_lkqqb̓CAex*cu" $5  |1mQiMuIjP ++V m D&{Cӕ՜㾋sB wT'3~#!c,/<4=!mfSE@c4ϝ4-tJ7}u<6B WWFa,-3ʃ2K4Zjp`Z!̏k{ȉo8kv^}53*L/ܻvVG!{ٽ֥U߻䠶ّC 0(Vϵ+ac-$*Cbۖ(DL^,اQi h6y߹p5L-"b6e_|Qn]ջk6H ~x)qeoyd$/_֗·ޕ’.ᓊrDgWsC_āǗc4C[ߗE5`ozw_pȋ.0" InvJhXެ4)^̭ïTA"FN׿3Qq<9"PbOj] xEMahZWsc*-N+[H}Mb9 lp+@W ѡW}o bϢQ*/ xgW]euDQXP~N;JxAV TjNTMܗqūEƫ\i>˗e ZΝPభ h |9fph?uqї@ĭː`D !te˝%mc+0)*@tEJJ}Q,>K+f YQ%HU G8>}Uk+a5ZWVn?wՅ93箛oJ#QSztw?(|HstQ%}"\ "BVw5C5+GaV ZZmq۸F @>D I);<%w S&vx~b/S3l/ kɎ}~J5Ȟ /-ǟgz=BE endstream endobj 1275 0 obj <> stream xYKW!`Tb6`b:=m[-y$y&KIt(UWՇ]GWW]}[ђTeEW5+I%vS!X+њ8޿[o8E/? }cQ|ߎ'7~a؞Mf_}Ǘ7TKBFTPait \芔%+hhQtY6Hh> P6qm=59$LU3#- 8P}\KYԇs`M,YcPüc2BkHV 1Gu 6sھml$ mncE~߰grm oܾV]l,Th=))|-$cm'鐖 Fkh7R d*-P^Z._KZ>oƘki8o;6cnKIjpF]O(]49": :!AJ$D|9bḦC5Bq@ƚldAy̅O]o5t!pDݮw^HP>kxy;{xYݻOţeL8v-5ٗ9A6!`unXxc"Ja =8 a|èTeH-M55US:,FF(m}8XsJOn?eu S!mUx9 c<ڀ^6 CF <ĝax,Ø}V[x3= ?`r LwH"߼)1J03ji'xoAC'?"O{7bbBVɀÉDfe[B d?aXf¤K D{6Jn׌Cr)F!Qv#qO»qhABY}8N `ߔM" [_IO{\aRq(+-*1񣻘{ӄ's6CeR@hqZEVDs3g)B?c6Lh"kv eY^Y1+:fr8f\;5VQׇPBVuWXE` 5fH5/Xu (0؞\2sȷnеy?bFm5R¦ze(^'ٓv8l2ƇР_..<HCT;\1`rn 5|,`erǢA<(i$p=D|of{ dS2 J- kǶ<@Xw{{Q%R%Ƕl7$tzB^kK}3{4L>X]h:q?ku/UFp#Pjp> `pn}agІ#+}2dd򳓹^o&JX1#؊Q?`}߻T/ĉ,6uc} ɔ\ȫe{/ a(qwh\юjgE;+ /Mter%sU.z1(CCOjYK\kGǢ\FzKsEeMTKem,DϹĢ"XfZh2}_*K\.frrX ~/eL72TۯW*cjUJc3[@\~Dt~ qS4 ]bji܍Ҷk߇GƮU-Պ&[C*c"Ql?VB&# ܑha'JϖU, cpTwQF}ݝPx_YmDem۶FdNmD^ћIMUIOn M҄tрeFU)1_yGdZ'azoE Y{>WW ƈ>7%ޕL_X;2,\zsWRd3(mV{! }o}~Mn"^_eZ/7#o endstream endobj 1278 0 obj <> stream xڽZKܸW4h+49d 8E5MƣGm=bö-QYfۆo*ojWw߈ X[|aÛ U}ǛRJY47Ru97mfFXPRU0\5\هo`.G\VqUtvod,nazê7oa\ʇӸ]it$SBn8ibvouZFO+bIt8~JU^VU PPVbSZ6jhZgtSqր ]|-=uy%Y[UPR"]ǯT[O8h^-ÍFb;t|[ً7^ؗYfvS̵ru\AwB7`c64LG~Gxp誣/s{ӂ$P\k0n]#0@rzь82qDjw }qniPg1UI+uZCNsLSn@4XhpEpUQDtRցfX#P0p某Jih83+R'UU &]6F }f@ǵ)=T wwǰa5T5E6X K>U@4:SÓE]n7jx1PuUIz7*qWѯ8 S fW]_!]#-@6!*L{<"Y Y9悡iH39Y芪f; ,Bjsag3F5$yLד-f*3JQu%8$5I}7BIv>[q2(R%I pYf KBB]^z]kO_;akk281#w4l,N (Cߺ gUԇӼE@yޛ#,F IIr,wZ' nEu|RSg;mI !+H>^j mzW|"J-t\RVZ N,}X6{l$ &AtIU#m6`\E>,o^h1EkB LG|`D&Ȭ :{>p1v\Ǭ{LLd a-FfX$:SxeǣiӢ_h*jSQ*(*.=n熵wt0P<̽3ĄIlxU2. mk^AEwzMhtXd4ӂc%i,PFЫ?R8Cd*4й Ej)#.gZ#Ԇ*-(kR 3^Y¬0wC<Hv@"hDJc}ͮWaR6 =m4h֖  FKSYUpB50qi(5+^h렧(Z&H^'[}%oY>Nt!B ,*lPӘ-*0SuddJ7_F2v$Iܾy?lMhRxyഎKO|)uzg.P :T1IpZUV0V2go1o"TbGH6+'t2-y85t3*ئ}VRZώ(dYZDi+P]ixg ~ۆ:Z' [zքRjL+.mw=\ #(55fd鸳 8/7r/Vy) #@YYEk#ANq(!Xt%4bI={{"=׺;oQ8&z+f`~Un4*kRd ]"+ R{H'*UL!:U$:Q{.a.rn?>+H endstream endobj 1281 0 obj <> stream xڭZݏ۸_aNӧ)>5}PlyW[r,9{ۿ3pHS5Y}[Up[6_nW?|+Vlu[zDie+.xiqϟ>ެEoiMaq,Hnּ.6CpSLU2 t?ܻ>[\Uܪ  YJnV븲oJTE?L8`x>]}uULNt>GxjGv%b-Ufn/7)˲(k]',U&KeL$4dv-*ɂ`_y)Wu.%lQϑdu >tpU S5`j8ut@s~q8`xo1נŔo0EMDẃ[Z m8zYK)6$hШĬA;2m[r]?NMq`7~7 CmhWYֶ,@\"8pon4o8L8;r;MA]Ñ_«b,@zyK BJ3CPcbӌ~p:Z5Hei**M ,a7|["sXBTg u1hN\G7N. h51/-3%u" q @?^ d6MOף FX "V!H'fV$WH@m\8xq1EOyXȠ_ " 2^c?w|^*5j׺6ŧUx; \7(,F1>Cѽ˩RN;mΛ>#mօȪK.-;GJ HAm(7Ғ %">U>!j'sI)B"?BBu49Qj$pq XCާkAd笝v6$zcrfC,ǕQ/rCpmkRղrbQ`_4=n-&P9 @̘Hxf{!{0'*'zrB?U^?q~ s_4 `jKǕ*JCBpxԜS%d :[JfSI۠ھ,yrRof">$2V/ku- 4"k]LWd`ǁcQGK.q2ju9fEJӨ\A/KH1\Cy!-\C>E$ ·~UAhi'rI.JӈtA^d<\g2Ru ebL\Yy~|mk(s!m!BcHIuV&{&X[rc ¦P\oQ$2鵗{c׾ZCQ8sSW@qE7ԱtB7R2eAj2*]Q $9MIml&R Z>A4G;鸓\:1.窺M97#6"KKm O# YhM8P;=j!СrGO3!jSDh}k21ocbBT $%OI_.9 Dm-;DYT `ٶd~GxKeis˖l`I-L8 E#9Q_QkYJ%ôd~o4)vdRߕc.5A>)!j:Og׉FDKV@ 8Ht8"=|ݕ?ф8Bo\_fH{U߼7_ c];951PtI8{.KbsBeV8F2*;ˑ#F6| Y"2)009ll 5ArS߀*򔠙[]aX~]4t=b㝼~)u\|aVҲ:kka!k6m˜5uNuчR7!+%xg- ت M!j7Ǧ2dƣ\)6y0u]bW~wrT͉޲/NΥdcem+X cwmyFJtgqw8XyhR7ؐEGinX"5݇LR&Tr$ޣ ~*W@_Z&hضYpat >9TeoGـ?~r_1_\w :\Qu Ͼ][N@}1MȢU# g"oYY1EڰYLCl0Z!$Nm};}cnDU|7q\ݩ+twݫ핋4ŗw۟_+1 Sa>c Ea>wtӣ{v?,n endstream endobj 1284 0 obj <> stream xڭYKW|Zċ gNIʮJ.)f$R+RU~ jq*-@_ɾd-tr%EEgr0OޟHÕȜTۑk<ӁęR*AbpK~~=nMjBP9x΍aԑVVǮoRCG;<4>tG|S>N 7C ɮȞ\L5'dE rJ` Ibh7PZ3S،XJGfNh<ĝqW@Ҝ af,sCaP.@@GAINSR΅{7=LF#xUQF4"@DiP!u2iSޥ*RpHt{i $HyHr!]꒒TdL9{2y0峋 a]8MQbVlN#ףCrcZ\^ ⅆMu!e,~9 b;&m+Ʉ^QXI~UY"+yoi<!*c@宔r6 y4TyN[oḷI0PtxpPooɩ Y`LS1>ftA̢ `Z5>3Ip`F>qZӢbs_(;0<c1z}|BCJB] G@gb  *dWQTiyWXD 06dͦz(: ;hLk9Em3g5rr3RS\I  ^e'r~i5{V)5FX=\`CjW vLsAk߼qtt{]"O:PdnMVfx,qxތO1o;'DT`w2~`͚=V! 21x> ʝ*9W<NyO*DiyXP])דs{V!{!Ib#\N.b駵)ӥ އ` g(z\P>rDmlh\q[GlooN$QjZzO[Cb.Y.K0SQ|(_ƚiv1&.%b$ * v,X'4~poW8یc!LLJr{k/t5(rvSn hq?t&Ljfx9YKBڢ Sݙ9[oYC^w~7vҷ񹣂ΝjV\NV68zTw+[Y *LD_pG_p9 W97 |VS34%wxKYSpqC̈́Jn]Ʌ"f@9PCġ\% u1R=s%74;'qSG\;!ոEk0]@E0&X~JPz.t[ X}Q˓$.&J9xv(>>& .κTi|NK(hZ/7tRS'^\jO$z`!&?R˽cw<ۯu|@PB> stream xڭX[s6~LgI>lL:uȱyq~}$l N2c!Cbx ~w0@  C7' &XQo_J"ǮuË}/&6ZlU*>6!0UG-ǨL{pGӜE-td>H(k˨sq]=3S({`z"` \BB)Iqև &Rp>k+m(.H# a6Sf}U*"O˸%iHc)4<+(Aig*X͘CnBzZG+fL#y:ff+ 慲 ω+B& 69KxlY9CƟQ\۞hZiYhcC$"= +6L{JnFkȅt ofoa1_pIbl1!7bF'y`;ڛ y^/<%R+9MV"wq\ѶGY'.b䑠5bM Sa819- Ά&!*߸CSEj|:A1s,6\=sO&LLb2މ 7 JdJe18_g@lGOvDu Ӳы~u`',ڙ)B/i_s id QH$qY嬫ɉ!Qki2Hai'  %N4wv}B|71.L؂gҽUz&/wvr8*z $Qn!iDk&Zϭi,΢Q^< {(?hUA#/c S.dccwZyg/#6E*JDYdH&g'ܫCJ\-sn;&P$W3Y1 yKtۓtKvt-Ui*X9ұ\Uy:՗*MV} 2+Q<) =(S^>JΪX^ 䘢\Xg#ܵVlyRd^G ;'6{u9v|ɹ..h d\H/b{Qe\:P"H'Dzv;Ȗ͵!.n Q.up8֊KmTHLf倕V6EO dg_^|$V endstream endobj 1290 0 obj <> stream xXnF}W(P^KC&@MkEl)^H2)G6@j;;sY9v|Î ;yw@ȏsrp`": :ԲyR7,QH)#M_u׏:#(9uUs~Et$R`@iFF'|M]եWN0ӗ ]"Ë u|sjnbWjJ| جVoU}`ef]Y+flJm-ݛҬڶcbFٖiލE H:aj'#]4+!v`x!VwdKQb'59,6^iԚKF9"Aј%8om6GAןUE-eJ W,u~(S 8ҭ1Y]9 -LܔU=cKRۚE6CZHN8 AWJúECˆ&П[j ]T~E|ĵ*CܿGPGK p*W_I;:=fl` aۺί8(>3!gR |UE|Z5G ^%yQֲb4k+0Z.չcw_D6?2FծgEG#Sb я.ܝ~Þ!/2> stream xڽWIFW !J&zJn\6CKyL!E p-}H8kk*\z2# U̮sN/e)k{ͻWc,ᇡ>aU2oN+i}Xcl[ER ;[oI * d ^ouB~ǶXuS e8 f;;+7FLy%D^fmoƊo/kE ag_b7; SHU*tQZ8U"L& A6M ?M$B B@D!Y>ƶZ`8o7xq3mx؇2 37kMWO̷ +xNh;m&cNno'ڥ/Ɖ2>r撆$K7'CvsIL;+"΀4q5I1dWk5BmL=FS&@(I H=7!=`1.fB&\}ݷa\?Nu`s'_wW:Oh?QNrZoyueBs5g8޸'8N.ʼӾnnQݶ uOB%$&\b)9Tc:‹P LT8˂a4R,gP^SA c&Ũ\LkR+8H^v>6ZW_QII"F!_g-LԦ4$R߰"QB|3sd 7"g)UQQb3Vb+U*hC5@D˘FBT/HT_SmDU&IWq$.kl4g점kA lɓK ]VA*'vx(n>E%" +C~m-*X15+g-9Ցd0pKzF!tJO $̊E?$ :(HojܯJZ܎q~RNN@R^J #,}sBT*~. G[PJvGkJ/J-\K$JzW>5ЛO*H =U‚e!']6q-ԋ1콒ak؄ # '8ݥg oYǚUGa; AfaP/;)%CNrg\(%ReD1&uyYA"TS6Qa4!,ə%ge6}}%ʞ%0g~?x/̓}Q[U>T;(t{09 n[]'1Mcr*I?nnt3ON3j׊Rrv endstream endobj 1296 0 obj <> stream xڝZKܸW4rIfħ6 A {tstKߞ*IImjǰ1MQ|YWEm~Mϛ?/b V||()f%|Ho|z=zY V J=ihz3g =Hr wSoЧw05 FCDSqM^X駯AЪ#|H~Om8xM^"*v+/6*0Nc3ЯSV}4ooק Cx_OBaeT ;1#iaA9PUQ=nF܆XViZGQ67N'kNwoS`VǥVh ~(]:P9m8v:^ǃ~tC% %hHCSx26ytmпS_1&i ^kxXܰr6ѴǺKxS=RvfelZ(&t%z{l\_@Ii]̲f7+cD hCh='.47jB =یދn3B<R, D"Yza*PJS7?t@σo 0(_OC5Z0nnF g GPj2= RKG9 B ڱ ۮ?{7姾{3w_j- ,P.}<u({R/xJ؛;;*=2!^O8:&: ]ct MԶޏ G M(ӱjO&0[#T]P݂␊ =Z˃CÊsrS_GDY߭$#5#.:nR_,(*yrK5l@<*Qobd<%|i_ٿ~\%h I$D7y!ɝXnj@Q%< ۟U`-Xd(;l|?݉@Caѫܢ+*NE VGi`4gҗz2ɳ;_ f|-(Oi2qXHVɽGs] T.?^ΓjW+)|ڀQOw4]^kb9",ST~O^WIfyrI/~z)Ku4^bX=! U\*+"0'z[1J͆A_c|2׮gv;)KL@dGoa r{U`CXg&11]L!O6^k,x0X&8}* U@)fZˏ]c}jz(5S&*ṭ3LX JּoF3F&#72W!ߺ} ;jkݦ _Ѕ0beʄ\Q@;K.eH%xb1Wѣ^Da~aJrbJG-_*.g#>]/N;WqDjzI/I}}zOC` c7XnS`.oeJ) ez82y\% +Tfw+s,(/x@XT*lc6jN^ z 9|2b${(3~ܶߡ9]̀MąWvqҾp$d=t%s @60tDc\7M@#o+ A,/zQܮ&]4*mk4~8!z;"Θ-*ɚ6p@x. b?<`@P߻=(|ޙAtU:A LR!Fzfk{\f]VIÔ?6r 8?y2 /}K2۾{BO+ٗ ݾnׇ fSUUD: ұ~ v*=OnͲOW6,MPӕ ~xLP>ǶɎ#L`}P>xOR Bx5@L;y[lR1mX)1EqMe:yRMwty,)qH ږ׮3 =%ery]!Z_nz))ϯ̥d\zN7yN'n78eիNFW B6w¤n owٗŠ0mz $"W3E6Mh 'o}y:p5pGEN亓u?`f:0B>zd2D)D҅QEC ?΅ endstream endobj 1299 0 obj <> stream xڽXKoFWV 7ME"遦V6THʉ?]e= ,Z$73:ᬄ8Ys~f_ *+mVb*Qf$%ͷ/޼})(y/ot? ЛkNGæ *oNogk+lJ6łR ),V0› ];ֺvC(2+DRkU{{C.v'w9ioF*$O3\]YOʼ247~5L)RDxhS0R/vK9"0b7/$GXw!ت^`!"̱}䧩o= Ej1Z4)"\ɰ DqdRGzl练ۦ8ILep|gjC \ У}\~B|jNϽbppI]zA!z+Nn4_c$X5)F/<֍1~E^߆R"a4c[ )Y]Y!:3ŽS F( 6fPx޷8R88x$p8.y쇹3YtsTq"02a_~vzJ8܎3WD\aXOLWo(s0m>=Xo,)n=QHRP02NSPs0 ?Hrtͬ3Ft^'fatyAUUi ?zo΄\^*pCFk?$ayI"f[6* wvn ؆ K(73N%?,2ӚLAP+Z`c/:؝p%s>5VXK- B˃ Ƣ]Q0]=/ɠ_h eH2)AN8߯Egޤ0 M v}lO: IF E6݃I4ITȅ ›)O&L8 k^ڴ-r d`8#*F`8t韦5d0JtDwUs޵dO>C:J 0 y4 L,7F-HM=iU1}wpJj;vd'ҟ⽹!xAx"I*y G!jd?ͼNa零y0UgP4g9\^BT^V:dʵnz*v0Z\5{/59R?irJP4jh^\6C7%T/&ԇt^@lb,}E 'z(Yd-]F24J|r4anf5Z$\NnT!|mphzf!}xs&>01'7;`W1`swTg2s8 j}/+hIV2$K֏n)b4?ފsY 1RXۇ&TViC ׸v,0ˑNX?2 xpp$6UϫZWjj=57b)f8*?8J5-U JD:<фOjY#M~#vts)k 99%Bc`?1"mҗ.w_j1x_wiml?L`9d'U@kW endstream endobj 1302 0 obj <> stream xYێ}W +ޥ$l oVC*)bjg*kfq ܔߒڰ@}! }>ɽ)lm=Hj{_9<ĽUv#@`>ڦ>^ }jX^ěpV*CPlfe|E-q"@uK~,]p y eHbcnMWs<pd-RwR nyCU 1HI9>$3{M=]N$R[ %l;7ɣ#Jrh\"3$HJ34^&yrJx Hr \3% /C۴@\Be@0 T9-o{wUI Rhu7>$e];EK.eH87IAE8U*I|K~ 9P50Ƥf+!L"xj*Hx+Jd.pWi\!W3"z4Wu4%k6IuϤ&27VVrƉQTZ]^Xp%'+HV51KjRV[*W}{WU>Xɚ1J!B٦LE3q?A1~i Z_ t?-$3T?|+o:zZ/ԃ \%ߴ11*I'3~uE UhosBs/TK3NpX'EE.}\lw=X퓿{ g(?8N~4r{C|VzyU(@:^&ſ8%;RGnKLpP $}%ɳP8$E6@jY i)Uu7XX_4KOX܁Ԑ k7 h),@3O|/ans]F*Y/\GM|zk?/\\EIkz _gii IpYOgܘT2*EKCrTv*Y])+zby=Gd2|靮>}q.B(*0,0Ԕ>xVvmwwS='*L oMaVL@3jUBVN(F$o~m^woB /PV"S&T +e2^ӉO4;u Mu$jx>pREI <<[EOq.Xװs'2S?!9!^R/8v>55 Z sХ@l.܈1, 7/t~e."ʼwugqY` ;/)#o©[z#n7(JFFsxew}lC@v^+Q8Z2/BmZAN];fÛ =7@+(cLzXK(V@DWY~qɴ"2 4 m;CdaSBJ|4KV'Zx*ƣI êvz41!K`L>3-> stream xڝZ[~ϯP%Z#nO61 eM!F;#]Xȯ9}ZC,jwH%4!&_TKPCBuByV Nn{k8˔gz͎s_v?"g3i5t2UfEE0"G iU&L2Bٺʹv󍤩߳O,W"-4[Qߵq$Ӧ[)0U9:&G˴4@"44!Fa.Bo綩W:+TupJF4Sw3eP 4$-}sG(0{@CWN0DfzyTegםwi~X z)H?kn5E$uVEfҾK@2;m ,g 62OTzNПV=ReG14rKA4c"J4gɮA293δɛwE`FDeDPBH/X>hL :ш/ƺRAW &SvM\;F3EQ9zC? cNz#h* 4,#6&৤ lbr#Ku;YVhœAp$uaQ kθDrnS+1B -mhSP!3:ذԻM"{hݦ} qMtkB͘[0# !SgtzF?] {;mS8hFdAѫl[!AVx\RD%epv,6c`2`_\iiz%"rkn1v2}XFkey%/*BAfI hz+z(1N#V0}nVX:P?w4"VW&`0 `r I"*g'pqa#P`i`b(L/+V:ߚ8ōҕ!IBZ4``2^;NCm>ک{\\ˣ;LO/8isЁZ~>X !!k|"'WQGd*얓|ՔS\!Z3 ;ɠdUx2ac"[` FP` k~nVE)Ҷ؆ރ7Px(ǣaa#,6w¦bvWPOƜc)yoYnbps-[uvȢ3T(P^W eޗ{@"w{~5YNL+Aj/pͺ$Y?^W&7Q6w6W~iS4kLX).}qyP A uodlu-8'$a:5&5{O\{t5)F@WEBeܻ>&ȮC]Ɍ.3cy\VDDkQ[bQW ͊ḮN,N?jl)⮈3 `p2u7ζgc?M=Bhm̎-63"s9N,ں ybT*t3K/vՆg)FarMCa*l>6e Ct c3 h/;V[cP=^\|c'a59p2A{]W=7.vĚIVWX/D*NlU8^ {Ad s]o'Lߣud}TDڕӱ*०=r{`iR$QӾ0DFE|8[IMB|=YjOвֵyaʙB8vvOW E4~hF |~08qQɣ!/ ?QbʞHD3q}[ƕ(6EjJI1L.WX!z.%xTe[Z8ga +fͮhrE$TijIuE~&`If>MCAC!Dy31l)!Q^'<Bh@F 14%qOnݴa.R NӨ*ն>O*Dn%hx8_̾Pq+ uOP27iGBl*%*? Zt q綩uXݟByssk?EQ#qp1"pEynmWX~}o͗Sh-}'*)D\C|P~;dƗI_eR Ln҃Ϻj7/ r5l0߲͡U4䶌*ە-Fٝ!^Ix.MtDJdni1f(94wSMҀYE12*xX؟Ŷ-ҡlZWq%42,]H(L]|3 :~qƀ_v@<ο';SVL_|4O|S'lj>' endstream endobj 1308 0 obj <> stream xڭX[o6~߯0 lo֢: eòƢcҾ^dɡt+XE#t](b[Z<-hN͂ I%UGj+yV}\ !WݾnW?.PS7rdWqJT­%J,+%3jYM>gs/?G[sͺ~AbEÝoPUYDϳެkSaəT`~)ic&+Vߚ( a |n+VfC a$/Y}ėՇ`yRd^2E"+`, "򩈒)M)"rvX#F&ę ;~|,)BIQ5~"hT2:h=dGIMa9 Qe\7w4D`DTٯOPntc{"k6apU^ }us&֝31ٲ;{Rpg õ 0^MdRab0}T$FS9Uy^)mJʳ0Jg,礠V [,aAkv:.ƱbҖ*,G$* ZHFⳠU*4̻1x].xoPuϭt*d1 uc1BڔA_.NϪ)$l3Dj'=>#8BH'<^.WTBS|?!iL7> ׉ 6vn "8y/wK芐kjGk )ݶX`p|iXsu~XܴzhiBD,UN$gjgArk-VcUidB.u}.fogbWd0}P8zmkop!WGZq8]+aos\ךշq^Վ)ssB SUBb_Dva\ms7uB|.cj9} :PD.6Jd~ouX=u~x9OO'Zm޼TF9b3eJ~ǬO 2 U.JIH\rħ5$qnV*ly^}^F?ׁDU}$=Fhh̍<~{}c̃0=&4k}Xո %Fm1 /S to_<6]sijf37|FN!N'' Gx8If^MBaxxuGSF _qdݱx2w%۸욕[> 8Džz}jB-J(]$^sTF\0EL5F=(4Img4hf Eru-;j OozWI~۷^HReRKWUtA8Eevx@?V=`gnL{jj^x*֪#x}Ƴ endstream endobj 1311 0 obj <> stream xڝZ˒+dWhMz7I<,ŲDI*)|Ń5ؒ]@Ľ88a mv_7_}EV&B)Ⴇ|Mn+Hfo[{: e}?޿w['jI;W Do,ҜI+HY*R}U'"Km S cPS߇'fG]Omס[%HA{6[fR-PaN[«zR*yU=T5UW_$M;k.?efnF,i %SsKݝb ֧L.0UߗOUtFBrqjGl%"e7i*&_}]ݻPUTdI 쫇Sԑ*5aK}<:2o垆CТnTūrZc߾vPuaC)NŪhڲrk4mTbtT?5#W {(5E>;u,ghA/Pܫ}'hMݾm'Goye ?me~{ac#n<9XKXuEomzړېSa-/$ b 1Kh,'nj*yҗ5CO8ͱyS1@~pm|:9|@@DȈb"sS{@qo.7p:#0 Q3EhP惆&S z!drjA9QJE*ǽ.j* \UV}iA`B;3F>MtzmmȟOhrOPad^!|3U- Fyҟ=[}tX*FP4]l>,FxۮV]Ʒǀ]WlXR28E9l[PRcp EBl-/w3l h<0xz9h[7"ٟ}Є6Ƨ+wQ4bdDqnI]-UkCQ;7='M$fd?#eqޤHy- 03#i+ac{GXwM:w}d2r!x9 ,-tqXS%=i>;uj.XXź78(J/ } GAx?'lu :[ӹK_;5WѺ*#-ލ#4rtVM+j'VcaFksqX!D YZhZ%UDʐ6;_֏cm-x.:4k-hg}RSvy5WҲ"ZbHwjYBj24=e8W''?T[6`% G}셰8p&"G %]5;ОYiѵGқc㧧bO<R2H#wbPT Kgɓw%Su!^᳏X,TRt ,u̔)]INQ-b`2OG4A] 8M\b5"\HlY|4> stream xڝZ[s~tDҤi3~@KtIx绋 R-'3!ow#6R?ٝ6|wbsF(tPLpUJֺxn0* 3Z)߻՜3$4?J.3|o:f0΅j C?*ńtmZw܌R0%e ed%fݝ,/w*p)j8AXe*g3mEWLVp,pylF,kra6!*LlцE sςLŸrAd$d\YzPӧJD<-.kYFƯU<_f%3& m(VU 1\PrK`تʙT#P)BOWK\œ~Id\K=C &u۷CSݖ1~;$s6%\'H0SsWC_:Fl&ĉॉCUק~ s-Nח_R'v[\}>aB?f>Y[@5k ,Ԍ9ɖi|XOi^8kp9L'|΂!`Ը2ZCw .qƶs^|E.t#ˊU{G!)dOh/H#bq @Ph#=Sň ͪHQL)V B2 )^nEϧ\BfV5v*+ #ӳ>))䱀 (+4S<0Na//dotNֆ-evz*0a pB8C|"X;oUU=/Ad>CLaO g_Aخoqאo Zgwz ڱv/0g-8.3xeq_m& cIf ^QjhA.l=01(r$ NYwTRI!`)m&,RyauݕR@RZ-* @ٴ5<~"_q|v~3ӼBRFe@n|8kUL9`vJT/-|m1ag#IJ(a se9c :㞖Пr$X\LK_aZʂh^qn(};8 @j(/j1o_ϟM9U ݃B]eFű, 0Rz ; RcB-q;b[$#h[ =$'S`bC)f_%?o{*"*[z?f^/3xxqqПAv hXC}s F]j!ߧT+c0ظ ɖ.<WXFr &|~%2|c|D@"In`CG7Ĩ,~(K,Yi1G ` 12câ\ k}C(\YBMV f2(`Tec*q[6%6XYEڌ1n+ɩ~vfIA\1r~=4-΁[+~`F7cvI1!CiPh2>9 S-3 )T3?^*E)y<_ރaj u@S N>/Ge)~a=\⦁.{+V媷oUc詁+ ߝjskdV_ˈvV-d@,͋>AI#r|Ѩ&,P QejVk_$ك~ŹV@ܿ܊]iD={ʇ/PWQ,U2We-؏OiРfQg :mU\.&88_K/> stream xڭZYo#7~_я0&{,fȌme #u;R cV>dA0WUBcOUݮUwJ2޿TJvK+5]mi?6Z)'3]JᘗUQy/k#Vp-Պq ƹHjuzl1ҫ6jSԸjޮ6}ɻ;R5fUSGǎf4åfhCiN'O,*!`ܯj34'jC6ݧ __?LϠt)k#TLC%X9քy|@RQڱG-Mɀ9&#8yz"1@W >V.i @T#rK-SN#,U:]s,Nhfk@ruGUٳ (ة8Ŕ8Qx$ Y++ϗ!a$C+\++ HZrj:B vE* % # y D!pUt݉ |H'0bUxG {M=4@j~0Oq9 J]cY G ~KOnc7ě9Ow>q9Ƹ 1GtFa}eH 'jl)mjv5=uo:w>` CYՇsEBt>(ᘅWb7Yčɉ@bʮr%h@=mMcr%"n[ 8j7>*XvOucť]vR+ʑd;RJ~j)^r1{ؖ8>p'ِ1j+W۵43_0T/oD(( ˧:NhdNѾ @Co n0@HiIxY4CgxޕJui!Ib@ى B3xulݎe7XyutUC3 W>hn.@y=c M(`H9Vr4#'*ƶ??<AջC3LjmM &SFx$PU7Ax\̹O &)E 3*p@Cj-2@Gd))<dž\s≏RZd,0$o| Bʾܯ>{!#.B%AO4ʣO{SMN13!,]T+P}J @W2tOpYxXk`yWӌ6Ӽ 9-f-$)zlȳcnjY^[( B $QHt*'Pxio$+ IHs,! #@@3@j|mTjzLtf>n&Nip#N`R__;L0Δ 9h8_M]UU:‰,1ϕqPU#!,&q8*;A ix5o&v'\ f%8y!CP㯛mߢ^pkf 1;Ìg 6 ,x )ezf2)A[!Z$!6[xL':PLk:Ch`f q"rK4;DnhMi2:}d#gh,QKJE$zx"USvd,~ k$`UŊ9 ￯]y*56Fi{l4n8Z{eneR@DȒêkex4VN%&`NUhElyY?.o/=/~i#sJG WH 9/?y endstream endobj 1320 0 obj <> stream xڥY[ۺ~0$GL) <#LsP)'TR7kr:-yNQ+<8>vݐ^+hɢ/5~`5DsDJ"ti~gT4 M_qswS_>)! m34㥺jJ$ *3nC8E" JzG)@{?+Öp|rʄ:O)' Bz 3oUALg|LhN*WR'mH!'m] Ih'S% ̙ ] `؞;@h;pP{3Vo_>=>O$'L'F&4vBaQUZ C?mS7c{OUIiEK&9e'22,|)0oK)38TTW!0aT(d(94;. 2dsV9Ur97@]w&ZQKyXE@3hC8eAl_isRĤot+V'vnll&J(%%52( ؄p{c4ƽWJKƨ"Rm /IR/mH<\;P:ʄa00"a 4$E$k-k@r@iގ5v.j/.-fJ)'QQsw D rkc0~(HT̕7\P#&R3J`wyOCOF<9G\p&gɕ!b}oe9MZ\! tU9zd 1d~^7V}{~kȠ*&HjSMy%.4A8"UW faC*'j rA'Xǔ,xN8irmm*AKI~T Щ}X NP ׯ.rc5a Q4O4*%:Y5^ 0Hk2?Dz0@.'H}L,}͐fyfg'LkD9?P+ߓϙhӶ5XoXqm9p+CJq6WP~xYwH@3;qb е!f@sZEf~ $$s =P3pc'~7hp3ޝ,E+3@Ve{x?Ջ"zן.}oLax=mW[8Xf 4V%lX5.vbE#cH6,)4Ve~pNJ^l% /AAGݹ gpӝ 좄/zE}_F3f*q8K뽲 %ҘVE0٥ l C2!}S wTx ϼ/z{_5>:r-~zD#.˯c߷є*k/oj/߿{v돻-8[#`$?8R! {GH\SȜ_=pE Ϟ4R&gN0دP I:cmpхB4%*K%{2#/&, ]1 U G21&?rArn?:_UAxnԄ~"t}UIJr汝!_ hМ¨`lU7Xz^i\`m> !3Q뙴.WꩤEFjoco{P0[n$@ -w(<_@ i7E7HtS7m's&4>;*znD endstream endobj 1323 0 obj <> stream xYK۸WHXI998-WR;l( cqC ̿O7@#ٛKjJh[.?K'lG%=>QN2wǏj/;ISoշ~isΣ>ş?-5sSZD?]LGp6QowȈn~.I,K-Fǡ0z~<}ye\"R(#IBe/id,%RxzRz<:΄$P~"J<$H0%u p-&5 ˲Ȯ5unTcqJec,4i[qȕ&G4+r"߫hjA0'S(>$ ɀ>I ΀ iPQC5)UyR DvW*P^Sޅ0J̼ߊ1.&~T5N(Lוj~pR|\xS$e`(1墲<_*h'0s}K!9Xhk -ܴT|E &'0KaMW Kx˔SY왊NU1N I"ׁ7NqMNBNwg$~nF]O=uT(!p5`|&DКwXz]&t'רzQB̠8JP`U z~%S]FaŠ 4c<>[$_*= \*K3G, 5ݟˮ&d-x\ʙN#+ͭ<|AfL> 4]іPL<ɫ_'(ImӁO:4~:WʶOXd1#-tHӠ S@oy=eC0*?cRk%-Y @4ovB;mCBkIĽ1TA?JIWS~h>ͬj8b^&<݆"K͟DN"gk1W|[[yJ4r:lPAɅcc%JJS"~z/ĺ^gg8ꬌMg GӮXէ|z?Awۯcn\`.7PmG)Mc>~WRuՕt R `UV|~p_/&$bL)֙7#/zڞ1jYCӛy桘 A74Y`ts_R96NJR&J3 q4QL(N?JzDa 휼#XaGe7W%H<ZHacގldsA&e~1TQOzww1 endstream endobj 1326 0 obj <> stream xY[oܸ~ﯘ@+^DJSvEb,u5Dx_sxHdsEEc;;7fuw);#/Uow}/v,ꜙ𢯐j#T(rnSnʮ. ef_oxj[5#2ARH *zX(J9 Þhdq_VML@H֗SLN"LZ9,5/f4 4$Gn9!ΒTZ3vEeiEzlƃ+D![S[1!Ys{Τ%i⾣SumuC?w9C?5ЌQUq4`Mw7pIFěA;*AyIj̑f~ou#2l 4:S1}Nt8 fs?Zr$h7!3][Ќ?..ѳZZMbKm]d }먇Ug0`ihX[yd^#G @U;!D!1j,qۿi$%KrRǶc]ei_qz>Q/I%)L)`x" =+ tVJ ~kj'ihCO`$p9d9>bdŕfVVMWsMLJoeLjZ3.xLRrG!'qK,Ai E*5 ;EpqZn :.FVPGnkgYmpʦYFİHE'm4ϑPqQ,76NϖM/qXr]ݵOY"rAv!ur-/Xlj|kWz:zBC*@*İ@ l)^G&u%,)5.JnkHr~ e-q҅0W4EȯԿdFC9(H=c#xtp&y/8/BO_:G.f r˼V h ։Jǎւ Aej 4PP4.+#0@9ؔOS.BPlvt:ԠvQz( !} ,_zdc.n乐ږ°9?`5ȦsVu2frk[Y~!aJq)rr?wՊ%`ȗ_IF2 0U`=x>cصlׇV殶D:vkv(',_O8_O働ӂ<ʟAk"v@` endstream endobj 1329 0 obj <> stream xYKW̑~w7GG fp ɑ@~|_\Nsr]۬W\d(ǫj꛷tE0*pAVVDC׫͇3e)mwcYn_<nSUǽiTe[b7ð:@pW:fi}m7 Yuc[u~ bDx$cNK!1AHpZɺvS[aQNW2LA\Ӳ A@hP$[#8s<=_?qsp)_a"NyX2> ?ٕ!Ng+.hԮBnĵ~iqT".ID",I<ߍ=G5&)KN}o!"t ߘEz3Mٻ_xG߸K3,aD06$]t?c x@a|.?!2+ZDPrѿuOЛCo/~/=ڻ6!=!%ND!O0@vI`Í%?q rYU5ͫ1 L}GJk1 s۵'/3K?4+30RA@ܨB::i 0B. BJ61Ωc?ʾ.$s|ų^Yȑ_ QZ 5j} ^̱=\BYґTX+ .D"̯.]*r࿖%: 0x/#Kgo M4P.LY =LE"̶%)Fc/yXbZ~ˊ xk6P$edǝ׍L:. ‚0޿@qT,<ٛ'<F gl\T@0j )RJ% KGMkE!H(5.VsTr1䀹4T}k#yUX*`ld7/$(V^Ot.? 7l }pf2qʭIB0PTYjm;};( {f8{CL@zUP[ar_zSxKX͕H"N(D᪘uwRܘ*SPժ5-C:Я\3QtL )c)] ~\ *%oH r>5"2:%AHI#JG4K&ZnF7/W8GcX"F#@0"jR@Lȁl}/Ʌh#Y"]yF| nvuйpkU ݗ<'zۖMzR4,]X&6=6$aQA[0Sy!*dysG]A2&QID׮d2,wz;Y;8&_v9ꢟI\PrKHa b endstream endobj 1332 0 obj <> stream xڵZKW!e?IzO/ dGFL$R&ǧI#9ƈ"]է_2a/bSV_=V<_q eFJoTsn~+537`9Wa9T9M,4vUjyzzơ4LMX*x#s W2)Ȓ/k'%B+fO n#.=SS jʂq?]Tmv^21sPz z !J KA[?ZBLC_p#'ЕdRs[2Ϙi n\O˔~iH,2& K)$+q|ly|D໙  rUuQel J~Q Kj񡓺'Jx`MMՕ J6M104f°H3Vl&ϙN>_Nչjf_],U[plFKN STpkRw;O>]$O}[\L_x<]_tp`8/o|S "F*m<آ30ȣu}X8Xd M|&[蒩YJ`!sdjW^{a ]UFmJL(/ 5TL^xDPdD̚<+C'\^p?+3Iʄdz{"k.#M4K#\ʡf|t JЊGt"^(2HEfiFUr <2i^uEݙe2CǶSx&lWl_ϊEyڅuT 5iv,U lxt _2:[$'l,j:MxI<ۂChq)+m&\V#܅b %9˸&0Wl*8_1IJ3] G!ir=rzMQ{ګw7'P5~\0 l%{*rj[g k_ěCYs+;i^A$kh%XցP?K#,`3*RxXSW=Gۛ{wLK1.Oe0;?BI4pߴf,_:\dFwp>4 c>kGa{ҧÂANsfҀNB3ye!syH,VVzX5)!LKRX/u QB0yufC/cs+ FBݛbh;[dt+Ѳy>uz&OUfʶ ]+Qq?Mn/} ,Ŗ,ο^3/CɆ*>~R6K(0# z N j%123c1m\EJ<O4Fy wj1W?S7=A{tIy],z8W_:+6[Ƽҵd ٪@H_isZ!E+X9DFj<[(*Y搾 ;FMv2\6{vSXzc>ͩ򩪃[ͪ?k\ O ͯ1դsQl(bc5R'!F燈.vTnDrcBKɠ[_wR2ɹBn6ѓzz+k9SD>]IIg ੁ d{x,IͪBKbɂX¡mq6蘏^U=Ɇw > stream xX[oH~_a;b+Т҅6]N"ܮԧCra! 0SfvTUGGI`[;2Z;e_h6ڵ5o !QM-qVWJIdll$J@|e2I<5I֤uJzיaуl#'b)4];YTɍ:m,zs8 n!BЁݐLO9ϏGoP| G@PF[. !R,h M/ʲ(01eɸ'oKxlrz:y'|TTuT=Ū@ƻ'ij,0"[ܘe Bv!+Jzp\~bOZwB̛ җ$onٗ&m2olϽ-#J8*G3#^q'uH\vsXlԪ޺'p9Lfp Y g˓Ku=.Rz[fAwwHn%'  tZSTCêΙ)D4ذW+bJ.(~ X/ k%j=!E\o # (!3ba8UgH=n_IՐ-GǍ4|DBΙIZ`\f0bT7y,rҘ\dHG< l/<ʩc ! \EbHS [@vM] eO`=ifI4MS{xl\~zEw π-/E.(MT,E)NX2f19 nr8)jQmٝt 0tTPD.D)g ջ\JEĆLû]غ&ԔlЭlnG+V)3}\DUQS qG[ Vi̻JmLuY4iX½zp a _! 9 [Pb%ݐ бySoךhUFE$ȃ$՝ e@+-lzA<-:4Tˆt\" -ٍxYEHinG RDJZj)[XQ7ri TPS)ⱨ_ˤߪba jhXuIRo}HGJRn0Dȇ/Blݷ ~ endstream endobj 1338 0 obj <> stream xXYoF~ RZs'50(y@K+0;{QL;q@m{=]zKb=;( f+a(7[~?V֓1'S3V2kl&f 1~Z.M>X)yt:7*phpf1 QFLp1vfrC6EU=MD(!vUrHRF[҅˨1ţZKJ7ykFzB,"+&+ֹ 14$iFB0fQgkeEd~Oc Wr PWD(j {_}'͘8F1O:!xhmcg0t.V. D82["bCD軅2tɓ53&*4˽1"D3_U_d盋 " @(B,t;Z xՂ;40"!Q|YM0J% q* P$%B3r!)%1ighĸd;^;~fh5v֖M6k}[4Lq)OzgjTc'75UgV4xrp8{s5z+

ftb粞'\@KKgw\Q*+?hǑbF&uOW\ޗNΎL2>xQanbmK8B~6^ _TӪu Ckop# !Jl;=. Y6ҝ\ZKw1"4+vt<.=믞P-L'X /x-jrcP=!S\>"\z{z8_n5p*b!Tkj,ҶOJ >3HgVQH# ?^ gPqͽhO+H? H endstream endobj 1341 0 obj <> stream xn=_1؇0i kg7d$P aSG7#s$pl4?h¿hzbXEaYYE*ASJ_e%Dm}/fË?/^u6V_~ϻk_^1֦YrNڏ4*^* Hk?҉򢳵~75ZeBhhS>` Ub u e3މ~rt|m @-/T B{^n #i?;w\8MĒ+ ^G^eނQŁMہE ; &d!S@U m)m7 /ox?'ݭS tQIG׀K_ Bv1X;=AAUzm>߾h#FƔиSx!NfJm`k:>pÐhfQ\/ P Ww6imT`[&n+Lz%:UU,#T?^w&෍ߗ&O?9gHy]tZ .ۛ%tIm-lۯ`(8@$3>Y`PCS.ǥdc<."4LBE>djX,H ڰؚvXB-@et2. eIKh}yC;^ 2HXPdO/9>m̻EfY~.rKȲ@N{ptjoo8 t6xC8?rl -SlIEߌï+>}EB@?rG81SKp:P2N4 eٲH!krKl; ėEf"Sŧ,Mlq22WOdg-\9K^ R`=V'>&*V}g,=M)A;c \ Wyhv (OrB"2Y%L%y[SUze ݔksUWܑԾk>O=Б5Vܹ@]CHu;j +][/tX1>f D?V^d~%oAbZvR)Xkjھ/+\~S)AS1(vͼ>jsx8pOtە}c{^lwM.t1Ww3R hn9kZ@X&JH_yWkEj da?;@pzv,Yڶ0M;V핇X}3 2S5(+lK9Am߈*Ϩ OaM˿dQs b%@Lɾ еCeU14"73.dA;tsB]Bۑ6u9Ӟ qe-?fQ%Mgw;p[d)D'>Ƌwvxz (ajTf7w7wHb$o%v̻*XX6s gPH8ۗ4HXgzmçH{to { wgǵU9[M#5daEL>r5K6{fyZ!C9| n yr #ٔŀɔwk{ 𡤄K4 قnٛD2Y2ђ#æqO8T'suHZc?@nBEV`NH$xaQs>=$J=cO:ճP(1vЊi58;X *k3{'@9M0tsvܦk[GCJ~ʱ4zt 2dk0rvI T<2ӥyN9q|bP4KM ŘE*C1?v_A.~0JU lq9T M`MY-ֵ"/$#k f j4OLޒ B5{O CѼЏ yuwX6+};w_@; pLܔ fBY{cOPn7Z?qɗzr4xjYE I#stu%z>V34OguVS0?qvb?ėA endstream endobj 1344 0 obj <> stream xWYoF~ P@výx'vm PWkTx81`wHr\E!Ԓs~3 }x[w 'AB#GNx-?tzc~2!ι*ͫD`Yip72]e9)e/e25[-> &@i몶rQ2 L~F#_u@Ї{_ݩr̙:8aJVZY1 N`.L7e;e1|y-ҶMF`!3 _46|KKF\w1 `%eݦ-~*oJb,. .ke21} b0cl2۴ l`Ns u_In.hq4VGQJ^ΦGFlT\Q\utym^H$|SE^nST9U-;_Ps zm<^k;6_tit( l: l4V );m/~]YaVTHI̱S(OR˶u]3dzER*5Ce!4{̱$@KJ>7G8:MbbFuԼaʌŁa;Y(|Hxokx/K5ūz͖Q뫋_ܜ_,x#d2֩f3? "i $p"]e*ۮų^zn+;y Iudua^RkE)*ݭ`B>7K`EöFe9Et$9nc\S fՁTtw4 B ;k'(háCi;nl4}eRa?~E~&>L&H5mGyXdjgL@' *B^=&&uUqa9=;E"Du\ײ"xߖ(#|R0J5^|B}յE /y>7d7 endstream endobj 1347 0 obj <> stream xV]o0}߯xXC%UH`զҀ>>0-4 *U9 [RL{ǾW{Ґf/,~6i=+֐=CZo!WCzFiw  ][B^lY660˷׼ 3ʚ+t Bl0="3jd{&}BgU%` %1U 06!&r@" `K}D 7 I1QO($Δ/ S@X#ź)e82M޷T!z."V3,(H18k҂w)Ka~rX٤@9]^/a#jZ"nkcy D &fk"w_x(X~ޑ7`>R!|d lE%m:2gzۇI^tkٜU;]+tHEuCx E{iۋMlwTԫR,XM V|%~@+u;ʶW^~tV?, Bm\JЮ{ȕisenx[!Nz'sJ!b(a{w =jYܯ@lifiR5 Թu(OFn~lY(34bB9/t&Z`6ſҞ,=I±E=oOՓ=l1XUo]6 v*2doN*{rخpxL+n07-X(πS_Ei/UhQu endstream endobj 1350 0 obj <> stream xWmOF_a݇f\j;,±sw! W:ppfggyvs@~HR"8{4 1ˀȀ0qgg|٩&B0EsYuFNNX ΅yw6݂iF3, 7e,.B=8]*Oneݛjfl#Y UggmayȜQ4BeQ)mh `yۮL@Ƣn?B$4j%n…ypz~pщK.{\('y8{ N5}_L/n^XՍ*g5YhZW]Q\ݻ-ůxw *0SĖ>њRC})qHiCRL$y-yXݒgjRt1ﺫܥ-ըuOgGtώ:$8%pcƩ1=8 rv4rkanlޙ@ۼFub^e &8NkmZwb~h۹%PYI؛0 Sle[3Igr c lܫj#^Bo<ȱ9ϋQeLbn:s<)gYXܬx8e̾w)N43w>RG} ^}#udw 'IOX,K- ى?4!S1h@NC7_/$SjNeC ӛ/bm9 { ;HSġ@JEM] ;ٹo_mqOz(;IՈ >bCE`Z7749<0_X:8* ji孝sK:!V\&FCCF]ٌ@6}Կk̳Fd߰nfzZ?AͫQC s٣unfY=)LӦ3fS|tU)[!2/[ }y$:+"` $ZKZ*JFðvrE(cfaҗ*UO;o1r qJघ’ $.ާNf\h/s#φO`Nr]ύ_ɡ"~Q79\lGoB endstream endobj 1353 0 obj <> stream xڽXmoܸ_H>D[D:;۫ڛrm!Zi\wCs!Fpf3C>͂Yϟe_ޱY{z${Hf/?f3/9|'WssrE]|jJ Ǽi5wYdFs;û7aoڵ"@NUͫ|% 37sJ59FSyz"S^a<"~F4Qž*6L9t;Lک2 DdӆoVgՔ@ň'"'s QX=c8z# rAA7B5@a8Bz};S |_18Kl`Fxc>TS\b\ҝq0x8;k Ŋ<MmC;TsZQ(En']yו+R"t$ i1s"Q>t*C"W5pPN5NU55[y3i[^̅|ݚleG^ nHIM[[B?`A4UW -_d)2M7E䪿gфnj&\>:U)%!b{Xz!FHnvsX.,8?/0250SX5zm29UbR\ȧTBInʈ?aڮˠ<>jpd7]N *"&ŭsU2ܞ>Xިf @ӵA 'H# 3QBc"B] ;6l`{Ĕu x`xkP"K!)m13Ux c hh$i2F\.hˆQU4.`lbp[ftxʪ2.CATj8]BXQձ1A\w,qJ "n@ 4<<\ʬo>Z$qAϽ^K_>"8xuu~o+4ě3)A-dC#b2~}/fEndž1H!TO]NO3F4NC6c@d49ؚ"$tq]dDB.}{1}BoI=ޅƯ|,qoٽT+dy&5 d ~ʺ~(r9D&-PD|J@Ȼ_O./˳S#`/UgCVM^QvF?D9gȠG^߿sGM"̰=9zća,j 1~2rekT􄝼lZ%W޴H63/ P듫 T(t)y |JO܊nsq!wgwr((, 5Ln` *~엯`V#|qO˗fUW_E(o VKV}C}'n&o]O^qbH}PXfzJǒ[dzu&X9$Ɔ$P>72+RrY:AfrO endstream endobj 1356 0 obj <> stream xWmoH~Kp/lXHi8L?Ցʋ e=T4:% yggvg6l'oxg6m)ggrn+Q,JGc̼̳(<+Gw_r xvZ8|aVF,X~+FC3 S=aaOy" >gymwI2GMU^Ag i˖.Naj|7G @13>*z$]*=m.kQha̿f$<*sߐ+Yr.U>-s wƔ"[-13O`q&H0jDή޲:7GCOH#" :H&4hGX R\??,l3ߜE^q +^LNOKM>+5c\/󬊳Б,_NO&`߅.ž=ʀMU Ļg&̶֪b=* qW&JQ^7iϷjo"yT+حϕRKwp_C6mV;[h!cU.E+ސeȟF"CGoy*M_0/nn?M]ۛIGK4葜yO"q,sn!]8)E6׽fU^RR'컪"ʕ( ɕRV#cr$MΞ]ca:,@V +>ۘeUC(]dH xqBBlK p4;+Ϭ2^gaRȀ}'NH5ְ={FJH=v3!ˆwY$@ ޘlkxGCP$OKʻS b("6 JNׁxTp'wy%,1e! \MF͍fK%Ca<Nn3pn> stream xYK6WE%-ϢEȶ=$9h%jK!YPޤ(ZRci8faEV#+IgWǯ`┬6+VU6\_")|mO_q3Ƣ*׿p+e{t:*TF1al-J8j@T(TߢY_MYv)fS&RUx3 O¾BySͶcli(W;_JfD:d$e>bDT+x&dFBb1 /`.|5-r[e{]6t *UH^|)D԰Lt@ǝ!@RD8 &Lj6K5[%?.}xܗQN;om*7޴Dԡ T N3NDШ G7ketYduJ#o{[FwYݜ3`μJ%!p R RCmtۅcd`K@~#uzCtb4xtS\hpBH$yx2ujq}@9&YϑR )<0,l= &&l:疻b+ ) }`B X–̽9SAe`G6]PzO3SdEv#/~gh{0ٳMޡs6:3 Y\ 2TIajU.*Y' EU#[RD)kNjK̄@Sp5'Qe>y!,J0(0=-q%Uݹ65Dby}0.+KζG q84L=7?aͶf; BHuMwv?mYmx!A)g(!*>k1n 9"+Õajϴ]S`.3R ܻץ0X4z H}_}E&2:d9J۴םRXض0b_v&Qˍ۹RWyݻ75mьLnE4O~Bͳr3>9 s+ӦYh~9ol0)0 ÝXhж ӟАastijcǠbx=1AKT9oZWn} t޵6['Cc]K6 ӣRA|V {v^N|wzzD,o zёj"C7&/2Ϟ#ie[1UxeTף HηW^ Uğ+nonhmiKru}* } A̅PH@b,_uj7 endstream endobj 1362 0 obj <> stream xڽW[o6~߯6`EJ)Kh>(c %OtqE!DS<|#^!zZy/ބ p[y$)KU?fV D)ӗ Ϫ2/ڢ*ŧ#i c}HEj=XעYAzHM nuZ3 ϽhѺ/ؿ-L"QUp^(Kw5BmM)~zO+Uˢԯo#w+I |0i?s,֭1o-5E -dEb[EEDlkܹpnŚh۝Gv0C.4+y6 pyhu'Zȧ AS$ @O?ub8TLq _(G7|2|~hbʳ;U^"M oNk+N<R}M,-A+]1NVFY_{ ^P`s}0 PkCvz8FAYԋj ױtwzyy./^/WV"Р(:`''HM%:RVu}_ޞ_ӫ:z }Q,\6l Ԯet K=5\.*wʍ,!;&nQ~{6߂/Iq endstream endobj 1365 0 obj <> stream xڽXKoFWT`n/.[$Mhad@kD\*;Hye؀y73=óLOfvv1{p$dz g3LQβ٢O_%H o7Wן14*.~..mEkyLoe3'" ue,Gf2*ۦZGFm]\tuʾ.cumP33 K掘WMΊx2qƖxwvT!s6dW7+MxvvQj5l24 &1plr$^Fm/GLshJxhFY1KZ|5(KAVA{Nu-YnP#3+ `1MMi!!n(oN:\ Z$ɐ‘UI0Źvqur2rڍjmj?)j2g܁n:[ُ0iԻY G^TTÜ{xT <$,@4#y&9&!Q@@%TfB]Gp}{8E"ez]l~G<ӅO61(N4y0}cNްiW<$<Sl(N_MX?et4LbPayɄi %oNKb3 剪ͦ Eʦ j{~>"߱ZS|ޱ;S6Mi|l%61YӺK#(`&q6/XBa㓼xfOUBs3Lau#H,, Voܽ_?W1 endstream endobj 1368 0 obj <> stream xXmOF_aqRq$EU+:h+Y jlGRYmamNW)<ѧD>$J)h~ޞш`&mDTD\EW>T$XOy|jկ'I&A=߾=#VVmJ%\#Ex-{i hNynY97G I 7"QN۷빙bf%’4T7bYd* Mȗ7Go;($N#F$bFZ|۬ۮ Ɩp qBEDO!i<#5GCgКȓY"c<:CgT39<`Ltd5>t9QA*@&`\\"Dp: HX: *e+PT+ xU))^3ܳvɷƧM1Y>cFMl="kY->螟n-}d!`E,pm(0qcUP~S8iw,| AE w[ %^*(t?VH-h%)JDH$# +\UHЛvK(A<7Xll:G '4Å4v2M_b'XT~@ ]l96fݕMaT<3Xwr30XH-$m1Aђl'~ߕ]?rYRyJU(BJ!+B>3L))ٍ>[G[ yսB(*`ӯXv&๟3˅5q(^ƥ>E9/Wr_= vsQw˃ Gஜtb? P,@kPsR&=6n_P18Pbi 9Kp5}Q$WkB|, W/ʬ3)i.'/offS7N9Ј VY=۽b>3+֎j0'CӠ4g<0]3WXh;mץ X-zA0A\FBzd= CDeއC@.8S4R HvkV2K 2'I 1"^"1>K[%kJm UU x|b(s_g'h_;΃lu=0hyQ< Sqc0eOk)ܤ];Vm5{Ubʒ endstream endobj 1371 0 obj <> stream xXYo6~m`1"EC'6E]@|gHJ-PÙooB^76v齾` If[q;@xL[5{eԌMe6yIx0>0v[w7>)C+UPF(c]#P}`"ʢd<6.fM桡z^љ ?-LhHH -'ڌpР+;'PDt)ɴӡFt;VVt貗eKR *C,~xJsʅQ2B¬rtN`?^Ӯo`L,Jt(nH2E Jc[t,YZO }z@1>lnphLxFaGmzzA$FJw9F=h!a.2 B!Q OV -R+p{۾ϯ qg>j?Ĭ|Wyx}g0r2lّ[ MSHPke5b̄/yO,\1qKi+sp5Iِp?zD1ܢ)'- u MFCMAכ6/f4x( A?l)g>ar+oWF_fmmVwzaޢ6:填եm0;U0{P:}wup-XLԼ2+-S 7M]J(v5Llۚc^/Z$odu<#SxS;BImqr+,aFT8$gQm/09 zoUi q>inܩg;ZX]efw@Ld8ԧd8q $%um)/̷O@} endstream endobj 1374 0 obj <> stream xY[o~?Bh*/V\"%*@nŶ=ӗMu"K.IwYҎӗ(7L[@ c?Ve4&y`yPЄ\rSz.$Ibq˦^}fC id\E}wEQP rQlfE<'r=+CAE;d<1;Fpy47ʷ$γSnzE5 DJa;é§YB(Mħ¢kCIv[؞1Jgâ'W0"|#NNݔ*rS63"$kGqpն v'<;rG;䈥&s磓cAPkbF0H' %t yNIR y1 Yy[ Uoƣy H$aUϋH0~նxPd?Dg 9g6l]/|JnE͇3$a-@^ps|LAGTJFw w D8'O T7U׌}nmUAͺ7>$qJt$d0@qPuLy>2e+p,A1C3D!'ԏ_{qYIƳ # 2p0NO{L2. YuwAp3knJURfeן.'1.c$ygRl92WN&8W Njc-;**Qx&rC&NuԔI٥LCĻzת}UKÌ#~Y겥W$S'oum+ېecިZ=l0?_`UfiZ]9c8ginSs#.f;%*WMwCB}e? .h#MP{905e(c7'*Z^Aj'Q֏Dǔ2'}l+,1 OC)}S." >4.$O'dkTg|2X{ͦ_PM`q/wZbFx^7D< cz{A6r#]Dr39h|DB0tN|j]>5qr6͒pToweǠ- 8^?v`it/홨sQswb?N0Lbvk粌3')ӆtUT41(Deqií}tY]_V1 BcI6mqƓ8 : }eA [brg?`2DVb\D襘$+ax6`BӅ <;+ElNdy$#9mq &3z\H0xb2 }" eI͞G$I!{m5rzFnQۘ{)X̋#cIr.M*B8N36oS%4}=޶G{S|Yvh[+bDA`z5ެʮ(*{MOuw׫ ]ŦzX X ;SS WDl9KGy{}Ϟh%ǂe3&rBҴ63w`᭹7egFO2=i?=oҠ}N U:܀+;KCszXnVЯ _G ((y `> z;)5?U7"rӏeΌ> stream xX[o6~߯EĊ7QCMlE5l3tIo9$H.mah_>*3A h2x5^$3Lx1R> gD)(✇jf/>Xu\+Er4K163bNJ$2Rad]3 <ObiW<"H¹9|'|E}N M%I6v5HJi8'Zc'PfDU𱧌PFݞ#p]*_ZMa<NYQOKi9ΜQtL T$R) 8 ug!`g6{^<R 4ÏQ(s{HJ$M!q6^j]'ܘ6'Na +=q .# 3ER uUէ#[E|}<J&w*ȿA}y9Ŏ|!M*t R%M>#or(I A3€E2a UFJ{'ǍN[{ԣ\:~,/z.%tZM4I2Oo T$0MJ׍9I,ynqf4iJGsW#_;ffc?Olq践C ~V?N$;OXB*w!Xx*GXLJX+tɈ jf`D"kEcEE_c"E3Fe4ΪHHyD3أR ="=Nޒw"x/o~I8} .H7W'`_u4v7V)~w.KJ@kSiτC9GqA[ p{#%R*[ĠkŃ] LZ0e6b+A˓=}epKDx_47eBBXXϹa`k~˺.&ŢhzYtlIKDc( ^82ΧȿеMh}9BŽ4[ IoCP__0y-v&ƈtQF)ڒ p$tq ^Ao@?y1PRZ^X_#A3@I['{mrEkm؅ td?zos3Ɏ n'wLk3oXnLw&I2^4tmy%HJ,`|&j}ǕZH*w~q=&tϫI&g-ROc# ar}خ:$,Uxϓ7 þE4Yɯ4گ ?;>..hVCI8~b|~.KX<85VY]Ntu<([N\ZexrmӋz鵌p FG0?3 '4mGoLv#v}m `L']!)o񯎺d; |%rqK%kO endstream endobj 1380 0 obj <> stream xڥXo8BCOޫD}` L,T\INf,t␢pf8a%bQ,*8ˢ>z{G,Kˬd]tDZJl?va4*B*Rv[uO7$Si.r;R42lO2LhkG/bdQ 7gGaBlWqss wwvnӏu{oF?H]__kɑ8\Y9?w}yv$j8S4-P y(㡾oO]?p;9?-qFAv![e/Zd*vDlwR #yqԜ`G'duNUeM5:P2Ȱ61Ubjw))dS nWg)faZ?}W)p@d-WT5.P6}&)8_&Ԧ;6ۀ)lgXc<{  C󯺃WNsWoqze?_fQWzHo/f"zd^TUTf,Ϧr;D~pM. iNy]2P$(LՏ^Nx['l +'-Dg7fkv?YnmݬWsrBkHgD0p_ft쟝vE,Ѕס:Ý{t& & R,[ً2͋˔\Q9_VLv?kU r'/A3e;1(q9S?'Z[~eepm5ՓyfSܢT'Y^NRL Fk^t`hp-z2 K);;FĹk!x3}S.GH_RzʩM\GTpGiN aJĠYrP6 6Ъ`XNTZtn~k2H2e0 5l0}fwu(72\2Ϲ;X;H|Yٿܺ~[4XoyT w/bP gH5Ty~o8Bhں$ ]jzv켅;@;^[ei1=f<H\rdΚ|YH /?=kHgǂǦv;VJoW~d?<6[7~=B`#8‘3^3M{zs޵-oc%'f"F?u endstream endobj 1383 0 obj <> stream xXn6}W.HNĈy(`'u f>d k^Zq|{g4Vr  ȹp'$~;+px jea60!K qמ/tzCNz5C=+"u~jO$n7H}~%}DLÌ<tݺy~$B8ܒhRtYv 3p#i}MGՐ[zSvia|OE~h*wF>,BX2ⷺ6٧﮴VO2*ՍVF]L ö'Sd0[ݳ܎h5G8׮jmp9H%\75agZR8t> wZߞ? їNNeݩ&/NUG662K~d5H'Ֆ{AHYJf,[+sV Ƞ5JBO{Cu\oԡ uҿ}'ˆMu}S/MYiJ*WECnTC\A-UnDkNv7Tdnږ3 _}A]>,S.' L1g#) XƎτ$2#oH:8Β 5R&~y|œ _yqYPz;NJėSH"(t "Ga|-eM=GZv@LXo R>-;:قc+mXi>`B#PK f&BSa9'Y6hӈq9 Qϯ^hMda:_ [z(;3i)OtJқA 5KQ$]ըoZd RCWǻ8[LKطA0P mWDq} I6/ʪ `L`{~ݨ׵ߖ7u^l/v)JC@%1aPIvÉ4(q1 p(0S:/t0BKHI&2K ~=ee"A+̖T[4%Ro%g2(ٗ,`̶S'o%L$SN.S_"}[ZkBt9]y+4l' ZX3,73edMHf%HHryVLfcux8Er>7dѲq`*þ:k_䱫D>PU |:46prpl&(t~c٢Px/>u$q^s lwbWjOV^#Yb `Nj$CM C߯dĢd b^?CC_%sZͷ%ήh(2D{ ȭ@"Q$lzC:D_,`֖$e@aߩڟ endstream endobj 1386 0 obj <> stream xXo6_u?$RA![n=4ye&&K$3?~GX!M0$(xG{y zes{y4$IPo|QQN8KGOG?iUٌ.?yF$1h6+D$w( AQtRHn 1TBnMjTeWeZ4{nas!LGG3!!{+PNdQցnFAL77q&ؘڿyYUuUwUW߾8qQIh|?΁hgǿ(8:=psPRPEńn;·FGk^qY!KrAk(H>ÕvICw#}zg%DDgR]sJNO޼?#WxK6]-'ߏ* i@,L\'ISL;D;)W Z,PwϷmI=jP"9$챒y dא ϙ ia#=+ܓ/W`k7 L3 \phu+DO9^G%uGrC*J r@IS')Kd'֞ s_WzHg4ʸp^6i. ᭣ SN;ytm aD8vf61Qq1iĤ֥Ej'Q"}J aNt m#Zq+, lk4:Wyye^gfSE˰ TcF10l`tx?iD 9GZ@SQlY.6"+ \)xW.MĚl:d4> stream xڥYm _uGk&7E:]hK6@tZݭ] %E/ٻ 4;"9ÇnnG7dS7n64!:ts{نrE mqF61<ʛ7mǶ{Ovv,*cl#%U^K,4ɨ04aX,:ʨU2yѵ?9i|ydSER΍իv؊"%]n vܻ rA!GTT5!A<#Y=$MZIvېPd8a/* ]ILlbi+D m%~)mcD(($֎uV.PEo ?YeSHP*DP_FC.?l5$X=۷3y[}jH+l_$'RE2X)]BEمpKIH~IT眄ĦQSuv s+6ɒQ=Sgj?cZ xy~l LFTϺ!E?=/_uۗ}CtDl3`9'2ֵVd۔!P{s&Q`ȫP/UCr>EwM)IROTWE5؜9u39TtͰ0I 3( pijGC.AY5oa)wE!~慳~ E^0we_t A6"L[0rePsؓh t6],k7OM~ خXT6EEs  O+*tT 1RBJhuJ}e 0HtJI"&"'TRRb k@qr:4 q煲RЎ5lg"Y8pm8 FCiă_U(ֱ/e GJ*0[Z N\{₥b©G.yP<׻;ldUe|x4d |@,M#!{{ AJv]=~/Cfb' sךrZFȔ ̺|x$4 ӟvY_COit]mŒ$[w -.Oٻ 5q [<CA'rG~^#2yF5ێu7UK- *&NӕhuN\&%>@%تyiZx *lݐC`K Zl^_ Y}6eT7L_:JHCҒEQIߎQ*5w.,e2!}e%(FR.ibZ@Lp[ \pQ_$t ;\$7MC_MWiLF`HEHTNC8kdZ 3V}c5MTFþ.<VBv[e1'[y=R/ގ!u#I1<$:)ɬbwQp(@|eʅKPK2j4ȈMƭ[N|ߘ >aݭ|,x`1颰"ǪYǻ@{!5!Yn_{gư|b=OƮϯ_٧sɒ 9tlWoWma:TG;z];[x`? ?1o(C+I9ef◾N/P}ʞ  Ƈ%@yN* f$1&Ь6fIIz & endstream endobj 1392 0 obj <> stream xZ[o~%;\94\ }@s)ܒ\9s\z ,/ssmM6_m{64'&7tsuzC91BoX<3o;!DCa{s(2~!O{dw\(R C4vuN2Q^oװp7;J߶; }_ijP I #*`1+0.^>]KkJ(<r<~죊l/GYݱ"Y3umŠ޻7Uy&[[ۇr_o“V̥p34wmyHi)eAүrػ2hU[g]{WD6ϋ` \ aBV+PYM(sMS[I:e&PHkƋf p웻; |m7/vpOiv;d&'B2D P{ANG &GX0w:qgY )^*8D5y!ז"&X.OPa޾Mga O'g{juNE $W&ro޸tv,iSHrΉIښZG7V@^Q,+ *IBԛ4cojl\d?V9,h W݂o nrlKT4%JnE<朶n.PZ|`lcTtDS2"%[x~q^%/ C28=b9&EvLXeYQD26w6j*GzҒPʇO(!`zwﴻq)Q|ߝv @s[óp u䲨0m /+@kKE"N (;g*{qI^ I%qYdH=>uUų*P 5Y:79aVCvp!:iM r(TVv}(SB y(GbyW4*$iL"*f1FV]#]rG49,g^A^T>3at?Dz=K4Jƅ޺tx׿`Dk(_mHj uD@b6YU+|>,[w_}w9iLௌ c+%0@gb^!60RU ./ZXKNv%5I)S[cUH(][;99j1Q\:gI _WDZxDDQ%MњPp%!z9kY̭ R0HC`5qF;֊K+69"EM&Gn;z[x|,}p,(ᯉ`Q]\lgL Tuǐn2[@:.q,̎\}rvtgX$@S"0 &;O/IRͦ,XJ!w-Y`,`aĴeoN jwBbFϓOP%Dtgk{ti±$\Y}w3MxP]&Kf^tȤº;֞YU:[<ã.R Tq$sN|t}ey0zjSsk+*ѥdGNuQ 9YaN"%^NfHW۩Ei*h2 T}A9Jo6f/P{=(0ơ`Q\g{8-)p?&[-+S<U pvNEѩ y8zfJԶ!<64 6/J d endstream endobj 1395 0 obj <> stream xY[o~ RA8˹bۦuP}(<&Brmgn)HZ$~6 >8Rl^?L,z 96O: Oǡ)A8 (!\tu6yR s}N bPyaaG$^[4M[sAq֕̃5 c'sԞjڽE92V` D8> ^p5KKsy-lc+b%Vn,, :9dS ZȈ1.骷+(r2^PX1VtIX :}#"f<&3;]h:=At (}$9Fq{뤶Q,3,WW!eVv[5>JL@4!sS`lI?J:(Or!&шr'djh/6 g)$qVaR.s'@=Kx$C)6ö6:ne3c(}R-HZ֔N }ġ>!WU#rVy(E*]QzskPL\T^SN ]cjbf̘C.6*P@RTB< ,/$ ٙ6 L/JI>}5Fҹtɍ"̶A'lBM o>k޹!Lf bu4PFL vc`DW7Œj9f]ۛ8L'2+W/T>(_U)7l`]76O^|ZZ4c~TIM-gȏR`:V]h1T\:Y϶D={(8uTW&U92-\&Kh5]>Z+tm^t8}GKj*ݮߋn~poPqdJCRO@[ "t\/wo^}wᆌm|thb78:5[ *rZ܆Ҋɋ?-.~//]\@ ;bi'wԶAj](8Կzl.ɺd8nCgo,9qG ~H{+FjRBUʔgu/*74{#"M?vgX2 *1Oƻ T[wGƑx~SbZ2JyiUbl=&3{͗t1-y:=AA$ 3IzS?Җb=h3}fi> stream xڵXM6WC"b/rC&@ 4@E/dȒ#ɛ] ?CRD-{Pyof | pR`} ^#Qg8Xv1|Ϗl4̖1Mu.>0QB` O_S bwaVQ1΂Ǽ}^mJD,"N< {|'.tGu2DyqaɭNw "O7wߨv~/f-ԟevŁQJ .r3pqB".FvM}Q o|bF(NI7U$b2i-*/s$R-Ih@KCk, 8, 4:oyKeǹ̸r%J?}qʴm>?3}9xR{%H6MX}$b0}J1[|R)=)aMc(/ZT㱩$ CQ=&r*y)agwPA&ѪןȀViF#SMF 5<NeWKIBeoQs17 vP J_h,Kg6%IY^NYW_ՈFk]r?oG\ D-GrWy]SHHNJ ,VgŪְa;42J-ǿuS9(?M]=qRmD29HQb.Yg"Ms23HEǡl&HzS6ԍN9w{;@(;#;5`@Aw8n}KRf6+*XB-O#bgW'0?i$sZȷkMXWT5R-HhDʬۢ;2~ 7ysiuLOm5`opI$c&VFF5@A3@kyT\8:ŮziW-k:(7Id>R6oS3T\UE>NKgkw{}e2f4S$Eʧ7)uSh^Hnm|85, OܘUcy(TA=`d"4;]I>@O<'!=tcqڢڙ _vͣ)ThE&C,,6ruEJl' 1G\w1fjz\ 綠|tGbnZ:Ue*Nԗ8̽2c5l v_@;ogЯ{*Q &aV80Zynia;dT?'KE/e)uYg1~2']*ve2ԭVϪVFI&a)^:`(6iNٟIt0z%63VʪR1I2AKI:Ab;(bʞoz-Z\4(ԦQ\H;Y@VĖnwW>LXgZ^S6Ν":8b^!jD0atjuH0tP&{cI{\Q)P͡qiUC;v:\@6A=קU '0Tcϧlh)<Á`=v,ǫ,(n< u7qG %. 6fdy8>/\';Se.eo*h[Ի&?:ob>q*^+ߓETVM]O(]z=d1xekySw9.{Aa{ ?d endstream endobj 1401 0 obj <> stream xY[۸~+/"F-[dڗyPdVId`{!)YPciZ)\s." ?Z7W?Htq^dA9IEY"f-gD)qːsd fC55Es_eȒ ?zTk~ӣC8JEJ*Qw+pUنٮ[&RNb1`e(2'[(Rt8;tvzXUaG Wvec&[sp1T|DŽG?5,p8B/&6ܷͦv/,?/C4,. +t|s5EdD(%$OX̩o 8+nF69v?A`gzUETISKH 82 n g]qr ɂ})|Ӕt Qcԫ/ѷǮ/vf bw/-;4iȢڠn R "zVn",ڶim,!vrCa|G<R!L u egnP~XJdW !nũh5F^ᆈH$6k}9{ԇ:Uatn N#/2ꁀ̸-C[1WxY̞&(F>/_JNê"2S' `kV KLqQnrq|;O$\1Gu  ̩й糶Ma&hl̠'C -yTiùf+3i6f.캲ޘ'QpTXNTjuX5kl[48X8x@?kXЕ!Ctɳڬ< ?Ve+9NI Y00?_dpKͽO H?¶-f gP=ʌnCk>ZY UWf5ZecXүif)4oqU.x\.rACڸ eW׾(͂=zvgQa'O" 6s{jEC.ՌsR }ӁW1L >C! "T~ HUv& k0fBNciyX)"$f]Am:H4;4՟ w$~ 7#Ĵ/~U"#IѴkRHpQ\z7մp9GUx4h[QNkO9S+_E*Zp Ywt®bd6~?u#/WbڲbRy̏f^1řUs/\NJk s7^JIhB{2"I"/6mVUMHy~.ѫDL[ϥ,09e)JMlNas@uD YN~5hg)IلOS&:eU3;T}hikZ-`| MX8͝3jr&w W-\ݚ::$z׷xUX'ċ$ol7%F$,2鴤`.{ "Ɨ33~ؖ9# fValVپѰT2!$ t5n4.=vf .ԍ|6ha4~טﰷSn19~cO7C* PyW*bS4x aQ endstream endobj 1404 0 obj <> stream xYKFQvs^8eH<'II6z7l?Q:o}ܼnFy Ib^.ƹ\9/ 2][%q{Vo>w* dιN1H7,h!bɛ vf S͡ii h״XPtw͂sӱ pH?y_KCWu!.{ KMS QKz 'u/CNh]@J-O\4=x`3 jb|-oA,ߡ+P TF\ͣQP> |ljt-⡰RH1>h82;?Jr`:f{#Qxw 8" [˗cU~U3mimci9v{<8^kL K.4  ͤͱ6Ǝ6 m[ZEЗL尥S_}A-&˩N5b{{2^bq-a?4 Zf8kc%F*hyyй)5JVK%xޣgt,&,!BegMBwJdߥVi +rl"WX9=kvBJ!˲d:N,Yy3=D jՊT̖"yyn1)ҙK3~_RQd29F `].o*8V8}sPCA2~&H)]`˓;~- alN'c34ϧz5|棱Oce{׶n!3)<:ĹzB;S9dk &Alъԁ\aǢTڼ6VMd^g 6M@43?a2/c{Ln&nC[IY`|8b'5y>k۝xk2#TkX>'ƙ,ps6Sϯ,Pc Rx1Uu8)BIo2Adlb܆tr#, c7y\v @pSwqԻ liԗ~xor endstream endobj 1407 0 obj <> stream xZK۶WhNNo]5N&zHDNH3_{àF=c w/}C79эf/Noo764'E^ fs%Jz hkonlt6Ouzkodjn;7?)m1TXZ_EJMԆ9CnUj:fǽzoSrJIr%Ic;ڇ;b<{wZ|Zاz_!{|簀T4v6ښFɉj(Gi#6 "3~PZ?͈R&B]ɣv}#p[t˻cGZwǤ\TBf,SL܄MTóK*8"/Fcc$<:?'k,g0L_nVs&t)Is1ωS~B1،ק_փ^}PaeQO"3ILPP}UUb]h}5zbи(4kXIh'BBQM ԠG-Z-4M< 2ץ83A"9əb8v[էzta#A087}pòF3Ý`CPev~>T>뙸K3d)Կ,P@%Șυ?e++ uvd1+Fh&}TȔ 砡nlvUR "{UULʕqW֨VD"P+":ܫT2\0$_էQcv"W|HYΌ` ubr8&_c4P&pz+L6n0z)Kz<.ZpE:GXJma$c:tρ{Oxk}|tSuL6! Bרr wtU%bő?6bP5}mI^yt"Ჱ':lb 8ꡝ~ /b{fGo`+ dsi-đZ(DNB]ʓrJ.r&,[eI^A6la864Up\'LRǗ{j/wkz^ꡲ-`ñA(WHδ27@=+~&hu.tws daf ]6S-&n8״ɞBp;`&n tM*ԕ w. ~Vqz auP-ƾb #|*qnBtk{PsvV#+׺=IM;}!q sLǹA„TG8,aɷ>lg<"X=)d (gl'-ދb!֞,#I-sBJⲔΐ_ܰyv(ICf?'m:t@ɲ$4 򨒈a'3^LnlLK1F(d&VjM C҈ ڙ;=y~RbR, ȯ݄V5A+X6Ӱuü( JiIm*,7n~7"89=77?'h~Z#R-@XR 1: Q>THl.eyBD=c!_*x_G "?A E7QٗοVOL5c aVX|)hP g^ڟݮzؽSp|qFdh_. ,ZrڿPՄLgvfTW Ȭ bVsGl/ݹBm7+/"y1sƂ!|maLj8wY(ceRHRI+'эٔנZ=CoqQk@8meWp^Ed=fZ6*$Zߙ}^QaHi+{:O<V)I1/J@JlRZFˬDIWs9kc)\<ٗ5z"g1wC}֐cz 9JdX8B&?S9 endstream endobj 1410 0 obj <> stream xڽYOSDK6ƆeWRr4L }{gO˦1Df4cW<_?hɡ~x>|YxŠӁBя:iOXJwu35}7׃SʸCicYK/'يXpj8f<2WSܕ㶭$U9П5#Y%ߙto!B3l32 j=#.y21(+M:VyDr8g2=eI٧=I'y3ҟ F^,ৡP2 b~adI9雝fL0@i>-蕚IpD_fz3xt[7:{WF%L6hlDeV#\8KY;`!Ht0{: M9+AF!;)a`}'l7p֪o\t en\K5I5_IUPs*oeQ K(reѻlcVQ(2+f|BLnjՕ.vcVML̝?wfmjRsL=<Li!/x WJh)Ӻ`iL=i)F-_LUuAAy9"mq(4kvrl,$| OkkƧ\QN y%j-=.=+c!«yr[_buj-AM.$eVvr:`ߴ0UmkN l1~0CX|4GƓk,#k$Y9A*LlǶ? i4ݺ  BrxNw6ЕvDѵvlX|F+n|c( 5+`EFr53= (; 2[OscWwtʰ,"xH$~— [s?]M8E8XuXejTn-oj +o6^sB+P(0@C%fWװ ADCUT21ȧǺTW7:۷둡%Zh&j$Nb]{wv~t@Fn㲏p{=ԌW**& ]B*>g[S\~uDY׮w~z>O1Vr endstream endobj 1413 0 obj <> stream xXYo6~\#^:"ڍFM_y%WWHwxH+)\;n6E7á拉yvN؏\;8r0E1eeAx!0[Ξ\XxR72=eYWrܗy{gt[jABSRӱjq;Qҵrq[7cY"8fP蟶ˋB˺f4[R=9Xqۼ k 116;oG{n s#c$Bq8~0mmS˧g?inԧ6]@b?ՅEb[!p040|Jlˆ?ܣ<8]oQz d3㬎Oq_Pb{4K\o96+U~έi@"[7-a endstream endobj 1416 0 obj <> stream xڵX[o6~߯:@@RɃб6[r%9"}'rvpbv=;@&㲾Eu[۷**BYAdMAnfxK?bYYx%"%ABgʣq@+{҂J;4kZ'\!ؓ WHD^u3`Zw&ܘ՝s& Kvߧ.{}A.}&*L1ƹ 䘲'O?Bw,cy|g7d"~4.6f8=Y$&'O;)qy,p+iUFD-A4A~hcpݲپmd27f0 i-gqǷl1t{lj\w5?ǙP%*|MՇ{f&0z~Ӈ׿ss pƄx,М:[Sgkw?{zw|PˋQpEfUm j*O)EϷA* uڲal߮!4pBӸ{;yS,-vgݬTKݎ].3S͙kwMխ D̍^l\_;<\OMJ8r4qC@Q_^Xބ$֊4QÅU/5*vA5uXy0Cd]qM`uLyk/w Ϫ֡ qP\ >$.(,Qoē-WM%᧩^ esL.QyG0)$Š5GodQvP%I&[=W,g Cño hBSG{P ܇hHU|M`5ha5(Ʉz&=A hƇL~ ڴܽdW)7ݳu=}`@܋KU<5,.!pX- 6Z|.I1q\se5JϽC'ߡ=M]i̢6+7Vٽ |KaTiUYY:d9hb$Ɔ0MUshѥ ϪWðL ,q9sUըKD`?W%aW)ng `W#61ef%lMN3;,EqO'o 8 endstream endobj 1419 0 obj <> stream xڕX[۶~?C#+^tKohOb? FH7Pza bY^qB~ t"ETuw&z ̓()\AQ3v^;rAPM`B< cꞴn;JzKöhg讵߿Z!3Vtbu lfI3<Ɲ3DFò5VWk*.rQ0Y  ;%2π? ,I`tzs&IXsR#X9($e SJ`G\55xjnXzPǔq?UMB=&H`,x%^{U(RxC}OUu4K7d!&7Xh(Ӏm9UΠ$K㐛C˩]F7:ңY&VJEW`yQ\L8Y| 綪iA0^N5Ω԰r(WoyX>%_}g0I~,@8QǮvX@45· ƱbJc_Rui{cvHӴ`A}Gվorf<̀iSնB-4&Z2~hcnU}uv\ܺw~|C 2It$M•Y boV@M}'`w"[M͙Y61u3DQLrFɫv݉UTt$z_~,P@AòFsyH#IAfp]gшwU~wT-d^(,6yE#6(.@}m"8_ug!Tqs?aVƔ4QAgG kJoӼ78])c%^` ׌ɕqIK-~] otɤ ~A̮go`;zc4.hgv5WH [ZVf|4]Kk}lpom^72dэ 8'>^3q;xl NTܫ7\5CfMԉ7zĿK~$/=d"z|N~=4ãLJV9^?<; 撃Efq թgQ=u -y :w3كw70 PN8M,ȏ M }CS~֓S;s7 e&.y{㣬lF c}> stream xڽX[o6~߯:`U(v)СV Mɒ+i;H6vH4y.!O 0 b<р`y@Ҁ04އO$bI96˦&$(D2czYDDRD4F +e)a' Va0gr3*A*8 ޘ0q NQ8nU ƩM7NWf]u\FzǺuۺ2X/,w ;<\`DJ ` "b&L>u I˲ɷoRH2Fc״IHH11kK0{0,x%"8Ip>F_ү-v'8`wʁX&ńa+](iL=p ䷅$#NS%{1Q'?f-yY*(vt(а 1 n)gqRTZ8hxr&Tj{'=/.y+oHT)&CᕛnaXx:=n?0ӼR`Zv#XtZx'buQ]V{ |"pTހƈ&T 7{+#\ \2G8!v-I2LCAi|A2\x WXU"l kt"M DJ@ iH@(9խ6%А!IЉ!nBl6nC16}L슶4}!Gi]N!T:* p kǁ۾,U#*٩cmNAn[˱L_U/6$EԭcUNs t2Dn!kv[pe?;?n, CV%ШՕa,}:`nު㈳[(mklloRj4.%^k&%+4C };u}-ܴ\Ai>0F)>{8B'AEf`MI0Z ?P:" zN$yYTθ છdi.ːҌ!֨DGMtFZ\T0EMf%[݃vڬa9j?/ A¨) 5O_zA9Mk21ѫ $FH,^Ԁa4_m=nhlS畷$;j 3Dfj,3Pg#q+ [] r6>C{ǖ1Wo::2`P9s.~.c%Xig ;ic^މH$56BRD${Oܴ,uc>wkژfsE%ywHuUE]6>:(7oL7?j endstream endobj 1425 0 obj <> stream xڵXmo6_OU)Cu[54 ˴UR HɒGހAM| H ?dMkf8 %<nC/e)y{yuf1´\WeWY׼o_Uau*l{?&FFu4hxb­[LZm)xpgv " IS/yjuӦu w.NK$=GYh.!ʁ'6 V9哦K>.ʪryUF| ND~A XpxZ[/і>v>QN\k#/'K%q{s0b j׵zgwV#&cžt@6[-WUm68o 7N1"hZmuH`w0"ح<"L,k򴅒$IF6G~p!t+ѣ+qDz\Y)i TFeƼ#'Rf?mOF]U_JS ıQ`#)<۝ O.3IkUWYn"pN58#ihwIDGB޿{N92A*3Dr02#J+E񰈩. KZHRf +ͫ`^W%3hkTN#r[#'a! >F?H\q(SA44]Pb:!\?і5p9x9#i\ݤӞ%7Sljm7i!G %!HȬ(M(~r-/mDf^qPLI9*C=Ds2F}!붫˾Ay\x8J_R,ܸʑiӘFYV[7>*A 3\N<#^h#XBϸBPfjk`WzijILzgϱIL4%=P@}C[;le*ÒDᗣob309ľ}$m_"_*e?RO!/m1j|>?~7,>> stream xY[o~ڇZss'P`7u,Z/x%C-"l=gfHڑ-DCr\s,."?tMflA%]-hd"]ܔ7|ۛvsΣr !7M]V}O A%Q\e"I kW0~enjM5k4s58+ I fatq eek`{=6 -suĺd:Bn'\B+ Ȁ9 (K`j4v;!/PHP֯Loo Hdk][$RZ6/&s]p˻¨{4~aKā9bWf;Ǧt`BBZ|B6u.8&3G銶7rkqaOijSg,!`9ұMyEuUIi@wl s]WAjS@9[L:Аnc/\N6@Ko Q Ew6n3xu6x gRhd\>sW-U* W)h1>Jt3S%rd١/@_fh6&4)vu`E?ڮIٮt+1!09I6mPGbAxzh%&Dg{Ʉb"S`|Hh6c*t\*<}%6-̀ƛGR ydS!cΰ-wݮ@#IG5*_Pdc\ A- e&> fg𚹾:ʎ?;gg}A”aJμr;ugjHka1/49UkXM "ͬ)huW.S%7y_cPRN;'a$iMˣe{:o綂Y:uI_Mwr$ej?v̄nは㛉@o*Ew!T:]B(1lד'ѡSAveɝp#pbe/q5ͣwϦ=l+]zUЏBEDufoöy}z+KG^N)n׫k|;/Y1ٯ׏Wso6^so~yw˕{I>?y^S.g%Lkakn ~δ]c{!OjԙXY;RW7?`iv endstream endobj 1431 0 obj <> stream xY[oF~ﯠOe+3+ n)i*U*;f7(d%6sss|H _E F)NIp C)Eq^PFQ0x[>y*bYUo_ݮ}V"*|SՊ&ag>zƬ#JDyD ~F]tQYuUۃ=CՍn^]~p!"/7ʾُu쪫҄?U׋}ˣD7ĆgJQ2+!юp#(2@sMYl,+Lʻܽ<@l_nzwӕ~u[vޢaGU5};eiG Cξ̶Ryo+W!Xf {h" _>˧ HZ!s&b1؊RqVUX7?= +*}E+Y Z5ZR"HrVWҠǛ{WTvT>zL$˵J0ۖ謲ij_p^Z '}6ETdyxD֡+L܀ U YYP.C<ٶ`x tPP1qoG,A$}qi(}N{o$dl|SEIHzcZN3!HGRMWH+jJAj*OIռ>&fq*b3=hɒe5UƢia5-EN˪8i=a8γidT |-#H=r55ЫGB@FLGgW"hIAG`qFMX=2}8` &R~;3k|mVHJ S7jtVٚ:(,!-N`G4m-{xQ7cOA^Mç sͥ3W7Gjb 9 D WN> |U̹Iꠛl|$ED)~ /x%~RxF\iGed!IAo;Sp\I a@ga ~~9ܙQbv)Yag#6Tݻ2"J.`\ɠqGڝm&xm09sc@jl~5$zNϚät>#ۇ^!?~Tr4)##ǽwq{](fY;ӬSA0bOٖA%P~:J*Jt}A吠$=Z;N<źV087B#)/-!P#$oO0MLdP2ٔkr$"aL#zO&Z5cl]߼܃>4ɛB&U2_?-ff}M L9s1%]ٔFicLySCڋS| Z}RéEƖvZ” vU"UܰA2זnK*(HA?BX(lyb9Oq_eh)RhDt> stream xZKFБ v- {Y,vZ⌈H䄤oUW7FvEͮW_5c#6oOʍ<CmwJxiPuۏhaUv'SםBEr͇coeJTn7s=^=.Sj׾ImhA!7W7hY ~v/$hmx!&I^JpS3Lj7TvEEW_}K9TZWӾ;rfqo5q+γf+m6lw(Sg/OxWxkS=}.\wms͞hІ!L} kH }yO\f  r8>'ӄCݹOf`Zgp%V,S!D.N'%csPZJcxX/*Nb,^o]WC y|ۦ+ˁ~ {ANkCJ-ȯ;֚%/:SC*صgRau"X.eo!A2,?UVQY &c-h @l $'B2̚} }](rٗz84HELң-IVN)#PTF-+t0K fGXk3JXJW/ͤΞ=*URG6SRoCW6c|Y `7D.7T]w@Pl,x*sէZ?*uڲxve+׊^DPM>l Ie>fNR?{걌P4#A@a̺0>á N'(d.Nw4Dt>77CCJ  7V^W'cўNǞkҍAY&q:_T.{_I 8.c{9(qA1rh [{!"=˥ZOHa.EWy*$s.+˱ 3cPAM!S pV衚uO.6X1S#yN'P F@R膲X8Nh[5ԧdnV;g:r;' DZ9 \_aJ${:.^2kGSLqO 4A A C#H/x3˰S*ECF!ttb*ĒI7C5{,l}O[X0S6W3S<'_AXQ`<K͙PZ¬šš$J;0P-&b o9g>I6i5}mE07 >N{dMJ=M}qfI$|&#!.Ewsڑ25ÊrɁq쬢P;Zqq͙+^QVbISG ӜJFM[4>Ã"P9Sr 9hV;_1YC #w{IsmwEY$ \`W+L,L8E`D-|=BN;xᵠq ~;T!x[DD]-XصưJ{4Zc{AҳN.23<(n%+Sa>sTyY #JGGv:;P3x\<^GШfVq4$]BJfF>HKجK}\Ciq ,97& 9QCPn$iƟ' Fpr׀_Dzd~V>4'~ZNNbHlgG+ `,wIS_ [,T% Q8̚a6V?j_} *[A 0_$ T}U 7,@׸@Ռ{A Z+ I>Dk yw̿/s6"É\͑5p*ly5]#у7Xp#{k!FfB2D@$d-.jYB  ;@Ѥ`S5 L+wWy5@>l}Mar,lY"a8Aa'qOuM0L`p;Ear5B eIK@W_Y(<ʡx1^d݈Sc<'ey8<8r)Y0-J $woGu8V5$߱xko% NdP> stream xZK۸W(7)eaA:n֛8#aFH,I3UF 4}Kk ϯů ?0ea⻟ĂgJ_b%+U~\*VnR0c$|j-\V͖=j׺Z`0Ol߾ՔlR퇪w5DgӢ=c]}zL5/lg`қ;GcO>< o3Z/Ȃ)Zu<,v2CÎpMH*/.5HG291 *Qe6!x-e;l Pmgu]UzzyҠ,mxl6*扪8o"/9R@&^FmڐɒWC0wqbW:6r:{ߢH^pp`YO̜taX׿whQ{W.j]e{Slvo=;E 믖gъL{&ۡк]p,p۷]fn}u@s7*>~L+Ɍ.¾u3mn)IL5!_qN('~s^.$ȡ/ KϰO)BQ>d窄dlJG2E#R8+=D /`;c}%YI ]85]ј.Եph+=JI0P/3.!o!a7\mjmN V 1RlO g}*]Sh7up@jozėwJkɡ Tj[r誦]V2_OƒP0mUS;w 93yakm&t>nXc{=- fz/=$0 quS*"ndkׁyΔ}7y TPH?E׮'+(b#y1Q (SC冮GR&SXIڵ)4E3f9x7/.{Gs@α%LiM$BLHzA{B*OOd͑KW$cvd5.AKhv$*l*Ppc`)niʙ Z23Wd%Q .jQF  7_h=M6a͐# ~Fʥ0aχoN4%k–#8cWjφu`kY<8Bs)oL*.U \ AKAGͥJ,:ijNo\p(GS`LzPD1;z'rƟaG#B-mdy9jdQӨXzjnG( !K.Ò%_gR]$kH~HFLЭ!<k|UL.WAdUK2{z iwgXºW 9MqH>: 'dؙbuXt #\Bmuْ؃d<.gwBSl n;a0NR6Xq0e{ endstream endobj 1440 0 obj <> stream xڽZY~ϯ6@B-6İ'.E2yP%ϋ{h^挀 lVWU7o&?r+n7F" Sd#HM;xN}nwZ cM/n1ҊHG@003H ?*AyϿOsNP-7" %},aX n෭iiY2 ;/8wŞ_coڣ,ddHsz~][t};|QcTBGfK˄32s*0A OQKOϝtڇ >{ʮ8#&>blڭǻ8tJxC6J6 Xd5<9P$V[H*MmqbYuRSʺUtJ`L* }l}7^ƚZ ^uD ~cǒ6`tara wJBƃhsnL}C*t[p{I+PR z*2vc*6VEHւTG(:A~nQF*9-|o˶IDKϱO s!ؠ-sD%AƱ0pn4a{&_7Lz:9>t)hWB%SI!gf42%xUtXngcR9=`j!Gv!}4CmTQ`\gGP=x̍Id|*8`VVaԖ`ÿYJMSs}w>#aby~.g?{uߴ#q7b;65khF"%#" T?yѬr|*^3%{bH"sEe"d!ul|eA''DcBGT"ȭIbN,K7?QՖP.JPm 0kv9⇅ys<̀ϥ=.vأ{/<_]E26{.zTe39cF+Jvk?|O|tw>TcQ]{e+-cڂs-Ѽ  M k&q]dɩXƕ1$/!j qe\!C@Q$Y}QިڣJD&"e{T[Z{V#}MIlCb9eq ߬2BxߥYg_1U%13vV%:Ę$˾Nx% #*^+^c]cgrQc/T_AXxjAd J$d^,!eNŸ7[nFM%"wTP3W'\Y`6Jzp4u  +|PTR2/ 05D= D )'?]:4"S` #Cݴ+1yj'IZzuP&^LU2kEҁ"W٭#ZEK*ZoIAMDLg|:4y*x֮[o5z໋xM"jOhny-DhjFC(mxnnMt-|ةU6 ƕ˫9Z7?[olQP At!f"`UYN6H8X?HrNe,h8j|=s[*EyeHbZv}7 -\ˇ@=\t~ aUvqsQ,BReO ڌ14:H^fx 甇 N^ vW=kFys;߄R%ߒ1%eiP0 GO\u^//jy3@-;nlTE+~ɭj/K O7A endstream endobj 1443 0 obj <> stream xڝU[o0~߯4\7Sj ]=i@Re}25js co 61 4&   ]_a[o:l[ŭXݨPu$wB%l(0ۉ)S!v>m%/Q/fz8DsQRn"R1ad*adq 6L)rSڼ0 ¦6L$H4MY*F3ƴ"~d|dU7t1Z@UHj_na]2[CZ>u>aBa;ԖAUĕkeKS3L'gS-˶<{@,G퓀c FwƆ2LB^ŀCܰVfc݉oh/Wˑ)U;^ݎRD*MAvRZ2,o`[$o* ytE!IJ/a$MfTr&_+N'S|ez3?TƭjV\cM(%z^S+fq Ww띞ǽBEp90yN,Bl7zߌJ"TeY<L 7\q#s% KJgIZG"#R~Qq. nxAt;Õ.}x+{}msK&HGdx'77:'DrHlRo`2} '`fuOCK_OõOw~'ޘy endstream endobj 1446 0 obj <> stream xڵWn8}߯@Ɉ݌n׵٤ubL;ʒ"N ")WrKY؀(jxfp834 dX eK8bYз|d DO=c[yYIj^A^\|Qi}dQT+ f?T^eV9ڻ꽑oިJF!c4*WLALoǗ׷:O8}`JtSk4 rʸkOP]j"9k>%!r >Y\ cU**29Y,>3t /.տNh&vn!i6o<ٿsn7W@2Z1B#Sز=¸oW/.nWg%2CXpDZ-bվ3& ?4@AJ6ҁyיFwx Cyrf {B>fBl>%?a@yCT3Q5<=!@̯PēMx#Ӓhn&^mQW!MCŪ%*4̸|Qew5e[=2d E%z6k :Xu2Z0jC 09Jt6Z@5.puNs ~I>KOc[|_tsʳPXƒv2M5Mv3W=j@>=U1q#=CueH~my3`Ux`l|_( endstream endobj 1449 0 obj <> stream xڭWێ6}WX/-ЇIE6d@˴-@f~|gHʖlm xΜ bA?&&x4&E\f<"n6CO73eqoW< ~ ~M[Ϫ?Wz<,F+Z}OhA$ SaϺ ܭj Aou73ѺB?mFQ7zvֲYo3급QveRpoz2vuIﴗ\]8+/qAxʧB< МyM}NVwD`*t A$ G8^bTBI"&aD'HH)@"6vӫ%쪯/|H2²1T+n1rC$pa3P_ݮzX_>żPQ]xP;4@)4Et%={qp^kF`hIZdg)DN5u$zjZ9T_Vjl:wݾ*Ql?ؽDO" j7ި쪣8z[+cj_Ve=(K÷͡V[#-88TmNdqhޡZ'^a(_uGZ:uO>H\ŋCѧ/Fyҫ9TDT ""|YXr>d':0 `L.T&w{zmwv+FNuT-N_ZY{|M%\cyrR8n9t=w}1t^ؗv3)*٭iC{ P7 y;n)bPoũK3L١qxux1hWҸ]Yn{wi{=[~=,?\c ',٩+%Աh|۩ؼ!׊3wR[[O4h EZbF;W"d7wGlaqcp:l!ё0gGuz.'-Κ oR`&[S1" ja砙#HPbY~|*8PtP~Z+,8d*I;Эz'$0Exl|= ^KOX!<`}tY Nxren Rf.˓?AefDto蛮0_ P4V߫SGr= ߶G9Ft h)o- X;/)cmsm/N6V˩`o9]_%xr_~RNx,#Z> stream xYKoFW9QE7 M%΁6 >T# ?/T6M`Z|Ya#?^ՓtE0pFVW+COW盷|;n3Ƣ:GfSew?8H2 <l*6fhyRڢ*U XP]Dꇼ&~b}6Bc&T$ȸWĮ`=Զv]c!葝%N(v∓ה:&"'8;]=ywZ'/2D1|RiYlHs(-L/z~P5rfXo#yM"y=,<ӐAR2M7n̝9:5u oܹq$nm4܂E[ow6JlkOH/T )0ĀD5@46cfdh5e_9m)錷e@yIr .Fh^yѵBfN%)E1#@2@$߻jvIԭ;+ːL<@WB b(Ct1)0JY(D\OSӠ~W Au%J);.?Pw A>:⬻ժY3Y(o63Ncd4d0X?]ܳnRz7FZ hmv3A]%TdIJT(|'Hbysa1Y^C` =Brյ\6͐ X8p3K=1ڠqʗCHn!g̲Mѻ$Z&k& GnN_}p[29B4~hF4dd@Mfi8eSA^AxOB,HчKDtZZ $KGk5AsJW۔59z_!NbUk!"Š{ȫV0E'ćQ=ƈkcP86OF~k~h/4M22V7$b ?~T}ѕ[M1lTtnXF?-CQQeF`Bp~Q(QjԓXΗF "R!ڸ+o96{ h1M$ ]]Y^R%RUé42cظ f~!/ nk*V*kW&]::ID& ,<|iLμI JAq 0c^Zjq&HlU*y3 ;벀Ts[0] OJ mUB J[0"8`tƆJ@ܤ@{[6FI}#p gb$A[gg` 8}nx%=[a{PA崛19UUR ibvf },ߺ],ja&ֿ_aҎxAJ9J2ؕS Iڅ9ZiZsp]cNotԟ)HۗMW|bo KVVS -Sw,ںnKWo> w:k8_ptoD9T5>)^= ԯxүakN@B(X_DT?V蜟l,`7&΍Dӭ 6S \N?A8:>M h.+byJt^tk endstream endobj 1455 0 obj <> stream xڭX[oF~ﯰfaK*UJ7*nfm=Nh1G{憍=8Eܿ3x!o0] ~ޝPx0p4>i4~uh 8 >Aa狡3pyŢŚ:ӺTOϊK"g\|HBαPn5Z\Sij V20%ON4 8DKSi'nTpf=2Y1,@#3֠O3gyv E,V~itaOi֢['I"dikLWP>R&-a t>On[֜G EзJ"rZ f\-OM[W/qB(LCQUj_sjB d&ly}YdI) x0h" $4teJ;\'PU wG7TXHGEV= tle  : 8B j?fe[}V̓\ Y2ϋbYwJpj3k@(d}(]!{<͒eKkm(B!af)S ppXҷ R* >$L'/! r*7+Ra G %,f]6hJr Gy7^Y:xiZ?D >Ӷgv' ܕUqO {p4瀥,6%_o8DҰiTBvy=\9s;*J}9^\\ݏWWתp"WeZz&Q[R ;*%*E.BsnOnT[uyJj AW*`7=cxэخJ>^͗ *nakvd"ˊ'k|M)ʵYʂHK]䉭n`NTI}S*VOE5kӅ{ SJ,J FZO <]ArTm)c/IXzEG(OMMׄü1#[8mkgH{m,LJ+}׼)kpwqq,s *e[~sA5z\DuiBЖx"6h |v> stream xXm6~¸TEo"n˹k!Rnȏ ZE$) <3[$-rŦY\.~,ˤd͂ &RCja$0RLʴ]qυdi $Y07[q,6YR."Yn*ؘf?:ڛ{m#s0J X (s/"ЉnKtS3/2"X"^4SP˩:j{cS+{ܥ_1m_z^^]>oL][Z?PZ~;4kmsJsлΟ6콠vT [9ʽl;A4Z h^p~rFط~M\)e@,#Çs>ǹ(w~;'D8OEAYi}\ug./4py/9ȣڭ^%L`i2՜<./`u+G{uD~Y=Dz.f RG&7688W., iQ1/Qώv;n8F0wf4``twiEKӏM5jJF9y<%85nju"~Yp99h^Qkv4s#jH}QЀ5D<yL_mߍIHbV {}6ۇ],7.*ﭹtwc!:I4G^Z7.UުஷZ5~3s~M')?m#kܩz>絕Þ72W5 2(iPjЦLwa g8ռ=9\.4@;y"pkxe`=б@bI@8fCe(d(kU{HGz3BAҪd_欩O {/ܬs @|eʑ,3rAg ΍Na|6]Οa[AJu߅>-)S>jEfdDA V&Eό$ Ni,j*s|UOySU'mXy_V~Ĝ5ꟓ:9>};e'vTt<v1On &pBIx>' $T e{jBĥ(׌!-H'1rb|n#4 ~OB_NY0?ͣ<B!nPW _IٔwG?tI]_q6pבr # 9 endstream endobj 1461 0 obj <> stream xXr6+X  7KvR4N0$F2srɷ"G,9)%U4 <8_緹q?|%,vٹb2<JPQ-[OΎfe_ޟ|/oͦ*;sf[Gb76ṁ^?cJA̼ $n 9< 1T4-ʧnD@>-V\otө޼1h&D#j'U) c=h:߶yU>|-CDl9iLc( ,Ć&4& QōʮZjMtZZ׶ \?(bQ-T.k^'˙(D hV '*"43mT~o,b0fZ/V0bAOLr[d}D]WI ͼȧYQ{X" v.xcX4YkKb`hQ.Ӫ02IIV M ^V 2ݣR<ީu%1]K*W.1JoSfZ9_BiBk&Œ  X9/=JmϨ&U۵PגonhiT @M\y)~S.e(|-D3:I6@U[@X5w-_.fe~N]CN\VeAՉ>} ~fb8`>+p l˶0aQʂ,?S ԸQj˺w1Zk7#gѳ[eH[u=xa>DiňFSE/?aLC[_q) fzw8 ;f B-Ӡdj` k݉qB$>f݇3drhtm;#vmxc!þT6g1qh c@YÒ6Q|#}Ƈ }A[XW#zSD*9%f ť 4O! yF>\}v˾)zYt?>Ee{@ A 1l5=Flp(Pmy3ègwՕ^gVJFюhT^Xόv]{!J ^Z$qi-w9No< o&0jn|fFdbuɍFEz\yaBQМZhopg&L~LeS/E]4Tdhgx?% b`Wj|gHU­D>SN}OVBq[-wFN^I {BYCDVLPça~?98>> stream xXnFߧ  !,ýxEPQRiYAPX&WTHJ"=%Rdh09Y@!8}<I@g4q`@'$vFم{:eWɱ!iYdyE]t~C!Yr_Xc qIE;v3>*=@qof ,sހVyq]T>*;0)y=}Bɐ*o,=by_6MBcQV<[k?v=aұ[v\E/kbM,(Gyd2 dDRMoeƚ7/<4,ǚq׈0S7Gy>o6ZAX0zᐾXN JVzU6Te3p'_Ox .=Ke/5|{AYC^%Q#Myι(qOfuy|gF SC)G,2> )ےFB?%> !aUS_>P]k'Vt#ml {k&3YrR.2mJyEnN^;#0T[KkX4x܇4>tGIpCG5VE^y(v?XHW8A"`BI 9h%K!/F{ϥ6`|^+ϩj:v !rXbM9Y=ؚX}XE~Ye72T"<[7$U选|BD9 [7el4KK0?ܦ֯\**VNGU-eٖem^EpkY\j/?_:ӉDF%*_\|5ڄۃ,֙@ŨXy :yݻĖN>R QdrL"l.S&kMuVGOK"׎ϼʪ夷FBg Aw_L`du_XhȖ”Dp(\St(lYj <o$TG4o[>g:d&kpzX=ӗ/fbw#hΌ5yJ\D[6rdVff8ڧHGd0R-/f^/j R K3[6%HK^"p K(,C/O7BΌZgfƈ3ZW'5Dl"RVss"Z{񹅈 Ѧ5Eh*Px킧 π|KdӞcXygǪ7Է^y_`*wD&`0w`x:0L>[m>|ް}rlW6bNycdVfD[s@ `{$kW F·_D' endstream endobj 1467 0 obj <> stream xZ[~0P#ީ(6bb&af42=V#KI CR%/%k(9D~Co~M$/_n6_$4Ifj)Jn#wB f?Ɣ(vnrc]1Qnz姣DF]lfx%f)Rٽ~,l믿cM%#S1D?U;}`V]h5&P"plZL!xk߼1S=f:LQYd\q֋8^_7,׭Q:h%3C1K8{sl^8ۤ{fDv-,ovO:n^oB\b04bMl-QV5UT-tO,>OA!TtT]?'bDOU+RBmU)f0@.h3z+XX' a2xGޙH)qgO0rH nOGňKk ь3 gd=6#<(r<tnR};$aƎt Ʒ1$r*}۬zbQFye4>k#7OiSD(9syvo$Q(冠'Q :~gYS)Ud?;F:@2n_nSǧ ;-1#,+ u+F*rO(L.in$>t#`q -Ñ$>_?nX2j$ af <&ȵOƌ-bVep,i/E /ilA_ 7N wչSA㧦:O[P۠4wzE«NɪӋ/:3o`Tqv4؜5(]_*ɷ6N$J|NGbaRCX_sdA!Ɍ̒#JO|`J@I.5&MOT;T\jv`*` Ǧ.݄0:mF.QG[ˢ=0ρ !${|, 3bpd(Vmf+,n2=f~TeCWH$ޞF}qh F7s_-(B 27 6.L(eI &#ԵpaoNP0#\* )04. xOTXfknP`Nf 1p EC*@Ywm6vĈËXjo>*j[FL4mg]^ftlJs\o[/ggH>clTM#9i"C|r_4;5A`h {Bzxѷ&ro&C"Jrl ϙ1Epܣѣ/%A$\ŃY_Oט7H#8\\0|B FOILD*`>`1%+^;.-h}x`< vi[Bpe'Rs N7eGtڸID0 .q:.;XčMzZ>ERwp[Tu(jF̚T S$s?d=AL3}^valH@H'XqM4l+5Ypkʆ1[X>>v~@r 7lTMkg": twpHmof:Kcs\箢5ܴ݅4׀s 1f{.V V-fr7OSe9Un5tbfsqo7"* endstream endobj 1470 0 obj <> stream xڭVmo6_Ax@+c%#ԛMc{٘ -1&$/)䷏I[e7) ;><S0p-7b >lll"1{S_])Xև!Ըi*V<mG0۳1.L[B],y~E16KhEi WiQm5H,.žXpEF(ljd9ꮪ)%ޕUf鬂@l =PǺÔYȫTGLϯz?V%> stream xVmoH_}-")rԘ\?K KH ݦiUlaٙgf>kH3i6C a 5\y RGԱ&zi`hDhWb!p> OV2/|+WO`GʄlEmtrBkYX &zt;?K6w(f eZj)rҵg*{H)JŇH! ]dIL` -"1_ϯgz~1?_^\ lwg"XPk%5:Ғ|+ @9)0: UnH.O('IcާF6͇ӫLF*>#$=::d|=)Eo=cygE^vDz@$,c?$+/~\klX [#5)AO4 i%x1 kuJ&cE x'Jۦ#! -j,x&-aa#U,10֏A@Sv2g]z83Y!w^lY)9݂gD#c:/z>0hAلx@cV_@˽'Oh@dV|&U:DNH%T!t-%-a#qJc?\iCD M:`w`GU}(On( #>+oǭU%C픇'WUi!c~WM (.m5eb1LHy+ ? v>QuKl%y\ /,{.lUǃ[rϽ  %#F/a.u1}"><] endstream endobj 1476 0 obj <> stream xYnF}WPShr'qiNMQ1I*"V)b9{fvv\$e4x#5 Nqp:? LVmV"Xg<*yWe3{wK@I౲oa#K$$"Pڶ=lؔR;\(YD"1+C}9Ӥ"jnU}Lu6A?F"FH981\%bOϞ=s$Ua!Zk{_=9BBv>f2)EVGy9F;~Ẽe7@+$8ӟE')G д5˪@?!lVӺْժuЙLV` &V9r:z":翿>zusקd3$r.t"8 s蝼!G2<HVU3'ҷ"&ba#5 J ,b asXQ=1aY6(a˻ AöNf >mަU9>gD5,Z@a}JJ U'mq,ԇz&H8[څ߼0gBI^$E<̫4i:IHR'|؁3$0 FIcF2 Ƴ0{v5@e V)˼|?Fa~(-&Kv&Yvx˞V+bJZavqG^ >J=NR헏mǎUYҽwk%ùNثnVde껸@ϓ*M _\u\_:eI$KiV rHMIX=ub؇W`$:~#T]j+#.ŞAf j=&w B"#Iq!h,sa0BᔆܗB ph#` ޓW5TbϩğPx-Tݜtڏ8V_ Ú8f%Z>p xR¤S+"pU s)En xRVd!dzI+.g=hMn7坱f//!MƥM< 7峼t򀕪>̒pDÁIv𰇃Yh.S #sm9ãH.9{<2IQ!|"as<{4VAR~M8{4M< / e-U81Ljmvl{A4{4s%}tm.$G\Rp,l:t<͞lL\nW.w\!*\ne#d#d$Gc ]p@7Pǒ7Xoli˦ڭL|9٣ĻdNO&{6L>$F,;8[f8:W-CQ+Ajrň+I32DP(!4}Rhw Q{7b5P?c~/=L8a0kaeJ b!ԬRF$a{IQDM[գCn ~@\0|5j/+61D%3| OT*N*ʚshhò+` K 죭3}~4LMe:!Z?Ѫ\s T> 1(p~1 xw:w endstream endobj 1479 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1482 0 obj <> stream xڝX[o6~߯ Ĝx`0lH>(k%W[xNܡE,Q|;}Ytgr7nG61LpNW3ʉni.rr;fՄQ)̥M] Cr*\-Rq~v۟…bV@XXIhr-~kQDgPfásmc{]s143D⬘U9WX()vURMaݰ)O(m][.CLJMZ&UU$TQ*Ү`2L鏻{6)Kbs"\2}z`RjU}m6n{qCdɐ9A,v[9vΜޑ1F+?MO[O" Ѕ|rW7U#E.]mR"i~nv#% A2{OFG-OkjO)+Nm۳J)ĐB1mI`jFS_.P9m4P18&t< g%VN+jvh^3Du>mU9dpXWM%-qd .Fc1Cgضxg's=inFМohkw^(Po#_擜z,xuq}ir 2b1Jll65"Q lmﶳqߊaj42Uo3E綁 6hZڮ>=~alZbwq e\ug]uk5]~ӽT$S; v:Le*iiشMNC؆C@L`';3}#^n<=ZԫfchBc贏&2zV,Wiɞ䠀QIDDa#x fy!mQ3/4t+^s*FLjHƣ=O֑^©(Wqs} _1X^y $oKpω["%QgpEU567aAt8PO9-BYI<K>? endstream endobj 1485 0 obj <> stream xڵ[Y~ϯ[4U<%>RNboJy%S !()KIht1WtE? է_%%WԬ(/0’e8+koa9__Nk[}96̬c<0ܨeAa؍ r?RbB B{){3&X_` D J̺svit0~)WCu[Rv1Q6aqA0N5-J?LϦGY(™=O &ͮzGh` UEû`L~l-a#]!AB2,V?֪SiN(76[wE1RR;#Ɲ?z6 xWi<ƶmsV2`2 7*'%nڢ9=j&G'N!$p[]0-B*'SP `ͣ K\ [?/0-EO))Onuw{]Xn(f$0 M wo~)şZv5]B Y^rNP .PèN ѯKa#z\\ppHlHX!J&{>7a+?eIaD)g@Z`9W(nw\'78{RWxN#=ޜzr1QY8R.7d5 {v꿖Ӌ44(Ѿ>pj bS@LG?^n&BeR%Mk/mȝI >]>4U|hثXڂH&eⲃ~eOF(`U9NHgK< |U~]n] 4E(!Wv>|ijK=#Q#0[xi 'p?VLithUq(ސ`]f]1p/؁W<5kl%OܓzKuov]u& ,#0!8#!J0c[v@ xz?bm0*f@q3zKlcdTF@{Pxr}; gH8g}-d(IeM8K9KŒSϦͤ+V+tA% X;?\U2pT v"D.A ?6|5H=ċV_:\9ϙâDbf:dvfT'B6\쀕 _r :x Rwj8\9 iI֌X֘1/׍, ,T{`l[4:}+%qjЃ䎁b- 1g>g/!hy!tnO[:Brt:0w,^WYV/M8&K))9\"TR?[pY;ƆBIK#44GY6D$/$|>rXܵEOdu^kxbZ''Wpaeݺ/R4>^ di8o7In&]͐кSW/mdzyQJ&ݣ rq0'IbaE  E^*7fNA]D7B8Q~rdZRp/D/evʗ`=bD\}LUmP!fWy E+O'taTFv󞯭ӥrL)K}z8O7mWN[4>>G*?$$ࣆ=߾a_Фo߀G7th߰d@^}xZ43 GG3dkJwW,\?LH(đȋ(ot||N> stream xY[o6~߯0RY)fO]/@a:cÐAqX"y6CIQNРv$>L d(z|4d2tBɡ |_F igǺ,J<,Dɠ/IW< |Χ)ylΎUveb M!x>AŽb"$RL1sFU.Y_YW0hT8ɦC<;Ļ 2>-`mq y5'o꼫su~wcrx*G#i#hP@EN '^L1  hK u;/n|wq|U;QL ifCE;  (r t ,|eAr8Nil qrQp 58#`\G@\iJ F8K9- :}~z"JR4X6x>LR̗Y +nk O}k|DC pb߅%$$>x}&ZyݥwQ]Gŋ!FJ-yۘug~;QH|8Ww(U@`uCJ #h_JrBT]k.fe{nbM 5P dcQؔ zsNDLdy2e0sǛ’"%WS͒yK|(n )Vr*`v>I nfXveJS+x1s=kAP;g?@_-,YF;Vd҉US&a4Pxv0̻v#FJ@{Q+/u OCu5._.zX%]uryDPjLO?LTw"w_fEG̎%^2K]zU p-qV#Ϟj&(O¬ 3C(DB$ƅHm݁_;e4#LAw$B(Ry'S!c[rr0ٲ̋) `}<9%Ř4;F>1=NzizGY*hXĐS!a7흓̃n> ,NެkVR@/6|WțO endstream endobj 1491 0 obj <> stream xYo6~_!aOQ̞: f{I LE\I^aJ%;CCJf;@R6"x# .!œb}rE/~(HJ6/}xcaZ~q/ߕmYw;7\D4 W.T 1aX,uD\pֻy; 2AD$~,];_ ozLeqիE;%Db)!Jv~8F,;uvك;*DT`"DLá[0ڸHBp_,>շ`~# q[ZQjD>2Hu]Oх4z*+n&~"AwE&edWp04t׶ԵWpZ{ű앟CY:x(MTߌm YʆQ]*!s){tD% d!$'3|X2l=/5oM_AB0P] JюwK&Lyb>D&Hzw&N yР)tfZ!D}Y,Aǹ(ƈ6Q }~εBRt<{H@qWXYAVͽYmcIcI=@*؄ !mO A IMFkYx!@^zȮ %?za wj6iqCʭ e;]oÌ|6\[:$t/"H,&:p^3ֹdl `yY@i8 *V- nl GD&la?8(|x6M!0Aao SayJ=9;_fTlHhhjRiU-iiv{ΚKFowM;M׭Iؗ7&쐉 JQw<N endstream endobj 1494 0 obj <> stream xYߏ۸~_!\V" Їk/ASp$yP[r$-wh %job)a ?,1dO||',&&L\v>Cqv !RF_2)ez_qޭ2uK$SD 2oڣ`gèL2ƾg?(nxQ>]Ze˴/۪*|al`VX <ȹ8&P8w5h;/O=ae6nvv8 CJ }"s|hxh^ S[bt?T#h+EAaf%ƎI t-V͉1XיBEAą}F Ⱥu[ʂuږ}Q՝DQJfBG9T^.-s吿|0!++)QY3=BB]f<6n-K@c=6)9?J4 [QiXRTr3f sEP;>{#/Oζ6jY&*SeCBIiY„\XD[X'wR n)A/5gwUrJ\0.C*':7_нM;w!L-UXC{%y3Fym#n'=Ώ}^z 9Qc{劲9K-59ط ">qTofZ K= 'N u>ʜ&B +C] !k 4I^J|I3rDŽl"]"QB^vE.]ضBCO5zA~հWΰ (Mh w GQ*_jj3(Ҝ>.Rt1<A/'`@,×[2 /0/,Hr'(3֠qz%|N4T{ЮLk)&cÝ]r9r_%r?^Wi諯X^X~kF8D~|vZmˍG̺=؅C aŇoy}vۿ@ж'gA>W86WxZ;/'*kyxjS5ub86~a-q_~wJ$7У)?2Ⳁ >!KS3>o  endstream endobj 1497 0 obj <> stream xY[o6~_!@)"ViS((Ky3V#M$Ml&Kcjfld7EH(\sw8ѧG)Ñ FmǷ$):y),Vb&o Ak="E7^7o=/Y$$DĽYǷtueQ$13{]"׭Z%˪U =MnnQ>G""p~O#q ;Eթcx .E8<|%!LI+eisQգ32aPQ 2:MWfD_,8c07;,|9>y凒~m%x*S$A`a\lVJKQUŎ:$7C)zٗy,{u\ۛ˘73|[~/\ݠa컿>E .b\ *s[DѐCUtad猠,)—o3NJs謟Z*vTvxjb9i^iY S]K]F V_j[T/~_*jf_9Jוyڶi-knl%¹pD-2{DQפ&'pQ% ,U :MZrD1jW7S72ա:FYJTt"λT:u5nC3~o@N1*([!@n‡mqh:cT_Y튍 B?2{Nj Z%9 qNIwh 1v^nG::#BB2P1t2Lh}2MΥ 0R0#]dõàلuÍNhs.m"3B>#WP& ##\v2 )GZn1:KFek# 6:{d/gB67npc +ݫWu;Ҝke#}^1T9١#N[cOY/' YvtC?w/j endstream endobj 1500 0 obj <> stream xڵXY6~҇J]ۧMibd KMD#QR Gbcx/yeY{<ʉz$ sy۾8(ѯƘOU9M*ϮVya87<֣ (/(=zۢ9bS@1M ԗUSw Fwj,4Qsse(5e?_zm@8 DDbb5E؉#s8qďH5ûCqj4y#Qt6ٓ0%'6 u$a,*37BxnYw+}4ۢ n@ b?i+*0d@%^<Ѕ$N"zrX0w8g y޳Mcס1Ѧ{nNJBwwef YaTGvZe4o#3*$L˶E#Z3dvEh02_ѿt Y>m *%yHtIQ=jqd8m)JvmQî xXW rgsњoIﶓx$Lt;b 05XD`Nq)KyH={l+[l4̶v K,q7eh.L/ ?Saƣ@b<)K_,,CēuG/6&̀ <Krƙ*^WFI6ħBNHtN1زfAQC/8Wྸ=Բsf5T(go`p2`P8#T~#SvQɋ[nzcZJE `0U A%ՎQ]#n26EiC|); &k3h0*3wG}o| 3]̈́lx[yL_a<4Ԯ7 vzDqV<]sv;AD67RA,kK|dQc&`,wj`4PlHKeƵ2Cpu ءB8kl)tc{6%?$ظƗHMUBAh ܆x#Z!}Q)HݸۗH6.#@X,nffcЊ8j:2iY+ntJ.sf]rùrE#\b(\>y$Q>qLJ)tvkS|%Qc؛$ǹJU8XЋg Q4  㿫LO6z(9b|=NwbD:%xs~Fbb? Q $Zm-A1W*?4@)݌3mS &$}b({))5O>cDaTRPfeյC(G0U?JΜG@!X=V/nK4.쮇?#ԤFx@AcAyJ-۱- o=O.i'C•Yzd+i֜= b]I'[l yo؟o=sш#+ k.Z%xQHSFe4Xd > Zs8X1 wq> stream xY[6~_a䡐1+^D٧t,hݗ$3#T@|y(YlO- `&;w ](E]|^|-hLtb}rEXo>DB QmzGYſo~ſZDv?K|5ՒsT{G-x[֫JhRx$ޔm'"NjUDr.<#ay|&DMHK!bJLP]`BD'R+gVB O 8uDHԝiYa<~&qe-V}u m ?MEb̙ŒWI5*ZyΘ ؘ]c3 /ȋk2oI=e†lg{-BmCr+vvm2 t"MC/`XzG<[CI=.͞tx [[a?m`,n[R]>[@) qv8Yb6}ｌAR}Q2  88/CZϳ94$8p/NUө+Ruv1|MxIAwbk rP4km6E^iplAsBsChxq>|T | vGٓQ -]u4!1 w/dx68TNz_SYԤϣɤ(ȟ'5MNn;ѫw?*^SX/fAc sڹ8t|(7﯐@2&Q[T=*ooyĦ TtNfj2_P@Ó%Ƞmoo&.z|Ҹ lg.֍:yc3{ fVC #831)I_T*fz* ?\ @ۧ#{kkm16 ٙ wY# >՞ `Zis?:onbޗNe׮O4@٠PNp va\i ,bV%䣠=4,dCez7}rfHF}x9\;~ZIp\9. ̝j:b̈N/aҝhz}+>Iȼ]/~ǟ!B$ endstream endobj 1506 0 obj <> stream xڥYYF~_!`LV}Nc66`a#fH㷪4=r&쮻j/XE B3.6?߽a _ 7LDJރ>}B#9.TPC$̨, O *sRYe_WOxЇ.}fCD18/ؠCo>k@a+$FCbq;'2Qʼn>wuH,n ַm͒!&8$R0QGHe6=E`ƌI$U푺QOeK,ՍSl6mm⮣HR?qS둁| 1 5oq";7r~uziXTgAMcs[ǥ›&i4:ivҰܠwܺ*1pT}pS=;r0V,k)OeI_Z)J/UK`{(o|B!m' x]_'Q0R*ǐ[ D3}J? v G~[t {16u'fR:cg_"imQV>@wel1j٪+]/Bm'=$v^?}UѻI'a ^ & _,ZTی,?.^LQ[CXm+7h,`I5$aPAGdS[+m/IJCi N 2Ml܏Mј] kf\j,,Mnk>췦-p攐]9씘팩sLϦ pa.J`85ڣ3٦,Q=$4+m.Q$ Zb{F#F);3,ܢ2?.dWD/7xyw绺^("rLPYC=A` ݳ8 = $bc-`)Cs u][LhO+k(R[ x} ʰo\4խ!-u[ P+f1[jҠɇ+؄<1oL b,'2bЊ}2T1¸ UhѰmc)B{_uQ/(z5Usf``)? eg,Q{},gʉ ET8@.CC!ht_we<^fS>Viw݇&٥J|Եp>\D=F] YtOcbàǧJMPl,3CÌxQdDԭU]m2de8 _if@G]4oWAV9('q-ǽhlU\:eCyJ8 NC,O0ރgcHL+ Ⴧf>5=9(t|܄FY1 (6iJW)ZL\EEq&`,M@YJ\qQAL%`wTIsg,=ԓyv2|'8q(6J ^"G)fD7Z(N"$w`FT¦UMV'@nȞ'@@c#?+llҹhMS%Zl] 2(/ڙ+vpIBRq Oe6,f,$RN,s@y,%ۭ9+D QS`$H.0 Û{u;3rsbu`$ϢrO4VTBM`o_g{ݚ]9$Nz>eꎬ*p_'݋ lj`Nfg!MaJTzrp"F5yc)ER۰mWt(zl<BrΠP±Z2=I8#1<>13W\T}։rß{}VP endstream endobj 1509 0 obj <> stream xY[s6~`&fgNg4nIi&Q̀PX.j)EbeV m8'HLf[ٍy"Ot}L};jnF1Z?oO"iYwjPsf'G؉.)vV2~r`Vզ\Zuܐ@Bo~%획tQvwð>d:뺐T,e-%ܺ:3(&awïo4j2EDWܶL+m}L(DȐ3e5:͚jF0sm-<-Mځ&\ukJ i\-!%e{_x&a1x.8}FCNHoN6npDP lN8154y& @9F 5z&NIpݳgf2/{ƱuZZYmzWmUkgզ0\_i)}uiFtʈ 'R0H򰻫!K='T)p^6pfNkejpIb̼ܫ SIHnH)>D 2ƱTAai$/r-8'JPH"[4NzRiXbŮPG,>+")iu:]J=*Atvm}: `w ѹ-U?L쵺[`ƘOi*ǎķʩnUHԨrt ~>ipbX r?H)ux^1څI1X4! v#~R1O0JDRqdO98 6}ۭhz{#EȠƀCƔN|(sZ1LeƘ}?hn&)uʢSL&?#B)!;,4DӪJT<`aYZI 0jUJ3ٶδ4[]CBa^s _MyEbԫ2]9uLErJ9CDX԰a# e# TLfTY8Ic~4k`z͡N3ڪ,L1W71 ["2)4:7ybii_P\jT7i:GM]c$ւŽz43zx4ތkZwMVAȃ."Ugp*k-3mJ) kdkCy =G=*LC /r;w$&F"=p%r#ʠƞ%SCB%kWo8g pln'; 'JmByr n&no(NZ\ aꖣ6xwm73!Ͷi˒a:_N endstream endobj 1512 0 obj <> stream xW[OV~ﯰT{}n,\KVfLr .+wq'CA0ofb}B ߾5]Zߏ7o|/cd,Yx1}4OV/b#ดR{iоu\/JG"$4o"»X4"Dk[=.7o/,Yrx2['&:ViWIo(v nҘW: A@eMI w<_/f^z}, 5 Pri%Ƒt@SLc%zŎ完b˰oDcz rey5y&1t)}# 8X֬oU2?8gm A0dz{_ z)VOkYų45RO.CmVƘW"ڥ~d緿s2an6fm RcHt0z |,yFnz\LmeBQ_?db/'RBB'*{il3 ;:w o^\Sߚf_{}xtvx2l\]\\]秣k;K04qk@IѵA`B*02 axP A6~NBCu g~9 j@ڞ'R)ofble.ϓ$kKDe*gA؋3kM6ddoY>/ߎ?~^ endstream endobj 1515 0 obj <> stream xXMs6WpC &I$N&"6'TwAZXrұG HM"z2'(K2/#Fn˹0Pnt`ƎWE^4*Ł}qiRE9с*54|.Zx0ZRbHJ@LLլQZt$l} ]2@IXו5-)Aȝ@Bg[E]|Ig+@r(fZ6yYhj_$5ϮIv_Y/F]^:wO2^Y8U(R8olЮ RRы;gjWGgTۄL3|78S4wMh^]t]gpF.l H !g2s@E⥖c!BQjgzr!3 a-`hXkϴSV$x}],!4W뻋EGlGՕ)nuB2?@dwq=q ֆDmM+ΐg v>u 2Z}W)6\|_%w?SyKG̬{V8"w\JL{ pfd1 ˥O]D=ꎿ^M AGn_&\z"~kuء-5uٞ05 Mwlު\>}ηIjбYe w:pt"|; -$! ]{%E: a1wƼ}mmj_!.7$)y?PenF8@xx7$ = t^֫dHyՈov~*J-śL+%q/8] endstream endobj 1518 0 obj <> stream xX[o6~߯[%bś$O[AYfbmr;ȑ\*ې@e\ "^B7jxC<I4é)ԛ??.U+ 8: BƘ~ Hςu)Oӟ=9i BaE`^YY!3=n<;D^X@B@$iꯥL֮bU#4WiuDգ.b/*d6H1i,gǀ+J ?;tZÈ']:FZhڍ (B.1AI%Y.d]YϲҌ!uۤEf32(sYJmVEu[7ˬ-j@m6bn^dJGTJ߭)7jDUS5RO]*v̖…c4H㲐r{ z(ꪈ|SB@'` ̂D><2eV ?繐n>Y~W;K[&}ùx8\Ͼ c3i}B0 ZE5wg)E|zz-*\wXL d9ys^*o)&1M!PmQ;,NQ!aɛښuZR""S f8]L g;m‡Hpk ؽ470퐾QG c;$IykDٌ tT!} .lpgO {|$=Y 6Y~|4sY"N|NiuU/R7x8ί_.xk8l$9_H,OJsf/~uR\5GR_nUvQH3ămk >g{uʅ1[}sJ݊T+Qb~ڣ endstream endobj 1521 0 obj <> stream xZ[o~S# ƙI6MRl,mv[IԒT=sI%n E3q9Y?8~lϾϾd@P8̰0E~a tPݻeN)]T6}s0lseNbuÒEoW'::J",g I^U^朰7үP/*TejBPIaEaH)J(.{|eYNŠ8[|,0ի^Cli i}xvt/Qb7Ԫ%*?>(Prrmq^sRw)ܫN?Ǿn~W Hms[Ɣm۴.GiF@xS9|$i`5QyKD!ju;4W72Uq~AG}"E(&b#ddnH0w*,uQaC4mjaSHT6Ső$%8QQXL*15rf?^b\dtANРMTI A>PH3L>/"4b9c }SZl7rN&# >0"fZm`ӧb+zYq!oT8(ƨlTwZ;z뚈M<6m!ʼnh[k@~vjXN Q;~zN, bϊI_!%)kYh,!\/QKA.#B{J ϑv,78t}u0JXV!B ǼgC I"?R欠 GsL8:ff YJ"ke\\4Y -[7(>QhIG+8SޮVj~Jo8HI,_2MH}X `9i/Xß$( :TRG_evsk:˅r,JǡYֽEvǟk:2YO)=C HH \m7vA)tC .M+_K2xS|{7Ţq0&<&fZ(!)4*""PE!U8VV>d=ý@*N E 6r;0|m PƥuӰrS'zl?h{=|% G$hF4VvFtsmz*#2Y4 sTwz uXչx@IgÞ"y"\Y܂<rX@0rBӜ@_6&e3F [[ff4k J@K7k繙M'`(&zb`_>A+=eLCL+3s&Hd{ pce$ĴǔɘW3u`(#|6]Ze*_-֪@1Z S50eAw Q-Ë́ O"" &Vw8Og@ FBi; .d/ ]hzWbv s\> . #u!XyI9{X ai3-vP/ bc‹XT;7[3,̩>-87T5Ȓw&E\|7[3.!qEz{΃ɟ4D;}9<) U? endstream endobj 1524 0 obj <> stream xڽY[o6~߯2`Uet ES`Mdɕ;)YrhF"AHsWq0'u<(1q&sDa(3}t[$Zs ~swYz4t<-4yp"P@-5O_zo|Fv5Y2Yxa> Ƒf;urw',y <-ϓOy5;ࠒ!"Qɺ]˼#79>VQWzFu_%i ((=Zg֣L;ϼ `A>jvb.FޏCXKR\[,G={>Hpv27_]_h4 >eCd~/4=<0Qq|*ɲYGX.44|CSL+&=;gth <0`p~8D8xi,7[s3>ݭHɼ&O tnڭ`źKY뱦d(n;NWj7dnn> P8}#UIocfD1eQQT԰0ߎR/:L=:9ɲ;L"xfyWd*Kv0t[W#}^9Ŀ|7zO뛡@H֪"y\ɴ,{d Rȓ} ufu~^/ҲUp[AӳAhWH%*>:_@9ɐaP{Fz}3߿^ЄPl=)>hg GvN5 F|g :b aLQ8PQӱij*(d!LkiNԃ54Efz{UUWYE3rub`]JPf7+OWI>8%Yja5RJ_b+ SF¬IyrڼlXh36ǵifqNԈ"Tu=㍥F̪3W\ Qg˙u.5 - 6e.&9&Jymvw[vd'<bQP}Gm[h#W4nI<σC1!Qv r*T>NèGjPp~".>?=t"6,o1% 'r{~׶owL?.bDTnS'tuVƂ^Ӧ*$-ER*}ɴޣ:܅bRBM4rK9-K 7sUԛu%MRYkM@P[t਋=0:qy[urͦESg}8UOU5@BRGU# NZ'*9beLEt hl:C%Nkn[5ōCbER^kZgv;oT290*u kj= /8mXE ͤvۮP߽?gR7Kn2 m Y*"l+_"qp-/Aѕxe-)X$#f rj7Mrs׺+keRbj`/ʜ'`R iX5N㨽a m?ǫBA}P\/^-k)ϗJ!L:8?ZT endstream endobj 1527 0 obj <> stream xYmo6_!t*wnKrՖ\Ina?~G-v6!AB3sϽN >$EEEb<MƚY@0yB藀2b=><D0ɧv],"7kͪ}U ""Tu#kbamTGkh9a.ead*~x=,\:+N ۴QH2HjAΐYW.f4 (r".h(‘2ciFQ2LbYV{^ǀXeiqyHXW"\fJ櫴::k س'6J|(KOAOP$5"pINdt˙tr/@lW4TOj4@ja$j &ף앉u1AI[^JI-MuwS?H /( a*YY,쪾I}di)e肟iY6H8*( .  QCDDZ`Puޚ;O *=+[,Y̼>#)򰼐hz@#L.Hئ 7ۙd}C5kVߘ)sF+D a)y~+BRC%BV Ψ,?25Kh8\H^l9ʦc?;/#lBSCB2N$1%zkI!jCJ/-·80b> A:"Zjx.Ƙe=lhD1U&oKX˯,SG{F<[Iyݐi*ʇAY2RftlK>"S">n#>Mg g*>*) y3@:A ny`< f-n| 9ڿ1%^1Kusl֦)ѲkŶfn=9u<S2g[q%/:ٮ(x-Mtxw8)&3BҲf.W=Ƒȫ: *ILaaK}߲Eb L#qAeQFe_-Ƨy\@Fѡ>=x;t6]$L 6"8>}3vok>_~t>zyvz9:>O.m<@ɳ81ܟu3?D`[|ѾJc$%luK%-Wñ(9?h_S>%d%ffGwTrl_|B/㾻q{ia^ĽVf1ωa;u]5y\N1pcf8j%}gKe;Ydn\zM339poA endstream endobj 1530 0 obj <> stream xYKsFWp3[e̛qNNbrp*** eV<,)@ jeJ0t|nb$>,x8F*V888 0E%Y6Hn74M 7D6Uyw{0G ``>1^aC/z4튘B fvL I_CjG*+ P܉ؕ;G]u6,l#9:2H9J6zɖ; E i6txߔ~uw0̛G Df1Νn>T!cc2nE^QPIT}^T]3K]3D{s}cVG  <#&Q"ոmM$eC>"F\N\{4G X+[?`5ѡ*J G*8+}6|F;GJMxu#хɰ"m 4돐 z2Ř5E2lu`$qoy Y>̬ }sD[y#m]6m^T#kؕu捝%q*^0ǖ.xm^hA[ xXWe_A KIԦ}a3 H>)f޸ uXK3arе񣾺iwcL̨&;0ܹn̗׮bф#J@,M* ۔G~&3I(%)&"osf6 ~Y-Z+7 6l `d6>PK:c?X_m܁ƛ7$9^?Ӂ 7Mwbyq+ m5%N8:A2܏qQr՘vƢߏذ0p;#ܛ+CIëB;?S-Me>19 o}U皌12i%i^gbS@QşeuD@r2F FC )x@8ֻ(=^:]o}u^r*H B}o\t]֪#űKs]$PO8r/d`ؠţ Neg?>4wBAգp}j+ rYvaQ+"]?Ypj+ò=}; $[+9@7.EVTC2k6Ye(tVySiDѽ|P ;ӟBw##1OA:q4Pdž8!SC ❚柅 v]B͌}{-bDB,Q gwDrS ?L[,ꧦF:0X6UCҢd:v쫽S c)!9s:\ݗ60ڦ6#=swUh7N$&I,x"2yv4kL:,j.\h PMGyƊ-_=J.;xoT)e56fnYK) $P4XAK&q#94)F1FsfaoHїg?bH endstream endobj 1533 0 obj <> stream xXKoF WVg=nh.P%A'tǗ"#Yl  YHGѧD~H(h~XDoӈ`Dۈ$a(IX_◈2bpڼ=plr~{l<׼޺ٜ&j匪Z߼'2)Jwvw#qS2ŽQ%?g)PuW(Xp4' IƬqs3$ /; e,bECj0Hjjo*;GiQ죉6p{rDL4&ҋ@&@yH%(ᩗۗNҙ"$^eyݺu>W@\Qi0f^ryǠ_@(ˡ`v6?J^|6ۢWEl#A C˸ g~UL%w"6[d!"?cl+ ˾a4M#DpZ)5@lMFNu<% )#V4 %) ,0ĈC)M(b0I1;ܙ&P.ҷYQ`*tPeZ;XbOaE3r_Pj&p  2}3Zr79zHB當4.Ry̋gB!bwʳp"Ry8og62:wVccaQWg`Ĝ$0=΢D ]j_E]uӕ},OD9ZZ*:K%iRP~ve3WN4nfߚogAffuW2k;խpSOqN`s~8.DO (")0.ʰu  0&rP?GqM~?N0W@\Rrn>pN+U\u6έ㔙PBɳ{?Ć*nKlen}V{IWQ7fK\>dzm5 TO>ۇ.L,J$w>Jp|f#l GĎO̕7h6AmOTWںĔԀo2tk),N!] +ĸjBs|?HѠRzuk DDDbb[JJgN,' QE_Qg;v-}.Iz2*b5^㡳k3ZlJUcŇeړ>sͨ\wN7@1g#g&qT” K 5.aX <d+Uq~_ endstream endobj 1536 0 obj <> stream xWMo6W)bM)6@Eź9(P$ͿPdɦbE[bș7{@ ( 8X<̂kR`$ < fmxbXHysooU}wU췀$,Xglh=f2ER )JoZ7ߣXPg~̣yA Y-ߞ"~͊mNJX{j-9X$`v]rbFϮh%F)Y Hp1Ģ:!HQu9t0d[5[ݟvt‚qz @vN} ܈0JR~nT^b >9<;z(Dʇ;0QMCꡡ Uz)(^uu_|fft̩QLUAi&vr0Ӌ&+XM'+~q5 KTTWW˾NLV{е`'gaNw}\vw88Fqk)?)/zTN Λ_8 $ *jIOŻU&TH2~)vӈiQ-s*1UZߖ9h#SCQL$­s}6tZWp)Ȏplǃ-{ +dhHTv )?^3G>dfX7U(hͲZ{E#" ̡1 6ilUWkȚ\.&9AYYVͶ"ڴ5v?<жfμ̡u ra9+`Pev_xEJJ&C '0@f(1lpbE|}{QMpfV%@[~_Y]۵Ct˅k@3O֦@lXDH̞U[L5yhH^/l.1J0;4wM&H*6$ץxo=>!ǒFB8@vb~crtPunVқQ}l 9/rZ#wɠ %e잺zY6eoKMsF뜱ڝ<2^a6L_| )ʏWi 9A,cٿ gc]y 9E"QCP &] 8?6{5K껄nẅ́YO endstream endobj 1539 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1542 0 obj <> stream xڝY[ ~[t)mOE" ֖ڲ#slv}%"9[Pc .V/%:x,D `8iV= $ق™(Lyѥt2e{X*ͫՃpV" O%&?,?ݪ9ePp>*X粲j}ZC/F Z"j*8aN$J/:5Ii[0T5~j_mn6a~}#m>|?3]qaB>$OMX7}kyn?]Ӆ۱70:tM9& R8EjAb*y:}}Kix-4PE| 6_F+.%Q(_~ 2˔OaZEݩh[H%("Х"1f@=,׭;p4h|,$L1̓Y7}ɾ1[[6n7>0O&|"}rXPL/SP-ꓒhLn!aU.rur%yw+^dp\(eKLu {eKy5{s킩lط!uo}3lcQ MÈ37U.F=W% ,QFB /?ϧ?VPJ!\L^jX>6+,;l)TPR5^{7"]#v.8"'fr6YҐ oL?X7>#/$XAiCZxb$VUռ#R %u%-u)VbGd6T:\i3ttm1 @ƾ15CXCdtkTqzaٚ)[6i[9O nE(N;dP+P,ܗ {T %b yZc?-v8l(9 Ⱦ)LR,%<98.EGMha̵ܽ',Cm=W>]U9@=[W)pw#G$>64 2LP_=ic )]DĨp# (vD*@K*P|yԸWB  WclJ`N臨|k(\nWĒb_9K&a[} ?ȉ15_ӺdRL !dig˰:2 _ٿ1т">|d9`&r %SFi|e"Ҫ9K-~֌lj".Mzf[lWy16D?dC1'or=O{GhɃ-Dfn8Un3Em4z.xt,_'\׳d")#R _/Tyl?Ńw?/F7.cY<`G ̞0Yoτ(QrKHw7͈b:#ҹ2@.s±ha$%ZD6!e5WOPn+se΅);Q0LG<UgkP56xf$23WHX>}e&#x!,x@bM yC[("P!jA]q"sWnPCgt6 aFOrK fhJ@L\~lf'4+/@1T ?G3G J|S>ѷ/3;9 BkPy{m;n|]"XXS|JoDz/+@bꊅsXzy`S"ykùt=TM~~ <4Ϗ__N]Gdz97;t?6c2*ul+$%gb jz{ס&#{tm,hI1T\ c?7oI3~$S$A&`sQ/<ʩ#Z|.t{N<DwHߦ|ܔ\o^!ЅWHtWl:B}$uǣ:ۻ!\y>Sg#vjd&]>q?XIk endstream endobj 1545 0 obj <> stream xڝZK۸W*HNNNx˓!΁#Q%qV<ʟO7Jq$Hэ~|ݍů ?X~X/%:x.]0A Xp1~~aBan_9,~0fXaMq^ I:*+ej.dZbA(e? [̊[ԧxmjw0Vvr4q \2n nWiϸrReW jՏCoR4'k$a TGQ\[!J:ag(ة%%OƉWf_To(,/S;Ņt*N6._o(DP*dZGS${g+b#S(|7H4@K'?]GApvfy-sa?;R-QOU5OA[L$4 W2REĮ})MqDi$M_]M4)9ۿubaY1aBV<{$pnOaΫ;9 (0|cC;!#uptB/'@%goY2hJ q 6qXa) ܤw;U ^1 pK6<@ wt6Y7nx8Z؏b: L:ሹ;uKvm:` QUYo#CG=sZtuޙ:;5-(KEeO=(w]c&}`ԟhBYd,HM/И # 6R}-&P|}_ \aR`-H@/H=Q#0$ƄH0ʬVDPw!c[h(1a Q+U=qX훾 Ms}OYY_E] Dl쪋jo*l& >ez?>,~]^CFӋ= I_sOCŧ/ٓIJv_`XnN{T2Sc x6Ln0M8S_yS.Qsޡ~25_)gWUbb .n3ex_7Àk@َ^CHDR"y# §*{< { 9d8 @2s t^$PQI"w _~hCh*ikq[dG{=W!-LnEWUɱJˇ\ăE㛨uj7x2 #1YV(~8hK*yrXwGV؋_S,Z*X= so*~te *ɸ̘lq*B!n"Rq|4zum0j@j}ѩ?[ݜ۬ZQ& Q<t#<ź[{ i@Aw(y䃭SGwd .P.Sd 2mۥ dX|l?Uy 2oh+'i@2c~5q endstream endobj 1548 0 obj <> stream xڝZ[۸~[e Q}H<)`>(N,Ė\I>ك C;A#poo#7Bl;m~/j#3QfܼHZmtcoSu"۪"v6I}I\JjMCsjJᤡӫv#LRCM?/ERZBnҩ_VGƪdx9}YjA+mޫj$6\HwK_,oNw9yoLq/TS\9݀;Y!d]zm nU|!:+X܃׊]|;iIRAZz UlAR r/5ٍ#znvpXj\ |#REpUY1!7} 44|>,7\@ʏ<@_i \Ȭ,$* A3}=;$lf;vnv`047fo7>0\D\O*a/GԴVQiQ*4l_- ?oۡ8@8PgNʂRЛm|9-g|~mP,G8 [n;fcv +ߥ"?5o\4J;M0qB;T n{K=ӁGfRy6)l:W,)CLE m65tTQ%,| 0L/X_$,xx.runڀ+G4-8k0u{4-h{ &)A߄NA:\ gn089xޟo8a 0yL > l 0d (1 ]p3,L/~maQJ'=+fnɅpycŸ8xebezVh3Y^-3]+i8z+ڈ4lp aےy4RDTZ:x ?Am:<&׷`_4ȱZDf$) irEV o)YOF 6j,nMM+ZI ,0E=T6T_JYj{Kj ć0]}[!&-)4'NLUd7l2qńxgo 6ܔ, ,2u]0m":l;f 4wD %+frs62 >z]z畧9#>; dDU#*R{Pºi;KU(11@ۚ@r׽V3/^q V90J r$bT\dZD"նlfNS[\V@Q`M,٭R0˥>"SW iSt @^IMGe ͳtFc-L^2(`?XzTܻk#Fr6t2Haf aw|.UD]OT<{j,i5,f_1x4Wf l)Z,tǗ3@䊩L{ r'ASk9}(*H͉rFZ*3AYU7h/ A(D7K~%d؜~y?!5͵dΩcI`y|_Dj|@|`l83)/SMGFZϹ^4uʺȢayl@wULʥu+: xlk$z& Su=A-S~XZ .|:v9y G tTLYF44)efSB彵`nqHQo\6;co( QjN1L*UsKIQ GlhU^1Hx-[. %JҀ+[2s0NJ2t%sy&b ?uLGBtJm5Ow40rڿshA$TK/2Y׫S|U7T*OrJqwJVw3!+IQjreI<Ⓗ?‡̟Ij4 TO0[,)~TQ>+2H )t44?[}-ogZz$Zם 嵛NigDRAr$HJ1o$#%9(n#-#q"PQY%iL s#ݵ.S#5"ƠjO$DA8)[98юE l[flms/Vy?rEkSycI\"Y8r煮낗N> stream xڽZے}W-}CȉYVuR ϧ{nJ\V Lt>}f^pGw FIA _0`.?,cwݫZ,ŋvouwwԮ.7}լYnuv- bt~Ry6_6+ܴ{Tqo}D3Xq00dBm`=Feu~Qձ +% nO_Oٗ-5yaGV+ŖcPen|0ۨXum8ӟmΪ)>2;xy6Lp0NuS S?B@H;ݒi%Ũ|[&:Plngzla+u\7貅Us˰Ѿq >|-,ʱ' `)%fy[|zn[J;:"{ 3ܤ!\ɺS.I|'sRP0A³HiJm򣟚S3%m{,OEe{{ )›_z:uX?]"dUk#UCA\)Y>տC Q#ZpC,pa$cZ+͗zp[yqdJPpJp OE/T w5.eWmV,U9V7 fX we w]ü*AǧL "%Ds>ĀUP-53?&(ZLf-! 3P(oң;qIE%蓼QDHCxf ,3F"To>Ύh~~ӏmr 0c}w^aF-`rb]`;u~8fBRgg7*ۣO7Ęq꿩}}"[f^|7߾Y~-#Eݻt飧߿{j'~Կ?Or`i,JCD*.H30;oD7#L':b<ܹ@3q #-wԣX>$ ,_86 5ZÝaF:X}TޛoG)"Ț(R\1K`հp*.Bf3RWgEBQep1p*p*D4X0>z+e#3\Qiٔ,KH;RfiSD}i0M3\}f2?簪`@r7L)QkLr1ə4Rl%ieP5h5xqX"C? )CYD)%"6e"qv5 k]˗^8c#R㓘awjub>XqW$ =Y&Fg}2ulcF,Bwr_ƃ 5/nŷ{Pi?b"1< 9͌a fߴ`O';C?O '2u4vGijl ypὟ-+lB "){{T>4:[%4EAk-)JK`"mPrLڂ!"= +P8Qt t@{~$=$ =2Ċh//_M pԠI9O/e] >Y^WGX2ؘ ^Vq݀4WĨb\a͛ցґs,rxkq8KƊy wi&9.eX+Nl!_mr^[H۱zH%%feB=SG >rw4 ݞ8P _\qʌ W\ˠ)/F6f X^1oqAԱNX:=`ajS^hPI&lu يė1sBdw`ދP'!QQܛ}QИծp459XH_pggٲUҪ8f3.YlB$θu8*Ђ~ RlR: K\;'NzKB/[LnnbMO4>̈d9Uj,EtV*#ƖK&v3s5jE`{J%TJ/k諠u;n\mSM S"9nz`:*Z^&5K2gJ9a SpSQczDπiLR. כJ˻_ endstream endobj 1554 0 obj <> stream xYKWV y?|*8V(Mb%m~}g @ȍc~[le8Ypz%:ۮ]1A/ٛbWu.nK)knOkcu\zוdha@ .VLp;X&/ubʮLn臫Xy!ߩ FJM4lCB*|,kn3Oem=s[)jN bY宨 6q.T =1YU.i"49?&!1VNt~W5U}ݵ)-PHx=3W=x ^ ]T|8ci gH_1::dPZzͰ[ͭ&܁&hE(:,.mwh#: LhtJe.U~Wˢ hIXle?''by|v}H=PHJ1D8qqBAVRIo~ǟ/' 6-OX2">Cˊd9M =.=R"큾+ Id_Iۭ ʸ nwD6u;s;`#)[SL)~W( $<$52Dp&EgwR9P3TlX5)JPAp!<loN[s fH^$^cX)WrH-`(F87ͳ7]{F^F7i Ok{VZ2!}<MqF"b/ /5~Wu{]+l >X1.$= ڄ6īQ t85 (cb:=wD nd\h7Y3M}_e|i5L S=.TU9Bj$I cٜĄd:A=UlW}Ksxl Jxp&4^5Ux^yTC˓GcH=:68~};i~ W#4o~n^IB g`eCdc  mpS[.u=X\He~ gnOD)7srkSq4I1Uq7UkOEh_}!LDӚ 4:gm[ˁ RdW "otN}zbZ<r}5]Ɓz}.Rc"d66›j ͎#ɫ A'Q0K-$M}PasÛz X"FF@] 9gO직FĤQ6 wX'Ʉ+6Lf2e T(z*V5c+:?)imјr>i b. 5,nSD 779XlF{aÛy\nО=fnTZ>6_MK.l[[{I`81c>¸P&-dڜ)p^l?ˈ"Fx?tT ~ 47),*:$I0^ X7 D-Id!B-lrwàyc\3J7+8Ik0(?Oarj8|dkօ`~MH׵ TN.?bi'B52at2(M]^l,g|{71ڜ{g<} %"n?b endstream endobj 1557 0 obj <> stream xZmo_!D.\\Zq>mDξr)/e%MQ`Q;;;33/Jr/^|YRH3Xp̖?]uA(ARRxW_/WҢ:l_.޴}{0׬xGwv"X?Òb°+?r%w?ލ ~2lkwc~u{ݏ;Ck+6Y.bp矜(H2Je# wSbvج|aEL!Eb%Yrd_4ͬn*?O 1%E5EUY 2fډ~m:#^U20! FDJ)d*~!ᗵ+$"/`ؿmk$ :HrvgF *x,7Ϳk7j]ׇkKca=4b1XA̧-ƿ5s"0 ;+kEjG*ܨ"̝Wm}:+@T ]!+&P`̦q&dgYi&I%:91*&'Ѱq-Ċ1ƍ%#`[ UkNu}4ѻu 9,iY GVX6mooWﾾ' $8%XKRg~*;wu}W_$TM? uwq^[nf75n9FcF9Uʉ@B hf`2y;.w-˳qTo6YF`} J'y,9WeVg@J4ņ /R?3ϗ.LHUT޾u?5k D -ĢlXQ؜ L&]oF~(p͒M=ٟ Q3󗒦a}j-n}l!ЉZ+g>_0mV@#/aowM:CJ U!VL996N,պNQ޼)q=T$QS5>56HdAf[PWFvWY`ako0aWVm pDfah׍h\3@ P05U'HrUB^ I&.h,(-Q,Zcջy-5pr)*&gVE#F ^ 1u1ȧ4\׀l^PRUuiDPN0R&3GA ; NM.nn4[{3tZG*dR=h*Kbe+<"-kLbāzcKԘP?e 5G(K:(fs+q2CAhm`PL-lCjacz3Ө#2sRCTOF`iR ZNg9)G<Һ)|r2AJT!RUHMmcsI@1R\*<+ )!d *B6fY Fzc'qrROGyr RV :en<fQU` q 9^±TIg9* ()3*pcfib,Dh["͗>oTӺ{ȃ%jxzȳ3Y f}զR@.^aȑep} 5N+ޭ15Sn]g?f+r, ,A^ϩZ1BfKv7 ‚P ˹P@ P c!g1jn>_ƈuP@] P P9sI3%\ Qә`@8 6TQLA)R7@3kDB3nܕmCoX裈t$6:ہ 3<2vKߚ1}OU0 8\bMۺɫs_x7jȠFџcixSSfNiZb[B*g>hNJ@Y !R'|4!2S|.I p .3HhSU>aIݭXu=V#3ݭ3O4۟Ym#܂]1S,8*4E4bXh%$lk`T]cZ^cTmhw?ØgcI^d#(?x0@ RA`#v퍩gM[3ց-$ (# !5#% `k >}hLP`.gF05^Mǔ^ NF27n#I͞co3dtdɋ9A.=||<ژy?evʋLܞŃOaDU&{{_~uhu^9~fO@8^]>0ՃlL zf*1dr`e8(N*IN y /&HfJ!$ޙeJR9&!u؋uugmZV8iC255rcȀ!g0)}gwUrdjSҡaSopf9_И#/ ugcRԼNTHӱzAf^ᑫ{3W94]IX3;pTl6sًoWb endstream endobj 1560 0 obj <> stream xYmo_O -G\4gK-Qlb &N8IN' QJytZnV9E=(L6tol?\5halF-KqcUOjR0YI3JH\ u]]uV27)/_mnQwDQoiK60$ 't:Y/eDnmah9\pbvftVl2Zn]]솸LgGC:W*>r{*c>R3`6YJ0,\ku}v>-ˡ!H(y-A Xߔ,cW͆hi΃ς^eTdhͤ^_hj@vIZp%1лu?!HfMw"fIpB V[ ǁ/'\ ~rM&qBTmpH?Э\mPo؇A{ 3=ܷO4j!eLuñ` r<~[C*Mq@w=psr܃%0VRYBG"d3>|ʭ61\~C0Ę<{2k@9X;y/TVYq?0xvZ CT4!wWI xPEȭ{~>s*vBr-HD}6\d")*iŸur!YҭV TJkv,C~:hFצs4$>g%f6{ u* SQ5Qfz \'*`սěWŕ!_wqBb'ް|LSMO'=aз0َp{&рIXgaЌUx^=о%+G?E@C-)qS B៶޸>bHoЎ˷ABDّN-nC]{b{zZdS USL)*C9w/{_uD_6#sWd9u]$c16 >i~k؍:fZ׺>5=??Kao 3~oőkVj^ٞ3k}AQj^f}Rv:IغԸt 9_u7Np 3HuiV(ـ\0;d~G'*/Ia;AgO!)I9oz(;0_=Ã]t`xPNf-Vۗ|l"7iAT#Ŀߴ%Z&9 e*3!! ║xub}>*62I1zz{EZVQX1>5”bRAƁ5/ @+:TJR%:2ms觙z\qZ5=اFU}%vн|_|vG ~X1z!Yilj_+ѬC\:iߺ~٨P͋OX;=giXS$@4̴!yU@ף'h+hq!8>5)sHV 2^Ewq{zf 6i[ϥi±ٌ;슻 )ci<B9C7-Da迄p 2#~vS.>l)?"܄~ 9>FJgc 93^섋2XV!>dW!4V_n->JL9?geH]5vm'<:x2B ~st\=(z2/Ьد "^;C =ZD~>!u?_:_ ,MQwŠ,5[_$.94lY׏9. #N)2+qZp s od>6 /";Lz9whÌ߯:kȊ|ۓnbF|6"6rY*7nBj^M@Yo&9mr3/+I弧"w]wmҙN?M3r%; endstream endobj 1563 0 obj <> stream xڽZmo_al?Tӟ|WvEs>%3+Lg)N8e),1Tޕ_^_bI5QaFn)Fh#2vglAFóz_≀Qf) r8D0F4mj>AI.YxH,m[n(jO}jT03pb/'eRw?e۔z]5>t*|rc-9ipB% 2UWW [$we/+)MFUi<1 W$>xބ/Q 1'k=L)4v.pCbL 1^1U6e~J -J J2'*Zq9)Q~f&afJZ NQȂ3 bcz=EȎQC6Z;΢Fc1՚UC>ejVaLNUhQf}BDLQt1cIq>U:ά9d4ЊH\# %xzyVmIbUJ7 ?ԝë gUhM;}徼B~Uc5<2.w*Xzq\zouk|YKsĊQ$NIp= +3vnB,ȝϔ85/Z%e4{lvU` iP_9`qX @Or3T M`!1\ LퟶC] t R'  <>zw᡿.a t8,؛BnSC0.E-㣚N/k Șӎe:p'Ƿӟ^Z%毋s !ُ5q/o>~`GQѹC G8O=>kP,JT[m}O/Ԁ닂r#;lWuoMu젦;AhEު5M RϮ@ X~"[ _"XrgUЃd]gTf<y:C/Fr>.b}. d#XRbl̲*}A/\Uw~˥TK.YcWweM[$8CaR%S^2n:b|`´!w\7s ?#&N#=tsbfs. ;(4&VAZ`ڦ*f(pXg]зɾ|>-Lj`3nN %'Po8{u= N7D*9]nLz Oή vewP P~m wpq]htx$JqC8GA+V4Yd_Bծ%  6'+$W}^&{?PJf\~XD=v˥kzWK¸7i l|껿]pss˯oH-ĒZ y.T ĘJu| O;=~n'yIaѵ_- LpyOOABMajeC)Dn x&Rc&Λ92@ҼP艬7]֎E:]>~ N !*pVm:hWA _ňۧ(*)o~v[H^GU>irH,M64oMo˹SߚHµ3So)y^ųx~[Ɗ pd ~Ֆȭ0z_iJO|[=͂ӆ&!.RᾜPup&Xl>9eYmgT=bP>hu]Blr- $͆ W²"*V]k+u> stream xXsF~_A3r?C}ru&㶶L,aFPCBt>vv`!y>uQ`8[(0pLp]DcGcD#]O_93 NÂ3mbp=x*H^"p"{zo#ÎG$<Ւx(M21I4Y>>6c `,x#fm,1 omBfPn:m~0 #C@@džǏA啋<bC2D)0BaU2m*Q5hjE̢udu lO:} A'|jx{ՈaFMZ8l08+4y_f61sK7`,ž+k^";~AXisCAAHۇp( pefppfލ6.uԅa{hivYEɈȍܰV.7Qވ綟/k]_B)N%"3d31G=wC)!y0hmS%(H3i ,iGXv;]T;nͲ0qn>EdRV&4() 0@lZrp.2I|fI 00 uYͲ(NӂDlI\g^[QC tvRQb-A&M8+ۍYE˩}"L,=,"jF#X̭,V( לk>=N{ntjblCThGY4+;׍^%!3=zJ u/([pIZ훹YTl2=CWauW;.rIٷ#!i-< ,-GЌfQmB )((A;ew&t'o=U_hLuS |[6stx۬Ԫ=&=շK3 fߝ@y AUNjS5Yp9$^0,*/9lP;PFL1jQj݂ˠK#?'ZʋEn֩MyI%7HnvdX.BgHPՉdٵX( P~~D|曒uW5W`n_Aɼ"^$=b*7-;,Q2~MLz:T<8s|{9{>9r⽹&=,?nuvx'Y&SϟJ endstream endobj 1569 0 obj <> stream xX[o6~߯@N)m2dm.qwAfZr;$%[tY &9k!") 8M!FH4H2Fy,H:QFR NOώ c,˱[|-^TiU5_}$4G.TōU'$K2JxR­(I}7&DP1K:ӗ;V$ ąeD8yjJdQ涁]V 剆#NA6CD{4d!HQ-E- ,{u&x3i<.b_RSWо r Hpp[[baca3ǫ L5ڐJ^{bŎ!c^4E-qwC$R)U&$ ` aݠ??, m-[:#s!F ua8,SGn ^1myt>KgZ;OjI#FAAƤ5k`IEHBV2Wpk%gzD,=rϮp|-\ 'db *jR;F[AMPI (sUmf&h":,jؙ\yST%{>ǁq><| D 'pHϬ7yl(ڿ8[3a49ݡRju ?g-IA6c"8"~(=S;A=@)i&1 AN2l:?d 8520_o.{ $_qڻZ[80"ġ8pim<> ? #qS+rR7s|Zl&t2>o$2mowDqͼ(o@PXM7<$5(A`+©-?=ӸKG|)R|Z/@) R^Ay.Nz\ X] *u7RC3s饮Gbf5Ὀp~|!:x]*Cj uҊTHa() &-F.(+Xσ\7y~# WR" %\Gr!鶪jHxھ%WWy ÏMԂK}CEZsv2lwu@MڞdžH;j݁N`YؐAUt; Pd0V#Pv4h "jrcq nBH뇫~h|״Jqc ^:lP OvzAʏl˙^ J/$gMB?jv͛۝GHjH1 dchtdeYe\bUN!t3W5n@e8v@jGZ7nQ]V{#mvy;E25rAz9h!ۊ=!VM1BfBl7Dc'j [q{6 J|G:smb15Oc|nm8eO恤>o~)@ye.3qֿj4[qWFJM3qE7nRvsՖ$1JwA?o8!^̫(^z9.kGlZ XNF83@%ȩ7N $P&y0օw endstream endobj 1572 0 obj <> stream xZMW{R=@Fp#qFHD6nEr†ׯ^ς.RCt/z [Д ݼO^m&?,WJd:R${JIeIc0ΰZ K ٿP<7EU^_o]bE5w)fv _J]ݾzpFWfCI>V >PօosXWj #4D$=1o pIuE7[ѽl2&v[R'em’x$:S3Ձ閉DׇD+ :; jc;k1}U'c|, wIQ_P}[v׾o?>Ų-+ʀI[Os?~FY|u`C//Z0;]i辉)$珰#^mC" 񠧵_sTZ$7 db̿&!D]1;M(.QGV߇+L("y>$e;-xD RD09HA؏xaD u7K51h w#镛yBHWs$zP'4JX䉲&⣐oEhH!oG K^S{(g7a;Ҽ(bdfquXfMP$':OU[uGG3MOf*t&f@HP U!FSl[pT ͋^B8%fW6-u-d> osMwMФwB&h+](g)139l}E6zf4}YpLщ˗t58b}  > eދh 6II/,&'m`n.7W4uUBźiX4VikOeOy.(yኹ1 xu2S+ l+ニ^8_ PIOkhZL@Pį+C8hπ7A_&*2:+ЭcwlUÉ:zpkj PsCʹ|XDŎ>4oygO@cXˆ4 3\N٦r0I _aZd.>ዣ:5: 4 'DN;fCm=~P6yf2D|94l6}W`Y ʰfdm:#gƤb6Xz琉R;9 ssk~g{b9+j ?u ?# t%Oh=Ǡ?^ʢՄ],AwuPɓb{͏V2dG_q) 4sa%%} ͱYS%:ps8Ha9hrPVGشxMGᰵUg [ T |u`Q&uӃOי؍/ wGB)5r,* ^FGg̠V!eX6 %-il+_@=_KzY4%ISN"\TB"=l z*-xT/ܐߠ|G"в0U\|n ^hSWtF8L N,Wt↹)q7В3P߂ۊ!~ڙ׆~];)G(b8:%Uw<_7~u^.Mx endstream endobj 1575 0 obj <> stream xڽXmܶ_!@,i}tN]i#i{> ?>CJ:jN†w%9yf .a|# ֛$aH$XCA2j3zy*bi/?^~yUvUi]j$;]hݮ߾!t[B ᝭nŅ[hGADb$܄n_*dh P..6&!vVšqeYݬm9M%)e0mR&hfE iƁ")?{8{t~{z}b#1;H")_ =8)nz`tq<8΋/n`$vnd&L 0ffBaSts>"9Ii KӊҚ2<{F3U2wd)! K |೽/ TyN f(f$iB|;J8_Znͭ~;?9\9N ΗI /DDgh^%K$`4 8~1#u&C]<4U%c-Nx9hb\uk/l@~!T25'sǽf{Y54L}҂OAODl|OɁ/_#T&Sf~(S^`tKdJJȰ+ifyj@Sٴ 0uE'..MO { Ӱi!-jc9zѣ>gzh@h8r}HmPo$k;TRݏ/x8DDNV/h ʼn[뺪 bWio xԧ,H"kF&!7MiOB#:"8 gȥJʂ)-mo %wߗ% jFzzϻ*Ex(eȠM[_x^yZ\y̋-ʬ Qg.XF;$`?yE"6JKf)2-%&IBU5l𞎗v[߮+2sʪDRY;[>)P s4!"l9]yJO /&cDAS&KumAt{`dD)Q'Y`M-ģ@qk\H;Gi6cX{EA ".Fo7b9AUwzՔb6%(QGBZRBO?x'kc 96nsIĎ9?$bu{D=$T oW6SDϙx=⽔{;͟]ǚB)i4蔬S}vtV7s7Ug`]^$!If7ܬu2jؖ5DJ}{M~|뫿aLE ՘M/ݼY*}ǝka} ܋9< KkWbkxn# qQc8Nda"Po$2t[كٶvjqBYE7n:~Y4j endstream endobj 1578 0 obj <> stream xYkoF[ 0~ҦfSGX`#-n$J!u IЖ@#&׹gN$$$N䟋W4!lHNNCd\V1bqw3|<2ol=>D q Jׯ'!ʸApEusrH N4/WB曃_h7Cq;2~&(j_’}<*cB+[7e Ql0|UkӔ iZm彶Ӹ(DnA4Ҧ}gwۂP)o_(oj9=kaӸuXl6HQnd.ȟ2K$zL01j?nQR#z.R@ibXAȚqSʑ+2ʐ!ɿ*M+LL_&_Z`\d+2[*T h 1XV-X@nk _9e:ȣ$T?aH.򪅅Į}P]78;]{EDtLָ(m(d8iqL宬헃-=܊]ʕ„dP\Ok9\EٱXՊ+'RGL`YXbٴF cF?a0LJzX&9e| i62#A(mfwW ʫ;w/_]gήfWV!Me"Hԡ@ֿ׿xoAˋ?_$_ JXrp O9TvD&y*,vDM@gvnmof͞nMk6X@*juQ6T<[Ōj$#`?e 'reV7A<#+`0ZS̀9C~Wлl%رωb2@y >P@{|x۳JPD\d\l]OXrYGA}0<׻vQ 1G7 ~QJO5n"#QQ|^ 杣rٲ ]8mWrma<5'uXy]*w|QM⼉AT Tt.CnIYzS{LU@L3br3W]1sQt[ȯ=:9 rP8?- w>-rWt`m^g]9)62!: 9#ř/ro*Dɞ~)Ѕ$( $ĈcjXjCTpxcu"Fgڗ\E@TqݞpArWA:tWȍZ?M EYA OL% ] b 嵔'")W骨q:?u*g HAb>*[d Pfm˥q,ݕn_h0Vc9Sv7m+wNS@d By;em^b%.>Ԛt8hAo|ᣱܨq3+p]+[9?=kw-OjUl M~k'˼i0{xy;||B ,㐶}bpjh6آD_l\ endstream endobj 1581 0 obj <> stream xڽY[o~ Rjs բ7,nZKZ[D$KR5sBȖEhD s$9Ih͒.v|%4#EVdyPPN S*}^3a8O..?n]55ECݹ59j3RyǪЄCp"$O t2Frm\,ޝWbby9sP/8+W_[36庹[on}B/`cΨMM$qmW~1so`M{8{<{ϝ7圾M /=hԛVսi oGF˃q6X?! SӃv>x3L.? oKw%vz._ޤrK h.RP,[i۵ywӶM t3A.D"sZxDz~QnV}Xػ w_Ɂ zA+ܵ)[]:7Ee͍~/3)S =t܆BNQ3CYhX5uWzy2vEG{M];Rڦ۬F\* rTȟYa8vX6!ƨ1F{B`1>Kl5mq61)zmkQiYN*& ]C"t=O"LXUh{῿+(,bk]9ɡ>c-Ꮘ RT)i^b0,d?n6+Ɔq_4POIv)M'bP4c&)cJR W&θƈ"}9Qyrۚr4_BvO)@X056s+@?甥މjzcڪ/땱\auQY0~S(k^ѬiA޸ ;_&?'DJ 3 JbgGl` T!FV=PKWks} NB~j{Ƭ=>-+ogG ]΄id|xəg3@H-\,?MWe?0Ή$ ę*r{NT$jo[(11yT&-C>秴irzs5QTM.?h6iE|N]lr6:&e`xksSV#>+خGi]wX0 EpdѠJBD;ӭC4t e[J]0/邩CŴ1`.F]Kߵ;ekw7in7&aYgnf/}nܧc(`Y>`Di/ DRAO#СjyN 1YQmj/PGD$Lf ?m<3 =HPL<._QLe^0'ݷx-TIZU*7B6EiP±rB>@LXyYښ۲]EζB~c QZd~ci(ġX=6QGgy7a71i @霘\J3;2XǺw8)eBMnž'4y F ~ŬW䉔\:H=%#Sus)h1StE5.*TqI`7m ۛ8Ƒ8!dk+t zx=^ôtrr u$a@O_ endstream endobj 1584 0 obj <> stream xZmo_a\?|t|r{Cz۴EMj+ɗM%:kk&9Ç3ϼ(O3:#inlFI.W3(O2.|ۚzs#JO"z7g:\(1gDq Bpd܎~R %ĂDe$m &.󘩨[Hnj$YBae KAX0UyE,-j6F Í\`>hߠo7~m`ډϭ1%2JOM[gQrcpw=46!00z_k=inOiT4!R\/)7&$\H?RD NpZTk#f*Ƒ+_pN(@nN; ;ɽz="bH]~kPm rfN+`r*`4n3f&,K^!o{p3R =6Ԟgt{xzsIPEGX"iCfy`Ɉu|X:/1ψэ7m,Vnmۧ(2+Pt=fׅsPL YIF1ܔw^롍ջ))YV>&҅|QWR fTpΦpqO ѰpY GBvμ0 Co:յq!օ_I"xtvdl٦zahUw Jv . Eh3#2>87OٶI"/<&jF#U<ῥRGC7L>z b&BŎ#wX_p>W> v\ ƞPhK( /OU6n ýND@݀$RH!,+-ƴ6s0(iHy-c($d׀Ǖ!hAӃXhiBS[_+\}e2噵7;o0q 7A)!:i\R1i1 $M;K@;"GȂAdJDЏYMOl{HAztgw˂3T. ]Vu9 nf2eE܏nj$cR[m]{oT)M2ЅinsQrM=(!XIk`30 \ pHEY[+').- |sx0K1F8 񽰬c"x(]32Ww̗@32SG.LxR}$͢)J3YP0+!\~&lXrVD 0-ebˣѽu]EHBhl2!RL’oSNI;D ;X E awkގi{6rh.'؜xCXKnNȭ6vP[ϑeiٶ[6s֧i>]w_u'cLJ4HNĿB~^ eusU1-#@4ZgWvkhnGtnBDŽsJHԃe&;_LTWuֹ?g@Sz,L YʅD|0LW|7!bE&l-M^c#m)8bGYΐ 1AM.eN#$OєB[T=@d\z$mtC&8Dq͜}]U~A۳젏*}+rhٓvez^5, a49Fd N{n½/]f;R`SOך% $dFmߑ2ƉK'#4 `A1lM^s)ZPKM- '=@ң!a}\w=_c銥@7.mJ{V-{*̲[ gI#|*'dY'|N]o2/{>0E!p'H|~u Un ɅiG -_(A޳K(/UclhUjwDΟmm~-]AKI(1:>T})ŕMw/@.~OMK,RQ^-(h?'VWH] ڿP Br endstream endobj 1587 0 obj <> stream xڽ]o6+R)$E}yCulEڥ.Ptޅb1PKr%itlJtu!(sC1@/2bl]#'B6Ʒ : qj3 .qټwxҲ]5<WEeeE|V lerfݨkYFNi#ͳ Oo8fOwLW Hh؏q̋7|3HI:ADt7bJQX)--ӏ׏6CvQy#N"ogE#l-V"n!PBz;ma`O)Y +]sO8c#%0d4D`;g99U(]a&fꯖ {|~[B>]b]|~>~ȣW}T֐mkAigR[j qeF, !N}=_9|=ڟBZimz\:n]N1oQ9k0]x->nנ9⍅W-nU.\4惣C2o_WWpPovA'~_cv,'lj{_hdʲ(~v[B}~t[bش4_%{u#8K=OFc)hlآ endstream endobj 1590 0 obj <> stream xڽXmF_aQuyxh+%Rٻs/Sۡď̮p %qvgy=?BGVޏshH0ʣʣ$BykMnt5 8>@῜O3{;^zv'hD$A ^Xd>C WP"! s,HvgOx>ϧcS׬,hbD^hi4\zIh(I$TQof.䌁u Vܜ hL$ȫXw0óktN̦  v.Nut<ۉUZ&!%ürO'7UDG nXºd鈤={p?hqP}%* t;DqɎPL99csh,w_ _8ufTBXLF;LX|=@Gi"ﾞH_g0P90 I>)Rﾰ.(!4S f(:"cʛMVh<ʹ' nEont{8!n^`7m &"mʥZbtԥCۓ8inƊ[L 36ҙ_lSUYnQhSN 4$a $L JH& - _4ɚrT`6 EǭQW0mʥMP"{*ňpЙ:^Ł /bOb`dqbIq ~ǁ+@98>_ޝNoϑar~]^ԍNAD:F w {W+Fn6UQ;bΗ.XX-m&v!KQWdPŴpr9C჊f]" [|r-' QP|L<:?"h:m^)1lJ^0Q|tb((|]br+w?Z9JV"Y; luXCHĨ2G~R0ޡ$t@ ^x*-آ"+r]tK.%|Yqu3׏UdOٹkFWg ([ΠGKg8+XTH520#ձ 7t];$Ql榬MZxjjJ"oܢPH pLs$Ѕ4WcA=tBV咓%$#<bR\/,7˅&m <“=T۷m|X鹨fPfdXv%ۋIv<_e?;Jͅ'7PUD{ C5qX}}Ľ=woAa4Q  A* 9-`_3TTxhntYN.Lx)C>H冷 /684(([[d9(Eă37"\?~v?{l endstream endobj 1593 0 obj <> stream xYko_A@C l i$nbhqdH-Iի?w^ e Zcx_s=玣R4Zn/oϿ&NQ8YEXF|s"n%((|^^vPJ.7oͦ5}UH${#Vn:Z#ޛ(e)xE&w{ c_(Iq|,UR徘x/ػ"$u׷U},.UWEߴ!2E)&3`. 3+j B2y8ϳt]u}HHz*$;p:'Ad(ժح{#Ug*d@ Rm\bq 5%9⹋M]X .パe⏍(] yNt9Ȍa m0(ɬ6۵R싾jT)ffA鴇`S~ L"s", HhM qRݲ:C!c؛V|Z=Í3H(PBVMQ19rzr d|'3(JGX|dd μ䧇jĆěB쭲;,VA; ۪jKa g#zn4DuIYhծ-+]&밌Ugq' fNn#pG8 }ԫVqBnӸY1#)a 6l8vZV_Xs RtF"9b[ =~p3Ȁ/b: u]fK]n!,NHるx .N9iTV8&XcAh7m=_H6 {{_.nNL!ոF .+kQ˷|u}%Pȡ6L?XG-sFJ͆_:_"q{,Ŝܫ` gvF;{}b(a?a Tw;gHD9ݨV'&kjS7o>rJ!:rLv#bܟ>^[/463=PN^:&@ !'pJj9"s!9t,`&jn)9s%6Ôgljr5CU㗇#ݻڏeHڄUBra=E^Q`{Da\ASƎe*Z+CcP2r,t ,?*}gF |+SVrgU+<4Ee3ira(l4#u[aղdޮsG@:RLb;'Nj86nGYpc1xY@-HIGh̎ͼ{(Ч`rzٔ\H8ѐ.$ƎMu< 9%-l .8;$}@̧ޜkEﮜܙ(l)"ߗrk]pE {a@WNt Ti1 6 glB~@( yl bK&^9m&eymoh ֿ6UDkj0˾ mwm1d`C s{ղXgK\…{`)-큷 fͮYi͙*Z cA%oJW8L"Q݋@WY@%"x.`]N(PJ0F%lK3h ժ M?˶j|S'2Bx~OF1143ɰШz9Y5&|Z[ z2w֬2Sp`'8L1Œ48Lp/9 Z&|܀5o2qǠ==A虄q 8>X=SOZ$/&Odq endstream endobj 1596 0 obj <> stream xZKWHv9>mS C6DSBR;;jl0xaHWYgVc+]m?>%9qbvɥ]=P[oc더2ۚ\+e_W)MNJwʤȜX&ݳlւeC*:YQaG 3 Q8IMq,ǧqM~*b8oǧbY[$ F$&hA]n{`M]fvǘt ҥ)\>w^yZʝ6ү:XpӝLJdkbR}d-5edED~[we_=7vQIa/ >j Kɷ(3۸ mpƅ˯t3=˄6ePvcoa:?+)}@,M/w:u1*x0 bB 6V8ݕhm]tC6Q(ůCU&BE=# 1|mZ}bWYu M;\PANח)@i2h s8,h6jBxm54AUh֢>Q]4e2З-eйMNω'v(* WN}%`_ DTeAeڀ"`ܓ.mW0C䱪p(\BeuB=0DO?cy +IN? 0)B|TGq?Dl?W|9b۵u-CR*\7:h~Vb15=?@d<?iErV丞N)1 ܰomJI:Z45_5~pe2Er-g.!\OkWo+8wW2=5=T=(wZlt'5dh#0E{EɤXsӏ0t]C wQ9}&StgݎթNĩaȚGܹ|(M۱ K<{ 0q\D=" kε.ܧˌ>l9e(}Ӵ evp)1_AG6qRu{ %  Io^&)yá \wB<ƕ\u}#pf&Gz3%Y$ܟ'#6 HNEuCG*Y,f̦͘ë sUB!Gkw袜ur:&]\588M;z؋C '֡iC'qM1b }mL;=fR|i_:ϥM, FN.\j2`(Ck_n,.鳤J +=TI OǑ8| 4|۷]dž]ruaF%F({TZCuwʌc ~ s; ~[n*X 3 'cx !P Vs<އT̳/jI)xl* Bvco":y!W7L3uWno̳,`x{L\yqj~A+Hh/ӃKs=wI~ /I'F.q2l 4ժ9SS3R)B;';vARg9 ~}.cY4`usm~ل|ZHK۬=J,6oJ]%!$]}̡t+{e|喘X݆^t8@<3MƔnV!{D+bؾ%L{\1" - ~iɾ`!sXbrxc<ñ=z(H(a|< ś Hyhef&zX(8(569[sof@eOCQ5+S:PҬ:yl,&tB6rCSa4FRkW-g}~鼘REAu1z;xR:M`P=á#(:Cޤ(s1QѶq\;@}s_[>8|?\b~xr0gmh;zy\? endstream endobj 1599 0 obj <> stream xXKo6W!ZbE#"}E[{^#/rH=Zi 6E{{Q/% ~Cho/g IfԻ=z4hD2z`۟<1$֫oqDQm7iTi\g\Vv0\F xFR ۓ<~#j~~/ Ֆ_ACX:) '#FE#aHy=n]#$*V=rNpR'ke%I>쟚NP_՛b/B׀3N8fg^hP-"$ \i|MʃN|i U[VE>_χ0N~'stW@NuAWU]+cZ!zda W݌Q9wO*Uc8t>&"~Wgӄl9H~c~JFk> [_'U,? ɵDAQٽ{(_͋S^NmP8 1n^j4j$C(PfrxU?j܍cDdȢڇа㔟펶g%o1Z5**˥P^4ZG53D/*ڳ8VJ lAAsW/VMOmTBMw[BBADjP - PW0j#(N3q7[lvn,ie2U -jՏXW%N=uGMԣ|ӣH N--ސˠ]&+c1mbB."xzl(,3!@Ih[-iF|) &39`K+{(/P G@k8OeSN-*V_kvZjBքlD]]pi]M PW"c B7yjsL}< \)Sfg)FIԌWC)S3jBQ=чM7|͛-ɡIjq̣8\ Pf<7K#6hi;m%n ;B\i[F:jzlV徺s^]Q_wOk)fmD!)Pg:Jtۀ:)/TI.a3mbUB[^""0s ʑPM+':L,76kucxz͎.+jmlCbY1k`*iu| hmϝl dy ` AX_mz(sSd:]?h:/5ѹ=((\8 ,]ZGt\fKY70$?mj'| SY-8"іYׂߪfJվtūI+G0-+ftAxĐZIظgjE~ endstream endobj 1602 0 obj <> stream xX[o~ϯ \!s¹qJ@Tm6/]J"%7$׶3r5+ BΜ9\#eG#_-яW,)FrR-Vowf$ǔ$"~0K}"󸼭\%xX¬"H^px(|\UM4Xm7o`v~>rߛ[y%grQLG$˨p'Pp\0k\w~%(_ś$a{]ڧ]VWɉiLHRH"U'dV1-&Efe {CR"PXw\;5lO#旚zw3'P玺!~T}['@̼)e HjnsMSf[u_}`,=Ѯo~KRjvQ=9;Woݟ3+ Ƭ"`^NdnӲڠe=nK\No}=Mb;ܕf0%] -\ 4jG&2ܑ7&^B2F m_SK>Idc9hL'!L=3C~Έ~ ͦSn9XC q8#zۍm[X3r66zP p/c!yOXxi~VJ]1*‡m2*Z ,M02qbxfxk˵ JxΜp .~cy eBӒpT@c?4%a@Z ƥCΠw-hV  L9 i..O5ɳ|z]FRXLy q &g`vYUN+?_wa߽zj̩7CTVNo + 0oMX.. 3Wqx.lAB ̗{Cblf'ȈP-gC Jpգ*}UK%F;Sh19xU4cx.dq!|wf le"]rЮѾ7qr0 %Hσ&Xد7(u?xaDCG:e-6(*WDOj+ֶ8 V. X ZgO" h#+Pvl4Sk(Sazyed+o뻘wz֑ҙJv¬P05+Oglً_׋.<ʝyZ VE!}쪢|?N:;v.*2~z>tqEXK X93?Y}dX7fvts)#6)YNnv7!3hY x_;ɕJy(RU/f)%0:Ocnv99ٛG5ˮ򺴳GBӉ?/> stream xY[oF~ `K&˹qƢ8EIk"M,"TS!E*#[pQ/9 >$H¿$(Ww/h@8K2\-⌫j>,})R2x]\E0NjwY^^Un,*,k]ͨ ;C%YG=g"NEwImаN[Yꅕ[gBvܵ^>945,+*_Y /n~I~/ x!9J vQiTN-͒cF`A1yPDdn}3$W>L*hUw>rD3`T fm[ެWtTiLSl^^|D?%1e%ΩZk2neT tw8m(\Y$ddaiLy#JqgjCz6,vC B-}d,do*ʩ=9&$;QRx? o1`+C6%PLLaNK61)d,)b$tS~b1_`Ki#8d1ē>QCT e{E3oi nuCyUbY٭V^y-N2T֠&F®VK7v ۋhr3H,W%*.QjU\ LoL*bBsmj ʿ@ -_kDSFPjDY@%9 O,p:6Va^`v6`[\I:R@4u['@/ It\ya< IR$u>CE|(pW_a-YdUἶIگ3'Vjhjn-hi(Ѽ[֫,"yOU1rZ^M(9wH#&t,o>sh{Y0 s)>A8M~zo0wIF`s MJm{z5[oP OrCFSDeB6`vۆBlUzq?D{|Yfq*'o!M? '`'`?(fupSf{?ߞ=C쾷9E)޹[}uzimaTy?걢"I\ϧxL]_7g]~{zjίO3R {Hd♽ ._˧ /A 0Խ-qBGW2(@hQVƺxl\|ubÕMԸM,.Q(r_,<&g.n}ݵI]cm8yuk_}(2gË>yA׳}g0}|G߆,3< 8|'Ӗ;K] 9F׶N ^Mݶ{/*wZ^/N*/Ny" endstream endobj 1608 0 obj <> stream xY[o~SAքsnwH-fhȤJRȏ9sP$vaR̹~;t? ؂ .YPN a/ݮ< U\q3J?,WBKrYJUzυ(a|Yrj~VaJPa~C66"\>x)=ŊjOuo2+~Wn%So'a=Z/^L )х7MJ! u8fm8-ɬ5SmsNeaW;0T~l7_B7 p]QU{+uUOsBd @gw?*;I['J2Vc[w9*w)&z֝eNOuU ]HxU\soI z+_;rIs"+0AlçJN~RIEoiC$'N06_8ׄ3G(qS J(bA4 '-]%G(ʺܴR*&U/VPDUS$H)Ʌ<|H* U5 " %}z4vm,cd:DICڄI!MND"PvCMu1%U-X}9Z^r(X~t9ϱܵ꺶#Ig$9SpHa +sU9Կ*]&h˦XliB\S0M26<!y6ط7IG'rL_XM: \jAFCP,b;dG/*]5U3Ӟr$*ںOsB2% -TѸ4zj;LlO)fC,ueӲՙ܌"Bkru?tul mjLH,li)j^Ն$1R WdqdGh&&Ғ"7Dq?`=:=IK#TwH$AfČ~ktbߵ2iߺݶlyowZ8ʽ:O{$i.*^^م5 F\%ZR}uL&FBˋX8szG`Zo ۮ@>#rTvuO&j-{ q8 l%r 02R(V6M˖G@1yPT- LlQ\MgPEsଧV4%*,Nd54C[Uk0e}|L|5KxngRGF3="u}d/P;Z@p3nt0+|-.?"Bnb D5ΜvԱQ NU,>qJp%I^| cojhW0 C C;|>LN8jSvsˆ $Z;n{JÅV9`5.{Z0<>F[;O @11_ǎ9$&:bWU 6N1>6>@sر `3p~KL fOĶ*nf~5> stream xYmoF~H; (p+q>0HURwE3<,75"H(r}{M#ƚDۈaH4Z>Ă?#(R,aYr?\.^UMUk_==f M&/gTō,amtҮpRZf/+o-HP%D!ɘ}&.d-,/^}Uryq.zO&3$8enn`MJa-%ݰoOg?ǖ&X"7 5MczJs'?_p77&~oMm3*gbgnΨD,Z~[~|qg0Ud gnzrHoC~B8N0p?;Տy]-!$%uQ7~&y5?,BfaIZtCi>JG ')8oH֚ɼe1Y5 fCV?͏zF'N8X:qu ;BZFIVÀd>U^4ۗMQC9L~(b=S:i*|;%V[cI."J sC_ kC8}:#qS; ]D/h~bϩA_*oy -8.>YSB ľ1йZ$P;X")Rhb,qݳ2[&3W8 hUyl \qMfg9x/եO`"U?lb_7 jnT9)_&ňbDzFTzpHH< pqSH37vRxe=HZúIӺj;fH%4"ּl\ +n`9"z^ +z^/h!S$fVr Daz@CS|W4&[@,_>3ohހ[B=099@d=|LjI6 iW[?d8-*aD޼y/:*,ypubbaX~,{$b5~ALWn6=|w<)ď98[vYۿ#tTM`mTsr,@YY:Ggwhe]g)5:UOL&Q2Phk%`zr~OOz$Ughq&q BǠ@Ѕ$D uhEDVy((G5sa뉻JKJ`@*?} w+׵)ء?vfMMQ;>4֪\?:l6O݄卦D.'ש\A@ u?*Wv]޸N2`/vX6{٘׿sKٗw3dqgfkW;! $2:e0LORy]Itr:Ȥ eiR".1)Kjz72xR{xnAv+Q|($ QLۗ s,8) NT|9G%Ě"Mn~cbֿ_rks.ϙo^$"H+L> stream xZ[s~@ԇb/63-7js"&Ac0;={ t=j<+py\sY$q0߿ Q'8-LQT0[܄VɪID) 1N"XzBdM0̑?攚߿"08XffmhI m^5uN513X-PB cQmfvEXJEiM8"ILٿ.qe]G'z構 b8ֱ#̋ETؼ-ז틗G/_8LE6Εp6=yzꧫ_gW]+* E@.z/T647t~=pX3[en? E=$B\>yH'nR,t$"*lPmJ"yY@^UaC@T9M]SW%"*>j M`7Hvͮ"-T܁{PCu:aX>1_`E`d]n`QUbsd(eCpn1%Ӟǔ =lseZF<6c|TD?9b0qUd'uy?juv٧˲R/`  '#&O{mv\͂b"C%FkLJx@{ Ib1b[ƛr$wt0$T+BgHOǥ' /= KOdh‡+~p^Zz#'}!S8rpV?{.h倁o+9P8z_ف ]|h]{yqo_kA uqX@(&qhS.>U ݺqtUqV>n*3*ZunC~qZwZ;4]up?<7Mq1[J.OG:շ(MV4iϨ-uSiK`6;կB>1p8.uyL2xOkbNx\h@?cN!ݗPpJ7l(Dz7>#Jnk3q`2ӧDgoeD&Mz{3Zƈ? SІJJ\A?@ Au{{$$,ez,Ls#_-?+zϨbߵFT|E胟#uϟ`ı#C">}4(|+*3U,)N:nsU6"A7ǯiGhĖ>)4B(5GsԭpvY`Bqho{b<$C]omm}SĺjwDC^du~_M>@C[OA^cLOxPaj5D<µ-hT䄟[}H{R~J8~)CN*!Zk>s˦5 <^솱!L8Xz*7s.ٱ XfǛL>ͫ,m27|h߼Qݜn$Y[TYڎG Av%D/!7^K@I "# 89mJRieDˬ)gZn@v@g_9*{(bgtԔTHMu7uX#1φ&ƉvF/UؕU^'ʸ*-=tVM=؅Svn'}r 6/{б*\#9pUCCco&9}Ć1fip|xۗ:4a1]1&/!Ky}EuPh\V^8qZ- Խ +JajcZ+ulQw:슠L a&^!kY>R'bCBֱ ,mi%O̓zݮsWD/_n)گn}蛒 '~u+T~Ѯ ES%ȮJJH&Z"ƒG:4Dk =/omd IJVMoQ+G"^i?+Eǜ2FRϪ 5]QUYd>S s;756 5|]2O"ݺr1u/慻yvZgR3RH)Ja(m6ޖ Y˟ &g( endstream endobj 1617 0 obj <> stream xڭZɎ+tTܗy ccjNnXEDʤ_\URb4)ŋ6ڰ pG7Fmf7L'៏p1w˯vBmQ/lƱ.˹^?,ƦwN:b~zd!2s Fn]1fX25 `+q?/4QR&<(-_/e3 Q m R3B5毋syr6|ۼzp a~=i%t 粭ñma'~:<41InxKdumt/˩*?0%0 .|Uf{(cHYPzv:978F/x-US?Ų>wDoJmKVTt2ǣaھ?5; Pj|dWGF g"z83E,RyWU 3N_$ "J2G${."1Ё6sV[ K_aDRB]|Ak;to'<A1dI4eI&+0jT`p dƓx\,>HD1*$xL0LGN$5U%L~(?S& 4z3jF9\w `9G@lDCǽaͬhQC4ccn.p_o>NoH_<01 }Yv*6,7I7#sNLC_ 1zNJ/‚xz6&4EY:?8pi>kDhؼq1D jN<"İ鱜M,p]vI9`?b5rþ™#-̎rx%E|gnmA]-#{R#X}gHߠsذxYkÂ3RX[Tuh>`dB ~NRT8JX đfe [Ɵ0OT@sM"YubT RLn?n+ÝHF&I)2lۮ4 EUb\4^QM]c50J9fwp7V/:*JKT΅qnDz!9Mz:ǡwcK g:Nprv^5yAodPYzB m=q~[-z|%)p :@ ck Bg"cY"[[GK`rv={F@sU,38 L͘&@C>:pc&wp$f1/ ;rg+fL;9Koe 9gA{?ONLrL6mN #Uw%ba9K>DbqC_i=|Θs i`nrbS|_1?n 悍pF,ʶ_xn嵺>>l!5нBaۮ%I":پc"Bv[ƻ!n]CrZ }b_a[, *;I΂[::&fΪ2鞮V@m˧*j}%5Tu(0rVfDՀq xVc\8rnք$p4@> {jn8V:@lj.+ ^8ʮN hܤK gCCEkPk t]`̎: PKNV>%gh-^A !1 *];":U/*@/Y.f&swǴ9IZbHTAjNgHm?ld R6V OX@oB0RNrM!0,~ׅ@N(P*_JAN(wlf=.f]) 񏔂Ԥv!JArߙ ẀD}Tc ƭqcRwP3$ͳ>ڙJ4Œ|1 S1#L*ο4vShWy:޲8S ?|,zsot}ƕmX񥶥Œ-zPO`$ri ߫3loڭ/glxGZ,5ΜH}hęا128> stream xڕYIo8ϯIqqh`,ɶ&Z$_?kIeʱ"e蟈DHGe~}F$HrE_m&ƄlXqʸ(ϯ.⦞6_1‘9m^',Gax?r+ Ŵ3i0ma4YYM4__.9GaL4鮻pd/tgeRD?_uadI6Dfvf1 6lwO/6 Oi )gQ&\s)m1>i)9vnj7.RxMEVEa9L;է5A[RmԚu00c=.E²hn_x|3 ¾08xomSW:Kpv , w@WugXi7YyjKarljYe9*i?P?vw #pDщa2QdبWmqjnueC@G*$Sbj qn]l42p0:OL¾$Zx BP;:/`9Gfȫ0:rЗ-toP78me pknnUt)S0sPj+5 :8XGƎ0+upq #HH1?6*T`|Q9:öP|c0EJ:eYJ3v} {%~k *Io~gXCaE$v)b,Is<&iи|^m[1Cu*Y`ąەǎz8ލp+G:ߛݭ6*UIn.ԉF1!#6ށoЪfkpHLA`m$\B2gb)8Ŏo .jkJ=3%Ÿ^e A~OgQD#$I 1/5h?]q9:t\df︆ݬ!>6<}j&܂)eR|?oWCƆAgzj45ʰ1>?kL(hdS3*B%;lŀ}m)̕X. EN Rt޲V9aK GSBIϛRCSnKm]A=c{gRAյWZ*.+ZQԉ,GjA[ @O|(\4vz \P ʷ*)$ʤHJl*n1 Qt@ @ 6]n/_3Oj x!Fq?b >Axsb]~d endstream endobj 1623 0 obj <> stream xZݏ_!* _4[ x0E\;KʧFs$wg~3_$_OoWOX|qYb%+UZR-^R<6~2RFU?^v۵Vϵ߻e,hv)h~#h#SU ,K\E7peSEsIi_s̤RL(߷k}pu4$:tXDo(Y>}-]uCDxR39ügOl & 5S䯨j7yL5-ڕ LNTpVCˑ>+\`C;pDƲ,\3nF/<2ce~>'GJ;b`WgWݠ͘D(/P"2CB2=ًtS,Yo 5Fo^ՆH$47~7} N2z=_ Zw6~|. 9",+ drq42}JVUj=5[c>?|4ejLKLI7޽Wje!ü;AEDBʥW!R c}}!2j{yC*ag1Md*ٛ@v~Wr=mOUa8Gf,Jگ^k5m wWh,>,{C)_qr ܚlnt7**>4JcfZA6-Vt!PtsYfE Â$ bBknˮnjzM +<5hSBNU nH"QB^>2 xY&FGCφ!l%dO$9{'iN [ v?ܹ$ҍA O vmhG-.8Ȳs'` ro؝c.YG2 lz.&sǴ;,~yW/.__eĹ!)YA&"~@kpf,W uదjcڰPM8\|tveA*RlVu׀4>Zhz[ai pߛz~B{RdyWO6qzsti⺞#40Gg?FPC%8H'x*h!DZx6:J>Px7;iEZś{3} @=y=db Α(;]p24%CٝHF49q6[^H!f^^¢0=},$h$& R&wnTmg 4wU`:8`18CPqEge63`)miJZZK5jjUd^ɫn߬4XkԱidž .j -kj`$`qZg>c ;Vآ,@cpz3Wp)8Nj.1vT,qq9 +R?:Qk-Yz XwwN§[8A9MQtoVQU!tr-/pĞe!u퐑ו{׶M xT!E5zCu[^3(#y61";T'9:li/Ȗ,XVz;ja U$lMe`,fCk[ @y+O ;wS!8SI625Up3 jCT̽9rȿף2]Wԃ)r2u^5;OXm =gas@>r}F*wģE'ƀlB; f!g,eÿ8҄]%!nj͉%t|z:Px>fyEXN3gOc}pC46v`Z5%_#ʣCrzݞ:ěqRy脡 w ƅWβCBFt{țG3Q_L% 1*M)BL> stream xڵZmo_!\?;\_Qܵi(him'I@|g/Җ/(.V3;/<3[QV9jsX}{_1J4luubŊ e;nW]Bu*L>yi3?W^IH&r+۫|PS dZBI{֬K6ϲ?;Nq_J}쿥KN-[&"'9̗{+t݂|Xb[g|^+cٛ-)86qA4wv˻8›s8:9 T$+_t&I t=~0u5TNPGEGm~;mbrIx.ܚnV7I7 ggar]L92E& Zj/ Оgɣ[/ AYUFyَ!Ō@C<Gqq"Xf wXd+7rt\$ YpX.O l.&[f` $8 ]no4,Tҙ]jVCf9՛H,ddc6h9]BbOӸ,(yb c)sƃѢ0USOEEr.ܻt]C (_hKy)3h'B -XlW"X(A}ȕ^DSE/+ 1*3Y6 %jPŤ'^Oͭ~?!1Ks~`8iNk lLMxԭ)0vdP 7ML^;ԣ Ds @N}<#ajşϞr4`NCڭzAxEϘqB<;K93[AnUL[و"UC!Y0"8ĈY9 X;yZK<)^y k yhB fI<-}& Ag ~_{Ƈ 1e)\8+,ԝqdH^j{#_@o( :A%ޔJ&%ԙo*OW^ը,GoX.٪3D2b@̝h*kA= ڞ"'ݬE# <,PDc9UJwj4Q ƺ<.q@ B(JdR蠌%x G} $"rWE u L|ki N\Ov$Zx}^͊e``ū& ͟hQY…힡{1  ZWєĆ$ 6wqU@ !2$}X< f,$r]LyI._?#*cۢݐ." jľjvB>sΛC6dWԤqj,HB&B01HNIjņb3<.&3,"Qbj g,(㪀6U]h~mPn2UހPf #Mm1O7a,`8-1^+)fwî ųN>$˓{֫i\J%#3S50 @s "Ƴ?!;g ͽK`֞n GuL' u* OXpgP ;R4\I(1mҤNgz0`-qgqBy> q@|+.D.d0:Mr4@G|*YP63U[bB慘V%܏2qL" ʃ{qshwՓGH:V7UEk/[w5[Tf'B`SU_yR2 hHW)7荝;҅TyJ R ~4 WeDbWoMz}C_FڅcZ8d3%``WￔqL7'eMDi2I=MzsǥJ.mg+`7ki6;#4V"pp8)љln?/_?r9WSp n9oU|=h]P PFALyj6TD\8Gx 5*k, bFo+ =\L \"S5O 86ⵎZP4y22O3t^8#ݛ(݃e0"<7sO [tfR`XHљ(Kr)p|H_a1F_% LOn?38~m8WۙｿZ7R endstream endobj 1629 0 obj <> stream xZm_O SۭNkw""Hl ?>3K,u<#m†I3o,` ".VwW'/QӜ-n, 4D pdק޾\B䯯ORvu2lg2&YwZ,i'/PurCԋT0tO]K8](X'1"0^[iݦ͗um «,{3N{X\Z7AP'?8#c ?藑F9Yݪ1\9'Z?xyo?y3w F@BNȮobF2-Nu7-% KhLn2fdMxd0?Vk2YuLԄj-c2b<2A-GYMc: 7,K郰0! I5%¨j/3V>ϴ(6mU!&fc{SYx 7q2$v1!Fv5bu<6[0Yt&]>$ӂ{PB-$ҕ>>/A (qð}2WeuЮobeBbr6P}2{^Ąiu3"dJDYEv)ꪌJz$ZT8t _S/fu(]] śzggQ@u%t']DrD."ŧRn 򼯤5fߗ`FYP0CϽB/y>0کWp< N;0uXx\V1`g##=#;[Tؗ;j|ngPcxCNj]?x#y(&kCaǛz\'we|@ ,!3mT;L٫8\h;z:zo~.lp230,󄈓a cT/f08Qpڐ&q S ̓3׿i3HptySMC~ @d=;FOe.apl,~5B?/xZrk+UX3 VTM Ep}D(ve%542:rb9+xUMiO޸hlv.\ }.<'ũvX՘c!* ~\ďq\fwnqkod< =xmSٝh1-m N&&,FicOнPF;.uA BV=<9pQŸ-cK!z٥r\e,Jurv c8e=J+ ~shXWzfD1ȖT5 XrA|'v`<1 H>ISGDTJNr-BQ˻zpœ!f=0@몱_ gaOaq7kh2H렭bۺ?abO|~4|8y~~2VkG endstream endobj 1632 0 obj <> stream xX]o6}߯IEŊa@:C6钬AX-y.@.EI(ZDB{xx?`' y~<;& $v.fLds1t_Urϧz>c}Ѝ'Džߨ»a#ACps*ώ ofLjxZ^B(CBZ-I-8|N{ͫw磳WRsw;%^>u4ʌOE9niD}P\Ͳ\ ! @i?=5O^1а{vbtvrdEh8z?:󟏎OFw^^ɐ~uԸj$U,R{1kCz8CvNX de\A&ѐG"k0s4 Cөjj &6c '\V~qԕp@ZB`q"1 G5V!57#2W7D0mlH٥ -|F"$^"Fp 4IFt¨<(@]BXX :Yhc(! #7ҽ"f\W&ŔQe7v0EB7n@WOpބ5g0D3Ӭh{kd}2T#QRʯ{F?q endstream endobj 1635 0 obj <> stream xX[o6~߯R X)e]muؒ+P$ˡ/)R!8sw}HD/&Q-F9I4HrEXp\~(H)oo__KRX\TSUXԕyY.$YnTeT7!%F#pf!߁l|9 1^bWdd ul;[>d)LPD#AXłpvY:ٕ7|6#A xiH著 VK_qY˺))*L!!"Hwl޼pbN 81?B9I19L rzpZ22V\l[q Ź=&l3TzZܪtSY3N>;;;9! ,}tz\cL1`6V᠍0gftrY4'FM|0%lMK' m_z?;jǘ &yFDt?{\BSɡb%Egވo%Q)#g-x[ۥxW, 53D]NAՀuc14fЏc{@^p7ԃ6σk7# \}Y.͘t BJ~TDNe[oO(ti}-odQVm] endstream endobj 1638 0 obj <> stream xXnF}WCH b\5c}@KZ"BY.EJԤEÆ$WgfgΜu! ( 8̓o3 6$C`8 O&ɢLQ 9byxQ&#z &i] 8H2_Tψx+i«<"F²)&~oaa2[Q (ڔqBZD; Uo’ N|xnCLp,)Zc"%ڸ*x6-J/Y6O# h@}"N/fuF+(&M`- 4v~tQN9T;TWiZfCoF'䢝 ./'#32Qo3;$б$@"$S,Ch'ɧ&Ŭ6W\N\ G"n23F0d,womX Y?[Xlo^ږ-Ӌ&˧Cф H3iT,L'rV̜* v1pU:Y_j]{\ )coxb8X"-S{o( Zo@O6'DZ)K槺նJ|pdW[jq%?6e}EU8+p]Kga2)&ёͶvneq՘{{0؎1L"{qwt=@J@OEͷ{s /=:{C#;ş='O=iɕג/mnVg(_`it4M30VfӿfҾˬZ)mω endstream endobj 1641 0 obj <> stream xڵW[sF~`#O}tu[+Cl#XPZw{]5|0OQ`b2S`xӹGB0Л^~O_=(Rt`0847?|3}ô1oI@CbL U~Uk}O1 頱#~U2ŭQ%?&@Xr{*]_$cK2Ŀh!JY3>*:}$zӗ⟟*8܁,k$=$ IKt(ֶGݞi7.>-pE8lnk[."2^$_oUnq`(nik LIcқ/ +-gpjuy!Wv/7|o;lB\-iSzI~ Ne'e| wstzXjWeC1 D|? TڛfgM+{2Z.Em+&J9f`kHYWl]F}T_W$0ZE_"_eUٕ —UYeTpaLX#PFrC}D'I6{8=PnQ6i0TSBx:!rtk)u9&,iV%Efퟜ~zZaLBruF,C۠!طwE9 endstream endobj 1644 0 obj <> stream xX[OF~ﯰ%<;KnvID*U|21*k\sw> odY'$D` ƔQ 9byxQy g?$'~X\Xqw* ҄g0m|){<=m/~x8۬\0 0̓6lΗ& 8SEACX1 o~6IlY@۝/Z(m,bal^Yq$]>cQ"u}bzxBNX{ogpDba |@Iq,X`A&@sJVz!"^I._ct;"7 C lcO (/7HZ>k(I i3"!Al)UِX|UؿE8uؕ qî˴i~ȫjL݆I] +\1j=hr$j2eVqF&GMq(S$t|mݺòav5`]$@c_yק+bS-dpuG@<*n㱽 R$"[6ֹ+2mx۬W)HB=F\64wo)1f6b351&e\`{^G]Z5b)HX;U旼A4Hnad*c?:à_l`;'7Ͷz=U;L+lHVWzw5 +,+)M^1ҫSuz:vqˬD֏#?L!6x{]1GXL<S{'~`GCϚumXV]' #:mV=KCm>Rg-kVg6, 6QܚQ8/}% ;< Ԝk3N4- e &T SA'h # UP0iU~[:AXUA$(6N6mlK(CoP:CvwSscj7/Bi6 %4l9Β.*lӃ] Nf]UHVYqu"CJ&UTDYzٛ1UP/|V],⻁t$+ "=O?~%7~yaY/m C^e{/a$ߎWRX\_~?B endstream endobj 1647 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1650 0 obj <> stream xVMo6W(-~諈ir( KJT$3jvoE> stream xڽY[ۺ~𣌮"R:)MOE[!E±%WOwCҒ]AA,p\׆mrc_iN?o޼gU^㆕&Jݧj/.xӸMIOAөY&m3ߦLt[RM9YɫM*d/cGx|\3Y;3ٙmIW?WLJItӧmw>kzł4\I{vs &!$JfoO>RAxcSJ b9 j)Z iT!BԝݚxiQɉBσiz31` pÂG#'.RP$ڨX 55 5PW$jHyyry T)M31ۦqD^XҴpoyVGp2wA '"*EhIRl)e&sJ7j8.` S ̫'xzk%XD@*yڑعVO^C` Ӹo?;+ Y 1F @VT- u,kn$QK@J+z!+`Z[} ڤ!(eBڎe$#m߶>^h<j_Q2.{TFIHy׌FKBdá14~s%؁3ѹG%,$GI2'd n]RhZfX}D \mȵ[-k+tm!5tNF lBR z`, _N%=pd"2 ٚKJۨ̃#,A6e(ص"WY}zxHǔ?c׬$їk4VQ%]D,es_9o'XXqnT03-E$TóJK)BD|@! l3T%50o>X)R3{U1XCKQeY*x菴@>KFHKJO4vx/}!P"Ca )d1G~iBDpʑ3@gAzPC ]z*laxQВx¢D(yZcɛ{Ř8TcwRΡ"SM˷pbz|JYQm=Ċٳ];wX^%}C;4 !=0`l݂!b^{_] PמvH%bneI#eyu/lo 1uc :J_0}2x:(8 M\.|hhCcRJկ2rO1ѱW {H~e|(@]Jzi~VٸKi]|M]|[ŠC~jHfYA]*H+=ۏC"G8[!<;TOo!8R6jBeZ)HP轊ywYTn{ + 1Ei-4#6ᩄ&Bt?|to/6L*6(OPpxپɲrBVX-p,4uL/*1j!л46t&n*l]j: b}CqQE\ƒ<u9eEš_T⦢;!fHh֐@W"(vnFC0~ ["da~9'8+ B*2YEۆk=g(B FC_rNwCIq8BB[w*JuuY9CC}I~ji.C|odPRYb<0kODPp4~r i_ReEx<%\tjc/g+eTb{>@w+-ţz X 5v늼W3[a6zo <6:Jt8Sa<*@U2Sċ_Fא J̶x Ë;1ϡRpz{QM?HS! J Z?0g&\ 0͖=([ũ.ouc˽hj;z9ǟrV*q͖raGsaoyI]?n_Ys_~a͂kElSÌ)j2_R[=2}t vW(|Vup@yq~ҪԡWo4$q:4>8' ]S;/> stream xX[o6~߯dbx>tv)}Pd K$wCʖM')0HQ"yha"./%-nf6y)w闩"a2R&K%7|B2E^T2soSI)EAr& %IU]ʤl<0nzcp9}9um -lǑ.RʱѽV3{IbIun@Seɮ_*tvg˭3UQNoV(R9ƾkPqcP_kNS*g D/1`{ډ.a*.B%J_wK\6 ]iiR Kl>1* ƇeٮpP3'.;3rB똘ͪ  \B|+ѡK\2:g[D>6H'P_cG0k \G(yY~i_}p%[וH+q/6&3ѕ*ǚѕ|׽ ΋u %'J;,{<\^f,JrMn%q/Y?~YAR9KI)GD:1)r.I w +uIVlCjcq%}樖8Rpg){}oq"1WH")dS ~VA(;@zNnlb7>p Am߱7z=,."gґz\v!,'{n]cɝ,h#Y޾Αb ˧J5 x[nM42wܛX;?Lu~C~ :5%J6 WOX RdƤW席w=}r赮JrJ%_-h"<|8,Hu}վ$)XgF#G7v`y.0t[nmIh~oBQ¡[t\Xrr`fB'1Q2w& ;q쓁Kdh߮guVơk VP:xWh lPVVE F.fEķK7uEɎ <9>z@Y/H(pDsG<樘400U@b0J U^1V2/z9~&:# CqHF$k:B8SBf$ec]JlXa࠘¬p~b2*c<ꭲCb'a^sSWV b͏K}|AX^`:RˡcUevxB*H>6zҟ7N&wi> !.̐\paΑ2MM?,?0 endstream endobj 1659 0 obj <> stream xڝXK6Wpd[bgSJg}s`y Î?nl)o_>x RW6ދ;aν<<μß?{",M#8߿DQD/?~K//ۦi5//FHH LzA"XFW?ʬ'!K*=)PǪIj2(!1*9#aS JX+wCyW%$Xcw!,"ORxlљON\ C.ArjGs Os{! w4Idb@ƁNŸeαꁴGCv&8)Y~14gLF[fy M"g<%v: ,b T7T5ПXye0ZHms&26 8ekJ~˰tv],UqmZ$Ʉ@~:+[(wꗂo](Ѿs2ʢ [pI\O`Rq3OjVհBrSm("x|kdS.CdaHwӍR՝e?Q ֞Zo\ ߯+ᷫf?QjVSIp\pR!q`hbW݈cCQjtd1OvVXYURcN5)W58 w9\.߇BK% Ai 0p'EoMq4H;AN4^PY<•vкE ǟ0޹A|I;Nyso4p$lH4[6'6m_qWdx@WRVL0K|5ٕMuq!sǁD{d~ͦ]ql sv0Hóyu HvFPYnQJhCGq/ t{0f߷H{T{FK~ji*MzP}|,[@AϺP8ւtHTP SS426e2C@ň^]$$|xU#d~9fDIiZoՋ@=&U*ԇ Jxjez}|`  +4NHݑ+p2АxQTY 9@]Ibya0W .1x@QU umm]R䔴ąOt`O/ԫ="*yD)%]2@hĹrg9xUq˔*/" `T^YQ0qmLYxr0XV+.h6Qo̦]Qzo Bh? endstream endobj 1662 0 obj <> stream xڕXK6W=@))=h@qZ`Ku}g8^v`o!7;"J%}xr+]$H(fu=<}秮hVkT,:W2WkY4%*p5,eBEkx–zwԵu=?\!.ݬAW".ʺr TSa"3\Gs𬹟6f{^|%r-i3rdR[SW93D:x:ǢpeaG(0>o{4x 4ũ)‡ϝV;l I){K6I1f_\sĝV]Ym;5Ze'v$_| d*Uwn$!jmZ^\:B*m=!yMuԑe\CN.-?aRGBhF-Z! Y#IK[ԸDZ1lњ|D=\1- u G &-p!`)?-6CM2#UZ?V!?lG@Q:~[蹒+ !Ky"F^.)|\|+b2gs( }ysW4T/#m"B9yg+휇}â L솨ISꉒ]HQ*R}87+cTE_oSCwR}>arNb¸C8bƯ.J0KRs&玀i\Ou'\ eijM/hn@HDDk<jxU1"vJX&] ظ_B:ܣZ`_\؜h.S,h%: p5J+9C0d_Y@-M8ˆ\'}TA# tV^oQ}E},p&`EݒAG ;v*oʛNk)<71. y=ÖADTwtA-bb=bXOU&[$ s.5D0kRbɐ,ɨk09 *f,&c9`%hG=И>~L8n28h[ﱵG95^|'ˋ@|wx l[;N: >s0d~JS2ެԥ#A*bǗ2NJ&JS  ptBp=E:̢Gy> stream xZo_A/)I6@-QITH*g|g"uKYN4;@Kr8;./1Ii˓&6a I4}LI('0?S)ſn0Έƻ_"㜧 nm4[ousw,2f~SmL՚1&L2HU}0񱐠2QYL2~yrT-]5~DHƥ{}1JALz)=q2MSD5yIjFSff,x+)1 oś_o>W0*஢xuʅx&R 44]ΉlR9Qo<^L翥új};Epp6 0X1ʩ:J\P(u PGo/;z 8g \q*P2C.~::R0>\bD9z}BH=%y7+>E_4o LMH`sEj\+fk|3r㸵S qn'!l2_pٺyrB QTisyfeho/.~bQ"QVeWk+'c_|:{un7QȆQ? h|Άp_~%ŕ`Xhڙ%8'*`3SPؑ&74#l߃7%"Nv/A || /;: m?a|\F^t/.^v hc~˴*nz{iW"f;-rQj hY~'NŋaTtq~E"9_JR3zTDBiLc7 ©gX]Ny+z`*}q>ÁhNZoMٻ[]_uśGh7Ee "s]F:Y1>exK)Ρ`gn:butw>6u}J P:/No/@:3Ξ"- jXl!1` :HC=$On^շsEgԯǪ RrR_ֆ .$M,Q\bE426394AMIi}6ν*飯^ZG_%DfUED GSpa'!hmk+ \#Yv ),bɂ黨f(N+Bcnʞ,2- d27e2qO BCкr14$Sۺ)4m`b#} @j/ۧOXZcue_U{ua>ܣ&YoEnYbYmT6{z.ZbȜ83/>9 _~meh`&\<4[/9"K΃n~z RaiRzv()vv88@ rƜ#؄sIΑZ-Xo_hlODI1=t+_kG?hx^["2{ i)I`P Sl*ɢģ =Laf%.0w˅/O3ع%"iV}ړkn]nġCDD ~=~DmW8&Wg%`[1V{8z]l_%UEZo8#ir}X>?{Ȝ,'{6mmn쎇N;Y I':vhԆv{̍4ݮ(? j|ŧWr5N'sdmP?3> stream xڕXK۸WHU,x:5Jj+*C&YD-F9Cz4e_~x?ulҨkN~G_WKmO}՜>HCQXt4("TD[-W%q]@!& "e2]_ӥhG˵ζEXlj;=y%pʚ VCZ"2f͹~Ƒ CjEjHj:@@ʶ|_v6 W07*p418ZT[YB\\ ?w#ޞP7IfkNxx,D[lhɉIU@0ᨲ&e!m۴a/|g[W9l/L&rsw$.u:MagB9ה[d\t`'\unz:lT NM,ߔTqdy?L֗X_5x$&.mIʻ8H{%1ȴŅ]=N {-K)}@/R3V\*ڱ88t.+1!r1À\s jεK nh O[{747JX0p^ mm_Tg4sb}EP_;;Fu}Ҹ 9m `< etB`˼ƻc:_ 5 A-&ү-o`W:%dr(%jhA`i.V4D 6r`NN 窻0KWӘ",c)ט={еw7((pW~"*w'k)^Xu4Z i&̞hy&\;Â#d*![g}yھvS 䘐pRYq wKPה@ 0>Js37Ы<F.:2|qO. ~Z/vG"AW1[VRPJ-3*Q; 7rXJF^ u){҂fmšk"Rld kbsJ8J4Ǵc;߉v?-_>K|A3 3}6X. pwce0ԾkjǪJZBJ1ƣתz޸~/av!B`&oyg}ZW,W ?2} H zjr%D1tT𑧡V 9ޫ2<_E; endstream endobj 1671 0 obj <> stream xڵْܶ=_1?S ,[)_ypwpI|xbV[S@}71wIOlf|s܈$Γ\ln7":\#F*[`7ξᗷ۝R** nOAXGWgm;ET6[iNYIaL曝LhmJݦf'f]'Bwhn(e !ċHL N=oOAXzT¹kpu;0SqW5EwϟXgVi,t4&:!e^8>6I zѤ)d,bu3~ذ٠uѴM+{J*m9|%&/Ʃb3zZp,2c=0ҢEr2`y< \l7qq*3mb=1@ɠ[9m? JC{:B>SWѮZ Hqr/{Ǭ<+wO玀C3ʮ}`jD8MD89ֲ)5eHr6{)&l)iwTJA[Bz]%Ց8mnig$ .ٮ%k9޷nP*C!E@F'Ǜm&#kRtb uZ@^:ב"u\o {XYpL*Gd<.lldõD2gjTk{u|PS*=#^`Lv}q*b9]Fcs(PQIlO`N}ę:`lɴ?clHW GMɛԪyր6 T22dy-gyq6m0<]3<'$tEnW6doJW$XL?a3OFx_xw/vkZ&I..4Ǣ>b'׏L?p3)P"H<gh{T.K{v?L,T"O~W8V=I6I"<3Ixf\SBהF= \,| |2Ѝe8U#޽?Yh`YRÙǮjg_9A#RZX+=#/g4JYX ߂PuSKߖP%\P&=nk=x*5P ES~I<(B2=UkԜnhb|3겈4,05+ n'R,j~:\5y=r-1!sJ^1 n]ڔ1@B}M=8Z8TYIE1Y<\zܩ֔2g[_>^&su\ ]%sZv Kү~>sVWc|38 7vhrl+]ӵ{. >@ ~Uy;?aN nWߜIe“q%/bE=5v}-)NPT4,7}m3m!ߚ= :Ht}{4o$`eYh1"26VA͡W¢;xX7 HiDňmt'PFo'ՙ]uǕD6iYJ:93Ľ̵3'e {'χ?})4LF-؀W0UwmӞʡ|TN]`!׎y jwcq {> ]xFܮ-g9_'{'j*\2nk;in#bb|^c%G?X8 endstream endobj 1674 0 obj <> stream xX[o6~߯Уg]|SJ.2in髲{lUHUP9?BFL)qV%LUgUKK>S,#G?K>(d9J~ztd^1k{ib~f=F RQR%K N:봵 9 ɻoj endstream endobj 1677 0 obj <> stream xڽXKܶW̑a!"].96' v 9C:>xpfU7>@8NvSf㲒4du͋3y0X٠+5o8~W2*C!H-Ryϣ)5-G? ,g# %@Vp<%fT,E> stream xY[o~ЇR9˹pHVY;~`$ZbW"q? G2e4i$3&N$t1L_ް H$txxB9IDYԼTu^g5>T@t"о;4UN}{6Cׇ%E1A\.1yɏB.. 5 p5y6eiʙ2`)ߥHI^q$ѡ`z~!BJBP#&{p˩QZeWtu'@ xӁB0=VNH %IkDݫz$٠6-qbL%-J@ŖNP>-*:( ;gComk$Ĭ" s3>NTuHuB_/x׃)d1Y0EeIfŶ.m$Nj3!t|z"IiөTqgv &IҢ,JxzcYzڑn3}\lrCޙ 'v"$*nYSg_ԪNx jXLRYtP9{/G%TqƢo@Uvcao%]L=Xں"ȫ|@AO,T"/-C! %q`LИXsFNFtRpj,@wj4AM3qVަFX='a[S0[2Ndyh!2վ= ͘054ݥYؤ'Uv8& )mlq 5(,ԕc+=pbG`gﶫ >h\ B˙>V`Օ~hk=aYSlKfuoo3{ǟ_H{k)]p8< UAމ;RYE8hL_hjghP~lsP8`KCK+U^̋FC+d_,W7 endstream endobj 1683 0 obj <> stream xZY~ϯD%V/E`xH85@"$5 TuuqS~ldqbglp5qgWf\\eHd/3!KS ƻx7_H)^fkj\U?6ȢaWsF[Ű7np,T2^y9R]t냽ZU˘?W lSHI繾n˻$r_/҇z./>vZFFiJXSe4ɐF\ZMfJkK1A*RKmvvUZk'x*%~A1q>2RPp~e ?DD1yiS;g\C>KX>EpxYRTu_w h]vM]Mۅx)˽6M0wdjܒ)~ኈ|X$l;֑p$Ҧk$|X Ͳ81 X4LCsSNDMѓ>~xrGEc_5>@-W%ne*]Hvא8xX-ƥ4a%.03KBH?598B 61Gsd3h1)uB`dv66OʼnOF&3H]x(]%P]y"u 9f:u[_wSp3P!+)@p7 V*kRΔ2 G_XyԳ M5g7Ȇ!f1‰9i90qt[% k>GNL.M<8r 5dI|#?jE6E8a:{n&;FK{susΊgVLPte0@u9 [%-"-"Onmٖ ΢==G ܛ|tU_W)FG:cx{腽 *RHǪaUu wH8AX)\tuuS ^~) 8W.Ec>V7^TR.FRP MrNš.Xe\Y$mxo Y"R !~40 ɊgBgV\m܄+a@c oE;IxA#ab \bT8,G6 FPmCڦ$ma԰rݰBR{c-lH'9d>uIrG;W4æ"76$BBJrCJ)6v#ᖜ -ҝo1fX_ʎvD&b68^ iߪYXvlI bZʑ[S20ۨq3,=>BՉn.;`~!mֳU&pnmJ ΂jj%3V$²Sq##.+RBRM6(:zء&־619yE= q㈧N̾ ~4ԩ]ƘWކDCqJ va{:f8 ]=<ь{CȰfޒtXp]+m( Hqsz~.'C'}8Vq6*\))1/wJjgcXr4, [ &jGɽgԃ\)H}SXE9TɄSD0r!LI*%' u6BȜ*@C;)B2z=N!NG$jB9Mvv `ѨidR x0d.HqB 2k|w οڃ{a=:yԷ|{m򽇯~A_{xs5 O endstream endobj 1686 0 obj <> stream xYIW `L܇T6[BKpbPMʠZm8IT ɏ I0#'*&& g$<&D'd>޴5c,%j9OUj Mۭmp"d?Bo凁v]UADp;8 5py/1~(>/+u7A3eyl(w@B>% @âɣa5Z?0K1ʾߔm|2=o"mrLVrtk)RABA%uSd&)r\xQEMMw},)ID?GF\cDDt{+F~w8t8ESƂG8co7uf.fQEJ:7c(j @6TVB>\ ’NS>X80zq> ~E_Wej_4q&e\[~v1Jéyd@ hk)eIlb()Ǝ_)7RR6QFkB2$4ʤG/QGȮcrc {bYZd|z܏Gy2~c/ öBխPOJ%LE n 87GՋ}iCA\?e:=˻/Kܻ N8c3-^ 8HAf7Jb!>.֮|<[:8^,9˸M+wC&E-avPWpeT[o<:%@sZwf|Hh B*ɚfS&obx8By:ƽtJv\ $a~SvOSnNSw_]hȌxyÂ.6@s&(xUe& 2h;Kzs/!/mZG%yNP]Y"p4n8֩Ea<çc_*cؐ<:GY+.᳷FrRP`PPI ax%r0\s]\:3!60u~g_)dL]MT^lLs.R܆͡p sw C#Y1~ gAUX:i4FTQ endstream endobj 1689 0 obj <> stream xZKs6J&3[sAi[PLI4 Q+[5sٯ(cf7Wy(qԱ.c6c8i_r3.81F6>}R~9l-w1,]^W/% Ů @%FZ?Sf8o!M;oYA\?'NV܇wAƫ'mvcY JFpks[z.{Kouahgr)$lDu{3:OQfwt_mi"Sݍ \*5X"ykf̞&Vǯ=@s\B5z^9Ǹִؾ\LڕskK POU/*D*(+ߌZ?Vu޷Z6YX_A R짴B}]4ފmU;Wa{i61m< KǺB۟Kh$a{pF*ؤa ܞp (`u\" 9o*w-PP =q"X4?Cs&"-awJ i }mܬ7~gO~.f$!=%yϨ:+T/%J~3=/!97i"g,:y~ 2G`2;XK)xD#S];i4LJmhu5Ҷ52mhBXW_z.7h-~4 k*"O!Vl>yҳil܏Ao)>._}{)b;gv ǥN~1XjB뤿.I268D%ݾ'j`d 5hbGR&ˠ^H7ll3뀉/%k A¼}POS#HAP^*Xӟ}{ym8nbw1?oCgd=p#nϽ-t UP*/q endstream endobj 1692 0 obj <> stream xXKoFWH^斦ɡ--hD$eWE|gv4%/%NKZQ߼_h?ih~Go?$K3"j"I&L4_}?l}W4sSn!_bߢig"A%Q\(ef$HS2*,ɶ~(d[_<K "HR{M]Az ~&i|. OGeϷh4^m8ciH 2Q1bL8IUKJep'|Sös $\1QRP(%F "9QJx^)a*(a yWӗAhoېչ"La}1K<ŬJ10 4H˂n2p- =ߖ%8Z̄?)]YWޅDJғ[V1{i4mvxmѹCT¹ۆ!1Oiop'~TVrwE0 [Y~`Ā=&\LB`VϤ1ݻ:Md'>;\>-DqiTAZA8ᙸVAÊ2ˆ%R1B,?7Ƕ+vˇm޶5E@BccppsۀV\&bn05Ov1M NTDK:׏ۗfW-Σ߿s{Ǎ endstream endobj 1695 0 obj <> stream xXYo6~#XqK-q<6T5ZwHGPHpo&5"Q?$~hFo>Ј$8K2M""pU4]\#&weKk$f\o/v*5G?̓{Tf \| FXKyV֕BrtjoIS妞tGˆ,/%=HJ4;tHBC8rS.MBx!VT.ƭ觼-*k[ lKi#ɤe3g%B1 $d jR.EMFwin-_HP*0ݲ/j= ]ε F8+ faƳFRҵN$&Kb Cf9:̍(lqH,7U$8xPUz'_ +u3c/t_.PM%(Vuq}6]qy{O12 Ռ34׵^v_*E^enݧ՝n!uD} :2;'jd8wHS_mkMȹTLt*|azLqV,Q}WCpɼ=|ӴţKP^`uP,TaNxD:,2JBTm,H6=*Uw7/\!\oYܴ๒sj}sݠ66ONwBdO!FKc(nUeBy z!vg }wRߜ2(n&- &rE@slNu*1u\zo?e^b~4M -t-o l(iQ(oA Ǫܗho&b 8]Yͧ=}y2fF$Q:x1^)Voa^B&F{X9(~y!{k2Z}481F!2O 'B 8ﺛgpC:?Lf{u`l-×-q񩟜kPz*g11;k >HKSN')U-`SS]L)L#)Ejt_!0. fG90Nv6$*G_Sܠ2ټ%wuմq0> stream xYKoFWV*07~!} '%6tD:p)/e0s Xb8dK~Z&Qc:a6a8iCm~E&HȤ݂two%)AYw;(GY+X&z_޵e]yNMtI mjm+Ќpł*BY6~+$X%ȉK4Khʛd+4-b**7nnk6.NНw_%._/b/q-:q9DJwl2C' -IA2 R haBiƹ#˂[Ȗ xw W"ݖM+^]o/j¾6His3`}rnEg+ s6yz<+}o6.!єL}];`i}_AQrno]!BjsN|Y]ŗ2o&}1.iubWi#&F<.CIDwT2lKE 3ID 'VPWs*cT/($\-y,} fcWu }@mʶAA)x]Pv:59g/晳 Q;yhxME}E2XK{"oIAP[.ÝJ5o u`o5k[`;LE~{V33ږf<"gb ^Xę5Loʿ`Ma $7DM۫\-`V? }Ӏ@( ޟ$Mf&]o؁u;k q)^~#lXqy/ Xu4'_Utx&<.y26]4a:D )4ˁFݳf,U+&Pt4T!Vzjap5VyZ'R!uP0)uc< oA3qUN}Iy]ܹ?_DrgbYGR@s>(Uu 6_DiwTc2{˩ endstream endobj 1701 0 obj <> stream xXK6WH#D)@&)@bSzؒc] ?C%.`Zyp,,GQʂ} $>ٗj-ͧfd-~[RneaגW;}9 yB)f\A}YcضJ(S0br,W`#֦V|&"lMDĸgfY拈I[t@nWy(< 1Ħ?b~84p)ۛoyVŚbZ8.>6ut1{D\rrăД%{Cw(* "1O-3DDJE$)IKN_݋{ ~{Yu㈊ 8/j3S7F|4 Vfޛjwu^!lde6M`ܢ2]hR޻EYYgôQ2?揌hTYaKI$UT]C)T/J ~=@Jlc-!M%f,cm71W$j dWPذi]4ףԆŬ!C֣r42:?r0nc{;;8P-ZPх2ׅP'ZBQZ:zvipW6{[7{z3eV@=w@!ƐCfOd}zWyy6|Og`VU?Va ZdI >.A]$Kr)v$:j m)M`PVI\ؙɭ!u.-nMui"9Ԛ:TP! ˸-CQ¬;{ϵAR pk3%t wY6(L,Q| ) p,1%њ`[+ םUBHejG%.D|Jn*g`dL:!rcK111%] 5HO4z,赠S੆P$'5܅BN‘f*CRG6Ky{A| U7Da]њJ:^m*;>ԣ8-UނlR[qx|(+cr8CΠhz@mڍ)y NeU&a[D۹^i%EE΍Z+b/C 7PyP{s|xʖ=bH쭋Qv9mLEi| qv10aM+cыat0e A2߯a{=Bм3TKer;{kcP%z(aVF b%Iz}TRuHTWՖPI9~uj endstream endobj 1704 0 obj <> stream xYYoF~SAzO2qPї8h HCRw ŕi CoVۈDHR&2:(.Qa(*\oIfgɌs$T M-D`@Q̼= ZZ )E;oۮgܷ5hF$|˛ Sw q/=A8U; fwVl- ^ P`x\n}t2`)  ꊕZP﫺n$D+Ag ; 1i1'QDXHiGX p&C&R$tA,s/44dob?~/4 <~}d4Vs7!oH"̸!GiohFxX%xڰE؞i '9/z})VE<7YImͫ 1$D\#( nm8 qNÃz +/ׅ_ m"m Sn*a$Z[LkIζh^Jz)HIIònBQІӽHS4{CMXCN q%ȧptOacXC`Hz?S. DYÉ2B2%\O׌Bί=՗S>'= |-a-BBy{hf3ӽ-ze";Dz:=0LNJcy1)ql鍝-n6EWB޵uԺMQ=wThVjY׵}$T lv@UJwzALZPBH vͶHH_ʥ]T^C! ?l<!(7uEl,deۋuުenÛ%4fS r8c|^{`w27ls.  :3 0JU[.Ɯsv ^k!Fh)u#J<6EoFpSnUYͽ}1Eb$uu(pX{0pvj6A:tA^2#2 ˜`~<0rD V¾RbPA,-^1RIS$99MYfj;=V6<72ۅ]}&lLNCxݟ[§)36NŜR_*SĈ8T>HSS1Exh4'iQ:z]li䉩2,krv*+ZZ"h[\1MBj't?>r>Z%#}OxUՈA"I5U71OV H| )ɂc)Dy8A!H|19`8dc,zATȓǀaS5-x@ 4>dukF?WkGB+>6~;R_)Tżh[;1Ӏ\Csx.0ԅ,J3]|4m[<&wr޶]w󦡇EBx_ endstream endobj 1707 0 obj <> stream xZ]o6}߯0`7"mMa+04K#'l+4w)JP;0Rṇ^>yxFS zGĻ{$Cw|72bp_c̏gW[9Nns5W |Te59[~t@@ $EՓ. L];-М!EU.-.š4eTw)yDG8ȅQ7?ָE 9q<)(A$ GqE"Ew)0bi4|->sD{IdD^J$8dQ aU165r$5}}һ`Bu ؊_~ =`Ez,- L hB![`$~8(ͲӧH[%ǞnT7KZ{$V "J`?u(Ru؅p%D@rR4cN7/DBes-2x!<eE|␡P-8"DL`\4D<$aLVХҵa̰͏hHTgÍ}D*OH2UZ@ɵ=|\p6|`f@%SSVX` SE$AЇۮX'HOi{\1c 4T*ߏ._0M$@&qv!&}í6^e/ {&^vڼʖam#$8L'HP-n.:< ~|̫3ЦN1SIy>0rsCSJZ[B%UK^bߛk0&k񶝺 Sޅ,Ft1Խk:u@U?z~~LJn&ݚn㮇,cտ 9Dn.a37&"x&ŰrҀ۵:x?p?jK137뉻B?ZqCP#ܯPEJ/+ҟ$|{e}^ovbn]> stream xWKFWP9*3 N吇}!${rҬkByw]v-hhIOF2 H(٦~^%nn33Puv+:_7szlVTW5旌$`(pzR/&lM_ƺk߼ o9&Dk̉7}Z ho7oE>ޙ /B -J?> FYѫ]o to0;=]:z?Z=yݮ1m=ڳOJ1@ EFrR9VJ!: AG $T?U3*S!OTȳr$Ow+O1EJTѧK\/ lk(*aoZ ceҞ$zcDw=u;WγXGgE=5W@p$W7 U07qoH/]qp޳T>E"y ];V;AF.tFL>LރΝv@etצkzkzϻsBcMN_H~5)}6Cgݢ,-> %68z,;KJ82(X} &fTSWm|6S _5tQ݃3]z(+!G@ޠP $}ekUI_"TSTRhNC%"<TbM4=` g@Kœ&0ܚK Vb[dM#qj^R5&jkTeo>B=#T`?X,Α,y&K8>xRs7A戽Υ1!J.`i0sQ_۩wAs=b75S<[2lIz3xḯ;;} e{s #8 5'htנS[ʇ )8qˎ6ml\ΔD`J*KJ[RƸ=ZΛ. y fg@hF7K52 ,LmAywfQDn*Ϻ}_S|+´p%g>Qj5X;쫍v[ϖ|z͋i]~.HQ;UOaT`K"$^]aW%B Q~ZhLb̧Hf>+e sVK[ O6Ms-Ͻ.miO]BLK~?H{|tx_hP4,JM#XCGP%*']`e|ɔ/ O ݧ3hbVR(.&}~X= RjQ)@mǼOKm녝yȢ*/Ϋ;?MvhM!z]'~MyԭP\2aO  .'>s1.|Q.WʋK }ͨy|{ͿX endstream endobj 1713 0 obj <> stream xXIoFWV 0'p9MR6q{r`L@"U?oҤ<$IQ6,~o$~H")lx}P&$# .2ؖ ik[_8>%H,>g&')C9]Y+p&R"rb>ӆa$pLY崉B3V=t롫 2<4P>'9@l` ԝ$QD,ウ1nzq<}jYl?|' `gcf&I!,Aqw|>"G`@x-s|wpQz%7[l{Ah"a;sy#aGĀ;LA>@҈qroR`E$i_)].6yZ VL0ݦ(p(`]110Psz[@c,?4!isip]M44K\9"bٚZŜ1lW٘iD<Ec4o2EX`_ޚEќ:Hl$ե:/Cm1l(ۓX/ц %|޷<0C#\, E0JeV)J'ua|ۦBߥr &.QGں 11jt 3`ޏ`V ׂK76S5$A4Eek`eXbY]\CLscac+&̓7kTNؾ?G( w5=c%_hڳ D=l؃C PnBR (&tOn=*āl, ?;@-,vGj̈oCCk9sQuTCw68= Gl#JfFHrDv 7;j2_!Nİ)νgQ MaWXסqًw \vÉ Ud!/O߿4 endstream endobj 1716 0 obj <> stream xYK6W(PhMjH=(hq^[^ ,7MK+j)ۋ&hZ E 37jnFfV׳/`T̮73gMvyוoII@(]t~)E9Tt?3'WMW޻$ X86p״r,ɰ ̂Y:yJ#ЛhrV%xvO ."ӁH()(JD$Y>14fHVe[o͒ *{֫eW>qD"kcbM>(H"y9W2aoaP*D@ymkz~k d_Qtoo3Ba:GXa) o1?\ ۻcUe sru"`?$EM/7ǿbEPN-RT}/&Z <)<"֐l"M OGF q r*B* Be~Y@0txXQ/9XIzj_Ի㠶-IDddNCк~z gQʅFXb匑ĽrsSK0bQWz[Ufyu5 LM1} P՝]vGPYF(Mtf^|G 0}_b}hnIJ>(p6bͰe΅Fiڜ%0 9td F`~1~3@ٔC@Q'ԎSaH✤칝sQ;q)W8$+5Pg3,F_,ɀ} IP 2O`XV(z:1V<1:R"êlz "čo}44{ (`[%E +|6e@l$FW[vǶ6>Pj Ճ邅i&4ƇXbk(17Hw6 sgnG9M=H߁&+j8xyu91ym' Z-Tg.i˻T0/je·H妕HLeBT^utW ?v|XV`ɣa qvk-_tf/yΒáE eJ ^aW${ohl& u 슶`L!~l,crGHz|eYŗB!xP}sOT5HLa͝4 }J9%a4H(i4K Ghέ]n߀MetneMMbx׺ ̩LqAaSRb"]܅A 6' [AqLaFcհm^W 3Sbpu0`trgnޖġȌQ̧@{NJoe‡.4Zaߕ]% > stream xڭY[~ Pr<r.PME )Wv HޢoP4ag|  qe޼HaEMFdFR׿QF NݿEnm?}]|v}es;>EAez5݂|oyWƢ /(4K;0ѵĨ*y0&.ŕ#yV̈́#2)l&e*p^ж'QJN;&=$˪Ye)#I%G)ϟr0\ҧ֣PP:?!& aXxJjRFH*1Jy#yhF>$#rWiWV屮c3X~cIΝH(OLsz1w F Nai'? |tƃAc_Np[/8]-jomv8deVW 9^Q@1[>7>9-$ř*婔cVUt| 2ue 5(} i Jk@+lEԃNRM(9*]B5/I.86}6~jɞ&5HZ>-X=DQK\9<@g6M?R"DXz4n;,1;+&||h%)*ac1(8j˅3&-vIVITIZB&'QGuۇ{߾ڗ>Ҁ˅݊bmF]3`lVh^ t}wlsn0`i$;jƶwt8.tQwf{Й̒Av8L`}:^ѺgB2$30-:mGb PƲXZ⩐'L(AxlcB=IW}$si%nLzQ"<T (׻_r#e;NJhqbBcׄUmұ{OLފJNL$v+0oZ$EA=Sƅ>t yBԖ'3#RhD 0v X!جvv3jNgCSVP"lv tWBSukݣ&:-is݂X3h3ao1uˡ]ǤIDyMΙ@aG$ Ꮯ3L&b2l{@e-,H)At Th6ȝ[ 8`wQ-sߕpc[ՠwyAg8A3pC쇳Z*-D N %̠5FTGU#pFZ-`&DkQ^%y+"ı?1Unˌ"hZ0ᝑȋxT]JL|+&[p"_B8>("U \FTܣ qAvUPD(#HFeo[=lheYMYBfs8-JH"^E/ X@I IRW_RޑJ~w?M_0FEUV3ُSj" _R\᜺';}9>_]8O//o:t܄ސa$'ω7It<>w>Js'ݫAOW7?9/g)t)z=QQ-Pφ׿Kv endstream endobj 1722 0 obj <> stream xYێF}WPȨ;O^H`GH☤ߪi(F6<oUݧNt? 5[М ʉf1{+:,W˕"{:,+MtBPIW0ʸ)A=j_E0ɾ;۾~'0;_wccy 5,p<)"' Z^xJE-~["E5=0lZXΆnZ{~y4Σa4ze4ѹeJMµܻQ%Pzf8_{B-ۜ:5F̫:ExVM6mʋ,YReϙI_/VF{B]jSS8zVԠg-y>NIET:kPeN.`U@Xk˃e+KW\dwG/fp Fs* @ƭ,Nl{Ek54@=a&^ aF@97n[mrx /07F;?Y&cXyHx| ,~1qq%qbY 1f)F^@gpP)[1IɊ_1'\KX6uEx Sʕ@x͠,Ijs3 mcG&h"M4RXĐ0)(5Te*[q?&NU/&zlO|N3BiḆMXqnT΃G8n2Dȏwi7o7YAC l 3*BSlOg) W .}mMao$y3yTLPCı3̩\)6۳t CPLe2FסW[0E 1|0|>%8A軂FrynZYh;5xww% endstream endobj 1725 0 obj <> stream xڭYߏ~_aIFV\"%>54ۼ)^ӏk=3Rt9h~fY|Z"/Ż{<0 \Hg| He |o?a'I*ghfK}Y/eV{8FձHW%";)4L e{Xd,M+K-ukgNR&R6"$Nr$rcRg)<Rf9)BBd\}r޼!$I$FifQMOn8vUMKN=7rNPk5b*鷳ߜ`Yˮ򊣻w з geG \}3%ݫ% Lb:#/u[V&(eX{nBrR&-^|q2cf /V>SfC_ vM*ofs |2Ϊ#Aֳ,_" z(@Mcg$^%~L ?s?Ҹ%\bEͤk}஖a?\YX {3s|„VЦ\q/XO.v`{h $iω(P̞7F xtθާMV5=Wۡu^+dVi(&`rM^~iȝ-M!-֕(zFG=qΣrF&S#3®ٞ;HOsH2Swi_h6BECI7$HLz/N`)0CB8QHuj&խAqp+ڞv}uftRМe& )+paSNV)7AW't!No9eQ`toOզ܄OLեQbFECΖN|J !TG{exTGv_P$kaAB>lhjf$mo WZMPU sW;{l嶘"~h;ppecڋ0U /n[)7w.n]+Zve9M.\f[cbx٠5u1cw([~>2&ר55C߽ =7щ'$/.;On(uƜa_6J>ˆ.> rNzWm۱8:+7 SUzpj8_ 18T!+=k7gNB rm٧ӜG򡧩'{'. ! q&E84_J"n[8|fr,49g Ҹ M ӊA[mEBAJPB%H!JO)0)xgFF pcw}[1%Q{-=:uw4{8NUBhmhKmG~~l:mOs[v$$e:K_ Ium߭Iryoo.)wNJ#BE¡s%6 L]N^Y8M4`$=)c;ff(`_lhLn~y endstream endobj 1728 0 obj <> stream xڵYKW9Qf?Ib` x r#Q)vcԚGf]]U]Z HXpxQ.DI.BŹF=l+T$˕:崔i\e-uB [ea\hR+O^<΄v$6zU Gd/Q4)veU)mYv.ڞh'G5PjP3NYy&NeX {IlUM;mQKU;"M}v<'íf C:.odyG7>tgJ5];~Bi0%~]s<68HѶ\'Bawnh=꒾nK 4w?DH'BLMþQ;wS&;O7$qZβ__VuW!N؂`$7IM,lޑ hgO|Ø85J͟ ZP!/86C8LxkVxA%ϲbEIy~ 06ղ|zⳒ6CHNgFӄ d".cyc^ONg#+xFFQMJ`?s> !&g8|rŒYV1ku E{5Pqڥp†7WY9?4 U);,ީB9WM1u%iվK-=<'R 9UKk JnE\/ﰖbrh\4lnQ>ިf5k3i$V&Ls6HpVK$솥DƩ_k*ACJR7Y W^O2U&Es;-.lѓ^ vwLj <Ā; fmu&"ё؀iNccQt2FQD9簓|<4x8jei0r9L;DQjEC9 " П3)HeTL|%␀ѵʣg$g2ekGvJRAHX嚦!a"L`/Y,Bdz73,ga:䑹A/lNBY܉<|VdIq\>xQ0eK\ 2uF^0͸Rz ˱^We4n T^X2F~p5[p}ù6rÀۮoe"4 G^P-7=ˠ2xc! vWBP!e~ !֜/^ÓPPF<%5%5<4k%FjUY4/:*zPc } jR$kXPZ=c (ɶq2Q-"pF%nT 5ku rE ',tdҷ[0Dga:>Ҋm-D#:6'_ (/@(( H㷀1?zOѷ,$20@1t''x/eWA&o@x 80=ńuE!$7̨a4Jd *UFh2Qcnr}s}qrttafx*O:~bT/k5r{.WJy+:,UQ.Q7P 6E$7Gf7W ^O߳nxjVxq"ަ{(Ğ|(BZHjUےj㌚4u ʟx#m=s,⭇3/|S9T{cb#TϘ p 9>ꋯXt_w4Af`OxܪQ_zo8cd^AQvD_ +aV>ec_;tAw$答 pmَ \x~3FTvL ~냐ڳ:{ߌ#F!ꧤYn*KQѕmwګ7z[Gqz#v:A $ .%e|k - n/;a  ncV]Μ Wщq+[{6/鿻9 endstream endobj 1731 0 obj <> stream xZ[o6~߯0y)v.kCY_<(j %ג;H4ʗI cIx.)>?<t9btzNFE )<8HxtqspIW%֟|8I~cΊd~k1IL74TjHbF xUG>b<=m9$wjJΊ&2@1YwwLa["8KUZfIn.jK}Y|KG:-7 :F,bÀFc;녵K;H,ܟPޠMi)Jpuo6_0Bnu㝠(H8?`Hق1x="gdDم8nq#X2^d%z ]dQa`@|Fn0;vܬWe& ^+-KNG1WYZ)܏DQ;[Tx+KW)q"DO˻֮7V m&;ٚ"Ojj1MR'gHPڠ G xkUxΒnn)䘵>Zǩ$ﾍX) >/g}(o8.5JEx UO1.š-+m;xjكɃB`g{u~Ӻ[] cU}\G15W]X r xTpmoᾨs2ۆ<0E;&I'{I=㯨10,|!l"qs`mhrM+1xPscDnjϞy C‚&ARQ!'P&cEN#coI&İ ȱ6&!×N*T{Vc}1>FtbU,2L2 s|Y^}G`OTw1 /}ttJb4bV˪]Ԛ", 5]CԇZjr.3`{Y" lPǴ `fYZ/EqLvٌ0lpa3ER}C#LyGЦjݠ'UQjacH/y8'`SGXQvfCnLPK+XkËj}S͋2mT3{kI#Y h#%} V-̉7ZV1ܳ+ڑP5x]іlڒmIbΪ2pH-Tn')N¿\ESۅ[޲&kۛ"5ͱf#rQ̮`*^ ġ{ oZQsi2H)w# $ ͢y7eBJEfՉ!TfoC @ϡUkcB\ӣRP6oAڭdL28zP-Sݵ a~B5:,f"9Hx$l 48A,'F廷%!C #ͺYemq5uY,6ǜC߸W[V! oF`:Mt]#o/(2L"G`$>;Fȃ3VNi?VCYrHW ͒ endstream endobj 1734 0 obj <> stream xXYoF~[#yJh(`% ZZKD)!F;ŕ)@ sw9;ͱ3>G,cQFCuG,X1A GuJ1/W2~mMJWg]L8e{v{|v98ⱟB} 1m:p \xa!RɈpa]J/nDl!U> stream xZݏܸ _1ї%;>6EYﮁ{l@"寑wfw@Q$h}PI?qq%WȕSW׫J\]߭d:-L:sZ)R4>U^o["DisuxDӾ[wkTfĪƳ~S*`s$Cy#~8 H-v)O~fWmICU loH) eeS'<'QҤʨl$ sl \U|,KMVym(kҁRi&poNqJa4~ƬHA8R }uՂ&Jk4;rO/{%9"Uxi0Ev}Le$1)nn#.\,Oq 9=i;KE"\j^td.2Pgh4S\>x͸`gնY(+x2xN[`7n!RSW{ۆh )b00(ݹ1M D|)LTJt+>S[ҶR[f˦{(nv :Ф%5;V/-pa /"n U}O]MäuYu,cpIK]@c]E_>9tnl5}bg C̐F[j7sh9R@Rt@z*#-N~,nNk꾽Jg1rYw@1v0 ބD~.-DX3 /lWcflՖ> sftvoZ7w n+l_OiQ8vt7WoևV}(w_φ?uyaxapZ z~j4sq,&uǧ-([}btG"K^HS~)87|tU8IՋ2^ƔFS"I>æ#aK][=7Xgg8m|y2[?6Ho(Ӂ!rd6T2=>>Sc=>?agk#H"u2@r>Tf؀HgOISsHGrFTik 7QzF]F{P2hIV}V, I)3'ׅgKx@Q<ЌхdtMcQxY˦@c莍{HxϷAa?U %zncG۰{lT>WsT5}ι]wu $XLnA_>MЄB~ ܪ΋ݙ[,wZ}HfT|N=zz-b'q9ԄUBZ'>LPQdn0>7ZwiQ~}kK8j&:jg> \Ơz(C1W@c=)!(yOGǷ\a I.1> o2.} "&(\R2Dxc\ \zBn\@_@.p u xڶ- }ߗTW&C։d%J70`GWiF`>;V;Ǽڒ_ݹ-omDqUfHvzT8]*Fz`7Bѯ׆uf8Ū@j( b)B0HV8y!Av 2^.w^-y- `abYc#d@<@$ _-J⹿8U0C‚0UhHq#4"7HṫPSznǧo9Ъ)F(pݤ+ @@ơm*PrT5rsn]xD<O2uŤH.Jqod kװ`bCū<b_DM$QBT $hugf :}z(/?@0%2ՋQA*.zA׫?պUC endstream endobj 1740 0 obj <> stream xY[۶~0P;'Z8Ak3kf;CRPNl lY$gp}pG_׋oQbe V, VMzS{.s!De.%72Ov׿.$SD p2ʿ}< Qz>ʥ%~ϟ~W15HHYBf]Uo2˸JOW)͂ptfd4JIUXԺjOSe4|v6qMah̞0׷`TP4`a)DœKRەUS[8D#U?ӈtX~ 5e]6->ũ3M~XLywa8s3- cᔭTI bDAL!Fa]`q)BIe%Rĩ?7*N` bVfj ℬ7;R;Tዐ"sAE2HKH0@̝?Ptv ]$$ >>[N{阽ظAUY z{_VC_%TBBdLlXɱƄ̠O!aⓅ"W 4U`Ȃ/9C?rEL:҈dN1K$#.R"Y|—T>=v,mD`ȍ?Yy5ۡX*x;fC !18Dd+i20C5@eNTObvז maC>6 ҅kv%l>Uph[꯰\WaWB;?֗bGi08Gy6)ϷuE#~Y{8΢ .0ȁWc==YY®j˻m\'N..h[8zVe%:=)''~y"7K+NX!RwzLŨ@CGjg.% -E|0mЅa'kL`]nzl93j'&Ü;b*=Mp)R~5ͣGIuR9uK\?557a߆2ҿ9p"&Vg(Jp|,M\h1x*z,(>hkah3ck;FaHɋaPy~IbǖB ?ݰo+JE 71쩀1֟[ϐ08Y]ͽE˻n,Y "D^ًN -\c;G2{߯n3ó!أ^b)Va JHmEaRr*5`Z@#kMZ8~y晘T'.Hcscc18Gs h&~Qh3O2mPG5k|OJ.׫c7ueEph2"HkDp 6v6˜1 fFg8Ξk&9'"4QJ'8+ @b1,bŦ4ߴAvT7IXS"H}3H#]GpJ*bUg7$ڛ 9nL(ָp׋~+S endstream endobj 1743 0 obj <> stream xX[o6~߯P`ъTߺ:lf{I:@iG-y\~II]:6 Lw'+! I?7W%MF9IrLNC9:J]PFR ޶O~j1ҢZÏfSWӟv럾g|1ՌsT/.ee \2#ME(}A> stream xY[4~WTBB n|w'XX $@EʶHmMR"~<Ƿ4:3)hfs\ջ^WoV_ެ6 ,J[aLnvq:fX猱aMdv_77߮HP ̋\JtNTar)LۯsN s3Y۵n줉֢D ʝ0KNgbiCwI0Ha{ }pQ8ƙǓ3vRi~h(}P˱(c˰׏qH ڠ†#Ls1(cC[}궩Tz8UA⅗99J|W? y${#ȽƦ c+@K\w]ۥTqJ;#w)t2'Wݚt͐R {'i7Kx09 :i7e`SۊP$ 希zx8΃$%rT;#_vHy8"ˆ}jvѻ4&P!J&Хz 6b`mG7ccup#,0ﳔ8UfNOոȗxFm̢CTQ̚C0 ǀ0f@% zj}~ٵ 8Cl )!?9\E{m]<cD W-q%y{1A#! mLuIYT&J(>\L*QWD0lw'uMG_̟1ŵZ)LtTmVz5T1NC2eCAʃ̝nC}Pk!i\Yڴ{wj\\JY%"~|eMq6.KWCjϳdA.'dp^ %U6)Mv+aϞ6! .hŖB7RdJ'__~նSX<$thT ˸.UC‹0qWNop`y idEB"F"5Yu.:)W3. "X7Ͻz;Y$a'AM[>P1$s>P>P 7 ioȌf<+2homm|8yK(@(r"ei&[ڛ :i,,fI< ,8!utҡawp֟tD8[73G=BONZg=G6%fbqNTНxp-M㑹uI o5܌pT3'!y93P?1ϓSX8s췵=1PⰜrЭȐZZ8_4Z3 -:$=ӝㄑkI˺^{]{d%[q#VjZ׬s$d=s ~XJ/ @aOt]Ћ"՘w3tm~'1[y'A17ca ݱ\u2sANMFJҜ>̪=4ʂnDQHZPJ~ %/wt2[d7=.]_s_R P] >Ɍ5|dcu!`Z0߻AL.n\JDw'lmSO\JȽfs흘8q)&=ɓ9\r,(&MƎg.\^8˕ZYiߒ93TSx>:50'Pi=ZE@pXPY_6 endstream endobj 1749 0 obj <> stream xXKo6WE®)mb6@i/q$Bmɕ`[w(Ay8٦ə78="?軋=Fk]D$Cg2*K.~(H)?$)c,Ϋ[|[ۺkX;m4T UqKM)Q(:JF;Nи-o|o?{}K%AZaL=(26i-.((,\yc5f8 L"'oA[{.g+h"W6ko8ҙ {{I[e[Uzݻ14uHqʄD(1Іy>9In݋W=tlwY[˹-g졸Sc5`1onk8re] аXcߊjsďƀ-ǯ7mpN1A!܁ tнf :$K%La%H6T\7W/][-4RtQ;|L_KPBacaMYюr3r5;QFG55x"tB(WBҘ 2" /B%RLyDSMA] "7% L87M{WI]NN0Q´픖F3IHFLHC7P`ڣOjטY`  "P|nڐ0w +_ ̷ٛvqON*#)_?,q!(UP!S}[+=7pAM˷]_Z}[C` =귦-rgr'?O@I@t""F@R '.1I.ؾ@וquc#T aW>}j384$HXL%_vWr8bu}Plt}`);@B.ASmD 9vM'M:9N&@{~u7O?lE{lmCbTEo {9lqϷoqۻa47uͫ¸CYөܗu'1~HeQvɱoMp`BnBϯyfKJǨ1 OAqw&#dCq zg!WJi¡|Wienuw|gԩ/'2̒3ʵW9WF?O'E7t endstream endobj 1752 0 obj <> stream xXKo8-O9̥ͫfN2U$ni1-Rb}U_U1/K4?lv0J Z>a&a$~*B^eRnuzՇ')Ji&)%yaPäݼQd7Ḽjb `\) dʫ)J4I͔1iWsb_Yd|:+/+RI`xPǠlSF L҆W.DE²n&(%_0$HVP"1/bGN9cD!|h;}mj"gܖА }݃$c/ V?UV~7ڕM5vT *GH2ݔx`/`cMjᇘ@ ,[OH;X ߗݮiXfN^9zBH.`u_>.mUgр$7^^Eh"^2J9TmS}LTIَd$aK~.7[ݸmBξwSHq)ꮶ*Jrp|a1 ̟If d3P?7T\֫A!RN9D9[dL;ޅ-D 8@DDi=>)hrCrzf <&&`[$[Q2P0EB`2僌s™pb~z.((6`;!S:?̕L\=/ v0g2o,7D<@i!&RŢpbub2]0SDg N犆 #Oˣ8`<$k Ռfӂ])UQ08у^RC܌u$v*]/BI(}v`!1,ߊ"~ (Bcp"(3eCwјgj;tEпHv?FrbCZec(a(iCmHԐʻ0/[t_>بU5j4^Ea'҄`s$b~~<@ jL]&[ R`4Oe eN0E|Ad>iٲޗ 0&!Ͳ!y݇L< \w° A2Z7s(}kvCo`xDqtv;Wեq[uv3 G~Pu̷sBWqf;j:.`AxDjke0N8E8YPq7nXm*XwA~yՠv;Sk7D0|UóeA~)ZрZ>pc#(TW> `tW*ؠC|9aFlŗ/\j>~pe,CzTE~R]f\O־ne12c$L&~TN,*ŒWķdqC҇ KO ]Epytzshc֍ϛYx#b /B>qHhv#c8΀`bG-:;&zK^:<׆JMɨ:S\ ;FIArn S|0]+ծWg-OUo_M5r%(Ge`>O6 k-ÑY-5Q:un־4p]Wu%_y!%KJ;fwi uh_> stream xڽZo_!/n{y]E6nM32QT;\R`ZR mVprj=_1JrVL\fω_V\pb_ݟ>~NIܺş?-޵]Z&{wv,)Ys p62'_jmSlɧ?x捧2Rf]{zQϪq~D_+T~H6G)as UN083SM_*JJBxMy#" sN`=؛rYcW'; =I7XnuR}m&R8hIh۠ߢ%H]Sbt":~Ԩe{{ePzSlAu.ZudX4ΈBx N͓ؑa ӃUV߯sŗT2ast)rlEh@KJöR<}TS`jU!-šJGLBRMKϋd4P<ʣLɲ(164]i; XlDbVq M?lg!g,!NFNp1h(dh?=;m{Ȅ6(;fY8d)kJ,%0(9IST- +S`cd<1Q$&Oms{m8M'}m*@FL>3꺪?v!f 0ՠQ CPAy0IW{ 8[akXN%P,6T'wUW-ł ZB ( w @TY wnw[+P(U\awE+uycD&.D"/̦'%V8nb?QMrB5 QsarD(E3|z:? Yȓ~47N U:pd|x,1Ȍq.Ҹ ڿKG/myZYBP%3muۭ{c7)1,cw&\,'-0ט6l>)S-Pj6wڷn~Yw^Ov&w4=ŎI_gp~$O$EXhRlY܁PZ?"'g.'\_u<u瓉A=xS><١ޱ3ry<;!Ql&:bB'<"fTneE-,&>k9hN1nuDl:v EVuNmn.B͂Nx9>uT$J,|S5=ټJSFx\9b6TemBy>NqlaNvԊ[%<`+⮮o]Q7z҉G[YⲄF1fِ/e-YwpN*> &RǨh0酃/E׻³o\Fᑇq~S`Bos1a _0b ?ӻ{ TȽr\a\Ǎu5z"?,Ӱb,󃖅Gӵnj62veD=`M]!Bm Td="sm;7؟nfĨI@ڡkeMcK?9o |{}[77V[.ڨcs:#Ԥ:|~1]/=8Quk,ohɽ)5*B=%xdy o|m15X5=ŷ*9>:'G$PQKfgMx|&X-M!V_V}%I endstream endobj 1758 0 obj <> stream xڵX[o6~߯0`Uk`/uqؒ#m H]l|}B H")j~\^ф`T$׷ Q a*^Jܕ^1jq݂f_v&B107ҳ*R۵o~W68T& T?<˅ߔ7T&2aX4L2,#uYAutteI(^fcE*8 l"NGwӮs(ֹn"wE^9wʑѮPQ|O7bVϫeƑJ:IF|(? Q}`/9+ ?Y]GIPΣ]dCح5-ۮZ]Y}L!GSZ/1^N*&L"._ J ,ݗ(bxcaEL(,vᰅ"O[ym=~ߙ ӵ}WM݁c2~t>8$QCvaVQ`W=~+ҾqNubriڪunmw~۪io>KLL*{$m6c1ˀD,em/N1qTZY:Z'aakCQn 6 QkG¢2ZQ 24g@h)XŒܑ  I<bo[P*¯5nkUo;h"6O0%_}f5Jry*$ IJ,r+؈Myu\!Y՗P"T{3B *=3/i9LaӁ1;B#޹ʚ c_)&hh_2С,,ҧG>{K!N6 ZiH^fb޺m$E7S H&QʋXN\[ѱ5uu겟sL1ynb0nl6+[ǐ2:J&tyw&2 ,. zg:CIF#R %$ݪ&Oath 361߀Y7Kՙ 5_f(c|OMO;Xmع_R i)ɔ$ e&m?,\Ɯ,<LIql`'m~$= x HFȵ$%K,҇DZ7ܓk6sujN@=ĂDr51t@<+Ƿ_? b endstream endobj 1761 0 obj <> stream xX[oF~„8U6Jm_l?`WZMafe3J$0;wn!(8QQE?HS֛S1+]J6O/_J(q^؛jjs_ݣ}Y%Džȸ~tՉג )] o:߁(m̓'e@%X"AC92nmZl8>`$tWڝd' E {z%N%`,'(Sܽ݌C{mAT]7# q1_( N`4)f#܆Ckŋ]׌?T3D׽K}bV2$ 0܁]Qݾ=:$s;*3օc7^TVƶH?C|L1i˘V[B''Ҋ6|7} ̅Dž 70Eػ}҇9/#M-s{%h?.cL1$<^ؘD<.uw׿E܆lfy;TD |=LH$'uUyi*b ex("DEbm)!LDx%OnC$L32I.a&̳\ңJO;x!\eP P|>c*?y0 IND4g!)2d]d;q㋳GTP9A\1Rou`V^A.䘭a)V fݐ a [&b԰*f_8u`٤$h1-jS[tWbDYx!OkΧƓ\0՞o{;GA s6V$;4DZ\_YQk2NuoczMMYzbB"6%4VnܚK/ NR: endstream endobj 1764 0 obj <> stream xXKo6W贐ڈTnvE^ ؒ+fCR$]1" y+3"?) ?ͷя5FHt2]*5JRXLUrۄ!IῩ׈$ rO;gH?nʟcCpY{O2R\ E~ @");UGSO/f /"ċK%3<]z KG }L9vr6#_`yB@\OfCtʒ4"Cv4lm$U*vL!` 2MFFX})Fv+/?,`fo>i !tGQs`*m:JYfe+vYSY- &$]Ѓ GFgSϫzso>]lYY2;*jwfebc0-bntCQٓ!2$1&6*p{/ؤz^]A8⟫XPݖh=}۹=Bn%|s(q{b8 .QwT-f ըM@N1*ЏxS <ՠ#Щ0M2pwd+2p-[پ^xFɡt@Ή'?'6o@ `ҫAnOALC$M -Tf*KM&lO` r*{d8HC\ȃ@7n Y7n<oV~zid5[vKj V{AQQW-&O隂Z zt )IHN~>7v;'~ND8/_.C3p/%Na>)ԅBn* O9@r^6#׀#8ID$ Lն 1l1ի+=lp8$3& :ɹSv.!c`v6HO} endstream endobj 1767 0 obj <> stream xڽXKFʪ^s8pH)Z]#Za䰿}zI) ]*Q$d4 2qPw,1)wI!{bqF׸w<,ۣ^˿|Z\pѻ?ta5ecY8*QlY)(HNuܘR8hFRyӝ T@F^S`x/q˲ dŇ$aN.}29uA0N b:OR&"_ׂмxK&H !a5viQe.G]Kl&i ,'rNHL^!+<8ЄsTHԯv ,Z6:7 * pNHQd_Eι}D̄ӔPf}Z>1n^ ԏ/%,%VUX*7>qYS9Q>r$KLAȭJ"NTz|%L%~g>LWFDXj3LS`j]EwMWR:ɫEEAt4/<@ڌ.3WSKpΰծrĐuܪ,9|3L >-f W@3>˵z d:cOf` , R.bsHY{2Q[:/zÂ4g Hb4<ʋV=5o%,g^oZmvytgO?AiVZdx}LW2YAMa)RASM0wz4FUkWl 7mnC#uy@TKix˶B?u^tQxV +zOs^gGPorДeӵ:k";B>ב%e|Wh-Xnh+@_G'c G/b؄`"ɕUvQ|&AYIBTOQuNO|K/z.xYL"6KDg^l)aRYm}r/p] B5Խ UwT$eC_ 77OXf.Dc3ҍ97JFPs'"k25CK8_&#ΨՉ%8_y=:PjZló؋"cMUXr;R,o T~V/~cViq͒+ZWٙ:*(ټAD45JbNhpLL3an _l\ZIO}aGڦp]u)Ⴏ @3{2}t|Wb]}π)79q鶸{%awjM[3[..r)OF̕zKfF3udi61zo\Mݕ7oS81~ShcaqCԪ`?~|e'ˈ*kǒ 񭽇?й endstream endobj 1770 0 obj <> stream xڽXMo6W(#~Sm|!@E/WXH?CRT5v`ûyy3CFD8Go=Tѯ p,1*LEmsq&I)1&I?UBd)Ioٴ揈a'rw7XQ)ˑ̌DErA0oC)+&i]}lөYb Ʃ1Za"C_}J8ϻnyb:OۄDP] 7Հmېi.P8)zo8_1_ölLbQNP$67O}Uk5m,.[ߚbߗu;]i b_.D)![y%jQTH;c_9y9\8͉wP!&]BF#jH9,co1(g~/ۇfwԙaN1!-ހ5.߷o Gvaa骅ƒ/ QХ_~YC ǯt(g'L J7tU$g :Axn/NP)򯲴wm=F1|6 0vО@6dV1tM㿿cTL⺜Y?~ssjʶWv"xn^Oʤ:S~>ݤg!l<H rp9ljI=< ^c9kV$/]и-*mt^m'*Fx obUW}e+\=^R5cժO>бMG˒6a-5 endstream endobj 1773 0 obj <> stream xڵYYoF~  0{}Eۗ8D[$!);{*KY$Hz97,0#g}uvyE3dwap]oB2(Ro*cyl/o?}k^O:_U*+bamU {#Ѓ0ŃR%WL@1gQH2$5Jo&48_Gq382Z(%PQ,:na_7):IiQ a_^udo%2@$J?Um&y }>g#'mlTC릲6"/.>?+-{%aq[ $5,8vuTPc}.V'8Zw Q $PX8Ǟ@88qJ*u7gbOi8.G/.R@<7Uákzk[` /R!!GI&qdvD$x ȑ$5zv=2 R\0gSJhq򅁒f +aNLD뙕bH'7n\X))P6g*@ɜ}n_mCc9cLY2Oh$|OI-HîzLTHRo]x$AI)j㍫SPu6l}-iYl1Pps.&n'I@= |CLw[:.@wr{zپͮtQ9m|Y`I۶چ}O{wbJ3VBJ$t g3oH 6 ܒRh/L^Gd5c}zD?Qi浔~2wYЬy~K +#IiX(OqILJ,T\#V0 ïw= ilے f# ]~i '.S~Zm}B r *ׄe=k`cShEԼh.E cφKrbDIK#"-)”c;& Ўp*&XAAD} 7{ 1A'(5O0*릶Y꼎Z/> ([;r; %+PnHlQr7M[z͏V.<{I.O9EtHqڑб>G_#;}*@FLSK@5S,1<22!hh8LV#%Y1-3aaNqk5fAv OVx.N"WqhYzUB&ͫv0rF0%(rih^ip; 0.E*m^Ib3ƙ4G#YPa`L#z2 ǧX `9R1EVa<<Շ_:L_l !KبN8t*}ZU"j\>&K<|ܻSAMIINH?}aE7,ծ-äp0m-zOJJ RbA7saڒx" Z4wP<0Ly}7#uM~yt_Ym6?m6&Q4,i ݤݕf)h|)Xet" y?/#); he7Ҕ7^1&3EB9!d"^'dáO+ha?Y،>f,!a>Lg]Ym`ߧj[nn%~n44E endstream endobj 1776 0 obj <> stream xYK6WE D ߤЦ R4[֖dѣw(zؔ׻X4H`Q9̓3YaGVVݮ^+Qݭ^WfM}ssΣᆪ&߬nnD $00Vw@P'Hޯ=k6u~l|SLxXZn 9HR6DD ukEJQUp̪ڥȯmPU,8 ՏBg_]]6̭B"pro"DKDgj0"m.Ý8JrKq]Y):8 փ,cO`GClYdA%QDuln};昃Kh0&m 7ۧm9 +)KF^NZ, p+т ..8vb`_gi5my&} `/XQ!;Y3IK;jO yH7;Znro drX2r 'P

W! ~2 ?Ob#}`qZyL]J"] "[T"xcYmևT( ">!. t*C,SřBf!ԕY"@֙d:̃^c"*!)N!I0VouU#-o&Ph#N>&oƾ5vX{ X)N6Ŝ+!j C˴nyM }0lVf0CFЇCjh&xU{;Y<7x%ؔ61Ę*1iF4kyQ)q]!/zt'@iDg"-{ADvL LƜMvti>mחc˝pSǔԗbK6Umꊭ+XQJd4gu]J\whL;i[߱P\q0-H5| pYUk/ܒZ^@˜\x /z_2\1[vSo;ܗf"l1BG\^QDGtFJQL噍zVhjJ8D[0ֺsyJ %!;B$'y, <}2~-j>r9۸ͨtl% H33޾{1g1d=%tSZث.| Ջ* n B7%QǮ_ԼһJ]5-$6ˋ܆/%9T/Oy0`alxj:aH 6]cJ- 蟴LÐ]G2=ۺyI 905뼸.1#k o]ӢpwCjr%6qI endstream endobj 1779 0 obj <> stream xX[o~SA-V M6ؠ틽45Pq3Hy(lp4<'I2 8)w߮ф`"6!yBRd4+izg#C*g00Eqy,$\PE(KC]?N41oLwWTnג)v:ek1 =cH(/^CbW%ڴ~=4efwNvl$q*QbX"F漢1T" <$g"B3f.ücs(9b^`b7|yznX O-' uB&0CYkk[颎[~ )J(t/*r9ԁX?̈́f24ߘ7n/TQt2XjSBH7P6"L1 ;?/xMUǫHMd:Ns7#--T,CgHK` z0u0R9FZs.,4udKSl4*b%J#fN>&S0Xe -X*9rYg挺+;'b& ?# $q 0~^QeX-G58Χ-~} .62h8vf$l-0V0 ss1ٙM϶S$T#[E3dal< XwXn3vW/f9 OH0.ƻ*ՒKB 7ikڝovhxOw6؅uM0fmZ6zb^,ەomtP( {< SvS #cTB0*OU?ݻ̢rxl;fcbn+%N.-ZÈx>1?=pǿ.vAcÚⱀ8}N4O5vrS-s^/Κy3y-0XS{B!LͳA p T9vTg]deyd~_p' |#(?.@1 endstream endobj 1782 0 obj <> stream xڽXK6WT@"搶=helsmJrdɡޠ z?~qb ormfD덏+wN}{QXFr E>}>M>TeqX4iֵna`\>iO~SՁ_mzfmn]\*$P:: ޿) [r!4>Y4L{[(%M([P81AdW "KYaq])J 9놷σ-׿LZaO0/_{'@g`Ǫ:*(2yD޵76y0w|RO{ 2rX ~ b;_ʄߢJµnJ?mhF"E eyhmxʯ9"^eI'7vuSg^0 ǕЇ >H/ VmF8nBI1q/(Q(hY좰d e[YfC[ iL}eKH*R{`,JTc#*L 鵠ଘ]E^+@v iAam3*)*I=@axwqށͩ7 K7Ҩa'UkluXUFZ]/A=? kU/ Cԭ;NXVuR@skïA^ aPv?;Cjr¸A^55H؄MZu[abSQnpTK~\U]VI 6y+/qru  99hŷI}498jhWADʱv-6,08n~mzvq\T۪89G2'оTۑhi AO7y|yJ9cGLF-Nfd^0o:\, ǽtv;2GS6ZCH0A&ߜKsˣIRD_g*FY=Q jRW+!z_u?lU,MӶ ǡ/%E%J> stream xXKFWLaޒDHQT%89 KF`SyH͒"IUjV#~|CD" ?$J)hs_F_҈`Dda(Y^"Njw˟"(JSgo޾Z$v_phj;ڧϛEBx3Ti_m mm:$h!Kl j!HOTEA)aL"xD nMb&\ZkQd/SGE ҳvgtXK\o:vFp4'1JqꥄS?f y|BEuު&VېBn{s2ɗ!)yǪGh[&fEg_DD A|l1Fz=`9H%`ؼWEe6)T<*g_%q5SLL3W"G:ғLaAHm4U$P Kpt,֕t h _iI0H*fI>>u~SQ4 ˢj|L}-ROh`ѽI(:HxH"Qf_[ClLжl?1c%;cN4OӾ莿[2AЩ0_籲=^/o>d+pqRy/yl + %Js92F9#>rSՍ#*uT5.)f2Wj3< $'5DdSދewK#c endstream endobj 1788 0 obj <> stream xڵXKsFWPC`k{9V%Qb|V@[a ɵޒhu`@Qr\/R`$ < |:c!Q9?6U}]7◀$(R=ac1).(!ۛEUmXP>T.uW.mn]UQekoUɢ, k֪6o+)m$ڧ0jYQX|$J0yOXgѺΡs8-nS̱@0aX0 EIB&񯊕?IIOOgH(D6ܘ(iXF 0<1j'F`x.M2H;_wrbܛ=r+ʚD&M, } >+uN*7K+uEIdZWzVhl/Tpa;ߴ8',|&'m& 4N^}Qc$i]&&do6u=U8kv;BG[ endstream endobj 1791 0 obj <> stream xY[۸~0#ީ^RbiOUؒW3EsHJdjƞv 3i<\xiA хf,W؂&$MRfA9IYn>F2e˻35-cy~_EspO13%Qk~GYuqEJ 7yC[T7 ,bn_4JLuR*"v=>y:|H'e1~C"!osN~j5G^JmxT/ee"+vp1# }u)g,Xns?CNQw̔c&NީlVnݪ$?"*'TRK--\(wH QyqAtIXx"*CQf)+T78%ܡjr9qDKyI0 @2GoГM|BT\$]X%QZCj,q,CAW_"J,hu 'LuWDa-a@XnUBEo4Tt#b9ݮ

ڱˮқٺC%cu|z oZϲPkW,d >_b'}qS^zr)%B A8*`O0_'إ 'o|c;tIςX)t Vlx O\׉d ,=8т+Xyl䮑tLP 2͵, %ZJS75ݧ=بYA{KX\KeG,˰r.ۚs #nMXbXQ-&d\ŗ%Xe4ߝS_*&z}h7ؓ$51aS vqR~}lkutl)즑AarllSdK<KoɅS u`葏3Cj{;7S[bih\[`%ۚbNadsLh9!aqu#=0F_6]\r>ohLf)(vG_]4FCt)o+Yu}o|=KL{Yl{Wk5m}F˒1*aڥyBq>?g"Y!R*7s-Qpؖo0Ӏ[2kvA%G}}BVjno\:BT3V"JuuƠ,Eƅd BO.N @Uc٩ϛn97~ۗmk R(x#l'ӓ28HT**fɴiXm֠uə4˥WC]oh7Qjy)h=ī7oU5w5-O!&-ӯe<:{J&E-YU,N_ WkMA T{TF(GYzn{WKw׷vnrъU8Φ{hVT};-iXPõXusľnt >O@A_bRIg3yZ|V|w³b\KƯ } >qmrn}*Aɓ7}=ʾʘ:ѼC8C.tl~rW :ĔJg<<' 4%v>4tniV6I@"z8~ Q)pOgK;[+/LjǸ47xWOuYpo% 7 7]O6Y$Se`ZHf&_ eYveoz5XSA"<5G]bѥqͤ{BA#~4O(J$ECW|yGQYrD|Rsym$uޝ[|lH)J)*ͽzL(255(i{rh+#ix?NM> stream xڽZY#~ϯKΈ<'' N]i2yxߝŏwu|ߖ&. 7gK[#y`Xxl N7[ WjZ!6;Wj+ ΛXJ2Ͷ|}yDMk3k+E~7[WEτWwu]b+@E4rL R'։5 rFYؕNtmt/@2ߩ;b0;Hw|@ItIBedx]/.ь˷^TMZZ2NBP\Kӵ]}-L\qKv:_<5OPLPTCA43U^VUw+/uxrH!1u٣]*'EX?@cyj9t }w `$hF݄(zc[<(՞Zl+(%\@qXGc"cm 'GyH۰ N e 6gDy-.< t$n&#*3AZPGy0eF0 g|UhM|/tA!&qu^v$]ɤMR>|zd tbG o D7ȶ;䕐FUT͌BcC=Eځ@f|/(?nS.AuL3 R"YMd1!§!gڟ #6yqv6$!ِjs&8$P5% é Fw9Cքs1SH5 {<39 bXJgI l!0 ֫ Rx}o_:kb:grɆ0]҅I zJ049RӹB]Qls_tdxUzb83rK 0ܰ/9`yڵ)PF}Z3$E v?$U[h8N<.<-dudDLKFLF3VEc27٪[a!LH^)yQBci`\j[0|DbpEwV:2 5,SI">2g1; ITLIIWU>$_eFsyw&l7n%pIG$X@._#YA0G@BJb7W_)ZklHCܜNZ"zuAU^3Xl} P+"M/W|0_@"uڝ UVƢ(~4:r97@x?+8oUFߣK$\ [w&ʬur Cx3FjBLDJ>e'D<1 v+i&_@עF55@bM86+P8<ɵ7 ؟6Bx.wU߿q;Zǐr;+<۸Jd6[R1 ~v|tQ}UP2ڈ jz9a<Zlbi71 dkuqSW`;T UBbGwq֣{1$in}O6r2_T[ *RŜMO#*bYa FbQz'LRX)c.saɅe 3ga:<9P@]Pe_dM6uogORZW]?aK/b jYQLw %ϞǾ9Xu*fw>JŽ~}6Dw cC̡d@(#>Q9 \H!"GL⥸PpkCg(߳3)i+2HRt˙YE,{fֻkfK1>ٽٸJB~H1u]^N A9I].jE#+ͯ cWkª.'O;^561$:x endstream endobj 3129 0 obj <> stream xZ[~0RX3I$7A4h AѠ֌ؒCR4e4@ H#$;9ӂ-(c ?]-/%{\0`w?m+!D˕ۮ~4 es%'%|h&eɊ~hw0l-R!~Unr+^<,yU^*]<<ٸm ފb>mq]4ftc=}?ZqSmbzdnS&ݤ$T:7k\ܶa?y{#ݓ{ kN CJYqq ;R UOԄqHrfQn81BTb>,`-&dJrHj%LJI̪:i!It9qoz:#O/t`Ϯyþ“U0}ۍvBEE$f;6c34֨ϪisG] 15S]ΌfvGwԴBҳi51Ӭ Ing{w}rw]cZ0 g8q?˹KW|@sla}la 0"8aa+EQwίIqij4$ ?mR<`w \X L!IVpiBpiSͶZ|bT5IFr棛380({2nM~#)-p/]nݫ{97\UR?/5/ҁ{Exv$WR+'**D }Ҳde.9:m $V+.ztsLۣftcn6R '7gi]Pud&ҿTDT.0ףxrC.#`Rk5DxγQ]xc4i3DUQfWfen}lꡙat;0skא*^ZX$ ] j=DSFgMKp-I쐍`}6^zo30 u3 <;ZW: de`&tM2QGINDb!pn2߻3(^$Fcܾ-few!.c> X&#8GcO5:SVEjLb> *"K'D/Ym¢>B*>V) ׅ\2lD(AC@f"V!>b{xDPB|94lXqhv \WCK56A\~Z.a`߬bcF*Tޙ:'}.$"ȫs5SR v?DAj"R/TTAsKOt9[nIt}DX7zx B|=@N>t]9&ϐ7IG+_bCo|eTbޥ\\/,z|;P@ &iȇ7竰GWʇvd! ]WHC.|H~lB~7 %"L;7;Ry YבBRlov dػpOK>_d:SkV;WӶ#e­~ۜ\8~2';VA١[՛.290@v.6*XCs;nH siny^4++= ,|ZTg0}vӰZ.HTI>iүeבBB^KA*j] cƆ–+Э%gm!!"_A:J )#oӂSy{KT*v 0rf]}|ٍ}mN~3>GKuYC /rD UfH.g%n 쬕&@rm8|fM bXu1 Rf#S ÄӶY]^4I!)PEе[MbTxs* DP|W}YXʬT]LB6N 2mkPkG=׍->-@!05Qm%h)bfGſ&⇚C`A@/'fv 2hjBBGk{R9!5 7oC P`݅#GUΕ`RK,1Q+˄M^ 2hWҨI%OTLCیL3ρ; ,҄&n Ng =UF3f3DjT?)Y&hKDp͒·0#=a*qFIy~!%C՗&4*!08Bf'vHNmKSʨMwa>47pslf,77)ab>=cLzZՋ[_B.dAc oε!~Ogj$٭G?A%DSd4\FM%.k2kd:$?) endstream endobj 3132 0 obj <> stream xڥZێ}WK;7!F`ǀ9g^Ei6ʃ=U]l^4#.-KuթSu +_/>Z,x,w .Y~gҭ~v!`Jxo߬Rel~?ݮm=][nNY <^?ZM^Q*g+?S{5/Ůd\#)2F3<,G;DzrDp@\kfp]`52ikJUi_ dp H"ö:_/.]px89?ql6%}jb8poS c5  C6S.-Lʁo|. p `baoz[F)#Mnk vB:A¸B. e]"'փ̆0rW յ[c8t s{n/ÔӖ;r:/ϲiQi+ 5$A˄֯:e9aYfX4,R#C[yq:)9Hx9f .R_]VRV.1SY߄.P.8߾\ [>]I-U-NsyLBM:!;G 8>+i ;e f ҁ|TT&I;~롤z/Nށ2 IRrԋc5=,I$^7LxB†76bWR}q>cAE{|m?btc}(TD2yi(ϲ/šZ!T=uZ ]QWu[~o{T'9W-}%$a *:IfЗNZaůVaiH3E vV,ʆ>6r>pyyߊy<7+uȘ`{O ^ M0.-p\ Dcb8%y"=SF%^p8AE V4B}Awdmtb  17ɫړ|*!1dlS*VSvWu%}ܴ5-Q}z萕`Ĩ[Q@gHF%k 'm1zjsq> EAˉlX53ə&Y.A&51YZؿ>$\@ :$SO|BC9qL.!j#f(^NɅk(4ܕ Ŵty{Y55fYEk6H#}<{ =ϲ@XDfy/E op eGom-7:PSp>y/5I5w+V T{UƊ#JP Ы3n 5f/zѺ,<a^ Ě 9{&(\C4>CAEZRGFCuf&VqG@HdxxRnW ^t2kqJKuKU\t'uJ:&5[ c}CxjU0[]ԇ؞iЏ A~F xC0^뻈:_ʥr'b 2B6X+JɌ/&*ut?hEO͚; ` }p B2POnc\?qngʸt0鞟I((_f1DY*>e_/D endstream endobj 3135 0 obj <> stream xڥZK WjGN٩U)-G<%r;>@7"nJ-j4W؊?2_1Jul_1b8iWO-[o[o?Tv>k%rXp?8QF:b7+[JXaTk!46gs0ÉT">)eJs8_֊!`DQ~YXO9#B/vhYVgzV̩qG)0HRDL-MP 4{nvaN ?l:A^7:>T^Sڿ81S[4zeVӌ_6G@e1 ;*Y6ev{Jl{.]̺6BBh bq+z> u)׳2pG0tЄF_>,|G@]4ܢ%$ѣ^VDmG,~n㣼vUӗQuDZ"!Torp[])ȮƥCnvß}x 8u"6))=u>y;Um;~}Ɏ*AU_[oOh!mh]|I;$wK\w۹v$0Dq M>Ŷ:k>UxZUtkz$KDޡ%x-1ѝ 'uX)$o_:/Wi(Έr2h$mv3es0r'A>oڗfL%ĂT/.!u *b hwRHj?POf:4`U & v=A".%VrB/AT"& l@63Za TT_  * P&1M!\'ԄWp!U"wթҔ} }6~n'AR.q%qKkx24dcl+:>nX>Fdبڗy`bUMWF5*oNʋ=P )Fҭ mS 7{ڔ:' ԣ\(yAK/$G-Zu4ـFp/hd8dcE`@ljAnL܌KSPǢK0y{7˧Nzc,rnTz-zINaL S͐Q#xM6%*Z=b(d: 7JRsp!?|9JuB8l4DGƿML~2/ιtb1fUep+XuE}b19ZXn;odqCe!$nj=aCȭ}m1: /OaL>ϕS+1.R;<-&d9'c=hbZN.I1b^BCu+&Vz EipQSvᏕ/91؁- ?UTB$'9%ӵ'4 @`Ҍ{<4!a[v}dŞNsMU妤 x%7UF]}+ϔMt~ %.pӉO{ BL 2w[H/ֈZ&jQ'Hy]3Bf'XZ -0 c'1.swm"MFx0 3PI\1 ͉cq*avr^0>yu!f4[]:o8 #_&kA+ΒYgeNm8zLH׃ J؍$iֵ)9+4_7Qu"Yib^=.8]N-/Q]] (Rs(z"9DGÎSCEDgbLOڔ.hl0c[k齄4mQ2 w<5klsHU Bi9Lp,$2h/B(ŷsnЊǦO.@}>f7iuV|:8Ãa4? !ꀫW:|Khfb|;ZaNӳfqO.%nB%-1=u ymo/@C'4؁z;" 5?4oU12'Rn_"Ah ᕑz}!19EcWfNdQ(Hϻޣw4m|քbǩ+ 6ؽ .ҋP"ByPdZ$( qSm}Z,U%"<b,. g ^@lXK.†s ̝w^Ɛ/mәu$\?O,[DR J:ؤ @]Ƥ];272 (i*d:۸8 IؐM"[t˸1D~ ~y\IR_0;CdbRFb8F:ɈI o>e AqA .q˓tP/pqDPU]ƹ}8x<ŋPvX*jXX/.G_x 9jZ%I#}Yiy2!Ƿ='Wб |m8w<6zF>t!oԸ~_Z){]Tu79pJH 8\ڱj9_aKjUC-ݹ iD[y~pz_Q1ǧտw$~ endstream endobj 3138 0 obj <> stream xڽZ[۸~0Ibx%imۜ6cʒWY3Yl'A!-Q\f.RCt/~|X|-hJ I!旄"](s|O\qΓɻe'iHW>k\~xuGNuSĨ3-䅘b$3"uHLt+*9KXvh5:Γ5iQIDQSF)):oȌ+n7 gvvv2)+*O^W[sGM?}od%QLMUGe*YvYa0H-^yAH8umۚFFRD?cjm'gRVgcc$`i] !ZGBR#ٚjr0),Le7O'i>LFOIu]Qm* C%PJ(% 쬸ɟ$l6?ގ îbmEUC-5dIݪ?> /3܎܊/,o#<-\. LG.! F*xn;pF6`bnܷNoW[9ݿ?Ƨ;i2nog>MHa~ayT*^e|`rNG$` .0wqȌMϨkBT.5rn KMi}4IFBtz >0t-#޷v1aμmA节E2ɺۧ H+{':`Z>s_̸,hneӦ7Dv4&F"xaX^rmmUok(" p9 <@i>''`FW&u-XC',Z@`LD{[B+M"釶Cnћw& Ɍ!/ĵx.8.)x1 ;B'p>KR)Fɉc1E)qy {4Kq¸ZM!0y|2f>ltG9abA1.1_ecyN(f*,![4z#K3*F ~y7,ҩ[oʧIyΞIdLk`m3NODy7,@T]/i V?aR ܼ[M? IK5naAFDf 4(gT`YhXV =TsHl$xi;P^9 B;N%*S2I+t;7m/8T4:sf*,@oSvMl{ HZ{N) & WΤߏ8@-'=\at2egp)+IRd"z:8ľN13zkX3Tv< 3`^2/=*fH:,\@io.b{N@^HUF;x53 ^5\]$wJyeF120$@)}&(fE:6miKWnPAP]l.kOjxbέX vE7L Cُ V-r]$wP;f41#"J' ag{rì}@]Zޔ>Z@8MCzsqgku@cՔsWEV@;s|,2Yp⑍DBK^%Z -l,~U ^mʡ3󲵝1K:t1"C))|-~~?/ ,\[e?/ORŤv =2{XoK.1[rQ A+(\/䥣 pKܐ̑-ٟj5!F 9SZI}a'0:#j2c6^W~kǫq-n?s9P; eskZwC}g|[eR=N%h] meO+ u63v[Z+Eg ^@N1WQc'%)k4ד36uefbօ)gk~dk<L (Ynmr(\2ȺϠ$ ڶn([mlEC#y(aah@m%V0۱RBCpӯ ]5J1 ҮJ s)7g'']富K<'RlSSM]i:B+fp&)DOnc endstream endobj 3141 0 obj <> stream xڭZKW{ ~ ,\29PG-2Iy2>UbSnjAz}U*J3v՟?޽g+2/+I)es1z#~>uPJǴ`0~@sA"^vmDI *rte<[jV$ϩ7g~PA8ӫMVS~mku}}nLgc56,e$xx.fgp±;رc_׬j;R Cனz0BkJJ<#Մ{EQ䱳yv~ZڑRF ]8U첖y5:/-)C36B\QS&Tx[vfOFSt:jJ?1-e ،0%oaN(`jc qn>Z\2QYf{zCC{6iA !ݩ4#|&d!yI 00VS3 K3?Ni*ƒ갵5S N_?OXF.d3 wX P 3jU$I's̢resȹaRD c*Sj [?d&pMb-|{[7me2~ȩh rLߦN@!㢀B(&x¯v% yE(vng _9'3GSp>9/NN븰)>շz;6Z"@ `S|HS;5jvnH[792nD]ʡ@Tf_S\|jVF *##}c'yy]6q4N, t74:-jȉy1z{He'}N6q@To^tS)S.A4]禭F_\f-I9 :tnS&W.8SI]_j ([_p4Ag^׉0T wN'/5)n01pL YH PuOnkND󌁋B@Y7\E͘+ϴq}=frQJs<,0 Ș`WZuz% TsJ=+2Z:,Ckϗ9*rš \t$m Yl`y]&.d}̴ Yb_LT56H*3\ Ny}}C\Q1KT2"Aپ7Q/ɾZ^R KBQJ6B/Iӱn¦-B\m7.%\gˡM/J<9,I]{j͹PT_z- DX(͵AIfI|OT`)msZ`no$4v;ݢiPYpfsi7 9dqTiC 6˲2 5o=ćٮ?̝Jk<4"F؆\[ZhN|<=[_|k_.(؝|я5k)"a7yM vW&5}X:J`8)XǰpLL5)lx46 ! F[s3XԨnc b_/!,*C[ !wiPKy&(79VP7pxkS3wչq•.\ss?\S3#%q ؁eYt/*PI" R Fwv{{˨mwL>9= f3.X]V%P ` a ("g5|g9~ӵxKip|]$Yl׾+3wLJt*ea~9)p7;9_@_ KyjwFIʅAx|\$6 endstream endobj 3144 0 obj <> stream xڭYK۸Wr,LNd7TT&8fD[$$ק 44S2ID7ob7Z_)͟6,a͆K%fsw5q"}#`ZKxmwR(t?7UxD('K [ޭZ1.<*"yhv~ZاQ~}:Eٟ^蹬e@k4Ѷeg9qQ X ,\VO' y_6uYHf7dՍߓJ$Mjs:D ^yt-zVO}GЌ8j%,թwJYU>?>v8KT_m Rli)%$N yq>lel恮(eϙ3 W'!KOݹ#>d's_ʹ>XKù5]XWPx*璭))vJ3n"\V&Y5 Y*oh-IԽt`whuU,eT.m,6zx1wa1i;ؠ!1Iiiv闲yUvs&c0Ƅ,! n":U =܀j۲HN{ ˄%Bi="0ODeJxd+Vٍiq(G1w c!>l7͸^wjgT,Cci4ˎ:-I4{n .=<= 5YHi+Q"-Ԍ'JuΓbUs}]:i!|A!|foN%n9RʅOF$S{lW=?`XN})٤2]a3Lڊu%Q Zb&Tzߴy]-Ritt((8F.`19&qrU>1a _ZYӵk*f5b%DS7fɽJHXQN7:չN|Pn婣*<-mKO=Nxz6,:h4wRCÝCzHfԈh@ ͹]k'0 ҳ )h@OomOeFnjA.`GXPbM%,3tf2t~,^]WjB>WSI8SlΏNLSZ"!bb{N'R{0x @l~ZgsbuLszwy葾C`iwMWzr&<ʚN`)񧼣Q x|V^1zK Q`}Z]皴ֳh&@9b^R;bp nL%ipd>>X7/>A\xA:jvxBR޾xb4$m_V%J8Tè,ntIn`=/M d Tvdzv&[4~μłב|;٘cOd[bk e#0[8#dEDS~c}`˱TסETxP94}o7wJMyQخ+#2 ^}\5rBr[ t׏9_C?И~6<&^ڢy'3OT80)E> stream xZ[~0$kFL )R([&[;-yu*Kڳhb+s?9oJ7r?mvG%R›,7"kS}aD|1Ɗqow0xK pɨG/vL!vĬkn1vGdѸEx<-/ x)Fŕ#qz'[;p@Iq ?t}=Cғ3DN-΃f̱7L/@4,&!p&8gC"Ʃԁ3K*oEV268V$ ܬ͌67 Um7H0O0Baes9C13O b-~KþZ%ȦqbH "\ # (KvSzbJ Op EbO/x,sxn)E{}fmE"]|Nd #sl0Ѐ*bau (XێPTYQMYEےGgIK`ppe94 +0gzrVNJ0?s>m!>@ $MV**U2!xЋN74%#)Q$#  C{X(̪>0e+i-bv2{{==v_}ooюSWGrVC.64[H]s?2,ₘk A2iXPTIu3: 2 Ȱ\XH ܌02`sSuyf'&id4 Z uDHh;DA5#2*}~sWMƗ]|x96%eu`Q"!LYTU3OASV'4hbgZ)T:4Xo~BTîGWCtV)S{r䗨L!ٵ n+%S,a_EZ1I>b p\FڻԌTs! V 7BP@ aIz3դn^*dkxk u47#6Ьd;1d݄P,Z$`0x/YVY/qoY)I%",ZrXG)5ԚJЈ5Fq^ 5o1 ieqioqvq 'WYcn`3H._|xgh2v,cdċ@@%)^X)1EZ;0EV9dPI7P/T6zþ~fBT+.T4Ppv[`DX/₲x GGE;hcj4\h[}}<6.%lB^;*<]_ÀkeIn>@̝1SŊAM}ڝST8RJ&%ҹo_}ruq2[  8WMBd-hrmC ZtSk|jW*etja~ۤo@⢂}zd%A%#"=\0uX:.cD^0SQx7am9ͨ,QLS . {`v3+Y!U]Lް46KDRT7Tb+Rhʥ4u]Eby6z+]caSE=z$) /(sN@,ӭj5ŵXy *1mYIJeG(sʢ뱃?,c>UzB:J4!旙Onê.h1yX.?̒00JNDim6C 1yU!eӚ>LdYGYBA>úzUngHY`42i! Yף[/obHVЭ-3V` %AhQXeL΁85Ϻ׷{݈i8NIQ8--7Y:o%ciMU+ەg]>ԊD R>:~ӡO(-Ќ8(A80if:>f9( SVwh~Tµ7hŭ0ث;ߴdhʵ uHl t:wCc>r ,>!9; o6wTBۯΞ:`aErK',Rʮa\@O~$ħ8Uz31$N?)1>l}1c;F+RͻW *&>Q2v 6o4\YFš"8&j~Q\%qrU]U R}enI0qfmP{" ii|*E}i~0YGAu;vϰ!pV؜#NjSS`Vkqdy=> stream xZݓ_AKɐ7GRJ\r/:?pήߞ`a5]) COOOsɇ&9GyR$/_KܼKN('mJs!~{8#Es|o2yZu;wn^}Hkƃ{m1ǽXNVb9wfDI4vƍ7CW(S7Nk $ A?jԂ\%UWIw;wupD]n=ڋMw~O{Q EJ&0TMMe;sSљ+Iӝ:cJ<~ԛiC[+Rgx%eZG쉺n2!Dzmy%l+jhSP`>fh m=f Yt Z /D]ȲDv)nM~"Oo hju)IQeYfBKhC}(FT۫,M8ծQnjc7ɇ0YbJL SO:!8E#wl:Xk9)xڳ~_ݛak-ʞgYLoB3!5z׬:6; O"P;[]/9 nS4bUa\`+PcF#0;v5BM/A$3Dt6!;sG̓YCe\ IoE[?4kyqj a˅ws ^LMb&|@T7,Wys{:덱KMyTzwp2r5g>9%Z˳搅mۘΔ1?ATC4GSMe. +89ʐe Wg9x Wb20cBT8R2ʧbH-W ;jFwWuj>h؟4Tt0ZcB@] '+V-wsXYVa (mԟ ]RH;񟾅Crd^ï] 0 ocgr J}-`g'S4\3,{z{V<hD'#SF=Ff0X8?aNAD}R%!jZ@ 6€ďNv<0F[tu `w ̞O>"aV+xbBݰ$R-0) nS ك)fs3Dg/-d j(,T͜,.Q5i9o0Sz.wfL!9ej-v]f-c`+=򝯣܋--*j(wM4 V~B!I 6Wsjz&ogwzJݒpI" b'20n*J ҊrC1^ֵ0$} /j!O 2u5S(FBm`EF#V:e:Y V5FεX2,~xI w~mc}e_Ќ]s"HYOй>x':QW شn1>Y -E f&JXIvϵ91M;C }*~kA)Um)TBkؔ7Um*Xy<}}yj ȗF#Ԣ~7X$WsdxC_O)9XfMJnLPm%H,>k 1.Ű(Sܢ7cj4[=09{4:sKhe!/W(GtA?^gsXb(u\bẴRT6LE+xՌXlY.4E [c_& 42> v 1B .$;=j""fL]:L|Ba࿢laъg( Ř ^SpbW1ۂˤ8jAj&E}Wք@ &j}1Ìș.h=UOgMةlM"zvgWP.è-j>|s> 2 t>M*2gٌLsT$z+g`gk{Fgg;SpS`n: n.dJNo<.Pchڹ^Bbg?mKe)]Z"Vvi]''vvApP߅AmԼ<UJ34JoѥpZ%3ykc^Oհk~1qD jssf YPCaYbSoCB%7C.fhQbٹnn]퐄:%us sQ }{L庲ũW6)mjaKM(Gwi:m I* _+!kBX1Gap|-SݎV[ wEw>'jZ dTtNDLk܁Z8f0@(:M)ўԍ[RB(W!Lew-9_J36X]@|pI]!y%O$iQ._5q0kqmtXchoՆŎ?g@ÿx endstream endobj 3153 0 obj <> stream xڭZێ}Wy1X}%'DZ'FA&5""$5OU_(rܔfw](uSb+ ت𗮶՟V~+F+WL#nCyl!2iRf۾/06~n6ͤ[~͋̾ڔvq=-V=~|1q󗿤Ttj _Pq:8G'7KJ % zTXNܟ˺~/,{8xAn-FcЬj b%y.k4`*{\PPsowNp RBx켶M!r-IJMkF!x~PGYHie"hə:^?Cq_ CwQXEVY?RE,~.Y5%"[cˑug> vd7r=秖<cḧ́,T8dH,V+ۏCגJ̯[)X c7ˤ %mxB#4JdP2;6"0zP@ ~ߟ;lђ4HLn!Kٙ8^ ,PvW G1eptm$nG<.S%>T!] -\nS|ׇKњpgVvvo˄Vc@er|M,yGva|@:.2"0< 1 ;뽺aP} S~wLvb)^S:1'Q\xTĥ }"AzDͅ?'ag" Ŝ5{U*Fr`ApoA*rvL*7|X \7hS-!QPY,*x0ˁ:e~#ё~K9X$NqbI Z&  \:(KR =s*aI)8QJD6gpH`:\#2NIZ|&٠:l#jld& . v],d\j$-,^*ᜐMY$OeWAmI(pRyd\{- RbʁkP|-7u zpʹI*&E>h:'\ XA`A$i=r4hԤ*%W) WVmIx8fқra ŊGۏ%HĨ i +qWAqmТ ) RcUKG@=>V 4{Cch{L<"&^UA8o귀U@!OC.}N"\,4pVń2S('jphg&4ͮ ic91sykѸ o5RΫqH'䦖o(OkPcSy{75+8Qȕ>gm[}X4< m"7vo\(_nի_W?^p),M rvho!Џ@:FI_a!ݶÓ 9/_;["޶ͮ2xr ݮoi^mc7^~1خV#\ "<\/$:x[N+nv h#17Aɩ5C/:H+K[q + Bړ _{G+ʰ# NWǪryqĪzG4\N!xSTCXxmBcqLe"z$:ދK4>S qQ`Jm_D4)qO/{Wj@xǑ^'՗a|0C/:4GoC endstream endobj 3156 0 obj <> stream xڵZ]}0`II}KM,d(-GwvSPELQs?+O j_a7r%*zx^r%RaDd+˴(rN_ۻuI}_o݁U];n-ds7;Y$oteεk{e=}YYv{^m`H2Kp}[;-Tl^gԛcsT:-t?>.lHb~ 1sazĝ*"pURmwviSv͖=>݉8VtP: qpK=q;jMT#odđgrD:X>% b܃2.)$V(ERGe瀨9l D*MpōLN{8%nsf!:I0k{8 {KeF)7ݵϾ%:3xzr՛VRW~{wI_`vE=Ӭ}kaѷ|Gb $Gk JTgi(J B&c 7CoؾɣT?njKe9!]Awzye's@s-8_4*ݛQ=cvqE!o$jW/Mh`-&!TEs;bbs(&U9QOF L8KV'\\D‚ÏңpJ6}vA<LE ]7e-m`V;5NexBO/>ɒm^ ՜%g-akKڃ<=7Tn ~ fX6ZԌ n[J[0Xdr>\ Zd8VnM1~ہMV s#;&jYPd'Չ+Vg |X Ub|!wZ[Y;^1ϙm=bF$Md܁&V+@4R%/"%_A=ߎ$?aaF&} DE37(HY :s~5i-2zQ!FU2tuw$˴e׺ƶJ@ñnmƕHפ"2U ܈$Z:V Bї̫Qǝﰯ7lBЬ+[cy 8v̍-m*ܖ YE?PL-j*el},EX[7yovΥ-* %A>" nQάrQ$Cx+&+kw5lˋ{)HmI5F JU9Tk-'h5_#$iׇg]ύcqt]zP6}U4X -*Ý։Uyų<8ZL-fWxhW[&$/Y+M&T3m~La.t86cGjսNpo @ lY/% EʵdIK@"<ȼ\L.֬scAS)N3^UҧW 8¢8m-i3jfF{ղ,=7߶}wxy n]<@:_$"ˊ-Em њ \lZ*nmZ%U/,Iqc1ul/iMUP!'k06{:ڇZF܋@m57<>"e4YMeыaScMVˏݓA yc益x]bO_;͕8cy8weT xa8 vZ|Ǎ;64#@OgB6{{ذckY ouտTAH> q> O&Km'l!ꪲmݒ}l S5\p]e>OG:Wji}C\"wМuڍ1kiKJe%5, GkXl:]e7;GR Lfd 0ך/N.K~UYV$o hjqH6ѭ`Um6n5~΋{>1i4SCX&L[3—p\ύg<~sn'65E{f&g6߀eb"v.U☄[ʮ;'!=zqBͨ`W/wE endstream endobj 3159 0 obj <> stream xڝZMWs 7% [:-Ok֖=_U$EInSEU^mC7эf_lv_6?6 eQaC͆rR y7Ku~s3ͅ?0T25 h!Ob9l>uEI jӸE lsM*뷒f՞W" ))b/5LTwۜlW/ga5ֹzpݖꫝSttL)"ҋ}Rq|{軓sOd%ѥU:Eg0wJW]~EID)Jd}_fK;Ͷ\Ys:sw:e*me3).(jKJh/aP6yFӆhSXlc3I.&cLHj9tʦ"axJZLEK$M4nwжb bY>9%,XYW~\¯ŏߘdUwE´]kk\c4(5`\MC.z)5ϜKk:sm\'Z@S,O)+a;cV-5#7 n?  :65B#Vku~u=5-krXCEqqJ@!Zd(1Yu2Bdg ** \m92КIn- @ 9ؕeXwcuGj)lZG ri7) AYޔaB+<ޖ[`6X\K: :[d0Âw)?(R9Ub#}=4GN%I . f^<,>& ܕ%ce `]1Ɉ@fV((1zm0nR4X|D')b - vl~ 1LA 8EmsH"0Szv_xk'! 6@c=w'\bXo/`C3 M * . e ' 0Ŷ.4uMVM?(I˟cc&f|j-@S=.g W&.iJ.U`s8͜o {+M_me< @|&;Dy{}^ktx!Ռ7R-G=gQ } YSlJWcF`yU$ĘJ[)Ď%rUѧI ڮo/u_ςǴ"U,hu<~suʫR!+pX08~S^!*+SlUJK%QTq\EC㮶E!0pqŖ bGrEa;cse_/rb<=ko-݆~>!-qh|L*V1gvUu/ +r}'2]To`U#JAƺwJK4ރa MW9өUR"!.ipi훾Y++-\s}WmX{%M9e8@! >9KYY >+4= mS:;6]W3+߽O%/& t8]J-XT)QĮ nhF*}/ G  u^VKleW@%is!掠jrvpsX+v\GHDA8}xg]'t #Qŭ͡J&`sc㽏?Qi7 zYp&W| ۵4hkjGL1o*W*0]C`| w]6La+Ibw˜YQC *ul%PhhV Z=5Q'~/(GiS$\{L*;''yXB䮿:L[,1(!",vno膞\1[͂YT0ç5Ķ [scc߻̙^]KoO7nոaeΉ4qn$ŁwEPpcH-KM1Lyݭd S#:S\uv*-V/ agD>+Q25|tWYOU)4Qg0𢉎p%A2RA%樿T'zIR.t_+RU= *>@Yq :/[B\ [*k^7|0.QR%"C8]}lǴ{}~6Puh6s;ej×;ڔ2>0GECkN`Y•ix.|ҭȣX-M‘aY`{|X;fL#] $}ട%aV\ZA1J]1 weXK(WMsFә}g%z2dP*oIxnu;z{6l} Sv(ѫκ "%S QcDҙ93jHXjX;M{΋oT]FwmQ;p~pf|_+`ڱFx5qMSbdw"k~E +r>([' AmM h'n:ҹwaԝxxpNjY'NV!yN'ݐx0|7@?W_2E7Rs{p \E|TNR@vmG09x ؕYD05"`vV^ή#bIy5,ru*F]BV+爵8 ~t'7 endstream endobj 3162 0 obj <> stream xڽZKWr1=TTZ$D"Ztj]I.DLOtuW*ti7og+[znE͊rbYٽh.7\1Έ^/_z9ϊz/?tjjUwwkfTkb*{l% 'ol[;6e9}Y…]<QsZ6ðyӬH4aRnEץ&fPkoLK J:@k۵3feU2%MSHj/NM].RE$qCdI/`zj8QTHRh/JI=W m8jI{pF}#I? F\7WGq8}riMwD2VX66</fzDn^. WkG6KdV(b؟[w}/)߫/• %&e/gA,M.b6Ip9[6a36~aN&̏QW^rKؠޕw9uL(*5!Lo{@_{[V_+7[{/۶ Yf&3,<_x>2t ,!|,az+.ur~sh/-xܣ~zQޅF[сaWrBލL >_01g)}GsC o;- Aq:nq=]0 8 72 ۳t' CuǠ>r,;i}JP$m_ H@Ia0A]w\<6epEI1D1M|xq^a1BLZ [wŗ[ p)juȖQ|X iTT9-TtWM() G!Φal fK\bNZq=F/ɅixrD<`q %Uӌ勪m8$DxPH@> 'ݟeD)xp׷#]g8byM= 9Iҧ!i-h 䭙yQLTt{ji" thvfV\/E>ȩ]y 5Ԅ0] ?AYDm9>+#S/ t.JH"E\Rhpե/ `/)*5Wgyv9 C-QJ^Z`4>Uخ!@˦2*>B [jyӻ`" DʍHB\aLꓸzr^h@H\t3^m-ag#O0o($$?M q\< bb(".ՕE~9-ȦX.ch#}vnz9l 5 <K!?4_Fd嘘蓠fp"8!rk9(bG1;7_@KyCwJ1STXkSIY!*W+fN^*ȋbTg?N^JaKψ^{(~i8R&\tyR ),YjH:% ͦ=8)Џ`HP. )&7)kdYrelRQ9MA^yuTJ3'LTs̑K~.ʈ2a 9-^ӽYHZ781 g hM4B4 )m kB߸p=pmv_!ܬ}s͐%2J k(di`f5G\j|*xaw}Vec\O7gjkWy"F!NT 6)n`9 S5N)8$T@~t8s|&ƣ qC^S/7\56!4<pN9+GyJ*o =vEٍ=Lo@YaJ6rk- Uk$ajBjVN"0<>+ V_@k l|;ޚL4w5}jWߛ(pD:w\nb*2kbSBm+ 0;?WWDjO+J@U(ơ/?8IfDO~*`8]<oM+ uǼN<;6ceCI)Zb|q _(&']*LԚÿK W7ZW^ ;T]h:%0= ƒW DHz"@e)\ۗH5@&JpY{#0NxYƹ,] 5w7=7݄Bq»c;7EL?2!)PxC* _!\ސ7]5_7G狢ETbf!x7%CH&5}۵rWrz3- AXd ;ɷr>~:uӌ*.#X'sb.l 3Od˟ I. endstream endobj 3168 0 obj <> stream xZݏ_a^̈"ѧ4MmC6Z[Ė =roZ+49f/Wiw/^1W9y~Kݼ;啮n~|յ߽f'6ݿtz|VtәF:W{w),W~SwHӹ;6vr]3ف\,ZQ1Q=.6Jm/mvY*7o[]i&x&?Yst&?Բm1+dJCV&Cn5:}KB}x(4kvk.-Ģ⊶z;=58>tcw Oq8\#đ=kM8Ì,h |x5:J4kQx&)9bL$]K!u\i6 >nyhߓZɠmni阰0 -s9/ER,&?BGTXmltr5&4$ܻoGЧ>4#|A߶ԖFti j'pM4gN ˜(m-ؤO>dOlHx{@i< c\'uPQHaxi]<-sҝ}iߜs:Mn*&@< gYP1^3k"Hw N\@Ql)`mEtCQ,H p7_ w=ȹeC*8^S ZX;r|hqR_*w);R߻];i@9M3v7Cs۷@}m~0e\)r`6' 3\b'r f!"+h>u|.!KKv`nzfuBϒ)B2͌77Vmau[vmOT`Zp 4̧?.HY= - 5/<#"<.y50SA='hO]9ѻ0/y}IF氵M " 2{PK9%f,N;YUcbbַ"yDiJ|Mc9=]bQS 03Npl/@gYu@դ@IX/y'#v_ay$ހ_9. V,eBJ)6LSwTnyavRm8A5 WJ ٚ%J=:3 |-5[fX+mƩGr[u K@A{u^H;ww@a&ndiCNNM4236LS|ן \aב>|{q&u 8v-*D8Վ/kN|dS*Ax4jN*Ѥ]$I0L~\|SKe|G(,ܳLK|ʭ6QaEdžo}pS6h&}cEFFv-7NӼrVB9❡ Aϱj2/b6<<$B]EKv$wZp!O|ؤ|/ fu睃hEֆAϠX[HNJ ]n:Uhby!?qnxZ]ЬPa9m>ܭ[(i`w4Bsxn Ez;^}tV7O~i±O3.?u{ߘ=@ՆqL/m={:!4lw4LWkUeWY/n+0K=f Yfqn8 tB7iklc>цi#hwӐ缼Rb;>Sd7_vZޖע%85_[ x_,xD'x2&A=zp*y/F>4h A TP8yW B99dy|y 'V.MzϬzhmcI c -FwxQPE(!cCW:'eBtxH Vȑ Xws*~7Ta)֕/ܬYV2c*za!nu4[xOєd+Z vqG/ d,lKRo; $Ms?l0&MDlj>uPWUĔ`Pr?_B"1zy*n&ϱ1@MxUPIG=_f27،4L/>jm[;W.&!n /,9<}osFw|j32A e[ٷO\`P\$huAyNMu!^ɷeRdC}ӗ0(Ooއb)t#iRa?s@ endstream endobj 3171 0 obj <> stream xڽZے}WJcn N*V.dىM,]"W|}\ pܕdZ\Lt>݃ H.rb_|))҂.nT-('P< U\qmB$?ھ/oW^LJjnDAW͝{E_9+LJ4qOM+Ŝ26""8BN\\&]u誾j,K^3Ra^uJŮҫI%{=#V5!j[ń k)M-%M6*s¿ԴC9mcE޶ycũ";mSo~V˽P49,e76%% 37Ħ]}_M "MƽMHLFK=6J[6DFҌgs|ȓ "ioD_XY7.~Տu[Qb_C1ʻ*6"#,O-Y k Ѯ>HbPzU["RIB>H14aDq$4A)"+}O23 ό$hAq 3;nP^b|("e2Yo%ֵ۾'`q/iy~]_0hIؚƣMLrkb㰜0NlS$ۯ`ii0UnBqJcׯ'F>E0QH;,Y},@հm1u|Ӳ>V& ʟsAZ;썙Au$FPwK}czteAG28S'"<"mofsv8Poq焥ɚ$-MѱLJ'! V?3dI^({Tuzѳ=6k.GP3y{29-8$2 Ue5^PQ2ɿD]<ݵbup%x6[8g[c yJ٬5l|P})BXK=iplzMW:.-iZ6c:17)>ԧپbt};lٸ2SiqވF+Fb3mρUxL!z:i۳ULǧo㓅^*1Tv- hRXr}}78[;cxQ {eܵ3ѮHVL"?1mf2;q6ؘѰ(`eP-wI"JI~ ޹. 7Q(H'E h#* T' Yc*l&ΊwƛJxӅ¶xV˜KB宦+aܑ\- 1`ee`'@hŨ4!Tu_eBPe(8j :l3vX&ޛl+Ūq$)Y\jǦXZ^L#] t/}FBpr{7Hk,Zv\$1G>o$R5JOj!i(8igzD!li!)kx!p endstream endobj 3174 0 obj <> stream xڵZr6}߯PIF6ٝV*SZ-N$R!q({25Sŋїs^bJsWWYlubfDVJf7?{ϴ^77!ĺjv_=ۆۺ?lo6ܬmn^NWt8Faմ}r>H_o:x$XqMΊ1fa\y%rSn!7i1R, Q-fHMQ&Հ/%_﫞n`ݮq"\7mwѴ9udaİoY^f`n~@( Lz4җ~D?Φ2|dͮn^}dBZ6"P_OߨvyVn9 bE)Wql6yr"1PJ<4X7uLhջu?*tpRn{y[|Ww-VHY)8эeKJlTO|~!Bj;Plۦ-%pkku:ym{qwC'KӏUcl#ihf6ގNTvD NִO:r3&˙l0MB,#FauJFh2Ӑ?omW!;'eqȬd qE˚?=m# 5bpPZ)3%-L6c!Oj DwkNaAһm_r#?atПV&)ua~V-KZM藴噌Y+hZՎy#dWi05ʸB/Hm0nVQLr+ p.ۿZLG_野^om߻D+8ۉ_w7wr,F>E͸EXoŹ@y.Ff`欞eL5Fn&_R;7U5Kxr[a\rki.NRa1?VM%/(b#JȷgW0y0k޶]4wZr<cM$>v(T)mO%rvv)ԑu_]VYL˹w"ʙF9K Fp ra.fs1믁C+m ~=hJT*F,T9&o(ڜ]rϱѽ_Qs=M/y~Nf!? & aY2Dծ123*7>Д`br\ޡ=:`dܴI LS{DY2QÿiލY#z0}G^E(.HrWMQؽiKQ#F#Cwa&z9)_C}q/7դ?lBBPj!CqS30wM]bl]L36Gfg}5TŽl@G˴ݗ~jV!) ^<=R7agSMȟ[Ol rlV ww &coUWFĒiL/qgoڠ083Gp=zCH.g#ۀޮ~]e( nu$[D2WՏ*\n"zēK|Wo]-ӾzKi" "c[⺹u/l ZF <:|SL6DȣmlDZ4޵/O­: 8}ʸ;ucW#)x0">+n:wѲˮiE6ϊ|4E=}y[Y@1KBf&F8 |@~D/PjT Au"`:e>sy[#sR|$p{dhfҠ(^ 쐲Z}.xJjC|RxV)jgXh9GɛN/jomdgzz"kv2':C0K*jӶچJNV+\?F@ J Di}+"|%~vp`9w?-*+#~?0ְ~e=aj/,k:qU-?A@.iN x2y7NaҶO4 WX$2W{Z&Z)"ޑZiJleb}Bܑ{ڽŒF W"EP-F-"MFY/zcL(2"T~hW5%7 d$RP vzzF̕S6̻r+QY<\oy^s= LB)^q#܁2w'Q{ xsNַz)Gj7wPSM3^X[޵3Xzåd_p4!c"!bG:y`"PQ&/im -5 hFe/UHjnhѼ̑S0,EUEpn{y; i/"Lb%ST{?ce9Sӽs:|r13wudޑ ^0E3phgz9]:Vz-CuMX,9b!EgS.$=:@yjWE5E WOAQνgOYJO)VN;z~ùS%w`B@.I gr2*gGD-&G/!dm&g̍jiXkTi'V3YE3Ԅ>Eۅ?m1^rBs?!`-[U@3vW' endstream endobj 3177 0 obj <> stream xڭZKܶWLĭxI)璸lyH|xGh%% ~[?2t9'bTb݊+&H%?ZQpׇuu$^f%Fk8Q_ˊL_}_ID ƈy Jܧn)R[2}K' i7S斦JHܒ„qPw]cFLY,?DV[nt95YW+%\e=JiS9D.GB¾ (ݽ LV F*SusĠ}BSX~[+mWr CGB iz% e.JJ ,?_ps:Ǜ$QEKC X4М 8YOCߒ򎯉j0%-!U{wC!JLygmiZKƋ>aj2Z㦩=MBRFAFfr+' */ˑ#z[9dI5뵨K '$?}* %՚4h?E"x!'DF3?At2jLgJ$"~d|N0J",7K`~W%PP9^>k,.ojJ^JŽ S|786/{؇TPVe)󐗹@o6f]hpA%"()+1 -Evī ȃ YYA:*1ELoKȈ4AMn.d ,OMruFBK4 ѾL,W.C<,g7va*WNAykcE dqaϽyc8qv`Uy&龅M0-X6Hk=So٤ }zsHP&OHgm"!C"7x5*o!1ϲ-K,c{5 ?7 w8td"R;+m[ =mS#=] 5=O/WgY(EC u˓B23hKB-"cTALY!)B]/Cc$Ən┏pհ*ݺ0Vs{JWKhܲ RpN]MZGb(m/a7{pb Zz45 %sJ Y,6M+1KDʋ=@k4}r-}{rf2DE1PVHRSK\ۆ.8 Ϥ3n8fsdeRNM:x%2³7sb.] poo~qcCCzy;HN#𕈣P9IMΣpƒX*Sݶ4SJi9NZIѦBW* m$opmyف |> stream xڽZKW)`E]ǁFGpWeRݹ$@|VuU*~[Ule8~nw|Ŋ,J{\1b"/]տdPr+.xn7?z#ȪCM?t_pv oknwr{3r2L:^j/|X+U$dzmy jNA\6 SCHYV,ܿ[\ʋwuYcUΙbdA=*~M4(27M(! lVrnm+UyYj:٧nWxXfݡk2;-톡}=ӭUt{6i`#1ml3^ĕLeZgOx*aQjKv&gXnSӃ>^%gs[_ l[vMթ˿|Q /B%'>ō27/O;F03Vshjc@/̂2;"Z{ž>@TeGp>ʈZO~nP6hχф乴j#`L"s9JG#6/ 8%W7CP@Ꮝ/ka`x^ݖhF&ns+5w3%$`(>Q-qqM{SeCusNpE v- \D9|k6- A1>HyYA&6CEE|و0.pCn"BjUTTgh́aTrqЊJz]n)CzH)]Gf(1Hχ/<4u"6s/ogg*Ͽ&/8N~@̊V_~MErR>baRJ%ɶ)q)y P$:F[¸RpIykqZp Ű2.G.;| .. U8P=bb9nϛqL=ޱ83u0r=8́2$wb, ݮC֠^ycdOK>MBV .}%_% ҭvzxxݖ CSdw.@t65VS3xP>BQ@C"1bi| Kvz$io (B"c0X-ߒ<4VXn'W@;LBp>%?vtyŦMoƙr3\Pa lhۆڃX&Ki e&8uBu^P]/j vآj+E, 2Kuc^25C Y1?]-/JGqdD\'rM{,_&.+$T݆]xcRmҒ.|ZnyW R @mxz0;UԶ贛) qin|Bv`aP<¥P^v9 驜# &pĐ&I4rD 6`6~yPp1\&n.d9Pƪ1W2eA)9inƒA;o[h[QY2Ob p?uXQN^\T6<87݇*pkҳb(Lc@j)!EA.2~=Lfo@T1b$s,|yD@%^f$@=sͶ{UӶɷr:UtFg9DhЀAR0k}%xv}nhƔ" S)w6٧P;R lN|*$,hNV3_ ȇP'4dg9l 6O+" Y5J"Wq&H@nSxb9m+d^: -ܭ64/ endstream endobj 3183 0 obj <> stream xZKW| J@rJ:`I6 PhiS eǵ[p8r!O."E.-Nro_c_7+Re/oVƘ?M\xX:)Ҕ?ƌŮ´' M>mq(fܲTžt,'IXeJ"Ϛ*ailRVv^6wY1&N5`W&mL6 ˢ U2S駖-,jT%2~]}xMSw}[Tuǟ][Q 8`a|R{^k<12' ? 7U P}lK)]T֛cUW9 - vMӶ%=m>joΡy]ڐN`MDMtuxS. 06 ?6څJ8ƝY$ZG싮U fA`Uy"Ux`_ufzjĹ<Dz|DK2DALc-4UnM {8:| {LQHt\.Iږk!M],I@W9ԕ[Ȧٖ>e3N`h^wק._@G$]p]TXL8SUncLUL,&bo֛Щa;;:Gm,H-9uVKy+-2.SdhXP8P>:p죁%* >?a?io]3r]K4i1Q> "X)G`.b æ, fr!C4!k h4&M&V^^ڛJ"EtEz-6%p[hpj ߲IY\q$.{Ѵ_qZbL>'-ԕHҶ~Z=0OV"Npw_*W3.]\!En](_C|`r  )WsHU>CM]&=sFIL3di^sdo+#Qd+~xl!Ij$wFjyF٫^Y'$KgPݞ+aq%خkHؗLi})\%3zqlrؿHw%#}qQ_\e<2;1UPI=焹`i(}'&*{ ꊽwḺP=|]4Ѯt,ʒ~ !, 雉h3drY] ]!aV\qɺR(07T7w–GǃTdjaN0վ>V27I8[۲8pM2WX?r\dN6Z=Ozj p?\O28pΕ"=X\qX@ [qZIyQ\.wY_諾uIc}@z> `[72@;_$Iȯe r+[l7"ǀEy*b[|[Np$ YVVaѐH Ŏ/ )=ĚqoƛZ?;@7\FkJp$*ʤt0y ;Aɖݲg П 6yk5&yblR mQioǚqζ)ND 8~^t2U.!!b7@K;]40sfTѡvpYmv(N{Qm|}CLF6dC Jvs3~{d͋x׋wd]_aL$<@VI*yhx)J kl!{ NܟQ3wl9Ѽ=zua2;¬kYS |$r#m??&&ML ֒սqz&O8P=`؝y5 ݳKvC~+(8|e>>Ds:7WOJ̞C,jǂjÈЬхgyb  *冽7S _-7%6,b. (8i>}\u KMc]ΆYtN8|U*GI{R݇_I30|WW[rg PᒹyBw pݹ= V"Agu(vͨB'~O9ܰT jPnL㐛5|=#\‘P+7*(̯۞Ir7ɴK_|{z F1cZ7d1~|dƫ#fq?߲-6FfPA_S5#}^tz~֦_)osЩrqo!.|5m~Lj%OB/p endstream endobj 3186 0 obj <> stream xZY~ϯ%\CfM)aC'j 9"9ZSQsv%cfίyЍf7T͟n7_d"/͆ fs{\oa9շ7[yV;w.]"g3_-3Yu> h~RކU 7IJ, GXjOOIMf PiIZJ86E*4%^@iܗ0ڋ{Ёja<ɳɉRa\Vbޤ ba_E%n> \FUlUR5TSc_U=Ɇ/ny.aҫέw-})%,/>QԳ"Ӂ޲"(bs=)MIi1 ͈ҿ I;LЧ$/fLT4'Fz1AXpnw]NE HSĶ\yfwjG<Yv{cX>9ʇ|Tk&IG S*0jhRp"P_cL~-'cM@{l9tm{Nd.7ܷǩ`W />mݣsge$Á`$?!/یFHa[ӵhU̓eLekBUP6ҹ0Bns8A_aCBqiY YsaAYr Ml ^imJWܯUx:7 D3p=Kns)0ͣ΂V0awh9%HS;,)B[` 9>P$SDP>%krJivC3$\M9A2c.$x)C gf%;7ZXeޝl;F1 Z; kUK7{oWފS>lAw``Άg/M֗[5 ӐAt_9Sִbck wo*LRz:Iq9KR1r.T5_/ɘ wr:. gU <:ZZ;D,-ae4DK-ҹ8~t n,xPu T]Z!^"܀}]~pP8x*vC\0/29>N[9>@̰ 9b36q/2&h)y0lB{2J}yVoѡV}}kM ʄ-h>ud,4p7& (mr:ډ1QZ$h2 0vϊEDtA\͇B.B.tnsNpbA[6"p%L+\wCTa{prYV&[{ Z<ƥ}|?:$Tn0 ͪMUH5.jr4-#Ώ0=]HD2멖 ,2)lr/'uECpݮ̠o C!sh8qRM N:Q ..)=rJݹ\3n-+@ņF%6^[n$Ta%ZWiݹ_x/(Ƞuߑ'}ٻ“۪9'^Oizȅ)SIUqNvMmxՓ3(E@8 d faD1֭VԠ/ۡpī=m{k@!X6| k%E2xg9߶]6tcw,`@iQj^e^KicV]%|)Vsrq@n;^E :Y,𱣦+LCF@hf fjԴsmwoV@|k ވ+܈".R .6my|v2 !И;^ޑPa!(˴K+؊ώɟ8/5.ʕ:G:Qzy!BGls JԍG8rؼ L** B^p`7c9To-0/*{LBc@#+23uՠVntC01-Y`&- 5sgw.Ю\; X$}㓴dlOm3p8bYZGQ!&A|a[hM͑May>/>' b7i/3ĝЕ4c0 r{ Tʉ ׁf#~8n*v0yZ0; gqeh^S$+9a:&d\> stream xZ[~0$ EQ}j,ɑ`}HK>@pf/( ͡nݏtC02ؐÆ ap;eNfuq3{i$!MMyQZrb˱ڔd6x1-`ndf5&?(RSX7GJ ( Ϩ="(TAZtՐNdU0K[Da͐d6h }tB}sW6 𐏅 m2 K2_R0&X|T,>b8qʺyn0\n`uvY&kUpNh^abVOo嫵%Nx=9cՓĵ{- 2 F~e<㩻wñyE/g&Hu; xNszsnd93eLx 8Hnn+>e_1釮i|gj ! #>D\WFk灍MQ,WDli~)-ԡfD)\+Cy֖~'sSaj͗m%D"'◬FL} d3MAj>GTyܯ}o;`k-ZйPP4AxP=M^TM4:tcZ$Mc߲xB M|>zo]gqfoi풋s|J%s7 VY-.R!@B8e&4^3Goaj{\Q@eZ L܄@</G_ba3`bQ9c0v.r. (^9io׹ƙ$=N+H~`Q"nXwJfV;0yԏ͋@pqJ72 iϑ;sZ8r4k& yݱAFD:1 ^.q\s{xHaDv9 7 &ن k45@_]։pNhvek'OBMK~K7DoO{ 賳0vIzXqpuc8g%PL$,@iy##:ThN lE ~<$S`ʮ@oF3욣صUI vơ%4'Lid"ƆҍZ+,M:9W/uDFUa60x3MCfl6ِ#.opD&"t%<f Hͤm%\HH|0O0]FVz|[.c@Vȵjy|v(\ֽ/W#Pue+iXL5*c'/];bJ 4]c: e'aۉ0L1fAt$8/w]}Ii' nW]Й3IS腪{Q=BqjDE.s 2r.㘽e?-WeH6FNpr5#' 8\d*ֽ9*zzyp]2Cc~M|p؂a p)Y12~Rl-(/oZ[~kh/"[dU^8ʽ{8Uߖ.[lK!yk*{k߀1t *qjȼҢ) h7Du5rx_I E4n:- "N;&cHrx1' ԵiNg{L22nE>Rp y#S8'Ycu\ف^> stream xZK۸Wr,x +'ۉSJmj%;{Hk%'>h"eP#{|Hvˢ h})Fb}XY~/т,KBx0X9xרX5=f&t˕JVB2 T :)M^fibWp&@h~eru%mJ9i7;Y2Kn۶YsܣH>n`B<ȼ`&#EC+љgUͪR|0לqs696uӵ]M"nxcc0#ƃM04[ 4w02zoMBW ֎-WWͮl5aиϗ1Xa8$J 2yUf+wI¤*s`Æњ~t[t^$IEOgCd?uWQt"eJ 8=<HKl=ڭ`12[# hUǪ*]Oqs_ iWq@ʘN{%&ice fEUrA t6jM9!aLOr#S:<"4)}{#ZoL1)qcl+ɹbQpПtmEmW1tҢבth{ky M,Ld}'L=Xw҅А$x>q @YYC(<w Y 4XO3sÙʳ cd*^aֹج$'z6ۻ*ٷ{g# 199<;Cmș<]fgM Ops> A!HK'8&s~ ζPWP7QT2ｦ.*0ٺ5%ɒc"i0#innDsZ' k.j3 ^c}:C`(lƇBZ VWٌb0slD̸q i\ˮz$%g%&cF/E, pWVLb&Nr GHC9}"ptCVVbqXcEUTԁRŵQ31OqY_RK S%z7 i&,)OG_GfzT<pT'q5O=i;]"=s6^-qm8 4e]j_[ PuiMِ7{'G$hk6N>qe{jdrT?$6(’zս*(y< e1 '%50lPɿD s JWLFANEV8]g9SLRK!)GLL#PQ>O#)?kl<e UjG/XAOk +zlK$~L _>BlCd/pdr[K6J+ ="jk`@!WILh詧q deii|$ώ$c44>vaP<6-?ݤ=Ó?.3(%.z&~6R /[4s j;s,ب3E<^ʖm!$ͦZ,\MۑT4֯Ce / } iJP @d ^ϯ& c,tbq޼x@={n|ś.2Œ|LK[Dy2'S s@1>ί8TfE/5Q.x|v ꗓٵˍ7V4OY*4dA}@|@Ԃ<6-u%p<40YT^Z4Ԃd7Qr5VU^]nH_`m&B݊?Sq3Z{ׇ\@!f0{jGwcCb\1?wcetxb >.o ksM~=T' [ 觜HWo#ƧlK:ɂ&uo/)ZUnkh-lE4lVV<~d>@uSoI J z,"=1OQqC)P32;XO> stream xZ[۶~[ <3δq+qwKJR7 DjݵI'wsVlE?2ۻw?QVnW̮ Nջݯ46z#~RVֿJ3a`F8QоX&WNh;뻟|r!vjE(efXcR#N&uXRU]eaqp?C}(l0x_]~hiv”}sꛡTc=e~u57l8ڀzzUQ$q%l!N߱o]}ȭCx#M5N-l WEsīSy]0!0_Ǜwά>eD]o&~":W~θh9xÂu]p[M5hU7GzmvJ/TE[v?To׊F؁3єh͢lprc;C~4&vUx:ct _ j<߼Lpj.jc@h䩡ua$8 ؋ hv0^%' YldK9wpoܙ}8Q{ (#'(9ߏiXdx y#BE&aF89|s R HV &ii3 Lp@ P(a/METʱ#y6ݏuf M8y`l̺DJW4v tQ'C>g,ˋPocW05Gl@`iOއ8_|C #jw"ZI+Ҳjb ڱ%& Sa'٭+M4-`EG5)]3WLlz9W>>ût-?Ӟk4e}p}(=y~nf쩍iHhQo%HJ@, ڟʏ)bٹ0$BEYO5u8wRw&467]N~^Rݱoo`%\\ nBtM/S{ejY`J 0s1x\ԾSq`Ί'x|v7Q 載L*¸AZf Cf!=]p@쥩s:Z`JzV,x+$4 \CN2,QEҲ,Dp.*yvcmNTO# `нI@e 0Y SNr%LڰWO7(}{Ўܬ`\9T@୍֔Sv!-DYh€'VNs[5s&,G>(8/x_EE=&[!%>b%$X4(28JBG&/-lxgfawH#1aǸ3s-ϢTrZewv' 9RSϡ7ޜ61!ks3x %'9|NGL1Cjg6`X>}.ߐPl*<m0K.LJS0ʜ!Ic]o3L\ ΃ͶoI\Rkbط7 ܦ r9V\޷}L/xq9 2դcx7cBNn- ߴW!Q)T XĢ-wr*YTg,6&~\DN JxLLpx8xh*ZLBP6*rWB)s&pje#e=@J/"40dxyKT/bQqx] tŗ6":9PswG_~uoK94ކN^},uhf[Kl:a}: qC蜽 S:Li݄rN%w5`W8U),4)%=هϱ 1(xN51y8bB}W`)/-B`.aѡxmf_h)OYRV2R|( X.vKD,g8z#HyR[,*({&j>`]mh:4)Uu*҄t͗(=r ydX_Ri 茝zJYFzYGf;3Os 5S8p3}Ty *IȂI B}=.0q%f4IEG/cW/MXW^t ä 0'~ﳞfffXE .B}ڮ:Ļ }.z}<|cm ,hNٟ$ "D^%-A/# S6AW\b%uA눚9")܋deѿ<L*pE_}7x8\|SA7|n*_e'9ӮCy519QY4y}輇* 7ϳ1 U7hL%-Hh \0C0nxS[1ɎX1~C=ɄT>KJ3=Ԭ)poCpyutꏧ&\4.=_.V?=>n>ט^@Dׄ@n#/Rt[=@:ݢ޵|P߼[0 endstream endobj 3198 0 obj <> stream xڭZݏ_a\BlvM 8bNnU45k#j>4l~_U/\ӃyN*0^>ViO$U62+@8`<[)DH8%Δ،stȔ7mI -s"̀tVt7*דtdehGGK̳C2^ч0sXLMGbei"JMEr$Eɖf+gj 2"V\&P);*{tX<ƚa_aHfp M:6Ϊ.M> EiCG~.*.#%4&t|qCl9X Я;'6,3A'gzPGSa/W?N3!<qh\2t:ɳ* @ӴF͕~*kdcyᓔD_Θ_Gq=&u1pM m6N6M #BP#"VC1@:3~ LV#y@xo ӡ E I'if*2dZ|3i/YM[(0ʟ50͕8E*ka"~o  4׃fr5:Ac5ves*jM wi0K4N4wլCAev' J2cuWcrj֥$ R*4gmUo?r%odžՖhc¯L!A2ܜ ͸ 2`8^uѣHe^gGq3+z,fn=٩4a~s-<=j3nU]DWx$FbG%igP n&}p[NZҠqD5lA0F`kOs_(&65r|F79UBDEG+g0L=P'f:} i< m]Sك;hŝ@tAr3 beLɯ(W=pK}yN\ݨJMzw\#t;B+vhGy^MOCZ[ag¤5"He^ aoD+"#Ơ='o:ss|xPܡJx 0lwŦĉ֑KxH~%o8bwYC7f(u4>udN& Mxu[Uڭ?Jw7">/GIP9yytDҡ_T+wYKJ)0iA'x__9σ%N=Dj"ϩVdoDJ ZA=WHKö쇶~0?4U4Js0B<LTcU /57{u< j 7nR o~+6.`gi.ϠvCJg\3hjbdbF[c7!Tl@? yG,w_Fc谹 n&*'qr536QÑy}vPS|ۇ)K|.^TwsbKMjIn铓-~]?,Pb%p,ηwR0 tI>S#թhtCa#ZVkZAϞ}[tt ' 5st1+1Z{;0 #sb&=\iu{5Wnz8 h~ !0,~/1x_%QMv 1y ?3ւu endstream endobj 3201 0 obj <> stream xZo~_KeĈ)=$EAj.ZJ{+ܿ3$EIkr+iei|͐Ohv؆VVn7l('VÇs}M9/M)(뇡>|׍a ??rz*S% _WR!UE ',gzS(I8]#iQ?^N`%\˜\go|iP4}jaPB5єOv)8~hw90<mdP<,ѱyl"Z]GLX){nF1D]?m;ޔbF8b%Fp59;qv{tVdJzQJ)! kћs{%}ӍCjJl>6~}v8*04ܰbsDko)~J.X%@eX}]X>n9ݓ]AWcK*;鳘&\X*,Ir L`JdKأqn)Y2ZSC1iKz'O.sW@ctCr 4gsׇVI33SD ^qfps3"C~I6~OEBbxM>G0nLm9a)dӐK놭w-m%$@ oۧfSƦ8&c^RÕf3~켏},—|e/iFXtSTJiLPa[;Q]x.{Xw5X`5Mb ϓ@=ÿorX m^p 6MgT*ks.Ll[W4:%kqG*cM5$C;bvxw= #ѨtLXbe Vm|g6Gk`t\P3xw)*K)mc&Yts<1gMRL](qyam)y?pF4_C1HJ$:wgHlX;+ʔͧSLieT UA95O؅%2:S4E@TO{ZcrvAE}1|1Dܻ]g 1l=HK&7Ҽ~ nT$SR.N~R )?Ķ>̺8lRQ\OkI <.i\CocoK3cp?q|Ej,cVE/M0.Witx́{bG[ H\З+9ez+m`ihI!3`*f;mm#M@[Wjg{Wj40!$٪26Яd.#Ӎ ,/, ҽ ڼ.b[K83U|MRұLOZ֮0ih, "ra GrEua )sŚc&vdh1HW\A]h9M9 *#1xMhKZc!ksPe p5IO >LDGC j^4 ֽ"N)l6,MA:BNN?/I];zncc2x_މUPcy UuCT޿`4_l5u.Ժ߷cmi:=Sހ8j'47iE!OIWGAfUdu; ~g}`0!1cQˍ uE4R}S SMp[iOǮ);:  ۄ6!*mBhj mgaAYIůvR1M ϭ/O5H`֟@vDovǿL#aN~=򰫷\"K{ ьN t.qH$ii%iEĬ Fa:B`w̾Ղ%dў,ٌa!6Q4e]U@*nabGqPuȓ OT)eÉա%iegUU#k+Pfy\-aydsU["fWrMzUm}cPQ+~r:^1ukWU#^0B*/{jֱWƩ.c2!A bYª?xclHOQ,:t;?'Olv P,]R+7!: YB@1-;02C&U$~XA,f8}-Y8B\|/w7.`^WYz&$}Uwl/X|nbmGWvm3'U$!vqZi .0zp=<#£n{7 嫽uAHИ{=zl5ѐ9)c9b#Y5i'LVn{H9)Y$kYL"}k3E,ݥTHA,t6g)s~L17p]hĭڜlWT"2E2gʶu8$nỎ0 ŗ[ex=J D/?fZU5&I5·{ahw/0m `C3O!wO³t> cG;T}lSB9IlqKqfvr@x!>ȌWe>x_1%G:~i6??r endstream endobj 3204 0 obj <> stream xڽZKW>q~7{c'(pMZĀ%Rz`fՏz|U5WVt? q7o؊ ߯YQN aVw_+њϱpges_Gw&k )dXGr ŽejRFa}S1N.tK]'䊑\S$gIGyVܥUK[}8Qw̥Y UR@,%J1O rA+Km?abBBԇcaa^=)sX8H&R'Ҫ9Z+U8[bMS/jCXy7>t/VM3dI $^l<* 6Mh"&zʨ)^!1[xzlo'į`<}Z;TK&)aQlaId"HNGHh%{a:&9#&)B8㣛}a`}\bK}){HpW"[1zu EzVIXX#@C, Aw'2k T2z(ii2 :jR5drb``\]~\.=τ1 WԬm&hp% x49 hԽC Oy_0ϧ)5v؃V791+I /so $cFEd|݌ c}&!/w\s4D\}X ǭѷn¥_cُf7 ?-J-Iϱn!ڥs x"#^(Zަ|Yí7h_!XY@/T#ҒWZ]34/b.&v[ S'a]-MaJ 1I<'Xg얈" Sϩ2&TP`P1ԯ?t.ucC-Q %NtW+0^>ݦKИ&50OK5o%56|!{@xDgX Xz2_4 c69~aIGIL "]yXr4WLK `//>8ݡ›xvW ۾,s7:/H *:x0WB~ݹ";U%YLIH92ٱkkbortwXZD*3o!ފ WW|Khzҧ/3>Ի'>9oug[jka / endstream endobj 3207 0 obj <> stream xڽZ[~҇pQk¹Ϥo E" xhD*$ew[ G$wF^EKe\3mC7%G7fwlCKbKK7o?lPN0w<ݖs^0VQ C?/S`a|߽ec[a=<K RقPTZZ-g:HQֱV-VR?NL:թ8j_ _'ESzhxxlx8ߥDD3 IO1)VTSL}х-c 43 IZMƏTWcCR^@Ic3IWb2_I->_%@Kj1]|/IZMJ Wbt+cxtuOu6G^C5'7~D2{JFK8 ^[TmQ 5-e lf<0)JjSbx)}=.rAoD Nծ QIL[A)^ bND" i-%QRZ"}ZT}KEXp%ZPwcicSp\P_,+/a1)y81UX(DIOb|~fd^vv̾pVvaTϊO0 L(.WӐ`9,抔jgDj+/m2U)0Nb$T鬣Y* F $vH-_'kpԡ2aV.47 mHP%[u\Y⥁[C|-% *ܮzٔ-#dD熳"LN qUϐ H3E+nAzGyKM4k9Y^sc}w-eZ,nO/[s_..P 1q&Y!Rˠ8`.\Ҙ[EY4h2vs4&&GmBDB!ՌK,T΃FuIJwFWm-S6Z$!qN-lv=*I\ΩqCм?&SJ&c]N>~t׀ 6jLcv3+yAGųL4U?r"فPk Į:  ~uqfᜈXf"ͺa]0I\ \YYRIuSp&)afluQ9vsh6Ji+e+9R.\94j/ORi}竃ch`"%J0?!B1N *"D.UmNp2)E@zݻ&F'BiO@Gz-uRc,:W#UK[fwmÖ_[^ھ.Q\̀-"*ЃB_}RPx%Rf _,P`o"@,ؔa ȩ?fNn>^9UOqkg۲LD]DetQ]?{exJelt2Ǟ5-Dbl6sӊUIUvTt g)o[1rin'h \(tjM-`TPɼx*BRua4^p1NO=Xc6u%Щm;`5C)5Y|/n mZw ܻr]U/xˇۀb^Y4C"?L!cuTG Zz@C:!%s1QҔsSsw^}Բg&Z@H~:y< c} V^/<+kA3)(Doi4_,+P5^eHe HH$N5l'1c&|pa7g-N {H:Z(3#)ea6,Vx=R|W+_De}Bx?0XʞQm72fjZ?Py+*{!|lv،yc'qC锿9PKIAkq TLbFCm0rFG@> 㤔 !ysyflzpQ},MׂdZ]e6 'ԋ̖>@"L@s/3>q]Ng)Į?7tdR)hd覎c߾>:N0sfKS:F6"f46ј]t[w܅%/K冮z2tf)<FH{/ n^?a> stream xZ[۸~023DۤآikaKIMڢɔKE$S|;Z}XdSWqի7tE0XQ+ju9#X/w]QFQ3x>XV;?4cSk?7 UYy:zMwz7*"ܭUǃW}Xm ;ͧ09 7C¨F9b"*RhD0 BٕgŧԜ\ ixWCU8C97[ ̓TFbլ># `}j6Bg|G; Y<20p`;2(~NIF ;) 0Byozdʾi܉,]'{1<{2SRHk~:~~~&16v?@*\"%˦U}ԿfKU/uJ9:S eHy}0iq仒"6kמl׷U-^ *ߋA.7RY-~/ I.? 6snfOI\d]s4}u46QK`,9nbbhQJ8uƪZ 1d>!2)&2Ay)GJ% |BW̭IK9tip33&L;#86^BeMhsԈsyxtS͗CLƲ.z;Z.Թ*@fR@Y5PX7{U?(Ќ~-v*sve'pgܞ]gnHRO(Rc]ҨQx$ 'Fnz8]Weѣe?E23nJܭ[(5;$egc,$qaj吘P)UJE-."Wڂ( v(#fgФ{9Tnjpe9@Z1_5i)#9å:O.Q2Oa4z(DnSDIW!Q}1zw%S.+d˙\OUs!<a nh G՘.g0L_Bil1oC;u/^n# f^݆bk7>d%p/ ӡ>]/s‹P(ϠPT^5WNs 7,e!]©Ha\7_F6S ^9+HwmDTEf<$4Xsm+8 b (EbumUhڜ7c&nfKnǣ5B(Is/Sp/._5{43Y̗<pGj2쿺s{sj ɻ37~l%\Iظ|_ hd,QIƽA%};TrzÙ~&]6agN,Ahgz~ˡk{#sat`ׂN ͺ1_h5Ǣ't >TQws:(PQD-ZzbBi$^0|`(QX/γC$qm  z^+x4ѱ2m_V{kOB \wW06Pp`jùк-@9q>w@G}t@ز})o 2DovSa?ӈH# hLx}8t endstream endobj 3213 0 obj <> stream xڽZo~_aUК'@8d>\ADdswCTr[pProZ|ZE XmXUe-dr럊RBoJ]ׇseL/hw*v9[9~_0Zefʒa c*&],1;w:wn]4/`oˢ^4L$2J3 17{Q&7:93qD?Vt5ͬkn=nhTc}YDnoǫ͝JX6/I x:ZآY-Vhvց~ևJnٵc0`,Wal0^`W~e%x%z=sVyMQ9خ`uQ-Lx_&?'DhVqs;<҄MO^+aLwd #3Z,m*dzsve ~" ;/~V慆l7 {'sQi&^KUʢZ=ntyVV v^Ki`YQ(nKw"{h#$~@ӏj6 gv4* VF{,'ĜΔ DC3BX)+cXݿvY0j M1JrL}4ڥܚo2rNXs%I0@rQЦhI4EYl w0dTGDvb]Rlkԭ55 ɮO$':NbJS̹/g8qj]iѵ]7 `*@[}6E_%gOɬHOWZnݦy#Ƹ# lXgCQMeWRKWo!mz۟jMfw%Kfϯ+yiif<} f,Me+j.W;S+uwy*156㎘ul⨞zYyߗH,QF@{ H3T $)xF,uUYʀťP@Pir!Ea(&YHy )<]M>y6"ہTDPUR VO9ȶb)QZR0+`M11lP 5&զ&ӹ2sAmmG\ c&z PH*%T?<.(R(-^sy4 _%Mh 9YHkQSW!x'ܛNh, ̰H  dted!uݳd< v#8`pi`>3B51#L-$ ,Q ܊@B93`K:/-Ty5[I{NuO5)m*""{;'܂qP+y?Y'=1I Ŝ>G%ƹ̫3Ǚ"1s)HrsU P' oC[?gu CVk"P\r `RMELB9'F]6R;˶,ɟum%8@CxCY:}*6M>^v^p0n<c!Mɿ";APH۴sE1UJ2șg۫˰źWV6Pyhw&iYRwfXأM–3U(aӲ*O|kX"6Lq\']-fDL)@ƮtEljI d.PX̂/@J;O7Yι5G4E4( tBKlw8R9-M!⃧I͇_uӷXLGZ7Sj~W"_7O=l)+f|]剩=_Sc15>{~Ms}8m +T9Mx{I"Y1Ŵ8E j]}kbגx l%'d2ri.ĒdlI[6p|i-XS44-9agKd9 9=g2jhSBxK0 $p[pz${IVćg/2i|G`K&ai t/!x1jO>R2qˑ#꡹( V%6zFvg@;4*kMg[wi`r|k0kN$4n:m<3އ+hHUi"w Cm#`Ҧk?zDaP6Qq.$er&\f<ye)$wNLUy -+6I{OrkT/>[@U=^Tg>qzMOr| ㉝*Ə01@~&n;SMeAgm0E3xZ_iK녊*L+ͧc{fYp%+by)} <4.;p[Ɠō B/g<)m?k ߩS=L4gB-䅄"׫_x}Hr&t9_#0ŘDC>H%(*ueMsF٥5$!=Lɒ͋qOך. Ak&¦qIL֭qJ!eAUR$a >)t5bY _u ;OKv.y+.w*=7DNH4Nx6$~V&$#f,7mM1?ZT endstream endobj 3216 0 obj <> stream xڽZ[۸~0Y\.>nѢXig4fԖdLٔE")\ů (]hjقĔ._ZPN Z*?35ױOuvoa;lpp?,YU{`(ҽa05GmVz2}WjKJZGvpunC&MaT\Yp[XpLAҢ޶5@.]=Ȳhr;H*FdFq𳂍+MDMRm$"ƨ=Bd6;MG][ .K~ƷAѼ^kRPƈRp!!xb6uXIRJ b.$1dw3"c|ـ!7KJ; _\o ZN~"3O뷮a -aYV:{%3#@kbD]3صt5ơfvufߊ3&t"rB)Oݙ$SBu \/YBe飉b3rYMu?I %:ۨ(#/m=]K#&ϔ#Mu͟6kԐՍ40@HRDԌpj2Ȝ  2) /H DAo"1O%q# +}#﷾+ (Ys*=u?x aFImh}4w-/JZʧvl @$eiҀQS/߄Fjܮd_b~'˾ }-'ǠWк[qaNs"#yJQ.SG}dpƪ }Ol~ݣMKBA raŰqFv4h`綛@f'[6vQ4_Wat/6a˒CVָ@Dʓ97D3%UbJ&wmzB.Ha#\| {xFEB53'dBE9U#+BIn dșS(EȗqR=s܇^㸏Xh08LXNJL,び[%1988£,>)p&8z eO1N8UnM RVy4}AfR&ЉTwp'vc}Pd3he Yט̒"T 3\?ܥCV&BW.54wq0st!ptXBbpØ@^l3e*F&a9S 12#8׬=JU˛ȋI|4afa yc>4#_W` UT w9RL*I1Y=ىgْh9 }GX alBX2d r ?[-9)Sr# 9q HNÑKj|cL~fvoljya07G4 9 EsQ9{ A.$~R> 2Y&+՛艷)tEHMVM-'e&G{cwbՀ*i!~aSPX,c|bPY׼Ԍ-y:Y]А 䶶eٻO]1roqL^f*[`x׆mI0-(] l]`,Rojtg]10)uA;Ye9{L2,\` D_mwv cqsn3(^ӓ%-}S"ޤ /]A]Oן  endstream endobj 3219 0 obj <> stream xڵZKWHm-a xoNũJܼ9p$ )N~}$5ukEbF7m覀F3쎛6?6 tfC9ld})O}u"?6^a|J~sX.,1T<^5[mxm~ $焤&jT: ZJ!IAG*FZxF <ǭYynn,2MÊ']/MS7ϱ5#*@>Ul#~:GOޡ^dԊ=nC>E#@$:^qC6/hjOd|0uuJӳ)[򠮏Q)M !G%QgPtƂ!>ge@UVC|}61Jw|nsLfc>%cꐃ͠f(ZU2|'GCS!x [m. L,s|th(Y Г>D}2@L0 ɡӇ}QTxo,fi"V%]*zRșP)UPS B8d˸r('IS>FUe5!WUem{ܖ+k3׾˃U@ e}H@S-qhްMP ߧaLJwV'-SDA.G:8Gq5Vڲ/ZpڨfwV2>H엃aI1b{Z܂ v7G/mW'W3yLх/8!r>ČXm}(ޞpb}(RYLKS=Q7]@ ! #ށ:e6IP;Ej (_@]R81 h8yn|AtHrG:Cc~ldGiDlh&p:a[%p&&SÝ\ W0àbV"_pN[8oĻ<ѐTsKDȼ* &`-)Q P4\@f!,=l@I"H RUN!ONw;nAסCgQGMX*1PG\|v6fp=]z:>! <幺(善-F%/<ُʳ'p2^2-.C ȅ ;w <"V* `kЇʗ&|Wkg0C`GaR#Ȗa2;0m063r )`ix@۫Vؚ" EDKkGpJ*|FR/Gm0z#C78g˩R¥&8pp0uajԮX@D>.ė'2 M|ԉ1u[D7&]R}E _v]2|t<7h"BTC?q PN,݁ x`g&_af]Ļ`_MNpk0lA2̿^-y)y1“p-OQojSO΁؆jr>Ώ,Q?ê}.RXSzpE†ǪtU`%|[ ;\)-~Zҍ\O}5<|RoT8H)lu 6+KG^ 2P*o endstream endobj 3222 0 obj <> stream xڽZK6P퉪I`oHVS&0%=AR(EQd7M/O|М ʉzKFs׆qFx~qgesp|{{: ^m=h;T5[Vdb{7p C4Wן惣Uy髲 jSijj. ^2F[I \g$Rjx#HLG'G1" tY"7YA0d1rU7u=b7Wy j=En9Pa,oq.fLӀߒ]9QZ_b@b3A?Y\0%1\%wmh Qӹ1^YewvQLܭ+Kk - [MY20tH 5RemfSz8Ӱ:~l|5 >؇rc4Pj_r>ݺGݏR1w:f( CCeRzcSx)jmuheܽB] 7&ȃԀFx:<;Y@MA"D/Ot*28&rfu뀫VK6 6^8`lC\}>~Đ]RxG5ОOnC.rY"$*mgi@TR_([6Nh0b.ѩPĚZib݊R ֣lqbZ37Z8s>EɏX2>EL&x2jJH )7CcWQc$h].%&׍R7- G9p&46n#DИ2Mh/Ioƀ_ D= fVɤ[UםDŵ.!>f/@tV羭ηth MtU7`3*9~r$6 u u@]@Rk(`>=xTp6>wܗx%b*Ow_`ewc >cKdhy!|-4ba( 5/&JN6eRu2`C[+s")I*׍&~q"r,/j8WN?WtP&Za&ߧVOȗ| \Ǝ܍fDWd8@)X6?--8m?){S2۶__3KX?UUb2f'SP]Wk^B.r`>=cgg1*=W~_G?!{m޾q\|.Z;B=,qU4/dV$kZ*S5!o Fl6_+?V>s܇Db!G % [q_qOǺ:A 'ʂE% [< +Q6JXnR@+a}"sng"E8H"`[)v"܃u"@~;4oQ-pZYҜ~zL4R~}b@:}{mv aa:(n]eUl̡EdiLB#N7 á& =(`8ov[8}{u5q1j5BCiM10ɫ,˿`mU_K? ūT@bLSp1Ҹ}-<֥"2FIt^#+U谯і_sg&Lqܔ'X Xs]5 ̄ko^ endstream endobj 3225 0 obj <> stream xڽZݏ_aIV$taE͊rbY=+Rp ~!컾N0 @Ke_9 H8*:B^̊%uP^m<^&_ۮ}=Yi-ˢ^KVT'|S)X9> OQWSdO}ք|F ZhpnCӵXKj?T?.wLz؀uZJZ:d.Xx},\ØJ(b }ZF5i¬$va9.F92٢2^*^& /%aTu{%Pem8ڟq Q`rrR }RUFU\Qv#@)|AZpʂ/$Umr aB7Ҥhm.CҼ }ap!？"L?ٜ[I|e||a0,цOlQ5"d '7\3U<7wq g$ޭ)?$5fhB݋fRkRPf0cVڽwթu&i) 1p>|!wd!=nvJ+!g<?t\c.%%L.Ռzj뾩Lw[..x"Pw?#B4p%g/C3 `l_*j;DS-n= }cIŶB0ҿJ'z6mRP"s_Mh'*VMޅ: /Հ A.swWͮNΧ}S?<9r)k0ʘXḥ̟wikJN7)=GՅX^AXDrvW[z$){4)bxwЩY$8yt1E=ù O9y#*Q+_qk7J <u.nz-9(c7LWuo΍]Xł[=VRo ! j,3cah(^ R1?iMV:%i2#+-Dh}}ۡNK/<TΛnu\BrдP\$+1Mg@&DA:pLpi]`u3Rl͢!Ν4;S.l-̡oSih,<>~Cwo?jh1Ǧ; Q2tg>xnu)tڥ9rԛurr*zx;`OMx\14M.il37ϼCd"A;^ LDq%x#S}<}~_bJ0\O30GbZKhElg. 'hsY64v9 IH ĚIgR (n/'vvt ёWN0!>gEЃ4#El֙X1U} J(H*&^Zhv?KC`(ꐞe\I1}3~|ߡj$_@xrs4ԓrY>8 zKxӟ_%h{8i?۳㤂`҆Q6fR)'> /'J46t?/@t>` |Im}-Pf\kd,%]ABIEMKyt\Xi \5yvSɮ +yΈs;09Wa[=DĖ?o465 X?TϟV,X( a wT,1 p!K:S^0BQ4%gQF␪LĘxvC Պ372!';ʛ/ED \76 ;[:OIMѸ) |!b]AcVFEU -8OZ @={z(GLZ93,GB5l h ΃%41J,'U̽^|X nɮǬ8ǩ c% T[SjNQm}Fot:ߞkВD͏+J"k_1N9x/0IcZ/z̵& á5PңSh|4=zc7A.! B3\fEm+]"؎?*%cYgˇP \+ebvisQG4fZߧU#[f,%p$ Xh^tTr6\w C=v/GoAmn~9ݰs~dSl3ؕi ccpr{8vVM?lj|r!X!U.+hWt2ny  .(a"rFsDX,)摒߶Pnjܝ9:8/Tr9NomǗ?; endstream endobj 3228 0 obj <> stream xڽZKW|V0&rs)gǕÎ3b,2Ixt%P6k  t_7eEW%+V]}hILiaEĈju}_R7?u8#Zson֜t7_C(mǣ{fͪbs:4 d{H^Q ; S[Ϯ7ReD >ӎV ˜]?zp|8ޘ 5LfC3S=%/wvYiHI RO-\fɈR)HlsT:' +pzC!ͮ.'e)5 +C7إ)umU|Slk5so SJ""'kDI$̎S-H}< NəyIŰriXo]o+kCd >dQG& vZ ++GU19-k㚙(XbߺvI\ tA~ s8d16zf~ϼR#.75DJU1;qd( M_qHB]}6Z#kQj25 6 !-<-Ht6Y*P\xg,\wno* ?[~Ѝ?qvs@"1kJҐ}n8 wsJIRuCL <dSʕ&"ƝRmf(U f-(ó,zó{W, ?c07k>wi tx1Wﱚ˅hr+"D;eUhea0% @(fx?4H}E OH,jttnb. u&ZH?σ'(\ZZak9xuULy{Paln0~k,.}(Bco6Z=qc 9^9yy%0o Dk 9,5=6á5N9řԄ0aj= ;d>Е8n,s[©1k%P">y^@w} FxpJ YVVޤrqB7\\+w7ز9='pH;$J`yU0{5.WM ަ~#'(M/v!>wy{.\QVyKBJD_Mϓ *Z \]"@iE9F!DnÓ܉hgp Io+4,n\Mw~pH=hZ~teK?8Bjie^FA*b L~jA |n1^ xXE)H$Q ZR|=o`v%c|]IWպ]ŮۊS:>pOW6/d`Yۺj|]`AEJ!h3yMpcMs![&"6SHe6ːF.$E Y=84 NdGtb" Xl +̏EEZh#.`AעzKǍ rcՊ m5 f>sES|8lQKDy܉a<*-anAƲ  x"t]C! .m s,M1N%a+H0`[hϘتn"|%@NKft5=pXDDf|(Kld-,T(~B.ܽ[ڜ)s;މu1Yut[4+cA&eMP3+Ng HX~-9@]mCSԢm$򸵽9WM}mJ.3&> stream xZێ6}߯0$1;S6,X,$JlG{*^dM=4KT9%>؊?2jw\nw|()iVw+fWLRۧypz#(z#,uh^׿{%ff9 70jo;9vmdI,x}^o.\KMR } Dfz-*X+EPEA%y7V }n2b2ۗ08ũ?Ukc=gߥ]QI 5p!S~mvpp>%/j+Wܹqv3hB8ŸVԣ`0x&xĻ=y"Rfq-CKe#"K9V?p̭$(+ʴm@Ho*8pl|]iq8Rk2d('+Q wX0#̩[6#8a)32H KVd^b??}nOlEɋ:W$^[31]WTk9[j1ިbaU֬ ڟ8.,*(R'J\Єj69%Ts.1[NB+ 5ћ-u58|)ph?c0T [S]h-Yn.j+1$1d_OHs>?w̸b߫+T9Cn！D>R /CУh&~vy٤-# g CbvLKYxz I.{%c؇4 tn~M^2b]7xc, uם{pkvCzU-eC.O=zH`o6 @@/%>aߵqo N(d60D\W}{n-"KFA:9C&&%ԻeTQ\?{[?G 3,' ?x? M03* ]M80f`/LZ^j!Ƅ Y'! D1p. ]?! X3W{Ŏ)A`< =O%JK?Q*Z/Q@RXrlϰS71Q;G>qz@Fw]◲K 1YRTJ0"Aw[|՘(m^=wM`(K屫[Z|>]u]~?o;y}Tqbl; {Gv\?&[΅·xrMב&`182S&I ǽ9r=Hd5aVn.1?D7![z8u}H^yz_M7 49@n%)m _ci0v]}[ ])֏ _e|"e+!6p9 W$KU1E>_Z5 U D:[,}t/Q#I*̸ i^!Xmt0'逃ރCA\P>.YtpqӃ{fxld`8١ pLHԼT7{ŸCP\g-5,W~FȬv 0ǃ~Tm k T7 sNv/Y黜&H+,^'2E7LSZqdb,B])T^Af )Ȕ SRdG%YuZM ޖSi:er[^D%(C *A"YEԜi;I A tP f;d&uKX7#zcc哒3:A!Ui|t4I"^Nus%PcQ2g I- )}:X]x@0N:֏O\ڨɅVyQQbfSvI,rOܒI41MnSm TԤZaXqe!'ؓ]T\:%EGO$# E7tF0 +ФԹi`w4ܦwcYL4(T3Mos_3>K޻@6= d4TL}W%0蝹 G:JEUȾ'(Χ}NQS#=8u,Rh]՟:o&/B+ (%w]{ Ac47=b' 6JJ^iqTϱxzGf *vj7BM/Rl$$) &4dX/?u;8_c0x>}Q'ڒc,fpQ Og87%wHӒ %5?e!un#6 ^W92qs!_N%ku|/ԸPj6yW|x 3rD endstream endobj 3234 0 obj <> stream x[[~Dd$ѧMAt.]1H^37ڡ$@ذhwΌW؊J9W$9[yXlez}0oₓ4s!DR4[ڇ6,hG֮7*3%qNT*ݤu[}Bq @rݢ/Sr {Lpr7دc.χQf|y2Q{vdB-LuK<몫ͽF]xz xbUvQ'ˆ ј|zSé/u}m]{02k UjjUo+O}ZUVsxHR'#dS1~{C0 &m F4JJ"hxd)QHw)~Q4/D4MZ!^9`4x̦.R"#BM!`JIoיQZcc96|;C67\= E]ajROcmDJ>K"ݷ ^?/cɁPq"'xW,+Y߮ d! !P&՗E!lhoZ2Y"ZTܲ>D4 A@ iWʮŸ"!1D4Dp3 â>ǒtq҉45~b! Y+%0qeiH|]<ՃTr$#@Mvve:euIFWQW4|I Oo'rk:yQť.r$k&>|$sB 0:oḯ>-$@2^˃c pK3]"69`'FՀYϼBe2B=- MXH#N%@-CDsT\k!9?foh|(~7`zoHI ; !% Vd%E/;ss<29EProz" RrTƁnL]! Έ-W%~Axkw6g3Oła}7Rt#>bH,zz,X*D2p6Knj+N G[5{5}K=L`=k?ܦv$̓Ba ,* =dkR&6BMr6/?ԍSR*bV$K}='oM$pjWFEBku!r!o:*F?n/xI9uy54Kx2񒊸vi4S, p&G"&>FL"N"}9f)[Jov8nv;DRݩݽfc$) G|+نM?w Š4XliɎbz9dr/ʯ44i]מw$#Py-J mWb@+IOH(j4hxl|O+_'*7nTU>~HE7BEBj5iN^Q{zpqt ʔj)y^hD̟axC>3k_3CɠysTI9.zvb8Q^s8sO37_WDjp' I9rauX1 ah[;Ӈ2pGM`NCmiHt<>I5,pop>37˦F#SQVBt.=̥ OA߹] q,Lj7T% EL_mv!g/S=E7` p S1's'8_k`uMu-eF#.s"i5rAQ5DGv+e v_gLS$,BʘU/nwrwD":F}aM r:Svy.B9m`*_)q}2c7oW4 az&_7緊"s6w2ݘsHBr^Ê f&-$ NԞmp}b}_ߛ 0Xpc qiY=x7-햇ckD'Ex;ޚ\@\`"LJ@Ppʼn=ػLE>JW*Bf k|Rj&w'a3$yUS'A0 O kHMm6$կ_vsյ抧vZcK%ʡؑԫc?; lP#6gr^n7Ml!^G1*fN? @~(S-#WId#^ :}Xd8XߩRxG\tIjkc'x2y1w(W ֎X{auTۓBsvHb:vTW}0Lg\׸l`̿L-Gߌ8f<9η8Dʮ? P7}Zv0"tMP)5?f~,K) h|O<[_#H~;5kgKIfۂf s`$D2lT|.IBӹ7UeNDLP"O|or?%\N-36&Ŗ&dFtX(˶S 1i23_Po| 6 endstream endobj 3237 0 obj <> stream xڽZKoW{Y >& A{HkSlOfj.."tϗ>͈,]\^/YPN0˿۾hWkZkt]>~Ba01f5H_ K mW5%rӬ,v[y_`\vO]_j-3tY1`$˨*Ȿۇ⊘,=~8?_~v iܟ]szwyw}+?7 V1R-ɚqM|U][~A /7MݭY "Iepa&徨П/_/ )ɤ ]GS->-~IXdV:fTy=6*.]I̟Rb #˫j'!oZhWge*jYXzb[ߞlQ~L`LH̡ IX;K$aZ2DuО2^|6@&trV:XMf,|Wp$dDјY>Hrp}y?YW$0pޞvqb6sQGNqg.A`ud(Ec,Ak?PqE`%t@`$OYt$3¬9fwW,չ6SoBA[:^J"U"KF,؊Ȧ!(h/BSq~!,)`cWbRM4t}7.d2Te]' ?cSp>uPv_ 鿸X-Z`~ڃ4Τ@JYVIB@-'|$IA4Il|O i}<Ƿq 6g)Ld/)3_`#MfW~+RՂͧ,f~-1)y s8ꨪ|puBnJm}`om[psݝsdRx27i5Ԟgf@pb d-vGr` 5c%Ap.Ĉa(Cz ēH@7ep2S{ot&qp#z3(6았8Oom =25Xa?^뫫i]8|z||Qq/V~>Ky6<>ȱ@auQoP? F]'ēQ{c?oI 7 UsSn򈙃p]3$oej`$ Рhc]ߎ'ܼL .< tA?QCbϿqHr `˂*n|Iʩ|я5-AbG%}2wWM]=ֶۼ2.\= F\ư4CMdrFsf 1MIChic]Vɽ 0I8]l$1ِ~`n(d Lcympϸp2! ‚Vzl|pMذX„hh {ыfXsʶ .bq]Qs} T9U{,ʅW7cJp0f[Sau5\<6),::]f9|QFf?S)FOLKwY &<$~x|Sv=].nѕ3;Gn3+'2xo'asg8p):_n]PH`>Ցdd&5@eQM@ZN z&,\̤fIf\ӽ$%%^h #f(,їG\!p3!_\.@.C6/: Jy;ҙ;9݆ GCLNi+]bFq}|ݻ|F+}#eP?ZMpF2C6"Jx&]0hJ~C:%] 3{HuӻSP7#Nj}AZF=~ ]B4Xa7jM%moćTcb9Dm!WjRh,lƂRpwQ]WUԿT\0l]/0_?LN eWqEPeD26@9U1Kg. \r.Gm3qDәp퐥NęfrY<&/jQ:mtr6|?9^F5oȸۉ<| T} onb#$7 uF` 1wɋڠ{h;.ܭi0%/]K(T endstream endobj 3240 0 obj <> stream xڽZY~ϯjo2o ?p$ mIjw S՗nI'.C>+*]if˷lEKR5]?hԢZo/h[1Έ_w_߭9Eo_jEn:ط֬*6}1]f/ߊxe-jRQaz'e:3+coZ;Aoۏn(%5Q5J3JOWNC1<"aqMjDƉvj$-JM .(aB}rhܧ]?џ15,~ӱ]kF{sܛy׾ٷ@"mw-iNn$ek~iHUϑXI [sM NAlH0Qܷ;#ţA-Myl0Kۻ`6;&;7pKg(.-'صnk"`3U嶱k%[F<3CrpA SJ 7(F}30f6E$ll^S2"ʂ]­vw|Y{ݼykH%%Rgx:0-Lb3<6]n @4|.Yh$UR?3W:K7m X,#>Y./14vLZhuag2cAiq04LS{=\;mp+G<%eLtS4ckofln^-G.'^YWS*0 Bwf.S7TkoۏfF*Hq,Vf6WO㰷FJoڦD=m*3h'\=7L"$Ϊ-eZZynߌV#D/Fбzqª6܈f@ ev)J JX.D=@=WWWiB#Ó[+`# Jɦ zu[J4*lD9*ء1Qk۴եZh`wK:dā]k͍KԬJ̴R&S9U.9: {NJNoÖ"L-JyAW. 1qj]T:OExS5=&.;XR\V3GԌfRuJ}vS TS)Uhz]sivfR4)5q7/d>I 6zxx4fZ__<ɇ;3,<m|cϬIDӲL¥Ckbۢ=!>@zw) ڥ>znCi <i*rg0}p хߜ 02u:Dt&|MmgKxeT|^L$Rxx-4N00 kwSWG:^^o:F4L$BxjԆj0`Cߴv]ܒ$fFe:֠e\اfo 7AL a2:ؼk01M/bo <vWTɋ~n>&\,:(ٞ!%<xuȆ s3NBAzsw @ %!ȌչjtɄKDHv cmՀ`B.z݉`*n͇9h焪~Uc%R} 4 rll$]Ng0' KcV1/ BT4ryz,Êq4p=0V{H@>ڭޭ2?dm>AL1EH$Yz<$(h!Ŵ.(lq E[;K!Tb5Ï6$ST_Dzr'O0`#oQLiO@/Q{~Q18F{N )rɫpD7q دc@ |c< vL/CqkhXexyT܋8Ӂyx\7K%zFMYu3]ٷB.P:ճ6 ]Mdze#84a.hJNa1cyL"}pFX8FjH]*Հzmt4OU+&8[jT(s x.}VlZoolY] @]?7Z |~5fӧ:;ëڜ rVZ:pxtJx/ wn# endstream endobj 3243 0 obj <> stream xڅAk0 f'ղeqc6e;6t钴?%q #=)KP4J W9b+ 4]>c_Ij')麲$ŋ nFYxh@ٱX XwMg,<P" #rW&`y*,4A+S!4~.SErpPi ɾV[>LnNj*dkf8.v[u6fګg̉> stream xS(T0T0BCs# 2PHU4g endstream endobj 3249 0 obj <> stream xڭXm6_iA -Mf&3|mݙ9wW+ ܁Ϟf9KBZ>Bf1l~]~~g, 0eL$` , l0_o`+8,՗p2 &fHqn7Lξue x:p;0:\\pϬAF,[{=On;"' IӣN}VxES"x.tmvYƸPYz^)dxo{uu^]%Ӭ*s5aWU<&a-+ZQ_-X y ZD3kXfSESe1Qzȱd+yDtكթ2$aE% Z4@64 6lMOg~V6|Ӊm<Æ%J:ИB7L8M4c ԐJ Z@:-_f /w[LF7YY&<`ozF?S)74jJLу8օ5 '7dg8v2f YoE@:L ^്t%dao}Ȭ4,gֈT7xCl;L+ihf_JzTތrF2Q[4CBY0H˶f<ǀbxeO@`@+P.P{'d9k@ BṪfa[U: m32 TW~Nޜ ö; K!Oba6ks_(P r$z~m.7~5Us˱-?(z|tz\JVpJ,W-%BwTvY/d"Lfn=%09X~g -R}=7AB$;,]P߱̍3q? zOW%#jQ #Vʘ2ǿ C/7x\ (^~( endstream endobj 3252 0 obj <> stream xڍSMo0 W(3O>#2dAWahlm~ G<A8>X/'-յ$CsA= rJV~$RIVa~-,QJѪa{wm}7ٚn=KdFw똴t^]#ĝ\XC&%-,17LqZ혒:[M~uMHG$BQ] )AK{>3#~ ` He"x.nhe F_@Ҥ6dyB:T/y_ri)c"4e)DM:}p0(z fѴ:5uKLU ly?(}x2]]պXiiXDj *tP PO+n^v!x_,AHkMEhQҦ=ޅ- eg)WC`s?G 2*Wa endstream endobj 3019 0 obj <> stream x[ێ}WTC!ȋMC,<22}^DN-fIh7@Nisԥ/CEjXB\T!D (!J!\88Z(i 88N%1! 8<p|Ab "()-XDHv+AVAj06jq$(TLM),h%@6HWF P4Eo("xKj h(!U!-Q[!-]MQb Iɕ$ )fIg)q(}>He qMjJ yWJBz.qCNqVCΕ PU ǵ%Ee[ѥRj^"R&J9@RȆ ȩJ S$UcdTU Blu:tNEP,5(Q`(jY渔U#ȁC^ANy9*.H!Df!pkT** R0p̅jd_V&Kµh HiK=Xd-nkt æF6Jc+JX#k$V;"~wkF#l)#ptP1TxM2+_^Pj:]!nn!n^ a}!>E"uax#5hHep m=NYw !:BrSB2CYoʬ&xFX!UQfMƏs8 2! 0Zэ7'!=OKc{Ķ!f#1dXZMm-1ďj4h@+kG44RTa"M !]SDA841b/͍ k"=d(Eve! o9o,~ROJ"')'-}rTI+ܨ}2"7(%Sa50ۑ̽"s2K Rh@(A"K3>bƌ[4!0sUb54$)y_û>O?>~?.͟.j>h9oA|[wP|K}-2me*3ygo AݝjB=KVnߣ>c Z Z۝:eoIx^2wWs^rzEk &˷MO9ܦ|9Հ;eQtS&կiq^r^k{h/-hko he~sm/m's<>oK Na?\k[#7GvK})OOS(O L{X?sCt im*2 ж,@+^*\ Rl1MFZHq 6@df 6mSkYgvdy8F:vmJnqow[>IKhN1NC9T=k;awƷ5'/7Zp&*qy}1Q. endstream endobj 3289 0 obj <> stream xڝ[ˮ+C$/ ,dd <"SWgP Hz*+mmUh6z>iЦr(."78-nhGug=FÕm1qwhG-'Z;. .LpId!R ~3 QC G 9%Ъq5. %DÃZbP~4;a6ZlGИ f`l@\̄*t0c5; Pa  %}mJ)ȉSaH 4CaeaBz\0C83jxbdăc,[\@)\Q i8p6ȌӸO}F\yC5Dgg |X8fG4|՘QSK[e1 |!-nG<x $@\RDžJkAaX&H''8k`BZ8 Y4 ),jtp|ačdZEnq# 1-24b!|hx pg;!dSdMC0Efbcٽ)_9|yxYyuɋ!@<Qr\^%x{ bg׿./N}/ju{މv71[/z?4yg=b0 ҉8D H'y " nb|T; Ny' A;g!;M&_08NҜNy' Aj*D!^+yp襾cnb|A'۩:D\R1kjD:D^!@<'>[jھ~`q3^0GM!i? endstream endobj 3344 0 obj <> stream xڝ[ˎ+fQ o&0 AxE>(Z#4wiu(纥iJeR^Җ%ZWJU\}RƶUĚ ׶inڦMF,cf' yǗ6I3KJTU z9I.cvU\ *La0I= AjܖBp+[r5Z5AJVCpX5p b2 ȃq2p|3E7Mi(6ܠ.P3ivaGkbZ="k9bP *KP qIHhT\Kp#B:X9=!8,Y{p5n8 L+A m2֬1qԊ5SRFf4a!=6n9B^D+<H2Z,AkA܇|9Ց+cSh&/_~_w|;~ϿჯCr@: ^1f1fɘd^gJ@ED[!"U!߰lI%KWW'U*^*C3DKDV!Z~Dz/c_g 7p_" '!;̰S$eD.Xf9|ppN3Þb̜.BXJCw,3?,Ǿpl<<,Wyh!@e!gNB4X<9q3!}x\OŻ+mWm}OBvB2RSC.{Z xYemc|'<3\N2:sM*F4,1 u}ak„tPHb  L4>TFK_gGX? xKv ےv!fѕ:* Ce&FHYiLވ޲r=l -s7wYxۻ *O* CޏzޑuiU'@[VG=]怅!빡()zyo endstream endobj 3398 0 obj <> stream xڝ[ˮ +-`6&dd$ `zfʬ*TZ1mvն\Vo"cl%5m+~ RA͒9f~ ٪}r1+ ocg\ ~o/#jΝ p$-~sɾ`)ٯYX-g)ڜfy䉗\\"T#KJs+@@sʅ}+R5`USWR!xQh|)zǪ)9iJQK.J6VN2%ؔRw8e.?lUgv씯6ISVp%ylVZXUx j`U}&\jRɪ,(s # U0:5NjDjUw0<* jQ4;2xG,÷4%wӶ +H7٩bx dZaxt0Wqif3v]VVa[kZ /^ {FBNnpA8wWoz ;$G>##>\r6*6 $G@0wV9NMMkC..d7\?{"cJcJf |ҲFDx174NQ,Nk]a&NQzBƢշc^vسk$'oW7&ښmMeq8D5vF:Hguzo WOE _="NF z=eo@lDH_a|$OMD b0x[@)q)<^O4_^D*k1S=IEztqޔfJtJ^F}mk ^5)f#)cGz DX[aH_z?6/ylJT;-0q,-,@5BO#l$oX6b d,0qjRGZȋAwW憕ǩbqZ-_iLƣ@XTR/0GSfKسk$ҏ%L $ʌĻ:wu컴v:ǎƎ]t.Pqü'y=}SH5XA}"|RH#8'k%:4@HA@8Yme d,l|fόϞi9( bzae+jy2f_(^iD7#QelP  t>(vu\=y<~?y[ D9$flP  t>(vc]Gi9,L#NbZlN@XAbGH:CfCfbl8b' A#Hc,U|_7O"&1f1f-߼FxWM4! 4;aN@8|,2.ܬGx9pcfN@HW>v2\|pqYל{F4 endstream endobj 3453 0 obj <> stream xڝ[, DQ$Í4.H$A;𱋼}Hp߁w3u~"0?H unG# Sv&NvtBA=v!臌vGa"_SKmT87:Z3zTF騝3-ps#Wb'tBXmq+.NY19ovJZPQYI#-5ԧhܘm8C}vh(&'k窅f挗(披a)~P8Lk~+BR撘. Sh~%>{ppE$П4?WC%O^( &=xqSH.4TIs]_1) KE].Ao;P7rp[M"\|KH]b݇9GG)&xhT iw)zi7ިu<8mZE^,ndҜɳp1mz ZuGr +8ǂ /G^nA{:RËm$m is&׮ ?ȏ{!R$$WAיKcb6gRkHnm3~5_ӔYs̐m"f݂ܴ>=4ReJPSr׋ڔܭfaK&^;M+8?u3E Lmʱm-уb)99(>,D((p@QJxEZ(5\pja42RG tONy\`AzTȤ Z w`FµE0:?!BXኵ)][ Bb؏>9Ӧ  a*)$eUT,Rg"4 M}[1ŲJB[h)Q jdx[swF3l=q!8#izS%&X!`Jn:0FAj /\`Լ<:Q|qd.p.Ra,.]Y\ zxAuRX)"> ¦k{0drL\OzUoR;9'O_5n/?}wǿ_3?o>oc?WQR: r՗;[M?_Svyn ĖB- @  T6@[j!NS5> [4%;I!Ct*脤D"9NI|[oRQsu"UUF\^ J 6@P>mT_fsS:rn [G\A}> g< gFn0Íza eQ6@ :@⌱i3ކomI 70NǥZA7@8 G;wfETL#SȂIq_nB_l@b;4dіD"6!SAl#-Hi2XT;&p [(R:HEԾBh9@:I-!pʅ-!ZiHJ/ @lD;!jgHԕӰ@⠫s{MLzK7@Pn qz]yjy?` VBazal@aZyjֵb.=g0rCCڅ-:6@PAmd qo̙8H ST:,}#8E 'nT/$@V=zdy|<&z#HV? %JA t Al-h8=oޢj(2 MPA6.(j$ H˖2N- S^Ck1B :6@-kY̵$*nM.l! ZŭF 0h~Zo녶3(zllk['Z>7H9wr<=K/vF>dA(]w;o@PrPܛYMҝfɵ`ݎ [(n ۹{7 S씔3!v/ll+vw;o@87y"i9;%NIGz@n}%*vw;o@w;z *\A-0%)&%|s2bxƩr@ݎn  t\A :Mހ>wyfj(2pc+v w;Cݎn !i9;%NJKn-C (m'Z,;%= Ʃ>9Vot HQzC5 QzcZzdv&)kDvC﵍p@Ѳ^6@PwZAzǯ!8 3Xчbq@A6n 赉1o qX7@#-gp PNL(u $ H˜Ild1C1OMPAYl8^o(7@jyqXoM-$okfn ՍR%J:zmb7@Pl,޼'Ï4|eZ)u!Z (mGZ9wJ'ѓ ze ԦSw uV>aM@np [@dd* HQů ՛4eP_7/>3w.Q9S=y}G?/4a|7t~S>FzQ=DS endstream endobj 3509 0 obj <> stream xڝ[%Kփ@pЉ!83p"Z)ohfEn 4٧un^)VrH1=ڌ8_=!\I / Wk99z4fG-~C-&c=j)k O-BGC*5YC5ЮQ?Y<`z Y!@vB"q Q< L3(q V@DkHP w^Ӡ-ĨAn~Vsp$ LYxPcT"WjqMu#rX@+ŢiF"y4ч.pNӈB( ĽxX.pSka>r=''<];NeVuZA;,^!݂u5 ʶe9mY>}YC"~Xk(cY iY>.q 3))"4Eтm3PF "Rj ]3OWcF)2v󬘌kiс22% N J*7 )CKl%` ]D10{DAceiΈ"xqGx0Y* q52\BQA+ nh%tǚR*]i[񰘀@&HyQ\1!*)JkuUY΄ŶڊLT["lEE +<6PZ”Z{_jO b_爧@W= x/&1!bL&P.H\!Θ ; 3D$#}jqGex4jgQ.WIjO{(PuhHG<A 'Q-`UiRe"p\TՑR×~_[y:/~?O>V1 sk\ b dlw ow|ÔpuM+nW<)4WV-@lDHa洲2_ӧ.)x TY& m8 ̜.Az}˭>mBfwgi)O\bsAd b dl<ϒSHʩ>U  e }#edx!i<y?%@3QΪϋC,oB%#Pi@oZ"/Ngs7UXo?-R.b V## vC[>jIVcpZ:^Ԛ D8# j/yf^=ygihϫXhr ̜^|r"ֲҰsE-7@XCe38>P`mo/F`~!=TEkFr[#y$}} +-I֙dRxRm( ̜Z6@K^g3")x KU Զ dn0sDH}rXNny:/j ! Q*-* ny/D7Pf`[ lZ^7y)[ ._ѽ4Ԓmsh5R82bvX st.Œ7F6H?/+ V;|l0sZK^s} 󤞳4lE-VZa= fN ]^r˺r}2;Ky.j1z 38.˱X5H´Hv} u"s2rǣn ; gl34)cl1m} brw1b~&Yg}BK}^Ri6@ fN e-g3b):Oitӑolo,w3,߰c?hE;hFt~, 1 +<3ɚdz}1~墖1BnXm$ {x򀛕c_s4sEJmMoM(0GK^n;?"|> stream xڝ[g>92y AZr;C 6{1b3""ӆlm۶mS֊0mk%[alcTWRfM$CKmށ,qhdbܿN խ6B+4c!ոK@H=$jdoU[õ` -/K6(< C*̟3m :+$}gܨcEP*pd۴o:c"~RHǪ::V-C\Ў0<=aBN7DAJt9} (m_" MjFEF&#V{UCB$9 oc6Ԙ{"_aBR@¬aR q0"9 ̟qJǓmtx̎(H_,WLX P@W}s٣~vP4Pv(^7X4P뢶tbYK{D('΍V:BaW!"`k-3H ~քVD T2y$g3@ ("*Z)876p ֑ℸ^5QZjBfA9Eу0 nvOCDiߢamj5:l]Nu%%jQCDv(t% ^P-^{ NmwI$̆ypIG51N8|肖\n℈Y*v;NY|A{c@×~_}O_| ?~oVϿŁos;D@ﮃoqq~ie_[ 3 ~n{C)4fiΏ:@|^.'1p^0HAoDIՒZZTfN /cxTR8;QS_OjV@ dd:ӧvҰqI-ޮ@3sV j |v2UOOdnYzIgs*7zg=1ﺿ-ZO D@gYaD:l91p!$Y'cƤCI@|[ua\oyyiD'Ph~RA5d y˒ELkf44qRuc dYuڡc ^/},;GHyzEHroNii5qrd jlAس̹ru3\#s)?mjdR2@9 򖗧OzʫbHue=^e %@3qvxjsxfsVcXc_ma*KxžCmY,7)/'~s7g.7;$u7-~v8iZZ3~DٳY?yn `jiZuZ\aT[whZK =P[a c3]aoyEL[KaҰs~|sd Uw:\? ɃѯP,R}O<>7O3<9cCN"MKg2XaL]>^cf%dIV5G= lDE@9boyyf3$OU^:>2UYй3u_P/k1fkA1Z|Pk|P3`A W jy9wBnnj+&f޹ }f'O=A3@` rq2JI@at.43:h 3]aбW -ܬf , /wͬd :Hoy9ܬ2뜧iҐm 38X5tD4UN>͇٘P,R9;gݳ[(w;$d쓐 ǥuRW#?9H2Y혲jJ{{ʥc3o3_ƾ]QٵW vIW :iD[^Ι9^N|ctv혈xRU#: x:i C'^X{93g251)]{z 2e}I8Ͽ=NFesΜRNӖ͞yA͞y ŷc9u.,VrϓZ@uoB{˞sksk^G , ==W endstream endobj 3657 0 obj <> stream x]1o0wSU4@F%n>Rb,Clwpt7Atq8\D8,N@urO~}cX>g> stream xڕY \T?0sh bz]R+7e@}EagfdE1DdT,%,˴43VzsƗ{ۻߏaq{Yyad2ͮK-hBiIWfn l- YF&8f8ȊߌO_@Fd\d8;Oܢ0?q;;N3g$眝8.#;#.xwDy!O5#0|Jp '9FE:GcSz,  :;,jۻO~f\IC2̖ ddv fl>L_ƞga0A f0*Ɓ<f$3Me1 Df3Leistf7f&3ag2BfY¸0KerfYŬf^f0ZfyldܘMfƝqfllpk66'lDEDCs\6Iim{Ϻ>&إ}7U{aI:Lg. 8oAkw;~a%C ҨsPU*-~a[9|Ꮕcl^= 'ީ[Qgof|bp#zt 9X.Qi&}*_f h%%HnGsLCMK#>틅X9p8bK>1 4 [k?ZQf|^O~A:%|_zJx RtQ{ brbK9²KhWTM9>d}RmT}]Cd+[9_5)?os,+dƌ ЁBvA"5?q&osgUqqC0tiQǑAWBr/\NMuR NF{I}aK(+H„d_Z4cIցvҎ quD{҇p dIkHo֔.o\1}#(^^J:7u4l}usʌhC`=lkӴ;_&>xRU\G3/FisU.#M|\WsDZ7  -&.-˷-7'65l7Upr]d} ;rі b6\ g8mPQT \҅dH2K* ˀ,kmA7yU.@.fpZɚ WƠ 1 }6m&3 Qhdp"+qp2syJ_̭f8W2+ $rQQ!I f1|0roa&= V9.ZS| :sڊְ1'YI9t8iFtArшR:3G*[) pC[Ǐ(&W{m;sEja(U1q0 88Ev{jtc Fo'¨#ayAs~ j Us>^Lmݳ9ɢq}~؆*FI9@5fl {뵆(C>MH@`(m P&4y@Yob8r{Jhi&}h9xO'D&c=f~dw$8?PoGT:^(  ӷnN\{TΨN I{( UjyE%-GHOVuմ6 e糰Nw dzhYچ&ḳBw{P -0`|#LG ?P*$T :ˤ+aLe~%oe_3aq0wlm5- [5V.Ļ|>5 LQWk  ("hWf}T^sʀJWW%Oܲ'CIqnnqKOz oQ[;Wb_ц!=zȈ'j^D)6.`pͫ uȲ|Tap-U/Ol[.g]7yhs89̝hܺt ж˄?I.R % gJ|"˚rk ݵg.tX`1%d8Q} vxc(7?MA+ىհ[4nЃx ܟat -BE꒝$-EDK`_c$|N! PL#A|q#4 8ʸPib6*gkU,s p}zj A `].C45^Rv7xCpam`Nj{Y1Yl6ރB=]6%7X9rDA6&5p4aÖq='k8qݙuȫ}kq9z%^(#u@w{f* KMԚqcFO,:rKe_ Y;n82&;''Q.Ȣ=ږeƩh/7$&I8 Vuw K}|c?Yifs`6m1>"׆>yEkj@Af@'N>լ ӏ`НNQHUߒ_D^5>a[_ t퇂_2R%yLmŅy̮m[|x 8mK.*]ïЛ4u,&n݂m6~ BF*dM27X8kĒ(i8Dt;ɱ#9ǁH08H7_x~)Dƍ#~t 4m;h5q7pa~5%<ʧuTڊ=8[l·y|As!2$sݓz"}yPSa0LU5vR,l@#-L^ɐaț0EPRvGSv;Hu: r߁{͇8usCJ`Gқx24r8?m|Ex.Gtk_5 ր+%;`1G.gOVj 8@VnN.=T#'zfVrV>)Ktq>FgMY Y\۹0_K7^Rc ~ ޿b9GdNsӧ @;?V&Q▬e$K1["(}h?E/6QE \Y_zP PUxỊFNwY4v+$L7qX"8.~Cx^.v[yEr֌4ɇ)GuI*"rF+جPtr5F)du=.9,kG]dOq$dG?ُ\ӥgQ龰JvgȿCy_ڂѳrGM[ZAB"s =qIv)MOjmSX{JN'퐞նd,-,O?><~>y\nĝQF_ߵDET>[ϽG'r ֚dM}xuKr'){ s_Ho[S(GIѐcEn=[ >wla1YN5> }H-&= h{J*w߱ٿM ˬʡJ54m^!!;ٸ7'-}מ xS1vOK./(M'(t)jH 2F%j?{ZSO eˊJk*/qVPm (ud蕍(ȞJS?xӫ!מn[u1eiKKWDظ:ҝE!Ȳk;T{_kh`K13;KtވNOY3Fdȝ8 gݼO1< +\UԴ0[R\ ;y /36I#5D+w "Rwϝ]F^gDgaΟq9zJ45.o- }Onn^NLa2LT[dީ9O)M\vr||qʱ緪=y^7t-'ӴT~}ޘnJˆ0^p VK2d?sv#T5T 6w3EMPSTAW V)[P-r2c9rq8ϧr$OοD|η5Gizs@7H,!*%%2{^[$"%ٚ˚mQ`j 6zgً}/F.Y endstream endobj 3660 0 obj <> stream x]Rn0 9v&NBH-CשvtH#Dc~fe^nbTk;XU.pt $k:5'V}m0s^Aӱ1k%n\}/u;$  .8;[l/mW8eg1ЃԧdI V`k} CLvx%! &g7ۣ ,'$ dYbJFbC֓X#" _a1v<q^kU7k*qꝆ0( endstream endobj 3662 0 obj <> stream xڭzXPL$f֖ػK, v"UԕKYKeYXڂ hlQ1jlE713xHw,7}wgx9s73VTU7-X7j5 'b3e{5s"RU]r a3[#Ќ?im 8u ӧO=psc /w?@{! 1n\hhXAG=k`nNvC܃wsAtezuctYy@,9ՓvXM)nT(՝M1T'ՋCP}~TʖPoP,&%쨷wG Q!P=}j5AFQ1Xj5@M&Q)Tj5A}HͤSZH-SK2j9ZIVSk({j-ZOm6RʟP S7ʊ(|j?*%z}vEm8FĬfvѣGGϾ=׸^6sfվ}+-wBɻ,\÷uAAj]xw8ݵ-$Z+M?xxȏC}~o{-=yvؤa9^6B2Ⱦ#Ge=g1#c?Fëmk`-(d,8_em=#{`>y &$?2XZ˞[NI)LɰxU|vTbΗ֛5Z 'Cǫ Hjd=e5ϹPFKGhBcxu C,iچow֙l/=+9n3Zbpɿօ6>RKFh`GOqUPg ٦QC$]STR_ubmܱFlƾTN=J_A{*%Uթ>@`le?AF{3|rˀrWEA G(/_\.Z/&xnͪآܤ}I5<*Ÿ 1ߊ%ύ~|W In`yvdaK ڇ{޸go| ~;쳶3z߸إ.ƃ7DF q0ZΡE<(k6 ^/棌.h rgx뚀poc.J v`H0 x<[\cGpx'jԶ. h =+< 0 3BnfjNӑ4CJ>󗯈 UJ֍QO?x/F'FthuM#;sh (h8T O_A:!3\$cԊk!0 -<x8T MZ:Tv,. 9z5@? ܐk_l >2h{ʯI,HW%0*DgX;(m$-g1ŭ֘Stm20EE; 2xx8ZZ_3.<'pñ5>ugƖlF{1*o8٫t]0bA<\rwOen(n FvەnN?u-]6{&0!)ƌfGQv65CoT8HJT&nZ8`ɬma;|`*|5҅cwQwm{JՒJ;>!>@cȌ2AŘl4}yNֹ1ack/ -"o՝Xdr 囬o>1V-hpuZb.P_$DzHEcz GN~5eZ"o,X1w \RN?R501Y'ל[y"1m5l= C4,198q59YQ_cٚL yxDwicH5xķ;GPhĉ,@Q#[@vy/ꟓ z00i*x~¢UXw" pOIL`R iW{Hy32pEE+Q)PUTJAScx`ws<t)LVظ F[6MPw񽦓so,Y!K)AL~V^ TxY)-HNlE^$Hatim .sz9wO%0( Р%R,[JX;r g[Ggep8I^brұg\_+S3zN2OJ2ި:]}*9U*J= WwuOEhזKIJhPũ'M|tֶ\H4d MRU ~C; ,\Kuq]`% 6ga,>J4gό |]{\`O|uU'>3p6Hu) 5p6hx=́,R,cFsA:$v.7RЇp+MR_|i#٫ȣ=ձ8_q46ށZҘ} ze?Yl 2%٧Oxĝ<x5l玛h Mee^\{ڒϏ=3M3׮kT Wɯ<-@I~NqQ K@ީj1R=; G~DMmuh+zM)n 8Gzz1hmT$V~]N:%Q%&C7.WؚP`АsL$DA:r4S\60oMл&F `eKGVkG0h ,`j ̥fhĭS΍$Ib~Id:Kn|Hu_zOҁ:[JTԯLJv&}KLU 'Low0eg؈;%"Nұ<6naP/|]~'y2W#I6rkRHW_:jB-fJm@*bxYl8zrbELl%2x@2V>5|~$$S]1v Ee{CIVvkj0}|™ 9Xecb?FZ1w,zf s#yz{ yqPV¢*'vs?0}S788^}.}, nXz##BY ٺu]KpbpoGQ@g\rf|O!*CsjCj8f$/̴#'q?/?WY|?WΚ>$3{Io<!Z671Uob*5׽):].KFfBd' dj#j/^͹x=rq׆(:&ۣ.5?!(Y@ז렙9zԊEKDT@4g9|<,r%Ƒd2;2 9xkR{„zi7sDCeHhu!\87er݀:z,Ŷߏ}";*37'<)x'-xl k3igRQZg2/Pf>p<0ߥM4-BhzMC9VK Zd [XUN_y j8YgFa8qJ<),Uu\?}9IBIص{iFרuZҿJt{u6M@#7d`e--)aTf!}Ԓ^(Ů<}dɄN%!c+`>wVI6ag}}4sb M@EzϦRF#yWOD~2Xڭ,VKj簾 ^Mf" Gd;-ww!X| [Y1ff>$@]Vh]ٌF fp}!䢸e  ?"qf2=a23* OQ&Dq{X1cc#u>iH.khɖ3َ+~a%@CwPGś 92MB8Q\to1 f|6f%ވ,{W$w͑7GϣS>cҮ~1U 2Zwǒxxs-j%Ts `ҵ> '}? vA$F&vxk,h"g]J-b/\pw:6CŊW!Bw_%P67u YW2ALpw)jx.L [] W; gL8X5hm gm_)axgڲNsϯ+.|uIN:._E7i'euEbP~*[,t7]x>f& pv# 1D>- tCa3wɬڏLr/f~z1[oUgFwQY>}:ہaXNU.WFA!AX a!z0*䟡I'OvC.!ˉr PDsΦOz[b#?{!9DýHl0B42]nlڢ|݂A-v+6 1UZ(,n"VjxYN)\Lv,l^[6뎢:IR9P\Yvggc{2jv,7@N Fvl|6Y )vUǡS"~Cc)uSx!i`xK:ڥxC\3Ғst>Eftv:˼kD,[Mջ M r]$'(i4 ,ƳE4tH#)ZGK=}W<EPX䏖cOIѡ~[;25v&%UQN,Ð#)* v+p(CnaؙJ{tv"7BePƨx:.%@b&qo]9y_'e΅,/tE~ KVz:A6<]sf~{BA$cXљOiȺ:Frqî'*@ v)P.d$#s+H)&F+ԳQұmlFQ>{:mI՗dٲrO.JFxWh 7Yi_>YvRrbse2vTETw]1z+zW0䥪_u*ɣp)‚|Le&o16_rM=w,;n&벣A [/C4) n j?cD@eTUW^{0cned>NsDYhi,$i0z펛hz&E1?ĄvTEG`]Y&1hz}Ŗ5G,LVhVy&ۊ(l(ME#nw$&;YT-6Ѻdf ehd2IJM *:z??f u?{糈=p`?EYq^t -Bm%h%Jl+B/yjۜK~S ;Ƞ\WgN.h !S'*(!6ߕ̸ %&u0Ν,]u)BEVJR@,YVR[FIͥ@&ñ Ζݼ3&*I;9Е>٠^6uc 3$|wZw(>Ǿ Zv50'ķQwnoP: u;ωP@Zem]CXNrYp8~ݺ DA4o]tq5L z|6>Om/=g(I^ȨїvXJiI~JwAS\\Mqb~ۯKϒ9Cy , ,H K6B9Sn pإSg#>5^Үp lzzV%`5$*/{Bf{ P5Jm~K"VJI[Bߡhi3->DXԍƲ!/*^Wҏ~-V @ƿ8Thήt$hgb,0֘ps]ֳ&70: nsq/(NWT'b 閿}%~Un.$q6A.>EgbIĪUq*{6"0ڸ/WܭP~M<̈-hsmbC v*F~ WҸغpǂs=w܋úE\e'h諉cB4jXHO޲hT6z~ 'HzG9IQ[Q)$,%Cۄ<"~2f9+mHV}PY!kT*{8]jeN'w,kBB.W4$+s|ICh}R@rFrȻ O,989'Ӛa(A3gHjUV2 `$vh7jvtI|MfL2/-l NF$aN~S7z]'=ldD)?:ϸ>Y!C[U6FV}Rה_:PGz}s&="!2.&IbtOJ cjMNώvG^)2EWV٬)VnH!泯&MWDLX;77hC*; &/'.)'NGrAEAlV>JTdZY=q]Fia%MV/\B+$ )  96{NCӱc˜ f U"m=6#Kp@S.'i Ww>HN#8$1a ixWtԡ6Ϣ:O>=N)$g[=y9`KCrXVʡuoVM~ hGVIeӖz2z>g݇}wt` endstream endobj 3663 0 obj <> stream x]QMO0Wq1,& a.wh$8amf^{y P~K^ Ӹh`KF z>oP+dZ}B}:cURa [OVm}q(iơlY{cwu/;]!/(g$M]gIu-;$XyiO 9%,Nnc<7(\r$20j; _6 t]Tv^Ԩʝ?ك endstream endobj 3665 0 obj <> stream xڍz\Er.TS~pjj[[pԁ[AQd#aF#"֭8qmVVm}0[W<^{3emMD"۵+W~d\\&O23-+/C)aHW/XDȑz8|?|No߶E"&L&M8iҔARoO/[v$ưnX:Y KV.QC` 3肯~oqcA NS£`'x74V2x)*NOA6slw'DxnXȱ5US(+ۑ ٹ3Y kj=آ30:BrD@? I;}"C:. 25id@| fmIHK(&B,xaBv LV3"[ kx2Npܸ+gk1Y< ^^4I"/13MǢ"< aN㡓@$h啵h+G9C?\R%#-kީ:* Qiw"}~VAksx*P||fSZ0.+sT<:BABTD+1"&1: )CN>v.~sUc{ۀ>fWqT8#H:.px$!~hIǀW#9#L&Ut4ypHIx]l*J@FZ\ĕ~LI"eXzm^0(:y՚8'$%b=we4UR(@Orྋ-G. 7&}fxgMP ? >3zTm\bJ\v>mCA&c c[Ԝ̍_`1hbJs¤̗=]yWxKUU) F;bۉOV._tf҂Ke )Whqpuy:FDzQ$mڋRhPzIP&і}b 2Dݲ}ӻ@:rΰHgb{]4ɶ&6I Ct(~.}}y\*YWٹ KtJsx ?%فg230w!k4Ȋ_qV4hwl[g" 4j!ӝc3OD0!%J8RoؕX*-Y `>`#/JV jtpD$Q̵_ܸwjd** !9# 5sfCN(e?@,g ;hy?.yݚ^HHJU&4o/ ށ:fζ ;qwed)Ϗ!Uwv2Fg&}a|{qi~9,9ۢuW\\e NP7Z.3q<&r 1>J=YE5[ yqYA.ULTx>Nb&:JcH0c>hvo_zJbhG'jj$$VV( 90>!84&<vfD&a*$ ##ѡ["2"Դ`>tmp+3o4rͻ ( /@<?F9>{&HH8/_Xo`05Qhz8WY]uș9uV3 aDۢj l^nW TIIqdb. &O>]>SNJg x(H΍LJ1gjdLŒfфMf{D_i?FkKeNB+s}l0ZLVBh|u<U"F6n`tyf)Y,AaqNJ.gB_^»)7ȬJUԧf~=|h0b~h{+bx U@3C܁4޾gLL WEwLduA@lE|Y2~ui4>rD{8cqQVP"F6-3J<[WDFf{lBCLMM?YbIm]D&cXҎB;D5RQ(w+nH].O{ sͫu=3aVha0kC>(5kX]#-6cT#:d5*B)k[QuqnRck9XηLHmLUW6ߡ0HUx{m/Fo?H':}9 N^թ yu)J= Į a])1z%%%äv"N"~#]Dګ#{-)BTS=2G<^mCButqew@,iH?#9KMP ů殥o~v\Ym-Vɢ fD0|y9?jҖڠ2q1Rw^=_G7Em^2U)Zu %,&^Ѕ^oxSrL$z0&I=DXtU 6lg|@RNE*m\@]ݙ/4JoXw:Sm]2eڄ|(tHѴӯ}X)n0GSJXMZ,EF[%\ccv)҃G ً$jh=X]u{yA[iT,@5݅-&TMJˬu \ --F8NtTbǜ{pZ˼#Mh/r sa9,kaScb_jD. Hg"sG`1e=P]k)pZPZ9xڭW#п{!"-K(؝Xp14|Gz@iѧƦdA17J֗ 'K8 -u3e5y9cXC Ulg_ȁC&5=٬6t'6$BH_ZiI7a?Ü;DE7d%oѥP ea K}u5QX3NS3 p!;ӫ!O:31:4ШUEW@fcw VE6HfSfi򑝸VBoHů'uEL=Dap--2C!^Syb|="NAbwr} 3= { pvH℔e"q܊kOCN= /G=6/est<$dĥ'}lYHWCvJn~tܙَ30ᯑxBsNm_C#1sGh.ϟDJsFuL3F4tR{VH+,bG[_@Q_^\sCpcn)nc2D\@Ξ\=nB.έ&w,RmGO=t׮rs[ObU{e<~n]|md!"@ *OFW_[^-Qy^[yg\B[u>ESQ^Ҝyde=_@o.9Ol<K]stsmt?~ KtqqXyKwF[9Epd;ǖH.ֽjAq(8ԋ4컱aR#Į8c<+^1}{l'Ub;&0/? +)WcLÒݝ-{Y6n٣ {ݙkFc3Jdtif@SP3k""뻔[Ȥ(Un7'^(û#*iN62;wL6<䒔.U5ST@&󔪆dgJwxS̎^d҈R3MgЯFY>Nym%`QEred̆]|]Vk`z5iҵ73c|gq=rM5mIt(ć.$"|M h$Ə`R(]dqgBVFQk%l1oR!c1!6Jfz>aS쏸EP8-s)r֡6͝27@ea+k ˈ\ׄ{g$Ge]"-e6ziV!1sTuOem@ endstream endobj 3666 0 obj <> stream x]n@{iDф(ڦ2XlZаt 0BWq,p].vu}\krqN˩Rެ(HHaW+XDy0wriOPtDY)\#@[jゼawsF3c8d}HpLQrN==*JEn6 ˀlK. 9 c+R*pd%bSd Ѡs7pifKch <-uMG endstream endobj 3668 0 obj <> stream xڭYwXTgֿklW5wEnlGY5{:033Е"#E5hL,MbIjܘ7fw^|~{7ey~~wQffH$_e֝3mΟ'Xd/3R?AĿ1h7(J!\)+r3EHL$b"b-3o[A1>^6`3%lޚ7o͚PC6v½=mvxL_lܨ9z,(poa6m 1j?urԆA$ftщA9`qcfnayQ2IrHrg,5si0=8u?xy4tPЇ6KmFrV _1eHQ9213Ƅd\Tiq}0~x&po}ƺa~Y y߾MB+#2@ )ڐ0H$-\ޥ(BN $eE&f z7i˾ۿ6dR_ 2}\[D?FRCT>EK^HbY܈~4M}6cÖ [>N~&'FVi#tS˗Mq?$P$q>n3gBY=,]Uꞑ(GG+AĜ%7 5u4u|pBoc7w&#󠭪[8wV0x8۾9G&Ч61=DkIrҘynɋGvq8õ^V3k*_ЋL$rEـ<GHXe .P*H?tx r1:ֲp yb)ɑ`m˝z~gf}\A r?HM*sz-.*7O 64-Eż 54쉽+f<gidawAg '{mg7|clβ,'6¼ &uᾄ(O3 ۋч}b)|'G| =eL6s[O) -|Fh(:(udHKW,&NPSR_}S+pAŖmXb_^uZ2`*o$h&74;ldD"4[Bgݬ5Y|(Tߐ\M˯wew#s4ϱ3; s%֋} ٔdu ĀRBwsiz*303xߎ5ǎU֐gVkymH,EA#oĠ3114>`exIJρ(22XIhZiَtM >q)2/ Ol>ʐ ]~5A`|E]h&vt].)NnKPSn_IhIfg+ /KR}`x4ah&%OXY"M[a]gkއoNvMF#|Skd}:`MN@gѴur)Pm` Oq?+} 6oqX ;Üv L&l1A$4LcfeLA-U'YkeFtQ6yK\(ZZ7S># yj#I(`ޑhBoC!~z@t׷XT͂%x`WCDQq@d:IuߤQK3烛|&d).]!HtKhoZ٨ _%h;( hxnxeW9Ed=<ݑ6hLU9|Es(ƒBF1bfN'ٯmMb>❼*:] ؃"@I)0Qcjp[)XEGB&U5T1Q5f'f%UvYEم(Nk hkleS#v'H2@1j[K2!TmH>/(/1 xPu+A(T9*<4Btt%T*uL2L#~0>Irs6(OEx ~(<EHD{mr.&upyPE Ն@[&dBK&@~*4gaV,Jw7P$Z J~Y@icYօ[!Ԉ 8Ծhx>85|?3_,^*Fzԩ/$zhl ]đeH|osT'@,2RUqQAd|^T\ͬNViQ^wÞjsUr@Æ?u 25Pg3y&_ÚJ,uo>Xu +} Gm9Se9aG#FUAZ o!#_]u6B| "O=t=oqe'WS w84 xb6>[II dW0f,!D,޷VQ>G9)( zzތ?CyXl–|_qh)49e)&ԁ5A94b29~@cIE}RՕir K_EO$,}pjRw0 "ps5}%8('6KQևA+c,_})b}.j'bR<_o v1ځ;y~>OWqPv\vJ5XC&PR491$ 'O@_Oe 痨 ZI wcZQ$b 7Hм\ך^xH&[\l`(iSwiZۮ1<ĀHDov6t2=_Ll&dst{&`JYpkblĒw^Y/2Q!#SBQdĦs#m&[H"kB|X|Ʀ4EԕYB߫s L<&1o?BGKe {p%B>Y#W;j V2Xr])"5 $-{66El:u sGeϺncUX{eFih;X$sx`&gV h+(p #7؋P5<eLOOۺ=ҍdF˲f3-52Ktsou#~"q |W]ǔǽlNqW^<V4[!#,Cb1 cP[Vb@n}"3-YYLe:$3e1uue5-$M^>ng,׭KۑpLOm~qias*'f8zr ޸v.~o4';e2$/6+RKFW;a`1+nAz$Z>MBpXæ#>?1.է/p&BݚzYwkՇ=uЫ] o. Ѩ>9pDriD%h/ءQDo7Qed(2 "ɴb.iRM1-!^^Wn~@B+3%h5?2[Ւ ,y3IG^qށNph[i[ﭛz8-7X"=àg\z{=A)2*mXT2PIHwB%nH^#3Qڬ ٫!dău-ds@r%?_/ È@M-x<_6JTA$]栋%2STxml~( RmW.hlBYkLK$f+H>EuSbB0uJu3 ~ZɢNS}I[; SšJ`L[t4jꎜ0A!dU Z̯ ˂x@~"UTq464WQ\MOTDmJrRB2(꒜84F;:>7ʍǃvތO,Ͽr$lK'E݈G)\:*89;J3S6b+`vI,_ƣ<^Ɖ_ơ<8/R^! >C5]7l-f1 endstream endobj 3669 0 obj <> stream x]Qn0+0DBHCڪ$@%E*2䐿Nr{<Ύvժ!2hpW4^@8W,@b)Vܷ|+rCri$^aq,4q@5gyBI' 4:#8!|ũ?aYZ%88xx{lpZxML8q}n +)l,eMU[vM> stream xڵz|Te E08D "((MP#-&-=IϤ&b7wlO7?-<<}_6kh͞auV=z 2j*zMnErGn ~b0߬7 $h6(( /XՙY9ɉIyfΙh%=pi+sc3mKOH-369>x=xaa9+̛V4mk|n|NA|ܴ33?-`_3ӳsmΌv3353hrJbXSϬtV{q_Vle/Ph.BƬW=E5<yZ1"h/w5ݫh ޹? uޚ!0N(I |ѶȆ ؠr7X|K %$|Sh"amcN@OEMw{ XEO/-~͋O[[;X-ޙ` D3[Уؽ?po57547ѷg`bƍ"y_1:ǕjY(J"~dZ_}}҈`E8<ԐoTԖCEzEW(MG7xeoT~PWsDE?4e+PO. 'aFkL=^sNh?knLL6s.ǫh*Tyhʌ[}/d`bqz2Akh)G{S?vVT^Qh@P#f%GH"II|4+ '?ƑւfAo󑆻$T[\=XJI\c--5{j7Ί3M;MLD:= AdDlCsfN,k.B^NSVOȬ:ZE@OKR2sj;^?ӿјQ_k6KzZVGѸ:uTlNRFjӉsmFqPJH** \6IEJI:EoH4sTq fU:ơ&Qx0,X[QC" TJ=dڟ@?62VQ"6\K(Z+F A/j5q\ІS|:7_h-=b̤ApeuUJBGs/96髋H4Z=m$z`6dd,)Q%%t.%"@`2vYE0HJWXЪR=20pzg$HUȖP ̂C'`#VCAl7 /F̼8̓<耇 4ޱykЂ>= GO-g/#6Z]Gzj]bZ"3$DF%2KwQw8G\2;,"+:7:|Z0`!h4-5۠Z K_7V>0|b֯L ͉8G~<__GSg=({#ϥ˞Lȡ@ƐW vHLᡙr"`jӽ3)JJZ.xݑ[h @B]_w } W[. y:6{X+ 50zJ̌BUm͵O?Hj3dgZVF]uR8"3Wb0M-lMVOիV53 LXi]QWbSfDs'Ѧv e. C KZny IrZ$keF3V=I ZΗWYTer,4M (q ~[!AU߽2SL.6ǩU8>Ҧ2jZպEDB3Je5:V<:_+pel:+if;~UG+}؞R,,?eKވmw+Ua6|&T4Z' $!#`3zo#M8L[:8aIζ^DE(XPuH FGm"}ȫaG:4Db:F)7uִKh ,E[W?4=!^ k ,gc[& Lse}K!_ȨHAuT%6As\jO% ,;-l{=ǺIJYYQ*4Wf Epkp;hB? B@/ 8ʙ>H hK ;bcp^i+M[ dnŖ)5nNzRw_#coV WPGބwңf͘EBbESlUb́bɥL-rFcIh6lqyn⑏yŕ24o{'l X"7(D 5g<7E#>0<ԌF]MEbTj[ƗH0'/ֻþ{9h;Ëz>J%8ll55y&XpK ʐh/8,ehq]1(20ݽBePS v]S{&!ATI4ë}۰IoDCAQ2f(`ѩӈ#*Uu@ ..6n_ =ƣ禁& i^B|3Ss}a{hGqrlbE`erK+QTS|ZB?DልR05#Pa:*^lz%_C!8ۈ]G.Ǟ@:k3t`&&4l8+s4mAP2G,G̀{Z2Чg޺&Y f e8<=$<<-4AOQ #0KJ}"t:vLFtWQ)hUEk{.b5@NիrIXϐ`0kZI@$@!ROarnL6|Ӱh.z{Q/5BRN&,Zf 15s(\m6O/{~~SCBeXai*qW\J3NEԣwv=Y΃@ƮiԨ ! 1J].r֗v=1B'Mό.b7q7Y{iTz:.?•nG'хZ"u֋:>/'(n:ԸF >F7!D%tfi O3;e3CoJ(vGP#59+vlL(^_8ԃ¾YoN2b11Q1B@^tԉZ>"EXD6ɋ;^bg'#𾳾⡗ i ƳEIhHzB_ Q\R*Ѓk/HvKMGLtQxފn/$$680'uGyg`EQQث \LP}qbY*R z!X?bۓy9~A\@ZL6ry`:g2h[$BG(bUku]@-S$F]T S-|WF+!,6c#o4azz!az $.<kVa*3T(%E6!D^MSM|:VU v  2?mO~2>JRjU@0W^[~oIRa<̣_ғh:Rϧ^;5ox Viēz# ~9~H 7Ҝ'^; [9-tb];ohuX蓿Q~ 8*go@aȤ]EO'a=ew~Ftj[𠑛Jo塥ѽ(: ^gS2@DlKBDf-*^*2oHJݧ[ӑ>\sw3z 8- SUb{=F5fxTi*t~)ؗ-H izz҃NxT1bw~Tf7=ĹPiؑ+8BE<GpEcz??!\-V.&ݫAL7۾TVR-=5 tmsL &S kI0XN.la=P(J5qo1Gʲj=JQD][]!X|/k-& FӔ|`E,f6NWYS{ǹXmOBf$@/=+1k)9ʒv#>oYlR,R#KlC `76C5_׋6 O 0Y"x5j:~gm-ıRK˥̔a1FtMoC<;?n-屑)|E*e=I8:S(ux,/}m\Q琒Yڜ pv JfFZQ#W1m' Ί@gԒ 䤔oXW/7 *P\8oܱ!lm)lC`v0SBeksSR6ASi QUR:ϧzfQ ŽPU8mBj3\NA?URƴ dhN!?q)6e|CQS P E`8kr}JJZlhj v5CiRڌ䄔CoA(z6  `kMe?V[uS`t- [M 3k '5vyRNnRW;͉>cZaX88׾\ TgFq)kwEpXSw` IVt_ҙ?.rW`+WC=NLJ}K7*f1^.okW яEiYP-{[kGR F:z}{*7PA 9 [z_0~V)âRi-&iܑU*%H6"k7?+r Ugq}Sy+8ڷw[,ٙMsuF!1Ea|V,obH~P=N̺ $`d 398vo,7,^Vrymvq(.& \}*bS!s$dA_ZZpGcquؾ9}eeyT7*R_^mKGиÍ:iGv뵚3#andW\v4bX,~>%\ƈlNjbZ9-G>Ds,,VD9[(W,lt6'h"Mtf8`Ihk_~?B7#>*#1(ЌzyGy9<ي}%^oLLQ}! \.urʢg 58+wf2j*XhdfV2o[MtzA#"5WAq8}`,WZFYx~iFw- ].S;ݻ]p "BZ򭒜\H1ҍ@G l-FqV+-̮VtT K1WEw bXp* k_rW5{O <'?ԠV@ir'DE'n &' 9J&hn5wz\^SV[j?ɷ40s:GFvCTbFd(,y2;^{gE-dm;ñPrIad=?}G/KMzB5ѱڌ!oTKuJ]x> [$զ2u0[x+J!_]|ɸڔ k0A'~-p3-kh{Fv` 2XǏ[W+./,xy(m4M$51"Lk f薹R5,LRkICuS`́ ɠ۰⼨nI' Wq`+ǚV`ٛ!zۍfTz_8PSG/??8#_߭F ^Q\'yȉTǝy Zũ`t)* tXE⫋A'efcO/D[KKF-Hg~|/W,K6{%Oe"OBg[C[͎UoW&hᙊТJFMuIy9yy$mJ!۔I)s/m a˖*k寶6PK,<1Dh"'y3h~?z=s-SN©wj-e! ٞܔ۞yH[ Uv27kNC_Dۅh$~]M )O.a_~qbj(t dSqe_ODnr j./V wN2Ew|KYRvˊO1k`㌀Q:O6/;#-O5}φrhJ*)H$@GOu{Qi_G;f=+> stream x]Mk0sR]AV+RCVI࿯2<37ȫ(^~:FIXb|SI_Z}m'?9ߌ4E [F*u8UW 6֬pz'Wfz'(2횸8떣i$4,3R?!)c[gF,#i8fEqmLi8޹p|v=qsEiz7Qc"Py` endstream endobj 3674 0 obj <> stream xMmlSUmk{ccb{ıg -}ۺu0/ݺ{[sw5ss9wc*x;Ca}EZ G&BxF)<2~]V/nRس(Z_x||TAB`i<.7m !K>jlCX-=FNnwt;;$X,~?8lF)F :<=InrKva?j\t$MERqIhOT :P]MF cB+mZ7K~Х+ryL{I˰h6R&$w0Rdg$mon]v\::7bw6&s|o/LyL|7~_Zʱl*b! )i$S>&ى[L9ɞ": מ_ wd3a) tP?=gLr7,G qBN:Tb,9 rPLތ]uq}i"> {ZdV2}x~HWfJx%P vnR+"SM:p!rM`wWٟQ@~ˋ˩-W;1qN.CŁ#ueتwh:"#T[xL'7QF)1JYcff'EkC}"!+6e'` \s-8^<'u34:,Zh ^ɕớNݴI 30g\L1S$F5^=rcj_Yi^j[-V'ڐ endstream endobj 3675 0 obj <> stream x]n0 y ;M[%A֭41Q/"+T7Ap2(qS8\@8S,@vbwn}YAVO|?Un@b듪F}q¾Pq/'s^g|ڧh:uEN)Z`jΒم*1Hu#4,<8J'έn gr9|| ^mS`1ܳsv_5e-.ܬ{Kk^ xw7vmv117,wۢN}z~Ȓ endstream endobj 3677 0 obj <> stream xڕX TSg~1P=Sm+"juDž*ŽB*@%lE:N;ڪiک]jO[9eqtN8@~GDyyQ"hu[7)l9^9? S(q( yqdF=AQW}]OxOp= ɿND"&Se<7D&?HO x:9 >078xaXEBt4 <*5>6)*Iz(EgJJ )<H X-J q>hY<-5V.UHOfū"FPQM|/5DMfP`j5zO-Q+j%ZMB:* S+TLmRۨUj'8Q2+uD4U.aTX"Z#KGG0y11?+[2n#D|8>h|U|1ڤԉW,,BUAI^S3(hJBKTEJ 2e*LfO~L@Sf6r͟Q(૫gptrSqT'묡`#SsYPj!>]I$놞6~Rd䑉nc hbMWXE̷Kb"^QeoohBcZN=0~xp3\\)UE>i3Tq}jXQ eLcE@v18& %)6^{XDKfY0ϨxlBӜaK g>- );ݷ|-7e XJq`Iy $]n6GO~D[M #u@)jS@jAeE3x ݉H.N+-R[ds47X{L`";Z!u_ȑd8GiH:"ӑ u Jȇы==CSe]Jg'm< E%8v(3Л>#U9aꄠi X ̴ǡGU?BJcpVIuP#e[r1s"B8!E#&;mQ<Τ4 Fգtuu+B^˺ KO8c8/\':.yoS?p뉗+~N_uMB_ 52K_O;z!BN J( --P?"37m62kUGhcՏUym`=-Ss.SY HV\h5ؽiyq+/x+AEAoɂO\pO!WϹ% fCbٵ[7?G>4;p]_/PݚCo\Co_&(`gUkBa/Nѭ^N|؋6m6z G>h,<Ɇqry%>XDbro/5AUo]7 7i(wa/>r c# S':T&&щ/ gOq'_$7^Lwo}sv>ԡCaXADd`xr3*mid0Dj+io$3!4,'XenI-N5z8I٠\X.*oa_+|?2:x O"aaU^gK"J+Po歆¡L%u^H- 3ZepipF4w HݺMegT֤rQg] qGCGW}fp]ˋkrģbel`7>cjpX={?};xK|Vl608fIMG!;O$@M2nWZ`PZ0;,U?ҟu6 GppZɩVf֣T$!MoW"5yf{ЂL7Zh:vf,;/]Fdp[v3HTWĵ;ď|_az4A7bձC^4A=oLտbH5ceNa+*. 1dѐ/n5K#5 D'O這hZ>x%m  3|n7\O4ħh A׻\>KHED3 NxۜcqARxq#5-$_LIE9RK36u4+AUv~8o*VTAӘBVWw@#mͩ"/ȅLrKrQsCiB'7d] 2\ !haU5vˍ:$-' ^ endstream endobj 3678 0 obj <> stream x]Pn sܦiTdLv]mmmS@-Ix h̛a%esnt|Y[t0H%,zQ*Q7!IyaMKVߗõg8l+j7vN49H =ޅ٧hp-8ic~qB %Eg8ZF$yuAPoO$o/6| WQog-XŠ⯃A&Etj endstream endobj 3680 0 obj <> stream xM_HSqmekFEӈĈm=DyusΫqA2Z* /g-mAc/={ _zp8Y,c=4 wԓE1?wȸf1,gyg\i`lḰ)1 -N{{uJpX$;$ #\r!liAn5#/j0!L!/pO:]QcӗtԨ:қHq".9'O.r]ZPY%ӻSo6WިҾ-Lgfz@ź^{Y mC%>Z3q֜5>mxt~o!#\S(tQ,E3JRnU1Υ, `,kZNao=AE 9%Q%̯<ۜMyks5S)Wѝ*g7=KrI^vd5#JojV&*MՓv{~dy C=KD endstream endobj 3617 0 obj <> stream x\Ys7~_1okזJRۑI@ScJIq뷻C[;C;ٗ-YC|zHY'm}F|eqȸƸXCV56ylywxcq 4l49()  (+ Ƹ% I)_dMv __A,_j?7Fv]eka~RsT oB]jToҹ^nj%k_o|%W9965rj 61'@|sSM ;p+JF ѐve#9DN69bryTJHip4;%F.Nj=vpՎU/[XwA]Wǚj$S-tLsMoL}DWB̍,ŦP\j@&_A|>+Z)Z))YU)ɉŦzbY$p6Qڎ1GYT*q4GCͦ{bq 1AD?eeMfLehh85=8z8U©c=.v ek4tqIڨU2ME-R|=K a^ݛ ~ɻ8*W`\dx>uX܆.Ѓ* (+'Ih{bq# ې©CMbn汲;r4L|X\&3$qr#@XuبrjbJK=DK5t/R-fձ&TO'777YOl,Ŧ{HVj8WHheG =yK:F V4':lZ Z (+ohU(4Gk>u؞X\0z8Q©cpC}mdmTvshTm8v@NGpQp7_ʵS]Wj m} qM=yB!Fv#}$T竸~+tL:_ހ ]=K@ʛ}dH|0a(El6x 2 .dXj?65H,:OPœz.o?{7:{}̒J_o(ɺu ?+ݑv^ZT7YOs d TsX/_ׄa5lWMR:Ms6Ah't ;Z"F wNk>2!Z ]Gv4 F@!j<\XacHzD(EzUd3֜Ģ%ބܓCmqpuKw,vr?~qv΁: kN!{@#yZkF*4s1WweY 84:?2zA=} NgR-/㥏-dWIYa#V*rpNHrfF1Y[ûyI 0;Y"DE߃1*Ѹݻd/DM.qK1\Y-=9WQ2'h1Qm 1̖h8Kr;8Q>`FiC.9{5xt_|>Y"P<䪽u]1Y0Q!>2kE{y*r6kjꐹ˭\6{\{\6e}SXd6 R 5d1`n{l_Rժ{ˏW̢wfrz}!/*Ų@N mYuuV[gm;ppc[?9}g=$N;@V.9[9;:Ey{0vRrGGʋt7,i,[ޗEv><;pʘeq-[aG<2}` CGgV>ӖYfY,zq7>tYf $O*+Jw a#k^MrIyu- wc^p{^{^׃^|.9}๓N?BcW=!`F쁴~> 3o=oëzw_|u]݁B'/)]'ntΤ`9v Y endstream endobj 3689 0 obj <<5603bc28929419b0039d9c624b9f4eec>]/Size 3690/W[1 3 2]/Filter/FlateDecode/Length 9510>> stream x=uxcpeI%K-ɲw^23333 N4tnᶡ6|;gΣgYҝ;3w3c0 n48= N|}C`4 .kg SgJG i)]amItHdz> U(=`#B C"fJo~Z F[}`?+/ &R `YE(`X2MDA0(N_uc;`XIEÝK"0<7FMë5E<0Kç(ca'⧌$eRC$H8(H2-PYH3)Ӏ"Y@"Q Db9@U}┹@{"ٔy@~" |&Bf\"?EJQu*MYt#RDn,L)GY h&RCe50+RrZe-0_<:`4ʔ<*!}\U)[ EQ7_N\xHMN:"(NjԦ5Ie/_}u)%]Cz}0ϩO@ Q] )`,3T0~iL9c4 S0v%֌rƂu")g`x YiI9, ZQ`\HkW*҆rƭER.Zv+0+iO ㉃"(`P#t܄OD:Sn](aX+_t܇]tc4iZK1",JVُDSR4mIʈ XA+ LIE4!7DQHzqp IϲDFPHz/&2AgxCs"c($f~Nd%ESH9&2GE&R\$J-ډLĐܵJ_L"yYd'tN)YΠAg"3)吼^,Jy$o? 2RɅϡTDDR\T_d2oO䇺,TE,TGwDQj bJM$J-$SܥH^ױeHrJC EVP6Od%1L^]>(MaYd5LJ DRZT:J+YOi S+]7PY)ma&J{fJFJG&J=RF ES^EwPôU ;)0>E _)`:;Vd7LWv@Rӣ+"(`z&d 鍿 } ES#0H(eLӵeT|)r2) AJ r2)1.NQ#G")RQDT{Y,eRu2)]tO{2)zT_DѺ^LGEL,,r2 )[oLDP NH( rG)Hy{%Hy-2D6e9R> r)-r)=j$)k`6kZZR^.\}_*z :xJ s }QLs7^%g |GqPv<#e7̣"I=0O@$Rܿ(`^-B"f7P*by?DR)G`>1RF9 r"i0/b(8('a~"S0I9 (aBroʈ)`񎈇rSHK -CG"~UXEk$)7`)P$D KE”["܆IT$r-D(`_!܇ePg,#sD┇L,My ˌ$(Ű,l'RrWh/],H.[/R4ҔdX'Rbe))%Rb")VXn$R ˣ",/E*Q찼a˛E*SayHOtJq1j/,\95(~XS~I j'RHmJH:9/ԥdZ]z(5vԧ`mHJV" )ٰv ҈kO}Sra-8-҄R ֑4uBsf2)ҜR sEZP`]WKJeXoEM")`=TA :2ERjzQK;JMXo:ߞRևE:P~OGJ]X_%҉R7nt4"]( amR}H7JcXHwJ3\ɧ4GHJ DjH/Jk~A7 Rt/ч5#җP:HH?JG6O{EP:#@JWX*2 q tGj"C(H]VGd(RLFDS"h'+2. @ꃞ")']c(3H}OqHx0~p5HMIQu226ۗ"S(c`sZ72iq")`!22"3)S`kKde*lͦLCXdel=5n.e&lGۈ")s`\f^YHݳ-̇mS¶\_SPYK)a?Ode l,,+(`{GM+)a{*=jZ>5}_Jd-e:F9ulBZL6P >ҍH߳ it[LَFmDZ"[)6j6nM['itikQ@N}E9}z ri't+C9"]{)GvsB1=yOd8^](riosr ix[ 4>)rri^0,~=I_OR`prvM8"}?A{BQ')`/{SW9#rrZEPnhYmk9{~/rrAE(`Kty9o\<}˔ǰS7J)PZ%w҃nq)ޠaG 7))'rb]=*M%P+rbXQ% Sp+<8H{'G D)>8&^Cs%c~X1Rp$QXIDz^D/C$E̔gX(9p\RrA$RDw(e_$RW)xR}"锊p|5NIǏ&% "HO](TCREHXGZWDHoHR-)u7һ劄) >P!GZD2)>I,Jc=&4E:"1J3oH{ndSZ l%ҋ\"9HH.EJQ#ODJS: Y=2NHGHPזr.HHyJW3L;ҿF"%?Dg[$N")tZWNB*/YEQ qT\H 8I gS"(Cl[AmP8[=Cg"u)#9Qe$SESF9zH8'3ؐ29!Fqp.՟ܘ2΍iB箿4Lfp%֜2i"-(SἪ[SK,8OnE m")s|iH\8}][|8? ҎOiOY/t,")KH'RL>w,+mHr9\8:7t:I Ԃ=9MEPMp9JCC<1(RDi/u_4'I-)౞DieJKx2"W(I"rrpʺNi,4swoS“J7x !rGɇghL-<',R1=O(٤K)?<;2,gsI-BV xe0)bL "|]UFϏE"iYN "4x]D) tqRfUEEo"*A o)sLC o;"^.?e1^ P>.,e9 SV;H^L*xɢw.(e-kQH{D)=^$AP6{(K\R:"R U"e)}H9xVM<7~@D*RJ~/G9*S?U(GHUQT/#Rr>kH IEjRNSr~Omyr~C)五 U5"|u*Rr" (Wk}N!*|׊4\GƔ[$҄riJ6"(\O9.|3_iAߢn"-)[r+6"Қ?W_䏻’;MiG|pT%v|kt@3|vڅb"])}˧ϋt|"=(>IqŸ˹[Q)3C_ZQ})>)H?JƺO F0]j % d?x`J! $2f0JENɁm/\HJ)3R/|Dd 7)2RDQ*B?ӥ:RLT }͝DןLԀ"S(5]Z$2RLE J="3)̢4@ G$) })̥4Cy4b>u -F(m3Xd1-j,G`T %GM(Qd93tA`VR"D*J7VOYM"k(%4Q"pZז.lC@eєF躱2;l B--z_d+e(oFl G'";(#F_vRF! ]&oMk=t߲2"Iׂ}V5s?e {LEI e:@~aLgBpG)s1\9NT.rENQ!xP_+OS#xn/YRN9GY#]3SV!QV#m 5E:Пsw]l@G=Bوo\lF(E([J;/r!7(O&eB"(;P6eBUCٍPC=ڹKكPk=GُPݏݧ@P"4C!#1(B+N<ChyJ9. )':Zrx>) in1R tHBOV$S#bRDR(R%b\D"u>Rn "禈r _oQ lZNcraU$rD-qQ!\mH1"n[6PH䏻’;}{QP")F PL+ RR Q]$L %"ML ͳD(i->Q>S;,Mq!|o" JwP<?H.ŋEJQ|HiuHYJ/d"MHyJ?@"8"IVd#T$@ĿA2%h?*Rz,RRQ R=Y:,""5(izR&"ԢTD$?W6"EP\K."c7ԣTGdm,HJMDMiH֙"(u)\,ҘRcDP!RJ)"F44Dv'F<򈴠4FE4EUk4Cn)yGaJ D>|M-%"S"\=="jUQtt@HGJGd'҉u")].,+2uFGfU.Sz AL$,҃ A2"(}9WޔdCv\P2to܏2[u/ڟ2HP!nq)#Yk Hd^׵n0e2B E櫺F̷6 GeEFP& y"#)QQ2>s4e oLEVbX4dGDSf#. 9Kd"e.Fve>v1Y +L,D>"S)U_Q kQ)KuGeȺp^d&e9EY;EfSV!K̡FKER M}Q"])P6!'- )5q"Du/lC44Hd e;ٺW_Jفhr"(;[rnD麱W_Iًh~Hd}mZMُ]P :ZZAD'})rzrхE6PN Jv6RN"[MSnlFYDlClGR"DAwEvR.!.eD#ݔ+5D[)rOt[.@!"(7y~LzdurDR!5>bI")+b[WbV+`WU+mժXU$U+L*EST(zFQS AO[ƌLVz76M#S:/VHR+j&2?׷355y#GȨ5/j݄ZVjZyr\UVZ)5*_e|KUKW*K\etkUUVy*XNT+_60,Ō+3c<Ƹq>ƣGӌEW:))VߨL*Ǭ$?:,ye*/K̫ Q*GeI&}2TQY7*CFe .*D~<ΌG2`8qpF)q<ƙ 3 UrUeU9*ORePɩ2*USy*GQ>dGTI[Ȩ ꙅzP1ɘX cwC=qPO,W3j.]{9j5W՝{TjU͎YJ5{f\SstjL͡y5fLQ39j6@ͫ95_ Lm32Z_?`TwI-V]R#vuS=۫17-a.jijLvCU;dؗq  1Nf8qvƥ3nc܊\r{k.k@nNsB=!%sOd?r C@J~ʶ-=wxWr/C[E#I[y}8Q4jFʹK} endstream endobj startxref 2480379 %%EOF gcl-2.6.14/info/chap-17.texi0000644000175000017500000023133514360276512013770 0ustar cammcamm @node Sequences, Hash Tables, Strings, Top @chapter Sequences @menu * Sequence Concepts:: * Rules about Test Functions:: * Sequences Dictionary:: @end menu @node Sequence Concepts, Rules about Test Functions, Sequences, Sequences @section Sequence Concepts @c including concept-sequences A @i{sequence} @IGindex sequence is an ordered collection of @i{elements}, implemented as either a @i{vector} or a @i{list}. @i{Sequences} can be created by the @i{function} @b{make-sequence}, as well as other @i{functions} that create @i{objects} of @i{types} that are @i{subtypes} of @b{sequence} (@i{e.g.}, @b{list}, @b{make-list}, @b{mapcar}, and @b{vector}). A @i{sequence function} @IGindex sequence function is a @i{function} defined by this specification or added as an extension by the @i{implementation} that operates on one or more @i{sequences}. Whenever a @i{sequence function} must construct and return a new @i{vector}, it always returns a @i{simple vector}. Similarly, any @i{strings} constructed will be @i{simple strings}. @format @group @noindent @w{ concatenate length remove } @w{ copy-seq map remove-duplicates } @w{ count map-into remove-if } @w{ count-if merge remove-if-not } @w{ count-if-not mismatch replace } @w{ delete notany reverse } @w{ delete-duplicates notevery search } @w{ delete-if nreverse some } @w{ delete-if-not nsubstitute sort } @w{ elt nsubstitute-if stable-sort } @w{ every nsubstitute-if-not subseq } @w{ fill position substitute } @w{ find position-if substitute-if } @w{ find-if position-if-not substitute-if-not } @w{ find-if-not reduce } @noindent @w{ Figure 17--1: Standardized Sequence Functions } @end group @end format @menu * General Restrictions on Parameters that must be Sequences:: @end menu @node General Restrictions on Parameters that must be Sequences, , Sequence Concepts, Sequence Concepts @subsection General Restrictions on Parameters that must be Sequences In general, @i{lists} (including @i{association lists} and @i{property lists}) that are treated as @i{sequences} must be @i{proper lists}. @c end of including concept-sequences @node Rules about Test Functions, Sequences Dictionary, Sequence Concepts, Sequences @section Rules about Test Functions @c including concept-tests @menu * Satisfying a Two-Argument Test:: * Satisfying a One-Argument Test:: @end menu @node Satisfying a Two-Argument Test, Satisfying a One-Argument Test, Rules about Test Functions, Rules about Test Functions @subsection Satisfying a Two-Argument Test When an @i{object} O is being considered iteratively against each @i{element} E_i of a @i{sequence} S by an @i{operator} F listed in Figure 17--2, it is sometimes useful to control the way in which the presence of O is tested in S is tested by F. This control is offered on the basis of a @i{function} designated with either a @t{:test} or @t{:test-not} @i{argument}. @format @group @noindent @w{ adjoin nset-exclusive-or search } @w{ assoc nsublis set-difference } @w{ count nsubst set-exclusive-or } @w{ delete nsubstitute sublis } @w{ find nunion subsetp } @w{ intersection position subst } @w{ member pushnew substitute } @w{ mismatch rassoc tree-equal } @w{ nintersection remove union } @w{ nset-difference remove-duplicates } @noindent @w{ Figure 17--2: Operators that have Two-Argument Tests to be Satisfied} @end group @end format The object O might not be compared directly to E_i. If a @t{:key} @i{argument} is provided, it is a @i{designator} for a @i{function} of one @i{argument} to be called with each E_i as an @i{argument}, and @i{yielding} an @i{object} Z_i to be used for comparison. (If there is no @t{:key} @i{argument}, Z_i is E_i.) The @i{function} designated by the @t{:key} @i{argument} is never called on O itself. However, if the function operates on multiple sequences (@i{e.g.}, as happens in @b{set-difference}), O will be the result of calling the @t{:key} function on an @i{element} of the other sequence. A @t{:test} @i{argument}, if supplied to F, is a @i{designator} for a @i{function} of two @i{arguments}, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to @i{satisfy the test} @IGindex satisfy the test if this @t{:test} @i{function} returns a @i{generalized boolean} representing @i{true}. A @t{:test-not} @i{argument}, if supplied to F, is @i{designator} for a @i{function} of two @i{arguments}, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to @i{satisfy the test} @IGindex satisfy the test if this @t{:test-not} @i{function} returns a @i{generalized boolean} representing @i{false}. If neither a @t{:test} nor a @t{:test-not} @i{argument} is supplied, it is as if a @t{:test} argument of @t{#'eql} was supplied. The consequences are unspecified if both a @t{:test} and a @t{:test-not} @i{argument} are supplied in the same @i{call} to F. @menu * Examples of Satisfying a Two-Argument Test:: @end menu @node Examples of Satisfying a Two-Argument Test, , Satisfying a Two-Argument Test, Satisfying a Two-Argument Test @subsubsection Examples of Satisfying a Two-Argument Test @example (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equal) @result{} (foo bar "BAR" "foo" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equalp) @result{} (foo bar "BAR" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string-equal) @result{} (bar "BAR" "bar") (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string=) @result{} (BAR "BAR" "foo" "bar") (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'eql) @result{} (1) (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'=) @result{} (1 1.0 #C(1.0 0.0)) (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test (complement #'=)) @result{} (1 1.0 #C(1.0 0.0)) (count 1 '((one 1) (uno 1) (two 2) (dos 2)) :key #'cadr) @result{} 2 (count 2.0 '(1 2 3) :test #'eql :key #'float) @result{} 1 (count "FOO" (list (make-pathname :name "FOO" :type "X") (make-pathname :name "FOO" :type "Y")) :key #'pathname-name :test #'equal) @result{} 2 @end example @node Satisfying a One-Argument Test, , Satisfying a Two-Argument Test, Rules about Test Functions @subsection Satisfying a One-Argument Test When using one of the @i{functions} in Figure 17--3, the elements E of a @i{sequence} S are filtered not on the basis of the presence or absence of an object O under a two @i{argument} @i{predicate}, as with the @i{functions} described in @ref{Satisfying a Two-Argument Test}, but rather on the basis of a one @i{argument} @i{predicate}. @format @group @noindent @w{ assoc-if member-if rassoc-if } @w{ assoc-if-not member-if-not rassoc-if-not } @w{ count-if nsubst-if remove-if } @w{ count-if-not nsubst-if-not remove-if-not } @w{ delete-if nsubstitute-if subst-if } @w{ delete-if-not nsubstitute-if-not subst-if-not } @w{ find-if position-if substitute-if } @w{ find-if-not position-if-not substitute-if-not } @noindent @w{ Figure 17--3: Operators that have One-Argument Tests to be Satisfied} @end group @end format The element E_i might not be considered directly. If a @t{:key} @i{argument} is provided, it is a @i{designator} for a @i{function} of one @i{argument} to be called with each E_i as an @i{argument}, and @i{yielding} an @i{object} Z_i to be used for comparison. (If there is no @t{:key} @i{argument}, Z_i is E_i.) @i{Functions} defined in this specification and having a name that ends in ``@t{-if}'' accept a first @i{argument} that is a @i{designator} for a @i{function} of one @i{argument}, Z_i. An E_i is said to @i{satisfy the test} @IGindex satisfy the test if this @t{:test} @i{function} returns a @i{generalized boolean} representing @i{true}. @i{Functions} defined in this specification and having a name that ends in ``@t{-if-not}'' accept a first @i{argument} that is a @i{designator} for a @i{function} of one @i{argument}, Z_i. An E_i is said to @i{satisfy the test} @IGindex satisfy the test if this @t{:test} @i{function} returns a @i{generalized boolean} representing @i{false}. @menu * Examples of Satisfying a One-Argument Test:: @end menu @node Examples of Satisfying a One-Argument Test, , Satisfying a One-Argument Test, Satisfying a One-Argument Test @subsubsection Examples of Satisfying a One-Argument Test @example (count-if #'zerop '(1 #C(0.0 0.0) 0 0.0d0 0.0s0 3)) @result{} 4 (remove-if-not #'symbolp '(0 1 2 3 4 5 6 7 8 9 A B C D E F)) @result{} (A B C D E F) (remove-if (complement #'symbolp) '(0 1 2 3 4 5 6 7 8 9 A B C D E F)) @result{} (A B C D E F) (count-if #'zerop '("foo" "" "bar" "" "" "baz" "quux") :key #'length) @result{} 3 @end example @c end of including concept-tests @node Sequences Dictionary, , Rules about Test Functions, Sequences @section Sequences Dictionary @c including dict-sequences @menu * sequence:: * copy-seq:: * elt:: * fill:: * make-sequence:: * subseq:: * map:: * map-into:: * reduce:: * count:: * length:: * reverse:: * sort:: * find:: * position:: * search:: * mismatch:: * replace:: * substitute:: * concatenate:: * merge:: * remove:: * remove-duplicates:: @end menu @node sequence, copy-seq, Sequences Dictionary, Sequences Dictionary @subsection sequence [System Class] @subsubheading Class Precedence List:: @b{sequence}, @b{t} @subsubheading Description:: @i{Sequences} are ordered collections of @i{objects}, called the @i{elements} of the @i{sequence}. The @i{types} @b{vector} and the @i{type} @b{list} are @i{disjoint} @i{subtypes} of @i{type} @b{sequence}, but are not necessarily an @i{exhaustive partition} of @i{sequence}. When viewing a @i{vector} as a @i{sequence}, only the @i{active} @i{elements} of that @i{vector} are considered @i{elements} of the @i{sequence}; that is, @i{sequence} operations respect the @i{fill pointer} when given @i{sequences} represented as @i{vectors}. @node copy-seq, elt, sequence, Sequences Dictionary @subsection copy-seq [Function] @code{copy-seq} @i{sequence} @result{} @i{copied-sequence} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{copied-sequence}---a @i{proper sequence}. @subsubheading Description:: Creates a copy of @i{sequence}. The @i{elements} of the new @i{sequence} are the @i{same} as the corresponding @i{elements} of the given @i{sequence}. If @i{sequence} is a @i{vector}, the result is a @i{fresh} @i{simple array} of @i{rank} one that has the same @i{actual array element type} as @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{fresh} @i{list}. @subsubheading Examples:: @example (setq str "a string") @result{} "a string" (equalp str (copy-seq str)) @result{} @i{true} (eql str (copy-seq str)) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{copy-list} @subsubheading Notes:: From a functional standpoint, @example (copy-seq x) @equiv{} (subseq x 0) @end example However, the programmer intent is typically very different in these two cases. @node elt, fill, copy-seq, Sequences Dictionary @subsection elt [Accessor] @code{elt} @i{sequence index} @result{} @i{object} (setf (@code{ elt} @i{sequence index}) new-object)@* @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{index}---a @i{valid sequence index} for @i{sequence}. @i{object}---an @i{object}. @i{new-object}---an @i{object}. @subsubheading Description:: @i{Accesses} the @i{element} of @i{sequence} specified by @i{index}. @subsubheading Examples:: @example (setq str (copy-seq "0123456789")) @result{} "0123456789" (elt str 6) @result{} #\6 (setf (elt str 0) #\#) @result{} #\# str @result{} "#123456789" @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. Should signal an error of @i{type} @b{type-error} if @i{index} is not a @i{valid sequence index} for @i{sequence}. @subsubheading See Also:: @ref{aref} , @ref{nth} , @ref{Compiler Terminology} @subsubheading Notes:: @b{aref} may be used to @i{access} @i{vector} elements that are beyond the @i{vector}'s @i{fill pointer}. @node fill, make-sequence, elt, Sequences Dictionary @subsection fill [Function] @code{fill} @i{sequence item @r{&key} start end} @result{} @i{sequence} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{item}---a @i{sequence}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @subsubheading Description:: Replaces the @i{elements} of @i{sequence} @i{bounded} by @i{start} and @i{end} with @i{item}. @subsubheading Examples:: @example (fill (list 0 1 2 3 4 5) '(444)) @result{} ((444) (444) (444) (444) (444) (444)) (fill (copy-seq "01234") #\e :start 3) @result{} "012ee" (setq x (vector 'a 'b 'c 'd 'e)) @result{} #(A B C D E) (fill x 'z :start 1 :end 3) @result{} #(A Z Z D E) x @result{} #(A Z Z D E) (fill x 'p) @result{} #(P P P P P) x @result{} #(P P P P P) @end example @subsubheading Side Effects:: @i{Sequence} is destructively modified. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. Should signal an error of @i{type} @b{type-error} if @i{start} is not a non-negative @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{end} is not a non-negative @i{integer} or @b{nil}. @subsubheading See Also:: @ref{replace} , @b{nsubstitute} @subsubheading Notes:: @t{(fill @i{sequence} @i{item}) @equiv{} (nsubstitute-if @i{item} (constantly t) @i{sequence})} @node make-sequence, subseq, fill, Sequences Dictionary @subsection make-sequence [Function] @code{make-sequence} @i{result-type size @r{&key} initial-element} @result{} @i{sequence} @subsubheading Arguments and Values:: @i{result-type}---a @b{sequence} @i{type specifier}. @i{size}---a non-negative @i{integer}. @i{initial-element}---an @i{object}. The default is @i{implementation-dependent}. @i{sequence}---a @i{proper sequence}. @subsubheading Description:: Returns a @i{sequence} of the type @i{result-type} and of length @i{size}, each of the @i{elements} of which has been initialized to @i{initial-element}. If the @i{result-type} is a @i{subtype} of @b{list}, the result will be a @i{list}. If the @i{result-type} is a @i{subtype} of @b{vector}, then if the implementation can determine the element type specified for the @i{result-type}, the element type of the resulting array is the result of @i{upgrading} that element type; or, if the implementation can determine that the element type is unspecified (or @t{*}), the element type of the resulting array is @b{t}; otherwise, an error is signaled. @subsubheading Examples:: @example (make-sequence 'list 0) @result{} () (make-sequence 'string 26 :initial-element #\.) @result{} ".........................." (make-sequence '(vector double-float) 2 :initial-element 1d0) @result{} #(1.0d0 1.0d0) @end example @example (make-sequence '(vector * 2) 3) should signal an error (make-sequence '(vector * 4) 3) should signal an error @end example @subsubheading Affected By:: The @i{implementation}. @subsubheading Exceptional Situations:: The consequences are unspecified if @i{initial-element} is not an @i{object} which can be stored in the resulting @i{sequence}. An error of @i{type} @b{type-error} must be signaled if the @i{result-type} is neither a @i{recognizable subtype} of @b{list}, nor a @i{recognizable subtype} of @b{vector}. An error of @i{type} @b{type-error} should be signaled if @i{result-type} specifies the number of elements and @i{size} is different from that number. @subsubheading See Also:: @ref{make-array} , @ref{make-list} @subsubheading Notes:: @example (make-sequence 'string 5) @equiv{} (make-string 5) @end example @node subseq, map, make-sequence, Sequences Dictionary @subsection subseq [Accessor] @code{subseq} @i{sequence start @r{&optional} end} @result{} @i{subsequence} (setf (@code{ subseq} @i{sequence start @r{&optional} end}) new-subsequence)@* @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The default for @i{end} is @b{nil}. @i{subsequence}---a @i{proper sequence}. @i{new-subsequence}---a @i{proper sequence}. @subsubheading Description:: @b{subseq} creates a @i{sequence} that is a copy of the subsequence of @i{sequence} @i{bounded} by @i{start} and @i{end}. @i{Start} specifies an offset into the original @i{sequence} and marks the beginning position of the subsequence. @i{end} marks the position following the last element of the subsequence. @b{subseq} always allocates a new @i{sequence} for a result; it never shares storage with an old @i{sequence}. The result subsequence is always of the same @i{type} as @i{sequence}. If @i{sequence} is a @i{vector}, the result is a @i{fresh} @i{simple array} of @i{rank} one that has the same @i{actual array element type} as @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{fresh} @i{list}. @b{setf} may be used with @b{subseq} to destructively replace @i{elements} of a subsequence with @i{elements} taken from a @i{sequence} of new values. If the subsequence and the new sequence are not of equal length, the shorter length determines the number of elements that are replaced. The remaining @i{elements} at the end of the longer sequence are not modified in the operation. @subsubheading Examples:: @example (setq str "012345") @result{} "012345" (subseq str 2) @result{} "2345" (subseq str 3 5) @result{} "34" (setf (subseq str 4) "abc") @result{} "abc" str @result{} "0123ab" (setf (subseq str 0 2) "A") @result{} "A" str @result{} "A123ab" @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. Should be prepared to signal an error of @i{type} @b{type-error} if @i{new-subsequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{replace} @node map, map-into, subseq, Sequences Dictionary @subsection map [Function] @code{map} @i{result-type function @r{&rest} sequences^+} @result{} @i{result} @subsubheading Arguments and Values:: @i{result-type} -- a @b{sequence} @i{type specifier}, or @b{nil}. @i{function}---a @i{function designator}. @i{function} must take as many arguments as there are @i{sequences}. @i{sequence}---a @i{proper sequence}. @i{result}---if @i{result-type} is a @i{type specifier} other than @b{nil}, then a @i{sequence} of the @i{type} it denotes; otherwise (if the @i{result-type} is @b{nil}), @b{nil}. @subsubheading Description:: Applies @i{function} to successive sets of arguments in which one argument is obtained from each @i{sequence}. The @i{function} is called first on all the elements with index @t{0}, then on all those with index @t{1}, and so on. The @i{result-type} specifies the @i{type} of the resulting @i{sequence}. @b{map} returns @b{nil} if @i{result-type} is @b{nil}. Otherwise, @b{map} returns a @i{sequence} such that element @t{j} is the result of applying @i{function} to element @t{j} of each of the @i{sequences}. The result @i{sequence} is as long as the shortest of the @i{sequences}. The consequences are undefined if the result of applying @i{function} to the successive elements of the @i{sequences} cannot be contained in a @i{sequence} of the @i{type} given by @i{result-type}. If the @i{result-type} is a @i{subtype} of @b{list}, the result will be a @i{list}. If the @i{result-type} is a @i{subtype} of @b{vector}, then if the implementation can determine the element type specified for the @i{result-type}, the element type of the resulting array is the result of @i{upgrading} that element type; or, if the implementation can determine that the element type is unspecified (or @t{*}), the element type of the resulting array is @b{t}; otherwise, an error is signaled. @subsubheading Examples:: @example (map 'string #'(lambda (x y) (char "01234567890ABCDEF" (mod (+ x y) 16))) '(1 2 3 4) '(10 9 8 7)) @result{} "AAAA" (setq seq '("lower" "UPPER" "" "123")) @result{} ("lower" "UPPER" "" "123") (map nil #'nstring-upcase seq) @result{} NIL seq @result{} ("LOWER" "UPPER" "" "123") (map 'list #'- '(1 2 3 4)) @result{} (-1 -2 -3 -4) (map 'string #'(lambda (x) (if (oddp x) #\1 #\0)) '(1 2 3 4)) @result{} "1010" @end example @example (map '(vector * 4) #'cons "abc" "de") should signal an error @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{type-error} must be signaled if the @i{result-type} is not a @i{recognizable subtype} of @b{list}, not a @i{recognizable subtype} of @b{vector}, and not @b{nil}. Should be prepared to signal an error of @i{type} @b{type-error} if any @i{sequence} is not a @i{proper sequence}. An error of @i{type} @b{type-error} should be signaled if @i{result-type} specifies the number of elements and the minimum length of the @i{sequences} is different from that number. @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @node map-into, reduce, map, Sequences Dictionary @subsection map-into [Function] @code{map-into} @i{result-sequence function @r{&rest} sequences} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @i{result-sequence}---a @i{proper sequence}. @i{function}---a @i{designator} for a @i{function} of as many @i{arguments} as there are @i{sequences}. @i{sequence}---a @i{proper sequence}. @subsubheading Description:: Destructively modifies @i{result-sequence} to contain the results of applying @i{function} to each element in the argument @i{sequences} in turn. @i{result-sequence} and each element of @i{sequences} can each be either a @i{list} or a @i{vector}. If @i{result-sequence} and each element of @i{sequences} are not all the same length, the iteration terminates when the shortest @i{sequence} (of any of the @i{sequences} or the @i{result-sequence}) is exhausted. If @i{result-sequence} is a @i{vector} with a @i{fill pointer}, the @i{fill pointer} is ignored when deciding how many iterations to perform, and afterwards the @i{fill pointer} is set to the number of times @i{function} was applied. If @i{result-sequence} is longer than the shortest element of @i{sequences}, extra elements at the end of @i{result-sequence} are left unchanged. If @i{result-sequence} is @b{nil}, @b{map-into} immediately returns @b{nil}, since @b{nil} is a @i{sequence} of length zero. If @i{function} has side effects, it can count on being called first on all of the elements with index 0, then on all of those numbered 1, and so on. @subsubheading Examples:: @example (setq a (list 1 2 3 4) b (list 10 10 10 10)) @result{} (10 10 10 10) (map-into a #'+ a b) @result{} (11 12 13 14) a @result{} (11 12 13 14) b @result{} (10 10 10 10) (setq k '(one two three)) @result{} (ONE TWO THREE) (map-into a #'cons k a) @result{} ((ONE . 11) (TWO . 12) (THREE . 13) 14) (map-into a #'gensym) @result{} (#:G9090 #:G9091 #:G9092 #:G9093) a @result{} (#:G9090 #:G9091 #:G9092 #:G9093) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{result-sequence} is not a @i{proper sequence}. Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading Notes:: @b{map-into} differs from @b{map} in that it modifies an existing @i{sequence} rather than creating a new one. In addition, @b{map-into} can be called with only two arguments, while @b{map} requires at least three arguments. @b{map-into} could be defined by: @example (defun map-into (result-sequence function &rest sequences) (loop for index below (apply #'min (length result-sequence) (mapcar #'length sequences)) do (setf (elt result-sequence index) (apply function (mapcar #'(lambda (seq) (elt seq index)) sequences)))) result-sequence) @end example @node reduce, count, map-into, Sequences Dictionary @subsection reduce [Function] @code{reduce} @i{function sequence @r{&key} key from-end start end initial-value} @result{} @i{result} @subsubheading Arguments and Values:: @i{function}---a @i{designator} for a @i{function} that might be called with either zero or two @i{arguments}. @i{sequence}---a @i{proper sequence}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{initial-value}---an @i{object}. @i{result}---an @i{object}. @subsubheading Description:: @b{reduce} uses a binary operation, @i{function}, to combine the @i{elements} of @i{sequence} @i{bounded} by @i{start} and @i{end}. The @i{function} must accept as @i{arguments} two @i{elements} of @i{sequence} or the results from combining those @i{elements}. The @i{function} must also be able to accept no arguments. If @i{key} is supplied, it is used is used to extract the values to reduce. The @i{key} function is applied exactly once to each element of @i{sequence} in the order implied by the reduction order but not to the value of @i{initial-value}, if supplied. The @i{key} function typically returns part of the @i{element} of @i{sequence}. If @i{key} is not supplied or is @b{nil}, the @i{sequence} @i{element} itself is used. The reduction is left-associative, unless @i{from-end} is @i{true} in which case it is right-associative. If @i{initial-value} is supplied, it is logically placed before the subsequence (or after it if @i{from-end} is @i{true}) and included in the reduction operation. In the normal case, the result of @b{reduce} is the combined result of @i{function}'s being applied to successive pairs of @i{elements} of @i{sequence}. If the subsequence contains exactly one @i{element} and no @i{initial-value} is given, then that @i{element} is returned and @i{function} is not called. If the subsequence is empty and an @i{initial-value} is given, then the @i{initial-value} is returned and @i{function} is not called. If the subsequence is empty and no @i{initial-value} is given, then the @i{function} is called with zero arguments, and @b{reduce} returns whatever @i{function} does. This is the only case where the @i{function} is called with other than two arguments. @subsubheading Examples:: @example (reduce #'* '(1 2 3 4 5)) @result{} 120 (reduce #'append '((1) (2)) :initial-value '(i n i t)) @result{} (I N I T 1 2) (reduce #'append '((1) (2)) :from-end t :initial-value '(i n i t)) @result{} (1 2 I N I T) (reduce #'- '(1 2 3 4)) @equiv{} (- (- (- 1 2) 3) 4) @result{} -8 (reduce #'- '(1 2 3 4) :from-end t) ;Alternating sum. @equiv{} (- 1 (- 2 (- 3 4))) @result{} -2 (reduce #'+ '()) @result{} 0 (reduce #'+ '(3)) @result{} 3 (reduce #'+ '(foo)) @result{} FOO (reduce #'list '(1 2 3 4)) @result{} (((1 2) 3) 4) (reduce #'list '(1 2 3 4) :from-end t) @result{} (1 (2 (3 4))) (reduce #'list '(1 2 3 4) :initial-value 'foo) @result{} ((((foo 1) 2) 3) 4) (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo) @result{} (1 (2 (3 (4 foo)))) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @node count, length, reduce, Sequences Dictionary @subsection count, count-if, count-if-not [Function] @code{count} @i{item sequence @r{&key} from-end start end key test test-not} @result{} @i{n} @code{count-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} @code{count-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{sequence}---a @i{proper sequence}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{n}---a non-negative @i{integer} less than or equal to the @i{length} of @i{sequence}. @subsubheading Description:: @b{count}, @b{count-if}, and @b{count-if-not} count and return the number of @i{elements} in the @i{sequence} @i{bounded} by @i{start} and @i{end} that @i{satisfy the test}. The @i{from-end} has no direct effect on the result. However, if @i{from-end} is @i{true}, the @i{elements} of @i{sequence} will be supplied as @i{arguments} to the @i{test}, @i{test-not}, and @i{key} in reverse order, which may change the side-effects, if any, of those functions. @subsubheading Examples:: @example (count #\a "how many A's are there in here?") @result{} 2 (count-if-not #'oddp '((1) (2) (3) (4)) :key #'car) @result{} 2 (count-if #'upper-case-p "The Crying of Lot 49" :start 4) @result{} 2 @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{Rules about Test Functions}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. The @i{function} @b{count-if-not} is deprecated. @node length, reverse, count, Sequences Dictionary @subsection length [Function] @code{length} @i{sequence} @result{} @i{n} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{n}---a non-negative @i{integer}. @subsubheading Description:: Returns the number of @i{elements} in @i{sequence}. If @i{sequence} is a @i{vector} with a @i{fill pointer}, the active length as specified by the @i{fill pointer} is returned. @subsubheading Examples:: @example (length "abc") @result{} 3 (setq str (make-array '(3) :element-type 'character :initial-contents "abc" :fill-pointer t)) @result{} "abc" (length str) @result{} 3 (setf (fill-pointer str) 2) @result{} 2 (length str) @result{} 2 @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{list-length} , @b{sequence} @node reverse, sort, length, Sequences Dictionary @subsection reverse, nreverse [Function] @code{reverse} @i{sequence} @result{} @i{reversed-sequence} @code{nreverse} @i{sequence} @result{} @i{reversed-sequence} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{reversed-sequence}---a @i{sequence}. @subsubheading Description:: @b{reverse} and @b{nreverse} return a new @i{sequence} of the same kind as @i{sequence}, containing the same @i{elements}, but in reverse order. @b{reverse} and @b{nreverse} differ in that @b{reverse} always creates and returns a new @i{sequence}, whereas @b{nreverse} might modify and return the given @i{sequence}. @b{reverse} never modifies the given @i{sequence}. For @b{reverse}, if @i{sequence} is a @i{vector}, the result is a @i{fresh} @i{simple array} of @i{rank} one that has the same @i{actual array element type} as @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{fresh} @i{list}. For @b{nreverse}, if @i{sequence} is a @i{vector}, the result is a @i{vector} that has the same @i{actual array element type} as @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{list}. For @b{nreverse}, @i{sequence} might be destroyed and re-used to produce the result. The result might or might not be @i{identical} to @i{sequence}. Specifically, when @i{sequence} is a @i{list}, @b{nreverse} is permitted to @b{setf} any part, @b{car} or @b{cdr}, of any @i{cons} that is part of the @i{list structure} of @i{sequence}. When @i{sequence} is a @i{vector}, @b{nreverse} is permitted to re-order the elements of @i{sequence} in order to produce the resulting @i{vector}. @subsubheading Examples:: @example (setq str "abc") @result{} "abc" (reverse str) @result{} "cba" str @result{} "abc" (setq str (copy-seq str)) @result{} "abc" (nreverse str) @result{} "cba" str @result{} @i{implementation-dependent} (setq l (list 1 2 3)) @result{} (1 2 3) (nreverse l) @result{} (3 2 1) l @result{} @i{implementation-dependent} @end example @subsubheading Side Effects:: @b{nreverse} might either create a new @i{sequence}, modify the argument @i{sequence}, or both. (@b{reverse} does not modify @i{sequence}.) @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @node sort, find, reverse, Sequences Dictionary @subsection sort, stable-sort [Function] @code{sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} @code{stable-sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{predicate}---a @i{designator} for a @i{function} of two arguments that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{sorted-sequence}---a @i{sequence}. @subsubheading Description:: @b{sort} and @b{stable-sort} destructively sort @i{sequences} according to the order determined by the @i{predicate} function. If @i{sequence} is a @i{vector}, the result is a @i{vector} that has the same @i{actual array element type} as @i{sequence}. The result might or might not be simple, and might or might not be @i{identical} to @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{list}. @b{sort} determines the relationship between two elements by giving keys extracted from the elements to the @i{predicate}. The first argument to the @i{predicate} function is the part of one element of @i{sequence} extracted by the @i{key} function (if supplied); the second argument is the part of another element of @i{sequence} extracted by the @i{key} function (if supplied). @i{Predicate} should return @i{true} if and only if the first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then the @i{predicate} should return @i{false}. The argument to the @i{key} function is the @i{sequence} element. The return value of the @i{key} function becomes an argument to @i{predicate}. If @i{key} is not supplied or @b{nil}, the @i{sequence} element itself is used. There is no guarantee on the number of times the @i{key} will be called. If the @i{key} and @i{predicate} always return, then the sorting operation will always terminate, producing a @i{sequence} containing the same @i{elements} as @i{sequence} (that is, the result is a permutation of @i{sequence}). This is guaranteed even if the @i{predicate} does not really consistently represent a total order (in which case the @i{elements} will be scrambled in some unpredictable way, but no @i{element} will be lost). If the @i{key} consistently returns meaningful keys, and the @i{predicate} does reflect some total ordering criterion on those keys, then the @i{elements} of the @i{sorted-sequence} will be properly sorted according to that ordering. The sorting operation performed by @b{sort} is not guaranteed stable. Elements considered equal by the @i{predicate} might or might not stay in their original order. The @i{predicate} is assumed to consider two elements @t{x} and @t{y} to be equal if @t{(funcall @i{predicate} @i{x} @i{y})} and @t{(funcall @i{predicate} @i{y} @i{x})} are both @i{false}. @b{stable-sort} guarantees stability. The sorting operation can be destructive in all cases. In the case of a @i{vector} argument, this is accomplished by permuting the elements in place. In the case of a @i{list}, the @i{list} is destructively reordered in the same manner as for @b{nreverse}. @subsubheading Examples:: @example (setq tester (copy-seq "lkjashd")) @result{} "lkjashd" (sort tester #'char-lessp) @result{} "adhjkls" (setq tester (list '(1 2 3) '(4 5 6) '(7 8 9))) @result{} ((1 2 3) (4 5 6) (7 8 9)) (sort tester #'> :key #'car) @result{} ((7 8 9) (4 5 6) (1 2 3)) (setq tester (list 1 2 3 4 5 6 7 8 9 0)) @result{} (1 2 3 4 5 6 7 8 9 0) (stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y)))) @result{} (1 3 5 7 9 2 4 6 8 0) (sort (setq committee-data (vector (list (list "JonL" "White") "Iteration") (list (list "Dick" "Waters") "Iteration") (list (list "Dick" "Gabriel") "Objects") (list (list "Kent" "Pitman") "Conditions") (list (list "Gregor" "Kiczales") "Objects") (list (list "David" "Moon") "Objects") (list (list "Kathy" "Chapman") "Editorial") (list (list "Larry" "Masinter") "Cleanup") (list (list "Sandra" "Loosemore") "Compiler"))) #'string-lessp :key #'cadar) @result{} #((("Kathy" "Chapman") "Editorial") (("Dick" "Gabriel") "Objects") (("Gregor" "Kiczales") "Objects") (("Sandra" "Loosemore") "Compiler") (("Larry" "Masinter") "Cleanup") (("David" "Moon") "Objects") (("Kent" "Pitman") "Conditions") (("Dick" "Waters") "Iteration") (("JonL" "White") "Iteration")) ;; Note that individual alphabetical order within `committees' ;; is preserved. (setq committee-data (stable-sort committee-data #'string-lessp :key #'cadr)) @result{} #((("Larry" "Masinter") "Cleanup") (("Sandra" "Loosemore") "Compiler") (("Kent" "Pitman") "Conditions") (("Kathy" "Chapman") "Editorial") (("Dick" "Waters") "Iteration") (("JonL" "White") "Iteration") (("Dick" "Gabriel") "Objects") (("Gregor" "Kiczales") "Objects") (("David" "Moon") "Objects")) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{merge} , @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects}, @ref{Destructive Operations} @node find, position, sort, Sequences Dictionary @subsection find, find-if, find-if-not [Function] @code{find} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{element} @code{find-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} @code{find-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{sequence}---a @i{proper sequence}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{element}---an @i{element} of the @i{sequence}, or @b{nil}. @subsubheading Description:: @b{find}, @b{find-if}, and @b{find-if-not} each search for an @i{element} of the @i{sequence} @i{bounded} by @i{start} and @i{end} that @i{satisfies the predicate} @i{predicate} or that @i{satisfies the test} @i{test} or @i{test-not}, as appropriate. If @i{from-end} is @i{true}, then the result is the rightmost @i{element} that @i{satisfies the test}. If the @i{sequence} contains an @i{element} that @i{satisfies the test}, then the leftmost or rightmost @i{sequence} element, depending on @i{from-end}, is returned; otherwise @b{nil} is returned. @subsubheading Examples:: @example (find #\d "here are some letters that can be looked at" :test #'char>) @result{} #\Space (find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) @result{} 3 (find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2) @result{} NIL @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{position} , @ref{Rules about Test Functions}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. The @i{function} @b{find-if-not} is deprecated. @node position, search, find, Sequences Dictionary @subsection position, position-if, position-if-not [Function] @code{position} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{position} @code{position-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} @code{position-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{sequence}---a @i{proper sequence}. @i{predicate}---a @i{designator} for a @i{function} of one argument that returns a @i{generalized boolean}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{position}---a @i{bounding index} of @i{sequence}, or @b{nil}. @subsubheading Description:: @b{position}, @b{position-if}, and @b{position-if-not} each search @i{sequence} for an @i{element} that @i{satisfies the test}. The @i{position} returned is the index within @i{sequence} of the leftmost (if @i{from-end} is @i{true}) or of the rightmost (if @i{from-end} is @i{false}) @i{element} that @i{satisfies the test}; otherwise @b{nil} is returned. The index returned is relative to the left-hand end of the entire @i{sequence}, regardless of the value of @i{start}, @i{end}, or @i{from-end}. @subsubheading Examples:: @example (position #\a "baobab" :from-end t) @result{} 4 (position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) @result{} 2 (position 595 '()) @result{} NIL (position-if-not #'integerp '(1 2 3 4 5.0)) @result{} 4 @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{find} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. The @i{function} @b{position-if-not} is deprecated. @node search, mismatch, position, Sequences Dictionary @subsection search [Function] @code{search} @i{sequence-1 sequence-2 @r{&key} from-end test test-not key start1 start2 end1 end2}@* @result{} @i{position} @subsubheading Arguments and Values:: @i{Sequence-1}---a @i{sequence}. @i{Sequence-2}---a @i{sequence}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{start1}, @i{end1}---@i{bounding index designators} of @i{sequence-1}. The defaults for @i{start1} and @i{end1} are @t{0} and @b{nil}, respectively. @i{start2}, @i{end2}---@i{bounding index designators} of @i{sequence-2}. The defaults for @i{start2} and @i{end2} are @t{0} and @b{nil}, respectively. @i{position}---a @i{bounding index} of @i{sequence-2}, or @b{nil}. @subsubheading Description:: Searches @i{sequence-2} for a subsequence that matches @i{sequence-1}. The implementation may choose to search @i{sequence-2} in any order; there is no guarantee on the number of times the test is made. For example, when @i{start-end} is @i{true}, the @i{sequence} might actually be searched from left to right instead of from right to left (but in either case would return the rightmost matching subsequence). If the search succeeds, @b{search} returns the offset into @i{sequence-2} of the first element of the leftmost or rightmost matching subsequence, depending on @i{from-end}; otherwise @b{search} returns @b{nil}. If @i{from-end} is @i{true}, the index of the leftmost element of the rightmost matching subsequence is returned. @subsubheading Examples:: @example (search "dog" "it's a dog's life") @result{} 7 (search '(0 1) '(2 4 6 1 3 5) :key #'oddp) @result{} 2 @end example @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. @node mismatch, replace, search, Sequences Dictionary @subsection mismatch [Function] @code{mismatch} @i{sequence-1 sequence-2 @r{&key} from-end test test-not key start1 start2 end1 end2}@* @result{} @i{position} @subsubheading Arguments and Values:: @i{Sequence-1}---a @i{sequence}. @i{Sequence-2}---a @i{sequence}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start1}, @i{end1}---@i{bounding index designators} of @i{sequence-1}. The defaults for @i{start1} and @i{end1} are @t{0} and @b{nil}, respectively. @i{start2}, @i{end2}---@i{bounding index designators} of @i{sequence-2}. The defaults for @i{start2} and @i{end2} are @t{0} and @b{nil}, respectively. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{position}---a @i{bounding index} of @i{sequence-1}, or @b{nil}. @subsubheading Description:: The specified subsequences of @i{sequence-1} and @i{sequence-2} are compared element-wise. The @i{key} argument is used for both the @i{sequence-1} and the @i{sequence-2}. If @i{sequence-1} and @i{sequence-2} are of equal length and match in every element, the result is @i{false}. Otherwise, the result is a non-negative @i{integer}, the index within @i{sequence-1} of the leftmost or rightmost position, depending on @i{from-end}, at which the two subsequences fail to match. If one subsequence is shorter than and a matching prefix of the other, the result is the index relative to @i{sequence-1} beyond the last position tested. If @i{from-end} is @i{true}, then one plus the index of the rightmost position in which the @i{sequences} differ is returned. In effect, the subsequences are aligned at their right-hand ends; then, the last elements are compared, the penultimate elements, and so on. The index returned is an index relative to @i{sequence-1}. @subsubheading Examples:: @example (mismatch "abcd" "ABCDE" :test #'char-equal) @result{} 4 (mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t) @result{} 3 (mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp) @result{} NIL (mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4) @result{} NIL @end example @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. @node replace, substitute, mismatch, Sequences Dictionary @subsection replace [Function] @code{replace} @i{sequence-1 sequence-2 @r{&key} start1 end1 start2 end2} @result{} @i{sequence-1} @subsubheading Arguments and Values:: @i{sequence-1}---a @i{sequence}. @i{sequence-2}---a @i{sequence}. @i{start1}, @i{end1}---@i{bounding index designators} of @i{sequence-1}. The defaults for @i{start1} and @i{end1} are @t{0} and @b{nil}, respectively. @i{start2}, @i{end2}---@i{bounding index designators} of @i{sequence-2}. The defaults for @i{start2} and @i{end2} are @t{0} and @b{nil}, respectively. @subsubheading Description:: Destructively modifies @i{sequence-1} by replacing the @i{elements} of @i{subsequence-1} @i{bounded} by @i{start1} and @i{end1} with the @i{elements} of @i{subsequence-2} @i{bounded} by @i{start2} and @i{end2}. @i{Sequence-1} is destructively modified by copying successive @i{elements} into it from @i{sequence-2}. @i{Elements} of the subsequence of @i{sequence-2} @i{bounded} by @i{start2} and @i{end2} are copied into the subsequence of @i{sequence-1} @i{bounded} by @i{start1} and @i{end1}. If these subsequences are not of the same length, then the shorter length determines how many @i{elements} are copied; the extra @i{elements} near the end of the longer subsequence are not involved in the operation. The number of elements copied can be expressed as: @example (min (- @i{end1} @i{start1}) (- @i{end2} @i{start2})) @end example If @i{sequence-1} and @i{sequence-2} are the @i{same} @i{object} and the region being modified overlaps the region being copied from, then it is as if the entire source region were copied to another place and only then copied back into the target region. However, if @i{sequence-1} and @i{sequence-2} are not the same, but the region being modified overlaps the region being copied from (perhaps because of shared list structure or displaced @i{arrays}), then after the @b{replace} operation the subsequence of @i{sequence-1} being modified will have unpredictable contents. It is an error if the elements of @i{sequence-2} are not of a @i{type} that can be stored into @i{sequence-1}. @subsubheading Examples:: @example (replace "abcdefghij" "0123456789" :start1 4 :end1 7 :start2 4) @result{} "abcd456hij" (setq lst "012345678") @result{} "012345678" (replace lst lst :start1 2 :start2 0) @result{} "010123456" lst @result{} "010123456" @end example @subsubheading Side Effects:: The @i{sequence-1} is modified. @subsubheading See Also:: @ref{fill} @node substitute, concatenate, replace, Sequences Dictionary @subsection substitute, substitute-if, substitute-if-not, @subheading nsubstitute, nsubstitute-if, nsubstitute-if-not @flushright @i{[Function]} @end flushright @code{substitute} @i{newitem olditem sequence @r{&key} from-end test test-not start end count key}@* @result{} @i{result-sequence} @code{substitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{result-sequence} @code{substitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{result-sequence} @code{nsubstitute} @i{newitem olditem sequence @r{&key} from-end test test-not start end count key}@* @result{} @i{sequence} @code{nsubstitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{sequence} @code{nsubstitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{sequence} @subsubheading Arguments and Values:: @i{newitem}---an @i{object}. @i{olditem}---an @i{object}. @i{sequence}---a @i{proper sequence}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{count}---an @i{integer} or @b{nil}. The default is @b{nil}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-sequence}---a @i{sequence}. @subsubheading Description:: @b{substitute}, @b{substitute-if}, and @b{substitute-if-not} return a copy of @i{sequence} in which each @i{element} that @i{satisfies the test} has been replaced with @i{newitem}. @b{nsubstitute}, @b{nsubstitute-if}, and @b{nsubstitute-if-not} are like @b{substitute}, @b{substitute-if}, and @b{substitute-if-not} respectively, but they may modify @i{sequence}. If @i{sequence} is a @i{vector}, the result is a @i{vector} that has the same @i{actual array element type} as @i{sequence}. The result might or might not be simple, and might or might not be @i{identical} to @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{list}. @i{Count}, if supplied, limits the number of elements altered; if more than @i{count} @i{elements} @i{satisfy the test}, then of these @i{elements} only the leftmost or rightmost, depending on @i{from-end}, are replaced, as many as specified by @i{count}. If @i{count} is supplied and negative, the behavior is as if zero had been supplied instead. If @i{count} is @b{nil}, all matching items are affected. Supplying a @i{from-end} of @i{true} matters only when the @i{count} is provided (and @i{non-nil}); in that case, only the rightmost @i{count} @i{elements} @i{satisfying the test} are removed (instead of the leftmost). @i{predicate}, @i{test}, and @i{test-not} might be called more than once for each @i{sequence} @i{element}, and their side effects can happen in any order. The result of all these functions is a @i{sequence} of the same @i{type} as @i{sequence} that has the same elements except that those in the subsequence @i{bounded} by @i{start} and @i{end} and @i{satisfying the test} have been replaced by @i{newitem}. @b{substitute}, @b{substitute-if}, and @b{substitute-if-not} return a @i{sequence} which can share with @i{sequence} or may be @i{identical} to the input @i{sequence} if no elements need to be changed. @b{nsubstitute} and @b{nsubstitute-if} are required to @b{setf} any @b{car} (if @i{sequence} is a @i{list}) or @b{aref} (if @i{sequence} is a @i{vector}) of @i{sequence} that is required to be replaced with @i{newitem}. If @i{sequence} is a @i{list}, none of the @i{cdrs} of the top-level @i{list} can be modified. @subsubheading Examples:: @example (substitute #\. #\SPACE "0 2 4 6") @result{} "0.2.4.6" (substitute 9 4 '(1 2 4 1 3 4 5)) @result{} (1 2 9 1 3 9 5) (substitute 9 4 '(1 2 4 1 3 4 5) :count 1) @result{} (1 2 9 1 3 4 5) (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) @result{} (1 2 4 1 3 9 5) (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) @result{} (9 9 4 9 3 4 5) (substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car) @result{} ((1) (2) (3) 0) (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) @result{} (9 2 4 9 9 4 9) (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) @result{} (1 2 4 1 3 9 5) (setq some-things (list 'a 'car 'b 'cdr 'c)) @result{} (A CAR B CDR C) (nsubstitute-if "function was here" #'fboundp some-things :count 1 :from-end t) @result{} (A CAR B "function was here" C) some-things @result{} (A CAR B "function was here" C) (setq alpha-tester (copy-seq "ab ")) @result{} "ab " (nsubstitute-if-not #\z #'alpha-char-p alpha-tester) @result{} "abz" alpha-tester @result{} "abz" @end example @subsubheading Side Effects:: @b{nsubstitute}, @b{nsubstitute-if}, and @b{nsubstitute-if-not} modify @i{sequence}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{subst} , @b{nsubst}, @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. The functions @b{substitute-if-not} and @b{nsubstitute-if-not} are deprecated. @b{nsubstitute} and @b{nsubstitute-if} can be used in for-effect-only positions in code. Because the side-effecting variants (@i{e.g.}, @b{nsubstitute}) potentially change the path that is being traversed, their effects in the presence of shared or circular structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: @example (defun test-it (fn) (let ((x (cons 'b nil))) (rplacd x x) (funcall fn 'a 'b x :count 1))) (test-it #'substitute) @result{} (A . #1=(B . #1#)) (test-it #'nsubstitute) @result{} (A . #1#) @end example @node concatenate, merge, substitute, Sequences Dictionary @subsection concatenate [Function] @code{concatenate} @i{result-type @r{&rest} sequences} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @i{result-type}---a @b{sequence} @i{type specifier}. @i{sequences}---a @i{sequence}. @i{result-sequence}---a @i{proper sequence} of @i{type} @i{result-type}. @subsubheading Description:: @b{concatenate} returns a @i{sequence} that contains all the individual elements of all the @i{sequences} in the order that they are supplied. The @i{sequence} is of type @i{result-type}, which must be a @i{subtype} of @i{type} @b{sequence}. All of the @i{sequences} are copied from; the result does not share any structure with any of the @i{sequences}. Therefore, if only one @i{sequence} is provided and it is of type @i{result-type}, @b{concatenate} is required to copy @i{sequence} rather than simply returning it. It is an error if any element of the @i{sequences} cannot be an element of the @i{sequence} result. [Reviewer Note by Barmar: Should signal?] If the @i{result-type} is a @i{subtype} of @b{list}, the result will be a @i{list}. If the @i{result-type} is a @i{subtype} of @b{vector}, then if the implementation can determine the element type specified for the @i{result-type}, the element type of the resulting array is the result of @i{upgrading} that element type; or, if the implementation can determine that the element type is unspecified (or @t{*}), the element type of the resulting array is @b{t}; otherwise, an error is signaled. @subsubheading Examples:: @example (concatenate 'string "all" " " "together" " " "now") @result{} "all together now" (concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011) @result{} (#\A #\B #\C D E F 1 2 3 1 0 1 1) (concatenate 'list) @result{} NIL @end example @example (concatenate '(vector * 2) "a" "bc") should signal an error @end example @subsubheading Exceptional Situations:: An error is signaled if the @i{result-type} is neither a @i{recognizable subtype} of @b{list}, nor a @i{recognizable subtype} of @b{vector}. An error of @i{type} @b{type-error} should be signaled if @i{result-type} specifies the number of elements and the sum of @i{sequences} is different from that number. @subsubheading See Also:: @ref{append} @node merge, remove, concatenate, Sequences Dictionary @subsection merge [Function] @code{merge} @i{result-type sequence-1 sequence-2 predicate @r{&key} key} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @i{result-type}---a @b{sequence} @i{type specifier}. @i{sequence-1}---a @i{sequence}. @i{sequence-2}---a @i{sequence}. @i{predicate}---a @i{designator} for a @i{function} of two arguments that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-sequence}---a @i{proper sequence} of @i{type} @i{result-type}. @subsubheading Description:: Destructively merges @i{sequence-1} with @i{sequence-2} according to an order determined by the @i{predicate}. @b{merge} determines the relationship between two elements by giving keys extracted from the sequence elements to the @i{predicate}. The first argument to the @i{predicate} function is an element of @i{sequence-1} as returned by the @i{key} (if supplied); the second argument is an element of @i{sequence-2} as returned by the @i{key} (if supplied). @i{Predicate} should return @i{true} if and only if its first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then @i{predicate} should return @i{false}. @b{merge} considers two elements @t{x} and @t{y} to be equal if @t{(funcall predicate x y)} and @t{(funcall predicate y x)} both @i{yield} @i{false}. The argument to the @i{key} is the @i{sequence} element. Typically, the return value of the @i{key} becomes the argument to @i{predicate}. If @i{key} is not supplied or @b{nil}, the sequence element itself is used. The @i{key} may be executed more than once for each @i{sequence} @i{element}, and its side effects may occur in any order. If @i{key} and @i{predicate} return, then the merging operation will terminate. The result of merging two @i{sequences} @t{x} and @t{y} is a new @i{sequence} of type @i{result-type} @t{z}, such that the length of @t{z} is the sum of the lengths of @t{x} and @t{y}, and @t{z} contains all the elements of @t{x} and @t{y}. If @t{x1} and @t{x2} are two elements of @t{x}, and @t{x1} precedes @t{x2} in @t{x}, then @t{x1} precedes @t{x2} in @t{z}, and similarly for elements of @t{y}. In short, @t{z} is an interleaving of @t{x} and @t{y}. If @t{x} and @t{y} were correctly sorted according to the @i{predicate}, then @t{z} will also be correctly sorted. If @t{x} or @t{y} is not so sorted, then @t{z} will not be sorted, but will nevertheless be an interleaving of @t{x} and @t{y}. The merging operation is guaranteed stable; if two or more elements are considered equal by the @i{predicate}, then the elements from @i{sequence-1} will precede those from @i{sequence-2} in the result. @i{sequence-1} and/or @i{sequence-2} may be destroyed. If the @i{result-type} is a @i{subtype} of @b{list}, the result will be a @i{list}. If the @i{result-type} is a @i{subtype} of @b{vector}, then if the implementation can determine the element type specified for the @i{result-type}, the element type of the resulting array is the result of @i{upgrading} that element type; or, if the implementation can determine that the element type is unspecified (or @t{*}), the element type of the resulting array is @b{t}; otherwise, an error is signaled. @subsubheading Examples:: @example (setq test1 (list 1 3 4 6 7)) (setq test2 (list 2 5 8)) (merge 'list test1 test2 #'<) @result{} (1 2 3 4 5 6 7 8) (setq test1 (copy-seq "BOY")) (setq test2 (copy-seq :nosy")) (merge 'string test1 test2 #'char-lessp) @result{} "BnOosYy" (setq test1 (vector ((red . 1) (blue . 4)))) (setq test2 (vector ((yellow . 2) (green . 7)))) (merge 'vector test1 test2 #'< :key #'cdr) @result{} #((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7)) @end example @example (merge '(vector * 4) '(1 5) '(2 4 6) #'<) should signal an error @end example @subsubheading Exceptional Situations:: An error must be signaled if the @i{result-type} is neither a @i{recognizable subtype} of @b{list}, nor a @i{recognizable subtype} of @b{vector}. An error of @i{type} @b{type-error} should be signaled if @i{result-type} specifies the number of elements and the sum of the lengths of @i{sequence-1} and @i{sequence-2} is different from that number. @subsubheading See Also:: @ref{sort} , @b{stable-sort}, @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @node remove, remove-duplicates, merge, Sequences Dictionary @subsection remove, remove-if, remove-if-not, @subheading delete, delete-if, delete-if-not @flushright @i{[Function]} @end flushright @code{remove} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} @code{remove-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} @code{remove-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} @code{delete} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} @code{delete-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} @code{delete-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{sequence}---a @i{proper sequence}. @i{test}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{count}---an @i{integer} or @b{nil}. The default is @b{nil}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-sequence}---a @i{sequence}. @subsubheading Description:: @b{remove}, @b{remove-if}, and @b{remove-if-not} return a @i{sequence} from which the elements that @i{satisfy the test} have been removed. @b{delete}, @b{delete-if}, and @b{delete-if-not} are like @b{remove}, @b{remove-if}, and @b{remove-if-not} respectively, but they may modify @i{sequence}. If @i{sequence} is a @i{vector}, the result is a @i{vector} that has the same @i{actual array element type} as @i{sequence}. The result might or might not be simple, and might or might not be @i{identical} to @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{list}. Supplying a @i{from-end} of @i{true} matters only when the @i{count} is provided; in that case only the rightmost @i{count} elements @i{satisfying the test} are deleted. @i{Count}, if supplied, limits the number of elements removed or deleted; if more than @i{count} elements @i{satisfy the test}, then of these elements only the leftmost or rightmost, depending on @i{from-end}, are deleted or removed, as many as specified by @i{count}. If @i{count} is supplied and negative, the behavior is as if zero had been supplied instead. If @i{count} is @b{nil}, all matching items are affected. For all these functions, elements not removed or deleted occur in the same order in the result as they did in @i{sequence}. @b{remove}, @b{remove-if}, @b{remove-if-not} return a @i{sequence} of the same @i{type} as @i{sequence} that has the same elements except that those in the subsequence @i{bounded} by @i{start} and @i{end} and @i{satisfying the test} have been removed. This is a non-destructive operation. If any elements need to be removed, the result will be a copy. The result of @b{remove} may share with @i{sequence}; the result may be @i{identical} to the input @i{sequence} if no elements need to be removed. @b{delete}, @b{delete-if}, and @b{delete-if-not} return a @i{sequence} of the same @i{type} as @i{sequence} that has the same elements except that those in the subsequence @i{bounded} by @i{start} and @i{end} and @i{satisfying the test} have been deleted. @i{Sequence} may be destroyed and used to construct the result; however, the result might or might not be @i{identical} to @i{sequence}. @b{delete}, when @i{sequence} is a @i{list}, is permitted to @b{setf} any part, @b{car} or @b{cdr}, of the top-level list structure in that @i{sequence}. When @i{sequence} is a @i{vector}, @b{delete} is permitted to change the dimensions of the @i{vector} and to slide its elements into new positions without permuting them to produce the resulting @i{vector}. @b{delete-if} is constrained to behave exactly as follows: @example (delete nil @i{sequence} :test #'(lambda (ignore @i{item}) (funcall @i{test} @i{item})) ...) @end example @subsubheading Examples:: @example (remove 4 '(1 3 4 5 9)) @result{} (1 3 5 9) (remove 4 '(1 2 4 1 3 4 5)) @result{} (1 2 1 3 5) (remove 4 '(1 2 4 1 3 4 5) :count 1) @result{} (1 2 1 3 4 5) (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) @result{} (1 2 4 1 3 5) (remove 3 '(1 2 4 1 3 4 5) :test #'>) @result{} (4 3 4 5) (setq lst '(list of four elements)) @result{} (LIST OF FOUR ELEMENTS) (setq lst2 (copy-seq lst)) @result{} (LIST OF FOUR ELEMENTS) (setq lst3 (delete 'four lst)) @result{} (LIST OF ELEMENTS) (equal lst lst2) @result{} @i{false} (remove-if #'oddp '(1 2 4 1 3 4 5)) @result{} (2 4 4) (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) @result{} (1 2 4 1 3 5) (remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t) @result{} (1 2 3 4 5 6 8) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete 4 tester) @result{} (1 2 1 3 5) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete 4 tester :count 1) @result{} (1 2 1 3 4 5) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete 4 tester :count 1 :from-end t) @result{} (1 2 4 1 3 5) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete 3 tester :test #'>) @result{} (4 3 4 5) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete-if #'oddp tester) @result{} (2 4 4) (setq tester (list 1 2 4 1 3 4 5)) @result{} (1 2 4 1 3 4 5) (delete-if #'evenp tester :count 1 :from-end t) @result{} (1 2 4 1 3 5) (setq tester (list 1 2 3 4 5 6)) @result{} (1 2 3 4 5 6) (delete-if #'evenp tester) @result{} (1 3 5) tester @result{} @i{implementation-dependent} @end example @example (setq foo (list 'a 'b 'c)) @result{} (A B C) (setq bar (cdr foo)) @result{} (B C) (setq foo (delete 'b foo)) @result{} (A C) bar @result{} ((C)) or ... (eq (cdr foo) (car bar)) @result{} T or ... @end example @subsubheading Side Effects:: For @b{delete}, @b{delete-if}, and @b{delete-if-not}, @i{sequence} may be destroyed and used to construct the result. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. The functions @b{delete-if-not} and @b{remove-if-not} are deprecated. @node remove-duplicates, , remove, Sequences Dictionary @subsection remove-duplicates, delete-duplicates [Function] @code{remove-duplicates} @i{sequence @r{&key} from-end test test-not start end key}@* @result{} @i{result-sequence} @code{delete-duplicates} @i{sequence @r{&key} from-end test test-not start end key}@* @result{} @i{result-sequence} @subsubheading Arguments and Values:: @i{sequence}---a @i{proper sequence}. @i{from-end}---a @i{generalized boolean}. The default is @i{false}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-sequence}---a @i{sequence}. @subsubheading Description:: @b{remove-duplicates} returns a modified copy of @i{sequence} from which any element that matches another element occurring in @i{sequence} has been removed. If @i{sequence} is a @i{vector}, the result is a @i{vector} that has the same @i{actual array element type} as @i{sequence}. The result might or might not be simple, and might or might not be @i{identical} to @i{sequence}. If @i{sequence} is a @i{list}, the result is a @i{list}. @b{delete-duplicates} is like @b{remove-duplicates}, but @b{delete-duplicates} may modify @i{sequence}. The elements of @i{sequence} are compared @i{pairwise}, and if any two match, then the one occurring earlier in @i{sequence} is discarded, unless @i{from-end} is @i{true}, in which case the one later in @i{sequence} is discarded. @b{remove-duplicates} and @b{delete-duplicates} return a @i{sequence} of the same @i{type} as @i{sequence} with enough elements removed so that no two of the remaining elements match. The order of the elements remaining in the result is the same as the order in which they appear in @i{sequence}. @b{remove-duplicates} returns a @i{sequence} that may share with @i{sequence} or may be @i{identical} to @i{sequence} if no elements need to be removed. @b{delete-duplicates}, when @i{sequence} is a @i{list}, is permitted to @b{setf} any part, @b{car} or @b{cdr}, of the top-level list structure in that @i{sequence}. When @i{sequence} is a @i{vector}, @b{delete-duplicates} is permitted to change the dimensions of the @i{vector} and to slide its elements into new positions without permuting them to produce the resulting @i{vector}. @subsubheading Examples:: @example (remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) @result{} "aBcD" (remove-duplicates '(a b c b d d e)) @result{} (A C B D E) (remove-duplicates '(a b c b d d e) :from-end t) @result{} (A B C D E) (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) @result{} ((BAR #\%) (BAZ #\A)) (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) @result{} ((FOO #\a) (BAR #\%)) (setq tester (list 0 1 2 3 4 5 6)) (delete-duplicates tester :key #'oddp :start 1 :end 6) @result{} (0 4 5 6) @end example @subsubheading Side Effects:: @b{delete-duplicates} might destructively modify @i{sequence}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} @i{argument} is deprecated. These functions are useful for converting @i{sequence} into a canonical form suitable for representing a set. @c end of including dict-sequences @c %**end of chapter gcl-2.6.14/info/chap-4.texi0000644000175000017500000031034414360276512013702 0ustar cammcamm @node Types and Classes, Data and Control Flow, Evaluation and Compilation, Top @chapter Types and Classes @menu * Introduction (Types and Classes):: * Types:: * Classes:: * Types and Classes Dictionary:: @end menu @node Introduction (Types and Classes), Types, Types and Classes, Types and Classes @section Introduction @c including concept-type-intro A @i{type} is a (possibly infinite) set of @i{objects}. An @i{object} can belong to more than one @i{type}. @i{Types} are never explicitly represented as @i{objects} by @r{Common Lisp}. Instead, they are referred to indirectly by the use of @i{type specifiers}, which are @i{objects} that denote @i{types}. New @i{types} can be defined using @b{deftype}, @b{defstruct}, @b{defclass}, and @b{define-condition}. The @i{function} @b{typep}, a set membership test, is used to determine whether a given @i{object} is of a given @i{type}. The function @b{subtypep}, a subset test, is used to determine whether a given @i{type} is a @i{subtype} of another given @i{type}. The function @b{type-of} returns a particular @i{type} to which a given @i{object} belongs, even though that @i{object} must belong to one or more other @i{types} as well. (For example, every @i{object} is of @i{type} @b{t}, but @b{type-of} always returns a @i{type specifier} for a @i{type} more specific than @b{t}.) @i{Objects}, not @i{variables}, have @i{types}. Normally, any @i{variable} can have any @i{object} as its @i{value}. It is possible to declare that a @i{variable} takes on only values of a given @i{type} by making an explicit @i{type declaration}. @i{Types} are arranged in a directed acyclic graph, except for the presence of equivalences. @i{Declarations} can be made about @i{types} using @b{declare}, @b{proclaim}, @b{declaim}, or @b{the}. For more information about @i{declarations}, see @ref{Declarations}. Among the fundamental @i{objects} of the object system are @i{classes}. A @i{class} determines the structure and behavior of a set of other @i{objects}, which are called its @i{instances}. Every @i{object} is a @i{direct instance} of a @i{class}. The @i{class} of an @i{object} determines the set of operations that can be performed on the @i{object}. For more information, see @ref{Classes}. It is possible to write @i{functions} that have behavior @i{specialized} to the class of the @i{objects} which are their @i{arguments}. For more information, see @ref{Generic Functions and Methods}. The @i{class} of the @i{class} of an @i{object} is called its @i{metaclass} @IGindex metaclass . For more information about @i{metaclasses}, see @ref{Meta-Objects}. @c end of including concept-type-intro @node Types, Classes, Introduction (Types and Classes), Types and Classes @section Types @c including concept-types @menu * Data Type Definition:: * Type Relationships:: * Type Specifiers:: @end menu @node Data Type Definition, Type Relationships, Types, Types @subsection Data Type Definition Information about @i{type} usage is located in the sections specified in @i{Figure~4--1}. @i{Figure~4--7} lists some @i{classes} that are particularly relevant to the object system. @i{Figure~9--1} lists the defined @i{condition} @i{types}. @format @group @noindent @w{ @b{Section} Data Type } @w{ _________________________________________________________________________} @w{ @ref{Classes} Object System types } @w{ @ref{Slots} Object System types } @w{ @ref{Objects} Object System types } @w{ @ref{Generic Functions and Methods} Object System types } @w{ @ref{Condition System Concepts} Condition System types } @w{ @ref{Types and Classes} Miscellaneous types } @w{ @ref{Syntax} All types---read and print syntax } @w{ @ref{The Lisp Printer} All types---print syntax } @w{ @ref{Compilation} All types---compilation issues } @noindent @w{ Figure 4--1: Cross-References to Data Type Information } @end group @end format @node Type Relationships, Type Specifiers, Data Type Definition, Types @subsection Type Relationships @table @asis @item @t{*} The @i{types} @b{cons}, @b{symbol}, @b{array}, @b{number}, @b{character}, @b{hash-table}, @b{function}, @b{readtable}, @b{package}, @b{pathname}, @b{stream}, @b{random-state}, @b{condition}, @b{restart}, and any single other @i{type} created by @b{defstruct}, @b{define-condition}, or @b{defclass} are @i{pairwise} @i{disjoint}, except for type relations explicitly established by specifying @i{superclasses} in @b{defclass} or @b{define-condition} or the @t{:include} option of @b{destruct}. @item @t{*} Any two @i{types} created by @b{defstruct} are @i{disjoint} unless one is a @i{supertype} of the other by virtue of the @b{defstruct} @t{:include} option. [Editorial Note by KMP: The comments in the source say gray suggested some change from ``common superclass'' to ``common subclass'' in the following, but the result looks suspicious to me.] @item @t{*} Any two @i{distinct} @i{classes} created by @b{defclass} or @b{define-condition} are @i{disjoint} unless they have a common @i{subclass} or one @i{class} is a @i{subclass} of the other. @item @t{*} An implementation may be extended to add other @i{subtype} relationships between the specified @i{types}, as long as they do not violate the type relationships and disjointness requirements specified here. An implementation may define additional @i{types} that are @i{subtypes} or @i{supertypes} of any specified @i{types}, as long as each additional @i{type} is a @i{subtype} of @i{type} @b{t} and a @i{supertype} of @i{type} @b{nil} and the disjointness requirements are not violated. At the discretion of the implementation, either @b{standard-object} or @b{structure-object} might appear in any class precedence list for a @i{system class} that does not already specify either @b{standard-object} or @b{structure-object}. If it does, it must precede the @i{class} @b{t} and follow all other @i{standardized} @i{classes}. @end table @node Type Specifiers, , Type Relationships, Types @subsection Type Specifiers @i{Type specifiers} can be @i{symbols}, @i{classes}, or @i{lists}. @i{Figure~4--2} lists @i{symbols} that are @i{standardized} @i{atomic type specifiers}, and @i{Figure~4--3} lists @i{standardized} @i{compound type specifier} @i{names}. For syntax information, see the dictionary entry for the corresponding @i{type specifier}. It is possible to define new @i{type specifiers} using @b{defclass}, @b{define-condition}, @b{defstruct}, or @b{deftype}. @format @group @noindent @w{ arithmetic-error function simple-condition } @w{ array generic-function simple-error } @w{ atom hash-table simple-string } @w{ base-char integer simple-type-error } @w{ base-string keyword simple-vector } @w{ bignum list simple-warning } @w{ bit logical-pathname single-float } @w{ bit-vector long-float standard-char } @w{ broadcast-stream method standard-class } @w{ built-in-class method-combination standard-generic-function } @w{ cell-error nil standard-method } @w{ character null standard-object } @w{ class number storage-condition } @w{ compiled-function package stream } @w{ complex package-error stream-error } @w{ concatenated-stream parse-error string } @w{ condition pathname string-stream } @w{ cons print-not-readable structure-class } @w{ control-error program-error structure-object } @w{ division-by-zero random-state style-warning } @w{ double-float ratio symbol } @w{ echo-stream rational synonym-stream } @w{ end-of-file reader-error t } @w{ error readtable two-way-stream } @w{ extended-char real type-error } @w{ file-error restart unbound-slot } @w{ file-stream sequence unbound-variable } @w{ fixnum serious-condition undefined-function } @w{ float short-float unsigned-byte } @w{ floating-point-inexact signed-byte vector } @w{ floating-point-invalid-operation simple-array warning } @w{ floating-point-overflow simple-base-string } @w{ floating-point-underflow simple-bit-vector } @noindent @w{ Figure 4--2: Standardized Atomic Type Specifiers } @end group @end format \indent If a @i{type specifier} is a @i{list}, the @i{car} of the @i{list} is a @i{symbol}, and the rest of the @i{list} is subsidiary @i{type} information. Such a @i{type specifier} is called a @i{compound type specifier} @IGindex compound type specifier . Except as explicitly stated otherwise, the subsidiary items can be unspecified. The unspecified subsidiary items are indicated by writing @t{*}. For example, to completely specify a @i{vector}, the @i{type} of the elements and the length of the @i{vector} must be present. @example (vector double-float 100) @end example The following leaves the length unspecified: @example (vector double-float *) @end example The following leaves the element type unspecified: @example (vector * 100) @end example Suppose that two @i{type specifiers} are the same except that the first has a @t{*} where the second has a more explicit specification. Then the second denotes a @i{subtype} of the @i{type} denoted by the first. If a @i{list} has one or more unspecified items at the end, those items can be dropped. If dropping all occurrences of @t{*} results in a @i{singleton} @i{list}, then the parentheses can be dropped as well (the list can be replaced by the @i{symbol} in its @i{car}). For example, @t{(vector double-float *)} can be abbreviated to @t{(vector double-float)}, and @t{(vector * *)} can be abbreviated to @t{(vector)} and then to @t{vector}. @format @group @noindent @w{ and long-float simple-base-string } @w{ array member simple-bit-vector } @w{ base-string mod simple-string } @w{ bit-vector not simple-vector } @w{ complex or single-float } @w{ cons rational string } @w{ double-float real unsigned-byte } @w{ eql satisfies values } @w{ float short-float vector } @w{ function signed-byte } @w{ integer simple-array } @noindent @w{ Figure 4--3: Standardized Compound Type Specifier Names} @end group @end format Figure 4--4 show the @i{defined names} that can be used as @i{compound type specifier} @i{names} but that cannot be used as @i{atomic type specifiers}. @format @group @noindent @w{ and mod satisfies } @w{ eql not values } @w{ member or } @noindent @w{ Figure 4--4: Standardized Compound-Only Type Specifier Names} @end group @end format New @i{type specifiers} can come into existence in two ways. @table @asis @item @t{*} Defining a structure by using @b{defstruct} without using the @t{:type} specifier or defining a @i{class} by using @b{defclass} or @b{define-condition} automatically causes the name of the structure or class to be a new @i{type specifier} @i{symbol}. @item @t{*} @b{deftype} can be used to define @i{derived type specifiers} @IGindex derived type specifier , which act as `abbreviations' for other @i{type specifiers}. @end table A @i{class} @i{object} can be used as a @i{type specifier}. When used this way, it denotes the set of all members of that @i{class}. Figure 4--5 shows some @i{defined names} relating to @i{types} and @i{declarations}. @format @group @noindent @w{ coerce defstruct subtypep } @w{ declaim deftype the } @w{ declare ftype type } @w{ defclass locally type-of } @w{ define-condition proclaim typep } @noindent @w{ Figure 4--5: Defined names relating to types and declarations.} @end group @end format Figure 4--6 shows all @i{defined names} that are @i{type specifier} @i{names}, whether for @i{atomic type specifiers} or @i{compound type specifiers}; this list is the union of the lists in @i{Figure~4--2} and @i{Figure~4--3}. @format @group @noindent @w{ and function simple-array } @w{ arithmetic-error generic-function simple-base-string } @w{ array hash-table simple-bit-vector } @w{ atom integer simple-condition } @w{ base-char keyword simple-error } @w{ base-string list simple-string } @w{ bignum logical-pathname simple-type-error } @w{ bit long-float simple-vector } @w{ bit-vector member simple-warning } @w{ broadcast-stream method single-float } @w{ built-in-class method-combination standard-char } @w{ cell-error mod standard-class } @w{ character nil standard-generic-function } @w{ class not standard-method } @w{ compiled-function null standard-object } @w{ complex number storage-condition } @w{ concatenated-stream or stream } @w{ condition package stream-error } @w{ cons package-error string } @w{ control-error parse-error string-stream } @w{ division-by-zero pathname structure-class } @w{ double-float print-not-readable structure-object } @w{ echo-stream program-error style-warning } @w{ end-of-file random-state symbol } @w{ eql ratio synonym-stream } @w{ error rational t } @w{ extended-char reader-error two-way-stream } @w{ file-error readtable type-error } @w{ file-stream real unbound-slot } @w{ fixnum restart unbound-variable } @w{ float satisfies undefined-function } @w{ floating-point-inexact sequence unsigned-byte } @w{ floating-point-invalid-operation serious-condition values } @w{ floating-point-overflow short-float vector } @w{ floating-point-underflow signed-byte warning } @noindent @w{ Figure 4--6: Standardized Type Specifier Names } @end group @end format @c end of including concept-types @node Classes, Types and Classes Dictionary, Types, Types and Classes @section Classes @c including concept-classes While the object system is general enough to describe all @i{standardized} @i{classes} (including, for example, @b{number}, @b{hash-table}, and @b{symbol}), Figure 4--7 contains a list of @i{classes} that are especially relevant to understanding the object system. @format @group @noindent @w{ built-in-class method-combination standard-object } @w{ class standard-class structure-class } @w{ generic-function standard-generic-function structure-object } @w{ method standard-method } @noindent @w{ Figure 4--7: Object System Classes } @end group @end format @menu * Introduction to Classes:: * Defining Classes:: * Creating Instances of Classes:: * Inheritance:: * Determining the Class Precedence List:: * Redefining Classes:: * Integrating Types and Classes:: @end menu @node Introduction to Classes, Defining Classes, Classes, Classes @subsection Introduction to Classes A @i{class} @IGindex class is an @i{object} that determines the structure and behavior of a set of other @i{objects}, which are called its @i{instances} @IGindex instance . A @i{class} can inherit structure and behavior from other @i{classes}. A @i{class} whose definition refers to other @i{classes} for the purpose of inheriting from them is said to be a @i{subclass} of each of those @i{classes}. The @i{classes} that are designated for purposes of inheritance are said to be @i{superclasses} of the inheriting @i{class}. A @i{class} can have a @i{name}. The @i{function} @b{class-name} takes a @i{class} @i{object} and returns its @i{name}. The @i{name} of an anonymous @i{class} is @b{nil}. A @i{symbol} can @i{name} a @i{class}. The @i{function} @b{find-class} takes a @i{symbol} and returns the @i{class} that the @i{symbol} names. A @i{class} has a @i{proper name} if the @i{name} is a @i{symbol} and if the @i{name} of the @i{class} names that @i{class}. That is, a @i{class}~C has the @i{proper name}~S if S= @t{(class-name C)} and C= @t{(find-class S)}. Notice that it is possible for @t{(find-class S_1)} = @t{(find-class S_2)} and S_1!= S_2. If C= @t{(find-class S)}, we say that C is the @i{class} @i{named} S. A @i{class} C_1 is a @i{direct superclass} @IGindex direct superclass of a @i{class} C_2 if C_2 explicitly designates C_1 as a @i{superclass} in its definition. In this case C_2 is a @i{direct subclass} @IGindex direct subclass of C_1. A @i{class} C_n is a @i{superclass} @IGindex superclass of a @i{class} C_1 if there exists a series of @i{classes} C_2,...,C_@{n-1@} such that C_@{i+1@} is a @i{direct superclass} of C_i for 1 <= i= 2, be the @i{classes} from S_C with no predecessors. Let (C_1... C_n), n>= 1, be the @i{class precedence list} constructed so far. C_1 is the most specific @i{class}, and C_n is the least specific. Let 1<= j<= n be the largest number such that there exists an i where 1<= i<= m and N_i is a direct @i{superclass} of C_j; N_i is placed next. The effect of this rule for selecting from a set of @i{classes} with no predecessors is that the @i{classes} in a simple @i{superclass} chain are adjacent in the @i{class precedence list} and that @i{classes} in each relatively separated subgraph are adjacent in the @i{class precedence list}. For example, let T_1 and T_2 be subgraphs whose only element in common is the class J. Suppose that no superclass of J appears in either T_1 or T_2, and that J is in the superclass chain of every class in both T_1 and T_2. Let C_1 be the bottom of T_1; and let C_2 be the bottom of T_2. Suppose C is a @i{class} whose direct @i{superclasses} are C_1 and C_2 in that order, then the @i{class precedence list} for C starts with C and is followed by all @i{classes} in T_1 except J. All the @i{classes} of T_2 are next. The @i{class} J and its @i{superclasses} appear last. @node Examples of Class Precedence List Determination, , Topological Sorting, Determining the Class Precedence List @subsubsection Examples of Class Precedence List Determination This example determines a @i{class precedence list} for the class @t{pie}. The following @i{classes} are defined: @example (defclass pie (apple cinnamon) ()) (defclass apple (fruit) ()) (defclass cinnamon (spice) ()) (defclass fruit (food) ()) (defclass spice (food) ()) (defclass food () ()) @end example The set S_@{pie@}~= @{pie, apple, cinnamon, fruit, spice, food, standard-object, t @}. The set R~= @{ (pie, apple), (apple, cinnamon), (apple, fruit), (cinnamon, spice), \break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) @}. The class @t{pie} is not preceded by anything, so it comes first; the result so far is @t{(pie)}. Remove @t{pie} from S and pairs mentioning @t{pie} from R to get S~= @{apple, cinnamon, fruit, spice, food, standard-object, t @} and R~=~@{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) @}. The class @t{apple} is not preceded by anything, so it is next; the result is @t{(pie apple)}. Removing @t{apple} and the relevant pairs results in S~= @{ cinnamon, fruit, spice, food, standard-object, t @} and R~= @{ (cinnamon, spice), (fruit, food), (spice, food), (food, standard-object),\break (standard-object, t) @}. The classes @t{cinnamon} and @t{fruit} are not preceded by anything, so the one with a direct @i{subclass} rightmost in the @i{class precedence list} computed so far goes next. The class @t{apple} is a direct @i{subclass} of @t{fruit}, and the class @t{pie} is a direct @i{subclass} of @t{cinnamon}. Because @t{apple} appears to the right of @t{pie} in the @i{class precedence list}, @t{fruit} goes next, and the result so far is @t{(pie apple fruit)}. S~= @{ cinnamon, spice, food, standard-object, t @}; R~= @{(cinnamon, spice), (spice, food),\break (food, standard-object), (standard-object, t) @}. The class @t{cinnamon} is next, giving the result so far as @t{(pie apple fruit cinnamon)}. At this point S~= @{ spice, food, standard-object, t @}; R~= @{ (spice, food), (food, standard-object), (standard-object, t) @}. The classes @t{spice}, @t{food}, @b{standard-object}, and @b{t} are added in that order, and the @i{class precedence list} is @t{(pie apple fruit cinnamon spice food standard-object t)}. It is possible to write a set of @i{class} definitions that cannot be ordered. For example: @example (defclass new-class (fruit apple) ()) (defclass apple (fruit) ()) @end example The class @t{fruit} must precede @t{apple} because the local ordering of @i{superclasses} must be preserved. The class @t{apple} must precede @t{fruit} because a @i{class} always precedes its own @i{superclasses}. When this situation occurs, an error is signaled, as happens here when the system tries to compute the @i{class precedence list} of @t{new-class}. The following might appear to be a conflicting set of definitions: @example (defclass pie (apple cinnamon) ()) (defclass pastry (cinnamon apple) ()) (defclass apple () ()) (defclass cinnamon () ()) @end example The @i{class precedence list} for @t{pie} is @t{(pie apple cinnamon standard-object t)}. The @i{class precedence list} for @t{pastry} is @t{(pastry cinnamon apple standard-object t)}. It is not a problem for @t{apple} to precede @t{cinnamon} in the ordering of the @i{superclasses} of @t{pie} but not in the ordering for @t{pastry}. However, it is not possible to build a new @i{class} that has both @t{pie} and @t{pastry} as @i{superclasses}. @node Redefining Classes, Integrating Types and Classes, Determining the Class Precedence List, Classes @subsection Redefining Classes A @i{class} that is a @i{direct instance} of @b{standard-class} can be redefined if the new @i{class} is also a @i{direct instance} of @b{standard-class}. Redefining a @i{class} modifies the existing @i{class} @i{object} to reflect the new @i{class} definition; it does not create a new @i{class} @i{object} for the @i{class}. Any @i{method} @i{object} created by a @t{:reader}, @t{:writer}, or @t{:accessor} option specified by the old @b{defclass} form is removed from the corresponding @i{generic function}. @i{Methods} specified by the new @b{defclass} form are added. When the class C is redefined, changes are propagated to its @i{instances} and to @i{instances} of any of its @i{subclasses}. Updating such an @i{instance} occurs at an @i{implementation-dependent} time, but no later than the next time a @i{slot} of that @i{instance} is read or written. Updating an @i{instance} does not change its identity as defined by the @i{function} @b{eq}. The updating process may change the @i{slots} of that particular @i{instance}, but it does not create a new @i{instance}. Whether updating an @i{instance} consumes storage is @i{implementation-dependent}. Note that redefining a @i{class} may cause @i{slots} to be added or deleted. If a @i{class} is redefined in a way that changes the set of @i{local slots} @i{accessible} in @i{instances}, the @i{instances} are updated. It is @i{implementation-dependent} whether @i{instances} are updated if a @i{class} is redefined in a way that does not change the set of @i{local slots} @i{accessible} in @i{instances}. The value of a @i{slot} that is specified as shared both in the old @i{class} and in the new @i{class} is retained. If such a @i{shared slot} was unbound in the old @i{class}, it is unbound in the new @i{class}. @i{Slots} that were local in the old @i{class} and that are shared in the new @i{class} are initialized. Newly added @i{shared slots} are initialized. Each newly added @i{shared slot} is set to the result of evaluating the @i{captured initialization form} for the @i{slot} that was specified in the @b{defclass} @i{form} for the new @i{class}. If there was no @i{initialization form}, the @i{slot} is unbound. If a @i{class} is redefined in such a way that the set of @i{local slots} @i{accessible} in an @i{instance} of the @i{class} is changed, a two-step process of updating the @i{instances} of the @i{class} takes place. The process may be explicitly started by invoking the generic function @b{make-instances-obsolete}. This two-step process can happen in other circumstances in some implementations. For example, in some implementations this two-step process is triggered if the order of @i{slots} in storage is changed. The first step modifies the structure of the @i{instance} by adding new @i{local slots} and discarding @i{local slots} that are not defined in the new version of the @i{class}. The second step initializes the newly-added @i{local slots} and performs any other user-defined actions. These two steps are further specified in the next two sections. @menu * Modifying the Structure of Instances:: * Initializing Newly Added Local Slots (Redefining Classes):: * Customizing Class Redefinition:: @end menu @node Modifying the Structure of Instances, Initializing Newly Added Local Slots (Redefining Classes), Redefining Classes, Redefining Classes @subsubsection Modifying the Structure of Instances [Reviewer Note by Barmar: What about shared slots that are deleted?] The first step modifies the structure of @i{instances} of the redefined @i{class} to conform to its new @i{class} definition. @i{Local slots} specified by the new @i{class} definition that are not specified as either local or shared by the old @i{class} are added, and @i{slots} not specified as either local or shared by the new @i{class} definition that are specified as local by the old @i{class} are discarded. The @i{names} of these added and discarded @i{slots} are passed as arguments to @b{update-instance-for-redefined-class} as described in the next section. The values of @i{local slots} specified by both the new and old @i{classes} are retained. If such a @i{local slot} was unbound, it remains unbound. The value of a @i{slot} that is specified as shared in the old @i{class} and as local in the new @i{class} is retained. If such a @i{shared slot} was unbound, the @i{local slot} is unbound. @node Initializing Newly Added Local Slots (Redefining Classes), Customizing Class Redefinition, Modifying the Structure of Instances, Redefining Classes @subsubsection Initializing Newly Added Local Slots The second step initializes the newly added @i{local slots} and performs any other user-defined actions. This step is implemented by the generic function @b{update-instance-for-redefined-class}, which is called after completion of the first step of modifying the structure of the @i{instance}. The generic function @b{update-instance-for-redefined-class} takes four required arguments: the @i{instance} being updated after it has undergone the first step, a list of the names of @i{local slots} that were added, a list of the names of @i{local slots} that were discarded, and a property list containing the @i{slot} names and values of @i{slots} that were discarded and had values. Included among the discarded @i{slots} are @i{slots} that were local in the old @i{class} and that are shared in the new @i{class}. The generic function @b{update-instance-for-redefined-class} also takes any number of initialization arguments. When it is called by the system to update an @i{instance} whose @i{class} has been redefined, no initialization arguments are provided. There is a system-supplied primary @i{method} for @b{update-instance-for-redefined-class} whose @i{parameter specializer} for its @i{instance} argument is the @i{class} @b{standard-object}. First this @i{method} checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see @ref{Declaring the Validity of Initialization Arguments}.) Then it calls the generic function @b{shared-initialize} with the following arguments: the @i{instance}, the list of @i{names} of the newly added @i{slots}, and the initialization arguments it received. @node Customizing Class Redefinition, , Initializing Newly Added Local Slots (Redefining Classes), Redefining Classes @subsubsection Customizing Class Redefinition [Reviewer Note by Barmar: This description is hard to follow.] @i{Methods} for @b{update-instance-for-redefined-class} may be defined to specify actions to be taken when an @i{instance} is updated. If only @i{after methods} for @b{update-instance-for-redefined-class} are defined, they will be run after the system-supplied primary @i{method} for initialization and therefore will not interfere with the default behavior of @b{update-instance-for-redefined-class}. Because no initialization arguments are passed to @b{update-instance-for-redefined-class} when it is called by the system, the @i{initialization forms} for @i{slots} that are filled by @i{before methods} for @b{update-instance-for-redefined-class} will not be evaluated by @b{shared-initialize}. @i{Methods} for @b{shared-initialize} may be defined to customize @i{class} redefinition. For more information, see @ref{Shared-Initialize}. @node Integrating Types and Classes, , Redefining Classes, Classes @subsection Integrating Types and Classes The object system maps the space of @i{classes} into the space of @i{types}. Every @i{class} that has a proper name has a corresponding @i{type} with the same @i{name}. The proper name of every @i{class} is a valid @i{type specifier}. In addition, every @i{class} @i{object} is a valid @i{type specifier}. Thus the expression @t{(typep @i{object} @i{class})} evaluates to @i{true} if the @i{class} of @i{object} is @i{class} itself or a @i{subclass} of @i{class}. The evaluation of the expression @t{(subtypep class1 class2)} returns the values @i{true} and @i{true} if @t{class1} is a subclass of @t{class2} or if they are the same @i{class}; otherwise it returns the values @i{false} and @i{true}. If I is an @i{instance} of some @i{class} C named S and C is an @i{instance} of @b{standard-class}, the evaluation of the expression @t{(type-of I\/)} returns S if S is the @i{proper name} of C; otherwise, it returns C. Because the names of @i{classes} and @i{class} @i{objects} are @i{type specifiers}, they may be used in the special form @b{the} and in type declarations. Many but not all of the predefined @i{type specifiers} have a corresponding @i{class} with the same proper name as the @i{type}. These type specifiers are listed in @i{Figure~4--8}. For example, the @i{type} @b{array} has a corresponding @i{class} named @b{array}. No @i{type specifier} that is a list, such as @t{(vector double-float 100)}, has a corresponding @i{class}. The @i{operator} @b{deftype} does not create any @i{classes}. Each @i{class} that corresponds to a predefined @i{type specifier} can be implemented in one of three ways, at the discretion of each implementation. It can be a @i{standard class}, a @i{structure class}, or a @i{system class}. A @i{built-in class} is one whose @i{generalized instances} have restricted capabilities or special representations. Attempting to use @b{defclass} to define @i{subclasses} of a @b{built-in-class} signals an error. Calling @b{make-instance} to create a @i{generalized instance} of a @i{built-in class} signals an error. Calling @b{slot-value} on a @i{generalized instance} of a @i{built-in class} signals an error. Redefining a @i{built-in class} or using @b{change-class} to change the @i{class} of an @i{object} to or from a @i{built-in class} signals an error. However, @i{built-in classes} can be used as @i{parameter specializers} in @i{methods}. It is possible to determine whether a @i{class} is a @i{built-in class} by checking the @i{metaclass}. A @i{standard class} is an @i{instance} of the @i{class} @b{standard-class}, a @i{built-in class} is an @i{instance} of the @i{class} @b{built-in-class}, and a @i{structure class} is an @i{instance} of the @i{class} @b{structure-class}. Each @i{structure} @i{type} created by @b{defstruct} without using the @t{:type} option has a corresponding @i{class}. This @i{class} is a @i{generalized instance} of the @i{class} @b{structure-class}. The @t{:include} option of @b{defstruct} creates a direct @i{subclass} of the @i{class} that corresponds to the included @i{structure} @i{type}. It is @i{implementation-dependent} whether @i{slots} are involved in the operation of @i{functions} defined in this specification on @i{instances} of @i{classes} defined in this specification, except when @i{slots} are explicitly defined by this specification. If in a particular @i{implementation} a @i{class} defined in this specification has @i{slots} that are not defined by this specfication, the names of these @i{slots} must not be @i{external symbols} of @i{packages} defined in this specification nor otherwise @i{accessible} in the @t{CL-USER} @i{package}. The purpose of specifying that many of the standard @i{type specifiers} have a corresponding @i{class} is to enable users to write @i{methods} that discriminate on these @i{types}. @i{Method} selection requires that a @i{class precedence list} can be determined for each @i{class}. The hierarchical relationships among the @i{type specifiers} are mirrored by relationships among the @i{classes} corresponding to those @i{types}. @i{Figure~4--8} lists the set of @i{classes} that correspond to predefined @i{type specifiers}. @format @group @noindent @w{ arithmetic-error generic-function simple-error } @w{ array hash-table simple-type-error } @w{ bit-vector integer simple-warning } @w{ broadcast-stream list standard-class } @w{ built-in-class logical-pathname standard-generic-function } @w{ cell-error method standard-method } @w{ character method-combination standard-object } @w{ class null storage-condition } @w{ complex number stream } @w{ concatenated-stream package stream-error } @w{ condition package-error string } @w{ cons parse-error string-stream } @w{ control-error pathname structure-class } @w{ division-by-zero print-not-readable structure-object } @w{ echo-stream program-error style-warning } @w{ end-of-file random-state symbol } @w{ error ratio synonym-stream } @w{ file-error rational t } @w{ file-stream reader-error two-way-stream } @w{ float readtable type-error } @w{ floating-point-inexact real unbound-slot } @w{ floating-point-invalid-operation restart unbound-variable } @w{ floating-point-overflow sequence undefined-function } @w{ floating-point-underflow serious-condition vector } @w{ function simple-condition warning } @noindent @w{ Figure 4--8: Classes that correspond to pre-defined type specifiers } @end group @end format The @i{class precedence list} information specified in the entries for each of these @i{classes} are those that are required by the object system. Individual implementations may be extended to define other type specifiers to have a corresponding @i{class}. Individual implementations may be extended to add other @i{subclass} relationships and to add other @i{elements} to the @i{class precedence lists} as long as they do not violate the type relationships and disjointness requirements specified by this standard. A standard @i{class} defined with no direct @i{superclasses} is guaranteed to be disjoint from all of the @i{classes} in the table, except for the class named @b{t}. @c end of including concept-classes @node Types and Classes Dictionary, , Classes, Types and Classes @section Types and Classes Dictionary @c including dict-types @menu * nil (Type):: * boolean:: * function (System Class):: * compiled-function:: * generic-function:: * standard-generic-function:: * class:: * built-in-class:: * structure-class:: * standard-class:: * method:: * standard-method:: * structure-object:: * standard-object:: * method-combination:: * t (System Class):: * satisfies:: * member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: * values (Type Specifier):: * eql (Type Specifier):: * coerce:: * deftype:: * subtypep:: * type-of:: * typep:: * type-error:: * type-error-datum:: * simple-type-error:: @end menu @node nil (Type), boolean, Types and Classes Dictionary, Types and Classes Dictionary @subsection nil [Type] @subsubheading Supertypes:: all @i{types} @subsubheading Description:: The @i{type} @b{nil} contains no @i{objects} and so is also called the @i{empty type}. The @i{type} @b{nil} is a @i{subtype} of every @i{type}. No @i{object} is of @i{type} @b{nil}. @subsubheading Notes:: The @i{type} containing the @i{object} @b{nil} is the @i{type} @b{null}, not the @i{type} @b{nil}. @node boolean, function (System Class), nil (Type), Types and Classes Dictionary @subsection boolean [Type] @subsubheading Supertypes:: @b{boolean}, @b{symbol}, @b{t} @subsubheading Description:: The @i{type} @b{boolean} contains the @i{symbols} @b{t} and @b{nil}, which represent true and false, respectively. @subsubheading See Also:: @b{t} (@i{constant variable}), @b{nil} (@i{constant variable}), @ref{if} , @ref{not} , @ref{complement} @subsubheading Notes:: Conditional operations, such as @b{if}, permit the use of @i{generalized booleans}, not just @i{booleans}; any @i{non-nil} value, not just @b{t}, counts as true for a @i{generalized boolean}. However, as a matter of convention, the @i{symbol} @b{t} is considered the canonical value to use even for a @i{generalized boolean} when no better choice presents itself. @node function (System Class), compiled-function, boolean, Types and Classes Dictionary @subsection function [System Class] @subsubheading Class Precedence List:: @b{function}, @b{t} @subsubheading Description:: A @i{function} is an @i{object} that represents code to be executed when an appropriate number of arguments is supplied. A @i{function} is produced by the @b{function} @i{special form}, the @i{function} @b{coerce}, or the @i{function} @b{compile}. A @i{function} can be directly invoked by using it as the first argument to @b{funcall}, @b{apply}, or @b{multiple-value-call}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{function}@{@i{@t{[}arg-typespec @r{[}value-typespec@r{]}@t{]}}@}) @w{@i{arg-typespec} ::=@r{(}@{@i{typespec}@}* } @w{ @t{[}@r{&optional} @{@i{typespec}@}*@t{]} } @w{ @t{[}@r{&rest} @i{typespec}@t{]} } @w{ @t{[}@r{&key} @{@r{(}keyword typespec @r{)}@}*@t{]}@r{)}} @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier}. @i{value-typespec}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: [Editorial Note by KMP: Isn't there some context info about ftype declarations to be merged here?] [Editorial Note by KMP: This could still use some cleaning up.] [Editorial Note by Sandra: Still need clarification about what happens if the number of arguments doesn't match the FUNCTION type declaration.] The list form of the @b{function} @i{type-specifier} can be used only for declaration and not for discrimination. Every element of this @i{type} is a @i{function} that accepts arguments of the types specified by the @i{argj-types} and returns values that are members of the @i{types} specified by @i{value-type}. The @b{&optional}, @b{&rest}, @b{&key}, and @b{&allow-other-keys} markers can appear in the list of argument types. The @i{type specifier} provided with @b{&rest} is the @i{type} of each actual argument, not the @i{type} of the corresponding variable. The @b{&key} parameters should be supplied as lists of the form @t{(@i{keyword} @i{type})}. The @i{keyword} must be a valid keyword-name symbol as must be supplied in the actual arguments of a call. This is usually a @i{symbol} in the @t{KEYWORD} @i{package} but can be any @i{symbol}. When @b{&key} is given in a @b{function} @i{type specifier} @i{lambda list}, the @i{keyword parameters} given are exhaustive unless @b{&allow-other-keys} is also present. @b{&allow-other-keys} is an indication that other keyword arguments might actually be supplied and, if supplied, can be used. For example, the @i{type} of the @i{function} @b{make-list} could be declared as follows: @example (function ((integer 0) &key (:initial-element t)) list) @end example The @i{value-type} can be a @b{values} @i{type specifier} in order to indicate the @i{types} of @i{multiple values}. Consider a declaration of the following form: @example (ftype (function (arg0-type arg1-type ...) val-type) f)) @end example Any @i{form} @t{(f arg0 arg1 ...)} within the scope of that declaration is equivalent to the following: @example (the val-type (f (the arg0-type arg0) (the arg1-type arg1) ...)) @end example That is, the consequences are undefined if any of the arguments are not of the specified @i{types} or the result is not of the specified @i{type}. In particular, if any argument is not of the correct @i{type}, the result is not guaranteed to be of the specified @i{type}. Thus, an @b{ftype} declaration for a @i{function} describes @i{calls} to the @i{function}, not the actual definition of the @i{function}. Consider a declaration of the following form: @example (type (function (arg0-type arg1-type ...) val-type) fn-valued-variable) @end example This declaration has the interpretation that, within the scope of the declaration, the consequences are unspecified if the value of @t{fn-valued-variable} is called with arguments not of the specified @i{types}; the value resulting from a valid call will be of type @t{val-type}. As with variable type declarations, nested declarations imply intersections of @i{types}, as follows: @table @asis @item @t{*} Consider the following two declarations of @b{ftype}: @example (ftype (function (arg0-type1 arg1-type1 ...) val-type1) f)) @end example and @example (ftype (function (arg0-type2 arg1-type2 ...) val-type2) f)) @end example If both these declarations are in effect, then within the shared scope of the declarations, calls to @t{f} can be treated as if @t{f} were declared as follows: @example (ftype (function ((and arg0-type1 arg0-type2) (and arg1-type1 arg1-type2 ...) ...) (and val-type1 val-type2)) f)) @end example It is permitted to ignore one or all of the @b{ftype} declarations in force. @item @t{*} If two (or more) type declarations are in effect for a variable, and they are both @t{function} declarations, the declarations combine similarly. @end table @node compiled-function, generic-function, function (System Class), Types and Classes Dictionary @subsection compiled-function [Type] @subsubheading Supertypes:: @b{compiled-function}, @b{function}, @b{t} @subsubheading Description:: Any @i{function} may be considered by an @i{implementation} to be a a @i{compiled function} if it contains no references to @i{macros} that must be expanded at run time, and it contains no unresolved references to @i{load time values}. See @ref{Compilation Semantics}. @i{Functions} whose definitions appear lexically within a @i{file} that has been @i{compiled} with @b{compile-file} and then @i{loaded} with @b{load} are of @i{type} @b{compiled-function}. @i{Functions} produced by the @b{compile} function are of @i{type} @b{compiled-function}. Other @i{functions} might also be of @i{type} @b{compiled-function}. @node generic-function, standard-generic-function, compiled-function, Types and Classes Dictionary @subsection generic-function [System Class] @subsubheading Class Precedence List:: @b{generic-function}, @b{function}, @b{t} @subsubheading Description:: A @i{generic function} @IGindex generic function is a @i{function} whose behavior depends on the @i{classes} or identities of the @i{arguments} supplied to it. A generic function object contains a set of @i{methods}, a @i{lambda list}, a @i{method combination} @i{type}, and other information. The @i{methods} define the class-specific behavior and operations of the @i{generic function}; a @i{method} is said to @i{specialize} a @i{generic function}. When invoked, a @i{generic function} executes a subset of its @i{methods} based on the @i{classes} or identities of its @i{arguments}. A @i{generic function} can be used in the same ways that an ordinary @i{function} can be used; specifically, a @i{generic function} can be used as an argument to @b{funcall} and @b{apply}, and can be given a global or a local name. @node standard-generic-function, class, generic-function, Types and Classes Dictionary @subsection standard-generic-function [System Class] @subsubheading Class Precedence List:: @b{standard-generic-function}, @b{generic-function}, @b{function}, @b{t} @subsubheading Description:: The @i{class} @b{standard-generic-function} is the default @i{class} of @i{generic functions} @i{established} by @b{defmethod}, @b{ensure-generic-function}, @b{defgeneric}, and @b{defclass} @i{forms}. @node class, built-in-class, standard-generic-function, Types and Classes Dictionary @subsection class [System Class] @subsubheading Class Precedence List:: @b{class}, @b{standard-object}, @b{t} @subsubheading Description:: The @i{type} @b{class} represents @i{objects} that determine the structure and behavior of their @i{instances}. Associated with an @i{object} of @i{type} @b{class} is information describing its place in the directed acyclic graph of @i{classes}, its @i{slots}, and its options. @node built-in-class, structure-class, class, Types and Classes Dictionary @subsection built-in-class [System Class] @subsubheading Class Precedence List:: @b{built-in-class}, @b{class}, @b{standard-object}, @b{t} @subsubheading Description:: A @i{built-in class} is a @i{class} whose @i{instances} have restricted capabilities or special representations. Attempting to use @b{defclass} to define @i{subclasses} of a @i{built-in class} signals an error of @i{type} @b{error}. Calling @b{make-instance} to create an @i{instance} of a @i{built-in class} signals an error of @i{type} @b{error}. Calling @b{slot-value} on an @i{instance} of a @i{built-in class} signals an error of @i{type} @b{error}. Redefining a @i{built-in class} or using @b{change-class} to change the @i{class} of an @i{instance} to or from a @i{built-in class} signals an error of @i{type} @b{error}. However, @i{built-in classes} can be used as @i{parameter specializers} in @i{methods}. @node structure-class, standard-class, built-in-class, Types and Classes Dictionary @subsection structure-class [System Class] @subsubheading Class Precedence List:: @b{structure-class}, @b{class}, @b{standard-object}, @b{t} @subsubheading Description:: All @i{classes} defined by means of @b{defstruct} are @i{instances} of the @i{class} @b{structure-class}. @node standard-class, method, structure-class, Types and Classes Dictionary @subsection standard-class [System Class] @subsubheading Class Precedence List:: @b{standard-class}, @b{class}, @b{standard-object}, @b{t} @subsubheading Description:: The @i{class} @b{standard-class} is the default @i{class} of @i{classes} defined by @b{defclass}. @node method, standard-method, standard-class, Types and Classes Dictionary @subsection method [System Class] @subsubheading Class Precedence List:: @b{method}, @b{t} @subsubheading Description:: A @i{method} is an @i{object} that represents a modular part of the behavior of a @i{generic function}. A @i{method} contains @i{code} to implement the @i{method}'s behavior, a sequence of @i{parameter specializers} that specify when the given @i{method} is applicable, and a sequence of @i{qualifiers} that is used by the method combination facility to distinguish among @i{methods}. Each required parameter of each @i{method} has an associated @i{parameter specializer}, and the @i{method} will be invoked only on arguments that satisfy its @i{parameter specializers}. The method combination facility controls the selection of @i{methods}, the order in which they are run, and the values that are returned by the generic function. The object system offers a default method combination type and provides a facility for declaring new types of method combination. @subsubheading See Also:: @ref{Generic Functions and Methods} @node standard-method, structure-object, method, Types and Classes Dictionary @subsection standard-method [System Class] @subsubheading Class Precedence List:: @b{standard-method}, @b{method}, @b{standard-object}, @b{t} @subsubheading Description:: The @i{class} @b{standard-method} is the default @i{class} of @i{methods} defined by the @b{defmethod} and @b{defgeneric} @i{forms}. @node structure-object, standard-object, standard-method, Types and Classes Dictionary @subsection structure-object [Class] @subsubheading Class Precedence List:: @b{structure-object}, @b{t} @subsubheading Description:: The @i{class} @b{structure-object} is an @i{instance} of @b{structure-class} and is a @i{superclass} of every @i{class} that is an @i{instance} of @b{structure-class} except itself, and is a @i{superclass} of every @i{class} that is defined by @b{defstruct}. @subsubheading See Also:: @ref{defstruct} , @ref{Sharpsign S}, @ref{Printing Structures} @node standard-object, method-combination, structure-object, Types and Classes Dictionary @subsection standard-object [Class] @subsubheading Class Precedence List:: @b{standard-object}, @b{t} @subsubheading Description:: The @i{class} @b{standard-object} is an @i{instance} of @b{standard-class} and is a @i{superclass} of every @i{class} that is an @i{instance} of @b{standard-class} except itself. @node method-combination, t (System Class), standard-object, Types and Classes Dictionary @subsection method-combination [System Class] @subsubheading Class Precedence List:: @b{method-combination}, @b{t} @subsubheading Description:: Every @i{method combination} @i{object} is an @i{indirect instance} of the @i{class} @b{method-combination}. A @i{method combination} @i{object} represents the information about the @i{method combination} being used by a @i{generic function}. A @i{method combination} @i{object} contains information about both the type of @i{method combination} and the arguments being used with that @i{type}. @node t (System Class), satisfies, method-combination, Types and Classes Dictionary @subsection t [System Class] @subsubheading Class Precedence List:: @b{t} @subsubheading Description:: The set of all @i{objects}. The @i{type} @b{t} is a @i{supertype} of every @i{type}, including itself. Every @i{object} is of @i{type} @b{t}. @node satisfies, member (Type Specifier), t (System Class), Types and Classes Dictionary @subsection satisfies [Type Specifier] @subsubheading Compound Type Specifier Kind:: Predicating. @subsubheading Compound Type Specifier Syntax:: (@code{satisfies}@{@i{predicate-name}@}) @subsubheading Compound Type Specifier Arguments:: @i{predicate-name}---a @i{symbol}. @subsubheading Compound Type Specifier Description:: This denotes the set of all @i{objects} that satisfy the @i{predicate} @i{predicate-name}, which must be a @i{symbol} whose global @i{function} definition is a one-argument predicate. A name is required for @i{predicate-name}; @i{lambda expressions} are not allowed. For example, the @i{type specifier} @t{(and integer (satisfies evenp))} denotes the set of all even integers. The form @t{(typep @i{x} '(satisfies @i{p}))} is equivalent to @t{(if (@i{p} @i{x}) t nil)}. The argument is required. The @i{symbol} @b{*} can be the argument, but it denotes itself (the @i{symbol} @b{*}), and does not represent an unspecified value. The symbol @b{satisfies} is not valid as a @i{type specifier}. @node member (Type Specifier), not (Type Specifier), satisfies, Types and Classes Dictionary @subsection member [Type Specifier] @subsubheading Compound Type Specifier Kind:: Combining. @subsubheading Compound Type Specifier Syntax:: (@code{member}@{@i{@{@i{object}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @i{object}---an @i{object}. @subsubheading Compound Type Specifier Description:: This denotes the set containing the named @i{objects}. An @i{object} is of this @i{type} if and only if it is @b{eql} to one of the specified @i{objects}. The @i{type specifiers} @t{(member)} and @b{nil} are equivalent. @b{*} can be among the @i{objects}, but if so it denotes itself (the symbol @b{*}) and does not represent an unspecified value. The symbol @b{member} is not valid as a @i{type specifier}; and, specifically, it is not an abbreviation for either @t{(member)} or @t{(member *)}. @subsubheading See Also:: the @i{type} @b{eql} @node not (Type Specifier), and (Type Specifier), member (Type Specifier), Types and Classes Dictionary @subsection not [Type Specifier] @subsubheading Compound Type Specifier Kind:: Combining. @subsubheading Compound Type Specifier Syntax:: (@code{not}@{@i{typespec}@}) @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: This denotes the set of all @i{objects} that are not of the @i{type} @i{typespec}. The argument is required, and cannot be @b{*}. The symbol @b{not} is not valid as a @i{type specifier}. @node and (Type Specifier), or (Type Specifier), not (Type Specifier), Types and Classes Dictionary @subsection and [Type Specifier] @subsubheading Compound Type Specifier Kind:: Combining. @subsubheading Compound Type Specifier Syntax:: (@code{and}@{@i{@{@i{typespec}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: This denotes the set of all @i{objects} of the @i{type} determined by the intersection of the @i{typespecs}. @b{*} is not permitted as an argument. The @i{type specifiers} @t{(and)} and @b{t} are equivalent. The symbol @b{and} is not valid as a @i{type specifier}, and, specifically, it is not an abbreviation for @t{(and)}. @node or (Type Specifier), values (Type Specifier), and (Type Specifier), Types and Classes Dictionary @subsection or [Type Specifier] @subsubheading Compound Type Specifier Kind:: Combining. @subsubheading Compound Type Specifier Syntax:: (@code{or}@{@i{@{@i{typespec}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: This denotes the set of all @i{objects} of the @i{type} determined by the union of the @i{typespecs}. For example, the @i{type} @b{list} by definition is the same as @t{(or null cons)}. Also, the value returned by @b{position} is an @i{object} of @i{type} @t{(or null (integer 0 *))}; @i{i.e.}, either @b{nil} or a non-negative @i{integer}. @b{*} is not permitted as an argument. The @i{type specifiers} @t{(or)} and @b{nil} are equivalent. The symbol @b{or} is not valid as a @i{type specifier}; and, specifically, it is not an abbreviation for @t{(or)}. @node values (Type Specifier), eql (Type Specifier), or (Type Specifier), Types and Classes Dictionary @subsection values [Type Specifier] @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{values}@{@i{!@i{value-typespec}}@}) [Reviewer Note by Barmar: Missing @b{&key}] @w{@i{value-typespec} ::=@{@i{typespec}@}* @t{[}@r{&optional} @r{@{@i{typespec}@}*}@t{]} @t{[}@r{&rest} typespec @t{]} @t{[}@b{&allow-other-keys}@t{]}} @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: This @i{type specifier} can be used only as the @i{value-type} in a @b{function} @i{type specifier} or a @b{the} @i{special form}. It is used to specify individual @i{types} when @i{multiple values} are involved. The @b{&optional} and @b{&rest} markers can appear in the @i{value-type} list; they indicate the parameter list of a @i{function} that, when given to @b{multiple-value-call} along with the values, would correctly receive those values. The symbol @b{*} may not be among the @i{value-types}. The symbol @b{values} is not valid as a @i{type specifier}; and, specifically, it is not an abbreviation for @t{(values)}. @node eql (Type Specifier), coerce, values (Type Specifier), Types and Classes Dictionary @subsection eql [Type Specifier] @subsubheading Compound Type Specifier Kind:: Combining. @subsubheading Compound Type Specifier Syntax:: (@code{eql}@{@i{object}@}) @subsubheading Compound Type Specifier Arguments:: @i{object}---an @i{object}. @subsubheading Compound Type Specifier Description:: Represents the @i{type} whose only @i{element} is @i{object}. The argument @i{object} is required. The @i{object} can be @b{*}, but if so it denotes itself (the symbol @b{*}) and does not represent an unspecified value. The @i{symbol} @b{eql} is not valid as an @i{atomic type specifier}. @node coerce, deftype, eql (Type Specifier), Types and Classes Dictionary @subsection coerce [Function] @code{coerce} @i{object result-type} @result{} @i{result} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{result-type}---a @i{type specifier}. @i{result}---an @i{object}, of @i{type} @i{result-type} except in situations described in @ref{Rule of Canonical Representation for Complex Rationals}. @subsubheading Description:: @i{Coerces} the @i{object} to @i{type} @i{result-type}. If @i{object} is already of @i{type} @i{result-type}, the @i{object} itself is returned, regardless of whether it would have been possible in general to coerce an @i{object} of some other @i{type} to @i{result-type}. Otherwise, the @i{object} is @i{coerced} to @i{type} @i{result-type} according to the following rules: @table @asis @item @b{sequence} If the @i{result-type} is a @i{recognizable subtype} of @b{list}, and the @i{object} is a @i{sequence}, then the @i{result} is a @i{list} that has the @i{same} @i{elements} as @i{object}. If the @i{result-type} is a @i{recognizable subtype} of @b{vector}, and the @i{object} is a @i{sequence}, then the @i{result} is a @i{vector} that has the @i{same} @i{elements} as @i{object}. If @i{result-type} is a specialized @i{type}, the @i{result} has an @i{actual array element type} that is the result of @i{upgrading} the element type part of that @i{specialized} @i{type}. If no element type is specified, the element type defaults to @b{t}. If the @i{implementation} cannot determine the element type, an error is signaled. @item @b{character} If the @i{result-type} is @b{character} and the @i{object} is a @i{character designator}, the @i{result} is the @i{character} it denotes. @item @b{complex} If the @i{result-type} is @b{complex} and the @i{object} is a @i{number}, then the @i{result} is obtained by constructing a @i{complex} whose real part is the @i{object} and whose imaginary part is the result of @i{coercing} an @i{integer} zero to the @i{type} of the @i{object} (using @b{coerce}). (If the real part is a @i{rational}, however, then the result must be represented as a @i{rational} rather than a @i{complex}; see @ref{Rule of Canonical Representation for Complex Rationals}. So, for example, @t{(coerce 3 'complex)} is permissible, but will return @t{3}, which is not a @i{complex}.) @item @b{float} If the @i{result-type} is any of @b{float}, @b{short-float}, @b{single-float}, @b{double-float}, @b{long-float}, and the @i{object} is a @i{real}, then the @i{result} is a @i{float} of @i{type} @i{result-type} which is equal in sign and magnitude to the @i{object} to whatever degree of representational precision is permitted by that @i{float} representation. (If the @i{result-type} is @b{float} and @i{object} is not already a @i{float}, then the @i{result} is a @i{single float}.) @item @b{function} If the @i{result-type} is @b{function}, and @i{object} is any @i{function name} that is @i{fbound} but that is globally defined neither as a @i{macro name} nor as a @i{special operator}, then the @i{result} is the @i{functional value} of @i{object}. If the @i{result-type} is @b{function}, and @i{object} is a @i{lambda expression}, then the @i{result} is a @i{closure} of @i{object} in the @i{null lexical environment}. @item @b{t} Any @i{object} can be @i{coerced} to an @i{object} of @i{type} @b{t}. In this case, the @i{object} is simply returned. @end table @subsubheading Examples:: @example (coerce '(a b c) 'vector) @result{} #(A B C) (coerce 'a 'character) @result{} #\A (coerce 4.56 'complex) @result{} #C(4.56 0.0) (coerce 4.5s0 'complex) @result{} #C(4.5s0 0.0s0) (coerce 7/2 'complex) @result{} 7/2 (coerce 0 'short-float) @result{} 0.0s0 (coerce 3.5L0 'float) @result{} 3.5L0 (coerce 7/2 'float) @result{} 3.5 (coerce (cons 1 2) t) @result{} (1 . 2) @end example All the following @i{forms} should signal an error: @example (coerce '(a b c) '(vector * 4)) (coerce #(a b c) '(vector * 4)) (coerce '(a b c) '(vector * 2)) (coerce #(a b c) '(vector * 2)) (coerce "foo" '(string 2)) (coerce #(#\a #\b #\c) '(string 2)) (coerce '(0 1) '(simple-bit-vector 3)) @end example @subsubheading Exceptional Situations:: If a coercion is not possible, an error of @i{type} @b{type-error} is signaled. @t{(coerce x 'nil)} always signals an error of @i{type} @b{type-error}. An error of @i{type} @b{error} is signaled if the @i{result-type} is @b{function} but @i{object} is a @i{symbol} that is not @i{fbound} or if the @i{symbol} names a @i{macro} or a @i{special operator}. An error of @i{type} @b{type-error} should be signaled if @i{result-type} specifies the number of elements and @i{object} is of a different length. @subsubheading See Also:: @ref{rational (Function)} , @ref{floor} , @ref{char-code} , @ref{char-int} @subsubheading Notes:: Coercions from @i{floats} to @i{rationals} and from @i{ratios} to @i{integers} are not provided because of rounding problems. @example (coerce x 't) @equiv{} (identity x) @equiv{} x @end example @node deftype, subtypep, coerce, Types and Classes Dictionary @subsection deftype [Macro] @code{deftype} @i{name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*} @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{lambda-list}---a @i{deftype lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @subsubheading Description:: @b{deftype} defines a @i{derived type specifier} named @i{name}. The meaning of the new @i{type specifier} is given in terms of a function which expands the @i{type specifier} into another @i{type specifier}, which itself will be expanded if it contains references to another @i{derived type specifier}. The newly defined @i{type specifier} may be referenced as a list of the form @t{(@i{name} @i{arg_1} @i{arg_2} ...)\/}. The number of arguments must be appropriate to the @i{lambda-list}. If the new @i{type specifier} takes no arguments, or if all of its arguments are optional, the @i{type specifier} may be used as an @i{atomic type specifier}. The @i{argument} @i{expressions} to the @i{type specifier}, @i{arg_1} ... @i{arg_n}, are not @i{evaluated}. Instead, these @i{literal objects} become the @i{objects} to which corresponding @i{parameters} become @i{bound}. The body of the @b{deftype} @i{form} (but not the @i{lambda-list}) is implicitly enclosed in a @i{block} named @i{name}, and is evaluated as an @i{implicit progn}, returning a new @i{type specifier}. The @i{lexical environment} of the body is the one which was current at the time the @b{deftype} form was evaluated, augmented by the @i{variables} in the @i{lambda-list}. Recursive expansion of the @i{type specifier} returned as the expansion must terminate, including the expansion of @i{type specifiers} which are nested within the expansion. The consequences are undefined if the result of fully expanding a @i{type specifier} contains any circular structure, except within the @i{objects} referred to by @b{member} and @b{eql} @i{type specifiers}. @i{Documentation} is attached to @i{name} as a @i{documentation string} of kind @b{type}. If a @b{deftype} @i{form} appears as a @i{top level form}, the @i{compiler} must ensure that the @i{name} is recognized in subsequent @i{type} declarations. The @i{programmer} must ensure that the body of a @b{deftype} form can be @i{evaluated} at compile time if the @i{name} is referenced in subsequent @i{type} declarations. If the expansion of a @i{type specifier} is not defined fully at compile time (perhaps because it expands into an unknown @i{type specifier} or a @b{satisfies} of a named @i{function} that isn't defined in the compile-time environment), an @i{implementation} may ignore any references to this @i{type} in declarations and/or signal a warning. @subsubheading Examples:: @example (defun equidimensional (a) (or (< (array-rank a) 2) (apply #'= (array-dimensions a)))) @result{} EQUIDIMENSIONAL (deftype square-matrix (&optional type size) `(and (array ,type (,size ,size)) (satisfies equidimensional))) @result{} SQUARE-MATRIX @end example @subsubheading See Also:: @b{declare}, @ref{defmacro} , @ref{documentation} , @ref{Type Specifiers}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @node subtypep, type-of, deftype, Types and Classes Dictionary @subsection subtypep [Function] @code{subtypep} @i{type-1 type-2 @r{&optional} environment} @result{} @i{subtype-p, valid-p} @subsubheading Arguments and Values:: @i{type-1}---a @i{type specifier}. @i{type-2}---a @i{type specifier}. @i{environment}---an @i{environment} @i{object}. The default is @b{nil}, denoting the @i{null lexical environment} and the current @i{global environment}. @i{subtype-p}---a @i{generalized boolean}. @i{valid-p}---a @i{generalized boolean}. @subsubheading Description:: If @i{type-1} is a @i{recognizable subtype} of @i{type-2}, the first @i{value} is @i{true}. Otherwise, the first @i{value} is @i{false}, indicating that either @i{type-1} is not a @i{subtype} of @i{type-2}, or else @i{type-1} is a @i{subtype} of @i{type-2} but is not a @i{recognizable subtype}. A second @i{value} is also returned indicating the `certainty' of the first @i{value}. If this value is @i{true}, then the first value is an accurate indication of the @i{subtype} relationship. (The second @i{value} is always @i{true} when the first @i{value} is @i{true}.) Figure 4--9 summarizes the possible combinations of @i{values} that might result. @format @group @noindent @w{ Value 1 Value 2 Meaning } @w{ @i{true} @i{true} @i{type-1} is definitely a @i{subtype} of @i{type-2}. } @w{ @i{false} @i{true} @i{type-1} is definitely not a @i{subtype} of @i{type-2}. } @w{ @i{false} @i{false} @b{subtypep} could not determine the relationship, } @w{ so @i{type-1} might or might not be a @i{subtype} of @i{type-2}. } @noindent @w{ Figure 4--9: Result possibilities for subtypep } @end group @end format @b{subtypep} is permitted to return the @i{values} @i{false} and @i{false} only when at least one argument involves one of these @i{type specifiers}: @b{and}, @b{eql}, the list form of @b{function}, @b{member}, @b{not}, @b{or}, @b{satisfies}, or @b{values}. (A @i{type specifier} `involves' such a @i{symbol} if, after being @i{type expanded}, it contains that @i{symbol} in a position that would call for its meaning as a @i{type specifier} to be used.) One consequence of this is that if neither @i{type-1} nor @i{type-2} involves any of these @i{type specifiers}, then @b{subtypep} is obliged to determine the relationship accurately. In particular, @b{subtypep} returns the @i{values} @i{true} and @i{true} if the arguments are @b{equal} and do not involve any of these @i{type specifiers}. @b{subtypep} never returns a second value of @b{nil} when both @i{type-1} and @i{type-2} involve only the names in @i{Figure~4--2}, or names of @i{types} defined by @b{defstruct}, @b{define-condition}, or @b{defclass}, or @i{derived types} that expand into only those names. While @i{type specifiers} listed in @i{Figure~4--2} and names of @b{defclass} and @b{defstruct} can in some cases be implemented as @i{derived types}, @b{subtypep} regards them as primitive. The relationships between @i{types} reflected by @b{subtypep} are those specific to the particular implementation. For example, if an implementation supports only a single type of floating-point numbers, in that implementation @t{(subtypep 'float 'long-float)} returns the @i{values} @i{true} and @i{true} (since the two @i{types} are identical). For all @i{T1} and @i{T2} other than @t{*}, @t{(array @i{T1})} and @t{(array @i{T2})} are two different @i{type specifiers} that always refer to the same sets of things if and only if they refer to @i{arrays} of exactly the same specialized representation, @i{i.e.}, if @t{(upgraded-array-element-type '@i{T1})} and @t{(upgraded-array-element-type '@i{T2})} return two different @i{type specifiers} that always refer to the same sets of @i{objects}. This is another way of saying that @t{`(array @i{type-specifier})} and @t{`(array ,(upgraded-array-element-type '@i{type-specifier}))} refer to the same set of specialized @i{array} representations. For all @i{T1} and @i{T2} other than @t{*}, the intersection of @t{(array @i{T1})} and @t{(array @i{T2})} is the empty set if and only if they refer to @i{arrays} of different, distinct specialized representations. Therefore, @example (subtypep '(array T1) '(array T2)) @result{} @i{true} @end example if and only if @example (upgraded-array-element-type 'T1) and (upgraded-array-element-type 'T2) @end example return two different @i{type specifiers} that always refer to the same sets of @i{objects}. For all type-specifiers @i{T1} and @i{T2} other than @t{*}, @example (subtypep '(complex T1) '(complex T2)) @result{} @i{true}, @i{true} @end example if: @table @asis @item 1. @t{T1} is a @i{subtype} of @t{T2}, or @item 2. @t{(upgraded-complex-part-type '@i{T1})} and @t{(upgraded-complex-part-type '@i{T2})} return two different @i{type specifiers} that always refer to the same sets of @i{objects}; in this case, @t{(complex @i{T1})} and @t{(complex @i{T2})} both refer to the same specialized representation. @end table The @i{values} are @i{false} and @i{true} otherwise. The form @example (subtypep '(complex single-float) '(complex float)) @end example must return @i{true} in all implementations, but @example (subtypep '(array single-float) '(array float)) @end example returns @i{true} only in implementations that do not have a specialized @i{array} representation for @i{single floats} distinct from that for other @i{floats}. @subsubheading Examples:: @example (subtypep 'compiled-function 'function) @result{} @i{true}, @i{true} (subtypep 'null 'list) @result{} @i{true}, @i{true} (subtypep 'null 'symbol) @result{} @i{true}, @i{true} (subtypep 'integer 'string) @result{} @i{false}, @i{true} (subtypep '(satisfies dummy) nil) @result{} @i{false}, @i{implementation-dependent} (subtypep '(integer 1 3) '(integer 1 4)) @result{} @i{true}, @i{true} (subtypep '(integer (0) (0)) 'nil) @result{} @i{true}, @i{true} (subtypep 'nil '(integer (0) (0))) @result{} @i{true}, @i{true} (subtypep '(integer (0) (0)) '(member)) @result{} @i{true}, @i{true} ;or @i{false}, @i{false} (subtypep '(member) 'nil) @result{} @i{true}, @i{true} ;or @i{false}, @i{false} (subtypep 'nil '(member)) @result{} @i{true}, @i{true} ;or @i{false}, @i{false} @end example Let @t{} and @t{} be two distinct @i{type specifiers} that do not always refer to the same sets of @i{objects} in a given implementation, but for which @b{make-array}, will return an @i{object} of the same @i{array} @i{type}. Thus, in each case, @example (subtypep (array-element-type (make-array 0 :element-type ')) (array-element-type (make-array 0 :element-type '))) @result{} @i{true}, @i{true} (subtypep (array-element-type (make-array 0 :element-type ')) (array-element-type (make-array 0 :element-type '))) @result{} @i{true}, @i{true} @end example If @t{(array )} and @t{(array )} are different names for exactly the same set of @i{objects}, these names should always refer to the same sets of @i{objects}. That implies that the following set of tests are also true: @example (subtypep '(array ) '(array )) @result{} @i{true}, @i{true} (subtypep '(array ) '(array )) @result{} @i{true}, @i{true} @end example @subsubheading See Also:: @ref{Types} @subsubheading Notes:: The small differences between the @b{subtypep} specification for the @b{array} and @b{complex} types are necessary because there is no creation function for @i{complexes} which allows the specification of the resultant part type independently of the actual types of the parts. Thus in the case of the @i{type} @b{complex}, the actual type of the parts is referred to, although a @i{number} can be a member of more than one @i{type}. For example, @t{17} is of @i{type} @t{(mod 18)} as well as @i{type} @t{(mod 256)} and @i{type} @b{integer}; and @t{2.3f5} is of @i{type} @b{single-float} as well as @i{type} @b{float}. @node type-of, typep, subtypep, Types and Classes Dictionary @subsection type-of [Function] @code{type-of} @i{object} @result{} @i{typespec} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{typespec}---a @i{type specifier}. @subsubheading Description:: Returns a @i{type specifier}, @i{typespec}, for a @i{type} that has the @i{object} as an @i{element}. The @i{typespec} satisfies the following: @table @asis @item 1. For any @i{object} that is an @i{element} of some @i{built-in type}: @table @asis @item a. the @i{type} returned is a @i{recognizable subtype} of that @i{built-in type}. @item b. the @i{type} returned does not involve @t{and}, @t{eql}, @t{member}, @t{not}, @t{or}, @t{satisfies}, or @t{values}. @end table @item 2. For all @i{objects}, @t{(typep @i{object} (type-of @i{object}))} returns @i{true}. Implicit in this is that @i{type specifiers} which are not valid for use with @b{typep}, such as the @i{list} form of the @b{function} @i{type specifier}, are never returned by @b{type-of}. @item 3. The @i{type} returned by @b{type-of} is always a @i{recognizable subtype} of the @i{class} returned by @b{class-of}. That is, @example (subtypep (type-of @i{object}) (class-of @i{object})) @result{} @i{true}, @i{true} @end example @item 4. For @i{objects} of metaclass @b{structure-class} or @b{standard-class}, and for @i{conditions}, @b{type-of} returns the @i{proper name} of the @i{class} returned by @b{class-of} if it has a @i{proper name}, and otherwise returns the @i{class} itself. In particular, for @i{objects} created by the constructor function of a structure defined with @b{defstruct} without a @t{:type} option, @b{type-of} returns the structure name; and for @i{objects} created by @b{make-condition}, the @i{typespec} is the @i{name} of the @i{condition} @i{type}. @item 5. For each of the @i{types} @b{short-float}, @b{single-float}, @b{double-float}, or @b{long-float} of which the @i{object} is an @i{element}, the @i{typespec} is a @i{recognizable subtype} of that @i{type}. @end table @subsubheading Examples:: @example @end example @example (type-of 'a) @result{} SYMBOL (type-of '(1 . 2)) @result{} CONS @i{OR}@result{} (CONS FIXNUM FIXNUM) (type-of #c(0 1)) @result{} COMPLEX @i{OR}@result{} (COMPLEX INTEGER) (defstruct temp-struct x y z) @result{} TEMP-STRUCT (type-of (make-temp-struct)) @result{} TEMP-STRUCT (type-of "abc") @result{} STRING @i{OR}@result{} (STRING 3) (subtypep (type-of "abc") 'string) @result{} @i{true}, @i{true} (type-of (expt 2 40)) @result{} BIGNUM @i{OR}@result{} INTEGER @i{OR}@result{} (INTEGER 1099511627776 1099511627776) @i{OR}@result{} SYSTEM::TWO-WORD-BIGNUM @i{OR}@result{} FIXNUM (subtypep (type-of 112312) 'integer) @result{} @i{true}, @i{true} (defvar *foo* (make-array 5 :element-type t)) @result{} *FOO* (class-name (class-of *foo*)) @result{} VECTOR (type-of *foo*) @result{} VECTOR @i{OR}@result{} (VECTOR T 5) @end example @subsubheading See Also:: @ref{array-element-type} , @ref{class-of} , @ref{defstruct} , @ref{typecase} , @ref{typep} , @ref{Types} @subsubheading Notes:: Implementors are encouraged to arrange for @b{type-of} to return a portable value. @node typep, type-error, type-of, Types and Classes Dictionary @subsection typep [Function] @code{typep} @i{object type-specifier @r{&optional} environment} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{type-specifier}---any @i{type specifier} except @b{values}, or a @i{type specifier} list whose first element is either @b{function} or @b{values}. @i{environment}---an @i{environment} @i{object}. The default is @b{nil}, denoting the @i{null lexical environment} and the and current @i{global environment}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of the @i{type} specified by @i{type-specifier}; otherwise, returns @i{false}. A @i{type-specifier} of the form @t{(satisfies fn)} is handled by applying the function @t{fn} to @i{object}. @t{(typep @i{object} '(array @i{type-specifier}))}, where @i{type-specifier} is not @t{*}, returns @i{true} if and only if @i{object} is an @i{array} that could be the result of supplying @i{type-specifier} as the @t{:element-type} argument to @b{make-array}. @t{(array *)} refers to all @i{arrays} regardless of element type, while @t{(array @i{type-specifier})} refers only to those @i{arrays} that can result from giving @i{type-specifier} as the @t{:element-type} argument to @b{make-array}. A similar interpretation applies to @t{(simple-array @i{type-specifier})} and @t{(vector @i{type-specifier})}. See @ref{Array Upgrading}. @t{(typep @i{object} '(complex @i{type-specifier}))} returns @i{true} for all @i{complex} numbers that can result from giving @i{numbers} of type @i{type-specifier} to the @i{function} @b{complex}, plus all other @i{complex} numbers of the same specialized representation. Both the real and the imaginary parts of any such @i{complex} number must satisfy: @example (typep realpart 'type-specifier) (typep imagpart 'type-specifier) @end example See the @i{function} @b{upgraded-complex-part-type}. @subsubheading Examples:: @example (typep 12 'integer) @result{} @i{true} (typep (1+ most-positive-fixnum) 'fixnum) @result{} @i{false} (typep nil t) @result{} @i{true} (typep nil nil) @result{} @i{false} (typep 1 '(mod 2)) @result{} @i{true} (typep #c(1 1) '(complex (eql 1))) @result{} @i{true} ;; To understand this next example, you might need to refer to ;; @ref{Rule of Canonical Representation for Complex Rationals}. (typep #c(0 0) '(complex (eql 0))) @result{} @i{false} @end example Let @t{A_x} and @t{A_y} be two @i{type specifiers} that denote different @i{types}, but for which @example (upgraded-array-element-type 'A_x) @end example and @example (upgraded-array-element-type 'A_y) @end example denote the same @i{type}. Notice that @example (typep (make-array 0 :element-type 'A_x) '(array A_x)) @result{} @i{true} (typep (make-array 0 :element-type 'A_y) '(array A_y)) @result{} @i{true} (typep (make-array 0 :element-type 'A_x) '(array A_y)) @result{} @i{true} (typep (make-array 0 :element-type 'A_y) '(array A_x)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{error} is signaled if @i{type-specifier} is @t{values}, or a @i{type specifier} list whose first element is either @b{function} or @b{values}. The consequences are undefined if the @i{type-specifier} is not a @i{type specifier}. @subsubheading See Also:: @ref{type-of} , @ref{upgraded-array-element-type} , @ref{upgraded-complex-part-type} , @ref{Type Specifiers} @subsubheading Notes:: @i{Implementations} are encouraged to recognize and optimize the case of @t{(typep @i{x} (the class @i{y}))}, since it does not involve any need for expansion of @b{deftype} information at runtime. @example @end example @node type-error, type-error-datum, typep, Types and Classes Dictionary @subsection type-error [Condition Type] @subsubheading Class Precedence List:: @b{type-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{type-error} represents a situation in which an @i{object} is not of the expected type. The ``offending datum'' and ``expected type'' are initialized by the initialization arguments named @t{:datum} and @t{:expected-type} to @b{make-condition}, and are @i{accessed} by the functions @b{type-error-datum} and @b{type-error-expected-type}. @subsubheading See Also:: @ref{type-error-datum} , @b{type-error-expected-type} @node type-error-datum, simple-type-error, type-error, Types and Classes Dictionary @subsection type-error-datum, type-error-expected-type [Function] @code{type-error-datum} @i{condition} @result{} @i{datum} @code{type-error-expected-type} @i{condition} @result{} @i{expected-type} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{type-error}. @i{datum}---an @i{object}. @i{expected-type}---a @i{type specifier}. @subsubheading Description:: @b{type-error-datum} returns the offending datum in the @i{situation} represented by the @i{condition}. @b{type-error-expected-type} returns the expected type of the offending datum in the @i{situation} represented by the @i{condition}. @subsubheading Examples:: @example (defun fix-digits (condition) (check-type condition type-error) (let* ((digits '(zero one two three four five six seven eight nine)) (val (position (type-error-datum condition) digits))) (if (and val (subtypep 'fixnum (type-error-expected-type condition))) (store-value 7)))) (defun foo (x) (handler-bind ((type-error #'fix-digits)) (check-type x number) (+ x 3))) (foo 'seven) @result{} 10 @end example @subsubheading See Also:: @b{type-error}, @ref{Conditions} @node simple-type-error, , type-error-datum, Types and Classes Dictionary @subsection simple-type-error [Condition Type] @subsubheading Class Precedence List:: @b{simple-type-error}, @b{simple-condition}, @b{type-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: @i{Conditions} of @i{type} @b{simple-type-error} are like @i{conditions} of @i{type} @b{type-error}, except that they provide an alternate mechanism for specifying how the @i{condition} is to be @i{reported}; see the @i{type} @b{simple-condition}. @subsubheading See Also:: @b{simple-condition}, @ref{simple-condition-format-control} , @b{simple-condition-format-arguments}, @ref{type-error-datum} , @b{type-error-expected-type} @c end of including dict-types @c %**end of chapter gcl-2.6.14/info/c-interface.texi0000755000175000017500000000114014360276512015000 0ustar cammcamm@c Copyright (c) 1994 William Schelter. @node C Interface, System Definitions, GCL Specific, Top @chapter C Interface @menu * Available Symbols:: @end menu @node Available Symbols, , C Interface, C Interface @section Available Symbols When GCL is built, those symbols in the system libraries which are referenced by functions linked in in the list of objects given in @file{unixport/makefile}, become available for reference by GCL code. On some systems it is possible with @code{faslink} to load @file{.o} files which reference other libraries, but in general this practice is not portable. gcl-2.6.14/info/gcl.info-80000644000175000017500000111470614360276512013527 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: Printer, Next: Reader, Prev: Streams, Up: Top 22 Printer ********** * Menu: * The Lisp Printer:: * The Lisp Pretty Printer:: * Formatted Output:: * Printer Dictionary::  File: gcl.info, Node: The Lisp Printer, Next: The Lisp Pretty Printer, Prev: Printer, Up: Printer 22.1 The Lisp Printer ===================== * Menu: * Overview of The Lisp Printer:: * Printer Dispatching:: * Default Print-Object Methods:: * Examples of Printer Behavior::  File: gcl.info, Node: Overview of The Lisp Printer, Next: Printer Dispatching, Prev: The Lisp Printer, Up: The Lisp Printer 22.1.1 Overview of The Lisp Printer ----------------------------------- Common Lisp provides a representation of most objects in the form of printed text called the printed representation. Functions such as print take an object and send the characters of its printed representation to a stream. The collection of routines that does this is known as the (Common Lisp) printer. Reading a printed representation typically produces an object that is equal to the originally printed object. * Menu: * Multiple Possible Textual Representations:: * Printer Escaping::  File: gcl.info, Node: Multiple Possible Textual Representations, Next: Printer Escaping, Prev: Overview of The Lisp Printer, Up: Overview of The Lisp Printer 22.1.1.1 Multiple Possible Textual Representations .................................................. Most objects have more than one possible textual representation. For example, the positive integer with a magnitude of twenty-seven can be textually expressed in any of these ways: 27 27. #o33 #x1B #b11011 #.(* 3 3 3) 81/3 A list containing the two symbols A and B can also be textually expressed in a variety of ways: (A B) (a b) ( a b ) (\A |B|) (|\A| B ) In general, from the point of view of the Lisp reader, wherever whitespace is permissible in a textual representation, any number of spaces and newlines can appear in standard syntax. When a function such as print produces a printed representation, it must choose from among many possible textual representations. In most cases, it chooses a program readable representation, but in certain cases it might use a more compact notation that is not program-readable. A number of option variables, called printer control variables , are provided to permit control of individual aspects of the printed representation of objects. Figure 22-1 shows the standardized printer control variables; there might also be implementation-defined printer control variables. *print-array* *print-gensym* *print-pprint-dispatch* *print-base* *print-length* *print-pretty* *print-case* *print-level* *print-radix* *print-circle* *print-lines* *print-readably* *print-escape* *print-miser-width* *print-right-margin* Figure 22-1: Standardized Printer Control Variables In addition to the printer control variables, the following additional defined names relate to or affect the behavior of the Lisp printer: *package* *read-eval* readtable-case *read-default-float-format* *readtable* Figure 22-2: Additional Influences on the Lisp printer.  File: gcl.info, Node: Printer Escaping, Prev: Multiple Possible Textual Representations, Up: Overview of The Lisp Printer 22.1.1.2 Printer Escaping ......................... The variable *print-escape* controls whether the Lisp printer tries to produce notations such as escape characters and package prefixes. The variable *print-readably* can be used to override many of the individual aspects controlled by the other printer control variables when program-readable output is especially important. One of the many effects of making the value of *print-readably* be true is that the Lisp printer behaves as if *print-escape* were also true. For notational convenience, we say that if the value of either *print-readably* or *print-escape* is true, then printer escaping is "enabled"; and we say that if the values of both *print-readably* and *print-escape* are false, then printer escaping is "disabled".  File: gcl.info, Node: Printer Dispatching, Next: Default Print-Object Methods, Prev: Overview of The Lisp Printer, Up: The Lisp Printer 22.1.2 Printer Dispatching -------------------------- The Lisp printer makes its determination of how to print an object as follows: If the value of *print-pretty* is true, printing is controlled by the current pprint dispatch table; see *note Pretty Print Dispatch Tables::. Otherwise (if the value of *print-pretty* is false), the object's print-object method is used; see *note Default Print-Object Methods::.  File: gcl.info, Node: Default Print-Object Methods, Next: Examples of Printer Behavior, Prev: Printer Dispatching, Up: The Lisp Printer 22.1.3 Default Print-Object Methods ----------------------------------- This section describes the default behavior of print-object methods for the standardized types. * Menu: * Printing Numbers:: * Printing Integers:: * Printing Ratios:: * Printing Floats:: * Printing Complexes:: * Note about Printing Numbers:: * Printing Characters:: * Printing Symbols:: * Package Prefixes for Symbols:: * Effect of Readtable Case on the Lisp Printer:: * Examples of Effect of Readtable Case on the Lisp Printer:: * Printing Strings:: * Printing Lists and Conses:: * Printing Bit Vectors:: * Printing Other Vectors:: * Printing Other Arrays:: * Examples of Printing Arrays:: * Printing Random States:: * Printing Pathnames:: * Printing Structures:: * Printing Other Objects::  File: gcl.info, Node: Printing Numbers, Next: Printing Integers, Prev: Default Print-Object Methods, Up: Default Print-Object Methods 22.1.3.1 Printing Numbers .........................  File: gcl.info, Node: Printing Integers, Next: Printing Ratios, Prev: Printing Numbers, Up: Default Print-Object Methods 22.1.3.2 Printing Integers .......................... Integers are printed in the radix specified by the current output base in positional notation, most significant digit first. If appropriate, a radix specifier can be printed; see *print-radix*. If an integer is negative, a minus sign is printed and then the absolute value of the integer is printed. The integer zero is represented by the single digit 0 and never has a sign. A decimal point might be printed, depending on the value of *print-radix*. For related information about the syntax of an integer, see *note Syntax of an Integer::.  File: gcl.info, Node: Printing Ratios, Next: Printing Floats, Prev: Printing Integers, Up: Default Print-Object Methods 22.1.3.3 Printing Ratios ........................ Ratios are printed as follows: the absolute value of the numerator is printed, as for an integer; then a /; then the denominator. The numerator and denominator are both printed in the radix specified by the current output base; they are obtained as if by numerator and denominator, and so ratios are printed in reduced form (lowest terms). If appropriate, a radix specifier can be printed; see *print-radix*. If the ratio is negative, a minus sign is printed before the numerator. For related information about the syntax of a ratio, see *note Syntax of a Ratio::.  File: gcl.info, Node: Printing Floats, Next: Printing Complexes, Prev: Printing Ratios, Up: Default Print-Object Methods 22.1.3.4 Printing Floats ........................ If the magnitude of the float is either zero or between 10^-3 (inclusive) and 10^7 (exclusive), it is printed as the integer part of the number, then a decimal point, followed by the fractional part of the number; there is always at least one digit on each side of the decimal point. If the sign of the number (as determined by float-sign) is negative, then a minus sign is printed before the number. If the format of the number does not match that specified by *read-default-float-format*, then the exponent marker for that format and the digit 0 are also printed. For example, the base of the natural logarithms as a short float might be printed as 2.71828S0. For non-zero magnitudes outside of the range 10^-3 to 10^7, a float is printed in computerized scientific notation. The representation of the number is scaled to be between 1 (inclusive) and 10 (exclusive) and then printed, with one digit before the decimal point and at least one digit after the decimal point. Next the exponent marker for the format is printed, except that if the format of the number matches that specified by *read-default-float-format*, then the exponent marker E is used. Finally, the power of ten by which the fraction must be multiplied to equal the original number is printed as a decimal integer. For example, Avogadro's number as a short float is printed as 6.02S23. For related information about the syntax of a float, see *note Syntax of a Float::.  File: gcl.info, Node: Printing Complexes, Next: Note about Printing Numbers, Prev: Printing Floats, Up: Default Print-Object Methods 22.1.3.5 Printing Complexes ........................... A complex is printed as #C, an open parenthesis, the printed representation of its real part, a space, the printed representation of its imaginary part, and finally a close parenthesis. For related information about the syntax of a complex, see *note Syntax of a Complex:: and *note Sharpsign C::.  File: gcl.info, Node: Note about Printing Numbers, Next: Printing Characters, Prev: Printing Complexes, Up: Default Print-Object Methods 22.1.3.6 Note about Printing Numbers .................................... The printed representation of a number must not contain escape characters; see *note Escape Characters and Potential Numbers::.  File: gcl.info, Node: Printing Characters, Next: Printing Symbols, Prev: Note about Printing Numbers, Up: Default Print-Object Methods 22.1.3.7 Printing Characters ............................ When printer escaping is disabled, a character prints as itself; it is sent directly to the output stream. When printer escaping is enabled, then #\ syntax is used. When the printer types out the name of a character, it uses the same table as the #\ reader macro would use; therefore any character name that is typed out is acceptable as input (in that implementation). If a non-graphic character has a standardized name_5, that name is preferred over non-standard names for printing in #\ notation. For the graphic standard characters, the character itself is always used for printing in #\ notation--even if the character also has a name_5. For details about the #\ reader macro, see *note Sharpsign Backslash::.  File: gcl.info, Node: Printing Symbols, Next: Package Prefixes for Symbols, Prev: Printing Characters, Up: Default Print-Object Methods 22.1.3.8 Printing Symbols ......................... When printer escaping is disabled, only the characters of the symbol's name are output (but the case in which to print characters in the name is controlled by *print-case*; see *note Effect of Readtable Case on the Lisp Printer::). The remainder of this section applies only when printer escaping is enabled. When printing a symbol, the printer inserts enough single escape and/or multiple escape characters (backslashes and/or vertical-bars) so that if read were called with the same *readtable* and with *read-base* bound to the current output base, it would return the same symbol (if it is not apparently uninterned) or an uninterned symbol with the same print name (otherwise). For example, if the value of *print-base* were 16 when printing the symbol face, it would have to be printed as \FACE or \Face or |FACE|, because the token face would be read as a hexadecimal number (decimal value 64206) if the value of *read-base* were 16. For additional restrictions concerning characters with nonstandard syntax types in the current readtable, see the variable *print-readably* For information about how the Lisp reader parses symbols, see *note Symbols as Tokens:: and *note Sharpsign Colon::. nil might be printed as () when *print-pretty* is true and printer escaping is enabled.  File: gcl.info, Node: Package Prefixes for Symbols, Next: Effect of Readtable Case on the Lisp Printer, Prev: Printing Symbols, Up: Default Print-Object Methods 22.1.3.9 Package Prefixes for Symbols ..................................... Package prefixes are printed if necessary. The rules for package prefixes are as follows. When the symbol is printed, if it is in the KEYWORD package, then it is printed with a preceding colon; otherwise, if it is accessible in the current package, it is printed without any package prefix; otherwise, it is printed with a package prefix. A symbol that is apparently uninterned is printed preceded by "#:" if *print-gensym* is true and printer escaping is enabled; if *print-gensym* is false or printer escaping is disabled, then the symbol is printed without a prefix, as if it were in the current package. Because the #: syntax does not intern the following symbol, it is necessary to use circular-list syntax if *print-circle* is true and the same uninterned symbol appears several times in an expression to be printed. For example, the result of (let ((x (make-symbol "FOO"))) (list x x)) would be printed as (#:foo #:foo) if *print-circle* were false, but as (#1=#:foo #1#) if *print-circle* were true. A summary of the preceding package prefix rules follows: foo:bar foo:bar is printed when symbol bar is external in its home package foo and is not accessible in the current package. foo::bar foo::bar is printed when bar is internal in its home package foo and is not accessible in the current package. :bar :bar is printed when the home package of bar is the KEYWORD package. #:bar #:bar is printed when bar is apparently uninterned, even in the pathological case that bar has no home package but is nevertheless somehow accessible in the current package.  File: gcl.info, Node: Effect of Readtable Case on the Lisp Printer, Next: Examples of Effect of Readtable Case on the Lisp Printer, Prev: Package Prefixes for Symbols, Up: Default Print-Object Methods 22.1.3.10 Effect of Readtable Case on the Lisp Printer ...................................................... When printer escaping is disabled, or the characters under consideration are not already quoted specifically by single escape or multiple escape syntax, the readtable case of the current readtable affects the way the Lisp printer writes symbols in the following ways: :upcase When the readtable case is :upcase, uppercase characters are printed in the case specified by *print-case*, and lowercase characters are printed in their own case. :downcase When the readtable case is :downcase, uppercase characters are printed in their own case, and lowercase characters are printed in the case specified by *print-case*. :preserve When the readtable case is :preserve, all alphabetic characters are printed in their own case. :invert When the readtable case is :invert, the case of all alphabetic characters in single case symbol names is inverted. Mixed-case symbol names are printed as is. The rules for escaping alphabetic characters in symbol names are affected by the readtable-case if printer escaping is enabled. Alphabetic characters are escaped as follows: :upcase When the readtable case is :upcase, all lowercase characters must be escaped. :downcase When the readtable case is :downcase, all uppercase characters must be escaped. :preserve When the readtable case is :preserve, no alphabetic characters need be escaped. :invert When the readtable case is :invert, no alphabetic characters need be escaped.  File: gcl.info, Node: Examples of Effect of Readtable Case on the Lisp Printer, Next: Printing Strings, Prev: Effect of Readtable Case on the Lisp Printer, Up: Default Print-Object Methods 22.1.3.11 Examples of Effect of Readtable Case on the Lisp Printer .................................................................. (defun test-readtable-case-printing () (let ((*readtable* (copy-readtable nil)) (*print-case* *print-case*)) (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output~ ~ ~ (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (print-case '(:upcase :downcase :capitalize)) (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) (setq *print-case* print-case) (format t "~&:~A~15T:~A~29T~A~42T~A" (string-upcase readtable-case) (string-upcase print-case) (symbol-name symbol) (prin1-to-string symbol))))))) The output from (test-readtable-case-printing) should be as follows: READTABLE-CASE *PRINT-CASE* Symbol-name Output -------------------------------------------------- :UPCASE :UPCASE ZEBRA ZEBRA :UPCASE :UPCASE Zebra |Zebra| :UPCASE :UPCASE zebra |zebra| :UPCASE :DOWNCASE ZEBRA zebra :UPCASE :DOWNCASE Zebra |Zebra| :UPCASE :DOWNCASE zebra |zebra| :UPCASE :CAPITALIZE ZEBRA Zebra :UPCASE :CAPITALIZE Zebra |Zebra| :UPCASE :CAPITALIZE zebra |zebra| :DOWNCASE :UPCASE ZEBRA |ZEBRA| :DOWNCASE :UPCASE Zebra |Zebra| :DOWNCASE :UPCASE zebra ZEBRA :DOWNCASE :DOWNCASE ZEBRA |ZEBRA| :DOWNCASE :DOWNCASE Zebra |Zebra| :DOWNCASE :DOWNCASE zebra zebra :DOWNCASE :CAPITALIZE ZEBRA |ZEBRA| :DOWNCASE :CAPITALIZE Zebra |Zebra| :DOWNCASE :CAPITALIZE zebra Zebra :PRESERVE :UPCASE ZEBRA ZEBRA :PRESERVE :UPCASE Zebra Zebra :PRESERVE :UPCASE zebra zebra :PRESERVE :DOWNCASE ZEBRA ZEBRA :PRESERVE :DOWNCASE Zebra Zebra :PRESERVE :DOWNCASE zebra zebra :PRESERVE :CAPITALIZE ZEBRA ZEBRA :PRESERVE :CAPITALIZE Zebra Zebra :PRESERVE :CAPITALIZE zebra zebra :INVERT :UPCASE ZEBRA zebra :INVERT :UPCASE Zebra Zebra :INVERT :UPCASE zebra ZEBRA :INVERT :DOWNCASE ZEBRA zebra :INVERT :DOWNCASE Zebra Zebra :INVERT :DOWNCASE zebra ZEBRA :INVERT :CAPITALIZE ZEBRA zebra :INVERT :CAPITALIZE Zebra Zebra :INVERT :CAPITALIZE zebra ZEBRA  File: gcl.info, Node: Printing Strings, Next: Printing Lists and Conses, Prev: Examples of Effect of Readtable Case on the Lisp Printer, Up: Default Print-Object Methods 22.1.3.12 Printing Strings .......................... The characters of the string are output in order. If printer escaping is enabled, a double-quote is output before and after, and all double-quotes and single escapes are preceded by backslash. The printing of strings is not affected by *print-array*. Only the active elements of the string are printed. For information on how the Lisp reader parses strings, see *note Double-Quote::.  File: gcl.info, Node: Printing Lists and Conses, Next: Printing Bit Vectors, Prev: Printing Strings, Up: Default Print-Object Methods 22.1.3.13 Printing Lists and Conses ................................... Wherever possible, list notation is preferred over dot notation. Therefore the following algorithm is used to print a cons x: 1. A left-parenthesis is printed. 2. The car of x is printed. 3. If the cdr of x is itself a cons, it is made to be the current cons (i.e., x becomes that cons), a space is printed, and step 2 is re-entered. 4. If the cdr of x is not null, a space, a dot, a space, and the cdr of x are printed. 5. A right-parenthesis is printed. Actually, the above algorithm is only used when *print-pretty* is false. When *print-pretty* is true (or when pprint is used), additional whitespace_1 may replace the use of a single space, and a more elaborate algorithm with similar goals but more presentational flexibility is used; see *note Printer Dispatching::. Although the two expressions below are equivalent, and the reader accepts either one and produces the same cons, the printer always prints such a cons in the second form. (a . (b . ((c . (d . nil)) . (e . nil)))) (a b (c d) e) The printing of conses is affected by *print-level*, *print-length*, and *print-circle*. Following are examples of printed representations of lists: (a . b) ;A dotted pair of a and b (a.b) ;A list of one element, the symbol named a.b (a. b) ;A list of two elements a. and b (a .b) ;A list of two elements a and .b (a b . c) ;A dotted list of a and b with c at the end; two conses .iot ;The symbol whose name is .iot (. b) ;Invalid -- an error is signaled if an attempt is made to read ;this syntax. (a .) ;Invalid -- an error is signaled. (a .. b) ;Invalid -- an error is signaled. (a . . b) ;Invalid -- an error is signaled. (a b c ...) ;Invalid -- an error is signaled. (a \. b) ;A list of three elements a, ., and b (a |.| b) ;A list of three elements a, ., and b (a \... b) ;A list of three elements a, ..., and b (a |...| b) ;A list of three elements a, ..., and b For information on how the Lisp reader parses lists and conses, see *note Left-Parenthesis::.  File: gcl.info, Node: Printing Bit Vectors, Next: Printing Other Vectors, Prev: Printing Lists and Conses, Up: Default Print-Object Methods 22.1.3.14 Printing Bit Vectors .............................. A bit vector is printed as #* followed by the bits of the bit vector in order. If *print-array* is false, then the bit vector is printed in a format (using #<) that is concise but not readable. Only the active elements of the bit vector are printed. [Reviewer Note by Barrett: Need to provide for #5*0 as an alternate notation for #*00000.] For information on Lisp reader parsing of bit vectors, see *note Sharpsign Asterisk::.  File: gcl.info, Node: Printing Other Vectors, Next: Printing Other Arrays, Prev: Printing Bit Vectors, Up: Default Print-Object Methods 22.1.3.15 Printing Other Vectors ................................ If *print-array* is true and *print-readably* is false, any vector other than a string or bit vector is printed using general-vector syntax; this means that information about specialized vector representations does not appear. The printed representation of a zero-length vector is #(). The printed representation of a non-zero-length vector begins with #(. Following that, the first element of the vector is printed. If there are any other elements, they are printed in turn, with each such additional element preceded by a space if *print-pretty* is false, or whitespace_1 if *print-pretty* is true. A right-parenthesis after the last element terminates the printed representation of the vector. The printing of vectors is affected by *print-level* and *print-length*. If the vector has a fill pointer, then only those elements below the fill pointer are printed. If both *print-array* and *print-readably* are false, the vector is not printed as described above, but in a format (using #<) that is concise but not readable. If *print-readably* is true, the vector prints in an implementation-defined manner; see the variable *print-readably*. For information on how the Lisp reader parses these "other vectors," see *note Sharpsign Left-Parenthesis::.  File: gcl.info, Node: Printing Other Arrays, Next: Examples of Printing Arrays, Prev: Printing Other Vectors, Up: Default Print-Object Methods 22.1.3.16 Printing Other Arrays ............................... If *print-array* is true and *print-readably* is false, any array other than a vector is printed using #nA format. Let n be the rank of the array. Then # is printed, then n as a decimal integer, then A, then n open parentheses. Next the elements are scanned in row-major order, using write on each element, and separating elements from each other with whitespace_1. The array's dimensions are numbered 0 to n-1 from left to right, and are enumerated with the rightmost index changing fastest. Every time the index for dimension j is incremented, the following actions are taken: * If j < n-1, then a close parenthesis is printed. * If incrementing the index for dimension j caused it to equal dimension j, that index is reset to zero and the index for dimension j-1 is incremented (thereby performing these three steps recursively), unless j=0, in which case the entire algorithm is terminated. If incrementing the index for dimension j did not cause it to equal dimension j, then a space is printed. * If j < n-1, then an open parenthesis is printed. This causes the contents to be printed in a format suitable for :initial-contents to make-array. The lists effectively printed by this procedure are subject to truncation by *print-level* and *print-length*. If the array is of a specialized type, containing bits or characters, then the innermost lists generated by the algorithm given above can instead be printed using bit-vector or string syntax, provided that these innermost lists would not be subject to truncation by *print-length*. If both *print-array* and *print-readably* are false, then the array is printed in a format (using #<) that is concise but not readable. If *print-readably* is true, the array prints in an implementation-defined manner; see the variable *print-readably*. In particular, this may be important for arrays having some dimension 0. For information on how the Lisp reader parses these "other arrays," see *note Sharpsign A::.  File: gcl.info, Node: Examples of Printing Arrays, Next: Printing Random States, Prev: Printing Other Arrays, Up: Default Print-Object Methods 22.1.3.17 Examples of Printing Arrays ..................................... (let ((a (make-array '(3 3))) (*print-pretty* t) (*print-array* t)) (dotimes (i 3) (dotimes (j 3) (setf (aref a i j) (format nil "<~D,~D>" i j)))) (print a) (print (make-array 9 :displaced-to a))) |> #2A(("<0,0>" "<0,1>" "<0,2>") |> ("<1,0>" "<1,1>" "<1,2>") |> ("<2,0>" "<2,1>" "<2,2>")) |> #("<0,0>" "<0,1>" "<0,2>" "<1,0>" "<1,1>" "<1,2>" "<2,0>" "<2,1>" "<2,2>") => #  File: gcl.info, Node: Printing Random States, Next: Printing Pathnames, Prev: Examples of Printing Arrays, Up: Default Print-Object Methods 22.1.3.18 Printing Random States ................................ A specific syntax for printing objects of type random-state is not specified. However, every implementation must arrange to print a random state object in such a way that, within the same implementation, read can construct from the printed representation a copy of the random state object as if the copy had been made by make-random-state. If the type random state is effectively implemented by using the machinery for defstruct, the usual structure syntax can then be used for printing random state objects; one might look something like #S(RANDOM-STATE :DATA #(14 49 98436589 786345 8734658324 ... )) where the components are implementation-dependent.  File: gcl.info, Node: Printing Pathnames, Next: Printing Structures, Prev: Printing Random States, Up: Default Print-Object Methods 22.1.3.19 Printing Pathnames ............................ When printer escaping is enabled, the syntax #P"..." is how a pathname is printed by write and the other functions herein described. The "..." is the namestring representation of the pathname. When printer escaping is disabled, write writes a pathname P by writing (namestring P) instead. For information on how the Lisp reader parses pathnames, see *note Sharpsign P::.  File: gcl.info, Node: Printing Structures, Next: Printing Other Objects, Prev: Printing Pathnames, Up: Default Print-Object Methods 22.1.3.20 Printing Structures ............................. By default, a structure of type S is printed using #S syntax. This behavior can be customized by specifying a :print-function or :print-object option to the defstruct form that defines S, or by writing a print-object method that is specialized for objects of type S. Different structures might print out in different ways; the default notation for structures is: #S(structure-name {slot-key slot-value}*) where #S indicates structure syntax, structure-name is a structure name, each slot-key is an initialization argument name for a slot in the structure, and each corresponding slot-value is a representation of the object in that slot. For information on how the Lisp reader parses structures, see *note Sharpsign S::.  File: gcl.info, Node: Printing Other Objects, Prev: Printing Structures, Up: Default Print-Object Methods 22.1.3.21 Printing Other Objects ................................ Other objects are printed in an implementation-dependent manner. It is not required that an implementation print those objects readably. For example, hash tables, readtables, packages, streams, and functions might not print readably. A common notation to use in this circumstance is #<...>. Since #< is not readable by the Lisp reader, the precise format of the text which follows is not important, but a common format to use is that provided by the print-unreadable-object macro. For information on how the Lisp reader treats this notation, see *note Sharpsign Less-Than-Sign::. For information on how to notate objects that cannot be printed readably, see *note Sharpsign Dot::.  File: gcl.info, Node: Examples of Printer Behavior, Prev: Default Print-Object Methods, Up: The Lisp Printer 22.1.4 Examples of Printer Behavior ----------------------------------- (let ((*print-escape* t)) (fresh-line) (write #\a)) |> #\a => #\a (let ((*print-escape* nil) (*print-readably* nil)) (fresh-line) (write #\a)) |> a => #\a (progn (fresh-line) (prin1 #\a)) |> #\a => #\a (progn (fresh-line) (print #\a)) |> |> #\a => #\a (progn (fresh-line) (princ #\a)) |> a => #\a (dolist (val '(t nil)) (let ((*print-escape* val) (*print-readably* val)) (print '#\a) (prin1 #\a) (write-char #\Space) (princ #\a) (write-char #\Space) (write #\a))) |> #\a #\a a #\a |> #\a #\a a a => NIL (progn (fresh-line) (write '(let ((a 1) (b 2)) (+ a b)))) |> (LET ((A 1) (B 2)) (+ A B)) => (LET ((A 1) (B 2)) (+ A B)) (progn (fresh-line) (pprint '(let ((a 1) (b 2)) (+ a b)))) |> (LET ((A 1) |> (B 2)) |> (+ A B)) => (LET ((A 1) (B 2)) (+ A B)) (progn (fresh-line) (write '(let ((a 1) (b 2)) (+ a b)) :pretty t)) |> (LET ((A 1) |> (B 2)) |> (+ A B)) => (LET ((A 1) (B 2)) (+ A B)) (with-output-to-string (s) (write 'write :stream s) (prin1 'prin1 s)) => "WRITEPRIN1"  File: gcl.info, Node: The Lisp Pretty Printer, Next: Formatted Output, Prev: The Lisp Printer, Up: Printer 22.2 The Lisp Pretty Printer ============================ * Menu: * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: * Notes about the Pretty Printer`s Background::  File: gcl.info, Node: Pretty Printer Concepts, Next: Examples of using the Pretty Printer, Prev: The Lisp Pretty Printer, Up: The Lisp Pretty Printer 22.2.1 Pretty Printer Concepts ------------------------------ The facilities provided by the pretty printer permit programs to redefine the way in which code is displayed, and allow the full power of pretty printing to be applied to complex combinations of data structures. Whether any given style of output is in fact "pretty" is inherently a somewhat subjective issue. However, since the effect of the pretty printer can be customized by conforming programs, the necessary flexibility is provided for individual programs to achieve an arbitrary degree of aesthetic control. By providing direct access to the mechanisms within the pretty printer that make dynamic decisions about layout, the macros and functions pprint-logical-block, pprint-newline, and pprint-indent make it possible to specify pretty printing layout rules as a part of any function that produces output. They also make it very easy for the detection of circularity and sharing, and abbreviation based on length and nesting depth to be supported by the function. The pretty printer is driven entirely by dispatch based on the value of *print-pprint-dispatch*. The function set-pprint-dispatch makes it possible for conforming programs to associate new pretty printing functions with a type. * Menu: * Dynamic Control of the Arrangement of Output:: * Format Directive Interface:: * Compiling Format Strings:: * Pretty Print Dispatch Tables:: * Pretty Printer Margins::  File: gcl.info, Node: Dynamic Control of the Arrangement of Output, Next: Format Directive Interface, Prev: Pretty Printer Concepts, Up: Pretty Printer Concepts 22.2.1.1 Dynamic Control of the Arrangement of Output ..................................................... The actions of the pretty printer when a piece of output is too large to fit in the space available can be precisely controlled. Three concepts underlie the way these operations work--logical blocks , conditional newlines , and sections . Before proceeding further, it is important to define these terms. The first line of Figure 22-3 shows a schematic piece of output. Each of the characters in the output is represented by "-". The positions of conditional newlines are indicated by digits. The beginnings and ends of logical blocks are indicated by "<" and ">" respectively. The output as a whole is a logical block and the outermost section. This section is indicated by the 0's on the second line of Figure 1. Logical blocks nested within the output are specified by the macro pprint-logical-block. Conditional newline positions are specified by calls to pprint-newline. Each conditional newline defines two sections (one before it and one after it) and is associated with a third (the section immediately containing it). The section after a conditional newline consists of: all the output up to, but not including, (a) the next conditional newline immediately contained in the same logical block; or if (a) is not applicable, (b) the next newline that is at a lesser level of nesting in logical blocks; or if (b) is not applicable, (c) the end of the output. The section before a conditional newline consists of: all the output back to, but not including, (a) the previous conditional newline that is immediately contained in the same logical block; or if (a) is not applicable, (b) the beginning of the immediately containing logical block. The last four lines in Figure 1 indicate the sections before and after the four conditional newlines. The section immediately containing a conditional newline is the shortest section that contains the conditional newline in question. In Figure 22-3, the first conditional newline is immediately contained in the section marked with 0's, the second and third conditional newlines are immediately contained in the section before the fourth conditional newline, and the fourth conditional newline is immediately contained in the section after the first conditional newline. <-1---<--<--2---3->--4-->-> 000000000000000000000000000 11 111111111111111111111111 22 222 333 3333 44444444444444 44444 Figure 22-2: Example of Logical Blocks, Conditional Newlines, and Sections Whenever possible, the pretty printer displays the entire contents of a section on a single line. However, if the section is too long to fit in the space available, line breaks are inserted at conditional newline positions within the section.  File: gcl.info, Node: Format Directive Interface, Next: Compiling Format Strings, Prev: Dynamic Control of the Arrangement of Output, Up: Pretty Printer Concepts 22.2.1.2 Format Directive Interface ................................... The primary interface to operations for dynamically determining the arrangement of output is provided through the functions and macros of the pretty printer. Figure 22-3 shows the defined names related to pretty printing. *print-lines* pprint-dispatch pprint-pop *print-miser-width* pprint-exit-if-list-exhausted pprint-tab *print-pprint-dispatch* pprint-fill pprint-tabular *print-right-margin* pprint-indent set-pprint-dispatch copy-pprint-dispatch pprint-linear write format pprint-logical-block formatter pprint-newline Figure 22-3: Defined names related to pretty printing. Figure 22-4 identifies a set of format directives which serve as an alternate interface to the same pretty printing operations in a more textually compact form. ~I ~W ~<...~:> ~:T ~/.../ ~_ Figure 22-4: Format directives related to Pretty Printing  File: gcl.info, Node: Compiling Format Strings, Next: Pretty Print Dispatch Tables, Prev: Format Directive Interface, Up: Pretty Printer Concepts 22.2.1.3 Compiling Format Strings ................................. A format string is essentially a program in a special-purpose language that performs printing, and that is interpreted by the function format. The formatter macro provides the efficiency of using a compiled function to do that same printing but without losing the textual compactness of format strings. A format control is either a format string or a function that was returned by the the formatter macro.  File: gcl.info, Node: Pretty Print Dispatch Tables, Next: Pretty Printer Margins, Prev: Compiling Format Strings, Up: Pretty Printer Concepts 22.2.1.4 Pretty Print Dispatch Tables ..................................... A pprint dispatch table is a mapping from keys to pairs of values. Each key is a type specifier. The values associated with a key are a "function" (specifically, a function designator or nil) and a "numerical priority" (specifically, a real). Basic insertion and retrieval is done based on the keys with the equality of keys being tested by equal. When *print-pretty* is true, the current pprint dispatch table (in *print-pprint-dispatch*) controls how objects are printed. The information in this table takes precedence over all other mechanisms for specifying how to print objects. In particular, it has priority over user-defined print-object methods because the current pprint dispatch table is consulted first. The function is chosen from the current pprint dispatch table by finding the highest priority function that is associated with a type specifier that matches the object; if there is more than one such function, it is implementation-dependent which is used. However, if there is no information in the table about how to pretty print a particular kind of object, a function is invoked which uses print-object to print the object. The value of *print-pretty* is still true when this function is called, and individual methods for print-object might still elect to produce output in a special format conditional on the value of *print-pretty*.  File: gcl.info, Node: Pretty Printer Margins, Prev: Pretty Print Dispatch Tables, Up: Pretty Printer Concepts 22.2.1.5 Pretty Printer Margins ............................... A primary goal of pretty printing is to keep the output between a pair of margins. The column where the output begins is taken as the left margin. If the current column cannot be determined at the time output begins, the left margin is assumed to be zero. The right margin is controlled by *print-right-margin*.  File: gcl.info, Node: Examples of using the Pretty Printer, Next: Notes about the Pretty Printer`s Background, Prev: Pretty Printer Concepts, Up: The Lisp Pretty Printer 22.2.2 Examples of using the Pretty Printer ------------------------------------------- As an example of the interaction of logical blocks, conditional newlines, and indentation, consider the function simple-pprint-defun below. This function prints out lists whose cars are defun in the standard way assuming that the list has exactly length 4. (defun simple-pprint-defun (*standard-output* list) (pprint-logical-block (*standard-output* list :prefix "(" :suffix ")") (write (first list)) (write-char #\Space) (pprint-newline :miser) (pprint-indent :current 0) (write (second list)) (write-char #\Space) (pprint-newline :fill) (write (third list)) (pprint-indent :block 1) (write-char #\Space) (pprint-newline :linear) (write (fourth list)))) Suppose that one evaluates the following: (simple-pprint-defun *standard-output* '(defun prod (x y) (* x y))) If the line width available is greater than or equal to 26, then all of the output appears on one line. If the line width available is reduced to 25, a line break is inserted at the linear-style conditional newline before the expression (* x y), producing the output shown. The (pprint-indent :block 1) causes (* x y) to be printed at a relative indentation of 1 in the logical block. (DEFUN PROD (X Y) (* X Y)) If the line width available is 15, a line break is also inserted at the fill style conditional newline before the argument list. The call on (pprint-indent :current 0) causes the argument list to line up under the function name. (DEFUN PROD (X Y) (* X Y)) If *print-miser-width* were greater than or equal to 14, the example output above would have been as follows, because all indentation changes are ignored in miser mode and line breaks are inserted at miser-style conditional newlines. (DEFUN PROD (X Y) (* X Y)) As an example of a per-line prefix, consider that evaluating the following produces the output shown with a line width of 20 and *print-miser-width* of nil. (pprint-logical-block (*standard-output* nil :per-line-prefix ";;; ") (simple-pprint-defun *standard-output* '(defun prod (x y) (* x y)))) ;;; (DEFUN PROD ;;; (X Y) ;;; (* X Y)) As a more complex (and realistic) example, consider the function pprint-let below. This specifies how to print a let form in the traditional style. It is more complex than the example above, because it has to deal with nested structure. Also, unlike the example above it contains complete code to readably print any possible list that begins with the symbol let. The outermost pprint-logical-block form handles the printing of the input list as a whole and specifies that parentheses should be printed in the output. The second pprint-logical-block form handles the list of binding pairs. Each pair in the list is itself printed by the innermost pprint-logical-block. (A loop form is used instead of merely decomposing the pair into two objects so that readable output will be produced no matter whether the list corresponding to the pair has one element, two elements, or (being malformed) has more than two elements.) A space and a fill-style conditional newline are placed after each pair except the last. The loop at the end of the topmost pprint-logical-block form prints out the forms in the body of the let form separated by spaces and linear-style conditional newlines. (defun pprint-let (*standard-output* list) (pprint-logical-block (nil list :prefix "(" :suffix ")") (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (loop (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (loop (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :linear))) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :fill))) (pprint-indent :block 1) (loop (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :linear) (write (pprint-pop))))) Suppose that one evaluates the following with *print-level* being 4, and *print-circle* being true. (pprint-let *standard-output* '#1=(let (x (*print-length* (f (g 3))) (z . 2) (k (car y))) (setq x (sqrt z)) #1#)) If the line length is greater than or equal to 77, the output produced appears on one line. However, if the line length is 76, line breaks are inserted at the linear-style conditional newlines separating the forms in the body and the output below is produced. Note that, the degenerate binding pair x is printed readably even though it fails to be a list; a depth abbreviation marker is printed in place of (g 3); the binding pair (z . 2) is printed readably even though it is not a proper list; and appropriate circularity markers are printed. #1=(LET (X (*PRINT-LENGTH* (F #)) (Z . 2) (K (CAR Y))) (SETQ X (SQRT Z)) #1#) If the line length is reduced to 35, a line break is inserted at one of the fill-style conditional newlines separating the binding pairs. #1=(LET (X (*PRINT-PRETTY* (F #)) (Z . 2) (K (CAR Y))) (SETQ X (SQRT Z)) #1#) Suppose that the line length is further reduced to 22 and *print-length* is set to 3. In this situation, line breaks are inserted after both the first and second binding pairs. In addition, the second binding pair is itself broken across two lines. Clause (b) of the description of fill-style conditional newlines (see the function pprint-newline) prevents the binding pair (z . 2) from being printed at the end of the third line. Note that the length abbreviation hides the circularity from view and therefore the printing of circularity markers disappears. (LET (X (*PRINT-LENGTH* (F #)) (Z . 2) ...) (SETQ X (SQRT Z)) ...) The next function prints a vector using "#(...)" notation. (defun pprint-vector (*standard-output* v) (pprint-logical-block (nil nil :prefix "#(" :suffix ")") (let ((end (length v)) (i 0)) (when (plusp end) (loop (pprint-pop) (write (aref v i)) (if (= (incf i) end) (return nil)) (write-char #\Space) (pprint-newline :fill)))))) Evaluating the following with a line length of 15 produces the output shown. (pprint-vector *standard-output* '#(12 34 567 8 9012 34 567 89 0 1 23)) #(12 34 567 8 9012 34 567 89 0 1 23) As examples of the convenience of specifying pretty printing with format strings, consider that the functions simple-pprint-defun and pprint-let used as examples above can be compactly defined as follows. (The function pprint-vector cannot be defined using format because the data structure it traverses is not a list.) (defun simple-pprint-defun (*standard-output* list) (format T "~:<~W ~@_~:I~W ~:_~W~1I ~_~W~:>" list)) (defun pprint-let (*standard-output* list) (format T "~:<~W~^~:<~@{~:<~@{~W~^~_~}~:>~^~:_~}~:>~1I~@{~^~_~W~}~:>" list)) In the following example, the first form restores *print-pprint-dispatch* to the equivalent of its initial value. The next two forms then set up a special way to pretty print ratios. Note that the more specific type specifier has to be associated with a higher priority. (setq *print-pprint-dispatch* (copy-pprint-dispatch nil)) (set-pprint-dispatch 'ratio #'(lambda (s obj) (format s "#.(/ ~W ~W)" (numerator obj) (denominator obj)))) (set-pprint-dispatch '(and ratio (satisfies minusp)) #'(lambda (s obj) (format s "#.(- (/ ~W ~W))" (- (numerator obj)) (denominator obj))) 5) (pprint '(1/3 -2/3)) (#.(/ 1 3) #.(- (/ 2 3))) The following two forms illustrate the definition of pretty printing functions for types of code. The first form illustrates how to specify the traditional method for printing quoted objects using single-quote. Note the care taken to ensure that data lists that happen to begin with quote will be printed readably. The second form specifies that lists beginning with the symbol my-let should print the same way that lists beginning with let print when the initial pprint dispatch table is in effect. (set-pprint-dispatch '(cons (member quote)) () #'(lambda (s list) (if (and (consp (cdr list)) (null (cddr list))) (funcall (formatter "'~W") s (cadr list)) (pprint-fill s list)))) (set-pprint-dispatch '(cons (member my-let)) (pprint-dispatch '(let) nil)) The next example specifies a default method for printing lists that do not correspond to function calls. Note that the functions pprint-linear, pprint-fill, and pprint-tabular are all defined with optional colon-p and at-sign-p arguments so that they can be used as pprint dispatch functions as well as ~/.../ functions. (set-pprint-dispatch '(cons (not (and symbol (satisfies fboundp)))) #'pprint-fill -5) ;; Assume a line length of 9 (pprint '(0 b c d e f g h i j k)) (0 b c d e f g h i j k) This final example shows how to define a pretty printing function for a user defined data structure. (defstruct family mom kids) (set-pprint-dispatch 'family #'(lambda (s f) (funcall (formatter "~@<#<~;~W and ~2I~_~/pprint-fill/~;>~:>") s (family-mom f) (family-kids f)))) The pretty printing function for the structure family specifies how to adjust the layout of the output so that it can fit aesthetically into a variety of line widths. In addition, it obeys the printer control variables *print-level*, *print-length*, *print-lines*, *print-circle* and *print-escape*, and can tolerate several different kinds of malformity in the data structure. The output below shows what is printed out with a right margin of 25, *print-pretty* being true, *print-escape* being false, and a malformed kids list. (write (list 'principal-family (make-family :mom "Lucy" :kids '("Mark" "Bob" . "Dan"))) :right-margin 25 :pretty T :escape nil :miser-width nil) (PRINCIPAL-FAMILY #) Note that a pretty printing function for a structure is different from the structure's print-object method. While print-object methods are permanently associated with a structure, pretty printing functions are stored in pprint dispatch tables and can be rapidly changed to reflect different printing needs. If there is no pretty printing function for a structure in the current pprint dispatch table, its print-object method is used instead.  File: gcl.info, Node: Notes about the Pretty Printer`s Background, Prev: Examples of using the Pretty Printer, Up: The Lisp Pretty Printer 22.2.3 Notes about the Pretty Printer's Background -------------------------------------------------- For a background reference to the abstract concepts detailed in this section, see XP: A Common Lisp Pretty Printing System. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material.  File: gcl.info, Node: Formatted Output, Next: Printer Dictionary, Prev: The Lisp Pretty Printer, Up: Printer 22.3 Formatted Output ===================== [Editorial Note by KMP: This is transplanted from FORMAT and will need a bit of work before it looks good standing alone. Bear with me.] format is useful for producing nicely formatted text, producing good-looking messages, and so on. format can generate and return a string or output to destination. The control-string argument to format is actually a format control. That is, it can be either a format string or a function, for example a function returned by the formatter macro. If it is a function, the function is called with the appropriate output stream as its first argument and the data arguments to format as its remaining arguments. The function should perform whatever output is necessary and return the unused tail of the arguments (if any). The compilation process performed by formatter produces a function that would do with its arguments as the format interpreter would do with those arguments. The remainder of this section describes what happens if the control-string is a format string. Control-string is composed of simple text (characters) and embedded directives. format writes the simple text as is; each embedded directive specifies further text output that is to appear at the corresponding point within the simple text. Most directives use one or more elements of args to create their output. A directive consists of a tilde, optional prefix parameters separated by commas, optional colon and at-sign modifiers, and a single character indicating what kind of directive this is. There is no required ordering between the at-sign and colon modifier. The case of the directive character is ignored. Prefix parameters are notated as signed (sign is optional) decimal numbers, or as a single-quote followed by a character. For example, ~5,'0d can be used to print an integer in decimal radix in five columns with leading zeros, or ~5,'*d to get leading asterisks. In place of a prefix parameter to a directive, V (or v) can be used. In this case, format takes an argument from args as a parameter to the directive. The argument should be an integer or character. If the arg used by a V parameter is nil, the effect is as if the parameter had been omitted. # can be used in place of a prefix parameter; it represents the number of args remaining to be processed. When used within a recursive format, in the context of ~? or ~{, the # prefix parameter represents the number of format arguments remaining within the recursive call. Examples of format strings: "~S" ;This is an S directive with no parameters or modifiers. "~3,-4:@s" ;This is an S directive with two parameters, 3 and -4, ; and both the colon and at-sign flags. "~,+4S" ;Here the first prefix parameter is omitted and takes ; on its default value, while the second parameter is 4. Figure 22-5: Examples of format control strings format sends the output to destination. If destination is nil, format creates and returns a string containing the output from control-string. If destination is non-nil, it must be a string with a fill pointer, a stream, or the symbol t. If destination is a string with a fill pointer, the output is added to the end of the string. If destination is a stream, the output is sent to that stream. If destination is t, the output is sent to standard output. In the description of the directives that follows, the term arg in general refers to the next item of the set of args to be processed. The word or phrase at the beginning of each description is a mnemonic for the directive. format directives do not bind any of the printer control variables (*print-...*) except as specified in the following descriptions. Implementations may specify the binding of new, implementation-specific printer control variables for each format directive, but they may neither bind any standard printer control variables not specified in description of a format directive nor fail to bind any standard printer control variables as specified in the description. * Menu: * FORMAT Basic Output:: * FORMAT Radix Control:: * FORMAT Floating-Point Printers:: * FORMAT Printer Operations:: * FORMAT Pretty Printer Operations:: * FORMAT Layout Control:: * FORMAT Control-Flow Operations:: * FORMAT Miscellaneous Operations:: * FORMAT Miscellaneous Pseudo-Operations:: * Additional Information about FORMAT Operations:: * Examples of FORMAT:: * Notes about FORMAT::  File: gcl.info, Node: FORMAT Basic Output, Next: FORMAT Radix Control, Prev: Formatted Output, Up: Formatted Output 22.3.1 FORMAT Basic Output -------------------------- * Menu: * Tilde C-> Character:: * Tilde Percent-> Newline:: * Tilde Ampersand-> Fresh-Line:: * Tilde Vertical-Bar-> Page:: * Tilde Tilde-> Tilde::  File: gcl.info, Node: Tilde C-> Character, Next: Tilde Percent-> Newline, Prev: FORMAT Basic Output, Up: FORMAT Basic Output 22.3.1.1 Tilde C: Character ........................... The next arg should be a character; it is printed according to the modifier flags. ~C prints the character as if by using write-char if it is a simple character. Characters that are not simple are not necessarily printed as if by write-char, but are displayed in an implementation-defined, abbreviated format. For example, (format nil "~C" #\A) => "A" (format nil "~C" #\Space) => " " ~:C is the same as ~C for printing characters, but other characters are "spelled out." The intent is that this is a "pretty" format for printing characters. For simple characters that are not printing, what is spelled out is the name of the character (see char-name). For characters that are not simple and not printing, what is spelled out is implementation-defined. For example, (format nil "~:C" #\A) => "A" (format nil "~:C" #\Space) => "Space" ;; This next example assumes an implementation-defined "Control" attribute. (format nil "~:C" #\Control-Space) => "Control-Space" OR=> "c-Space" ~:@C prints what ~:C would, and then if the character requires unusual shift keys on the keyboard to type it, this fact is mentioned. For example, (format nil "~:@C" #\Control-Partial) => "Control-\partial (Top-F)" This is the format used for telling the user about a key he is expected to type, in prompts, for instance. The precise output may depend not only on the implementation, but on the particular I/O devices in use. ~@C prints the character in a way that the Lisp reader can understand, using #\ syntax. ~@C binds *print-escape* to t.  File: gcl.info, Node: Tilde Percent-> Newline, Next: Tilde Ampersand-> Fresh-Line, Prev: Tilde C-> Character, Up: FORMAT Basic Output 22.3.1.2 Tilde Percent: Newline ............................... This outputs a #\Newline character, thereby terminating the current output line and beginning a new one. ~n% outputs n newlines. No arg is used.  File: gcl.info, Node: Tilde Ampersand-> Fresh-Line, Next: Tilde Vertical-Bar-> Page, Prev: Tilde Percent-> Newline, Up: FORMAT Basic Output 22.3.1.3 Tilde Ampersand: Fresh-Line .................................... Unless it can be determined that the output stream is already at the beginning of a line, this outputs a newline. ~n& calls fresh-line and then outputs n- 1 newlines. ~0& does nothing.  File: gcl.info, Node: Tilde Vertical-Bar-> Page, Next: Tilde Tilde-> Tilde, Prev: Tilde Ampersand-> Fresh-Line, Up: FORMAT Basic Output 22.3.1.4 Tilde Vertical-Bar: Page ................................. This outputs a page separator character, if possible. ~n| does this n times.  File: gcl.info, Node: Tilde Tilde-> Tilde, Prev: Tilde Vertical-Bar-> Page, Up: FORMAT Basic Output 22.3.1.5 Tilde Tilde: Tilde ........................... This outputs a tilde. ~n~ outputs n tildes.  File: gcl.info, Node: FORMAT Radix Control, Next: FORMAT Floating-Point Printers, Prev: FORMAT Basic Output, Up: Formatted Output 22.3.2 FORMAT Radix Control --------------------------- * Menu: * Tilde R-> Radix:: * Tilde D-> Decimal:: * Tilde B-> Binary:: * Tilde O-> Octal:: * Tilde X-> Hexadecimal::  File: gcl.info, Node: Tilde R-> Radix, Next: Tilde D-> Decimal, Prev: FORMAT Radix Control, Up: FORMAT Radix Control 22.3.2.1 Tilde R: Radix ....................... ~nR prints arg in radix n. The modifier flags and any remaining parameters are used as for the ~D directive. ~D is the same as ~10R. The full form is ~radix,mincol,padchar,commachar,comma-intervalR. If no prefix parameters are given to ~R, then a different interpretation is given. The argument should be an integer. For example, if arg is 4: * ~R prints arg as a cardinal English number: four. * ~:R prints arg as an ordinal English number: fourth. * ~@R prints arg as a Roman numeral: IV. * ~:@R prints arg as an old Roman numeral: IIII. For example: (format nil "~,,' ,4:B" 13) => "1101" (format nil "~,,' ,4:B" 17) => "1 0001" (format nil "~19,0,' ,4:B" 3333) => "0000 1101 0000 0101" (format nil "~3,,,' ,2:R" 17) => "1 22" (format nil "~,,'|,2:D" #xFFFF) => "6|55|35" If and only if the first parameter, n, is supplied, ~R binds *print-escape* to false, *print-radix* to false, *print-base* to n, and *print-readably* to false. If and only if no parameters are supplied, ~R binds *print-base* to 10.  File: gcl.info, Node: Tilde D-> Decimal, Next: Tilde B-> Binary, Prev: Tilde R-> Radix, Up: FORMAT Radix Control 22.3.2.2 Tilde D: Decimal ......................... An arg, which should be an integer, is printed in decimal radix. ~D will never put a decimal point after the number. ~mincolD uses a column width of mincol; spaces are inserted on the left if the number requires fewer than mincol columns for its digits and sign. If the number doesn't fit in mincol columns, additional columns are used as needed. ~mincol,padcharD uses padchar as the pad character instead of space. If arg is not an integer, it is printed in ~A format and decimal base. The @ modifier causes the number's sign to be printed always; the default is to print it only if the number is negative. The : modifier causes commas to be printed between groups of digits; commachar may be used to change the character used as the comma. comma-interval must be an integer and defaults to 3. When the : modifier is given to any of these directives, the commachar is printed between groups of comma-interval digits. Thus the most general form of ~D is ~mincol,padchar,commachar,comma-intervalD. ~D binds *print-escape* to false, *print-radix* to false, *print-base* to 10, and *print-readably* to false.  File: gcl.info, Node: Tilde B-> Binary, Next: Tilde O-> Octal, Prev: Tilde D-> Decimal, Up: FORMAT Radix Control 22.3.2.3 Tilde B: Binary ........................ This is just like ~D but prints in binary radix (radix 2) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalB. ~B binds *print-escape* to false, *print-radix* to false, *print-base* to 2, and *print-readably* to false.  File: gcl.info, Node: Tilde O-> Octal, Next: Tilde X-> Hexadecimal, Prev: Tilde B-> Binary, Up: FORMAT Radix Control 22.3.2.4 Tilde O: Octal ....................... This is just like ~D but prints in octal radix (radix 8) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalO. ~O binds *print-escape* to false, *print-radix* to false, *print-base* to 8, and *print-readably* to false.  File: gcl.info, Node: Tilde X-> Hexadecimal, Prev: Tilde O-> Octal, Up: FORMAT Radix Control 22.3.2.5 Tilde X: Hexadecimal ............................. This is just like ~D but prints in hexadecimal radix (radix 16) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalX. ~X binds *print-escape* to false, *print-radix* to false, *print-base* to 16, and *print-readably* to false.  File: gcl.info, Node: FORMAT Floating-Point Printers, Next: FORMAT Printer Operations, Prev: FORMAT Radix Control, Up: Formatted Output 22.3.3 FORMAT Floating-Point Printers ------------------------------------- * Menu: * Tilde F-> Fixed-Format Floating-Point:: * Tilde E-> Exponential Floating-Point:: * Tilde G-> General Floating-Point:: * Tilde Dollarsign-> Monetary Floating-Point::  File: gcl.info, Node: Tilde F-> Fixed-Format Floating-Point, Next: Tilde E-> Exponential Floating-Point, Prev: FORMAT Floating-Point Printers, Up: FORMAT Floating-Point Printers 22.3.3.1 Tilde F: Fixed-Format Floating-Point ............................................. The next arg is printed as a float. The full form is ~w,d,k,overflowchar,padcharF. The parameter w is the width of the field to be printed; d is the number of digits to print after the decimal point; k is a scale factor that defaults to zero. Exactly w characters will be output. First, leading copies of the character padchar (which defaults to a space) are printed, if necessary, to pad the field on the left. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. Then a sequence of digits, containing a single embedded decimal point, is printed; this represents the magnitude of the value of arg times 10^k, rounded to d fractional digits. When rounding up and rounding down would produce printed values equidistant from the scaled value of arg, then the implementation is free to use either one. For example, printing the argument 6.375 using the format ~4,2F may correctly produce either 6.37 or 6.38. Leading zeros are not permitted, except that a single zero digit is output before the decimal point if the printed value is less than one, and this single zero digit is not output at all if w=d+1. If it is impossible to print the value in the required format in a field of width w, then one of two actions is taken. If the parameter overflowchar is supplied, then w copies of that parameter are printed instead of the scaled value of arg. If the overflowchar parameter is omitted, then the scaled value is printed using more than w characters, as many more as may be needed. If the w parameter is omitted, then the field is of variable width. In effect, a value is chosen for w in such a way that no leading pad characters need to be printed and exactly d characters will follow the decimal point. For example, the directive ~,2F will print exactly two digits after the decimal point and as many as necessary before the decimal point. If the parameter d is omitted, then there is no constraint on the number of digits to appear after the decimal point. A value is chosen for d in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter w and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero, then a single zero digit should appear after the decimal point if permitted by the width constraint. If both w and d are omitted, then the effect is to print the value using ordinary free-format output; prin1 uses this format for any number whose magnitude is either zero or between 10^-3 (inclusive) and 10^7 (exclusive). If w is omitted, then if the magnitude of arg is so large (or, if d is also omitted, so small) that more than 100 digits would have to be printed, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive ~E (with all parameters to ~E defaulted, not taking their values from the ~F directive). If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If w and d are not supplied and the number has no exact decimal representation, for example 1/3, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed. If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w. ~F binds *print-escape* to false and *print-readably* to false.  File: gcl.info, Node: Tilde E-> Exponential Floating-Point, Next: Tilde G-> General Floating-Point, Prev: Tilde F-> Fixed-Format Floating-Point, Up: FORMAT Floating-Point Printers 22.3.3.2 Tilde E: Exponential Floating-Point ............................................ The next arg is printed as a float in exponential notation. The full form is ~w,d,e,k,overflowchar,padchar,exponentcharE. The parameter w is the width of the field to be printed; d is the number of digits to print after the decimal point; e is the number of digits to use when printing the exponent; k is a scale factor that defaults to one (not zero). Exactly w characters will be output. First, leading copies of the character padchar (which defaults to a space) are printed, if necessary, to pad the field on the left. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. Then a sequence of digits containing a single embedded decimal point is printed. The form of this sequence of digits depends on the scale factor k. If k is zero, then d digits are printed after the decimal point, and a single zero digit appears before the decimal point if the total field width will permit it. If k is positive, then it must be strictly less than d+2; k significant digits are printed before the decimal point, and d- k+1 digits are printed after the decimal point. If k is negative, then it must be strictly greater than - d; a single zero digit appears before the decimal point if the total field width will permit it, and after the decimal point are printed first - k zeros and then d+k significant digits. The printed fraction must be properly rounded. When rounding up and rounding down would produce printed values equidistant from the scaled value of arg, then the implementation is free to use either one. For example, printing the argument 637.5 using the format ~8,2E may correctly produce either 6.37E+2 or 6.38E+2. Following the digit sequence, the exponent is printed. First the character parameter exponentchar is printed; if this parameter is omitted, then the exponent marker that prin1 would use is printed, as determined from the type of the float and the current value of *read-default-float-format*. Next, either a plus sign or a minus sign is printed, followed by e digits representing the power of ten by which the printed fraction must be multiplied to properly represent the rounded value of arg. If it is impossible to print the value in the required format in a field of width w, possibly because k is too large or too small or because the exponent cannot be printed in e character positions, then one of two actions is taken. If the parameter overflowchar is supplied, then w copies of that parameter are printed instead of the scaled value of arg. If the overflowchar parameter is omitted, then the scaled value is printed using more than w characters, as many more as may be needed; if the problem is that d is too small for the supplied k or that e is too small, then a larger value is used for d or e as may be needed. If the w parameter is omitted, then the field is of variable width. In effect a value is chosen for w in such a way that no leading pad characters need to be printed. If the parameter d is omitted, then there is no constraint on the number of digits to appear. A value is chosen for d in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter w, the constraint of the scale factor k, and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero then a single zero digit should appear after the decimal point. If the parameter e is omitted, then the exponent is printed using the smallest number of digits necessary to represent its value. If all of w, d, and e are omitted, then the effect is to print the value using ordinary free-format exponential-notation output; prin1 uses a similar format for any non-zero number whose magnitude is less than 10^-3 or greater than or equal to 10^7. The only difference is that the ~E directive always prints a plus or minus sign in front of the exponent, while prin1 omits the plus sign if the exponent is non-negative. If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If w and d are unsupplied and the number has no exact decimal representation, for example 1/3, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed. If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w. ~E binds *print-escape* to false and *print-readably* to false.  File: gcl.info, Node: Tilde G-> General Floating-Point, Next: Tilde Dollarsign-> Monetary Floating-Point, Prev: Tilde E-> Exponential Floating-Point, Up: FORMAT Floating-Point Printers 22.3.3.3 Tilde G: General Floating-Point ........................................ The next arg is printed as a float in either fixed-format or exponential notation as appropriate. The full form is ~w,d,e,k,overflowchar,padchar,exponentcharG. The format in which to print arg depends on the magnitude (absolute value) of the arg. Let n be an integer such that 10^n-1 \le |arg| < 10^n. Let ee equal e+2, or 4 if e is omitted. Let ww equal w- ee, or nil if w is omitted. If d is omitted, first let q be the number of digits needed to print arg with no loss of information and without leading or trailing zeros; then let d equal (max q (min n 7)). Let dd equal d- n. If 0 \le dd \le d, then arg is printed as if by the format directives ~ww,dd,,overflowchar,padcharF~ee@T Note that the scale factor k is not passed to the ~F directive. For all other values of dd, arg is printed as if by the format directive ~w,d,e,k,overflowchar,padchar,exponentcharE In either case, an @ modifier is supplied to the ~F or ~E directive if and only if one was supplied to the ~G directive. ~G binds *print-escape* to false and *print-readably* to false.  File: gcl.info, Node: Tilde Dollarsign-> Monetary Floating-Point, Prev: Tilde G-> General Floating-Point, Up: FORMAT Floating-Point Printers 22.3.3.4 Tilde Dollarsign: Monetary Floating-Point .................................................. The next arg is printed as a float in fixed-format notation. The full form is ~d,n,w,padchar$. The parameter d is the number of digits to print after the decimal point (default value 2); n is the minimum number of digits to print before the decimal point (default value 1); w is the minimum total width of the field to be printed (default value 0). First padding and the sign are output. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. If the : modifier is used, the sign appears before any padding, and otherwise after the padding. If w is supplied and the number of other characters to be output is less than w, then copies of padchar (which defaults to a space) are output to make the total field width equal w. Then n digits are printed for the integer part of arg, with leading zeros if necessary; then a decimal point; then d digits of fraction, properly rounded. If the magnitude of arg is so large that more than m digits would have to be printed, where m is the larger of w and 100, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive ~w,q,,,,padcharE, where w and padchar are present or omitted according to whether they were present or omitted in the ~$ directive, and where q=d+n- 1, where d and n are the (possibly default) values given to the ~$ directive. If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w. ~$ binds *print-escape* to false and *print-readably* to false.  File: gcl.info, Node: FORMAT Printer Operations, Next: FORMAT Pretty Printer Operations, Prev: FORMAT Floating-Point Printers, Up: Formatted Output 22.3.4 FORMAT Printer Operations -------------------------------- * Menu: * Tilde A-> Aesthetic:: * Tilde S-> Standard:: * Tilde W-> Write::  File: gcl.info, Node: Tilde A-> Aesthetic, Next: Tilde S-> Standard, Prev: FORMAT Printer Operations, Up: FORMAT Printer Operations 22.3.4.1 Tilde A: Aesthetic ........................... An arg, any object, is printed without escape characters (as by princ). If arg is a string, its characters will be output verbatim. If arg is nil it will be printed as nil; the colon modifier (~:A) will cause an arg of nil to be printed as (), but if arg is a composite structure, such as a list or vector, any contained occurrences of nil will still be printed as nil. ~mincolA inserts spaces on the right, if necessary, to make the width at least mincol columns. The @ modifier causes the spaces to be inserted on the left rather than the right. ~mincol,colinc,minpad,padcharA is the full form of ~A, which allows control of the padding. The string is padded on the right (or on the left if the @ modifier is used) with at least minpad copies of padchar; padding characters are then inserted colinc characters at a time until the total width is at least mincol. The defaults are 0 for mincol and minpad, 1 for colinc, and the space character for padchar. ~A binds *print-escape* to false, and *print-readably* to false.  File: gcl.info, Node: Tilde S-> Standard, Next: Tilde W-> Write, Prev: Tilde A-> Aesthetic, Up: FORMAT Printer Operations 22.3.4.2 Tilde S: Standard .......................... This is just like ~A, but arg is printed with escape characters (as by prin1 rather than princ). The output is therefore suitable for input to read. ~S accepts all the arguments and modifiers that ~A does. ~S binds *print-escape* to t.  File: gcl.info, Node: Tilde W-> Write, Prev: Tilde S-> Standard, Up: FORMAT Printer Operations 22.3.4.3 Tilde W: Write ....................... An argument, any object, is printed obeying every printer control variable (as by write). In addition, ~W interacts correctly with depth abbreviation, by not resetting the depth counter to zero. ~W does not accept parameters. If given the colon modifier, ~W binds *print-pretty* to true. If given the at-sign modifier, ~W binds *print-level* and *print-length* to nil. ~W provides automatic support for the detection of circularity and sharing. If the value of *print-circle* is not nil and ~W is applied to an argument that is a circular (or shared) reference, an appropriate #n# marker is inserted in the output instead of printing the argument.  File: gcl.info, Node: FORMAT Pretty Printer Operations, Next: FORMAT Layout Control, Prev: FORMAT Printer Operations, Up: Formatted Output 22.3.5 FORMAT Pretty Printer Operations --------------------------------------- The following constructs provide access to the pretty printer: * Menu: * Tilde Underscore-> Conditional Newline:: * Tilde Less-Than-Sign-> Logical Block:: * Tilde I-> Indent:: * Tilde Slash-> Call Function::  File: gcl.info, Node: Tilde Underscore-> Conditional Newline, Next: Tilde Less-Than-Sign-> Logical Block, Prev: FORMAT Pretty Printer Operations, Up: FORMAT Pretty Printer Operations 22.3.5.1 Tilde Underscore: Conditional Newline .............................................. Without any modifiers, ~_ is the same as (pprint-newline :linear). ~@_ is the same as (pprint-newline :miser). ~:_ is the same as (pprint-newline :fill). ~:@_ is the same as (pprint-newline :mandatory).  File: gcl.info, Node: Tilde Less-Than-Sign-> Logical Block, Next: Tilde I-> Indent, Prev: Tilde Underscore-> Conditional Newline, Up: FORMAT Pretty Printer Operations 22.3.5.2 Tilde Less-Than-Sign: Logical Block ............................................ ~<...~:> If ~:> is used to terminate a ~<...~>, the directive is equivalent to a call to pprint-logical-block. The argument corresponding to the ~<...~:> directive is treated in the same way as the list argument to pprint-logical-block, thereby providing automatic support for non-list arguments and the detection of circularity, sharing, and depth abbreviation. The portion of the control-string nested within the ~<...~:> specifies the :prefix (or :per-line-prefix), :suffix, and body of the pprint-logical-block. The control-string portion enclosed by ~<...~:> can be divided into segments ~ by ~; directives. If the first section is terminated by ~@;, it specifies a per-line prefix rather than a simple prefix. The prefix and suffix cannot contain format directives. An error is signaled if either the prefix or suffix fails to be a constant string or if the enclosed portion is divided into more than three segments. If the enclosed portion is divided into only two segments, the suffix defaults to the null string. If the enclosed portion consists of only a single segment, both the prefix and the suffix default to the null string. If the colon modifier is used (i.e., ~:<...~:>), the prefix and suffix default to "(" and ")" (respectively) instead of the null string. The body segment can be any arbitrary format string. This format string is applied to the elements of the list corresponding to the ~<...~:> directive as a whole. Elements are extracted from this list using pprint-pop, thereby providing automatic support for malformed lists, and the detection of circularity, sharing, and length abbreviation. Within the body segment, ~^ acts like pprint-exit-if-list-exhausted. ~<...~:> supports a feature not supported by pprint-logical-block. If ~:@> is used to terminate the directive (i.e., ~<...~:@>), then a fill-style conditional newline is automatically inserted after each group of blanks immediately contained in the body (except for blanks after a ~ directive). This makes it easy to achieve the equivalent of paragraph filling. If the at-sign modifier is used with ~<...~:>, the entire remaining argument list is passed to the directive as its argument. All of the remaining arguments are always consumed by ~@<...~:>, even if they are not all used by the format string nested in the directive. Other than the difference in its argument, ~@<...~:> is exactly the same as ~<...~:> except that circularity detection is not applied if ~@<...~:> is encountered at top level in a format string. This ensures that circularity detection is applied only to data lists, not to format argument lists. " . #n#" is printed if circularity or sharing has to be indicated for its argument as a whole. To a considerable extent, the basic form of the directive ~<...~> is incompatible with the dynamic control of the arrangement of output by ~W, ~_, ~<...~:>, ~I, and ~:T. As a result, an error is signaled if any of these directives is nested within ~<...~>. Beyond this, an error is also signaled if the ~<...~:;...~> form of ~<...~> is used in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T. See also *note Tilde Less-Than-Sign-> Justification::.  File: gcl.info, Node: Tilde I-> Indent, Next: Tilde Slash-> Call Function, Prev: Tilde Less-Than-Sign-> Logical Block, Up: FORMAT Pretty Printer Operations 22.3.5.3 Tilde I: Indent ........................ ~nI is the same as (pprint-indent :block n). ~n:I is the same as (pprint-indent :current n). In both cases, n defaults to zero, if it is omitted.  File: gcl.info, Node: Tilde Slash-> Call Function, Prev: Tilde I-> Indent, Up: FORMAT Pretty Printer Operations 22.3.5.4 Tilde Slash: Call Function ................................... ~/name/ User defined functions can be called from within a format string by using the directive ~/name/. The colon modifier, the at-sign modifier, and arbitrarily many parameters can be specified with the ~/name/ directive. name can be any arbitrary string that does not contain a "/". All of the characters in name are treated as if they were upper case. If name contains a single colon (:) or double colon (::), then everything up to but not including the first ":" or "::" is taken to be a string that names a package. Everything after the first ":" or "::" (if any) is taken to be a string that names a symbol. The function corresponding to a ~/name/ directive is obtained by looking up the symbol that has the indicated name in the indicated package. If name does not contain a ":" or "::", then the whole name string is looked up in the COMMON-LISP-USER package. When a ~/name/ directive is encountered, the indicated function is called with four or more arguments. The first four arguments are: the output stream, the format argument corresponding to the directive, a generalized boolean that is true if the colon modifier was used, and a generalized boolean that is true if the at-sign modifier was used. The remaining arguments consist of any parameters specified with the directive. The function should print the argument appropriately. Any values returned by the function are ignored. The three functions pprint-linear, pprint-fill, and pprint-tabular are specifically designed so that they can be called by ~/.../ (i.e., ~/pprint-linear/, ~/pprint-fill/, and ~/pprint-tabular/). In particular they take colon and at-sign arguments.  File: gcl.info, Node: FORMAT Layout Control, Next: FORMAT Control-Flow Operations, Prev: FORMAT Pretty Printer Operations, Up: Formatted Output 22.3.6 FORMAT Layout Control ---------------------------- * Menu: * Tilde T-> Tabulate:: * Tilde Less-Than-Sign-> Justification:: * Tilde Greater-Than-Sign-> End of Justification::  File: gcl.info, Node: Tilde T-> Tabulate, Next: Tilde Less-Than-Sign-> Justification, Prev: FORMAT Layout Control, Up: FORMAT Layout Control 22.3.6.1 Tilde T: Tabulate .......................... This spaces over to a given column. ~colnum,colincT will output sufficient spaces to move the cursor to column colnum. If the cursor is already at or beyond column colnum, it will output spaces to move it to column colnum+k*colinc for the smallest positive integer k possible, unless colinc is zero, in which case no spaces are output if the cursor is already at or beyond column colnum. colnum and colinc default to 1. If for some reason the current absolute column position cannot be determined by direct inquiry, format may be able to deduce the current column position by noting that certain directives (such as ~%, or ~&, or ~A with the argument being a string containing a newline) cause the column position to be reset to zero, and counting the number of characters emitted since that point. If that fails, format may attempt a similar deduction on the riskier assumption that the destination was at column zero when format was invoked. If even this heuristic fails or is implementationally inconvenient, at worst the ~T operation will simply output two spaces. ~@T performs relative tabulation. ~colrel,colinc@T outputs colrel spaces and then outputs the smallest non-negative number of additional spaces necessary to move the cursor to a column that is a multiple of colinc. For example, the directive ~3,8@T outputs three spaces and then moves the cursor to a "standard multiple-of-eight tab stop" if not at one already. If the current output column cannot be determined, however, then colinc is ignored, and exactly colrel spaces are output. If the colon modifier is used with the ~T directive, the tabbing computation is done relative to the horizontal position where the section immediately containing the directive begins, rather than with respect to a horizontal position of zero. The numerical parameters are both interpreted as being in units of ems and both default to 1. ~n,m:T is the same as (pprint-tab :section n m). ~n,m:@T is the same as (pprint-tab :section-relative n m).  File: gcl.info, Node: Tilde Less-Than-Sign-> Justification, Next: Tilde Greater-Than-Sign-> End of Justification, Prev: Tilde T-> Tabulate, Up: FORMAT Layout Control 22.3.6.2 Tilde Less-Than-Sign: Justification ............................................ ~mincol,colinc,minpad,padchar This justifies the text produced by processing str within a field at least mincol columns wide. str may be divided up into segments with ~;, in which case the spacing is evenly divided between the text segments. With no modifiers, the leftmost text segment is left justified in the field, and the rightmost text segment is right justified. If there is only one text element, as a special case, it is right justified. The : modifier causes spacing to be introduced before the first text segment; the @ modifier causes spacing to be added after the last. The minpad parameter (default 0) is the minimum number of padding characters to be output between each segment. The padding character is supplied by padchar, which defaults to the space character. If the total width needed to satisfy these constraints is greater than mincol, then the width used is mincol+k*colinc for the smallest possible non-negative integer value k. colinc defaults to 1, and mincol defaults to 0. Note that str may include format directives. All the clauses in str are processed in order; it is the resulting pieces of text that are justified. The ~^ directive may be used to terminate processing of the clauses prematurely, in which case only the completely processed clauses are justified. If the first clause of a ~< is terminated with ~:; instead of ~;, then it is used in a special way. All of the clauses are processed (subject to ~^ , of course), but the first one is not used in performing the spacing and padding. When the padded result has been determined, then if it will fit on the current line of output, it is output, and the text for the first clause is discarded. If, however, the padded text will not fit on the current line, then the text segment for the first clause is output before the padded text. The first clause ought to contain a newline (such as a ~% directive). The first clause is always processed, and so any arguments it refers to will be used; the decision is whether to use the resulting segment of text, not whether to process the first clause. If the ~:; has a prefix parameter n, then the padded text must fit on the current line with n character positions to spare to avoid outputting the first clause's text. For example, the control string "~ can be used to print a list of items separated by commas without breaking items over line boundaries, beginning each line with ;; . The prefix parameter 1 in ~1:; accounts for the width of the comma that will follow the justified item if it is not the last element in the list, or the period if it is. If ~:; has a second prefix parameter, then it is used as the width of the line, thus overriding the natural line width of the output stream. To make the preceding example use a line width of 50, one would write "~ If the second argument is not supplied, then format uses the line width of the destination output stream. If this cannot be determined (for example, when producing a string result), then format uses 72 as the line length. See also *note Tilde Less-Than-Sign-> Logical Block::.  File: gcl.info, Node: Tilde Greater-Than-Sign-> End of Justification, Prev: Tilde Less-Than-Sign-> Justification, Up: FORMAT Layout Control 22.3.6.3 Tilde Greater-Than-Sign: End of Justification ...................................................... ~> terminates a ~<. The consequences of using it elsewhere are undefined.  File: gcl.info, Node: FORMAT Control-Flow Operations, Next: FORMAT Miscellaneous Operations, Prev: FORMAT Layout Control, Up: Formatted Output 22.3.7 FORMAT Control-Flow Operations ------------------------------------- * Menu: * Tilde Asterisk-> Go-To:: * Tilde Left-Bracket-> Conditional Expression:: * Tilde Right-Bracket-> End of Conditional Expression:: * Tilde Left-Brace-> Iteration:: * Tilde Right-Brace-> End of Iteration:: * Tilde Question-Mark-> Recursive Processing::  File: gcl.info, Node: Tilde Asterisk-> Go-To, Next: Tilde Left-Bracket-> Conditional Expression, Prev: FORMAT Control-Flow Operations, Up: FORMAT Control-Flow Operations 22.3.7.1 Tilde Asterisk: Go-To .............................. The next arg is ignored. ~n* ignores the next n arguments. ~:* backs up in the list of arguments so that the argument last processed will be processed again. ~n:* backs up n arguments. When within a ~{ construct (see below), the ignoring (in either direction) is relative to the list of arguments being processed by the iteration. ~n@* goes to the nth arg, where 0 means the first one; n defaults to 0, so ~@* goes back to the first arg. Directives after a ~n@* will take arguments in sequence beginning with the one gone to. When within a ~{ construct, the "goto" is relative to the list of arguments being processed by the iteration.  File: gcl.info, Node: Tilde Left-Bracket-> Conditional Expression, Next: Tilde Right-Bracket-> End of Conditional Expression, Prev: Tilde Asterisk-> Go-To, Up: FORMAT Control-Flow Operations 22.3.7.2 Tilde Left-Bracket: Conditional Expression ................................................... ~[str0~;str1~;...~;strn~] This is a set of control strings, called clauses, one of which is chosen and used. The clauses are separated by ~; and the construct is terminated by ~]. For example, "~[Siamese~;Manx~;Persian~] Cat" The argth clause is selected, where the first clause is number 0. If a prefix parameter is given (as ~n[), then the parameter is used instead of an argument. If arg is out of range then no clause is selected and no error is signaled. After the selected alternative has been processed, the control string continues after the ~]. ~[str0~;str1~;...~;strn~:;default~] has a default case. If the last ~; used to separate clauses is ~:; instead, then the last clause is an else clause that is performed if no other clause is selected. For example: "~[Siamese~;Manx~;Persian~:;Alley~] Cat" ~:[alternative~;consequent~] selects the alternative control string if arg is false, and selects the consequent control string otherwise. ~@[consequent~] tests the argument. If it is true, then the argument is not used up by the ~[ command but remains as the next one to be processed, and the one clause consequent is processed. If the arg is false, then the argument is used up, and the clause is not processed. The clause therefore should normally use exactly one argument, and may expect it to be non-nil. For example: (setq *print-level* nil *print-length* 5) (format nil "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) => " print length = 5" Note also that (format stream "...~@[str~]..." ...) == (format stream "...~:[~;~:*str~]..." ...) The combination of ~[ and # is useful, for example, for dealing with English conventions for printing lists: (setq foo "Items:~#[ none~; ~S~; ~S and ~S~ ~:;~@{~#[~; and~] ~S~^ ,~}~].") (format nil foo) => "Items: none." (format nil foo 'foo) => "Items: FOO." (format nil foo 'foo 'bar) => "Items: FOO and BAR." (format nil foo 'foo 'bar 'baz) => "Items: FOO, BAR, and BAZ." (format nil foo 'foo 'bar 'baz 'quux) => "Items: FOO, BAR, BAZ, and QUUX."  File: gcl.info, Node: Tilde Right-Bracket-> End of Conditional Expression, Next: Tilde Left-Brace-> Iteration, Prev: Tilde Left-Bracket-> Conditional Expression, Up: FORMAT Control-Flow Operations 22.3.7.3 Tilde Right-Bracket: End of Conditional Expression ........................................................... ~] terminates a ~[. The consequences of using it elsewhere are undefined.  File: gcl.info, Node: Tilde Left-Brace-> Iteration, Next: Tilde Right-Brace-> End of Iteration, Prev: Tilde Right-Bracket-> End of Conditional Expression, Up: FORMAT Control-Flow Operations 22.3.7.4 Tilde Left-Brace: Iteration .................................... ~{str~} This is an iteration construct. The argument should be a list, which is used as a set of arguments as if for a recursive call to format. The string str is used repeatedly as the control string. Each iteration can absorb as many elements of the list as it likes as arguments; if str uses up two arguments by itself, then two elements of the list will get used up each time around the loop. If before any iteration step the list is empty, then the iteration is terminated. Also, if a prefix parameter n is given, then there will be at most n repetitions of processing of str. Finally, the ~^ directive can be used to terminate the iteration prematurely. For example: (format nil "The winners are:~{ ~S~}." '(fred harry jill)) => "The winners are: FRED HARRY JILL." (format nil "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) => "Pairs: ." ~:{ str~} is similar, but the argument should be a list of sublists. At each repetition step, one sublist is used as the set of arguments for processing str; on the next repetition, a new sublist is used, whether or not all of the last sublist had been processed. For example: (format nil "Pairs:~:{ <~S,~S>~} ." '((a 1) (b 2) (c 3))) => "Pairs: ." ~@{ str~} is similar to ~{ str~} , but instead of using one argument that is a list, all the remaining arguments are used as the list of arguments for the iteration. Example: (format nil "Pairs:~@{ <~S,~S>~} ." 'a 1 'b 2 'c 3) => "Pairs: ." If the iteration is terminated before all the remaining arguments are consumed, then any arguments not processed by the iteration remain to be processed by any directives following the iteration construct. ~:@{ str~} combines the features of ~:{ str~} and ~@{ str~} . All the remaining arguments are used, and each one must be a list. On each iteration, the next argument is used as a list of arguments to str. Example: (format nil "Pairs:~:@{ <~S,~S>~} ." '(a 1) '(b 2) '(c 3)) => "Pairs: ." Terminating the repetition construct with ~:} instead of ~} forces str to be processed at least once, even if the initial list of arguments is null. However, this will not override an explicit prefix parameter of zero. If str is empty, then an argument is used as str. It must be a format control and precede any arguments processed by the iteration. As an example, the following are equivalent: (apply #'format stream string arguments) == (format stream "~1{~:}" string arguments) This will use string as a formatting string. The ~1{ says it will be processed at most once, and the ~:} says it will be processed at least once. Therefore it is processed exactly once, using arguments as the arguments. This case may be handled more clearly by the ~? directive, but this general feature of ~{ is more powerful than ~?.  File: gcl.info, Node: Tilde Right-Brace-> End of Iteration, Next: Tilde Question-Mark-> Recursive Processing, Prev: Tilde Left-Brace-> Iteration, Up: FORMAT Control-Flow Operations 22.3.7.5 Tilde Right-Brace: End of Iteration ............................................ ~} terminates a ~{. The consequences of using it elsewhere are undefined.  File: gcl.info, Node: Tilde Question-Mark-> Recursive Processing, Prev: Tilde Right-Brace-> End of Iteration, Up: FORMAT Control-Flow Operations 22.3.7.6 Tilde Question-Mark: Recursive Processing .................................................. The next arg must be a format control, and the one after it a list; both are consumed by the ~? directive. The two are processed as a control-string, with the elements of the list as the arguments. Once the recursive processing has been finished, the processing of the control string containing the ~? directive is resumed. Example: (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) => " 7" (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) => " 7" Note that in the second example three arguments are supplied to the format string "<~A ~D>", but only two are processed and the third is therefore ignored. With the @ modifier, only one arg is directly consumed. The arg must be a string; it is processed as part of the control string as if it had appeared in place of the ~@? construct, and any directives in the recursively processed control string may consume arguments of the control string containing the ~@? directive. Example: (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) => " 7" (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) => " 14"  File: gcl.info, Node: FORMAT Miscellaneous Operations, Next: FORMAT Miscellaneous Pseudo-Operations, Prev: FORMAT Control-Flow Operations, Up: Formatted Output 22.3.8 FORMAT Miscellaneous Operations -------------------------------------- * Menu: * Tilde Left-Paren-> Case Conversion:: * Tilde Right-Paren-> End of Case Conversion:: * Tilde P-> Plural::  File: gcl.info, Node: Tilde Left-Paren-> Case Conversion, Next: Tilde Right-Paren-> End of Case Conversion, Prev: FORMAT Miscellaneous Operations, Up: FORMAT Miscellaneous Operations 22.3.8.1 Tilde Left-Paren: Case Conversion .......................................... ~(str~) The contained control string str is processed, and what it produces is subject to case conversion. With no flags, every uppercase character is converted to the corresponding lowercase character. ~:( capitalizes all words, as if by string-capitalize. ~@( capitalizes just the first word and forces the rest to lower case. ~:@( converts every lowercase character to the corresponding uppercase character. In this example ~@( is used to cause the first word produced by ~@R to be capitalized: (format nil "~@R ~(~@R~)" 14 14) => "XIV xiv" (defun f (n) (format nil "~@(~R~) error~:P detected." n)) => F (f 0) => "Zero errors detected." (f 1) => "One error detected." (f 23) => "Twenty-three errors detected." When case conversions appear nested, the outer conversion dominates, as illustrated in the following example: (format nil "~@(how is ~:(BOB SMITH~)?~)") => "How is bob smith?" NOT=> "How is Bob Smith?"  File: gcl.info, Node: Tilde Right-Paren-> End of Case Conversion, Next: Tilde P-> Plural, Prev: Tilde Left-Paren-> Case Conversion, Up: FORMAT Miscellaneous Operations 22.3.8.2 Tilde Right-Paren: End of Case Conversion .................................................. ~) terminates a ~(. The consequences of using it elsewhere are undefined.  File: gcl.info, Node: Tilde P-> Plural, Prev: Tilde Right-Paren-> End of Case Conversion, Up: FORMAT Miscellaneous Operations 22.3.8.3 Tilde P: Plural ........................ If arg is not eql to the integer 1, a lowercase s is printed; if arg is eql to 1, nothing is printed. If arg is a floating-point 1.0, the s is printed. ~:P does the same thing, after doing a ~:* to back up one argument; that is, it prints a lowercase s if the previous argument was not 1. ~@P prints y if the argument is 1, or ies if it is not. ~:@P does the same thing, but backs up first. (format nil "~D tr~:@P/~D win~:P" 7 1) => "7 tries/1 win" (format nil "~D tr~:@P/~D win~:P" 1 0) => "1 try/0 wins" (format nil "~D tr~:@P/~D win~:P" 1 3) => "1 try/3 wins"  File: gcl.info, Node: FORMAT Miscellaneous Pseudo-Operations, Next: Additional Information about FORMAT Operations, Prev: FORMAT Miscellaneous Operations, Up: Formatted Output 22.3.9 FORMAT Miscellaneous Pseudo-Operations --------------------------------------------- * Menu: * Tilde Semicolon-> Clause Separator:: * Tilde Circumflex-> Escape Upward:: * Tilde Newline-> Ignored Newline::  File: gcl.info, Node: Tilde Semicolon-> Clause Separator, Next: Tilde Circumflex-> Escape Upward, Prev: FORMAT Miscellaneous Pseudo-Operations, Up: FORMAT Miscellaneous Pseudo-Operations 22.3.9.1 Tilde Semicolon: Clause Separator .......................................... This separates clauses in ~[ and ~< constructs. The consequences of using it elsewhere are undefined.  File: gcl.info, Node: Tilde Circumflex-> Escape Upward, Next: Tilde Newline-> Ignored Newline, Prev: Tilde Semicolon-> Clause Separator, Up: FORMAT Miscellaneous Pseudo-Operations 22.3.9.2 Tilde Circumflex: Escape Upward ........................................ ~^ This is an escape construct. If there are no more arguments remaining to be processed, then the immediately enclosing ~{ or ~< construct is terminated. If there is no such enclosing construct, then the entire formatting operation is terminated. In the ~< case, the formatting is performed, but no more segments are processed before doing the justification. ~^ may appear anywhere in a ~{ construct. (setq donestr "Done.~^ ~D warning~:P.~^ ~D error~:P.") => "Done.~^ ~D warning~:P.~^ ~D error~:P." (format nil donestr) => "Done." (format nil donestr 3) => "Done. 3 warnings." (format nil donestr 1 5) => "Done. 1 warning. 5 errors." If a prefix parameter is given, then termination occurs if the parameter is zero. (Hence ~^ is equivalent to ~#^.) If two parameters are given, termination occurs if they are equal. [Reviewer Note by Barmar: Which equality predicate?] If three parameters are given, termination occurs if the first is less than or equal to the second and the second is less than or equal to the third. Of course, this is useless if all the prefix parameters are constants; at least one of them should be a # or a V parameter. If ~^ is used within a ~:{ construct, then it terminates the current iteration step because in the standard case it tests for remaining arguments of the current step only; the next iteration step commences immediately. ~:^ is used to terminate the iteration process. ~:^ may be used only if the command it would terminate is ~:{ or ~:@{ . The entire iteration process is terminated if and only if the sublist that is supplying the arguments for the current iteration step is the last sublist in the case of ~:{ , or the last format argument in the case of ~:@{ . ~:^ is not equivalent to ~#:^; the latter terminates the entire iteration if and only if no arguments remain for the current iteration step. For example: (format nil "~:{ ~@?~:^ ...~} " '(("a") ("b"))) => "a...b" If ~^ appears within a control string being processed under the control of a ~? directive, but not within any ~{ or ~< construct within that string, then the string being processed will be terminated, thereby ending processing of the ~? directive. Processing then continues within the string containing the ~? directive at the point following that directive. If ~^ appears within a ~[ or ~( construct, then all the commands up to the ~^ are properly selected or case-converted, the ~[ or ~( processing is terminated, and the outward search continues for a ~{ or ~< construct to be terminated. For example: (setq tellstr "~@(~@[~R~]~^ ~A!~)") => "~@(~@[~R~]~^ ~A!~)" (format nil tellstr 23) => "Twenty-three!" (format nil tellstr nil "losers") => " Losers!" (format nil tellstr 23 "losers") => "Twenty-three losers!" Following are examples of the use of ~^ within a ~< construct. (format nil "~15<~S~;~^~S~;~^~S~>" 'foo) => " FOO" (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) => "FOO BAR" (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) => "FOO BAR BAZ"  File: gcl.info, Node: Tilde Newline-> Ignored Newline, Prev: Tilde Circumflex-> Escape Upward, Up: FORMAT Miscellaneous Pseudo-Operations 22.3.9.3 Tilde Newline: Ignored Newline ....................................... Tilde immediately followed by a newline ignores the newline and any following non-newline whitespace_1 characters. With a :, the newline is ignored, but any following whitespace_1 is left in place. With an @, the newline is left in place, but any following whitespace_1 is ignored. For example: (defun type-clash-error (fn nargs argnum right-type wrong-type) (format *error-output* "~&~S requires its ~:[~:R~;~*~]~ argument to be of type ~S,~ with an argument of type ~S.~ fn (eql nargs 1) argnum right-type wrong-type)) (type-clash-error 'aref nil 2 'integer 'vector) prints: AREF requires its second argument to be of type INTEGER, but it was called with an argument of type VECTOR. NIL (type-clash-error 'car 1 1 'list 'short-float) prints: CAR requires its argument to be of type LIST, but it was called with an argument of type SHORT-FLOAT. NIL Note that in this example newlines appear in the output only as specified by the ~& and ~% directives; the actual newline characters in the control string are suppressed because each is preceded by a tilde.  File: gcl.info, Node: Additional Information about FORMAT Operations, Next: Examples of FORMAT, Prev: FORMAT Miscellaneous Pseudo-Operations, Up: Formatted Output 22.3.10 Additional Information about FORMAT Operations ------------------------------------------------------ * Menu: * Nesting of FORMAT Operations:: * Missing and Additional FORMAT Arguments:: * Additional FORMAT Parameters:: * Undefined FORMAT Modifier Combinations::  File: gcl.info, Node: Nesting of FORMAT Operations, Next: Missing and Additional FORMAT Arguments, Prev: Additional Information about FORMAT Operations, Up: Additional Information about FORMAT Operations 22.3.10.1 Nesting of FORMAT Operations ...................................... The case-conversion, conditional, iteration, and justification constructs can contain other formatting constructs by bracketing them. These constructs must nest properly with respect to each other. For example, it is not legitimate to put the start of a case-conversion construct in each arm of a conditional and the end of the case-conversion construct outside the conditional: (format nil "~:[abc~:@(def~;ghi~ :@(jkl~]mno~)" x) ;Invalid! This notation is invalid because the ~[...~;...~] and ~(...~) constructs are not properly nested. The processing indirection caused by the ~? directive is also a kind of nesting for the purposes of this rule of proper nesting. It is not permitted to start a bracketing construct within a string processed under control of a ~? directive and end the construct at some point after the ~? construct in the string containing that construct, or vice versa. For example, this situation is invalid: (format nil "~@?ghi~)" "abc~@(def") ;Invalid! This notation is invalid because the ~? and ~(...~) constructs are not properly nested.  File: gcl.info, Node: Missing and Additional FORMAT Arguments, Next: Additional FORMAT Parameters, Prev: Nesting of FORMAT Operations, Up: Additional Information about FORMAT Operations 22.3.10.2 Missing and Additional FORMAT Arguments ................................................. The consequences are undefined if no arg remains for a directive requiring an argument. However, it is permissible for one or more args to remain unprocessed by a directive; such args are ignored.  File: gcl.info, Node: Additional FORMAT Parameters, Next: Undefined FORMAT Modifier Combinations, Prev: Missing and Additional FORMAT Arguments, Up: Additional Information about FORMAT Operations 22.3.10.3 Additional FORMAT Parameters ...................................... The consequences are undefined if a format directive is given more parameters than it is described here as accepting.  File: gcl.info, Node: Undefined FORMAT Modifier Combinations, Prev: Additional FORMAT Parameters, Up: Additional Information about FORMAT Operations 22.3.10.4 Undefined FORMAT Modifier Combinations ................................................ The consequences are undefined if colon or at-sign modifiers are given to a directive in a combination not specifically described here as being meaningful.  File: gcl.info, Node: Examples of FORMAT, Next: Notes about FORMAT, Prev: Additional Information about FORMAT Operations, Up: Formatted Output 22.3.11 Examples of FORMAT -------------------------- (format nil "foo") => "foo" (setq x 5) => 5 (format nil "The answer is ~D." x) => "The answer is 5." (format nil "The answer is ~3D." x) => "The answer is 5." (format nil "The answer is ~3,'0D." x) => "The answer is 005." (format nil "The answer is ~:D." (expt 47 x)) => "The answer is 229,345,007." (setq y "elephant") => "elephant" (format nil "Look at the ~A!" y) => "Look at the elephant!" (setq n 3) => 3 (format nil "~D item~:P found." n) => "3 items found." (format nil "~R dog~:[s are~; is~] here." n (= n 1)) => "three dogs are here." (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) => "three dogs are here." (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) => "Here are three puppies." (defun foo (x) (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x)) => FOO (foo 3.14159) => " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (foo -3.14159) => " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (foo 100.0) => "100.00|******|100.00| 100.0|100.00|100.0" (foo 1234.0) => "1234.00|******|??????|1234.0|1234.00|1234.0" (foo 0.006) => " 0.01| 0.06| 0.01| 0.006|0.01|0.006" (defun foo (x) (format nil "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~ ~9,3,2,-2,' x x x x)) (foo 3.14159) => " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" (foo -3.14159) => " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" (foo 1100.0) => " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" (foo 1100.0L0) => " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" (foo 1.1E13) => "*********| 11.00$+12|+.001E+16| 1.10E+13" (foo 1.1L120) => "*********|??????????| (foo 1.1L1200) => "*********|??????????| As an example of the effects of varying the scale factor, the code (dotimes (k 13) (format t "~ (- k 5) (- k 5) 3.14159)) produces the following output: Scale factor -5: | 0.000003E+06| Scale factor -4: | 0.000031E+05| Scale factor -3: | 0.000314E+04| Scale factor -2: | 0.003142E+03| Scale factor -1: | 0.031416E+02| Scale factor 0: | 0.314159E+01| Scale factor 1: | 3.141590E+00| Scale factor 2: | 31.41590E-01| Scale factor 3: | 314.1590E-02| Scale factor 4: | 3141.590E-03| Scale factor 5: | 31415.90E-04| Scale factor 6: | 314159.0E-05| Scale factor 7: | 3141590.E-06| (defun foo (x) (format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,' x x x x)) (foo 0.0314159) => " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" (foo 0.314159) => " 0.31 |0.314 |0.314 | 0.31 " (foo 3.14159) => " 3.1 | 3.14 | 3.14 | 3.1 " (foo 31.4159) => " 31. | 31.4 | 31.4 | 31. " (foo 314.159) => " 3.14E+2| 314. | 314. | 3.14E+2" (foo 3141.59) => " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" (foo 3141.59L0) => " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" (foo 3.14E12) => "*********|314.0$+10|0.314E+13| 3.14E+12" (foo 3.14L120) => "*********|?????????| (foo 3.14L1200) => "*********|?????????| (format nil "~10") => "foo bar" (format nil "~10:") => " foo bar" (format nil "~10") => " foobar" (format nil "~10:") => " foobar" (format nil "~10:@") => " foo bar " (format nil "~10@") => "foobar " (format nil "~10:@") => " foobar " (FORMAT NIL "Written to ~A." #P"foo.bin") => "Written to foo.bin."  File: gcl.info, Node: Notes about FORMAT, Prev: Examples of FORMAT, Up: Formatted Output 22.3.12 Notes about FORMAT -------------------------- Formatted output is performed not only by format, but by certain other functions that accept a format control the way format does. For example, error-signaling functions such as cerror accept format controls. Note that the meaning of nil and t as destinations to format are different than those of nil and t as stream designators. The ~^ should appear only at the beginning of a ~< clause, because it aborts the entire clause in which it appears (as well as all following clauses).  File: gcl.info, Node: Printer Dictionary, Prev: Formatted Output, Up: Printer 22.4 Printer Dictionary ======================= * Menu: * copy-pprint-dispatch:: * formatter:: * pprint-dispatch:: * pprint-exit-if-list-exhausted:: * pprint-fill:: * pprint-indent:: * pprint-logical-block:: * pprint-newline:: * pprint-pop:: * pprint-tab:: * print-object:: * print-unreadable-object:: * set-pprint-dispatch:: * write:: * write-to-string:: * *print-array*:: * *print-base*:: * *print-case*:: * *print-circle*:: * *print-escape*:: * *print-gensym*:: * *print-level*:: * *print-lines*:: * *print-miser-width*:: * *print-pprint-dispatch*:: * *print-pretty*:: * *print-readably*:: * *print-right-margin*:: * print-not-readable:: * print-not-readable-object:: * format::  File: gcl.info, Node: copy-pprint-dispatch, Next: formatter, Prev: Printer Dictionary, Up: Printer Dictionary 22.4.1 copy-pprint-dispatch [Function] -------------------------------------- 'copy-pprint-dispatch' &optional table => new-table Arguments and Values:: ...................... table--a pprint dispatch table, or nil. new-table--a fresh pprint dispatch table. Description:: ............. Creates and returns a copy of the specified table, or of the value of *print-pprint-dispatch* if no table is specified, or of the initial value of *print-pprint-dispatch* if nil is specified. Exceptional Situations:: ........................ Should signal an error of type type-error if table is not a pprint dispatch table.  File: gcl.info, Node: formatter, Next: pprint-dispatch, Prev: copy-pprint-dispatch, Up: Printer Dictionary 22.4.2 formatter [Macro] ------------------------ 'formatter' control-string => function Arguments and Values:: ...................... control-string--a format string; not evaluated. function--a function. Description:: ............. Returns a function which has behavior equivalent to: #'(lambda (*standard-output* &rest arguments) (apply #'format t control-string arguments) arguments-tail) where arguments-tail is either the tail of arguments which has as its car the argument that would be processed next if there were more format directives in the control-string, or else nil if no more arguments follow the most recently processed argument. Examples:: .......... (funcall (formatter "~&~A~A") *standard-output* 'a 'b 'c) |> AB => (C) (format t (formatter "~&~A~A") 'a 'b 'c) |> AB => NIL Exceptional Situations:: ........................ Might signal an error (at macro expansion time or at run time) if the argument is not a valid format string. See Also:: .......... *note format::  File: gcl.info, Node: pprint-dispatch, Next: pprint-exit-if-list-exhausted, Prev: formatter, Up: Printer Dictionary 22.4.3 pprint-dispatch [Function] --------------------------------- 'pprint-dispatch' object &optional table => function, found-p Arguments and Values:: ...................... object--an object. table--a pprint dispatch table, or nil. The default is the value of *print-pprint-dispatch*. function--a function designator. found-p--a generalized boolean. Description:: ............. Retrieves the highest priority function in table that is associated with a type specifier that matches object. The function is chosen by finding all of the type specifiers in table that match the object and selecting the highest priority function associated with any of these type specifiers. If there is more than one highest priority function, an arbitrary choice is made. If no type specifiers match the object, a function is returned that prints object using print-object. The secondary value, found-p, is true if a matching type specifier was found in table, or false otherwise. If table is nil, retrieval is done in the initial pprint dispatch table. Affected By:: ............. The state of the table. Exceptional Situations:: ........................ Should signal an error of type type-error if table is neither a pprint-dispatch-table nor nil. Notes:: ....... (let ((*print-pretty* t)) (write object :stream s)) == (funcall (pprint-dispatch object) s object)  File: gcl.info, Node: pprint-exit-if-list-exhausted, Next: pprint-fill, Prev: pprint-dispatch, Up: Printer Dictionary 22.4.4 pprint-exit-if-list-exhausted [Local Macro] -------------------------------------------------- Syntax:: ........ 'pprint-exit-if-list-exhausted' => nil Description:: ............. Tests whether or not the list passed to the lexically current logical block has been exhausted; see *note Dynamic Control of the Arrangement of Output::. If this list has been reduced to nil, pprint-exit-if-list-exhausted terminates the execution of the lexically current logical block except for the printing of the suffix. Otherwise pprint-exit-if-list-exhausted returns nil. Whether or not pprint-exit-if-list-exhausted is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of pprint-exit-if-list-exhausted are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use pprint-exit-if-list-exhausted outside of pprint-logical-block are undefined. Exceptional Situations:: ........................ An error is signaled (at macro expansion time or at run time) if pprint-exit-if-list-exhausted is used anywhere other than lexically within a call on pprint-logical-block. Also, the consequences of executing pprint-if-list-exhausted outside of the dynamic extent of the pprint-logical-block which lexically contains it are undefined. See Also:: .......... *note pprint-logical-block:: , *note pprint-pop:: .  File: gcl.info, Node: pprint-fill, Next: pprint-indent, Prev: pprint-exit-if-list-exhausted, Up: Printer Dictionary 22.4.5 pprint-fill, pprint-linear, pprint-tabular [Function] ------------------------------------------------------------ 'pprint-fill' stream object &optional colon-p at-sign-p => nil 'pprint-linear' stream object &optional colon-p at-sign-p => nil 'pprint-tabular' stream object &optional colon-p at-sign-p tabsize => nil Arguments and Values:: ...................... stream--an output stream designator. object--an object. colon-p--a generalized boolean. The default is true. at-sign-p--a generalized boolean. The default is implementation-dependent. tabsize--a non-negative integer. The default is 16. Description:: ............. The functions pprint-fill, pprint-linear, and pprint-tabular specify particular ways of pretty printing a list to stream. Each function prints parentheses around the output if and only if colon-p is true. Each function ignores its at-sign-p argument. (Both arguments are included even though only one is needed so that these functions can be used via ~/.../ and as set-pprint-dispatch functions, as well as directly.) Each function handles abbreviation and the detection of circularity and sharing correctly, and uses write to print object when it is a non-list. If object is a list and if the value of *print-pretty* is false, each of these functions prints object using a minimum of whitespace, as described in *note Printing Lists and Conses::. Otherwise (if object is a list and if the value of *print-pretty* is true): * The function pprint-linear prints a list either all on one line, or with each element on a separate line. * The function pprint-fill prints a list with as many elements as possible on each line. * The function pprint-tabular is the same as pprint-fill except that it prints the elements so that they line up in columns. The tabsize specifies the column spacing in ems, which is the total spacing from the leading edge of one column to the leading edge of the next. Examples:: .......... Evaluating the following with a line length of 25 produces the output shown. (progn (princ "Roads ") (pprint-tabular *standard-output* '(elm main maple center) nil nil 8)) Roads ELM MAIN MAPLE CENTER Side Effects:: .............. Performs output to the indicated stream. Affected By:: ............. The cursor position on the indicated stream, if it can be determined. Notes:: ....... The function pprint-tabular could be defined as follows: (defun pprint-tabular (s list &optional (colon-p t) at-sign-p (tabsize nil)) (declare (ignore at-sign-p)) (when (null tabsize) (setq tabsize 16)) (pprint-logical-block (s list :prefix (if colon-p "(" "") :suffix (if colon-p ")" "")) (pprint-exit-if-list-exhausted) (loop (write (pprint-pop) :stream s) (pprint-exit-if-list-exhausted) (write-char #\Space s) (pprint-tab :section-relative 0 tabsize s) (pprint-newline :fill s)))) Note that it would have been inconvenient to specify this function using format, because of the need to pass its tabsize argument through to a ~:T format directive nested within an iteration over a list.  File: gcl.info, Node: pprint-indent, Next: pprint-logical-block, Prev: pprint-fill, Up: Printer Dictionary 22.4.6 pprint-indent [Function] ------------------------------- 'pprint-indent' relative-to n &optional stream => nil Arguments and Values:: ...................... relative-to--either :block or :current. n--a real. stream--an output stream designator. The default is standard output. Description:: ............. pprint-indent specifies the indentation to use in a logical block on stream. If stream is a pretty printing stream and the value of *print-pretty* is true, pprint-indent sets the indentation in the innermost dynamically enclosing logical block; otherwise, pprint-indent has no effect. N specifies the indentation in ems. If relative-to is :block, the indentation is set to the horizontal position of the first character in the dynamically current logical block plus n ems. If relative-to is :current, the indentation is set to the current output position plus n ems. (For robustness in the face of variable-width fonts, it is advisable to use :current with an n of zero whenever possible.) N can be negative; however, the total indentation cannot be moved left of the beginning of the line or left of the end of the rightmost per-line prefix--an attempt to move beyond one of these limits is treated the same as an attempt to move to that limit. Changes in indentation caused by pprint-indent do not take effect until after the next line break. In addition, in miser mode all calls to pprint-indent are ignored, forcing the lines corresponding to the logical block to line up under the first character in the block. Exceptional Situations:: ........................ An error is signaled if relative-to is any object other than :block or :current. See Also:: .......... *note Tilde I-> Indent::  File: gcl.info, Node: pprint-logical-block, Next: pprint-newline, Prev: pprint-indent, Up: Printer Dictionary 22.4.7 pprint-logical-block [Macro] ----------------------------------- 'pprint-logical-block' (stream-symbol object &key prefix per-line-prefix suffix) {declaration}* {form}* => nil Arguments and Values:: ...................... stream-symbol--a stream variable designator. object--an object; evaluated. :prefix--a string; evaluated. Complicated defaulting behavior; see below. :per-line-prefix--a string; evaluated. Complicated defaulting behavior; see below. :suffix--a string; evaluated. The default is the null string. declaration--a declare expression; not evaluated. forms--an implicit progn. Description:: ............. Causes printing to be grouped into a logical block. The logical block is printed to the stream that is the value of the variable denoted by stream-symbol. During the execution of the forms, that variable is bound to a pretty printing stream that supports decisions about the arrangement of output and then forwards the output to the destination stream. All the standard printing functions (e.g., write, princ, and terpri) can be used to print output to the pretty printing stream. All and only the output sent to this pretty printing stream is treated as being in the logical block. The prefix specifies a prefix to be printed before the beginning of the logical block. The per-line-prefix specifies a prefix that is printed before the block and at the beginning of each new line in the block. The :prefix and :pre-line-prefix arguments are mutually exclusive. If neither :prefix nor :per-line-prefix is specified, a prefix of the null string is assumed. The suffix specifies a suffix that is printed just after the logical block. The object is normally a list that the body forms are responsible for printing. If object is not a list, it is printed using write. (This makes it easier to write printing functions that are robust in the face of malformed arguments.) If *print-circle* is non-nil and object is a circular (or shared) reference to a cons, then an appropriate "#n#" marker is printed. (This makes it easy to write printing functions that provide full support for circularity and sharing abbreviation.) If *print-level* is not nil and the logical block is at a dynamic nesting depth of greater than *print-level* in logical blocks, "#" is printed. (This makes easy to write printing functions that provide full support for depth abbreviation.) If either of the three conditions above occurs, the indicated output is printed on stream-symbol and the body forms are skipped along with the printing of the :prefix and :suffix. (If the body forms are not to be responsible for printing a list, then the first two tests above can be turned off by supplying nil for the object argument.) In addition to the object argument of pprint-logical-block, the arguments of the standard printing functions (such as write, print, prin1, and pprint, as well as the arguments of the standard format directives such as ~A, ~S, (and ~W) are all checked (when necessary) for circularity and sharing. However, such checking is not applied to the arguments of the functions write-line, write-string, and write-char or to the literal text output by format. A consequence of this is that you must use one of the latter functions if you want to print some literal text in the output that is not supposed to be checked for circularity or sharing. The body forms of a pprint-logical-block form must not perform any side-effects on the surrounding environment; for example, no variables must be assigned which have not been bound within its scope. The pprint-logical-block macro may be used regardless of the value of *print-pretty*. Affected By:: ............. *print-circle*, *print-level*. Exceptional Situations:: ........................ An error of type type-error is signaled if any of the :suffix, :prefix, or :per-line-prefix is supplied but does not evaluate to a string. An error is signaled if :prefix and :pre-line-prefix are both used. pprint-logical-block and the pretty printing stream it creates have dynamic extent. The consequences are undefined if, outside of this extent, output is attempted to the pretty printing stream it creates. It is also unspecified what happens if, within this extent, any output is sent directly to the underlying destination stream. See Also:: .......... *note pprint-pop:: , *note pprint-exit-if-list-exhausted:: , *note Tilde Less-Than-Sign-> Logical Block:: Notes:: ....... One reason for using the pprint-logical-block macro when the value of *print-pretty* is nil would be to allow it to perform checking for dotted lists, as well as (in conjunction with pprint-pop) checking for *print-level* or *print-length* being exceeded. Detection of circularity and sharing is supported by the pretty printer by in essence performing requested output twice. On the first pass, circularities and sharing are detected and the actual outputting of characters is suppressed. On the second pass, the appropriate "#n=" and "#n#" markers are inserted and characters are output. This is why the restriction on side-effects is necessary. Obeying this restriction is facilitated by using pprint-pop, instead of an ordinary pop when traversing a list being printed by the body forms of the pprint-logical-block form.)  File: gcl.info, Node: pprint-newline, Next: pprint-pop, Prev: pprint-logical-block, Up: Printer Dictionary 22.4.8 pprint-newline [Function] -------------------------------- 'pprint-newline' kind &optional stream => nil Arguments and Values:: ...................... kind--one of :linear, :fill, :miser, or :mandatory. stream--a stream designator. The default is standard output. Description:: ............. If stream is a pretty printing stream and the value of *print-pretty* is true, a line break is inserted in the output when the appropriate condition below is satisfied; otherwise, pprint-newline has no effect. Kind specifies the style of conditional newline. This parameter is treated as follows: :linear This specifies a "linear-style" conditional newline. A line break is inserted if and only if the immediately containing section cannot be printed on one line. The effect of this is that line breaks are either inserted at every linear-style conditional newline in a logical block or at none of them. :miser This specifies a "miser-style" conditional newline. A line break is inserted if and only if the immediately containing section cannot be printed on one line and miser style is in effect in the immediately containing logical block. The effect of this is that miser-style conditional newlines act like linear-style conditional newlines, but only when miser style is in effect. Miser style is in effect for a logical block if and only if the starting position of the logical block is less than or equal to *print-miser-width* ems from the right margin. :fill This specifies a "fill-style" conditional newline. A line break is inserted if and only if either (a) the following section cannot be printed on the end of the current line, (b) the preceding section was not printed on a single line, or (c) the immediately containing section cannot be printed on one line and miser style is in effect in the immediately containing logical block. If a logical block is broken up into a number of subsections by fill-style conditional newlines, the basic effect is that the logical block is printed with as many subsections as possible on each line. However, if miser style is in effect, fill-style conditional newlines act like linear-style conditional newlines. :mandatory This specifies a "mandatory-style" conditional newline. A line break is always inserted. This implies that none of the containing sections can be printed on a single line and will therefore trigger the insertion of line breaks at linear-style conditional newlines in these sections. When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are omitted from the output and indentation is introduced at the beginning of the next line. By default, the indentation causes the following line to begin in the same horizontal position as the first character in the immediately containing logical block. (The indentation can be changed via pprint-indent.) There are a variety of ways unconditional newlines can be introduced into the output (i.e., via terpri or by printing a string containing a newline character). As with mandatory conditional newlines, this prevents any of the containing sections from being printed on one line. In general, when an unconditional newline is encountered, it is printed out without suppression of the preceding blanks and without any indentation following it. However, if a per-line prefix has been specified (see pprint-logical-block), this prefix will always be printed no matter how a newline originates. Examples:: .......... See *note Examples of using the Pretty Printer::. Side Effects:: .............. Output to stream. Affected By:: ............. *print-pretty*, *print-miser*. The presence of containing logical blocks. The placement of newlines and conditional newlines. Exceptional Situations:: ........................ An error of type type-error is signaled if kind is not one of :linear, :fill, :miser, or :mandatory. See Also:: .......... *note Tilde Underscore-> Conditional Newline::, *note Examples of using the Pretty Printer::  File: gcl.info, Node: pprint-pop, Next: pprint-tab, Prev: pprint-newline, Up: Printer Dictionary 22.4.9 pprint-pop [Local Macro] ------------------------------- Syntax:: ........ 'pprint-pop' => object Arguments and Values:: ...................... object--an element of the list being printed in the lexically current logical block, or nil. Description:: ............. Pops one element from the list being printed in the lexically current logical block, obeying *print-length* and *print-circle* as described below. Each time pprint-pop is called, it pops the next value off the list passed to the lexically current logical block and returns it. However, before doing this, it performs three tests: * If the remaining 'list' is not a list, ". " is printed followed by the remaining 'list.' (This makes it easier to write printing functions that are robust in the face of malformed arguments.) * If *print-length* is non-nil, and pprint-pop has already been called *print-length* times within the immediately containing logical block, "..." is printed. (This makes it easy to write printing functions that properly handle *print-length*.) * If *print-circle* is non-nil, and the remaining list is a circular (or shared) reference, then ". " is printed followed by an appropriate "#n#" marker. (This catches instances of cdr circularity and sharing in lists.) If either of the three conditions above occurs, the indicated output is printed on the pretty printing stream created by the immediately containing pprint-logical-block and the execution of the immediately containing pprint-logical-block is terminated except for the printing of the suffix. If pprint-logical-block is given a 'list' argument of nil--because it is not processing a list--pprint-pop can still be used to obtain support for *print-length*. In this situation, the first and third tests above are disabled and pprint-pop always returns nil. See *note Examples of using the Pretty Printer::--specifically, the pprint-vector example. Whether or not pprint-pop is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of pprint-pop are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use pprint-pop outside of pprint-logical-block are undefined. Side Effects:: .............. Might cause output to the pretty printing stream associated with the lexically current logical block. Affected By:: ............. *print-length*, *print-circle*. Exceptional Situations:: ........................ An error is signaled (either at macro expansion time or at run time) if a usage of pprint-pop occurs where there is no lexically containing pprint-logical-block form. The consequences are undefined if pprint-pop is executed outside of the dynamic extent of this pprint-logical-block. See Also:: .......... *note pprint-exit-if-list-exhausted:: , *note pprint-logical-block:: . Notes:: ....... It is frequently a good idea to call pprint-exit-if-list-exhausted before calling pprint-pop.  File: gcl.info, Node: pprint-tab, Next: print-object, Prev: pprint-pop, Up: Printer Dictionary 22.4.10 pprint-tab [Function] ----------------------------- 'pprint-tab' kind colnum colinc &optional stream => nil Arguments and Values:: ...................... kind--one of :line, :section, :line-relative, or :section-relative. colnum--a non-negative integer. colinc--a non-negative integer. stream--an output stream designator. Description:: ............. Specifies tabbing to stream as performed by the standard ~T format directive. If stream is a pretty printing stream and the value of *print-pretty* is true, tabbing is performed; otherwise, pprint-tab has no effect. The arguments colnum and colinc correspond to the two parameters to ~T and are in terms of ems. The kind argument specifies the style of tabbing. It must be one of :line (tab as by ~T), :section (tab as by ~:T, but measuring horizontal positions relative to the start of the dynamically enclosing section), :line-relative (tab as by ~@T), or :section-relative (tab as by ~:@T, but measuring horizontal positions relative to the start of the dynamically enclosing section). Exceptional Situations:: ........................ An error is signaled if kind is not one of :line, :section, :line-relative, or :section-relative. See Also:: .......... *note pprint-logical-block::  File: gcl.info, Node: print-object, Next: print-unreadable-object, Prev: pprint-tab, Up: Printer Dictionary 22.4.11 print-object [Standard Generic Function] ------------------------------------------------ Syntax:: ........ 'print-object' object stream => object Method Signatures:: ................... 'print-object' (object standard-object) stream 'print-object' (object structure-object) stream Arguments and Values:: ...................... object--an object. stream--a stream. Description:: ............. The generic function print-object writes the printed representation of object to stream. The function print-object is called by the Lisp printer; it should not be called by the user. Each implementation is required to provide a method on the class standard-object and on the class structure-object. In addition, each implementation must provide methods on enough other classes so as to ensure that there is always an applicable method. Implementations are free to add methods for other classes. Users may write methods for print-object for their own classes if they do not wish to inherit an implementation-dependent method. The method on the class structure-object prints the object in the default #S notation; see *note Printing Structures::. Methods on print-object are responsible for implementing their part of the semantics of the printer control variables, as follows: *print-readably* All methods for print-object must obey *print-readably*. This includes both user-defined methods and implementation-defined methods. Readable printing of structures and standard objects is controlled by their print-object method, not by their make-load-form method. Similarity for these objects is application dependent and hence is defined to be whatever these methods do; see *note Similarity of Literal Objects::. *print-escape* Each method must implement *print-escape*. *print-pretty* The method may wish to perform specialized line breaking or other output conditional on the value of *print-pretty*. For further information, see (for example) the macro pprint-fill. See also *note Pretty Print Dispatch Tables:: and *note Examples of using the Pretty Printer::. *print-length* Methods that produce output of indefinite length must obey *print-length*. For further information, see (for example) the macros pprint-logical-block and pprint-pop. See also *note Pretty Print Dispatch Tables:: and *note Examples of using the Pretty Printer::. *print-level* The printer takes care of *print-level* automatically, provided that each method handles exactly one level of structure and calls write (or an equivalent function) recursively if there are more structural levels. The printer's decision of whether an object has components (and therefore should not be printed when the printing depth is not less than *print-level*) is implementation-dependent. In some implementations its print-object method is not called; in others the method is called, and the determination that the object has components is based on what it tries to write to the stream. *print-circle* When the value of *print-circle* is true, a user-defined print-object method can print objects to the supplied stream using write, prin1, princ, or format and expect circularities to be detected and printed using the #n# syntax. If a user-defined print-object method prints to a stream other than the one that was supplied, then circularity detection starts over for that stream. See *print-circle*. *print-base*, *print-radix*, *print-case*, *print-gensym*, and *print-array* These printer control variables apply to specific types of objects and are handled by the methods for those objects. If these rules are not obeyed, the results are undefined. In general, the printer and the print-object methods should not rebind the print control variables as they operate recursively through the structure, but this is implementation-dependent. In some implementations the stream argument passed to a print-object method is not the original stream, but is an intermediate stream that implements part of the printer. methods should therefore not depend on the identity of this stream. See Also:: .......... *note pprint-fill:: , *note pprint-logical-block:: , *note pprint-pop:: , *note write:: , *print-readably*, *print-escape*, *print-pretty*, *print-length*, *note Default Print-Object Methods::, *note Printing Structures::, *note Pretty Print Dispatch Tables::, *note Examples of using the Pretty Printer::  File: gcl.info, Node: print-unreadable-object, Next: set-pprint-dispatch, Prev: print-object, Up: Printer Dictionary 22.4.12 print-unreadable-object [Macro] --------------------------------------- 'print-unreadable-object' (object stream &key type identity) {form}* => nil Arguments and Values:: ...................... object--an object; evaluated. stream-- a stream designator; evaluated. type--a generalized boolean; evaluated. identity--a generalized boolean; evaluated. forms--an implicit progn. Description:: ............. Outputs a printed representation of object on stream, beginning with "#<" and ending with ">". Everything output to stream by the body forms is enclosed in the the angle brackets. If type is true, the output from forms is preceded by a brief description of the object's type and a space character. If identity is true, the output from forms is followed by a space character and a representation of the object's identity, typically a storage address. If either type or identity is not supplied, its value is false. It is valid to omit the body forms. If type and identity are both true and there are no body forms, only one space character separates the type and the identity. Examples:: .......... ;; Note that in this example, the precise form of the output ;; is implementation-dependent. (defmethod print-object ((obj airplane) stream) (print-unreadable-object (obj stream :type t :identity t) (princ (tail-number obj) stream))) (prin1-to-string my-airplane) => "#" OR=> "#" Exceptional Situations:: ........................ If *print-readably* is true, print-unreadable-object signals an error of type print-not-readable without printing anything.  File: gcl.info, Node: set-pprint-dispatch, Next: write, Prev: print-unreadable-object, Up: Printer Dictionary 22.4.13 set-pprint-dispatch [Function] -------------------------------------- 'set-pprint-dispatch' type-specifier function &optional priority table => nil Arguments and Values:: ...................... type-specifier--a type specifier. function--a function, a function name, or nil. priority--a real. The default is 0. table--a pprint dispatch table. The default is the value of *print-pprint-dispatch*. Description:: ............. Installs an entry into the pprint dispatch table which is table. Type-specifier is the key of the entry. The first action of set-pprint-dispatch is to remove any pre-existing entry associated with type-specifier. This guarantees that there will never be two entries associated with the same type specifier in a given pprint dispatch table. Equality of type specifiers is tested by equal. Two values are associated with each type specifier in a pprint dispatch table: a function and a priority. The function must accept two arguments: the stream to which output is sent and the object to be printed. The function should pretty print the object to the stream. The function can assume that object satisfies the type given by type-specifier. The function must obey *print-readably*. Any values returned by the function are ignored. Priority is a priority to resolve conflicts when an object matches more than one entry. It is permissible for function to be nil. In this situation, there will be no type-specifier entry in table after set-pprint-dispatch returns. Exceptional Situations:: ........................ An error is signaled if priority is not a real. Notes:: ....... Since pprint dispatch tables are often used to control the pretty printing of Lisp code, it is common for the type-specifier to be an expression of the form (cons car-type cdr-type) This signifies that the corresponding object must be a cons cell whose car matches the type specifier car-type and whose cdr matches the type specifier cdr-type. The cdr-type can be omitted in which case it defaults to t.  File: gcl.info, Node: write, Next: write-to-string, Prev: set-pprint-dispatch, Up: Printer Dictionary 22.4.14 write, prin1, print, pprint, princ [Function] ----------------------------------------------------- 'write' object &key \writekeysstream => object 'prin' 1 => object &optional output-stream object 'princ' object &optional output-stream => object 'print' object &optional output-stream => object 'pprint' object &optional output-stream => Arguments and Values:: ...................... object--an object. output-stream--an output stream designator. The default is standard output. \writekeydescriptionsstream--an output stream designator. The default is standard output. Description:: ............. write, prin1, princ, print, and pprint write the printed representation of object to output-stream. write is the general entry point to the Lisp printer. For each explicitly supplied keyword parameter named in Figure 22-6, the corresponding printer control variable is dynamically bound to its value while printing goes on; for each keyword parameter in Figure 22-6 that is not explicitly supplied, the value of the corresponding printer control variable is the same as it was at the time write was invoked. Once the appropriate bindings are established, the object is output by the Lisp printer. Parameter Corresponding Dynamic Variable array *print-array* base *print-base* case *print-case* circle *print-circle* escape *print-escape* gensym *print-gensym* length *print-length* level *print-level* lines *print-lines* miser-width *print-miser-width* pprint-dispatch *print-pprint-dispatch* pretty *print-pretty* radix *print-radix* readably *print-readably* right-margin *print-right-margin* Figure 22-6: Argument correspondences for the WRITE function. prin1, princ, print, and pprint implicitly bind certain print parameters to particular values. The remaining parameter values are taken from *print-array*, *print-base*, *print-case*, *print-circle*, *print-escape*, *print-gensym*, *print-length*, *print-level*, *print-lines*, *print-miser-width*, *print-pprint-dispatch*, *print-pretty*, *print-radix*, and *print-right-margin*. prin1 produces output suitable for input to read. It binds *print-escape* to true. princ is just like prin1 except that the output has no escape characters. It binds *print-escape* to false and *print-readably* to false. The general rule is that output from princ is intended to look good to people, while output from prin1 is intended to be acceptable to read. print is just like prin1 except that the printed representation of object is preceded by a newline and followed by a space. pprint is just like print except that the trailing space is omitted and object is printed with the *print-pretty* flag non-nil to produce pretty output. Output-stream specifies the stream to which output is to be sent. Affected By:: ............. *standard-output*, *terminal-io*, *print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*, *read-default-float-format*. See Also:: .......... *note readtable-case:: , *note FORMAT Printer Operations:: Notes:: ....... The functions prin1 and print do not bind *print-readably*. (prin1 object output-stream) == (write object :stream output-stream :escape t) (princ object output-stream) == (write object stream output-stream :escape nil :readably nil) (print object output-stream) == (progn (terpri output-stream) (write object :stream output-stream :escape t) (write-char #\space output-stream)) (pprint object output-stream) == (write object :stream output-stream :escape t :pretty t)  File: gcl.info, Node: write-to-string, Next: *print-array*, Prev: write, Up: Printer Dictionary 22.4.15 write-to-string, prin1-to-string, princ-to-string [Function] -------------------------------------------------------------------- 'write-to-string' object &key \writekeys => string 'prin' 1 => -to-string object string 'princ-to-string' object => string Arguments and Values:: ...................... object--an object. \writekeydescriptions string--a string. Description:: ............. write-to-string, prin1-to-string, and princ-to-string are used to create a string consisting of the printed representation of object. Object is effectively printed as if by write, prin1, or princ, respectively, and the characters that would be output are made into a string. write-to-string is the general output function. It has the ability to specify all the parameters applicable to the printing of object. prin1-to-string acts like write-to-string with :escape t, that is, escape characters are written where appropriate. princ-to-string acts like write-to-string with :escape nil :readably nil. Thus no escape characters are written. All other keywords that would be specified to write-to-string are default values when prin1-to-string or princ-to-string is invoked. The meanings and defaults for the keyword arguments to write-to-string are the same as those for write. Examples:: .......... (prin1-to-string "abc") => "\"abc\"" (princ-to-string "abc") => "abc" Affected By:: ............. *print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*, *read-default-float-format*. See Also:: .......... *note write:: Notes:: ....... (write-to-string object {key argument}*) == (with-output-to-string (#1=#:string-stream) (write object :stream #1# {key argument}*)) (princ-to-string object) == (with-output-to-string (string-stream) (princ object string-stream)) (prin1-to-string object) == (with-output-to-string (string-stream) (prin1 object string-stream))  File: gcl.info, Node: *print-array*, Next: *print-base*, Prev: write-to-string, Up: Printer Dictionary 22.4.16 *print-array* [Variable] -------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... implementation-dependent. Description:: ............. Controls the format in which arrays are printed. If it is false, the contents of arrays other than strings are never printed. Instead, arrays are printed in a concise form using #< that gives enough information for the user to be able to identify the array, but does not include the entire array contents. If it is true, non-string arrays are printed using #(...), #*, or #nA syntax. Affected By:: ............. The implementation. See Also:: .......... *note Sharpsign Left-Parenthesis::, *note Sharpsign Less-Than-Sign::  File: gcl.info, Node: *print-base*, Next: *print-case*, Prev: *print-array*, Up: Printer Dictionary 22.4.17 *print-base*, *print-radix* [Variable] ---------------------------------------------- Value Type:: ............ *print-base*--a radix. *print-radix*--a generalized boolean. Initial Value:: ............... The initial value of *print-base* is 10. The initial value of *print-radix* is false. Description:: ............. *print-base* and *print-radix* control the printing of rationals. The value of *print-base* is called the current output base . The value of *print-base* is the radix in which the printer will print rationals. For radices above 10, letters of the alphabet are used to represent digits above 9. If the value of *print-radix* is true, the printer will print a radix specifier to indicate the radix in which it is printing a rational number. The radix specifier is always printed using lowercase letters. If *print-base* is 2, 8, or 16, then the radix specifier used is #b, #o, or #x, respectively. For integers, base ten is indicated by a trailing decimal point instead of a leading radix specifier; for ratios, #10r is used. Examples:: .......... (let ((*print-base* 24.) (*print-radix* t)) (print 23.)) |> #24rN => 23 (setq *print-base* 10) => 10 (setq *print-radix* nil) => NIL (dotimes (i 35) (let ((*print-base* (+ i 2))) ;print the decimal number 40 (write 40) ;in each base from 2 to 36 (if (zerop (mod i 10)) (terpri) (format t " ")))) |> 101000 |> 1111 220 130 104 55 50 44 40 37 34 |> 31 2C 2A 28 26 24 22 20 1J 1I |> 1H 1G 1F 1E 1D 1C 1B 1A 19 18 |> 17 16 15 14 => NIL (dolist (pb '(2 3 8 10 16)) (let ((*print-radix* t) ;print the integer 10 and (*print-base* pb)) ;the ratio 1/10 in bases 2, (format t "~&~S ~S~ |> #b1010 #b1/1010 |> #3r101 #3r1/101 |> #o12 #o1/12 |> 10. #10r1/10 |> #xA #x1/A => NIL Affected By:: ............. Might be bound by format, and write, write-to-string. See Also:: .......... *note format:: , *note write:: , *note write-to-string::  File: gcl.info, Node: *print-case*, Next: *print-circle*, Prev: *print-base*, Up: Printer Dictionary 22.4.18 *print-case* [Variable] ------------------------------- Value Type:: ............ One of the symbols :upcase, :downcase, or :capitalize. Initial Value:: ............... The symbol :upcase. Description:: ............. The value of *print-case* controls the case (upper, lower, or mixed) in which to print any uppercase characters in the names of symbols when vertical-bar syntax is not used. *print-case* has an effect at all times when the value of *print-escape* is false. *print-case* also has an effect when the value of *print-escape* is true unless inside an escape context (i.e., unless between vertical-bars or after a slash). Examples:: .......... (defun test-print-case () (dolist (*print-case* '(:upcase :downcase :capitalize)) (format t "~&~S ~S~ => TEST-PC ;; Although the choice of which characters to escape is specified by ;; *PRINT-CASE*, the choice of how to escape those characters ;; (i.e., whether single escapes or multiple escapes are used) ;; is implementation-dependent. The examples here show two of the ;; many valid ways in which escaping might appear. (test-print-case) ;Implementation A |> THIS-AND-THAT |And-something-elSE| |> this-and-that a\n\d-\s\o\m\e\t\h\i\n\g-\e\lse |> This-And-That A\n\d-\s\o\m\e\t\h\i\n\g-\e\lse => NIL (test-print-case) ;Implementation B |> THIS-AND-THAT |And-something-elSE| |> this-and-that a|nd-something-el|se |> This-And-That A|nd-something-el|se => NIL See Also:: .......... *note write:: Notes:: ....... read normally converts lowercase characters appearing in symbols to corresponding uppercase characters, so that internally print names normally contain only uppercase characters. If *print-escape* is true, lowercase characters in the name of a symbol are always printed in lowercase, and are preceded by a single escape character or enclosed by multiple escape characters; uppercase characters in the name of a symbol are printed in upper case, in lower case, or in mixed case so as to capitalize words, according to the value of *print-case*. The convention for what constitutes a "word" is the same as for string-capitalize.  File: gcl.info, Node: *print-circle*, Next: *print-escape*, Prev: *print-case*, Up: Printer Dictionary 22.4.19 *print-circle* [Variable] --------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... false. Description:: ............. Controls the attempt to detect circularity and sharing in an object being printed. If false, the printing process merely proceeds by recursive descent without attempting to detect circularity and sharing. If true, the printer will endeavor to detect cycles and sharing in the structure to be printed, and to use #n= and #n# syntax to indicate the circularities or shared components. If true, a user-defined print-object method can print objects to the supplied stream using write, prin1, princ, or format and expect circularities and sharing to be detected and printed using the #n# syntax. If a user-defined print-object method prints to a stream other than the one that was supplied, then circularity detection starts over for that stream. Note that implementations should not use #n# notation when the Lisp reader would automatically assure sharing without it (e.g., as happens with interned symbols). Examples:: .......... (let ((a (list 1 2 3))) (setf (cdddr a) a) (let ((*print-circle* t)) (write a) :done)) |> #1=(1 2 3 . #1#) => :DONE See Also:: .......... *note write:: Notes:: ....... An attempt to print a circular structure with *print-circle* set to nil may lead to looping behavior and failure to terminate.  File: gcl.info, Node: *print-escape*, Next: *print-gensym*, Prev: *print-circle*, Up: Printer Dictionary 22.4.20 *print-escape* [Variable] --------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... true. Description:: ............. If false, escape characters and package prefixes are not output when an expression is printed. If true, an attempt is made to print an expression in such a way that it can be read again to produce an equal expression. (This is only a guideline; not a requirement. See *print-readably*.) For more specific details of how the value of *print-escape* affects the printing of certain types, see *note Default Print-Object Methods::. Examples:: .......... (let ((*print-escape* t)) (write #\a)) |> #\a => #\a (let ((*print-escape* nil)) (write #\a)) |> a => #\a Affected By:: ............. princ, prin1, format See Also:: .......... *note write:: , *note readtable-case:: Notes:: ....... princ effectively binds *print-escape* to false. prin1 effectively binds *print-escape* to true.  File: gcl.info, Node: *print-gensym*, Next: *print-level*, Prev: *print-escape*, Up: Printer Dictionary 22.4.21 *print-gensym* [Variable] --------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... true. Description:: ............. Controls whether the prefix "#:" is printed before apparently uninterned symbols. The prefix is printed before such symbols if and only if the value of *print-gensym* is true. Examples:: .......... (let ((*print-gensym* nil)) (print (gensym))) |> G6040 => #:G6040 See Also:: .......... *note write:: , *print-escape*  File: gcl.info, Node: *print-level*, Next: *print-lines*, Prev: *print-gensym*, Up: Printer Dictionary 22.4.22 *print-level*, *print-length* [Variable] ------------------------------------------------ Value Type:: ............ a non-negative integer, or nil. Initial Value:: ............... nil. Description:: ............. *print-level* controls how many levels deep a nested object will print. If it is false, then no control is exercised. Otherwise, it is an integer indicating the maximum level to be printed. An object to be printed is at level 0; its components (as of a list or vector) are at level 1; and so on. If an object to be recursively printed has components and is at a level equal to or greater than the value of *print-level*, then the object is printed as "#". *print-length* controls how many elements at a given level are printed. If it is false, there is no limit to the number of components printed. Otherwise, it is an integer indicating the maximum number of elements of an object to be printed. If exceeded, the printer will print "..." in place of the other elements. In the case of a dotted list, if the list contains exactly as many elements as the value of *print-length*, the terminating atom is printed rather than printing "..." *print-level* and *print-length* affect the printing of an any object printed with a list-like syntax. They do not affect the printing of symbols, strings, and bit vectors. Examples:: .......... (setq a '(1 (2 (3 (4 (5 (6))))))) => (1 (2 (3 (4 (5 (6)))))) (dotimes (i 8) (let ((*print-level* i)) (format t "~&~D -- ~S~ |> 0 -- # |> 1 -- (1 #) |> 2 -- (1 (2 #)) |> 3 -- (1 (2 (3 #))) |> 4 -- (1 (2 (3 (4 #)))) |> 5 -- (1 (2 (3 (4 (5 #))))) |> 6 -- (1 (2 (3 (4 (5 (6)))))) |> 7 -- (1 (2 (3 (4 (5 (6)))))) => NIL (setq a '(1 2 3 4 5 6)) => (1 2 3 4 5 6) (dotimes (i 7) (let ((*print-length* i)) (format t "~&~D -- ~S~ |> 0 -- (...) |> 1 -- (1 ...) |> 2 -- (1 2 ...) |> 3 -- (1 2 3 ...) |> 4 -- (1 2 3 4 ...) |> 5 -- (1 2 3 4 5 6) |> 6 -- (1 2 3 4 5 6) => NIL (dolist (level-length '((0 1) (1 1) (1 2) (1 3) (1 4) (2 1) (2 2) (2 3) (3 2) (3 3) (3 4))) (let ((*print-level* (first level-length)) (*print-length* (second level-length))) (format t "~&~D ~D -- ~S~ *print-level* *print-length* '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz")))))) |> 0 1 -- # |> 1 1 -- (IF ...) |> 1 2 -- (IF # ...) |> 1 3 -- (IF # # ...) |> 1 4 -- (IF # # #) |> 2 1 -- (IF ...) |> 2 2 -- (IF (MEMBER X ...) ...) |> 2 3 -- (IF (MEMBER X Y) (+ # 3) ...) |> 3 2 -- (IF (MEMBER X ...) ...) |> 3 3 -- (IF (MEMBER X Y) (+ (CAR X) 3) ...) |> 3 4 -- (IF (MEMBER X Y) (+ (CAR X) 3) '(FOO . #(A B C D ...))) => NIL See Also:: .......... *note write::  File: gcl.info, Node: *print-lines*, Next: *print-miser-width*, Prev: *print-level*, Up: Printer Dictionary 22.4.23 *print-lines* [Variable] -------------------------------- Value Type:: ............ a non-negative integer, or nil. Initial Value:: ............... nil. Description:: ............. When the value of *print-lines* is other than nil, it is a limit on the number of output lines produced when something is pretty printed. If an attempt is made to go beyond that many lines, ".." is printed at the end of the last line followed by all of the suffixes (closing delimiters) that are pending to be printed. Examples:: .......... (let ((*print-right-margin* 25) (*print-lines* 3)) (pprint '(progn (setq a 1 b 2 c 3 d 4)))) |> (PROGN (SETQ A 1 |> B 2 |> C 3 ..)) => Notes:: ....... The ".." notation is intentionally different than the "..." notation used for level abbreviation, so that the two different situations can be visually distinguished. This notation is used to increase the likelihood that the Lisp reader will signal an error if an attempt is later made to read the abbreviated output. Note however that if the truncation occurs in a string, as in "This string has been trunc..", the problem situation cannot be detected later and no such error will be signaled.  File: gcl.info, Node: *print-miser-width*, Next: *print-pprint-dispatch*, Prev: *print-lines*, Up: Printer Dictionary 22.4.24 *print-miser-width* [Variable] -------------------------------------- Value Type:: ............ a non-negative integer, or nil. Initial Value:: ............... implementation-dependent Description:: ............. If it is not nil, the pretty printer switches to a compact style of output (called miser style) whenever the width available for printing a substructure is less than or equal to this many ems.  File: gcl.info, Node: *print-pprint-dispatch*, Next: *print-pretty*, Prev: *print-miser-width*, Up: Printer Dictionary 22.4.25 *print-pprint-dispatch* [Variable] ------------------------------------------ Value Type:: ............ a pprint dispatch table. Initial Value:: ............... implementation-dependent, but the initial entries all use a special class of priorities that have the property that they are less than every priority that can be specified using set-pprint-dispatch, so that the initial contents of any entry can be overridden. Description:: ............. The pprint dispatch table which currently controls the pretty printer. See Also:: .......... *print-pretty*, *note Pretty Print Dispatch Tables:: Notes:: ....... The intent is that the initial value of this variable should cause 'traditional' pretty printing of code. In general, however, you can put a value in *print-pprint-dispatch* that makes pretty-printed output look exactly like non-pretty-printed output. Setting *print-pretty* to true just causes the functions contained in the current pprint dispatch table to have priority over normal print-object methods; it has no magic way of enforcing that those functions actually produce pretty output. For details, see *note Pretty Print Dispatch Tables::.  File: gcl.info, Node: *print-pretty*, Next: *print-readably*, Prev: *print-pprint-dispatch*, Up: Printer Dictionary 22.4.26 *print-pretty* [Variable] --------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... implementation-dependent. Description:: ............. Controls whether the Lisp printer calls the pretty printer. If it is false, the pretty printer is not used and a minimum of whitespace_1 is output when printing an expression. If it is true, the pretty printer is used, and the Lisp printer will endeavor to insert extra whitespace_1 where appropriate to make expressions more readable. *print-pretty* has an effect even when the value of *print-escape* is false. Examples:: .......... (setq *print-pretty* 'nil) => NIL (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil) |> (LET ((A 1) (B 2) (C 3)) (+ A B C)) => NIL (let ((*print-pretty* t)) (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil)) |> (LET ((A 1) |> (B 2) |> (C 3)) |> (+ A B C)) => NIL ;; Note that the first two expressions printed by this next form ;; differ from the second two only in whether escape characters are printed. ;; In all four cases, extra whitespace is inserted by the pretty printer. (flet ((test (x) (let ((*print-pretty* t)) (print x) (format t "~ (terpri) (princ x) (princ " ") (format t "~ (test '#'(lambda () (list "a" #'c #'d)))) |> #'(LAMBDA () |> (LIST "a" #'C #'D)) |> #'(LAMBDA () |> (LIST "a" #'C #'D)) |> #'(LAMBDA () |> (LIST a b 'C #'D)) |> #'(LAMBDA () |> (LIST a b 'C #'D)) => NIL See Also:: .......... *note write::  File: gcl.info, Node: *print-readably*, Next: *print-right-margin*, Prev: *print-pretty*, Up: Printer Dictionary 22.4.27 *print-readably* [Variable] ----------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... false. Description:: ............. If *print-readably* is true, some special rules for printing objects go into effect. Specifically, printing any object O_1 produces a printed representation that, when seen by the Lisp reader while the standard readtable is in effect, will produce an object O_2 that is similar to O_1. The printed representation produced might or might not be the same as the printed representation produced when *print-readably* is false. If printing an object readably is not possible, an error of type print-not-readable is signaled rather than using a syntax (e.g., the "#<" syntax) that would not be readable by the same implementation. If the value of some other printer control variable is such that these requirements would be violated, the value of that other variable is ignored. Specifically, if *print-readably* is true, printing proceeds as if *print-escape*, *print-array*, and *print-gensym* were also true, and as if *print-length*, *print-level*, and *print-lines* were false. If *print-readably* is false, the normal rules for printing and the normal interpretations of other printer control variables are in effect. Individual methods for print-object, including user-defined methods, are responsible for implementing these requirements. If *read-eval* is false and *print-readably* is true, any such method that would output a reference to the "#." reader macro will either output something else or will signal an error (as described above). Examples:: .......... (let ((x (list "a" '\a (gensym) '((a (b (c))) d e f g))) (*print-escape* nil) (*print-gensym* nil) (*print-level* 3) (*print-length* 3)) (write x) (let ((*print-readably* t)) (terpri) (write x) :done)) |> (a a G4581 ((A #) D E ...)) |> ("a" |a| #:G4581 ((A (B (C))) D E F G)) => :DONE ;; This is setup code is shared between the examples ;; of three hypothetical implementations which follow. (setq table (make-hash-table)) => # (setf (gethash table 1) 'one) => ONE (setf (gethash table 2) 'two) => TWO ;; Implementation A (let ((*print-readably* t)) (print table)) Error: Can't print # readably. ;; Implementation B ;; No standardized #S notation for hash tables is defined, ;; but there might be an implementation-defined notation. (let ((*print-readably* t)) (print table)) |> #S(HASH-TABLE :TEST EQL :SIZE 120 :CONTENTS (1 ONE 2 TWO)) => # ;; Implementation C ;; Note that #. notation can only be used if *READ-EVAL* is true. ;; If *READ-EVAL* were false, this same implementation might have to ;; signal an error unless it had yet another printing strategy to fall ;; back on. (let ((*print-readably* t)) (print table)) |> #.(LET ((HASH-TABLE (MAKE-HASH-TABLE))) |> (SETF (GETHASH 1 HASH-TABLE) ONE) |> (SETF (GETHASH 2 HASH-TABLE) TWO) |> HASH-TABLE) => # See Also:: .......... *note write:: , *note print-unreadable-object:: Notes:: ....... The rules for "similarity" imply that #A or #( syntax cannot be used for arrays of element type other than t. An implementation will have to use another syntax or signal an error of type print-not-readable.  File: gcl.info, Node: *print-right-margin*, Next: print-not-readable, Prev: *print-readably*, Up: Printer Dictionary 22.4.28 *print-right-margin* [Variable] --------------------------------------- Value Type:: ............ a non-negative integer, or nil. Initial Value:: ............... nil. Description:: ............. If it is non-nil, it specifies the right margin (as integer number of ems) to use when the pretty printer is making layout decisions. If it is nil, the right margin is taken to be the maximum line length such that output can be displayed without wraparound or truncation. If this cannot be determined, an implementation-dependent value is used. Notes:: ....... This measure is in units of ems in order to be compatible with implementation-defined variable-width fonts while still not requiring the language to provide support for fonts.  File: gcl.info, Node: print-not-readable, Next: print-not-readable-object, Prev: *print-right-margin*, Up: Printer Dictionary 22.4.29 print-not-readable [Condition Type] ------------------------------------------- Class Precedence List:: ....................... print-not-readable, error, serious-condition, condition, t Description:: ............. The type print-not-readable consists of error conditions that occur during output while *print-readably* is true, as a result of attempting to write a printed representation with the Lisp printer that would not be correctly read back with the Lisp reader. The object which could not be printed is initialized by the :object initialization argument to make-condition, and is accessed by the function print-not-readable-object. See Also:: .......... *note print-not-readable-object::  File: gcl.info, Node: print-not-readable-object, Next: format, Prev: print-not-readable, Up: Printer Dictionary 22.4.30 print-not-readable-object [Function] -------------------------------------------- 'print-not-readable-object' condition => object Arguments and Values:: ...................... condition--a condition of type print-not-readable. object--an object. Description:: ............. Returns the object that could not be printed readably in the situation represented by condition. See Also:: .......... print-not-readable, *note Conditions::  File: gcl.info, Node: format, Prev: print-not-readable-object, Up: Printer Dictionary 22.4.31 format [Function] ------------------------- 'format' destination control-string &rest args => result Arguments and Values:: ...................... destination--nil, t, a stream, or a string with a fill pointer. control-string--a format control. args--format arguments for control-string. result--if destination is non-nil, then nil; otherwise, a string. Description:: ............. format produces formatted output by outputting the characters of control-string and observing that a tilde introduces a directive. The character after the tilde, possibly preceded by prefix parameters and modifiers, specifies what kind of formatting is desired. Most directives use one or more elements of args to create their output. If destination is a string, a stream, or t, then the result is nil. Otherwise, the result is a string containing the 'output.' format is useful for producing nicely formatted text, producing good-looking messages, and so on. format can generate and return a string or output to destination. For details on how the control-string is interpreted, see *note Formatted Output::. Affected By:: ............. *standard-output*, *print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*. Exceptional Situations:: ........................ If destination is a string with a fill pointer, the consequences are undefined if destructive modifications are performed directly on the string during the dynamic extent of the call. See Also:: .......... *note write:: , *note Documentation of Implementation-Defined Scripts::  File: gcl.info, Node: Reader, Next: System Construction, Prev: Printer, Up: Top 23 Reader ********* * Menu: * Reader Concepts:: * Reader Dictionary::  File: gcl.info, Node: Reader Concepts, Next: Reader Dictionary, Prev: Reader, Up: Reader 23.1 Reader Concepts ==================== * Menu: * Dynamic Control of the Lisp Reader:: * Effect of Readtable Case on the Lisp Reader:: * Argument Conventions of Some Reader Functions::  File: gcl.info, Node: Dynamic Control of the Lisp Reader, Next: Effect of Readtable Case on the Lisp Reader, Prev: Reader Concepts, Up: Reader Concepts 23.1.1 Dynamic Control of the Lisp Reader ----------------------------------------- Various aspects of the Lisp reader can be controlled dynamically. See *note Readtables:: and *note Variables that affect the Lisp Reader::.  File: gcl.info, Node: Effect of Readtable Case on the Lisp Reader, Next: Argument Conventions of Some Reader Functions, Prev: Dynamic Control of the Lisp Reader, Up: Reader Concepts 23.1.2 Effect of Readtable Case on the Lisp Reader -------------------------------------------------- The readtable case of the current readtable affects the Lisp reader in the following ways: :upcase When the readtable case is :upcase, unescaped constituent characters are converted to uppercase, as specified in *note Reader Algorithm::. :downcase When the readtable case is :downcase, unescaped constituent characters are converted to lowercase. :preserve When the readtable case is :preserve, the case of all characters remains unchanged. :invert When the readtable case is :invert, then if all of the unescaped letters in the extended token are of the same case, those (unescaped) letters are converted to the opposite case. * Menu: * Examples of Effect of Readtable Case on the Lisp Reader::  File: gcl.info, Node: Examples of Effect of Readtable Case on the Lisp Reader, Prev: Effect of Readtable Case on the Lisp Reader, Up: Effect of Readtable Case on the Lisp Reader 23.1.2.1 Examples of Effect of Readtable Case on the Lisp Reader ................................................................ (defun test-readtable-case-reading () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE Input Symbol-name~ ~ ~ (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (input '("ZEBRA" "Zebra" "zebra")) (format t "~&:~A~16T~A~24T~A" (string-upcase readtable-case) input (symbol-name (read-from-string input))))))) The output from (test-readtable-case-reading) should be as follows: READTABLE-CASE Input Symbol-name ------------------------------------- :UPCASE ZEBRA ZEBRA :UPCASE Zebra ZEBRA :UPCASE zebra ZEBRA :DOWNCASE ZEBRA zebra :DOWNCASE Zebra zebra :DOWNCASE zebra zebra :PRESERVE ZEBRA ZEBRA :PRESERVE Zebra Zebra :PRESERVE zebra zebra :INVERT ZEBRA zebra :INVERT Zebra Zebra :INVERT zebra ZEBRA  File: gcl.info, Node: Argument Conventions of Some Reader Functions, Prev: Effect of Readtable Case on the Lisp Reader, Up: Reader Concepts 23.1.3 Argument Conventions of Some Reader Functions ---------------------------------------------------- * Menu: * The EOF-ERROR-P argument:: * The RECURSIVE-P argument::  File: gcl.info, Node: The EOF-ERROR-P argument, Next: The RECURSIVE-P argument, Prev: Argument Conventions of Some Reader Functions, Up: Argument Conventions of Some Reader Functions 23.1.3.1 The EOF-ERROR-P argument ................................. Eof-error-p in input function calls controls what happens if input is from a file (or any other input source that has a definite end) and the end of the file is reached. If eof-error-p is true (the default), an error of type end-of-file is signaled at end of file. If it is false, then no error is signaled, and instead the function returns eof-value. Functions such as read that read the representation of an object rather than a single character always signals an error, regardless of eof-error-p, if the file ends in the middle of an object representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, read signals an error. If a file ends in a symbol or a number immediately followed by end-of-file, read reads the symbol or number successfully and when called again will act according to eof-error-p. Similarly, the function read-line successfully reads the last line of a file even if that line is terminated by end-of-file rather than the newline character. Ignorable text, such as lines containing only whitespace_2 or comments, are not considered to begin an object; if read begins to read an expression but sees only such ignorable text, it does not consider the file to end in the middle of an object. Thus an eof-error-p argument controls what happens when the file ends between objects.  File: gcl.info, Node: The RECURSIVE-P argument, Prev: The EOF-ERROR-P argument, Up: Argument Conventions of Some Reader Functions 23.1.3.2 The RECURSIVE-P argument ................................. If recursive-p is supplied and not nil, it specifies that this function call is not an outermost call to read but an embedded call, typically from a reader macro function. It is important to distinguish such recursive calls for three reasons. 1. An outermost call establishes the context within which the #n= and #n# syntax is scoped. Consider, for example, the expression (cons '#3=(p q r) '(x y . #3#)) If the single-quote reader macro were defined in this way: (set-macro-character #\' ;incorrect #'(lambda (stream char) (declare (ignore char)) (list 'quote (read stream)))) then each call to the single-quote reader macro function would establish independent contexts for the scope of read information, including the scope of identifications between markers like "#3=" and "#3#". However, for this expression, the scope was clearly intended to be determined by the outer set of parentheses, so such a definition would be incorrect. The correct way to define the single-quote reader macro uses recursive-p: (set-macro-character #\' ;correct #'(lambda (stream char) (declare (ignore char)) (list 'quote (read stream t nil t)))) 2. A recursive call does not alter whether the reading process is to preserve whitespace_2 or not (as determined by whether the outermost call was to read or read-preserving-whitespace). Suppose again that single-quote were to be defined as shown above in the incorrect definition. Then a call to read-preserving-whitespace that read the expression 'foo would fail to preserve the space character following the symbol foo because the single-quote reader macro function calls read, not read-preserving-whitespace, to read the following expression (in this case foo). The correct definition, which passes the value true for recursive-p to read, allows the outermost call to determine whether whitespace_2 is preserved. 3. When end-of-file is encountered and the eof-error-p argument is not nil, the kind of error that is signaled may depend on the value of recursive-p. If recursive-p is true, then the end-of-file is deemed to have occurred within the middle of a printed representation; if recursive-p is false, then the end-of-file may be deemed to have occurred between objects rather than within the middle of one.  File: gcl.info, Node: Reader Dictionary, Prev: Reader Concepts, Up: Reader 23.2 Reader Dictionary ====================== * Menu: * readtable:: * copy-readtable:: * make-dispatch-macro-character:: * read:: * read-delimited-list:: * read-from-string:: * readtable-case:: * readtablep:: * set-dispatch-macro-character:: * set-macro-character:: * set-syntax-from-char:: * with-standard-io-syntax:: * *read-base*:: * *read-default-float-format*:: * *read-eval*:: * *read-suppress*:: * *readtable*:: * reader-error::  File: gcl.info, Node: readtable, Next: copy-readtable, Prev: Reader Dictionary, Up: Reader Dictionary 23.2.1 readtable [System Class] ------------------------------- Class Precedence List:: ....................... readtable, t Description:: ............. A readtable maps characters into syntax types for the Lisp reader; see *note Syntax::. A readtable also contains associations between macro characters and their reader macro functions, and records information about the case conversion rules to be used by the Lisp reader when parsing symbols. Each simple character must be representable in the readtable. It is implementation-defined whether non-simple characters can have syntax descriptions in the readtable. See Also:: .......... *note Readtables::, *note Printing Other Objects::  File: gcl.info, Node: copy-readtable, Next: make-dispatch-macro-character, Prev: readtable, Up: Reader Dictionary 23.2.2 copy-readtable [Function] -------------------------------- 'copy-readtable' &optional from-readtable to-readtable => readtable Arguments and Values:: ...................... from-readtable--a readtable designator. The default is the current readtable. to-readtable--a readtable or nil. The default is nil. readtable--the to-readtable if it is non-nil, or else a fresh readtable. Description:: ............. copy-readtable copies from-readtable. If to-readtable is nil, a new readtable is created and returned. Otherwise the readtable specified by to-readtable is modified and returned. copy-readtable copies the setting of readtable-case. Examples:: .......... (setq zvar 123) => 123 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) => T zvar => 123 (copy-readtable table2 *readtable*) => # zvar => VAR (setq *readtable* (copy-readtable)) => # zvar => VAR (setq *readtable* (copy-readtable nil)) => # zvar => 123 See Also:: .......... readtable, *note readtable:: Notes:: ....... (setq *readtable* (copy-readtable nil)) restores the input syntax to standard Common Lisp syntax, even if the initial readtable has been clobbered (assuming it is not so badly clobbered that you cannot type in the above expression). On the other hand, (setq *readtable* (copy-readtable)) replaces the current readtable with a copy of itself. This is useful if you want to save a copy of a readtable for later use, protected from alteration in the meantime. It is also useful if you want to locally bind the readtable to a copy of itself, as in: (let ((*readtable* (copy-readtable))) ...)  File: gcl.info, Node: make-dispatch-macro-character, Next: read, Prev: copy-readtable, Up: Reader Dictionary 23.2.3 make-dispatch-macro-character [Function] ----------------------------------------------- 'make-dispatch-macro-character' char &optional non-terminating-p readtable => t Arguments and Values:: ...................... char--a character. non-terminating-p--a generalized boolean. The default is false. readtable--a readtable. The default is the current readtable. Description:: ............. make-dispatch-macro-character makes char be a dispatching macro character in readtable. Initially, every character in the dispatch table associated with the char has an associated function that signals an error of type reader-error. If non-terminating-p is true, the dispatching macro character is made a non-terminating macro character; if non-terminating-p is false, the dispatching macro character is made a terminating macro character. Examples:: .......... (get-macro-character #\{) => NIL, false (make-dispatch-macro-character #\{) => T (not (get-macro-character #\{)) => false The readtable is altered. See Also:: .......... *note readtable:: , *note set-dispatch-macro-character::  File: gcl.info, Node: read, Next: read-delimited-list, Prev: make-dispatch-macro-character, Up: Reader Dictionary 23.2.4 read, read-preserving-whitespace [Function] -------------------------------------------------- 'read' &optional input-stream eof-error-p eof-value recursive-p => object 'read-preserving-whitespace' &optional input-stream eof-error-p eof-value recursive-p => object Arguments and Values:: ...................... input-stream--an input stream designator. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. recursive-p--a generalized boolean. The default is false. object--an object (parsed by the Lisp reader) or the eof-value. Description:: ............. read parses the printed representation of an object from input-stream and builds such an object. read-preserving-whitespace is like read but preserves any whitespace_2 character that delimits the printed representation of the object. read-preserving-whitespace is exactly like read when the recursive-p argument to read-preserving-whitespace is true. When *read-suppress* is false, read throws away the delimiting character required by certain printed representations if it is a whitespace_2 character; but read preserves the character (using unread-char) if it is syntactically meaningful, because it could be the start of the next expression. If a file ends in a symbol or a number immediately followed by an end of file_1, read reads the symbol or number successfully; when called again, it sees the end of file_1 and only then acts according to eof-error-p. If a file contains ignorable text at the end, such as blank lines and comments, read does not consider it to end in the middle of an object. If recursive-p is true, the call to read is expected to be made from within some function that itself has been called from read or from a similar input function, rather than from the top level. Both functions return the object read from input-stream. Eof-value is returned if eof-error-p is false and end of file is reached before the beginning of an object. Examples:: .......... (read) |> |>>'a<<| => (QUOTE A) (with-input-from-string (is " ") (read is nil 'the-end)) => THE-END (defun skip-then-read-char (s c n) (if (char= c #\{) (read s t nil t) (read-preserving-whitespace s)) (read-char-no-hang s)) => SKIP-THEN-READ-CHAR (let ((*readtable* (copy-readtable nil))) (set-dispatch-macro-character #\# #\{ #'skip-then-read-char) (set-dispatch-macro-character #\# #\} #'skip-then-read-char) (with-input-from-string (is "#{123 x #}123 y") (format t "~S ~S" (read is) (read is)))) => #\x, #\Space, NIL As an example, consider this reader macro definition: (defun slash-reader (stream char) (declare (ignore char)) `(path . ,(loop for dir = (read-preserving-whitespace stream t nil t) then (progn (read-char stream t nil t) (read-preserving-whitespace stream t nil t)) collect dir while (eql (peek-char nil stream nil nil t) #\/)))) (set-macro-character #\/ #'slash-reader) Consider now calling read on this expression: (zyedh /usr/games/zork /usr/games/boggle) The / macro reads objects separated by more / characters; thus /usr/games/zork is intended to read as (path usr games zork). The entire example expression should therefore be read as (zyedh (path usr games zork) (path usr games boggle)) However, if read had been used instead of read-preserving-whitespace, then after the reading of the symbol zork, the following space would be discarded; the next call to peek-char would see the following /, and the loop would continue, producing this interpretation: (zyedh (path usr games zork usr games boggle)) There are times when whitespace_2 should be discarded. If a command interpreter takes single-character commands, but occasionally reads an object then if the whitespace_2 after a symbol is not discarded it might be interpreted as a command some time later after the symbol had been read. Affected By:: ............. *standard-input*, *terminal-io*, *readtable*, *read-default-float-format*, *read-base*, *read-suppress*, *package*, *read-eval*. Exceptional Situations:: ........................ read signals an error of type end-of-file, regardless of eof-error-p, if the file ends in the middle of an object representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, read signals an error. This is detected when read or read-preserving-whitespace is called with recursive-p and eof-error-p non-nil, and end-of-file is reached before the beginning of an object. If eof-error-p is true, an error of type end-of-file is signaled at the end of file. See Also:: .......... *note peek-char:: , *note read-char:: , *note unread-char:: , *note read-from-string:: , *note read-delimited-list:: , *note parse-integer:: , *note Syntax::, *note Reader Concepts::  File: gcl.info, Node: read-delimited-list, Next: read-from-string, Prev: read, Up: Reader Dictionary 23.2.5 read-delimited-list [Function] ------------------------------------- 'read-delimited-list' char &optional input-stream recursive-p => list Arguments and Values:: ...................... char--a character. input-stream--an input stream designator. The default is standard input. recursive-p--a generalized boolean. The default is false. list--a list of the objects read. Description:: ............. read-delimited-list reads objects from input-stream until the next character after an object's representation (ignoring whitespace_2 characters and comments) is char. read-delimited-list looks ahead at each step for the next non-whitespace_2 character and peeks at it as if with peek-char. If it is char, then the character is consumed and the list of objects is returned. If it is a constituent or escape character, then read is used to read an object, which is added to the end of the list. If it is a macro character, its reader macro function is called; if the function returns a value, that value is added to the list. The peek-ahead process is then repeated. If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function. It is an error to reach end-of-file during the operation of read-delimited-list. The consequences are undefined if char has a syntax type of whitespace_2 in the current readtable. Examples:: .......... (read-delimited-list #\]) 1 2 3 4 5 6 ] => (1 2 3 4 5 6) Suppose you wanted #{a b c ... z} to read as a list of all pairs of the elements a, b, c, ..., z, for example. #{p q z a} reads as ((p q) (p z) (p a) (q z) (q a) (z a)) This can be done by specifying a macro-character definition for #{ that does two things: reads in all the items up to the }, and constructs the pairs. read-delimited-list performs the first task. (defun |#{-reader| (stream char arg) (declare (ignore char arg)) (mapcon #'(lambda (x) (mapcar #'(lambda (y) (list (car x) y)) (cdr x))) (read-delimited-list #\} stream t))) => |#{-reader| (set-dispatch-macro-character #\# #\{ #'|#{-reader|) => T (set-macro-character #\} (get-macro-character #\) nil)) Note that true is supplied for the recursive-p argument. It is necessary here to give a definition to the character } as well to prevent it from being a constituent. If the line (set-macro-character #\} (get-macro-character #\) nil)) shown above were not included, then the } in #{ p q z a} would be considered a constituent character, part of the symbol named a}. This could be corrected by putting a space before the }, but it is better to call set-macro-character. Giving } the same definition as the standard definition of the character ) has the twin benefit of making it terminate tokens for use with read-delimited-list and also making it invalid for use in any other context. Attempting to read a stray } will signal an error. Affected By:: ............. *standard-input*, *readtable*, *terminal-io*. See Also:: .......... *note read:: , *note peek-char:: , *note read-char:: , *note unread-char:: . Notes:: ....... read-delimited-list is intended for use in implementing reader macros. Usually it is desirable for char to be a terminating macro character so that it can be used to delimit tokens; however, read-delimited-list makes no attempt to alter the syntax specified for char by the current readtable. The caller must make any necessary changes to the readtable syntax explicitly.  File: gcl.info, Node: read-from-string, Next: readtable-case, Prev: read-delimited-list, Up: Reader Dictionary 23.2.6 read-from-string [Function] ---------------------------------- 'read-from-string' string &optional eof-error-p eof-value &key start end preserve-whitespace => object, position Arguments and Values:: ...................... string--a string. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. preserve-whitespace--a generalized boolean. The default is false. object--an object (parsed by the Lisp reader) or the eof-value. position--an integer greater than or equal to zero, and less than or equal to one more than the length of the string. Description:: ............. Parses the printed representation of an object from the subsequence of string bounded by start and end, as if read had been called on an input stream containing those same characters. If preserve-whitespace is true, the operation will preserve whitespace_2 as read-preserving-whitespace would do. If an object is successfully parsed, the primary value, object, is the object that was parsed. If eof-error-p is false and if the end of the substring is reached, eof-value is returned. The secondary value, position, is the index of the first character in the bounded string that was not read. The position may depend upon the value of preserve-whitespace. If the entire string was read, the position returned is either the length of the string or one greater than the length of the string. Examples:: .......... (read-from-string " 1 3 5" t nil :start 2) => 3, 5 (read-from-string "(a b c)") => (A B C), 7 Exceptional Situations:: ........................ If the end of the supplied substring occurs before an object can be read, an error is signaled if eof-error-p is true. An error is signaled if the end of the substring occurs in the middle of an incomplete object. See Also:: .......... *note read:: , read-preserving-whitespace Notes:: ....... The reason that position is allowed to be beyond the length of the string is to permit (but not require) the implementation to work by simulating the effect of a trailing delimiter at the end of the bounded string. When preserve-whitespace is true, the position might count the simulated delimiter.  File: gcl.info, Node: readtable-case, Next: readtablep, Prev: read-from-string, Up: Reader Dictionary 23.2.7 readtable-case [Accessor] -------------------------------- 'readtable-case' readtable => mode (setf (' readtable-case' readtable) mode) Arguments and Values:: ...................... readtable--a readtable. mode--a case sensitivity mode. Description:: ............. Accesses the readtable case of readtable, which affects the way in which the Lisp Reader reads symbols and the way in which the Lisp Printer writes symbols. Examples:: .......... See *note Examples of Effect of Readtable Case on the Lisp Reader:: and *note Examples of Effect of Readtable Case on the Lisp Printer::. Exceptional Situations:: ........................ Should signal an error of type type-error if readtable is not a readtable. Should signal an error of type type-error if mode is not a case sensitivity mode. See Also:: .......... *note readtable:: , *print-escape*, *note Reader Algorithm::, *note Effect of Readtable Case on the Lisp Reader::, *note Effect of Readtable Case on the Lisp Printer:: Notes:: ....... copy-readtable copies the readtable case of the readtable.  File: gcl.info, Node: readtablep, Next: set-dispatch-macro-character, Prev: readtable-case, Up: Reader Dictionary 23.2.8 readtablep [Function] ---------------------------- 'readtablep' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type readtable; otherwise, returns false. Examples:: .......... (readtablep *readtable*) => true (readtablep (copy-readtable)) => true (readtablep '*readtable*) => false Notes:: ....... (readtablep object) == (typep object 'readtable)  File: gcl.info, Node: set-dispatch-macro-character, Next: set-macro-character, Prev: readtablep, Up: Reader Dictionary 23.2.9 set-dispatch-macro-character, get-dispatch-macro-character ----------------------------------------------------------------- [Function] 'get-dispatch-macro-character' disp-char sub-char &optional readtable => function 'set-dispatch-macro-character' disp-char sub-char new-function &optional readtable => t Arguments and Values:: ...................... disp-char--a character. sub-char--a character. readtable--a readtable designator. The default is the current readtable. function--a function designator or nil. new-function--a function designator. Description:: ............. set-dispatch-macro-character causes new-function to be called when disp-char followed by sub-char is read. If sub-char is a lowercase letter, it is converted to its uppercase equivalent. It is an error if sub-char is one of the ten decimal digits. set-dispatch-macro-character installs a new-function to be called when a particular dispatching macro character pair is read. New-function is installed as the dispatch function to be called when readtable is in use and when disp-char is followed by sub-char. For more information about how the new-function is invoked, see *note Macro Characters::. get-dispatch-macro-character retrieves the dispatch function associated with disp-char and sub-char in readtable. get-dispatch-macro-character returns the macro-character function for sub-char under disp-char, or nil if there is no function associated with sub-char. If sub-char is a decimal digit, get-dispatch-macro-character returns nil. Examples:: .......... (get-dispatch-macro-character #\# #\{) => NIL (set-dispatch-macro-character #\# #\{ ;dispatch on #{ #'(lambda(s c n) (let ((list (read s nil (values) t))) ;list is object after #n{ (when (consp list) ;return nth element of list (unless (and n (< 0 n (length list))) (setq n 0)) (setq list (nth n list))) list))) => T #{(1 2 3 4) => 1 #3{(0 1 2 3) => 3 #{123 => 123 If it is desired that #$foo : as if it were (dollars foo). (defun |#$-reader| (stream subchar arg) (declare (ignore subchar arg)) (list 'dollars (read stream t nil t))) => |#$-reader| (set-dispatch-macro-character #\# #\$ #'|#$-reader|) => T See Also:: .......... *note Macro Characters:: Side Effects:: .............. The readtable is modified. Affected By:: ............. *readtable*. Exceptional Situations:: ........................ For either function, an error is signaled if disp-char is not a dispatching macro character in readtable. See Also:: .......... *note readtable:: Notes:: ....... It is necessary to use make-dispatch-macro-character to set up the dispatch character before specifying its sub-characters.  File: gcl.info, Node: set-macro-character, Next: set-syntax-from-char, Prev: set-dispatch-macro-character, Up: Reader Dictionary 23.2.10 set-macro-character, get-macro-character [Function] ----------------------------------------------------------- 'get-macro-character' char &optional readtable => function, non-terminating-p 'set-macro-character' char new-function &optional non-terminating-p readtable => t Arguments and Values:: ...................... char--a character. non-terminating-p--a generalized boolean. The default is false. readtable--a readtable designator. The default is the current readtable. function--nil, or a designator for a function of two arguments. new-function--a function designator. Description:: ............. get-macro-character returns as its primary value, function, the reader macro function associated with char in readtable (if any), or else nil if char is not a macro character in readtable. The secondary value, non-terminating-p, is true if char is a non-terminating macro character; otherwise, it is false. set-macro-character causes char to be a macro character associated with the reader macro function new-function (or the designator for new-function) in readtable. If non-terminating-p is true, char becomes a non-terminating macro character; otherwise it becomes a terminating macro character. Examples:: .......... (get-macro-character #\{) => NIL, false (not (get-macro-character #\;)) => false The following is a possible definition for the single-quote reader macro in standard syntax: (defun single-quote-reader (stream char) (declare (ignore char)) (list 'quote (read stream t nil t))) => SINGLE-QUOTE-READER (set-macro-character #\' #'single-quote-reader) => T Here single-quote-reader reads an object following the single-quote and returns a list of quote and that object. The char argument is ignored. The following is a possible definition for the semicolon reader macro in standard syntax: (defun semicolon-reader (stream char) (declare (ignore char)) ;; First swallow the rest of the current input line. ;; End-of-file is acceptable for terminating the comment. (do () ((char= (read-char stream nil #\Newline t) #\Newline))) ;; Return zero values. (values)) => SEMICOLON-READER (set-macro-character #\; #'semicolon-reader) => T Side Effects:: .............. The readtable is modified. See Also:: .......... *note readtable::  File: gcl.info, Node: set-syntax-from-char, Next: with-standard-io-syntax, Prev: set-macro-character, Up: Reader Dictionary 23.2.11 set-syntax-from-char [Function] --------------------------------------- 'set-syntax-from-char' to-char from-char &optional to-readtable from-readtable => t Arguments and Values:: ...................... to-char--a character. from-char--a character. to-readtable--a readtable. The default is the current readtable. from-readtable--a readtable designator. The default is the standard readtable. Description:: ............. set-syntax-from-char makes the syntax of to-char in to-readtable be the same as the syntax of from-char in from-readtable. set-syntax-from-char copies the syntax types of from-char. If from-char is a macro character, its reader macro function is copied also. If the character is a dispatching macro character, its entire dispatch table of reader macro functions is copied. The constituent traits of from-char are not copied. A macro definition from a character such as " can be copied to another character; the standard definition for " looks for another character that is the same as the character that invoked it. The definition of ( can not be meaningfully copied to {, on the other hand. The result is that lists are of the form {a b c), not {a b c}, because the definition always looks for a closing parenthesis, not a closing brace. Examples:: .......... (set-syntax-from-char #\7 #\;) => T 123579 => 1235 Side Effects:: .............. The to-readtable is modified. Affected By:: ............. The existing values in the from-readtable. See Also:: .......... *note set-macro-character:: , *note make-dispatch-macro-character:: , *note Character Syntax Types:: Notes:: ....... The constituent traits of a character are "hard wired" into the parser for extended tokens. For example, if the definition of S is copied to *, then * will become a constituent that is alphabetic_2 but that cannot be used as a short float exponent marker. For further information, see *note Constituent Traits::.  File: gcl.info, Node: with-standard-io-syntax, Next: *read-base*, Prev: set-syntax-from-char, Up: Reader Dictionary 23.2.12 with-standard-io-syntax [Macro] --------------------------------------- 'with-standard-io-syntax' {form}* => {result}* Arguments and Values:: ...................... forms--an implicit progn. results--the values returned by the forms. Description:: ............. Within the dynamic extent of the body of forms, all reader/printer control variables, including any implementation-defined ones not specified by this standard, are bound to values that produce standard read/print behavior. The values for the variables specified by this standard are listed in Figure 23-1. [Reviewer Note by Barrett: *print-pprint-dispatch* should probably be mentioned here, too.] Variable Value *package* The CL-USER package *print-array* t *print-base* 10 *print-case* :upcase *print-circle* nil *print-escape* t *print-gensym* t *print-length* nil *print-level* nil *print-lines* nil *print-miser-width* nil *print-pprint-dispatch* The standard pprint dispatch table *print-pretty* nil *print-radix* nil *print-readably* t *print-right-margin* nil *read-base* 10 *read-default-float-format* single-float *read-eval* t *read-suppress* nil *readtable* The standard readtable Figure 23-1: Values of standard control variables Examples:: .......... (with-open-file (file pathname :direction :output) (with-standard-io-syntax (print data file))) ;;; ... Later, in another Lisp: (with-open-file (file pathname :direction :input) (with-standard-io-syntax (setq data (read file))))  File: gcl.info, Node: *read-base*, Next: *read-default-float-format*, Prev: with-standard-io-syntax, Up: Reader Dictionary 23.2.13 *read-base* [Variable] ------------------------------ Value Type:: ............ a radix. Initial Value:: ............... 10. Description:: ............. Controls the interpretation of tokens by read as being integers or ratios. The value of *read-base*, called the current input base , is the radix in which integers and ratios are to be read by the Lisp reader. The parsing of other numeric types (e.g., floats) is not affected by this option. The effect of *read-base* on the reading of any particular rational number can be locally overridden by explicit use of the #O, #X, #B, or #nR syntax or by a trailing decimal point. Examples:: .......... (dotimes (i 6) (let ((*read-base* (+ 10. i))) (let ((object (read-from-string "(\\DAD DAD |BEE| BEE 123. 123)"))) (print (list *read-base* object))))) |> (10 (DAD DAD BEE BEE 123 123)) |> (11 (DAD DAD BEE BEE 123 146)) |> (12 (DAD DAD BEE BEE 123 171)) |> (13 (DAD DAD BEE BEE 123 198)) |> (14 (DAD 2701 BEE BEE 123 227)) |> (15 (DAD 3088 BEE 2699 123 258)) => NIL Notes:: ....... Altering the input radix can be useful when reading data files in special formats.  File: gcl.info, Node: *read-default-float-format*, Next: *read-eval*, Prev: *read-base*, Up: Reader Dictionary 23.2.14 *read-default-float-format* [Variable] ---------------------------------------------- Value Type:: ............ one of the atomic type specifiers short-float, single-float, double-float, or long-float, or else some other type specifier defined by the implementation to be acceptable. Initial Value:: ............... The symbol single-float. Description:: ............. Controls the floating-point format that is to be used when reading a floating-point number that has no exponent marker or that has e or E for an exponent marker. Other exponent markers explicitly prescribe the floating-point format to be used. The printer uses *read-default-float-format* to guide the choice of exponent markers when printing floating-point numbers. Examples:: .......... (let ((*read-default-float-format* 'double-float)) (read-from-string "(1.0 1.0e0 1.0s0 1.0f0 1.0d0 1.0L0)")) => (1.0 1.0 1.0 1.0 1.0 1.0) ;Implementation has float format F. => (1.0 1.0 1.0s0 1.0 1.0 1.0) ;Implementation has float formats S and F. => (1.0d0 1.0d0 1.0 1.0 1.0d0 1.0d0) ;Implementation has float formats F and D. => (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0d0) ;Implementation has float formats S, F, D. => (1.0d0 1.0d0 1.0 1.0 1.0d0 1.0L0) ;Implementation has float formats F, D, L. => (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0L0) ;Implementation has formats S, F, D, L.  File: gcl.info, Node: *read-eval*, Next: *read-suppress*, Prev: *read-default-float-format*, Up: Reader Dictionary 23.2.15 *read-eval* [Variable] ------------------------------ Value Type:: ............ a generalized boolean. Initial Value:: ............... true. Description:: ............. If it is true, the #. reader macro has its normal effect. Otherwise, that reader macro signals an error of type reader-error. See Also:: .......... *print-readably* Notes:: ....... If *read-eval* is false and *print-readably* is true, any method for print-object that would output a reference to the #. reader macro either outputs something different or signals an error of type print-not-readable.  File: gcl.info, Node: *read-suppress*, Next: *readtable*, Prev: *read-eval*, Up: Reader Dictionary 23.2.16 *read-suppress* [Variable] ---------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... false. Description:: ............. This variable is intended primarily to support the operation of the read-time conditional notations #+ and #-. It is important for the reader macros which implement these notations to be able to skip over the printed representation of an expression despite the possibility that the syntax of the skipped expression may not be entirely valid for the current implementation, since #+ and #- exist in order to allow the same program to be shared among several Lisp implementations (including dialects other than Common Lisp) despite small incompatibilities of syntax. If it is false, the Lisp reader operates normally. If the value of *read-suppress* is true, read, read-preserving-whitespace, read-delimited-list, and read-from-string all return a primary value of nil when they complete successfully; however, they continue to parse the representation of an object in the normal way, in order to skip over the object, and continue to indicate end of file in the normal way. Except as noted below, any standardized reader macro_2 that is defined to read_2 a following object or token will do so, but not signal an error if the object read is not of an appropriate type or syntax. The standard syntax and its associated reader macros will not construct any new objects (e.g., when reading the representation of a symbol, no symbol will be constructed or interned). Extended tokens All extended tokens are completely uninterpreted. Errors such as those that might otherwise be signaled due to detection of invalid potential numbers, invalid patterns of package markers, and invalid uses of the dot character are suppressed. Dispatching macro characters (including sharpsign) Dispatching macro characters continue to parse an infix numerical argument, and invoke the dispatch function. The standardized sharpsign reader macros do not enforce any constraints on either the presence of or the value of the numerical argument. #= The #= notation is totally ignored. It does not read a following object. It produces no object, but is treated as whitespace_2. ## The ## notation always produces nil. No matter what the value of *read-suppress*, parentheses still continue to delimit and construct lists; the #( notation continues to delimit vectors; and comments, strings, and the single-quote and backquote notations continue to be interpreted properly. Such situations as '), #<, #), and # continue to signal errors. Examples:: .......... (let ((*read-suppress* t)) (mapcar #'read-from-string '("#(foo bar baz)" "#P(:type :lisp)" "#c1.2" "#.(PRINT 'FOO)" "#3AHELLO" "#S(INTEGER)" "#*ABC" "#\GARBAGE" "#RALPHA" "#3R444"))) => (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) See Also:: .......... *note read:: , *note Syntax:: Notes:: ....... Programmers and implementations that define additional macro characters are strongly encouraged to make them respect *read-suppress* just as standardized macro characters do. That is, when the value of *read-suppress* is true, they should ignore type errors when reading a following object and the functions that implement dispatching macro characters should tolerate nil as their infix parameter value even if a numeric value would ordinarily be required.  File: gcl.info, Node: *readtable*, Next: reader-error, Prev: *read-suppress*, Up: Reader Dictionary 23.2.17 *readtable* [Variable] ------------------------------ Value Type:: ............ a readtable. Initial Value:: ............... A readtable that conforms to the description of Common Lisp syntax in *note Syntax::. Description:: ............. The value of *readtable* is called the current readtable. It controls the parsing behavior of the Lisp reader, and can also influence the Lisp printer (e.g., see the function readtable-case). Examples:: .......... (readtablep *readtable*) => true (setq zvar 123) => 123 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) => T zvar => 123 (setq *readtable* table2) => # zvar => VAR (setq *readtable* (copy-readtable nil)) => # zvar => 123 Affected By:: ............. compile-file, load See Also:: .......... *note compile-file:: , *note load:: , *note readtable:: , *note The Current Readtable::  File: gcl.info, Node: reader-error, Prev: *readtable*, Up: Reader Dictionary 23.2.18 reader-error [Condition Type] ------------------------------------- Class Precedence List:: ....................... reader-error, parse-error, stream-error, error, serious-condition, condition, t Description:: ............. The type reader-error consists of error conditions that are related to tokenization and parsing done by the Lisp reader. See Also:: .......... *note read:: , *note stream-error-stream:: , *note Reader Concepts::  File: gcl.info, Node: System Construction, Next: Environment, Prev: Reader, Up: Top 24 System Construction ********************** * Menu: * System Construction Concepts:: * System Construction Dictionary::  File: gcl.info, Node: System Construction Concepts, Next: System Construction Dictionary, Prev: System Construction, Up: System Construction 24.1 System Construction Concepts ================================= * Menu: * Loading:: * Features::  File: gcl.info, Node: Loading, Next: Features, Prev: System Construction Concepts, Up: System Construction Concepts 24.1.1 Loading -------------- To load a file is to treat its contents as code and execute that code. The file may contain source code or compiled code . A file containing source code is called a source file . Loading a source file is accomplished essentially by sequentially reading_2 the forms in the file, evaluating each immediately after it is read. A file containing compiled code is called a compiled file . Loading a compiled file is similar to loading a source file, except that the file does not contain text but rather an implementation-dependent representation of pre-digested expressions created by the compiler. Often, a compiled file can be loaded more quickly than a source file. See *note Compilation::. The way in which a source file is distinguished from a compiled file is implementation-dependent.  File: gcl.info, Node: Features, Prev: Loading, Up: System Construction Concepts 24.1.2 Features --------------- A feature is an aspect or attribute of Common Lisp, of the implementation, or of the environment. A feature is identified by a symbol. A feature is said to be present in a Lisp image if and only if the symbol naming it is an element of the list held by the variable *features*, which is called the features list . * Menu: * Feature Expressions:: * Examples of Feature Expressions::  File: gcl.info, Node: Feature Expressions, Next: Examples of Feature Expressions, Prev: Features, Up: Features 24.1.2.1 Feature Expressions ............................ Boolean combinations of features, called feature expressions , are used by the #+ and #- reader macros in order to direct conditional reading of expressions by the Lisp reader. The rules for interpreting a feature expression are as follows: feature If a symbol naming a feature is used as a feature expression, the feature expression succeeds if that feature is present; otherwise it fails. (not feature-conditional) A not feature expression succeeds if its argument feature-conditional fails; otherwise, it succeeds. (and {feature-conditional}*) An and feature expression succeeds if all of its argument feature-conditionals succeed; otherwise, it fails. (or {feature-conditional}*) An or feature expression succeeds if any of its argument feature-conditionals succeed; otherwise, it fails.  File: gcl.info, Node: Examples of Feature Expressions, Prev: Feature Expressions, Up: Features 24.1.2.2 Examples of Feature Expressions ........................................ For example, suppose that in implementation A, the features spice and perq are present, but the feature lispm is not present; in implementation B, the feature lispm is present, but the features spice and perq are not present; and in implementation C, none of the features spice, lispm, or perq are present. Figure 24-1 shows some sample expressions, and how they would be read_2 in these implementations. (cons #+spice "Spice" #-spice "Lispm" x) in implementation A ... (CONS "Spice" X) in implementation B ... (CONS "Lispm" X) in implementation C ... (CONS "Lispm" X) (cons #+spice "Spice" #+LispM "Lispm" x) in implementation A ... (CONS "Spice" X) in implementation B ... (CONS "Lispm" X) in implementation C ... (CONS X) (setq a '(1 2 #+perq 43 #+(not perq) 27)) in implementation A ... (SETQ A '(1 2 43)) in implementation B ... (SETQ A '(1 2 27)) in implementation C ... (SETQ A '(1 2 27)) (let ((a 3) #+(or spice lispm) (b 3)) (foo a)) in implementation A ... (LET ((A 3) (B 3)) (FOO A)) in implementation B ... (LET ((A 3) (B 3)) (FOO A)) in implementation C ... (LET ((A 3)) (FOO A)) (cons #+Lispm "#+Spice" #+Spice "foo" #-(or Lispm Spice) 7 x) in implementation A ... (CONS "foo" X) in implementation B ... (CONS "#+Spice" X) in implementation C ... (CONS 7 X) Figure 24-1: Features examples  File: gcl.info, Node: System Construction Dictionary, Prev: System Construction Concepts, Up: System Construction 24.2 System Construction Dictionary =================================== * Menu: * compile-file:: * compile-file-pathname:: * load:: * with-compilation-unit:: * *features*:: * *compile-file-pathname*:: * *load-pathname*:: * *compile-print*:: * *load-print*:: * *modules*:: * provide::  File: gcl.info, Node: compile-file, Next: compile-file-pathname, Prev: System Construction Dictionary, Up: System Construction Dictionary 24.2.1 compile-file [Function] ------------------------------ 'compile-file' input-file &key output-file verbose print external-format => output-truename, warnings-p, failure-p Arguments and Values:: ...................... input-file--a pathname designator. (Default fillers for unspecified components are taken from *default-pathname-defaults*.) output-file--a pathname designator. The default is implementation-defined. verbose--a generalized boolean. The default is the value of *compile-verbose*. print--a generalized boolean. The default is the value of *compile-print*. external-format--an external file format designator. The default is :default. output-truename--a pathname (the truename of the output file), or nil. warnings-p--a generalized boolean. failure-p--a generalized boolean. Description:: ............. compile-file transforms the contents of the file specified by input-file into implementation-dependent binary data which are placed in the file specified by output-file. The file to which input-file refers should be a source file. output-file can be used to specify an output pathname; the actual pathname of the compiled file to which compiled code will be output is computed as if by calling compile-file-pathname. If input-file or output-file is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname. If verbose is true, compile-file prints a message in the form of a comment (i.e., with a leading semicolon) to standard output indicating what file is being compiled and other useful information. If verbose is false, compile-file does not print this information. If print is true, information about top level forms in the file being compiled is printed to standard output. Exactly what is printed is implementation-dependent, but nevertheless some information is printed. If print is nil, no information is printed. The external-format specifies the external file format to be used when opening the file; see the function open. compile-file and load must cooperate in such a way that the resulting compiled file can be loaded without specifying an external file format anew; see the function load. compile-file binds *readtable* and *package* to the values they held before processing the file. *compile-file-truename* is bound by compile-file to hold the truename of the pathname of the file being compiled. *compile-file-pathname* is bound by compile-file to hold a pathname denoted by the first argument to compile-file, merged against the defaults; that is, (pathname (merge-pathnames input-file)). The compiled functions contained in the compiled file become available for use when the compiled file is loaded into Lisp. Any function definition that is processed by the compiler, including #'(lambda ...) forms and local function definitions made by flet, labels and defun forms, result in an object of type compiled-function. The primary value returned by compile-file, output-truename, is the truename of the output file, or nil if the file could not be created. The secondary value, warnings-p, is false if no conditions of type error or warning were detected by the compiler, and true otherwise. The tertiary value, failure-p, is false if no conditions of type error or warning (other than style-warning) were detected by the compiler, and true otherwise. For general information about how files are processed by the file compiler, see *note File Compilation::. Programs to be compiled by the file compiler must only contain externalizable objects; for details on such objects, see *note Literal Objects in Compiled Files::. For information on how to extend the set of externalizable objects, see the function make-load-form and *note Additional Constraints on Externalizable Objects::. Affected By:: ............. *error-output*, *standard-output*, *compile-verbose*, *compile-print* The computer's file system. Exceptional Situations:: ........................ For information about errors detected during the compilation process, see *note Exceptional Situations in the Compiler::. An error of type file-error might be signaled if (wild-pathname-p input-file)\/ returns true. If either the attempt to open the source file for input or the attempt to open the compiled file for output fails, an error of type file-error is signaled. See Also:: .......... *note compile:: , declare, *note eval-when:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: compile-file-pathname, Next: load, Prev: compile-file, Up: System Construction Dictionary 24.2.2 compile-file-pathname [Function] --------------------------------------- 'compile-file-pathname' input-file &key output-file &allow-other-keys => pathname Arguments and Values:: ...................... input-file--a pathname designator. (Default fillers for unspecified components are taken from *default-pathname-defaults*.) output-file--a pathname designator. The default is implementation-defined. pathname--a pathname. Description:: ............. Returns the pathname that compile-file would write into, if given the same arguments. The defaults for the output-file are taken from the pathname that results from merging the input-file with the value of *default-pathname-defaults*, except that the type component should default to the appropriate implementation-defined default type for compiled files. If input-file is a logical pathname and output-file is unsupplied, the result is a logical pathname. If input-file is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname. If input-file is a stream, the stream can be either open or closed. compile-file-pathname returns the same pathname after a file is closed as it did when the file was open. It is an error if input-file is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, make-string-output-stream. If an implementation supports additional keyword arguments to compile-file, compile-file-pathname must accept the same arguments. Examples:: .......... See logical-pathname-translations. Exceptional Situations:: ........................ An error of type file-error might be signaled if either input-file or output-file is wild. See Also:: .......... *note compile-file:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: load, Next: with-compilation-unit, Prev: compile-file-pathname, Up: System Construction Dictionary 24.2.3 load [Function] ---------------------- 'load' filespec &key verbose print if-does-not-exist external-format => generalized-boolean Arguments and Values:: ...................... filespec--a stream, or a pathname designator. The default is taken from *default-pathname-defaults*. verbose--a generalized boolean. The default is the value of *load-verbose*. print--a generalized boolean. The default is the value of *load-print*. if-does-not-exist--a generalized boolean. The default is true. external-format--an external file format designator. The default is :default. generalized-boolean--a generalized boolean. Description:: ............. load loads the file named by filespec into the Lisp environment. The manner in which a source file is distinguished from a compiled file is implementation-dependent. If the file specification is not complete and both a source file and a compiled file exist which might match, then which of those files load selects is implementation-dependent. If filespec is a stream, load determines what kind of stream it is and loads directly from the stream. If filespec is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname. load sequentially executes each form it encounters in the file named by filespec. If the file is a source file and the implementation chooses to perform implicit compilation, load must recognize top level forms as described in *note Processing of Top Level Forms:: and arrange for each top level form to be executed before beginning implicit compilation of the next. (Note, however, that processing of eval-when forms by load is controlled by the :execute situation.) If verbose is true, load prints a message in the form of a comment (i.e., with a leading semicolon) to standard output indicating what file is being loaded and other useful information. If verbose is false, load does not print this information. If print is true, load incrementally prints information to standard output showing the progress of the loading process. For a source file, this information might mean printing the values yielded by each form in the file as soon as those values are returned. For a compiled file, what is printed might not reflect precisely the contents of the source file, but some information is generally printed. If print is false, load does not print this information. If the file named by filespec is successfully loaded, load returns true. [Reviewer Note by Loosemore: What happens if the file cannot be loaded for some reason other than that it doesn't exist?] [Editorial Note by KMP: i.e., can it return NIL? must it?] If the file does not exist, the specific action taken depends on if-does-not-exist: if it is nil, load returns nil; otherwise, load signals an error. The external-format specifies the external file format to be used when opening the file (see the function open), except that when the file named by filespec is a compiled file, the external-format is ignored. compile-file and load cooperate in an implementation-dependent way to assure the preservation of the similarity of characters referred to in the source file at the time the source file was processed by the file compiler under a given external file format, regardless of the value of external-format at the time the compiled file is loaded. load binds *readtable* and *package* to the values they held before loading the file. *load-truename* is bound by load to hold the truename of the pathname of the file being loaded. *load-pathname* is bound by load to hold a pathname that represents filespec merged against the defaults. That is, (pathname (merge-pathnames filespec)). Examples:: .......... ;Establish a data file... (with-open-file (str "data.in" :direction :output :if-exists :error) (print 1 str) (print '(setq a 888) str) t) => T (load "data.in") => true a => 888 (load (setq p (merge-pathnames "data.in")) :verbose t) ; Loading contents of file /fred/data.in ; Finished loading /fred/data.in => true (load p :print t) ; Loading contents of file /fred/data.in ; 1 ; 888 ; Finished loading /fred/data.in => true ;----[Begin file SETUP]---- (in-package "MY-STUFF") (defmacro compile-truename () `',*compile-file-truename*) (defvar *my-compile-truename* (compile-truename) "Just for debugging.") (defvar *my-load-pathname* *load-pathname*) (defun load-my-system () (dolist (module-name '("FOO" "BAR" "BAZ")) (load (merge-pathnames module-name *my-load-pathname*)))) ;----[End of file SETUP]---- (load "SETUP") (load-my-system) Affected By:: ............. The implementation, and the host computer's file system. Exceptional Situations:: ........................ If :if-does-not-exist is supplied and is true, or is not supplied, load signals an error of type file-error if the file named by filespec does not exist, or if the file system cannot perform the requested operation. An error of type file-error might be signaled if (wild-pathname-p filespec) returns true. See Also:: .......... *note error:: , *note merge-pathnames:: , *load-verbose*, *default-pathname-defaults*, pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: with-compilation-unit, Next: *features*, Prev: load, Up: System Construction Dictionary 24.2.4 with-compilation-unit [Macro] ------------------------------------ 'with-compilation-unit' ([[!option]]) {form}* => {result}* option ::=:override override Arguments and Values:: ...................... override--a generalized boolean; evaluated. The default is nil. forms--an implicit progn. results--the values returned by the forms. Description:: ............. Executes forms from left to right. Within the dynamic environment of with-compilation-unit, actions deferred by the compiler until the end of compilation will be deferred until the end of the outermost call to with-compilation-unit. The set of options permitted may be extended by the implementation, but the only standardized keyword is :override. If nested dynamically only the outer call to with-compilation-unit has any effect unless the value associated with :override is true, in which case warnings are deferred only to the end of the innermost call for which override is true. The function compile-file provides the effect of (with-compilation-unit (:override nil) ...) around its code. Any implementation-dependent extensions can only be provided as the result of an explicit programmer request by use of an implementation-dependent keyword. Implementations are forbidden from attaching additional meaning to a use of this macro which involves either no keywords or just the keyword :override. Examples:: .......... If an implementation would normally defer certain kinds of warnings, such as warnings about undefined functions, to the end of a compilation unit (such as a file), the following example shows how to cause those warnings to be deferred to the end of the compilation of several files. (defun compile-files (&rest files) (with-compilation-unit () (mapcar #'(lambda (file) (compile-file file)) files))) (compile-files "A" "B" "C") Note however that if the implementation does not normally defer any warnings, use of with-compilation-unit might not have any effect. See Also:: .......... *note compile:: , *note compile-file::  File: gcl.info, Node: *features*, Next: *compile-file-pathname*, Prev: with-compilation-unit, Up: System Construction Dictionary 24.2.5 *features* [Variable] ---------------------------- Value Type:: ............ a proper list. Initial Value:: ............... implementation-dependent. Description:: ............. The value of *features* is called the features list. It is a list of symbols, called features, that correspond to some aspect of the implementation or environment. Most features have implementation-dependent meanings; The following meanings have been assigned to feature names: :cltl1 If present, indicates that the LISP package purports to conform to the 1984 specification Common Lisp: The Language. It is possible, but not required, for a conforming implementation to have this feature because this specification specifies that its symbols are to be in the COMMON-LISP package, not the LISP package. :cltl2 If present, indicates that the implementation purports to conform to Common Lisp: The Language, Second Edition. This feature must not be present in any conforming implementation, since conformance to that document is not compatible with conformance to this specification. The name, however, is reserved by this specification in order to help programs distinguish implementations which conform to that document from implementations which conform to this specification. :ieee-floating-point If present, indicates that the implementation purports to conform to the requirements of IEEE Standard for Binary Floating-Point Arithmetic. :x3j13 If present, indicates that the implementation conforms to some particular working draft of this specification, or to some subset of features that approximates a belief about what this specification might turn out to contain. A conforming implementation might or might not contain such a feature. (This feature is intended primarily as a stopgap in order to provide implementors something to use prior to the availability of a draft standard, in order to discourage them from introducing the :draft-ansi-cl and :ansi-cl features prematurely.) :draft-ansi-cl If present, indicates that the implementation purports to conform to the first full draft of this specification, which went to public review in 1992. A conforming implementation which has the :draft-ansi-cl-2 or :ansi-cl feature is not permitted to retain the :draft-ansi-cl feature since incompatible changes were made subsequent to the first draft. :draft-ansi-cl-2 If present, indicates that a second full draft of this specification has gone to public review, and that the implementation purports to conform to that specification. (If additional public review drafts are produced, this keyword will continue to refer to the second draft, and additional keywords will be added to identify conformance with such later drafts. As such, the meaning of this keyword can be relied upon not to change over time.) A conforming implementation which has the :ansi-cl feature is only permitted to retain the :draft-ansi-cl feature if the finally approved standard is not incompatible with the draft standard. :ansi-cl If present, indicates that this specification has been adopted by ANSI as an official standard, and that the implementation purports to conform. :common-lisp This feature must appear in *features* for any implementation that has one or more of the features :x3j13, :draft-ansi-cl, or :ansi-cl. It is intended that it should also appear in implementations which have the features :cltl1 or :cltl2, but this specification cannot force such behavior. The intent is that this feature should identify the language family named "Common Lisp," rather than some specific dialect within that family. See Also:: .......... *note Use of Read-Time Conditionals::, *note Standard Macro Characters:: Notes:: ....... The value of *features* is used by the #+ and #- reader syntax. Symbols in the features list may be in any package, but in practice they are generally in the KEYWORD package. This is because KEYWORD is the package used by default when reading_2 feature expressions in the #+ and #- reader macros. Code that needs to name a feature_2 in a package P (other than KEYWORD) can do so by making explicit use of a package prefix for P, but note that such code must also assure that the package P exists in order for the feature expression to be read_2--even in cases where the feature expression is expected to fail. It is generally considered wise for an implementation to include one or more features identifying the specific implementation, so that conditional expressions can be written which distinguish idiosyncrasies of one implementation from those of another. Since features are normally symbols in the KEYWORD package where name collisions might easily result, and since no uniquely defined mechanism is designated for deciding who has the right to use which symbol for what reason, a conservative strategy is to prefer names derived from one's own company or product name, since those names are often trademarked and are hence less likely to be used unwittingly by another implementation.  File: gcl.info, Node: *compile-file-pathname*, Next: *load-pathname*, Prev: *features*, Up: System Construction Dictionary 24.2.6 *compile-file-pathname*, *compile-file-truename* [Variable] ------------------------------------------------------------------ Value Type:: ............ The value of *compile-file-pathname* must always be a pathname or nil. The value of *compile-file-truename* must always be a physical pathname or nil. Initial Value:: ............... nil. Description:: ............. During a call to compile-file, *compile-file-pathname* is bound to the pathname denoted by the first argument to compile-file, merged against the defaults; that is, it is bound to (pathname (merge-pathnames input-file)). During the same time interval, *compile-file-truename* is bound to the truename of the file being compiled. At other times, the value of these variables is nil. If a break loop is entered while compile-file is ongoing, it is implementation-dependent whether these variables retain the values they had just prior to entering the break loop or whether they are bound to nil. The consequences are unspecified if an attempt is made to assign or bind either of these variables. Affected By:: ............. The file system. See Also:: .......... *note compile-file::  File: gcl.info, Node: *load-pathname*, Next: *compile-print*, Prev: *compile-file-pathname*, Up: System Construction Dictionary 24.2.7 *load-pathname*, *load-truename* [Variable] -------------------------------------------------- Value Type:: ............ The value of *load-pathname* must always be a pathname or nil. The value of *load-truename* must always be a physical pathname or nil. Initial Value:: ............... nil. Description:: ............. During a call to load, *load-pathname* is bound to the pathname denoted by the the first argument to load, merged against the defaults; that is, it is bound to (pathname (merge-pathnames filespec)). During the same time interval, *load-truename* is bound to the truename of the file being loaded. At other times, the value of these variables is nil. If a break loop is entered while load is ongoing, it is implementation-dependent whether these variables retain the values they had just prior to entering the break loop or whether they are bound to nil. The consequences are unspecified if an attempt is made to assign or bind either of these variables. Affected By:: ............. The file system. See Also:: .......... *note load::  File: gcl.info, Node: *compile-print*, Next: *load-print*, Prev: *load-pathname*, Up: System Construction Dictionary 24.2.8 *compile-print*, *compile-verbose* [Variable] ---------------------------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... implementation-dependent. Description:: ............. The value of *compile-print* is the default value of the :print argument to compile-file. The value of *compile-verbose* is the default value of the :verbose argument to compile-file. See Also:: .......... *note compile-file::  File: gcl.info, Node: *load-print*, Next: *modules*, Prev: *compile-print*, Up: System Construction Dictionary 24.2.9 *load-print*, *load-verbose* [Variable] ---------------------------------------------- Value Type:: ............ a generalized boolean. Initial Value:: ............... The initial value of *load-print* is false. The initial value of *load-verbose* is implementation-dependent. Description:: ............. The value of *load-print* is the default value of the :print argument to load. The value of *load-verbose* is the default value of the :verbose argument to load. See Also:: .......... *note load::  File: gcl.info, Node: *modules*, Next: provide, Prev: *load-print*, Up: System Construction Dictionary 24.2.10 *modules* [Variable] ---------------------------- Value Type:: ............ a list of strings. Initial Value:: ............... implementation-dependent. Description:: ............. The value of *modules* is a list of names of the modules that have been loaded into the current Lisp image. Affected By:: ............. provide See Also:: .......... *note provide:: , require Notes:: ....... The variable *modules* is deprecated.  File: gcl.info, Node: provide, Prev: *modules*, Up: System Construction Dictionary 24.2.11 provide, require [Function] ----------------------------------- 'provide' module-name => implementation-dependent 'require' module-name &optional pathname-list => implementation-dependent Arguments and Values:: ...................... module-name--a string designator. pathname-list--nil, or a designator for a non-empty list of pathname designators. The default is nil. Description:: ............. provide adds the module-name to the list held by *modules*, if such a name is not already present. require tests for the presence of the module-name in the list held by *modules*. If it is present, require immediately returns. Otherwise, an attempt is made to load an appropriate set of files as follows: The pathname-list argument, if non-nil, specifies a list of pathnames to be loaded in order, from left to right. If the pathname-list is nil, an implementation-dependent mechanism will be invoked in an attempt to load the module named module-name; if no such module can be loaded, an error of type error is signaled. Both functions use string= to test for the presence of a module-name. Examples:: .......... ;;; This illustrates a nonportable use of REQUIRE, because it ;;; depends on the implementation-dependent file-loading mechanism. (require "CALCULUS") ;;; This use of REQUIRE is nonportable because of the literal ;;; physical pathname. (require "CALCULUS" "/usr/lib/lisp/calculus") ;;; One form of portable usage involves supplying a logical pathname, ;;; with appropriate translations defined elsewhere. (require "CALCULUS" "lib:calculus") ;;; Another form of portable usage involves using a variable or ;;; table lookup function to determine the pathname, which again ;;; must be initialized elsewhere. (require "CALCULUS" *calculus-module-pathname*) Side Effects:: .............. provide modifies *modules*. Affected By:: ............. The specific action taken by require is affected by calls to provide (or, in general, any changes to the value of *modules*). Exceptional Situations:: ........................ Should signal an error of type type-error if module-name is not a string designator. If require fails to perform the requested operation due to a problem while interacting with the file system, an error of type file-error is signaled. An error of type file-error might be signaled if any pathname in pathname-list is a designator for a wild pathname. See Also:: .......... *modules*, *note Pathnames as Filenames:: Notes:: ....... The functions provide and require are deprecated. If a module consists of a single package, it is customary for the package and module names to be the same.  File: gcl.info, Node: Environment, Next: Glossary (Glossary), Prev: System Construction, Up: Top 25 Environment ************** * Menu: * The External Environment:: * Environment Dictionary::  File: gcl.info, Node: The External Environment, Next: Environment Dictionary, Prev: Environment, Up: Environment 25.1 The External Environment ============================= * Menu: * Top level loop:: * Debugging Utilities:: * Environment Inquiry:: * Time::  File: gcl.info, Node: Top level loop, Next: Debugging Utilities, Prev: The External Environment, Up: The External Environment 25.1.1 Top level loop --------------------- The top level loop is the Common Lisp mechanism by which the user normally interacts with the Common Lisp system. This loop is sometimes referred to as the Lisp read-eval-print loop because it typically consists of an endless loop that reads an expression, evaluates it and prints the results. The top level loop is not completely specified; thus the user interface is implementation-defined. The top level loop prints all values resulting from the evaluation of a form. Figure 25-1 lists variables that are maintained by the Lisp read-eval-print loop. * + / - ** ++ // *** +++ /// Figure 25-1: Variables maintained by the Read-Eval-Print Loop  File: gcl.info, Node: Debugging Utilities, Next: Environment Inquiry, Prev: Top level loop, Up: The External Environment 25.1.2 Debugging Utilities -------------------------- Figure 25-2 shows defined names relating to debugging. *debugger-hook* documentation step apropos dribble time apropos-list ed trace break inspect untrace describe invoke-debugger Figure 25-2: Defined names relating to debugging  File: gcl.info, Node: Environment Inquiry, Next: Time, Prev: Debugging Utilities, Up: The External Environment 25.1.3 Environment Inquiry -------------------------- Environment inquiry defined names provide information about the hardware and software configuration on which a Common Lisp program is being executed. Figure 25-3 shows defined names relating to environment inquiry. *features* machine-instance short-site-name lisp-implementation-type machine-type software-type lisp-implementation-version machine-version software-version long-site-name room Figure 25-3: Defined names relating to environment inquiry.  File: gcl.info, Node: Time, Prev: Environment Inquiry, Up: The External Environment 25.1.4 Time ----------- Time is represented in four different ways in Common Lisp: decoded time, universal time, internal time, and seconds. Decoded time and universal time are used primarily to represent calendar time, and are precise only to one second. Internal time is used primarily to represent measurements of computer time (such as run time) and is precise to some implementation-dependent fraction of a second called an internal time unit, as specified by internal-time-units-per-second. An internal time can be used for either absolute and relative time measurements. Both a universal time and a decoded time can be used only for absolute time measurements. In the case of one function, sleep, time intervals are represented as a non-negative real number of seconds. Figure 25-4 shows defined names relating to time. decode-universal-time get-internal-run-time encode-universal-time get-universal-time get-decoded-time internal-time-units-per-second get-internal-real-time sleep Figure 25-4: Defined names involving Time. * Menu: * Decoded Time:: * Universal Time:: * Internal Time:: * Seconds::  File: gcl.info, Node: Decoded Time, Next: Universal Time, Prev: Time, Up: Time 25.1.4.1 Decoded Time ..................... A decoded time is an ordered series of nine values that, taken together, represent a point in calendar time (ignoring leap seconds): Second An integer between 0 and~59, inclusive. Minute An integer between 0 and~59, inclusive. Hour An integer between 0 and~23, inclusive. Date An integer between 1 and~31, inclusive (the upper limit actually depends on the month and year, of course). Month An integer between 1 and 12, inclusive; 1~means January, 2~means February, and so on; 12~means December. Year An integer indicating the year A.D. However, if this integer is between 0 and 99, the "obvious" year is used; more precisely, that year is assumed that is equal to the integer modulo 100 and within fifty years of the current year (inclusive backwards and exclusive forwards). Thus, in the year 1978, year 28 is 1928 but year 27 is 2027. (Functions that return time in this format always return a full year number.) Day of week An integer between~0 and~6, inclusive; 0~means Monday, 1~means Tuesday, and so on; 6~means Sunday. Daylight saving time flag A generalized boolean that, if true, indicates that daylight saving time is in effect. Time zone A time zone. Figure 25-5 shows defined names relating to decoded time. decode-universal-time get-decoded-time Figure 25-5: Defined names involving time in Decoded Time.  File: gcl.info, Node: Universal Time, Next: Internal Time, Prev: Decoded Time, Up: Time 25.1.4.2 Universal Time ....................... Universal time is an absolute time represented as a single non-negative integer--the number of seconds since midnight, January 1, 1900 GMT (ignoring leap seconds). Thus the time 1 is 00:00:01 (that is, 12:00:01 a.m.) on January 1, 1900 GMT. Similarly, the time 2398291201 corresponds to time 00:00:01 on January 1, 1976 GMT. Recall that the year 1900 was not a leap year; for the purposes of Common Lisp, a year is a leap year if and only if its number is divisible by 4, except that years divisible by 100 are not leap years, except that years divisible by 400 are leap years. Therefore the year 2000 will be a leap year. Because universal time must be a non-negative integer, times before the base time of midnight, January 1, 1900 GMT cannot be processed by Common Lisp. decode-universal-time get-universal-time encode-universal-time Figure 25-6: Defined names involving time in Universal Time.  File: gcl.info, Node: Internal Time, Next: Seconds, Prev: Universal Time, Up: Time 25.1.4.3 Internal Time ...................... Internal time represents time as a single integer, in terms of an implementation-dependent unit called an internal time unit. Relative time is measured as a number of these units. Absolute time is relative to an arbitrary time base. Figure 25-7 shows defined names related to internal time. get-internal-real-time internal-time-units-per-second get-internal-run-time Figure 25-7: Defined names involving time in Internal Time.  File: gcl.info, Node: Seconds, Prev: Internal Time, Up: Time 25.1.4.4 Seconds ................ One function, sleep, takes its argument as a non-negative real number of seconds. Informally, it may be useful to think of this as a relative universal time, but it differs in one important way: universal times are always non-negative integers, whereas the argument to sleep can be any kind of non-negative real, in order to allow for the possibility of fractional seconds. sleep Figure 25-8: Defined names involving time in Seconds.  File: gcl.info, Node: Environment Dictionary, Prev: The External Environment, Up: Environment 25.2 Environment Dictionary =========================== * Menu: * decode-universal-time:: * encode-universal-time:: * get-universal-time:: * sleep:: * apropos:: * describe:: * describe-object:: * trace:: * step:: * time:: * internal-time-units-per-second:: * get-internal-real-time:: * get-internal-run-time:: * disassemble:: * documentation:: * room:: * ed:: * inspect:: * dribble:: * - (Variable):: * + (Variable):: * * (Variable):: * / (Variable):: * lisp-implementation-type:: * short-site-name:: * machine-instance:: * machine-type:: * machine-version:: * software-type:: * user-homedir-pathname::  File: gcl.info, Node: decode-universal-time, Next: encode-universal-time, Prev: Environment Dictionary, Up: Environment Dictionary 25.2.1 decode-universal-time [Function] --------------------------------------- 'decode-universal-time' universal-time &optional time-zone => second, minute, hour, date, month, year, day, daylight-p, zone Arguments and Values:: ...................... universal-time--a universal time. time-zone--a time zone. second, minute, hour, date, month, year, day, daylight-p, zone--a decoded time. Description:: ............. Returns the decoded time represented by the given universal time. If time-zone is not supplied, it defaults to the current time zone adjusted for daylight saving time. If time-zone is supplied, daylight saving time information is ignored. The daylight saving time flag is nil if time-zone is supplied. Examples:: .......... (decode-universal-time 0 0) => 0, 0, 0, 1, 1, 1900, 0, false, 0 ;; The next two examples assume Eastern Daylight Time. (decode-universal-time 2414296800 5) => 0, 0, 1, 4, 7, 1976, 6, false, 5 (decode-universal-time 2414293200) => 0, 0, 1, 4, 7, 1976, 6, true, 5 ;; This example assumes that the time zone is Eastern Daylight Time ;; (and that the time zone is constant throughout the example). (let* ((here (nth 8 (multiple-value-list (get-decoded-time)))) ;Time zone (recently (get-universal-time)) (a (nthcdr 7 (multiple-value-list (decode-universal-time recently)))) (b (nthcdr 7 (multiple-value-list (decode-universal-time recently here))))) (list a b (equal a b))) => ((T 5) (NIL 5) NIL) Affected By:: ............. Implementation-dependent mechanisms for calculating when or if daylight savings time is in effect for any given session. See Also:: .......... *note encode-universal-time:: , *note get-universal-time:: , *note Time::  File: gcl.info, Node: encode-universal-time, Next: get-universal-time, Prev: decode-universal-time, Up: Environment Dictionary 25.2.2 encode-universal-time [function] --------------------------------------- Syntax:: ........ 'encode-universal-time' second minute hour date month year &optional time-zone => universal-time Arguments and Values:: ...................... second, minute, hour, date, month, year, time-zone--the corresponding parts of a decoded time. (Note that some of the nine values in a full decoded time are redundant, and so are not used as inputs to this function.) universal-time--a universal time. Description:: ............. encode-universal-time converts a time from Decoded Time format to a universal time. If time-zone is supplied, no adjustment for daylight savings time is performed. Examples:: .......... (encode-universal-time 0 0 0 1 1 1900 0) => 0 (encode-universal-time 0 0 1 4 7 1976 5) => 2414296800 ;; The next example assumes Eastern Daylight Time. (encode-universal-time 0 0 1 4 7 1976) => 2414293200 See Also:: .......... *note decode-universal-time:: , get-decoded-time  File: gcl.info, Node: get-universal-time, Next: sleep, Prev: encode-universal-time, Up: Environment Dictionary 25.2.3 get-universal-time, get-decoded-time [Function] ------------------------------------------------------ 'get-universal-time' => universal-time 'get-decoded-time' => second, minute, hour, date, month, year, day, daylight-p, zone Arguments and Values:: ...................... universal-time--a universal time. second, minute, hour, date, month, year, day, daylight-p, zone--a decoded time. Description:: ............. get-universal-time returns the current time, represented as a universal time. get-decoded-time returns the current time, represented as a decoded time. Examples:: .......... ;; At noon on July 4, 1976 in Eastern Daylight Time. (get-decoded-time) => 0, 0, 12, 4, 7, 1976, 6, true, 5 ;; At exactly the same instant. (get-universal-time) => 2414332800 ;; Exactly five minutes later. (get-universal-time) => 2414333100 ;; The difference is 300 seconds (five minutes) (- * **) => 300 Affected By:: ............. The time of day (i.e., the passage of time), the system clock's ability to keep accurate time, and the accuracy of the system clock's initial setting. Exceptional Situations:: ........................ An error of type error might be signaled if the current time cannot be determined. See Also:: .......... *note decode-universal-time:: , *note encode-universal-time:: , *note Time:: Notes:: ....... (get-decoded-time) == (decode-universal-time (get-universal-time)) No implementation is required to have a way to verify that the time returned is correct. However, if an implementation provides a validity check (e.g., the failure to have properly initialized the system clock can be reliably detected) and that validity check fails, the implementation is strongly encouraged (but not required) to signal an error of type error (rather than, for example, returning a known-to-be-wrong value) that is correctable by allowing the user to interactively set the correct time.  File: gcl.info, Node: sleep, Next: apropos, Prev: get-universal-time, Up: Environment Dictionary 25.2.4 sleep [Function] ----------------------- 'sleep' seconds => nil Arguments and Values:: ...................... seconds--a non-negative real. Description:: ............. Causes execution to cease and become dormant for approximately the seconds of real time indicated by seconds, whereupon execution is resumed. Examples:: .......... (sleep 1) => NIL ;; Actually, since SLEEP is permitted to use approximate timing, ;; this might not always yield true, but it will often enough that ;; we felt it to be a productive example of the intent. (let ((then (get-universal-time)) (now (progn (sleep 10) (get-universal-time)))) (>= (- now then) 10)) => true Side Effects:: .............. Causes processing to pause. Affected By:: ............. The granularity of the scheduler. Exceptional Situations:: ........................ Should signal an error of type type-error if seconds is not a non-negative real.  File: gcl.info, Node: apropos, Next: describe, Prev: sleep, Up: Environment Dictionary 25.2.5 apropos, apropos-list [Function] --------------------------------------- 'apropos' string &optional package => 'apropos-list' string &optional package => symbols Arguments and Values:: ...................... string--a string designator. package--a package designator or nil. The default is nil. symbols--a list of symbols. Description:: ............. These functions search for interned symbols whose names contain the substring string. For apropos, as each such symbol is found, its name is printed on standard output. In addition, if such a symbol is defined as a function or dynamic variable, information about those definitions might also be printed. For apropos-list, no output occurs as the search proceeds; instead a list of the matching symbols is returned when the search is complete. If package is non-nil, only the symbols accessible in that package are searched; otherwise all symbols accessible in any package are searched. Because a symbol might be available by way of more than one inheritance path, apropos might print information about the same symbol more than once, or apropos-list might return a list containing duplicate symbols. Whether or not the search is case-sensitive is implementation-defined. Affected By:: ............. The set of symbols which are currently interned in any packages being searched. apropos is also affected by *standard-output*.  File: gcl.info, Node: describe, Next: describe-object, Prev: apropos, Up: Environment Dictionary 25.2.6 describe [Function] -------------------------- 'describe' object &optional stream => Arguments and Values:: ...................... object--an object. stream--an output stream designator. The default is standard output. Description:: ............. describe displays information about object to stream. For example, describe of a symbol might show the symbol's value, its definition, and each of its properties. describe of a float might show the number's internal representation in a way that is useful for tracking down round-off errors. In all cases, however, the nature and format of the output of describe is implementation-dependent. describe can describe something that it finds inside the object; in such cases, a notational device such as increased indentation or positioning in a table is typically used in order to visually distinguish such recursive descriptions from descriptions of the argument object. The actual act of describing the object is implemented by describe-object. describe exists as an interface primarily to manage argument defaulting (including conversion of arguments t and nil into stream objects) and to inhibit any return values from describe-object. describe is not intended to be an interactive function. In a conforming implementation, describe must not, by default, prompt for user input. User-defined methods for describe-object are likewise restricted. Side Effects:: .............. Output to standard output or terminal I/O. Affected By:: ............. *standard-output* and *terminal-io*, methods on describe-object and print-object for objects having user-defined classes. See Also:: .......... *note inspect:: , *note describe-object::  File: gcl.info, Node: describe-object, Next: trace, Prev: describe, Up: Environment Dictionary 25.2.7 describe-object [Standard Generic Function] -------------------------------------------------- Syntax:: ........ 'describe-object' object stream => implementation-dependent Method Signatures:: ................... 'describe-object' (object standard-object) stream Arguments and Values:: ...................... object--an object. stream--a stream. Description:: ............. The generic function describe-object prints a description of object to a stream. describe-object is called by describe; it must not be called by the user. Each implementation is required to provide a method on the class standard-object and methods on enough other classes so as to ensure that there is always an applicable method. Implementations are free to add methods for other classes. Users can write methods for describe-object for their own classes if they do not wish to inherit an implementation-supplied method. Methods on describe-object can recursively call describe. Indentation, depth limits, and circularity detection are all taken care of automatically, provided that each method handles exactly one level of structure and calls describe recursively if there are more structural levels. The consequences are undefined if this rule is not obeyed. In some implementations the stream argument passed to a describe-object method is not the original stream, but is an intermediate stream that implements parts of describe. Methods should therefore not depend on the identity of this stream. Examples:: .......... (defclass spaceship () ((captain :initarg :captain :accessor spaceship-captain) (serial# :initarg :serial-number :accessor spaceship-serial-number))) (defclass federation-starship (spaceship) ()) (defmethod describe-object ((s spaceship) stream) (with-slots (captain serial#) s (format stream "~&~S is a spaceship of type ~S,~ ~ and with serial number ~D.~ s (type-of s) captain serial#))) (make-instance 'federation-starship :captain "Rachel Garrett" :serial-number "NCC-1701-C") => # (describe *) |> # is a spaceship of type FEDERATION-STARSHIP, |> with Rachel Garrett at the helm and with serial number NCC-1701-C. => See Also:: .......... *note describe:: Notes:: ....... The same implementation techniques that are applicable to print-object are applicable to describe-object. The reason for making the return values for describe-object unspecified is to avoid forcing users to include explicit (values) in all of their methods. describe takes care of that.  File: gcl.info, Node: trace, Next: step, Prev: describe-object, Up: Environment Dictionary 25.2.8 trace, untrace [Macro] ----------------------------- 'trace' {function-name}* => trace-result 'untrace' {function-name}* => untrace-result Arguments and Values:: ...................... function-name--a function name. trace-result--implementation-dependent, unless no function-names are supplied, in which case trace-result is a list of function names. untrace-result--implementation-dependent. Description:: ............. trace and untrace control the invocation of the trace facility. Invoking trace with one or more function-names causes the denoted functions to be "traced." Whenever a traced function is invoked, information about the call, about the arguments passed, and about any eventually returned values is printed to trace output. If trace is used with no function-names, no tracing action is performed; instead, a list of the functions currently being traced is returned. Invoking untrace with one or more function names causes those functions to be "untraced" (i.e., no longer traced). If untrace is used with no function-names, all functions currently being traced are untraced. If a function to be traced has been open-coded (e.g., because it was declared inline), a call to that function might not produce trace output. Examples:: .......... (defun fact (n) (if (zerop n) 1 (* n (fact (- n 1))))) => FACT (trace fact) => (FACT) ;; Of course, the format of traced output is implementation-dependent. (fact 3) |> 1 Enter FACT 3 |> | 2 Enter FACT 2 |> | 3 Enter FACT 1 |> | | 4 Enter FACT 0 |> | | 4 Exit FACT 1 |> | 3 Exit FACT 1 |> | 2 Exit FACT 2 |> 1 Exit FACT 6 => 6 Side Effects:: .............. Might change the definitions of the functions named by function-names. Affected By:: ............. Whether the functions named are defined or already being traced. Exceptional Situations:: ........................ Tracing an already traced function, or untracing a function not currently being traced, should produce no harmful effects, but might signal a warning. See Also:: .......... *trace-output*, *note step:: Notes:: ....... trace and untrace may also accept additional implementation-dependent argument formats. The format of the trace output is implementation-dependent. Although trace can be extended to permit non-standard options, implementations are nevertheless encouraged (but not required) to warn about the use of syntax or options that are neither specified by this standard nor added as an extension by the implementation, since they could be symptomatic of typographical errors or of reliance on features supported in implementations other than the current implementation.  File: gcl.info, Node: step, Next: time, Prev: trace, Up: Environment Dictionary 25.2.9 step [Macro] ------------------- 'step' form => {result}* Arguments and Values:: ...................... form--a form; evaluated as described below. results--the values returned by the form. Description:: ............. step implements a debugging paradigm wherein the programmer is allowed to step through the evaluation of a form. The specific nature of the interaction, including which I/O streams are used and whether the stepping has lexical or dynamic scope, is implementation-defined. step evaluates form in the current environment. A call to step can be compiled, but it is acceptable for an implementation to interactively step through only those parts of the computation that are interpreted. It is technically permissible for a conforming implementation to take no action at all other than normal execution of the form. In such a situation, (step form) is equivalent to, for example, (let () form). In implementations where this is the case, the associated documentation should mention that fact. See Also:: .......... *note trace:: Notes:: ....... Implementations are encouraged to respond to the typing of ? or the pressing of a "help key" by providing help including a list of commands.  File: gcl.info, Node: time, Next: internal-time-units-per-second, Prev: step, Up: Environment Dictionary 25.2.10 time [Macro] -------------------- 'time' form => {result}* Arguments and Values:: ...................... form--a form; evaluated as described below. results--the values returned by the form. Description:: ............. time evaluates form in the current environment (lexical and dynamic). A call to time can be compiled. time prints various timing data and other information to trace output. The nature and format of the printed information is implementation-defined. Implementations are encouraged to provide such information as elapsed real time, machine run time, and storage management statistics. Affected By:: ............. The accuracy of the results depends, among other things, on the accuracy of the corresponding functions provided by the underlying operating system. The magnitude of the results may depend on the hardware, the operating system, the lisp implementation, and the state of the global environment. Some specific issues which frequently affect the outcome are hardware speed, nature of the scheduler (if any), number of competing processes (if any), system paging, whether the call is interpreted or compiled, whether functions called are compiled, the kind of garbage collector involved and whether it runs, whether internal data structures (e.g., hash tables) are implicitly reorganized, etc. See Also:: .......... *note get-internal-real-time:: , *note get-internal-run-time:: Notes:: ....... In general, these timings are not guaranteed to be reliable enough for marketing comparisons. Their value is primarily heuristic, for tuning purposes. For useful background information on the complicated issues involved in interpreting timing results, see Performance and Evaluation of Lisp Programs.  File: gcl.info, Node: internal-time-units-per-second, Next: get-internal-real-time, Prev: time, Up: Environment Dictionary 25.2.11 internal-time-units-per-second [Constant Variable] ---------------------------------------------------------- Constant Value:: ................ A positive integer, the magnitude of which is implementation-dependent. Description:: ............. The number of internal time units in one second. See Also:: .......... *note get-internal-run-time:: , *note get-internal-real-time:: Notes:: ....... These units form the basis of the Internal Time format representation.  File: gcl.info, Node: get-internal-real-time, Next: get-internal-run-time, Prev: internal-time-units-per-second, Up: Environment Dictionary 25.2.12 get-internal-real-time [Function] ----------------------------------------- 'get-internal-real-time' => internal-time Arguments and Values:: ...................... internal-time--a non-negative integer. Description:: ............. get-internal-real-time returns as an integer the current time in internal time units, relative to an arbitrary time base. The difference between the values of two calls to this function is the amount of elapsed real time (i.e., clock time) between the two calls. Affected By:: ............. Time of day (i.e., the passage of time). The time base affects the result magnitude. See Also:: .......... *note internal-time-units-per-second::  File: gcl.info, Node: get-internal-run-time, Next: disassemble, Prev: get-internal-real-time, Up: Environment Dictionary 25.2.13 get-internal-run-time [Function] ---------------------------------------- 'get-internal-run-time' => internal-time Arguments and Values:: ...................... internal-time--a non-negative integer. Description:: ............. Returns as an integer the current run time in internal time units. The precise meaning of this quantity is implementation-defined; it may measure real time, run time, CPU cycles, or some other quantity. The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which computational effort was expended on behalf of the executing program. Affected By:: ............. The implementation, the time of day (i.e., the passage of time). See Also:: .......... *note internal-time-units-per-second:: Notes:: ....... Depending on the implementation, paging time and garbage collection time might be included in this measurement. Also, in a multitasking environment, it might not be possible to show the time for just the running process, so in some implementations, time taken by other processes during the same time interval might be included in this measurement as well.  File: gcl.info, Node: disassemble, Next: documentation, Prev: get-internal-run-time, Up: Environment Dictionary 25.2.14 disassemble [Function] ------------------------------ 'disassemble' fn => nil Arguments and Values:: ...................... fn--an extended function designator or a lambda expression. Description:: ............. The function disassemble is a debugging aid that composes symbolic instructions or expressions in some implementation-dependent language which represent the code used to produce the function which is or is named by the argument fn. The result is displayed to standard output in an implementation-dependent format. If fn is a lambda expression or interpreted function, it is compiled first and the result is disassembled. If the fn designator is a function name, the function that it names is disassembled. (If that function is an interpreted function, it is first compiled but the result of this implicit compilation is not installed.) Examples:: .......... (defun f (a) (1+ a)) => F (eq (symbol-function 'f) (progn (disassemble 'f) (symbol-function 'f))) => true Affected By:: ............. *standard-output*. Exceptional Situations:: ........................ Should signal an error of type type-error if fn is not an extended function designator or a lambda expression.  File: gcl.info, Node: documentation, Next: room, Prev: disassemble, Up: Environment Dictionary 25.2.15 documentation, (setf documentation) [Standard Generic Function] ----------------------------------------------------------------------- Syntax:: ........ 'documentation' x doc-type => documentation '(setf documentation)' new-value x doc-type => new-value Argument Precedence Order:: ........................... doc-type, object Method Signatures:: ................... Functions, Macros, and Special Forms .................................... documentation (x 'function') (doc-type (eql 't)) (setf documentation) new-value(x 'function') (doc-type (eql 't)) documentation (x 'function') (doc-type (eql 'function)) (setf documentation) new-value(x 'function') (doc-type (eql 'function)) documentation (x 'list') (doc-type (eql 'function)) (setf documentation) new-value(x 'list') (doc-type (eql 'function)) documentation (x 'list') (doc-type (eql 'compiler-macro)) (setf documentation) new-value(x 'list') (doc-type (eql 'compiler-macro)) documentation (x 'symbol') (doc-type (eql 'function)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'function)) documentation (x 'symbol') (doc-type (eql 'compiler-macro)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'compiler-macro)) documentation (x 'symbol') (doc-type (eql 'setf)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'setf)) Method Combinations ................... documentation (x 'method-combination') (doc-type (eql 't)) (setf documentation) new-value(x 'method-combination') (doc-type (eql 't)) documentation (x 'method-combination') (doc-type (eql 'method-combination)) (setf documentation) new-value(x 'method-combination') (doc-type (eql 'method-combination)) documentation (x 'symbol') (doc-type (eql 'method-combination)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'method-combination)) Methods ....... documentation (x 'standard-method') (doc-type (eql 't)) (setf documentation) new-value(x 'standard-method') (doc-type (eql 't)) Packages ........ documentation (x 'package') (doc-type (eql 't)) (setf documentation) new-value(x 'package') (doc-type (eql 't)) Types, Classes, and Structure Names ................................... documentation (x 'standard-class') (doc-type (eql 't)) (setf documentation) new-value(x 'standard-class') (doc-type (eql 't)) documentation (x 'standard-class') (doc-type (eql 'type)) (setf documentation) new-value(x 'standard-class') (doc-type (eql 'type)) documentation (x 'structure-class') (doc-type (eql 't)) (setf documentation) new-value(x 'structure-class') (doc-type (eql 't)) documentation (x 'structure-class') (doc-type (eql 'type)) (setf documentation) new-value(x 'structure-class') (doc-type (eql 'type)) documentation (x 'symbol') (doc-type (eql 'type)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'type)) documentation (x 'symbol') (doc-type (eql 'structure)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'structure)) Variables ......... documentation (x 'symbol') (doc-type (eql 'variable)) (setf documentation) new-value(x 'symbol') (doc-type (eql 'variable)) Arguments and Values:: ...................... x--an object. doc-type--a symbol. documentation--a string, or nil. new-value--a string. Description:: ............. The generic function documentation returns the documentation string associated with the given object if it is available; otherwise it returns nil. The generic function (setf documentation) updates the documentation string associated with x to new-value. If x is a list, it must be of the form (setf symbol). Documentation strings are made available for debugging purposes. Conforming programs are permitted to use documentation strings when they are present, but should not depend for their correct behavior on the presence of those documentation strings. An implementation is permitted to discard documentation strings at any time for implementation-defined reasons. The nature of the documentation string returned depends on the doc-type, as follows: compiler-macro Returns the documentation string of the compiler macro whose name is the function name x. function If x is a function name, returns the documentation string of the function, macro, or special operator whose name is x. If x is a function, returns the documentation string associated with x. method-combination If x is a symbol, returns the documentation string of the method combination whose name is x. If x is a method combination, returns the documentation string associated with x. setf Returns the documentation string of the setf expander whose name is the symbol x. structure Returns the documentation string associated with the structure name x. t Returns a documentation string specialized on the class of the argument x itself. For example, if x is a function, the documentation string associated with the function x is returned. type If x is a symbol, returns the documentation string of the class whose name is the symbol x, if there is such a class. Otherwise, it returns the documentation string of the type which is the type specifier symbol x. If x is a structure class or standard class, returns the documentation string associated with the class x. variable Returns the documentation string of the dynamic variable or constant variable whose name is the symbol x. A conforming implementation or a conforming program may extend the set of symbols that are acceptable as the doc-type. Notes:: ....... This standard prescribes no means to retrieve the documentation strings for individual slots specified in a defclass form, but implementations might still provide debugging tools and/or programming language extensions which manipulate this information. Implementors wishing to provide such support are encouraged to consult the Metaobject Protocol for suggestions about how this might be done. gcl-2.6.14/info/chap-14.texi0000644000175000017500000034053014360276512013763 0ustar cammcamm @node Conses, Arrays, Characters, Top @chapter Conses @menu * Cons Concepts:: * Conses Dictionary:: @end menu @node Cons Concepts, Conses Dictionary, Conses, Conses @section Cons Concepts @c including concept-conses A @i{cons} @IGindex cons is a compound data @i{object} having two components called the @i{car} and the @i{cdr}. @format @group @noindent @w{ car cons rplacd } @w{ cdr rplaca } @noindent @w{ Figure 14--1: Some defined names relating to conses.} @end group @end format Depending on context, a group of connected @i{conses} can be viewed in a variety of different ways. A variety of operations is provided to support each of these various views. @menu * Conses as Trees:: * Conses as Lists:: @end menu @node Conses as Trees, Conses as Lists, Cons Concepts, Cons Concepts @subsection Conses as Trees A @i{tree} @IGindex tree is a binary recursive data structure made up of @i{conses} and @i{atoms}: the @i{conses} are themselves also @i{trees} (sometimes called ``subtrees'' or ``branches''), and the @i{atoms} are terminal nodes (sometimes called @i{leaves} @IGindex leaves ). Typically, the @i{leaves} represent data while the branches establish some relationship among that data. @format @group @noindent @w{ caaaar caddar cdar nsubst } @w{ caaadr cadddr cddaar nsubst-if } @w{ caaar caddr cddadr nsubst-if-not } @w{ caadar cadr cddar nthcdr } @w{ caaddr cdaaar cdddar sublis } @w{ caadr cdaadr cddddr subst } @w{ caar cdaar cdddr subst-if } @w{ cadaar cdadar cddr subst-if-not } @w{ cadadr cdaddr copy-tree tree-equal } @w{ cadar cdadr nsublis } @noindent @w{ Figure 14--2: Some defined names relating to trees.} @end group @end format @menu * General Restrictions on Parameters that must be Trees:: @end menu @node General Restrictions on Parameters that must be Trees, , Conses as Trees, Conses as Trees @subsubsection General Restrictions on Parameters that must be Trees Except as explicitly stated otherwise, for any @i{standardized} @i{function} that takes a @i{parameter} that is required to be a @i{tree}, the consequences are undefined if that @i{tree} is circular. @node Conses as Lists, , Conses as Trees, Cons Concepts @subsection Conses as Lists A @i{list} @IGindex list is a chain of @i{conses} in which the @i{car} of each @i{cons} is an @i{element} of the @i{list}, and the @i{cdr} of each @i{cons} is either the next link in the chain or a terminating @i{atom}. A @i{proper list} @IGindex proper list is a @i{list} terminated by the @i{empty list}. The @i{empty list} is a @i{proper list}, but is not a @i{cons}. An @i{improper list} @IGindex improper list is a @i{list} that is not a @i{proper list}; that is, it is a @i{circular list} or a @i{dotted list}. A @i{dotted list} @IGindex dotted list is a @i{list} that has a terminating @i{atom} that is not the @i{empty list}. A @i{non-nil} @i{atom} by itself is not considered to be a @i{list} of any kind---not even a @i{dotted list}. A @i{circular list} @IGindex circular list is a chain of @i{conses} that has no termination because some @i{cons} in the chain is the @i{cdr} of a later @i{cons}. @format @group @noindent @w{ append last nbutlast rest } @w{ butlast ldiff nconc revappend } @w{ copy-alist list ninth second } @w{ copy-list list* nreconc seventh } @w{ eighth list-length nth sixth } @w{ endp make-list nthcdr tailp } @w{ fifth member pop tenth } @w{ first member-if push third } @w{ fourth member-if-not pushnew } @noindent @w{ Figure 14--3: Some defined names relating to lists.} @end group @end format @menu * Lists as Association Lists:: * Lists as Sets:: * General Restrictions on Parameters that must be Lists:: @end menu @node Lists as Association Lists, Lists as Sets, Conses as Lists, Conses as Lists @subsubsection Lists as Association Lists An @i{association list} @IGindex association list is a @i{list} of @i{conses} representing an association of @i{keys} with @i{values}, where the @i{car} of each @i{cons} is the @i{key} and the @i{cdr} is the @i{value} associated with that @i{key}. @format @group @noindent @w{ acons assoc-if pairlis rassoc-if } @w{ assoc assoc-if-not rassoc rassoc-if-not } @noindent @w{ Figure 14--4: Some defined names related to assocation lists.} @end group @end format @node Lists as Sets, General Restrictions on Parameters that must be Lists, Lists as Association Lists, Conses as Lists @subsubsection Lists as Sets @i{Lists} are sometimes viewed as sets by considering their elements unordered and by assuming there is no duplication of elements. @format @group @noindent @w{ adjoin nset-difference set-difference union } @w{ intersection nset-exclusive-or set-exclusive-or } @w{ nintersection nunion subsetp } @noindent @w{ Figure 14--5: Some defined names related to sets. } @end group @end format @node General Restrictions on Parameters that must be Lists, , Lists as Sets, Conses as Lists @subsubsection General Restrictions on Parameters that must be Lists Except as explicitly specified otherwise, any @i{standardized} @i{function} that takes a @i{parameter} that is required to be a @i{list} should be prepared to signal an error of @i{type} @b{type-error} if the @i{value} received is a @i{dotted list}. Except as explicitly specified otherwise, for any @i{standardized} @i{function} that takes a @i{parameter} that is required to be a @i{list}, the consequences are undefined if that @i{list} is @i{circular}. @c end of including concept-conses @node Conses Dictionary, , Cons Concepts, Conses @section Conses Dictionary @c including dict-conses @menu * list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: * cons:: * consp:: * atom:: * rplaca:: * car:: * copy-tree:: * sublis:: * subst:: * tree-equal:: * copy-list:: * list (Function):: * list-length:: * listp:: * make-list:: * push:: * pop:: * first:: * nth:: * endp:: * null:: * nconc:: * append:: * revappend:: * butlast:: * last:: * ldiff:: * nthcdr:: * rest:: * member (Function):: * mapc:: * acons:: * assoc:: * copy-alist:: * pairlis:: * rassoc:: * get-properties:: * getf:: * remf:: * intersection:: * adjoin:: * pushnew:: * set-difference:: * set-exclusive-or:: * subsetp:: * union:: @end menu @node list (System Class), null (System Class), Conses Dictionary, Conses Dictionary @subsection list [System Class] @subsubheading Class Precedence List:: @b{list}, @b{sequence}, @b{t} @subsubheading Description:: A @i{list} @IGindex list is a chain of @i{conses} in which the @i{car} of each @i{cons} is an @i{element} of the @i{list}, and the @i{cdr} of each @i{cons} is either the next link in the chain or a terminating @i{atom}. A @i{proper list} @IGindex proper list is a chain of @i{conses} terminated by the @i{empty list} @IGindex empty list , @t{()}, which is itself a @i{proper list}. A @i{dotted list} @IGindex dotted list is a @i{list} which has a terminating @i{atom} that is not the @i{empty list}. A @i{circular list} @IGindex circular list is a chain of @i{conses} that has no termination because some @i{cons} in the chain is the @i{cdr} of a later @i{cons}. @i{Dotted lists} and @i{circular lists} are also @i{lists}, but usually the unqualified term ``list'' within this specification means @i{proper list}. Nevertheless, the @i{type} @b{list} unambiguously includes @i{dotted lists} and @i{circular lists}. For each @i{element} of a @i{list} there is a @i{cons}. The @i{empty list} has no @i{elements} and is not a @i{cons}. The @i{types} @b{cons} and @b{null} form an @i{exhaustive partition} of the @i{type} @b{list}. @subsubheading See Also:: @ref{Left-Parenthesis}, @ref{Printing Lists and Conses} @node null (System Class), cons (System Class), list (System Class), Conses Dictionary @subsection null [System Class] @subsubheading Class Precedence List:: @b{null}, @b{symbol}, @b{list}, @b{sequence}, @b{t} @subsubheading Description:: The only @i{object} of @i{type} @b{null} is @b{nil}, which represents the @i{empty list} and can also be notated @t{()}. @subsubheading See Also:: @ref{Symbols as Tokens}, @ref{Left-Parenthesis}, @ref{Printing Symbols} @node cons (System Class), atom (Type), null (System Class), Conses Dictionary @subsection cons [System Class] @subsubheading Class Precedence List:: @b{cons}, @b{list}, @b{sequence}, @b{t} @subsubheading Description:: A @i{cons} is a compound @i{object} having two components, called the @i{car} and @i{cdr}. These form a @i{dotted pair}. Each component can be any @i{object}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{cons}@{@i{@t{[}car-typespec @r{[}cdr-typespec@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{car-typespec}---a @i{type specifier}, or the @i{symbol} @b{*}. The default is the @i{symbol} @b{*}. @i{cdr-typespec}---a @i{type specifier}, or the @i{symbol} @b{*}. The default is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the set of @i{conses} whose @i{car} is constrained to be of @i{type} @i{car-typespec} and whose @i{cdr} is constrained to be of @i{type} @i{cdr-typespec}. (If either @i{car-typespec} or @i{cdr-typespec} is @b{*}, it is as if the @i{type} @b{t} had been denoted.) @subsubheading See Also:: @ref{Left-Parenthesis}, @ref{Printing Lists and Conses} @node atom (Type), cons, cons (System Class), Conses Dictionary @subsection atom [Type] @subsubheading Supertypes:: @b{atom}, @b{t} @subsubheading Description:: It is equivalent to @t{(not cons)}. @node cons, consp, atom (Type), Conses Dictionary @subsection cons [Function] @code{cons} @i{object-1 object-2} @result{} @i{cons} @subsubheading Arguments and Values:: @i{object-1}---an @i{object}. @i{object-2}---an @i{object}. @i{cons}---a @i{cons}. @subsubheading Description:: Creates a @i{fresh} @i{cons}, the @i{car} of which is @i{object-1} and the @i{cdr} of which is @i{object-2}. @subsubheading Examples:: @example (cons 1 2) @result{} (1 . 2) (cons 1 nil) @result{} (1) (cons nil 2) @result{} (NIL . 2) (cons nil nil) @result{} (NIL) (cons 1 (cons 2 (cons 3 (cons 4 nil)))) @result{} (1 2 3 4) (cons 'a 'b) @result{} (A . B) (cons 'a (cons 'b (cons 'c '@t{()}))) @result{} (A B C) (cons 'a '(b c d)) @result{} (A B C D) @end example @subsubheading See Also:: @ref{list (Function)} @subsubheading Notes:: If @i{object-2} is a @i{list}, @b{cons} can be thought of as producing a new @i{list} which is like it but has @i{object-1} prepended. @node consp, atom, cons, Conses Dictionary @subsection consp [Function] @code{consp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{cons}; otherwise, returns @i{false}. @subsubheading Examples:: @example (consp nil) @result{} @i{false} (consp (cons 1 2)) @result{} @i{true} @end example The @i{empty list} is not a @i{cons}, so @example (consp '()) @equiv{} (consp 'nil) @result{} @i{false} @end example @subsubheading See Also:: @ref{listp} @subsubheading Notes:: @example (consp @i{object}) @equiv{} (typep @i{object} 'cons) @equiv{} (not (typep @i{object} 'atom)) @equiv{} (typep @i{object} '(not atom)) @end example @node atom, rplaca, consp, Conses Dictionary @subsection atom [Function] @code{atom} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{atom}; otherwise, returns @i{false}. @subsubheading Examples:: @example (atom 'sss) @result{} @i{true} (atom (cons 1 2)) @result{} @i{false} (atom nil) @result{} @i{true} (atom '()) @result{} @i{true} (atom 3) @result{} @i{true} @end example @subsubheading Notes:: @example (atom @i{object}) @equiv{} (typep @i{object} 'atom) @equiv{} (not (consp @i{object})) @equiv{} (not (typep @i{object} 'cons)) @equiv{} (typep @i{object} '(not cons)) @end example @node rplaca, car, atom, Conses Dictionary @subsection rplaca, rplacd [Function] @code{rplaca} @i{cons object} @result{} @i{cons} @code{rplacd} @i{cons object} @result{} @i{cons} @subsubheading Pronunciation:: @b{rplaca}: pronounced ,r\=e 'plak e or pronounced ,re 'plak e @b{rplacd}: pronounced ,r\=e 'plak de or pronounced ,re 'plak de or pronounced ,r\=e 'plak d\=e or pronounced ,re 'plak d\=e @subsubheading Arguments and Values:: @i{cons}---a @i{cons}. @i{object}---an @i{object}. @subsubheading Description:: @b{rplaca} replaces the @i{car} of the @i{cons} with @i{object}. @b{rplacd} replaces the @i{cdr} of the @i{cons} with @i{object}. @subsubheading Examples:: @example (defparameter *some-list* (list* 'one 'two 'three 'four)) @result{} *some-list* *some-list* @result{} (ONE TWO THREE . FOUR) (rplaca *some-list* 'uno) @result{} (UNO TWO THREE . FOUR) *some-list* @result{} (UNO TWO THREE . FOUR) (rplacd (last *some-list*) (list 'IV)) @result{} (THREE IV) *some-list* @result{} (UNO TWO THREE IV) @end example @subsubheading Side Effects:: The @i{cons} is modified. Should signal an error of @i{type} @b{type-error} if @i{cons} is not a @i{cons}. @node car, copy-tree, rplaca, Conses Dictionary @subsection car, cdr, @subheading caar, cadr, cdar, cddr, @subheading caaar, caadr, cadar, caddr, cdaar, cdadr, cddar, cdddr, @subheading caaaar, caaadr, caadar, caaddr, cadaar, cadadr, caddar, cadddr, @subheading cdaaar, cdaadr, cdadar, cdaddr, cddaar, cddadr, cdddar, cddddr @flushright @i{[Accessor]} @end flushright @code{car} @i{x} @result{} @i{object} (setf (@code{car} @i{x}) new-object)@* @code{cdr} @i{x} @result{} @i{object} (setf (@code{cdr} @i{x}) new-object)@* @code{\vksip 5pt} @i{x} @result{} @i{object} (setf (@code{\vksip 5pt} @i{x}) new-object)@* @code{caar} @i{x} @result{} @i{object} (setf (@code{caar} @i{x}) new-object)@* @code{cadr} @i{x} @result{} @i{object} (setf (@code{cadr} @i{x}) new-object)@* @code{cdar} @i{x} @result{} @i{object} (setf (@code{cdar} @i{x}) new-object)@* @code{cddr} @i{x} @result{} @i{object} (setf (@code{cddr} @i{x}) new-object)@* @code{\vksip 5pt} @i{x} @result{} @i{object} (setf (@code{\vksip 5pt} @i{x}) new-object)@* @code{caaar} @i{x} @result{} @i{object} (setf (@code{caaar} @i{x}) new-object)@* @code{caadr} @i{x} @result{} @i{object} (setf (@code{caadr} @i{x}) new-object)@* @code{cadar} @i{x} @result{} @i{object} (setf (@code{cadar} @i{x}) new-object)@* @code{caddr} @i{x} @result{} @i{object} (setf (@code{caddr} @i{x}) new-object)@* @code{cdaar} @i{x} @result{} @i{object} (setf (@code{cdaar} @i{x}) new-object)@* @code{cdadr} @i{x} @result{} @i{object} (setf (@code{cdadr} @i{x}) new-object)@* @code{cddar} @i{x} @result{} @i{object} (setf (@code{cddar} @i{x}) new-object)@* @code{cdddr} @i{x} @result{} @i{object} (setf (@code{cdddr} @i{x}) new-object)@* @code{\vksip 5pt} @i{x} @result{} @i{object} (setf (@code{\vksip 5pt} @i{x}) new-object)@* @code{caaaar} @i{x} @result{} @i{object} (setf (@code{caaaar} @i{x}) new-object)@* @code{caaadr} @i{x} @result{} @i{object} (setf (@code{caaadr} @i{x}) new-object)@* @code{caadar} @i{x} @result{} @i{object} (setf (@code{caadar} @i{x}) new-object)@* @code{caaddr} @i{x} @result{} @i{object} (setf (@code{caaddr} @i{x}) new-object)@* @code{cadaar} @i{x} @result{} @i{object} (setf (@code{cadaar} @i{x}) new-object)@* @code{cadadr} @i{x} @result{} @i{object} (setf (@code{cadadr} @i{x}) new-object)@* @code{caddar} @i{x} @result{} @i{object} (setf (@code{caddar} @i{x}) new-object)@* @code{cadddr} @i{x} @result{} @i{object} (setf (@code{cadddr} @i{x}) new-object)@* @code{cdaaar} @i{x} @result{} @i{object} (setf (@code{cdaaar} @i{x}) new-object)@* @code{cdaadr} @i{x} @result{} @i{object} (setf (@code{cdaadr} @i{x}) new-object)@* @code{cdadar} @i{x} @result{} @i{object} (setf (@code{cdadar} @i{x}) new-object)@* @code{cdaddr} @i{x} @result{} @i{object} (setf (@code{cdaddr} @i{x}) new-object)@* @code{cddaar} @i{x} @result{} @i{object} (setf (@code{cddaar} @i{x}) new-object)@* @code{cddadr} @i{x} @result{} @i{object} (setf (@code{cddadr} @i{x}) new-object)@* @code{cdddar} @i{x} @result{} @i{object} (setf (@code{cdddar} @i{x}) new-object)@* @code{cddddr} @i{x} @result{} @i{object} (setf (@code{cddddr} @i{x}) new-object)@* @subsubheading Pronunciation:: @b{cadr}: pronounced 'ka ,de r @b{caddr}: pronounced 'kad e ,de r or pronounced 'ka ,dude r @b{cdr}: pronounced 'ku ,de r @b{cddr}: pronounced 'kud e ,de r or pronounced 'ke ,dude r @subsubheading Arguments and Values:: @i{x}---a @i{list}. @i{object}---an @i{object}. @i{new-object}---an @i{object}. @subsubheading Description:: If @i{x} is a @i{cons}, @b{car} returns the @i{car} of that @i{cons}. If @i{x} is @b{nil}, @b{car} returns @b{nil}. If @i{x} is a @i{cons}, @b{cdr} returns the @i{cdr} of that @i{cons}. If @i{x} is @b{nil}, @b{cdr} returns @b{nil}. @i{Functions} are provided which perform compositions of up to four @b{car} and @b{cdr} operations. Their @i{names} consist of a @t{C}, followed by two, three, or four occurrences of @t{A} or @t{D}, and finally an @t{R}. The series of @t{A}'s and @t{D}'s in each @i{function}'s @i{name} is chosen to identify the series of @b{car} and @b{cdr} operations that is performed by the function. The order in which the @t{A}'s and @t{D}'s appear is the inverse of the order in which the corresponding operations are performed. Figure 14--6 defines the relationships precisely. @format @group @noindent @w{ This @i{place} ... Is equivalent to this @i{place} ... } @w{ @t{(caar @i{x})} @t{(car (car @i{x}))} } @w{ @t{(cadr @i{x})} @t{(car (cdr @i{x}))} } @w{ @t{(cdar @i{x})} @t{(cdr (car @i{x}))} } @w{ @t{(cddr @i{x})} @t{(cdr (cdr @i{x}))} } @w{ @t{(caaar @i{x})} @t{(car (car (car @i{x})))} } @w{ @t{(caadr @i{x})} @t{(car (car (cdr @i{x})))} } @w{ @t{(cadar @i{x})} @t{(car (cdr (car @i{x})))} } @w{ @t{(caddr @i{x})} @t{(car (cdr (cdr @i{x})))} } @w{ @t{(cdaar @i{x})} @t{(cdr (car (car @i{x})))} } @w{ @t{(cdadr @i{x})} @t{(cdr (car (cdr @i{x})))} } @w{ @t{(cddar @i{x})} @t{(cdr (cdr (car @i{x})))} } @w{ @t{(cdddr @i{x})} @t{(cdr (cdr (cdr @i{x})))} } @w{ @t{(caaaar @i{x})} @t{(car (car (car (car @i{x}))))} } @w{ @t{(caaadr @i{x})} @t{(car (car (car (cdr @i{x}))))} } @w{ @t{(caadar @i{x})} @t{(car (car (cdr (car @i{x}))))} } @w{ @t{(caaddr @i{x})} @t{(car (car (cdr (cdr @i{x}))))} } @w{ @t{(cadaar @i{x})} @t{(car (cdr (car (car @i{x}))))} } @w{ @t{(cadadr @i{x})} @t{(car (cdr (car (cdr @i{x}))))} } @w{ @t{(caddar @i{x})} @t{(car (cdr (cdr (car @i{x}))))} } @w{ @t{(cadddr @i{x})} @t{(car (cdr (cdr (cdr @i{x}))))} } @w{ @t{(cdaaar @i{x})} @t{(cdr (car (car (car @i{x}))))} } @w{ @t{(cdaadr @i{x})} @t{(cdr (car (car (cdr @i{x}))))} } @w{ @t{(cdadar @i{x})} @t{(cdr (car (cdr (car @i{x}))))} } @w{ @t{(cdaddr @i{x})} @t{(cdr (car (cdr (cdr @i{x}))))} } @w{ @t{(cddaar @i{x})} @t{(cdr (cdr (car (car @i{x}))))} } @w{ @t{(cddadr @i{x})} @t{(cdr (cdr (car (cdr @i{x}))))} } @w{ @t{(cdddar @i{x})} @t{(cdr (cdr (cdr (car @i{x}))))} } @w{ @t{(cddddr @i{x})} @t{(cdr (cdr (cdr (cdr @i{x}))))} } @noindent @w{ Figure 14--6: CAR and CDR variants } @end group @end format @b{setf} can also be used with any of these functions to change an existing component of @i{x}, but @b{setf} will not make new components. So, for example, the @i{car} of a @i{cons} can be assigned with @b{setf} of @b{car}, but the @i{car} of @b{nil} cannot be assigned with @b{setf} of @b{car}. Similarly, the @i{car} of the @i{car} of a @i{cons} whose @i{car} is a @i{cons} can be assigned with @b{setf} of @b{caar}, but neither @b{nil} nor a @i{cons} whose car is @b{nil} can be assigned with @b{setf} of @b{caar}. The argument @i{x} is permitted to be a @i{dotted list} or a @i{circular list}. @subsubheading Examples:: @example (car nil) @result{} NIL (cdr '(1 . 2)) @result{} 2 (cdr '(1 2)) @result{} (2) (cadr '(1 2)) @result{} 2 (car '(a b c)) @result{} A (cdr '(a b c)) @result{} (B C) @end example @subsubheading Exceptional Situations:: The functions @b{car} and @b{cdr} should signal @b{type-error} if they receive an argument which is not a @i{list}. The other functions (@b{caar}, @b{cadr}, ... @b{cddddr}) should behave for the purpose of error checking as if defined by appropriate calls to @b{car} and @b{cdr}. @subsubheading See Also:: @ref{rplaca} , @ref{first} , @ref{rest} @subsubheading Notes:: The @i{car} of a @i{cons} can also be altered by using @b{rplaca}, and the @i{cdr} of a @i{cons} can be altered by using @b{rplacd}. @example (car @i{x}) @equiv{} (first @i{x}) (cadr @i{x}) @equiv{} (second @i{x}) @equiv{} (car (cdr @i{x})) (caddr @i{x}) @equiv{} (third @i{x}) @equiv{} (car (cdr (cdr @i{x}))) (cadddr @i{x}) @equiv{} (fourth @i{x}) @equiv{} (car (cdr (cdr (cdr @i{x})))) @end example @node copy-tree, sublis, car, Conses Dictionary @subsection copy-tree [Function] @code{copy-tree} @i{tree} @result{} @i{new-tree} @subsubheading Arguments and Values:: @i{tree}---a @i{tree}. @i{new-tree}---a @i{tree}. @subsubheading Description:: Creates a @i{copy} of a @i{tree} of @i{conses}. If @i{tree} is not a @i{cons}, it is returned; otherwise, the result is a new @i{cons} of the results of calling @b{copy-tree} on the @i{car} and @i{cdr} of @i{tree}. In other words, all @i{conses} in the @i{tree} represented by @i{tree} are copied recursively, stopping only when non-@i{conses} are encountered. @b{copy-tree} does not preserve circularities and the sharing of substructure. @subsubheading Examples:: @example (setq object (list (cons 1 "one") (cons 2 (list 'a 'b 'c)))) @result{} ((1 . "one") (2 A B C)) (setq object-too object) @result{} ((1 . "one") (2 A B C)) (setq copy-as-list (copy-list object)) (setq copy-as-alist (copy-alist object)) (setq copy-as-tree (copy-tree object)) (eq object object-too) @result{} @i{true} (eq copy-as-tree object) @result{} @i{false} (eql copy-as-tree object) @result{} @i{false} (equal copy-as-tree object) @result{} @i{true} (setf (first (cdr (second object))) "a" (car (second object)) "two" (car object) '(one . 1)) @result{} (ONE . 1) object @result{} ((ONE . 1) ("two" "a" B C)) object-too @result{} ((ONE . 1) ("two" "a" B C)) copy-as-list @result{} ((1 . "one") ("two" "a" B C)) copy-as-alist @result{} ((1 . "one") (2 "a" B C)) copy-as-tree @result{} ((1 . "one") (2 A B C)) @end example @subsubheading See Also:: @ref{tree-equal} @node sublis, subst, copy-tree, Conses Dictionary @subsection sublis, nsublis [Function] @code{sublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} @code{nsublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} @subsubheading Arguments and Values:: @i{alist}---an @i{association list}. @i{tree}---a @i{tree}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{new-tree}---a @i{tree}. @subsubheading Description:: @b{sublis} makes substitutions for @i{objects} in @i{tree} (a structure of @i{conses}). @b{nsublis} is like @b{sublis} but destructively modifies the relevant parts of the @i{tree}. @b{sublis} looks at all subtrees and leaves of @i{tree}; if a subtree or leaf appears as a key in @i{alist} (that is, the key and the subtree or leaf @i{satisfy the test}), it is replaced by the @i{object} with which that key is associated. This operation is non-destructive. In effect, @b{sublis} can perform several @b{subst} operations simultaneously. If @b{sublis} succeeds, a new copy of @i{tree} is returned in which each occurrence of such a subtree or leaf is replaced by the @i{object} with which it is associated. If no changes are made, the original tree is returned. The original @i{tree} is left unchanged, but the result tree may share cells with it. @b{nsublis} is permitted to modify @i{tree} but otherwise returns the same values as @b{sublis}. @subsubheading Examples:: @example (sublis '((x . 100) (z . zprime)) '(plus x (minus g z x p) 4 . x)) @result{} (PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100) (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y))) '(* (/ (+ x y) (+ x p)) (- x y)) :test #'equal) @result{} (* (/ (- X Y) (+ X P)) (+ X Y)) (setq tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4))))) @result{} (1 (1 2) ((1 2 3)) (((1 2 3 4)))) (sublis '((3 . "three")) tree1) @result{} (1 (1 2) ((1 2 "three")) (((1 2 "three" 4)))) (sublis '((t . "string")) (sublis '((1 . "") (4 . 44)) tree1) :key #'stringp) @result{} ("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44)))) tree1 @result{} (1 (1 2) ((1 2 3)) (((1 2 3 4)))) (setq tree2 '("one" ("one" "two") (("one" "Two" "three")))) @result{} ("one" ("one" "two") (("one" "Two" "three"))) (sublis '(("two" . 2)) tree2) @result{} ("one" ("one" "two") (("one" "Two" "three"))) tree2 @result{} ("one" ("one" "two") (("one" "Two" "three"))) (sublis '(("two" . 2)) tree2 :test 'equal) @result{} ("one" ("one" 2) (("one" "Two" "three"))) (nsublis '((t . 'temp)) tree1 :key #'(lambda (x) (or (atom x) (< (list-length x) 3)))) @result{} ((QUOTE TEMP) (QUOTE TEMP) QUOTE TEMP) @end example @subsubheading Side Effects:: @b{nsublis} modifies @i{tree}. @subsubheading See Also:: @ref{subst} , @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. Because the side-effecting variants (@i{e.g.}, @b{nsublis}) potentially change the path that is being traversed, their effects in the presence of shared or circular structure structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: @example (defun test-it (fn) (let* ((shared-piece (list 'a 'b)) (data (list shared-piece shared-piece))) (funcall fn '((a . b) (b . a)) data))) (test-it #'sublis) @result{} ((B A) (B A)) (test-it #'nsublis) @result{} ((A B) (A B)) @end example @node subst, tree-equal, sublis, Conses Dictionary @subsection subst, subst-if, subst-if-not, nsubst, nsubst-if, nsubst-if-not @flushright @i{[Function]} @end flushright @code{subst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} @code{subst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} @code{subst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} @code{nsubst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} @code{nsubst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} @code{nsubst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} @subsubheading Arguments and Values:: @i{new}---an @i{object}. @i{old}---an @i{object}. @i{predicate}---a @i{symbol} that names a @i{function}, or a @i{function} of one argument that returns a @i{generalized boolean} value. @i{tree}---a @i{tree}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{new-tree}---a @i{tree}. @subsubheading Description:: @b{subst}, @b{subst-if}, and @b{subst-if-not} perform substitution operations on @i{tree}. Each function searches @i{tree} for occurrences of a particular @i{old} item of an element or subexpression that @i{satisfies the test}. @b{nsubst}, @b{nsubst-if}, and @b{nsubst-if-not} are like @b{subst}, @b{subst-if}, and @b{subst-if-not} respectively, except that the original @i{tree} is modified. @b{subst} makes a copy of @i{tree}, substituting @i{new} for every subtree or leaf of @i{tree} (whether the subtree or leaf is a @i{car} or a @i{cdr} of its parent) such that @i{old} and the subtree or leaf @i{satisfy the test}. @b{nsubst} is a destructive version of @b{subst}. The list structure of @i{tree} is altered by destructively replacing with @i{new} each leaf of the @i{tree} such that @i{old} and the leaf @i{satisfy the test}. For @b{subst}, @b{subst-if}, and @b{subst-if-not}, if the functions succeed, a new copy of the tree is returned in which each occurrence of such an element is replaced by the @i{new} element or subexpression. If no changes are made, the original @i{tree} may be returned. The original @i{tree} is left unchanged, but the result tree may share storage with it. For @b{nsubst}, @b{nsubst-if}, and @b{nsubst-if-not} the original @i{tree} is modified and returned as the function result, but the result may not be @b{eq} to @i{tree}. @subsubheading Examples:: @example (setq tree1 '(1 (1 2) (1 2 3) (1 2 3 4))) @result{} (1 (1 2) (1 2 3) (1 2 3 4)) (subst "two" 2 tree1) @result{} (1 (1 "two") (1 "two" 3) (1 "two" 3 4)) (subst "five" 5 tree1) @result{} (1 (1 2) (1 2 3) (1 2 3 4)) (eq tree1 (subst "five" 5 tree1)) @result{} @i{implementation-dependent} (subst 'tempest 'hurricane '(shakespeare wrote (the hurricane))) @result{} (SHAKESPEARE WROTE (THE TEMPEST)) (subst 'foo 'nil '(shakespeare wrote (twelfth night))) @result{} (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO) (subst '(a . cons) '(old . pair) '((old . spice) ((old . shoes) old . pair) (old . pair)) :test #'equal) @result{} ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS)) (subst-if 5 #'listp tree1) @result{} 5 (subst-if-not '(x) #'consp tree1) @result{} (1 X) tree1 @result{} (1 (1 2) (1 2 3) (1 2 3 4)) (nsubst 'x 3 tree1 :key #'(lambda (y) (and (listp y) (third y)))) @result{} (1 (1 2) X X) tree1 @result{} (1 (1 2) X X) @end example @subsubheading Side Effects:: @b{nsubst}, @b{nsubst-if}, and @b{nsubst-if-not} might alter the @i{tree structure} of @i{tree}. @subsubheading See Also:: @ref{substitute} , @b{nsubstitute}, @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. The functions @b{subst-if-not} and @b{nsubst-if-not} are deprecated. One possible definition of @b{subst}: @example (defun subst (old new tree &rest x &key test test-not key) (cond ((satisfies-the-test old tree :test test :test-not test-not :key key) new) ((atom tree) tree) (t (let ((a (apply #'subst old new (car tree) x)) (d (apply #'subst old new (cdr tree) x))) (if (and (eql a (car tree)) (eql d (cdr tree))) tree (cons a d)))))) @end example @node tree-equal, copy-list, subst, Conses Dictionary @subsection tree-equal [Function] @code{tree-equal} @i{tree-1 tree-2 @r{&key} test test-not} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{tree-1}---a @i{tree}. @i{tree-2}---a @i{tree}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{tree-equal} tests whether two trees are of the same shape and have the same leaves. @b{tree-equal} returns @i{true} if @i{tree-1} and @i{tree-2} are both @i{atoms} and @i{satisfy the test}, or if they are both @i{conses} and the @i{car} of @i{tree-1} is @b{tree-equal} to the @i{car} of @i{tree-2} and the @i{cdr} of @i{tree-1} is @b{tree-equal} to the @i{cdr} of @i{tree-2}. Otherwise, @b{tree-equal} returns @i{false}. @b{tree-equal} recursively compares @i{conses} but not any other @i{objects} that have components. The first argument to the @t{:test} or @t{:test-not} function is @i{tree-1} or a @i{car} or @i{cdr} of @i{tree-1}; the second argument is @i{tree-2} or a @i{car} or @i{cdr} of @i{tree-2}. @subsubheading Examples:: @example (setq tree1 '(1 (1 2)) tree2 '(1 (1 2))) @result{} (1 (1 2)) (tree-equal tree1 tree2) @result{} @i{true} (eql tree1 tree2) @result{} @i{false} (setq tree1 '('a ('b 'c)) tree2 '('a ('b 'c))) @result{} ('a ('b 'c)) @result{} ((QUOTE A) ((QUOTE B) (QUOTE C))) (tree-equal tree1 tree2 :test 'eq) @result{} @i{true} @end example @subsubheading Exceptional Situations:: The consequences are undefined if both @i{tree-1} and @i{tree-2} are circular. @subsubheading See Also:: @ref{equal} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. @node copy-list, list (Function), tree-equal, Conses Dictionary @subsection copy-list [Function] @code{copy-list} @i{list} @result{} @i{copy} @subsubheading Arguments and Values:: @i{list}---a @i{proper list} or a @i{dotted list}. @i{copy}---a @i{list}. @subsubheading Description:: Returns a @i{copy} of @i{list}. If @i{list} is a @i{dotted list}, the resulting @i{list} will also be a @i{dotted list}. Only the @i{list structure} of @i{list} is copied; the @i{elements} of the resulting list are the @i{same} as the corresponding @i{elements} of the given @i{list}. @subsubheading Examples:: @example (setq lst (list 1 (list 2 3))) @result{} (1 (2 3)) (setq slst lst) @result{} (1 (2 3)) (setq clst (copy-list lst)) @result{} (1 (2 3)) (eq slst lst) @result{} @i{true} (eq clst lst) @result{} @i{false} (equal clst lst) @result{} @i{true} (rplaca lst "one") @result{} ("one" (2 3)) slst @result{} ("one" (2 3)) clst @result{} (1 (2 3)) (setf (caadr lst) "two") @result{} "two" lst @result{} ("one" ("two" 3)) slst @result{} ("one" ("two" 3)) clst @result{} (1 ("two" 3)) @end example @subsubheading Exceptional Situations:: The consequences are undefined if @i{list} is a @i{circular list}. @subsubheading See Also:: @ref{copy-alist} , @ref{copy-seq} , @ref{copy-tree} @subsubheading Notes:: The copy created is @b{equal} to @i{list}, but not @b{eq}. @node list (Function), list-length, copy-list, Conses Dictionary @subsection list, list* [Function] @code{list} @i{@r{&rest} objects} @result{} @i{list} @code{list*} @i{@r{&rest} objects^+} @result{} @i{result} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{list}---a @i{list}. @i{result}---an @i{object}. @subsubheading Description:: @b{list} returns a @i{list} containing the supplied @i{objects}. @b{list*} is like @b{list} except that the last @i{argument} to @b{list} becomes the @i{car} of the last @i{cons} constructed, while the last @i{argument} to @b{list*} becomes the @i{cdr} of the last @i{cons} constructed. Hence, any given call to @b{list*} always produces one fewer @i{conses} than a call to @b{list} with the same number of arguments. If the last @i{argument} to @b{list*} is a @i{list}, the effect is to construct a new @i{list} which is similar, but which has additional elements added to the front corresponding to the preceding @i{arguments} of @b{list*}. If @b{list*} receives only one @i{object}, that @i{object} is returned, regardless of whether or not it is a @i{list}. @subsubheading Examples:: @example (list 1) @result{} (1) (list* 1) @result{} 1 (setq a 1) @result{} 1 (list a 2) @result{} (1 2) '(a 2) @result{} (A 2) (list 'a 2) @result{} (A 2) (list* a 2) @result{} (1 . 2) (list) @result{} NIL ;@i{i.e.}, () (setq a '(1 2)) @result{} (1 2) (eq a (list* a)) @result{} @i{true} (list 3 4 'a (car '(b . c)) (+ 6 -2)) @result{} (3 4 A B 4) (list* 'a 'b 'c 'd) @equiv{} (cons 'a (cons 'b (cons 'c 'd))) @result{} (A B C . D) (list* 'a 'b 'c '(d e f)) @result{} (A B C D E F) @end example @subsubheading See Also:: @ref{cons} @subsubheading Notes:: @example (list* @i{x}) @equiv{} @i{x} @end example @node list-length, listp, list (Function), Conses Dictionary @subsection list-length [Function] @code{list-length} @i{list} @result{} @i{length} @subsubheading Arguments and Values:: @i{list}---a @i{proper list} or a @i{circular list}. @i{length}---a non-negative @i{integer}, or @b{nil}. @subsubheading Description:: Returns the @i{length} of @i{list} if @i{list} is a @i{proper list}. Returns @b{nil} if @i{list} is a @i{circular list}. @subsubheading Examples:: @example (list-length '(a b c d)) @result{} 4 (list-length '(a (b c) d)) @result{} 3 (list-length '()) @result{} 0 (list-length nil) @result{} 0 (defun circular-list (&rest elements) (let ((cycle (copy-list elements))) (nconc cycle cycle))) (list-length (circular-list 'a 'b)) @result{} NIL (list-length (circular-list 'a)) @result{} NIL (list-length (circular-list)) @result{} 0 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{list} is not a @i{proper list} or a @i{circular list}. @subsubheading See Also:: @ref{length} @subsubheading Notes:: @b{list-length} could be implemented as follows: @example (defun list-length (x) (do ((n 0 (+ n 2)) ;Counter. (fast x (cddr fast)) ;Fast pointer: leaps by 2. (slow x (cdr slow))) ;Slow pointer: leaps by 1. (nil) ;; If fast pointer hits the end, return the count. (when (endp fast) (return n)) (when (endp (cdr fast)) (return (+ n 1))) ;; If fast pointer eventually equals slow pointer, ;; then we must be stuck in a circular list. ;; (A deeper property is the converse: if we are ;; stuck in a circular list, then eventually the ;; fast pointer will equal the slow pointer. ;; That fact justifies this implementation.) (when (and (eq fast slow) (> n 0)) (return nil)))) @end example @node listp, make-list, list-length, Conses Dictionary @subsection listp [Function] @code{listp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{list}; otherwise, returns @i{false}. @subsubheading Examples:: @example (listp nil) @result{} @i{true} (listp (cons 1 2)) @result{} @i{true} (listp (make-array 6)) @result{} @i{false} (listp t) @result{} @i{false} @end example @subsubheading See Also:: @ref{consp} @subsubheading Notes:: If @i{object} is a @i{cons}, @b{listp} does not check whether @i{object} is a @i{proper list}; it returns @i{true} for any kind of @i{list}. @example (listp @i{object}) @equiv{} (typep @i{object} 'list) @equiv{} (typep @i{object} '(or cons null)) @end example @node make-list, push, listp, Conses Dictionary @subsection make-list [Function] @code{make-list} @i{size @r{&key} initial-element} @result{} @i{list} @subsubheading Arguments and Values:: @i{size}---a non-negative @i{integer}. @i{initial-element}---an @i{object}. The default is @b{nil}. @i{list}---a @i{list}. @subsubheading Description:: Returns a @i{list} of @i{length} given by @i{size}, each of the @i{elements} of which is @i{initial-element}. @subsubheading Examples:: @example (make-list 5) @result{} (NIL NIL NIL NIL NIL) (make-list 3 :initial-element 'rah) @result{} (RAH RAH RAH) (make-list 2 :initial-element '(1 2 3)) @result{} ((1 2 3) (1 2 3)) (make-list 0) @result{} NIL ;@i{i.e.}, () (make-list 0 :initial-element 'new-element) @result{} NIL @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{size} is not a non-negative @i{integer}. @subsubheading See Also:: @ref{cons} , @ref{list (Function)} @node push, pop, make-list, Conses Dictionary @subsection push [Macro] @code{push} @i{item place} @result{} @i{new-place-value} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{place}---a @i{place}, the @i{value} of which may be any @i{object}. @i{new-place-value}---a @i{list} (the new @i{value} of @i{place}). @subsubheading Description:: @b{push} prepends @i{item} to the @i{list} that is stored in @i{place}, stores the resulting @i{list} in @i{place}, and returns the @i{list}. For information about the @i{evaluation} of @i{subforms} of @i{place}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (setq llst '(nil)) @result{} (NIL) (push 1 (car llst)) @result{} (1) llst @result{} ((1)) (push 1 (car llst)) @result{} (1 1) llst @result{} ((1 1)) (setq x '(a (b c) d)) @result{} (A (B C) D) (push 5 (cadr x)) @result{} (5 B C) x @result{} (A (5 B C) D) @end example @subsubheading Side Effects:: The contents of @i{place} are modified. @subsubheading See Also:: @ref{pop} , @ref{pushnew} , @ref{Generalized Reference} @subsubheading Notes:: The effect of @t{(push @i{item} @i{place})} is equivalent to @example (setf place (cons @i{item} @i{place})) @end example except that the @i{subforms} of @i{place} are evaluated only once, and @i{item} is evaluated before @i{place}. @node pop, first, push, Conses Dictionary @subsection pop [Macro] @code{pop} @i{place} @result{} @i{element} @subsubheading Arguments and Values:: @i{place}---a @i{place}, the @i{value} of which is a @i{list} (possibly, but necessarily, a @i{dotted list} or @i{circular list}). @i{element}---an @i{object} (the @i{car} of the contents of @i{place}). @subsubheading Description:: @b{pop} @i{reads} the @i{value} of @i{place}, remembers the @i{car} of the @i{list} which was retrieved, @i{writes} the @i{cdr} of the @i{list} back into the @i{place}, and finally @i{yields} the @i{car} of the originally retrieved @i{list}. For information about the @i{evaluation} of @i{subforms} of @i{place}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (setq stack '(a b c)) @result{} (A B C) (pop stack) @result{} A stack @result{} (B C) (setq llst '((1 2 3 4))) @result{} ((1 2 3 4)) (pop (car llst)) @result{} 1 llst @result{} ((2 3 4)) @end example @subsubheading Side Effects:: The contents of @i{place} are modified. @subsubheading See Also:: @ref{push} , @ref{pushnew} , @ref{Generalized Reference} @subsubheading Notes:: The effect of @t{(pop @i{place})} is roughly equivalent to @example (prog1 (car @i{place}) (setf @i{place} (cdr @i{place}))) @end example except that the latter would evaluate any @i{subforms} of @i{place} three times, while @b{pop} evaluates them only once. @node first, nth, pop, Conses Dictionary @subsection first, second, third, fourth, fifth, @subheading sixth, seventh, eighth, ninth, tenth @flushright @i{[Accessor]} @end flushright @code{first} @i{list} @result{} @i{object} (setf (@code{first} @i{list}) new-object)@* @code{second} @i{list} @result{} @i{object} (setf (@code{second} @i{list}) new-object)@* @code{third} @i{list} @result{} @i{object} (setf (@code{third} @i{list}) new-object)@* @code{fourth} @i{list} @result{} @i{object} (setf (@code{fourth} @i{list}) new-object)@* @code{fifth} @i{list} @result{} @i{object} (setf (@code{fifth} @i{list}) new-object)@* @code{sixth} @i{list} @result{} @i{object} (setf (@code{sixth} @i{list}) new-object)@* @code{seventh} @i{list} @result{} @i{object} (setf (@code{seventh} @i{list}) new-object)@* @code{eighth} @i{list} @result{} @i{object} (setf (@code{eighth} @i{list}) new-object)@* @code{ninth} @i{list} @result{} @i{object} (setf (@code{ninth} @i{list}) new-object)@* @code{tenth} @i{list} @result{} @i{object} (setf (@code{tenth} @i{list}) new-object)@* @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list} or a @i{circular list}. @i{object}, @i{new-object}---an @i{object}. @subsubheading Description:: The functions @b{first}, @b{second}, @b{third}, @b{fourth}, @b{fifth}, @b{sixth}, @b{seventh}, @b{eighth}, @b{ninth}, and @b{tenth} @i{access} the first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, and tenth @i{elements} of @i{list}, respectively. Specifically, @example (first @i{list}) @equiv{} (car @i{list}) (second @i{list}) @equiv{} (car (cdr @i{list})) (third @i{list}) @equiv{} (car (cddr @i{list})) (fourth @i{list}) @equiv{} (car (cdddr @i{list})) (fifth @i{list}) @equiv{} (car (cddddr @i{list})) (sixth @i{list}) @equiv{} (car (cdr (cddddr @i{list}))) (seventh @i{list}) @equiv{} (car (cddr (cddddr @i{list}))) (eighth @i{list}) @equiv{} (car (cdddr (cddddr @i{list}))) (ninth @i{list}) @equiv{} (car (cddddr (cddddr @i{list}))) (tenth @i{list}) @equiv{} (car (cdr (cddddr (cddddr @i{list})))) @end example @b{setf} can also be used with any of these functions to change an existing component. The same equivalences apply. For example: @example (setf (fifth @i{list}) @i{new-object}) @equiv{} (setf (car (cddddr @i{list})) @i{new-object}) @end example @subsubheading Examples:: @example (setq lst '(1 2 3 (4 5 6) ((V)) vi 7 8 9 10)) @result{} (1 2 3 (4 5 6) ((V)) VI 7 8 9 10) (first lst) @result{} 1 (tenth lst) @result{} 10 (fifth lst) @result{} ((V)) (second (fourth lst)) @result{} 5 (sixth '(1 2 3)) @result{} NIL (setf (fourth lst) "four") @result{} "four" lst @result{} (1 2 3 "four" ((V)) VI 7 8 9 10) @end example @subsubheading See Also:: @ref{car} , @ref{nth} @subsubheading Notes:: @b{first} is functionally equivalent to @b{car}, @b{second} is functionally equivalent to @b{cadr}, @b{third} is functionally equivalent to @b{caddr}, and @b{fourth} is functionally equivalent to @b{cadddr}. The ordinal numbering used here is one-origin, as opposed to the zero-origin numbering used by @b{nth}: @example (fifth x) @equiv{} (nth 4 x) @end example @node nth, endp, first, Conses Dictionary @subsection nth [Accessor] @code{nth} @i{n list} @result{} @i{object} (setf (@code{ nth} @i{n list}) new-object)@* @subsubheading Arguments and Values:: @i{n}---a non-negative @i{integer}. @i{list}---a @i{list}, which might be a @i{dotted list} or a @i{circular list}. @i{object}---an @i{object}. @i{new-object}---an @i{object}. @subsubheading Description:: @b{nth} locates the @i{n}th element of @i{list}, where the @i{car} of the @i{list} is the ``zeroth'' element. Specifically, @example (nth @i{n} @i{list}) @equiv{} (car (nthcdr @i{n} @i{list})) @end example @b{nth} may be used to specify a @i{place} to @b{setf}. Specifically, @example (setf (nth @i{n} @i{list}) @i{new-object}) @equiv{} (setf (car (nthcdr @i{n} @i{list})) @i{new-object}) @end example @subsubheading Examples:: @example (nth 0 '(foo bar baz)) @result{} FOO (nth 1 '(foo bar baz)) @result{} BAR (nth 3 '(foo bar baz)) @result{} NIL (setq 0-to-3 (list 0 1 2 3)) @result{} (0 1 2 3) (setf (nth 2 0-to-3) "two") @result{} "two" 0-to-3 @result{} (0 1 "two" 3) @end example @subsubheading See Also:: @ref{elt} , @ref{first} , @ref{nthcdr} @node endp, null, nth, Conses Dictionary @subsection endp [Function] @code{endp} @i{list} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list} or a @i{circular list}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{list} is the @i{empty list}. Returns @i{false} if @i{list} is a @i{cons}. @subsubheading Examples:: @example (endp nil) @result{} @i{true} (endp '(1 2)) @result{} @i{false} (endp (cddr '(1 2))) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{list} is not a @i{list}. @subsubheading Notes:: The purpose of @b{endp} is to test for the end of @i{proper list}. Since @b{endp} does not descend into a @i{cons}, it is well-defined to pass it a @i{dotted list}. However, if shorter ``lists'' are iteratively produced by calling @b{cdr} on such a @i{dotted list} and those ``lists'' are tested with @b{endp}, a situation that has undefined consequences will eventually result when the @i{non-nil} @i{atom} (which is not in fact a @i{list}) finally becomes the argument to @b{endp}. Since this is the usual way in which @b{endp} is used, it is conservative programming style and consistent with the intent of @b{endp} to treat @b{endp} as simply a function on @i{proper lists} which happens not to enforce an argument type of @i{proper list} except when the argument is @i{atomic}. @node null, nconc, endp, Conses Dictionary @subsection null [Function] @code{null} @i{object} @result{} @i{boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{boolean}---a @i{boolean}. @subsubheading Description:: Returns @b{t} if @i{object} is the @i{empty list}; otherwise, returns @b{nil}. @subsubheading Examples:: @example (null '()) @result{} T (null nil) @result{} T (null t) @result{} NIL (null 1) @result{} NIL @end example @subsubheading See Also:: @ref{not} @subsubheading Notes:: @b{null} is intended to be used to test for the @i{empty list} whereas @b{not} is intended to be used to invert a @i{boolean} (or @i{generalized boolean}). Operationally, @b{null} and @b{not} compute the same result; which to use is a matter of style. @example (null @i{object}) @equiv{} (typep @i{object} 'null) @equiv{} (eq @i{object} '@t{()}) @end example @node nconc, append, null, Conses Dictionary @subsection nconc [Function] @code{nconc} @i{@r{&rest} lists} @result{} @i{concatenated-list} @subsubheading Arguments and Values:: @i{list}---each but the last must be a @i{list} (which might be a @i{dotted list} but must not be a @i{circular list}); the last @i{list} may be any @i{object}. @i{concatenated-list}---a @i{list}. @subsubheading Description:: Returns a @i{list} that is the concatenation of @i{lists}. If no @i{lists} are supplied, @t{(nconc)} returns @b{nil}. @b{nconc} is defined using the following recursive relationship: @example (nconc) @result{} () (nconc nil . @i{lists}) @equiv{} (nconc . @i{lists}) (nconc @i{list}) @result{} @i{list} (nconc @i{list-1} @i{list-2}) @equiv{} (progn (rplacd (last @i{list-1}) @i{list-2}) @i{list-1}) (nconc @i{list-1} @i{list-2} . @i{lists}) @equiv{} (nconc (nconc @i{list-1} @i{list-2}) . @i{lists}) @end example @subsubheading Examples:: @example (nconc) @result{} NIL (setq x '(a b c)) @result{} (A B C) (setq y '(d e f)) @result{} (D E F) (nconc x y) @result{} (A B C D E F) x @result{} (A B C D E F) @end example Note, in the example, that the value of @t{x} is now different, since its last @i{cons} has been @b{rplacd}'d to the value of @t{y}. If @t{(nconc x y)} were evaluated again, it would yield a piece of a @i{circular list}, whose printed representation would be @t{(A B C D E F D E F D E F ...)}, repeating forever; if the @b{*print-circle*} switch were @i{non-nil}, it would be printed as @t{(A B C . #1=(D E F . #1#))}. @example (setq foo (list 'a 'b 'c 'd 'e) bar (list 'f 'g 'h 'i 'j) baz (list 'k 'l 'm)) @result{} (K L M) (setq foo (nconc foo bar baz)) @result{} (A B C D E F G H I J K L M) foo @result{} (A B C D E F G H I J K L M) bar @result{} (F G H I J K L M) baz @result{} (K L M) (setq foo (list 'a 'b 'c 'd 'e) bar (list 'f 'g 'h 'i 'j) baz (list 'k 'l 'm)) @result{} (K L M) (setq foo (nconc nil foo bar nil baz)) @result{} (A B C D E F G H I J K L M) foo @result{} (A B C D E F G H I J K L M) bar @result{} (F G H I J K L M) baz @result{} (K L M) @end example @subsubheading Side Effects:: The @i{lists} are modified rather than copied. @subsubheading See Also:: @ref{append} , @ref{concatenate} @node append, revappend, nconc, Conses Dictionary @subsection append [Function] @code{append} @i{@r{&rest} lists} @result{} @i{result} @subsubheading Arguments and Values:: @i{list}---each must be a @i{proper list} except the last, which may be any @i{object}. @i{result}---an @i{object}. This will be a @i{list} unless the last @i{list} was not a @i{list} and all preceding @i{lists} were @i{null}. @subsubheading Description:: @b{append} returns a new @i{list} that is the concatenation of the copies. @i{lists} are left unchanged; the @i{list structure} of each of @i{lists} except the last is copied. The last argument is not copied; it becomes the @i{cdr} of the final @i{dotted pair} of the concatenation of the preceding @i{lists}, or is returned directly if there are no preceding @i{non-empty} @i{lists}. @subsubheading Examples:: @example (append '(a b c) '(d e f) '() '(g)) @result{} (A B C D E F G) (append '(a b c) 'd) @result{} (A B C . D) (setq lst '(a b c)) @result{} (A B C) (append lst '(d)) @result{} (A B C D) lst @result{} (A B C) (append) @result{} NIL (append 'a) @result{} A @end example @subsubheading See Also:: @ref{nconc} , @ref{concatenate} @node revappend, butlast, append, Conses Dictionary @subsection revappend, nreconc [Function] @code{revappend} @i{list tail} @result{} @i{result-list} @code{nreconc} @i{list tail} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list}---a @i{proper list}. @i{tail}---an @i{object}. @i{result-list}---an @i{object}. @subsubheading Description:: @b{revappend} constructs a @i{copy}_2 of @i{list}, but with the @i{elements} in reverse order. It then appends (as if by @b{nconc}) the @i{tail} to that reversed list and returns the result. @b{nreconc} reverses the order of @i{elements} in @i{list} (as if by @b{nreverse}). It then appends (as if by @b{nconc}) the @i{tail} to that reversed list and returns the result. The resulting @i{list} shares @i{list structure} with @i{tail}. @subsubheading Examples:: @example (let ((list-1 (list 1 2 3)) (list-2 (list 'a 'b 'c))) (print (revappend list-1 list-2)) (print (equal list-1 '(1 2 3))) (print (equal list-2 '(a b c)))) @t{ |> } (3 2 1 A B C) @t{ |> } T @t{ |> } T @result{} T (revappend '(1 2 3) '()) @result{} (3 2 1) (revappend '(1 2 3) '(a . b)) @result{} (3 2 1 A . B) (revappend '() '(a b c)) @result{} (A B C) (revappend '(1 2 3) 'a) @result{} (3 2 1 . A) (revappend '() 'a) @result{} A ;degenerate case (let ((list-1 '(1 2 3)) (list-2 '(a b c))) (print (nreconc list-1 list-2)) (print (equal list-1 '(1 2 3))) (print (equal list-2 '(a b c)))) @t{ |> } (3 2 1 A B C) @t{ |> } NIL @t{ |> } T @result{} T @end example @subsubheading Side Effects:: @b{revappend} does not modify either of its @i{arguments}. @b{nreconc} is permitted to modify @i{list} but not @i{tail}. Although it might be implemented differently, @b{nreconc} is constrained to have side-effect behavior equivalent to: @example (nconc (nreverse @i{list}) @i{tail}) @end example @subsubheading See Also:: @ref{reverse} , @b{nreverse}, @ref{nconc} @subsubheading Notes:: The following functional equivalences are true, although good @i{implementations} will typically use a faster algorithm for achieving the same effect: @example (revappend @i{list} @i{tail}) @equiv{} (nconc (reverse @i{list}) @i{tail}) (nreconc @i{list} @i{tail}) @equiv{} (nconc (nreverse @i{list}) @i{tail}) @end example @node butlast, last, revappend, Conses Dictionary @subsection butlast, nbutlast [Function] @code{butlast} @i{list @r{&optional} n} @result{} @i{result-list} @code{nbutlast} @i{list @r{&optional} n} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list} but must not be a @i{circular list}. @i{n}---a non-negative @i{integer}. @i{result-list}---a @i{list}. @subsubheading Description:: @b{butlast} returns a copy of @i{list} from which the last @i{n} conses have been omitted. If @i{n} is not supplied, its value is 1. If there are fewer than @i{n} conses in @i{list}, @b{nil} is returned and, in the case of @b{nbutlast}, @i{list} is not modified. @b{nbutlast} is like @b{butlast}, but @b{nbutlast} may modify @i{list}. It changes the @i{cdr} of the @i{cons} @i{n}+1 from the end of the @i{list} to @b{nil}. @subsubheading Examples:: @example (setq lst '(1 2 3 4 5 6 7 8 9)) @result{} (1 2 3 4 5 6 7 8 9) (butlast lst) @result{} (1 2 3 4 5 6 7 8) (butlast lst 5) @result{} (1 2 3 4) (butlast lst (+ 5 5)) @result{} NIL lst @result{} (1 2 3 4 5 6 7 8 9) (nbutlast lst 3) @result{} (1 2 3 4 5 6) lst @result{} (1 2 3 4 5 6) (nbutlast lst 99) @result{} NIL lst @result{} (1 2 3 4 5 6) (butlast '(a b c d)) @result{} (A B C) (butlast '((a b) (c d))) @result{} ((A B)) (butlast '(a)) @result{} NIL (butlast nil) @result{} NIL (setq foo (list 'a 'b 'c 'd)) @result{} (A B C D) (nbutlast foo) @result{} (A B C) foo @result{} (A B C) (nbutlast (list 'a)) @result{} NIL (nbutlast '()) @result{} NIL @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{list} is not a @i{proper list} or a @i{dotted list}. Should signal an error of @i{type} @b{type-error} if @i{n} is not a non-negative @i{integer}. @subsubheading Notes:: @example (butlast @i{list} @i{n}) @equiv{} (ldiff @i{list} (last @i{list} @i{n})) @end example @node last, ldiff, butlast, Conses Dictionary @subsection last [Function] @code{last} @i{list @r{&optional} n} @result{} @i{tail} @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list} but must not be a @i{circular list}. @i{n}---a non-negative @i{integer}. The default is @t{1}. @i{tail}---an @i{object}. @subsubheading Description:: @b{last} returns the last @i{n} @i{conses} (not the last @i{n} elements) of @i{list}). If @i{list} is @t{()}, @b{last} returns @t{()}. If @i{n} is zero, the atom that terminates @i{list} is returned. If @i{n} is greater than or equal to the number of @i{cons} cells in @i{list}, the result is @i{list}. @subsubheading Examples:: @example (last nil) @result{} NIL (last '(1 2 3)) @result{} (3) (last '(1 2 . 3)) @result{} (2 . 3) (setq x (list 'a 'b 'c 'd)) @result{} (A B C D) (last x) @result{} (D) (rplacd (last x) (list 'e 'f)) x @result{} (A B C D E F) (last x) @result{} (F) (last '(a b c)) @result{} (C) (last '(a b c) 0) @result{} () (last '(a b c) 1) @result{} (C) (last '(a b c) 2) @result{} (B C) (last '(a b c) 3) @result{} (A B C) (last '(a b c) 4) @result{} (A B C) (last '(a . b) 0) @result{} B (last '(a . b) 1) @result{} (A . B) (last '(a . b) 2) @result{} (A . B) @end example @subsubheading Exceptional Situations:: The consequences are undefined if @i{list} is a @i{circular list}. Should signal an error of @i{type} @b{type-error} if @i{n} is not a non-negative @i{integer}. @subsubheading See Also:: @ref{butlast} , @ref{nth} @subsubheading Notes:: The following code could be used to define @b{last}. @example (defun last (list &optional (n 1)) (check-type n (integer 0)) (do ((l list (cdr l)) (r list) (i 0 (+ i 1))) ((atom l) r) (if (>= i n) (pop r)))) @end example @node ldiff, nthcdr, last, Conses Dictionary @subsection ldiff, tailp [Function] @code{ldiff} @i{list object} @result{} @i{result-list} @code{tailp} @i{object list} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list}. @i{object}---an @i{object}. @i{result-list}---a @i{list}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: If @i{object} is the @i{same} as some @i{tail} of @i{list}, @b{tailp} returns @i{true}; otherwise, it returns @i{false}. If @i{object} is the @i{same} as some @i{tail} of @i{list}, @b{ldiff} returns a @i{fresh} @i{list} of the @i{elements} of @i{list} that precede @b{object} in the @i{list structure} of @i{list}; otherwise, it returns a @i{copy}_2 of @i{list}. @subsubheading Examples:: @example (let ((lists '#((a b c) (a b c . d)))) (dotimes (i (length lists)) () (let ((list (aref lists i))) (format t "~2&list=~S ~21T(tailp object list)~ ~44T(ldiff list object)~ (let ((objects (vector list (cddr list) (copy-list (cddr list)) '(f g h) '() 'd 'x))) (dotimes (j (length objects)) () (let ((object (aref objects j))) (format t "~& object=~S ~21T~S ~44T~S" object (tailp object list) (ldiff list object)))))))) @t{ |> } @t{ |> } list=(A B C) (tailp object list) (ldiff list object) @t{ |> } object=(A B C) T NIL @t{ |> } object=(C) T (A B) @t{ |> } object=(C) NIL (A B C) @t{ |> } object=(F G H) NIL (A B C) @t{ |> } object=NIL T (A B C) @t{ |> } object=D NIL (A B C) @t{ |> } object=X NIL (A B C) @t{ |> } @t{ |> } list=(A B C . D) (tailp object list) (ldiff list object) @t{ |> } object=(A B C . D) T NIL @t{ |> } object=(C . D) T (A B) @t{ |> } object=(C . D) NIL (A B C . D) @t{ |> } object=(F G H) NIL (A B C . D) @t{ |> } object=NIL NIL (A B C . D) @t{ |> } object=D T (A B C) @t{ |> } object=X NIL (A B C . D) @result{} NIL @end example @subsubheading Side Effects:: Neither @b{ldiff} nor @b{tailp} modifies either of its @i{arguments}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list} is not a @i{proper list} or a @i{dotted list}. @subsubheading See Also:: @ref{set-difference} @subsubheading Notes:: If the @i{list} is a @i{circular list}, @b{tailp} will reliably @i{yield} a @i{value} only if the given @i{object} is in fact a @i{tail} of @i{list}. Otherwise, the consequences are unspecified: a given @i{implementation} which detects the circularity must return @i{false}, but since an @i{implementation} is not obliged to detect such a @i{situation}, @b{tailp} might just loop indefinitely without returning in that case. @b{tailp} could be defined as follows: @example (defun tailp (object list) (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) (return t)))) @end example and @b{ldiff} could be defined by: @example (defun ldiff (list object) (do ((list list (cdr list)) (r '() (cons (car list) r))) ((atom list) (if (eql list object) (nreverse r) (nreconc r list))) (when (eql object list) (return (nreverse r))))) @end example @node nthcdr, rest, ldiff, Conses Dictionary @subsection nthcdr [Function] @code{nthcdr} @i{n list} @result{} @i{tail} @subsubheading Arguments and Values:: @i{n}---a non-negative @i{integer}. @i{list}---a @i{list}, which might be a @i{dotted list} or a @i{circular list}. @i{tail}---an @i{object}. @subsubheading Description:: Returns the @i{tail} of @i{list} that would be obtained by calling @b{cdr} @i{n} times in succession. @subsubheading Examples:: @example (nthcdr 0 '()) @result{} NIL (nthcdr 3 '()) @result{} NIL (nthcdr 0 '(a b c)) @result{} (A B C) (nthcdr 2 '(a b c)) @result{} (C) (nthcdr 4 '(a b c)) @result{} () (nthcdr 1 '(0 . 1)) @result{} 1 (locally (declare (optimize (safety 3))) (nthcdr 3 '(0 . 1))) Error: Attempted to take CDR of 1. @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{n} is not a non-negative @i{integer}. For @i{n} being an integer greater than @t{1}, the error checking done by @t{(nthcdr @i{n} @i{list})} is the same as for @t{(nthcdr (- @i{n} 1) (cdr @i{list}))}; see the @i{function} @b{cdr}. @subsubheading See Also:: @b{cdr}, @ref{nth} , @ref{rest} @node rest, member (Function), nthcdr, Conses Dictionary @subsection rest [Accessor] @code{rest} @i{list} @result{} @i{tail} (setf (@code{ rest} @i{list}) new-tail)@* @subsubheading Arguments and Values:: @i{list}---a @i{list}, which might be a @i{dotted list} or a @i{circular list}. @i{tail}---an @i{object}. @subsubheading Description:: @b{rest} performs the same operation as @b{cdr}, but mnemonically complements @b{first}. Specifically, @example (rest @i{list}) @equiv{} (cdr @i{list}) (setf (rest @i{list}) @i{new-tail}) @equiv{} (setf (cdr @i{list}) @i{new-tail}) @end example @subsubheading Examples:: @example (rest '(1 2)) @result{} (2) (rest '(1 . 2)) @result{} 2 (rest '(1)) @result{} NIL (setq *cons* '(1 . 2)) @result{} (1 . 2) (setf (rest *cons*) "two") @result{} "two" *cons* @result{} (1 . "two") @end example @subsubheading See Also:: @b{cdr}, @ref{nthcdr} @subsubheading Notes:: @b{rest} is often preferred stylistically over @b{cdr} when the argument is to being subjectively viewed as a @i{list} rather than as a @i{cons}. @node member (Function), mapc, rest, Conses Dictionary @subsection member, member-if, member-if-not [Function] @code{member} @i{item list @r{&key} key test test-not} @result{} @i{tail} @code{member-if} @i{predicate list @r{&key} key} @result{} @i{tail} @code{member-if-not} @i{predicate list @r{&key} key} @result{} @i{tail} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{list}---a @i{proper list}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{tail}---a @i{list}. @subsubheading Description:: @b{member}, @b{member-if}, and @b{member-if-not} each search @i{list} for @i{item} or for a top-level element that @i{satisfies the test}. The argument to the @i{predicate} function is an element of @i{list}. If some element @i{satisfies the test}, the tail of @i{list} beginning with this element is returned; otherwise @b{nil} is returned. @i{list} is searched on the top level only. @subsubheading Examples:: @example (member 2 '(1 2 3)) @result{} (2 3) (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr) @result{} ((3 . 4)) (member 'e '(a b c d)) @result{} NIL @end example @example (member-if #'listp '(a b nil c d)) @result{} (NIL C D) (member-if #'numberp '(a #\Space 5/3 foo)) @result{} (5/3 FOO) (member-if-not #'zerop '(3 6 9 11 . 12) :key #'(lambda (x) (mod x 3))) @result{} (11 . 12) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list} is not a @i{proper list}. @subsubheading See Also:: @ref{find} , @ref{position} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. The @i{function} @b{member-if-not} is deprecated. In the following @example (member 'a '(g (a y) c a d e a f)) @result{} (A D E A F) @end example the value returned by @b{member} is @i{identical} to the portion of the @i{list} beginning with @t{a}. Thus @b{rplaca} on the result of @b{member} can be used to alter the part of the @i{list} where @t{a} was found (assuming a check has been made that @b{member} did not return @b{nil}). @node mapc, acons, member (Function), Conses Dictionary @subsection mapc, mapcar, mapcan, mapl, maplist, mapcon [Function] @code{mapc} @i{function @r{&rest} lists^+} @result{} @i{list-1} @code{mapcar} @i{function @r{&rest} lists^+} @result{} @i{result-list} @code{mapcan} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} @code{mapl} @i{function @r{&rest} lists^+} @result{} @i{list-1} @code{maplist} @i{function @r{&rest} lists^+} @result{} @i{result-list} @code{mapcon} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} @subsubheading Arguments and Values:: @i{function}---a @i{designator} for a @i{function} that must take as many @i{arguments} as there are @i{lists}. @i{list}---a @i{proper list}. @i{list-1}---the first @i{list} (which must be a @i{proper list}). @i{result-list}---a @i{list}. @i{concatenated-results}---a @i{list}. @subsubheading Description:: The mapping operation involves applying @i{function} to successive sets of arguments in which one argument is obtained from each @i{sequence}. Except for @b{mapc} and @b{mapl}, the result contains the results returned by @i{function}. In the cases of @b{mapc} and @b{mapl}, the resulting @i{sequence} is @i{list}. @i{function} is called first on all the elements with index @t{0}, then on all those with index @t{1}, and so on. @i{result-type} specifies the @i{type} of the resulting @i{sequence}. If @i{function} is a @i{symbol}, it is @b{coerce}d to a @i{function} as if by @b{symbol-function}. @b{mapcar} operates on successive @i{elements} of the @i{lists}. @i{function} is applied to the first @i{element} of each @i{list}, then to the second @i{element} of each @i{list}, and so on. The iteration terminates when the shortest @i{list} runs out, and excess elements in other lists are ignored. The value returned by @b{mapcar} is a @i{list} of the results of successive calls to @i{function}. @b{mapc} is like @b{mapcar} except that the results of applying @i{function} are not accumulated. The @i{list} argument is returned. @b{maplist} is like @b{mapcar} except that @i{function} is applied to successive sublists of the @i{lists}. @i{function} is first applied to the @i{lists} themselves, and then to the @i{cdr} of each @i{list}, and then to the @i{cdr} of the @i{cdr} of each @i{list}, and so on. @b{mapl} is like @b{maplist} except that the results of applying @i{function} are not accumulated; @i{list-1} is returned. @b{mapcan} and @b{mapcon} are like @b{mapcar} and @b{maplist} respectively, except that the results of applying @i{function} are combined into a @i{list} by the use of @b{nconc} rather than @b{list}. That is, @example (mapcon f x1 ... xn) @equiv{} (apply #'nconc (maplist f x1 ... xn)) @end example and similarly for the relationship between @b{mapcan} and @b{mapcar}. @subsubheading Examples:: @example (mapcar #'car '((1 a) (2 b) (3 c))) @result{} (1 2 3) (mapcar #'abs '(3 -4 2 -5 -6)) @result{} (3 4 2 5 6) (mapcar #'cons '(a b c) '(1 2 3)) @result{} ((A . 1) (B . 2) (C . 3)) (maplist #'append '(1 2 3 4) '(1 2) '(1 2 3)) @result{} ((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3)) (maplist #'(lambda (x) (cons 'foo x)) '(a b c d)) @result{} ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D)) (maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c)) @result{} (0 0 1 0 1 1 1) ;An entry is 1 if the corresponding element of the input ; list was the last instance of that element in the input list. (setq dummy nil) @result{} NIL (mapc #'(lambda (&rest x) (setq dummy (append dummy x))) '(1 2 3 4) '(a b c d e) '(x y z)) @result{} (1 2 3 4) dummy @result{} (1 A X 2 B Y 3 C Z) (setq dummy nil) @result{} NIL (mapl #'(lambda (x) (push x dummy)) '(1 2 3 4)) @result{} (1 2 3 4) dummy @result{} ((4) (3 4) (2 3 4) (1 2 3 4)) (mapcan #'(lambda (x y) (if (null x) nil (list x y))) '(nil nil nil d e) '(1 2 3 4 5 6)) @result{} (D 4 E 5) (mapcan #'(lambda (x) (and (numberp x) (list x))) '(a 1 b c 3 4 d 5)) @result{} (1 3 4 5) @end example In this case the function serves as a filter; this is a standard @r{Lisp} idiom using @b{mapcan}. @example (mapcon #'list '(1 2 3 4)) @result{} ((1 2 3 4) (2 3 4) (3 4) (4)) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if any @i{list} is not a @i{proper list}. @subsubheading See Also:: @ref{dolist} , @ref{map} , @ref{Traversal Rules and Side Effects} @node acons, assoc, mapc, Conses Dictionary @subsection acons [Function] @code{acons} @i{key datum alist} @result{} @i{new-alist} @subsubheading Arguments and Values:: @i{key}---an @i{object}. @i{datum}---an @i{object}. @i{alist}---an @i{association list}. @i{new-alist}---an @i{association list}. @subsubheading Description:: Creates a @i{fresh} @i{cons}, the @i{cdr} of which is @i{alist} and the @i{car} of which is another @i{fresh} @i{cons}, the @i{car} of which is @i{key} and the @i{cdr} of which is @i{datum}. @subsubheading Examples:: @example (setq alist '()) @result{} NIL (acons 1 "one" alist) @result{} ((1 . "one")) alist @result{} NIL (setq alist (acons 1 "one" (acons 2 "two" alist))) @result{} ((1 . "one") (2 . "two")) (assoc 1 alist) @result{} (1 . "one") (setq alist (acons 1 "uno" alist)) @result{} ((1 . "uno") (1 . "one") (2 . "two")) (assoc 1 alist) @result{} (1 . "uno") @end example @subsubheading See Also:: @ref{assoc} , @ref{pairlis} @subsubheading Notes:: @example (acons @i{key} @i{datum} @i{alist}) @equiv{} (cons (cons @i{key} @i{datum}) @i{alist}) @end example @node assoc, copy-alist, acons, Conses Dictionary @subsection assoc, assoc-if, assoc-if-not [Function] @code{assoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} @code{assoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} @code{assoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{alist}---an @i{association list}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{entry}---a @i{cons} that is an @i{element} of @i{alist}, or @b{nil}. @subsubheading Description:: @b{assoc}, @b{assoc-if}, and @b{assoc-if-not} return the first @i{cons} in @i{alist} whose @i{car} @i{satisfies the test}, or @b{nil} if no such @i{cons} is found. For @b{assoc}, @b{assoc-if}, and @b{assoc-if-not}, if @b{nil} appears in @i{alist} in place of a pair, it is ignored. @subsubheading Examples:: @example (setq values '((x . 100) (y . 200) (z . 50))) @result{} ((X . 100) (Y . 200) (Z . 50)) (assoc 'y values) @result{} (Y . 200) (rplacd (assoc 'y values) 201) @result{} (Y . 201) (assoc 'y values) @result{} (Y . 201) (setq alist '((1 . "one")(2 . "two")(3 . "three"))) @result{} ((1 . "one") (2 . "two") (3 . "three")) (assoc 2 alist) @result{} (2 . "two") (assoc-if #'evenp alist) @result{} (2 . "two") (assoc-if-not #'(lambda(x) (< x 3)) alist) @result{} (3 . "three") (setq alist '(("one" . 1)("two" . 2))) @result{} (("one" . 1) ("two" . 2)) (assoc "one" alist) @result{} NIL (assoc "one" alist :test #'equalp) @result{} ("one" . 1) (assoc "two" alist :key #'(lambda(x) (char x 2))) @result{} NIL (assoc #\o alist :key #'(lambda(x) (char x 2))) @result{} ("two" . 2) (assoc 'r '((a . b) (c . d) (r . x) (s . y) (r . z))) @result{} (R . X) (assoc 'goo '((foo . bar) (zoo . goo))) @result{} NIL (assoc '2 '((1 a b c) (2 b c d) (-7 x y z))) @result{} (2 B C D) (setq alist '(("one" . 1) ("2" . 2) ("three" . 3))) @result{} (("one" . 1) ("2" . 2) ("three" . 3)) (assoc-if-not #'alpha-char-p alist :key #'(lambda (x) (char x 0))) @result{} ("2" . 2) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{alist} is not an @i{association list}. @subsubheading See Also:: @ref{rassoc} , @ref{find} , @ref{member (Function)} , @ref{position} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. The @i{function} @b{assoc-if-not} is deprecated. It is possible to @b{rplacd} the result of @b{assoc}, provided that it is not @b{nil}, in order to ``update'' @i{alist}. The two expressions @example (assoc item list :test fn) @end example and @example (find item list :test fn :key #'car) @end example are equivalent in meaning with one exception: if @b{nil} appears in @i{alist} in place of a pair, and @i{item} is @b{nil}, @b{find} will compute the @i{car} of the @b{nil} in @i{alist}, find that it is equal to @i{item}, and return @b{nil}, whereas @b{assoc} will ignore the @b{nil} in @i{alist} and continue to search for an actual @i{cons} whose @i{car} is @b{nil}. @node copy-alist, pairlis, assoc, Conses Dictionary @subsection copy-alist [Function] @code{copy-alist} @i{alist} @result{} @i{new-alist} @subsubheading Arguments and Values:: @i{alist}---an @i{association list}. @i{new-alist}---an @i{association list}. @subsubheading Description:: @b{copy-alist} returns a @i{copy} of @i{alist}. The @i{list structure} of @i{alist} is copied, and the @i{elements} of @i{alist} which are @i{conses} are also copied (as @i{conses} only). Any other @i{objects} which are referred to, whether directly or indirectly, by the @i{alist} continue to be shared. @subsubheading Examples:: @example (defparameter *alist* (acons 1 "one" (acons 2 "two" '()))) *alist* @result{} ((1 . "one") (2 . "two")) (defparameter *list-copy* (copy-list *alist*)) *list-copy* @result{} ((1 . "one") (2 . "two")) (defparameter *alist-copy* (copy-alist *alist*)) *alist-copy* @result{} ((1 . "one") (2 . "two")) (setf (cdr (assoc 2 *alist-copy*)) "deux") @result{} "deux" *alist-copy* @result{} ((1 . "one") (2 . "deux")) *alist* @result{} ((1 . "one") (2 . "two")) (setf (cdr (assoc 1 *list-copy*)) "uno") @result{} "uno" *list-copy* @result{} ((1 . "uno") (2 . "two")) *alist* @result{} ((1 . "uno") (2 . "two")) @end example @subsubheading See Also:: @ref{copy-list} @node pairlis, rassoc, copy-alist, Conses Dictionary @subsection pairlis [Function] @code{pairlis} @i{keys data @r{&optional} alist} @result{} @i{new-alist} @subsubheading Arguments and Values:: @i{keys}---a @i{proper list}. @i{data}---a @i{proper list}. @i{alist}---an @i{association list}. The default is the @i{empty list}. @i{new-alist}---an @i{association list}. @subsubheading Description:: Returns an @i{association list} that associates elements of @i{keys} to corresponding elements of @i{data}. The consequences are undefined if @i{keys} and @i{data} are not of the same @i{length}. If @i{alist} is supplied, @b{pairlis} returns a modified @i{alist} with the new pairs prepended to it. The new pairs may appear in the resulting @i{association list} in either forward or backward order. The result of @example (pairlis '(one two) '(1 2) '((three . 3) (four . 19))) @end example might be @example ((one . 1) (two . 2) (three . 3) (four . 19)) @end example or @example ((two . 2) (one . 1) (three . 3) (four . 19)) @end example @subsubheading Examples:: @example (setq keys '(1 2 3) data '("one" "two" "three") alist '((4 . "four"))) @result{} ((4 . "four")) (pairlis keys data) @result{} ((3 . "three") (2 . "two") (1 . "one")) (pairlis keys data alist) @result{} ((3 . "three") (2 . "two") (1 . "one") (4 . "four")) alist @result{} ((4 . "four")) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{keys} and @i{data} are not @i{proper lists}. @subsubheading See Also:: @ref{acons} @node rassoc, get-properties, pairlis, Conses Dictionary @subsection rassoc, rassoc-if, rassoc-if-not [Function] @code{rassoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} @code{rassoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} @code{rassoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{alist}---an @i{association list}. @i{predicate}---a @i{designator} for a @i{function} of one @i{argument} that returns a @i{generalized boolean}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{entry}---a @i{cons} that is an @i{element} of the @i{alist}, or @b{nil}. @subsubheading Description:: @b{rassoc}, @b{rassoc-if}, and @b{rassoc-if-not} return the first @i{cons} whose @i{cdr} @i{satisfies the test}. If no such @i{cons} is found, @b{nil} is returned. If @b{nil} appears in @i{alist} in place of a pair, it is ignored. @subsubheading Examples:: @example (setq alist '((1 . "one") (2 . "two") (3 . 3))) @result{} ((1 . "one") (2 . "two") (3 . 3)) (rassoc 3 alist) @result{} (3 . 3) (rassoc "two" alist) @result{} NIL (rassoc "two" alist :test 'equal) @result{} (2 . "two") (rassoc 1 alist :key #'(lambda (x) (if (numberp x) (/ x 3)))) @result{} (3 . 3) (rassoc 'a '((a . b) (b . c) (c . a) (z . a))) @result{} (C . A) (rassoc-if #'stringp alist) @result{} (1 . "one") (rassoc-if-not #'vectorp alist) @result{} (3 . 3) @end example @subsubheading See Also:: @ref{assoc} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. The @i{function} @b{rassoc-if-not} is deprecated. It is possible to @b{rplaca} the result of @b{rassoc}, provided that it is not @b{nil}, in order to ``update'' @i{alist}. The expressions @example (rassoc item list :test fn) @end example and @example (find item list :test fn :key #'cdr) @end example are equivalent in meaning, except when the @t{item} is @b{nil} and @b{nil} appears in place of a pair in the @i{alist}. See the @i{function} @b{assoc}. @node get-properties, getf, rassoc, Conses Dictionary @subsection get-properties [Function] @code{get-properties} @i{plist indicator-list} @result{} @i{indicator, value, tail} @subsubheading Arguments and Values:: @i{plist}---a @i{property list}. @i{indicator-list}---a @i{proper list} (of @i{indicators}). @i{indicator}---an @i{object} that is an @i{element} of @i{indicator-list}. @i{value}---an @i{object}. @i{tail}---a @i{list}. @subsubheading Description:: @b{get-properties} is used to look up any of several @i{property list} entries all at once. It searches the @i{plist} for the first entry whose @i{indicator} is @i{identical} to one of the @i{objects} in @i{indicator-list}. If such an entry is found, the @i{indicator} and @i{value} returned are the @i{property indicator} and its associated @i{property value}, and the @i{tail} returned is the @i{tail} of the @i{plist} that begins with the found entry (@i{i.e.}, whose @i{car} is the @i{indicator}). If no such entry is found, the @i{indicator}, @i{value}, and @i{tail} are all @b{nil}. @subsubheading Examples:: @example (setq x '()) @result{} NIL (setq *indicator-list* '(prop1 prop2)) @result{} (PROP1 PROP2) (getf x 'prop1) @result{} NIL (setf (getf x 'prop1) 'val1) @result{} VAL1 (eq (getf x 'prop1) 'val1) @result{} @i{true} (get-properties x *indicator-list*) @result{} PROP1, VAL1, (PROP1 VAL1) x @result{} (PROP1 VAL1) @end example @subsubheading See Also:: @ref{get} , @ref{getf} @node getf, remf, get-properties, Conses Dictionary @subsection getf [Accessor] @code{getf} @i{plist indicator @r{&optional} default} @result{} @i{value} (setf (@code{ getf} @i{place indicator @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: @i{plist}---a @i{property list}. @i{place}---a @i{place}, the @i{value} of which is a @i{property list}. @i{indicator}---an @i{object}. @i{default}---an @i{object}. The default is @b{nil}. @i{value}---an @i{object}. @i{new-value}---an @i{object}. @subsubheading Description:: @b{getf} finds a @i{property} on the @i{plist} whose @i{property indicator} is @i{identical} to @i{indicator}, and returns its corresponding @i{property value}. If there are multiple @i{properties}_1 with that @i{property indicator}, @b{getf} uses the first such @i{property}. If there is no @i{property} with that @i{property indicator}, @i{default} is returned. @b{setf} of @b{getf} may be used to associate a new @i{object} with an existing indicator in the @i{property list} held by @i{place}, or to create a new assocation if none exists. If there are multiple @i{properties}_1 with that @i{property indicator}, @b{setf} of @b{getf} associates the @i{new-value} with the first such @i{property}. When a @b{getf} @i{form} is used as a @b{setf} @i{place}, any @i{default} which is supplied is evaluated according to normal left-to-right evaluation rules, but its @i{value} is ignored. @b{setf} of @b{getf} is permitted to either @i{write} the @i{value} of @i{place} itself, or modify of any part, @i{car} or @i{cdr}, of the @i{list structure} held by @i{place}. @subsubheading Examples:: @example (setq x '()) @result{} NIL (getf x 'prop1) @result{} NIL (getf x 'prop1 7) @result{} 7 (getf x 'prop1) @result{} NIL (setf (getf x 'prop1) 'val1) @result{} VAL1 (eq (getf x 'prop1) 'val1) @result{} @i{true} (getf x 'prop1) @result{} VAL1 (getf x 'prop1 7) @result{} VAL1 x @result{} (PROP1 VAL1) ;; Examples of implementation variation permitted. (setq foo (list 'a 'b 'c 'd 'e 'f)) @result{} (A B C D E F) (setq bar (cddr foo)) @result{} (C D E F) (remf foo 'c) @result{} @i{true} foo @result{} (A B E F) bar @result{} (C D E F) @i{OR}@result{} (C) @i{OR}@result{} (NIL) @i{OR}@result{} (C NIL) @i{OR}@result{} (C D) @end example @subsubheading See Also:: @ref{get} , @ref{get-properties} , @ref{setf} , @ref{Function Call Forms as Places} @subsubheading Notes:: There is no way (using @b{getf}) to distinguish an absent property from one whose value is @i{default}; but see @b{get-properties}. Note that while supplying a @i{default} argument to @b{getf} in a @b{setf} situation is sometimes not very interesting, it is still important because some macros, such as @b{push} and @b{incf}, require a @i{place} argument which data is both @i{read} from and @i{written} to. In such a context, if a @i{default} argument is to be supplied for the @i{read} situation, it must be syntactically valid for the @i{write} situation as well. For example, @example (let ((plist '())) (incf (getf plist 'count 0)) plist) @result{} (COUNT 1) @end example @node remf, intersection, getf, Conses Dictionary @subsection remf [Macro] @code{remf} @i{place indicator} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{indicator}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{remf} removes from the @i{property list} stored in @i{place} a @i{property}_1 with a @i{property indicator} @i{identical} to @i{indicator}. If there are multiple @i{properties}_1 with the @i{identical} key, @b{remf} only removes the first such @i{property}. @b{remf} returns @i{false} if no such @i{property} was found, or @i{true} if a property was found. The @i{property indicator} and the corresponding @i{property value} are removed in an undefined order by destructively splicing the property list. @b{remf} is permitted to either @b{setf} @i{place} or to @b{setf} any part, @b{car} or @b{cdr}, of the @i{list structure} held by that @i{place}. For information about the @i{evaluation} of @i{subforms} of @i{place}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (setq x (cons () ())) @result{} (NIL) (setf (getf (car x) 'prop1) 'val1) @result{} VAL1 (remf (car x) 'prop1) @result{} @i{true} (remf (car x) 'prop1) @result{} @i{false} @end example @subsubheading Side Effects:: The property list stored in @i{place} is modified. @subsubheading See Also:: @ref{remprop} , @ref{getf} @node intersection, adjoin, remf, Conses Dictionary @subsection intersection, nintersection [Function] @code{intersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @code{nintersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list-1}---a @i{proper list}. @i{list-2}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-list}---a @i{list}. @subsubheading Description:: @b{intersection} and @b{nintersection} return a @i{list} that contains every element that occurs in both @i{list-1} and @i{list-2}. @b{nintersection} is the destructive version of @b{intersection}. It performs the same operation, but may destroy @i{list-1} using its cells to construct the result. @i{list-2} is not destroyed. The intersection operation is described as follows. For all possible ordered pairs consisting of one @i{element} from @i{list-1} and one @i{element} from @i{list-2}, @t{:test} or @t{:test-not} are used to determine whether they @i{satisfy the test}. The first argument to the @t{:test} or @t{:test-not} function is an element of @i{list-1}; the second argument is an element of @i{list-2}. If @t{:test} or @t{:test-not} is not supplied, @b{eql} is used. It is an error if @t{:test} and @t{:test-not} are supplied in the same function call. If @t{:key} is supplied (and not @b{nil}), it is used to extract the part to be tested from the @i{list} element. The argument to the @t{:key} function is an element of either @i{list-1} or @i{list-2}; the @t{:key} function typically returns part of the supplied element. If @t{:key} is not supplied or @b{nil}, the @i{list-1} and @i{list-2} elements are used. For every pair that @i{satifies the test}, exactly one of the two elements of the pair will be put in the result. No element from either @i{list} appears in the result that does not @i{satisfy the test} for an element from the other @i{list}. If one of the @i{lists} contains duplicate elements, there may be duplication in the result. There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result @i{list} may share cells with, or be @b{eq} to, either @i{list-1} or @i{list-2} if appropriate. @subsubheading Examples:: @example (setq list1 (list 1 1 2 3 4 a b c "A" "B" "C" "d") list2 (list 1 4 5 b c d "a" "B" "c" "D")) @result{} (1 4 5 B C D "a" "B" "c" "D") (intersection list1 list2) @result{} (C B 4 1 1) (intersection list1 list2 :test 'equal) @result{} ("B" C B 4 1 1) (intersection list1 list2 :test #'equalp) @result{} ("d" "C" "B" "A" C B 4 1 1) (nintersection list1 list2) @result{} (1 1 4 B C) list1 @result{} @i{implementation-dependent} ;@i{e.g.}, (1 1 4 B C) list2 @result{} @i{implementation-dependent} ;@i{e.g.}, (1 4 5 B C D "a" "B" "c" "D") (setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5)))) @result{} ((1 . 2) (2 . 3) (3 . 4) (4 . 5)) (setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8)))) @result{} ((1 . 3) (2 . 4) (3 . 6) (4 . 8)) (nintersection list1 list2 :key #'cdr) @result{} ((2 . 3) (3 . 4)) list1 @result{} @i{implementation-dependent} ;@i{e.g.}, ((1 . 2) (2 . 3) (3 . 4)) list2 @result{} @i{implementation-dependent} ;@i{e.g.}, ((1 . 3) (2 . 4) (3 . 6) (4 . 8)) @end example @subsubheading Side Effects:: @b{nintersection} can modify @i{list-1}, but not @i{list-2}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list-1} and @i{list-2} are not @i{proper lists}. @subsubheading See Also:: @ref{union} , @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. Since the @b{nintersection} side effect is not required, it should not be used in for-effect-only positions in portable code. @node adjoin, pushnew, intersection, Conses Dictionary @subsection adjoin [Function] @code{adjoin} @i{item list @r{&key} key test test-not} @result{} @i{new-list} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{list}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{new-list}---a @i{list}. @subsubheading Description:: Tests whether @i{item} is the same as an existing element of @i{list}. If the @i{item} is not an existing element, @b{adjoin} adds it to @i{list} (as if by @b{cons}) and returns the resulting @i{list}; otherwise, nothing is added and the original @i{list} is returned. The @i{test}, @i{test-not}, and @i{key} affect how it is determined whether @i{item} is the same as an @i{element} of @i{list}. For details, see @ref{Satisfying a Two-Argument Test}.\ifvmode\else\endgraf \ifdim \prevdepth>-1000pt \NIS\parskip \normalparskip\relax\fi @subsubheading Examples:: @example (setq slist '()) @result{} NIL (adjoin 'a slist) @result{} (A) slist @result{} NIL (setq slist (adjoin '(test-item 1) slist)) @result{} ((TEST-ITEM 1)) (adjoin '(test-item 1) slist) @result{} ((TEST-ITEM 1) (TEST-ITEM 1)) (adjoin '(test-item 1) slist :test 'equal) @result{} ((TEST-ITEM 1)) (adjoin '(new-test-item 1) slist :key #'cadr) @result{} ((TEST-ITEM 1)) (adjoin '(new-test-item 1) slist) @result{} ((NEW-TEST-ITEM 1) (TEST-ITEM 1)) @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list} is not a @i{proper list}. @subsubheading See Also:: @ref{pushnew} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. @example (adjoin item list :key fn) @equiv{} (if (member (fn item) list :key fn) list (cons item list)) @end example @node pushnew, set-difference, adjoin, Conses Dictionary @subsection pushnew [Macro] @code{pushnew} @i{item place @r{&key} key test test-not}@* @result{} @i{new-place-value} @subsubheading Arguments and Values:: @i{item}---an @i{object}. @i{place}---a @i{place}, the @i{value} of which is a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{new-place-value}---a @i{list} (the new @i{value} of @i{place}). @subsubheading Description:: @b{pushnew} tests whether @i{item} is the same as any existing element of the @i{list} stored in @i{place}. If @i{item} is not, it is prepended to the @i{list}, and the new @i{list} is stored in @i{place}. @b{pushnew} returns the new @i{list} that is stored in @i{place}. Whether or not @i{item} is already a member of the @i{list} that is in @i{place} is determined by comparisons using @t{:test} or @t{:test-not}. The first argument to the @t{:test} or @t{:test-not} function is @i{item}; the second argument is an element of the @i{list} in @i{place} as returned by the @t{:key} function (if supplied). If @t{:key} is supplied, it is used to extract the part to be tested from both @i{item} and the @i{list} element, as for @b{adjoin}. The argument to the @t{:key} function is an element of the @i{list} stored in @i{place}. The @t{:key} function typically returns part part of the element of the @i{list}. If @t{:key} is not supplied or @b{nil}, the @i{list} element is used. For information about the @i{evaluation} of @i{subforms} of @i{place}, see @ref{Evaluation of Subforms to Places}. It is @i{implementation-dependent} whether or not @b{pushnew} actually executes the storing form for its @i{place} in the situation where the @i{item} is already a member of the @i{list} held by @i{place}. @subsubheading Examples:: @example (setq x '(a (b c) d)) @result{} (A (B C) D) (pushnew 5 (cadr x)) @result{} (5 B C) x @result{} (A (5 B C) D) (pushnew 'b (cadr x)) @result{} (5 B C) x @result{} (A (5 B C) D) (setq lst '((1) (1 2) (1 2 3))) @result{} ((1) (1 2) (1 2 3)) (pushnew '(2) lst) @result{} ((2) (1) (1 2) (1 2 3)) (pushnew '(1) lst) @result{} ((1) (2) (1) (1 2) (1 2 3)) (pushnew '(1) lst :test 'equal) @result{} ((1) (2) (1) (1 2) (1 2 3)) (pushnew '(1) lst :key #'car) @result{} ((1) (2) (1) (1 2) (1 2 3)) @end example @subsubheading Side Effects:: The contents of @i{place} may be modified. @subsubheading See Also:: @ref{push} , @ref{adjoin} , @ref{Generalized Reference} @subsubheading Notes:: The effect of @example (pushnew item place :test p) @end example is roughly equivalent to @example (setf place (adjoin item place :test p)) @end example except that the @i{subforms} of @t{place} are evaluated only once, and @t{item} is evaluated before @t{place}. @node set-difference, set-exclusive-or, pushnew, Conses Dictionary @subsection set-difference, nset-difference [Function] @code{set-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @code{nset-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list-1}---a @i{proper list}. @i{list-2}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-list}---a @i{list}. @subsubheading Description:: @b{set-difference} returns a @i{list} of elements of @i{list-1} that do not appear in @i{list-2}. @b{nset-difference} is the destructive version of @b{set-difference}. It may destroy @i{list-1}. For all possible ordered pairs consisting of one element from @i{list-1} and one element from @i{list-2}, the @t{:test} or @t{:test-not} function is used to determine whether they @i{satisfy the test}. The first argument to the @t{:test} or @t{:test-not} function is the part of an element of @i{list-1} that is returned by the @t{:key} function (if supplied); the second argument is the part of an element of @i{list-2} that is returned by the @t{:key} function (if supplied). If @t{:key} is supplied, its argument is a @i{list-1} or @i{list-2} element. The @t{:key} function typically returns part of the supplied element. If @t{:key} is not supplied, the @i{list-1} or @i{list-2} element is used. An element of @i{list-1} appears in the result if and only if it does not match any element of @i{list-2}. There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result @i{list} may share cells with, or be @b{eq} to, either of @i{list-1} or @i{list-2}, if appropriate. @subsubheading Examples:: @example (setq lst1 (list "A" "b" "C" "d") lst2 (list "a" "B" "C" "d")) @result{} ("a" "B" "C" "d") (set-difference lst1 lst2) @result{} ("d" "C" "b" "A") (set-difference lst1 lst2 :test 'equal) @result{} ("b" "A") (set-difference lst1 lst2 :test #'equalp) @result{} NIL (nset-difference lst1 lst2 :test #'string=) @result{} ("A" "b") (setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f"))) @result{} (("a" . "b") ("c" . "d") ("e" . "f")) (setq lst2 '(("c" . "a") ("e" . "b") ("d" . "a"))) @result{} (("c" . "a") ("e" . "b") ("d" . "a")) (nset-difference lst1 lst2 :test #'string= :key #'cdr) @result{} (("c" . "d") ("e" . "f")) lst1 @result{} (("a" . "b") ("c" . "d") ("e" . "f")) lst2 @result{} (("c" . "a") ("e" . "b") ("d" . "a")) @end example @example ;; Remove all flavor names that contain "c" or "w". (set-difference '("strawberry" "chocolate" "banana" "lemon" "pistachio" "rhubarb") '(#\c #\w) :test #'(lambda (s c) (find c s))) @result{} ("banana" "rhubarb" "lemon") ;One possible ordering. @end example @subsubheading Side Effects:: @b{nset-difference} may destroy @i{list-1}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list-1} and @i{list-2} are not @i{proper lists}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. @node set-exclusive-or, subsetp, set-difference, Conses Dictionary @subsection set-exclusive-or, nset-exclusive-or [Function] @code{set-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @code{nset-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list-1}---a @i{proper list}. @i{list-2}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-list}---a @i{list}. @subsubheading Description:: @b{set-exclusive-or} returns a @i{list} of elements that appear in exactly one of @i{list-1} and @i{list-2}. @b{nset-exclusive-or} is the @i{destructive} version of @b{set-exclusive-or}. For all possible ordered pairs consisting of one element from @i{list-1} and one element from @i{list-2}, the @t{:test} or @t{:test-not} function is used to determine whether they @i{satisfy the test}. If @t{:key} is supplied, it is used to extract the part to be tested from the @i{list-1} or @i{list-2} element. The first argument to the @t{:test} or @t{:test-not} function is the part of an element of @i{list-1} extracted by the @t{:key} function (if supplied); the second argument is the part of an element of @i{list-2} extracted by the @t{:key} function (if supplied). If @t{:key} is not supplied or @b{nil}, the @i{list-1} or @i{list-2} element is used. The result contains precisely those elements of @i{list-1} and @i{list-2} that appear in no matching pair. The result @i{list} of @b{set-exclusive-or} might share storage with one of @i{list-1} or @i{list-2}. @subsubheading Examples:: @example (setq lst1 (list 1 "a" "b") lst2 (list 1 "A" "b")) @result{} (1 "A" "b") (set-exclusive-or lst1 lst2) @result{} ("b" "A" "b" "a") (set-exclusive-or lst1 lst2 :test #'equal) @result{} ("A" "a") (set-exclusive-or lst1 lst2 :test 'equalp) @result{} NIL (nset-exclusive-or lst1 lst2) @result{} ("a" "b" "A" "b") (setq lst1 (list (("a" . "b") ("c" . "d") ("e" . "f")))) @result{} (("a" . "b") ("c" . "d") ("e" . "f")) (setq lst2 (list (("c" . "a") ("e" . "b") ("d" . "a")))) @result{} (("c" . "a") ("e" . "b") ("d" . "a")) (nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr) @result{} (("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a")) lst1 @result{} (("a" . "b") ("c" . "d") ("e" . "f")) lst2 @result{} (("c" . "a") ("d" . "a")) @end example @subsubheading Side Effects:: @b{nset-exclusive-or} is permitted to modify any part, @i{car} or @i{cdr}, of the @i{list structure} of @i{list-1} or @i{list-2}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list-1} and @i{list-2} are not @i{proper lists}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. Since the @b{nset-exclusive-or} side effect is not required, it should not be used in for-effect-only positions in portable code. @node subsetp, union, set-exclusive-or, Conses Dictionary @subsection subsetp [Function] @code{subsetp} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{list-1}---a @i{proper list}. @i{list-2}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{subsetp} returns @i{true} if every element of @i{list-1} matches some element of @i{list-2}, and @i{false} otherwise. Whether a list element is the same as another list element is determined by the functions specified by the keyword arguments. The first argument to the @t{:test} or @t{:test-not} function is typically part of an element of @i{list-1} extracted by the @t{:key} function; the second argument is typically part of an element of @i{list-2} extracted by the @t{:key} function. The argument to the @t{:key} function is an element of either @i{list-1} or @i{list-2}; the return value is part of the element of the supplied list element. If @t{:key} is not supplied or @b{nil}, the @i{list-1} or @i{list-2} element itself is supplied to the @t{:test} or @t{:test-not} function. @subsubheading Examples:: @example (setq cosmos '(1 "a" (1 2))) @result{} (1 "a" (1 2)) (subsetp '(1) cosmos) @result{} @i{true} (subsetp '((1 2)) cosmos) @result{} @i{false} (subsetp '((1 2)) cosmos :test 'equal) @result{} @i{true} (subsetp '(1 "A") cosmos :test #'equalp) @result{} @i{true} (subsetp '((1) (2)) '((1) (2))) @result{} @i{false} (subsetp '((1) (2)) '((1) (2)) :key #'car) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list-1} and @i{list-2} are not @i{proper lists}. @subsubheading See Also:: @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. @node union, , subsetp, Conses Dictionary @subsection union, nunion [Function] @code{union} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @code{nunion} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @i{list-1}---a @i{proper list}. @i{list-2}---a @i{proper list}. @i{test}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{test-not}---a @i{designator} for a @i{function} of two @i{arguments} that returns a @i{generalized boolean}. @i{key}---a @i{designator} for a @i{function} of one argument, or @b{nil}. @i{result-list}---a @i{list}. @subsubheading Description:: @b{union} and @b{nunion} return a @i{list} that contains every element that occurs in either @i{list-1} or @i{list-2}. For all possible ordered pairs consisting of one element from @i{list-1} and one element from @i{list-2}, @t{:test} or @t{:test-not} is used to determine whether they @i{satisfy the test}. The first argument to the @t{:test} or @t{:test-not} function is the part of the element of @i{list-1} extracted by the @t{:key} function (if supplied); the second argument is the part of the element of @i{list-2} extracted by the @t{:key} function (if supplied). The argument to the @t{:key} function is an element of @i{list-1} or @i{list-2}; the return value is part of the supplied element. If @t{:key} is not supplied or @b{nil}, the element of @i{list-1} or @i{list-2} itself is supplied to the @t{:test} or @t{:test-not} function. For every matching pair, one of the two elements of the pair will be in the result. Any element from either @i{list-1} or @i{list-2} that matches no element of the other will appear in the result. If there is a duplication between @i{list-1} and @i{list-2}, only one of the duplicate instances will be in the result. If either @i{list-1} or @i{list-2} has duplicate entries within it, the redundant entries might or might not appear in the result. The order of elements in the result do not have to reflect the ordering of @i{list-1} or @i{list-2} in any way. The result @i{list} may be @b{eq} to either @i{list-1} or @i{list-2} if appropriate. @subsubheading Examples:: @example (union '(a b c) '(f a d)) @result{} (A B C F D) @i{OR}@result{} (B C F A D) @i{OR}@result{} (D F A B C) (union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car) @result{} ((X 5) (Y 6) (Z 2)) @i{OR}@result{} ((X 4) (Y 6) (Z 2)) (setq lst1 (list 1 2 '(1 2) "a" "b") lst2 (list 2 3 '(2 3) "B" "C")) @result{} (2 3 (2 3) "B" "C") (nunion lst1 lst2) @result{} (1 (1 2) "a" "b" 2 3 (2 3) "B" "C") @i{OR}@result{} (1 2 (1 2) "a" "b" "C" "B" (2 3) 3) @end example @subsubheading Side Effects:: @b{nunion} is permitted to modify any part, @i{car} or @i{cdr}, of the @i{list structure} of @i{list-1} or @i{list-2}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{list-1} and @i{list-2} are not @i{proper lists}. @subsubheading See Also:: @ref{intersection} , @ref{Compiler Terminology}, @ref{Traversal Rules and Side Effects} @subsubheading Notes:: The @t{:test-not} parameter is deprecated. Since the @b{nunion} side effect is not required, it should not be used in for-effect-only positions in portable code. @c end of including dict-conses @c %**end of chapter gcl-2.6.14/info/gcl-tk/0000755000175000017500000000000014360276512013107 5ustar cammcammgcl-2.6.14/info/gcl-tk/place.html0000644000175000017500000003065614360276512015073 0ustar cammcamm place (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.15 place

place \- Geometry manager for fixed or rubber-sheet placement

Synopsis

place window option value ?option value ...?


place configure window option value ?option value ...?


place forget window


place info window


place slaves window

Description

The placer is a geometry manager for Tk. It provides simple fixed placement of windows, where you specify the exact size and location of one window, called the slave, within another window, called the master. The placer also provides rubber-sheet placement, where you specify the size and location of the slave in terms of the dimensions of the master, so that the slave changes size and location in response to changes in the size of the master. Lastly, the placer allows you to mix these styles of placement so that, for example, the slave has a fixed width and height but is centered inside the master.

If the first argument to the place command is a window path name or configure then the command arranges for the placer to manage the geometry of a slave whose path name is window. The remaining arguments consist of one or more option:value pairs that specify the way in which window’s geometry is managed. If the placer is already managing window, then the option:value pairs modify the configuration for window. In this form the place command returns an empty string as result. The following option:value pairs are supported:

:in master

Master specifes the path name of the window relative to which window is to be placed. Master must either be window’s parent or a descendant of window’s parent. In addition, master and window must both be descendants of the same top-level window. These restrictions are necessary to guarantee that window is visible whenever master is visible. If this option isn’t specified then the master defaults to window’s parent.

:x location

Location specifies the x-coordinate within the master window of the anchor point for window. The location is specified in screen units (i.e. any of the forms accepted by Tk_GetPixels) and need not lie within the bounds of the master window.

:relx location

Location specifies the x-coordinate within the master window of the anchor point for window. In this case the location is specified in a relative fashion as a floating-point number: 0.0 corresponds to the left edge of the master and 1.0 corresponds to the right edge of the master. Location need not be in the range 0.0\-1.0.

:y location

Location specifies the y-coordinate within the master window of the anchor point for window. The location is specified in screen units (i.e. any of the forms accepted by Tk_GetPixels) and need not lie within the bounds of the master window.

:rely location

Location specifies the y-coordinate within the master window of the anchor point for window. In this case the value is specified in a relative fashion as a floating-point number: 0.0 corresponds to the top edge of the master and 1.0 corresponds to the bottom edge of the master. Location need not be in the range 0.0\-1.0.

:anchor where

Where specifies which point of window is to be positioned at the (x,y) location selected by the :x, :y, :relx, and :rely options. The anchor point is in terms of the outer area of window including its border, if any. Thus if where is se then the lower-right corner of window’s border will appear at the given (x,y) location in the master. The anchor position defaults to nw.

:width size

Size specifies the width for window in screen units (i.e. any of the forms accepted by Tk_GetPixels). The width will be the outer width of window including its border, if any. If size is an empty string, or if no :width or :relwidth option is specified, then the width requested internally by the window will be used.

:relwidth size

Size specifies the width for window. In this case the width is specified as a floating-point number relative to the width of the master: 0.5 means window will be half as wide as the master, 1.0 means window will have the same width as the master, and so on.

:height size

Size specifies the height for window in screen units (i.e. any of the forms accepted by Tk_GetPixels). The height will be the outer dimension of window including its border, if any. If size is an empty string, or if no :height or :relheight option is specified, then the height requested internally by the window will be used.

:relheight size

Size specifies the height for window. In this case the height is specified as a floating-point number relative to the height of the master: 0.5 means window will be half as high as the master, 1.0 means window will have the same height as the master, and so on.

:bordermode mode

Mode determines the degree to which borders within the master are used in determining the placement of the slave. The default and most common value is inside. In this case the placer considers the area of the master to be the innermost area of the master, inside any border: an option of :x 0 corresponds to an x-coordinate just inside the border and an option of :relwidth 1.0 means window will fill the area inside the master’s border. If mode is outside then the placer considers the area of the master to include its border; this mode is typically used when placing window outside its master, as with the options :x 0 :y 0 :anchor ne. Lastly, mode may be specified as ignore, in which case borders are ignored: the area of the master is considered to be its official X area, which includes any internal border but no external border. A bordermode of ignore is probably not very useful.

If the same value is specified separately with two different options, such as :x and :relx, then the most recent option is used and the older one is ignored.

The place slaves command returns a list of all the slave windows for which window is the master. If there are no slaves for window then an empty string is returned.

The place forget command causes the placer to stop managing the geometry of window. As a side effect of this command window will be unmapped so that it doesn’t appear on the screen. If window isn’t currently managed by the placer then the command has no effect. Place forget returns an empty string as result.

The place info command returns a list giving the current configuration of window. The list consists of option:value pairs in exactly the same form as might be specified to the place configure command. If the configuration of a window has been retrieved with place info, that configuration can be restored later by first using place forget to erase any existing information for the window and then invoking place configure with the saved information.

"Fine Points"

It is not necessary for the master window to be the parent of the slave window. This feature is useful in at least two situations. First, for complex window layouts it means you can create a hierarchy of subwindows whose only purpose is to assist in the layout of the parent. The “real children” of the parent (i.e. the windows that are significant for the application’s user interface) can be children of the parent yet be placed inside the windows of the geometry-management hierarchy. This means that the path names of the “real children” don’t reflect the geometry-management hierarchy and users can specify options for the real children without being aware of the structure of the geometry-management hierarchy.

A second reason for having a master different than the slave’s parent is to tie two siblings together. For example, the placer can be used to force a window always to be positioned centered just below one of its siblings by specifying the configuration 

:in sibling :relx 0.5 :rely 1.0 :anchor n :bordermode outside

Whenever the sibling is repositioned in the future, the slave will be repositioned as well.

Unlike many other geometry managers (such as the packer) the placer does not make any attempt to manipulate the geometry of the master windows or the parents of slave windows (i.e. it doesn’t set their requested sizes). To control the sizes of these windows, make them windows like frames and canvases that provide configuration options for this purpose.

Keywords

geometry manager, height, location, master, place, rubber sheet, slave, width

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/toplevel.html0000644000175000017500000001602014360276512015626 0ustar cammcamm toplevel (GCL TK Manual)

Previous: , Up: Widgets   [Contents]

2.15 toplevel

toplevel \- Create and manipulate toplevel widgets

Synopsis

toplevel pathName ?:screen screenName? ?:class className? ?options?

Standard Options

background                  geometry                
borderWidth                 relief

See options, for more information.

Arguments for Toplevel

Description

The toplevel command creates a new toplevel widget (given by the pathName argument). Additional options, described above, may be specified on the command line or in the option database to configure aspects of the toplevel such as its background color and relief. The toplevel command returns the path name of the new window.

A toplevel is similar to a frame except that it is created as a top-level window: its X parent is the root window of a screen rather than the logical parent from its path name. The primary purpose of a toplevel is to serve as a container for dialog boxes and other collections of widgets. The only features of a toplevel are its background color and an optional 3-D border to make the toplevel appear raised or sunken.

Two special command-line options may be provided to the toplevel command: :class and :screen. If :class is specified, then the new widget’s class will be set to className instead of Toplevel. Changing the class of a toplevel widget may be useful in order to use a special class name in database options referring to this widget and its children. The :screen option may be used to place the window on a different screen than the window’s logical parent. Any valid screen name may be used, even one associated with a different display.

Note: :class and :screen are handled differently than other command-line options. They may not be specified using the option database (these options must have been processed before the new window has been created enough to use the option database; in particular, the new class name will affect the lookup of options in the database). In addition, :class and :screen may not be queried or changed using the config command described below. However, the winfo :class command may be used to query the class of a window, and winfo :screen may be used to query its screen.

A Toplevel Widget’s Arguments

The toplevel command creates a new Tcl command whose name is the same as the path name of the toplevel’s window. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

PathName is the name of the command, which is the same as the toplevel widget’s path name. Option and the args determine the exact behavior of the command. The following commands are possible for toplevel widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the toplevel command.

Bindings

When a new toplevel is created, it has no default event bindings: toplevels are not intended to be interactive.

Keywords

toplevel, widget

Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/tk_002dlistbox_002dsingle_002dselect.html0000644000175000017500000000574214360276512022431 0ustar cammcamm tk-listbox-single-select (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.8 tk-listbox-single-select

tk-listbox-single-select \- Allow only one selected element in listbox(es)

Synopsis

tk-listbox-single-select arg ?arg arg ...?

Description

This command is a Tcl procedure provided as part of the Tk script library. It takes as arguments the path names of one or more listbox widgets, or the value Listbox. For each named widget, tk-listbox-single-select modifies the bindings of the widget so that only a single element may be selected at a time (the normal configuration allows multiple elements to be selected). If the keyword Listbox is among the window arguments, then the class bindings for listboxes are changed so that all listboxes have the one-selection-at-a-time behavior.

Keywords

listbox, selection

gcl-2.6.14/info/gcl-tk/bind.html0000644000175000017500000005446014360276512014722 0ustar cammcamm bind (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.2 bind

bind \- Arrange for X events to invoke Tcl commands

Synopsis


bind windowSpec

bind windowSpec sequence

bind windowSpec sequence command
bind windowSpec sequence +command

Description

If all three arguments are specified, bind will arrange for command (a Tcl command) to be executed whenever the sequence of events given by sequence occurs in the window(s) identified by windowSpec. If command is prefixed with a “+”, then it is appended to any existing binding for sequence; otherwise command replaces the existing binding, if any. If command is an empty string then the current binding for sequence is destroyed, leaving sequence unbound. In all of the cases where a command argument is provided, bind returns an empty string.

If sequence is specified without a command, then the command currently bound to sequence is returned, or an empty string if there is no binding for sequence. If neither sequence nor command is specified, then the return value is a list whose elements are all the sequences for which there exist bindings for windowSpec.

The windowSpec argument selects which window(s) the binding applies to. It may have one of three forms. If windowSpec is the path name for a window, then the binding applies to that particular window. If windowSpec is the name of a class of widgets, then the binding applies to all widgets in that class. Lastly, windowSpec may have the value all, in which case the binding applies to all windows in the application.

The sequence argument specifies a sequence of one or more event patterns, with optional white space between the patterns. Each event pattern may take either of two forms. In the simplest case it is a single printing ASCII character, such as a or [. The character may not be a space character or the character <. This form of pattern matches a KeyPress event for the particular character. The second form of pattern is longer but more general. It has the following syntax: 

<modifier-modifier-type-detail>

The entire event pattern is surrounded by angle brackets. Inside the angle brackets are zero or more modifiers, an event type, and an extra piece of information (detail) identifying a particular button or keysym. Any of the fields may be omitted, as long as at least one of type and detail is present. The fields must be separated by white space or dashes.

Modifiers may consist of any of the values in the following list: 

Control                  Any                            
Shift                    Double                         
Lock                     Triple                         
Button1, B1              Mod1, M1, Meta, M              
Button2, B2              Mod2, M2, Alt                  
Button3, B3              Mod3, M3                       
Button4, B4              Mod4, M4                       
Button5, B5              Mod5, M5

Where more than one value is listed, separated by commas, the values are equivalent. All of the modifiers except Any, Double, and Triple have the obvious X meanings. For example, Button1 requires that button 1 be depressed when the event occurs. Under normal conditions the button and modifier state at the time of the event must match exactly those specified in the bind command. If no modifiers are specified, then events will match only if no modifiers are present. If the Any modifier is specified, then additional modifiers may be present besides those specified explicitly. For example, if button 1 is pressed while the shift and control keys are down, the specifier <Any-Control-Button-1> will match the event, but the specifier <Control-Button-1> will not.

The Double and Triple modifiers are a convenience for specifying double mouse clicks and other repeated events. They cause a particular event pattern to be repeated 2 or 3 times, and also place a time and space requirement on the sequence: for a sequence of events to match a Double or Triple pattern, all of the events must occur close together in time and without substantial mouse motion in between. For example, <Double-Button-1> is equivalent to <Button-1><Button-1> with the extra time and space requirement.

The type field may be any of the standard X event types, with a few extra abbreviations. Below is a list of all the valid types; where two name appear together, they are synonyms. 

ButtonPress, Button      Expose             Leave              
ButtonRelease            FocusIn            Map                
Circulate                FocusOut           Property           
CirculateRequest         Gravity            Reparent           
Colormap                 Keymap             ResizeRequest      
Configure                KeyPress, Key      Unmap              
ConfigureRequest         KeyRelease         Visibility         
Destroy                  MapRequest         
Enter                    Motion

The last part of a long event specification is detail. In the case of a ButtonPress or ButtonRelease event, it is the number of a button (1-5). If a button number is given, then only an event on that particular button will match; if no button number is given, then an event on any button will match. Note: giving a specific button number is different than specifying a button modifier; in the first case, it refers to a button being pressed or released, while in the second it refers to some other button that is already depressed when the matching event occurs. If a button number is given then type may be omitted: if will default to ButtonPress. For example, the specifier <1> is equivalent to <ButtonPress-1>.

If the event type is KeyPress or KeyRelease, then detail may be specified in the form of an X keysym. Keysyms are textual specifications for particular keys on the keyboard; they include all the alphanumeric ASCII characters (e.g. “a” is the keysym for the ASCII character “a”), plus descriptions for non-alphanumeric characters (“comma” is the keysym for the comma character), plus descriptions for all the non-ASCII keys on the keyboard (“Shift_L” is the keysm for the left shift key, and “F1” is the keysym for the F1 function key, if it exists). The complete list of keysyms is not presented here; it should be available in other X documentation. If necessary, you can use the %K notation described below to print out the keysym name for an arbitrary key. If a keysym detail is given, then the type field may be omitted; it will default to KeyPress. For example, <Control-comma> is equivalent to <Control-KeyPress-comma>. If a keysym detail is specified then the Shift modifier need not be specified and will be ignored if specified: each keysym already implies a particular state for the shift key.

The command argument to bind is a Tcl command string, which will be executed whenever the given event sequence occurs. Command will be executed in the same interpreter that the bind command was executed in. If command contains any % characters, then the command string will not be executed directly. Instead, a new command string will be generated by replacing each %, and the character following it, with information from the current event. The replacement depends on the character following the %, as defined in the list below. Unless otherwise indicated, the replacement string is the decimal value of the given field from the current event. Some of the substitutions are only valid for certain types of events; if they are used for other types of events the value substituted is undefined.

%%

Replaced with a single percent.

|%#|

The number of the last client request processed by the server (the serial field from the event). Valid for all event types.

|%a|

The above field from the event. Valid only for ConfigureNotify events.

|%b|

The number of the button that was pressed or released. Valid only for ButtonPress and ButtonRelease events.

|%c|

The count field from the event. Valid only for Expose, GraphicsExpose, and MappingNotify events.

|%d|

The detail field from the event. The |%d| is replaced by a string identifying the detail. For EnterNotify, LeaveNotify, FocusIn, and FocusOut events, the string will be one of the following: 

NotifyAncestor            NotifyNonlinearVirtual          
NotifyDetailNone          NotifyPointer                   
NotifyInferior            NotifyPointerRoot               
NotifyNonlinear           NotifyVirtual

For ConfigureRequest events, the substituted string will be one of the following: 

Above                     Opposite                  
Below                     TopIf                     
BottomIf

For events other than these, the substituted string is undefined. .RE

|%f|

The focus field from the event (0 or 1). Valid only for EnterNotify and LeaveNotify events.

|%h|

The height field from the event. Valid only for Configure, ConfigureNotify, Expose, GraphicsExpose, and ResizeRequest events.

|%k|

The keycode field from the event. Valid only for KeyPress and KeyRelease events.

|%m|

The mode field from the event. The substituted string is one of NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed. Valid only for EnterWindow, FocusIn, FocusOut, and LeaveWindow events.

|%o|

The override_redirect field from the event. Valid only for CreateNotify, MapNotify, ReparentNotify, and ConfigureNotify events.

|%p|

The place field from the event, substituted as one of the strings PlaceOnTop or PlaceOnBottom. Valid only for CirculateNotify and CirculateRequest events.

|%s|

The state field from the event. For ButtonPress, ButtonRelease, EnterNotify, KeyPress, KeyRelease, LeaveNotify, and MotionNotify events, a decimal string is substituted. For VisibilityNotify, one of the strings VisibilityUnobscured, VisibilityPartiallyObscured, and VisibilityFullyObscured is substituted.

|%t|

The time field from the event. Valid only for events that contain a time field.

|%v|

The value_mask field from the event. Valid only for ConfigureRequest events.

|%w|

The width field from the event. Valid only for Configure, ConfigureRequest, Expose, GraphicsExpose, and ResizeRequest events.

|%x|

The x field from the event. Valid only for events containing an x field.

|%y|

The y field from the event. Valid only for events containing a y field.

%A

Substitutes the ASCII character corresponding to the event, or the empty string if the event doesn’t correspond to an ASCII character (e.g. the shift key was pressed). XLookupString does all the work of translating from the event to an ASCII character. Valid only for KeyPress and KeyRelease events.

%B

The border_width field from the event. Valid only for ConfigureNotify and CreateWindow events.

%D

The display field from the event. Valid for all event types.

%E

The send_event field from the event. Valid for all event types.

%K

The keysym corresponding to the event, substituted as a textual string. Valid only for KeyPress and KeyRelease events.

%N

The keysym corresponding to the event, substituted as a decimal number. Valid only for KeyPress and KeyRelease events.

%R

The root window identifier from the event. Valid only for events containing a root field.

%S

The subwindow window identifier from the event. Valid only for events containing a subwindow field.

%T

The type field from the event. Valid for all event types.

%W

The path name of the window to which the event was reported (the window field from the event). Valid for all event types.

%X

The x_root field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding x-coordinate in the virtual root. Valid only for ButtonPress, ButtonRelease, KeyPress, KeyRelease, and MotionNotify events.

%Y

The y_root field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding y-coordinate in the virtual root. Valid only for ButtonPress, ButtonRelease, KeyPress, KeyRelease, and MotionNotify events.

If the replacement string for a %-replacement contains characters that are interpreted specially by the Tcl parser (such as backslashes or square brackets or spaces) additional backslashes are added during replacement so that the result after parsing is the original replacement string. For example, if command is 

insert %A

and the character typed is an open square bracket, then the command actually executed will be 

insert \e[

This will cause the insert to receive the original replacement string (open square bracket) as its first argument. If the extra backslash hadn’t been added, Tcl would not have been able to parse the command correctly.

At most one binding will trigger for any given X event. If several bindings match the recent events, the most specific binding is chosen and its command will be executed. The following tests are applied, in order, to determine which of several matching sequences is more specific: (a) a binding whose windowSpec names a particular window is more specific than a binding for a class, which is more specific than a binding whose windowSpec is all; (b) a longer sequence (in terms of number of events matched) is more specific than a shorter sequence; (c) an event pattern that specifies a specific button or key is more specific than one that doesn’t; (e) an event pattern that requires a particular modifier is more specific than one that doesn’t require the modifier; (e) an event pattern specifying the Any modifier is less specific than one that doesn’t. If the matching sequences contain more than one event, then tests (c)-(e) are applied in order from the most recent event to the least recent event in the sequences. If these tests fail to determine a winner, then the most recently registered sequence is the winner.

If an X event does not match any of the existing bindings, then the event is ignored (an unbound event is not considered to be an error).

When a sequence specified in a bind command contains more than one event pattern, then its command is executed whenever the recent events (leading up to and including the current event) match the given sequence. This means, for example, that if button 1 is clicked repeatedly the sequence <Double-ButtonPress-1> will match each button press but the first. If extraneous events that would prevent a match occur in the middle of an event sequence then the extraneous events are ignored unless they are KeyPress or ButtonPress events. For example, <Double-ButtonPress-1> will match a sequence of presses of button 1, even though there will be ButtonRelease events (and possibly MotionNotify events) between the ButtonPress events. Furthermore, a KeyPress event may be preceded by any number of other KeyPress events for modifier keys without the modifier keys preventing a match. For example, the event sequence aB will match a press of the a key, a release of the a key, a press of the Shift key, and a press of the b key: the press of Shift is ignored because it is a modifier key. Finally, if several MotionNotify events occur in a row, only the last one is used for purposes of matching binding sequences.

If an error occurs in executing the command for a binding then the tkerror mechanism is used to report the error. The command will be executed at global level (outside the context of any Tcl procedure).

See tkerror.

Keywords

form, manual

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/options.html0000644000175000017500000006330014360276512015472 0ustar cammcamm options (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.12 options

options \- Standard options supported by widgets

Description

This manual entry describes the common configuration options supported by widgets in the Tk toolkit. Every widget does not necessarily support every option (see the manual entries for individual widgets for a list of the standard options supported by that widget), but if a widget does support an option with one of the names listed below, then the option has exactly the effect described below.

In the descriptions below, “Name” refers to the option’s name in the option database (e.g. in .Xdefaults files). “Class” refers to the option’s class value in the option database. “Command-Line Switch” refers to the switch used in widget-creation and configure widget commands to set this value. For example, if an option’s command-line switch is :foreground and there exists a widget .a.b.c, then the command 


(.a.b.c  :configure  :foreground "black")

may be used to specify the value black for the option in the the widget .a.b.c. Command-line switches may be abbreviated, as long as the abbreviation is unambiguous.

:activebackground

Name="activeBackground" Class="Foreground"


Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some action to occur.

:activeborderwidth

Name="activeBorderWidth" Class="BorderWidth"


Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above for definition of active elements. The value may have any of the forms acceptable to Tk_GetPixels. This option is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons).

:activeforeground

Name="activeForeground" Class="Background"


Specifies foreground color to use when drawing active elements. See above for definition of active elements.

:anchor

Name="anchor" Class="Anchor"


Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget. Must be one of the values n, ne, e, se, s, sw, w, nw, or center. For example, nw means display the information such that its top-left corner is at the top-left corner of the widget.

:background or :bg

Name="background" Class="Background"


Specifies the normal background color to use when displaying the widget.

:bitmap

Name="bitmap" Class="Bitmap"


Specifies a bitmap to display in the widget, in any of the forms acceptable to Tk_GetBitmap. The exact way in which the bitmap is displayed may be affected by other options such as anchor or justify. Typically, if this option is specified then it overrides other options that specify a textual value to display in the widget; the bitmap option may be reset to an empty string to re-enable a text display.

:borderwidth or :bd

Name="borderWidth" Class="BorderWidth"


Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the widget (if such a border is being drawn; the relief option typically determines this). The value may also be used when drawing 3-D effects in the interior of the widget. The value may have any of the forms acceptable to Tk_GetPixels.

:cursor

Name="cursor" Class="Cursor"


Specifies the mouse cursor to be used for the widget. The value may have any of the forms acceptable to Tk_GetCursor.

:cursorbackground

Name="cursorBackground" Class="Foreground"


Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). \fIThis option is obsolete and is gradually being replaced by the insertBackground option.

:cursorborderwidth

Name="cursorBorderWidth" Class="BorderWidth"


Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. \fIThis option is obsolete and is gradually being replaced by the insertBorderWidth option.

:cursorofftime

Name="cursorOffTime" Class="OffTime"


Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain “off” in each blink cycle. If this option is zero then the cursor doesn’t blink: it is on all the time. \fIThis option is obsolete and is gradually being replaced by the insertOffTime option.

:cursorontime

Name="cursorOnTime" Class="OnTime"


Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain “on” in each blink cycle. \fIThis option is obsolete and is gradually being replaced by the insertOnTime option.

:cursorwidth

Name="cursorWidth" Class="CursorWidth"


Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. If a border has been specified for the cursor (using the cursorBorderWidth option), the border will be drawn inside the width specified by the cursorWidth option. \fIThis option is obsolete and is gradually being replaced by the insertWidth option.

:disabledforeground

Name="disabledForeground" Class="DisabledForeground"


Specifies foreground color to use when drawing a disabled element. If the option is specified as an empty string (which is typically the case on monochrome displays), disabled elements are drawn with the normal fooreground color but they are dimmed by drawing them with a stippled fill pattern.

:exportselection

Name="exportSelection" Class="ExportSelection"


Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the forms accepted by Tcl_GetBoolean, such as true, false, 0, 1, yes, or no. If the selection is exported, then selecting in the widget deselects the current X selection, selecting outside the widget deselects any widget selection, and the widget will respond to selection retrieval requests when it has a selection. The default is usually for widgets to export selections.

:font

Name="font" Class="Font"


Specifies the font to use when drawing text inside the widget.

:foreground or :fg

Name="foreground" Class="Foreground"


Specifies the normal foreground color to use when displaying the widget.

:geometry

Name="geometry" Class="Geometry"


Specifies the desired geometry for the widget’s window, in the form widthxheight, where width is the desired width of the window and height is the desired height. The units for width and height depend on the particular widget. For widgets displaying text the units are usually the size of the characters in the font being displayed; for other widgets the units are usually pixels.

:insertbackground

Name="insertBackground" Class="Foreground"


Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection).

:insertborderwidth

Name="insertBorderWidth" Class="BorderWidth"


Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels.

:insertofftime

Name="insertOffTime" Class="OffTime"


Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain “off” in each blink cycle. If this option is zero then the cursor doesn’t blink: it is on all the time.

:insertontime

Name="insertOnTime" Class="OnTime"


Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain “on” in each blink cycle.

:insertwidth

Name="insertWidth" Class="InsertWidth"


Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. If a border has been specified for the insertion cursor (using the insertBorderWidth option), the border will be drawn inside the width specified by the insertWidth option.

:orient

Name="orient" Class="Orient"


For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars, this option specifies which orientation should be used. Must be either horizontal or vertical or an abbreviation of one of these.

:padx

Name="padX" Class="Pad"


Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction. The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs, the widget will add this amount to the width it would normally need (as determined by the width of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space to the left and/or right of what it displays inside.

:pady

Name="padY" Class="Pad"


Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction. The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs, the widget will add this amount to the height it would normally need (as determined by the height of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space above and/or below what it displays inside.

:relief

Name="relief" Class="Relief"


Specifies the 3-D effect desired for the widget. Acceptable values are raised, sunken, flat, ridge, and groove. The value indicates how the interior of the widget should appear relative to its exterior; for example, raised means the interior of the widget should appear to protrude from the screen, relative to the exterior of the widget.

:repeatdelay

Name="repeatDelay" Class="RepeatDelay"


Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used, for example, on the up- and down-arrows in scrollbars.

:repeatinterval

Name="repeatInterval" Class="RepeatInterval"


Used in conjunction with repeatDelay: once auto-repeat begins, this option determines the number of milliseconds between auto-repeats.

:scrollcommand

Name="scrollCommand" Class="ScrollCommand"


Specifies the prefix for a command used to communicate with scrollbar widgets. When the view in the widget’s window changes (or whenever anything else occurs that could change the display in a scrollbar, such as a change in the total size of the widget’s contents), the widget will generate a Tcl command by concatenating the scroll command and four numbers. The four numbers are, in order: the total size of the widget’s contents, in unspecified units (“unit” is a widget-specific term; for widgets displaying text, the unit is a line); the maximum number of units that may be displayed at once in the widget’s window, given its current size; the index of the top-most or left-most unit currently visible in the window (index 0 corresponds to the first unit); and the index of the bottom-most or right-most unit currently visible in the window. This command is then passed to the Tcl interpreter for execution. Typically the scrollCommand option consists of the path name of a scrollbar widget followed by “set”, e.g. “.x.scrollbar set”: this will cause the scrollbar to be updated whenever the view in the window changes. If this option is not specified, then no command will be executed.

The scrollCommand option is used for widgets that support scrolling in only one direction. For widgets that support scrolling in both directions, this option is replaced with the xScrollCommand and yScrollCommand options.

:selectbackground

Name="selectBackground" Class="Foreground"


Specifies the background color to use when displaying selected items.

:selectborderwidth

Name="selectBorderWidth" Class="BorderWidth"


Specifies a non-negative value indicating the width of the 3-D border to draw around selected items. The value may have any of the forms acceptable to Tk_GetPixels.

:selectforeground

Name="selectForeground" Class="Background"


Specifies the foreground color to use when displaying selected items.

:setgrid

Name="setGrid" Class="SetGrid"


Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window. This option is typically used in text widgets, where the information in the widget has a natural size (the size of a character) and it makes sense for the window’s dimensions to be integral numbers of these units. These natural window sizes form a grid. If the setGrid option is set to true then the widget will communicate with the window manager so that when the user interactively resizes the top-level window that contains the widget, the dimensions of the window will be displayed to the user in grid units and the window size will be constrained to integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the wm manual entry for more details.

:text

Name="text" Class="Text"


Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the particular widget and may be determined by other options, such as anchor or justify.

:textvariable

Name="textVariable" Class="Variable"


Specifies the name of a variable. The value of the variable is a text string to be displayed inside the widget; if the variable value changes then the widget will automatically update itself to reflect the new value. The way in which the string is displayed in the widget depends on the particular widget and may be determined by other options, such as anchor or justify.

:underline

Name="underline" Class="Underline"


Specifies the integer index of a character to underline in the widget. This option is typically used to indicate keyboard traversal characters in menu buttons and menu entries. 0 corresponds to the first character of the text displayed in the widget, 1 to the next character, and so on.

:xscrollcommand

Name="xScrollCommand" Class="ScrollCommand"


Specifies the prefix for a command used to communicate with horizontal scrollbars. This option is treated in the same way as the scrollCommand option, except that it is used for horizontal scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of scrollCommand for complete details on how this option is used.

:yscrollcommand

Name="yScrollCommand" Class="ScrollCommand"


Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the same way as the scrollCommand option, except that it is used for vertical scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of scrollCommand for complete details on how this option is used.

Keywords

class, name, standard option, switch

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/Lisp-Functions-Invoked-from-Graphics.html0000644000175000017500000002050314360276512022746 0ustar cammcamm Lisp Functions Invoked from Graphics (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.6 Lisp Functions Invoked from Graphics

It is possible to make certain areas of a window mouse sensitive, or to run commands on reception of certain events such as keystrokes, while the focus is in a certain window. This is done by having a lisp function invoked or some lisp form evaluated. We shall refer to such a lisp function or form as a command.

For example 

(button '.button :text "Hello" :command '(print "hi"))
(button '.jim :text "Call Jim" :command 'call-jim)

In the first case when the window .button is clicked on, the word "hi" will be printed in the lisp to standard output. In the second case call-jim will be funcalled with no arguments.

A command must be one of the following three types. What happens depends on which type it is:

‘function’

If the value satisfies functionp then it will be called with a number of arguments which is dependent on the way it was bound, to graphics.

‘string’

If the command is a string, then it is passed directly to TCL/TK for evaluation on that side. Lisp will not be required for the evaluation when the command is invoked.

‘lisp form’

Any other lisp object is regarded as a lisp form to be eval’d, and this will be done when the command is invoked.

The following keywords accept as their value a command: 

   :command
   :yscroll    :yscrollcommand
   :xscroll    :xscrollcommand
   :scrollcommand
   :bind

and in addition bind takes a command as its third argument, see See bind.

Below we give three different examples using the 3 possibilities for a command: functionp, string, and lisp form. They all accomplish exactly the same thing. For given a frame .frame we could construct a listbox in it as: 

(listbox '.frame.listbox :yscroll 'joe)

Then whenever the listbox view position changes, or text is inserted, so that something changes, the function joe will be invoked with 4 arguments giving the totalsize of the text, maximum number of units the window can display, the index of the top unit, and finally the index of the bottom unit. What these arguments are is specific to the widget listbox and is documented See listbox.

joe might be used to do anything, but a common usage is to have joe alter the position of some other window, such as a scroll bar window. Indeed if .scrollbar is a scrollbar then the function 

(defun joe (a b c d)
  (.scrollbar :set a b c d))

would look after sizing the scrollbar appropriately for the percentage of the window visible, and positioning it.

A second method of accomplishing this identical, using a string (the second type of command), 

(listbox '.frame.listbox :yscroll ".scrollbar set")

and this will not involve a call back to lisp. It uses the fact that the TK graphics side understands the window name .scrollbar and that it takes the option set. Note that it does not get the : before the keyword in this case.

In the case of a command which is a lisp form but is not installed via bind or :bind, then the form will be installed as 

#'(lambda (&rest *arglist*) lisp-form)

where the lisp-form might wish to access the elements of the special variable *arglist*. Most often this list will be empty, but for example if the command was setup for .scale which is a scale, then the command will be supplied one argument which is the new numeric value which is the scale position. A third way of accomplishing the scrollbar setting using a lisp form is: 

(listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*))

The bind command and :bind keyword, have an additional wrinkle, see See bind. These are associated to an event in a particular window, and the lisp function or form to be evaled must have access to that information. For example the x y position, the window name, the key pressed, etc. This is done via percent symbols which are specified, see See bind. 

(bind "Entry" "<Control-KeyPress>" '(emacs-move  %W %A ))

will cause the function emacs-move to be be invoked whenever a control key is pressed (unless there are more key specific or window specific bindings of said key). It will be invoked with two arguments, the first %W indicating the window in which it was invoked, and the second being a string which is the ascii keysym which was pressed at the same time as the control key.

These percent constructs are only permitted in commands which are invoked via bind or :bind. The lisp form which is passed as the command, is searched for the percent constructs, and then a function 

#'(lambda (%W %A) (emacs-move %W %A))

will be invoked with two arguments, which will be supplied by the TK graphics server, at the time the command is invoked. The *arglist* construct is not available for these commands.

Next: , Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/scrollbar.html0000644000175000017500000002535514360276512015772 0ustar cammcamm scrollbar (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.6 scrollbar

scrollbar \- Create and manipulate scrollbar widgets

Synopsis

scrollbar pathName ?options?

Standard Options

activeForeground       cursor           relief               
background             foreground       repeatDelay          
borderWidth            orient           repeatInterval

See options, for more information.

Arguments for Scrollbar

:command

Name="command" Class="Command"


Specifies the prefix of a Tcl command to invoke to change the view in the widget associated with the scrollbar. When a user requests a view change by manipulating the scrollbar, a Tcl command is invoked. The actual command consists of this option followed by a space and a number. The number indicates the logical unit that should appear at the top of the associated window.

:width

Name="width" Class="Width"


Specifies the desired narrow dimension of the scrollbar window, not including 3-D border, if any. For vertical scrollbars this will be the width and for horizontal scrollbars this will be the height. The value may have any of the forms acceptable to Tk_GetPixels.

Description

The scrollbar command creates a new window (given by the pathName argument) and makes it into a scrollbar widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scrollbar such as its colors, orientation, and relief. The scrollbar command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A scrollbar is a widget that displays two arrows, one at each end of the scrollbar, and a slider in the middle portion of the scrollbar. A scrollbar is used to provide information about what is visible in an associated window that displays an object of some sort (such as a file being edited or a drawing). The position and size of the slider indicate which portion of the object is visible in the associated window. For example, if the slider in a vertical scrollbar covers the top third of the area between the two arrows, it means that the associated window displays the top third of its object.

Scrollbars can be used to adjust the view in the associated window by clicking or dragging with the mouse. See the BINDINGS section below for details.

A Scrollbar Widget’s Arguments

The scrollbar command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for scrollbar widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the scrollbar command.

pathName :get

Returns a Tcl list containing four decimal values, which are the current totalUnits, widnowUnits, firstUnit, and lastUnit values for the scrollbar. These are the values from the most recent set widget command on the scrollbar.

pathName :set totalUnits windowUnits firstUnit lastUnit

This command is invoked to give the scrollbar information about the widget associated with the scrollbar. TotalUnits is an integer value giving the total size of the object being displayed in the associated widget. The meaning of one unit depends on the associated widget; for example, in a text editor widget units might correspond to lines of text. WindowUnits indicates the total number of units that can fit in the associated window at one time. FirstUnit and lastUnit give the indices of the first and last units currently visible in the associated window (zero corresponds to the first unit of the object). This command should be invoked by the associated widget whenever its object or window changes size and whenever it changes the view in its window.

Bindings

The description below assumes a vertically-oriented scrollbar. For a horizontally-oriented scrollbar replace the words “up”, “down”, “top”, and “bottom” with “left”, “right”, “left”, and “right”, respectively

A scrollbar widget is divided into five distinct areas. From top to bottom, they are: the top arrow, the top gap (the empty space between the arrow and the slider), the slider, the bottom gap, and the bottom arrow. Pressing mouse button 1 in each area has a different effect:

top arrow

Causes the view in the associated window to shift up by one unit (i.e. the object appears to move down one unit in its window). If the button is held down the action will auto-repeat.

top gap

Causes the view in the associated window to shift up by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very top of the window will now appear at the very bottom). If the button is held down the action will auto-repeat.

slider

Pressing button 1 in this area has no immediate effect except to cause the slider to appear sunken rather than raised. However, if the mouse is moved with the button down then the slider will be dragged, adjusting the view as the mouse is moved.

bottom gap

Causes the view in the associated window to shift down by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very bottom of the window will now appear at the very top). If the button is held down the action will auto-repeat.

bottom arrow

Causes the view in the associated window to shift down by one unit (i.e. the object appears to move up one unit in its window). If the button is held down the action will auto-repeat.

Note: none of the actions described above has an immediate impact on the position of the slider in the scrollbar. It simply invokes the command specified in the command option to notify the associated widget that a change in view is desired. If the view is actually changed then the associated widget must invoke the scrollbar’s set widget command to change what is displayed in the scrollbar.

Keywords

scrollbar, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/exit.html0000644000175000017500000000524414360276512014753 0ustar cammcamm exit (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.5 exit

exit \- Exit the process

Synopsis

exit ?returnCode?

Description

Terminate the process, returning returnCode (an integer) to the system as the exit status. If returnCode isn’t specified then it defaults to 0. This command replaces the Tcl command by the same name. It is identical to Tcl’s exit command except that before exiting it destroys all the windows managed by the process. This allows various cleanup operations to be performed, such as removing application names from the global registry of applications.

Keywords

exit, process

gcl-2.6.14/info/gcl-tk/destroy.html0000644000175000017500000000511714360276512015472 0ustar cammcamm destroy (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.3 destroy

destroy \- Destroy one or more windows

Synopsis

destroy ?window window ...?

Description

This command deletes the windows given by the window arguments, plus all of their descendants. If a window “.” is deleted then the entire application will be destroyed. The windows are destroyed in order, and if an error occurs in destroying a window the command aborts without destroying the remaining windows.

Keywords

application, destroy, window

gcl-2.6.14/info/gcl-tk/lower.html0000644000175000017500000000610014360276512015122 0ustar cammcamm lower (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.9 lower

lower \- Change a window’s position in the stacking order

Synopsis

lower window ?belowThis?

Description

If the belowThis argument is omitted then the command lowers window so that it is below all of its siblings in the stacking order (it will be obscured by any siblings that overlap it and will not obscure any siblings). If belowThis is specified then it must be the path name of a window that is either a sibling of window or the descendant of a sibling of window. In this case the lower command will insert window into the stacking order just below belowThis (or the ancestor of belowThis that is a sibling of window); this could end up either raising or lowering window.

Keywords

lower, obscure, stacking order

gcl-2.6.14/info/gcl-tk/Control.html0000644000175000017500000001270314360276512015420 0ustar cammcamm Control (GCL TK Manual)

Previous: , Up: Top   [Contents]

3 Control

• after  
• bind  
• destroy  
• tk-dialog  
• exit  
• focus  
• grab  
• tk-listbox-single-select  
• lower  
• tk-menu-bar  
• option  
• options  
• pack-old  
• pack  
• place  
• raise  
• selection  
• send  
• tk  
• tkerror  
• tkvars  
• tkwait  
• update  
• winfo  
• wm  
gcl-2.6.14/info/gcl-tk/tk_002ddialog.html0000644000175000017500000001032314360276512016317 0ustar cammcamm tk-dialog (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.4 tk-dialog

tk-dialog \- Create modal dialog and wait for response

Synopsis

tk-dialog window title text bitmap default string string ...

Description

This procedure is part of the Tk script library. Its arguments describe a dialog box:

window

Name of top-level window to use for dialog. Any existing window by this name is destroyed.

title

Text to appear in the window manager’s title bar for the dialog.

text

Message to appear in the top portion of the dialog box.

bitmap

If non-empty, specifies a bitmap to display in the top portion of the dialog, to the left of the text. If this is an empty string then no bitmap is displayed in the dialog.

default

If this is an integer greater than or equal to zero, then it gives the index of the button that is to be the default button for the dialog (0 for the leftmost button, and so on). If less than zero or an empty string then there won’t be any default button.

string

There will be one button for each of these arguments. Each string specifies text to display in a button, in order from left to right.

After creating a dialog box, tk-dialog waits for the user to select one of the buttons either by clicking on the button with the mouse or by typing return to invoke the default button (if any). Then it returns the index of the selected button: 0 for the leftmost button, 1 for the button next to it, and so on.

While waiting for the user to respond, tk-dialog sets a local grab. This prevents the user from interacting with the application in any way except to invoke the dialog box.

Keywords

bitmap, dialog, modal

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/canvas.html0000644000175000017500000022112714360276512015255 0ustar cammcamm canvas (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.4 canvas

canvas \- Create and manipulate canvas widgets

Synopsis

canvas pathName ?options?

Standard Options

background       insertBorderWidth relief            xScrollCommand 
borderWidth      insertOffTime     selectBackground  yScrollCommand 
cursor           insertOnTime      selectBorderWidth 
insertBackground insertWidth       selectForeground

See options, for more information.

Arguments for Canvas

:closeenough

Name="closeEnough" Class="CloseEnough"


Specifies a floating-point value indicating how close the mouse cursor must be to an item before it is considered to be “inside” the item. Defaults to 1.0.

:confine

Name="confine" Class="Confine"


Specifies a boolean value that indicates whether or not it should be allowable to set the canvas’s view outside the region defined by the scrollRegion argument. Defaults to true, which means that the view will be constrained within the scroll region.

:height

Name="height" Class="Height"


Specifies a desired window height that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below.

:scrollincrement

Name="scrollIncrement" Class="ScrollIncrement"


Specifies a distance used as increment during scrolling: when one of the arrow buttons on an associated scrollbar is pressed, the picture will shift by this distance. The distance may be specified in any of the forms described in the COORDINATES section below.

:scrollregion

Name="scrollRegion" Class="ScrollRegion"


Specifies a list with four coordinates describing the left, top, right, and bottom coordinates of a rectangular region. This region is used for scrolling purposes and is considered to be the boundary of the information in the canvas. Each of the coordinates may be specified in any of the forms given in the COORDINATES section below.

:width

Name="width" Class="width"


Specifies a desired window width that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below.

Introduction

The canvas command creates a new window (given by the pathName argument) and makes it into a canvas widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the canvas such as its colors and 3-D relief. The canvas command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

Canvas widgets implement structured graphics. A canvas displays any number of items, which may be things like rectangles, circles, lines, and text. Items may be manipulated (e.g. moved or re-colored) and commands may be associated with items in much the same way that the bind command allows commands to be bound to widgets. For example, a particular command may be associated with the <Button-1> event so that the command is invoked whenever button 1 is pressed with the mouse cursor over an item. This means that items in a canvas can have behaviors defined by the Tcl scripts bound to them.

Display List

The items in a canvas are ordered for purposes of display, with the first item in the display list being displayed first, followed by the next item in the list, and so on. Items later in the display list obscure those that are earlier in the display list and are sometimes referred to as being “on top” of earlier items. When a new item is created it is placed at the end of the display list, on top of everything else. Widget commands may be used to re-arrange the order of the display list.

Item Ids And Tags

Items in a canvas widget may be named in either of two ways: by id or by tag. Each item has a unique identifying number which is assigned to that item when it is created. The id of an item never changes and id numbers are never re-used within the lifetime of a canvas widget.

Each item may also have any number of tags associated with it. A tag is just a string of characters, and it may take any form except that of an integer. For example, “x123” is OK but “123” isn’t. The same tag may be associated with many different items. This is commonly done to group items in various interesting ways; for example, all selected items might be given the tag “selected”.

The tag all is implicitly associated with every item in the canvas; it may be used to invoke operations on all the items in the canvas.

The tag current is managed automatically by Tk; it applies to the current item, which is the topmost item whose drawn area covers the position of the mouse cursor. If the mouse is not in the canvas widget or is not over an item, then no item has the current tag.

When specifying items in canvas widget commands, if the specifier is an integer then it is assumed to refer to the single item with that id. If the specifier is not an integer, then it is assumed to refer to all of the items in the canvas that have a tag matching the specifier. The symbol tagOrId is used below to indicate that an argument specifies either an id that selects a single item or a tag that selects zero or more items. Some widget commands only operate on a single item at a time; if tagOrId is specified in a way that names multiple items, then the normal behavior is for the command to use the first (lowest) of these items in the display list that is suitable for the command. Exceptions are noted in the widget command descriptions below.

Coordinates

All coordinates related to canvases are stored as floating-point numbers. Coordinates and distances are specified in screen units, which are floating-point numbers optionally followed by one of several letters. If no letter is supplied then the distance is in pixels. If the letter is m then the distance is in millimeters on the screen; if it is c then the distance is in centimeters; i means inches, and p means printers points (1/72 inch). Larger y-coordinates refer to points lower on the screen; larger x-coordinates refer to points farther to the right.

Transformations

Normally the origin of the canvas coordinate system is at the upper-left corner of the window containing the canvas. It is possible to adjust the origin of the canvas coordinate system relative to the origin of the window using the xview and yview widget commands; this is typically used for scrolling. Canvases do not support scaling or rotation of the canvas coordinate system relative to the window coordinate system.

Indidividual items may be moved or scaled using widget commands described below, but they may not be rotated.

Indices

Text items support the notion of an index for identifying particular positions within the item. Indices are used for commands such as inserting text, deleting a range of characters, and setting the insertion cursor position. An index may be specified in any of a number of ways, and different types of items may support different forms for specifying indices. Text items support the following forms for an index; if you define new types of text-like items, it would be advisable to support as many of these forms as practical. Note that it is possible to refer to the character just after the last one in the text item; this is necessary for such tasks as inserting new text at the end of the item.

number

A decimal number giving the position of the desired character within the text item. 0 refers to the first character, 1 to the next character, and so on. A number less than 0 is treated as if it were zero, and a number greater than the length of the text item is treated as if it were equal to the length of the text item.

end

Refers to the character just after the last one in the item (same as the number of characters in the item).

insert

Refers to the character just before which the insertion cursor is drawn in this item.

sel.first

Refers to the first selected character in the item. If the selection isn’t in this item then this form is illegal.

sel.last

Refers to the last selected character in the item. If the selection isn’t in this item then this form is illegal.

@x,y

Refers to the character at the point given by x and y, where x and y are specified in the coordinate system of the canvas. If x and y lie outside the coordinates covered by the text item, then they refer to the first or last character in the line that is closest to the given point.

A Canvas Widget’s Arguments

The canvas command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following widget commands are possible for canvas widgets:

pathName :addtag tag searchSpec ?arg arg ...?

For each item that meets the constraints specified by searchSpec and the args, add tag to the list of tags associated with the item if it isn’t already present on that list. It is possible that no items will satisfy the constraints given by searchSpec and args, in which case the command has no effect. This command returns an empty string as result. SearchSpec and arg’s may take any of the following forms:

above tagOrId

Selects the item just after (above) the one given by tagOrId in the display list. If tagOrId denotes more than one item, then the last (topmost) of these items in the display list is used.

all

Selects all the items in the canvas.

below tagOrId

Selects the item just before (below) the one given by tagOrId in the display list. If tagOrId denotes more than one item, then the first (lowest) of these items in the display list is used.

closest x y ?halo? ?start?

Selects the item closest to the point given by x and y. If more than one item is at the same closest distance (e.g. two items overlap the point), then the top-most of these items (the last one in the display list) is used. If halo is specified, then it must be a non-negative value. Any item closer than halo to the point is considered to overlap it. The start argument may be used to step circularly through all the closest items. If start is specified, it names an item using a tag or id (if by tag, it selects the first item in the display list with the given tag). Instead of selecting the topmost closest item, this form will select the topmost closest item that is below start in the display list; if no such item exists, then the selection behaves as if the start argument had not been specified.

enclosed x1 y1 x2 y2

Selects all the items completely enclosed within the rectangular region given by x1, y1, x2, and y2. X1 must be no greater then x2 and y1 must be no greater than y2.

overlapping x1 y1 x2 y2

Selects all the items that overlap or are enclosed within the rectangular region given by x1, y1, x2, and y2. X1 must be no greater then x2 and y1 must be no greater than y2.

withtag tagOrId

Selects all the items given by tagOrId.

pathName :bbox tagOrId ?tagOrId tagOrId ...?

Returns a list with four elements giving an approximate bounding box for all the items named by the tagOrId arguments. The list has the form “x1 y1 x2 y2” such that the drawn areas of all the named elements are within the region bounded by x1 on the left, x2 on the right, y1 on the top, and y2 on the bottom. The return value may overestimate the actual bounding box by a few pixels. If no items match any of the tagOrId arguments then an empty string is returned.

pathName :bind tagOrId ?sequence? ?command?

This command associates command with all the items given by tagOrId such that whenever the event sequence given by sequence occurs for one of the items the command will be invoked. This widget command is similar to the bind command except that it operates on items in a canvas rather than entire widgets. See the bind manual entry for complete details on the syntax of sequence and the substitutions performed on command before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same sequence and tagOrId (if the first character of command is “+” then command augments an existing binding rather than replacing it). In this case the return value is an empty string. If command is omitted then the command returns the command associated with tagOrId and sequence (an error occurs if there is no such binding). If both command and sequence are omitted then the command returns a list of all the sequences for which bindings have been defined for tagOrId.

The only events for which bindings may be specified are those related to the mouse and keyboard, such as Enter, Leave, ButtonPress, Motion, and KeyPress. The handling of events in canvases uses the current item defined in ITEM IDS AND TAGS above. Enter and Leave events trigger for an item when it becomes the current item or ceases to be the current item; note that these events are different than Enter and Leave events for windows. Mouse-related events are directed to the current item, if any. Keyboard-related events are directed to the focus item, if any (see the focus widget command below for more on this).

It is possible for multiple commands to be bound to a single event sequence for a single object. This occurs, for example, if one command is associated with the item’s id and another is associated with one of the item’s tags. When this occurs, the first matching binding is used. A binding for the item’s id has highest priority, followed by the oldest tag for the item and proceeding through all of the item’s tags up through the most-recently-added one. If a binding is associated with the tag all, the binding will have lower priority than all other bindings associated with the item.

pathName :canvasx screenx ?gridspacing?

Given a screen x-coordinate screenx this command returns the canvas x-coordinate that is displayed at that location. If gridspacing is specified, then the canvas coordinate is rounded to the nearest multiple of gridspacing units.

pathName :canvasy screeny ?gridspacing?

Given a screen y-coordinate screeny this command returns the canvas y-coordinate that is displayed at that location. If gridspacing is specified, then the canvas coordinate is rounded to the nearest multiple of gridspacing units.

pathName :configure ?option? ?value? ?option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the canvas command.

pathName :coords tagOrId ?x0 y0 ...?

Query or modify the coordinates that define an item. If no coordinates are specified, this command returns a list whose elements are the coordinates of the item named by tagOrId. If coordinates are specified, then they replace the current coordinates for the named item. If tagOrId refers to multiple items, then the first one in the display list is used.

pathName :create type x y ?x y ...? ?option value ...?

Create a new item in pathName of type type. The exact format of the arguments after type depends on type, but usually they consist of the coordinates for one or more points, followed by specifications for zero or more item options. See the subsections on individual item types below for more on the syntax of this command. This command returns the id for the new item.

pathName :dchars tagOrId first ?last?

For each item given by tagOrId, delete the characters in the range given by first and last, inclusive. If some of the items given by tagOrId don’t support text operations, then they are ignored. First and last are indices of characters within the item(s) as described in INDICES above. If last is omitted, it defaults to first. This command returns an empty string.

pathName :delete ?tagOrId tagOrId ...?

Delete each of the items given by each tagOrId, and return an empty string.

pathName :dtag tagOrId ?tagToDelete?

For each of the items given by tagOrId, delete the tag given by tagToDelete from the list of those associated with the item. If an item doesn’t have the tag tagToDelete then the item is unaffected by the command. If tagToDelete is omitted then it defaults to tagOrId. This command returns an empty string.

pathName :find searchCommand ?arg arg ...?

This command returns a list consisting of all the items that meet the constraints specified by searchCommand and arg’s. SearchCommand and args have any of the forms accepted by the addtag command.

pathName :focus ?tagOrId?

Set the keyboard focus for the canvas widget to the item given by tagOrId. If tagOrId refers to several items, then the focus is set to the first such item in the display list that supports the insertion cursor. If tagOrId doesn’t refer to any items, or if none of them support the insertion cursor, then the focus isn’t changed. If tagOrId is an empty string, then the focus item is reset so that no item has the focus. If tagOrId is not specified then the command returns the id for the item that currently has the focus, or an empty string if no item has the focus.

Once the focus has been set to an item, the item will display the insertion cursor and all keyboard events will be directed to that item. The focus item within a canvas and the focus window on the screen (set with the focus command) are totally independent: a given item doesn’t actually have the input focus unless (a) its canvas is the focus window and (b) the item is the focus item within the canvas. In most cases it is advisable to follow the focus widget command with the focus command to set the focus window to the canvas (if it wasn’t there already).

pathName :gettags tagOrId

Return a list whose elements are the tags associated with the item given by tagOrId. If tagOrId refers to more than one item, then the tags are returned from the first such item in the display list. If tagOrId doesn’t refer to any items, or if the item contains no tags, then an empty string is returned.

pathName :icursor tagOrId index

Set the position of the insertion cursor for the item(s) given by tagOrId to just before the character whose position is given by index. If some or all of the items given by tagOrId don’t support an insertion cursor then this command has no effect on them. See INDICES above for a description of the legal forms for index. Note: the insertion cursor is only displayed in an item if that item currently has the keyboard focus (see the widget command focus, below), but the cursor position may be set even when the item doesn’t have the focus. This command returns an empty string.

pathName :index tagOrId index

This command returns a decimal string giving the numerical index within tagOrId corresponding to index. Index gives a textual description of the desired position as described in INDICES above. The return value is guaranteed to lie between 0 and the number of characters within the item, inclusive. If tagOrId refers to multiple items, then the index is processed in the first of these items that supports indexing operations (in display list order).

pathName :insert tagOrId beforeThis string

For each of the items given by tagOrId, if the item supports text insertion then string is inserted into the item’s text just before the character whose index is beforeThis. See INDICES above for information about the forms allowed for beforeThis. This command returns an empty string.

pathName :itemconfigure tagOrId ?option? ?value? ?option value ...?

This command is similar to the configure widget command except that it modifies item-specific options for the items given by tagOrId instead of modifying options for the overall canvas widget. If no option is specified, returns a list describing all of the available options for the first item given by tagOrId (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s) in each of the items given by tagOrId; in this case the command returns an empty string. The options and values are the same as those permissible in the create widget command when the item(s) were created; see the sections describing individual item types below for details on the legal options.

pathName :lower tagOrId ?belowThis?

Move all of the items given by tagOrId to a new position in the display list just before the item given by belowThis. If tagOrId refers to more than one item then all are moved but the relative order of the moved items will not be changed. BelowThis is a tag or id; if it refers to more than one item then the first (lowest) of these items in the display list is used as the destination location for the moved items. This command returns an empty string.

pathName :move tagOrId xAmount yAmount

Move each of the items given by tagOrId in the canvas coordinate space by adding xAmount to the x-coordinate of each point associated with the item and yAmount to the y-coordinate of each point associated with the item. This command returns an empty string.

pathName :postscript ?option value option value ...?

Generate a Postscript representation for part or all of the canvas. If the :file option is specified then the Postscript is written to a file and an empty string is returned; otherwise the Postscript is returned as the result of the command. The Postscript is created in Encapsulated Postscript form using version 3.0 of the Document Structuring Conventions. The option\-value argument pairs provide additional information to control the generation of Postscript. The following options are supported:

:colormap varName

VarName must be the name of a global array variable that specifies a color mapping to use in the Postscript. Each element of varName must consist of Postscript code to set a particular color value (e.g. “1.0 1.0 0.0 setrgbcolor”). When outputting color information in the Postscript, Tk checks to see if there is an element of varName with the same name as the color. If so, Tk uses the value of the element as the Postscript command to set the color. If this option hasn’t been specified, or if there isn’t an entry in varName for a given color, then Tk uses the red, green, and blue intensities from the X color.

:colormode mode

Specifies how to output color information. Mode must be either color (for full color output), gray (convert all colors to their gray-scale equivalents) or mono (convert all colors to black or white).

:file fileName

Specifies the name of the file in which to write the Postscript. If this option isn’t specified then the Postscript is returned as the result of the command instead of being written to a file.

:fontmap varName

VarName must be the name of a global array variable that specifies a font mapping to use in the Postscript. Each element of varName must consist of a Tcl list with two elements, which are the name and point size of a Postscript font. When outputting Postscript commands for a particular font, Tk checks to see if varName contains an element with the same name as the font. If there is such an element, then the font information contained in that element is used in the Postscript. Otherwise Tk attempts to guess what Postscript font to use. Tk’s guesses generally only work for well-known fonts such as Times and Helvetica and Courier, and only if the X font name does not omit any dashes up through the point size. For example, \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but \fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the dashes to parse the font name).

:height size

Specifies the height of the area of the canvas to print. Defaults to the height of the canvas window.

:pageanchor anchor

Specifies which point of the printed area should be appear over the positioning point on the page (which is given by the :pagex and :pagey options). For example, :pageanchor n means that the top center of the printed area should be over the positioning point. Defaults to center.

:pageheight size

Specifies that the Postscript should be scaled in both x and y so that the printed area is size high on the Postscript page. Size consists of a floating-point number followed by c for centimeters, i for inches, m for millimeters, or p or nothing for printer’s points (1/72 inch). Defaults to the height of the printed area on the screen. If both :pageheight and :pagewidth are specified then the scale factor from the later option is used (non-uniform scaling is not implemented).

:pagewidth size

Specifies that the Postscript should be scaled in both x and y so that the printed area is size wide on the Postscript page. Size has the same form as for :pageheight. Defaults to the width of the printed area on the screen. If both :pageheight and :pagewidth are specified then the scale factor from the later option is used (non-uniform scaling is not implemented).

:pagex position

Position gives the x-coordinate of the positioning point on the Postscript page, using any of the forms allowed for :pageheight. Used in conjunction with the :pagey and :pageanchor options to determine where the printed area appears on the Postscript page. Defaults to the center of the page.

:pagey position

Position gives the y-coordinate of the positioning point on the Postscript page, using any of the forms allowed for :pageheight. Used in conjunction with the :pagex and :pageanchor options to determine where the printed area appears on the Postscript page. Defaults to the center of the page.

:rotate boolean

Boolean specifies whether the printed area is to be rotated 90 degrees. In non-rotated output the x-axis of the printed area runs along the short dimension of the page (“portrait” orientation); in rotated output the x-axis runs along the long dimension of the page (“landscape” orientation). Defaults to non-rotated.

:width size

Specifies the width of the area of the canvas to print. Defaults to the width of the canvas window.

:x position

Specifies the x-coordinate of the left edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the left edge of the window.

:y position

Specifies the y-coordinate of the top edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the top edge of the window.

pathName :raise tagOrId ?aboveThis?

Move all of the items given by tagOrId to a new position in the display list just after the item given by aboveThis. If tagOrId refers to more than one item then all are moved but the relative order of the moved items will not be changed. AboveThis is a tag or id; if it refers to more than one item then the last (topmost) of these items in the display list is used as the destination location for the moved items. This command returns an empty string.

pathName :scale tagOrId xOrigin yOrigin xScale yScale

Rescale all of the items given by tagOrId in canvas coordinate space. XOrigin and yOrigin identify the origin for the scaling operation and xScale and yScale identify the scale factors for x- and y-coordinates, respectively (a scale factor of 1.0 implies no change to that coordinate). For each of the points defining each item, the x-coordinate is adjusted to change the distance from xOrigin by a factor of xScale. Similarly, each y-coordinate is adjusted to change the distance from yOrigin by a factor of yScale. This command returns an empty string.

pathName :scan option args

This command is used to implement scanning on canvases. It has two forms, depending on option:

pathName :scan :mark x y

Records x and y and the canvas’s current view; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget and x and y are the coordinates of the mouse. It returns an empty string.

pathName :scan :dragto x y.

This command computes the difference between its x and y arguments (which are typically mouse coordinates) and the x and y arguments to the last scan mark command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the canvas at high speed through its window. The return value is an empty string.

pathName :select option ?tagOrId arg?

Manipulates the selection in one of several ways, depending on option. The command may take any of the forms described below. In all of the descriptions below, tagOrId must refer to an item that supports indexing and selection; if it refers to multiple items then the first of these that supports indexing and the selection is used. Index gives a textual description of a position within tagOrId, as described in INDICES above.

pathName :select :adjust tagOrId index

Locate the end of the selection in tagOrId nearest to the character given by index, and adjust that end of the selection to be at index (i.e. including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn’t currently in tagOrId then this command behaves the same as the select to widget command. Returns an empty string.

pathName :select :clear

Clear the selection if it is in this widget. If the selection isn’t in this widget then the command has no effect. Returns an empty string.

pathName :select :from tagOrId index

Set the selection anchor point for the widget to be just before the character given by index in the item given by tagOrId. This command doesn’t change the selection; it just sets the fixed end of the selection for future select to commands. Returns an empty string.

pathName :select :item

Returns the id of the selected item, if the selection is in an item in this canvas. If the selection is not in this canvas then an empty string is returned.

pathName :select :to tagOrId index

Set the selection to consist of those characters of tagOrId between the selection anchor point and index. The new selection will include the character given by index; it will include the character given by the anchor point only if index is greater than or equal to the anchor point. The anchor point is determined by the most recent select adjust or select from command for this widget. If the selection anchor point for the widget isn’t currently in tagOrId, then it is set to the same character given by index. Returns an empty string.

pathName :type tagOrId

Returns the type of the item given by tagOrId, such as rectangle or text. If tagOrId refers to more than one item, then the type of the first item in the display list is returned. If tagOrId doesn’t refer to any items at all then an empty string is returned.

pathName :xview index

Change the view in the canvas so that the canvas position given by index appears at the left edge of the window. This command is typically used by scrollbars to scroll the canvas. Index counts in units of scroll increments (the value of the scrollIncrement option): a value of 0 corresponds to the left edge of the scroll region (as defined by the scrollRegion option), a value of 1 means one scroll unit to the right of this, and so on. The return value is an empty string.

pathName :yview index

Change the view in the canvas so that the canvas position given by index appears at the top edge of the window. This command is typically used by scrollbars to scroll the canvas. Index counts in units of scroll increments (the value of the scrollIncrement option): a value of 0 corresponds to the top edge of the scroll region (as defined by the scrollRegion option), a value of 1 means one scroll unit below this, and so on. The return value is an empty string.

Overview Of Item Types

The sections below describe the various types of items supported by canvas widgets. Each item type is characterized by two things: first, the form of the create command used to create instances of the type; and second, a set of configuration options for items of that type, which may be used in the create and itemconfigure widget commands. Most items don’t support indexing or selection or the commands related to them, such as index and insert. Where items do support these facilities, it is noted explicitly in the descriptions below (at present, only text items provide this support).

Arc Items

Items of type arc appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the :start and :extent options) and displayed in one of several ways (specified by the :style option). Arcs are created with widget commands of the following form:

pathName :create arc x1 y1 x2 y2 ?option value option value ...?

The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for arcs:

:extent degrees

Specifies the size of the angular range occupied by the arc. The arc’s range extends for degrees degrees counter-clockwise from the starting angle given by the :start option. Degrees may be negative.

:fill color

Fill the region of the arc with color. Color may have any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the arc will not be filled.

:outline color

Color specifies a color to use for drawing the arc’s outline; it may have any of the forms accepted by Tk_GetColor. This option defaults to black. If the arc’s style is arc then this option is ignored (the section of perimeter is filled using the :fill option). If color is specified as an empty string then no outline is drawn for the arc.

:start degrees

Specifies the beginning of the angular range occupied by the arc. Degrees is given in units of degrees measured counter-clockwise from the 3-o’clock position; it may be either positive or negative.

:stipple bitmap

Indicates that the arc should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn’t been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion.

:style type

Specifies how to draw the arc. If type is pieslice (the default) then the arc’s region is defined by a section of the oval’s perimeter plus two line segments, one between the center of the oval and each end of the perimeter section. If type is chord then the arc’s region is defined by a section of the oval’s perimeter plus a single line segment connecting the two end points of the perimeter section. If type is arc then the arc’s region consists of a section of the perimeter alone. In this last case there is no outline for the arc and the :outline option is ignored.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:width outlineWidth

Specifies the width of the outline to be drawn around the arc’s region, in any of the forms described in the COORDINATES section above. If the :outline option has been specified as an empty string then this option has no effect. Wide outlines will be drawn centered on the edges of the arc’s region. This option defaults to 1.0.

Bitmap Items

Items of type bitmap appear on the display as images with two colors, foreground and background. Bitmaps are created with widget commands of the following form:

pathName :create bitmap x y ?option value option value ...?

The arguments x and y specify the coordinates of a point used to position the bitmap on the display (see the :anchor option below for more information on how bitmaps are displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for bitmaps:

:anchor anchorPos

AnchorPos tells how to position the bitmap relative to the positioning point for the item; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the bitmap is centered on the point; if anchorPos is n then the bitmap will be drawn so that its top center point is at the positioning point. This option defaults to center.

:background color

Specifies a color to use for each of the bitmap pixels whose value is 0. Color may have any of the forms accepted by Tk_GetColor. If this option isn’t specified, or if it is specified as an empty string, then the background color for the canvas is used.

:bitmap bitmap

Specifies the bitmap to display in the item. Bitmap may have any of the forms accepted by Tk_GetBitmap.

:foreground color

Specifies a color to use for each of the bitmap pixels whose value is 1. Color may have any of the forms accepted by Tk_GetColor and defaults to black.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

Line Items

Items of type line appear on the display as one or more connected line segments or curves. Lines are created with widget commands of the following form:

pathName :create line x1 y1... xn yn ?option value option value ...?

The arguments x1 through yn give the coordinates for a series of two or more points that describe a series of connected line segments. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for lines:

:arrow where

Indicates whether or not arrowheads are to be drawn at one or both ends of the line. Where must have one of the values none (for no arrowheads), first (for an arrowhead at the first point of the line), last (for an arrowhead at the last point of the line), or both (for arrowheads at both ends). This option defaults to none.

:arrowshape shape

This option indicates how to draw arrowheads. The shape argument must be a list with three elements, each specifying a distance in any of the forms described in the COORDINATES section above. The first element of the list gives the distance along the line from the neck of the arrowhead to its tip. The second element gives the distance along the line from the trailing points of the arrowhead to the tip, and the third element gives the distance from the outside edge of the line to the trailing points. If this option isn’t specified then Tk picks a “reasonable” shape.

:capstyle style

Specifies the ways in which caps are to be drawn at the endpoints of the line. Style may have any of the forms accepted by Tk_GetCapStyle (butt, projecting, or round). If this option isn’t specified then it defaults to butt. Where arrowheads are drawn the cap style is ignored.

:fill color

Color specifies a color to use for drawing the line; it may have any of the forms acceptable to Tk_GetColor. It may also be an empty string, in which case the line will be transparent. This option defaults to black.

:joinstyle style

Specifies the ways in which joints are to be drawn at the vertices of the line. Style may have any of the forms accepted by Tk_GetCapStyle (bevel, miter, or round). If this option isn’t specified then it defaults to miter. If the line only contains two points then this option is irrelevant.

:smooth boolean

Boolean must have one of the forms accepted by Tk_GetBoolean. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of Bezier splines: one spline is drawn for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated within a curve by duplicating the end-points of the desired line segment.

:splinesteps number

Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the :smooth option is true.

:stipple bitmap

Indicates that the line should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default), then filling is done in a solid fashion.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:width lineWidth

LineWidth specifies the width of the line, in any of the forms described in the COORDINATES section above. Wide lines will be drawn centered on the path specified by the points. If this option isn’t specified then it defaults to 1.0.

Oval Items

Items of type oval appear as circular or oval regions on the display. Each oval may have an outline, a fill, or both. Ovals are created with widget commands of the following form:

pathName :create oval x1 y1 x2 y2 ?option value option value ...?

The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval. The oval will include the top and left edges of the rectangle not the lower or right edges. If the region is square then the resulting oval is circular; otherwise it is elongated in shape. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for ovals:

:fill color

Fill the area of the oval with color. Color may have any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the oval will not be filled.

:outline color

Color specifies a color to use for drawing the oval’s outline; it may have any of the forms accepted by Tk_GetColor. This option defaults to black. If color is an empty string then no outline will be drawn for the oval.

:stipple bitmap

Indicates that the oval should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn’t been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:width outlineWidth

outlineWidth specifies the width of the outline to be drawn around the oval, in any of the forms described in the COORDINATES section above. If the :outline option hasn’t been specified then this option has no effect. Wide outlines are drawn centered on the oval path defined by x1, y1, x2, and y2. This option defaults to 1.0.

Polygon Items

Items of type polygon appear as polygonal or curved filled regions on the display. Polygons are created with widget commands of the following form:

pathName :create polygon x1 y1 ... xn yn ?option value option value ...?

The arguments x1 through yn specify the coordinates for three or more points that define a closed polygon. The first and last points may be the same; whether they are or not, Tk will draw the polygon as a closed polygon. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for polygons:

:fill color

Color specifies a color to use for filling the area of the polygon; it may have any of the forms acceptable to Tk_GetColor. If color is an empty string then the polygon will be transparent. This option defaults to black.

:smooth boolean

Boolean must have one of the forms accepted by Tk_GetBoolean It indicates whether or not the polygon should be drawn with a curved perimeter. If so, the outline of the polygon becomes a set of Bezier splines, one spline for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated in a smoothed polygon by duplicating the end-points of the desired line segment.

:splinesteps number

Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the :smooth option is true.

:stipple bitmap

Indicates that the polygon should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default), then filling is done in a solid fashion.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

Rectangle Items

Items of type rectangle appear as rectangular regions on the display. Each rectangle may have an outline, a fill, or both. Rectangles are created with widget commands of the following form:

pathName :create rectangle x1 y1 x2 y2 ?option value option value ...?

The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of the rectangle (the rectangle will include its upper and left edges but not its lower or right edges). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for rectangles:

:fill color

Fill the area of the rectangle with color, which may be specified in any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the rectangle will not be filled.

:outline color

Draw an outline around the edge of the rectangle in color. Color may have any of the forms accepted by Tk_GetColor. This option defaults to black. If color is an empty string then no outline will be drawn for the rectangle.

:stipple bitmap

Indicates that the rectangle should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn’t been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:width outlineWidth

OutlineWidth specifies the width of the outline to be drawn around the rectangle, in any of the forms described in the COORDINATES section above. If the :outline option hasn’t been specified then this option has no effect. Wide outlines are drawn centered on the rectangular path defined by x1, y1, x2, and y2. This option defaults to 1.0.

Text Items

A text item displays a string of characters on the screen in one or more lines. Text items support indexing and selection, along with the following text-related canvas widget commands: dchars, focus, icursor, index, insert, select. Text items are created with widget commands of the following form:

pathName :create text x y ?option value option value ...?

The arguments x and y specify the coordinates of a point used to position the text on the display (see the options below for more information on how text is displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for text items:

:anchor anchorPos

AnchorPos tells how to position the text relative to the positioning point for the text; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the text is centered on the point; if anchorPos is n then the text will be drawn such that the top center point of the rectangular region occupied by the text will be at the positioning point. This option defaults to center.

:fill color

Color specifies a color to use for filling the text characters; it may have any of the forms accepted by Tk_GetColor. If this option isn’t specified then it defaults to black.

:font fontName

Specifies the font to use for the text item. FontName may be any string acceptable to Tk_GetFontStruct. If this option isn’t specified, it defaults to a system-dependent font.

:justify how

Specifies how to justify the text within its bounding region. How must be one of the values left, right, or center. This option will only matter if the text is displayed as multiple lines. If the option is omitted, it defaults to left.

:stipple bitmap

Indicates that the text should be drawn in a stippled pattern rather than solid; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default) then the text is drawn in a solid fashion.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:text string

String specifies the characters to be displayed in the text item. Newline characters cause line breaks. The characters in the item may also be changed with the insert and delete widget commands. This option defaults to an empty string.

:width lineLength

Specifies a maximum line length for the text, in any of the forms described in the COORDINATES section abov. If this option is zero (the default) the text is broken into lines only at newline characters. However, if this option is non-zero then any line that would be longer than lineLength is broken just before a space character to make the line shorter than lineLength; the space character is treated as if it were a newline character.

Window Items

Items of type window cause a particular window to be displayed at a given position on the canvas. Window items are created with widget commands of the following form: 

pathName :create window x y ?option value option value ...?

The arguments x and y specify the coordinates of a point used to position the window on the display (see the :anchor option below for more information on how bitmaps are displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item’s configuration. The following options are supported for window items:

:anchor anchorPos

AnchorPos tells how to position the window relative to the positioning point for the item; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the window is centered on the point; if anchorPos is n then the window will be drawn so that its top center point is at the positioning point. This option defaults to center.

:height pixels

Specifies the height to assign to the item’s window. Pixels may have any of the forms described in the COORDINATES section above. If this option isn’t specified, or if it is specified as an empty string, then the window is given whatever height it requests internally.

:tags tagList

Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list.

:width pixels

Specifies the width to assign to the item’s window. Pixels may have any of the forms described in the COORDINATES section above. If this option isn’t specified, or if it is specified as an empty string, then the window is given whatever width it requests internally.

:window pathName

Specifies the window to associate with this item. The window specified by pathName must either be a child of the canvas widget or a child of some ancestor of the canvas widget. PathName may not refer to a top-level window.

Application-Defined Item Types

It is possible for individual applications to define new item types for canvas widgets using C code. The interfaces for this mechanism are not presently documented, and it’s possible they may change, but you should be able to see how they work by examining the code for some of the existing item types.

Bindings

In the current implementation, new canvases are not given any default behavior: you’ll have to execute explicit Tcl commands to give the canvas its behavior.

Credits

Tk’s canvas widget is a blatant ripoff of ideas from Joel Bartlett’s ezd program. Ezd provides structured graphics in a Scheme environment and preceded canvases by a year or two. Its simple mechanisms for placing and animating graphical objects inspired the functions of canvases.

Keywords

canvas, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/update.html0000644000175000017500000000701014360276512015255 0ustar cammcamm update (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.23 update

update \- Process pending events and/or when-idle handlers

Synopsis

update ?:idletasks?

Description

This command is used to bring the entire application world “up to date.” It flushes all pending output to the display, waits for the server to process that output and return errors or events, handles all pending events of any sort (including when-idle handlers), and repeats this set of operations until there are no pending events, no pending when-idle handlers, no pending output to the server, and no operations still outstanding at the server.

If the idletasks keyword is specified as an argument to the command, then no new events or errors are processed; only when-idle idlers are invoked. This causes operations that are normally deferred, such as display updates and window layout calculations, to be performed immediately.

The update :idletasks command is useful in scripts where changes have been made to the application’s state and you want those changes to appear on the display immediately, rather than waiting for the script to complete. The update command with no options is useful in scripts where you are performing a long-running computation but you still want the application to respond to user interactions; if you occasionally call update then user input will be processed during the next call to update.

Keywords

event, flush, handler, idle, update

gcl-2.6.14/info/gcl-tk/wm.html0000644000175000017500000017110614360276512014426 0ustar cammcamm wm (GCL TK Manual)

Previous: , Up: Control   [Contents]

3.25 wm

wm \- Communicate with window manager

Synopsis

wm option window ?args?

Description

The wm command is used to interact with window managers in order to control such things as the title for a window, its geometry, or the increments in terms of which it may be resized. The wm command can take any of a number of different forms, depending on the option argument. All of the forms expect at least one additional argument, window, which must be the path name of a top-level window.

The legal forms for the wm command are:

wm :aspect window ?minNumer minDenom maxNumer maxDenom?

If minNumer, minDenom, maxNumer, and maxDenom are all specified, then they will be passed to the window manager and the window manager should use them to enforce a range of acceptable aspect ratios for window. The aspect ratio of window (width/length) will be constrained to lie between minNumer/minDenom and maxNumer/maxDenom. If minNumer etc. are all specified as empty strings, then any existing aspect ratio restrictions are removed. If minNumer etc. are specified, then the command returns an empty string. Otherwise, it returns a Tcl list containing four elements, which are the current values of minNumer, minDenom, maxNumer, and maxDenom (if no aspect restrictions are in effect, then an empty string is returned).

wm :client window ?name?

If name is specified, this command stores name (which should be the name of the host on which the application is executing) in window’s WM_CLIENT_MACHINE property for use by the window manager or session manager. The command returns an empty string in this case. If name isn’t specified, the command returns the last name set in a wm :client command for window. If name is specified as an empty string, the command deletes the WM_CLIENT_MACHINE property from window.

wm :command window ?value?

If value is specified, this command stores value in window’s WM_COMMAND property for use by the window manager or session manager and returns an empty string. Value must have proper list structure; the elements should contain the words of the command used to invoke the application. If value isn’t specified then the command returns the last value set in a wm :command command for window. If value is specified as an empty string, the command deletes the WM_COMMAND property from window.

wm :deiconify window

Arrange for window to be displayed in normal (non-iconified) form. This is done by mapping the window. If the window has never been mapped then this command will not map the window, but it will ensure that when the window is first mapped it will be displayed in de-iconified form. Returns an empty string.

wm :focusmodel window ?active|passive?

If active or passive is supplied as an optional argument to the command, then it specifies the focus model for window. In this case the command returns an empty string. If no additional argument is supplied, then the command returns the current focus model for window. An active focus model means that window will claim the input focus for itself or its descendants, even at times when the focus is currently in some other application. Passive means that window will never claim the focus for itself: the window manager should give the focus to window at appropriate times. However, once the focus has been given to window or one of its descendants, the application may re-assign the focus among window’s descendants. The focus model defaults to passive, and Tk’s focus command assumes a passive model of focussing.

wm :frame window

If window has been reparented by the window manager into a decorative frame, the command returns the X window identifier for the outermost frame that contains window (the window whose parent is the root or virtual root). If window hasn’t been reparented by the window manager then the command returns the X window identifier for window.

wm :geometry window ?newGeometry?

If newGeometry is specified, then the geometry of window is changed and an empty string is returned. Otherwise the current geometry for window is returned (this is the most recent geometry specified either by manual resizing or in a wm :geometry command). NewGeometry has the form =widthxheight\(+-x\(+-y, where any of =, widthxheight, or \(+-x\(+-y may be omitted. Width and height are positive integers specifying the desired dimensions of window. If window is gridded (see GRIDDED GEOMETRY MANAGEMENT below) then the dimensions are specified in grid units; otherwise they are specified in pixel units. X and y specify the desired location of window on the screen, in pixels. If x is preceded by +, it specifies the number of pixels between the left edge of the screen and the left edge of window’s border; if preceded by - then x specifies the number of pixels between the right edge of the screen and the right edge of window’s border. If y is preceded by + then it specifies the number of pixels between the top of the screen and the top of window’s border; if y is preceded by - then it specifies the number of pixels between the bottom of window’s border and the bottom of the screen. If newGeometry is specified as an empty string then any existing user-specified geometry for window is cancelled, and the window will revert to the size requested internally by its widgets.

wm :grid window ?baseWidth baseHeight widthInc heightInc?

This command indicates that window is to be managed as a gridded window. It also specifies the relationship between grid units and pixel units. BaseWidth and baseHeight specify the number of grid units corresponding to the pixel dimensions requested internally by window using Tk_GeometryRequest. WidthInc and heightInc specify the number of pixels in each horizontal and vertical grid unit. These four values determine a range of acceptable sizes for window, corresponding to grid-based widths and heights that are non-negative integers. Tk will pass this information to the window manager; during manual resizing, the window manager will restrict the window’s size to one of these acceptable sizes. Furthermore, during manual resizing the window manager will display the window’s current size in terms of grid units rather than pixels. If baseWidth etc. are all specified as empty strings, then window will no longer be managed as a gridded window. If baseWidth etc. are specified then the return value is an empty string. Otherwise the return value is a Tcl list containing four elements corresponding to the current baseWidth, baseHeight, widthInc, and heightInc; if window is not currently gridded, then an empty string is returned. Note: this command should not be needed very often, since the Tk_SetGrid library procedure and the setGrid option provide easier access to the same functionality.

wm :group window ?pathName?

If pathName is specified, it gives the path name for the leader of a group of related windows. The window manager may use this information, for example, to unmap all of the windows in a group when the group’s leader is iconified. PathName may be specified as an empty string to remove window from any group association. If pathName is specified then the command returns an empty string; otherwise it returns the path name of window’s current group leader, or an empty string if window isn’t part of any group.

wm :iconbitmap window ?bitmap?

If bitmap is specified, then it names a bitmap in the standard forms accepted by Tk (see the Tk_GetBitmap manual entry for details). This bitmap is passed to the window manager to be displayed in window’s icon, and the command returns an empty string. If an empty string is specified for bitmap, then any current icon bitmap is cancelled for window. If bitmap is specified then the command returns an empty string. Otherwise it returns the name of the current icon bitmap associated with window, or an empty string if window has no icon bitmap.

wm :iconify window

Arrange for window to be iconified. It window hasn’t yet been mapped for the first time, this command will arrange for it to appear in the iconified state when it is eventually mapped.

wm :iconmask window ?bitmap?

If bitmap is specified, then it names a bitmap in the standard forms accepted by Tk (see the Tk_GetBitmap manual entry for details). This bitmap is passed to the window manager to be used as a mask in conjunction with the iconbitmap option: where the mask has zeroes no icon will be displayed; where it has ones, the bits from the icon bitmap will be displayed. If an empty string is specified for bitmap then any current icon mask is cancelled for window (this is equivalent to specifying a bitmap of all ones). If bitmap is specified then the command returns an empty string. Otherwise it returns the name of the current icon mask associated with window, or an empty string if no mask is in effect.

wm :iconname window ?newName?

If newName is specified, then it is passed to the window manager; the window manager should display newName inside the icon associated with window. In this case an empty string is returned as result. If newName isn’t specified then the command returns the current icon name for window, or an empty string if no icon name has been specified (in this case the window manager will normally display the window’s title, as specified with the wm :title command).

wm :iconposition window ?x y?

If x and y are specified, they are passed to the window manager as a hint about where to position the icon for window. In this case an empty string is returned. If x and y are specified as empty strings then any existing icon position hint is cancelled. If neither x nor y is specified, then the command returns a Tcl list containing two values, which are the current icon position hints (if no hints are in effect then an empty string is returned).

wm :iconwindow window ?pathName?

If pathName is specified, it is the path name for a window to use as icon for window: when window is iconified then pathName should be mapped to serve as icon, and when window is de-iconified then pathName will be unmapped again. If pathName is specified as an empty string then any existing icon window association for window will be cancelled. If the pathName argument is specified then an empty string is returned. Otherwise the command returns the path name of the current icon window for window, or an empty string if there is no icon window currently specified for window. Note: not all window managers support the notion of an icon window.

wm :maxsize window ?width height?

If width and height are specified, then window becomes resizable and width and height give its maximum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window’s dimensions to be less than or equal to width and height. If width and height are specified as empty strings, then the maximum size option is cancelled for window. If width and height are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the maximum width and height currently in effect; if no maximum dimensions are in effect for window then an empty string is returned. See the sections on geometry management below for more information.

wm :minsize window ?width height?

If width and height are specified, then window becomes resizable and width and height give its minimum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window’s dimensions to be greater than or equal to width and height. If width and height are specified as empty strings, then the minimum size option is cancelled for window. If width and height are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the minimum width and height currently in effect; if no minimum dimensions are in effect for window then an empty string is returned. See the sections on geometry management below for more information.

wm :overrideredirect window ?boolean?

If boolean is specified, it must have a proper boolean form and the override-redirect flag for window is set to that value. If boolean is not specified then 1 or 0 is returned to indicate whether or not the override-redirect flag is currently set for window. Setting the override-redirect flag for a window causes it to be ignored by the window manager; among other things, this means that the window will not be reparented from the root window into a decorative frame and the user will not be able to manipulate the window using the normal window manager mechanisms.

wm :positionfrom window ?who?

If who is specified, it must be either program or user, or an abbreviation of one of these two. It indicates whether window’s current position was requested by the program or by the user. Many window managers ignore program-requested initial positions and ask the user to manually position the window; if user is specified then the window manager should position the window at the given place without asking the user for assistance. If who is specified as an empty string, then the current position source is cancelled. If who is specified, then the command returns an empty string. Otherwise it returns user or window to indicate the source of the window’s current position, or an empty string if no source has been specified yet. Most window managers interpret “no source” as equivalent to program. Tk will automatically set the position source to user when a wm :geometry command is invoked, unless the source has been set explicitly to program.

wm :protocol window ?name? ?command?

This command is used to manage window manager protocols such as WM_DELETE_WINDOW. Name is the name of an atom corresponding to a window manager protocol, such as WM_DELETE_WINDOW or WM_SAVE_YOURSELF or WM_TAKE_FOCUS. If both name and command are specified, then command is associated with the protocol specified by name. Name will be added to window’s WM_PROTOCOLS property to tell the window manager that the application has a protocol handler for name, and command will be invoked in the future whenever the window manager sends a message to the client for that protocol. In this case the command returns an empty string. If name is specified but command isn’t, then the current command for name is returned, or an empty string if there is no handler defined for name. If command is specified as an empty string then the current handler for name is deleted and it is removed from the WM_PROTOCOLS property on window; an empty string is returned. Lastly, if neither name nor command is specified, the command returns a list of all the protocols for which handlers are currently defined for window.

Tk always defines a protocol handler for WM_DELETE_WINDOW, even if you haven’t asked for one with wm :protocol. If a WM_DELETE_WINDOW message arrives when you haven’t defined a handler, then Tk handles the message by destroying the window for which it was received. .RE

wm :sizefrom window ?who?

If who is specified, it must be either program or user, or an abbreviation of one of these two. It indicates whether window’s current size was requested by the program or by the user. Some window managers ignore program-requested sizes and ask the user to manually size the window; if user is specified then the window manager should give the window its specified size without asking the user for assistance. If who is specified as an empty string, then the current size source is cancelled. If who is specified, then the command returns an empty string. Otherwise it returns user or window to indicate the source of the window’s current size, or an empty string if no source has been specified yet. Most window managers interpret “no source” as equivalent to program.

wm :state window

Returns the current state of window: either normal, iconic, or withdrawn.

wm :title window ?string?

If string is specified, then it will be passed to the window manager for use as the title for window (the window manager should display this string in window’s title bar). In this case the command returns an empty string. If string isn’t specified then the command returns the current title for the window. The title for a window defaults to its name.

wm :transient window ?master?

If master is specified, then the window manager is informed that window is a transient window (e.g. pull-down menu) working on behalf of master (where master is the path name for a top-level window). Some window managers will use this information to manage window specially. If master is specified as an empty string then window is marked as not being a transient window any more. If master is specified, then the command returns an empty string. Otherwise the command returns the path name of window’s current master, or an empty string if window isn’t currently a transient window.

wm :withdraw window

Arranges for window to be withdrawn from the screen. This causes the window to be unmapped and forgotten about by the window manager. If the window has never been mapped, then this command causes the window to be mapped in the withdrawn state. Not all window managers appear to know how to handle windows that are mapped in the withdrawn state. Note: it sometimes seems to be necessary to withdraw a window and then re-map it (e.g. with wm :deiconify) to get some window managers to pay attention to changes in window attributes such as group.

"Sources Of Geometry Information"

Size-related information for top-level windows can come from three sources. First, geometry requests come from the widgets that are descendants of a top-level window. Each widget requests a particular size for itself by calling Tk_GeometryRequest. This information is passed to geometry managers, which then request large enough sizes for parent windows so that they can layout the children properly. Geometry information passes upwards through the window hierarchy until eventually a particular size is requested for each top-level window. These requests are called internal requests in the discussion below. The second source of width and height information is through the wm :geometry command. Third, the user can request a particular size for a window using the interactive facilities of the window manager. The second and third types of geometry requests are called external requests in the discussion below; Tk treats these two kinds of requests identically.

"Ungridded Geometry Management"

Tk allows the geometry of a top-level window to be managed in either of two general ways: ungridded or gridded. The ungridded form occurs if no wm :grid command has been issued for a top-level window. Ungridded management has several variants. In the simplest variant of ungridded windows, no wm :geometry, wm :minsize, or wm :maxsize commands have been invoked either. In this case, the window’s size is determined totally by the internal requests emanating from the widgets inside the window: Tk will ask the window manager not to permit the user to resize the window interactively.

If a wm :geometry command is invoked on an ungridded window, then the size in that command overrides any size requested by the window’s widgets; from now on, the window’s size will be determined entirely by the most recent information from wm :geometry commands. To go back to using the size requested by the window’s widgets, issue a wm :geometry command with an empty geometry string.

To enable interactive resizing of an ungridded window, one or both of the wm :maxsize and wm :minsize commands must be issued. The information from these commands will be passed to the window manager, and size changes within the specified range will be permitted. For ungridded windows the limits refer to the top-level window’s dimensions in pixels. If only a wm :maxsize command is issued then the minimum dimensions default to 1; if only a wm :minsize command is issued then the maximum dimensions default to the size of the display. If the size of a window is changed interactively, it has the same effect as if wm :geometry had been invoked: from now on, internal geometry requests will be ignored. To return to internal control over the window’s size, issue a wm :geometry command with an empty geometry argument. If a window has been manually resized or moved, the wm :geometry command will return the geometry that was requested interactively.

"Gridded Geometry Management"

The second style of geometry management is called gridded. This approach occurs when one of the widgets of an application supports a range of useful sizes. This occurs, for example, in a text editor where the scrollbars, menus, and other adornments are fixed in size but the edit widget can support any number of lines of text or characters per line. In this case, it is usually desirable to let the user specify the number of lines or characters-per-line, either with the wm :geometry command or by interactively resizing the window. In the case of text, and in other interesting cases also, only discrete sizes of the window make sense, such as integral numbers of lines and characters-per-line; arbitrary pixel sizes are not useful.

Gridded geometry management provides support for this kind of application. Tk (and the window manager) assume that there is a grid of some sort within the application and that the application should be resized in terms of grid units rather than pixels. Gridded geometry management is typically invoked by turning on the setGrid option for a widget; it can also be invoked with the wm :grid command or by calling Tk_SetGrid. In each of these approaches the particular widget (or sometimes code in the application as a whole) specifies the relationship between integral grid sizes for the window and pixel sizes. To return to non-gridded geometry management, invoke wm :grid with empty argument strings.

When gridded geometry management is enabled then all the dimensions specified in wm :minsize, wm :maxsize, and wm :geometry commands are treated as grid units rather than pixel units. Interactive resizing is automatically enabled, and it will be carried out in even numbers of grid units rather than pixels. By default there are no limits on the minimum or maximum dimensions of a gridded window. As with ungridded windows, interactive resizing has exactly the same effect as invoking the wm :geometry command. For gridded windows, internally- and externally-requested dimensions work together: the externally-specified width and height determine the size of the window in grid units, and the information from the last wm :grid command maps from grid units to pixel units.

Bugs

The window manager interactions seem too complicated, especially for managing geometry. Suggestions on how to simplify this would be greatly appreciated.

Most existing window managers appear to have bugs that affect the operation of the wm command. For example, some changes won’t take effect if the window is already active: the window will have to be withdrawn and de-iconified in order to make the change happen.

Keywords

aspect ratio, deiconify, focus model, geometry, grid, group, icon, iconify, increments, position, size, title, top-level window, units, window manager

Short Table of Contents

Table of Contents

Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/tk.html0000644000175000017500000001056114360276512014416 0ustar cammcamm tk (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.19 tk

tk \- Manipulate Tk internal state

Synopsis

tk option ?arg arg ...?

Description

The tk command provides access to miscellaneous elements of Tk’s internal state. Most of the information manipulated by this command pertains to the application as a whole, or to a screen or display, rather than to a particular window. The command can take any of a number of different forms depending on the option argument. The legal forms are:

tk :colormodel window ?newValue?

If newValue isn’t specified, this command returns the current color model in use for window’s screen, which will be either color or monochrome. If newValue is specified, then it must be either color or monochrome or an abbreviation of one of them; the color model for window’s screen is set to this value.

The color model is used by Tk and its widgets to determine whether it should display in black and white only or use colors. A single color model is shared by all of the windows managed by one process on a given screen. The color model for a screen is set initially by Tk to monochrome if the display has four or fewer bit planes and to color otherwise. The color model will automatically be changed from color to monochrome if Tk fails to allocate a color because all entries in the colormap were in use. An application can change its own color model at any time (e.g. it might change the model to monochrome in order to conserve colormap entries, or it might set the model to color to use color on a four-bit display in special circumstances), but an application is not allowed to change the color model to color unless the screen has at least two bit planes. .RE

Keywords

color model, internal state

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/Argument-Lists.html0000644000175000017500000001502114360276512016652 0ustar cammcamm Argument Lists (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.5 Argument Lists

1.5.1 Widget Functions

The rule is that the first argument for a widget function is a keyword, called the option. The pattern of the remaining arguments depends completely on the option argument. Thus 

(.hello option ?arg1? ?arg2? ...)

One option which is permitted for every widget function is :configure. The argument pattern following it is the same keyword/value pair list which is used in widget creation. For a button widget, the other valid options are :deactivate, :flash, and :invoke. To find these, since .hello was constructed with the button constructor, you should see See button. The argument pattern for other options depends completely on the option and the widget function. For example if .scrollbar is a scroll bar window, then the option :set must be followed by 4 numeric arguments, which indicate how the scrollbar should be displayed, see See scrollbar. 

(.scrollbar :set a1 a2 a3 a4)

If on the other hand .scale is a scale (see scale), then we have 

(.scale :set a1 )

only one numeric argument should be supplied, in order to position the scale.

1.5.2 Widget Constructor Argument Lists

These are 

(widget-constructor pathname :keyword1 value1 :keyword2 value2 ...)

to create the widget whose name is pathname. The possible keywords allowed are specified in the corresponding section of See Widgets.

1.5.3 Concatenation Using ‘:’ in Argument List

What has been said so far about arguments is not quite true. A special string concatenation construction is allowed in argument lists for widgets, widget constructors and control functions.

First we introduce the function tk-conc which takes an arbitrary number of arguments, which may be symbols, strings or numbers, and concatenates these into a string. The print names of symbols are converted to lower case, and package names are ignored. 

(tk-conc "a" 1 :b 'cd "e") ==> "a1bcde"

One could use tk-conc to construct arguments for widget functions. But even though tk-conc has been made quite efficient, it still would involve the creation of a string. The : construct avoids this. In a call to a widget function, a widget constructor, or a control function you may remove the call to tk-conc and place : in between each of its arguments. Those functions are able to understand this and treat the extra arguments as if they were glued together in one string, but without the extra cost of actually forming that string. 

(tk-conc a b c .. w) <==> a : b : c : ... w
(setq i 10)
(.hello :configure :text i : " pies")
(.hello :configure :text (tk-conc i  " pies"))
(.hello :configure :text (format nil "~a pies" i))

The last three examples would all result in the text string being "10 pies", but the first method is the most efficient. That call will be made with no string or cons creation. The GC Monitor example, is written in such a way that there is no creation of cons or string types during normal operation. This is particularly useful in that case, since one is trying to monitor usage of conses by other programs, not its own usage.

Next: , Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/focus.html0000644000175000017500000001731314360276512015121 0ustar cammcamm focus (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.6 focus

focus \- Direct keyboard events to a particular window

Synopsis


focus

focus window
focus option ?arg arg ...?

Description

The focus command is used to manage the Tk input focus. At any given time, one window in an application is designated as the focus window for that application; any key press or key release events directed to any window in the application will be redirected instead to the focus window. If there is no focus window for an application then keyboard events are discarded. Typically, windows that are prepared to deal with the focus (e.g. entries and other widgets that display editable text) will claim the focus when mouse button 1 is pressed in them. When an application is created its main window is initially given the focus.

The focus command can take any of the following forms:

focus

If invoked with no arguments, focus returns the path name of the current focus window, or none if there is no focus window.

focus window

If invoked with a single argument consisting of a window’s path name, focus sets the input focus to that window. The return value is an empty string.

focus :default ?window?

If window is specified, it becomes the default focus window (the window that receives the focus whenever the focus window is deleted) and the command returns an empty string. If window isn’t specified, the command returns the path name of the current default focus window, or none if there is no default. Window may be specified as none to clear its existing value. The default window is initially none.

focus :none

Clears the focus window, so that keyboard input to this application will be discarded.

"Focus Events"

Tk’s model of the input focus is different than X’s model, and the focus window set with the focus command is not usually the same as the X focus window. Tk never explicitly changes the official X focus window. It waits for the window manager to direct the X input focus to and from the application’s top-level windows, and it intercepts FocusIn and FocusOut events coming from the X server to detect these changes. All of the focus events received from X are discarded by Tk; they never reach the application. Instead, Tk generates a different stream of FocusIn and FocusOut for the application. This means that FocusIn and and FocusOut events seen by the application will not obey the conventions described in the documentation for Xlib.

Tk applications receive two kinds of FocusIn and FocusOut events, which can be distinguished by their detail fields. Events with a detail of NotifyAncestor are directed to the current focus window when it becomes active or inactive. A window is the active focus whenever two conditions are simultaneously true: (a) the window is the focus window for its application, and (b) some top-level window in the application has received the X focus. When this happens Tk generates a FocusIn event for the focus window with detail NotifyAncestor. When a window loses the active focus (either because the window manager removed the focus from the application or because the focus window changed within the application) then it receives a FocusOut event with detail NotifyAncestor.

The events described above are directed to the application’s focus window regardless of which top-level window within the application has received the focus. The second kind of focus event is provided for applications that need to know which particular top-level window has the X focus. Tk generates FocusIn and FocusOut events with detail NotifyVirtual for top-level windows whenever they receive or lose the X focus. These events are generated regardless of which window in the application has the Tk input focus. They do not imply that keystrokes will be directed to the window that receives the event; they simply indicate which top-level window is active as far as the window manager is concerned. If a top-level window is also the application’s focus window, then it will receive both NotifyVirtual and NotifyAncestor events when it receives or loses the X focus.

Tk does not generate the hierarchical chains of FocusIn and FocusOut events described in the Xlib documentation (e.g. a window can get a FocusIn or FocusOut event without all of its ancestors getting events too). Furthermore, the mode field in focus events is always NotifyNormal and the only values ever present in the detail field are NotifyAncestor and NotifyVirtual.

Keywords

events, focus, keyboard, top-level, window manager

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/pack.html0000644000175000017500000003523514360276512014723 0ustar cammcamm pack (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.14 pack

pack \- Geometry manager that packs around edges of cavity

Synopsis

pack option arg ?arg ...?

Description

The pack command is used to communicate with the packer, a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The pack command can have any of several forms, depending on the option argument:

pack slave ?slave ...? ?options?

If the first argument to pack is a window name (any value starting with “.”), then the command is processed in the same way as pack configure.

pack configure slave ?slave ...? ?options?

The arguments consist of the names of one or more slave windows followed by pairs of arguments that specify how to manage the slaves. See “THE PACKER ALGORITHM” below for details on how the options are used by the packer. The following options are supported:

:after other

Other must the name of another window. Use its master as the master for the slaves, and insert the slaves just after other in the packing order.

:anchor anchor

Anchor must be a valid anchor position such as n or sw; it specifies where to position each slave in its parcel. Defaults to center.

:before other

Other must the name of another window. Use its master as the master for the slaves, and insert the slaves just before other in the packing order.

:expand boolean

Specifies whether the slaves should be expanded to consume extra space in their master. Boolean may have any proper boolean value, such as 1 or no. Defaults to 0.

:fill style

If a slave’s parcel is larger than its requested dimensions, this option may be used to stretch the slave. Style must have one of the following values:

none

Give the slave its requested dimensions plus any internal padding requested with :ipadx or :ipady. This is the default.

x

Stretch the slave horizontally to fill the entire width of its parcel (except leave external padding as specified by :padx).

y

Stretch the slave vertically to fill the entire height of its parcel (except leave external padding as specified by :pady).

both

Stretch the slave both horizontally and vertically.

:in other

Insert the slave(s) at the end of the packing order for the master window given by other.

:ipadx amount

Amount specifies how much horizontal internal padding to leave on each side of the slave(s). Amount must be a valid screen distance, such as 2 or .5c. It defaults to 0.

:ipady amount

Amount specifies how much vertical internal padding to leave on each side of the slave(s). Amount defaults to 0.

:padx amount

Amount specifies how much horizontal external padding to leave on each side of the slave(s). Amount defaults to 0.

:pady amount

Amount specifies how much vertical external padding to leave on each side of the slave(s). Amount defaults to 0.

:side side

Specifies which side of the master the slave(s) will be packed against. Must be left, right, top, or bottom. Defaults to top.

If no :in, :after or :before option is specified then each of the slaves will be inserted at the end of the packing list for its parent unless it is already managed by the packer (in which case it will be left where it is). If one of these options is specified then all the slaves will be inserted at the specified point. If any of the slaves are already managed by the geometry manager then any unspecified options for them retain their previous values rather than receiving default values. .RE

pack :forget slave ?slave ...?

Removes each of the slaves from the packing order for its master and unmaps their windows. The slaves will no longer be managed by the packer.

pack :newinfo slave

Returns a list whose elements are the current configuration state of the slave given by slave in the same option-value form that might be specified to pack configure. The first two elements of the list are “:in master” where master is the slave’s master. Starting with Tk 4.0 this option will be renamed "pack info".

pack :propagate master ?boolean?

If boolean has a true boolean value such as 1 or on then propagation is enabled for master, which must be a window name (see “GEOMETRY PROPAGATION” below). If boolean has a false boolean value then propagation is disabled for master. In either of these cases an empty string is returned. If boolean is omitted then the command returns 0 or 1 to indicate whether propagation is currently enabled for master. Propagation is enabled by default.

pack :slaves master

Returns a list of all of the slaves in the packing order for master. The order of the slaves in the list is the same as their order in the packing order. If master has no slaves then an empty string is returned.

"The Packer Algorithm"

For each master the packer maintains an ordered list of slaves called the packing list. The :in, :after, and :before configuration options are used to specify the master for each slave and the slave’s position in the packing list. If none of these options is given for a slave then the slave is added to the end of the packing list for its parent.

The packer arranges the slaves for a master by scanning the packing list in order. At the time it processes each slave, a rectangular area within the master is still unallocated. This area is called the cavity; for the first slave it is the entire area of the master.

For each slave the packer carries out the following steps:

  • [1] The packer allocates a rectangular parcel for the slave along the side of the cavity given by the slave’s :side option. If the side is top or bottom then the width of the parcel is the width of the cavity and its height is the requested height of the slave plus the :ipady and :pady options. For the left or right side the height of the parcel is the height of the cavity and the width is the requested width of the slave plus the :ipadx and :padx options. The parcel may be enlarged further because of the :expand option (see “EXPANSION” below)
  • [2] The packer chooses the dimensions of the slave. The width will normally be the slave’s requested width plus twice its :ipadx option and the height will normally be the slave’s requested height plus twice its :ipady option. However, if the :fill option is x or both then the width of the slave is expanded to fill the width of the parcel, minus twice the :padx option. If the :fill option is y or both then the height of the slave is expanded to fill the width of the parcel, minus twice the :pady option.
  • [3] The packer positions the slave over its parcel. If the slave is smaller than the parcel then the :anchor option determines where in the parcel the slave will be placed. If :padx or :pady is non-zero, then the given amount of external padding will always be left between the slave and the edges of the parcel.

Once a given slave has been packed, the area of its parcel is subtracted from the cavity, leaving a smaller rectangular cavity for the next slave. If a slave doesn’t use all of its parcel, the unused space in the parcel will not be used by subsequent slaves. If the cavity should become too small to meet the needs of a slave then the slave will be given whatever space is left in the cavity. If the cavity shrinks to zero size, then all remaining slaves on the packing list will be unmapped from the screen until the master window becomes large enough to hold them again.

"Expansion"

If a master window is so large that there will be extra space left over after all of its slaves have been packed, then the extra space is distributed uniformly among all of the slaves for which the :expand option is set. Extra horizontal space is distributed among the expandable slaves whose :side is left or right, and extra vertical space is distributed among the expandable slaves whose :side is top or bottom.

"Geometry Propagation"

The packer normally computes how large a master must be to just exactly meet the needs of its slaves, and it sets the requested width and height of the master to these dimensions. This causes geometry information to propagate up through a window hierarchy to a top-level window so that the entire sub-tree sizes itself to fit the needs of the leaf windows. However, the pack propagate command may be used to turn off propagation for one or more masters. If propagation is disabled then the packer will not set the requested width and height of the packer. This may be useful if, for example, you wish for a master window to have a fixed size that you specify.

"Restrictions On Master Windows"

The master for each slave must either be the slave’s parent (the default) or a descendant of the slave’s parent. This restriction is necessary to guarantee that the slave can be placed over any part of its master that is visible without danger of the slave being clipped by its parent.

"Packing Order"

If the master for a slave is not its parent then you must make sure that the slave is higher in the stacking order than the master. Otherwise the master will obscure the slave and it will appear as if the slave hasn’t been packed correctly. The easiest way to make sure the slave is higher than the master is to create the master window first: the most recently created window will be highest in the stacking order. Or, you can use the raise and lower commands to change the stacking order of either the master or the slave.

Keywords

geometry manager, location, packer, parcel, propagation, size

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/send.html0000644000175000017500000001034314360276512014727 0ustar cammcamm send (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.18 send

send \- Execute a command in a different interpreter

Synopsis

send interp cmd ?arg arg ...?

Description

This command arranges for cmd (and args) to be executed in the interpreter named by interp. It returns the result or error from that command execution. Interp must be the name of an interpreter registered on the display associated with the interpreter in which the command is invoked; it need not be within the same process or application. If no arg arguments are present, then the command to be executed is contained entirely within the cmd argument. If one or more args are present, they are concatenated to form the command to be executed, just as for the eval Tcl command.

Security

The send command is potentially a serious security loophole, since any application that can connect to your X server can send scripts to your applications. These incoming scripts can use Tcl to read and write your files and invoke subprocesses under your name. Host-based access control such as that provided by xhost is particularly insecure, since it allows anyone with an account on particular hosts to connect to your server, and if disabled it allows anyone anywhere to connect to your server. In order to provide at least a small amount of security, Tk checks the access control being used by the server and rejects incoming sends unless (a) xhost-style access control is enabled (i.e. only certain hosts can establish connections) and (b) the list of enabled hosts is empty. This means that applications cannot connect to your server unless they use some other form of authorization such as that provide by xauth.

Keywords

interpreter, remote execution, security, send

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/Return-Values.html0000644000175000017500000001621414360276512016515 0ustar cammcamm Return Values (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.4 Return Values

1.4.1 Widget Constructor Return Values

On successful completion, the widget constructor functions return the symbol passed in as the first argument. It will now have a functional binding. It is an error to pass in a symbol which already corresponds to a widget, without first calling the destroy command. On failure, an error is signalled.

1.4.2 Widget Return Values

The widget functions themselves, do not normally return any value. Indeed the lisp process does not wait for them to return, but merely dispatches the commands, such as to change the text in themselves. Sometimes however you either wish to wait, in order to synchronize, or you wish to see if your command fails or succeeds. You request values by passing the keyword :return and a value indicating the type. 

(.hello :configure :text "Bye World" :return 'string)
==> "" 
==> T

the empty string is returned as first value, and the second value T indicates that the new text value was successfully set. LISP will not continue until the tkclsrv process indicates back that the function call has succeeded. While waiting of course LISP will continue to process other graphics events which arrive, since otherwise a deadlock would arise: the user for instance might click on a mouse, just after we had decided to wait for a return value from the .hello function. More generally a user program may be running in GCL and be interrupted to receive and act on communications from the gcltksrv process. If an error occurred then the second return value of the lisp function will be NIL. In this case the first value, the string is usually an informative message about the type of error.

A special variable tk::*break-on-errors* which if not nil, requests that that LISP signal an error when a message is received indicating a function failed. Whenever a command fails, whether a return value was requested or not, gcltksrv returns a message indicating failure. The default is to not go into the debugger. When debugging your windows it may be convenient however to set this variable to T to track down incorrect messages.

The gcltksrv process always returns strings as values. If :return type is specified, then conversion to type is accomplished by calling 

(coerce-result return-string type)

Here type must be a symbol with a coercion-functions property. The builtin return types which may be requested are:

T

in which case the string passed back from the gcltksrv process, will be read by the lisp reader.

number

the string is converted to a number using the current *read-base*

list-strings
(coerce-result "a b {c d} e" 'list-strings)
==> ("a" "b" "c d" "e")
boolean

(coerce-result "1" ’boolean) ==> T (coerce-result "0" ’boolean) ==> NIL

The above symbols are in the TK or LISP package. It would be possible to add new types just as the :return t is done: 

(setf (get 't 'coercion-functions)
      (cons #'(lambda (x) (our-read-from-string x 0))
	    #'(lambda (x) (format nil "~s" x))))

The coercion-functions property of a symbol, is a cons whose car is the coercion form from a string to some possibly different lisp object, and whose cdr is a function which builds a string to send to the graphics server. Often the two functions are inverse functions one of the other up to equal.

1.4.3 Control Function Return Values

The control functions (see Control) do not return a value or wait unless requested to do so, using the :return keyword. The types and method of specification are the same as for the Widget Functions in the previous section. 

(winfo :width '.hello :return 'number)
==> 120

indicates that the .hello button is actually 120 pixels wide.

Next: , Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/option.html0000644000175000017500000001400214360276512015302 0ustar cammcamm option (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.11 option

option \- Add/retrieve window options to/from the option database

Synopsis

option :add pattern value ?priority?


option :clear


option :get window name class


option :readfile fileName ?priority?

Description

The option command allows you to add entries to the Tk option database or to retrieve options from the database. The add form of the command adds a new option to the database. Pattern contains the option being specified, and consists of names and/or classes separated by asterisks or dots, in the usual X format. Value contains a text string to associate with pattern; this is the value that will be returned in calls to Tk_GetOption or by invocations of the option :get command. If priority is specified, it indicates the priority level for this option (see below for legal values); it defaults to interactive. This command always returns an empty string.

The option :clear command clears the option database. Default options (in the RESOURCE_MANAGER property or the .Xdefaults file) will be reloaded automatically the next time an option is added to the database or removed from it. This command always returns an empty string.

The option :get command returns the value of the option specified for window under name and class. If several entries in the option database match window, name, and class, then the command returns whichever was created with highest priority level. If there are several matching entries at the same priority level, then it returns whichever entry was most recently entered into the option database. If there are no matching entries, then the empty string is returned.

The readfile form of the command reads fileName, which should have the standard format for an X resource database such as .Xdefaults, and adds all the options specified in that file to the option database. If priority is specified, it indicates the priority level at which to enter the options; priority defaults to interactive.

The priority arguments to the option command are normally specified symbolically using one of the following values:

widgetDefault

Level 20. Used for default values hard-coded into widgets.

startupFile

Level 40. Used for options specified in application-specific startup files.

userDefault

Level 60. Used for options specified in user-specific defaults files, such as .Xdefaults, resource databases loaded into the X server, or user-specific startup files.

interactive

Level 80. Used for options specified interactively after the application starts running. If priority isn’t specified, it defaults to this level.

Any of the above keywords may be abbreviated. In addition, priorities may be specified numerically using integers between 0 and 100, inclusive. The numeric form is probably a bad idea except for new priority levels other than the ones given above.

Keywords

database, option, priority, retrieve

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/tkvars.html0000644000175000017500000001111414360276512015305 0ustar cammcamm tkvars (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.21 tkvars

tkvars \- Variables used or set by Tk

Description

The following Tcl variables are either set or used by Tk at various times in its execution:

tk_library

Tk sets this variable hold the name of a directory containing a library of Tcl scripts related to Tk. These scripts include an initialization file that is normally processed whenever a Tk application starts up, plus other files containing procedures that implement default behaviors for widgets. The value of this variable is taken from the TK_LIBRARY environment variable, if one exists, or else from a default value compiled into Tk.

tk_patchLevel

Contains a decimal integer giving the current patch level for Tk. The patch level is incremented for each new release or patch, and it uniquely identifies an official version of Tk.

tk_priv

This variable is an array containing several pieces of information that are private to Tk. The elements of tk_priv are used by Tk library procedures and default bindings. They should not be accessed by any code outside Tk.

tk_strictMotif

This variable is set to zero by default. If an application sets it to one, then Tk attempts to adhere as closely as possible to Motif look-and-feel standards. For example, active elements such as buttons and scrollbar sliders will not change color when the pointer passes over them.

tk_version

Tk sets this variable in the interpreter for each application. The variable holds the current version number of the Tk library in the form major.minor. Major and minor are integers. The major version number increases in any Tk release that includes changes that are not backward compatible (i.e. whenever existing Tk applications and scripts may have to change to work with the new release). The minor version number increases with each new release of Tk, except that it resets to zero whenever the major version number changes.

tkVersion

Has the same value as tk_version. This variable is obsolete and will be deleted soon.

Keywords

variables, version

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/entry.html0000644000175000017500000003463314360276512015147 0ustar cammcamm entry (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.10 entry

entry \- Create and manipulate entry widgets

Synopsis

entry pathName ?options?

Standard Options

background      foreground        insertWidth       selectForeground 
borderWidth     insertBackground  relief            textVariable     
cursor          insertBorderWidth scrollCommand     
exportSelection insertOffTime     selectBackground  
font            insertOnTime      selectBorderWidth

See options, for more information.

Arguments for Entry

:state

Name="state" Class="State"


Specifies one of two states for the entry: normal or disabled. If the entry is disabled then the value may not be changed using widget commands and no insertion cursor will be displayed, even if the input focus is in the widget.

:width

Name="width" Class="Width"


Specifies an integer value indicating the desired width of the entry window, in average-size characters of the widget’s font.

Description

The entry command creates a new window (given by the pathName argument) and makes it into an entry widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the entry such as its colors, font, and relief. The entry command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

An entry is a widget that displays a one-line text string and allows that string to be edited using widget commands described below, which are typically bound to keystrokes and mouse actions. When first created, an entry’s string is empty. A portion of the entry may be selected as described below. If an entry is exporting its selection (see the exportSelection option), then it will observe the standard X11 protocols for handling the selection; entry selections are available as type STRING. Entries also observe the standard Tk rules for dealing with the input focus. When an entry has the input focus it displays an insertion cursor to indicate where new characters will be inserted.

Entries are capable of displaying strings that are too long to fit entirely within the widget’s window. In this case, only a portion of the string will be displayed; commands described below may be used to change the view in the window. Entries use the standard scrollCommand mechanism for interacting with scrollbars (see the description of the scrollCommand option for details). They also support scanning, as described below.

A Entry Widget’s Arguments

The entry command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command.

Many of the widget commands for entries take one or more indices as arguments. An index specifies a particular character in the entry’s string, in any of the following ways:

number

Specifies the character as a numerical index, where 0 corresponds to the first character in the string.

end

Indicates the character just after the last one in the entry’s string. This is equivalent to specifying a numerical index equal to the length of the entry’s string.

insert

Indicates the character adjacent to and immediately following the insertion cursor.

sel.first

Indicates the first character in the selection. It is an error to use this form if the selection isn’t in the entry window.

sel.last

Indicates the last character in the selection. It is an error to use this form if the selection isn’t in the entry window.

@number

In this form, number is treated as an x-coordinate in the entry’s window; the character spanning that x-coordinate is used. For example, “@0” indicates the left-most character in the window.

Abbreviations may be used for any of the forms above, e.g. “e” or “sel.f”. In general, out-of-range indices are automatically rounded to the nearest legal value.

The following commands are possible for entry widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the entry command.

pathName :delete first ?last?

Delete one or more elements of the entry. First and last are indices of of the first and last characters in the range to be deleted. If last isn’t specified it defaults to first, i.e. a single character is deleted. This command returns an empty string.

pathName :get

Returns the entry’s string.

pathName :icursor index

Arrange for the insertion cursor to be displayed just before the character given by index. Returns an empty string.

pathName :index index

Returns the numerical index corresponding to index.

pathName :insert index string

Insert the characters of string just before the character indicated by index. Returns an empty string.

pathName :scan option args

This command is used to implement scanning on entries. It has two forms, depending on option:

pathName :scan :mark x

Records x and the current view in the entry window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string.

pathName :scan :dragto x

This command computes the difference between its x argument and the x argument to the last scan mark command for the widget. It then adjusts the view left or right by 10 times the difference in x-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the entry at high speed through the window. The return value is an empty string.

pathName :select option arg

This command is used to adjust the selection within an entry. It has several forms, depending on option:

pathName :select :adjust index

Locate the end of the selection nearest to the character given by index, and adjust that end of the selection to be at index (i.e including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn’t currently in the entry, then a new selection is created to include the characters between index and the most recent selection anchor point, inclusive. Returns an empty string.

pathName :select :clear

Clear the selection if it is currently in this widget. If the selection isn’t in this widget then the command has no effect. Returns an empty string.

pathName :select :from index

Set the selection anchor point to just before the character given by index. Doesn’t change the selection. Returns an empty string.

pathName :select :to index

Set the selection to consist of the elements from the anchor point to element index, inclusive. The anchor point is determined by the most recent select from or select adjust command in this widget. If the selection isn’t in this widget then a new selection is created using the most recent anchor point specified for the widget. Returns an empty string.

pathName :view index

Adjust the view in the entry so that element index is at the left edge of the window. Returns an empty string.

"Default Bindings"

Tk automatically creates class bindings for entries that give them the following default behavior:

  • [1] Clicking mouse button 1 in an entry positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget.
  • [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse.
  • [3] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed.
  • [4] The view in the entry can be adjusted by dragging with mouse button 2.
  • [5] If the input focus is in an entry widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor.
  • [6] Control-h and the Backspace and Delete keys erase the character just before the insertion cursor.
  • [7] Control-w erases the word just before the insertion cursor.
  • [8] Control-u clears the entry to an empty string.
  • [9] Control-v inserts the current selection just before the insertion cursor.
  • [10] Control-d deletes the selected characters; an error occurs if the selection is not in this widget.

If the entry is disabled using the state option, then the entry’s view can still be adjusted and text in the entry can still be selected, but no insertion cursor will be displayed and no text modifications will take place.

The behavior of entries can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Keywords

entry, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/tkconnect.html0000644000175000017500000001046314360276512015771 0ustar cammcamm tkconnect (GCL TK Manual)

Previous: , Up: General   [Contents]

1.8 tkconnect

tkconnect &key host display can-rsh gcltksrv

This function provides a connection to a graphics server process, which in turn connects to possibly several graphics display screens. The graphics server process, called gcltksrv may or may not run on the same machine as the lisp to which it is attached. display indicates the name of the default display to connect to, and this in turn defaults to the value of the environment variable DISPLAY.

When tkconnect is invoked, a socket is opened and it waits for a graphics process to connect to it. If the host argument is not supplied, then a process will be spawned which will connect back to the lisp process. The name of the command for invoking the process is the value of the gcltksrv argument, which defaults to the value of the environment variable GCL_TK_SERVER. If that variable is not set, then the lisp *lib-directory* is searched for an entry gcl-tk/gcltksrv.

If host is supplied, then a command to run on the remote machine will be printed on standard output. If can-rsh is not nil, then the command will not be printed, but rather an attempt will be made to rsh to the machine, and to run the command.

Thus 

(tkconnect)

would start the process on the local machine, and use for display the value of the environment variable DISPLAY. 

(tkconnect :host "max.ma.utexas.edu" :can-rsh t)

would cause an attempt to rsh to max and to run the command there, to connect back to the appropriate port on the localhost.

You may indicate that different toplevel windows be on different displays, by using the :display argument when creating the window, See toplevel.

Clearly you must have a copy of the program gcltksrv and TK libraries installed on the machine where you wish to run the server.

Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/Common-Features-of-Widgets.html0000644000175000017500000001521114360276512021007 0ustar cammcamm Common Features of Widgets (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.3 Common Features of Widgets

A widget is a lisp symbol which has a function binding. The first argument is always a keyword and is called the option. The argument pattern for the remaining arguments depends on the option. The most common option is :configure in which case the remaining arguments are alternating keyword/value pairs, with the same keywords being permitted as at the creation of the widget.

A widget is created by means of a widget constructor, of which there are currently 15, each of them appearing as the title of a section in Widgets. They live in the "TK" package, and for the moment we will assume we have switched to this package. Thus for example button is such a widget constructor function. Of course this is lisp, and you can make your own widget constructors, but when you do so it is a good idea to follow the standard argument patterns that are outlined in this section. 

(button '.hello)
==> .HELLO

creates a widget whose name is .hello. There is a parent child hierarchy among widgets which is implicit in the name used for the widget. This is much like the pathname structure on a Unix or Dos file system, except that '.' is used as the separator rather than a / or \. For this reason the widget instances are sometimes referred to as pathnames. A child of the parent widget .hello might be called .hello.joe, and a child of this last might be .hello.joe.bar. The parent of everyone is called . . Multiple top level windows are created using the toplevel command (see toplevel).

The widget constructor functions take keyword and value pairs, which allow you to specify attributes at the time of creation: 

(button '.hello :text "Hello World" :width 20)
==>.HELLO

indicating that we want the text in the button window to be Hello World and the width of the window to be 20 characters wide. Other types of windows allow specification in centimeters 2c, or in inches (2i) or in millimeters 2m or in pixels 2. But text windows usually have their dimensions specified as multiples of a character width and height. This latter concept is called a grid.

Once the window has been created, if you want to change the text you do NOT do: 

(button '.hello :text "Bye World" :width 20)

This would be in error, because the window .hello already exists. You would either have to first call 

(destroy '.hello)

But usually you just want to change an attribute. .hello is actually a function, as we mentioned earlier, and it is this function that you use: 

(.hello :configure :text "Bye World")

This would simply change the text, and not change where the window had been placed on the screen (if it had), or how it had been packed into the window hierarchy. Here the argument :configure is called an option, and it specifies which types of keywords can follow it. For example 

(.hello :flash)

is also valid, but in this case the :text keyword is not permitted after flash. If it were, then it would mean something else besides what it means in the above. For example one might have defined 

(.hello :flash :text "PUSH ME")

so here the same keyword :text would mean something else, eg to flash a subliminal message on the screen.

We often refer to calls to the widget functions as messages. One reason for this is that they actually turn into messages to the graphics process gcltksrv. To actually see these messages you can do 

(debugging t).

Next: , Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/label.html0000644000175000017500000001517114360276512015061 0ustar cammcamm label (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.13 label

label \- Create and manipulate label widgets

Synopsis

label pathName ?options?

Standard Options

anchor           borderWidth     foreground     relief           
background       cursor          padX           text             
bitmap           font            padY           textVariable

See options, for more information.

Arguments for Label

:height

Name="height" Class="Height"


Specifies a desired height for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn’t specified, the label’s desired height is computed from the size of the bitmap or text being displayed in it.

:width

Name="width" Class="Width"


Specifies a desired width for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn’t specified, the label’s desired width is computed from the size of the bitmap or text being displayed in it.

Description

The label command creates a new window (given by the pathName argument) and makes it into a label widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the label such as its colors, font, text, and initial relief. The label command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A label is a widget that displays a textual string or bitmap. The label can be manipulated in a few simple ways, such as changing its relief or text, using the commands described below.

A Label Widget’s Arguments

The label command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for label widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the label command.

Bindings

When a new label is created, it has no default event bindings: labels are not intended to be interactive.

Keywords

label, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/General.html0000644000175000017500000000644514360276512015363 0ustar cammcamm General (GCL TK Manual)

Next: , Previous: , Up: Top   [Contents]

1 General

• Introduction  
• Getting Started  
• Common Features of Widgets  
• Return Values  
• Argument Lists  
• Lisp Functions Invoked from Graphics  
• Linked Variables  
• tkconnect  
gcl-2.6.14/info/gcl-tk/pack_002dold.html0000644000175000017500000002662514360276512016152 0ustar cammcamm pack-old (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.13 pack-old

pack \- Obsolete syntax for packer geometry manager

Synopsis

pack after sibling window options ?window options ...?


pack append parent window options ?window options ...?


pack before sibling window options ?window options ...?


pack info parent


pack unpack window

Description

Note: this manual entry describes the syntax for the pack\fI command as it before Tk version 3.3. Although this syntax continues to be supported for backward compatibility, it is obsolete and should not be used anymore. At some point in the future it may cease to be supported.

The packer is a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The first child is placed against one side of the window, occupying the entire span of the window along that side. This reduces the space remaining for other children as if the side had been moved in by the size of the first child. Then the next child is placed against one side of the remaining cavity, and so on until all children have been placed or there is no space left in the cavity.

The before, after, and append forms of the pack command are used to insert one or more children into the packing order for their parent. The before form inserts the children before window sibling in the order; all of the other windows must be siblings of sibling. The after form inserts the windows after sibling, and the append form appends one or more windows to the end of the packing order for parent. If a window named in any of these commands is already packed in its parent, it is removed from its current position in the packing order and repositioned as indicated by the command. All of these commands return an empty string as result.

The unpack form of the pack command removes window from the packing order of its parent and unmaps it. After the execution of this command the packer will no longer manage window’s geometry.

The placement of each child is actually a four-step process; the options argument following each window consists of a list of one or more fields that govern the placement of that window. In the discussion below, the term cavity refers to the space left in a parent when a particular child is placed (i.e. all the space that wasn’t claimed by earlier children in the packing order). The term parcel refers to the space allocated to a particular child; this is not necessarily the same as the child window’s final geometry.

The first step in placing a child is to determine which side of the cavity it will lie against. Any one of the following options may be used to specify a side:

top

Position the child’s parcel against the top of the cavity, occupying the full width of the cavity.

bottom

Position the child’s parcel against the bottom of the cavity, occupying the full width of the cavity.

left

Position the child’s parcel against the left side of the cavity, occupying the full height of the cavity.

right

Position the child’s parcel against the right side of the cavity, occupying the full height of the cavity.

At most one of these options should be specified for any given window. If no side is specified, then the default is top.

The second step is to decide on a parcel for the child. For top and bottom windows, the desired parcel width is normally the cavity width and the desired parcel height is the window’s requested height, as passed to Tk_GeometryRequest. For left and right windows, the desired parcel height is normally the cavity height and the desired width is the window’s requested width. However, extra space may be requested for the window using any of the following options:

padx num

Add num pixels to the window’s requested width before computing the parcel size as described above.

pady num

Add num pixels to the window’s requested height before computing the parcel size as described above.

expand

This option requests that the window’s parcel absorb any extra space left over in the parent’s cavity after packing all the children. The amount of space left over depends on the sizes requested by the other children, and may be zero. If several windows have all specified expand then the extra width will be divided equally among all the left and right windows that specified expand and the extra height will be divided equally among all the top and bottom windows that specified expand.

If the desired width or height for a parcel is larger than the corresponding dimension of the cavity, then the cavity’s dimension is used instead.

The third step in placing the window is to decide on the window’s width and height. The default is for the window to receive either its requested width and height or the those of the parcel, whichever is smaller. If the parcel is larger than the window’s requested size, then the following options may be used to expand the window to partially or completely fill the parcel:

fill

Set the window’s size to equal the parcel size.

fillx

Increase the window’s width to equal the parcel’s width, but retain the window’s requested height.

filly

Increase the window’s height to equal the parcel’s height, but retain the window’s requested width.

The last step is to decide the window’s location within its parcel. If the window’s size equals the parcel’s size, then the window simply fills the entire parcel. If the parcel is larger than the window, then one of the following options may be used to specify where the window should be positioned within its parcel:

frame center

Center the window in its parcel. This is the default if no framing option is specified.

frame n

Position the window with its top edge centered on the top edge of the parcel.

frame ne

Position the window with its upper-right corner at the upper-right corner of the parcel.

frame e

Position the window with its right edge centered on the right edge of the parcel.

frame se

Position the window with its lower-right corner at the lower-right corner of the parcel.

frame s

Position the window with its bottom edge centered on the bottom edge of the parcel.

frame sw

Position the window with its lower-left corner at the lower-left corner of the parcel.

frame w

Position the window with its left edge centered on the left edge of the parcel.

frame nw

Position the window with its upper-left corner at the upper-left corner of the parcel.

The pack info command may be used to retrieve information about the packing order for a parent. It returns a list in the form 

window options window options ...

Each window is a name of a window packed in parent, and the following options describes all of the options for that window, just as they would be typed to pack append. The order of the list is the same as the packing order for parent.

The packer manages the mapped/unmapped state of all the packed children windows. It automatically maps the windows when it packs them, and it unmaps any windows for which there was no space left in the cavity.

The packer makes geometry requests on behalf of the parent windows it manages. For each parent window it requests a size large enough to accommodate all the options specified by all the packed children, such that zero space would be leftover for expand options.

Keywords

geometry manager, location, packer, parcel, size

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/Introduction.html0000644000175000017500000000660514360276512016465 0ustar cammcamm Introduction (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.1 Introduction

GCL-TK is a windowing interface for GNU Common Lisp. It provides the functionality of the TK widget set, which in turn implements a widget set which has the look and feel of Motif.

The interface allows the user to draw graphics, get input from menus, make regions mouse sensitive, and bind lisp commands to regions. It communicates over a socket with a gcltksrv process, which speaks to the display via the TK library. The displaying process may run on a machine which is closer to the display, and so involves less communication. It also may remain active even though the lisp is involved in a separate user computation. The display server can, however, interrupt the lisp at will, to inquire about variables and run commands.

The user may also interface with existing TCL/TK programs, binding some buttons, or tracking some objects.

The size of the program is moderate. In its current form it adds only about 45K bytes to the lisp image, and the gcltksrv program uses shared libraries, and is on the order of 150Kbytes on a sparc.

This chapter describes some of the common features of the command structure of widgets, and of control functions. The actual functions for construction of windows are discussed in Widgets, and more general functions for making them appear, lowering them, querying about them in Control.

gcl-2.6.14/info/gcl-tk/Getting-Started.html0000644000175000017500000000715714360276512017014 0ustar cammcamm Getting Started (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.2 Getting Started

Once GCL has been properly installed you should be able to do the following simple example: 

(in-package "TK")
(tkconnect)
(button '.hello :text "Hello World" :command '(print "hi"))
==>.HELLO
(pack '.hello)

We first switched to the "TK" package, so that functions like button and pack would be found. After doing the tkconnect, a window should appear on your screen, see See tkconnect. The invocation of the function button creates a new function called .hello which is a widget function. It is then made visible in the window by using the pack function.

You may now click on the little window, and you should see the command executed in your lisp. Thus "hi" should be printed in the lisp window. This will happen whether or not you have a job running in the lisp, that is lisp will be interrupted and your command will run, and then return the control to your program.

The function button is called a widget constructor, and the function .hello is called a widget. If you have managed to accomplish the above, then GCL is probably installed correctly, and you can graduate to the next section! If you dont like reading but prefer to look at demos and code, then you should look in the demos directory, where you will find a number of examples. A monitor for the garbage collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), a sample listbox with scrolling (mklistbox).

gcl-2.6.14/info/gcl-tk/text.html0000644000175000017500000012162414360276512014767 0ustar cammcamm text (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.9 text

text \- Create and manipulate text widgets

Synopsis

text pathName ?options?

Standard Options

background      foreground        insertWidth      selectBorderWidth 
borderWidth     insertBackground  padX             selectForeground  
cursor          insertBorderWidth padY             setGrid           
exportSelection insertOffTime     relief           yScrollCommand    
font            insertOnTime      selectBackground

See options, for more information.

Arguments for Text

:height

Name="height" Class="Height"


Specifies the desired height for the window, in units of characters. Must be at least one.

:state

Name="state" Class="State"


Specifies one of two states for the text: normal or disabled. If the text is disabled then characters may not be inserted or deleted and no insertion cursor will be displayed, even if the input focus is in the widget.

:width

Name="width" Class="Width"


Specifies the desired width for the window in units of characters. If the font doesn’t have a uniform width then the width of the character “0” is used in translating from character units to screen units.

:wrap

Name="wrap" Class="Wrap"


Specifies how to handle lines in the text that are too long to be displayed in a single line of the text’s window. The value must be none or char or word. A wrap mode of none means that each line of text appears as exactly one line on the screen; extra characters that don’t fit on the screen are not displayed. In the other modes each line of text will be broken up into several screen lines if necessary to keep all the characters visible. In char mode a screen line break may occur after any character; in word mode a line break will only be made at word boundaries.

Description

The text command creates a new window (given by the pathName argument) and makes it into a text widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the text such as its default background color and relief. The text command returns the path name of the new window.

A text widget displays one or more lines of text and allows that text to be edited. Text widgets support three different kinds of annotations on the text, called tags, marks, and windows. Tags allow different portions of the text to be displayed with different fonts and colors. In addition, Tcl commands can be associated with tags so that commands are invoked when particular actions such as keystrokes and mouse button presses occur in particular ranges of the text. See TAGS below for more details.

The second form of annotation consists of marks, which are floating markers in the text. Marks are used to keep track of various interesting positions in the text as it is edited. See MARKS below for more details.

The third form of annotation allows arbitrary windows to be displayed in the text widget. See WINDOWS below for more details.

Indices

Many of the widget commands for texts take one or more indices as arguments. An index is a string used to indicate a particular place within a text, such as a place to insert characters or one endpoint of a range of characters to delete. Indices have the syntax

base modifier modifier modifier ...

Where base gives a starting point and the modifiers adjust the index from the starting point (e.g. move forward or backward one character). Every index must contain a base, but the modifiers are optional.

The base for an index must have one of the following forms:

line.char

Indicates char’th character on line line. Lines are numbered from 1 for consistency with other UNIX programs that use this numbering scheme. Within a line, characters are numbered from 0.

@x,y

Indicates the character that covers the pixel whose x and y coordinates within the text’s window are x and y.

end

Indicates the last character in the text, which is always a newline character.

mark

Indicates the character just after the mark whose name is mark.

tag.first

Indicates the first character in the text that has been tagged with tag. This form generates an error if no characters are currently tagged with tag.

tag.last

Indicates the character just after the last one in the text that has been tagged with tag. This form generates an error if no characters are currently tagged with tag.

If modifiers follow the base index, each one of them must have one of the forms listed below. Keywords such as chars and wordend may be abbreviated as long as the abbreviation is unambiguous.

+ count chars

Adjust the index forward by count characters, moving to later lines in the text if necessary. If there are fewer than count characters in the text after the current index, then set the index to the last character in the text. Spaces on either side of count are optional.

- count chars

Adjust the index backward by count characters, moving to earlier lines in the text if necessary. If there are fewer than count characters in the text before the current index, then set the index to the first character in the text. Spaces on either side of count are optional.

+ count lines

Adjust the index forward by count lines, retaining the same character position within the line. If there are fewer than count lines after the line containing the current index, then set the index to refer to the same character position on the last line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of count are optional.

- count lines

Adjust the index backward by count lines, retaining the same character position within the line. If there are fewer than count lines before the line containing the current index, then set the index to refer to the same character position on the first line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of count are optional.

linestart

Adjust the index to refer to the first character on the line.

lineend

Adjust the index to refer to the last character on the line (the newline).

wordstart

Adjust the index to refer to the first character of the word containing the current index. A word consists of any number of adjacent characters that are letters, digits, or underscores, or a single character that is not one of these.

wordend

Adjust the index to refer to the character just after the last one of the word containing the current index. If the current index refers to the last character of the text then it is not modified.

If more than one modifier is present then they are applied in left-to-right order. For example, the index “\fBend \- 1 chars” refers to the next-to-last character in the text and “\fBinsert wordstart \- 1 c” refers to the character just before the first one in the word containing the insertion cursor.

Tags

The first form of annotation in text widgets is a tag. A tag is a textual string that is associated with some of the characters in a text. There may be any number of tags associated with characters in a text. Each tag may refer to a single character, a range of characters, or several ranges of characters. An individual character may have any number of tags associated with it.

A priority order is defined among tags, and this order is used in implementing some of the tag-related functions described below. When a tag is defined (by associating it with characters or setting its display options or binding commands to it), it is given a priority higher than any existing tag. The priority order of tags may be redefined using the “pathName :tag :raise” and “pathName :tag :lower” widget commands.

Tags serve three purposes in text widgets. First, they control the way information is displayed on the screen. By default, characters are displayed as determined by the background, font, and foreground options for the text widget. However, display options may be associated with individual tags using the “pathName :tag configure” widget command. If a character has been tagged, then the display options associated with the tag override the default display style. The following options are currently supported for tags:

:background color

Color specifies the background color to use for characters associated with the tag. It may have any of the forms accepted by Tk_GetColor.

:bgstipple bitmap

Bitmap specifies a bitmap that is used as a stipple pattern for the background. It may have any of the forms accepted by Tk_GetBitmap. If bitmap hasn’t been specified, or if it is specified as an empty string, then a solid fill will be used for the background.

:borderwidth pixels

Pixels specifies the width of a 3-D border to draw around the background. It may have any of the forms accepted by Tk_GetPixels. This option is used in conjunction with the :relief option to give a 3-D appearance to the background for characters; it is ignored unless the :background option has been set for the tag.

:fgstipple bitmap

Bitmap specifies a bitmap that is used as a stipple pattern when drawing text and other foreground information such as underlines. It may have any of the forms accepted by Tk_GetBitmap. If bitmap hasn’t been specified, or if it is specified as an empty string, then a solid fill will be used.

:font fontName

FontName is the name of a font to use for drawing characters. It may have any of the forms accepted by Tk_GetFontStruct.

:foreground color

Color specifies the color to use when drawing text and other foreground information such as underlines. It may have any of the forms accepted by Tk_GetColor.

:relief relief

\fIRelief specifies the 3-D relief to use for drawing backgrounds, in any of the forms accepted by Tk_GetRelief. This option is used in conjunction with the :borderwidth option to give a 3-D appearance to the background for characters; it is ignored unless the :background option has been set for the tag.

:underline boolean

Boolean specifies whether or not to draw an underline underneath characters. It may have any of the forms accepted by Tk_GetBoolean.

If a character has several tags associated with it, and if their display options conflict, then the options of the highest priority tag are used. If a particular display option hasn’t been specified for a particular tag, or if it is specified as an empty string, then that option will never be used; the next-highest-priority tag’s option will used instead. If no tag specifies a particular display optionl, then the default style for the widget will be used.

The second purpose for tags is event bindings. You can associate bindings with a tag in much the same way you can associate bindings with a widget class: whenever particular X events occur on characters with the given tag, a given Tcl command will be executed. Tag bindings can be used to give behaviors to ranges of characters; among other things, this allows hypertext-like features to be implemented. For details, see the description of the tag bind widget command below.

The third use for tags is in managing the selection. See THE SELECTION below.

Marks

The second form of annotation in text widgets is a mark. Marks are used for remembering particular places in a text. They are something like tags, in that they have names and they refer to places in the file, but a mark isn’t associated with particular characters. Instead, a mark is associated with the gap between two characters. Only a single position may be associated with a mark at any given time. If the characters around a mark are deleted the mark will still remain; it will just have new neighbor characters. In contrast, if the characters containing a tag are deleted then the tag will no longer have an association with characters in the file. Marks may be manipulated with the “pathName :mark” widget command, and their current locations may be determined by using the mark name as an index in widget commands.

The name space for marks is different from that for tags: the same name may be used for both a mark and a tag, but they will refer to different things.

Two marks have special significance. First, the mark insert is associated with the insertion cursor, as described under THE INSERTION CURSOR below. Second, the mark current is associated with the character closest to the mouse and is adjusted automatically to track the mouse position and any changes to the text in the widget (one exception: current is not updated in response to mouse motions if a mouse button is down; the update will be deferred until all mouse buttons have been released). Neither of these special marks may be unset.

Windows

The third form of annotation in text widgets is a window. Window support isn’t implemented yet, but when it is it will be described here.

The Selection

Text widgets support the standard X selection. Selection support is implemented via tags. If the exportSelection option for the text widget is true then the sel tag will be associated with the selection:

  • [1] Whenever characters are tagged with sel the text widget will claim ownership of the selection.
  • [2] Attempts to retrieve the selection will be serviced by the text widget, returning all the charaters with the sel tag.
  • [3] If the selection is claimed away by another application or by another window within this application, then the sel tag will be removed from all characters in the text.

The sel tag is automatically defined when a text widget is created, and it may not be deleted with the “pathName :tag delete” widget command. Furthermore, the selectBackground, selectBorderWidth, and selectForeground options for the text widget are tied to the :background, :borderwidth, and :foreground options for the sel tag: changes in either will automatically be reflected in the other.

The Insertion Cursor

The mark named insert has special significance in text widgets. It is defined automatically when a text widget is created and it may not be unset with the “pathName :mark unset” widget command. The insert mark represents the position of the insertion cursor, and the insertion cursor will automatically be drawn at this point whenever the text widget has the input focus.

A Text Widget’s Arguments

The text command creates a new Tcl command whose name is the same as the path name of the text’s window. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

PathName is the name of the command, which is the same as the text widget’s path name. Option and the args determine the exact behavior of the command. The following commands are possible for text widgets:

pathName :compare index1 op index2

Compares the indices given by index1 and index2 according to the relational operator given by op, and returns 1 if the relationship is satisfied and 0 if it isn’t. Op must be one of the operators <, <=, ==, >=, >, or !=. If op is == then 1 is returned if the two indices refer to the same character, if op is < then 1 is returned if index1 refers to an earlier character in the text than index2, and so on.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the text command.

pathName :debug ?boolean?

If boolean is specified, then it must have one of the true or false values accepted by Tcl_GetBoolean. If the value is a true one then internal consistency checks will be turned on in the B-tree code associated with text widgets. If boolean has a false value then the debugging checks will be turned off. In either case the command returns an empty string. If boolean is not specified then the command returns on or off to indicate whether or not debugging is turned on. There is a single debugging switch shared by all text widgets: turning debugging on or off in any widget turns it on or off for all widgets. For widgets with large amounts of text, the consistency checks may cause a noticeable slow-down.

pathName :delete index1 ?index2?

Delete a range of characters from the text. If both index1 and index2 are specified, then delete all the characters starting with the one given by index1 and stopping just before index2 (i.e. the character at index2 is not deleted). If index2 doesn’t specify a position later in the text than index1 then no characters are deleted. If index2 isn’t specified then the single character at index1 is deleted. It is not allowable to delete characters in a way that would leave the text without a newline as the last character. The command returns an empty string.

pathName :get index1 ?index2?

Return a range of characters from the text. The return value will be all the characters in the text starting with the one whose index is index1 and ending just before the one whose index is index2 (the character at index2 will not be returned). If index2 is omitted then the single character at index1 is returned. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then an empty string is returned.

pathName :index index

Returns the position corresponding to index in the form line.char where line is the line number and char is the character number. Index may have any of the forms described under INDICES above.

pathName :insert \fIindex chars

Inserts chars into the text just before the character at index and returns an empty string. It is not possible to insert characters after the last newline of the text.

pathName :mark option ?arg arg ...?

This command is used to manipulate marks. The exact behavior of the command depends on the option argument that follows the mark argument. The following forms of the command are currently supported:

pathName :mark :names

Returns a list whose elements are the names of all the marks that are currently set.

pathName :mark :set markName index

Sets the mark named markName to a position just before the character at index. If markName already exists, it is moved from its old position; if it doesn’t exist, a new mark is created. This command returns an empty string.

pathName :mark :unset markName ?markName markName ...?

Remove the mark corresponding to each of the markName arguments. The removed marks will not be usable in indices and will not be returned by future calls to “pathName :mark names”. This command returns an empty string.

pathName :scan option args

This command is used to implement scanning on texts. It has two forms, depending on option:

pathName :scan :mark y

Records y and the current view in the text window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string.

pathName :scan :dragto y

This command computes the difference between its y argument and the y argument to the last scan mark command for the widget. It then adjusts the view up or down by 10 times the difference in y-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the text at high speed through the window. The return value is an empty string.

pathName :tag option ?arg arg ...?

This command is used to manipulate tags. The exact behavior of the command depends on the option argument that follows the tag argument. The following forms of the command are currently supported:

pathName :tag :add tagName index1 ?index2?

Associate the tag tagName with all of the characters starting with index1 and ending just before index2 (the character at index2 isn’t tagged). If index2 is omitted then the single character at index1 is tagged. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then the command has no effect. This command returns an empty string.

pathName :tag :bind tagName ?sequence? ?command?

This command associates command with the tag given by tagName. Whenever the event sequence given by sequence occurs for a character that has been tagged with tagName, the command will be invoked. This widget command is similar to the bind command except that it operates on characters in a text rather than entire widgets. See the bind manual entry for complete details on the syntax of sequence and the substitutions performed on command before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same sequence and tagName (if the first character of command is “+” then command augments an existing binding rather than replacing it). In this case the return value is an empty string. If command is omitted then the command returns the command associated with tagName and sequence (an error occurs if there is no such binding). If both command and sequence are omitted then the command returns a list of all the sequences for which bindings have been defined for tagName.

The only events for which bindings may be specified are those related to the mouse and keyboard, such as Enter, Leave, ButtonPress, Motion, and KeyPress. Event bindings for a text widget use the current mark described under MARKS above. Enter events trigger for a character when it becomes the current character (i.e. the current mark moves to just in front of that character). Leave events trigger for a character when it ceases to be the current item (i.e. the current mark moves away from that character, or the character is deleted). These events are different than Enter and Leave events for windows. Mouse and keyboard events are directed to the current character.

It is possible for the current character to have multiple tags, and for each of them to have a binding for a particular event sequence. When this occurs, the binding from the highest priority tag is used. If a particular tag doesn’t have a binding that matches an event, then the tag is ignored and tags with lower priority will be checked.

If bindings are created for the widget as a whole using the bind command, then those bindings will supplement the tag bindings. This means that a single event can trigger two Tcl scripts, one for a widget-level binding and one for a tag-level binding.

pathName :tag :configure tagName ?option? ?value? ?option value ...?

This command is similar to the configure widget command except that it modifies options associated with the tag given by tagName instead of modifying options for the overall text widget. If no option is specified, the command returns a list describing all of the available options for tagName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given option(s) to have the given value(s) in tagName; in this case the command returns an empty string. See TAGS above for details on the options available for tags.

pathName :tag :delete tagName ?tagName ...?

Deletes all tag information for each of the tagName arguments. The command removes the tags from all characters in the file and also deletes any other information associated with the tags, such as bindings and display information. The command returns an empty string.

pathName :tag :lower tagName ?belowThis?

Changes the priority of tag tagName so that it is just lower in priority than the tag whose name is belowThis. If belowThis is omitted, then tagName’s priority is changed to make it lowest priority of all tags.

pathName :tag :names ?index?

Returns a list whose elements are the names of all the tags that are active at the character position given by index. If index is omitted, then the return value will describe all of the tags that exist for the text (this includes all tags that have been named in a “pathName :tag” widget command but haven’t been deleted by a “pathName :tag :delete” widget command, even if no characters are currently marked with the tag). The list will be sorted in order from lowest priority to highest priority.

pathName :tag :nextrange tagName index1 ?index2?

This command searches the text for a range of characters tagged with tagName where the first character of the range is no earlier than the character at index1 and no later than the character just before index2 (a range starting at index2 will not be considered). If several matching ranges exist, the first one is chosen. The command’s return value is a list containing two elements, which are the index of the first character of the range and the index of the character just after the last one in the range. If no matching range is found then the return value is an empty string. If index2 is not given then it defaults to the end of the text.

pathName :tag :raise tagName ?aboveThis?

Changes the priority of tag tagName so that it is just higher in priority than the tag whose name is aboveThis. If aboveThis is omitted, then tagName’s priority is changed to make it highest priority of all tags.

pathName :tag :ranges tagName

Returns a list describing all of the ranges of text that have been tagged with tagName. The first two elements of the list describe the first tagged range in the text, the next two elements describe the second range, and so on. The first element of each pair contains the index of the first character of the range, and the second element of the pair contains the index of the character just after the last one in the range. If there are no characters tagged with tag then an empty string is returned.

pathName :tag :remove tagName index1 ?index2?

Remove the tag tagName from all of the characters starting at index1 and ending just before index2 (the character at index2 isn’t affected). If index2 is omitted then the single character at index1 is untagged. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then the command has no effect. This command returns an empty string.

pathName :yview ?:pickplace? what

This command changes the view in the widget’s window so that the line given by what is visible in the window. What may be either an absolute line number, where 0 corresponds to the first line of the file, or an index with any of the forms described under INDICES above. The first form (absolute line number) is used in the commands issued by scrollbars to control the widget’s view. If the :pickplace option isn’t specified then what will appear at the top of the window. If :pickplace is specified then the widget chooses where what appears in the window:

  • [1] If what is already visible somewhere in the window then the command does nothing.
  • [2] If what is only a few lines off-screen above the window then it will be positioned at the top of the window.
  • [3] If what is only a few lines off-screen below the window then it will be positioned at the bottom of the window.
  • [4] Otherwise, what will be centered in the window.

The :pickplace option is typically used after inserting text to make sure that the insertion cursor is still visible on the screen. This command returns an empty string.

Bindings

Tk automatically creates class bindings for texts that give them the following default behavior:

  • [1] Pressing mouse button 1 in an text positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget.
  • [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse.
  • [3] If you double-press mouse button 1 then the word under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the word, and dragging the mouse will stroke out a selection whole words at a time.
  • [4] If you triple-press mouse button 1 then the line under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the line, and dragging the mouse will stroke out a selection whole line at a time.
  • [5] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. If the selection was made in word or line mode then it will be adjusted in this same mode.
  • [6] The view in the text can be adjusted by dragging with mouse button 2.
  • [7] If the input focus is in a text widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor.
  • [8] Control+h and the Backspace and Delete keys erase the character just before the insertion cursor.
  • [9] Control+v inserts the current selection just before the insertion cursor.
  • [10] Control+d deletes the selected characters; an error occurs if the selection is not in this widget.

If the text is disabled using the state option, then the text’s view can still be adjusted and text in the text can still be selected, but no insertion cursor will be displayed and no text modifications will take place.

The behavior of texts can be changed by defining new bindings for individual widgets or by redefining the class bindings.

"Performance Issues"

Text widgets should run efficiently under a variety of conditions. The text widget uses about 2-3 bytes of main memory for each byte of text, so texts containing a megabyte or more should be practical on most workstations. Text is represented internally with a modified B-tree structure that makes operations relatively efficient even with large texts. Tags are included in the B-tree structure in a way that allows tags to span large ranges or have many disjoint smaller ranges without loss of efficiency. Marks are also implemented in a way that allows large numbers of marks. The only known mode of operation where a text widget may not run efficiently is if it has a very large number of different tags. Hundreds of tags should be fine, or even a thousand, but tens of thousands of tags will make texts consume a lot of memory and run slowly.

Keywords

text, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/tk_002dmenu_002dbar.html0000644000175000017500000002054514360276512017245 0ustar cammcamm tk-menu-bar (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.10 tk-menu-bar

tk-menu-bar, tk_bindForTraversal \- Support for menu bars

Synopsis

tk-menu-bar frame ?menu menu ...?


tk_bindForTraversal arg arg ...

Description

These two commands are Tcl procedures in the Tk script library. They provide support for menu bars. A menu bar is a frame that contains a collection of menu buttons that work together, so that the user can scan from one menu to another with the mouse: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. Menus in a menu bar can also be accessed using keyboard traversal (i.e. by typing keystrokes instead of using the mouse). In order for an application to use these procedures, it must do three things, which are described in the paragraphs below.

First, each application must call tk-menu-bar to provide information about the menubar. The frame argument gives the path name of the frame that contains all of the menu buttons, and the menu arguments give path names for all of the menu buttons associated with the menu bar. Normally frame is the parent of each of the menu’s. This need not be the case, but frame must be an ancestor of each of the menu’s in order for grabs to work correctly when the mouse is used to pull down menus. The order of the menu arguments determines the traversal order for the menu buttons. If tk-menu-bar is called without any menu arguments, it returns a list containing the current menu buttons for frame, or an empty string if frame isn’t currently set up as a menu bar. If tk-menu-bar is called with a single menu argument consisting of an empty string, any menubar information for frame is removed; from now on the menu buttons will function independently without keyboard traversal. Only one menu bar may be defined at a time within each top-level window.

The second thing an application must do is to identify the traversal characters for menu buttons and menu entries. This is done by underlining those characters using the :underline options for the widgets. The menu traversal system uses this information to traverse the menus under keyboard control (see below).

The third thing that an application must do is to make sure that the input focus is always in a window that has been configured to support menu traversal. If the input focus is none then input characters will be discarded and no menu traversal will be possible. If you have no other place to set the focus, set it to the menubar widget: tk-menu-bar creates bindings for its frame argument to support menu traversal.

The Tk startup scripts configure all the Tk widget classes with bindings to support menu traversal, so menu traversal will be possible regardless of which widget has the focus. If your application defines new classes of widgets that support the input focus, then you should call tk_bindForTraversal for each of these classes. Tk_bindForTraversal takes any number of arguments, each of which is a widget path name or widget class name. It sets up bindings for all the named widgets and classes so that the menu traversal system will be invoked when appropriate keystrokes are typed in those widgets or classes.

"Menu Traversal Bindings"

Once an application has made the three arrangements described above, menu traversal will be available. At any given time, the only menus available for traversal are those associated with the top-level window containing the input focus. Menu traversal is initiated by one of the following actions:

  • [1] If <F10> is typed, then the first menu button in the list for the top-level window is posted and the first entry within that menu is selected.
  • [2] If <Alt-key> is pressed, then the menu button that has key as its underlined character is posted and the first entry within that menu is selected. The comparison between key and the underlined characters ignores case differences. If no menu button matches key then the keystroke has no effect.
  • [3] Clicking mouse button 1 on a menu button posts that menu and selects its first entry.

Once a menu has been posted, the input focus is switched to that menu and the following actions are possible:

  • [1] Typing <ESC> or clicking mouse button 1 outside the menu button or its menu will abort the menu traversal.
  • [2] If <Alt-key> is pressed, then the entry in the posted menu whose underlined character is key is invoked. This causes the menu to be unposted, the entry’s action to be taken, and the menu traversal to end. The comparison between key and underlined characters ignores case differences. If no menu entry matches key then the keystroke is ignored.
  • [3] The arrow keys may be used to move among entries and menus. The left and right arrow keys move circularly among the available menus and the up and down arrow keys move circularly among the entries in the current menu.
  • [4] If <Return> is pressed, the selected entry in the posted menu is invoked, which causes the menu to be unposted, the entry’s action to be taken, and the menu traversal to end.

When a menu traversal completes, the input focus reverts to the window that contained it when the traversal started.

Keywords

keyboard traversal, menu, menu bar, post

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/frame.html0000644000175000017500000001641714360276512015100 0ustar cammcamm frame (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.12 frame

frame \- Create and manipulate frame widgets

Synopsis

frame pathName ?:class className? ?options?

Standard Options

background             cursor             relief           
borderWidth            geometry

See options, for more information.

Arguments for Frame

:height

Name="height" Class="Height"


Specifies the desired height for the window in any of the forms acceptable to Tk_GetPixels. This option is only used if the :geometry option is unspecified. If this option is less than or equal to zero (and :geometry is not specified) then the window will not request any size at all.

:width

Name="width" Class="Width"


Specifies the desired width for the window in any of the forms acceptable to Tk_GetPixels. This option is only used if the :geometry option is unspecified. If this option is less than or equal to zero (and :geometry is not specified) then the window will not request any size at all.

Description

The frame command creates a new window (given by the pathName argument) and makes it into a frame widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the frame such as its background color and relief. The frame command returns the path name of the new window.

A frame is a simple widget. Its primary purpose is to act as a spacer or container for complex window layouts. The only features of a frame are its background color and an optional 3-D border to make the frame appear raised or sunken.

In addition to the standard options listed above, a :class option may be specified on the command line. If it is specified, then the new widget’s class will be set to className instead of Frame. Changing the class of a frame widget may be useful in order to use a special class name in database options referring to this widget and its children. Note: :class is handled differently than other command-line options and cannot be specified using the option database (it has to be processed before the other options are even looked up, since the new class name will affect the lookup of the other options). In addition, the :class option may not be queried or changed using the config command described below.

A Frame Widget’s Arguments

The frame command creates a new Tcl command whose name is the same as the path name of the frame’s window. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

PathName is the name of the command, which is the same as the frame widget’s path name. Option and the args determine the exact behavior of the command. The following commands are possible for frame widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the frame command.

Bindings

When a new frame is created, it has no default event bindings: frames are not intended to be interactive.

Keywords

frame, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/Linked-Variables.html0000644000175000017500000001534314360276512017117 0ustar cammcamm Linked Variables (GCL TK Manual)

Next: , Previous: , Up: General   [Contents]

1.7 Linked Variables

It is possible to link lisp variables to TK variables. In general when the TK variable is changed, by for instance clicking on a radiobutton, the linked lisp variable will be changed. Conversely changing the lisp variable will be noticed by the TK graphics side, if one does the assignment in lisp using setk instead of setq. 

(button '.hello :textvariable '*message* :text "hi there")
(pack '.hello)

This causes linking of the global variable *message* in lisp to a corresponding variable in TK. Moreover the message that is in the button .hello will be whatever the value of this global variable is (so long as the TK side is notified of the change!).

Thus if one does 

(setk *message* "good bye")

then the button will change to have good bye as its text. The lisp macro setk expands into 

(prog1 (setf *message* "good bye") (notice-text-variables))

which does the assignment, and then goes thru the linked variables checking for those that have changed, and updating the TK side should there be any. Thus if you have a more complex program which might have done the assignment of your global variable, you may include the call to notice-text-variables at the end, to assure that the graphics side knows about the changes.

A variable which is linked using the keyword :textvariable is always a variable containing a string.

However it is possible to have other types of variables. 

(checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*))
(checkbutton '.checkbutton2 :text "A button" :variable '*joe*)
(checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*)
              :onvalue 100 :offvalue -1)

The first two examples are the same in that the default variable type for a checkbutton is boolean. Notice that the specification of a variable type is by (type variable). The types which are permissible are those which have coercion-fucntions, See Return Values. In the first example a variable *joe* will be linked, and its default initial value will be set to nil, since the default initial state of the check button is off, and the default off value is nil. Actually on the TK side, the corresponding boolean values are "1" and "0", but the boolean type makes these become t and nil.

In the third example the variable *debug* may have any lisp value (here type is t). The initial value will be made to be -1, since the checkbutton is off. Clicking on .checkbutton3 will result in the value of *debug* being changed to 100, and the light in the button will be toggled to on, See checkbutton. You may set the variable to be another value besides 100.

You may also call 

(link-text-variable '*joe* 'boolean)

to cause the linking of a variable named *joe*. This is done automatically whenever the variable is specified after one of the keys 

:variable   :textvariable.

Just as one must be cautious about using global variables in lisp, one must be cautious in making such linked variables. In particular note that the TK side, uses variables for various purposes. If you make a checkbutton with pathname .a.b.c then unless you specify a :variable option, the variable c will become associated to the TK value of the checkbutton. We do NOT link this variable by default, feeling that one might inadvertently alter global variables, and that they would not typically use the lisp convention of being of the form *c*. You must specify the :variable option, or call link-variable.

Next: , Previous: , Up: General   [Contents]

gcl-2.6.14/info/gcl-tk/listbox.html0000644000175000017500000003043514360276512015466 0ustar cammcamm listbox (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.2 listbox

listbox \- Create and manipulate listbox widgets

Synopsis

listbox pathName ?options?

Standard Options

background       foreground  selectBackground   xScrollCommand  
borderWidth      font        selectBorderWidth  yScrollCommand  
cursor           geometry    selectForeground   
exportSelection  relief      setGrid

See options, for more information.

Arguments for Listbox

None.

Description

The listbox command creates a new window (given by the pathName argument) and makes it into a listbox widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the listbox such as its colors, font, text, and relief. The listbox command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A listbox is a widget that displays a list of strings, one per line. When first created, a new listbox has no elements in its list. Elements may be added or deleted using widget commands described below. In addition, one or more elements may be selected as described below. If a listbox is exporting its selection (see exportSelection option), then it will observe the standard X11 protocols for handling the selection; listbox selections are available as type STRING, consisting of a Tcl list with one entry for each selected element.

For large lists only a subset of the list elements will be displayed in the listbox window at once; commands described below may be used to change the view in the window. Listboxes allow scrolling in both directions using the standard xScrollCommand and yScrollCommand options. They also support scanning, as described below.

A Listbox’s Arguments

The listbox command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for listbox widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the listbox command.

pathName :curselection

Returns a list containing the indices of all of the elements in the listbox that are currently selected. If there are no elements selected in the listbox then an empty string is returned.

pathName :delete first ?last?

Delete one or more elements of the listbox. First and last give the integer indices of the first and last elements in the range to be deleted. If last isn’t specified it defaults to first, i.e. a single element is deleted. An index of 0 corresponds to the first element in the listbox. Either first or last may be specified as end, in which case it refers to the last element of the listbox. This command returns an empty string

pathName :get index

Return the contents of the listbox element indicated by index. Index must be a non-negative integer (0 corresponds to the first element in the listbox), or it may also be specified as end to indicate the last element in the listbox.

pathName :insert index ?element element ...?

Insert zero or more new elements in the list just before the element given by index. If index is specified as end then the new elements are added to the end of the list. Returns an empty string.

pathName :nearest y

Given a y-coordinate within the listbox window, this command returns the index of the (visible) listbox element nearest to that y-coordinate.

pathName :scan option args

This command is used to implement scanning on listboxes. It has two forms, depending on option:

pathName :scan :mark x y

Records x and y and the current view in the listbox window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string.

pathName :scan :dragto x y.

This command computes the difference between its x and y arguments and the x and y arguments to the last scan mark command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the list at high speed through the window. The return value is an empty string.

pathName :select option arg

This command is used to adjust the selection within a listbox. It has several forms, depending on option. In all of the forms the index end refers to the last element in the listbox.

pathName :select :adjust index

Locate the end of the selection nearest to the element given by index, and adjust that end of the selection to be at index (i.e including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn’t currently in the listbox, then this command is identical to the select from widget command. Returns an empty string.

pathName :select :clear

If the selection is in this listbox then it is cleared so that none of the listbox’s elements are selected anymore.

pathName :select :from index

Set the selection to consist of element index, and make index the anchor point for future select to widget commands. Returns an empty string.

pathName :select :to index

Set the selection to consist of the elements from the anchor point to element index, inclusive. The anchor point is determined by the most recent select from or select adjust command in this widget. If the selection isn’t in this widget, this command is identical to select from. Returns an empty string.

pathName :size

Returns a decimal string indicating the total number of elements in the listbox.

pathName :xview index

Adjust the view in the listbox so that character position index is displayed at the left edge of the widget. Returns an empty string.

pathName :yview index

Adjust the view in the listbox so that element index is displayed at the top of the widget. If index is specified as end it indicates the last element of the listbox. Returns an empty string.

"Default Bindings"

Tk automatically creates class bindings for listboxes that give them the following default behavior:

  • [1] When button 1 is pressed over a listbox, the element underneath the mouse cursor is selected. The mouse can be dragged to select a range of elements.
  • [2] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed.
  • [3] The view in the listbox can be adjusted by dragging with mouse button 2.

The behavior of listboxes can be changed by defining new bindings for individual widgets or by redefining the class bindings. In addition, the procedure tk_listboxSingleSelect may be invoked to change listbox behavior so that only a single element may be selected at once.

Keywords

listbox, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/tkerror.html0000644000175000017500000001005014360276512015461 0ustar cammcamm tkerror (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.20 tkerror

tkerror \- Command invoked to process background errors

Synopsis

tkerror message

Description

The tkerror command doesn’t exist as built-in part of Tk. Instead, individual applications or users can define a tkerror command (e.g. as a Tcl procedure) if they wish to handle background errors.

A background error is one that occurs in a command that didn’t originate with the application. For example, if an error occurs while executing a command specified with a bind of after command, then it is a background error. For a non-background error, the error can simply be returned up through nested Tcl command evaluations until it reaches the top-level code in the application; then the application can report the error in whatever way it wishes. When a background error occurs, the unwinding ends in the Tk library and there is no obvious way for Tk to report the error.

When Tk detects a background error, it invokes the tkerror command, passing it the error message as its only argument. Tk assumes that the application has implemented the tkerror command, and that the command will report the error in a way that makes sense for the application. Tk will ignore any result returned by the tkerror command.

If another Tcl error occurs within the tkerror command then Tk reports the error itself by writing a message to stderr.

The Tk script library includes a default tkerror procedure that posts a dialog box containing the error message and offers the user a chance to see a stack trace that shows where the error occurred.

Keywords

background error, reporting

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/tkwait.html0000644000175000017500000000702014360276512015277 0ustar cammcamm tkwait (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.22 tkwait

tkwait \- Wait for variable to change or window to be destroyed

Synopsis


tkwait :variable name

tkwait :visibility name
tkwait :window name

Description

The tkwait command waits for one of several things to happen, then it returns without taking any other actions. The return value is always an empty string. If the first argument is :variable (or any abbreviation of it) then the second argument is the name of a global variable and the command waits for that variable to be modified. If the first argument is :visibility (or any abbreviation of it) then the second argument is the name of a window and the tkwait command waits for a change in its visibility state (as indicated by the arrival of a VisibilityNotify event). This form is typically used to wait for a newly-created window to appear on the screen before taking some action. If the first argument is :window (or any abbreviation of it) then the second argument is the name of a window and the tkwait command waits for that window to be destroyed. This form is typically used to wait for a user to finish interacting with a dialog box before using the result of that interaction.

While the tkwait command is waiting it processes events in the normal fashion, so the application will continue to respond to user interactions.

Keywords

variable, visibility, wait, window

gcl-2.6.14/info/gcl-tk/checkbutton.html0000644000175000017500000003415714360276512016320 0ustar cammcamm checkbutton (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.7 checkbutton

checkbutton \- Create and manipulate check-button widgets

Synopsis

checkbutton pathName ?options?

Standard Options

activeBackground  bitmap              font        relief        
activeForeground  borderWidth         foreground  text          
anchor            cursor              padX        textVariable  
background        disabledForeground  padY

See options, for more information.

Arguments for Checkbutton

:command

Name="command" Class="Command"


Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button’s global variable (:variable option) will be updated before the command is invoked.

:height

Name="height" Class="Height"


Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn’t specified, the button’s desired height is computed from the size of the bitmap or text being displayed in it.

:offvalue

Name="offValue" Class="Value"


Specifies value to store in the button’s associated variable whenever this button is deselected. Defaults to “0”.

:onvalue

Name="onValue" Class="Value"


Specifies value to store in the button’s associated variable whenever this button is selected. Defaults to “1”.

:selector

Name="selector" Class="Foreground"


Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button.

:state

Name="state" Class="State"


Specifies one of three states for the check button: normal, active, or disabled. In normal state the check button is displayed using the foreground and background options. The active state is typically used when the pointer is over the check button. In active state the check button is displayed using the activeForeground and activeBackground options. Disabled state means that the check button is insensitive: it doesn’t activate and doesn’t respond to mouse button presses. In this state the disabledForeground and background options determine how the check button is displayed.

:variable

Name="variable" Class="Variable"


Specifies name of global variable to set to indicate whether or not this button is selected. Defaults to the name of the button within its parent (i.e. the last element of the button window’s path name).

:width

Name="width" Class="Width"


Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn’t specified, the button’s desired width is computed from the size of the bitmap or text being displayed in it.

Description

The checkbutton command creates a new window (given by the pathName argument) and makes it into a check-button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the check button such as its colors, font, text, and initial relief. The checkbutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A check button is a widget that displays a textual string or bitmap and a square called a selector. A check button has all of the behavior of a simple button, including the following: it can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button.

In addition, check buttons can be selected. If a check button is selected then a special highlight appears in the selector, and a Tcl variable associated with the check button is set to a particular value (normally 1). If the check button is not selected, then the selector is drawn in a different fashion and the associated variable is set to a different value (typically 0). By default, the name of the variable associated with a check button is the same as the name used to create the check button. The variable name, and the “on” and “off” values stored in it, may be modified with options on the command line or in the option database. By default a check button is configured to select and deselect itself on alternate button clicks. In addition, each check button monitors its associated variable and automatically selects and deselects itself when the variables value changes to and from the button’s “on” value.

A Checkbutton Widget’s Arguments

The checkbutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for check button widgets:

pathName :activate

Change the check button’s state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the check button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state active” instead.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the checkbutton command.

pathName :deactivate

Change the check button’s state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the check button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state normal” instead.

pathName :deselect

Deselect the check button: redisplay it without a highlight in the selector and set the associated variable to its “off” value.

pathName :flash

Flash the check button. This is accomplished by redisplaying the check button several times, alternating between active and normal colors. At the end of the flash the check button is left in the same normal/active state as when the command was invoked. This command is ignored if the check button’s state is disabled.

pathName :invoke

Does just what would have happened if the user invoked the check button with the mouse: toggle the selection state of the button and invoke the Tcl command associated with the check button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the check button. This command is ignored if the check button’s state is disabled.

pathName :select

Select the check button: display it with a highlighted selector and set the associated variable to its “on” value.

pathName :toggle

Toggle the selection state of the button, redisplaying it and modifying its associated variable to reflect the new state.

Bindings

Tk automatically creates class bindings for check buttons that give them the following default behavior:

  • [1] The check button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the check button.
  • [2] The check button’s relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released.
  • [3] If mouse button 1 is pressed over the check button and later released over the check button, the check button is invoked (i.e. its selection state toggles and the command associated with the button is invoked, if there is one). However, if the mouse is not over the check button when button 1 is released, then no invocation occurs.

If the check button’s state is disabled then none of the above actions occur: the check button is completely non-responsive.

The behavior of check buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Keywords

check button, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/winfo.html0000644000175000017500000003174114360276512015125 0ustar cammcamm winfo (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.24 winfo

winfo \- Return window-related information

Synopsis

winfo option ?arg arg ...?

Description

The winfo command is used to retrieve information about windows managed by Tk. It can take any of a number of different forms, depending on the option argument. The legal forms are:

winfo :atom name

Returns a decimal string giving the integer identifier for the atom whose name is name. If no atom exists with the name name then a new one is created.

winfo :atomname id

Returns the textual name for the atom whose integer identifier is id. This command is the inverse of the winfo :atom command. Generates an error if no such atom exists.

winfo :cells window

Returns a decimal string giving the number of cells in the color map for window.

winfo :children window

Returns a list containing the path names of all the children of window. Top-level windows are returned as children of their logical parents.

winfo :class window

Returns the class name for window.

winfo :containing rootX rootY

Returns the path name for the window containing the point given by rootX and rootY. RootX and rootY are specified in screen units (i.e. any form acceptable to Tk_GetPixels) in the coordinate system of the root window (if a virtual-root window manager is in use then the coordinate system of the virtual root window is used). If no window in this application contains the point then an empty string is returned. In selecting the containing window, children are given higher priority than parents and among siblings the highest one in the stacking order is chosen.

winfo :depth window

Returns a decimal string giving the depth of window (number of bits per pixel).

winfo :exists window

Returns 1 if there exists a window named window, 0 if no such window exists.

winfo :fpixels window number

Returns a floating-point value giving the number of pixels in window corresponding to the distance given by number. Number may be specified in any of the forms acceptable to Tk_GetScreenMM, such as “2.0c” or “1i”. The return value may be fractional; for an integer value, use winfo :pixels.

winfo :geometry window

Returns the geometry for window, in the form widthxheight+x+y. All dimensions are in pixels.

winfo :height window

Returns a decimal string giving window’s height in pixels. When a window is first created its height will be 1 pixel; the height will eventually be changed by a geometry manager to fulfill the window’s needs. If you need the true height immediately after creating a widget, invoke update to force the geometry manager to arrange it, or use winfo :reqheight to get the window’s requested height instead of its actual height.

winfo :id window

Returns a hexadecimal string indicating the X identifier for window.

winfo :interps

Returns a list whose members are the names of all Tcl interpreters (e.g. all Tk-based applications) currently registered for the display of the invoking application.

winfo :ismapped window

Returns 1 if window is currently mapped, 0 otherwise.

winfo :name window

Returns window’s name (i.e. its name within its parent, as opposed to its full path name). The command winfo :name . will return the name of the application.

winfo :parent window

Returns the path name of window’s parent, or an empty string if window is the main window of the application.

winfo :pathname id

Returns the path name of the window whose X identifier is id. Id must be a decimal, hexadecimal, or octal integer and must correspond to a window in the invoking application.

winfo :pixels window number

Returns the number of pixels in window corresponding to the distance given by number. Number may be specified in any of the forms acceptable to Tk_GetPixels, such as “2.0c” or “1i”. The result is rounded to the nearest integer value; for a fractional result, use winfo :fpixels.

winfo :reqheight window

Returns a decimal string giving window’s requested height, in pixels. This is the value used by window’s geometry manager to compute its geometry.

winfo :reqwidth window

Returns a decimal string giving window’s requested width, in pixels. This is the value used by window’s geometry manager to compute its geometry.

winfo :rgb window color

Returns a list containing three decimal values, which are the red, green, and blue intensities that correspond to color in the window given by window. Color may be specified in any of the forms acceptable for a color option.

winfo :rootx window

Returns a decimal string giving the x-coordinate, in the root window of the screen, of the upper-left corner of window’s border (or window if it has no border).

winfo :rooty window

Returns a decimal string giving the y-coordinate, in the root window of the screen, of the upper-left corner of window’s border (or window if it has no border).

winfo :screen window

Returns the name of the screen associated with window, in the form displayName.screenIndex.

winfo :screencells window

Returns a decimal string giving the number of cells in the default color map for window’s screen.

winfo :screendepth window

Returns a decimal string giving the depth of the root window of window’s screen (number of bits per pixel).

winfo :screenheight window

Returns a decimal string giving the height of window’s screen, in pixels.

winfo :screenmmheight window

Returns a decimal string giving the height of window’s screen, in millimeters.

winfo :screenmmwidth window

Returns a decimal string giving the width of window’s screen, in millimeters.

winfo :screenvisual window

Returns one of the following strings to indicate the default visual type for window’s screen: directcolor, grayscale, pseudocolor, staticcolor, staticgray, or truecolor.

winfo :screenwidth window

Returns a decimal string giving the width of window’s screen, in pixels.

winfo :toplevel window

Returns the path name of the top-level window containing window.

winfo :visual window

Returns one of the following strings to indicate the visual type for window: directcolor, grayscale, pseudocolor, staticcolor, staticgray, or truecolor.

winfo :vrootheight window

Returns the height of the virtual root window associated with window if there is one; otherwise returns the height of window’s screen.

winfo :vrootwidth window

Returns the width of the virtual root window associated with window if there is one; otherwise returns the width of window’s screen.

winfo :vrootx window

Returns the x-offset of the virtual root window associated with window, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for window.

winfo :vrooty window

Returns the y-offset of the virtual root window associated with window, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for window.

winfo :width window

Returns a decimal string giving window’s width in pixels. When a window is first created its width will be 1 pixel; the width will eventually be changed by a geometry manager to fulfill the window’s needs. If you need the true width immediately after creating a widget, invoke update to force the geometry manager to arrange it, or use winfo :reqwidth to get the window’s requested width instead of its actual width.

winfo :x window

Returns a decimal string giving the x-coordinate, in window’s parent, of the upper-left corner of window’s border (or window if it has no border).

winfo :y window

Returns a decimal string giving the y-coordinate, in window’s parent, of the upper-left corner of window’s border (or window if it has no border).

Keywords

atom, children, class, geometry, height, identifier, information, interpreters, mapped, parent, path name, screen, virtual root, width, window

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/raise.html0000644000175000017500000000570514360276512015107 0ustar cammcamm raise (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.16 raise

raise \- Change a window’s position in the stacking order

Synopsis

raise window ?aboveThis?

Description

If the aboveThis argument is omitted then the command raises window so that it is above all of its siblings in the stacking order (it will not be obscured by any siblings and will obscure any siblings that overlap it). If aboveThis is specified then it must be the path name of a window that is either a sibling of window or the descendant of a sibling of window. In this case the raise command will insert window into the stacking order just above aboveThis (or the ancestor of aboveThis that is a sibling of window); this could end up either raising or lowering window.

Keywords

obscure, raise, stacking order

gcl-2.6.14/info/gcl-tk/menu.html0000644000175000017500000006020314360276512014742 0ustar cammcamm menu (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.5 menu

menu \- Create and manipulate menu widgets

Synopsis

menu pathName ?options?

Standard Options

activeBackground       background       disabledForeground      
activeBorderWidth      borderWidth      font                    
activeForeground       cursor           foreground

See options, for more information.

Arguments for Menu

:postcommand

Name="postCommand" Class="Command"


If this option is specified then it provides a Tcl command to execute each time the menu is posted. The command is invoked by the post widget command before posting the menu.

:selector

Name="selector" Class="Foreground"


For menu entries that are check buttons or radio buttons, this option specifies the color to display in the selector when the check button or radio button is selected.

Introduction

The menu command creates a new top-level window (given by the pathName argument) and makes it into a menu widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menu such as its colors and font. The menu command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A menu is a widget that displays a collection of one-line entries arranged in a column. There exist several different types of entries, each with different properties. Entries of different types may be combined in a single menu. Menu entries are not the same as entry widgets. In fact, menu entries are not even distinct widgets; the entire menu is one widget.

Menu entries are displayed with up to three separate fields. The main field is a label in the form of text or a bitmap, which is determined by the :label or :bitmap option for the entry. If the :accelerator option is specified for an entry then a second textual field is displayed to the right of the label. The accelerator typically describes a keystroke sequence that may be typed in the application to cause the same result as invoking the menu entry. The third field is a selector. The selector is present only for check-button or radio-button entries. It indicates whether the entry is selected or not, and is displayed to the left of the entry’s string.

In normal use, an entry becomes active (displays itself differently) whenever the mouse pointer is over the entry. If a mouse button is released over the entry then the entry is invoked. The effect of invocation is different for each type of entry; these effects are described below in the sections on individual entries.

Entries may be disabled, which causes their labels and accelerators to be displayed with dimmer colors. A disabled entry cannot be activated or invoked. Disabled entries may be re-enabled, at which point it becomes possible to activate and invoke them again.

Command Entries

The most common kind of menu entry is a command entry, which behaves much like a button widget. When a command entry is invoked, a Tcl command is executed. The Tcl command is specified with the :command option.

Separator Entries

A separator is an entry that is displayed as a horizontal dividing line. A separator may not be activated or invoked, and it has no behavior other than its display appearance.

Check-Button Entries

A check-button menu entry behaves much like a check-button widget. When it is invoked it toggles back and forth between the selected and deselected states. When the entry is selected, a particular value is stored in a particular global variable (as determined by the :onvalue and :variable options for the entry); when the entry is deselected another value (determined by the :offvalue option) is stored in the global variable. A selector box is displayed to the left of the label in a check-button entry. If the entry is selected then the box’s center is displayed in the color given by the selector option for the menu; otherwise the box’s center is displayed in the background color for the menu. If a :command option is specified for a check-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after toggling the entry’s selected state.

Radio-Button Entries

A radio-button menu entry behaves much like a radio-button widget. Radio-button entries are organized in groups of which only one entry may be selected at a time. Whenever a particular entry becomes selected it stores a particular value into a particular global variable (as determined by the :value and :variable options for the entry). This action causes any previously-selected entry in the same group to deselect itself. Once an entry has become selected, any change to the entry’s associated variable will cause the entry to deselect itself. Grouping of radio-button entries is determined by their associated variables: if two entries have the same associated variable then they are in the same group. A selector diamond is displayed to the left of the label in each radio-button entry. If the entry is selected then the diamond’s center is displayed in the color given by the selector option for the menu; otherwise the diamond’s center is displayed in the background color for the menu. If a :command option is specified for a radio-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after selecting the entry.

Cascade Entries

A cascade entry is one with an associated menu (determined by the :menu option). Cascade entries allow the construction of cascading menus. When the entry is activated, the associated menu is posted just to the right of the entry; that menu remains posted until the higher-level menu is unposted or until some other entry is activated in the higher-level menu. The associated menu should normally be a child of the menu containing the cascade entry, in order for menu traversal to work correctly.

A cascade entry posts its associated menu by invoking a Tcl command of the form

menu :post x y

where menu is the path name of the associated menu, x and y are the root-window coordinates of the upper-right corner of the cascade entry, and group is the name of the menu’s group (as determined in its last post widget command). The lower-level menu is unposted by executing a Tcl command with the form

menu:unpost

where menu is the name of the associated menu.

If a :command option is specified for a cascade entry then it is evaluated as a Tcl command each time the associated menu is posted (the evaluation occurs before the menu is posted).

A Menu Widget’s Arguments

The menu command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form:

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command.

Many of the widget commands for a menu take as one argument an indicator of which entry of the menu to operate on. These indicators are called indexes and may be specified in any of the following forms:

number

Specifies the entry numerically, where 0 corresponds to the top-most entry of the menu, 1 to the entry below it, and so on.

active

Indicates the entry that is currently active. If no entry is active then this form is equivalent to none. This form may not be abbreviated.

last

Indicates the bottommost entry in the menu. If there are no entries in the menu then this form is equivalent to none. This form may not be abbreviated.

none

Indicates “no entry at all”; this is used most commonly with the activate option to deactivate all the entries in the menu. In most cases the specification of none causes nothing to happen in the widget command. This form may not be abbreviated.

@number

In this form, number is treated as a y-coordinate in the menu’s window; the entry spanning that y-coordinate is used. For example, “@0” indicates the top-most entry in the window. If number is outside the range of the window then this form is equivalent to none.

pattern

If the index doesn’t satisfy one of the above forms then this form is used. Pattern is pattern-matched against the label of each entry in the menu, in order from the top down, until a matching entry is found. The rules of Tcl_StringMatch are used.

The following widget commands are possible for menu widgets:

pathName :activate index

Change the state of the entry indicated by index to active and redisplay it using its active colors. Any previously-active entry is deactivated. If index is specified as none, or if the specified entry is disabled, then the menu ends up with no active entry. Returns an empty string.

pathName :add type ?option value option value ...?

Add a new entry to the bottom of the menu. The new entry’s type is given by type and must be one of cascade, checkbutton, command, radiobutton, or separator, or a unique abbreviation of one of the above. If additional arguments are present, they specify any of the following options:

:activebackground value

Specifies a background color to use for displaying this entry when it is active. If this option is specified as an empty string (the default), then the activeBackground option for the overall menu is used. This option is not available for separator entries.

:accelerator value

Specifies a string to display at the right side of the menu entry. Normally describes an accelerator keystroke sequence that may be typed to invoke the same function as the menu entry. This option is not available for separator entries.

:background value

Specifies a background color to use for displaying this entry when it is in the normal state (neither active nor disabled). If this option is specified as an empty string (the default), then the background option for the overall menu is used. This option is not available for separator entries.

:bitmap value

Specifies a bitmap to display in the menu instead of a textual label, in any of the forms accepted by Tk_GetBitmap. This option overrides the :label option but may be reset to an empty string to enable a textual label to be displayed. This option is not available for separator entries.

:command value

For command, checkbutton, and radiobutton entries, specifies a Tcl command to execute when the menu entry is invoked. For cascade entries, specifies a Tcl command to execute when the entry is activated (i.e. just before its submenu is posted). Not available for separator entries.

:font value

Specifies the font to use when drawing the label or accelerator string in this entry. If this option is specified as an empty string (the default) then the font option for the overall menu is used. This option is not available for separator entries.

:label value

Specifies a string to display as an identifying label in the menu entry. Not available for separator entries.

:menu value

Available only for cascade entries. Specifies the path name of the menu associated with this entry.

:offvalue value

Available only for check-button entries. Specifies the value to store in the entry’s associated variable when the entry is deselected.

:onvalue value

Available only for check-button entries. Specifies the value to store in the entry’s associated variable when the entry is selected.

:state value

Specifies one of three states for the entry: normal, active, or disabled. In normal state the entry is displayed using the foreground option for the menu and the background option from the entry or the menu. The active state is typically used when the pointer is over the entry. In active state the entry is displayed using the activeForeground option for the menu along with the activebackground option from the entry. Disabled state means that the entry is insensitive: it doesn’t activate and doesn’t respond to mouse button presses or releases. In this state the entry is displayed according to the disabledForeground option for the menu and the background option from the entry. This option is not available for separator entries.

:underline value

Specifies the integer index of a character to underline in the entry. This option is typically used to indicate keyboard traversal characters. 0 corresponds to the first character of the text displayed in the entry, 1 to the next character, and so on. If a bitmap is displayed in the entry then this option is ignored. This option is not available for separator entries.

:value value

Available only for radio-button entries. Specifies the value to store in the entry’s associated variable when the entry is selected.

:variable value

Available only for check-button and radio-button entries. Specifies the name of a global value to set when the entry is selected. For check-button entries the variable is also set when the entry is deselected. For radio-button entries, changing the variable causes the currently-selected entry to deselect itself.

The add widget command returns an empty string.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the menu command.

pathName :delete index1 ?index2?

Delete all of the menu entries between index1 and index2 inclusive. If index2 is omitted then it defaults to index1. Returns an empty string.

pathName :disable index

Change the state of the entry given by index to disabled and redisplay the entry using its disabled colors. Returns an empty string. This command is obsolete and will eventually be removed; use “pathName :entryconfigure index :state disabled” instead.

pathName :enable index

Change the state of the entry given by index to normal and redisplay the entry using its normal colors. Returns an empty string. This command is obsolete and will eventually be removed; use “pathName :entryconfigure index :state normal” instead.

pathName :entryconfigure index ?options?

This command is similar to the configure command, except that it applies to the options for an individual entry, whereas configure applies to the options for the menu as a whole. Options may have any of the values accepted by the add widget command. If options are specified, options are modified as indicated in the command and the command returns an empty string. If no options are specified, returns a list describing the current options for entry index (see Tk_ConfigureInfo for information on the format of this list).

pathName :index index

Returns the numerical index corresponding to index, or none if index was specified as none.

pathName :invoke index

Invoke the action of the menu entry. See the sections on the individual entries above for details on what happens. If the menu entry is disabled then nothing happens. If the entry has a command associated with it then the result of that command is returned as the result of the invoke widget command. Otherwise the result is an empty string. Note: invoking a menu entry does not automatically unpost the menu. Normally the associated menubutton will take care of unposting the menu.

pathName :post x y

Arrange for the menu to be displayed on the screen at the root-window coordinates given by x and y. These coordinates are adjusted if necessary to guarantee that the entire menu is visible on the screen. This command normally returns an empty string. If the :postcommand option has been specified, then its value is executed as a Tcl script before posting the menu and the result of that script is returned as the result of the post widget command. If an error returns while executing the command, then the error is returned without posting the menu.

pathName :unpost

Unmap the window so that it is no longer displayed. If a lower-level cascaded menu is posted, unpost that menu. Returns an empty string.

pathName :yposition index

Returns a decimal string giving the y-coordinate within the menu window of the topmost pixel in the entry specified by index.

Default Bindings

Tk automatically creates class bindings for menus that give them the following default behavior:

  • [1] When the mouse cursor enters a menu, the entry underneath the mouse cursor is activated; as the mouse moves around the menu, the active entry changes to track the mouse.
  • [2] When button 1 is released over a menu, the active entry (if any) is invoked.
  • [3] A menu can be repositioned on the screen by dragging it with mouse button 2.
  • [4] A number of other bindings are created to support keyboard menu traversal. See the manual entry for tk_bindForTraversal for details on these bindings.

Disabled menu entries are non-responsive: they don’t activate and ignore mouse button presses and releases.

The behavior of menus can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Bugs

At present it isn’t possible to use the option database to specify values for the options to individual entries.

Keywords

menu, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/message.html0000644000175000017500000002327014360276512015425 0ustar cammcamm message (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.11 message

message \- Create and manipulate message widgets

Synopsis

message pathName ?options?

Standard Options

anchor            cursor          padX        text              
background        font            padY        textVariable      
borderWidth       foreground      relief      width

See options, for more information.

Arguments for Message

:aspect

Name="aspect" Class="Aspect"


Specifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. Used to choose line length for text if width option isn’t specified. Defaults to 150.

:justify

Name="justify" Class="Justify"


Specifies how to justify lines of text. Must be one of left, center, or right. Defaults to left. This option works together with the anchor, aspect, padX, padY, and width options to provide a variety of arrangements of the text within the window. The aspect and width options determine the amount of screen space needed to display the text. The anchor, padX, and padY options determine where this rectangular area is displayed within the widget’s window, and the justify option determines how each line is displayed within that rectangular region. For example, suppose anchor is e and justify is left, and that the message window is much larger than needed for the text. The the text will displayed so that the left edges of all the lines line up and the right edge of the longest line is padX from the right side of the window; the entire text block will be centered in the vertical span of the window.

:width

Name="width" Class="Width"


Specifies the length of lines in the window. The value may have any of the forms acceptable to Tk_GetPixels. If this option has a value greater than zero then the aspect option is ignored and the width option determines the line length. If this option has a value less than or equal to zero, then the aspect option determines the line length.

Description

The message command creates a new window (given by the pathName argument) and makes it into a message widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the message such as its colors, font, text, and initial relief. The message command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A message is a widget that displays a textual string. A message widget has three special features. First, it breaks up its string into lines in order to produce a given aspect ratio for the window. The line breaks are chosen at word boundaries wherever possible (if not even a single word would fit on a line, then the word will be split across lines). Newline characters in the string will force line breaks; they can be used, for example, to leave blank lines in the display.

The second feature of a message widget is justification. The text may be displayed left-justified (each line starts at the left side of the window), centered on a line-by-line basis, or right-justified (each line ends at the right side of the window).

The third feature of a message widget is that it handles control characters and non-printing characters specially. Tab characters are replaced with enough blank space to line up on the next 8-character boundary. Newlines cause line breaks. Other control characters (ASCII code less than 0x20) and characters not defined in the font are displayed as a four-character sequence \fB\exhh where hh is the two-digit hexadecimal number corresponding to the character. In the unusual case where the font doesn’t contain all of the characters in “0123456789abcdef\ex” then control characters and undefined characters are not displayed at all.

A Message Widget’s Arguments

The message command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for message widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the message command.

"Default Bindings"

When a new message is created, it has no default event bindings: messages are intended for output purposes only.

Bugs

Tabs don’t work very well with text that is centered or right-justified. The most common result is that the line is justified wrong.

Keywords

message, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/menubutton.html0000644000175000017500000002712314360276512016202 0ustar cammcamm menubutton (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.8 menubutton

menubutton \- Create and manipulate menubutton widgets

Synopsis

menubutton pathName ?options?

Standard Options

activeBackground  bitmap              font        relief        
activeForeground  borderWidth         foreground  text          
anchor            cursor              padX        textVariable  
background        disabledForeground  padY        underline

See options, for more information.

Arguments for Menubutton

:height

Name="height" Class="Height"


Specifies a desired height for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn’t specified, the menu button’s desired height is computed from the size of the bitmap or text being displayed in it.

:menu

Name="menu" Class="MenuName"


Specifies the path name of the menu associated with this menubutton. The menu must be a descendant of the menubutton in order for normal pull-down operation to work via the mouse.

:state

Name="state" Class="State"


Specifies one of three states for the menu button: normal, active, or disabled. In normal state the menu button is displayed using the foreground and background options. The active state is typically used when the pointer is over the menu button. In active state the menu button is displayed using the activeForeground and activeBackground options. Disabled state means that the menu button is insensitive: it doesn’t activate and doesn’t respond to mouse button presses. In this state the disabledForeground and background options determine how the button is displayed.

:width

Name="width" Class="Width"


Specifies a desired width for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn’t specified, the menu button’s desired width is computed from the size of the bitmap or text being displayed in it.

Introduction

The menubutton command creates a new window (given by the pathName argument) and makes it into a menubutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menubutton such as its colors, font, text, and initial relief. The menubutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A menubutton is a widget that displays a textual string or bitmap and is associated with a menu widget. In normal usage, pressing mouse button 1 over the menubutton causes the associated menu to be posted just underneath the menubutton. If the mouse is moved over the menu before releasing the mouse button, the button release causes the underlying menu entry to be invoked. When the button is released, the menu is unposted.

Menubuttons are typically organized into groups called menu bars that allow scanning: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. The tk-menu-bar procedure is used to set up menu bars for scanning; see that procedure for more details.

A Menubutton Widget’s Arguments

The menubutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for menubutton widgets:

pathName :activate

Change the menu button’s state to active and redisplay the menu button using its active foreground and background colors instead of normal colors. The command returns an empty string. This command is ignored if the menu button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state active” instead.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the menubutton command.

pathName :deactivate

Change the menu button’s state to normal and redisplay the menu button using its normal foreground and background colors. The command returns an empty string. This command is ignored if the menu button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state normal” instead.

"Default Bindings"

Tk automatically creates class bindings for menu buttons that give them the following default behavior:

  • [1] A menu button activates whenever the mouse passes over it and deactivates whenever the mouse leaves it.
  • [2] A menu button’s relief is changed to raised whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released or the mouse is dragged into another menu button in the same menu bar.
  • [3] When mouse button 1 is pressed over a menu button, or when the mouse is dragged into a menu button with mouse button 1 pressed, the associated menu is posted; the mouse can be dragged across the menu and released over an entry in the menu to invoke that entry. The menu is unposted when button 1 is released outside either the menu or the menu button. The menu is also unposted when the mouse is dragged into another menu button in the same menu bar.
  • [4] If mouse button 1 is pressed and released within the menu button, then the menu stays posted and keyboard traversal is possible as described in the manual entry for tk-menu-bar.
  • [5] Menubuttons may also be posted by typing characters on the keyboard. See the manual entry for tk-menu-bar for full details on keyboard menu traversal.
  • [6] If mouse button 2 is pressed over a menu button then the associated menu is posted and also torn off: it can then be dragged around on the screen with button 2 and the menu will not automatically unpost when entries in it are invoked. To close a torn off menu, click mouse button 1 over the associated menu button.

If the menu button’s state is disabled then none of the above actions occur: the menu button is completely non-responsive.

The behavior of menu buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Keywords

menubutton, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/grab.html0000644000175000017500000001726614360276512014724 0ustar cammcamm grab (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.7 grab

grab \- Confine pointer and keyboard events to a window sub-tree

Synopsis


grab ?:global? window
grab option ?arg arg ...?

Description

This command implements simple pointer and keyboard grabs for Tk. Tk’s grabs are different than the grabs described in the Xlib documentation. When a grab is set for a particular window, Tk restricts all pointer events to the grab window and its descendants in Tk’s window hierarchy. Whenever the pointer is within the grab window’s subtree, the pointer will behave exactly the same as if there had been no grab at all and all events will be reported in the normal fashion. When the pointer is outside window’s tree, button presses and releases and mouse motion events are reported to window, and window entry and window exit events are ignored. The grab subtree “owns” the pointer: windows outside the grab subtree will be visible on the screen but they will be insensitive until the grab is released. The tree of windows underneath the grab window can include top-level windows, in which case all of those top-level windows and their descendants will continue to receive mouse events during the grab.

Two forms of grabs are possible: local and global. A local grab affects only the grabbing application: events will be reported to other applications as if the grab had never occurred. Grabs are local by default. A global grab locks out all applications on the screen, so that only the given subtree of the grabbing application will be sensitive to pointer events (mouse button presses, mouse button releases, pointer motions, window entries, and window exits). During global grabs the window manager will not receive pointer events either.

During local grabs, keyboard events (key presses and key releases) are delivered as usual: the window manager controls which application receives keyboard events, and if they are sent to any window in the grabbing application then they are redirected to the focus window. During a global grab Tk grabs the keyboard so that all keyboard events are always sent to the grabbing application. The focus command is still used to determine which window in the application receives the keyboard events. The keyboard grab is released when the grab is released.

Grabs apply to particular displays. If an application has windows on multiple displays then it can establish a separate grab on each display. The grab on a particular display affects only the windows on that display. It is possible for different applications on a single display to have simultaneous local grabs, but only one application can have a global grab on a given display at once.

The grab command can take any of the following forms:

grab ?:global? window

Same as grab :set, described below.

grab :current ?window?

If window is specified, returns the name of the current grab window in this application for window’s display, or an empty string if there is no such window. If window is omitted, the command returns a list whose elements are all of the windows grabbed by this application for all displays, or an empty string if the application has no grabs.

grab :release window

Releases the grab on window if there is one, otherwise does nothing. Returns an empty string.

grab :set ?:global? window

Sets a grab on window. If :global is specified then the grab is global, otherwise it is local. If a grab was already in effect for this application on window’s display then it is automatically released. If there is already a grab on window and it has the same global/local form as the requested grab, then the command does nothing. Returns an empty string.

grab :status window

Returns none if no grab is currently set on window, local if a local grab is set on window, and global if a global grab is set.

Bugs

It took an incredibly complex and gross implementation to produce the simple grab effect described above. Given the current implementation, it isn’t safe for applications to use the Xlib grab facilities at all except through the Tk grab procedures. If applications try to manipulate X’s grab mechanisms directly, things will probably break.

If a single process is managing several different Tk applications, only one of those applications can have a local grab for a given display at any given time. If the applications are in different processes, this restriction doesn’t exist.

Keywords

grab, keyboard events, pointer events, window

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/button.html0000644000175000017500000002470014360276512015313 0ustar cammcamm button (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.1 button

button \- Create and manipulate button widgets

Synopsis

button pathName ?options?

Standard Options

activeBackground  bitmap              font        relief        
activeForeground  borderWidth         foreground  text          
anchor            cursor              padX        textVariable  
background        disabledForeground  padY

See options, for more information.

Arguments for Button

:command

Name="command" Class="Command"


Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window.

:height

Name="height" Class="Height"


Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn’t specified, the button’s desired height is computed from the size of the bitmap or text being displayed in it.

:state

Name="state" Class="State"


Specifies one of three states for the button: normal, active, or disabled. In normal state the button is displayed using the foreground and background options. The active state is typically used when the pointer is over the button. In active state the button is displayed using the activeForeground and activeBackground options. Disabled state means that the button is insensitive: it doesn’t activate and doesn’t respond to mouse button presses. In this state the disabledForeground and background options determine how the button is displayed.

:width

Name="width" Class="Width"


Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn’t specified, the button’s desired width is computed from the size of the bitmap or text being displayed in it.

Description

The button command creates a new window (given by the pathName argument) and makes it into a button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the button such as its colors, font, text, and initial relief. The button command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A button is a widget that displays a textual string or bitmap. It can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; and it can be made to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the button), then the Tcl command specified in the :command option is invoked.

A Button Widget’s Arguments

The button command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for button widgets:

pathName :activate

Change the button’s state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state active” instead.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the button command.

pathName :deactivate

Change the button’s state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state normal” instead.

pathName :flash

Flash the button. This is accomplished by redisplaying the button several times, alternating between active and normal colors. At the end of the flash the button is left in the same normal/active state as when the command was invoked. This command is ignored if the button’s state is disabled.

pathName :invoke

Invoke the Tcl command associated with the button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the button. This command is ignored if the button’s state is disabled.

"Default Bindings"

Tk automatically creates class bindings for buttons that give them the following default behavior:

  • [1] The button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the button.
  • [2] The button’s relief is changed to sunken whenever mouse button 1 is pressed over the button, and the relief is restored to its original value when button 1 is later released.
  • [3] If mouse button 1 is pressed over the button and later released over the button, the button is invoked. However, if the mouse is not over the button when button 1 is released, then no invocation occurs.

If the button’s state is disabled then none of the above actions occur: the button is completely non-responsive.

The behavior of buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Keywords

button, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/after.html0000644000175000017500000000633714360276512015107 0ustar cammcamm after (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.1 after

after - Execute a command after a time delay

Synopsis

after ms ?arg1 arg2 arg3 ...?

Description

This command is used to delay execution of the program or to execute a command in background after a delay. The ms argument gives a time in milliseconds. If ms is the only argument to after then the command sleeps for ms milliseconds and returns. While the command is sleeping the application does not respond to X events and other events.

If additional arguments are present after ms, then a Tcl command is formed by concatenating all the additional arguments in the same fashion as the concat command. After returns immediately but arranges for the command to be executed ms milliseconds later in background. The command will be executed at global level (outside the context of any Tcl procedure). If an error occurs while executing the delayed command then the tkerror mechanism is used to report the error.

The after command always returns an empty string.

See tkerror.

Keywords

delay, sleep, time

gcl-2.6.14/info/gcl-tk/index.html0000644000175000017500000002361214360276512015110 0ustar cammcamm Top (GCL TK Manual)

Next: , Previous: , Up: (dir)   [Contents]

• General  
• Widgets  
• Control   

 — The Detailed Node Listing —

General
• Introduction  
• Getting Started  
• Common Features of Widgets  
• Return Values  
• Argument Lists  
• Lisp Functions Invoked from Graphics  
• Linked Variables  
• tkconnect   

Widgets
• button  
• listbox  
• scale  
• canvas  
• menu  
• scrollbar  
• checkbutton  
• menubutton  
• text  
• entry  
• message  
• frame  
• label  
• radiobutton  
• toplevel   

Control
• after  
• bind  
• destroy  
• tk-dialog  
• exit  
• focus  
• grab  
• tk-listbox-single-select  
• lower  
• tk-menu-bar  
• option  
• options  
• pack-old  
• pack  
• place  
• raise  
• selection  
• send  
• tk  
• tkerror  
• tkvars  
• tkwait  
• update  
• winfo  
• wm  

Next: , Previous: , Up: (dir)   [Contents]

gcl-2.6.14/info/gcl-tk/radiobutton.html0000644000175000017500000003302514360276512016332 0ustar cammcamm radiobutton (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.14 radiobutton

radiobutton \- Create and manipulate radio-button widgets

Synopsis

radiobutton pathName ?options?

Standard Options

activeBackground  bitmap              font        relief        
activeForeground  borderWidth         foreground  text          
anchor            cursor              padX        textVariable  
background        disabledForeground  padX

See options, for more information.

Arguments for Radiobutton

:command

Name="command" Class="Command"


Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button’s global variable (:variable option) will be updated before the command is invoked.

:height

Name="height" Class="Height"


Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn’t specified, the button’s desired height is computed from the size of the bitmap or text being displayed in it.

:selector

Name="selector" Class="Foreground"


Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button.

:state

Name="state" Class="State"


Specifies one of three states for the radio button: normal, active, or disabled. In normal state the radio button is displayed using the foreground and background options. The active state is typically used when the pointer is over the radio button. In active state the radio button is displayed using the activeForeground and activeBackground options. Disabled state means that the radio button is insensitive: it doesn’t activate and doesn’t respond to mouse button presses. In this state the disabledForeground and background options determine how the radio button is displayed.

:value

Name="value" Class="Value"


Specifies value to store in the button’s associated variable whenever this button is selected. Defaults to the name of the radio button.

:variable

Name="variable" Class="Variable"


Specifies name of global variable to set whenever this button is selected. Changes in this variable also cause the button to select or deselect itself. Defaults to the value selectedButton.

:width

Name="width" Class="Width"


Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn’t specified, the button’s desired width is computed from the size of the bitmap or text being displayed in it.

Description

The radiobutton command creates a new window (given by the pathName argument) and makes it into a radiobutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the radio button such as its colors, font, text, and initial relief. The radiobutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A radio button is a widget that displays a textual string or bitmap and a diamond called a selector. A radio button has all of the behavior of a simple button: it can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button.

In addition, radio buttons can be selected. If a radio button is selected then a special highlight appears in the selector and a Tcl variable associated with the radio button is set to a particular value. If the radio button is not selected then the selector is drawn in a different fashion. Typically, several radio buttons share a single variable and the value of the variable indicates which radio button is to be selected. When a radio button is selected it sets the value of the variable to indicate that fact; each radio button also monitors the value of the variable and automatically selects and deselects itself when the variable’s value changes. By default the variable selectedButton is used; its contents give the name of the button that is selected, or the empty string if no button associated with that variable is selected. The name of the variable for a radio button, plus the variable to be stored into it, may be modified with options on the command line or in the option database. By default a radio button is configured to select itself on button clicks.

A Radiobutton Widget’s Arguments

The radiobutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for radio-button widgets:

pathName :activate

Change the radio button’s state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the radio button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state active” instead.

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the radiobutton command.

pathName :deactivate

Change the radio button’s state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the radio button’s state is disabled. This command is obsolete and will eventually be removed; use “pathName :configure :state normal” instead.

pathName :deselect

Deselect the radio button: redisplay it without a highlight in the selector and set the associated variable to an empty string. If this radio button was not currently selected, then the command has no effect.

pathName :flash

Flash the radio button. This is accomplished by redisplaying the radio button several times, alternating between active and normal colors. At the end of the flash the radio button is left in the same normal/active state as when the command was invoked. This command is ignored if the radio button’s state is disabled.

pathName :invoke

Does just what would have happened if the user invoked the radio button with the mouse: select the button and invoke its associated Tcl command, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the radio button. This command is ignored if the radio button’s state is disabled.

pathName :select

Select the radio button: display it with a highlighted selector and set the associated variable to the value corresponding to this widget.

Bindings

Tk automatically creates class bindings for radio buttons that give them the following default behavior:

  • [1] The radio button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the radio button.
  • [2] The radio button’s relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released.
  • [3] If mouse button 1 is pressed over the radio button and later released over the radio button, the radio button is invoked (i.e. it is selected and the command associated with the button is invoked, if there is one). However, if the mouse is not over the radio button when button 1 is released, then no invocation occurs.

The behavior of radio buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings.

Keywords

radio button, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/scale.html0000644000175000017500000003000114360276512015056 0ustar cammcamm scale (GCL TK Manual)

Next: , Previous: , Up: Widgets   [Contents]

2.3 scale

scale \- Create and manipulate scale widgets

Synopsis

scale pathName ?options?

Standard Options

activeForeground     borderWidth     font           orient     
background           cursor          foreground     relief

See options, for more information.

Arguments for Scale

:command

Name="command" Class="Command"


Specifies the prefix of a Tcl command to invoke whenever the value of the scale is changed interactively. The actual command consists of this option followed by a space and a number. The number indicates the new value of the scale.

:from

Name="from" Class="From"


Specifies the value corresponding to the left or top end of the scale. Must be an integer.

:label

Name="label" Class="Label"


Specifies a string to displayed as a label for the scale. For vertical scales the label is displayed just to the right of the top end of the scale. For horizontal scales the label is displayed just above the left end of the scale.

:length

Name="length" Class="Length"


Specifies the desired long dimension of the scale in screen units, that is in any of the forms acceptable to Tk_GetPixels. For vertical scales this is the scale’s height; for horizontal scales it is the scale’s width.

:showvalue

Name="showValue" Class="ShowValue"


Specifies a boolean value indicating whether or not the current value of the scale is to be displayed.

:sliderforeground

Name="sliderForeground" Class="sliderForeground"


Specifies the color to use for drawing the slider under normal conditions. When the mouse is in the slider window then the slider’s color is determined by the activeForeground option.

:sliderlength

Name="sliderLength" Class="SliderLength"


Specfies the size of the slider, measured in screen units along the slider’s long dimension. The value may be specified in any of the forms acceptable to Tk_GetPixels.

:state

Name="state" Class="State"


Specifies one of two states for the scale: normal or disabled. If the scale is disabled then the value may not be changed and the scale won’t activate when the mouse enters it.

:tickinterval

Name="tickInterval" Class="TickInterval"


Must be an integer value. Determines the spacing between numerical tick-marks displayed below or to the left of the slider. If specified as 0, then no tick-marks will be displayed.

:to

Name="to" Class="To"


Specifies the value corresponding to the right or bottom end of the scale. Must be an integer. This value may be either less than or greater than the from option.

:width

Name="width" Class="Width"


Specifies the desired narrow dimension of the scale in screen units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical scales this is the scale’s width; for horizontal scales this is the scale’s height.

Description

The scale command creates a new window (given by the pathName argument) and makes it into a scale widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scale such as its colors, orientation, and relief. The scale command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName’s parent must exist.

A scale is a widget that displays a rectangular region and a small slider. The rectangular region corresponds to a range of integer values (determined by the from and to options), and the position of the slider selects a particular integer value. The slider’s position (and hence the scale’s value) may be adjusted by clicking or dragging with the mouse as described in the BINDINGS section below. Whenever the scale’s value is changed, a Tcl command is invoked (using the command option) to notify other interested widgets of the change.

Three annotations may be displayed in a scale widget: a label appearing at the top-left of the widget (top-right for vertical scales), a number displayed just underneath the slider (just to the left of the slider for vertical scales), and a collection of numerical tick-marks just underneath the current value (just to the left of the current value for vertical scales). Each of these three annotations may be selectively enabled or disabled using the configuration options.

A Scale’s"Argumentsommand"

The scale command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: 

pathName option ?arg arg ...?

Option and the args determine the exact behavior of the command. The following commands are possible for scale widgets:

pathName :configure ?option? ?value option value ...?

Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the scale command.

pathName :get

Returns a decimal string giving the current value of the scale.

pathName :set value

This command is invoked to change the current value of the scale, and hence the position at which the slider is displayed. Value gives the new value for the scale.

Bindings

When a new scale is created, it is given the following initial behavior by default:

<Enter>

Change the slider display to use activeForeground instead of sliderForeground.

<Leave>

Reset the slider display to use sliderForeground instead of activeForeground.

<ButtonPress-1>

Change the slider display so that the slider appears sunken rather than raised. Move the slider (and adjust the scale’s value) to correspond to the current mouse position.

<Button1-Motion>

Move the slider (and adjust the scale’s value) to correspond to the current mouse position.

<ButtonRelease-1>

Reset the slider display so that the slider appears raised again.

Keywords

scale, widget

Next: , Previous: , Up: Widgets   [Contents]

gcl-2.6.14/info/gcl-tk/selection.html0000644000175000017500000002017514360276512015767 0ustar cammcamm selection (GCL TK Manual)

Next: , Previous: , Up: Control   [Contents]

3.17 selection

selection \- Manipulate the X selection

Synopsis

selection option ?arg arg ...?

Description

This command provides a Tcl interface to the X selection mechanism and implements the full selection functionality described in the X Inter-Client Communication Conventions Manual (ICCCM), except that it supports only the primary selection.

The first argument to selection determines the format of the rest of the arguments and the behavior of the command. The following forms are currently supported:

selection :clear window

If there is a selection anywhere on window’s display, clear it so that no window owns the selection anymore. Returns an empty string.

selection :get ?type?

Retrieves the value of the primary selection and returns it as a result. Type specifies the form in which the selection is to be returned (the desired “target” for conversion, in ICCCM terminology), and should be an atom name such as STRING or FILE_NAME; see the Inter-Client Communication Conventions Manual for complete details. Type defaults to STRING. The selection :owner may choose to return the selection in any of several different representation formats, such as STRING, ATOM, INTEGER, etc. (this format is different than the selection type; see the ICCCM for all the confusing details). If the selection is returned in a non-string format, such as INTEGER or ATOM, the selection command converts it to string format as a collection of fields separated by spaces: atoms are converted to their textual names, and anything else is converted to hexadecimal integers.

selection :handle window command ?type? ?format?

Creates a handler for selection requests, such that command will be executed whenever the primary selection is owned by window and someone attempts to retrieve it in the form given by type (e.g. type is specified in the selection :get command). Type defaults to STRING. If command is an empty string then any existing handler for window and type is removed.

When the selection is requested and window is the selection :owner and type is the requested type, command will be executed as a Tcl command with two additional numbers appended to it (with space separators). The two additional numbers are offset and maxBytes: offset specifies a starting character position in the selection and maxBytes gives the maximum number of bytes to retrieve. The command should return a value consisting of at most maxBytes of the selection, starting at position offset. For very large selections (larger than maxBytes) the selection will be retrieved using several invocations of command with increasing offset values. If command returns a string whose length is less than maxBytes, the return value is assumed to include all of the remainder of the selection; if the length of command’s result is equal to maxBytes then command will be invoked again, until it eventually returns a result shorter than maxBytes. The value of maxBytes will always be relatively large (thousands of bytes).

If command returns an error then the selection retrieval is rejected just as if the selection didn’t exist at all.

The format argument specifies the representation that should be used to transmit the selection to the requester (the second column of Table 2 of the ICCCM), and defaults to STRING. If format is STRING, the selection is transmitted as 8-bit ASCII characters (i.e. just in the form returned by command). If format is ATOM, then the return value from command is divided into fields separated by white space; each field is converted to its atom value, and the 32-bit atom value is transmitted instead of the atom name. For any other format, the return value from command is divided into fields separated by white space and each field is converted to a 32-bit integer; an array of integers is transmitted to the selection requester.

The format argument is needed only for compatibility with selection requesters that don’t use Tk. If the Tk toolkit is being used to retrieve the selection then the value is converted back to a string at the requesting end, so format is irrelevant. .RE

selection :own ?window? ?command?

If window is specified, then it becomes the new selection :owner and the command returns an empty string as result. The existing owner, if any, is notified that it has lost the selection. If command is specified, it is a Tcl script to execute when some other window claims ownership of the selection away from window. If neither window nor command is specified then the command returns the path name of the window in this application that owns the selection, or an empty string if no window in this application owns the selection.

Keywords

clear, format, handler, ICCCM, own, selection, target, type

Next: , Previous: , Up: Control   [Contents]

gcl-2.6.14/info/gcl-tk/Widgets.html0000644000175000017500000001016214360276512015403 0ustar cammcamm Widgets (GCL TK Manual)

Next: , Previous: , Up: Top   [Contents]

2 Widgets

• button  
• listbox  
• scale  
• canvas  
• menu  
• scrollbar  
• checkbutton  
• menubutton  
• text  
• entry  
• message  
• frame  
• label  
• radiobutton  
• toplevel  
gcl-2.6.14/info/chap-10.texi0000644000175000017500000011757214360276512013767 0ustar cammcamm @node Symbols, Packages, Conditions, Top @chapter Symbols @menu * Symbol Concepts:: * Symbols Dictionary:: @end menu @node Symbol Concepts, Symbols Dictionary, Symbols, Symbols @section Symbol Concepts @c including concept-symbols Figure 10--1 lists some @i{defined names} that are applicable to the @i{property lists} of @i{symbols}. @format @group @noindent @w{ get remprop symbol-plist } @noindent @w{ Figure 10--1: Property list defined names} @end group @end format Figure 10--2 lists some @i{defined names} that are applicable to the creation of and inquiry about @i{symbols}. @format @group @noindent @w{ copy-symbol keywordp symbol-package } @w{ gensym make-symbol symbol-value } @w{ gentemp symbol-name } @noindent @w{ Figure 10--2: Symbol creation and inquiry defined names} @end group @end format @c end of including concept-symbols @node Symbols Dictionary, , Symbol Concepts, Symbols @section Symbols Dictionary @c including dict-symbols @menu * symbol:: * keyword:: * symbolp:: * keywordp:: * make-symbol:: * copy-symbol:: * gensym:: * *gensym-counter*:: * gentemp:: * symbol-function:: * symbol-name:: * symbol-package:: * symbol-plist:: * symbol-value:: * get:: * remprop:: * boundp:: * makunbound:: * set:: * unbound-variable:: @end menu @node symbol, keyword, Symbols Dictionary, Symbols Dictionary @subsection symbol [System Class] @subsubheading Class Precedence List:: @b{symbol}, @b{t} @subsubheading Description:: @i{Symbols} are used for their @i{object} identity to name various entities in @r{Common Lisp}, including (but not limited to) linguistic entities such as @i{variables} and @i{functions}. @i{Symbols} can be collected together into @i{packages}. A @i{symbol} is said to be @i{interned} in a @i{package} if it is @i{accessible} in that @i{package}; the same @i{symbol} can be @i{interned} in more than one @i{package}. If a @i{symbol} is not @i{interned} in any @i{package}, it is called @i{uninterned}. An @i{interned} @i{symbol} is uniquely identifiable by its @i{name} from any @i{package} in which it is @i{accessible}. @i{Symbols} have the following attributes. For historically reasons, these are sometimes referred to as @i{cells}, although the actual internal representation of @i{symbols} and their attributes is @i{implementation-dependent}. @table @asis @item @b{Name} The @i{name} of a @i{symbol} is a @i{string} used to identify the @i{symbol}. Every @i{symbol} has a @i{name}, and the consequences are undefined if that @i{name} is altered. The @i{name} is used as part of the external, printed representation of the @i{symbol}; see @ref{Character Syntax}. The @i{function} @b{symbol-name} returns the @i{name} of a given @i{symbol}. A @i{symbol} may have any @i{character} in its @i{name}. @item @b{Package} The @i{object} in this @i{cell} is called the @i{home package} of the @i{symbol}. If the @i{home package} is @b{nil}, the @i{symbol} is sometimes said to have no @i{home package}. When a @i{symbol} is first created, it has no @i{home package}. When it is first @i{interned}, the @i{package} in which it is initially @i{interned} becomes its @i{home package}. The @i{home package} of a @i{symbol} can be @i{accessed} by using the @i{function} @b{symbol-package}. If a @i{symbol} is @i{uninterned} from the @i{package} which is its @i{home package}, its @i{home package} is set to @b{nil}. Depending on whether there is another @i{package} in which the @i{symbol} is @i{interned}, the symbol might or might not really be an @i{uninterned} @i{symbol}. A @i{symbol} with no @i{home package} is therefore called @i{apparently uninterned}. The consequences are undefined if an attempt is made to alter the @i{home package} of a @i{symbol} external in the @t{COMMON-LISP} @i{package} or the @t{KEYWORD} @i{package}. @item @b{Property list} The @i{property list} of a @i{symbol} provides a mechanism for associating named attributes with that @i{symbol}. The operations for adding and removing entries are @i{destructive} to the @i{property list}. @r{Common Lisp} provides @i{operators} both for direct manipulation of @i{property list} @i{objects} (@i{e.g.}, see @b{getf}, @b{remf}, and @b{symbol-plist}) and for implicit manipulation of a @i{symbol}'s @i{property list} by reference to the @i{symbol} (@i{e.g.}, see @b{get} and @b{remprop}). The @i{property list} associated with a @i{fresh} @i{symbol} is initially @i{null}. @item @b{Value} If a symbol has a value attribute, it is said to be @i{bound}, and that fact can be detected by the @i{function} @b{boundp}. The @i{object} contained in the @i{value cell} of a @i{bound} @i{symbol} is the @i{value} of the @i{global variable} named by that @i{symbol}, and can be @i{accessed} by the @i{function} @b{symbol-value}. A @i{symbol} can be made to be @i{unbound} by the @i{function} @b{makunbound}. The consequences are undefined if an attempt is made to change the @i{value} of a @i{symbol} that names a @i{constant variable}, or to make such a @i{symbol} be @i{unbound}. @item @b{Function} If a symbol has a function attribute, it is said to be @i{fbound}, and that fact can be detected by the @i{function} @b{fboundp}. If the @i{symbol} is the @i{name} of a @i{function} in the @i{global environment}, the @i{function cell} contains the @i{function}, and can be @i{accessed} by the @i{function} @b{symbol-function}. If the @i{symbol} is the @i{name} of either a @i{macro} in the @i{global environment} (see @b{macro-function}) or a @i{special operator} (see @b{special-operator-p}), the @i{symbol} is @i{fbound}, and can be @i{accessed} by the @i{function} @b{symbol-function}, but the @i{object} which the @i{function cell} contains is of @i{implementation-dependent} @i{type} and purpose. A @i{symbol} can be made to be @i{funbound} by the @i{function} @b{fmakunbound}. The consequences are undefined if an attempt is made to change the @i{functional value} of a @i{symbol} that names a @i{special form}. @end table Operations on a @i{symbol}'s @i{value cell} and @i{function cell} are sometimes described in terms of their effect on the @i{symbol} itself, but the user should keep in mind that there is an intimate relationship between the contents of those @i{cells} and the @i{global variable} or global @i{function} definition, respectively. @i{Symbols} are used as identifiers for @i{lexical variables} and lexical @i{function} definitions, but in that role, only their @i{object} identity is significant. @r{Common Lisp} provides no operation on a @i{symbol} that can have any effect on a @i{lexical variable} or on a lexical @i{function} definition. @subsubheading See Also:: @ref{Symbols as Tokens}, @ref{Potential Numbers as Tokens}, @ref{Printing Symbols} @node keyword, symbolp, symbol, Symbols Dictionary @subsection keyword [Type] @subsubheading Supertypes:: @b{keyword}, @b{symbol}, @b{t} @subsubheading Description:: The @i{type} @b{keyword} includes all @i{symbols} @i{interned} the @t{KEYWORD} @i{package}. @i{Interning} a @i{symbol} in the @t{KEYWORD} @i{package} has three automatic effects: @table @asis @item 1. It causes the @i{symbol} to become @i{bound} to itself. @item 2. It causes the @i{symbol} to become an @i{external symbol} of the @t{KEYWORD} @i{package}. @item 3. It causes the @i{symbol} to become a @i{constant variable}. @end table @subsubheading See Also:: @ref{keywordp} @node symbolp, keywordp, keyword, Symbols Dictionary @subsection symbolp [Function] @code{symbolp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{symbol}; otherwise, returns @i{false}. @subsubheading Examples:: @example (symbolp 'elephant) @result{} @i{true} (symbolp 12) @result{} @i{false} (symbolp nil) @result{} @i{true} (symbolp '()) @result{} @i{true} (symbolp :test) @result{} @i{true} (symbolp "hello") @result{} @i{false} @end example @subsubheading See Also:: @ref{keywordp} , @b{symbol}, @ref{typep} @subsubheading Notes:: @example (symbolp @i{object}) @equiv{} (typep @i{object} 'symbol) @end example @node keywordp, make-symbol, symbolp, Symbols Dictionary @subsection keywordp [Function] @code{keywordp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is a @i{keyword}_1; otherwise, returns @i{false}. @subsubheading Examples:: @example (keywordp 'elephant) @result{} @i{false} (keywordp 12) @result{} @i{false} (keywordp :test) @result{} @i{true} (keywordp ':test) @result{} @i{true} (keywordp nil) @result{} @i{false} (keywordp :nil) @result{} @i{true} (keywordp '(:test)) @result{} @i{false} (keywordp "hello") @result{} @i{false} (keywordp ":hello") @result{} @i{false} (keywordp '&optional) @result{} @i{false} @end example @subsubheading See Also:: @ref{constantp} , @ref{keyword} , @ref{symbolp} , @ref{symbol-package} @node make-symbol, copy-symbol, keywordp, Symbols Dictionary @subsection make-symbol [Function] @code{make-symbol} @i{name} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @i{name}---a @i{string}. @i{new-symbol}---a @i{fresh}, @i{uninterned} @i{symbol}. @subsubheading Description:: @b{make-symbol} creates and returns a @i{fresh}, @i{uninterned} @i{symbol} whose @i{name} is the given @i{name}. The @i{new-symbol} is neither @i{bound} nor @i{fbound} and has a @i{null} @i{property list}. It is @i{implementation-dependent} whether the @i{string} that becomes the @i{new-symbol}'s @i{name} is the given @i{name} or a copy of it. Once a @i{string} has been given as the @i{name} @i{argument} to @i{make-symbol}, the consequences are undefined if a subsequent attempt is made to alter that @i{string}. @subsubheading Examples:: @example (setq temp-string "temp") @result{} "temp" (setq temp-symbol (make-symbol temp-string)) @result{} #:|temp| (symbol-name temp-symbol) @result{} "temp" (eq (symbol-name temp-symbol) temp-string) @result{} @i{implementation-dependent} (find-symbol "temp") @result{} NIL, NIL (eq (make-symbol temp-string) (make-symbol temp-string)) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{name} is not a @i{string}. @subsubheading See Also:: @ref{copy-symbol} @subsubheading Notes:: No attempt is made by @b{make-symbol} to convert the case of the @i{name} to uppercase. The only case conversion which ever occurs for @i{symbols} is done by the @i{Lisp reader}. The program interface to @i{symbol} creation retains case, and the program interface to interning symbols is case-sensitive. @node copy-symbol, gensym, make-symbol, Symbols Dictionary @subsection copy-symbol [Function] @code{copy-symbol} @i{symbol @r{&optional} copy-properties} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{copy-properties}---a @i{generalized boolean}. The default is @i{false}. @i{new-symbol}---a @i{fresh}, @i{uninterned} @i{symbol}. @subsubheading Description:: @b{copy-symbol} returns a @i{fresh}, @i{uninterned} @i{symbol}, the @i{name} of which is @b{string=} to and possibly the @i{same} as the @i{name} of the given @i{symbol}. If @i{copy-properties} is @i{false}, the @i{new-symbol} is neither @i{bound} nor @i{fbound} and has a @i{null} @i{property list}. If @i{copy-properties} is @i{true}, then the initial @i{value} of @i{new-symbol} is the @i{value} of @i{symbol}, the initial @i{function} definition of @i{new-symbol} is the @i{functional value} of @i{symbol}, and the @i{property list} of @i{new-symbol} is a @i{copy}_2 of the @i{property list} of @i{symbol}. @subsubheading Examples:: @example (setq fred 'fred-smith) @result{} FRED-SMITH (setf (symbol-value fred) 3) @result{} 3 (setq fred-clone-1a (copy-symbol fred nil)) @result{} #:FRED-SMITH (setq fred-clone-1b (copy-symbol fred nil)) @result{} #:FRED-SMITH (setq fred-clone-2a (copy-symbol fred t)) @result{} #:FRED-SMITH (setq fred-clone-2b (copy-symbol fred t)) @result{} #:FRED-SMITH (eq fred fred-clone-1a) @result{} @i{false} (eq fred-clone-1a fred-clone-1b) @result{} @i{false} (eq fred-clone-2a fred-clone-2b) @result{} @i{false} (eq fred-clone-1a fred-clone-2a) @result{} @i{false} (symbol-value fred) @result{} 3 (boundp fred-clone-1a) @result{} @i{false} (symbol-value fred-clone-2a) @result{} 3 (setf (symbol-value fred-clone-2a) 4) @result{} 4 (symbol-value fred) @result{} 3 (symbol-value fred-clone-2a) @result{} 4 (symbol-value fred-clone-2b) @result{} 3 (boundp fred-clone-1a) @result{} @i{false} (setf (symbol-function fred) #'(lambda (x) x)) @result{} # (fboundp fred) @result{} @i{true} (fboundp fred-clone-1a) @result{} @i{false} (fboundp fred-clone-2a) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{make-symbol} @subsubheading Notes:: Implementors are encouraged not to copy the @i{string} which is the @i{symbol}'s @i{name} unnecessarily. Unless there is a good reason to do so, the normal implementation strategy is for the @i{new-symbol}'s @i{name} to be @i{identical} to the given @i{symbol}'s @i{name}. @node gensym, *gensym-counter*, copy-symbol, Symbols Dictionary @subsection gensym [Function] @code{gensym} @i{@r{&optional} x} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @i{x}---a @i{string} or a non-negative @i{integer}. Complicated defaulting behavior; see below. @i{new-symbol}---a @i{fresh}, @i{uninterned} @i{symbol}. @subsubheading Description:: Creates and returns a @i{fresh}, @i{uninterned} @i{symbol}, as if by calling @b{make-symbol}. (The only difference between @b{gensym} and @b{make-symbol} is in how the @i{new-symbol}'s @i{name} is determined.) The @i{name} of the @i{new-symbol} is the concatenation of a prefix, which defaults to @t{"G"}, and a suffix, which is the decimal representation of a number that defaults to the @i{value} of @b{*gensym-counter*}. If @i{x} is supplied, and is a @i{string}, then that @i{string} is used as a prefix instead of @t{"G"} for this call to @b{gensym} only. If @i{x} is supplied, and is an @i{integer}, then that @i{integer}, instead of the @i{value} of @b{*gensym-counter*}, is used as the suffix for this call to @b{gensym} only. If and only if no explicit suffix is supplied, @b{*gensym-counter*} is incremented after it is used. @subsubheading Examples:: @example (setq sym1 (gensym)) @result{} #:G3142 (symbol-package sym1) @result{} NIL (setq sym2 (gensym 100)) @result{} #:G100 (setq sym3 (gensym 100)) @result{} #:G100 (eq sym2 sym3) @result{} @i{false} (find-symbol "G100") @result{} NIL, NIL (gensym "T") @result{} #:T3143 (gensym) @result{} #:G3144 @end example @subsubheading Side Effects:: Might increment @b{*gensym-counter*}. @subsubheading Affected By:: @b{*gensym-counter*} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{x} is not a @i{string} or a non-negative @i{integer}. @subsubheading See Also:: @ref{gentemp} , @b{*gensym-counter*} @subsubheading Notes:: The ability to pass a numeric argument to @b{gensym} has been deprecated; explicitly @i{binding} @b{*gensym-counter*} is now stylistically preferred. (The somewhat baroque conventions for the optional argument are historical in nature, and supported primarily for compatibility with older dialects of @r{Lisp}. In modern code, it is recommended that the only kind of argument used be a string prefix. In general, though, to obtain more flexible control of the @i{new-symbol}'s @i{name}, consider using @b{make-symbol} instead.) @node *gensym-counter*, gentemp, gensym, Symbols Dictionary @subsection *gensym-counter* [Variable] @subsubheading Value Type:: a non-negative @i{integer}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: A number which will be used in constructing the @i{name} of the next @i{symbol} generated by the @i{function} @b{gensym}. @b{*gensym-counter*} can be either @i{assigned} or @i{bound} at any time, but its value must always be a non-negative @i{integer}. @subsubheading Affected By:: @b{gensym}. @subsubheading See Also:: @ref{gensym} @subsubheading Notes:: The ability to pass a numeric argument to @b{gensym} has been deprecated; explicitly @i{binding} @b{*gensym-counter*} is now stylistically preferred. @node gentemp, symbol-function, *gensym-counter*, Symbols Dictionary @subsection gentemp [Function] @code{gentemp} @i{@r{&optional} prefix package} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @i{prefix}---a @i{string}. The default is @t{"T"}. @i{package}---a @i{package designator}. The default is the @i{current package}. @i{new-symbol}---a @i{fresh}, @i{interned} @i{symbol}. @subsubheading Description:: @b{gentemp} creates and returns a @i{fresh} @i{symbol}, @i{interned} in the indicated @i{package}. The @i{symbol} is guaranteed to be one that was not previously @i{accessible} in @i{package}. It is neither @i{bound} nor @i{fbound}, and has a @i{null} @i{property list}. The @i{name} of the @i{new-symbol} is the concatenation of the @i{prefix} and a suffix, which is taken from an internal counter used only by @b{gentemp}. (If a @i{symbol} by that name is already @i{accessible} in @i{package}, the counter is incremented as many times as is necessary to produce a @i{name} that is not already the @i{name} of a @i{symbol} @i{accessible} in @i{package}.) @subsubheading Examples:: @example (gentemp) @result{} T1298 (gentemp "FOO") @result{} FOO1299 (find-symbol "FOO1300") @result{} NIL, NIL (gentemp "FOO") @result{} FOO1300 (find-symbol "FOO1300") @result{} FOO1300, :INTERNAL (intern "FOO1301") @result{} FOO1301, :INTERNAL (gentemp "FOO") @result{} FOO1302 (gentemp) @result{} T1303 @end example @subsubheading Side Effects:: Its internal counter is incremented one or more times. @i{Interns} the @i{new-symbol} in @i{package}. @subsubheading Affected By:: The current state of its internal counter, and the current state of the @i{package}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{prefix} is not a @i{string}. Should signal an error of @i{type} @b{type-error} if @i{package} is not a @i{package designator}. @subsubheading See Also:: @ref{gensym} @subsubheading Notes:: The function @b{gentemp} is deprecated. If @i{package} is the @t{KEYWORD} @i{package}, the result is an @i{external symbol} of @i{package}. Otherwise, the result is an @i{internal symbol} of @i{package}. The @b{gentemp} internal counter is independent of @b{*gensym-counter*}, the counter used by @b{gensym}. There is no provision for accessing the @b{gentemp} internal counter. Just because @b{gentemp} creates a @i{symbol} which did not previously exist does not mean that such a @i{symbol} might not be seen in the future (@i{e.g.}, in a data file---perhaps even created by the same program in another session). As such, this symbol is not truly unique in the same sense as a @i{gensym} would be. In particular, programs which do automatic code generation should be careful not to attach global attributes to such generated @i{symbols} (@i{e.g.}, @b{special} @i{declarations}) and then write them into a file because such global attributes might, in a different session, end up applying to other @i{symbols} that were automatically generated on another day for some other purpose. @node symbol-function, symbol-name, gentemp, Symbols Dictionary @subsection symbol-function [Accessor] @code{symbol-function} @i{symbol} @result{} @i{contents} (setf (@code{ symbol-function} @i{symbol}) new-contents)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{contents}--- If the @i{symbol} is globally defined as a @i{macro} or a @i{special operator}, an @i{object} of @i{implementation-dependent} nature and identity is returned. If the @i{symbol} is not globally defined as either a @i{macro} or a @i{special operator}, and if the @i{symbol} is @i{fbound}, a @i{function} @i{object} is returned. @i{new-contents}---a @i{function}. @subsubheading Description:: @i{Accesses} the @i{symbol}'s @i{function cell}. @subsubheading Examples:: @example (symbol-function 'car) @result{} # (symbol-function 'twice) is an error ;because TWICE isn't defined. (defun twice (n) (* n 2)) @result{} TWICE (symbol-function 'twice) @result{} # (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3)) @result{} (6 6 6) (flet ((twice (x) (list x x))) (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3))) @result{} ((3 3) (3 3) 6) (setf (symbol-function 'twice) #'(lambda (x) (list x x))) @result{} # (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3)) @result{} ((3 3) (3 3) (3 3)) (fboundp 'defun) @result{} @i{true} (symbol-function 'defun) @result{} @i{implementation-dependent} (functionp (symbol-function 'defun)) @result{} @i{implementation-dependent} (defun symbol-function-or-nil (symbol) (if (and (fboundp symbol) (not (macro-function symbol)) (not (special-operator-p symbol))) (symbol-function symbol) nil)) @result{} SYMBOL-FUNCTION-OR-NIL (symbol-function-or-nil 'car) @result{} # (symbol-function-or-nil 'defun) @result{} NIL @end example @subsubheading Affected By:: @b{defun} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. Should signal @b{undefined-function} if @i{symbol} is not @i{fbound} and an attempt is made to @i{read} its definition. (No such error is signaled on an attempt to @i{write} its definition.) @subsubheading See Also:: @ref{fboundp} , @ref{fmakunbound} , @ref{macro-function} , @ref{special-operator-p} @subsubheading Notes:: @b{symbol-function} cannot @i{access} the value of a lexical function name produced by @b{flet} or @b{labels}; it can @i{access} only the global function value. @b{setf} may be used with @b{symbol-function} to replace a global function definition when the @i{symbol}'s function definition does not represent a @i{special operator}. @example (symbol-function @i{symbol}) @equiv{} (fdefinition @i{symbol}) @end example However, @b{fdefinition} accepts arguments other than just @i{symbols}. @node symbol-name, symbol-package, symbol-function, Symbols Dictionary @subsection symbol-name [Function] @code{symbol-name} @i{symbol} @result{} @i{name} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{name}---a @i{string}. @subsubheading Description:: @b{symbol-name} returns the @i{name} of @i{symbol}. The consequences are undefined if @i{name} is ever modified. @subsubheading Examples:: @example (symbol-name 'temp) @result{} "TEMP" (symbol-name :start) @result{} "START" (symbol-name (gensym)) @result{} "G1234" ;for example @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @node symbol-package, symbol-plist, symbol-name, Symbols Dictionary @subsection symbol-package [Function] @code{symbol-package} @i{symbol} @result{} @i{contents} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{contents}---a @i{package} @i{object} or @b{nil}. @subsubheading Description:: Returns the @i{home package} of @i{symbol}. @subsubheading Examples:: @example (in-package "CL-USER") @result{} # (symbol-package 'car) @result{} # (symbol-package 'bus) @result{} # (symbol-package :optional) @result{} # ;; Gensyms are uninterned, so have no home package. (symbol-package (gensym)) @result{} NIL (make-package 'pk1) @result{} # (intern "SAMPLE1" "PK1") @result{} PK1::SAMPLE1, NIL (export (find-symbol "SAMPLE1" "PK1") "PK1") @result{} T (make-package 'pk2 :use '(pk1)) @result{} # (find-symbol "SAMPLE1" "PK2") @result{} PK1:SAMPLE1, :INHERITED (symbol-package 'pk1::sample1) @result{} # (symbol-package 'pk2::sample1) @result{} # (symbol-package 'pk1::sample2) @result{} # (symbol-package 'pk2::sample2) @result{} # ;; The next several forms create a scenario in which a symbol ;; is not really uninterned, but is "apparently uninterned", ;; and so SYMBOL-PACKAGE still returns NIL. (setq s3 'pk1::sample3) @result{} PK1::SAMPLE3 (import s3 'pk2) @result{} T (unintern s3 'pk1) @result{} T (symbol-package s3) @result{} NIL (eq s3 'pk2::sample3) @result{} T @end example @subsubheading Affected By:: @b{import}, @b{intern}, @b{unintern} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{intern} @node symbol-plist, symbol-value, symbol-package, Symbols Dictionary @subsection symbol-plist [Accessor] @code{symbol-plist} @i{symbol} @result{} @i{plist} (setf (@code{ symbol-plist} @i{symbol}) new-plist)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{plist}, @i{new-plist}---a @i{property list}. @subsubheading Description:: @i{Accesses} the @i{property list} of @i{symbol}. @subsubheading Examples:: @example (setq sym (gensym)) @result{} #:G9723 (symbol-plist sym) @result{} () (setf (get sym 'prop1) 'val1) @result{} VAL1 (symbol-plist sym) @result{} (PROP1 VAL1) (setf (get sym 'prop2) 'val2) @result{} VAL2 (symbol-plist sym) @result{} (PROP2 VAL2 PROP1 VAL1) (setf (symbol-plist sym) (list 'prop3 'val3)) @result{} (PROP3 VAL3) (symbol-plist sym) @result{} (PROP3 VAL3) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{get} , @ref{remprop} @subsubheading Notes:: The use of @b{setf} should be avoided, since a @i{symbol}'s @i{property list} is a global resource that can contain information established and depended upon by unrelated programs in the same @i{Lisp image}. @node symbol-value, get, symbol-plist, Symbols Dictionary @subsection symbol-value [Accessor] @code{symbol-value} @i{symbol} @result{} @i{value} (setf (@code{ symbol-value} @i{symbol}) new-value)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol} that must have a @i{value}. @i{value}, @i{new-value}---an @i{object}. @subsubheading Description:: @i{Accesses} the @i{symbol}'s @i{value cell}. @subsubheading Examples:: @example (setf (symbol-value 'a) 1) @result{} 1 (symbol-value 'a) @result{} 1 ;; SYMBOL-VALUE cannot see lexical variables. (let ((a 2)) (symbol-value 'a)) @result{} 1 (let ((a 2)) (setq a 3) (symbol-value 'a)) @result{} 1 ;; SYMBOL-VALUE can see dynamic variables. (let ((a 2)) (declare (special a)) (symbol-value 'a)) @result{} 2 (let ((a 2)) (declare (special a)) (setq a 3) (symbol-value 'a)) @result{} 3 (let ((a 2)) (setf (symbol-value 'a) 3) a) @result{} 2 a @result{} 3 (symbol-value 'a) @result{} 3 (let ((a 4)) (declare (special a)) (let ((b (symbol-value 'a))) (setf (symbol-value 'a) 5) (values a b))) @result{} 5, 4 a @result{} 3 (symbol-value :any-keyword) @result{} :ANY-KEYWORD (symbol-value 'nil) @result{} NIL (symbol-value '()) @result{} NIL ;; The precision of this next one is @i{implementation-dependent}. (symbol-value 'pi) @result{} 3.141592653589793d0 @end example @subsubheading Affected By:: @b{makunbound}, @b{set}, @b{setq} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. Should signal @b{unbound-variable} if @i{symbol} is @i{unbound} and an attempt is made to @i{read} its @i{value}. (No such error is signaled on an attempt to @i{write} its @i{value}.) @subsubheading See Also:: @ref{boundp} , @ref{makunbound} , @ref{set} , @ref{setq} @subsubheading Notes:: @b{symbol-value} can be used to get the value of a @i{constant variable}. @b{symbol-value} cannot @i{access} the value of a @i{lexical variable}. @node get, remprop, symbol-value, Symbols Dictionary @subsection get [Accessor] @code{get} @i{symbol indicator @r{&optional} default} @result{} @i{value} (setf (@code{ get} @i{symbol indicator @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{indicator}---an @i{object}. @i{default}---an @i{object}. The default is @b{nil}. @i{value}---if the indicated property exists, the @i{object} that is its @i{value}; otherwise, the specified @i{default}. @i{new-value}---an @i{object}. @subsubheading Description:: @b{get} finds a @i{property} on the @i{property list}_2 of @i{symbol} whose @i{property indicator} is @i{identical} to @i{indicator}, and returns its corresponding @i{property value}. If there are multiple @i{properties}_1 with that @i{property indicator}, @b{get} uses the first such @i{property}. If there is no @i{property} with that @i{property indicator}, @i{default} is returned. @b{setf} of @b{get} may be used to associate a new @i{object} with an existing indicator already on the @i{symbol}'s @i{property list}, or to create a new assocation if none exists. If there are multiple @i{properties}_1 with that @i{property indicator}, @b{setf} of @b{get} associates the @i{new-value} with the first such @i{property}. When a @b{get} @i{form} is used as a @b{setf} @i{place}, any @i{default} which is supplied is evaluated according to normal left-to-right evaluation rules, but its @i{value} is ignored. @subsubheading Examples:: @example (defun make-person (first-name last-name) (let ((person (gensym "PERSON"))) (setf (get person 'first-name) first-name) (setf (get person 'last-name) last-name) person)) @result{} MAKE-PERSON (defvar *john* (make-person "John" "Dow")) @result{} *JOHN* *john* @result{} #:PERSON4603 (defvar *sally* (make-person "Sally" "Jones")) @result{} *SALLY* (get *john* 'first-name) @result{} "John" (get *sally* 'last-name) @result{} "Jones" (defun marry (man woman married-name) (setf (get man 'wife) woman) (setf (get woman 'husband) man) (setf (get man 'last-name) married-name) (setf (get woman 'last-name) married-name) married-name) @result{} MARRY (marry *john* *sally* "Dow-Jones") @result{} "Dow-Jones" (get *john* 'last-name) @result{} "Dow-Jones" (get (get *john* 'wife) 'first-name) @result{} "Sally" (symbol-plist *john*) @result{} (WIFE #:PERSON4604 LAST-NAME "Dow-Jones" FIRST-NAME "John") (defmacro age (person &optional (default ''thirty-something)) `(get ,person 'age ,default)) @result{} AGE (age *john*) @result{} THIRTY-SOMETHING (age *john* 20) @result{} 20 (setf (age *john*) 25) @result{} 25 (age *john*) @result{} 25 (age *john* 20) @result{} 25 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{getf} , @ref{symbol-plist} , @ref{remprop} @subsubheading Notes:: @example (get x y) @equiv{} (getf (symbol-plist x) y) @end example @i{Numbers} and @i{characters} are not recommended for use as @i{indicators} in portable code since @b{get} tests with @b{eq} rather than @b{eql}, and consequently the effect of using such @i{indicators} is @i{implementation-dependent}. There is no way using @b{get} to distinguish an absent property from one whose value is @i{default}. However, see @b{get-properties}. @node remprop, boundp, get, Symbols Dictionary @subsection remprop [Function] @code{remprop} @i{symbol indicator} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{indicator}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{remprop} removes from the @i{property list}_2 of @i{symbol} a @i{property}_1 with a @i{property indicator} @i{identical} to @i{indicator}. If there are multiple @i{properties}_1 with the @i{identical} key, @b{remprop} only removes the first such @i{property}. @b{remprop} returns @i{false} if no such @i{property} was found, or @i{true} if a property was found. The @i{property indicator} and the corresponding @i{property value} are removed in an undefined order by destructively splicing the property list. The permissible side-effects correspond to those permitted for @b{remf}, such that: @example (remprop @i{x} @i{y}) @equiv{} (remf (symbol-plist @i{x}) @i{y}) @end example @subsubheading Examples:: @example (setq test (make-symbol "PSEUDO-PI")) @result{} #:PSEUDO-PI (symbol-plist test) @result{} () (setf (get test 'constant) t) @result{} T (setf (get test 'approximation) 3.14) @result{} 3.14 (setf (get test 'error-range) 'noticeable) @result{} NOTICEABLE (symbol-plist test) @result{} (ERROR-RANGE NOTICEABLE APPROXIMATION 3.14 CONSTANT T) (setf (get test 'approximation) nil) @result{} NIL (symbol-plist test) @result{} (ERROR-RANGE NOTICEABLE APPROXIMATION NIL CONSTANT T) (get test 'approximation) @result{} NIL (remprop test 'approximation) @result{} @i{true} (get test 'approximation) @result{} NIL (symbol-plist test) @result{} (ERROR-RANGE NOTICEABLE CONSTANT T) (remprop test 'approximation) @result{} NIL (symbol-plist test) @result{} (ERROR-RANGE NOTICEABLE CONSTANT T) (remprop test 'error-range) @result{} @i{true} (setf (get test 'approximation) 3) @result{} 3 (symbol-plist test) @result{} (APPROXIMATION 3 CONSTANT T) @end example @subsubheading Side Effects:: The @i{property list} of @i{symbol} is modified. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{remf} , @ref{symbol-plist} @subsubheading Notes:: @i{Numbers} and @i{characters} are not recommended for use as @i{indicators} in portable code since @b{remprop} tests with @b{eq} rather than @b{eql}, and consequently the effect of using such @i{indicators} is @i{implementation-dependent}. Of course, if you've gotten as far as needing to remove such a @i{property}, you don't have much choice---the time to have been thinking about this was when you used @b{setf} of @b{get} to establish the @i{property}. @node boundp, makunbound, remprop, Symbols Dictionary @subsection boundp [Function] @code{boundp} @i{symbol} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{symbol} is @i{bound}; otherwise, returns @i{false}. @subsubheading Examples:: @example (setq x 1) @result{} 1 (boundp 'x) @result{} @i{true} (makunbound 'x) @result{} X (boundp 'x) @result{} @i{false} (let ((x 2)) (boundp 'x)) @result{} @i{false} (let ((x 2)) (declare (special x)) (boundp 'x)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{set} , @ref{setq} , @ref{symbol-value} , @ref{makunbound} @subsubheading Notes:: The @i{function} @b{bound} determines only whether a @i{symbol} has a value in the @i{global environment}; any @i{lexical bindings} are ignored. @node makunbound, set, boundp, Symbols Dictionary @subsection makunbound [Function] @code{makunbound} @i{symbol} @result{} @i{symbol} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol} @subsubheading Description:: Makes the @i{symbol} be @i{unbound}, regardless of whether it was previously @i{bound}. @subsubheading Examples:: @example (setf (symbol-value 'a) 1) (boundp 'a) @result{} @i{true} a @result{} 1 (makunbound 'a) @result{} A (boundp 'a) @result{} @i{false} @end example @subsubheading Side Effects:: The @i{value cell} of @i{symbol} is modified. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{symbol} is not a @i{symbol}. @subsubheading See Also:: @ref{boundp} , @ref{fmakunbound} @node set, unbound-variable, makunbound, Symbols Dictionary @subsection set [Function] @code{set} @i{symbol value} @result{} @i{value} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{value}---an @i{object}. @subsubheading Description:: @b{set} changes the contents of the @i{value cell} of @i{symbol} to the given @i{value}. @example (set @i{symbol} @i{value}) @equiv{} (setf (symbol-value @i{symbol}) @i{value}) @end example @subsubheading Examples:: @example (setf (symbol-value 'n) 1) @result{} 1 (set 'n 2) @result{} 2 (symbol-value 'n) @result{} 2 (let ((n 3)) (declare (special n)) (setq n (+ n 1)) (setf (symbol-value 'n) (* n 10)) (set 'n (+ (symbol-value 'n) n)) n) @result{} 80 n @result{} 2 (let ((n 3)) (setq n (+ n 1)) (setf (symbol-value 'n) (* n 10)) (set 'n (+ (symbol-value 'n) n)) n) @result{} 4 n @result{} 44 (defvar *n* 2) (let ((*n* 3)) (setq *n* (+ *n* 1)) (setf (symbol-value '*n*) (* *n* 10)) (set '*n* (+ (symbol-value '*n*) *n*)) *n*) @result{} 80 *n* @result{} 2 (defvar *even-count* 0) @result{} *EVEN-COUNT* (defvar *odd-count* 0) @result{} *ODD-COUNT* (defun tally-list (list) (dolist (element list) (set (if (evenp element) '*even-count* '*odd-count*) (+ element (if (evenp element) *even-count* *odd-count*))))) (tally-list '(1 9 4 3 2 7)) @result{} NIL *even-count* @result{} 6 *odd-count* @result{} 20 @end example @subsubheading Side Effects:: The @i{value} of @i{symbol} is changed. @subsubheading See Also:: @ref{setq} , @ref{progv} , @ref{symbol-value} @subsubheading Notes:: The function @b{set} is deprecated. @b{set} cannot change the value of a @i{lexical variable}. @node unbound-variable, , set, Symbols Dictionary @subsection unbound-variable [Condition Type] @subsubheading Class Precedence List:: @b{unbound-variable}, @b{cell-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{unbound-variable} consists of @i{error} @i{conditions} that represent attempts to @i{read} the @i{value} of an @i{unbound variable}. The name of the cell (see @b{cell-error}) is the @i{name} of the @i{variable} that was @i{unbound}. @subsubheading See Also:: @ref{cell-error-name} @c end of including dict-symbols @c %**end of chapter gcl-2.6.14/info/gcl-tk.info-10000644000175000017500000111315014360276512014124 0ustar cammcammThis is gcl-tk.info, produced by makeinfo version 6.7 from gcl-tk.texi. INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU TK Manual END-INFO-DIR-ENTRY This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter  File: gcl-tk.info, Node: Top, Next: General, Prev: (dir), Up: (dir) * Menu: * General:: * Widgets:: * Control:: -- The Detailed Node Listing -- General * Introduction:: * Getting Started:: * Common Features of Widgets:: * Return Values:: * Argument Lists:: * Lisp Functions Invoked from Graphics:: * Linked Variables:: * tkconnect:: Widgets * button:: * listbox:: * scale:: * canvas:: * menu:: * scrollbar:: * checkbutton:: * menubutton:: * text:: * entry:: * message:: * frame:: * label:: * radiobutton:: * toplevel:: Control * after:: * bind:: * destroy:: * tk-dialog:: * exit:: * focus:: * grab:: * tk-listbox-single-select:: * lower:: * tk-menu-bar:: * option:: * options:: * pack-old:: * pack:: * place:: * raise:: * selection:: * send:: * tk:: * tkerror:: * tkvars:: * tkwait:: * update:: * winfo:: * wm::  File: gcl-tk.info, Node: General, Next: Widgets, Prev: Top, Up: Top 1 General ********* * Menu: * Introduction:: * Getting Started:: * Common Features of Widgets:: * Return Values:: * Argument Lists:: * Lisp Functions Invoked from Graphics:: * Linked Variables:: * tkconnect::  File: gcl-tk.info, Node: Introduction, Next: Getting Started, Prev: General, Up: General 1.1 Introduction ================ GCL-TK is a windowing interface for GNU Common Lisp. It provides the functionality of the TK widget set, which in turn implements a widget set which has the look and feel of Motif. The interface allows the user to draw graphics, get input from menus, make regions mouse sensitive, and bind lisp commands to regions. It communicates over a socket with a 'gcltksrv' process, which speaks to the display via the TK library. The displaying process may run on a machine which is closer to the display, and so involves less communication. It also may remain active even though the lisp is involved in a separate user computation. The display server can, however, interrupt the lisp at will, to inquire about variables and run commands. The user may also interface with existing 'TCL/TK' programs, binding some buttons, or tracking some objects. The size of the program is moderate. In its current form it adds only about 45K bytes to the lisp image, and the 'gcltksrv' program uses shared libraries, and is on the order of 150Kbytes on a sparc. This chapter describes some of the common features of the command structure of widgets, and of control functions. The actual functions for construction of windows are discussed in *note Widgets::, and more general functions for making them appear, lowering them, querying about them in *note Control::.  File: gcl-tk.info, Node: Getting Started, Next: Common Features of Widgets, Prev: Introduction, Up: General 1.2 Getting Started =================== Once GCL has been properly installed you should be able to do the following simple example: (in-package "TK") (tkconnect) (button '.hello :text "Hello World" :command '(print "hi")) ==>.HELLO (pack '.hello) We first switched to the "TK" package, so that functions like button and pack would be found. After doing the tkconnect, a window should appear on your screen, see *Note tkconnect::. The invocation of the function 'button' creates a new function called '.hello' which is a widget function. It is then made visible in the window by using the 'pack' function. You may now click on the little window, and you should see the command executed in your lisp. Thus "hi" should be printed in the lisp window. This will happen whether or not you have a job running in the lisp, that is lisp will be interrupted and your command will run, and then return the control to your program. The function 'button' is called a widget constructor, and the function '.hello' is called a widget. If you have managed to accomplish the above, then GCL is probably installed correctly, and you can graduate to the next section! If you dont like reading but prefer to look at demos and code, then you should look in the demos directory, where you will find a number of examples. A monitor for the garbage collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), a sample listbox with scrolling (mklistbox).  File: gcl-tk.info, Node: Common Features of Widgets, Next: Return Values, Prev: Getting Started, Up: General 1.3 Common Features of Widgets ============================== A widget is a lisp symbol which has a function binding. The first argument is always a keyword and is called the option. The argument pattern for the remaining arguments depends on the option. The most common option is ':configure' in which case the remaining arguments are alternating keyword/value pairs, with the same keywords being permitted as at the creation of the widget. A widget is created by means of a widget constructor, of which there are currently 15, each of them appearing as the title of a section in *note Widgets::. They live in the '"TK"' package, and for the moment we will assume we have switched to this package. Thus for example 'button' is such a widget constructor function. Of course this is lisp, and you can make your own widget constructors, but when you do so it is a good idea to follow the standard argument patterns that are outlined in this section. (button '.hello) ==> .HELLO creates a widget whose name is '.hello'. There is a parent child hierarchy among widgets which is implicit in the name used for the widget. This is much like the pathname structure on a Unix or Dos file system, except that ''.'' is used as the separator rather than a '/' or '\'. For this reason the widget instances are sometimes referred to as pathnames. A child of the parent widget '.hello' might be called '.hello.joe', and a child of this last might be '.hello.joe.bar'. The parent of everyone is called '.' . Multiple top level windows are created using the 'toplevel' command (*note toplevel::). The widget constructor functions take keyword and value pairs, which allow you to specify attributes at the time of creation: (button '.hello :text "Hello World" :width 20) ==>.HELLO indicating that we want the text in the button window to be 'Hello World' and the width of the window to be 20 characters wide. Other types of windows allow specification in centimeters '2c', or in inches ('2i') or in millimeters '2m' or in pixels '2'. But text windows usually have their dimensions specified as multiples of a character width and height. This latter concept is called a grid. Once the window has been created, if you want to change the text you do NOT do: (button '.hello :text "Bye World" :width 20) This would be in error, because the window .hello already exists. You would either have to first call (destroy '.hello) But usually you just want to change an attribute. '.hello' is actually a function, as we mentioned earlier, and it is this function that you use: (.hello :configure :text "Bye World") This would simply change the text, and not change where the window had been placed on the screen (if it had), or how it had been packed into the window hierarchy. Here the argument ':configure' is called an option, and it specifies which types of keywords can follow it. For example (.hello :flash) is also valid, but in this case the ':text' keyword is not permitted after flash. If it were, then it would mean something else besides what it means in the above. For example one might have defined (.hello :flash :text "PUSH ME") so here the same keyword ':text' would mean something else, eg to flash a subliminal message on the screen. We often refer to calls to the widget functions as messages. One reason for this is that they actually turn into messages to the graphics process 'gcltksrv'. To actually see these messages you can do (debugging t).  File: gcl-tk.info, Node: Return Values, Next: Argument Lists, Prev: Common Features of Widgets, Up: General 1.4 Return Values ================= 1.4.1 Widget Constructor Return Values -------------------------------------- On successful completion, the widget constructor functions return the symbol passed in as the first argument. It will now have a functional binding. It is an error to pass in a symbol which already corresponds to a widget, without first calling the 'destroy' command. On failure, an error is signalled. 1.4.2 Widget Return Values -------------------------- The widget functions themselves, do not normally return any value. Indeed the lisp process does not wait for them to return, but merely dispatches the commands, such as to change the text in themselves. Sometimes however you either wish to wait, in order to synchronize, or you wish to see if your command fails or succeeds. You request values by passing the keyword :return and a value indicating the type. (.hello :configure :text "Bye World" :return 'string) ==> "" ==> T the empty string is returned as first value, and the second value 'T' indicates that the new text value was successfully set. LISP will not continue until the tkclsrv process indicates back that the function call has succeeded. While waiting of course LISP will continue to process other graphics events which arrive, since otherwise a deadlock would arise: the user for instance might click on a mouse, just after we had decided to wait for a return value from the '.hello' function. More generally a user program may be running in GCL and be interrupted to receive and act on communications from the 'gcltksrv' process. If an error occurred then the second return value of the lisp function will be NIL. In this case the first value, the string is usually an informative message about the type of error. A special variable 'tk::*break-on-errors*' which if not 'nil', requests that that LISP signal an error when a message is received indicating a function failed. Whenever a command fails, whether a return value was requested or not, 'gcltksrv' returns a message indicating failure. The default is to not go into the debugger. When debugging your windows it may be convenient however to set this variable to 'T' to track down incorrect messages. The 'gcltksrv' process always returns strings as values. If ':return' type is specified, then conversion to type is accomplished by calling (coerce-result return-string type) Here type must be a symbol with a 'coercion-functions' property. The builtin return types which may be requested are: 'T' in which case the string passed back from the 'gcltksrv' process, will be read by the lisp reader. 'number' the string is converted to a number using the current *read-base* 'list-strings' (coerce-result "a b {c d} e" 'list-strings) ==> ("a" "b" "c d" "e") 'boolean' (coerce-result "1" 'boolean) ==> T (coerce-result "0" 'boolean) ==> NIL The above symbols are in the 'TK' or 'LISP' package. It would be possible to add new types just as the ':return t' is done: (setf (get 't 'coercion-functions) (cons #'(lambda (x) (our-read-from-string x 0)) #'(lambda (x) (format nil "~s" x)))) The 'coercion-functions' property of a symbol, is a cons whose 'car' is the coercion form from a string to some possibly different lisp object, and whose 'cdr' is a function which builds a string to send to the graphics server. Often the two functions are inverse functions one of the other up to equal. 1.4.3 Control Function Return Values ------------------------------------ The control functions (*note Control::) do not return a value or wait unless requested to do so, using the ':return' keyword. The types and method of specification are the same as for the Widget Functions in the previous section. (winfo :width '.hello :return 'number) ==> 120 indicates that the '.hello' button is actually 120 pixels wide.  File: gcl-tk.info, Node: Argument Lists, Next: Lisp Functions Invoked from Graphics, Prev: Return Values, Up: General 1.5 Argument Lists ================== 1.5.1 Widget Functions ---------------------- The rule is that the first argument for a widget function is a keyword, called the option. The pattern of the remaining arguments depends completely on the option argument. Thus (.hello option ?arg1? ?arg2? ...) One option which is permitted for every widget function is ':configure'. The argument pattern following it is the same keyword/value pair list which is used in widget creation. For a 'button' widget, the other valid options are ':deactivate', ':flash', and ':invoke'. To find these, since '.hello' was constructed with the 'button' constructor, you should see *Note button::. The argument pattern for other options depends completely on the option and the widget function. For example if '.scrollbar' is a scroll bar window, then the option ':set' must be followed by 4 numeric arguments, which indicate how the scrollbar should be displayed, see *Note scrollbar::. (.scrollbar :set a1 a2 a3 a4) If on the other hand '.scale' is a scale (*note scale::), then we have (.scale :set a1 ) only one numeric argument should be supplied, in order to position the scale. 1.5.2 Widget Constructor Argument Lists --------------------------------------- These are (widget-constructor pathname :keyword1 value1 :keyword2 value2 ...) to create the widget whose name is pathname. The possible keywords allowed are specified in the corresponding section of *Note Widgets::. 1.5.3 Concatenation Using ':' in Argument List ---------------------------------------------- What has been said so far about arguments is not quite true. A special string concatenation construction is allowed in argument lists for widgets, widget constructors and control functions. First we introduce the function 'tk-conc' which takes an arbitrary number of arguments, which may be symbols, strings or numbers, and concatenates these into a string. The print names of symbols are converted to lower case, and package names are ignored. (tk-conc "a" 1 :b 'cd "e") ==> "a1bcde" One could use 'tk-conc' to construct arguments for widget functions. But even though 'tk-conc' has been made quite efficient, it still would involve the creation of a string. The ':' construct avoids this. In a call to a widget function, a widget constructor, or a control function you may remove the call to 'tk-conc' and place ':' in between each of its arguments. Those functions are able to understand this and treat the extra arguments as if they were glued together in one string, but without the extra cost of actually forming that string. (tk-conc a b c .. w) <==> a : b : c : ... w (setq i 10) (.hello :configure :text i : " pies") (.hello :configure :text (tk-conc i " pies")) (.hello :configure :text (format nil "~a pies" i)) The last three examples would all result in the text string being '"10 pies"', but the first method is the most efficient. That call will be made with no string or cons creation. The GC Monitor example, is written in such a way that there is no creation of 'cons' or 'string' types during normal operation. This is particularly useful in that case, since one is trying to monitor usage of conses by other programs, not its own usage.  File: gcl-tk.info, Node: Lisp Functions Invoked from Graphics, Next: Linked Variables, Prev: Argument Lists, Up: General 1.6 Lisp Functions Invoked from Graphics ======================================== It is possible to make certain areas of a window mouse sensitive, or to run commands on reception of certain events such as keystrokes, while the focus is in a certain window. This is done by having a lisp function invoked or some lisp form evaluated. We shall refer to such a lisp function or form as a _command_. For example (button '.button :text "Hello" :command '(print "hi")) (button '.jim :text "Call Jim" :command 'call-jim) In the first case when the window '.button' is clicked on, the word "hi" will be printed in the lisp to standard output. In the second case 'call-jim' will be funcalled with no arguments. A command must be one of the following three types. What happens depends on which type it is: 'function' If the value satisfies 'functionp' then it will be called with a number of arguments which is dependent on the way it was bound, to graphics. 'string' If the command is a string, then it is passed directly to TCL/TK for evaluation on that side. Lisp will not be required for the evaluation when the command is invoked. 'lisp form' Any other lisp object is regarded as a lisp form to be eval'd, and this will be done when the command is invoked. The following keywords accept as their value a command: :command :yscroll :yscrollcommand :xscroll :xscrollcommand :scrollcommand :bind and in addition 'bind' takes a command as its third argument, see *Note bind::. Below we give three different examples using the 3 possibilities for a command: functionp, string, and lisp form. They all accomplish exactly the same thing. For given a frame '.frame' we could construct a listbox in it as: (listbox '.frame.listbox :yscroll 'joe) Then whenever the listbox view position changes, or text is inserted, so that something changes, the function 'joe' will be invoked with 4 arguments giving the totalsize of the text, maximum number of units the window can display, the index of the top unit, and finally the index of the bottom unit. What these arguments are is specific to the widget 'listbox' and is documented *Note listbox::. 'joe' might be used to do anything, but a common usage is to have 'joe' alter the position of some other window, such as a scroll bar window. Indeed if '.scrollbar' is a scrollbar then the function (defun joe (a b c d) (.scrollbar :set a b c d)) would look after sizing the scrollbar appropriately for the percentage of the window visible, and positioning it. A second method of accomplishing this identical, using a string (the second type of command), (listbox '.frame.listbox :yscroll ".scrollbar set") and this will not involve a call back to lisp. It uses the fact that the TK graphics side understands the window name '.scrollbar' and that it takes the option 'set'. Note that it does not get the ':' before the keyword in this case. In the case of a command which is a lisp form but is not installed via 'bind' or ':bind', then the form will be installed as #'(lambda (&rest *arglist*) lisp-form) where the lisp-form might wish to access the elements of the special variable '*arglist*'. Most often this list will be empty, but for example if the command was setup for '.scale' which is a scale, then the command will be supplied one argument which is the new numeric value which is the scale position. A third way of accomplishing the scrollbar setting using a lisp form is: (listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*)) The 'bind' command and ':bind' keyword, have an additional wrinkle, see *Note bind::. These are associated to an event in a particular window, and the lisp function or form to be evaled must have access to that information. For example the x y position, the window name, the key pressed, etc. This is done via percent symbols which are specified, see *Note bind::. (bind "Entry" "" '(emacs-move %W %A )) will cause the function emacs-move to be be invoked whenever a control key is pressed (unless there are more key specific or window specific bindings of said key). It will be invoked with two arguments, the first %W indicating the window in which it was invoked, and the second being a string which is the ascii keysym which was pressed at the same time as the control key. These percent constructs are only permitted in commands which are invoked via 'bind' or ':bind'. The lisp form which is passed as the command, is searched for the percent constructs, and then a function #'(lambda (%W %A) (emacs-move %W %A)) will be invoked with two arguments, which will be supplied by the TK graphics server, at the time the command is invoked. The '*arglist*' construct is not available for these commands.  File: gcl-tk.info, Node: Linked Variables, Next: tkconnect, Prev: Lisp Functions Invoked from Graphics, Up: General 1.7 Linked Variables ==================== It is possible to link lisp variables to TK variables. In general when the TK variable is changed, by for instance clicking on a radiobutton, the linked lisp variable will be changed. Conversely changing the lisp variable will be noticed by the TK graphics side, if one does the assignment in lisp using 'setk' instead of 'setq'. (button '.hello :textvariable '*message* :text "hi there") (pack '.hello) This causes linking of the global variable '*message*' in lisp to a corresponding variable in TK. Moreover the message that is in the button '.hello' will be whatever the value of this global variable is (so long as the TK side is notified of the change!). Thus if one does (setk *message* "good bye") then the button will change to have good bye as its text. The lisp macro 'setk' expands into (prog1 (setf *message* "good bye") (notice-text-variables)) which does the assignment, and then goes thru the linked variables checking for those that have changed, and updating the TK side should there be any. Thus if you have a more complex program which might have done the assignment of your global variable, you may include the call to 'notice-text-variables' at the end, to assure that the graphics side knows about the changes. A variable which is linked using the keyword ':textvariable' is always a variable containing a string. However it is possible to have other types of variables. (checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*)) (checkbutton '.checkbutton2 :text "A button" :variable '*joe*) (checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*) :onvalue 100 :offvalue -1) The first two examples are the same in that the default variable type for a checkbutton is 'boolean'. Notice that the specification of a variable type is by '(type variable)'. The types which are permissible are those which have coercion-fucntions, *Note Return Values::. In the first example a variable '*joe*' will be linked, and its default initial value will be set to nil, since the default initial state of the check button is off, and the default off value is nil. Actually on the TK side, the corresponding boolean values are '"1"' and '"0"', but the 'boolean' type makes these become 't' and 'nil'. In the third example the variable *debug* may have any lisp value (here type is 't'). The initial value will be made to be '-1', since the checkbutton is off. Clicking on '.checkbutton3' will result in the value of '*debug*' being changed to 100, and the light in the button will be toggled to on, *Note checkbutton::. You may set the variable to be another value besides 100. You may also call (link-text-variable '*joe* 'boolean) to cause the linking of a variable named *joe*. This is done automatically whenever the variable is specified after one of the keys :variable :textvariable. Just as one must be cautious about using global variables in lisp, one must be cautious in making such linked variables. In particular note that the TK side, uses variables for various purposes. If you make a checkbutton with pathname '.a.b.c' then unless you specify a ':variable' option, the variable 'c' will become associated to the TK value of the checkbutton. We do NOT link this variable by default, feeling that one might inadvertently alter global variables, and that they would not typically use the lisp convention of being of the form '*c*'. You must specify the ':variable' option, or call 'link-variable'.  File: gcl-tk.info, Node: tkconnect, Prev: Linked Variables, Up: General 1.8 tkconnect ============= tkconnect &key host display can-rsh gcltksrv This function provides a connection to a graphics server process, which in turn connects to possibly several graphics display screens. The graphics server process, called 'gcltksrv' may or may not run on the same machine as the lisp to which it is attached. 'display' indicates the name of the default display to connect to, and this in turn defaults to the value of the environment variable 'DISPLAY'. When tkconnect is invoked, a socket is opened and it waits for a graphics process to connect to it. If the host argument is not supplied, then a process will be spawned which will connect back to the lisp process. The name of the command for invoking the process is the value of the 'gcltksrv' argument, which defaults to the value of the environment variable 'GCL_TK_SERVER'. If that variable is not set, then the lisp '*lib-directory*' is searched for an entry 'gcl-tk/gcltksrv'. If 'host' is supplied, then a command to run on the remote machine will be printed on standard output. If 'can-rsh' is not nil, then the command will not be printed, but rather an attempt will be made to rsh to the machine, and to run the command. Thus (tkconnect) would start the process on the local machine, and use for 'display' the value of the environment variable 'DISPLAY'. (tkconnect :host "max.ma.utexas.edu" :can-rsh t) would cause an attempt to rsh to 'max' and to run the command there, to connect back to the appropriate port on the localhost. You may indicate that different toplevel windows be on different displays, by using the ':display' argument when creating the window, *Note toplevel::. Clearly you must have a copy of the program 'gcltksrv' and TK libraries installed on the machine where you wish to run the server.  File: gcl-tk.info, Node: Widgets, Next: Control, Prev: General, Up: Top 2 Widgets ********* * Menu: * button:: * listbox:: * scale:: * canvas:: * menu:: * scrollbar:: * checkbutton:: * menubutton:: * text:: * entry:: * message:: * frame:: * label:: * radiobutton:: * toplevel::  File: gcl-tk.info, Node: button, Next: listbox, Prev: Widgets, Up: Widgets 2.1 button ========== button \- Create and manipulate button widgets Synopsis -------- button pathName ?options? Standard Options ---------------- activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY *Note options::, for more information. Arguments for Button -------------------- ':command' Name='"command" Class="Command"' Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. ':height' Name='"height" Class="Height"' Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. ':state' Name='"state" Class="State"' Specifies one of three states for the button: normal, active, or disabled. In normal state the button is displayed using the foreground and background options. The active state is typically used when the pointer is over the button. In active state the button is displayed using the activeForeground and activeBackground options. Disabled state means that the button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the disabledForeground and background options determine how the button is displayed. ':width' Name='"width" Class="Width"' Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. Description ----------- The button command creates a new window (given by the pathName argument) and makes it into a button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the button such as its colors, font, text, and initial relief. The button command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A button is a widget that displays a textual string or bitmap. It can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; and it can be made to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the button), then the Tcl command specified in the :command option is invoked. A Button Widget's Arguments --------------------------- The button command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for button widgets: pathName :activate Change the button's state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state active" instead. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the button command. pathName :deactivate Change the button's state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state normal" instead. pathName :flash Flash the button. This is accomplished by redisplaying the button several times, alternating between active and normal colors. At the end of the flash the button is left in the same normal/active state as when the command was invoked. This command is ignored if the button's state is disabled. pathName :invoke Invoke the Tcl command associated with the button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the button. This command is ignored if the button's state is disabled. "Default Bindings" ------------------ Tk automatically creates class bindings for buttons that give them the following default behavior: [1] The button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the button. [2] The button's relief is changed to sunken whenever mouse button 1 is pressed over the button, and the relief is restored to its original value when button 1 is later released. [3] If mouse button 1 is pressed over the button and later released over the button, the button is invoked. However, if the mouse is not over the button when button 1 is released, then no invocation occurs. If the button's state is disabled then none of the above actions occur: the button is completely non-responsive. The behavior of buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. Keywords -------- button, widget  File: gcl-tk.info, Node: listbox, Next: scale, Prev: button, Up: Widgets 2.2 listbox =========== listbox \- Create and manipulate listbox widgets Synopsis -------- listbox pathName ?options? Standard Options ---------------- background foreground selectBackground xScrollCommand borderWidth font selectBorderWidth yScrollCommand cursor geometry selectForeground exportSelection relief setGrid *Note options::, for more information. Arguments for Listbox --------------------- None. Description ----------- The listbox command creates a new window (given by the pathName argument) and makes it into a listbox widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the listbox such as its colors, font, text, and relief. The listbox command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A listbox is a widget that displays a list of strings, one per line. When first created, a new listbox has no elements in its list. Elements may be added or deleted using widget commands described below. In addition, one or more elements may be selected as described below. If a listbox is exporting its selection (see exportSelection option), then it will observe the standard X11 protocols for handling the selection; listbox selections are available as type STRING, consisting of a Tcl list with one entry for each selected element. For large lists only a subset of the list elements will be displayed in the listbox window at once; commands described below may be used to change the view in the window. Listboxes allow scrolling in both directions using the standard xScrollCommand and yScrollCommand options. They also support scanning, as described below. A Listbox's Arguments --------------------- The listbox command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for listbox widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the listbox command. pathName :curselection Returns a list containing the indices of all of the elements in the listbox that are currently selected. If there are no elements selected in the listbox then an empty string is returned. pathName :delete first ?last? Delete one or more elements of the listbox. First and last give the integer indices of the first and last elements in the range to be deleted. If last isn't specified it defaults to first, i.e. a single element is deleted. An index of 0 corresponds to the first element in the listbox. Either first or last may be specified as end, in which case it refers to the last element of the listbox. This command returns an empty string pathName :get index Return the contents of the listbox element indicated by index. Index must be a non-negative integer (0 corresponds to the first element in the listbox), or it may also be specified as end to indicate the last element in the listbox. pathName :insert index ?element element ...? Insert zero or more new elements in the list just before the element given by index. If index is specified as end then the new elements are added to the end of the list. Returns an empty string. pathName :nearest y Given a y-coordinate within the listbox window, this command returns the index of the (visible) listbox element nearest to that y-coordinate. pathName :scan option args This command is used to implement scanning on listboxes. It has two forms, depending on option: pathName :scan :mark x y Records x and y and the current view in the listbox window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. pathName :scan :dragto x y. This command computes the difference between its x and y arguments and the x and y arguments to the last scan mark command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the list at high speed through the window. The return value is an empty string. pathName :select option arg This command is used to adjust the selection within a listbox. It has several forms, depending on option. In all of the forms the index end refers to the last element in the listbox. pathName :select :adjust index Locate the end of the selection nearest to the element given by index, and adjust that end of the selection to be at index (i.e including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn't currently in the listbox, then this command is identical to the select from widget command. Returns an empty string. pathName :select :clear If the selection is in this listbox then it is cleared so that none of the listbox's elements are selected anymore. pathName :select :from index Set the selection to consist of element index, and make index the anchor point for future select to widget commands. Returns an empty string. pathName :select :to index Set the selection to consist of the elements from the anchor point to element index, inclusive. The anchor point is determined by the most recent select from or select adjust command in this widget. If the selection isn't in this widget, this command is identical to select from. Returns an empty string. pathName :size Returns a decimal string indicating the total number of elements in the listbox. pathName :xview index Adjust the view in the listbox so that character position index is displayed at the left edge of the widget. Returns an empty string. pathName :yview index Adjust the view in the listbox so that element index is displayed at the top of the widget. If index is specified as end it indicates the last element of the listbox. Returns an empty string. "Default Bindings" ------------------ Tk automatically creates class bindings for listboxes that give them the following default behavior: [1] When button 1 is pressed over a listbox, the element underneath the mouse cursor is selected. The mouse can be dragged to select a range of elements. [2] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. [3] The view in the listbox can be adjusted by dragging with mouse button 2. The behavior of listboxes can be changed by defining new bindings for individual widgets or by redefining the class bindings. In addition, the procedure tk_listboxSingleSelect may be invoked to change listbox behavior so that only a single element may be selected at once. Keywords -------- listbox, widget  File: gcl-tk.info, Node: scale, Next: canvas, Prev: listbox, Up: Widgets 2.3 scale ========= scale \- Create and manipulate scale widgets Synopsis -------- scale pathName ?options? Standard Options ---------------- activeForeground borderWidth font orient background cursor foreground relief *Note options::, for more information. Arguments for Scale ------------------- ':command' Name='"command" Class="Command"' Specifies the prefix of a Tcl command to invoke whenever the value of the scale is changed interactively. The actual command consists of this option followed by a space and a number. The number indicates the new value of the scale. ':from' Name='"from" Class="From"' Specifies the value corresponding to the left or top end of the scale. Must be an integer. ':label' Name='"label" Class="Label"' Specifies a string to displayed as a label for the scale. For vertical scales the label is displayed just to the right of the top end of the scale. For horizontal scales the label is displayed just above the left end of the scale. ':length' Name='"length" Class="Length"' Specifies the desired long dimension of the scale in screen units, that is in any of the forms acceptable to Tk_GetPixels. For vertical scales this is the scale's height; for horizontal scales it is the scale's width. ':showvalue' Name='"showValue" Class="ShowValue"' Specifies a boolean value indicating whether or not the current value of the scale is to be displayed. ':sliderforeground' Name='"sliderForeground" Class="sliderForeground"' Specifies the color to use for drawing the slider under normal conditions. When the mouse is in the slider window then the slider's color is determined by the activeForeground option. ':sliderlength' Name='"sliderLength" Class="SliderLength"' Specfies the size of the slider, measured in screen units along the slider's long dimension. The value may be specified in any of the forms acceptable to Tk_GetPixels. ':state' Name='"state" Class="State"' Specifies one of two states for the scale: normal or disabled. If the scale is disabled then the value may not be changed and the scale won't activate when the mouse enters it. ':tickinterval' Name='"tickInterval" Class="TickInterval"' Must be an integer value. Determines the spacing between numerical tick-marks displayed below or to the left of the slider. If specified as 0, then no tick-marks will be displayed. ':to' Name='"to" Class="To"' Specifies the value corresponding to the right or bottom end of the scale. Must be an integer. This value may be either less than or greater than the from option. ':width' Name='"width" Class="Width"' Specifies the desired narrow dimension of the scale in screen units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical scales this is the scale's width; for horizontal scales this is the scale's height. Description ----------- The scale command creates a new window (given by the pathName argument) and makes it into a scale widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scale such as its colors, orientation, and relief. The scale command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A scale is a widget that displays a rectangular region and a small slider. The rectangular region corresponds to a range of integer values (determined by the from and to options), and the position of the slider selects a particular integer value. The slider's position (and hence the scale's value) may be adjusted by clicking or dragging with the mouse as described in the BINDINGS section below. Whenever the scale's value is changed, a Tcl command is invoked (using the command option) to notify other interested widgets of the change. Three annotations may be displayed in a scale widget: a label appearing at the top-left of the widget (top-right for vertical scales), a number displayed just underneath the slider (just to the left of the slider for vertical scales), and a collection of numerical tick-marks just underneath the current value (just to the left of the current value for vertical scales). Each of these three annotations may be selectively enabled or disabled using the configuration options. A Scale's"Argumentsommand" -------------------------- The scale command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for scale widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the scale command. pathName :get Returns a decimal string giving the current value of the scale. pathName :set value This command is invoked to change the current value of the scale, and hence the position at which the slider is displayed. Value gives the new value for the scale. Bindings -------- When a new scale is created, it is given the following initial behavior by default: Change the slider display to use activeForeground instead of sliderForeground. Reset the slider display to use sliderForeground instead of activeForeground. Change the slider display so that the slider appears sunken rather than raised. Move the slider (and adjust the scale's value) to correspond to the current mouse position. Move the slider (and adjust the scale's value) to correspond to the current mouse position. Reset the slider display so that the slider appears raised again. Keywords -------- scale, widget  File: gcl-tk.info, Node: canvas, Next: menu, Prev: scale, Up: Widgets 2.4 canvas ========== canvas \- Create and manipulate canvas widgets Synopsis -------- canvas pathName ?options? Standard Options ---------------- background insertBorderWidth relief xScrollCommand borderWidth insertOffTime selectBackground yScrollCommand cursor insertOnTime selectBorderWidth insertBackground insertWidth selectForeground *Note options::, for more information. Arguments for Canvas -------------------- ':closeenough' Name='"closeEnough" Class="CloseEnough"' Specifies a floating-point value indicating how close the mouse cursor must be to an item before it is considered to be "inside" the item. Defaults to 1.0. ':confine' Name='"confine" Class="Confine"' Specifies a boolean value that indicates whether or not it should be allowable to set the canvas's view outside the region defined by the scrollRegion argument. Defaults to true, which means that the view will be constrained within the scroll region. ':height' Name='"height" Class="Height"' Specifies a desired window height that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. ':scrollincrement' Name='"scrollIncrement" Class="ScrollIncrement"' Specifies a distance used as increment during scrolling: when one of the arrow buttons on an associated scrollbar is pressed, the picture will shift by this distance. The distance may be specified in any of the forms described in the COORDINATES section below. ':scrollregion' Name='"scrollRegion" Class="ScrollRegion"' Specifies a list with four coordinates describing the left, top, right, and bottom coordinates of a rectangular region. This region is used for scrolling purposes and is considered to be the boundary of the information in the canvas. Each of the coordinates may be specified in any of the forms given in the COORDINATES section below. ':width' Name='"width" Class="width"' Specifies a desired window width that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. Introduction ------------ The canvas command creates a new window (given by the pathName argument) and makes it into a canvas widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the canvas such as its colors and 3-D relief. The canvas command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. Canvas widgets implement structured graphics. A canvas displays any number of items, which may be things like rectangles, circles, lines, and text. Items may be manipulated (e.g. moved or re-colored) and commands may be associated with items in much the same way that the bind command allows commands to be bound to widgets. For example, a particular command may be associated with the event so that the command is invoked whenever button 1 is pressed with the mouse cursor over an item. This means that items in a canvas can have behaviors defined by the Tcl scripts bound to them. Display List ------------ The items in a canvas are ordered for purposes of display, with the first item in the display list being displayed first, followed by the next item in the list, and so on. Items later in the display list obscure those that are earlier in the display list and are sometimes referred to as being "on top" of earlier items. When a new item is created it is placed at the end of the display list, on top of everything else. Widget commands may be used to re-arrange the order of the display list. Item Ids And Tags ----------------- Items in a canvas widget may be named in either of two ways: by id or by tag. Each item has a unique identifying number which is assigned to that item when it is created. The id of an item never changes and id numbers are never re-used within the lifetime of a canvas widget. Each item may also have any number of tags associated with it. A tag is just a string of characters, and it may take any form except that of an integer. For example, "x123" is OK but "123" isn't. The same tag may be associated with many different items. This is commonly done to group items in various interesting ways; for example, all selected items might be given the tag "selected". The tag all is implicitly associated with every item in the canvas; it may be used to invoke operations on all the items in the canvas. The tag current is managed automatically by Tk; it applies to the current item, which is the topmost item whose drawn area covers the position of the mouse cursor. If the mouse is not in the canvas widget or is not over an item, then no item has the current tag. When specifying items in canvas widget commands, if the specifier is an integer then it is assumed to refer to the single item with that id. If the specifier is not an integer, then it is assumed to refer to all of the items in the canvas that have a tag matching the specifier. The symbol tagOrId is used below to indicate that an argument specifies either an id that selects a single item or a tag that selects zero or more items. Some widget commands only operate on a single item at a time; if tagOrId is specified in a way that names multiple items, then the normal behavior is for the command to use the first (lowest) of these items in the display list that is suitable for the command. Exceptions are noted in the widget command descriptions below. Coordinates ----------- All coordinates related to canvases are stored as floating-point numbers. Coordinates and distances are specified in screen units, which are floating-point numbers optionally followed by one of several letters. If no letter is supplied then the distance is in pixels. If the letter is m then the distance is in millimeters on the screen; if it is c then the distance is in centimeters; i means inches, and p means printers points (1/72 inch). Larger y-coordinates refer to points lower on the screen; larger x-coordinates refer to points farther to the right. Transformations --------------- Normally the origin of the canvas coordinate system is at the upper-left corner of the window containing the canvas. It is possible to adjust the origin of the canvas coordinate system relative to the origin of the window using the xview and yview widget commands; this is typically used for scrolling. Canvases do not support scaling or rotation of the canvas coordinate system relative to the window coordinate system. Indidividual items may be moved or scaled using widget commands described below, but they may not be rotated. Indices ------- Text items support the notion of an index for identifying particular positions within the item. Indices are used for commands such as inserting text, deleting a range of characters, and setting the insertion cursor position. An index may be specified in any of a number of ways, and different types of items may support different forms for specifying indices. Text items support the following forms for an index; if you define new types of text-like items, it would be advisable to support as many of these forms as practical. Note that it is possible to refer to the character just after the last one in the text item; this is necessary for such tasks as inserting new text at the end of the item. number A decimal number giving the position of the desired character within the text item. 0 refers to the first character, 1 to the next character, and so on. A number less than 0 is treated as if it were zero, and a number greater than the length of the text item is treated as if it were equal to the length of the text item. end Refers to the character just after the last one in the item (same as the number of characters in the item). insert Refers to the character just before which the insertion cursor is drawn in this item. sel.first Refers to the first selected character in the item. If the selection isn't in this item then this form is illegal. sel.last Refers to the last selected character in the item. If the selection isn't in this item then this form is illegal. @x,y Refers to the character at the point given by x and y, where x and y are specified in the coordinate system of the canvas. If x and y lie outside the coordinates covered by the text item, then they refer to the first or last character in the line that is closest to the given point. A Canvas Widget's Arguments --------------------------- The canvas command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following widget commands are possible for canvas widgets: pathName :addtag tag searchSpec ?arg arg ...? For each item that meets the constraints specified by searchSpec and the args, add tag to the list of tags associated with the item if it isn't already present on that list. It is possible that no items will satisfy the constraints given by searchSpec and args, in which case the command has no effect. This command returns an empty string as result. SearchSpec and arg's may take any of the following forms: above tagOrId Selects the item just after (above) the one given by tagOrId in the display list. If tagOrId denotes more than one item, then the last (topmost) of these items in the display list is used. all Selects all the items in the canvas. below tagOrId Selects the item just before (below) the one given by tagOrId in the display list. If tagOrId denotes more than one item, then the first (lowest) of these items in the display list is used. closest x y ?halo? ?start? Selects the item closest to the point given by x and y. If more than one item is at the same closest distance (e.g. two items overlap the point), then the top-most of these items (the last one in the display list) is used. If halo is specified, then it must be a non-negative value. Any item closer than halo to the point is considered to overlap it. The start argument may be used to step circularly through all the closest items. If start is specified, it names an item using a tag or id (if by tag, it selects the first item in the display list with the given tag). Instead of selecting the topmost closest item, this form will select the topmost closest item that is below start in the display list; if no such item exists, then the selection behaves as if the start argument had not been specified. enclosed x1 y1 x2 y2 Selects all the items completely enclosed within the rectangular region given by x1, y1, x2, and y2. X1 must be no greater then x2 and y1 must be no greater than y2. overlapping x1 y1 x2 y2 Selects all the items that overlap or are enclosed within the rectangular region given by x1, y1, x2, and y2. X1 must be no greater then x2 and y1 must be no greater than y2. withtag tagOrId Selects all the items given by tagOrId. pathName :bbox tagOrId ?tagOrId tagOrId ...? Returns a list with four elements giving an approximate bounding box for all the items named by the tagOrId arguments. The list has the form "x1 y1 x2 y2" such that the drawn areas of all the named elements are within the region bounded by x1 on the left, x2 on the right, y1 on the top, and y2 on the bottom. The return value may overestimate the actual bounding box by a few pixels. If no items match any of the tagOrId arguments then an empty string is returned. pathName :bind tagOrId ?sequence? ?command? This command associates command with all the items given by tagOrId such that whenever the event sequence given by sequence occurs for one of the items the command will be invoked. This widget command is similar to the bind command except that it operates on items in a canvas rather than entire widgets. See the bind manual entry for complete details on the syntax of sequence and the substitutions performed on command before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same sequence and tagOrId (if the first character of command is "+" then command augments an existing binding rather than replacing it). In this case the return value is an empty string. If command is omitted then the command returns the command associated with tagOrId and sequence (an error occurs if there is no such binding). If both command and sequence are omitted then the command returns a list of all the sequences for which bindings have been defined for tagOrId. The only events for which bindings may be specified are those related to the mouse and keyboard, such as Enter, Leave, ButtonPress, Motion, and KeyPress. The handling of events in canvases uses the current item defined in ITEM IDS AND TAGS above. Enter and Leave events trigger for an item when it becomes the current item or ceases to be the current item; note that these events are different than Enter and Leave events for windows. Mouse-related events are directed to the current item, if any. Keyboard-related events are directed to the focus item, if any (see the focus widget command below for more on this). It is possible for multiple commands to be bound to a single event sequence for a single object. This occurs, for example, if one command is associated with the item's id and another is associated with one of the item's tags. When this occurs, the first matching binding is used. A binding for the item's id has highest priority, followed by the oldest tag for the item and proceeding through all of the item's tags up through the most-recently-added one. If a binding is associated with the tag all, the binding will have lower priority than all other bindings associated with the item. pathName :canvasx screenx ?gridspacing? Given a screen x-coordinate screenx this command returns the canvas x-coordinate that is displayed at that location. If gridspacing is specified, then the canvas coordinate is rounded to the nearest multiple of gridspacing units. pathName :canvasy screeny ?gridspacing? Given a screen y-coordinate screeny this command returns the canvas y-coordinate that is displayed at that location. If gridspacing is specified, then the canvas coordinate is rounded to the nearest multiple of gridspacing units. pathName :configure ?option? ?value? ?option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the canvas command. pathName :coords tagOrId ?x0 y0 ...? Query or modify the coordinates that define an item. If no coordinates are specified, this command returns a list whose elements are the coordinates of the item named by tagOrId. If coordinates are specified, then they replace the current coordinates for the named item. If tagOrId refers to multiple items, then the first one in the display list is used. pathName :create type x y ?x y ...? ?option value ...? Create a new item in pathName of type type. The exact format of the arguments after type depends on type, but usually they consist of the coordinates for one or more points, followed by specifications for zero or more item options. See the subsections on individual item types below for more on the syntax of this command. This command returns the id for the new item. pathName :dchars tagOrId first ?last? For each item given by tagOrId, delete the characters in the range given by first and last, inclusive. If some of the items given by tagOrId don't support text operations, then they are ignored. First and last are indices of characters within the item(s) as described in INDICES above. If last is omitted, it defaults to first. This command returns an empty string. pathName :delete ?tagOrId tagOrId ...? Delete each of the items given by each tagOrId, and return an empty string. pathName :dtag tagOrId ?tagToDelete? For each of the items given by tagOrId, delete the tag given by tagToDelete from the list of those associated with the item. If an item doesn't have the tag tagToDelete then the item is unaffected by the command. If tagToDelete is omitted then it defaults to tagOrId. This command returns an empty string. pathName :find searchCommand ?arg arg ...? This command returns a list consisting of all the items that meet the constraints specified by searchCommand and arg's. SearchCommand and args have any of the forms accepted by the addtag command. pathName :focus ?tagOrId? Set the keyboard focus for the canvas widget to the item given by tagOrId. If tagOrId refers to several items, then the focus is set to the first such item in the display list that supports the insertion cursor. If tagOrId doesn't refer to any items, or if none of them support the insertion cursor, then the focus isn't changed. If tagOrId is an empty string, then the focus item is reset so that no item has the focus. If tagOrId is not specified then the command returns the id for the item that currently has the focus, or an empty string if no item has the focus. Once the focus has been set to an item, the item will display the insertion cursor and all keyboard events will be directed to that item. The focus item within a canvas and the focus window on the screen (set with the focus command) are totally independent: a given item doesn't actually have the input focus unless (a) its canvas is the focus window and (b) the item is the focus item within the canvas. In most cases it is advisable to follow the focus widget command with the focus command to set the focus window to the canvas (if it wasn't there already). pathName :gettags tagOrId Return a list whose elements are the tags associated with the item given by tagOrId. If tagOrId refers to more than one item, then the tags are returned from the first such item in the display list. If tagOrId doesn't refer to any items, or if the item contains no tags, then an empty string is returned. pathName :icursor tagOrId index Set the position of the insertion cursor for the item(s) given by tagOrId to just before the character whose position is given by index. If some or all of the items given by tagOrId don't support an insertion cursor then this command has no effect on them. See INDICES above for a description of the legal forms for index. Note: the insertion cursor is only displayed in an item if that item currently has the keyboard focus (see the widget command focus, below), but the cursor position may be set even when the item doesn't have the focus. This command returns an empty string. pathName :index tagOrId index This command returns a decimal string giving the numerical index within tagOrId corresponding to index. Index gives a textual description of the desired position as described in INDICES above. The return value is guaranteed to lie between 0 and the number of characters within the item, inclusive. If tagOrId refers to multiple items, then the index is processed in the first of these items that supports indexing operations (in display list order). pathName :insert tagOrId beforeThis string For each of the items given by tagOrId, if the item supports text insertion then string is inserted into the item's text just before the character whose index is beforeThis. See INDICES above for information about the forms allowed for beforeThis. This command returns an empty string. pathName :itemconfigure tagOrId ?option? ?value? ?option value ...? This command is similar to the configure widget command except that it modifies item-specific options for the items given by tagOrId instead of modifying options for the overall canvas widget. If no option is specified, returns a list describing all of the available options for the first item given by tagOrId (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s) in each of the items given by tagOrId; in this case the command returns an empty string. The options and values are the same as those permissible in the create widget command when the item(s) were created; see the sections describing individual item types below for details on the legal options. pathName :lower tagOrId ?belowThis? Move all of the items given by tagOrId to a new position in the display list just before the item given by belowThis. If tagOrId refers to more than one item then all are moved but the relative order of the moved items will not be changed. BelowThis is a tag or id; if it refers to more than one item then the first (lowest) of these items in the display list is used as the destination location for the moved items. This command returns an empty string. pathName :move tagOrId xAmount yAmount Move each of the items given by tagOrId in the canvas coordinate space by adding xAmount to the x-coordinate of each point associated with the item and yAmount to the y-coordinate of each point associated with the item. This command returns an empty string. pathName :postscript ?option value option value ...? Generate a Postscript representation for part or all of the canvas. If the :file option is specified then the Postscript is written to a file and an empty string is returned; otherwise the Postscript is returned as the result of the command. The Postscript is created in Encapsulated Postscript form using version 3.0 of the Document Structuring Conventions. The option\-value argument pairs provide additional information to control the generation of Postscript. The following options are supported: :colormap varName VarName must be the name of a global array variable that specifies a color mapping to use in the Postscript. Each element of varName must consist of Postscript code to set a particular color value (e.g. "1.0 1.0 0.0 setrgbcolor"). When outputting color information in the Postscript, Tk checks to see if there is an element of varName with the same name as the color. If so, Tk uses the value of the element as the Postscript command to set the color. If this option hasn't been specified, or if there isn't an entry in varName for a given color, then Tk uses the red, green, and blue intensities from the X color. :colormode mode Specifies how to output color information. Mode must be either color (for full color output), gray (convert all colors to their gray-scale equivalents) or mono (convert all colors to black or white). :file fileName Specifies the name of the file in which to write the Postscript. If this option isn't specified then the Postscript is returned as the result of the command instead of being written to a file. :fontmap varName VarName must be the name of a global array variable that specifies a font mapping to use in the Postscript. Each element of varName must consist of a Tcl list with two elements, which are the name and point size of a Postscript font. When outputting Postscript commands for a particular font, Tk checks to see if varName contains an element with the same name as the font. If there is such an element, then the font information contained in that element is used in the Postscript. Otherwise Tk attempts to guess what Postscript font to use. Tk's guesses generally only work for well-known fonts such as Times and Helvetica and Courier, and only if the X font name does not omit any dashes up through the point size. For example, \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but \fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the dashes to parse the font name). :height size Specifies the height of the area of the canvas to print. Defaults to the height of the canvas window. :pageanchor anchor Specifies which point of the printed area should be appear over the positioning point on the page (which is given by the :pagex and :pagey options). For example, :pageanchor n means that the top center of the printed area should be over the positioning point. Defaults to center. :pageheight size Specifies that the Postscript should be scaled in both x and y so that the printed area is size high on the Postscript page. Size consists of a floating-point number followed by c for centimeters, i for inches, m for millimeters, or p or nothing for printer's points (1/72 inch). Defaults to the height of the printed area on the screen. If both :pageheight and :pagewidth are specified then the scale factor from the later option is used (non-uniform scaling is not implemented). :pagewidth size Specifies that the Postscript should be scaled in both x and y so that the printed area is size wide on the Postscript page. Size has the same form as for :pageheight. Defaults to the width of the printed area on the screen. If both :pageheight and :pagewidth are specified then the scale factor from the later option is used (non-uniform scaling is not implemented). :pagex position Position gives the x-coordinate of the positioning point on the Postscript page, using any of the forms allowed for :pageheight. Used in conjunction with the :pagey and :pageanchor options to determine where the printed area appears on the Postscript page. Defaults to the center of the page. :pagey position Position gives the y-coordinate of the positioning point on the Postscript page, using any of the forms allowed for :pageheight. Used in conjunction with the :pagex and :pageanchor options to determine where the printed area appears on the Postscript page. Defaults to the center of the page. :rotate boolean Boolean specifies whether the printed area is to be rotated 90 degrees. In non-rotated output the x-axis of the printed area runs along the short dimension of the page ("portrait" orientation); in rotated output the x-axis runs along the long dimension of the page ("landscape" orientation). Defaults to non-rotated. :width size Specifies the width of the area of the canvas to print. Defaults to the width of the canvas window. :x position Specifies the x-coordinate of the left edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the left edge of the window. :y position Specifies the y-coordinate of the top edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the top edge of the window. pathName :raise tagOrId ?aboveThis? Move all of the items given by tagOrId to a new position in the display list just after the item given by aboveThis. If tagOrId refers to more than one item then all are moved but the relative order of the moved items will not be changed. AboveThis is a tag or id; if it refers to more than one item then the last (topmost) of these items in the display list is used as the destination location for the moved items. This command returns an empty string. pathName :scale tagOrId xOrigin yOrigin xScale yScale Rescale all of the items given by tagOrId in canvas coordinate space. XOrigin and yOrigin identify the origin for the scaling operation and xScale and yScale identify the scale factors for x- and y-coordinates, respectively (a scale factor of 1.0 implies no change to that coordinate). For each of the points defining each item, the x-coordinate is adjusted to change the distance from xOrigin by a factor of xScale. Similarly, each y-coordinate is adjusted to change the distance from yOrigin by a factor of yScale. This command returns an empty string. pathName :scan option args This command is used to implement scanning on canvases. It has two forms, depending on option: pathName :scan :mark x y Records x and y and the canvas's current view; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget and x and y are the coordinates of the mouse. It returns an empty string. pathName :scan :dragto x y. This command computes the difference between its x and y arguments (which are typically mouse coordinates) and the x and y arguments to the last scan mark command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the canvas at high speed through its window. The return value is an empty string. pathName :select option ?tagOrId arg? Manipulates the selection in one of several ways, depending on option. The command may take any of the forms described below. In all of the descriptions below, tagOrId must refer to an item that supports indexing and selection; if it refers to multiple items then the first of these that supports indexing and the selection is used. Index gives a textual description of a position within tagOrId, as described in INDICES above. pathName :select :adjust tagOrId index Locate the end of the selection in tagOrId nearest to the character given by index, and adjust that end of the selection to be at index (i.e. including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn't currently in tagOrId then this command behaves the same as the select to widget command. Returns an empty string. pathName :select :clear Clear the selection if it is in this widget. If the selection isn't in this widget then the command has no effect. Returns an empty string. pathName :select :from tagOrId index Set the selection anchor point for the widget to be just before the character given by index in the item given by tagOrId. This command doesn't change the selection; it just sets the fixed end of the selection for future select to commands. Returns an empty string. pathName :select :item Returns the id of the selected item, if the selection is in an item in this canvas. If the selection is not in this canvas then an empty string is returned. pathName :select :to tagOrId index Set the selection to consist of those characters of tagOrId between the selection anchor point and index. The new selection will include the character given by index; it will include the character given by the anchor point only if index is greater than or equal to the anchor point. The anchor point is determined by the most recent select adjust or select from command for this widget. If the selection anchor point for the widget isn't currently in tagOrId, then it is set to the same character given by index. Returns an empty string. pathName :type tagOrId Returns the type of the item given by tagOrId, such as rectangle or text. If tagOrId refers to more than one item, then the type of the first item in the display list is returned. If tagOrId doesn't refer to any items at all then an empty string is returned. pathName :xview index Change the view in the canvas so that the canvas position given by index appears at the left edge of the window. This command is typically used by scrollbars to scroll the canvas. Index counts in units of scroll increments (the value of the scrollIncrement option): a value of 0 corresponds to the left edge of the scroll region (as defined by the scrollRegion option), a value of 1 means one scroll unit to the right of this, and so on. The return value is an empty string. pathName :yview index Change the view in the canvas so that the canvas position given by index appears at the top edge of the window. This command is typically used by scrollbars to scroll the canvas. Index counts in units of scroll increments (the value of the scrollIncrement option): a value of 0 corresponds to the top edge of the scroll region (as defined by the scrollRegion option), a value of 1 means one scroll unit below this, and so on. The return value is an empty string. Overview Of Item Types ---------------------- The sections below describe the various types of items supported by canvas widgets. Each item type is characterized by two things: first, the form of the create command used to create instances of the type; and second, a set of configuration options for items of that type, which may be used in the create and itemconfigure widget commands. Most items don't support indexing or selection or the commands related to them, such as index and insert. Where items do support these facilities, it is noted explicitly in the descriptions below (at present, only text items provide this support). Arc Items --------- Items of type arc appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the :start and :extent options) and displayed in one of several ways (specified by the :style option). Arcs are created with widget commands of the following form: pathName :create arc x1 y1 x2 y2 ?option value option value ...? The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for arcs: :extent degrees Specifies the size of the angular range occupied by the arc. The arc's range extends for degrees degrees counter-clockwise from the starting angle given by the :start option. Degrees may be negative. :fill color Fill the region of the arc with color. Color may have any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the arc will not be filled. :outline color Color specifies a color to use for drawing the arc's outline; it may have any of the forms accepted by Tk_GetColor. This option defaults to black. If the arc's style is arc then this option is ignored (the section of perimeter is filled using the :fill option). If color is specified as an empty string then no outline is drawn for the arc. :start degrees Specifies the beginning of the angular range occupied by the arc. Degrees is given in units of degrees measured counter-clockwise from the 3-o'clock position; it may be either positive or negative. :stipple bitmap Indicates that the arc should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn't been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion. :style type Specifies how to draw the arc. If type is pieslice (the default) then the arc's region is defined by a section of the oval's perimeter plus two line segments, one between the center of the oval and each end of the perimeter section. If type is chord then the arc's region is defined by a section of the oval's perimeter plus a single line segment connecting the two end points of the perimeter section. If type is arc then the arc's region consists of a section of the perimeter alone. In this last case there is no outline for the arc and the :outline option is ignored. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :width outlineWidth Specifies the width of the outline to be drawn around the arc's region, in any of the forms described in the COORDINATES section above. If the :outline option has been specified as an empty string then this option has no effect. Wide outlines will be drawn centered on the edges of the arc's region. This option defaults to 1.0. Bitmap Items ------------ Items of type bitmap appear on the display as images with two colors, foreground and background. Bitmaps are created with widget commands of the following form: pathName :create bitmap x y ?option value option value ...? The arguments x and y specify the coordinates of a point used to position the bitmap on the display (see the :anchor option below for more information on how bitmaps are displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for bitmaps: :anchor anchorPos AnchorPos tells how to position the bitmap relative to the positioning point for the item; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the bitmap is centered on the point; if anchorPos is n then the bitmap will be drawn so that its top center point is at the positioning point. This option defaults to center. :background color Specifies a color to use for each of the bitmap pixels whose value is 0. Color may have any of the forms accepted by Tk_GetColor. If this option isn't specified, or if it is specified as an empty string, then the background color for the canvas is used. :bitmap bitmap Specifies the bitmap to display in the item. Bitmap may have any of the forms accepted by Tk_GetBitmap. :foreground color Specifies a color to use for each of the bitmap pixels whose value is 1. Color may have any of the forms accepted by Tk_GetColor and defaults to black. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. Line Items ---------- Items of type line appear on the display as one or more connected line segments or curves. Lines are created with widget commands of the following form: pathName :create line x1 y1... xn yn ?option value option value ...? The arguments x1 through yn give the coordinates for a series of two or more points that describe a series of connected line segments. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for lines: :arrow where Indicates whether or not arrowheads are to be drawn at one or both ends of the line. Where must have one of the values none (for no arrowheads), first (for an arrowhead at the first point of the line), last (for an arrowhead at the last point of the line), or both (for arrowheads at both ends). This option defaults to none. :arrowshape shape This option indicates how to draw arrowheads. The shape argument must be a list with three elements, each specifying a distance in any of the forms described in the COORDINATES section above. The first element of the list gives the distance along the line from the neck of the arrowhead to its tip. The second element gives the distance along the line from the trailing points of the arrowhead to the tip, and the third element gives the distance from the outside edge of the line to the trailing points. If this option isn't specified then Tk picks a "reasonable" shape. :capstyle style Specifies the ways in which caps are to be drawn at the endpoints of the line. Style may have any of the forms accepted by Tk_GetCapStyle (butt, projecting, or round). If this option isn't specified then it defaults to butt. Where arrowheads are drawn the cap style is ignored. :fill color Color specifies a color to use for drawing the line; it may have any of the forms acceptable to Tk_GetColor. It may also be an empty string, in which case the line will be transparent. This option defaults to black. :joinstyle style Specifies the ways in which joints are to be drawn at the vertices of the line. Style may have any of the forms accepted by Tk_GetCapStyle (bevel, miter, or round). If this option isn't specified then it defaults to miter. If the line only contains two points then this option is irrelevant. :smooth boolean Boolean must have one of the forms accepted by Tk_GetBoolean. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of Bezier splines: one spline is drawn for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated within a curve by duplicating the end-points of the desired line segment. :splinesteps number Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the :smooth option is true. :stipple bitmap Indicates that the line should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default), then filling is done in a solid fashion. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :width lineWidth LineWidth specifies the width of the line, in any of the forms described in the COORDINATES section above. Wide lines will be drawn centered on the path specified by the points. If this option isn't specified then it defaults to 1.0. Oval Items ---------- Items of type oval appear as circular or oval regions on the display. Each oval may have an outline, a fill, or both. Ovals are created with widget commands of the following form: pathName :create oval x1 y1 x2 y2 ?option value option value ...? The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval. The oval will include the top and left edges of the rectangle not the lower or right edges. If the region is square then the resulting oval is circular; otherwise it is elongated in shape. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for ovals: :fill color Fill the area of the oval with color. Color may have any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the oval will not be filled. :outline color Color specifies a color to use for drawing the oval's outline; it may have any of the forms accepted by Tk_GetColor. This option defaults to black. If color is an empty string then no outline will be drawn for the oval. :stipple bitmap Indicates that the oval should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn't been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :width outlineWidth outlineWidth specifies the width of the outline to be drawn around the oval, in any of the forms described in the COORDINATES section above. If the :outline option hasn't been specified then this option has no effect. Wide outlines are drawn centered on the oval path defined by x1, y1, x2, and y2. This option defaults to 1.0. Polygon Items ------------- Items of type polygon appear as polygonal or curved filled regions on the display. Polygons are created with widget commands of the following form: pathName :create polygon x1 y1 ... xn yn ?option value option value ...? The arguments x1 through yn specify the coordinates for three or more points that define a closed polygon. The first and last points may be the same; whether they are or not, Tk will draw the polygon as a closed polygon. After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for polygons: :fill color Color specifies a color to use for filling the area of the polygon; it may have any of the forms acceptable to Tk_GetColor. If color is an empty string then the polygon will be transparent. This option defaults to black. :smooth boolean Boolean must have one of the forms accepted by Tk_GetBoolean It indicates whether or not the polygon should be drawn with a curved perimeter. If so, the outline of the polygon becomes a set of Bezier splines, one spline for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated in a smoothed polygon by duplicating the end-points of the desired line segment. :splinesteps number Specifies the degree of smoothness desired for curves: each spline will be approximated with number line segments. This option is ignored unless the :smooth option is true. :stipple bitmap Indicates that the polygon should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default), then filling is done in a solid fashion. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. Rectangle Items --------------- Items of type rectangle appear as rectangular regions on the display. Each rectangle may have an outline, a fill, or both. Rectangles are created with widget commands of the following form: pathName :create rectangle x1 y1 x2 y2 ?option value option value ...? The arguments x1, y1, x2, and y2 give the coordinates of two diagonally opposite corners of the rectangle (the rectangle will include its upper and left edges but not its lower or right edges). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for rectangles: :fill color Fill the area of the rectangle with color, which may be specified in any of the forms accepted by Tk_GetColor. If color is an empty string (the default), then then the rectangle will not be filled. :outline color Draw an outline around the edge of the rectangle in color. Color may have any of the forms accepted by Tk_GetColor. This option defaults to black. If color is an empty string then no outline will be drawn for the rectangle. :stipple bitmap Indicates that the rectangle should be filled in a stipple pattern; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If the :fill option hasn't been specified then this option has no effect. If bitmap is an empty string (the default), then filling is done in a solid fashion. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :width outlineWidth OutlineWidth specifies the width of the outline to be drawn around the rectangle, in any of the forms described in the COORDINATES section above. If the :outline option hasn't been specified then this option has no effect. Wide outlines are drawn centered on the rectangular path defined by x1, y1, x2, and y2. This option defaults to 1.0. Text Items ---------- A text item displays a string of characters on the screen in one or more lines. Text items support indexing and selection, along with the following text-related canvas widget commands: dchars, focus, icursor, index, insert, select. Text items are created with widget commands of the following form: pathName :create text x y ?option value option value ...? The arguments x and y specify the coordinates of a point used to position the text on the display (see the options below for more information on how text is displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for text items: :anchor anchorPos AnchorPos tells how to position the text relative to the positioning point for the text; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the text is centered on the point; if anchorPos is n then the text will be drawn such that the top center point of the rectangular region occupied by the text will be at the positioning point. This option defaults to center. :fill color Color specifies a color to use for filling the text characters; it may have any of the forms accepted by Tk_GetColor. If this option isn't specified then it defaults to black. :font fontName Specifies the font to use for the text item. FontName may be any string acceptable to Tk_GetFontStruct. If this option isn't specified, it defaults to a system-dependent font. :justify how Specifies how to justify the text within its bounding region. How must be one of the values left, right, or center. This option will only matter if the text is displayed as multiple lines. If the option is omitted, it defaults to left. :stipple bitmap Indicates that the text should be drawn in a stippled pattern rather than solid; bitmap specifies the stipple pattern to use, in any of the forms accepted by Tk_GetBitmap. If bitmap is an empty string (the default) then the text is drawn in a solid fashion. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :text string String specifies the characters to be displayed in the text item. Newline characters cause line breaks. The characters in the item may also be changed with the insert and delete widget commands. This option defaults to an empty string. :width lineLength Specifies a maximum line length for the text, in any of the forms described in the COORDINATES section abov. If this option is zero (the default) the text is broken into lines only at newline characters. However, if this option is non-zero then any line that would be longer than lineLength is broken just before a space character to make the line shorter than lineLength; the space character is treated as if it were a newline character. Window Items ------------ Items of type window cause a particular window to be displayed at a given position on the canvas. Window items are created with widget commands of the following form: pathName :create window x y ?option value option value ...? The arguments x and y specify the coordinates of a point used to position the window on the display (see the :anchor option below for more information on how bitmaps are displayed). After the coordinates there may be any number of option-value pairs, each of which sets one of the configuration options for the item. These same option\-value pairs may be used in itemconfigure widget commands to change the item's configuration. The following options are supported for window items: :anchor anchorPos AnchorPos tells how to position the window relative to the positioning point for the item; it may have any of the forms accepted by Tk_GetAnchor. For example, if anchorPos is center then the window is centered on the point; if anchorPos is n then the window will be drawn so that its top center point is at the positioning point. This option defaults to center. :height pixels Specifies the height to assign to the item's window. Pixels may have any of the forms described in the COORDINATES section above. If this option isn't specified, or if it is specified as an empty string, then the window is given whatever height it requests internally. :tags tagList Specifies a set of tags to apply to the item. TagList consists of a list of tag names, which replace any existing tags for the item. TagList may be an empty list. :width pixels Specifies the width to assign to the item's window. Pixels may have any of the forms described in the COORDINATES section above. If this option isn't specified, or if it is specified as an empty string, then the window is given whatever width it requests internally. :window pathName Specifies the window to associate with this item. The window specified by pathName must either be a child of the canvas widget or a child of some ancestor of the canvas widget. PathName may not refer to a top-level window. Application-Defined Item Types ------------------------------ It is possible for individual applications to define new item types for canvas widgets using C code. The interfaces for this mechanism are not presently documented, and it's possible they may change, but you should be able to see how they work by examining the code for some of the existing item types. Bindings -------- In the current implementation, new canvases are not given any default behavior: you'll have to execute explicit Tcl commands to give the canvas its behavior. Credits ------- Tk's canvas widget is a blatant ripoff of ideas from Joel Bartlett's ezd program. Ezd provides structured graphics in a Scheme environment and preceded canvases by a year or two. Its simple mechanisms for placing and animating graphical objects inspired the functions of canvases. Keywords -------- canvas, widget  File: gcl-tk.info, Node: menu, Next: scrollbar, Prev: canvas, Up: Widgets 2.5 menu ======== menu \- Create and manipulate menu widgets Synopsis -------- menu pathName ?options? Standard Options ---------------- activeBackground background disabledForeground activeBorderWidth borderWidth font activeForeground cursor foreground *Note options::, for more information. Arguments for Menu ------------------ ':postcommand' Name='"postCommand" Class="Command"' If this option is specified then it provides a Tcl command to execute each time the menu is posted. The command is invoked by the post widget command before posting the menu. ':selector' Name='"selector" Class="Foreground"' For menu entries that are check buttons or radio buttons, this option specifies the color to display in the selector when the check button or radio button is selected. Introduction ------------ The menu command creates a new top-level window (given by the pathName argument) and makes it into a menu widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menu such as its colors and font. The menu command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A menu is a widget that displays a collection of one-line entries arranged in a column. There exist several different types of entries, each with different properties. Entries of different types may be combined in a single menu. Menu entries are not the same as entry widgets. In fact, menu entries are not even distinct widgets; the entire menu is one widget. Menu entries are displayed with up to three separate fields. The main field is a label in the form of text or a bitmap, which is determined by the :label or :bitmap option for the entry. If the :accelerator option is specified for an entry then a second textual field is displayed to the right of the label. The accelerator typically describes a keystroke sequence that may be typed in the application to cause the same result as invoking the menu entry. The third field is a selector. The selector is present only for check-button or radio-button entries. It indicates whether the entry is selected or not, and is displayed to the left of the entry's string. In normal use, an entry becomes active (displays itself differently) whenever the mouse pointer is over the entry. If a mouse button is released over the entry then the entry is invoked. The effect of invocation is different for each type of entry; these effects are described below in the sections on individual entries. Entries may be disabled, which causes their labels and accelerators to be displayed with dimmer colors. A disabled entry cannot be activated or invoked. Disabled entries may be re-enabled, at which point it becomes possible to activate and invoke them again. Command Entries --------------- The most common kind of menu entry is a command entry, which behaves much like a button widget. When a command entry is invoked, a Tcl command is executed. The Tcl command is specified with the :command option. Separator Entries ----------------- A separator is an entry that is displayed as a horizontal dividing line. A separator may not be activated or invoked, and it has no behavior other than its display appearance. Check-Button Entries -------------------- A check-button menu entry behaves much like a check-button widget. When it is invoked it toggles back and forth between the selected and deselected states. When the entry is selected, a particular value is stored in a particular global variable (as determined by the :onvalue and :variable options for the entry); when the entry is deselected another value (determined by the :offvalue option) is stored in the global variable. A selector box is displayed to the left of the label in a check-button entry. If the entry is selected then the box's center is displayed in the color given by the selector option for the menu; otherwise the box's center is displayed in the background color for the menu. If a :command option is specified for a check-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after toggling the entry's selected state. Radio-Button Entries -------------------- A radio-button menu entry behaves much like a radio-button widget. Radio-button entries are organized in groups of which only one entry may be selected at a time. Whenever a particular entry becomes selected it stores a particular value into a particular global variable (as determined by the :value and :variable options for the entry). This action causes any previously-selected entry in the same group to deselect itself. Once an entry has become selected, any change to the entry's associated variable will cause the entry to deselect itself. Grouping of radio-button entries is determined by their associated variables: if two entries have the same associated variable then they are in the same group. A selector diamond is displayed to the left of the label in each radio-button entry. If the entry is selected then the diamond's center is displayed in the color given by the selector option for the menu; otherwise the diamond's center is displayed in the background color for the menu. If a :command option is specified for a radio-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after selecting the entry. Cascade Entries --------------- A cascade entry is one with an associated menu (determined by the :menu option). Cascade entries allow the construction of cascading menus. When the entry is activated, the associated menu is posted just to the right of the entry; that menu remains posted until the higher-level menu is unposted or until some other entry is activated in the higher-level menu. The associated menu should normally be a child of the menu containing the cascade entry, in order for menu traversal to work correctly. A cascade entry posts its associated menu by invoking a Tcl command of the form menu :post x y where menu is the path name of the associated menu, x and y are the root-window coordinates of the upper-right corner of the cascade entry, and group is the name of the menu's group (as determined in its last post widget command). The lower-level menu is unposted by executing a Tcl command with the form menu:unpost where menu is the name of the associated menu. If a :command option is specified for a cascade entry then it is evaluated as a Tcl command each time the associated menu is posted (the evaluation occurs before the menu is posted). A Menu Widget's Arguments ------------------------- The menu command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. Many of the widget commands for a menu take as one argument an indicator of which entry of the menu to operate on. These indicators are called indexes and may be specified in any of the following forms: number Specifies the entry numerically, where 0 corresponds to the top-most entry of the menu, 1 to the entry below it, and so on. active Indicates the entry that is currently active. If no entry is active then this form is equivalent to none. This form may not be abbreviated. last Indicates the bottommost entry in the menu. If there are no entries in the menu then this form is equivalent to none. This form may not be abbreviated. none Indicates "no entry at all"; this is used most commonly with the activate option to deactivate all the entries in the menu. In most cases the specification of none causes nothing to happen in the widget command. This form may not be abbreviated. @number In this form, number is treated as a y-coordinate in the menu's window; the entry spanning that y-coordinate is used. For example, "@0" indicates the top-most entry in the window. If number is outside the range of the window then this form is equivalent to none. pattern If the index doesn't satisfy one of the above forms then this form is used. Pattern is pattern-matched against the label of each entry in the menu, in order from the top down, until a matching entry is found. The rules of Tcl_StringMatch are used. The following widget commands are possible for menu widgets: pathName :activate index Change the state of the entry indicated by index to active and redisplay it using its active colors. Any previously-active entry is deactivated. If index is specified as none, or if the specified entry is disabled, then the menu ends up with no active entry. Returns an empty string. pathName :add type ?option value option value ...? Add a new entry to the bottom of the menu. The new entry's type is given by type and must be one of cascade, checkbutton, command, radiobutton, or separator, or a unique abbreviation of one of the above. If additional arguments are present, they specify any of the following options: :activebackground value Specifies a background color to use for displaying this entry when it is active. If this option is specified as an empty string (the default), then the activeBackground option for the overall menu is used. This option is not available for separator entries. :accelerator value Specifies a string to display at the right side of the menu entry. Normally describes an accelerator keystroke sequence that may be typed to invoke the same function as the menu entry. This option is not available for separator entries. :background value Specifies a background color to use for displaying this entry when it is in the normal state (neither active nor disabled). If this option is specified as an empty string (the default), then the background option for the overall menu is used. This option is not available for separator entries. :bitmap value Specifies a bitmap to display in the menu instead of a textual label, in any of the forms accepted by Tk_GetBitmap. This option overrides the :label option but may be reset to an empty string to enable a textual label to be displayed. This option is not available for separator entries. :command value For command, checkbutton, and radiobutton entries, specifies a Tcl command to execute when the menu entry is invoked. For cascade entries, specifies a Tcl command to execute when the entry is activated (i.e. just before its submenu is posted). Not available for separator entries. :font value Specifies the font to use when drawing the label or accelerator string in this entry. If this option is specified as an empty string (the default) then the font option for the overall menu is used. This option is not available for separator entries. :label value Specifies a string to display as an identifying label in the menu entry. Not available for separator entries. :menu value Available only for cascade entries. Specifies the path name of the menu associated with this entry. :offvalue value Available only for check-button entries. Specifies the value to store in the entry's associated variable when the entry is deselected. :onvalue value Available only for check-button entries. Specifies the value to store in the entry's associated variable when the entry is selected. :state value Specifies one of three states for the entry: normal, active, or disabled. In normal state the entry is displayed using the foreground option for the menu and the background option from the entry or the menu. The active state is typically used when the pointer is over the entry. In active state the entry is displayed using the activeForeground option for the menu along with the activebackground option from the entry. Disabled state means that the entry is insensitive: it doesn't activate and doesn't respond to mouse button presses or releases. In this state the entry is displayed according to the disabledForeground option for the menu and the background option from the entry. This option is not available for separator entries. :underline value Specifies the integer index of a character to underline in the entry. This option is typically used to indicate keyboard traversal characters. 0 corresponds to the first character of the text displayed in the entry, 1 to the next character, and so on. If a bitmap is displayed in the entry then this option is ignored. This option is not available for separator entries. :value value Available only for radio-button entries. Specifies the value to store in the entry's associated variable when the entry is selected. :variable value Available only for check-button and radio-button entries. Specifies the name of a global value to set when the entry is selected. For check-button entries the variable is also set when the entry is deselected. For radio-button entries, changing the variable causes the currently-selected entry to deselect itself. The add widget command returns an empty string. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the menu command. pathName :delete index1 ?index2? Delete all of the menu entries between index1 and index2 inclusive. If index2 is omitted then it defaults to index1. Returns an empty string. pathName :disable index Change the state of the entry given by index to disabled and redisplay the entry using its disabled colors. Returns an empty string. This command is obsolete and will eventually be removed; use "pathName :entryconfigure index :state disabled" instead. pathName :enable index Change the state of the entry given by index to normal and redisplay the entry using its normal colors. Returns an empty string. This command is obsolete and will eventually be removed; use "pathName :entryconfigure index :state normal" instead. pathName :entryconfigure index ?options? This command is similar to the configure command, except that it applies to the options for an individual entry, whereas configure applies to the options for the menu as a whole. Options may have any of the values accepted by the add widget command. If options are specified, options are modified as indicated in the command and the command returns an empty string. If no options are specified, returns a list describing the current options for entry index (see Tk_ConfigureInfo for information on the format of this list). pathName :index index Returns the numerical index corresponding to index, or none if index was specified as none. pathName :invoke index Invoke the action of the menu entry. See the sections on the individual entries above for details on what happens. If the menu entry is disabled then nothing happens. If the entry has a command associated with it then the result of that command is returned as the result of the invoke widget command. Otherwise the result is an empty string. Note: invoking a menu entry does not automatically unpost the menu. Normally the associated menubutton will take care of unposting the menu. pathName :post x y Arrange for the menu to be displayed on the screen at the root-window coordinates given by x and y. These coordinates are adjusted if necessary to guarantee that the entire menu is visible on the screen. This command normally returns an empty string. If the :postcommand option has been specified, then its value is executed as a Tcl script before posting the menu and the result of that script is returned as the result of the post widget command. If an error returns while executing the command, then the error is returned without posting the menu. pathName :unpost Unmap the window so that it is no longer displayed. If a lower-level cascaded menu is posted, unpost that menu. Returns an empty string. pathName :yposition index Returns a decimal string giving the y-coordinate within the menu window of the topmost pixel in the entry specified by index. Default Bindings ---------------- Tk automatically creates class bindings for menus that give them the following default behavior: [1] When the mouse cursor enters a menu, the entry underneath the mouse cursor is activated; as the mouse moves around the menu, the active entry changes to track the mouse. [2] When button 1 is released over a menu, the active entry (if any) is invoked. [3] A menu can be repositioned on the screen by dragging it with mouse button 2. [4] A number of other bindings are created to support keyboard menu traversal. See the manual entry for tk_bindForTraversal for details on these bindings. Disabled menu entries are non-responsive: they don't activate and ignore mouse button presses and releases. The behavior of menus can be changed by defining new bindings for individual widgets or by redefining the class bindings. Bugs ---- At present it isn't possible to use the option database to specify values for the options to individual entries. Keywords -------- menu, widget  File: gcl-tk.info, Node: scrollbar, Next: checkbutton, Prev: menu, Up: Widgets 2.6 scrollbar ============= scrollbar \- Create and manipulate scrollbar widgets Synopsis -------- scrollbar pathName ?options? Standard Options ---------------- activeForeground cursor relief background foreground repeatDelay borderWidth orient repeatInterval *Note options::, for more information. Arguments for Scrollbar ----------------------- ':command' Name='"command" Class="Command"' Specifies the prefix of a Tcl command to invoke to change the view in the widget associated with the scrollbar. When a user requests a view change by manipulating the scrollbar, a Tcl command is invoked. The actual command consists of this option followed by a space and a number. The number indicates the logical unit that should appear at the top of the associated window. ':width' Name='"width" Class="Width"' Specifies the desired narrow dimension of the scrollbar window, not including 3-D border, if any. For vertical scrollbars this will be the width and for horizontal scrollbars this will be the height. The value may have any of the forms acceptable to Tk_GetPixels. Description ----------- The scrollbar command creates a new window (given by the pathName argument) and makes it into a scrollbar widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scrollbar such as its colors, orientation, and relief. The scrollbar command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A scrollbar is a widget that displays two arrows, one at each end of the scrollbar, and a slider in the middle portion of the scrollbar. A scrollbar is used to provide information about what is visible in an associated window that displays an object of some sort (such as a file being edited or a drawing). The position and size of the slider indicate which portion of the object is visible in the associated window. For example, if the slider in a vertical scrollbar covers the top third of the area between the two arrows, it means that the associated window displays the top third of its object. Scrollbars can be used to adjust the view in the associated window by clicking or dragging with the mouse. See the BINDINGS section below for details. A Scrollbar Widget's Arguments ------------------------------ The scrollbar command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for scrollbar widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the scrollbar command. pathName :get Returns a Tcl list containing four decimal values, which are the current totalUnits, widnowUnits, firstUnit, and lastUnit values for the scrollbar. These are the values from the most recent set widget command on the scrollbar. pathName :set totalUnits windowUnits firstUnit lastUnit This command is invoked to give the scrollbar information about the widget associated with the scrollbar. TotalUnits is an integer value giving the total size of the object being displayed in the associated widget. The meaning of one unit depends on the associated widget; for example, in a text editor widget units might correspond to lines of text. WindowUnits indicates the total number of units that can fit in the associated window at one time. FirstUnit and lastUnit give the indices of the first and last units currently visible in the associated window (zero corresponds to the first unit of the object). This command should be invoked by the associated widget whenever its object or window changes size and whenever it changes the view in its window. Bindings -------- The description below assumes a vertically-oriented scrollbar. For a horizontally-oriented scrollbar replace the words "up", "down", "top", and "bottom" with "left", "right", "left", and "right", respectively A scrollbar widget is divided into five distinct areas. From top to bottom, they are: the top arrow, the top gap (the empty space between the arrow and the slider), the slider, the bottom gap, and the bottom arrow. Pressing mouse button 1 in each area has a different effect: top arrow Causes the view in the associated window to shift up by one unit (i.e. the object appears to move down one unit in its window). If the button is held down the action will auto-repeat. top gap Causes the view in the associated window to shift up by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very top of the window will now appear at the very bottom). If the button is held down the action will auto-repeat. slider Pressing button 1 in this area has no immediate effect except to cause the slider to appear sunken rather than raised. However, if the mouse is moved with the button down then the slider will be dragged, adjusting the view as the mouse is moved. bottom gap Causes the view in the associated window to shift down by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very bottom of the window will now appear at the very top). If the button is held down the action will auto-repeat. bottom arrow Causes the view in the associated window to shift down by one unit (i.e. the object appears to move up one unit in its window). If the button is held down the action will auto-repeat. Note: none of the actions described above has an immediate impact on the position of the slider in the scrollbar. It simply invokes the command specified in the command option to notify the associated widget that a change in view is desired. If the view is actually changed then the associated widget must invoke the scrollbar's set widget command to change what is displayed in the scrollbar. Keywords -------- scrollbar, widget  File: gcl-tk.info, Node: checkbutton, Next: menubutton, Prev: scrollbar, Up: Widgets 2.7 checkbutton =============== checkbutton \- Create and manipulate check-button widgets Synopsis -------- checkbutton pathName ?options? Standard Options ---------------- activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY *Note options::, for more information. Arguments for Checkbutton ------------------------- ':command' Name='"command" Class="Command"' Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button's global variable (:variable option) will be updated before the command is invoked. ':height' Name='"height" Class="Height"' Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. ':offvalue' Name='"offValue" Class="Value"' Specifies value to store in the button's associated variable whenever this button is deselected. Defaults to "0". ':onvalue' Name='"onValue" Class="Value"' Specifies value to store in the button's associated variable whenever this button is selected. Defaults to "1". ':selector' Name='"selector" Class="Foreground"' Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button. ':state' Name='"state" Class="State"' Specifies one of three states for the check button: normal, active, or disabled. In normal state the check button is displayed using the foreground and background options. The active state is typically used when the pointer is over the check button. In active state the check button is displayed using the activeForeground and activeBackground options. Disabled state means that the check button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the disabledForeground and background options determine how the check button is displayed. ':variable' Name='"variable" Class="Variable"' Specifies name of global variable to set to indicate whether or not this button is selected. Defaults to the name of the button within its parent (i.e. the last element of the button window's path name). ':width' Name='"width" Class="Width"' Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. Description ----------- The checkbutton command creates a new window (given by the pathName argument) and makes it into a check-button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the check button such as its colors, font, text, and initial relief. The checkbutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A check button is a widget that displays a textual string or bitmap and a square called a selector. A check button has all of the behavior of a simple button, including the following: it can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button. In addition, check buttons can be selected. If a check button is selected then a special highlight appears in the selector, and a Tcl variable associated with the check button is set to a particular value (normally 1). If the check button is not selected, then the selector is drawn in a different fashion and the associated variable is set to a different value (typically 0). By default, the name of the variable associated with a check button is the same as the name used to create the check button. The variable name, and the "on" and "off" values stored in it, may be modified with options on the command line or in the option database. By default a check button is configured to select and deselect itself on alternate button clicks. In addition, each check button monitors its associated variable and automatically selects and deselects itself when the variables value changes to and from the button's "on" value. A Checkbutton Widget's Arguments -------------------------------- The checkbutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for check button widgets: pathName :activate Change the check button's state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the check button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state active" instead. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the checkbutton command. pathName :deactivate Change the check button's state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the check button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state normal" instead. pathName :deselect Deselect the check button: redisplay it without a highlight in the selector and set the associated variable to its "off" value. pathName :flash Flash the check button. This is accomplished by redisplaying the check button several times, alternating between active and normal colors. At the end of the flash the check button is left in the same normal/active state as when the command was invoked. This command is ignored if the check button's state is disabled. pathName :invoke Does just what would have happened if the user invoked the check button with the mouse: toggle the selection state of the button and invoke the Tcl command associated with the check button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the check button. This command is ignored if the check button's state is disabled. pathName :select Select the check button: display it with a highlighted selector and set the associated variable to its "on" value. pathName :toggle Toggle the selection state of the button, redisplaying it and modifying its associated variable to reflect the new state. Bindings -------- Tk automatically creates class bindings for check buttons that give them the following default behavior: [1] The check button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the check button. [2] The check button's relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released. [3] If mouse button 1 is pressed over the check button and later released over the check button, the check button is invoked (i.e. its selection state toggles and the command associated with the button is invoked, if there is one). However, if the mouse is not over the check button when button 1 is released, then no invocation occurs. If the check button's state is disabled then none of the above actions occur: the check button is completely non-responsive. The behavior of check buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. Keywords -------- check button, widget  File: gcl-tk.info, Node: menubutton, Next: text, Prev: checkbutton, Up: Widgets 2.8 menubutton ============== menubutton \- Create and manipulate menubutton widgets Synopsis -------- menubutton pathName ?options? Standard Options ---------------- activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY underline *Note options::, for more information. Arguments for Menubutton ------------------------ ':height' Name='"height" Class="Height"' Specifies a desired height for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the menu button's desired height is computed from the size of the bitmap or text being displayed in it. ':menu' Name='"menu" Class="MenuName"' Specifies the path name of the menu associated with this menubutton. The menu must be a descendant of the menubutton in order for normal pull-down operation to work via the mouse. ':state' Name='"state" Class="State"' Specifies one of three states for the menu button: normal, active, or disabled. In normal state the menu button is displayed using the foreground and background options. The active state is typically used when the pointer is over the menu button. In active state the menu button is displayed using the activeForeground and activeBackground options. Disabled state means that the menu button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the disabledForeground and background options determine how the button is displayed. ':width' Name='"width" Class="Width"' Specifies a desired width for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn't specified, the menu button's desired width is computed from the size of the bitmap or text being displayed in it. Introduction ------------ The menubutton command creates a new window (given by the pathName argument) and makes it into a menubutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menubutton such as its colors, font, text, and initial relief. The menubutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A menubutton is a widget that displays a textual string or bitmap and is associated with a menu widget. In normal usage, pressing mouse button 1 over the menubutton causes the associated menu to be posted just underneath the menubutton. If the mouse is moved over the menu before releasing the mouse button, the button release causes the underlying menu entry to be invoked. When the button is released, the menu is unposted. Menubuttons are typically organized into groups called menu bars that allow scanning: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. The tk-menu-bar procedure is used to set up menu bars for scanning; see that procedure for more details. A Menubutton Widget's Arguments ------------------------------- The menubutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for menubutton widgets: pathName :activate Change the menu button's state to active and redisplay the menu button using its active foreground and background colors instead of normal colors. The command returns an empty string. This command is ignored if the menu button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state active" instead. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the menubutton command. pathName :deactivate Change the menu button's state to normal and redisplay the menu button using its normal foreground and background colors. The command returns an empty string. This command is ignored if the menu button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state normal" instead. "Default Bindings" ------------------ Tk automatically creates class bindings for menu buttons that give them the following default behavior: [1] A menu button activates whenever the mouse passes over it and deactivates whenever the mouse leaves it. [2] A menu button's relief is changed to raised whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released or the mouse is dragged into another menu button in the same menu bar. [3] When mouse button 1 is pressed over a menu button, or when the mouse is dragged into a menu button with mouse button 1 pressed, the associated menu is posted; the mouse can be dragged across the menu and released over an entry in the menu to invoke that entry. The menu is unposted when button 1 is released outside either the menu or the menu button. The menu is also unposted when the mouse is dragged into another menu button in the same menu bar. [4] If mouse button 1 is pressed and released within the menu button, then the menu stays posted and keyboard traversal is possible as described in the manual entry for tk-menu-bar. [5] Menubuttons may also be posted by typing characters on the keyboard. See the manual entry for tk-menu-bar for full details on keyboard menu traversal. [6] If mouse button 2 is pressed over a menu button then the associated menu is posted and also torn off: it can then be dragged around on the screen with button 2 and the menu will not automatically unpost when entries in it are invoked. To close a torn off menu, click mouse button 1 over the associated menu button. If the menu button's state is disabled then none of the above actions occur: the menu button is completely non-responsive. The behavior of menu buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. Keywords -------- menubutton, widget  File: gcl-tk.info, Node: text, Next: entry, Prev: menubutton, Up: Widgets 2.9 text ======== text \- Create and manipulate text widgets Synopsis -------- text pathName ?options? Standard Options ---------------- background foreground insertWidth selectBorderWidth borderWidth insertBackground padX selectForeground cursor insertBorderWidth padY setGrid exportSelection insertOffTime relief yScrollCommand font insertOnTime selectBackground *Note options::, for more information. Arguments for Text ------------------ ':height' Name='"height" Class="Height"' Specifies the desired height for the window, in units of characters. Must be at least one. ':state' Name='"state" Class="State"' Specifies one of two states for the text: normal or disabled. If the text is disabled then characters may not be inserted or deleted and no insertion cursor will be displayed, even if the input focus is in the widget. ':width' Name='"width" Class="Width"' Specifies the desired width for the window in units of characters. If the font doesn't have a uniform width then the width of the character "0" is used in translating from character units to screen units. ':wrap' Name='"wrap" Class="Wrap"' Specifies how to handle lines in the text that are too long to be displayed in a single line of the text's window. The value must be none or char or word. A wrap mode of none means that each line of text appears as exactly one line on the screen; extra characters that don't fit on the screen are not displayed. In the other modes each line of text will be broken up into several screen lines if necessary to keep all the characters visible. In char mode a screen line break may occur after any character; in word mode a line break will only be made at word boundaries. Description ----------- The text command creates a new window (given by the pathName argument) and makes it into a text widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the text such as its default background color and relief. The text command returns the path name of the new window. A text widget displays one or more lines of text and allows that text to be edited. Text widgets support three different kinds of annotations on the text, called tags, marks, and windows. Tags allow different portions of the text to be displayed with different fonts and colors. In addition, Tcl commands can be associated with tags so that commands are invoked when particular actions such as keystrokes and mouse button presses occur in particular ranges of the text. See TAGS below for more details. The second form of annotation consists of marks, which are floating markers in the text. Marks are used to keep track of various interesting positions in the text as it is edited. See MARKS below for more details. The third form of annotation allows arbitrary windows to be displayed in the text widget. See WINDOWS below for more details. Indices ------- Many of the widget commands for texts take one or more indices as arguments. An index is a string used to indicate a particular place within a text, such as a place to insert characters or one endpoint of a range of characters to delete. Indices have the syntax base modifier modifier modifier ... Where base gives a starting point and the modifiers adjust the index from the starting point (e.g. move forward or backward one character). Every index must contain a base, but the modifiers are optional. The base for an index must have one of the following forms: line.char Indicates char'th character on line line. Lines are numbered from 1 for consistency with other UNIX programs that use this numbering scheme. Within a line, characters are numbered from 0. @x,y Indicates the character that covers the pixel whose x and y coordinates within the text's window are x and y. end Indicates the last character in the text, which is always a newline character. mark Indicates the character just after the mark whose name is mark. tag.first Indicates the first character in the text that has been tagged with tag. This form generates an error if no characters are currently tagged with tag. tag.last Indicates the character just after the last one in the text that has been tagged with tag. This form generates an error if no characters are currently tagged with tag. If modifiers follow the base index, each one of them must have one of the forms listed below. Keywords such as chars and wordend may be abbreviated as long as the abbreviation is unambiguous. + count chars Adjust the index forward by count characters, moving to later lines in the text if necessary. If there are fewer than count characters in the text after the current index, then set the index to the last character in the text. Spaces on either side of count are optional. - count chars Adjust the index backward by count characters, moving to earlier lines in the text if necessary. If there are fewer than count characters in the text before the current index, then set the index to the first character in the text. Spaces on either side of count are optional. + count lines Adjust the index forward by count lines, retaining the same character position within the line. If there are fewer than count lines after the line containing the current index, then set the index to refer to the same character position on the last line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of count are optional. - count lines Adjust the index backward by count lines, retaining the same character position within the line. If there are fewer than count lines before the line containing the current index, then set the index to refer to the same character position on the first line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of count are optional. linestart Adjust the index to refer to the first character on the line. lineend Adjust the index to refer to the last character on the line (the newline). wordstart Adjust the index to refer to the first character of the word containing the current index. A word consists of any number of adjacent characters that are letters, digits, or underscores, or a single character that is not one of these. wordend Adjust the index to refer to the character just after the last one of the word containing the current index. If the current index refers to the last character of the text then it is not modified. If more than one modifier is present then they are applied in left-to-right order. For example, the index "\fBend \- 1 chars" refers to the next-to-last character in the text and "\fBinsert wordstart \- 1 c" refers to the character just before the first one in the word containing the insertion cursor. Tags ---- The first form of annotation in text widgets is a tag. A tag is a textual string that is associated with some of the characters in a text. There may be any number of tags associated with characters in a text. Each tag may refer to a single character, a range of characters, or several ranges of characters. An individual character may have any number of tags associated with it. A priority order is defined among tags, and this order is used in implementing some of the tag-related functions described below. When a tag is defined (by associating it with characters or setting its display options or binding commands to it), it is given a priority higher than any existing tag. The priority order of tags may be redefined using the "pathName :tag :raise" and "pathName :tag :lower" widget commands. Tags serve three purposes in text widgets. First, they control the way information is displayed on the screen. By default, characters are displayed as determined by the background, font, and foreground options for the text widget. However, display options may be associated with individual tags using the "pathName :tag configure" widget command. If a character has been tagged, then the display options associated with the tag override the default display style. The following options are currently supported for tags: :background color Color specifies the background color to use for characters associated with the tag. It may have any of the forms accepted by Tk_GetColor. :bgstipple bitmap Bitmap specifies a bitmap that is used as a stipple pattern for the background. It may have any of the forms accepted by Tk_GetBitmap. If bitmap hasn't been specified, or if it is specified as an empty string, then a solid fill will be used for the background. :borderwidth pixels Pixels specifies the width of a 3-D border to draw around the background. It may have any of the forms accepted by Tk_GetPixels. This option is used in conjunction with the :relief option to give a 3-D appearance to the background for characters; it is ignored unless the :background option has been set for the tag. :fgstipple bitmap Bitmap specifies a bitmap that is used as a stipple pattern when drawing text and other foreground information such as underlines. It may have any of the forms accepted by Tk_GetBitmap. If bitmap hasn't been specified, or if it is specified as an empty string, then a solid fill will be used. :font fontName FontName is the name of a font to use for drawing characters. It may have any of the forms accepted by Tk_GetFontStruct. :foreground color Color specifies the color to use when drawing text and other foreground information such as underlines. It may have any of the forms accepted by Tk_GetColor. :relief relief \fIRelief specifies the 3-D relief to use for drawing backgrounds, in any of the forms accepted by Tk_GetRelief. This option is used in conjunction with the :borderwidth option to give a 3-D appearance to the background for characters; it is ignored unless the :background option has been set for the tag. :underline boolean Boolean specifies whether or not to draw an underline underneath characters. It may have any of the forms accepted by Tk_GetBoolean. If a character has several tags associated with it, and if their display options conflict, then the options of the highest priority tag are used. If a particular display option hasn't been specified for a particular tag, or if it is specified as an empty string, then that option will never be used; the next-highest-priority tag's option will used instead. If no tag specifies a particular display optionl, then the default style for the widget will be used. The second purpose for tags is event bindings. You can associate bindings with a tag in much the same way you can associate bindings with a widget class: whenever particular X events occur on characters with the given tag, a given Tcl command will be executed. Tag bindings can be used to give behaviors to ranges of characters; among other things, this allows hypertext-like features to be implemented. For details, see the description of the tag bind widget command below. The third use for tags is in managing the selection. See THE SELECTION below. Marks ----- The second form of annotation in text widgets is a mark. Marks are used for remembering particular places in a text. They are something like tags, in that they have names and they refer to places in the file, but a mark isn't associated with particular characters. Instead, a mark is associated with the gap between two characters. Only a single position may be associated with a mark at any given time. If the characters around a mark are deleted the mark will still remain; it will just have new neighbor characters. In contrast, if the characters containing a tag are deleted then the tag will no longer have an association with characters in the file. Marks may be manipulated with the "pathName :mark" widget command, and their current locations may be determined by using the mark name as an index in widget commands. The name space for marks is different from that for tags: the same name may be used for both a mark and a tag, but they will refer to different things. Two marks have special significance. First, the mark insert is associated with the insertion cursor, as described under THE INSERTION CURSOR below. Second, the mark current is associated with the character closest to the mouse and is adjusted automatically to track the mouse position and any changes to the text in the widget (one exception: current is not updated in response to mouse motions if a mouse button is down; the update will be deferred until all mouse buttons have been released). Neither of these special marks may be unset. Windows ------- The third form of annotation in text widgets is a window. Window support isn't implemented yet, but when it is it will be described here. The Selection ------------- Text widgets support the standard X selection. Selection support is implemented via tags. If the exportSelection option for the text widget is true then the sel tag will be associated with the selection: [1] Whenever characters are tagged with sel the text widget will claim ownership of the selection. [2] Attempts to retrieve the selection will be serviced by the text widget, returning all the charaters with the sel tag. [3] If the selection is claimed away by another application or by another window within this application, then the sel tag will be removed from all characters in the text. The sel tag is automatically defined when a text widget is created, and it may not be deleted with the "pathName :tag delete" widget command. Furthermore, the selectBackground, selectBorderWidth, and selectForeground options for the text widget are tied to the :background, :borderwidth, and :foreground options for the sel tag: changes in either will automatically be reflected in the other. The Insertion Cursor -------------------- The mark named insert has special significance in text widgets. It is defined automatically when a text widget is created and it may not be unset with the "pathName :mark unset" widget command. The insert mark represents the position of the insertion cursor, and the insertion cursor will automatically be drawn at this point whenever the text widget has the input focus. A Text Widget's Arguments ------------------------- The text command creates a new Tcl command whose name is the same as the path name of the text's window. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? PathName is the name of the command, which is the same as the text widget's path name. Option and the args determine the exact behavior of the command. The following commands are possible for text widgets: pathName :compare index1 op index2 Compares the indices given by index1 and index2 according to the relational operator given by op, and returns 1 if the relationship is satisfied and 0 if it isn't. Op must be one of the operators <, <=, ==, >=, >, or !=. If op is == then 1 is returned if the two indices refer to the same character, if op is < then 1 is returned if index1 refers to an earlier character in the text than index2, and so on. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the text command. pathName :debug ?boolean? If boolean is specified, then it must have one of the true or false values accepted by Tcl_GetBoolean. If the value is a true one then internal consistency checks will be turned on in the B-tree code associated with text widgets. If boolean has a false value then the debugging checks will be turned off. In either case the command returns an empty string. If boolean is not specified then the command returns on or off to indicate whether or not debugging is turned on. There is a single debugging switch shared by all text widgets: turning debugging on or off in any widget turns it on or off for all widgets. For widgets with large amounts of text, the consistency checks may cause a noticeable slow-down. pathName :delete index1 ?index2? Delete a range of characters from the text. If both index1 and index2 are specified, then delete all the characters starting with the one given by index1 and stopping just before index2 (i.e. the character at index2 is not deleted). If index2 doesn't specify a position later in the text than index1 then no characters are deleted. If index2 isn't specified then the single character at index1 is deleted. It is not allowable to delete characters in a way that would leave the text without a newline as the last character. The command returns an empty string. pathName :get index1 ?index2? Return a range of characters from the text. The return value will be all the characters in the text starting with the one whose index is index1 and ending just before the one whose index is index2 (the character at index2 will not be returned). If index2 is omitted then the single character at index1 is returned. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then an empty string is returned. pathName :index index Returns the position corresponding to index in the form line.char where line is the line number and char is the character number. Index may have any of the forms described under INDICES above. pathName :insert \fIindex chars Inserts chars into the text just before the character at index and returns an empty string. It is not possible to insert characters after the last newline of the text. pathName :mark option ?arg arg ...? This command is used to manipulate marks. The exact behavior of the command depends on the option argument that follows the mark argument. The following forms of the command are currently supported: pathName :mark :names Returns a list whose elements are the names of all the marks that are currently set. pathName :mark :set markName index Sets the mark named markName to a position just before the character at index. If markName already exists, it is moved from its old position; if it doesn't exist, a new mark is created. This command returns an empty string. pathName :mark :unset markName ?markName markName ...? Remove the mark corresponding to each of the markName arguments. The removed marks will not be usable in indices and will not be returned by future calls to "pathName :mark names". This command returns an empty string. pathName :scan option args This command is used to implement scanning on texts. It has two forms, depending on option: pathName :scan :mark y Records y and the current view in the text window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. pathName :scan :dragto y This command computes the difference between its y argument and the y argument to the last scan mark command for the widget. It then adjusts the view up or down by 10 times the difference in y-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the text at high speed through the window. The return value is an empty string. pathName :tag option ?arg arg ...? This command is used to manipulate tags. The exact behavior of the command depends on the option argument that follows the tag argument. The following forms of the command are currently supported: pathName :tag :add tagName index1 ?index2? Associate the tag tagName with all of the characters starting with index1 and ending just before index2 (the character at index2 isn't tagged). If index2 is omitted then the single character at index1 is tagged. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then the command has no effect. This command returns an empty string. pathName :tag :bind tagName ?sequence? ?command? This command associates command with the tag given by tagName. Whenever the event sequence given by sequence occurs for a character that has been tagged with tagName, the command will be invoked. This widget command is similar to the bind command except that it operates on characters in a text rather than entire widgets. See the bind manual entry for complete details on the syntax of sequence and the substitutions performed on command before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same sequence and tagName (if the first character of command is "+" then command augments an existing binding rather than replacing it). In this case the return value is an empty string. If command is omitted then the command returns the command associated with tagName and sequence (an error occurs if there is no such binding). If both command and sequence are omitted then the command returns a list of all the sequences for which bindings have been defined for tagName. The only events for which bindings may be specified are those related to the mouse and keyboard, such as Enter, Leave, ButtonPress, Motion, and KeyPress. Event bindings for a text widget use the current mark described under MARKS above. Enter events trigger for a character when it becomes the current character (i.e. the current mark moves to just in front of that character). Leave events trigger for a character when it ceases to be the current item (i.e. the current mark moves away from that character, or the character is deleted). These events are different than Enter and Leave events for windows. Mouse and keyboard events are directed to the current character. It is possible for the current character to have multiple tags, and for each of them to have a binding for a particular event sequence. When this occurs, the binding from the highest priority tag is used. If a particular tag doesn't have a binding that matches an event, then the tag is ignored and tags with lower priority will be checked. If bindings are created for the widget as a whole using the bind command, then those bindings will supplement the tag bindings. This means that a single event can trigger two Tcl scripts, one for a widget-level binding and one for a tag-level binding. pathName :tag :configure tagName ?option? ?value? ?option value ...? This command is similar to the configure widget command except that it modifies options associated with the tag given by tagName instead of modifying options for the overall text widget. If no option is specified, the command returns a list describing all of the available options for tagName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given option(s) to have the given value(s) in tagName; in this case the command returns an empty string. See TAGS above for details on the options available for tags. pathName :tag :delete tagName ?tagName ...? Deletes all tag information for each of the tagName arguments. The command removes the tags from all characters in the file and also deletes any other information associated with the tags, such as bindings and display information. The command returns an empty string. pathName :tag :lower tagName ?belowThis? Changes the priority of tag tagName so that it is just lower in priority than the tag whose name is belowThis. If belowThis is omitted, then tagName's priority is changed to make it lowest priority of all tags. pathName :tag :names ?index? Returns a list whose elements are the names of all the tags that are active at the character position given by index. If index is omitted, then the return value will describe all of the tags that exist for the text (this includes all tags that have been named in a "pathName :tag" widget command but haven't been deleted by a "pathName :tag :delete" widget command, even if no characters are currently marked with the tag). The list will be sorted in order from lowest priority to highest priority. pathName :tag :nextrange tagName index1 ?index2? This command searches the text for a range of characters tagged with tagName where the first character of the range is no earlier than the character at index1 and no later than the character just before index2 (a range starting at index2 will not be considered). If several matching ranges exist, the first one is chosen. The command's return value is a list containing two elements, which are the index of the first character of the range and the index of the character just after the last one in the range. If no matching range is found then the return value is an empty string. If index2 is not given then it defaults to the end of the text. pathName :tag :raise tagName ?aboveThis? Changes the priority of tag tagName so that it is just higher in priority than the tag whose name is aboveThis. If aboveThis is omitted, then tagName's priority is changed to make it highest priority of all tags. pathName :tag :ranges tagName Returns a list describing all of the ranges of text that have been tagged with tagName. The first two elements of the list describe the first tagged range in the text, the next two elements describe the second range, and so on. The first element of each pair contains the index of the first character of the range, and the second element of the pair contains the index of the character just after the last one in the range. If there are no characters tagged with tag then an empty string is returned. pathName :tag :remove tagName index1 ?index2? Remove the tag tagName from all of the characters starting at index1 and ending just before index2 (the character at index2 isn't affected). If index2 is omitted then the single character at index1 is untagged. If there are no characters in the specified range (e.g. index1 is past the end of the file or index2 is less than or equal to index1) then the command has no effect. This command returns an empty string. pathName :yview ?:pickplace? what This command changes the view in the widget's window so that the line given by what is visible in the window. What may be either an absolute line number, where 0 corresponds to the first line of the file, or an index with any of the forms described under INDICES above. The first form (absolute line number) is used in the commands issued by scrollbars to control the widget's view. If the :pickplace option isn't specified then what will appear at the top of the window. If :pickplace is specified then the widget chooses where what appears in the window: [1] If what is already visible somewhere in the window then the command does nothing. [2] If what is only a few lines off-screen above the window then it will be positioned at the top of the window. [3] If what is only a few lines off-screen below the window then it will be positioned at the bottom of the window. [4] Otherwise, what will be centered in the window. The :pickplace option is typically used after inserting text to make sure that the insertion cursor is still visible on the screen. This command returns an empty string. Bindings -------- Tk automatically creates class bindings for texts that give them the following default behavior: [1] Pressing mouse button 1 in an text positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget. [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse. [3] If you double-press mouse button 1 then the word under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the word, and dragging the mouse will stroke out a selection whole words at a time. [4] If you triple-press mouse button 1 then the line under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the line, and dragging the mouse will stroke out a selection whole line at a time. [5] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. If the selection was made in word or line mode then it will be adjusted in this same mode. [6] The view in the text can be adjusted by dragging with mouse button 2. [7] If the input focus is in a text widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor. [8] Control+h and the Backspace and Delete keys erase the character just before the insertion cursor. [9] Control+v inserts the current selection just before the insertion cursor. [10] Control+d deletes the selected characters; an error occurs if the selection is not in this widget. If the text is disabled using the state option, then the text's view can still be adjusted and text in the text can still be selected, but no insertion cursor will be displayed and no text modifications will take place. The behavior of texts can be changed by defining new bindings for individual widgets or by redefining the class bindings. "Performance Issues" -------------------- Text widgets should run efficiently under a variety of conditions. The text widget uses about 2-3 bytes of main memory for each byte of text, so texts containing a megabyte or more should be practical on most workstations. Text is represented internally with a modified B-tree structure that makes operations relatively efficient even with large texts. Tags are included in the B-tree structure in a way that allows tags to span large ranges or have many disjoint smaller ranges without loss of efficiency. Marks are also implemented in a way that allows large numbers of marks. The only known mode of operation where a text widget may not run efficiently is if it has a very large number of different tags. Hundreds of tags should be fine, or even a thousand, but tens of thousands of tags will make texts consume a lot of memory and run slowly. Keywords -------- text, widget  File: gcl-tk.info, Node: entry, Next: message, Prev: text, Up: Widgets 2.10 entry ========== entry \- Create and manipulate entry widgets Synopsis -------- entry pathName ?options? Standard Options ---------------- background foreground insertWidth selectForeground borderWidth insertBackground relief textVariable cursor insertBorderWidth scrollCommand exportSelection insertOffTime selectBackground font insertOnTime selectBorderWidth *Note options::, for more information. Arguments for Entry ------------------- ':state' Name='"state" Class="State"' Specifies one of two states for the entry: normal or disabled. If the entry is disabled then the value may not be changed using widget commands and no insertion cursor will be displayed, even if the input focus is in the widget. ':width' Name='"width" Class="Width"' Specifies an integer value indicating the desired width of the entry window, in average-size characters of the widget's font. Description ----------- The entry command creates a new window (given by the pathName argument) and makes it into an entry widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the entry such as its colors, font, and relief. The entry command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. An entry is a widget that displays a one-line text string and allows that string to be edited using widget commands described below, which are typically bound to keystrokes and mouse actions. When first created, an entry's string is empty. A portion of the entry may be selected as described below. If an entry is exporting its selection (see the exportSelection option), then it will observe the standard X11 protocols for handling the selection; entry selections are available as type STRING. Entries also observe the standard Tk rules for dealing with the input focus. When an entry has the input focus it displays an insertion cursor to indicate where new characters will be inserted. Entries are capable of displaying strings that are too long to fit entirely within the widget's window. In this case, only a portion of the string will be displayed; commands described below may be used to change the view in the window. Entries use the standard scrollCommand mechanism for interacting with scrollbars (see the description of the scrollCommand option for details). They also support scanning, as described below. A Entry Widget's Arguments -------------------------- The entry command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. Many of the widget commands for entries take one or more indices as arguments. An index specifies a particular character in the entry's string, in any of the following ways: number Specifies the character as a numerical index, where 0 corresponds to the first character in the string. end Indicates the character just after the last one in the entry's string. This is equivalent to specifying a numerical index equal to the length of the entry's string. insert Indicates the character adjacent to and immediately following the insertion cursor. sel.first Indicates the first character in the selection. It is an error to use this form if the selection isn't in the entry window. sel.last Indicates the last character in the selection. It is an error to use this form if the selection isn't in the entry window. @number In this form, number is treated as an x-coordinate in the entry's window; the character spanning that x-coordinate is used. For example, "@0" indicates the left-most character in the window. Abbreviations may be used for any of the forms above, e.g. "e" or "sel.f". In general, out-of-range indices are automatically rounded to the nearest legal value. The following commands are possible for entry widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the entry command. pathName :delete first ?last? Delete one or more elements of the entry. First and last are indices of of the first and last characters in the range to be deleted. If last isn't specified it defaults to first, i.e. a single character is deleted. This command returns an empty string. pathName :get Returns the entry's string. pathName :icursor index Arrange for the insertion cursor to be displayed just before the character given by index. Returns an empty string. pathName :index index Returns the numerical index corresponding to index. pathName :insert index string Insert the characters of string just before the character indicated by index. Returns an empty string. pathName :scan option args This command is used to implement scanning on entries. It has two forms, depending on option: pathName :scan :mark x Records x and the current view in the entry window; used in conjunction with later scan dragto commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. pathName :scan :dragto x This command computes the difference between its x argument and the x argument to the last scan mark command for the widget. It then adjusts the view left or right by 10 times the difference in x-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the entry at high speed through the window. The return value is an empty string. pathName :select option arg This command is used to adjust the selection within an entry. It has several forms, depending on option: pathName :select :adjust index Locate the end of the selection nearest to the character given by index, and adjust that end of the selection to be at index (i.e including but not going beyond index). The other end of the selection is made the anchor point for future select to commands. If the selection isn't currently in the entry, then a new selection is created to include the characters between index and the most recent selection anchor point, inclusive. Returns an empty string. pathName :select :clear Clear the selection if it is currently in this widget. If the selection isn't in this widget then the command has no effect. Returns an empty string. pathName :select :from index Set the selection anchor point to just before the character given by index. Doesn't change the selection. Returns an empty string. pathName :select :to index Set the selection to consist of the elements from the anchor point to element index, inclusive. The anchor point is determined by the most recent select from or select adjust command in this widget. If the selection isn't in this widget then a new selection is created using the most recent anchor point specified for the widget. Returns an empty string. pathName :view index Adjust the view in the entry so that element index is at the left edge of the window. Returns an empty string. "Default Bindings" ------------------ Tk automatically creates class bindings for entries that give them the following default behavior: [1] Clicking mouse button 1 in an entry positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget. [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse. [3] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. [4] The view in the entry can be adjusted by dragging with mouse button 2. [5] If the input focus is in an entry widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor. [6] Control-h and the Backspace and Delete keys erase the character just before the insertion cursor. [7] Control-w erases the word just before the insertion cursor. [8] Control-u clears the entry to an empty string. [9] Control-v inserts the current selection just before the insertion cursor. [10] Control-d deletes the selected characters; an error occurs if the selection is not in this widget. If the entry is disabled using the state option, then the entry's view can still be adjusted and text in the entry can still be selected, but no insertion cursor will be displayed and no text modifications will take place. The behavior of entries can be changed by defining new bindings for individual widgets or by redefining the class bindings. Keywords -------- entry, widget  File: gcl-tk.info, Node: message, Next: frame, Prev: entry, Up: Widgets 2.11 message ============ message \- Create and manipulate message widgets Synopsis -------- message pathName ?options? Standard Options ---------------- anchor cursor padX text background font padY textVariable borderWidth foreground relief width *Note options::, for more information. Arguments for Message --------------------- ':aspect' Name='"aspect" Class="Aspect"' Specifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. Used to choose line length for text if width option isn't specified. Defaults to 150. ':justify' Name='"justify" Class="Justify"' Specifies how to justify lines of text. Must be one of left, center, or right. Defaults to left. This option works together with the anchor, aspect, padX, padY, and width options to provide a variety of arrangements of the text within the window. The aspect and width options determine the amount of screen space needed to display the text. The anchor, padX, and padY options determine where this rectangular area is displayed within the widget's window, and the justify option determines how each line is displayed within that rectangular region. For example, suppose anchor is e and justify is left, and that the message window is much larger than needed for the text. The the text will displayed so that the left edges of all the lines line up and the right edge of the longest line is padX from the right side of the window; the entire text block will be centered in the vertical span of the window. ':width' Name='"width" Class="Width"' Specifies the length of lines in the window. The value may have any of the forms acceptable to Tk_GetPixels. If this option has a value greater than zero then the aspect option is ignored and the width option determines the line length. If this option has a value less than or equal to zero, then the aspect option determines the line length. Description ----------- The message command creates a new window (given by the pathName argument) and makes it into a message widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the message such as its colors, font, text, and initial relief. The message command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A message is a widget that displays a textual string. A message widget has three special features. First, it breaks up its string into lines in order to produce a given aspect ratio for the window. The line breaks are chosen at word boundaries wherever possible (if not even a single word would fit on a line, then the word will be split across lines). Newline characters in the string will force line breaks; they can be used, for example, to leave blank lines in the display. The second feature of a message widget is justification. The text may be displayed left-justified (each line starts at the left side of the window), centered on a line-by-line basis, or right-justified (each line ends at the right side of the window). The third feature of a message widget is that it handles control characters and non-printing characters specially. Tab characters are replaced with enough blank space to line up on the next 8-character boundary. Newlines cause line breaks. Other control characters (ASCII code less than 0x20) and characters not defined in the font are displayed as a four-character sequence \fB\exhh where hh is the two-digit hexadecimal number corresponding to the character. In the unusual case where the font doesn't contain all of the characters in "0123456789abcdef\ex" then control characters and undefined characters are not displayed at all. A Message Widget's Arguments ---------------------------- The message command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for message widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the message command. "Default Bindings" ------------------ When a new message is created, it has no default event bindings: messages are intended for output purposes only. Bugs ---- Tabs don't work very well with text that is centered or right-justified. The most common result is that the line is justified wrong. Keywords -------- message, widget  File: gcl-tk.info, Node: frame, Next: label, Prev: message, Up: Widgets 2.12 frame ========== frame \- Create and manipulate frame widgets Synopsis -------- frame pathName ?:class className? ?options? Standard Options ---------------- background cursor relief borderWidth geometry *Note options::, for more information. Arguments for Frame ------------------- ':height' Name='"height" Class="Height"' Specifies the desired height for the window in any of the forms acceptable to Tk_GetPixels. This option is only used if the :geometry option is unspecified. If this option is less than or equal to zero (and :geometry is not specified) then the window will not request any size at all. ':width' Name='"width" Class="Width"' Specifies the desired width for the window in any of the forms acceptable to Tk_GetPixels. This option is only used if the :geometry option is unspecified. If this option is less than or equal to zero (and :geometry is not specified) then the window will not request any size at all. Description ----------- The frame command creates a new window (given by the pathName argument) and makes it into a frame widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the frame such as its background color and relief. The frame command returns the path name of the new window. A frame is a simple widget. Its primary purpose is to act as a spacer or container for complex window layouts. The only features of a frame are its background color and an optional 3-D border to make the frame appear raised or sunken. In addition to the standard options listed above, a :class option may be specified on the command line. If it is specified, then the new widget's class will be set to className instead of Frame. Changing the class of a frame widget may be useful in order to use a special class name in database options referring to this widget and its children. Note: :class is handled differently than other command-line options and cannot be specified using the option database (it has to be processed before the other options are even looked up, since the new class name will affect the lookup of the other options). In addition, the :class option may not be queried or changed using the config command described below. A Frame Widget's Arguments -------------------------- The frame command creates a new Tcl command whose name is the same as the path name of the frame's window. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? PathName is the name of the command, which is the same as the frame widget's path name. Option and the args determine the exact behavior of the command. The following commands are possible for frame widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the frame command. Bindings -------- When a new frame is created, it has no default event bindings: frames are not intended to be interactive. Keywords -------- frame, widget  File: gcl-tk.info, Node: label, Next: radiobutton, Prev: frame, Up: Widgets 2.13 label ========== label \- Create and manipulate label widgets Synopsis -------- label pathName ?options? Standard Options ---------------- anchor borderWidth foreground relief background cursor padX text bitmap font padY textVariable *Note options::, for more information. Arguments for Label ------------------- ':height' Name='"height" Class="Height"' Specifies a desired height for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the label's desired height is computed from the size of the bitmap or text being displayed in it. ':width' Name='"width" Class="Width"' Specifies a desired width for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn't specified, the label's desired width is computed from the size of the bitmap or text being displayed in it. Description ----------- The label command creates a new window (given by the pathName argument) and makes it into a label widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the label such as its colors, font, text, and initial relief. The label command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A label is a widget that displays a textual string or bitmap. The label can be manipulated in a few simple ways, such as changing its relief or text, using the commands described below. A Label Widget's Arguments -------------------------- The label command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for label widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the label command. Bindings -------- When a new label is created, it has no default event bindings: labels are not intended to be interactive. Keywords -------- label, widget  File: gcl-tk.info, Node: radiobutton, Next: toplevel, Prev: label, Up: Widgets 2.14 radiobutton ================ radiobutton \- Create and manipulate radio-button widgets Synopsis -------- radiobutton pathName ?options? Standard Options ---------------- activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padX *Note options::, for more information. Arguments for Radiobutton ------------------------- ':command' Name='"command" Class="Command"' Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button's global variable (:variable option) will be updated before the command is invoked. ':height' Name='"height" Class="Height"' Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. ':selector' Name='"selector" Class="Foreground"' Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button. ':state' Name='"state" Class="State"' Specifies one of three states for the radio button: normal, active, or disabled. In normal state the radio button is displayed using the foreground and background options. The active state is typically used when the pointer is over the radio button. In active state the radio button is displayed using the activeForeground and activeBackground options. Disabled state means that the radio button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the disabledForeground and background options determine how the radio button is displayed. ':value' Name='"value" Class="Value"' Specifies value to store in the button's associated variable whenever this button is selected. Defaults to the name of the radio button. ':variable' Name='"variable" Class="Variable"' Specifies name of global variable to set whenever this button is selected. Changes in this variable also cause the button to select or deselect itself. Defaults to the value selectedButton. ':width' Name='"width" Class="Width"' Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. Description ----------- The radiobutton command creates a new window (given by the pathName argument) and makes it into a radiobutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the radio button such as its colors, font, text, and initial relief. The radiobutton command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A radio button is a widget that displays a textual string or bitmap and a diamond called a selector. A radio button has all of the behavior of a simple button: it can display itself in either of three different ways, according to the state option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button. In addition, radio buttons can be selected. If a radio button is selected then a special highlight appears in the selector and a Tcl variable associated with the radio button is set to a particular value. If the radio button is not selected then the selector is drawn in a different fashion. Typically, several radio buttons share a single variable and the value of the variable indicates which radio button is to be selected. When a radio button is selected it sets the value of the variable to indicate that fact; each radio button also monitors the value of the variable and automatically selects and deselects itself when the variable's value changes. By default the variable selectedButton is used; its contents give the name of the button that is selected, or the empty string if no button associated with that variable is selected. The name of the variable for a radio button, plus the variable to be stored into it, may be modified with options on the command line or in the option database. By default a radio button is configured to select itself on button clicks. A Radiobutton Widget's Arguments -------------------------------- The radiobutton command creates a new Tcl command whose name is pathName. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? Option and the args determine the exact behavior of the command. The following commands are possible for radio-button widgets: pathName :activate Change the radio button's state to active and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the radio button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state active" instead. pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the radiobutton command. pathName :deactivate Change the radio button's state to normal and redisplay the button using its normal foreground and background colors. This command is ignored if the radio button's state is disabled. This command is obsolete and will eventually be removed; use "pathName :configure :state normal" instead. pathName :deselect Deselect the radio button: redisplay it without a highlight in the selector and set the associated variable to an empty string. If this radio button was not currently selected, then the command has no effect. pathName :flash Flash the radio button. This is accomplished by redisplaying the radio button several times, alternating between active and normal colors. At the end of the flash the radio button is left in the same normal/active state as when the command was invoked. This command is ignored if the radio button's state is disabled. pathName :invoke Does just what would have happened if the user invoked the radio button with the mouse: select the button and invoke its associated Tcl command, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the radio button. This command is ignored if the radio button's state is disabled. pathName :select Select the radio button: display it with a highlighted selector and set the associated variable to the value corresponding to this widget. Bindings -------- Tk automatically creates class bindings for radio buttons that give them the following default behavior: [1] The radio button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the radio button. [2] The radio button's relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released. [3] If mouse button 1 is pressed over the radio button and later released over the radio button, the radio button is invoked (i.e. it is selected and the command associated with the button is invoked, if there is one). However, if the mouse is not over the radio button when button 1 is released, then no invocation occurs. The behavior of radio buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. Keywords -------- radio button, widget  File: gcl-tk.info, Node: toplevel, Prev: radiobutton, Up: Widgets 2.15 toplevel ============= toplevel \- Create and manipulate toplevel widgets Synopsis -------- toplevel pathName ?:screen screenName? ?:class className? ?options? Standard Options ---------------- background geometry borderWidth relief *Note options::, for more information. Arguments for Toplevel ---------------------- Description ----------- The toplevel command creates a new toplevel widget (given by the pathName argument). Additional options, described above, may be specified on the command line or in the option database to configure aspects of the toplevel such as its background color and relief. The toplevel command returns the path name of the new window. A toplevel is similar to a frame except that it is created as a top-level window: its X parent is the root window of a screen rather than the logical parent from its path name. The primary purpose of a toplevel is to serve as a container for dialog boxes and other collections of widgets. The only features of a toplevel are its background color and an optional 3-D border to make the toplevel appear raised or sunken. Two special command-line options may be provided to the toplevel command: :class and :screen. If :class is specified, then the new widget's class will be set to className instead of Toplevel. Changing the class of a toplevel widget may be useful in order to use a special class name in database options referring to this widget and its children. The :screen option may be used to place the window on a different screen than the window's logical parent. Any valid screen name may be used, even one associated with a different display. Note: :class and :screen are handled differently than other command-line options. They may not be specified using the option database (these options must have been processed before the new window has been created enough to use the option database; in particular, the new class name will affect the lookup of options in the database). In addition, :class and :screen may not be queried or changed using the config command described below. However, the winfo :class command may be used to query the class of a window, and winfo :screen may be used to query its screen. A Toplevel Widget's Arguments ----------------------------- The toplevel command creates a new Tcl command whose name is the same as the path name of the toplevel's window. This command may be used to invoke various operations on the widget. It has the following general form: pathName option ?arg arg ...? PathName is the name of the command, which is the same as the toplevel widget's path name. Option and the args determine the exact behavior of the command. The following commands are possible for toplevel widgets: pathName :configure ?option? ?value option value ...? Query or modify the configuration options of the widget. If no option is specified, returns a list describing all of the available options for pathName (see Tk_ConfigureInfo for information on the format of this list). If option is specified with no value, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no option is specified). If one or more option:value pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. Option may have any of the values accepted by the toplevel command. Bindings -------- When a new toplevel is created, it has no default event bindings: toplevels are not intended to be interactive. Keywords -------- toplevel, widget  File: gcl-tk.info, Node: Control, Prev: Widgets, Up: Top 3 Control ********* * Menu: * after:: * bind:: * destroy:: * tk-dialog:: * exit:: * focus:: * grab:: * tk-listbox-single-select:: * lower:: * tk-menu-bar:: * option:: * options:: * pack-old:: * pack:: * place:: * raise:: * selection:: * send:: * tk:: * tkerror:: * tkvars:: * tkwait:: * update:: * winfo:: * wm::  File: gcl-tk.info, Node: after, Next: bind, Prev: Control, Up: Control 3.1 after ========= after - Execute a command after a time delay Synopsis -------- after ms ?arg1 arg2 arg3 ...? Description ----------- This command is used to delay execution of the program or to execute a command in background after a delay. The ms argument gives a time in milliseconds. If ms is the only argument to after then the command sleeps for ms milliseconds and returns. While the command is sleeping the application does not respond to X events and other events. If additional arguments are present after ms, then a Tcl command is formed by concatenating all the additional arguments in the same fashion as the concat command. After returns immediately but arranges for the command to be executed ms milliseconds later in background. The command will be executed at global level (outside the context of any Tcl procedure). If an error occurs while executing the delayed command then the tkerror mechanism is used to report the error. The after command always returns an empty string. *Note tkerror::. Keywords -------- delay, sleep, time  File: gcl-tk.info, Node: bind, Next: destroy, Prev: after, Up: Control 3.2 bind ======== bind \- Arrange for X events to invoke Tcl commands Synopsis -------- bind windowSpec bind windowSpec sequence bind windowSpec sequence command bind windowSpec sequence +command Description ----------- If all three arguments are specified, bind will arrange for command (a Tcl command) to be executed whenever the sequence of events given by sequence occurs in the window(s) identified by windowSpec. If command is prefixed with a "+", then it is appended to any existing binding for sequence; otherwise command replaces the existing binding, if any. If command is an empty string then the current binding for sequence is destroyed, leaving sequence unbound. In all of the cases where a command argument is provided, bind returns an empty string. If sequence is specified without a command, then the command currently bound to sequence is returned, or an empty string if there is no binding for sequence. If neither sequence nor command is specified, then the return value is a list whose elements are all the sequences for which there exist bindings for windowSpec. The windowSpec argument selects which window(s) the binding applies to. It may have one of three forms. If windowSpec is the path name for a window, then the binding applies to that particular window. If windowSpec is the name of a class of widgets, then the binding applies to all widgets in that class. Lastly, windowSpec may have the value all, in which case the binding applies to all windows in the application. The sequence argument specifies a sequence of one or more event patterns, with optional white space between the patterns. Each event pattern may take either of two forms. In the simplest case it is a single printing ASCII character, such as a or [. The character may not be a space character or the character <. This form of pattern matches a KeyPress event for the particular character. The second form of pattern is longer but more general. It has the following syntax: The entire event pattern is surrounded by angle brackets. Inside the angle brackets are zero or more modifiers, an event type, and an extra piece of information (detail) identifying a particular button or keysym. Any of the fields may be omitted, as long as at least one of type and detail is present. The fields must be separated by white space or dashes. Modifiers may consist of any of the values in the following list: Control Any Shift Double Lock Triple Button1, B1 Mod1, M1, Meta, M Button2, B2 Mod2, M2, Alt Button3, B3 Mod3, M3 Button4, B4 Mod4, M4 Button5, B5 Mod5, M5 Where more than one value is listed, separated by commas, the values are equivalent. All of the modifiers except Any, Double, and Triple have the obvious X meanings. For example, Button1 requires that button 1 be depressed when the event occurs. Under normal conditions the button and modifier state at the time of the event must match exactly those specified in the bind command. If no modifiers are specified, then events will match only if no modifiers are present. If the Any modifier is specified, then additional modifiers may be present besides those specified explicitly. For example, if button 1 is pressed while the shift and control keys are down, the specifier will match the event, but the specifier will not. The Double and Triple modifiers are a convenience for specifying double mouse clicks and other repeated events. They cause a particular event pattern to be repeated 2 or 3 times, and also place a time and space requirement on the sequence: for a sequence of events to match a Double or Triple pattern, all of the events must occur close together in time and without substantial mouse motion in between. For example, is equivalent to with the extra time and space requirement. The type field may be any of the standard X event types, with a few extra abbreviations. Below is a list of all the valid types; where two name appear together, they are synonyms. ButtonPress, Button Expose Leave ButtonRelease FocusIn Map Circulate FocusOut Property CirculateRequest Gravity Reparent Colormap Keymap ResizeRequest Configure KeyPress, Key Unmap ConfigureRequest KeyRelease Visibility Destroy MapRequest Enter Motion The last part of a long event specification is detail. In the case of a ButtonPress or ButtonRelease event, it is the number of a button (1-5). If a button number is given, then only an event on that particular button will match; if no button number is given, then an event on any button will match. Note: giving a specific button number is different than specifying a button modifier; in the first case, it refers to a button being pressed or released, while in the second it refers to some other button that is already depressed when the matching event occurs. If a button number is given then type may be omitted: if will default to ButtonPress. For example, the specifier <1> is equivalent to . If the event type is KeyPress or KeyRelease, then detail may be specified in the form of an X keysym. Keysyms are textual specifications for particular keys on the keyboard; they include all the alphanumeric ASCII characters (e.g. "a" is the keysym for the ASCII character "a"), plus descriptions for non-alphanumeric characters ("comma" is the keysym for the comma character), plus descriptions for all the non-ASCII keys on the keyboard ("Shift_L" is the keysm for the left shift key, and "F1" is the keysym for the F1 function key, if it exists). The complete list of keysyms is not presented here; it should be available in other X documentation. If necessary, you can use the %K notation described below to print out the keysym name for an arbitrary key. If a keysym detail is given, then the type field may be omitted; it will default to KeyPress. For example, is equivalent to . If a keysym detail is specified then the Shift modifier need not be specified and will be ignored if specified: each keysym already implies a particular state for the shift key. The command argument to bind is a Tcl command string, which will be executed whenever the given event sequence occurs. Command will be executed in the same interpreter that the bind command was executed in. If command contains any % characters, then the command string will not be executed directly. Instead, a new command string will be generated by replacing each %, and the character following it, with information from the current event. The replacement depends on the character following the %, as defined in the list below. Unless otherwise indicated, the replacement string is the decimal value of the given field from the current event. Some of the substitutions are only valid for certain types of events; if they are used for other types of events the value substituted is undefined. %% Replaced with a single percent. |%#| The number of the last client request processed by the server (the serial field from the event). Valid for all event types. |%a| The above field from the event. Valid only for ConfigureNotify events. |%b| The number of the button that was pressed or released. Valid only for ButtonPress and ButtonRelease events. |%c| The count field from the event. Valid only for Expose, GraphicsExpose, and MappingNotify events. |%d| The detail field from the event. The |%d| is replaced by a string identifying the detail. For EnterNotify, LeaveNotify, FocusIn, and FocusOut events, the string will be one of the following: NotifyAncestor NotifyNonlinearVirtual NotifyDetailNone NotifyPointer NotifyInferior NotifyPointerRoot NotifyNonlinear NotifyVirtual For ConfigureRequest events, the substituted string will be one of the following: Above Opposite Below TopIf BottomIf For events other than these, the substituted string is undefined. .RE |%f| The focus field from the event (0 or 1). Valid only for EnterNotify and LeaveNotify events. |%h| The height field from the event. Valid only for Configure, ConfigureNotify, Expose, GraphicsExpose, and ResizeRequest events. |%k| The keycode field from the event. Valid only for KeyPress and KeyRelease events. |%m| The mode field from the event. The substituted string is one of NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed. Valid only for EnterWindow, FocusIn, FocusOut, and LeaveWindow events. |%o| The override_redirect field from the event. Valid only for CreateNotify, MapNotify, ReparentNotify, and ConfigureNotify events. |%p| The place field from the event, substituted as one of the strings PlaceOnTop or PlaceOnBottom. Valid only for CirculateNotify and CirculateRequest events. |%s| The state field from the event. For ButtonPress, ButtonRelease, EnterNotify, KeyPress, KeyRelease, LeaveNotify, and MotionNotify events, a decimal string is substituted. For VisibilityNotify, one of the strings VisibilityUnobscured, VisibilityPartiallyObscured, and VisibilityFullyObscured is substituted. |%t| The time field from the event. Valid only for events that contain a time field. |%v| The value_mask field from the event. Valid only for ConfigureRequest events. |%w| The width field from the event. Valid only for Configure, ConfigureRequest, Expose, GraphicsExpose, and ResizeRequest events. |%x| The x field from the event. Valid only for events containing an x field. |%y| The y field from the event. Valid only for events containing a y field. %A Substitutes the ASCII character corresponding to the event, or the empty string if the event doesn't correspond to an ASCII character (e.g. the shift key was pressed). XLookupString does all the work of translating from the event to an ASCII character. Valid only for KeyPress and KeyRelease events. %B The border_width field from the event. Valid only for ConfigureNotify and CreateWindow events. %D The display field from the event. Valid for all event types. %E The send_event field from the event. Valid for all event types. %K The keysym corresponding to the event, substituted as a textual string. Valid only for KeyPress and KeyRelease events. %N The keysym corresponding to the event, substituted as a decimal number. Valid only for KeyPress and KeyRelease events. %R The root window identifier from the event. Valid only for events containing a root field. %S The subwindow window identifier from the event. Valid only for events containing a subwindow field. %T The type field from the event. Valid for all event types. %W The path name of the window to which the event was reported (the window field from the event). Valid for all event types. %X The x_root field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding x-coordinate in the virtual root. Valid only for ButtonPress, ButtonRelease, KeyPress, KeyRelease, and MotionNotify events. %Y The y_root field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding y-coordinate in the virtual root. Valid only for ButtonPress, ButtonRelease, KeyPress, KeyRelease, and MotionNotify events. If the replacement string for a %-replacement contains characters that are interpreted specially by the Tcl parser (such as backslashes or square brackets or spaces) additional backslashes are added during replacement so that the result after parsing is the original replacement string. For example, if command is insert %A and the character typed is an open square bracket, then the command actually executed will be insert \e[ This will cause the insert to receive the original replacement string (open square bracket) as its first argument. If the extra backslash hadn't been added, Tcl would not have been able to parse the command correctly. At most one binding will trigger for any given X event. If several bindings match the recent events, the most specific binding is chosen and its command will be executed. The following tests are applied, in order, to determine which of several matching sequences is more specific: (a) a binding whose windowSpec names a particular window is more specific than a binding for a class, which is more specific than a binding whose windowSpec is all; (b) a longer sequence (in terms of number of events matched) is more specific than a shorter sequence; (c) an event pattern that specifies a specific button or key is more specific than one that doesn't; (e) an event pattern that requires a particular modifier is more specific than one that doesn't require the modifier; (e) an event pattern specifying the Any modifier is less specific than one that doesn't. If the matching sequences contain more than one event, then tests (c)-(e) are applied in order from the most recent event to the least recent event in the sequences. If these tests fail to determine a winner, then the most recently registered sequence is the winner. If an X event does not match any of the existing bindings, then the event is ignored (an unbound event is not considered to be an error). When a sequence specified in a bind command contains more than one event pattern, then its command is executed whenever the recent events (leading up to and including the current event) match the given sequence. This means, for example, that if button 1 is clicked repeatedly the sequence will match each button press but the first. If extraneous events that would prevent a match occur in the middle of an event sequence then the extraneous events are ignored unless they are KeyPress or ButtonPress events. For example, will match a sequence of presses of button 1, even though there will be ButtonRelease events (and possibly MotionNotify events) between the ButtonPress events. Furthermore, a KeyPress event may be preceded by any number of other KeyPress events for modifier keys without the modifier keys preventing a match. For example, the event sequence aB will match a press of the a key, a release of the a key, a press of the Shift key, and a press of the b key: the press of Shift is ignored because it is a modifier key. Finally, if several MotionNotify events occur in a row, only the last one is used for purposes of matching binding sequences. If an error occurs in executing the command for a binding then the tkerror mechanism is used to report the error. The command will be executed at global level (outside the context of any Tcl procedure). *Note tkerror::. Keywords -------- form, manual  File: gcl-tk.info, Node: destroy, Next: tk-dialog, Prev: bind, Up: Control 3.3 destroy =========== destroy \- Destroy one or more windows Synopsis -------- destroy ?window window ...? Description ----------- This command deletes the windows given by the window arguments, plus all of their descendants. If a window "." is deleted then the entire application will be destroyed. The windows are destroyed in order, and if an error occurs in destroying a window the command aborts without destroying the remaining windows. Keywords -------- application, destroy, window  File: gcl-tk.info, Node: tk-dialog, Next: exit, Prev: destroy, Up: Control 3.4 tk-dialog ============= tk-dialog \- Create modal dialog and wait for response Synopsis -------- tk-dialog window title text bitmap default string string ... Description ----------- This procedure is part of the Tk script library. Its arguments describe a dialog box: window Name of top-level window to use for dialog. Any existing window by this name is destroyed. title Text to appear in the window manager's title bar for the dialog. text Message to appear in the top portion of the dialog box. bitmap If non-empty, specifies a bitmap to display in the top portion of the dialog, to the left of the text. If this is an empty string then no bitmap is displayed in the dialog. default If this is an integer greater than or equal to zero, then it gives the index of the button that is to be the default button for the dialog (0 for the leftmost button, and so on). If less than zero or an empty string then there won't be any default button. string There will be one button for each of these arguments. Each string specifies text to display in a button, in order from left to right. After creating a dialog box, tk-dialog waits for the user to select one of the buttons either by clicking on the button with the mouse or by typing return to invoke the default button (if any). Then it returns the index of the selected button: 0 for the leftmost button, 1 for the button next to it, and so on. While waiting for the user to respond, tk-dialog sets a local grab. This prevents the user from interacting with the application in any way except to invoke the dialog box. Keywords -------- bitmap, dialog, modal  File: gcl-tk.info, Node: exit, Next: focus, Prev: tk-dialog, Up: Control 3.5 exit ======== exit \- Exit the process Synopsis -------- exit ?returnCode? Description ----------- Terminate the process, returning returnCode (an integer) to the system as the exit status. If returnCode isn't specified then it defaults to 0. This command replaces the Tcl command by the same name. It is identical to Tcl's exit command except that before exiting it destroys all the windows managed by the process. This allows various cleanup operations to be performed, such as removing application names from the global registry of applications. Keywords -------- exit, process  File: gcl-tk.info, Node: focus, Next: grab, Prev: exit, Up: Control 3.6 focus ========= focus \- Direct keyboard events to a particular window Synopsis -------- focus focus window focus option ?arg arg ...? Description ----------- The focus command is used to manage the Tk input focus. At any given time, one window in an application is designated as the focus window for that application; any key press or key release events directed to any window in the application will be redirected instead to the focus window. If there is no focus window for an application then keyboard events are discarded. Typically, windows that are prepared to deal with the focus (e.g. entries and other widgets that display editable text) will claim the focus when mouse button 1 is pressed in them. When an application is created its main window is initially given the focus. The focus command can take any of the following forms: focus If invoked with no arguments, focus returns the path name of the current focus window, or none if there is no focus window. focus window If invoked with a single argument consisting of a window's path name, focus sets the input focus to that window. The return value is an empty string. focus :default ?window? If window is specified, it becomes the default focus window (the window that receives the focus whenever the focus window is deleted) and the command returns an empty string. If window isn't specified, the command returns the path name of the current default focus window, or none if there is no default. Window may be specified as none to clear its existing value. The default window is initially none. focus :none Clears the focus window, so that keyboard input to this application will be discarded. "Focus Events" -------------- Tk's model of the input focus is different than X's model, and the focus window set with the focus command is not usually the same as the X focus window. Tk never explicitly changes the official X focus window. It waits for the window manager to direct the X input focus to and from the application's top-level windows, and it intercepts FocusIn and FocusOut events coming from the X server to detect these changes. All of the focus events received from X are discarded by Tk; they never reach the application. Instead, Tk generates a different stream of FocusIn and FocusOut for the application. This means that FocusIn and and FocusOut events seen by the application will not obey the conventions described in the documentation for Xlib. Tk applications receive two kinds of FocusIn and FocusOut events, which can be distinguished by their detail fields. Events with a detail of NotifyAncestor are directed to the current focus window when it becomes active or inactive. A window is the active focus whenever two conditions are simultaneously true: (a) the window is the focus window for its application, and (b) some top-level window in the application has received the X focus. When this happens Tk generates a FocusIn event for the focus window with detail NotifyAncestor. When a window loses the active focus (either because the window manager removed the focus from the application or because the focus window changed within the application) then it receives a FocusOut event with detail NotifyAncestor. The events described above are directed to the application's focus window regardless of which top-level window within the application has received the focus. The second kind of focus event is provided for applications that need to know which particular top-level window has the X focus. Tk generates FocusIn and FocusOut events with detail NotifyVirtual for top-level windows whenever they receive or lose the X focus. These events are generated regardless of which window in the application has the Tk input focus. They do not imply that keystrokes will be directed to the window that receives the event; they simply indicate which top-level window is active as far as the window manager is concerned. If a top-level window is also the application's focus window, then it will receive both NotifyVirtual and NotifyAncestor events when it receives or loses the X focus. Tk does not generate the hierarchical chains of FocusIn and FocusOut events described in the Xlib documentation (e.g. a window can get a FocusIn or FocusOut event without all of its ancestors getting events too). Furthermore, the mode field in focus events is always NotifyNormal and the only values ever present in the detail field are NotifyAncestor and NotifyVirtual. Keywords -------- events, focus, keyboard, top-level, window manager  File: gcl-tk.info, Node: grab, Next: tk-listbox-single-select, Prev: focus, Up: Control 3.7 grab ======== grab \- Confine pointer and keyboard events to a window sub-tree Synopsis -------- grab ?:global? window grab option ?arg arg ...? Description ----------- This command implements simple pointer and keyboard grabs for Tk. Tk's grabs are different than the grabs described in the Xlib documentation. When a grab is set for a particular window, Tk restricts all pointer events to the grab window and its descendants in Tk's window hierarchy. Whenever the pointer is within the grab window's subtree, the pointer will behave exactly the same as if there had been no grab at all and all events will be reported in the normal fashion. When the pointer is outside window's tree, button presses and releases and mouse motion events are reported to window, and window entry and window exit events are ignored. The grab subtree "owns" the pointer: windows outside the grab subtree will be visible on the screen but they will be insensitive until the grab is released. The tree of windows underneath the grab window can include top-level windows, in which case all of those top-level windows and their descendants will continue to receive mouse events during the grab. Two forms of grabs are possible: local and global. A local grab affects only the grabbing application: events will be reported to other applications as if the grab had never occurred. Grabs are local by default. A global grab locks out all applications on the screen, so that only the given subtree of the grabbing application will be sensitive to pointer events (mouse button presses, mouse button releases, pointer motions, window entries, and window exits). During global grabs the window manager will not receive pointer events either. During local grabs, keyboard events (key presses and key releases) are delivered as usual: the window manager controls which application receives keyboard events, and if they are sent to any window in the grabbing application then they are redirected to the focus window. During a global grab Tk grabs the keyboard so that all keyboard events are always sent to the grabbing application. The focus command is still used to determine which window in the application receives the keyboard events. The keyboard grab is released when the grab is released. Grabs apply to particular displays. If an application has windows on multiple displays then it can establish a separate grab on each display. The grab on a particular display affects only the windows on that display. It is possible for different applications on a single display to have simultaneous local grabs, but only one application can have a global grab on a given display at once. The grab command can take any of the following forms: grab ?:global? window Same as grab :set, described below. grab :current ?window? If window is specified, returns the name of the current grab window in this application for window's display, or an empty string if there is no such window. If window is omitted, the command returns a list whose elements are all of the windows grabbed by this application for all displays, or an empty string if the application has no grabs. grab :release window Releases the grab on window if there is one, otherwise does nothing. Returns an empty string. grab :set ?:global? window Sets a grab on window. If :global is specified then the grab is global, otherwise it is local. If a grab was already in effect for this application on window's display then it is automatically released. If there is already a grab on window and it has the same global/local form as the requested grab, then the command does nothing. Returns an empty string. grab :status window Returns none if no grab is currently set on window, local if a local grab is set on window, and global if a global grab is set. Bugs ---- It took an incredibly complex and gross implementation to produce the simple grab effect described above. Given the current implementation, it isn't safe for applications to use the Xlib grab facilities at all except through the Tk grab procedures. If applications try to manipulate X's grab mechanisms directly, things will probably break. If a single process is managing several different Tk applications, only one of those applications can have a local grab for a given display at any given time. If the applications are in different processes, this restriction doesn't exist. Keywords -------- grab, keyboard events, pointer events, window  File: gcl-tk.info, Node: tk-listbox-single-select, Next: lower, Prev: grab, Up: Control 3.8 tk-listbox-single-select ============================ tk-listbox-single-select \- Allow only one selected element in listbox(es) Synopsis -------- tk-listbox-single-select arg ?arg arg ...? Description ----------- This command is a Tcl procedure provided as part of the Tk script library. It takes as arguments the path names of one or more listbox widgets, or the value Listbox. For each named widget, tk-listbox-single-select modifies the bindings of the widget so that only a single element may be selected at a time (the normal configuration allows multiple elements to be selected). If the keyword Listbox is among the window arguments, then the class bindings for listboxes are changed so that all listboxes have the one-selection-at-a-time behavior. Keywords -------- listbox, selection  File: gcl-tk.info, Node: lower, Next: tk-menu-bar, Prev: tk-listbox-single-select, Up: Control 3.9 lower ========= lower \- Change a window's position in the stacking order Synopsis -------- lower window ?belowThis? Description ----------- If the belowThis argument is omitted then the command lowers window so that it is below all of its siblings in the stacking order (it will be obscured by any siblings that overlap it and will not obscure any siblings). If belowThis is specified then it must be the path name of a window that is either a sibling of window or the descendant of a sibling of window. In this case the lower command will insert window into the stacking order just below belowThis (or the ancestor of belowThis that is a sibling of window); this could end up either raising or lowering window. Keywords -------- lower, obscure, stacking order  File: gcl-tk.info, Node: tk-menu-bar, Next: option, Prev: lower, Up: Control 3.10 tk-menu-bar ================ tk-menu-bar, tk_bindForTraversal \- Support for menu bars Synopsis -------- tk-menu-bar frame ?menu menu ...? tk_bindForTraversal arg arg ... Description ----------- These two commands are Tcl procedures in the Tk script library. They provide support for menu bars. A menu bar is a frame that contains a collection of menu buttons that work together, so that the user can scan from one menu to another with the mouse: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. Menus in a menu bar can also be accessed using keyboard traversal (i.e. by typing keystrokes instead of using the mouse). In order for an application to use these procedures, it must do three things, which are described in the paragraphs below. First, each application must call tk-menu-bar to provide information about the menubar. The frame argument gives the path name of the frame that contains all of the menu buttons, and the menu arguments give path names for all of the menu buttons associated with the menu bar. Normally frame is the parent of each of the menu's. This need not be the case, but frame must be an ancestor of each of the menu's in order for grabs to work correctly when the mouse is used to pull down menus. The order of the menu arguments determines the traversal order for the menu buttons. If tk-menu-bar is called without any menu arguments, it returns a list containing the current menu buttons for frame, or an empty string if frame isn't currently set up as a menu bar. If tk-menu-bar is called with a single menu argument consisting of an empty string, any menubar information for frame is removed; from now on the menu buttons will function independently without keyboard traversal. Only one menu bar may be defined at a time within each top-level window. The second thing an application must do is to identify the traversal characters for menu buttons and menu entries. This is done by underlining those characters using the :underline options for the widgets. The menu traversal system uses this information to traverse the menus under keyboard control (see below). The third thing that an application must do is to make sure that the input focus is always in a window that has been configured to support menu traversal. If the input focus is none then input characters will be discarded and no menu traversal will be possible. If you have no other place to set the focus, set it to the menubar widget: tk-menu-bar creates bindings for its frame argument to support menu traversal. The Tk startup scripts configure all the Tk widget classes with bindings to support menu traversal, so menu traversal will be possible regardless of which widget has the focus. If your application defines new classes of widgets that support the input focus, then you should call tk_bindForTraversal for each of these classes. Tk_bindForTraversal takes any number of arguments, each of which is a widget path name or widget class name. It sets up bindings for all the named widgets and classes so that the menu traversal system will be invoked when appropriate keystrokes are typed in those widgets or classes. "Menu Traversal Bindings" ------------------------- Once an application has made the three arrangements described above, menu traversal will be available. At any given time, the only menus available for traversal are those associated with the top-level window containing the input focus. Menu traversal is initiated by one of the following actions: [1] If is typed, then the first menu button in the list for the top-level window is posted and the first entry within that menu is selected. [2] If is pressed, then the menu button that has key as its underlined character is posted and the first entry within that menu is selected. The comparison between key and the underlined characters ignores case differences. If no menu button matches key then the keystroke has no effect. [3] Clicking mouse button 1 on a menu button posts that menu and selects its first entry. Once a menu has been posted, the input focus is switched to that menu and the following actions are possible: [1] Typing or clicking mouse button 1 outside the menu button or its menu will abort the menu traversal. [2] If is pressed, then the entry in the posted menu whose underlined character is key is invoked. This causes the menu to be unposted, the entry's action to be taken, and the menu traversal to end. The comparison between key and underlined characters ignores case differences. If no menu entry matches key then the keystroke is ignored. [3] The arrow keys may be used to move among entries and menus. The left and right arrow keys move circularly among the available menus and the up and down arrow keys move circularly among the entries in the current menu. [4] If is pressed, the selected entry in the posted menu is invoked, which causes the menu to be unposted, the entry's action to be taken, and the menu traversal to end. When a menu traversal completes, the input focus reverts to the window that contained it when the traversal started. Keywords -------- keyboard traversal, menu, menu bar, post  File: gcl-tk.info, Node: option, Next: options, Prev: tk-menu-bar, Up: Control 3.11 option =========== option \- Add/retrieve window options to/from the option database Synopsis -------- option :add pattern value ?priority? option :clear option :get window name class option :readfile fileName ?priority? Description ----------- The option command allows you to add entries to the Tk option database or to retrieve options from the database. The add form of the command adds a new option to the database. Pattern contains the option being specified, and consists of names and/or classes separated by asterisks or dots, in the usual X format. Value contains a text string to associate with pattern; this is the value that will be returned in calls to Tk_GetOption or by invocations of the option :get command. If priority is specified, it indicates the priority level for this option (see below for legal values); it defaults to interactive. This command always returns an empty string. The option :clear command clears the option database. Default options (in the RESOURCE_MANAGER property or the .Xdefaults file) will be reloaded automatically the next time an option is added to the database or removed from it. This command always returns an empty string. The option :get command returns the value of the option specified for window under name and class. If several entries in the option database match window, name, and class, then the command returns whichever was created with highest priority level. If there are several matching entries at the same priority level, then it returns whichever entry was most recently entered into the option database. If there are no matching entries, then the empty string is returned. The readfile form of the command reads fileName, which should have the standard format for an X resource database such as .Xdefaults, and adds all the options specified in that file to the option database. If priority is specified, it indicates the priority level at which to enter the options; priority defaults to interactive. The priority arguments to the option command are normally specified symbolically using one of the following values: widgetDefault Level 20. Used for default values hard-coded into widgets. startupFile Level 40. Used for options specified in application-specific startup files. userDefault Level 60. Used for options specified in user-specific defaults files, such as .Xdefaults, resource databases loaded into the X server, or user-specific startup files. interactive Level 80. Used for options specified interactively after the application starts running. If priority isn't specified, it defaults to this level. Any of the above keywords may be abbreviated. In addition, priorities may be specified numerically using integers between 0 and 100, inclusive. The numeric form is probably a bad idea except for new priority levels other than the ones given above. Keywords -------- database, option, priority, retrieve  File: gcl-tk.info, Node: options, Next: pack-old, Prev: option, Up: Control 3.12 options ============ options \- Standard options supported by widgets Description ----------- This manual entry describes the common configuration options supported by widgets in the Tk toolkit. Every widget does not necessarily support every option (see the manual entries for individual widgets for a list of the standard options supported by that widget), but if a widget does support an option with one of the names listed below, then the option has exactly the effect described below. In the descriptions below, "Name" refers to the option's name in the option database (e.g. in .Xdefaults files). "Class" refers to the option's class value in the option database. "Command-Line Switch" refers to the switch used in widget-creation and configure widget commands to set this value. For example, if an option's command-line switch is :foreground and there exists a widget .a.b.c, then the command (.a.b.c :configure :foreground "black") may be used to specify the value black for the option in the the widget .a.b.c. Command-line switches may be abbreviated, as long as the abbreviation is unambiguous. ':activebackground' Name='"activeBackground" Class="Foreground"' Specifies background color to use when drawing active elements. An element (a widget or portion of a widget) is active if the mouse cursor is positioned over the element and pressing a mouse button will cause some action to occur. ':activeborderwidth' Name='"activeBorderWidth" Class="BorderWidth"' Specifies a non-negative value indicating the width of the 3-D border drawn around active elements. See above for definition of active elements. The value may have any of the forms acceptable to Tk_GetPixels. This option is typically only available in widgets displaying more than one element at a time (e.g. menus but not buttons). ':activeforeground' Name='"activeForeground" Class="Background"' Specifies foreground color to use when drawing active elements. See above for definition of active elements. ':anchor' Name='"anchor" Class="Anchor"' Specifies how the information in a widget (e.g. text or a bitmap) is to be displayed in the widget. Must be one of the values n, ne, e, se, s, sw, w, nw, or center. For example, nw means display the information such that its top-left corner is at the top-left corner of the widget. ':background or :bg' Name='"background" Class="Background"' Specifies the normal background color to use when displaying the widget. ':bitmap' Name='"bitmap" Class="Bitmap"' Specifies a bitmap to display in the widget, in any of the forms acceptable to Tk_GetBitmap. The exact way in which the bitmap is displayed may be affected by other options such as anchor or justify. Typically, if this option is specified then it overrides other options that specify a textual value to display in the widget; the bitmap option may be reset to an empty string to re-enable a text display. ':borderwidth or :bd' Name='"borderWidth" Class="BorderWidth"' Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the widget (if such a border is being drawn; the relief option typically determines this). The value may also be used when drawing 3-D effects in the interior of the widget. The value may have any of the forms acceptable to Tk_GetPixels. ':cursor' Name='"cursor" Class="Cursor"' Specifies the mouse cursor to be used for the widget. The value may have any of the forms acceptable to Tk_GetCursor. ':cursorbackground' Name='"cursorBackground" Class="Foreground"' Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). \fIThis option is obsolete and is gradually being replaced by the insertBackground option. ':cursorborderwidth' Name='"cursorBorderWidth" Class="BorderWidth"' Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. \fIThis option is obsolete and is gradually being replaced by the insertBorderWidth option. ':cursorofftime' Name='"cursorOffTime" Class="OffTime"' Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain "off" in each blink cycle. If this option is zero then the cursor doesn't blink: it is on all the time. \fIThis option is obsolete and is gradually being replaced by the insertOffTime option. ':cursorontime' Name='"cursorOnTime" Class="OnTime"' Specifies a non-negative integer value indicating the number of milliseconds the cursor should remain "on" in each blink cycle. \fIThis option is obsolete and is gradually being replaced by the insertOnTime option. ':cursorwidth' Name='"cursorWidth" Class="CursorWidth"' Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. If a border has been specified for the cursor (using the cursorBorderWidth option), the border will be drawn inside the width specified by the cursorWidth option. \fIThis option is obsolete and is gradually being replaced by the insertWidth option. ':disabledforeground' Name='"disabledForeground" Class="DisabledForeground"' Specifies foreground color to use when drawing a disabled element. If the option is specified as an empty string (which is typically the case on monochrome displays), disabled elements are drawn with the normal fooreground color but they are dimmed by drawing them with a stippled fill pattern. ':exportselection' Name='"exportSelection" Class="ExportSelection"' Specifies whether or not a selection in the widget should also be the X selection. The value may have any of the forms accepted by Tcl_GetBoolean, such as true, false, 0, 1, yes, or no. If the selection is exported, then selecting in the widget deselects the current X selection, selecting outside the widget deselects any widget selection, and the widget will respond to selection retrieval requests when it has a selection. The default is usually for widgets to export selections. ':font' Name='"font" Class="Font"' Specifies the font to use when drawing text inside the widget. ':foreground or :fg' Name='"foreground" Class="Foreground"' Specifies the normal foreground color to use when displaying the widget. ':geometry' Name='"geometry" Class="Geometry"' Specifies the desired geometry for the widget's window, in the form widthxheight, where width is the desired width of the window and height is the desired height. The units for width and height depend on the particular widget. For widgets displaying text the units are usually the size of the characters in the font being displayed; for other widgets the units are usually pixels. ':insertbackground' Name='"insertBackground" Class="Foreground"' Specifies the color to use as background in the area covered by the insertion cursor. This color will normally override either the normal background for the widget (or the selection background if the insertion cursor happens to fall in the selection). ':insertborderwidth' Name='"insertBorderWidth" Class="BorderWidth"' Specifies a non-negative value indicating the width of the 3-D border to draw around the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. ':insertofftime' Name='"insertOffTime" Class="OffTime"' Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain "off" in each blink cycle. If this option is zero then the cursor doesn't blink: it is on all the time. ':insertontime' Name='"insertOnTime" Class="OnTime"' Specifies a non-negative integer value indicating the number of milliseconds the insertion cursor should remain "on" in each blink cycle. ':insertwidth' Name='"insertWidth" Class="InsertWidth"' Specifies a value indicating the total width of the insertion cursor. The value may have any of the forms acceptable to Tk_GetPixels. If a border has been specified for the insertion cursor (using the insertBorderWidth option), the border will be drawn inside the width specified by the insertWidth option. ':orient' Name='"orient" Class="Orient"' For widgets that can lay themselves out with either a horizontal or vertical orientation, such as scrollbars, this option specifies which orientation should be used. Must be either horizontal or vertical or an abbreviation of one of these. ':padx' Name='"padX" Class="Pad"' Specifies a non-negative value indicating how much extra space to request for the widget in the X-direction. The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs, the widget will add this amount to the width it would normally need (as determined by the width of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space to the left and/or right of what it displays inside. ':pady' Name='"padY" Class="Pad"' Specifies a non-negative value indicating how much extra space to request for the widget in the Y-direction. The value may have any of the forms acceptable to Tk_GetPixels. When computing how large a window it needs, the widget will add this amount to the height it would normally need (as determined by the height of the things displayed in the widget); if the geometry manager can satisfy this request, the widget will end up with extra internal space above and/or below what it displays inside. ':relief' Name='"relief" Class="Relief"' Specifies the 3-D effect desired for the widget. Acceptable values are raised, sunken, flat, ridge, and groove. The value indicates how the interior of the widget should appear relative to its exterior; for example, raised means the interior of the widget should appear to protrude from the screen, relative to the exterior of the widget. ':repeatdelay' Name='"repeatDelay" Class="RepeatDelay"' Specifies the number of milliseconds a button or key must be held down before it begins to auto-repeat. Used, for example, on the up- and down-arrows in scrollbars. ':repeatinterval' Name='"repeatInterval" Class="RepeatInterval"' Used in conjunction with repeatDelay: once auto-repeat begins, this option determines the number of milliseconds between auto-repeats. ':scrollcommand' Name='"scrollCommand" Class="ScrollCommand"' Specifies the prefix for a command used to communicate with scrollbar widgets. When the view in the widget's window changes (or whenever anything else occurs that could change the display in a scrollbar, such as a change in the total size of the widget's contents), the widget will generate a Tcl command by concatenating the scroll command and four numbers. The four numbers are, in order: the total size of the widget's contents, in unspecified units ("unit" is a widget-specific term; for widgets displaying text, the unit is a line); the maximum number of units that may be displayed at once in the widget's window, given its current size; the index of the top-most or left-most unit currently visible in the window (index 0 corresponds to the first unit); and the index of the bottom-most or right-most unit currently visible in the window. This command is then passed to the Tcl interpreter for execution. Typically the scrollCommand option consists of the path name of a scrollbar widget followed by "set", e.g. ".x.scrollbar set": this will cause the scrollbar to be updated whenever the view in the window changes. If this option is not specified, then no command will be executed. The scrollCommand option is used for widgets that support scrolling in only one direction. For widgets that support scrolling in both directions, this option is replaced with the xScrollCommand and yScrollCommand options. ':selectbackground' Name='"selectBackground" Class="Foreground"' Specifies the background color to use when displaying selected items. ':selectborderwidth' Name='"selectBorderWidth" Class="BorderWidth"' Specifies a non-negative value indicating the width of the 3-D border to draw around selected items. The value may have any of the forms acceptable to Tk_GetPixels. ':selectforeground' Name='"selectForeground" Class="Background"' Specifies the foreground color to use when displaying selected items. ':setgrid' Name='"setGrid" Class="SetGrid"' Specifies a boolean value that determines whether this widget controls the resizing grid for its top-level window. This option is typically used in text widgets, where the information in the widget has a natural size (the size of a character) and it makes sense for the window's dimensions to be integral numbers of these units. These natural window sizes form a grid. If the setGrid option is set to true then the widget will communicate with the window manager so that when the user interactively resizes the top-level window that contains the widget, the dimensions of the window will be displayed to the user in grid units and the window size will be constrained to integral numbers of grid units. See the section GRIDDED GEOMETRY MANAGEMENT in the wm manual entry for more details. ':text' Name='"text" Class="Text"' Specifies a string to be displayed inside the widget. The way in which the string is displayed depends on the particular widget and may be determined by other options, such as anchor or justify. ':textvariable' Name='"textVariable" Class="Variable"' Specifies the name of a variable. The value of the variable is a text string to be displayed inside the widget; if the variable value changes then the widget will automatically update itself to reflect the new value. The way in which the string is displayed in the widget depends on the particular widget and may be determined by other options, such as anchor or justify. ':underline' Name='"underline" Class="Underline"' Specifies the integer index of a character to underline in the widget. This option is typically used to indicate keyboard traversal characters in menu buttons and menu entries. 0 corresponds to the first character of the text displayed in the widget, 1 to the next character, and so on. ':xscrollcommand' Name='"xScrollCommand" Class="ScrollCommand"' Specifies the prefix for a command used to communicate with horizontal scrollbars. This option is treated in the same way as the scrollCommand option, except that it is used for horizontal scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of scrollCommand for complete details on how this option is used. ':yscrollcommand' Name='"yScrollCommand" Class="ScrollCommand"' Specifies the prefix for a command used to communicate with vertical scrollbars. This option is treated in the same way as the scrollCommand option, except that it is used for vertical scrollbars associated with widgets that support both horizontal and vertical scrolling. See the description of scrollCommand for complete details on how this option is used. Keywords -------- class, name, standard option, switch  File: gcl-tk.info, Node: pack-old, Next: pack, Prev: options, Up: Control 3.13 pack-old ============= pack \- Obsolete syntax for packer geometry manager Synopsis -------- pack after sibling window options ?window options ...? pack append parent window options ?window options ...? pack before sibling window options ?window options ...? pack info parent pack unpack window Description ----------- Note: this manual entry describes the syntax for the pack\fI command as it before Tk version 3.3. Although this syntax continues to be supported for backward compatibility, it is obsolete and should not be used anymore. At some point in the future it may cease to be supported. The packer is a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The first child is placed against one side of the window, occupying the entire span of the window along that side. This reduces the space remaining for other children as if the side had been moved in by the size of the first child. Then the next child is placed against one side of the remaining cavity, and so on until all children have been placed or there is no space left in the cavity. The before, after, and append forms of the pack command are used to insert one or more children into the packing order for their parent. The before form inserts the children before window sibling in the order; all of the other windows must be siblings of sibling. The after form inserts the windows after sibling, and the append form appends one or more windows to the end of the packing order for parent. If a window named in any of these commands is already packed in its parent, it is removed from its current position in the packing order and repositioned as indicated by the command. All of these commands return an empty string as result. The unpack form of the pack command removes window from the packing order of its parent and unmaps it. After the execution of this command the packer will no longer manage window's geometry. The placement of each child is actually a four-step process; the options argument following each window consists of a list of one or more fields that govern the placement of that window. In the discussion below, the term cavity refers to the space left in a parent when a particular child is placed (i.e. all the space that wasn't claimed by earlier children in the packing order). The term parcel refers to the space allocated to a particular child; this is not necessarily the same as the child window's final geometry. The first step in placing a child is to determine which side of the cavity it will lie against. Any one of the following options may be used to specify a side: top Position the child's parcel against the top of the cavity, occupying the full width of the cavity. bottom Position the child's parcel against the bottom of the cavity, occupying the full width of the cavity. left Position the child's parcel against the left side of the cavity, occupying the full height of the cavity. right Position the child's parcel against the right side of the cavity, occupying the full height of the cavity. At most one of these options should be specified for any given window. If no side is specified, then the default is top. The second step is to decide on a parcel for the child. For top and bottom windows, the desired parcel width is normally the cavity width and the desired parcel height is the window's requested height, as passed to Tk_GeometryRequest. For left and right windows, the desired parcel height is normally the cavity height and the desired width is the window's requested width. However, extra space may be requested for the window using any of the following options: padx num Add num pixels to the window's requested width before computing the parcel size as described above. pady num Add num pixels to the window's requested height before computing the parcel size as described above. expand This option requests that the window's parcel absorb any extra space left over in the parent's cavity after packing all the children. The amount of space left over depends on the sizes requested by the other children, and may be zero. If several windows have all specified expand then the extra width will be divided equally among all the left and right windows that specified expand and the extra height will be divided equally among all the top and bottom windows that specified expand. If the desired width or height for a parcel is larger than the corresponding dimension of the cavity, then the cavity's dimension is used instead. The third step in placing the window is to decide on the window's width and height. The default is for the window to receive either its requested width and height or the those of the parcel, whichever is smaller. If the parcel is larger than the window's requested size, then the following options may be used to expand the window to partially or completely fill the parcel: fill Set the window's size to equal the parcel size. fillx Increase the window's width to equal the parcel's width, but retain the window's requested height. filly Increase the window's height to equal the parcel's height, but retain the window's requested width. The last step is to decide the window's location within its parcel. If the window's size equals the parcel's size, then the window simply fills the entire parcel. If the parcel is larger than the window, then one of the following options may be used to specify where the window should be positioned within its parcel: frame center Center the window in its parcel. This is the default if no framing option is specified. frame n Position the window with its top edge centered on the top edge of the parcel. frame ne Position the window with its upper-right corner at the upper-right corner of the parcel. frame e Position the window with its right edge centered on the right edge of the parcel. frame se Position the window with its lower-right corner at the lower-right corner of the parcel. frame s Position the window with its bottom edge centered on the bottom edge of the parcel. frame sw Position the window with its lower-left corner at the lower-left corner of the parcel. frame w Position the window with its left edge centered on the left edge of the parcel. frame nw Position the window with its upper-left corner at the upper-left corner of the parcel. The pack info command may be used to retrieve information about the packing order for a parent. It returns a list in the form window options window options ... Each window is a name of a window packed in parent, and the following options describes all of the options for that window, just as they would be typed to pack append. The order of the list is the same as the packing order for parent. The packer manages the mapped/unmapped state of all the packed children windows. It automatically maps the windows when it packs them, and it unmaps any windows for which there was no space left in the cavity. The packer makes geometry requests on behalf of the parent windows it manages. For each parent window it requests a size large enough to accommodate all the options specified by all the packed children, such that zero space would be leftover for expand options. Keywords -------- geometry manager, location, packer, parcel, size  File: gcl-tk.info, Node: pack, Next: place, Prev: pack-old, Up: Control 3.14 pack ========= pack \- Geometry manager that packs around edges of cavity Synopsis -------- pack option arg ?arg ...? Description ----------- The pack command is used to communicate with the packer, a geometry manager that arranges the children of a parent by packing them in order around the edges of the parent. The pack command can have any of several forms, depending on the option argument: pack slave ?slave ...? ?options? If the first argument to pack is a window name (any value starting with "."), then the command is processed in the same way as pack configure. pack configure slave ?slave ...? ?options? The arguments consist of the names of one or more slave windows followed by pairs of arguments that specify how to manage the slaves. See "THE PACKER ALGORITHM" below for details on how the options are used by the packer. The following options are supported: :after other Other must the name of another window. Use its master as the master for the slaves, and insert the slaves just after other in the packing order. :anchor anchor Anchor must be a valid anchor position such as n or sw; it specifies where to position each slave in its parcel. Defaults to center. :before other Other must the name of another window. Use its master as the master for the slaves, and insert the slaves just before other in the packing order. :expand boolean Specifies whether the slaves should be expanded to consume extra space in their master. Boolean may have any proper boolean value, such as 1 or no. Defaults to 0. :fill style If a slave's parcel is larger than its requested dimensions, this option may be used to stretch the slave. Style must have one of the following values: none Give the slave its requested dimensions plus any internal padding requested with :ipadx or :ipady. This is the default. x Stretch the slave horizontally to fill the entire width of its parcel (except leave external padding as specified by :padx). y Stretch the slave vertically to fill the entire height of its parcel (except leave external padding as specified by :pady). both Stretch the slave both horizontally and vertically. :in other Insert the slave(s) at the end of the packing order for the master window given by other. :ipadx amount Amount specifies how much horizontal internal padding to leave on each side of the slave(s). Amount must be a valid screen distance, such as 2 or .5c. It defaults to 0. :ipady amount Amount specifies how much vertical internal padding to leave on each side of the slave(s). Amount defaults to 0. :padx amount Amount specifies how much horizontal external padding to leave on each side of the slave(s). Amount defaults to 0. :pady amount Amount specifies how much vertical external padding to leave on each side of the slave(s). Amount defaults to 0. :side side Specifies which side of the master the slave(s) will be packed against. Must be left, right, top, or bottom. Defaults to top. If no :in, :after or :before option is specified then each of the slaves will be inserted at the end of the packing list for its parent unless it is already managed by the packer (in which case it will be left where it is). If one of these options is specified then all the slaves will be inserted at the specified point. If any of the slaves are already managed by the geometry manager then any unspecified options for them retain their previous values rather than receiving default values. .RE pack :forget slave ?slave ...? Removes each of the slaves from the packing order for its master and unmaps their windows. The slaves will no longer be managed by the packer. pack :newinfo slave Returns a list whose elements are the current configuration state of the slave given by slave in the same option-value form that might be specified to pack configure. The first two elements of the list are ":in master" where master is the slave's master. Starting with Tk 4.0 this option will be renamed "pack info". pack :propagate master ?boolean? If boolean has a true boolean value such as 1 or on then propagation is enabled for master, which must be a window name (see "GEOMETRY PROPAGATION" below). If boolean has a false boolean value then propagation is disabled for master. In either of these cases an empty string is returned. If boolean is omitted then the command returns 0 or 1 to indicate whether propagation is currently enabled for master. Propagation is enabled by default. pack :slaves master Returns a list of all of the slaves in the packing order for master. The order of the slaves in the list is the same as their order in the packing order. If master has no slaves then an empty string is returned. "The Packer Algorithm" ---------------------- For each master the packer maintains an ordered list of slaves called the packing list. The :in, :after, and :before configuration options are used to specify the master for each slave and the slave's position in the packing list. If none of these options is given for a slave then the slave is added to the end of the packing list for its parent. The packer arranges the slaves for a master by scanning the packing list in order. At the time it processes each slave, a rectangular area within the master is still unallocated. This area is called the cavity; for the first slave it is the entire area of the master. For each slave the packer carries out the following steps: [1] The packer allocates a rectangular parcel for the slave along the side of the cavity given by the slave's :side option. If the side is top or bottom then the width of the parcel is the width of the cavity and its height is the requested height of the slave plus the :ipady and :pady options. For the left or right side the height of the parcel is the height of the cavity and the width is the requested width of the slave plus the :ipadx and :padx options. The parcel may be enlarged further because of the :expand option (see "EXPANSION" below) [2] The packer chooses the dimensions of the slave. The width will normally be the slave's requested width plus twice its :ipadx option and the height will normally be the slave's requested height plus twice its :ipady option. However, if the :fill option is x or both then the width of the slave is expanded to fill the width of the parcel, minus twice the :padx option. If the :fill option is y or both then the height of the slave is expanded to fill the width of the parcel, minus twice the :pady option. [3] The packer positions the slave over its parcel. If the slave is smaller than the parcel then the :anchor option determines where in the parcel the slave will be placed. If :padx or :pady is non-zero, then the given amount of external padding will always be left between the slave and the edges of the parcel. Once a given slave has been packed, the area of its parcel is subtracted from the cavity, leaving a smaller rectangular cavity for the next slave. If a slave doesn't use all of its parcel, the unused space in the parcel will not be used by subsequent slaves. If the cavity should become too small to meet the needs of a slave then the slave will be given whatever space is left in the cavity. If the cavity shrinks to zero size, then all remaining slaves on the packing list will be unmapped from the screen until the master window becomes large enough to hold them again. "Expansion" ----------- If a master window is so large that there will be extra space left over after all of its slaves have been packed, then the extra space is distributed uniformly among all of the slaves for which the :expand option is set. Extra horizontal space is distributed among the expandable slaves whose :side is left or right, and extra vertical space is distributed among the expandable slaves whose :side is top or bottom. "Geometry Propagation" ---------------------- The packer normally computes how large a master must be to just exactly meet the needs of its slaves, and it sets the requested width and height of the master to these dimensions. This causes geometry information to propagate up through a window hierarchy to a top-level window so that the entire sub-tree sizes itself to fit the needs of the leaf windows. However, the pack propagate command may be used to turn off propagation for one or more masters. If propagation is disabled then the packer will not set the requested width and height of the packer. This may be useful if, for example, you wish for a master window to have a fixed size that you specify. "Restrictions On Master Windows" -------------------------------- The master for each slave must either be the slave's parent (the default) or a descendant of the slave's parent. This restriction is necessary to guarantee that the slave can be placed over any part of its master that is visible without danger of the slave being clipped by its parent. "Packing Order" --------------- If the master for a slave is not its parent then you must make sure that the slave is higher in the stacking order than the master. Otherwise the master will obscure the slave and it will appear as if the slave hasn't been packed correctly. The easiest way to make sure the slave is higher than the master is to create the master window first: the most recently created window will be highest in the stacking order. Or, you can use the raise and lower commands to change the stacking order of either the master or the slave. Keywords -------- geometry manager, location, packer, parcel, propagation, size gcl-2.6.14/info/chap-1.texi0000644000175000017500000035630314360276512013704 0ustar cammcamm @node Introduction (Introduction), Syntax, Top, Top @chapter Introduction @menu * Scope:: * Organization of the Document:: * Referenced Publications:: * Definitions:: * Conformance:: * Language Extensions:: * Language Subsets:: * Deprecated Language Features:: * Symbols in the COMMON-LISP Package:: @end menu @node Scope, Organization of the Document, Introduction (Introduction), Introduction (Introduction) @section Scope, Purpose, and History @c including concept-history @menu * Scope and Purpose:: * History:: @end menu @node Scope and Purpose, History, Scope, Scope @subsection Scope and Purpose The specification set forth in this document is designed to promote the portability of @r{Common Lisp} programs among a variety of data processing systems. It is a language specification aimed at an audience of implementors and knowledgeable programmers. It is neither a tutorial nor an implementation guide. @node History, , Scope and Purpose, Scope @subsection History Lisp is a family of languages with a long history. Early key ideas in Lisp were developed by John McCarthy during the 1956 Dartmouth Summer Research Project on Artificial Intelligence. McCarthy's motivation was to develop an algebraic list processing language for artificial intelligence work. Implementation efforts for early dialects of Lisp were undertaken on the IBM~704, the IBM~7090, the Digital Equipment Corporation (DEC) PDP-1, the DEC~PDP-6, and the PDP-10. The primary dialect of Lisp between 1960 and 1965 was Lisp~1.5. By the early 1970's there were two predominant dialects of Lisp, both arising from these early efforts: MacLisp and Interlisp. For further information about very early Lisp dialects, see @b{The Anatomy of Lisp} or @b{Lisp 1.5 Programmer's Manual}. MacLisp improved on the Lisp~1.5 notion of special variables and error handling. MacLisp also introduced the concept of functions that could take a variable number of arguments, macros, arrays, non-local dynamic exits, fast arithmetic, the first good Lisp compiler, and an emphasis on execution speed. By the end of the 1970's, MacLisp was in use at over 50 sites. For further information about Maclisp, see @b{Maclisp Reference Manual, Revision~0} or @b{The Revised Maclisp Manual}. Interlisp introduced many ideas into Lisp programming environments and methodology. One of the Interlisp ideas that influenced @r{Common Lisp} was an iteration construct implemented by Warren Teitelman that inspired the @b{loop} macro used both on the Lisp Machines and in MacLisp, and now in @r{Common Lisp}. For further information about Interlisp, see @b{Interlisp Reference Manual}. Although the first implementations of Lisp were on the IBM~704 and the IBM~7090, later work focussed on the DEC PDP-6 and, later, PDP-10 computers, the latter being the mainstay of Lisp and artificial intelligence work at such places as Massachusetts Institute of Technology (MIT), Stanford University, and Carnegie Mellon University (CMU) from the mid-1960's through much of the 1970's. The PDP-10 computer and its predecessor the PDP-6 computer were, by design, especially well-suited to Lisp because they had 36-bit words and 18-bit addresses. This architecture allowed a @i{cons} cell to be stored in one word; single instructions could extract the @i{car} and @i{cdr} parts. The PDP-6 and PDP-10 had fast, powerful stack instructions that enabled fast function calling. But the limitations of the PDP-10 were evident by 1973: it supported a small number of researchers using Lisp, and the small, 18-bit address space (2^18 = 262,144 words) limited the size of a single program. One response to the address space problem was the Lisp Machine, a special-purpose computer designed to run Lisp programs. The other response was to use general-purpose computers with address spaces larger than 18~bits, such as the DEC VAX and the S-1~Mark~IIA. For further information about S-1 Common Lisp, see @b{S-1 Common Lisp Implementation}. The Lisp machine concept was developed in the late 1960's. In the early 1970's, Peter Deutsch, working with Daniel Bobrow, implemented a Lisp on the Alto, a single-user minicomputer, using microcode to interpret a byte-code implementation language. Shortly thereafter, Richard Greenblatt began work on a different hardware and instruction set design at MIT. Although the Alto was not a total success as a Lisp machine, a dialect of Interlisp known as Interlisp-D became available on the D-series machines manufactured by Xerox---the Dorado, Dandelion, Dandetiger, and Dove (or Daybreak). An upward-compatible extension of MacLisp called Lisp Machine Lisp became available on the early MIT Lisp Machines. Commercial Lisp machines from Xerox, Lisp Machines (LMI), and Symbolics were on the market by 1981. For further information about Lisp Machine Lisp, see @b{Lisp Machine Manual}. During the late 1970's, Lisp Machine Lisp began to expand towards a much fuller language. Sophisticated lambda lists, @t{setf}, multiple values, and structures like those in @r{Common Lisp} are the results of early experimentation with programming styles by the Lisp Machine group. Jonl White and others migrated these features to MacLisp. Around 1980, Scott Fahlman and others at CMU began work on a Lisp to run on the Scientific Personal Integrated Computing Environment (SPICE) workstation. One of the goals of the project was to design a simpler dialect than Lisp Machine Lisp. The Macsyma group at MIT began a project during the late 1970's called the New Implementation of Lisp (NIL) for the VAX, which was headed by White. One of the stated goals of the NIL project was to fix many of the historic, but annoying, problems with Lisp while retaining significant compatibility with MacLisp. At about the same time, a research group at Stanford University and Lawrence Livermore National Laboratory headed by Richard P. Gabriel began the design of a Lisp to run on the S-1~Mark~IIA supercomputer. S-1~Lisp, never completely functional, was the test bed for adapting advanced compiler techniques to Lisp implementation. Eventually the S-1 and NIL groups collaborated. For further information about the NIL project, see @b{NIL---A Perspective}. The first effort towards Lisp standardization was made in 1969, when Anthony Hearn and Martin Griss at the University of Utah defined Standard Lisp---a subset of Lisp~1.5 and other dialects---to transport REDUCE, a symbolic algebra system. During the 1970's, the Utah group implemented first a retargetable optimizing compiler for Standard Lisp, and then an extended implementation known as Portable Standard Lisp (PSL). By the mid 1980's, PSL ran on about a dozen kinds of computers. For further information about Standard Lisp, see @b{Standard LISP Report}. PSL and Franz Lisp---a MacLisp-like dialect for Unix machines---were the first examples of widely available Lisp dialects on multiple hardware platforms. One of the most important developments in Lisp occurred during the second half of the 1970's: Scheme. Scheme, designed by Gerald J. Sussman and Guy L. Steele Jr., is a simple dialect of Lisp whose design brought to Lisp some of the ideas from programming language semantics developed in the 1960's. Sussman was one of the prime innovators behind many other advances in Lisp technology from the late 1960's through the 1970's. The major contributions of Scheme were lexical scoping, lexical closures, first-class continuations, and simplified syntax (no separation of value cells and function cells). Some of these contributions made a large impact on the design of @r{Common Lisp}. For further information about Scheme, see @b{IEEE Standard for the Scheme Programming Language} or @b{Revised^3 Report on the Algorithmic Language Scheme}. In the late 1970's object-oriented programming concepts started to make a strong impact on Lisp. At MIT, certain ideas from Smalltalk made their way into several widely used programming systems. Flavors, an object-oriented programming system with multiple inheritance, was developed at MIT for the Lisp machine community by Howard Cannon and others. At Xerox, the experience with Smalltalk and Knowledge Representation Language (KRL) led to the development of Lisp Object Oriented Programming System (LOOPS) and later Common LOOPS. For further information on Smalltalk, see @b{Smalltalk-80: The Language and its Implementation}. For further information on Flavors, see @b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}. These systems influenced the design of the Common Lisp Object System (CLOS). CLOS was developed specifically for this standardization effort, and was separately written up in @b{Common Lisp Object System Specification}. However, minor details of its design have changed slightly since that publication, and that paper should not be taken as an authoritative reference to the semantics of the object system as described in this document. In 1980 Symbolics and LMI were developing Lisp Machine Lisp; stock-hardware implementation groups were developing NIL, Franz Lisp, and PSL; Xerox was developing Interlisp; and the SPICE project at CMU was developing a MacLisp-like dialect of Lisp called SpiceLisp. In April 1981, after a DARPA-sponsored meeting concerning the splintered Lisp community, Symbolics, the SPICE project, the NIL project, and the S-1~Lisp project joined together to define @r{Common Lisp}. Initially spearheaded by White and Gabriel, the driving force behind this grassroots effort was provided by Fahlman, Daniel Weinreb, David Moon, Steele, and Gabriel. @r{Common Lisp} was designed as a description of a family of languages. The primary influences on @r{Common Lisp} were Lisp Machine Lisp, MacLisp, NIL, S-1~Lisp, Spice Lisp, and Scheme. @i{Common Lisp: The Language} is a description of that design. Its semantics were intentionally underspecified in places where it was felt that a tight specification would overly constrain @r{Common Lisp} research and use. In 1986 X3J13 was formed as a technical working group to produce a draft for an ANSI @r{Common Lisp} standard. Because of the acceptance of @r{Common Lisp}, the goals of this group differed from those of the original designers. These new goals included stricter standardization for portability, an object-oriented programming system, a condition system, iteration facilities, and a way to handle large character sets. To accommodate those goals, a new language specification, this document, was developed. @c end of including concept-history @node Organization of the Document, Referenced Publications, Scope, Introduction (Introduction) @section Organization of the Document @c including concept-organization This is a reference document, not a tutorial document. Where possible and convenient, the order of presentation has been chosen so that the more primitive topics precede those that build upon them; however, linear readability has not been a priority. This document is divided into chapters by topic. Any given chapter might contain conceptual material, dictionary entries, or both. @i{Defined names} within the dictionary portion of a chapter are grouped in a way that brings related topics into physical proximity. Many such groupings were possible, and no deep significance should be inferred from the particular grouping that was chosen. To see @i{defined names} grouped alphabetically, consult the index. For a complete list of @i{defined names}, see @ref{Symbols in the COMMON-LISP Package}. In order to compensate for the sometimes-unordered portions of this document, a glossary has been provided; see @ref{Glossary}. The glossary provides connectivity by providing easy access to definitions of terms, and in some cases by providing examples or cross references to additional conceptual material. For information about notational conventions used in this document, see @ref{Definitions}. For information about conformance, see @ref{Conformance}. For information about extensions and subsets, see @ref{Language Extensions} and @ref{Language Subsets}. For information about how @i{programs} in the language are parsed by the @i{Lisp reader}, see @ref{Syntax}. For information about how @i{programs} in the language are @i{compiled} and @i{executed}, see @ref{Evaluation and Compilation}. For information about data types, see @ref{Types and Classes}. Not all @i{types} and @i{classes} are defined in this chapter; many are defined in chapter corresponding to their topic--for example, the numeric types are defined in @ref{Numbers (Numbers)}. For a complete list of @i{standardized} @i{types}, see @i{Figure~4--2}. For information about general purpose control and data flow, see @ref{Data and Control Flow} or @ref{Iteration}. @c end of including concept-organization @node Referenced Publications, Definitions, Organization of the Document, Introduction (Introduction) @section Referenced Publications @c including concept-references @table @asis @item @t{*} @b{The Anatomy of Lisp}, John Allen, McGraw-Hill, Inc., 1978. @item @t{*} @b{The Art of Computer Programming, Volume 3}, Donald E. Knuth, Addison-Wesley Company (Reading, MA), 1973. @item @t{*} @b{The Art of the Metaobject Protocol}, Kiczales et al., MIT Press (Cambridge, MA), 1991. @item @t{*} @b{Common Lisp Object System Specification}, D. Bobrow, L. DiMichiel, R.P. Gabriel, S. Keene, G. Kiczales, D. Moon, @i{SIGPLAN Notices} V23, September, 1988. @item @t{*} @b{Common Lisp: The Language}, Guy L. Steele Jr., Digital Press (Burlington, MA), 1984. @item @t{*} @b{Common Lisp: The Language, Second Edition}, Guy L. Steele Jr., Digital Press (Bedford, MA), 1990. @item @t{*} @b{Exceptional Situations in Lisp}, Kent M. Pitman, @i{Proceedings of the First European Conference on the Practical Application of LISP\/} (EUROPAL '90), Churchill College, Cambridge, England, March 27-29, 1990. @item @t{*} @b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}, Howard I. Cannon, 1982. @item @t{*} @b{IEEE Standard for Binary Floating-Point Arithmetic}, ANSI/IEEE Std 754-1985, Institute of Electrical and Electronics Engineers, Inc. (New York), 1985. @item @t{*} @b{IEEE Standard for the Scheme Programming Language}, IEEE Std 1178-1990, Institute of Electrical and Electronic Engineers, Inc. (New York), 1991. @item @t{*} @b{Interlisp Reference Manual}, Third Revision, Teitelman, Warren, et al, Xerox Palo Alto Research Center (Palo Alto, CA), 1978. @item @t{*} @r{ISO 6937/2}, @i{Information processing---Coded character sets for text communication---Part 2: Latin alphabetic and non-alphabetic graphic characters}, ISO, 1983. @item @t{*} @b{Lisp 1.5 Programmer's Manual}, John McCarthy, MIT Press (Cambridge, MA), August, 1962. @item @t{*} @b{Lisp Machine Manual}, D.L. Weinreb and D.A. Moon, Artificial Intelligence Laboratory, MIT (Cambridge, MA), July, 1981. @item @t{*} @b{Maclisp Reference Manual, Revision~0}, David A. Moon, Project MAC (Laboratory for Computer Science), MIT (Cambridge, MA), March, 1974. @item @t{*} @b{NIL---A Perspective}, JonL White, @i{Macsyma User's Conference}, 1979. @item @t{*} @b{Performance and Evaluation of Lisp Programs}, Richard P. Gabriel, MIT Press (Cambridge, MA), 1985. @item @t{*} @b{Principal Values and Branch Cuts in Complex APL}, Paul Penfield Jr., @i{APL 81 Conference Proceedings}, ACM SIGAPL (San Francisco, September 1981), 248-256. Proceedings published as @i{APL Quote Quad 12}, 1 (September 1981). @item @t{*} @b{The Revised Maclisp Manual}, Kent M. Pitman, Technical Report 295, Laboratory for Computer Science, MIT (Cambridge, MA), May 1983. @item @t{*} @b{Revised^3 Report on the Algorithmic Language Scheme}, Jonathan Rees and William Clinger (editors), @i{SIGPLAN Notices} V21, #12, December, 1986. @item @t{*} @b{S-1 Common Lisp Implementation}, R.A. Brooks, R.P. Gabriel, and G.L. Steele, @i{Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, 108-113, 1982. @item @t{*} @b{Smalltalk-80: The Language and its Implementation}, A. Goldberg and D. Robson, Addison-Wesley, 1983. @item @t{*} @b{Standard LISP Report}, J.B. Marti, A.C. Hearn, M.L. Griss, and C. Griss, @i{SIGPLAN Notices} V14, #10, October, 1979. @item @t{*} @b{Webster's Third New International Dictionary the English Language, Unabridged}, Merriam Webster (Springfield, MA), 1986. @item @t{*} @b{XP: A Common Lisp Pretty Printing System}, R.C. Waters, Memo 1102a, Artificial Intelligence Laboratory, MIT (Cambridge, MA), September 1989. @end table @c end of including concept-references @node Definitions, Conformance, Referenced Publications, Introduction (Introduction) @section Definitions @c including concept-definitions This section contains notational conventions and definitions of terms used in this manual. @menu * Notational Conventions:: * Error Terminology:: * Sections Not Formally Part Of This Standard:: * Interpreting Dictionary Entries:: @end menu @node Notational Conventions, Error Terminology, Definitions, Definitions @subsection Notational Conventions @ITindex notation The following notational conventions are used throughout this document. @menu * Font Key:: * Modified BNF Syntax:: * Splicing in Modified BNF Syntax:: * Indirection in Modified BNF Syntax:: * Additional Uses for Indirect Definitions in Modified BNF Syntax:: * Special Symbols:: * Objects with Multiple Notations:: * Case in Symbols:: * Numbers (Objects with Multiple Notations):: * Use of the Dot Character:: * NIL:: * Designators:: * Nonsense Words:: @end menu @node Font Key, Modified BNF Syntax, Notational Conventions, Notational Conventions @subsubsection Font Key @ITindex font key Fonts are used in this document to convey information. @table @asis @item @i{name} Denotes a formal term whose meaning is defined in the Glossary. When this font is used, the Glossary definition takes precedence over normal English usage. Sometimes a glossary term appears subscripted, as in ``@i{whitespace}_2.'' Such a notation selects one particular Glossary definition out of several, in this case the second. The subscript notation for Glossary terms is generally used where the context might be insufficient to disambiguate among the available definitions. @item @i{name} @IGindex name Denotes the introduction of a formal term locally to the current text. There is still a corresponding glossary entry, and is formally equivalent to a use of ``@i{name},'' but the hope is that making such uses conspicuous will save the reader a trip to the glossary in some cases. @item @b{name} Denotes a symbol in the @t{COMMON-LISP} @i{package}. For information about @i{case} conventions, see @ref{Case in Symbols}. @item @t{name} Denotes a sample @i{name} or piece of @i{code} that a programmer might write in @r{Common Lisp}. This font is also used for certain @i{standardized} names that are not names of @i{external symbols} of the @t{COMMON-LISP} @i{package}, such as @i{keywords}_1, @i{package} @i{names}, and @i{loop keywords}. @item @i{name} Denotes the name of a @i{parameter} or @i{value}. In some situations the notation ``<<@i{name}>>'' (@i{i.e.}, the same font, but with surrounding ``angle brackets'') is used instead in order to provide better visual separation from surrounding characters. These ``angle brackets'' are metasyntactic, and never actually appear in program input or output. @end table @node Modified BNF Syntax, Splicing in Modified BNF Syntax, Font Key, Notational Conventions @subsubsection Modified BNF Syntax @ITindex bnf key This specification uses an extended Backus Normal Form (BNF) to describe the syntax of @r{Common Lisp} @i{macro forms} and @i{special forms}. This section discusses the syntax of BNF expressions. @node Splicing in Modified BNF Syntax, Indirection in Modified BNF Syntax, Modified BNF Syntax, Notational Conventions @subsubsection Splicing in Modified BNF Syntax The primary extension used is the following: @center [[O]] An expression of this form appears whenever a list of elements is to be spliced into a larger structure and the elements can appear in any order. The symbol O represents a description of the syntax of some number of syntactic elements to be spliced; that description must be of the form @center O_1 | ... | O_l @noindent where each O_i can be of the form S or of the form S@r{*} or of the form S^1. The expression [[O]] means that a list of the form @center (O_@{i_1@}... O_@{i_j@}) 1<= j @noindent is spliced into the enclosing expression, such that if n != m and 1<= n,m<= j, then either O_@{i_n@}!= O_@{i_m@} or O_@{i_n@} = O_@{i_m@} = Q_k, where for some 1<= k <= n, O_k is of the form Q_k@r{*}. Furthermore, for each O_@{i_n@} that is of the form Q_k^1, that element is required to appear somewhere in the list to be spliced. For example, the expression @t{(x [[A | B@r{*} | C]] y)} @noindent means that at most one @t{A}, any number of @t{B}'s, and at most one @t{C} can occur in any order. It is a description of any of these: @example (x y) (x B A C y) (x A B B B B B C y) (x C B A B B B y) @end example @noindent but not any of these: @example (x B B A A C C y) (x C B C y) @end example @noindent In the first case, both @t{A} and @t{C} appear too often, and in the second case @t{C} appears too often. The notation [[O_1 | O_2 | ...]]^+ adds the additional restriction that at least one item from among the possible choices must be used. For example: @t{(x [[A | B@r{*} | C]]^+ y)} @noindent means that at most one @t{A}, any number of @t{B}'s, and at most one @t{C} can occur in any order, but that in any case at least one of these options must be selected. It is a description of any of these: @example (x B y) (x B A C y) (x A B B B B B C y) (x C B A B B B y) @end example @noindent but not any of these: @example (x y) (x B B A A C C y) (x C B C y) @end example @noindent In the first case, no item was used; in the second case, both @t{A} and @t{C} appear too often; and in the third case @t{C} appears too often. Also, the expression: @t{(x [[A^1 | B^1 | C]] y)} @noindent can generate exactly these and no others: @example (x A B C y) (x A C B y) (x A B y) (x B A C y) (x B C A y) (x B A y) (x C A B y) (x C B A y) @end example @node Indirection in Modified BNF Syntax, Additional Uses for Indirect Definitions in Modified BNF Syntax, Splicing in Modified BNF Syntax, Notational Conventions @subsubsection Indirection in Modified BNF Syntax An indirection extension is introduced in order to make this new syntax more readable: @center !@i{O} @noindent If @i{O} is a non-terminal symbol, the right-hand side of its definition is substituted for the entire expression !@i{O}. For example, the following BNF is equivalent to the BNF in the previous example: @t{(x [[!@i{O}]] y)} @w{@i{O} ::=@t{A} | @t{B}@r{*} | @t{C}} @node Additional Uses for Indirect Definitions in Modified BNF Syntax, Special Symbols, Indirection in Modified BNF Syntax, Notational Conventions @subsubsection Additional Uses for Indirect Definitions in Modified BNF Syntax In some cases, an auxiliary definition in the BNF might appear to be unused within the BNF, but might still be useful elsewhere. For example, consider the following definitions: @code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} @code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} @w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} Here the term ``@i{clause}'' might appear to be ``dead'' in that it is not used in the BNF. However, the purpose of the BNF is not just to guide parsing, but also to define useful terms for reference in the descriptive text which follows. As such, the term ``@i{clause}'' might appear in text that follows, as shorthand for ``@i{normal-clause} or @i{otherwise-clause}.'' @node Special Symbols, Objects with Multiple Notations, Additional Uses for Indirect Definitions in Modified BNF Syntax, Notational Conventions @subsubsection Special Symbols The special symbols described here are used as a notational convenience within this document, and are part of neither the @r{Common Lisp} language nor its environment. @table @asis @item @result{} This indicates evaluation. For example: @example (+ 4 5) @result{} 9 @end example This means that the result of evaluating the @i{form} @t{(+ 4 5)} is @t{9}. If a @i{form} returns @i{multiple values}, those values might be shown separated by spaces, line breaks, or commas. For example: @example (truncate 7 5) @result{} 1 2 (truncate 7 5) @result{} 1 2 (truncate 7 5) @result{} 1, 2 @end example Each of the above three examples is equivalent, and specifies that @t{(truncate 7 5)} returns two values, which are @t{1} and @t{2}. Some @i{conforming implementations} actually type an arrow (or some other indicator) before showing return values, while others do not. @item @i{OR}@result{} The notation ``@i{OR}@result{}'' is used to denote one of several possible alternate results. The example @example (char-name #\a) @result{} NIL @i{OR}@result{} "LOWERCASE-a" @i{OR}@result{} "Small-A" @i{OR}@result{} "LA01" @end example indicates that @b{nil}, @t{"LOWERCASE-a"}, @t{"Small-A"}, @t{"LA01"} are among the possible results of @t{(char-name #\a)}---each with equal preference. Unless explicitly specified otherwise, it should not be assumed that the set of possible results shown is exhaustive. Formally, the above example is equivalent to @example (char-name #\a) @result{} @i{implementation-dependent} @end example but it is intended to provide additional information to illustrate some of the ways in which it is permitted for implementations to diverge. @item @i{NOT}@result{} The notation ``@i{NOT}@result{}'' is used to denote a result which is not possible. This might be used, for example, in order to emphasize a situation where some anticipated misconception might lead the reader to falsely believe that the result might be possible. For example, @example (function-lambda-expression (funcall #'(lambda (x) #'(lambda () x)) nil)) @result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA () X), @i{true}, NIL @i{NOT}@result{} NIL, @i{false}, NIL @i{NOT}@result{} (LAMBDA () X), @i{false}, NIL @end example @item @equiv{} This indicates code equivalence. For example: @example (gcd x (gcd y z)) @equiv{} (gcd (gcd x y) z) @end example This means that the results and observable side-effects of evaluating the @i{form} @t{(gcd x (gcd y z))} are always the same as the results and observable side-effects of @t{(gcd (gcd x y) z)} for any @t{x}, @t{y}, and @t{z}. @item @t{ |> } @r{Common Lisp} specifies input and output with respect to a non-interactive stream model. The specific details of how interactive input and output are mapped onto that non-interactive model are @i{implementation-defined}. For example, @i{conforming implementations} are permitted to differ in issues of how interactive input is terminated. For example, the @i{function} @b{read} terminates when the final delimiter is typed on a non-interactive stream. In some @i{implementations}, an interactive call to @b{read} returns as soon as the final delimiter is typed, even if that delimiter is not a @i{newline}. In other @i{implementations}, a final @i{newline} is always required. In still other @i{implementations}, there might be a command which ``activates'' a buffer full of input without the command itself being visible on the program's input stream. In the examples in this document, the notation ``@t{ |> }'' precedes lines where interactive input and output occurs. Within such a scenario, ``@b{|>>}@t{this notation}@b{<<|}'' notates user input. For example, the notation @example (+ 1 (print (+ (sqrt (read)) (sqrt (read))))) @t{ |> } @b{|>>}@t{9 16 }@b{<<|} @t{ |> } 7 @result{} 8 @end example shows an interaction in which ``@t{(+ 1 (print (+ (sqrt (read)) (sqrt (read)))))}'' is a @i{form} to be @i{evaluated}, ``@t{9 16 }'' is interactive input, ``@t{7}'' is interactive output, and ``@t{8}'' is the @i{value} @i{yielded} from the @i{evaluation}. The use of this notation is intended to disguise small differences in interactive input and output behavior between @i{implementations}. Sometimes, the non-interactive stream model calls for a @i{newline}. How that @i{newline} character is interactively entered is an @i{implementation-defined} detail of the user interface, but in that case, either the notation ``<@i{Newline}>'' or ``@i{[<--}~]'' might be used. @example (progn (format t "~&Who? ") (read-line)) @t{ |> } Who? @b{|>>}@t{Fred, Mary, and Sally @i{[<--}~]}@b{<<|} @result{} "Fred, Mary, and Sally", @i{false} @end example @end table @node Objects with Multiple Notations, Case in Symbols, Special Symbols, Notational Conventions @subsubsection Objects with Multiple Notations Some @i{objects} in @r{Common Lisp} can be notated in more than one way. In such situations, the choice of which notation to use is technically arbitrary, but conventions may exist which convey a ``point of view'' or ``sense of intent.'' @node Case in Symbols, Numbers (Objects with Multiple Notations), Objects with Multiple Notations, Notational Conventions @subsubsection Case in Symbols @ITindex case in symbol names While @i{case} is significant in the process of @i{interning} a @i{symbol}, the @i{Lisp reader}, by default, attempts to canonicalize the case of a @i{symbol} prior to interning; see @ref{Effect of Readtable Case on the Lisp Reader}. As such, case in @i{symbols} is not, by default, significant. Throughout this document, except as explicitly noted otherwise, the case in which a @i{symbol} appears is not significant; that is, @t{HELLO}, @t{Hello}, @t{hElLo}, and @t{hello} are all equivalent ways to denote a symbol whose name is @t{"HELLO"}. The characters @i{backslash} and @i{vertical-bar} are used to explicitly quote the @i{case} and other parsing-related aspects of characters. As such, the notations @t{|hello|} and @t{\h\e\l\l\o} are equivalent ways to refer to a symbol whose name is @t{"hello"}, and which is @i{distinct} from any symbol whose name is @t{"HELLO"}. The @i{symbols} that correspond to @r{Common Lisp} @i{defined names} have @i{uppercase} names even though their names generally appear in @i{lowercase} in this document. @node Numbers (Objects with Multiple Notations), Use of the Dot Character, Case in Symbols, Notational Conventions @subsubsection Numbers Although @r{Common Lisp} provides a variety of ways for programs to manipulate the input and output radix for rational numbers, all numbers in this document are in decimal notation unless explicitly noted otherwise. @node Use of the Dot Character, NIL, Numbers (Objects with Multiple Notations), Notational Conventions @subsubsection Use of the Dot Character The dot appearing by itself in an @i{expression} such as @t{(@i{item1} @i{item2} @t{.} @i{tail})} means that @i{tail} represents a @i{list} of @i{objects} at the end of a list. For example, @t{(A B C @t{.} (D E F))} is notationally equivalent to: @t{(A B C D E F)} Although @i{dot} is a valid constituent character in a symbol, no @i{standardized} @i{symbols} contain the character @i{dot}, so a period that follows a reference to a @i{symbol} at the end of a sentence in this document should always be interpreted as a period and never as part of the @i{symbol}'s @i{name}. For example, within this document, a sentence such as ``This sample sentence refers to the symbol @b{car}.'' refers to a symbol whose name is @t{"CAR"} (with three letters), and never to a four-letter symbol @t{"CAR."} @node NIL, Designators, Use of the Dot Character, Notational Conventions @subsubsection NIL @IGindex nil @IGindex () @IRindex nil @b{nil} has a variety of meanings. It is a @i{symbol} in the @t{COMMON-LISP} @i{package} with the @i{name} @t{"NIL"}, it is @i{boolean} (and @i{generalized boolean}) @i{false}, it is the @i{empty list}, and it is the @i{name} of the @i{empty type} (a @i{subtype} of all @i{types}). Within @r{Common Lisp}, @b{nil} can be notated interchangeably as either @t{NIL} or @t{()}. By convention, the choice of notation offers a hint as to which of its many roles it is playing. @format @group @noindent @w{ @b{For Evaluation?} @b{Notation} @b{Typically Implied Role} } @w{ ________________________________________________________} @w{ Yes @t{nil} use as a @i{boolean}. } @w{ Yes @t{'nil} use as a @i{symbol}. } @w{ Yes @t{'()} use as an @i{empty list} } @w{ No @t{nil} use as a @i{symbol} or @i{boolean}. } @w{ No @t{()} use as an @i{empty list}. } @noindent @w{ Figure 1--1: Notations for NIL } @end group @end format Within this document only, @b{nil} is also sometimes notated as @i{false} to emphasize its role as a @i{boolean}. For example: @example (print ()) ;avoided (defun three nil 3) ;avoided '(nil nil) ;list of two symbols '(() ()) ;list of empty lists (defun three () 3) ;Emphasize empty parameter list. (append '() '()) @result{} () ;Emphasize use of empty lists (not nil) @result{} @i{true} ;Emphasize use as Boolean false (get 'nil 'color) ;Emphasize use as a symbol @end example A @i{function} is sometimes said to ``be @i{false}'' or ``be @i{true}'' in some circumstance. Since no @i{function} object can be the same as @b{nil} and all @i{function} @i{objects} represent @i{true} when viewed as @i{booleans}, it would be meaningless to say that the @i{function} was literally @i{false} and uninteresting to say that it was literally @i{true}. Instead, these phrases are just traditional alternative ways of saying that the @i{function} ``returns @i{false}'' or ``returns @i{true},'' respectively. @node Designators, Nonsense Words, NIL, Notational Conventions @subsubsection Designators A @i{designator} @IGindex designator is an @i{object} that denotes another @i{object}. Where a @i{parameter} of an @i{operator} is described as a @i{designator}, the description of the @i{operator} is written in a way that assumes that the value of the @i{parameter} is the denoted @i{object}; that is, that the @i{parameter} is already of the denoted @i{type}. (The specific nature of the @i{object} denoted by a ``<<@i{type}>> @i{designator}'' or a ``@i{designator} for a <<@i{type}>>'' can be found in the Glossary entry for ``<<@i{type}>> @i{designator}.'') For example, ``@b{nil}'' and ``the @i{value} of @b{*standard-output*}'' are operationally indistinguishable as @i{stream designators}. Similarly, the @i{symbol} @t{foo} and the @i{string} @t{"FOO"} are operationally indistinguishable as @i{string designators}. Except as otherwise noted, in a situation where the denoted @i{object} might be used multiple times, it is @i{implementation-dependent} whether the @i{object} is coerced only once or whether the coercion occurs each time the @i{object} must be used. For example, @b{mapcar} receives a @i{function designator} as an argument, and its description is written as if this were simply a function. In fact, it is @i{implementation-dependent} whether the @i{function designator} is coerced right away or whether it is carried around internally in the form that it was given as an @i{argument} and re-coerced each time it is needed. In most cases, @i{conforming programs} cannot detect the distinction, but there are some pathological situations (particularly those involving self-redefining or mutually-redefining functions) which do conform and which can detect this difference. The following program is a @i{conforming program}, but might or might not have portably correct results, depending on whether its correctness depends on one or the other of the results: @example (defun add-some (x) (defun add-some (x) (+ x 2)) (+ x 1)) @result{} ADD-SOME (mapcar 'add-some '(1 2 3 4)) @result{} (2 3 4 5) @i{OR}@result{} (2 4 5 6) @end example In a few rare situations, there may be a need in a dictionary entry to refer to the @i{object} that was the original @i{designator} for a @i{parameter}. Since naming the @i{parameter} would refer to the denoted @i{object}, the phrase ``the <<@i{parameter-name}>> @i{designator}'' can be used to refer to the @i{designator} which was the @i{argument} from which the @i{value} of <<@i{parameter-name}>> was computed. @node Nonsense Words, , Designators, Notational Conventions @subsubsection Nonsense Words @ICindex foo @ICindex bar @ICindex baz @ICindex quux When a word having no pre-attached semantics is required (@i{e.g.}, in an example), it is common in the Lisp community to use one of the words ``foo,'' ``bar,'' ``baz,'' and ``quux.'' For example, in @example (defun foo (x) (+ x 1)) @end example the use of the name @t{foo} is just a shorthand way of saying ``please substitute your favorite name here.'' These nonsense words have gained such prevalance of usage, that it is commonplace for newcomers to the community to begin to wonder if there is an attached semantics which they are overlooking---there is not. @node Error Terminology, Sections Not Formally Part Of This Standard, Notational Conventions, Definitions @subsection Error Terminology @IGindex error terminology Situations in which errors might, should, or must be signaled are described in the standard. The wording used to describe such situations is intended to have precise meaning. The following list is a glossary of those meanings. @table @asis @item @b{Safe code} @IGindex safe This is @i{code} processed with the @b{safety} optimization at its highest setting (@t{3}). @b{safety} is a lexical property of code. The phrase ``the function @t{F} should signal an error'' means that if @t{F} is invoked from code processed with the highest @b{safety} optimization, an error is signaled. It is @i{implementation-dependent} whether @t{F} or the calling code signals the error. @item @b{Unsafe code} @IGindex unsafe This is code processed with lower safety levels. Unsafe code might do error checking. Implementations are permitted to treat all code as safe code all the time. @item @b{An error is signaled} @IGindex signal @ITindex is signaled @ITindex must signal This means that an error is signaled in both safe and unsafe code. @i{Conforming code} may rely on the fact that the error is signaled in both safe and unsafe code. Every implementation is required to detect the error in both safe and unsafe code. For example, ``an error is signaled if @b{unexport} is given a @i{symbol} not @i{accessible} in the @i{current package}.'' If an explicit error type is not specified, the default is @b{error}. @item @b{An error should be signaled} @IGindex signal @ITindex should signal This means that an error is signaled in safe code, and an error might be signaled in unsafe code. @i{Conforming code} may rely on the fact that the error is signaled in safe code. Every implementation is required to detect the error at least in safe code. When the error is not signaled, the ``consequences are undefined'' (see below). For example, ``@b{+} should signal an error of @i{type} @b{type-error} if any argument is not of @i{type} @b{number}.'' @item @b{Should be prepared to signal an error} @IGindex signal @ITindex prepared to signal This is similar to ``should be signaled'' except that it does not imply that `extra effort' has to be taken on the part of an @i{operator} to discover an erroneous situation if the normal action of that @i{operator} can be performed successfully with only `lazy' checking. An @i{implementation} is always permitted to signal an error, but even in @i{safe} @i{code}, it is only required to signal the error when failing to signal it might lead to incorrect results. In @i{unsafe} @i{code}, the consequences are undefined. For example, defining that ``@b{find} should be prepared to signal an error of @i{type} @b{type-error} if its second @i{argument} is not a @i{proper list}'' does not imply that an error is always signaled. The @i{form} @example (find 'a '(a b . c)) @end example must either signal an error of @i{type} @b{type-error} in @i{safe} @i{code}, else return @t{A}. In @i{unsafe} @i{code}, the consequences are undefined. By contrast, @example (find 'd '(a b . c)) @end example must signal an error of @i{type} @b{type-error} in @i{safe} @i{code}. In @i{unsafe} @i{code}, the consequences are undefined. Also, @example (find 'd '#1=(a b . #1#)) @end example in @i{safe code} might return @b{nil} (as an @i{implementation-defined} extension), might never return, or might signal an error of @i{type} @b{type-error}. In @i{unsafe} @i{code}, the consequences are undefined. Typically, the ``should be prepared to signal'' terminology is used in type checking situations where there are efficiency considerations that make it impractical to detect errors that are not relevant to the correct operation of the @i{operator}. @item @b{The consequences are unspecified} @ITindex consequences @ITindex unspecified consequences This means that the consequences are unpredictable but harmless. Implementations are permitted to specify the consequences of this situation. No @i{conforming code} may depend on the results or effects of this situation, and all @i{conforming code} is required to treat the results and effects of this situation as unpredictable but harmless. For example, ``if the second argument to @b{shared-initialize} specifies a name that does not correspond to any @i{slots} @i{accessible} in the @i{object}, the results are unspecified.'' @item @b{The consequences are undefined} @ITindex consequences @ITindex undefined consequences This means that the consequences are unpredictable. The consequences may range from harmless to fatal. No @i{conforming code} may depend on the results or effects. @i{Conforming code} must treat the consequences as unpredictable. In places where the words ``must,'' ``must not,'' or ``may not'' are used, then ``the consequences are undefined'' if the stated requirement is not met and no specific consequence is explicitly stated. An implementation is permitted to signal an error in this case. For example: ``Once a name has been declared by @b{defconstant} to be constant, any further assignment or binding of that variable has undefined consequences.'' @item @b{An error might be signaled} @IGindex signal @ITindex might signal This means that the situation has undefined consequences; however, if an error is signaled, it is of the specified @i{type}. For example, ``@b{open} might signal an error of @i{type} @b{file-error}.'' @item @b{The return values are unspecified} @ITindex unspecified values This means that only the number and nature of the return values of a @i{form} are not specified. However, the issue of whether or not any side-effects or transfer of control occurs is still well-specified. A program can be well-specified even if it uses a function whose returns values are unspecified. For example, even if the return values of some function @t{F} are unspecified, an expression such as @t{(length (list (F)))} is still well-specified because it does not rely on any particular aspect of the value or values returned by @t{F}. @item @b{Implementations may be extended to cover this situation} @ITindex extensions This means that the @i{situation} has undefined consequences; however, a @i{conforming implementation} is free to treat the situation in a more specific way. For example, an @i{implementation} might define that an error is signaled, or that an error should be signaled, or even that a certain well-defined non-error behavior occurs. No @i{conforming code} may depend on the consequences of such a @i{situation}; all @i{conforming code} must treat the consequences of the situation as undefined. @i{Implementations} are required to document how the situation is treated. For example, ``implementations may be extended to define other type specifiers to have a corresponding @i{class}.'' @item @b{Implementations are free to extend the syntax} @ITindex extensions This means that in this situation implementations are permitted to define unambiguous extensions to the syntax of the @i{form} being described. No @i{conforming code} may depend on this extension. Implementations are required to document each such extension. All @i{conforming code} is required to treat the syntax as meaningless. The standard might disallow certain extensions while allowing others. For example, ``no implementation is free to extend the syntax of @b{defclass}.'' @item @b{A warning might be issued} @ITindex warning This means that @i{implementations} are encouraged to issue a warning if the context is appropriate (@i{e.g.}, when compiling). However, a @i{conforming implementation} is not required to issue a warning. @end table @node Sections Not Formally Part Of This Standard, Interpreting Dictionary Entries, Error Terminology, Definitions @subsection Sections Not Formally Part Of This Standard Front matter and back matter, such as the ``Table of Contents,'' ``Index,'' ``Figures,'' ``Credits,'' and ``Appendix'' are not considered formally part of this standard, so that we retain the flexibility needed to update these sections even at the last minute without fear of needing a formal vote to change those parts of the document. These items are quite short and very useful, however, and it is not recommended that they be removed even in an abridged version of this document. Within the concept sections, subsections whose names begin with the words ``Note'' or ``Notes'' or ``Example'' or ``Examples'' are provided for illustration purposes only, and are not considered part of the standard. An attempt has been made to place these sections last in their parent section, so that they could be removed without disturbing the contiguous numbering of the surrounding sections in order to produce a document of smaller size. Likewise, the ``Examples'' and ``Notes'' sections in a dictionary entry are not considered part of the standard and could be removed if necessary. Nevertheless, the examples provide important clarifications and consistency checks for the rest of the material, and such abridging is not recommended unless absolutely unavoidable. @node Interpreting Dictionary Entries, , Sections Not Formally Part Of This Standard, Definitions @subsection Interpreting Dictionary Entries The dictionary entry for each @i{defined name} is partitioned into sections. Except as explicitly indicated otherwise below, each section is introduced by a label identifying that section. The omission of a section implies that the section is either not applicable, or would provide no interesting information. This section defines the significance of each potential section in a dictionary entry. @menu * The "Affected By" Section of a Dictionary Entry:: * The "Arguments" Section of a Dictionary Entry:: * The "Arguments and Values" Section of a Dictionary Entry:: * The "Binding Types Affected" Section of a Dictionary Entry:: * The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: * The "Compound Type Specifier Kind" Section of a Dictionary Entry:: * The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: * The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: * The "Compound Type Specifier Description" Section of a Dictionary Entry:: * The "Constant Value" Section of a Dictionary Entry:: * The "Description" Section of a Dictionary Entry:: * The "Examples" Section of a Dictionary Entry:: * The "Exceptional Situations" Section of a Dictionary Entry:: * The "Initial Value" Section of a Dictionary Entry:: * The "Argument Precedence Order" Section of a Dictionary Entry:: * The "Method Signature" Section of a Dictionary Entry:: * The "Name" Section of a Dictionary Entry:: * The "Notes" Section of a Dictionary Entry:: * The "Pronunciation" Section of a Dictionary Entry:: * The "See Also" Section of a Dictionary Entry:: * The "Side Effects" Section of a Dictionary Entry:: * The "Supertypes" Section of a Dictionary Entry:: * The "Syntax" Section of a Dictionary Entry:: * Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: * Requiring Non-Null Rest Parameters in The "Syntax" Section:: * Return values in The "Syntax" Section:: * No Arguments or Values in The "Syntax" Section:: * Unconditional Transfer of Control in The "Syntax" Section:: * The "Valid Context" Section of a Dictionary Entry:: * The "Value Type" Section of a Dictionary Entry:: @end menu @node The "Affected By" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries, Interpreting Dictionary Entries @subsubsection The "Affected By" Section of a Dictionary Entry For an @i{operator}, anything that can affect the side effects of or @i{values} returned by the @i{operator}. For a @i{variable}, anything that can affect the @i{value} of the @i{variable} including @i{functions} that bind or assign it. @node The "Arguments" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, The "Affected By" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Arguments" Section of a Dictionary Entry This information describes the syntax information of entries such as those for @i{declarations} and special @i{expressions} which are never @i{evaluated} as @i{forms}, and so do not return @i{values}. @node The "Arguments and Values" Section of a Dictionary Entry, The "Binding Types Affected" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Arguments and Values" Section of a Dictionary Entry An English language description of what @i{arguments} the @i{operator} accepts and what @i{values} it returns, including information about defaults for @i{parameters} corresponding to omittable @i{arguments} (such as @i{optional parameters} and @i{keyword parameters}). For @i{special operators} and @i{macros}, their @i{arguments} are not @i{evaluated} unless it is explicitly stated in their descriptions that they are @i{evaluated}. @node The "Binding Types Affected" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Binding Types Affected" Section of a Dictionary Entry This information alerts the reader to the kinds of @i{bindings} that might potentially be affected by a declaration. Whether in fact any particular such @i{binding} is actually affected is dependent on additional factors as well. See The "Description" Section of the declaration in question for details. @node The "Class Precedence List" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, The "Binding Types Affected" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Class Precedence List" Section of a Dictionary Entry This appears in the dictionary entry for a @i{class}, and contains an ordered list of the @i{classes} defined by @r{Common Lisp} that must be in the @i{class precedence list} of this @i{class}. It is permissible for other (@i{implementation-defined}) @i{classes} to appear in the @i{implementation}'s @i{class precedence list} for the @i{class}. It is permissible for either @b{standard-object} or @b{structure-object} to appear in the @i{implementation}'s @i{class precedence list}; for details, see @ref{Type Relationships}. Except as explicitly indicated otherwise somewhere in this specification, no additional @i{standardized} @i{classes} may appear in the @i{implementation}'s @i{class precedence list}. By definition of the relationship between @i{classes} and @i{types}, the @i{classes} listed in this section are also @i{supertypes} of the @i{type} denoted by the @i{class}. @node Dictionary Entries for Type Specifiers, The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection Dictionary Entries for Type Specifiers The @i{atomic type specifiers} are those @i{defined names} listed in @i{Figure~4--2}. Such dictionary entries are of kind ``Class,'' ``Condition Type,'' ``System Class,'' or ``Type.'' A description of how to interpret a @i{symbol} naming one of these @i{types} or @i{classes} as an @i{atomic type specifier} is found in The "Description" Section of such dictionary entries. The @i{compound type specifiers} are those @i{defined names} listed in @i{Figure~4--3}. Such dictionary entries are of kind ``Class,'' ``System Class,'' ``Type,'' or ``Type Specifier.'' A description of how to interpret as a @i{compound type specifier} a @i{list} whose @i{car} is such a @i{symbol} is found in the ``Compound Type Specifier Kind,'' ``Compound Type Specifier Syntax,'' ``Compound Type Specifier Arguments,'' and ``Compound Type Specifier Description'' sections of such dictionary entries. @node The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, Interpreting Dictionary Entries @subsubsection The "Compound Type Specifier Kind" Section of a Dictionary Entry An ``abbreviating'' @i{type specifier} is one that describes a @i{subtype} for which it is in principle possible to enumerate the @i{elements}, but for which in practice it is impractical to do so. A ``specializing'' @i{type specifier} is one that describes a @i{subtype} by restricting the @i{type} of one or more components of the @i{type}, such as @i{element type} or @i{complex part type}. A ``predicating'' @i{type specifier} is one that describes a @i{subtype} containing only those @i{objects} that satisfy a given @i{predicate}. A ``combining'' @i{type specifier} is one that describes a @i{subtype} in a compositional way, using combining operations (such as ``and,'' ``or,'' and ``not'') on other @i{types}. @node The "Compound Type Specifier Syntax" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Kind" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Compound Type Specifier Syntax" Section of a Dictionary Entry This information about a @i{type} describes the syntax of a @i{compound type specifier} for that @i{type}. Whether or not the @i{type} is acceptable as an @i{atomic type specifier} is not represented here; see @ref{Dictionary Entries for Type Specifiers}. @node The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Compound Type Specifier Arguments" Section of a Dictionary Entry This information describes @i{type} information for the structures defined in The "Compound Type Specifier Syntax" Section. @node The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Compound Type Specifier Description" Section of a Dictionary Entry This information describes the meaning of the structures defined in The "Compound Type Specifier Syntax" Section. @node The "Constant Value" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Constant Value" Section of a Dictionary Entry This information describes the unchanging @i{type} and @i{value} of a @i{constant variable}. @node The "Description" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Description" Section of a Dictionary Entry A summary of the @i{operator} and all intended aspects of the @i{operator}, but does not necessarily include all the fields referenced below it (``Side Effects,'' ``Exceptional Situations,'' @i{etc.}) @node The "Examples" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Examples" Section of a Dictionary Entry Examples of use of the @i{operator}. These examples are not considered part of the standard; see @ref{Sections Not Formally Part Of This Standard}. @node The "Exceptional Situations" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Exceptional Situations" Section of a Dictionary Entry Three kinds of information may appear here: @table @asis @item @t{*} Situations that are detected by the @i{function} and formally signaled. @item @t{*} Situations that are handled by the @i{function}. @item @t{*} Situations that may be detected by the @i{function}. @end table This field does not include conditions that could be signaled by @i{functions} passed to and called by this @i{operator} as arguments or through dynamic variables, nor by executing subforms of this operator if it is a @i{macro} or @i{special operator}. @node The "Initial Value" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Initial Value" Section of a Dictionary Entry This information describes the initial @i{value} of a @i{dynamic variable}. Since this variable might change, see @i{type} restrictions in The "Value Type" Section. @node The "Argument Precedence Order" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Argument Precedence Order" Section of a Dictionary Entry This information describes the argument precedence order. If it is omitted, the argument precedence order is the default (left to right). @node The "Method Signature" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Method Signature" Section of a Dictionary Entry The description of a @i{generic function} includes descriptions of the @i{methods} that are defined on that @i{generic function} by the standard. A method signature is used to describe the @i{parameters} and @i{parameter specializers} for each @i{method}. @i{Methods} defined for the @i{generic function} must be of the form described by the @i{method} @i{signature}. @code{F} @i{@r{(}@i{x} @i{class}@r{)} @r{(}@i{y} t@r{)} @r{&optional} @i{z} @r{&key} @i{k}} @noindent This @i{signature} indicates that this method on the @i{generic function} @b{F} has two @i{required parameters}: @i{x}, which must be a @i{generalized instance} of the @i{class} @i{class}; and @i{y}, which can be any @i{object} (@i{i.e.}, a @i{generalized instance} of the @i{class} @b{t}). In addition, there is an @i{optional parameter} @i{z} and a @i{keyword parameter} @i{k}. This @i{signature} also indicates that this method on @t{F} is a @i{primary method} and has no @i{qualifiers}. For each @i{parameter}, the @i{argument} supplied must be in the intersection of the @i{type} specified in the description of the corresponding @i{generic function} and the @i{type} given in the @i{signature} of some @i{method} (including not only those @i{methods} defined in this specification, but also @i{implementation-defined} or user-defined @i{methods} in situations where the definition of such @i{methods} is permitted). @node The "Name" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Name" Section of a Dictionary Entry This section introduces the dictionary entry. It is not explicitly labeled. It appears preceded and followed by a horizontal bar. In large print at left, the @i{defined name} appears; if more than one @i{defined name} is to be described by the entry, all such @i{names} are shown separated by commas. In somewhat smaller italic print at right is an indication of what kind of dictionary entry this is. Possible values are: @table @asis @item @i{Accessor} This is an @i{accessor} @i{function}. @item @i{Class} This is a @i{class}. @item @i{Condition Type} This is a @i{subtype} of @i{type} @b{condition}. @item @i{Constant Variable} This is a @i{constant variable}. @item @i{Declaration} This is a @i{declaration identifier}. @item @i{Function} This is a @i{function}. @item @i{Local Function} This is a @i{function} that is defined only lexically within the scope of some other @i{macro form}. @item @i{Local Macro} This is a @i{macro} that is defined only lexically within the scope of some other @i{macro form}. @item @i{Macro} This is a @i{macro}. @item @i{Restart} This is a @i{restart}. @item @i{Special Operator} This is a @i{special operator}. @item @i{Standard Generic Function} This is a @i{standard generic function}. @item @i{Symbol} This is a @i{symbol} that is specially recognized in some particular situation, such as the syntax of a @i{macro}. @item @i{System Class} This is like @i{class}, but it identifies a @i{class} that is potentially a @i{built-in class}. (No @i{class} is actually required to be a @i{built-in class}.) @item @i{Type} This is an @i{atomic type specifier}, and depending on information for each particular entry, may subject to form other @i{type specifiers}. @item @i{Type Specifier} This is a @i{defined name} that is not an @i{atomic type specifier}, but that can be used in constructing valid @i{type specifiers}. @item @i{Variable} This is a @i{dynamic variable}. @end table @node The "Notes" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Notes" Section of a Dictionary Entry Information not found elsewhere in this description which pertains to this @i{operator}. Among other things, this might include cross reference information, code equivalences, stylistic hints, implementation hints, typical uses. This information is not considered part of the standard; any @i{conforming implementation} or @i{conforming program} is permitted to ignore the presence of this information. @node The "Pronunciation" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Pronunciation" Section of a Dictionary Entry This offers a suggested pronunciation for @i{defined names} so that people not in verbal communication with the original designers can figure out how to pronounce words that are not in normal English usage. This information is advisory only, and is not considered part of the standard. For brevity, it is only provided for entries with names that are specific to @r{Common Lisp} and would not be found in @b{Webster's Third New International Dictionary the English Language, Unabridged}. @node The "See Also" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "See Also" Section of a Dictionary Entry List of references to other parts of this standard that offer information relevant to this @i{operator}. This list is not part of the standard. @node The "Side Effects" Section of a Dictionary Entry, The "Supertypes" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Side Effects" Section of a Dictionary Entry Anything that is changed as a result of the evaluation of the @i{form} containing this @i{operator}. @node The "Supertypes" Section of a Dictionary Entry, The "Syntax" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Supertypes" Section of a Dictionary Entry This appears in the dictionary entry for a @i{type}, and contains a list of the @i{standardized} @i{types} that must be @i{supertypes} of this @i{type}. In @i{implementations} where there is a corresponding @i{class}, the order of the @i{classes} in the @i{class precedence list} is consistent with the order presented in this section. @node The "Syntax" Section of a Dictionary Entry, Special "Syntax" Notations for Overloaded Operators, The "Supertypes" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Syntax" Section of a Dictionary Entry This section describes how to use the @i{defined name} in code. The "Syntax'' description for a @i{generic function} describes the @i{lambda list} of the @i{generic function} itself, while The "Method Signatures'' describe the @i{lambda lists} of the defined @i{methods}. The "Syntax'' description for an @i{ordinary function}, a @i{macro}, or a @i{special operator} describes its @i{parameters}. For example, an @i{operator} description might say: @code{F} @i{x y @r{&optional} z @r{&key} k} @noindent This description indicates that the function @b{F} has two required parameters, @i{x} and @i{y}. In addition, there is an optional parameter @i{z} and a keyword parameter @i{k}. For @i{macros} and @i{special operators}, syntax is given in modified BNF notation; see @ref{Modified BNF Syntax}. For @i{functions} a @i{lambda list} is given. In both cases, however, the outermost parentheses are omitted, and default value information is omitted. @node Special "Syntax" Notations for Overloaded Operators, Naming Conventions for Rest Parameters, The "Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection Special "Syntax" Notations for Overloaded Operators If two descriptions exist for the same operation but with different numbers of arguments, then the extra arguments are to be treated as optional. For example, this pair of lines: @code{file-position} @i{stream} @result{} @i{position} @code{file-position} @i{stream position-spec} @result{} @i{success-p} @noindent is operationally equivalent to this line: @code{file-position} @i{stream @r{&optional} position-spec} @result{} @i{result} @noindent and differs only in that it provides on opportunity to introduce different names for @i{parameter} and @i{values} for each case. The separated (multi-line) notation is used when an @i{operator} is overloaded in such a way that the @i{parameters} are used in different ways depending on how many @i{arguments} are supplied (@i{e.g.}, for the @i{function} @b{/}) or the return values are different in the two cases (@i{e.g.}, for the @i{function} @b{file-position}). @node Naming Conventions for Rest Parameters, Requiring Non-Null Rest Parameters in The "Syntax" Section, Special "Syntax" Notations for Overloaded Operators, Interpreting Dictionary Entries @subsubsection Naming Conventions for Rest Parameters Within this specification, if the name of a @i{rest parameter} is chosen to be a plural noun, use of that name in @i{parameter} font refers to the @i{list} to which the @i{rest parameter} is bound. Use of the singular form of that name in @i{parameter} font refers to an @i{element} of that @i{list}. For example, given a syntax description such as: @code{F} @i{@r{&rest} @i{arguments}} @noindent it is appropriate to refer either to the @i{rest parameter} named @i{arguments} by name, or to one of its elements by speaking of ``an @i{argument},'' ``some @i{argument},'' ``each @i{argument}'' @i{etc.} @node Requiring Non-Null Rest Parameters in The "Syntax" Section, Return values in The "Syntax" Section, Naming Conventions for Rest Parameters, Interpreting Dictionary Entries @subsubsection Requiring Non-Null Rest Parameters in The "Syntax" Section In some cases it is useful to refer to all arguments equally as a single aggregation using a @i{rest parameter} while at the same time requiring at least one argument. A variety of imperative and declarative means are available in @i{code} for expressing such a restriction, however they generally do not manifest themselves in a @i{lambda list}. For descriptive purposes within this specification, @code{F} @i{@r{&rest} arguments^+} @noindent means the same as @code{F} @i{@r{&rest} arguments} @noindent but introduces the additional requirement that there be at least one @i{argument}. @node Return values in The "Syntax" Section, No Arguments or Values in The "Syntax" Section, Requiring Non-Null Rest Parameters in The "Syntax" Section, Interpreting Dictionary Entries @subsubsection Return values in The "Syntax" Section An evaluation arrow ``@result{}'' precedes a list of @i{values} to be returned. For example: @code{F} @i{a b c} @result{} @i{x} @noindent indicates that @t{F} is an operator that has three @i{required parameters} (@i{i.e.}, @i{a}, @i{b}, and @i{c}) and that returns one @i{value} (@i{i.e.}, @i{x}). If more than one @i{value} is returned by an operator, the @i{names} of the @i{values} are separated by commas, as in: @code{F} @i{a b c} @result{} @i{x, y, z} @node No Arguments or Values in The "Syntax" Section, Unconditional Transfer of Control in The "Syntax" Section, Return values in The "Syntax" Section, Interpreting Dictionary Entries @subsubsection No Arguments or Values in The "Syntax" Section If no @i{arguments} are permitted, or no @i{values} are returned, a special notation is used to make this more visually apparent. For example, @code{F} @i{<@i{no @i{arguments}}>} @result{} @i{<@i{no @i{values}}>} indicates that @t{F} is an operator that accepts no @i{arguments} and returns no @i{values}. @node Unconditional Transfer of Control in The "Syntax" Section, The "Valid Context" Section of a Dictionary Entry, No Arguments or Values in The "Syntax" Section, Interpreting Dictionary Entries @subsubsection Unconditional Transfer of Control in The "Syntax" Section Some @i{operators} perform an unconditional transfer of control, and so never have any return values. Such @i{operators} are notated using a notation such as the following: @code{F} @i{a b c} @result{} # @node The "Valid Context" Section of a Dictionary Entry, The "Value Type" Section of a Dictionary Entry, Unconditional Transfer of Control in The "Syntax" Section, Interpreting Dictionary Entries @subsubsection The "Valid Context" Section of a Dictionary Entry This information is used by dictionary entries such as ``Declarations'' in order to restrict the context in which the declaration may appear. A given ``Declaration'' might appear in a @i{declaration} (@i{i.e.}, a @b{declare} @i{expression}), a @i{proclamation} (@i{i.e.}, a @b{declaim} or @b{proclaim} @i{form}), or both. @node The "Value Type" Section of a Dictionary Entry, , The "Valid Context" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection The "Value Type" Section of a Dictionary Entry This information describes any @i{type} restrictions on a @i{dynamic variable}. @c end of including concept-definitions @node Conformance, Language Extensions, Definitions, Introduction (Introduction) @section Conformance @c including concept-conformance This standard presents the syntax and semantics to be implemented by a @i{conforming implementation} (and its accompanying documentation). In addition, it imposes requirements on @i{conforming programs}. @menu * Conforming Implementations:: * Conforming Programs:: @end menu @node Conforming Implementations, Conforming Programs, Conformance, Conformance @subsection Conforming Implementations A @i{conforming implementation} @IGindex conforming implementation shall adhere to the requirements outlined in this section. @menu * Required Language Features:: * Documentation of Implementation-Dependent Features:: * Documentation of Extensions:: * Treatment of Exceptional Situations:: * Resolution of Apparent Conflicts in Exceptional Situations:: * Examples of Resolution of Apparent Conflict in Exceptional Situations:: * Conformance Statement:: @end menu @node Required Language Features, Documentation of Implementation-Dependent Features, Conforming Implementations, Conforming Implementations @subsubsection Required Language Features A @i{conforming implementation} shall accept all features (including deprecated features) of the language specified in this standard, with the meanings defined in this standard. A @i{conforming implementation} shall not require the inclusion of substitute or additional language elements in code in order to accomplish a feature of the language that is specified in this standard. @node Documentation of Implementation-Dependent Features, Documentation of Extensions, Required Language Features, Conforming Implementations @subsubsection Documentation of Implementation-Dependent Features A @i{conforming implementation} shall be accompanied by a document that provides a definition of all @i{implementation-defined} aspects of the language defined by this specification. In addition, a @i{conforming implementation} is encouraged (but not required) to document items in this standard that are identified as @i{implementation-dependent}, although in some cases such documentation might simply identify the item as ``undefined.'' @node Documentation of Extensions, Treatment of Exceptional Situations, Documentation of Implementation-Dependent Features, Conforming Implementations @subsubsection Documentation of Extensions A @i{conforming implementation} shall be accompanied by a document that separately describes any features accepted by the @i{implementation} that are not specified in this standard, but that do not cause any ambiguity or contradiction when added to the language standard. Such extensions shall be described as being ``extensions to @r{Common Lisp} as specified by ANSI <<@i{standard number}>>.'' @node Treatment of Exceptional Situations, Resolution of Apparent Conflicts in Exceptional Situations, Documentation of Extensions, Conforming Implementations @subsubsection Treatment of Exceptional Situations A @i{conforming implementation} shall treat exceptional situations in a manner consistent with this specification. @node Resolution of Apparent Conflicts in Exceptional Situations, Examples of Resolution of Apparent Conflict in Exceptional Situations, Treatment of Exceptional Situations, Conforming Implementations @subsubsection Resolution of Apparent Conflicts in Exceptional Situations If more than one passage in this specification appears to apply to the same situation but in conflicting ways, the passage that appears to describe the situation in the most specific way (not necessarily the passage that provides the most constrained kind of error detection) takes precedence. @node Examples of Resolution of Apparent Conflict in Exceptional Situations, Conformance Statement, Resolution of Apparent Conflicts in Exceptional Situations, Conforming Implementations @subsubsection Examples of Resolution of Apparent Conflict in Exceptional Situations Suppose that function @t{foo} is a member of a set S of @i{functions} that operate on numbers. Suppose that one passage states that an error must be signaled if any @i{function} in S is ever given an argument of @t{17}. Suppose that an apparently conflicting passage states that the consequences are undefined if @t{foo} receives an argument of @t{17}. Then the second passage (the one specifically about @t{foo}) would dominate because the description of the situational context is the most specific, and it would not be required that @t{foo} signal an error on an argument of @t{17} even though other functions in the set S would be required to do so. @node Conformance Statement, , Examples of Resolution of Apparent Conflict in Exceptional Situations, Conforming Implementations @subsubsection Conformance Statement A @i{conforming implementation} shall produce a conformance statement as a consequence of using the implementation, or that statement shall be included in the accompanying documentation. If the implementation conforms in all respects with this standard, the conformance statement shall be @table @asis @item @t{} ``<<@i{Implementation}>> conforms with the requirements of ANSI <<@i{standard number}>>'' @end table If the @i{implementation} conforms with some but not all of the requirements of this standard, then the conformance statement shall be @table @asis @item @t{} ``<<@i{Implementation}>> conforms with the requirements of ANSI <<@i{standard number}>> with the following exceptions: <<@i{reference to or complete list of the requirements of the standard with which the implementation does not conform}>>.'' @end table @node Conforming Programs, , Conforming Implementations, Conformance @subsection Conforming Programs @IGindex conforming program @IGindex conforming code Code conforming with the requirements of this standard shall adhere to the following: @table @asis @item 1. @i{Conforming code} shall use only those features of the language syntax and semantics that are either specified in this standard or defined using the extension mechanisms specified in the standard. @item 2. @i{Conforming code} shall not rely on any particular interpretation of @i{implementation-dependent} features. @item 3. @i{Conforming code} shall not depend on the consequences of undefined or unspecified situations. @item 4. @i{Conforming code} does not use any constructions that are prohibited by the standard. @item 5. @i{Conforming code} does not depend on extensions included in an implementation. @end table @menu * Use of Implementation-Defined Language Features:: * Use of Read-Time Conditionals:: @end menu @node Use of Implementation-Defined Language Features, Use of Read-Time Conditionals, Conforming Programs, Conforming Programs @subsubsection Use of Implementation-Defined Language Features Note that @i{conforming code} may rely on particular @i{implementation-defined} values or features. Also note that the requirements for @i{conforming code} and @i{conforming implementations} do not require that the results produced by conforming code always be the same when processed by a @i{conforming implementation}. The results may be the same, or they may differ. @i{Portable code} is written using only @i{standard characters}. Conforming code may run in all conforming implementations, but might have allowable @i{implementation-defined} behavior that makes it non-portable code. For example, the following are examples of @i{forms} that are conforming, but that might return different @i{values} in different implementations: @example (evenp most-positive-fixnum) @result{} @i{implementation-dependent} (random) @result{} @i{implementation-dependent} (> lambda-parameters-limit 93) @result{} @i{implementation-dependent} (char-name #\A) @result{} @i{implementation-dependent} @end example @node Use of Read-Time Conditionals, , Use of Implementation-Defined Language Features, Conforming Programs @subsubsection Use of Read-Time Conditionals Use of @t{#+} and @t{#-} does not automatically disqualify a program from being conforming. A program which uses @t{#+} and @t{#-} is considered conforming if there is no set of @i{features} in which the program would not be conforming. Of course, @i{conforming programs} are not necessarily working programs. The following program is conforming: @example (defun foo () #+ACME (acme:initialize-something) (print 'hello-there)) @end example However, this program might or might not work, depending on whether the presence of the feature @t{ACME} really implies that a function named @t{acme:initialize-something} is present in the environment. In effect, using @t{#+} or @t{#-} in a @i{conforming program} means that the variable @b{*features*} @IRindex *features* becomes just one more piece of input data to that program. Like any other data coming into a program, the programmer is responsible for assuring that the program does not make unwarranted assumptions on the basis of input data. @c end of including concept-conformance @node Language Extensions, Language Subsets, Conformance, Introduction (Introduction) @section Language Extensions @c including concept-extensions A language extension is any documented @i{implementation-defined} behavior of a @i{defined name} in this standard that varies from the behavior described in this standard, or a documented consequence of a situation that the standard specifies as undefined, unspecified, or extendable by the implementation. For example, if this standard says that ``the results are unspecified,'' an extension would be to specify the results. [Reviewer Note by Barmar: This contradicts previous definitions of conforming code.] If the correct behavior of a program depends on the results provided by an extension, only implementations with the same extension will execute the program correctly. Note that such a program might be non-conforming. Also, if this standard says that ``an implementation may be extended,'' a conforming, but possibly non-portable, program can be written using an extension. An implementation can have extensions, provided they do not alter the behavior of conforming code and provided they are not explicitly prohibited by this standard. The term ``extension'' refers only to extensions available upon startup. An implementation is free to allow or prohibit redefinition of an extension. The following list contains specific guidance to implementations concerning certain types of extensions. @table @asis @item @b{Extra return values} An implementation must return exactly the number of return values specified by this standard unless the standard specifically indicates otherwise. @item @b{Unsolicited messages} No output can be produced by a function other than that specified in the standard or due to the signaling of @i{conditions} detected by the function. Unsolicited output, such as garbage collection notifications and autoload heralds, should not go directly to the @i{stream} that is the value of a @i{stream} variable defined in this standard, but can go indirectly to @i{terminal I/O} by using a @i{synonym stream} to @b{*terminal-io*}. Progress reports from such functions as @b{load} and @b{compile} are considered solicited, and are not covered by this prohibition. @item @b{Implementation of macros and special forms} @i{Macros} and @i{special operators} defined in this standard must not be @i{functions}. @end table @c end of including concept-extensions @node Language Subsets, Deprecated Language Features, Language Extensions, Introduction (Introduction) @section Language Subsets @c including concept-subsets The language described in this standard contains no subsets, though subsets are not forbidden. For a language to be considered a subset, it must have the property that any valid @i{program} in that language has equivalent semantics and will run directly (with no extralingual pre-processing, and no special compatibility packages) in any @i{conforming implementation} of the full language. A language that conforms to this requirement shall be described as being a ``subset of @r{Common Lisp} as specified by ANSI <<@i{standard number}>>.'' @c end of including concept-subsets @node Deprecated Language Features, Symbols in the COMMON-LISP Package, Language Subsets, Introduction (Introduction) @section Deprecated Language Features @c including concept-deprecated Deprecated language features are not expected to appear in future @r{Common Lisp} standards, but are required to be implemented for conformance with this standard; see @ref{Required Language Features}. @i{Conforming programs} can use deprecated features; however, it is considered good programming style to avoid them. It is permissible for the compiler to produce @i{style warnings} about the use of such features at compile time, but there should be no such warnings at program execution time. @menu * Deprecated Functions:: * Deprecated Argument Conventions:: * Deprecated Variables:: * Deprecated Reader Syntax:: @end menu @node Deprecated Functions, Deprecated Argument Conventions, Deprecated Language Features, Deprecated Language Features @subsection Deprecated Functions The @i{functions} in Figure 1--2 are deprecated. @format @group @noindent @w{ assoc-if-not nsubst-if-not require } @w{ count-if-not nsubstitute-if-not set } @w{ delete-if-not position-if-not subst-if-not } @w{ find-if-not provide substitute-if-not } @w{ gentemp rassoc-if-not } @w{ member-if-not remove-if-not } @noindent @w{ Figure 1--2: Deprecated Functions } @end group @end format @node Deprecated Argument Conventions, Deprecated Variables, Deprecated Functions, Deprecated Language Features @subsection Deprecated Argument Conventions The ability to pass a numeric @i{argument} to @b{gensym} has been deprecated. The @t{:test-not} @i{argument} to the @i{functions} in Figure 1--3 are deprecated. @format @group @noindent @w{ adjoin nset-difference search } @w{ assoc nset-exclusive-or set-difference } @w{ count nsublis set-exclusive-or } @w{ delete nsubst sublis } @w{ delete-duplicates nsubstitute subsetp } @w{ find nunion subst } @w{ intersection position substitute } @w{ member rassoc tree-equal } @w{ mismatch remove union } @w{ nintersection remove-duplicates } @noindent @w{ Figure 1--3: Functions with Deprecated :TEST-NOT Arguments} @end group @end format The use of the situation names @b{compile}, @b{load}, and @b{eval} in @b{eval-when} is deprecated. @node Deprecated Variables, Deprecated Reader Syntax, Deprecated Argument Conventions, Deprecated Language Features @subsection Deprecated Variables The @i{variable} @b{*modules*} is deprecated. @node Deprecated Reader Syntax, , Deprecated Variables, Deprecated Language Features @subsection Deprecated Reader Syntax The @t{#S} @i{reader macro} forces keyword names into the @t{KEYWORD} @i{package}; see @ref{Sharpsign S}. This feature is deprecated; in the future, keyword names will be taken in the package they are read in, so @i{symbols} that are actually in the @t{KEYWORD} @i{package} should be used if that is what is desired. @c end of including concept-deprecated @node Symbols in the COMMON-LISP Package, , Deprecated Language Features, Introduction (Introduction) @section Symbols in the COMMON-LISP Package @c including concept-cl-symbols The figures on the next twelve pages contain a complete enumeration of the 978 @i{external} @i{symbols} in the @t{COMMON-LISP} @i{package}. @IPindex common-lisp @format @group @noindent @w{ &allow-other-keys *print-miser-width* } @w{ &aux *print-pprint-dispatch* } @w{ &body *print-pretty* } @w{ &environment *print-radix* } @w{ &key *print-readably* } @w{ &optional *print-right-margin* } @w{ &rest *query-io* } @w{ &whole *random-state* } @w{ * *read-base* } @w{ ** *read-default-float-format* } @w{ *** *read-eval* } @w{ *break-on-signals* *read-suppress* } @w{ *compile-file-pathname* *readtable* } @w{ *compile-file-truename* *standard-input* } @w{ *compile-print* *standard-output* } @w{ *compile-verbose* *terminal-io* } @w{ *debug-io* *trace-output* } @w{ *debugger-hook* + } @w{ *default-pathname-defaults* ++ } @w{ *error-output* +++ } @w{ *features* - } @w{ *gensym-counter* / } @w{ *load-pathname* // } @w{ *load-print* /// } @w{ *load-truename* /= } @w{ *load-verbose* 1+ } @w{ *macroexpand-hook* 1- } @w{ *modules* < } @w{ *package* <= } @w{ *print-array* = } @w{ *print-base* > } @w{ *print-case* >= } @w{ *print-circle* abort } @w{ *print-escape* abs } @w{ *print-gensym* acons } @w{ *print-length* acos } @w{ *print-level* acosh } @w{ *print-lines* add-method } @noindent @w{ Figure 1--4: Symbols in the COMMON-LISP package (part one of twelve).} @end group @end format @page @format @group @noindent @w{ adjoin atom boundp } @w{ adjust-array base-char break } @w{ adjustable-array-p base-string broadcast-stream } @w{ allocate-instance bignum broadcast-stream-streams } @w{ alpha-char-p bit built-in-class } @w{ alphanumericp bit-and butlast } @w{ and bit-andc1 byte } @w{ append bit-andc2 byte-position } @w{ apply bit-eqv byte-size } @w{ apropos bit-ior caaaar } @w{ apropos-list bit-nand caaadr } @w{ aref bit-nor caaar } @w{ arithmetic-error bit-not caadar } @w{ arithmetic-error-operands bit-orc1 caaddr } @w{ arithmetic-error-operation bit-orc2 caadr } @w{ array bit-vector caar } @w{ array-dimension bit-vector-p cadaar } @w{ array-dimension-limit bit-xor cadadr } @w{ array-dimensions block cadar } @w{ array-displacement boole caddar } @w{ array-element-type boole-1 cadddr } @w{ array-has-fill-pointer-p boole-2 caddr } @w{ array-in-bounds-p boole-and cadr } @w{ array-rank boole-andc1 call-arguments-limit } @w{ array-rank-limit boole-andc2 call-method } @w{ array-row-major-index boole-c1 call-next-method } @w{ array-total-size boole-c2 car } @w{ array-total-size-limit boole-clr case } @w{ arrayp boole-eqv catch } @w{ ash boole-ior ccase } @w{ asin boole-nand cdaaar } @w{ asinh boole-nor cdaadr } @w{ assert boole-orc1 cdaar } @w{ assoc boole-orc2 cdadar } @w{ assoc-if boole-set cdaddr } @w{ assoc-if-not boole-xor cdadr } @w{ atan boolean cdar } @w{ atanh both-case-p cddaar } @noindent @w{ Figure 1--5: Symbols in the COMMON-LISP package (part two of twelve).} @end group @end format @page @format @group @noindent @w{ cddadr clear-input copy-tree } @w{ cddar clear-output cos } @w{ cdddar close cosh } @w{ cddddr clrhash count } @w{ cdddr code-char count-if } @w{ cddr coerce count-if-not } @w{ cdr compilation-speed ctypecase } @w{ ceiling compile debug } @w{ cell-error compile-file decf } @w{ cell-error-name compile-file-pathname declaim } @w{ cerror compiled-function declaration } @w{ change-class compiled-function-p declare } @w{ char compiler-macro decode-float } @w{ char-code compiler-macro-function decode-universal-time } @w{ char-code-limit complement defclass } @w{ char-downcase complex defconstant } @w{ char-equal complexp defgeneric } @w{ char-greaterp compute-applicable-methods define-compiler-macro } @w{ char-int compute-restarts define-condition } @w{ char-lessp concatenate define-method-combination } @w{ char-name concatenated-stream define-modify-macro } @w{ char-not-equal concatenated-stream-streams define-setf-expander } @w{ char-not-greaterp cond define-symbol-macro } @w{ char-not-lessp condition defmacro } @w{ char-upcase conjugate defmethod } @w{ char/= cons defpackage } @w{ char< consp defparameter } @w{ char<= constantly defsetf } @w{ char= constantp defstruct } @w{ char> continue deftype } @w{ char>= control-error defun } @w{ character copy-alist defvar } @w{ characterp copy-list delete } @w{ check-type copy-pprint-dispatch delete-duplicates } @w{ cis copy-readtable delete-file } @w{ class copy-seq delete-if } @w{ class-name copy-structure delete-if-not } @w{ class-of copy-symbol delete-package } @noindent @w{ Figure 1--6: Symbols in the COMMON-LISP package (part three of twelve). } @end group @end format @page @format @group @noindent @w{ denominator eq } @w{ deposit-field eql } @w{ describe equal } @w{ describe-object equalp } @w{ destructuring-bind error } @w{ digit-char etypecase } @w{ digit-char-p eval } @w{ directory eval-when } @w{ directory-namestring evenp } @w{ disassemble every } @w{ division-by-zero exp } @w{ do export } @w{ do* expt } @w{ do-all-symbols extended-char } @w{ do-external-symbols fboundp } @w{ do-symbols fceiling } @w{ documentation fdefinition } @w{ dolist ffloor } @w{ dotimes fifth } @w{ double-float file-author } @w{ double-float-epsilon file-error } @w{ double-float-negative-epsilon file-error-pathname } @w{ dpb file-length } @w{ dribble file-namestring } @w{ dynamic-extent file-position } @w{ ecase file-stream } @w{ echo-stream file-string-length } @w{ echo-stream-input-stream file-write-date } @w{ echo-stream-output-stream fill } @w{ ed fill-pointer } @w{ eighth find } @w{ elt find-all-symbols } @w{ encode-universal-time find-class } @w{ end-of-file find-if } @w{ endp find-if-not } @w{ enough-namestring find-method } @w{ ensure-directories-exist find-package } @w{ ensure-generic-function find-restart } @noindent @w{ Figure 1--7: Symbols in the COMMON-LISP package (part four of twelve).} @end group @end format @page @format @group @noindent @w{ find-symbol get-internal-run-time } @w{ finish-output get-macro-character } @w{ first get-output-stream-string } @w{ fixnum get-properties } @w{ flet get-setf-expansion } @w{ float get-universal-time } @w{ float-digits getf } @w{ float-precision gethash } @w{ float-radix go } @w{ float-sign graphic-char-p } @w{ floating-point-inexact handler-bind } @w{ floating-point-invalid-operation handler-case } @w{ floating-point-overflow hash-table } @w{ floating-point-underflow hash-table-count } @w{ floatp hash-table-p } @w{ floor hash-table-rehash-size } @w{ fmakunbound hash-table-rehash-threshold } @w{ force-output hash-table-size } @w{ format hash-table-test } @w{ formatter host-namestring } @w{ fourth identity } @w{ fresh-line if } @w{ fround ignorable } @w{ ftruncate ignore } @w{ ftype ignore-errors } @w{ funcall imagpart } @w{ function import } @w{ function-keywords in-package } @w{ function-lambda-expression incf } @w{ functionp initialize-instance } @w{ gcd inline } @w{ generic-function input-stream-p } @w{ gensym inspect } @w{ gentemp integer } @w{ get integer-decode-float } @w{ get-decoded-time integer-length } @w{ get-dispatch-macro-character integerp } @w{ get-internal-real-time interactive-stream-p } @noindent @w{ Figure 1--8: Symbols in the COMMON-LISP package (part five of twelve).} @end group @end format @page @format @group @noindent @w{ intern lisp-implementation-type } @w{ internal-time-units-per-second lisp-implementation-version } @w{ intersection list } @w{ invalid-method-error list* } @w{ invoke-debugger list-all-packages } @w{ invoke-restart list-length } @w{ invoke-restart-interactively listen } @w{ isqrt listp } @w{ keyword load } @w{ keywordp load-logical-pathname-translations } @w{ labels load-time-value } @w{ lambda locally } @w{ lambda-list-keywords log } @w{ lambda-parameters-limit logand } @w{ last logandc1 } @w{ lcm logandc2 } @w{ ldb logbitp } @w{ ldb-test logcount } @w{ ldiff logeqv } @w{ least-negative-double-float logical-pathname } @w{ least-negative-long-float logical-pathname-translations } @w{ least-negative-normalized-double-float logior } @w{ least-negative-normalized-long-float lognand } @w{ least-negative-normalized-short-float lognor } @w{ least-negative-normalized-single-float lognot } @w{ least-negative-short-float logorc1 } @w{ least-negative-single-float logorc2 } @w{ least-positive-double-float logtest } @w{ least-positive-long-float logxor } @w{ least-positive-normalized-double-float long-float } @w{ least-positive-normalized-long-float long-float-epsilon } @w{ least-positive-normalized-short-float long-float-negative-epsilon } @w{ least-positive-normalized-single-float long-site-name } @w{ least-positive-short-float loop } @w{ least-positive-single-float loop-finish } @w{ length lower-case-p } @w{ let machine-instance } @w{ let* machine-type } @noindent @w{ Figure 1--9: Symbols in the COMMON-LISP package (part six of twelve). } @end group @end format @page @format @group @noindent @w{ machine-version mask-field } @w{ macro-function max } @w{ macroexpand member } @w{ macroexpand-1 member-if } @w{ macrolet member-if-not } @w{ make-array merge } @w{ make-broadcast-stream merge-pathnames } @w{ make-concatenated-stream method } @w{ make-condition method-combination } @w{ make-dispatch-macro-character method-combination-error } @w{ make-echo-stream method-qualifiers } @w{ make-hash-table min } @w{ make-instance minusp } @w{ make-instances-obsolete mismatch } @w{ make-list mod } @w{ make-load-form most-negative-double-float } @w{ make-load-form-saving-slots most-negative-fixnum } @w{ make-method most-negative-long-float } @w{ make-package most-negative-short-float } @w{ make-pathname most-negative-single-float } @w{ make-random-state most-positive-double-float } @w{ make-sequence most-positive-fixnum } @w{ make-string most-positive-long-float } @w{ make-string-input-stream most-positive-short-float } @w{ make-string-output-stream most-positive-single-float } @w{ make-symbol muffle-warning } @w{ make-synonym-stream multiple-value-bind } @w{ make-two-way-stream multiple-value-call } @w{ makunbound multiple-value-list } @w{ map multiple-value-prog1 } @w{ map-into multiple-value-setq } @w{ mapc multiple-values-limit } @w{ mapcan name-char } @w{ mapcar namestring } @w{ mapcon nbutlast } @w{ maphash nconc } @w{ mapl next-method-p } @w{ maplist nil } @noindent @w{ Figure 1--10: Symbols in the COMMON-LISP package (part seven of twelve).} @end group @end format @page @format @group @noindent @w{ nintersection package-error } @w{ ninth package-error-package } @w{ no-applicable-method package-name } @w{ no-next-method package-nicknames } @w{ not package-shadowing-symbols } @w{ notany package-use-list } @w{ notevery package-used-by-list } @w{ notinline packagep } @w{ nreconc pairlis } @w{ nreverse parse-error } @w{ nset-difference parse-integer } @w{ nset-exclusive-or parse-namestring } @w{ nstring-capitalize pathname } @w{ nstring-downcase pathname-device } @w{ nstring-upcase pathname-directory } @w{ nsublis pathname-host } @w{ nsubst pathname-match-p } @w{ nsubst-if pathname-name } @w{ nsubst-if-not pathname-type } @w{ nsubstitute pathname-version } @w{ nsubstitute-if pathnamep } @w{ nsubstitute-if-not peek-char } @w{ nth phase } @w{ nth-value pi } @w{ nthcdr plusp } @w{ null pop } @w{ number position } @w{ numberp position-if } @w{ numerator position-if-not } @w{ nunion pprint } @w{ oddp pprint-dispatch } @w{ open pprint-exit-if-list-exhausted } @w{ open-stream-p pprint-fill } @w{ optimize pprint-indent } @w{ or pprint-linear } @w{ otherwise pprint-logical-block } @w{ output-stream-p pprint-newline } @w{ package pprint-pop } @noindent @w{ Figure 1--11: Symbols in the COMMON-LISP package (part eight of twelve).} @end group @end format @page @format @group @noindent @w{ pprint-tab read-char } @w{ pprint-tabular read-char-no-hang } @w{ prin1 read-delimited-list } @w{ prin1-to-string read-from-string } @w{ princ read-line } @w{ princ-to-string read-preserving-whitespace } @w{ print read-sequence } @w{ print-not-readable reader-error } @w{ print-not-readable-object readtable } @w{ print-object readtable-case } @w{ print-unreadable-object readtablep } @w{ probe-file real } @w{ proclaim realp } @w{ prog realpart } @w{ prog* reduce } @w{ prog1 reinitialize-instance } @w{ prog2 rem } @w{ progn remf } @w{ program-error remhash } @w{ progv remove } @w{ provide remove-duplicates } @w{ psetf remove-if } @w{ psetq remove-if-not } @w{ push remove-method } @w{ pushnew remprop } @w{ quote rename-file } @w{ random rename-package } @w{ random-state replace } @w{ random-state-p require } @w{ rassoc rest } @w{ rassoc-if restart } @w{ rassoc-if-not restart-bind } @w{ ratio restart-case } @w{ rational restart-name } @w{ rationalize return } @w{ rationalp return-from } @w{ read revappend } @w{ read-byte reverse } @noindent @w{ Figure 1--12: Symbols in the COMMON-LISP package (part nine of twelve).} @end group @end format @page @format @group @noindent @w{ room simple-bit-vector } @w{ rotatef simple-bit-vector-p } @w{ round simple-condition } @w{ row-major-aref simple-condition-format-arguments } @w{ rplaca simple-condition-format-control } @w{ rplacd simple-error } @w{ safety simple-string } @w{ satisfies simple-string-p } @w{ sbit simple-type-error } @w{ scale-float simple-vector } @w{ schar simple-vector-p } @w{ search simple-warning } @w{ second sin } @w{ sequence single-float } @w{ serious-condition single-float-epsilon } @w{ set single-float-negative-epsilon } @w{ set-difference sinh } @w{ set-dispatch-macro-character sixth } @w{ set-exclusive-or sleep } @w{ set-macro-character slot-boundp } @w{ set-pprint-dispatch slot-exists-p } @w{ set-syntax-from-char slot-makunbound } @w{ setf slot-missing } @w{ setq slot-unbound } @w{ seventh slot-value } @w{ shadow software-type } @w{ shadowing-import software-version } @w{ shared-initialize some } @w{ shiftf sort } @w{ short-float space } @w{ short-float-epsilon special } @w{ short-float-negative-epsilon special-operator-p } @w{ short-site-name speed } @w{ signal sqrt } @w{ signed-byte stable-sort } @w{ signum standard } @w{ simple-array standard-char } @w{ simple-base-string standard-char-p } @noindent @w{ Figure 1--13: Symbols in the COMMON-LISP package (part ten of twelve).} @end group @end format @page @format @group @noindent @w{ standard-class sublis } @w{ standard-generic-function subseq } @w{ standard-method subsetp } @w{ standard-object subst } @w{ step subst-if } @w{ storage-condition subst-if-not } @w{ store-value substitute } @w{ stream substitute-if } @w{ stream-element-type substitute-if-not } @w{ stream-error subtypep } @w{ stream-error-stream svref } @w{ stream-external-format sxhash } @w{ streamp symbol } @w{ string symbol-function } @w{ string-capitalize symbol-macrolet } @w{ string-downcase symbol-name } @w{ string-equal symbol-package } @w{ string-greaterp symbol-plist } @w{ string-left-trim symbol-value } @w{ string-lessp symbolp } @w{ string-not-equal synonym-stream } @w{ string-not-greaterp synonym-stream-symbol } @w{ string-not-lessp t } @w{ string-right-trim tagbody } @w{ string-stream tailp } @w{ string-trim tan } @w{ string-upcase tanh } @w{ string/= tenth } @w{ string< terpri } @w{ string<= the } @w{ string= third } @w{ string> throw } @w{ string>= time } @w{ stringp trace } @w{ structure translate-logical-pathname } @w{ structure-class translate-pathname } @w{ structure-object tree-equal } @w{ style-warning truename } @noindent @w{ Figure 1--14: Symbols in the COMMON-LISP package (part eleven of twelve).} @end group @end format @page @format @group @noindent @w{ truncate values-list } @w{ two-way-stream variable } @w{ two-way-stream-input-stream vector } @w{ two-way-stream-output-stream vector-pop } @w{ type vector-push } @w{ type-error vector-push-extend } @w{ type-error-datum vectorp } @w{ type-error-expected-type warn } @w{ type-of warning } @w{ typecase when } @w{ typep wild-pathname-p } @w{ unbound-slot with-accessors } @w{ unbound-slot-instance with-compilation-unit } @w{ unbound-variable with-condition-restarts } @w{ undefined-function with-hash-table-iterator } @w{ unexport with-input-from-string } @w{ unintern with-open-file } @w{ union with-open-stream } @w{ unless with-output-to-string } @w{ unread-char with-package-iterator } @w{ unsigned-byte with-simple-restart } @w{ untrace with-slots } @w{ unuse-package with-standard-io-syntax } @w{ unwind-protect write } @w{ update-instance-for-different-class write-byte } @w{ update-instance-for-redefined-class write-char } @w{ upgraded-array-element-type write-line } @w{ upgraded-complex-part-type write-sequence } @w{ upper-case-p write-string } @w{ use-package write-to-string } @w{ use-value y-or-n-p } @w{ user-homedir-pathname yes-or-no-p } @w{ values zerop } @noindent @w{ Figure 1--15: Symbols in the COMMON-LISP package (part twelve of twelve).} @end group @end format @c end of including concept-cl-symbols @c %**end of chapter gcl-2.6.14/info/chap-22.texi0000644000175000017500000057345414360276512013777 0ustar cammcamm @node Printer, Reader, Streams, Top @chapter Printer @menu * The Lisp Printer:: * The Lisp Pretty Printer:: * Formatted Output:: * Printer Dictionary:: @end menu @node The Lisp Printer, The Lisp Pretty Printer, Printer, Printer @section The Lisp Printer @c including concept-print @menu * Overview of The Lisp Printer:: * Printer Dispatching:: * Default Print-Object Methods:: * Examples of Printer Behavior:: @end menu @node Overview of The Lisp Printer, Printer Dispatching, The Lisp Printer, The Lisp Printer @subsection Overview of The Lisp Printer @r{Common Lisp} provides a representation of most @i{objects} in the form of printed text called the printed representation. Functions such as @b{print} take an @i{object} and send the characters of its printed representation to a @i{stream}. The collection of routines that does this is known as the (@r{Common Lisp}) printer. Reading a printed representation typically produces an @i{object} that is @b{equal} to the originally printed @i{object}. @menu * Multiple Possible Textual Representations:: * Printer Escaping:: @end menu @node Multiple Possible Textual Representations, Printer Escaping, Overview of The Lisp Printer, Overview of The Lisp Printer @subsubsection Multiple Possible Textual Representations Most @i{objects} have more than one possible textual representation. For example, the positive @i{integer} with a magnitude of twenty-seven can be textually expressed in any of these ways: @example 27 27. #o33 #x1B #b11011 #.(* 3 3 3) 81/3 @end example A list containing the two symbols @t{A} and @t{B} can also be textually expressed in a variety of ways: @example (A B) (a b) ( a b ) (\A |B|) (|\A| B ) @end example In general, from the point of view of the @i{Lisp reader}, wherever @i{whitespace} is permissible in a textual representation, any number of @i{spaces} and @i{newlines} can appear in @i{standard syntax}. When a function such as @b{print} produces a printed representation, it must choose from among many possible textual representations. In most cases, it chooses a program readable representation, but in certain cases it might use a more compact notation that is not program-readable. A number of option variables, called @i{printer control variables} @IGindex printer control variable , are provided to permit control of individual aspects of the printed representation of @i{objects}. Figure 22--1 shows the @i{standardized} @i{printer control variables}; there might also be @i{implementation-defined} @i{printer control variables}. @format @group @noindent @w{ *print-array* *print-gensym* *print-pprint-dispatch* } @w{ *print-base* *print-length* *print-pretty* } @w{ *print-case* *print-level* *print-radix* } @w{ *print-circle* *print-lines* *print-readably* } @w{ *print-escape* *print-miser-width* *print-right-margin* } @noindent @w{ Figure 22--1: Standardized Printer Control Variables } @end group @end format In addition to the @i{printer control variables}, the following additional @i{defined names} relate to or affect the behavior of the @i{Lisp printer}: @format @group @noindent @w{ *package* *read-eval* readtable-case } @w{ *read-default-float-format* *readtable* } @noindent @w{ Figure 22--2: Additional Influences on the Lisp printer. } @end group @end format @node Printer Escaping, , Multiple Possible Textual Representations, Overview of The Lisp Printer @subsubsection Printer Escaping The @i{variable} @b{*print-escape*} controls whether the @i{Lisp printer} tries to produce notations such as escape characters and package prefixes. The @i{variable} @b{*print-readably*} can be used to override many of the individual aspects controlled by the other @i{printer control variables} when program-readable output is especially important. One of the many effects of making the @i{value} of @b{*print-readably*} be @i{true} is that the @i{Lisp printer} behaves as if @b{*print-escape*} were also @i{true}. For notational convenience, we say that if the value of either @b{*print-readably*} or @b{*print-escape*} is @i{true}, then @i{printer escaping} @IGindex printer escaping is ``enabled''; and we say that if the values of both @b{*print-readably*} and @b{*print-escape*} are @i{false}, then @i{printer escaping} is ``disabled''. @node Printer Dispatching, Default Print-Object Methods, Overview of The Lisp Printer, The Lisp Printer @subsection Printer Dispatching The @i{Lisp printer} makes its determination of how to print an @i{object} as follows: If the @i{value} of @b{*print-pretty*} is @i{true}, printing is controlled by the @i{current pprint dispatch table}; see @ref{Pretty Print Dispatch Tables}. Otherwise (if the @i{value} of @b{*print-pretty*} is @i{false}), the object's @b{print-object} method is used; see @ref{Default Print-Object Methods}. @node Default Print-Object Methods, Examples of Printer Behavior, Printer Dispatching, The Lisp Printer @subsection Default Print-Object Methods This section describes the default behavior of @b{print-object} methods for the @i{standardized} @i{types}. @menu * Printing Numbers:: * Printing Integers:: * Printing Ratios:: * Printing Floats:: * Printing Complexes:: * Note about Printing Numbers:: * Printing Characters:: * Printing Symbols:: * Package Prefixes for Symbols:: * Effect of Readtable Case on the Lisp Printer:: * Examples of Effect of Readtable Case on the Lisp Printer:: * Printing Strings:: * Printing Lists and Conses:: * Printing Bit Vectors:: * Printing Other Vectors:: * Printing Other Arrays:: * Examples of Printing Arrays:: * Printing Random States:: * Printing Pathnames:: * Printing Structures:: * Printing Other Objects:: @end menu @node Printing Numbers, Printing Integers, Default Print-Object Methods, Default Print-Object Methods @subsubsection Printing Numbers @node Printing Integers, Printing Ratios, Printing Numbers, Default Print-Object Methods @subsubsection Printing Integers @i{Integers} are printed in the radix specified by the @i{current output base} in positional notation, most significant digit first. If appropriate, a radix specifier can be printed; see @b{*print-radix*}. If an @i{integer} is negative, a minus sign is printed and then the absolute value of the @i{integer} is printed. The @i{integer} zero is represented by the single digit @t{0} and never has a sign. A decimal point might be printed, depending on the @i{value} of @b{*print-radix*}. For related information about the syntax of an @i{integer}, see @ref{Syntax of an Integer}. @node Printing Ratios, Printing Floats, Printing Integers, Default Print-Object Methods @subsubsection Printing Ratios @IRindex ratio @i{Ratios} are printed as follows: the absolute value of the numerator is printed, as for an @i{integer}; then a @t{/}; then the denominator. The numerator and denominator are both printed in the radix specified by the @i{current output base}; they are obtained as if by @b{numerator} and @b{denominator}, and so @i{ratios} are printed in reduced form (lowest terms). If appropriate, a radix specifier can be printed; see @b{*print-radix*}. If the ratio is negative, a minus sign is printed before the numerator. For related information about the syntax of a @i{ratio}, see @ref{Syntax of a Ratio}. @node Printing Floats, Printing Complexes, Printing Ratios, Default Print-Object Methods @subsubsection Printing Floats @IRindex float If the magnitude of the @i{float} is either zero or between 10^@r{-3} (inclusive) and 10^7 (exclusive), it is printed as the integer part of the number, then a decimal point, followed by the fractional part of the number; there is always at least one digit on each side of the decimal point. If the sign of the number (as determined by @b{float-sign}) is negative, then a minus sign is printed before the number. If the format of the number does not match that specified by @b{*read-default-float-format*}, then the @i{exponent marker} for that format and the digit @t{0} are also printed. For example, the base of the natural logarithms as a @i{short float} might be printed as @t{2.71828S0}. For non-zero magnitudes outside of the range 10^@r{-3} to 10^7, a @i{float} is printed in computerized scientific notation. The representation of the number is scaled to be between 1 (inclusive) and 10 (exclusive) and then printed, with one digit before the decimal point and at least one digit after the decimal point. Next the @i{exponent marker} for the format is printed, except that if the format of the number matches that specified by @b{*read-default-float-format*}, then the @i{exponent marker} @t{E} is used. Finally, the power of ten by which the fraction must be multiplied to equal the original number is printed as a decimal integer. For example, Avogadro's number as a @i{short float} is printed as @t{6.02S23}. For related information about the syntax of a @i{float}, see @ref{Syntax of a Float}. @node Printing Complexes, Note about Printing Numbers, Printing Floats, Default Print-Object Methods @subsubsection Printing Complexes @IRindex complex A @i{complex} is printed as @t{#C}, an open parenthesis, the printed representation of its real part, a space, the printed representation of its imaginary part, and finally a close parenthesis. For related information about the syntax of a @i{complex}, see @ref{Syntax of a Complex} and @ref{Sharpsign C}. @node Note about Printing Numbers, Printing Characters, Printing Complexes, Default Print-Object Methods @subsubsection Note about Printing Numbers The printed representation of a number must not contain @i{escape} @i{characters}; see @ref{Escape Characters and Potential Numbers}. @node Printing Characters, Printing Symbols, Note about Printing Numbers, Default Print-Object Methods @subsubsection Printing Characters When @i{printer escaping} is disabled, a @i{character} prints as itself; it is sent directly to the output @i{stream}. When @i{printer escaping} is enabled, then @t{#\} syntax is used. When the printer types out the name of a @i{character}, it uses the same table as the @t{#\} @i{reader macro} would use; therefore any @i{character} name that is typed out is acceptable as input (in that @i{implementation}). If a @i{non-graphic} @i{character} has a @i{standardized} @i{name}_5, that @i{name} is preferred over non-standard @i{names} for printing in @t{#\} notation. For the @i{graphic} @i{standard characters}, the @i{character} itself is always used for printing in @t{#\} notation---even if the @i{character} also has a @i{name}_5. For details about the @t{#\} @i{reader macro}, see @ref{Sharpsign Backslash}. @node Printing Symbols, Package Prefixes for Symbols, Printing Characters, Default Print-Object Methods @subsubsection Printing Symbols When @i{printer escaping} is disabled, only the characters of the @i{symbol}'s @i{name} are output (but the case in which to print characters in the @i{name} is controlled by @b{*print-case*}; see @ref{Effect of Readtable Case on the Lisp Printer}). The remainder of this section applies only when @i{printer escaping} is enabled. When printing a @i{symbol}, the printer inserts enough @i{single escape} and/or @i{multiple escape} characters (@i{backslashes} and/or @i{vertical-bars}) so that if @b{read} were called with the same @b{*readtable*} and with @b{*read-base*} bound to the @i{current output base}, it would return the same @i{symbol} (if it is not @i{apparently uninterned}) or an @i{uninterned} @i{symbol} with the same @i{print name} (otherwise). For example, if the @i{value} of @b{*print-base*} were @t{16} when printing the symbol @t{face}, it would have to be printed as @t{\FACE} or @t{\Face} or @t{|FACE|}, because the token @t{face} would be read as a hexadecimal number (decimal value 64206) if the @i{value} of @b{*read-base*} were @t{16}. For additional restrictions concerning characters with nonstandard @i{syntax types} in the @i{current readtable}, see the @i{variable} @b{*print-readably*} For information about how the @i{Lisp reader} parses @i{symbols}, see @ref{Symbols as Tokens} and @ref{Sharpsign Colon}. @b{nil} might be printed as @t{()} when @b{*print-pretty*} is @i{true} and @i{printer escaping} is enabled. @node Package Prefixes for Symbols, Effect of Readtable Case on the Lisp Printer, Printing Symbols, Default Print-Object Methods @subsubsection Package Prefixes for Symbols @i{Package prefixes} are printed if necessary. The rules for @i{package prefixes} are as follows. When the @i{symbol} is printed, if it is in the @t{KEYWORD} @i{package}, then it is printed with a preceding @i{colon}; otherwise, if it is @i{accessible} in the @i{current package}, it is printed without any @i{package prefix}; otherwise, it is printed with a @i{package prefix}. A @i{symbol} that is @i{apparently uninterned} is printed preceded by ``@t{#:}'' if @b{*print-gensym*} is @i{true} and @i{printer escaping} is enabled; if @b{*print-gensym*} is @i{false} or @i{printer escaping} is disabled, then the @i{symbol} is printed without a prefix, as if it were in the @i{current package}. Because the @t{#:} syntax does not intern the following symbol, it is necessary to use circular-list syntax if @b{*print-circle*} is @i{true} and the same uninterned symbol appears several times in an expression to be printed. For example, the result of @example (let ((x (make-symbol "FOO"))) (list x x)) @end example would be printed as @t{(#:foo #:foo)} if @b{*print-circle*} were @i{false}, but as @t{(#1=#:foo #1#)} if @b{*print-circle*} were @i{true}. A summary of the preceding package prefix rules follows: @table @asis @item @t{foo:bar} @t{foo:bar} is printed when @i{symbol} @t{bar} is external in its @i{home package} @t{foo} and is not @i{accessible} in the @i{current package}. @item @t{foo::bar} @t{foo::bar} is printed when @t{bar} is internal in its @i{home package} @t{foo} and is not @i{accessible} in the @i{current package}. @item @t{:bar} @t{:bar} is printed when the home package of @t{bar} is the @t{KEYWORD} @i{package}. @item #:bar @t{#:bar} is printed when @t{bar} is @i{apparently uninterned}, even in the pathological case that @t{bar} has no @i{home package} but is nevertheless somehow @i{accessible} in the @i{current package}. @end table @node Effect of Readtable Case on the Lisp Printer, Examples of Effect of Readtable Case on the Lisp Printer, Package Prefixes for Symbols, Default Print-Object Methods @subsubsection Effect of Readtable Case on the Lisp Printer When @i{printer escaping} is disabled, or the characters under consideration are not already quoted specifically by @i{single escape} or @i{multiple escape} syntax, the @i{readtable case} of the @i{current readtable} affects the way the @i{Lisp printer} writes @i{symbols} in the following ways: @table @asis @item @t{:upcase} When the @i{readtable case} is @t{:upcase}, @i{uppercase} @i{characters} are printed in the case specified by @b{*print-case*}, and @i{lowercase} @i{characters} are printed in their own case. @item @t{:downcase} When the @i{readtable case} is @t{:downcase}, @i{uppercase} @i{characters} are printed in their own case, and @i{lowercase} @i{characters} are printed in the case specified by @b{*print-case*}. @item @t{:preserve} When the @i{readtable case} is @t{:preserve}, all @i{alphabetic} @i{characters} are printed in their own case. @item @t{:invert} When the @i{readtable case} is @t{:invert}, the case of all @i{alphabetic} @i{characters} in single case symbol names is inverted. Mixed-case symbol names are printed as is. @end table The rules for escaping @i{alphabetic} @i{characters} in symbol names are affected by the @b{readtable-case} if @i{printer escaping} is enabled. @i{Alphabetic} @i{characters} are escaped as follows: @table @asis @item @t{:upcase} When the @i{readtable case} is @t{:upcase}, all @i{lowercase} @i{characters} must be escaped. @item @t{:downcase} When the @i{readtable case} is @t{:downcase}, all @i{uppercase} @i{characters} must be escaped. @item @t{:preserve} When the @i{readtable case} is @t{:preserve}, no @i{alphabetic} @i{characters} need be escaped. @item @t{:invert} When the @i{readtable case} is @t{:invert}, no @i{alphabetic} @i{characters} need be escaped. @end table @node Examples of Effect of Readtable Case on the Lisp Printer, Printing Strings, Effect of Readtable Case on the Lisp Printer, Default Print-Object Methods @subsubsection Examples of Effect of Readtable Case on the Lisp Printer @example (defun test-readtable-case-printing () (let ((*readtable* (copy-readtable nil)) (*print-case* *print-case*)) (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output~ ~ ~ (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (print-case '(:upcase :downcase :capitalize)) (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) (setq *print-case* print-case) (format t "~&:~A~15T:~A~29T~A~42T~A" (string-upcase readtable-case) (string-upcase print-case) (symbol-name symbol) (prin1-to-string symbol))))))) @end example The output from @t{(test-readtable-case-printing)} should be as follows: @example READTABLE-CASE *PRINT-CASE* Symbol-name Output -------------------------------------------------- :UPCASE :UPCASE ZEBRA ZEBRA :UPCASE :UPCASE Zebra |Zebra| :UPCASE :UPCASE zebra |zebra| :UPCASE :DOWNCASE ZEBRA zebra :UPCASE :DOWNCASE Zebra |Zebra| :UPCASE :DOWNCASE zebra |zebra| :UPCASE :CAPITALIZE ZEBRA Zebra :UPCASE :CAPITALIZE Zebra |Zebra| :UPCASE :CAPITALIZE zebra |zebra| :DOWNCASE :UPCASE ZEBRA |ZEBRA| :DOWNCASE :UPCASE Zebra |Zebra| :DOWNCASE :UPCASE zebra ZEBRA :DOWNCASE :DOWNCASE ZEBRA |ZEBRA| :DOWNCASE :DOWNCASE Zebra |Zebra| :DOWNCASE :DOWNCASE zebra zebra :DOWNCASE :CAPITALIZE ZEBRA |ZEBRA| :DOWNCASE :CAPITALIZE Zebra |Zebra| :DOWNCASE :CAPITALIZE zebra Zebra :PRESERVE :UPCASE ZEBRA ZEBRA :PRESERVE :UPCASE Zebra Zebra :PRESERVE :UPCASE zebra zebra :PRESERVE :DOWNCASE ZEBRA ZEBRA :PRESERVE :DOWNCASE Zebra Zebra :PRESERVE :DOWNCASE zebra zebra :PRESERVE :CAPITALIZE ZEBRA ZEBRA :PRESERVE :CAPITALIZE Zebra Zebra :PRESERVE :CAPITALIZE zebra zebra :INVERT :UPCASE ZEBRA zebra :INVERT :UPCASE Zebra Zebra :INVERT :UPCASE zebra ZEBRA :INVERT :DOWNCASE ZEBRA zebra :INVERT :DOWNCASE Zebra Zebra :INVERT :DOWNCASE zebra ZEBRA :INVERT :CAPITALIZE ZEBRA zebra :INVERT :CAPITALIZE Zebra Zebra :INVERT :CAPITALIZE zebra ZEBRA @end example @node Printing Strings, Printing Lists and Conses, Examples of Effect of Readtable Case on the Lisp Printer, Default Print-Object Methods @subsubsection Printing Strings The characters of the @i{string} are output in order. If @i{printer escaping} is enabled, a @i{double-quote} is output before and after, and all @i{double-quotes} and @i{single escapes} are preceded by @i{backslash}. The printing of @i{strings} is not affected by @b{*print-array*}. Only the @i{active} @i{elements} of the @i{string} are printed. For information on how the @i{Lisp reader} parses @i{strings}, see @ref{Double-Quote}. @node Printing Lists and Conses, Printing Bit Vectors, Printing Strings, Default Print-Object Methods @subsubsection Printing Lists and Conses Wherever possible, list notation is preferred over dot notation. Therefore the following algorithm is used to print a @i{cons} x: @table @asis @item 1. A @i{left-parenthesis} is printed. @item 2. The @i{car} of x is printed. @item 3. If the @i{cdr} of x is itself a @i{cons}, it is made to be the current @i{cons} (@i{i.e.}, x becomes that @i{cons}), a @i{space} is printed, and step 2 is re-entered. @item 4. If the @i{cdr} of x is not @i{null}, a @i{space}, a @i{dot}, a @i{space}, and the @i{cdr} of x are printed. @item 5. A @i{right-parenthesis} is printed. @end table Actually, the above algorithm is only used when @b{*print-pretty*} is @i{false}. When @b{*print-pretty*} is @i{true} (or when @b{pprint} is used), additional @i{whitespace}_1 may replace the use of a single @i{space}, and a more elaborate algorithm with similar goals but more presentational flexibility is used; see @ref{Printer Dispatching}. Although the two expressions below are equivalent, and the reader accepts either one and produces the same @i{cons}, the printer always prints such a @i{cons} in the second form. @example (a . (b . ((c . (d . nil)) . (e . nil)))) (a b (c d) e) @end example The printing of @i{conses} is affected by @b{*print-level*}, @b{*print-length*}, and @b{*print-circle*}. Following are examples of printed representations of @i{lists}: @example (a . b) ;A dotted pair of a and b (a.b) ;A list of one element, the symbol named a.b (a. b) ;A list of two elements a. and b (a .b) ;A list of two elements a and .b (a b . c) ;A dotted list of a and b with c at the end; two conses .iot ;The symbol whose name is .iot (. b) ;Invalid -- an error is signaled if an attempt is made to read ;this syntax. (a .) ;Invalid -- an error is signaled. (a .. b) ;Invalid -- an error is signaled. (a . . b) ;Invalid -- an error is signaled. (a b c ...) ;Invalid -- an error is signaled. (a \. b) ;A list of three elements a, ., and b (a |.| b) ;A list of three elements a, ., and b (a \... b) ;A list of three elements a, ..., and b (a |...| b) ;A list of three elements a, ..., and b @end example For information on how the @i{Lisp reader} parses @i{lists} and @i{conses}, see @ref{Left-Parenthesis}. @node Printing Bit Vectors, Printing Other Vectors, Printing Lists and Conses, Default Print-Object Methods @subsubsection Printing Bit Vectors A @i{bit vector} is printed as @t{#*} followed by the bits of the @i{bit vector} in order. If @b{*print-array*} is @i{false}, then the @i{bit vector} is printed in a format (using @t{#<}) that is concise but not readable. Only the @i{active} @i{elements} of the @i{bit vector} are printed. [Reviewer Note by Barrett: Need to provide for @t{#5*0} as an alternate notation for @t{#*00000}.] For information on @i{Lisp reader} parsing of @i{bit vectors}, see @ref{Sharpsign Asterisk}. @node Printing Other Vectors, Printing Other Arrays, Printing Bit Vectors, Default Print-Object Methods @subsubsection Printing Other Vectors If @b{*print-array*} is @i{true} and @b{*print-readably*} is @i{false}, any @i{vector} other than a @i{string} or @i{bit vector} is printed using general-vector syntax; this means that information about specialized vector representations does not appear. The printed representation of a zero-length @i{vector} is @t{#()}. The printed representation of a non-zero-length @i{vector} begins with @t{#(}. Following that, the first element of the @i{vector} is printed. If there are any other elements, they are printed in turn, with each such additional element preceded by a @i{space} if @b{*print-pretty*} is @i{false}, or @i{whitespace}_1 if @b{*print-pretty*} is @i{true}. A @i{right-parenthesis} after the last element terminates the printed representation of the @i{vector}. The printing of @i{vectors} is affected by @b{*print-level*} and @b{*print-length*}. If the @i{vector} has a @i{fill pointer}, then only those elements below the @i{fill pointer} are printed. If both @b{*print-array*} and @b{*print-readably*} are @i{false}, the @i{vector} is not printed as described above, but in a format (using @t{#<}) that is concise but not readable. If @b{*print-readably*} is @i{true}, the @i{vector} prints in an @i{implementation-defined} manner; see the @i{variable} @b{*print-readably*}. For information on how the @i{Lisp reader} parses these ``other @i{vectors},'' see @ref{Sharpsign Left-Parenthesis}. @node Printing Other Arrays, Examples of Printing Arrays, Printing Other Vectors, Default Print-Object Methods @subsubsection Printing Other Arrays If @b{*print-array*} is @i{true} and @b{*print-readably*} is @i{false}, any @i{array} other than a @i{vector} is printed using @t{#}@t{n}@t{A} format. Let @t{n} be the @i{rank} of the @i{array}. Then @t{#} is printed, then @t{n} as a decimal integer, then @t{A}, then @t{n} open parentheses. Next the @i{elements} are scanned in row-major order, using @b{write} on each @i{element}, and separating @i{elements} from each other with @i{whitespace}_1. The array's dimensions are numbered 0 to @t{n}-1 from left to right, and are enumerated with the rightmost index changing fastest. Every time the index for dimension @t{j} is incremented, the following actions are taken: @table @asis @item @t{*} If @t{j} < @t{n}-1, then a close parenthesis is printed. @item @t{*} If incrementing the index for dimension @t{j} caused it to equal dimension @t{j}, that index is reset to zero and the index for dimension @t{j}-1 is incremented (thereby performing these three steps recursively), unless @t{j}=0, in which case the entire algorithm is terminated. If incrementing the index for dimension @t{j} did not cause it to equal dimension @t{j}, then a space is printed. @item @t{*} If @t{j} < @t{n}-1, then an open parenthesis is printed. @end table This causes the contents to be printed in a format suitable for @t{:initial-contents} to @b{make-array}. The lists effectively printed by this procedure are subject to truncation by @b{*print-level*} and @b{*print-length*}. If the @i{array} is of a specialized @i{type}, containing bits or characters, then the innermost lists generated by the algorithm given above can instead be printed using bit-vector or string syntax, provided that these innermost lists would not be subject to truncation by @b{*print-length*}. If both @b{*print-array*} and @b{*print-readably*} are @i{false}, then the @i{array} is printed in a format (using @t{#<}) that is concise but not readable. If @b{*print-readably*} is @i{true}, the @i{array} prints in an @i{implementation-defined} manner; see the @i{variable} @b{*print-readably*}. In particular, this may be important for arrays having some dimension @t{0}. For information on how the @i{Lisp reader} parses these ``other @i{arrays},'' see @ref{Sharpsign A}. @node Examples of Printing Arrays, Printing Random States, Printing Other Arrays, Default Print-Object Methods @subsubsection Examples of Printing Arrays @example (let ((a (make-array '(3 3))) (*print-pretty* t) (*print-array* t)) (dotimes (i 3) (dotimes (j 3) (setf (aref a i j) (format nil "<~D,~D>" i j)))) (print a) (print (make-array 9 :displaced-to a))) @t{ |> } #2A(("<0,0>" "<0,1>" "<0,2>") @t{ |> } ("<1,0>" "<1,1>" "<1,2>") @t{ |> } ("<2,0>" "<2,1>" "<2,2>")) @t{ |> } #("<0,0>" "<0,1>" "<0,2>" "<1,0>" "<1,1>" "<1,2>" "<2,0>" "<2,1>" "<2,2>") @result{} # @end example @node Printing Random States, Printing Pathnames, Examples of Printing Arrays, Default Print-Object Methods @subsubsection Printing Random States A specific syntax for printing @i{objects} of @i{type} @b{random-state} is not specified. However, every @i{implementation} must arrange to print a @i{random state} @i{object} in such a way that, within the same implementation, @b{read} can construct from the printed representation a copy of the @i{random state} object as if the copy had been made by @b{make-random-state}. If the type @i{random state} is effectively implemented by using the machinery for @b{defstruct}, the usual structure syntax can then be used for printing @i{random state} objects; one might look something like @example #S(RANDOM-STATE :DATA #(14 49 98436589 786345 8734658324 ... )) @end example where the components are @i{implementation-dependent}. @node Printing Pathnames, Printing Structures, Printing Random States, Default Print-Object Methods @subsubsection Printing Pathnames When @i{printer escaping} is enabled, the syntax @t{#P"..."} is how a @i{pathname} is printed by @b{write} and the other functions herein described. The @t{"..."} is the namestring representation of the pathname. When @i{printer escaping} is disabled, @b{write} writes a @i{pathname} @i{P} by writing @t{(namestring @i{P})} instead. For information on how the @i{Lisp reader} parses @i{pathnames}, see @ref{Sharpsign P}. @node Printing Structures, Printing Other Objects, Printing Pathnames, Default Print-Object Methods @subsubsection Printing Structures By default, a @i{structure} of type S is printed using @t{#S} syntax. This behavior can be customized by specifying a @t{:print-function} or @t{:print-object} option to the @b{defstruct} @i{form} that defines S, or by writing a @b{print-object} @i{method} that is @i{specialized} for @i{objects} of type S. Different structures might print out in different ways; the default notation for structures is: @example #S(@i{structure-name} @{@i{slot-key} @i{slot-value}@}*) @end example where @t{#S} indicates structure syntax, @i{structure-name} is a @i{structure name}, each @i{slot-key} is an initialization argument @i{name} for a @i{slot} in the @i{structure}, and each corresponding @i{slot-value} is a representation of the @i{object} in that @i{slot}. For information on how the @i{Lisp reader} parses @i{structures}, see @ref{Sharpsign S}. @node Printing Other Objects, , Printing Structures, Default Print-Object Methods @subsubsection Printing Other Objects Other @i{objects} are printed in an @i{implementation-dependent} manner. It is not required that an @i{implementation} print those @i{objects} @i{readably}. For example, @i{hash tables}, @i{readtables}, @i{packages}, @i{streams}, and @i{functions} might not print @i{readably}. A common notation to use in this circumstance is @t{#<...>}. Since @t{#<} is not readable by the @i{Lisp reader}, the precise format of the text which follows is not important, but a common format to use is that provided by the @b{print-unreadable-object} @i{macro}. For information on how the @i{Lisp reader} treats this notation, see @ref{Sharpsign Less-Than-Sign}. For information on how to notate @i{objects} that cannot be printed @i{readably}, see @ref{Sharpsign Dot}. @node Examples of Printer Behavior, , Default Print-Object Methods, The Lisp Printer @subsection Examples of Printer Behavior @example (let ((*print-escape* t)) (fresh-line) (write #\a)) @t{ |> } #\a @result{} #\a (let ((*print-escape* nil) (*print-readably* nil)) (fresh-line) (write #\a)) @t{ |> } a @result{} #\a (progn (fresh-line) (prin1 #\a)) @t{ |> } #\a @result{} #\a (progn (fresh-line) (print #\a)) @t{ |> } @t{ |> } #\a @result{} #\a (progn (fresh-line) (princ #\a)) @t{ |> } a @result{} #\a (dolist (val '(t nil)) (let ((*print-escape* val) (*print-readably* val)) (print '#\a) (prin1 #\a) (write-char #\Space) (princ #\a) (write-char #\Space) (write #\a))) @t{ |> } #\a #\a a #\a @t{ |> } #\a #\a a a @result{} NIL (progn (fresh-line) (write '(let ((a 1) (b 2)) (+ a b)))) @t{ |> } (LET ((A 1) (B 2)) (+ A B)) @result{} (LET ((A 1) (B 2)) (+ A B)) (progn (fresh-line) (pprint '(let ((a 1) (b 2)) (+ a b)))) @t{ |> } (LET ((A 1) @t{ |> } (B 2)) @t{ |> } (+ A B)) @result{} (LET ((A 1) (B 2)) (+ A B)) (progn (fresh-line) (write '(let ((a 1) (b 2)) (+ a b)) :pretty t)) @t{ |> } (LET ((A 1) @t{ |> } (B 2)) @t{ |> } (+ A B)) @result{} (LET ((A 1) (B 2)) (+ A B)) (with-output-to-string (s) (write 'write :stream s) (prin1 'prin1 s)) @result{} "WRITEPRIN1" @end example @c end of including concept-print @node The Lisp Pretty Printer, Formatted Output, The Lisp Printer, Printer @section The Lisp Pretty Printer @c including concept-pprint @menu * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: * Notes about the Pretty Printer`s Background:: @end menu @node Pretty Printer Concepts, Examples of using the Pretty Printer, The Lisp Pretty Printer, The Lisp Pretty Printer @subsection Pretty Printer Concepts The facilities provided by the @i{pretty printer} @IGindex pretty printer permit @i{programs} to redefine the way in which @i{code} is displayed, and allow the full power of @i{pretty printing} to be applied to complex combinations of data structures. Whether any given style of output is in fact ``pretty'' is inherently a somewhat subjective issue. However, since the effect of the @i{pretty printer} can be customized by @i{conforming programs}, the necessary flexibility is provided for individual @i{programs} to achieve an arbitrary degree of aesthetic control. By providing direct access to the mechanisms within the pretty printer that make dynamic decisions about layout, the macros and functions @b{pprint-logical-block}, @b{pprint-newline}, and @b{pprint-indent} make it possible to specify pretty printing layout rules as a part of any function that produces output. They also make it very easy for the detection of circularity and sharing, and abbreviation based on length and nesting depth to be supported by the function. The @i{pretty printer} is driven entirely by dispatch based on the @i{value} of @b{*print-pprint-dispatch*}. The @i{function} @b{set-pprint-dispatch} makes it possible for @i{conforming programs} to associate new pretty printing functions with a @i{type}. @menu * Dynamic Control of the Arrangement of Output:: * Format Directive Interface:: * Compiling Format Strings:: * Pretty Print Dispatch Tables:: * Pretty Printer Margins:: @end menu @node Dynamic Control of the Arrangement of Output, Format Directive Interface, Pretty Printer Concepts, Pretty Printer Concepts @subsubsection Dynamic Control of the Arrangement of Output The actions of the @i{pretty printer} when a piece of output is too large to fit in the space available can be precisely controlled. Three concepts underlie the way these operations work---@i{logical blocks} @IGindex logical blocks , @i{conditional newlines} @IGindex conditional newlines , and @i{sections} @IGindex sections . Before proceeding further, it is important to define these terms. The first line of Figure 22--3 shows a schematic piece of output. Each of the characters in the output is represented by ``@t{-}''. The positions of conditional newlines are indicated by digits. The beginnings and ends of logical blocks are indicated by ``@t{<}'' and ``@t{>}'' respectively. The output as a whole is a logical block and the outermost section. This section is indicated by the @t{0}'s on the second line of Figure 1. Logical blocks nested within the output are specified by the macro @b{pprint-logical-block}. Conditional newline positions are specified by calls to @b{pprint-newline}. Each conditional newline defines two sections (one before it and one after it) and is associated with a third (the section immediately containing it). The section after a conditional newline consists of: all the output up to, but not including, (a) the next conditional newline immediately contained in the same logical block; or if (a) is not applicable, (b) the next newline that is at a lesser level of nesting in logical blocks; or if (b) is not applicable, (c) the end of the output. The section before a conditional newline consists of: all the output back to, but not including, (a) the previous conditional newline that is immediately contained in the same logical block; or if (a) is not applicable, (b) the beginning of the immediately containing logical block. The last four lines in Figure 1 indicate the sections before and after the four conditional newlines. The section immediately containing a conditional newline is the shortest section that contains the conditional newline in question. In Figure 22--3, the first conditional newline is immediately contained in the section marked with @t{0}'s, the second and third conditional newlines are immediately contained in the section before the fourth conditional newline, and the fourth conditional newline is immediately contained in the section after the first conditional newline. @example <-1---<--<--2---3->--4-->-> 000000000000000000000000000 11 111111111111111111111111 22 222 333 3333 44444444444444 44444 @end example @w{ Figure 22--2: Example of Logical Blocks, Conditional Newlines, and Sections} Whenever possible, the pretty printer displays the entire contents of a section on a single line. However, if the section is too long to fit in the space available, line breaks are inserted at conditional newline positions within the section. @node Format Directive Interface, Compiling Format Strings, Dynamic Control of the Arrangement of Output, Pretty Printer Concepts @subsubsection Format Directive Interface The primary interface to operations for dynamically determining the arrangement of output is provided through the functions and macros of the pretty printer. Figure 22--3 shows the defined names related to @i{pretty printing}. @format @group @noindent @w{ *print-lines* pprint-dispatch pprint-pop } @w{ *print-miser-width* pprint-exit-if-list-exhausted pprint-tab } @w{ *print-pprint-dispatch* pprint-fill pprint-tabular } @w{ *print-right-margin* pprint-indent set-pprint-dispatch } @w{ copy-pprint-dispatch pprint-linear write } @w{ format pprint-logical-block } @w{ formatter pprint-newline } @noindent @w{ Figure 22--3: Defined names related to pretty printing. } @end group @end format Figure 22--4 identifies a set of @i{format directives} which serve as an alternate interface to the same pretty printing operations in a more textually compact form. @format @group @noindent @w{ @t{~I} @t{~W} @t{~<...~:>} } @w{ @t{~:T} @t{~/.../} @t{~_} } @noindent @w{ Figure 22--4: Format directives related to Pretty Printing} @end group @end format @node Compiling Format Strings, Pretty Print Dispatch Tables, Format Directive Interface, Pretty Printer Concepts @subsubsection Compiling Format Strings A @i{format string} is essentially a program in a special-purpose language that performs printing, and that is interpreted by the @i{function} @b{format}. The @b{formatter} @i{macro} provides the efficiency of using a @i{compiled function} to do that same printing but without losing the textual compactness of @i{format strings}. A @i{format control} @IGindex format control is either a @i{format string} or a @i{function} that was returned by the the @b{formatter} @i{macro}. @node Pretty Print Dispatch Tables, Pretty Printer Margins, Compiling Format Strings, Pretty Printer Concepts @subsubsection Pretty Print Dispatch Tables A @i{pprint dispatch table} @IGindex pprint dispatch table is a mapping from keys to pairs of values. Each key is a @i{type specifier}. The values associated with a key are a ``function'' (specifically, a @i{function designator} or @b{nil}) and a ``numerical priority'' (specifically, a @i{real}). Basic insertion and retrieval is done based on the keys with the equality of keys being tested by @b{equal}. When @b{*print-pretty*} is @i{true}, the @i{current pprint dispatch table} @IGindex current pprint dispatch table (in @b{*print-pprint-dispatch*}) controls how @i{objects} are printed. The information in this table takes precedence over all other mechanisms for specifying how to print @i{objects}. In particular, it has priority over user-defined @b{print-object} @i{methods} because the @i{current pprint dispatch table} is consulted first. The function is chosen from the @i{current pprint dispatch table} by finding the highest priority function that is associated with a @i{type specifier} that matches the @i{object}; if there is more than one such function, it is @i{implementation-dependent} which is used. However, if there is no information in the table about how to @i{pretty print} a particular kind of @i{object}, a @i{function} is invoked which uses @b{print-object} to print the @i{object}. The value of @b{*print-pretty*} is still @i{true} when this function is @i{called}, and individual methods for @b{print-object} might still elect to produce output in a special format conditional on the @i{value} of @b{*print-pretty*}. @node Pretty Printer Margins, , Pretty Print Dispatch Tables, Pretty Printer Concepts @subsubsection Pretty Printer Margins A primary goal of pretty printing is to keep the output between a pair of margins. The column where the output begins is taken as the left margin. If the current column cannot be determined at the time output begins, the left margin is assumed to be zero. The right margin is controlled by @b{*print-right-margin*}. @node Examples of using the Pretty Printer, Notes about the Pretty Printer`s Background, Pretty Printer Concepts, The Lisp Pretty Printer @subsection Examples of using the Pretty Printer As an example of the interaction of logical blocks, conditional newlines, and indentation, consider the function @t{simple-pprint-defun} below. This function prints out lists whose @i{cars} are @b{defun} in the standard way assuming that the list has exactly length @t{4}. @example (defun simple-pprint-defun (*standard-output* list) (pprint-logical-block (*standard-output* list :prefix "(" :suffix ")") (write (first list)) (write-char #\Space) (pprint-newline :miser) (pprint-indent :current 0) (write (second list)) (write-char #\Space) (pprint-newline :fill) (write (third list)) (pprint-indent :block 1) (write-char #\Space) (pprint-newline :linear) (write (fourth list)))) @end example Suppose that one evaluates the following: @example (simple-pprint-defun *standard-output* '(defun prod (x y) (* x y))) @end example If the line width available is greater than or equal to @t{26}, then all of the output appears on one line. If the line width available is reduced to @t{25}, a line break is inserted at the linear-style conditional newline @ITindex linear-style conditional newline before the @i{expression} @t{(* x y)}, producing the output shown. The @t{(pprint-indent :block 1)} causes @t{(* x y)} to be printed at a relative indentation of @t{1} in the logical block. @example (DEFUN PROD (X Y) (* X Y)) @end example If the line width available is @t{15}, a line break is also inserted at the fill style conditional newline before the argument list. The call on @t{(pprint-indent :current 0)} causes the argument list to line up under the function name. @example (DEFUN PROD (X Y) (* X Y)) @end example If @b{*print-miser-width*} were greater than or equal to 14, the example output above would have been as follows, because all indentation changes are ignored in miser mode and line breaks are inserted at miser-style conditional newlines. @ITindex miser-style conditional newline @example (DEFUN PROD (X Y) (* X Y)) @end example As an example of a per-line prefix, consider that evaluating the following produces the output shown with a line width of @t{20} and @b{*print-miser-width*} of @b{nil}. @example (pprint-logical-block (*standard-output* nil :per-line-prefix ";;; ") (simple-pprint-defun *standard-output* '(defun prod (x y) (* x y)))) ;;; (DEFUN PROD ;;; (X Y) ;;; (* X Y)) @end example As a more complex (and realistic) example, consider the function @t{pprint-let} below. This specifies how to print a @b{let} @i{form} in the traditional style. It is more complex than the example above, because it has to deal with nested structure. Also, unlike the example above it contains complete code to readably print any possible list that begins with the @i{symbol} @b{let}. The outermost @b{pprint-logical-block} @i{form} handles the printing of the input list as a whole and specifies that parentheses should be printed in the output. The second @b{pprint-logical-block} @i{form} handles the list of binding pairs. Each pair in the list is itself printed by the innermost @b{pprint-logical-block}. (A @b{loop} @i{form} is used instead of merely decomposing the pair into two @i{objects} so that readable output will be produced no matter whether the list corresponding to the pair has one element, two elements, or (being malformed) has more than two elements.) A space and a fill-style conditional newline @ITindex fill-style conditional newline are placed after each pair except the last. The loop at the end of the topmost @b{pprint-logical-block} @i{form} prints out the forms in the body of the @b{let} @i{form} separated by spaces and linear-style conditional newlines. @example (defun pprint-let (*standard-output* list) (pprint-logical-block (nil list :prefix "(" :suffix ")") (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (loop (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) (loop (write (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :linear))) (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :fill))) (pprint-indent :block 1) (loop (pprint-exit-if-list-exhausted) (write-char #\Space) (pprint-newline :linear) (write (pprint-pop))))) @end example Suppose that one evaluates the following with @b{*print-level*} being 4, and @b{*print-circle*} being @i{true}. @example (pprint-let *standard-output* '#1=(let (x (*print-length* (f (g 3))) (z . 2) (k (car y))) (setq x (sqrt z)) #1#)) @end example If the line length is greater than or equal to @t{77}, the output produced appears on one line. However, if the line length is @t{76}, line breaks are inserted at the linear-style conditional newlines separating the forms in the body and the output below is produced. Note that, the degenerate binding pair @t{x} is printed readably even though it fails to be a list; a depth abbreviation marker is printed in place of @t{(g 3)}; the binding pair @t{(z . 2)} is printed readably even though it is not a proper list; and appropriate circularity markers are printed. @example #1=(LET (X (*PRINT-LENGTH* (F #)) (Z . 2) (K (CAR Y))) (SETQ X (SQRT Z)) #1#) @end example If the line length is reduced to @t{35}, a line break is inserted at one of the fill-style conditional newlines separating the binding pairs. @example #1=(LET (X (*PRINT-PRETTY* (F #)) (Z . 2) (K (CAR Y))) (SETQ X (SQRT Z)) #1#) @end example Suppose that the line length is further reduced to @t{22} and @b{*print-length*} is set to @t{3}. In this situation, line breaks are inserted after both the first and second binding pairs. In addition, the second binding pair is itself broken across two lines. Clause (b) of the description of fill-style conditional newlines (see the @i{function} @b{pprint-newline}) prevents the binding pair @t{(z . 2)} from being printed at the end of the third line. Note that the length abbreviation hides the circularity from view and therefore the printing of circularity markers disappears. @example (LET (X (*PRINT-LENGTH* (F #)) (Z . 2) ...) (SETQ X (SQRT Z)) ...) @end example The next function prints a vector using ``@t{#(...)}'' notation. @example (defun pprint-vector (*standard-output* v) (pprint-logical-block (nil nil :prefix "#(" :suffix ")") (let ((end (length v)) (i 0)) (when (plusp end) (loop (pprint-pop) (write (aref v i)) (if (= (incf i) end) (return nil)) (write-char #\Space) (pprint-newline :fill)))))) @end example Evaluating the following with a line length of 15 produces the output shown. @example (pprint-vector *standard-output* '#(12 34 567 8 9012 34 567 89 0 1 23)) #(12 34 567 8 9012 34 567 89 0 1 23) @end example As examples of the convenience of specifying pretty printing with @i{format strings}, consider that the functions @t{simple-pprint-defun} and @t{pprint-let} used as examples above can be compactly defined as follows. (The function @t{pprint-vector} cannot be defined using @b{format} because the data structure it traverses is not a list.) @example (defun simple-pprint-defun (*standard-output* list) (format T "~:<~W ~@@_~:I~W ~:_~W~1I ~_~W~:>" list)) (defun pprint-let (*standard-output* list) (format T "~:<~W~@t{^}~:<~@@@{~:<~@@@{~W~@t{^}~_~@}~:>~@t{^}~:_~@}~:>~1I~@@@{~@t{^}~_~W~@}~:>" list)) @end example In the following example, the first @i{form} restores @b{*print-pprint-dispatch*} to the equivalent of its initial value. The next two forms then set up a special way to pretty print ratios. Note that the more specific @i{type specifier} has to be associated with a higher priority. @example (setq *print-pprint-dispatch* (copy-pprint-dispatch nil)) (set-pprint-dispatch 'ratio #'(lambda (s obj) (format s "#.(/ ~W ~W)" (numerator obj) (denominator obj)))) (set-pprint-dispatch '(and ratio (satisfies minusp)) #'(lambda (s obj) (format s "#.(- (/ ~W ~W))" (- (numerator obj)) (denominator obj))) 5) (pprint '(1/3 -2/3)) (#.(/ 1 3) #.(- (/ 2 3))) @end example The following two @i{forms} illustrate the definition of pretty printing functions for types of @i{code}. The first @i{form} illustrates how to specify the traditional method for printing quoted objects using @i{single-quote}. Note the care taken to ensure that data lists that happen to begin with @b{quote} will be printed readably. The second form specifies that lists beginning with the symbol @t{my-let} should print the same way that lists beginning with @b{let} print when the initial @i{pprint dispatch table} is in effect. @example (set-pprint-dispatch '(cons (member quote)) () #'(lambda (s list) (if (and (consp (cdr list)) (null (cddr list))) (funcall (formatter "'~W") s (cadr list)) (pprint-fill s list)))) (set-pprint-dispatch '(cons (member my-let)) (pprint-dispatch '(let) nil)) @end example The next example specifies a default method for printing lists that do not correspond to function calls. Note that the functions @b{pprint-linear}, @b{pprint-fill}, and @b{pprint-tabular} are all defined with optional @i{colon-p} and @i{at-sign-p} arguments so that they can be used as @b{pprint dispatch functions} as well as @t{~/.../} functions. @example (set-pprint-dispatch '(cons (not (and symbol (satisfies fboundp)))) #'pprint-fill -5) ;; Assume a line length of 9 (pprint '(0 b c d e f g h i j k)) (0 b c d e f g h i j k) @end example This final example shows how to define a pretty printing function for a user defined data structure. @example (defstruct family mom kids) (set-pprint-dispatch 'family #'(lambda (s f) (funcall (formatter "~@@<#<~;~W and ~2I~_~/pprint-fill/~;>~:>") s (family-mom f) (family-kids f)))) @end example The pretty printing function for the structure @t{family} specifies how to adjust the layout of the output so that it can fit aesthetically into a variety of line widths. In addition, it obeys the printer control variables @b{*print-level*}, @b{*print-length*}, @b{*print-lines*}, @b{*print-circle*} and @b{*print-escape*}, and can tolerate several different kinds of malformity in the data structure. The output below shows what is printed out with a right margin of @t{25}, @b{*print-pretty*} being @i{true}, @b{*print-escape*} being @i{false}, and a malformed @t{kids} list. @example (write (list 'principal-family (make-family :mom "Lucy" :kids '("Mark" "Bob" . "Dan"))) :right-margin 25 :pretty T :escape nil :miser-width nil) (PRINCIPAL-FAMILY #) @end example Note that a pretty printing function for a structure is different from the structure's @b{print-object} @i{method}. While @b{print-object} @i{methods} are permanently associated with a structure, pretty printing functions are stored in @i{pprint dispatch tables} and can be rapidly changed to reflect different printing needs. If there is no pretty printing function for a structure in the current @i{pprint dispatch table}, its @b{print-object} @i{method} is used instead. @node Notes about the Pretty Printer`s Background, , Examples of using the Pretty Printer, The Lisp Pretty Printer @subsection Notes about the Pretty Printer`s Background For a background reference to the abstract concepts detailed in this section, see @i{XP: A Common Lisp Pretty Printing System}. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material. @c end of including concept-pprint @node Formatted Output, Printer Dictionary, The Lisp Pretty Printer, Printer @section Formatted Output @c including concept-format [Editorial Note by KMP: This is transplanted from FORMAT and will need a bit of work before it looks good standing alone. Bear with me.] @b{format} is useful for producing nicely formatted text, producing good-looking messages, and so on. @b{format} can generate and return a @i{string} or output to @i{destination}. The @i{control-string} argument to @b{format} is actually a @i{format control}. That is, it can be either a @i{format string} or a @i{function}, for example a @i{function} returned by the @b{formatter} @i{macro}. If it is a @i{function}, the @i{function} is called with the appropriate output stream as its first argument and the data arguments to @b{format} as its remaining arguments. The function should perform whatever output is necessary and return the unused tail of the arguments (if any). The compilation process performed by @b{formatter} produces a @i{function} that would do with its @i{arguments} as the @b{format} interpreter would do with those @i{arguments}. The remainder of this section describes what happens if the @i{control-string} is a @i{format string}. @i{Control-string} is composed of simple text (@i{characters}) and embedded directives. @b{format} writes the simple text as is; each embedded directive specifies further text output that is to appear at the corresponding point within the simple text. Most directives use one or more elements of @i{args} to create their output. A directive consists of a @i{tilde}, optional prefix parameters separated by commas, optional @i{colon} and @i{at-sign} modifiers, and a single character indicating what kind of directive this is. There is no required ordering between the @i{at-sign} and @i{colon} modifier. The @i{case} of the directive character is ignored. Prefix parameters are notated as signed (sign is optional) decimal numbers, or as a @i{single-quote} followed by a character. For example, @t{~5,'0d} can be used to print an @i{integer} in decimal radix in five columns with leading zeros, or @t{~5,'*d} to get leading asterisks. In place of a prefix parameter to a directive, @t{V} (or @t{v}) can be used. In this case, @b{format} takes an argument from @i{args} as a parameter to the directive. The argument should be an @i{integer} or @i{character}. If the @i{arg} used by a @t{V} parameter is @b{nil}, the effect is as if the parameter had been omitted. @t{#} can be used in place of a prefix parameter; it represents the number of @i{args} remaining to be processed. When used within a recursive format, in the context of @t{~?} or @t{~@{}, the @t{#} prefix parameter represents the number of @i{format arguments} remaining within the recursive call. Examples of @i{format strings}: @format @group @noindent @w{ @t{"~S"} ;This is an S directive with no parameters or modifiers. } @w{ @t{"~3,-4:@@s"} ;This is an S directive with two parameters, @t{3} and @t{-4}, } @w{ ; and both the @i{colon} and @i{at-sign} flags. } @w{ @t{"~,+4S"} ;Here the first prefix parameter is omitted and takes } @w{ ; on its default value, while the second parameter is @t{4}. } @noindent @w{ Figure 22--5: Examples of format control strings } @end group @end format @b{format} sends the output to @i{destination}. If @i{destination} is @b{nil}, @b{format} creates and returns a @i{string} containing the output from @i{control-string}. If @i{destination} is @i{non-nil}, it must be a @i{string} with a @i{fill pointer}, a @i{stream}, or the symbol @b{t}. If @i{destination} is a @i{string} with a @i{fill pointer}, the output is added to the end of the @i{string}. If @i{destination} is a @i{stream}, the output is sent to that @i{stream}. If @i{destination} is @b{t}, the output is sent to @i{standard output}. In the description of the directives that follows, the term @i{arg} in general refers to the next item of the set of @i{args} to be processed. The word or phrase at the beginning of each description is a mnemonic for the directive. @b{format} directives do not bind any of the printer control variables (@b{*print-...*}) except as specified in the following descriptions. Implementations may specify the binding of new, implementation-specific printer control variables for each @b{format} directive, but they may neither bind any standard printer control variables not specified in description of a @b{format} directive nor fail to bind any standard printer control variables as specified in the description. @menu * FORMAT Basic Output:: * FORMAT Radix Control:: * FORMAT Floating-Point Printers:: * FORMAT Printer Operations:: * FORMAT Pretty Printer Operations:: * FORMAT Layout Control:: * FORMAT Control-Flow Operations:: * FORMAT Miscellaneous Operations:: * FORMAT Miscellaneous Pseudo-Operations:: * Additional Information about FORMAT Operations:: * Examples of FORMAT:: * Notes about FORMAT:: @end menu @node FORMAT Basic Output, FORMAT Radix Control, Formatted Output, Formatted Output @subsection FORMAT Basic Output @menu * Tilde C-> Character:: * Tilde Percent-> Newline:: * Tilde Ampersand-> Fresh-Line:: * Tilde Vertical-Bar-> Page:: * Tilde Tilde-> Tilde:: @end menu @node Tilde C-> Character, Tilde Percent-> Newline, FORMAT Basic Output, FORMAT Basic Output @subsubsection Tilde C: Character The next @i{arg} should be a @i{character}; it is printed according to the modifier flags. @t{~C} prints the @i{character} as if by using @b{write-char} if it is a @i{simple character}. @i{Characters} that are not @i{simple} are not necessarily printed as if by @b{write-char}, but are displayed in an @i{implementation-defined}, abbreviated format. For example, @example (format nil "~C" #\A) @result{} "A" (format nil "~C" #\Space) @result{} " " @end example @t{~:C} is the same as @t{~C} for @i{printing} @i{characters}, but other @i{characters} are ``spelled out.'' The intent is that this is a ``pretty'' format for printing characters. For @i{simple} @i{characters} that are not @i{printing}, what is spelled out is the @i{name} of the @i{character} (see @b{char-name}). For @i{characters} that are not @i{simple} and not @i{printing}, what is spelled out is @i{implementation-defined}. For example, @example (format nil "~:C" #\A) @result{} "A" (format nil "~:C" #\Space) @result{} "Space" ;; This next example assumes an implementation-defined "Control" attribute. (format nil "~:C" #\Control-Space) @result{} "Control-Space" @i{OR}@result{} "c-Space" @end example @t{~:@@C} prints what @t{~:C} would, and then if the @i{character} requires unusual shift keys on the keyboard to type it, this fact is mentioned. For example, @example (format nil "~:@@C" #\Control-Partial) @result{} "Control-\partial (Top-F)" @end example This is the format used for telling the user about a key he is expected to type, in prompts, for instance. The precise output may depend not only on the implementation, but on the particular I/O devices in use. @t{~@@C} prints the @i{character} in a way that the @i{Lisp reader} can understand, using @t{#\} syntax. @t{~@@C} binds @b{*print-escape*} to @b{t}. @node Tilde Percent-> Newline, Tilde Ampersand-> Fresh-Line, Tilde C-> Character, FORMAT Basic Output @subsubsection Tilde Percent: Newline This outputs a @t{#\Newline} character, thereby terminating the current output line and beginning a new one. @t{~@i{n}%} outputs @i{n} newlines. No @i{arg} is used. @node Tilde Ampersand-> Fresh-Line, Tilde Vertical-Bar-> Page, Tilde Percent-> Newline, FORMAT Basic Output @subsubsection Tilde Ampersand: Fresh-Line Unless it can be determined that the output stream is already at the beginning of a line, this outputs a newline. @t{~@i{n}&} calls @b{fresh-line} and then outputs @i{n}- 1 newlines. @t{~0&} does nothing. @node Tilde Vertical-Bar-> Page, Tilde Tilde-> Tilde, Tilde Ampersand-> Fresh-Line, FORMAT Basic Output @subsubsection Tilde Vertical-Bar: Page This outputs a page separator character, if possible. @t{~@i{n}|} does this @i{n} times. @node Tilde Tilde-> Tilde, , Tilde Vertical-Bar-> Page, FORMAT Basic Output @subsubsection Tilde Tilde: Tilde This outputs a @i{tilde}. @t{~@i{n}~} outputs @i{n} tildes. @node FORMAT Radix Control, FORMAT Floating-Point Printers, FORMAT Basic Output, Formatted Output @subsection FORMAT Radix Control @menu * Tilde R-> Radix:: * Tilde D-> Decimal:: * Tilde B-> Binary:: * Tilde O-> Octal:: * Tilde X-> Hexadecimal:: @end menu @node Tilde R-> Radix, Tilde D-> Decimal, FORMAT Radix Control, FORMAT Radix Control @subsubsection Tilde R: Radix @t{~@i{n}R} prints @i{arg} in radix @i{n}. The modifier flags and any remaining parameters are used as for the @t{~D} directive. @t{~D} is the same as @t{~10R}. The full form is @t{~@i{radix},@i{mincol},@i{padchar},@i{commachar},@i{comma-interval}R}. If no prefix parameters are given to @t{~R}, then a different interpretation is given. The argument should be an @i{integer}. For example, if @i{arg} is 4: @table @asis @item @t{*} @t{~R} prints @i{arg} as a cardinal English number: @t{four}. @item @t{*} @t{~:R} prints @i{arg} as an ordinal English number: @t{fourth}. @item @t{*} @t{~@@R} prints @i{arg} as a Roman numeral: @t{IV}. @item @t{*} @t{~:@@R} prints @i{arg} as an old Roman numeral: @t{IIII}. @end table For example: @example (format nil "~,,' ,4:B" 13) @result{} "1101" (format nil "~,,' ,4:B" 17) @result{} "1 0001" (format nil "~19,0,' ,4:B" 3333) @result{} "0000 1101 0000 0101" (format nil "~3,,,' ,2:R" 17) @result{} "1 22" (format nil "~,,'|,2:D" #xFFFF) @result{} "6|55|35" @end example If and only if the first parameter, @i{n}, is supplied, @t{~R} binds @b{*print-escape*} to @i{false}, @b{*print-radix*} to @i{false}, @b{*print-base*} to @i{n}, and @b{*print-readably*} to @i{false}. If and only if no parameters are supplied, @t{~R} binds @b{*print-base*} to @t{10}. @node Tilde D-> Decimal, Tilde B-> Binary, Tilde R-> Radix, FORMAT Radix Control @subsubsection Tilde D: Decimal An @i{arg}, which should be an @i{integer}, is printed in decimal radix. @t{~D} will never put a decimal point after the number. @t{~@i{mincol}D} uses a column width of @i{mincol}; spaces are inserted on the left if the number requires fewer than @i{mincol} columns for its digits and sign. If the number doesn't fit in @i{mincol} columns, additional columns are used as needed. @t{~@i{mincol},@i{padchar}D} uses @i{padchar} as the pad character instead of space. If @i{arg} is not an @i{integer}, it is printed in @t{~A} format and decimal base. The @t{@@} modifier causes the number's sign to be printed always; the default is to print it only if the number is negative. The @t{:} modifier causes commas to be printed between groups of digits; @i{commachar} may be used to change the character used as the comma. @i{comma-interval} must be an @i{integer} and defaults to 3. When the @t{:} modifier is given to any of these directives, the @i{commachar} is printed between groups of @i{comma-interval} digits. Thus the most general form of @t{~D} is @t{~@i{mincol},@i{padchar},@i{commachar},@i{comma-interval}D}. @t{~D} binds @b{*print-escape*} to @i{false}, @b{*print-radix*} to @i{false}, @b{*print-base*} to @t{10}, and @b{*print-readably*} to @i{false}. @node Tilde B-> Binary, Tilde O-> Octal, Tilde D-> Decimal, FORMAT Radix Control @subsubsection Tilde B: Binary This is just like @t{~D} but prints in binary radix (radix 2) instead of decimal. The full form is therefore @t{~@i{mincol},@i{padchar},@i{commachar},@i{comma-interval}B}. @t{~B} binds @b{*print-escape*} to @i{false}, @b{*print-radix*} to @i{false}, @b{*print-base*} to @t{2}, and @b{*print-readably*} to @i{false}. @node Tilde O-> Octal, Tilde X-> Hexadecimal, Tilde B-> Binary, FORMAT Radix Control @subsubsection Tilde O: Octal This is just like @t{~D} but prints in octal radix (radix 8) instead of decimal. The full form is therefore @t{~@i{mincol},@i{padchar},@i{commachar},@i{comma-interval}O}. @t{~O} binds @b{*print-escape*} to @i{false}, @b{*print-radix*} to @i{false}, @b{*print-base*} to @t{8}, and @b{*print-readably*} to @i{false}. @node Tilde X-> Hexadecimal, , Tilde O-> Octal, FORMAT Radix Control @subsubsection Tilde X: Hexadecimal This is just like @t{~D} but prints in hexadecimal radix (radix 16) instead of decimal. The full form is therefore @t{~@i{mincol},@i{padchar},@i{commachar},@i{comma-interval}X}. @t{~X} binds @b{*print-escape*} to @i{false}, @b{*print-radix*} to @i{false}, @b{*print-base*} to @t{16}, and @b{*print-readably*} to @i{false}. @node FORMAT Floating-Point Printers, FORMAT Printer Operations, FORMAT Radix Control, Formatted Output @subsection FORMAT Floating-Point Printers @menu * Tilde F-> Fixed-Format Floating-Point:: * Tilde E-> Exponential Floating-Point:: * Tilde G-> General Floating-Point:: * Tilde Dollarsign-> Monetary Floating-Point:: @end menu @node Tilde F-> Fixed-Format Floating-Point, Tilde E-> Exponential Floating-Point, FORMAT Floating-Point Printers, FORMAT Floating-Point Printers @subsubsection Tilde F: Fixed-Format Floating-Point The next @i{arg} is printed as a @i{float}. The full form is @t{~@i{w},@i{d},@i{k},@i{overflowchar},@i{padchar}F}. The parameter @i{w} is the width of the field to be printed; @i{d} is the number of digits to print after the decimal point; @i{k} is a scale factor that defaults to zero. Exactly @i{w} characters will be output. First, leading copies of the character @i{padchar} (which defaults to a space) are printed, if necessary, to pad the field on the left. If the @i{arg} is negative, then a minus sign is printed; if the @i{arg} is not negative, then a plus sign is printed if and only if the @t{@@} modifier was supplied. Then a sequence of digits, containing a single embedded decimal point, is printed; this represents the magnitude of the value of @i{arg} times 10^@i{k}, rounded to @i{d} fractional digits. When rounding up and rounding down would produce printed values equidistant from the scaled value of @i{arg}, then the implementation is free to use either one. For example, printing the argument @t{6.375} using the format @t{~4,2F} may correctly produce either @t{6.37} or @t{6.38}. Leading zeros are not permitted, except that a single zero digit is output before the decimal point if the printed value is less than one, and this single zero digit is not output at all if @i{w}=@i{d}+1. If it is impossible to print the value in the required format in a field of width @i{w}, then one of two actions is taken. If the parameter @i{overflowchar} is supplied, then @i{w} copies of that parameter are printed instead of the scaled value of @i{arg}. If the @i{overflowchar} parameter is omitted, then the scaled value is printed using more than @i{w} characters, as many more as may be needed. If the @i{w} parameter is omitted, then the field is of variable width. In effect, a value is chosen for @i{w} in such a way that no leading pad characters need to be printed and exactly @i{d} characters will follow the decimal point. For example, the directive @t{~,2F} will print exactly two digits after the decimal point and as many as necessary before the decimal point. If the parameter @i{d} is omitted, then there is no constraint on the number of digits to appear after the decimal point. A value is chosen for @i{d} in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter @i{w} and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero, then a single zero digit should appear after the decimal point if permitted by the width constraint. If both @i{w} and @i{d} are omitted, then the effect is to print the value using ordinary free-format output; @b{prin1} uses this format for any number whose magnitude is either zero or between 10^@r{-3} (inclusive) and 10^7 (exclusive). If @i{w} is omitted, then if the magnitude of @i{arg} is so large (or, if @i{d} is also omitted, so small) that more than 100 digits would have to be printed, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive @t{~E} (with all parameters to @t{~E} defaulted, not taking their values from the @t{~F} directive). If @i{arg} is a @i{rational} number, then it is coerced to be a @i{single float} and then printed. Alternatively, an implementation is permitted to process a @i{rational} number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If @i{w} and @i{d} are not supplied and the number has no exact decimal representation, for example @t{1/3}, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed. If @i{arg} is a @i{complex} number or some non-numeric @i{object}, then it is printed using the format directive @t{~@i{w}D}, thereby printing it in decimal radix and a minimum field width of @i{w}. @t{~F} binds @b{*print-escape*} to @i{false} and @b{*print-readably*} to @i{false}. @node Tilde E-> Exponential Floating-Point, Tilde G-> General Floating-Point, Tilde F-> Fixed-Format Floating-Point, FORMAT Floating-Point Printers @subsubsection Tilde E: Exponential Floating-Point The next @i{arg} is printed as a @i{float} in exponential notation. The full form is @t{~@i{w},@i{d},@i{e},@i{k},@i{overflowchar},@i{padchar},@i{exponentchar}E}. The parameter @i{w} is the width of the field to be printed; @i{d} is the number of digits to print after the decimal point; @i{e} is the number of digits to use when printing the exponent; @i{k} is a scale factor that defaults to one (not zero). Exactly @i{w} characters will be output. First, leading copies of the character @i{padchar} (which defaults to a space) are printed, if necessary, to pad the field on the left. If the @i{arg} is negative, then a minus sign is printed; if the @i{arg} is not negative, then a plus sign is printed if and only if the @t{@@} modifier was supplied. Then a sequence of digits containing a single embedded decimal point is printed. The form of this sequence of digits depends on the scale factor @i{k}. If @i{k} is zero, then @i{d} digits are printed after the decimal point, and a single zero digit appears before the decimal point if the total field width will permit it. If @i{k} is positive, then it must be strictly less than @i{d}+2; @i{k} significant digits are printed before the decimal point, and @i{d}- @i{k}+1 digits are printed after the decimal point. If @i{k} is negative, then it must be strictly greater than - @i{d}; a single zero digit appears before the decimal point if the total field width will permit it, and after the decimal point are printed first - @i{k} zeros and then @i{d}+@i{k} significant digits. The printed fraction must be properly rounded. When rounding up and rounding down would produce printed values equidistant from the scaled value of @i{arg}, then the implementation is free to use either one. For example, printing the argument @t{637.5} using the format @t{~8,2E} may correctly produce either @t{6.37E+2} or @t{6.38E+2}. Following the digit sequence, the exponent is printed. First the character parameter @i{exponentchar} is printed; if this parameter is omitted, then the @i{exponent marker} that @b{prin1} would use is printed, as determined from the type of the @i{float} and the current value of @b{*read-default-float-format*}. Next, either a plus sign or a minus sign is printed, followed by @i{e} digits representing the power of ten by which the printed fraction must be multiplied to properly represent the rounded value of @i{arg}. If it is impossible to print the value in the required format in a field of width @i{w}, possibly because @i{k} is too large or too small or because the exponent cannot be printed in @i{e} character positions, then one of two actions is taken. If the parameter @i{overflowchar} is supplied, then @i{w} copies of that parameter are printed instead of the scaled value of @i{arg}. If the @i{overflowchar} parameter is omitted, then the scaled value is printed using more than @i{w} characters, as many more as may be needed; if the problem is that @i{d} is too small for the supplied @i{k} or that @i{e} is too small, then a larger value is used for @i{d} or @i{e} as may be needed. If the @i{w} parameter is omitted, then the field is of variable width. In effect a value is chosen for @i{w} in such a way that no leading pad characters need to be printed. If the parameter @i{d} is omitted, then there is no constraint on the number of digits to appear. A value is chosen for @i{d} in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter @i{w}, the constraint of the scale factor @i{k}, and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero then a single zero digit should appear after the decimal point. If the parameter @i{e} is omitted, then the exponent is printed using the smallest number of digits necessary to represent its value. If all of @i{w}, @i{d}, and @i{e} are omitted, then the effect is to print the value using ordinary free-format exponential-notation output; @b{prin1} uses a similar format for any non-zero number whose magnitude is less than 10^@r{-3} or greater than or equal to 10^7. The only difference is that the @t{~E} directive always prints a plus or minus sign in front of the exponent, while @b{prin1} omits the plus sign if the exponent is non-negative. If @i{arg} is a @i{rational} number, then it is coerced to be a @i{single float} and then printed. Alternatively, an implementation is permitted to process a @i{rational} number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If @i{w} and @i{d} are unsupplied and the number has no exact decimal representation, for example @t{1/3}, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed. If @i{arg} is a @i{complex} number or some non-numeric @i{object}, then it is printed using the format directive @t{~@i{w}D}, thereby printing it in decimal radix and a minimum field width of @i{w}. @t{~E} binds @b{*print-escape*} to @i{false} and @b{*print-readably*} to @i{false}. @node Tilde G-> General Floating-Point, Tilde Dollarsign-> Monetary Floating-Point, Tilde E-> Exponential Floating-Point, FORMAT Floating-Point Printers @subsubsection Tilde G: General Floating-Point The next @i{arg} is printed as a @i{float} in either fixed-format or exponential notation as appropriate. The full form is @t{~@i{w},@i{d},@i{e},@i{k},@i{overflowchar},@i{padchar},@i{exponentchar}G}. The format in which to print @i{arg} depends on the magnitude (absolute value) of the @i{arg}. Let @i{n} be an integer such that 10^@r{@r{n}-1} \le |@i{arg}| < 10^@i{n}. Let @i{ee} equal @i{e}+2, or 4 if @i{e} is omitted. Let @i{ww} equal @i{w}- @i{ee}, or @b{nil} if @i{w} is omitted. If @i{d} is omitted, first let @i{q} be the number of digits needed to print @i{arg} with no loss of information and without leading or trailing zeros; then let @i{d} equal @t{(max @i{q} (min @i{n} 7))}. Let @i{dd} equal @i{d}- @i{n}. If 0 \le @i{dd} \le @i{d}, then @i{arg} is printed as if by the format directives @t{~@i{ww},@i{dd},,@i{overflowchar},@i{padchar}F~@i{ee}@@T} Note that the scale factor @i{k} is not passed to the @t{~F} directive. For all other values of @i{dd}, @i{arg} is printed as if by the format directive @t{~@i{w},@i{d},@i{e},@i{k},@i{overflowchar},@i{padchar},@i{exponentchar}E} In either case, an @t{@@} modifier is supplied to the @t{~F} or @t{~E} directive if and only if one was supplied to the @t{~G} directive. @t{~G} binds @b{*print-escape*} to @i{false} and @b{*print-readably*} to @i{false}. @node Tilde Dollarsign-> Monetary Floating-Point, , Tilde G-> General Floating-Point, FORMAT Floating-Point Printers @subsubsection Tilde Dollarsign: Monetary Floating-Point The next @i{arg} is printed as a @i{float} in fixed-format notation. The full form is @t{~@i{d},@i{n},@i{w},@i{padchar}$}. The parameter @i{d} is the number of digits to print after the decimal point (default value 2); @i{n} is the minimum number of digits to print before the decimal point (default value 1); @i{w} is the minimum total width of the field to be printed (default value 0). First padding and the sign are output. If the @i{arg} is negative, then a minus sign is printed; if the @i{arg} is not negative, then a plus sign is printed if and only if the @t{@@} modifier was supplied. If the @t{:} modifier is used, the sign appears before any padding, and otherwise after the padding. If @i{w} is supplied and the number of other characters to be output is less than @i{w}, then copies of @i{padchar} (which defaults to a space) are output to make the total field width equal @i{w}. Then @i{n} digits are printed for the integer part of @i{arg}, with leading zeros if necessary; then a decimal point; then @i{d} digits of fraction, properly rounded. If the magnitude of @i{arg} is so large that more than @i{m} digits would have to be printed, where @i{m} is the larger of @i{w} and 100, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive @t{~@i{w},@i{q},,,,@i{padchar}E}, where @i{w} and @i{padchar} are present or omitted according to whether they were present or omitted in the @t{~$} directive, and where @i{q}=@i{d}+@i{n}- 1, where @i{d} and @i{n} are the (possibly default) values given to the @t{~$} directive. If @i{arg} is a @i{rational} number, then it is coerced to be a @i{single float} and then printed. Alternatively, an implementation is permitted to process a @i{rational} number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If @i{arg} is a @i{complex} number or some non-numeric @i{object}, then it is printed using the format directive @t{~@i{w}D}, thereby printing it in decimal radix and a minimum field width of @i{w}. @t{~$} binds @b{*print-escape*} to @i{false} and @b{*print-readably*} to @i{false}. @node FORMAT Printer Operations, FORMAT Pretty Printer Operations, FORMAT Floating-Point Printers, Formatted Output @subsection FORMAT Printer Operations @menu * Tilde A-> Aesthetic:: * Tilde S-> Standard:: * Tilde W-> Write:: @end menu @node Tilde A-> Aesthetic, Tilde S-> Standard, FORMAT Printer Operations, FORMAT Printer Operations @subsubsection Tilde A: Aesthetic An @i{arg}, any @i{object}, is printed without escape characters (as by @b{princ}). If @i{arg} is a @i{string}, its @i{characters} will be output verbatim. If @i{arg} is @b{nil} it will be printed as @b{nil}; the @i{colon} modifier (@t{~:A}) will cause an @i{arg} of @b{nil} to be printed as @t{()}, but if @i{arg} is a composite structure, such as a @i{list} or @i{vector}, any contained occurrences of @b{nil} will still be printed as @b{nil}. @t{~@i{mincol}A} inserts spaces on the right, if necessary, to make the width at least @i{mincol} columns. The @t{@@} modifier causes the spaces to be inserted on the left rather than the right. @t{~@i{mincol},@i{colinc},@i{minpad},@i{padchar}A} is the full form of @t{~A}, which allows control of the padding. The @i{string} is padded on the right (or on the left if the @t{@@} modifier is used) with at least @i{minpad} copies of @i{padchar}; padding characters are then inserted @i{colinc} characters at a time until the total width is at least @i{mincol}. The defaults are @t{0} for @i{mincol} and @i{minpad}, @t{1} for @i{colinc}, and the space character for @i{padchar}. @t{~A} binds @b{*print-escape*} to @i{false}, and @b{*print-readably*} to @i{false}. @node Tilde S-> Standard, Tilde W-> Write, Tilde A-> Aesthetic, FORMAT Printer Operations @subsubsection Tilde S: Standard This is just like @t{~A}, but @i{arg} is printed with escape characters (as by @b{prin1} rather than @t{princ}). The output is therefore suitable for input to @b{read}. @t{~S} accepts all the arguments and modifiers that @t{~A} does. @t{~S} binds @b{*print-escape*} to @b{t}. @node Tilde W-> Write, , Tilde S-> Standard, FORMAT Printer Operations @subsubsection Tilde W: Write An argument, any @i{object}, is printed obeying every printer control variable (as by @b{write}). In addition, @t{~W} interacts correctly with depth abbreviation, by not resetting the depth counter to zero. @t{~W} does not accept parameters. If given the @i{colon} modifier, @t{~W} binds @b{*print-pretty*} to @i{true}. If given the @i{at-sign} modifier, @t{~W} binds @b{*print-level*} and @b{*print-length*} to @b{nil}. @t{~W} provides automatic support for the detection of circularity and sharing. If the @i{value} of @b{*print-circle*} is not @b{nil} and @t{~W} is applied to an argument that is a circular (or shared) reference, an appropriate @t{#@i{n}#} marker is inserted in the output instead of printing the argument. @node FORMAT Pretty Printer Operations, FORMAT Layout Control, FORMAT Printer Operations, Formatted Output @subsection FORMAT Pretty Printer Operations The following constructs provide access to the @i{pretty printer}: @menu * Tilde Underscore-> Conditional Newline:: * Tilde Less-Than-Sign-> Logical Block:: * Tilde I-> Indent:: * Tilde Slash-> Call Function:: @end menu @node Tilde Underscore-> Conditional Newline, Tilde Less-Than-Sign-> Logical Block, FORMAT Pretty Printer Operations, FORMAT Pretty Printer Operations @subsubsection Tilde Underscore: Conditional Newline Without any modifiers, @t{~_} is the same as @t{(pprint-newline :linear)}. @t{~@@_} is the same as @t{(pprint-newline :miser)}. @t{~:_} is the same as @t{(pprint-newline :fill)}. @t{~:@@_} is the same as @t{(pprint-newline :mandatory)}. @node Tilde Less-Than-Sign-> Logical Block, Tilde I-> Indent, Tilde Underscore-> Conditional Newline, FORMAT Pretty Printer Operations @subsubsection Tilde Less-Than-Sign: Logical Block @t{~<...~:>} If @t{~:>} is used to terminate a @t{~<...~>}, the directive is equivalent to a call to @b{pprint-logical-block}. The argument corresponding to the @t{~<...~:>} directive is treated in the same way as the @i{list} argument to @b{pprint-logical-block}, thereby providing automatic support for non-@i{list} arguments and the detection of circularity, sharing, and depth abbreviation. The portion of the @i{control-string} nested within the @t{~<...~:>} specifies the @t{:prefix} (or @t{:per-line-prefix}), @t{:suffix}, and body of the @b{pprint-logical-block}. The @i{control-string} portion enclosed by @t{~<...~:>} can be divided into segments @t{~<@i{prefix}~;@i{body}~;@i{suffix}~:>} by @t{~;} directives. If the first section is terminated by @t{~@@;}, it specifies a per-line prefix rather than a simple prefix. The @i{prefix} and @i{suffix} cannot contain format directives. An error is signaled if either the prefix or suffix fails to be a constant string or if the enclosed portion is divided into more than three segments. If the enclosed portion is divided into only two segments, the @i{suffix} defaults to the null string. If the enclosed portion consists of only a single segment, both the @i{prefix} and the @i{suffix} default to the null string. If the @i{colon} modifier is used (@i{i.e.}, @t{~:<...~:>}), the @i{prefix} and @i{suffix} default to @t{"("} and @t{")"} (respectively) instead of the null string. The body segment can be any arbitrary @i{format string}. This @i{format string} is applied to the elements of the list corresponding to the @t{~<...~:>} directive as a whole. Elements are extracted from this list using @b{pprint-pop}, thereby providing automatic support for malformed lists, and the detection of circularity, sharing, and length abbreviation. Within the body segment, @t{~@t{^}} acts like @b{pprint-exit-if-list-exhausted}. @t{~<...~:>} supports a feature not supported by @b{pprint-logical-block}. If @t{~:@@>} is used to terminate the directive (@i{i.e.}, @t{~<...~:@@>}), then a fill-style conditional newline is automatically inserted after each group of blanks immediately contained in the body (except for blanks after a ~<@i{Newline}> directive). This makes it easy to achieve the equivalent of paragraph filling. If the @i{at-sign} modifier is used with @t{~<...~:>}, the entire remaining argument list is passed to the directive as its argument. All of the remaining arguments are always consumed by @t{~@@<...~:>}, even if they are not all used by the @i{format string} nested in the directive. Other than the difference in its argument, @t{~@@<...~:>} is exactly the same as @t{~<...~:>} except that circularity detection is not applied if @t{~@@<...~:>} is encountered at top level in a @i{format string}. This ensures that circularity detection is applied only to data lists, not to @i{format argument} @i{lists}. @t{" . #@i{n}#"} is printed if circularity or sharing has to be indicated for its argument as a whole. To a considerable extent, the basic form of the directive @t{~<...~>} is incompatible with the dynamic control of the arrangement of output by @t{~W}, @t{~_}, @t{~<...~:>}, @t{~I}, and @t{~:T}. As a result, an error is signaled if any of these directives is nested within @t{~<...~>}. Beyond this, an error is also signaled if the @t{~<...~:;...~>} form of @t{~<...~>} is used in the same @i{format string} with @t{~W}, @t{~_}, @t{~<...~:>}, @t{~I}, or @t{~:T}. See also @ref{Tilde Less-Than-Sign-> Justification}. @node Tilde I-> Indent, Tilde Slash-> Call Function, Tilde Less-Than-Sign-> Logical Block, FORMAT Pretty Printer Operations @subsubsection Tilde I: Indent @t{~@i{n}I} is the same as @t{(pprint-indent :block n)}. @t{~@i{n}:I} is the same as @t{(pprint-indent :current n)}. In both cases, @i{n} defaults to zero, if it is omitted. @node Tilde Slash-> Call Function, , Tilde I-> Indent, FORMAT Pretty Printer Operations @subsubsection Tilde Slash: Call Function @t{~/@i{name}/} User defined functions can be called from within a format string by using the directive @t{~/@i{name}/}. The @i{colon} modifier, the @i{at-sign} modifier, and arbitrarily many parameters can be specified with the @t{~/@i{name}/} directive. @i{name} can be any arbitrary string that does not contain a "/". All of the characters in @i{name} are treated as if they were upper case. If @i{name} contains a single @i{colon} (@t{:}) or double @i{colon} (@t{::}), then everything up to but not including the first @t{":"} or @t{"::"} is taken to be a @i{string} that names a @i{package}. Everything after the first @t{":"} or @t{"::"} (if any) is taken to be a @i{string} that names a @t{symbol}. The function corresponding to a @t{~/name/} directive is obtained by looking up the @i{symbol} that has the indicated name in the indicated @i{package}. If @i{name} does not contain a @t{":"} or @t{"::"}, then the whole @i{name} string is looked up in the @t{COMMON-LISP-USER} @i{package}. When a @t{~/name/} directive is encountered, the indicated function is called with four or more arguments. The first four arguments are: the output stream, the @i{format argument} corresponding to the directive, a @i{generalized boolean} that is @i{true} if the @i{colon} modifier was used, and a @i{generalized boolean} that is @i{true} if the @i{at-sign} modifier was used. The remaining arguments consist of any parameters specified with the directive. The function should print the argument appropriately. Any values returned by the function are ignored. The three @i{functions} @b{pprint-linear}, @b{pprint-fill}, and @b{pprint-tabular} are specifically designed so that they can be called by @t{~/.../} (@i{i.e.}, @t{~/pprint-linear/}, @t{~/pprint-fill/}, and @t{~/pprint-tabular/}). In particular they take @i{colon} and @i{at-sign} arguments. @node FORMAT Layout Control, FORMAT Control-Flow Operations, FORMAT Pretty Printer Operations, Formatted Output @subsection FORMAT Layout Control @menu * Tilde T-> Tabulate:: * Tilde Less-Than-Sign-> Justification:: * Tilde Greater-Than-Sign-> End of Justification:: @end menu @node Tilde T-> Tabulate, Tilde Less-Than-Sign-> Justification, FORMAT Layout Control, FORMAT Layout Control @subsubsection Tilde T: Tabulate This spaces over to a given column. @t{~@i{colnum},@i{colinc}T} will output sufficient spaces to move the cursor to column @i{colnum}. If the cursor is already at or beyond column @i{colnum}, it will output spaces to move it to column @i{colnum}+@i{k}*@i{colinc} for the smallest positive integer @i{k} possible, unless @i{colinc} is zero, in which case no spaces are output if the cursor is already at or beyond column @i{colnum}. @i{colnum} and @i{colinc} default to @t{1}. If for some reason the current absolute column position cannot be determined by direct inquiry, @b{format} may be able to deduce the current column position by noting that certain directives (such as @t{~%}, or @t{~&}, or @t{~A} with the argument being a string containing a newline) cause the column position to be reset to zero, and counting the number of characters emitted since that point. If that fails, @b{format} may attempt a similar deduction on the riskier assumption that the destination was at column zero when @b{format} was invoked. If even this heuristic fails or is implementationally inconvenient, at worst the @t{~T} operation will simply output two spaces. @t{~@@T} performs relative tabulation. @t{~@i{colrel},@i{colinc}@@T} outputs @i{colrel} spaces and then outputs the smallest non-negative number of additional spaces necessary to move the cursor to a column that is a multiple of @i{colinc}. For example, the directive @t{~3,8@@T} outputs three spaces and then moves the cursor to a ``standard multiple-of-eight tab stop'' if not at one already. If the current output column cannot be determined, however, then @i{colinc} is ignored, and exactly @i{colrel} spaces are output. If the @i{colon} modifier is used with the @t{~T} directive, the tabbing computation is done relative to the horizontal position where the section immediately containing the directive begins, rather than with respect to a horizontal position of zero. The numerical parameters are both interpreted as being in units of @i{ems} and both default to @t{1}. @t{~@i{n},@i{m}:T} is the same as @t{(pprint-tab :section @i{n} @i{m})}. @t{~@i{n},@i{m}:@@T} is the same as @t{(pprint-tab :section-relative @i{n} @i{m})}. @node Tilde Less-Than-Sign-> Justification, Tilde Greater-Than-Sign-> End of Justification, Tilde T-> Tabulate, FORMAT Layout Control @subsubsection Tilde Less-Than-Sign: Justification @t{~@i{mincol},@i{colinc},@i{minpad},@i{padchar}<@i{str}~>} This justifies the text produced by processing @i{str} within a field at least @i{mincol} columns wide. @i{str} may be divided up into segments with @t{~;}, in which case the spacing is evenly divided between the text segments. With no modifiers, the leftmost text segment is left justified in the field, and the rightmost text segment is right justified. If there is only one text element, as a special case, it is right justified. The @t{:} modifier causes spacing to be introduced before the first text segment; the @t{@@} modifier causes spacing to be added after the last. The @i{minpad} parameter (default @t{0}) is the minimum number of padding characters to be output between each segment. The padding character is supplied by @i{padchar}, which defaults to the space character. If the total width needed to satisfy these constraints is greater than @i{mincol}, then the width used is @i{mincol}+@i{k}*@i{colinc} for the smallest possible non-negative integer value @i{k}. @i{colinc} defaults to @t{1}, and @i{mincol} defaults to @t{0}. Note that @i{str} may include @b{format} directives. All the clauses in @i{str} are processed in order; it is the resulting pieces of text that are justified. The @t{~@t{^} } directive may be used to terminate processing of the clauses prematurely, in which case only the completely processed clauses are justified. If the first clause of a @t{~<} is terminated with @t{~:;} instead of @t{~;}, then it is used in a special way. All of the clauses are processed (subject to @t{~@t{^} }, of course), but the first one is not used in performing the spacing and padding. When the padded result has been determined, then if it will fit on the current line of output, it is output, and the text for the first clause is discarded. If, however, the padded text will not fit on the current line, then the text segment for the first clause is output before the padded text. The first clause ought to contain a newline (such as a @t{~%} directive). The first clause is always processed, and so any arguments it refers to will be used; the decision is whether to use the resulting segment of text, not whether to process the first clause. If the @t{~:;} has a prefix parameter @i{n}, then the padded text must fit on the current line with @i{n} character positions to spare to avoid outputting the first clause's text. For example, the control string @example "~ @end example can be used to print a list of items separated by commas without breaking items over line boundaries, beginning each line with @t{;; }. The prefix parameter @t{1} in @t{~1:;} accounts for the width of the comma that will follow the justified item if it is not the last element in the list, or the period if it is. If @t{~:;} has a second prefix parameter, then it is used as the width of the line, thus overriding the natural line width of the output stream. To make the preceding example use a line width of 50, one would write @example "~ @end example If the second argument is not supplied, then @b{format} uses the line width of the @i{destination} output stream. If this cannot be determined (for example, when producing a @i{string} result), then @b{format} uses @t{72} as the line length. See also @ref{Tilde Less-Than-Sign-> Logical Block}. @node Tilde Greater-Than-Sign-> End of Justification, , Tilde Less-Than-Sign-> Justification, FORMAT Layout Control @subsubsection Tilde Greater-Than-Sign: End of Justification @t{~>} terminates a @t{~<}. The consequences of using it elsewhere are undefined. @node FORMAT Control-Flow Operations, FORMAT Miscellaneous Operations, FORMAT Layout Control, Formatted Output @subsection FORMAT Control-Flow Operations @menu * Tilde Asterisk-> Go-To:: * Tilde Left-Bracket-> Conditional Expression:: * Tilde Right-Bracket-> End of Conditional Expression:: * Tilde Left-Brace-> Iteration:: * Tilde Right-Brace-> End of Iteration:: * Tilde Question-Mark-> Recursive Processing:: @end menu @node Tilde Asterisk-> Go-To, Tilde Left-Bracket-> Conditional Expression, FORMAT Control-Flow Operations, FORMAT Control-Flow Operations @subsubsection Tilde Asterisk: Go-To The next @i{arg} is ignored. @t{~@i{n}*} ignores the next @i{n} arguments. @t{~:*} backs up in the list of arguments so that the argument last processed will be processed again. @t{~@i{n}:*} backs up @i{n} arguments. When within a @t{~@{} construct (see below), the ignoring (in either direction) is relative to the list of arguments being processed by the iteration. @t{~@i{n}@@*} goes to the @i{n}th @i{arg}, where 0 means the first one; @i{n} defaults to 0, so @t{~@@*} goes back to the first @i{arg}. Directives after a @t{~@i{n}@@*} will take arguments in sequence beginning with the one gone to. When within a @t{~@{} construct, the ``goto'' is relative to the list of arguments being processed by the iteration. @node Tilde Left-Bracket-> Conditional Expression, Tilde Right-Bracket-> End of Conditional Expression, Tilde Asterisk-> Go-To, FORMAT Control-Flow Operations @subsubsection Tilde Left-Bracket: Conditional Expression @t{~[@i{str0}~;@i{str1}~;@i{...}~;@i{strn}~]} This is a set of control strings, called @i{clauses}, one of which is chosen and used. The clauses are separated by @t{~;} and the construct is terminated by @t{~]}. For example, @t{"~[Siamese~;Manx~;Persian~] Cat"} The @i{arg}th clause is selected, where the first clause is number 0. If a prefix parameter is given (as @t{~@i{n}[}), then the parameter is used instead of an argument. If @i{arg} is out of range then no clause is selected and no error is signaled. After the selected alternative has been processed, the control string continues after the @t{~]}. @t{~[@i{str0}~;@i{str1}~;@i{...}~;@i{strn}~:;@i{default}~]} has a default case. If the @i{last} @t{~;} used to separate clauses is @t{~:;} instead, then the last clause is an else clause that is performed if no other clause is selected. For example: @t{"~[Siamese~;Manx~;Persian~:;Alley~] Cat"} @t{~:[@i{alternative}~;@i{consequent}~]} selects the @i{alternative} control string if @i{arg} is @i{false}, and selects the @i{consequent} control string otherwise. @t{~@@[@i{consequent}~]} tests the argument. If it is @i{true}, then the argument is not used up by the @t{~[} command but remains as the next one to be processed, and the one clause @i{consequent} is processed. If the @i{arg} is @i{false}, then the argument is used up, and the clause is not processed. The clause therefore should normally use exactly one argument, and may expect it to be @i{non-nil}. For example: @example (setq *print-level* nil *print-length* 5) (format nil "~@@[ print level = ~D~]~@@[ print length = ~D~]" *print-level* *print-length*) @result{} " print length = 5" @end example Note also that @example (format @i{stream} "...~@@[@i{str}~]..." ...) @equiv{} (format @i{stream} "...~:[~;~:*@i{str}~]..." ...) @end example The combination of @t{~[} and @t{#} is useful, for example, for dealing with English conventions for printing lists: @example (setq foo "Items:~#[ none~; ~S~; ~S and ~S~ ~:;~@@@{~#[~; and~] ~S~@t{^} ,~@}~].") (format nil foo) @result{} "Items: none." (format nil foo 'foo) @result{} "Items: FOO." (format nil foo 'foo 'bar) @result{} "Items: FOO and BAR." (format nil foo 'foo 'bar 'baz) @result{} "Items: FOO, BAR, and BAZ." (format nil foo 'foo 'bar 'baz 'quux) @result{} "Items: FOO, BAR, BAZ, and QUUX." @end example @node Tilde Right-Bracket-> End of Conditional Expression, Tilde Left-Brace-> Iteration, Tilde Left-Bracket-> Conditional Expression, FORMAT Control-Flow Operations @subsubsection Tilde Right-Bracket: End of Conditional Expression @t{~]} terminates a @t{~[}. The consequences of using it elsewhere are undefined. @node Tilde Left-Brace-> Iteration, Tilde Right-Brace-> End of Iteration, Tilde Right-Bracket-> End of Conditional Expression, FORMAT Control-Flow Operations @subsubsection Tilde Left-Brace: Iteration @t{~@{@i{str}~@}} This is an iteration construct. The argument should be a @i{list}, which is used as a set of arguments as if for a recursive call to @b{format}. The @i{string} @i{str} is used repeatedly as the control string. Each iteration can absorb as many elements of the @i{list} as it likes as arguments; if @i{str} uses up two arguments by itself, then two elements of the @i{list} will get used up each time around the loop. If before any iteration step the @i{list} is empty, then the iteration is terminated. Also, if a prefix parameter @i{n} is given, then there will be at most @i{n} repetitions of processing of @i{str}. Finally, the @t{~@t{^} } directive can be used to terminate the iteration prematurely. For example: @example (format nil "The winners are:~@{ ~S~@}." '(fred harry jill)) @result{} "The winners are: FRED HARRY JILL." (format nil "Pairs:~@{ <~S,~S>~@}." '(a 1 b 2 c 3)) @result{} "Pairs: ." @end example @t{~:@{ @i{str}~@} } is similar, but the argument should be a @i{list} of sublists. At each repetition step, one sublist is used as the set of arguments for processing @i{str}; on the next repetition, a new sublist is used, whether or not all of the last sublist had been processed. For example: @example (format nil "Pairs:~:@{ <~S,~S>~@} ." '((a 1) (b 2) (c 3))) @result{} "Pairs: ." @end example @t{~@@@{ @i{str}~@} } is similar to @t{~@{ @i{str}~@} }, but instead of using one argument that is a list, all the remaining arguments are used as the list of arguments for the iteration. Example: @example (format nil "Pairs:~@@@{ <~S,~S>~@} ." 'a 1 'b 2 'c 3) @result{} "Pairs: ." @end example If the iteration is terminated before all the remaining arguments are consumed, then any arguments not processed by the iteration remain to be processed by any directives following the iteration construct. @t{~:@@@{ @i{str}~@} } combines the features of @t{~:@{ @i{str}~@} } and @t{~@@@{ @i{str}~@} }. All the remaining arguments are used, and each one must be a @i{list}. On each iteration, the next argument is used as a @i{list} of arguments to @i{str}. Example: @example (format nil "Pairs:~:@@@{ <~S,~S>~@} ." '(a 1) '(b 2) '(c 3)) @result{} "Pairs: ." @end example Terminating the repetition construct with @t{~:@} } instead of @t{~@} } forces @i{str} to be processed at least once, even if the initial list of arguments is null. However, this will not override an explicit prefix parameter of zero. If @i{str} is empty, then an argument is used as @i{str}. It must be a @i{format control} and precede any arguments processed by the iteration. As an example, the following are equivalent: @example (apply #'format stream string arguments) @equiv{} (format stream "~1@{~:@}" string arguments) @end example This will use @t{string} as a formatting string. The @t{~1@{ } says it will be processed at most once, and the @t{~:@} } says it will be processed at least once. Therefore it is processed exactly once, using @t{arguments} as the arguments. This case may be handled more clearly by the @t{~?} directive, but this general feature of @t{~@{ } is more powerful than @t{~?}. @node Tilde Right-Brace-> End of Iteration, Tilde Question-Mark-> Recursive Processing, Tilde Left-Brace-> Iteration, FORMAT Control-Flow Operations @subsubsection Tilde Right-Brace: End of Iteration @t{~@}} terminates a @t{~@{}. The consequences of using it elsewhere are undefined. @node Tilde Question-Mark-> Recursive Processing, , Tilde Right-Brace-> End of Iteration, FORMAT Control-Flow Operations @subsubsection Tilde Question-Mark: Recursive Processing The next @i{arg} must be a @i{format control}, and the one after it a @i{list}; both are consumed by the @t{~?} directive. The two are processed as a @i{control-string}, with the elements of the @i{list} as the arguments. Once the recursive processing has been finished, the processing of the control string containing the @t{~?} directive is resumed. Example: @example (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) @result{} " 7" (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) @result{} " 7" @end example Note that in the second example three arguments are supplied to the @i{format string} @t{"<~A ~D>"}, but only two are processed and the third is therefore ignored. With the @t{@@} modifier, only one @i{arg} is directly consumed. The @i{arg} must be a @i{string}; it is processed as part of the control string as if it had appeared in place of the @t{~@@?} construct, and any directives in the recursively processed control string may consume arguments of the control string containing the @t{~@@?} directive. Example: @example (format nil "~@@? ~D" "<~A ~D>" "Foo" 5 7) @result{} " 7" (format nil "~@@? ~D" "<~A ~D>" "Foo" 5 14 7) @result{} " 14" @end example @node FORMAT Miscellaneous Operations, FORMAT Miscellaneous Pseudo-Operations, FORMAT Control-Flow Operations, Formatted Output @subsection FORMAT Miscellaneous Operations @menu * Tilde Left-Paren-> Case Conversion:: * Tilde Right-Paren-> End of Case Conversion:: * Tilde P-> Plural:: @end menu @node Tilde Left-Paren-> Case Conversion, Tilde Right-Paren-> End of Case Conversion, FORMAT Miscellaneous Operations, FORMAT Miscellaneous Operations @subsubsection Tilde Left-Paren: Case Conversion @t{~(@i{str}~)} The contained control string @i{str} is processed, and what it produces is subject to case conversion. With no flags, every @i{uppercase} @i{character} is converted to the corresponding @i{lowercase} @i{character}. @t{~:(} capitalizes all words, as if by @b{string-capitalize}. @t{~@@(} capitalizes just the first word and forces the rest to lower case. @t{~:@@(} converts every lowercase character to the corresponding uppercase character. In this example @t{~@@(} is used to cause the first word produced by @t{~@@R} to be capitalized: @example (format nil "~@@R ~(~@@R~)" 14 14) @result{} "XIV xiv" (defun f (n) (format nil "~@@(~R~) error~:P detected." n)) @result{} F (f 0) @result{} "Zero errors detected." (f 1) @result{} "One error detected." (f 23) @result{} "Twenty-three errors detected." @end example When case conversions appear nested, the outer conversion dominates, as illustrated in the following example: @example (format nil "~@@(how is ~:(BOB SMITH~)?~)") @result{} "How is bob smith?" @i{NOT}@result{} "How is Bob Smith?" @end example @node Tilde Right-Paren-> End of Case Conversion, Tilde P-> Plural, Tilde Left-Paren-> Case Conversion, FORMAT Miscellaneous Operations @subsubsection Tilde Right-Paren: End of Case Conversion @t{~)} terminates a @t{~(}. The consequences of using it elsewhere are undefined. @node Tilde P-> Plural, , Tilde Right-Paren-> End of Case Conversion, FORMAT Miscellaneous Operations @subsubsection Tilde P: Plural If @i{arg} is not @b{eql} to the integer @t{1}, a lowercase @t{s} is printed; if @i{arg} is @b{eql} to @t{1}, nothing is printed. If @i{arg} is a floating-point @t{1.0}, the @t{s} is printed. @t{~:P} does the same thing, after doing a @t{~:*} to back up one argument; that is, it prints a lowercase @t{s} if the previous argument was not @t{1}. @t{~@@P} prints @t{y} if the argument is @t{1}, or @t{ies} if it is not. @t{~:@@P} does the same thing, but backs up first. @example (format nil "~D tr~:@@P/~D win~:P" 7 1) @result{} "7 tries/1 win" (format nil "~D tr~:@@P/~D win~:P" 1 0) @result{} "1 try/0 wins" (format nil "~D tr~:@@P/~D win~:P" 1 3) @result{} "1 try/3 wins" @end example @node FORMAT Miscellaneous Pseudo-Operations, Additional Information about FORMAT Operations, FORMAT Miscellaneous Operations, Formatted Output @subsection FORMAT Miscellaneous Pseudo-Operations @menu * Tilde Semicolon-> Clause Separator:: * Tilde Circumflex-> Escape Upward:: * Tilde Newline-> Ignored Newline:: @end menu @node Tilde Semicolon-> Clause Separator, Tilde Circumflex-> Escape Upward, FORMAT Miscellaneous Pseudo-Operations, FORMAT Miscellaneous Pseudo-Operations @subsubsection Tilde Semicolon: Clause Separator This separates clauses in @t{~[} and @t{~<} constructs. The consequences of using it elsewhere are undefined. @node Tilde Circumflex-> Escape Upward, Tilde Newline-> Ignored Newline, Tilde Semicolon-> Clause Separator, FORMAT Miscellaneous Pseudo-Operations @subsubsection Tilde Circumflex: Escape Upward @t{~@t{^} } This is an escape construct. If there are no more arguments remaining to be processed, then the immediately enclosing @t{~@{ } or @t{~<} construct is terminated. If there is no such enclosing construct, then the entire formatting operation is terminated. In the @t{~<} case, the formatting is performed, but no more segments are processed before doing the justification. @t{~@t{^} } may appear anywhere in a @t{~@{ } construct. @example (setq donestr "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P.") @result{} "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P." (format nil donestr) @result{} "Done." (format nil donestr 3) @result{} "Done. 3 warnings." (format nil donestr 1 5) @result{} "Done. 1 warning. 5 errors." @end example If a prefix parameter is given, then termination occurs if the parameter is zero. (Hence @t{~@t{^}} is equivalent to @t{~#@t{^}}.) If two parameters are given, termination occurs if they are equal. [Reviewer Note by Barmar: Which equality predicate?] If three parameters are given, termination occurs if the first is less than or equal to the second and the second is less than or equal to the third. Of course, this is useless if all the prefix parameters are constants; at least one of them should be a @t{#} or a @t{V} parameter. If @t{~@t{^}} is used within a @t{~:@{ } construct, then it terminates the current iteration step because in the standard case it tests for remaining arguments of the current step only; the next iteration step commences immediately. @t{~:@t{^}} is used to terminate the iteration process. @t{~:@t{^}} may be used only if the command it would terminate is @t{~:@{ } or @t{~:@@@{ }. The entire iteration process is terminated if and only if the sublist that is supplying the arguments for the current iteration step is the last sublist in the case of @t{~:@{ }, or the last @b{format} argument in the case of @t{~:@@@{ }. @t{~:@t{^}} is not equivalent to @t{~#:@t{^}}; the latter terminates the entire iteration if and only if no arguments remain for the current iteration step. For example: @example (format nil "~:@{ ~@@?~:@t{^} ...~@} " '(("a") ("b"))) @result{} "a...b" @end example If @t{~@t{^}} appears within a control string being processed under the control of a @t{~?} directive, but not within any @t{~@{ } or @t{~<} construct within that string, then the string being processed will be terminated, thereby ending processing of the @t{~?} directive. Processing then continues within the string containing the @t{~?} directive at the point following that directive. If @t{~@t{^}} appears within a @t{~[} or @t{~(} construct, then all the commands up to the @t{~@t{^}} are properly selected or case-converted, the @t{~[} or @t{~(} processing is terminated, and the outward search continues for a @t{~@{ } or @t{~<} construct to be terminated. For example: @example (setq tellstr "~@@(~@@[~R~]~@t{^} ~A!~)") @result{} "~@@(~@@[~R~]~@t{^} ~A!~)" (format nil tellstr 23) @result{} "Twenty-three!" (format nil tellstr nil "losers") @result{} " Losers!" (format nil tellstr 23 "losers") @result{} "Twenty-three losers!" @end example Following are examples of the use of @t{~@t{^}} within a @t{~<} construct. @example (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo) @result{} " FOO" (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar) @result{} "FOO BAR" (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar 'baz) @result{} "FOO BAR BAZ" @end example @node Tilde Newline-> Ignored Newline, , Tilde Circumflex-> Escape Upward, FORMAT Miscellaneous Pseudo-Operations @subsubsection Tilde Newline: Ignored Newline @i{Tilde} immediately followed by a @i{newline} ignores the @i{newline} and any following non-newline @i{whitespace}_1 characters. With a @t{:}, the @i{newline} is ignored, but any following @i{whitespace}_1 is left in place. With an @t{@@}, the @i{newline} is left in place, but any following @i{whitespace}_1 is ignored. For example: @example (defun type-clash-error (fn nargs argnum right-type wrong-type) (format *error-output* "~&~S requires its ~:[~:R~;~*~]~ argument to be of type ~S,~ with an argument of type ~S.~ fn (eql nargs 1) argnum right-type wrong-type)) (type-clash-error 'aref nil 2 'integer 'vector) prints: AREF requires its second argument to be of type INTEGER, but it was called with an argument of type VECTOR. NIL (type-clash-error 'car 1 1 'list 'short-float) prints: CAR requires its argument to be of type LIST, but it was called with an argument of type SHORT-FLOAT. NIL @end example Note that in this example newlines appear in the output only as specified by the @t{~&} and @t{~%} directives; the actual newline characters in the control string are suppressed because each is preceded by a tilde. @node Additional Information about FORMAT Operations, Examples of FORMAT, FORMAT Miscellaneous Pseudo-Operations, Formatted Output @subsection Additional Information about FORMAT Operations @menu * Nesting of FORMAT Operations:: * Missing and Additional FORMAT Arguments:: * Additional FORMAT Parameters:: * Undefined FORMAT Modifier Combinations:: @end menu @node Nesting of FORMAT Operations, Missing and Additional FORMAT Arguments, Additional Information about FORMAT Operations, Additional Information about FORMAT Operations @subsubsection Nesting of FORMAT Operations The case-conversion, conditional, iteration, and justification constructs can contain other formatting constructs by bracketing them. These constructs must nest properly with respect to each other. For example, it is not legitimate to put the start of a case-conversion construct in each arm of a conditional and the end of the case-conversion construct outside the conditional: @example (format nil "~:[abc~:@@(def~;ghi~ :@@(jkl~]mno~)" x) ;Invalid! @end example This notation is invalid because the @t{~[...~;...~]} and @t{~(...~)} constructs are not properly nested. The processing indirection caused by the @t{~?} directive is also a kind of nesting for the purposes of this rule of proper nesting. It is not permitted to start a bracketing construct within a string processed under control of a @t{~?} directive and end the construct at some point after the @t{~?} construct in the string containing that construct, or vice versa. For example, this situation is invalid: @example (format nil "~@@?ghi~)" "abc~@@(def") ;Invalid! @end example This notation is invalid because the @t{~?} and @t{~(...~)} constructs are not properly nested. @node Missing and Additional FORMAT Arguments, Additional FORMAT Parameters, Nesting of FORMAT Operations, Additional Information about FORMAT Operations @subsubsection Missing and Additional FORMAT Arguments The consequences are undefined if no @i{arg} remains for a directive requiring an argument. However, it is permissible for one or more @i{args} to remain unprocessed by a directive; such @i{args} are ignored. @node Additional FORMAT Parameters, Undefined FORMAT Modifier Combinations, Missing and Additional FORMAT Arguments, Additional Information about FORMAT Operations @subsubsection Additional FORMAT Parameters The consequences are undefined if a format directive is given more parameters than it is described here as accepting. @node Undefined FORMAT Modifier Combinations, , Additional FORMAT Parameters, Additional Information about FORMAT Operations @subsubsection Undefined FORMAT Modifier Combinations The consequences are undefined if @i{colon} or @i{at-sign} modifiers are given to a directive in a combination not specifically described here as being meaningful. @node Examples of FORMAT, Notes about FORMAT, Additional Information about FORMAT Operations, Formatted Output @subsection Examples of FORMAT @example (format nil "foo") @result{} "foo" (setq x 5) @result{} 5 (format nil "The answer is ~D." x) @result{} "The answer is 5." (format nil "The answer is ~3D." x) @result{} "The answer is 5." (format nil "The answer is ~3,'0D." x) @result{} "The answer is 005." (format nil "The answer is ~:D." (expt 47 x)) @result{} "The answer is 229,345,007." (setq y "elephant") @result{} "elephant" (format nil "Look at the ~A!" y) @result{} "Look at the elephant!" (setq n 3) @result{} 3 (format nil "~D item~:P found." n) @result{} "3 items found." (format nil "~R dog~:[s are~; is~] here." n (= n 1)) @result{} "three dogs are here." (format nil "~R dog~:*~[s are~; is~:;s are~] here." n) @result{} "three dogs are here." (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@@P." n) @result{} "Here are three puppies." @end example @example (defun foo (x) (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x)) @result{} FOO (foo 3.14159) @result{} " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (foo -3.14159) @result{} " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (foo 100.0) @result{} "100.00|******|100.00| 100.0|100.00|100.0" (foo 1234.0) @result{} "1234.00|******|??????|1234.0|1234.00|1234.0" (foo 0.006) @result{} " 0.01| 0.06| 0.01| 0.006|0.01|0.006" @end example @example (defun foo (x) (format nil "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~ ~9,3,2,-2,' x x x x)) (foo 3.14159) @result{} " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" (foo -3.14159) @result{} " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" (foo 1100.0) @result{} " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" (foo 1100.0L0) @result{} " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3" (foo 1.1E13) @result{} "*********| 11.00$+12|+.001E+16| 1.10E+13" (foo 1.1L120) @result{} "*********|??????????| (foo 1.1L1200) @result{} "*********|??????????| @end example As an example of the effects of varying the scale factor, the code @example (dotimes (k 13) (format t "~ (- k 5) (- k 5) 3.14159)) @end example produces the following output: @example Scale factor -5: | 0.000003E+06| Scale factor -4: | 0.000031E+05| Scale factor -3: | 0.000314E+04| Scale factor -2: | 0.003142E+03| Scale factor -1: | 0.031416E+02| Scale factor 0: | 0.314159E+01| Scale factor 1: | 3.141590E+00| Scale factor 2: | 31.41590E-01| Scale factor 3: | 314.1590E-02| Scale factor 4: | 3141.590E-03| Scale factor 5: | 31415.90E-04| Scale factor 6: | 314159.0E-05| Scale factor 7: | 3141590.E-06| @end example @example (defun foo (x) (format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,' x x x x)) (foo 0.0314159) @result{} " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" (foo 0.314159) @result{} " 0.31 |0.314 |0.314 | 0.31 " (foo 3.14159) @result{} " 3.1 | 3.14 | 3.14 | 3.1 " (foo 31.4159) @result{} " 31. | 31.4 | 31.4 | 31. " (foo 314.159) @result{} " 3.14E+2| 314. | 314. | 3.14E+2" (foo 3141.59) @result{} " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" (foo 3141.59L0) @result{} " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3" (foo 3.14E12) @result{} "*********|314.0$+10|0.314E+13| 3.14E+12" (foo 3.14L120) @result{} "*********|?????????| (foo 3.14L1200) @result{} "*********|?????????| @end example @example (format nil "~10") @result{} "foo bar" (format nil "~10:") @result{} " foo bar" (format nil "~10") @result{} " foobar" (format nil "~10:") @result{} " foobar" (format nil "~10:@@") @result{} " foo bar " (format nil "~10@@") @result{} "foobar " (format nil "~10:@@") @result{} " foobar " @end example @example (FORMAT NIL "Written to ~A." #P"foo.bin") @result{} "Written to foo.bin." @end example @node Notes about FORMAT, , Examples of FORMAT, Formatted Output @subsection Notes about FORMAT Formatted output is performed not only by @b{format}, but by certain other functions that accept a @i{format control} the way @b{format} does. For example, error-signaling functions such as @b{cerror} accept @i{format controls}. Note that the meaning of @b{nil} and @b{t} as destinations to @b{format} are different than those of @b{nil} and @b{t} as @i{stream designators}. The @t{~@t{^}} should appear only at the beginning of a @t{~<} clause, because it aborts the entire clause in which it appears (as well as all following clauses). @c end of including concept-format @node Printer Dictionary, , Formatted Output, Printer @section Printer Dictionary @c including dict-printer @menu * copy-pprint-dispatch:: * formatter:: * pprint-dispatch:: * pprint-exit-if-list-exhausted:: * pprint-fill:: * pprint-indent:: * pprint-logical-block:: * pprint-newline:: * pprint-pop:: * pprint-tab:: * print-object:: * print-unreadable-object:: * set-pprint-dispatch:: * write:: * write-to-string:: * *print-array*:: * *print-base*:: * *print-case*:: * *print-circle*:: * *print-escape*:: * *print-gensym*:: * *print-level*:: * *print-lines*:: * *print-miser-width*:: * *print-pprint-dispatch*:: * *print-pretty*:: * *print-readably*:: * *print-right-margin*:: * print-not-readable:: * print-not-readable-object:: * format:: @end menu @node copy-pprint-dispatch, formatter, Printer Dictionary, Printer Dictionary @subsection copy-pprint-dispatch [Function] @code{copy-pprint-dispatch} @i{@r{&optional} table} @result{} @i{new-table} @subsubheading Arguments and Values:: @i{table}---a @i{pprint dispatch table}, or @b{nil}. @i{new-table}---a @i{fresh} @i{pprint dispatch table}. @subsubheading Description:: Creates and returns a copy of the specified @i{table}, or of the @i{value} of @b{*print-pprint-dispatch*} if no @i{table} is specified, or of the initial @i{value} of @b{*print-pprint-dispatch*} if @b{nil} is specified. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{table} is not a @i{pprint dispatch table}. @node formatter, pprint-dispatch, copy-pprint-dispatch, Printer Dictionary @subsection formatter [Macro] @code{formatter} @i{control-string} @result{} @i{function} @subsubheading Arguments and Values:: @i{control-string}---a @i{format string}; not evaluated. @i{function}---a @i{function}. @subsubheading Description:: Returns a @i{function} which has behavior equivalent to: @example #'(lambda (*standard-output* &rest arguments) (apply #'format t @i{control-string} arguments) @i{arguments-tail}) @end example where @i{arguments-tail} is either the tail of @i{arguments} which has as its @i{car} the argument that would be processed next if there were more format directives in the @i{control-string}, or else @b{nil} if no more @i{arguments} follow the most recently processed argument. @subsubheading Examples:: @example (funcall (formatter "~&~A~A") *standard-output* 'a 'b 'c) @t{ |> } AB @result{} (C) (format t (formatter "~&~A~A") 'a 'b 'c) @t{ |> } AB @result{} NIL @end example @subsubheading Exceptional Situations:: Might signal an error (at macro expansion time or at run time) if the argument is not a valid @i{format string}. @subsubheading See Also:: @ref{format} @node pprint-dispatch, pprint-exit-if-list-exhausted, formatter, Printer Dictionary @subsection pprint-dispatch [Function] @code{pprint-dispatch} @i{object @r{&optional} table} @result{} @i{function, found-p} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{table}---a @i{pprint dispatch table}, or @b{nil}. The default is the @i{value} of @b{*print-pprint-dispatch*}. @i{function}---a @i{function designator}. @i{found-p}---a @i{generalized boolean}. @subsubheading Description:: Retrieves the highest priority function in @i{table} that is associated with a @i{type specifier} that matches @i{object}. The function is chosen by finding all of the @i{type specifiers} in @i{table} that match the @i{object} and selecting the highest priority function associated with any of these @i{type specifiers}. If there is more than one highest priority function, an arbitrary choice is made. If no @i{type specifiers} match the @i{object}, a function is returned that prints @i{object} using @b{print-object}. The @i{secondary value}, @i{found-p}, is @i{true} if a matching @i{type specifier} was found in @i{table}, or @i{false} otherwise. If @i{table} is @b{nil}, retrieval is done in the @i{initial pprint dispatch table}. @subsubheading Affected By:: The state of the @i{table}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{table} is neither a @i{pprint-dispatch-table} nor @b{nil}. @subsubheading Notes:: @example (let ((*print-pretty* t)) (write object :stream s)) @equiv{} (funcall (pprint-dispatch object) s object) @end example @node pprint-exit-if-list-exhausted, pprint-fill, pprint-dispatch, Printer Dictionary @subsection pprint-exit-if-list-exhausted [Local Macro] @subsubheading Syntax:: @code{pprint-exit-if-list-exhausted} @i{<@i{no @i{arguments}}>} @result{} @i{@b{nil}} @subsubheading Description:: Tests whether or not the @i{list} passed to the @i{lexically current logical block} has been exhausted; see @ref{Dynamic Control of the Arrangement of Output}. If this @i{list} has been reduced to @b{nil}, @b{pprint-exit-if-list-exhausted} terminates the execution of the @i{lexically current logical block} except for the printing of the suffix. Otherwise @b{pprint-exit-if-list-exhausted} returns @b{nil}. Whether or not @b{pprint-exit-if-list-exhausted} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{pprint-exit-if-list-exhausted} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{pprint-exit-if-list-exhausted} outside of @b{pprint-logical-block} are undefined. @subsubheading Exceptional Situations:: An error is signaled (at macro expansion time or at run time) if @b{pprint-exit-if-list-exhausted} is used anywhere other than lexically within a call on @b{pprint-logical-block}. Also, the consequences of executing @b{pprint-if-list-exhausted} outside of the dynamic extent of the @b{pprint-logical-block} which lexically contains it are undefined. @subsubheading See Also:: @ref{pprint-logical-block} , @ref{pprint-pop} . @node pprint-fill, pprint-indent, pprint-exit-if-list-exhausted, Printer Dictionary @subsection pprint-fill, pprint-linear, pprint-tabular [Function] @code{pprint-fill} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} @code{pprint-linear} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} @code{pprint-tabular} @i{stream object @r{&optional} colon-p at-sign-p tabsize} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{stream}---an @i{output} @i{stream designator}. @i{object}---an @i{object}. @i{colon-p}---a @i{generalized boolean}. The default is @i{true}. @i{at-sign-p}---a @i{generalized boolean}. The default is @i{implementation-dependent}. @i{tabsize}---a non-negative @i{integer}. The default is @t{16}. @subsubheading Description:: The functions @b{pprint-fill}, @b{pprint-linear}, and @b{pprint-tabular} specify particular ways of @i{pretty printing} a @i{list} to @i{stream}. Each function prints parentheses around the output if and only if @i{colon-p} is @i{true}. Each function ignores its @i{at-sign-p} argument. (Both arguments are included even though only one is needed so that these functions can be used via @t{~/.../} and as @b{set-pprint-dispatch} functions, as well as directly.) Each function handles abbreviation and the detection of circularity and sharing correctly, and uses @b{write} to print @i{object} when it is a @i{non-list}. If @i{object} is a @i{list} and if the @i{value} of @b{*print-pretty*} is @i{false}, each of these functions prints @i{object} using a minimum of @i{whitespace}, as described in @ref{Printing Lists and Conses}. Otherwise (if @i{object} is a @i{list} and if the @i{value} of @b{*print-pretty*} is @i{true}): @table @asis @item @t{*} The @i{function} @b{pprint-linear} prints a @i{list} either all on one line, or with each @i{element} on a separate line. @item @t{*} The @i{function} @b{pprint-fill} prints a @i{list} with as many @i{elements} as possible on each line. @item @t{*} The @i{function} @b{pprint-tabular} is the same as @b{pprint-fill} except that it prints the @i{elements} so that they line up in columns. The @i{tabsize} specifies the column spacing in @i{ems}, which is the total spacing from the leading edge of one column to the leading edge of the next. @end table @subsubheading Examples:: Evaluating the following with a line length of @t{25} produces the output shown. @example (progn (princ "Roads ") (pprint-tabular *standard-output* '(elm main maple center) nil nil 8)) Roads ELM MAIN MAPLE CENTER @end example @subsubheading Side Effects:: Performs output to the indicated @i{stream}. @subsubheading Affected By:: The cursor position on the indicated @i{stream}, if it can be determined. @subsubheading Notes:: The @i{function} @b{pprint-tabular} could be defined as follows: @example (defun pprint-tabular (s list &optional (colon-p t) at-sign-p (tabsize nil)) (declare (ignore at-sign-p)) (when (null tabsize) (setq tabsize 16)) (pprint-logical-block (s list :prefix (if colon-p "(" "") :suffix (if colon-p ")" "")) (pprint-exit-if-list-exhausted) (loop (write (pprint-pop) :stream s) (pprint-exit-if-list-exhausted) (write-char #\Space s) (pprint-tab :section-relative 0 tabsize s) (pprint-newline :fill s)))) @end example Note that it would have been inconvenient to specify this function using @b{format}, because of the need to pass its @i{tabsize} argument through to a @t{~:T} format directive nested within an iteration over a list. @node pprint-indent, pprint-logical-block, pprint-fill, Printer Dictionary @subsection pprint-indent [Function] @code{pprint-indent} @i{relative-to n @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{relative-to}---either @t{:block} or @t{:current}. @i{n}---a @i{real}. @i{stream}---an @i{output} @i{stream designator}. The default is @i{standard output}. @subsubheading Description:: @b{pprint-indent} specifies the indentation to use in a logical block on @i{stream}. If @i{stream} is a @i{pretty printing stream} and the @i{value} of @b{*print-pretty*} is @i{true}, @b{pprint-indent} sets the indentation in the innermost dynamically enclosing logical block; otherwise, @b{pprint-indent} has no effect. @i{N} specifies the indentation in @i{ems}. If @i{relative-to} is @t{:block}, the indentation is set to the horizontal position of the first character in the @i{dynamically current logical block} plus @i{n} @i{ems}. If @i{relative-to} is @t{:current}, the indentation is set to the current output position plus @i{n} @i{ems}. (For robustness in the face of variable-width fonts, it is advisable to use @t{:current} with an @i{n} of zero whenever possible.) @i{N} can be negative; however, the total indentation cannot be moved left of the beginning of the line or left of the end of the rightmost per-line prefix---an attempt to move beyond one of these limits is treated the same as an attempt to move to that limit. Changes in indentation caused by @i{pprint-indent} do not take effect until after the next line break. In addition, in miser mode all calls to @b{pprint-indent} are ignored, forcing the lines corresponding to the logical block to line up under the first character in the block. @subsubheading Exceptional Situations:: An error is signaled if @i{relative-to} is any @i{object} other than @t{:block} or @t{:current}. @subsubheading See Also:: @ref{Tilde I-> Indent} @node pprint-logical-block, pprint-newline, pprint-indent, Printer Dictionary @subsection pprint-logical-block [Macro] @code{pprint-logical-block} @i{@r{(}stream-symbol object @r{&key} prefix per-line-prefix suffix@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{stream-symbol}---a @i{stream variable designator}. @i{object}---an @i{object}; evaluated. @t{:prefix}---a @i{string}; evaluated. Complicated defaulting behavior; see below. @t{:per-line-prefix}---a @i{string}; evaluated. Complicated defaulting behavior; see below. @t{:suffix}---a @i{string}; evaluated. The default is the @i{null} @i{string}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @subsubheading Description:: Causes printing to be grouped into a logical block. The logical block is printed to the @i{stream} that is the @i{value} of the @i{variable} denoted by @i{stream-symbol}. During the execution of the @i{forms}, that @i{variable} is @i{bound} to a @i{pretty printing stream} that supports decisions about the arrangement of output and then forwards the output to the destination stream. All the standard printing functions (@i{e.g.}, @b{write}, @b{princ}, and @b{terpri}) can be used to print output to the @i{pretty printing stream}. All and only the output sent to this @i{pretty printing stream} is treated as being in the logical block. The @i{prefix} specifies a prefix to be printed before the beginning of the logical block. The @i{per-line-prefix} specifies a prefix that is printed before the block and at the beginning of each new line in the block. The @t{:prefix} and @t{:pre-line-prefix} @i{arguments} are mutually exclusive. If neither @t{:prefix} nor @t{:per-line-prefix} is specified, a @i{prefix} of the @i{null} @i{string} is assumed. The @i{suffix} specifies a suffix that is printed just after the logical block. The @i{object} is normally a @i{list} that the body @i{forms} are responsible for printing. If @i{object} is not a @i{list}, it is printed using @b{write}. (This makes it easier to write printing functions that are robust in the face of malformed arguments.) If @b{*print-circle*} is @i{non-nil} and @i{object} is a circular (or shared) reference to a @i{cons}, then an appropriate ``@t{#@i{n}#}'' marker is printed. (This makes it easy to write printing functions that provide full support for circularity and sharing abbreviation.) If @b{*print-level*} is not @b{nil} and the logical block is at a dynamic nesting depth of greater than @b{*print-level*} in logical blocks, ``@t{#}'' is printed. (This makes easy to write printing functions that provide full support for depth abbreviation.) If either of the three conditions above occurs, the indicated output is printed on @i{stream-symbol} and the body @i{forms} are skipped along with the printing of the @t{:prefix} and @t{:suffix}. (If the body @i{forms} are not to be responsible for printing a list, then the first two tests above can be turned off by supplying @b{nil} for the @i{object} argument.) In addition to the @i{object} argument of @b{pprint-logical-block}, the arguments of the standard printing functions (such as @b{write}, @b{print}, @b{prin1}, and @b{pprint}, as well as the arguments of the standard @i{format directives} such as @t{~A}, @t{~S}, (and @t{~W}) are all checked (when necessary) for circularity and sharing. However, such checking is not applied to the arguments of the functions @b{write-line}, @b{write-string}, and @b{write-char} or to the literal text output by @b{format}. A consequence of this is that you must use one of the latter functions if you want to print some literal text in the output that is not supposed to be checked for circularity or sharing. The body @i{forms} of a @b{pprint-logical-block} @i{form} must not perform any side-effects on the surrounding environment; for example, no @i{variables} must be assigned which have not been @i{bound} within its scope. The @b{pprint-logical-block} @i{macro} may be used regardless of the @i{value} of @b{*print-pretty*}. @subsubheading Affected By:: @b{*print-circle*}, @b{*print-level*}. @subsubheading Exceptional Situations:: An error of @i{type} @b{type-error} is signaled if any of the @t{:suffix}, @t{:prefix}, or @t{:per-line-prefix} is supplied but does not evaluate to a @i{string}. An error is signaled if @t{:prefix} and @t{:pre-line-prefix} are both used. @b{pprint-logical-block} and the @i{pretty printing stream} it creates have @i{dynamic extent}. The consequences are undefined if, outside of this extent, output is attempted to the @i{pretty printing stream} it creates. It is also unspecified what happens if, within this extent, any output is sent directly to the underlying destination stream. @subsubheading See Also:: @ref{pprint-pop} , @ref{pprint-exit-if-list-exhausted} , @ref{Tilde Less-Than-Sign-> Logical Block} @subsubheading Notes:: One reason for using the @b{pprint-logical-block} @i{macro} when the @i{value} of @b{*print-pretty*} is @b{nil} would be to allow it to perform checking for @i{dotted lists}, as well as (in conjunction with @b{pprint-pop}) checking for @b{*print-level*} or @b{*print-length*} being exceeded. Detection of circularity and sharing is supported by the @i{pretty printer} by in essence performing requested output twice. On the first pass, circularities and sharing are detected and the actual outputting of characters is suppressed. On the second pass, the appropriate ``@t{#@i{n}=}'' and ``@t{#@i{n}#}'' markers are inserted and characters are output. This is why the restriction on side-effects is necessary. Obeying this restriction is facilitated by using @b{pprint-pop}, instead of an ordinary @b{pop} when traversing a list being printed by the body @i{forms} of the @b{pprint-logical-block} @i{form}.) @node pprint-newline, pprint-pop, pprint-logical-block, Printer Dictionary @subsection pprint-newline [Function] @code{pprint-newline} @i{kind @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{kind}---one of @t{:linear}, @t{:fill}, @t{:miser}, or @t{:mandatory}. @i{stream}---a @i{stream designator}. The default is @i{standard output}. @subsubheading Description:: If @i{stream} is a @i{pretty printing stream} and the @i{value} of @b{*print-pretty*} is @i{true}, a line break is inserted in the output when the appropriate condition below is satisfied; otherwise, @b{pprint-newline} has no effect. @i{Kind} specifies the style of conditional newline. This @i{parameter} is treated as follows: @table @asis @item @t{:linear} This specifies a ``linear-style'' @i{conditional newline}. @ITindex linear-style conditional newline A line break is inserted if and only if the immediately containing @i{section} cannot be printed on one line. The effect of this is that line breaks are either inserted at every linear-style conditional newline in a logical block or at none of them. @item @t{:miser} This specifies a ``miser-style'' @i{conditional newline}. @ITindex miser-style conditional newline A line break is inserted if and only if the immediately containing @i{section} cannot be printed on one line and miser style is in effect in the immediately containing logical block. The effect of this is that miser-style conditional newlines act like linear-style conditional newlines, but only when miser style is in effect. Miser style is in effect for a logical block if and only if the starting position of the logical block is less than or equal to @b{*print-miser-width*} @i{ems} from the right margin. @item @t{:fill} This specifies a ``fill-style'' @i{conditional newline}. @ITindex fill-style conditional newline A line break is inserted if and only if either (a) the following @i{section} cannot be printed on the end of the current line, (b) the preceding @i{section} was not printed on a single line, or (c) the immediately containing @i{section} cannot be printed on one line and miser style is in effect in the immediately containing logical block. If a logical block is broken up into a number of subsections by fill-style conditional newlines, the basic effect is that the logical block is printed with as many subsections as possible on each line. However, if miser style is in effect, fill-style conditional newlines act like linear-style conditional newlines. @item @t{:mandatory} This specifies a ``mandatory-style'' @i{conditional newline}. @ITindex mandatory-style conditional newline A line break is always inserted. This implies that none of the containing @i{sections} can be printed on a single line and will therefore trigger the insertion of line breaks at linear-style conditional newlines in these @i{sections}. @end table When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are omitted from the output and indentation is introduced at the beginning of the next line. By default, the indentation causes the following line to begin in the same horizontal position as the first character in the immediately containing logical block. (The indentation can be changed via @b{pprint-indent}.) There are a variety of ways unconditional newlines can be introduced into the output (@i{i.e.}, via @b{terpri} or by printing a string containing a newline character). As with mandatory conditional newlines, this prevents any of the containing @i{sections} from being printed on one line. In general, when an unconditional newline is encountered, it is printed out without suppression of the preceding blanks and without any indentation following it. However, if a per-line prefix has been specified (see @b{pprint-logical-block}), this prefix will always be printed no matter how a newline originates. @subsubheading Examples:: See @ref{Examples of using the Pretty Printer}. @subsubheading Side Effects:: Output to @i{stream}. @subsubheading Affected By:: @b{*print-pretty*}, @b{*print-miser*}. The presence of containing logical blocks. The placement of newlines and conditional newlines. @subsubheading Exceptional Situations:: An error of @i{type} @b{type-error} is signaled if @i{kind} is not one of @t{:linear}, @t{:fill}, @t{:miser}, or @t{:mandatory}. @subsubheading See Also:: @ref{Tilde Underscore-> Conditional Newline}, @ref{Examples of using the Pretty Printer} @node pprint-pop, pprint-tab, pprint-newline, Printer Dictionary @subsection pprint-pop [Local Macro] @subsubheading Syntax:: @code{pprint-pop} @i{<@i{no @i{arguments}}>} @result{} @i{object} @subsubheading Arguments and Values:: @i{object}---an @i{element} of the @i{list} being printed in the @i{lexically current logical block}, or @b{nil}. @subsubheading Description:: Pops one @i{element} from the @i{list} being printed in the @i{lexically current logical block}, obeying @b{*print-length*} and @b{*print-circle*} as described below. Each time @b{pprint-pop} is called, it pops the next value off the @i{list} passed to the @i{lexically current logical block} and returns it. However, before doing this, it performs three tests: @table @asis @item @t{*} If the remaining `list' is not a @i{list}, ``@t{. }'' is printed followed by the remaining `list.' (This makes it easier to write printing functions that are robust in the face of malformed arguments.) @item @t{*} If @b{*print-length*} is @i{non-nil}, and @b{pprint-pop} has already been called @b{*print-length*} times within the immediately containing logical block, ``@t{...}'' is printed. (This makes it easy to write printing functions that properly handle @b{*print-length*}.) @item @t{*} If @b{*print-circle*} is @i{non-nil}, and the remaining list is a circular (or shared) reference, then ``@t{. }'' is printed followed by an appropriate ``@t{#@i{n}#}'' marker. (This catches instances of @i{cdr} circularity and sharing in lists.) @end table If either of the three conditions above occurs, the indicated output is printed on the @i{pretty printing stream} created by the immediately containing @b{pprint-logical-block} and the execution of the immediately containing @b{pprint-logical-block} is terminated except for the printing of the suffix. If @b{pprint-logical-block} is given a `list' argument of @b{nil}---because it is not processing a list---@b{pprint-pop} can still be used to obtain support for @b{*print-length*}. In this situation, the first and third tests above are disabled and @b{pprint-pop} always returns @b{nil}. See @ref{Examples of using the Pretty Printer}---specifically, the @b{pprint-vector} example. Whether or not @b{pprint-pop} is @i{fbound} in the @i{global environment} is @i{implementation-dependent}; however, the restrictions on redefinition and @i{shadowing} of @b{pprint-pop} are the same as for @i{symbols} in the @t{COMMON-LISP} @i{package} which are @i{fbound} in the @i{global environment}. The consequences of attempting to use @b{pprint-pop} outside of @b{pprint-logical-block} are undefined. @subsubheading Side Effects:: Might cause output to the @i{pretty printing stream} associated with the lexically current logical block. @subsubheading Affected By:: @b{*print-length*}, @b{*print-circle*}. @subsubheading Exceptional Situations:: An error is signaled (either at macro expansion time or at run time) if a usage of @b{pprint-pop} occurs where there is no lexically containing @b{pprint-logical-block} @i{form}. The consequences are undefined if @b{pprint-pop} is executed outside of the @i{dynamic extent} of this @b{pprint-logical-block}. @subsubheading See Also:: @ref{pprint-exit-if-list-exhausted} , @ref{pprint-logical-block} . @subsubheading Notes:: It is frequently a good idea to call @b{pprint-exit-if-list-exhausted} before calling @b{pprint-pop}. @node pprint-tab, print-object, pprint-pop, Printer Dictionary @subsection pprint-tab [Function] @code{pprint-tab} @i{kind colnum colinc @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{kind}---one of @t{:line}, @t{:section}, @t{:line-relative}, or @t{:section-relative}. @i{colnum}---a non-negative @i{integer}. @i{colinc}---a non-negative @i{integer}. @i{stream}---an @i{output} @i{stream designator}. @subsubheading Description:: Specifies tabbing to @i{stream} as performed by the standard @t{~T} format directive. If @i{stream} is a @i{pretty printing stream} and the @i{value} of @b{*print-pretty*} is @i{true}, tabbing is performed; otherwise, @b{pprint-tab} has no effect. The arguments @i{colnum} and @i{colinc} correspond to the two @i{parameters} to @t{~T} and are in terms of @i{ems}. The @i{kind} argument specifies the style of tabbing. It must be one of @t{:line} (tab as by @t{~T}), @t{:section} (tab as by @t{~:T}, but measuring horizontal positions relative to the start of the dynamically enclosing section), @t{:line-relative} (tab as by @t{~@@T}), or @t{:section-relative} (tab as by @t{~:@@T}, but measuring horizontal positions relative to the start of the dynamically enclosing section). @subsubheading Exceptional Situations:: An error is signaled if @i{kind} is not one of @t{:line}, @t{:section}, @t{:line-relative}, or @t{:section-relative}. @subsubheading See Also:: @ref{pprint-logical-block} @node print-object, print-unreadable-object, pprint-tab, Printer Dictionary @subsection print-object [Standard Generic Function] @subsubheading Syntax:: @code{print-object} @i{object stream} @result{} @i{object} @subsubheading Method Signatures:: @code{print-object} @i{@r{(}@i{object} standard-object@r{)} @i{stream}} @code{print-object} @i{@r{(}@i{object} structure-object@r{)} @i{stream}} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{stream}---a @i{stream}. @subsubheading Description:: The @i{generic function} @b{print-object} writes the printed representation of @i{object} to @i{stream}. The @i{function} @b{print-object} is called by the @i{Lisp printer}; it should not be called by the user. Each implementation is required to provide a @i{method} on the @i{class} @b{standard-object} and on the @i{class} @b{structure-object}. In addition, each @i{implementation} must provide @i{methods} on enough other @i{classes} so as to ensure that there is always an applicable @i{method}. Implementations are free to add @i{methods} for other @i{classes}. Users may write @i{methods} for @b{print-object} for their own @i{classes} if they do not wish to inherit an @i{implementation-dependent} @i{method}. The @i{method} on the @i{class} @b{structure-object} prints the object in the default @t{#S} notation; see @ref{Printing Structures}. @i{Methods} on @b{print-object} are responsible for implementing their part of the semantics of the @i{printer control variables}, as follows: @table @asis @item @b{*print-readably*} All methods for @b{print-object} must obey @b{*print-readably*}. This includes both user-defined methods and @i{implementation-defined} methods. Readable printing of @i{structures} and @i{standard objects} is controlled by their @b{print-object} method, not by their @b{make-load-form} @i{method}. @i{Similarity} for these @i{objects} is application dependent and hence is defined to be whatever these @i{methods} do; see @ref{Similarity of Literal Objects}. @item @b{*print-escape*} Each @i{method} must implement @b{*print-escape*}. @item @b{*print-pretty*} The @i{method} may wish to perform specialized line breaking or other output conditional on the @i{value} of @b{*print-pretty*}. For further information, see (for example) the @i{macro} @b{pprint-fill}. See also @ref{Pretty Print Dispatch Tables} and @ref{Examples of using the Pretty Printer}. @item @b{*print-length*} @i{Methods} that produce output of indefinite length must obey @b{*print-length*}. For further information, see (for example) the @i{macros} @b{pprint-logical-block} and @b{pprint-pop}. See also @ref{Pretty Print Dispatch Tables} and @ref{Examples of using the Pretty Printer}. @item @b{*print-level*} The printer takes care of @b{*print-level*} automatically, provided that each @i{method} handles exactly one level of structure and calls @b{write} (or an equivalent @i{function}) recursively if there are more structural levels. The printer's decision of whether an @i{object} has components (and therefore should not be printed when the printing depth is not less than @b{*print-level*}) is @i{implementation-dependent}. In some implementations its @b{print-object} @i{method} is not called; in others the @i{method} is called, and the determination that the @i{object} has components is based on what it tries to write to the @i{stream}. @item @b{*print-circle*} When the @i{value} of @b{*print-circle*} is @i{true}, a user-defined @b{print-object} @i{method} can print @i{objects} to the supplied @i{stream} using @b{write}, @b{prin1}, @b{princ}, or @b{format} and expect circularities to be detected and printed using the @t{#@i{n}#} syntax. If a user-defined @b{print-object} @i{method} prints to a @i{stream} other than the one that was supplied, then circularity detection starts over for that @i{stream}. See @b{*print-circle*}. @item @b{*print-base*}, @b{*print-radix*}, @b{*print-case*}, @b{*print-gensym*}, and @b{*print-array*} These @i{printer control variables} apply to specific types of @i{objects} and are handled by the @i{methods} for those @i{objects}. @end table If these rules are not obeyed, the results are undefined. In general, the printer and the @b{print-object} methods should not rebind the print control variables as they operate recursively through the structure, but this is @i{implementation-dependent}. In some implementations the @i{stream} argument passed to a @b{print-object} @i{method} is not the original @i{stream}, but is an intermediate @i{stream} that implements part of the printer. @i{methods} should therefore not depend on the identity of this @i{stream}. @subsubheading See Also:: @ref{pprint-fill} , @ref{pprint-logical-block} , @ref{pprint-pop} , @ref{write} , @b{*print-readably*}, @b{*print-escape*}, @b{*print-pretty*}, @b{*print-length*}, @ref{Default Print-Object Methods}, @ref{Printing Structures}, @ref{Pretty Print Dispatch Tables}, @ref{Examples of using the Pretty Printer} @node print-unreadable-object, set-pprint-dispatch, print-object, Printer Dictionary @subsection print-unreadable-object [Macro] @code{print-unreadable-object} @i{@r{(}object stream @r{&key} type identity@r{)} @{@i{form}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{object}---an @i{object}; evaluated. @i{stream}--- a @i{stream designator}; evaluated. @i{type}---a @i{generalized boolean}; evaluated. @i{identity}---a @i{generalized boolean}; evaluated. @i{forms}---an @i{implicit progn}. @subsubheading Description:: Outputs a printed representation of @i{object} on @i{stream}, beginning with ``@t{#<}'' and ending with ``@t{>}''. Everything output to @i{stream} by the body @i{forms} is enclosed in the the angle brackets. If @i{type} is @i{true}, the output from @i{forms} is preceded by a brief description of the @i{object}'s @i{type} and a space character. If @i{identity} is @i{true}, the output from @i{forms} is followed by a space character and a representation of the @i{object}'s identity, typically a storage address. If either @i{type} or @i{identity} is not supplied, its value is @i{false}. It is valid to omit the body @i{forms}. If @i{type} and @i{identity} are both true and there are no body @i{forms}, only one space character separates the type and the identity. @subsubheading Examples:: ;; Note that in this example, the precise form of the output ;; is @i{implementation-dependent}. @example (defmethod print-object ((obj airplane) stream) (print-unreadable-object (obj stream :type t :identity t) (princ (tail-number obj) stream))) (prin1-to-string my-airplane) @result{} "#" @i{OR}@result{} "#" @end example @subsubheading Exceptional Situations:: If @b{*print-readably*} is @i{true}, @b{print-unreadable-object} signals an error of @i{type} @b{print-not-readable} without printing anything. @node set-pprint-dispatch, write, print-unreadable-object, Printer Dictionary @subsection set-pprint-dispatch [Function] @code{set-pprint-dispatch} @i{type-specifier function @r{&optional} priority table} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{type-specifier}---a @i{type specifier}. @i{function}---a @i{function}, a @i{function name}, or @b{nil}. @i{priority}---a @i{real}. The default is @t{0}. @i{table}---a @i{pprint dispatch table}. The default is the @i{value} of @b{*print-pprint-dispatch*}. @subsubheading Description:: Installs an entry into the @i{pprint dispatch table} which is @i{table}. @i{Type-specifier} is the @i{key} of the entry. The first action of @b{set-pprint-dispatch} is to remove any pre-existing entry associated with @i{type-specifier}. This guarantees that there will never be two entries associated with the same @i{type specifier} in a given @i{pprint dispatch table}. Equality of @i{type specifiers} is tested by @b{equal}. Two values are associated with each @i{type specifier} in a @i{pprint dispatch table}: a @i{function} and a @i{priority}. The @i{function} must accept two arguments: the @i{stream} to which output is sent and the @i{object} to be printed. The @i{function} should @i{pretty print} the @i{object} to the @i{stream}. The @i{function} can assume that object satisfies the @i{type} given by @i{type-specifier}. The @i{function} must obey @b{*print-readably*}. Any values returned by the @i{function} are ignored. @i{Priority} is a priority to resolve conflicts when an object matches more than one entry. It is permissible for @i{function} to be @b{nil}. In this situation, there will be no @i{type-specifier} entry in @i{table} after @b{set-pprint-dispatch} returns. @subsubheading Exceptional Situations:: An error is signaled if @i{priority} is not a @i{real}. @subsubheading Notes:: Since @i{pprint dispatch tables} are often used to control the pretty printing of Lisp code, it is common for the @i{type-specifier} to be an @i{expression} of the form @example (cons @i{car-type} @i{cdr-type}) @end example This signifies that the corresponding object must be a cons cell whose @i{car} matches the @i{type specifier} @i{car-type} and whose @i{cdr} matches the @i{type specifier} @i{cdr-type}. The @i{cdr-type} can be omitted in which case it defaults to @b{t}. @node write, write-to-string, set-pprint-dispatch, Printer Dictionary @subsection write, prin1, print, pprint, princ [Function] @code{write} @i{@i{object} @r{&key} \writekeys@r{stream}}@* @result{} @i{object} @code{prin} @i{1} @result{} @i{object @r{&optional} output-stream} @r{object} @code{princ} @i{object @r{&optional} output-stream} @result{} @i{object} @code{print} @i{object @r{&optional} output-stream} @result{} @i{object} @code{pprint} @i{object @r{&optional} output-stream} @result{} @i{<@i{no @i{values}}>} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{output-stream}---an @i{output} @i{stream designator}. The default is @i{standard output}. \writekeydescriptions@r{@i{stream}---an @i{output} @i{stream designator}. The default is @i{standard output}.} @subsubheading Description:: @b{write}, @b{prin1}, @b{princ}, @b{print}, and @b{pprint} write the printed representation of @i{object} to @i{output-stream}. @b{write} is the general entry point to the @i{Lisp printer}. For each explicitly supplied @i{keyword parameter} named in Figure 22--6, the corresponding @i{printer control variable} is dynamically bound to its @i{value} while printing goes on; for each @i{keyword parameter} in Figure 22--6 that is not explicitly supplied, the value of the corresponding @i{printer control variable} is the same as it was at the time @b{write} was invoked. Once the appropriate @i{bindings} are @i{established}, the @i{object} is output by the @i{Lisp printer}. @format @group @noindent @w{ Parameter Corresponding Dynamic Variable } @w{ @i{array} @b{*print-array*} } @w{ @i{base} @b{*print-base*} } @w{ @i{case} @b{*print-case*} } @w{ @i{circle} @b{*print-circle*} } @w{ @i{escape} @b{*print-escape*} } @w{ @i{gensym} @b{*print-gensym*} } @w{ @i{length} @b{*print-length*} } @w{ @i{level} @b{*print-level*} } @w{ @i{lines} @b{*print-lines*} } @w{ @i{miser-width} @b{*print-miser-width*} } @w{ @i{pprint-dispatch} @b{*print-pprint-dispatch*} } @w{ @i{pretty} @b{*print-pretty*} } @w{ @i{radix} @b{*print-radix*} } @w{ @i{readably} @b{*print-readably*} } @w{ @i{right-margin} @b{*print-right-margin*} } @noindent @w{ Figure 22--6: Argument correspondences for the WRITE function.} @end group @end format @b{prin1}, @b{princ}, @b{print}, and @b{pprint} implicitly @i{bind} certain print parameters to particular values. The remaining parameter values are taken from @b{*print-array*}, @b{*print-base*}, @b{*print-case*}, @b{*print-circle*}, @b{*print-escape*}, @b{*print-gensym*}, @b{*print-length*}, @b{*print-level*}, @b{*print-lines*}, @b{*print-miser-width*}, @b{*print-pprint-dispatch*}, @b{*print-pretty*}, @b{*print-radix*}, and @b{*print-right-margin*}. @b{prin1} produces output suitable for input to @b{read}. It binds @b{*print-escape*} to @i{true}. @b{princ} is just like @b{prin1} except that the output has no @i{escape} @i{characters}. It binds @b{*print-escape*} to @i{false} and @b{*print-readably*} to @i{false}. The general rule is that output from @b{princ} is intended to look good to people, while output from @b{prin1} is intended to be acceptable to @b{read}. @b{print} is just like @b{prin1} except that the printed representation of @i{object} is preceded by a newline and followed by a space. @b{pprint} is just like @b{print} except that the trailing space is omitted and @i{object} is printed with the @b{*print-pretty*} flag @i{non-nil} to produce pretty output. @i{Output-stream} specifies the @i{stream} to which output is to be sent. @subsubheading Affected By:: @b{*standard-output*}, @b{*terminal-io*}, @b{*print-escape*}, @b{*print-radix*}, @b{*print-base*}, @b{*print-circle*}, @b{*print-pretty*}, @b{*print-level*}, @b{*print-length*}, @b{*print-case*}, @b{*print-gensym*}, @b{*print-array*}, @b{*read-default-float-format*}. @subsubheading See Also:: @ref{readtable-case} , @ref{FORMAT Printer Operations} @subsubheading Notes:: The @i{functions} @b{prin1} and @b{print} do not bind @b{*print-readably*}. @example (prin1 object output-stream) @equiv{} (write object :stream output-stream :escape t) @end example @example (princ object output-stream) @equiv{} (write object stream output-stream :escape nil :readably nil) @end example @example (print object output-stream) @equiv{} (progn (terpri output-stream) (write object :stream output-stream :escape t) (write-char #\space output-stream)) @end example @example (pprint object output-stream) @equiv{} (write object :stream output-stream :escape t :pretty t) @end example @node write-to-string, *print-array*, write, Printer Dictionary @subsection write-to-string, prin1-to-string, princ-to-string [Function] @code{write-to-string} @i{object @r{&key} \writekeys}@* @result{} @i{string} @code{prin} @i{1} @result{} @i{-to-string} @r{object} @r{string} @code{princ-to-string} @i{object} @result{} @i{string} @subsubheading Arguments and Values:: @i{object}---an @i{object}. \writekeydescriptions @i{string}---a @i{string}. @subsubheading Description:: @b{write-to-string}, @b{prin1-to-string}, and @b{princ-to-string} are used to create a @i{string} consisting of the printed representation of @i{object}. @i{Object} is effectively printed as if by @b{write}, @b{prin1}, or @b{princ}, respectively, and the @i{characters} that would be output are made into a @i{string}. @b{write-to-string} is the general output function. It has the ability to specify all the parameters applicable to the printing of @i{object}. @b{prin1-to-string} acts like @b{write-to-string} with @t{:escape t}, that is, escape characters are written where appropriate. @b{princ-to-string} acts like @b{write-to-string} with @t{:escape nil :readably nil}. Thus no @i{escape} @i{characters} are written. All other keywords that would be specified to @b{write-to-string} are default values when @b{prin1-to-string} or @b{princ-to-string} is invoked. The meanings and defaults for the keyword arguments to @b{write-to-string} are the same as those for @b{write}. @subsubheading Examples:: @example (prin1-to-string "abc") @result{} "\"abc\"" (princ-to-string "abc") @result{} "abc" @end example @subsubheading Affected By:: @b{*print-escape*}, @b{*print-radix*}, @b{*print-base*}, @b{*print-circle*}, @b{*print-pretty*}, @b{*print-level*}, @b{*print-length*}, @b{*print-case*}, @b{*print-gensym*}, @b{*print-array*}, @b{*read-default-float-format*}. @subsubheading See Also:: @ref{write} @subsubheading Notes:: @example (write-to-string @i{object} @{@i{key} @i{argument}@}*) @equiv{} (with-output-to-string (#1=#:string-stream) (write object :stream #1# @{@i{key} @i{argument}@}*)) (princ-to-string @i{object}) @equiv{} (with-output-to-string (string-stream) (princ @i{object} string-stream)) (prin1-to-string @i{object}) @equiv{} (with-output-to-string (string-stream) (prin1 @i{object} string-stream)) @end example @node *print-array*, *print-base*, write-to-string, Printer Dictionary @subsection *print-array* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: Controls the format in which @i{arrays} are printed. If it is @i{false}, the contents of @i{arrays} other than @i{strings} are never printed. Instead, @i{arrays} are printed in a concise form using @t{#<} that gives enough information for the user to be able to identify the @i{array}, but does not include the entire @i{array} contents. If it is @i{true}, non-@i{string} @i{arrays} are printed using @t{#(...)}, @t{#*}, or @t{#nA} syntax. @subsubheading Affected By:: The @i{implementation}. @subsubheading See Also:: @ref{Sharpsign Left-Parenthesis}, @ref{Sharpsign Less-Than-Sign} @node *print-base*, *print-case*, *print-array*, Printer Dictionary @subsection *print-base*, *print-radix* [Variable] @subsubheading Value Type:: @b{*print-base*}---a @i{radix}. @b{*print-radix*}---a @i{generalized boolean}. @subsubheading Initial Value:: The initial @i{value} of @b{*print-base*} is @t{10}. The initial @i{value} of @b{*print-radix*} is @i{false}. @subsubheading Description:: @b{*print-base*} and @b{*print-radix*} control the printing of @i{rationals}. The @i{value} of @b{*print-base*} is called the @i{current output base} @IGindex current output base . The @i{value} of @b{*print-base*} is the @i{radix} in which the printer will print @i{rationals}. For radices above @t{10}, letters of the alphabet are used to represent digits above @t{9}. If the @i{value} of @b{*print-radix*} is @i{true}, the printer will print a radix specifier to indicate the @i{radix} in which it is printing a @i{rational} number. The radix specifier is always printed using lowercase letters. If @b{*print-base*} is @t{2}, @t{8}, or @t{16}, then the radix specifier used is @t{#b}, @t{#o}, or @t{#x}, respectively. For @i{integers}, base ten is indicated by a trailing decimal point instead of a leading radix specifier; for @i{ratios}, @t{#10r} is used. @subsubheading Examples:: @example (let ((*print-base* 24.) (*print-radix* t)) (print 23.)) @t{ |> } #24rN @result{} 23 (setq *print-base* 10) @result{} 10 (setq *print-radix* nil) @result{} NIL (dotimes (i 35) (let ((*print-base* (+ i 2))) ;print the decimal number 40 (write 40) ;in each base from 2 to 36 (if (zerop (mod i 10)) (terpri) (format t " ")))) @t{ |> } 101000 @t{ |> } 1111 220 130 104 55 50 44 40 37 34 @t{ |> } 31 2C 2A 28 26 24 22 20 1J 1I @t{ |> } 1H 1G 1F 1E 1D 1C 1B 1A 19 18 @t{ |> } 17 16 15 14 @result{} NIL (dolist (pb '(2 3 8 10 16)) (let ((*print-radix* t) ;print the integer 10 and (*print-base* pb)) ;the ratio 1/10 in bases 2, (format t "~&~S ~S~ @t{ |> } #b1010 #b1/1010 @t{ |> } #3r101 #3r1/101 @t{ |> } #o12 #o1/12 @t{ |> } 10. #10r1/10 @t{ |> } #xA #x1/A @result{} NIL @end example @subsubheading Affected By:: Might be @i{bound} by @b{format}, and @b{write}, @b{write-to-string}. @subsubheading See Also:: @ref{format} , @ref{write} , @ref{write-to-string} @node *print-case*, *print-circle*, *print-base*, Printer Dictionary @subsection *print-case* [Variable] @subsubheading Value Type:: One of the @i{symbols} @t{:upcase}, @t{:downcase}, or @t{:capitalize}. @subsubheading Initial Value:: The @i{symbol} @t{:upcase}. @subsubheading Description:: The @i{value} of @b{*print-case*} controls the case (upper, lower, or mixed) in which to print any uppercase characters in the names of @i{symbols} when vertical-bar syntax is not used. @b{*print-case*} has an effect at all times when the @i{value} of @b{*print-escape*} is @i{false}. @b{*print-case*} also has an effect when the @i{value} of @b{*print-escape*} is @i{true} unless inside an escape context (@i{i.e.}, unless between @i{vertical-bars} or after a @i{slash}). @subsubheading Examples:: @example (defun test-print-case () (dolist (*print-case* '(:upcase :downcase :capitalize)) (format t "~&~S ~S~ @result{} TEST-PC ;; Although the choice of which characters to escape is specified by ;; *PRINT-CASE*, the choice of how to escape those characters ;; (i.e., whether single escapes or multiple escapes are used) ;; is implementation-dependent. The examples here show two of the ;; many valid ways in which escaping might appear. (test-print-case) ;Implementation A @t{ |> } THIS-AND-THAT |And-something-elSE| @t{ |> } this-and-that a\n\d-\s\o\m\e\t\h\i\n\g-\e\lse @t{ |> } This-And-That A\n\d-\s\o\m\e\t\h\i\n\g-\e\lse @result{} NIL (test-print-case) ;Implementation B @t{ |> } THIS-AND-THAT |And-something-elSE| @t{ |> } this-and-that a|nd-something-el|se @t{ |> } This-And-That A|nd-something-el|se @result{} NIL @end example @subsubheading See Also:: @ref{write} @subsubheading Notes:: @b{read} normally converts lowercase characters appearing in @i{symbols} to corresponding uppercase characters, so that internally print names normally contain only uppercase characters. If @b{*print-escape*} is @i{true}, lowercase characters in the @i{name} of a @i{symbol} are always printed in lowercase, and are preceded by a single escape character or enclosed by multiple escape characters; uppercase characters in the @i{name} of a @i{symbol} are printed in upper case, in lower case, or in mixed case so as to capitalize words, according to the value of @b{*print-case*}. The convention for what constitutes a ``word'' is the same as for @b{string-capitalize}. @node *print-circle*, *print-escape*, *print-case*, Printer Dictionary @subsection *print-circle* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{false}. @subsubheading Description:: Controls the attempt to detect circularity and sharing in an @i{object} being printed. If @i{false}, the printing process merely proceeds by recursive descent without attempting to detect circularity and sharing. If @i{true}, the printer will endeavor to detect cycles and sharing in the structure to be printed, and to use @t{#@i{n}=} and @t{#@i{n}#} syntax to indicate the circularities or shared components. If @i{true}, a user-defined @b{print-object} @i{method} can print @i{objects} to the supplied @i{stream} using @b{write}, @b{prin1}, @b{princ}, or @b{format} and expect circularities and sharing to be detected and printed using the @t{#@i{n}#} syntax. If a user-defined @b{print-object} @i{method} prints to a @i{stream} other than the one that was supplied, then circularity detection starts over for that @i{stream}. Note that implementations should not use @t{#@i{n}#} notation when the @i{Lisp reader} would automatically assure sharing without it (@i{e.g.}, as happens with @i{interned} @i{symbols}). @subsubheading Examples:: @example (let ((a (list 1 2 3))) (setf (cdddr a) a) (let ((*print-circle* t)) (write a) :done)) @t{ |> } #1=(1 2 3 . #1#) @result{} :DONE @end example @subsubheading See Also:: @ref{write} @subsubheading Notes:: An attempt to print a circular structure with @b{*print-circle*} set to @b{nil} may lead to looping behavior and failure to terminate. @node *print-escape*, *print-gensym*, *print-circle*, Printer Dictionary @subsection *print-escape* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{true}. @subsubheading Description:: If @i{false}, escape characters and @i{package prefixes} are not output when an expression is printed. If @i{true}, an attempt is made to print an @i{expression} in such a way that it can be read again to produce an @b{equal} @i{expression}. (This is only a guideline; not a requirement. See @b{*print-readably*}.) For more specific details of how the @i{value} of @b{*print-escape*} affects the printing of certain @i{types}, see @ref{Default Print-Object Methods}. @subsubheading Examples:: @example (let ((*print-escape* t)) (write #\a)) @t{ |> } #\a @result{} #\a (let ((*print-escape* nil)) (write #\a)) @t{ |> } a @result{} #\a @end example @subsubheading Affected By:: @b{princ}, @b{prin1}, @b{format} @subsubheading See Also:: @ref{write} , @ref{readtable-case} @subsubheading Notes:: @b{princ} effectively binds @b{*print-escape*} to @i{false}. @b{prin1} effectively binds @b{*print-escape*} to @i{true}. @node *print-gensym*, *print-level*, *print-escape*, Printer Dictionary @subsection *print-gensym* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{true}. @subsubheading Description:: Controls whether the prefix ``@t{#:}'' is printed before @i{apparently uninterned} @i{symbols}. The prefix is printed before such @i{symbols} if and only if the @i{value} of @b{*print-gensym*} is @i{true}. @subsubheading Examples:: @example (let ((*print-gensym* nil)) (print (gensym))) @t{ |> } G6040 @result{} #:G6040 @end example @subsubheading See Also:: @ref{write} , @b{*print-escape*} @node *print-level*, *print-lines*, *print-gensym*, Printer Dictionary @subsection *print-level*, *print-length* [Variable] @subsubheading Value Type:: a non-negative @i{integer}, or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: @b{*print-level*} controls how many levels deep a nested @i{object} will print. If it is @i{false}, then no control is exercised. Otherwise, it is an @i{integer} indicating the maximum level to be printed. An @i{object} to be printed is at level @t{0}; its components (as of a @i{list} or @i{vector}) are at level @t{1}; and so on. If an @i{object} to be recursively printed has components and is at a level equal to or greater than the @i{value} of @b{*print-level*}, then the @i{object} is printed as ``@t{#}''. @b{*print-length*} controls how many elements at a given level are printed. If it is @i{false}, there is no limit to the number of components printed. Otherwise, it is an @i{integer} indicating the maximum number of @i{elements} of an @i{object} to be printed. If exceeded, the printer will print ``@t{...}'' in place of the other @i{elements}. In the case of a @i{dotted list}, if the @i{list} contains exactly as many @i{elements} as the @i{value} of @b{*print-length*}, the terminating @i{atom} is printed rather than printing ``@t{...}'' @b{*print-level*} and @b{*print-length*} affect the printing of an any @i{object} printed with a list-like syntax. They do not affect the printing of @i{symbols}, @i{strings}, and @i{bit vectors}. @subsubheading Examples:: @example (setq a '(1 (2 (3 (4 (5 (6))))))) @result{} (1 (2 (3 (4 (5 (6)))))) (dotimes (i 8) (let ((*print-level* i)) (format t "~&~D -- ~S~ @t{ |> } 0 -- # @t{ |> } 1 -- (1 #) @t{ |> } 2 -- (1 (2 #)) @t{ |> } 3 -- (1 (2 (3 #))) @t{ |> } 4 -- (1 (2 (3 (4 #)))) @t{ |> } 5 -- (1 (2 (3 (4 (5 #))))) @t{ |> } 6 -- (1 (2 (3 (4 (5 (6)))))) @t{ |> } 7 -- (1 (2 (3 (4 (5 (6)))))) @result{} NIL (setq a '(1 2 3 4 5 6)) @result{} (1 2 3 4 5 6) (dotimes (i 7) (let ((*print-length* i)) (format t "~&~D -- ~S~ @t{ |> } 0 -- (...) @t{ |> } 1 -- (1 ...) @t{ |> } 2 -- (1 2 ...) @t{ |> } 3 -- (1 2 3 ...) @t{ |> } 4 -- (1 2 3 4 ...) @t{ |> } 5 -- (1 2 3 4 5 6) @t{ |> } 6 -- (1 2 3 4 5 6) @result{} NIL (dolist (level-length '((0 1) (1 1) (1 2) (1 3) (1 4) (2 1) (2 2) (2 3) (3 2) (3 3) (3 4))) (let ((*print-level* (first level-length)) (*print-length* (second level-length))) (format t "~&~D ~D -- ~S~ *print-level* *print-length* '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz")))))) @t{ |> } 0 1 -- # @t{ |> } 1 1 -- (IF ...) @t{ |> } 1 2 -- (IF # ...) @t{ |> } 1 3 -- (IF # # ...) @t{ |> } 1 4 -- (IF # # #) @t{ |> } 2 1 -- (IF ...) @t{ |> } 2 2 -- (IF (MEMBER X ...) ...) @t{ |> } 2 3 -- (IF (MEMBER X Y) (+ # 3) ...) @t{ |> } 3 2 -- (IF (MEMBER X ...) ...) @t{ |> } 3 3 -- (IF (MEMBER X Y) (+ (CAR X) 3) ...) @t{ |> } 3 4 -- (IF (MEMBER X Y) (+ (CAR X) 3) '(FOO . #(A B C D ...))) @result{} NIL @end example @subsubheading See Also:: @ref{write} @node *print-lines*, *print-miser-width*, *print-level*, Printer Dictionary @subsection *print-lines* [Variable] @subsubheading Value Type:: a non-negative @i{integer}, or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: When the @i{value} of @b{*print-lines*} is other than @b{nil}, it is a limit on the number of output lines produced when something is pretty printed. If an attempt is made to go beyond that many lines, ``@t{..}'' is printed at the end of the last line followed by all of the suffixes (closing delimiters) that are pending to be printed. @subsubheading Examples:: @example (let ((*print-right-margin* 25) (*print-lines* 3)) (pprint '(progn (setq a 1 b 2 c 3 d 4)))) @t{ |> } (PROGN (SETQ A 1 @t{ |> } B 2 @t{ |> } C 3 ..)) @result{} <@i{no @i{values}}> @end example @subsubheading Notes:: The ``@t{..}'' notation is intentionally different than the ``@t{...}'' notation used for level abbreviation, so that the two different situations can be visually distinguished. This notation is used to increase the likelihood that the @i{Lisp reader} will signal an error if an attempt is later made to read the abbreviated output. Note however that if the truncation occurs in a @i{string}, as in @t{"This string has been trunc.."}, the problem situation cannot be detected later and no such error will be signaled. @node *print-miser-width*, *print-pprint-dispatch*, *print-lines*, Printer Dictionary @subsection *print-miser-width* [Variable] @subsubheading Value Type:: a non-negative @i{integer}, or @b{nil}. @subsubheading Initial Value:: @i{implementation-dependent} @subsubheading Description:: If it is not @b{nil}, the @i{pretty printer} switches to a compact style of output (called miser style) whenever the width available for printing a substructure is less than or equal to this many @i{ems}. @node *print-pprint-dispatch*, *print-pretty*, *print-miser-width*, Printer Dictionary @subsection *print-pprint-dispatch* [Variable] @subsubheading Value Type:: a @i{pprint dispatch table}. @subsubheading Initial Value:: @i{implementation-dependent}, but the initial entries all use a special class of priorities that have the property that they are less than every priority that can be specified using @b{set-pprint-dispatch}, so that the initial contents of any entry can be overridden. @subsubheading Description:: The @i{pprint dispatch table} which currently controls the @i{pretty printer}. @subsubheading See Also:: @b{*print-pretty*}, @ref{Pretty Print Dispatch Tables} @subsubheading Notes:: The intent is that the initial @i{value} of this @i{variable} should cause `traditional' @i{pretty printing} of @i{code}. In general, however, you can put a value in @b{*print-pprint-dispatch*} that makes pretty-printed output look exactly like non-pretty-printed output. Setting @b{*print-pretty*} to @i{true} just causes the functions contained in the @i{current pprint dispatch table} to have priority over normal @b{print-object} methods; it has no magic way of enforcing that those functions actually produce pretty output. For details, see @ref{Pretty Print Dispatch Tables}. @node *print-pretty*, *print-readably*, *print-pprint-dispatch*, Printer Dictionary @subsection *print-pretty* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: Controls whether the @i{Lisp printer} calls the @i{pretty printer}. If it is @i{false}, the @i{pretty printer} is not used and a minimum of @i{whitespace}_1 is output when printing an expression. If it is @i{true}, the @i{pretty printer} is used, and the @i{Lisp printer} will endeavor to insert extra @i{whitespace}_1 where appropriate to make @i{expressions} more readable. @b{*print-pretty*} has an effect even when the @i{value} of @b{*print-escape*} is @i{false}. @subsubheading Examples:: @example (setq *print-pretty* 'nil) @result{} NIL (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil) @t{ |> } (LET ((A 1) (B 2) (C 3)) (+ A B C)) @result{} NIL (let ((*print-pretty* t)) (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil)) @t{ |> } (LET ((A 1) @t{ |> } (B 2) @t{ |> } (C 3)) @t{ |> } (+ A B C)) @result{} NIL ;; Note that the first two expressions printed by this next form ;; differ from the second two only in whether escape characters are printed. ;; In all four cases, extra whitespace is inserted by the pretty printer. (flet ((test (x) (let ((*print-pretty* t)) (print x) (format t "~ (terpri) (princ x) (princ " ") (format t "~ (test '#'(lambda () (list "a" #@b{'c} #'d)))) @t{ |> } #'(LAMBDA () @t{ |> } (LIST "a" #@b{'C} #'D)) @t{ |> } #'(LAMBDA () @t{ |> } (LIST "a" #@b{'C} #'D)) @t{ |> } #'(LAMBDA () @t{ |> } (LIST a b 'C #'D)) @t{ |> } #'(LAMBDA () @t{ |> } (LIST a b 'C #'D)) @result{} NIL @end example @subsubheading See Also:: @ref{write} @node *print-readably*, *print-right-margin*, *print-pretty*, Printer Dictionary @subsection *print-readably* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{false}. @subsubheading Description:: If @b{*print-readably*} is @i{true}, some special rules for printing @i{objects} go into effect. Specifically, printing any @i{object} O_1 produces a printed representation that, when seen by the @i{Lisp reader} while the @i{standard readtable} is in effect, will produce an @i{object} O_2 that is @i{similar} to O_1. The printed representation produced might or might not be the same as the printed representation produced when @b{*print-readably*} is @i{false}. If printing an @i{object} @i{readably} is not possible, an error of @i{type} @b{print-not-readable} is signaled rather than using a syntax (@i{e.g.}, the ``@t{#<}'' syntax) that would not be readable by the same @i{implementation}. If the @i{value} of some other @i{printer control variable} is such that these requirements would be violated, the @i{value} of that other @i{variable} is ignored. Specifically, if @b{*print-readably*} is @i{true}, printing proceeds as if @b{*print-escape*}, @b{*print-array*}, and @b{*print-gensym*} were also @i{true}, and as if @b{*print-length*}, @b{*print-level*}, and @b{*print-lines*} were @i{false}. If @b{*print-readably*} is @i{false}, the normal rules for printing and the normal interpretations of other @i{printer control variables} are in effect. Individual @i{methods} for @b{print-object}, including user-defined @i{methods}, are responsible for implementing these requirements. If @b{*read-eval*} is @i{false} and @b{*print-readably*} is @i{true}, any such method that would output a reference to the ``@t{#.}'' @i{reader macro} will either output something else or will signal an error (as described above). @subsubheading Examples:: @example (let ((x (list "a" '\a (gensym) '((a (b (c))) d e f g))) (*print-escape* nil) (*print-gensym* nil) (*print-level* 3) (*print-length* 3)) (write x) (let ((*print-readably* t)) (terpri) (write x) :done)) @t{ |> } (a a G4581 ((A #) D E ...)) @t{ |> } ("a" |a| #:G4581 ((A (B (C))) D E F G)) @result{} :DONE ;; This is setup code is shared between the examples ;; of three hypothetical implementations which follow. (setq table (make-hash-table)) @result{} # (setf (gethash table 1) 'one) @result{} ONE (setf (gethash table 2) 'two) @result{} TWO ;; Implementation A (let ((*print-readably* t)) (print table)) Error: Can't print # readably. ;; Implementation B ;; No standardized #S notation for hash tables is defined, ;; but there might be an implementation-defined notation. (let ((*print-readably* t)) (print table)) @t{ |> } #S(HASH-TABLE :TEST EQL :SIZE 120 :CONTENTS (1 ONE 2 TWO)) @result{} # ;; Implementation C ;; Note that #. notation can only be used if *READ-EVAL* is true. ;; If *READ-EVAL* were false, this same implementation might have to ;; signal an error unless it had yet another printing strategy to fall ;; back on. (let ((*print-readably* t)) (print table)) @t{ |> } #.(LET ((HASH-TABLE (MAKE-HASH-TABLE))) @t{ |> } (SETF (GETHASH 1 HASH-TABLE) ONE) @t{ |> } (SETF (GETHASH 2 HASH-TABLE) TWO) @t{ |> } HASH-TABLE) @result{} # @end example @subsubheading See Also:: @ref{write} , @ref{print-unreadable-object} @subsubheading Notes:: The rules for ``@i{similarity}'' imply that @t{#A} or @t{#(} syntax cannot be used for @i{arrays} of @i{element type} other than @b{t}. An implementation will have to use another syntax or signal an error of @i{type} @b{print-not-readable}. @node *print-right-margin*, print-not-readable, *print-readably*, Printer Dictionary @subsection *print-right-margin* [Variable] @subsubheading Value Type:: a non-negative @i{integer}, or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: If it is @i{non-nil}, it specifies the right margin (as @i{integer} number of @i{ems}) to use when the @i{pretty printer} is making layout decisions. If it is @b{nil}, the right margin is taken to be the maximum line length such that output can be displayed without wraparound or truncation. If this cannot be determined, an @i{implementation-dependent} value is used. @subsubheading Notes:: This measure is in units of @i{ems} in order to be compatible with @i{implementation-defined} variable-width fonts while still not requiring the language to provide support for fonts. @node print-not-readable, print-not-readable-object, *print-right-margin*, Printer Dictionary @subsection print-not-readable [Condition Type] @subsubheading Class Precedence List:: @b{print-not-readable}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{print-not-readable} consists of error conditions that occur during output while @b{*print-readably*} is @i{true}, as a result of attempting to write a printed representation with the @i{Lisp printer} that would not be correctly read back with the @i{Lisp reader}. The object which could not be printed is initialized by the @t{:object} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{print-not-readable-object}. @subsubheading See Also:: @ref{print-not-readable-object} @node print-not-readable-object, format, print-not-readable, Printer Dictionary @subsection print-not-readable-object [Function] @code{print-not-readable-object} @i{condition} @result{} @i{object} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{print-not-readable}. @i{object}---an @i{object}. @subsubheading Description:: Returns the @i{object} that could not be printed readably in the situation represented by @i{condition}. @subsubheading See Also:: @b{print-not-readable}, @ref{Conditions} @node format, , print-not-readable-object, Printer Dictionary @subsection format [Function] @code{format} @i{destination control-string @r{&rest} args} @result{} @i{result} @subsubheading Arguments and Values:: @i{destination}---@b{nil}, @b{t}, a @i{stream}, or a @i{string} with a @i{fill pointer}. @i{control-string}---a @i{format control}. @i{args}---@i{format arguments} for @i{control-string}. @i{result}---if @i{destination} is @i{non-nil}, then @b{nil}; otherwise, a @i{string}. @subsubheading Description:: @b{format} produces formatted output by outputting the characters of @i{control-string} and observing that a @i{tilde} introduces a directive. The character after the tilde, possibly preceded by prefix parameters and modifiers, specifies what kind of formatting is desired. Most directives use one or more elements of @i{args} to create their output. If @i{destination} is a @i{string}, a @i{stream}, or @b{t}, then the @i{result} is @b{nil}. Otherwise, the @i{result} is a @i{string} containing the `output.' @b{format} is useful for producing nicely formatted text, producing good-looking messages, and so on. @b{format} can generate and return a @i{string} or output to @i{destination}. For details on how the @i{control-string} is interpreted, see @ref{Formatted Output}. @subsubheading Affected By:: @b{*standard-output*}, @b{*print-escape*}, @b{*print-radix*}, @b{*print-base*}, @b{*print-circle*}, @b{*print-pretty*}, @b{*print-level*}, @b{*print-length*}, @b{*print-case*}, @b{*print-gensym*}, @b{*print-array*}. @subsubheading Exceptional Situations:: If @i{destination} is a @i{string} with a @i{fill pointer}, the consequences are undefined if destructive modifications are performed directly on the @i{string} during the @i{dynamic extent} of the call. @subsubheading See Also:: @ref{write} , @ref{Documentation of Implementation-Defined Scripts} @c end of including dict-printer @c %**end of chapter gcl-2.6.14/info/chap-13.texi0000644000175000017500000014335114360276512013764 0ustar cammcamm @node Characters, Conses, Numbers (Numbers), Top @chapter Characters @menu * Character Concepts:: * Characters Dictionary:: @end menu @node Character Concepts, Characters Dictionary, Characters, Characters @section Character Concepts @c including concept-characters @menu * Introduction to Characters:: * Introduction to Scripts and Repertoires:: * Character Attributes:: * Character Categories:: * Identity of Characters:: * Ordering of Characters:: * Character Names:: * Treatment of Newline during Input and Output:: * Character Encodings:: * Documentation of Implementation-Defined Scripts:: @end menu @node Introduction to Characters, Introduction to Scripts and Repertoires, Character Concepts, Character Concepts @subsection Introduction to Characters A @i{character} @IGindex character is an @i{object} that represents a unitary token (@i{e.g.}, a letter, a special symbol, or a ``control character'') in an aggregate quantity of text (@i{e.g.}, a @i{string} or a text @i{stream}). @r{Common Lisp} allows an implementation to provide support for international language @i{characters} as well as @i{characters} used in specialized arenas (@i{e.g.}, mathematics). The following figures contain lists of @i{defined names} applicable to @i{characters}. Figure 13--1 lists some @i{defined names} relating to @i{character} @i{attributes} and @i{character} @i{predicates}. @format @group @noindent @w{ alpha-char-p char-not-equal char> } @w{ alphanumericp char-not-greaterp char>= } @w{ both-case-p char-not-lessp digit-char-p } @w{ char-code-limit char/= graphic-char-p } @w{ char-equal char< lower-case-p } @w{ char-greaterp char<= standard-char-p } @w{ char-lessp char= upper-case-p } @noindent @w{ Figure 13--1: Character defined names -- 1 } @end group @end format Figure 13--2 lists some @i{character} construction and conversion @i{defined names}. @format @group @noindent @w{ char-code char-name code-char } @w{ char-downcase char-upcase digit-char } @w{ char-int character name-char } @noindent @w{ Figure 13--2: Character defined names -- 2} @end group @end format @node Introduction to Scripts and Repertoires, Character Attributes, Introduction to Characters, Character Concepts @subsection Introduction to Scripts and Repertoires @menu * Character Scripts:: * Character Repertoires:: @end menu @node Character Scripts, Character Repertoires, Introduction to Scripts and Repertoires, Introduction to Scripts and Repertoires @subsubsection Character Scripts A @i{script} is one of possibly several sets that form an @i{exhaustive partition} of the type @b{character}. The number of such sets and boundaries between them is @i{implementation-defined}. @r{Common Lisp} does not require these sets to be @i{types}, but an @i{implementation} is permitted to define such @i{types} as an extension. Since no @i{character} from one @i{script} can ever be a member of another @i{script}, it is generally more useful to speak about @i{character} @i{repertoires}. Although the term ``@i{script}'' is chosen for definitional compatibility with ISO terminology, no @i{conforming implementation} is required to use any particular @i{scripts} standardized by ISO or by any other standards organization. Whether and how the @i{script} or @i{scripts} used by any given @i{implementation} are named is @i{implementation-dependent}. @node Character Repertoires, , Character Scripts, Introduction to Scripts and Repertoires @subsubsection Character Repertoires A @i{repertoire} @IGindex repertoire is a @i{type specifier} for a @i{subtype} of @i{type} @b{character}. This term is generally used when describing a collection of @i{characters} independent of their coding. @i{Characters} in @i{repertoires} are only identified by name, by @i{glyph}, or by character description. A @i{repertoire} can contain @i{characters} from several @i{scripts}, and a @i{character} can appear in more than one @i{repertoire}. For some examples of @i{repertoires}, see the coded character standards ISO 8859/1, ISO 8859/2, and ISO 6937/2. Note, however, that although the term ``@i{repertoire}'' is chosen for definitional compatibility with ISO terminology, no @i{conforming implementation} is required to use @i{repertoires} standardized by ISO or any other standards organization. @node Character Attributes, Character Categories, Introduction to Scripts and Repertoires, Character Concepts @subsection Character Attributes @i{Characters} have only one @i{standardized} @i{attribute}: a @i{code}. A @i{character}'s @i{code} is a non-negative @i{integer}. This @i{code} is composed from a character @i{script} and a character label in an @i{implementation-dependent} way. See the @i{functions} @b{char-code} and @b{code-char}. Additional, @i{implementation-defined} @i{attributes} of @i{characters} are also permitted so that, for example, two @i{characters} with the same @i{code} may differ in some other, @i{implementation-defined} way. For any @i{implementation-defined} @i{attribute} there is a distinguished value called the @i{null} @IGindex null value for that @i{attribute}. A @i{character} for which each @i{implementation-defined} @i{attribute} has the null value for that @i{attribute} is called a @i{simple} @i{character}. If the @i{implementation} has no @i{implementation-defined} @i{attributes}, then all @i{characters} are @i{simple} @i{characters}. @node Character Categories, Identity of Characters, Character Attributes, Character Concepts @subsection Character Categories There are several (overlapping) categories of @i{characters} that have no formally associated @i{type} but that are nevertheless useful to name. They include @i{graphic} @i{characters}, @i{alphabetic}_1 @i{characters}, @i{characters} with @i{case} (@i{uppercase} and @i{lowercase} @i{characters}), @i{numeric} @i{characters}, @i{alphanumeric} @i{characters}, and @i{digits} (in a given @i{radix}). For each @i{implementation-defined} @i{attribute} of a @i{character}, the documentation for that @i{implementation} must specify whether @i{characters} that differ only in that @i{attribute} are permitted to differ in whether are not they are members of one of the aforementioned categories. Note that these terms are defined independently of any special syntax which might have been enabled in the @i{current readtable}. @menu * Graphic Characters:: * Alphabetic Characters:: * Characters With Case:: * Uppercase Characters:: * Lowercase Characters:: * Corresponding Characters in the Other Case:: * Case of Implementation-Defined Characters:: * Numeric Characters:: * Alphanumeric Characters:: * Digits in a Radix:: @end menu @node Graphic Characters, Alphabetic Characters, Character Categories, Character Categories @subsubsection Graphic Characters @i{Characters} that are classified as @i{graphic} @IGindex graphic , or displayable, are each associated with a glyph, a visual representation of the @i{character}. A @i{graphic} @i{character} is one that has a standard textual representation as a single @i{glyph}, such as @t{A} or @t{*} or @t{=}. @i{Space}, which effectively has a blank @i{glyph}, is defined to be a @i{graphic}. Of the @i{standard characters}, @i{newline} is @i{non-graphic} and all others are @i{graphic}; see @ref{Standard Characters}. @i{Characters} that are not @i{graphic} are called @i{non-graphic} @IGindex non-graphic . @i{Non-graphic} @i{characters} are sometimes informally called ``formatting characters'' or ``control characters.'' @t{#\Backspace}, @t{#\Tab}, @t{#\Rubout}, @t{#\Linefeed}, @t{#\Return}, and @t{#\Page}, if they are supported by the @i{implementation}, are @i{non-graphic}. @node Alphabetic Characters, Characters With Case, Graphic Characters, Character Categories @subsubsection Alphabetic Characters The @i{alphabetic}_1 @i{characters} are a subset of the @i{graphic} @i{characters}. Of the @i{standard characters}, only these are the @i{alphabetic}_1 @i{characters}: @t{A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @t{a b c d e f g h i j k l m n o p q r s t u v w x y z} Any @i{implementation-defined} @i{character} that has @i{case} must be @i{alphabetic}_1. For each @i{implementation-defined} @i{graphic} @i{character} that has no @i{case}, it is @i{implementation-defined} whether that @i{character} is @i{alphabetic}_1. @node Characters With Case, Uppercase Characters, Alphabetic Characters, Character Categories @subsubsection Characters With Case The @i{characters} with @i{case} are a subset of the @i{alphabetic}_1 @i{characters}. A @i{character} with @i{case} has the property of being either @i{uppercase} or @i{lowercase}. Every @i{character} with @i{case} is in one-to-one correspondence with some other @i{character} with the opposite @i{case}. @node Uppercase Characters, Lowercase Characters, Characters With Case, Character Categories @subsubsection Uppercase Characters An uppercase @i{character} is one that has a corresponding @i{lowercase} @i{character} that is @i{different} (and can be obtained using @b{char-downcase}). Of the @i{standard characters}, only these are @i{uppercase} @i{characters}: @t{A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @node Lowercase Characters, Corresponding Characters in the Other Case, Uppercase Characters, Character Categories @subsubsection Lowercase Characters A lowercase @i{character} is one that has a corresponding @i{uppercase} @i{character} that is @i{different} (and can be obtained using @b{char-upcase}). Of the @i{standard characters}, only these are @i{lowercase} @i{characters}: @t{a b c d e f g h i j k l m n o p q r s t u v w x y z} @node Corresponding Characters in the Other Case, Case of Implementation-Defined Characters, Lowercase Characters, Character Categories @subsubsection Corresponding Characters in the Other Case The @i{uppercase} @i{standard characters} @t{A} through @t{Z} mentioned above respectively correspond to the @i{lowercase} @i{standard characters} @t{a} through @t{z} mentioned above. For example, the @i{uppercase} @i{character} @t{E} corresponds to the @i{lowercase} @i{character} @t{e}, and vice versa. @node Case of Implementation-Defined Characters, Numeric Characters, Corresponding Characters in the Other Case, Character Categories @subsubsection Case of Implementation-Defined Characters An @i{implementation} may define that other @i{implementation-defined} @i{graphic} @i{characters} have @i{case}. Such definitions must always be done in pairs---one @i{uppercase} @i{character} in one-to-one @i{correspondence} with one @i{lowercase} @i{character}. @node Numeric Characters, Alphanumeric Characters, Case of Implementation-Defined Characters, Character Categories @subsubsection Numeric Characters The @i{numeric} @i{characters} are a subset of the @i{graphic} @i{characters}. Of the @i{standard characters}, only these are @i{numeric} @i{characters}: @t{0 1 2 3 4 5 6 7 8 9} For each @i{implementation-defined} @i{graphic} @i{character} that has no @i{case}, the @i{implementation} must define whether or not it is a @i{numeric} @i{character}. @node Alphanumeric Characters, Digits in a Radix, Numeric Characters, Character Categories @subsubsection Alphanumeric Characters The set of @i{alphanumeric} @i{characters} is the union of the set of @i{alphabetic}_1 @i{characters} and the set of @i{numeric} @i{characters}. @node Digits in a Radix, , Alphanumeric Characters, Character Categories @subsubsection Digits in a Radix What qualifies as a @i{digit} depends on the @i{radix} (an @i{integer} between @t{2} and @t{36}, inclusive). The potential @i{digits} are: @t{0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} Their respective weights are @t{0}, @t{1}, @t{2}, ... @t{35}. In any given radix n, only the first n potential @i{digits} are considered to be @i{digits}. For example, the digits in radix @t{2} are @t{0} and @t{1}, the digits in radix @t{10} are @t{0} through @t{9}, and the digits in radix @t{16} are @t{0} through @t{F}. @i{Case} is not significant in @i{digits}; for example, in radix @t{16}, both @t{F} and @t{f} are @i{digits} with weight @t{15}. @node Identity of Characters, Ordering of Characters, Character Categories, Character Concepts @subsection Identity of Characters Two @i{characters} that are @b{eql}, @b{char=}, or @b{char-equal} are not necessarily @b{eq}. @node Ordering of Characters, Character Names, Identity of Characters, Character Concepts @subsection Ordering of Characters The total ordering on @i{characters} is guaranteed to have the following properties: @table @asis @item @t{*} If two @i{characters} have the same @i{implementation-defined} @i{attributes}, then their ordering by @b{char<} is consistent with the numerical ordering by the predicate @b{<} on their code @i{attributes}. @item @t{*} If two @i{characters} differ in any @i{attribute}, then they are not @b{char=}. [Reviewer Note by Barmar: I wonder if we should say that the ordering may be dependent on the @i{implementation-defined} @i{attributes}.] @item @t{*} The total ordering is not necessarily the same as the total ordering on the @i{integers} produced by applying @b{char-int} to the @i{characters}. @item @t{*} While @i{alphabetic}_1 @i{standard characters} of a given @i{case} must obey a partial ordering, they need not be contiguous; it is permissible for @i{uppercase} and @i{lowercase} @i{characters} to be interleaved. Thus @t{(char<= #\a x #\z)} is not a valid way of determining whether or not @t{x} is a @i{lowercase} @i{character}. @end table Of the @i{standard characters}, those which are @i{alphanumeric} obey the following partial ordering: @example A, char<=, char>=, @subheading char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, @subheading char-not-lessp @flushright @i{[Function]} @end flushright @code{@r{char=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{@r{char/=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{@r{char<}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{@r{char>}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{@r{char<=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{@r{char>=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-not-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-not-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @code{char-not-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{character}---a @i{character}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: These predicates compare @i{characters}. @b{char=} returns @i{true} if all @i{characters} are the @i{same}; otherwise, it returns @i{false}. If two @i{characters} differ in any @i{implementation-defined} @i{attributes}, then they are not @b{char=}. @b{char/=} returns @i{true} if all @i{characters} are different; otherwise, it returns @i{false}. @b{char<} returns @i{true} if the @i{characters} are monotonically increasing; otherwise, it returns @i{false}. If two @i{characters} have @i{identical} @i{implementation-defined} @i{attributes}, then their ordering by @b{char<} is consistent with the numerical ordering by the predicate @t{<} on their @i{codes}. @b{char>} returns @i{true} if the @i{characters} are monotonically decreasing; otherwise, it returns @i{false}. If two @i{characters} have @i{identical} @i{implementation-defined} @i{attributes}, then their ordering by @b{char>} is consistent with the numerical ordering by the predicate @t{>} on their @i{codes}. @b{char<=} returns @i{true} if the @i{characters} are monotonically nondecreasing; otherwise, it returns @i{false}. If two @i{characters} have @i{identical} @i{implementation-defined} @i{attributes}, then their ordering by @b{char<=} is consistent with the numerical ordering by the predicate @t{<=} on their @i{codes}. @b{char>=} returns @i{true} if the @i{characters} are monotonically nonincreasing; otherwise, it returns @i{false}. If two @i{characters} have @i{identical} @i{implementation-defined} @i{attributes}, then their ordering by @b{char>=} is consistent with the numerical ordering by the predicate @t{>=} on their @i{codes}. @b{char-equal}, @b{char-not-equal}, @b{char-lessp}, @b{char-greaterp}, @b{char-not-greaterp}, and @b{char-not-lessp} are similar to @b{char=}, @b{char/=}, @b{char<}, @b{char>}, @b{char<=}, @b{char>=}, respectively, except that they ignore differences in @i{case} and might have an @i{implementation-defined} behavior for @i{non-simple} @i{characters}. For example, an @i{implementation} might define that @b{char-equal}, @i{etc.} ignore certain @i{implementation-defined} @i{attributes}. The effect, if any, of each @i{implementation-defined} @i{attribute} upon these functions must be specified as part of the definition of that @i{attribute}. @subsubheading Examples:: @example (char= #\d #\d) @result{} @i{true} (char= #\A #\a) @result{} @i{false} (char= #\d #\x) @result{} @i{false} (char= #\d #\D) @result{} @i{false} (char/= #\d #\d) @result{} @i{false} (char/= #\d #\x) @result{} @i{true} (char/= #\d #\D) @result{} @i{true} (char= #\d #\d #\d #\d) @result{} @i{true} (char/= #\d #\d #\d #\d) @result{} @i{false} (char= #\d #\d #\x #\d) @result{} @i{false} (char/= #\d #\d #\x #\d) @result{} @i{false} (char= #\d #\y #\x #\c) @result{} @i{false} (char/= #\d #\y #\x #\c) @result{} @i{true} (char= #\d #\c #\d) @result{} @i{false} (char/= #\d #\c #\d) @result{} @i{false} (char< #\d #\x) @result{} @i{true} (char<= #\d #\x) @result{} @i{true} (char< #\d #\d) @result{} @i{false} (char<= #\d #\d) @result{} @i{true} (char< #\a #\e #\y #\z) @result{} @i{true} (char<= #\a #\e #\y #\z) @result{} @i{true} (char< #\a #\e #\e #\y) @result{} @i{false} (char<= #\a #\e #\e #\y) @result{} @i{true} (char> #\e #\d) @result{} @i{true} (char>= #\e #\d) @result{} @i{true} (char> #\d #\c #\b #\a) @result{} @i{true} (char>= #\d #\c #\b #\a) @result{} @i{true} (char> #\d #\d #\c #\a) @result{} @i{false} (char>= #\d #\d #\c #\a) @result{} @i{true} (char> #\e #\d #\b #\c #\a) @result{} @i{false} (char>= #\e #\d #\b #\c #\a) @result{} @i{false} (char> #\z #\A) @result{} @i{implementation-dependent} (char> #\Z #\a) @result{} @i{implementation-dependent} (char-equal #\A #\a) @result{} @i{true} (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp) @result{} (#\A #\a #\b #\B #\c #\C) (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char<) @result{} (#\A #\B #\C #\a #\b #\c) ;Implementation A @result{} (#\a #\b #\c #\A #\B #\C) ;Implementation B @result{} (#\a #\A #\b #\B #\c #\C) ;Implementation C @result{} (#\A #\a #\B #\b #\C #\c) ;Implementation D @result{} (#\A #\B #\a #\b #\C #\c) ;Implementation E @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{program-error} if at least one @i{character} is not supplied. @subsubheading See Also:: @ref{Character Syntax}, @ref{Documentation of Implementation-Defined Scripts} @subsubheading Notes:: If characters differ in their @i{code} @i{attribute} or any @i{implementation-defined} @i{attribute}, they are considered to be different by @b{char=}. There is no requirement that @t{(eq c1 c2)} be true merely because @t{(char= c1 c2)} is @i{true}. While @b{eq} can distinguish two @i{characters} that @b{char=} does not, it is distinguishing them not as @i{characters}, but in some sense on the basis of a lower level implementation characteristic. If @t{(eq c1 c2)} is @i{true}, then @t{(char= c1 c2)} is also true. @b{eql} and @b{equal} compare @i{characters} in the same way that @b{char=} does. The manner in which @i{case} is used by @b{char-equal}, @b{char-not-equal}, @b{char-lessp}, @b{char-greaterp}, @b{char-not-greaterp}, and @b{char-not-lessp} implies an ordering for @i{standard characters} such that @t{A=a}, @t{B=b}, and so on, up to @t{Z=z}, and furthermore either @t{9 and <@i{Space}> have the respective names @t{"Newline"} and @t{"Space"}. The @i{semi-standard} @i{characters} <@i{Tab}>, <@i{Page}>, <@i{Rubout}>, <@i{Linefeed}>, <@i{Return}>, and <@i{Backspace}> (if they are supported by the @i{implementation}) have the respective names @t{"Tab"}, @t{"Page"}, @t{"Rubout"}, @t{"Linefeed"}, @t{"Return"}, and @t{"Backspace"} (in the indicated case, even though name lookup by ``@t{#\}'' and by the @i{function} @b{name-char} is not case sensitive). @subsubheading Examples:: @example (char-name #\ ) @result{} "Space" (char-name #\Space) @result{} "Space" (char-name #\Page) @result{} "Page" (char-name #\a) @result{} NIL @i{OR}@result{} "LOWERCASE-a" @i{OR}@result{} "Small-A" @i{OR}@result{} "LA01" (char-name #\A) @result{} NIL @i{OR}@result{} "UPPERCASE-A" @i{OR}@result{} "Capital-A" @i{OR}@result{} "LA02" ;; Even though its CHAR-NAME can vary, #\A prints as #\A (prin1-to-string (read-from-string (format nil "#\\~A" (or (char-name #\A) "A")))) @result{} "#\\A" @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{character} is not a @i{character}. @subsubheading See Also:: @ref{name-char} , @ref{Printing Characters} @subsubheading Notes:: @i{Non-graphic} @i{characters} having @i{names} are written by the @i{Lisp printer} as ``@t{#\}'' followed by the their @i{name}; see @ref{Printing Characters}. @node name-char, , char-name, Characters Dictionary @subsection name-char [Function] @code{name-char} @i{name} @result{} @i{char-p} @subsubheading Arguments and Values:: @i{name}---a @i{string designator}. @i{char-p}---a @i{character} or @b{nil}. @subsubheading Description:: Returns the @i{character} @i{object} whose @i{name} is @i{name} (as determined by @b{string-equal}---@i{i.e.}, lookup is not case sensitive). If such a @i{character} does not exist, @b{nil} is returned. @subsubheading Examples:: @example (name-char 'space) @result{} #\Space (name-char "space") @result{} #\Space (name-char "Space") @result{} #\Space (let ((x (char-name #\a))) (or (not x) (eql (name-char x) #\a))) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{name} is not a @i{string designator}. @subsubheading See Also:: @ref{char-name} @c end of including dict-characters @c %**end of chapter gcl-2.6.14/info/gcl-tk.pdf0000644000175000017500000141142214360276512013607 0ustar cammcamm%PDF-1.5 % 5 0 obj <> stream xE? 0w?ō^җ歊 ġ(NAFj;8~a/&2['% PaE_n}Uhjs6yu=6#$VqQ#B㌶T@> stream xY[~P-`1p)xFa+VR<9HZ;@bsf̹|ŇE/Y zۿEGe\&BkmIXl.7?]HH%F#JWD djҶUiR)\}eex^һjq뮕=XQ/W7nz,x]{5 fXJ8㙺woݶZ[Ij$;_Las,&KY].])EgR]JH\ytGrY$vSD,} )#è HT|X^ϣ~W9rnQ9'oй p6)$/KG|,Lvb*̑3:|n:X $?TU~廹RirCGX`g>wKxBq6P*!<\:ʓQېUI%Y]iT{$'iSԟu (*:_.]MX}dmAO;Akfr]+y 4nĚ+ l1&*` n!0\m_m,꾦(D@ȃ۷z+D7-'B Ym4btڈ77[Sk^r4u1V7rql$R۝N``m88$K9WLRXqwNE ήۢ0UӤ@]%*C Rd^tE#+O5 vC*/=,%4T@J9dy'$ T0I-7;ĨٟI H%nn0:;5lcg%,g ^>z`kqV~IR*'DHNn|TOvyLs/+~ HXƧJsϥo g*pW`e8]LKO{f [/_m =JE(mc-uqRL le;;ҩD=Bf  e3Ԩ* C+1EsjSpP y>u*+O`ǚ`n#du.[)iIFMc1$ҧ5ԝ Q h8_}'_~KzP*!B5z ēc65J_6Ȇ#(3xr'?,D3 endstream endobj 17 0 obj <> stream xڽZێ }W4b5)ndEY#rfZkԑ;ҥGsٗhTbX!6r?Iśa'\no72H-rm/zΥHű:Wa•E&lU[E_Wp:|D-p]/WdG=M5~n[~g;+ŝ][n7I7ݎl=,<臮ZǛ+ة^[RJG&Q}U޹opjpapYԢU g]W$򕛭Z$7mJ\E#^DEk=6ב+SP-O~ፐű1r!YG,n\;T\1YwFb_h~ -7POcjtgĥj=:MHKUIt&8Uq<14,_ oxv߀p&_3!d7b $՚T _8f;"QXV|IC4ϩ8&8ӨL"|UC(y \%S5\*悎it$Ν{3Jf*#v6>h uM?8# 3)t:z8jÒUHHy,,t솋FrdRCX0m\ ' \3Nf0Bm rnp%[kQ!e)9fP^#iC cjrfɛ32]+3YJOs3\\R!SzLv|KhΡ˂00s&&ԅo*դ/,0 j" PHmX@v&gY*u_hNdcw^L>cRd]PG!vοNPQ+C*wjJJ=S0ԁ4ı#TAb>c YaM)(Kòqall1ޭ R4j`i/izk.+4*TrA`-7I%GƁ{Fo^t+h7κ'vx3%B;b LeWsՁ[cW;"^Ӝolap]q OScUT jh狣v.t|G:4Hu@ ~K`*"!.hwo &pc$ La^hq5cBgcr3O f)NX gH8sgvr ` FϮ@qC߬V>8zVl[L֌*%zdthB 17jrzb3zq1r ~fKaud9V^BS3u8 nKWS&wZ$rʧdEG.K0Fjk.g\US*e(f,\Jq:9Og3ĆʦǵKw̶Ex*WzɄAƣ ^4d U ەy%ĺzjl^ }Tꌁ|+|MzJd-Bq^*.SʚTXܷ'_3"ڵ1@4q(, -ތđڄaT7~C >ʴ]:5y ׀xg~keg8 3Gڲ2FּrcC{ 3 O91Qngy&Eua.aM-@TlMAe_ _ }2(H-s[VwlT*.8&ɣh%t> XbbY +a"仺qŰ>BW.zQn^RJIu<61?;>M,vFSN=$3 T _B?2  endstream endobj 20 0 obj <> stream xڝX[ܶ~Hƈ-&5Z3Z#m$7_s.^95]@$<<<|EvhW^v~w* (WNe;ef_s0~0f߻EݟwV'al a,Tŵ{#]Gwa)~Sv>]{'WJ&:0ͮ,΃hWqheeZBeO0]b 6@ȯGW#ehxK<O83 {zOW(ELV-*&U]t8A=ziи-c,4uB١Cmpsl~ebm<_g&(}l[W`3:ű,sp~lSU0K~2*Lu*ffhQcۉ2R Gvl7cZ#K!o Ayq0]XËkSaW>&퉻A`u d R-kF(X>9'5HsВƥ>tV':Da`_X!|.@hIbq&PEb籨+QBڛPZb&uLYgoM4+5>[EцQp : Hx@#Da ~ # vA!Ӏit$Uܶ#.Kᤦ=Cx{:RuMcAŽ`Ka<:x23 BthWQ1r>,!4)L3XٲV6/s5_zHnER_=085ϙkb.#ф's5~ԲA #Ϲ~K&%4#~c?b^8pK*IIeY6ϐ=#O[Ε#W6!y <`ˇ嫦aiCHdϮ/o͗g'|MB&x{KPJ:_^?4aZN cH<DTj`[55TuW\WAde̿LRsa>"bBLFʌT.m2ܺGOLg+L-tn*)8o3!,!۟xL2,L5Cgˆ 6+ #Ew ?A4O<7 83SMunbG8h=$LJ1$otEiBXW"tp$s&l}_,*t -S{j։%qxy?͑B:|WK\r#ƂvF]'A0(^+]{m2jbzמ\YWN:zYs=+Wg\k/K7p0A$xUܢ;>a;XRypWSJ;رQ6 d 0.ܹTy_k XNY~@- }f8Ty+<c8^$Ry5!e#r/ܠH䠤kK5O B\ğs02_tFl|x&*1瓃G3//pC)Ï~ō4MP$ug)*Ȧt3 _n߄ܺ4Q]IyLzdN1X}# QȉP,?PLy$"|ZK񗡍*ddiY|.߽11";㇛еqj+M3cCҶn6V> stream xYݏ_a\N<"%jˡ zȵm!٢mdEgCʒݾ.@Z3Ù|h"Z-Rb{\yx/ea-ֻEQ2@,^ugKg5U+mWnJdLEle5-W"A[YP]>T=(;ƺ {<* ͰkGzO?fhsY͒'=G#KX42l+X0`f\.HCKgDZZ譲:mwZ!)-MeNYxNLoG "_-KXv;o-2h[kUۦm2u]u:9N$h"aQйgVǮ}(Kxj-0 vC׷pnIՀ;/!giݘ̘Y(Si)@@P8iJMt'} ]Ÿn"MEU]W0c0Ix1єA|m'2|3UQ*XAU;thz-$Le{\$(ר]' TIaYJou}Z GzBk #m=d  7*Bh ;[}a5ALݑaMn^H/xyч\b*Ĺt# eިџ_p ,( )1qTahv =ixXJa.:ܱ Z$E{@ӓ_C]91-DTlDZkZd<#9睠 p"Gˏ״65.3r89@l4;H$g$ͭa+OmKTe״=",nit:KL9le3tci6{NX](5e]*LĬPzUoM-D<>砬-￘ĩO7ly!K6C7ZƦZY=_T~ҕh׃fqfQ\ZjQ~2 SI(h6S[Cpߒ3npy4!u?vUg z+3u{,{rGz>44Bmo:,tw®c+f?4`3OG%wī"&ijm_?p˖vZ3>:e9 lĞY`8SƐ;84O9`._1z:suh̕aj?3KZ4dKDvUnr> stream xڽYێ}W4j`Z)6؋a#ad?,=-ZeoOݨƚb+HYd9UDOm2 Ѧ@&!Y<1fI 8yr 6b@ QCvB4\ C{aޕM{"J͇dƞVWHJx{4[Nn А0| z Y,\nCOO@8% |#'a'FN^u=˶뜼7ⶮ H}(+ ;iA+'8!bʧ? @QIWc @?7&|~;Z=7$9djy#+)˅ie(&l_{YabY2tl4K$;+(SJt0!HbC Nqz%4H6/0QF&/v~9*w 0V b|KH c(/҉b]y $y&4լ*B U'X˂ʂ0Ծ"ܵ jjl]a_\j 6c 2?lM3Ď-X D͜#C8ҹS;P=8 Y,#'a KP鹶(εW{^SUbxp1'$셉r5 S2%A>[Iͅ+#L. NM311>fD/M"tt2;W fEEuJ<Jd&_;zƗ\<126Ա ٿ-\HJlT ^__ء?=CuxfT2?Ihx;")0'~GI$sgj߹r՟ӻ8/ZFEIl?^^SblY~Zc,e-c j,~N 9=S.@@ R6׏o0H(m:`PkJN "lJEkW&5c*m[uc'@Yjr`OMUp Nz Zұx- C+,xE1L8i!*yy9yW96S;\;!Sħ/?v0P†8г2ES) (H1%ah]9IӗxD>h2=@}B&.(%1YXfG_+fy+s27a+g U9ֶ#ȑcͣr*(),FĒI=yu^ _P-lEV;wCgOPWi. l 栿n~U endstream endobj 30 0 obj <> stream xn=_!PE&f }l[=#Z_Z"ez&6>귕^WxUV?ެ>|4+2.~LM)֟o~^R.[_Zk?nW:Q6 /R:[L3=㺴ѡGߵ.%uq:꾮\}[׃`.uaGQđGɣnNKcGv׵"\˨vXT>O|tk$@x8v$kH8uZ^ݮjketJ/]&,: Iq-)Pt'p+|xl |i1pf8^jL}LXg NHƨel0{g!$΢k hSѷWgK{yz91A0;{w8ʑ}iUC5@U]&r eT-_ݽ Ϛr06eJpd"kx63ϴ6b:!Y2$U:rVщK]`b͏"}va'3Vi&WY3o8cRDiFW{ynɺ(Si_? biINW] Ϻø?`ͅIۃ$ą4Wi{YS ܑh yO~0W`Y2{u?vC-d?9oDqqb |Y]`K%%k5RBzH m@nM%86~aq#|IvLM ;G?sE*NK%Zxt$tPyjqepMhF?spâXemvF~QR6ܘLT W8fQwHy;rN4ӱ $2 ^" m$00XGq3b2ݡm.~ǧ$P!Cƃ:oaa2)œh\8F8HNCZ nܾN3SJ~pE@\X0I8 Z|$'xv I0_/&n7 W{2vJ(r1LR,PJ$r$4E2:7JL%Ζ*I_JgSJJUR}cVV(Jzኘ00 d1wI= U1 >X R{aTY0'M&,Ni"1*KҸ <ȀsDRU$yɚ~Y-^-^Yz[^ey~wUzsΊ"Oތ9br܍[H*qRB|8,Q}#LOR0{t!Jgmbuh$!0YN2cB%4(s,-2)8FX^6*0x+Ã$a0cLE)_1$'"[PoA Np$ǬͬiM.~KTo^xBԀp7%c =\;%& )5=77ppiAZmkZrSa =KjXPY}OPujN$_:iHPGzXQ(ZbIrOTK^*JS[SQo; iur!a`A'3æC6Y1c0^m*ͳy3 tJG >,ŨRc7Vx&.5*rf䃊 R A w'͓U'0m9'$ 3=.f!l&iU,bI#tr#6?퉖#uaLdKnf 6AqR oܸz:6h.:8QW^h4p0opʋ{h`"UЧ6VI3cf0 vaBv9iA\~᷑oE 9:clCXݵ\ܞ J瞣R)wEvE 2\ۦ, 3[> stream xڽZYܸ~ϯh8جژ֊#`I agjδ0jWRxS"%-؇ 7Ib꫃aMo)O?n{7,` 7Lą7wG}L !"fRF1tXE̎}^+DƼ,IKy}ٵuװ2zӛ[*~wۻ[~N&1Wrci.gQ{x¢pw`o9g!LW􃡽+9HLOU_kscϖ1D́$O}5TmC h5vp_sJUԛ5}2ñLi˲=?ڕpzjU-^f꿿 ߂ q]SPKpt|ќ8bu 8omu!0]w#PI5L*bV plOt^D3KotiЄw:;ZwGDfGNPD\.پ;[g$y磱z5e*Wxٜ8ʴ?mZwj~6LmNΑ4AHһtM#O[Ady,̗0c>o{k`5)3e,9U֤J1| oФ `ACT~C_8:@IB(xB:Әyx&,,piyS ߗ[@8E"FY)g(\ ; QqDmcQ-Y9ɸYc鋝;'g 6S R# vjV3_3Hvl:O yo0*,eacpDNi7&`D "0@Ll:r1WPJg wpg=,üL U!G\S4W!aӎdpʂg*15zch[͏;.x̥w9%L6水٤%WI'xL3 3DgV9+Z1e46ug)5,1uuhH" d ?sy֮`0E7~<1,6; eitiJC/_gв`$'dbʇ#ta:`DPMsPR1˔39 &Ʈ3\9X8P" t@82ų3lJѥ4("Je`vO~'5p~Pݑ<6Vl%dgq80wIs/oޗq\XʯY8NнrU?kֻ?Qjtl~wjX:7owՕ}TqR_r16&v,i&JvS5m)4ơ[G#f-U@4<ulGV`wpE wN N̡$9!L`87 P;R]fm2r@2[bUc5#Nr2 Uӧ1J1h3җD#YEuM)dANҁL$YBǬ^yXLl;Xΰ+b;yNal9ݗUEMDF#4Zc k4TұL6jmE3>Ad"i]aщI&>4%bܕr#Yd*i4;i0P{8$F#Hp )JG|LSeC̤$'lPd Iik6 LR%87#DAl"V_m;g զ\v6B+AM<O2 ̮$#"B$@!0]GyH5=Vv{ 1[c|%tO:Wo BDBW`d@)BAl YeNJ6nN endstream endobj 36 0 obj <> stream xڽZYo~ϯ)ACO~s#   5bC*lD*-uWQHm÷8*fjk7wzVY~˴}u}lF$'jknMwzqh+jh8Ǣ,Ҳ(zC}cϘTJ+s2>1~+fd~2C[iTc+~{@̪TcRTHKR YfɟL=( |f&j9ogx) oR:(TjXr6\8|ޮi= 9F si2kwS~wep"Ԧ2ɵY`zN}MƕI6deQ+#Ϟd8*͵7,wC3Dt?M`JZ0vcDeJmщ2BZT.OOU;<SS쾞 =yy}qWoۏl ՗cC KIV$gK7UcMǻA0n,uX0g;apbO׆=1T0~~ڃ BqJw-L2WCzݓ,Nɏ͇NDrU( (V@π^pip9iOZѪ#s0RS[oс:ܱ9sNq.уS'W"/;p|&8F]p=Ww}߷uqW__/1'4Ϸ8&+ {\Y*J}w be]ߊ i:@Xs'XR=֟*#MWC1VG3EۉօƄ#nҐ Ɏ"w,Fv1E^bx/KdID9ndi9QO Nꝃ;!AK$x0Nk֢֝qS$:wpF:I]k #M%^ .K}Ju14FTn yc$p5"I"cx!\QC鄱ɷiP_v4!בHEJv,WX9 ҿWSy&Y,wVwv }35xd e}DQ߯!lv}59 :xtpqcEj#׉X!DKxM-d}XTF3쩹`Aqu|jOg(;;nWL+2˃'I`ݱbqձ¼>!']xڊ動m2QydAgX96gm*J(4   n+vC$D*<ah;\-ffsYƭPdtV*]1wU0 i n/Ep[a5q1CK5~:ѱPI~+AS|@E 9 PSEq _Wn BR+ΧY@ X .Ȼ`$8H- RvPkuvwBHZ(B'Da0vdҮwbaAr;/ˀM'Rѓ$6}ɲԫɒ-Yԁ${HV\EOp\ *! í+I  KS^_"/T\;oUa.}e.J=HaHn>) y/WOb$6}AkTP.p`Ez2y_y3b08|{GqC@$ ij>jM_qQ{.Lok%0jI衞[Bs8JP4A iH).=^UM;b/Y 矛  MhI iާhZZ:'R;8TJzx*Ɨ@/ym>'ܐQ֑??8i}â^R9ƑٮvOuN$%gsM|\n=6S ߨrO >4]*ņ"s-;җ:N$h{ \f?OGK_h^Z]&x->x7( w}wJ놊T_VN8m0]﮿ ct BP셖#Z \WY&{˫OZ?no endstream endobj 39 0 obj <> stream xڽXKo6h#J$Emw2 C6c$2A@w˶`ÎVJV<c(zN'wy pzt'Q$]LFy(}eY$cTmٔ]{R#2p-~7r'ȔIxU!TR Ia%ѡm0<(bYLÚZ:)G|P>TEm?HGǪ?&]OC=<#_JK?FȬ_W=&mhv}jX$rb3!:ou|_zK$#o|5+\P#=QTfŰB)fBjID Lj}_ϸ?G{@<QOOlz ئk֧H)CJ!RJ)k3 UoM' 𛆋2jځVA΀BNtl_5%Ѹ͌aHY i _ZŦ ) yS"$=u0",$ RF-~eX޺x&c -}\+81%߇g/$S^#:El*c6`Wܲ4Hf~/[FUI@'8i?7+&vlͱ*7#X_zG(`sJ! |oh)ďt)0G]=[-HH%8aOz9\q }F}w6.n5ޱi|z/i½xn$|ۓ7Ze`I{lqZ3ғb0 lXpnD*t~OOC5 $ވJHj8R{R$E"F1<}@ H"$Vd=%IL0u3Da|FڕM\"=oIɗ7ň0`  l[v"5"E"e{nVbd{pY&>.QSځǫěɹ,RdpuH8G2 "S64 \Oq5֓:4LXC؟/ꕪ|t+p7;nO#=7ݰ'!I [$m[cg&h*͡*Z6$AHJG gDsxoROeˑCRCvH8?ɉq(t(v՞~>e,`sp+|wSFMۋ2Yt#Ʉ*F- Ff՝V{HP-* ܈/gz7E{Kw^3#\HLM'X}Jdq@ntR3./03SW,[ɣt+(Iȟg ::{{pt *8Oau\+2,5ѡ+٧:j,PKEc$^A`~ _X}T3찺MN,DLO'o,m &gxT ;IX T(&493T@sNGd0!X]h2؆lF Z}!i$@#OyraHY5t*&0_6ztdCzuYpQ1W"*|z endstream endobj 42 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 45 0 obj <> stream xڽX[oD~WX+sU QPgwe^lo9seכVx̹~2$8r_%_$ Q8M-]b ՛۫v%"3K1e 0sdqAfuvekyQ_#o컮…Bp„(G+ ds@-2JieV~-+oBái#1A_ؓ҉PջDzz`.#21LnqZv_ʭ#Js8<ԻU;܉8`45$^ec)Y$\D!,$C\v>/wM9+m˝@鶮:-5jѷn?#J *@H˺S!u [J: .^Q-uqQE`7m<i+1Ffpױi\[[hǞrNNN1O K_lʶ}>R#\*hqMHb(Bқ{[dDzi,2`jh@Զ"*]2@)T xeJ#()gkm֖y7 B]k $%O[QD??=ʙ|C'`ĢXJq`CU:9BUn#86c0dAD#J.,w rwIۖ%#y.+Ӆ vNj^!wzKrwk^ 6ԫ{GUW+DD ig^p6)ol' ,Ώͼכٹ ps!c~p+ݘJ-x F +-\Hu[Ek+gG=l¡w=p| U_5m>-sL1 l,sZ(&et<ɔYfʠՕBCi75drV~éGٜ^~_j3Hf8)d_NpnSBacHd:gՃ% ENuPj\_R-ؙQB `BnQMk7W IQ._CsOы=͔<^0VGXkԻ,zyxŽ {˺ǡ V i+VJW0R*40]_Ƨ",b3>HVSe;*cG>d^U4h1\-(GP,}4Hy !? d/l`~ m pen]vqNiZ]&*|^^ګ> stream xڭYIWr1Xe .ىSSC& Q"5R~}X84%4%6zyV\U *3Ow~1++{ۯtVyvYוZ>8[Xk?NŰaʵmE嶺+;8<ڕ]Ֆ;{vMsåZ7{VZ՟3OUrܚGeU?MUw>kWuxE넸ki8uxG>m[3e>T 6*j7{>79Pݖx8R?bz k=ϕrUIT+oFMW3ު:fN3WSO8H@g 6X} ˭yamRC׉[q*Mr.8}J~ͷ xyى3^9ODULᧂz,Akb~gNP2HY.ΐfVL F V5^xie,$_QfW 9vcӢK ^hzKu@ |hcU,A sS+S[K[wr-YKlT0+lكT(zgd;B]r * Nxp[!-gt+{37A*+D2d 9¡ l9 ןp\ >pd5X& olfR*sFW{  ,>WmC; b Pݥ~A јւ1Iѿ4x&O /!|`p Tz/0?(.]) ֛)r@$;_tl_\:y<5:ӱpʓke``X~Grz&2t0>~|~׼BTM131Whß0ڿ С=(Ƹ\'b]JbpOH i D?bt4|FM1Jq:+I*|S yw)[Iz9O ånʮ|qҜMo#M\[%mM==xLz{THS v<E9eO+(a]S(|Ɛ#g=؜pu"‚7_8wЙ$c=Z(%w@X~՜|c~p[7 eD1lsrr!8˭8R޺8ոxکQ!ӹ2bbgʷL,$ cn=~H/:Y7xYb44)6kK:eIs3QQ!֮R+ԂƷ>9C4QT"K"(Kfu:YPkFxK]\cef+ ~i eܰ\6(m5US4wR5 0 œ&3n )HVϓG)썢 "f?Ufr%H  endstream endobj 52 0 obj <> stream xڵ]o6}Bd VE ml݆C !jѶY$9ixG}8ʐ> x߼/^Co{n7a6;OLަSo:"_^J)SYM߭l~R]D&\;ʂT(zZÇh("0s(;0L$:֠ BT'`hM֙Pvv|m`LG\ 5Eٝ|%X{^ugдye gtW)Ad1H\7=JyX Pv}y`EݴGdɷMմXę{B"=aa,}{/4FH'k̮g0;Y"_Om@~]3drs$ϻVI'z(Z1~GN!=hgpG_d)L A+dɿVz!b4ȢŤ °Aߑ4O^<ҭ(pqmx(nklnKp@|z857ߦ6x2+~zWgtlpkE*X(yMRNd]r+klBJY }?ڪpG ?1 0s쒗Qn;"}gȧa!."0l ȞHZ@I1 t0.?W)mYpw^-i"TpQzW#t˯N Eƍt=sڏun8g  @[p{(9Fu_6E^Du+r Cu5Ujk_+̆4m BE29wN o*(ʞ" °$ģ , lcNq+ b'$zTѺdezo{Fowʯ ~dTxCb.aA=*q4):$Xm]O%1bкi}YpID,xlA r;<&+/CDї='+ آS76<ɌUFgT]3F=/]=jT7R)ݨlg tߚqcݯ0 BD7E)Wچ1}j0մeɨ`+JdHŶgI: 8J {۩lG_"@KWd[ØAH _V%s'emd G#qG!($fNl+z }"u\(^Y)(aFd-N1"NҀAն !rmiwޑ\/- <׃~f:Xġ@Mb e`i!yaVԺ薢>BHQ "HG j'҇dEa(='vSHhGfcT…KLctkRUhO ØXpħN]b WS|SX\2emraΜ- %v 6BhNK*r7ljzۂѿfgw(Sʽ" |{osM+I8X(gkBs,o# 㶅Y?l1وoOedI:"8!ET?.HInW8MT4GӷX_,c)7r|;5mѢnc)VI!_۲Xufxx xj2[rPf!Tn4c@ąbLvr~Zt*j9y*Nf;WŏMk܌Ѐ 7 8қv>BwPZ/+G[_w endstream endobj 55 0 obj <> stream xڥn_1o;x}(IآHBƒ#ɱ{..3& s7n&)7o߫ErssHZonɤ]JvnT% E)V}_y kV曝,Ӛo#bRJ@ qjvŸVmT&,wU{%}]?m̍=R6k~~rgnnMk. {?n̪Nj0.`+p./D@hvZB7vg"kZ$sWǯm4Qlw@ Su%fdHD#0 &XHg$%#m.MDA|uMa mͭoX}0L10QMtC@r<9Ά=Wb W1qzd1EvCw_bOlק>_S :n8aUqFo|ہ7'8o[aK⭄/Mg*w 4duy)<}3pk;Qƀ懾0c1hK|v&ˈ˪!BˆCmAY &_ 0l [ V-OVA#=85lPM>v!1P]GZB,{nkw(TtH1L2Q&{ Wb N4x2~$t("vG[jZAÛ?7OCs1W\ZE&`ᦫjUo)wo==,9fJ3|3>,4)XZ?ǿ%-z ްaO>G3_Tomlh܌+ӢbPn!eXFh:t]HxբvҹY!p硣*3;c 0< NR{<93qGoM )hy`vdgGMN3;:D7](Z=4JW^k]T1Vh|M 1OB5VjiSVU;msZ1?poNCJ5<=N62쫶BHr.0tK,.A%] M4"!Zf/tB$1ų|12cᔼ?M?m^,'4Xac^n$|j9@H JaM!k,+QUe$Cq%'ƎG!-: q{q^[rBi1*0,jKcUlxW3ŊTcdΪ)L :P[S"F6"ʼY.rJeyv)B gT)J~a.vƻk% tZO4Tݥ.gS5j?r3=G er>\n5* /}Tp ŕȘlP<eMd6)&&X⏞eI"JvK"`ː3ypOKI:=!{l1W_HZ&\~MN[W?=~6͑&|PlyUbL$l#%pdԥ4بMxq~R >0-ԢWQ'f*3b4&֧p2 'l'O ` 2 ƛre>+yؔ`O\^mPjQs\nVKQJ"RA&|D1NҵC /v)KM9g }5b%Jl:ɕKƂ2&9V^q'ZV)e"6:\$Κ2C ɗ+q^\ 靪l;o1e"Tu$ڡ`kI4xZ''=0ٌ~ T !`]"@ݔe֠Qu)"Wn)%N&[2, PE'e FnE۫r4|z>Cn_ 5R$ee}@cMۡ B;G NmBwy_%n* \ ==AhG/f~xc 0\IgYFA뒎q'&W5ZD0MQ~_?NO ɴ,gVCX^J'B{/fӭz~*Dy*]EMVţ}f珍8Y5H{28T6Rd:}@u*u0qKu  AUs{^.^"y"Fok]؅q(㥺GjW}EDl!\䃫 r23>Sń TC2Ⱦad}u|p)Mj8?Qŋ8UšVkY{&u˥O@u-Z8.•S~_^m1e1+=Fctbq0*@@sK9WX= ĤH"+ Wk~fwLV@;"K΋ҸB + yD qvW<".q פ6WCWt(_W,;Y> stream xڽYKW20T A6 E9sP۴[$yz&>U,Rdzz&3hX$++_ǟĊKzگ]qJeWOe{΃)e&TzwpCWJp3s/ Ozr6d+/z^6`7ㅗ &^6lm>6cvOAdǺ^iQ;9Oz[ nG_ps&gwO!R)Rd ʛMWم QCr.%iuӻ.RwCdRI)iZ CkzHy.gcld)Zqo5m\PFjBy/>Q(=w)tB 5>Ḥ5S$eO)mYcthɳʳwC[&WLjl` a.?T]vJ0qp&GYCpI_5u@ 90LSA5N'N'#|Ny\ςXSF!+Sd7ۖ Ս#~KۛAoA#'lө]4g9EIz3/6X=w"$Hڨ {s+-Og܊ ՞ Ek̷Oɥ1Y.x <7@0߉e;( @UXħKzíw.\pm>ڰb^}(G,{H:L(.p$/1;FIZ;hҮZz ՈK,ė r m/@⦉&XVK^)#N@:|Tz`\\qDR˥Rj({dֱ%E4eyu 8_1B a-')IG8Rr3Ulk 3sj&| ?2π`^,X>Guט ט?\cę˕ =+6v& }Iѐ~/gvHc޺Xy~ Lp*-}'E令K9 M>hwlbmʔ Ž7bmÙI;0_+,v'Jx^0= !@~ͳuq1ۨTBcm֔X4pC/&1itOn9c zR6_ƨ1-'_b#ISނ(a(QC䙋2: p""Z C 0lBy+lZ`G |5*Y6{ck/4h#56 fGf0%kf^`{6]K@{hyaV1&1&x L؎t>iVƦ(a^_Wo-'B<ϙT])ʦv=62 BWēCoigųe:w]Oj J'kP ׅf1k؝w _ !pR\d^.6ZO8t^[o\@7XBRԈJzTswy#ۖbG4 -},F4 a*C;y E@K2#uiU>/Bi$0Yӆơ &n3ڴM.1IջS>1yA `ޚoO! ]{sp eS*>fKdg[WOSw)I% McZ2 L-</~718E|TtAx9Ie0cj =ŗC&}vS~gsőЋ/_ZWey endstream endobj 61 0 obj <> stream xڽXݏ_!%Z̈CѴ >AgiYcɻ;LlPpș$? d'o~PDU2'L)mk*݇]Ia#nN|hil(fȀc*QJCwLysE:\KLDI;v7VoOc*'eQ74gǷRk[@9kQxiywQ2Ow0ucXvSE:%BY,T.֎ HlZ ןP~y)^3aB5g3𦩜-pýncomThEzϓ08SԉR¹2A\ƌXS<}7=bw,0\ ge=5BeJ?xgčJ " Ҽ6(0ї!4sn5'm,Wj06 "_a> EM l$/ԦRLx,ZG@;0HtZyuZysZu6ܞnh!%RhQ?E+:W0;. J[\!M@XA򭪈̺ycR! L%.pxMh(K& ǘpTYq!2FQ2~v솎q`3 {aнhd%{c%͗ iK1ƥkE6<*Tq9*O@u= ?<76=w&1ubLȰ *v%9#GZkLkb嫩Tmg}&#Vs5u&SѳNOnFc\<4u+%T(zI_MCX](}Aϡί+h?.`ZNF> ,L>-@`.X>/a W80J̦pę,ŁQplJ '*˥lrq9b erAͪfs}ХRM~\OgJ1M1t~εPb́13s)VA'HKWY!$܂B[ys)AE T:_Y&C6+'mߣ-.jUDAJH %{qQ籯;޴&uÏEoS(SǃkgW8Y1jn:OWxzK< *6<yG=$B-|O4XHGy;t?) ]ͯ@X9C0]:֖N ,g!jUYa> stream xڽXoF_NmH6+UGS }gvv1u,ٙٙ|,ǀA"/ C&x~&,x< dJM.|ϏVk)e(^JmUЯo~ wF'dȵgZ\Y!oʼ+AtߏC6ۭ'LKiwP]3=5 Ah‹+M {Km V;#ۮ2naW`.]ȋN2p1o;q0I;9+uyx-D-AiƤN8x Ȕӱ_P1vWUc%aJHTKI޵QnD$M7œe{z8@IUC`4@,`!D'qx^?,a%(!o%ÅL) yz9÷KzB"i R1ˮc@:B9ϓWHMY&A.ut"&GH$4E0( =MdYx,4>5MQRU+߉ڛ\1k\q'uُ\y PZ ΔD XdU֟W  ֯S^;)0P@UA2+O I۶[TreO[ uu ?c>t"&H !hn .(JrO/BՔU6J."jv(l  ?XbMŶk PHyo|?8V CWrW~%r+u-4fGl6jDYD0ECt )/ =Q/6ּX4!:wpa!m &8R=_fધGT!H@+XTFp#:1I^HVN=X,l \{A8ʰ.@E1գ&ei ʫ cS22o0Sʙ][tP+rbQ`Zr^n#9epI̅Ѡa1} qإgzdM=3s_˙yBd,;JTCF^֦+<{jjsh|jqXa f#m4ҬF19'Z^8[4Zp)؇r >L* 9NJxp)zyr^H4#" TL/^43?1=~kFB_xtt 4rq7McٞR)0=x;K%.N@咹ꗦg\YiFί/^LЫO?q zrA 8˞"-Gb_n .:sbVq.#ӎDizFsYʙm7nPCRwcJMw,x'_ RV3_xdKhkĆp N!–V]t6tW[O$@ƻ}琚X A-vSp|ZkL\=߆~3XU?2iI> stream xڭXKW |J{d3. 5C:v+-K_\FI_L2#'n[#uY f ?;LJS<̲,WVP>o2O 8,KGG-)7uztp]S&@ S[{ta].Ix]ڡZOwڈ,1؞|פr[/u>pZm[ ꋳe;[@@|W:ftkŁk( 8엁 *$s3;6cpA+ O>#;ܩ?հX<Ɠ݅P@3 #?PI16^(a%WSҜ"|赃%BnݗHQ5{GgG‚={?m/m=@2 ;i\P틳! 5|fMQ0{e#q 塋ߐIc5h9za9!9$ XLf Fadje93"22g!X^ (EE0/Ekj,dN#s] ~i-4HojW%r3 `kQԇrR =gp56O>c{$f@:.wMI ;p%j͊{gi=!zI AO2S+\\f+{Hzlt.Z;_Ζ`@=ywY!2_!}Հ c%E{Rfj͚3.g!xWCz0=)2]8g~y , 3+@Zh=C|0^RF4rX{r{0='& % X61Dv|ObJݣ/^=Lڙy/@ޏr񁄚mw〺%S@1f E6@MЋ BWHbZVLl\\Sj&QRאNI6B/!nEy E|2,1^"12+cg/i0{ҡSV;{>]17;Ձh}Rߪ/5gh< 4tymLwX endstream endobj 70 0 obj <> stream xYK۸Wr UeaA`:SzT|@KcԒH@Cy-)FV?*|U WbsfsWw+nV\2nO4z#z7zJ ɹM( WmƊ?߾;zt-|XoDՇn-t7nOn|f5lC^>"皈?u+UX^9Ї dǪlCWP/P]X ɺKgi݋Bo^X3QJ%Ut)~M;z*WN^^07 isF" V-3qy|ĉ+!c-K)iWrp*:'̦f۲Ed[eQƃ(.0EIprۂ{ɹz!u|8)rR͹ Y͒v34Ư\= Τi\șK^`sΙEv9%$6`1 ڝOE6?)3VepB>TB5ktVy#%DoIJJ0q8UF1ndy@jz/VSB\ZCVl@Qf)8j OjG_85W&I;%G|2Ң\b䙊?{$u.Ѷ´]*]FhKjF`MkCBW2^$aN!c_4JWD\ԬZmɷ$JߋkuTQ ~[TF( /We7K/qL?N(}KJ6G6.CJ: td;;yyǮ;Æ/nշG3j&z``O]FO?ɺWs='HL퀪!$`Qehz0n|;u0v;FJ~t/w)/u(x>381y$ya\œ+7wQR0-KVL ^( Hc=[/@D, endstream endobj 73 0 obj <> stream xڽX[o6~߯2Y"u) Mb݀K ,61ItE^y(J.hA)s | h? lU- hD(j,1y!WqNIl2pZoH9(w\?{R"h.eaNsBc|SMXK Gw-N⇩U%;J}],X=R=a/, e$ edwj?""% $fȻ"*3gTԔp$6eQ˟PAU['ld54$| ˢ]Qy 3> 'sDHkX/;YާE[U>n Zlf#lܵzo XJsj=Kh~!hXE#gM$f:'M/,Cgt鱻4N^当BD9Kgpf\=NAju#Fd8^nN'A(oe5''$JF9a)Sw3l&IU 8r.Τ<{QHa;F)g^fs<{#\Dȱ x c^ “_~Y1͂>N207 e,$`a, 7nXrݖrHXMAT*5rﴥ= ck5Iwc㕬1pEz hEߴ(!>/Q*Glp,CݛJ"2w[ Pb$36G }yOT4Jx~Qpr| @Y[K|L2| Qa'V;h?G6NuuPCԵ8zT'`E!P(:=>+y}=|vA>Sw%vc=sY,)1 J5J_> stream xڭYY6~_aee`"u 6 L&X$L΃Zmbm#~[釠 EEë/+OUuZ|CRQXDZV*_)&_msoFkįcLm2 qeD䱢Nuh`tc0W涮˺z<;XZaT,x(xXo<_[u5+ɺfǃc״N]:|Qh;P _ooֹlջavlPǐXAOouda \04} b4ckȇ"$Q-<ٟLuF$H,΄}[n$NDz~Zf$B;(4ٕsa 0R|[-UA^X4ez*W5AߜqLYoy?}VshlsX934cS>|? u} my> D3PG8any>c_Nk iZ3]LClWr=-H -a-n1$w8ZScrmR5?#F 74`" I@N% )j-yXaDŽc9'8¯B%߃i~ 8$AL<8p!Itf!#]"c|FҌL!VH&C[etƦ &sBT(|M{x>oajǟٶr|FuIƧ\D8c>4k0T`eQɔbq5 eCn}O+?WPB]6Ԯ-ZEFkpiE.h>Q$s7 ?K1I'q|;RSLG x),ni6. tLgKJ< >Y!}‡X6ljؖ\'ZC 燄'yO0C>=<(gcII6A"p³>Ԍea^t0:aR/T+Zc=ޘd9P|un>̈/̀Ādl88'<ĪBS!n* 1u/pՕ6 EBb<)~ K;``BթY ]$#)XIDv+F8nk endstream endobj 79 0 obj <> stream xڝ]۸¸@H$<]w@ECEﲑ%W;_$[I35$Kw /j&qTK]ʔ柑R=y4Ϋ6#~ZGnj-tEwSejhqY&{QkG3_u4qc;D"QN.NQtfw )lĽGn̘GL8q\|R:K;ӌ:K#U=;"u2S p?寙[q3^d\O Sn_G'd}~HBkȝ&$tx(;`22ly DŠ"rED[lcj;X"q 4耈ͻZb#~h4 +C]Ǡ/,y8=qB &umZPa e/=NgџCLS~L%\+:g4KK/XTҾai'Y%kP߉TDӖ2jv64x =r\٦(ɼp2~nuɔ W3Kn.xc˜zr}zM Yf-ҢE˹zЗbŒYcC<"[OVS}3w)$zu׉/ [;gǕQqudǚAtVŪ(eN<; H"Tʘ4/9~R2L(+Tz5Ά[P!y&2d9\{1*xA %黴'_\de (:0IH4 c:OH|bnﯼ(2Ў D oʉ6iݥ}3ۆY{ m/n&2׌ms(#lnd#= ҹyIeBnr;u$B9ybq`Zsh;Ma~KjDޙMz(Lлx;uTSŕb D͓%ǪvJb endstream endobj 82 0 obj <> stream xڵYKW620J$EIsl`r"rHAcӶYԃԫn@U,mlbK6xl$("<7II(ty8;\^{mwJHѿn6Z&WD.MLYN"O46OO49/IflD'D.e/Vfe+vc>Us±+Q몾jjhU=~+Mt.rOUX/= @oIW.3iҒG9Qq8ѝyv' [9c/h=^Zi,*t~ö! h*s8B} ?Ζ=^JO]=Q-1k0e9i%?^D _Զ9gSlxxDa`t$˞@0oOdȹ]lR>/gb>jJ$yjAw9;?ڠ;˃ٰ6tT' l?ENW)#W^,&T_^#L-$EVJ*x흪g^?L`k g:d$0|xlԹs#CW&,*jK"D;6G3OQ fteZчuA?tfA l #R(X ܊3k{*J+RVZN J0hxukȂ566X1j WSٟװA.tze}yuM$](T*f2x?!~As%l+ >=dh'duMZg o]6TbHd8ꑍFzȑ2ydMq"+;7W.`N%FE`@-CP5m >K)  qR[:2RJ"RsS)0iJ]yAۧU~`ԹU1 \@HDձ6IcFq1:pOI}O?y0bOz*M8Z_`W:ƀZ:?IP<_ # [CI<&AFJaP)d:LEŠC#vdjyCoiSwzN @[ژbQlׂXzOB+<Fo/2-=AN/%?̃}KϠKOI G[54YXvj-BKB7 @Y`*{zD_Jo?q|z+`jSoKwǻ}rL@ӕdO(ZFzz.݂536߻;lGpT15qmtWTZI~\c^OH`z&(bv^z'ߐ^j0*'DM"ħϗ"W>whU 9fyM.)0 y99}024od)9*M/.Yj̓-7Ȍ]b 8ց>~H#ޭ,GEZ%CvyW}yZHqvH~ ܦ#mfe2yv˔ʷMK^FK]Ɣ 5"ϓYx򀵛F%5 yD}(?inJ|yTh  `{U 11zD(+Nc[Nld")3yY1= \: uBf<Ҧt;BSlVp8::ƿEJYC2<|kgXά)mKp$ ((*G/|.SQzb?C#LO-#kC> 90ҹ%] iZhL)]tn>sj >-8Rp7A~/d:JʆrT8>.LuI 3CPٷ^no#B/hL>'!8"MgD+ F`JnA>\Od tVۉ3яcpc;76D#KG qۊrVțU9"^83j< s0{ܵ.-K F!lW&._7X'& uo6/RIԎ!_/ITBc;_G%[+ aR!TBX:- F8DòoJT~][<;v`-ŹC[pނY'AooƅlӬ7ŤsF]sԒKXZH&w1w(]$C^ ?eᧉL &yZGy>;V:F{K{b~ M5 բz{"_o\N}/?5CL 8,rs}r649KYK8zL]͛J8ڿzq- j_IkS^T"4`9I~v>Rلb! =ьCUPG9Op/'z8яǐo@/i.$_6 @d endstream endobj 85 0 obj <> stream xZKW{R#c d7Ct[ƶ>7ͱU[m]669h \NκlY-El·*2KRCeW'jmvsޗhksP~O /8lxa TKsܽYä#kEZZ%Fd#}w(iUjwːݶ Cm40v LPRSp.ܸ=ܡ">A!Gn%;R- }&Fkp5d0 6.eζD4-x-B-S{ b又ۅ, ?zv 2aC_=Ü6`;҄d;*J7c eGs!e2WQC ~mCQQ%~/MXXDYs`7,qO= z^܆@4BB֡i}W 'l@<>!tz"ޚSf6 e6?I-PnȻ.K4x789%J^sĕ,hzUt(3Ávʩל-p\Z8*> * Jyp> +0upy.?N.fs>~1u59o}$/~iw$2f75/&͉$nFz4|;ͳʜ4>RQyVtی*ά~~AZj;~)2y䍛_sHb)?QVc_Vc؜[jrc)")HSK`4ܠ9i|"QAMX-%j|_hN-]tJP}'94#p[?P !CN/K|_:UFV!ci2;'V4/ n bLNk|/x'wUG/}$Uns` 3Lyo42 {"್V6݂`8ײkuTL8c5 JMŝ̾]Wѹ́\SY 0+z0~8q9ebNh܃fsn;쑪OE7GH &oTPe"4v,StAL '|OUO'4〮>ԾNhMZ G^}}IQ`u7`;B}ĬMu)[ ӄ;uN= |5ED$K}*mYfU`wV@3 ؤ@ud M.4I&އ]EYG#_HBlkmq)`\Bg#! -&/l!p];,2*$|za#6&5̤D'c$oԋ[- Z%=mqa^b߈Y/7iА[IӄREAC6WKl!o\ܖH.3n"HBG/7xbo6Ǽ>S*2~?Kl|2kTtX/}t Ô7&fTěPwU 3 TuEMгUwOZxv;V$+yh eCA`ㆡAJjцL^oi<?~ãp܅9 r8&W?vwp e峬-(N0۝IM~r)dTOPWIZ7&_r*\͓wooILH,׏M_rjG p``j\|̦kοTEеpDzΐ*۽jHY_w~> stream x˒͜MH.gcv|!D$3O7TNyģw7c%VU"7ZmޯQDfQ&VەHW"3o:@Y+bg[))B\Rε],LrcL[48UAYS7Zyky-t{Mc܎!tHC Uق^ zO~7i|~zO576 ݉1IE: H@8hk?} VU{jDc p Max}Tlkא5=v0}=>:@&Oyx82ye.z& 0')ZRN)3/։(b'qwe[י]W %HlL &$׸i\U5"ΎxDz*>$YS5/5(Һsʡh6j}^ՠO*x,( +FU+o12*2xO2B C,I0/rx^>E3^_LhGg 4h½jD$%{F,Kdw2 F&P~6H=rMoDдaAD.ʺr3B] 0Mg+ aG=9c]e H鄻b%@T:U";YE'sFR8ҳTI]c(lGKdH?? sUvB Ig**|E>ۻU82uIHu| WTXG **Ux^!* _UB>Z9 BѯO+i1Ik2c~8/fROTpb 44 å=f2%!M6`+:0V@(D@5/{.ue~ !i.UiPK'#2}#Pcu}zuZ9hMS  ǡt 4 kV*0yFwQry,I$( B>zƂ*` '?ܯXAp*Be(aqpqX_d,T4OeTx;]7Y_dAXы0 WO8:#[?-N\}^c!^#WBL kO\!-{2,XJ>W0jE+jnQyY>Sr#yX'0\= bG55Zv5 %z iOlyLZCi kE&w!s4U y{~q:K6v)F8dTr3e).' RB$@u[a_A.}i_'4\)/yqKiu).W xe R*+Wש!@ m: 7 y YwX}.7tnBZu׫XkT4y=:_}9m׀H.F+2_yuX~y_ ^E6Ƶ囍=ŏ+pa)4b*[Dh賣 ~C!Ԟ]+sЫ>1 {HOFZ141K*8%=q|KDJ(/`l29fnί^H v\YGq#9q}c`솇rRcfpiS罼`1q%eY/!n/ztS'U|1XL7)8&jj3)U"Y"B%cMeW)4vkw91ܻ]Htjhyldžo;p|_g,&|I+2ŧ{>Qٓ'2'UzbI$PsMg!Slᣲ -}ͱY, }țm²O={-]>%# Tp}7)w=C׷{1i+tFrVMfV*L&d D3#sI!vI_^2oP]^;*-a{j̩4H2ŻD{}I: [{իiOk7b8'6E,.~vL9싯 ߟ hnhDRI%} ]ϾP0{lK;IEk/5]͵Df Ii)C&5| WDR/НlN7X1xY@wP敡"Xlvvt BMȫjOqkԽ|+`"s, >ÒB9[2jwD9?~G9#WESb)GD7NS Wc^ŽuUOlΗi~ endstream endobj 91 0 obj <> stream xڵZKWfn8'fb[UAD{.XJ%ϯ{vߍHOmf~[QRTF2asVwƔJcx8|Z!aΖ"(#Nnö -6>Skj4mm$N!'ma䙋hԄ.ϬڎZ -᩺ n7ۏۦ=4z #>U}~ NiWMe&VX|r[ }}|$~h,}w?>*! ?YpFұ_ I ԝq U-MDcrӭA|kح P&>A*{E*D<%g5*涯Ǘ告u>?VaqUvni=|<Ωm5>515N Sá>cv ?"hX=ڿ[9?[!`(v\&/i-[X2%%s*dzqͼɪ"Jk)DY$Mxwt.R~U:(a嫆䅷ogE?D*4fI=;r>jEe3 YT؜ ք@!͍1lEDZ $~z;S;_$ƬѲ3ʋ|L}wƃءZ#I슜jꪆrT#UG| {w4D=ڪF{ C#E.]NZnH!be-eɤ@/mxyI0-d8f`?Im^H9w8\f$ƯD)lv:oxmN/*/0yXl/k~;\Rrr#E%JTPJ|]P y#?*!㦩mFcO'j2C#U\ː~KGLw&x]*}umI_G00~Cd.V{ȟVK"'r0+^3a-{V^ 1FM;=hY AZ@z7 UZ|@ O|gj:v R oR< #=*b9o۵5p\L-G1^>c|d.˥qyЗ c1ٜ70 iBeM\O.{J®ߦ]9_tñmT^3\Ps&< ) a!&Sgh$wEk0ϴpi(d #%xJ3EtȞu_}Y֠.ܝ@MMQ%],ir{ D{07ې̖$SV.Ij!0^N'rbH1Cs҆_MI xNTvE?1P Yb]ص |ohKFh W\wJ@!>9eT7,Tsd> Zd9?`[D kP3V.—<( @O_4Bt[L%TtH _S= 4a[ᅰHA/7(/aaEۏ)5:MTBSͧ/ Koߵt޹"NOa4H.h_QZAL0u6zQ !W9;`@K,Iίp?ᲊA|z':|~[M7Buڶ]wƂB3h*S|>שD= bFh/ꍸ fW\pװFr`=NP-^r-NV2bpR,vi*0FQ19)I/ni蔴3p 0B RI$#Zr*h/ @R{)=1rkUZӣW[xaFsw9G 0Zc CoUM t #>IRӜ9"TrBJ1Lo8{ ҅JB)_N 3eRMZ`cl'4w}uieɫ̬ }I1pНJf ۱8] š%4OA/kV׺?::G8h^rz_Y~maN(7Wiʐh4J:3 >5-',sJتͣ?Vx 40/lOc,nAjkĪ+JVU\aﻱtz,@CvmL Ձ xW.&H=c)Յ[Vm.3u29SQ:+xi9a2VmxL@ރMaSh.u$4/+:,ҳ`9PL5ӑ9}zJ->"pejl_+Kn|Z)MOf?W~Pۢ endstream endobj 94 0 obj <> stream xڵZo_@#Enzab3Z[Irw[N[ j4$|fo gYz/~Y1Y ] cU jm]&Vk!t_7Y(쩉=ɈG?r֮Pqz\fYv SjMBim]Uo×m략+|ڂiw,txe|嚔:{t<4]$94%ܲ(-U{ܕޯH@ yӡنv5kv xXgųVtaܭ@-{MuʊlW9 Nd7mtOM~Iwa3\AW5KjNn9g |n~9뇛o xX/~|2CaU*ђ ܜP6hiLPmOH@)6>zDWzu-t;5fE,tn e/ܚ7 o)W#v# }vu"3 9E]&`vhM`<ơF WW[(ȊR=O \8Va"cj raaE(̨@dhOwt^`.0jsl M i}`j&_羊4;+Q&'] N{Un.U5},F)\ީQ߳rёCC琶ku%~,:dۗ]T#Pe7RFTјt⥑ ߐ^,vSL׌Lc.:ziޜ^Q1hn%:߆i[JPm4&h1omy4cb_m:ż*$-T76M(p% "GUvvA [ ,A*F&i̷ WEq]}6loКR}gW ujK5JzgkdlcNIc,p$㓁Hj{һq\^^A޿5Dywx#g`n0P$ |t<hD'BWtD䣆8"L#JAތ^MG!17VILI!)2业LK\A EG4^_,e=o>-Lk}vz%iQ~G,knaؗ$W>/'s}* 60ё?PS7@Sgrv' 7KT[&)8:ԇ.tAXrC$nO/W 77cX'?T0BiE d^dr.Dy,<"3`QG694r^`%\z؎pH&Bzdx[)P7%rP} ^D=q%UR / cG;W+קP/Z%hZ+R!^˽m:17r$kD> stream xَ=_aeX+^ydILF@:j%$OS*ʒ͞I)XW?*?zYZfX=WX X=b߮T)ҼpwR*y}i]wkiέ7:IcݵU&}ן*\q pr컆NGG;׺~vqyLכBÑV`IOվkOstgD8SUpr>7H~tkɑ %`ӅF93 9oRZv^h9zɒ~Eùz{i>)h81q!]4 1f&&؉H3Q<)$ ?vNmOwr #]=)>y5p%o öjOsx\syf .'j(?l(&~Kܧ<0◟0 ƴ, /kC&21B`/D7὇R\8 L[y|v7j\*xTs\۠ν6\%@X/}Kb$`z7\4Ţ_ ܆rFW:T>h/GTGBj(e#sBѣ&tg6JI }M}~x%JfdYKbEᵏ@e!$(嬏ygEöI3A*La>gȒڹkxPq[h(dn1a+( m!PN!r&ȁ &ʃ'hoQ1HYPpc1X?FK2U`MtQӌUo V8.\e~3s82 ]ݼ󑚏 ׎t_gT0%ewX]]ō_ŲC~IyLxQo=LI~| 8w4Y»WاxǀQ H%k?:O)PBUKiQܼIq@ۭHOpfWEq VRTOouKL'[]OޑŸfɺTL. 7ٳmO=Y~~bb/dGcD+BG} [v endstream endobj 100 0 obj <> stream xYK4+2lpfj=lekVez\nܘI;^~=!)vSJ#KGG:ӑm!'Vl/[V-d&B Eem}2Z'25$?f}0J ŷz2ՅکD) <ͶiKe+R(U.DI24NnT ¶eΒ6>KgɸGjjaul8dݚ߰Vqmw(~#ԝ{r3Ђl]NQ&#Ew2McSP;\TX?"dpRw+O} RBi}}ke%lXzwC m9M@!=wx؝Kpa:z|cJ}Sb)EmY )!ż7[gvFcm U1Յ([mJ^JFs1R^&v Nu,Se}</^{hGu^EQ&|aO&/d{L%ڣXԧN7YŬƄbn.0ÜJ9#3L4XUwNә".=Nz3Vتt.E(U!.mhNƓG$ʠ]hq(z5b0}."4i2:alћZd2; MhCtk![, sTfD ( Uq᫲0ϐV6&SVÍK5 s"9a`t#>z܇Ǹ/8e⇍\W8a_`0l;ӄtӌ4qC PXCKV0Es&{5QM.} iMW='qv<3]]%%8|YjRTegn[<(Z^zkAY>e nTHs!ܿA JV"A FǁW1\[-YunQI d T`+RBuJbQ@ANQkW+L:fH l ƲtvJBy6\̫.oNU9P}pN}j: 0Y+xLB!>~w@韅#]1Xg7b؏ĩ3EJ=cZˈ52\i.*0`ZK/Q8* ڂl?g3q;S#  4V;稊j;x8*i{!V­nz4N 6rvn4כb&p>wtwu;~[N5"~_̏`=xk c,"QgL51n.$Ɉ͠E; _]}.u&!bCT37Z*ϟ wa<Z2ݝBk,A,%vf5޶ݚo DQVmqI091zv˽_l]ᖐGl|SoĽLV[8_acB#Pl8r¼HsH"2vÕcCs,t92óVe"oO,rgxBDD3I$/^)^ n'_w endstream endobj 103 0 obj <> stream xڭZK8md ֈQRrXcN;{P,ڭ[JrO(QnA `JdVb?$OV+ERn%Pq}H%c "c(z8X7&7s[u*rxXK*|)b'pwe/EڌSrswWvtLR$0E+?Z/fqԍ&NH D],yd-UTQRf/mv곔&d CK_,駱O87жmxQ*?JZ[ܡV@y!g QlGM 2َ֎a'ge\7("t,UM8:]ϛjvolhwmCPEVTDJP)VJ(q cG$PR]@>C9&iNUuDIapVSдπ[Ixn ["voxĒX(:.rF*.YxM*ET^s1S̙en"Favh)u&/ (@wҳޫ^$ =AJ}<j0MKyʇc&Υ ǖ[Gzr'=O4qj^O}Hn˒h>3x޼2%v^ PV!b/^f 2ٲ]Q|j.c܆n*pXh_w1X&kp= ѧXTtU!ID&GC2 UvA:5%K<31:ܡW(e,.ěZ&}juՅk6oqXJo͢bX~ +8GmnrH'THH-H q[8 W{Rn+T XXYjpHd!4X5g1²9Krt"pi3A8* }(+60BxXʕ~R}'_ @IN6r <̢.C)uqa`voO4&Hㆱ Uq"g'&p\h|8̩jӔs }嚎+ LehjLsL)jˎM_%*}|S4jk )#| H &Q%\H4|q9SΊ/[Ls8WY+ qɅyx9bT̙jHMAdyXt\!)()%B[%HxZ}7%aΦe67 .!".#2ń0,n]@4ᾦj)$꼵U4N [TLz?MB~?tuv: _Ζfa& [HPeK*u ,Ӯޗ,8x_<kϤnԼSԧ1(LBsVu ̮{Fj$׵YY,ә ֱLU_x߸|/ z3T*o wo?|b:'$L) b1 "Zm V^ɭw W|RˆM?>3k,8ǀᇹו[o$DөOtpn#kgc]$8;5AcÑa-) BPwAc2Hm@a…F:vf patsEoAZ j]EE&Djk@ >Ԃ:j4:Y1)~eeE_ LB+jC8>ɻ3u*H|-}b2 .ӟ `fn]̱|7P3(? +|ۥ#8DžB|`h<P_]R endstream endobj 106 0 obj <> stream xYKW XM.=$fhB"gETuUSÉa,UU⏅ZHr>.~Y^()٨vBذz{ޝi2TreyXׅJNWF:`teMsۃT;pߏ( BH C<z_-emVϗS~Mw祮{2Jxʑ Ӿ fW[k-q[:Uۿg.0:MuiJt;߁]ޗGHa#Mn±CI(,dviH!aih^*|h9\vf73mOqsՠM p]E8@-KRvMP?`24p j!ԎBOV:HW#Qf$L4ً^褬nR ?AR(X8 4ȰI/8:vx206/b2,UҊ@o Y\uj0%_2O@t͆Acu٫QW aXZQUX{2pF~;ND֐8bbt/n3B*qmBK ͢}E"N??@г8>oGJ߳V R My͕Ana~(~p uf$׀Oʹq*QیwD` ŵ(Cbf)xJ?.ҏCk6 KPfVՀ,L?He DᲉ\L=GK"I# x/Ȯ5!;'SŃ9Q7͌+M pG1,71ett <|vD<HĤء{Z-L]\ 89UJ8&}Kp?8}E J)'ELݤD?WXP(ҟ) 1$he5R#]#l; Gj  3 MG"QH֑A4:*mi;$rt7\_N'yr&%9Dxi#%gzP !PIᖗSqX/ͯPp~ .685TJC0I2C8 al\SsC>J foܟBKLaNm:,gq6C"ϳsYC xme)>VX"E\-3vy]0S]P5FqLMJ!rN]jmF}mÞ#ZOhL8֯ϴ˸-ֹ[$^[D dO,\nqbQ6ځKpłinm !Y"=|I:)$Df:qЕyn\msˊ\6^ڽ%9X;~}0m3S 65$/Cܦ!]͎R32] $S?`h')/5=M]2!ԖF?V3֔GKkwusѧ}N ;eЅʊ$8Tnf)c}6KFSw2BkݔܽS!cON~C\)ij2Pd f(Xn|v$bG*|eh)@v{P|\kSBՆ!s/<rh@Eu@xNTlSK1ˊJBȨ|ƨJ 6ZgrE}5 i00~շ|6|v&^;-aI|S|gǑ1w|w߽wKnP.;wӰ>MwS݌n`Yc 9B@-\eyYO3M endstream endobj 109 0 obj <> stream xڕYKFmd ^zLA,fM=lAcWBdɑ%-O`rb?R?7r?y۟FLK{b#(M;7jmt)EV0;;urWY&9vA~gJQHGieO{I~}M>LN H7ԋEp+E2Xw퀿v5V#Iܰk~Cb&U_wׁGIzְ[*K'_0}TW-:ЮU2v~N+"_hg÷X{uy:l^/Yr-k*B߸ DP1k_Y fŅLixx='&MY2* %"Sύ6y}Fj]zYk'j3KED60O>xhWvj[_EA~OqCI 4k=s+YZ K* lŇpUKj]O Q%`pwGACEQ4j~*.45y[VL2˗a _V7+">F P T -CHTz0X[檧BeA6w?)<ہ4^wc)Sl7O~l:B=> Գ< XQy쳫$'!*B\lgFWT)4xx6w/ YXb fr {p{a)MqZ s:‚E9bzk2 kAwY$=Ԛ*m#_۟|jS\pPぞȠ2AפdWH(B0ЖrUWQPUEg)Pvdsx}9r=Ƅ?8/1XжZ==ʁ49\ S'\nz7`"{*//ه`J%1Df-™{I32z5,KL1Fe;oWT v!'}oBCVuyPA  ~۳Q[~Ԕ2WkT^/Q ޿C4̮`ktE5)hg!9^|]}) wxG2}wV`; $J& GGu[8wVi0/4(I&+V)?ި<̴D:CuGp-:XMA ECl.5Ůf\ts1c_O/}Zoe/nDXtX07< MH ,lTIMS_Om= +E<>9fǫ uw; 3 qCJvp6&WceBA'=[eri  c= ϗs}|h FpM* o@:u@݀sT: K5u2<0"رh%hL<"I@f~1(vŌo.V2YAx%K l<>fVЗXg׆MM5Z-23 T#9:S؂nj5ҸۏkAp 6B V܄q' OjXo0Fp W-OzeÔaRY2,М}pyIb> stream xڥYݏ_ᷓ(jP\"E4=yAgkm!Xۻ3lz@ "Gp7Z+bUHivGJؕPv;pc}YoR|XooP?ۿ \)7G5rb]2+#}Ƶ,om_1WeEiWsou.@+oh&:7uk@{<d64TcMe?=yDQ?<3!%%=mynmv-eBٖwt3W5c^Cw4nܾFAv?;*_7n$eY9E:Y}iN3{.pIE7(pgù; pN$UG|RY ӷ~ Osysk*қ٫hL`w&XfN$;᱿8sNE$-qÀc7k+= JRJ8(I'( ܉n Jy-TsPrvM?tXOB}됛&pa S=NN0IZu-f-HS[` ͫ0(YEvh Vp p.A~C3~IBqҳz]$!|F9% Ѯj7~ ~ѻX|/phl_gKHTq!l2"?;AXX9t޳d CX$rPi0T*c$;6JB4pʄ_ǀp3~~44XX__m8Lflyv۰Fj C+РN0f/frn a g8K$܌ C3/o)-x7zSõt1r\Y}:3[1co9d@ udB.t!2:͹;_f{ɐa*{hً]ȥroA%I˜!$Bmawi"!syesӠː!o zmmK4,=`U]:ϕˋA,]2*]j$+ H$.!bX_XՈUgN)䂩)!N'pu6P"e%Uqݗ}F>PqΧc#!XQ,Kw pu9< 1yݜ岌Mʡ̎0-4IiƢ 1=}[`ATj[]8'!`0x :NT ( 3,1\5ҬxLͳGI~N3͇ pr7p6OpwVdM&SMZ3=uF9`V/b@^u lPդb4cS/ADS |=%THvԋۊZΜ6 APYd*c !/ UlM=W 3Ϙqz[p7+Q{w<6E$WƼ'֛b]-0˥1H+ǔrVə5(gI=\zn3L LN`2yp2Eo;{ɥBNSyPtL« cS %Rq*qj bgj!1)aesur'v@ϞbJ]kg kaFm 4(zn}@^t~YV^¶ JTL EPOh ?ð0)9G0TP[˯n|?_R>nWTZ{JwGvNJi ;PX. e:|jWVݑ%BIf?SZ:`PS|NF7+A` VZDqP'D%V25SAE3]Jhϲ YU6xA .ng8+ymHjSOR;I4\~LtcW72nHKV\UC%:KUWP&4=FoTsm8hI'Y#u댓[|Uu8S2uIlh%ilKYò kdMӷWU*qE( ]f^M2MR=]4u;˱[}YcoȦ8pJ\|er^;o0|p1> 8oF^qKylUZ@F@5+ؚ 0yl%ˍ B]BYC 뿉"~DnᰄRd¢wq5jϙـj}zXWfRQئ᫅ĔE endstream endobj 115 0 obj <> stream xڥYݏ_!%Z̐ERR$iR\\>tzHۻ>3R. /*#? <۝LpVJdLLR6fE% ,wݦ(|NKqߨYܪt/^3e2ƹp+5s"$4ykP͈|:6ⷢv;/8`ZN͙B0Ï7,*'>,:;m6MX?={Eg'ݮL͞&>,;]YDH ~t4?o?2Lj4`Ι4 Q){NY-dckɄ64mS$PJKC I{ރa蟺}6ewwS?߀*@īƇwnϧGޡːx`ssi؇>ݕe^vt" J :[R95$E@8HHF~b?x~5ag+l,[+bDh*wS0[Tڃi#IYz}}X?ѻ_T_}8 >* iԋB:SØE%l0;ڎSEKRLǧcQ q\N_r@۱+LW̨"xsߍ@7$_$G(tkw|h +` g݁H~\"<ۄfQi@\М/SD  'Im{O yD)@{Np*큕Bs?)?`֙ mk=Q}GGa dtf\)` )FT]?O ùq.~iiFBdE 8ԤzNt$s=#gD~%%|'өG O!|μ`";}2|A.8"Ӭ, FiF6ҥk8iߒ*'/S G|^m<,j03!rpVöN pxZ єX uj Sc:Br8&K_0LLhevN*wm&D (B;>fhÜ9}zƹSP)\Ɂq7K  V?/A_&qjKDǥ@68ϥQ 6 @ޟΨ~SERqn :mR;eݩ aK.AV Q QR< )~]3K垨S d &T$H?TK_B MK~YbC#Uw+4IT.Vp~pē߹k#_OǗ᫡Sb`,9R*xҿ_SIQ2%BCtvqo8nuP0%'s;&[B &T"0Q{wJ UUf`8<ܽIV | ·t 3Hg|OMtT}(}}ZF8ʕħxc+c Ǽq{kΑ9_{7J|CPdjLJ/_j%ܜ9%N᧞=X$j: ev(#[Z}kQfJƠo^wQ+PfA-@[W.."бG!)aF+ݣbqy!ѱ+[8^"܃MA+(裨]poy㍧jN;k7uUPH0W%_\Zn[dwpt> stream xڕˎ-`!o0b 8#1K2IYv>Cl3zWii%W1UWoV?d,8VR\gݿwԻvQJEFk^~J'R1+Cȟ~V-7*\dR돱U>LJı$Ȩ`CjGgR(V$i%:ʨGmyKWΝcKXٵ:ѥ0yk쀩V.f{ ci逿*:='bIu=ܺϠ+_f%26ɽXxJoA;ŤQY#2.r4Y\ &*#1t)iSEݝ֑zIt(;9el3v8W 5˪2ZX{q׏Tx ĄoȌkd]LV1-YR LhD j~D''=-OfA!}%O;Yf ēCACēd=FÆfOopnoբ%z%:INJT 40鈹 BfBqb>FKk`~>ctբ!)Oji;+A%&]g@6xN)\_ l}\ i$XC +.=>lKeffd` J aQ 'ח^%*x )aa?. @Jh #uu g~]C $=+U`0xc#4cCŰ( g*=pyIZ1߽]Ή &<;Ԣv H>P 8 |(d '* 2+ LPJ *j[@D2Cx\eyp4e"lPUe+E:~? PwhՎ!$(؞[KZGf#U0CyxB!s-* -ѹT7>ߺx;Z EL2N;vX Y^k<#vdcpvjAzD$;+:vTifv@̶ӡ×][<]nK9[ޟF l>8:9Hutc|ܹl5إJCDNR3[UŖcp6N۷/8T`@A n4fPGޢoU%jөm/լ%5/jL\ 32$v>5<0QbHS!ťy@+u3XfR Pc.ngߞݝ6?( ii}ȅ4cR+zv`%&xԭmģأ {4|9&ܩة,2-Rl<,$:GųIF; IB#@( Cο F6CʰEF(Pۀ#X G^0ߕQB'fRiByg!2"OC㢛BxZ?/ "ѧ,}!qMmBt(SMbf8$[;ڰL^WTW^PbPP/%$%HaNXMUܠ 4^@ʟ=hqbyW=S}5D_$:lyvIrvSP;0PGב4Rc(NUEتa偛qVC  ߹&PO n-\U4U:dqp9q)w'LeseFpf2*BGָ~Fe ?%(=3mKdvo݇ï]gI.t}5ӌn@,%;Л}ښV}mb0VPPA904  Ƣք׬_-W68Qd7yc4jjJJO)`~HO`vEnO0x}/aC';7Z'5O^@ mYZB- &<{u{w` ؕP/}4z_ QM=#̇ |ќ|cbDq܅koP i*k"m]hW~_$a0/qhZUtː_/xN4BFXIz͜z&nMdW*ك$, ,Ž㮊{sQG 9Lf3!yD"mylxL-zҩ^Ms C _|8c0P[-kO<+ +B8*ehwe R,Ʀ+}SMZ&PTxWBomڵ^[[EQ{]`r)Û>:3v{Heoln!q91@ *3 t Rc2ߌqQ}K%V[e&fAT NP|:s\36$;bHAc" A"F 6> stream xڵ]obߢn~K{(4W.I@>ȻZ[VYwCJ.uv 6, ~_%vGJ+XߙcJl8(fhkqB;:72jޘg &kl dϻ5 P+U"Nǽۏ6>,4 b G44΃8N6nR*QOu ,:vssQLr-)9"{~l`چzZ8vȜRhl\;v<ϾY3;+=:)pOw:P e +. )GHɞzG&f%ByȞIlrC= Pu6UR,c4\3 -m{DM@SKuqppX(9 ͪbJ@ \.RIj &e6 -lҾ@ъHzE#x|%@/<7c;Y.% m!~XJΤ&0x5SHWAG$cZw<&;4pz#g4M4p$D}t%[6޻oӹn ,R ɺq4+sY%1eO,h3?@+B"ryrTG䜙ѤG Gnp#4?XXøc gnٝhWoQŒ`GF & z]`[ T~KjG$  !5Z :5ڨI Hq^%k: aXIvMsV tj `p:<\vN+F?F5=˩ >,գl<\|k#K,&p֓A6M5zAkAY5a&k B4 I3@dI(@ 4d  D|c"bZșS0Bѵ]5DA1ܥ"ؙ`V0`qSwSto7хh2)$%TJ!MhZ0z;s̋L*y*g:WiA82-ZM.݅SŁT΋H 16w Ȏ9-Ƕ y?meNVOM?,VX?_H S8łA8 4/)>}"AHo9ep)ۼR*pgApI19 "Q+؄N9 3˧/`lN Qb"{PAμU MY%$SͅFx i6s_\&ؐ Pk:#ݥ֦ |&=ǜHZ<Wi3BAV mq } pWsS$#?Ͽ|n]ώyIH %{_Cu.x9EqwJ^9$z<%]M:Z=DI.ȃgS=*<8UB`nm" pDL*rkC8H*CZt+b/yD8E$dB.FŶ%jL q"@7%T(qK7C 3X_]k5U64 q8K3Pqe`%$D&!/W;k*@GwۂlC@hI(^^|(7$`OO> stream xڕYߏ ~_:FgK-o(p'$9vvvv(GVٝc$"?Mlr_ٟ76?|$E\$Mb66OeN)۝:w}8V7Z&FƖ]Gr2%4;]h~8w۝̣npD;K~,8=#ܖҰIw[AKs*uǶ0V!xN^`G!,Ԛlk=q}e1ob!f ohL^7 )9c_ꦁ$|:1QyRuԒ(%bߤ#7r6~ư8=p-Ϝd)j'Q_]rO)E8>! ڙ~w{N^ %ZXvf>b( j1@<vUl\*H6F9d6m)OW3EM?-tȍ7XY3(-즸6A#ˋ279$sT4g)PՙlT"͡+""1+J[DCvl"| 8y nƾb}_D/B-Kw>#w#m%2ilLx>d1y [Ŗ9P,61JK$Bi/2S Ӎs0m۾ɜ0粹V†ZuoW`֣qwT#*v|RT\"RϤ={_ӫ63_GIT@鮻w ҥV4\'zBc~oKHCgJbec'HxP_={4,gsW tЊt7gL2^fik #1p r-g"w\;.x "WGvр%C]+,dYarx4ˋⶨ?0埡Dye!i$|ٯe/_>l|@&EjU= "F3h`D%OU?ӤFs}N}.a~zQ[kNR pN|Nu]e^ٜ0 A or)XQm/I5ɖ(r8Zw޹?a,@7W -_l~BF 2Ʃ3EٛݔZDs w#۷!F&S1| d]ʚrF g~B9>6p%T-19߿BUZrSͯ ,J"P3{#"% lru1? ٩_8A J Cnj endstream endobj 127 0 obj <> stream xڍYKsܸW3U, ʇwN9rr8rXҿO7cUVy@4_?$<1Ҥ<&&? OY<}HMdiG"stn`2v~;)ʍQ.׀QRߩYܬaOi^Ne KS(X<ݚdH?,jPPUQʱh9sv'ܥ\5M~ ?˳>N8V}>vtS9F&YԟoNcGze0R[7/a7݃'w+C3(4$Lk/1-g9KL 8n?ʓDI%;dzrzk;jimiLUyf)y^)|c /R3rCڜNcݵ$C1?TrF$kn3:[xCqŴv[LΨ;c LA߱BDrhi$ջawHw",~Cqnƻ; :#Hn@%vﻶVHAC{j>¢pŤX3CL2"c  _[*Thw /)p_ri:( %93JzڲklyvM0liehc52Sy:%B?S@SST8q#3A!.\?tEp]^Xw0sAƞxz3Y0}bsWV p3i9U67/(] smCYD-3 π[π,<~^ho?z ry!f ihk0\t,\"Fr1D+ڕ:WpMc@=Z|B,y y0wUj"x[xoB{eSt_-eֈ9`Ӥt3!t2mνs8gi.1| {9 xNLT!|bLA0P?y`a恨 a_E_`k)IJww)LFOǮ=ξAp6λ!Įɞv>8Η1T Cdt&x!Γ_;y)/YRtmC `qyGiAc}oT2 r}r=] a*ߺV]4c U7/߾P0B7ˇ# ӂpg S dh{3o^l΂`q{&}t1΅QbJ BO 2"h p: q7sFϧh5\]|]ʝ}qoEsF. 1rs)1v$X|\3F H_3OtC gb3W("uK5\Dȹ(sj:q/׾cP{m(hz5٧Cz%w\jI"C*oH`)A 8nʋLևyb>l]n R).6:7m><.IOEB"!A.F\|}E} N"xx Zd] }70TKBH•^މSQ.GzS0n~)s!cF@NGn}^Ѐs訂) e&P6 {:T3]EJ.ZbFPGrMk!lHتhjj f G9!Zx P@{h}tI'F~hԟN=ʁA OQ@FirOTn$xTtn20l K WG>&Q/Hw#E-Jw7v†ϕXm+|.kzQbu ^{Tյ#|"0^@ U ޴!I 㕋!-F @Ӽ@4YpzD\=!LNet׈Pfk|}εpן%dnӵK`az蹆0 5Dӯ*GE? ztjMЮ]&Su3)Ʈ;xDuPxǕςLbR'` endstream endobj 130 0 obj <> stream xڭYݏ_P~<IC<:1H|;3Ke@ჹ|f(2J%p}VE2y~,Z&ǡVkuVkcL{}*~#7Os[==rkLOzkJp7&DHO P2_x?Wk8T4eZ$} y<~φ}It= '& UF8BxJ]6P /x|?YL( Ŋ&g2jpb)CX4K-AiI~L"*4Z;)reX͸PGff' (ޮ2x0tϛaI.[fKY.w;Ⱦi oXJR 31soߠPY5qiڃHheَh6XR%l~vK&HM0}{ZJDf/cط ' ] [xkѩ68|`luRW>>"s|uRAI>ZH h2.,,h~.E։p&xV]MZJDoIEAW=QjsQk‘$ [T-OopK P" @* T&,AfԨxևbjGO:L2鹭c]E[\q-c]N]5e̚4TC8yFN TM5v%K'eϕ9%;&97!b=Vá8.~7rwSb@U/xUfo-΁m3Ʃ!2ѫIWg5H۸oj}:IxcmE@rWop(L0|22D—!9afP<@.?#%SCpr4̣-&Ic畛YX`JGBf!MpS viw iѿ Wh0) 0N|)aκ/r⑂ w}6d̬>iMyؐ)ʮ;O H0~hpటϹP{j.  wn9_y |R&Z$f4EĔa:M@bvpZ%\n:x4a{Y|W=N$6D)#`䁇yh헼Y͝ۯ$؎k6Gm3%Ht nR?wh2Q0 ^`_t'n\ьH CJO)TzrMUf&}_0*dBC))|Ae΄]Y|D ?+m+u2ʩ(IF!w\ .dӗݲ !g,_x@K}!߽L#XGwW٘qLܴ͚:qynarZKgSMuR3UmW`hIMRtu/:D֊F8Ss";2y 弋*SǢs]t4è[ sȁe4aإYWo}C&($d63 yBt;S}BDbMgu?$>9?wm]Wjw,tICy@zu?bB&#FwL/BS>Ӏ^s!u(L!Z)/@e!GYC+dfb"guOn~7jxJ"r6g$Yv}4GlZݶjkބYЃ^o+j c\8fEE¸d~´26TwEC]ADH^~SS',\t߃O_.EOḯ_/+V;m:,igIoLoη:&8pk&Q!xTYQj5rƎz$!oW.Uz Ⱦ %Wg󟓨'`#mG x?8r 玵]{"eP!v ڟE lhnawA Z $jis҉aecH|e:A`gA~3KeO]/AYLm,7 ՙnQeҫӤ"E*}a#@,1i̳" ._:} endstream endobj 133 0 obj <> stream xXK۸Wfsvʛ!! 1E$eק 5rIT ,)8(}G8;&̂}Pƛ ĎEjdlBpoJ>]1igbԴnY&Y1 _ ,$`KH'Lh$nluUu`vh ?Ұo,l:ӛq3u9VWyo~`kԙ855N[gtg8d;R 󟡩84o F( 5d9, g8 0/ }uIqͧ)$Z,"V8.Jd98H` lG>sxyjUpBi+ga33Mԅ̊yיc=+iJf8O #e>}yr!D('vΉarzµk-XND %2+wEkK359y׿M4>rи<(:mRW"ӈN*0BRKۻߎZN܍5}-ĉ[}}Ih]gA 5 c\ >q~]ج TU39BpQ.}~Lׯ &8E9tv˥ztکg&=,6bJESw$rVaiH"S3Yw))'K>"G0!el5el41O`GCQqo1p\2@;TX-MtooO {gf)cfhЊd'H嚙<IνKʐ^B*͞ ˏ #)CոO3RvXq:cb>8ɡ,u$Xg8Q;ԜJ8Jmh/KcQ8 /k ,P6SX#u*ɫܫb~}x{[Nb(|8+8<`0K1LU8=vñ?6IbABii_k~ٺK3|W2+ї8$3G&#>P@} Ɓ/@؍Z˶PQKd6zQ `ҽ-d}SH&۟5bV 8o@qW1%ZЕS$%3.ʲ(S)yEhm7ṂyQ!3QОnԋx/:kSz^(-%'.҄HG9@ё0*&h4ixiung#Oq=kWl"u,_u$#Q+%G7BõGiѝkURK*ײBQ:Ʒ3)'߬}=Ll.Rv8~?ސA<K̬M^8!`K W2>l[ uYȿ]n;e=/pplGI^h`h {)cҾ謋|v,|8pDFH:W/pVஷ08fۅ 7dNP}>xd[JMC8Թ}h3~GwyWǘ^+mvIC\@H -mslL$iú.(bGeҥ jYٷעEdYX=ĺ_| \(2(~m`d%v,t? 20_uޒ =z x=v`Y0 UZ&W5=m >Xay? o tcb}5p Ê> stream xڽYݏ۸_ad`(iC .@ EQp{\V}ᐲ$+}*9/fl؈ ?bI7q~'FX;-xu۝R*۝:oc`{r-䏟Fhrv`ОTtKL*\Ι2|%߂2)RL:,eŎ,9;8۶Nϗf\—L^'{; oJ]wR֞}:Q0 JXg\T$v8ݪ)Ok@4C}j5FhN--s\i;f,g9ȘQ/g[I_*N!u Gՠ|? #H|,M9G8ps?ow~(Oǣ] jrC(i-d8#ͨǙ3K3ƻTccu)::g*VԞ293DҼ𔟟'ás" i'=ژ'1\E^4sN_ʅeC~WW^| gKqzA2VR0Xl 9vIQ>E3O/5y1\9&i2ZlHLi8WLds||lӘt}iekR("]!@Rc-XmV/q`!v)jL!O\%˚0j.~dͧM|>5fŌx+1^2 X:qIgDðЫUP7f(,2劘$ Wf J\_΍Q4 D@O0"i9J v𺬒zMcɻVO('3ՑƓRzǓihѱh2<"SM#Cğֽ`8wl]Cu[y|&&" CpVdžR%!#ADOh_nchF.89Ia1CUxNG튘YBӈj10 {hJBQ-FW΃oRdԭ/K!%%X/UR>>PyEϗ.,Q/ ׉`\kA'Z""杯o>t)Xi=LgGA.];FKUX5y0Nɾm&U6DQӥiP0 ºGDG~k0Ij55g\dΘ972ΘwLGC|a`Sy?|CM0(PtF ~bPN֫rH [ I wwm=0råf7q5rOᠳufxvwlV!(wu!NjP܉:DK8TIO{_pkMxn&y&_^v 7* ]q1x̅Оҋ?֭w+,{Šz&_U( _ۑXl|S/=GGnQ*g_jn0Azn׸Q y9Wךx::<ϛ9ͩ!5aÄXs9kE+jSM zH)ߵil(JzQо3MD}hD]f h=oW`ۡHH8$7HQ]/\k Бρ)>vkh=鼊p bj>;[m'8_7 %i,!_$pGB=dNֺ0#{dU &zTESx:gAh(Y$CcSx<~>D㡖\$x= ~\v֥m7b7m{"ڍ24r!WF `&MZ*>^ (O K{#Cx}`^iz'U28o+>14r]us) JSL\ZϷ^;T:yGī=xgpV©lS)L]/Y򲋗_eH8b7 j endstream endobj 139 0 obj <> stream xڥY[o~طh"^DIOI CYJJ>;7JZ{j2Ùp7ިMjSh6i滟FeiUjs{بrLZrs5z6R ;cLrMǖw^`gT~d:wnw Iﻦڑ؞%.oXI7wlm3{dT?Lrn|>֨m˄GdlrltLhWoߐ~!%IerTM{Vx>G,elq`p |RD6/(Ӳ]ۺ s`}w)ӞEnB`M.!C [ 9oh#ϰ":Vm;`20.\6O(}5xf*޿Lp''SL%fv$*Owaw?( t/SU(xL*ZT6sXH3q lO@T%t~R\7V5of˳2^,N&HطcsYԎt4](1ag#7ҍXۿPlƕqAZ%'oHen>ti)Bt8QS 4;sX{sHC<\OL5Ă^QSé*r}w:QDBfU|m[ԕcVrIB}"dӌ.K0U(7,%Iv[zox P p%^HÂDZãnUZ.1+{yO"Pw}*n Ѝ`W:2?-,4+(Rgx$),GDS9NԡVlh-"@aPͣ,l[4EbzQVGs6$Λ 'Wc)2C;'686iEh~B*J9hebgg Q@7'm+qLt25'9uNgU,Kˢ\sM?8!I/*2/!Y# Q,8?ECl. [,q%be dDלߔx2x1^bw&vk!ᐄK*A'H$^?_<֨ib>q;8-}vs.ߢ'p[@5_@˼e4o\r0k\ ﯩ5ꇈ G2U%̫Q@6QWRNĄ|k`QAG YCH3%AYMlA\jxe`k^B5Ȣ3y<s+jx8c|BG1-d 'PQ{]ȯ!`|(9;t\ZLHpHi<xM!PA V^n{üUNnR)x?v$(=X_^8w}Xc]oU/9?um*28-Cm=yﮜ]Cch I<$6UsV9;K7JG]D;{+s1MBGv.$-r SMpnkWNvIčS٬[Dɮ|61G⃼,\~îxo̓UyA<>_$7 ХIJGvrϠӣtŦU=P ݢ<"$F/̋8/DHk4}) pitfbq\>W<{%0VyqBP*1¿9TW23pp>c;&yPσ+,ƿCxz8)Q8P LatxC?@~1'g2$LO^#a8,&a0Y /Qo*)Y?`V^rj 0` d2af3cÕ3qQ olheX(\g5i-t/mB8E7^QD>/7y(cm]Sg\ h' u/]@hNVǁfk:~^Ƒhᬋ-mމfV;//$'c72j~Lr ay( Q5}P?ɏ4(_4^$dv&MEԓK"—%;9u42ZBFE@9ĢWFBȄ\4^QFK9JT1l|xH5[h!NWm!qr( `* ` ;Z^y WiMp20uy%Xg,M$ߔ͘X$&"OUQuB9;޴ou /<6EF8>tUk g8蟯wo! ¯0{H6|A(~OЩ{ endstream endobj 142 0 obj <> stream xڝYo_K-O}=4i@Z5U+9|3RV븁 H|fm6&/7o>ꍒ>lTQFzfg7;kccRxw2Y¤-E,q}u_nlo܎}S`&T.2c`M>F?]x0t7;]lM5DH'Zٯi"W;'<ǰa[7{Cqd<ͤnߥZtA`/RV?TG&w%_ޏpd)eQpՂ@e NX F`6bVLpb@k gԊ&}ߝNU̼sb$R$ۅi)*WR 1m΅@px4 5F 7Ge%.xR3$Domub g2)[=tȋx57ah3+L2^*wc=J WY =7}0Þ ӴpJ|z`:G#oZVe _]4aL.Tl8Hx5^dpκ}Y>;9 glz|3D-!w3/--+!H96U Y 13}F9±'E&8V@!R6 spg)c/PZ#Ï]Idžm sԇpR|@I]) * .5lU>?,C}QI+2s'Dռ (Te44"yJl}ρX;Q#2~$IΖ8]Ss<3ƇQk`y<Ta堨"mAٚgllQ &jm؍=3tīxyu %L{E.E4Y?վ:5qS`|FX(H?s^|r!h$ 5'20>=L %Y0q膚g0&2?:a"~BR|O\"ͅU!Xɛ%Mj#r=S`OňנwDiZ.,6K;4 IV $BE~iP i] aR/lxzF9+fjUcĊJ ' 5` c)~!b1^e!E ]jn#VS?lByy̱X`~Z8=j?Ney.qr~Y X'넁F%B3h.ݠ F<)PK6j$Y0VIBy$U(;& m`Zj=z Ej Ň5Bͩ+OcJ421ru^wشG=WUëNӞOѷZ_+g^৅-YTpo%[~oYy'r;E]/\֨OSn`k{Òx|Un׭*nq|hO^:\Ũ/xkx&$=O:iSJ_F V 'z:u82v_l %tDztZ W@lx5ՍH @Yk/D~ێL2vQ*HPPzQi C>yNoM2gB?ID G_L"4 5 oH>*A> stream xڭYKoW20_Kd -ރRt{$ߧrn`"GU_=:ɬ?U l{e?~P,D]2eeRڸOn/wt-EYW07u~PklICN7Vu-Ty43IsEew tL*f8nUqXllx Q hWL>Oh钿 wxfby >!t6*|e߅ .߯WFzwٗLg[vmJ)jePj!rOl&ő6,+< /~ri6kƎUx(-iCm&fh'f^=OS4‹NjMI&ܨ]ХJl#a46=7{zu}yjG؊XO3nCM4.cثwˣ8:zZ c|L @YشKDǮӾA R4{J\y6O𻖹7q'4J? | y<7QiZV?& D$`‚uFe ^,4pfJ*jFbgDYGhp3Σ^mxM56`_=O3'Ǵ*v-{>zf:FXexctn>C1; x MwgZ'rsj% x#FٟZ%BԎRkk՞Yբ42~Z¡}F B 2cT(D=n@(V֠%0oJIċ=zu@VT-/ub.BW{;I^;Qf6m<-X*-p8EꢁBFͅƦ폿r*S J,/kNˌE_f.aQ ;x@ȜZ(92Ghqfջ.!M1όs=/x=uT=x,q꺋0^aM{1MW] Π 0JOk'I @>}Vg."d`;qys8'I*7Σ#5,tK 7@f 2+a" zȃ!={գheלͻtbC oy x2{ɽO̵G]UrK Y8+u>) I*AB>h o0KpU4wHUh] 6k_] MC?MAIAh!` K1O$O}ǜA1VV~2-=ܴݴ{& >/IAg_g]f]ʂMy{6IreK+30aGyz:1 g|:44Ecm*h#y L(mPu5 ե|^".e@j!5va$lQŀ*dR+k#.~2.Ac ϶y( X/R\e BsC[n-u**]Y A?cpGl߇W{!kJ@;'UdaB,u_(q ѕ5C?}gf;+eχ攬e9RzۍߌHd$N^Pq)ЈЉkZn|Fξ$&:~8\V:Iդp`+IsRp*ktKXMp[H85jߺ}4DSAZPw:h⥰v]ʋ Ζ|yK#jTv߄;OfK~2*n/(`0ch[*->Ik֠ MRtV|> stream xXK6W% =(@M\K+Ė\Id}g8,zS(]@crH<$?dwH~I޼ Ϙ,Onn.U&)L|pǡ6[)e*nJ􏺼~/̳+߼-2LU<ۻو"Š|Bhe |3a`\&[kb®ծqUKP1 t:}燪!2~K[tn0i'ζ}չtFuv4e#eӊ6Fl-M\2i{궡8IoI.̺pRu8Oy^s!=`25#dShT·3 4G`;4\<-niundh87h0^nd[ZIbi܁:'5z,ޞyh6r~AW-Ot)P9*.*n@B4v?"Ր5ˌF/}{ν \k< -Ta(Ua(dA1J"L1p6mwp*M<뵝 tn?᱗c| 4V`kqO|@X@1r,ʹr#H=-9ِDI8,b̻]TXJ5maV}lVފ-f ! MΠ(i0\ZfmڏҀ],J>/HL ½=J$$=X}3(BGTw8;/ KI퀊GbT[UGKnӂnb 1 7}u,uhYʖ"~߼M7be4]l]Sh#UZc^ i<ayG|CV3+Mp": D5D4mWR̼]Su0[nٳfA"|ڞhq~M/9jK U"tH,A[dZd?;.:~w xԖ]Gn_75ps&Ҭ0ZI$cEg K@0!/C,("3],=IR9- Zf8Q+Q~ M CE>XD "s:mz,`p7:lG-^悫4Cn_GO^!#dzĒ8,\}h_zFHW|"i6m(f %M-}-3* w[wxF[ɚbXY>*<@ɆzP\k-x׼eͭ~y@B4N'gbQ.^ o/> stream xZKoW9@~'da[-Q61οOUWwiS#,S`l'UZ?^XU=-~x/ ^1W9^ ^\2vR3,,ΟC7`F9Vsmo-[xy*]=Mczla/7Zͩk- u#4qǝ.q pǵ'=۩ݱ2upUyjvݐs=2]@P9Um#qN:NCI[ )\[7۞хbBh8{o\ wva0=p<6^Nt>#4(84!_D?p(q n4/JLHػU\=ObDNFA_GV(ַ㸟43A۸5빻.ck]Vn-B-! Pﺽ#Fm9˪ ĨH^LKQ_j]~ӆƹE}])-ô.<>y-)-1Q@3*zq{=U`ÁC|z"Mw Xe]XFVVp"Lu|6m݀ ׹պg`Vx.j+΄űpYN2+SCFqLj]{qtx⦌O4h< 㠿xh d[pN&83t&|Հ.0#|brHu@zfDD| "8b62TP[9{ }h?Z3#!'8u[$3K궍)HC>Q ~c _EL"zj7+eƹCK7#u3Y%Ln`&LC8 3qYUAXddT.;zSKǼ/xUn&yP"BeD ^¯iFʇ uVr&V~݄x ב[Rr[qS"m3/B ߒH#,9DE2j,6 &E9γѬ"7Kk,0$PmS %tZ'}UCƀ&Hr=DChFvNZJ((ߵ Z7Gq~`< :!=oDW$9HL#w/3#|oUKQ=q]Pq*crt=Ǡ`AV_5HM H)7|ƔVaMFQ$WS(C7(sMJ|W2aB?bR &UlS3&Pz㙽`iV*X5AJ[\*p:N BYMDm#< L,ܙ*FB`x,&HDpN#l`9l } nq}׵e!EOż0lnLgG_R&|1 jcro24*DѸKB~/ΰ1UPKБ#U5vDE9TAqj K[|E]UQ"JKB$M(g*A&WUx'X\p~\SU'ӹR'E+E6 6bUQ!1 Eu<Rf0 YNn.&йzzUO3/BU&Śb؍V+Vrm*lp.u\ڋ6LܕҨn0ya =Ӂ\tRL(Ps=P}M`pݗnwFF]-}ͤX?͸Zˮ<_f&*4d&VU^FVR5'ܾ̽M8nLi*ahr7'"U2>!ZKZz;7V IJ Iҡ‰Я*:X=VuV:N6/"0f!Nkk\)VXP6|Ra·MVs3s]ʪuՖSE \(ƃ6aµZ`Wd'm^9 =By,+8evCd_` YHC"8,v-ϵq֎U>$AJ;!} #9Wqpc+k+]@Ygq)Z,,աqv͵ 4Z$@׳Y&*>O|)R :%U- Sg̕굯iZ!ǩskRe]2M}?R<|K/fy='@n Y|x=~ 6]F:K4U'-_05m8hpŖyLqS WVr0I  15ax3vzHӏ8  Gx\AAdfTU#lTzX*+X2RC9hƾq$ΤOy,ݿ8DHhgDcucSlCD᰽ AЪ%s=_~Տ5",T<=wc}ܧ?@% endstream endobj 154 0 obj <> stream xXIoW6Y iI;5RR3bm.mťc%$^Z@1 s|Q*P!PyLT<8?ew6T8>X"͈7,Preim֊r9<7~1]þO(()u%*t'wdYHTd|u6/( "̌8t#w#C" Vh1QfbYơ_bH@&]p쫪;pܿ-X+YxdH~ HiplqjzFai "M. -oj=)禺H0)NPkWrd Ai #6 ձSă$HX5UldkOOv8qߺ n8P롾o%e\g0(`)gT¬ƩohRR&Pt T& D| QJGo<ǿP8e;yɡ0Jet8UX٪ɤXy$k&JDqb72tKuq98=k  k+&J Kr9m {n&x"&#J&V9Ik,ʻuM>DPj\Em &/0e*REᑸo/}7gġY f/xꦑY_fn:tVl.l %vga13Pv<#0 GTZXٔ=Nƙh24 jLOu׿#hu (M;U}U:A58M S?Pgx~N_ѳ Oxv[}95g}%'儨j<[ln\MT9iVA' F숸ėéǃ{wD'!K: Eόfz243ʧ9bҒ ]6;_F _=}#>|Gձ^tܻM;3Z&17#2yI>/I^@3>]Pq)jI4 b'W71y*0;xx GT2 EG> stream xڽYݏ6¸W6"bCڱvF]==I#Ecz{98$HEQ#D"%GFI;F?F߾SLD2}dI-JSD/)63ҥYf$~h7[u|څoIܕ4a͗= z~hme)gںfsV 6p`"ˤRh%kR!ӑ= m5AJRgTiUyJwlSٮ{&BW(@D.2Mֲ?wm]{nIj)r5;w}K6*s3=VR$ᢸ~ow }Xx%˚tv>j8Ho;5uO^{2 $q㫧 .. >I31\%4Zf2d5a(~a ݯ+_*΅f48‹ľĪ+ljv,{GlDi|s17RvhjM{ C0"Hscur hʋmLcmuR&e@j!J]^t":HVy6yGS3Ί} xYҪo6 i7Ȝalwgw"&uBn}w:D@,vpK` S`"?Šs:uz<ꦯǕ{YӹoYLQ\1 gz0+OfE87FƏ8p\'KDg{%w(>\Qud80j=o GdwAyEyP|DvF⯰Ђo*WAȩ=0497~ v ZhuEc{:qN,nhO4@,V^AG2Xm Y8`.){52F`eGMĥ  'BTEy71iC4<]>F]>:_ eLͮ>W/=No"Skh6lr*SX` @GC̃g_M&{Л 8WfjK\ tS,OOGn遁 TBIgGۏ'8F2,L³M+ط; bv[LdSqXq})L=G2͠l*$JHUDG P5RD?Sg.3DV'7vjuU:, jQuH0yEju>BA 6au?BD_3e\0PΖxy{OØ2pq̖Jk{1 FdjDw)c23 9ZJF!e/B efa4 TǗxcχ`RD,x:8,%8f'jsg,ŊXr"*"7Fk,e|J8,Dy%X~lW(FݹԹ@khfy*n`H#B5J$`WB@f!NcCs4rc pR(tōm„Pjd%<"EuQ]*b,ЫP(cP(7}#}p \Z3V10tyX k2B@֏uǶ=0 wZ \CxCH@4.Su هnyX섀( ,&Du #:(>t^PRr-frC}KDNBM&G|U<>q%Ryƾ҂L-f_h*-(danJ,0J~ҀSĆ~m :T6.348+ 9K%Ɏ\9P,ޣ@}K06'r*McLxus .8Ȉy[m fFǞ{ra9)&,-syQS1zJr07!8}EDEfN=x 0U$ND80*w޵}0:CK;MX#&!gď~*Rh.<:QvYɼ7*.^|9Yxz fCORGFgBJ %f'\_1HC0?D v㧵Oul \X?}c"%6C=F ^ 8 endstream endobj 160 0 obj <> stream xڥYKW| Ue>>.osHx\>D9p$hX"$O@3YWR;@ϯͯIޔuFʥNoN]mQV㿒od;kmss|_76 W4:"~A#x"]NUɏ\kܢ̅~z?ܮݚ4 nvT1e'e+p[fsBfn -CѣTJj?.֯m*Sط,;Ӥ(ʉeUv:vЏzL"]BZ :)"p>;^;Jɉc餪ZdAAN;-'ɬMjUUפU6ƃCHƩҋlӠ%SfI[r%j4ȣk)Y'/(,p͋n.51 jC- 9LBj'_unp ? /4ͯe+66Sʋjs8HrqCΨXWi9oOݚS&sC kZoTP<.~KUBZ*W?WZ/ 8CC39VrbpGN^hQQ2</GPgbF.03N؟* xLuCmLq1~+;~!q[aҰ`O,*`¯ Cp> %)FQojY#nsTsfJu`HL#s6QPX_NK2@D|"@J.:<G~뽖.L~JSVU .hV gUV.`QA PN!8BnZ18z~{(ֲhV)FCcpY6Édb~$Wk*7vc})Ĥbm;g]qSaXL_}5fPlB0"UieSK}j2㩗 G&İ p:ԃtv[̽ CTԒlwYZ*PȼS]f Q9aie@&f u?%(mŹv3P$ӈyQ,J.k"K\RpaN)hF8deW~i1RZR>z1->R!`Y~`”Y&#xe)=4IDlN&G~!KU`l`}~P 7mzʃM+(oW~9]nTPӮg̀G^- 6Vڂl^:L|)" v"H^\n6~sDIPN^k1$2 awK0/4<{PIg2a_ JYfNt0%@r@xf{!48\n|jVG*g cz=Hъ;Ej!`4of²Ҁ=;=i%\E)PjC 3}`9qH$&O[#(zD*#k94w<9J%}BRAF&La|d~67XXO#>|ńFe:=,8o_ы)i]Ay\ʵ6{F~"|jA}[e3^S- /] endstream endobj 163 0 obj <> stream xXo6_!e20")@1u lmɓw#eVZщ<DFl$Ω|K)6Lƾ hU", 4i/og<km4ޚ]E+F/!0kMEo9P7P,Uβh)rt;[ TR4[o0b0Z2ߢHhsu{SaЫIthpoXc>/J^a{.Vh*jb,كܹ>Y>$e8ljܻrxoT9>"KBqBRz1eq".ape"Ɔ:;Eyr4VD\F>rUBx㺃+(dR"(—]EnjM^f_rGZo>m>RmUyz^2}ʰ ?,NҀZeOކ2 $9*A)q;Zq6s7qpCb b코gT Ρπ[hKVr\S Ұ0t(OʓZa޹Iu5QɸCdp=0U!EHcE$`]7 >DHU g҄—h=_\β|l({츱8+vzjhe]z>r=n,/cWpnꪛs$MA8])%"XWWm =NÙ6nnfo-%p_}hqFֵ=wĂtr& ph~Cggp,!'&N a8$WzofL Ü4 &eLԔd9S{n]ƿMO2) V1$;\oYI ~JlmjBeV@ƃYCSCJ^4*0_o9Mg{q> stream xXK6WD"F|%iҦAAkk!X: %k[ass~a TfZMiֲThiw6=U+Z;8sNZÝ<N"WmfI \wrs3j"%^DdYͶ+zFexX9-A{ٹ%V@Z4)qB9lvQ2DT֦]n~"ťvoƼrp,Ϧ',^ZhiiEP j0gJ_,RrtiTB#f2>k*6t4mOBP,MaWo*ՈMm- Y!oVko|ٲ&s\plQ¢nf90T"=uX2Hc5oVBظMba=C3ѱa?5o瀩L!"y<˃M ct.Y*b:fBM{Tkz#9O^SQ_8ڸ!߄,uGӪ;- ΎJxDtGBg` Hl_5Җ(xMxp{@-PB.h GF0Z]Vy1߃J;>钰Q85}fKEQSeᦺq5d/X*U.^ )f$OϱcLQ\g*L󾃳\ћ@򌩌3d4doY6 n&숽5֐ Ce:qt)}ubZXXt-7HV$4d :2'=t$Df$&5Ir(̊P֙w"3`֚ TPCeuĉ?˴EfL/f\y$# rS=](om3MTe J`{| zG+LOtHBCorSK^1=Q˹W~7Pߊ!)}ð׷8G AG~@= yA[@x+{Cscf.샂+qD8?tٺ#88[S?=>gr_1}ZRe(T;qjP'Af[+ Pz8'l2)(m~L$9)n4`v7Y7.T Qy31cue/NmO$OU;OSKk^v|_wd"T endstream endobj 169 0 obj <> stream xڝ]BE늠$MqyH@}ZXYIEYͥ=|8 :b1~|SHQ>y*llv xρ)J #v6ƄjKZUlXBҶNuz-{8ذqǒGힿ/ujZ%I=״˄C+}9fWm .r8`l3J>CQꄈ Pj"ܻs="_17<"ksrf5 7miHFxo/Z{0z):`GɌ_,mrY:,5_ݶy]{+, ?2"4];Y$Usے еUwWCUҘdͲw ҋ]VڍNKbeX\zDĩVy|CX]kȰӔ\4o~ _O8GCtNUy>GWD("s߂s|7LJGJk"'7QR9R@\krhK %=*ei+S4g'yJlc^fgΌjK-+s&W!⤮^j;zY!9wzCЉ ‘ܟyýwX mG|i8<&4RYa%TڕuUQd6yl"G,7wvwp!_:S-WV%pTSy>JeA $R}4,"'|wʾ !\8s/PΊsa!SA[m%V̵Xa3Y&!-Ti,|U#-"BWg Pg4zm}q2:EoK0{;jegL̻~Jt0%8,`j^vdȅ~t;!}N|Ct ydǀ'q v~AN˻wy=wj M'ўVK> stream xڵYߏ۸~_!Kë"%á6Ep -jdiOf8Cds" DCr8&%QdT7v/ѻi$a+C$M$D?7[TlT 8Lw[/V&q9Q+2)T*#$ɿ/wcye0OX)ʷjMM'n6i*t6~cq a hRLH?2kRpp%=-WzxnJ+0GP2푚ڕg+O*>t}u컋۶м?4JgO]t@ƪ@߶e4NgKV9 S@_>{ɗ15W hQ V.jt;AE ~'힆4U"^ꦡ-hM+?OJiùC(UD"c(d/Dw]H}{6,gᕾ)}UdB)JdZQ݀JY"T]CH籆 !"y^LLC粹/ m3wXd"V,R ; ~  !mU2+6})/.c ,@ ]*L)Йfz7 FLB`FWia־v}Rp-`n+n0#7 d>ɗl E6 ?CD7"ex$ m^"cEn AȦbD?G _m`$AMr:qC@P&3f~Fc%Ayۡ{ AxJ-+X~V7w\dv+ƣ'jAKa .i{\/CO6t (RR[K"`$\Z1+i5:YD <:?LQf{dV k),c7Y N[Y24K?#oD|Ze;zضm= Hwcz>s Fy&NB4p]>Q.T-ԬWqUއ׋}zYOxȳP 7d$H3/*]D̥+p ~lЭ;iI38K~ Y+f8w\aYp<6J@rvY6sZ>,ڱdγvM (gHf* +Lzӳ;VXQMܭ M~ e"If0m'4<w~"2>J)* KK^hQO*CK׉ pIM[LIqd%4L]e(\w<rL@d,PI.7r 7̼B+ޅj^h{crހΙe/Lqq-ҞeztwKNbW^C6FŜMl,r> stream xڽێF_,ńREU5M[5mV/恵(l9f>Us98 ?d`}^ge ⨈ "Ƀ}&UH fTJ+W?{-+"HcI"qX/mc 8X,J92ɲ<͡-7^\~/[F!*gs]cn#>Wl\-yPb7ؽ16"R~o9unhqbb-`h:XfEd&KUд<n-nN];*BO tU]u]=sJL1~&`z1jlXi(`e /W_z󯔕R^=$&@s;9Ь-FPôYzfRӽ)a.nM1<ĘǪ9%{BX!."n)@.Go$9;I@[j¥e9S8!@S`r6Cz5sVBKoL*DI} Rhz6T` tR&xGMr9d 0)(g~0of(IpA§>V;ԑc10>.>2 =U?O~mJ@K;G7 a,8&=`nDI|q?ծmt>p߆\ Hp?hRf)z d>`?I~+6!%11 endstream endobj 178 0 obj <> stream xڵYݏܶ_!Zˈ(ypҺH |z}tJIw3Ǯv69HF Qw7T$Q$#i#EaltW3aNCmZXl1|~󯻟"'OS?;=g D[S+'}s3X\BRd:2J+X}fN3d^@*r3ű N*lSe[g)EjR&yЉ[Y:ڪBhK"zlmie<+ܰQQxA䟛s+9繫PDR>þQJah:LR[я0WacG?e益t^L5m,'+EEv4״h|:۲/-KsCYk-Y njgv4k؞Jx 9odjֈ髦ýIIC!Ėe߼zbƤKi[]ճMJ vf Ln@\ ?\,DvL.ڦWn%{yEĮ/},k1K]Z> HspNDf&й4 ƺH9~H/ 3- ㌧N4l}j1STMhC~/uS' M< ʖ7E(>mRa? Z#~CĈJ%X:g9| [Y3liUI=U,kTae{WsA_Ҝπea. @e1 0Ĩ== ,2 }yqt\+ms nX$UCޯk v$L\xMD苼Bf Au((tD$=[}!ptW {Cf2| H1E43vxZfC} # а8i2e>Sp=yL *ӴMW0hf <)\z$ #@VH&x"_ 1bݝ\%}*?YpfKrԒҊ[ a}R)*pv=2vWzʛB endstream endobj 181 0 obj <> stream xڥYKW4rئŇXub gnuXR{>U,zԓ(ů^ͯ)fw|w%sÆ )RT?6q8SRtj7?p\U䱍[ʯ*tw,.i;/#pjf RzOQ D 6]Ӛ]>n,vCSOH>] UN*_ԏ t6E/Ԛ٪ ?UpՊ0Dn-8oUY2!9hG2^Q;/yۂJP8!5m~w*/# zjnxS_1l@?N4T 2QөG!_OU.sl:D;}PY(2 4ґ^NP 1J_5"A=ahTc,,RWr]]-V&M1e0۵+q DFט2m$fjs5^&j>?.m?pU%WJo~8\/|9آ4stP׏cxj&MD~MM3Ǹp q]*Τ=(%VV3a\~=%.9iH"I OqBD߯ ĵDGy^y>wh|e!'R42sB,nE4=5ǡ~7,0wHyp~iƩ1 x &bΐ? hO7Jie<,HCy8 pZd]~8X\j@Pzs/w4jk B 3—DZ?5?/K{:Q!uK}:ah)] D44>f-X&2T]`R1Yہ ChOM޴^Z&D%lՓ řDp'wEdRIuJ,!1V)ΎAtÁж͂&KVڥܠ/̀` LVODCRh{QWuFE97-IƩİN.Kl7T#6۰L֎ 1aoQf1bAx5}N8Qkߌ}D }6 aZRJu{}ltQ-@zbH|b#C16T@RSܱo~0eۼlA@,Sq7ߛT,;ɌTD;Џݡ_ 9SMi1X⺈_͇C-;{ך#9T/@!޵ UUn*Z#OOZ pa+UwȯBxA7 +ET iЌ }X:Q(ڊ)8 D{S+}̓S$s CTw{_~ ,̖}Q%jYl.F*Ż7PRR%yF A#R+nIJJVJB7aUt\CgkBTpEiP"Bl2GBhF81EMgp4JJ |[a:Y~1W>Qe Hը2)oMCל ňF i71G8_:|Ƿ!#J^0uV2)cvfUĂmk'J%XtZ_ÙvVs5I)_њoOD opxTA\SŬ9\n[3_U|72Ù`B,MɰW{دcړ 8YQ'˼X;kL[etLԘ"Ε ,*7c*ݘT{Z|RW_YZKbA*lY?aۆ{Vaŝ"&eV8CN(׌f6=W*1V0 YifLy wGTJP׫7xv+$su+o(ߛC}9M]q=VNH˄3cr 6B8=OcT }~3|UoX1=aZN-"xj4}RW/s/OD"7Tc5Q d Y!O Ϡ2DD S,.>i%[\ΛC!Avbլ K"`! :Sh c;fOSvcKHUC/?C^_״W{~0ñq/f1|9{Z?Ƕ;gDBI4N,Y'!cܫ1z"ӆkHU:͐AXAR@+a "!5s,s냩YNׁ׌v^1 K h;Ҵš^VguiXP9O8;! `T%ښWE'9iۨ+u40z7Hb-_j@;c{fB;|{0~ֳg<Eam h¿nX=Î޽i(Z ֛':F4BN%B2:uW+_,ZD`aT!& 'DX6 6)3&=rb^79|V? endstream endobj 184 0 obj <> stream xڵXYF~_!K(^ڈI5 yH=)RKRVoUWpHGu]\o%WR_WonW_S+:a%Ԣ6v!yk֩:Qש1&m4nX%>vkU&G,L 4/R*=N <>&˒:UUҏ 7"L&OHfLfi?Ʀ%j7o7R3ɭ7뎉 (^$G%d4{{ԭjG de>I'@sL\ Qt\npBr';{b*s ˸mdpeC.9qo0h<ؙTL;pJ ƄĦ-PpqWJTO l;.!0j_v O:_$M:(X +()Q t/U(?.v#@RqJy;X *snX! /=@Mxq9X1AAkfFi`aC7}Uh."@T*ͭRue.4]U=RCZNhOfn/ (y`) ysn3BZJ>Q e^rMz7J'8r 83jA4Ųm_~k0g?<ܺf"raз~o?wKＤg3+BW"{{m>{ 3-;L(w R4ΘA!F3H]e0G+JqQٷ1W;~  ʳu䔩=<1Cm 6%Y<&_{pIUJ@YlcwsIvg癩[,,3"7CZ +-琇Okv~1woB`52 c4=*'D)7ؿyȘW26et !mM7~j mXr_C 5į]De)CBe+ghȿ 7/2Y p`JcDYK ta޶6=}@rKDah_x:(WG :gq[̊&;ˀ=ȿ>.ߖpHy6NvBx0E93"qT>|-8?-w:jw8lOO uޮ~C endstream endobj 187 0 obj <> stream xڵXo_a@E=b[w`>0%W7,J7(`M |fտWj?*RKVO~JW*RJ+ʔQVyוTW,FznahT&oLЪ?<7(-ȬR9oa{5S^IDo6" N4-,G1,͢?/Tqf2aPy^ q^h$p8?כܶKq~1G4ozW3D]_p>7mݭA37-f^oLEv$5l"@GIA:V"a#RڷR_?\Tdy]L PM;x0%Ms3Y] O6^d)Ezmvh]xt!Ib7~;ZkbgE6)o_qCi🷜Ǿ4c]-y+6M!Ql}$ڶ!ھi/9R{,,-#({vLS`Z3O.Ę"%38<ͣg,eeݟDd: NK3km׺" p 6BZHEQ&zFQ]_/ҠUb4HD7ĸYΕ}NT;/WdfQ6 KXl Rɼ'sr$ۋ+f* ,ƯMQ9qtF xtCzq+è3N]ˤ Lbʫ G" F=Gwy&dӬv%;f = P˓#!_A6e8P*[1X,3n뼷=:d*ӈwuGZR +KCUI0eU} XB(E?)1fz;ġfPb溃x&PVⰝ' rhy**#RZEgu-N1䃭eFgy΍AOE@wjk7nlb\udɹ t 1 2c X X('lƅxREv2[!˘N W1L~|kx>#v4KBop?;λ58*~BPꐚ*dU L:}pdB~S &;=~'pDKV|/.LdJ:m"K G#u9)tϿa Ɛv ;Z˄&fR 1)T+ ^su|z1Awbaл}vW EWOS߆nL-uI-F(0i' P$ky[qp4x3oL U3^r-Q %T"]J j ]0s.Lq"6-=16AHp䞽 PZxXck;.||bm2Y" 2p-@ RbC2y'ܴX?<4&pVѵCnH7ShkF=7tō/or@D a-)v̔eYW\J""n&~A_~TVW w2z-z{[L uj+Ǐ3!+u:vK? /=tsyޘ +T7>8r`TPȡLAjyIh^z1CCwƴt5GJ*siO`> ٥i yZi&@f53g#[ A;5p|=pRMIcjm#Í&cs߀OH2/@@M1f$ RI`|7'`ͯ8ܠmlLq(6; AW7`A0yA/{,{Mp ux}Gɟ?M{Zx2k?uKMZrv`~Z ;,B<08 HiD="zc[{nZE.B/7m0+4x3;ۭtX ^e1kAtwzi/W\ϝ \[K7zb4ե\+ % N;D ~:έ eh!~D)+V% ~&Y|q>?-8oR˯ * p;ʌQCz 2RQ[wHeX%| J*.p-𼯭0$d :;*Ώ!y'٬sۄ.r#hMCp ,+,E ܭEj:}? ji-g+*.>WU ^eC \ty>T^wP AQzP endstream endobj 190 0 obj <> stream xڵY[o~ط,%ON[(r {JwCJV9R5!Fl8'6N?vwr#8 N)44-7yT7! w[&A`^8wXodZ \D#ՐugI0̉nT>tɴߦ_pO7m_>c?jtmMtzxPiH>4|f TD`B׎MWs2u[[M13~ 2mMRTkig{?Qݧspks&]6КcO>R?@W}M1|D)ð}D" ( aGI((&Lީn@5xm*:|Oÿ4zzXh2YԤI.,X?հU<`^livd5,sQ{,,_Nϴe@~})j"8KFy"G'jM.*|nG>vC~Il4x˙^\M1I ZaT9}5bOH˜ A=`Rk n6LY,s0iVB&_+b[}4mڙK-觭_#dkZ|{xmmNm wNFS4ݬrtix\潊SPT='Äψe=lkjpn҂Ӯqߏ ibBh!0!U=ViٻϺnF| D&_9ӞHӀ"?#4t*)$;;uJϠn~JA40Qے搂ݭbNW/}_br:\&˅mBEhyCtׇ%YRZ=0 Lfza"D-zN-*iLAIQ\|N- \|,U;-y G TH" ©El T(PJ({yTpaDv /P{^ڨSa(X(X'`IJH~Qê&\~'ٱNw[I}W[YbтFV/f|U@Ih}vfİZrU!skŬ cA74Uf@j*t $pNQBWͼ D]ҽ ti+e֯270eG8Jv/iG3%5~ NFvO$%uH5<=QIDK'uTY-.<=t,L&"|Hkd7c.˗[$r܈ٹXJ}nYP}M!G|!~vt(>O’#;\,9Ld8K/o?nZ endstream endobj 193 0 obj <> stream xڭYK۸W|a+[29p$HC/%jIc CخJyF_?X%%L_WV?}P$HVU&_=~Y"lfhU_;Zx)<1N˶YdWQ'Dn:u/nZ!kdɓ?Ɖi=e[n{9|Ѣ6$&ɢڠ;n*ߴU<'wߩ ~iwjҖ?tU!k0 QHZڑJf?`xT3QuNĠaFFww`,EޖyL#P|+5/G i1S2Ж';^[ǃvA]uzXa.Mm +%?:O-B" F;&:5`b|vSߢCX|L}6 a0b-č]A"_@>cъS~37y4dC3tO 2$@{?0bݎݿ1*㨚Q 6 B44"#〸[˓M|ȊcV+ϕ{y>ו ݾͦ#F\%z. #1PLKy<2Z2p~|H1"P?ԁd(S1ᣡwٰx нi!RF|!crDBg*2ȲR KDթs-TPmHo Kh0#Չhj4'B3BC2%dzBlӸhțh5 w1iA{+ ݒbp{ IdP֠1LyQ(8O98R+,NSd)T#;eB`w)kLB TB,sڶ*{L JA P829:QCH4J2LBas4W+4D@^mRIO9V"J\(VHVQ"u%A|JR 3RCag)4\<.K966&ם]KsCldA * i~wEjɒE}噔6܆ˋn 1no=GoQi$۪ir(6cáhp=QP` bEJD?>y.Ry%nW2J^N޴frbum[IzA/{tonr Fጃ V-r--GEI컉7r:"bQ H<ɵ@z:h8R* W.O+e#5K0w979 e@k:=ߚ2p^pjT"R$jܷ@M GWl9d( ;6> `3) 2s'lvRx0BWwJ/=NJ#2,x'ʿrD PE]?0t. DqVyhǨU0Zq+쐟pY-b0$f.v154e-(H!^_$nI(8Vğ5= bE߻rL\x1fm[k2oʸng|UvfԒsékpSerنo>Y_ p"q k3h[֝90|WC8<#15~8.]RF8cű@O[w.j|ɫXZ n98i",nm?V4BɡԂW0*vWZƿO9ѥx~o7}h@,_j!/f;@kw>v쬣G=U<Yy:qaq<ʊWĔl~F!;/O/OK|jz<"!et>~A)O3>h@ R 5*‹U{j0uP1I[&2us" dPs?ktZ\ddPGN>#e9Xh='=}vGװm܎gKYvsRm]@D(eSW;އ<뚧_*?'$|39wrVzHKE2MꋫVbGG8w>.D\j*c-֛Ij#< ][) "3b?7:ňe$cWX> stream xڭYK۸WrYj%^|7odRڵTG⌸H-Ie~%ʹf4@ ZR*vջzH >TR&.lp(Ocկ7ƘHYoK5oZ83!T&\r6se0֧SSɔ4bX*NEOx,O \FTG]FNcXTN΢jWJ85Qw x(GCvg کAY-\þu„2/p&.*Jpbrh6yk$y~Y̮6Z8u\2b˖4uJWj-cX|౑q0tM&4X㢆]l3?Gƛ1i,BkթwIhcrYBdď&px{YwCٗ;~45kԐ{25DSK'SC75_<<+Y!G5=S^oV\-lcc洲̅t43|2TYǏcލKw p4vZ_Ci `r9xYtv=1" iJ2]ą`JhGPpch>rfGF|bÁvA@;Yڹy8*g0w aԑa߁2g@b> MǹξHSp'M.{0fIymR|Vf쫦,#BV;CY?}Ztjq6iW^pcR &,*;TGf'nH#"R JJ->3i`yT!TAfFBW{Hv?Z (rK \)ڹ'O @LJN=V~ /l8S_r%Pˡdb_Ε- l\ ذtA)(/ &hA cUvZ7rY=N"Z>aJPk<ţ|Y!LWrÒ&ϳs3z!Ya5OiL\,mP`'3v>{>kwScKb!h?FC6.τ-!$wIPx0*1F)쉰Uӊ4 @{z% rlSE_D ~ծ8?G.y-$Kg8*n-GUR3eC x:ϮB?\S6ru6%0r!uLW(ɢu56 ;niplg!0l40?aUi XM/'zOVGe Al',Ɨ#//I endstream endobj 199 0 obj <> stream xڕY_۸0r2I҇"wH!&.r@r]%Wɷΐn!?J2+#?[m_6_˕2+jsv%TZv}L\J"ե]*M= n2"˶X5X\F0E2]p{:׬N$v&VC6=-:V;-c8dṯȐhǪB:s/HEF =ݽhRZJxƅ 2OՖwmG)]JZ{aF'M1&9;(P9ލG H^fx0dl`4qͫwd?Ѐ-uy$% ̑,I6kJ++Ds,jt*ڟ9ѷ9,nhP}|U5%'"AD<CʊX*dYvhEI$vD/Yr3V( v4sđ jL* |'KG vOÕ|G'Dӂ|b놰C\Ow[1`p2伇(y\882kChana{^k8T6‰/ %xh<RU#W\MNAӳ2FDԗf׺9c=AcWڟi)5!oQOBcl*bkO:TC!+`H D,8۝]yY5bbЎez\XP@Tnf1,Tu,uHABQo}yr_wDȺ=Ѫ| HRȟAH TڠIH%|=T8|6P,|95qSin ȏPބwKNB'?d9UX1=i簇+/O+p*Dj {,2J0=6Qjǒϋ_ii؁R?J|ĂM0bd!R7`rkVk{8ZWA)s6l;wC5K& . 7>u̪fM}B!,%CbRe@ϋ,._c}\?-R ޶$W 6W- j|sG([Bb%8΋Ϭ.ll{emܐ+(ZZN5tq'.r1&cap,74fn뒻,ᆋ*FM}P8C*Bnc9o>ɯ>1%Lt7vi7^nL0g(𹼃Ut{a} my SkupE#@҉8Mhӄ' T& %4rZMg-8K詶.t4.gnR@J $2r^+Ĕ@w;`E/-:7$K:兀Ǔ"B8u |J<{t]$qM=|z+ V]>F ^(]Lv isOQ̓eUj+ԙ(Rn\m*),(P6n$)> stream xڵZKW('k,&Tc6$N*la,c}j9[Zx6Տ+O?WnW_}+WXW¯bA_DZo6J|wZqWZ 3ynUl[[.2TBǡƇT:M` ά"mؘPSʼnP n? mw8n6FmnwCSsbƱ4{ *qnCjG N7Mt3û%p3-hG\LS2,111PŭG,=ɥ{񁺚k u7HVo~B>- Ï_hF2n- !-,j*o/voӡPW-3$~%xԾ5wrtZˋ&BF}=>@vk0<4դN Z͘5Rb\4 20d@O! 9".2~!'!g{htM~hn.:+Wxפ[ Mg- 죒׮Xh _/]h{K( 6&\{: \QJH[TB Uh2q>:zѝ$7MMD#+č$WBX .H,֖ Ȟ.1x[8>&!@c^;oad QEvu0ՠ!cb!=D)jXix,9P\='Ò=BHX_ WoKa\RJ`哔(DZE[a$lr$' xwQLf;Ǫ=1bm^/ Y/I2SHY 9YHC,*49IAu: حO7i:R,瑧[XYRcN@E m5DGq.FBiJH]3=HPD@PXUxz" gh"Iщ>"',qh+63.*f-Sre πap5M8ew)XK@ |fv˾~,HZ_X/9$m)=M-DK#2J SW!5"'p֖wWP Dp`@C`D T+LJ qy  .z@[OR :EiXƑEQ%ZtTuFO1vK1Ҭ1’}P6fYAiXݑz)b]J5>&ݥs+xԽ6KY6[fKr&rύ-h#XH st )^% ^@ Ǧ5hl&,A]#_%wێB 3MўG8h&qo 殹rharPۥ3-OawUΠ&M!MTKVrCl:T XmZL]gX{xL' ˶+IHnn@(:KkQ()E&/&DR?"ܷEq8żXdAcܺRN 1@0M+UElJYq2VI!g29j,Î: *c뉅buO飢 lT%5! ю<6,;O&S15d<\w@jc\=WϬ#+]@UzO<{14eR5r5Uū\U|R$bR:@(> stream xڵYIWJ9H2t[-U8#.n[(]0l@[o y?EWrsFjQrsoJ W1;uvߌ'O5";SRZ=lw&xp\Shw=}OnyBb#\M{TXS;K>䇁u;F>.uNEL@ Y oc|>a@jҟ(rõpޏSH pUhekeVwه/ +V2X-+1\˹hw ] Wac?e t-lpȺ@)@VgR<)ZUk9~\!r;+נ% Zen˦H%u{Hj/!,ܷ.Gc8x&|YG>ͥHz)(CHe< _ڰ\PA!x4" r\?0`cHs?1Y7,h@|?uf@")U;~Kwi0Yi^gFFLVy6O#U/0XpJ\zhS=TPaHXA*U tJq ;M\AP%-@[U.ϴF,(Vh CyS4C7nM÷z_QBP| 3u 3svB9(t%գl-ǎ"ЅҮI)Wf?kL^88 >4T>_ c AꡋUEp.a(R`ӷ fиGKg}rY9q:{_>hSh=t 5W ೛ IJ,H!%5$EDtAC .`tC'M xԠ 9&ݕ xjư;J4ʳ&+e} q{t/az s#Xm`>Bҗ?}|hNJtu^*^y+cEq>y\g$l 4mE>l fª=0ij`hp֨*ajk<ۘm>LA+9hR+n]]bcwmJfK&=uWe3;q2(bp| dBZ%120yX}GbAlM %Ȓ54Yԉ+-$#UPFsoUѯb|N˪\=@C79KPjY.ȩ&+㙏 fAZ|r.x+|l}@SAŶBhBĀj׏t1b(4VƐЋ%\q%ez:r}Pƫ@,s&0#ǫ.==g0 %7R!DxFjp?ƽ%"K^U\ч)GhwFB"Ex|WL!TPO.YV㾑AG|T_<&EY|du79gVH~NJPqW3V3Jp:fz3N tRR k*&d+;ٜ hCӅG:8ɜW .SM*X>M P6&FH^Ĩd5t k 8P8$~RcF{,`b"kޓ"?F1`9_< ]¤cxV{ ž$Z-%[aǭ8M4eYap~?Lj endstream endobj 208 0 obj <> stream xڭZ[o~0RsyӅRtE 0MIԱ-$Os!uq3(<^P Ԣ_.ֻ׋~ %N-\(#-כ-Pz^1Kje]~7}J:1\EuTHWZVߪGFRǾO1y9u# cFJ˄Ԅ]BAYA/2!RB(βRR +a ]jrnvjtcCOpԇ};J }ZܼtVMDQQpĖ oJ 74-TYTt39uuMoP~$hPљPf'Jy+ثi4W` '-*_gˮ-(K* *ڮmM+\c9"Mc7wtǤS*Y :S@{·=sgJAyn>˅2Q@Qu~ss ^.ilVANb%}q_` -{s{J >8dE$#y13 A(GW 2qƾS3Y`+uxRn7K/E29tWpf({% ( O!#mhC&KI";(ʩ|[uqj?LCcc Mrfhgxތw7WAJqGNV؎{Q הȬ )'ec&=s"w} 4<7zNLNd,dM_~F;2GIjʙMTj'ª" `Bx8b@q?{8 lzq_"ȯH2J(]/XBS.yj*?\p :+qx;?b\,C.AD"t и4s0C8z>L}Uo;~AQL״R ,<3 1 O {{B1)h*9ltۮ#wEUb-P jۢ/`SJf҂J_\QgJz8ȨƤd호X.HзGn5V@gHn=P?l5/2WK6gOuC3 `/ghtc8# :RsPkd`,CT#c mK5/_Ty~Ɗ4 'n Nqޛ@j^. If$X:G:OMK}(YGRT1iT`jjxsyiKI֘  j{ C$\awLݩZ]IOFlbK@z[N -Ν) pF2`%Lyxcy^C~^2=z0Vm4r`tm0F^.U,+ Qy O%Z\fOm%B'So:#WNK}qԨA!PJ5&:hE-DkR+w$gr&)\C?]1aiH$iJƐ[ UqV 熈8ތ$.''˻wΰ"PE ?ϟ~*DFDzMjFAĭjBij,P£xgGϏsvA@* 6 j, bȐ>@ VLi%:o(ɀ 篬$?f ]I fka@Hyph98}32@!( N))Dy*mEOe #Ay0HC"x6@<;BcK`V~P['D\wNO7*,* MR.f(T{A}Xz4(*'͒BH"nQ wr kLDr-e: y?ellj:/'A$` 1A6ĩCH/9"4<IYˀ 2 ep_dP}Cy93 7u׌P67ʹ=1Ps?xշt骋"3|A >CDaqׇmS 2{^6K_ @MMMjx!=\sve`x>'xeɩPzaBNt2^vZR𬗝#C}ˡB;u +󥱖Xq?f .0c$UU=kȟSY~H'=pW~ߴBVQ֖2SL !{w=t\?~_ endstream endobj 211 0 obj <> stream xڽZKWr1jJ;\n8GbL2F7l%NTFvFnR'7N_ٟ7mAmd*4F"fwGb?w\ ;jZdW uo"m /@6YX594+,@p/XM&y95S=ye=?ʍ0oD Äo#/ h`L dGT:?^&r3|lOdCq\~-HbݩQ.9EȢhT5q 7-}2Чx,;<( YKd}]uw8˓axAdtWwI8x4Ձ-stn砒%9..a$ sy02)OyZIpܕk9%gՌ~2+TkLj5>:ֺ^N"?ńyU,eD겯emq>Bȕ]y沰g݊&qU]Dmޥ4Zxt{˛qB{ôWn(?§RL-l/I3zpEOGة"ŗj8(Ac"@g&yɗR.6RR5P ki8%-IXkH|o(?t-TشVslnfU|20Ku fkeqWRhP" >xp4"~z0pU]CGfL^pz5Vhmހ5F8cҗOkHm~݈gbc*Z7gXПO+gJjX˼ ;|7yS&C&Ȝ@Pw'a7,4]!khwVڮ+Y>8HYv^8 RÊhU0iaY"`㓄{@ȹ]O8"HX)ėXg/۲@Z\@舘Y@z>8SX،_2jYZլc߀ ?G"Glq/(717Rp2zN /`P@Q=d=B^eI)O~ \)\\gчr$8k aaJB"!zj7οe]`f9+ptۻbr; ^.Z #ґD[w9e ŝO ̅AYN%>dw KA`nyË|f+D<ʛ*32n 9, VA=ӈ$9ѩPvebG9Z`QSꌖJѵyM :Z!8@{3lHLSR+h4*QQ_RQ|ҠokIjFQ8aDM=n@begF Qܲn_BnrV˒[֘|w*c0k\pc ^)f`uaߐ¨O_=,dBG g{Zzx-ѫBG;M2aB*|Prv{mX)S+e^[)lfJܞaq@ <i&[ඩ2Z(Q @/Bb//1>+HC ﮙ;lSpPRvnv~3^ܽ5TW  r.SKп؈O*]6+:.;/reёY(.Sr"0 bnM3u,W`t.)lTa^^Hq/Ku:4\A$ .?0Z>OO]qu_d% '9g1ƿ .xV> stream xYKW0Evs. >xcIjSnDNYU]J_Wr%\Yj{Zij%EL+VRǙqѷzzc~*w/E׮??meq婥I`tcICsݡc,*]s4M=BD۵!o-\ՋߛWip=!b1eB/Y r=J☇ٺ! wg1ܪmqcUOyw r9Z<|__H< UOlSt~Y'I/~ӹ[4:jx@6ml"|-B%&B'&*nb9:a绪;6 2&½_P $VA0M+ص$n,N&B{nb7v*^ؤvSuaIaOZ۪XisǛ8M-}q\.W?v<rpQz) CCpx]@NNY]&< %Ա?RFAϱ$+mS>Sv(6!˘7$?!G׆p52: kظ{œ VgEO̾{QyEkNű8`]K8 :* Bc6F)™j# ԝ6jQa"u,NK- :TALjm ib(9 8YWfH/.qpUoQ=ep-˪] % J9; J  /xvЅs=\HM/A\4>G pջ2Lt[Tn Hktn[Xo⦻**.bFeIi=Tc<jƓKXq"l6:lrI#NĺMv8VtvάtɏS!~R޴XFbNǮob ۾O|*疌A>}ej8vyq^yRCwvZT1 P߰(5:qH%)U+?Hc -9wOVB1 6q(wtz@B$c 0?|D :?zz^[:->4<]J͂3citJECN+A0M!d !iAҧ}|bt۰KX|g`W FfJD{Υ3VEۆ 9r-ӯ'EVVܫ P8}Z#Zk^4t=o(, 1*Q}t0"xd]o&t$%G_V@fDߪ%/c-n6qo%&)۩?:M^` UxޠBBy*I>6|U2ֽAvDz!TKCwWq b2Ӗ0E$X4)]#u/{roxy(]订tɟx VR:/' !4LeS}pjWۺi PTGWEPߎ#yc 28H-{ $!0 JMλFO9)7idG ?׏~Od0V-dT1xiikݒ!6̔ɹ2Bwpp²m/4 64dmSyQ7vWZ:#/tT ^Wv Q J,?,A4LsW֕֞7Q>j9Iug $ג0-]ywƣo|jؙҒ6=f3fh33q&.T$2}?T=B;䬫3zbդGj{MJb2լןg\nL}6mL)l֧BdW4_׉lXR$|='v2駐C;W(w}Hz8_Ϟ"DZ/ hGKrhjVݤx~ԩj낪ɴ!wZb 3 "7řO=z˒ff}:Δ7ѪkUϴba3`!,yvg^w+e[<,Yl Mt=3[1g}Vӿd endstream endobj 217 0 obj <> stream xڍY[o~X2U$Q4 -RoU.[]gn=́ p8f83{!=$ é?|z<|SvHNrHC:ͯqPu뺄8ᨔۥ4ʢu ONB?vZU-ۛro^'i-g(`2J Ʉ; ::<ƪHHPKu|kTHZ_Nd?NsP[ w& 3F8 )U7/=5x |,8?CKA@?֥̺Y-ft:3K1 x!2k&wzGanbNtpqЙ+"gYYcmf-/&0H/rV7IDE@TәQ:a#ƅE.zP|n=0CT tI5@xC_}aDiU!HR@(t鼱޼1;iHwn;E`[+9QE? ?^ᰎek9 YL7 {x%] r-M#Tm8.0SGFPhF(wqM-쯹 ΠZ,62N1ra(5JgDޝ8blQE]K+Q4g:8zRzJzp}Y'I]$XhPt48$IR×! J$1$kV_h1e+A٦z8w.XrۯPuhApyW),$˽̣̥gڬ# 'ʐ~ [,/ԛq~FxҥN?ϼw%й,[ lNejBEԟ;eG#y8%fۆi~@'LW4e<>f`_z P8* r#FmOg$OF jH1^<|g_VEme@ RiQZF@ f2҉n,+ƑhGf5O0gvwM?`M W^"+uUa+ٕW qGSf8In{%Y|ߢ`64˳- 8jXʶ=jw}U Xw&GQQ%#_*(W :HA 86ꒋ Iu,dq@wF 0c#.ml/ɸKH6@pv[ 'S6 k,ퟄhh"enqxO6N.1ly I \=vN }r,WƭUBF1"eȄq6I;ybZ-'Q+;Yq'rޯ" x~[ endstream endobj 220 0 obj <> stream xڽXKo6W,r D@Pn6C J[=q}g8VZky~3_WpޯnWo?,~ Snw׭K)|\[wVJw<̢V})W[kNJG)4yĬiiQDt3rQ]^6bCouѶfCr ֮˪>fޒh| &9jz}±bp6-CMj<c䥊pAHsGt$y y!FAGaۑqD=?Y/3A)D<Q,<<,qD$'yo[l R?΅:vKF25S3xfLgVqs#@ ?/ %h} H]1M܃1(ik)HXR`w[LA84mgt{Nbi/!TH%2LMS`Ն+Oe_(gHԔ;x.Y9)}e"Xb ]JK@Wk|(b"$M7̬dVHMUְQEY^[(85)B:31: ɕW] HUD0Cz rjWKN|z^d @FDʻ2ODE*Ȓ31.R? duĊGlpCipAn8P춱d\-#B5EiX %VPEr(;L4 Oxe!G/ _d\./j\ N%2YG]rRT3[ېKXm*6ѧ Qަ^5+'Ԥy z {UTrghRi s[7q2!oO0hBmh2f5>dɬ'39ncc1uV'M̔\a_SĮmׂUr5|bx "|51>[0 b \\c' R6Y5X+%|(UD,X䇲/!8p'^}3ti07WL_hhJ{dWSAgTRF?@9EB.OngVI;_? endstream endobj 223 0 obj <> stream x]۸¸@ERs{@S1p}ڴ,9M}g8C}8S p8ei%W1,jw^mma%T|'"wze_9 mE.{Xo,roEܮw{uD< {|jI=F'2;z @}eGjھwSʦ=,8Oߪ)+ɄJı/"0 3n R:\~^gx'l⯊˪sg| 0]_ܿK'mT'8RyvUxOdR|Q<}6g>** ") ,F,6X{%j%TfL75bۀk@~<2gۏ^+$#ۼJK83>]W‘bRY_=X5HU2QbKS7CFt Ry)|t˹Ye w6bwm;č(VQ z_Z?Qim4/"* `2Eڒik0HY hW\X aw$/=\t}hҟFЬj¹Wc#E,[W}%rP5:f)qzOH0 R^/w5m2:DɨmX6%\Gې:0n+{018Ly63ĵeE! gM;ѹ +-A?F&<`}42h @=7lw *1"˃g7U 1fT\$.Πi%)C blp/{ o60ȅCr0 !\H ?(! l`w=D~NZh{r_i3eU^u /I;Bl\S)1i6|IkJF^LJ].LOe&zgGQG2*B],\+f<`Kre g!h|iG~#vW y<58BAb&/k0?SK2 ~{t+JY6S˃+OC+eMjGxl|sX/*$i*OD] ߞ_1g峨t lܘDX`)*8.6Hy`"!47hӹg !0թtLɨG2í^ԨBkx`eF~ྀ3%'J6Kr5&GtPFNl E17t>BC3royB=DC(kFEYtnZ^ 8h'^O }a&+1q̂~.$kU̘iE+ 'g+G#ar#)a**!ՒޠOD;M -PU*m9 淐V3=.dM:f{Ca)af$9R ň_OR]>!1׮fg"3O*x% bъ:u|v"!&Cy9xC'SxkU 7On-J"o1Cklpw|dpmKN9جrh |MzIbSlRCyR73t r}"ss =f*ivf+BnߘR}.~FVHice{3z˥R#b>XH;i:{ fǽv_Ԅb]",#|j'ī( V .Tq{(8Z"(&-ncYuP9ԗ|bqec(B9seb!~h*PSܡߜ_h[MV !|C>C%4J}.IiPeΦWƙôΌxR"$ob'Y b-h&L N,qaQ`D&d]k,4*͵4MKݢ9ġY\ ,b6WBaȵvp6(B7+9Q:5Ɍ8VHTːXv]ۗJ:))X6PϤdPCծ1B }*xzDKe,4;lX6L>.xcqS7neg<5q8_k!qgU@XǓGƮd`w[7={NyZh!Pv@ڰ(+|өvcܺ/< ~0^% 8PJ'߄قmJę~fkʨH)(‹gN~Cٮ> kz\喾`<.TtvU"Sr_F#ʄ\L]bU3I5ĥ([5ߪ/kzвH|eCaC `XRqj0˜?@ݯC p-c/e endstream endobj 226 0 obj <> stream xYKW20%J HE9drȴ-9ܳS"eΦ@0*b=boĦow?ɍ<7j]mw~l.R*:{;yO-Õܱse@u*Ӷ(tװVYc7Ѩm&#4I;vgnr{[Yf3cOf}=Y VՆq.X{Hd;,&.%K˚ SorП( /ٰ'5ҽidm-h{G__VKq I"[oʷy|N]VzNФr6+*FJi܂˶eǿ4 `J9>6** =NsRZ G~کSELW:%/5S6"Uiw2F=Uly{!"bJgiU2}ݿb=~j+̢{*6a߲w]o岬6&Ur;AC 86cjL41NM8`e@rDpϼ,uO )[~tnO:B_kô@}s=5(u% V.~ŹE vU1 5A z&;^e$r ;"xŨđI*;tOoG9) ,҅.ЏQG&v RpźD-cᕴ}%iWf _َ]ۜDa;4@< 6Ri*#ut.|m3/ g ]oH+0E}F(Cq>$rg1& !SX3),4B٨{<ri@,(`vSj? e,WCQTbz<r$SguV=B Hh󬗶CSJ#"x[rdm6q$E,Hhr4'e+"86JALP[5E\UQl3MD!p_. -OI oNs(N#+Z0>_w >.N"ʂ+sS d(I-'zU+vp":M਱ n7/mx|(>\E=ȿB\q *g.nnJ6pL[;& wa.d301 ;0~l'Zl;RTiS.v=aR/]F`D 0<<i+uu5Aj!ҋ  7ek쮭}o"ڙpRgcV99Z4sDQxppIizK߮A~@O[aԑk-Ò:{BեtzKTftީzw>@1&INv7g̖Uj8 j}x_9JZUjN&8_u*Մ~RL定&@[ur)(rmQvfꈸ7nſJc;:z._zҕ/J! iٝ-%vHeۯ_. endstream endobj 229 0 obj <> stream xˎܸhe5[+>DISlg@m|Hiji"=O5A݀bX*8dB?;4ûOȃ*tA-)T%RSwGTrͽGYTQWi)G놦("ebg\zá<ݟ~1oLKi >3f$RSY톑fMq܍Qe+ ㄚɓ`z]NĦwGU7;_:'/="5HxNrbyZE`ý%MoiOy&E{ԣҬ?˕;w毣os&nHte>}3,?򋓐,sÏxbUy:Y˺f\_ \; #dBze9XcV<''+wi%L t ;*Le0Xgfw?!qQB 4MH;Bn| OҬ :0G?Jfdx4'a(Xs/eZ;#]yؘU*U'onL/4_am f\ ċ rZo/&QQJؕ`ƕ^F?[DU*!ag0gr ٪H=bî/=`>nk/`[?Y_Y(GRUzJ;aTm|I 9A'G~UЬ[{B yfɧ'J.X,IjeEtۧ<$<;0 >/Ga2=&`BК3꥿+ `e%o ⣾Ae ?6ށ'"o*Ȗ#D"|@;ej_8RBG#y_N 8pY_|Y@}N_p7x>L Ne^Tei$PGyKoOa 5yf 玾}3o3`wSHj`4F3Py kmp!QîYѫLp D3Zys=C4}~1;ڒcN^N&I>e_)5n܍[$orHGA:wuC` c$?Eg͜2\YE:;BvT9hQUܪM,B$L?z{p6-S7<]gZ=Q\p;uab5KT3SH*Vx] kM0x?RHLQePqA@=PX1A2*>sQ +K 0Z˔~P;M|9x͔iBew(u(0no6EPу ]k\ѡ)>w'_uBfBp**hgx,R~dMEE"7@zWSrOuc7HgcT;^X(m23Q$WضBk!Iɞ9QqzM+ JW-/ %-n^۶ jߞzNXq!;&?rBzM Oį9.dg0FrB[=a Ñq9zkr;{7j8Z݇j#J3}Gϓ"K }DRqʊ]ۇ}U'|_Vp(PxB{L;?`٪P O}M,d{Yݘ=_`ZoiX)]r!?__ endstream endobj 232 0 obj <> stream xڽXm_aK U. -6)ri[=[r$6;!eKnp8.~[?0b}\nXpW⋻킗 .J/ٛ= [x\) ׻Jd^H?Rȹ2P%W~n@˕(3KaOupE+,s ]zXۆf‡Fmvn=o{US7;n}PQ7mmzspC̹KiC@FRdU bE{կr 6cb%tJ2{_J6}mJ\KǨ=,K}AhK*[sV/Wݹ[M\PMp|x>JF "Wt!\6|j4:Y\J(L&e߻=uWKUK+fKU< 0NӐO"nFK++Esr^y7@ m4*LlD×b&)VY!Q3R%]&*ѩG6wJ(d43c;۶Vwq2U:a׹33;n{~u]+aL.YJ3Jw.戞m˱XT.T mRT"&\Rf52Kϴ8UN=U6:qV2^k۟2[)EQ @|*<9SH\yaFe+-TҚy<W~s^Bm n0C]TZcFi,iUvr8*a_)vH9P?9Mo ࡌ `S0B ɗ*(^meͨ dFZfmO=Jڻz_"#+H&la=͹0!xA{kDz:p#=އ~QōU>ԁEQP݇rg_#3y%"(z ģo3޿iĈ>>8t5;8*XM'GsDJf".,*KÚu[{> 1Pa-\)*Qx*FTLǘ '`IRw)A<"Ktzw>Oj? $S{jrU絒rS?δA"uHWC[ 9@¾FvGCY%V4e~x„0R +/yr@#GH㞥kr5mHv3~A4KDat^"Pe!םsMx>u}lߢ=S`Õ FUE4݊/RA%W+D9oϔ TzPe;. r_Q5r.O੃āt>,R Q,ME"ҧJ\Һ`Uo>qU[8OhV\3"61 Җ[n TinŕI36;> stream xڝkܶ{"_ )R/AuM~NJgIs;/걫K wqgv]Ÿwoކ;U3;L3Ve.ݕw63*،ZcS7o\Rh}ud8&VQVpJF.JBn} t"s(ɇmFE.Djµ`TʼnL%!Lq( QT #`wXzes[v{ gί|^\9G_pG FCvZS]E DL^Ә?aY0v[X$uPzS.uygHH;kx4~WMl͂֟fR˼AĢ( 6m=0Xw-Cs<_Ǫsx8NGӀI॓XxˡևLqhY0l ˈ,\LBsʨPGg9@hS ߞ˖gH7 C% ŋ۲Ԣ/VKEk 9)FWx R;-[Q[Yf{@SIR E_χ^ }Xw99a ROզG; ^ѝdb.3AAB|sbT DJ# WWJ>2A>>b2ٺhdU=Cy+yOT9Ȥ!#~Hc($/-:U#oʲF" C3@=YAX.#)5!c S2TLA_ 7ot0B/fN!l!QZ!qf-pWM]1{%g0i + F]{3^v ÖAm }=C =KhU T=KA!=WsA?P/v# Ü?@g% 9>3 0#2n>8p$z_K~{=I1gĺWl(׳,XEe$x2*n`&a0u{"6|YW))}%w= ([J<}cbu?9q剿5XK pYk_R/ʲ -dy)*^yaTl,9rЗJ U;^}G c7RG!H~ԗ 0i˼cnEF _knsGݲ"H% 7E2K#S #Q8e6H@-Ѻi>g*BEYq q%h|y;;n!9'KAϝ9.3 PcЩ}(u$u:L$${c7btc=ۊC!nJ]?^^Pű7w<~E/Q}'D7_rL"[h76Kp5ǀ/ ĩ)LvPݡOaRf xHy3"JBP_JӖTY~N!/ӾWL+ =P+7rY/ %z5_rdߨ^䓼pvL?.4Y.:IԮ,,034\Igv#x~-JVMU,dWw&((PJm9<(:˲+Xpy^MUyc+_zuV)=k޾ht=rUs~}jx @TYÀCv27|PaϭUh}-atҐB_)^>nEq;MqxCĵT~[> stream xXKW{ XmdO`M6c=x|DDjXySM#j6A1ɮz}USģx O)z~+"0v#.Qy962R*Pnk?)Ly˯1˥L%S^*r#*1+]ܰd@Y*dt`c>f HipDP&@ ڢbPQ#3ŃCmb?pJ0$ q5-JWĦI!"핧cJ?]1b2.syC 8jKΡK%.kФZFn[t ˎ ] A^,BQU'ƒ9<6;76:>-r9c'NLLlZRki?v``GzTmZ]\E'_Q_rl| USwrp[˟ W)@Sb`sU T!= $UvLXڸ4^0?e!z5{Nq}Ez"*P2Em`\)R 1c25Arqfp{qI⑧`(o(/sW;g;(AL>OU}nvл5Aiəí hv;@,~;'Ux"ͱhҐ3B9e6HtX2N SC Hp}E%~_=S-@ĺ|7u_Q$m@jc})J5m`康v7Я4ӹpwS6_Ol  a1IE|JYs>Yh~.'Zt'\3!|+"39=f4aZcJx؝9TOsfߟŒXg:~02e0M\6ԃ)KQfx5{#x0Yk1Zj73 "g ?|#ӜКA'@|A6%n8aR8TjH5x.__5@pM%MiS%^0跺_+K_048/>a_O2_/8 };~l[h9:=LBݗ[-u1;^q8%\ɸ}|e^3&űi߹*ðG :;BO+ Gq`NԻDmjz蚁}P,F/),r39~Xhq;ujk&=*C9s ~ mZ}?G寡cq> stream xڥYKoWmIr1pbDDCI_jNsı <~TWf9J#ҨOEC},JUK}Qg~߸owH4]qCZ4]( !=i<=7#X[ʀ~jeG?!YwI(Q*>W^k$+]ź~xde\ozp;>+l6 .0Bzi] 3Ȓ6r g=Jd+M5ma#EE)"&:]z |mUu\J2MlE:k[idm8^6PWS=r⟮~F(?OTaƏy4_0_^H2W?\(ZLt 5?TM,D<1n<BqnvdK,wj2wt; -g2cόԌAT|7LqC5240li9^w;ICWնM~@$ѐMj Є@pD+`i"jocXLW`e|ϿLhd `2Y)`4Ft%Pͯv?bgu{}VW$zp%KkIStYguxmpjt=ptb 8հx$iqe zamJjomA~Ő2XUx' ;w[F._he\BZ@¡)B>g%G >NLF~ mQ˙6`ZlxElU("EfEQzzS"ڮFyl1%H.&2{ēQ7P]oJxn™XO-1 'lUtdCQR/`p&E_P\얱E~èfSC.EwG}i6h!XsHMÈWKV>ds*EԀuJ z‡UOBϕt-wTβUq;ׄg2/ 9mX2ɽ^D*E.EVKupv6'x*KPy2istSA0_%߄Ϸ:ϋ*?jOA.UpR /٤&6_!Bc7g=^횽LMTULY/[,-gO^")YmIJ#ƿbCP.Aw.LwaWe2$[X| ZƗH81E"\~3?XE7< UD&r\p~H~}SD΀'/T".=hDs_Άsۃߞ:1y4T/|6nI̲v[s{^zu"o%U敚b٪5 w¿155Ub·F*+.p RXxuXթ/#@Bnw;d N <.1z~]Jo;5U٩Y B? .Kf>˟TV endstream endobj 244 0 obj <> stream xX[H~WX2u]00i}N܉5~=fNЌ/v]N:ԩHG %.;DIH瑶pyt1~lWkkml^ιj+n"g‘ {O|#uAAh kGFiZߨ5Oaɹ姞1A{&4U )_5Ux8,.1WS6y93.-/)sʸa`>Ѯ.K\l@U̫"ꧯoNaDoQY@I\0ťc ElߴWh}VTgo.aޗn&6`&]TB.9㫥x3Y 08xCokT/5[ *琷Y2o|%%@ImU-*mQp/Yj\{Q'~M媓6Q;N2Yy[­%SyB(AUpٽe6m99U/qJK9`Ug<3q.fSzi [b@2~]=E9@pX Ǩ0jpGd[!weSyXOx_-˘Tד^Pե4aA`nh]+Qߝ -2KG7Kgv+)&US 7tY 6GnBWCJt 4v VƑPLpm?5lE#UZ Pe2=Q_5Gt9yeC~xNM s\-6`@CLc'i :DӈM¶)l4f<`TLxlhws8)z\-d=@o2І $m;͇o EC@_.{9;)$HₚMB\Pu5&n ^| 3~5Vldu%A2\s7鎔)JZ;xtkw>UAץz ޳>b= د܏gp-d%f6,4 g{H?`/"2at'kh@ 2<7Ő+DlM8$ᚷÓ[>4H8u $2+n"SKhņn/{p,Alu0|T @a~7Mέtnu+Svzwfy дd;cJ!Ut N)Bk / w -s[KDu/5V/7p7~8CWYٙ.Kw*v01姪6 "L ^>^@/ʍ&/UֽA+3Nez)r Ls`NV`>ptnv|fN#͏_dy}uEH\ [QCbE,,bjgs'w5JS @#EJ'p\@H}F6.0 A}w 1'>y^2 \@Ν Lp(8? 3ʻkw/FeAYjX L~9eH?f|O.ˍ"8~R,`U7_*Aњ- ѝJ5DyL%hܱ`# B̍59x!.84}tZ /DqHO\ͳw>zMsCXX)AfbL-$%i endstream endobj 247 0 obj <> stream xڽX[~RX1x9EPtY4-bFS Eʒ#;CRlfQ `J<<\ׄ&9Ѥ,?Ov6}М\dOJ(#d[jo ӔH]a~1m3^.yd,ɸ&rw;O9uUWo2d:9# >ɮ!ƛ "{Dεpj:sj7i*5jSk#t&9$mۣMeDP#z .Nx?S_񴭬jejZ|~nꃙƇr(lTMSp,[R JXA}v}S~ &Y&'sLpV"Azs"e98qv+<窽XLj2V)!$ <'ZQ ^E /Os|݆B؝* a ATG]在B+9uHxѲV4)]XM)t0ezPT6ㄫڌygVm.33V 5.>XTG-f$/)ܮJxt4Qt*$XxQ~M~MW\'ωҮe4/ erJtA/cKJfdNkRuDe~@V7aӅV6` /,"N.('Z鯁+X~#(kf\I"W+>qp] N 'G\7 —U|lI*|x%Wdj0s 3Px0u: Wym Nl> ׬U'BfåI!o W2OԎ󔸻 c؀4\M)VʿqAWw򂸺YM- >*0xc <8A 3.I.&3Ч vQ߯Q˂JTb~v`8jJ*;K-_j4bf!R쾘8Z0S]gk-2Œ-Ms\#.Dwm5}7kҼWE47ꭡ lXTm:JHnw->_=xp%Gaw 6x/m2\.`q"v[d'sӾ ^rcЭ#}7`Mqi`m?s57> stream xXKF WrS&)rHb+Bqώ{,Gju1C--'ZE)cFC"zG,M4g6bYD,(coZǫ2~SWV\I:q;ZhHedL:jMl7۔IہNit\ڮjmI;[]V\=~x۴wf]^}S'L/3UU(D:OV_b*qnzX|\g |8'^XNNR mɲ2~/ɲZ($Wms]Kڕ>gg6ibL6K0P=:-[zC & FڐZuYXSp |%!(5ñǔ-%K`QIuCqpTl !k}EfpL  g|Aug >Tb~qEmq`\RAB HT^y+8hjIzt".)X˨/mYDڋ=\IiM_}p7MgjviqA'^R!^2l\Bڗ,J;Oӿ?KoDftr4̆@BRFuB 95fnOHJ=Cv,4&8ޝW`&LݩMCp! 9;P[+ Pʱ'\!sNl-TeG&7oz'TWD)=E|G 5Fݫ`^("QSpgݛCzd \V2a|Z)?,Le8]!\ Ã-.T3/|]Â!q k+-p]6F"7X BT!N!/". ֗M;<>4M" ft >cAϩU9kJe N#]0lj:Ei!UOk|ǡKuOop-̷*n6Nh paNo@^]GA CQ1&sKArQ1 ہSuӚUcxnY))K,~mIZ\?d3{J~Eei|o.B@ċ4cȉ8 !/z++3׫t7+sm w҆hyaeNU_ۥM!.N!.o%y pmt hΆw) f7Uksx0]R<Mo7uB ϨO4:ӋX!TY Vx^h)&:ڴ[% gRJ_/L^&9at3eȵ׵$z8^~lWPkJ#] n&J+R61ʹ{t5%|1;a Ef뙾k/40~QZ endstream endobj 253 0 obj <> stream xڥˎhb Ezp}0Nl C&NK=-5;޿O(Q3"B|bػvz?+3Kwwv:U.uzwjrN?UJX?w{cLrN]CM6=~oUi>Om5s^0Oace*L|iްHUn_j;ahԌ4/xi/u ;yr,h檚|ul!gJQ?<]p1=8ۛB+m Q:״?vxvMS^y[x'^b/Kjb>mKb%YKgڇTۆ/ne!Rcf^Vڤk/2<Ү ΃e !2gQ69‚s8<^x"ʑN#wɱgQi~MSo/F M6GbZ"a}L"8#LUJ ߛʪ2+6ǒ*2yOfՂFL9Nȓ38̃{E* VSQz\VL. -c;Ovy%đ5ad(Ǿ!ƧDkh#{z'c`/77͍ܜΟ6ċD%x]$K'"l8G\Dt41i\؅߸[[WԵEл'ܢ|Wr$ )2j'a6o G0 b\.+a n|u2l R'k@3Ԁh%tـuTlLOan6 |Qle ϟ/,2C#@HC* !w  G@niR.4)#1[F8P|{ic'9ajW"<SA3F̀iꅘrboF>sbS3*03Ӻ9k7q$oD:wqBT]ld' mjYa$1Qd%Q{A"g s$Hjc.)"96F%ЯeF⅐\s~$<(G_ʃ.g㍃lxε("ZI~e@R{S6.ybfۦԊUjb1HRqU\qpD:hP ! YhD m_ÇCDgpXt-w<^'^ls.$RPP$wy[j!4M*y+%}mB$&MP3ahU*\ÎtfK^N=IꀭvKUd$c^WF"2tI7ܢ0 }Bru^Ѻn'9`"&6C[u=Yhފd( 82+Vj]~x4\۠/MH:TJ#O `W)ܫmWRlTaT9`Vŭ 2f~!F7)\n#oY7S3V:`s`jH"K  ZgrKű/Vh<$)F %R}lXwJoʲZ,h;Ez](TVu~4RzPxJKa(Wk?Cʽ%;c}uT\G.C%0ΕQ1S 7_C~?r1wˏS븜Qp ԐL H F_ۧ YbIZ%U,bRPfgbԭ `pwM@`~2{|͗kل'Pvœ?@:ӜZ ņ76'9(Nin/x'%5 ͂D6,(jݭT~ę)iTDt>I"KWpWLUZelrm =K [%$>J,k>e"Kؖ˒ <`KusU5s &N@2AN$, 𐅬Zy͹ZmHp+ļ$òv!aE} *7WɾHSnUy ݿvOV8JcRq ӢD.~c:ef'^0 Ҥ$|YtL$ZȰ;2V8}Xi+orUC\՜:$uֶW&;`zRY> stream xڥY[۸~_aKeXE}6 Т>AǦm5Jr΍el @x!J"VY qz.^(,BWJWSylhzc ]vLB\{ѩ P7seO$ jylitP5Upz(R{>͞]#̥,˰3CW5ǐty.*,|F"q֙%t 0K'C &)*+PjS ܊8hlF>6Ez,X{ϳo).a W`]ڗ0,'B.h0)8(he* u4yn|]&3g*B9e\L:dA[e7fv6Y<;+^δ62kUGgөEC񰒌QFDƤyph;{+yظܡӏ8n>\orS[dS7`"| fՁ.t>ή;]a ê_+.2.JK 2,_l4r$2ok?ߪf YivfRQ/b', )&5x[ WW&VsPudP"ܥg|$sz5Ÿ*CR(]'M6cLsz^Sk_ZWnT,K$'Aިp3?̔_ ^ OcOҸ7X3a,ؕLbn4LE'K<3WTD0L';{` =F27b,kH> ~Wy(͒&C0P;r&G%bfw>x&~~; Z鲧 endstream endobj 259 0 obj <> stream xڽY[~[e`P$u>ۤAIHl6#,93J=C+^p.Ǜ6F¿tS(e&Uٟ6iILIJuRW,Nkq~Mj6B@3(SW)f]d쮍}e^ 7;=uL,YfPA]m#6Lrm}5D5>8̇B.&dW"Ksٿu;eZ =8e2|6K;>h/n@R&vm .#sڮ:_hp_k](wƘuRA5T)L1zw]Ǻk5NkPi3hRI~؛`5yG{t#:r]wqcO˻wMNkP)ɢ4g*+,ָ+25;1yzY!ʢb_~}CyU %dƒwY/ V If,B7'b]d~[hbN# I!{[{= ?5'iɄVbQƄu. I>Աi36(kD!90CȡɏH$u3r U6Z*pF:=[+Px%2-Ko{w<֨Z 22 qL@?BNuD XIDe Wj14uh+($ʟhGh"ß@kNsB&퀧| ,[C󓇮!sO9E1@".VNaZpލ <+_hE-~c"ƭєۣg% E)iUAU$@3C}2Zz#S=Ynd彁 ނ WTd-HW۳ d"Fߑ+ԝ zT'[0>}vct]:bB3 D-L0+dV]b{R<[O>С(32^?Ci oa=1玵s7 ~vR(@XWH|wPCLޘ+BO_8KfK7ȉư[\CŞ}r1?>O`Drm=8~d>Zb|ّ[b=U.;0'tE &4OZ$8m`aڼ-i߮&@Av.m{\3>"H *1*yZ=rz|EMPy""#%{l(v<4D;]%k\CUO[v=2\;^{~)i~[4Z`#. bNs4c|-ľf3փpbVw5F8Y{Y]^74VAZ. 3I5+vzwr}O $Hd0xYCus1:#< YiV4zҩ8JϨb_őxr YaEF>ݜ&drbdۈ;L; ǁ6 m#І Ê`o97=4"P20`Y<#dH:zE~puu+DsmtQXC.D*̖ΰLNO$ UxlSyVdhH`q"XrPЩX^dFʤEi ;/MpW8c$~pvuD3g.md)W7 \dX/D b_3@;c{踶eG)@{LoA v 0 ~7և@ެr"4B@ -·вP# >ݮ4@rta˴\d.O=SX~Y3|# :.. /)T w6fȦdF*0 AJ| ֏1,)gGU s"FsYLkW.TESn2#k(7K{g!v!۟!7D;NDUUwl_XM\JZ?m!W " 0EWUU/ #{?pq+#"sj* C)7ugգZ"+ghդe`:ˣ]!C}S*fWb_.a } -G85jvcߖߦgOA endstream endobj 262 0 obj <> stream xڍVKo6W(1/Idz(Eh=4= %$'ȿCR y|3CpR?#Չ|ܑf8ׄKj&=OnllRצ~rӸk+QS/mb*C5Wyf䢐 J eWO!/"۫Ok3yjnMd(ʅVՊg^,/:YQFLH WЦȀlE!t6Rnɳ|ϫK2u}>®__2ETEU.#[ ഫ c;;px8vc54{yf >Bev7y٦EqܮF,)+S(+X^buѭ"Q@zˎ|#Tie цYCNN:n򀝽o$- lЯ^*! Y)aY:>pAz$1n\.=VR,F PT@\QUy!|?rt: NW"W}BB0Q+=6BGK1FS>c8/߈d}S M nC{LMeeS$8L]NxϥkqaoPc-cUFМG ((7 " %ø&1q8f+nܿ` g ;84 @ |= uEIs 6C#yvqO;3qH8pխ{[X~TWiO ʎa ]جkb;'oyiHb85&-?GMIy7'K/|cDP^,vW(H[.F$تrڪk?"+rs0Z0 f+#sf>a w%g+%|lBk}KZH|} P i&;×S o&m$w=;K;K D}tҿSZ vjs S5p*3jjd ^_6PG!b[A6 endstream endobj 265 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 268 0 obj <> stream xڽXK6W=_M"Z zȒ#qwCȻ-HyH~3pF+J_j{XY}XIW9!,Wj{ez~[ c%U2\:MIԷM5.ULTd)ybh 㴪mg@^L'Ob2ݞzK*6CQq/^~gb-L8"W%9!}X7Ǯ켤I`$t*&R& Q-i6δqi͸^hךG{0͒h/f3I3q`2͌sOnۖǾW/lb-Vi>E$r/y7VY`UUvvԻ΁J7qʎNp#C,ې/x>YrM&ײHHn< `0&]eųi=YV>cUF[yPVN=b,mf֙e`Yv.Ǫ.kE I~1GC")/0)h@p3eHRvB%`( ]'Gs oG9-D$/En2acFĥx?ֿ YG`c>H:K akps0*x>`j7銃yvBHi)hKQف-%nWׂ1VIڇ/Qy`^ܝzm[{R51 F%)%q\Mt%Hυuq WEP:*1Lg7ľ8G¯cp\:rࢠN5ܬy‹W> +owίj ~I/Hg=V6J m5a^Y۶'|巧gw8`>'Q(!G 3*vr;X簇.%ufMRC2z!nZ Ə] {=rAhcb p0`2pB.Q!mU=Dl3$ Y.mfXfB8 iq,0 f|lHU4ɿZr`Ѯp`*~ nJdLwS=LMԌe*Pvi#P;Fv>Tɇ['!)On2ӯi`tYuƯ|#)_ 5qɱC5>P. z ,s$/pطxGI(#aײO:h 1<wdɬJE09|peT}-.CybBz3t&9 ܼ+bumUlgЅTTAE"3ѧ.-"A<,2G jZ|RMP8t‡JԶ |t]q= }}xg[> Vvnz㛿$T endstream endobj 271 0 obj <> stream xڝYYܸ~ϯG 0/ Iv y5njWR{<:5>(,u~Uћ&5ovOoF*syxl]yeVId[{FPɜ6ߺ\eѬ:\6;lŝS&ǚ望Fn۞:h5Гklب}PrǮ˞e'fujUf;JkǢٯn2W6&XN\D,}Z\DP/j35= v laӀ{xWCW5M&Ty2{\Qw"ce26OȔUc=>Uá=. }K6^ۛR4L;/.ڝNW?c!Hdbj[`wǘ|DQQ.uOdt>Aꑟk:u Ѧ'8hd~Dʱr&Xf=*[Vu:5\k^8C|X$I֕4TtȂjHw~)+k]m_r4N>[#>s˃V%q Ltv'6x r_xu]㥍?݉?Uzt :I 8Q֤?br$t rG6^xo}ԿN !MgS]qHqn"Xz(oPufRl\Daծ, 8@?s(/zr8:Á[MqnC˜eɉSYyp8u*ڝiM %~\gbI fY|_rob0WWy^/c\yB\'al}~E<ؓ!ZܮZܚS |ܓAϩG\#vzp\Lpu T+);ǣOOfu!c6zI3euo$~+B=ЪYs<W U۬ ;82Hܧ{3Y|wRGٰǶ3^,a(hzCB&dNxB"U.9i@~6YP$$DCN$~䭏~)F p 0#]2'O$Ot$vIИwBsQKROuKV%=de q!'nb&z Nёn9)vFld Ѹ*S ƸLJ2>ok4 a(|8+[£6jbL@]H`6vdo{57^#q58t)Q =eG訁y,B)UL7];')gxF@_CEma,"?ibڃm>*`ش8yѫF);`8Z{~XJ2=VC[ A2[@$L˂#^XaJZ^D.p)ǔ_!3yYA äM mVIF轪oP]>ۯ2nL|ﾱU:_lܢM://aa؍)E60G6#Сm/Xߙd0ħhJ$cμYNظ d[~ٕa8+Ė\>R!]Ed$dg5Mf."T9>2idN6s_͏cY4XZxՈRMgLfDj 3'Ul \0ҡ;BބBŶ e_bHQ 9^Da;wt0ZD$!AN 2 *oxl'mBAظEbIT*yr;t958H[aD%|Xtct: `iHor$A RF H9ymnAW{뗲Efc,-\Z|D zsewxgKD3f0O}N۾ƠwcPfV>FnE=;Svy nq|ff] 0w&[1 }r\%Ob+|1uΛ̡CG%8z(X"XzkW=SAUHXo7S2LXdXu/*2MJ}ӲֶTz|u5U'c9tqy)jt,;?34*v۴pL f:+!?%^֘3}@s蹨//3=+vMe;0LZ'S瞏D#`)YDڦ:\.:p])0\ĮETʒyWТ,1ϯc)M>" 1h] Vlf\Nc}˭SM 'u9uᒕbSQjK Qԃ ?gҌ5[b,7Ima*.q*͕Wt+υ\륈+ "V]Q KjpW> stream xڵZo޿BN %"@s"@4RΧٙH <~3ǕX%'VV*wnW_+yv%Pq_b?f7kumno}JKOɬo\ֵLh7T;f&z0KWEMCwwԿk ߬e'=k⛵IMswzir|^I"<Qj:Vf8v6kD8KT'ATi,ZAȪ' 쳨]}hֳi,d8g6A\8W9v6wZATc!|HTP!hE;Wv(4bREaU&8I@IfB1'qcD82΀$ Kv5#v_ҠSxR$>oSɢߨ}Bb _"׿2_oS } 4ecؘUN-TXg X_+>9Pӣ؟鶴dSgiEkތrd.:OLeg3U s=JH-~ `0޷=HWW|4(ۙD=_\0{J][ٿ%۪+u1\$ڽ+_S$q{8f*mv;֌8ΘYfmás 잕v U*@vv3꾪eS8]{$ Z0=wN(}9R &2%Q]kD8M~Bk߂~yғ¦~O^1mgtbㆢ}s$ 1ު is23 ۵~']G^UG ZR Au=Oj¾FhnC/ludy7+!1x !]<Α/۾owd5@w툍qvW `ތ]o/ޱ(2׍N3Mban p c)k@_A?sG{)/bkXlD' &+ م5)f4jDv*`o䙈gC>(b&2;ߩ ee)^BJ.ʪYû˵L"0"8A.}GEp;0T <'d0@zŜ\-BCY䟮oXl%a8w;k!f1DQcx* :cj|f,K*Fg= '\tE9P: _r'it/fa0[W׺H b}MeW타xh%xyOu/}+nw$@R~QiG@߃Alar)&I9aIuS.TgaՖ X= h*:AhzaBǡK!|-;c4vہzt #q̠i1yqڄw~KhM$7r,JaX zJI@e}"kff-'&{l M#e1JBMXpÎR3A:/,5;ax/a8A+!A'OXG7> cRͳb'6/\aI"-r\,um⸡}WM8T[т t ޹O]|hAWCb 3SVl |9JMs'3UǍ-X"b{V:&#Lq)e,2hRi3Z_"Հ4׀!3NVޭXI#PyN(I4),a\2'kt'A׷$jʒ1ʖzRy " AOh6S=H;[$_QcE7α}Ʃg6]:p|Y8M9&JgUMۅ^/ha~Qy {9>W#9 1IZuKqP3͕\$AsakyTJ})KKjkHrݖ5=̘?BD:Su >@ ް2MϹ< 򌡀0E* MI$ }S\P1ދzbxD6gWT0ȡkSuj7oVL o_nаK8Ps(>kNrv r>-,\y: \lۚ+sO 2`Ƀ06lvw"l6fvGM_pΆr84x+lŴ*]jU }{DHo&j)`L#l(3XJצFX\dXT%M2dS=ijU,?@x"0;p/_eٸ3>v ))̸RMs <$F-5SaO5 2?ߔ]^iξXLj{ _OLx١W} 2ϮX`O: ޤAŨj 7K `ԊuBrQ ' K" Bl];C?S" endstream endobj 277 0 obj <> stream xZm۸_!8@ :/vi"mr۽܇d[YvEYZ&@;$ M əgf*ш4R '>z~E$FTG'FfX%&(xW+y|SeK1rW$|<3MSQB{8Y9QsKң)U\]1W+t\ڿ[;Seo;Ȼ7Cn;9|ϷvlY U]Nx"js#3s~ T嶛HNm{k01xa[ l?\%W+!xJ8+ <gmYY;ŠHyY/RHؑP!@$܈~ h7~]3sUJK4%n=JB|DzT@It+pя&So$J}&/k0f!Acʼn;ءC!{:$m C֕}Z;of{;k6yg0vjb`~mĪw-L"jַsP6Y'QAlBsoƴp gFݜM|JϸHkT`uɧgRgu|?}2IS٠V EB338Bdb?#60$g]BYqȬ _g]Q}  -A_7 m6o `zevOj:Z~z*'${&ߕ&.>8Cb۳v LBcz]0D; @|/,ț0 sD(t3M M%='N㞱@os% lN dҤ^Wrp|.:BD{(,]UniE?Ǥ.2#  =GTm{Pd8 Ӣʳ}Ѵ?uz; I|W@'n쬗s]9Y!Ƨ{bU*Q\ԞŸ^#nwݗ>r!0WzR>-npڀpJ15OkG|̓yśz6l5~S대=5͓s8~c f5>6q+1U62v.`äCƕBsQzabg'lRq>PAPx[#E楷*a qe<><qևwNFx"p5 f1/# #nF{0kB>Ssy] (l@AG2w;nx8Q)P=)-ǥ 5((Cȋs`{(ZD+!)G?۫>9'KqP.`ʻxU7mH9.9܏HW3IqebLqnߡCZ=M3,I2:9Cް$\.k>a q2π(B}&n8W&:BF.t$UmhH@/iwJrH_ﰟ"΋`(-uѷD )+G }w"pYկC]l+1"l9J rm>pv*Z_ta6k ]Ӌ01X8 vfs|n&׏aoTpށ>˄A&w >F:WQ9b*fhW6)[# t=֢2CO6Ԥ˿;6{_4}qg@nN[Co!}/7}Oچ#2Y09aa x|fX_+N&P&K' ypPk}ݿdO᫰9ndF2nD,-&| t 9y(]' 2tEI^|"$'( wEj~ƿ/+]:\ +O:~K endstream endobj 280 0 obj <> stream xZ[~"`͈d߲,M4A"MkK^Iޙ{iK& hoWS˅SF>Bg\ߝap]}qJU*Xޱq$Vc *C-W@mc2 B~3+|N@aN|lVеP DžWkt>Ԩ] /BbH3R`,W,8ip+}塨ހDE!QI>D" a¤C-LBo4a^JqΩd,c|+оqNoIBm2FޔC*;&(u~~&vH 镋EΛL0~F@UO\ؒ}drTzIFv:˥JMnLaCnEKR[@f^Sukv~g81-ԑU7[ /YCjsN|sM|Dq 3sD@R1!+_Gk ~:pd8Y[BB5\Ϥ OMڮݮ4$A.Z8>mI` "|5.C]M40ٌ&{3*Mн+q~dюYB7Q഻R#(E)Q endstream endobj 283 0 obj <> stream xڭَ=_#:$f$"4AmȒW*VQ͞ f"Wݗ7m&rS(nͻj#SaS+7wǍ,7R kĦ_Vp?u۝:.rQdz3Vm?lU̓S7QtC&u |xPx my3g8Te2.O/G:>8:W ?>(<1U# |w{4q|txҟ Th8owT=gKtU{ cѝN 4q2!S2-s욦Y6pxp>7;q&͒%h\ϰ#?^6M=k- 7~v-##@7af9;ER!FT΍`3Ri=$<8ʽ?"p!zVITƞ\a~Y`P“>!(TCvWɏrD׽p!¨ !QWiEhfRX[(\3BNݚ8RC+2/TZrΈ2ȴD4?擤bYr<@P &TZF.T\Y\+.hqTTq+57ErӁ>h#-NuGYWE(168'u4%& շBSJex.+6v턬^9!z(eRVfXU+/AlviV)W(Mj^ $P΍;]~h>4?֘ )fKK@dn"OTvwgF)(tMd,n_]~;phWREth"fe33u?v۪|}#BR5Q^!R!@w#fIFCص I&0h#*l:֢\!`(w,|CDu\z{u7EclcC{s΄&vrÅ$u \u"3;)cGv*GZD* zrĐ5'̭6mUR[ Taw{O^ɍ p]4jʺ\x㉊}l7~nfQ pTݾ!M9FՇK>ӃTeYޝQc&޺C21)L4mcB~}C(P˻o{ ;|d w@QnBVhf)a@S{"^&'Qv@EǠ%Z-4\%7 zL OEUAά.;Bť^nA'㎘7> stream xڕXKo6W Z6E 5CӃbѶYJ&_P9IirϰwE*3W5~Էk+}-8 LaVMYpNX"(tϲ7;GK>֒f3Rt,ژEծ+`S򆼏%: @=}w\7J\"%"M;:uG4X ھ uM]8YY3o{jYݹ烜 Ī9~yJK[w"Rf[A&SZ3P`xA؞ R pTT @")ԜHBѹKo+ e)g-sH5 **,RaE/C\')s.nԀ =.Y$0K1p&Cnz]M_5IgYg*Ѿ2d]0nAdߛ*9jTS\X 25ږяʜRsm"J ><ӱ~VӮ`kEoZC* @g\]EI)4|1,iDp@WZ}`Lz=(n|0*a Q8yQBVERۭk јr" i?7Rе 3*~8g][pS x|u\t<2J1^ܔ\uwZߞ "ûehk9CyZ>mM+aQ2qҥ?NjsB_lU  8H"8* ]K"ՃqO9""9&v|jm5'Rd;AL7hܵaC־x&Q<#5GL0&{k]^Eh]k"UOx]hL6]#< txšִ:V&pȏgFwL4N/EFFd@f :RQ/,BD:dؙ%$~ӯD<݈TB<w 43z+ k-#.'BV>O?Jp endstream endobj 289 0 obj <> stream xڥX[o6~m)bl0lJmJUGC l} dUmc܏)/ʳ^q~y<Y)oT)d&v~mLIfa3~lꏎe1 2GJ.?(k&ұa"?>KpQii**B$cpg2cVP#cK)TzpbTcD63KG2+꒶=v!N~@+htEςX`6&o"I3hXؠ7p&ʙWZɕ7KqQ`l݉0=p|>a)q zB 1AI)dRz_  ᷖ5eRU%#)؉3j1NLh -R`tvG.}g}'?_)fVu0*zzʫ1 &o$Ct,,!gE J27yk:̳l@KҌY̵7ԢRv{jNb)W'p1HQ )K%sC4$›; '['%.x)݊pDťm8>-e jW'Ck= G¸&^ËCVLZI^7'n)FVnfɛϠUӀ&)pAbhşܔr,) ܼ p}\lUw`Z|tQ|l;Om߹[\ /XW@3{%TFєC*^j}ؿ'r;]zڇ;(i/x~Nj5 $l7?+/S>Xq/g=J:֯a@j|pG ] !`P Mf1g͢h(~j3rB$/CĬ[H%/YE })NpA]c?7T endstream endobj 292 0 obj <> stream xڥZ[ۺ~0Kd !ŋĜ48(hh]!Jr.dEE/Ù"o&O?m~mHprsFbswW.&eP4as?I]p%'б[(/G~yh{ pDeeҴ̫iʱk7Ԙ`-Md vYYnXT3` I*q%$qI٭d%olR+&ZoeKV}G ߪA<^<(.C(,ɓ0ѕ; ꪯy#lTr `0\1Td0 JqT rmRoUFNU@uV!Uw_ߠ&<9ߋ d|s؜ih?O@C b M{ņLE[%NW~H2`B=+gz91]ŀ6ĠHzj\K0J./n1tO-7Z4y%A 4PoA0@ͬz}Ȏ>K~bJO9IQɧ =4-Lk+@P~/fQXSM--t.R'msP=77w{mλ#^gr+[qͪ'oܯzѤVKT#Z1(SeZvuѿ-ٵ*b39 < I.G|sl5qO#oinKѶ}O$+xLQox#d"UA;DN Z+? YRb zߠ0'yڏL"EKb^6wɧ}"7YZ׾-{U7aa`TFDA:m/1]T=@@V!IRwɗu7ЗydSKffno7`vap=B\[ 8^gz%=?p;}[} G U=nƺ8D< pIpU@ !~?V_(u= *bH9khrb'8d֘a!;NTHK=9 d); XTkPйk @l>rfa; @l ,{ծ7 Hh}]?т|xZ*2I8\9DyE]8[  ܩ9gEh=aF=zKLgs׾g^&= 9T+D_ ˲ͥ3߁GY9)?o#_/>N^- , 3 S| ǁfׄEcO<'dx*y~h8S,FlPA" YoņEvP64crn#ZƑo 2cj̚1O<yy?xf,.J7PmJY6Kh BoF-1HHpHY,+ B_WqndnnJ,#7mbJ1\(Q0Đ1V L6'&$@=Q߁^wvG^Yˋ[Y(+o.p2̇hX'KW?_/B2@[:z@\ZLNMXr9Jh)Tv  ])HTQt~jHpy5le揦=X.RcBఠmkLAG$-"FrfWZ+,5ŋʃRgWw cxr :KZ _CчQ??*L_b(1rPo ~?rox j$ endstream endobj 295 0 obj <> stream xڽM_axV$K6M 16w-"`*UF(F>;N^Hj{bXA Bx*P (dV(+홥cN c3ת㭩0TxgJxn#'LJħ%EtF]pD"(8`u 0l{7ܟUlC\}Q3 +*Bbfd8(' d` \DHbvڹk`Qq$Ntp ǀVǡ]uQ[Pz0'iW< LQyq8p!~>|m-ǧIoE -|Y0hR k&+$(ۙmmpɮL(5ki8̙YcԃG!} A0 BcCh9E,_ }c+'ݜCJ4-zYZڡc5rjP|!,$au 8A!yTdTaZ2Zs^c9' hh{aE 9??wud>,6 &L*nx>1mzI1/E="݆q#yBzjm]=qcSB0n1[eVqERѬ``0 h50#U!֞lj8 Ѫ1CxF+p u{ln'Ww7fz~%XQF0)^ߝ_[n|nxu5%~c' GY^V{{5;oe vn}JJ*9"V( hI o U;r"J zwQ6+ % N+RFɄLьU4`?b\1 dTOQ}ARx!' 􂇤<2hPu6'NKENj*)^pȑBK-@-^Dtr2ŊY$S࿱ܢ\\'5kukhr8Y!b_p#,{t\me,j8NT@*6Uަdh:%j#zrτcX'"0*:P]!g˝/Oh,.̑.Xk"r{yU%bnP[gctI.H$oxUo7>~ xNcE2qnU(wE'Mx}]xy~4 d ;`jt~Qb)7>94*Q9^ӈQyr嚮aYTÑ9#r`Վ&u5D?F 9ˆjX)+g0MUkiz٥j:]+5p&%J3c)/xv 2JB^rj4l˨c7^gB<9KMFYMF^ők#ׁUIXFKOk6phuJ)$DHƄ"MiqϷBK*(%R()|Gf:PoQ5?]is$c\I}mM2g%3N\44:vgVqS mSUsp}&2(.s|P@*!dBm _I{/B  sXt-quQ[g` 14=Infua_ UkchX\]e4n o՝+a=_4VpX(T*!]{AT*2w"CN>=2L׮iƲ^}O?/d aQR>Fa$`)$O'ihgM '젯`ޱ#LfͼX9AfEqgކ+dyQZp29FL$.~s 8g}ː~0PpGLKƞ@&ǟ[ 4Ͷ&&מ-A<2!ƨW JkH4AY*J+gyc>d3Q op P(^/| @m_w7".kݿ6 endstream endobj 298 0 obj <> stream xڝXKsW6T!@$粕dRy\2V{)Zf$}7eg 6z~ɦ:l~|j6:QeRFimi~5y4]k m)3S* -U->u#tDӪe傹Ty$"8ֻ5W;xm[Ϗ >,bX˔o[9x%*)c<]@*Hhm #5dMt5.z񑄁Q:M^fxhz$265>FZ䇱o{jOmG?pג sY&@<'jwbPAY:+z[S n1Q9Ѽñ)V1,/=&*M,{Sz9tFԨ<:}nL ;4Am ,6֑Pmb\}q% *glZ?Q̀p_mwU3M~9޾\#aSʹx]# xy=|02 4?VrnjILs+VC6"E3n@ RNQ*8Fչ% db4F$Fi;n7k*  &SJS\VE (+o8>Q[ChVr.) GA6H1N$!L\e 0YI<ьdψ 2E pszn`â7}7 C=KO=;W̐@{E:C7/%2.qϼ@Bd#Y}3?yBiT<E૦m3=Q[pj>wcܸ}AU;5q ^O&ଛӹc`C]>035=PU6*,=#f=!J> h %텲E*8M8~gz'h_d&& \Qғ&i@ eLF8" @l|8pPPea@y7(ˏ`zildS9c1%b_M#MBUpfRINI[%V5ߡ_u {HG\~y~Č@SF <D^tl|AQãa֗^j PXg7;TtSBb|o^Dc~<@YoI=#)DAIeUΒc2I";sۊ$X bY;W:tP7S/4426~bi;b~v{UX_S' j֟+|IbDp9Jl[Yt*Hȩ=O^F!ʣn_Kgb{ @S+lڤ> stream xڝnm(a$   nhKMjԣv`_d'\/K//*(R&DԢ4E'-?]J.jN7p_$XkSBp_2K3YVRYӇOn@(}}Cӵ7FhTP ,֩Эtf[xa$ .+U܎qU+-Kq ZWKM ?&4펐}qE'H;٦Þ/צ}[ ϑ;-k5_mwM̅M9J!b./%YRdOVVl͢\܁3-A6ˉkCo49Y?A/m͇ uRտuMOc3 nDHAnjyH,ˏ("jQLS:G`cNH-A:(2y8Il=7@|t7q;6n,w8ѥ"Zܣi ] JN&spzNPf3FTPYZ4xWb6F-NBd3Nz-tUFX1(m+LNb,d-h)bU1i}fJ{ ǐҐ;< 9 G s?+k]`fV3?yb Fm퇸|Ж^ZtDHͽVb9h?H|ҺD{cZ_5)"7ϥ'nN/y'2 BIYrJQzz=ĕ@0jx 7I~IT֬sPY䘔hq|M~ZB9Hxd/BKparO\z|G <ͪm!w; ^ +mQvh Yt\iS|[_1xCvd7i ~Pᐒ% R?ݪ!a~10t@](|׿c9Rcg2j;t1pgObPK#d;Ze+͹,!rv?4|ۜAn5O؉CDRJ܊TNa<g]Ch~⶟z\<t>"Ary1he*oɇKF  G7`zMPW r:1S6xV'PG>t>'55fp܎Tge~}catR;,ˇaA Opv$vherglx5X㪞O iKXSlp|= ;C߽x֙mc~#i6 yhT] *yNf[K"zFR 5j] o_HBKc~9i, L& m]g"Č\u 1RE{ iZPqBME Rذ,@fߪܫ@f\1<&k>ŧ> stream xڵnF}bSGӻX 1b A~DCNHNds [?vzGrjw8~}촊 UNqm1zXz[k#f$InLMC|.1:Պ9 >)b;c6)\twYx<|+ip<B՚)GDGz EA.]fl|O, Լ畯̦:ΓTD5Y繗rx8Ȥ[gTgB:A>MW#Y'CkA!IKf#&nY)ePѩe]߱ Wo+-3@]yF4l[ h?7cA6{b)KVx:Nf8ꘚA1E4yFiQfe5h R8nbO [bb8O3U3$a#!Ļy)0; U>&f)Hi BK~ <} F윿|i̝OMr~ɟ@$ 5_A]d`4_T"Xz6p0c0X<mU _t yBWBօ/|"-eX29;SVJb Fu# w9W)uYXf~'ĉU2c$e86-+j[,n(IWĩ - *5P ,ٮ`OEy/x!;e'2Q ig_R4\Ž  /#F*L8HnbjY FcVwa°:9M#w- &|/-G2<1=rk ˁpZՆ+Aq:)$Xi5k MQCCz} qfT>sA)# max܋ [;n~8JodXd^ <݃RkUMt㘡q]GtJ0BI4U(tc'.)v;."L;%Jiw~2jk,ҸJazX  R*R *fW0 t&yAO:<:V8D"UaY#-8Ww%@B!ΥLrAv1Czx87Yf0t*Gnu%e/#! O# :@y⡱.$ᇞD B,$Hs:/GrQS%c_Lj E\Yv)h́s¶J[4l'Ό%cŶ ih 1櫐,)纚9NZ8U煾P \$ &/;!H__y$0'<Un3in35hX)3_C 'e"zolY CC=fGU~ jmϗ~UZ4.1.G&: >yhXL@.g% 1Ha<̚8.dc/i8B)601wUnUz09eo2 n1y5D1*--WRqfsΜ:gFN, (w ӾZj7;aFX5dWfqR4pƸ׮ƹ3z?~u"M/ɀI@Ot&Ur?-X1Oq^̏8|\GJaĆ//Q8qEYD." X:P{ED菧rh^/3Kf!0>2jщqf"*&h~(zfЪzSW狫6u3.,m! vjcА%_6H#vX 0\3ƶOƦy).=ص 6YTsQ]Du/Wu_&kV^Ն^5IgjW+O}9\Ɔ \ki> stream xڭmo{H1Zm{kսnڞtdI20̥&Uily(RˢBџw"ҤL,{2e2)?ť|k$,e}J)zl,="MRت21"olq!m7O6Bǿlm?T;ضdUBw;Ѽ ܾs6IQٞR2Em\mԭ;NsWXgc!Ue9ݯڮkW W>ͤm G~:咮4JJC52vXWDko–2w0`钱p)0/taD,u"5I~Ho>\T}߱`; g8&Oj5!,;C}'^ƾ&2"p*e~wj9xVqɁg|)n]p7gN"_h1O& cdmܜo@Lr( ՔXG7Vk-ʜ~†Jk;t>D`ʤ0\i,矉L :Ʋ7wu{<|$1aKtn>rv+zBd JZ[,ԼR91GoeXSjtjХPd/=ldw~X%|p@긫=GKͬnoށIn/1M@5VXk+K*l3C &/ϊDK9Z$N&[9XjNvM9:SڟV;}~H */0-fy( ^˶klTA@af!Kmu@cM5j{._#j j"=e{4WtNh^\,O|c]_)njEYB&BHGzK !dTUpxMw f]tj$s.q,"?")]ER"]WP:9UB% L>.]JJD a־"(T`Wcd!aӁڀ6 "vfaCZg\D)E} Zn6J/ǁwĈnB} gŝ.Vv4TyG>F(rj$Mpª4OЎոS)wm ,EBZ_8ulI_Qa,5ֿy5e 5v^Z^y/=-r:QS;gPtں V/u*x)GD2ܭ,U5 _ ۻ(QFK$ ( W*=LGM1_,Kē1 D[;~57f§P.x[Y@@[!ruU=+i(-6dzr*.ʩbiΦin$ lC.$j^A~wtXIᵅ qIaXbr|!/X^wMh D]:,ty2hoS3::)SX3le.fF$ve  GAgo^Lnq>H fiaI~|I~u[Z~*{p vS{@:$os8wٵ)㞋o.P3WPs Da9BH-h^8Y4Їo޿AJ߾8TÎTNV,NJPDQ$?^sCh\dh}7L`C}key^8`~ l,8&SЁo0/ك t4 򲃗"@TŽYF*ōrD˰)"^m@ꫪQ|Z͓P)OhI& U$+7$]E.fO*h˛v0ݏRn~zHկkvS$eU?)(J^ ,3? x2}0>0 6W所7%.arťr )9nc(~_ic endstream endobj 310 0 obj <> stream xڝXKW}YhiŇ^SvvH^`8YȒW>U"-ՓF *ɪW/n܈M bI7iOr#⨈ y:lD**ty|< P)Pk|컭̂iRD:KCG uB۹TֶW34P z".r_&qT@du=NTǦ{^<4f|D; pˑwKWU&~T1++IrlȦ$x/-y,qVi֋6N X9(ܰV98A >`2Tex ;qGks(/4Gjm 5$l["@!xކhAC~e*g # 0ZGn 1p"GX\RV<4L7Ж%3Z'HvS'IemɌ$AO5_˴ʒIT,L2CRl.Y@guU{%#ix+JtbŵvC0q;:PȨ.pōt H;tQE*w|9qp+51:q0NQ3!:w^9Q'moqַ'2b̵Vds8E9H-/%D$Ú.Ml EB_gdNf:+U~X2zk-m=pcFHa. N\0]ΟQGPF7`-gY0Ť2*Hi̅kЭ H/J[0.S̲z3{)HIJϒWH.jo5FGG2UiMFl7Ɍ ɟt0t&ZM3qwo;WQr;9{Zw-RW\ RWAyI :H ׅp:Z9=IfiI&;(?r= _SPScC(~ta{{{~?/~GW~`6PԮ;`wJAc[?K^땛/op Bf\RCl&[Y@`&%6\"Q"]6%Ily`g">#G=ܓxpkKdjSr2iuЙܕva=fcf gVeAB5.)S *hQв׵b<=z$Ƀ~j?J>@ 2`V JBe01E#]ۭF(sO3&&}ifv?7CTb\"$eL-[oͯY]Wx `eఊD.~ܫ=5(hY ?Peַ_F4ߕ8hO~g革8C򢹠k淶vqB,m;RzX(#\ lצeA sیl<4OA.C! g ˆm)/|ZsXQʔެe kMbCzcLDv. 6E X/V̽*͗Ϗ;+)|IV)ysm]ΛP6%\࠾HWnC1层"mHh.5˓g@)3[ v DNI>ՎǶB'Ę'$ dڶdp@=UzBK7*%#] 5(%`8"VkmD"Yv,}^y8  1j8)U ,5 tn v ,. İL5TFipy/^ {vڻN%ydw"+}Tkuџ,vY)BEFa{r>G"Epph, W߇}[V_v[{/O_l endstream endobj 313 0 obj <> stream xYKW9+ Ec tn+ג3~X,iRdX,+:-Q <h[GwDS9֏".YhOt?"sfr qvH)uW'f+OV+a/Dob">unGVZmF} :.9W+&s4~MUlq_p2(ccح=ePlD;rE@J@`]F3ʉ4l(?u]4d,5 µ tݻGWAǨt-6T۽ #~yԸ+@rjڔOԱ%e e^m_~Bi/)}:f MXMa %A4" )/I1ci'-TSUtpVۣlWrϴH1cG_yH‹7v0&m[yihЂQw vG]4D߮r5eQ<Ig79FS`Z8JxHZ/o{89P4."2[ԭ?'vc7l9?xhPDCz xONVWGuJ ˪޶ |u{qYγk7 [;FA8.eD[pzik¾)m=kT"DŽ(aϲٕ[ AEޒC74ngsi,p4jsfE}Gs'&\ >=bgMFPbm찍n_B}qE)qZt صuTa g)K2oSʣsk0 y0Yǡ*Bj]dRFBθ*?[2=eqB].w$_.XVU}! 0(3ZmS F*.C8Ǯ @XC&~_"& bmhÒcOx@aɩ[06t(zvG, P-շ̿4,タ"Oj2pʧ*C3u|ҩ I߈OӳL}t|W[XuU5א@Pap $Ҙ,Ϗ_(o5!CT* $+(s84 mʾ.=.P=9C<$hߜ{q$H b2yzБÇFy!4K "wK< S#ibwXd'"nEb΋g^,,F/\`IɌ4#0oKaI Y6D2rf r,PUc>TnQ~( /]`̯Bf殏3i`O2aQoI%B2kfgӧ EK 7r l\T1~_v.±>l4oo7*6/͔7V]^&gB3G&sG71ʱdKfOWv霏d$eNos 0֧i 'C>9C; ,-D>Ύ!.4^F+"O\`> V7(ԥ#GwgiC20XՇ~!\H.q-n$3/#Wx1DkBKpdP"l .B~W,ϾB"/ 7 endstream endobj 316 0 obj <> stream xYK6Wr u [ػN%ݤ2{H 9!:~"%Ja*5F?igٷoy(qԱl˘͘ Nl-X>|*x*Yq^{c&"ZhPSe[e v!L_VL2{PM^Ɵm??VJe}LU6 {0^ ߾6E욋A0Pփ+&\S`B߭Ȫ g 줡6ν~?Ϗ>?`z'xRHM׬Ȏ7誾.瀑$"m6inCN!yxAS6Ig+|v~6t(k |qF&ZtwAH+]12+%liFNc}iJ$eANO|/yD9l!K t9Ǒ F6Ǯ_ȵ#@! rKrۚe^Z\ן-9WCGgu-+dDI\( ;6 aDVpG2!.߷L[ t+;|(79yɻ ޭF6xGN8 .x":#ݛqC-̄(V*9̗'5C wzp7W@)uD+e@w1e,g.SCnfzɂVkeve?;]; nCaN7mv)brHaL]vT&|OA0S5BZx[AlU`/U]#)| ,fibԧ]bɌKZ*E9ҤY!{cPP5ѓ# < Opi4RO"NLA7wd f?-$*v?kACuá>GG ߾rX⿠",q`[36$ȘD{?*Y0_\:mi 1Ac{ ;ww Vx|9< wH|~S{2vQ 1PUv oF]<3YB mC^ o p7H_=H E ># F87Rȓ #CBI- h s8B npRZhJ5~?+NYpR^(o5 HsD`/w9q?Gq!XDn'G"jěi$"L5~ѽw} OD9v""5T)aHGaRS/~W N-8b [ 6yZ Det3ЬH*Z L{3Y 'Ae>ZvWayZr42 26,(eGe&OP |"GA>(-;5(HNa?_ endstream endobj 319 0 obj <> stream xYK6W ߒ2L=@lAmm!L~}Xny3ۇ`0Y*N'"O$<72f<:O66IT!-2XԟZ)nv;L5˅lyYpQ OĻUVTIS$s7"ov_]f9JêWnl=h^X5Y)dJd .K'-W0{<4KSW<( 4| $$LI̿i8xkxhO D6#Ij!ȋ#r烀ivYy!mut.J[w˭ 7)yM`VE4\v7wLZV9ӂ fWu}vm.`BKHk~.㰌rI<<0߮r 3bk#M}]vw˛fw`^hsf1!%S3+46Ymj,o9<܉F>GV=[ӟA!7: uNg"-DxCj[]z͐Ԯ@dZpj`[vaԄͩ)CfZH,r;}ve'lh}8?V*o@:5oB)/d @`WKj=(Rh]W3 D<{Hw1;ui|I+kHw\4Qݕ 3fF^e&p'BIZL hRkZ u]g 2&7L~NJ@Jy|nTc[w}EfXb7[B(?l u2te Tr P#N% IW2cfG׿i($jW.LeEP+,KY]҆uMUqfׁ66Y1U)pb$×69 A|G떑/59Y ރ$LLE˭o*Bi"c8ʄ A!pEZ甹QB@adVڀ#AncA&gcOɆO+Ҳw*40rۅ.\aAs%12xpPԴ_\'A"%EZURByhPϤA qaEL ,7NjvYBz PWy[gTB'l !95/F/7z)pU5cf(@`tª.;LA at ڷ'.~R+A ۟zO^G)s~ppۏe}UL|Lh?%7cEn^4sNJ vE,?ys< kO!o3~ĚAQ;UiLI2ɣ?, 29UBNhlݒH0GqmP8F>rH>xLKox,3ӣ{NY&5p{} _c `Zpߗ2|y\¢(N"wPE^6[C]~פ']]^#l(e{No\4!UZŐvɾx/PcҟxX=5v?BCy9uaUC\A˗_2 @ ݭX|勿: endstream endobj 322 0 obj <> stream xXm4ίBV"nBQEC.F6z=&^Нx<Qs6"|޵&ñ_?&$)6Ch̭ >yHdDQauA&{]_*ǭ\L<`u4s]8n=&!IkNlɌd$|^ͺ}J8N2;ZbOIYFVם.˘ =2ڨ7X3G4 m}VmYq`/ yJ̡)<4of[x~`yheΠ+)Y xz+Wa3Z` Omw&^w}3`3/ Z/Kja?+' wZoۀ%t99S ID)1Duk oi<%:=zX $NVqG9.QЀء|"UL3KqKPMckgp~hcgƔ2hc*[ASvi11Yc?ciq4fF4l(ߦjEז44 ön M$q.fa[4vUW(Z[嵇w58 }}w`-V*4K",;t~1Įjv 뜩6Eh~*$*N$E!?!N{@"#1?A5_X< ^9Z3XpvxHٺy1 P"I>]e("qFh/?bq& sX#ēɗ4DЍyMx|a (bFP8DIc0-/$ȷ0h r qHa(l;8Ll_T*KGn g)ɨ?,/1?q*<+.C`n+_œ?֧*Qa VNe+=n=eϞMtUpcVƢ$'if|S濓",yս94Ubbxh7q0 ѴhX-6j}2q3>e L-#B&kڑN:2;977P8}d\[뫼pY]^G8~6]\y#N]f1mldSGe3|$xP, L>H&6xcX#eGkKI^ (D=֨$CŇDiWE@ o4skۯZ&u &`E١4 cnDMoM]Or#r}>PXVîvO&"Xj| z/5zPmnﬦ˔ӕSI)m/ g@`/ |ݴrp܍73wtʳl[>󥢯nHW,' 3̷"^w~-{~o8 endstream endobj 325 0 obj <> stream xڭYYܸ~ϯ 0-K$un6}Xd Vcz&>u:z4'0lyXW_9g'p|8^꧁?:AKUőiEi _NJˡ4] S>^v"vu^@>7mfS6w(Q>ޅͪt˦(siNѹE+wjlH3맡XKrrC˿<~αpv ײ8icdcW·mS`~h͇O M|Ι:hΚt{Qֽs}lksF4':F"4D";O%*u +DHg^*SH GN#^09QLO-+H ." 6e#t*N3$Em؅j>Fh+]˪B0$nVeov!D9huy:/ʁǯ8֎U bVUɉI$Nom[*Ad=?vm}bwZ7kTvk oҞBk؞Ph!$Yx2G2!LX&?z;舷u@p4,֐y[߁ah#l>D\S9G;k0)04+!-tQ%)|+u*)ԏC3Cc2%2&At j}BF0=^vfI*p`:`HXjJا7Io3I*o lH4F% mQA.y*Hi!/xpR!pi=6t=*ZhL">"2v~ \&چ%FyB!D9^RNI%juFB\>|si=pFt_ lBsq!⯇򗐜JPPSc_\LoFe-"KK!do,27Z'ȰafG3%7TM`z,B޽$6H=@loX+QNyxFaD;5+μ3W<zzzcDh+n 3IJ0?9)\x)#/b뵶먡𦌂}@)C36pwT7]'oGx> pa.VՈƾ&M=/qlǎ[cMŗҝz پ+t,Zº\ i\NG3i0r&glz×& ;whM T[/fxǛH= ,;;PjKKCoOcuTLvpTɠ8Lh$jTNx)5CαآR6*5f o>I̭Ac$d:́3x[24Bntcynh/3obaPV=o8K~%Ɗga矼 U\ j)E r䥱N E wiH}E&349;#0X*3΀Ԇw=Xdf2Q&n]>@V8ɒ&}gY%.||4/em 7/EȪƈS`2u$*`)Ǚ%"Mgn5P/s Rteg9LymYowJB?zxwoގ?-K !HߡU4l57` tp2;#@x u"-iJGO8O-Y:) ,iO <۴fߘ?ΉWN_*aP³wrm endstream endobj 328 0 obj <> stream xڵXYo6~R2!JNIxѢh@^5Zi#i㸿3R+m xa^h曃>FZpKx5Mޥ^SN@o7:Xڙ]|=gpzg 6SLb, 5uS/j{i MeTŦaY8&t\-D9oFxN>]A j&7#ԨT,4.I92-7/Ա_6heG}eyzs^%|ƌSɗ21U]E`Ya]mBDEo)sO3 KV~U7t߼gq! suq_@߭npEoGg9\;؝HЩCB_QEZ@Ɗ'cJ;X6áS>)+Q2{9WqRFH!Ň._YS(W|[[eMlR)`%iW/Rw*oуKsBήWe@^r^7xV*ZzF%r@k'>pwUN^PC(w y lE7UCT4-YZ}&3N;ze`\o[ӵzBPϥh 5B`Ug=h5G907BLp }?GZS 4t~ ȋj2afx/KTNP{#»mh4 endstream endobj 331 0 obj <> stream xXo6_!IjVI ( X6`i݃b1VYDGْ$kb$w}H*+I<1dK$ߋg lnn.Yl~OyWl~Ld. H#nRzh\b0U,Wn`"-C+z[6I2=WkaҪCGrmHsDo=Q><-cRYݯ`r%lz$ qI4 K`6σ~mijoJ<⏫Ӳ0MIFWn2kJWd-i|ۊo\͵A -&si;-T퇺k+b;`Tr/[:K3#<9WLq?~oKe,3:򱥕֒kf2:n4mܰP PTνjfQo4Z{l)Ciu.T).g#o.lb%m6`dPaAz=Rte?2>!Pޗ 6MhA{ٹQDSX> H-S y0<2p"O];OaxJ!phC!" ,0-8EM"IfEe7 z~۾kmۍ< TS_*if[ϖk_\܀3J[E~!3oq>ƃ|o?CViCA(5R^=Z0B sCedT E<_]Yl R'?v?#baC~CG=z2y?8ÍIE6aDM^9G'cx0 G|fLrѩ7DԂ;SY7>ތZ"uh=ݜO/NB4 d\`ò˄윱 G!)9aA5NϰL@NR \ b& -jr)%˗>u{-4.~iSMLP$~$~ endstream endobj 334 0 obj <> stream xڭZK۸W趜x 7'籩!M@ЈԒ:>HJ=Jyv.bg%ey?ʝ2+NWSuWJ%ꇧ:c=ILC>;-(KYW`a\wFuBrah.S+%텅I[?9fB$窻V-]7 X?=YxtrT?wS0jI4yZYTd?>Eru N%C>fBD"SXnyתh<*cS D:(5]#o(ϹJz/GY`t Lq@)^@_|VqkV`s} Tm6C\\KNB=͑Df|ө rM.ˤ󰢁kL<{"Q@:$L:DM 9rANppx9Ĭo:ެ@oį Ԁ 5j '=D=+)馽W$Uےi9P gÔꠞ-<" ANغDM13wږ;Z+4Ue4,_1&My/_h؅e`P1E"3{{097u-KI\J]_g°8-{V7Xn0 Bӊ0A]r-6Wj!giɕI~b:M9딇=o[,Gp.8Ȭ 0WB܇#2q!8#-_e&zs#IqrBV╱(eac@g* 齯D]'ZqJPQW.242C믒, .pbV_wpx@lɃk;}!Ӣ byd~Ѻb}o-fC^:yjZLƭRTw]Wښ=`c6iTr:BVsYE&O8;W(0A5o<;\I݇~&~YN4|kPYlj Pξ 2}B37 0B 8bDX%8LW>s ?~VC#:Y4ԍL٬|fط-Y=ArSa"â|n8=ҭToP76נkViqZw@_P(ӵ5ıRzep]nWpY⁋UQ$?8u]&u3#'t<yha#,1ϛ,1n~E[1.jLc#14'ta8{;LV-ct I܈Vֱ2(pj쾛hsX/;DBQ-]7VA:OPJR ^hѵN0/nO7rkf\ &Zg_{:KaBz6܅U9MР"[ẻ`C(1_vUH/|PVD 5|~Q(JES@$E z} 6>۩&@ʁ2;!,T25J7h;J*<:\ʜWX,<UL&Q9V rp,Mr;b$Y$dZ*=Sp?(N,z^τVxAHז|ktޑ\japz0駩?lJ9ź {la[$lsw+ooÇ&b3$wAȼ~>zxpfָI3&&&<-&Iti9H#[Rt道k^O+p  :$w!f"nyW?xEz ZPEg hlJט6+e!> E=SBZJ~S!MA/c{x%ԡ~mM".ŔmyojO/LK4w/?Gn_jw 7qKb.}Xy"Jnf`5ǒ@3gx͌,jR(Y,_M ?/lš/'TƣW YeFoh|(R]k76y3/7/'> stream xڵYKWfMՈ&IT\RIenIZL2Iק ;kj@hNR'vxgiR=v =ދxv)sٿZˤڑMgp&vl[ǵ62OmH]?\}YαBO +ET]vә~s=i` 9m͎ R J(%.zSz *Kh%ovAe qmz}f`|qբ&}{N?ж°0p}.a&9tDBg |ͧd*\u`yJZ+DB Q昻6 qSii}#IR&Z8hKZ{| lypeBE?[[5+;},QCwR"3(?_CW~ۘTmmulF3B_N@"Q8#ÙT".UR/WI]SqfT\  9)30VG;f-0XֽjNFP@ߟP]պ/q.{|lX{)kHl:%KJSpzEXm4CMCt gmutY.hR3zZD݇tK|_rלT[i{&&Oۙ'mC mUo0q[*_e|21` pЏ[-җR0<熲]4l!cgS)b-ƞeAk4;)?nA%W TnIwK>|#+~3Gho6u(=5PVĭֶoKWDg+cc| \^YŅ%wv@tʗCwl52AxV+=aFÇ%&;neD$* ;_Mx}-TKX-diO{yp/|QUPJ [6n_#xU&V#BDs{S]>U| NJ:7"L 8If%(tI_-KY~ԥAydC3.'ِ6z PCx5B#uڹY4cգi]pDrK4}4DC->no./)hWKOIZvȨ<ڂVB+n(/⷗4T_BuߺꡣCH%$w*Ai~p< mN4 &ۇm˭œo6NTUA%V.^RX1A7_ŲM. #9NBƸB.]26PvWE2 5BElHbxULh6IʲܴSsK@W\рk$XGE(=)u ȣs Tq"VP3,gU #Cy#"p!"n~8lx66o&'m`MyOot=t m"LKFhq$yO oY endstream endobj 340 0 obj <> stream xڥYݓ _ɓ<։LzKI'i}gk5Hn7}I-\ӹH ?/+Xfi՛r%j߯D*u3yw0Tޮ7Z]߭eLC\+-P%"ʗq\]Жw?SBEϼ*&\,ܷ۩Pb22yn]gNHSGa-6f?:<#~r,"hOsIA Q F풗)ETi&+(hMpARKx^K { C)ap=m"fG IrHC'.#k]!.P4/:7|\ƿOtWž~%O󪶔{^YyfGȓ1 <-+Kd8|2ipP$LC<7 Y'k2Ksz#^B?X0=`%EQljeFY%vdjz{bM lo%:xGCB1oI{ā@" xLUJ fkG /3;0=g uhJ:USEb馘zN~JXs##Ŷuŵ3uJgpdw͸Zvgx)s<҇d)q]#"pܑ22Ɍft9@05š>"\+p4 L1G(\"-b1/簁)t4 Ô IUmJe-?Q Wp*<q̣uL4ry#":E g[("=_P#\P^hR'2[煦@+PQ 84hY[~hNR>DY-!H3Z?Zk\r s KzAC![@UԿ,7*!^X'CÑX +H!\qb-``{wnr {1?b|Ea]V,i\p,b`LfB_b;Vd6ま1[-V6';t^!&Fm JO\](:A%ꎸйcї 2.z9;߂?=\޸ZY MzUe\M wʀf,Qi4:m|F ?--`¶#nqk1&جTx2YUnКSj,2o #)E:@R|{xi)M7ױ;05C$lNF;y1;S"짗?x+Ct*S`L6'fc(2ˈ_Ƥ􎁒#IQBBizH#xFΨzTV&FѰ^Բh5A6x \D~] $DW Il=Bde`:4Wm*("S/|m{e6ob5/饼？+@7޺6|޺? Y;|}aZ5ZGnBsa4Qt<&+B*b1| ^N|Qo P^j> stream xYo_og_$A EpSy*3w@wJSwlGeeQRЂ; wLJD*2XGC3{nrdAr&ͪ;yQ,wRfȁQ1_,fjW$=1&V$̈́墋 H-rA22FwܒXʳ,|}h)zrSo#i^2Kq-/OCMhWPd'L)^ݘ2uR9ԝ}ɘ:CR @-MOf(QʡNpB,Do? Z~ A}S]b\G-;<ͼ6]땯FzUf?lq\Vޕ a6)v 2 {7(9ɳ %޶B(Չ͸Rbvq u}O %)[ڤ:Kmߣ˶}Qm :b3ƤkS͔F5 X#ėC}qrȗ0`4bV2:4 sR9- pIsj0%YEo% Z/`ՊkV416 ߍj`DT@yt C|𦤜)Xk4c)颱Cy+4J׾6DVA1z_BfnlbrbC3C#V>`"Q0(;_@s0OXKID!߭0V| K&$vq)jB~Ŝz,-'  ,чc` ;~gtG-ufQb )S74{Al%rbs!ӗ^0uU3Newйtζ>Fuܲ*l/uʕSZ*|G둩jY+}(|z#`npZru, m}X=BFeg.TRikWmTʔچ.[]czh*2Ek|U XtgWc+uH["܏6/3HM-]wPFʂMf6Xe3e*;&*;9+Z֍gNo+H endstream endobj 346 0 obj <> stream xڕZݏ_a2pVHCq .i 4^E6:[^ %Ww}g8C )r4$7r!?(/oS )JTrq]r!~K>Ͱ\eYdw˕:Hơ/B<5ήJWi)]|lC3/˕*Erøk:Ֆ=UrNGNu n6DǶN'& Xm84OmN9fC =X@2wp&+Y7S=H%O7eujYz y، _3"U`)ST3)F3b|rYeyi㗙q[2ʹbH9x%* Ev$~K ء0Vo.KMOCxہ) w6֊A;2C}jmpD7*O2]m v{gRNA` .2%iGr2|EKLz W no=myn6WeQ)O1_<{feoO#w /P¡͡!<&^K< LC$C,x< iG~2r6'\oڀ#:-yLʜiŇDr<"[p8,^G<;/ZI05@c3P͡7k`i`&IG/+ ?oL/ViB0c$( 8حd@11t.û, ݟ!(DQKw,ǵAn SL/'$ 䢔c=pw82o4SAh0g%xgw &r<-my g9oGHyǡ?֏%ߣV!{C%!ϾYPe yĭTdsGxw2Uv5g,(Ro|H< TΚHwJ;DQeNL}b$Y܅K<< )!UWJ+r̷(smkQCm%$IKCqOYPϔhsg S_,KXoy ~DP B?#Kw=FV7lӪAfn[zI 3 n{\A:ƉYoSddnޥ(!lWIŽ)=Qx`JTO6?a8GCQBz3P: K-6j6nbTQQHj"yvmQJmv8PR]|8*:Օ; PۛPe"KcTUsG읦X -B"-r:N_(8H-YUӒU5gǃ=a@08,`MYe`yQb^y;'Z4/HW3dS H\I`|g]a&oiHi;YGe_O˒h ;ًb"bT$Tl8l S,bw\8oSATdil#(A0V٤Ԟ\#6%(GY)C2ŐC@dD\/A?V0q؆FrڕH\LFͲ0\S))bֲzX %H_X1HQse07n6r`)͔s0k6('#J+LiB S7O3}"! *3ƫk lwsX,\VijmN|Έ,"&WvLmtͯr֜+qn$ArSyPU:Jj@g&|q4 Y4]1I1%L8#8or- i=. 0m6.Z-kM+uÎ!{qqmFM@%M1hl'dE'z@0ݣE]kV>պ::2_ FVl K] sllH3YZ7'ʘa.Ƣz=v:Ԏ2Rݰ<@fnI;o/W`AN@aQʥk OE)Kfyx11Jk-N2rת* ?9[mq0Kԗؑ"npVNкz/\zOwpd_1XXL&5,2bhwnNT{G诶t,9ϧ/eO=cy@x+IP_z IW!3ũq̸H&dd\,6H7f["E6k`L5.T7R92p-jK^V*H2e%^q+]r=I:T}d__2pөI{:9>◹%UEgbzG "h).RS&MH9W6cu'JfAȦ jڡ"_ije3׫*#TC+WU6!Y0sn3[,\7 :SΫ,_랸 B/G ;Lw'w6w+(PpOP8bAh!Di?_p#6?zuq'> stream xڥَ6}K@[H^؝좁}Am-Ȓ#|E]Vw3hbX[w..S?λ??^(,"=vquX|t1cwô`7B=S=4:ڏ'<^AZxq  :ۄ{M<P-ݹlOnv M'tC@h4^ϥi0WZm܅5H.8?׭u|[e{Ku *Ս`=<#H03 JpJ< ̈b٥<~޼S:w41^D@W ѳ%EvGN#y8|7"`ywb4$ܖ πcݾ0 es{PiP (<)@vrii`S)x4x`^! Aҁ= >1?_O̤ tWQhC{@v^SB_ŢG^$⠷nCxf{ܵq=k_ϔ\^8) uq E&zvG=D-pΥ(a-XIDr EXmw} ͪk&|W %tQA[ sޯ%aS n}A+MC0V(OTs"FIÏPZ1IB 5qf.|NTЇyyo ?U8 azBCw"Щ/aUSW{}/cLC] 8 oxdafԻ.=NLh\|:\Slz ^2Kwu:=Mi+"AǨuW:EiXDvOѪ!Gr.s{weL&E R &XvpzJkƐ*[+ʒ5.4al)8p*Ob 2~!/b`ue:.' d%A[C:XնUrdc9a7@ +f BHPS/B] +U+emsBc5A֝P hp M%$WSVLP^`4&8*=ɆUfyo&v&%3C8_P׾Q"<\(/@]+}lu8w=\F1L@@Z&@00)/̽/"S3m& i")b\^Fj Ō)\ o *M}G*};__"'jWh.a2E:I۴g+7z6q)IE ->c18V,Y[U֙*N݀ :/RIxYCSJ>LٻXI}dz$kD.eo[`mSym%O,UcO$[=li>@MSZ2~\ R2}c-S=ʼ]u/BH`lcߎ"NFdI.q>eIYeǿԮ '7x* '*N31onz_HYwӐ;4?^E~b:]s*gL [|ηjLrXg,Z^ytn8+?Q3w})-kOTDH硯 aX7H| RGE#ggz?wo7x,O`=õ_㮿`[2JgdlG!me/-s)=qy޴Cc+:\?4ɓ'B^6˾c@+ _G,ʎ[ Co9o6z:jڠ w÷]6TDɛ{}y,;h:1y/]Gi&dfd00E4Y`}D# w v5z 1cMͣ)Cfjo~ܛ( M,tARe' Tɉ8g_}ZI b4O`c_=8y> stream xڵn=_7S>Ǿl[!v뇜红Ο/_v ǺiۑwI<DN Bd*!p` G//mwË L+Ն{X{jڪ{z veڤ_5*a|/@M`F=J=˲n^qce9/@$&bf'}ע>ʹ.2u;/=|;T)f;v!ۦ}bC)nP?Jwܤdژ=k"ӂG؊I_ \u'vuk`a</u<3]SʆJiWNøp6q,{*txXy-lq[x$bScĴ#ױTGe{p&>ŖOja1L{#bC ~˝qq9G^@gG#3-#È/uᎆ.|] 8{0@4>_c9x#[EOM5iIűnO\Gs*dp@0S"d$n$I+1@%gOP#:nd41_JfM NLwfz̡(('bߠQU($WעYTQԎQrR}odH)PU 1j3lQQf*HJCpkN68aթCW]BXؚsec=WyudbRb-ف6B: u`V1b]vɋ9NhCgr~@ۏQʕpzJW&+õ=uM[S״m]#-%k7/nllArDFUZGӏܖh]#jrR.Bn\`tN^` jv fk> #~D]nuJX稇CҕA| m+ vS8˓FJN8(|Eݾjra< $[+ಥ+ra]&d/($zS`vt07o2bn-ֵmFCdΰ9N|!<0cܢb}9be~__FgFCs"e 3Lu O~K2iM*]!Eer ׈iL?{O9' v6iс6XK/v#mve#u׶ĵ&LaY;:27BgqG,t^eO9g#IKS1Э\a|1psL؞sճc:c*rE΢)m,2#7;f dH Ǻ.*q)?Og$G(rZZ뺶uqUz4kVnIB]t=|Lwy#> stream xڵYo _@<cnqŵVnC<${hq˘8?~/,*O^?>BVjY2RڄvRJ ]Kjo#Zk]v]s!Ŀ6ķ>~gV7O od!JFaee5Я־+[DOHDQZ+_VkcMyzli}PۮoNL~N]?7é=&~{X}17?Q͵B*[FHl\yB%Ty3#ڱ/KHw$@ `Юx U]v=6 秛c}wNqų~3)D;k<~ +Z( tAf>pS|-BnYx[|) .^ i+,Y+Sb`=Rvů/WKpVt>[ md]Vz3oiÉH%Jr,$Fѡ>ہ szцFHb1^Gxlw•T|X@ Piȱ;hp!0R`y 3?fdY \E`FS/j<־)zIoBhm S%-s)`J~eˆ~ E|?r0J DH(y=>M?ɴ++Qǖu=s<oJ5==I C{>eqחWU3XYB)E6vvkY"K,GcD\PXC Pzt$232)vj8Q5(;*2{Ss\fH5km%'Gj$%(mNwX:% '/ TvڍgQ tbԎE6N,kz6OIգJC% =*=F(ILMSS?7UQ!pRSif͎ˆi{+Uׯ4W&]_=3+Mՙr2V%GF7#0b; {%F.8%Vη~ho$\68?5?*"+IreM({6(CFԌ@b<OR_ ׎4 & F:+WAK'."vp``SH r4\cv)EMϘ]Cy}_4ȼF Nm3/6ҮfC- {[fS3|MuG7)-*Ӵ]z u|v2ɶ>2maAnoub΄'J$|lvDI;aAjG5}P}VAƕYs4z'CfXA7mhrԁ؇qF0E @ }¾2HTzC׀WrXHCUF> +ĄmJ"\:X0:۷0BeTZi[6[ُpĂ?k \#ھG48$8$Ѓ !gHHPcV 18OJ\F4@>eT\9,ƯK]z2gjOZ"6Q16QS/rQ3nT5m*fT~  LS5͏MsߏW=Mv:ޝY9CuTE k̻AW@\DWd`2 \&`2KU#pQ S:O(TVE0pQ#}W+;. \XYyV$[2z1Y$/|vƯ!^h_s3a R-I> Լ07e^nLEUn[,' ]i&!a9$2aU%{X]YK_.{+#S1-߃=Zb&*VH!?&M˲G @9%9Njw}>+:N<6d2B\'gz2-dŏ aޏ' cS\|B@J;D$o*;gvm.WegU,Q-) B (; endstream endobj 358 0 obj <> stream xڕɎ|1hƥsr $ 9R1E$5=ۊĞ`cU7淍$Om2 fqGQI\$<7*(6<t*/;cLd;kmSlu ][oU.NM 1 "ΕUsh_ Ĺ58Ik]Slg|PUM_쁋{>mw]ݥ~>,F*֩ЯPNW2 8 e{&0; YXfRn5.T%qt=>BfefATC1g9Vr H*I #YRVve]"?0yYӐ2&NS-5"cAt 10$^oxh/CB]mnh 3HҸBox#c٣HNmͪYdIl].[c CP59Y V^ ,,IAL ;gJ i+FTR)l %(s̅I #~=U,&e_BN؀xȲ lOkQLbN|/$z}vq)Z(\5MW{CT&*ku :٦y:\6^|VlS_.\sntsaI\5F㵎GIA8|dYsYO[ t!7a\+O3ŒnQ2/քH6llQ1Nƪ\resXçUUW1)3o3KXxQSABhK0ԇPF_'~zߌ3JmvO~Ugie=lF}M*k*7L[0׮BeQ -q¸QQ:"yqϧRbuVctE\/to.EDWHh5 Kl`-#roA꫹wATʯ?_/.z7xz F|X-C1p5]F L4抱V^B&il^|{C'9= ma\t6~DZC{~?Q_^S?$ZRz6 橜ks./Bch)j iZ7] oM'wߩsPiDڅ@D[6sNtpIy1!)ijHS'*]%BPqZ,:W_BRs}B3PG1ZHiAɖ o|XcxlWCOރፑp|(ü1IR}bWDfڔ BX\wa .\vaUSylgN]$"@NsiS;Dnl8?|h-Q8G5=Pew垍ۅ)љ(srb!CϔOkURx5:(wc&p|Rz_ޮZP֩Nr) 1S\'Kd AH;lT6c])8w~g 1P2UbDF } ZC'Pl` Y]I5?8XQI-x6*2Ge߭v;yH3S#JQgӜC\h- (\g:+-qع/ބFp Am{ 8rB|;G_S=R ~E8k\(>Z+);܂6mZRόc!xeЃHSɅg_6kӻ7|H*aT v Kœ2xL,1M9uKzjĩo(ŠRgq*Ҿ|MPn.ǵ$d1k.ԌOOjͧ>xسz ??EU i1), W3=˔&q]Np -C0iˋRF/ףhP<̐Yu@ e'TvB+KCQ%+frS8 !R<Jy0?,ae~h]|aKB\dݹ`YZ՜3> TTx% iNsgRKS9ʌfÅ4΄Ŗld:ApshIl(p׀MYtaKCd =I8s %$zyk0 aqtj([V[ d_=@ Gg~Bt䂏yt PcBAetMC ^l6نeq3ey~1^okvDb{+6C iL`lj+cd2{L>^R8_Ce{CYgIG:<%R1koLY[|LAɰvx)reY:?ĕE>WIp#/4&-jGb+4LP.-*ä3ߓ-q[|M]'/18 u(|ϥ3+\JQ+[K聿xAEF!=ן:U@3x`.ך5Z? 0f]lɖ v":|A/X-$N9`T *<*=bh}U Z`w8hG]AA>rF&cuBqN^z'(_8[亻nOٞ!)S{FZ#HH^j:<"c(П̉dX%<5~72>KL$ڟD^LW 3 endstream endobj 361 0 obj <> stream xڝXYo~ϯ  q58xQz$fBZ>u5-5Pu~E7Oy!)/?vG sm_7Dz=Ozvhk't"kL>}$DqWڞ){^q2{;Qo+on_PŠS6R& =q6哄AMTV9a En*A篍r]lmtI] !EdX,Qs*0%21Ne -qiH ԠXH-J$Oe$*PO^Fzo]0'Abҗe\701`ډ$vYFYM,epZٰd91WvuuW#+km2ƒ9%%- o7!2GHWWƹrJآGҍʠN廢y`)~j)6{8Sx!wZ;/Z% tȶ2#\yX28d'ѵFDwQY<JbX@N[fYlpV, nrj \ޓVQaad{~7UdDh.wv2=]~oWwũw`eDH۪I*|]=_Ω-} v11 `$sFZY0]*w*w u_zeE̝=ZͶmMUTTB/OPģ% "YJ|024X>4T'ulNVc{E3cR K¶rAX2jNZ!ҦYi~&Rʓ[/ oXTYLHϫ*J~DƉoen\4}iw3{\J8#X2:tLNdE$'/q " KLp>-o* [L! s=<9 'ᔲ?ZHMiWt_T6M%FYpf|&Ж]UB#0OPS3* $ Ǐ0S#0In!*3=HT5nFcrCDs!'j<sfȸC׍+lyM7:su_A_6>cJ*?n<{T\G"r f\//K_i0O2$0+ +eI>//}.:ah nd{'EWގ.wA5`!v:~ e V %7JoR>N{}v$k.`/;;9C`\/c[sIƩ9Mc@ . 2,.tst!^e5O twLsisg,h3VzX\unRdDs':(jF2|sž=;">$M2 Gp!0I2(\kIvz״dLXBwzͅYGxs41 U3 c͡8uB*6M endstream endobj 364 0 obj <> stream xڝZ[o~[(f8wrP$FRlhbuhil1+Iw}efDjɵp.gΜwhJ +'XmW"Wȫ(WB.WdweV)w[uveCJ [eai"Quo)F*/zݱN8-T]`.|DeF} -}A̍$9l~6JFQX1O`̉5xkw}7\BWGAfl v ZY0˴}b@.n+@ok*_WpSŁaA=o 4p1s %뇴R˟Ñnk"AԦ<+6]{ڇ:,t ]DS>: 0<

WI+]@YǑJ1e/UY]#Q@+_֥jJd|Mg$R{n?ǎ[g)NM,z!OM 69!m>6>FC؊ѣRt($z;> )k6LB߃S x'{ƥk(6qĵo8[2/1lA@aSe"cpi ^7'jLG" Da^LA A n>'= ƭ?`<"5p Mq{î2" pwxrG# rz]M1B@G<֐{szx& _@6Wo #9,F-9Bko(!c& T]3:*(-emMDaP9Wo6(0![< E./JQI`N$IJ WN24=}!%2N).*+(}[~$3[1}Cq(s"e8G 1ոr%IpW^ endstream endobj 367 0 obj <> stream xڭ]o62VE$m@fb5f_3,9n{8$Hp83?OlJ m|܈,ZlQmD֪쏿%BT?lZ.a75:TŇ(R98,S RYj}{@r0 Y-+5\:p~iИ1n{n.60Ss@iQĬb`j~N>nA7b":=0`Nאt솀} ugec | zQZNce  ] ]cP QWX:ݽ"9P—2ZZVafM\P322$2U~:S %bhijqcsOfo=,p =FVTgJ FL!\7@ xe@@h{eQ&O$8ŹxuS$_@<>E}z5 QW,,Y\{>Y+L̘-^WLbS N'4R#3G)V|Rt_{iz 'yBK7fPĹp~AfII>eJ,婽-\,pX*K/OVy '=E0:yqӤ6|؈P {&.95# ?ƟgEZ/UR.{XZ#-&.2,]}I0 ʌ/YxFeF Nxa/R<YRBPHpG@ E\?cŝuHњSt8"5ג|&]>9}wKJE-o>ŏXvøZ+I޽jE+/Z5hO{;kE_zͪY?9C1baRG,Xכ6b"jkZ}zѷL0*,KS:~ /- endstream endobj 370 0 obj <> stream xڭnm(940 rHb$8X HmŦ@`,Vz|7&x+6MeTƛ&.6qW>yv$I|٪<adqI?SCt&?~߹#Ymvq?ZJ@J:I #ٷi*dIEV^\e{fu -C\um^z޲=YC r=Orݱlטa 6D)_~p%H0Ncx%E mw2$)R7W\p;q[Fyl7E,!s>n?F0~\mmXhI2bL5lmgsmP8" p:Dp4r ꚊTxQFVB'23M0솉Q熘171 JC'rTjL̥"r͓ahҮ0O $:L"oܦ{D߫퓷Ñ2Ag?Nie1,0˽wѝO He5s#Y*eX&?!Jɲn,0ŮairmGV*^o/1>4 }zQ-B ]AG"tgKB>,6P޼$$uB(vY ./EXR`9jPQ cdC H!&=R{3W ȿWl-`bj HAi10چuiU 9 O(}@1% uᄢNH$0n` % ='|CYc-̭1=}<{>Ip 䵞LMSPEσ*<Z0>Sv>UOֿu,$'gG+yn?Zͳ5GT M9 Ug~:Ka,/ۦ~SV8 @r /9/EH8$4OHI]!fD>C6OOlI|PaH;lpɽ=l@#i{=x\.8`1Z |-]㤵eF&`+nr sϾw*w?oC"?TVB;yWX'RXXg,a6, eHLP^pu=PvjChX D(9\K($RGMzSL[1Os4J*vquK -q] ZKDzIBMQ#/P;쯰:sܠj@lK̙vjY9ŨATC(Ѭxan|P)N>!iqNP#u <O< ,aG]eSDmz۽pK%Hދ4tQ*zb&I~s)t9`Y P6C,Sm1/K'0n|~LY\\#)Dѹ'`D׫L4,9a7"]+E2 ;*z~7xkPX @y\N"Ӵ=#g!^jsA6x̻#@ RqA<H ʙN.P2gGۯ@~㼫->+3d2g )[@"v2o9WpC{?S"'$)aT/,$^ 5󳻑?>bY㜃]Ma ^qM3ݫ >N’aɋe8G̋QϫDq%8bv?}#:^c, _ > stream xڭYo_G 8$ִ=4MR aM)RGR9}gvf)Җ~-xe%V9B|UVݬ>~+gU^~%ʕPYk!nRlUHW*7al||oM[]ea#o2V<>QVa S{7s94 zlĮ__n#qGb@w߲[Л0$>*3a&n ]mZaaڮ.JUS3SSθ+Ɛ&ӽe"++ͼ׌o)ʬpK|pAKZ$- O@a-JR[إ- @3`iHs:otuL&dx\>c;]~~x@L/y,)u#pۻB[7]tExr{^rMJU[Ux}Uݩg8&\"q.\k;"FwxW`vz6+\DB)+MMAڤYG3 ѽߝϟ9"(ȽkkϜ>H?">{W3>k9C'sO2@r.X^_? L9Xe?7Jk&CniIɒ)Fh&,c?_dLYkK)np10uS '+; D2 G A x4OW!:db_Ҁʙ  $k(<?j}lNLbP$(ӟi$D".֞6XñO{!L%02<.b`blBcbٲO5'Ot^{Bx72^lqw\YGsD=SRgRcfrD3namQ_|?t*)1]WZ`K]@ӫ$Ƿ:橸c"S( NjOH͍ʖݎI6mó|ĥ `a%q%[KBIiF?b5Hbs]%"D t:@]a ]x=Cr~$LRcñq}lY_>ț @tn%*P{\@wI|j Äw:nxH6|9扩;O RbR\2:&ɘ؆Н({JW:zW_ rU~*~HIob&j %%^;K@=* 똩U:q3ҩ#<-51S+b&"k- 4JXmUsC C:+^3 *ia:=a6ȊfצY7/yinhuA=1܆vV -95A1O2CNu .mɳwaX;CB1\ՀL8(wݰGdnU.N|` fs$Mkn7 ?m!3FUsb=9M&)&{dg2q41تJBX=o2dIhMyElje;q™pZ牟GΆ9:E- ?PAad"^x,dB!Qስ^+_2%1ZmS8` (Mw;t T)<&f!//@/@8?ɝP endstream endobj 376 0 obj <> stream xڕX_6 ߧjYl vX=Ũcg}"Hom(GV*rU?[mV+:a%TnWnvZJDYZ82_}JBe@4t%J@0M=WkQIxiJ&㴳|(R&[Z֎(fPhI;t:ߪ&jQD ͒_Vt.WTol+Hɔוrad !oig*ᱥ? hi^%̼k-8 vR0ka<v7H*e~:xY ڥ;RJs#TpSg{]P)bK2n8_B:e Cv/j+-l$OiQ^x84ştQGD-]aw#Df@#! ܷIgj4nޏ'9-*'|!!ur6,dӷhF+@*oʱan:נɳ#A2"|LJ]L,uz<ZK,ĒgREZԵCP@]B ($vfM<KöcÉNdżcygaCF/LsVSlS]A"7nfbQ`r<\V}EGM/5򨣼A*vd)m{ֿe,i=<8_=Yҫ/cD}GOy]iQ󅹘3myZ2st㲫PSq+U2j'#|SJQy ymhA|\f?6Y7-y_^#@@h >aMvXg"&NHl G&0Nt7uyM]i]|Ov9׏vke}o3)%xn'B/|d`*)0~}uV kymԳDDAk\,Nv߲* L :|7`ybG>‰<4ZIFCbD P"ظ> stream xڭY[~ϯ-Ԯ.0y%D⇬@n3>nܽ5Eթs GE:J2hwD:QERh{ti G6ۿGwkm:f^e6PvDnc2Lͷv~ɕKH%&j__z!^Ҧ6˝rgxoO㰫q)e#| 4clxi  q.<YXM)h:)1vơڮq::4ޅ?q_y lPO7GTp?^^oثM+!ޕ>ȸ]uPLp=%ID~vDzF}84dCE<"iOu ! hٷHzaqih+**ݹfb2lde,Ra.@ƊHp@0$c3Hdy]T*2'{k/#$t8|X]W!Htrkl= DG̈́w}`RPU "ot=OĻOG;1x/ƒ}g綗-;\8Ƶv9-;h>{e'ܺ0W, m%)@y(/k\&[v{ EuW@G"܎չ"L8I/we8-<]|21ʉ4@ejNDHV /7rblE<+pxiL/\;k,~^;:8pP׫&VuE_C! c1sIgi%9VR,ribGؼkVȏUBwC^նK;p"lc&\$x%InyR75@807!$C6[OgV(?ÿF@~YOv$7@Rz:XE8L72o!Dp+!IJRr̮ʾfk׎ye%??yUk;/TcC>@>W]1U+ӞU?OUl#P}CqznAJ凸RAXcjz |ЀŜ$Alھ߶oruJTu0_u~~_c'9dXDŽC%?͊-w(3'uͽd}}E_!l凉v׹8[_ܰ6B\-4C/7/R5=g<"30ߊh8uȇv ]# endstream endobj 382 0 obj <> stream xڥYݏ_AjmK "R 'KLR>Β"u+vqr?kg~3g"'B?϶d&8+y)S&\&+6?Z):mVȇ=gaVY8Z8 uɜanv-n~#[{{Xڸ"Wt:j8$VuӦaiZK5-&ƪ l R&폧g@?]w&vVȳ8f\A Mŏ}}u>Wuqs'X{Ԙ,]~궫 sT eSձ DA@aO_D?t@mGjY?TwkJn7VP$s ƹ6%ҍ޷;qoRD r~tVBodXgJyi)tۧmBfkƹC*,iCl|\A?%yP<zzZ̟.%d 渌r._{86%h ՗Z²m݀ DǡxsW4pJMudFػ)Lq)RLJ7GJH ,AZSPPZƖY[,||\:NɼddCibi+Xk2'-Iʘ:=};cg"ؤ 6hZyd-ME s*-pe\mίcŌ[z-}dmcl4V5[O/  1 A9+#!qCJҍc VggV rB-PFCjbx}G%lB$%8=u\xS ф J)M=%1[mǝ`-w0['s 1wrġ|X]$w3~GHn! ڑpnhU.D߀'1Tin-@$D$yp*R䇚ܤ_rAݣ2 ̺]Ptnȏp@os!PtC3aky~܍U t5qP3> @t:LPf&Q\QDH>'_0 a>A]zB"u d$SN}o%dyO"j,d $$@{Xpy{ta7u\Y~5WpS˯Pdz.'3]"E|m?n_Pl, endstream endobj 385 0 obj <> stream xYKW|1Ueċ[\v*92>p(hԒO7%'Z`ltJ'4MJyR>$k<ʉ*y;Ll~}G5%.a6o2yL/ɂ|&4QTYM;4M;rj H$$i_7433IJTɿ8t#u:6L S&6g_;vŴENJI=ҋ0`?wۦ{UO nqqd,DlO()hI ʽJyQ]LV AWNLѩJME`Q6evtXF0Ǐ Ÿ!靿QOw% 8g9OG0 /|mq^y5  ;pKDa~X#s Qǃw䐵f((-P!/qto ð0F3_,FN94@*/j[B[jv\dȜ(e)"Alb(}x*o W¶qt~U(I R.SjYCoV2^UşqlZ:]`{!a5(ZnkEN6m K l`ldB ["w [(AHzd+]eK8nl? fPz[~i&ASe ;=d)4je^3R k0 0.X`:  VkPiHnVo/`4'mpԋВGÞ``' މ> stream xYK6WVX14@Szش-TIή;|HvxEѠo> CD˓!.y$8G:8&X%"Tr=}/iW41mi6ꏻ9Tv&yGfT4R9ه6~n&~(7>!shp.xil刃h{KjS[w~.Ee,w]q{b$X\IJzT mPpechEFZSؤF\>oh5ULYIWUln 8iai]̈A)(]/eׁ]EY[ PViyd0QAlA j ew* vl鴩MP(۱mʣhh<=Ⱦ%,]<4+"qAMr? bDeع۔Yמ1bMlNk ι[M(b_n3' aS.+(T v}ї~z~aR?|ml^ۓYqbxYXG:F"i \jeD:Y qsz2NLZf}igz߶ePN 'ls +8!GNx%NHzY.#/( F ,\j`81ݱK$ T&T}ve`Leʺi!ξeJK<[_ k7m5;1$"3imH}Wę<\H|wyfXzLB7 b1g>en3v/p0Q_ra,i*CqCcC=c w+BcC93\moꙂ3Ham(5A) g+g)+=U;;&ߍ} Ry8nHdt)Pɬws>,c}3!ҝio]LE]yIr{쎝 Ӵۢn{jc6ahF/j~.4K@RѴ<ƺ.a"uZl:d;a)Z4r@ŮXT"Nttrc/qa9k9^PuL""ϓ yʢm}a{.jr؆n[azg[QR;a)JK`霃p2]X`x[Yh0ohщEN^eZ9v֣? #:vS@$kEjޞkD+\]X)5\>ցK?|zNGqf"릭B+Kx Kܧ) 9U 90-}$&OV_-\q4,,9v8vr9l$_grpN2 !nޟaEŔH0b^蛃}.T{jt?{`TjxYΎ6ě6 4/zqL{l ߅&U1 @O8/_/}y s_S9$J _xme iEC%HpXZ#=ʰ'3cNy6UTex̙ ȘK~o9 endstream endobj 391 0 obj <> stream xZݏܶ_o^Z?҇E ͡} JIwC,ݮE,E!9ߐ}797F|;nzy݆ );B8@o}lm|h#n9lV9f ~\7b95laZ x2z*#rsUhN}ԠFaǪ7l1F0eA }4w9d9rYckڊt]5-6/jF<ٚ\%vXЃg+scMY[a޷宧ǪaWZ`޷3H5޷T㠻FmUtV<:VqXl#/ pB`cP,G _@vY9|j6[WGOv.NcGU=>T*Pc#,j߳Xcl 5%i{8P=d\+@/01dA-m+GM왃(.!A~i-hYq/h~ S]>*@{iǪ~&R4׾nP>|-llRXf\[Rs&-S 2LfiUtN,4.= :3YX; /;AS~fhuz;j90!# C qQ4)VL*6ĀJC=4~!@ì?b2v飤c "v,w;ˏ$9ౣ2B!9{UmNG +H%,ص.*.C@p?<pCǓI0 =]ߖU*ϡ8bOGE_/]6Y8X')rFd~-S.K 6p|U+uoC` `Fk`"À+Qp('p9:9v#@`㩏,LI F !!!hJ1<τwHY|sh.@1H@+8b{AJζ(\\ <6m}n.vM^B6O~wƐL+z9[[e[L[@Q on7om7|!<_7M<}!A/$_bVDBI]1ZdwpoV0GeNm@ c㤕sc$Beiw])({!6fdуS`K` :U+;X f%t.xV4tJtJLVn(- b]cUXd`KWrF0xDDmL>SLJ@q7_@Z]Ǵ6lnp_.ՖUQ+f7t Vn=Axw 8 Җ0`X FabREAAǿ1\(At#sWpmVb$ZY: b[J&T8~+JENRUsNb1-_2a#S#`)J.#%p֚tps1sExIdhP@ |ceho*ÚʦOh1nV꺣9&w$(yyґS,'7Sb*rz@DYX+ O >zBTFէ _U|}u C0t oԉ9 M@Xm~ dHΗpCm%Eb/vjX */hwJanD)p>*'>M/oц5_F$nǾNwᒕCu5U<_65<3Gpr!*VaƷln$c:'7<6bCP#rƗa:Si t\Ƨ,MO Y>d:чme0/ L \dOTjbEeK_EF@m")Xl@0h"|Ni/ endstream endobj 394 0 obj <> stream xZmo_"#"JPy\@&5u?ve[ȮH. 5uޤ- X3 7F7_o>Jlxʼ .Yza2_mR]{%L6(^0-5W06ڪY#Q N[&OEϩ؜\oXs"д\CvS?M`j76j?Y' J[H+M;|aIsM U<˂BbF^ߦ?,2T*#>Ǿip"^ܜ"&`f"]YElw[x77Av?6v )|)|^.wKA"M^iyH46zc]M\aBsVr!3x08T͑$h4isơ> >r]+؀(yVg Ȫ^cq68 ؀LJBrxG4- ѿtW!YRdE_7fvEt0|^xI^29+;4sIóG/Ll@c(Fq$n HAI@N=ѹ}7e6:Yń H+0o/@jȾA~Kk{w޸: #|J (/9.i~v>ePh1;?Vh_ow^1-wFX. hЈc%)VV3C)ЯYYMthR 9C<\Tg6ObE C:FZKz{! XI`߉qsna<X](f\`Vb@`K q47 }P1%M! Q4qnp =AD8,:ݐc oKVM"IS1(N~rޟS 7׻d]nOiv|JV5퐴[I~yLώ&3y,H0kӏ'9\a ++/ `܃s)-x wņgvl2djQc%on[eG-]9!MΔ-. m SFE7\] ؿKƥqڧI _W.bB: ]ujhyl.siMXt纻܁b1U{2r gkU>V3 {yTʐTRi7[A[w?6&`Ơ8^[kK5;1 9mҹ8s. Ӌ]}2WxI %Mo e*8#l)sfho䙑/!K:bJ::`̜&hrSJgt>`pLOq7l#qܿdoa}M)ȹ1Y+Z}D"9tvjoSKA幾]v] RGDi !>}#xGZrH9Xɋ;bJpd*^:K qqrV_EccAA>1O%yuf} v" )b ܲge}"ȸ] JTvynh\}RSC9PnߑS)c!Ǽ]tͱnk+0| -S^TPs~&Ꚛ~x//WVd}ٷa7/>7WtB0-CcBza1il7OSی'XT@JR>ROc歫"FϗDT)U5Ŝ1wCP hDk_8#+ W%8&^J\{bȪҭ(Ϯ_g@yVhޮpD-7$VDŽ)j x>Lɖ pWdG(H=^u :~آ#5NUZҐPơíF,+ z!}ڔGUZHZ/.Y5fq&5Cɠuj~33-VAGD1&h0jZ?^y> ` XE[=iÀ-&Cߊmуsu`R)/HOO3UOlEđviړz-ƫ\6R$V8٣ `Je,5' DfŐZkMu9 `?L:W䨐b3S^B#%zJ1/ WN|NpPAjLl}?RNN|ԿgWmG.b;%k.Wɍ@[K"ЏmgVhHKn^ib;Z91I Cfwm(׀=;֬c]Gq E z4P:nܺȋUeA/r*Y6-aYmcmN 1)f$ߞyĩVjsX&4[97u@sWp(ɜf/b9|Yܕ_^j*/zp}SVbNYZ 9/+aᮭ8+cp /ӷkϔă T uȱk5]ynwd}I Ê^Ѕ(sY]ST>^x[];ܕ/(8Ϣ-Bbح5%:\]8e_"M*+Y|Q+<瀱S恆](FHy?23RBQ}U*3Z_, dZw,HzpC/qDu}_{c5qgS>Lr{M2ipfxD`Û1>ݗ}7{uVfs\-Xtoa ¸N=~/2ڛ}4XO7y~>[ݮ~7?}@SV\x~7ko(_M飔T۾~s җN4<qU.v[Xe$7P$0x: pP_(+PX¡.LOn͝yOUkg endstream endobj 397 0 obj <> stream xڭZKoWCM!91, l %1!gI_z4Fb`Ow_&S_lv͏?i.rH:͍Ho{ύe ٟ:CIӤ&O4D֖]gU?SU%O[ɱEv=}8% ?:܇DzcNf 8,vw$ԥ7[/ÍWɹ7cӖx %s 7Bj|#.ޗWa40@6\wʍ$vZd_uC ͻʸ^v-'XH\DmI"8V{xxcQ+bd=M~LHVnLwMw ~)H.aJ  VU4>,w,>*ͺW/He.$ۧ%&Lh&u[,h=>{"e$Hʹ 88?hV?PDĄXxH tUt$IcrMG)0WAKdT /̀ "23/%"D3[q϶PSŕA89 u qJR xA;@RL^2({1`3m4v:0Z2x#C6K3)!ufa x4Lk'4cH-5$reK兓ʕ]ǛV&MdՍ$En4c5E+:HVXjfNut z}]77SBF(Ef[<ԞOReω M#i0+}E70G!}\zފEVIH`)#ĕ5؞k <*m{UFa޽Ա{K+(½P$ILJ aϺ {4n&#̫eez.cf޿V-om[*Zq y@<"u}F4;05 8D)x-"n)̌s!mtWGlU!NI-fpT FN0K&PB0.:(; H֞&3O >\.s!sޜ䭝Xt/Pڔ|H`3%ؿ~G;I HS&ThTQg"ir@&-M8c35Zjpju/AM@J+4D &T@AZŚ@a%md|.X0+Eh#`5mZL0Gkz>7I-o0ԴgEw.2L3?eh* ?_hUQW[Rb7 w,6D@嬚70 ?˖3y&(a_0V E/Co!enN!莿b88 %E Б==eO/G92"l5y r//V-8&H4\^я TA4Iϵ"@@=CO|o99|w)0uX>Hr_& ~@K5CsUQHpv KRz93"zBmYSPM+EE]Q#F@A*~Ų(El>ۍPG.#F: _5}RU8/Oiv8 66&:w٪5hvpj4]cˡ~cvxTFgW]>~ r65+mb@B[jXÈ/deZ7|?[H:p3RrfƯ}[YbceiiUw2RR.}&W}k&u>Xh׿CV endstream endobj 400 0 obj <> stream xZݏ_h3@>zo>(^Z-m,.}g8DWE (rDg3zFl87O6߾YAl>5cp·s?>տ}o]Ie z8z(~,4N3P_j]>H[» ȷ|FsÁlӱ<DǺ{9^LkKCuh= z_~Ot8)A͔%AWG..3mYP!';f20'| n%KY)nlADǥҌLR^ f6;yLidCS0.0{`z$tv88/˓(16d/D0R]m=/ъ]b[1Nѥ'=b/ܓ:f"AAs]KV܌ВD,♆V:*XzDGC YUSq=.juTƼm*NT nN@^E4 Q7Mz0.] (6#2?`U F5JάX Z-BSA`͊QfKj"0J蛭$f\rИbY셑>~& dKЧttQ=U g!ў(OAc>aR5#ڏ@.zב,Ƅ d]?ƫbX9g Ap$ r-$z<#ŀ$9 <Q~ jϤr$ޕdܶâmkHF&/eJHZO2r RKDFKS,ok5#ͺb,S|Dpqi|@܀ޣk>:CsFLbg^@ u|xKذvKT]u2G:]>gQ ~UN@7 |sQ* ^QAL r&}(M#QAW 4Es }S^db-d-(?Hr?J,18,4%)yqְ 01PŮ.:r`bDontRЯCQݛbf wX#:=UbUZW {pLHI섈3шh(*h:.!yiYMwA=u<tUO6^]jL%kFroSrRr}бD=% '` ީ|& z`6~B] N'_lXoھXc9ضeJ4Q;0R7kV{ JS X~"a&}U?C i%<<ڈ{R1*OzL'ml יUVs2m"a=-VaLrU*t#cPʾr!o N& ]Iɱ\z[xX>G8C)uմ5 {wp2:8R^Fof}H>^ӝl{qy+ /#PTQ鱾aQ̰(޴]cQ/.( l X`EƢXl9VTW((3V;0`Vݺ)WQp~kp԰bM^c1/U7++Z,-B>hnfb~8J@;ӥ2ujQM__n9ǔ]hf*Tdق!/79.5<.tMn2\o`;x.j#V >ddB{ endstream endobj 403 0 obj <> stream xڭZ[~-1sp"Ml7A+q%q-Rv9CrV2PX gr.߹ r!O.X]|R-ȼrq{B̛bqRjqۿ-Yަޟzy[w*RzY!MxӎQnFp7աԇjřv$&ʄȿk.Nެ̗ Bj5[6.v뎇=S"0z!z]v~zp5 'V]W9jxB䟰(OjMtXݵ,X動rnf?cIpD\}%yh&>L&xﲇW*"ʛ'Lf tLs=*J&4t vmAvdkI,Kps'2 Te&9{ww>%I{g^)kM7i[&)R+23 {'1'"tr+z~];8*[Dexo>6@ E3 f8&gfb${9t?|OAfSL)s4_c@v\l5n P{pR%"dӨѾ0cHE=2cݒ&S?w|~N_QkwQe"iK[Qbo<%=qI$nX)EmtXN}'nBk+k PܞA:l\R3\<|&ecw$8FQh/-xyb^xXGpxp;w~חϯmҒO~8r L.X=p1~q4r-RbpSyt;RE.)ЎLF5>&T‰iPb(Ttap\:8$玉+L-4sӌϭNDy "8nu_!!$1 -`$+(vs'{`.L>K4IסnÒcQ ]N EmȈAMzuBc1z /Eq&ND7Ŋ 4/nBD, jëcvv BL *E/n_<]CTIֱ"u@:7Īee0BrQQ$I`袨-N='giEO 8Ľ~b$B)LO J@U cUp D> JyIϩy 9i V|:''"DFj6hjN,7w2gq絁`pp$_P=g+F:뢭"FJ眹hL UOB(omqZ[ֿ_Gg\ ?8h~v&ϧ)ϰF吿'K Xi.=S#:*7uS !x̤9)lgJOK~x%mz0- 6ywHJS(5T]r5Er+&Kbf5\KVbN$dg 1s^%[M~fC{!@_^ך7P$@(l! fgB=0Lh k07?y=k9dbKDȕ_́1*))&5Gch8Ԧ9Q=&o<>{cI5g| b ;5 6GQ* H'Y 7@)_!)}>Reb$H@D0~sqsbC.]#=e ٗE.ZWr]Cچ޴2 Cei EWnpfa6 QgspTw3aN_u\ea&H1QJsтE.&Ӣ©srU"Ȅ~u_Ρ6sJg7IBϽes.DWS!_iQК_e*ͧ5o eXoZj,idu_}CMOj #PZqYx(.[":6+p+#MKޙJ6QϥAe^VïRvRЧ*8WyJDKp\ $fc5D/#U8xxݠ!4:^벥SȹY]$sAPӈUu5L&cS\ 3I |<"dCPŦ5@INk7כ̊Rړfgdz=51m4 sf)I*_>yqgl!Y{zԠG1 w?w.1Ϥظjf\C %N!;ˤL}8";9==WP痓`[)W,| ]Qrɥ=T׋)\h 92髾% 8T=V4?4B6@4҉v( <-9HR-x{f\&`E"\BElҙuVdV&>/).Dռ+q2n2?$Ct8%w4+)S$:AV HQ6ub'[~/6JgJH>B}[o0T0 `4ZwM(j_6'rٯ(T5 endstream endobj 406 0 obj <> stream xڭZ[o~0e`/"C.v).v'oM[ؒG7 #'x;|aVVrrKWo?LEru~%ȍ_n/N}ެ։t6$?5rI6ced&05ZR돟tu6Pߧ#(FHDJT)]"~eiLl:ݾYK"N k$3ai). ::ЮIwYvMuJSn?uRY%GTZC_<=Ղqɸҩmvmq\ڑɄe\KhadJNAY-jBKÚ\+DdVS:N vԤuth̔KϝTMїw|ڗ[!]+6fN?tܶ%;7=s [Я-ˮ/\oAfqz&3:l81X#6Tz⁠t|mQ6uؕmUi ǍҩhdNr {apS-(nq8<VlX)柡IdIPVᲹ{v/?װ:CnR~\>WQPia];JxhU߅/vElEp ڮdT:h_`d-Tt]E)<[I7pK +bqDWtzS-+ cHcIK|t͹݄2w&p( v.pzCl#S{5/Y2,؁mw1ږE=iPrn{2 aPBƹZzq4`= BllQY853HGX'e]("ǥ b}AX g&FogCYzuf ;o{jKf}80^6Ǒ̀A)Bk"qGhc7硍/7 Pw@]$ E8sؒz=HQEs' 'Lė(Y*ތNH͎F8?&f԰\'@NT {, L@&94uYt['#"q7,Ճ~d|Ҵp8>7IȔ^>Pm3O_gz/ y@4377+ {s -ᾠ&!BY"!DeO-n@i#bҘ({Q¹ ݋nO04 <9 N|"\Ȩy6G<( 4*ɶN""tvX ݪzi .;ѓZ4:14˔n]e4̜W-ꮚ ]xǢIDszߕn&re06& #J dHJcE* HUEt8V;7y"6W cpX5>M} !D}qx\vR#ȼz6nwiqt~unF^ {.p)xc/56Ǐ*%5@kCnC_:O;6D토lO Y]!3X|e)BW+fas-^I\_x:9[`cb=|Ԁ[nb'DGwM3vNZ?fa@O=q178BBw7q>ؤ K)9X1Ainr }T|Ls͘6ٞf%]@_دHc1ncmXh;"c=VBnk=PfGt>m3KZ:3iALKŔ8WDz[xL)#z캢}&G c6)ߌ#9 j Br+=*B[$Ng4bPe,-)!x ~wBGdK3HU@ )#v)mw15T>~yur9{/A,FGkGnCs)`LD*>uܰ)¨ ,gзh!/ ~\]Rc( &/orN!nĺJPؖݦSum]FK=K~.Ӡϸ;gNEW`I4P]w>,@13O*%|%iL+)S:B )LƦWYރ!|Nc!L[lbLC')G 1$/CdD(rHv(& g!Jn/s9wcBH yi5Œ@)$f9ڡ=aөmi $/Ϯ@ u>@vqɖ$l..@U-o_@U!?E'7ָٟN6BY\+ut__ k endstream endobj 409 0 obj <> stream xڵZ[~ ΅áV\l>pъ0%*${nËNQ1̙۹~n~ۨMM_ٟ7~QoTY6Ǎe៉2znLRW0{nwƘ@He%CEnwVi.v WIjp~E3ILeݥj%6ϒu"{y87pu}#$a^.u{aej{;ite\7+SN[=vjS A \2EۓL3d7QJg&~sokl)tZj%3 'ˇS$\ևN$E Nmm%\nW^P>vi}y!:6@|@ZP-Jվn="3euE SF3QvVI P$1ұM2&ݧ:u7L>(|Q[otNHxV\IY`s3|N`Ѕbdd¼{Bl1 FW},9mMm!ep HK{R,DI\Z'婫b*l$"OF>km7T;+^8>35*K̲ИR;N wͭIWYo< ;C v}2g.p QT4PW6SDǿ҉>H^P{4̣vկ9yҾDb F|O9U=7w"My;FJ?wRg!T9W=r qr &G~C 9O>]d0N׆-~ZoDVٹ`g"AAl+Q.fqe ` .Ң(V>+ pXV)N30ѵ\jbA癧 &'ӼQu͔ZɻBSjh i34RC鹵$aߤt?UGD `"o+yXxSUЊq9n[&{l -^.Gux y/(5}E4LR_^ĴW|i K[la ],h ,hcbosK02aQ.U3}Bw_S,5~{0./\N#5ߨv~vGxU `NLJŨt Nv <0P3lxVMP1d#N&"ܝ H6ҝ^ܻ1bmjxM}t:f*gěb 5Mc!EoJ wc8iWu@PצbNnC=6*.,"HwHtTs`:{WPB A+b[8Mfc-b$JXJiYoWIH߇bRP{߉kHDIF%]C:NFӫEDcI VBÉ7vm.\(iߗm+3nPP.+11nV-un-]]S gxkUn}8&Dz~%1$?2wIZa e]2.& ;$}$JW1hߎ&ɷ\M>U+ "M9z[A^,ȉ‘eǣ@U!>œhN4UY2Nu<#>M0WMF_K $1xߒFD]=Q9_LAߨRtZdOįR*%1q)q- UQؽԆ3ʝA٭8 }( dھJ:)/a&ޖш!OqHmf71Yefj6n~Zf>@uɯo ` /$OaB%Gag?>fi̧.$/`  [p`3φ֒W?7]K#Lx6=s?'`{ endstream endobj 412 0 obj <> stream xڝWK6WVX)(KTnݠڢzh{ZMDKE f| 4(3O}?噚r]# *0yowVxiJݡ* -%;wjP x ?0 PQG8tEԌ[^dm\+ӰZ;uU MTۼ/ЮTi0?u߸1Nn5 *js;̠o*Yk[^XO P9kfF6ԖN<GHnIgӒ)+ u9\8}5055O0Kox@k.hgj12%xckY()vhŧd~x&8'%k59uS;窯m}wL%XW!Of'(iDNKuwQ!Y/A zG-9P p}mbHWe;{麟Qp}u{H^ ZYnlu`l > stream xS(T0T0BCs# 2PHU4g endstream endobj 420 0 obj <> stream xN >d`FMx0[uS&5[O@2!1VBr2-AJyJvy $:}lR6 ظL 8™E5J Ics< [eP4-\}fp endstream endobj 423 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 427 0 obj <> stream x[nF}Wy1^foy˥ (ZCQDD$%-:KF/ 4gϙ9蟈Fľh#l8f%`EXGA,yFTݝSdu4޳qrH'S0^]_ q6z<z :R0~i,6'4ܗr<HTtRC]@%[6O_c\75^z^dPPnNfs(٦]|2u SC4ߐr%F N#=ZG:!_gHڔBT}J6f7A%}'I>aQocurX=++}Vu]Q-g"]b [}0Ƀ=F7+AY5\;A6V{V`S1 XlkMAs]R=K+ؾA dbHiЏ[@MxqQ!*qY[FVieqR%k`nw8m g( endstream endobj 430 0 obj <> stream xIoF:h2қHm, &FU"R]IΈv]-^β9hFn5 am Kh@/JU<,*nVbІ&#fH ([8hXeP N:DӱCL L Gꚡ6 l#kQmR}JIR쵏rδk$:йQI҆6M|_6Mf묣n-m&)L>;l.^F=# iҦx9ך~DQh>k.kheD?sL6MB0s`XTuؽ2]8B,ig w׭tBR :g, LںqXKv'0l'vN)ǥ?V}+~ZB:O+qsw{l܁'0ѝR)0$ǘ@y? rdud$J@jՏA/؎ endstream endobj 433 0 obj <> stream x\nF+lB-t3GwvnEdQdJ#$Rjdʝ3܊҅ |xxsϥ?E7If$yuJK"Bn+L2901sK;DisuVΊjʛ^]IiߏTmlQك)T *m!Oesb4朧?|f#Ovr~U/zK6볪$I= {KD޶Թ\e~[Ys83-@8D780?ew_k^yk'GJۥf. ݕJf4֦ tJƑr91)zp]R.eX pO jϧż-|~n [?cEߵ{gS.VE rjg(muDݝgA(FX%=ߤaF-ybrPkڜ#b䁩ܻ!^x`D|+DW>:sp22V_gHyp3D?Ž!y(svGo3#|ddXRr+C\q=we+O+Mp1vgeKP[" uNvy: Ĩ.>X['z" >)56g4(U}E~WuA5$h=㞥 vEEff&~}"Cz߬!w>^eV4gtTCJFF?MUf>GT(jك98Ex:SiT|YX|\glGrhBK7J+>> d@ecA %m؎*U]=)5ZAr7״'Lc8&GxKDU6CVOQaw"q_DI/ɧ=mԭƞw׀ 8SMgLq\u㪚T#/8R}ñ,7‘ţ\UӉ;ѓ'hMi kaZ \-"A8FAOÃj=Ȗl,\->שR}GySuruJ3_Fvp}E1׳QH#t"F?{8ރ {iUؠZS"-zZfpRr endstream endobj 436 0 obj <> stream xKoF+̝wwN/"AZY]!mEb#'|( آHsfFfo`<| f1|s=^GϽ`K&rlgϘ|K)eVX{cV'MݔYOzt8K=[˜m{E`=HTf'\8 Κ1pp2*ViU\Yq:,Fu e@v<ao8$*u:U:~Ij[?`k9Rf@({XN\hXtݞDu`Ծ [mo767R4a'x$"iڤuܮsH4e^ݚ^?2//ۂP% "q{F=}eQbàJ XtBPJ JŞJUC*weّ΃Hҽ=2c\c;J5 fn}@5 ~}ZӀZG8azt|h)T}h:1PrMlus%ʩѠD3;[(ue~NWc;y>)i̢钽d endstream endobj 439 0 obj <> stream x\MoFW9Qwv;Ũ]E6C-1 TIَ}L & y@Foapv) 9B0(iXwH2T6ol ș@DX9Fe6gEҝX_ƽm}AZ7/| *@Z20z %LpD{~K„E9*dFfx aLie(DIb BS1 G7~c` 5%񄀕t&zŬ6d ?f7f7f'n]kwˁaMfAN%dxq;:LSy{/-UG􅊒ǣLdc-iޤL0;@ztn5Cj"wZpxF~3p X5Amu;wul_iVͯ=FkTedFU:MGso{@3wVcW-Z] L IXlvZϻᙖ&`J=78̈gQmN<~lMg֤'K9zXi›*7rw„GU%iJA:L:3DmVeRdMUV%f;{c%-)6I^D2[`lWZ3!1#j[ĩ)rf̒ӧ2Zk&,BVH_ZybiOZ6L=KFKTL~d<~q@g:L{tkնdh]ު]:3Z`ؽdV:Uz[`O}~z,4V.@聊hJqHsUFR~2n%?魣^kyM1-(k kEHG:-@ڸGX\|%yJzİi u՜ZF؁v_:K6(Y2I"1[޸TR+ 0tŠ{Ǵ٨p,7jp Q;ST[>ƽ`17'~(6?R_z3d3@;m|`x"^nϦ(TNaLԡ{V#nt!L#n,{} endstream endobj 442 0 obj <> stream xKO@VOξGԂڪ/ Ħw8&(!Z7:@@_& 8:aPb`p +L0 4~>QV竿Q9iy,VbjGw>I4[5{fɲaf3a9A \N!BBǻ( }oؕXwWz2!UbJ*vKmۛb<"3D^62R.C}RQl a:M]$kq#Z,NeM\"zI6˯pF%bd:*ҫ238ύ.0[.2UR2m` FR2:.JWaZ'ݕskRꤛu ؠ)cNF"-:G/% !R@Ԕ `*0Z s]3^wM%YK2zmӳ#E^xQ+I(4'Pޓ1`"(ap$4&בV> stream x\Mo6WC|h A/A[CEM]٥#iq jxސҮwb.E'I6ą]0su8⢸$Eu{N;R_D.W'!VgM ׭UpRqxxPcAaJ]P $D$G,=cR-:éG&5W$¯xi[$d0G4/x.K1'X8pD=@ؘ) ƈE;F;BQ+cԘ $$rL<$+2"'A P1n-0a9YaʨU)U] QTR@G5 ps|J@@$eXEPÊ5s,(ML!FªgbAQ0P/2\o0w< 5 a@PI#=̕l?\)􅕥*pe\eBB@J5'\UՌl > ZQDjAC$)ރHcJQ5D+: ((#Is!OCQ"=` #!7"R":j_i/u@n**ۉPh GXUN"Č"FkwI\%)-O]ra (\x"*AEtI,esu݀׮'փٵkX8 <*+jcx&(mZ5"EA)z')4cacB]w=PTB <٥>n|MLzN'9bA| OW f}bKK{$v9e\AwT|winЖ߻._\bgsAv!o.kriX椶76z kܕ!Uu*/g|N61.hj)6A?y2on>~ѽ۫ט>~~ow{g|yZlrGagLú>] \i;.cˁ\dO\ItzzZC:rP3uлKK˰Ԇ;rqy,pGGsy86^61Kvz*;ۮk=pNzϠ(jvg]N=Lw#M6_D;NgLJe-ϣ-`m&e>>!h;xr;箯/cOOi^m–:w}Gk^3%?Ev&ak'`^os<6Gv1B4]I?_}pg@BѱcOzшli'v 4ڮ_4 endstream endobj 530 0 obj <> stream x]Qo0+,DЄ(F734ő|ޖrν'xY-T;r`zYțVf$ \[׭}ˮ:7g?x9s?54Nrk/}+T$a{_Xq͝u':45V]씕i 2ɾAWL!Ry@-ʠ2#F)K9x,.;;pe9$M;>BXƅ%pu);Eh9B9]In@)Y"("KDE%v d%!>f(oI۱ ?5 n endstream endobj 532 0 obj <> stream xڍXXT׶>#"֣3v,7h 1bEQ,(AzDzgf̀*]@EKDFMD>$M4޷`{0|3g_2ĄdnK-_2yi'o%ow'32qDQCMF0,|}e5@z?PzO_^[71ɸX>ncHhtoqSgͲh=n 0AMkV?hkw|#"Bߞ2%**jGP0wM^ea#ۺɽCBwDxY;xySk͙$\bfiUa,1c `1!Pg1KƊyyyɌbF3cmDf3c2әߘ{f&382Y,f0gf9qaV2jf YǸ1 >1aK27Yi}dIi_4N4E :ʞo\fqW?`YG xzA9 3pv9ކ?7|װÿ3-M?Uz\O|ES4+8,B Lܶ֓O! 2яU]'?95 N.`r4Jrɬ~bQ;8C>e^99E .();hI-^>u>DŽFSY"S)k$FqUͿ?Sx萾M$'zYc?L#$ H @0Dv^UVSBމ'WsŖ۰Hbl\P1Q)jL ]J 9\Tmǎv2$^@NZ : =.I) hmK QgC3+Ē_:q!UهveW=G%8uT e jv3% -ϱ:K&0}3F K`1SLsw⺊Wlq'?b=2BST<$ѬEv y!rs Vw*%6;#&B9[?~ "dRLB>Gk`)l}C9/3p9u=f4Im 3)4h&#>z(R۝ V 8?v rya~ΗP.V.y*luBP%ŹePJ^כx\/=u>M 2b5xԯELtua%޻(1,zGP3o=yѪU7w; f5{vk\;rx}hvRB>}~@;!|"sk k˂n_bEbCq| Ai(pGpe P*; H ܂`[{W"2+u?=ag qs,>uzw8:=5h{^Zƀ:$3,3Chb,4_30!0+t.fUtJѬ{ ?@=6%9fJ݇XchouU/zۨD7gݺH μDp{h)5}V~#$ȗ<~,-'e~oViݕ`u = sh#jI3!z|Q\")d2MOGơE 4+O* 4d"M%0}yր|Wzة 7=.9%WZj3 Ꮹp7/gmI&$.?8k7vFMҹIn\KEZ5#ɸmdt;l?xT9Gَ<%yL\ 8 KJ ϵ+1ɴGjCU)M:*< 6v{Q4PҀƓ주-zuK2AX8Rӡn^ OuX$F; wjkXRh"!dkXT|`Gk^G?4g嗏t@c0S_u(< "((SZoJH dPǂX2yLLTl)?m'_j)ķyLŅyPasQl5j&qnj\5;/ l0sc-!ZZ^B#U`쳯Л42!*qTlkhB5;LeCEYZ2(6mDB4uīo=&>yIx *fŠѳCٞDR>/fDtggkP͉',ܝTVSuJJs(0?6!9q7{`FP]_KCH8ñć5Pc6#r_˚?r \Ng֝[pVո"g 3;qa~UR J/mŮc=i<_}ĻdgboHy.{2EIEf>Ҁblۊ6CbŽ'‡7gWϩ_ ;}8 Q]D<;NTCуxNФjFaz1!7$6+:alI_l>kj 2Bi=,;=cμ %\c1XEgE*ȪQ [B*djT,êOe䜩DE-KNkH{tG:818U;DD/h@VpAR!ڂ⺺ӛnǟ/" ~.K?UD$JQwGw+2A{?;ܔsM>̳'}$1 !yyjfUjP1("?jzJQj33 b1+qN ̿4TX }p:ߡc4Sdݾ S]pr"P)!j(.8KK$ӯ 5")2(* M蟚{t9w3) 䢯 N if$wzVYb鷒8xF2!N7EzL4jb\ήjܜ2'zXcGN ؝[/y}?wH~V \~BAZh{bXTGPKXF!cSR(_2ѳgeQ#W sƕ{4Gkj"uϮB}~-egm޳[YqӷrQ+;m^TTA5E82-%5'Glӵ4}i^|Mk:rս'sSLU\R|ΖWWUv=x,#&=T6 vN2d6êm`!l;WM}LkZҸPB[_%BMzBEShoNܛpn@C-1CȦfF3598 ǷM\VBgpKBAcYmv.3x.d޽%U <##=kNa Xkg/f[ULxs\>Y;૕aEKa:[ ]MhŞ--,_?.= Miq]_뻒>Z/R.F43*nzOc` N)~_駍1JgW.~,27. #??6ޓP4r w@?o&ޝc>YL.\ Ƹ;h&]B9E=(*(̿$(ضݵ4j3SV%db_eE{?MlE%EASOxY@$j2K8g^ | E1'KCc`˜ KXNGA~*4 ։w8_?#8ῖxk}_$]c:S~H2 8 't.Yɓa}o=ZBC*}`s3/!Ykz 4Sr$x>@&NZQ#L" #^~cP|N-jkwG6C}rƅvhGJQ ϟI;x}.NǾB\b.ܻv)i_8 Ae #5'qPv8]s_Κ+ 8}P9 ta<+$;X>=⍲3$ŖVӏB԰9fNJ+tPgj2琕 lz!C,N-QBȲ[t~F>@C/%Xt D2Jr]VgiM_) Zc*(0> stream x]Rn0 +r4M$PZ*!Ƥv[i/tH#D /g&ȫRDO3&vJ@Op!n7}Iokz{o%_P WhxWE}'+4M &'sN܇`:uc^;h =2e. aԍӨ3eP7|ȩ?!iȭ1{XZ2^ =#^z~eqT8>BMTzl a{X{}c/g {w^VO0j$H` {Wc# $>b_ljcL~ݶp/Q% endstream endobj 535 0 obj <> stream xڭzx abb5{/ƽބ-ْF܋l ۸ !@B @:ڔ>a왙wfޙ#ս;%z/\y1s8A1 ~W'ZoS@N7ouDȕppF./PE"F0a & f7miӦ4a4;{mn.v\¼=]m9;,,h\Cx}4j]0o!=-wy\un"#nYGHѵGO 0jxl,^rD=nT8% ՓMYS}T?ʆR)zzQmj Qv`j5F FP#Qhj 5zG&PId=j >5FMfPۨ({j5G}LͧP Ebj ZF-VP+Ujj ZG6PMfj %Sxwf[IK$Ò?h(3Ƥ7quޗ7[_3ϞC﷩FlOiFe3\oEHdko 98wt QRAoq0 >l찐a<|:^m_ oeA&ѳ3̃b~-?E@'r(8a ëj J+wVGJj@ `bfX2 D;*a!G^C-B%앣K&~}u~h&Ϸcעg,^o;:`t&<A JTA"3N v#NɆX3҃1c_f{]x1mJohn%VhH( sը!+)//VqF,c_RK z>D{RYIVw%0h͐ayYXCx \6TAubbjtCdVLnu?]95 JoR9xdXVR w(n?V/znMrPRI pPF0h-Șql<4}E^C1a9ck - G,G<[ԚaCkJE?8裊p?dVzМ]h LfAEP`%nL#}[}n-&#͐)7&" ZdE0TԠ)iq<Yxm⺔Uf~)Brn2$7enIBX.'Akj: BcAYQYx)N˄\`ىF.r 9 S$jnygt)W/lqZ 9|̄avĖY?G۲=?0g/{;4G< S8 gPg"KF欁Yf&fjGm!tAg+@-[2H.ѥdJRO|$| F%/Oӽ3_z}M@#I&^~5PTRY% -H `>Mnv^}dJ%yHͱ ';%$'-EsACQ_>7۴?FޟD)=eWs}1gcj:@ g9p&r׬ v߲MM҆j!IFڡTfBGrq(5h Z#0uE把(Ow)gG?"Sg~p{QwwH4@}B٪2mcbѯ"T#'m`w\y7~bNڱ<7oaPO|] 'U*3k%I,ˊ=a#l-)֔)㿸$:fᾘ⟱18UAZ„H|Yb(>qne ,RLo`9 #9{sC45:Vk]1<=aT~+uGN(b>r} o~x 0'0b8"s#}*` z)o4(zFE,ifF~iS~~ߥOP #$pK![WqQNٓUSd -PD'/<)h %^@&L5[ #]\`6}?MoAKk w*Xʫ'V뛶2l=dXdyeY|2o'›0Iyb43''\ELº"_Y3-Fh\X*[P+Q%P '1Hb䓠.܌C$S~(YVB:ӪXΘ%HaqOKZ3bWg^:셕o M-ċ=H{1 >c)(^4k 1GD[Rbu;)6OFJO6d)- B{jj^Cj| -ݏcibb"Tw M,#ֵ뎌$-IdZ.9W+w~t F1?fK\E⭶My88oV صbgJ$t Ⴟ[ax~BP`U fNasaj .X jҹU0=C-l(L'Pw~EԂQ(Ɏߴf=uiQXdnc8.pN_I)'e2x OMbP~*"Çl-tV6ݬDNHHJgp 8&c7e$fǑ! Vu=qq[)u9;!ܑ (~x0ӺrA:K=\g^%XbUH>M4t(xe}&AN*R; Dv~2hޫe5-HċN$ϹdL=5T%H, fަS#mNݘ8Hc: d33[C7ɥѢSK dVE fueڧHd GS (Jє6̹ cطIDFB'UPB |΢Hz-Ex:f- `:hI :O^![4ۼ^f }ETҾE.⯳U5_ q ۴e* /.kx*mq0 Ϳ {e<(}zz>c{nCſ"i"_X%KmDJDp8m&mwNy zWaq(\/2,Sx%3ڵ!-%9t < fdi| MiuyɿpMjwAܺIAPJhXg0i )YfKRhzx-y7JP\b Sb[ZuG;ު"QmH4S&$}!ԶrFzy5D`{v+[b7&٧iܿA~R.*.U2^>I!M-3plչW, FZ& ?R4:64>Yz4Q6ͣg -|3 Bm6"5leT *V#0OCm7>}m6%-E,cEJ_TITܞw9vzG"|~7Jdo$+MQk;>M-ԳRַl[~`>˿&?^RMMɫѽiSwX_U) rM۪?`$^>p}ܓ>Qzm!0G}%d;;wfme4)!&j,*!A,CV~Yɛ̴N_(kti_B,KHc>#.d+MAg,l:v4BCpGa5fEv?u^LlRiFu6;o cooMzˆSz/WҢ_jO)H\Err@%&U 8ޓɻyɊV޶d",kehBy@.=W\N8< XH$}42;v!4(- g]-5{,@=Xch ehɦJ<);Jg3ШE0ZI:`k@cNtFw3$Bܿ-Fs,b?dO{=ASלޢHb'n#(n \os:!MBl=xT.*]m9+0"^Zߘ@72B6Kyp%94F77lH/x Zej♨œZwN*W:͟Lq1>H)󰄯u7fk5Xz,pdov gþ]{ ̧[;LY7o(y1og@Yl'"[EbBFKƢ&4~[R 2[e$O`S|hn۞.>CQOaΗZ,RHE +H+͇*24002v=@G7qCZvjc |#qAY~_߸p_ٙgЇ;ueK Q8; gWתŘ͹~5ΜZL&:s'(rGYShlvMߩi /9Y8:]I).W[F}ur"QƸ0N0-8 'tD󗮙3߸xujBbڣb 0JHW%ZH}Q-Rѯg ?bCvݨTFq ϝ掇=<½"Ea""i4UDZ!xq̧۲`mˠ$ǣ0`OupUAdc{]^@~amXV}@~Zc5a8KZU^Wd׮ф MGjeS ҲrK\pOt->hɫ)8E>BxAkP&%nΖDZajR"-@Q% 59q*f"JS:NR:σE67Yz!IM j=ƍiJm:}^jDNQ|Fj:T|W ĕ G# AE[Eh6AI2,FMAJ.m^xafF;DXUbm% bKZ ʈ°pEcA8.`DfYF9L^DrDX%KI1H"fU IZa"I=;aFh% ?3LK[zili\SK{n? endstream endobj 536 0 obj <> stream x]n0 <$T"14F=$m;l7u/;,J3^%)A._ؙ(|t#BZWP%t!x3m^plt?AQD7΋j38*[Wc~qD%%9)M'vQX eZۄs/:iFFoogN5q^yռZ|HU8qRY _|e ) x ՂY7PZz.?:?ftd\GP= endstream endobj 538 0 obj <> stream xڭYwTT?9dž DcEbDcH/R7mf HQ@Աw4&\i&z-7&{}/G{,iwzo72̌d/^v4kLѕl.`đ2^R.5{adiy>@(]'Ћc0c&1jkSGzYwjڜ96[[ϱZ=a{g0cպ w_ϰh}‚N9e{@蔠ޙdc33$jIP`ժV&vAa!VA!~}{ab3ؙ\fpZΑn0L cưLo?c `2f3Q2V(f43KGeL`&2f*cLcf023Y 3Cgl;f1c,a20˘ f%b>dV3k:f=lb63[##:y;fom5;k.3eG"n(_m߻mߨ6oտ"l6ApC|\thn00aWoT)b832e#fi!~ F|f`.28Oq\G ~d\WCdiRwN޵%aE{}eIsvor( KN5nl_{LqToq >-#?.GZ܍P)KIN_ɍ؛,S&oPcdh  h@͏z~v]e%DE;QXyqm<5Lp'_sGE81~]˅L5$wB<@?ߕ,]LR8|ѰʠPUA $dEϖos] lDNl.{Л-iƆ@HPGژ4w@`?ƬЁ޲$$JiŤZAglPE*tds2MP2GaWW ]MQ?p' 6 >37bT5@#Υ0ʻZ)Cd居񐒚!l,EF2L}t''q #Ё18gO|]=[-' 2_%~DկE_$ɜ?BT]岿>] @Z??\q2:C =_OQFöj5Ld1`K]'#|9}/BkY'Γ㺽B kB“jH J>ϯٶս x }"+ĽrG[ ;$Z >->>->--J 1+%˻V Ŵ<^$!Rc2ɟ9EO 3ܓ[YyD kš8EWT0xo )&G/DIo(P]I@09u K[ E-Y4L'[I 4PQ|h&iN-q!,*= k"0⁃[:':/],=]Z}d!N,ǧNnk1-9[bLD UýKf82f M"#}w~C珨9;32!ʠkQP.gt+$$i!!y'~HdfFQ'uLMw)u5m.Ş Z> bdl'֠ 6Y9+%dkH1`QF8Fnw?$pOT[Oe.-ׄd򑀥hdТsU7J#8+PT!\wć;C Ł.DHiBG+ANI]Qms2d*J"H(NhrUىpVcSBbfHMr慣bXBVɮBwi;l1%xU܃l=MW`C'AnҋjK4zF35F+'KN8mn@#.uqE \3Cwvpou%y痁EIplM4NdF*i2q/pPIE}Hgp.𻡘"HW5ՈEO%Fw ɜt,zl~uWעmmc2b:i] ^$ޕTS#9ܦ7x'Πۿ55xUqeHޔfM ڀDnveiK Z8Ƶ=d6=C)M(rq8O谯NX&s=xQ\)TBMR&%i餃* 'PX&BRz.vN2wә߽\4茩tSbhM~Y>J1x'"$p@։t}0XO%AIYNQg8pL-7]6DZf-aw*0FB@k=~@1E\OO˱kX  =mC 8ѦOٔZA~͆Z_Z4Njo/GT;\Ts55ɉ6S}#a2It'Q!$Xmq9Ş$7I!8Ｐ EAM<޷vv|@;~ʍ$ZH3׎_ ՈUxV@~yGEHO _G@Ozw&81 bF603'##Oj^ _+tҴE%6rCcˡ=!`%dEyE{\X Tѐp 4(|ʕ̪c=?$.ð'Ja6aq,]ɛ|sOPD.x=K4`GӶ5 f*X]RhH^ޚ>^K*)WV|(r. *TܷOqFj+{>Rѐ=gU%f}m%r2*S|5dWQf8 .(H7F3iF6{~C?9yÉ=>8&80wv>qZ5TIwt G&NpCw2##Csʝp8.(RBn.K\UY$a^hEtQE cg c0^91Y)u`y=bKޖ5a6`Il/ %Hbgx緹Cdr叟Ͻcr7(u1!`Y 9*$/ DķTᎂAoYCM8==W|J 4&&(F96]p5p5&;R22ԉml $ PHSHmWkoiz>{e^kO!owVWa\L*N"AAQے%Ө%￴ģ[fN"MBtl":e?uʱ{=$G_L]qA\ӑ3ݢ dU׸jYy:]u\L2FVvB{K>6>RbˋZIDmO3naiQBEQNSiqלݥ$`lZ.s'r.x+C/%o<|BSG&0@Chgwpqq~^;[im6Ym>t)q aKW?^T;(fZ+24*ō;}ߖ P TZ^=ӋV-i`-{h>鼎Sh 2'a \>q:_-a"|y8ϣG/R8R--]}p;c"3=h3/k >%Lg?3S>CIS=k=rI]n:NZt+,nr_>dh>$+-Lu4j541 qs8s&98$*iB(+3 "1[]OUB>߲3${_?L)1GP6ILUOOr?8pXfzśIMF 2ʘ*ĵoCK"8!iIaK)yUW֪\]mNO.6P|=5`ʉߝZtݢWdڥeB=7Eݟ;!;K%'k_TRQH1B pԌoD:E>KR.Z)N xge&8dc :Gwz|$0o|hQq`k %h6$q"%sΰ}W ʠkY&@$ߝk/G#l[AM\`G}TU]Z[)~Fdְ3D2BE@a?O~K0i?D@3ǍW:QHXؓ0ZwтN2nF mV:*x#u J:QF5Dr/.!41Ayu;L9ܖҙj8gZ.Ƙ3vkQ/egַoVs 6PyC[+t2_2_ :yc (t>`#XMa཯:ǯ"%Y ܆X@gZhgUgՊJ#+^,Ie-xR_OPF q e~Kžs:%ԄvIH{XY.PLDy#YعI'唽 v5U#qJ]b IC]u=*26$i*_4 ꠀm}~+u̍dzI懌lf:,h.t}(M6.. ;$>/d(U/WQ'<ơٹ_JvDl4{'(GV"BV"o=l5kϫ+$ fB3]2|۠?lХR!s(+CN.ڋM"xoA~IHNO,!NM.SG.O rN$Pk3%9%7VFy8t>3(q> stream x]n0 y;M-Bh٘mtwL4Bo?;a=@ؿ^^J0`]Zx1 νb~^˞rh4CߚC]X~[\J}]4Pni8>Qq͕x;L|u+.Zje'90FiX*DӢ߿U:f r8$Gıx?A6K'x!s±t<,v &K )BJCy#aȨKĉ2{@vݜ> uۖc; Y nkף*< endstream endobj 541 0 obj <> stream xڍYxS׿eJV * A@d(*ղJJӝt{Ϥ{A)[ʔ Q?Eq}oIsH[[F"ؿeLZ>mt2}41=%1==$ؘ}a$e#7o7?C[Pԩ3L:}IpHG]͙dSqY%ݹ=m+p^ 륈vynB2"##l ,dH_0/y.A \oIp`HKKD:V2䘍"$zmծe2iʽu< v|u#&7ǖ?vI3GY4򁣻㟲ٷaT?F]0ʩys<$3o|6||ڠX&6Yn`c. -ՔY\N=GFwoBegw.q]ή?蟍iÑ|vafqʊH! RI9' *j!2ï?}~o-Zɓ?^^G5=ZP\\/uwun=~b}+l.) /'G$ί:щj[ز:hn X%V)ZC Yq1{wzoIE{o\E[>/ʯTQ+'"lz4pD8^Tqdzx}_mS*~ѡa!:E9L!)U%&%A,]*È0mLx(KɎ.&m~ʋ򲡌OӅmĉ@ֶkkmosraS#EPdl")#3aLMD2f219 \rnd]nC',o#LKȝp#@.ݺb3!8]Iej=Ȝw*+Ƀ*jyN<$^49??3YJN5.*J-IA[Ny+>%."!蠀ոBs{M =vS#Iqd,c͇+^ X p,ƃO]\,;g[t,{8İNEW| yڼLW%69T YPm8RBϻz/y@u--lCNr4Ё+^C25|N)d.,F'TC^Yn Ge7HNM <Bl'' >y]|WćaN0ɵϓdkTGp3f% r  5>-kֆ(u&B 2LCGs=sJc D̶z*kaMFIɩi\=yb }} *X IS?]?rbK#&\'dؼ9v7&Tk*(N+I+;rm!²Moxn 14~6-s_Xy_J'40##(Io>!rzM F9\8zꍷW]5U B;rrrAFpF|-]i1 c0 If?fIqW"`aXް8 -WvOJ̆A&.#p</w~gOw7(Mμx7׻4R$J Vs ZURu+^]+b0>GlRG(vj_o _0jIp?3gwM>eJ)sD IQ%dSRj\2q ) r*MЈW׈PE瑃d޼*or1]xnPWVqd>3C/6ޏ>iRZ5X䚵< zQ&|EADWBYEgEU|PY_wcWӾCGwN57i]~g6U20-#pHƿ a' 6dw b1:88<<8:7$ &?4nIUXH"TTuBjj"qP!g+kivDXbkyGҼJ>[Q"f8khG@|Qil Ǒn~;]_eq]0i⮭IlBiͧ| 6Xك6VNw@ v?*ΕD(_7/ش뭗~;h+lLQ ԦA'kܪ{^:\?F{ ALPࢢ01@QHKP4,N=B tY\@`%&UvXU-UFNMطĽ8 GgEe7}$s5܀o$FLYNdKex{j4b$:ӌ I=ΈN1IAAM영Z9~m_*o.ESVZqώWx&C f~g8mO(ȗUV7Ԏb骤stbUnc>~2+׭МhWXe)X⪞rM=87gMu:uk~4bMsx8rևnA ǟ?,tc%[ouhK*s/ a5҄u\Ј2 Kgj6ݾsgm"ŠzTVL%Y#ׯ߶|5*)x]ۍ:,[7y=U\¢?A{q,I[?Vvs 5:a;+cw悑H &KV cgI5M w<}/{]7~ /s5OM;7Tj*4I]$NX7Ӷ>`!p}mǗ8Z%'7r{Wt8:q#AًYEftcF*$h[WAfY"q0Nv'[4c lDFrzяa'gйGAjEf~n3?VI@~`]\7lXl&G%^{ 'M{ JOv/S|)ۜ5lZ[zER &gGSQUM@;vGZV$E&)nQ4@C҉$$N٠ ^ڂ4I5 HD-dKeTdUQj#Z]O-uP{rZ6=U!>7yQPaWmAи>Ҩq)0'jgŭ5, % {0P_z;EwPX2ڿwzeWC8$Nىzj ig9rގK]1q%k?pHN7zc$2Z) M+Upk5X㨇/iE*cEHNJůSNb~L5pJ 3r93aO5pq[7e!|uq~l9YH?ZyvxXʠ@Z.T[bA?=Tuea#L_\q_ECW^G W}"vE{x@2pn;78>3+G4]o?k)qɉ}^lie#!vE:Av#In$?2t3L<}83?9IV,{ ?3H1ƴ%|c NLڲYK~w8FDOZ}EӵqAIAF0QKEC꿯_Nޠ:(\ aeaN5(FN2i2o5746qoTco~W/XkSpArֈ4Z^_Ȯ&'M HYvH13RYLK“p |gn.9-5<[%},jՔ7^xb_eaDiYf#]:Z &$.zz\ݍνTR~3=z[֯ N'Ǵ4'54kK!5)U7D`folOV^\m~eQ0 I>E:$p3Q8AG|!.o{4əJH҄R2!;4"?qᑣ"T ph3=n;pY{'QQ~DV<l@ػ?u4MDsV}qq.7ez݆ "Yu.-ԶI,*x7>ad;(|:;s" 1@Lm]רP-}8 cQ N3pm.b>(k"X,E&>&Yjtȗ zfo·7D[]ߴBhtpGv%9Tp%}*DKe'u)Y!4j \F d #.xropp MUguGP$GzE~ FlO)ϑDdC~ ]}|i)n DnHs7h^GT!I]w(6Oֲ~{rSC5w7}g 1^BHӎ5m/ kpUU*5Y|Wa00ߒrZC8>&h*"뀫֕7߁8g{ @XkR+ ٰ}Ap؀XSdGfs_/\}kˏ—PɌiӍmzJ(j9" {mO$ݻ [`mᅾʵ'Ϩit~y\݃ M+t S ͕hfdl)>ߒ vk8] z?MDq[n>]iZ=Tg])Y}iO? XO*'$c5Au7rARk 1-64[0FHu"v[1Hu,Jɝb_ jhEF1HM 6fA! E"ez[*ӰqE_(~$N'#iOٝ;OU@zh/lE 8JCݷҬjlh'Cc*iY"i0[#mZ Eܳ8PyAdN]:p4 ~.xŧ-ɑ[ۗ߸ݩ)q*IR5S8,"IM7(c5aB^u+ݒÊ)ǁy$&,-ΔB]!ue{u\1OZ dʞд~Up1GU4Ђ2#-ΑRXx^B?nhs$4rT}ʎkko&aZ2$SٛqĊˎ7&Wӧ|> stream x]Pj0+渥.Hhiw4jb<({!{C@/JZm^"4iC abp'΢GKXW<ݮU N!Mk! 'ؽ(ò 6n>:= a,ʥ'iNHtH$aW#hԿle4Ì̞_lk (,YQ!$[h9V|z4o endstream endobj 544 0 obj <> stream xcd`aa`dd pv 44 l ?3P`!"Ћ?, @A <*/:yļԒԴ(3=X9WHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ s4u3K2RSRSJsS ^ӃP%E )Ey@W3f0203v0032DCw߂_3}/b~giݽ85Miknik'^sB^@ u3%M2Mmo)C\Vtt}`5Ӂ;Hh:[Aljw?)]$5twvI6Li&7jT?.b>sWfܛg1"Z endstream endobj 545 0 obj <> stream x]Qn0+ت0$I$ވHXݵi=`ն2ѻT/qS|+bC#DW{**ϧc@c$ǛEH{o}eLD8Nk=7uL}{4H>.=Ah19de 4߷48έn)7ܐppLx&,%ٹ˙K&lNv^I\bƄWO\#eR-˄ ,[^B+CPwp_:GSuﻴe~,H endstream endobj 547 0 obj <> stream xڭzxB0 Pz޷ 2P "B٥{3M;IGZhQB2E9Gxp= or:j>s&ch۸i-k_q[ {JmrIAAF%Fƥ$+(@Eɹv\zB|wuzb:&,ZQ\_SS_"H">@ NߥG?ϩʯIJLHWr v;]몘܏v'0UFTuvPli0͈K d:.VNI\öNIĸ@v4to0T2\hl֡5@*BB$,N }:ކMzWs֟X8ME>K)Fk p9I,Pl< ԠQ 駆r.W!G|s6Ơ1SVqى`0S`2t˨V6gQ{_=DfWpt:,"%5۫aAG<:K~H(ߓbJrPv+œhgЂh? ~K)y]a9Vt2>gW8i6ڂxYC-2ĵ)v[klNܽ@Ly(pzN;Qkӽ~ 9: :.5)/Bq~?_~ 5ro/ȵdh1 LTAEԊ7r2=Vh"1ޠ U#Rkϓ0%+WԠ5\C\AV@|Vas@3bW}Nԋ]}.a`>o*FUӓcBh@V!`CEɑ&uV .;UpqBh%ہ!d*x\\v E4=߃_0>S޿ _7%y Ӕ8JX1 4r5KeZ]s}?'@!ZJs1wOxw:M `܅5gֻ3Ѭ/]ѷX&fZ$:t>@4ڋbpWQ3OAo |u6~D?Iti+ayt֣mM# ]@86lOo{HdS _/K=;v 5Ht`踓E̶/=(昛-z3~@% RP۱#)9$[04mp%z"I?X ϣ2.b VS TIC❽Ŭ1<}EmKaqnhPk7C5U?LD{.}Yq(WKBq.!yf1;vEꈐ{<ߢ.ϵ K_1sʕ'`^ hTt4wF5~Qe"͠[l[qǎsDZXI4&yWZ )6i1&ZҼ">O4]EBV ?Ew0ݒIO,:ʁFB5πCG,JWݼbݕ.pԖtV:Ɍ4u:/sGLkbeBBc.Vz( rSyaٱ *&JËa FuCBS6bF!+#jm]=7Xqt8\]^U\5Vr@Q8F`g8.e$.Zl]Wv 2%I2@MHZEϢ_徎Ne]*; Ѯ+?R ^O@Ԓ¥h OFm+J&i$lU6 'Ɣ?2JuHrc1 x>Tvy?]GX־: +}iV"/&2R5j:Ae=v搮;bT^c~q\RBVAmתWi /K9PNTomuAox/$SU<3.׆?A8űj?Ȼba vHT$Z%ߓsWÜ̢sz|LW2T^tc5ł$0uuU"j"Qܷ<(ǵ{ ?VQ ŋcA 9I'͡: Ř{b +pz'k8D7A ?^e)r2-7Qّ{_y1]빅&2ddaSjcNhz ҩbp uQ '^/mZCsOhlu_݉=8m],~QjNV nѳosmGX+j(.7 K[sa6:uCg/cC(ظ/ū umVpϗނ'Bm):[j A:KL1 M>ng.t=SǏ u XqwCqmMJ躘lԧtXX[nWfP.I$-%V j#iER28uaVjv JVRXDzewŝ0>-,/жY;Ag*;{ ֚u\ `DhgԊ BFn7`޽W)1Yɫp|-;{)1$槧lٵu:҇7};wֿf07>n\l9B [9eap+%C`9ňvDshg1\\𶵦yԁޣx1Ktp2dosBɝ- .c7ykⰚU)q^huBUCq]y{ɹ{V+Aj[KnszKbЦ!c(J苪D/ʧ U)XOs5 -Ē_EA\yudnnK}Id+C!v'Ŀ#?!HʉmƉQqzHJzWl_ tM%=_O!) Lye˄o6_z^~vqf4Mt'*!rcS})˜ J޾+tDsv]`}IO-TXʍJ3dhlis6)wF\_X"촴Z[n*aD\bp8ޞ@ !L@Te¿Q5A#qwͻx1-I4齽W"@!) x˧(8v8z⬌M:_/ WTDX SL8DV_N6@SR1JLyEz#Ex> 68[%*\!;/gwY>|<y~g!~ZYnȕ[1UC]و!S)ޤ3bJ$'{*sAS IINtZp/.ZVIMp͋g)~|-ΆoW4U&m/ & b!EWOL4$Zp咺&p ~F "$M30) 1;$G[IlT&.sɧ+I? yCw‘h@HH\p#gJoB? ixקˡڋL=4_u"y"2y"FpMA,;IMyF#)q\GiḰM+'R 1#_ؖdr;$dm1sDʣte _?pʌHxwA$B#X<Ԑy%kY&՝KCkgys#z ;kgԢYݥg,%AK\uWIz+y]ωa¬3Ƣ(#\qb[pWX]_E@q"O y{Y[\sv'g\3Xȍ9ℭ"E-^\W'Uas  U74YMuP25W %b{VaZ>sIuCO'8"e`RkyJ'> A`ζ& A 2Pj͖F Lkl:>9xurU"! w endstream endobj 548 0 obj <> stream x]Qj0+渥-D n[[hoV1D=$yyo23 "+T?CnFQ mi\@h #b5 K_!Ⱦ}z)Uk{zQjh\B#1>(4v/rlroFUkZ:\ %K(qҵ@SYyq' wM+~j(#%t>y|"16Ǧyg!NI#đCd sy-͎6EC͹Y{У.ᐆo endstream endobj 550 0 obj <> stream xڕV PSgEhw ͥuZmU@ZuhZEE@B!bxg ' B W]VtVTV{wwg&aw?9wI"0 I2l;͍KHߺuAy?L{ @.yhAƆ+{zO\Q)iJX8H$әBeAD #kWuz5bO$Mf"JIl#o;I&eـ~ PpHQ'*P:+X\6-lZzHX9Ϋ\Be%a5J#d,P8t ӫddHӤőw"psEnkN3=TK7vɡ}*R@ VZP&S9]aIq=,ʨlxGfO}ɄLJfY.DQhs?-p%Q'CÌSHR2 ^?TazQ]u^ 7~~\}Ys*Ws"V c|TdTe+= # 7 w P37̘l`ݓ EՔZ1C]U!T.@[e`2ߦ=vwC7?Y^:0`ዬçn(2-XKJq*J Ui{svlՋ(Y BcAo6]㶾cWa'~<9P"ݷ}mf)bSŅm{6A$Ax{Nُ+UPJ{Q.x`S)ټMD~u^gykpE*j9?]@UeIA@'< VWl0+eC݇4[X$Wf32~慅1,۲|U; 8ТZY 9[y0t|MX]SGyFVg4im:YgRYOҮxԢT۔:{2 BjZ;Ϝ;d}r}"WDou;fOwo=L޲_l'ѹl2әgl{G?42x|̦>Dc@"OSɍ5^+_z/ q_^λބ^@;x^y5@єǡq쥌O"a߮i> j>PIqo:3 PQv{ 䬹'AtJUdlʠieԂKu8j52Jםj3:z&W7w~+qrni:0O!Z?.Zz ߽8j`Pq8 0# AX{c_ߺfY XVQ7&0Y}ӡ 衋oY(wM&ʼ>O}OQ>&!G^_"c28ΛDn="^--d%$ѤWHV]VX*MLOSwYx7[ڞ鐛WXv4li~u Q`2'#5]iXުB]U>N/|/Yųp3E c#_rȆL1J] *k a\vY~kZ*l2q.TE芁-,_'FӡCIDbpbF=P+uXivո.>4݇ 㘴.=c9oƲHgGxjC {z|c+!Yz7xvR^ : GOE 8ud+ ij6>yұ d$k,7 @f%t G~-ċ QlPaӼd.XmÈi @^u %Cz/ OQty[Nhcc}'aoxp/]S@MӅ: dME"fpYnqQp.&Tu&a;> stream x]Pn >nUU=HUVQ#u D!F{#gliӝ;gu FLůQ# 8YG*td%YB jFz}Eʊ?]e[=F[@GޝmI8wn {% N/h0Z7~qF.N\jm[t_P Qw&cUݞ^c#GyuxS!|mI endstream endobj 553 0 obj <> stream xcd`aa`dds v 14v7i2?d~1ge``x%" RH0 102rt9Teg(h$k*ZZ(X*8e&')&d&99 ə% 6%%VzzEv: % AũEe) ny% ~ GA(܂Ғ"Ԣ<df`bdd ~k3_!gD{Nꋚ;YpY=38|O۝ܝݜ>wDOmOe 8p~:IGp9+Rc֓{ endstream endobj 554 0 obj <> stream x]n0EY*^ $B !5}=HX,Ef;L} O3'h;% +:Ţd'e翢o4 M|op|S\eĖY#˾8a_v> stream xmV TTMLž;O674)@ "0 ð28,8̰ 4˅¥|e/.ι|c#C7- *z$918Cg08M=9-oΙ/rbV\\ //@D.MNL {,xy 6 q"AX,I'^RdL.X$I^^B,M\\,KD3,a`X$ǥ 3W@q$S& B [bA.,Kd,R cOc N+ۄmƶ`!X: v`;9b[|nw;|+p\8TpL&ʈmOƨܘ|26GrcB??Yܡ8\\i@ag/r$8.'KdВUdnTA1LMyݿyҰ:jcV6r`p36z6|6}BՔiThAO 9ݴ}&() ~Jz8AZ|Wfߺo6^Y53K_ߩl45vte4dR%3z'<rTشdDCpB-aDuFA;:|3ohDNWn4T%**ثJ`gWAJ(!zJ Fa Q(r'B n ?&j GMKNT^zr)o<4{?ن~zmxI~%xQ\lI;R4z =|_&م_ěaʅ]DmO!7GܡT_auݠOtn]YVdyvU .u"=tPO W0[YIJh%녂;PՅ Mi1]䦥@nb#OAtmB?o|ҊPF^eEG̒4Ui/PV"]RVeUYHo%Xge?0〷\C즊?᧖s̃9jlܗcB_O>RMۣ,y+() ~Ӱ8ZNZXbwBG8ѧ@6bvȝ]̀Rc9"Q8OAN~c SJ*3/Soo`z!6t6W&wnIU`A TUikGaD_|`.W[xȇq%uE73DdomknnO<Bo:`67ҳԇ0h3 WL| HәЧ3# eGب')@h} Mad<(ن\E<4f(M'=\ȗ=o=}F f-uAʣ#4o"d>At@tEopmu9艮=\u3hA 4W-`x.:.f?NAKJh%Kեk‌{ɂ6![z q&ԿL„/p@(v 1GЮM곽MG(+U@!_[Фk[$j$祵&%h= =k "H=R]#anz;?)Njsyp(AQ[d4W76|_xJ ֎Z%@$GEe#Ѡ54% o 'Xm>O qˇyps) `Vqzf$-SonX {Kq"B(akx[BDHf@1k>K:(LQLZqLrK@^89hyk़=s?AH}x.n̜|k<nF鸩PQ. )j-l2wH,jysf-2rd韀\ǻ|3u%dON:51x ԛ%~xT1l}ޱLҽT0LruU,R9.biZl6iBEcSqhg0~&SR\V)CrQz.ZZ#ZCK|.BΚ&.R7N}";} ^"Pw),؈ĵ:3WGXgM6ָL4R]@~ 9 endstream endobj 557 0 obj <> stream x]Pj0 +t#N;@Ilci=:8! = ޓU}{+[ k> stream xcd`aa`ddrswv445gi2?d~1g{I |"_ Hu (!QVm``g``_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܮs JKR|SRb:EGoa[tEW_XlӦ}/X;a*|I<\=< p/إc endstream endobj 560 0 obj <> stream x]PMo0 WiBhR}A@H T(~$E=`K~~3~y+[ 0h> stream xcd`aa`dd t v44dgi2?d~1g{I |"_ Hu (!QVm``g``_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܮs JKR|SRb:EG_~er@tE⼼⼼+V,^Btif|];q|I<\=<ܫ.s/c endstream endobj 469 0 obj <> stream xڽ\kF_o gWNNBx-კ73!$~oulIFvKu[776B*^hhiCQ((oq^4HQ1h6.'ǺyӺrk$  qz3"I6hx64Ӥ_K8epd }*F:No/t IQ9PG\\A50!Qh"VJ@#@-M*Fj`.- 7FѠiHΒ H$Fx,0 =V @1 %IAz\4:KD @ch!1KH!+J%PS9d d%,(5C4L֤%D*蒤- 1 $K,]`('VFH 4fiD#9& (PpaN,i4p !7HQB41 L | rpxf98&1 #r,9_,0PTLQiQ @AkE@:E*%P!ԍ Yq4<'aN "i(8:qguh5`[Nj\(qڍh<7hDF B\ h)m(K @/ H!we{ZqהQ0JX7 q4&P2@5PRb @@q`pb'y^B@SpP2pZTʗr1d`DCɁe'(\‰gr0  nA (b7)X(RF11ހ9>§>ce+A"/e|J3񤇲;Jp8` |M1Kԃs pb#H_wIY] K'_-{8u{e.\mqy%,x@®=._8D<Wo  Za0MiJԋzU@j j!dA+c4 T-/@MCLO})^ ѪN7 l&=$j NP:՛RfpfވS-A0$O{Z}13رVJ|6P [ nu xPL:tSnȦRp;[-TPɹEBs5i ^JbB5 Zae"2WP j Z yr3'4L;?IRBA #'tcZ})3x3Vo BнdtrF5OTK3 JtiZ}13RJ(lkT]h!]Rsj\5/ϗd3øv^ҪZ V1 /"lbf[ TK3 ya aኙatWQTK(\]h d.x9koȵ7* ҍWyI%Tm ~\ ;/x0ÀJ5/ Za@2"q*PqY)A6Ij 24(R;:tSɗl2cVhx/a3N/f;V_@j vigST/ Vs He_BXbfc%BBp+Y+AB649mtٹ\wB%_-ޥI !cvyIgĨKi]-A1 y@iYP_3b\>të%i|dZ})ψ=Je [-*L}Aghҧ t{;'l*9y VBhd?a")|_B)3q+T B.ai^ rT4 Zc@^qYP_ R ZB(HPDݓJt^j=bFh\5e6SxNRvltRJEGye^N"/X*H 'taۦUQӅrhҪaWK(Vtmh!ֳB3Wͼ;׼{Jy Iy6ݔ_rqcɵ|YuخWgfu=w\(^e֫v}oWЋ'7],WgʭoIhq/5)F\l'c\eɟ<菤eawX>θ|Uq܁_u\Dy:sw"{pw^BfU"=[7eBlOBA3v>[@gwH:rflHGMWƓ>c ޽ROIHϸq,,|YJ#;o\N=yQg uv"B(sqlj;eiDD'7I2vȇ}H%0V<¿둡Jgqv֮wꁵ6 %{WӴS;G͓{$}z\p>#GnH4d'Whdsrl`>xBsy)_w:ǜ'2Q(ca!d#!WR${+@ mLӖ(ٰ?؝N kIJؼoT졺RX!t4DʗJh4|j;}[㿴m?*O +0X4bvg*gK!Ԇ1uQot@g{ly:jey}7^ns,o !vN<~E (.POX:/ gOsi%}8LJ0 uOӺ-Ih$t$y7S$4\tk"LE_vYȷg\%"&9~6wQ=!€۞J a߄gϦau@s է%AѿaL2hmgG b37+% M1j922A3MfEmNGvyrX8E5 v4T?3JSA9)/r}Y\T?tj9U†_N?װ=ΩCG>xP |O| %ӳw?KZzfN [oym&Gu蛂9Ɗ endstream endobj 572 0 obj <> stream xڵKO0=PY;DBH4(j.Wy{jZ6c[;,x dā!@(#N@b6焙)-olc#sV걙H)\)^艝Jo3]6K~9Wk'~?L<3WznMWt1;;kK|>4,8zLM;ܙ =-ásP"֠|fk:N 9$q d*ChJBh*"~L/0 NQc%F;j^ 9^,ON0_enؠ!wbbtQ5w[aYϩf@UkSN:/ _U?kr19 endstream endobj 575 0 obj <<9380306b7c157af9283354de934c764e>]/Size 576/W[1 3 2]/Filter/FlateDecode/Length 1498>> stream x5gPWB+bb Db X 6b {ǂ A쨩c3!ǘѨ&d 9ewy*ԇZ:JSx|JREez泗٫z(? v#T@f7Aq-M.*rnjuHď9GէHqv7Ԑ"%ؽPdv?TBH{T!X 0BRlԆ",oDʰGeeCe)Ǟ:}Q<{*oH6HE4|J"Y?ٮT as>3YTc/VTguDBk@["au H8{QR$ ļ=EjR40H-$ ME"u(~@[(ŁM?ԥG) d|+R-Ҁ] #<2"(S4Tg)ޙ(d*hADZRCW+Ҋ HkJ8t-"m(fԄ`vZESjCQ.t]Qz7t4NJD^H3tq.[Օzo')͠3E>4ΉFi H4 \vwDzPC?HI~*ҋEޔЯt~o򧔮pth~h8!Dd'"1pkKS$")}'2N7qpbL.22΄"C)qpfF g^pP8Kj ZC$2x8DFQFj'22ιw"c(c\X88<2νI"(O8, p^h)p^ @ cIpE'Sf J"JER 22n*"Smiyṗ̠ۻLJ28{͢,;H"e)v%Qkp'̦,ƞ9pKY wOyUp3OI3H$nnC/)pکA" )]}eܧES6kV/lP+vx,jgrJVO^]!{*? H e?k5 &v_C9=k)ᵵO ,bw6v'aك<{fO؛l{3ʢc-!l),[̚jlk=̓finf9bfqffcvZ350ٓ^dUO}Zf$fg0:5Yf}bvsMk@s56}{c3sr~"@Qq>Y+ o={O.Ɂ[wiO EN%'O։OM9 K[5|oyx=\"{^co7\e_DY/`Rp endstream endobj startxref 396383 %%EOF gcl-2.6.14/info/gcl-tk.info0000644000175000017500000000276414360276512013775 0ustar cammcammThis is gcl-tk.info, produced by makeinfo version 6.7 from gcl-tk.texi. INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU TK Manual END-INFO-DIR-ENTRY This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter  Indirect: gcl-tk.info-1: 258 gcl-tk.info-2: 300905  Tag Table: (Indirect) Node: Top258 Node: General1087 Node: Introduction1374 Node: Getting Started2871 Node: Common Features of Widgets4473 Node: Return Values8135 Node: Argument Lists12193 Node: Lisp Functions Invoked from Graphics15625 Node: Linked Variables20678 Node: tkconnect24411 Node: Widgets26338 Node: button26626 Node: listbox33347 Node: scale41766 Node: canvas49013 Node: menu109714 Node: scrollbar128873 Node: checkbutton136162 Node: menubutton145900 Node: text153878 Node: entry188019 Node: message198361 Node: frame204319 Node: label208322 Node: radiobutton211737 Node: toplevel221174 Node: Control225016 Node: after225395 Node: bind226551 Node: destroy242234 Node: tk-dialog242819 Node: exit244634 Node: focus245311 Node: grab250026 Node: tk-listbox-single-select254694 Node: lower255598 Node: tk-menu-bar256476 Node: option262144 Node: options265226 Node: pack-old282810 Node: pack290570 Node: place300906 Node: raise309727 Node: selection310586 Node: send315792 Node: tk317613 Node: tkerror319450 Node: tkvars321174 Node: tkwait323442 Node: update324926 Node: winfo326448 Node: wm334891  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.6.14/info/gcl.info-10000644000175000017500000111375514360276512013523 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: Top, Next: Introduction (Introduction), Prev: (dir), Up: (dir) * Menu: * Introduction (Introduction):: * Syntax:: * Evaluation and Compilation:: * Types and Classes:: * Data and Control Flow:: * Iteration:: * Objects:: * Structures:: * Conditions:: * Symbols:: * Packages:: * Numbers (Numbers):: * Characters:: * Conses:: * Arrays:: * Strings:: * Sequences:: * Hash Tables:: * Filenames:: * Files:: * Streams:: * Printer:: * Reader:: * System Construction:: * Environment:: * Glossary (Glossary):: * Appendix:: -- The Detailed Node Listing -- Introduction * Scope:: * Organization of the Document:: * Referenced Publications:: * Definitions:: * Conformance:: * Language Extensions:: * Language Subsets:: * Deprecated Language Features:: * Symbols in the COMMON-LISP Package:: Scope, Purpose, and History * Scope and Purpose:: * History:: Definitions * Notational Conventions:: * Error Terminology:: * Sections Not Formally Part Of This Standard:: * Interpreting Dictionary Entries:: Notational Conventions * Font Key:: * Modified BNF Syntax:: * Splicing in Modified BNF Syntax:: * Indirection in Modified BNF Syntax:: * Additional Uses for Indirect Definitions in Modified BNF Syntax:: * Special Symbols:: * Objects with Multiple Notations:: * Case in Symbols:: * Numbers (Objects with Multiple Notations):: * Use of the Dot Character:: * NIL:: * Designators:: * Nonsense Words:: Interpreting Dictionary Entries * The "Affected By" Section of a Dictionary Entry:: * The "Arguments" Section of a Dictionary Entry:: * The "Arguments and Values" Section of a Dictionary Entry:: * The "Binding Types Affected" Section of a Dictionary Entry:: * The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: * The "Compound Type Specifier Kind" Section of a Dictionary Entry:: * The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: * The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: * The "Compound Type Specifier Description" Section of a Dictionary Entry:: * The "Constant Value" Section of a Dictionary Entry:: * The "Description" Section of a Dictionary Entry:: * The "Examples" Section of a Dictionary Entry:: * The "Exceptional Situations" Section of a Dictionary Entry:: * The "Initial Value" Section of a Dictionary Entry:: * The "Argument Precedence Order" Section of a Dictionary Entry:: * The "Method Signature" Section of a Dictionary Entry:: * The "Name" Section of a Dictionary Entry:: * The "Notes" Section of a Dictionary Entry:: * The "Pronunciation" Section of a Dictionary Entry:: * The "See Also" Section of a Dictionary Entry:: * The "Side Effects" Section of a Dictionary Entry:: * The "Supertypes" Section of a Dictionary Entry:: * The "Syntax" Section of a Dictionary Entry:: * Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: * Requiring Non-Null Rest Parameters in The "Syntax" Section:: * Return values in The "Syntax" Section:: * No Arguments or Values in The "Syntax" Section:: * Unconditional Transfer of Control in The "Syntax" Section:: * The "Valid Context" Section of a Dictionary Entry:: * The "Value Type" Section of a Dictionary Entry:: Conformance * Conforming Implementations:: * Conforming Programs:: Conforming Implementations * Required Language Features:: * Documentation of Implementation-Dependent Features:: * Documentation of Extensions:: * Treatment of Exceptional Situations:: * Resolution of Apparent Conflicts in Exceptional Situations:: * Examples of Resolution of Apparent Conflict in Exceptional Situations:: * Conformance Statement:: Conforming Programs * Use of Implementation-Defined Language Features:: * Use of Read-Time Conditionals:: Deprecated Language Features * Deprecated Functions:: * Deprecated Argument Conventions:: * Deprecated Variables:: * Deprecated Reader Syntax:: Syntax * Character Syntax:: * Reader Algorithm:: * Interpretation of Tokens:: * Standard Macro Characters:: Character Syntax * Readtables:: * Variables that affect the Lisp Reader:: * Standard Characters:: * Character Syntax Types:: Readtables * The Current Readtable:: * The Standard Readtable:: * The Initial Readtable:: Character Syntax Types * Constituent Characters:: * Constituent Traits:: * Invalid Characters:: * Macro Characters:: * Multiple Escape Characters:: * Examples of Multiple Escape Characters:: * Single Escape Character:: * Examples of Single Escape Characters:: * Whitespace Characters:: * Examples of Whitespace Characters:: Interpretation of Tokens * Numbers as Tokens:: * Constructing Numbers from Tokens:: * The Consing Dot:: * Symbols as Tokens:: * Valid Patterns for Tokens:: * Package System Consistency Rules:: Numbers as Tokens * Potential Numbers as Tokens:: * Escape Characters and Potential Numbers:: * Examples of Potential Numbers:: Constructing Numbers from Tokens * Syntax of a Rational:: * Syntax of an Integer:: * Syntax of a Ratio:: * Syntax of a Float:: * Syntax of a Complex:: Standard Macro Characters * Left-Parenthesis:: * Right-Parenthesis:: * Single-Quote:: * Semicolon:: * Double-Quote:: * Backquote:: * Comma:: * Sharpsign:: * Re-Reading Abbreviated Expressions:: Single-Quote * Examples of Single-Quote:: Semicolon * Examples of Semicolon:: * Notes about Style for Semicolon:: * Use of Single Semicolon:: * Use of Double Semicolon:: * Use of Triple Semicolon:: * Use of Quadruple Semicolon:: * Examples of Style for Semicolon:: Backquote * Notes about Backquote:: Sharpsign * Sharpsign Backslash:: * Sharpsign Single-Quote:: * Sharpsign Left-Parenthesis:: * Sharpsign Asterisk:: * Examples of Sharpsign Asterisk:: * Sharpsign Colon:: * Sharpsign Dot:: * Sharpsign B:: * Sharpsign O:: * Sharpsign X:: * Sharpsign R:: * Sharpsign C:: * Sharpsign A:: * Sharpsign S:: * Sharpsign P:: * Sharpsign Equal-Sign:: * Sharpsign Sharpsign:: * Sharpsign Plus:: * Sharpsign Minus:: * Sharpsign Vertical-Bar:: * Examples of Sharpsign Vertical-Bar:: * Notes about Style for Sharpsign Vertical-Bar:: * Sharpsign Less-Than-Sign:: * Sharpsign Whitespace:: * Sharpsign Right-Parenthesis:: Evaluation and Compilation * Evaluation:: * Compilation:: * Declarations:: * Lambda Lists:: * Error Checking in Function Calls:: * Traversal Rules and Side Effects:: * Destructive Operations:: * Evaluation and Compilation Dictionary:: Evaluation * Introduction to Environments:: * The Evaluation Model:: * Lambda Expressions:: * Closures and Lexical Binding:: * Shadowing:: * Extent:: * Return Values:: Introduction to Environments * The Global Environment:: * Dynamic Environments:: * Lexical Environments:: * The Null Lexical Environment:: * Environment Objects:: The Evaluation Model * Form Evaluation:: * Symbols as Forms:: * Lexical Variables:: * Dynamic Variables:: * Constant Variables:: * Symbols Naming Both Lexical and Dynamic Variables:: * Conses as Forms:: * Special Forms:: * Macro Forms:: * Function Forms:: * Lambda Forms:: * Self-Evaluating Objects:: * Examples of Self-Evaluating Objects:: Compilation * Compiler Terminology:: * Compilation Semantics:: * File Compilation:: * Literal Objects in Compiled Files:: * Exceptional Situations in the Compiler:: Compilation Semantics * Compiler Macros:: * Purpose of Compiler Macros:: * Naming of Compiler Macros:: * When Compiler Macros Are Used:: * Notes about the Implementation of Compiler Macros:: * Minimal Compilation:: * Semantic Constraints:: File Compilation * Processing of Top Level Forms:: * Processing of Defining Macros:: * Constraints on Macros and Compiler Macros:: Literal Objects in Compiled Files * Externalizable Objects:: * Similarity of Literal Objects:: * Similarity of Aggregate Objects:: * Definition of Similarity:: * Extensions to Similarity Rules:: * Additional Constraints on Externalizable Objects:: Declarations * Minimal Declaration Processing Requirements:: * Declaration Specifiers:: * Declaration Identifiers:: * Declaration Scope:: Declaration Identifiers * Shorthand notation for Type Declarations:: Declaration Scope * Examples of Declaration Scope:: Lambda Lists * Ordinary Lambda Lists:: * Generic Function Lambda Lists:: * Specialized Lambda Lists:: * Macro Lambda Lists:: * Destructuring Lambda Lists:: * Boa Lambda Lists:: * Defsetf Lambda Lists:: * Deftype Lambda Lists:: * Define-modify-macro Lambda Lists:: * Define-method-combination Arguments Lambda Lists:: * Syntactic Interaction of Documentation Strings and Declarations:: Ordinary Lambda Lists * Specifiers for the required parameters:: * Specifiers for optional parameters:: * A specifier for a rest parameter:: * Specifiers for keyword parameters:: * Suppressing Keyword Argument Checking:: * Examples of Suppressing Keyword Argument Checking:: * Specifiers for &aux variables:: * Examples of Ordinary Lambda Lists:: Macro Lambda Lists * Destructuring by Lambda Lists:: * Data-directed Destructuring by Lambda Lists:: * Examples of Data-directed Destructuring by Lambda Lists:: * Lambda-list-directed Destructuring by Lambda Lists:: Error Checking in Function Calls * Argument Mismatch Detection:: Argument Mismatch Detection * Safe and Unsafe Calls:: * Error Detection Time in Safe Calls:: * Too Few Arguments:: * Too Many Arguments:: * Unrecognized Keyword Arguments:: * Invalid Keyword Arguments:: * Odd Number of Keyword Arguments:: * Destructuring Mismatch:: * Errors When Calling a Next Method:: Destructive Operations * Modification of Literal Objects:: * Transfer of Control during a Destructive Operation:: Transfer of Control during a Destructive Operation * Examples of Transfer of Control during a Destructive Operation:: Evaluation and Compilation Dictionary * lambda (Symbol):: * lambda:: * compile:: * eval:: * eval-when:: * load-time-value:: * quote:: * compiler-macro-function:: * define-compiler-macro:: * defmacro:: * macro-function:: * macroexpand:: * define-symbol-macro:: * symbol-macrolet:: * *macroexpand-hook*:: * proclaim:: * declaim:: * declare:: * ignore:: * dynamic-extent:: * type:: * inline:: * ftype:: * declaration:: * optimize:: * special:: * locally:: * the:: * special-operator-p:: * constantp:: Types and Classes * Introduction (Types and Classes):: * Types:: * Classes:: * Types and Classes Dictionary:: Types * Data Type Definition:: * Type Relationships:: * Type Specifiers:: Classes * Introduction to Classes:: * Defining Classes:: * Creating Instances of Classes:: * Inheritance:: * Determining the Class Precedence List:: * Redefining Classes:: * Integrating Types and Classes:: Introduction to Classes * Standard Metaclasses:: Inheritance * Examples of Inheritance:: * Inheritance of Class Options:: Determining the Class Precedence List * Topological Sorting:: * Examples of Class Precedence List Determination:: Redefining Classes * Modifying the Structure of Instances:: * Initializing Newly Added Local Slots (Redefining Classes):: * Customizing Class Redefinition:: Types and Classes Dictionary * nil (Type):: * boolean:: * function (System Class):: * compiled-function:: * generic-function:: * standard-generic-function:: * class:: * built-in-class:: * structure-class:: * standard-class:: * method:: * standard-method:: * structure-object:: * standard-object:: * method-combination:: * t (System Class):: * satisfies:: * member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: * values (Type Specifier):: * eql (Type Specifier):: * coerce:: * deftype:: * subtypep:: * type-of:: * typep:: * type-error:: * type-error-datum:: * simple-type-error:: Data and Control Flow * Generalized Reference:: * Transfer of Control to an Exit Point:: * Data and Control Flow Dictionary:: Generalized Reference * Overview of Places and Generalized Reference:: * Kinds of Places:: * Treatment of Other Macros Based on SETF:: Overview of Places and Generalized Reference * Evaluation of Subforms to Places:: * Examples of Evaluation of Subforms to Places:: * Setf Expansions:: * Examples of Setf Expansions:: Kinds of Places * Variable Names as Places:: * Function Call Forms as Places:: * VALUES Forms as Places:: * THE Forms as Places:: * APPLY Forms as Places:: * Setf Expansions and Places:: * Macro Forms as Places:: * Symbol Macros as Places:: * Other Compound Forms as Places:: Data and Control Flow Dictionary * apply:: * defun:: * fdefinition:: * fboundp:: * fmakunbound:: * flet:: * funcall:: * function (Special Operator):: * function-lambda-expression:: * functionp:: * compiled-function-p:: * call-arguments-limit:: * lambda-list-keywords:: * lambda-parameters-limit:: * defconstant:: * defparameter:: * destructuring-bind:: * let:: * progv:: * setq:: * psetq:: * block:: * catch:: * go:: * return-from:: * return:: * tagbody:: * throw:: * unwind-protect:: * nil:: * not:: * t:: * eq:: * eql:: * equal:: * equalp:: * identity:: * complement:: * constantly:: * every:: * and:: * cond:: * if:: * or:: * when:: * case:: * typecase:: * multiple-value-bind:: * multiple-value-call:: * multiple-value-list:: * multiple-value-prog1:: * multiple-value-setq:: * values:: * values-list:: * multiple-values-limit:: * nth-value:: * prog:: * prog1:: * progn:: * define-modify-macro:: * defsetf:: * define-setf-expander:: * get-setf-expansion:: * setf:: * shiftf:: * rotatef:: * control-error:: * program-error:: * undefined-function:: Iteration * The LOOP Facility:: * Iteration Dictionary:: The LOOP Facility * Overview of the Loop Facility:: * Variable Initialization and Stepping Clauses:: * Value Accumulation Clauses:: * Termination Test Clauses:: * Unconditional Execution Clauses:: * Conditional Execution Clauses:: * Miscellaneous Clauses:: * Examples of Miscellaneous Loop Features:: * Notes about Loop:: Overview of the Loop Facility * Simple vs Extended Loop:: * Simple Loop:: * Extended Loop:: * Loop Keywords:: * Parsing Loop Clauses:: * Expanding Loop Forms:: * Summary of Loop Clauses:: * Summary of Variable Initialization and Stepping Clauses:: * Summary of Value Accumulation Clauses:: * Summary of Termination Test Clauses:: * Summary of Unconditional Execution Clauses:: * Summary of Conditional Execution Clauses:: * Summary of Miscellaneous Clauses:: * Order of Execution:: * Destructuring:: * Restrictions on Side-Effects:: Variable Initialization and Stepping Clauses * Iteration Control:: * The for-as-arithmetic subclause:: * Examples of for-as-arithmetic subclause:: * The for-as-in-list subclause:: * Examples of for-as-in-list subclause:: * The for-as-on-list subclause:: * Examples of for-as-on-list subclause:: * The for-as-equals-then subclause:: * Examples of for-as-equals-then subclause:: * The for-as-across subclause:: * Examples of for-as-across subclause:: * The for-as-hash subclause:: * The for-as-package subclause:: * Examples of for-as-package subclause:: * Local Variable Initializations:: * Examples of WITH clause:: Value Accumulation Clauses * Examples of COLLECT clause:: * Examples of APPEND and NCONC clauses:: * Examples of COUNT clause:: * Examples of MAXIMIZE and MINIMIZE clauses:: * Examples of SUM clause:: Termination Test Clauses * Examples of REPEAT clause:: * Examples of ALWAYS:: * Examples of WHILE and UNTIL clauses:: Unconditional Execution Clauses * Examples of unconditional execution:: Conditional Execution Clauses * Examples of WHEN clause:: Miscellaneous Clauses * Control Transfer Clauses:: * Examples of NAMED clause:: * Initial and Final Execution:: Examples of Miscellaneous Loop Features * Examples of clause grouping:: Iteration Dictionary * do:: * dotimes:: * dolist:: * loop:: * loop-finish:: Objects * Object Creation and Initialization:: * Changing the Class of an Instance:: * Reinitializing an Instance:: * Meta-Objects:: * Slots:: * Generic Functions and Methods:: * Objects Dictionary:: Object Creation and Initialization * Initialization Arguments:: * Declaring the Validity of Initialization Arguments:: * Defaulting of Initialization Arguments:: * Rules for Initialization Arguments:: * Shared-Initialize:: * Initialize-Instance:: * Definitions of Make-Instance and Initialize-Instance:: Changing the Class of an Instance * Modifying the Structure of the Instance:: * Initializing Newly Added Local Slots (Changing the Class of an Instance):: * Customizing the Change of Class of an Instance:: Reinitializing an Instance * Customizing Reinitialization:: Meta-Objects * Standard Meta-objects:: Slots * Introduction to Slots:: * Accessing Slots:: * Inheritance of Slots and Slot Options:: Generic Functions and Methods * Introduction to Generic Functions:: * Introduction to Methods:: * Agreement on Parameter Specializers and Qualifiers:: * Congruent Lambda-lists for all Methods of a Generic Function:: * Keyword Arguments in Generic Functions and Methods:: * Method Selection and Combination:: * Inheritance of Methods:: Keyword Arguments in Generic Functions and Methods * Examples of Keyword Arguments in Generic Functions and Methods:: Method Selection and Combination * Determining the Effective Method:: * Selecting the Applicable Methods:: * Sorting the Applicable Methods by Precedence Order:: * Applying method combination to the sorted list of applicable methods:: * Standard Method Combination:: * Declarative Method Combination:: * Built-in Method Combination Types:: Objects Dictionary * function-keywords:: * ensure-generic-function:: * allocate-instance:: * reinitialize-instance:: * shared-initialize:: * update-instance-for-different-class:: * update-instance-for-redefined-class:: * change-class:: * slot-boundp:: * slot-exists-p:: * slot-makunbound:: * slot-missing:: * slot-unbound:: * slot-value:: * method-qualifiers:: * no-applicable-method:: * no-next-method:: * remove-method:: * make-instance:: * make-instances-obsolete:: * make-load-form:: * make-load-form-saving-slots:: * with-accessors:: * with-slots:: * defclass:: * defgeneric:: * defmethod:: * find-class:: * next-method-p:: * call-method:: * call-next-method:: * compute-applicable-methods:: * define-method-combination:: * find-method:: * add-method:: * initialize-instance:: * class-name:: * (setf class-name):: * class-of:: * unbound-slot:: * unbound-slot-instance:: Structures * Structures Dictionary:: Structures Dictionary * defstruct:: * copy-structure:: Conditions * Condition System Concepts:: * Conditions Dictionary:: Condition System Concepts * Condition Types:: * Creating Conditions:: * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: * Notes about the Condition System`s Background:: Condition Types * Serious Conditions:: Creating Conditions * Condition Designators:: Printing Conditions * Recommended Style in Condition Reporting:: * Capitalization and Punctuation in Condition Reports:: * Leading and Trailing Newlines in Condition Reports:: * Embedded Newlines in Condition Reports:: * Note about Tabs in Condition Reports:: * Mentioning Containing Function in Condition Reports:: Signaling and Handling Conditions * Signaling:: * Resignaling a Condition:: * Restarts:: * Interactive Use of Restarts:: * Interfaces to Restarts:: * Restart Tests:: * Associating a Restart with a Condition:: Conditions Dictionary * condition:: * warning:: * style-warning:: * serious-condition:: * error (Condition Type):: * cell-error:: * cell-error-name:: * parse-error:: * storage-condition:: * assert:: * error:: * cerror:: * check-type:: * simple-error:: * invalid-method-error:: * method-combination-error:: * signal:: * simple-condition:: * simple-condition-format-control:: * warn:: * simple-warning:: * invoke-debugger:: * break:: * *debugger-hook*:: * *break-on-signals*:: * handler-bind:: * handler-case:: * ignore-errors:: * define-condition:: * make-condition:: * restart:: * compute-restarts:: * find-restart:: * invoke-restart:: * invoke-restart-interactively:: * restart-bind:: * restart-case:: * restart-name:: * with-condition-restarts:: * with-simple-restart:: * abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: * abort (Function):: Symbols * Symbol Concepts:: * Symbols Dictionary:: Symbols Dictionary * symbol:: * keyword:: * symbolp:: * keywordp:: * make-symbol:: * copy-symbol:: * gensym:: * *gensym-counter*:: * gentemp:: * symbol-function:: * symbol-name:: * symbol-package:: * symbol-plist:: * symbol-value:: * get:: * remprop:: * boundp:: * makunbound:: * set:: * unbound-variable:: Packages * Package Concepts:: * Packages Dictionary:: Package Concepts * Introduction to Packages:: * Standardized Packages:: Introduction to Packages * Package Names and Nicknames:: * Symbols in a Package:: * Internal and External Symbols:: * Package Inheritance:: * Accessibility of Symbols in a Package:: * Locating a Symbol in a Package:: * Prevention of Name Conflicts in Packages:: Standardized Packages * The COMMON-LISP Package:: * Constraints on the COMMON-LISP Package for Conforming Implementations:: * Constraints on the COMMON-LISP Package for Conforming Programs:: * Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs:: * The COMMON-LISP-USER Package:: * The KEYWORD Package:: * Interning a Symbol in the KEYWORD Package:: * Notes about The KEYWORD Package:: * Implementation-Defined Packages:: Packages Dictionary * package:: * export:: * find-symbol:: * find-package:: * find-all-symbols:: * import:: * list-all-packages:: * rename-package:: * shadow:: * shadowing-import:: * delete-package:: * make-package:: * with-package-iterator:: * unexport:: * unintern:: * in-package:: * unuse-package:: * use-package:: * defpackage:: * do-symbols:: * intern:: * package-name:: * package-nicknames:: * package-shadowing-symbols:: * package-use-list:: * package-used-by-list:: * packagep:: * *package*:: * package-error:: * package-error-package:: Numbers * Number Concepts:: * Numbers Dictionary:: Number Concepts * Numeric Operations:: * Implementation-Dependent Numeric Constants:: * Rational Computations:: * Floating-point Computations:: * Complex Computations:: * Interval Designators:: * Random-State Operations:: Numeric Operations * Associativity and Commutativity in Numeric Operations:: * Examples of Associativity and Commutativity in Numeric Operations:: * Contagion in Numeric Operations:: * Viewing Integers as Bits and Bytes:: * Logical Operations on Integers:: * Byte Operations on Integers:: Rational Computations * Rule of Unbounded Rational Precision:: * Rule of Canonical Representation for Rationals:: * Rule of Float Substitutability:: Floating-point Computations * Rule of Float and Rational Contagion:: * Examples of Rule of Float and Rational Contagion:: * Rule of Float Approximation:: * Rule of Float Underflow and Overflow:: * Rule of Float Precision Contagion:: Complex Computations * Rule of Complex Substitutability:: * Rule of Complex Contagion:: * Rule of Canonical Representation for Complex Rationals:: * Examples of Rule of Canonical Representation for Complex Rationals:: * Principal Values and Branch Cuts:: Numbers Dictionary * number:: * complex (System Class):: * real:: * float (System Class):: * short-float:: * rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: * mod (System Class):: * bit (System Class):: * fixnum:: * bignum:: * =:: * max:: * minusp:: * zerop:: * floor:: * sin:: * asin:: * pi:: * sinh:: * *:: * +:: * -:: * /:: * 1+:: * abs:: * evenp:: * exp:: * gcd:: * incf:: * lcm:: * log:: * mod (Function):: * signum:: * sqrt:: * random-state:: * make-random-state:: * random:: * random-state-p:: * *random-state*:: * numberp:: * cis:: * complex:: * complexp:: * conjugate:: * phase:: * realpart:: * upgraded-complex-part-type:: * realp:: * numerator:: * rational (Function):: * rationalp:: * ash:: * integer-length:: * integerp:: * parse-integer:: * boole:: * boole-1:: * logand:: * logbitp:: * logcount:: * logtest:: * byte:: * deposit-field:: * dpb:: * ldb:: * ldb-test:: * mask-field:: * most-positive-fixnum:: * decode-float:: * float:: * floatp:: * most-positive-short-float:: * short-float-epsilon:: * arithmetic-error:: * arithmetic-error-operands:: * division-by-zero:: * floating-point-invalid-operation:: * floating-point-inexact:: * floating-point-overflow:: * floating-point-underflow:: Characters * Character Concepts:: * Characters Dictionary:: Character Concepts * Introduction to Characters:: * Introduction to Scripts and Repertoires:: * Character Attributes:: * Character Categories:: * Identity of Characters:: * Ordering of Characters:: * Character Names:: * Treatment of Newline during Input and Output:: * Character Encodings:: * Documentation of Implementation-Defined Scripts:: Introduction to Scripts and Repertoires * Character Scripts:: * Character Repertoires:: Character Categories * Graphic Characters:: * Alphabetic Characters:: * Characters With Case:: * Uppercase Characters:: * Lowercase Characters:: * Corresponding Characters in the Other Case:: * Case of Implementation-Defined Characters:: * Numeric Characters:: * Alphanumeric Characters:: * Digits in a Radix:: Characters Dictionary * character (System Class):: * base-char:: * standard-char:: * extended-char:: * char=:: * character:: * characterp:: * alpha-char-p:: * alphanumericp:: * digit-char:: * digit-char-p:: * graphic-char-p:: * standard-char-p:: * char-upcase:: * upper-case-p:: * char-code:: * char-int:: * code-char:: * char-code-limit:: * char-name:: * name-char:: Conses * Cons Concepts:: * Conses Dictionary:: Cons Concepts * Conses as Trees:: * Conses as Lists:: Conses as Trees * General Restrictions on Parameters that must be Trees:: Conses as Lists * Lists as Association Lists:: * Lists as Sets:: * General Restrictions on Parameters that must be Lists:: Conses Dictionary * list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: * cons:: * consp:: * atom:: * rplaca:: * car:: * copy-tree:: * sublis:: * subst:: * tree-equal:: * copy-list:: * list (Function):: * list-length:: * listp:: * make-list:: * push:: * pop:: * first:: * nth:: * endp:: * null:: * nconc:: * append:: * revappend:: * butlast:: * last:: * ldiff:: * nthcdr:: * rest:: * member (Function):: * mapc:: * acons:: * assoc:: * copy-alist:: * pairlis:: * rassoc:: * get-properties:: * getf:: * remf:: * intersection:: * adjoin:: * pushnew:: * set-difference:: * set-exclusive-or:: * subsetp:: * union:: Arrays * Array Concepts:: * Arrays Dictionary:: Array Concepts * Array Elements:: * Specialized Arrays:: Array Elements * Array Indices:: * Array Dimensions:: * Implementation Limits on Individual Array Dimensions:: * Array Rank:: * Vectors:: * Fill Pointers:: * Multidimensional Arrays:: * Storage Layout for Multidimensional Arrays:: * Implementation Limits on Array Rank:: Specialized Arrays * Array Upgrading:: * Required Kinds of Specialized Arrays:: Arrays Dictionary * array:: * simple-array:: * vector (System Class):: * simple-vector:: * bit-vector:: * simple-bit-vector:: * make-array:: * adjust-array:: * adjustable-array-p:: * aref:: * array-dimension:: * array-dimensions:: * array-element-type:: * array-has-fill-pointer-p:: * array-displacement:: * array-in-bounds-p:: * array-rank:: * array-row-major-index:: * array-total-size:: * arrayp:: * fill-pointer:: * row-major-aref:: * upgraded-array-element-type:: * array-dimension-limit:: * array-rank-limit:: * array-total-size-limit:: * simple-vector-p:: * svref:: * vector:: * vector-pop:: * vector-push:: * vectorp:: * bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p:: Strings * String Concepts:: * Strings Dictionary:: String Concepts * Implications of Strings Being Arrays:: * Subtypes of STRING:: Strings Dictionary * string (System Class):: * base-string:: * simple-string:: * simple-base-string:: * simple-string-p:: * char:: * string:: * string-upcase:: * string-trim:: * string=:: * stringp:: * make-string:: Sequences * Sequence Concepts:: * Rules about Test Functions:: * Sequences Dictionary:: Sequence Concepts * General Restrictions on Parameters that must be Sequences:: Rules about Test Functions * Satisfying a Two-Argument Test:: * Satisfying a One-Argument Test:: Satisfying a Two-Argument Test * Examples of Satisfying a Two-Argument Test:: Satisfying a One-Argument Test * Examples of Satisfying a One-Argument Test:: Sequences Dictionary * sequence:: * copy-seq:: * elt:: * fill:: * make-sequence:: * subseq:: * map:: * map-into:: * reduce:: * count:: * length:: * reverse:: * sort:: * find:: * position:: * search:: * mismatch:: * replace:: * substitute:: * concatenate:: * merge:: * remove:: * remove-duplicates:: Hash Tables * Hash Table Concepts:: * Hash Tables Dictionary:: Hash Table Concepts * Hash-Table Operations:: * Modifying Hash Table Keys:: Modifying Hash Table Keys * Visible Modification of Objects with respect to EQ and EQL:: * Visible Modification of Objects with respect to EQUAL:: * Visible Modification of Conses with respect to EQUAL:: * Visible Modification of Bit Vectors and Strings with respect to EQUAL:: * Visible Modification of Objects with respect to EQUALP:: * Visible Modification of Structures with respect to EQUALP:: * Visible Modification of Arrays with respect to EQUALP:: * Visible Modification of Hash Tables with respect to EQUALP:: * Visible Modifications by Language Extensions:: Hash Tables Dictionary * hash-table:: * make-hash-table:: * hash-table-p:: * hash-table-count:: * hash-table-rehash-size:: * hash-table-rehash-threshold:: * hash-table-size:: * hash-table-test:: * gethash:: * remhash:: * maphash:: * with-hash-table-iterator:: * clrhash:: * sxhash:: Filenames * Overview of Filenames:: * Pathnames:: * Logical Pathnames:: * Filenames Dictionary:: Overview of Filenames * Namestrings as Filenames:: * Pathnames as Filenames:: * Parsing Namestrings Into Pathnames:: Pathnames * Pathname Components:: * Interpreting Pathname Component Values:: * Merging Pathnames:: Pathname Components * The Pathname Host Component:: * The Pathname Device Component:: * The Pathname Directory Component:: * The Pathname Name Component:: * The Pathname Type Component:: * The Pathname Version Component:: Interpreting Pathname Component Values * Strings in Component Values:: * Special Characters in Pathname Components:: * Case in Pathname Components:: * Local Case in Pathname Components:: * Common Case in Pathname Components:: * Special Pathname Component Values:: * NIL as a Component Value:: * ->WILD as a Component Value:: * ->UNSPECIFIC as a Component Value:: * Relation between component values NIL and ->UNSPECIFIC:: * Restrictions on Wildcard Pathnames:: * Restrictions on Examining Pathname Components:: * Restrictions on Examining a Pathname Host Component:: * Restrictions on Examining a Pathname Device Component:: * Restrictions on Examining a Pathname Directory Component:: * Directory Components in Non-Hierarchical File Systems:: * Restrictions on Examining a Pathname Name Component:: * Restrictions on Examining a Pathname Type Component:: * Restrictions on Examining a Pathname Version Component:: * Notes about the Pathname Version Component:: * Restrictions on Constructing Pathnames:: Merging Pathnames * Examples of Merging Pathnames:: Logical Pathnames * Syntax of Logical Pathname Namestrings:: * Logical Pathname Components:: Syntax of Logical Pathname Namestrings * Additional Information about Parsing Logical Pathname Namestrings:: * The Host part of a Logical Pathname Namestring:: * The Device part of a Logical Pathname Namestring:: * The Directory part of a Logical Pathname Namestring:: * The Type part of a Logical Pathname Namestring:: * The Version part of a Logical Pathname Namestring:: * Wildcard Words in a Logical Pathname Namestring:: * Lowercase Letters in a Logical Pathname Namestring:: * Other Syntax in a Logical Pathname Namestring:: Logical Pathname Components * Unspecific Components of a Logical Pathname:: * Null Strings as Components of a Logical Pathname:: Filenames Dictionary * pathname (System Class):: * logical-pathname (System Class):: * pathname:: * make-pathname:: * pathnamep:: * pathname-host:: * load-logical-pathname-translations:: * logical-pathname-translations:: * logical-pathname:: * *default-pathname-defaults*:: * namestring:: * parse-namestring:: * wild-pathname-p:: * pathname-match-p:: * translate-logical-pathname:: * translate-pathname:: * merge-pathnames:: Files * File System Concepts:: * Files Dictionary:: File System Concepts * Coercion of Streams to Pathnames:: * File Operations on Open and Closed Streams:: * Truenames:: Truenames * Examples of Truenames:: Files Dictionary * directory:: * probe-file:: * ensure-directories-exist:: * truename:: * file-author:: * file-write-date:: * rename-file:: * delete-file:: * file-error:: * file-error-pathname:: Streams * Stream Concepts:: * Streams Dictionary:: Stream Concepts * Introduction to Streams:: * Stream Variables:: * Stream Arguments to Standardized Functions:: * Restrictions on Composite Streams:: Introduction to Streams * Abstract Classifications of Streams (Introduction to Streams):: * Input:: * Open and Closed Streams:: * Interactive Streams:: * Abstract Classifications of Streams:: * File Streams:: * Other Subclasses of Stream:: Streams Dictionary * stream:: * broadcast-stream:: * concatenated-stream:: * echo-stream:: * file-stream:: * string-stream:: * synonym-stream:: * two-way-stream:: * input-stream-p:: * interactive-stream-p:: * open-stream-p:: * stream-element-type:: * streamp:: * read-byte:: * write-byte:: * peek-char:: * read-char:: * read-char-no-hang:: * terpri:: * unread-char:: * write-char:: * read-line:: * write-string:: * read-sequence:: * write-sequence:: * file-length:: * file-position:: * file-string-length:: * open:: * stream-external-format:: * with-open-file:: * close:: * with-open-stream:: * listen:: * clear-input:: * finish-output:: * y-or-n-p:: * make-synonym-stream:: * synonym-stream-symbol:: * broadcast-stream-streams:: * make-broadcast-stream:: * make-two-way-stream:: * two-way-stream-input-stream:: * echo-stream-input-stream:: * make-echo-stream:: * concatenated-stream-streams:: * make-concatenated-stream:: * get-output-stream-string:: * make-string-input-stream:: * make-string-output-stream:: * with-input-from-string:: * with-output-to-string:: * *debug-io*:: * *terminal-io*:: * stream-error:: * stream-error-stream:: * end-of-file:: Printer * The Lisp Printer:: * The Lisp Pretty Printer:: * Formatted Output:: * Printer Dictionary:: The Lisp Printer * Overview of The Lisp Printer:: * Printer Dispatching:: * Default Print-Object Methods:: * Examples of Printer Behavior:: Overview of The Lisp Printer * Multiple Possible Textual Representations:: * Printer Escaping:: Default Print-Object Methods * Printing Numbers:: * Printing Integers:: * Printing Ratios:: * Printing Floats:: * Printing Complexes:: * Note about Printing Numbers:: * Printing Characters:: * Printing Symbols:: * Package Prefixes for Symbols:: * Effect of Readtable Case on the Lisp Printer:: * Examples of Effect of Readtable Case on the Lisp Printer:: * Printing Strings:: * Printing Lists and Conses:: * Printing Bit Vectors:: * Printing Other Vectors:: * Printing Other Arrays:: * Examples of Printing Arrays:: * Printing Random States:: * Printing Pathnames:: * Printing Structures:: * Printing Other Objects:: The Lisp Pretty Printer * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: * Notes about the Pretty Printer`s Background:: Pretty Printer Concepts * Dynamic Control of the Arrangement of Output:: * Format Directive Interface:: * Compiling Format Strings:: * Pretty Print Dispatch Tables:: * Pretty Printer Margins:: Formatted Output * FORMAT Basic Output:: * FORMAT Radix Control:: * FORMAT Floating-Point Printers:: * FORMAT Printer Operations:: * FORMAT Pretty Printer Operations:: * FORMAT Layout Control:: * FORMAT Control-Flow Operations:: * FORMAT Miscellaneous Operations:: * FORMAT Miscellaneous Pseudo-Operations:: * Additional Information about FORMAT Operations:: * Examples of FORMAT:: * Notes about FORMAT:: FORMAT Basic Output * Tilde C-> Character:: * Tilde Percent-> Newline:: * Tilde Ampersand-> Fresh-Line:: * Tilde Vertical-Bar-> Page:: * Tilde Tilde-> Tilde:: FORMAT Radix Control * Tilde R-> Radix:: * Tilde D-> Decimal:: * Tilde B-> Binary:: * Tilde O-> Octal:: * Tilde X-> Hexadecimal:: FORMAT Floating-Point Printers * Tilde F-> Fixed-Format Floating-Point:: * Tilde E-> Exponential Floating-Point:: * Tilde G-> General Floating-Point:: * Tilde Dollarsign-> Monetary Floating-Point:: FORMAT Printer Operations * Tilde A-> Aesthetic:: * Tilde S-> Standard:: * Tilde W-> Write:: FORMAT Pretty Printer Operations * Tilde Underscore-> Conditional Newline:: * Tilde Less-Than-Sign-> Logical Block:: * Tilde I-> Indent:: * Tilde Slash-> Call Function:: FORMAT Layout Control * Tilde T-> Tabulate:: * Tilde Less-Than-Sign-> Justification:: * Tilde Greater-Than-Sign-> End of Justification:: FORMAT Control-Flow Operations * Tilde Asterisk-> Go-To:: * Tilde Left-Bracket-> Conditional Expression:: * Tilde Right-Bracket-> End of Conditional Expression:: * Tilde Left-Brace-> Iteration:: * Tilde Right-Brace-> End of Iteration:: * Tilde Question-Mark-> Recursive Processing:: FORMAT Miscellaneous Operations * Tilde Left-Paren-> Case Conversion:: * Tilde Right-Paren-> End of Case Conversion:: * Tilde P-> Plural:: FORMAT Miscellaneous Pseudo-Operations * Tilde Semicolon-> Clause Separator:: * Tilde Circumflex-> Escape Upward:: * Tilde Newline-> Ignored Newline:: Additional Information about FORMAT Operations * Nesting of FORMAT Operations:: * Missing and Additional FORMAT Arguments:: * Additional FORMAT Parameters:: * Undefined FORMAT Modifier Combinations:: Printer Dictionary * copy-pprint-dispatch:: * formatter:: * pprint-dispatch:: * pprint-exit-if-list-exhausted:: * pprint-fill:: * pprint-indent:: * pprint-logical-block:: * pprint-newline:: * pprint-pop:: * pprint-tab:: * print-object:: * print-unreadable-object:: * set-pprint-dispatch:: * write:: * write-to-string:: * *print-array*:: * *print-base*:: * *print-case*:: * *print-circle*:: * *print-escape*:: * *print-gensym*:: * *print-level*:: * *print-lines*:: * *print-miser-width*:: * *print-pprint-dispatch*:: * *print-pretty*:: * *print-readably*:: * *print-right-margin*:: * print-not-readable:: * print-not-readable-object:: * format:: Reader * Reader Concepts:: * Reader Dictionary:: Reader Concepts * Dynamic Control of the Lisp Reader:: * Effect of Readtable Case on the Lisp Reader:: * Argument Conventions of Some Reader Functions:: Effect of Readtable Case on the Lisp Reader * Examples of Effect of Readtable Case on the Lisp Reader:: Argument Conventions of Some Reader Functions * The EOF-ERROR-P argument:: * The RECURSIVE-P argument:: Reader Dictionary * readtable:: * copy-readtable:: * make-dispatch-macro-character:: * read:: * read-delimited-list:: * read-from-string:: * readtable-case:: * readtablep:: * set-dispatch-macro-character:: * set-macro-character:: * set-syntax-from-char:: * with-standard-io-syntax:: * *read-base*:: * *read-default-float-format*:: * *read-eval*:: * *read-suppress*:: * *readtable*:: * reader-error:: System Construction * System Construction Concepts:: * System Construction Dictionary:: System Construction Concepts * Loading:: * Features:: Features * Feature Expressions:: * Examples of Feature Expressions:: System Construction Dictionary * compile-file:: * compile-file-pathname:: * load:: * with-compilation-unit:: * *features*:: * *compile-file-pathname*:: * *load-pathname*:: * *compile-print*:: * *load-print*:: * *modules*:: * provide:: Environment * The External Environment:: * Environment Dictionary:: The External Environment * Top level loop:: * Debugging Utilities:: * Environment Inquiry:: * Time:: Time * Decoded Time:: * Universal Time:: * Internal Time:: * Seconds:: Environment Dictionary * decode-universal-time:: * encode-universal-time:: * get-universal-time:: * sleep:: * apropos:: * describe:: * describe-object:: * trace:: * step:: * time:: * internal-time-units-per-second:: * get-internal-real-time:: * get-internal-run-time:: * disassemble:: * documentation:: * room:: * ed:: * inspect:: * dribble:: * -:: * +:: * *:: * /:: * lisp-implementation-type:: * short-site-name:: * machine-instance:: * machine-type:: * machine-version:: * software-type:: * user-homedir-pathname:: Glossary * Glossary:: Appendix * Removed Language Features:: Removed Language Features * Requirements for removed and deprecated features:: * Removed Types:: * Removed Operators:: * Removed Argument Conventions:: * Removed Variables:: * Removed Reader Syntax:: * Packages No Longer Required::  File: gcl.info, Node: Introduction (Introduction), Next: Syntax, Prev: Top, Up: Top 1 Introduction ************** * Menu: * Scope:: * Organization of the Document:: * Referenced Publications:: * Definitions:: * Conformance:: * Language Extensions:: * Language Subsets:: * Deprecated Language Features:: * Symbols in the COMMON-LISP Package::  File: gcl.info, Node: Scope, Next: Organization of the Document, Prev: Introduction (Introduction), Up: Introduction (Introduction) 1.1 Scope, Purpose, and History =============================== * Menu: * Scope and Purpose:: * History::  File: gcl.info, Node: Scope and Purpose, Next: History, Prev: Scope, Up: Scope 1.1.1 Scope and Purpose ----------------------- The specification set forth in this document is designed to promote the portability of Common Lisp programs among a variety of data processing systems. It is a language specification aimed at an audience of implementors and knowledgeable programmers. It is neither a tutorial nor an implementation guide.  File: gcl.info, Node: History, Prev: Scope and Purpose, Up: Scope 1.1.2 History ------------- Lisp is a family of languages with a long history. Early key ideas in Lisp were developed by John McCarthy during the 1956 Dartmouth Summer Research Project on Artificial Intelligence. McCarthy's motivation was to develop an algebraic list processing language for artificial intelligence work. Implementation efforts for early dialects of Lisp were undertaken on the IBM~704, the IBM~7090, the Digital Equipment Corporation (DEC) PDP-1, the DEC~PDP-6, and the PDP-10. The primary dialect of Lisp between 1960 and 1965 was Lisp~1.5. By the early 1970's there were two predominant dialects of Lisp, both arising from these early efforts: MacLisp and Interlisp. For further information about very early Lisp dialects, see The Anatomy of Lisp or Lisp 1.5 Programmer's Manual. MacLisp improved on the Lisp~1.5 notion of special variables and error handling. MacLisp also introduced the concept of functions that could take a variable number of arguments, macros, arrays, non-local dynamic exits, fast arithmetic, the first good Lisp compiler, and an emphasis on execution speed. By the end of the 1970's, MacLisp was in use at over 50 sites. For further information about Maclisp, see Maclisp Reference Manual, Revision~0 or The Revised Maclisp Manual. Interlisp introduced many ideas into Lisp programming environments and methodology. One of the Interlisp ideas that influenced Common Lisp was an iteration construct implemented by Warren Teitelman that inspired the loop macro used both on the Lisp Machines and in MacLisp, and now in Common Lisp. For further information about Interlisp, see Interlisp Reference Manual. Although the first implementations of Lisp were on the IBM~704 and the IBM~7090, later work focussed on the DEC PDP-6 and, later, PDP-10 computers, the latter being the mainstay of Lisp and artificial intelligence work at such places as Massachusetts Institute of Technology (MIT), Stanford University, and Carnegie Mellon University (CMU) from the mid-1960's through much of the 1970's. The PDP-10 computer and its predecessor the PDP-6 computer were, by design, especially well-suited to Lisp because they had 36-bit words and 18-bit addresses. This architecture allowed a cons cell to be stored in one word; single instructions could extract the car and cdr parts. The PDP-6 and PDP-10 had fast, powerful stack instructions that enabled fast function calling. But the limitations of the PDP-10 were evident by 1973: it supported a small number of researchers using Lisp, and the small, 18-bit address space (2^18 = 262,144 words) limited the size of a single program. One response to the address space problem was the Lisp Machine, a special-purpose computer designed to run Lisp programs. The other response was to use general-purpose computers with address spaces larger than 18~bits, such as the DEC VAX and the S-1~Mark~IIA. For further information about S-1 Common Lisp, see S-1 Common Lisp Implementation. The Lisp machine concept was developed in the late 1960's. In the early 1970's, Peter Deutsch, working with Daniel Bobrow, implemented a Lisp on the Alto, a single-user minicomputer, using microcode to interpret a byte-code implementation language. Shortly thereafter, Richard Greenblatt began work on a different hardware and instruction set design at MIT. Although the Alto was not a total success as a Lisp machine, a dialect of Interlisp known as Interlisp-D became available on the D-series machines manufactured by Xerox--the Dorado, Dandelion, Dandetiger, and Dove (or Daybreak). An upward-compatible extension of MacLisp called Lisp Machine Lisp became available on the early MIT Lisp Machines. Commercial Lisp machines from Xerox, Lisp Machines (LMI), and Symbolics were on the market by 1981. For further information about Lisp Machine Lisp, see Lisp Machine Manual. During the late 1970's, Lisp Machine Lisp began to expand towards a much fuller language. Sophisticated lambda lists, setf, multiple values, and structures like those in Common Lisp are the results of early experimentation with programming styles by the Lisp Machine group. Jonl White and others migrated these features to MacLisp. Around 1980, Scott Fahlman and others at CMU began work on a Lisp to run on the Scientific Personal Integrated Computing Environment (SPICE) workstation. One of the goals of the project was to design a simpler dialect than Lisp Machine Lisp. The Macsyma group at MIT began a project during the late 1970's called the New Implementation of Lisp (NIL) for the VAX, which was headed by White. One of the stated goals of the NIL project was to fix many of the historic, but annoying, problems with Lisp while retaining significant compatibility with MacLisp. At about the same time, a research group at Stanford University and Lawrence Livermore National Laboratory headed by Richard P. Gabriel began the design of a Lisp to run on the S-1~Mark~IIA supercomputer. S-1~Lisp, never completely functional, was the test bed for adapting advanced compiler techniques to Lisp implementation. Eventually the S-1 and NIL groups collaborated. For further information about the NIL project, see NIL--A Perspective. The first effort towards Lisp standardization was made in 1969, when Anthony Hearn and Martin Griss at the University of Utah defined Standard Lisp--a subset of Lisp~1.5 and other dialects--to transport REDUCE, a symbolic algebra system. During the 1970's, the Utah group implemented first a retargetable optimizing compiler for Standard Lisp, and then an extended implementation known as Portable Standard Lisp (PSL). By the mid 1980's, PSL ran on about a dozen kinds of computers. For further information about Standard Lisp, see Standard LISP Report. PSL and Franz Lisp--a MacLisp-like dialect for Unix machines--were the first examples of widely available Lisp dialects on multiple hardware platforms. One of the most important developments in Lisp occurred during the second half of the 1970's: Scheme. Scheme, designed by Gerald J. Sussman and Guy L. Steele Jr., is a simple dialect of Lisp whose design brought to Lisp some of the ideas from programming language semantics developed in the 1960's. Sussman was one of the prime innovators behind many other advances in Lisp technology from the late 1960's through the 1970's. The major contributions of Scheme were lexical scoping, lexical closures, first-class continuations, and simplified syntax (no separation of value cells and function cells). Some of these contributions made a large impact on the design of Common Lisp. For further information about Scheme, see IEEE Standard for the Scheme Programming Language or Revised^3 Report on the Algorithmic Language Scheme. In the late 1970's object-oriented programming concepts started to make a strong impact on Lisp. At MIT, certain ideas from Smalltalk made their way into several widely used programming systems. Flavors, an object-oriented programming system with multiple inheritance, was developed at MIT for the Lisp machine community by Howard Cannon and others. At Xerox, the experience with Smalltalk and Knowledge Representation Language (KRL) led to the development of Lisp Object Oriented Programming System (LOOPS) and later Common LOOPS. For further information on Smalltalk, see Smalltalk-80: The Language and its Implementation. For further information on Flavors, see Flavors: A Non-Hierarchical Approach to Object-Oriented Programming. These systems influenced the design of the Common Lisp Object System (CLOS). CLOS was developed specifically for this standardization effort, and was separately written up in Common Lisp Object System Specification. However, minor details of its design have changed slightly since that publication, and that paper should not be taken as an authoritative reference to the semantics of the object system as described in this document. In 1980 Symbolics and LMI were developing Lisp Machine Lisp; stock-hardware implementation groups were developing NIL, Franz Lisp, and PSL; Xerox was developing Interlisp; and the SPICE project at CMU was developing a MacLisp-like dialect of Lisp called SpiceLisp. In April 1981, after a DARPA-sponsored meeting concerning the splintered Lisp community, Symbolics, the SPICE project, the NIL project, and the S-1~Lisp project joined together to define Common Lisp. Initially spearheaded by White and Gabriel, the driving force behind this grassroots effort was provided by Fahlman, Daniel Weinreb, David Moon, Steele, and Gabriel. Common Lisp was designed as a description of a family of languages. The primary influences on Common Lisp were Lisp Machine Lisp, MacLisp, NIL, S-1~Lisp, Spice Lisp, and Scheme. Common Lisp: The Language is a description of that design. Its semantics were intentionally underspecified in places where it was felt that a tight specification would overly constrain Common Lisp research and use. In 1986 X3J13 was formed as a technical working group to produce a draft for an ANSI Common Lisp standard. Because of the acceptance of Common Lisp, the goals of this group differed from those of the original designers. These new goals included stricter standardization for portability, an object-oriented programming system, a condition system, iteration facilities, and a way to handle large character sets. To accommodate those goals, a new language specification, this document, was developed.  File: gcl.info, Node: Organization of the Document, Next: Referenced Publications, Prev: Scope, Up: Introduction (Introduction) 1.2 Organization of the Document ================================ This is a reference document, not a tutorial document. Where possible and convenient, the order of presentation has been chosen so that the more primitive topics precede those that build upon them; however, linear readability has not been a priority. This document is divided into chapters by topic. Any given chapter might contain conceptual material, dictionary entries, or both. Defined names within the dictionary portion of a chapter are grouped in a way that brings related topics into physical proximity. Many such groupings were possible, and no deep significance should be inferred from the particular grouping that was chosen. To see defined names grouped alphabetically, consult the index. For a complete list of defined names, see *note Symbols in the COMMON-LISP Package::. In order to compensate for the sometimes-unordered portions of this document, a glossary has been provided; see *note Glossary::. The glossary provides connectivity by providing easy access to definitions of terms, and in some cases by providing examples or cross references to additional conceptual material. For information about notational conventions used in this document, see *note Definitions::. For information about conformance, see *note Conformance::. For information about extensions and subsets, see *note Language Extensions:: and *note Language Subsets::. For information about how programs in the language are parsed by the Lisp reader, see *note Syntax::. For information about how programs in the language are compiled and executed, see *note Evaluation and Compilation::. For information about data types, see *note Types and Classes::. Not all types and classes are defined in this chapter; many are defined in chapter corresponding to their topic-for example, the numeric types are defined in *note Numbers (Numbers)::. For a complete list of standardized types, see Figure~4-2. For information about general purpose control and data flow, see *note Data and Control Flow:: or *note Iteration::.  File: gcl.info, Node: Referenced Publications, Next: Definitions, Prev: Organization of the Document, Up: Introduction (Introduction) 1.3 Referenced Publications =========================== * The Anatomy of Lisp, John Allen, McGraw-Hill, Inc., 1978. * The Art of Computer Programming, Volume 3, Donald E. Knuth, Addison-Wesley Company (Reading, MA), 1973. * The Art of the Metaobject Protocol, Kiczales et al., MIT Press (Cambridge, MA), 1991. * Common Lisp Object System Specification, D. Bobrow, L. DiMichiel, R.P. Gabriel, S. Keene, G. Kiczales, D. Moon, SIGPLAN Notices V23, September, 1988. * Common Lisp: The Language, Guy L. Steele Jr., Digital Press (Burlington, MA), 1984. * Common Lisp: The Language, Second Edition, Guy L. Steele Jr., Digital Press (Bedford, MA), 1990. * Exceptional Situations in Lisp, Kent M. Pitman, Proceedings of the First European Conference on the Practical Application of LISP\/ (EUROPAL '90), Churchill College, Cambridge, England, March 27-29, 1990. * Flavors: A Non-Hierarchical Approach to Object-Oriented Programming, Howard I. Cannon, 1982. * IEEE Standard for Binary Floating-Point Arithmetic, ANSI/IEEE Std 754-1985, Institute of Electrical and Electronics Engineers, Inc. (New York), 1985. * IEEE Standard for the Scheme Programming Language, IEEE Std 1178-1990, Institute of Electrical and Electronic Engineers, Inc. (New York), 1991. * Interlisp Reference Manual, Third Revision, Teitelman, Warren, et al, Xerox Palo Alto Research Center (Palo Alto, CA), 1978. * ISO 6937/2, Information processing--Coded character sets for text communication--Part 2: Latin alphabetic and non-alphabetic graphic characters, ISO, 1983. * Lisp 1.5 Programmer's Manual, John McCarthy, MIT Press (Cambridge, MA), August, 1962. * Lisp Machine Manual, D.L. Weinreb and D.A. Moon, Artificial Intelligence Laboratory, MIT (Cambridge, MA), July, 1981. * Maclisp Reference Manual, Revision~0, David A. Moon, Project MAC (Laboratory for Computer Science), MIT (Cambridge, MA), March, 1974. * NIL--A Perspective, JonL White, Macsyma User's Conference, 1979. * Performance and Evaluation of Lisp Programs, Richard P. Gabriel, MIT Press (Cambridge, MA), 1985. * Principal Values and Branch Cuts in Complex APL, Paul Penfield Jr., APL 81 Conference Proceedings, ACM SIGAPL (San Francisco, September 1981), 248-256. Proceedings published as APL Quote Quad 12, 1 (September 1981). * The Revised Maclisp Manual, Kent M. Pitman, Technical Report 295, Laboratory for Computer Science, MIT (Cambridge, MA), May 1983. * Revised^3 Report on the Algorithmic Language Scheme, Jonathan Rees and William Clinger (editors), SIGPLAN Notices V21, #12, December, 1986. * S-1 Common Lisp Implementation, R.A. Brooks, R.P. Gabriel, and G.L. Steele, Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming, 108-113, 1982. * Smalltalk-80: The Language and its Implementation, A. Goldberg and D. Robson, Addison-Wesley, 1983. * Standard LISP Report, J.B. Marti, A.C. Hearn, M.L. Griss, and C. Griss, SIGPLAN Notices V14, #10, October, 1979. * Webster's Third New International Dictionary the English Language, Unabridged, Merriam Webster (Springfield, MA), 1986. * XP: A Common Lisp Pretty Printing System, R.C. Waters, Memo 1102a, Artificial Intelligence Laboratory, MIT (Cambridge, MA), September 1989.  File: gcl.info, Node: Definitions, Next: Conformance, Prev: Referenced Publications, Up: Introduction (Introduction) 1.4 Definitions =============== This section contains notational conventions and definitions of terms used in this manual. * Menu: * Notational Conventions:: * Error Terminology:: * Sections Not Formally Part Of This Standard:: * Interpreting Dictionary Entries::  File: gcl.info, Node: Notational Conventions, Next: Error Terminology, Prev: Definitions, Up: Definitions 1.4.1 Notational Conventions ---------------------------- The following notational conventions are used throughout this document. * Menu: * Font Key:: * Modified BNF Syntax:: * Splicing in Modified BNF Syntax:: * Indirection in Modified BNF Syntax:: * Additional Uses for Indirect Definitions in Modified BNF Syntax:: * Special Symbols:: * Objects with Multiple Notations:: * Case in Symbols:: * Numbers (Objects with Multiple Notations):: * Use of the Dot Character:: * NIL:: * Designators:: * Nonsense Words::  File: gcl.info, Node: Font Key, Next: Modified BNF Syntax, Prev: Notational Conventions, Up: Notational Conventions 1.4.1.1 Font Key ................ Fonts are used in this document to convey information. name Denotes a formal term whose meaning is defined in the Glossary. When this font is used, the Glossary definition takes precedence over normal English usage. Sometimes a glossary term appears subscripted, as in "whitespace_2." Such a notation selects one particular Glossary definition out of several, in this case the second. The subscript notation for Glossary terms is generally used where the context might be insufficient to disambiguate among the available definitions. name Denotes the introduction of a formal term locally to the current text. There is still a corresponding glossary entry, and is formally equivalent to a use of "name," but the hope is that making such uses conspicuous will save the reader a trip to the glossary in some cases. name Denotes a symbol in the COMMON-LISP package. For information about case conventions, see *note Case in Symbols::. name Denotes a sample name or piece of code that a programmer might write in Common Lisp. This font is also used for certain standardized names that are not names of external symbols of the COMMON-LISP package, such as keywords_1, package names, and loop keywords. name Denotes the name of a parameter or value. In some situations the notation "<>" (i.e., the same font, but with surrounding "angle brackets") is used instead in order to provide better visual separation from surrounding characters. These "angle brackets" are metasyntactic, and never actually appear in program input or output.  File: gcl.info, Node: Modified BNF Syntax, Next: Splicing in Modified BNF Syntax, Prev: Font Key, Up: Notational Conventions 1.4.1.2 Modified BNF Syntax ........................... This specification uses an extended Backus Normal Form (BNF) to describe the syntax of Common Lisp macro forms and special forms. This section discusses the syntax of BNF expressions.  File: gcl.info, Node: Splicing in Modified BNF Syntax, Next: Indirection in Modified BNF Syntax, Prev: Modified BNF Syntax, Up: Notational Conventions 1.4.1.3 Splicing in Modified BNF Syntax ....................................... The primary extension used is the following: [[O]] An expression of this form appears whenever a list of elements is to be spliced into a larger structure and the elements can appear in any order. The symbol O represents a description of the syntax of some number of syntactic elements to be spliced; that description must be of the form O_1 | ... | O_l where each O_i can be of the form S or of the form S* or of the form S^1. The expression [[O]] means that a list of the form (O_{i_1}... O_{i_j}) 1<= j is spliced into the enclosing expression, such that if n != m and 1<= n,m<= j, then either O_{i_n}!= O_{i_m} or O_{i_n} = O_{i_m} = Q_k, where for some 1<= k <= n, O_k is of the form Q_k*. Furthermore, for each O_{i_n} that is of the form Q_k^1, that element is required to appear somewhere in the list to be spliced. For example, the expression (x [[A | B* | C]] y) means that at most one A, any number of B's, and at most one C can occur in any order. It is a description of any of these: (x y) (x B A C y) (x A B B B B B C y) (x C B A B B B y) but not any of these: (x B B A A C C y) (x C B C y) In the first case, both A and C appear too often, and in the second case C appears too often. The notation [[O_1 | O_2 | ...]]^+ adds the additional restriction that at least one item from among the possible choices must be used. For example: (x [[A | B* | C]]^+ y) means that at most one A, any number of B's, and at most one C can occur in any order, but that in any case at least one of these options must be selected. It is a description of any of these: (x B y) (x B A C y) (x A B B B B B C y) (x C B A B B B y) but not any of these: (x y) (x B B A A C C y) (x C B C y) In the first case, no item was used; in the second case, both A and C appear too often; and in the third case C appears too often. Also, the expression: (x [[A^1 | B^1 | C]] y) can generate exactly these and no others: (x A B C y) (x A C B y) (x A B y) (x B A C y) (x B C A y) (x B A y) (x C A B y) (x C B A y)  File: gcl.info, Node: Indirection in Modified BNF Syntax, Next: Additional Uses for Indirect Definitions in Modified BNF Syntax, Prev: Splicing in Modified BNF Syntax, Up: Notational Conventions 1.4.1.4 Indirection in Modified BNF Syntax .......................................... An indirection extension is introduced in order to make this new syntax more readable: !O If O is a non-terminal symbol, the right-hand side of its definition is substituted for the entire expression !O. For example, the following BNF is equivalent to the BNF in the previous example: (x [[!O]] y) O ::=A | B* | C  File: gcl.info, Node: Additional Uses for Indirect Definitions in Modified BNF Syntax, Next: Special Symbols, Prev: Indirection in Modified BNF Syntax, Up: Notational Conventions 1.4.1.5 Additional Uses for Indirect Definitions in Modified BNF Syntax ....................................................................... In some cases, an auxiliary definition in the BNF might appear to be unused within the BNF, but might still be useful elsewhere. For example, consider the following definitions: 'case' keyform {!normal-clause}* [!otherwise-clause] => {result}* 'ccase' keyplace {!normal-clause}* => {result}* 'ecase' keyform {!normal-clause}* => {result}* normal-clause ::=(keys {form}*) otherwise-clause ::=({otherwise | t} {form}*) clause ::=normal-clause | otherwise-clause Here the term "clause" might appear to be "dead" in that it is not used in the BNF. However, the purpose of the BNF is not just to guide parsing, but also to define useful terms for reference in the descriptive text which follows. As such, the term "clause" might appear in text that follows, as shorthand for "normal-clause or otherwise-clause."  File: gcl.info, Node: Special Symbols, Next: Objects with Multiple Notations, Prev: Additional Uses for Indirect Definitions in Modified BNF Syntax, Up: Notational Conventions 1.4.1.6 Special Symbols ....................... The special symbols described here are used as a notational convenience within this document, and are part of neither the Common Lisp language nor its environment. => This indicates evaluation. For example: (+ 4 5) => 9 This means that the result of evaluating the form (+ 4 5) is 9. If a form returns multiple values, those values might be shown separated by spaces, line breaks, or commas. For example: (truncate 7 5) => 1 2 (truncate 7 5) => 1 2 (truncate 7 5) => 1, 2 Each of the above three examples is equivalent, and specifies that (truncate 7 5) returns two values, which are 1 and 2. Some conforming implementations actually type an arrow (or some other indicator) before showing return values, while others do not. OR=> The notation "OR=>" is used to denote one of several possible alternate results. The example (char-name #\a) => NIL OR=> "LOWERCASE-a" OR=> "Small-A" OR=> "LA01" indicates that nil, "LOWERCASE-a", "Small-A", "LA01" are among the possible results of (char-name #\a)--each with equal preference. Unless explicitly specified otherwise, it should not be assumed that the set of possible results shown is exhaustive. Formally, the above example is equivalent to (char-name #\a) => implementation-dependent but it is intended to provide additional information to illustrate some of the ways in which it is permitted for implementations to diverge. NOT=> The notation "NOT=>" is used to denote a result which is not possible. This might be used, for example, in order to emphasize a situation where some anticipated misconception might lead the reader to falsely believe that the result might be possible. For example, (function-lambda-expression (funcall #'(lambda (x) #'(lambda () x)) nil)) => NIL, true, NIL OR=> (LAMBDA () X), true, NIL NOT=> NIL, false, NIL NOT=> (LAMBDA () X), false, NIL == This indicates code equivalence. For example: (gcd x (gcd y z)) == (gcd (gcd x y) z) This means that the results and observable side-effects of evaluating the form (gcd x (gcd y z)) are always the same as the results and observable side-effects of (gcd (gcd x y) z) for any x, y, and z. |> Common Lisp specifies input and output with respect to a non-interactive stream model. The specific details of how interactive input and output are mapped onto that non-interactive model are implementation-defined. For example, conforming implementations are permitted to differ in issues of how interactive input is terminated. For example, the function read terminates when the final delimiter is typed on a non-interactive stream. In some implementations, an interactive call to read returns as soon as the final delimiter is typed, even if that delimiter is not a newline. In other implementations, a final newline is always required. In still other implementations, there might be a command which "activates" a buffer full of input without the command itself being visible on the program's input stream. In the examples in this document, the notation " |> " precedes lines where interactive input and output occurs. Within such a scenario, "|>>this notation<<|" notates user input. For example, the notation (+ 1 (print (+ (sqrt (read)) (sqrt (read))))) |> |>>9 16 <<| |> 7 => 8 shows an interaction in which "(+ 1 (print (+ (sqrt (read)) (sqrt (read)))))" is a form to be evaluated, "9 16 " is interactive input, "7" is interactive output, and "8" is the value yielded from the evaluation. The use of this notation is intended to disguise small differences in interactive input and output behavior between implementations. Sometimes, the non-interactive stream model calls for a newline. How that newline character is interactively entered is an implementation-defined detail of the user interface, but in that case, either the notation "" or "[<-~]" might be used. (progn (format t "~&Who? ") (read-line)) |> Who? |>>Fred, Mary, and Sally [<-~]<<| => "Fred, Mary, and Sally", false  File: gcl.info, Node: Objects with Multiple Notations, Next: Case in Symbols, Prev: Special Symbols, Up: Notational Conventions 1.4.1.7 Objects with Multiple Notations ....................................... Some objects in Common Lisp can be notated in more than one way. In such situations, the choice of which notation to use is technically arbitrary, but conventions may exist which convey a "point of view" or "sense of intent."  File: gcl.info, Node: Case in Symbols, Next: Numbers (Objects with Multiple Notations), Prev: Objects with Multiple Notations, Up: Notational Conventions 1.4.1.8 Case in Symbols ....................... While case is significant in the process of interning a symbol, the Lisp reader, by default, attempts to canonicalize the case of a symbol prior to interning; see *note Effect of Readtable Case on the Lisp Reader::. As such, case in symbols is not, by default, significant. Throughout this document, except as explicitly noted otherwise, the case in which a symbol appears is not significant; that is, HELLO, Hello, hElLo, and hello are all equivalent ways to denote a symbol whose name is "HELLO". The characters backslash and vertical-bar are used to explicitly quote the case and other parsing-related aspects of characters. As such, the notations |hello| and \h\e\l\l\o are equivalent ways to refer to a symbol whose name is "hello", and which is distinct from any symbol whose name is "HELLO". The symbols that correspond to Common Lisp defined names have uppercase names even though their names generally appear in lowercase in this document.  File: gcl.info, Node: Numbers (Objects with Multiple Notations), Next: Use of the Dot Character, Prev: Case in Symbols, Up: Notational Conventions 1.4.1.9 Numbers ............... Although Common Lisp provides a variety of ways for programs to manipulate the input and output radix for rational numbers, all numbers in this document are in decimal notation unless explicitly noted otherwise.  File: gcl.info, Node: Use of the Dot Character, Next: NIL, Prev: Numbers (Objects with Multiple Notations), Up: Notational Conventions 1.4.1.10 Use of the Dot Character ................................. The dot appearing by itself in an expression such as (item1 item2 . tail) means that tail represents a list of objects at the end of a list. For example, (A B C . (D E F)) is notationally equivalent to: (A B C D E F) Although dot is a valid constituent character in a symbol, no standardized symbols contain the character dot, so a period that follows a reference to a symbol at the end of a sentence in this document should always be interpreted as a period and never as part of the symbol's name. For example, within this document, a sentence such as "This sample sentence refers to the symbol car." refers to a symbol whose name is "CAR" (with three letters), and never to a four-letter symbol "CAR."  File: gcl.info, Node: NIL, Next: Designators, Prev: Use of the Dot Character, Up: Notational Conventions 1.4.1.11 NIL ............ nil has a variety of meanings. It is a symbol in the COMMON-LISP package with the name "NIL", it is boolean (and generalized boolean) false, it is the empty list, and it is the name of the empty type (a subtype of all types). Within Common Lisp, nil can be notated interchangeably as either NIL or (). By convention, the choice of notation offers a hint as to which of its many roles it is playing. For Evaluation? Notation Typically Implied Role ________________________________________________________ Yes nil use as a boolean. Yes 'nil use as a symbol. Yes '() use as an empty list No nil use as a symbol or boolean. No () use as an empty list. Figure 1-1: Notations for NIL Within this document only, nil is also sometimes notated as false to emphasize its role as a boolean. For example: (print ()) ;avoided (defun three nil 3) ;avoided '(nil nil) ;list of two symbols '(() ()) ;list of empty lists (defun three () 3) ;Emphasize empty parameter list. (append '() '()) => () ;Emphasize use of empty lists (not nil) => true ;Emphasize use as Boolean false (get 'nil 'color) ;Emphasize use as a symbol A function is sometimes said to "be false" or "be true" in some circumstance. Since no function object can be the same as nil and all function objects represent true when viewed as booleans, it would be meaningless to say that the function was literally false and uninteresting to say that it was literally true. Instead, these phrases are just traditional alternative ways of saying that the function "returns false" or "returns true," respectively.  File: gcl.info, Node: Designators, Next: Nonsense Words, Prev: NIL, Up: Notational Conventions 1.4.1.12 Designators .................... A designator is an object that denotes another object. Where a parameter of an operator is described as a designator, the description of the operator is written in a way that assumes that the value of the parameter is the denoted object; that is, that the parameter is already of the denoted type. (The specific nature of the object denoted by a "<> designator" or a "designator for a <>" can be found in the Glossary entry for "<> designator.") For example, "nil" and "the value of *standard-output*" are operationally indistinguishable as stream designators. Similarly, the symbol foo and the string "FOO" are operationally indistinguishable as string designators. Except as otherwise noted, in a situation where the denoted object might be used multiple times, it is implementation-dependent whether the object is coerced only once or whether the coercion occurs each time the object must be used. For example, mapcar receives a function designator as an argument, and its description is written as if this were simply a function. In fact, it is implementation-dependent whether the function designator is coerced right away or whether it is carried around internally in the form that it was given as an argument and re-coerced each time it is needed. In most cases, conforming programs cannot detect the distinction, but there are some pathological situations (particularly those involving self-redefining or mutually-redefining functions) which do conform and which can detect this difference. The following program is a conforming program, but might or might not have portably correct results, depending on whether its correctness depends on one or the other of the results: (defun add-some (x) (defun add-some (x) (+ x 2)) (+ x 1)) => ADD-SOME (mapcar 'add-some '(1 2 3 4)) => (2 3 4 5) OR=> (2 4 5 6) In a few rare situations, there may be a need in a dictionary entry to refer to the object that was the original designator for a parameter. Since naming the parameter would refer to the denoted object, the phrase "the <> designator" can be used to refer to the designator which was the argument from which the value of <> was computed.  File: gcl.info, Node: Nonsense Words, Prev: Designators, Up: Notational Conventions 1.4.1.13 Nonsense Words ....................... When a word having no pre-attached semantics is required (e.g., in an example), it is common in the Lisp community to use one of the words "foo," "bar," "baz," and "quux." For example, in (defun foo (x) (+ x 1)) the use of the name foo is just a shorthand way of saying "please substitute your favorite name here." These nonsense words have gained such prevalance of usage, that it is commonplace for newcomers to the community to begin to wonder if there is an attached semantics which they are overlooking--there is not.  File: gcl.info, Node: Error Terminology, Next: Sections Not Formally Part Of This Standard, Prev: Notational Conventions, Up: Definitions 1.4.2 Error Terminology ----------------------- Situations in which errors might, should, or must be signaled are described in the standard. The wording used to describe such situations is intended to have precise meaning. The following list is a glossary of those meanings. Safe code This is code processed with the safety optimization at its highest setting (3). safety is a lexical property of code. The phrase "the function F should signal an error" means that if F is invoked from code processed with the highest safety optimization, an error is signaled. It is implementation-dependent whether F or the calling code signals the error. Unsafe code This is code processed with lower safety levels. Unsafe code might do error checking. Implementations are permitted to treat all code as safe code all the time. An error is signaled This means that an error is signaled in both safe and unsafe code. Conforming code may rely on the fact that the error is signaled in both safe and unsafe code. Every implementation is required to detect the error in both safe and unsafe code. For example, "an error is signaled if unexport is given a symbol not accessible in the current package." If an explicit error type is not specified, the default is error. An error should be signaled This means that an error is signaled in safe code, and an error might be signaled in unsafe code. Conforming code may rely on the fact that the error is signaled in safe code. Every implementation is required to detect the error at least in safe code. When the error is not signaled, the "consequences are undefined" (see below). For example, "+ should signal an error of type type-error if any argument is not of type number." Should be prepared to signal an error This is similar to "should be signaled" except that it does not imply that 'extra effort' has to be taken on the part of an operator to discover an erroneous situation if the normal action of that operator can be performed successfully with only 'lazy' checking. An implementation is always permitted to signal an error, but even in safe code, it is only required to signal the error when failing to signal it might lead to incorrect results. In unsafe code, the consequences are undefined. For example, defining that "find should be prepared to signal an error of type type-error if its second argument is not a proper list" does not imply that an error is always signaled. The form (find 'a '(a b . c)) must either signal an error of type type-error in safe code, else return A. In unsafe code, the consequences are undefined. By contrast, (find 'd '(a b . c)) must signal an error of type type-error in safe code. In unsafe code, the consequences are undefined. Also, (find 'd '#1=(a b . #1#)) in safe code might return nil (as an implementation-defined extension), might never return, or might signal an error of type type-error. In unsafe code, the consequences are undefined. Typically, the "should be prepared to signal" terminology is used in type checking situations where there are efficiency considerations that make it impractical to detect errors that are not relevant to the correct operation of the operator. The consequences are unspecified This means that the consequences are unpredictable but harmless. Implementations are permitted to specify the consequences of this situation. No conforming code may depend on the results or effects of this situation, and all conforming code is required to treat the results and effects of this situation as unpredictable but harmless. For example, "if the second argument to shared-initialize specifies a name that does not correspond to any slots accessible in the object, the results are unspecified." The consequences are undefined This means that the consequences are unpredictable. The consequences may range from harmless to fatal. No conforming code may depend on the results or effects. Conforming code must treat the consequences as unpredictable. In places where the words "must," "must not," or "may not" are used, then "the consequences are undefined" if the stated requirement is not met and no specific consequence is explicitly stated. An implementation is permitted to signal an error in this case. For example: "Once a name has been declared by defconstant to be constant, any further assignment or binding of that variable has undefined consequences." An error might be signaled This means that the situation has undefined consequences; however, if an error is signaled, it is of the specified type. For example, "open might signal an error of type file-error." The return values are unspecified This means that only the number and nature of the return values of a form are not specified. However, the issue of whether or not any side-effects or transfer of control occurs is still well-specified. A program can be well-specified even if it uses a function whose returns values are unspecified. For example, even if the return values of some function F are unspecified, an expression such as (length (list (F))) is still well-specified because it does not rely on any particular aspect of the value or values returned by F. Implementations may be extended to cover this situation This means that the situation has undefined consequences; however, a conforming implementation is free to treat the situation in a more specific way. For example, an implementation might define that an error is signaled, or that an error should be signaled, or even that a certain well-defined non-error behavior occurs. No conforming code may depend on the consequences of such a situation; all conforming code must treat the consequences of the situation as undefined. Implementations are required to document how the situation is treated. For example, "implementations may be extended to define other type specifiers to have a corresponding class." Implementations are free to extend the syntax This means that in this situation implementations are permitted to define unambiguous extensions to the syntax of the form being described. No conforming code may depend on this extension. Implementations are required to document each such extension. All conforming code is required to treat the syntax as meaningless. The standard might disallow certain extensions while allowing others. For example, "no implementation is free to extend the syntax of defclass." A warning might be issued This means that implementations are encouraged to issue a warning if the context is appropriate (e.g., when compiling). However, a conforming implementation is not required to issue a warning.  File: gcl.info, Node: Sections Not Formally Part Of This Standard, Next: Interpreting Dictionary Entries, Prev: Error Terminology, Up: Definitions 1.4.3 Sections Not Formally Part Of This Standard ------------------------------------------------- Front matter and back matter, such as the "Table of Contents," "Index," "Figures," "Credits," and "Appendix" are not considered formally part of this standard, so that we retain the flexibility needed to update these sections even at the last minute without fear of needing a formal vote to change those parts of the document. These items are quite short and very useful, however, and it is not recommended that they be removed even in an abridged version of this document. Within the concept sections, subsections whose names begin with the words "Note" or "Notes" or "Example" or "Examples" are provided for illustration purposes only, and are not considered part of the standard. An attempt has been made to place these sections last in their parent section, so that they could be removed without disturbing the contiguous numbering of the surrounding sections in order to produce a document of smaller size. Likewise, the "Examples" and "Notes" sections in a dictionary entry are not considered part of the standard and could be removed if necessary. Nevertheless, the examples provide important clarifications and consistency checks for the rest of the material, and such abridging is not recommended unless absolutely unavoidable.  File: gcl.info, Node: Interpreting Dictionary Entries, Prev: Sections Not Formally Part Of This Standard, Up: Definitions 1.4.4 Interpreting Dictionary Entries ------------------------------------- The dictionary entry for each defined name is partitioned into sections. Except as explicitly indicated otherwise below, each section is introduced by a label identifying that section. The omission of a section implies that the section is either not applicable, or would provide no interesting information. This section defines the significance of each potential section in a dictionary entry. * Menu: * The "Affected By" Section of a Dictionary Entry:: * The "Arguments" Section of a Dictionary Entry:: * The "Arguments and Values" Section of a Dictionary Entry:: * The "Binding Types Affected" Section of a Dictionary Entry:: * The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: * The "Compound Type Specifier Kind" Section of a Dictionary Entry:: * The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: * The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: * The "Compound Type Specifier Description" Section of a Dictionary Entry:: * The "Constant Value" Section of a Dictionary Entry:: * The "Description" Section of a Dictionary Entry:: * The "Examples" Section of a Dictionary Entry:: * The "Exceptional Situations" Section of a Dictionary Entry:: * The "Initial Value" Section of a Dictionary Entry:: * The "Argument Precedence Order" Section of a Dictionary Entry:: * The "Method Signature" Section of a Dictionary Entry:: * The "Name" Section of a Dictionary Entry:: * The "Notes" Section of a Dictionary Entry:: * The "Pronunciation" Section of a Dictionary Entry:: * The "See Also" Section of a Dictionary Entry:: * The "Side Effects" Section of a Dictionary Entry:: * The "Supertypes" Section of a Dictionary Entry:: * The "Syntax" Section of a Dictionary Entry:: * Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: * Requiring Non-Null Rest Parameters in The "Syntax" Section:: * Return values in The "Syntax" Section:: * No Arguments or Values in The "Syntax" Section:: * Unconditional Transfer of Control in The "Syntax" Section:: * The "Valid Context" Section of a Dictionary Entry:: * The "Value Type" Section of a Dictionary Entry::  File: gcl.info, Node: The "Affected By" Section of a Dictionary Entry, Next: The "Arguments" Section of a Dictionary Entry, Prev: Interpreting Dictionary Entries, Up: Interpreting Dictionary Entries 1.4.4.1 The "Affected By" Section of a Dictionary Entry ....................................................... For an operator, anything that can affect the side effects of or values returned by the operator. For a variable, anything that can affect the value of the variable including functions that bind or assign it.  File: gcl.info, Node: The "Arguments" Section of a Dictionary Entry, Next: The "Arguments and Values" Section of a Dictionary Entry, Prev: The "Affected By" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.2 The "Arguments" Section of a Dictionary Entry ..................................................... This information describes the syntax information of entries such as those for declarations and special expressions which are never evaluated as forms, and so do not return values.  File: gcl.info, Node: The "Arguments and Values" Section of a Dictionary Entry, Next: The "Binding Types Affected" Section of a Dictionary Entry, Prev: The "Arguments" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.3 The "Arguments and Values" Section of a Dictionary Entry ................................................................ An English language description of what arguments the operator accepts and what values it returns, including information about defaults for parameters corresponding to omittable arguments (such as optional parameters and keyword parameters). For special operators and macros, their arguments are not evaluated unless it is explicitly stated in their descriptions that they are evaluated.  File: gcl.info, Node: The "Binding Types Affected" Section of a Dictionary Entry, Next: The "Class Precedence List" Section of a Dictionary Entry, Prev: The "Arguments and Values" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.4 The "Binding Types Affected" Section of a Dictionary Entry .................................................................. This information alerts the reader to the kinds of bindings that might potentially be affected by a declaration. Whether in fact any particular such binding is actually affected is dependent on additional factors as well. See The "Description" Section of the declaration in question for details.  File: gcl.info, Node: The "Class Precedence List" Section of a Dictionary Entry, Next: Dictionary Entries for Type Specifiers, Prev: The "Binding Types Affected" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.5 The "Class Precedence List" Section of a Dictionary Entry ................................................................. This appears in the dictionary entry for a class, and contains an ordered list of the classes defined by Common Lisp that must be in the class precedence list of this class. It is permissible for other (implementation-defined) classes to appear in the implementation's class precedence list for the class. It is permissible for either standard-object or structure-object to appear in the implementation's class precedence list; for details, see *note Type Relationships::. Except as explicitly indicated otherwise somewhere in this specification, no additional standardized classes may appear in the implementation's class precedence list. By definition of the relationship between classes and types, the classes listed in this section are also supertypes of the type denoted by the class.  File: gcl.info, Node: Dictionary Entries for Type Specifiers, Next: The "Compound Type Specifier Kind" Section of a Dictionary Entry, Prev: The "Class Precedence List" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.6 Dictionary Entries for Type Specifiers .............................................. The atomic type specifiers are those defined names listed in Figure~4-2. Such dictionary entries are of kind "Class," "Condition Type," "System Class," or "Type." A description of how to interpret a symbol naming one of these types or classes as an atomic type specifier is found in The "Description" Section of such dictionary entries. The compound type specifiers are those defined names listed in Figure~4-3. Such dictionary entries are of kind "Class," "System Class," "Type," or "Type Specifier." A description of how to interpret as a compound type specifier a list whose car is such a symbol is found in the "Compound Type Specifier Kind," "Compound Type Specifier Syntax," "Compound Type Specifier Arguments," and "Compound Type Specifier Description" sections of such dictionary entries.  File: gcl.info, Node: The "Compound Type Specifier Kind" Section of a Dictionary Entry, Next: The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Prev: Dictionary Entries for Type Specifiers, Up: Interpreting Dictionary Entries 1.4.4.7 The "Compound Type Specifier Kind" Section of a Dictionary Entry ........................................................................ An "abbreviating" type specifier is one that describes a subtype for which it is in principle possible to enumerate the elements, but for which in practice it is impractical to do so. A "specializing" type specifier is one that describes a subtype by restricting the type of one or more components of the type, such as element type or complex part type. A "predicating" type specifier is one that describes a subtype containing only those objects that satisfy a given predicate. A "combining" type specifier is one that describes a subtype in a compositional way, using combining operations (such as "and," "or," and "not") on other types.  File: gcl.info, Node: The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Next: The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Prev: The "Compound Type Specifier Kind" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.8 The "Compound Type Specifier Syntax" Section of a Dictionary Entry .......................................................................... This information about a type describes the syntax of a compound type specifier for that type. Whether or not the type is acceptable as an atomic type specifier is not represented here; see *note Dictionary Entries for Type Specifiers::.  File: gcl.info, Node: The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Next: The "Compound Type Specifier Description" Section of a Dictionary Entry, Prev: The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.9 The "Compound Type Specifier Arguments" Section of a Dictionary Entry ............................................................................. This information describes type information for the structures defined in The "Compound Type Specifier Syntax" Section.  File: gcl.info, Node: The "Compound Type Specifier Description" Section of a Dictionary Entry, Next: The "Constant Value" Section of a Dictionary Entry, Prev: The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.10 The "Compound Type Specifier Description" Section of a Dictionary Entry ................................................................................ This information describes the meaning of the structures defined in The "Compound Type Specifier Syntax" Section.  File: gcl.info, Node: The "Constant Value" Section of a Dictionary Entry, Next: The "Description" Section of a Dictionary Entry, Prev: The "Compound Type Specifier Description" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.11 The "Constant Value" Section of a Dictionary Entry ........................................................... This information describes the unchanging type and value of a constant variable.  File: gcl.info, Node: The "Description" Section of a Dictionary Entry, Next: The "Examples" Section of a Dictionary Entry, Prev: The "Constant Value" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.12 The "Description" Section of a Dictionary Entry ........................................................ A summary of the operator and all intended aspects of the operator, but does not necessarily include all the fields referenced below it ("Side Effects," "Exceptional Situations," etc.)  File: gcl.info, Node: The "Examples" Section of a Dictionary Entry, Next: The "Exceptional Situations" Section of a Dictionary Entry, Prev: The "Description" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.13 The "Examples" Section of a Dictionary Entry ..................................................... Examples of use of the operator. These examples are not considered part of the standard; see *note Sections Not Formally Part Of This Standard::.  File: gcl.info, Node: The "Exceptional Situations" Section of a Dictionary Entry, Next: The "Initial Value" Section of a Dictionary Entry, Prev: The "Examples" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.14 The "Exceptional Situations" Section of a Dictionary Entry ................................................................... Three kinds of information may appear here: * Situations that are detected by the function and formally signaled. * Situations that are handled by the function. * Situations that may be detected by the function. This field does not include conditions that could be signaled by functions passed to and called by this operator as arguments or through dynamic variables, nor by executing subforms of this operator if it is a macro or special operator.  File: gcl.info, Node: The "Initial Value" Section of a Dictionary Entry, Next: The "Argument Precedence Order" Section of a Dictionary Entry, Prev: The "Exceptional Situations" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.15 The "Initial Value" Section of a Dictionary Entry .......................................................... This information describes the initial value of a dynamic variable. Since this variable might change, see type restrictions in The "Value Type" Section.  File: gcl.info, Node: The "Argument Precedence Order" Section of a Dictionary Entry, Next: The "Method Signature" Section of a Dictionary Entry, Prev: The "Initial Value" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.16 The "Argument Precedence Order" Section of a Dictionary Entry ...................................................................... This information describes the argument precedence order. If it is omitted, the argument precedence order is the default (left to right).  File: gcl.info, Node: The "Method Signature" Section of a Dictionary Entry, Next: The "Name" Section of a Dictionary Entry, Prev: The "Argument Precedence Order" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.17 The "Method Signature" Section of a Dictionary Entry ............................................................. The description of a generic function includes descriptions of the methods that are defined on that generic function by the standard. A method signature is used to describe the parameters and parameter specializers for each method. Methods defined for the generic function must be of the form described by the method signature. 'F' (x class) (y t) &optional z &key k This signature indicates that this method on the generic function F has two required parameters: x, which must be a generalized instance of the class class; and y, which can be any object (i.e., a generalized instance of the class t). In addition, there is an optional parameter z and a keyword parameter k. This signature also indicates that this method on F is a primary method and has no qualifiers. For each parameter, the argument supplied must be in the intersection of the type specified in the description of the corresponding generic function and the type given in the signature of some method (including not only those methods defined in this specification, but also implementation-defined or user-defined methods in situations where the definition of such methods is permitted).  File: gcl.info, Node: The "Name" Section of a Dictionary Entry, Next: The "Notes" Section of a Dictionary Entry, Prev: The "Method Signature" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.18 The "Name" Section of a Dictionary Entry ................................................. This section introduces the dictionary entry. It is not explicitly labeled. It appears preceded and followed by a horizontal bar. In large print at left, the defined name appears; if more than one defined name is to be described by the entry, all such names are shown separated by commas. In somewhat smaller italic print at right is an indication of what kind of dictionary entry this is. Possible values are: Accessor This is an accessor function. Class This is a class. Condition Type This is a subtype of type condition. Constant Variable This is a constant variable. Declaration This is a declaration identifier. Function This is a function. Local Function This is a function that is defined only lexically within the scope of some other macro form. Local Macro This is a macro that is defined only lexically within the scope of some other macro form. Macro This is a macro. Restart This is a restart. Special Operator This is a special operator. Standard Generic Function This is a standard generic function. Symbol This is a symbol that is specially recognized in some particular situation, such as the syntax of a macro. System Class This is like class, but it identifies a class that is potentially a built-in class. (No class is actually required to be a built-in class.) Type This is an atomic type specifier, and depending on information for each particular entry, may subject to form other type specifiers. Type Specifier This is a defined name that is not an atomic type specifier, but that can be used in constructing valid type specifiers. Variable This is a dynamic variable.  File: gcl.info, Node: The "Notes" Section of a Dictionary Entry, Next: The "Pronunciation" Section of a Dictionary Entry, Prev: The "Name" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.19 The "Notes" Section of a Dictionary Entry .................................................. Information not found elsewhere in this description which pertains to this operator. Among other things, this might include cross reference information, code equivalences, stylistic hints, implementation hints, typical uses. This information is not considered part of the standard; any conforming implementation or conforming program is permitted to ignore the presence of this information.  File: gcl.info, Node: The "Pronunciation" Section of a Dictionary Entry, Next: The "See Also" Section of a Dictionary Entry, Prev: The "Notes" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.20 The "Pronunciation" Section of a Dictionary Entry .......................................................... This offers a suggested pronunciation for defined names so that people not in verbal communication with the original designers can figure out how to pronounce words that are not in normal English usage. This information is advisory only, and is not considered part of the standard. For brevity, it is only provided for entries with names that are specific to Common Lisp and would not be found in Webster's Third New International Dictionary the English Language, Unabridged.  File: gcl.info, Node: The "See Also" Section of a Dictionary Entry, Next: The "Side Effects" Section of a Dictionary Entry, Prev: The "Pronunciation" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.21 The "See Also" Section of a Dictionary Entry ..................................................... List of references to other parts of this standard that offer information relevant to this operator. This list is not part of the standard.  File: gcl.info, Node: The "Side Effects" Section of a Dictionary Entry, Next: The "Supertypes" Section of a Dictionary Entry, Prev: The "See Also" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.22 The "Side Effects" Section of a Dictionary Entry ......................................................... Anything that is changed as a result of the evaluation of the form containing this operator.  File: gcl.info, Node: The "Supertypes" Section of a Dictionary Entry, Next: The "Syntax" Section of a Dictionary Entry, Prev: The "Side Effects" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.23 The "Supertypes" Section of a Dictionary Entry ....................................................... This appears in the dictionary entry for a type, and contains a list of the standardized types that must be supertypes of this type. In implementations where there is a corresponding class, the order of the classes in the class precedence list is consistent with the order presented in this section.  File: gcl.info, Node: The "Syntax" Section of a Dictionary Entry, Next: Special "Syntax" Notations for Overloaded Operators, Prev: The "Supertypes" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.24 The "Syntax" Section of a Dictionary Entry ................................................... This section describes how to use the defined name in code. The "Syntax" description for a generic function describes the lambda list of the generic function itself, while The "Method Signatures" describe the lambda lists of the defined methods. The "Syntax" description for an ordinary function, a macro, or a special operator describes its parameters. For example, an operator description might say: 'F' x y &optional z &key k This description indicates that the function F has two required parameters, x and y. In addition, there is an optional parameter z and a keyword parameter k. For macros and special operators, syntax is given in modified BNF notation; see *note Modified BNF Syntax::. For functions a lambda list is given. In both cases, however, the outermost parentheses are omitted, and default value information is omitted.  File: gcl.info, Node: Special "Syntax" Notations for Overloaded Operators, Next: Naming Conventions for Rest Parameters, Prev: The "Syntax" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.25 Special "Syntax" Notations for Overloaded Operators ............................................................ If two descriptions exist for the same operation but with different numbers of arguments, then the extra arguments are to be treated as optional. For example, this pair of lines: 'file-position' stream => position 'file-position' stream position-spec => success-p is operationally equivalent to this line: 'file-position' stream &optional position-spec => result and differs only in that it provides on opportunity to introduce different names for parameter and values for each case. The separated (multi-line) notation is used when an operator is overloaded in such a way that the parameters are used in different ways depending on how many arguments are supplied (e.g., for the function /) or the return values are different in the two cases (e.g., for the function file-position).  File: gcl.info, Node: Naming Conventions for Rest Parameters, Next: Requiring Non-Null Rest Parameters in The "Syntax" Section, Prev: Special "Syntax" Notations for Overloaded Operators, Up: Interpreting Dictionary Entries 1.4.4.26 Naming Conventions for Rest Parameters ............................................... Within this specification, if the name of a rest parameter is chosen to be a plural noun, use of that name in parameter font refers to the list to which the rest parameter is bound. Use of the singular form of that name in parameter font refers to an element of that list. For example, given a syntax description such as: 'F' &rest arguments it is appropriate to refer either to the rest parameter named arguments by name, or to one of its elements by speaking of "an argument," "some argument," "each argument" etc.  File: gcl.info, Node: Requiring Non-Null Rest Parameters in The "Syntax" Section, Next: Return values in The "Syntax" Section, Prev: Naming Conventions for Rest Parameters, Up: Interpreting Dictionary Entries 1.4.4.27 Requiring Non-Null Rest Parameters in The "Syntax" Section ................................................................... In some cases it is useful to refer to all arguments equally as a single aggregation using a rest parameter while at the same time requiring at least one argument. A variety of imperative and declarative means are available in code for expressing such a restriction, however they generally do not manifest themselves in a lambda list. For descriptive purposes within this specification, 'F' &rest arguments^+ means the same as 'F' &rest arguments but introduces the additional requirement that there be at least one argument.  File: gcl.info, Node: Return values in The "Syntax" Section, Next: No Arguments or Values in The "Syntax" Section, Prev: Requiring Non-Null Rest Parameters in The "Syntax" Section, Up: Interpreting Dictionary Entries 1.4.4.28 Return values in The "Syntax" Section .............................................. An evaluation arrow "=>" precedes a list of values to be returned. For example: 'F' a b c => x indicates that F is an operator that has three required parameters (i.e., a, b, and c) and that returns one value (i.e., x). If more than one value is returned by an operator, the names of the values are separated by commas, as in: 'F' a b c => x, y, z  File: gcl.info, Node: No Arguments or Values in The "Syntax" Section, Next: Unconditional Transfer of Control in The "Syntax" Section, Prev: Return values in The "Syntax" Section, Up: Interpreting Dictionary Entries 1.4.4.29 No Arguments or Values in The "Syntax" Section ....................................................... If no arguments are permitted, or no values are returned, a special notation is used to make this more visually apparent. For example, 'F' => indicates that F is an operator that accepts no arguments and returns no values.  File: gcl.info, Node: Unconditional Transfer of Control in The "Syntax" Section, Next: The "Valid Context" Section of a Dictionary Entry, Prev: No Arguments or Values in The "Syntax" Section, Up: Interpreting Dictionary Entries 1.4.4.30 Unconditional Transfer of Control in The "Syntax" Section .................................................................. Some operators perform an unconditional transfer of control, and so never have any return values. Such operators are notated using a notation such as the following: 'F' a b c => #  File: gcl.info, Node: The "Valid Context" Section of a Dictionary Entry, Next: The "Value Type" Section of a Dictionary Entry, Prev: Unconditional Transfer of Control in The "Syntax" Section, Up: Interpreting Dictionary Entries 1.4.4.31 The "Valid Context" Section of a Dictionary Entry .......................................................... This information is used by dictionary entries such as "Declarations" in order to restrict the context in which the declaration may appear. A given "Declaration" might appear in a declaration (i.e., a declare expression), a proclamation (i.e., a declaim or proclaim form), or both.  File: gcl.info, Node: The "Value Type" Section of a Dictionary Entry, Prev: The "Valid Context" Section of a Dictionary Entry, Up: Interpreting Dictionary Entries 1.4.4.32 The "Value Type" Section of a Dictionary Entry ....................................................... This information describes any type restrictions on a dynamic variable.  File: gcl.info, Node: Conformance, Next: Language Extensions, Prev: Definitions, Up: Introduction (Introduction) 1.5 Conformance =============== This standard presents the syntax and semantics to be implemented by a conforming implementation (and its accompanying documentation). In addition, it imposes requirements on conforming programs. * Menu: * Conforming Implementations:: * Conforming Programs::  File: gcl.info, Node: Conforming Implementations, Next: Conforming Programs, Prev: Conformance, Up: Conformance 1.5.1 Conforming Implementations -------------------------------- A conforming implementation shall adhere to the requirements outlined in this section. * Menu: * Required Language Features:: * Documentation of Implementation-Dependent Features:: * Documentation of Extensions:: * Treatment of Exceptional Situations:: * Resolution of Apparent Conflicts in Exceptional Situations:: * Examples of Resolution of Apparent Conflict in Exceptional Situations:: * Conformance Statement::  File: gcl.info, Node: Required Language Features, Next: Documentation of Implementation-Dependent Features, Prev: Conforming Implementations, Up: Conforming Implementations 1.5.1.1 Required Language Features .................................. A conforming implementation shall accept all features (including deprecated features) of the language specified in this standard, with the meanings defined in this standard. A conforming implementation shall not require the inclusion of substitute or additional language elements in code in order to accomplish a feature of the language that is specified in this standard.  File: gcl.info, Node: Documentation of Implementation-Dependent Features, Next: Documentation of Extensions, Prev: Required Language Features, Up: Conforming Implementations 1.5.1.2 Documentation of Implementation-Dependent Features .......................................................... A conforming implementation shall be accompanied by a document that provides a definition of all implementation-defined aspects of the language defined by this specification. In addition, a conforming implementation is encouraged (but not required) to document items in this standard that are identified as implementation-dependent, although in some cases such documentation might simply identify the item as "undefined."  File: gcl.info, Node: Documentation of Extensions, Next: Treatment of Exceptional Situations, Prev: Documentation of Implementation-Dependent Features, Up: Conforming Implementations 1.5.1.3 Documentation of Extensions ................................... A conforming implementation shall be accompanied by a document that separately describes any features accepted by the implementation that are not specified in this standard, but that do not cause any ambiguity or contradiction when added to the language standard. Such extensions shall be described as being "extensions to Common Lisp as specified by ANSI <>."  File: gcl.info, Node: Treatment of Exceptional Situations, Next: Resolution of Apparent Conflicts in Exceptional Situations, Prev: Documentation of Extensions, Up: Conforming Implementations 1.5.1.4 Treatment of Exceptional Situations ........................................... A conforming implementation shall treat exceptional situations in a manner consistent with this specification.  File: gcl.info, Node: Resolution of Apparent Conflicts in Exceptional Situations, Next: Examples of Resolution of Apparent Conflict in Exceptional Situations, Prev: Treatment of Exceptional Situations, Up: Conforming Implementations 1.5.1.5 Resolution of Apparent Conflicts in Exceptional Situations .................................................................. If more than one passage in this specification appears to apply to the same situation but in conflicting ways, the passage that appears to describe the situation in the most specific way (not necessarily the passage that provides the most constrained kind of error detection) takes precedence.  File: gcl.info, Node: Examples of Resolution of Apparent Conflict in Exceptional Situations, Next: Conformance Statement, Prev: Resolution of Apparent Conflicts in Exceptional Situations, Up: Conforming Implementations 1.5.1.6 Examples of Resolution of Apparent Conflict in Exceptional Situations ............................................................................. Suppose that function foo is a member of a set S of functions that operate on numbers. Suppose that one passage states that an error must be signaled if any function in S is ever given an argument of 17. Suppose that an apparently conflicting passage states that the consequences are undefined if foo receives an argument of 17. Then the second passage (the one specifically about foo) would dominate because the description of the situational context is the most specific, and it would not be required that foo signal an error on an argument of 17 even though other functions in the set S would be required to do so.  File: gcl.info, Node: Conformance Statement, Prev: Examples of Resolution of Apparent Conflict in Exceptional Situations, Up: Conforming Implementations 1.5.1.7 Conformance Statement ............................. A conforming implementation shall produce a conformance statement as a consequence of using the implementation, or that statement shall be included in the accompanying documentation. If the implementation conforms in all respects with this standard, the conformance statement shall be "<> conforms with the requirements of ANSI <>" If the implementation conforms with some but not all of the requirements of this standard, then the conformance statement shall be "<> conforms with the requirements of ANSI <> with the following exceptions: <>."  File: gcl.info, Node: Conforming Programs, Prev: Conforming Implementations, Up: Conformance 1.5.2 Conforming Programs ------------------------- Code conforming with the requirements of this standard shall adhere to the following: 1. Conforming code shall use only those features of the language syntax and semantics that are either specified in this standard or defined using the extension mechanisms specified in the standard. 2. Conforming code shall not rely on any particular interpretation of implementation-dependent features. 3. Conforming code shall not depend on the consequences of undefined or unspecified situations. 4. Conforming code does not use any constructions that are prohibited by the standard. 5. Conforming code does not depend on extensions included in an implementation. * Menu: * Use of Implementation-Defined Language Features:: * Use of Read-Time Conditionals::  File: gcl.info, Node: Use of Implementation-Defined Language Features, Next: Use of Read-Time Conditionals, Prev: Conforming Programs, Up: Conforming Programs 1.5.2.1 Use of Implementation-Defined Language Features ....................................................... Note that conforming code may rely on particular implementation-defined values or features. Also note that the requirements for conforming code and conforming implementations do not require that the results produced by conforming code always be the same when processed by a conforming implementation. The results may be the same, or they may differ. Portable code is written using only standard characters. Conforming code may run in all conforming implementations, but might have allowable implementation-defined behavior that makes it non-portable code. For example, the following are examples of forms that are conforming, but that might return different values in different implementations: (evenp most-positive-fixnum) => implementation-dependent (random) => implementation-dependent (> lambda-parameters-limit 93) => implementation-dependent (char-name #\A) => implementation-dependent  File: gcl.info, Node: Use of Read-Time Conditionals, Prev: Use of Implementation-Defined Language Features, Up: Conforming Programs 1.5.2.2 Use of Read-Time Conditionals ..................................... Use of #+ and #- does not automatically disqualify a program from being conforming. A program which uses #+ and #- is considered conforming if there is no set of features in which the program would not be conforming. Of course, conforming programs are not necessarily working programs. The following program is conforming: (defun foo () #+ACME (acme:initialize-something) (print 'hello-there)) However, this program might or might not work, depending on whether the presence of the feature ACME really implies that a function named acme:initialize-something is present in the environment. In effect, using #+ or #- in a conforming program means that the variable *features* becomes just one more piece of input data to that program. Like any other data coming into a program, the programmer is responsible for assuring that the program does not make unwarranted assumptions on the basis of input data.  File: gcl.info, Node: Language Extensions, Next: Language Subsets, Prev: Conformance, Up: Introduction (Introduction) 1.6 Language Extensions ======================= A language extension is any documented implementation-defined behavior of a defined name in this standard that varies from the behavior described in this standard, or a documented consequence of a situation that the standard specifies as undefined, unspecified, or extendable by the implementation. For example, if this standard says that "the results are unspecified," an extension would be to specify the results. [Reviewer Note by Barmar: This contradicts previous definitions of conforming code.] If the correct behavior of a program depends on the results provided by an extension, only implementations with the same extension will execute the program correctly. Note that such a program might be non-conforming. Also, if this standard says that "an implementation may be extended," a conforming, but possibly non-portable, program can be written using an extension. An implementation can have extensions, provided they do not alter the behavior of conforming code and provided they are not explicitly prohibited by this standard. The term "extension" refers only to extensions available upon startup. An implementation is free to allow or prohibit redefinition of an extension. The following list contains specific guidance to implementations concerning certain types of extensions. Extra return values An implementation must return exactly the number of return values specified by this standard unless the standard specifically indicates otherwise. Unsolicited messages No output can be produced by a function other than that specified in the standard or due to the signaling of conditions detected by the function. Unsolicited output, such as garbage collection notifications and autoload heralds, should not go directly to the stream that is the value of a stream variable defined in this standard, but can go indirectly to terminal I/O by using a synonym stream to *terminal-io*. Progress reports from such functions as load and compile are considered solicited, and are not covered by this prohibition. Implementation of macros and special forms Macros and special operators defined in this standard must not be functions.  File: gcl.info, Node: Language Subsets, Next: Deprecated Language Features, Prev: Language Extensions, Up: Introduction (Introduction) 1.7 Language Subsets ==================== The language described in this standard contains no subsets, though subsets are not forbidden. For a language to be considered a subset, it must have the property that any valid program in that language has equivalent semantics and will run directly (with no extralingual pre-processing, and no special compatibility packages) in any conforming implementation of the full language. A language that conforms to this requirement shall be described as being a "subset of Common Lisp as specified by ANSI <>."  File: gcl.info, Node: Deprecated Language Features, Next: Symbols in the COMMON-LISP Package, Prev: Language Subsets, Up: Introduction (Introduction) 1.8 Deprecated Language Features ================================ Deprecated language features are not expected to appear in future Common Lisp standards, but are required to be implemented for conformance with this standard; see *note Required Language Features::. Conforming programs can use deprecated features; however, it is considered good programming style to avoid them. It is permissible for the compiler to produce style warnings about the use of such features at compile time, but there should be no such warnings at program execution time. * Menu: * Deprecated Functions:: * Deprecated Argument Conventions:: * Deprecated Variables:: * Deprecated Reader Syntax::  File: gcl.info, Node: Deprecated Functions, Next: Deprecated Argument Conventions, Prev: Deprecated Language Features, Up: Deprecated Language Features 1.8.1 Deprecated Functions -------------------------- The functions in Figure 1-2 are deprecated. assoc-if-not nsubst-if-not require count-if-not nsubstitute-if-not set delete-if-not position-if-not subst-if-not find-if-not provide substitute-if-not gentemp rassoc-if-not member-if-not remove-if-not Figure 1-2: Deprecated Functions  File: gcl.info, Node: Deprecated Argument Conventions, Next: Deprecated Variables, Prev: Deprecated Functions, Up: Deprecated Language Features 1.8.2 Deprecated Argument Conventions ------------------------------------- The ability to pass a numeric argument to gensym has been deprecated. The :test-not argument to the functions in Figure 1-3 are deprecated. adjoin nset-difference search assoc nset-exclusive-or set-difference count nsublis set-exclusive-or delete nsubst sublis delete-duplicates nsubstitute subsetp find nunion subst intersection position substitute member rassoc tree-equal mismatch remove union nintersection remove-duplicates Figure 1-3: Functions with Deprecated :TEST-NOT Arguments The use of the situation names compile, load, and eval in eval-when is deprecated.  File: gcl.info, Node: Deprecated Variables, Next: Deprecated Reader Syntax, Prev: Deprecated Argument Conventions, Up: Deprecated Language Features 1.8.3 Deprecated Variables -------------------------- The variable *modules* is deprecated.  File: gcl.info, Node: Deprecated Reader Syntax, Prev: Deprecated Variables, Up: Deprecated Language Features 1.8.4 Deprecated Reader Syntax ------------------------------ The #S reader macro forces keyword names into the KEYWORD package; see *note Sharpsign S::. This feature is deprecated; in the future, keyword names will be taken in the package they are read in, so symbols that are actually in the KEYWORD package should be used if that is what is desired.  File: gcl.info, Node: Symbols in the COMMON-LISP Package, Prev: Deprecated Language Features, Up: Introduction (Introduction) 1.9 Symbols in the COMMON-LISP Package ====================================== The figures on the next twelve pages contain a complete enumeration of the 978 external symbols in the COMMON-LISP package. &allow-other-keys *print-miser-width* &aux *print-pprint-dispatch* &body *print-pretty* &environment *print-radix* &key *print-readably* &optional *print-right-margin* &rest *query-io* &whole *random-state* * *read-base* ** *read-default-float-format* *** *read-eval* *break-on-signals* *read-suppress* *compile-file-pathname* *readtable* *compile-file-truename* *standard-input* *compile-print* *standard-output* *compile-verbose* *terminal-io* *debug-io* *trace-output* *debugger-hook* + *default-pathname-defaults* ++ *error-output* +++ *features* - *gensym-counter* / *load-pathname* // *load-print* /// *load-truename* /= *load-verbose* 1+ *macroexpand-hook* 1- *modules* < *package* <= *print-array* = *print-base* > *print-case* >= *print-circle* abort *print-escape* abs *print-gensym* acons *print-length* acos *print-level* acosh *print-lines* add-method Figure 1-4: Symbols in the COMMON-LISP package (part one of twelve). adjoin atom boundp adjust-array base-char break adjustable-array-p base-string broadcast-stream allocate-instance bignum broadcast-stream-streams alpha-char-p bit built-in-class alphanumericp bit-and butlast and bit-andc1 byte append bit-andc2 byte-position apply bit-eqv byte-size apropos bit-ior caaaar apropos-list bit-nand caaadr aref bit-nor caaar arithmetic-error bit-not caadar arithmetic-error-operands bit-orc1 caaddr arithmetic-error-operation bit-orc2 caadr array bit-vector caar array-dimension bit-vector-p cadaar array-dimension-limit bit-xor cadadr array-dimensions block cadar array-displacement boole caddar array-element-type boole-1 cadddr array-has-fill-pointer-p boole-2 caddr array-in-bounds-p boole-and cadr array-rank boole-andc1 call-arguments-limit array-rank-limit boole-andc2 call-method array-row-major-index boole-c1 call-next-method array-total-size boole-c2 car array-total-size-limit boole-clr case arrayp boole-eqv catch ash boole-ior ccase asin boole-nand cdaaar asinh boole-nor cdaadr assert boole-orc1 cdaar assoc boole-orc2 cdadar assoc-if boole-set cdaddr assoc-if-not boole-xor cdadr atan boolean cdar atanh both-case-p cddaar Figure 1-5: Symbols in the COMMON-LISP package (part two of twelve). cddadr clear-input copy-tree cddar clear-output cos cdddar close cosh cddddr clrhash count cdddr code-char count-if cddr coerce count-if-not cdr compilation-speed ctypecase ceiling compile debug cell-error compile-file decf cell-error-name compile-file-pathname declaim cerror compiled-function declaration change-class compiled-function-p declare char compiler-macro decode-float char-code compiler-macro-function decode-universal-time char-code-limit complement defclass char-downcase complex defconstant char-equal complexp defgeneric char-greaterp compute-applicable-methods define-compiler-macro char-int compute-restarts define-condition char-lessp concatenate define-method-combination char-name concatenated-stream define-modify-macro char-not-equal concatenated-stream-streams define-setf-expander char-not-greaterp cond define-symbol-macro char-not-lessp condition defmacro char-upcase conjugate defmethod char/= cons defpackage char< consp defparameter char<= constantly defsetf char= constantp defstruct char> continue deftype char>= control-error defun character copy-alist defvar characterp copy-list delete check-type copy-pprint-dispatch delete-duplicates cis copy-readtable delete-file class copy-seq delete-if class-name copy-structure delete-if-not class-of copy-symbol delete-package Figure 1-6: Symbols in the COMMON-LISP package (part three of twelve). denominator eq deposit-field eql describe equal describe-object equalp destructuring-bind error digit-char etypecase digit-char-p eval directory eval-when directory-namestring evenp disassemble every division-by-zero exp do export do* expt do-all-symbols extended-char do-external-symbols fboundp do-symbols fceiling documentation fdefinition dolist ffloor dotimes fifth double-float file-author double-float-epsilon file-error double-float-negative-epsilon file-error-pathname dpb file-length dribble file-namestring dynamic-extent file-position ecase file-stream echo-stream file-string-length echo-stream-input-stream file-write-date echo-stream-output-stream fill ed fill-pointer eighth find elt find-all-symbols encode-universal-time find-class end-of-file find-if endp find-if-not enough-namestring find-method ensure-directories-exist find-package ensure-generic-function find-restart Figure 1-7: Symbols in the COMMON-LISP package (part four of twelve). find-symbol get-internal-run-time finish-output get-macro-character first get-output-stream-string fixnum get-properties flet get-setf-expansion float get-universal-time float-digits getf float-precision gethash float-radix go float-sign graphic-char-p floating-point-inexact handler-bind floating-point-invalid-operation handler-case floating-point-overflow hash-table floating-point-underflow hash-table-count floatp hash-table-p floor hash-table-rehash-size fmakunbound hash-table-rehash-threshold force-output hash-table-size format hash-table-test formatter host-namestring fourth identity fresh-line if fround ignorable ftruncate ignore ftype ignore-errors funcall imagpart function import function-keywords in-package function-lambda-expression incf functionp initialize-instance gcd inline generic-function input-stream-p gensym inspect gentemp integer get integer-decode-float get-decoded-time integer-length get-dispatch-macro-character integerp get-internal-real-time interactive-stream-p Figure 1-8: Symbols in the COMMON-LISP package (part five of twelve). intern lisp-implementation-type internal-time-units-per-second lisp-implementation-version intersection list invalid-method-error list* invoke-debugger list-all-packages invoke-restart list-length invoke-restart-interactively listen isqrt listp keyword load keywordp load-logical-pathname-translations labels load-time-value lambda locally lambda-list-keywords log lambda-parameters-limit logand last logandc1 lcm logandc2 ldb logbitp ldb-test logcount ldiff logeqv least-negative-double-float logical-pathname least-negative-long-float logical-pathname-translations least-negative-normalized-double-float logior least-negative-normalized-long-float lognand least-negative-normalized-short-float lognor least-negative-normalized-single-float lognot least-negative-short-float logorc1 least-negative-single-float logorc2 least-positive-double-float logtest least-positive-long-float logxor least-positive-normalized-double-float long-float least-positive-normalized-long-float long-float-epsilon least-positive-normalized-short-float long-float-negative-epsilon least-positive-normalized-single-float long-site-name least-positive-short-float loop least-positive-single-float loop-finish length lower-case-p let machine-instance let* machine-type Figure 1-9: Symbols in the COMMON-LISP package (part six of twelve). machine-version mask-field macro-function max macroexpand member macroexpand-1 member-if macrolet member-if-not make-array merge make-broadcast-stream merge-pathnames make-concatenated-stream method make-condition method-combination make-dispatch-macro-character method-combination-error make-echo-stream method-qualifiers make-hash-table min make-instance minusp make-instances-obsolete mismatch make-list mod make-load-form most-negative-double-float make-load-form-saving-slots most-negative-fixnum make-method most-negative-long-float make-package most-negative-short-float make-pathname most-negative-single-float make-random-state most-positive-double-float make-sequence most-positive-fixnum make-string most-positive-long-float make-string-input-stream most-positive-short-float make-string-output-stream most-positive-single-float make-symbol muffle-warning make-synonym-stream multiple-value-bind make-two-way-stream multiple-value-call makunbound multiple-value-list map multiple-value-prog1 map-into multiple-value-setq mapc multiple-values-limit mapcan name-char mapcar namestring mapcon nbutlast maphash nconc mapl next-method-p maplist nil Figure 1-10: Symbols in the COMMON-LISP package (part seven of twelve). nintersection package-error ninth package-error-package no-applicable-method package-name no-next-method package-nicknames not package-shadowing-symbols notany package-use-list notevery package-used-by-list notinline packagep nreconc pairlis nreverse parse-error nset-difference parse-integer nset-exclusive-or parse-namestring nstring-capitalize pathname nstring-downcase pathname-device nstring-upcase pathname-directory nsublis pathname-host nsubst pathname-match-p nsubst-if pathname-name nsubst-if-not pathname-type nsubstitute pathname-version nsubstitute-if pathnamep nsubstitute-if-not peek-char nth phase nth-value pi nthcdr plusp null pop number position numberp position-if numerator position-if-not nunion pprint oddp pprint-dispatch open pprint-exit-if-list-exhausted open-stream-p pprint-fill optimize pprint-indent or pprint-linear otherwise pprint-logical-block output-stream-p pprint-newline package pprint-pop Figure 1-11: Symbols in the COMMON-LISP package (part eight of twelve). pprint-tab read-char pprint-tabular read-char-no-hang prin1 read-delimited-list prin1-to-string read-from-string princ read-line princ-to-string read-preserving-whitespace print read-sequence print-not-readable reader-error print-not-readable-object readtable print-object readtable-case print-unreadable-object readtablep probe-file real proclaim realp prog realpart prog* reduce prog1 reinitialize-instance prog2 rem progn remf program-error remhash progv remove provide remove-duplicates psetf remove-if psetq remove-if-not push remove-method pushnew remprop quote rename-file random rename-package random-state replace random-state-p require rassoc rest rassoc-if restart rassoc-if-not restart-bind ratio restart-case rational restart-name rationalize return rationalp return-from read revappend read-byte reverse Figure 1-12: Symbols in the COMMON-LISP package (part nine of twelve). room simple-bit-vector rotatef simple-bit-vector-p round simple-condition row-major-aref simple-condition-format-arguments rplaca simple-condition-format-control rplacd simple-error safety simple-string satisfies simple-string-p sbit simple-type-error scale-float simple-vector schar simple-vector-p search simple-warning second sin sequence single-float serious-condition single-float-epsilon set single-float-negative-epsilon set-difference sinh set-dispatch-macro-character sixth set-exclusive-or sleep set-macro-character slot-boundp set-pprint-dispatch slot-exists-p set-syntax-from-char slot-makunbound setf slot-missing setq slot-unbound seventh slot-value shadow software-type shadowing-import software-version shared-initialize some shiftf sort short-float space short-float-epsilon special short-float-negative-epsilon special-operator-p short-site-name speed signal sqrt signed-byte stable-sort signum standard simple-array standard-char simple-base-string standard-char-p Figure 1-13: Symbols in the COMMON-LISP package (part ten of twelve). standard-class sublis standard-generic-function subseq standard-method subsetp standard-object subst step subst-if storage-condition subst-if-not store-value substitute stream substitute-if stream-element-type substitute-if-not stream-error subtypep stream-error-stream svref stream-external-format sxhash streamp symbol string symbol-function string-capitalize symbol-macrolet string-downcase symbol-name string-equal symbol-package string-greaterp symbol-plist string-left-trim symbol-value string-lessp symbolp string-not-equal synonym-stream string-not-greaterp synonym-stream-symbol string-not-lessp t string-right-trim tagbody string-stream tailp string-trim tan string-upcase tanh string/= tenth string< terpri string<= the string= third string> throw string>= time stringp trace structure translate-logical-pathname structure-class translate-pathname structure-object tree-equal style-warning truename Figure 1-14: Symbols in the COMMON-LISP package (part eleven of twelve). truncate values-list two-way-stream variable two-way-stream-input-stream vector two-way-stream-output-stream vector-pop type vector-push type-error vector-push-extend type-error-datum vectorp type-error-expected-type warn type-of warning typecase when typep wild-pathname-p unbound-slot with-accessors unbound-slot-instance with-compilation-unit unbound-variable with-condition-restarts undefined-function with-hash-table-iterator unexport with-input-from-string unintern with-open-file union with-open-stream unless with-output-to-string unread-char with-package-iterator unsigned-byte with-simple-restart untrace with-slots unuse-package with-standard-io-syntax unwind-protect write update-instance-for-different-class write-byte update-instance-for-redefined-class write-char upgraded-array-element-type write-line upgraded-complex-part-type write-sequence upper-case-p write-string use-package write-to-string use-value y-or-n-p user-homedir-pathname yes-or-no-p values zerop Figure 1-15: Symbols in the COMMON-LISP package (part twelve of twelve).  File: gcl.info, Node: Syntax, Next: Evaluation and Compilation, Prev: Introduction (Introduction), Up: Top 2 Syntax ******** * Menu: * Character Syntax:: * Reader Algorithm:: * Interpretation of Tokens:: * Standard Macro Characters::  File: gcl.info, Node: Character Syntax, Next: Reader Algorithm, Prev: Syntax, Up: Syntax 2.1 Character Syntax ==================== The Lisp reader takes characters from a stream, interprets them as a printed representation of an object, constructs that object, and returns it. The syntax described by this chapter is called the standard syntax . Operations are provided by Common Lisp so that various aspects of the syntax information represented by a readtable can be modified under program control; see *note Reader::. Except as explicitly stated otherwise, the syntax used throughout this document is standard syntax. * Menu: * Readtables:: * Variables that affect the Lisp Reader:: * Standard Characters:: * Character Syntax Types::  File: gcl.info, Node: Readtables, Next: Variables that affect the Lisp Reader, Prev: Character Syntax, Up: Character Syntax 2.1.1 Readtables ---------------- Syntax information for use by the Lisp reader is embodied in an object called a readtable . Among other things, the readtable contains the association between characters and syntax types. Figure 2-1 lists some defined names that are applicable to readtables. *readtable* readtable-case copy-readtable readtablep get-dispatch-macro-character set-dispatch-macro-character get-macro-character set-macro-character make-dispatch-macro-character set-syntax-from-char Figure 2-1: Readtable defined names * Menu: * The Current Readtable:: * The Standard Readtable:: * The Initial Readtable::  File: gcl.info, Node: The Current Readtable, Next: The Standard Readtable, Prev: Readtables, Up: Readtables 2.1.1.1 The Current Readtable ............................. Several readtables describing different syntaxes can exist, but at any given time only one, called the current readtable , affects the way in which expressions_2 are parsed into objects by the Lisp reader. The current readtable in a given dynamic environment is the value of *readtable* in that environment. To make a different readtable become the current readtable, *readtable* can be assigned or bound.  File: gcl.info, Node: The Standard Readtable, Next: The Initial Readtable, Prev: The Current Readtable, Up: Readtables 2.1.1.2 The Standard Readtable .............................. The standard readtable conforms to standard syntax. The consequences are undefined if an attempt is made to modify the standard readtable. To achieve the effect of altering or extending standard syntax, a copy of the standard readtable can be created; see the function copy-readtable. The readtable case of the standard readtable is :upcase.  File: gcl.info, Node: The Initial Readtable, Prev: The Standard Readtable, Up: Readtables 2.1.1.3 The Initial Readtable ............................. The initial readtable is the readtable that is the current readtable at the time when the Lisp image starts. At that time, it conforms to standard syntax. The initial readtable is distinct from the standard readtable. It is permissible for a conforming program to modify the initial readtable.  File: gcl.info, Node: Variables that affect the Lisp Reader, Next: Standard Characters, Prev: Readtables, Up: Character Syntax 2.1.2 Variables that affect the Lisp Reader ------------------------------------------- The Lisp reader is influenced not only by the current readtable, but also by various dynamic variables. Figure 2-2 lists the variables that influence the behavior of the Lisp reader. *package* *read-default-float-format* *readtable* *read-base* *read-suppress* Figure 2-2: Variables that influence the Lisp reader.  File: gcl.info, Node: Standard Characters, Next: Character Syntax Types, Prev: Variables that affect the Lisp Reader, Up: Character Syntax 2.1.3 Standard Characters ------------------------- All implementations must support a character repertoire called standard-char; characters that are members of that repertoire are called standard characters . The standard-char repertoire consists of the non-graphic character newline, the graphic character space, and the following additional ninety-four graphic characters or their equivalents: Graphic ID Glyph Description Graphic ID Glyph Description LA01 a small a LN01 n small n LA02 A capital A LN02 N capital N LB01 b small b LO01 o small o LB02 B capital B LO02 O capital O LC01 c small c LP01 p small p LC02 C capital C LP02 P capital P LD01 d small d LQ01 q small q LD02 D capital D LQ02 Q capital Q LE01 e small e LR01 r small r LE02 E capital E LR02 R capital R LF01 f small f LS01 s small s LF02 F capital F LS02 S capital S LG01 g small g LT01 t small t LG02 G capital G LT02 T capital T LH01 h small h LU01 u small u LH02 H capital H LU02 U capital U LI01 i small i LV01 v small v LI02 I capital I LV02 V capital V LJ01 j small j LW01 w small w LJ02 J capital J LW02 W capital W LK01 k small k LX01 x small x LK02 K capital K LX02 X capital X LL01 l small l LY01 y small y LL02 L capital L LY02 Y capital Y LM01 m small m LZ01 z small z LM02 M capital M LZ02 Z capital Z Figure 2-3: Standard Character Subrepertoire (Part 1 of 3: Latin Characters) Graphic ID Glyph Description Graphic ID Glyph Description ND01 1 digit 1 ND06 6 digit 6 ND02 2 digit 2 ND07 7 digit 7 ND03 3 digit 3 ND08 8 digit 8 ND04 4 digit 4 ND09 9 digit 9 ND05 5 digit 5 ND10 0 digit 0 Figure 2-4: Standard Character Subrepertoire (Part 2 of 3: Numeric Characters) Graphic ID Glyph Description SP02 ! exclamation mark SC03 $ dollar sign SP04 " quotation mark, or double quote SP05 ' apostrophe, or [single] quote SP06 ( left parenthesis, or open parenthesis SP07 ) right parenthesis, or close parenthesis SP08 , comma SP09 _ low line, or underscore SP10 - hyphen, or minus [sign] SP11 . full stop, period, or dot SP12 / solidus, or slash SP13 : colon SP14 ; semicolon SP15 ? question mark SA01 + plus [sign] SA03 < less-than [sign] SA04 = equals [sign] SA05 > greater-than [sign] SM01 # number sign, or sharp[sign] SM02 % percent [sign] SM03 & ampersand SM04 * asterisk, or star SM05 @ commercial at, or at-sign SM06 [ left [square] bracket SM07 \ reverse solidus, or backslash SM08 ] right [square] bracket SM11 { left curly bracket, or left brace SM13 | vertical bar SM14 } right curly bracket, or right brace SD13 ` grave accent, or backquote SD15 ^ circumflex accent SD19 ~ tilde Figure 2-5: Standard Character Subrepertoire (Part 3 of 3: Special Characters) The graphic IDs are not used within Common Lisp, but are provided for cross reference purposes with ISO 6937/2. Note that the first letter of the graphic ID categorizes the character as follows: L--Latin, N--Numeric, S--Special.  File: gcl.info, Node: Character Syntax Types, Prev: Standard Characters, Up: Character Syntax 2.1.4 Character Syntax Types ---------------------------- The Lisp reader constructs an object from the input text by interpreting each character according to its syntax type. The Lisp reader cannot accept as input everything that the Lisp printer produces, and the Lisp reader has features that are not used by the Lisp printer. The Lisp reader can be used as a lexical analyzer for a more general user-written parser. When the Lisp reader is invoked, it reads a single character from the input stream and dispatches according to the syntax type of that character. Every character that can appear in the input stream is of one of the syntax types shown in Figure~2-6. constituent macro character single escape invalid multiple escape whitespace_2 Figure 2-6: Possible Character Syntax Types The syntax type of a character in a readtable determines how that character is interpreted by the Lisp reader while that readtable is the current readtable. At any given time, every character has exactly one syntax type. Figure~2-7 lists the syntax type of each character in standard syntax. character syntax type character syntax type Backspace constituent 0-9 constituent Tab whitespace_2 : constituent Newline whitespace_2 ; terminating macro char Linefeed whitespace_2 < constituent Page whitespace_2 = constituent Return whitespace_2 > constituent Space whitespace_2 ? constituent* ! constituent* @ constituent " terminating macro char A-Z constituent # non-terminating macro char [ constituent* $ constituent \ single escape % constituent ] constituent* & constituent ^ constituent ' terminating macro char _ constituent ( terminating macro char ' terminating macro char ) terminating macro char a-z constituent * constituent { constituent* + constituent | multiple escape , terminating macro char } constituent* - constituent ~ constituent . constituent Rubout constituent / constituent Figure 2-7: Character Syntax Types in Standard Syntax The characters marked with an asterisk (*) are initially constituents, but they are not used in any standard Common Lisp notations. These characters are explicitly reserved to the programmer. ~ is not used in Common Lisp, and reserved to implementors. $ and % are alphabetic_2 characters, but are not used in the names of any standard Common Lisp defined names. Whitespace_2 characters serve as separators but are otherwise ignored. Constituent and escape characters are accumulated to make a token, which is then interpreted as a number or symbol. Macro characters trigger the invocation of functions (possibly user-supplied) that can perform arbitrary parsing actions. Macro characters are divided into two kinds, terminating and non-terminating, depending on whether or not they terminate a token. The following are descriptions of each kind of syntax type. * Menu: * Constituent Characters:: * Constituent Traits:: * Invalid Characters:: * Macro Characters:: * Multiple Escape Characters:: * Examples of Multiple Escape Characters:: * Single Escape Character:: * Examples of Single Escape Characters:: * Whitespace Characters:: * Examples of Whitespace Characters::  File: gcl.info, Node: Constituent Characters, Next: Constituent Traits, Prev: Character Syntax Types, Up: Character Syntax Types 2.1.4.1 Constituent Characters .............................. Constituent characters are used in tokens. A token is a representation of a number or a symbol. Examples of constituent characters are letters and digits. Letters in symbol names are sometimes converted to letters in the opposite case when the name is read; see *note Effect of Readtable Case on the Lisp Reader::. Case conversion can be suppressed by the use of single escape or multiple escape characters.  File: gcl.info, Node: Constituent Traits, Next: Invalid Characters, Prev: Constituent Characters, Up: Character Syntax Types 2.1.4.2 Constituent Traits .......................... Every character has one or more constituent traits that define how the character is to be interpreted by the Lisp reader when the character is a constituent character. These constituent traits are alphabetic_2, digit, package marker, plus sign, minus sign, dot, decimal point, ratio marker, exponent marker, and invalid. Figure~2-8 shows the constituent traits of the standard characters and of certain semi-standard characters; no mechanism is provided for changing the constituent trait of a character. Any character with the alphadigit constituent trait in that figure is a digit if the current input base is greater than that character's digit value, otherwise the character is alphabetic_2. Any character quoted by a single escape is treated as an alphabetic_2 constituent, regardless of its normal syntax. constituent traits constituent traits character character ________________________________________________________________________________ Backspace invalid { alphabetic_2 Tab invalid* } alphabetic_2 Newline invalid* + alphabetic_2, plus sign Linefeed invalid* - alphabetic_2, minus sign Page invalid* . alphabetic_2, dot, decimal point Return invalid* / alphabetic_2, ratio marker Space invalid* A, a alphadigit ! alphabetic_2 B, b alphadigit " alphabetic_2* C, c alphadigit # alphabetic_2* D, d alphadigit, double-float exponent marker $ alphabetic_2 E, e alphadigit, float exponent marker % alphabetic_2 F, f alphadigit, single-float exponent marker & alphabetic_2 G, g alphadigit ' alphabetic_2* H, h alphadigit ( alphabetic_2* I, i alphadigit ) alphabetic_2* J, j alphadigit * alphabetic_2 K, k alphadigit , alphabetic_2* L, l alphadigit, long-float exponent marker 0-9 alphadigit M, m alphadigit : package marker N, n alphadigit ; alphabetic_2* O, o alphadigit < alphabetic_2 P, p alphadigit = alphabetic_2 Q, q alphadigit > alphabetic_2 R, r alphadigit ? alphabetic_2 S, s alphadigit, short-float exponent marker @ alphabetic_2 T, t alphadigit [ alphabetic_2 U, u alphadigit \ alphabetic_2* V, v alphadigit ] alphabetic_2 W, w alphadigit ^ alphabetic_2 X, x alphadigit _ alphabetic_2 Y, y alphadigit ' alphabetic_2* Z, z alphadigit | alphabetic_2* Rubout invalid ~ alphabetic_2 Figure 2-8: Constituent Traits of Standard Characters and Semi-Standard Characters The interpretations in this table apply only to characters whose syntax type is constituent. Entries marked with an asterisk (*) are normally shadowed_2 because the indicated characters are of syntax type whitespace_2, macro character, single escape, or multiple escape; these constituent traits apply to them only if their syntax types are changed to constituent.  File: gcl.info, Node: Invalid Characters, Next: Macro Characters, Prev: Constituent Traits, Up: Character Syntax Types 2.1.4.3 Invalid Characters .......................... Characters with the constituent trait invalid cannot ever appear in a token except under the control of a single escape character. If an invalid character is encountered while an object is being read, an error of type reader-error is signaled. If an invalid character is preceded by a single escape character, it is treated as an alphabetic_2 constituent instead.  File: gcl.info, Node: Macro Characters, Next: Multiple Escape Characters, Prev: Invalid Characters, Up: Character Syntax Types 2.1.4.4 Macro Characters ........................ When the Lisp reader encounters a macro character on an input stream, special parsing of subsequent characters on the input stream is performed. A macro character has an associated function called a reader macro function that implements its specialized parsing behavior. An association of this kind can be established or modified under control of a conforming program by using the functions set-macro-character and set-dispatch-macro-character. Upon encountering a macro character, the Lisp reader calls its reader macro function, which parses one specially formatted object from the input stream. The function either returns the parsed object, or else it returns no values to indicate that the characters scanned by the function are being ignored (e.g., in the case of a comment). Examples of macro characters are backquote, single-quote, left-parenthesis, and right-parenthesis. A macro character is either terminating or non-terminating. The difference between terminating and non-terminating macro characters lies in what happens when such characters occur in the middle of a token. If a non-terminating macro character occurs in the middle of a token, the function associated with the non-terminating macro character is not called, and the non-terminating macro character does not terminate the token's name; it becomes part of the name as if the macro character were really a constituent character. A terminating macro character terminates any token, and its associated reader macro function is called no matter where the character appears. The only non-terminating macro character in standard syntax is sharpsign. If a character is a dispatching macro character C_1, its reader macro function is a function supplied by the implementation. This function reads decimal digit characters until a non-digit C_2 is read. If any digits were read, they are converted into a corresponding integer infix parameter P; otherwise, the infix parameter P is nil. The terminating non-digit C_2 is a character (sometimes called a "sub-character" to emphasize its subordinate role in the dispatching) that is looked up in the dispatch table associated with the dispatching macro character C_1. The reader macro function associated with the sub-character C_2 is invoked with three arguments: the stream, the sub-character C_2, and the infix parameter P. For more information about dispatch characters, see the function set-dispatch-macro-character. For information about the macro characters that are available in standard syntax, see *note Standard Macro Characters::.  File: gcl.info, Node: Multiple Escape Characters, Next: Examples of Multiple Escape Characters, Prev: Macro Characters, Up: Character Syntax Types 2.1.4.5 Multiple Escape Characters .................................. A pair of multiple escape characters is used to indicate that an enclosed sequence of characters, including possible macro characters and whitespace_2 characters, are to be treated as alphabetic_2 characters with case preserved. Any single escape and multiple escape characters that are to appear in the sequence must be preceded by a single escape character. Vertical-bar is a multiple escape character in standard syntax.  File: gcl.info, Node: Examples of Multiple Escape Characters, Next: Single Escape Character, Prev: Multiple Escape Characters, Up: Character Syntax Types 2.1.4.6 Examples of Multiple Escape Characters .............................................. ;; The following examples assume the readtable case of *readtable* ;; and *print-case* are both :upcase. (eq 'abc 'ABC) => true (eq 'abc '|ABC|) => true (eq 'abc 'a|B|c) => true (eq 'abc '|abc|) => false  File: gcl.info, Node: Single Escape Character, Next: Examples of Single Escape Characters, Prev: Examples of Multiple Escape Characters, Up: Character Syntax Types 2.1.4.7 Single Escape Character ............................... A single escape is used to indicate that the next character is to be treated as an alphabetic_2 character with its case preserved, no matter what the character is or which constituent traits it has. Slash is a single escape character in standard syntax.  File: gcl.info, Node: Examples of Single Escape Characters, Next: Whitespace Characters, Prev: Single Escape Character, Up: Character Syntax Types 2.1.4.8 Examples of Single Escape Characters ............................................ ;; The following examples assume the readtable case of *readtable* ;; and *print-case* are both :upcase. (eq 'abc '\A\B\C) => true (eq 'abc 'a\Bc) => true (eq 'abc '\ABC) => true (eq 'abc '\abc) => false  File: gcl.info, Node: Whitespace Characters, Next: Examples of Whitespace Characters, Prev: Examples of Single Escape Characters, Up: Character Syntax Types 2.1.4.9 Whitespace Characters ............................. Whitespace_2 characters are used to separate tokens. Space and newline are whitespace_2 characters in standard syntax.  File: gcl.info, Node: Examples of Whitespace Characters, Prev: Whitespace Characters, Up: Character Syntax Types 2.1.4.10 Examples of Whitespace Characters .......................................... (length '(this-that)) => 1 (length '(this - that)) => 3 (length '(a b)) => 2 (+ 34) => 34 (+ 3 4) => 7  File: gcl.info, Node: Reader Algorithm, Next: Interpretation of Tokens, Prev: Character Syntax, Up: Syntax 2.2 Reader Algorithm ==================== This section describes the algorithm used by the Lisp reader to parse objects from an input character stream, including how the Lisp reader processes macro characters. When dealing with tokens, the reader's basic function is to distinguish representations of symbols from those of numbers. When a token is accumulated, it is assumed to represent a number if it satisfies the syntax for numbers listed in Figure~2-9. If it does not represent a number, it is then assumed to be a potential number if it satisfies the rules governing the syntax for a potential number. If a valid token is neither a representation of a number nor a potential number, it represents a symbol. The algorithm performed by the Lisp reader is as follows: 1. If at end of file, end-of-file processing is performed as specified in read. Otherwise, one character, x, is read from the input stream, and dispatched according to the syntax type of x to one of steps 2 to 7. 2. If x is an invalid character, an error of type reader-error is signaled. 3. If x is a whitespace_2 character, then it is discarded and step 1 is re-entered. 4. If x is a terminating or non-terminating macro character then its associated reader macro function is called with two arguments, the input stream and x. The reader macro function may read characters from the input stream; if it does, it will see those characters following the macro character. The Lisp reader may be invoked recursively from the reader macro function. The reader macro function must not have any side effects other than on the input stream; because of backtracking and restarting of the read operation, front ends to the Lisp reader (e.g., "editors" and "rubout handlers") may cause the reader macro function to be called repeatedly during the reading of a single expression in which x only appears once. The reader macro function may return zero values or one value. If one value is returned, then that value is returned as the result of the read operation; the algorithm is done. If zero values are returned, then step 1 is re-entered. 5. If x is a single escape character then the next character, y, is read, or an error of type end-of-file is signaled if at the end of file. y is treated as if it is a constituent whose only constituent trait is alphabetic_2. y is used to begin a token, and step 8 is entered. 6. If x is a multiple escape character then a token (initially containing no characters) is begun and step 9 is entered. 7. If x is a constituent character, then it begins a token. After the token is read in, it will be interpreted either as a Lisp object or as being of invalid syntax. If the token represents an object, that object is returned as the result of the read operation. If the token is of invalid syntax, an error is signaled. If x is a character with case, it might be replaced with the corresponding character of the opposite case, depending on the readtable case of the current readtable, as outlined in *note Effect of Readtable Case on the Lisp Reader::. X is used to begin a token, and step 8 is entered. 8. At this point a token is being accumulated, and an even number of multiple escape characters have been encountered. If at end of file, step 10 is entered. Otherwise, a character, y, is read, and one of the following actions is performed according to its syntax type: * If y is a constituent or non-terminating macro character: - If y is a character with case, it might be replaced with the corresponding character of the opposite case, depending on the readtable case of the current readtable, as outlined in *note Effect of Readtable Case on the Lisp Reader::. - Y is appended to the token being built. - Step 8 is repeated. * If y is a single escape character, then the next character, z, is read, or an error of type end-of-file is signaled if at end of file. Z is treated as if it is a constituent whose only constituent trait is alphabetic_2. Z is appended to the token being built, and step 8 is repeated. * If y is a multiple escape character, then step 9 is entered. * If y is an invalid character, an error of type reader-error is signaled. * If y is a terminating macro character, then it terminates the token. First the character y is unread (see unread-char), and then step 10 is entered. * If y is a whitespace_2 character, then it terminates the token. First the character y is unread if appropriate (see read-preserving-whitespace), and then step 10 is entered. 9. At this point a token is being accumulated, and an odd number of multiple escape characters have been encountered. If at end of file, an error of type end-of-file is signaled. Otherwise, a character, y, is read, and one of the following actions is performed according to its syntax type: * If y is a constituent, macro, or whitespace_2 character, y is treated as a constituent whose only constituent trait is alphabetic_2. Y is appended to the token being built, and step 9 is repeated. * If y is a single escape character, then the next character, z, is read, or an error of type end-of-file is signaled if at end of file. Z is treated as a constituent whose only constituent trait is alphabetic_2. Z is appended to the token being built, and step 9 is repeated. * If y is a multiple escape character, then step 8 is entered. * If y is an invalid character, an error of type reader-error is signaled. 10. An entire token has been accumulated. The object represented by the token is returned as the result of the read operation, or an error of type reader-error is signaled if the token is not of valid syntax.  File: gcl.info, Node: Interpretation of Tokens, Next: Standard Macro Characters, Prev: Reader Algorithm, Up: Syntax 2.3 Interpretation of Tokens ============================ * Menu: * Numbers as Tokens:: * Constructing Numbers from Tokens:: * The Consing Dot:: * Symbols as Tokens:: * Valid Patterns for Tokens:: * Package System Consistency Rules::  File: gcl.info, Node: Numbers as Tokens, Next: Constructing Numbers from Tokens, Prev: Interpretation of Tokens, Up: Interpretation of Tokens 2.3.1 Numbers as Tokens ----------------------- When a token is read, it is interpreted as a number or symbol. The token is interpreted as a number if it satisfies the syntax for numbers specified in Figure 2-9. numeric-token ::= !integer | !ratio | !float integer ::= [sign] {decimal-digit}^+ decimal-point | [sign] {digit}^+ ratio ::= [sign] {digit}^+ slash {digit}^+ float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}^+ [!exponent] | [sign] {decimal-digit}^+ [decimal-point {decimal-digit}*] !exponent exponent ::= exponent-marker [sign] {digit}^+ sign--a sign. slash--a slash decimal-point--a dot. exponent-marker--an exponent marker. decimal-digit--a digit in radix 10. digit--a digit in the current input radix. Figure 2-9: Syntax for Numeric Tokens * Menu: * Potential Numbers as Tokens:: * Escape Characters and Potential Numbers:: * Examples of Potential Numbers::  File: gcl.info, Node: Potential Numbers as Tokens, Next: Escape Characters and Potential Numbers, Prev: Numbers as Tokens, Up: Numbers as Tokens 2.3.1.1 Potential Numbers as Tokens ................................... To allow implementors and future Common Lisp standards to extend the syntax of numbers, a syntax for potential numbers is defined that is more general than the syntax for numbers. A token is a potential number if it satisfies all of the following requirements: 1. The token consists entirely of digits, signs, ratio markers, decimal points (.), extension characters (^ or _), and number markers. A number marker is a letter. Whether a letter may be treated as a number marker depends on context, but no letter that is adjacent to another letter may ever be treated as a number marker. Exponent markers are number markers. 2. The token contains at least one digit. Letters may be considered to be digits, depending on the current input base, but only in tokens containing no decimal points. 3. The token begins with a digit, sign, decimal point, or extension character, [Reviewer Note by Barmar: This section is unnecessary because the first bullet already omits discussion of a colon (package marker).] but not a package marker. The syntax involving a leading package marker followed by a potential number is not well-defined. The consequences of the use of notation such as :1, :1/2, and :2^3 in a position where an expression appropriate for read is expected are unspecified. 4. The token does not end with a sign. If a potential number has number syntax, a number of the appropriate type is constructed and returned, if the number is representable in an implementation. A number will not be representable in an implementation if it is outside the boundaries set by the implementation-dependent constants for numbers. For example, specifying too large or too small an exponent for a float may make the number impossible to represent in the implementation. A ratio with denominator zero (such as -35/000) is not represented in any implementation. When a token with the syntax of a number cannot be converted to an internal number, an error of type reader-error is signaled. An error must not be signaled for specifying too many significant digits for a float; a truncated or rounded value should be produced. If there is an ambiguity as to whether a letter should be treated as a digit or as a number marker, the letter is treated as a digit.  File: gcl.info, Node: Escape Characters and Potential Numbers, Next: Examples of Potential Numbers, Prev: Potential Numbers as Tokens, Up: Numbers as Tokens 2.3.1.2 Escape Characters and Potential Numbers ............................................... A potential number cannot contain any escape characters. An escape character robs the following character of all syntactic qualities, forcing it to be strictly alphabetic_2 and therefore unsuitable for use in a potential number. For example, all of the following representations are interpreted as symbols, not numbers: \256 25\64 1.0\E6 |100| 3\.14159 |3/4| 3\/4 5|| In each case, removing the escape character (or characters) would cause the token to be a potential number.  File: gcl.info, Node: Examples of Potential Numbers, Prev: Escape Characters and Potential Numbers, Up: Numbers as Tokens 2.3.1.3 Examples of Potential Numbers ..................................... As examples, the tokens in Figure 2-10 are potential numbers, but they are not actually numbers, and so are reserved tokens; a conforming implementation is permitted, but not required, to define their meaning. 1b5000 777777q 1.7J -3/4+6.7J 12/25/83 27^19 3^4/5 6//7 3.1.2.6 ^-43^ 3.141_592_653_589_793_238_4 -3.7+2.6i-6.17j+19.6k Figure 2-10: Examples of reserved tokens The tokens in Figure 2-11 are not potential numbers; they are always treated as symbols: / /5 + 1+ 1- foo+ ab.cd _ ^ ^/- Figure 2-11: Examples of symbols The tokens in Figure 2-12 are potential numbers if the current input base is 16, but they are always treated as symbols if the current input base is 10. bad-face 25-dec-83 a/b fad_cafe f^ Figure 2-12: Examples of symbols or potential numbers  File: gcl.info, Node: Constructing Numbers from Tokens, Next: The Consing Dot, Prev: Numbers as Tokens, Up: Interpretation of Tokens 2.3.2 Constructing Numbers from Tokens -------------------------------------- A real is constructed directly from a corresponding numeric token; see Figure~2-9. A complex is notated as a #C (or #c) followed by a list of two reals; see *note Sharpsign C::. The reader macros #B, #O, #X, and #R may also be useful in controlling the input radix in which rationals are parsed; see *note Sharpsign B::, *note Sharpsign O::, *note Sharpsign X::, and *note Sharpsign R::. This section summarizes the full syntax for numbers. * Menu: * Syntax of a Rational:: * Syntax of an Integer:: * Syntax of a Ratio:: * Syntax of a Float:: * Syntax of a Complex::  File: gcl.info, Node: Syntax of a Rational, Next: Syntax of an Integer, Prev: Constructing Numbers from Tokens, Up: Constructing Numbers from Tokens 2.3.2.1 Syntax of a Rational ............................  File: gcl.info, Node: Syntax of an Integer, Next: Syntax of a Ratio, Prev: Syntax of a Rational, Up: Constructing Numbers from Tokens 2.3.2.2 Syntax of an Integer ............................ Integers can be written as a sequence of digits, optionally preceded by a sign and optionally followed by a decimal point; see Figure~2-9. When a decimal point is used, the digits are taken to be in radix 10; when no decimal point is used, the digits are taken to be in radix given by the current input base. For information on how integers are printed, see *note Printing Integers::.  File: gcl.info, Node: Syntax of a Ratio, Next: Syntax of a Float, Prev: Syntax of an Integer, Up: Constructing Numbers from Tokens 2.3.2.3 Syntax of a Ratio ......................... Ratios can be written as an optional sign followed by two non-empty sequences of digits separated by a slash; see Figure~2-9. The second sequence may not consist entirely of zeros. Examples of ratios are in Figure 2-13. 2/3 ;This is in canonical form 4/6 ;A non-canonical form for 2/3 -17/23 ;A ratio preceded by a sign -30517578125/32768 ;This is (-5/2)^15 10/5 ;The canonical form for this is 2 #o-101/75 ;Octal notation for -65/61 #3r120/21 ;Ternary notation for 15/7 #Xbc/ad ;Hexadecimal notation for 188/173 #xFADED/FACADE ;Hexadecimal notation for 1027565/16435934 Figure 2-13: Examples of Ratios [Reviewer Note by Barmar: #o, #3r, #X, and #x mentioned above are not in the syntax rules defined just above that.] For information on how ratios are printed, see *note Printing Ratios::.  File: gcl.info, Node: Syntax of a Float, Next: Syntax of a Complex, Prev: Syntax of a Ratio, Up: Constructing Numbers from Tokens 2.3.2.4 Syntax of a Float ......................... Floats can be written in either decimal fraction or computerized scientific notation: an optional sign, then a non-empty sequence of digits with an embedded decimal point, then an optional decimal exponent specification. If there is no exponent specifier, then the decimal point is required, and there must be digits after it. The exponent specifier consists of an exponent marker, an optional sign, and a non-empty sequence of digits. If no exponent specifier is present, or if the exponent marker e (or E) is used, then the format specified by *read-default-float-format* is used. See Figure~2-9. An implementation may provide one or more kinds of float that collectively make up the type float. The letters s, f, d, and l (or their respective uppercase equivalents) explicitly specify the use of the types short-float, single-float, double-float, and long-float, respectively. The internal format used for an external representation depends only on the exponent marker, and not on the number of decimal digits in the external representation. Figure 2-14 contains examples of notations for floats: 0.0 ;Floating-point zero in default format 0E0 ;As input, this is also floating-point zero in default format. ;As output, this would appear as 0.0. 0e0 ;As input, this is also floating-point zero in default format. ;As output, this would appear as 0.0. -.0 ;As input, this might be a zero or a minus zero, ; depending on whether the implementation supports ; a distinct minus zero. ;As output, 0.0 is zero and -0.0 is minus zero. 0. ;On input, the integer zero--not a floating-point number! ;Whether this appears as 0 or 0. on output depends ;on the value of *print-radix*. 0.0s0 ;A floating-point zero in short format 0s0 ;As input, this is a floating-point zero in short format. ;As output, such a zero would appear as 0.0s0 ; (or as 0.0 if short-float was the default format). 6.02E+23 ;Avogadro's number, in default format 602E+21 ;Also Avogadro's number, in default format Figure 2-14: Examples of Floating-point numbers For information on how floats are printed, see *note Printing Floats::.  File: gcl.info, Node: Syntax of a Complex, Prev: Syntax of a Float, Up: Constructing Numbers from Tokens 2.3.2.5 Syntax of a Complex ........................... A complex has a Cartesian structure, with a real part and an imaginary part each of which is a real. The parts of a complex are not necessarily floats but both parts must be of the same type: [Editorial Note by KMP: This is not the same as saying they must be the same type. Maybe we mean they are of the same 'precision' or 'format'? GLS had suggestions which are not yet merged.] either both are rationals, or both are of the same float subtype. When constructing a complex, if the specified parts are not the same type, the parts are converted to be the same type internally (i.e., the rational part is converted to a float). An object of type (complex rational) is converted internally and represented thereafter as a rational if its imaginary part is an integer whose value is 0. For further information, see *note Sharpsign C:: and *note Printing Complexes::.  File: gcl.info, Node: The Consing Dot, Next: Symbols as Tokens, Prev: Constructing Numbers from Tokens, Up: Interpretation of Tokens 2.3.3 The Consing Dot --------------------- If a token consists solely of dots (with no escape characters), then an error of type reader-error is signaled, except in one circumstance: if the token is a single dot and appears in a situation where dotted pair notation permits a dot, then it is accepted as part of such syntax and no error is signaled. See *note Left-Parenthesis::.  File: gcl.info, Node: Symbols as Tokens, Next: Valid Patterns for Tokens, Prev: The Consing Dot, Up: Interpretation of Tokens 2.3.4 Symbols as Tokens ----------------------- Any token that is not a potential number, does not contain a package marker, and does not consist entirely of dots will always be interpreted as a symbol. Any token that is a potential number but does not fit the number syntax is a reserved token and has an implementation-dependent interpretation. In all other cases, the token is construed to be the name of a symbol. Examples of the printed representation of symbols are in Figure 2-15. For presentational simplicity, these examples assume that the readtable case of the current readtable is :upcase. FROBBOZ The symbol whose name is FROBBOZ. frobboz Another way to notate the same symbol. fRObBoz Yet another way to notate it. unwind-protect A symbol with a hyphen in its name. +$ The symbol named +$. 1+ The symbol named 1+. +1 This is the integer 1, not a symbol. pascal_style This symbol has an underscore in its name. file.rel.43 This symbol has periods in its name. \( The symbol whose name is (. \+1 The symbol whose name is +1. +\1 Also the symbol whose name is +1. \frobboz The symbol whose name is fROBBOZ. 3.14159265\s0 The symbol whose name is 3.14159265s0. 3.14159265\S0 A different symbol, whose name is 3.14159265S0. 3.14159265s0 A possible short float approximation to \pi. Figure 2-15: Examples of the printed representation of symbols (Part 1 of 2) APL\\360 The symbol whose name is APL\360. apl\\360 Also the symbol whose name is APL\360. \(b^2\)\ -\ 4*a*c The name is (B^2) - 4*A*C. Parentheses and two spaces in it. \(\b^2\)\ -\4*\a*\c The name is (b^2) - 4*a*c. Letters explicitly lowercase. |"| The same as writing \". |(b^2) - 4*a*c| The name is (b^2) - 4*a*c. |frobboz| The name is frobboz, not FROBBOZ. |APL\360| The name is APL360. |APL\\360| The name is APL\360. |apl\\360| The name is apl\360. |\|\|| Same as \|\| --the name is ||. |(B^2) - 4*A*C| The name is (B^2) - 4*A*C. Parentheses and two spaces in it. |(b^2) - 4*a*c| The name is (b^2) - 4*a*c. Figure 2-16: Examples of the printed representation of symbols (Part 2 of 2) In the process of parsing a symbol, it is implementation-dependent which implementation-defined attributes are removed from the characters forming a token that represents a symbol. When parsing the syntax for a symbol, the Lisp reader looks up the name of that symbol in the current package. This lookup may involve looking in other packages whose external symbols are inherited by the current package. If the name is found, the corresponding symbol is returned. If the name is not found (that is, there is no symbol of that name accessible in the current package), a new symbol is created and is placed in the current package as an internal symbol. The current package becomes the owner (home package) of the symbol, and the symbol becomes interned in the current package. If the name is later read again while this same package is current, the same symbol will be found and returned.  File: gcl.info, Node: Valid Patterns for Tokens, Next: Package System Consistency Rules, Prev: Symbols as Tokens, Up: Interpretation of Tokens 2.3.5 Valid Patterns for Tokens ------------------------------- The valid patterns for tokens are summarized in Figure 2-17. nnnnn a number xxxxx a symbol in the current package :xxxxx a symbol in the the KEYWORD package ppppp:xxxxx an external symbol in the ppppp package ppppp::xxxxx a (possibly internal) symbol in the ppppp package :nnnnn undefined ppppp:nnnnn undefined ppppp::nnnnn undefined ::aaaaa undefined aaaaa: undefined aaaaa:aaaaa:aaaaa undefined Figure 2-17: Valid patterns for tokens Note that nnnnn has number syntax, neither xxxxx nor ppppp has number syntax, and aaaaa has any syntax. A summary of rules concerning package markers follows. In each case, examples are offered to illustrate the case; for presentational simplicity, the examples assume that the readtable case of the current readtable is :upcase. 1. If there is a single package marker, and it occurs at the beginning of the token, then the token is interpreted as a symbol in the KEYWORD package. It also sets the symbol-value of the newly-created symbol to that same symbol so that the symbol will self-evaluate. For example, :bar, when read, interns BAR as an external symbol in the KEYWORD package. 2. If there is a single package marker not at the beginning or end of the token, then it divides the token into two parts. The first part specifies a package; the second part is the name of an external symbol available in that package. For example, foo:bar, when read, looks up BAR among the external symbols of the package named FOO. 3. If there are two adjacent package markers not at the beginning or end of the token, then they divide the token into two parts. The first part specifies a package; the second part is the name of a symbol within that package (possibly an internal symbol). For example, foo::bar, when read, interns BAR in the package named FOO. 4. If the token contains no package markers, and does not have potential number syntax, then the entire token is the name of the symbol. The symbol is looked up in the current package. For example, bar, when read, interns BAR in the current package. 5. The consequences are unspecified if any other pattern of package markers in a token is used. All other uses of package markers within names of symbols are not defined by this standard but are reserved for implementation-dependent use. For example, assuming the readtable case of the current readtable is :upcase, editor:buffer refers to the external symbol named BUFFER present in the package named editor, regardless of whether there is a symbol named BUFFER in the current package. If there is no package named editor, or if no symbol named BUFFER is present in editor, or if BUFFER is not exported by editor, the reader signals a correctable error. If editor::buffer is seen, the effect is exactly the same as reading buffer with the EDITOR package being the current package.  File: gcl.info, Node: Package System Consistency Rules, Prev: Valid Patterns for Tokens, Up: Interpretation of Tokens 2.3.6 Package System Consistency Rules -------------------------------------- The following rules apply to the package system as long as the value of *package* is not changed: Read-read consistency Reading the same symbol name always results in the same symbol. Print-read consistency An interned symbol always prints as a sequence of characters that, when read back in, yields the same symbol. For information about how the Lisp printer treats symbols, see *note Printing Symbols::. Print-print consistency If two interned symbols are not the same, then their printed representations will be different sequences of characters. These rules are true regardless of any implicit interning. As long as the current package is not changed, results are reproducible regardless of the order of loading files or the exact history of what symbols were typed in when. If the value of *package* is changed and then changed back to the previous value, consistency is maintained. The rules can be violated by changing the value of *package*, forcing a change to symbols or to packages or to both by continuing from an error, or calling one of the following functions: unintern, unexport, shadow, shadowing-import, or unuse-package. An inconsistency only applies if one of the restrictions is violated between two of the named symbols. shadow, unexport, unintern, and shadowing-import can only affect the consistency of symbols with the same names (under string=) as the ones supplied as arguments.  File: gcl.info, Node: Standard Macro Characters, Prev: Interpretation of Tokens, Up: Syntax 2.4 Standard Macro Characters ============================= If the reader encounters a macro character, then its associated reader macro function is invoked and may produce an object to be returned. This function may read the characters following the macro character in the stream in any syntax and return the object represented by that syntax. Any character can be made to be a macro character. The macro characters defined initially in a conforming implementation include the following: * Menu: * Left-Parenthesis:: * Right-Parenthesis:: * Single-Quote:: * Semicolon:: * Double-Quote:: * Backquote:: * Comma:: * Sharpsign:: * Re-Reading Abbreviated Expressions::  File: gcl.info, Node: Left-Parenthesis, Next: Right-Parenthesis, Prev: Standard Macro Characters, Up: Standard Macro Characters 2.4.1 Left-Parenthesis ---------------------- The left-parenthesis initiates reading of a list. read is called recursively to read successive objects until a right parenthesis is found in the input stream. A list of the objects read is returned. Thus (a b c) is read as a list of three objects (the symbols a, b, and c). The right parenthesis need not immediately follow the printed representation of the last object; whitespace_2 characters and comments may precede it. If no objects precede the right parenthesis, it reads as a list of zero objects (the empty list). If a token that is just a dot not immediately preceded by an escape character is read after some object then exactly one more object must follow the dot, possibly preceded or followed by whitespace_2 or a comment, followed by the right parenthesis: (a b c . d) This means that the cdr of the last cons in the list is not nil, but rather the object whose representation followed the dot. The above example might have been the result of evaluating (cons 'a (cons 'b (cons 'c 'd))) Similarly, (cons 'this-one 'that-one) => (this-one . that-one) It is permissible for the object following the dot to be a list: (a b c d . (e f . (g))) == (a b c d e f g) For information on how the Lisp printer prints lists and conses, see *note Printing Lists and Conses::.  File: gcl.info, Node: Right-Parenthesis, Next: Single-Quote, Prev: Left-Parenthesis, Up: Standard Macro Characters 2.4.2 Right-Parenthesis ----------------------- The right-parenthesis is invalid except when used in conjunction with the left parenthesis character. For more information, see *note Reader Algorithm::.  File: gcl.info, Node: Single-Quote, Next: Semicolon, Prev: Right-Parenthesis, Up: Standard Macro Characters 2.4.3 Single-Quote ------------------ Syntax: '<> A single-quote introduces an expression to be "quoted." Single-quote followed by an expression exp is treated by the Lisp reader as an abbreviation for and is parsed identically to the expression (quote exp). See the special operator quote. * Menu: * Examples of Single-Quote::  File: gcl.info, Node: Examples of Single-Quote, Prev: Single-Quote, Up: Single-Quote 2.4.3.1 Examples of Single-Quote ................................ 'foo => FOO ''foo => (QUOTE FOO) (car ''foo) => QUOTE  File: gcl.info, Node: Semicolon, Next: Double-Quote, Prev: Single-Quote, Up: Standard Macro Characters 2.4.4 Semicolon --------------- Syntax: ;<> A semicolon introduces characters that are to be ignored, such as comments. The semicolon and all characters up to and including the next newline or end of file are ignored. * Menu: * Examples of Semicolon:: * Notes about Style for Semicolon:: * Use of Single Semicolon:: * Use of Double Semicolon:: * Use of Triple Semicolon:: * Use of Quadruple Semicolon:: * Examples of Style for Semicolon::  File: gcl.info, Node: Examples of Semicolon, Next: Notes about Style for Semicolon, Prev: Semicolon, Up: Semicolon 2.4.4.1 Examples of Semicolon ............................. (+ 3 ; three 4) => 7  File: gcl.info, Node: Notes about Style for Semicolon, Next: Use of Single Semicolon, Prev: Examples of Semicolon, Up: Semicolon 2.4.4.2 Notes about Style for Semicolon ....................................... Some text editors make assumptions about desired indentation based on the number of semicolons that begin a comment. The following style conventions are common, although not by any means universal.  File: gcl.info, Node: Use of Single Semicolon, Next: Use of Double Semicolon, Prev: Notes about Style for Semicolon, Up: Semicolon 2.4.4.3 Use of Single Semicolon ............................... Comments that begin with a single semicolon are all aligned to the same column at the right (sometimes called the "comment column"). The text of such a comment generally applies only to the line on which it appears. Occasionally two or three contain a single sentence together; this is sometimes indicated by indenting all but the first with an additional space (after the semicolon).  File: gcl.info, Node: Use of Double Semicolon, Next: Use of Triple Semicolon, Prev: Use of Single Semicolon, Up: Semicolon 2.4.4.4 Use of Double Semicolon ............................... Comments that begin with a double semicolon are all aligned to the same level of indentation as a form would be at that same position in the code. The text of such a comment usually describes the state of the program at the point where the comment occurs, the code which follows the comment, or both.  File: gcl.info, Node: Use of Triple Semicolon, Next: Use of Quadruple Semicolon, Prev: Use of Double Semicolon, Up: Semicolon 2.4.4.5 Use of Triple Semicolon ............................... Comments that begin with a triple semicolon are all aligned to the left margin. Usually they are used prior to a definition or set of definitions, rather than within a definition.  File: gcl.info, Node: Use of Quadruple Semicolon, Next: Examples of Style for Semicolon, Prev: Use of Triple Semicolon, Up: Semicolon 2.4.4.6 Use of Quadruple Semicolon .................................. Comments that begin with a quadruple semicolon are all aligned to the left margin, and generally contain only a short piece of text that serve as a title for the code which follows, and might be used in the header or footer of a program that prepares code for presentation as a hardcopy document.  File: gcl.info, Node: Examples of Style for Semicolon, Prev: Use of Quadruple Semicolon, Up: Semicolon 2.4.4.7 Examples of Style for Semicolon ....................................... ;;;; Math Utilities ;;; FIB computes the the Fibonacci function in the traditional ;;; recursive way. (defun fib (n) (check-type n integer) ;; At this point we're sure we have an integer argument. ;; Now we can get down to some serious computation. (cond ((< n 0) ;; Hey, this is just supposed to be a simple example. ;; Did you really expect me to handle the general case? (error "FIB got ~D as an argument." n)) ((< n 2) n) ;fib[0]=0 and fib[1]=1 ;; The cheap cases didn't work. ;; Nothing more to do but recurse. (t (+ (fib (- n 1)) ;The traditional formula (fib (- n 2)))))) ; is fib[n-1]+fib[n-2].  File: gcl.info, Node: Double-Quote, Next: Backquote, Prev: Semicolon, Up: Standard Macro Characters 2.4.5 Double-Quote ------------------ Syntax: "<>" The double-quote is used to begin and end a string. When a double-quote is encountered, characters are read from the input stream and accumulated until another double-quote is encountered. If a single escape character is seen, the single escape character is discarded, the next character is accumulated, and accumulation continues. The accumulated characters up to but not including the matching double-quote are made into a simple string and returned. It is implementation-dependent which attributes of the accumulated characters are removed in this process. Examples of the use of the double-quote character are in Figure 2-18. "Foo" ;A string with three characters in it "" ;An empty string "\"APL\\360?\" he cried." ;A string with twenty characters "|x| = |-x|" ;A ten-character string Figure 2-18: Examples of the use of double-quote Note that to place a single escape character or a double-quote into a string, such a character must be preceded by a single escape character. Note, too, that a multiple escape character need not be quoted by a single escape character within a string. For information on how the Lisp printer prints strings, see *note Printing Strings::.  File: gcl.info, Node: Backquote, Next: Comma, Prev: Double-Quote, Up: Standard Macro Characters 2.4.6 Backquote --------------- The backquote introduces a template of a data structure to be built. For example, writing `(cond ((numberp ,x) ,@y) (t (print ,x) ,@y)) is roughly equivalent to writing (list 'cond (cons (list 'numberp x) y) (list* 't (list 'print x) y)) Where a comma occurs in the template, the expression following the comma is to be evaluated to produce an object to be inserted at that point. Assume b has the value 3, for example, then evaluating the form denoted by `(a b ,b ,(+ b 1) b) produces the result (a b 3 4 b). If a comma is immediately followed by an at-sign, then the form following the at-sign is evaluated to produce a list of objects. These objects are then "spliced" into place in the template. For example, if x has the value (a b c), then `(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x)) => (x (a b c) a b c foo b bar (b c) baz b c) The backquote syntax can be summarized formally as follows. * `basic is the same as 'basic, that is, (quote basic), for any expression basic that is not a list or a general vector. * `,form is the same as form, for any form, provided that the representation of form does not begin with at-sign or dot. (A similar caveat holds for all occurrences of a form after a comma.) * `,@form has undefined consequences. * `(x1 x2 x3 ... xn . atom) may be interpreted to mean (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] (quote atom)) where the brackets are used to indicate a transformation of an xj as follows: - [form] is interpreted as (list `form), which contains a backquoted form that must then be further interpreted. - [,form] is interpreted as (list form). - [,@form] is interpreted as form. * `(x1 x2 x3 ... xn) may be interpreted to mean the same as the backquoted form `(x1 x2 x3 ... xn . nil), thereby reducing it to the previous case. * `(x1 x2 x3 ... xn . ,form) may be interpreted to mean (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] form) where the brackets indicate a transformation of an xj as described above. * `(x1 x2 x3 ... xn . ,@form) has undefined consequences. * `#(x1 x2 x3 ... xn) may be interpreted to mean (apply #'vector `(x1 x2 x3 ... xn)). Anywhere ",@" may be used, the syntax ",." may be used instead to indicate that it is permissible to operate destructively on the list structure produced by the form following the ",." (in effect, to use nconc instead of append). If the backquote syntax is nested, the innermost backquoted form should be expanded first. This means that if several commas occur in a row, the leftmost one belongs to the innermost backquote. An implementation is free to interpret a backquoted form F_1 as any form F_2 that, when evaluated, will produce a result that is the same under equal as the result implied by the above definition, provided that the side-effect behavior of the substitute form F_2 is also consistent with the description given above. The constructed copy of the template might or might not share list structure with the template itself. As an example, the above definition implies that `((,a b) ,c ,@d) will be interpreted as if it were (append (list (append (list a) (list 'b) 'nil)) (list c) d 'nil) but it could also be legitimately interpreted to mean any of the following: (append (list (append (list a) (list 'b))) (list c) d) (append (list (append (list a) '(b))) (list c) d) (list* (cons a '(b)) c d) (list* (cons a (list 'b)) c d) (append (list (cons a '(b))) (list c) d) (list* (cons a '(b)) c (copy-list d)) * Menu: * Notes about Backquote::  File: gcl.info, Node: Notes about Backquote, Prev: Backquote, Up: Backquote 2.4.6.1 Notes about Backquote ............................. Since the exact manner in which the Lisp reader will parse an expression involving the backquote reader macro is not specified, an implementation is free to choose any representation that preserves the semantics described. Often an implementation will choose a representation that facilitates pretty printing of the expression, so that (pprint `(a ,b)) will display `(a ,b) and not, for example, (list 'a b). However, this is not a requirement. Implementors who have no particular reason to make one choice or another might wish to refer to IEEE Standard for the Scheme Programming Language, which identifies a popular choice of representation for such expressions that might provide useful to be useful compatibility for some user communities. There is no requirement, however, that any conforming implementation use this particular representation. This information is provided merely for cross-reference purposes.  File: gcl.info, Node: Comma, Next: Sharpsign, Prev: Backquote, Up: Standard Macro Characters 2.4.7 Comma ----------- The comma is part of the backquote syntax; see *note Backquote::. Comma is invalid if used other than inside the body of a backquote expression as described above.  File: gcl.info, Node: Sharpsign, Next: Re-Reading Abbreviated Expressions, Prev: Comma, Up: Standard Macro Characters 2.4.8 Sharpsign --------------- Sharpsign is a non-terminating dispatching macro character. It reads an optional sequence of digits and then one more character, and uses that character to select a function to run as a reader macro function. The standard syntax includes constructs introduced by the # character. The syntax of these constructs is as follows: a character that identifies the type of construct is followed by arguments in some form. If the character is a letter, its case is not important; #O and #o are considered to be equivalent, for example. Certain # constructs allow an unsigned decimal number to appear between the # and the character. The reader macros associated with the dispatching macro character # are described later in this section and summarized in Figure 2-19. dispatch char purpose dispatch char purpose Backspace signals error { undefined* Tab signals error } undefined* Newline signals error + read-time conditional Linefeed signals error - read-time conditional Page signals error . read-time evaluation Return signals error / undefined Space signals error A, a array ! undefined* B, b binary rational " undefined C, c complex number # reference to = label D, d undefined $ undefined E, e undefined % undefined F, f undefined & undefined G, g undefined ' function abbreviation H, h undefined ( simple vector I, i undefined ) signals error J, j undefined * bit vector K, k undefined , undefined L, l undefined : uninterned symbol M, m undefined ; undefined N, n undefined < signals error O, o octal rational = labels following object P, p pathname > undefined Q, q undefined ? undefined* R, r radix-n rational @ undefined S, s structure [ undefined* T, t undefined \ character object U, u undefined ] undefined* V, v undefined ^ undefined W, w undefined _ undefined X, x hexadecimal rational ' undefined Y, y undefined | balanced comment Z, z undefined ~ undefined Rubout undefined Figure 2-19: Standard # Dispatching Macro Character Syntax The combinations marked by an asterisk (*) are explicitly reserved to the user. No conforming implementation defines them. Note also that digits do not appear in the preceding table. This is because the notations #0, #1, ..., #9 are reserved for another purpose which occupies the same syntactic space. When a digit follows a sharpsign, it is not treated as a dispatch character. Instead, an unsigned integer argument is accumulated and passed as an argument to the reader macro for the character that follows the digits. For example, #2A((1 2) (3 4)) is a use of #A with an argument of 2. * Menu: * Sharpsign Backslash:: * Sharpsign Single-Quote:: * Sharpsign Left-Parenthesis:: * Sharpsign Asterisk:: * Examples of Sharpsign Asterisk:: * Sharpsign Colon:: * Sharpsign Dot:: * Sharpsign B:: * Sharpsign O:: * Sharpsign X:: * Sharpsign R:: * Sharpsign C:: * Sharpsign A:: * Sharpsign S:: * Sharpsign P:: * Sharpsign Equal-Sign:: * Sharpsign Sharpsign:: * Sharpsign Plus:: * Sharpsign Minus:: * Sharpsign Vertical-Bar:: * Examples of Sharpsign Vertical-Bar:: * Notes about Style for Sharpsign Vertical-Bar:: * Sharpsign Less-Than-Sign:: * Sharpsign Whitespace:: * Sharpsign Right-Parenthesis::  File: gcl.info, Node: Sharpsign Backslash, Next: Sharpsign Single-Quote, Prev: Sharpsign, Up: Sharpsign 2.4.8.1 Sharpsign Backslash ........................... Syntax: #\<> When the token x is a single character long, this parses as the literal character char. Uppercase and lowercase letters are distinguished after #\; #\A and #\a denote different character objects. Any single character works after #\, even those that are normally special to read, such as left-parenthesis and right-parenthesis. In the single character case, the x must be followed by a non-constituent character. After #\ is read, the reader backs up over the slash and then reads a token, treating the initial slash as a single escape character (whether it really is or not in the current readtable). When the token x is more than one character long, the x must have the syntax of a symbol with no embedded package markers. In this case, the sharpsign backslash notation parses as the character whose name is (string-upcase x); see *note Character Names::. For information about how the Lisp printer prints character objects, see *note Printing Characters::.  File: gcl.info, Node: Sharpsign Single-Quote, Next: Sharpsign Left-Parenthesis, Prev: Sharpsign Backslash, Up: Sharpsign 2.4.8.2 Sharpsign Single-Quote .............................. Any expression preceded by #' (sharpsign followed by single-quote), as in #'expression, is treated by the Lisp reader as an abbreviation for and parsed identically to the expression (function expression). See function. For example, (apply #'+ l) == (apply (function +) l)  File: gcl.info, Node: Sharpsign Left-Parenthesis, Next: Sharpsign Asterisk, Prev: Sharpsign Single-Quote, Up: Sharpsign 2.4.8.3 Sharpsign Left-Parenthesis .................................. #( and ) are used to notate a simple vector. If an unsigned decimal integer appears between the # and (, it specifies explicitly the length of the vector. The consequences are undefined if the number of objects specified before the closing ) exceeds the unsigned decimal integer. If the number of objects supplied before the closing ) is less than the unsigned decimal integer but greater than zero, the last object is used to fill all remaining elements of the vector. [Editorial Note by Barmar: This should say "signals...".] The consequences are undefined if the unsigned decimal integer is non-zero and number of objects supplied before the closing ) is zero. For example, #(a b c c c c) #6(a b c c c c) #6(a b c) #6(a b c c) all mean the same thing: a vector of length 6 with elements a, b, and four occurrences of c. Other examples follow: #(a b c) ;A vector of length 3 #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) ;A vector containing the primes below 50 #() ;An empty vector The notation #() denotes an empty vector, as does #0(). For information on how the Lisp printer prints vectors, see *note Printing Strings::, *note Printing Bit Vectors::, or *note Printing Other Vectors::.  File: gcl.info, Node: Sharpsign Asterisk, Next: Examples of Sharpsign Asterisk, Prev: Sharpsign Left-Parenthesis, Up: Sharpsign 2.4.8.4 Sharpsign Asterisk .......................... Syntax: #*<> A simple bit vector is constructed containing the indicated bits (0's and 1's), where the leftmost bit has index zero and the subsequent bits have increasing indices. Syntax: #<>*<> With an argument n, the vector to be created is of length n. If the number of bits is less than n but greater than zero, the last bit is used to fill all remaining bits of the bit vector. The notations #* and #0* each denote an empty bit vector. Regardless of whether the optional numeric argument n is provided, the token that follows the asterisk is delimited by a normal token delimiter. However, (unless the value of *read-suppress* is true) an error of type reader-error is signaled if that token is not composed entirely of 0's and 1's, or if n was supplied and the token is composed of more than n bits, or if n is greater than one, but no bits were specified. Neither a single escape nor a multiple escape is permitted in this token. For information on how the Lisp printer prints bit vectors, see *note Printing Bit Vectors::.  File: gcl.info, Node: Examples of Sharpsign Asterisk, Next: Sharpsign Colon, Prev: Sharpsign Asterisk, Up: Sharpsign 2.4.8.5 Examples of Sharpsign Asterisk ...................................... For example, #*101111 #6*101111 #6*101 #6*1011 all mean the same thing: a vector of length 6 with elements 1, 0, 1, 1, 1, and 1. For example: #* ;An empty bit-vector  File: gcl.info, Node: Sharpsign Colon, Next: Sharpsign Dot, Prev: Examples of Sharpsign Asterisk, Up: Sharpsign 2.4.8.6 Sharpsign Colon ....................... Syntax: #:<> #: introduces an uninterned symbol whose name is symbol-name. Every time this syntax is encountered, a distinct uninterned symbol is created. The symbol-name must have the syntax of a symbol with no package prefix. For information on how the Lisp reader prints uninterned symbols, see *note Printing Symbols::.  File: gcl.info, Node: Sharpsign Dot, Next: Sharpsign B, Prev: Sharpsign Colon, Up: Sharpsign 2.4.8.7 Sharpsign Dot ..................... #.foo is read as the object resulting from the evaluation of the object represented by foo. The evaluation is done during the read process, when the #. notation is encountered. The #. syntax therefore performs a read-time evaluation of foo. The normal effect of #. is inhibited when the value of *read-eval* is false. In that situation, an error of type reader-error is signaled. For an object that does not have a convenient printed representation, a form that computes the object can be given using the #. notation.  File: gcl.info, Node: Sharpsign B, Next: Sharpsign O, Prev: Sharpsign Dot, Up: Sharpsign 2.4.8.8 Sharpsign B ................... #Brational reads rational in binary (radix 2). For example, #B1101 == 13 ;1101_2 #b101/11 == 5/3 The consequences are undefined if the token immediately following the #B does not have the syntax of a binary (i.e., radix 2) rational.  File: gcl.info, Node: Sharpsign O, Next: Sharpsign X, Prev: Sharpsign B, Up: Sharpsign 2.4.8.9 Sharpsign O ................... #Orational reads rational in octal (radix 8). For example, #o37/15 == 31/13 #o777 == 511 #o105 == 69 ;105_8 The consequences are undefined if the token immediately following the #O does not have the syntax of an octal (i.e., radix 8) rational.  File: gcl.info, Node: Sharpsign X, Next: Sharpsign R, Prev: Sharpsign O, Up: Sharpsign 2.4.8.10 Sharpsign X .................... #Xrational reads rational in hexadecimal (radix 16). The digits above 9 are the letters A through F (the lowercase letters a through f are also acceptable). For example, #xF00 == 3840 #x105 == 261 ;105_16 The consequences are undefined if the token immediately following the #X does not have the syntax of a hexadecimal (i.e., radix 16) rational.  File: gcl.info, Node: Sharpsign R, Next: Sharpsign C, Prev: Sharpsign X, Up: Sharpsign 2.4.8.11 Sharpsign R .................... #nR #radixRrational reads rational in radix radix. radix must consist of only digits that are interpreted as an integer in decimal radix; its value must be between 2 and 36 (inclusive). Only valid digits for the specified radix may be used. For example, #3r102 is another way of writing 11 (decimal), and #11R32 is another way of writing 35 (decimal). For radices larger than 10, letters of the alphabet are used in order for the digits after 9. No alternate # notation exists for the decimal radix since a decimal point suffices. Figure 2-20 contains examples of the use of #B, #O, #X, and #R. #2r11010101 ;Another way of writing 213 decimal #b11010101 ;Ditto #b+11010101 ;Ditto #o325 ;Ditto, in octal radix #xD5 ;Ditto, in hexadecimal radix #16r+D5 ;Ditto #o-300 ;Decimal -192, written in base 8 #3r-21010 ;Same thing in base 3 #25R-7H ;Same thing in base 25 #xACCEDED ;181202413, in hexadecimal radix Figure 2-20: Radix Indicator Example The consequences are undefined if the token immediately following the #nR does not have the syntax of a rational in radix n.  File: gcl.info, Node: Sharpsign C, Next: Sharpsign A, Prev: Sharpsign R, Up: Sharpsign 2.4.8.12 Sharpsign C .................... #C reads a following object, which must be a list of length two whose elements are both reals. These reals denote, respectively, the real and imaginary parts of a complex number. If the two parts as notated are not of the same data type, then they are converted according to the rules of floating-point contagion described in *note Contagion in Numeric Operations::. #C(real imag) is equivalent to #.(complex (quote real) (quote imag)), except that #C is not affected by *read-eval*. See the function complex. Figure 2-21 contains examples of the use of #C. #C(3.0s1 2.0s-1) ;A complex with small float parts. #C(5 -3) ;A "Gaussian integer" #C(5/3 7.0) ;Will be converted internally to #C(1.66666 7.0) #C(0 1) ;The imaginary unit; that is, i. Figure 2-21: Complex Number Example For further information, see *note Printing Complexes:: and *note Syntax of a Complex::.  File: gcl.info, Node: Sharpsign A, Next: Sharpsign S, Prev: Sharpsign C, Up: Sharpsign 2.4.8.13 Sharpsign A .................... #nA #nAobject constructs an n-dimensional array, using object as the value of the :initial-contents argument to make-array. For example, #2A((0 1 5) (foo 2 (hot dog))) represents a 2-by-3 matrix: 0 1 5 foo 2 (hot dog) In contrast, #1A((0 1 5) (foo 2 (hot dog))) represents a vector of length 2 whose elements are lists: (0 1 5) (foo 2 (hot dog)) #0A((0 1 5) (foo 2 (hot dog))) represents a zero-dimensional array whose sole element is a list: ((0 1 5) (foo 2 (hot dog))) #0A foo represents a zero-dimensional array whose sole element is the symbol foo. The notation #1A foo is not valid because foo is not a sequence. If some dimension of the array whose representation is being parsed is found to be 0, all dimensions to the right (i.e., the higher numbered dimensions) are also considered to be 0. For information on how the Lisp printer prints arrays, see *note Printing Strings::, *note Printing Bit Vectors::, *note Printing Other Vectors::, or *note Printing Other Arrays::.  File: gcl.info, Node: Sharpsign S, Next: Sharpsign P, Prev: Sharpsign A, Up: Sharpsign 2.4.8.14 Sharpsign S .................... #s(name slot1 value1 slot2 value2 ...) denotes a structure. This is valid only if name is the name of a structure type already defined by defstruct and if the structure type has a standard constructor function. Let cm stand for the name of this constructor function; then this syntax is equivalent to #.(cm keyword1 'value1 keyword2 'value2 ...) where each keywordj is the result of computing (intern (string slotj) (find-package 'keyword)) The net effect is that the constructor function is called with the specified slots having the specified values. (This coercion feature is deprecated; in the future, keyword names will be taken in the package they are read in, so symbols that are actually in the KEYWORD package should be used if that is what is desired.) Whatever object the constructor function returns is returned by the #S syntax. For information on how the Lisp printer prints structures, see *note Printing Structures::.  File: gcl.info, Node: Sharpsign P, Next: Sharpsign Equal-Sign, Prev: Sharpsign S, Up: Sharpsign 2.4.8.15 Sharpsign P .................... #P reads a following object, which must be a string. #P<> is equivalent to #.(parse-namestring '<>), except that #P is not affected by *read-eval*. For information on how the Lisp printer prints pathnames, see *note Printing Pathnames::.  File: gcl.info, Node: Sharpsign Equal-Sign, Next: Sharpsign Sharpsign, Prev: Sharpsign P, Up: Sharpsign 2.4.8.16 Sharpsign Equal-Sign ............................. #n= #n=object reads as whatever object has object as its printed representation. However, that object is labeled by n, a required unsigned decimal integer, for possible reference by the syntax #n#. The scope of the label is the expression being read by the outermost call to read; within this expression, the same label may not appear twice.  File: gcl.info, Node: Sharpsign Sharpsign, Next: Sharpsign Plus, Prev: Sharpsign Equal-Sign, Up: Sharpsign 2.4.8.17 Sharpsign Sharpsign ............................ #n# #n#, where n is a required unsigned decimal integer, provides a reference to some object labeled by #n=; that is, #n# represents a pointer to the same (eq) object labeled by #n=. For example, a structure created in the variable y by this code: (setq x (list 'p 'q)) (setq y (list (list 'a 'b) x 'foo x)) (rplacd (last y) (cdr y)) could be represented in this way: ((a b) . #1=(#2=(p q) foo #2# . #1#)) Without this notation, but with *print-length* set to 10 and *print-circle* set to nil, the structure would print in this way: ((a b) (p q) foo (p q) (p q) foo (p q) (p q) foo (p q) ...) A reference #n# may only occur after a label #n=; forward references are not permitted. The reference may not appear as the labeled object itself (that is, #n=#n#) may not be written because the object labeled by #n= is not well defined in this case.  File: gcl.info, Node: Sharpsign Plus, Next: Sharpsign Minus, Prev: Sharpsign Sharpsign, Up: Sharpsign 2.4.8.18 Sharpsign Plus ....................... #+ provides a read-time conditionalization facility; the syntax is #+test expression. If the feature expression test succeeds, then this textual notation represents an object whose printed representation is expression. If the feature expression test fails, then this textual notation is treated as whitespace_2; that is, it is as if the "#+ test expression" did not appear and only a space appeared in its place. For a detailed description of success and failure in feature expressions, see *note Feature Expressions::. #+ operates by first reading the feature expression and then skipping over the form if the feature expression fails. While reading the test, the current package is the KEYWORD package. Skipping over the form is accomplished by binding *read-suppress* to true and then calling read. For examples, see *note Examples of Feature Expressions::.  File: gcl.info, Node: Sharpsign Minus, Next: Sharpsign Vertical-Bar, Prev: Sharpsign Plus, Up: Sharpsign 2.4.8.19 Sharpsign Minus ........................ #- is like #+ except that it skips the expression if the test succeeds; that is, #-test expression == #+(not test) expression For examples, see *note Examples of Feature Expressions::.  File: gcl.info, Node: Sharpsign Vertical-Bar, Next: Examples of Sharpsign Vertical-Bar, Prev: Sharpsign Minus, Up: Sharpsign 2.4.8.20 Sharpsign Vertical-Bar ............................... #|...|# is treated as a comment by the reader. It must be balanced with respect to other occurrences of #| and |#, but otherwise may contain any characters whatsoever.  File: gcl.info, Node: Examples of Sharpsign Vertical-Bar, Next: Notes about Style for Sharpsign Vertical-Bar, Prev: Sharpsign Vertical-Bar, Up: Sharpsign 2.4.8.21 Examples of Sharpsign Vertical-Bar ........................................... The following are some examples that exploit the #|...|# notation: ;;; In this example, some debugging code is commented out with #|...|# ;;; Note that this kind of comment can occur in the middle of a line ;;; (because a delimiter marks where the end of the comment occurs) ;;; where a semicolon comment can only occur at the end of a line ;;; (because it comments out the rest of the line). (defun add3 (n) #|(format t "~&Adding 3 to ~D." n)|# (+ n 3)) ;;; The examples that follow show issues related to #| ... |# nesting. ;;; In this first example, #| and |# always occur properly paired, ;;; so nesting works naturally. (defun mention-fun-fact-1a () (format t "CL uses ; and #|...|# in comments.")) => MENTION-FUN-FACT-1A (mention-fun-fact-1a) |> CL uses ; and #|...|# in comments. => NIL #| (defun mention-fun-fact-1b () (format t "CL uses ; and #|...|# in comments.")) |# (fboundp 'mention-fun-fact-1b) => NIL ;;; In this example, vertical-bar followed by sharpsign needed to appear ;;; in a string without any matching sharpsign followed by vertical-bar ;;; having preceded this. To compensate, the programmer has included a ;;; slash separating the two characters. In case 2a, the slash is ;;; unnecessary but harmless, but in case 2b, the slash is critical to ;;; allowing the outer #| ... |# pair match. If the slash were not present, ;;; the outer comment would terminate prematurely. (defun mention-fun-fact-2a () (format t "Don't use |\# unmatched or you'll get in trouble!")) => MENTION-FUN-FACT-2A (mention-fun-fact-2a) |> Don't use |# unmatched or you'll get in trouble! => NIL #| (defun mention-fun-fact-2b () (format t "Don't use |\# unmatched or you'll get in trouble!") |# (fboundp 'mention-fun-fact-2b) => NIL ;;; In this example, the programmer attacks the mismatch problem in a ;;; different way. The sharpsign vertical bar in the comment is not needed ;;; for the correct parsing of the program normally (as in case 3a), but ;;; becomes important to avoid premature termination of a comment when such ;;; a program is commented out (as in case 3b). (defun mention-fun-fact-3a () ; #| (format t "Don't use |# unmatched or you'll get in trouble!")) => MENTION-FUN-FACT-3A (mention-fun-fact-3a) |> Don't use |# unmatched or you'll get in trouble! => NIL #| (defun mention-fun-fact-3b () ; #| (format t "Don't use |# unmatched or you'll get in trouble!")) |# (fboundp 'mention-fun-fact-3b) => NIL  File: gcl.info, Node: Notes about Style for Sharpsign Vertical-Bar, Next: Sharpsign Less-Than-Sign, Prev: Examples of Sharpsign Vertical-Bar, Up: Sharpsign 2.4.8.22 Notes about Style for Sharpsign Vertical-Bar ..................................................... Some text editors that purport to understand Lisp syntax treat any |...| as balanced pairs that cannot nest (as if they were just balanced pairs of the multiple escapes used in notating certain symbols). To compensate for this deficiency, some programmers use the notation #||...#||...||#...||# instead of #|...#|...|#...|#. Note that this alternate usage is not a different reader macro; it merely exploits the fact that the additional vertical-bars occur within the comment in a way that tricks certain text editor into better supporting nested comments. As such, one might sometimes see code like: #|| (+ #|| 3 ||# 4 5) ||# Such code is equivalent to: #| (+ #| 3 |# 4 5) |#  File: gcl.info, Node: Sharpsign Less-Than-Sign, Next: Sharpsign Whitespace, Prev: Notes about Style for Sharpsign Vertical-Bar, Up: Sharpsign 2.4.8.23 Sharpsign Less-Than-Sign ................................. #< is not valid reader syntax. The Lisp reader will signal an error of type reader-error on encountering #<. This syntax is typically used in the printed representation of objects that cannot be read back in.  File: gcl.info, Node: Sharpsign Whitespace, Next: Sharpsign Right-Parenthesis, Prev: Sharpsign Less-Than-Sign, Up: Sharpsign 2.4.8.24 Sharpsign Whitespace ............................. # followed immediately by whitespace_1 is not valid reader syntax. The Lisp reader will signal an error of type reader-error if it encounters the reader macro notation # or #.  File: gcl.info, Node: Sharpsign Right-Parenthesis, Prev: Sharpsign Whitespace, Up: Sharpsign 2.4.8.25 Sharpsign Right-Parenthesis .................................... This is not valid reader syntax. The Lisp reader will signal an error of type reader-error upon encountering #).  File: gcl.info, Node: Re-Reading Abbreviated Expressions, Prev: Sharpsign, Up: Standard Macro Characters 2.4.9 Re-Reading Abbreviated Expressions ---------------------------------------- Note that the Lisp reader will generally signal an error of type reader-error when reading an expression_2 that has been abbreviated because of length or level limits (see *print-level*, *print-length*, and *print-lines*) due to restrictions on "..", "...", "#" followed by whitespace_1, and "#)".  File: gcl.info, Node: Evaluation and Compilation, Next: Types and Classes, Prev: Syntax, Up: Top 3 Evaluation and Compilation **************************** * Menu: * Evaluation:: * Compilation:: * Declarations:: * Lambda Lists:: * Error Checking in Function Calls:: * Traversal Rules and Side Effects:: * Destructive Operations:: * Evaluation and Compilation Dictionary::  File: gcl.info, Node: Evaluation, Next: Compilation, Prev: Evaluation and Compilation, Up: Evaluation and Compilation 3.1 Evaluation ============== Execution of code can be accomplished by a variety of means ranging from direct interpretation of a form representing a program to invocation of compiled code produced by a compiler. Evaluation is the process by which a program is executed in Common Lisp. The mechanism of evaluation is manifested both implicitly through the effect of the Lisp read-eval-print loop, and explicitly through the presence of the functions eval, compile, compile-file, and load. Any of these facilities might share the same execution strategy, or each might use a different one. The behavior of a conforming program processed by eval and by compile-file might differ; see *note Semantic Constraints::. Evaluation can be understood in terms of a model in which an interpreter recursively traverses a form performing each step of the computation as it goes. This model, which describes the semantics of Common Lisp programs, is described in *note The Evaluation Model::. * Menu: * Introduction to Environments:: * The Evaluation Model:: * Lambda Expressions:: * Closures and Lexical Binding:: * Shadowing:: * Extent:: * Return Values::  File: gcl.info, Node: Introduction to Environments, Next: The Evaluation Model, Prev: Evaluation, Up: Evaluation 3.1.1 Introduction to Environments ---------------------------------- A binding is an association between a name and that which the name denotes. Bindings are established in a lexical environment or a dynamic environment by particular special operators. An environment is a set of bindings and other information used during evaluation (e.g., to associate meanings with names). Bindings in an environment are partitioned into namespaces . A single name can simultaneously have more than one associated binding per environment, but can have only one associated binding per namespace. * Menu: * The Global Environment:: * Dynamic Environments:: * Lexical Environments:: * The Null Lexical Environment:: * Environment Objects::  File: gcl.info, Node: The Global Environment, Next: Dynamic Environments, Prev: Introduction to Environments, Up: Introduction to Environments 3.1.1.1 The Global Environment .............................. The global environment is that part of an environment that contains bindings with both indefinite scope and indefinite extent. The global environment contains, among other things, the following: * bindings of dynamic variables and constant variables. * bindings of functions, macros, and special operators. * bindings of compiler macros. * bindings of type and class names * information about proclamations.  File: gcl.info, Node: Dynamic Environments, Next: Lexical Environments, Prev: The Global Environment, Up: Introduction to Environments 3.1.1.2 Dynamic Environments ............................ A dynamic environment for evaluation is that part of an environment that contains bindings whose duration is bounded by points of establishment and disestablishment within the execution of the form that established the binding. A dynamic environment contains, among other things, the following: * bindings for dynamic variables. * information about active catch tags. * information about exit points established by unwind-protect. * information about active handlers and restarts. The dynamic environment that is active at any given point in the execution of a program is referred to by definite reference as "the current dynamic environment," or sometimes as just "the dynamic environment." Within a given namespace, a name is said to be bound in a dynamic environment if there is a binding associated with its name in the dynamic environment or, if not, there is a binding associated with its name in the global environment.  File: gcl.info, Node: Lexical Environments, Next: The Null Lexical Environment, Prev: Dynamic Environments, Up: Introduction to Environments 3.1.1.3 Lexical Environments ............................ A lexical environment for evaluation at some position in a program is that part of the environment that contains information having lexical scope within the forms containing that position. A lexical environment contains, among other things, the following: * bindings of lexical variables and symbol macros. * bindings of functions and macros. (Implicit in this is information about those compiler macros that are locally disabled.) * bindings of block tags. * bindings of go tags. * information about declarations. The lexical environment that is active at any given position in a program being semantically processed is referred to by definite reference as "the current lexical environment," or sometimes as just "the lexical environment." Within a given namespace, a name is said to be bound in a lexical environment if there is a binding associated with its name in the lexical environment or, if not, there is a binding associated with its name in the global environment.  File: gcl.info, Node: The Null Lexical Environment, Next: Environment Objects, Prev: Lexical Environments, Up: Introduction to Environments 3.1.1.4 The Null Lexical Environment .................................... The null lexical environment is equivalent to the global environment. Although in general the representation of an environment object is implementation-dependent, nil can be used in any situation where an environment object is called for in order to denote the null lexical environment.  File: gcl.info, Node: Environment Objects, Prev: The Null Lexical Environment, Up: Introduction to Environments 3.1.1.5 Environment Objects ........................... Some operators make use of an object, called an environment object , that represents the set of lexical bindings needed to perform semantic analysis on a form in a given lexical environment. The set of bindings in an environment object may be a subset of the bindings that would be needed to actually perform an evaluation; for example, values associated with variable names and function names in the corresponding lexical environment might not be available in an environment object. The type and nature of an environment object is implementation-dependent. The values of environment parameters to macro functions are examples of environment objects. The object nil when used as an environment object denotes the null lexical environment; see *note The Null Lexical Environment::.  File: gcl.info, Node: The Evaluation Model, Next: Lambda Expressions, Prev: Introduction to Environments, Up: Evaluation 3.1.2 The Evaluation Model -------------------------- A Common Lisp system evaluates forms with respect to lexical, dynamic, and global environments. The following sections describe the components of the Common Lisp evaluation model. * Menu: * Form Evaluation:: * Symbols as Forms:: * Lexical Variables:: * Dynamic Variables:: * Constant Variables:: * Symbols Naming Both Lexical and Dynamic Variables:: * Conses as Forms:: * Special Forms:: * Macro Forms:: * Function Forms:: * Lambda Forms:: * Self-Evaluating Objects:: * Examples of Self-Evaluating Objects::  File: gcl.info, Node: Form Evaluation, Next: Symbols as Forms, Prev: The Evaluation Model, Up: The Evaluation Model 3.1.2.1 Form Evaluation ....................... Forms fall into three categories: symbols, conses, and self-evaluating objects. The following sections explain these categories.  File: gcl.info, Node: Symbols as Forms, Next: Lexical Variables, Prev: Form Evaluation, Up: The Evaluation Model 3.1.2.2 Symbols as Forms ........................ If a form is a symbol, then it is either a symbol macro or a variable. The symbol names a symbol macro if there is a binding of the symbol as a symbol macro in the current lexical environment (see define-symbol-macro and symbol-macrolet). If the symbol is a symbol macro, its expansion function is obtained. The expansion function is a function of two arguments, and is invoked by calling the macroexpand hook with the expansion function as its first argument, the symbol as its second argument, and an environment object (corresponding to the current lexical environment) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The value of the expansion function, which is passed through by the macroexpand hook, is a form. This resulting form is processed in place of the original symbol. If a form is a symbol that is not a symbol macro, then it is the name of a variable, and the value of that variable is returned. There are three kinds of variables: lexical variables, dynamic variables, and constant variables. A variable can store one object. The main operations on a variable are to read_1 and to write_1 its value. An error of type unbound-variable should be signaled if an unbound variable is referenced. Non-constant variables can be assigned by using setq or bound_3 by using let. Figure 3-1 lists some defined names that are applicable to assigning, binding, and defining variables. boundp let progv defconstant let* psetq defparameter makunbound set defvar multiple-value-bind setq lambda multiple-value-setq symbol-value Figure 3-1: Some Defined Names Applicable to Variables The following is a description of each kind of variable.  File: gcl.info, Node: Lexical Variables, Next: Dynamic Variables, Prev: Symbols as Forms, Up: The Evaluation Model 3.1.2.3 Lexical Variables ......................... A lexical variable is a variable that can be referenced only within the lexical scope of the form that establishes that variable; lexical variables have lexical scope. Each time a form creates a lexical binding of a variable, a fresh binding is established. Within the scope of a binding for a lexical variable name, uses of that name as a variable are considered to be references to that binding except where the variable is shadowed_2 by a form that establishes a fresh binding for that variable name, or by a form that locally declares the name special. A lexical variable always has a value. There is no operator that introduces a binding for a lexical variable without giving it an initial value, nor is there any operator that can make a lexical variable be unbound. Bindings of lexical variables are found in the lexical environment.  File: gcl.info, Node: Dynamic Variables, Next: Constant Variables, Prev: Lexical Variables, Up: The Evaluation Model 3.1.2.4 Dynamic Variables ......................... A variable is a dynamic variable if one of the following conditions hold: * It is locally declared or globally proclaimed special. * It occurs textually within a form that creates a dynamic binding for a variable of the same name, and the binding is not shadowed_2 by a form that creates a lexical binding of the same variable name. A dynamic variable can be referenced at any time in any program; there is no textual limitation on references to dynamic variables. At any given time, all dynamic variables with a given name refer to exactly one binding, either in the dynamic environment or in the global environment. The value part of the binding for a dynamic variable might be empty; in this case, the dynamic variable is said to have no value, or to be unbound. A dynamic variable can be made unbound by using makunbound. The effect of binding a dynamic variable is to create a new binding to which all references to that dynamic variable in any program refer for the duration of the evaluation of the form that creates the dynamic binding. A dynamic variable can be referenced outside the dynamic extent of a form that binds it. Such a variable is sometimes called a "global variable" but is still in all respects just a dynamic variable whose binding happens to exist in the global environment rather than in some dynamic environment. A dynamic variable is unbound unless and until explicitly assigned a value, except for those variables whose initial value is defined in this specification or by an implementation.  File: gcl.info, Node: Constant Variables, Next: Symbols Naming Both Lexical and Dynamic Variables, Prev: Dynamic Variables, Up: The Evaluation Model 3.1.2.5 Constant Variables .......................... Certain variables, called constant variables, are reserved as "named constants." The consequences are undefined if an attempt is made to assign a value to, or create a binding for a constant variable, except that a 'compatible' redefinition of a constant variable using defconstant is permitted; see the macro defconstant. Keywords, symbols defined by Common Lisp or the implementation as constant (such as nil, t, and pi), and symbols declared as constant using defconstant are constant variables.  File: gcl.info, Node: Symbols Naming Both Lexical and Dynamic Variables, Next: Conses as Forms, Prev: Constant Variables, Up: The Evaluation Model 3.1.2.6 Symbols Naming Both Lexical and Dynamic Variables ......................................................... The same symbol can name both a lexical variable and a dynamic variable, but never in the same lexical environment. In the following example, the symbol x is used, at different times, as the name of a lexical variable and as the name of a dynamic variable. (let ((x 1)) ;Binds a special variable X (declare (special x)) (let ((x 2)) ;Binds a lexical variable X (+ x ;Reads a lexical variable X (locally (declare (special x)) x)))) ;Reads a special variable X => 3  File: gcl.info, Node: Conses as Forms, Next: Special Forms, Prev: Symbols Naming Both Lexical and Dynamic Variables, Up: The Evaluation Model 3.1.2.7 Conses as Forms ....................... A cons that is used as a form is called a compound form. If the car of that compound form is a symbol, that symbol is the name of an operator, and the form is either a special form, a macro form, or a function form, depending on the function binding of the operator in the current lexical environment. If the operator is neither a special operator nor a macro name, it is assumed to be a function name (even if there is no definition for such a function). If the car of the compound form is not a symbol, then that car must be a lambda expression, in which case the compound form is a lambda form. How a compound form is processed depends on whether it is classified as a special form, a macro form, a function form, or a lambda form.  File: gcl.info, Node: Special Forms, Next: Macro Forms, Prev: Conses as Forms, Up: The Evaluation Model 3.1.2.8 Special Forms ..................... A special form is a form with special syntax, special evaluation rules, or both, possibly manipulating the evaluation environment, control flow, or both. A special operator has access to the current lexical environment and the current dynamic environment. Each special operator defines the manner in which its subexpressions are treated--which are forms, which are special syntax, etc. Some special operators create new lexical or dynamic environments for use during the evaluation of subforms of the special form. For example, block creates a new lexical environment that is the same as the one in force at the point of evaluation of the block form with the addition of a binding of the block name to an exit point from the block. The set of special operator names is fixed in Common Lisp; no way is provided for the user to define a special operator. Figure 3-2 lists all of the Common Lisp symbols that have definitions as special operators. block let* return-from catch load-time-value setq eval-when locally symbol-macrolet flet macrolet tagbody function multiple-value-call the go multiple-value-prog1 throw if progn unwind-protect labels progv let quote Figure 3-2: Common Lisp Special Operators  File: gcl.info, Node: Macro Forms, Next: Function Forms, Prev: Special Forms, Up: The Evaluation Model 3.1.2.9 Macro Forms ................... If the operator names a macro, its associated macro function is applied to the entire form and the result of that application is used in place of the original form. Specifically, a symbol names a macro in a given lexical environment if macro-function is true of the symbol and that environment. The function returned by macro-function is a function of two arguments, called the expansion function. The expansion function is invoked by calling the macroexpand hook with the expansion function as its first argument, the entire macro form as its second argument, and an environment object (corresponding to the current lexical environment) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The value of the expansion function, which is passed through by the macroexpand hook, is a form. The returned form is evaluated in place of the original form. The consequences are undefined if a macro function destructively modifies any part of its form argument. A macro name is not a function designator, and cannot be used as the function argument to functions such as apply, funcall, or map. An implementation is free to implement a Common Lisp special operator as a macro. An implementation is free to implement any macro operator as a special operator, but only if an equivalent definition of the macro is also provided. Figure 3-3 lists some defined names that are applicable to macros. *macroexpand-hook* macro-function macroexpand-1 defmacro macroexpand macrolet Figure 3-3: Defined names applicable to macros  File: gcl.info, Node: Function Forms, Next: Lambda Forms, Prev: Macro Forms, Up: The Evaluation Model 3.1.2.10 Function Forms ....................... If the operator is a symbol naming a function, the form represents a function form, and the cdr of the list contains the forms which when evaluated will supply the arguments passed to the function. When a function name is not defined, an error of type undefined-function should be signaled at run time; see *note Semantic Constraints::. A function form is evaluated as follows: The subforms in the cdr of the original form are evaluated in left-to-right order in the current lexical and dynamic environments. The primary value of each such evaluation becomes an argument to the named function; any additional values returned by the subforms are discarded. The functional value of the operator is retrieved from the lexical environment, and that function is invoked with the indicated arguments. Although the order of evaluation of the argument subforms themselves is strictly left-to-right, it is not specified whether the definition of the operator in a function form is looked up before the evaluation of the argument subforms, after the evaluation of the argument subforms, or between the evaluation of any two argument subforms if there is more than one such argument subform. For example, the following might return 23 or~24. (defun foo (x) (+ x 3)) (defun bar () (setf (symbol-function 'foo) #'(lambda (x) (+ x 4)))) (foo (progn (bar) 20)) A binding for a function name can be established in one of several ways. A binding for a function name in the global environment can be established by defun, setf of fdefinition, setf of symbol-function, ensure-generic-function, defmethod (implicitly, due to ensure-generic-function), or defgeneric. A binding for a function name in the lexical environment can be established by flet or labels. Figure 3-4 lists some defined names that are applicable to functions. apply fdefinition mapcan call-arguments-limit flet mapcar complement fmakunbound mapcon constantly funcall mapl defgeneric function maplist defmethod functionp multiple-value-call defun labels reduce fboundp map symbol-function Figure 3-4: Some function-related defined names  File: gcl.info, Node: Lambda Forms, Next: Self-Evaluating Objects, Prev: Function Forms, Up: The Evaluation Model 3.1.2.11 Lambda Forms ..................... A lambda form is similar to a function form, except that the function name is replaced by a lambda expression. A lambda form is equivalent to using funcall of a lexical closure of the lambda expression on the given arguments. (In practice, some compilers are more likely to produce inline code for a lambda form than for an arbitrary named function that has been declared inline; however, such a difference is not semantic.) For further information, see *note Lambda Expressions::.  File: gcl.info, Node: Self-Evaluating Objects, Next: Examples of Self-Evaluating Objects, Prev: Lambda Forms, Up: The Evaluation Model 3.1.2.12 Self-Evaluating Objects ................................ A form that is neither a symbol nor a cons is defined to be a self-evaluating object. Evaluating such an object yields the same object as a result. Certain specific symbols and conses might also happen to be "self-evaluating" but only as a special case of a more general set of rules for the evaluation of symbols and conses; such objects are not considered to be self-evaluating objects. The consequences are undefined if literal objects (including self-evaluating objects) are destructively modified.  File: gcl.info, Node: Examples of Self-Evaluating Objects, Prev: Self-Evaluating Objects, Up: The Evaluation Model 3.1.2.13 Examples of Self-Evaluating Objects ............................................ Numbers, pathnames, and arrays are examples of self-evaluating objects. 3 => 3 #c(2/3 5/8) => #C(2/3 5/8) #p"S:[BILL]OTHELLO.TXT" => #P"S:[BILL]OTHELLO.TXT" #(a b c) => #(A B C) "fred smith" => "fred smith"  File: gcl.info, Node: Lambda Expressions, Next: Closures and Lexical Binding, Prev: The Evaluation Model, Up: Evaluation 3.1.3 Lambda Expressions ------------------------ In a lambda expression, the body is evaluated in a lexical environment that is formed by adding the binding of each parameter in the lambda list with the corresponding value from the arguments to the current lexical environment. For further discussion of how bindings are established based on the lambda list, see *note Lambda Lists::. The body of a lambda expression is an implicit progn; the values it returns are returned by the lambda expression.  File: gcl.info, Node: Closures and Lexical Binding, Next: Shadowing, Prev: Lambda Expressions, Up: Evaluation 3.1.4 Closures and Lexical Binding ---------------------------------- A lexical closure is a function that can refer to and alter the values of lexical bindings established by binding forms that textually include the function definition. Consider this code, where x is not declared special: (defun two-funs (x) (list (function (lambda () x)) (function (lambda (y) (setq x y))))) (setq funs (two-funs 6)) (funcall (car funs)) => 6 (funcall (cadr funs) 43) => 43 (funcall (car funs)) => 43 The function special form coerces a lambda expression into a closure in which the lexical environment in effect when the special form is evaluated is captured along with the lambda expression. The function two-funs returns a list of two functions, each of which refers to the binding of the variable x created on entry to the function two-funs when it was called. This variable has the value 6 initially, but setq can alter this binding. The lexical closure created for the first lambda expression does not "snapshot" the value 6 for x when the closure is created; rather it captures the binding of x. The second function can be used to alter the value in the same (captured) binding (to 43, in the example), and this altered variable binding then affects the value returned by the first function. In situations where a closure of a lambda expression over the same set of bindings may be produced more than once, the various resulting closures may or may not be identical, at the discretion of the implementation. That is, two functions that are behaviorally indistinguishable might or might not be identical. Two functions that are behaviorally distinguishable are distinct. For example: (let ((x 5) (funs '())) (dotimes (j 10) (push #'(lambda (z) (if (null z) (setq x 0) (+ x z))) funs)) funs) The result of the above form is a list of ten closures. Each requires only the binding of x. It is the same binding in each case, but the ten closure objects might or might not be identical. On the other hand, the result of the form (let ((funs '())) (dotimes (j 10) (let ((x 5)) (push (function (lambda (z) (if (null z) (setq x 0) (+ x z)))) funs))) funs) is also a list of ten closures. However, in this case no two of the closure objects can be identical because each closure is closed over a distinct binding of x, and these bindings can be behaviorally distinguished because of the use of setq. The result of the form (let ((funs '())) (dotimes (j 10) (let ((x 5)) (push (function (lambda (z) (+ x z))) funs))) funs) is a list of ten closure objects that might or might not be identical. A different binding of x is involved for each closure, but the bindings cannot be distinguished because their values are the same and immutable (there being no occurrence of setq on x). A compiler could internally transform the form to (let ((funs '())) (dotimes (j 10) (push (function (lambda (z) (+ 5 z))) funs)) funs) where the closures may be identical. It is possible that a closure does not close over any variable bindings. In the code fragment (mapcar (function (lambda (x) (+ x 2))) y) the function (lambda (x) (+ x 2)) contains no references to any outside object. In this case, the same closure might be returned for all evaluations of the function form.  File: gcl.info, Node: Shadowing, Next: Extent, Prev: Closures and Lexical Binding, Up: Evaluation 3.1.5 Shadowing --------------- If two forms that establish lexical bindings with the same name N are textually nested, then references to N within the inner form refer to the binding established by the inner form; the inner binding for N shadows the outer binding for N. Outside the inner form but inside the outer one, references to N refer to the binding established by the outer form. For example: (defun test (x z) (let ((z (* x 2))) (print z)) z) The binding of the variable z by let shadows the parameter binding for the function test. The reference to the variable z in the print form refers to the let binding. The reference to z at the end of the function test refers to the parameter named z. Constructs that are lexically scoped act as if new names were generated for each object on each execution. Therefore, dynamic shadowing cannot occur. For example: (defun contorted-example (f g x) (if (= x 0) (funcall f) (block here (+ 5 (contorted-example g #'(lambda () (return-from here 4)) (- x 1)))))) Consider the call (contorted-example nil nil 2). This produces 4. During the course of execution, there are three calls to contorted-example, interleaved with two blocks: (contorted-example nil nil 2) (block here_1 ...) (contorted-example nil #'(lambda () (return-from here_1 4)) 1) (block here_2 ...) (contorted-example #'(lambda () (return-from here_1 4)) #'(lambda () (return-from here_2 4)) 0) (funcall f) where f => #'(lambda () (return-from here_1 4)) (return-from here_1 4) At the time the funcall is executed there are two block exit points outstanding, each apparently named here. The return-from form executed as a result of the funcall operation refers to the outer outstanding exit point (here_1), not the inner one (here_2). It refers to that exit point textually visible at the point of execution of function (here abbreviated by the #' syntax) that resulted in creation of the function object actually invoked by funcall. If, in this example, one were to change the (funcall f) to (funcall g), then the value of the call (contorted-example nil nil 2) would be 9. The value would change because funcall would cause the execution of (return-from here_2 4), thereby causing a return from the inner exit point (here_2). When that occurs, the value 4 is returned from the middle invocation of contorted-example, 5 is added to that to get 9, and that value is returned from the outer block and the outermost call to contorted-example. The point is that the choice of exit point returned from has nothing to do with its being innermost or outermost; rather, it depends on the lexical environment that is packaged up with a lambda expression when function is executed.  File: gcl.info, Node: Extent, Next: Return Values, Prev: Shadowing, Up: Evaluation 3.1.6 Extent ------------ Contorted-example works only because the function named by f is invoked during the extent of the exit point. Once the flow of execution has left the block, the exit point is disestablished. For example: (defun invalid-example () (let ((y (block here #'(lambda (z) (return-from here z))))) (if (numberp y) y (funcall y 5)))) One might expect the call (invalid-example) to produce 5 by the following incorrect reasoning: let binds y to the value of block; this value is a function resulting from the lambda expression. Because y is not a number, it is invoked on the value 5. The return-from should then return this value from the exit point named here, thereby exiting from the block again and giving y the value 5 which, being a number, is then returned as the value of the call to invalid-example. The argument fails only because exit points have dynamic extent. The argument is correct up to the execution of return-from. The execution of return-from should signal an error of type control-error, however, not because it cannot refer to the exit point, but because it does correctly refer to an exit point and that exit point has been disestablished. A reference by name to a dynamic exit point binding such as a catch tag refers to the most recently established binding of that name that has not been disestablished. For example: (defun fun1 (x) (catch 'trap (+ 3 (fun2 x)))) (defun fun2 (y) (catch 'trap (* 5 (fun3 y)))) (defun fun3 (z) (throw 'trap z)) Consider the call (fun1 7). The result is 10. At the time the throw is executed, there are two outstanding catchers with the name trap: one established within procedure fun1, and the other within procedure fun2. The latter is the more recent, and so the value 7 is returned from catch in fun2. Viewed from within fun3, the catch in fun2 shadows the one in fun1. Had fun2 been defined as (defun fun2 (y) (catch 'snare (* 5 (fun3 y)))) then the two exit points would have different names, and therefore the one in fun1 would not be shadowed. The result would then have been 7.  File: gcl.info, Node: Return Values, Prev: Extent, Up: Evaluation 3.1.7 Return Values ------------------- Ordinarily the result of calling a function is a single object. Sometimes, however, it is convenient for a function to compute several objects and return them. In order to receive other than exactly one value from a form, one of several special forms or macros must be used to request those values. If a form produces multiple values which were not requested in this way, then the first value is given to the caller and all others are discarded; if the form produces zero values, then the caller receives nil as a value. Figure 3-5 lists some operators for receiving multiple values_2. These operators can be used to specify one or more forms to evaluate and where to put the values returned by those forms. multiple-value-bind multiple-value-prog1 return-from multiple-value-call multiple-value-setq throw multiple-value-list return Figure 3-5: Some operators applicable to receiving multiple values The function values can produce multiple values_2. (values) returns zero values; (values form) returns the primary value returned by form; (values form1 form2) returns two values, the primary value of form1 and the primary value of form2; and so on. See multiple-values-limit and values-list.  File: gcl.info, Node: Compilation, Next: Declarations, Prev: Evaluation, Up: Evaluation and Compilation 3.2 Compilation =============== * Menu: * Compiler Terminology:: * Compilation Semantics:: * File Compilation:: * Literal Objects in Compiled Files:: * Exceptional Situations in the Compiler::  File: gcl.info, Node: Compiler Terminology, Next: Compilation Semantics, Prev: Compilation, Up: Compilation 3.2.1 Compiler Terminology -------------------------- The following terminology is used in this section. The compiler is a utility that translates code into an implementation-dependent form that might be represented or executed efficiently. The term compiler refers to both of the functions compile and compile-file. The term compiled code refers to objects representing compiled programs, such as objects constructed by compile or by load when loading a compiled file. The term implicit compilation refers to compilation performed during evaluation. The term literal object refers to a quoted object or a self-evaluating object or an object that is a substructure of such an object. A constant variable is not itself a literal object. The term coalesce is defined as follows. Suppose A and B are two literal constants in the source code, and that A' and B' are the corresponding objects in the compiled code. If A' and B' are eql but A and B are not eql, then it is said that A and B have been coalesced by the compiler. The term minimal compilation refers to actions the compiler must take at compile time. These actions are specified in *note Compilation Semantics::. The verb process refers to performing minimal compilation, determining the time of evaluation for a form, and possibly evaluating that form (if required). The term further compilation refers to implementation-dependent compilation beyond minimal compilation. That is, processing does not imply complete compilation. Block compilation and generation of machine-specific instructions are examples of further compilation. Further compilation is permitted to take place at run time. Four different environments relevant to compilation are distinguished: the startup environment, the compilation environment, the evaluation environment, and the run-time environment. The startup environment is the environment of the Lisp image from which the compiler was invoked. The compilation environment is maintained by the compiler and is used to hold definitions and declarations to be used internally by the compiler. Only those parts of a definition needed for correct compilation are saved. The compilation environment is used as the environment argument to macro expanders called by the compiler. It is unspecified whether a definition available in the compilation environment can be used in an evaluation initiated in the startup environment or evaluation environment. The evaluation environment is a run-time environment in which macro expanders and code specified by eval-when to be evaluated are evaluated. All evaluations initiated by the compiler take place in the evaluation environment. The run-time environment is the environment in which the program being compiled will be executed. The compilation environment inherits from the evaluation environment, and the compilation environment and evaluation environment might be identical. The evaluation environment inherits from the startup environment, and the startup environment and evaluation environment might be identical. The term compile time refers to the duration of time that the compiler is processing source code. At compile time, only the compilation environment and the evaluation environment are available. The term compile-time definition refers to a definition in the compilation environment. For example, when compiling a file, the definition of a function might be retained in the compilation environment if it is declared inline. This definition might not be available in the evaluation environment. The term run time refers to the duration of time that the loader is loading compiled code or compiled code is being executed. At run time, only the run-time environment is available. The term run-time definition refers to a definition in the run-time environment. The term run-time compiler refers to the function compile or implicit compilation, for which the compilation and run-time environments are maintained in the same Lisp image. Note that when the run-time compiler is used, the run-time environment and startup environment are the same.  File: gcl.info, Node: Compilation Semantics, Next: File Compilation, Prev: Compiler Terminology, Up: Compilation 3.2.2 Compilation Semantics --------------------------- Conceptually, compilation is a process that traverses code, performs certain kinds of syntactic and semantic analyses using information (such as proclamations and macro definitions) present in the compilation environment, and produces equivalent, possibly more efficient code. * Menu: * Compiler Macros:: * Purpose of Compiler Macros:: * Naming of Compiler Macros:: * When Compiler Macros Are Used:: * Notes about the Implementation of Compiler Macros:: * Minimal Compilation:: * Semantic Constraints::  File: gcl.info, Node: Compiler Macros, Next: Purpose of Compiler Macros, Prev: Compilation Semantics, Up: Compilation Semantics 3.2.2.1 Compiler Macros ....................... A compiler macro can be defined for a name that also names a function or macro. That is, it is possible for a function name to name both a function and a compiler macro. A function name names a compiler macro if compiler-macro-function is true of the function name in the lexical environment in which it appears. Creating a lexical binding for the function name not only creates a new local function or macro definition, but also shadows_2 the compiler macro. The function returned by compiler-macro-function is a function of two arguments, called the expansion function. To expand a compiler macro, the expansion function is invoked by calling the macroexpand hook with the expansion function as its first argument, the entire compiler macro form as its second argument, and the current compilation environment (or with the current lexical environment, if the form is being processed by something other than compile-file) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The return value from the expansion function, which is passed through by the macroexpand hook, might either be the same form, or else a form that can, at the discretion of the code doing the expansion, be used in place of the original form. *macroexpand-hook* compiler-macro-function define-compiler-macro Figure 3-6: Defined names applicable to compiler macros  File: gcl.info, Node: Purpose of Compiler Macros, Next: Naming of Compiler Macros, Prev: Compiler Macros, Up: Compilation Semantics 3.2.2.2 Purpose of Compiler Macros .................................. The purpose of the compiler macro facility is to permit selective source code transformations as optimization advice to the compiler. When a compound form is being processed (as by the compiler), if the operator names a compiler macro then the compiler macro function may be invoked on the form, and the resulting expansion recursively processed in preference to performing the usual processing on the original form according to its normal interpretation as a function form or macro form. A compiler macro function, like a macro function, is a function of two arguments: the entire call form and the environment. Unlike an ordinary macro function, a compiler macro function can decline to provide an expansion merely by returning a value that is the same as the original form. The consequences are undefined if a compiler macro function destructively modifies any part of its form argument. The form passed to the compiler macro function can either be a list whose car is the function name, or a list whose car is funcall and whose cadr is a list (function name); note that this affects destructuring of the form argument by the compiler macro function. define-compiler-macro arranges for destructuring of arguments to be performed correctly for both possible formats. When compile-file chooses to expand a top level form that is a compiler macro form, the expansion is also treated as a top level form for the purposes of eval-when processing; see *note Processing of Top Level Forms::.  File: gcl.info, Node: Naming of Compiler Macros, Next: When Compiler Macros Are Used, Prev: Purpose of Compiler Macros, Up: Compilation Semantics 3.2.2.3 Naming of Compiler Macros ................................. Compiler macros may be defined for function names that name macros as well as functions. Compiler macro definitions are strictly global. There is no provision for defining local compiler macros in the way that macrolet defines local macros. Lexical bindings of a function name shadow any compiler macro definition associated with the name as well as its global function or macro definition. Note that the presence of a compiler macro definition does not affect the values returned by functions that access function definitions (e.g., fboundp) or macro definitions (e.g., macroexpand). Compiler macros are global, and the function compiler-macro-function is sufficient to resolve their interaction with other lexical and global definitions.  File: gcl.info, Node: When Compiler Macros Are Used, Next: Notes about the Implementation of Compiler Macros, Prev: Naming of Compiler Macros, Up: Compilation Semantics 3.2.2.4 When Compiler Macros Are Used ..................................... The presence of a compiler macro definition for a function or macro indicates that it is desirable for the compiler to use the expansion of the compiler macro instead of the original function form or macro form. However, no language processor (compiler, evaluator, or other code walker) is ever required to actually invoke compiler macro functions, or to make use of the resulting expansion if it does invoke a compiler macro function. When the compiler encounters a form during processing that represents a call to a compiler macro name (that is not declared notinline), the compiler might expand the compiler macro, and might use the expansion in place of the original form. When eval encounters a form during processing that represents a call to a compiler macro name (that is not declared notinline), eval might expand the compiler macro, and might use the expansion in place of the original form. There are two situations in which a compiler macro definition must not be applied by any language processor: * The global function name binding associated with the compiler macro is shadowed by a lexical binding of the function name. * The function name has been declared or proclaimed notinline and the call form appears within the scope of the declaration. It is unspecified whether compiler macros are expanded or used in any other situations. gcl-2.6.14/info/compiler-defs.texi0000755000175000017500000001144014360276512015355 0ustar cammcamm @node Compiler Definitions, Function and Variable Index, Miscellaneous, Top @chapter Compiler Definitions @defun EMIT-FN (turn-on) Package:COMPILER If TURN-ON is t, the subsequent calls to COMPILE-FILE will cause compilation of foo.lisp to emit a foo.fn as well as foo.o. The .fn file contains cross referencing information as well as information useful to the collection utilities in cmpnew/collectfn This latter file must be manually loaded to call emit-fn. @end defun @defvar *CMPINCLUDE-STRING* Package:COMPILER If it is a string it holds the text of the cmpinclude.h file appropriate for this version. Otherwise the usual #include of *cmpinclude* will be used. To disable this feature set *cmpinclude-string* to NIL in the init-form. @end defvar @defun EMIT-FN (turn-on) Package:COMPILER If TURN-ON is t, then subsequent calls to compile-file on a file foo.lisp cause output of a file foo.fn. This .fn file contains lisp structures describing the functions in foo.lisp. Some tools for analyzing this data base are WHO-CALLS, LIST-UNDEFINED-FUNCTIONS, LIST-UNCALLED-FUNCTIONS, and MAKE-PROCLAIMS. Usage: (compiler::emit-fn t) (compile-file "foo1.lisp") (compile-file "foo2.lisp") This would create foo1.fn and foo2.fn. These may be loaded using LOAD. Each time compile-file is called the data base is cleared. Immediately after the compilation, the data base consists of data from the compilation. Thus if you wished to find functions called but not defined in the current file, you could do (list-undefined-functions), immediately following the compilation. If you have a large system, you would load all the .fn files before using the above tools. @end defun @defun MAKE-ALL-PROCLAIMS (&rest directories) Package:COMPILER For each D in DIRECTORIES all files in (directory D) are loaded. For example (make-all-proclaims "lsp/*.fn" "cmpnew/*.fn") would load any files in lsp/*.fn and cmpnew/*.fn. [See EMIT-FN for details on creation of .fn files] Then calculations on the newly loaded .fn files are made, to determine function proclamations. If number of values of a function cannot be determined [for example because of a final funcall, or call of a function totally unknown at this time] then return type * is assigned. Finally a file sys-proclaim.lisp is written out. This file contains function proclamations. (load "sys-proclaim.lisp") (compile-file "foo1.lisp") (compile-file "foo2.lisp") @end defun @defun MAKE-PROCLAIMS (&optional (stream *standard-output*)) Package:COMPILER Write to STREAM the function proclaims from the current data base. Usually a number of .fn files are loaded prior to running this. See EMIT-FN for details on how to collect this. Simply use LOAD to load in .fn files. @end defun @defun LIST-UNDEFINED-FUNCTIONS () Package:COMPILER Return a list of all functions called but not defined, in the current data base (see EMIT-FN). @example Sample: (compiler::emit-fn t) (compile-file "foo1.lisp") (compiler::list-undefined-functions) or (mapcar 'load (directory "*.fn")) (compiler::list-undefined-functions) @end example @end defun @defun WHO-CALLS (function-name) Package:COMPILER List all functions in the data base [see emit-fn] which call FUNCTION-NAME. @end defun @defun LIST-UNCALLED-FUNCTIONS () Package:COMPILER Examine the current data base [see emit-fn] for any functions or macros which are called but are not: fboundp, OR defined in the data base, OR having special compiler optimizer properties which would eliminate an actual call. @end defun @defvar *CC* Package:COMPILER Has value a string which controls which C compiler is used by GCL. Usually this string is obtained from the machine.defs file, but may be reset by the user, to change compilers or add an include path. @end defvar @defvar *SPLIT-FILES* Package:COMPILER This affects the behaviour of compile-file, and is useful for cases where the C compiler cannot handle large C files resulting from lisp compilation. This scheme should allow arbitrarily long lisp files to be compiled. If the value [default NIL] is a positive integer, then the source file will be compiled into several object files whose names have 0,1,2,.. prepended, and which will be loaded by the main object file. File 0 will contain compilation of top level forms thru position *split-files* in the lisp source file, and file 1 the next forms, etc. Thus a 180k file would probably result in three object files (plus the master object file of the same name) if *split-files* was set to 60000. The package information will be inserted in each file. @end defvar @defvar *COMPILE-ORDINARIES* Package:COMPILER If this has a non nil value [default = nil], then all top level forms will be compiled into machine instructions. Otherwise only defun's, defmacro's, and top level forms beginning with (progn 'compile ...) will do so. @end defvar gcl-2.6.14/info/gcl-si/0000755000175000017500000000000014360276512013104 5ustar cammcammgcl-2.6.14/info/gcl-si/Doc.html0000644000175000017500000001414614360276512014505 0ustar cammcamm Doc (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

13 Doc

Function: APROPOS (string &optional (package nil))

Package:LISP

Prints those symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched.

Function: INFO (string &optional (list-of-info-files *default-info-files*))

PACKAGE:SI

Find all documentation about STRING in LIST-OF-INFO-FILES. The search is done for STRING as a substring of a node name, or for STRING in the indexed entries in the first index for each info file. Typically that should be a variable and function definition index, if the info file is about a programming language. If the windowing system is connected, then a choice box is offered and double clicking on an item brings up its documentation.

Otherwise a list of choices is offered and the user may select some of these choices.

list-of-info-files is of the form 

 ("gcl-si.info" "gcl-tk.info" "gcl.info")

The above list is the default value of *default-info-files*, a variable in the SI package. To find these files in the file system, the search path *info-paths* is consulted as is the master info directory dir.

see *Index *default-info-files*:: and *Index *info-paths*::. For example 

(info "defun")

 0: DEFUN :(gcl-si.info)Special Forms and Functions.
 1: (gcl.info)defun.
Enter n, all, none, or multiple choices eg 1 3 : 1

Info from file /home/wfs/gcl-doc/gcl.info:
defun                                                               [Macro]
---------------------------------------------------------------------------
`Defun'  function-name lambda-list [[{declaration}* | documentation]]
...

would list the node (gcl.info)defun. That is the node entitled defun from the info file gcl.info. That documentation is based on the ANSI common lisp standard. The choice 

DEFUN :(gcl-si.info)Special Forms and Functions.

refers to the documentation on DEFUN from the info file gcl-si.info in the node Special Forms And Functions. This is an index reference and only the part of the node which refers to defun will be printed. 

(info "factor" '("maxima.info"))

would search the maxima info files index and nodes for factor.

Variable: *info-paths*

Package SI:

A list of strings such as 

  '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/"
    "/usr/local/gnu/info/" )

saying where to look for the info files. It is used implicitly by info, see *Index info::.

Looking for maxima.info would look for the file maxima.info in all the directories listed in *info-paths*. If nto found then it would look for dir in the *info-paths* directories, and if it were found it would look in the dir for a menu item such as 

* maxima: (/home/wfs/maxima-5.0/info/maxima.info).

If such an entry exists then the directory there would be used for the purpose of finding maxima.info

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Debugging.html0000644000175000017500000000517514360276512015675 0ustar cammcamm Debugging (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

18 Debugging

• Source Level Debugging in Emacs  
• Low Level Debug Functions  
gcl-2.6.14/info/gcl-si/User-Interface.html0000644000175000017500000003231714360276512016614 0ustar cammcamm User Interface (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

12 User Interface

Special Variable: -

Package:LISP Holds the top-level form that GCL is currently evaluating.

Function: - (number &rest more-numbers)

Package:LISP

Subtracts the second and all subsequent NUMBERs from the first NUMBER. With one arg, negates it.

Macro: UNTRACE

Package:LISP

Syntax: 

(untrace {function-name}*)

Removes tracing from the specified functions. With no FUNCTION-NAMEs, untraces all functions.

Variable: ***

Package:LISP Gets the previous value of ** when GCL evaluates a top-level form.

Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string)))

Package:LISP

Returns an input stream which will supply the characters of String between Start and End in order.

Macro: STEP

Package:LISP

Syntax: 

(step form)

Evaluates FORM in the single-step mode and returns the value.

Variable: *BREAK-ENABLE*

Package:LISP GCL specific: When an error occurrs, control enters to the break loop only if the value of this variable is non-NIL.

Special Variable: /

Package:LISP Holds a list of the values of the last top-level form.

Function: DESCRIBE (x)

Package:LISP

Prints a description of the object X.

Function: ED (&optional x)

Package:LISP

Invokes the editor. The action depends on the version of GCL.

Variable: *DEBUG-IO*

Package:LISP Holds the I/O stream used by the GCL debugger.

Variable: *BREAK-ON-WARNINGS*

Package:LISP When the function WARN is called, control enters to the break loop only if the value of this varialbe is non-NIL.

Function: CERROR (continue-format-string error-format-string &rest args)

Package:LISP

Signals a correctable error.

Variable: **

Package:LISP Gets the previous value of * when GCL evaluates a top-level form.

Special Variable: +++

Package:LISP Gets the previous value of ++ when GCL evaluates a top-level form.

Function: INSPECT (x)

Package:LISP

Shows the information about the object X in an interactive manner

Special Variable: //

Package:LISP Gets the previous value of / when GCL evaluates a top-level form.

Variable: *TRACE-OUTPUT*

Package:LISP The trace output stream.

Special Variable: ++

Package:LISP Gets the previous value of + when GCL evaluates a top-level form.

Variable: *ERROR-OUTPUT*

Package:LISP Holds the output stream for error messages.

Function: DRIBBLE (&optional pathname)

Package:LISP

If PATHNAME is given, begins to record the interaction to the specified file. If PATHNAME is not given, ends the recording.

Variable: *

Package:LISP Holds the value of the last top-level form.

Special Variable: ///

Package:LISP Gets the previous value of // when GCL evaluates a top-level form.

Function: WARN (format-string &rest args)

Package:LISP

Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message.

Function: BREAK (&optional (format-string nil) &rest args)

Package:LISP

Enters a break loop. If FORMAT-STRING is non-NIL, formats FORMAT-STRING and ARGS to *ERROR-OUTPUT* before entering a break loop. Typing :HELP at the break loop will list the break-loop commands.

Special Variable: +

Package:LISP Holds the last top-level form.

Macro: TRACE

Package:LISP

Syntax: 

(trace {function-name}*)

Traces the specified functions. With no FUNCTION-NAMEs, returns a list of functions currently being traced.

Additional Keywords are allowed in GCL with the syntax (trace {fn | (fn {:kw form}*)}*)

For each FN naming a function, traces that function. Each :KW should be one of the ones listed below, and FORM should have the corresponding form. No :KW may be given more than once for the same FN. Returns a list of all FNs now traced which weren’t already traced.

EXAMPLE (Try this with your favorite factorial function FACT): 

;; print entry args and exit values

(trace FACT)

;; Break coming out of FACT if the value is bigger than 1000.

(trace (fact :exit
	     (progn
	       (if (> (car values) 1000)(break "big result"))
	       (car values))))

;; Hairy example:

;;make arglist available without the si:: prefix
(import 'si::arglist)

(trace (fact
        :DECLARATIONS
        ((in-string "Here comes input: ")
         (out-string "Here comes output: ")
         all-values
         (silly (+ 3 4)))
        :COND
        (equal (rem (car arglist) 2) 0)
        :ENTRY
        (progn
          (cond
           ((equal (car arglist) 8)
            (princ "Entering FACT on input 8!! ")
            (setq out-string "Here comes output from inside (FACT 8): "))
           (t
            (princ in-string)))
          (car arglist))
        :EXIT
        (progn
          (setq all-values (cons (car values) all-values))
          (princ out-string)
          (when (equal (car arglist) 8)
                ;; reset out-string
                (setq out-string "Here comes output: "))
          (cons 'fact values))
        :ENTRYCOND
        (not (= (car arglist) 6))
        :EXITCOND
        (not (= (car values) (* 6 (car arglist))))
        :DEPTH
        5))

Syntax is :keyword form1 :keyword form2 ...

:declarations
DEFAULT: NIL

FORM is ((var1 form1 )(var2 form2 )...), where the var_i are symbols distinct from each other and from all symbols which are similarly declared for currently traced functions. Each form is evaluated immediately. Upon any invocation of a traced function when not already inside a traced function call, each var is bound to that value of form .

:COND
DEFAULT: T

Here, FORM is any Lisp form to be evaluated (by EVAL) upon entering a call of FN, in the environment where si::ARGLIST is bound to the current list of arguments of FN. Note that even if the evaluation of FORM changes the value of SI::ARGLIST (e.g. by evaluation of (SETQ si::ARGLIST ...)), the list of arguments passed to FN is unchanged. Users may alter args passed by destructively modifying the list structure of SI::ARGLIST however. The call is traced (thus invoking the :ENTRYCOND and :EXITCOND forms, at least) if and only if FORM does not evaluate to NIL.

:ENTRYCOND
DEFAULT: T

This is evaluated (by EVAL) if the :COND form evaluates to non-NIL, both in an environment where SI::ARGLIST is bound to the current list of arguments of FN. If non-NIL, the :ENTRY form is then evaluated and printed with the trace "prompt".

:ENTRY
DEFAULT: (CONS (QUOTE x) SI::ARGLIST),

where x is the symbol we call FN If the :COND and :ENTRYCOND forms evaluate to non-NIL, then the trace "prompt" is printed and then this FORM is evaluated (by EVAL) in an environment where SI::ARGLIST is bound to the current list of arguments of FN. The result is then printed.

:EXITCOND
DEFAULT: T

This is evaluated (by EVAL) in the environment described below for the :EXIT form. The :EXIT form is then evaluated and printed with the "prompt" if and only if the result here is non-NIL.

:EXIT
DEFAULT: (CONS (QUOTE x) VALUES),

where x is the symbol we call FN Upon exit from tracing a given call, this FORM is evaluated (after the appropriate trace "prompt" is printed), using EVAL in an environment where SI::ARGLIST is bound to the current list of arguments of FN and VALUES is bound to the list of values returned by FN (recalling that Common Lisp functions may return multiple values).

:DEPTH
DEFAULT:  No depth limit

FORM is simply a positive integer specifying the maximum nesting of traced calls of FN, i.e. of calls of FN in which the :COND form evaluated to non-NIL. For calls of FN in which this limit is exceeded, even the :COND form is not evaluated, and the call is not traced.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Lists.html0000644000175000017500000005774114360276512015106 0ustar cammcamm Lists (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

4 Lists

Function: NINTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the intersection of LIST1 and LIST2. LIST1 may be destroyed.

Function: RASSOC-IF (predicate alist)

Package:LISP

Returns the first cons in ALIST whose cdr satisfies PREDICATE.

Function: MAKE-LIST (size &key (initial-element nil))

Package:LISP

Creates and returns a list containing SIZE elements, each of which is initialized to INITIAL-ELEMENT.

Function: NTH (n list)

Package:LISP

Returns the N-th element of LIST, where the car of LIST is the zeroth element.

Function: CAAR (x)

Package:LISP

Equivalent to (CAR (CAR X)).

Function: NULL (x)

Package:LISP

Returns T if X is NIL; NIL otherwise.

Function: FIFTH (x)

Package:LISP

Equivalent to (CAR (CDDDDR X)).

Function: NCONC (&rest lists)

Package:LISP

Concatenates LISTs by destructively modifying them.

Function: TAILP (sublist list)

Package:LISP

Returns T if SUBLIST is one of the conses in LIST; NIL otherwise.

Function: CONSP (x)

Package:LISP

Returns T if X is a cons; NIL otherwise.

Function: TENTH (x)

Package:LISP

Equivalent to (CADR (CDDDDR (CDDDDR X))).

Function: LISTP (x)

Package:LISP

Returns T if X is either a cons or NIL; NIL otherwise.

Function: MAPCAN (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cars of LISTs, NCONCs the results, and returns it.

Function: EIGHTH (x)

Package:LISP

Equivalent to (CADDDR (CDDDDR X)).

Function: LENGTH (sequence)

Package:LISP

Returns the length of SEQUENCE.

Function: RASSOC (item alist &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the first cons in ALIST whose cdr is equal to ITEM.

Function: NSUBST-IF-NOT (new test tree &key (key #'identity))

Package:LISP

Substitutes NEW for subtrees of TREE that do not satisfy TEST.

Function: NBUTLAST (list &optional (n 1))

Package:LISP

Changes the cdr of the N+1 th cons from the end of the list LIST to NIL. Returns the whole list.

Function: CDR (list)

Package:LISP

Returns the cdr of LIST. Returns NIL if LIST is NIL.

Function: MAPC (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cars of LISTs. Returns the first LIST.

Function: MAPL (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cdrs of LISTs. Returns the first LIST.

Function: CONS (x y)

Package:LISP

Returns a new cons whose car and cdr are X and Y, respectively.

Function: LIST (&rest args)

Package:LISP

Returns a list of its arguments

Function: THIRD (x)

Package:LISP

Equivalent to (CADDR X).

Function: CDDAAR (x)

Package:LISP

Equivalent to (CDR (CDR (CAR (CAR X)))).

Function: CDADAR (x)

Package:LISP

Equivalent to (CDR (CAR (CDR (CAR X)))).

Function: CDAADR (x)

Package:LISP

Equivalent to (CDR (CAR (CAR (CDR X)))).

Function: CADDAR (x)

Package:LISP

Equivalent to (CAR (CDR (CDR (CAR X)))).

Function: CADADR (x)

Package:LISP

Equivalent to (CAR (CDR (CAR (CDR X)))).

Function: CAADDR (x)

Package:LISP

Equivalent to (CAR (CAR (CDR (CDR X)))).

Function: NTHCDR (n list)

Package:LISP

Returns the result of performing the CDR operation N times on LIST.

Function: PAIRLIS (keys data &optional (alist nil))

Package:LISP

Constructs an association list from KEYS and DATA adding to ALIST.

Function: SEVENTH (x)

Package:LISP

Equivalent to (CADDR (CDDDDR X)).

Function: SUBSETP (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns T if every element of LIST1 appears in LIST2; NIL otherwise.

Function: NSUBST-IF (new test tree &key (key #'identity))

Package:LISP

Substitutes NEW for subtrees of TREE that satisfy TEST.

Function: COPY-LIST (list)

Package:LISP

Returns a new copy of LIST.

Function: LAST (list)

Package:LISP

Returns the last cons in LIST

Function: CAAAR (x)

Package:LISP

Equivalent to (CAR (CAR (CAR X))).

Function: LIST-LENGTH (list)

Package:LISP

Returns the length of LIST, or NIL if LIST is circular.

Function: CDDDR (x)

Package:LISP

Equivalent to (CDR (CDR (CDR X))).

Function: INTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the intersection of List1 and List2.

Function: NSUBST (new old tree &key (test #'eql) test-not (key #'identity))

Package:LISP

Substitutes NEW for subtrees in TREE that match OLD.

Function: REVAPPEND (x y)

Package:LISP

Equivalent to (APPEND (REVERSE X) Y)

Function: CDAR (x)

Package:LISP

Equivalent to (CDR (CAR X)).

Function: CADR (x)

Package:LISP

Equivalent to (CAR (CDR X)).

Function: REST (x)

Package:LISP

Equivalent to (CDR X).

Function: NSET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns a list with elements which appear but once in LIST1 and LIST2.

Function: ACONS (key datum alist)

Package:LISP

Constructs a new alist by adding the pair (KEY . DATUM) to ALIST.

Function: SUBST-IF-NOT (new test tree &key (key #'identity))

Package:LISP

Substitutes NEW for subtrees of TREE that do not satisfy TEST.

Function: RPLACA (x y)

Package:LISP

Replaces the car of X with Y, and returns the modified X.

Function: SECOND (x)

Package:LISP

Equivalent to (CADR X).

Function: NUNION (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the union of LIST1 and LIST2. LIST1 and/or LIST2 may be destroyed.

Function: BUTLAST (list &optional (n 1))

Package:LISP

Creates and returns a list with the same elements as LIST but without the last N elements.

Function: COPY-ALIST (alist)

Package:LISP Returns a new copy of ALIST.

Function: SIXTH (x)

Package:LISP Equivalent to (CADR (CDDDDR X)).

Function: CAAAAR (x)

Package:LISP

Equivalent to (CAR (CAR (CAR (CAR X)))).

Function: CDDDAR (x)

Package:LISP

Equivalent to (CDR (CDR (CDR (CAR X)))).

Function: CDDADR (x)

Package:LISP

Equivalent to (CDR (CDR (CAR (CDR X)))).

Function: CDADDR (x)

Package:LISP

Equivalent to (CDR (CAR (CDR (CDR X)))).

Function: CADDDR (x)

Package:LISP

Equivalent to (CAR (CDR (CDR (CDR X)))).

Function: FOURTH (x)

Package:LISP

Equivalent to (CADDDR X).

Function: NSUBLIS (alist tree &key (test #'eql) test-not (key #'identity))

Package:LISP

Substitutes from ALIST for subtrees of TREE.

Function: SUBST-IF (new test tree &key (key #'identity))

Package:LISP

Substitutes NEW for subtrees of TREE that satisfy TEST.

Function: NSET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns a list of elements of LIST1 that do not appear in LIST2. LIST1 may be destroyed.

Special Form: POP

Package:LISP

Syntax: 

(pop place)

Pops one item off the front of the list in PLACE and returns it.

Special Form: PUSH

Package:LISP

Syntax: 

(push item place)

Conses ITEM onto the list in PLACE, and returns the new list.

Function: CDAAR (x)

Package:LISP

Equivalent to (CDR (CAR (CAR X))).

Function: CADAR (x)

Package:LISP

Equivalent to (CAR (CDR (CAR X))).

Function: CAADR (x)

Package:LISP

Equivalent to (CAR (CAR (CDR X))).

Function: FIRST (x)

Package:LISP

Equivalent to (CAR X).

Function: SUBST (new old tree &key (test #'eql) test-not (key #'identity))

Package:LISP

Substitutes NEW for subtrees of TREE that match OLD.

Function: ADJOIN (item list &key (test #'eql) test-not (key #'identity))

Package:LISP

Adds ITEM to LIST unless ITEM is already a member of LIST.

Function: MAPCON (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cdrs of LISTs, NCONCs the results, and returns it.

Macro: PUSHNEW

Package:LISP

Syntax: 

(pushnew item place {keyword value}*)

If ITEM is already in the list stored in PLACE, does nothing. Else, conses ITEM onto the list. Returns NIL. If no KEYWORDs are supplied, each element in the list is compared with ITEM by EQL, but the comparison can be controlled by supplying keywords :TEST, :TEST-NOT, and/or :KEY.

Function: SET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns a list of elements appearing exactly once in LIST1 and LIST2.

Function: TREE-EQUAL (x y &key (test #'eql) test-not)

Package:LISP

Returns T if X and Y are isomorphic trees with identical leaves.

Function: CDDR (x)

Package:LISP

Equivalent to (CDR (CDR X)).

Function: GETF (place indicator &optional (default nil))

Package:LISP

Searches the property list stored in Place for an indicator EQ to Indicator. If one is found, the corresponding value is returned, else the Default is returned.

Function: LDIFF (list sublist)

Package:LISP

Returns a new list, whose elements are those of LIST that appear before SUBLIST. If SUBLIST is not a tail of LIST, a copy of LIST is returned.

Function: UNION (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the union of LIST1 and LIST2.

Function: ASSOC-IF-NOT (test alist)

Package:LISP

Returns the first pair in ALIST whose car does not satisfy TEST.

Function: RPLACD (x y)

Package:LISP

Replaces the cdr of X with Y, and returns the modified X.

Function: MEMBER-IF-NOT (test list &key (key #'identity))

Package:LISP

Returns the tail of LIST beginning with the first element not satisfying TEST.

Function: CAR (list)

Package:LISP

Returns the car of LIST. Returns NIL if LIST is NIL.

Function: ENDP (x)

Package:LISP

Returns T if X is NIL. Returns NIL if X is a cons. Otherwise, signals an error.

Function: LIST* (arg &rest others)

Package:LISP

Returns a list of its arguments with the last cons being a dotted pair of the next to the last argument and the last argument.

Function: NINTH (x)

Package:LISP

Equivalent to (CAR (CDDDDR (CDDDDR X))).

Function: CDAAAR (x)

Package:LISP

Equivalent to (CDR (CAR (CAR (CAR X)))).

Function: CADAAR (x)

Package:LISP

Equivalent to (CAR (CDR (CAR (CAR X)))).

Function: CAADAR (x)

Package:LISP

Equivalent to (CAR (CAR (CDR (CAR X)))).

Function: CAAADR (x)

Package:LISP

Equivalent to (CAR (CAR (CAR (CDR X)))).

Function: CDDDDR (x)

Package:LISP

Equivalent to (CDR (CDR (CDR (CDR X)))).

Function: SUBLIS (alist tree &key (test #'eql) test-not (key #'identity))

Package:LISP

Substitutes from ALIST for subtrees of TREE nondestructively.

Function: RASSOC-IF-NOT (predicate alist)

Package:LISP

Returns the first cons in ALIST whose cdr does not satisfy PREDICATE.

Function: NRECONC (x y)

Package:LISP

Equivalent to (NCONC (NREVERSE X) Y).

Function: MAPLIST (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cdrs of LISTs and returns the results as a list.

Function: SET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns a list of elements of LIST1 that do not appear in LIST2.

Function: ASSOC-IF (test alist)

Package:LISP

Returns the first pair in ALIST whose car satisfies TEST.

Function: GET-PROPERTIES (place indicator-list)

Package:LISP

Looks for the elements of INDICATOR-LIST in the property list stored in PLACE. If found, returns the indicator, the value, and T as multiple-values. If not, returns NILs as its three values.

Function: MEMBER-IF (test list &key (key #'identity))

Package:LISP

Returns the tail of LIST beginning with the first element satisfying TEST.

Function: COPY-TREE (object)

Package:LISP

Recursively copies conses in OBJECT and returns the result.

Function: ATOM (x)

Package:LISP

Returns T if X is not a cons; NIL otherwise.

Function: CDDAR (x)

Package:LISP

Equivalent to (CDR (CDR (CAR X))).

Function: CDADR (x)

Package:LISP

Equivalent to (CDR (CAR (CDR X))).

Function: CADDR (x)

Package:LISP

Equivalent to (CAR (CDR (CDR X))).

Function: ASSOC (item alist &key (test #'eql) test-not)

Package:LISP

Returns the first pair in ALIST whose car is equal (in the sense of TEST) to ITEM.

Function: APPEND (&rest lists)

Package:LISP

Constructs a new list by concatenating its arguments.

Function: MEMBER (item list &key (test #'eql) test-not (key #'identity))

Package:LISP

Returns the tail of LIST beginning with the first ITEM.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Compiler-Definitions.html0000644000175000017500000002106614360276512020022 0ustar cammcamm Compiler Definitions (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

20 Compiler Definitions

Function: EMIT-FN (turn-on)

Package:COMPILER

If TURN-ON is t, the subsequent calls to COMPILE-FILE will cause compilation of foo.lisp to emit a foo.fn as well as foo.o. The .fn file contains cross referencing information as well as information useful to the collection utilities in cmpnew/collectfn This latter file must be manually loaded to call emit-fn.

Variable: *CMPINCLUDE-STRING*

Package:COMPILER If it is a string it holds the text of the cmpinclude.h file appropriate for this version. Otherwise the usual #include of *cmpinclude* will be used. To disable this feature set *cmpinclude-string* to NIL in the init-form.

Function: EMIT-FN (turn-on)

Package:COMPILER

If TURN-ON is t, then subsequent calls to compile-file on a file foo.lisp cause output of a file foo.fn. This .fn file contains lisp structures describing the functions in foo.lisp. Some tools for analyzing this data base are WHO-CALLS, LIST-UNDEFINED-FUNCTIONS, LIST-UNCALLED-FUNCTIONS, and MAKE-PROCLAIMS.

Usage: (compiler::emit-fn t) (compile-file "foo1.lisp") (compile-file "foo2.lisp")

This would create foo1.fn and foo2.fn. These may be loaded using LOAD. Each time compile-file is called the data base is cleared. Immediately after the compilation, the data base consists of data from the compilation. Thus if you wished to find functions called but not defined in the current file, you could do (list-undefined-functions), immediately following the compilation. If you have a large system, you would load all the .fn files before using the above tools.

Function: MAKE-ALL-PROCLAIMS (&rest directories)

Package:COMPILER

For each D in DIRECTORIES all files in (directory D) are loaded.

For example (make-all-proclaims "lsp/*.fn" "cmpnew/*.fn") would load any files in lsp/*.fn and cmpnew/*.fn.

[See EMIT-FN for details on creation of .fn files]

Then calculations on the newly loaded .fn files are made, to determine function proclamations. If number of values of a function cannot be determined [for example because of a final funcall, or call of a function totally unknown at this time] then return type * is assigned.

Finally a file sys-proclaim.lisp is written out. This file contains function proclamations.

(load "sys-proclaim.lisp") (compile-file "foo1.lisp") (compile-file "foo2.lisp")

Function: MAKE-PROCLAIMS (&optional (stream *standard-output*))

Package:COMPILER

Write to STREAM the function proclaims from the current data base. Usually a number of .fn files are loaded prior to running this. See EMIT-FN for details on how to collect this. Simply use LOAD to load in .fn files.

Function: LIST-UNDEFINED-FUNCTIONS ()

Package:COMPILER

Return a list of all functions called but not defined, in the current data base (see EMIT-FN). 

Sample:
(compiler::emit-fn t)
(compile-file "foo1.lisp")
(compiler::list-undefined-functions)
or
(mapcar 'load (directory "*.fn")) (compiler::list-undefined-functions)
Function: WHO-CALLS (function-name)

Package:COMPILER

List all functions in the data base [see emit-fn] which call FUNCTION-NAME.

Function: LIST-UNCALLED-FUNCTIONS ()

Package:COMPILER

Examine the current data base [see emit-fn] for any functions or macros which are called but are not: fboundp, OR defined in the data base, OR having special compiler optimizer properties which would eliminate an actual call.

Variable: *CC*

Package:COMPILER Has value a string which controls which C compiler is used by GCL. Usually this string is obtained from the machine.defs file, but may be reset by the user, to change compilers or add an include path.

Variable: *SPLIT-FILES*

Package:COMPILER This affects the behaviour of compile-file, and is useful for cases where the C compiler cannot handle large C files resulting from lisp compilation. This scheme should allow arbitrarily long lisp files to be compiled.

If the value [default NIL] is a positive integer, then the source file will be compiled into several object files whose names have 0,1,2,.. prepended, and which will be loaded by the main object file. File 0 will contain compilation of top level forms thru position *split-files* in the lisp source file, and file 1 the next forms, etc. Thus a 180k file would probably result in three object files (plus the master object file of the same name) if *split-files* was set to 60000. The package information will be inserted in each file.

Variable: *COMPILE-ORDINARIES*

Package:COMPILER If this has a non nil value [default = nil], then all top level forms will be compiled into machine instructions. Otherwise only defun’s, defmacro’s, and top level forms beginning with (progn ’compile ...) will do so.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/GCL-Specific.html0000644000175000017500000003017714360276512016132 0ustar cammcamm GCL Specific (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

15 GCL Specific

Function: SYSTEM (string)

Package:LISP

GCL specific: Executes a Shell command as if STRING is an input to the Shell. Not all versions of GCL support this function. At least on POSIX systems, this call should return two integers represeting the exit status and any possible terminating signal respectively.

Variable: *TMP-DIR*

Package:COMPILER GCL specific: Directory in which temporary “gazonk” files used by the compiler are to be created.

Variable: *IGNORE-MAXIMUM-PAGES*

Package:SI GCL specific: Tells the GCL memory manager whether (non-NIL) or not (NIL) it should expand memory whenever the maximum allocatable pages have been used up.

Variable: *OPTIMIZE-MAXIMUM-PAGES*

Package:SI

GCL specific: Tells the GCL memory manager whether to attempt to adjust the maximum allowable pages for each type to approximately optimize the garbage collection load in the current process. Defaults to T. Set to NIL if you care more about memory usage than runtime.

Function: MACHINE-VERSION ()

Package:LISP

Returns a string that identifies the machine version of the machine on which GCL is currently running.

Function: BY ()

Package:LISP

GCL specific: Exits from GCL.

Macro: DEFCFUN

Package:LISP

Syntax: 

(defcfun header n {element}*)

GCL specific: Defines a C-language function which calls Lisp functions and/or handles Lisp objects. HEADER gives the header of the C function as a string. Non-negative-integer is the number of the main stack entries used by the C function, primarily for protecting Lisp objects from being garbage-collected. Each ELEMENT may give a C code fragment as a string, or it may be a list ((symbol {arg}*) {place}*) which, when executed, calls the Lisp function named by SYMBOL with the specified arguments and saves the value(s) to the specified places. The DEFCFUN form has the above meanings only after compiled; The GCL interpreter simply ignores this form.

An example which defines a C function list2 of two arguments, but which calls the ’lisp’ function CONS by name, and refers to the constant ’NIL. Note to be loaded by load the function should be static.

(defCfun "static object list2(x,y) object x,y;" 0 "object z;" (’NIL z) ((CONS y z) z) ((CONS x z) z) "return(z);" )

In lisp the operations in the body would be (setq z ’nil) (setq z (cons y z)) (setq z (cons x z))

Syntax: 


        (defCfun header non-negative-integer
                { string
                  | ( function-symbol { value }* )
                  | (( function-symbol  { value }* ) { place }* ) })


value:
place:
         { C-expr | ( C-type C-expr ) }

C-function-name:
C-expr:
         { string | symbol }
 
C-type:
         { object | int | char | float | double }
Macro: CLINES

Package:LISP

Syntax: 

(clines {string}*)

GCL specific: The GCL compiler embeds STRINGs into the intermediate C language code. The interpreter ignores this form.

Function: ALLOCATE (type number &optional (really-allocate nil))

Package:LISP

GCL specific: Sets the maximum number of pages for the type class of the GCL implementation type TYPE to NUMBER. If REALLY-ALLOCATE is given a non-NIL value, then the specified number of pages will be allocated immediately.

Function: GBC (x)

Package:LISP

GCL specific: Invokes the garbage collector (GC) with the collection level specified by X. NIL as the argument causes GC to collect cells only. T as the argument causes GC to collect everything.

Function: SAVE (pathname)

Package:LISP

GCL specific: Saves the current GCL core image into a program file specified by PATHNAME. This function depends on the version of GCL. The function si::save-system is to be preferred in almost all circumstances. Unlike save, it makes the relocatable section permanent, and causes no future gc of currently loaded .o files.

Function: HELP* (string &optional (package 'lisp))

Package:LISP

GCL specific: Prints the documentation associated with those symbols in the specified package whose print names contain STRING as substring. STRING may be a symbol, in which case the print-name of that symbol is used. If PACKAGE is NIL, then all packages are searched.

Macro: DEFLA

Package:LISP

Syntax: 

(defla name lambda-list {decl | doc}* {form}*)

GCL specific: Used to DEFine Lisp Alternative. For the interpreter, DEFLA is equivalent to DEFUN, but the compiler ignores this form.

Function: PROCLAMATION (decl-spec)

Package:LISP

GCL specific: Returns T if the specified declaration is globally in effect; NIL otherwise. See the doc of DECLARE for possible DECL-SPECs.

Macro: DEFENTRY

Package:LISP

Syntax: 

(defentry name arg-types c-function)

GCL specific: The compiler defines a Lisp function whose body consists of a calling sequence to the C language function specified by C-FUNCTION. The interpreter ignores this form. The ARG-TYPES specifies the C types of the arguments which C-FUNCTION requires. The list of allowed types is (object char int float double string). Code will be produced to coerce from a lisp object to the appropriate type before passing the argument to the C-FUNCTION. The c-function should be of the form (c-result-type c-fname) where c-result-type is a member of (void object char int float double string). c-fname may be a symbol (in which case it will be downcased) or a string. If c-function is not a list, then (object c-function) is assumed. In order for C code to be loaded in by load you should declare any variables and functions to be static. If you will link them in at build time, of course you are allowed to define new externals. 

  Sample usage:
--File begin-----
;; JOE takes X a lisp string and Y a fixnum and returns a character.
(clines "#include \"foo.ch\"")
(defentry joe (string int) (char "our_c_fun"))
---File end------
---File foo.ch---
/* C function for extracting the i'th element of a string */
static char our_c_fun(p,i)
char *p;
int i;
   {
	return p[i];
   }
-----File end---

One must be careful of storage allocation issues when passing a string. If the C code invokes storage allocation (either by calling malloc or make_cons etc), then there is a possibility of a garbage collection, so that if the string passed was not constructed with :static t when its array was constructed, then it could move. If the C function may allocate storage, then you should pass a copy: 

(defun safe-c-string (x)
  (let* ((n (length x))
         (a (make-array (+ n 1) :element-type 'string-char
           :static t :fill-pointer n)))
    (si::copy-array-portion x y 0 0 n)
    (setf (aref a n) (code-char 0)))
    a)
Function: COPY-ARRAY-PORTION (x,y,i1,i2,n1)

Package:SI Copy elements from X to Y starting at X[i1] to Y[i2] and doing N1 elements if N1 is supplied otherwise, doing the length of X - I1 elements. If the types of the arrays are not the same, this has implementation dependent results.

Function: BYE ( &optional (exit-status 0))

Package:LISP

GCL specific: Exits from GCL with exit-status.

Package:LISP

GCL specific: If TURN-ON is not nil, the fast link mechanism is enabled, so that ordinary function calls will not appear in the invocation stack, and calls will be much faster. This is the default. If you anticipate needing to see a stack trace in the debugger, then you should turn this off.

• Bignums  

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Command-Line.html0000644000175000017500000001773014360276512016245 0ustar cammcamm Command Line (GCL SI Manual)

Next: , Previous: , Up: Operating System   [Contents][Index]

9.1 Command Line

The variable si::*command-args* is set to the list of strings passed in when gcl is invoked.

Various flags are understood.

-eval

Call read and then eval on the command argument following -eval

-load

Load the file whose pathname is specified after -load.

-f

Replace si::*command-args* by the the list starting after -f. Open the file following -f for input, skip the first line, and then read and eval the rest of the forms in the file. This can be used as with the shells to write small shell programs: 

#!/usr/local/bin/gcl.exe -f
(format t "hello world ~a~%" (nth 1 si::*command-args*))

The value si::*command-args* will have the appropriate value. Thus if the above 2 line file is made executable and called foo then 

tutorial% foo billy
hello world billy

NOTE: On many systems (eg SunOs) the first line of an executable script file such as: 

#!/usr/local/bin/gcl.exe -f

only reads the first 32 characters! So if your pathname where the executable together with the ’-f’ amount to more than 32 characters the file will not be recognized. Also the executable must be the actual large binary file, [or a link to it], and not just a /bin/sh script. In latter case the /bin/sh interpreter would get invoked on the file.

Alternately one could invoke the file foo without making it executable: 

tutorial% gcl -f foo "from bill"
hello world from bill

Finally perhaps the best way (why do we save the best for last.. I guess because we only figure it out after all the others..) The following file myhello has 4 lines: 

#!/bin/sh
#| Lisp will skip the next 2 lines on reading
exec gcl   -f "$0" $ |#
(format t "hello world ~a~%" (nth 1 si::*command-args*))

marie% chmod a+x myhello
marie% myhello bill
hello world bill

The advantage of this method is that gcl can itself be a shell script, which sets up environment and so on. Also the normal path will be searched to find gcl The disadvantage is that this would cause 2 invocations of sh and one invocation of gcl. The plan using gcl.exe bypasses the sh entirely. Inded invoking gcl.exe to print hello world is faster on most systems than a similar csh or bash script, but slightly slower than the old sh.

-batch

Do not enter the command print loop. Useful if the other command line arguments do something. Do not print the License and acknowledgement information. Note if your program does print any License information, it must print the GCL header information also.

-dir

Directory where the executable binary that is running is located. Needed by save and friends. This gets set as si::*system-directory*

-libdir 
   -libdir /d/wfs/gcl-2.0/

would mean that the files like gcl-tk/tk.o would be found by concatting the path to the libdir path, ie in 

/d/wfs/gcl-2.0/gcl-tk/tk.o
-compile

Invoke the compiler on the filename following -compile. Other flags affect compilation.

-o-file

If nil follows -o-file then do not produce an .o file.

-c-file

If -c-file is specified, leave the intermediate .c file there.

-h-file

If -h-file is specified, leave the intermediate .h file there.

-data-file

If -data-file is specified, leave the intermediate .data file there.

-system-p

If -system-p is specified then invoke compile-file with the :system-p t keyword argument, meaning that the C init function will bear a name based on the name of the file, so that it may be invoked by name by C code.

Next: , Previous: , Up: Operating System   [Contents][Index]

gcl-2.6.14/info/gcl-si/Sequences-and-Arrays-and-Hash-Tables.html0000644000175000017500000010712414360276512022562 0ustar cammcamm Sequences and Arrays and Hash Tables (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

2 Sequences and Arrays and Hash Tables

Function: VECTOR (&rest objects)

Package:LISP

Constructs a Simple-Vector from the given objects.

Function: SUBSEQ (sequence start &optional (end (length sequence)))

Package:LISP

Returns a copy of a subsequence of SEQUENCE between START (inclusive) and END (exclusive).

Function: COPY-SEQ (sequence)

Package:LISP

Returns a copy of SEQUENCE.

Function: POSITION (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the index of the first element in SEQUENCE that satisfies TEST with ITEM; NIL if no such element exists.

Function: ARRAY-RANK (array)

Package:LISP

Returns the number of dimensions of ARRAY.

Function: SBIT (simple-bit-array &rest subscripts)

Package:LISP

Returns the bit from SIMPLE-BIT-ARRAY at SUBSCRIPTS.

Function: STRING-CAPITALIZE (string &key (start 0) (end (length string)))

Package:LISP

Returns a copy of STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case.

Function: NSUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements

except that all elements not satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed.

Function: FIND-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists.

Function: BIT-EQV (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical EQV on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: STRING< (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

If STRING1 is lexicographically less than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL.

Function: REVERSE (sequence)

Package:LISP

Returns a new sequence containing the same elements as SEQUENCE but in reverse order.

Function: NSTRING-UPCASE (string &key (start 0) (end (length string)))

Package:LISP

Returns STRING with all lower case characters converted to uppercase.

Function: STRING>= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

If STRING1 is lexicographically greater than or equal to STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL.

Function: ARRAY-ROW-MAJOR-INDEX (array &rest subscripts)

Package:LISP

Returns the index into the data vector of ARRAY for the element of ARRAY specified by SUBSCRIPTS.

Function: ARRAY-DIMENSION (array axis-number)

Package:LISP

Returns the length of AXIS-NUMBER of ARRAY.

Function: FIND (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the first element in SEQUENCE satisfying TEST with ITEM; NIL if no such element exists.

Function: STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Similar to STRING=, but ignores cases.

Function: STRING-RIGHT-TRIM (char-bag string)

Package:LISP

Returns a copy of STRING with the characters in CHAR-BAG removed from the right end.

Function: DELETE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence formed by destructively removing the elements not satisfying TEST from SEQUENCE.

Function: REMOVE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a copy of SEQUENCE with elements not satisfying TEST removed.

Function: STRING= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Returns T if the two strings are character-wise CHAR=; NIL otherwise.

Function: NSUBSTITUTE-IF (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed.

Function: SOME (predicate sequence &rest more-sequences)

Package:LISP

Returns T if at least one of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise.

Function: MAKE-STRING (size &key (initial-element #\Space))

Package:LISP

Creates and returns a new string of SIZE length whose elements are all INITIAL-ELEMENT.

Function: NSUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM. SEQUENCE may be destroyed.

Function: STRING-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Given two strings (string1 and string2), and optional integers start1, start2, end1 and end2, compares characters in string1 to characters in string2 (using char-equal).

Function: STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Similar to STRING<=, but ignores cases.

Function: STRING> (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

If STRING1 is lexicographically greater than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL.

Function: STRINGP (x)

Package:LISP

Returns T if X is a string; NIL otherwise.

Function: DELETE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence formed by removing the elements satisfying TEST destructively from SEQUENCE.

Function: SIMPLE-STRING-P (x)

Package:LISP

Returns T if X is a simple string; NIL otherwise.

Function: REMOVE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a copy of SEQUENCE with elements satisfying TEST removed.

Function: HASH-TABLE-COUNT (hash-table)

Package:LISP

Returns the number of entries in the given Hash-Table.

Function: ARRAY-DIMENSIONS (array)

Package:LISP

Returns a list whose elements are the dimensions of ARRAY

Function: SUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying TEST are replaced with NEWITEM.

Function: ADJUSTABLE-ARRAY-P (array)

Package:LISP

Returns T if ARRAY is adjustable; NIL otherwise.

Function: SVREF (simple-vector index)

Package:LISP

Returns the INDEX-th element of SIMPLE-VECTOR.

Function: VECTOR-PUSH-EXTEND (new-element vector &optional (extension (length vector)))

Package:LISP

Similar to VECTOR-PUSH except that, if the fill pointer gets too large, extends VECTOR rather then simply returns NIL.

Function: DELETE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence formed by removing the specified ITEM destructively from SEQUENCE.

Function: REMOVE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a copy of SEQUENCE with ITEM removed.

Function: STRING (x)

Package:LISP

Coerces X into a string. If X is a string, then returns X itself. If X is a symbol, then returns X’s print name. If X is a character, then returns a one element string containing that character. Signals an error if X cannot be coerced into a string.

Function: STRING-UPCASE (string &key (start 0) (end (length string)))

Package:LISP

Returns a copy of STRING with all lower case characters converted to uppercase.

Function: GETHASH (key hash-table &optional (default nil))

Package:LISP

Finds the entry in HASH-TABLE whose key is KEY and returns the associated value and T, as multiple values. Returns DEFAULT and NIL if there is no such entry.

Function: MAKE-HASH-TABLE (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7))

Package:LISP

Creates and returns a hash table.

Function: STRING/= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Returns NIL if STRING1 and STRING2 are character-wise CHAR=. Otherwise, returns the index to the longest common prefix of the strings.

Function: STRING-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Similar to STRING>, but ignores cases.

Function: ELT (sequence index)

Package:LISP

Returns the INDEX-th element of SEQUENCE.

Function: MAKE-ARRAY (dimensions &key (element-type t) initial-element (initial-contents nil) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0) static)

Package:LISP

Creates an array of the specified DIMENSIONS. The default for INITIAL- ELEMENT depends on ELEMENT-TYPE. MAKE-ARRAY will always try to find the ‘best’ array to accommodate the element-type specified. For example on a SUN element-type (mod 1) –> bit (integer 0 10) –> unsigned-char (integer -3 10) –> signed-char si::best-array-element-type is the function doing this. It is also used by the compiler, for coercing array element types. If you are going to declare an array you should use the same element type as was used in making it. eg (setq my-array (make-array 4 :element-type ’(integer 0 10))) (the (array (integer 0 10)) my-array) When wanting to optimize references to an array you need to declare the array eg: (the (array (integer -3 10)) my-array) if ar were constructed using the (integer -3 10) element-type. You could of course have used signed-char, but since the ranges may be implementation dependent it is better to use -3 10 range. MAKE-ARRAY needs to do some calculation with the element-type if you don’t provide a primitive data-type. One way of doing this in a machine independent fashion:

(defvar *my-elt-type* #. (array-element-type (make-array 1 :element-type ’(integer -3 10))))

Then calls to (make-array n :element-type *my-elt-type*) will not have to go through a type inclusion computation. The keyword STATIC (GCL specific) if non nil, will cause the array body to be non relocatable.

Function: NSTRING-DOWNCASE (string &key (start 0) (end (length string)))

Package:LISP Returns STRING with all upper case characters converted to lowercase.

Function: ARRAY-IN-BOUNDS-P (array &rest subscripts)

Package:LISP Returns T if SUBSCRIPTS are valid subscripts for ARRAY; NIL otherwise.

Function: SORT (sequence predicate &key (key #'identity))

Package:LISP Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument.

Function: HASH-TABLE-P (x)

Package:LISP

Returns T if X is a hash table object; NIL otherwise.

Function: COUNT-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the number of elements in SEQUENCE not satisfying TEST.

Function: FILL-POINTER (vector)

Package:LISP

Returns the fill pointer of VECTOR.

Function: ARRAYP (x)

Package:LISP

Returns T if X is an array; NIL otherwise.

Function: REPLACE (sequence1 sequence2 &key (start1 0) (end1 (length sequence1)) (start2 0) (end2 (length sequence2)))

Package:LISP

Destructively modifies SEQUENCE1 by copying successive elements into it from SEQUENCE2.

Function: BIT-XOR (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical XOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: CLRHASH (hash-table)

Package:LISP

Removes all entries of HASH-TABLE and returns the hash table itself.

Function: SUBSTITUTE-IF (newitem test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM.

Function: MISMATCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity))

Package:LISP

The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the result is NIL. Otherwise, the result is a non-negative integer, the index within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within SEQUENCE1 beyond the last position tested is returned.

Constant: ARRAY-TOTAL-SIZE-LIMIT

Package:LISP The exclusive upper bound on the total number of elements of an array.

Function: VECTOR-POP (vector)

Package:LISP

Attempts to decrease the fill-pointer of VECTOR by 1 and returns the element pointed to by the new fill pointer. Signals an error if the old value of the fill pointer is 0.

Function: SUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))

Package:LISP

Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM.

Function: ARRAY-HAS-FILL-POINTER-P (array)

Package:LISP

Returns T if ARRAY has a fill pointer; NIL otherwise.

Function: CONCATENATE (result-type &rest sequences)

Package:LISP

Returns a new sequence of the specified RESULT-TYPE, consisting of all elements in SEQUENCEs.

Function: VECTOR-PUSH (new-element vector)

Package:LISP

Attempts to set the element of ARRAY designated by its fill pointer to NEW-ELEMENT and increments the fill pointer by one. Returns NIL if the fill pointer is too large. Otherwise, returns the new fill pointer value.

Function: STRING-TRIM (char-bag string)

Package:LISP

Returns a copy of STRING with the characters in CHAR-BAG removed from both ends.

Function: ARRAY-ELEMENT-TYPE (array)

Package:LISP

Returns the type of the elements of ARRAY

Function: NOTANY (predicate sequence &rest more-sequences)

Package:LISP

Returns T if none of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise.

Function: BIT-NOT (bit-array &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical NOT in the elements of BIT-ARRAY. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: BIT-ORC1 (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical ORC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: COUNT-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the number of elements in SEQUENCE satisfying TEST.

Function: MAP (result-type function sequence &rest more-sequences)

Package:LISP

FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that the i-th element is the result of applying FUNCTION to the i-th elements of the SEQUENCEs.

Constant: ARRAY-RANK-LIMIT

Package:LISP The exclusive upper bound on the rank of an array.

Function: COUNT (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the number of elements in SEQUENCE satisfying TEST with ITEM.

Function: BIT-VECTOR-P (x)

Package:LISP

Returns T if X is a bit vector; NIL otherwise.

Function: NSTRING-CAPITALIZE (string &key (start 0) (end (length string)))

Package:LISP

Returns STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case.

Function: ADJUST-ARRAY (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0))

Package:LISP

Adjusts the dimensions of ARRAY to the given DIMENSIONS. The default value of INITIAL-ELEMENT depends on ELEMENT-TYPE.

Package:LISP

A search is conducted for the first subsequence of SEQUENCE2 which element-wise matches SEQUENCE1. If there is such a subsequence in SEQUENCE2, the index of the its leftmost element is returned; otherwise, NIL is returned.

Function: SIMPLE-BIT-VECTOR-P (x)

Package:LISP

Returns T if X is a simple bit-vector; NIL otherwise.

Function: MAKE-SEQUENCE (type length &key initial-element)

Package:LISP

Returns a sequence of the given TYPE and LENGTH, with elements initialized to INITIAL-ELEMENT. The default value of INITIAL-ELEMENT depends on TYPE.

Function: BIT-ORC2 (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical ORC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: NREVERSE (sequence)

Package:LISP

Returns a sequence of the same elements as SEQUENCE but in reverse order. SEQUENCE may be destroyed.

Constant: ARRAY-DIMENSION-LIMIT

Package:LISP The exclusive upper bound of the array dimension.

Function: NOTEVERY (predicate sequence &rest more-sequences)

Package:LISP

Returns T if at least one of the elements in SEQUENCEs does not satisfy PREDICATE; NIL otherwise.

Function: POSITION-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists.

Function: STRING-DOWNCASE (string &key (start 0) (end (length string)))

Package:LISP

Returns a copy of STRING with all upper case characters converted to lowercase.

Function: BIT (bit-array &rest subscripts)

Package:LISP

Returns the bit from BIT-ARRAY at SUBSCRIPTS.

Function: STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Similar to STRING>=, but ignores cases.

Function: CHAR (string index)

Package:LISP

Returns the INDEX-th character in STRING.

Function: AREF (array &rest subscripts)

Package:LISP

Returns the element of ARRAY specified by SUBSCRIPTS.

Function: FILL (sequence item &key (start 0) (end (length sequence)))

Package:LISP

Replaces the specified elements of SEQUENCE all with ITEM.

Function: STABLE-SORT (sequence predicate &key (key #'identity))

Package:LISP

Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument.

Function: BIT-IOR (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical IOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: REMHASH (key hash-table)

Package:LISP

Removes any entry for KEY in HASH-TABLE. Returns T if such an entry existed; NIL otherwise.

Function: VECTORP (x)

Package:LISP

Returns T if X is a vector; NIL otherwise.

Function: STRING<= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

If STRING1 is lexicographically less than or equal to STRING2, then returns the longest common prefix of the two strings. Otherwise, returns NIL.

Function: SIMPLE-VECTOR-P (x)

Package:LISP

Returns T if X is a simple vector; NIL otherwise.

Function: STRING-LEFT-TRIM (char-bag string)

Package:LISP

Returns a copy of STRING with the characters in CHAR-BAG removed from the left end.

Function: ARRAY-TOTAL-SIZE (array)

Package:LISP

Returns the total number of elements of ARRAY.

Function: FIND-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists.

Function: DELETE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns a sequence formed by removing duplicated elements destructively from SEQUENCE.

Function: REMOVE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))

Package:LISP

The elements of SEQUENCE are examined, and if any two match, one is discarded. Returns the resulting sequence.

Function: POSITION-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))

Package:LISP

Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists.

Function: MERGE (result-type sequence1 sequence2 predicate &key (key #'identity))

Package:LISP

SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type RESULT-TYPE using PREDICATE to order the elements.

Function: EVERY (predicate sequence &rest more-sequences)

Package:LISP

Returns T if every elements of SEQUENCEs satisfy PREDICATE; NIL otherwise.

Function: REDUCE (function sequence &key (from-end nil) (start 0) (end (length sequence)) initial-value)

Package:LISP

Combines all the elements of SEQUENCE using a binary operation FUNCTION. If INITIAL-VALUE is supplied, it is logically placed before the SEQUENCE.

Function: STRING-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))

Package:LISP

Similar to STRING<, but ignores cases.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Function-and-Variable-Index.html0000644000175000017500000061601714360276512021122 0ustar cammcamm Function and Variable Index (GCL SI Manual)

Previous: , Up: Top   [Contents][Index]

Appendix A Function and Variable Index

Jump to:   *   +   -   /   1   <   =   >  
A   B   C   D   E   F   G   H   I   K   L   M   N   O   P   Q   R   S   T   U   V   W   X   Y   Z  
Index Entry  Section
*
*: Numbers
*: User Interface
**: User Interface
***: User Interface
*AFTER-GBC-HOOK*: System Definitions
*APPLYHOOK*: Special Forms and Functions
*BREAK-ENABLE*: User Interface
*BREAK-ON-WARNINGS*: User Interface
*CASE-FOLD-SEARCH*: System Definitions
*CC*: Compiler Definitions
*CMPINCLUDE-STRING*: Compiler Definitions
*COMPILE-ORDINARIES*: Compiler Definitions
*DEBUG-IO*: User Interface
*DEFAULT-C-FILE*: Compilation
*DEFAULT-DATA-FILE*: Compilation
*DEFAULT-H-FILE*: Compilation
*DEFAULT-PATHNAME-DEFAULTS*: Operating System Definitions
*DEFAULT-SYSTEM-P*: Compilation
*DEFAULT-TIME-ZONE*: System Definitions
*ERROR-OUTPUT*: User Interface
*EVALHOOK*: Special Forms and Functions
*FEATURES*: Compilation
*GBC-MESSAGE*: System Definitions
*GBC-NOTIFY*: System Definitions
*IGNORE-EOF-ON-TERMINAL-IO*: System Definitions
*IGNORE-MAXIMUM-PAGES*: GCL Specific
*INDENT-FORMATTED-OUTPUT*: System Definitions
*info-paths*: Doc
*INTERRUPT-ENABLE*: System Definitions
*LISP-MAXPAGES*: System Definitions
*LOAD-PATHNAME*: System Definitions
*LOAD-VERBOSE*: Streams and Reading
*MACROEXPAND-HOOK*: Special Forms and Functions
*MAKE-CONSTANT: System Definitions
*MAKE-SPECIAL: System Definitions
*MODULES*: Operating System Definitions
*MULTIPLY-STACKS*: System Definitions
*NOTIFY-GBC*: System Definitions
*OPTIMIZE-MAXIMUM-PAGES*: GCL Specific
*PACKAGE*: Symbols
*PRINT-ARRAY*: Streams and Reading
*PRINT-BASE*: Streams and Reading
*PRINT-CASE*: Streams and Reading
*PRINT-CIRCLE*: Streams and Reading
*PRINT-ESCAPE*: Streams and Reading
*PRINT-GENSYM*: Streams and Reading
*PRINT-LENGTH*: Streams and Reading
*PRINT-LEVEL*: Streams and Reading
*PRINT-PRETTY*: Streams and Reading
*PRINT-RADIX*: Streams and Reading
*QUERY-IO*: Streams and Reading
*RANDOM-STATE*: Numbers
*READ-BASE*: Streams and Reading
*READ-DEFAULT-FLOAT-FORMAT*: Streams and Reading
*READ-SUPPRESS*: Streams and Reading
*READLINE-PREFIX*: Streams and Reading
*READTABLE*: Streams and Reading
*SPLIT-FILES*: Compiler Definitions
*STANDARD-INPUT*: Streams and Reading
*STANDARD-OUTPUT*: Streams and Reading
*SYSTEM-DIRECTORY*: System Definitions
*TERMINAL-IO*: Streams and Reading
*TMP-DIR*: GCL Specific
*TOP-LEVEL-HOOK*: System Definitions
*TRACE-OUTPUT*: User Interface
+
+: Numbers
+: User Interface
++: User Interface
+++: User Interface
-
-: User Interface
-: User Interface
-batch: Command Line
-c-file: Command Line
-compile: Command Line
-data-file: Command Line
-dir: Command Line
-eval: Command Line
-f: Command Line
-h-file: Command Line
-libdir: Command Line
-load: Command Line
-o-file: Command Line
-system-p: Command Line
/
/: Numbers
/: User Interface
//: User Interface
///: User Interface
/=: Numbers
1
1+: Numbers
1-: Numbers
<
<: Numbers
<=: Numbers
=
=: Numbers
>
>: Numbers
>=: Numbers
A
ABS: Numbers
ACCEPT: System Definitions
ACONS: Lists
ACOS: Numbers
ACOSH: Numbers
ADDRESS: System Definitions
ADJOIN: Lists
ADJUST-ARRAY: Sequences and Arrays and Hash Tables
ADJUSTABLE-ARRAY-P: Sequences and Arrays and Hash Tables
ALLOCATE: GCL Specific
ALLOCATE-CONTIGUOUS-PAGES: System Definitions
ALLOCATE-GROWTH: System Definitions
ALLOCATE-RELOCATABLE-PAGES: System Definitions
ALLOCATE-SGC: System Definitions
ALLOCATED: System Definitions
ALLOCATED-CONTIGUOUS-PAGES: System Definitions
ALLOCATED-PAGES: System Definitions
ALLOCATED-RELOCATABLE-PAGES: System Definitions
ALPHA-CHAR-P: Characters
ALPHANUMERICP: Characters
AND: Special Forms and Functions
APPEND: Lists
APPLY: Special Forms and Functions
APPLYHOOK: Special Forms and Functions
APROPOS: Doc
APROPOS-LIST: Symbols
AREF: Sequences and Arrays and Hash Tables
ARGC: System Definitions
ARGV: System Definitions
ARRAY-DIMENSION: Sequences and Arrays and Hash Tables
ARRAY-DIMENSION-LIMIT: Sequences and Arrays and Hash Tables
ARRAY-DIMENSIONS: Sequences and Arrays and Hash Tables
ARRAY-ELEMENT-TYPE: Sequences and Arrays and Hash Tables
ARRAY-HAS-FILL-POINTER-P: Sequences and Arrays and Hash Tables
ARRAY-IN-BOUNDS-P: Sequences and Arrays and Hash Tables
ARRAY-RANK: Sequences and Arrays and Hash Tables
ARRAY-RANK-LIMIT: Sequences and Arrays and Hash Tables
ARRAY-ROW-MAJOR-INDEX: Sequences and Arrays and Hash Tables
ARRAY-TOTAL-SIZE: Sequences and Arrays and Hash Tables
ARRAY-TOTAL-SIZE-LIMIT: Sequences and Arrays and Hash Tables
ARRAYP: Sequences and Arrays and Hash Tables
ASH: Numbers
ASIN: Numbers
ASINH: Numbers
ASSERT: Type
ASSOC: Lists
ASSOC-IF: Lists
ASSOC-IF-NOT: Lists
ATAN: Numbers
ATANH: Numbers
ATOM: Lists
B
BDS-VAL: System Definitions
BDS-VAR: System Definitions
BIT: Sequences and Arrays and Hash Tables
BIT-AND: Numbers
BIT-ANDC1: Numbers
BIT-ANDC2: Numbers
BIT-EQV: Sequences and Arrays and Hash Tables
BIT-IOR: Sequences and Arrays and Hash Tables
BIT-NAND: Numbers
BIT-NOR: Numbers
BIT-NOT: Sequences and Arrays and Hash Tables
BIT-ORC1: Sequences and Arrays and Hash Tables
BIT-ORC2: Sequences and Arrays and Hash Tables
BIT-VECTOR-P: Sequences and Arrays and Hash Tables
BIT-XOR: Sequences and Arrays and Hash Tables
BLOCK: Special Forms and Functions
BOOLE: Numbers
BOOLE-1: Numbers
BOOLE-2: Numbers
BOOLE-AND: Numbers
BOOLE-ANDC1: Numbers
BOOLE-ANDC2: Numbers
BOOLE-C1: Numbers
BOOLE-C2: Numbers
BOOLE-CLR: Numbers
BOOLE-EQV: Numbers
BOOLE-IOR: Numbers
BOOLE-NAND: Numbers
BOOLE-NOR: Numbers
BOOLE-ORC1: Numbers
BOOLE-ORC2: Numbers
BOOLE-SET: Numbers
BOOLE-XOR: Numbers
BOTH-CASE-P: Characters
BOUNDP: Symbols
BREAK: User Interface
BREAK-FUNCTION: System Definitions
BREAK-ON-FLOATING-POINT-EXCEPTIONS: Operating System Definitions
BUTLAST: Lists
BY: GCL Specific
BYE: GCL Specific
BYTE: Numbers
BYTE-POSITION: Numbers
BYTE-SIZE: Numbers
C
CAAAAR: Lists
CAAADR: Lists
CAAAR: Lists
CAADAR: Lists
CAADDR: Lists
CAADR: Lists
CAAR: Lists
CADAAR: Lists
CADADR: Lists
CADAR: Lists
CADDAR: Lists
CADDDR: Lists
CADDR: Lists
CADR: Lists
CALL-ARGUMENTS-LIMIT: Special Forms and Functions
CAR: Lists
CASE: Special Forms and Functions
CATCH: Special Forms and Functions
CATCH-BAD-SIGNALS: System Definitions
CATCH-FATAL: System Definitions
CCASE: Special Forms and Functions
CDAAAR: Lists
CDAADR: Lists
CDAAR: Lists
CDADAR: Lists
CDADDR: Lists
CDADR: Lists
CDAR: Lists
CDDAAR: Lists
CDDADR: Lists
CDDAR: Lists
CDDDAR: Lists
CDDDDR: Lists
CDDDR: Lists
CDDR: Lists
CDR: Lists
CEILING: Numbers
CERROR: User Interface
CHAR: Sequences and Arrays and Hash Tables
CHAR-BIT: Characters
CHAR-BITS: Characters
CHAR-BITS-LIMIT: Characters
CHAR-CODE: Characters
CHAR-CODE-LIMIT: Numbers
CHAR-CONTROL-BIT: Characters
CHAR-DOWNCASE: Characters
CHAR-EQUAL: Characters
CHAR-FONT: Characters
CHAR-FONT-LIMIT: Characters
CHAR-GREATERP: Characters
CHAR-HYPER-BIT: Characters
CHAR-INT: Numbers
CHAR-LESSP: Characters
CHAR-META-BIT: Characters
CHAR-NAME: Characters
CHAR-NOT-EQUAL: Characters
CHAR-NOT-GREATERP: Characters
CHAR-NOT-LESSP: Characters
CHAR-SUPER-BIT: Characters
CHAR-UPCASE: Characters
CHAR/=: Characters
CHAR<: Characters
CHAR<=: Characters
CHAR=: Characters
CHAR>: Characters
CHAR>=: Characters
CHARACTER: Characters
CHARACTERP: Characters
CHDIR: System Definitions
CHECK-TYPE: Type
CIS: Numbers
CLEAR-INPUT: Streams and Reading
CLEAR-OUTPUT: Streams and Reading
CLINES: GCL Specific
CLOSE: Streams and Reading
CLOSE-FASD: System Definitions
CLRHASH: Sequences and Arrays and Hash Tables
CODE-CHAR: Characters
COERCE: Type
COMMONP: Type
COMPILE: Compilation
COMPILE-FILE: Compilation
COMPILED-FUNCTION-NAME: System Definitions
COMPILED-FUNCTION-P: Compilation
COMPILER-LET: Special Forms and Functions
COMPLEX: Numbers
COMPLEXP: Numbers
CONCATENATE: Sequences and Arrays and Hash Tables
COND: Special Forms and Functions
CONJUGATE: Numbers
CONS: Lists
CONSP: Lists
CONSTANTP: Type
COPY-ALIST: Lists
COPY-ARRAY-PORTION: GCL Specific
COPY-LIST: Lists
COPY-READTABLE: Streams and Reading
COPY-SEQ: Sequences and Arrays and Hash Tables
COPY-STREAM: System Definitions
COPY-SYMBOL: Symbols
COPY-TREE: Lists
COS: Numbers
COSH: Numbers
COUNT: Sequences and Arrays and Hash Tables
COUNT-IF: Sequences and Arrays and Hash Tables
COUNT-IF-NOT: Sequences and Arrays and Hash Tables
CTYPECASE: Special Forms and Functions
D
DBL: System Definitions
DECF: Numbers
DECLARE: Special Forms and Functions
DECODE-FLOAT: Numbers
DECODE-UNIVERSAL-TIME: Operating System Definitions
DEFCFUN: GCL Specific
DEFCONSTANT: Special Forms and Functions
DEFENTRY: GCL Specific
DEFINE-COMPILER-MACRO: System Definitions
DEFINE-INLINE-FUNCTION: System Definitions
DEFINE-MODIFY-MACRO: Special Forms and Functions
DEFINE-SETF-METHOD: Special Forms and Functions
DEFLA: GCL Specific
DEFMACRO: Special Forms and Functions
DEFPARAMETER: Special Forms and Functions
DEFSETF: Special Forms and Functions
DEFSTRUCT: Structures
DEFTYPE: Type
DEFUN: Special Forms and Functions
DEFVAR: Special Forms and Functions
DELETE: Sequences and Arrays and Hash Tables
DELETE-DUPLICATES: Sequences and Arrays and Hash Tables
DELETE-FILE: Operating System Definitions
DELETE-IF: Sequences and Arrays and Hash Tables
DELETE-IF-NOT: Sequences and Arrays and Hash Tables
DENOMINATOR: Numbers
DEPOSIT-FIELD: Numbers
DESCRIBE: User Interface
DIGIT-CHAR: Characters
DIGIT-CHAR-P: Characters
DIRECTORY: Operating System Definitions
DIRECTORY-NAMESTRING: Streams and Reading
DISASSEMBLE: Characters
DISPLACED-ARRAY-P: System Definitions
DO: Streams and Reading
DO*: Iteration and Tests
DO-ALL-SYMBOLS: Iteration and Tests
DO-EXTERNAL-SYMBOLS: Iteration and Tests
DO-SYMBOLS: Iteration and Tests
DOCUMENTATION: Symbols
DOLIST: Iteration and Tests
DOTIMES: Special Forms and Functions
DOUBLE-FLOAT-EPSILON: Numbers
DOUBLE-FLOAT-NEGATIVE-EPSILON: Numbers
DPB: Numbers
DRIBBLE: User Interface
DYNAMIC-EXTENT: Type
E
ECASE: Special Forms and Functions
ED: User Interface
EIGHTH: Lists
ELT: Sequences and Arrays and Hash Tables
EMIT-FN: Compiler Definitions
EMIT-FN: Compiler Definitions
ENCODE-UNIVERSAL-TIME: Operating System Definitions
ENDP: Lists
ENOUGH-NAMESTRING: Operating System Definitions
EQ: Iteration and Tests
EQL: Numbers
EQUAL: Iteration and Tests
EQUALP: Iteration and Tests
ERROR: Special Forms and Functions
ERROR-SET: System Definitions
ETYPECASE: Special Forms and Functions
EVAL: Special Forms and Functions
EVAL-WHEN: Compilation
EVALHOOK: Special Forms and Functions
EVENP: Numbers
EVERY: Sequences and Arrays and Hash Tables
EXP: Numbers
EXPORT: Symbols
EXPT: Numbers
F
FASLINK: System Definitions
FBOUNDP: Symbols
FCEILING: Numbers
FFLOOR: Numbers
FIFTH: Lists
FILE-AUTHOR: Operating System Definitions
FILE-LENGTH: Streams and Reading
FILE-NAMESTRING: Streams and Reading
FILE-POSITION: Operating System Definitions
FILE-WRITE-DATE: Streams and Reading
FILL: Sequences and Arrays and Hash Tables
FILL-POINTER: Sequences and Arrays and Hash Tables
FIND: Sequences and Arrays and Hash Tables
FIND-ALL-SYMBOLS: Symbols
FIND-IF: Sequences and Arrays and Hash Tables
FIND-IF-NOT: Sequences and Arrays and Hash Tables
FIND-PACKAGE: Symbols
FIND-SHARING-TOP: System Definitions
FIND-SYMBOL: Symbols
FINISH-OUTPUT: Streams and Reading
FIRST: Lists
FIXNUMP: System Definitions
FLET: Special Forms and Functions
FLOAT: Numbers
FLOAT-DIGITS: Numbers
FLOAT-PRECISION: Numbers
FLOAT-RADIX: Numbers
FLOAT-SIGN: Numbers
FLOATP: Numbers
FLOOR: Numbers
FMAKUNBOUND: Symbols
FORCE-OUTPUT: Streams and Reading
FORMAT: Streams and Reading
FOURTH: Lists
FP-INPUT-STREAM: System Definitions
FP-OUTPUT-STREAM: System Definitions
FREAD: System Definitions
FREEZE-DEFSTRUCT: System Definitions
FRESH-LINE: Streams and Reading
FROUND: Numbers
FRS-BDS: System Definitions
FRS-IHS: System Definitions
FRS-VS: System Definitions
FTRUNCATE: Numbers
FUNCALL: Special Forms and Functions
FUNCTION: Special Forms and Functions
FUNCTIONP: Special Forms and Functions
FWRITE: System Definitions
G
GBC: GCL Specific
GBC-TIME: System Definitions
GCD: Numbers
GENSYM: Symbols
GENTEMP: Symbols
GET: Symbols
GET-DECODED-TIME: Operating System Definitions
GET-DISPATCH-MACRO-CHARACTER: Streams and Reading
GET-HOLE-SIZE: System Definitions
GET-INTERNAL-REAL-TIME: Operating System Definitions
GET-INTERNAL-RUN-TIME: Operating System Definitions
GET-MACRO-CHARACTER: Streams and Reading
GET-OUTPUT-STREAM-STRING: Streams and Reading
GET-PROPERTIES: Lists
GET-SETF-METHOD-MULTIPLE-VALUE: Special Forms and Functions
GET-STRING-INPUT-STREAM-INDEX: System Definitions
GET-UNIVERSAL-TIME: Operating System Definitions
GETENV: System Definitions
GETF: Lists
GETHASH: Sequences and Arrays and Hash Tables
GO: Special Forms and Functions
GPROF-QUIT: Compilation
GPROF-SET: Compilation
GPROF-START: Compilation
GRAPHIC-CHAR-P: Characters
H
HASH-TABLE-COUNT: Sequences and Arrays and Hash Tables
HASH-TABLE-P: Sequences and Arrays and Hash Tables
HELP: Structures
HELP*: GCL Specific
HOST-NAMESTRING: Operating System Definitions
I
IDENTITY: Special Forms and Functions
IF: Special Forms and Functions
IHS-FUN: System Definitions
IHS-VS: System Definitions
IMAGPART: Numbers
IMPORT: Symbols
IN-PACKAGE: Symbols
INCF: Numbers
INFO: Doc
INIT-SYSTEM: System Definitions
INPUT-STREAM-P: Streams and Reading
INSPECT: User Interface
INT-CHAR: Numbers
INTEGER-DECODE-FLOAT: Numbers
INTEGER-LENGTH: Numbers
INTEGERP: Numbers
INTERN: Symbols
INTERNAL-TIME-UNITS-PER-SECOND: Operating System Definitions
INTERSECTION: Lists
ISQRT: Numbers
K
KEYWORDP: Symbols
L
LABELS: Special Forms and Functions
LAMBDA-LIST-KEYWORDS: Special Forms and Functions
LAMBDA-PARAMETERS-LIMIT: Special Forms and Functions
LAST: Lists
LCM: Numbers
LDB: Numbers
LDB-TEST: Numbers
LDIFF: Lists
LEAST-NEGATIVE-DOUBLE-FLOAT: Numbers
LEAST-NEGATIVE-LONG-FLOAT: Numbers
LEAST-NEGATIVE-SHORT-FLOAT: Numbers
LEAST-NEGATIVE-SINGLE-FLOAT: Numbers
LEAST-POSITIVE-DOUBLE-FLOAT: Numbers
LEAST-POSITIVE-LONG-FLOAT: Numbers
LEAST-POSITIVE-SHORT-FLOAT: Numbers
LEAST-POSITIVE-SINGLE-FLOAT: Numbers
LENGTH: Lists
LET: Special Forms and Functions
LET*: Special Forms and Functions
LINK: Compilation
LISP-IMPLEMENTATION-TYPE: Operating System Definitions
LISP-IMPLEMENTATION-VERSION: Operating System Definitions
LIST: Lists
LIST*: Lists
LIST-ALL-PACKAGES: Symbols
LIST-LENGTH: Lists
LIST-UNCALLED-FUNCTIONS: Compiler Definitions
LIST-UNDEFINED-FUNCTIONS: Compiler Definitions
LISTEN: Streams and Reading
LISTP: Lists
LOAD: Streams and Reading
LOCALLY: Special Forms and Functions
LOG: Numbers
LOGAND: Numbers
LOGANDC1: Numbers
LOGANDC2: Numbers
LOGBITP: Numbers
LOGCOUNT: Numbers
LOGEQV: Numbers
LOGIOR: Numbers
LOGNAND: Numbers
LOGNOR: Numbers
LOGNOT: Numbers
LOGORC1: Numbers
LOGORC2: Numbers
LOGTEST: Numbers
LOGXOR: Numbers
LONG-FLOAT-EPSILON: Numbers
LONG-FLOAT-NEGATIVE-EPSILON: Numbers
LONG-SITE-NAME: Operating System Definitions
LOOP: Iteration and Tests
LOWER-CASE-P: Characters
M
MACHINE-INSTANCE: Operating System Definitions
MACHINE-TYPE: Operating System Definitions
MACHINE-VERSION: GCL Specific
MACRO-FUNCTION: Symbols
MACROEXPAND: Special Forms and Functions
MACROEXPAND-1: Special Forms and Functions
MACROLET: Special Forms and Functions
MAKE-ALL-PROCLAIMS: Compiler Definitions
MAKE-ARRAY: Sequences and Arrays and Hash Tables
MAKE-BROADCAST-STREAM: Streams and Reading
MAKE-CHAR: Characters
MAKE-CONCATENATED-STREAM: Streams and Reading
MAKE-DISPATCH-MACRO-CHARACTER: Streams and Reading
MAKE-ECHO-STREAM: Streams and Reading
MAKE-HASH-TABLE: Sequences and Arrays and Hash Tables
MAKE-LIST: Lists
MAKE-PACKAGE: Symbols
MAKE-PATHNAME: Streams and Reading
MAKE-PROCLAIMS: Compiler Definitions
MAKE-RANDOM-STATE: Numbers
MAKE-SEQUENCE: Sequences and Arrays and Hash Tables
MAKE-STRING: Sequences and Arrays and Hash Tables
MAKE-STRING-INPUT-STREAM: Streams and Reading
MAKE-STRING-INPUT-STREAM: User Interface
MAKE-STRING-OUTPUT-STREAM: Streams and Reading
MAKE-STRING-OUTPUT-STREAM-FROM-STRING: System Definitions
MAKE-SYMBOL: Symbols
MAKE-SYNONYM-STREAM: Streams and Reading
MAKE-TWO-WAY-STREAM: Streams and Reading
MAKUNBOUND: Symbols
MAP: Sequences and Arrays and Hash Tables
MAPC: Lists
MAPCAN: Lists
MAPCAR: Iteration and Tests
MAPCON: Lists
MAPHASH: Iteration and Tests
MAPL: Lists
MAPLIST: Lists
MASK-FIELD: Numbers
MATCH-BEGINNING: System Definitions
MATCH-END: System Definitions
MAX: Numbers
MAXIMUM-ALLOCATABLE-PAGES: System Definitions
MAXIMUM-CONTIGUOUS-PAGES: System Definitions
MEMBER: Lists
MEMBER-IF: Lists
MEMBER-IF-NOT: Lists
MERGE: Sequences and Arrays and Hash Tables
MERGE-PATHNAMES: Streams and Reading
MIN: Numbers
MINUSP: Numbers
MISMATCH: Sequences and Arrays and Hash Tables
MOD: Numbers
MODF: Numbers
MOST-NEGATIVE-DOUBLE-FLOAT: Numbers
MOST-NEGATIVE-FIXNUM: Numbers
MOST-NEGATIVE-LONG-FLOAT: Numbers
MOST-NEGATIVE-SHORT-FLOAT: Numbers
MOST-NEGATIVE-SINGLE-FLOAT: Numbers
MOST-POSITIVE-DOUBLE-FLOAT: Numbers
MOST-POSITIVE-FIXNUM: Numbers
MOST-POSITIVE-LONG-FLOAT: Numbers
MOST-POSITIVE-SHORT-FLOAT: Numbers
MOST-POSITIVE-SINGLE-FLOAT: Numbers
MULTIPLE-VALUE-BIND: Special Forms and Functions
MULTIPLE-VALUE-CALL: Special Forms and Functions
MULTIPLE-VALUE-LIST: Special Forms and Functions
MULTIPLE-VALUE-PROG1: Special Forms and Functions
MULTIPLE-VALUE-SETQ: Special Forms and Functions
MULTIPLE-VALUES-LIMIT: Special Forms and Functions
N
NAME-CHAR: Characters
NAMESTRING: Streams and Reading
NANI: System Definitions
NBUTLAST: Lists
NCONC: Lists
NIL: Symbols
NINTERSECTION: Lists
NINTH: Lists
NLOAD: System Definitions
NOT: Special Forms and Functions
NOTANY: Sequences and Arrays and Hash Tables
NOTEVERY: Sequences and Arrays and Hash Tables
NRECONC: Lists
NREVERSE: Sequences and Arrays and Hash Tables
NSET-DIFFERENCE: Lists
NSET-EXCLUSIVE-OR: Lists
NSTRING-CAPITALIZE: Sequences and Arrays and Hash Tables
NSTRING-DOWNCASE: Sequences and Arrays and Hash Tables
NSTRING-UPCASE: Sequences and Arrays and Hash Tables
NSUBLIS: Lists
NSUBST: Lists
NSUBST-IF: Lists
NSUBST-IF-NOT: Lists
NSUBSTITUTE: Sequences and Arrays and Hash Tables
NSUBSTITUTE-IF: Sequences and Arrays and Hash Tables
NSUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables
NTH: Lists
NTHCDR: Lists
NULL: Lists
NUMBERP: Numbers
NUMERATOR: Numbers
NUNION: Lists
O
ODDP: Numbers
OPEN: Streams and Reading
OPEN-FASD: System Definitions
OR: Special Forms and Functions
OUTPUT-STREAM-P: Streams and Reading
OUTPUT-STREAM-STRING: System Definitions
P
PACKAGE-NAME: Symbols
PACKAGE-NICKNAMES: Symbols
PACKAGE-SHADOWING-SYMBOLS: Symbols
PACKAGE-USE-LIST: Symbols
PACKAGE-USED-BY-LIST: Symbols
PACKAGEP: Symbols
PAIRLIS: Lists
PARSE-INTEGER: Numbers
PARSE-NAMESTRING: Streams and Reading
PATHNAME: Streams and Reading
PATHNAME-DEVICE: Streams and Reading
PATHNAME-DIRECTORY: Streams and Reading
PATHNAME-HOST: Operating System Definitions
PATHNAME-NAME: Streams and Reading
PATHNAME-TYPE: Streams and Reading
PATHNAME-VERSION: Streams and Reading
PATHNAMEP: Streams and Reading
PEEK-CHAR: Streams and Reading
PHASE: Numbers
PI: Numbers
PLUSP: Numbers
POP: Lists
POSITION: Sequences and Arrays and Hash Tables
POSITION-IF: Sequences and Arrays and Hash Tables
POSITION-IF-NOT: Sequences and Arrays and Hash Tables
PPRINT: Streams and Reading
PRIN1: Streams and Reading
PRIN1-TO-STRING: Streams and Reading
PRINC: Streams and Reading
PRINC-TO-STRING: Streams and Reading
PRINT: Streams and Reading
PROBE-FILE: Streams and Reading
PROCLAIM: Compilation
PROCLAMATION: GCL Specific
PROF: System Definitions
PROG: Special Forms and Functions
PROG*: Special Forms and Functions
PROG1: Special Forms and Functions
PROG2: Special Forms and Functions
PROGN: Special Forms and Functions
PROGV: Special Forms and Functions
PROVIDE: Compilation
PSETF: Special Forms and Functions
PSETQ: Symbols
PUSH: Lists
PUSHNEW: Lists
PUTPROP: System Definitions
Q
QUOTE: Special Forms and Functions
R
RANDOM: Numbers
RANDOM-STATE-P: Numbers
RASSOC: Lists
RASSOC-IF: Lists
RASSOC-IF-NOT: Lists
RATIONAL: Numbers
RATIONALIZE: Numbers
RATIONALP: Numbers
READ: Streams and Reading
READ-BYTE: Streams and Reading
READ-CHAR: Streams and Reading
READ-CHAR-NO-HANG: Streams and Reading
READ-DELIMITED-LIST: Streams and Reading
READ-FASD-TOP: System Definitions
READ-FROM-STRING: Streams and Reading
READ-LINE: Streams and Reading
READ-PRESERVING-WHITESPACE: Streams and Reading
READLINE-OFF: Streams and Reading
READLINE-ON: Streams and Reading
READTABLEP: Streams and Reading
REALPART: Numbers
REDUCE: Sequences and Arrays and Hash Tables
REM: Numbers
REMF: Symbols
REMHASH: Sequences and Arrays and Hash Tables
REMOVE: Sequences and Arrays and Hash Tables
REMOVE-DUPLICATES: Sequences and Arrays and Hash Tables
REMOVE-IF: Sequences and Arrays and Hash Tables
REMOVE-IF-NOT: Sequences and Arrays and Hash Tables
REMPROP: Symbols
RENAME-FILE: Operating System Definitions
RENAME-PACKAGE: Symbols
REPLACE: Sequences and Arrays and Hash Tables
REQUIRE: Operating System Definitions
RESET-GBC-COUNT: System Definitions
RESET-STACK-LIMITS: System Definitions
REST: Lists
RETURN: Special Forms and Functions
RETURN-FROM: Special Forms and Functions
REVAPPEND: Lists
REVERSE: Sequences and Arrays and Hash Tables
ROOM: Operating System Definitions
ROTATEF: Numbers
ROUND: Numbers
RPLACA: Lists
RPLACD: Lists
RUN-PROCESS: System Definitions
S
SAVE: GCL Specific
SAVE-SYSTEM: System Definitions
SBIT: Sequences and Arrays and Hash Tables
SCALE-FLOAT: Numbers
SCHAR: Characters
SEARCH: Sequences and Arrays and Hash Tables
SECOND: Lists
SET: Symbols
SET-CHAR-BIT: Characters
SET-DIFFERENCE: Lists
SET-DISPATCH-MACRO-CHARACTER: Streams and Reading
SET-EXCLUSIVE-OR: Lists
SET-HOLE-SIZE: System Definitions
SET-MACRO-CHARACTER: Streams and Reading
SET-SYNTAX-FROM-CHAR: Streams and Reading
SETF: Special Forms and Functions
SETQ: Symbols
SEVENTH: Lists
SGC-ON: System Definitions
SHADOW: Symbols
SHADOWING-IMPORT: Symbols
SHIFTF: Numbers
SHORT-FLOAT-EPSILON: Numbers
SHORT-FLOAT-NEGATIVE-EPSILON: Numbers
SHORT-SITE-NAME: Operating System Definitions
SIGNUM: Numbers
SIMPLE-BIT-VECTOR-P: Sequences and Arrays and Hash Tables
SIMPLE-STRING-P: Sequences and Arrays and Hash Tables
SIMPLE-VECTOR-P: Sequences and Arrays and Hash Tables
SIN: Numbers
SINGLE-FLOAT-EPSILON: Numbers
SINGLE-FLOAT-NEGATIVE-EPSILON: Numbers
SINH: Numbers
SIXTH: Lists
SLEEP: Operating System Definitions
SOCKET: System Definitions
SOFTWARE-TYPE: Operating System Definitions
SOFTWARE-VERSION: Operating System Definitions
SOME: Sequences and Arrays and Hash Tables
SORT: Sequences and Arrays and Hash Tables
SPECIAL-FORM-P: Special Forms and Functions
SPECIALP: System Definitions
SQRT: Numbers
STABLE-SORT: Sequences and Arrays and Hash Tables
STANDARD-CHAR-P: Characters
STEP: User Interface
STREAM-ELEMENT-TYPE: Streams and Reading
STREAMP: Streams and Reading
STRING: Sequences and Arrays and Hash Tables
STRING-CAPITALIZE: Sequences and Arrays and Hash Tables
STRING-CHAR-P: Characters
STRING-CONCATENATE: System Definitions
STRING-DOWNCASE: Sequences and Arrays and Hash Tables
STRING-EQUAL: Sequences and Arrays and Hash Tables
STRING-GREATERP: Sequences and Arrays and Hash Tables
STRING-LEFT-TRIM: Sequences and Arrays and Hash Tables
STRING-LESSP: Sequences and Arrays and Hash Tables
STRING-MATCH: System Definitions
STRING-NOT-EQUAL: Sequences and Arrays and Hash Tables
STRING-NOT-GREATERP: Sequences and Arrays and Hash Tables
STRING-NOT-LESSP: Sequences and Arrays and Hash Tables
STRING-RIGHT-TRIM: Sequences and Arrays and Hash Tables
STRING-TO-OBJECT: System Definitions
STRING-TRIM: Sequences and Arrays and Hash Tables
STRING-UPCASE: Sequences and Arrays and Hash Tables
STRING/=: Sequences and Arrays and Hash Tables
STRING<: Sequences and Arrays and Hash Tables
STRING<=: Sequences and Arrays and Hash Tables
STRING=: Sequences and Arrays and Hash Tables
STRING>: Sequences and Arrays and Hash Tables
STRING>=: Sequences and Arrays and Hash Tables
STRINGP: Sequences and Arrays and Hash Tables
STRUCTUREP: System Definitions
SUBLIS: Lists
SUBSEQ: Sequences and Arrays and Hash Tables
SUBSETP: Lists
SUBST: Lists
SUBST-IF: Lists
SUBST-IF-NOT: Lists
SUBSTITUTE: Sequences and Arrays and Hash Tables
SUBSTITUTE-IF: Sequences and Arrays and Hash Tables
SUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables
SUBTYPEP: Type
SVREF: Sequences and Arrays and Hash Tables
SXHASH: Numbers
SYMBOL-FUNCTION: Symbols
SYMBOL-NAME: Symbols
SYMBOL-PACKAGE: Symbols
SYMBOL-PLIST: Symbols
SYMBOL-VALUE: Symbols
SYMBOLP: Symbols
SYSTEM: GCL Specific
T
T: Symbols
TAGBODY: Special Forms and Functions
TAILP: Lists
TAN: Numbers
TANH: Numbers
TENTH: Lists
TERPRI: Streams and Reading
THE: Special Forms and Functions
THIRD: Lists
THROW: Special Forms and Functions
TIME: Operating System Definitions
TOP-LEVEL: System Definitions
TRACE: User Interface
TREE-EQUAL: Lists
TRUENAME: Streams and Reading
TRUNCATE: Numbers
TYPE-OF: Type
TYPECASE: Special Forms and Functions
TYPEP: Type
U
UNCATCH-BAD-SIGNALS: System Definitions
UNEXPORT: Symbols
UNINTERN: Symbols
UNION: Lists
UNIVERSAL-ERROR-HANDLER: System Definitions
UNLESS: Special Forms and Functions
UNREAD-CHAR: Streams and Reading
UNTRACE: User Interface
UNUSE-PACKAGE: Symbols
UNWIND-PROTECT: Special Forms and Functions
UPPER-CASE-P: Characters
USE-FAST-LINKS: GCL Specific
USE-PACKAGE: Symbols
USER-HOMEDIR-PATHNAME: Operating System Definitions
V
VALUES: Special Forms and Functions
VALUES-LIST: Special Forms and Functions
VECTOR: Sequences and Arrays and Hash Tables
VECTOR-POP: Sequences and Arrays and Hash Tables
VECTOR-PUSH: Sequences and Arrays and Hash Tables
VECTOR-PUSH-EXTEND: Sequences and Arrays and Hash Tables
VECTORP: Sequences and Arrays and Hash Tables
VS: System Definitions
W
WARN: User Interface
WHEN: Special Forms and Functions
WHO-CALLS: Compiler Definitions
WITH-INPUT-FROM-STRING: Streams and Reading
WITH-OPEN-FILE: Streams and Reading
WITH-OPEN-STREAM: Streams and Reading
WITH-OUTPUT-TO-STRING: Streams and Reading
WRITE: Streams and Reading
WRITE-BYTE: Streams and Reading
WRITE-CHAR: Streams and Reading
WRITE-DEBUG-SYMBOLS: System Definitions
WRITE-FASD-TOP: System Definitions
WRITE-LINE: Streams and Reading
WRITE-STRING: Streams and Reading
WRITE-TO-STRING: Streams and Reading
X
XDR-OPEN: System Definitions
XDR-READ: System Definitions
XDR-WRITE: System Definitions
Y
Y-OR-N-P: Streams and Reading
YES-OR-NO-P: Iteration and Tests
Z
ZEROP: Numbers
Jump to:   *   +   -   /   1   <   =   >  
A   B   C   D   E   F   G   H   I   K   L   M   N   O   P   Q   R   S   T   U   V   W   X   Y   Z  

Short Table of Contents

Table of Contents

Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Low-Level-X-Interface.html0000644000175000017500000000522014360276512017702 0ustar cammcamm Low Level X Interface (GCL SI Manual)

Previous: , Up: Miscellaneous   [Contents][Index]

19.3 Low Level X Interface

A sample program for drawing things on X windows from lisp is included in the file gcl/lsp/littleXlsp.lsp

That routine invokes the corresponding C routines in XLIB. So in order to use it you must ‘faslink’ in the X routines. Directions are given at the beginning of the lisp file, for either building them into the image or using faslink.

This program is also a good tutorial on invoking C from lisp.

See also defentry and faslink.

gcl-2.6.14/info/gcl-si/Numbers.html0000644000175000017500000011112214360276512015403 0ustar cammcamm Numbers (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

1 Numbers

Function: SIGNUM (number)

Package:LISP

If NUMBER is zero, returns NUMBER; else returns (/ NUMBER (ABS NUMBER)).

Function: LOGNOT (integer)

Package:LISP

Returns the bit-wise logical NOT of INTEGER.

Constant: MOST-POSITIVE-SHORT-FLOAT

Package:LISP The short-float closest in value to positive infinity.

Function: INTEGER-DECODE-FLOAT (float)

Package:LISP

Returns, as three values, the integer interpretation of significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT)

F is a non-negative integer, E is an integer, and S is either 1 or -1.

Function: MINUSP (number)

Package:LISP

Returns T if NUMBER < 0; NIL otherwise.

Function: LOGORC1 (integer1 integer2)

Package:LISP

Returns the logical OR of (LOGNOT INTEGER1) and INTEGER2.

Constant: MOST-NEGATIVE-SINGLE-FLOAT

Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT.

Constant: BOOLE-C1

Package:LISP Makes BOOLE return the complement of INTEGER1.

Constant: LEAST-POSITIVE-SHORT-FLOAT

Package:LISP The positive short-float closest in value to zero.

Function: BIT-NAND (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical NAND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: INT-CHAR (integer)

Package:LISP

Performs the inverse of CHAR-INT. Equivalent to CODE-CHAR in GCL.

Function: CHAR-INT (char)

Package:LISP

Returns the font, bits, and code attributes as a single non-negative integer. Equivalent to CHAR-CODE in GCL.

Constant: LEAST-NEGATIVE-SINGLE-FLOAT

Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT.

Function: /= (number &rest more-numbers)

Package:LISP

Returns T if no two of its arguments are numerically equal; NIL otherwise.

Function: LDB-TEST (bytespec integer)

Package:LISP

Returns T if at least one of the bits in the specified bytes of INTEGER is 1; NIL otherwise.

Constant: CHAR-CODE-LIMIT

Package:LISP The upper exclusive bound on values produced by CHAR-CODE.

Function: RATIONAL (number)

Package:LISP

Converts NUMBER into rational accurately and returns it.

Constant: PI

Package:LISP The floating-point number that is appropriately equal to the ratio of the circumference of the circle to the diameter.

Function: SIN (radians)

Package:LISP

Returns the sine of RADIANS.

Constant: BOOLE-ORC2

Package:LISP Makes BOOLE return LOGORC2 of INTEGER1 and INTEGER2.

Function: NUMERATOR (rational)

Package:LISP

Returns as an integer the numerator of the given rational number.

Function: MASK-FIELD (bytespec integer)

Package:LISP

Extracts the specified byte from INTEGER.

Special Form: INCF

Package:LISP

Syntax: 

(incf place [delta])

Adds the number produced by DELTA (which defaults to 1) to the number in PLACE.

Function: SINH (number)

Package:LISP

Returns the hyperbolic sine of NUMBER.

Function: PHASE (number)

Package:LISP

Returns the angle part of the polar representation of a complex number. For non-complex numbers, this is 0.

Function: BOOLE (op integer1 integer2)

Package:LISP

Returns an integer produced by performing the logical operation specified by OP on the two integers. OP must be the value of one of the following constants: BOOLE-CLR BOOLE-C1 BOOLE-XOR BOOLE-ANDC1 BOOLE-SET BOOLE-C2 BOOLE-EQV BOOLE-ANDC2 BOOLE-1 BOOLE-AND BOOLE-NAND BOOLE-ORC1 BOOLE-2 BOOLE-IOR BOOLE-NOR BOOLE-ORC2 See the variable docs of these constants for their operations.

Constant: SHORT-FLOAT-EPSILON

Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))).

Function: LOGORC2 (integer1 integer2)

Package:LISP

Returns the logical OR of INTEGER1 and (LOGNOT INTEGER2).

Constant: BOOLE-C2

Package:LISP Makes BOOLE return the complement of INTEGER2.

Function: REALPART (number)

Package:LISP

Extracts the real part of NUMBER.

Constant: BOOLE-CLR

Package:LISP Makes BOOLE return 0.

Constant: BOOLE-IOR

Package:LISP Makes BOOLE return LOGIOR of INTEGER1 and INTEGER2.

Function: FTRUNCATE (number &optional (divisor 1))

Package:LISP

Values: (quotient remainder) Same as TRUNCATE, but returns first value as a float.

Function: EQL (x y)

Package:LISP

Returns T if X and Y are EQ, or if they are numbers of the same type with the same value, or if they are character objects that represent the same character. Returns NIL otherwise.

Function: LOG (number &optional base)

Package:LISP

Returns the logarithm of NUMBER in the base BASE. BASE defaults to the base of natural logarithms.

Constant: DOUBLE-FLOAT-NEGATIVE-EPSILON

Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON.

Function: LOGIOR (&rest integers)

Package:LISP

Returns the bit-wise INCLUSIVE OR of its arguments.

Constant: MOST-NEGATIVE-DOUBLE-FLOAT

Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT.

Function: / (number &rest more-numbers)

Package:LISP

Divides the first NUMBER by each of the subsequent NUMBERS. With one arg, returns the reciprocal of the number.

Variable: *RANDOM-STATE*

Package:LISP The default random-state object used by RAMDOM.

Function: 1+ (number)

Package:LISP

Returns NUMBER + 1.

Constant: LEAST-NEGATIVE-DOUBLE-FLOAT

Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT.

Function: FCEILING (number &optional (divisor 1))

Package:LISP

Same as CEILING, but returns a float as the first value.

Constant: MOST-POSITIVE-FIXNUM

Package:LISP The fixnum closest in value to positive infinity.

Function: BIT-ANDC1 (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical ANDC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: TAN (radians)

Package:LISP

Returns the tangent of RADIANS.

Constant: BOOLE-NAND

Package:LISP Makes BOOLE return LOGNAND of INTEGER1 and INTEGER2.

Function: TANH (number)

Package:LISP

Returns the hyperbolic tangent of NUMBER.

Function: ASIN (number)

Package:LISP

Returns the arc sine of NUMBER.

Function: BYTE (size position)

Package:LISP

Returns a byte specifier. In GCL, a byte specifier is represented by a dotted pair (<size> . <position>).

Function: ASINH (number)

Package:LISP

Returns the hyperbolic arc sine of NUMBER.

Constant: MOST-POSITIVE-LONG-FLOAT

Package:LISP The long-float closest in value to positive infinity.

Macro: SHIFTF

Package:LISP

Syntax: 

(shiftf {place}+ newvalue)

Evaluates all PLACEs and NEWVALUE in turn, then assigns the value of each form to the PLACE on its left. Returns the original value of the leftmost form.

Constant: LEAST-POSITIVE-LONG-FLOAT

Package:LISP The positive long-float closest in value to zero.

Function: DEPOSIT-FIELD (newbyte bytespec integer)

Package:LISP

Returns an integer computed by replacing the specified byte of INTEGER with the specified byte of NEWBYTE.

Function: BIT-AND (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical AND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: LOGNAND (integer1 integer2)

Package:LISP

Returns the complement of the logical AND of INTEGER1 and INTEGER2.

Function: BYTE-POSITION (bytespec)

Package:LISP

Returns the position part (in GCL, the cdr part) of the byte specifier.

Macro: ROTATEF

Package:LISP

Syntax: 

(rotatef {place}*)

Evaluates PLACEs in turn, then assigns to each PLACE the value of the form to its right. The rightmost PLACE gets the value of the leftmost PLACE. Returns NIL always.

Function: BIT-ANDC2 (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical ANDC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: TRUNCATE (number &optional (divisor 1))

Package:LISP

Values: (quotient remainder) Returns NUMBER/DIVISOR as an integer, rounded toward 0. The second returned value is the remainder.

Constant: BOOLE-EQV

Package:LISP Makes BOOLE return LOGEQV of INTEGER1 and INTEGER2.

Constant: BOOLE-SET

Package:LISP Makes BOOLE return -1.

Function: LDB (bytespec integer)

Package:LISP

Extracts and right-justifies the specified byte of INTEGER, and returns the result.

Function: BYTE-SIZE (bytespec)

Package:LISP

Returns the size part (in GCL, the car part) of the byte specifier.

Constant: SHORT-FLOAT-NEGATIVE-EPSILON

Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (- (float 1 e) e))).

Function: REM (number divisor)

Package:LISP

Returns the second value of (TRUNCATE NUMBER DIVISOR).

Function: MIN (number &rest more-numbers)

Package:LISP

Returns the least of its arguments.

Function: EXP (number)

Package:LISP

Calculates e raised to the power NUMBER, where e is the base of natural logarithms.

Function: DECODE-FLOAT (float)

Package:LISP

Returns, as three values, the significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT)

S and F are floating-point numbers of the same float format as FLOAT, and E is an integer.

Constant: LONG-FLOAT-EPSILON

Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))).

Function: FROUND (number &optional (divisor 1))

Package:LISP

Same as ROUND, but returns first value as a float.

Function: LOGEQV (&rest integers)

Package:LISP

Returns the bit-wise EQUIVALENCE of its arguments.

Constant: MOST-NEGATIVE-SHORT-FLOAT

Package:LISP The short-float closest in value to negative infinity.

Function: BIT-NOR (bit-array1 bit-array2 &optional (result-bit-array nil))

Package:LISP

Performs a bit-wise logical NOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise.

Function: CEILING (number &optional (divisor 1))

Package:LISP

Returns the smallest integer not less than or NUMBER/DIVISOR. Returns the remainder as the second value.

Constant: LEAST-NEGATIVE-SHORT-FLOAT

Package:LISP The negative short-float closest in value to zero.

Function: 1- (number)

Package:LISP

Returns NUMBER - 1.

Function: <= (number &rest more-numbers)

Package:LISP

Returns T if arguments are in strictly non-decreasing order; NIL otherwise.

Function: IMAGPART (number)

Package:LISP

Extracts the imaginary part of NUMBER.

Function: INTEGERP (x)

Package:LISP

Returns T if X is an integer (fixnum or bignum); NIL otherwise.

Function: ASH (integer count)

Package:LISP

Shifts INTEGER left by COUNT places. Shifts right if COUNT is negative.

Function: LCM (integer &rest more-integers)

Package:LISP

Returns the least common multiple of the arguments.

Function: COS (radians)

Package:LISP

Returns the cosine of RADIANS.

Special Form: DECF

Package:LISP

Syntax: 

(decf place [delta])

Subtracts the number produced by DELTA (which defaults to 1) from the number in PLACE.

Function: ATAN (x &optional (y 1))

Package:LISP Returns the arc tangent of X/Y.

Constant: BOOLE-ANDC1

Package:LISP Makes BOOLE return LOGANDC1 of INTEGER1 and INTEGER2.

Function: COSH (number)

Package:LISP Returns the hyperbolic cosine of NUMBER.

Function: FLOAT-RADIX (float)

Package:LISP

Returns the representation radix (or base) of the floating-point number.

Function: ATANH (number)

Package:LISP

Returns the hyperbolic arc tangent of NUMBER.

Function: EVENP (integer)

Package:LISP Returns T if INTEGER is even. Returns NIL if INTEGER is odd.

Function: ZEROP (number)

Package:LISP Returns T if NUMBER = 0; NIL otherwise.

Function: FLOATP (x)

Package:LISP

Returns T if X is a floating-point number; NIL otherwise.

Function: SXHASH (object)

Package:LISP

Computes a hash code for OBJECT and returns it as an integer.

Constant: BOOLE-1

Package:LISP Makes BOOLE return INTEGER1.

Constant: MOST-POSITIVE-SINGLE-FLOAT

Package:LISP Same as MOST-POSITIVE-LONG-FLOAT.

Function: LOGANDC1 (integer1 integer2)

Package:LISP

Returns the logical AND of (LOGNOT INTEGER1) and INTEGER2.

Constant: LEAST-POSITIVE-SINGLE-FLOAT

Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT.

Function: COMPLEXP (x)

Package:LISP

Returns T if X is a complex number; NIL otherwise.

Constant: BOOLE-AND

Package:LISP Makes BOOLE return LOGAND of INTEGER1 and INTEGER2.

Function: MAX (number &rest more-numbers)

Package:LISP

Returns the greatest of its arguments.

Function: FLOAT-SIGN (float1 &optional (float2 (float 1 float1)))

Package:LISP

Returns a floating-point number with the same sign as FLOAT1 and with the same absolute value as FLOAT2.

Constant: BOOLE-ANDC2

Package:LISP Makes BOOLE return LOGANDC2 of INTEGER1 and INTEGER2.

Function: DENOMINATOR (rational)

Package:LISP

Returns the denominator of RATIONAL as an integer.

Function: FLOAT (number &optional other)

Package:LISP

Converts a non-complex number to a floating-point number. If NUMBER is already a float, FLOAT simply returns NUMBER. Otherwise, the format of the returned float depends on OTHER; If OTHER is not provided, FLOAT returns a SINGLE-FLOAT. If OTHER is provided, the result is in the same float format as OTHER’s.

Function: ROUND (number &optional (divisor 1))

Package:LISP

Rounds NUMBER/DIVISOR to nearest integer. The second returned value is the remainder.

Function: LOGAND (&rest integers)

Package:LISP

Returns the bit-wise AND of its arguments.

Constant: BOOLE-2

Package:LISP Makes BOOLE return INTEGER2.

Function: * (&rest numbers)

Package:LISP

Returns the product of its arguments. With no args, returns 1.

Function: < (number &rest more-numbers)

Package:LISP

Returns T if its arguments are in strictly increasing order; NIL otherwise.

Function: COMPLEX (realpart &optional (imagpart 0))

Package:LISP

Returns a complex number with the given real and imaginary parts.

Constant: SINGLE-FLOAT-EPSILON

Package:LISP Same as LONG-FLOAT-EPSILON.

Function: LOGANDC2 (integer1 integer2)

Package:LISP

Returns the logical AND of INTEGER1 and (LOGNOT INTEGER2).

Function: INTEGER-LENGTH (integer)

Package:LISP

Returns the number of significant bits in the absolute value of INTEGER.

Constant: MOST-NEGATIVE-FIXNUM

Package:LISP The fixnum closest in value to negative infinity.

Constant: LONG-FLOAT-NEGATIVE-EPSILON

Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (- (float 1 e) e))).

Function: >= (number &rest more-numbers)

Package:LISP

Returns T if arguments are in strictly non-increasing order; NIL otherwise.

Constant: BOOLE-NOR

Package:LISP Makes BOOLE return LOGNOR of INTEGER1 and INTEGER2.

Function: ACOS (number)

Package:LISP

Returns the arc cosine of NUMBER.

Function: MAKE-RANDOM-STATE (&optional (state *random-state*))

Package:LISP

Creates and returns a copy of the specified random state. If STATE is NIL, then the value of *RANDOM-STATE* is used. If STATE is T, then returns a random state object generated from the universal time.

Function: EXPT (base-number power-number)

Package:LISP

Returns BASE-NUMBER raised to the power POWER-NUMBER.

Function: SQRT (number)

Package:LISP

Returns the principal square root of NUMBER.

Function: SCALE-FLOAT (float integer)

Package:LISP

Returns (* FLOAT (expt (float-radix FLOAT) INTEGER)).

Function: ACOSH (number)

Package:LISP

Returns the hyperbolic arc cosine of NUMBER.

Constant: MOST-NEGATIVE-LONG-FLOAT

Package:LISP The long-float closest in value to negative infinity.

Constant: LEAST-NEGATIVE-LONG-FLOAT

Package:LISP The negative long-float closest in value to zero.

Function: FFLOOR (number &optional (divisor 1))

Package:LISP

Same as FLOOR, but returns a float as the first value.

Function: LOGNOR (integer1 integer2)

Package:LISP

Returns the complement of the logical OR of INTEGER1 and INTEGER2.

Function: PARSE-INTEGER (string &key (start 0) (end (length string)) (radix 10) (junk-allowed nil))

Package:LISP

Parses STRING for an integer and returns it.

Function: + (&rest numbers)

Package:LISP

Returns the sum of its arguments. With no args, returns 0.

Function: = (number &rest more-numbers)

Package:LISP

Returns T if all of its arguments are numerically equal; NIL otherwise.

Function: NUMBERP (x)

Package:LISP

Returns T if X is any kind of number; NIL otherwise.

Constant: MOST-POSITIVE-DOUBLE-FLOAT

Package:LISP Same as MOST-POSITIVE-LONG-FLOAT.

Function: LOGTEST (integer1 integer2)

Package:LISP

Returns T if LOGAND of INTEGER1 and INTEGER2 is not zero; NIL otherwise.

Function: RANDOM-STATE-P (x)

Package:LISP

Returns T if X is a random-state object; NIL otherwise.

Constant: LEAST-POSITIVE-DOUBLE-FLOAT

Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT.

Function: FLOAT-PRECISION (float)

Package:LISP

Returns the number of significant radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT).

Constant: BOOLE-XOR

Package:LISP Makes BOOLE return LOGXOR of INTEGER1 and INTEGER2.

Function: DPB (newbyte bytespec integer)

Package:LISP

Returns an integer computed by replacing the specified byte of INTEGER with NEWBYTE.

Function: ABS (number)

Package:LISP

Returns the absolute value of NUMBER.

Function: CONJUGATE (number)

Package:LISP

Returns the complex conjugate of NUMBER.

Function: CIS (radians)

Package:LISP

Returns e raised to i*RADIANS.

Function: ODDP (integer)

Package:LISP

Returns T if INTEGER is odd; NIL otherwise.

Function: RATIONALIZE (number)

Package:LISP

Converts NUMBER into rational approximately and returns it.

Function: ISQRT (integer)

Package:LISP

Returns the greatest integer less than or equal to the square root of the given non-negative integer.

Function: LOGXOR (&rest integers)

Package:LISP

Returns the bit-wise EXCLUSIVE OR of its arguments.

Function: > (number &rest more-numbers)

Package:LISP

Returns T if its arguments are in strictly decreasing order; NIL otherwise.

Function: LOGBITP (index integer)

Package:LISP

Returns T if the INDEX-th bit of INTEGER is 1.

Constant: DOUBLE-FLOAT-EPSILON

Package:LISP Same as LONG-FLOAT-EPSILON.

Function: LOGCOUNT (integer)

Package:LISP

If INTEGER is negative, returns the number of 0 bits. Otherwise, returns the number of 1 bits.

Function: GCD (&rest integers)

Package:LISP

Returns the greatest common divisor of INTEGERs.

Function: RATIONALP (x)

Package:LISP

Returns T if X is an integer or a ratio; NIL otherwise.

Function: MOD (number divisor)

Package:LISP

Returns the second result of (FLOOR NUMBER DIVISOR).

Function: MODF (number)

Package:SYSTEM

Returns the integer and fractional part of a floating point number mod 1.0.

Constant: BOOLE-ORC1

Package:LISP Makes BOOLE return LOGORC1 of INTEGER1 and INTEGER2.

Constant: SINGLE-FLOAT-NEGATIVE-EPSILON

Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON.

Function: FLOOR (number &optional (divisor 1))

Package:LISP

Returns the largest integer not larger than the NUMBER divided by DIVISOR. The second returned value is (- NUMBER (* first-value DIVISOR)).

Function: PLUSP (number)

Package:LISP

Returns T if NUMBER > 0; NIL otherwise.

Function: FLOAT-DIGITS (float)

Package:LISP

Returns the number of radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT).

Function: RANDOM (number &optional (state *random-state*))

Package:LISP

Generates a uniformly distributed pseudo-random number between zero (inclusive) and NUMBER (exclusive), by using the random state object STATE.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Regular-Expressions.html0000644000175000017500000002275514360276512017726 0ustar cammcamm Regular Expressions (GCL SI Manual)

Previous: , Up: System Definitions   [Contents][Index]

17.1 Regular Expressions

The function string-match (*Index string-match::) is used to match a regular expression against a string. If the variable *case-fold-search* is not nil, case is ignored in the match. To determine the extent of the match use *Index match-beginning:: and *Index match-end::.

Regular expressions are implemented using Henry Spencer’s package (thank you Henry!), and much of the description of regular expressions below is copied verbatim from his manual entry. Code for delimited searches, case insensitive searches, and speedups to allow fast searching of long files was contributed by W. Schelter. The speedups use an adaptation by Schelter of the Boyer and Moore string search algorithm to the case of branched regular expressions. These allow such expressions as ’not_there|really_not’ to be searched for 30 times faster than in GNU emacs (1995), and 200 times faster than in the original Spencer method. Expressions such as [a-u]bcdex get a speedup of 60 and 194 times respectively. This is based on searching a string of 50000 characters (such as the file tk.lisp).

  • A regular expression is a string containing zero or more branches which are separated by |. A match of the regular expression against a string is simply a match of the string with one of the branches.
  • Each branch consists of zero or more pieces, concatenated. A matching string must contain an initial substring matching the first piece, immediately followed by a second substring matching the second piece and so on.
  • Each piece is an atom optionally followed by +, *, or ?.
  • An atom followed by + matches a sequence of 1 or more matches of the atom.
  • An atom followed by * matches a sequence of 0 or more matches of the atom.
  • An atom followed by ? matches a match of the atom, or the null string.
  • An atom is
    • - a regular expression in parentheses matching a match for the regular expression
    • - a range see below
    • - a . matching any single character
    • - a ^ matching the null string at the beginning of the input string
    • - a $ matching the null string at the end of the input string
    • - a \ followed by a single character matching that character
    • - a single character with no other significance (matching that character).
  • A range is a sequence of characters enclosed in []. It normally matches any single character from the sequence.
    • - If the sequence begins with ^, it matches any single character not from the rest of the sequence.
    • - If two characters in the sequence are separated by -, this is shorthand for the full list of ASCII characters between them (e.g. [0-9] matches any decimal digit).
    • - To include a literal ] in the sequence, make it the first character (following a possible ^).
    • - To include a literal -, make it the first or last character.

Ordering Multiple Matches

In general there may be more than one way to match a regular expression to an input string. For example, consider the command 

 (string-match "(a*)b*"  "aabaaabb")

Considering only the rules given so far, the value of (list-matches 0 1) might be ("aabb" "aa") or ("aaab" "aaa") or ("ab" "a") or any of several other combinations. To resolve this potential ambiguity string-match chooses among alternatives using the rule first then longest. In other words, it considers the possible matches in order working from left to right across the input string and the pattern, and it attempts to match longer pieces of the input string before shorter ones. More specifically, the following rules apply in decreasing order of priority:

  • [1] If a regular expression could match two different parts of an input string then it will match the one that begins earliest.
  • [2] If a regular expression contains | operators then the leftmost matching sub-expression is chosen.
  • [3] In *, +, and ? constructs, longer matches are chosen in preference to shorter ones.
  • [4] In sequences of expression components the components are considered from left to right.

In the example from above, (a*)b* matches aab: the (a*) portion of the pattern is matched first and it consumes the leading aa; then the b* portion of the pattern consumes the next b. Or, consider the following example: 

 (string-match "(ab|a)(b*)c"  "xabc") ==> 1
 (list-matches 0 1 2 3) ==> ("abc" "ab" "" NIL)
 (match-beginning 0) ==> 1
 (match-end 0) ==> 4
 (match-beginning 1) ==> 1
 (match-end 1) ==> 3
 (match-beginning 2) ==> 3
 (match-end 2) ==> 3
 (match-beginning 3) ==> -1
 (match-end 3) ==> -1

In the above example the return value of 1 (which is > -1) indicates that a match was found. The entire match runs from 1 to 4. Rule 4 specifies that (ab|a) gets first shot at the input string and Rule 2 specifies that the ab sub-expression is checked before the a sub-expression. Thus the b has already been claimed before the (b*) component is checked and (b*) must match an empty string.

The special characters in the string "\()[]+.*|^$?", must be quoted, if a simple string search is desired. The function re-quote-string is provided for this purpose. 

(re-quote-string "*standard*") ==> "\\*standard\\*"

(string-match (re-quote-string "*standard*") "X *standard* ")
 ==> 2

(string-match "*standard*" "X *standard* ")
Error: Regexp Error: ?+* follows nothing

Note there is actually just one \ before the * but the printer makes two so that the string can be read, since \ is also the lisp quote character. In the last example an error is signalled since the special character * must follow an atom if it is interpreted as a regular expression.

Previous: , Up: System Definitions   [Contents][Index]

gcl-2.6.14/info/gcl-si/Streams-and-Reading.html0000644000175000017500000010641314360276512017524 0ustar cammcamm Streams and Reading (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

5 Streams and Reading

Function: MAKE-ECHO-STREAM (input-stream output-stream)

Package:LISP

Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM. In addition, all input is echoed to OUTPUT-STREAM.

Variable: *READTABLE*

Package:LISP The current readtable.

Function: LOAD (filename &key (verbose *load-verbose*) (print nil) (if-does-not-exist :error))

Package:LISP

Loads the file named by FILENAME into GCL.

Function: OPEN (filename &key (direction :input) (element-type 'string-char) (if-exists :error) (if-does-not-exist :error))

Package:LISP

Opens the file specified by FILENAME, which may be a string, a pathname, or a stream. Returns a stream for the open file. DIRECTION is :INPUT, :OUTPUT, :IO or :PROBE. ELEMENT-TYPE is STRING-CHAR, (UNSIGNED-BYTE n), UNSIGNED-BYTE, (SIGNED-BYTE n), SIGNED-BYTE, CHARACTER, BIT, (MOD n), or :DEFAULT. IF-EXISTS is :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE, or NIL. IF-DOES-NOT-EXIST is :ERROR, :CREATE, or NIL.

If FILENAME begins with a vertical pipe sign: ’|’ then the resulting stream is actually a one way pipe. It will be open for reading or writing depending on the direction given. The rest of FILENAME in this case is passed to the /bin/sh command. See the posix description of popen for more details. 

(setq pipe (open "| wc < /tmp/jim"))
(format t "File has ~%d lines" (read pipe))
(close pipe)
Variable: *PRINT-BASE*

Package:LISP The radix in which the GCL printer prints integers and rationals. The value must be an integer from 2 to 36, inclusive.

Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string)))

Package:LISP

Returns an input stream which will supply the characters of String between Start and End in order.

Function: PPRINT (object &optional (stream *standard-output*))

Package:LISP

Pretty-prints OBJECT. Returns OBJECT. Equivalent to (WRITE :STREAM STREAM :PRETTY T) The SI:PRETTY-PRINT-FORMAT property N (which must be a non-negative integer) of a symbol SYMBOL controls the pretty-printing of form (SYMBOL f1 ... fN fN+1 ... fM) in such a way that the subforms fN+1, ..., fM are regarded as the ’body’ of the entire form. For instance, the property value of 2 is initially given to the symbol DO.

Variable: *READ-DEFAULT-FLOAT-FORMAT*

Package:LISP The floating-point format the GCL reader uses when reading floating-point numbers that have no exponent marker or have e or E for an exponent marker. Must be one of SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, and LONG-FLOAT.

Function: READ-PRESERVING-WHITESPACE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))

Package:LISP

Reads an object from STREAM, preserving the whitespace that followed the object.

Function: STREAMP (x)

Package:LISP

Returns T if X is a stream object; NIL otherwise.

Function: SET-DISPATCH-MACRO-CHARACTER (disp-char sub-char function &optional (readtable *readtable*))

Package:LISP

Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is read.

Macro: WITH-OUTPUT-TO-STRING

Package:LISP

Syntax: 

(with-output-to-string (var [string]) {decl}* {form}*)

Binds VAR to a string output stream that puts characters into STRING, which defaults to a new string. The stream is automatically closed on exit and the string is returned.

Function: FILE-LENGTH (file-stream)

Package:LISP

Returns the length of the specified file stream.

Variable: *PRINT-CASE*

Package:LISP The case in which the GCL printer should print ordinary symbols. The value must be one of the keywords :UPCASE, :DOWNCASE, and :CAPITALIZE.

Function: PRINT (object &optional (stream *standard-output*))

Package:LISP

Outputs a newline character, and then prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (PROGN (TERPRI STREAM) (WRITE OBJECT :STREAM STREAM :ESCAPE T)).

Function: SET-MACRO-CHARACTER (char function &optional (non-terminating-p nil) (readtable *readtable*))

Package:LISP

Causes CHAR to be a macro character that, when seen by READ, causes FUNCTION to be called.

Function: FORCE-OUTPUT (&optional (stream *standard-output*))

Package:LISP

Attempts to force any buffered output to be sent.

Variable: *PRINT-ARRAY*

Package:LISP Whether the GCL printer should print array elements.

Function: STREAM-ELEMENT-TYPE (stream)

Package:LISP

Returns a type specifier for the kind of object returned by STREAM.

Function: WRITE-BYTE (integer stream)

Package:LISP

Outputs INTEGER to the binary stream STREAM. Returns INTEGER.

Function: MAKE-CONCATENATED-STREAM (&rest streams)

Package:LISP

Returns a stream which takes its input from each of the STREAMs in turn, going on to the next at end of stream.

Function: PRIN1 (object &optional (stream *standard-output*))

Package:LISP

Prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE T).

Function: PRINC (object &optional (stream *standard-output*))

Package:LISP

Prints OBJECT without escape characters. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE NIL).

Function: CLEAR-OUTPUT (&optional (stream *standard-output*))

Package:LISP

Clears the output stream STREAM.

Function: TERPRI (&optional (stream *standard-output*))

Package:LISP

Outputs a newline character.

Function: FINISH-OUTPUT (&optional (stream *standard-output*))

Package:LISP

Attempts to ensure that all output sent to STREAM has reached its destination, and only then returns.

Macro: WITH-OPEN-FILE

Package:LISP

Syntax: 

(with-open-file (stream filename {options}*) {decl}* {form}*)

Opens the file whose name is FILENAME, using OPTIONs, and binds the variable STREAM to a stream to/from the file. Then evaluates FORMs as a PROGN. The file is automatically closed on exit.

Special Form: DO

Package:LISP

Syntax: 

(do ({(var [init [step]])}*) (endtest {result}*)
          {decl}* {tag | statement}*)

Creates a NIL block, binds each VAR to the value of the corresponding INIT, and then executes STATEMENTs repeatedly until ENDTEST is satisfied. After each iteration, assigns to each VAR the value of the corresponding STEP. When ENDTEST is satisfied, evaluates RESULTs as a PROGN and returns the value(s) of the last RESULT (or NIL if no RESULTs are supplied). Performs variable bindings and assignments all at once, just like LET and PSETQ do.

Function: READ-FROM-STRING (string &optional (eof-error-p t) (eof-value nil) &key (start 0) (end (length string)) (preserve-whitespace nil))

Package:LISP

Reads an object from STRING.

Function: WRITE-STRING (string &optional (stream *standard-output*) &key (start 0) (end (length string)))

Package:LISP

Outputs STRING and returns it.

Variable: *PRINT-LEVEL*

Package:LISP How many levels deep the GCL printer should print. Unlimited if NIL.

Variable: *PRINT-RADIX*

Package:LISP Whether the GCL printer should print the radix indicator when printing integers and rationals.

Function: Y-OR-N-P (&optional (format-string nil) &rest args)

Package:LISP

Asks the user a question whose answer is either ’Y’ or ’N’. If FORMAT-STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Y or N)" is printed. Otherwise, no prompt will appear.

Function: MAKE-BROADCAST-STREAM (&rest streams)

Package:LISP

Returns an output stream which sends its output to all of the given streams.

Function: READ-CHAR (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))

Package:LISP

Reads a character from STREAM.

Function: PEEK-CHAR (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))

Package:LISP

Peeks at the next character in the input stream STREAM.

Function: OUTPUT-STREAM-P (stream)

Package:LISP

Returns non-nil if STREAM can handle output operations; NIL otherwise.

Variable: *QUERY-IO*

Package:LISP The query I/O stream.

Variable: *READ-BASE*

Package:LISP The radix that the GCL reader reads numbers in.

Macro: WITH-OPEN-STREAM

Package:LISP

Syntax: 

(with-open-stream (var stream) {decl}* {form}*)

Evaluates FORMs as a PROGN with VAR bound to the value of STREAM. The stream is automatically closed on exit.

Macro: WITH-INPUT-FROM-STRING

Package:LISP

Syntax: 

(with-input-from-string (var string {keyword value}*) {decl}*
{form}*)

Binds VAR to an input stream that returns characters from STRING and evaluates the FORMs. The stream is automatically closed on exit. Allowed keywords are :INDEX, :START, and :END.

Function: CLEAR-INPUT (&optional (stream *standard-input*))

Package:LISP Clears the input stream STREAM.

Variable: *TERMINAL-IO*

Package:LISP The terminal I/O stream.

Function: LISTEN (&optional (stream *standard-input*))

Package:LISP

Returns T if a character is available on STREAM; NIL otherwise. This function does not correctly work in some versions of GCL because of the lack of such mechanism in the underlying operating system.

Function: MAKE-PATHNAME (&key (defaults (parse-namestring "" (pathname-host *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults)) (directory (pathname-directory defaults)) (name (pathname-name defaults)) (type (pathname-type defaults)) (version (pathname-version defaults)))

Package:LISP

Create a pathname from HOST, DEVICE, DIRECTORY, NAME, TYPE and VERSION.

Function: PATHNAME-TYPE (pathname)

Package:LISP

Returns the type slot of PATHNAME.

Variable: *PRINT-GENSYM*

Package:LISP Whether the GCL printer should prefix symbols with no home package with "#:".

Function: READ-LINE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))

Package:LISP

Returns a line of text read from STREAM as a string, discarding the newline character.

Note that when using line at a time input under unix, input forms will always be followed by a #\newline. Thus if you do

>(read-line) "" nil

the empty string will be returned. After lisp reads the (read-line) it then invokes (read-line). This happens before it does anything else and so happens before the newline character immediately following (read-line) has been read. Thus read-line immediately encounters a #\newline and so returns the empty string. If there had been other characters before the #\newline it would have been different:

>(read-line) how are you " how are you" nil

If you want to throw away "" input, you can do that with the following:

(sloop::sloop while (equal (setq input (read-line)) ""))

You may also want to use character at a time input, but that makes input editing harder. nicolas% stty cbreak nicolas% gcl GCL (GNU Common Lisp) Version(1.1.2) Mon Jan 9 12:58:22 MET 1995 Licensed under GNU Public Library License Contains Enhancements by W. Schelter

>(let ((ifilename nil)) (format t "~%Input file name: ") (setq ifilename (read-line))) Input file name: /tmp/myfile "/tmp/myfile"

>(bye)Bye.

Function: WRITE-TO-STRING (object &key (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*))

Package:LISP

Returns as a string the printed representation of OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode.

Function: PATHNAMEP (x)

Package:LISP

Returns T if X is a pathname object; NIL otherwise.

Function: READTABLEP (x)

Package:LISP

Returns T if X is a readtable object; NIL otherwise.

Function: READ (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil))

Package:LISP

Reads in the next object from STREAM.

Function: NAMESTRING (pathname)

Package:LISP

Returns the full form of PATHNAME as a string.

Function: UNREAD-CHAR (character &optional (stream *standard-input*))

Package:LISP

Puts CHARACTER back on the front of the input stream STREAM.

Function: CLOSE (stream &key (abort nil))

Package:LISP

Closes STREAM. A non-NIL value of :ABORT indicates an abnormal termination.

Variable: *PRINT-LENGTH*

Package:LISP How many elements the GCL printer should print at each level of nested data object. Unlimited if NIL.

Function: SET-SYNTAX-FROM-CHAR (to-char from-char &optional (to-readtable *readtable*) (from-readtable nil))

Package:LISP

Makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax of FROM-CHAR in FROM-READTABLE.

Function: INPUT-STREAM-P (stream)

Package:LISP

Returns non-NIL if STREAM can handle input operations; NIL otherwise.

Function: PATHNAME (x)

Package:LISP

Turns X into a pathname. X may be a string, symbol, stream, or pathname.

Function: FILE-NAMESTRING (pathname)

Package:LISP

Returns the written representation of PATHNAME as a string.

Function: MAKE-DISPATCH-MACRO-CHARACTER (char &optional (non-terminating-p nil) (readtable *readtable*))

Package:LISP

Causes the character CHAR to be a dispatching macro character in READTABLE.

Variable: *STANDARD-OUTPUT*

Package:LISP The default output stream used by the GCL printer.

Function: MAKE-TWO-WAY-STREAM (input-stream output-stream)

Package:LISP

Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM.

Variable: *PRINT-ESCAPE*

Package:LISP Whether the GCL printer should put escape characters whenever appropriate.

Function: COPY-READTABLE (&optional (from-readtable *readtable*) (to-readtable nil))

Package:LISP

Returns a copy of the readtable FROM-READTABLE. If TO-READTABLE is non-NIL, then copies into TO-READTABLE. Otherwise, creates a new readtable.

Function: DIRECTORY-NAMESTRING (pathname)

Package:LISP

Returns the directory part of PATHNAME as a string.

Function: TRUENAME (pathname)

Package:LISP

Returns the pathname for the actual file described by PATHNAME.

Variable: *READ-SUPPRESS*

Package:LISP When the value of this variable is NIL, the GCL reader operates normally. When it is non-NIL, then the reader parses input characters but much of what is read is not interpreted.

Function: GET-DISPATCH-MACRO-CHARACTER (disp-char sub-char &optional (readtable *readtable*))

Package:LISP

Returns the macro-character function for SUB-CHAR under DISP-CHAR.

Function: PATHNAME-DEVICE (pathname)

Package:LISP

Returns the device slot of PATHNAME.

Function: READ-CHAR-NO-HANG (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))

Package:LISP

Returns the next character from STREAM if one is available; NIL otherwise.

Function: FRESH-LINE (&optional (stream *standard-output*))

Package:LISP

Outputs a newline if it is not positioned at the beginning of a line. Returns T if it output a newline; NIL otherwise.

Function: WRITE-CHAR (char &optional (stream *standard-output*))

Package:LISP

Outputs CHAR and returns it.

Function: PARSE-NAMESTRING (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) (end (length thing)) (junk-allowed nil))

Package:LISP

Parses a string representation of a pathname into a pathname. HOST is ignored.

Function: PATHNAME-DIRECTORY (pathname)

Package:LISP

Returns the directory slot of PATHNAME.

Function: GET-MACRO-CHARACTER (char &optional (readtable *readtable*))

Package:LISP

Returns the function associated with CHAR and, as a second value, returns the non-terminating-p flag.

Function: FORMAT (destination control-string &rest arguments)

Package:LISP

Provides various facilities for formatting output. DESTINATION controls where the result will go. If DESTINATION is T, then the output is sent to the standard output stream. If it is NIL, then the output is returned in a string as the value of the call. Otherwise, DESTINATION must be a stream to which the output will be sent.

CONTROL-STRING is a string to be output, possibly with embedded formatting directives, which are flagged with the escape character "~". Directives generally expand into additional text to be output, usually consuming one or more of ARGUMENTs in the process.

A few useful directives are: 


~A, ~nA, ~n@A	Prints one argument as if by PRINC
~S, ~nS, ~n@S	Prints one argument as if by PRIN1
~D, ~B, ~O, ~X	Prints one integer in decimal, binary, octal, and hexa
~%		Does TERPRI
~&		Does FRESH-LINE

where n is the minimal width of the field in which the object is printed. ~nA and ~nS put padding spaces on the right; ~n@A and ~n@S put on the left. 

~R  is for printing numbers in various formats.

  ~nR   prints arg in radix n.
  ~R    prints arg as a cardinal english number: two
  ~:R   prints arg as an ordinal english number: third
  ~@R   prints arg as an a Roman Numeral: VII
  ~:@R   prints arg as an old Roman Numeral: IIII

~C prints a character.
  ~:C represents non printing characters by their pretty names,eg Space
  ~@C uses the #\ syntax to allow the reader to read it.

~F prints a floating point number arg.
  The full form is ~w,d,k,overflowchar,padcharF
  w represents the total width of the printed representation (variable if
    not present)
  d the number of fractional digits to display
    (format nil "~,2f" 10010.0314) --> "10010.03"
  k arg is multiplied by 10^k before printing it as a decimal number.
  overflowchar width w characters copies of the overflow character will
    be printed.   eg(format t "X>~5,2,,'?F<X" 100.034) --> X>?????<X
  padchar is the character to pad with
    (format t "X>~10,2,1,'?,'bF<X" 100.03417) -->X>bbb1000.34<X
  @ makes + sign print if the arg is positive

~@[print-if-true~]

if arg is not nil, then it is retained as an arg for further printing, otherwise it is used up 

   (format nil "~@[x = ~d~]~a" nil 'bil) --> "BIL"
   (format nil "~@[x = ~d ~]~a" 8) --> "x = 8 BIL"
Function: PATHNAME-NAME (pathname)

Package:LISP

Returns the name slot of PATHNAME.

Function: MAKE-STRING-OUTPUT-STREAM ()

Package:LISP

Returns an output stream which will accumulate all output given it for the benefit of the function GET-OUTPUT-STREAM-STRING.

Function: MAKE-SYNONYM-STREAM (symbol)

Package:LISP

Returns a stream which performs its operations on the stream which is the value of the dynamic variable named by SYMBOL.

Variable: *LOAD-VERBOSE*

Package:LISP The default for the VERBOSE argument to LOAD.

Variable: *PRINT-CIRCLE*

Package:LISP Whether the GCL printer should take care of circular lists.

Variable: *PRINT-PRETTY*

Package:LISP Whether the GCL printer should pretty-print. See the function doc of PPRINT for more information about pretty-printing.

Function: FILE-WRITE-DATE (file)

Package:LISP

Returns the time at which the specified file is written, as an integer in universal time format. FILE may be a string or a stream.

Function: PRIN1-TO-STRING (object)

Package:LISP

Returns as a string the printed representation of OBJECT in the mostly readable representation. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE T).

Function: MERGE-PATHNAMES (pathname &optional (defaults *default-pathname-defaults*) default-version)

Package:LISP

Fills in unspecified slots of PATHNAME from DEFAULTS. DEFAULT-VERSION is ignored in GCL.

Function: READ-BYTE (stream &optional (eof-error-p t) (eof-value nil))

Package:LISP

Reads the next byte from STREAM.

Function: PRINC-TO-STRING (object)

Package:LISP

Returns as a string the printed representation of OBJECT without escape characters. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE NIL).

Variable: *STANDARD-INPUT*

Package:LISP The default input stream used by the GCL reader.

Function: PROBE-FILE (file)

Package:LISP

Returns the truename of file if the file exists. Returns NIL otherwise.

Function: PATHNAME-VERSION (pathname)

Package:LISP

Returns the version slot of PATHNAME.

Function: WRITE-LINE (string &optional (stream *standard-output*) &key (start 0) (end (length string)))

Package:LISP

Outputs STRING and then outputs a newline character. Returns STRING.

Function: WRITE (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*))

Package:LISP

Prints OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode.

Function: GET-OUTPUT-STREAM-STRING (stream)

Package:LISP

Returns a string of all the characters sent to STREAM made by MAKE-STRING-OUTPUT-STREAM since the last call to this function.

Function: READ-DELIMITED-LIST (char &optional (stream *standard-input*) (recursive-p nil))

Package:LISP

Reads objects from STREAM until the next character after an object’s representation is CHAR. Returns a list of the objects read.

Function: READLINE-ON ()

Package:SI

Begins readline command editing mode when possible. In addition to the basic readline editing features, command word completion is implemented according to the following scheme:

[[pkg]:[:]]txt

pkg – an optional package specifier. Defaults to the current package. The symbols in this package and those in the packages in this package’s use list will be searched.

:[:] – an optional internal/external specifier. Defaults to external. The keyword package is denoted by a single colon at the beginning of the token. Only symbols of this type will be searched for completion.

txt – a string. Symbol names beginning with this string are completed. The comparison is case insensitive.

Function: READLINE-OFF ()

Package:SI

Disables readline command editing mode.

Variable: *READLINE-PREFIX*

Package:SI

A string implicitly prepended to input text for use in readline command completion. If this string contains one or more colons, it is used to specify the default package and internal/external setting for searched symbols in the case that the supplied text itself contains no explicit package specification. If this string contains characters after the colon(s), or contains no colons at all, it is treated as a symbol name prefix. In this case, the prefix is matched first, then the supplied text, and the completion returned is relative to the supplied text itself, i.e. contains no prefix. For example, the setting “maxima::$” will complete input text “int” according to the internal symbols in the maxima package of the form “maxima::$int...”, and return suggestions to the user of the form “int...”.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Environment.html0000644000175000017500000000524214360276512016301 0ustar cammcamm Environment (GCL SI Manual)

Next: , Previous: , Up: Miscellaneous   [Contents][Index]

19.1 Environment

The environment in GCL which is passed to macroexpand and other functions requesting an environment, should be a list of 3 lists. The first list looks like ((v1 val1) (v2 val2) ..) where vi are variables and vali are their values. The second is a list of ((fname1 . fbody1) (fname2 . fbody2) ...) where fbody1 is either (macro lambda-list lambda-body) or (lambda-list lambda-body) depending on whether this is a macro or a function. The third list contains tags and blocks.

gcl-2.6.14/info/gcl-si/Symbols.html0000644000175000017500000003741014360276512015427 0ustar cammcamm Symbols (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

8 Symbols

Function: GENSYM (&optional (x nil))

Package:LISP

Creates and returns a new uninterned symbol whose name is a prefix string (defaults to "G"), followed by a decimal number. The number is incremented by each call to GENSYM. X, if an integer, resets the counter. If X is a string, it becomes the new prefix.

Function: KEYWORDP (x)

Package:LISP

Returns T if X is a symbol and it belongs to the KEYWORD package; NIL otherwise.

Function: REMPROP (symbol indicator)

Package:LISP

Look on property list of SYMBOL for property with specified INDICATOR. If found, splice this indicator and its value out of the plist, and return T. If not found, returns NIL with no side effects.

Function: SYMBOL-PACKAGE (symbol)

Package:LISP

Returns the contents of the package cell of the symbol SYMBOL.

Variable: *PACKAGE*

Package:LISP The current package.

Function: SHADOWING-IMPORT (symbols &optional (package *package*))

Package:LISP

Imports SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol of the same name is already present, then it is uninterned. SYMBOLS must be a list of symbols or a symbol.

Macro: REMF

Package:LISP

Syntax: 

(remf place indicator)

PLACE may be any place expression acceptable to SETF, and is expected to hold a property list or NIL. This list is destructively altered to remove the property specified by INDICATOR. Returns T if such a property was present; NIL otherwise.

Function: MAKUNBOUND (symbol)

Package:LISP

Makes empty the value slot of SYMBOL. Returns SYMBOL.

Function: USE-PACKAGE (packages-to-use &optional (package *package*))

Package:LISP

Adds all packages in PACKAGE-TO-USE list to the use list for PACKAGE so that the external symbols of the used packages are available as internal symbols in PACKAGE.

Function: MAKE-SYMBOL (string)

Package:LISP

Creates and returns a new uninterned symbol whose print name is STRING.

Special Form: PSETQ

Package:LISP

Syntax: 

(psetq {var form}*)

Similar to SETQ, but evaluates all FORMs first, and then assigns each value to the corresponding VAR. Returns NIL always.

Function: PACKAGE-USED-BY-LIST (package)

Package:LISP

Returns the list of packages that use PACKAGE.

Function: SYMBOLP (x)

Package:LISP

Returns T if X is a symbol; NIL otherwise.

Constant: NIL

Package:LISP Holds NIL.

Function: SET (symbol value)

Package:LISP

Assigns the value of VALUE to the dynamic variable named by SYMBOL, and returns the value assigned.

Special Form: SETQ

Package:LISP

Syntax: 

(setq {var form}*)

VARs are not evaluated and must be symbols. Assigns the value of the first FORM to the first VAR, then assigns the value of the second FORM to the second VAR, and so on. Returns the last value assigned.

Function: UNUSE-PACKAGE (packages-to-unuse &optional (package *package*))

Package:LISP

Removes PACKAGES-TO-UNUSE from the use list for PACKAGE.

Constant: T

Package:LISP Holds T.

Function: PACKAGE-USE-LIST (package)

Package:LISP

Returns the list of packages used by PACKAGE.

Function: LIST-ALL-PACKAGES ()

Package:LISP

Returns a list of all existing packages.

Function: COPY-SYMBOL (symbol &optional (copy-props nil))

Package:LISP

Returns a new uninterned symbol with the same print name as SYMBOL. If COPY-PROPS is NIL, the function, the variable, and the property slots of the new symbol have no value. Otherwise, these slots are given the values of the corresponding slots of SYMBOL.

Function: SYMBOL-PLIST (symbol)

Package:LISP

Returns the property list of SYMBOL.

Function: SYMBOL-NAME (symbol)

Package:LISP

Returns the print name of the symbol SYMBOL.

Function: FIND-SYMBOL (name &optional (package *package*))

Package:LISP

Returns the symbol named NAME in PACKAGE. If such a symbol is found, then the second value is :INTERN, :EXTERNAL, or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL.

Function: SHADOW (symbols &optional (package *package*))

Package:LISP

Creates an internal symbol in PACKAGE with the same name as each of the specified SYMBOLS. SYMBOLS must be a list of symbols or a symbol.

Function: FBOUNDP (symbol)

Package:LISP

Returns T if SYMBOL has a global function definition or if SYMBOL names a special form or a macro; NIL otherwise.

Function: MACRO-FUNCTION (symbol)

Package:LISP

If SYMBOL globally names a macro, then returns the expansion function. Returns NIL otherwise.

Function: IN-PACKAGE (package-name &key (nicknames nil) (use '(lisp)))

Package:LISP

Sets *PACKAGE* to the package with PACKAGE-NAME, creating the package if it does not exist. If the package already exists then it is modified to agree with USE and NICKNAMES arguments. Any new nicknames are added without removing any old ones not specified. If any package in the USE list is not currently used, then it is added to the use list.

Function: MAKE-PACKAGE (package-name &key (nicknames nil) (use '(lisp)))

Package:LISP

Makes a new package having the specified PACKAGE-NAME and NICKNAMES. The package will inherit all external symbols from each package in the USE list.

Function: PACKAGE-SHADOWING-SYMBOLS (package)

Package:LISP

Returns the list of symbols that have been declared as shadowing symbols in PACKAGE.

Function: INTERN (name &optional (package *package*))

Package:LISP

Returns a symbol having the specified name, creating it if necessary. Returns as the second value one of the symbols :INTERNAL, :EXTERNAL, :INHERITED, and NIL.

Function: EXPORT (symbols &optional (package *package*))

Package:LISP

Makes SYMBOLS external symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol.

Function: PACKAGEP (x)

Package:LISP

Returns T if X is a package; NIL otherwise.

Function: SYMBOL-FUNCTION (symbol)

Package:LISP

Returns the current global function definition named by SYMBOL.

Function: SYMBOL-VALUE (symbol)

Package:LISP

Returns the current value of the dynamic (special) variable named by SYMBOL.

Function: BOUNDP (symbol)

Package:LISP

Returns T if the global variable named by SYMBOL has a value; NIL otherwise.

Function: DOCUMENTATION (symbol doc-type)

Package:LISP

Returns the doc-string of DOC-TYPE for SYMBOL; NIL if none exists. Possible doc-types are: FUNCTION (special forms, macros, and functions) VARIABLE (dynamic variables, including constants) TYPE (types defined by DEFTYPE) STRUCTURE (structures defined by DEFSTRUCT) SETF (SETF methods defined by DEFSETF, DEFINE-SETF-METHOD, and DEFINE-MODIFY-MACRO) All built-in special forms, macros, functions, and variables have their doc-strings.

Function: GENTEMP (&optional (prefix "t") (package *package*))

Package:LISP

Creates a new symbol interned in the package PACKAGE with the given PREFIX.

Function: RENAME-PACKAGE (package new-name &optional (new-nicknames nil))

Package:LISP

Replaces the old name and nicknames of PACKAGE with NEW-NAME and NEW-NICKNAMES.

Function: UNINTERN (symbol &optional (package *package*))

Package:LISP

Makes SYMBOL no longer present in PACKAGE. Returns T if SYMBOL was present; NIL otherwise. If PACKAGE is the home package of SYMBOL, then makes SYMBOL uninterned.

Function: UNEXPORT (symbols &optional (package *package*))

Package:LISP

Makes SYMBOLS no longer accessible as external symbols in PACKAGE. SYMBOLS must be a list of symbols or a symbol.

Function: PACKAGE-NICKNAMES (package)

Package:LISP

Returns as a list the nickname strings for the specified PACKAGE.

Function: IMPORT (symbols &optional (package *package*))

Package:LISP

Makes SYMBOLS internal symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol.

Function: GET (symbol indicator &optional (default nil))

Package:LISP

Looks on the property list of SYMBOL for the specified INDICATOR. If this is found, returns the associated value. Otherwise, returns DEFAULT.

Function: FIND-ALL-SYMBOLS (string-or-symbol)

Package:LISP

Returns a list of all symbols that have the specified name.

Function: FMAKUNBOUND (symbol)

Package:LISP

Discards the global function definition named by SYMBOL. Returns SYMBOL.

Function: PACKAGE-NAME (package)

Package:LISP

Returns the string that names the specified PACKAGE.

Function: FIND-PACKAGE (name)

Package:LISP

Returns the specified package if it already exists; NIL otherwise. NAME may be a string that is the name or nickname of the package. NAME may also be a symbol, in which case the symbol’s print name is used.

Function: APROPOS-LIST (string &optional (package nil))

Package:LISP

Returns, as a list, all symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Structures.html0000644000175000017500000000717114360276512016163 0ustar cammcamm Structures (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

10 Structures

Macro: DEFSTRUCT

Package:LISP

Syntax: 

(defstruct
         {name | (name {:conc-name | (:conc-name prefix-string) |
                        :constructor | (:constructor symbol [lambda-list]) |
                        :copier | (:copier symbol) |
                        :predicate | (:predicate symbol) | 
                        (:include symbol) |
                        (:print-function function) |
                        (:type {vector | (vector type) | list}) |
                        :named | (:static { nil | t})
                        (:initial-offset number)}*)}
         [doc]
         {slot-name |
          (slot-name [default-value-form] {:type type | :read-only flag}*) }*
         )

Defines a structure. The doc-string DOC, if supplied, is saved as a STRUCTURE doc and can be retrieved by (documentation ’NAME ’structure). STATIC is gcl specific and makes the body non relocatable.

See the files misc/rusage.lsp misc/cstruct.lsp, for examples of making a lisp structure correspond to a C structure.

Function: HELP (&optional symbol)

Package:LISP

GCL specific: Prints the documentation associated with SYMBOL. With no argument, this function prints the greeting message to GCL beginners.

gcl-2.6.14/info/gcl-si/Available-Symbols.html0000644000175000017500000000501114360276512017275 0ustar cammcamm Available Symbols (GCL SI Manual)

Previous: , Up: C Interface   [Contents][Index]

16.1 Available Symbols

When GCL is built, those symbols in the system libraries which are referenced by functions linked in in the list of objects given in unixport/makefile, become available for reference by GCL code.

On some systems it is possible with faslink to load .o files which reference other libraries, but in general this practice is not portable.

gcl-2.6.14/info/gcl-si/Special-Forms-and-Functions.html0000644000175000017500000010471614360276512021155 0ustar cammcamm Special Forms and Functions (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

6 Special Forms and Functions

Constant: LAMBDA-LIST-KEYWORDS

Package:LISP List of all the lambda-list keywords used in GCL.

Special Form: THE

Package:LISP

Syntax: 

(the value-type form)

Declares that the value of FORM must be of VALUE-TYPE. Signals an error if this is not the case.

Special Form: SETF

Package:LISP

Syntax: 

(setf {place newvalue}*)

Replaces the value in PLACE with the value of NEWVALUE, from left to right. Returns the value of the last NEWVALUE. Each PLACE may be any one of the following:

  • A symbol that names a variable.
  • A function call form whose first element is the name of the following functions: 
    nth	elt	subseq	rest	first ... tenth
c?r	c??r	c???r	c????r
aref	svref	char	schar	bit	sbit	fill-poiter
get	getf	documentation	symbol-value	symbol-function
symbol-plist	macro-function	gethash
char-bit	ldb	mask-field
apply

    where ’?’ stands for either ’a’ or ’d’.

  • the form (THE type place) with PLACE being a place recognized by SETF.
  • a macro call which expands to a place recognized by SETF.
  • any form for which a DEFSETF or DEFINE-SETF-METHOD declaration has been made.
Special Form: WHEN

Package:LISP

Syntax: 

(when test {form}*)

If TEST evaluates to non-NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL.

Macro: CCASE

Package:LISP

Syntax: 

(ccase keyplace {({key | ({key}*)} {form}*)}*)

Evaluates KEYPLACE and tries to find the KEY that is EQL to the value of KEYPLACE. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error.

Function: MACROEXPAND (form &optional (env nil))

Package:LISP

If FORM is a macro form, then expands it repeatedly until it is not a macro any more. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro.

Special Form: MULTIPLE-VALUE-CALL

Package:LISP

Syntax: 

(multiple-value-call function {form}*)

Calls FUNCTION with all the values of FORMs as arguments.

Macro: DEFSETF

Package:LISP

Syntax: 

(defsetf access-fun {update-fun [doc] |
                             lambda-list (store-var) {decl | doc}*
{form}*)

Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation ’NAME ’setf). 

(defsetf access-fun update-fun) defines an expansion from
(setf (ACCESS-FUN arg1 ... argn) value) to (UPDATE-FUN arg1 ... argn value).

(defsetf access-fun lambda-list (store-var) . body) defines a macro which

expands 

(setf (ACCESS-FUN arg1 ... argn) value) into the form
	(let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)

where REST is the value of BODY with parameters in LAMBDA-LIST bound to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.

Special Form: TAGBODY

Package:LISP

Syntax: 

(tagbody {tag | statement}*)

Executes STATEMENTs and returns NIL if it falls off the end.

Macro: ETYPECASE

Package:LISP

Syntax: 

(etypecase keyform {(type {form}*)}*)

Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error.

Special Form: LET*

Package:LISP

Syntax: 

(let* ({var | (var [value])}*) {decl}* {form}*)

Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) from left to right, then evaluates FORMs as a PROGN.

Special Form: PROG1

Package:LISP

Syntax: 

(prog1 first {form}*)

Evaluates FIRST and FORMs in order, and returns the (single) value of FIRST.

Special Form: DEFUN

Package:LISP

Syntax: 

(defun name lambda-list {decl | doc}* {form}*)

Defines a function as the global function definition of the symbol NAME. The complete syntax of a lambda-list is: ({var}* [&optional {var | (var [initform [svar]])}*] [&rest var] [&key {var | ({var | (keyword var)} [initform [svar]])}* [&allow-other-keys]] [&aux {var | (var [initform])}*]) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation ’NAME ’function).

Special Form: MULTIPLE-VALUE-BIND

Package:LISP

Syntax: 

(multiple-value-bind ({var}*) values-form {decl}* {form}*)

Binds the VARiables to the results of VALUES-FORM, in order (defaulting to NIL) and evaluates FORMs in order.

Special Form: DECLARE

Package:LISP

Syntax: 

(declare {decl-spec}*)

Gives a declaration. Possible DECL-SPECs are: (SPECIAL {var}*) (TYPE type {var}*) where ’TYPE’ is one of the following symbols 

array		fixnum		package		simple-bit-vector
atom		float		pathname	simple-string
bignum		function	random-state	simple-vector
bit		hash-table	ratio		single-float
bit-vector	integer		rational	standard-char
character	keyword		readtable	stream
common		list		sequence	string
compiled-function  long-float	short-float	string-char
complex		nil		signed-byte	symbol
cons		null		unsigned-byte	t
double-float	number		simple-array	vector

’TYPE’ may also be a list containing one of the above symbols as its first element and more specific information later in the list. For example 

(vector long-float 80) ; vector of 80 long-floats.
(array long-float *)   ; array of long-floats
(array fixnum)         ; array of fixnums
(array * 30)           ; an array of length 30 but unspecified type

A list of 1 element may be replaced by the symbol alone, and a list ending in ’*’ may drop the the final ’*’. 

(OBJECT {var}*)
(FTYPE type {function-name}*)
    eg: ;; function of two required args and optional args and one value:
     (ftype (function (t t *) t) sort reduce)
        ;; function with 1 arg of general type returning 1 fixnum as value.
     (ftype (function (t) fixnum) length)
(FUNCTION function-name ({arg-type}*) {return-type}*)
(INLINE {function-name}*)
(NOTINLINE {function-name}*)
(IGNORE {var}*)
(OPTIMIZE {({SPEED | SPACE | SAFETY | COMPILATION-SPEED} {0 | 1 | 2 | 3})}*)
(DECLARATION {non-standard-decl-name}*)
(:DYNAMIC-EXTENT {var}*) ;GCL-specific.
Special Form: DEFMACRO

Package:LISP

Syntax: 

(defmacro name defmacro-lambda-list {decl | doc}* {form}*)

Defines a macro as the global macro definition of the symbol NAME. The complete syntax of a defmacro-lambda-list is:

( [&whole var] [&environment var] {pseudo-var}* [&optional {var | (pseudo-var [initform [pseudo-var]])}*] {[{&rest | &body} pseudo-var] [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* [&allow-other-keys]] [&aux {var | (pseudo-var [initform])}*] | . var})

where pseudo-var is either a symbol or a list of the following form:

( {pseudo-var}* [&optional {var | (pseudo-var [initform [pseudo-var]])}*] {[{&rest | &body} pseudo-var] [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* [ &allow-other-keys ] ] [&aux {var | (pseudo-var [initform])}*] | . var})

As a special case, a non-NIL symbol is accepcted as a defmacro-lambda-list: (DEFMACRO <name> <symbol> ...) is equivalent to (DEFMACRO <name> (&REST <symbol>) ...). The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation ’NAME ’function). See the type doc of LIST for the backquote macro useful for defining macros. Also, see the function doc of PPRINT for the output-formatting.

Variable: *EVALHOOK*

Package:LISP If *EVALHOOK* is not NIL, its value must be a function that can receive two arguments: a form to evaluate and an environment. This function does the evaluation instead of EVAL.

Function: FUNCTIONP (x)

Package:LISP

Returns T if X is a function, suitable for use by FUNCALL or APPLY. Returns NIL otherwise.

Constant: LAMBDA-PARAMETERS-LIMIT

Package:LISP The exclusive upper bound on the number of distinct parameter names that may appear in a single lambda-list. Actually, however, there is no such upper bound in GCL.

Special Form: FLET

Package:LISP

Syntax: 

(flet ({(name lambda-list {decl | doc}* {form}*)}*) . body)

Evaluates BODY as a PROGN, with local function definitions in effect. BODY is the scope of each local function definition. Since the scope does not include the function definitions themselves, the local function can reference externally defined functions of the same name. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored.

Macro: ECASE

Package:LISP

Syntax: 

(ecase keyform {({key | ({key}*)} {form}*)}*)

Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error.

Special Form: PROG2

Package:LISP

Syntax: 

(prog2 first second {forms}*)

Evaluates FIRST, SECOND, and FORMs in order, and returns the (single) value of SECOND.

Special Form: PROGV

Package:LISP

Syntax: 

(progv symbols values {form}*)

SYMBOLS must evaluate to a list of variables. VALUES must evaluate to a list of initial values. Evaluates FORMs as a PROGN, with each variable bound (as special) to the corresponding value.

Special Form: QUOTE

Package:LISP

Syntax: 

(quote x)

or ’x Simply returns X without evaluating it.

Special Form: DOTIMES

Package:LISP

Syntax: 

(dotimes (var countform [result]) {decl}* {tag | statement}*)

Executes STATEMENTs, with VAR bound to each number between 0 (inclusive) and the value of COUNTFORM (exclusive). Then returns the value(s) of RESULT (which defaults to NIL).

Function: SPECIAL-FORM-P (symbol)

Package:LISP

Returns T if SYMBOL globally names a special form; NIL otherwise. The special forms defined in Steele’s manual are: 

block		if			progv
catch		labels			quote
compiler-let	let			return-from
declare		let*			setq
eval-when	macrolet		tagbody
flet		multiple-value-call	the
function	multiple-value-prog1	throw
go		progn			unwind-protect

In addition, GCL implements the following macros as special forms, though of course macro-expanding functions such as MACROEXPAND work correctly for these macros. 

and		incf			prog1
case		locally			prog2
cond		loop			psetq
decf		multiple-value-bind	push
defmacro	multiple-value-list	return
defun		multiple-value-set	setf
do		or			unless
do*		pop			when
dolist		prog
dotimes		prog*
Special Form: FUNCTION

Package:LISP

Syntax: 

(function x)

or #’x If X is a lambda expression, creates and returns a lexical closure of X in the current lexical environment. If X is a symbol that names a function, returns that function.

Constant: MULTIPLE-VALUES-LIMIT

Package:LISP The exclusive upper bound on the number of values that may be returned from a function. Actually, however, there is no such upper bound in GCL.

Function: APPLYHOOK (function args evalhookfn applyhookfn &optional (env nil))

Package:LISP

Applies FUNCTION to ARGS, with *EVALHOOK* bound to EVALHOOKFN and with *APPLYHOOK* bound to APPLYHOOKFN. Ignores the hook function once, for the top-level application of FUNCTION to ARGS.

Variable: *MACROEXPAND-HOOK*

Package:LISP Holds a function that can take two arguments (a macro expansion function and the macro form to be expanded) and returns the expanded form. This function is whenever a macro-expansion takes place. Initially this is set to #’FUNCALL.

Special Form: PROG*

Package:LISP

Syntax: 

(prog* ({var | (var [init])}*) {decl}* {tag | statement}*)

Creates a NIL block, binds VARs sequentially, and then executes STATEMENTs.

Special Form: BLOCK

Package:LISP

Syntax: 

(block name {form}*)

The FORMs are evaluated in order, but it is possible to exit the block using (RETURN-FROM name value). The RETURN-FROM must be lexically contained within the block.

Special Form: PROGN

Package:LISP

Syntax: 

(progn {form}*)

Evaluates FORMs in order, and returns whatever the last FORM returns.

Function: APPLY (function arg &rest more-args)

Package:LISP

Applies FUNCTION. The arguments to the function consist of all ARGs except for the last, and all elements of the last ARG.

Special Form: LABELS

Package:LISP

Syntax: 

(labels ({(name lambda-list {decl | doc}* {form}*)}*) . body)

Evaluates BODY as a PROGN, with the local function definitions in effect. The scope of the locally defined functions include the function definitions themselves, so their definitions may include recursive references. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored.

Special Form: RETURN

Package:LISP

Syntax: 

(return [result])

Returns from the lexically surrounding NIL block. The value of RESULT, which defaults to NIL, is returned as the value of the block.

Macro: TYPECASE

Package:LISP

Syntax: 

(typecase keyform {(type {form}*)}*)

Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value of the last FORM. If not, simply returns NIL.

Special Form: AND

Package:LISP

Syntax: 

(and {form}*)

Evaluates FORMs in order from left to right. If any FORM evaluates to NIL, returns immediately with the value NIL. Else, returns the value(s) of the last FORM.

Special Form: LET

Package:LISP

Syntax: 

(let ({var | (var [value])}*) {decl}* {form}*)

Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) all at once, then evaluates FORMs as a PROGN.

Special Form: COND

Package:LISP

Syntax: 

(cond {(test {form}*)}*)

Evaluates each TEST in order until one evaluates to a non-NIL value. Then evaluates the associated FORMs in order and returns the value(s) of the last FORM. If no forms follow the TEST, then returns the value of the TEST. Returns NIL, if all TESTs evaluate to NIL.

Function: GET-SETF-METHOD-MULTIPLE-VALUE (form)

Package:LISP Returns the five values (or five ’gangs’) constituting the SETF method for FORM. See the doc of DEFINE-SETF-METHOD for the meanings of the gangs. The third value (i.e., the list of store variables) may consist of any number of elements. See the doc of GET-SETF-METHOD for comparison.

Special Form: CATCH

Package:LISP

Syntax: 

(catch tag {form}*)

Sets up a catcher with that value TAG. Then evaluates FORMs as a PROGN, but may possibly abort the evaluation by a THROW form that specifies the value EQ to the catcher tag.

Macro: DEFINE-MODIFY-MACRO

Package:LISP

Syntax: 

(define-modify-macro name lambda-list fun [doc])

Defines a read-modify-write macro, like PUSH and INCF. The defined macro will expand a form (NAME place val1 ... valn) into a form that in effect SETFs the value of the call (FUN PLACE arg1 ... argm) into PLACE, where arg1 ... argm are parameters in LAMBDA-LIST which are bound to the forms VAL1 ... VALn. The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation ’NAME ’function).

Function: MACROEXPAND-1 (form &optional (env nil))

Package:LISP

If FORM is a macro form, then expands it once. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro.

Function: FUNCALL (function &rest arguments)

Package:LISP

Applies FUNCTION to the ARGUMENTs

Constant: CALL-ARGUMENTS-LIMIT

Package:LISP The upper exclusive bound on the number of arguments that may be passed to a function. Actually, however, there is no such upper bound in GCL.

Special Form: CASE

Package:LISP

Syntax: 

(case keyform {({key | ({key}*)} {form}*)}*)

Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, simply returns NIL.

Macro: DEFINE-SETF-METHOD

Package:LISP

Syntax: 

(define-setf-method access-fun defmacro-lambda-list {decl | doc}*
          {form}*)

Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). When a form (setf (ACCESS-FUN arg1 ... argn) value) is being evaluated, the FORMs are first evaluated as a PROGN with the parameters in DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. Assuming that the last FORM returns five values (temp-var-1 ... temp-var-k) (value-from-1 ... value-form-k) (store-var) storing-form access-form in order, the whole SETF is then expanded into (let* ((temp-var-1 value-from-1) ... (temp-k value-form-k) (store-var VALUE)) storing-from) Incidentally, the five values are called the five gangs of a SETF method. The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation ’NAME ’setf).

Special Form: COMPILER-LET

Package:LISP

Syntax: 

(compiler-let ({var | (var [value])}*) {form}*)

When interpreted, this form works just like a LET form with all VARs declared special. When compiled, FORMs are processed with the VARs bound at compile time, but no bindings occur when the compiled code is executed.

Function: VALUES (&rest args)

Package:LISP

Returns ARGs in order, as values.

Special Form: MULTIPLE-VALUE-LIST

Package:LISP

Syntax: 

(multiple-value-list form)

Evaluates FORM, and returns a list of multiple values it returned.

Special Form: MULTIPLE-VALUE-PROG1

Package:LISP

Syntax: 

(multiple-value-prog1 form {form}*)

Evaluates the first FORM, saves all the values produced, then evaluates the other FORMs. Returns the saved values.

Special Form: MACROLET

Package:LISP

Syntax: 

(macrolet ({(name defmacro-lambda-list {decl | doc}* . body)}*)
          {form}*)

Evaluates FORMs as a PROGN, with the local macro definitions in effect. See the doc of DEFMACRO for the complete syntax of a defmacro-lambda-list. Doc-strings for local macros are simply ignored.

Special Form: GO

Package:LISP

Syntax: 

(go tag)

Jumps to the specified TAG established by a lexically surrounding TAGBODY.

Special Form: PROG

Package:LISP

Syntax: 

(prog ({var | (var [init])}*) {decl}* {tag | statement}*)

Creates a NIL block, binds VARs in parallel, and then executes STATEMENTs.

Variable: *APPLYHOOK*

Package:LISP Used to substitute another function for the implicit APPLY normally done within EVAL. If *APPLYHOOK* is not NIL, its value must be a function which takes three arguments: a function to be applied, a list of arguments, and an environment. This function does the application instead of APPLY.

Special Form: RETURN-FROM

Package:LISP

Syntax: 

(return-from name [result])

Returns from the lexically surrounding block whose name is NAME. The value of RESULT, which defaults to NIL, is returned as the value of the block.

Special Form: UNLESS

Package:LISP

Syntax: 

(unless test {form}*)

If TEST evaluates to NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL.

Special Form: MULTIPLE-VALUE-SETQ

Package:LISP

Syntax: 

(multiple-value-setq variables form)

Sets each variable in the list VARIABLES to the corresponding value of FORM. Returns the value assigned to the first variable.

Special Form: LOCALLY

Package:LISP

Syntax: 

(locally {decl}* {form}*)

Gives local pervasive declarations.

Function: IDENTITY (x)

Package:LISP

Simply returns X.

Function: NOT (x)

Package:LISP

Returns T if X is NIL; NIL otherwise.

Macro: DEFCONSTANT

Package:LISP

Syntax: 

(defconstant name initial-value [doc])

Declares that the variable NAME is a constant whose value is the value of INITIAL-VALUE. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation ’NAME ’variable).

Function: VALUES-LIST (list)

Package:LISP

Returns all of the elements of LIST in order, as values.

Function: ERROR (control-string &rest args)

Package:LISP

Signals a fatal error.

Special Form: IF

Package:LISP

Syntax: 

(if test then [else])

If TEST evaluates to non-NIL, then evaluates THEN and returns the result. If not, evaluates ELSE (which defaults to NIL) and returns the result.

Special Form: UNWIND-PROTECT

Package:LISP

Syntax: 

(unwind-protect protected-form {cleanup-form}*)

Evaluates PROTECTED-FORM and returns whatever it returned. Guarantees that CLEANUP-FORMs be always evaluated before exiting from the UNWIND-PROTECT form.

Function: EVALHOOK (form evalhookfn applyhookfn &optional (env nil))

Package:LISP

Evaluates FORM with *EVALHOOK* bound to EVALHOOKFN and *APPLYHOOK* bound to APPLYHOOKFN. Ignores these hooks once, for the top-level evaluation of FORM.

Special Form: OR

Package:LISP

Syntax: 

(or {form}*)

Evaluates FORMs in order from left to right. If any FORM evaluates to non-NIL, quits and returns that (single) value. If the last FORM is reached, returns whatever values it returns.

Macro: CTYPECASE

Package:LISP

Syntax: 

(ctypecase keyplace {(type {form}*)}*)

Evaluates KEYPLACE and tries to find the TYPE in which the value of KEYPLACE belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error.

Function: EVAL (exp)

Package:LISP

Evaluates EXP and returns the result(s).

Macro: PSETF

Package:LISP

Syntax: 

(psetf {place newvalue}*)

Similar to SETF, but evaluates all NEWVALUEs first, and then replaces the value in each PLACE with the value of the corresponding NEWVALUE. Returns NIL always.

Special Form: THROW

Package:LISP

Syntax: 

(throw tag result)

Evaluates TAG and aborts the execution of the most recent CATCH form that sets up a catcher with the same tag value. The CATCH form returns whatever RESULT returned.

Macro: DEFPARAMETER

Package:LISP

Syntax: 

(defparameter name initial-value [doc])

Declares the variable NAME as a special variable and initializes the value. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation ’NAME ’variable).

Macro: DEFVAR

Package:LISP

Syntax: 

(defvar name [initial-value [doc]])

Declares the variable NAME as a special variable and, optionally, initializes it. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation ’NAME ’variable).

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Iteration-and-Tests.html0000644000175000017500000001563414360276512017601 0ustar cammcamm Iteration and Tests (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

11 Iteration and Tests

Macro: DO-EXTERNAL-SYMBOLS

Package:LISP

Syntax: 

(do-external-symbols (var [package [result-form]])
          {decl}* {tag | statement}*)

Executes STATEMENTs once for each external symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s).

Special Form: DO*

Package:LISP

Syntax: 

(do* ({(var [init [step]])}*) (endtest {result}*)
          {decl}* {tag | statement}*)

Just like DO, but performs variable bindings and assignments in serial, just like LET* and SETQ do.

Macro: DO-ALL-SYMBOLS

Package:LISP

Syntax: 

(do-all-symbols (var [result-form]) {decl}* {tag | statement}*)

Executes STATEMENTs once for each symbol in each package, with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s).

Function: YES-OR-NO-P (&optional (format-string nil) &rest args)

Package:LISP

Asks the user a question whose answer is either ’YES’ or ’NO’. If FORMAT- STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Yes or No)" is printed. Otherwise, no prompt will appear.

Function: MAPHASH #'hash-table

Package:LISP

For each entry in HASH-TABLE, calls FUNCTION on the key and value of the entry; returns NIL.

Function: MAPCAR (fun list &rest more-lists)

Package:LISP

Applies FUN to successive cars of LISTs and returns the results as a list.

Special Form: DOLIST

Package:LISP

Syntax: 

(dolist (var listform [result]) {decl}* {tag | statement}*)

Executes STATEMENTs, with VAR bound to each member of the list value of LISTFORM. Then returns the value(s) of RESULT (which defaults to NIL).

Function: EQ (x y)

Package:LISP

Returns T if X and Y are the same identical object; NIL otherwise.

Function: EQUALP (x y)

Package:LISP

Returns T if X and Y are EQUAL, if they are characters and satisfy CHAR-EQUAL, if they are numbers and have the same numerical value, or if they have components that are all EQUALP. Returns NIL otherwise.

Function: EQUAL (x y)

Package:LISP

Returns T if X and Y are EQL or if they are of the same type and corresponding components are EQUAL. Returns NIL otherwise. Strings and bit-vectors are EQUAL if they are the same length and have identical components. Other arrays must be EQ to be EQUAL.

Macro: DO-SYMBOLS

Package:LISP

Syntax: 

(do-symbols (var [package [result-form]]) {decl}* {tag |
statement}*)

Executes STATEMENTs once for each symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s).

Special Form: LOOP

Package:LISP

Syntax: 

(loop {form}*)

Executes FORMs repeatedly until exited by a THROW or RETURN. The FORMs are surrounded by an implicit NIL block.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/C-Interface.html0000644000175000017500000000456414360276512016063 0ustar cammcamm C Interface (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

16 C Interface

• Available Symbols  
gcl-2.6.14/info/gcl-si/System-Definitions.html0000644000175000017500000011630414360276512017534 0ustar cammcamm System Definitions (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

17 System Definitions

Function: ALLOCATE-CONTIGUOUS-PAGES (number &optional (really-allocate nil))

Package:SI

GCL specific: Sets the maximum number of pages for contiguous blocks to NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified number of pages will be allocated immediately.

Function: FREEZE-DEFSTRUCT (name)

Package:SI

The inline defstruct type checker will be made more efficient, in that it will only check for types which currently include NAME. After calling this the defstruct should not be altered.

Function: MAXIMUM-ALLOCATABLE-PAGES (type)

Package:SI

GCL specific: Returns the current maximum number of pages for the type class of the GCL implementation type TYPE.

Function: ALLOCATED-RELOCATABLE-PAGES ()

Package:SI

GCL specific: Returns the number of pages currently allocated for relocatable blocks.

Function: PUTPROP (symbol value indicator)

Package:SI

Give SYMBOL the VALUE on INDICATOR property.

Function: ALLOCATED-PAGES (type)

Package:SI

GCL specific: Returns the number of pages currently allocated for the type class of the GCL implementation type TYPE.

Function: ALLOCATE-RELOCATABLE-PAGES (number)

Package:SI

GCL specific: Sets the maximum number of pages for relocatable blocks to NUMBER.

Function: ALLOCATED-CONTIGUOUS-PAGES ()

Package:SI

GCL specific: Returns the number of pages currently allocated for contiguous blocks.

Function: MAXIMUM-CONTIGUOUS-PAGES ()

Package:SI

GCL specific: Returns the current maximum number of pages for contiguous blocks.

Function: GET-HOLE-SIZE ()

Package:SI

GCL specific: Returns as a fixnum the size of the memory hole (in pages).

Function: SPECIALP (symbol)

Package:SI

GCL specific: Returns T if the SYMBOL is a globally special variable; NIL otherwise.

Function: OUTPUT-STREAM-STRING (string-output-stream)

Package:SI

GCL specific: Returns the string corresponding to the STRING-OUTPUT-STREAM.

Function: GET-STRING-INPUT-STREAM-INDEX (string-input-stream)

Package:SI

GCL specific: Returns the current index of the STRING-INPUT-STREAM.

Function: STRING-CONCATENATE (&rest strings)

Package:SI

GCL specific: Returns the result of concatenating the given STRINGS.

Function: BDS-VAR (i)

Package:SI

GCL specific: Returns the symbol of the i-th entity in the bind stack.

Function: ERROR-SET (form)

Package:SI

GCL specific: Evaluates the FORM in the null environment. If the evaluation of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first value and the result of the evaluation as the rest of the values. If, in the course of the evaluation, a non-local jump from the FORM is atempted, SI:ERROR-SET traps the jump and returns the corresponding jump tag as its value.

Function: COMPILED-FUNCTION-NAME (compiled-function-object)

Package:SI

GCL specific: Returns the name of the COMPILED-FUNCTION-OBJECT.

Function: STRUCTUREP (object)

Package:SI

GCL specific: Returns T if the OBJECT is a structure; NIL otherwise.

Function: IHS-VS (i)

Package:SI

GCL specific: Returns the value stack index of the i-th entity in the invocation history stack.

Function: UNIVERSAL-ERROR-HANDLER (error-name correctable function-name continue-format-string error-format-string &rest args)

Package:SI

GCL specific: Starts the error handler of GCL. When an error is detected, GCL calls SI:UNIVERSAL-ERROR-HANDLER with the specified arguments. ERROR-NAME is the name of the error. CORRECTABLE is T for a correctable error and NIL for a fatal error. FUNCTION-NAME is the name of the function that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the format strings of the error message. ARGS are the arguments to the format strings. To change the error handler of GCL, redefine SI:UNIVERSAL-ERROR- HANDLER.

Variable: *INTERRUPT-ENABLE*

Package:SI GCL specific: If the value of SI:*INTERRUPT-ENABLE* is non-NIL, GCL signals an error on the terminal interrupt (this is the default case). If it is NIL, GCL ignores the interrupt and assigns T to SI:*INTERRUPT-ENABLE*.

Function: CHDIR (pathname)

Package:SI

GCL/UNIX specific: Changes the current working directory to the specified pathname.

Function: COPY-STREAM (in-stream out-stream)

Package:SI

GCL specific: Copies IN-STREAM to OUT-STREAM until the end-of-file on IN- STREAM.

Function: INIT-SYSTEM ()

Package:SI

GCL specific: Initializes the library and the compiler of GCL. Since they have already been initialized in the standard image of GCL, calling SI:INIT- SYSTEM will cause an error.

Variable: *INDENT-FORMATTED-OUTPUT*

Package:SI GCL specific: The FORMAT directive ~% indents the next line if the value of this variable is non-NIL. If NIL, ~% simply does Newline.

Function: SET-HOLE-SIZE (fixnum)

Package:SI

GCL specific: Sets the size of the memory hole (in pages).

Function: FRS-BDS (i)

Package:SI

GCL specific: Returns the bind stack index of the i-th entity in the frame stack.

Function: IHS-FUN (i)

Package:SI

GCL specific: Returns the function value of the i-th entity in the invocation history stack.

Function: *MAKE-CONSTANT (symbol value)

Package:SI

GCL specific: Makes the SYMBOL a constant with the specified VALUE.

Function: FIXNUMP (object)

Package:SI

GCL specific: Returns T if the OBJECT is a fixnum; NIL otherwise.

Function: BDS-VAL (i)

Package:SI

GCL specific: Returns the value of the i-th entity in the bind stack.

Function: STRING-TO-OBJECT (string)

Package:SI

GCL specific: (SI:STRING-TO-OBJECT STRING) is equivalent to (READ-FROM-STRING STRING), but much faster.

Variable: *SYSTEM-DIRECTORY*

Package:SI GCL specific: Holds the name of the system directory of GCL.

Function: FRS-IHS (i)

Package:SI

GCL specific: Returns the invocation history stack index of the i-th entity in the frame stack.

Function: RESET-GBC-COUNT ()

Package:SI

GCL specific: Resets the counter of the garbage collector that records how many times the garbage collector has been called for each implementation type.

Function: CATCH-BAD-SIGNALS ()

Package:SI

GCL/BSD specific: Installs a signal catcher for bad signals: SIGILL, SIGIOT, SIGEMT, SIGBUS, SIGSEGV, SIGSYS. The signal catcher, upon catching the signal, signals an error (and enter the break-level). Since the internal memory of GCL may be broken, the user should check the signal and exit from GCL if necessary. When the signal is caught during garbage collection, GCL terminates immediately.

Function: RESET-STACK-LIMITS ()

Package:SI

GCL specific: Resets the stack limits to the normal state. When a stack has overflowed, GCL extends the limit for the stack in order to execute the error handler. After processing the error, GCL resets the stack limit by calling SI:RESET-STACK-LIMITS.

Variable: *GBC-MESSAGE*

Package:SI GCL specific: If the value of SI:*GBC-MESSAGE* is non-NIL, the garbage collector prints some information on the terminal. Usually SI:*GBC-MESSAGE* should be set NIL.

Variable: *GBC-NOTIFY*

Package:SI GCL specific: If the value is non-NIL, the garbage collector prints a very brief one line message about the area causing the collection, and the time spent in internal time units.

Variable: *AFTER-GBC-HOOK*

Package:SI Defaults to nil, but may be set to a function of one argument TYPE which is a lisp variable indicating the TYPE which caused the current collection.

Funcition: ALLOCATED (type)

Package:SI

Returns 6 values:

nfree

number free

npages

number of pages

maxpage

number of pages to grow to

nppage

number per page

gbccount

number of gc’s due to running out of items of this size

nused

number of items used

Note that all items of the same size are stored on similar pages. Thus for example on a 486 under linux the following basic types are all the same size and so will share the same allocated information: CONS BIGNUM RATIO COMPLEX STRUCTURE.

Function: *MAKE-SPECIAL (symbol)

Package:SI

GCL specific: Makes the SYMBOL globally special.

Function: MAKE-STRING-OUTPUT-STREAM-FROM-STRING (string)

Package:SI

GCL specific: Creates a string-output-stream corresponding to the STRING and returns it. The STRING should have a fill-pointer.

Variable: *IGNORE-EOF-ON-TERMINAL-IO*

Package:SI GCL specific: If the value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is non-NIL, GCL ignores the eof-character (usually ^D) on the terminal and the terminal never becomes end-of-file. The default value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is NIL.

Function: ADDRESS (object)

Package:SI

GCL specific: Returns the address of the OBJECT as a fixnum. The address of an object depends on the version of GCL. E.g. (SI:ADDRESS NIL) returns 1879062044 on GCL/AOSVS dated March 14, 1986.

Variable: *LISP-MAXPAGES*

Package:SI GCL specific: Holds the maximum number of pages (1 page = 2048 bytes) for the GCL process. The result of changing the value of SI:*LISP-MAXPAGES* is unpredictable.

Function: ARGC ()

Package:SI

GCL specific: Returns the number of arguments on the command line that invoked the GCL process.

Function: NANI (fixnum)

Package:SI

GCL specific: Returns the object in the address FIXNUM. This function is the inverse of SI:ADDRESS. Although SI:ADDRESS is a harmless operation, SI:NANI is quite dangerous and should be used with care.

Variable: *NOTIFY-GBC*

Package:SI GCL specific: If the value of this variable is non-NIL, then the garbage collector notifies that it begins to run whenever it is invoked. Otherwise, garbage collection begins silently.

Function: SAVE-SYSTEM (pathname)

Package:SI

GCL specific: Saves the current GCL core imange into a program file specified by PATHNAME. This function differs from SAVE in that the contiguous and relocatable areas are made permanent in the saved image. Usually the standard image of GCL interpreter/compiler is saved by SI:SAVE-SYSTEM. This function causes an exit from lisp. Various changes are made to the memory of the running system, such as closing files and resetting io streams. It would not be possible to continue normally.

Function: UNCATCH-BAD-SIGNALS ()

Package:SI

GCL/BSD specific: Undoes the effect of SI:CATCH-BAD-SIGNALS.

Function: VS (i)

Package:SI

GCL specific: Returns the i-th entity in the value stack.

Function: DISPLACED-ARRAY-P (array)

Package:SI

GCL specific: Returns T if the ARRAY is a displaced array; NIL otherwise.

Function: ARGV (fixnum)

Package:SI

GCL specific: Returns the FIXNUM-th argument on the command line that invoked the GCL process.

Variable: *DEFAULT-TIME-ZONE*

Package:SI GCL specific: Holds the default time zone. The initial value of SI:*DEFAULT- TIME-ZONE* is 6 (the time zone of Austin, Texas).

Function: GETENV (string)

Package:SI

GCL/UNIX specific: Returns the environment with the name STRING as a string; if the environment specified by STRING is not found, returns NIL.

Package:SI

GCL/BSD specific: Loads the FASL file FILE while linking the object files and libraries specified by STRING. For example, (faslink "foo.o" "bar.o boo.o -lpixrect") loads foo.o while linking two object files (bar.o and boo.o) and the library pixrect. Usually, foo.o consists of the C language interface for the functions defined in the object files or the libraries.

A more portable way of making references to C code, is to build it in at the time of the original make. If foo.c references things in -lpixrect, and foo.o is its compilation in the gcl/unixport directory

(cd gcl/unixport ; make "EXTRAS= foo.o -lpixrect ")

should add them. If EXTRAS was already joe.o in the unixport/makefile you should of course add joe.o to the above "EXTRAS= joe.o foo.o.."

Faslink does not work on most UNIX systems which are derived from SYS V or AIX.

Function: TOP-LEVEL ()

Package:SI

GCL specific: Starts the standard top-level listner of GCL. When the GCL process is invoked, it calls SI:TOP-LEVEL by (FUNCALL ’SI:TOP-LEVEL). To change the top-level of GCL, redefine SI:TOP-LEVEL and save the core imange in a file. When the saved imange is invoked, it will start the redefined top-level.

Function: FRS-VS (i)

Package:SI

GCL specific: Returns the value stack index of the i-th entity in the frame stack.

Function: WRITE-DEBUG-SYMBOLS (start file &key (main-file "/usr/local/schelter/xgcl/unixport/raw_gcl") (output-file "debug-symbols.o" ))

Package:SI

Write out a file of debug-symbols using address START as the place where FILE will be loaded into the running executable MAIN-FILE. The last is a keyword argument.

Function: PROF (x y)

Package:SI

These functions in the SI package are GCL specific, and allow monitoring the run time of functions loaded into GCL, as well as the basic functions. Sample Usage: (si::set-up-profile 1000000) (si::prof 0 90) run program (si::prof 0 0) ;; turn off profile (si::display-prof) (si::clear-profile) (si::prof 0 90) ;; start profile again run program .. Profile can be stopped with (si::prof 0 0) and restarted with (si::prof 0 90) The START-ADDRESS will correspond to the beginning of the profile array, and the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the profile array.

Thus if the profile array is 1,000,000 bytes long and the code segment is 5 megabytes long you can profile the whole thing using a scale of 50 Note that long runs may result in overflow, and so an understating of the time in a function.

You must run intensively however since, with a scale of 128 it takes 6,000,000 times through a loop to overflow the sampling in one part of the code.

Function: CATCH-FATAL (i)

Package:SI

Sets the value of the C variable catch_fatal to I which should be an integer. If catch_fatal is 1, then most unrecoverable fatal errors will be caught. Upon catching such an error catch_fatal becomes -1, to avoid recursive errors. The top level loop automatically sets catch_fatal to 1, if the value is less than zero. Catching can be turned off by making catch_fatal = 0.

Variable: *MULTIPLY-STACKS*

Package:SI

If this variable is set to a positive fixnum, then the next time through the TOP-LEVEL loop, the loop will be exited. The size of the stacks will be multiplied by the value of *multiply-stacks*, and the TOP-LEVEL will be called again. Thus to double the size of the stacks:

>(setq si::*multiply-stacks* 2) [exits top level and reinvokes it, with the new stacks in place] >

We must exit TOP-LEVEL, because it and any other lisp functions maintain many pointers into the stacks, which would be incorrect when the stacks have been moved. Interrupting the process of growing the stacks, can leave you in an inconsistent state.

Function: GBC-TIME (&optional x)

Package:SI

Sets the internal C variable gc_time to X if X is supplied and then returns gc_time. If gc_time is greater or equal to 0, then gc_time is incremented by the garbage collector, according to the number of internal time units spent there. The initial value of gc_time is -1.

Function: FWRITE (string start count stream)

Package:SI

Write from STRING starting at char START (or 0 if it is nil) COUNT characters (or to end if COUNT is nil) to STREAM. STREAM must be a stream such as returned by FP-OUTPUT-STREAM. Returns nil if it fails.

Function: FREAD (string start count stream)

Package:SI

Read characters into STRING starting at char START (or 0 if it is nil) COUNT characters (or from start to length of STRING if COUNT is nil). Characters are read from STREAM. STREAM must be a stream such as returned by FP-INPUT-STREAM. Returns nil if it fails. Return number of characters read if it succeeds.

Function: SGC-ON (&optional ON)

Package:SI

If ON is not nil then SGC (stratified garbage collection) is turned on. If ON is supplied and is nil, then SGC is turned off. If ON is not supplied, then it returns T if SGC is on, and NIL if SGC is off.

The purpose of SGC is to prevent paging activity during garbage collection. It is efficient if the actual number of pages being written to form a small percentage of the total image size. The image should be built as compactly as possible. This can be accomplished by using a settings such as (si::allocate-growth ’cons 1 10 50 20) to limit the growth in the cons maxpage to 10 pages per time. Then just before calling si::save-system to save your image you can do something like:

(si::set-hole-size 500)(gbc nil) (si::sgc-on t) (si::save-system ..)

This makes the saved image come up with SGC on. We have set a reasonably large hole size. This is so that allocation of pages either because they fill up, or through specific calls to si::allocate, will not need to move all the relocatable data. Moving relocatable data requires turning SGC off, performing a full gc, and then turning it back on. New relocatable data is collected by SGC, but moving the old requires going through all pages of memory to change pointers into it.

Using si::*notify-gbc* gives information about the number of pages used by SGC.

Note that SGC is only available on operating systems which provide the mprotect system call, to write protect pages. Otherwise we cannot tell which pages have been written too.

Function: ALLOCATE-SGC (type min-pages max-pages percent-free)

Package:SI

If MIN-PAGES is 0, then this type will not be swept by SGC. Otherwise this is the minimum number of pages to make available to SGC. MAX-PAGES is the upper limit of such pages. Only pages with PERCENT-FREE objects on them, will be assigned to SGC. A list of the previous values for min, max and percent are returned.

Function: ALLOCATE-GROWTH (type min max percent percent-free)

Package:SI

The next time after a garbage collection for TYPE, if PERCENT-FREE of the objects of this TYPE are not actually free, and if the maximum number of pages for this type has already been allocated, then the maximum number will be increased by PERCENT of the old maximum, subject to the condition that this increment be at least MIN pages and at most MAX pages. A list of the previous values for min, max, percent, and percent-free for the type TYPE is returned. A value of 0 means use the system default, and if an argument is out of range then the current values are returned with no change made.

Examples: (si::allocate-growth ’cons 1 10 50 10) would insist that after a garbage collection for cons, there be at least 10% cons’s free. If not the number of cons pages would be grown by 50% or 10 pages which ever was smaller. This might be reasonable if you were trying to build an image which was ‘full’, ie had few free objects of this type.

(si::allocate-growth ’fixnum 0 10000 30 40) would grow space till there were normally 40% free fixnums, usually growing by 30% per time.

(si::allocate-growth ’cons 0 0 0 40) would require 40% free conses after garbage collection for conses, and would use system defaults for the the rate to grow towards this goal.

(si::allocate-growth ’cons -1 0 0 0) would return the current values, but not make any changes.

Function: OPEN-FASD (stream direction eof-value table)

Package:SI

Given file STREAM open for input or output in DIRECTION, set it up to start writing or reading in fasd format. When reading from this stream the EOF-VALUE will be returned when the end a fasd end of dump marker is encountered. TABLE should be an eq hashtable on output, a vector on input, or nil. In this last case a default one will be constructed.

We shall refer to the result as a ‘fasd stream’. It is suitable as the arg to CLOSE-FASD, READ-FASD-TOP, and as the second second arg to WRITE-FASD. As a lisp object it is actually a vector, whose body coincides with:

struct fasd { object stream; /* lisp object of type stream */ object table; /* hash table used in dumping or vector on input*/ object eof; /* lisp object to be returned on coming to eof mark */ object direction; /* holds Cnil or Kinput or Koutput */ object package; /* the package symbols are in by default */ object index; /* integer. The current_dump index on write */ object filepos; /* nil or the position of the start */ object table_length; /* On read it is set to the size dump array needed or 0 */ object macro ; }

We did not use a defstruct for this, because we want the compiler to use this and it makes bootstrapping more difficult. It is in "cmpnew/fasdmacros.lsp"

Function: WRITE-FASD-TOP (X FASD-STREAM)

Package:SI

Write X to FASD-STREAM.

Function: READ-FASD-TOP (FASD-STREAM)

Package:SI

Read the next object from FASD-STREAM. Return the eof-value of FASD-STREAM if we encounter an eof marker put out by CLOSE-FASD. Encountering end of actual file stream causes an error.

Function: CLOSE-FASD (FASD-STREAM)

Package:SI

On output write an eof marker to the associated file stream, and then make FASD-STREAM invalid for further output. It also attempts to write information to the stream on the size of the index table needed to read from the stream from the last open. This is useful in growing the array. It does not alter the file stream, other than for writing this information to it. The file stream may be reopened for further use. It is an error to OPEN-FASD the same file or file stream again with out first calling CLOSE-FASD.

Function: FIND-SHARING-TOP (x table)

Package:SI

X is any lisp object and TABLE is an eq hash table. This walks through X making entries to indicate the frequency of symbols,lists, and arrays. Initially items get -1 when they are first met, and this is decremented by 1 each time the object occurs. Call this function on all the objects in a fasd file, which you wish to share structure.

Variable: *LOAD-PATHNAME*

Package:SI Load binds this to the pathname of the file being loaded.

Macro: DEFINE-INLINE-FUNCTION (fname vars &body body)

Package:SI

This is equivalent to defun except that VARS may not contain &optional, &rest, &key or &aux. Also a compiler property is added, which essentially saves the body and turns this into a let of the VARS and then execution of the body. This last is done using si::DEFINE-COMPILER-MACRO Example: (si::define-inline-function myplus (a b c) (+ a b c))

Macro: DEFINE-COMPILER-MACRO (fname vars &body body)

Package:SI

FNAME may be the name of a function, but at compile time the macro expansion given by this is used.

(si::define-compiler-macro mycar (a) ‘(car ,a))

Function: DBL ()

Package:SI

Invoke a top level loop, in which debug commands may be entered. These commands may also be entered at breaks, or in the error handler. See SOURCE-LEVEL-DEBUG

Function: NLOAD (file)

Package:SI

Load a file with the readtable bound to a special readtable, which permits tracking of source line information as the file is loaded. see SOURCE-LEVEL-DEBUG

Function: BREAK-FUNCTION (function &optional line absolute)

Package:SI

Set a breakpoint for a FUNCTION at LINE if the function has source information loaded. If ABSOLUTE is not nil, then the line is understood to be relative to the beginning of the buffer. See also dbl-break-function, the emacs command.

Function: XDR-OPEN (stream)

Package:SI

Returns an object suitable for passing to XDR-READ if the stream is an input stream, and XDR-WRITE if it was an output stream. Note the stream must be a unix stream, on which si::fp-input-stream or si::fp-output-stream would act as the identity.

Function: FP-INPUT-STREAM (stream)

Package:SI

Return a unix stream for input associated to STREAM if possible, otherwise return nil.

Function: FP-OUTPUT-STREAM (stream)

Package:SI

Return a unix stream for output associated to STREAM if possible, otherwise return nil.

Function: XDR-READ (stream element)

Package:SI

Read one item from STREAM of type the type of ELEMENT. The representation of the elements is machine independent. The xdr routines are what is used by the basic unix rpc calls.

Function: XDR-WRITE (stream element)

Package:SI

Write to STREAM the given ELEMENT.

Variable: *TOP-LEVEL-HOOK*

Package:SI If this variable is has a function as its value at start up time, then it is run immediately after the init.lsp file is loaded. This is useful for starting up an alternate top level loop.

Function: RUN-PROCESS (string arglist)

Package:SI

Execute the command STRING in a subshell passing the strings in the list ARGLIST as arguments to the command. Return a two way stream associated to this. Use si::fp-output-stream to get an associated output stream or si::fp-input-stream.

Bugs: It does not properly deallocate everything, so that it will fail if you call it too many times.

Variable: *CASE-FOLD-SEARCH*

Package: SI Non nil means that a string-match should ignore case

Function: STRING-MATCH (pattern string &optional start end)

Package: SI Match regexp PATTERN in STRING starting in string starting at START and ending at END. Return -1 if match not found, otherwise return the start index of the first matchs. The variable *MATCH-DATA* will be set to a fixnum array of sufficient size to hold the matches, to be obtained with match-beginning and match-end. If it already contains such an array, then the contents of it will be over written.

The form of a regexp pattern is discussed in See Regular Expressions.

Function: MATCH-BEGINNING (index)

Returns the beginning of the I’th match from the previous STRING-MATCH, where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* vector is not a fixnum array.

Function: MATCH-END (index)

Returns the end of the I’th match from the previous STRING-MATCH

Function: SOCKET (port &key host server async myaddr myport daemon)

Establishes a socket connection to the specified PORT under a variety of circumstances.

If HOST is specified, then it is a string designating the IP address of the server to which we are the client. ASYNC specifies that the connection should be made asynchronously, and the call return immediately. MYADDR and MYPORT can specify the IP address and port respectively of a client connection, for example when the running machine has several network interfaces.

If SERVER is specified, then it is a function which will handle incoming connections to this PORT. DAEMON specifies that the running process should be forked to handle incoming connections in the background. If DAEMON is set to the keyword PERSISTENT, then the backgrounded process will survive when the parent process exits, and the SOCKET call returns NIL. Any other non-NIL setting of DAEMON causes the socket call to return the process id of the backgrounded process. DAEMON currently only works on BSD and Linux based systems.

If DAEMON is not set or nil, or if the socket is not a SERVER socket, then the SOCKET call returns a two way stream. In this case, the running process is responsible for all I/O operations on the stream. Specifically, if a SERVER socket is created as a non-DAEMON, then the running process must LISTEN for connections, ACCEPT them when present, and call the SERVER function on the stream returned by ACCEPT.

Function: ACCEPT (stream)

Creates a new two-way stream to handle an individual incoming connection to STREAM, which must have been created with the SOCKET function with the SERVER keyword set. ACCEPT should only be invoked when LISTEN on STREAM returns T. If the STREAM was created with the DAEMON keyword set in the call to SOCKET, ACCEPT is unnecessary and will be called automatically as needed.

• Regular Expressions  

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Low-Level-Debug-Functions.html0000644000175000017500000000604114360276512020573 0ustar cammcamm Low Level Debug Functions (GCL SI Manual)

Previous: , Up: Debugging   [Contents][Index]

18.2 Low Level Debug Functions

Use the following functions to directly access GCL stacks. 

(SI:VS i)	Returns the i-th entity in VS.
(SI:IHS-VS i)	Returns the VS index of the i-th entity in IHS.
(SI:IHS-FUN i)	Returns the function of the i-th entity in IHS.
(SI:FRS-VS i)	Returns the VS index of the i-th entity in FRS.
(SI:FRS-BDS i)	Returns the BDS index of the i-th entity in FRS.
(SI:FRS-IHS i)	Returns the IHS index of the i-th entity in FRS.
(SI:BDS-VAR i)	Returns the symbol of the i-th entity in BDS.
(SI:BDS-VAL i)	Returns the value of the i-th entity in BDS.

(SI:SUPER-GO i tag)
	Jumps to the specified tag established by the TAGBODY frame at
	FRS[i].  Both arguments are evaluated.  If FRS[i] happens to be
	a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is
	performed.
gcl-2.6.14/info/gcl-si/Bignums.html0000644000175000017500000001175314360276512015405 0ustar cammcamm Bignums (GCL SI Manual)

Previous: , Up: GCL Specific   [Contents][Index]

15.1 Bignums

A directory mp was added to hold the new multi precision arithmetic code. The layout and a fair amount of code in the mp directory is an enhanced version of gpari version 34. The gpari c code was rewritten to be more efficient, and gcc assembler macros were added to allow inlining of operations not possible to do in C. On a 68K machine, this allows the C version to be as efficient as the very carefully written assembler in the gpari distribution. For the main machines, an assembler file (produced by gcc) based on this new method, is included. This is for sites which do not have gcc, or do not wish to compile the whole system with gcc.

Bignum arithmetic is much faster now. Many changes were made to cmpnew also, to add ’integer’ as a new type. It differs from variables of other types, in that storage is associated to each such variable, and assignments mean copying the storage. This allows a function which does a good deal of bignum arithmetic, to do very little consing in the heap. An example is the computation of PI-INV in scratchpad, which calculates the inverse of pi to a prescribed number of bits accuracy. That function is now about 20 times faster, and no longer causes garbage collection. In versions of GCL where HAVE_ALLOCA is defined, the temporary storage growth is on the C stack, although this often not so critical (for example it makes virtually no difference in the PI-INV example, since in spite of the many operations, only one storage allocation takes place.

Below is the actual code for PI-INV

On a sun3/280 (cli.com)

Here is the comparison of lucid and gcl before and after on that pi-inv. Times are in seconds with multiples of the gcl/akcl time in parentheses.

On a sun3/280 (cli.com) 


pi-inv   akcl-566  franz        lucid         old kcl/akcl
----------------------------------------
10000      3.3     9.2(2.8 X)  15.3 (4.6X)    92.7   (29.5 X)
20000      12.7    31.0(2.4 X) 62.2 (4.9X)    580.0  (45.5 X)


(defun pi-inv (bits &aux (m 0))
  (declare (integer bits m))
  (let* ((n (+ bits (integer-length bits) 11))
         (tt (truncate (ash 1 n) 882))
         (d (* 4 882 882))
         (s 0))
    (declare (integer s d tt n))
    (do ((i 2 (+ i 2))
         (j 1123 (+ j 21460)))
        ((zerop tt) (cons s (- (+ n 2))))
      (declare (integer i j))
        (setq s (+ s (* j tt))
              m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3)))
              tt (truncate (* m tt) (* d (the integer (expt i 3))))))))

Previous: , Up: GCL Specific   [Contents][Index]

gcl-2.6.14/info/gcl-si/Miscellaneous.html0000644000175000017500000000536214360276512016603 0ustar cammcamm Miscellaneous (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

19 Miscellaneous

• Environment  
• Inititialization  
• Low Level X Interface  
gcl-2.6.14/info/gcl-si/Type.html0000644000175000017500000001343214360276512014716 0ustar cammcamm Type (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

14 Type

Function: COERCE (x type)

Package:LISP

Coerces X to an object of the type TYPE.

Function: TYPE-OF (x)

Package:LISP

Returns the type of X.

Function: CONSTANTP (symbol)

Package:LISP

Returns T if the variable named by SYMBOL is a constant; NIL otherwise.

Function: TYPEP (x type)

Package:LISP

Returns T if X is of the type TYPE; NIL otherwise.

Function: COMMONP (x)

Package:LISP

Returns T if X is a Common Lisp object; NIL otherwise.

Function: SUBTYPEP (type1 type2)

Package:LISP

Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If it could not determine, then returns NIL as the second value. Otherwise, the second value is T.

Macro: CHECK-TYPE

Package:LISP

Syntax: 

(check-type place typespec [string])

Signals an error, if the contents of PLACE are not of the specified type.

Macro: ASSERT

Package:LISP

Syntax: 

(assert test-form [({place}*) [string {arg}*]])

Signals an error if the value of TEST-FORM is NIL. STRING is an format string used as the error message. ARGs are arguments to the format string.

Macro: DEFTYPE

Package:LISP

Syntax: 

(deftype name lambda-list {decl | doc}* {form}*)

Defines a new type-specifier abbreviation in terms of an ’expansion’ function (lambda lambda-list1 {decl}* {form}*) where lambda-list1 is identical to LAMBDA-LIST except that all optional parameters with no default value specified in LAMBDA-LIST defaults to the symbol ’*’, but not to NIL. When the type system of GCL encounters a type specifier (NAME arg1 ... argn), it calls the expansion function with the arguments arg1 ... argn, and uses the returned value instead of the original type specifier. When the symbol NAME is used as a type specifier, the expansion function is called with no argument. The doc-string DOC, if supplied, is saved as the TYPE doc of NAME, and is retrieved by (documentation ’NAME ’type).

Declaration: DYNAMIC-EXTENT

Package:LISP Declaration to allow locals to be cons’d on the C stack. For example (defun foo (&rest l) (declare (:dynamic-extent l)) ...) will cause l to be a list formed on the C stack of the foo function frame. Of course passing L out as a value of foo will cause havoc. (setq x (make-list n)) (setq x (cons a b)) (setq x (list a b c ..)) also are handled on the stack, for dynamic-extent x.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Compilation.html0000644000175000017500000004034214360276512016253 0ustar cammcamm Compilation (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

7 Compilation

Function: COMPILE (name &optional (definition nil))

Package:LISP

If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. In this case, COMPILE compiles the function, installs the compiled function as the global function definition of NAME, and returns NAME. If DEFINITION is non-NIL, it must be a lambda expression and NAME must be a symbol. COMPILE compiles the lambda expression, installs the compiled function as the function definition of NAME, and returns NAME. There is only one exception for this: If NAME is NIL, then the compiled function is not installed but is simply returned as the value of COMPILE. In any case, COMPILE creates temporary files whose filenames are "gazonk***". By default, i.e. if :LEAVE-GAZONK is not supplied or is NIL, these files are automatically deleted after compilation.

Package:LISP

On systems where dlopen is used for relocations, one cannot make custom images containing loaded binary object files simply by loading the files and executing save-system. This function is provided for such cases.

After compiling source files into objects, LINK can be called with a list of binary and source FILES which would otherwise normally be loaded in sequence before saving the image to IMAGE. LINK will use the system C linker to link the binary files thus supplied with GCL’s objects, using EXTRA-LIBS as well if provided, and producing a raw_IMAGE executable. This executable is then run to initialize first GCL’s objects, followed by the supplied files, in order, if RUN-USER-INIT is set. In such a case, source files are loaded at their position in the sequence. Any optional code which should be run after file initialization can be supplied in the POST variable. The image is then saved using save-system to IMAGE.

This method of creating lisp images may also have the advantage that all new object files are kept out of the lisp core and placed instead in the final image’s .text section. This should in principle reduce the core size, speed up garbage collection, and forego any performance penalty induced by data cache flushing on some machines.

In both the RAW and SAVED image, any calls to LOAD binary object files which have been specified in this list will bypass the normal load procedure, and simply initialize the already linked in module. One can rely on this feature by disabling RUN-USER-INIT, and instead passing the normal build commands in POST. In the course of executing this code, binary modules previously linked into the .text section of the executable will be initialized at the same point at which they would have normally been loaded into the lisp core, in the executable’s .data section. In this way, the user can choose to take advantage of the aforementioned possible benefits of this linking method in a relatively transparent way.

All binary objects specified in FILES must have been compiled with :SYSTEM-P set to T.

Special Form: EVAL-WHEN

Package:LISP

Syntax: 

(eval-when ({situation}*) {form}*)

A situation must be either COMPILE, LOAD, or EVAL. The interpreter evaluates only when EVAL is specified. If COMPILE is specified, FORMs are evaluated at compile time. If LOAD is specified, the compiler arranges so that FORMs be evaluated when the compiled code is loaded.

Function: COMPILE-FILE (input-pathname &key output-file (load nil) (message-file nil) ;GCL specific keywords: system-p c-debug c-file h-file data-file)

Package:LISP

Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then ".lsp" is used as the default file type for the source file. :LOAD specifies whether to load the generated fasl file after compilation. :MESSAGE-FILE specifies the log file for the compiler messages. It defaults to the value of the variable COMPILER:*DEFAULT-MESSAGE-FILE*. A non-NIL value of COMPILER::*COMPILE-PRINT* forces the compiler to indicate the form currently being compiled. More keyword parameters are accepted, depending on the version. Most versions of GCL can receive :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters, with which you can control the intermediate files generated by the GCL compiler. Also :C-DEBUG will pass the -g flag to the C compiler.

By top level forms in a file, we mean the value of *top-level-forms* after doing (TF form) for each form read from a file. We define TF as follows:

(defun TF (x) (when (consp x) (setq x (macroexpand x)) (when (consp x) (cond ((member (car x) ’(progn eval-when)) (mapcar ’tf (cdr x))) (t (push x *top-level-forms*))))))

Among the common lisp special forms only DEFUN and DEFMACRO will cause actual native machine code to be generated. The rest will be specially treated in an init section of the .data file. This is done so that things like putprop,setq, and many other forms would use up space which could not be usefully freed, if we were to compile to native machine code. If you have other ‘ordinary’ top level forms which you need to have compiled fully to machine code you may either set compiler::*COMPILE-ORDINARIES* to t, or put them inside a

(PROGN ’COMPILE ...forms-which-need-to-be-compiled)

The compiler will take each of them and make a temporary function which will be compiled and invoked once. It is permissible to wrap a (PROGN ’COMPILE ..) around the whole file. Currently this construction binds the compiler::*COMPILE-ORDINARIES* flag to t. Setting this flag globally to a non nil value to cause all top level forms to generate machine code. This might be useful in a system such as PCL, where a number of top level lambda expressions are given. Note that most common lisps will simply ignore the top level atom ’compile, since it has no side effects.

Defentry, clines, and defcfun also result in machine code being generated.

subsection Evaluation at Compile time

In GCL the eval-when behaviour was changed in order to allow more efficient init code, and also to bring it into line with the resolution passed by the X3j13 committee. Evaluation at compile time is controlled by placing eval-when special forms in the code, or by the value of the variable compiler::*eval-when-defaults* [default value :defaults]. If that variable has value :defaults, then the following hold:

Eval at Compile       Type of Top Level Form

Partial:

defstructs, defvar, defparameter

Full:

defmacro, defconstant, defsetf, define-setf-method, deftype, package ops, proclaim

None:

defun, others

By ‘partial’ we mean (see the X3J13 Common Lisp document (doc/compile-file-handling-of-top-level-forms) for more detail), that functions will not be defined, values will not be set, but other miscellaneous compiler properties will be set: eg properties to inline expand defstruct accessors and testers, defstruct properties allowing subsequent defstructs to include this one, any type hierarch information, special variable information will be set up.

Example: 

(defun foo () 3)
(defstruct jo a b)

As a side effect of compiling these two forms, foo would not have its function cell changed. Neither would jo-a, although it would gain a property which allows it to expand inline to a structure access. Thus if it had a previous definition (as commonly happens from previously loading the file), this previous definition would not be touched, and could well be inconsistent with the compiler properties. Unfortunately this is what the CL standard says to do, and I am just trying to follow it.

If you prefer a more intuitive scheme, of evaling all forms in the file, so that there are no inconsistencies, (previous behaviour of AKCL) you may set compiler::*eval-when-defaults* to ’(compile eval load).

The variable compiler::*FASD-DATA* [default t] controls whether an ascii output is used for the data section of the object file. The data section will be in ascii if *fasd-data* is nil or if the system-p keyword is supplied to compile-file and *fasd-data* is not eq to :system-p.

The old GCL variable *compile-time-too* has disappeared.

See OPTIMIZE on how to enable warnings of slow constructs.

Function: PROCLAIM (decl-spec)

Package:LISP

Puts the declaration given by DECL-SPEC into effect globally. See the doc of DECLARE for possible DECL-SPECs.

Function: PROVIDE (module-name)

Package:LISP

Adds the specified module to the list of modules maintained in *MODULES*.

Function: COMPILED-FUNCTION-P (x)

Package:LISP

Returns T if X is a compiled function; NIL otherwise.

Function: GPROF-START ()

Package:SYSTEM

GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with –enable-gprof. This function starts the profiling timers and counters.

Function: GPROF-QUIT ()

Package:SYSTEM

GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with –enable-gprof. This function reports the profiling results in the form of a call graph to standard output, and clears the profiling arrays. Please note that lisp functions are not (yet) displayed with their lisp names. Please see also the PROFILE function.

Function: GPROF-SET (begin end)

Package:SYSTEM

GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with –enable-gprof. This function sets the address range used by GPROF-START in specifying the section of the running program which is to be profiled. All subsequent calls to GPROF-START will use this new address range. By default, the range is set to begin at the starting address of the .text section, and to end at the current end of the running core. These default values can be restored by calling GPROF-SET with both argments set to 0.

Variable: *DEFAULT-SYSTEM-P*

Pakcage:COMPILER Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL.

Variable: *DEFAULT-C-FILE*

Pakcage:COMPILER Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL.

Variable: *DEFAULT-H-FILE*

Pakcage:COMPILER Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL.

Variable: *DEFAULT-DATA-FILE*

Pakcage:COMPILER Specifies the default setting of :DATA-FILE used by COMPILE. Defaults to NIL.

Variable: *FEATURES*

Package:LISP List of symbols that name features of the current version of GCL. These features are used to decide the read-time conditionalization facility provided by ’#+’ and ’#-’ read macros. When the GCL reader encounters 

	#+ feature-description form

it reads FORM in the usual manner if FEATURE-DESCRIPTION is true. Otherwise, the reader just skips FORM. 

	#- feature-description form

is equivalent to 

	#- (not feature-description) form

A feature-description may be a symbol, which is true only when it is an element of *FEATURES*. Or else, it must be one of the following: 

(and feature-desciption-1 ... feature-desciption-n)
(or  feature-desciption-1 ... feature-desciption-n)
(not feature-desciption)

The AND description is true only when all of its sub-descriptions are true. The OR description is true only when at least one of its sub-descriptions is true. The NOT description is true only when its sub-description is false.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/index.html0000644000175000017500000002016514360276512015105 0ustar cammcamm Top (GCL SI Manual)

Next: , Previous: , Up: (dir)   [Contents][Index]

• Numbers  
• Sequences and Arrays and Hash Tables  
• Characters  
• Lists  
• Streams and Reading  
• Special Forms and Functions  
• Compilation  
• Symbols  
• Operating System  
• Structures  
• Iteration and Tests  
• User Interface  
• Doc  
• Type  
• GCL Specific  
• C Interface  
• System Definitions  
• Debugging  
• Miscellaneous  
• Compiler Definitions  
• Function and Variable Index   

 — The Detailed Node Listing —

Operating System
• Command Line  
• Operating System Definitions   

GCL Specific
• Bignums   

C Interface
• Available Symbols   

System Definitions
• Regular Expressions   

Debugging
• Source Level Debugging in Emacs  
• Low Level Debug Functions   

Miscellaneous
• Environment  
• Inititialization  
• Low Level X Interface  

Next: , Previous: , Up: (dir)   [Contents][Index]

gcl-2.6.14/info/gcl-si/Operating-System.html0000644000175000017500000000505214360276512017206 0ustar cammcamm Operating System (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

9 Operating System

• Command Line  
• Operating System Definitions  
gcl-2.6.14/info/gcl-si/Inititialization.html0000644000175000017500000000514414360276512017322 0ustar cammcamm Inititialization (GCL SI Manual)

Next: , Previous: , Up: Miscellaneous   [Contents][Index]

19.2 Initialization

If the file init.lsp exists in the current directory, it is loaded at startup. The first argument passed to the executable image should be the system directory. Normally this would be gcl/unixport. This directory is stored in the si::*system-directory* variable. If the file sys-init.lsp exists in the system directory, it is loaded before init.lsp. See also si::*TOP-LEVEL-HOOK*.

gcl-2.6.14/info/gcl-si/Characters.html0000644000175000017500000003217214360276512016056 0ustar cammcamm Characters (GCL SI Manual)

Next: , Previous: , Up: Top   [Contents][Index]

3 Characters

Function: NAME-CHAR (name)

Package:LISP

Given an argument acceptable to string, Returns a character object whose name is NAME if one exists. Returns NIL otherwise. NAME must be an object that can be coerced to a string.

Function: CHAR-NAME (char)

Package:LISP

Returns the name for CHAR as a string; NIL if CHAR has no name. Only #\Backspace, #\Tab, #\Newline (or #\Linefeed), #\Page, #\Return, and #\Rubout have names.

Function: BOTH-CASE-P (char)

Package:LISP

Returns T if CHAR is an alphabetic character; NIL otherwise. Equivalent to ALPHA-CHAR-P.

Function: SCHAR (simple-string index)

Package:LISP

Returns the character object representing the INDEX-th character in STRING. This is faster than CHAR.

Constant: CHAR-SUPER-BIT

Package:LISP The bit that indicates a super character.

Constant: CHAR-FONT-LIMIT

Package:LISP The upper exclusive bound on values produced by CHAR-FONT.

Function: CHAR-DOWNCASE (char)

Package:LISP

Returns the lower-case equivalent of CHAR, if any. If not, simply returns CHAR.

Function: STRING-CHAR-P (char)

Package:LISP

Returns T if CHAR can be stored in a string. In GCL, this function always returns T since any character in GCL can be stored in a string.

Function: CHAR-NOT-LESSP (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used.

Function: DISASSEMBLE (thing)

Package:LISP

Compiles the form specified by THING and prints the intermediate C language code for that form. But does NOT install the result of compilation. If THING is a symbol that names a not-yet-compiled function, the function definition is disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form.

Function: LOWER-CASE-P (char)

Package:LISP

Returns T if CHAR is a lower-case character; NIL otherwise.

Function: CHAR<= (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise.

Constant: CHAR-HYPER-BIT

Package:LISP The bit that indicates a hyper character.

Function: CODE-CHAR (code &optional (bits 0) (font 0))

Package:LISP

Returns a character object with the specified code, if any. If not, returns NIL.

Function: CHAR-CODE (char)

Package:LISP

Returns the code attribute of CHAR.

Constant: CHAR-CONTROL-BIT

Package:LISP The bit that indicates a control character.

Function: CHAR-LESSP (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used.

Function: CHAR-FONT (char)

Package:LISP

Returns the font attribute of CHAR.

Function: CHAR< (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise.

Function: CHAR>= (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise.

Constant: CHAR-META-BIT

Package:LISP The bit that indicates a meta character.

Function: GRAPHIC-CHAR-P (char)

Package:LISP

Returns T if CHAR is a printing character, i.e., #\Space through #\~; NIL otherwise.

Function: CHAR-NOT-EQUAL (char &rest more-chars)

Package:LISP

Returns T if no two of CHARs are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same.

Constant: CHAR-BITS-LIMIT

Package:LISP The upper exclusive bound on values produced by CHAR-BITS.

Function: CHARACTERP (x)

Package:LISP

Returns T if X is a character; NIL otherwise.

Function: CHAR= (char &rest more-chars)

Package:LISP

Returns T if all CHARs are the same character; NIL otherwise.

Function: ALPHA-CHAR-P (char)

Package:LISP

Returns T if CHAR is an alphabetic character, A-Z or a-z; NIL otherwise.

Function: UPPER-CASE-P (char)

Package:LISP

Returns T if CHAR is an upper-case character; NIL otherwise.

Function: CHAR-BIT (char name)

Package:LISP

Returns T if the named bit is on in the character CHAR; NIL otherwise. In GCL, this function always returns NIL.

Function: MAKE-CHAR (char &optional (bits 0) (font 0))

Package:LISP

Returns a character object with the same code attribute as CHAR and with the specified BITS and FONT attributes.

Function: CHARACTER (x)

Package:LISP

Coerces X into a character object if possible.

Function: CHAR-EQUAL (char &rest more-chars)

Package:LISP

Returns T if all of its arguments are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same.

Function: CHAR-NOT-GREATERP (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used.

Function: CHAR> (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise.

Function: STANDARD-CHAR-P (char)

Package:LISP

Returns T if CHAR is a standard character, i.e., one of the 95 ASCII printing characters #\Space to #\~ and #Newline; NIL otherwise.

Function: CHAR-UPCASE (char)

Package:LISP

Returns the upper-case equivalent of CHAR, if any. If not, simply returns CHAR.

Function: DIGIT-CHAR-P (char &optional (radix 10))

Package:LISP

If CHAR represents a digit in RADIX, then returns the weight as an integer. Otherwise, returns nil.

Function: CHAR/= (char &rest more-chars)

Package:LISP

Returns T if no two of CHARs are the same character; NIL otherwise.

Function: CHAR-GREATERP (char &rest more-chars)

Package:LISP

Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used.

Function: ALPHANUMERICP (char)

Package:LISP

Returns T if CHAR is either numeric or alphabetic; NIL otherwise.

Function: CHAR-BITS (char)

Package:LISP

Returns the bits attribute (which is always 0 in GCL) of CHAR.

Function: DIGIT-CHAR (digit &optional (radix 10) (font 0))

Package:LISP

Returns a character object that represents the DIGIT in the specified RADIX. Returns NIL if no such character exists.

Function: SET-CHAR-BIT (char name newvalue)

Package:LISP

Returns a character just like CHAR except that the named bit is set or cleared, according to whether NEWVALUE is non-NIL or NIL. This function is useless in GCL.

Next: , Previous: , Up: Top   [Contents][Index]

gcl-2.6.14/info/gcl-si/Source-Level-Debugging-in-Emacs.html0000644000175000017500000001611414360276512021625 0ustar cammcamm Source Level Debugging in Emacs (GCL SI Manual)

Next: , Previous: , Up: Debugging   [Contents][Index]

18.1 Source Level Debugging in Emacs

In emacs load (load "dbl.el") from the gcl/doc directory. [ It also requires gcl.el from that directory. Your system administrator should do make in the doc directory, so that these files are copied to the standard location.]

OVERVIEW:

Lisp files loaded with si::nload will have source line information about them recorded. Break points may be set, and functions stepped. Source code will be automatically displayed in the other window, with a little arrow beside the current line. The backtrace (command :bt) will show line information and you will get automatic display of the source as you move up and down the stack.

FUNCTIONS: break points which have been set. si::nload (file) load a lisp file collecting source line information.

si::break-function (function &optional line absolute) set up a breakpoint for FUNCTION at LINE relative to start or ABSOLUTE

EMACS COMMANDS: M-x dbl makes a dbl buffer, suitable for running an inferior gcl. It has special keybindings for stepping and viewing sources. You may start your favorite gcl program in the dbl shell buffer.

Inferior Dbl Mode: Major mode for interacting with an inferior Dbl process. The following commands are available:

C-c l dbl-find-line

ESC d dbl-:down ESC u dbl-:up ESC c dbl-:r ESC n dbl-:next ESC i dbl-:step ESC s dbl-:step

M-x dbl-display-frame displays in the other window the last line referred to in the dbl buffer.

ESC i and ESC n in the dbl window, call dbl to step and next and then update the other window with the current file and position.

If you are in a source file, you may select a point to break at, by doing C-x SPC.

Commands: Many commands are inherited from shell mode. Additionally we have:

M-x dbl-display-frame display frames file in other window ESC i advance one line in program ESC n advance one line in program (skip over calls). M-x send-dbl-command used for special printing of an arg at the current point. C-x SPACE sets break point at current line.

—————————-

When visiting a lisp buffer (if gcl.el is loaded in your emacs) the command c-m-x evaluates the current defun into the process running in the other window. Line information will be kept. This line information allows you to set break points at a given line (by typing C-x \space on the line in the source file where you want the break to occur. Once stopped within a function you may single step with M-s. This moves one line at a time in the source code, displaying a little arrow beside your current position. M-c is like M-s, except that function invocations are skipped over, rather than entered into. M-c continues execution.

Keywords typed at top level, in the debug loop have a special meaning:

  • :delete [n1] [n2] .. – delete all break points or just n1,n2
  • :disable [n1] [n2] .. – disable all break points or just n1,n2
  • :enable [n1] [n2] .. – enable all break points or just n1,n2
  • :info [:bkpt] –print information about
  • :break [fun] [line] – break at the current location, or if fun is supplied in fun. Break at the beginning unless a line offset from the beginning of fun is supplied.
  • :fr [n] go to frame n When in frame n, if the frame is interpreted, typing the name of locals, will print their values. If it is compiled you must use (si::loc j) to print ‘locj’. Autodisplay of the source will take place if it is interpreted and the line can be determined.
  • :up [n] go up n frames from the current frame.
  • :down [n] go down n frames
  • :bt [n] back trace starting at the current frame and going to top level If n is specified show only n frames.
  • :r If stopped in a function resume. If at top level in the dbl loop, exit and resume an outer loop.
  • :q quit the computation back to top level dbl loop.
  • :step step to the next line with line information
  • :next step to the next line with line information skipping over function invocations.

Files: debug.lsp dbl.el gcl.el

Next: , Previous: , Up: Debugging   [Contents][Index]

gcl-2.6.14/info/gcl-si/Operating-System-Definitions.html0000644000175000017500000003045114360276512021460 0ustar cammcamm Operating System Definitions (GCL SI Manual)

Previous: , Up: Operating System   [Contents][Index]

9.2 Operating System Definitions

Function: GET-DECODED-TIME ()

Package:LISP

Returns the current time in decoded time format. Returns nine values: second, minute, hour, date, month, year, day-of-week, daylight-saving-time-p, and time-zone.

Function: HOST-NAMESTRING (pathname)

Package:LISP

Returns the host part of PATHNAME as a string.

Function: RENAME-FILE (file new-name)

Package:LISP

Renames the file FILE to NEW-NAME. FILE may be a string, a pathname, or a stream.

Function: FILE-AUTHOR (file)

Package:LISP

Returns the author name of the specified file, as a string. FILE may be a string or a stream

Function: PATHNAME-HOST (pathname)

Package:LISP

Returns the host slot of PATHNAME.

Function: FILE-POSITION (file-stream &optional position)

Package:LISP

Sets the file pointer of the specified file to POSITION, if POSITION is given. Otherwise, returns the current file position of the specified file.

Function: DECODE-UNIVERSAL-TIME (universal-time &optional (timezone -9))

Package:LISP

Converts UNIVERSAL-TIME into a decoded time at the TIMEZONE. Returns nine values: second, minute, hour, date, month (1 - 12), year, day-of-week (0 - 6), daylight-saving-time-p, and time-zone. TIMEZONE in GCL defaults to 6, the time zone of Austin, Texas.

Function: USER-HOMEDIR-PATHNAME (&optional host)

Package:LISP

Returns the home directory of the logged in user as a pathname. HOST is ignored.

Variable: *MODULES*

Package:LISP A list of names of the modules that have been loaded into GCL.

Function: SHORT-SITE-NAME ()

Package:LISP

Returns a string that identifies the physical location of the current GCL.

Function: DIRECTORY (name)

Package:LISP

Returns a list of files that match NAME. NAME may be a string, a pathname, or a file stream.

Function: SOFTWARE-VERSION ()

Package:LISP

Returns a string that identifies the software version of the software under which GCL is currently running.

Constant: INTERNAL-TIME-UNITS-PER-SECOND

Package:LISP The number of internal time units that fit into a second.

Function: ENOUGH-NAMESTRING (pathname &optional (defaults *default-pathname-defaults*))

Package:LISP

Returns a string which uniquely identifies PATHNAME with respect to DEFAULTS.

Function: REQUIRE (module-name &optional (pathname))

Package:LISP

If the specified module is not present, then loads the appropriate file(s). PATHNAME may be a single pathname or it may be a list of pathnames.

Function: ENCODE-UNIVERSAL-TIME (second minute hour date month year &optional (timezone ))

Package:LISP

Does the inverse operation of DECODE-UNIVERSAL-TIME.

Function: LISP-IMPLEMENTATION-VERSION ()

Package:LISP

Returns a string that tells you when the current GCL implementation is brought up.

Function: MACHINE-INSTANCE ()

Package:LISP

Returns a string that identifies the machine instance of the machine on which GCL is currently running.

Function: ROOM (&optional (x t))

Package:LISP

Displays information about storage allocation in the following format.

  • for each type class
    • the number of pages so-far allocated for the type class
    • the maximum number of pages for the type class
    • the percentage of used cells to cells so-far allocated
    • the number of times the garbage collector has been called to collect cells of the type class
    • the implementation types that belongs to the type class
  • the number of pages actually allocated for contiguous blocks
  • the maximum number of pages for contiguous blocks
  • the number of times the garbage collector has been called to collect contiguous blocks
  • the number of pages in the hole
  • the maximum number of pages for relocatable blocks
  • the number of times the garbage collector has been called to collect relocatable blocks
  • the total number of pages allocated for cells
  • the total number of pages allocated
  • the number of available pages
  • the number of pages GCL can use.

    The number of times the garbage collector has been called is not shown, if the number is zero. The optional X is ignored.

Function: GET-UNIVERSAL-TIME ()

Package:LISP

Returns the current time as a single integer in universal time format.

Function: GET-INTERNAL-RUN-TIME ()

Package:LISP

Returns the run time in the internal time format. This is useful for finding CPU usage. If the operating system allows, a second value containing CPU usage of child processes is returned.

Variable: *DEFAULT-PATHNAME-DEFAULTS*

Package:LISP The default pathname-defaults pathname.

Function: LONG-SITE-NAME ()

Package:LISP

Returns a string that identifies the physical location of the current GCL.

Function: DELETE-FILE (file)

Package:LISP Deletes FILE.

Function: GET-INTERNAL-REAL-TIME ()

Package:LISP

Returns the real time in the internal time format. This is useful for finding elapsed time.

Function: MACHINE-TYPE ()

Package:LISP

Returns a string that identifies the machine type of the machine on which GCL is currently running.

Macro: TIME

Package:LISP

Syntax: 

(time form)

Evaluates FORM and outputs timing statistics on *TRACE-OUTPUT*.

Function: SOFTWARE-TYPE ()

Package:LISP

Returns a string that identifies the software type of the software under which GCL is currently running.

Function: LISP-IMPLEMENTATION-TYPE ()

Package:LISP

Returns a string that tells you that you are using a version of GCL.

Function: SLEEP (n)

Package:LISP

This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number.

Function: BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero

floating-point-invalid-operation floating-point-overflow floating-point-underflow floating-point-inexact) Package:SI

Break on the specified IEEE floating point error conditions. With no arguments, report the exceptions currently trapped. Disable the break by setting the key to nil, e.g.

> (break-on-floaing-point-exceptions :division-by-zero t) (DIVISION-BY-ZERO)

> (break-on-floaing-point-exceptions) (DIVISION-BY-ZERO)

> (break-on-floaing-point-exceptions :division-by-zero nil) NIL

On some of the most common platforms, the offending instruction will be disassembled, and the register arguments looked up in the saved context and reported in as operands. Within the error handler, addresses may be disassembled, and other registers inspected, using the functions defined in gcl_fpe.lsp.

Previous: , Up: Operating System   [Contents][Index]

gcl-2.6.14/info/gcl.info-50000644000175000017500000110457614360276512013530 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: ignore-errors, Next: define-condition, Prev: handler-case, Up: Conditions Dictionary 9.2.28 ignore-errors [Macro] ---------------------------- 'ignore-errors' {form}* => {result}* Arguments and Values:: ...................... forms--an implicit progn. results--In the normal situation, the values of the forms are returned; in the exceptional situation, two values are returned: nil and the condition. Description:: ............. ignore-errors is used to prevent conditions of type error from causing entry into the debugger. Specifically, ignore-errors executes forms in a dynamic environment where a handler for conditions of type error has been established; if invoked, it handles such conditions by returning two values, nil and the condition that was signaled, from the ignore-errors form. If a normal return from the forms occurs, any values returned are returned by ignore-errors. Examples:: .......... (defun load-init-file (program) (let ((win nil)) (ignore-errors ;if this fails, don't enter debugger (load (merge-pathnames (make-pathname :name program :type :lisp) (user-homedir-pathname))) (setq win t)) (unless win (format t "~&Init file failed to load.~ win)) (load-init-file "no-such-program") |> Init file failed to load. NIL See Also:: .......... *note handler-case:: , *note Condition System Concepts:: Notes:: ....... (ignore-errors . forms) is equivalent to: (handler-case (progn . forms) (error (condition) (values nil condition))) Because the second return value is a condition in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or nil so that the two situations can be distinguished.  File: gcl.info, Node: define-condition, Next: make-condition, Prev: ignore-errors, Up: Conditions Dictionary 9.2.29 define-condition [Macro] ------------------------------- [Editorial Note by KMP: This syntax stuff is still very confused and needs lots of work.] 'define-condition' name ({parent-type}*) ({!slot-spec}*) {option}* => name slot-spec ::=slot-name | (slot-name !slot-option) slot-option ::=[[ {:reader symbol}* | {:writer !function-name}* | {:accessor symbol}* | {:allocation !allocation-type} | {:initarg symbol}* | {:initform form} | {:type type-specifier} ]] option ::=[[ (:default-initargs . initarg-list) | (:documentation string) | (:report report-name) ]] function-name ::={symbol | (setf symbol)} allocation-type ::=:instance | :class report-name ::=string | symbol | lambda expression Arguments and Values:: ...................... name--a symbol. parent-type--a symbol naming a condition type. If no parent-types are supplied, the parent-types default to (condition). default-initargs--a list of keyword/value pairs. [Editorial Note by KMP: This is all mixed up as to which is a slot option and which is a main option. I'll sort that out. Also, some of this is implied by the bnf and needn't be stated explicitly.] Slot-spec - the name of a slot or a list consisting of the slot-name followed by zero or more slot-options. Slot-name - a slot name (a symbol), the list of a slot name, or the list of slot name/slot form pairs. Option - Any of the following: :reader :reader can be supplied more than once for a given slot and cannot be nil. :writer :writer can be supplied more than once for a given slot and must name a generic function. :accessor :accessor can be supplied more than once for a given slot and cannot be nil. :allocation :allocation can be supplied once at most for a given slot. The default if :allocation is not supplied is :instance. :initarg :initarg can be supplied more than once for a given slot. :initform :initform can be supplied once at most for a given slot. :type :type can be supplied once at most for a given slot. :documentation :documentation can be supplied once at most for a given slot. :report :report can be supplied once at most. Description:: ............. define-condition defines a new condition type called name, which is a subtype of the type or types named by parent-type. Each parent-type argument specifies a direct supertype of the new condition. The new condition inherits slots and methods from each of its direct supertypes, and so on. If a slot name/slot form pair is supplied, the slot form is a form that can be evaluated by make-condition to produce a default value when an explicit value is not provided. If no slot form is supplied, the contents of the slot is initialized in an implementation-dependent way. If the type being defined and some other type from which it inherits have a slot by the same name, only one slot is allocated in the condition, but the supplied slot form overrides any slot form that might otherwise have been inherited from a parent-type. If no slot form is supplied, the inherited slot form (if any) is still visible. Accessors are created according to the same rules as used by defclass. A description of slot-options follows: :reader The :reader slot option specifies that an unqualified method is to be defined on the generic function named by the argument to :reader to read the value of the given slot. * The :initform slot option is used to provide a default initial value form to be used in the initialization of the slot. This form is evaluated every time it is used to initialize the slot. The lexical environment in which this form is evaluated is the lexical environment in which the define-condition form was evaluated. Note that the lexical environment refers both to variables and to functions. For local slots, the dynamic environment is the dynamic environment in which make-condition was called; for shared slots, the dynamic environment is the dynamic environment in which the define-condition form was evaluated. [Reviewer Note by Barmar: Issue CLOS-CONDITIONS doesn't say this.] No implementation is permitted to extend the syntax of define-condition to allow (slot-name form) as an abbreviation for (slot-name :initform form). :initarg The :initarg slot option declares an initialization argument named by its symbol argument and specifies that this initialization argument initializes the given slot. If the initialization argument has a value in the call to initialize-instance, the value is stored into the given slot, and the slot's :initform slot option, if any, is not evaluated. If none of the initialization arguments specified for a given slot has a value, the slot is initialized according to the :initform slot option, if specified. :type The :type slot option specifies that the contents of the slot is always of the specified type. It effectively declares the result type of the reader generic function when applied to an object of this condition type. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot is undefined. :default-initargs [Editorial Note by KMP: This is an option, not a slot option.] This option is treated the same as it would be defclass. :documentation [Editorial Note by KMP: This is both an option and a slot option.] The :documentation slot option provides a documentation string for the slot. :report [Editorial Note by KMP: This is an option, not a slot option.] Condition reporting is mediated through the print-object method for the condition type in question, with *print-escape* always being nil. Specifying (:report report-name) in the definition of a condition type C is equivalent to: (defmethod print-object ((x c) stream) (if *print-escape* (call-next-method) (report-name x stream))) If the value supplied by the argument to :report (report-name) is a symbol or a lambda expression, it must be acceptable to function. (function report-name) is evaluated in the current lexical environment. It should return a function of two arguments, a condition and a stream, that prints on the stream a description of the condition. This function is called whenever the condition is printed while *print-escape* is nil. If report-name is a string, it is a shorthand for (lambda (condition stream) (declare (ignore condition)) (write-string report-name stream)) This option is processed after the new condition type has been defined, so use of the slot accessors within the :report function is permitted. If this option is not supplied, information about how to report this type of condition is inherited from the parent-type. The consequences are unspecifed if an attempt is made to read a slot that has not been explicitly initialized and that has not been given a default value. The consequences are unspecified if an attempt is made to assign the slots by using setf. If a define-condition form appears as a top level form, the compiler must make name recognizable as a valid type name, and it must be possible to reference the condition type as the parent-type of another condition type in a subsequent define-condition form in the file being compiled. Examples:: .......... The following form defines a condition of type peg/hole-mismatch which inherits from a condition type called blocks-world-error: (define-condition peg/hole-mismatch (blocks-world-error) ((peg-shape :initarg :peg-shape :reader peg/hole-mismatch-peg-shape) (hole-shape :initarg :hole-shape :reader peg/hole-mismatch-hole-shape)) (:report (lambda (condition stream) (format stream "A ~A peg cannot go in a ~A hole." (peg/hole-mismatch-peg-shape condition) (peg/hole-mismatch-hole-shape condition))))) The new type has slots peg-shape and hole-shape, so make-condition accepts :peg-shape and :hole-shape keywords. The readers peg/hole-mismatch-peg-shape and peg/hole-mismatch-hole-shape apply to objects of this type, as illustrated in the :report information. The following form defines a condition type named machine-error which inherits from error: (define-condition machine-error (error) ((machine-name :initarg :machine-name :reader machine-error-machine-name)) (:report (lambda (condition stream) (format stream "There is a problem with ~A." (machine-error-machine-name condition))))) Building on this definition, a new error condition can be defined which is a subtype of machine-error for use when machines are not available: (define-condition machine-not-available-error (machine-error) () (:report (lambda (condition stream) (format stream "The machine ~A is not available." (machine-error-machine-name condition))))) This defines a still more specific condition, built upon machine-not-available-error, which provides a slot initialization form for machine-name but which does not provide any new slots or report information. It just gives the machine-name slot a default initialization: (define-condition my-favorite-machine-not-available-error (machine-not-available-error) ((machine-name :initform "mc.lcs.mit.edu"))) Note that since no :report clause was given, the information inherited from machine-not-available-error is used to report this type of condition. (define-condition ate-too-much (error) ((person :initarg :person :reader ate-too-much-person) (weight :initarg :weight :reader ate-too-much-weight) (kind-of-food :initarg :kind-of-food :reader :ate-too-much-kind-of-food))) => ATE-TOO-MUCH (define-condition ate-too-much-ice-cream (ate-too-much) ((kind-of-food :initform 'ice-cream) (flavor :initarg :flavor :reader ate-too-much-ice-cream-flavor :initform 'vanilla )) (:report (lambda (condition stream) (format stream "~A ate too much ~A ice-cream" (ate-too-much-person condition) (ate-too-much-ice-cream-flavor condition))))) => ATE-TOO-MUCH-ICE-CREAM (make-condition 'ate-too-much-ice-cream :person 'fred :weight 300 :flavor 'chocolate) => # (format t "~A" *) |> FRED ate too much CHOCOLATE ice-cream => NIL See Also:: .......... *note make-condition:: , *note defclass:: , *note Condition System Concepts::  File: gcl.info, Node: make-condition, Next: restart, Prev: define-condition, Up: Conditions Dictionary 9.2.30 make-condition [Function] -------------------------------- 'make-condition' type &rest slot-initializations => condition Arguments and Values:: ...................... type--a type specifier (for a subtype of condition). slot-initializations--an initialization argument list. condition--a condition. Description:: ............. Constructs and returns a condition of type type using slot-initializations for the initial values of the slots. The newly created condition is returned. Examples:: .......... (defvar *oops-count* 0) (setq a (make-condition 'simple-error :format-control "This is your ~:R error." :format-arguments (list (incf *oops-count*)))) => # (format t "~&~A~ |> This is your first error. => NIL (error a) |> Error: This is your first error. |> To continue, type :CONTINUE followed by an option number: |> 1: Return to Lisp Toplevel. |> Debug> Affected By:: ............. The set of defined condition types. See Also:: .......... *note define-condition:: , *note Condition System Concepts::  File: gcl.info, Node: restart, Next: compute-restarts, Prev: make-condition, Up: Conditions Dictionary 9.2.31 restart [System Class] ----------------------------- Class Precedence List:: ....................... restart, t Description:: ............. An object of type restart represents a function that can be called to perform some form of recovery action, usually a transfer of control to an outer point in the running program. An implementation is free to implement a restart in whatever manner is most convenient; a restart has only dynamic extent relative to the scope of the binding form which establishes it.  File: gcl.info, Node: compute-restarts, Next: find-restart, Prev: restart, Up: Conditions Dictionary 9.2.32 compute-restarts [Function] ---------------------------------- 'compute-restarts' &optional condition => restarts Arguments and Values:: ...................... condition--a condition object, or nil. restarts--a list of restarts. Description:: ............. compute-restarts uses the dynamic state of the program to compute a list of the restarts which are currently active. The resulting list is ordered so that the innermost (more-recently established) restarts are nearer the head of the list. When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered. compute-restarts returns all applicable restarts, including anonymous ones, even if some of them have the same name as others and would therefore not be found by find-restart when given a symbol argument. Implementations are permitted, but not required, to return distinct lists from repeated calls to compute-restarts while in the same dynamic environment. The consequences are undefined if the list returned by compute-restarts is every modified. Examples:: .......... ;; One possible way in which an interactive debugger might present ;; restarts to the user. (defun invoke-a-restart () (let ((restarts (compute-restarts))) (do ((i 0 (+ i 1)) (r restarts (cdr r))) ((null r)) (format t "~&~D: ~A~ (let ((n nil) (k (length restarts))) (loop (when (and (typep n 'integer) (>= n 0) (< n k)) (return t)) (format t "~&Option: ") (setq n (read)) (fresh-line)) (invoke-restart-interactively (nth n restarts))))) (restart-case (invoke-a-restart) (one () 1) (two () 2) (nil () :report "Who knows?" 'anonymous) (one () 'I) (two () 'II)) |> 0: ONE |> 1: TWO |> 2: Who knows? |> 3: ONE |> 4: TWO |> 5: Return to Lisp Toplevel. |> Option: |>>4<<| => II ;; Note that in addition to user-defined restart points, COMPUTE-RESTARTS ;; also returns information about any system-supplied restarts, such as ;; the "Return to Lisp Toplevel" restart offered above. Affected By:: ............. Existing restarts. See Also:: .......... *note find-restart:: , *note invoke-restart:: , *note restart-bind::  File: gcl.info, Node: find-restart, Next: invoke-restart, Prev: compute-restarts, Up: Conditions Dictionary 9.2.33 find-restart [Function] ------------------------------ 'find-restart' identifier &optional condition restart Arguments and Values:: ...................... identifier--a non-nil symbol, or a restart. condition--a condition object, or nil. restart--a restart or nil. Description:: ............. find-restart searches for a particular restart in the current dynamic environment. When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered. If identifier is a symbol, then the innermost (most recently established) applicable restart with that name is returned. nil is returned if no such restart is found. If identifier is a currently active restart, then it is returned. Otherwise, nil is returned. Examples:: .......... (restart-case (let ((r (find-restart 'my-restart))) (format t "~S is named ~S" r (restart-name r))) (my-restart () nil)) |> # is named MY-RESTART => NIL (find-restart 'my-restart) => NIL Affected By:: ............. Existing restarts. restart-case, restart-bind, with-condition-restarts. See Also:: .......... *note compute-restarts:: Notes:: ....... (find-restart identifier) == (find identifier (compute-restarts) :key :restart-name) Although anonymous restarts have a name of nil, the consequences are unspecified if nil is given as an identifier. Occasionally, programmers lament that nil is not permissible as an identifier argument. In most such cases, compute-restarts can probably be used to simulate the desired effect.  File: gcl.info, Node: invoke-restart, Next: invoke-restart-interactively, Prev: find-restart, Up: Conditions Dictionary 9.2.34 invoke-restart [Function] -------------------------------- 'invoke-restart' restart &rest arguments => {result}* Arguments and Values:: ...................... restart--a restart designator. argument--an object. results--the values returned by the function associated with restart, if that function returns. Description:: ............. Calls the function associated with restart, passing arguments to it. Restart must be valid in the current dynamic environment. Examples:: .......... (defun add3 (x) (check-type x number) (+ x 3)) (foo 'seven) |> Error: The value SEVEN was not of type NUMBER. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a different value to use. |> 2: Return to Lisp Toplevel. |> Debug> |>>(invoke-restart 'store-value 7)<<| => 10 Side Effects:: .............. A non-local transfer of control might be done by the restart. Affected By:: ............. Existing restarts. Exceptional Situations:: ........................ If restart is not valid, an error of type control-error is signaled. See Also:: .......... *note find-restart:: , *note restart-bind:: , *note restart-case:: , *note invoke-restart-interactively:: Notes:: ....... The most common use for invoke-restart is in a handler. It might be used explicitly, or implicitly through invoke-restart-interactively or a restart function. Restart functions call invoke-restart, not vice versa. That is, invoke-restart provides primitive functionality, and restart functions are non-essential "syntactic sugar."  File: gcl.info, Node: invoke-restart-interactively, Next: restart-bind, Prev: invoke-restart, Up: Conditions Dictionary 9.2.35 invoke-restart-interactively [Function] ---------------------------------------------- 'invoke-restart-interactively' restart => {result}* Arguments and Values:: ...................... restart--a restart designator. results--the values returned by the function associated with restart, if that function returns. Description:: ............. invoke-restart-interactively calls the function associated with restart, prompting for any necessary arguments. If restart is a name, it must be valid in the current dynamic environment. invoke-restart-interactively prompts for arguments by executing the code provided in the :interactive keyword to restart-case or :interactive-function keyword to restart-bind. If no such options have been supplied in the corresponding restart-bind or restart-case, then the consequences are undefined if the restart takes required arguments. If the arguments are optional, an argument list of nil is used. Once the arguments have been determined, invoke-restart-interactively executes the following: (apply #'invoke-restart restart arguments) Examples:: .......... (defun add3 (x) (check-type x number) (+ x 3)) (add3 'seven) |> Error: The value SEVEN was not of type NUMBER. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a different value to use. |> 2: Return to Lisp Toplevel. |> Debug> |>>(invoke-restart-interactively 'store-value)<<| |> Type a form to evaluate and use: |>>7<<| => 10 Side Effects:: .............. If prompting for arguments is necesary, some typeout may occur (on query I/O). A non-local transfer of control might be done by the restart. Affected By:: ............. *query-io*, active restarts Exceptional Situations:: ........................ If restart is not valid, an error of type control-error is signaled. See Also:: .......... *note find-restart:: , *note invoke-restart:: , *note restart-case:: , *note restart-bind:: Notes:: ....... invoke-restart-interactively is used internally by the debugger and may also be useful in implementing other portable, interactive debugging tools.  File: gcl.info, Node: restart-bind, Next: restart-case, Prev: invoke-restart-interactively, Up: Conditions Dictionary 9.2.36 restart-bind [Macro] --------------------------- 'restart-bind' ({(name function {!key-val-pair}*)}) {form}* => {result}* key-val-pair ::=:interactive-function interactive-function | :report-function report-function | :test-function test-function Arguments and Values:: ...................... name--a symbol; not evaluated. function--a form; evaluated. forms--an implicit progn. interactive-function--a form; evaluated. report-function--a form; evaluated. test-function--a form; evaluated. results--the values returned by the forms. Description:: ............. restart-bind executes the body of forms in a dynamic environment where restarts with the given names are in effect. If a name is nil, it indicates an anonymous restart; if a name is a non-nil symbol, it indicates a named restart. The function, interactive-function, and report-function are unconditionally evaluated in the current lexical and dynamic environment prior to evaluation of the body. Each of these forms must evaluate to a function. If invoke-restart is done on that restart, the function which resulted from evaluating function is called, in the dynamic environment of the invoke-restart, with the arguments given to invoke-restart. The function may either perform a non-local transfer of control or may return normally. If the restart is invoked interactively from the debugger (using invoke-restart-interactively), the arguments are defaulted by calling the function which resulted from evaluating interactive-function. That function may optionally prompt interactively on query I/O, and should return a list of arguments to be used by invoke-restart-interactively when invoking the restart. If a restart is invoked interactively but no interactive-function is used, then an argument list of nil is used. In that case, the function must be compatible with an empty argument list. If the restart is presented interactively (e.g., by the debugger), the presentation is done by calling the function which resulted from evaluating report-function. This function must be a function of one argument, a stream. It is expected to print a description of the action that the restart takes to that stream. This function is called any time the restart is printed while *print-escape* is nil. In the case of interactive invocation, the result is dependent on the value of :interactive-function as follows. :interactive-function Value is evaluated in the current lexical environment and should return a function of no arguments which constructs a list of arguments to be used by invoke-restart-interactively when invoking this restart. The function may prompt interactively using query I/O if necessary. :report-function Value is evaluated in the current lexical environment and should return a function of one argument, a stream, which prints on the stream a summary of the action that this restart takes. This function is called whenever the restart is reported (printed while *print-escape* is nil). If no :report-function option is provided, the manner in which the restart is reported is implementation-dependent. :test-function Value is evaluated in the current lexical environment and should return a function of one argument, a condition, which returns true if the restart is to be considered visible. Affected By:: ............. *query-io*. See Also:: .......... *note restart-case:: , *note with-simple-restart:: Notes:: ....... restart-bind is primarily intended to be used to implement restart-case and might be useful in implementing other macros. Programmers who are uncertain about whether to use restart-case or restart-bind should prefer restart-case for the cases where it is powerful enough, using restart-bind only in cases where its full generality is really needed.  File: gcl.info, Node: restart-case, Next: restart-name, Prev: restart-bind, Up: Conditions Dictionary 9.2.37 restart-case [Macro] --------------------------- 'restart-case' restartable-form {!clause} => {result}* clause ::=( case-name lambda-list [[:interactive interactive-expression | :report report-expression | :test test-expression]] {declaration}* {form}*) Arguments and Values:: ...................... restartable-form--a form. case-name--a symbol or nil. lambda-list--an ordinary lambda list. interactive-expression--a symbol or a lambda expression. report-expression--a string, a symbol, or a lambda expression. test-expression--a symbol or a lambda expression. declaration--a declare expression; not evaluated. form--a form. results--the values resulting from the evaluation of restartable-form, or the values returned by the last form executed in a chosen clause, or nil. Description:: ............. restart-case evaluates restartable-form in a dynamic environment where the clauses have special meanings as points to which control may be transferred. If restartable-form finishes executing and returns any values, all values returned are returned by restart-case and processing has completed. While restartable-form is executing, any code may transfer control to one of the clauses (see invoke-restart). If a transfer occurs, the forms in the body of that clause is evaluated and any values returned by the last such form are returned by restart-case. In this case, the dynamic state is unwound appropriately (so that the restarts established around the restartable-form are no longer active) prior to execution of the clause. If there are no forms in a selected clause, restart-case returns nil. If case-name is a symbol, it names this restart. It is possible to have more than one clause use the same case-name. In this case, the first clause with that name is found by find-restart. The other clauses are accessible using compute-restarts. Each arglist is an ordinary lambda list to be bound during the execution of its corresponding forms. These parameters are used by the restart-case clause to receive any necessary data from a call to invoke-restart. By default, invoke-restart-interactively passes no arguments and all arguments must be optional in order to accomodate interactive restarting. However, the arguments need not be optional if the :interactive keyword has been used to inform invoke-restart-interactively about how to compute a proper argument list. Keyword options have the following meaning. :interactive The value supplied by :interactive value must be a suitable argument to function. (function value) is evaluated in the current lexical environment. It should return a function of no arguments which returns arguments to be used by invoke-restart-interactively when it is invoked. invoke-restart-interactively is called in the dynamic environment available prior to any restart attempt, and uses query I/O for user interaction. If a restart is invoked interactively but no :interactive option was supplied, the argument list used in the invocation is the empty list. :report If the value supplied by :report value is a lambda expression or a symbol, it must be acceptable to function. (function value) is evaluated in the current lexical environment. It should return a function of one argument, a stream, which prints on the stream a description of the restart. This function is called whenever the restart is printed while *print-escape* is nil. If value is a string, it is a shorthand for (lambda (stream) (write-string value stream)) If a named restart is asked to report but no report information has been supplied, the name of the restart is used in generating default report text. When *print-escape* is nil, the printer uses the report information for a restart. For example, a debugger might announce the action of typing a "continue" command by: (format t "~&~S -- ~A~ which might then display as something like: :CONTINUE -- Return to command level The consequences are unspecified if an unnamed restart is specified but no :report option is provided. :test The value supplied by :test value must be a suitable argument to function. (function value) is evaluated in the current lexical environment. It should return a function of one argument, the condition, that returns true if the restart is to be considered visible. The default for this option is equivalent to (lambda (c) (declare (ignore c)) t). If the restartable-form is a list whose car is any of the symbols signal, error, cerror, or warn (or is a macro form which macroexpands into such a list), then with-condition-restarts is used implicitly to associate the indicated restarts with the condition to be signaled. Examples:: .......... (restart-case (handler-bind ((error #'(lambda (c) (declare (ignore condition)) (invoke-restart 'my-restart 7)))) (error "Foo.")) (my-restart (&optional v) v)) => 7 (define-condition food-error (error) ()) => FOOD-ERROR (define-condition bad-tasting-sundae (food-error) ((ice-cream :initarg :ice-cream :reader bad-tasting-sundae-ice-cream) (sauce :initarg :sauce :reader bad-tasting-sundae-sauce) (topping :initarg :topping :reader bad-tasting-sundae-topping)) (:report (lambda (condition stream) (format stream "Bad tasting sundae with ~S, ~S, and ~S" (bad-tasting-sundae-ice-cream condition) (bad-tasting-sundae-sauce condition) (bad-tasting-sundae-topping condition))))) => BAD-TASTING-SUNDAE (defun all-start-with-same-letter (symbol1 symbol2 symbol3) (let ((first-letter (char (symbol-name symbol1) 0))) (and (eql first-letter (char (symbol-name symbol2) 0)) (eql first-letter (char (symbol-name symbol3) 0))))) => ALL-START-WITH-SAME-LETTER (defun read-new-value () (format t "Enter a new value: ") (multiple-value-list (eval (read)))) => READ-NEW-VALUE (defun verify-or-fix-perfect-sundae (ice-cream sauce topping) (do () ((all-start-with-same-letter ice-cream sauce topping)) (restart-case (error 'bad-tasting-sundae :ice-cream ice-cream :sauce sauce :topping topping) (use-new-ice-cream (new-ice-cream) :report "Use a new ice cream." :interactive read-new-value (setq ice-cream new-ice-cream)) (use-new-sauce (new-sauce) :report "Use a new sauce." :interactive read-new-value (setq sauce new-sauce)) (use-new-topping (new-topping) :report "Use a new topping." :interactive read-new-value (setq topping new-topping)))) (values ice-cream sauce topping)) => VERIFY-OR-FIX-PERFECT-SUNDAE (verify-or-fix-perfect-sundae 'vanilla 'caramel 'cherry) |> Error: Bad tasting sundae with VANILLA, CARAMEL, and CHERRY. |> To continue, type :CONTINUE followed by an option number: |> 1: Use a new ice cream. |> 2: Use a new sauce. |> 3: Use a new topping. |> 4: Return to Lisp Toplevel. |> Debug> |>>:continue 1<<| |> Use a new ice cream. |> Enter a new ice cream: |>>'chocolate<<| => CHOCOLATE, CARAMEL, CHERRY See Also:: .......... *note restart-bind:: , *note with-simple-restart:: . Notes:: ....... (restart-case expression (name1 arglist1 ...options1... . body1) (name2 arglist2 ...options2... . body2)) is essentially equivalent to (block #1=#:g0001 (let ((#2=#:g0002 nil)) (tagbody (restart-bind ((name1 #'(lambda (&rest temp) (setq #2# temp) (go #3=#:g0003)) ...slightly-transformed-options1...) (name2 #'(lambda (&rest temp) (setq #2# temp) (go #4=#:g0004)) ...slightly-transformed-options2...)) (return-from #1# expression)) #3# (return-from #1# (apply #'(lambda arglist1 . body1) #2#)) #4# (return-from #1# (apply #'(lambda arglist2 . body2) #2#))))) Unnamed restarts are generally only useful interactively and an interactive option which has no description is of little value. Implementations are encouraged to warn if an unnamed restart is used and no report information is provided at compilation time. At runtime, this error might be noticed when entering the debugger. Since signaling an error would probably cause recursive entry into the debugger (causing yet another recursive error, etc.) it is suggested that the debugger print some indication of such problems when they occur but not actually signal errors. (restart-case (signal fred) (a ...) (b ...)) == (restart-case (with-condition-restarts fred (list (find-restart 'a) (find-restart 'b)) (signal fred)) (a ...) (b ...))  File: gcl.info, Node: restart-name, Next: with-condition-restarts, Prev: restart-case, Up: Conditions Dictionary 9.2.38 restart-name [Function] ------------------------------ 'restart-name' restart => name Arguments and Values:: ...................... restart--a restart. name--a symbol. Description:: ............. Returns the name of the restart, or nil if the restart is not named. Examples:: .......... (restart-case (loop for restart in (compute-restarts) collect (restart-name restart)) (case1 () :report "Return 1." 1) (nil () :report "Return 2." 2) (case3 () :report "Return 3." 3) (case1 () :report "Return 4." 4)) => (CASE1 NIL CASE3 CASE1 ABORT) ;; In the example above the restart named ABORT was not created ;; explicitly, but was implicitly supplied by the system. See Also:: .......... *note compute-restarts:: *note find-restart::  File: gcl.info, Node: with-condition-restarts, Next: with-simple-restart, Prev: restart-name, Up: Conditions Dictionary 9.2.39 with-condition-restarts [Macro] -------------------------------------- 'with-condition-restarts' condition-form restarts-form {form}* => {result}* Arguments and Values:: ...................... condition-form--a form; evaluated to produce a condition. condition--a condition object resulting from the evaluation of condition-form. restart-form--a form; evaluated to produce a restart-list. restart-list--a list of restart objects resulting from the evaluation of restart-form. forms--an implicit progn; evaluated. results--the values returned by forms. Description:: ............. First, the condition-form and restarts-form are evaluated in normal left-to-right order; the primary values yielded by these evaluations are respectively called the condition and the restart-list. Next, the forms are evaluated in a dynamic environment in which each restart in restart-list is associated with the condition. See *note Associating a Restart with a Condition::. See Also:: .......... *note restart-case:: Notes:: ....... Usually this macro is not used explicitly in code, since restart-case handles most of the common cases in a way that is syntactically more concise.  File: gcl.info, Node: with-simple-restart, Next: abort (Restart), Prev: with-condition-restarts, Up: Conditions Dictionary 9.2.40 with-simple-restart [Macro] ---------------------------------- 'with-simple-restart' (name format-control {format-argument}*) {form}* => {result}* Arguments and Values:: ...................... name--a symbol. format-control--a format control. format-argument--an object (i.e., a format argument). forms--an implicit progn. results--in the normal situation, the values returned by the forms; in the exceptional situation where the restart named name is invoked, two values--nil and t. Description:: ............. with-simple-restart establishes a restart. If the restart designated by name is not invoked while executing forms, all values returned by the last of forms are returned. If the restart designated by name is invoked, control is transferred to with-simple-restart, which returns two values, nil and t. If name is nil, an anonymous restart is established. The format-control and format-arguments are used report the restart. Examples:: .......... (defun read-eval-print-loop (level) (with-simple-restart (abort "Exit command level ~D." level) (loop (with-simple-restart (abort "Return to command level ~D." level) (let ((form (prog2 (fresh-line) (read) (fresh-line)))) (prin1 (eval form))))))) => READ-EVAL-PRINT-LOOP (read-eval-print-loop 1) (+ 'a 3) |> Error: The argument, A, to the function + was of the wrong type. |> The function expected a number. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use this time. |> 2: Return to command level 1. |> 3: Exit command level 1. |> 4: Return to Lisp Toplevel. (defun compute-fixnum-power-of-2 (x) (with-simple-restart (nil "Give up on computing 2^~D." x) (let ((result 1)) (dotimes (i x result) (setq result (* 2 result)) (unless (fixnump result) (error "Power of 2 is too large.")))))) COMPUTE-FIXNUM-POWER-OF-2 (defun compute-power-of-2 (x) (or (compute-fixnum-power-of-2 x) 'something big)) COMPUTE-POWER-OF-2 (compute-power-of-2 10) 1024 (compute-power-of-2 10000) |> Error: Power of 2 is too large. |> To continue, type :CONTINUE followed by an option number. |> 1: Give up on computing 2^10000. |> 2: Return to Lisp Toplevel |> Debug> |>>:continue 1<<| => SOMETHING-BIG See Also:: .......... *note restart-case:: Notes:: ....... with-simple-restart is shorthand for one of the most common uses of restart-case. with-simple-restart could be defined by: (defmacro with-simple-restart ((restart-name format-control &rest format-arguments) &body forms) `(restart-case (progn ,@forms) (,restart-name () :report (lambda (stream) (format stream ,format-control ,@format-arguments)) (values nil t)))) Because the second return value is t in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or nil so that the two situations can be distinguished.  File: gcl.info, Node: abort (Restart), Next: continue, Prev: with-simple-restart, Up: Conditions Dictionary 9.2.41 abort [Restart] ---------------------- Data Arguments Required:: ......................... None. Description:: ............. The intent of the abort restart is to allow return to the innermost "command level." Implementors are encouraged to make sure that there is always a restart named abort around any user code so that user code can call abort at any time and expect something reasonable to happen; exactly what the reasonable thing is may vary somewhat. Typically, in an interactive listener, the invocation of abort returns to the Lisp reader phase of the Lisp read-eval-print loop, though in some batch or multi-processing situations there may be situations in which having it kill the running process is more appropriate. See Also:: .......... *note Restarts::, *note Interfaces to Restarts::, *note invoke-restart:: , *note abort (Function):: (function)  File: gcl.info, Node: continue, Next: muffle-warning, Prev: abort (Restart), Up: Conditions Dictionary 9.2.42 continue [Restart] ------------------------- Data Arguments Required:: ......................... None. Description:: ............. The continue restart is generally part of protocols where there is a single "obvious" way to continue, such as in break and cerror. Some user-defined protocols may also wish to incorporate it for similar reasons. In general, however, it is more reliable to design a special purpose restart with a name that more directly suits the particular application. Examples:: .......... (let ((x 3)) (handler-bind ((error #'(lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (cond ((not (floatp x)) (cerror "Try floating it." "~D is not a float." x) (float x)) (t x)))) => 3.0 See Also:: .......... *note Restarts::, *note Interfaces to Restarts::, *note invoke-restart:: , *note continue:: (function), *note assert:: , *note cerror::  File: gcl.info, Node: muffle-warning, Next: store-value, Prev: continue, Up: Conditions Dictionary 9.2.43 muffle-warning [Restart] ------------------------------- Data Arguments Required:: ......................... None. Description:: ............. This restart is established by warn so that handlers of warning conditions have a way to tell warn that a warning has already been dealt with and that no further action is warranted. Examples:: .......... (defvar *all-quiet* nil) => *ALL-QUIET* (defvar *saved-warnings* '()) => *SAVED-WARNINGS* (defun quiet-warning-handler (c) (when *all-quiet* (let ((r (find-restart 'muffle-warning c))) (when r (push c *saved-warnings*) (invoke-restart r))))) => CUSTOM-WARNING-HANDLER (defmacro with-quiet-warnings (&body forms) `(let ((*all-quiet* t) (*saved-warnings* '())) (handler-bind ((warning #'quiet-warning-handler)) ,@forms *saved-warnings*))) => WITH-QUIET-WARNINGS (setq saved (with-quiet-warnings (warn "Situation #1.") (let ((*all-quiet* nil)) (warn "Situation #2.")) (warn "Situation #3."))) |> Warning: Situation #2. => (# #) (dolist (s saved) (format t "~&~A~ |> Situation #3. |> Situation #1. => NIL See Also:: .......... *note Restarts::, *note Interfaces to Restarts::, *note invoke-restart:: , *note muffle-warning:: (function), *note warn::  File: gcl.info, Node: store-value, Next: use-value, Prev: muffle-warning, Up: Conditions Dictionary 9.2.44 store-value [Restart] ---------------------------- Data Arguments Required:: ......................... a value to use instead (on an ongoing basis). Description:: ............. The store-value restart is generally used by handlers trying to recover from errors of types such as cell-error or type-error, which may wish to supply a replacement datum to be stored permanently. Examples:: .......... (defun type-error-auto-coerce (c) (when (typep c 'type-error) (let ((r (find-restart 'store-value c))) (handler-case (let ((v (coerce (type-error-datum c) (type-error-expected-type c)))) (invoke-restart r v)) (error ()))))) => TYPE-ERROR-AUTO-COERCE (let ((x 3)) (handler-bind ((type-error #'type-error-auto-coerce)) (check-type x float) x)) => 3.0 See Also:: .......... *note Restarts::, *note Interfaces to Restarts::, *note invoke-restart:: , *note store-value:: (function), ccase, *note check-type:: , ctypecase, *note use-value:: (function and restart)  File: gcl.info, Node: use-value, Next: abort (Function), Prev: store-value, Up: Conditions Dictionary 9.2.45 use-value [Restart] -------------------------- Data Arguments Required:: ......................... a value to use instead (once). Description:: ............. The use-value restart is generally used by handlers trying to recover from errors of types such as cell-error, where the handler may wish to supply a replacement datum for one-time use. See Also:: .......... *note Restarts::, *note Interfaces to Restarts::, *note invoke-restart:: , *note use-value:: (function), *note store-value:: (function and restart)  File: gcl.info, Node: abort (Function), Prev: use-value, Up: Conditions Dictionary 9.2.46 abort, continue, muffle-warning, store-value, use-value [Function] ------------------------------------------------------------------------- 'abort' &optional condition => # 'continue' &optional condition => nil 'muffle-warning' &optional condition => # 'store-value' value &optional condition => nil 'use-value' value &optional condition => nil Arguments and Values:: ...................... value--an object. condition--a condition object, or nil. Description:: ............. Transfers control to the most recently established applicable restart having the same name as the function. That is, the function abort searches for an applicable abort restart, the function continue searches for an applicable continue restart, and so on. If no such restart exists, the functions continue, store-value, and use-value return nil, and the functions abort and muffle-warning signal an error of type control-error. When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered. Examples:: .......... ;;; Example of the ABORT retart (defmacro abort-on-error (&body forms) `(handler-bind ((error #'abort)) ,@forms)) => ABORT-ON-ERROR (abort-on-error (+ 3 5)) => 8 (abort-on-error (error "You lose.")) |> Returned to Lisp Top Level. ;;; Example of the CONTINUE restart (defun real-sqrt (n) (when (minusp n) (setq n (- n)) (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n)) (sqrt n)) (real-sqrt 4) => 2 (real-sqrt -9) |> Error: Tried to take sqrt(-9). |> To continue, type :CONTINUE followed by an option number: |> 1: Return sqrt(9) instead. |> 2: Return to Lisp Toplevel. |> Debug> |>>(continue)<<| |> Return sqrt(9) instead. => 3 (handler-bind ((error #'(lambda (c) (continue)))) (real-sqrt -9)) => 3 ;;; Example of the MUFFLE-WARNING restart (defun count-down (x) (do ((counter x (1- counter))) ((= counter 0) 'done) (when (= counter 1) (warn "Almost done")) (format t "~&~D~ => COUNT-DOWN (count-down 3) |> 3 |> 2 |> Warning: Almost done |> 1 => DONE (defun ignore-warnings-while-counting (x) (handler-bind ((warning #'ignore-warning)) (count-down x))) => IGNORE-WARNINGS-WHILE-COUNTING (defun ignore-warning (condition) (declare (ignore condition)) (muffle-warning)) => IGNORE-WARNING (ignore-warnings-while-counting 3) |> 3 |> 2 |> 1 => DONE ;;; Example of the STORE-VALUE and USE-VALUE restarts (defun careful-symbol-value (symbol) (check-type symbol symbol) (restart-case (if (boundp symbol) (return-from careful-symbol-value (symbol-value symbol)) (error 'unbound-variable :name symbol)) (use-value (value) :report "Specify a value to use this time." value) (store-value (value) :report "Specify a value to store and use in the future." (setf (symbol-value symbol) value)))) (setq a 1234) => 1234 (careful-symbol-value 'a) => 1234 (makunbound 'a) => A (careful-symbol-value 'a) |> Error: A is not bound. |> To continue, type :CONTINUE followed by an option number. |> 1: Specify a value to use this time. |> 2: Specify a value to store and use in the future. |> 3: Return to Lisp Toplevel. |> Debug> |>>(use-value 12)<<| => 12 (careful-symbol-value 'a) |> Error: A is not bound. |> To continue, type :CONTINUE followed by an option number. |> 1: Specify a value to use this time. |> 2: Specify a value to store and use in the future. |> 3: Return to Lisp Toplevel. |> Debug> |>>(store-value 24)<<| => 24 (careful-symbol-value 'a) => 24 ;;; Example of the USE-VALUE restart (defun add-symbols-with-default (default &rest symbols) (handler-bind ((sys:unbound-symbol #'(lambda (c) (declare (ignore c)) (use-value default)))) (apply #'+ (mapcar #'careful-symbol-value symbols)))) => ADD-SYMBOLS-WITH-DEFAULT (setq x 1 y 2) => 2 (add-symbols-with-default 3 'x 'y 'z) => 6 Side Effects:: .............. A transfer of control may occur if an appropriate restart is available, or (in the case of the function abort or the function muffle-warning) execution may be stopped. Affected By:: ............. Each of these functions can be affected by the presence of a restart having the same name. Exceptional Situations:: ........................ If an appropriate abort restart is not available for the function abort, or an appropriate muffle-warning restart is not available for the function muffle-warning, an error of type control-error is signaled. See Also:: .......... *note invoke-restart:: , *note Restarts::, *note Interfaces to Restarts::, *note assert:: , ccase, *note cerror:: , *note check-type:: , ctypecase, *note use-value:: , *note warn:: Notes:: ....... (abort condition) == (invoke-restart 'abort) (muffle-warning) == (invoke-restart 'muffle-warning) (continue) == (let ((r (find-restart 'continue))) (if r (invoke-restart r))) (use-value x) == (let ((r (find-restart 'use-value))) (if r (invoke-restart r x))) (store-value x) == (let ((r (find-restart 'store-value))) (if r (invoke-restart r x))) No functions defined in this specification are required to provide a use-value restart.  File: gcl.info, Node: Symbols, Next: Packages, Prev: Conditions, Up: Top 10 Symbols ********** * Menu: * Symbol Concepts:: * Symbols Dictionary::  File: gcl.info, Node: Symbol Concepts, Next: Symbols Dictionary, Prev: Symbols, Up: Symbols 10.1 Symbol Concepts ==================== Figure 10-1 lists some defined names that are applicable to the property lists of symbols. get remprop symbol-plist Figure 10-1: Property list defined names Figure 10-2 lists some defined names that are applicable to the creation of and inquiry about symbols. copy-symbol keywordp symbol-package gensym make-symbol symbol-value gentemp symbol-name Figure 10-2: Symbol creation and inquiry defined names  File: gcl.info, Node: Symbols Dictionary, Prev: Symbol Concepts, Up: Symbols 10.2 Symbols Dictionary ======================= * Menu: * symbol:: * keyword:: * symbolp:: * keywordp:: * make-symbol:: * copy-symbol:: * gensym:: * *gensym-counter*:: * gentemp:: * symbol-function:: * symbol-name:: * symbol-package:: * symbol-plist:: * symbol-value:: * get:: * remprop:: * boundp:: * makunbound:: * set:: * unbound-variable::  File: gcl.info, Node: symbol, Next: keyword, Prev: Symbols Dictionary, Up: Symbols Dictionary 10.2.1 symbol [System Class] ---------------------------- Class Precedence List:: ....................... symbol, t Description:: ............. Symbols are used for their object identity to name various entities in Common Lisp, including (but not limited to) linguistic entities such as variables and functions. Symbols can be collected together into packages. A symbol is said to be interned in a package if it is accessible in that package; the same symbol can be interned in more than one package. If a symbol is not interned in any package, it is called uninterned. An interned symbol is uniquely identifiable by its name from any package in which it is accessible. Symbols have the following attributes. For historically reasons, these are sometimes referred to as cells, although the actual internal representation of symbols and their attributes is implementation-dependent. Name The name of a symbol is a string used to identify the symbol. Every symbol has a name, and the consequences are undefined if that name is altered. The name is used as part of the external, printed representation of the symbol; see *note Character Syntax::. The function symbol-name returns the name of a given symbol. A symbol may have any character in its name. Package The object in this cell is called the home package of the symbol. If the home package is nil, the symbol is sometimes said to have no home package. When a symbol is first created, it has no home package. When it is first interned, the package in which it is initially interned becomes its home package. The home package of a symbol can be accessed by using the function symbol-package. If a symbol is uninterned from the package which is its home package, its home package is set to nil. Depending on whether there is another package in which the symbol is interned, the symbol might or might not really be an uninterned symbol. A symbol with no home package is therefore called apparently uninterned. The consequences are undefined if an attempt is made to alter the home package of a symbol external in the COMMON-LISP package or the KEYWORD package. Property list The property list of a symbol provides a mechanism for associating named attributes with that symbol. The operations for adding and removing entries are destructive to the property list. Common Lisp provides operators both for direct manipulation of property list objects (e.g., see getf, remf, and symbol-plist) and for implicit manipulation of a symbol's property list by reference to the symbol (e.g., see get and remprop). The property list associated with a fresh symbol is initially null. Value If a symbol has a value attribute, it is said to be bound, and that fact can be detected by the function boundp. The object contained in the value cell of a bound symbol is the value of the global variable named by that symbol, and can be accessed by the function symbol-value. A symbol can be made to be unbound by the function makunbound. The consequences are undefined if an attempt is made to change the value of a symbol that names a constant variable, or to make such a symbol be unbound. Function If a symbol has a function attribute, it is said to be fbound, and that fact can be detected by the function fboundp. If the symbol is the name of a function in the global environment, the function cell contains the function, and can be accessed by the function symbol-function. If the symbol is the name of either a macro in the global environment (see macro-function) or a special operator (see special-operator-p), the symbol is fbound, and can be accessed by the function symbol-function, but the object which the function cell contains is of implementation-dependent type and purpose. A symbol can be made to be funbound by the function fmakunbound. The consequences are undefined if an attempt is made to change the functional value of a symbol that names a special form. Operations on a symbol's value cell and function cell are sometimes described in terms of their effect on the symbol itself, but the user should keep in mind that there is an intimate relationship between the contents of those cells and the global variable or global function definition, respectively. Symbols are used as identifiers for lexical variables and lexical function definitions, but in that role, only their object identity is significant. Common Lisp provides no operation on a symbol that can have any effect on a lexical variable or on a lexical function definition. See Also:: .......... *note Symbols as Tokens::, *note Potential Numbers as Tokens::, *note Printing Symbols::  File: gcl.info, Node: keyword, Next: symbolp, Prev: symbol, Up: Symbols Dictionary 10.2.2 keyword [Type] --------------------- Supertypes:: ............ keyword, symbol, t Description:: ............. The type keyword includes all symbols interned the KEYWORD package. Interning a symbol in the KEYWORD package has three automatic effects: 1. It causes the symbol to become bound to itself. 2. It causes the symbol to become an external symbol of the KEYWORD package. 3. It causes the symbol to become a constant variable. See Also:: .......... *note keywordp::  File: gcl.info, Node: symbolp, Next: keywordp, Prev: keyword, Up: Symbols Dictionary 10.2.3 symbolp [Function] ------------------------- 'symbolp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type symbol; otherwise, returns false. Examples:: .......... (symbolp 'elephant) => true (symbolp 12) => false (symbolp nil) => true (symbolp '()) => true (symbolp :test) => true (symbolp "hello") => false See Also:: .......... *note keywordp:: , symbol, *note typep:: Notes:: ....... (symbolp object) == (typep object 'symbol)  File: gcl.info, Node: keywordp, Next: make-symbol, Prev: symbolp, Up: Symbols Dictionary 10.2.4 keywordp [Function] -------------------------- 'keywordp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is a keyword_1; otherwise, returns false. Examples:: .......... (keywordp 'elephant) => false (keywordp 12) => false (keywordp :test) => true (keywordp ':test) => true (keywordp nil) => false (keywordp :nil) => true (keywordp '(:test)) => false (keywordp "hello") => false (keywordp ":hello") => false (keywordp '&optional) => false See Also:: .......... *note constantp:: , *note keyword:: , *note symbolp:: , *note symbol-package::  File: gcl.info, Node: make-symbol, Next: copy-symbol, Prev: keywordp, Up: Symbols Dictionary 10.2.5 make-symbol [Function] ----------------------------- 'make-symbol' name => new-symbol Arguments and Values:: ...................... name--a string. new-symbol--a fresh, uninterned symbol. Description:: ............. make-symbol creates and returns a fresh, uninterned symbol whose name is the given name. The new-symbol is neither bound nor fbound and has a null property list. It is implementation-dependent whether the string that becomes the new-symbol's name is the given name or a copy of it. Once a string has been given as the name argument to make-symbol, the consequences are undefined if a subsequent attempt is made to alter that string. Examples:: .......... (setq temp-string "temp") => "temp" (setq temp-symbol (make-symbol temp-string)) => #:|temp| (symbol-name temp-symbol) => "temp" (eq (symbol-name temp-symbol) temp-string) => implementation-dependent (find-symbol "temp") => NIL, NIL (eq (make-symbol temp-string) (make-symbol temp-string)) => false Exceptional Situations:: ........................ Should signal an error of type type-error if name is not a string. See Also:: .......... *note copy-symbol:: Notes:: ....... No attempt is made by make-symbol to convert the case of the name to uppercase. The only case conversion which ever occurs for symbols is done by the Lisp reader. The program interface to symbol creation retains case, and the program interface to interning symbols is case-sensitive.  File: gcl.info, Node: copy-symbol, Next: gensym, Prev: make-symbol, Up: Symbols Dictionary 10.2.6 copy-symbol [Function] ----------------------------- 'copy-symbol' symbol &optional copy-properties => new-symbol Arguments and Values:: ...................... symbol--a symbol. copy-properties--a generalized boolean. The default is false. new-symbol--a fresh, uninterned symbol. Description:: ............. copy-symbol returns a fresh, uninterned symbol, the name of which is string= to and possibly the same as the name of the given symbol. If copy-properties is false, the new-symbol is neither bound nor fbound and has a null property list. If copy-properties is true, then the initial value of new-symbol is the value of symbol, the initial function definition of new-symbol is the functional value of symbol, and the property list of new-symbol is a copy_2 of the property list of symbol. Examples:: .......... (setq fred 'fred-smith) => FRED-SMITH (setf (symbol-value fred) 3) => 3 (setq fred-clone-1a (copy-symbol fred nil)) => #:FRED-SMITH (setq fred-clone-1b (copy-symbol fred nil)) => #:FRED-SMITH (setq fred-clone-2a (copy-symbol fred t)) => #:FRED-SMITH (setq fred-clone-2b (copy-symbol fred t)) => #:FRED-SMITH (eq fred fred-clone-1a) => false (eq fred-clone-1a fred-clone-1b) => false (eq fred-clone-2a fred-clone-2b) => false (eq fred-clone-1a fred-clone-2a) => false (symbol-value fred) => 3 (boundp fred-clone-1a) => false (symbol-value fred-clone-2a) => 3 (setf (symbol-value fred-clone-2a) 4) => 4 (symbol-value fred) => 3 (symbol-value fred-clone-2a) => 4 (symbol-value fred-clone-2b) => 3 (boundp fred-clone-1a) => false (setf (symbol-function fred) #'(lambda (x) x)) => # (fboundp fred) => true (fboundp fred-clone-1a) => false (fboundp fred-clone-2a) => false Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note make-symbol:: Notes:: ....... Implementors are encouraged not to copy the string which is the symbol's name unnecessarily. Unless there is a good reason to do so, the normal implementation strategy is for the new-symbol's name to be identical to the given symbol's name.  File: gcl.info, Node: gensym, Next: *gensym-counter*, Prev: copy-symbol, Up: Symbols Dictionary 10.2.7 gensym [Function] ------------------------ 'gensym' &optional x => new-symbol Arguments and Values:: ...................... x--a string or a non-negative integer. Complicated defaulting behavior; see below. new-symbol--a fresh, uninterned symbol. Description:: ............. Creates and returns a fresh, uninterned symbol, as if by calling make-symbol. (The only difference between gensym and make-symbol is in how the new-symbol's name is determined.) The name of the new-symbol is the concatenation of a prefix, which defaults to "G", and a suffix, which is the decimal representation of a number that defaults to the value of *gensym-counter*. If x is supplied, and is a string, then that string is used as a prefix instead of "G" for this call to gensym only. If x is supplied, and is an integer, then that integer, instead of the value of *gensym-counter*, is used as the suffix for this call to gensym only. If and only if no explicit suffix is supplied, *gensym-counter* is incremented after it is used. Examples:: .......... (setq sym1 (gensym)) => #:G3142 (symbol-package sym1) => NIL (setq sym2 (gensym 100)) => #:G100 (setq sym3 (gensym 100)) => #:G100 (eq sym2 sym3) => false (find-symbol "G100") => NIL, NIL (gensym "T") => #:T3143 (gensym) => #:G3144 Side Effects:: .............. Might increment *gensym-counter*. Affected By:: ............. *gensym-counter* Exceptional Situations:: ........................ Should signal an error of type type-error if x is not a string or a non-negative integer. See Also:: .......... *note gentemp:: , *gensym-counter* Notes:: ....... The ability to pass a numeric argument to gensym has been deprecated; explicitly binding *gensym-counter* is now stylistically preferred. (The somewhat baroque conventions for the optional argument are historical in nature, and supported primarily for compatibility with older dialects of Lisp. In modern code, it is recommended that the only kind of argument used be a string prefix. In general, though, to obtain more flexible control of the new-symbol's name, consider using make-symbol instead.)  File: gcl.info, Node: *gensym-counter*, Next: gentemp, Prev: gensym, Up: Symbols Dictionary 10.2.8 *gensym-counter* [Variable] ---------------------------------- Value Type:: ............ a non-negative integer. Initial Value:: ............... implementation-dependent. Description:: ............. A number which will be used in constructing the name of the next symbol generated by the function gensym. *gensym-counter* can be either assigned or bound at any time, but its value must always be a non-negative integer. Affected By:: ............. gensym. See Also:: .......... *note gensym:: Notes:: ....... The ability to pass a numeric argument to gensym has been deprecated; explicitly binding *gensym-counter* is now stylistically preferred.  File: gcl.info, Node: gentemp, Next: symbol-function, Prev: *gensym-counter*, Up: Symbols Dictionary 10.2.9 gentemp [Function] ------------------------- 'gentemp' &optional prefix package => new-symbol Arguments and Values:: ...................... prefix--a string. The default is "T". package--a package designator. The default is the current package. new-symbol--a fresh, interned symbol. Description:: ............. gentemp creates and returns a fresh symbol, interned in the indicated package. The symbol is guaranteed to be one that was not previously accessible in package. It is neither bound nor fbound, and has a null property list. The name of the new-symbol is the concatenation of the prefix and a suffix, which is taken from an internal counter used only by gentemp. (If a symbol by that name is already accessible in package, the counter is incremented as many times as is necessary to produce a name that is not already the name of a symbol accessible in package.) Examples:: .......... (gentemp) => T1298 (gentemp "FOO") => FOO1299 (find-symbol "FOO1300") => NIL, NIL (gentemp "FOO") => FOO1300 (find-symbol "FOO1300") => FOO1300, :INTERNAL (intern "FOO1301") => FOO1301, :INTERNAL (gentemp "FOO") => FOO1302 (gentemp) => T1303 Side Effects:: .............. Its internal counter is incremented one or more times. Interns the new-symbol in package. Affected By:: ............. The current state of its internal counter, and the current state of the package. Exceptional Situations:: ........................ Should signal an error of type type-error if prefix is not a string. Should signal an error of type type-error if package is not a package designator. See Also:: .......... *note gensym:: Notes:: ....... The function gentemp is deprecated. If package is the KEYWORD package, the result is an external symbol of package. Otherwise, the result is an internal symbol of package. The gentemp internal counter is independent of *gensym-counter*, the counter used by gensym. There is no provision for accessing the gentemp internal counter. Just because gentemp creates a symbol which did not previously exist does not mean that such a symbol might not be seen in the future (e.g., in a data file--perhaps even created by the same program in another session). As such, this symbol is not truly unique in the same sense as a gensym would be. In particular, programs which do automatic code generation should be careful not to attach global attributes to such generated symbols (e.g., special declarations) and then write them into a file because such global attributes might, in a different session, end up applying to other symbols that were automatically generated on another day for some other purpose.  File: gcl.info, Node: symbol-function, Next: symbol-name, Prev: gentemp, Up: Symbols Dictionary 10.2.10 symbol-function [Accessor] ---------------------------------- 'symbol-function' symbol => contents (setf (' symbol-function' symbol) new-contents) Arguments and Values:: ...................... symbol--a symbol. contents-- If the symbol is globally defined as a macro or a special operator, an object of implementation-dependent nature and identity is returned. If the symbol is not globally defined as either a macro or a special operator, and if the symbol is fbound, a function object is returned. new-contents--a function. Description:: ............. Accesses the symbol's function cell. Examples:: .......... (symbol-function 'car) => # (symbol-function 'twice) is an error ;because TWICE isn't defined. (defun twice (n) (* n 2)) => TWICE (symbol-function 'twice) => # (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3)) => (6 6 6) (flet ((twice (x) (list x x))) (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3))) => ((3 3) (3 3) 6) (setf (symbol-function 'twice) #'(lambda (x) (list x x))) => # (list (twice 3) (funcall (function twice) 3) (funcall (symbol-function 'twice) 3)) => ((3 3) (3 3) (3 3)) (fboundp 'defun) => true (symbol-function 'defun) => implementation-dependent (functionp (symbol-function 'defun)) => implementation-dependent (defun symbol-function-or-nil (symbol) (if (and (fboundp symbol) (not (macro-function symbol)) (not (special-operator-p symbol))) (symbol-function symbol) nil)) => SYMBOL-FUNCTION-OR-NIL (symbol-function-or-nil 'car) => # (symbol-function-or-nil 'defun) => NIL Affected By:: ............. defun Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. Should signal undefined-function if symbol is not fbound and an attempt is made to read its definition. (No such error is signaled on an attempt to write its definition.) See Also:: .......... *note fboundp:: , *note fmakunbound:: , *note macro-function:: , *note special-operator-p:: Notes:: ....... symbol-function cannot access the value of a lexical function name produced by flet or labels; it can access only the global function value. setf may be used with symbol-function to replace a global function definition when the symbol's function definition does not represent a special operator. (symbol-function symbol) == (fdefinition symbol) However, fdefinition accepts arguments other than just symbols.  File: gcl.info, Node: symbol-name, Next: symbol-package, Prev: symbol-function, Up: Symbols Dictionary 10.2.11 symbol-name [Function] ------------------------------ 'symbol-name' symbol => name Arguments and Values:: ...................... symbol--a symbol. name--a string. Description:: ............. symbol-name returns the name of symbol. The consequences are undefined if name is ever modified. Examples:: .......... (symbol-name 'temp) => "TEMP" (symbol-name :start) => "START" (symbol-name (gensym)) => "G1234" ;for example Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol.  File: gcl.info, Node: symbol-package, Next: symbol-plist, Prev: symbol-name, Up: Symbols Dictionary 10.2.12 symbol-package [Function] --------------------------------- 'symbol-package' symbol => contents Arguments and Values:: ...................... symbol--a symbol. contents--a package object or nil. Description:: ............. Returns the home package of symbol. Examples:: .......... (in-package "CL-USER") => # (symbol-package 'car) => # (symbol-package 'bus) => # (symbol-package :optional) => # ;; Gensyms are uninterned, so have no home package. (symbol-package (gensym)) => NIL (make-package 'pk1) => # (intern "SAMPLE1" "PK1") => PK1::SAMPLE1, NIL (export (find-symbol "SAMPLE1" "PK1") "PK1") => T (make-package 'pk2 :use '(pk1)) => # (find-symbol "SAMPLE1" "PK2") => PK1:SAMPLE1, :INHERITED (symbol-package 'pk1::sample1) => # (symbol-package 'pk2::sample1) => # (symbol-package 'pk1::sample2) => # (symbol-package 'pk2::sample2) => # ;; The next several forms create a scenario in which a symbol ;; is not really uninterned, but is "apparently uninterned", ;; and so SYMBOL-PACKAGE still returns NIL. (setq s3 'pk1::sample3) => PK1::SAMPLE3 (import s3 'pk2) => T (unintern s3 'pk1) => T (symbol-package s3) => NIL (eq s3 'pk2::sample3) => T Affected By:: ............. import, intern, unintern Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note intern::  File: gcl.info, Node: symbol-plist, Next: symbol-value, Prev: symbol-package, Up: Symbols Dictionary 10.2.13 symbol-plist [Accessor] ------------------------------- 'symbol-plist' symbol => plist (setf (' symbol-plist' symbol) new-plist) Arguments and Values:: ...................... symbol--a symbol. plist, new-plist--a property list. Description:: ............. Accesses the property list of symbol. Examples:: .......... (setq sym (gensym)) => #:G9723 (symbol-plist sym) => () (setf (get sym 'prop1) 'val1) => VAL1 (symbol-plist sym) => (PROP1 VAL1) (setf (get sym 'prop2) 'val2) => VAL2 (symbol-plist sym) => (PROP2 VAL2 PROP1 VAL1) (setf (symbol-plist sym) (list 'prop3 'val3)) => (PROP3 VAL3) (symbol-plist sym) => (PROP3 VAL3) Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note get:: , *note remprop:: Notes:: ....... The use of setf should be avoided, since a symbol's property list is a global resource that can contain information established and depended upon by unrelated programs in the same Lisp image.  File: gcl.info, Node: symbol-value, Next: get, Prev: symbol-plist, Up: Symbols Dictionary 10.2.14 symbol-value [Accessor] ------------------------------- 'symbol-value' symbol => value (setf (' symbol-value' symbol) new-value) Arguments and Values:: ...................... symbol--a symbol that must have a value. value, new-value--an object. Description:: ............. Accesses the symbol's value cell. Examples:: .......... (setf (symbol-value 'a) 1) => 1 (symbol-value 'a) => 1 ;; SYMBOL-VALUE cannot see lexical variables. (let ((a 2)) (symbol-value 'a)) => 1 (let ((a 2)) (setq a 3) (symbol-value 'a)) => 1 ;; SYMBOL-VALUE can see dynamic variables. (let ((a 2)) (declare (special a)) (symbol-value 'a)) => 2 (let ((a 2)) (declare (special a)) (setq a 3) (symbol-value 'a)) => 3 (let ((a 2)) (setf (symbol-value 'a) 3) a) => 2 a => 3 (symbol-value 'a) => 3 (let ((a 4)) (declare (special a)) (let ((b (symbol-value 'a))) (setf (symbol-value 'a) 5) (values a b))) => 5, 4 a => 3 (symbol-value :any-keyword) => :ANY-KEYWORD (symbol-value 'nil) => NIL (symbol-value '()) => NIL ;; The precision of this next one is implementation-dependent. (symbol-value 'pi) => 3.141592653589793d0 Affected By:: ............. makunbound, set, setq Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. Should signal unbound-variable if symbol is unbound and an attempt is made to read its value. (No such error is signaled on an attempt to write its value.) See Also:: .......... *note boundp:: , *note makunbound:: , *note set:: , *note setq:: Notes:: ....... symbol-value can be used to get the value of a constant variable. symbol-value cannot access the value of a lexical variable.  File: gcl.info, Node: get, Next: remprop, Prev: symbol-value, Up: Symbols Dictionary 10.2.15 get [Accessor] ---------------------- 'get' symbol indicator &optional default => value (setf (' get' symbol indicator &optional default) new-value) Arguments and Values:: ...................... symbol--a symbol. indicator--an object. default--an object. The default is nil. value--if the indicated property exists, the object that is its value; otherwise, the specified default. new-value--an object. Description:: ............. get finds a property on the property list_2 of symbol whose property indicator is identical to indicator, and returns its corresponding property value. If there are multiple properties_1 with that property indicator, get uses the first such property. If there is no property with that property indicator, default is returned. setf of get may be used to associate a new object with an existing indicator already on the symbol's property list, or to create a new assocation if none exists. If there are multiple properties_1 with that property indicator, setf of get associates the new-value with the first such property. When a get form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored. Examples:: .......... (defun make-person (first-name last-name) (let ((person (gensym "PERSON"))) (setf (get person 'first-name) first-name) (setf (get person 'last-name) last-name) person)) => MAKE-PERSON (defvar *john* (make-person "John" "Dow")) => *JOHN* *john* => #:PERSON4603 (defvar *sally* (make-person "Sally" "Jones")) => *SALLY* (get *john* 'first-name) => "John" (get *sally* 'last-name) => "Jones" (defun marry (man woman married-name) (setf (get man 'wife) woman) (setf (get woman 'husband) man) (setf (get man 'last-name) married-name) (setf (get woman 'last-name) married-name) married-name) => MARRY (marry *john* *sally* "Dow-Jones") => "Dow-Jones" (get *john* 'last-name) => "Dow-Jones" (get (get *john* 'wife) 'first-name) => "Sally" (symbol-plist *john*) => (WIFE #:PERSON4604 LAST-NAME "Dow-Jones" FIRST-NAME "John") (defmacro age (person &optional (default ''thirty-something)) `(get ,person 'age ,default)) => AGE (age *john*) => THIRTY-SOMETHING (age *john* 20) => 20 (setf (age *john*) 25) => 25 (age *john*) => 25 (age *john* 20) => 25 Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note getf:: , *note symbol-plist:: , *note remprop:: Notes:: ....... (get x y) == (getf (symbol-plist x) y) Numbers and characters are not recommended for use as indicators in portable code since get tests with eq rather than eql, and consequently the effect of using such indicators is implementation-dependent. There is no way using get to distinguish an absent property from one whose value is default. However, see get-properties.  File: gcl.info, Node: remprop, Next: boundp, Prev: get, Up: Symbols Dictionary 10.2.16 remprop [Function] -------------------------- 'remprop' symbol indicator => generalized-boolean Arguments and Values:: ...................... symbol--a symbol. indicator--an object. generalized-boolean--a generalized boolean. Description:: ............. remprop removes from the property list_2 of symbol a property_1 with a property indicator identical to indicator. If there are multiple properties_1 with the identical key, remprop only removes the first such property. remprop returns false if no such property was found, or true if a property was found. The property indicator and the corresponding property value are removed in an undefined order by destructively splicing the property list. The permissible side-effects correspond to those permitted for remf, such that: (remprop x y) == (remf (symbol-plist x) y) Examples:: .......... (setq test (make-symbol "PSEUDO-PI")) => #:PSEUDO-PI (symbol-plist test) => () (setf (get test 'constant) t) => T (setf (get test 'approximation) 3.14) => 3.14 (setf (get test 'error-range) 'noticeable) => NOTICEABLE (symbol-plist test) => (ERROR-RANGE NOTICEABLE APPROXIMATION 3.14 CONSTANT T) (setf (get test 'approximation) nil) => NIL (symbol-plist test) => (ERROR-RANGE NOTICEABLE APPROXIMATION NIL CONSTANT T) (get test 'approximation) => NIL (remprop test 'approximation) => true (get test 'approximation) => NIL (symbol-plist test) => (ERROR-RANGE NOTICEABLE CONSTANT T) (remprop test 'approximation) => NIL (symbol-plist test) => (ERROR-RANGE NOTICEABLE CONSTANT T) (remprop test 'error-range) => true (setf (get test 'approximation) 3) => 3 (symbol-plist test) => (APPROXIMATION 3 CONSTANT T) Side Effects:: .............. The property list of symbol is modified. Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note remf:: , *note symbol-plist:: Notes:: ....... Numbers and characters are not recommended for use as indicators in portable code since remprop tests with eq rather than eql, and consequently the effect of using such indicators is implementation-dependent. Of course, if you've gotten as far as needing to remove such a property, you don't have much choice--the time to have been thinking about this was when you used setf of get to establish the property.  File: gcl.info, Node: boundp, Next: makunbound, Prev: remprop, Up: Symbols Dictionary 10.2.17 boundp [Function] ------------------------- 'boundp' symbol => generalized-boolean Arguments and Values:: ...................... symbol--a symbol. generalized-boolean--a generalized boolean. Description:: ............. Returns true if symbol is bound; otherwise, returns false. Examples:: .......... (setq x 1) => 1 (boundp 'x) => true (makunbound 'x) => X (boundp 'x) => false (let ((x 2)) (boundp 'x)) => false (let ((x 2)) (declare (special x)) (boundp 'x)) => true Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note set:: , *note setq:: , *note symbol-value:: , *note makunbound:: Notes:: ....... The function bound determines only whether a symbol has a value in the global environment; any lexical bindings are ignored.  File: gcl.info, Node: makunbound, Next: set, Prev: boundp, Up: Symbols Dictionary 10.2.18 makunbound [Function] ----------------------------- 'makunbound' symbol => symbol Arguments and Values:: ...................... symbol--a symbol Description:: ............. Makes the symbol be unbound, regardless of whether it was previously bound. Examples:: .......... (setf (symbol-value 'a) 1) (boundp 'a) => true a => 1 (makunbound 'a) => A (boundp 'a) => false Side Effects:: .............. The value cell of symbol is modified. Exceptional Situations:: ........................ Should signal an error of type type-error if symbol is not a symbol. See Also:: .......... *note boundp:: , *note fmakunbound::  File: gcl.info, Node: set, Next: unbound-variable, Prev: makunbound, Up: Symbols Dictionary 10.2.19 set [Function] ---------------------- 'set' symbol value => value Arguments and Values:: ...................... symbol--a symbol. value--an object. Description:: ............. set changes the contents of the value cell of symbol to the given value. (set symbol value) == (setf (symbol-value symbol) value) Examples:: .......... (setf (symbol-value 'n) 1) => 1 (set 'n 2) => 2 (symbol-value 'n) => 2 (let ((n 3)) (declare (special n)) (setq n (+ n 1)) (setf (symbol-value 'n) (* n 10)) (set 'n (+ (symbol-value 'n) n)) n) => 80 n => 2 (let ((n 3)) (setq n (+ n 1)) (setf (symbol-value 'n) (* n 10)) (set 'n (+ (symbol-value 'n) n)) n) => 4 n => 44 (defvar *n* 2) (let ((*n* 3)) (setq *n* (+ *n* 1)) (setf (symbol-value '*n*) (* *n* 10)) (set '*n* (+ (symbol-value '*n*) *n*)) *n*) => 80 *n* => 2 (defvar *even-count* 0) => *EVEN-COUNT* (defvar *odd-count* 0) => *ODD-COUNT* (defun tally-list (list) (dolist (element list) (set (if (evenp element) '*even-count* '*odd-count*) (+ element (if (evenp element) *even-count* *odd-count*))))) (tally-list '(1 9 4 3 2 7)) => NIL *even-count* => 6 *odd-count* => 20 Side Effects:: .............. The value of symbol is changed. See Also:: .......... *note setq:: , *note progv:: , *note symbol-value:: Notes:: ....... The function set is deprecated. set cannot change the value of a lexical variable.  File: gcl.info, Node: unbound-variable, Prev: set, Up: Symbols Dictionary 10.2.20 unbound-variable [Condition Type] ----------------------------------------- Class Precedence List:: ....................... unbound-variable, cell-error, error, serious-condition, condition, t Description:: ............. The type unbound-variable consists of error conditions that represent attempts to read the value of an unbound variable. The name of the cell (see cell-error) is the name of the variable that was unbound. See Also:: .......... *note cell-error-name::  File: gcl.info, Node: Packages, Next: Numbers (Numbers), Prev: Symbols, Up: Top 11 Packages *********** * Menu: * Package Concepts:: * Packages Dictionary::  File: gcl.info, Node: Package Concepts, Next: Packages Dictionary, Prev: Packages, Up: Packages 11.1 Package Concepts ===================== * Menu: * Introduction to Packages:: * Standardized Packages::  File: gcl.info, Node: Introduction to Packages, Next: Standardized Packages, Prev: Package Concepts, Up: Package Concepts 11.1.1 Introduction to Packages ------------------------------- A package establishes a mapping from names to symbols. At any given time, one package is current. The current package is the one that is the value of *package*. When using the Lisp reader, it is possible to refer to symbols in packages other than the current one through the use of package prefixes in the printed representation of the symbol. Figure 11-1 lists some defined names that are applicable to packages. Where an operator takes an argument that is either a symbol or a list of symbols, an argument of nil is treated as an empty list of symbols. Any package argument may be either a string, a symbol, or a package. If a symbol is supplied, its name will be used as the package name. *modules* import provide *package* in-package rename-package defpackage intern require do-all-symbols list-all-packages shadow do-external-symbols make-package shadowing-import do-symbols package-name unexport export package-nicknames unintern find-all-symbols package-shadowing-symbols unuse-package find-package package-use-list use-package find-symbol package-used-by-list Figure 11-1: Some Defined Names related to Packages * Menu: * Package Names and Nicknames:: * Symbols in a Package:: * Internal and External Symbols:: * Package Inheritance:: * Accessibility of Symbols in a Package:: * Locating a Symbol in a Package:: * Prevention of Name Conflicts in Packages::  File: gcl.info, Node: Package Names and Nicknames, Next: Symbols in a Package, Prev: Introduction to Packages, Up: Introduction to Packages 11.1.1.1 Package Names and Nicknames .................................... Each package has a name (a string) and perhaps some nicknames (also strings). These are assigned when the package is created and can be changed later. There is a single namespace for packages. The function find-package translates a package name or nickname into the associated package. The function package-name returns the name of a package. The function package-nicknames returns a list of all nicknames for a package. rename-package removes a package's current name and nicknames and replaces them with new ones specified by the caller.  File: gcl.info, Node: Symbols in a Package, Next: Internal and External Symbols, Prev: Package Names and Nicknames, Up: Introduction to Packages 11.1.1.2 Symbols in a Package .............................  File: gcl.info, Node: Internal and External Symbols, Next: Package Inheritance, Prev: Symbols in a Package, Up: Introduction to Packages 11.1.1.3 Internal and External Symbols ...................................... The mappings in a package are divided into two classes, external and internal. The symbols targeted by these different mappings are called external symbols and internal symbols of the package. Within a package, a name refers to one symbol or to none; if it does refer to a symbol, then it is either external or internal in that package, but not both. External symbols are part of the package's public interface to other packages. Symbols become external symbols of a given package if they have been exported from that package. A symbol has the same name no matter what package it is present in, but it might be an external symbol of some packages and an internal symbol of others.  File: gcl.info, Node: Package Inheritance, Next: Accessibility of Symbols in a Package, Prev: Internal and External Symbols, Up: Introduction to Packages 11.1.1.4 Package Inheritance ............................ Packages can be built up in layers. From one point of view, a package is a single collection of mappings from strings into internal symbols and external symbols. However, some of these mappings might be established within the package itself, while other mappings are inherited from other packages via use-package. A symbol is said to be present in a package if the mapping is in the package itself and is not inherited from somewhere else. There is no way to inherit the internal symbols of another package; to refer to an internal symbol using the Lisp reader, a package containing the symbol must be made to be the current package, a package prefix must be used, or the symbol must be imported into the current package.  File: gcl.info, Node: Accessibility of Symbols in a Package, Next: Locating a Symbol in a Package, Prev: Package Inheritance, Up: Introduction to Packages 11.1.1.5 Accessibility of Symbols in a Package .............................................. A symbol becomes accessible in a package if that is its home package when it is created, or if it is imported into that package, or by inheritance via use-package. If a symbol is accessible in a package, it can be referred to when using the Lisp reader without a package prefix when that package is the current package, regardless of whether it is present or inherited. Symbols from one package can be made accessible in another package in two ways. - Any individual symbol can be added to a package by use of import. After the call to import the symbol is present in the importing package. The status of the symbol in the package it came from (if any) is unchanged, and the home package for this symbol is unchanged. Once imported, a symbol is present in the importing package and can be removed only by calling unintern. A symbol is shadowed_3 by another symbol in some package if the first symbol would be accessible by inheritance if not for the presence of the second symbol. See shadowing-import. - The second mechanism for making symbols from one package accessible in another is provided by use-package. All of the external symbols of the used package are inherited by the using package. The function unuse-package undoes the effects of a previous use-package.  File: gcl.info, Node: Locating a Symbol in a Package, Next: Prevention of Name Conflicts in Packages, Prev: Accessibility of Symbols in a Package, Up: Introduction to Packages 11.1.1.6 Locating a Symbol in a Package ....................................... When a symbol is to be located in a given package the following occurs: - The external symbols and internal symbols of the package are searched for the symbol. - The external symbols of the used packages are searched in some unspecified order. The order does not matter; see the rules for handling name conflicts listed below.  File: gcl.info, Node: Prevention of Name Conflicts in Packages, Prev: Locating a Symbol in a Package, Up: Introduction to Packages 11.1.1.7 Prevention of Name Conflicts in Packages ................................................. Within one package, any particular name can refer to at most one symbol. A name conflict is said to occur when there would be more than one candidate symbol. Any time a name conflict is about to occur, a correctable error is signaled. The following rules apply to name conflicts: - Name conflicts are detected when they become possible, that is, when the package structure is altered. Name conflicts are not checked during every name lookup. - If the same symbol is accessible to a package through more than one path, there is no name conflict. A symbol cannot conflict with itself. Name conflicts occur only between distinct symbols with the same name (under string=). - Every package has a list of shadowing symbols. A shadowing symbol takes precedence over any other symbol of the same name that would otherwise be accessible in the package. A name conflict involving a shadowing symbol is always resolved in favor of the shadowing symbol, without signaling an error (except for one exception involving import). See shadow and shadowing-import. - The functions use-package, import, and export check for name conflicts. - shadow and shadowing-import never signal a name-conflict error. - unuse-package and unexport do not need to do any name-conflict checking. unintern does name-conflict checking only when a symbol being uninterned is a shadowing symbol . - Giving a shadowing symbol to unintern can uncover a name conflict that had previously been resolved by the shadowing. - Package functions signal name-conflict errors of type package-error before making any change to the package structure. When multiple changes are to be made, it is permissible for the implementation to process each change separately. For example, when export is given a list of symbols, aborting from a name conflict caused by the second symbol in the list might still export the first symbol in the list. However, a name-conflict error caused by export of a single symbol will be signaled before that symbol's accessibility in any package is changed. - Continuing from a name-conflict error must offer the user a chance to resolve the name conflict in favor of either of the candidates. The package structure should be altered to reflect the resolution of the name conflict, via shadowing-import, unintern, or unexport. - A name conflict in use-package between a symbol present in the using package and an external symbol of the used package is resolved in favor of the first symbol by making it a shadowing symbol, or in favor of the second symbol by uninterning the first symbol from the using package. - A name conflict in export or unintern due to a package's inheriting two distinct symbols with the same name (under string=) from two other packages can be resolved in favor of either symbol by importing it into the using package and making it a shadowing symbol , just as with use-package.  File: gcl.info, Node: Standardized Packages, Prev: Introduction to Packages, Up: Package Concepts 11.1.2 Standardized Packages ---------------------------- This section describes the packages that are available in every conforming implementation. A summary of the names and nicknames of those standardized packages is given in Figure 11-2. Name Nicknames COMMON-LISP CL COMMON-LISP-USER CL-USER KEYWORD none Figure 11-2: Standardized Package Names * Menu: * The COMMON-LISP Package:: * Constraints on the COMMON-LISP Package for Conforming Implementations:: * Constraints on the COMMON-LISP Package for Conforming Programs:: * Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs:: * The COMMON-LISP-USER Package:: * The KEYWORD Package:: * Interning a Symbol in the KEYWORD Package:: * Notes about The KEYWORD Package:: * Implementation-Defined Packages::  File: gcl.info, Node: The COMMON-LISP Package, Next: Constraints on the COMMON-LISP Package for Conforming Implementations, Prev: Standardized Packages, Up: Standardized Packages 11.1.2.1 The COMMON-LISP Package ................................ The COMMON-LISP package contains the primitives of the Common Lisp system as defined by this specification. Its external symbols include all of the defined names (except for defined names in the KEYWORD package) that are present in the Common Lisp system, such as car, cdr, *package*, etc. The COMMON-LISP package has the nickname CL. The COMMON-LISP package has as external symbols those symbols enumerated in the figures in *note Symbols in the COMMON-LISP Package::, and no others. These external symbols are present in the COMMON-LISP package but their home package need not be the COMMON-LISP package. For example, the symbol HELP cannot be an external symbol of the COMMON-LISP package because it is not mentioned in *note Symbols in the COMMON-LISP Package::. In contrast, the symbol variable must be an external symbol of the COMMON-LISP package even though it has no definition because it is listed in that section (to support its use as a valid second argument to the function documentation). The COMMON-LISP package can have additional internal symbols.  File: gcl.info, Node: Constraints on the COMMON-LISP Package for Conforming Implementations, Next: Constraints on the COMMON-LISP Package for Conforming Programs, Prev: The COMMON-LISP Package, Up: Standardized Packages 11.1.2.2 Constraints on the COMMON-LISP Package for Conforming Implementations .............................................................................. In a conforming implementation, an external symbol of the COMMON-LISP package can have a function, macro, or special operator definition, a global variable definition (or other status as a dynamic variable due to a special proclamation), or a type definition only if explicitly permitted in this standard. For example, fboundp yields false for any external symbol of the COMMON-LISP package that is not the name of a standardized function, macro or special operator, and boundp returns false for any external symbol of the COMMON-LISP package that is not the name of a standardized global variable. It also follows that conforming programs can use external symbols of the COMMON-LISP package as the names of local lexical variables with confidence that those names have not been proclaimed special by the implementation unless those symbols are names of standardized global variables. A conforming implementation must not place any property on an external symbol of the COMMON-LISP package using a property indicator that is either an external symbol of any standardized package or a symbol that is otherwise accessible in the COMMON-LISP-USER package.  File: gcl.info, Node: Constraints on the COMMON-LISP Package for Conforming Programs, Next: Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, Prev: Constraints on the COMMON-LISP Package for Conforming Implementations, Up: Standardized Packages 11.1.2.3 Constraints on the COMMON-LISP Package for Conforming Programs ....................................................................... Except where explicitly allowed, the consequences are undefined if any of the following actions are performed on an external symbol of the COMMON-LISP package: 1. Binding or altering its value (lexically or dynamically). (Some exceptions are noted below.) 2. Defining, undefining, or binding it as a function. (Some exceptions are noted below.) 3. Defining, undefining, or binding it as a macro or compiler macro. (Some exceptions are noted below.) 4. Defining it as a type specifier (via defstruct, defclass, deftype, define-condition). 5. Defining it as a structure (via defstruct). 6. Defining it as a declaration with a declaration proclamation. 7. Defining it as a symbol macro. 8. Altering its home package. 9. Tracing it (via trace). 10. Declaring or proclaiming it special (via declare, declaim, or proclaim). 11. Declaring or proclaiming its type or ftype (via declare, declaim, or proclaim). (Some exceptions are noted below.) 12. Removing it from the COMMON-LISP package. 13. Defining a setf expander for it (via defsetf or define-setf-method). 14. Defining, undefining, or binding its setf function name. 15. Defining it as a method combination type (via define-method-combination). 16. Using it as the class-name argument to setf of find-class. 17. Binding it as a catch tag. 18. Binding it as a restart name. 19. Defining a method for a standardized generic function which is applicable when all of the arguments are direct instances of standardized classes.  File: gcl.info, Node: Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, Next: The COMMON-LISP-USER Package, Prev: Constraints on the COMMON-LISP Package for Conforming Programs, Up: Standardized Packages 11.1.2.4 Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs .......................................................................................... If an external symbol of the COMMON-LISP package is not globally defined as a standardized dynamic variable or constant variable, it is allowed to lexically bind it and to declare the type of that binding, and it is allowed to locally establish it as a symbol macro (e.g., with symbol-macrolet). Unless explicitly specified otherwise, if an external symbol of the COMMON-LISP package is globally defined as a standardized dynamic variable, it is permitted to bind or assign that dynamic variable provided that the "Value Type" constraints on the dynamic variable are maintained, and that the new value of the variable is consistent with the stated purpose of the variable. If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind it as a function (e.g., with flet), to declare the ftype of that binding, and (in implementations which provide the ability to do so) to trace that binding. If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind it as a macro (e.g., with macrolet). If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind its setf function name as a function, and to declare the ftype of that binding.  File: gcl.info, Node: The COMMON-LISP-USER Package, Next: The KEYWORD Package, Prev: Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs, Up: Standardized Packages 11.1.2.5 The COMMON-LISP-USER Package ..................................... The COMMON-LISP-USER package is the current package when a Common Lisp system starts up. This package uses the COMMON-LISP package. The COMMON-LISP-USER package has the nickname CL-USER. The COMMON-LISP-USER package can have additional symbols interned within it; it can use other implementation-defined packages.  File: gcl.info, Node: The KEYWORD Package, Next: Interning a Symbol in the KEYWORD Package, Prev: The COMMON-LISP-USER Package, Up: Standardized Packages 11.1.2.6 The KEYWORD Package ............................ The KEYWORD package contains symbols, called keywords_1, that are typically used as special markers in programs and their associated data expressions_1. Symbol tokens that start with a package marker are parsed by the Lisp reader as symbols in the KEYWORD package; see *note Symbols as Tokens::. This makes it notationally convenient to use keywords when communicating between programs in different packages. For example, the mechanism for passing keyword parameters in a call uses keywords_1 to name the corresponding arguments; see *note Ordinary Lambda Lists::. Symbols in the KEYWORD package are, by definition, of type keyword.  File: gcl.info, Node: Interning a Symbol in the KEYWORD Package, Next: Notes about The KEYWORD Package, Prev: The KEYWORD Package, Up: Standardized Packages 11.1.2.7 Interning a Symbol in the KEYWORD Package .................................................. The KEYWORD package is treated differently than other packages in that special actions are taken when a symbol is interned in it. In particular, when a symbol is interned in the KEYWORD package, it is automatically made to be an external symbol and is automatically made to be a constant variable with itself as a value.  File: gcl.info, Node: Notes about The KEYWORD Package, Next: Implementation-Defined Packages, Prev: Interning a Symbol in the KEYWORD Package, Up: Standardized Packages 11.1.2.8 Notes about The KEYWORD Package ........................................ It is generally best to confine the use of keywords to situations in which there are a finitely enumerable set of names to be selected between. For example, if there were two states of a light switch, they might be called :on and :off. In situations where the set of names is not finitely enumerable (i.e., where name conflicts might arise) it is frequently best to use symbols in some package other than KEYWORD so that conflicts will be naturally avoided. For example, it is generally not wise for a program to use a keyword_1 as a property indicator, since if there were ever another program that did the same thing, each would clobber the other's data.  File: gcl.info, Node: Implementation-Defined Packages, Prev: Notes about The KEYWORD Package, Up: Standardized Packages 11.1.2.9 Implementation-Defined Packages ........................................ Other, implementation-defined packages might be present in the initial Common Lisp environment. It is recommended, but not required, that the documentation for a conforming implementation contain a full list of all package names initially present in that implementation but not specified in this specification. (See also the function list-all-packages.)  File: gcl.info, Node: Packages Dictionary, Prev: Package Concepts, Up: Packages 11.2 Packages Dictionary ======================== * Menu: * package:: * export:: * find-symbol:: * find-package:: * find-all-symbols:: * import:: * list-all-packages:: * rename-package:: * shadow:: * shadowing-import:: * delete-package:: * make-package:: * with-package-iterator:: * unexport:: * unintern:: * in-package:: * unuse-package:: * use-package:: * defpackage:: * do-symbols:: * intern:: * package-name:: * package-nicknames:: * package-shadowing-symbols:: * package-use-list:: * package-used-by-list:: * packagep:: * *package*:: * package-error:: * package-error-package::  File: gcl.info, Node: package, Next: export, Prev: Packages Dictionary, Up: Packages Dictionary 11.2.1 package [System Class] ----------------------------- Class Precedence List:: ....................... package, t Description:: ............. A package is a namespace that maps symbol names to symbols; see *note Package Concepts::. See Also:: .......... *note Package Concepts::, *note Printing Other Objects::, *note Symbols as Tokens::  File: gcl.info, Node: export, Next: find-symbol, Prev: package, Up: Packages Dictionary 11.2.2 export [Function] ------------------------ 'export' symbols &optional package => t Arguments and Values:: ...................... symbols--a designator for a list of symbols. package--a package designator. The default is the current package. Description:: ............. export makes one or more symbols that are accessible in package (whether directly or by inheritance) be external symbols of that package. If any of the symbols is already accessible as an external symbol of package, export has no effect on that symbol. If the symbol is present in package as an internal symbol, it is simply changed to external status. If it is accessible as an internal symbol via use-package, it is first imported into package, then exported. (The symbol is then present in the package whether or not package continues to use the package through which the symbol was originally inherited.) export makes each symbol accessible to all the packages that use package. All of these packages are checked for name conflicts: (export s p) does (find-symbol (symbol-name s) q) for each package q in (package-used-by-list p). Note that in the usual case of an export during the initial definition of a package, the result of package-used-by-list is nil and the name-conflict checking takes negligible time. When multiple changes are to be made, for example when export is given a list of symbols, it is permissible for the implementation to process each change separately, so that aborting from a name conflict caused by any but the first symbol in the list does not unexport the first symbol in the list. However, aborting from a name-conflict error caused by export of one of symbols does not leave that symbol accessible to some packages and inaccessible to others; with respect to each of symbols processed, export behaves as if it were as an atomic operation. A name conflict in export between one of symbols being exported and a symbol already present in a package that would inherit the newly-exported symbol may be resolved in favor of the exported symbol by uninterning the other one, or in favor of the already-present symbol by making it a shadowing symbol. Examples:: .......... (make-package 'temp :use nil) => # (use-package 'temp) => T (intern "TEMP-SYM" 'temp) => TEMP::TEMP-SYM, NIL (find-symbol "TEMP-SYM") => NIL, NIL (export (find-symbol "TEMP-SYM" 'temp) 'temp) => T (find-symbol "TEMP-SYM") => TEMP-SYM, :INHERITED Side Effects:: .............. The package system is modified. Affected By:: ............. Accessible symbols. Exceptional Situations:: ........................ If any of the symbols is not accessible at all in package, an error of type package-error is signaled that is correctable by permitting the user to interactively specify whether that symbol should be imported. See Also:: .......... *note import:: , *note unexport:: , *note Package Concepts::  File: gcl.info, Node: find-symbol, Next: find-package, Prev: export, Up: Packages Dictionary 11.2.3 find-symbol [Function] ----------------------------- 'find-symbol' string &optional package => symbol, status Arguments and Values:: ...................... string--a string. package--a package designator. The default is the current package. symbol--a symbol accessible in the package, or nil. status--one of :inherited, :external, :internal, or nil. Description:: ............. find-symbol locates a symbol whose name is string in a package. If a symbol named string is found in package, directly or by inheritance, the symbol found is returned as the first value; the second value is as follows: :internal If the symbol is present in package as an internal symbol. :external If the symbol is present in package as an external symbol. :inherited If the symbol is inherited by package through use-package, but is not present in package. If no such symbol is accessible in package, both values are nil. Examples:: .......... (find-symbol "NEVER-BEFORE-USED") => NIL, NIL (find-symbol "NEVER-BEFORE-USED") => NIL, NIL (intern "NEVER-BEFORE-USED") => NEVER-BEFORE-USED, NIL (intern "NEVER-BEFORE-USED") => NEVER-BEFORE-USED, :INTERNAL (find-symbol "NEVER-BEFORE-USED") => NEVER-BEFORE-USED, :INTERNAL (find-symbol "never-before-used") => NIL, NIL (find-symbol "CAR" 'common-lisp-user) => CAR, :INHERITED (find-symbol "CAR" 'common-lisp) => CAR, :EXTERNAL (find-symbol "NIL" 'common-lisp-user) => NIL, :INHERITED (find-symbol "NIL" 'common-lisp) => NIL, :EXTERNAL (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '()) (intern "NIL" "JUST-TESTING"))) => JUST-TESTING::NIL, :INTERNAL (export 'just-testing::nil 'just-testing) (find-symbol "NIL" 'just-testing) => JUST-TESTING:NIL, :EXTERNAL (find-symbol "NIL" "KEYWORD") => NIL, NIL OR=> :NIL, :EXTERNAL (find-symbol (symbol-name :nil) "KEYWORD") => :NIL, :EXTERNAL Affected By:: ............. intern, import, export, use-package, unintern, unexport, unuse-package See Also:: .......... *note intern:: , *note find-all-symbols:: Notes:: ....... find-symbol is operationally equivalent to intern, except that it never creates a new symbol.  File: gcl.info, Node: find-package, Next: find-all-symbols, Prev: find-symbol, Up: Packages Dictionary 11.2.4 find-package [Function] ------------------------------ 'find-package' name => package Arguments and Values:: ...................... name--a string designator or a package object. package--a package object or nil. Description:: ............. If name is a string designator, find-package locates and returns the package whose name or nickname is name. This search is case sensitive. If there is no such package, find-package returns nil. If name is a package object, that package object is returned. Examples:: .......... (find-package 'common-lisp) => # (find-package "COMMON-LISP-USER") => # (find-package 'not-there) => NIL Affected By:: ............. The set of packages created by the implementation. defpackage, delete-package, make-package, rename-package See Also:: .......... *note make-package::  File: gcl.info, Node: find-all-symbols, Next: import, Prev: find-package, Up: Packages Dictionary 11.2.5 find-all-symbols [Function] ---------------------------------- 'find-all-symbols' string => symbols Arguments and Values:: ...................... string--a string designator. symbols--a list of symbols. Description:: ............. find-all-symbols searches every registered package for symbols that have a name that is the same (under string=) as string. A list of all such symbols is returned. Whether or how the list is ordered is implementation-dependent. Examples:: .......... (find-all-symbols 'car) => (CAR) OR=> (CAR VEHICLES:CAR) OR=> (VEHICLES:CAR CAR) (intern "CAR" (make-package 'temp :use nil)) => TEMP::CAR, NIL (find-all-symbols 'car) => (TEMP::CAR CAR) OR=> (CAR TEMP::CAR) OR=> (TEMP::CAR CAR VEHICLES:CAR) OR=> (CAR TEMP::CAR VEHICLES:CAR) See Also:: .......... *note find-symbol::  File: gcl.info, Node: import, Next: list-all-packages, Prev: find-all-symbols, Up: Packages Dictionary 11.2.6 import [Function] ------------------------ 'import' symbols &optional package => t Arguments and Values:: ...................... symbols--a designator for a list of symbols. package--a package designator. The default is the current package. Description:: ............. import adds symbol or symbols to the internals of package, checking for name conflicts with existing symbols either present in package or accessible to it. Once the symbols have been imported, they may be referenced in the importing package without the use of a package prefix when using the Lisp reader. A name conflict in import between the symbol being imported and a symbol inherited from some other package can be resolved in favor of the symbol being imported by making it a shadowing symbol, or in favor of the symbol already accessible by not doing the import. A name conflict in import with a symbol already present in the package may be resolved by uninterning that symbol, or by not doing the import. The imported symbol is not automatically exported from the current package, but if it is already present and external, then the fact that it is external is not changed. If any symbol to be imported has no home package (i.e., (symbol-package symbol) => nil), import sets the home package of the symbol to package. If the symbol is already present in the importing package, import has no effect. Examples:: .......... (import 'common-lisp::car (make-package 'temp :use nil)) => T (find-symbol "CAR" 'temp) => CAR, :INTERNAL (find-symbol "CDR" 'temp) => NIL, NIL The form (import 'editor:buffer) takes the external symbol named buffer in the EDITOR package (this symbol was located when the form was read by the Lisp reader) and adds it to the current package as an internal symbol. The symbol buffer is then present in the current package. Side Effects:: .............. The package system is modified. Affected By:: ............. Current state of the package system. Exceptional Situations:: ........................ import signals a correctable error of type package-error if any of the symbols to be imported has the same name (under string=) as some distinct symbol (under eql) already accessible in the package, even if the conflict is with a shadowing symbol of the package. See Also:: .......... *note shadow:: , *note export::  File: gcl.info, Node: list-all-packages, Next: rename-package, Prev: import, Up: Packages Dictionary 11.2.7 list-all-packages [Function] ----------------------------------- 'list-all-packages' => packages Arguments and Values:: ...................... packages--a list of package objects. Description:: ............. list-all-packages returns a fresh list of all registered packages. Examples:: .......... (let ((before (list-all-packages))) (make-package 'temp) (set-difference (list-all-packages) before)) => (#) Affected By:: ............. defpackage, delete-package, make-package  File: gcl.info, Node: rename-package, Next: shadow, Prev: list-all-packages, Up: Packages Dictionary 11.2.8 rename-package [Function] -------------------------------- 'rename-package' package new-name &optional new-nicknames => package-object Arguments and Values:: ...................... package--a package designator. new-name--a package designator. new-nicknames--a list of string designators. The default is the empty list. package-object--the renamed package object. Description:: ............. Replaces the name and nicknames of package. The old name and all of the old nicknames of package are eliminated and are replaced by new-name and new-nicknames. The consequences are undefined if new-name or any new-nickname conflicts with any existing package names. Examples:: .......... (make-package 'temporary :nicknames '("TEMP")) => # (rename-package 'temp 'ephemeral) => # (package-nicknames (find-package 'ephemeral)) => () (find-package 'temporary) => NIL (rename-package 'ephemeral 'temporary '(temp fleeting)) => # (package-nicknames (find-package 'temp)) => ("TEMP" "FLEETING") See Also:: .......... *note make-package::  File: gcl.info, Node: shadow, Next: shadowing-import, Prev: rename-package, Up: Packages Dictionary 11.2.9 shadow [Function] ------------------------ 'shadow' symbol-names &optional package => t Arguments and Values:: ...................... symbol-names--a designator for a list of string designators. package--a package designator. The default is the current package. Description:: ............. shadow assures that symbols with names given by symbol-names are present in the package. Specifically, package is searched for symbols with the names supplied by symbol-names. For each such name, if a corresponding symbol is not present in package (directly, not by inheritance), then a corresponding symbol is created with that name, and inserted into package as an internal symbol. The corresponding symbol, whether pre-existing or newly created, is then added, if not already present, to the shadowing symbols list of package. Examples:: .......... (package-shadowing-symbols (make-package 'temp)) => NIL (find-symbol 'car 'temp) => CAR, :INHERITED (shadow 'car 'temp) => T (find-symbol 'car 'temp) => TEMP::CAR, :INTERNAL (package-shadowing-symbols 'temp) => (TEMP::CAR) (make-package 'test-1) => # (intern "TEST" (find-package 'test-1)) => TEST-1::TEST, NIL (shadow 'test-1::test (find-package 'test-1)) => T (shadow 'TEST (find-package 'test-1)) => T (assert (not (null (member 'test-1::test (package-shadowing-symbols (find-package 'test-1)))))) (make-package 'test-2) => # (intern "TEST" (find-package 'test-2)) => TEST-2::TEST, NIL (export 'test-2::test (find-package 'test-2)) => T (use-package 'test-2 (find-package 'test-1)) ;should not error Side Effects:: .............. shadow changes the state of the package system in such a way that the package consistency rules do not hold across the change. Affected By:: ............. Current state of the package system. See Also:: .......... *note package-shadowing-symbols:: , *note Package Concepts:: Notes:: ....... If a symbol with a name in symbol-names already exists in package, but by inheritance, the inherited symbol becomes shadowed_3 by a newly created internal symbol.  File: gcl.info, Node: shadowing-import, Next: delete-package, Prev: shadow, Up: Packages Dictionary 11.2.10 shadowing-import [Function] ----------------------------------- 'shadowing-import' symbols &optional package => t Arguments and Values:: ...................... symbols--a designator for a list of symbols. package --a package designator. The default is the current package. Description:: ............. shadowing-import is like import, but it does not signal an error even if the importation of a symbol would shadow some symbol already accessible in package. shadowing-import inserts each of symbols into package as an internal symbol, regardless of whether another symbol of the same name is shadowed by this action. If a different symbol of the same name is already present in package, that symbol is first uninterned from package. The new symbol is added to package's shadowing-symbols list. shadowing-import does name-conflict checking to the extent that it checks whether a distinct existing symbol with the same name is accessible; if so, it is shadowed by the new symbol, which implies that it must be uninterned if it was present in package. Examples:: .......... (in-package "COMMON-LISP-USER") => # (setq sym (intern "CONFLICT")) => CONFLICT (intern "CONFLICT" (make-package 'temp)) => TEMP::CONFLICT, NIL (package-shadowing-symbols 'temp) => NIL (shadowing-import sym 'temp) => T (package-shadowing-symbols 'temp) => (CONFLICT) Side Effects:: .............. shadowing-import changes the state of the package system in such a way that the consistency rules do not hold across the change. package's shadowing-symbols list is modified. Affected By:: ............. Current state of the package system. See Also:: .......... *note import:: , *note unintern:: , *note package-shadowing-symbols::  File: gcl.info, Node: delete-package, Next: make-package, Prev: shadowing-import, Up: Packages Dictionary 11.2.11 delete-package [Function] --------------------------------- 'delete-package' package => generalized-boolean Arguments and Values:: ...................... package--a package designator. generalized-boolean--a generalized boolean. Description:: ............. delete-package deletes package from all package system data structures. If the operation is successful, delete-package returns true, otherwise nil. The effect of delete-package is that the name and nicknames of package cease to be recognized package names. The package object is still a package (i.e., packagep is true of it) but package-name returns nil. The consequences of deleting the COMMON-LISP package or the KEYWORD package are undefined. The consequences of invoking any other package operation on package once it has been deleted are unspecified. In particular, the consequences of invoking find-symbol, intern and other functions that look for a symbol name in a package are unspecified if they are called with *package* bound to the deleted package or with the deleted package as an argument. If package is a package object that has already been deleted, delete-package immediately returns nil. After this operation completes, the home package of any symbol whose home package had previously been package is implementation-dependent. Except for this, symbols accessible in package are not modified in any other way; symbols whose home package is not package remain unchanged. Examples:: .......... (setq *foo-package* (make-package "FOO" :use nil)) (setq *foo-symbol* (intern "FOO" *foo-package*)) (export *foo-symbol* *foo-package*) (setq *bar-package* (make-package "BAR" :use '("FOO"))) (setq *bar-symbol* (intern "BAR" *bar-package*)) (export *foo-symbol* *bar-package*) (export *bar-symbol* *bar-package*) (setq *baz-package* (make-package "BAZ" :use '("BAR"))) (symbol-package *foo-symbol*) => # (symbol-package *bar-symbol*) => # (prin1-to-string *foo-symbol*) => "FOO:FOO" (prin1-to-string *bar-symbol*) => "BAR:BAR" (find-symbol "FOO" *bar-package*) => FOO:FOO, :EXTERNAL (find-symbol "FOO" *baz-package*) => FOO:FOO, :INHERITED (find-symbol "BAR" *baz-package*) => BAR:BAR, :INHERITED (packagep *foo-package*) => true (packagep *bar-package*) => true (packagep *baz-package*) => true (package-name *foo-package*) => "FOO" (package-name *bar-package*) => "BAR" (package-name *baz-package*) => "BAZ" (package-use-list *foo-package*) => () (package-use-list *bar-package*) => (#) (package-use-list *baz-package*) => (#) (package-used-by-list *foo-package*) => (#) (package-used-by-list *bar-package*) => (#) (package-used-by-list *baz-package*) => () (delete-package *bar-package*) |> Error: Package BAZ uses package BAR. |> If continued, BAZ will be made to unuse-package BAR, |> and then BAR will be deleted. |> Type :CONTINUE to continue. |> Debug> |>>:CONTINUE<<| => T (symbol-package *foo-symbol*) => # (symbol-package *bar-symbol*) is unspecified (prin1-to-string *foo-symbol*) => "FOO:FOO" (prin1-to-string *bar-symbol*) is unspecified (find-symbol "FOO" *bar-package*) is unspecified (find-symbol "FOO" *baz-package*) => NIL, NIL (find-symbol "BAR" *baz-package*) => NIL, NIL (packagep *foo-package*) => T (packagep *bar-package*) => T (packagep *baz-package*) => T (package-name *foo-package*) => "FOO" (package-name *bar-package*) => NIL (package-name *baz-package*) => "BAZ" (package-use-list *foo-package*) => () (package-use-list *bar-package*) is unspecified (package-use-list *baz-package*) => () (package-used-by-list *foo-package*) => () (package-used-by-list *bar-package*) is unspecified (package-used-by-list *baz-package*) => () Exceptional Situations:: ........................ If the package designator is a name that does not currently name a package, a correctable error of type package-error is signaled. If correction is attempted, no deletion action is attempted; instead, delete-package immediately returns nil. If package is used by other packages, a correctable error of type package-error is signaled. If correction is attempted, unuse-package is effectively called to remove any dependencies, causing package's external symbols to cease being accessible to those packages that use package. delete-package then deletes package just as it would have had there been no packages that used it. See Also:: .......... *note unuse-package::  File: gcl.info, Node: make-package, Next: with-package-iterator, Prev: delete-package, Up: Packages Dictionary 11.2.12 make-package [Function] ------------------------------- 'make-package' package-name &key nicknames use => package Arguments and Values:: ...................... package-name--a string designator. nicknames--a list of string designators. The default is the empty list. use-- a list of package designators. The default is implementation-defined. package--a package. Description:: ............. Creates a new package with the name package-name. Nicknames are additional names which may be used to refer to the new package. use specifies zero or more packages the external symbols of which are to be inherited by the new package. See the function use-package. Examples:: .......... (make-package 'temporary :nicknames '("TEMP" "temp")) => # (make-package "OWNER" :use '("temp")) => # (package-used-by-list 'temp) => (#) (package-use-list 'owner) => (#) Affected By:: ............. The existence of other packages in the system. Exceptional Situations:: ........................ The consequences are unspecified if packages denoted by use do not exist. A correctable error is signaled if the package-name or any of the nicknames is already the name or nickname of an existing package. See Also:: .......... *note defpackage:: , *note use-package:: Notes:: ....... In situations where the packages to be used contain symbols which would conflict, it is necessary to first create the package with :use '(), then to use shadow or shadowing-import to address the conflicts, and then after that to use use-package once the conflicts have been addressed. When packages are being created as part of the static definition of a program rather than dynamically by the program, it is generally considered more stylistically appropriate to use defpackage rather than make-package.  File: gcl.info, Node: with-package-iterator, Next: unexport, Prev: make-package, Up: Packages Dictionary 11.2.13 with-package-iterator [Macro] ------------------------------------- 'with-package-iterator' (name package-list-form &rest symbol-types) {declaration}* {form}* => {result}* Arguments and Values:: ...................... name--a symbol. package-list-form--a form; evaluated once to produce a package-list. package-list--a designator for a list of package designators. symbol-type--one of the symbols :internal, :external, or :inherited. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values of the forms. Description:: ............. Within the lexical scope of the body forms, the name is defined via macrolet such that successive invocations of (name) will return the symbols, one by one, from the packages in package-list. It is unspecified whether symbols inherited from multiple packages are returned more than once. The order of symbols returned does not necessarily reflect the order of packages in package-list. When package-list has more than one element, it is unspecified whether duplicate symbols are returned once or more than once. Symbol-types controls which symbols that are accessible in a package are returned as follows: :internal The symbols that are present in the package, but that are not exported. :external The symbols that are present in the package and are exported. :inherited The symbols that are exported by used packages and that are not shadowed. When more than one argument is supplied for symbol-types, a symbol is returned if its accessibility matches any one of the symbol-types supplied. Implementations may extend this syntax by recognizing additional symbol accessibility types. An invocation of (name) returns four values as follows: 1. A flag that indicates whether a symbol is returned (true means that a symbol is returned). 2. A symbol that is accessible in one the indicated packages. 3. The accessibility type for that symbol; i.e., one of the symbols :internal, :external, or :inherited. 4. The package from which the symbol was obtained. The package is one of the packages present or named in package-list. After all symbols have been returned by successive invocations of (name), then only one value is returned, namely nil. The meaning of the second, third, and fourth values is that the returned symbol is accessible in the returned package in the way indicated by the second return value as follows: :internal Means present and not exported. :external Means present and exported. :inherited Means not present (thus not shadowed) but inherited from some used package. It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the with-package-iterator form such as by returning some closure over the invocation form. Any number of invocations of with-package-iterator can be nested, and the body of the innermost one can invoke all of the locally established macros, provided all those macros have distinct names. Examples:: .......... The following function should return t on any package, and signal an error if the usage of with-package-iterator does not agree with the corresponding usage of do-symbols. (defun test-package-iterator (package) (unless (packagep package) (setq package (find-package package))) (let ((all-entries '()) (generated-entries '())) (do-symbols (x package) (multiple-value-bind (symbol accessibility) (find-symbol (symbol-name x) package) (push (list symbol accessibility) all-entries))) (with-package-iterator (generator-fn package :internal :external :inherited) (loop (multiple-value-bind (more? symbol accessibility pkg) (generator-fn) (unless more? (return)) (let ((l (multiple-value-list (find-symbol (symbol-name symbol) package)))) (unless (equal l (list symbol accessibility)) (error "Symbol ~S not found as ~S in package ~A [~S]" symbol accessibility (package-name package) l)) (push l generated-entries))))) (unless (and (subsetp all-entries generated-entries :test #'equal) (subsetp generated-entries all-entries :test #'equal)) (error "Generated entries and Do-Symbols entries don't correspond")) t)) The following function prints out every present symbol (possibly more than once): (defun print-all-symbols () (with-package-iterator (next-symbol (list-all-packages) :internal :external) (loop (multiple-value-bind (more? symbol) (next-symbol) (if more? (print symbol) (return)))))) Exceptional Situations:: ........................ with-package-iterator signals an error of type program-error if no symbol-types are supplied or if a symbol-type is not recognized by the implementation is supplied. The consequences are undefined if the local function named name established by with-package-iterator is called after it has returned false as its primary value. See Also:: .......... *note Traversal Rules and Side Effects::  File: gcl.info, Node: unexport, Next: unintern, Prev: with-package-iterator, Up: Packages Dictionary 11.2.14 unexport [Function] --------------------------- 'unexport' symbols &optional package => t Arguments and Values:: ...................... symbols--a designator for a list of symbols. package--a package designator. The default is the current package. Description:: ............. unexport reverts external symbols in package to internal status; it undoes the effect of export. unexport works only on symbols present in package, switching them back to internal status. If unexport is given a symbol that is already accessible as an internal symbol in package, it does nothing. Examples:: .......... (in-package "COMMON-LISP-USER") => # (export (intern "CONTRABAND" (make-package 'temp)) 'temp) => T (find-symbol "CONTRABAND") => NIL, NIL (use-package 'temp) => T (find-symbol "CONTRABAND") => CONTRABAND, :INHERITED (unexport 'contraband 'temp) => T (find-symbol "CONTRABAND") => NIL, NIL Side Effects:: .............. Package system is modified. Affected By:: ............. Current state of the package system. Exceptional Situations:: ........................ If unexport is given a symbol not accessible in package at all, an error of type package-error is signaled. The consequences are undefined if package is the KEYWORD package or the COMMON-LISP package. See Also:: .......... *note export:: , *note Package Concepts::  File: gcl.info, Node: unintern, Next: in-package, Prev: unexport, Up: Packages Dictionary 11.2.15 unintern [Function] --------------------------- 'unintern' symbol &optional package => generalized-boolean Arguments and Values:: ...................... symbol--a symbol. package--a package designator. The default is the current package. generalized-boolean--a generalized boolean. Description:: ............. unintern removes symbol from package. If symbol is present in package, it is removed from package and also from package's shadowing symbols list if it is present there. If package is the home package for symbol, symbol is made to have no home package. Symbol may continue to be accessible in package by inheritance. Use of unintern can result in a symbol that has no recorded home package, but that in fact is accessible in some package. Common Lisp does not check for this pathological case, and such symbols are always printed preceded by #:. unintern returns true if it removes symbol, and nil otherwise. Examples:: .......... (in-package "COMMON-LISP-USER") => # (setq temps-unpack (intern "UNPACK" (make-package 'temp))) => TEMP::UNPACK (unintern temps-unpack 'temp) => T (find-symbol "UNPACK" 'temp) => NIL, NIL temps-unpack => #:UNPACK Side Effects:: .............. unintern changes the state of the package system in such a way that the consistency rules do not hold across the change. Affected By:: ............. Current state of the package system. Exceptional Situations:: ........................ Giving a shadowing symbol to unintern can uncover a name conflict that had previously been resolved by the shadowing. If package A uses packages B and C, A contains a shadowing symbol x, and B and C each contain external symbols named x, then removing the shadowing symbol x from A will reveal a name conflict between b:x and c:x if those two symbols are distinct. In this case unintern will signal an error. See Also:: .......... *note Package Concepts::  File: gcl.info, Node: in-package, Next: unuse-package, Prev: unintern, Up: Packages Dictionary 11.2.16 in-package [Macro] -------------------------- 'in-package' name => package Arguments and Values:: ...................... name--a string designator; not evaluated. package--the package named by name. Description:: ............. Causes the the package named by name to become the current package--that is, the value of *package*. If no such package already exists, an error of type package-error is signaled. Everything in-package does is also performed at compile time if the call appears as a top level form. Side Effects:: .............. The variable *package* is assigned. If the in-package form is a top level form, this assignment also occurs at compile time. Exceptional Situations:: ........................ An error of type package-error is signaled if the specified package does not exist. See Also:: .......... *note package::  File: gcl.info, Node: unuse-package, Next: use-package, Prev: in-package, Up: Packages Dictionary 11.2.17 unuse-package [Function] -------------------------------- 'unuse-package' packages-to-unuse &optional package => t Arguments and Values:: ...................... packages-to-unuse--a designator for a list of package designators. package--a package designator. The default is the current package. Description:: ............. unuse-package causes package to cease inheriting all the external symbols of packages-to-unuse; unuse-package undoes the effects of use-package. The packages-to-unuse are removed from the use list of package. Any symbols that have been imported into package continue to be present in package. Examples:: .......... (in-package "COMMON-LISP-USER") => # (export (intern "SHOES" (make-package 'temp)) 'temp) => T (find-symbol "SHOES") => NIL, NIL (use-package 'temp) => T (find-symbol "SHOES") => SHOES, :INHERITED (find (find-package 'temp) (package-use-list 'common-lisp-user)) => # (unuse-package 'temp) => T (find-symbol "SHOES") => NIL, NIL Side Effects:: .............. The use list of package is modified. Affected By:: ............. Current state of the package system. See Also:: .......... *note use-package:: , *note package-use-list::  File: gcl.info, Node: use-package, Next: defpackage, Prev: unuse-package, Up: Packages Dictionary 11.2.18 use-package [Function] ------------------------------ 'use-package' packages-to-use &optional package => t Arguments and Values:: ...................... packages-to-use--a designator for a list of package designators. The KEYWORD package may not be supplied. package--a package designator. The KEYWORD package cannot be supplied. The default is the current package. Description:: ............. use-package causes package to inherit all the external symbols of packages-to-use. The inherited symbols become accessible as internal symbols of package. Packages-to-use are added to the use list of package if they are not there already. All external symbols in packages-to-use become accessible in package as internal symbols. use-package does not cause any new symbols to be present in package but only makes them accessible by inheritance. use-package checks for name conflicts between the newly imported symbols and those already accessible in package. A name conflict in use-package between two external symbols inherited by package from packages-to-use may be resolved in favor of either symbol by importing one of them into package and making it a shadowing symbol. Examples:: .......... (export (intern "LAND-FILL" (make-package 'trash)) 'trash) => T (find-symbol "LAND-FILL" (make-package 'temp)) => NIL, NIL (package-use-list 'temp) => (#) (use-package 'trash 'temp) => T (package-use-list 'temp) => (# #) (find-symbol "LAND-FILL" 'temp) => TRASH:LAND-FILL, :INHERITED Side Effects:: .............. The use list of package may be modified. See Also:: .......... *note unuse-package:: , *note package-use-list:: , *note Package Concepts:: Notes:: ....... It is permissible for a package P_1 to use a package P_2 even if P_2 already uses P_1. The using of packages is not transitive, so no problem results from the apparent circularity.  File: gcl.info, Node: defpackage, Next: do-symbols, Prev: use-package, Up: Packages Dictionary 11.2.19 defpackage [Macro] -------------------------- 'defpackage' defined-package-name [[!option]] => package option ::={(:nicknames {nickname}*)}* | (:documentation string) | {(:use {package-name}*)}* | {(:shadow {!symbol-name}*)}* | {(:shadowing-import-from package-name {!symbol-name}*)}* | {(:import-from package-name {!symbol-name}*)}* | {(:export {!symbol-name}*)}* | {(:intern {!symbol-name}*)}* | (:size integer) symbol-name ::=(symbol | string) Arguments and Values:: ...................... defined-package-name--a string designator. package-name--a package designator. nickname--a string designator. symbol-name--a string designator. package--the package named package-name. Description:: ............. defpackage creates a package as specified and returns the package. If defined-package-name already refers to an existing package, the name-to-package mapping for that name is not changed. If the new definition is at variance with the current state of that package, the consequences are undefined; an implementation might choose to modify the existing package to reflect the new definition. If defined-package-name is a symbol, its name is used. The standard options are described below. :nicknames The arguments to :nicknames set the package's nicknames to the supplied names. :documentation The argument to :documentation specifies a documentation string; it is attached as a documentation string to the package. At most one :documentation option can appear in a single defpackage form. :use The arguments to :use set the packages that the package named by package-name will inherit from. If :use is not supplied, it defaults to the same implementation-dependent value as the :use argument to make-package. :shadow The arguments to :shadow, symbol-names, name symbols that are to be created in the package being defined. These symbols are added to the list of shadowing symbols effectively as if by shadow. :shadowing-import-from The symbols named by the argument symbol-names are found (involving a lookup as if by find-symbol) in the specified package-name. The resulting symbols are imported into the package being defined, and placed on the shadowing symbols list as if by shadowing-import. In no case are symbols created in any package other than the one being defined. :import-from The symbols named by the argument symbol-names are found in the package named by package-name and they are imported into the package being defined. In no case are symbols created in any package other than the one being defined. :export The symbols named by the argument symbol-names are found or created in the package being defined and exported. The :export option interacts with the :use option, since inherited symbols can be used rather than new ones created. The :export option interacts with the :import-from and :shadowing-import-from options, since imported symbols can be used rather than new ones created. If an argument to the :export option is accessible as an (inherited) internal symbol via use-package, that the symbol named by symbol-name is first imported into the package being defined, and is then exported from that package. :intern The symbols named by the argument symbol-names are found or created in the package being defined. The :intern option interacts with the :use option, since inherited symbols can be used rather than new ones created. :size The argument to the :size option declares the approximate number of symbols expected in the package. This is an efficiency hint only and might be ignored by an implementation. The order in which the options appear in a defpackage form is irrelevant. The order in which they are executed is as follows: 1. :shadow and :shadowing-import-from. 2. :use. 3. :import-from and :intern. 4. :export. Shadows are established first, since they might be necessary to block spurious name conflicts when the :use option is processed. The :use option is executed next so that :intern and :export options can refer to normally inherited symbols. The :export option is executed last so that it can refer to symbols created by any of the other options; in particular, shadowing symbols and imported symbols can be made external. If a defpackage form appears as a top level form, all of the actions normally performed by this macro at load time must also be performed at compile time. Examples:: .......... (defpackage "MY-PACKAGE" (:nicknames "MYPKG" "MY-PKG") (:use "COMMON-LISP") (:shadow "CAR" "CDR") (:shadowing-import-from "VENDOR-COMMON-LISP" "CONS") (:import-from "VENDOR-COMMON-LISP" "GC") (:export "EQ" "CONS" "FROBOLA") ) (defpackage my-package (:nicknames mypkg :MY-PKG) ; remember Common Lisp conventions for case (:use common-lisp) ; conversion on symbols (:shadow CAR :cdr #:cons) (:export "CONS") ; this is the shadowed one. ) Affected By:: ............. Existing packages. Exceptional Situations:: ........................ If one of the supplied :nicknames already refers to an existing package, an error of type package-error is signaled. An error of type program-error should be signaled if :size or :documentation appears more than once. Since implementations might allow extended options an error of type program-error should be signaled if an option is present that is not actually supported in the host implementation. The collection of symbol-name arguments given to the options :shadow, :intern, :import-from, and :shadowing-import-from must all be disjoint; additionally, the symbol-name arguments given to :export and :intern must be disjoint. Disjoint in this context is defined as no two of the symbol-names being string= with each other. If either condition is violated, an error of type program-error should be signaled. For the :shadowing-import-from and :import-from options, a correctable error of type package-error is signaled if no symbol is accessible in the package named by package-name for one of the argument symbol-names. Name conflict errors are handled by the underlying calls to make-package, use-package, import, and export. See *note Package Concepts::. See Also:: .......... *note documentation:: , *note Package Concepts::, *note Compilation:: Notes:: ....... The :intern option is useful if an :import-from or a :shadowing-import-from option in a subsequent call to defpackage (for some other package) expects to find these symbols accessible but not necessarily external. It is recommended that the entire package definition is put in a single place, and that all the package definitions of a program are in a single file. This file can be loaded before loading or compiling anything else that depends on those packages. Such a file can be read in the COMMON-LISP-USER package, avoiding any initial state issues. defpackage cannot be used to create two "mutually recursive" packages, such as: (defpackage my-package (:use common-lisp your-package) ;requires your-package to exist first (:export "MY-FUN")) (defpackage your-package (:use common-lisp) (:import-from my-package "MY-FUN") ;requires my-package to exist first (:export "MY-FUN")) However, nothing prevents the user from using the package-affecting functions such as use-package, import, and export to establish such links after a more standard use of defpackage. The macroexpansion of defpackage could usefully canonicalize the names into strings, so that even if a source file has random symbols in the defpackage form, the compiled file would only contain strings. Frequently additional implementation-dependent options take the form of a keyword standing by itself as an abbreviation for a list (keyword T); this syntax should be properly reported as an unrecognized option in implementations that do not support it.  File: gcl.info, Node: do-symbols, Next: intern, Prev: defpackage, Up: Packages Dictionary 11.2.20 do-symbols, do-external-symbols, do-all-symbols [Macro] --------------------------------------------------------------- 'do-symbols' (var [package [result-form]]) {declaration}* {tag | statement}* => {result}* 'do-external-symbols' (var [package [result-form]]) {declaration}* {tag | statement}* => {result}* 'do-all-symbols' (var [result-form]) {declaration}* {tag | statement}* => {result}* Arguments and Values:: ...................... var--a variable name; not evaluated. package--a package designator; evaluated. The default in do-symbols and do-external-symbols is the current package. result-form--a form; evaluated as described below. The default is nil. declaration--a declare expression; not evaluated. tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. results--the values returned by the result-form if a normal return occurs, or else, if an explicit return occurs, the values that were transferred. Description:: ............. do-symbols, do-external-symbols, and do-all-symbols iterate over the symbols of packages. For each symbol in the set of packages chosen, the var is bound to the symbol, and the statements in the body are executed. When all the symbols have been processed, result-form is evaluated and returned as the value of the macro. do-symbols iterates over the symbols accessible in package. Statements may execute more than once for symbols that are inherited from multiple packages. do-all-symbols iterates on every registered package. do-all-symbols will not process every symbol whatsoever, because a symbol not accessible in any registered package will not be processed. do-all-symbols may cause a symbol that is present in several packages to be processed more than once. do-external-symbols iterates on the external symbols of package. When result-form is evaluated, var is bound and has the value nil. An implicit block named nil surrounds the entire do-symbols, do-external-symbols, or do-all-symbols form. return or return-from may be used to terminate the iteration prematurely. If execution of the body affects which symbols are contained in the set of packages over which iteration is occurring, other than to remove the symbol currently the value of var by using unintern, the consequences are undefined. For each of these macros, the scope of the name binding does not include any initial value form, but the optional result forms are included. Any tag in the body is treated as with tagbody. Examples:: .......... (make-package 'temp :use nil) => # (intern "SHY" 'temp) => TEMP::SHY, NIL ;SHY will be an internal symbol ;in the package TEMP (export (intern "BOLD" 'temp) 'temp) => T ;BOLD will be external (let ((lst ())) (do-symbols (s (find-package 'temp)) (push s lst)) lst) => (TEMP::SHY TEMP:BOLD) OR=> (TEMP:BOLD TEMP::SHY) (let ((lst ())) (do-external-symbols (s (find-package 'temp) lst) (push s lst)) lst) => (TEMP:BOLD) (let ((lst ())) (do-all-symbols (s lst) (when (eq (find-package 'temp) (symbol-package s)) (push s lst))) lst) => (TEMP::SHY TEMP:BOLD) OR=> (TEMP:BOLD TEMP::SHY) See Also:: .......... *note intern:: , *note export:: , *note Traversal Rules and Side Effects::  File: gcl.info, Node: intern, Next: package-name, Prev: do-symbols, Up: Packages Dictionary 11.2.21 intern [Function] ------------------------- 'intern' string &optional package => symbol, status Arguments and Values:: ...................... string--a string. package--a package designator. The default is the current package. symbol--a symbol. status--one of :inherited, :external, :internal, or nil. Description:: ............. intern enters a symbol named string into package. If a symbol whose name is the same as string is already accessible in package, it is returned. If no such symbol is accessible in package, a new symbol with the given name is created and entered into package as an internal symbol, or as an external symbol if the package is the KEYWORD package; package becomes the home package of the created symbol. The first value returned by intern, symbol, is the symbol that was found or created. The meaning of the secondary value, status, is as follows: :internal The symbol was found and is present in package as an internal symbol. :external The symbol was found and is present as an external symbol. :inherited The symbol was found and is inherited via use-package (which implies that the symbol is internal). nil No pre-existing symbol was found, so one was created. It is implementation-dependent whether the string that becomes the new symbol's name is the given string or a copy of it. Once a string has been given as the string argument to intern in this situation where a new symbol is created, the consequences are undefined if a subsequent attempt is made to alter that string. Examples:: .......... (in-package "COMMON-LISP-USER") => # (intern "Never-Before") => |Never-Before|, NIL (intern "Never-Before") => |Never-Before|, :INTERNAL (intern "NEVER-BEFORE" "KEYWORD") => :NEVER-BEFORE, NIL (intern "NEVER-BEFORE" "KEYWORD") => :NEVER-BEFORE, :EXTERNAL See Also:: .......... *note find-symbol:: , *note read:: , symbol, *note unintern:: , *note Symbols as Tokens:: Notes:: ....... intern does not need to do any name conflict checking because it never creates a new symbol if there is already an accessible symbol with the name given.  File: gcl.info, Node: package-name, Next: package-nicknames, Prev: intern, Up: Packages Dictionary 11.2.22 package-name [Function] ------------------------------- 'package-name' package => name Arguments and Values:: ...................... package--a package designator. name--a string or nil. Description:: ............. package-name returns the string that names package, or nil if the package designator is a package object that has no name (see the function delete-package). Examples:: .......... (in-package "COMMON-LISP-USER") => # (package-name *package*) => "COMMON-LISP-USER" (package-name (symbol-package :test)) => "KEYWORD" (package-name (find-package 'common-lisp)) => "COMMON-LISP" (defvar *foo-package* (make-package "FOO")) (rename-package "FOO" "FOO0") (package-name *foo-package*) => "FOO0" Exceptional Situations:: ........................ Should signal an error of type type-error if package is not a package designator.  File: gcl.info, Node: package-nicknames, Next: package-shadowing-symbols, Prev: package-name, Up: Packages Dictionary 11.2.23 package-nicknames [Function] ------------------------------------ 'package-nicknames' package => nicknames Arguments and Values:: ...................... package--a package designator. nicknames--a list of strings. Description:: ............. Returns the list of nickname strings for package, not including the name of package. Examples:: .......... (package-nicknames (make-package 'temporary :nicknames '("TEMP" "temp"))) => ("temp" "TEMP") Exceptional Situations:: ........................ Should signal an error of type type-error if package is not a package designator.  File: gcl.info, Node: package-shadowing-symbols, Next: package-use-list, Prev: package-nicknames, Up: Packages Dictionary 11.2.24 package-shadowing-symbols [Function] -------------------------------------------- 'package-shadowing-symbols' package => symbols Arguments and Values:: ...................... package--a package designator. symbols--a list of symbols. Description:: ............. Returns a list of symbols that have been declared as shadowing symbols in package by shadow or shadowing-import (or the equivalent defpackage options). All symbols on this list are present in package. Examples:: .......... (package-shadowing-symbols (make-package 'temp)) => () (shadow 'cdr 'temp) => T (package-shadowing-symbols 'temp) => (TEMP::CDR) (intern "PILL" 'temp) => TEMP::PILL, NIL (shadowing-import 'pill 'temp) => T (package-shadowing-symbols 'temp) => (PILL TEMP::CDR) Exceptional Situations:: ........................ Should signal an error of type type-error if package is not a package designator. See Also:: .......... *note shadow:: , *note shadowing-import:: Notes:: ....... Whether the list of symbols is fresh is implementation-dependent.  File: gcl.info, Node: package-use-list, Next: package-used-by-list, Prev: package-shadowing-symbols, Up: Packages Dictionary 11.2.25 package-use-list [Function] ----------------------------------- 'package-use-list' package => use-list Arguments and Values:: ...................... package--a package designator. use-list--a list of package objects. Description:: ............. Returns a list of other packages used by package. Examples:: .......... (package-use-list (make-package 'temp)) => (#) (use-package 'common-lisp-user 'temp) => T (package-use-list 'temp) => (# #) Exceptional Situations:: ........................ Should signal an error of type type-error if package is not a package designator. See Also:: .......... *note use-package:: , *note unuse-package::  File: gcl.info, Node: package-used-by-list, Next: packagep, Prev: package-use-list, Up: Packages Dictionary 11.2.26 package-used-by-list [Function] --------------------------------------- 'package-used-by-list' package => used-by-list Arguments and Values:: ...................... package--a package designator. used-by-list--a list of package objects. Description:: ............. package-used-by-list returns a list of other packages that use package. Examples:: .......... (package-used-by-list (make-package 'temp)) => () (make-package 'trash :use '(temp)) => # (package-used-by-list 'temp) => (#) Exceptional Situations:: ........................ Should signal an error of type type-error if package is not a package. See Also:: .......... *note use-package:: , *note unuse-package::  File: gcl.info, Node: packagep, Next: *package*, Prev: package-used-by-list, Up: Packages Dictionary 11.2.27 packagep [Function] --------------------------- 'packagep' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type package; otherwise, returns false. Examples:: .......... (packagep *package*) => true (packagep 'common-lisp) => false (packagep (find-package 'common-lisp)) => true Notes:: ....... (packagep object) == (typep object 'package)  File: gcl.info, Node: *package*, Next: package-error, Prev: packagep, Up: Packages Dictionary 11.2.28 *package* [Variable] ---------------------------- Value Type:: ............ a package object. Initial Value:: ............... the COMMON-LISP-USER package. Description:: ............. Whatever package object is currently the value of *package* is referred to as the current package. Examples:: .......... (in-package "COMMON-LISP-USER") => # *package* => # (make-package "SAMPLE-PACKAGE" :use '("COMMON-LISP")) => # (list (symbol-package (let ((*package* (find-package 'sample-package))) (setq *some-symbol* (read-from-string "just-testing")))) *package*) => (# #) (list (symbol-package (read-from-string "just-testing")) *package*) => (# #) (eq 'foo (intern "FOO")) => true (eq 'foo (let ((*package* (find-package 'sample-package))) (intern "FOO"))) => false Affected By:: ............. load, compile-file, in-package See Also:: .......... *note compile-file:: , *note in-package:: , *note load:: , *note package::  File: gcl.info, Node: package-error, Next: package-error-package, Prev: *package*, Up: Packages Dictionary 11.2.29 package-error [Condition Type] -------------------------------------- Class Precedence List:: ....................... package-error, error, serious-condition, condition, t Description:: ............. The type package-error consists of error conditions related to operations on packages. The offending package (or package name) is initialized by the :package initialization argument to make-condition, and is accessed by the function package-error-package. See Also:: .......... *note package-error-package:: , *note Conditions::  File: gcl.info, Node: package-error-package, Prev: package-error, Up: Packages Dictionary 11.2.30 package-error-package [Function] ---------------------------------------- 'package-error-package' condition => package Arguments and Values:: ...................... condition--a condition of type package-error. package--a package designator. Description:: ............. Returns a designator for the offending package in the situation represented by the condition. Examples:: .......... (package-error-package (make-condition 'package-error :package (find-package "COMMON-LISP"))) => # See Also:: .......... package-error  File: gcl.info, Node: Numbers (Numbers), Next: Characters, Prev: Packages, Up: Top 12 Numbers ********** * Menu: * Number Concepts:: * Numbers Dictionary::  File: gcl.info, Node: Number Concepts, Next: Numbers Dictionary, Prev: Numbers (Numbers), Up: Numbers (Numbers) 12.1 Number Concepts ==================== * Menu: * Numeric Operations:: * Implementation-Dependent Numeric Constants:: * Rational Computations:: * Floating-point Computations:: * Complex Computations:: * Interval Designators:: * Random-State Operations::  File: gcl.info, Node: Numeric Operations, Next: Implementation-Dependent Numeric Constants, Prev: Number Concepts, Up: Number Concepts 12.1.1 Numeric Operations ------------------------- Common Lisp provides a large variety of operations related to numbers. This section provides an overview of those operations by grouping them into categories that emphasize some of the relationships among them. Figure 12-1 shows operators relating to arithmetic operations. * 1+ gcd + 1- incf - conjugate lcm / decf Figure 12-1: Operators relating to Arithmetic. Figure 12-2 shows defined names relating to exponential, logarithmic, and trigonometric operations. abs cos signum acos cosh sin acosh exp sinh asin expt sqrt asinh isqrt tan atan log tanh atanh phase cis pi Figure 12-2: Defined names relating to Exponentials, Logarithms, and Trigonometry. Figure 12-3 shows operators relating to numeric comparison and predication. /= >= oddp < evenp plusp <= max zerop = min > minusp Figure 12-3: Operators for numeric comparison and predication. Figure 12-4 shows defined names relating to numeric type manipulation and coercion. ceiling float-radix rational complex float-sign rationalize decode-float floor realpart denominator fround rem fceiling ftruncate round ffloor imagpart scale-float float integer-decode-float truncate float-digits mod float-precision numerator Figure 12-4: Defined names relating to numeric type manipulation and coercion. * Menu: * Associativity and Commutativity in Numeric Operations:: * Examples of Associativity and Commutativity in Numeric Operations:: * Contagion in Numeric Operations:: * Viewing Integers as Bits and Bytes:: * Logical Operations on Integers:: * Byte Operations on Integers::  File: gcl.info, Node: Associativity and Commutativity in Numeric Operations, Next: Examples of Associativity and Commutativity in Numeric Operations, Prev: Numeric Operations, Up: Numeric Operations 12.1.1.1 Associativity and Commutativity in Numeric Operations .............................................................. For functions that are mathematically associative (and possibly commutative), a conforming implementation may process the arguments in any manner consistent with associative (and possibly commutative) rearrangement. This does not affect the order in which the argument forms are evaluated; for a discussion of evaluation order, see *note Function Forms::. What is unspecified is only the order in which the parameter values are processed. This implies that implementations may differ in which automatic coercions are applied; see *note Contagion in Numeric Operations::. A conforming program can control the order of processing explicitly by separating the operations into separate (possibly nested) function forms, or by writing explicit calls to functions that perform coercions.  File: gcl.info, Node: Examples of Associativity and Commutativity in Numeric Operations, Next: Contagion in Numeric Operations, Prev: Associativity and Commutativity in Numeric Operations, Up: Numeric Operations 12.1.1.2 Examples of Associativity and Commutativity in Numeric Operations .......................................................................... Consider the following expression, in which we assume that 1.0 and 1.0e-15 both denote single floats: (+ 1/3 2/3 1.0d0 1.0 1.0e-15) One conforming implementation might process the arguments from left to right, first adding 1/3 and 2/3 to get 1, then converting that to a double float for combination with 1.0d0, then successively converting and adding 1.0 and 1.0e-15. Another conforming implementation might process the arguments from right to left, first performing a single float addition of 1.0 and 1.0e-15 (perhaps losing accuracy in the process), then converting the sum to a double float and adding 1.0d0, then converting 2/3 to a double float and adding it, and then converting 1/3 and adding that. A third conforming implementation might first scan all the arguments, process all the rationals first to keep that part of the computation exact, then find an argument of the largest floating-point format among all the arguments and add that, and then add in all other arguments, converting each in turn (all in a perhaps misguided attempt to make the computation as accurate as possible). In any case, all three strategies are legitimate. A conforming program could control the order by writing, for example, (+ (+ 1/3 2/3) (+ 1.0d0 1.0e-15) 1.0)  File: gcl.info, Node: Contagion in Numeric Operations, Next: Viewing Integers as Bits and Bytes, Prev: Examples of Associativity and Commutativity in Numeric Operations, Up: Numeric Operations 12.1.1.3 Contagion in Numeric Operations ........................................ For information about the contagion rules for implicit coercions of arguments in numeric operations, see *note Rule of Float Precision Contagion::, *note Rule of Float and Rational Contagion::, and *note Rule of Complex Contagion::.  File: gcl.info, Node: Viewing Integers as Bits and Bytes, Next: Logical Operations on Integers, Prev: Contagion in Numeric Operations, Up: Numeric Operations 12.1.1.4 Viewing Integers as Bits and Bytes ...........................................  File: gcl.info, Node: Logical Operations on Integers, Next: Byte Operations on Integers, Prev: Viewing Integers as Bits and Bytes, Up: Numeric Operations 12.1.1.5 Logical Operations on Integers ....................................... Logical operations require integers as arguments; an error of type type-error should be signaled if an argument is supplied that is not an integer. Integer arguments to logical operations are treated as if they were represented in two's-complement notation. Figure 12-5 shows defined names relating to logical operations on numbers. ash boole-ior logbitp boole boole-nand logcount boole-1 boole-nor logeqv boole-2 boole-orc1 logior boole-and boole-orc2 lognand boole-andc1 boole-set lognor boole-andc2 boole-xor lognot boole-c1 integer-length logorc1 boole-c2 logand logorc2 boole-clr logandc1 logtest boole-eqv logandc2 logxor Figure 12-5: Defined names relating to logical operations on numbers.  File: gcl.info, Node: Byte Operations on Integers, Prev: Logical Operations on Integers, Up: Numeric Operations 12.1.1.6 Byte Operations on Integers .................................... The byte-manipulation functions use objects called byte specifiers to designate the size and position of a specific byte within an integer. The representation of a byte specifier is implementation-dependent; it might or might not be a number. The function byte will construct a byte specifier, which various other byte-manipulation functions will accept. Figure 12-6 shows defined names relating to manipulating bytes of numbers. byte deposit-field ldb-test byte-position dpb mask-field byte-size ldb Figure 12-6: Defined names relating to byte manipulation.  File: gcl.info, Node: Implementation-Dependent Numeric Constants, Next: Rational Computations, Prev: Numeric Operations, Up: Number Concepts 12.1.2 Implementation-Dependent Numeric Constants ------------------------------------------------- Figure 12-7 shows defined names relating to implementation-dependent details about numbers. double-float-epsilon most-negative-fixnum double-float-negative-epsilon most-negative-long-float least-negative-double-float most-negative-short-float least-negative-long-float most-negative-single-float least-negative-short-float most-positive-double-float least-negative-single-float most-positive-fixnum least-positive-double-float most-positive-long-float least-positive-long-float most-positive-short-float least-positive-short-float most-positive-single-float least-positive-single-float short-float-epsilon long-float-epsilon short-float-negative-epsilon long-float-negative-epsilon single-float-epsilon most-negative-double-float single-float-negative-epsilon Figure 12-7: Defined names relating to implementation-dependent details about numbers.  File: gcl.info, Node: Rational Computations, Next: Floating-point Computations, Prev: Implementation-Dependent Numeric Constants, Up: Number Concepts 12.1.3 Rational Computations ---------------------------- The rules in this section apply to rational computations. * Menu: * Rule of Unbounded Rational Precision:: * Rule of Canonical Representation for Rationals:: * Rule of Float Substitutability::  File: gcl.info, Node: Rule of Unbounded Rational Precision, Next: Rule of Canonical Representation for Rationals, Prev: Rational Computations, Up: Rational Computations 12.1.3.1 Rule of Unbounded Rational Precision ............................................. Rational computations cannot overflow in the usual sense (though there may not be enough storage to represent a result), since integers and ratios may in principle be of any magnitude.  File: gcl.info, Node: Rule of Canonical Representation for Rationals, Next: Rule of Float Substitutability, Prev: Rule of Unbounded Rational Precision, Up: Rational Computations 12.1.3.2 Rule of Canonical Representation for Rationals ....................................................... If any computation produces a result that is a mathematical ratio of two integers such that the denominator evenly divides the numerator, then the result is converted to the equivalent integer. If the denominator does not evenly divide the numerator, the canonical representation of a rational number is as the ratio that numerator and that denominator, where the greatest common divisor of the numerator and denominator is one, and where the denominator is positive and greater than one. When used as input (in the default syntax), the notation -0 always denotes the integer 0. A conforming implementation must not have a representation of "minus zero" for integers that is distinct from its representation of zero for integers. However, such a distinction is possible for floats; see the type float.  File: gcl.info, Node: Rule of Float Substitutability, Prev: Rule of Canonical Representation for Rationals, Up: Rational Computations 12.1.3.3 Rule of Float Substitutability ....................................... When the arguments to an irrational mathematical function [Reviewer Note by Barmar: There should be a table of these functions.] are all rational and the true mathematical result is also (mathematically) rational, then unless otherwise noted an implementation is free to return either an accurate rational result or a single float approximation. If the arguments are all rational but the result cannot be expressed as a rational number, then a single float approximation is always returned. If the arguments to a mathematical function are all of type (or rational (complex rational)) and the true mathematical result is (mathematically) a complex number with rational real and imaginary parts, then unless otherwise noted an implementation is free to return either an accurate result of type (or rational (complex rational)) or a single float (permissible only if the imaginary part of the true mathematical result is zero) or (complex single-float). If the arguments are all of type (or rational (complex rational)) but the result cannot be expressed as a rational or complex rational, then the returned value will be of type single-float (permissible only if the imaginary part of the true mathematical result is zero) or (complex single-float). Function Sample Results abs (abs #c(3 4)) => 5 or 5.0 acos (acos 1) => 0 or 0.0 acosh (acosh 1) => 0 or 0.0 asin (asin 0) => 0 or 0.0 asinh (asinh 0) => 0 or 0.0 atan (atan 0) => 0 or 0.0 atanh (atanh 0) => 0 or 0.0 cis (cis 0) => #c(1 0) or #c(1.0 0.0) cos (cos 0) => 1 or 1.0 cosh (cosh 0) => 1 or 1.0 exp (exp 0) => 1 or 1.0 expt (expt 8 1/3) => 2 or 2.0 log (log 1) => 0 or 0.0 (log 8 2) => 3 or 3.0 phase (phase 7) => 0 or 0.0 signum (signum #c(3 4)) => #c(3/5 4/5) or #c(0.6 0.8) sin (sin 0) => 0 or 0.0 sinh (sinh 0) => 0 or 0.0 sqrt (sqrt 4) => 2 or 2.0 (sqrt 9/16) => 3/4 or 0.75 tan (tan 0) => 0 or 0.0 tanh (tanh 0) => 0 or 0.0 Figure 12-8: Functions Affected by Rule of Float Substitutability  File: gcl.info, Node: Floating-point Computations, Next: Complex Computations, Prev: Rational Computations, Up: Number Concepts 12.1.4 Floating-point Computations ---------------------------------- The following rules apply to floating point computations. * Menu: * Rule of Float and Rational Contagion:: * Examples of Rule of Float and Rational Contagion:: * Rule of Float Approximation:: * Rule of Float Underflow and Overflow:: * Rule of Float Precision Contagion::  File: gcl.info, Node: Rule of Float and Rational Contagion, Next: Examples of Rule of Float and Rational Contagion, Prev: Floating-point Computations, Up: Floating-point Computations 12.1.4.1 Rule of Float and Rational Contagion ............................................. When rationals and floats are combined by a numerical function, the rational is first converted to a float of the same format. For functions such as + that take more than two arguments, it is permitted that part of the operation be carried out exactly using rationals and the rest be done using floating-point arithmetic. When rationals and floats are compared by a numerical function, the function rational is effectively called to convert the float to a rational and then an exact comparison is performed. In the case of complex numbers, the real and imaginary parts are effectively handled individually.  File: gcl.info, Node: Examples of Rule of Float and Rational Contagion, Next: Rule of Float Approximation, Prev: Rule of Float and Rational Contagion, Up: Floating-point Computations 12.1.4.2 Examples of Rule of Float and Rational Contagion ......................................................... ;;;; Combining rationals with floats. ;;; This example assumes an implementation in which ;;; (float-radix 0.5) is 2 (as in IEEE) or 16 (as in IBM/360), ;;; or else some other implementation in which 1/2 has an exact ;;; representation in floating point. (+ 1/2 0.5) => 1.0 (- 1/2 0.5d0) => 0.0d0 (+ 0.5 -0.5 1/2) => 0.5 ;;;; Comparing rationals with floats. ;;; This example assumes an implementation in which the default float ;;; format is IEEE single-float, IEEE double-float, or some other format ;;; in which 5/7 is rounded upwards by FLOAT. (< 5/7 (float 5/7)) => true (< 5/7 (rational (float 5/7))) => true (< (float 5/7) (float 5/7)) => false  File: gcl.info, Node: Rule of Float Approximation, Next: Rule of Float Underflow and Overflow, Prev: Examples of Rule of Float and Rational Contagion, Up: Floating-point Computations 12.1.4.3 Rule of Float Approximation .................................... Computations with floats are only approximate, although they are described as if the results were mathematically accurate. Two mathematically identical expressions may be computationally different because of errors inherent in the floating-point approximation process. The precision of a float is not necessarily correlated with the accuracy of that number. For instance, 3.142857142857142857 is a more precise approximation to \pi than 3.14159, but the latter is more accurate. The precision refers to the number of bits retained in the representation. When an operation combines a short float with a long float, the result will be a long float. Common Lisp functions assume that the accuracy of arguments to them does not exceed their precision. Therefore when two small floats are combined, the result is a small float. Common Lisp functions never convert automatically from a larger size to a smaller one.  File: gcl.info, Node: Rule of Float Underflow and Overflow, Next: Rule of Float Precision Contagion, Prev: Rule of Float Approximation, Up: Floating-point Computations 12.1.4.4 Rule of Float Underflow and Overflow ............................................. An error of type floating-point-overflow or floating-point-underflow should be signaled if a floating-point computation causes exponent overflow or underflow, respectively.  File: gcl.info, Node: Rule of Float Precision Contagion, Prev: Rule of Float Underflow and Overflow, Up: Floating-point Computations 12.1.4.5 Rule of Float Precision Contagion .......................................... The result of a numerical function is a float of the largest format among all the floating-point arguments to the function.  File: gcl.info, Node: Complex Computations, Next: Interval Designators, Prev: Floating-point Computations, Up: Number Concepts 12.1.5 Complex Computations --------------------------- The following rules apply to complex computations: * Menu: * Rule of Complex Substitutability:: * Rule of Complex Contagion:: * Rule of Canonical Representation for Complex Rationals:: * Examples of Rule of Canonical Representation for Complex Rationals:: * Principal Values and Branch Cuts::  File: gcl.info, Node: Rule of Complex Substitutability, Next: Rule of Complex Contagion, Prev: Complex Computations, Up: Complex Computations 12.1.5.1 Rule of Complex Substitutability ......................................... Except during the execution of irrational and transcendental functions, no numerical function ever yields a complex unless one or more of its arguments is a complex.  File: gcl.info, Node: Rule of Complex Contagion, Next: Rule of Canonical Representation for Complex Rationals, Prev: Rule of Complex Substitutability, Up: Complex Computations 12.1.5.2 Rule of Complex Contagion .................................. When a real and a complex are both part of a computation, the real is first converted to a complex by providing an imaginary part of 0.  File: gcl.info, Node: Rule of Canonical Representation for Complex Rationals, Next: Examples of Rule of Canonical Representation for Complex Rationals, Prev: Rule of Complex Contagion, Up: Complex Computations 12.1.5.3 Rule of Canonical Representation for Complex Rationals ............................................................... If the result of any computation would be a complex number whose real part is of type rational and whose imaginary part is zero, the result is converted to the rational which is the real part. This rule does not apply to complex numbers whose parts are floats. For example, #C(5 0) and 5 are not different objects in Common Lisp (they are always the same under eql); #C(5.0 0.0) and 5.0 are always different objects in Common Lisp (they are never the same under eql, although they are the same under equalp and =).  File: gcl.info, Node: Examples of Rule of Canonical Representation for Complex Rationals, Next: Principal Values and Branch Cuts, Prev: Rule of Canonical Representation for Complex Rationals, Up: Complex Computations 12.1.5.4 Examples of Rule of Canonical Representation for Complex Rationals ........................................................................... #c(1.0 1.0) => #C(1.0 1.0) #c(0.0 0.0) => #C(0.0 0.0) #c(1.0 1) => #C(1.0 1.0) #c(0.0 0) => #C(0.0 0.0) #c(1 1) => #C(1 1) #c(0 0) => 0 (typep #c(1 1) '(complex (eql 1))) => true (typep #c(0 0) '(complex (eql 0))) => false  File: gcl.info, Node: Principal Values and Branch Cuts, Prev: Examples of Rule of Canonical Representation for Complex Rationals, Up: Complex Computations 12.1.5.5 Principal Values and Branch Cuts ......................................... Many of the irrational and transcendental functions are multiply defined in the complex domain; for example, there are in general an infinite number of complex values for the logarithm function. In each such case, a principal value must be chosen for the function to return. In general, such values cannot be chosen so as to make the range continuous; lines in the domain called branch cuts must be defined, which in turn define the discontinuities in the range. Common Lisp defines the branch cuts, principal values, and boundary conditions for the complex functions following "Principal Values and Branch Cuts in Complex APL." The branch cut rules that apply to each function are located with the description of that function. Figure 12-9 lists the identities that are obeyed throughout the applicable portion of the complex domain, even on the branch cuts: sin i z = i sinh z sinh i z = i sin z arctan i z = i arctanh z cos i z = cosh z cosh i z = cos z arcsinh i z = i arcsin z tan i z = i tanh z arcsin i z = i arcsinh z arctanh i z = i arctan z Figure 12-9: Trigonometric Identities for Complex Domain The quadrant numbers referred to in the discussions of branch cuts are as illustrated in Figure 12-10. Imaginary Axis | | II | I | | | ______________________________________ Real Axis | | | III | IV | | | | Figure 12-9: Quadrant Numbering for Branch Cuts  File: gcl.info, Node: Interval Designators, Next: Random-State Operations, Prev: Complex Computations, Up: Number Concepts 12.1.6 Interval Designators --------------------------- The compound type specifier form of the numeric type specifiers in Figure 12-10 permit the user to specify an interval on the real number line which describe a subtype of the type which would be described by the corresponding atomic type specifier. A subtype of some type T is specified using an ordered pair of objects called interval designators for type T. The first of the two interval designators for type T can be any of the following: a number N of type T This denotes a lower inclusive bound of N. That is, elements of the subtype of T will be greater than or equal to N. a singleton list whose element is a number M of type T This denotes a lower exclusive bound of M. That is, elements of the subtype of T will be greater than M. the symbol * This denotes the absence of a lower bound on the interval. The second of the two interval designators for type T can be any of the following: a number N of type T This denotes an upper inclusive bound of N. That is, elements of the subtype of T will be less than or equal to N. a singleton list whose element is a number M of type T This denotes an upper exclusive bound of M. That is, elements of the subtype of T will be less than M. the symbol * This denotes the absence of an upper bound on the interval.  File: gcl.info, Node: Random-State Operations, Prev: Interval Designators, Up: Number Concepts 12.1.7 Random-State Operations ------------------------------ Figure 12-10 lists some defined names that are applicable to random states. *random-state* random make-random-state random-state-p Figure 12-10: Random-state defined names  File: gcl.info, Node: Numbers Dictionary, Prev: Number Concepts, Up: Numbers (Numbers) 12.2 Numbers Dictionary ======================= * Menu: * number:: * complex (System Class):: * real:: * float (System Class):: * short-float:: * rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: * mod (System Class):: * bit (System Class):: * fixnum:: * bignum:: * =:: * max:: * minusp:: * zerop:: * floor:: * sin:: * asin:: * pi:: * sinh:: * *:: * +:: * -:: * /:: * 1+:: * abs:: * evenp:: * exp:: * gcd:: * incf:: * lcm:: * log:: * mod (Function):: * signum:: * sqrt:: * random-state:: * make-random-state:: * random:: * random-state-p:: * *random-state*:: * numberp:: * cis:: * complex:: * complexp:: * conjugate:: * phase:: * realpart:: * upgraded-complex-part-type:: * realp:: * numerator:: * rational (Function):: * rationalp:: * ash:: * integer-length:: * integerp:: * parse-integer:: * boole:: * boole-1:: * logand:: * logbitp:: * logcount:: * logtest:: * byte:: * deposit-field:: * dpb:: * ldb:: * ldb-test:: * mask-field:: * most-positive-fixnum:: * decode-float:: * float:: * floatp:: * most-positive-short-float:: * short-float-epsilon:: * arithmetic-error:: * arithmetic-error-operands:: * division-by-zero:: * floating-point-invalid-operation:: * floating-point-inexact:: * floating-point-overflow:: * floating-point-underflow::  File: gcl.info, Node: number, Next: complex (System Class), Prev: Numbers Dictionary, Up: Numbers Dictionary 12.2.1 number [System Class] ---------------------------- Class Precedence List:: ....................... number, t Description:: ............. The type number contains objects which represent mathematical numbers. The types real and complex are disjoint subtypes of number. The function = tests for numerical equality. The function eql, when its arguments are both numbers, tests that they have both the same type and numerical value. Two numbers that are the same under eql or = are not necessarily the same under eq. Notes:: ....... Common Lisp differs from mathematics on some naming issues. In mathematics, the set of real numbers is traditionally described as a subset of the complex numbers, but in Common Lisp, the type real and the type complex are disjoint. The Common Lisp type which includes all mathematical complex numbers is called number. The reasons for these differences include historical precedent, compatibility with most other popular computer languages, and various issues of time and space efficiency.  File: gcl.info, Node: complex (System Class), Next: real, Prev: number, Up: Numbers Dictionary 12.2.2 complex [System Class] ----------------------------- Class Precedence List:: ....................... complex, number, t Description:: ............. The type complex includes all mathematical complex numbers other than those included in the type rational. Complexes are expressed in Cartesian form with a real part and an imaginary part, each of which is a real. The real part and imaginary part are either both rational or both of the same float type. The imaginary part can be a float zero, but can never be a rational zero, for such a number is always represented by Common Lisp as a rational rather than a complex. Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('complex'{[typespec | *]}) Compound Type Specifier Arguments:: ................................... typespec--a type specifier that denotes a subtype of type real. Compound Type Specifier Description:: ..................................... [Editorial Note by KMP: If you ask me, this definition is a complete mess. Looking at issue ARRAY-TYPE-ELEMENT-TYPE-SEMANTICS:UNIFY-UPGRADING does not help me figure it out, either. Anyone got any suggestions?] Every element of this type is a complex whose real part and imaginary part are each of type (upgraded-complex-part-type typespec). This type encompasses those complexes that can result by giving numbers of type typespec to complex. (complex type-specifier) refers to all complexes that can result from giving numbers of type type-specifier to the function complex, plus all other complexes of the same specialized representation. See Also:: .......... *note Rule of Canonical Representation for Complex Rationals::, *note Constructing Numbers from Tokens::, *note Printing Complexes:: Notes:: ....... The input syntax for a complex with real part r and imaginary part i is #C(r i). For further details, see *note Standard Macro Characters::. For every float, n, there is a complex which represents the same mathematical number and which can be obtained by (COERCE n 'COMPLEX).  File: gcl.info, Node: real, Next: float (System Class), Prev: complex (System Class), Up: Numbers Dictionary 12.2.3 real [System Class] -------------------------- Class Precedence List:: ....................... real, number, t Description:: ............. The type real includes all numbers that represent mathematical real numbers, though there are mathematical real numbers (e.g., irrational numbers) that do not have an exact representation in Common Lisp. Only reals can be ordered using the <, >, <=, and >= functions. The types rational and float are disjoint subtypes of type real. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('real'{[lower-limit [upper-limit]]}) Compound Type Specifier Arguments:: ................................... lower-limit, upper-limit--interval designators for type real. The defaults for each of lower-limit and upper-limit is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the reals on the interval described by lower-limit and upper-limit.  File: gcl.info, Node: float (System Class), Next: short-float, Prev: real, Up: Numbers Dictionary 12.2.4 float [System Class] --------------------------- Class Precedence List:: ....................... float, real, number, t Description:: ............. A float is a mathematical rational (but not a Common Lisp rational) of the form s\cdot f\cdot b^e-p, where s is +1 or -1, the sign; b is an integer greater than~1, the base or radix of the representation; p is a positive integer, the precision (in base-b digits) of the float; f is a positive integer between b^p-1 and b^p-1 (inclusive), the significand; and e is an integer, the exponent. The value of p and the range of~e depends on the implementation and on the type of float within that implementation. In addition, there is a floating-point zero; depending on the implementation, there can also be a "minus zero". If there is no minus zero, then 0.0 and~-0.0 are both interpreted as simply a floating-point zero. (= 0.0 -0.0) is always true. If there is a minus zero, (eql -0.0 0.0) is false, otherwise it is true. [Reviewer Note by Barmar: What about IEEE NaNs and infinities?] [Reviewer Note by RWK: In the following, what is the "ordering"? precision? range? Can there be additional subtypes of float or does "others" in the list of four?] The types short-float, single-float, double-float, and long-float are subtypes of type float. Any two of them must be either disjoint types or the same type; if the same type, then any other types between them in the above ordering must also be the same type. For example, if the type single-float and the type long-float are the same type, then the type double-float must be the same type also. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('float'{[lower-limit [upper-limit]]}) Compound Type Specifier Arguments:: ................................... lower-limit, upper-limit--interval designators for type float. The defaults for each of lower-limit and upper-limit is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the floats on the interval described by lower-limit and upper-limit. See Also:: .......... Figure~2-9, *note Constructing Numbers from Tokens::, *note Printing Floats:: Notes:: ....... Note that all mathematical integers are representable not only as Common Lisp reals, but also as complex floats. For example, possible representations of the mathematical number 1 include the integer 1, the float 1.0, or the complex #C(1.0 0.0).  File: gcl.info, Node: short-float, Next: rational (System Class), Prev: float (System Class), Up: Numbers Dictionary 12.2.5 short-float, single-float, double-float, long-float [Type] ----------------------------------------------------------------- Supertypes:: ............ short-float: short-float, float, real, number, t single-float: single-float, float, real, number, t double-float: double-float, float, real, number, t long-float: long-float, float, real, number, t Description:: ............. For the four defined subtypes of type float, it is true that intermediate between the type short-float and the type long-float are the type single-float and the type double-float. The precise definition of these categories is implementation-defined. The precision (measured in "bits", computed as p\log_2b) and the exponent size (also measured in "bits," computed as \log_2(n+1), where n is the maximum exponent value) is recommended to be at least as great as the values in Figure 12-11. Each of the defined subtypes of type float might or might not have a minus zero. Format Minimum Precision Minimum Exponent Size __________________________________________________ Short 13 bits 5 bits Single 24 bits 8 bits Double 50 bits 8 bits Long 50 bits 8 bits Figure 12-11: Recommended Minimum Floating-Point Precision and Exponent Size There can be fewer than four internal representations for floats. If there are fewer distinct representations, the following rules apply: - If there is only one, it is the type single-float. In this representation, an object is simultaneously of types single-float, double-float, short-float, and long-float. - Two internal representations can be arranged in either of the following ways: * Two types are provided: single-float and short-float. An object is simultaneously of types single-float, double-float, and long-float. * Two types are provided: single-float and double-float. An object is simultaneously of types single-float and short-float, or double-float and long-float. - Three internal representations can be arranged in either of the following ways: * Three types are provided: short-float, single-float, and double-float. An object can simultaneously be of type double-float and long-float. * Three types are provided: single-float, double-float, and long-float. An object can simultaneously be of types single-float and short-float. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('short-float'{[short-lower-limit [short-upper-limit]]}) ('single-float'{[single-lower-limit [single-upper-limit]]}) ('double-float'{[double-lower-limit [double-upper-limit]]}) ('long-float'{[long-lower-limit [long-upper-limit]]}) Compound Type Specifier Arguments:: ................................... short-lower-limit, short-upper-limit--interval designators for type short-float. The defaults for each of lower-limit and upper-limit is the symbol *. single-lower-limit, single-upper-limit--interval designators for type single-float. The defaults for each of lower-limit and upper-limit is the symbol *. double-lower-limit, double-upper-limit--interval designators for type double-float. The defaults for each of lower-limit and upper-limit is the symbol *. long-lower-limit, long-upper-limit--interval designators for type long-float. The defaults for each of lower-limit and upper-limit is the symbol *. Compound Type Specifier Description:: ..................................... Each of these denotes the set of floats of the indicated type that are on the interval specified by the interval designators.  File: gcl.info, Node: rational (System Class), Next: ratio, Prev: short-float, Up: Numbers Dictionary 12.2.6 rational [System Class] ------------------------------ Class Precedence List:: ....................... rational, real, number, t Description:: ............. The canonical representation of a rational is as an integer if its value is integral, and otherwise as a ratio. The types integer and ratio are disjoint subtypes of type rational. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('rational'{[lower-limit [upper-limit]]}) Compound Type Specifier Arguments:: ................................... lower-limit, upper-limit--interval designators for type rational. The defaults for each of lower-limit and upper-limit is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the rationals on the interval described by lower-limit and upper-limit.  File: gcl.info, Node: ratio, Next: integer, Prev: rational (System Class), Up: Numbers Dictionary 12.2.7 ratio [System Class] --------------------------- Class Precedence List:: ....................... ratio, rational, real, number, t Description:: ............. A ratio is a number representing the mathematical ratio of two non-zero integers, the numerator and denominator, whose greatest common divisor is one, and of which the denominator is positive and greater than one. See Also:: .......... Figure~2-9, *note Constructing Numbers from Tokens::, *note Printing Ratios::  File: gcl.info, Node: integer, Next: signed-byte, Prev: ratio, Up: Numbers Dictionary 12.2.8 integer [System Class] ----------------------------- Class Precedence List:: ....................... integer, rational, real, number, t Description:: ............. An integer is a mathematical integer. There is no limit on the magnitude of an integer. The types fixnum and bignum form an exhaustive partition of type integer. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('integer'{[lower-limit [upper-limit]]}) Compound Type Specifier Arguments:: ................................... lower-limit, upper-limit--interval designators for type integer. The defaults for each of lower-limit and upper-limit is the symbol *. Compound Type Specifier Description:: ..................................... This denotes the integers on the interval described by lower-limit and upper-limit. See Also:: .......... Figure~2-9, *note Constructing Numbers from Tokens::, *note Printing Integers:: Notes:: ....... The type (integer lower upper), where lower and upper are most-negative-fixnum and most-positive-fixnum, respectively, is also called fixnum. The type (integer 0 1) is also called bit. The type (integer 0 *) is also called unsigned-byte.  File: gcl.info, Node: signed-byte, Next: unsigned-byte, Prev: integer, Up: Numbers Dictionary 12.2.9 signed-byte [Type] ------------------------- Supertypes:: ............ signed-byte, integer, rational, real, number, t Description:: ............. The atomic type specifier signed-byte denotes the same type as is denoted by the type specifier integer; however, the list forms of these two type specifiers have different semantics. Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('signed-byte'{[s | *]}) Compound Type Specifier Arguments:: ................................... s--a positive integer. Compound Type Specifier Description:: ..................................... This denotes the set of integers that can be represented in two's-complement form in a byte of s bits. This is equivalent to (integer -2^s-1 2^s-1-1). The type signed-byte or the type (signed-byte *) is the same as the type integer.  File: gcl.info, Node: unsigned-byte, Next: mod (System Class), Prev: signed-byte, Up: Numbers Dictionary 12.2.10 unsigned-byte [Type] ---------------------------- Supertypes:: ............ unsigned-byte, signed-byte, integer, rational, real, number, t Description:: ............. The atomic type specifier unsigned-byte denotes the same type as is denoted by the type specifier (integer 0 *). Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('unsigned-byte'{[s | *]}) Compound Type Specifier Arguments:: ................................... s--a positive integer. Compound Type Specifier Description:: ..................................... This denotes the set of non-negative integers that can be represented in a byte of size s (bits). This is equivalent to (mod m) for m=2^s, or to (integer 0 n) for n=2^s-1. The type unsigned-byte or the type (unsigned-byte *) is the same as the type (integer 0 *), the set of non-negative integers. Notes:: ....... The type (unsigned-byte 1) is also called bit.  File: gcl.info, Node: mod (System Class), Next: bit (System Class), Prev: unsigned-byte, Up: Numbers Dictionary 12.2.11 mod [Type Specifier] ---------------------------- Compound Type Specifier Kind:: .............................. Abbreviating. Compound Type Specifier Syntax:: ................................ ('mod'{n}) Compound Type Specifier Arguments:: ................................... n--a positive integer. Compound Type Specifier Description:: ..................................... This denotes the set of non-negative integers less than n. This is equivalent to (integer 0 (n)) or to (integer 0 m), where m=n-1. The argument is required, and cannot be *. The symbol mod is not valid as a type specifier.  File: gcl.info, Node: bit (System Class), Next: fixnum, Prev: mod (System Class), Up: Numbers Dictionary 12.2.12 bit [Type] ------------------ Supertypes:: ............ bit, unsigned-byte, signed-byte, integer, rational, real, number, t Description:: ............. The type bit is equivalent to the type (integer 0 1) and (unsigned-byte 1).  File: gcl.info, Node: fixnum, Next: bignum, Prev: bit (System Class), Up: Numbers Dictionary 12.2.13 fixnum [Type] --------------------- Supertypes:: ............ fixnum, integer, rational, real, number, t Description:: ............. A fixnum is an integer whose value is between most-negative-fixnum and most-positive-fixnum inclusive. Exactly which integers are fixnums is implementation-defined. The type fixnum is required to be a supertype of (signed-byte 16).  File: gcl.info, Node: bignum, Next: =, Prev: fixnum, Up: Numbers Dictionary 12.2.14 bignum [Type] --------------------- Supertypes:: ............ bignum, integer, rational, real, number, t Description:: ............. The type bignum is defined to be exactly (and integer (not fixnum)).  File: gcl.info, Node: =, Next: max, Prev: bignum, Up: Numbers Dictionary 12.2.15 =, /=, <, >, <=, >= [Function] -------------------------------------- '=' &rest numbers^+ => generalized-boolean '/=' &rest numbers^+ => generalized-boolean '<' &rest numbers^+ => generalized-boolean '>' &rest numbers^+ => generalized-boolean '<=' &rest numbers^+ => generalized-boolean '>=' &rest numbers^+ => generalized-boolean Arguments and Values:: ...................... number--for <, >, <=, >=: a real; for =, /=: a number. generalized-boolean--a generalized boolean. Description:: ............. =, /=, <, >, <=, and >= perform arithmetic comparisons on their arguments as follows: = The value of = is true if all numbers are the same in value; otherwise it is false. Two complexes are considered equal by = if their real and imaginary parts are equal according to =. /= The value of /= is true if no two numbers are the same in value; otherwise it is false. < The value of < is true if the numbers are in monotonically increasing order; otherwise it is false. > The value of > is true if the numbers are in monotonically decreasing order; otherwise it is false. <= The value of <= is true if the numbers are in monotonically nondecreasing order; otherwise it is false. >= The value of >= is true if the numbers are in monotonically nonincreasing order; otherwise it is false. =, /=, <, >, <=, and >= perform necessary type conversions. Examples:: .......... The uses of these functions are illustrated in Figure 12-12. (= 3 3) is true. (/= 3 3) is false. (= 3 5) is false. (/= 3 5) is true. (= 3 3 3 3) is true. (/= 3 3 3 3) is false. (= 3 3 5 3) is false. (/= 3 3 5 3) is false. (= 3 6 5 2) is false. (/= 3 6 5 2) is true. (= 3 2 3) is false. (/= 3 2 3) is false. (< 3 5) is true. (<= 3 5) is true. (< 3 -5) is false. (<= 3 -5) is false. (< 3 3) is false. (<= 3 3) is true. (< 0 3 4 6 7) is true. (<= 0 3 4 6 7) is true. (< 0 3 4 4 6) is false. (<= 0 3 4 4 6) is true. (> 4 3) is true. (>= 4 3) is true. (> 4 3 2 1 0) is true. (>= 4 3 2 1 0) is true. (> 4 3 3 2 0) is false. (>= 4 3 3 2 0) is true. (> 4 3 1 2 0) is false. (>= 4 3 1 2 0) is false. (= 3) is true. (/= 3) is true. (< 3) is true. (<= 3) is true. (= 3.0 #c(3.0 0.0)) is true. (/= 3.0 #c(3.0 1.0)) is true. (= 3 3.0) is true. (= 3.0s0 3.0d0) is true. (= 0.0 -0.0) is true. (= 5/2 2.5) is true. (> 0.0 -0.0) is false. (= 0 -0.0) is true. (<= 0 x 9) is true if x is between 0 and 9, inclusive (< 0.0 x 1.0) is true if x is between 0.0 and 1.0, exclusive (< -1 j (length v)) is true if j is a valid array index for a vector v Figure 12-12: Uses of /=, =, <, >, <=, and >= Exceptional Situations:: ........................ Might signal type-error if some argument is not a real. Might signal arithmetic-error if otherwise unable to fulfill its contract. Notes:: ....... = differs from eql in that (= 0.0 -0.0) is always true, because = compares the mathematical values of its operands, whereas eql compares the representational values, so to speak.  File: gcl.info, Node: max, Next: minusp, Prev: =, Up: Numbers Dictionary 12.2.16 max, min [Function] --------------------------- 'max' &rest reals^+ => max-real 'min' &rest reals^+ => min-real Arguments and Values:: ...................... real--a real. max-real, min-real--a real. Description:: ............. max returns the real that is greatest (closest to positive infinity). min returns the real that is least (closest to negative infinity). For max, the implementation has the choice of returning the largest argument as is or applying the rules of floating-point contagion, taking all the arguments into consideration for contagion purposes. Also, if one or more of the arguments are =, then any one of them may be chosen as the value to return. For example, if the reals are a mixture of rationals and floats, and the largest argument is a rational, then the implementation is free to produce either that rational or its float approximation; if the largest argument is a float of a smaller format than the largest format of any float argument, then the implementation is free to return the argument in its given format or expanded to the larger format. Similar remarks apply to min (replacing "largest argument" by "smallest argument"). Examples:: .......... (max 3) => 3 (min 3) => 3 (max 6 12) => 12 (min 6 12) => 6 (max -6 -12) => -6 (min -6 -12) => -12 (max 1 3 2 -7) => 3 (min 1 3 2 -7) => -7 (max -2 3 0 7) => 7 (min -2 3 0 7) => -2 (max 5.0 2) => 5.0 (min 5.0 2) => 2 OR=> 2.0 (max 3.0 7 1) => 7 OR=> 7.0 (min 3.0 7 1) => 1 OR=> 1.0 (max 1.0s0 7.0d0) => 7.0d0 (min 1.0s0 7.0d0) => 1.0s0 OR=> 1.0d0 (max 3 1 1.0s0 1.0d0) => 3 OR=> 3.0d0 (min 3 1 1.0s0 1.0d0) => 1 OR=> 1.0s0 OR=> 1.0d0 Exceptional Situations:: ........................ Should signal an error of type type-error if any number is not a real.  File: gcl.info, Node: minusp, Next: zerop, Prev: max, Up: Numbers Dictionary 12.2.17 minusp, plusp [Function] -------------------------------- 'minusp' real => generalized-boolean 'plusp' real => generalized-boolean Arguments and Values:: ...................... real--a real. generalized-boolean--a generalized boolean. Description:: ............. minusp returns true if real is less than zero; otherwise, returns false. plusp returns true if real is greater than zero; otherwise, returns false. Regardless of whether an implementation provides distinct representations for positive and negative float zeros, (minusp -0.0) always returns false. Examples:: .......... (minusp -1) => true (plusp 0) => false (plusp least-positive-single-float) => true Exceptional Situations:: ........................ Should signal an error of type type-error if real is not a real.  File: gcl.info, Node: zerop, Next: floor, Prev: minusp, Up: Numbers Dictionary 12.2.18 zerop [Function] ------------------------ 'zerop' number => generalized-boolean Pronunciation:: ............... pronounced 'z\=e (, )r\=o(, )p\=e Arguments and Values:: ...................... number--a number. generalized-boolean--a generalized boolean. Description:: ............. Returns true if number is zero (integer, float, or complex); otherwise, returns false. Regardless of whether an implementation provides distinct representations for positive and negative floating-point zeros, (zerop -0.0) always returns true. Examples:: .......... (zerop 0) => true (zerop 1) => false (zerop -0.0) => true (zerop 0/100) => true (zerop #c(0 0.0)) => true Exceptional Situations:: ........................ Should signal an error of type type-error if number is not a number. Notes:: ....... (zerop number) == (= number 0)  File: gcl.info, Node: floor, Next: sin, Prev: zerop, Up: Numbers Dictionary 12.2.19 floor, ffloor, ceiling, fceiling, ----------------------------------------- truncate, ftruncate, round, fround ---------------------------------- [Function] 'floor' number &optional divisor => quotient, remainder 'ffloor' number &optional divisor => quotient, remainder 'ceiling' number &optional divisor => quotient, remainder 'fceiling' number &optional divisor => quotient, remainder 'truncate' number &optional divisor => quotient, remainder 'ftruncate' number &optional divisor => quotient, remainder 'round' number &optional divisor => quotient, remainder 'fround' number &optional divisor => quotient, remainder Arguments and Values:: ...................... number--a real. divisor--a non-zero real. The default is the integer 1. quotient--for floor, ceiling, truncate, and round: an integer; for ffloor, fceiling, ftruncate, and fround: a float. remainder--a real. Description:: ............. These functions divide number by divisor, returning a quotient and remainder, such that quotient\cdot divisor+remainder=number The quotient always represents a mathematical integer. When more than one mathematical integer might be possible (i.e., when the remainder is not zero), the kind of rounding or truncation depends on the operator: floor, ffloor floor and ffloor produce a quotient that has been truncated toward negative infinity; that is, the quotient represents the largest mathematical integer that is not larger than the mathematical quotient. ceiling, fceiling ceiling and fceiling produce a quotient that has been truncated toward positive infinity; that is, the quotient represents the smallest mathematical integer that is not smaller than the mathematical result. truncate, ftruncate truncate and ftruncate produce a quotient that has been truncated towards zero; that is, the quotient represents the mathematical integer of the same sign as the mathematical quotient, and that has the greatest integral magnitude not greater than that of the mathematical quotient. round, fround round and fround produce a quotient that has been rounded to the nearest mathematical integer; if the mathematical quotient is exactly halfway between two integers, (that is, it has the form integer+1\over2), then the quotient has been rounded to the even (divisible by two) integer. All of these functions perform type conversion operations on numbers. The remainder is an integer if both x and y are integers, is a rational if both x and y are rationals, and is a float if either x or y is a float. ffloor, fceiling, ftruncate, and fround handle arguments of different types in the following way: If number is a float, and divisor is not a float of longer format, then the first result is a float of the same type as number. Otherwise, the first result is of the type determined by contagion rules; see *note Contagion in Numeric Operations::. Examples:: .......... (floor 3/2) => 1, 1/2 (ceiling 3 2) => 2, -1 (ffloor 3 2) => 1.0, 1 (ffloor -4.7) => -5.0, 0.3 (ffloor 3.5d0) => 3.0d0, 0.5d0 (fceiling 3/2) => 2.0, -1/2 (truncate 1) => 1, 0 (truncate .5) => 0, 0.5 (round .5) => 0, 0.5 (ftruncate -7 2) => -3.0, -1 (fround -7 2) => -4.0, 1 (dolist (n '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (format t "~&~4,1@F ~2,' D ~2,' D ~2,' D ~2,' D" n (floor n) (ceiling n) (truncate n) (round n))) |> +2.6 2 3 2 3 |> +2.5 2 3 2 2 |> +2.4 2 3 2 2 |> +0.7 0 1 0 1 |> +0.3 0 1 0 0 |> -0.3 -1 0 0 0 |> -0.7 -1 0 0 -1 |> -2.4 -3 -2 -2 -2 |> -2.5 -3 -2 -2 -2 |> -2.6 -3 -2 -2 -3 => NIL Notes:: ....... When only number is given, the two results are exact; the mathematical sum of the two results is always equal to the mathematical value of number. (function number divisor) and (function (/ number divisor)) (where function is any of one of floor, ceiling, ffloor, fceiling, truncate, round, ftruncate, and fround) return the same first value, but they return different remainders as the second value. For example: (floor 5 2) => 2, 1 (floor (/ 5 2)) => 2, 1/2 If an effect is desired that is similar to round, but that always rounds up or down (rather than toward the nearest even integer) if the mathematical quotient is exactly halfway between two integers, the programmer should consider a construction such as (floor (+ x 1/2)) or (ceiling (- x 1/2)).  File: gcl.info, Node: sin, Next: asin, Prev: floor, Up: Numbers Dictionary 12.2.20 sin, cos, tan [Function] -------------------------------- 'sin' radians => number 'cos' radians => number 'tan' radians => number Arguments and Values:: ...................... radians--a number given in radians. number--a number. Description:: ............. sin, cos, and tan return the sine, cosine, and tangent, respectively, of radians. Examples:: .......... (sin 0) => 0.0 (cos 0.7853982) => 0.707107 (tan #c(0 1)) => #C(0.0 0.761594) Exceptional Situations:: ........................ Should signal an error of type type-error if radians is not a number. Might signal arithmetic-error. See Also:: .......... *note asin:: , acos, atan, *note Rule of Float Substitutability::  File: gcl.info, Node: asin, Next: pi, Prev: sin, Up: Numbers Dictionary 12.2.21 asin, acos, atan [Function] ----------------------------------- 'asin' number => radians 'acos' number => radians 'atan' number1 &optional number2 => radians Arguments and Values:: ...................... number--a number. number1--a number if number2 is not supplied, or a real if number2 is supplied. number2--a real. radians--a number (of radians). Description:: ............. asin, acos, and atan compute the arc sine, arc cosine, and arc tangent respectively. The arc sine, arc cosine, and arc tangent (with only number1 supplied) functions can be defined mathematically for number or number1 specified as x as in Figure 12-13. Function Definition Arc sine -i log (ix+ \sqrt1-x^2 ) Arc cosine (\pi/2) - arcsin x Arc tangent -i log ((1+ix) \sqrt1/(1+x^2) ) Figure 12-13: Mathematical definition of arc sine, arc cosine, and arc tangent These formulae are mathematically correct, assuming completely accurate computation. They are not necessarily the simplest ones for real-valued computations. If both number1 and number2 are supplied for atan, the result is the arc tangent of number1/number2. The value of atan is always between -\pi (exclusive) and~\pi (inclusive) when minus zero is not supported. The range of the two-argument arc tangent when minus zero is supported includes -\pi. For a real number1, the result is a real and lies between -\pi/2 and~\pi/2 (both exclusive). number1 can be a complex if number2 is not supplied. If both are supplied, number2 can be zero provided number1 is not zero. [Reviewer Note by Barmar: Should add "However, if the implementation distinguishes positive and negative zero, both may be signed zeros, and limits are used to define the result."] The following definition for arc sine determines the range and branch cuts: arcsin z = -i log (iz+\sqrt1-z^2\Bigr) The branch cut for the arc sine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is non-positive. The following definition for arc cosine determines the range and branch cuts: arccos z = \pi\over2 - arcsin z or, which are equivalent, arccos z = -i log (z+i \sqrt1-z^2\Bigr) arccos z = 2 log (\sqrt(1+z)/2 + i \sqrt(1-z)/2)\overi The branch cut for the arc cosine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. This is the same branch cut as for arc sine. The range is that strip of the complex plane containing numbers whose real part is between 0 and~\pi. A number with real part equal to 0 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi is in the range if and only if its imaginary part is non-positive. The following definition for (one-argument) arc tangent determines the range and branch cuts: arctan z = log (1+iz) - log (1-iz)\over2i Beware of simplifying this formula; "obvious" simplifications are likely to alter the branch cuts or the values on the branch cuts incorrectly. The branch cut for the arc tangent function is in two pieces: one along the positive imaginary axis above i (exclusive), continuous with quadrant II, and one along the negative imaginary axis below -i (exclusive), continuous with quadrant IV. The points i and~-i are excluded from the domain. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is strictly positive; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is strictly negative. Thus the range of arc tangent is identical to that of arc sine with the points -\pi/2 and~\pi/2 excluded. For atan, the signs of number1 (indicated as x) and number2 (indicated as y) are used to derive quadrant information. Figure 12-14 details various special cases. The asterisk (*) indicates that the entry in the figure applies to implementations that support minus zero. to 1pcy Condition x Condition Cartesian locus Range of result to 1pc y = 0 x > 0 Positive x-axis 0 to 1pc* y = +0 x > 0 Positive x-axis +0 to 1pc* y = -0 x > 0 Positive x-axis -0 to 1pc y > 0 x > 0 Quadrant I 0 < result < \pi/2 to 1pc y > 0 x = 0 Positive y-axis \pi/2 to 1pc y > 0 x < 0 Quadrant II \pi/2 < result < \pi to 1pc y = 0 x < 0 Negative x-axis \pi to 1pc* y = +0 x < 0 Negative x-axis +\pi to 1pc* y = -0 x < 0 Negative x-axis -\pi to 1pc y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 to 1pc y < 0 x = 0 Negative y-axis -\pi/2 to 1pc y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 to 1pc y = 0 x = 0 Origin undefined consequences to 1pc* y = +0 x = +0 Origin +0 to 1pc* y = -0 x = +0 Origin -0 to 1pc* y = +0 x = -0 Origin +\pi to 1pc* y = -0 x = -0 Origin -\pi Figure 12-14: Quadrant information for arc tangent Examples:: .......... (asin 0) => 0.0 (acos #c(0 1)) => #C(1.5707963267948966 -0.8813735870195432) (/ (atan 1 (sqrt 3)) 6) => 0.087266 (atan #c(0 2)) => #C(-1.5707964 0.54930615) Exceptional Situations:: ........................ acos and asin should signal an error of type type-error if number is not a number. atan should signal type-error if one argument is supplied and that argument is not a number, or if two arguments are supplied and both of those arguments are not reals. acos, asin, and atan might signal arithmetic-error. See Also:: .......... *note log:: , *note sqrt:: , *note Rule of Float Substitutability:: Notes:: ....... The result of either asin or acos can be a complex even if number is not a complex; this occurs when the absolute value of number is greater than one.  File: gcl.info, Node: pi, Next: sinh, Prev: asin, Up: Numbers Dictionary 12.2.22 pi [Constant Variable] ------------------------------ Value:: ....... an implementation-dependent long float. Description:: ............. The best long float approximation to the mathematical constant \pi. Examples:: .......... ;; In each of the following computations, the precision depends ;; on the implementation. Also, if `long float' is treated by ;; the implementation as equivalent to some other float format ;; (e.g., `double float') the exponent marker might be the marker ;; for that equivalent (e.g., `D' instead of `L'). pi => 3.141592653589793L0 (cos pi) => -1.0L0 (defun sin-of-degrees (degrees) (let ((x (if (floatp degrees) degrees (float degrees pi)))) (sin (* x (/ (float pi x) 180))))) Notes:: ....... An approximation to \pi in some other precision can be obtained by writing (float pi x), where x is a float of the desired precision, or by writing (coerce pi type), where type is the desired type, such as short-float.  File: gcl.info, Node: sinh, Next: *, Prev: pi, Up: Numbers Dictionary 12.2.23 sinh, cosh, tanh, asinh, acosh, atanh [Function] -------------------------------------------------------- 'sinh' number => result 'cosh' number => result 'tanh' number => result 'asinh' number => result 'acosh' number => result 'atanh' number => result Arguments and Values:: ...................... number--a number. result--a number. Description:: ............. These functions compute the hyperbolic sine, cosine, tangent, arc sine, arc cosine, and arc tangent functions, which are mathematically defined for an argument x as given in Figure 12-15. Function Definition Hyperbolic sine (e^x-e^-x)/2 Hyperbolic cosine (e^x+e^-x)/2 Hyperbolic tangent (e^x-e^-x)/(e^x+e^-x) Hyperbolic arc sine log (x+\sqrt1+x^2) Hyperbolic arc cosine 2 log (\sqrt(x+1)/2 + \sqrt(x-1)/2) Hyperbolic arc tangent (log (1+x) - log (1-x))/2 Figure 12-15: Mathematical definitions for hyperbolic functions The following definition for the inverse hyperbolic cosine determines the range and branch cuts: arccosh z = 2 log (\sqrt(z+1)/2 + \sqrt(z-1)/2\Bigr). The branch cut for the inverse hyperbolic cosine function lies along the real axis to the left of~1 (inclusive), extending indefinitely along the negative real axis, continuous with quadrant II and (between 0 and~1) with quadrant I. The range is that half-strip of the complex plane containing numbers whose real part is non-negative and whose imaginary part is between -\pi (exclusive) and~\pi (inclusive). A number with real part zero is in the range if its imaginary part is between zero (inclusive) and~\pi (inclusive). The following definition for the inverse hyperbolic sine determines the range and branch cuts: arcsinh z = log (z+\sqrt1+z^2\Bigr). The branch cut for the inverse hyperbolic sine function is in two pieces: one along the positive imaginary axis above i (inclusive), continuous with quadrant I, and one along the negative imaginary axis below -i (inclusive), continuous with quadrant III. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and~\pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is non-positive; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is non-negative. The following definition for the inverse hyperbolic tangent determines the range and branch cuts: arctanh z = log (1+z) - log (1-z)\over2. Note that: i arctan z = arctanh iz. The branch cut for the inverse hyperbolic tangent function is in two pieces: one along the negative real axis to the left of -1 (inclusive), continuous with quadrant III, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant I. The points -1 and~1 are excluded from the domain. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and \pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is strictly negative; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is strictly positive. Thus the range of the inverse hyperbolic tangent function is identical to that of the inverse hyperbolic sine function with the points -\pi i/2 and~\pi i/2 excluded. Examples:: .......... (sinh 0) => 0.0 (cosh (complex 0 -1)) => #C(0.540302 -0.0) Exceptional Situations:: ........................ Should signal an error of type type-error if number is not a number. Might signal arithmetic-error. See Also:: .......... *note log:: , *note sqrt:: , *note Rule of Float Substitutability:: Notes:: ....... The result of acosh may be a complex even if number is not a complex; this occurs when number is less than one. Also, the result of atanh may be a complex even if number is not a complex; this occurs when the absolute value of number is greater than one. The branch cut formulae are mathematically correct, assuming completely accurate computation. Implementors should consult a good text on numerical analysis. The formulae given above are not necessarily the simplest ones for real-valued computations; they are chosen to define the branch cuts in desirable ways for the complex case.  File: gcl.info, Node: *, Next: +, Prev: sinh, Up: Numbers Dictionary 12.2.24 * [Function] -------------------- '*' &rest numbers => product Arguments and Values:: ...................... number--a number. product--a number. Description:: ............. Returns the product of numbers, performing any necessary type conversions in the process. If no numbers are supplied, 1 is returned. Examples:: .......... (*) => 1 (* 3 5) => 15 (* 1.0 #c(22 33) 55/98) => #C(12.346938775510203 18.520408163265305) Exceptional Situations:: ........................ Might signal type-error if some argument is not a number. Might signal arithmetic-error. See Also:: .......... *note Numeric Operations::, *note Rational Computations::, *note Floating-point Computations::, *note Complex Computations::  File: gcl.info, Node: +, Next: -, Prev: *, Up: Numbers Dictionary 12.2.25 + [Function] -------------------- '+' &rest numbers => sum Arguments and Values:: ...................... number--a number. sum--a number. Description:: ............. Returns the sum of numbers, performing any necessary type conversions in the process. If no numbers are supplied, 0 is returned. Examples:: .......... (+) => 0 (+ 1) => 1 (+ 31/100 69/100) => 1 (+ 1/5 0.8) => 1.0 Exceptional Situations:: ........................ Might signal type-error if some argument is not a number. Might signal arithmetic-error. See Also:: .......... *note Numeric Operations::, *note Rational Computations::, *note Floating-point Computations::, *note Complex Computations::  File: gcl.info, Node: -, Next: /, Prev: +, Up: Numbers Dictionary 12.2.26 - [Function] -------------------- '-' number => negation '-' minuend &rest subtrahends^+ => difference Arguments and Values:: ...................... number, minuend, subtrahend--a number. negation, difference--a number. Description:: ............. The function - performs arithmetic subtraction and negation. If only one number is supplied, the negation of that number is returned. If more than one argument is given, it subtracts all of the subtrahends from the minuend and returns the result. The function - performs necessary type conversions. Examples:: .......... (- 55.55) => -55.55 (- #c(3 -5)) => #C(-3 5) (- 0) => 0 (eql (- 0.0) -0.0) => true (- #c(100 45) #c(0 45)) => 100 (- 10 1 2 3 4) => 0 Exceptional Situations:: ........................ Might signal type-error if some argument is not a number. Might signal arithmetic-error. See Also:: .......... *note Numeric Operations::, *note Rational Computations::, *note Floating-point Computations::, *note Complex Computations::  File: gcl.info, Node: /, Next: 1+, Prev: -, Up: Numbers Dictionary 12.2.27 / [Function] -------------------- '/' number => reciprocal '/' numerator &rest denominators^+ => quotient Arguments and Values:: ...................... number, denominator--a non-zero number. numerator, quotient, reciprocal--a number. Description:: ............. The function / performs division or reciprocation. If no denominators are supplied, the function / returns the reciprocal of number. If at least one denominator is supplied, the function / divides the numerator by all of the denominators and returns the resulting quotient. If each argument is either an integer or a ratio, and the result is not an integer, then it is a ratio. The function / performs necessary type conversions. If any argument is a float then the rules of floating-point contagion apply; see *note Floating-point Computations::. Examples:: .......... (/ 12 4) => 3 (/ 13 4) => 13/4 (/ -8) => -1/8 (/ 3 4 5) => 3/20 (/ 0.5) => 2.0 (/ 20 5) => 4 (/ 5 20) => 1/4 (/ 60 -2 3 5.0) => -2.0 (/ 2 #c(2 2)) => #C(1/2 -1/2) Exceptional Situations:: ........................ The consequences are unspecified if any argument other than the first is zero. If there is only one argument, the consequences are unspecified if it is zero. Might signal type-error if some argument is not a number. Might signal division-by-zero if division by zero is attempted. Might signal arithmetic-error. See Also:: .......... *note floor:: , ceiling, truncate, round  File: gcl.info, Node: 1+, Next: abs, Prev: /, Up: Numbers Dictionary 12.2.28 1+, 1- [Function] ------------------------- '1' + => number successor '1' - => number predecessor Arguments and Values:: ...................... number--a number. successor, predecessor--a number. Description:: ............. 1+ returns a number that is one more than its argument number. 1- returns a number that is one less than its argument number. Examples:: .......... (1+ 99) => 100 (1- 100) => 99 (1+ (complex 0.0)) => #C(1.0 0.0) (1- 5/3) => 2/3 Exceptional Situations:: ........................ Might signal type-error if its argument is not a number. Might signal arithmetic-error. See Also:: .......... *note incf:: , decf Notes:: ....... (1+ number) == (+ number 1) (1- number) == (- number 1) Implementors are encouraged to make the performance of both the previous expressions be the same.  File: gcl.info, Node: abs, Next: evenp, Prev: 1+, Up: Numbers Dictionary 12.2.29 abs [Function] ---------------------- 'abs' number => absolute-value Arguments and Values:: ...................... number--a number. absolute-value--a non-negative real. Description:: ............. abs returns the absolute value of number. If number is a real, the result is of the same type as number. If number is a complex, the result is a positive real with the same magnitude as number. The result can be a float [Reviewer Note by Barmar: Single-float.] even if number's components are rationals and an exact rational result would have been possible. Thus the result of (abs #c(3 4)) can be either 5 or 5.0, depending on the implementation. Examples:: .......... (abs 0) => 0 (abs 12/13) => 12/13 (abs -1.09) => 1.09 (abs #c(5.0 -5.0)) => 7.071068 (abs #c(5 5)) => 7.071068 (abs #c(3/5 4/5)) => 1 or approximately 1.0 (eql (abs -0.0) -0.0) => true See Also:: .......... *note Rule of Float Substitutability:: Notes:: ....... If number is a complex, the result is equivalent to the following: (sqrt (+ (expt (realpart number) 2) (expt (imagpart number) 2))) An implementation should not use this formula directly for all complexes but should handle very large or very small components specially to avoid intermediate overflow or underflow.  File: gcl.info, Node: evenp, Next: exp, Prev: abs, Up: Numbers Dictionary 12.2.30 evenp, oddp [Function] ------------------------------ 'evenp' integer => generalized-boolean 'oddp' integer => generalized-boolean Arguments and Values:: ...................... integer--an integer. generalized-boolean--a generalized boolean. Description:: ............. evenp returns true if integer is even (divisible by two); otherwise, returns false. oddp returns true if integer is odd (not divisible by two); otherwise, returns false. Examples:: .......... (evenp 0) => true (oddp 10000000000000000000000) => false (oddp -1) => true Exceptional Situations:: ........................ Should signal an error of type type-error if integer is not an integer. Notes:: ....... (evenp integer) == (not (oddp integer)) (oddp integer) == (not (evenp integer))  File: gcl.info, Node: exp, Next: gcd, Prev: evenp, Up: Numbers Dictionary 12.2.31 exp, expt [Function] ---------------------------- 'exp' number => result 'expt' base-number power-number => result Arguments and Values:: ...................... number--a number. base-number--a number. power-number--a number. result--a number. Description:: ............. exp and expt perform exponentiation. exp returns e raised to the power number, where e is the base of the natural logarithms. exp has no branch cut. expt returns base-number raised to the power power-number. If the base-number is a rational and power-number is an integer, the calculation is exact and the result will be of type rational; otherwise a floating-point approximation might result. For expt of a complex rational to an integer power, the calculation must be exact and the result is of type (or rational (complex rational)). The result of expt can be a complex, even when neither argument is a complex, if base-number is negative and power-number is not an integer. The result is always the principal complex value. For example, (expt -8 1/3) is not permitted to return -2, even though -2 is one of the cube roots of -8. The principal cube root is a complex approximately equal to #C(1.0 1.73205), not -2. expt is defined as b^x = e^x log b\/. This defines the principal values precisely. The range of expt is the entire complex plane. Regarded as a function of x, with b fixed, there is no branch cut. Regarded as a function of b, with x fixed, there is in general a branch cut along the negative real axis, continuous with quadrant II. The domain excludes the origin. By definition, 0^0=1. If b=0 and the real part of x is strictly positive, then b^x=0. For all other values of x, 0^x is an error. When power-number is an integer 0, then the result is always the value one in the type of base-number, even if the base-number is zero (of any type). That is: (expt x 0) == (coerce 1 (type-of x)) If power-number is a zero of any other type, then the result is also the value one, in the type of the arguments after the application of the contagion rules in *note Contagion in Numeric Operations::, with one exception: the consequences are undefined if base-number is zero when power-number is zero and not of type integer. Examples:: .......... (exp 0) => 1.0 (exp 1) => 2.718282 (exp (log 5)) => 5.0 (expt 2 8) => 256 (expt 4 .5) => 2.0 (expt #c(0 1) 2) => -1 (expt #c(2 2) 3) => #C(-16 16) (expt #c(2 2) 4) => -64 See Also:: .......... *note log:: , *note Rule of Float Substitutability:: Notes:: ....... Implementations of expt are permitted to use different algorithms for the cases of a power-number of type rational and a power-number of type float. Note that by the following logic, (sqrt (expt x 3)) is not equivalent to (expt x 3/2). (setq x (exp (/ (* 2 pi #c(0 1)) 3))) ;exp(2.pi.i/3) (expt x 3) => 1 ;except for round-off error (sqrt (expt x 3)) => 1 ;except for round-off error (expt x 3/2) => -1 ;except for round-off error  File: gcl.info, Node: gcd, Next: incf, Prev: exp, Up: Numbers Dictionary 12.2.32 gcd [Function] ---------------------- 'gcd' &rest integers => greatest-common-denominator Arguments and Values:: ...................... integer--an integer. greatest-common-denominator--a non-negative integer. Description:: ............. Returns the greatest common divisor of integers. If only one integer is supplied, its absolute value is returned. If no integers are given, gcd returns 0, which is an identity for this operation. Examples:: .......... (gcd) => 0 (gcd 60 42) => 6 (gcd 3333 -33 101) => 1 (gcd 3333 -33 1002001) => 11 (gcd 91 -49) => 7 (gcd 63 -42 35) => 7 (gcd 5) => 5 (gcd -4) => 4 Exceptional Situations:: ........................ Should signal an error of type type-error if any integer is not an integer. See Also:: .......... *note lcm:: Notes:: ....... For three or more arguments, (gcd b c ... z) == (gcd (gcd a b) c ... z)  File: gcl.info, Node: incf, Next: lcm, Prev: gcd, Up: Numbers Dictionary 12.2.33 incf, decf [Macro] -------------------------- 'incf' place [delta-form] => new-value 'decf' place [delta-form] => new-value Arguments and Values:: ...................... place--a place. delta-form--a form; evaluated to produce a delta. The default is 1. delta--a number. new-value--a number. Description:: ............. incf and decf are used for incrementing and decrementing the value of place, respectively. The delta is added to (in the case of incf) or subtracted from (in the case of decf) the number in place and the result is stored in place. Any necessary type conversions are performed automatically. For information about the evaluation of subforms of places, see *note Evaluation of Subforms to Places::. Examples:: .......... (setq n 0) (incf n) => 1 n => 1 (decf n 3) => -2 n => -2 (decf n -5) => 3 (decf n) => 2 (incf n 0.5) => 2.5 (decf n) => 1.5 n => 1.5 Side Effects:: .............. Place is modified. See Also:: .......... +, *note -:: , 1+, 1-, *note setf::  File: gcl.info, Node: lcm, Next: log, Prev: incf, Up: Numbers Dictionary 12.2.34 lcm [Function] ---------------------- 'lcm' &rest integers => least-common-multiple Arguments and Values:: ...................... integer--an integer. least-common-multiple--a non-negative integer. Description:: ............. lcm returns the least common multiple of the integers. If no integer is supplied, the integer 1 is returned. If only one integer is supplied, the absolute value of that integer is returned. For two arguments that are not both zero, (lcm a b) == (/ (abs (* a b)) (gcd a b)) If one or both arguments are zero, (lcm a 0) == (lcm 0 a) == 0 For three or more arguments, (lcm a b c ... z) == (lcm (lcm a b) c ... z) Examples:: .......... (lcm 10) => 10 (lcm 25 30) => 150 (lcm -24 18 10) => 360 (lcm 14 35) => 70 (lcm 0 5) => 0 (lcm 1 2 3 4 5 6) => 60 Exceptional Situations:: ........................ Should signal type-error if any argument is not an integer. See Also:: .......... *note gcd::  File: gcl.info, Node: log, Next: mod (Function), Prev: lcm, Up: Numbers Dictionary 12.2.35 log [Function] ---------------------- 'log' number &optional base => logarithm Arguments and Values:: ...................... number--a non-zero number. base--a number. logarithm--a number. Description:: ............. log returns the logarithm of number in base base. If base is not supplied its value is e, the base of the natural logarithms. log may return a complex when given a real negative number. (log -1.0) == (complex 0.0 (float pi 0.0)) If base is zero, log returns zero. The result of (log 8 2) may be either 3 or 3.0, depending on the implementation. An implementation can use floating-point calculations even if an exact integer result is possible. The branch cut for the logarithm function of one argument (natural logarithm) lies along the negative real axis, continuous with quadrant II. The domain excludes the origin. The mathematical definition of a complex logarithm is as follows, whether or not minus zero is supported by the implementation: (log x) == (complex (log (abs x)) (phase x)) Therefore the range of the one-argument logarithm function is that strip of the complex plane containing numbers with imaginary parts between -\pi (exclusive) and~\pi (inclusive) if minus zero is not supported, or -\pi (inclusive) and~\pi (inclusive) if minus zero is supported. The two-argument logarithm function is defined as (log base number) == (/ (log number) (log base)) This defines the principal values precisely. The range of the two-argument logarithm function is the entire complex plane. Examples:: .......... (log 100 10) => 2.0 => 2 (log 100.0 10) => 2.0 (log #c(0 1) #c(0 -1)) => #C(-1.0 0.0) OR=> #C(-1 0) (log 8.0 2) => 3.0 (log #c(-16 16) #c(2 2)) => 3 or approximately #c(3.0 0.0) or approximately 3.0 (unlikely) Affected By:: ............. The implementation. See Also:: .......... *note exp:: , expt, *note Rule of Float Substitutability::  File: gcl.info, Node: mod (Function), Next: signum, Prev: log, Up: Numbers Dictionary 12.2.36 mod, rem [Function] --------------------------- 'mod' number divisor => modulus 'rem' number divisor => remainder Arguments and Values:: ...................... number--a real. divisor--a real. modulus, remainder--a real. Description:: ............. mod and rem are generalizations of the modulus and remainder functions respectively. mod performs the operation floor on number and divisor and returns the remainder of the floor operation. rem performs the operation truncate on number and divisor and returns the remainder of the truncate operation. mod and rem are the modulus and remainder functions when number and divisor are integers. Examples:: .......... (rem -1 5) => -1 (mod -1 5) => 4 (mod 13 4) => 1 (rem 13 4) => 1 (mod -13 4) => 3 (rem -13 4) => -1 (mod 13 -4) => -3 (rem 13 -4) => 1 (mod -13 -4) => -1 (rem -13 -4) => -1 (mod 13.4 1) => 0.4 (rem 13.4 1) => 0.4 (mod -13.4 1) => 0.6 (rem -13.4 1) => -0.4 See Also:: .......... *note floor:: , truncate Notes:: ....... The result of mod is either zero or a real with the same sign as divisor.  File: gcl.info, Node: signum, Next: sqrt, Prev: mod (Function), Up: Numbers Dictionary 12.2.37 signum [Function] ------------------------- 'signum' number => signed-prototype Arguments and Values:: ...................... number--a number. signed-prototype--a number. Description:: ............. signum determines a numerical value that indicates whether number is negative, zero, or positive. For a rational, signum returns one of -1, 0, or 1 according to whether number is negative, zero, or positive. For a float, the result is a float of the same format whose value is minus one, zero, or one. For a complex number z, (signum z) is a complex number of the same phase but with unit magnitude, unless z is a complex zero, in which case the result is z. For rational arguments, signum is a rational function, but it may be irrational for complex arguments. If number is a float, the result is a float. If number is a rational, the result is a rational. If number is a complex float, the result is a complex float. If number is a complex rational, the result is a complex, but it is implementation-dependent whether that result is a complex rational or a complex float. Examples:: .......... (signum 0) => 0 (signum 99) => 1 (signum 4/5) => 1 (signum -99/100) => -1 (signum 0.0) => 0.0 (signum #c(0 33)) => #C(0.0 1.0) (signum #c(7.5 10.0)) => #C(0.6 0.8) (signum #c(0.0 -14.7)) => #C(0.0 -1.0) (eql (signum -0.0) -0.0) => true See Also:: .......... *note Rule of Float Substitutability:: Notes:: ....... (signum x) == (if (zerop x) x (/ x (abs x)))  File: gcl.info, Node: sqrt, Next: random-state, Prev: signum, Up: Numbers Dictionary 12.2.38 sqrt, isqrt [Function] ------------------------------ 'sqrt' number => root 'isqrt' natural => natural-root Arguments and Values:: ...................... number, root--a number. natural, natural-root--a non-negative integer. Description:: ............. sqrt and isqrt compute square roots. sqrt returns the principal square root of number. If the number is not a complex but is negative, then the result is a complex. isqrt returns the greatest integer less than or equal to the exact positive square root of natural. If number is a positive rational, it is implementation-dependent whether root is a rational or a float. If number is a negative rational, it is implementation-dependent whether root is a complex rational or a complex float. The mathematical definition of complex square root (whether or not minus zero is supported) follows: (sqrt x) = (exp (/ (log x) 2)) The branch cut for square root lies along the negative real axis, continuous with quadrant II. The range consists of the right half-plane, including the non-negative imaginary axis and excluding the negative imaginary axis. Examples:: .......... (sqrt 9.0) => 3.0 (sqrt -9.0) => #C(0.0 3.0) (isqrt 9) => 3 (sqrt 12) => 3.4641016 (isqrt 12) => 3 (isqrt 300) => 17 (isqrt 325) => 18 (sqrt 25) => 5 OR=> 5.0 (isqrt 25) => 5 (sqrt -1) => #C(0.0 1.0) (sqrt #c(0 2)) => #C(1.0 1.0) Exceptional Situations:: ........................ The function sqrt should signal type-error if its argument is not a number. The function isqrt should signal type-error if its argument is not a non-negative integer. The functions sqrt and isqrt might signal arithmetic-error. See Also:: .......... *note exp:: , *note log:: , *note Rule of Float Substitutability:: Notes:: ....... (isqrt x) == (values (floor (sqrt x))) but it is potentially more efficient.  File: gcl.info, Node: random-state, Next: make-random-state, Prev: sqrt, Up: Numbers Dictionary 12.2.39 random-state [System Class] ----------------------------------- Class Precedence List:: ....................... random-state, t Description:: ............. A random state object contains state information used by the pseudo-random number generator. The nature of a random state object is implementation-dependent. It can be printed out and successfully read back in by the same implementation, but might not function correctly as a random state in another implementation. Implementations are required to provide a read syntax for objects of type random-state, but the specific nature of that syntax is implementation-dependent. See Also:: .......... *note random-state:: , *note random:: , *note Printing Random States::  File: gcl.info, Node: make-random-state, Next: random, Prev: random-state, Up: Numbers Dictionary 12.2.40 make-random-state [Function] ------------------------------------ 'make-random-state' &optional state => new-state Arguments and Values:: ...................... state--a random state, or nil, or t. The default is nil. new-state--a random state object. Description:: ............. Creates a fresh object of type random-state suitable for use as the value of *random-state*. If state is a random state object, the new-state is a copy_5 of that object. If state is nil, the new-state is a copy_5 of the current random state. If state is t, the new-state is a fresh random state object that has been randomly initialized by some means. Examples:: .......... (let* ((rs1 (make-random-state nil)) (rs2 (make-random-state t)) (rs3 (make-random-state rs2)) (rs4 nil)) (list (loop for i from 1 to 10 collect (random 100) when (= i 5) do (setq rs4 (make-random-state))) (loop for i from 1 to 10 collect (random 100 rs1)) (loop for i from 1 to 10 collect (random 100 rs2)) (loop for i from 1 to 10 collect (random 100 rs3)) (loop for i from 1 to 10 collect (random 100 rs4)))) => ((29 25 72 57 55 68 24 35 54 65) (29 25 72 57 55 68 24 35 54 65) (93 85 53 99 58 62 2 23 23 59) (93 85 53 99 58 62 2 23 23 59) (68 24 35 54 65 54 55 50 59 49)) Exceptional Situations:: ........................ Should signal an error of type type-error if state is not a random state, or nil, or t. See Also:: .......... *note random:: , *note random-state:: Notes:: ....... One important use of make-random-state is to allow the same series of pseudo-random numbers to be generated many times within a single program.  File: gcl.info, Node: random, Next: random-state-p, Prev: make-random-state, Up: Numbers Dictionary 12.2.41 random [Function] ------------------------- 'random' limit &optional random-state => random-number Arguments and Values:: ...................... limit--a positive integer, or a positive float. random-state--a random state. The default is the current random state. random-number--a non-negative number less than limit and of the same type as limit. Description:: ............. Returns a pseudo-random number that is a non-negative number less than limit and of the same type as limit. The random-state, which is modified by this function, encodes the internal state maintained by the random number generator. An approximately uniform choice distribution is used. If limit is an integer, each of the possible results occurs with (approximate) probability 1/limit. Examples:: .......... (<= 0 (random 1000) 1000) => true (let ((state1 (make-random-state)) (state2 (make-random-state))) (= (random 1000 state1) (random 1000 state2))) => true Side Effects:: .............. The random-state is modified. Exceptional Situations:: ........................ Should signal an error of type type-error if limit is not a positive integer or a positive real. See Also:: .......... *note make-random-state:: , *note random-state:: Notes:: ....... See Common Lisp: The Language for information about generating random numbers.  File: gcl.info, Node: random-state-p, Next: *random-state*, Prev: random, Up: Numbers Dictionary 12.2.42 random-state-p [Function] --------------------------------- 'random-state-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type random-state; otherwise, returns false. Examples:: .......... (random-state-p *random-state*) => true (random-state-p (make-random-state)) => true (random-state-p 'test-function) => false See Also:: .......... *note make-random-state:: , *note random-state:: Notes:: ....... (random-state-p object) == (typep object 'random-state)  File: gcl.info, Node: *random-state*, Next: numberp, Prev: random-state-p, Up: Numbers Dictionary 12.2.43 *random-state* [Variable] --------------------------------- Value Type:: ............ a random state. Initial Value:: ............... implementation-dependent. Description:: ............. The current random state, which is used, for example, by the function random when a random state is not explicitly supplied. Examples:: .......... (random-state-p *random-state*) => true (setq snap-shot (make-random-state)) ;; The series from any given point is random, ;; but if you backtrack to that point, you get the same series. (list (loop for i from 1 to 10 collect (random)) (let ((*random-state* snap-shot)) (loop for i from 1 to 10 collect (random))) (loop for i from 1 to 10 collect (random)) (let ((*random-state* snap-shot)) (loop for i from 1 to 10 collect (random)))) => ((19 16 44 19 96 15 76 96 13 61) (19 16 44 19 96 15 76 96 13 61) (16 67 0 43 70 79 58 5 63 50) (16 67 0 43 70 79 58 5 63 50)) Affected By:: ............. The implementation. random. See Also:: .......... *note make-random-state:: , *note random:: , random-state Notes:: ....... Binding *random-state* to a different random state object correctly saves and restores the old random state object.  File: gcl.info, Node: numberp, Next: cis, Prev: *random-state*, Up: Numbers Dictionary 12.2.44 numberp [Function] -------------------------- 'numberp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type number; otherwise, returns false. Examples:: .......... (numberp 12) => true (numberp (expt 2 130)) => true (numberp #c(5/3 7.2)) => true (numberp nil) => false (numberp (cons 1 2)) => false Notes:: ....... (numberp object) == (typep object 'number)  File: gcl.info, Node: cis, Next: complex, Prev: numberp, Up: Numbers Dictionary 12.2.45 cis [Function] ---------------------- 'cis' radians => number Arguments and Values:: ...................... radians--a real. number--a complex. Description:: ............. cis returns the value of~e^i\cdot radians, which is a complex in which the real part is equal to the cosine of radians, and the imaginary part is equal to the sine of radians. Examples:: .......... (cis 0) => #C(1.0 0.0) See Also:: .......... *note Rule of Float Substitutability::  File: gcl.info, Node: complex, Next: complexp, Prev: cis, Up: Numbers Dictionary 12.2.46 complex [Function] -------------------------- 'complex' realpart &optional imagpart => complex Arguments and Values:: ...................... realpart--a real. imagpart--a real. complex--a rational or a complex. Description:: ............. complex returns a number whose real part is realpart and whose imaginary part is imagpart. If realpart is a rational and imagpart is the rational number zero, the result of complex is realpart, a rational. Otherwise, the result is a complex. If either realpart or imagpart is a float, the non-float is converted to a float before the complex is created. If imagpart is not supplied, the imaginary part is a zero of the same type as realpart; i.e., (coerce 0 (type-of realpart)) is effectively used. Type upgrading implies a movement upwards in the type hierarchy lattice. In the case of complexes, the type-specifier [Reviewer Note by Barmar: What type specifier?] must be a subtype of (upgraded-complex-part-type type-specifier). If type-specifier1 is a subtype of type-specifier2, then (upgraded-complex-element-type 'type-specifier1) must also be a subtype of (upgraded-complex-element-type 'type-specifier2). Two disjoint types can be upgraded into the same thing. Examples:: .......... (complex 0) => 0 (complex 0.0) => #C(0.0 0.0) (complex 1 1/2) => #C(1 1/2) (complex 1 .99) => #C(1.0 0.99) (complex 3/2 0.0) => #C(1.5 0.0) See Also:: .......... *note realpart:: , imagpart Notes:: ....... #c(a b) == #.(complex a b)  File: gcl.info, Node: complexp, Next: conjugate, Prev: complex, Up: Numbers Dictionary 12.2.47 complexp [Function] --------------------------- 'complexp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type complex; otherwise, returns false. Examples:: .......... (complexp 1.2d2) => false (complexp #c(5/3 7.2)) => true See Also:: .......... *note complex:: (function and type), *note typep:: Notes:: ....... (complexp object) == (typep object 'complex)  File: gcl.info, Node: conjugate, Next: phase, Prev: complexp, Up: Numbers Dictionary 12.2.48 conjugate [Function] ---------------------------- 'conjugate' number => conjugate Arguments and Values:: ...................... number--a number. conjugate--a number. Description:: ............. Returns the complex conjugate of number. The conjugate of a real number is itself. Examples:: .......... (conjugate #c(0 -1)) => #C(0 1) (conjugate #c(1 1)) => #C(1 -1) (conjugate 1.5) => 1.5 (conjugate #C(3/5 4/5)) => #C(3/5 -4/5) (conjugate #C(0.0D0 -1.0D0)) => #C(0.0D0 1.0D0) (conjugate 3.7) => 3.7 Notes:: ....... For a complex number z, (conjugate z) == (complex (realpart z) (- (imagpart z)))  File: gcl.info, Node: phase, Next: realpart, Prev: conjugate, Up: Numbers Dictionary 12.2.49 phase [Function] ------------------------ 'phase' number => phase Arguments and Values:: ...................... number--a number. phase--a number. Description:: ............. phase returns the phase of number (the angle part of its polar representation) in radians, in the range -\pi (exclusive) if minus zero is not supported, or -\pi (inclusive) if minus zero is supported, to \pi (inclusive). The phase of a positive real number is zero; that of a negative real number is \pi. The phase of zero is defined to be zero. If number is a complex float, the result is a float of the same type as the components of number. If number is a float, the result is a float of the same type. If number is a rational or a complex rational, the result is a single float. The branch cut for phase lies along the negative real axis, continuous with quadrant II. The range consists of that portion of the real axis between -\pi (exclusive) and~\pi (inclusive). The mathematical definition of phase is as follows: (phase x) = (atan (imagpart x) (realpart x)) Examples:: .......... (phase 1) => 0.0s0 (phase 0) => 0.0s0 (phase (cis 30)) => -1.4159266 (phase #c(0 1)) => 1.5707964 Exceptional Situations:: ........................ Should signal type-error if its argument is not a number. Might signal arithmetic-error. See Also:: .......... *note Rule of Float Substitutability::  File: gcl.info, Node: realpart, Next: upgraded-complex-part-type, Prev: phase, Up: Numbers Dictionary 12.2.50 realpart, imagpart [Function] ------------------------------------- 'realpart' number => real 'imagpart' number => real Arguments and Values:: ...................... number--a number. real--a real. Description:: ............. realpart and imagpart return the real and imaginary parts of number respectively. If number is real, then realpart returns number and imagpart returns (* 0 number), which has the effect that the imaginary part of a rational is 0 and that of a float is a floating-point zero of the same format. Examples:: .......... (realpart #c(23 41)) => 23 (imagpart #c(23 41.0)) => 41.0 (realpart #c(23 41.0)) => 23.0 (imagpart 23.0) => 0.0 Exceptional Situations:: ........................ Should signal an error of type type-error if number is not a number. See Also:: .......... *note complex::  File: gcl.info, Node: upgraded-complex-part-type, Next: realp, Prev: realpart, Up: Numbers Dictionary 12.2.51 upgraded-complex-part-type [Function] --------------------------------------------- 'upgraded-complex-part-type' typespec &optional environment => upgraded-typespec Arguments and Values:: ...................... typespec--a type specifier. environment--an environment object. The default is nil, denoting the null lexical environment and the and current global environment. upgraded-typespec--a type specifier. Description:: ............. upgraded-complex-part-type returns the part type of the most specialized complex number representation that can hold parts of type typespec. The typespec is a subtype of (and possibly type equivalent to) the upgraded-typespec. The purpose of upgraded-complex-part-type is to reveal how an implementation does its upgrading. See Also:: .......... *note complex:: (function and type) Notes:: .......  File: gcl.info, Node: realp, Next: numerator, Prev: upgraded-complex-part-type, Up: Numbers Dictionary 12.2.52 realp [Function] ------------------------ 'realp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type real; otherwise, returns false. Examples:: .......... (realp 12) => true (realp #c(5/3 7.2)) => false (realp nil) => false (realp (cons 1 2)) => false Notes:: ....... (realp object) == (typep object 'real)  File: gcl.info, Node: numerator, Next: rational (Function), Prev: realp, Up: Numbers Dictionary 12.2.53 numerator, denominator [Function] ----------------------------------------- 'numerator' rational => numerator 'denominator' rational => denominator Arguments and Values:: ...................... rational--a rational. numerator--an integer. denominator--a positive integer. Description:: ............. numerator and denominator reduce rational to canonical form and compute the numerator or denominator of that number. numerator and denominator return the numerator or denominator of the canonical form of rational. If rational is an integer, numerator returns rational and denominator returns 1. Examples:: .......... (numerator 1/2) => 1 (denominator 12/36) => 3 (numerator -1) => -1 (denominator (/ -33)) => 33 (numerator (/ 8 -6)) => -4 (denominator (/ 8 -6)) => 3 See Also:: .......... *note /:: Notes:: ....... (gcd (numerator x) (denominator x)) => 1  File: gcl.info, Node: rational (Function), Next: rationalp, Prev: numerator, Up: Numbers Dictionary 12.2.54 rational, rationalize [Function] ---------------------------------------- 'rational' number => rational 'rationalize' number => rational Arguments and Values:: ...................... number--a real. rational--a rational. Description:: ............. rational and rationalize convert reals to rationals. If number is already rational, it is returned. If number is a float, rational returns a rational that is mathematically equal in value to the float. rationalize returns a rational that approximates the float to the accuracy of the underlying floating-point representation. rational assumes that the float is completely accurate. rationalize assumes that the float is accurate only to the precision of the floating-point representation. Examples:: .......... (rational 0) => 0 (rationalize -11/100) => -11/100 (rational .1) => 13421773/134217728 ;implementation-dependent (rationalize .1) => 1/10 Affected By:: ............. The implementation. Exceptional Situations:: ........................ Should signal an error of type type-error if number is not a real. Might signal arithmetic-error. Notes:: ....... It is always the case that (float (rational x) x) == x and (float (rationalize x) x) == x That is, rationalizing a float by either method and then converting it back to a float of the same format produces the original number.  File: gcl.info, Node: rationalp, Next: ash, Prev: rational (Function), Up: Numbers Dictionary 12.2.55 rationalp [Function] ---------------------------- 'rationalp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type rational; otherwise, returns false. Examples:: .......... (rationalp 12) => true (rationalp 6/5) => true (rationalp 1.212) => false See Also:: .......... *note rational (Function):: Notes:: ....... (rationalp object) == (typep object 'rational)  File: gcl.info, Node: ash, Next: integer-length, Prev: rationalp, Up: Numbers Dictionary 12.2.56 ash [Function] ---------------------- 'ash' integer count => shifted-integer Arguments and Values:: ...................... integer--an integer. count--an integer. shifted-integer--an integer. Description:: ............. ash performs the arithmetic shift operation on the binary representation of integer, which is treated as if it were binary. ash shifts integer arithmetically left by count bit positions if count is positive, or right count bit positions if count is negative. The shifted value of the same sign as integer is returned. Mathematically speaking, ash performs the computation floor(integer\cdot 2^count). Logically, ash moves all of the bits in integer to the left, adding zero-bits at the right, or moves them to the right, discarding bits. ash is defined to behave as if integer were represented in two's complement form, regardless of how integers are represented internally. Examples:: .......... (ash 16 1) => 32 (ash 16 0) => 16 (ash 16 -1) => 8 (ash -100000000000000000000000000000000 -100) => -79 Exceptional Situations:: ........................ Should signal an error of type type-error if integer is not an integer. Should signal an error of type type-error if count is not an integer. Might signal arithmetic-error. Notes:: ....... (logbitp j (ash n k)) == (and (>= j k) (logbitp (- j k) n))  File: gcl.info, Node: integer-length, Next: integerp, Prev: ash, Up: Numbers Dictionary 12.2.57 integer-length [Function] --------------------------------- 'integer-length' integer => number-of-bits Arguments and Values:: ...................... integer--an integer. number-of-bits--a non-negative integer. Description:: ............. Returns the number of bits needed to represent integer in binary two's-complement format. Examples:: .......... (integer-length 0) => 0 (integer-length 1) => 1 (integer-length 3) => 2 (integer-length 4) => 3 (integer-length 7) => 3 (integer-length -1) => 0 (integer-length -4) => 2 (integer-length -7) => 3 (integer-length -8) => 3 (integer-length (expt 2 9)) => 10 (integer-length (1- (expt 2 9))) => 9 (integer-length (- (expt 2 9))) => 9 (integer-length (- (1+ (expt 2 9)))) => 10 Exceptional Situations:: ........................ Should signal an error of type type-error if integer is not an integer. Notes:: ....... This function could have been defined by: (defun integer-length (integer) (ceiling (log (if (minusp integer) (- integer) (1+ integer)) 2))) If integer is non-negative, then its value can be represented in unsigned binary form in a field whose width in bits is no smaller than (integer-length integer). Regardless of the sign of integer, its value can be represented in signed binary two's-complement form in a field whose width in bits is no smaller than (+ (integer-length integer) 1).  File: gcl.info, Node: integerp, Next: parse-integer, Prev: integer-length, Up: Numbers Dictionary 12.2.58 integerp [Function] --------------------------- 'integerp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type integer; otherwise, returns false. Examples:: .......... (integerp 1) => true (integerp (expt 2 130)) => true (integerp 6/5) => false (integerp nil) => false Notes:: ....... (integerp object) == (typep object 'integer)  File: gcl.info, Node: parse-integer, Next: boole, Prev: integerp, Up: Numbers Dictionary 12.2.59 parse-integer [Function] -------------------------------- 'parse-integer' string &key start end radix junk-allowed => integer, pos Arguments and Values:: ...................... string--a string. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. radix--a radix. The default is 10. junk-allowed--a generalized boolean. The default is false. integer--an integer or false. pos--a bounding index of string. Description:: ............. parse-integer parses an integer in the specified radix from the substring of string delimited by start and end. parse-integer expects an optional sign (+ or -) followed by a a non-empty sequence of digits to be interpreted in the specified radix. Optional leading and trailing whitespace_1 is ignored. parse-integer does not recognize the syntactic radix-specifier prefixes #O, #B, #X, and #nR, nor does it recognize a trailing decimal point. If junk-allowed is false, an error of type parse-error is signaled if substring does not consist entirely of the representation of a signed integer, possibly surrounded on either side by whitespace_1 characters. The first value returned is either the integer that was parsed, or else nil if no syntactically correct integer was seen but junk-allowed was true. The second value is either the index into the string of the delimiter that terminated the parse, or the upper bounding index of the substring if the parse terminated at the end of the substring (as is always the case if junk-allowed is false). Examples:: .......... (parse-integer "123") => 123, 3 (parse-integer "123" :start 1 :radix 5) => 13, 3 (parse-integer "no-integer" :junk-allowed t) => NIL, 0 Exceptional Situations:: ........................ If junk-allowed is false, an error is signaled if substring does not consist entirely of the representation of an integer, possibly surrounded on either side by whitespace_1 characters.  File: gcl.info, Node: boole, Next: boole-1, Prev: parse-integer, Up: Numbers Dictionary 12.2.60 boole [Function] ------------------------ 'boole' op integer-1 integer-2 => result-integer Arguments and Values:: ...................... Op--a bit-wise logical operation specifier. integer-1--an integer. integer-2--an integer. result-integer--an integer. Description:: ............. boole performs bit-wise logical operations on integer-1 and integer-2, which are treated as if they were binary and in two's complement representation. The operation to be performed and the return value are determined by op. boole returns the values specified for any op in Figure 12-16. Op Result boole-1 integer-1 boole-2 integer-2 boole-andc1 and complement of integer-1 with integer-2 boole-andc2 and integer-1 with complement of integer-2 boole-and and boole-c1 complement of integer-1 boole-c2 complement of integer-2 boole-clr always 0 (all zero bits) boole-eqv equivalence (exclusive nor) boole-ior inclusive or boole-nand not-and boole-nor not-or boole-orc1 or complement of integer-1 with integer-2 boole-orc2 or integer-1 with complement of integer-2 boole-set always -1 (all one bits) boole-xor exclusive or Figure 12-16: Bit-Wise Logical Operations Examples:: .......... (boole boole-ior 1 16) => 17 (boole boole-and -2 5) => 4 (boole boole-eqv 17 15) => -31 ;;; These examples illustrate the result of applying BOOLE and each ;;; of the possible values of OP to each possible combination of bits. (progn (format t "~&Results of (BOOLE #b0011 #b0101) ...~ ~ (dolist (symbol '(boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) (let ((result (boole (symbol-value symbol) #b0011 #b0101))) (format t "~& ~A~13T~3,' D~23T~:*~5,' B~31T ...~4,'0B~ symbol result (logand result #b1111))))) |> Results of (BOOLE #b0011 #b0101) ... |> ---Op-------Decimal-----Binary----Bits--- |> BOOLE-1 3 11 ...0011 |> BOOLE-2 5 101 ...0101 |> BOOLE-AND 1 1 ...0001 |> BOOLE-ANDC1 4 100 ...0100 |> BOOLE-ANDC2 2 10 ...0010 |> BOOLE-C1 -4 -100 ...1100 |> BOOLE-C2 -6 -110 ...1010 |> BOOLE-CLR 0 0 ...0000 |> BOOLE-EQV -7 -111 ...1001 |> BOOLE-IOR 7 111 ...0111 |> BOOLE-NAND -2 -10 ...1110 |> BOOLE-NOR -8 -1000 ...1000 |> BOOLE-ORC1 -3 -11 ...1101 |> BOOLE-ORC2 -5 -101 ...1011 |> BOOLE-SET -1 -1 ...1111 |> BOOLE-XOR 6 110 ...0110 => NIL Exceptional Situations:: ........................ Should signal type-error if its first argument is not a bit-wise logical operation specifier or if any subsequent argument is not an integer. See Also:: .......... *note logand:: Notes:: ....... In general, (boole boole-and x y) == (logand x y) Programmers who would prefer to use numeric indices rather than bit-wise logical operation specifiers can get an equivalent effect by a technique such as the following: ;; The order of the values in this `table' are such that ;; (logand (boole (elt boole-n-vector n) #b0101 #b0011) #b1111) => n (defconstant boole-n-vector (vector boole-clr boole-and boole-andc1 boole-2 boole-andc2 boole-1 boole-xor boole-ior boole-nor boole-eqv boole-c1 boole-orc1 boole-c2 boole-orc2 boole-nand boole-set)) => BOOLE-N-VECTOR (proclaim '(inline boole-n)) => implementation-dependent (defun boole-n (n integer &rest more-integers) (apply #'boole (elt boole-n-vector n) integer more-integers)) => BOOLE-N (boole-n #b0111 5 3) => 7 (boole-n #b0001 5 3) => 1 (boole-n #b1101 5 3) => -3 (loop for n from #b0000 to #b1111 collect (boole-n n 5 3)) => (0 1 2 3 4 5 6 7 -8 -7 -6 -5 -4 -3 -2 -1) gcl-2.6.14/info/chap-15.texi0000644000175000017500000023120214360276512013757 0ustar cammcamm @node Arrays, Strings, Conses, Top @chapter Arrays @menu * Array Concepts:: * Arrays Dictionary:: @end menu @node Array Concepts, Arrays Dictionary, Arrays, Arrays @section Array Concepts @c including concept-arrays @menu * Array Elements:: * Specialized Arrays:: @end menu @node Array Elements, Specialized Arrays, Array Concepts, Array Concepts @subsection Array Elements An @i{array} contains a set of @i{objects} called @i{elements} that can be referenced individually according to a rectilinear coordinate system. @menu * Array Indices:: * Array Dimensions:: * Implementation Limits on Individual Array Dimensions:: * Array Rank:: * Vectors:: * Fill Pointers:: * Multidimensional Arrays:: * Storage Layout for Multidimensional Arrays:: * Implementation Limits on Array Rank:: @end menu @node Array Indices, Array Dimensions, Array Elements, Array Elements @subsubsection Array Indices An @i{array} @i{element} is referred to by a (possibly empty) series of indices. The length of the series must equal the @i{rank} of the @i{array}. Each index must be a non-negative @i{fixnum} less than the corresponding @i{array} @i{dimension}. @i{Array} indexing is zero-origin. @node Array Dimensions, Implementation Limits on Individual Array Dimensions, Array Indices, Array Elements @subsubsection Array Dimensions An axis of an @i{array} is called a @i{dimension} @IGindex dimension . Each @i{dimension} is a non-negative @i{fixnum}; if any dimension of an @i{array} is zero, the @i{array} has no elements. It is permissible for a @i{dimension} to be zero, in which case the @i{array} has no elements, and any attempt to @i{access} an @i{element} is an error. However, other properties of the @i{array}, such as the @i{dimensions} themselves, may be used. @node Implementation Limits on Individual Array Dimensions, Array Rank, Array Dimensions, Array Elements @subsubsection Implementation Limits on Individual Array Dimensions An @i{implementation} may impose a limit on @i{dimensions} of an @i{array}, but there is a minimum requirement on that limit. See the @i{variable} @b{array-dimension-limit}. @node Array Rank, Vectors, Implementation Limits on Individual Array Dimensions, Array Elements @subsubsection Array Rank An @i{array} can have any number of @i{dimensions} (including zero). The number of @i{dimensions} is called the @i{rank} @IGindex rank . If the rank of an @i{array} is zero then the @i{array} is said to have no @i{dimensions}, and the product of the dimensions (see @b{array-total-size}) is then 1; a zero-rank @i{array} therefore has a single element. @node Vectors, Fill Pointers, Array Rank, Array Elements @subsubsection Vectors An @i{array} of @i{rank} one (@i{i.e.}, a one-dimensional @i{array}) is called a @i{vector} @IGindex vector . @node Fill Pointers, Multidimensional Arrays, Vectors, Array Elements @subsubsection Fill Pointers A @i{fill pointer} @IGindex fill pointer is a non-negative @i{integer} no larger than the total number of @i{elements} in a @i{vector}. Not all @i{vectors} have @i{fill pointers}. See the @i{functions} @b{make-array} and @b{adjust-array}. An @i{element} of a @i{vector} is said to be @i{active} @IGindex active if it has an index that is greater than or equal to zero, but less than the @i{fill pointer} (if any). For an @i{array} that has no @i{fill pointer}, all @i{elements} are considered @i{active}. Only @i{vectors} may have @i{fill pointers}; multidimensional @i{arrays} may not. A multidimensional @i{array} that is displaced to a @i{vector} that has a @i{fill pointer} can be created. @node Multidimensional Arrays, Storage Layout for Multidimensional Arrays, Fill Pointers, Array Elements @subsubsection Multidimensional Arrays @node Storage Layout for Multidimensional Arrays, Implementation Limits on Array Rank, Multidimensional Arrays, Array Elements @subsubsection Storage Layout for Multidimensional Arrays Multidimensional @i{arrays} store their components in row-major order; that is, internally a multidimensional @i{array} is stored as a one-dimensional @i{array}, with the multidimensional index sets ordered lexicographically, last index varying fastest. @node Implementation Limits on Array Rank, , Storage Layout for Multidimensional Arrays, Array Elements @subsubsection Implementation Limits on Array Rank An @i{implementation} may impose a limit on the @i{rank} of an @i{array}, but there is a minimum requirement on that limit. See the @i{variable} @b{array-rank-limit}. @node Specialized Arrays, , Array Elements, Array Concepts @subsection Specialized Arrays An @i{array} can be a @i{general} @i{array}, meaning each @i{element} may be any @i{object}, or it may be a @i{specialized} @i{array}, meaning that each @i{element} must be of a restricted @i{type}. The phrasing ``an @i{array} @i{specialized} to @i{type} <<@i{type}>>'' is sometimes used to emphasize the @i{element type} of an @i{array}. This phrasing is tolerated even when the <<@i{type}>> is @b{t}, even though an @i{array} @i{specialized} to @i{type} @i{t} is a @i{general} @i{array}, not a @i{specialized} @i{array}. Figure 15--1 lists some @i{defined names} that are applicable to @i{array} creation, @i{access}, and information operations. @format @group @noindent @w{ adjust-array array-in-bounds-p svref } @w{ adjustable-array-p array-rank upgraded-array-element-type } @w{ aref array-rank-limit upgraded-complex-part-type } @w{ array-dimension array-row-major-index vector } @w{ array-dimension-limit array-total-size vector-pop } @w{ array-dimensions array-total-size-limit vector-push } @w{ array-element-type fill-pointer vector-push-extend } @w{ array-has-fill-pointer-p make-array } @noindent @w{ Figure 15--1: General Purpose Array-Related Defined Names } @end group @end format @menu * Array Upgrading:: * Required Kinds of Specialized Arrays:: @end menu @node Array Upgrading, Required Kinds of Specialized Arrays, Specialized Arrays, Specialized Arrays @subsubsection Array Upgrading The @i{upgraded array element type} @IGindex upgraded array element type of a @i{type} T_1 is a @i{type} T_2 that is a @i{supertype} of T_1 and that is used instead of T_1 whenever T_1 is used as an @i{array element type} for object creation or type discrimination. During creation of an @i{array}, the @i{element type} that was requested is called the @i{expressed array element type} @IGindex expressed array element type . The @i{upgraded array element type} of the @i{expressed array element type} becomes the @i{actual array element type} @IGindex actual array element type of the @i{array} that is created. @i{Type} @i{upgrading} implies a movement upwards in the type hierarchy lattice. A @i{type} is always a @i{subtype} of its @i{upgraded array element type}. Also, if a @i{type} T_x is a @i{subtype} of another @i{type} T_y, then the @i{upgraded array element type} of T_x must be a @i{subtype} of the @i{upgraded array element type} of T_y. Two @i{disjoint} @i{types} can be @i{upgraded} to the same @i{type}. The @i{upgraded array element type} T_2 of a @i{type} T_1 is a function only of T_1 itself; that is, it is independent of any other property of the @i{array} for which T_2 will be used, such as @i{rank}, @i{adjustability}, @i{fill pointers}, or displacement. The @i{function} @b{upgraded-array-element-type} can be used by @i{conforming programs} to predict how the @i{implementation} will @i{upgrade} a given @i{type}. @node Required Kinds of Specialized Arrays, , Array Upgrading, Specialized Arrays @subsubsection Required Kinds of Specialized Arrays @i{Vectors} whose @i{elements} are restricted to @i{type} @b{character} or a @i{subtype} of @b{character} are called @i{strings} @IGindex string . @i{Strings} are of @i{type} @b{string}. Figure 15--2 lists some @i{defined names} related to @i{strings}. @i{Strings} are @i{specialized} @i{arrays} and might logically have been included in this chapter. However, for purposes of readability most information about @i{strings} does not appear in this chapter; see instead @ref{Strings}. @format @group @noindent @w{ char string-equal string-upcase } @w{ make-string string-greaterp string@t{/=} } @w{ nstring-capitalize string-left-trim string@t{<} } @w{ nstring-downcase string-lessp string@t{<=} } @w{ nstring-upcase string-not-equal string@t{=} } @w{ schar string-not-greaterp string@t{>} } @w{ string string-not-lessp string@t{>=} } @w{ string-capitalize string-right-trim } @w{ string-downcase string-trim } @noindent @w{ Figure 15--2: Operators that Manipulate Strings } @end group @end format @i{Vectors} whose @i{elements} are restricted to @i{type} @b{bit} are called @i{bit vectors} @IGindex bit vector . @i{Bit vectors} are of @i{type} @b{bit-vector}. Figure 15--3 lists some @i{defined names} for operations on @i{bit arrays}. @format @group @noindent @w{ bit bit-ior bit-orc2 } @w{ bit-and bit-nand bit-xor } @w{ bit-andc1 bit-nor sbit } @w{ bit-andc2 bit-not } @w{ bit-eqv bit-orc1 } @noindent @w{ Figure 15--3: Operators that Manipulate Bit Arrays} @end group @end format @c end of including concept-arrays @node Arrays Dictionary, , Array Concepts, Arrays @section Arrays Dictionary @c including dict-arrays @menu * array:: * simple-array:: * vector (System Class):: * simple-vector:: * bit-vector:: * simple-bit-vector:: * make-array:: * adjust-array:: * adjustable-array-p:: * aref:: * array-dimension:: * array-dimensions:: * array-element-type:: * array-has-fill-pointer-p:: * array-displacement:: * array-in-bounds-p:: * array-rank:: * array-row-major-index:: * array-total-size:: * arrayp:: * fill-pointer:: * row-major-aref:: * upgraded-array-element-type:: * array-dimension-limit:: * array-rank-limit:: * array-total-size-limit:: * simple-vector-p:: * svref:: * vector:: * vector-pop:: * vector-push:: * vectorp:: * bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p:: @end menu @node array, simple-array, Arrays Dictionary, Arrays Dictionary @subsection array [System Class] @subsubheading Class Precedence List:: @b{array}, @b{t} @subsubheading Description:: An @i{array} contains @i{objects} arranged according to a Cartesian coordinate system. An @i{array} provides mappings from a set of @i{fixnums} \left@{i_0,i_1,\dots,i_@{r-1@}\right@} to corresponding @i{elements} of the @i{array}, where 0 \le i_j < d_j, r is the rank of the array, and d_j is the size of @i{dimension} j of the array. When an @i{array} is created, the program requesting its creation may declare that all @i{elements} are of a particular @i{type}, called the @i{expressed array element type}. The implementation is permitted to @i{upgrade} this type in order to produce the @i{actual array element type}, which is the @i{element type} for the @i{array} is actually @i{specialized}. See the @i{function} @b{upgraded-array-element-type}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) @w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} @subsubheading Compound Type Specifier Arguments:: @i{dimension}---a @i{valid array dimension}. @i{element-type}---a @i{type specifier}. @i{rank}---a non-negative @i{fixnum}. @subsubheading Compound Type Specifier Description:: This denotes the set of @i{arrays} whose @i{element type}, @i{rank}, and @i{dimensions} match any given @i{element-type}, @i{rank}, and @i{dimensions}. Specifically: If @i{element-type} is the @i{symbol} @b{*}, @i{arrays} are not excluded on the basis of their @i{element type}. Otherwise, only those @i{arrays} are included whose @i{actual array element type} is the result of @i{upgrading} @i{element-type}; see @ref{Array Upgrading}. If the @i{dimension-spec} is a @i{rank}, the set includes only those @i{arrays} having that @i{rank}. If the @i{dimension-spec} is a @i{list} of @i{dimensions}, the set includes only those @i{arrays} having a @i{rank} given by the @i{length} of the @i{dimensions}, and having the indicated @i{dimensions}; in this case, @b{*} matches any value for the corresponding @i{dimension}. If the @i{dimension-spec} is the @i{symbol} @b{*}, the set is not restricted on the basis of @i{rank} or @i{dimension}. @subsubheading See Also:: @b{*print-array*}, @ref{aref} , @ref{make-array} , @b{vector}, @ref{Sharpsign A}, @ref{Printing Other Arrays} @subsubheading Notes:: Note that the type @t{(array t)} is a proper @i{subtype} of the type @t{(array *)}. The reason is that the type @t{(array t)} is the set of @i{arrays} that can hold any @i{object} (the @i{elements} are of @i{type} @b{t}, which includes all @i{objects}). On the other hand, the type @t{(array *)} is the set of all @i{arrays} whatsoever, including for example @i{arrays} that can hold only @i{characters}. The type @t{(array character)} is not a @i{subtype} of the type @t{(array t)}; the two sets are @i{disjoint} because the type @t{(array character)} is not the set of all @i{arrays} that can hold @i{characters}, but rather the set of @i{arrays} that are specialized to hold precisely @i{characters} and no other @i{objects}. @node simple-array, vector (System Class), array, Arrays Dictionary @subsection simple-array [Type] @subsubheading Supertypes:: @b{simple-array}, @b{array}, @b{t} @subsubheading Description:: The @i{type} of an @i{array} that is not displaced to another @i{array}, has no @i{fill pointer}, and is not @i{expressly adjustable} is a @i{subtype} of @i{type} @b{simple-array}. The concept of a @i{simple array} exists to allow the implementation to use a specialized representation and to allow the user to declare that certain values will always be @i{simple arrays}. The @i{types} @b{simple-vector}, @b{simple-string}, and @b{simple-bit-vector} are @i{disjoint} @i{subtypes} of @i{type} @b{simple-array}, for they respectively mean @t{(simple-array t (*))}, the union of all @t{(simple-array @i{c} (*))} for any @i{c} being a @i{subtype} of @i{type} @b{character}, and @t{(simple-array bit (*))}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{simple-array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) @w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} @subsubheading Compound Type Specifier Arguments:: @i{dimension}---a @i{valid array dimension}. @i{element-type}---a @i{type specifier}. @i{rank}---a non-negative @i{fixnum}. @subsubheading Compound Type Specifier Description:: This @i{compound type specifier} is treated exactly as the corresponding @i{compound type specifier} for @i{type} @b{array} would be treated, except that the set is further constrained to include only @i{simple arrays}. @subsubheading Notes:: It is @i{implementation-dependent} whether @i{displaced arrays}, @i{vectors} with @i{fill pointers}, or arrays that are @i{actually adjustable} are @i{simple arrays}. @t{(simple-array *)} refers to all @i{simple arrays} regardless of element type, @t{(simple-array @i{type-specifier})} refers only to those @i{simple arrays} that can result from giving @i{type-specifier} as the @t{:element-type} argument to @b{make-array}. @node vector (System Class), simple-vector, simple-array, Arrays Dictionary @subsection vector [System Class] @subsubheading Class Precedence List:: @b{vector}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: Any one-dimensional @i{array} is a @i{vector}. The @i{type} @b{vector} is a @i{subtype} of @i{type} @b{array}; for all @i{types} @t{x}, @t{(vector x)} is the same as @t{(array x (*))}. The @i{type} @t{(vector t)}, the @i{type} @b{string}, and the @i{type} @b{bit-vector} are @i{disjoint} @i{subtypes} of @i{type} @b{vector}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{vector}@{@i{@t{[}@{element-type | @b{*}@} @r{[}@{size | @b{*}@}@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}. @i{element-type}---a @i{type specifier}. @subsubheading Compound Type Specifier Description:: This denotes the set of specialized @i{vectors} whose @i{element type} and @i{dimension} match the specified values. Specifically: If @i{element-type} is the @i{symbol} @b{*}, @i{vectors} are not excluded on the basis of their @i{element type}. Otherwise, only those @i{vectors} are included whose @i{actual array element type} is the result of @i{upgrading} @i{element-type}; see @ref{Array Upgrading}. If a @i{size} is specified, the set includes only those @i{vectors} whose only @i{dimension} is @i{size}. If the @i{symbol} @b{*} is specified instead of a @i{size}, the set is not restricted on the basis of @i{dimension}. @subsubheading See Also:: @ref{Required Kinds of Specialized Arrays}, @ref{Sharpsign Left-Parenthesis}, @ref{Printing Other Vectors}, @ref{Sharpsign A} @subsubheading Notes:: The @i{type} @t{(vector @i{e} @i{s})} is equivalent to the @i{type} @t{(array @i{e} (@i{s}))}. The type @t{(vector bit)} has the name @b{bit-vector}. The union of all @i{types} @t{(vector C)}, where C is any @i{subtype} of @b{character}, has the name @b{string}. @t{(vector *)} refers to all @i{vectors} regardless of element type, @t{(vector @i{type-specifier})} refers only to those @i{vectors} that can result from giving @i{type-specifier} as the @t{:element-type} argument to @b{make-array}. @node simple-vector, bit-vector, vector (System Class), Arrays Dictionary @subsection simple-vector [Type] @subsubheading Supertypes:: @b{simple-vector}, @b{vector}, @b{simple-array}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: The @i{type} of a @i{vector} that is not displaced to another @i{array}, has no @i{fill pointer}, is not @i{expressly adjustable} and is able to hold elements of any @i{type} is a @i{subtype} of @i{type} @b{simple-vector}. The @i{type} @b{simple-vector} is a @i{subtype} of @i{type} @b{vector}, and is a @i{subtype} of @i{type} @t{(vector t)}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{simple-vector}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. The default is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This is the same as @t{(simple-array t (@i{size}))}. @node bit-vector, simple-bit-vector, simple-vector, Arrays Dictionary @subsection bit-vector [System Class] @subsubheading Class Precedence List:: @b{bit-vector}, @b{vector}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: A @i{bit vector} is a @i{vector} the @i{element type} of which is @i{bit}. The @i{type} @b{bit-vector} is a @i{subtype} of @i{type} @b{vector}, for @b{bit-vector} means @t{(vector bit)}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{bit-vector}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the same @i{type} as the @i{type} @t{(array bit (@i{size}))}; that is, the set of @i{bit vectors} of size @i{size}. @subsubheading See Also:: @ref{Sharpsign Asterisk}, @ref{Printing Bit Vectors}, @ref{Required Kinds of Specialized Arrays} @node simple-bit-vector, make-array, bit-vector, Arrays Dictionary @subsection simple-bit-vector [Type] @subsubheading Supertypes:: @b{simple-bit-vector}, @b{bit-vector}, @b{vector}, @b{simple-array}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: The @i{type} of a @i{bit vector} that is not displaced to another @i{array}, has no @i{fill pointer}, and is not @i{expressly adjustable} is a @i{subtype} of @i{type} @b{simple-bit-vector}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{simple-bit-vector}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. The default is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the same type as the @i{type} @t{(simple-array bit (@i{size}))}; that is, the set of @i{simple bit vectors} of size @i{size}. @node make-array, adjust-array, simple-bit-vector, Arrays Dictionary @subsection make-array [Function] @code{make-array} @i{dimensions @r{&key} element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset}@* @result{} @i{new-array} @subsubheading Arguments and Values:: @i{dimensions}---a @i{designator} for a @i{list} of @i{valid array dimensions}. @i{element-type}---a @i{type specifier}. The default is @b{t}. @i{initial-element}---an @i{object}. @i{initial-contents}---an @i{object}. @i{adjustable}---a @i{generalized boolean}. The default is @b{nil}. @i{fill-pointer}---a @i{valid fill pointer} for the @i{array} to be created, or @b{t} or @b{nil}. The default is @b{nil}. @i{displaced-to}---an @i{array} or @b{nil}. The default is @b{nil}. This option must not be supplied if either @i{initial-element} or @i{initial-contents} is supplied. @i{displaced-index-offset}---a @i{valid array row-major index} for @i{displaced-to}. The default is @t{0}. This option must not be supplied unless a @i{non-nil} @i{displaced-to} is supplied. @i{new-array}---an @i{array}. @subsubheading Description:: Creates and returns an @i{array} constructed of the most @i{specialized} @i{type} that can accommodate elements of @i{type} given by @i{element-type}. If @i{dimensions} is @b{nil} then a zero-dimensional @i{array} is created. @i{Dimensions} represents the dimensionality of the new @i{array}. @i{element-type} indicates the @i{type} of the elements intended to be stored in the @i{new-array}. The @i{new-array} can actually store any @i{objects} of the @i{type} which results from @i{upgrading} @i{element-type}; see @ref{Array Upgrading}. If @i{initial-element} is supplied, it is used to initialize each @i{element} of @i{new-array}. If @i{initial-element} is supplied, it must be of the @i{type} given by @i{element-type}. @i{initial-element} cannot be supplied if either the @t{:initial-contents} option is supplied or @i{displaced-to} is @i{non-nil}. If @i{initial-element} is not supplied, the consequences of later reading an uninitialized @i{element} of @i{new-array} are undefined unless either @i{initial-contents} is supplied or @i{displaced-to} is @i{non-nil}. @i{initial-contents} is used to initialize the contents of @i{array}. For example: @example (make-array '(4 2 3) :initial-contents '(((a b c) (1 2 3)) ((d e f) (3 1 2)) ((g h i) (2 3 1)) ((j k l) (0 0 0)))) @end example @i{initial-contents} is composed of a nested structure of @i{sequences}. The numbers of levels in the structure must equal the rank of @i{array}. Each leaf of the nested structure must be of the @i{type} given by @i{element-type}. If @i{array} is zero-dimensional, then @i{initial-contents} specifies the single @i{element}. Otherwise, @i{initial-contents} must be a @i{sequence} whose length is equal to the first dimension; each element must be a nested structure for an @i{array} whose dimensions are the remaining dimensions, and so on. @i{Initial-contents} cannot be supplied if either @i{initial-element} is supplied or @i{displaced-to} is @i{non-nil}. If @i{initial-contents} is not supplied, the consequences of later reading an uninitialized @i{element} of @i{new-array} are undefined unless either @i{initial-element} is supplied or @i{displaced-to} is @i{non-nil}. If @i{adjustable} is @i{non-nil}, the array is @i{expressly adjustable} (and so @i{actually adjustable}); otherwise, the array is not @i{expressly adjustable} (and it is @i{implementation-dependent} whether the array is @i{actually adjustable}). If @i{fill-pointer} is @i{non-nil}, the @i{array} must be one-dimensional; that is, the @i{array} must be a @i{vector}. If @i{fill-pointer} is @b{t}, the length of the @i{vector} is used to initialize the @i{fill pointer}. If @i{fill-pointer} is an @i{integer}, it becomes the initial @i{fill pointer} for the @i{vector}. If @i{displaced-to} is @i{non-nil}, @b{make-array} will create a @i{displaced array} and @i{displaced-to} is the @i{target} of that @i{displaced array}. In that case, the consequences are undefined if the @i{actual array element type} of @i{displaced-to} is not @i{type equivalent} to the @i{actual array element type} of the @i{array} being created. If @i{displaced-to} is @b{nil}, the @i{array} is not a @i{displaced array}. The @i{displaced-index-offset} is made to be the index offset of the @i{array}. When an array A is given as the @t{:displaced-to} @i{argument} to @b{make-array} when creating array B, then array B is said to be displaced to array A. The total number of elements in an @i{array}, called the total size of the @i{array}, is calculated as the product of all the dimensions. It is required that the total size of A be no smaller than the sum of the total size of B plus the offset @t{n} supplied by the @i{displaced-index-offset}. The effect of displacing is that array B does not have any elements of its own, but instead maps @i{accesses} to itself into @i{accesses} to array A. The mapping treats both @i{arrays} as if they were one-dimensional by taking the elements in row-major order, and then maps an @i{access} to element @t{k} of array B to an @i{access} to element @t{k}+@t{n} of array A. If @b{make-array} is called with @i{adjustable}, @i{fill-pointer}, and @i{displaced-to} each @b{nil}, then the result is a @i{simple array}. If @b{make-array} is called with one or more of @i{adjustable}, @i{fill-pointer}, or @i{displaced-to} being @i{true}, whether the resulting @i{array} is a @i{simple array} is @i{implementation-dependent}. When an array A is given as the @t{:displaced-to} @i{argument} to @b{make-array} when creating array B, then array B is said to be displaced to array A. The total number of elements in an @i{array}, called the total size of the @i{array}, is calculated as the product of all the dimensions. The consequences are unspecified if the total size of A is smaller than the sum of the total size of B plus the offset @t{n} supplied by the @i{displaced-index-offset}. The effect of displacing is that array B does not have any elements of its own, but instead maps @i{accesses} to itself into @i{accesses} to array A. The mapping treats both @i{arrays} as if they were one-dimensional by taking the elements in row-major order, and then maps an @i{access} to element @t{k} of array B to an @i{access} to @i{element} @t{k}+@t{n} of array A. @subsubheading Examples:: @example (make-array 5) ;; Creates a one-dimensional array of five elements. (make-array '(3 4) :element-type '(mod 16)) ;; Creates a ;;two-dimensional array, 3 by 4, with four-bit elements. (make-array 5 :element-type 'single-float) ;; Creates an array of single-floats. @end example @example (make-array nil :initial-element nil) @result{} #0ANIL (make-array 4 :initial-element nil) @result{} #(NIL NIL NIL NIL) (make-array '(2 4) :element-type '(unsigned-byte 2) :initial-contents '((0 1 2 3) (3 2 1 0))) @result{} #2A((0 1 2 3) (3 2 1 0)) (make-array 6 :element-type 'character :initial-element #\a :fill-pointer 3) @result{} "aaa" @end example The following is an example of making a @i{displaced array}. @example (setq a (make-array '(4 3))) @result{} # (dotimes (i 4) (dotimes (j 3) (setf (aref a i j) (list i 'x j '= (* i j))))) @result{} NIL (setq b (make-array 8 :displaced-to a :displaced-index-offset 2)) @result{} # (dotimes (i 8) (print (list i (aref b i)))) @t{ |> } (0 (0 X 2 = 0)) @t{ |> } (1 (1 X 0 = 0)) @t{ |> } (2 (1 X 1 = 1)) @t{ |> } (3 (1 X 2 = 2)) @t{ |> } (4 (2 X 0 = 0)) @t{ |> } (5 (2 X 1 = 2)) @t{ |> } (6 (2 X 2 = 4)) @t{ |> } (7 (3 X 0 = 0)) @result{} NIL @end example The last example depends on the fact that @i{arrays} are, in effect, stored in row-major order. @example (setq a1 (make-array 50)) @result{} # (setq b1 (make-array 20 :displaced-to a1 :displaced-index-offset 10)) @result{} # (length b1) @result{} 20 (setq a2 (make-array 50 :fill-pointer 10)) @result{} # (setq b2 (make-array 20 :displaced-to a2 :displaced-index-offset 10)) @result{} # (length a2) @result{} 10 (length b2) @result{} 20 (setq a3 (make-array 50 :fill-pointer 10)) @result{} # (setq b3 (make-array 20 :displaced-to a3 :displaced-index-offset 10 :fill-pointer 5)) @result{} # (length a3) @result{} 10 (length b3) @result{} 5 @end example @subsubheading See Also:: @ref{adjustable-array-p} , @ref{aref} , @ref{arrayp} , @ref{array-element-type} , @ref{array-rank-limit} , @ref{array-dimension-limit} , @ref{fill-pointer} , @ref{upgraded-array-element-type} @subsubheading Notes:: There is no specified way to create an @i{array} for which @b{adjustable-array-p} definitely returns @i{false}. There is no specified way to create an @i{array} that is not a @i{simple array}. @node adjust-array, adjustable-array-p, make-array, Arrays Dictionary @subsection adjust-array [Function] @code{adjust-array} @i{array new-dimensions @r{&key} element-type initial-element initial-contents fill-pointer displaced-to displaced-index-offset}@* @result{} @i{adjusted-array} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{new-dimensions}---a @i{valid array dimension} or a @i{list} of @i{valid array dimensions}. @i{element-type}---a @i{type specifier}. @i{initial-element}---an @i{object}. @i{Initial-element} must not be supplied if either @i{initial-contents} or @i{displaced-to} is supplied. @i{initial-contents}---an @i{object}. If @i{array} has rank greater than zero, then @i{initial-contents} is composed of nested @i{sequences}, the depth of which must equal the rank of @i{array}. Otherwise, @i{array} is zero-dimensional and @i{initial-contents} supplies the single element. @i{initial-contents} must not be supplied if either @i{initial-element} or @i{displaced-to} is given. @i{fill-pointer}---a @i{valid fill pointer} for the @i{array} to be created, or @b{t}, or @b{nil}. The default is @b{nil}. @i{displaced-to}---an @i{array} or @b{nil}. @i{initial-elements} and @i{initial-contents} must not be supplied if @i{displaced-to} is supplied. @i{displaced-index-offset}---an @i{object} of @i{type} @t{(fixnum 0 @i{n})} where @i{n} is @t{(array-total-size @i{displaced-to})}. @i{displaced-index-offset} may be supplied only if @i{displaced-to} is supplied. @i{adjusted-array}---an @i{array}. @subsubheading Description:: @b{adjust-array} changes the dimensions or elements of @i{array}. The result is an @i{array} of the same @i{type} and rank as @i{array}, that is either the modified @i{array}, or a newly created @i{array} to which @i{array} can be displaced, and that has the given @i{new-dimensions}. @i{New-dimensions} specify the size of each @i{dimension} of @i{array}. @i{Element-type} specifies the @i{type} of the @i{elements} of the resulting @i{array}. If @i{element-type} is supplied, the consequences are unspecified if the @i{upgraded array element type} of @i{element-type} is not the same as the @i{actual array element type} of @i{array}. If @i{initial-contents} is supplied, it is treated as for @b{make-array}. In this case none of the original contents of @i{array} appears in the resulting @i{array}. If @i{fill-pointer} is an @i{integer}, it becomes the @i{fill pointer} for the resulting @i{array}. If @i{fill-pointer} is the symbol @b{t}, it indicates that the size of the resulting @i{array} should be used as the @i{fill pointer}. If @i{fill-pointer} is @b{nil}, it indicates that the @i{fill pointer} should be left as it is. If @i{displaced-to} @i{non-nil}, a @i{displaced array} is created. The resulting @i{array} shares its contents with the @i{array} given by @i{displaced-to}. The resulting @i{array} cannot contain more elements than the @i{array} it is displaced to. If @i{displaced-to} is not supplied or @b{nil}, the resulting @i{array} is not a @i{displaced array}. If array A is created displaced to array B and subsequently array B is given to @b{adjust-array}, array A will still be displaced to array B. Although @i{array} might be a @i{displaced array}, the resulting @i{array} is not a @i{displaced array} unless @i{displaced-to} is supplied and not @b{nil}. The interaction between @b{adjust-array} and displaced @i{arrays} is as follows given three @i{arrays}, @t{A}, @t{B}, and~@t{C}: @table @asis @item @t{A} is not displaced before or after the call @example (adjust-array A ...) @end example The dimensions of @t{A} are altered, and the contents rearranged as appropriate. Additional elements of @t{A} are taken from @i{initial-element}. The use of @i{initial-contents} causes all old contents to be discarded. @item @t{A} is not displaced before, but is displaced to @t{C} after the call @example (adjust-array A ... :displaced-to C) @end example None of the original contents of @t{A} appears in @t{A} afterwards; @t{A} now contains the contents of @t{C}, without any rearrangement of @t{C}. @item @t{A} is displaced to @t{B} before the call, and is displaced to @t{C} after the call @example (adjust-array A ... :displaced-to B) (adjust-array A ... :displaced-to C) @end example @t{B} and @t{C} might be the same. The contents of @t{B} do not appear in @t{A} afterward unless such contents also happen to be in @t{C} If @i{displaced-index-offset} is not supplied in the @b{adjust-array} call, it defaults to zero; the old offset into @t{B} is not retained. @item @t{A} is displaced to @t{B} before the call, but not displaced afterward. @example (adjust-array A ... :displaced-to B) (adjust-array A ... :displaced-to nil) @end example @t{A} gets a new ``data region,'' and contents of @t{B} are copied into it as appropriate to maintain the existing old contents; additional elements of @t{A} are taken from @i{initial-element} if supplied. However, the use of @i{initial-contents} causes all old contents to be discarded. @end table If @i{displaced-index-offset} is supplied, it specifies the offset of the resulting @i{array} from the beginning of the @i{array} that it is displaced to. If @i{displaced-index-offset} is not supplied, the offset is~0. The size of the resulting @i{array} plus the offset value cannot exceed the size of the @i{array} that it is displaced to. If only @i{new-dimensions} and an @i{initial-element} argument are supplied, those elements of @i{array} that are still in bounds appear in the resulting @i{array}. The elements of the resulting @i{array} that are not in the bounds of @i{array} are initialized to @i{initial-element}; if @i{initial-element} is not provided, the consequences of later reading any such new @i{element} of @i{new-array} before it has been initialized are undefined. If @i{initial-contents} or @i{displaced-to} is supplied, then none of the original contents of @i{array} appears in the new @i{array}. The consequences are unspecified if @i{array} is adjusted to a size smaller than its @i{fill pointer} without supplying the @i{fill-pointer} argument so that its @i{fill-pointer} is properly adjusted in the process. If @t{A} is displaced to @t{B}, the consequences are unspecified if @t{B} is adjusted in such a way that it no longer has enough elements to satisfy @t{A}. If @b{adjust-array} is applied to an @i{array} that is @i{actually adjustable}, the @i{array} returned is @i{identical} to @i{array}. If the @i{array} returned by @b{adjust-array} is @i{distinct} from @i{array}, then the argument @i{array} is unchanged. Note that if an @i{array} A is displaced to another @i{array} B, and B is displaced to another @i{array} C, and B is altered by @b{adjust-array}, A must now refer to the adjust contents of B. This means that an implementation cannot collapse the chain to make A refer to C directly and forget that the chain of reference passes through B. However, caching techniques are permitted as long as they preserve the semantics specified here. @subsubheading Examples:: @example (adjustable-array-p (setq ada (adjust-array (make-array '(2 3) :adjustable t :initial-contents '((a b c) (1 2 3))) '(4 6)))) @result{} T (array-dimensions ada) @result{} (4 6) (aref ada 1 1) @result{} 2 (setq beta (make-array '(2 3) :adjustable t)) @result{} #2A((NIL NIL NIL) (NIL NIL NIL)) (adjust-array beta '(4 6) :displaced-to ada) @result{} #2A((A B C NIL NIL NIL) (1 2 3 NIL NIL NIL) (NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL)) (array-dimensions beta) @result{} (4 6) (aref beta 1 1) @result{} 2 @end example Suppose that the 4-by-4 array in @t{m} looks like this: @example #2A(( alpha beta gamma delta ) ( epsilon zeta eta theta ) ( iota kappa lambda mu ) ( nu xi omicron pi )) @end example Then the result of @example (adjust-array m '(3 5) :initial-element 'baz) @end example is a 3-by-5 array with contents @example #2A(( alpha beta gamma delta baz ) ( epsilon zeta eta theta baz ) ( iota kappa lambda mu baz )) @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{error} is signaled if @i{fill-pointer} is supplied and @i{non-nil} but @i{array} has no @i{fill pointer}. @subsubheading See Also:: @ref{adjustable-array-p} , @ref{make-array} , @ref{array-dimension-limit} , @ref{array-total-size-limit} , @b{array} @node adjustable-array-p, aref, adjust-array, Arrays Dictionary @subsection adjustable-array-p [Function] @code{adjustable-array-p} @i{array} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns true if and only if @b{adjust-array} could return a @i{value} which is @i{identical} to @i{array} when given that @i{array} as its first @i{argument}. @subsubheading Examples:: @example (adjustable-array-p (make-array 5 :element-type 'character :adjustable t :fill-pointer 3)) @result{} @i{true} (adjustable-array-p (make-array 4)) @result{} @i{implementation-dependent} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @ref{adjust-array} , @ref{make-array} @node aref, array-dimension, adjustable-array-p, Arrays Dictionary @subsection aref [Accessor] @code{aref} @i{array @r{&rest} subscripts} @result{} @i{element} (setf (@code{ aref} @i{array @r{&rest} subscripts}) new-element)@* @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{subscripts}---a @i{list} of @i{valid array indices} for the @i{array}. @i{element}, @i{new-element}---an @i{object}. @subsubheading Description:: @i{Accesses} the @i{array} @i{element} specified by the @i{subscripts}. If no @i{subscripts} are supplied and @i{array} is zero rank, @b{aref} @i{accesses} the sole element of @i{array}. @b{aref} ignores @i{fill pointers}. It is permissible to use @b{aref} to @i{access} any @i{array} @i{element}, whether @i{active} or not. @subsubheading Examples:: If the variable @t{foo} names a 3-by-5 array, then the first index could be 0, 1, or 2, and then second index could be 0, 1, 2, 3, or 4. The array elements can be referred to by using the @i{function} @b{aref}; for example, @t{(aref foo 2 1)} refers to element (2, 1) of the array. @example (aref (setq alpha (make-array 4)) 3) @result{} @i{implementation-dependent} (setf (aref alpha 3) 'sirens) @result{} SIRENS (aref alpha 3) @result{} SIRENS (aref (setq beta (make-array '(2 4) :element-type '(unsigned-byte 2) :initial-contents '((0 1 2 3) (3 2 1 0)))) 1 2) @result{} 1 (setq gamma '(0 2)) (apply #'aref beta gamma) @result{} 2 (setf (apply #'aref beta gamma) 3) @result{} 3 (apply #'aref beta gamma) @result{} 3 (aref beta 0 2) @result{} 3 @end example @subsubheading See Also:: @ref{bit (Array)} , @ref{char} , @ref{elt} , @ref{row-major-aref} , @ref{svref} , @ref{Compiler Terminology} @node array-dimension, array-dimensions, aref, Arrays Dictionary @subsection array-dimension [Function] @code{array-dimension} @i{array axis-number} @result{} @i{dimension} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{axis-number}---an @i{integer} greater than or equal to zero and less than the @i{rank} of the @i{array}. @i{dimension}---a non-negative @i{integer}. @subsubheading Description:: @b{array-dimension} returns the @i{axis-number} @i{dimension}_1 of @i{array}. (Any @i{fill pointer} is ignored.) @subsubheading Examples:: @example (array-dimension (make-array 4) 0) @result{} 4 (array-dimension (make-array '(2 3)) 1) @result{} 3 @end example @subsubheading Affected By:: None. @subsubheading See Also:: @ref{array-dimensions} , @ref{length} @subsubheading Notes:: @example (array-dimension array n) @equiv{} (nth n (array-dimensions array)) @end example @node array-dimensions, array-element-type, array-dimension, Arrays Dictionary @subsection array-dimensions [Function] @code{array-dimensions} @i{array} @result{} @i{dimensions} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{dimensions}---a @i{list} of @i{integers}. @subsubheading Description:: Returns a @i{list} of the @i{dimensions} of @i{array}. (If @i{array} is a @i{vector} with a @i{fill pointer}, that @i{fill pointer} is ignored.) @subsubheading Examples:: @example (array-dimensions (make-array 4)) @result{} (4) (array-dimensions (make-array '(2 3))) @result{} (2 3) (array-dimensions (make-array 4 :fill-pointer 2)) @result{} (4) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @ref{array-dimension} @node array-element-type, array-has-fill-pointer-p, array-dimensions, Arrays Dictionary @subsection array-element-type [Function] @code{array-element-type} @i{array} @result{} @i{typespec} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{typespec}---a @i{type specifier}. @subsubheading Description:: Returns a @i{type specifier} which represents the @i{actual array element type} of the array, which is the set of @i{objects} that such an @i{array} can hold. (Because of @i{array} @i{upgrading}, this @i{type specifier} can in some cases denote a @i{supertype} of the @i{expressed array element type} of the @i{array}.) @subsubheading Examples:: @example (array-element-type (make-array 4)) @result{} T (array-element-type (make-array 12 :element-type '(unsigned-byte 8))) @result{} @i{implementation-dependent} (array-element-type (make-array 12 :element-type '(unsigned-byte 5))) @result{} @i{implementation-dependent} @end example @example (array-element-type (make-array 5 :element-type '(mod 5))) @end example could be @t{(mod 5)}, @t{(mod 8)}, @t{fixnum}, @t{t}, or any other type of which @t{(mod 5)} is a @i{subtype}. @subsubheading Affected By:: The @i{implementation}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @b{array}, @ref{make-array} , @ref{subtypep} , @ref{upgraded-array-element-type} @node array-has-fill-pointer-p, array-displacement, array-element-type, Arrays Dictionary @subsection array-has-fill-pointer-p [Function] @code{array-has-fill-pointer-p} @i{array} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{array} has a @i{fill pointer}; otherwise returns @i{false}. @subsubheading Examples:: @example (array-has-fill-pointer-p (make-array 4)) @result{} @i{implementation-dependent} (array-has-fill-pointer-p (make-array '(2 3))) @result{} @i{false} (array-has-fill-pointer-p (make-array 8 :fill-pointer 2 :initial-element 'filler)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @ref{make-array} , @ref{fill-pointer} @subsubheading Notes:: Since @i{arrays} of @i{rank} other than one cannot have a @i{fill pointer}, @b{array-has-fill-pointer-p} always returns @b{nil} when its argument is such an array. @node array-displacement, array-in-bounds-p, array-has-fill-pointer-p, Arrays Dictionary @subsection array-displacement [Function] @code{array-displacement} @i{array} @result{} @i{displaced-to, displaced-index-offset} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{displaced-to}---an @i{array} or @b{nil}. @i{displaced-index-offset}---a non-negative @i{fixnum}. @subsubheading Description:: If the @i{array} is a @i{displaced array}, returns the @i{values} of the @t{:displaced-to} and @t{:displaced-index-offset} options for the @i{array} (see the @i{functions} @b{make-array} and @b{adjust-array}). If the @i{array} is not a @i{displaced array}, @b{nil} and @t{0} are returned. If @b{array-displacement} is called on an @i{array} for which a @i{non-nil} @i{object} was provided as the @t{:displaced-to} @i{argument} to @b{make-array} or @b{adjust-array}, it must return that @i{object} as its first value. It is @i{implementation-dependent} whether @b{array-displacement} returns a @i{non-nil} @i{primary value} for any other @i{array}. @subsubheading Examples:: @example (setq a1 (make-array 5)) @result{} # (setq a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) @result{} # (array-displacement a2) @result{} #, 1 (setq a3 (make-array 2 :displaced-to a2 :displaced-index-offset 2)) @result{} # (array-displacement a3) @result{} #, 2 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{array} is not an @i{array}. @subsubheading See Also:: @ref{make-array} @node array-in-bounds-p, array-rank, array-displacement, Arrays Dictionary @subsection array-in-bounds-p [Function] @code{array-in-bounds-p} @i{array @r{&rest} subscripts} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{subscripts}---a list of @i{integers} of length equal to the @i{rank} of the @i{array}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if the @i{subscripts} are all in bounds for @i{array}; otherwise returns @i{false}. (If @i{array} is a @i{vector} with a @i{fill pointer}, that @i{fill pointer} is ignored.) @subsubheading Examples:: @example (setq a (make-array '(7 11) :element-type 'string-char)) (array-in-bounds-p a 0 0) @result{} @i{true} (array-in-bounds-p a 6 10) @result{} @i{true} (array-in-bounds-p a 0 -1) @result{} @i{false} (array-in-bounds-p a 0 11) @result{} @i{false} (array-in-bounds-p a 7 0) @result{} @i{false} @end example @subsubheading See Also:: @ref{array-dimensions} @subsubheading Notes:: @example (array-in-bounds-p array subscripts) @equiv{} (and (not (some #'minusp (list subscripts))) (every #'< (list subscripts) (array-dimensions array))) @end example @node array-rank, array-row-major-index, array-in-bounds-p, Arrays Dictionary @subsection array-rank [Function] @code{array-rank} @i{array} @result{} @i{rank} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{rank}---a non-negative @i{integer}. @subsubheading Description:: Returns the number of @i{dimensions} of @i{array}. @subsubheading Examples:: @example (array-rank (make-array '())) @result{} 0 (array-rank (make-array 4)) @result{} 1 (array-rank (make-array '(4))) @result{} 1 (array-rank (make-array '(2 3))) @result{} 2 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @ref{array-rank-limit} , @ref{make-array} @node array-row-major-index, array-total-size, array-rank, Arrays Dictionary @subsection array-row-major-index [Function] @code{array-row-major-index} @i{array @r{&rest} subscripts} @result{} @i{index} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{subscripts}---a @i{list} of @i{valid array indices} for the @i{array}. @i{index}---a @i{valid array row-major index} for the @i{array}. @subsubheading Description:: Computes the position according to the row-major ordering of @i{array} for the element that is specified by @i{subscripts}, and returns the offset of the element in the computed position from the beginning of @i{array}. For a one-dimensional @i{array}, the result of @b{array-row-major-index} equals @i{subscript}. @b{array-row-major-index} ignores @i{fill pointers}. @subsubheading Examples:: @example (setq a (make-array '(4 7) :element-type '(unsigned-byte 8))) (array-row-major-index a 1 2) @result{} 9 (array-row-major-index (make-array '(2 3 4) :element-type '(unsigned-byte 8) :displaced-to a :displaced-index-offset 4) 0 2 1) @result{} 9 @end example @subsubheading Notes:: A possible definition of @b{array-row-major-index}, with no error-checking, is @example (defun array-row-major-index (a &rest subscripts) (apply #'+ (maplist #'(lambda (x y) (* (car x) (apply #'* (cdr y)))) subscripts (array-dimensions a)))) @end example @node array-total-size, arrayp, array-row-major-index, Arrays Dictionary @subsection array-total-size [Function] @code{array-total-size} @i{array} @result{} @i{size} @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{size}---a non-negative @i{integer}. @subsubheading Description:: Returns the @i{array total size} of the @i{array}. @subsubheading Examples:: @example (array-total-size (make-array 4)) @result{} 4 (array-total-size (make-array 4 :fill-pointer 2)) @result{} 4 (array-total-size (make-array 0)) @result{} 0 (array-total-size (make-array '(4 2))) @result{} 8 (array-total-size (make-array '(4 0))) @result{} 0 (array-total-size (make-array '())) @result{} 1 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its argument is not an @i{array}. @subsubheading See Also:: @ref{make-array} , @ref{array-dimensions} @subsubheading Notes:: If the @i{array} is a @i{vector} with a @i{fill pointer}, the @i{fill pointer} is ignored when calculating the @i{array total size}. Since the product of no arguments is one, the @i{array total size} of a zero-dimensional @i{array} is one. @example (array-total-size x) @equiv{} (apply #'* (array-dimensions x)) @equiv{} (reduce #'* (array-dimensions x)) @end example @node arrayp, fill-pointer, array-total-size, Arrays Dictionary @subsection arrayp [Function] @code{arrayp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{array}; otherwise, returns @i{false}. @subsubheading Examples:: @example (arrayp (make-array '(2 3 4) :adjustable t)) @result{} @i{true} (arrayp (make-array 6)) @result{} @i{true} (arrayp #*1011) @result{} @i{true} (arrayp "hi") @result{} @i{true} (arrayp 'hi) @result{} @i{false} (arrayp 12) @result{} @i{false} @end example @subsubheading See Also:: @ref{typep} @subsubheading Notes:: @example (arrayp @i{object}) @equiv{} (typep @i{object} 'array) @end example @node fill-pointer, row-major-aref, arrayp, Arrays Dictionary @subsection fill-pointer [Accessor] @code{fill-pointer} @i{vector} @result{} @i{fill-pointer} (setf (@code{ fill-pointer} @i{vector}) new-fill-pointer)@* @subsubheading Arguments and Values:: @i{vector}---a @i{vector} with a @i{fill pointer}. @i{fill-pointer}, @i{new-fill-pointer}---a @i{valid fill pointer} for the @i{vector}. @subsubheading Description:: @i{Accesses} the @i{fill pointer} of @i{vector}. @subsubheading Examples:: @example (setq a (make-array 8 :fill-pointer 4)) @result{} #(NIL NIL NIL NIL) (fill-pointer a) @result{} 4 (dotimes (i (length a)) (setf (aref a i) (* i i))) @result{} NIL a @result{} #(0 1 4 9) (setf (fill-pointer a) 3) @result{} 3 (fill-pointer a) @result{} 3 a @result{} #(0 1 4) (setf (fill-pointer a) 8) @result{} 8 a @result{} #(0 1 4 9 NIL NIL NIL NIL) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{vector} is not a @i{vector} with a @i{fill pointer}. @subsubheading See Also:: @ref{make-array} , @ref{length} @subsubheading Notes:: There is no @i{operator} that will remove a @i{vector}'s @i{fill pointer}. @node row-major-aref, upgraded-array-element-type, fill-pointer, Arrays Dictionary @subsection row-major-aref [Accessor] @code{row-major-aref} @i{array index} @result{} @i{element} (setf (@code{ row-major-aref} @i{array index}) new-element)@* @subsubheading Arguments and Values:: @i{array}---an @i{array}. @i{index}---a @i{valid array row-major index} for the @i{array}. @i{element}, @i{new-element}---an @i{object}. @subsubheading Description:: Considers @i{array} as a @i{vector} by viewing its @i{elements} in row-major order, and returns the @i{element} of that @i{vector} which is referred to by the given @i{index}. @b{row-major-aref} is valid for use with @b{setf}. @subsubheading See Also:: @ref{aref} , @ref{array-row-major-index} @subsubheading Notes:: @example (row-major-aref array index) @equiv{} (aref (make-array (array-total-size array) :displaced-to array :element-type (array-element-type array)) index) (aref array i1 i2 ...) @equiv{} (row-major-aref array (array-row-major-index array i1 i2)) @end example @node upgraded-array-element-type, array-dimension-limit, row-major-aref, Arrays Dictionary @subsection upgraded-array-element-type [Function] @code{upgraded-array-element-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} @subsubheading Arguments and Values:: @i{typespec}---a @i{type specifier}. @i{environment}---an @i{environment} @i{object}. The default is @b{nil}, denoting the @i{null lexical environment} and the current @i{global environment}. @i{upgraded-typespec}---a @i{type specifier}. @subsubheading Description:: Returns the @i{element type} of the most @i{specialized} @i{array} representation capable of holding items of the @i{type} denoted by @i{typespec}. The @i{typespec} is a @i{subtype} of (and possibly @i{type equivalent} to) the @i{upgraded-typespec}. If @i{typespec} is @b{bit}, the result is @i{type equivalent} to @t{bit}. If @i{typespec} is @b{base-char}, the result is @i{type equivalent} to @t{base-char}. If @i{typespec} is @b{character}, the result is @i{type equivalent} to @t{character}. The purpose of @b{upgraded-array-element-type} is to reveal how an implementation does its @i{upgrading}. The @i{environment} is used to expand any @i{derived type specifiers} that are mentioned in the @i{typespec}. @subsubheading See Also:: @ref{array-element-type} , @ref{make-array} @subsubheading Notes:: Except for storage allocation consequences and dealing correctly with the optional @i{environment} @i{argument}, @b{upgraded-array-element-type} could be defined as: @example (defun upgraded-array-element-type (type &optional environment) (array-element-type (make-array 0 :element-type type))) @end example @node array-dimension-limit, array-rank-limit, upgraded-array-element-type, Arrays Dictionary @subsection array-dimension-limit [Constant Variable] @subsubheading Constant Value:: A positive @i{fixnum}, the exact magnitude of which is @i{implementation-dependent}, but which is not less than @t{1024}. @subsubheading Description:: The upper exclusive bound on each individual @i{dimension} of an @i{array}. @subsubheading See Also:: @ref{make-array} @node array-rank-limit, array-total-size-limit, array-dimension-limit, Arrays Dictionary @subsection array-rank-limit [Constant Variable] @subsubheading Constant Value:: A positive @i{fixnum}, the exact magnitude of which is @i{implementation-dependent}, but which is not less than @t{8}. @subsubheading Description:: The upper exclusive bound on the @i{rank} of an @i{array}. @subsubheading See Also:: @ref{make-array} @node array-total-size-limit, simple-vector-p, array-rank-limit, Arrays Dictionary @subsection array-total-size-limit [Constant Variable] @subsubheading Constant Value:: A positive @i{fixnum}, the exact magnitude of which is @i{implementation-dependent}, but which is not less than @t{1024}. @subsubheading Description:: The upper exclusive bound on the @i{array total size} of an @i{array}. The actual limit on the @i{array total size} imposed by the @i{implementation} might vary according the @i{element type} of the @i{array}; in this case, the value of @b{array-total-size-limit} will be the smallest of these possible limits. @subsubheading See Also:: @ref{make-array} , @ref{array-element-type} @node simple-vector-p, svref, array-total-size-limit, Arrays Dictionary @subsection simple-vector-p [Function] @code{simple-vector-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{simple-vector}; otherwise, returns @i{false}.. @subsubheading Examples:: @example (simple-vector-p (make-array 6)) @result{} @i{true} (simple-vector-p "aaaaaa") @result{} @i{false} (simple-vector-p (make-array 6 :fill-pointer t)) @result{} @i{false} @end example @subsubheading See Also:: @b{simple-vector} @subsubheading Notes:: @example (simple-vector-p @i{object}) @equiv{} (typep @i{object} 'simple-vector) @end example @node svref, vector, simple-vector-p, Arrays Dictionary @subsection svref [Accessor] @code{svref} @i{simple-vector index} @result{} @i{element} (setf (@code{ svref} @i{simple-vector index}) new-element)@* @subsubheading Arguments and Values:: @i{simple-vector}---a @i{simple vector}. @i{index}---a @i{valid array index} for the @i{simple-vector}. @i{element}, @i{new-element}---an @i{object} (whose @i{type} is a @i{subtype} of the @i{array element type} of the @i{simple-vector}). @subsubheading Description:: @i{Accesses} the @i{element} of @i{simple-vector} specified by @i{index}. @subsubheading Examples:: @example (simple-vector-p (setq v (vector 1 2 'sirens))) @result{} @i{true} (svref v 0) @result{} 1 (svref v 2) @result{} SIRENS (setf (svref v 1) 'newcomer) @result{} NEWCOMER v @result{} #(1 NEWCOMER SIRENS) @end example @subsubheading See Also:: @ref{aref} , @b{sbit}, @b{schar}, @ref{vector} , @ref{Compiler Terminology} @subsubheading Notes:: @b{svref} is identical to @b{aref} except that it requires its first argument to be a @i{simple vector}. @example (svref @i{v} @i{i}) @equiv{} (aref (the simple-vector @i{v}) @i{i}) @end example @node vector, vector-pop, svref, Arrays Dictionary @subsection vector [Function] @code{vector} @i{@r{&rest} objects} @result{} @i{vector} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{vector}---a @i{vector} of @i{type} @t{(vector t @t{*})}. @subsubheading Description:: Creates a @i{fresh} @i{simple general vector} whose size corresponds to the number of @i{objects}. The @i{vector} is initialized to contain the @i{objects}. @subsubheading Examples:: @example (arrayp (setq v (vector 1 2 'sirens))) @result{} @i{true} (vectorp v) @result{} @i{true} (simple-vector-p v) @result{} @i{true} (length v) @result{} 3 @end example @subsubheading See Also:: @ref{make-array} @subsubheading Notes:: @b{vector} is analogous to @b{list}. @example (vector a_1 a_2 ... a_n) @equiv{} (make-array (list @i{n}) :element-type t :initial-contents (list a_1 a_2 ... a_n)) @end example @node vector-pop, vector-push, vector, Arrays Dictionary @subsection vector-pop [Function] @code{vector-pop} @i{vector} @result{} @i{element} @subsubheading Arguments and Values:: @i{vector}---a @i{vector} with a @i{fill pointer}. @i{element}---an @i{object}. @subsubheading Description:: Decreases the @i{fill pointer} of @i{vector} by one, and retrieves the @i{element} of @i{vector} that is designated by the new @i{fill pointer}. @subsubheading Examples:: @example (vector-push (setq fable (list 'fable)) (setq fa (make-array 8 :fill-pointer 2 :initial-element 'sisyphus))) @result{} 2 (fill-pointer fa) @result{} 3 (eq (vector-pop fa) fable) @result{} @i{true} (vector-pop fa) @result{} SISYPHUS (fill-pointer fa) @result{} 1 @end example @subsubheading Side Effects:: The @i{fill pointer} is decreased by one. @subsubheading Affected By:: The value of the @i{fill pointer}. @subsubheading Exceptional Situations:: An error of @i{type} @b{type-error} is signaled if @i{vector} does not have a @i{fill pointer}. If the @i{fill pointer} is zero, @b{vector-pop} signals an error of @i{type} @b{error}. @subsubheading See Also:: @ref{vector-push} , @b{vector-push-extend}, @ref{fill-pointer} @node vector-push, vectorp, vector-pop, Arrays Dictionary @subsection vector-push, vector-push-extend [Function] @code{vector-push} @i{new-element vector} @result{} @i{new-index-p} @code{vector-push-extend} @i{new-element vector @r{&optional} extension} @result{} @i{new-index} @subsubheading Arguments and Values:: @i{new-element}---an @i{object}. @i{vector}---a @i{vector} with a @i{fill pointer}. @i{extension}---a positive @i{integer}. The default is @i{implementation-dependent}. @i{new-index-p}---a @i{valid array index} for @i{vector}, or @b{nil}. @i{new-index}---a @i{valid array index} for @i{vector}. @subsubheading Description:: @b{vector-push} and @b{vector-push-extend} store @i{new-element} in @i{vector}. @b{vector-push} attempts to store @i{new-element} in the element of @i{vector} designated by the @i{fill pointer}, and to increase the @i{fill pointer} by one. If the @t{(>= (fill-pointer @i{vector}) (array-dimension @i{vector} 0))}, neither @i{vector} nor its @i{fill pointer} are affected. Otherwise, the store and increment take place and @b{vector-push} returns the former value of the @i{fill pointer} which is one less than the one it leaves in @i{vector}. @b{vector-push-extend} is just like @b{vector-push} except that if the @i{fill pointer} gets too large, @i{vector} is extended using @b{adjust-array} so that it can contain more elements. @i{Extension} is the minimum number of elements to be added to @i{vector} if it must be extended. @b{vector-push} and @b{vector-push-extend} return the index of @i{new-element} in @i{vector}. If @t{(>= (fill-pointer @i{vector}) (array-dimension @i{vector} 0))}, @b{vector-push} returns @b{nil}. @subsubheading Examples:: @example (vector-push (setq fable (list 'fable)) (setq fa (make-array 8 :fill-pointer 2 :initial-element 'first-one))) @result{} 2 (fill-pointer fa) @result{} 3 (eq (aref fa 2) fable) @result{} @i{true} (vector-push-extend #\X (setq aa (make-array 5 :element-type 'character :adjustable t :fill-pointer 3))) @result{} 3 (fill-pointer aa) @result{} 4 (vector-push-extend #\Y aa 4) @result{} 4 (array-total-size aa) @result{} at least 5 (vector-push-extend #\Z aa 4) @result{} 5 (array-total-size aa) @result{} 9 ;(or more) @end example @subsubheading Affected By:: The value of the @i{fill pointer}. How @i{vector} was created. @subsubheading Exceptional Situations:: An error of @i{type} @b{error} is signaled by @b{vector-push-extend} if it tries to extend @i{vector} and @i{vector} is not @i{actually adjustable}. An error of @i{type} @b{error} is signaled if @i{vector} does not have a @i{fill pointer}. @subsubheading See Also:: @ref{adjustable-array-p} , @ref{fill-pointer} , @ref{vector-pop} @node vectorp, bit (Array), vector-push, Arrays Dictionary @subsection vectorp [Function] @code{vectorp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{vector}; otherwise, returns @i{false}. @subsubheading Examples:: @example (vectorp "aaaaaa") @result{} @i{true} (vectorp (make-array 6 :fill-pointer t)) @result{} @i{true} (vectorp (make-array '(2 3 4))) @result{} @i{false} (vectorp #*11) @result{} @i{true} (vectorp #b11) @result{} @i{false} @end example @subsubheading Notes:: @example (vectorp @i{object}) @equiv{} (typep @i{object} 'vector) @end example @node bit (Array), bit-and, vectorp, Arrays Dictionary @subsection bit, sbit [Accessor] @code{bit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} @code{sbit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} (setf (@code{bit} @i{bit-array @r{&rest} subscripts}) new-bit)@*(setf (@code{sbit} @i{bit-array @r{&rest} subscripts}) new-bit)@* @subsubheading Arguments and Values:: @i{bit-array}---for @b{bit}, a @i{bit array}; for @b{sbit}, a @i{simple bit array}. @i{subscripts}---a @i{list} of @i{valid array indices} for the @i{bit-array}. @i{bit}---a @i{bit}. @subsubheading Description:: @b{bit} and @b{sbit} @i{access} the @i{bit-array} @i{element} specified by @i{subscripts}. These @i{functions} ignore the @i{fill pointer} when @i{accessing} @i{elements}. @subsubheading Examples:: @example (bit (setq ba (make-array 8 :element-type 'bit :initial-element 1)) 3) @result{} 1 (setf (bit ba 3) 0) @result{} 0 (bit ba 3) @result{} 0 (sbit ba 5) @result{} 1 (setf (sbit ba 5) 1) @result{} 1 (sbit ba 5) @result{} 1 @end example @subsubheading See Also:: @ref{aref} , @ref{Compiler Terminology} @subsubheading Notes:: @b{bit} and @b{sbit} are like @b{aref} except that they require @i{arrays} to be a @i{bit array} and a @i{simple bit array}, respectively. @b{bit} and @b{sbit}, unlike @b{char} and @b{schar}, allow the first argument to be an @i{array} of any @i{rank}. @node bit-and, bit-vector-p, bit (Array), Arrays Dictionary @subsection bit-and, bit-andc1, bit-andc2, bit-eqv, @subheading bit-ior, bit-nand, bit-nor, bit-not, bit-orc1, bit-orc2, bit-xor @flushright @i{[Function]} @end flushright @code{bit-and} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-andc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-andc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-eqv} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-ior} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-nand} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-nor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-orc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-orc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-xor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @code{bit-not} @i{bit-array @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @subsubheading Arguments and Values:: @i{bit-array}, @i{bit-array1}, @i{bit-array2}---a @i{bit array}. @i{Opt-arg}---a @i{bit array}, or @b{t}, or @b{nil}. The default is @b{nil}. @i{Bit-array}, @i{bit-array1}, @i{bit-array2}, and @i{opt-arg} (if an @i{array}) must all be of the same @i{rank} and @i{dimensions}. @i{resulting-bit-array}---a @i{bit array}. @subsubheading Description:: These functions perform bit-wise logical operations on @i{bit-array1} and @i{bit-array2} and return an @i{array} of matching @i{rank} and @i{dimensions}, such that any given bit of the result is produced by operating on corresponding bits from each of the arguments. In the case of @b{bit-not}, an @i{array} of @i{rank} and @i{dimensions} matching @i{bit-array} is returned that contains a copy of @i{bit-array} with all the bits inverted. If @i{opt-arg} is of type @t{(array bit)} the contents of the result are destructively placed into @i{opt-arg}. If @i{opt-arg} is the symbol @b{t}, @i{bit-array} or @i{bit-array1} is replaced with the result; if @i{opt-arg} is @b{nil} or omitted, a new @i{array} is created to contain the result. Figure 15--4 indicates the logical operation performed by each of the @i{functions}. 2 @format @group @noindent @w{@b{Function} @b{Operation} } @w{_______________________________________________________________________________________________________} @w{ } @w{@b{bit-and} and } @w{@b{bit-eqv} equivalence (exclusive nor) } @w{@b{bit-not} complement } @w{@b{bit-ior} inclusive or } @w{@b{bit-xor} exclusive or } @w{@b{bit-nand} complement of @i{bit-array1} and @i{bit-array2} } @w{@b{bit-nor} complement of @i{bit-array1} or @i{bit-array2} } @w{@b{bit-andc1} and complement of @i{bit-array1} with @i{bit-array2}} @w{@b{bit-andc2} and @i{bit-array1} with complement of @i{bit-array2}} @w{@b{bit-orc1} or complement of @i{bit-array1} with @i{bit-array2} } @w{@b{bit-orc2} or @i{bit-array1} with complement of @i{bit-array2} } @w{@w{ Figure 15--3: Bit-wise Logical Operations on Bit Arrays} } @end group @end format @subsubheading Examples:: @example (bit-and (setq ba #*11101010) #*01101011) @result{} #*01101010 (bit-and #*1100 #*1010) @result{} #*1000 (bit-andc1 #*1100 #*1010) @result{} #*0010 (setq rba (bit-andc2 ba #*00110011 t)) @result{} #*11001000 (eq rba ba) @result{} @i{true} (bit-not (setq ba #*11101010)) @result{} #*00010101 (setq rba (bit-not ba (setq tba (make-array 8 :element-type 'bit)))) @result{} #*00010101 (equal rba tba) @result{} @i{true} (bit-xor #*1100 #*1010) @result{} #*0110 @end example @subsubheading See Also:: @b{lognot}, @ref{logand} @node bit-vector-p, simple-bit-vector-p, bit-and, Arrays Dictionary @subsection bit-vector-p [Function] @code{bit-vector-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{bit-vector}; otherwise, returns @i{false}. @subsubheading Examples:: @example (bit-vector-p (make-array 6 :element-type 'bit :fill-pointer t)) @result{} @i{true} (bit-vector-p #*) @result{} @i{true} (bit-vector-p (make-array 6)) @result{} @i{false} @end example @subsubheading See Also:: @ref{typep} @subsubheading Notes:: @example (bit-vector-p @i{object}) @equiv{} (typep @i{object} 'bit-vector) @end example @node simple-bit-vector-p, , bit-vector-p, Arrays Dictionary @subsection simple-bit-vector-p [Function] @code{simple-bit-vector-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{simple-bit-vector}; otherwise, returns @i{false}. @subsubheading Examples:: @example (simple-bit-vector-p (make-array 6)) @result{} @i{false} (simple-bit-vector-p #*) @result{} @i{true} @end example @subsubheading See Also:: @ref{simple-vector-p} @subsubheading Notes:: @example (simple-bit-vector-p @i{object}) @equiv{} (typep @i{object} 'simple-bit-vector) @end example @c end of including dict-arrays @c %**end of chapter gcl-2.6.14/info/general.texi0000755000175000017500000006303414360276512014247 0ustar cammcamm@c Copyright (c) 1994 William Schelter. @node General, Widgets, Top, Top @chapter General @menu * Introduction:: * Getting Started:: * Common Features of Widgets:: * Return Values:: * Argument Lists:: * Lisp Functions Invoked from Graphics:: * Linked Variables:: * tkconnect:: @end menu @node Introduction, Getting Started, General, General @section Introduction @b{GCL-TK} is a windowing interface for @b{GNU Common Lisp}. It provides the functionality of the @b{TK} widget set, which in turn implements a widget set which has the look and feel of @b{Motif}. The interface allows the user to draw graphics, get input from menus, make regions mouse sensitive, and bind lisp commands to regions. It communicates over a socket with a @file{gcltksrv} process, which speaks to the display via the @b{TK} library. The displaying process may run on a machine which is closer to the display, and so involves less communication. It also may remain active even though the lisp is involved in a separate user computation. The display server can, however, interrupt the lisp at will, to inquire about variables and run commands. The user may also interface with existing @code{TCL/TK} programs, binding some buttons, or tracking some objects. The size of the program is moderate. In its current form it adds only about 45K bytes to the lisp image, and the @file{gcltksrv} program uses shared libraries, and is on the order of 150Kbytes on a sparc. This chapter describes some of the common features of the command structure of widgets, and of control functions. The actual functions for construction of windows are discussed in @ref{Widgets}, and more general functions for making them appear, lowering them, querying about them in @ref{Control}. @node Getting Started, Common Features of Widgets, Introduction, General @section Getting Started Once @b{GCL} has been properly installed you should be able to do the following simple example: @example (in-package "TK") (tkconnect) (button '.hello :text "Hello World" :command '(print "hi")) ==>.HELLO (pack '.hello) @end example We first switched to the "TK" package, so that functions like button and pack would be found. After doing the tkconnect, a window should appear on your screen, see @xref{tkconnect}. The invocation of the function @code{button} creates a new function called @code{.hello} which is a @i{widget function}. It is then made visible in the window by using the @code{pack} function. You may now click on the little window, and you should see the command executed in your lisp. Thus "hi" should be printed in the lisp window. This will happen whether or not you have a job running in the lisp, that is lisp will be interrupted and your command will run, and then return the control to your program. The function @code{button} is called a widget constructor, and the function @code{.hello} is called a widget. If you have managed to accomplish the above, then @b{GCL} is probably installed correctly, and you can graduate to the next section! If you dont like reading but prefer to look at demos and code, then you should look in the demos directory, where you will find a number of examples. A monitor for the garbage collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), a sample listbox with scrolling (mklistbox). @node Common Features of Widgets, Return Values, Getting Started, General @section Common Features of Widgets A @i{widget} is a lisp symbol which has a function binding. The first argument is always a keyword and is called the @i{option}. The argument pattern for the remaining arguments depends on the @i{option}. The most common @i{option} is @code{:configure} in which case the remaining arguments are alternating keyword/value pairs, with the same keywords being permitted as at the creation of the widget. A @i{widget} is created by means of a @i{widget constructor}, of which there are currently 15, each of them appearing as the title of a section in @ref{Widgets}. They live in the @code{"TK"} package, and for the moment we will assume we have switched to this package. Thus for example @code{button} is such a widget constructor function. Of course this is lisp, and you can make your own widget constructors, but when you do so it is a good idea to follow the standard argument patterns that are outlined in this section. @example (button '.hello) ==> .HELLO @end example @noindent creates a @i{widget} whose name is @code{.hello}. There is a parent child hierarchy among widgets which is implicit in the name used for the widget. This is much like the pathname structure on a Unix or Dos file system, except that @code{'.'} is used as the separator rather than a @code{/} or @code{\}. For this reason the widget instances are sometimes referred to as @i{pathnames}. A child of the parent widget @code{.hello} might be called @code{.hello.joe}, and a child of this last might be @code{.hello.joe.bar}. The parent of everyone is called @code{.} . Multiple top level windows are created using the @code{toplevel} command (@pxref{toplevel}). The widget constructor functions take keyword and value pairs, which allow you to specify attributes at the time of creation: @example (button '.hello :text "Hello World" :width 20) ==>.HELLO @end example @noindent indicating that we want the text in the button window to be @code{Hello World} and the width of the window to be 20 characters wide. Other types of windows allow specification in centimeters @code{2c}, or in inches (@code{2i}) or in millimeters @code{2m} or in pixels @code{2}. But text windows usually have their dimensions specified as multiples of a character width and height. This latter concept is called a grid. Once the window has been created, if you want to change the text you do NOT do: @example (button '.hello :text "Bye World" :width 20) @end example This would be in error, because the window .hello already exists. You would either have to first call @example (destroy '.hello) @end example But usually you just want to change an attribute. @code{.hello} is actually a function, as we mentioned earlier, and it is this function that you use: @example (.hello :configure :text "Bye World") @end example This would simply change the text, and not change where the window had been placed on the screen (if it had), or how it had been packed into the window hierarchy. Here the argument @code{:configure} is called an @i{option}, and it specifies which types of keywords can follow it. For example @example (.hello :flash) @end example @noindent is also valid, but in this case the @code{:text} keyword is not permitted after flash. If it were, then it would mean something else besides what it means in the above. For example one might have defined @example (.hello :flash :text "PUSH ME") @end example @noindent so here the same keyword @code{:text} would mean something else, eg to flash a subliminal message on the screen. We often refer to calls to the widget functions as messages. One reason for this is that they actually turn into messages to the graphics process @file{gcltksrv}. To actually see these messages you can do @example (debugging t). @end example @node Return Values, Argument Lists, Common Features of Widgets, General @section Return Values @subsection Widget Constructor Return Values On successful completion, the widget constructor functions return the symbol passed in as the first argument. It will now have a functional binding. It is an error to pass in a symbol which already corresponds to a widget, without first calling the @code{destroy} command. On failure, an error is signalled. @subsection Widget Return Values The @i{widget} functions themselves, do not normally return any value. Indeed the lisp process does not wait for them to return, but merely dispatches the commands, such as to change the text in themselves. Sometimes however you either wish to wait, in order to synchronize, or you wish to see if your command fails or succeeds. You request values by passing the keyword :return and a value indicating the type. @example (.hello :configure :text "Bye World" :return 'string) ==> "" ==> T @end example @noindent the empty string is returned as first value, and the second value @code{T} indicates that the new text value was successfully set. LISP will not continue until the tkclsrv process indicates back that the function call has succeeded. While waiting of course LISP will continue to process other graphics events which arrive, since otherwise a deadlock would arise: the user for instance might click on a mouse, just after we had decided to wait for a return value from the @code{.hello} function. More generally a user program may be running in @b{GCL} and be interrupted to receive and act on communications from the @file{gcltksrv} process. If an error occurred then the second return value of the lisp function will be NIL. In this case the first value, the string is usually an informative message about the type of error. A special variable @code{tk::*break-on-errors*} which if not @code{nil}, requests that that @b{LISP} signal an error when a message is received indicating a function failed. Whenever a command fails, whether a return value was requested or not, @file{gcltksrv} returns a message indicating failure. The default is to not go into the debugger. When debugging your windows it may be convenient however to set this variable to @code{T} to track down incorrect messages. The @file{gcltksrv} process always returns strings as values. If @code{:return} @i{type} is specified, then conversion to @i{type} is accomplished by calling @example (coerce-result @i{return-string} @i{type}) @end example Here @i{type} must be a symbol with a @code{coercion-functions} property. The builtin return types which may be requested are: @table @code @item T in which case the string passed back from the @file{gcltksrv} process, will be read by the lisp reader. @item number the string is converted to a number using the current *read-base* @item list-strings @example (coerce-result "a b @{c d@} e" 'list-strings) ==> ("a" "b" "c d" "e") @end example @item boolean (coerce-result "1" 'boolean) ==> T (coerce-result "0" 'boolean) ==> NIL @end table The above symbols are in the @code{TK} or @code{LISP} package. It would be possible to add new types just as the @code{:return t} is done: @example (setf (get 't 'coercion-functions) (cons #'(lambda (x) (our-read-from-string x 0)) #'(lambda (x) (format nil "~s" x)))) @end example The @code{coercion-functions} property of a symbol, is a cons whose @code{car} is the coercion form from a string to some possibly different lisp object, and whose @code{cdr} is a function which builds a string to send to the graphics server. Often the two functions are inverse functions one of the other up to equal. @subsection Control Function Return Values The @i{control} functions (@pxref{Control}) do not return a value or wait unless requested to do so, using the @code{:return} keyword. The types and method of specification are the same as for the Widget Functions in the previous section. @example (winfo :width '.hello :return 'number) ==> 120 @end example @noindent indicates that the @code{.hello} button is actually 120 pixels wide. @node Argument Lists, Lisp Functions Invoked from Graphics, Return Values, General @section Argument Lists @subsection Widget Functions The rule is that the first argument for a widget function is a keyword, called the @i{option}. The pattern of the remaining arguments depends completely on the @i{option} argument. Thus @example (.hello @i{option} ?arg1? ?arg2? ...) @end example One @i{option} which is permitted for every widget function is @code{:configure}. The argument pattern following it is the same keyword/value pair list which is used in widget creation. For a @code{button} widget, the other valid options are @code{:deactivate}, @code{:flash}, and @code{:invoke}. To find these, since @code{.hello} was constructed with the @code{button} constructor, you should see @xref{button}. The argument pattern for other options depends completely on the option and the widget function. For example if @code{.scrollbar} is a scroll bar window, then the option @code{:set} must be followed by 4 numeric arguments, which indicate how the scrollbar should be displayed, see @xref{scrollbar}. @example (.scrollbar :set a1 a2 a3 a4) @end example If on the other hand @code{.scale} is a scale (@pxref{scale}), then we have @example (.scale :set a1 ) @end example @noindent only one numeric argument should be supplied, in order to position the scale. @subsection Widget Constructor Argument Lists These are @example (widget-constructor @i{pathname} :keyword1 value1 :keyword2 value2 ...) @end example @noindent to create the widget whose name is @i{pathname}. The possible keywords allowed are specified in the corresponding section of @xref{Widgets}. @subsection Concatenation Using `:' in Argument List What has been said so far about arguments is not quite true. A special string concatenation construction is allowed in argument lists for widgets, widget constructors and control functions. First we introduce the function @code{tk-conc} which takes an arbitrary number of arguments, which may be symbols, strings or numbers, and concatenates these into a string. The print names of symbols are converted to lower case, and package names are ignored. @example (tk-conc "a" 1 :b 'cd "e") ==> "a1bcde" @end example One could use @code{tk-conc} to construct arguments for widget functions. But even though @code{tk-conc} has been made quite efficient, it still would involve the creation of a string. The @code{:} construct avoids this. In a call to a widget function, a widget constructor, or a control function you may remove the call to @code{tk-conc} and place @code{:} in between each of its arguments. Those functions are able to understand this and treat the extra arguments as if they were glued together in one string, but without the extra cost of actually forming that string. @example (tk-conc a b c .. w) <==> a : b : c : ... w (setq i 10) (.hello :configure :text i : " pies") (.hello :configure :text (tk-conc i " pies")) (.hello :configure :text (format nil "~a pies" i)) @end example The last three examples would all result in the text string being @code{"10 pies"}, but the first method is the most efficient. That call will be made with no string or cons creation. The @b{GC Monitor} example, is written in such a way that there is no creation of @code{cons} or @code{string} types during normal operation. This is particularly useful in that case, since one is trying to monitor usage of conses by other programs, not its own usage. @node Lisp Functions Invoked from Graphics, Linked Variables, Argument Lists, General @section Lisp Functions Invoked from Graphics It is possible to make certain areas of a window mouse sensitive, or to run commands on reception of certain events such as keystrokes, while the focus is in a certain window. This is done by having a lisp function invoked or some lisp form evaluated. We shall refer to such a lisp function or form as a @emph{command}. For example @example (button '.button :text "Hello" :command '(print "hi")) (button '.jim :text "Call Jim" :command 'call-jim) @end example In the first case when the window @code{.button} is clicked on, the word "hi" will be printed in the lisp to standard output. In the second case @code{call-jim} will be funcalled with no arguments. A command must be one of the following three types. What happens depends on which type it is: @table @samp @item function If the value satisfies @code{functionp} then it will be called with a number of arguments which is dependent on the way it was bound, to graphics. @item string If the command is a string, then it is passed directly to @b{TCL/TK} for evaluation on that side. Lisp will not be required for the evaluation when the command is invoked. @item lisp form Any other lisp object is regarded as a lisp form to be eval'd, and this will be done when the command is invoked. @end table The following keywords accept as their value a command: @example :command :yscroll :yscrollcommand :xscroll :xscrollcommand :scrollcommand :bind @end example @noindent and in addition @code{bind} takes a command as its third argument, see @xref{bind}. @c todo!! Below we give three different examples using the 3 possibilities for a command: functionp, string, and lisp form. They all accomplish exactly the same thing. For given a frame @code{.frame} we could construct a listbox in it as: @example (listbox '.frame.listbox :yscroll 'joe) @end example Then whenever the listbox view position changes, or text is inserted, so that something changes, the function @code{joe} will be invoked with 4 arguments giving the totalsize of the text, maximum number of units the window can display, the index of the top unit, and finally the index of the bottom unit. What these arguments are is specific to the widget @code{listbox} and is documented @xref{listbox}. @code{joe} might be used to do anything, but a common usage is to have @code{joe} alter the position of some other window, such as a scroll bar window. Indeed if @code{.scrollbar} is a scrollbar then the function @example (defun joe (a b c d) (.scrollbar :set a b c d)) @end example @noindent would look after sizing the scrollbar appropriately for the percentage of the window visible, and positioning it. A second method of accomplishing this identical, using a string (the second type of command), @example (listbox '.frame.listbox :yscroll ".scrollbar set") @end example @noindent and this will not involve a call back to lisp. It uses the fact that the @b{TK} graphics side understands the window name @code{.scrollbar} and that it takes the @i{option} @code{set}. Note that it does not get the @code{:} before the keyword in this case. In the case of a command which is a @i{lisp form} but is not installed via @code{bind} or @code{:bind}, then the form will be installed as @example #'(lambda (&rest *arglist*) @i{lisp-form}) @end example @noindent where the @i{lisp-form} might wish to access the elements of the special variable @code{*arglist*}. Most often this list will be empty, but for example if the command was setup for @code{.scale} which is a @i{scale}, then the command will be supplied one argument which is the new numeric value which is the scale position. A third way of accomplishing the scrollbar setting using a lisp form is: @example (listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*)) @end example The @code{bind} command and @code{:bind} keyword, have an additional wrinkle, see @xref{bind}. These are associated to an event in a particular window, and the lisp function or form to be evaled must have access to that information. For example the x y position, the window name, the key pressed, etc. This is done via @i{percent symbols} which are specified, see @xref{bind}. @example (bind "Entry" "" '(emacs-move %W %A )) @end example @noindent will cause the function emacs-move to be be invoked whenever a control key is pressed (unless there are more key specific or window specific bindings of said key). It will be invoked with two arguments, the first %W indicating the window in which it was invoked, and the second being a string which is the ascii keysym which was pressed at the same time as the control key. These @i{percent constructs} are only permitted in commands which are invoked via @code{bind} or @code{:bind}. The lisp form which is passed as the command, is searched for the percent constructs, and then a function @example #'(lambda (%W %A) (emacs-move %W %A)) @end example @noindent will be invoked with two arguments, which will be supplied by the @b{TK} graphics server, at the time the command is invoked. The @code{*arglist*} construct is not available for these commands. @node Linked Variables, tkconnect, Lisp Functions Invoked from Graphics, General @section Linked Variables It is possible to link lisp variables to @b{TK} variables. In general when the @b{TK} variable is changed, by for instance clicking on a radiobutton, the linked lisp variable will be changed. Conversely changing the lisp variable will be noticed by the @b{TK} graphics side, if one does the assignment in lisp using @code{setk} instead of @code{setq}. @example (button '.hello :textvariable '*message* :text "hi there") (pack '.hello) @end example This causes linking of the global variable @code{*message*} in lisp to a corresponding variable in @b{TK}. Moreover the message that is in the button @code{.hello} will be whatever the value of this global variable is (so long as the @b{TK} side is notified of the change!). Thus if one does @example (setk *message* "good bye") @end example @noindent then the button will change to have @i{good bye} as its text. The lisp macro @code{setk} expands into @example (prog1 (setf *message* "good bye") (notice-text-variables)) @end example @noindent which does the assignment, and then goes thru the linked variables checking for those that have changed, and updating the @b{TK} side should there be any. Thus if you have a more complex program which might have done the assignment of your global variable, you may include the call to @code{notice-text-variables} at the end, to assure that the graphics side knows about the changes. A variable which is linked using the keyword @code{:textvariable} is always a variable containing a string. However it is possible to have other types of variables. @example (checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*)) (checkbutton '.checkbutton2 :text "A button" :variable '*joe*) (checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*) :onvalue 100 :offvalue -1) @end example The first two examples are the same in that the default variable type for a checkbutton is @code{boolean}. Notice that the specification of a variable type is by @code{(@i{type} variable)}. The types which are permissible are those which have coercion-fucntions, @xref{Return Values}. In the first example a variable @code{*joe*} will be linked, and its default initial value will be set to nil, since the default initial state of the check button is off, and the default off value is nil. Actually on the @b{TK} side, the corresponding boolean values are @code{"1"} and @code{"0"}, but the @code{boolean} type makes these become @code{t} and @code{nil}. In the third example the variable *debug* may have any lisp value (here @i{type} is @code{t}). The initial value will be made to be @code{-1}, since the checkbutton is off. Clicking on @code{.checkbutton3} will result in the value of @code{*debug*} being changed to 100, and the light in the button will be toggled to on, @xref{checkbutton}. You may set the variable to be another value besides 100. You may also call @example (link-text-variable '*joe* 'boolean) @end example @noindent to cause the linking of a variable named *joe*. This is done automatically whenever the variable is specified after one of the keys @example :variable :textvariable. @end example Just as one must be cautious about using global variables in lisp, one must be cautious in making such linked variables. In particular note that the @b{TK} side, uses variables for various purposes. If you make a checkbutton with pathname @code{.a.b.c} then unless you specify a @code{:variable} option, the variable @code{c} will become associated to the @b{TK} value of the checkbutton. We do NOT link this variable by default, feeling that one might inadvertently alter global variables, and that they would not typically use the lisp convention of being of the form @code{*c*}. You must specify the @code{:variable} option, or call @code{link-variable}. @node tkconnect, , Linked Variables, General @section tkconnect @example @i{tkconnect} &key host display can-rsh gcltksrv @end example This function provides a connection to a graphics server process, which in turn connects to possibly several graphics display screens. The graphics server process, called @file{gcltksrv} may or may not run on the same machine as the lisp to which it is attached. @code{display} indicates the name of the default display to connect to, and this in turn defaults to the value of the environment variable @code{DISPLAY}. When @i{tkconnect} is invoked, a socket is opened and it waits for a graphics process to connect to it. If the host argument is not supplied, then a process will be spawned which will connect back to the lisp process. The name of the command for invoking the process is the value of the @file{gcltksrv} argument, which defaults to the value of the environment variable @code{GCL_TK_SERVER}. If that variable is not set, then the lisp @code{*lib-directory*} is searched for an entry @file{gcl-tk/gcltksrv}. If @code{host} is supplied, then a command to run on the remote machine will be printed on standard output. If @code{can-rsh} is not nil, then the command will not be printed, but rather an attempt will be made to rsh to the machine, and to run the command. Thus @example (tkconnect) @end example @noindent would start the process on the local machine, and use for @code{display} the value of the environment variable @code{DISPLAY}. @example (tkconnect :host "max.ma.utexas.edu" :can-rsh t) @end example @noindent would cause an attempt to rsh to @code{max} and to run the command there, to connect back to the appropriate port on the localhost. You may indicate that different @i{toplevel} windows be on different displays, by using the @code{:display} argument when creating the window, @xref{toplevel}. Clearly you must have a copy of the program @file{gcltksrv} and @b{TK} libraries installed on the machine where you wish to run the server. gcl-2.6.14/info/system.texi0000755000175000017500000002572114360276512014157 0ustar cammcamm @node Operating System, Structures, Symbols, Top @chapter Operating System @menu * Command Line:: * Operating System Definitions:: @end menu @node Command Line, Operating System Definitions, Operating System, Operating System @section Command Line The variable si::*command-args* is set to the list of strings passed in when gcl is invoked. Various flags are understood. @vtable @code @item -eval Call read and then eval on the command argument following @code{-eval} @item -load Load the file whose pathname is specified after @code{-load}. @item -f Replace si::*command-args* by the the list starting after @code{-f}. Open the file following @code{-f} for input, skip the first line, and then read and eval the rest of the forms in the file. This can be used as with the shells to write small shell programs: @example #!/usr/local/bin/gcl.exe -f (format t "hello world ~a~%" (nth 1 si::*command-args*)) @end example The value si::*command-args* will have the appropriate value. Thus if the above 2 line file is made executable and called @file{foo} then @example tutorial% foo billy hello world billy @end example @noindent NOTE: On many systems (eg SunOs) the first line of an executable script file such as: @example #!/usr/local/bin/gcl.exe -f @end example only reads the first 32 characters! So if your pathname where the executable together with the '-f' amount to more than 32 characters the file will not be recognized. Also the executable must be the actual large binary file, [or a link to it], and not just a @code{/bin/sh} script. In latter case the @code{/bin/sh} interpreter would get invoked on the file. Alternately one could invoke the file @file{foo} without making it executable: @example tutorial% gcl -f foo "from bill" hello world from bill @end example Finally perhaps the best way (why do we save the best for last.. I guess because we only figure it out after all the others..) The following file @file{myhello} has 4 lines: @example #!/bin/sh #| Lisp will skip the next 2 lines on reading exec gcl -f "$0" $@ |# (format t "hello world ~a~%" (nth 1 si::*command-args*)) @end example @example marie% chmod a+x myhello marie% myhello bill hello world bill @end example The advantage of this method is that @file{gcl} can itself be a shell script, which sets up environment and so on. Also the normal path will be searched to find @file{gcl} The disadvantage is that this would cause 2 invocations of @file{sh} and one invocation of @file{gcl}. The plan using @file{gcl.exe} bypasses the @file{sh} entirely. Inded invoking @file{gcl.exe} to print @file{hello world} is faster on most systems than a similar @file{csh} or @file{bash} script, but slightly slower than the old @file{sh}. @item -batch Do not enter the command print loop. Useful if the other command line arguments do something. Do not print the License and acknowledgement information. Note if your program does print any License information, it must print the GCL header information also. @item -dir Directory where the executable binary that is running is located. Needed by save and friends. This gets set as si::*system-directory* @item -libdir @example -libdir @file{/d/wfs/gcl-2.0/} @end example would mean that the files like gcl-tk/tk.o would be found by concatting the path to the libdir path, ie in @example @file{/d/wfs/gcl-2.0/gcl-tk/tk.o} @end example @item -compile Invoke the compiler on the filename following @code{-compile}. Other flags affect compilation. @item -o-file If nil follows @code{-o-file} then do not produce an @code{.o} file. @item -c-file If @code{-c-file} is specified, leave the intermediate @code{.c} file there. @item -h-file If @code{-h-file} is specified, leave the intermediate @code{.h} file there. @item -data-file If @code{-data-file} is specified, leave the intermediate @code{.data} file there. @item -system-p If @code{-system-p} is specified then invoke @code{compile-file} with the @code{:system-p t} keyword argument, meaning that the C init function will bear a name based on the name of the file, so that it may be invoked by name by C code. @end vtable @node Operating System Definitions, , Command Line, Operating System @section Operating System Definitions @defun GET-DECODED-TIME () Package:LISP Returns the current time in decoded time format. Returns nine values: second, minute, hour, date, month, year, day-of-week, daylight-saving-time-p, and time-zone. @end defun @defun HOST-NAMESTRING (pathname) Package:LISP Returns the host part of PATHNAME as a string. @end defun @defun RENAME-FILE (file new-name) Package:LISP Renames the file FILE to NEW-NAME. FILE may be a string, a pathname, or a stream. @end defun @defun FILE-AUTHOR (file) Package:LISP Returns the author name of the specified file, as a string. FILE may be a string or a stream @end defun @defun PATHNAME-HOST (pathname) Package:LISP Returns the host slot of PATHNAME. @end defun @defun FILE-POSITION (file-stream &optional position) Package:LISP Sets the file pointer of the specified file to POSITION, if POSITION is given. Otherwise, returns the current file position of the specified file. @end defun @defun DECODE-UNIVERSAL-TIME (universal-time &optional (timezone -9)) Package:LISP Converts UNIVERSAL-TIME into a decoded time at the TIMEZONE. Returns nine values: second, minute, hour, date, month (1 - 12), year, day-of-week (0 - 6), daylight-saving-time-p, and time-zone. TIMEZONE in GCL defaults to 6, the time zone of Austin, Texas. @end defun @defun USER-HOMEDIR-PATHNAME (&optional host) Package:LISP Returns the home directory of the logged in user as a pathname. HOST is ignored. @end defun @defvar *MODULES* Package:LISP A list of names of the modules that have been loaded into GCL. @end defvar @defun SHORT-SITE-NAME () Package:LISP Returns a string that identifies the physical location of the current GCL. @end defun @defun DIRECTORY (name) Package:LISP Returns a list of files that match NAME. NAME may be a string, a pathname, or a file stream. @end defun @defun SOFTWARE-VERSION () Package:LISP Returns a string that identifies the software version of the software under which GCL is currently running. @end defun @defvr {Constant} INTERNAL-TIME-UNITS-PER-SECOND Package:LISP The number of internal time units that fit into a second. @end defvr @defun ENOUGH-NAMESTRING (pathname &optional (defaults *default-pathname-defaults*)) Package:LISP Returns a string which uniquely identifies PATHNAME with respect to DEFAULTS. @end defun @defun REQUIRE (module-name &optional (pathname)) Package:LISP If the specified module is not present, then loads the appropriate file(s). PATHNAME may be a single pathname or it may be a list of pathnames. @end defun @defun ENCODE-UNIVERSAL-TIME (second minute hour date month year &optional (timezone )) Package:LISP Does the inverse operation of DECODE-UNIVERSAL-TIME. @end defun @defun LISP-IMPLEMENTATION-VERSION () Package:LISP Returns a string that tells you when the current GCL implementation is brought up. @end defun @defun MACHINE-INSTANCE () Package:LISP Returns a string that identifies the machine instance of the machine on which GCL is currently running. @end defun @defun ROOM (&optional (x t)) Package:LISP Displays information about storage allocation in the following format. @itemize @asis{} @item for each type class @itemize @asis{} @item the number of pages so-far allocated for the type class @item the maximum number of pages for the type class @item the percentage of used cells to cells so-far allocated @item the number of times the garbage collector has been called to collect cells of the type class @item the implementation types that belongs to the type class @end itemize @item the number of pages actually allocated for contiguous blocks @item the maximum number of pages for contiguous blocks @item the number of times the garbage collector has been called to collect contiguous blocks @item the number of pages in the hole @item the maximum number of pages for relocatable blocks @item the number of times the garbage collector has been called to collect relocatable blocks @item the total number of pages allocated for cells @item the total number of pages allocated @item the number of available pages @item the number of pages GCL can use. The number of times the garbage collector has been called is not shown, if the number is zero. The optional X is ignored. @end itemize @end defun @defun GET-UNIVERSAL-TIME () Package:LISP Returns the current time as a single integer in universal time format. @end defun @defun GET-INTERNAL-RUN-TIME () Package:LISP Returns the run time in the internal time format. This is useful for finding CPU usage. If the operating system allows, a second value containing CPU usage of child processes is returned. @end defun @defvar *DEFAULT-PATHNAME-DEFAULTS* Package:LISP The default pathname-defaults pathname. @end defvar @defun LONG-SITE-NAME () Package:LISP Returns a string that identifies the physical location of the current GCL. @end defun @defun DELETE-FILE (file) Package:LISP Deletes FILE. @end defun @defun GET-INTERNAL-REAL-TIME () Package:LISP Returns the real time in the internal time format. This is useful for finding elapsed time. @end defun @defun MACHINE-TYPE () Package:LISP Returns a string that identifies the machine type of the machine on which GCL is currently running. @end defun @deffn {Macro} TIME Package:LISP Syntax: @example (time form) @end example Evaluates FORM and outputs timing statistics on *TRACE-OUTPUT*. @end deffn @defun SOFTWARE-TYPE () Package:LISP Returns a string that identifies the software type of the software under which GCL is currently running. @end defun @defun LISP-IMPLEMENTATION-TYPE () Package:LISP Returns a string that tells you that you are using a version of GCL. @end defun @defun SLEEP (n) Package:LISP This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number. @end defun @defun BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero floating-point-invalid-operation floating-point-overflow floating-point-underflow floating-point-inexact) Package:SI Break on the specified IEEE floating point error conditions. With no arguments, report the exceptions currently trapped. Disable the break by setting the key to nil, e.g. > (break-on-floaing-point-exceptions :division-by-zero t) (DIVISION-BY-ZERO) > (break-on-floaing-point-exceptions) (DIVISION-BY-ZERO) > (break-on-floaing-point-exceptions :division-by-zero nil) NIL On some of the most common platforms, the offending instruction will be disassembled, and the register arguments looked up in the saved context and reported in as operands. Within the error handler, addresses may be disassembled, and other registers inspected, using the functions defined in gcl_fpe.lsp. @end defun gcl-2.6.14/info/type.texi0000755000175000017500000000476114360276512013615 0ustar cammcamm@node Type, GCL Specific, Doc, Top @chapter Type @defun COERCE (x type) Package:LISP Coerces X to an object of the type TYPE. @end defun @defun TYPE-OF (x) Package:LISP Returns the type of X. @end defun @defun CONSTANTP (symbol) Package:LISP Returns T if the variable named by SYMBOL is a constant; NIL otherwise. @end defun @defun TYPEP (x type) Package:LISP Returns T if X is of the type TYPE; NIL otherwise. @end defun @defun COMMONP (x) Package:LISP Returns T if X is a Common Lisp object; NIL otherwise. @end defun @defun SUBTYPEP (type1 type2) Package:LISP Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If it could not determine, then returns NIL as the second value. Otherwise, the second value is T. @end defun @deffn {Macro} CHECK-TYPE Package:LISP Syntax: @example (check-type place typespec [string]) @end example Signals an error, if the contents of PLACE are not of the specified type. @end deffn @deffn {Macro} ASSERT Package:LISP Syntax: @example (assert test-form [(@{place@}*) [string @{arg@}*]]) @end example Signals an error if the value of TEST-FORM is NIL. STRING is an format string used as the error message. ARGs are arguments to the format string. @end deffn @deffn {Macro} DEFTYPE Package:LISP Syntax: @example (deftype name lambda-list @{decl | doc@}* @{form@}*) @end example Defines a new type-specifier abbreviation in terms of an 'expansion' function (lambda lambda-list1 @{decl@}* @{form@}*) where lambda-list1 is identical to LAMBDA-LIST except that all optional parameters with no default value specified in LAMBDA-LIST defaults to the symbol '*', but not to NIL. When the type system of GCL encounters a type specifier (NAME arg1 ... argn), it calls the expansion function with the arguments arg1 ... argn, and uses the returned value instead of the original type specifier. When the symbol NAME is used as a type specifier, the expansion function is called with no argument. The doc-string DOC, if supplied, is saved as the TYPE doc of NAME, and is retrieved by (documentation 'NAME 'type). @end deffn @defvr {Declaration} DYNAMIC-EXTENT Package:LISP Declaration to allow locals to be cons'd on the C stack. For example (defun foo (&rest l) (declare (:dynamic-extent l)) ...) will cause l to be a list formed on the C stack of the foo function frame. Of course passing L out as a value of foo will cause havoc. (setq x (make-list n)) (setq x (cons a b)) (setq x (list a b c ..)) also are handled on the stack, for dynamic-extent x. @end defvr gcl-2.6.14/info/gcl.texi0000644000175000017500000013050414360276512013371 0ustar cammcamm\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gcl.info @settitle ANSI and GNU Common Lisp Document @c %**end of header @setchapternewpage odd @ifinfo This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter @format INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY @end format @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @center @titlefont{GNU Common Lisp Manual} @end titlepage @defcodeindex fu @c function index @defcodeindex IR @c reference index @defcodeindex IC @c Code index @defindex IT @c Text index @defindex IG @c Glossary index @defindex IE @c Example index @defcodeindex IP @c Package index @c @defcodeindex IK @c Keyword Index @node Top, Introduction (Introduction), (dir), (dir) @menu * Introduction (Introduction):: * Syntax:: * Evaluation and Compilation:: * Types and Classes:: * Data and Control Flow:: * Iteration:: * Objects:: * Structures:: * Conditions:: * Symbols:: * Packages:: * Numbers (Numbers):: * Characters:: * Conses:: * Arrays:: * Strings:: * Sequences:: * Hash Tables:: * Filenames:: * Files:: * Streams:: * Printer:: * Reader:: * System Construction:: * Environment:: * Glossary (Glossary):: * Appendix:: --- The Detailed Node Listing --- Introduction * Scope:: * Organization of the Document:: * Referenced Publications:: * Definitions:: * Conformance:: * Language Extensions:: * Language Subsets:: * Deprecated Language Features:: * Symbols in the COMMON-LISP Package:: Scope, Purpose, and History * Scope and Purpose:: * History:: Definitions * Notational Conventions:: * Error Terminology:: * Sections Not Formally Part Of This Standard:: * Interpreting Dictionary Entries:: Notational Conventions * Font Key:: * Modified BNF Syntax:: * Splicing in Modified BNF Syntax:: * Indirection in Modified BNF Syntax:: * Additional Uses for Indirect Definitions in Modified BNF Syntax:: * Special Symbols:: * Objects with Multiple Notations:: * Case in Symbols:: * Numbers (Objects with Multiple Notations):: * Use of the Dot Character:: * NIL:: * Designators:: * Nonsense Words:: Interpreting Dictionary Entries * The "Affected By" Section of a Dictionary Entry:: * The "Arguments" Section of a Dictionary Entry:: * The "Arguments and Values" Section of a Dictionary Entry:: * The "Binding Types Affected" Section of a Dictionary Entry:: * The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: * The "Compound Type Specifier Kind" Section of a Dictionary Entry:: * The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: * The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: * The "Compound Type Specifier Description" Section of a Dictionary Entry:: * The "Constant Value" Section of a Dictionary Entry:: * The "Description" Section of a Dictionary Entry:: * The "Examples" Section of a Dictionary Entry:: * The "Exceptional Situations" Section of a Dictionary Entry:: * The "Initial Value" Section of a Dictionary Entry:: * The "Argument Precedence Order" Section of a Dictionary Entry:: * The "Method Signature" Section of a Dictionary Entry:: * The "Name" Section of a Dictionary Entry:: * The "Notes" Section of a Dictionary Entry:: * The "Pronunciation" Section of a Dictionary Entry:: * The "See Also" Section of a Dictionary Entry:: * The "Side Effects" Section of a Dictionary Entry:: * The "Supertypes" Section of a Dictionary Entry:: * The "Syntax" Section of a Dictionary Entry:: * Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: * Requiring Non-Null Rest Parameters in The "Syntax" Section:: * Return values in The "Syntax" Section:: * No Arguments or Values in The "Syntax" Section:: * Unconditional Transfer of Control in The "Syntax" Section:: * The "Valid Context" Section of a Dictionary Entry:: * The "Value Type" Section of a Dictionary Entry:: Conformance * Conforming Implementations:: * Conforming Programs:: Conforming Implementations * Required Language Features:: * Documentation of Implementation-Dependent Features:: * Documentation of Extensions:: * Treatment of Exceptional Situations:: * Resolution of Apparent Conflicts in Exceptional Situations:: * Examples of Resolution of Apparent Conflict in Exceptional Situations:: * Conformance Statement:: Conforming Programs * Use of Implementation-Defined Language Features:: * Use of Read-Time Conditionals:: Deprecated Language Features * Deprecated Functions:: * Deprecated Argument Conventions:: * Deprecated Variables:: * Deprecated Reader Syntax:: Syntax * Character Syntax:: * Reader Algorithm:: * Interpretation of Tokens:: * Standard Macro Characters:: Character Syntax * Readtables:: * Variables that affect the Lisp Reader:: * Standard Characters:: * Character Syntax Types:: Readtables * The Current Readtable:: * The Standard Readtable:: * The Initial Readtable:: Character Syntax Types * Constituent Characters:: * Constituent Traits:: * Invalid Characters:: * Macro Characters:: * Multiple Escape Characters:: * Examples of Multiple Escape Characters:: * Single Escape Character:: * Examples of Single Escape Characters:: * Whitespace Characters:: * Examples of Whitespace Characters:: Interpretation of Tokens * Numbers as Tokens:: * Constructing Numbers from Tokens:: * The Consing Dot:: * Symbols as Tokens:: * Valid Patterns for Tokens:: * Package System Consistency Rules:: Numbers as Tokens * Potential Numbers as Tokens:: * Escape Characters and Potential Numbers:: * Examples of Potential Numbers:: Constructing Numbers from Tokens * Syntax of a Rational:: * Syntax of an Integer:: * Syntax of a Ratio:: * Syntax of a Float:: * Syntax of a Complex:: Standard Macro Characters * Left-Parenthesis:: * Right-Parenthesis:: * Single-Quote:: * Semicolon:: * Double-Quote:: * Backquote:: * Comma:: * Sharpsign:: * Re-Reading Abbreviated Expressions:: Single-Quote * Examples of Single-Quote:: Semicolon * Examples of Semicolon:: * Notes about Style for Semicolon:: * Use of Single Semicolon:: * Use of Double Semicolon:: * Use of Triple Semicolon:: * Use of Quadruple Semicolon:: * Examples of Style for Semicolon:: Backquote * Notes about Backquote:: Sharpsign * Sharpsign Backslash:: * Sharpsign Single-Quote:: * Sharpsign Left-Parenthesis:: * Sharpsign Asterisk:: * Examples of Sharpsign Asterisk:: * Sharpsign Colon:: * Sharpsign Dot:: * Sharpsign B:: * Sharpsign O:: * Sharpsign X:: * Sharpsign R:: * Sharpsign C:: * Sharpsign A:: * Sharpsign S:: * Sharpsign P:: * Sharpsign Equal-Sign:: * Sharpsign Sharpsign:: * Sharpsign Plus:: * Sharpsign Minus:: * Sharpsign Vertical-Bar:: * Examples of Sharpsign Vertical-Bar:: * Notes about Style for Sharpsign Vertical-Bar:: * Sharpsign Less-Than-Sign:: * Sharpsign Whitespace:: * Sharpsign Right-Parenthesis:: Evaluation and Compilation * Evaluation:: * Compilation:: * Declarations:: * Lambda Lists:: * Error Checking in Function Calls:: * Traversal Rules and Side Effects:: * Destructive Operations:: * Evaluation and Compilation Dictionary:: Evaluation * Introduction to Environments:: * The Evaluation Model:: * Lambda Expressions:: * Closures and Lexical Binding:: * Shadowing:: * Extent:: * Return Values:: Introduction to Environments * The Global Environment:: * Dynamic Environments:: * Lexical Environments:: * The Null Lexical Environment:: * Environment Objects:: The Evaluation Model * Form Evaluation:: * Symbols as Forms:: * Lexical Variables:: * Dynamic Variables:: * Constant Variables:: * Symbols Naming Both Lexical and Dynamic Variables:: * Conses as Forms:: * Special Forms:: * Macro Forms:: * Function Forms:: * Lambda Forms:: * Self-Evaluating Objects:: * Examples of Self-Evaluating Objects:: Compilation * Compiler Terminology:: * Compilation Semantics:: * File Compilation:: * Literal Objects in Compiled Files:: * Exceptional Situations in the Compiler:: Compilation Semantics * Compiler Macros:: * Purpose of Compiler Macros:: * Naming of Compiler Macros:: * When Compiler Macros Are Used:: * Notes about the Implementation of Compiler Macros:: * Minimal Compilation:: * Semantic Constraints:: File Compilation * Processing of Top Level Forms:: * Processing of Defining Macros:: * Constraints on Macros and Compiler Macros:: Literal Objects in Compiled Files * Externalizable Objects:: * Similarity of Literal Objects:: * Similarity of Aggregate Objects:: * Definition of Similarity:: * Extensions to Similarity Rules:: * Additional Constraints on Externalizable Objects:: Declarations * Minimal Declaration Processing Requirements:: * Declaration Specifiers:: * Declaration Identifiers:: * Declaration Scope:: Declaration Identifiers * Shorthand notation for Type Declarations:: Declaration Scope * Examples of Declaration Scope:: Lambda Lists * Ordinary Lambda Lists:: * Generic Function Lambda Lists:: * Specialized Lambda Lists:: * Macro Lambda Lists:: * Destructuring Lambda Lists:: * Boa Lambda Lists:: * Defsetf Lambda Lists:: * Deftype Lambda Lists:: * Define-modify-macro Lambda Lists:: * Define-method-combination Arguments Lambda Lists:: * Syntactic Interaction of Documentation Strings and Declarations:: Ordinary Lambda Lists * Specifiers for the required parameters:: * Specifiers for optional parameters:: * A specifier for a rest parameter:: * Specifiers for keyword parameters:: * Suppressing Keyword Argument Checking:: * Examples of Suppressing Keyword Argument Checking:: * Specifiers for @b{&aux} variables:: * Examples of Ordinary Lambda Lists:: Macro Lambda Lists * Destructuring by Lambda Lists:: * Data-directed Destructuring by Lambda Lists:: * Examples of Data-directed Destructuring by Lambda Lists:: * Lambda-list-directed Destructuring by Lambda Lists:: Error Checking in Function Calls * Argument Mismatch Detection:: Argument Mismatch Detection * Safe and Unsafe Calls:: * Error Detection Time in Safe Calls:: * Too Few Arguments:: * Too Many Arguments:: * Unrecognized Keyword Arguments:: * Invalid Keyword Arguments:: * Odd Number of Keyword Arguments:: * Destructuring Mismatch:: * Errors When Calling a Next Method:: Destructive Operations * Modification of Literal Objects:: * Transfer of Control during a Destructive Operation:: Transfer of Control during a Destructive Operation * Examples of Transfer of Control during a Destructive Operation:: Evaluation and Compilation Dictionary * lambda (Symbol):: * lambda:: * compile:: * eval:: * eval-when:: * load-time-value:: * quote:: * compiler-macro-function:: * define-compiler-macro:: * defmacro:: * macro-function:: * macroexpand:: * define-symbol-macro:: * symbol-macrolet:: * *macroexpand-hook*:: * proclaim:: * declaim:: * declare:: * ignore:: * dynamic-extent:: * type:: * inline:: * ftype:: * declaration:: * optimize:: * special:: * locally:: * the:: * special-operator-p:: * constantp:: Types and Classes * Introduction (Types and Classes):: * Types:: * Classes:: * Types and Classes Dictionary:: Types * Data Type Definition:: * Type Relationships:: * Type Specifiers:: Classes * Introduction to Classes:: * Defining Classes:: * Creating Instances of Classes:: * Inheritance:: * Determining the Class Precedence List:: * Redefining Classes:: * Integrating Types and Classes:: Introduction to Classes * Standard Metaclasses:: Inheritance * Examples of Inheritance:: * Inheritance of Class Options:: Determining the Class Precedence List * Topological Sorting:: * Examples of Class Precedence List Determination:: Redefining Classes * Modifying the Structure of Instances:: * Initializing Newly Added Local Slots (Redefining Classes):: * Customizing Class Redefinition:: Types and Classes Dictionary * nil (Type):: * boolean:: * function (System Class):: * compiled-function:: * generic-function:: * standard-generic-function:: * class:: * built-in-class:: * structure-class:: * standard-class:: * method:: * standard-method:: * structure-object:: * standard-object:: * method-combination:: * t (System Class):: * satisfies:: * member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: * values (Type Specifier):: * eql (Type Specifier):: * coerce:: * deftype:: * subtypep:: * type-of:: * typep:: * type-error:: * type-error-datum:: * simple-type-error:: Data and Control Flow * Generalized Reference:: * Transfer of Control to an Exit Point:: * Data and Control Flow Dictionary:: Generalized Reference * Overview of Places and Generalized Reference:: * Kinds of Places:: * Treatment of Other Macros Based on SETF:: Overview of Places and Generalized Reference * Evaluation of Subforms to Places:: * Examples of Evaluation of Subforms to Places:: * Setf Expansions:: * Examples of Setf Expansions:: Kinds of Places * Variable Names as Places:: * Function Call Forms as Places:: * VALUES Forms as Places:: * THE Forms as Places:: * APPLY Forms as Places:: * Setf Expansions and Places:: * Macro Forms as Places:: * Symbol Macros as Places:: * Other Compound Forms as Places:: Data and Control Flow Dictionary * apply:: * defun:: * fdefinition:: * fboundp:: * fmakunbound:: * flet:: * funcall:: * function (Special Operator):: * function-lambda-expression:: * functionp:: * compiled-function-p:: * call-arguments-limit:: * lambda-list-keywords:: * lambda-parameters-limit:: * defconstant:: * defparameter:: * destructuring-bind:: * let:: * progv:: * setq:: * psetq:: * block:: * catch:: * go:: * return-from:: * return:: * tagbody:: * throw:: * unwind-protect:: * nil:: * not:: * t:: * eq:: * eql:: * equal:: * equalp:: * identity:: * complement:: * constantly:: * every:: * and:: * cond:: * if:: * or:: * when:: * case:: * typecase:: * multiple-value-bind:: * multiple-value-call:: * multiple-value-list:: * multiple-value-prog1:: * multiple-value-setq:: * values:: * values-list:: * multiple-values-limit:: * nth-value:: * prog:: * prog1:: * progn:: * define-modify-macro:: * defsetf:: * define-setf-expander:: * get-setf-expansion:: * setf:: * shiftf:: * rotatef:: * control-error:: * program-error:: * undefined-function:: Iteration * The LOOP Facility:: * Iteration Dictionary:: The LOOP Facility * Overview of the Loop Facility:: * Variable Initialization and Stepping Clauses:: * Value Accumulation Clauses:: * Termination Test Clauses:: * Unconditional Execution Clauses:: * Conditional Execution Clauses:: * Miscellaneous Clauses:: * Examples of Miscellaneous Loop Features:: * Notes about Loop:: Overview of the Loop Facility * Simple vs Extended Loop:: * Simple Loop:: * Extended Loop:: * Loop Keywords:: * Parsing Loop Clauses:: * Expanding Loop Forms:: * Summary of Loop Clauses:: * Summary of Variable Initialization and Stepping Clauses:: * Summary of Value Accumulation Clauses:: * Summary of Termination Test Clauses:: * Summary of Unconditional Execution Clauses:: * Summary of Conditional Execution Clauses:: * Summary of Miscellaneous Clauses:: * Order of Execution:: * Destructuring:: * Restrictions on Side-Effects:: Variable Initialization and Stepping Clauses * Iteration Control:: * The for-as-arithmetic subclause:: * Examples of for-as-arithmetic subclause:: * The for-as-in-list subclause:: * Examples of for-as-in-list subclause:: * The for-as-on-list subclause:: * Examples of for-as-on-list subclause:: * The for-as-equals-then subclause:: * Examples of for-as-equals-then subclause:: * The for-as-across subclause:: * Examples of for-as-across subclause:: * The for-as-hash subclause:: * The for-as-package subclause:: * Examples of for-as-package subclause:: * Local Variable Initializations:: * Examples of WITH clause:: Value Accumulation Clauses * Examples of COLLECT clause:: * Examples of APPEND and NCONC clauses:: * Examples of COUNT clause:: * Examples of MAXIMIZE and MINIMIZE clauses:: * Examples of SUM clause:: Termination Test Clauses * Examples of REPEAT clause:: * Examples of ALWAYS:: * Examples of WHILE and UNTIL clauses:: Unconditional Execution Clauses * Examples of unconditional execution:: Conditional Execution Clauses * Examples of WHEN clause:: Miscellaneous Clauses * Control Transfer Clauses:: * Examples of NAMED clause:: * Initial and Final Execution:: Examples of Miscellaneous Loop Features * Examples of clause grouping:: Iteration Dictionary * do:: * dotimes:: * dolist:: * loop:: * loop-finish:: Objects * Object Creation and Initialization:: * Changing the Class of an Instance:: * Reinitializing an Instance:: * Meta-Objects:: * Slots:: * Generic Functions and Methods:: * Objects Dictionary:: Object Creation and Initialization * Initialization Arguments:: * Declaring the Validity of Initialization Arguments:: * Defaulting of Initialization Arguments:: * Rules for Initialization Arguments:: * Shared-Initialize:: * Initialize-Instance:: * Definitions of Make-Instance and Initialize-Instance:: Changing the Class of an Instance * Modifying the Structure of the Instance:: * Initializing Newly Added Local Slots (Changing the Class of an Instance):: * Customizing the Change of Class of an Instance:: Reinitializing an Instance * Customizing Reinitialization:: Meta-Objects * Standard Meta-objects:: Slots * Introduction to Slots:: * Accessing Slots:: * Inheritance of Slots and Slot Options:: Generic Functions and Methods * Introduction to Generic Functions:: * Introduction to Methods:: * Agreement on Parameter Specializers and Qualifiers:: * Congruent Lambda-lists for all Methods of a Generic Function:: * Keyword Arguments in Generic Functions and Methods:: * Method Selection and Combination:: * Inheritance of Methods:: Keyword Arguments in Generic Functions and Methods * Examples of Keyword Arguments in Generic Functions and Methods:: Method Selection and Combination * Determining the Effective Method:: * Selecting the Applicable Methods:: * Sorting the Applicable Methods by Precedence Order:: * Applying method combination to the sorted list of applicable methods:: * Standard Method Combination:: * Declarative Method Combination:: * Built-in Method Combination Types:: Objects Dictionary * function-keywords:: * ensure-generic-function:: * allocate-instance:: * reinitialize-instance:: * shared-initialize:: * update-instance-for-different-class:: * update-instance-for-redefined-class:: * change-class:: * slot-boundp:: * slot-exists-p:: * slot-makunbound:: * slot-missing:: * slot-unbound:: * slot-value:: * method-qualifiers:: * no-applicable-method:: * no-next-method:: * remove-method:: * make-instance:: * make-instances-obsolete:: * make-load-form:: * make-load-form-saving-slots:: * with-accessors:: * with-slots:: * defclass:: * defgeneric:: * defmethod:: * find-class:: * next-method-p:: * call-method:: * call-next-method:: * compute-applicable-methods:: * define-method-combination:: * find-method:: * add-method:: * initialize-instance:: * class-name:: * (setf class-name):: * class-of:: * unbound-slot:: * unbound-slot-instance:: Structures * Structures Dictionary:: Structures Dictionary * defstruct:: * copy-structure:: Conditions * Condition System Concepts:: * Conditions Dictionary:: Condition System Concepts * Condition Types:: * Creating Conditions:: * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: * Notes about the Condition System`s Background:: Condition Types * Serious Conditions:: Creating Conditions * Condition Designators:: Printing Conditions * Recommended Style in Condition Reporting:: * Capitalization and Punctuation in Condition Reports:: * Leading and Trailing Newlines in Condition Reports:: * Embedded Newlines in Condition Reports:: * Note about Tabs in Condition Reports:: * Mentioning Containing Function in Condition Reports:: Signaling and Handling Conditions * Signaling:: * Resignaling a Condition:: * Restarts:: * Interactive Use of Restarts:: * Interfaces to Restarts:: * Restart Tests:: * Associating a Restart with a Condition:: Conditions Dictionary * condition:: * warning:: * style-warning:: * serious-condition:: * error (Condition Type):: * cell-error:: * cell-error-name:: * parse-error:: * storage-condition:: * assert:: * error:: * cerror:: * check-type:: * simple-error:: * invalid-method-error:: * method-combination-error:: * signal:: * simple-condition:: * simple-condition-format-control:: * warn:: * simple-warning:: * invoke-debugger:: * break:: * *debugger-hook*:: * *break-on-signals*:: * handler-bind:: * handler-case:: * ignore-errors:: * define-condition:: * make-condition:: * restart:: * compute-restarts:: * find-restart:: * invoke-restart:: * invoke-restart-interactively:: * restart-bind:: * restart-case:: * restart-name:: * with-condition-restarts:: * with-simple-restart:: * abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: * abort (Function):: Symbols * Symbol Concepts:: * Symbols Dictionary:: Symbols Dictionary * symbol:: * keyword:: * symbolp:: * keywordp:: * make-symbol:: * copy-symbol:: * gensym:: * *gensym-counter*:: * gentemp:: * symbol-function:: * symbol-name:: * symbol-package:: * symbol-plist:: * symbol-value:: * get:: * remprop:: * boundp:: * makunbound:: * set:: * unbound-variable:: Packages * Package Concepts:: * Packages Dictionary:: Package Concepts * Introduction to Packages:: * Standardized Packages:: Introduction to Packages * Package Names and Nicknames:: * Symbols in a Package:: * Internal and External Symbols:: * Package Inheritance:: * Accessibility of Symbols in a Package:: * Locating a Symbol in a Package:: * Prevention of Name Conflicts in Packages:: Standardized Packages * The COMMON-LISP Package:: * Constraints on the COMMON-LISP Package for Conforming Implementations:: * Constraints on the COMMON-LISP Package for Conforming Programs:: * Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs:: * The COMMON-LISP-USER Package:: * The KEYWORD Package:: * Interning a Symbol in the KEYWORD Package:: * Notes about The KEYWORD Package:: * Implementation-Defined Packages:: Packages Dictionary * package:: * export:: * find-symbol:: * find-package:: * find-all-symbols:: * import:: * list-all-packages:: * rename-package:: * shadow:: * shadowing-import:: * delete-package:: * make-package:: * with-package-iterator:: * unexport:: * unintern:: * in-package:: * unuse-package:: * use-package:: * defpackage:: * do-symbols:: * intern:: * package-name:: * package-nicknames:: * package-shadowing-symbols:: * package-use-list:: * package-used-by-list:: * packagep:: * *package*:: * package-error:: * package-error-package:: Numbers * Number Concepts:: * Numbers Dictionary:: Number Concepts * Numeric Operations:: * Implementation-Dependent Numeric Constants:: * Rational Computations:: * Floating-point Computations:: * Complex Computations:: * Interval Designators:: * Random-State Operations:: Numeric Operations * Associativity and Commutativity in Numeric Operations:: * Examples of Associativity and Commutativity in Numeric Operations:: * Contagion in Numeric Operations:: * Viewing Integers as Bits and Bytes:: * Logical Operations on Integers:: * Byte Operations on Integers:: Rational Computations * Rule of Unbounded Rational Precision:: * Rule of Canonical Representation for Rationals:: * Rule of Float Substitutability:: Floating-point Computations * Rule of Float and Rational Contagion:: * Examples of Rule of Float and Rational Contagion:: * Rule of Float Approximation:: * Rule of Float Underflow and Overflow:: * Rule of Float Precision Contagion:: Complex Computations * Rule of Complex Substitutability:: * Rule of Complex Contagion:: * Rule of Canonical Representation for Complex Rationals:: * Examples of Rule of Canonical Representation for Complex Rationals:: * Principal Values and Branch Cuts:: Numbers Dictionary * number:: * complex (System Class):: * real:: * float (System Class):: * short-float:: * rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: * mod (System Class):: * bit (System Class):: * fixnum:: * bignum:: * =:: * max:: * minusp:: * zerop:: * floor:: * sin:: * asin:: * pi:: * sinh:: * *:: * +:: * -:: * /:: * 1+:: * abs:: * evenp:: * exp:: * gcd:: * incf:: * lcm:: * log:: * mod (Function):: * signum:: * sqrt:: * random-state:: * make-random-state:: * random:: * random-state-p:: * *random-state*:: * numberp:: * cis:: * complex:: * complexp:: * conjugate:: * phase:: * realpart:: * upgraded-complex-part-type:: * realp:: * numerator:: * rational (Function):: * rationalp:: * ash:: * integer-length:: * integerp:: * parse-integer:: * boole:: * boole-1:: * logand:: * logbitp:: * logcount:: * logtest:: * byte:: * deposit-field:: * dpb:: * ldb:: * ldb-test:: * mask-field:: * most-positive-fixnum:: * decode-float:: * float:: * floatp:: * most-positive-short-float:: * short-float-epsilon:: * arithmetic-error:: * arithmetic-error-operands:: * division-by-zero:: * floating-point-invalid-operation:: * floating-point-inexact:: * floating-point-overflow:: * floating-point-underflow:: Characters * Character Concepts:: * Characters Dictionary:: Character Concepts * Introduction to Characters:: * Introduction to Scripts and Repertoires:: * Character Attributes:: * Character Categories:: * Identity of Characters:: * Ordering of Characters:: * Character Names:: * Treatment of Newline during Input and Output:: * Character Encodings:: * Documentation of Implementation-Defined Scripts:: Introduction to Scripts and Repertoires * Character Scripts:: * Character Repertoires:: Character Categories * Graphic Characters:: * Alphabetic Characters:: * Characters With Case:: * Uppercase Characters:: * Lowercase Characters:: * Corresponding Characters in the Other Case:: * Case of Implementation-Defined Characters:: * Numeric Characters:: * Alphanumeric Characters:: * Digits in a Radix:: Characters Dictionary * character (System Class):: * base-char:: * standard-char:: * extended-char:: * char=:: * character:: * characterp:: * alpha-char-p:: * alphanumericp:: * digit-char:: * digit-char-p:: * graphic-char-p:: * standard-char-p:: * char-upcase:: * upper-case-p:: * char-code:: * char-int:: * code-char:: * char-code-limit:: * char-name:: * name-char:: Conses * Cons Concepts:: * Conses Dictionary:: Cons Concepts * Conses as Trees:: * Conses as Lists:: Conses as Trees * General Restrictions on Parameters that must be Trees:: Conses as Lists * Lists as Association Lists:: * Lists as Sets:: * General Restrictions on Parameters that must be Lists:: Conses Dictionary * list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: * cons:: * consp:: * atom:: * rplaca:: * car:: * copy-tree:: * sublis:: * subst:: * tree-equal:: * copy-list:: * list (Function):: * list-length:: * listp:: * make-list:: * push:: * pop:: * first:: * nth:: * endp:: * null:: * nconc:: * append:: * revappend:: * butlast:: * last:: * ldiff:: * nthcdr:: * rest:: * member (Function):: * mapc:: * acons:: * assoc:: * copy-alist:: * pairlis:: * rassoc:: * get-properties:: * getf:: * remf:: * intersection:: * adjoin:: * pushnew:: * set-difference:: * set-exclusive-or:: * subsetp:: * union:: Arrays * Array Concepts:: * Arrays Dictionary:: Array Concepts * Array Elements:: * Specialized Arrays:: Array Elements * Array Indices:: * Array Dimensions:: * Implementation Limits on Individual Array Dimensions:: * Array Rank:: * Vectors:: * Fill Pointers:: * Multidimensional Arrays:: * Storage Layout for Multidimensional Arrays:: * Implementation Limits on Array Rank:: Specialized Arrays * Array Upgrading:: * Required Kinds of Specialized Arrays:: Arrays Dictionary * array:: * simple-array:: * vector (System Class):: * simple-vector:: * bit-vector:: * simple-bit-vector:: * make-array:: * adjust-array:: * adjustable-array-p:: * aref:: * array-dimension:: * array-dimensions:: * array-element-type:: * array-has-fill-pointer-p:: * array-displacement:: * array-in-bounds-p:: * array-rank:: * array-row-major-index:: * array-total-size:: * arrayp:: * fill-pointer:: * row-major-aref:: * upgraded-array-element-type:: * array-dimension-limit:: * array-rank-limit:: * array-total-size-limit:: * simple-vector-p:: * svref:: * vector:: * vector-pop:: * vector-push:: * vectorp:: * bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p:: Strings * String Concepts:: * Strings Dictionary:: String Concepts * Implications of Strings Being Arrays:: * Subtypes of STRING:: Strings Dictionary * string (System Class):: * base-string:: * simple-string:: * simple-base-string:: * simple-string-p:: * char:: * string:: * string-upcase:: * string-trim:: * string=:: * stringp:: * make-string:: Sequences * Sequence Concepts:: * Rules about Test Functions:: * Sequences Dictionary:: Sequence Concepts * General Restrictions on Parameters that must be Sequences:: Rules about Test Functions * Satisfying a Two-Argument Test:: * Satisfying a One-Argument Test:: Satisfying a Two-Argument Test * Examples of Satisfying a Two-Argument Test:: Satisfying a One-Argument Test * Examples of Satisfying a One-Argument Test:: Sequences Dictionary * sequence:: * copy-seq:: * elt:: * fill:: * make-sequence:: * subseq:: * map:: * map-into:: * reduce:: * count:: * length:: * reverse:: * sort:: * find:: * position:: * search:: * mismatch:: * replace:: * substitute:: * concatenate:: * merge:: * remove:: * remove-duplicates:: Hash Tables * Hash Table Concepts:: * Hash Tables Dictionary:: Hash Table Concepts * Hash-Table Operations:: * Modifying Hash Table Keys:: Modifying Hash Table Keys * Visible Modification of Objects with respect to EQ and EQL:: * Visible Modification of Objects with respect to EQUAL:: * Visible Modification of Conses with respect to EQUAL:: * Visible Modification of Bit Vectors and Strings with respect to EQUAL:: * Visible Modification of Objects with respect to EQUALP:: * Visible Modification of Structures with respect to EQUALP:: * Visible Modification of Arrays with respect to EQUALP:: * Visible Modification of Hash Tables with respect to EQUALP:: * Visible Modifications by Language Extensions:: Hash Tables Dictionary * hash-table:: * make-hash-table:: * hash-table-p:: * hash-table-count:: * hash-table-rehash-size:: * hash-table-rehash-threshold:: * hash-table-size:: * hash-table-test:: * gethash:: * remhash:: * maphash:: * with-hash-table-iterator:: * clrhash:: * sxhash:: Filenames * Overview of Filenames:: * Pathnames:: * Logical Pathnames:: * Filenames Dictionary:: Overview of Filenames * Namestrings as Filenames:: * Pathnames as Filenames:: * Parsing Namestrings Into Pathnames:: Pathnames * Pathname Components:: * Interpreting Pathname Component Values:: * Merging Pathnames:: Pathname Components * The Pathname Host Component:: * The Pathname Device Component:: * The Pathname Directory Component:: * The Pathname Name Component:: * The Pathname Type Component:: * The Pathname Version Component:: Interpreting Pathname Component Values * Strings in Component Values:: * Special Characters in Pathname Components:: * Case in Pathname Components:: * Local Case in Pathname Components:: * Common Case in Pathname Components:: * Special Pathname Component Values:: * NIL as a Component Value:: * ->WILD as a Component Value:: * ->UNSPECIFIC as a Component Value:: * Relation between component values NIL and ->UNSPECIFIC:: * Restrictions on Wildcard Pathnames:: * Restrictions on Examining Pathname Components:: * Restrictions on Examining a Pathname Host Component:: * Restrictions on Examining a Pathname Device Component:: * Restrictions on Examining a Pathname Directory Component:: * Directory Components in Non-Hierarchical File Systems:: * Restrictions on Examining a Pathname Name Component:: * Restrictions on Examining a Pathname Type Component:: * Restrictions on Examining a Pathname Version Component:: * Notes about the Pathname Version Component:: * Restrictions on Constructing Pathnames:: Merging Pathnames * Examples of Merging Pathnames:: Logical Pathnames * Syntax of Logical Pathname Namestrings:: * Logical Pathname Components:: Syntax of Logical Pathname Namestrings * Additional Information about Parsing Logical Pathname Namestrings:: * The Host part of a Logical Pathname Namestring:: * The Device part of a Logical Pathname Namestring:: * The Directory part of a Logical Pathname Namestring:: * The Type part of a Logical Pathname Namestring:: * The Version part of a Logical Pathname Namestring:: * Wildcard Words in a Logical Pathname Namestring:: * Lowercase Letters in a Logical Pathname Namestring:: * Other Syntax in a Logical Pathname Namestring:: Logical Pathname Components * Unspecific Components of a Logical Pathname:: * Null Strings as Components of a Logical Pathname:: Filenames Dictionary * pathname (System Class):: * logical-pathname (System Class):: * pathname:: * make-pathname:: * pathnamep:: * pathname-host:: * load-logical-pathname-translations:: * logical-pathname-translations:: * logical-pathname:: * *default-pathname-defaults*:: * namestring:: * parse-namestring:: * wild-pathname-p:: * pathname-match-p:: * translate-logical-pathname:: * translate-pathname:: * merge-pathnames:: Files * File System Concepts:: * Files Dictionary:: File System Concepts * Coercion of Streams to Pathnames:: * File Operations on Open and Closed Streams:: * Truenames:: Truenames * Examples of Truenames:: Files Dictionary * directory:: * probe-file:: * ensure-directories-exist:: * truename:: * file-author:: * file-write-date:: * rename-file:: * delete-file:: * file-error:: * file-error-pathname:: Streams * Stream Concepts:: * Streams Dictionary:: Stream Concepts * Introduction to Streams:: * Stream Variables:: * Stream Arguments to Standardized Functions:: * Restrictions on Composite Streams:: Introduction to Streams * Abstract Classifications of Streams (Introduction to Streams):: * Input:: * Open and Closed Streams:: * Interactive Streams:: * Abstract Classifications of Streams:: * File Streams:: * Other Subclasses of Stream:: Streams Dictionary * stream:: * broadcast-stream:: * concatenated-stream:: * echo-stream:: * file-stream:: * string-stream:: * synonym-stream:: * two-way-stream:: * input-stream-p:: * interactive-stream-p:: * open-stream-p:: * stream-element-type:: * streamp:: * read-byte:: * write-byte:: * peek-char:: * read-char:: * read-char-no-hang:: * terpri:: * unread-char:: * write-char:: * read-line:: * write-string:: * read-sequence:: * write-sequence:: * file-length:: * file-position:: * file-string-length:: * open:: * stream-external-format:: * with-open-file:: * close:: * with-open-stream:: * listen:: * clear-input:: * finish-output:: * y-or-n-p:: * make-synonym-stream:: * synonym-stream-symbol:: * broadcast-stream-streams:: * make-broadcast-stream:: * make-two-way-stream:: * two-way-stream-input-stream:: * echo-stream-input-stream:: * make-echo-stream:: * concatenated-stream-streams:: * make-concatenated-stream:: * get-output-stream-string:: * make-string-input-stream:: * make-string-output-stream:: * with-input-from-string:: * with-output-to-string:: * *debug-io*:: * *terminal-io*:: * stream-error:: * stream-error-stream:: * end-of-file:: Printer * The Lisp Printer:: * The Lisp Pretty Printer:: * Formatted Output:: * Printer Dictionary:: The Lisp Printer * Overview of The Lisp Printer:: * Printer Dispatching:: * Default Print-Object Methods:: * Examples of Printer Behavior:: Overview of The Lisp Printer * Multiple Possible Textual Representations:: * Printer Escaping:: Default Print-Object Methods * Printing Numbers:: * Printing Integers:: * Printing Ratios:: * Printing Floats:: * Printing Complexes:: * Note about Printing Numbers:: * Printing Characters:: * Printing Symbols:: * Package Prefixes for Symbols:: * Effect of Readtable Case on the Lisp Printer:: * Examples of Effect of Readtable Case on the Lisp Printer:: * Printing Strings:: * Printing Lists and Conses:: * Printing Bit Vectors:: * Printing Other Vectors:: * Printing Other Arrays:: * Examples of Printing Arrays:: * Printing Random States:: * Printing Pathnames:: * Printing Structures:: * Printing Other Objects:: The Lisp Pretty Printer * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: * Notes about the Pretty Printer`s Background:: Pretty Printer Concepts * Dynamic Control of the Arrangement of Output:: * Format Directive Interface:: * Compiling Format Strings:: * Pretty Print Dispatch Tables:: * Pretty Printer Margins:: Formatted Output * FORMAT Basic Output:: * FORMAT Radix Control:: * FORMAT Floating-Point Printers:: * FORMAT Printer Operations:: * FORMAT Pretty Printer Operations:: * FORMAT Layout Control:: * FORMAT Control-Flow Operations:: * FORMAT Miscellaneous Operations:: * FORMAT Miscellaneous Pseudo-Operations:: * Additional Information about FORMAT Operations:: * Examples of FORMAT:: * Notes about FORMAT:: FORMAT Basic Output * Tilde C-> Character:: * Tilde Percent-> Newline:: * Tilde Ampersand-> Fresh-Line:: * Tilde Vertical-Bar-> Page:: * Tilde Tilde-> Tilde:: FORMAT Radix Control * Tilde R-> Radix:: * Tilde D-> Decimal:: * Tilde B-> Binary:: * Tilde O-> Octal:: * Tilde X-> Hexadecimal:: FORMAT Floating-Point Printers * Tilde F-> Fixed-Format Floating-Point:: * Tilde E-> Exponential Floating-Point:: * Tilde G-> General Floating-Point:: * Tilde Dollarsign-> Monetary Floating-Point:: FORMAT Printer Operations * Tilde A-> Aesthetic:: * Tilde S-> Standard:: * Tilde W-> Write:: FORMAT Pretty Printer Operations * Tilde Underscore-> Conditional Newline:: * Tilde Less-Than-Sign-> Logical Block:: * Tilde I-> Indent:: * Tilde Slash-> Call Function:: FORMAT Layout Control * Tilde T-> Tabulate:: * Tilde Less-Than-Sign-> Justification:: * Tilde Greater-Than-Sign-> End of Justification:: FORMAT Control-Flow Operations * Tilde Asterisk-> Go-To:: * Tilde Left-Bracket-> Conditional Expression:: * Tilde Right-Bracket-> End of Conditional Expression:: * Tilde Left-Brace-> Iteration:: * Tilde Right-Brace-> End of Iteration:: * Tilde Question-Mark-> Recursive Processing:: FORMAT Miscellaneous Operations * Tilde Left-Paren-> Case Conversion:: * Tilde Right-Paren-> End of Case Conversion:: * Tilde P-> Plural:: FORMAT Miscellaneous Pseudo-Operations * Tilde Semicolon-> Clause Separator:: * Tilde Circumflex-> Escape Upward:: * Tilde Newline-> Ignored Newline:: Additional Information about FORMAT Operations * Nesting of FORMAT Operations:: * Missing and Additional FORMAT Arguments:: * Additional FORMAT Parameters:: * Undefined FORMAT Modifier Combinations:: Printer Dictionary * copy-pprint-dispatch:: * formatter:: * pprint-dispatch:: * pprint-exit-if-list-exhausted:: * pprint-fill:: * pprint-indent:: * pprint-logical-block:: * pprint-newline:: * pprint-pop:: * pprint-tab:: * print-object:: * print-unreadable-object:: * set-pprint-dispatch:: * write:: * write-to-string:: * *print-array*:: * *print-base*:: * *print-case*:: * *print-circle*:: * *print-escape*:: * *print-gensym*:: * *print-level*:: * *print-lines*:: * *print-miser-width*:: * *print-pprint-dispatch*:: * *print-pretty*:: * *print-readably*:: * *print-right-margin*:: * print-not-readable:: * print-not-readable-object:: * format:: Reader * Reader Concepts:: * Reader Dictionary:: Reader Concepts * Dynamic Control of the Lisp Reader:: * Effect of Readtable Case on the Lisp Reader:: * Argument Conventions of Some Reader Functions:: Effect of Readtable Case on the Lisp Reader * Examples of Effect of Readtable Case on the Lisp Reader:: Argument Conventions of Some Reader Functions * The EOF-ERROR-P argument:: * The RECURSIVE-P argument:: Reader Dictionary * readtable:: * copy-readtable:: * make-dispatch-macro-character:: * read:: * read-delimited-list:: * read-from-string:: * readtable-case:: * readtablep:: * set-dispatch-macro-character:: * set-macro-character:: * set-syntax-from-char:: * with-standard-io-syntax:: * *read-base*:: * *read-default-float-format*:: * *read-eval*:: * *read-suppress*:: * *readtable*:: * reader-error:: System Construction * System Construction Concepts:: * System Construction Dictionary:: System Construction Concepts * Loading:: * Features:: Features * Feature Expressions:: * Examples of Feature Expressions:: System Construction Dictionary * compile-file:: * compile-file-pathname:: * load:: * with-compilation-unit:: * *features*:: * *compile-file-pathname*:: * *load-pathname*:: * *compile-print*:: * *load-print*:: * *modules*:: * provide:: Environment * The External Environment:: * Environment Dictionary:: The External Environment * Top level loop:: * Debugging Utilities:: * Environment Inquiry:: * Time:: Time * Decoded Time:: * Universal Time:: * Internal Time:: * Seconds:: Environment Dictionary * decode-universal-time:: * encode-universal-time:: * get-universal-time:: * sleep:: * apropos:: * describe:: * describe-object:: * trace:: * step:: * time:: * internal-time-units-per-second:: * get-internal-real-time:: * get-internal-run-time:: * disassemble:: * documentation:: * room:: * ed:: * inspect:: * dribble:: * -:: * +:: * *:: * /:: * lisp-implementation-type:: * short-site-name:: * machine-instance:: * machine-type:: * machine-version:: * software-type:: * user-homedir-pathname:: Glossary * Glossary:: Appendix * Removed Language Features:: Removed Language Features * Requirements for removed and deprecated features:: * Removed Types:: * Removed Operators:: * Removed Argument Conventions:: * Removed Variables:: * Removed Reader Syntax:: * Packages No Longer Required:: @end menu @c includes @include chap-1.texi @include chap-2.texi @include chap-3.texi @include chap-4.texi @include chap-5.texi @include chap-6.texi @include chap-7.texi @include chap-8.texi @include chap-9.texi @include chap-10.texi @include chap-11.texi @include chap-12.texi @include chap-13.texi @include chap-14.texi @include chap-15.texi @include chap-16.texi @include chap-17.texi @include chap-18.texi @include chap-19.texi @include chap-20.texi @include chap-21.texi @include chap-22.texi @include chap-23.texi @include chap-24.texi @include chap-25.texi @include chap-26.texi @include chap-a.texi @bye gcl-2.6.14/info/chap-20.texi0000644000175000017500000005421014360276512013755 0ustar cammcamm @node Files, Streams, Filenames, Top @chapter Files @menu * File System Concepts:: * Files Dictionary:: @end menu @node File System Concepts, Files Dictionary, Files, Files @section File System Concepts @c including concept-files This section describes the @r{Common Lisp} interface to file systems. The model used by this interface assumes that @i{files} @IGindex file are named by @i{filenames} @IGindex filename , that a @i{filename} can be represented by a @i{pathname} @i{object}, and that given a @i{pathname} a @i{stream} @IGindex stream can be constructed that connects to a @i{file} whose @i{filename} it represents. For information about opening and closing @i{files}, and manipulating their contents, see @ref{Streams}. Figure 20--1 lists some @i{operators} that are applicable to @i{files} and directories. @format @group @noindent @w{ compile-file file-length open } @w{ delete-file file-position probe-file } @w{ directory file-write-date rename-file } @w{ file-author load with-open-file } @noindent @w{ Figure 20--1: File and Directory Operations } @end group @end format @menu * Coercion of Streams to Pathnames:: * File Operations on Open and Closed Streams:: * Truenames:: @end menu @node Coercion of Streams to Pathnames, File Operations on Open and Closed Streams, File System Concepts, File System Concepts @subsection Coercion of Streams to Pathnames A @i{stream associated with a file} @IGindex stream associated with a file is either a @i{file stream} or a @i{synonym stream} whose target is a @i{stream associated with a file} @IGindex stream associated with a file . Such streams can be used as @i{pathname designators}. Normally, when a @i{stream associated with a file} is used as a @i{pathname designator}, it denotes the @i{pathname} used to open the @i{file}; this may be, but is not required to be, the actual name of the @i{file}. Some functions, such as @b{truename} and @b{delete-file}, coerce @i{streams} to @i{pathnames} in a different way that involves referring to the actual @i{file} that is open, which might or might not be the file whose name was opened originally. Such special situations are always notated specifically and are not the default. @node File Operations on Open and Closed Streams, Truenames, Coercion of Streams to Pathnames, File System Concepts @subsection File Operations on Open and Closed Streams Many @i{functions} that perform @i{file} operations accept either @i{open} or @i{closed} @i{streams} as @i{arguments}; see @ref{Stream Arguments to Standardized Functions}. Of these, the @i{functions} in Figure 20--2 treat @i{open} and @i{closed} @i{streams} differently. @format @group @noindent @w{ delete-file file-author probe-file } @w{ directory file-write-date truename } @noindent @w{ Figure 20--2: File Functions that Treat Open and Closed Streams Differently} @end group @end format Since treatment of @i{open} @i{streams} by the @i{file system} may vary considerably between @i{implementations}, however, a @i{closed} @i{stream} might be the most reliable kind of @i{argument} for some of these functions---in particular, those in Figure 20--3. For example, in some @i{file systems}, @i{open} @i{files} are written under temporary names and not renamed until @i{closed} and/or are held invisible until @i{closed}. In general, any code that is intended to be portable should use such @i{functions} carefully. @format @group @noindent @w{ directory probe-file truename } @noindent @w{ Figure 20--3: File Functions where Closed Streams Might Work Best} @end group @end format @node Truenames, , File Operations on Open and Closed Streams, File System Concepts @subsection Truenames Many @i{file systems} permit more than one @i{filename} to designate a particular @i{file}. Even where multiple names are possible, most @i{file systems} have a convention for generating a canonical @i{filename} in such situations. Such a canonical @i{filename} (or the @i{pathname} representing such a @i{filename}) is called a @i{truename} @IGindex truename . The @i{truename} of a @i{file} may differ from other @i{filenames} for the file because of symbolic links, version numbers, logical device translations in the @i{file system}, @i{logical pathname} translations within @r{Common Lisp}, or other artifacts of the @i{file system}. The @i{truename} for a @i{file} is often, but not necessarily, unique for each @i{file}. For instance, a Unix @i{file} with multiple hard links could have several @i{truenames}. @menu * Examples of Truenames:: @end menu @node Examples of Truenames, , Truenames, Truenames @subsubsection Examples of Truenames For example, a DEC TOPS-20 system with @i{files} @t{PS:FOO.TXT.1} and @t{PS:FOO.TXT.2} might permit the second @i{file} to be referred to as @t{PS:FOO.TXT.0}, since the ``@t{.0}'' notation denotes ``newest'' version of several @i{files}. In the same @i{file system}, a ``logical device'' ``@t{JOE:}'' might be taken to refer to @t{PS:}'' and so the names @t{JOE:FOO.TXT.2} or @t{JOE:FOO.TXT.0} might refer to @t{PS:FOO.TXT.2}. In all of these cases, the @i{truename} of the file would probably be @t{PS:FOO.TXT.2}. If a @i{file} is a symbolic link to another @i{file} (in a @i{file system} permitting such a thing), it is conventional for the @i{truename} to be the canonical name of the @i{file} after any symbolic links have been followed; that is, it is the canonical name of the @i{file} whose contents would become available if an @i{input} @i{stream} to that @i{file} were opened. In the case of a @i{file} still being created (that is, of an @i{output} @i{stream} open to such a @i{file}), the exact @i{truename} of the file might not be known until the @i{stream} is closed. In this case, the @i{function} @b{truename} might return different values for such a @i{stream} before and after it was closed. In fact, before it is closed, the name returned might not even be a valid name in the @i{file system}---for example, while a file is being written, it might have version @t{:newest} and might only take on a specific numeric value later when the file is closed even in a @i{file system} where all files have numeric versions. @c end of including concept-files @node Files Dictionary, , File System Concepts, Files @section Files Dictionary @c including dict-files @menu * directory:: * probe-file:: * ensure-directories-exist:: * truename:: * file-author:: * file-write-date:: * rename-file:: * delete-file:: * file-error:: * file-error-pathname:: @end menu @node directory, probe-file, Files Dictionary, Files Dictionary @subsection directory [Function] @code{directory} @i{pathspec @r{&key}} @result{} @i{pathnames} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}, which may contain @i{wild} components. @i{pathnames}---a @i{list} of @i{physical pathnames}. @subsubheading Description:: Determines which, if any, @i{files} that are present in the file system have names matching @i{pathspec}, and returns a @i{fresh} @i{list} of @i{pathnames} corresponding to the @i{truenames} of those @i{files}. An @i{implementation} may be extended to accept @i{implementation-defined} keyword arguments to @b{directory}. @subsubheading Affected By:: The host computer's file system. @subsubheading Exceptional Situations:: If the attempt to obtain a directory listing is not successful, an error of @i{type} @b{file-error} is signaled. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{ensure-directories-exist} , @ref{File System Concepts}, @ref{File Operations on Open and Closed Streams}, @ref{Pathnames as Filenames} @subsubheading Notes:: If the @i{pathspec} is not @i{wild}, the resulting list will contain either zero or one elements. @r{Common Lisp} specifies ``@r{&key}'' in the argument list to @b{directory} even though no @i{standardized} keyword arguments to @b{directory} are defined. ``@t{:allow-other-keys t}'' may be used in @i{conforming programs} in order to quietly ignore any additional keywords which are passed by the program but not supported by the @i{implementation}. @node probe-file, ensure-directories-exist, directory, Files Dictionary @subsection probe-file [Function] @code{probe-file} @i{pathspec} @result{} @i{truename} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}. @i{truename}---a @i{physical pathname} or @b{nil}. @subsubheading Description:: @b{probe-file} tests whether a file exists. @b{probe-file} returns @i{false} if there is no file named @i{pathspec}, and otherwise returns the @i{truename} of @i{pathspec}. If the @i{pathspec} @i{designator} is an open @i{stream}, then @b{probe-file} produces the @i{truename} of its associated @i{file}. If @i{pathspec} is a @i{stream}, whether open or closed, it is coerced to a @i{pathname} as if by the @i{function} @b{pathname}. @subsubheading Affected By:: The host computer's file system. @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} is signaled if @i{pathspec} is @i{wild}. An error of @i{type} @b{file-error} is signaled if the @i{file system} cannot perform the requested operation. @subsubheading See Also:: @ref{truename} , @ref{open} , @ref{ensure-directories-exist} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{File Operations on Open and Closed Streams}, @ref{Pathnames as Filenames} @node ensure-directories-exist, truename, probe-file, Files Dictionary @subsection ensure-directories-exist [Function] @code{ensure-directories-exist} @i{pathspec @r{&key} verbose} @result{} @i{pathspec, created} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}. @i{verbose}---a @i{generalized boolean}. @i{created}---a @i{generalized boolean}. @subsubheading Description:: Tests whether the directories containing the specified @i{file} actually exist, and attempts to create them if they do not. If the containing directories do not exist and if @i{verbose} is @i{true}, then the @i{implementation} is permitted (but not required) to perform output to @i{standard output} saying what directories were created. If the containing directories exist, or if @i{verbose} is @i{false}, this function performs no output. The @i{primary value} is the given @i{pathspec} so that this operation can be straightforwardly composed with other file manipulation expressions. The @i{secondary value}, @i{created}, is @i{true} if any directories were created. @subsubheading Affected By:: The host computer's file system. @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} is signaled if the host, device, or directory part of @i{pathspec} is @i{wild}. If the directory creation attempt is not successful, an error of @i{type} @b{file-error} is signaled; if this occurs, it might be the case that none, some, or all of the requested creations have actually occurred within the @i{file system}. @subsubheading See Also:: @ref{probe-file} , @ref{open} , @ref{Pathnames as Filenames} @node truename, file-author, ensure-directories-exist, Files Dictionary @subsection truename [Function] @code{truename} @i{filespec} @result{} @i{truename} @subsubheading Arguments and Values:: @i{filespec}---a @i{pathname designator}. @i{truename}---a @i{physical pathname}. @subsubheading Description:: @b{truename} tries to find the @i{file} indicated by @i{filespec} and returns its @i{truename}. If the @i{filespec} @i{designator} is an open @i{stream}, its associated @i{file} is used. If @i{filespec} is a @i{stream}, @b{truename} can be used whether the @i{stream} is open or closed. It is permissible for @b{truename} to return more specific information after the @i{stream} is closed than when the @i{stream} was open. If @i{filespec} is a @i{pathname} it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. @subsubheading Examples:: @example ;; An example involving version numbers. Note that the precise nature of ;; the truename is implementation-dependent while the file is still open. (with-open-file (stream ">vistor>test.text.newest") (values (pathname stream) (truename stream))) @result{} #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1" @i{OR}@result{} #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.newest" @i{OR}@result{} #P"S:>vistor>test.text.newest", #P"S:>vistor>_temp_._temp_.1" ;; In this case, the file is closed when the truename is tried, so the ;; truename information is reliable. (with-open-file (stream ">vistor>test.text.newest") (close stream) (values (pathname stream) (truename stream))) @result{} #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1" ;; An example involving TOP-20's implementation-dependent concept ;; of logical devices -- in this case, "DOC:" is shorthand for ;; "PS:" ... (with-open-file (stream "CMUC::DOC:DUMPER.HLP") (values (pathname stream) (truename stream))) @result{} #P"CMUC::DOC:DUMPER.HLP", #P"CMUC::PS:DUMPER.HLP.13" @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} is signaled if an appropriate @i{file} cannot be located within the @i{file system} for the given @i{filespec}, or if the @i{file system} cannot perform the requested operation. An error of @i{type} @b{file-error} is signaled if @i{pathname} is @i{wild}. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @subsubheading Notes:: @b{truename} may be used to account for any @i{filename} translations performed by the @i{file system}. @node file-author, file-write-date, truename, Files Dictionary @subsection file-author [Function] @code{file-author} @i{pathspec} @result{} @i{author} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}. @i{author}---a @i{string} or @b{nil}. @subsubheading Description:: Returns a @i{string} naming the author of the @i{file} specified by @i{pathspec}, or @b{nil} if the author's name cannot be determined. @subsubheading Examples:: @example (with-open-file (stream ">relativity>general.text") (file-author s)) @result{} "albert" @end example @subsubheading Affected By:: The host computer's file system. Other users of the @i{file} named by @i{pathspec}. @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} is signaled if @i{pathspec} is @i{wild}. An error of @i{type} @b{file-error} is signaled if the @i{file system} cannot perform the requested operation. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node file-write-date, rename-file, file-author, Files Dictionary @subsection file-write-date [Function] @code{file-write-date} @i{pathspec} @result{} @i{date} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}. @i{date}---a @i{universal time} or @b{nil}. @subsubheading Description:: Returns a @i{universal time} representing the time at which the @i{file} specified by @i{pathspec} was last written (or created), or returns @b{nil} if such a time cannot be determined. @subsubheading Examples:: @example (with-open-file (s "noel.text" :direction :output :if-exists :error) (format s "~&Dear Santa,~2 Please leave lots of toys.~2 ~2 (truename s)) @result{} #P"CUPID:/susan/noel.text" (with-open-file (s "noel.text") (file-write-date s)) @result{} 2902600800 @end example @subsubheading Affected By:: The host computer's file system. @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} is signaled if @i{pathspec} is @i{wild}. An error of @i{type} @b{file-error} is signaled if the @i{file system} cannot perform the requested operation. @subsubheading See Also:: @ref{Universal Time}, @ref{Pathnames as Filenames} @node rename-file, delete-file, file-write-date, Files Dictionary @subsection rename-file [Function] @code{rename-file} @i{filespec new-name} @result{} @i{defaulted-new-name, old-truename, new-truename} @subsubheading Arguments and Values:: @i{filespec}---a @i{pathname designator}. @i{new-name}---a @i{pathname designator} other than a @i{stream}. @i{defaulted-new-name}---a @i{pathname} @i{old-truename}---a @i{physical pathname}. @i{new-truename}---a @i{physical pathname}. @subsubheading Description:: @b{rename-file} modifies the file system in such a way that the file indicated by @i{filespec} is renamed to @i{defaulted-new-name}. It is an error to specify a filename containing a @i{wild} component, for @i{filespec} to contain a @b{nil} component where the file system does not permit a @b{nil} component, or for the result of defaulting missing components of @i{new-name} from @i{filespec} to contain a @b{nil} component where the file system does not permit a @b{nil} component. If @i{new-name} is a @i{logical pathname}, @b{rename-file} returns a @i{logical pathname} as its @i{primary value}. @b{rename-file} returns three values if successful. The @i{primary value}, @i{defaulted-new-name}, is the resulting name which is composed of @i{new-name} with any missing components filled in by performing a @b{merge-pathnames} operation using @i{filespec} as the defaults. The @i{secondary value}, @i{old-truename}, is the @i{truename} of the @i{file} before it was renamed. The @i{tertiary value}, @i{new-truename}, is the @i{truename} of the @i{file} after it was renamed. If the @i{filespec} @i{designator} is an open @i{stream}, then the @i{stream} itself and the file associated with it are affected (if the @i{file system} permits). @subsubheading Examples:: @example ;; An example involving logical pathnames. (with-open-file (stream "sys:chemistry;lead.text" :direction :output :if-exists :error) (princ "eureka" stream) (values (pathname stream) (truename stream))) @result{} #P"SYS:CHEMISTRY;LEAD.TEXT.NEWEST", #P"Q:>sys>chem>lead.text.1" (rename-file "sys:chemistry;lead.text" "gold.text") @result{} #P"SYS:CHEMISTRY;GOLD.TEXT.NEWEST", #P"Q:>sys>chem>lead.text.1", #P"Q:>sys>chem>gold.text.1" @end example @subsubheading Exceptional Situations:: If the renaming operation is not successful, an error of @i{type} @b{file-error} is signaled. An error of @i{type} @b{file-error} might be signaled if @i{filespec} is @i{wild}. @subsubheading See Also:: @ref{truename} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node delete-file, file-error, rename-file, Files Dictionary @subsection delete-file [Function] @code{delete-file} @i{filespec} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{filespec}---a @i{pathname designator}. @subsubheading Description:: Deletes the @i{file} specified by @i{filespec}. If the @i{filespec} @i{designator} is an open @i{stream}, then @i{filespec} and the file associated with it are affected (if the file system permits), in which case @i{filespec} might be closed immediately, and the deletion might be immediate or delayed until @i{filespec} is explicitly closed, depending on the requirements of the file system. It is @i{implementation-dependent} whether an attempt to delete a nonexistent file is considered to be successful. @b{delete-file} returns @i{true} if it succeeds, or signals an error of @i{type} @b{file-error} if it does not. The consequences are undefined if @i{filespec} has a @i{wild} component, or if @i{filespec} has a @b{nil} component and the file system does not permit a @b{nil} component. @subsubheading Examples:: @example (with-open-file (s "delete-me.text" :direction :output :if-exists :error)) @result{} NIL (setq p (probe-file "delete-me.text")) @result{} #P"R:>fred>delete-me.text.1" (delete-file p) @result{} T (probe-file "delete-me.text") @result{} @i{false} (with-open-file (s "delete-me.text" :direction :output :if-exists :error) (delete-file s)) @result{} T (probe-file "delete-me.text") @result{} @i{false} @end example @subsubheading Exceptional Situations:: If the deletion operation is not successful, an error of @i{type} @b{file-error} is signaled. An error of @i{type} @b{file-error} might be signaled if @i{filespec} is @i{wild}. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node file-error, file-error-pathname, delete-file, Files Dictionary @subsection file-error [Condition Type] @subsubheading Class Precedence List:: @b{file-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{file-error} consists of error conditions that occur during an attempt to open or close a file, or during some low-level transactions with a file system. The ``offending pathname'' is initialized by the @t{:pathname} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{file-error-pathname}. @subsubheading See Also:: @r{file-error-pathname}, @ref{open} , @ref{probe-file} , @ref{directory} , @ref{ensure-directories-exist} @node file-error-pathname, , file-error, Files Dictionary @subsection file-error-pathname [Function] @code{file-error-pathname} @i{condition} @result{} @i{pathspec} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{file-error}. @i{pathspec}---a @i{pathname designator}. @subsubheading Description:: Returns the ``offending pathname'' of a @i{condition} of @i{type} @b{file-error}. @subsubheading Exceptional Situations:: @subsubheading See Also:: @b{file-error}, @ref{Conditions} @c end of including dict-files @c %**end of chapter gcl-2.6.14/info/gcl-si.info0000644000175000017500000115446314360276512013777 0ustar cammcammThis is gcl-si.info, produced by makeinfo version 6.7 from gcl-si.texi. INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-si: (gcl-si.info). GNU Common Lisp System Internals END-INFO-DIR-ENTRY This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter  File: gcl-si.info, Node: Top, Next: Numbers, Prev: (dir), Up: (dir) * Menu: * Numbers:: * Sequences and Arrays and Hash Tables:: * Characters:: * Lists:: * Streams and Reading:: * Special Forms and Functions:: * Compilation:: * Symbols:: * Operating System:: * Structures:: * Iteration and Tests:: * User Interface:: * Doc:: * Type:: * GCL Specific:: * C Interface:: * System Definitions:: * Debugging:: * Miscellaneous:: * Compiler Definitions:: * Function and Variable Index:: -- The Detailed Node Listing -- Operating System * Command Line:: * Operating System Definitions:: GCL Specific * Bignums:: C Interface * Available Symbols:: System Definitions * Regular Expressions:: Debugging * Source Level Debugging in Emacs:: * Low Level Debug Functions:: Miscellaneous * Environment:: * Inititialization:: * Low Level X Interface::  File: gcl-si.info, Node: Numbers, Next: Sequences and Arrays and Hash Tables, Prev: Top, Up: Top 1 Numbers ********* -- Function: SIGNUM (number) Package:LISP If NUMBER is zero, returns NUMBER; else returns (/ NUMBER (ABS NUMBER)). -- Function: LOGNOT (integer) Package:LISP Returns the bit-wise logical NOT of INTEGER. -- Constant: MOST-POSITIVE-SHORT-FLOAT Package:LISP The short-float closest in value to positive infinity. -- Function: INTEGER-DECODE-FLOAT (float) Package:LISP Returns, as three values, the integer interpretation of significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) F is a non-negative integer, E is an integer, and S is either 1 or -1. -- Function: MINUSP (number) Package:LISP Returns T if NUMBER < 0; NIL otherwise. -- Function: LOGORC1 (integer1 integer2) Package:LISP Returns the logical OR of (LOGNOT INTEGER1) and INTEGER2. -- Constant: MOST-NEGATIVE-SINGLE-FLOAT Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT. -- Constant: BOOLE-C1 Package:LISP Makes BOOLE return the complement of INTEGER1. -- Constant: LEAST-POSITIVE-SHORT-FLOAT Package:LISP The positive short-float closest in value to zero. -- Function: BIT-NAND (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NAND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: INT-CHAR (integer) Package:LISP Performs the inverse of CHAR-INT. Equivalent to CODE-CHAR in GCL. -- Function: CHAR-INT (char) Package:LISP Returns the font, bits, and code attributes as a single non-negative integer. Equivalent to CHAR-CODE in GCL. -- Constant: LEAST-NEGATIVE-SINGLE-FLOAT Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT. -- Function: /= (number &rest more-numbers) Package:LISP Returns T if no two of its arguments are numerically equal; NIL otherwise. -- Function: LDB-TEST (bytespec integer) Package:LISP Returns T if at least one of the bits in the specified bytes of INTEGER is 1; NIL otherwise. -- Constant: CHAR-CODE-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-CODE. -- Function: RATIONAL (number) Package:LISP Converts NUMBER into rational accurately and returns it. -- Constant: PI Package:LISP The floating-point number that is appropriately equal to the ratio of the circumference of the circle to the diameter. -- Function: SIN (radians) Package:LISP Returns the sine of RADIANS. -- Constant: BOOLE-ORC2 Package:LISP Makes BOOLE return LOGORC2 of INTEGER1 and INTEGER2. -- Function: NUMERATOR (rational) Package:LISP Returns as an integer the numerator of the given rational number. -- Function: MASK-FIELD (bytespec integer) Package:LISP Extracts the specified byte from INTEGER. -- Special Form: INCF Package:LISP Syntax: (incf place [delta]) Adds the number produced by DELTA (which defaults to 1) to the number in PLACE. -- Function: SINH (number) Package:LISP Returns the hyperbolic sine of NUMBER. -- Function: PHASE (number) Package:LISP Returns the angle part of the polar representation of a complex number. For non-complex numbers, this is 0. -- Function: BOOLE (op integer1 integer2) Package:LISP Returns an integer produced by performing the logical operation specified by OP on the two integers. OP must be the value of one of the following constants: BOOLE-CLR BOOLE-C1 BOOLE-XOR BOOLE-ANDC1 BOOLE-SET BOOLE-C2 BOOLE-EQV BOOLE-ANDC2 BOOLE-1 BOOLE-AND BOOLE-NAND BOOLE-ORC1 BOOLE-2 BOOLE-IOR BOOLE-NOR BOOLE-ORC2 See the variable docs of these constants for their operations. -- Constant: SHORT-FLOAT-EPSILON Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))). -- Function: LOGORC2 (integer1 integer2) Package:LISP Returns the logical OR of INTEGER1 and (LOGNOT INTEGER2). -- Constant: BOOLE-C2 Package:LISP Makes BOOLE return the complement of INTEGER2. -- Function: REALPART (number) Package:LISP Extracts the real part of NUMBER. -- Constant: BOOLE-CLR Package:LISP Makes BOOLE return 0. -- Constant: BOOLE-IOR Package:LISP Makes BOOLE return LOGIOR of INTEGER1 and INTEGER2. -- Function: FTRUNCATE (number &optional (divisor 1)) Package:LISP Values: (quotient remainder) Same as TRUNCATE, but returns first value as a float. -- Function: EQL (x y) Package:LISP Returns T if X and Y are EQ, or if they are numbers of the same type with the same value, or if they are character objects that represent the same character. Returns NIL otherwise. -- Function: LOG (number &optional base) Package:LISP Returns the logarithm of NUMBER in the base BASE. BASE defaults to the base of natural logarithms. -- Constant: DOUBLE-FLOAT-NEGATIVE-EPSILON Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON. -- Function: LOGIOR (&rest integers) Package:LISP Returns the bit-wise INCLUSIVE OR of its arguments. -- Constant: MOST-NEGATIVE-DOUBLE-FLOAT Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT. -- Function: / (number &rest more-numbers) Package:LISP Divides the first NUMBER by each of the subsequent NUMBERS. With one arg, returns the reciprocal of the number. -- Variable: *RANDOM-STATE* Package:LISP The default random-state object used by RAMDOM. -- Function: 1+ (number) Package:LISP Returns NUMBER + 1. -- Constant: LEAST-NEGATIVE-DOUBLE-FLOAT Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT. -- Function: FCEILING (number &optional (divisor 1)) Package:LISP Same as CEILING, but returns a float as the first value. -- Constant: MOST-POSITIVE-FIXNUM Package:LISP The fixnum closest in value to positive infinity. -- Function: BIT-ANDC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ANDC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: TAN (radians) Package:LISP Returns the tangent of RADIANS. -- Constant: BOOLE-NAND Package:LISP Makes BOOLE return LOGNAND of INTEGER1 and INTEGER2. -- Function: TANH (number) Package:LISP Returns the hyperbolic tangent of NUMBER. -- Function: ASIN (number) Package:LISP Returns the arc sine of NUMBER. -- Function: BYTE (size position) Package:LISP Returns a byte specifier. In GCL, a byte specifier is represented by a dotted pair ( . ). -- Function: ASINH (number) Package:LISP Returns the hyperbolic arc sine of NUMBER. -- Constant: MOST-POSITIVE-LONG-FLOAT Package:LISP The long-float closest in value to positive infinity. -- Macro: SHIFTF Package:LISP Syntax: (shiftf {place}+ newvalue) Evaluates all PLACEs and NEWVALUE in turn, then assigns the value of each form to the PLACE on its left. Returns the original value of the leftmost form. -- Constant: LEAST-POSITIVE-LONG-FLOAT Package:LISP The positive long-float closest in value to zero. -- Function: DEPOSIT-FIELD (newbyte bytespec integer) Package:LISP Returns an integer computed by replacing the specified byte of INTEGER with the specified byte of NEWBYTE. -- Function: BIT-AND (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical AND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: LOGNAND (integer1 integer2) Package:LISP Returns the complement of the logical AND of INTEGER1 and INTEGER2. -- Function: BYTE-POSITION (bytespec) Package:LISP Returns the position part (in GCL, the cdr part) of the byte specifier. -- Macro: ROTATEF Package:LISP Syntax: (rotatef {place}*) Evaluates PLACEs in turn, then assigns to each PLACE the value of the form to its right. The rightmost PLACE gets the value of the leftmost PLACE. Returns NIL always. -- Function: BIT-ANDC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ANDC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: TRUNCATE (number &optional (divisor 1)) Package:LISP Values: (quotient remainder) Returns NUMBER/DIVISOR as an integer, rounded toward 0. The second returned value is the remainder. -- Constant: BOOLE-EQV Package:LISP Makes BOOLE return LOGEQV of INTEGER1 and INTEGER2. -- Constant: BOOLE-SET Package:LISP Makes BOOLE return -1. -- Function: LDB (bytespec integer) Package:LISP Extracts and right-justifies the specified byte of INTEGER, and returns the result. -- Function: BYTE-SIZE (bytespec) Package:LISP Returns the size part (in GCL, the car part) of the byte specifier. -- Constant: SHORT-FLOAT-NEGATIVE-EPSILON Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (- (float 1 e) e))). -- Function: REM (number divisor) Package:LISP Returns the second value of (TRUNCATE NUMBER DIVISOR). -- Function: MIN (number &rest more-numbers) Package:LISP Returns the least of its arguments. -- Function: EXP (number) Package:LISP Calculates e raised to the power NUMBER, where e is the base of natural logarithms. -- Function: DECODE-FLOAT (float) Package:LISP Returns, as three values, the significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) S and F are floating-point numbers of the same float format as FLOAT, and E is an integer. -- Constant: LONG-FLOAT-EPSILON Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))). -- Function: FROUND (number &optional (divisor 1)) Package:LISP Same as ROUND, but returns first value as a float. -- Function: LOGEQV (&rest integers) Package:LISP Returns the bit-wise EQUIVALENCE of its arguments. -- Constant: MOST-NEGATIVE-SHORT-FLOAT Package:LISP The short-float closest in value to negative infinity. -- Function: BIT-NOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: CEILING (number &optional (divisor 1)) Package:LISP Returns the smallest integer not less than or NUMBER/DIVISOR. Returns the remainder as the second value. -- Constant: LEAST-NEGATIVE-SHORT-FLOAT Package:LISP The negative short-float closest in value to zero. -- Function: 1- (number) Package:LISP Returns NUMBER - 1. -- Function: <= (number &rest more-numbers) Package:LISP Returns T if arguments are in strictly non-decreasing order; NIL otherwise. -- Function: IMAGPART (number) Package:LISP Extracts the imaginary part of NUMBER. -- Function: INTEGERP (x) Package:LISP Returns T if X is an integer (fixnum or bignum); NIL otherwise. -- Function: ASH (integer count) Package:LISP Shifts INTEGER left by COUNT places. Shifts right if COUNT is negative. -- Function: LCM (integer &rest more-integers) Package:LISP Returns the least common multiple of the arguments. -- Function: COS (radians) Package:LISP Returns the cosine of RADIANS. -- Special Form: DECF Package:LISP Syntax: (decf place [delta]) Subtracts the number produced by DELTA (which defaults to 1) from the number in PLACE. -- Function: ATAN (x &optional (y 1)) Package:LISP Returns the arc tangent of X/Y. -- Constant: BOOLE-ANDC1 Package:LISP Makes BOOLE return LOGANDC1 of INTEGER1 and INTEGER2. -- Function: COSH (number) Package:LISP Returns the hyperbolic cosine of NUMBER. -- Function: FLOAT-RADIX (float) Package:LISP Returns the representation radix (or base) of the floating-point number. -- Function: ATANH (number) Package:LISP Returns the hyperbolic arc tangent of NUMBER. -- Function: EVENP (integer) Package:LISP Returns T if INTEGER is even. Returns NIL if INTEGER is odd. -- Function: ZEROP (number) Package:LISP Returns T if NUMBER = 0; NIL otherwise. -- Function: FLOATP (x) Package:LISP Returns T if X is a floating-point number; NIL otherwise. -- Function: SXHASH (object) Package:LISP Computes a hash code for OBJECT and returns it as an integer. -- Constant: BOOLE-1 Package:LISP Makes BOOLE return INTEGER1. -- Constant: MOST-POSITIVE-SINGLE-FLOAT Package:LISP Same as MOST-POSITIVE-LONG-FLOAT. -- Function: LOGANDC1 (integer1 integer2) Package:LISP Returns the logical AND of (LOGNOT INTEGER1) and INTEGER2. -- Constant: LEAST-POSITIVE-SINGLE-FLOAT Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT. -- Function: COMPLEXP (x) Package:LISP Returns T if X is a complex number; NIL otherwise. -- Constant: BOOLE-AND Package:LISP Makes BOOLE return LOGAND of INTEGER1 and INTEGER2. -- Function: MAX (number &rest more-numbers) Package:LISP Returns the greatest of its arguments. -- Function: FLOAT-SIGN (float1 &optional (float2 (float 1 float1))) Package:LISP Returns a floating-point number with the same sign as FLOAT1 and with the same absolute value as FLOAT2. -- Constant: BOOLE-ANDC2 Package:LISP Makes BOOLE return LOGANDC2 of INTEGER1 and INTEGER2. -- Function: DENOMINATOR (rational) Package:LISP Returns the denominator of RATIONAL as an integer. -- Function: FLOAT (number &optional other) Package:LISP Converts a non-complex number to a floating-point number. If NUMBER is already a float, FLOAT simply returns NUMBER. Otherwise, the format of the returned float depends on OTHER; If OTHER is not provided, FLOAT returns a SINGLE-FLOAT. If OTHER is provided, the result is in the same float format as OTHER's. -- Function: ROUND (number &optional (divisor 1)) Package:LISP Rounds NUMBER/DIVISOR to nearest integer. The second returned value is the remainder. -- Function: LOGAND (&rest integers) Package:LISP Returns the bit-wise AND of its arguments. -- Constant: BOOLE-2 Package:LISP Makes BOOLE return INTEGER2. -- Function: * (&rest numbers) Package:LISP Returns the product of its arguments. With no args, returns 1. -- Function: < (number &rest more-numbers) Package:LISP Returns T if its arguments are in strictly increasing order; NIL otherwise. -- Function: COMPLEX (realpart &optional (imagpart 0)) Package:LISP Returns a complex number with the given real and imaginary parts. -- Constant: SINGLE-FLOAT-EPSILON Package:LISP Same as LONG-FLOAT-EPSILON. -- Function: LOGANDC2 (integer1 integer2) Package:LISP Returns the logical AND of INTEGER1 and (LOGNOT INTEGER2). -- Function: INTEGER-LENGTH (integer) Package:LISP Returns the number of significant bits in the absolute value of INTEGER. -- Constant: MOST-NEGATIVE-FIXNUM Package:LISP The fixnum closest in value to negative infinity. -- Constant: LONG-FLOAT-NEGATIVE-EPSILON Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (- (float 1 e) e))). -- Function: >= (number &rest more-numbers) Package:LISP Returns T if arguments are in strictly non-increasing order; NIL otherwise. -- Constant: BOOLE-NOR Package:LISP Makes BOOLE return LOGNOR of INTEGER1 and INTEGER2. -- Function: ACOS (number) Package:LISP Returns the arc cosine of NUMBER. -- Function: MAKE-RANDOM-STATE (&optional (state *random-state*)) Package:LISP Creates and returns a copy of the specified random state. If STATE is NIL, then the value of *RANDOM-STATE* is used. If STATE is T, then returns a random state object generated from the universal time. -- Function: EXPT (base-number power-number) Package:LISP Returns BASE-NUMBER raised to the power POWER-NUMBER. -- Function: SQRT (number) Package:LISP Returns the principal square root of NUMBER. -- Function: SCALE-FLOAT (float integer) Package:LISP Returns (* FLOAT (expt (float-radix FLOAT) INTEGER)). -- Function: ACOSH (number) Package:LISP Returns the hyperbolic arc cosine of NUMBER. -- Constant: MOST-NEGATIVE-LONG-FLOAT Package:LISP The long-float closest in value to negative infinity. -- Constant: LEAST-NEGATIVE-LONG-FLOAT Package:LISP The negative long-float closest in value to zero. -- Function: FFLOOR (number &optional (divisor 1)) Package:LISP Same as FLOOR, but returns a float as the first value. -- Function: LOGNOR (integer1 integer2) Package:LISP Returns the complement of the logical OR of INTEGER1 and INTEGER2. -- Function: PARSE-INTEGER (string &key (start 0) (end (length string)) (radix 10) (junk-allowed nil)) Package:LISP Parses STRING for an integer and returns it. -- Function: + (&rest numbers) Package:LISP Returns the sum of its arguments. With no args, returns 0. -- Function: = (number &rest more-numbers) Package:LISP Returns T if all of its arguments are numerically equal; NIL otherwise. -- Function: NUMBERP (x) Package:LISP Returns T if X is any kind of number; NIL otherwise. -- Constant: MOST-POSITIVE-DOUBLE-FLOAT Package:LISP Same as MOST-POSITIVE-LONG-FLOAT. -- Function: LOGTEST (integer1 integer2) Package:LISP Returns T if LOGAND of INTEGER1 and INTEGER2 is not zero; NIL otherwise. -- Function: RANDOM-STATE-P (x) Package:LISP Returns T if X is a random-state object; NIL otherwise. -- Constant: LEAST-POSITIVE-DOUBLE-FLOAT Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT. -- Function: FLOAT-PRECISION (float) Package:LISP Returns the number of significant radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). -- Constant: BOOLE-XOR Package:LISP Makes BOOLE return LOGXOR of INTEGER1 and INTEGER2. -- Function: DPB (newbyte bytespec integer) Package:LISP Returns an integer computed by replacing the specified byte of INTEGER with NEWBYTE. -- Function: ABS (number) Package:LISP Returns the absolute value of NUMBER. -- Function: CONJUGATE (number) Package:LISP Returns the complex conjugate of NUMBER. -- Function: CIS (radians) Package:LISP Returns e raised to i*RADIANS. -- Function: ODDP (integer) Package:LISP Returns T if INTEGER is odd; NIL otherwise. -- Function: RATIONALIZE (number) Package:LISP Converts NUMBER into rational approximately and returns it. -- Function: ISQRT (integer) Package:LISP Returns the greatest integer less than or equal to the square root of the given non-negative integer. -- Function: LOGXOR (&rest integers) Package:LISP Returns the bit-wise EXCLUSIVE OR of its arguments. -- Function: > (number &rest more-numbers) Package:LISP Returns T if its arguments are in strictly decreasing order; NIL otherwise. -- Function: LOGBITP (index integer) Package:LISP Returns T if the INDEX-th bit of INTEGER is 1. -- Constant: DOUBLE-FLOAT-EPSILON Package:LISP Same as LONG-FLOAT-EPSILON. -- Function: LOGCOUNT (integer) Package:LISP If INTEGER is negative, returns the number of 0 bits. Otherwise, returns the number of 1 bits. -- Function: GCD (&rest integers) Package:LISP Returns the greatest common divisor of INTEGERs. -- Function: RATIONALP (x) Package:LISP Returns T if X is an integer or a ratio; NIL otherwise. -- Function: MOD (number divisor) Package:LISP Returns the second result of (FLOOR NUMBER DIVISOR). -- Function: MODF (number) Package:SYSTEM Returns the integer and fractional part of a floating point number mod 1.0. -- Constant: BOOLE-ORC1 Package:LISP Makes BOOLE return LOGORC1 of INTEGER1 and INTEGER2. -- Constant: SINGLE-FLOAT-NEGATIVE-EPSILON Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON. -- Function: FLOOR (number &optional (divisor 1)) Package:LISP Returns the largest integer not larger than the NUMBER divided by DIVISOR. The second returned value is (- NUMBER (* first-value DIVISOR)). -- Function: PLUSP (number) Package:LISP Returns T if NUMBER > 0; NIL otherwise. -- Function: FLOAT-DIGITS (float) Package:LISP Returns the number of radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). -- Function: RANDOM (number &optional (state *random-state*)) Package:LISP Generates a uniformly distributed pseudo-random number between zero (inclusive) and NUMBER (exclusive), by using the random state object STATE.  File: gcl-si.info, Node: Sequences and Arrays and Hash Tables, Next: Characters, Prev: Numbers, Up: Top 2 Sequences and Arrays and Hash Tables ************************************** -- Function: VECTOR (&rest objects) Package:LISP Constructs a Simple-Vector from the given objects. -- Function: SUBSEQ (sequence start &optional (end (length sequence))) Package:LISP Returns a copy of a subsequence of SEQUENCE between START (inclusive) and END (exclusive). -- Function: COPY-SEQ (sequence) Package:LISP Returns a copy of SEQUENCE. -- Function: POSITION (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST with ITEM; NIL if no such element exists. -- Function: ARRAY-RANK (array) Package:LISP Returns the number of dimensions of ARRAY. -- Function: SBIT (simple-bit-array &rest subscripts) Package:LISP Returns the bit from SIMPLE-BIT-ARRAY at SUBSCRIPTS. -- Function: STRING-CAPITALIZE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case. -- Function: NSUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed. -- Function: FIND-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists. -- Function: BIT-EQV (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical EQV on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: STRING< (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically less than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. -- Function: REVERSE (sequence) Package:LISP Returns a new sequence containing the same elements as SEQUENCE but in reverse order. -- Function: NSTRING-UPCASE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with all lower case characters converted to uppercase. -- Function: STRING>= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically greater than or equal to STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. -- Function: ARRAY-ROW-MAJOR-INDEX (array &rest subscripts) Package:LISP Returns the index into the data vector of ARRAY for the element of ARRAY specified by SUBSCRIPTS. -- Function: ARRAY-DIMENSION (array axis-number) Package:LISP Returns the length of AXIS-NUMBER of ARRAY. -- Function: FIND (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the first element in SEQUENCE satisfying TEST with ITEM; NIL if no such element exists. -- Function: STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING=, but ignores cases. -- Function: STRING-RIGHT-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from the right end. -- Function: DELETE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by destructively removing the elements not satisfying TEST from SEQUENCE. -- Function: REMOVE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with elements not satisfying TEST removed. -- Function: STRING= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Returns T if the two strings are character-wise CHAR=; NIL otherwise. -- Function: NSUBSTITUTE-IF (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM. SEQUENCE may be destroyed. -- Function: SOME (predicate sequence &rest more-sequences) Package:LISP Returns T if at least one of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise. -- Function: MAKE-STRING (size &key (initial-element #\Space)) Package:LISP Creates and returns a new string of SIZE length whose elements are all INITIAL-ELEMENT. -- Function: NSUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM. SEQUENCE may be destroyed. -- Function: STRING-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Given two strings (string1 and string2), and optional integers start1, start2, end1 and end2, compares characters in string1 to characters in string2 (using char-equal). -- Function: STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING<=, but ignores cases. -- Function: STRING> (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically greater than STRING2, then returns the longest common prefix of the strings. Otherwise, returns NIL. -- Function: STRINGP (x) Package:LISP Returns T if X is a string; NIL otherwise. -- Function: DELETE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by removing the elements satisfying TEST destructively from SEQUENCE. -- Function: SIMPLE-STRING-P (x) Package:LISP Returns T if X is a simple string; NIL otherwise. -- Function: REMOVE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with elements satisfying TEST removed. -- Function: HASH-TABLE-COUNT (hash-table) Package:LISP Returns the number of entries in the given Hash-Table. -- Function: ARRAY-DIMENSIONS (array) Package:LISP Returns a list whose elements are the dimensions of ARRAY -- Function: SUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying TEST are replaced with NEWITEM. -- Function: ADJUSTABLE-ARRAY-P (array) Package:LISP Returns T if ARRAY is adjustable; NIL otherwise. -- Function: SVREF (simple-vector index) Package:LISP Returns the INDEX-th element of SIMPLE-VECTOR. -- Function: VECTOR-PUSH-EXTEND (new-element vector &optional (extension (length vector))) Package:LISP Similar to VECTOR-PUSH except that, if the fill pointer gets too large, extends VECTOR rather then simply returns NIL. -- Function: DELETE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence formed by removing the specified ITEM destructively from SEQUENCE. -- Function: REMOVE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a copy of SEQUENCE with ITEM removed. -- Function: STRING (x) Package:LISP Coerces X into a string. If X is a string, then returns X itself. If X is a symbol, then returns X's print name. If X is a character, then returns a one element string containing that character. Signals an error if X cannot be coerced into a string. -- Function: STRING-UPCASE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with all lower case characters converted to uppercase. -- Function: GETHASH (key hash-table &optional (default nil)) Package:LISP Finds the entry in HASH-TABLE whose key is KEY and returns the associated value and T, as multiple values. Returns DEFAULT and NIL if there is no such entry. -- Function: MAKE-HASH-TABLE (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7)) Package:LISP Creates and returns a hash table. -- Function: STRING/= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Returns NIL if STRING1 and STRING2 are character-wise CHAR=. Otherwise, returns the index to the longest common prefix of the strings. -- Function: STRING-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING>, but ignores cases. -- Function: ELT (sequence index) Package:LISP Returns the INDEX-th element of SEQUENCE. -- Function: MAKE-ARRAY (dimensions &key (element-type t) initial-element (initial-contents nil) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0) static) Package:LISP Creates an array of the specified DIMENSIONS. The default for INITIAL- ELEMENT depends on ELEMENT-TYPE. MAKE-ARRAY will always try to find the 'best' array to accommodate the element-type specified. For example on a SUN element-type (mod 1) -> bit (integer 0 10) -> unsigned-char (integer -3 10) -> signed-char si::best-array-element-type is the function doing this. It is also used by the compiler, for coercing array element types. If you are going to declare an array you should use the same element type as was used in making it. eg (setq my-array (make-array 4 :element-type '(integer 0 10))) (the (array (integer 0 10)) my-array) When wanting to optimize references to an array you need to declare the array eg: (the (array (integer -3 10)) my-array) if ar were constructed using the (integer -3 10) element-type. You could of course have used signed-char, but since the ranges may be implementation dependent it is better to use -3 10 range. MAKE-ARRAY needs to do some calculation with the element-type if you don't provide a primitive data-type. One way of doing this in a machine independent fashion: (defvar *my-elt-type* #. (array-element-type (make-array 1 :element-type '(integer -3 10)))) Then calls to (make-array n :element-type *my-elt-type*) will not have to go through a type inclusion computation. The keyword STATIC (GCL specific) if non nil, will cause the array body to be non relocatable. -- Function: NSTRING-DOWNCASE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with all upper case characters converted to lowercase. -- Function: ARRAY-IN-BOUNDS-P (array &rest subscripts) Package:LISP Returns T if SUBSCRIPTS are valid subscripts for ARRAY; NIL otherwise. -- Function: SORT (sequence predicate &key (key #'identity)) Package:LISP Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument. -- Function: HASH-TABLE-P (x) Package:LISP Returns T if X is a hash table object; NIL otherwise. -- Function: COUNT-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE not satisfying TEST. -- Function: FILL-POINTER (vector) Package:LISP Returns the fill pointer of VECTOR. -- Function: ARRAYP (x) Package:LISP Returns T if X is an array; NIL otherwise. -- Function: REPLACE (sequence1 sequence2 &key (start1 0) (end1 (length sequence1)) (start2 0) (end2 (length sequence2))) Package:LISP Destructively modifies SEQUENCE1 by copying successive elements into it from SEQUENCE2. -- Function: BIT-XOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical XOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: CLRHASH (hash-table) Package:LISP Removes all entries of HASH-TABLE and returns the hash table itself. -- Function: SUBSTITUTE-IF (newitem test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that all elements satisfying TEST are replaced with NEWITEM. -- Function: MISMATCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) Package:LISP The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the result is NIL. Otherwise, the result is a non-negative integer, the index within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within SEQUENCE1 beyond the last position tested is returned. -- Constant: ARRAY-TOTAL-SIZE-LIMIT Package:LISP The exclusive upper bound on the total number of elements of an array. -- Function: VECTOR-POP (vector) Package:LISP Attempts to decrease the fill-pointer of VECTOR by 1 and returns the element pointed to by the new fill pointer. Signals an error if the old value of the fill pointer is 0. -- Function: SUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) Package:LISP Returns a sequence of the same kind as SEQUENCE with the same elements except that OLDITEMs are replaced with NEWITEM. -- Function: ARRAY-HAS-FILL-POINTER-P (array) Package:LISP Returns T if ARRAY has a fill pointer; NIL otherwise. -- Function: CONCATENATE (result-type &rest sequences) Package:LISP Returns a new sequence of the specified RESULT-TYPE, consisting of all elements in SEQUENCEs. -- Function: VECTOR-PUSH (new-element vector) Package:LISP Attempts to set the element of ARRAY designated by its fill pointer to NEW-ELEMENT and increments the fill pointer by one. Returns NIL if the fill pointer is too large. Otherwise, returns the new fill pointer value. -- Function: STRING-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from both ends. -- Function: ARRAY-ELEMENT-TYPE (array) Package:LISP Returns the type of the elements of ARRAY -- Function: NOTANY (predicate sequence &rest more-sequences) Package:LISP Returns T if none of the elements in SEQUENCEs satisfies PREDICATE; NIL otherwise. -- Function: BIT-NOT (bit-array &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NOT in the elements of BIT-ARRAY. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: BIT-ORC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ORC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: COUNT-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE satisfying TEST. -- Function: MAP (result-type function sequence &rest more-sequences) Package:LISP FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that the i-th element is the result of applying FUNCTION to the i-th elements of the SEQUENCEs. -- Constant: ARRAY-RANK-LIMIT Package:LISP The exclusive upper bound on the rank of an array. -- Function: COUNT (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the number of elements in SEQUENCE satisfying TEST with ITEM. -- Function: BIT-VECTOR-P (x) Package:LISP Returns T if X is a bit vector; NIL otherwise. -- Function: NSTRING-CAPITALIZE (string &key (start 0) (end (length string))) Package:LISP Returns STRING with the first character of each word converted to upper-case, and remaining characters in the word converted to lower case. -- Function: ADJUST-ARRAY (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0)) Package:LISP Adjusts the dimensions of ARRAY to the given DIMENSIONS. The default value of INITIAL-ELEMENT depends on ELEMENT-TYPE. -- Function: SEARCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) Package:LISP A search is conducted for the first subsequence of SEQUENCE2 which element-wise matches SEQUENCE1. If there is such a subsequence in SEQUENCE2, the index of the its leftmost element is returned; otherwise, NIL is returned. -- Function: SIMPLE-BIT-VECTOR-P (x) Package:LISP Returns T if X is a simple bit-vector; NIL otherwise. -- Function: MAKE-SEQUENCE (type length &key initial-element) Package:LISP Returns a sequence of the given TYPE and LENGTH, with elements initialized to INITIAL-ELEMENT. The default value of INITIAL-ELEMENT depends on TYPE. -- Function: BIT-ORC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ORC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: NREVERSE (sequence) Package:LISP Returns a sequence of the same elements as SEQUENCE but in reverse order. SEQUENCE may be destroyed. -- Constant: ARRAY-DIMENSION-LIMIT Package:LISP The exclusive upper bound of the array dimension. -- Function: NOTEVERY (predicate sequence &rest more-sequences) Package:LISP Returns T if at least one of the elements in SEQUENCEs does not satisfy PREDICATE; NIL otherwise. -- Function: POSITION-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists. -- Function: STRING-DOWNCASE (string &key (start 0) (end (length string))) Package:LISP Returns a copy of STRING with all upper case characters converted to lowercase. -- Function: BIT (bit-array &rest subscripts) Package:LISP Returns the bit from BIT-ARRAY at SUBSCRIPTS. -- Function: STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING>=, but ignores cases. -- Function: CHAR (string index) Package:LISP Returns the INDEX-th character in STRING. -- Function: AREF (array &rest subscripts) Package:LISP Returns the element of ARRAY specified by SUBSCRIPTS. -- Function: FILL (sequence item &key (start 0) (end (length sequence))) Package:LISP Replaces the specified elements of SEQUENCE all with ITEM. -- Function: STABLE-SORT (sequence predicate &key (key #'identity)) Package:LISP Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first argument is to precede its second argument. -- Function: BIT-IOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical IOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. -- Function: REMHASH (key hash-table) Package:LISP Removes any entry for KEY in HASH-TABLE. Returns T if such an entry existed; NIL otherwise. -- Function: VECTORP (x) Package:LISP Returns T if X is a vector; NIL otherwise. -- Function: STRING<= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP If STRING1 is lexicographically less than or equal to STRING2, then returns the longest common prefix of the two strings. Otherwise, returns NIL. -- Function: SIMPLE-VECTOR-P (x) Package:LISP Returns T if X is a simple vector; NIL otherwise. -- Function: STRING-LEFT-TRIM (char-bag string) Package:LISP Returns a copy of STRING with the characters in CHAR-BAG removed from the left end. -- Function: ARRAY-TOTAL-SIZE (array) Package:LISP Returns the total number of elements of ARRAY. -- Function: FIND-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that does not satisfy TEST; NIL if no such element exists. -- Function: DELETE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns a sequence formed by removing duplicated elements destructively from SEQUENCE. -- Function: REMOVE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) Package:LISP The elements of SEQUENCE are examined, and if any two match, one is discarded. Returns the resulting sequence. -- Function: POSITION-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) Package:LISP Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if no such element exists. -- Function: MERGE (result-type sequence1 sequence2 predicate &key (key #'identity)) Package:LISP SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type RESULT-TYPE using PREDICATE to order the elements. -- Function: EVERY (predicate sequence &rest more-sequences) Package:LISP Returns T if every elements of SEQUENCEs satisfy PREDICATE; NIL otherwise. -- Function: REDUCE (function sequence &key (from-end nil) (start 0) (end (length sequence)) initial-value) Package:LISP Combines all the elements of SEQUENCE using a binary operation FUNCTION. If INITIAL-VALUE is supplied, it is logically placed before the SEQUENCE. -- Function: STRING-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) Package:LISP Similar to STRING<, but ignores cases.  File: gcl-si.info, Node: Characters, Next: Lists, Prev: Sequences and Arrays and Hash Tables, Up: Top 3 Characters ************ -- Function: NAME-CHAR (name) Package:LISP Given an argument acceptable to string, Returns a character object whose name is NAME if one exists. Returns NIL otherwise. NAME must be an object that can be coerced to a string. -- Function: CHAR-NAME (char) Package:LISP Returns the name for CHAR as a string; NIL if CHAR has no name. Only #\Backspace, #\Tab, #\Newline (or #\Linefeed), #\Page, #\Return, and #\Rubout have names. -- Function: BOTH-CASE-P (char) Package:LISP Returns T if CHAR is an alphabetic character; NIL otherwise. Equivalent to ALPHA-CHAR-P. -- Function: SCHAR (simple-string index) Package:LISP Returns the character object representing the INDEX-th character in STRING. This is faster than CHAR. -- Constant: CHAR-SUPER-BIT Package:LISP The bit that indicates a super character. -- Constant: CHAR-FONT-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-FONT. -- Function: CHAR-DOWNCASE (char) Package:LISP Returns the lower-case equivalent of CHAR, if any. If not, simply returns CHAR. -- Function: STRING-CHAR-P (char) Package:LISP Returns T if CHAR can be stored in a string. In GCL, this function always returns T since any character in GCL can be stored in a string. -- Function: CHAR-NOT-LESSP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. -- Function: DISASSEMBLE (thing) Package:LISP Compiles the form specified by THING and prints the intermediate C language code for that form. But does NOT install the result of compilation. If THING is a symbol that names a not-yet-compiled function, the function definition is disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form. -- Function: LOWER-CASE-P (char) Package:LISP Returns T if CHAR is a lower-case character; NIL otherwise. -- Function: CHAR<= (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise. -- Constant: CHAR-HYPER-BIT Package:LISP The bit that indicates a hyper character. -- Function: CODE-CHAR (code &optional (bits 0) (font 0)) Package:LISP Returns a character object with the specified code, if any. If not, returns NIL. -- Function: CHAR-CODE (char) Package:LISP Returns the code attribute of CHAR. -- Constant: CHAR-CONTROL-BIT Package:LISP The bit that indicates a control character. -- Function: CHAR-LESSP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. -- Function: CHAR-FONT (char) Package:LISP Returns the font attribute of CHAR. -- Function: CHAR< (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. -- Function: CHAR>= (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise. -- Constant: CHAR-META-BIT Package:LISP The bit that indicates a meta character. -- Function: GRAPHIC-CHAR-P (char) Package:LISP Returns T if CHAR is a printing character, i.e., #\Space through #\~; NIL otherwise. -- Function: CHAR-NOT-EQUAL (char &rest more-chars) Package:LISP Returns T if no two of CHARs are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same. -- Constant: CHAR-BITS-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-BITS. -- Function: CHARACTERP (x) Package:LISP Returns T if X is a character; NIL otherwise. -- Function: CHAR= (char &rest more-chars) Package:LISP Returns T if all CHARs are the same character; NIL otherwise. -- Function: ALPHA-CHAR-P (char) Package:LISP Returns T if CHAR is an alphabetic character, A-Z or a-z; NIL otherwise. -- Function: UPPER-CASE-P (char) Package:LISP Returns T if CHAR is an upper-case character; NIL otherwise. -- Function: CHAR-BIT (char name) Package:LISP Returns T if the named bit is on in the character CHAR; NIL otherwise. In GCL, this function always returns NIL. -- Function: MAKE-CHAR (char &optional (bits 0) (font 0)) Package:LISP Returns a character object with the same code attribute as CHAR and with the specified BITS and FONT attributes. -- Function: CHARACTER (x) Package:LISP Coerces X into a character object if possible. -- Function: CHAR-EQUAL (char &rest more-chars) Package:LISP Returns T if all of its arguments are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same. -- Function: CHAR-NOT-GREATERP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. -- Function: CHAR> (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise. -- Function: STANDARD-CHAR-P (char) Package:LISP Returns T if CHAR is a standard character, i.e., one of the 95 ASCII printing characters #\Space to #\~ and #Newline; NIL otherwise. -- Function: CHAR-UPCASE (char) Package:LISP Returns the upper-case equivalent of CHAR, if any. If not, simply returns CHAR. -- Function: DIGIT-CHAR-P (char &optional (radix 10)) Package:LISP If CHAR represents a digit in RADIX, then returns the weight as an integer. Otherwise, returns nil. -- Function: CHAR/= (char &rest more-chars) Package:LISP Returns T if no two of CHARs are the same character; NIL otherwise. -- Function: CHAR-GREATERP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. -- Function: ALPHANUMERICP (char) Package:LISP Returns T if CHAR is either numeric or alphabetic; NIL otherwise. -- Function: CHAR-BITS (char) Package:LISP Returns the bits attribute (which is always 0 in GCL) of CHAR. -- Function: DIGIT-CHAR (digit &optional (radix 10) (font 0)) Package:LISP Returns a character object that represents the DIGIT in the specified RADIX. Returns NIL if no such character exists. -- Function: SET-CHAR-BIT (char name newvalue) Package:LISP Returns a character just like CHAR except that the named bit is set or cleared, according to whether NEWVALUE is non-NIL or NIL. This function is useless in GCL.  File: gcl-si.info, Node: Lists, Next: Streams and Reading, Prev: Characters, Up: Top 4 Lists ******* -- Function: NINTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the intersection of LIST1 and LIST2. LIST1 may be destroyed. -- Function: RASSOC-IF (predicate alist) Package:LISP Returns the first cons in ALIST whose cdr satisfies PREDICATE. -- Function: MAKE-LIST (size &key (initial-element nil)) Package:LISP Creates and returns a list containing SIZE elements, each of which is initialized to INITIAL-ELEMENT. -- Function: NTH (n list) Package:LISP Returns the N-th element of LIST, where the car of LIST is the zeroth element. -- Function: CAAR (x) Package:LISP Equivalent to (CAR (CAR X)). -- Function: NULL (x) Package:LISP Returns T if X is NIL; NIL otherwise. -- Function: FIFTH (x) Package:LISP Equivalent to (CAR (CDDDDR X)). -- Function: NCONC (&rest lists) Package:LISP Concatenates LISTs by destructively modifying them. -- Function: TAILP (sublist list) Package:LISP Returns T if SUBLIST is one of the conses in LIST; NIL otherwise. -- Function: CONSP (x) Package:LISP Returns T if X is a cons; NIL otherwise. -- Function: TENTH (x) Package:LISP Equivalent to (CADR (CDDDDR (CDDDDR X))). -- Function: LISTP (x) Package:LISP Returns T if X is either a cons or NIL; NIL otherwise. -- Function: MAPCAN (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs, NCONCs the results, and returns it. -- Function: EIGHTH (x) Package:LISP Equivalent to (CADDDR (CDDDDR X)). -- Function: LENGTH (sequence) Package:LISP Returns the length of SEQUENCE. -- Function: RASSOC (item alist &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the first cons in ALIST whose cdr is equal to ITEM. -- Function: NSUBST-IF-NOT (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that do not satisfy TEST. -- Function: NBUTLAST (list &optional (n 1)) Package:LISP Changes the cdr of the N+1 th cons from the end of the list LIST to NIL. Returns the whole list. -- Function: CDR (list) Package:LISP Returns the cdr of LIST. Returns NIL if LIST is NIL. -- Function: MAPC (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs. Returns the first LIST. -- Function: MAPL (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs. Returns the first LIST. -- Function: CONS (x y) Package:LISP Returns a new cons whose car and cdr are X and Y, respectively. -- Function: LIST (&rest args) Package:LISP Returns a list of its arguments -- Function: THIRD (x) Package:LISP Equivalent to (CADDR X). -- Function: CDDAAR (x) Package:LISP Equivalent to (CDR (CDR (CAR (CAR X)))). -- Function: CDADAR (x) Package:LISP Equivalent to (CDR (CAR (CDR (CAR X)))). -- Function: CDAADR (x) Package:LISP Equivalent to (CDR (CAR (CAR (CDR X)))). -- Function: CADDAR (x) Package:LISP Equivalent to (CAR (CDR (CDR (CAR X)))). -- Function: CADADR (x) Package:LISP Equivalent to (CAR (CDR (CAR (CDR X)))). -- Function: CAADDR (x) Package:LISP Equivalent to (CAR (CAR (CDR (CDR X)))). -- Function: NTHCDR (n list) Package:LISP Returns the result of performing the CDR operation N times on LIST. -- Function: PAIRLIS (keys data &optional (alist nil)) Package:LISP Constructs an association list from KEYS and DATA adding to ALIST. -- Function: SEVENTH (x) Package:LISP Equivalent to (CADDR (CDDDDR X)). -- Function: SUBSETP (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns T if every element of LIST1 appears in LIST2; NIL otherwise. -- Function: NSUBST-IF (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that satisfy TEST. -- Function: COPY-LIST (list) Package:LISP Returns a new copy of LIST. -- Function: LAST (list) Package:LISP Returns the last cons in LIST -- Function: CAAAR (x) Package:LISP Equivalent to (CAR (CAR (CAR X))). -- Function: LIST-LENGTH (list) Package:LISP Returns the length of LIST, or NIL if LIST is circular. -- Function: CDDDR (x) Package:LISP Equivalent to (CDR (CDR (CDR X))). -- Function: INTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the intersection of List1 and List2. -- Function: NSUBST (new old tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes NEW for subtrees in TREE that match OLD. -- Function: REVAPPEND (x y) Package:LISP Equivalent to (APPEND (REVERSE X) Y) -- Function: CDAR (x) Package:LISP Equivalent to (CDR (CAR X)). -- Function: CADR (x) Package:LISP Equivalent to (CAR (CDR X)). -- Function: REST (x) Package:LISP Equivalent to (CDR X). -- Function: NSET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list with elements which appear but once in LIST1 and LIST2. -- Function: ACONS (key datum alist) Package:LISP Constructs a new alist by adding the pair (KEY . DATUM) to ALIST. -- Function: SUBST-IF-NOT (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that do not satisfy TEST. -- Function: RPLACA (x y) Package:LISP Replaces the car of X with Y, and returns the modified X. -- Function: SECOND (x) Package:LISP Equivalent to (CADR X). -- Function: NUNION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the union of LIST1 and LIST2. LIST1 and/or LIST2 may be destroyed. -- Function: BUTLAST (list &optional (n 1)) Package:LISP Creates and returns a list with the same elements as LIST but without the last N elements. -- Function: COPY-ALIST (alist) Package:LISP Returns a new copy of ALIST. -- Function: SIXTH (x) Package:LISP Equivalent to (CADR (CDDDDR X)). -- Function: CAAAAR (x) Package:LISP Equivalent to (CAR (CAR (CAR (CAR X)))). -- Function: CDDDAR (x) Package:LISP Equivalent to (CDR (CDR (CDR (CAR X)))). -- Function: CDDADR (x) Package:LISP Equivalent to (CDR (CDR (CAR (CDR X)))). -- Function: CDADDR (x) Package:LISP Equivalent to (CDR (CAR (CDR (CDR X)))). -- Function: CADDDR (x) Package:LISP Equivalent to (CAR (CDR (CDR (CDR X)))). -- Function: FOURTH (x) Package:LISP Equivalent to (CADDDR X). -- Function: NSUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes from ALIST for subtrees of TREE. -- Function: SUBST-IF (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that satisfy TEST. -- Function: NSET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements of LIST1 that do not appear in LIST2. LIST1 may be destroyed. -- Special Form: POP Package:LISP Syntax: (pop place) Pops one item off the front of the list in PLACE and returns it. -- Special Form: PUSH Package:LISP Syntax: (push item place) Conses ITEM onto the list in PLACE, and returns the new list. -- Function: CDAAR (x) Package:LISP Equivalent to (CDR (CAR (CAR X))). -- Function: CADAR (x) Package:LISP Equivalent to (CAR (CDR (CAR X))). -- Function: CAADR (x) Package:LISP Equivalent to (CAR (CAR (CDR X))). -- Function: FIRST (x) Package:LISP Equivalent to (CAR X). -- Function: SUBST (new old tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that match OLD. -- Function: ADJOIN (item list &key (test #'eql) test-not (key #'identity)) Package:LISP Adds ITEM to LIST unless ITEM is already a member of LIST. -- Function: MAPCON (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs, NCONCs the results, and returns it. -- Macro: PUSHNEW Package:LISP Syntax: (pushnew item place {keyword value}*) If ITEM is already in the list stored in PLACE, does nothing. Else, conses ITEM onto the list. Returns NIL. If no KEYWORDs are supplied, each element in the list is compared with ITEM by EQL, but the comparison can be controlled by supplying keywords :TEST, :TEST-NOT, and/or :KEY. -- Function: SET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements appearing exactly once in LIST1 and LIST2. -- Function: TREE-EQUAL (x y &key (test #'eql) test-not) Package:LISP Returns T if X and Y are isomorphic trees with identical leaves. -- Function: CDDR (x) Package:LISP Equivalent to (CDR (CDR X)). -- Function: GETF (place indicator &optional (default nil)) Package:LISP Searches the property list stored in Place for an indicator EQ to Indicator. If one is found, the corresponding value is returned, else the Default is returned. -- Function: LDIFF (list sublist) Package:LISP Returns a new list, whose elements are those of LIST that appear before SUBLIST. If SUBLIST is not a tail of LIST, a copy of LIST is returned. -- Function: UNION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the union of LIST1 and LIST2. -- Function: ASSOC-IF-NOT (test alist) Package:LISP Returns the first pair in ALIST whose car does not satisfy TEST. -- Function: RPLACD (x y) Package:LISP Replaces the cdr of X with Y, and returns the modified X. -- Function: MEMBER-IF-NOT (test list &key (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first element not satisfying TEST. -- Function: CAR (list) Package:LISP Returns the car of LIST. Returns NIL if LIST is NIL. -- Function: ENDP (x) Package:LISP Returns T if X is NIL. Returns NIL if X is a cons. Otherwise, signals an error. -- Function: LIST* (arg &rest others) Package:LISP Returns a list of its arguments with the last cons being a dotted pair of the next to the last argument and the last argument. -- Function: NINTH (x) Package:LISP Equivalent to (CAR (CDDDDR (CDDDDR X))). -- Function: CDAAAR (x) Package:LISP Equivalent to (CDR (CAR (CAR (CAR X)))). -- Function: CADAAR (x) Package:LISP Equivalent to (CAR (CDR (CAR (CAR X)))). -- Function: CAADAR (x) Package:LISP Equivalent to (CAR (CAR (CDR (CAR X)))). -- Function: CAAADR (x) Package:LISP Equivalent to (CAR (CAR (CAR (CDR X)))). -- Function: CDDDDR (x) Package:LISP Equivalent to (CDR (CDR (CDR (CDR X)))). -- Function: SUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes from ALIST for subtrees of TREE nondestructively. -- Function: RASSOC-IF-NOT (predicate alist) Package:LISP Returns the first cons in ALIST whose cdr does not satisfy PREDICATE. -- Function: NRECONC (x y) Package:LISP Equivalent to (NCONC (NREVERSE X) Y). -- Function: MAPLIST (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs and returns the results as a list. -- Function: SET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements of LIST1 that do not appear in LIST2. -- Function: ASSOC-IF (test alist) Package:LISP Returns the first pair in ALIST whose car satisfies TEST. -- Function: GET-PROPERTIES (place indicator-list) Package:LISP Looks for the elements of INDICATOR-LIST in the property list stored in PLACE. If found, returns the indicator, the value, and T as multiple-values. If not, returns NILs as its three values. -- Function: MEMBER-IF (test list &key (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first element satisfying TEST. -- Function: COPY-TREE (object) Package:LISP Recursively copies conses in OBJECT and returns the result. -- Function: ATOM (x) Package:LISP Returns T if X is not a cons; NIL otherwise. -- Function: CDDAR (x) Package:LISP Equivalent to (CDR (CDR (CAR X))). -- Function: CDADR (x) Package:LISP Equivalent to (CDR (CAR (CDR X))). -- Function: CADDR (x) Package:LISP Equivalent to (CAR (CDR (CDR X))). -- Function: ASSOC (item alist &key (test #'eql) test-not) Package:LISP Returns the first pair in ALIST whose car is equal (in the sense of TEST) to ITEM. -- Function: APPEND (&rest lists) Package:LISP Constructs a new list by concatenating its arguments. -- Function: MEMBER (item list &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first ITEM.  File: gcl-si.info, Node: Streams and Reading, Next: Special Forms and Functions, Prev: Lists, Up: Top 5 Streams and Reading ********************* -- Function: MAKE-ECHO-STREAM (input-stream output-stream) Package:LISP Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM. In addition, all input is echoed to OUTPUT-STREAM. -- Variable: *READTABLE* Package:LISP The current readtable. -- Function: LOAD (filename &key (verbose *load-verbose*) (print nil) (if-does-not-exist :error)) Package:LISP Loads the file named by FILENAME into GCL. -- Function: OPEN (filename &key (direction :input) (element-type 'string-char) (if-exists :error) (if-does-not-exist :error)) Package:LISP Opens the file specified by FILENAME, which may be a string, a pathname, or a stream. Returns a stream for the open file. DIRECTION is :INPUT, :OUTPUT, :IO or :PROBE. ELEMENT-TYPE is STRING-CHAR, (UNSIGNED-BYTE n), UNSIGNED-BYTE, (SIGNED-BYTE n), SIGNED-BYTE, CHARACTER, BIT, (MOD n), or :DEFAULT. IF-EXISTS is :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE, or NIL. IF-DOES-NOT-EXIST is :ERROR, :CREATE, or NIL. If FILENAME begins with a vertical pipe sign: '|' then the resulting stream is actually a one way pipe. It will be open for reading or writing depending on the direction given. The rest of FILENAME in this case is passed to the /bin/sh command. See the posix description of popen for more details. (setq pipe (open "| wc < /tmp/jim")) (format t "File has ~%d lines" (read pipe)) (close pipe) -- Variable: *PRINT-BASE* Package:LISP The radix in which the GCL printer prints integers and rationals. The value must be an integer from 2 to 36, inclusive. -- Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) Package:LISP Returns an input stream which will supply the characters of String between Start and End in order. -- Function: PPRINT (object &optional (stream *standard-output*)) Package:LISP Pretty-prints OBJECT. Returns OBJECT. Equivalent to (WRITE :STREAM STREAM :PRETTY T) The SI:PRETTY-PRINT-FORMAT property N (which must be a non-negative integer) of a symbol SYMBOL controls the pretty-printing of form (SYMBOL f1 ... fN fN+1 ... fM) in such a way that the subforms fN+1, ..., fM are regarded as the 'body' of the entire form. For instance, the property value of 2 is initially given to the symbol DO. -- Variable: *READ-DEFAULT-FLOAT-FORMAT* Package:LISP The floating-point format the GCL reader uses when reading floating-point numbers that have no exponent marker or have e or E for an exponent marker. Must be one of SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, and LONG-FLOAT. -- Function: READ-PRESERVING-WHITESPACE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Reads an object from STREAM, preserving the whitespace that followed the object. -- Function: STREAMP (x) Package:LISP Returns T if X is a stream object; NIL otherwise. -- Function: SET-DISPATCH-MACRO-CHARACTER (disp-char sub-char function &optional (readtable *readtable*)) Package:LISP Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is read. -- Macro: WITH-OUTPUT-TO-STRING Package:LISP Syntax: (with-output-to-string (var [string]) {decl}* {form}*) Binds VAR to a string output stream that puts characters into STRING, which defaults to a new string. The stream is automatically closed on exit and the string is returned. -- Function: FILE-LENGTH (file-stream) Package:LISP Returns the length of the specified file stream. -- Variable: *PRINT-CASE* Package:LISP The case in which the GCL printer should print ordinary symbols. The value must be one of the keywords :UPCASE, :DOWNCASE, and :CAPITALIZE. -- Function: PRINT (object &optional (stream *standard-output*)) Package:LISP Outputs a newline character, and then prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (PROGN (TERPRI STREAM) (WRITE OBJECT :STREAM STREAM :ESCAPE T)). -- Function: SET-MACRO-CHARACTER (char function &optional (non-terminating-p nil) (readtable *readtable*)) Package:LISP Causes CHAR to be a macro character that, when seen by READ, causes FUNCTION to be called. -- Function: FORCE-OUTPUT (&optional (stream *standard-output*)) Package:LISP Attempts to force any buffered output to be sent. -- Variable: *PRINT-ARRAY* Package:LISP Whether the GCL printer should print array elements. -- Function: STREAM-ELEMENT-TYPE (stream) Package:LISP Returns a type specifier for the kind of object returned by STREAM. -- Function: WRITE-BYTE (integer stream) Package:LISP Outputs INTEGER to the binary stream STREAM. Returns INTEGER. -- Function: MAKE-CONCATENATED-STREAM (&rest streams) Package:LISP Returns a stream which takes its input from each of the STREAMs in turn, going on to the next at end of stream. -- Function: PRIN1 (object &optional (stream *standard-output*)) Package:LISP Prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE T). -- Function: PRINC (object &optional (stream *standard-output*)) Package:LISP Prints OBJECT without escape characters. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE NIL). -- Function: CLEAR-OUTPUT (&optional (stream *standard-output*)) Package:LISP Clears the output stream STREAM. -- Function: TERPRI (&optional (stream *standard-output*)) Package:LISP Outputs a newline character. -- Function: FINISH-OUTPUT (&optional (stream *standard-output*)) Package:LISP Attempts to ensure that all output sent to STREAM has reached its destination, and only then returns. -- Macro: WITH-OPEN-FILE Package:LISP Syntax: (with-open-file (stream filename {options}*) {decl}* {form}*) Opens the file whose name is FILENAME, using OPTIONs, and binds the variable STREAM to a stream to/from the file. Then evaluates FORMs as a PROGN. The file is automatically closed on exit. -- Special Form: DO Package:LISP Syntax: (do ({(var [init [step]])}*) (endtest {result}*) {decl}* {tag | statement}*) Creates a NIL block, binds each VAR to the value of the corresponding INIT, and then executes STATEMENTs repeatedly until ENDTEST is satisfied. After each iteration, assigns to each VAR the value of the corresponding STEP. When ENDTEST is satisfied, evaluates RESULTs as a PROGN and returns the value(s) of the last RESULT (or NIL if no RESULTs are supplied). Performs variable bindings and assignments all at once, just like LET and PSETQ do. -- Function: READ-FROM-STRING (string &optional (eof-error-p t) (eof-value nil) &key (start 0) (end (length string)) (preserve-whitespace nil)) Package:LISP Reads an object from STRING. -- Function: WRITE-STRING (string &optional (stream *standard-output*) &key (start 0) (end (length string))) Package:LISP Outputs STRING and returns it. -- Variable: *PRINT-LEVEL* Package:LISP How many levels deep the GCL printer should print. Unlimited if NIL. -- Variable: *PRINT-RADIX* Package:LISP Whether the GCL printer should print the radix indicator when printing integers and rationals. -- Function: Y-OR-N-P (&optional (format-string nil) &rest args) Package:LISP Asks the user a question whose answer is either 'Y' or 'N'. If FORMAT-STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Y or N)" is printed. Otherwise, no prompt will appear. -- Function: MAKE-BROADCAST-STREAM (&rest streams) Package:LISP Returns an output stream which sends its output to all of the given streams. -- Function: READ-CHAR (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Reads a character from STREAM. -- Function: PEEK-CHAR (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Peeks at the next character in the input stream STREAM. -- Function: OUTPUT-STREAM-P (stream) Package:LISP Returns non-nil if STREAM can handle output operations; NIL otherwise. -- Variable: *QUERY-IO* Package:LISP The query I/O stream. -- Variable: *READ-BASE* Package:LISP The radix that the GCL reader reads numbers in. -- Macro: WITH-OPEN-STREAM Package:LISP Syntax: (with-open-stream (var stream) {decl}* {form}*) Evaluates FORMs as a PROGN with VAR bound to the value of STREAM. The stream is automatically closed on exit. -- Macro: WITH-INPUT-FROM-STRING Package:LISP Syntax: (with-input-from-string (var string {keyword value}*) {decl}* {form}*) Binds VAR to an input stream that returns characters from STRING and evaluates the FORMs. The stream is automatically closed on exit. Allowed keywords are :INDEX, :START, and :END. -- Function: CLEAR-INPUT (&optional (stream *standard-input*)) Package:LISP Clears the input stream STREAM. -- Variable: *TERMINAL-IO* Package:LISP The terminal I/O stream. -- Function: LISTEN (&optional (stream *standard-input*)) Package:LISP Returns T if a character is available on STREAM; NIL otherwise. This function does not correctly work in some versions of GCL because of the lack of such mechanism in the underlying operating system. -- Function: MAKE-PATHNAME (&key (defaults (parse-namestring "" (pathname-host *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults)) (directory (pathname-directory defaults)) (name (pathname-name defaults)) (type (pathname-type defaults)) (version (pathname-version defaults))) Package:LISP Create a pathname from HOST, DEVICE, DIRECTORY, NAME, TYPE and VERSION. -- Function: PATHNAME-TYPE (pathname) Package:LISP Returns the type slot of PATHNAME. -- Variable: *PRINT-GENSYM* Package:LISP Whether the GCL printer should prefix symbols with no home package with "#:". -- Function: READ-LINE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Returns a line of text read from STREAM as a string, discarding the newline character. Note that when using line at a time input under unix, input forms will always be followed by a #\newline. Thus if you do >(read-line) "" nil the empty string will be returned. After lisp reads the (read-line) it then invokes (read-line). This happens before it does anything else and so happens before the newline character immediately following (read-line) has been read. Thus read-line immediately encounters a #\newline and so returns the empty string. If there had been other characters before the #\newline it would have been different: >(read-line) how are you " how are you" nil If you want to throw away "" input, you can do that with the following: (sloop::sloop while (equal (setq input (read-line)) "")) You may also want to use character at a time input, but that makes input editing harder. nicolas% stty cbreak nicolas% gcl GCL (GNU Common Lisp) Version(1.1.2) Mon Jan 9 12:58:22 MET 1995 Licensed under GNU Public Library License Contains Enhancements by W. Schelter >(let ((ifilename nil)) (format t "~%Input file name: ") (setq ifilename (read-line))) Input file name: /tmp/myfile "/tmp/myfile" >(bye)Bye. -- Function: WRITE-TO-STRING (object &key (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) Package:LISP Returns as a string the printed representation of OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode. -- Function: PATHNAMEP (x) Package:LISP Returns T if X is a pathname object; NIL otherwise. -- Function: READTABLEP (x) Package:LISP Returns T if X is a readtable object; NIL otherwise. -- Function: READ (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) Package:LISP Reads in the next object from STREAM. -- Function: NAMESTRING (pathname) Package:LISP Returns the full form of PATHNAME as a string. -- Function: UNREAD-CHAR (character &optional (stream *standard-input*)) Package:LISP Puts CHARACTER back on the front of the input stream STREAM. -- Function: CLOSE (stream &key (abort nil)) Package:LISP Closes STREAM. A non-NIL value of :ABORT indicates an abnormal termination. -- Variable: *PRINT-LENGTH* Package:LISP How many elements the GCL printer should print at each level of nested data object. Unlimited if NIL. -- Function: SET-SYNTAX-FROM-CHAR (to-char from-char &optional (to-readtable *readtable*) (from-readtable nil)) Package:LISP Makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax of FROM-CHAR in FROM-READTABLE. -- Function: INPUT-STREAM-P (stream) Package:LISP Returns non-NIL if STREAM can handle input operations; NIL otherwise. -- Function: PATHNAME (x) Package:LISP Turns X into a pathname. X may be a string, symbol, stream, or pathname. -- Function: FILE-NAMESTRING (pathname) Package:LISP Returns the written representation of PATHNAME as a string. -- Function: MAKE-DISPATCH-MACRO-CHARACTER (char &optional (non-terminating-p nil) (readtable *readtable*)) Package:LISP Causes the character CHAR to be a dispatching macro character in READTABLE. -- Variable: *STANDARD-OUTPUT* Package:LISP The default output stream used by the GCL printer. -- Function: MAKE-TWO-WAY-STREAM (input-stream output-stream) Package:LISP Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM. -- Variable: *PRINT-ESCAPE* Package:LISP Whether the GCL printer should put escape characters whenever appropriate. -- Function: COPY-READTABLE (&optional (from-readtable *readtable*) (to-readtable nil)) Package:LISP Returns a copy of the readtable FROM-READTABLE. If TO-READTABLE is non-NIL, then copies into TO-READTABLE. Otherwise, creates a new readtable. -- Function: DIRECTORY-NAMESTRING (pathname) Package:LISP Returns the directory part of PATHNAME as a string. -- Function: TRUENAME (pathname) Package:LISP Returns the pathname for the actual file described by PATHNAME. -- Variable: *READ-SUPPRESS* Package:LISP When the value of this variable is NIL, the GCL reader operates normally. When it is non-NIL, then the reader parses input characters but much of what is read is not interpreted. -- Function: GET-DISPATCH-MACRO-CHARACTER (disp-char sub-char &optional (readtable *readtable*)) Package:LISP Returns the macro-character function for SUB-CHAR under DISP-CHAR. -- Function: PATHNAME-DEVICE (pathname) Package:LISP Returns the device slot of PATHNAME. -- Function: READ-CHAR-NO-HANG (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Returns the next character from STREAM if one is available; NIL otherwise. -- Function: FRESH-LINE (&optional (stream *standard-output*)) Package:LISP Outputs a newline if it is not positioned at the beginning of a line. Returns T if it output a newline; NIL otherwise. -- Function: WRITE-CHAR (char &optional (stream *standard-output*)) Package:LISP Outputs CHAR and returns it. -- Function: PARSE-NAMESTRING (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) (end (length thing)) (junk-allowed nil)) Package:LISP Parses a string representation of a pathname into a pathname. HOST is ignored. -- Function: PATHNAME-DIRECTORY (pathname) Package:LISP Returns the directory slot of PATHNAME. -- Function: GET-MACRO-CHARACTER (char &optional (readtable *readtable*)) Package:LISP Returns the function associated with CHAR and, as a second value, returns the non-terminating-p flag. -- Function: FORMAT (destination control-string &rest arguments) Package:LISP Provides various facilities for formatting output. DESTINATION controls where the result will go. If DESTINATION is T, then the output is sent to the standard output stream. If it is NIL, then the output is returned in a string as the value of the call. Otherwise, DESTINATION must be a stream to which the output will be sent. CONTROL-STRING is a string to be output, possibly with embedded formatting directives, which are flagged with the escape character "~". Directives generally expand into additional text to be output, usually consuming one or more of ARGUMENTs in the process. A few useful directives are: ~A, ~nA, ~n@A Prints one argument as if by PRINC ~S, ~nS, ~n@S Prints one argument as if by PRIN1 ~D, ~B, ~O, ~X Prints one integer in decimal, binary, octal, and hexa ~% Does TERPRI ~& Does FRESH-LINE where n is the minimal width of the field in which the object is printed. ~nA and ~nS put padding spaces on the right; ~n@A and ~n@S put on the left. ~R is for printing numbers in various formats. ~nR prints arg in radix n. ~R prints arg as a cardinal english number: two ~:R prints arg as an ordinal english number: third ~@R prints arg as an a Roman Numeral: VII ~:@R prints arg as an old Roman Numeral: IIII ~C prints a character. ~:C represents non printing characters by their pretty names,eg Space ~@C uses the #\ syntax to allow the reader to read it. ~F prints a floating point number arg. The full form is ~w,d,k,overflowchar,padcharF w represents the total width of the printed representation (variable if not present) d the number of fractional digits to display (format nil "~,2f" 10010.0314) --> "10010.03" k arg is multiplied by 10^k before printing it as a decimal number. overflowchar width w characters copies of the overflow character will be printed. eg(format t "X>~5,2,,'?F X>?????~10,2,1,'?,'bFX>bbb1000.34 "BIL" (format nil "~@[x = ~d ~]~a" 8) --> "x = 8 BIL" -- Function: PATHNAME-NAME (pathname) Package:LISP Returns the name slot of PATHNAME. -- Function: MAKE-STRING-OUTPUT-STREAM () Package:LISP Returns an output stream which will accumulate all output given it for the benefit of the function GET-OUTPUT-STREAM-STRING. -- Function: MAKE-SYNONYM-STREAM (symbol) Package:LISP Returns a stream which performs its operations on the stream which is the value of the dynamic variable named by SYMBOL. -- Variable: *LOAD-VERBOSE* Package:LISP The default for the VERBOSE argument to LOAD. -- Variable: *PRINT-CIRCLE* Package:LISP Whether the GCL printer should take care of circular lists. -- Variable: *PRINT-PRETTY* Package:LISP Whether the GCL printer should pretty-print. See the function doc of PPRINT for more information about pretty-printing. -- Function: FILE-WRITE-DATE (file) Package:LISP Returns the time at which the specified file is written, as an integer in universal time format. FILE may be a string or a stream. -- Function: PRIN1-TO-STRING (object) Package:LISP Returns as a string the printed representation of OBJECT in the mostly readable representation. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE T). -- Function: MERGE-PATHNAMES (pathname &optional (defaults *default-pathname-defaults*) default-version) Package:LISP Fills in unspecified slots of PATHNAME from DEFAULTS. DEFAULT-VERSION is ignored in GCL. -- Function: READ-BYTE (stream &optional (eof-error-p t) (eof-value nil)) Package:LISP Reads the next byte from STREAM. -- Function: PRINC-TO-STRING (object) Package:LISP Returns as a string the printed representation of OBJECT without escape characters. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE NIL). -- Variable: *STANDARD-INPUT* Package:LISP The default input stream used by the GCL reader. -- Function: PROBE-FILE (file) Package:LISP Returns the truename of file if the file exists. Returns NIL otherwise. -- Function: PATHNAME-VERSION (pathname) Package:LISP Returns the version slot of PATHNAME. -- Function: WRITE-LINE (string &optional (stream *standard-output*) &key (start 0) (end (length string))) Package:LISP Outputs STRING and then outputs a newline character. Returns STRING. -- Function: WRITE (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) Package:LISP Prints OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode. -- Function: GET-OUTPUT-STREAM-STRING (stream) Package:LISP Returns a string of all the characters sent to STREAM made by MAKE-STRING-OUTPUT-STREAM since the last call to this function. -- Function: READ-DELIMITED-LIST (char &optional (stream *standard-input*) (recursive-p nil)) Package:LISP Reads objects from STREAM until the next character after an object's representation is CHAR. Returns a list of the objects read. -- Function: READLINE-ON () Package:SI Begins readline command editing mode when possible. In addition to the basic readline editing features, command word completion is implemented according to the following scheme: [[pkg]:[:]]txt pkg - an optional package specifier. Defaults to the current package. The symbols in this package and those in the packages in this package's use list will be searched. :[:] - an optional internal/external specifier. Defaults to external. The keyword package is denoted by a single colon at the beginning of the token. Only symbols of this type will be searched for completion. txt - a string. Symbol names beginning with this string are completed. The comparison is case insensitive. -- Function: READLINE-OFF () Package:SI Disables readline command editing mode. -- Variable: *READLINE-PREFIX* Package:SI A string implicitly prepended to input text for use in readline command completion. If this string contains one or more colons, it is used to specify the default package and internal/external setting for searched symbols in the case that the supplied text itself contains no explicit package specification. If this string contains characters after the colon(s), or contains no colons at all, it is treated as a symbol name prefix. In this case, the prefix is matched first, then the supplied text, and the completion returned is relative to the supplied text itself, i.e. contains no prefix. For example, the setting "maxima::$" will complete input text "int" according to the internal symbols in the maxima package of the form "maxima::$int...", and return suggestions to the user of the form "int...".  File: gcl-si.info, Node: Special Forms and Functions, Next: Compilation, Prev: Streams and Reading, Up: Top 6 Special Forms and Functions ***************************** -- Constant: LAMBDA-LIST-KEYWORDS Package:LISP List of all the lambda-list keywords used in GCL. -- Special Form: THE Package:LISP Syntax: (the value-type form) Declares that the value of FORM must be of VALUE-TYPE. Signals an error if this is not the case. -- Special Form: SETF Package:LISP Syntax: (setf {place newvalue}*) Replaces the value in PLACE with the value of NEWVALUE, from left to right. Returns the value of the last NEWVALUE. Each PLACE may be any one of the following: A symbol that names a variable. A function call form whose first element is the name of the following functions: nth elt subseq rest first ... tenth c?r c??r c???r c????r aref svref char schar bit sbit fill-poiter get getf documentation symbol-value symbol-function symbol-plist macro-function gethash char-bit ldb mask-field apply where '?' stands for either 'a' or 'd'. the form (THE type place) with PLACE being a place recognized by SETF. a macro call which expands to a place recognized by SETF. any form for which a DEFSETF or DEFINE-SETF-METHOD declaration has been made. -- Special Form: WHEN Package:LISP Syntax: (when test {form}*) If TEST evaluates to non-NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL. -- Macro: CCASE Package:LISP Syntax: (ccase keyplace {({key | ({key}*)} {form}*)}*) Evaluates KEYPLACE and tries to find the KEY that is EQL to the value of KEYPLACE. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error. -- Function: MACROEXPAND (form &optional (env nil)) Package:LISP If FORM is a macro form, then expands it repeatedly until it is not a macro any more. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro. -- Special Form: MULTIPLE-VALUE-CALL Package:LISP Syntax: (multiple-value-call function {form}*) Calls FUNCTION with all the values of FORMs as arguments. -- Macro: DEFSETF Package:LISP Syntax: (defsetf access-fun {update-fun [doc] | lambda-list (store-var) {decl | doc}* {form}*) Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation 'NAME 'setf). (defsetf access-fun update-fun) defines an expansion from (setf (ACCESS-FUN arg1 ... argn) value) to (UPDATE-FUN arg1 ... argn value). (defsetf access-fun lambda-list (store-var) . body) defines a macro which expands (setf (ACCESS-FUN arg1 ... argn) value) into the form (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest) where REST is the value of BODY with parameters in LAMBDA-LIST bound to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0. -- Special Form: TAGBODY Package:LISP Syntax: (tagbody {tag | statement}*) Executes STATEMENTs and returns NIL if it falls off the end. -- Macro: ETYPECASE Package:LISP Syntax: (etypecase keyform {(type {form}*)}*) Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error. -- Special Form: LET* Package:LISP Syntax: (let* ({var | (var [value])}*) {decl}* {form}*) Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) from left to right, then evaluates FORMs as a PROGN. -- Special Form: PROG1 Package:LISP Syntax: (prog1 first {form}*) Evaluates FIRST and FORMs in order, and returns the (single) value of FIRST. -- Special Form: DEFUN Package:LISP Syntax: (defun name lambda-list {decl | doc}* {form}*) Defines a function as the global function definition of the symbol NAME. The complete syntax of a lambda-list is: ({var}* [&optional {var | (var [initform [svar]])}*] [&rest var] [&key {var | ({var | (keyword var)} [initform [svar]])}* [&allow-other-keys]] [&aux {var | (var [initform])}*]) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). -- Special Form: MULTIPLE-VALUE-BIND Package:LISP Syntax: (multiple-value-bind ({var}*) values-form {decl}* {form}*) Binds the VARiables to the results of VALUES-FORM, in order (defaulting to NIL) and evaluates FORMs in order. -- Special Form: DECLARE Package:LISP Syntax: (declare {decl-spec}*) Gives a declaration. Possible DECL-SPECs are: (SPECIAL {var}*) (TYPE type {var}*) where 'TYPE' is one of the following symbols array fixnum package simple-bit-vector atom float pathname simple-string bignum function random-state simple-vector bit hash-table ratio single-float bit-vector integer rational standard-char character keyword readtable stream common list sequence string compiled-function long-float short-float string-char complex nil signed-byte symbol cons null unsigned-byte t double-float number simple-array vector 'TYPE' may also be a list containing one of the above symbols as its first element and more specific information later in the list. For example (vector long-float 80) ; vector of 80 long-floats. (array long-float *) ; array of long-floats (array fixnum) ; array of fixnums (array * 30) ; an array of length 30 but unspecified type A list of 1 element may be replaced by the symbol alone, and a list ending in '*' may drop the the final '*'. (OBJECT {var}*) (FTYPE type {function-name}*) eg: ;; function of two required args and optional args and one value: (ftype (function (t t *) t) sort reduce) ;; function with 1 arg of general type returning 1 fixnum as value. (ftype (function (t) fixnum) length) (FUNCTION function-name ({arg-type}*) {return-type}*) (INLINE {function-name}*) (NOTINLINE {function-name}*) (IGNORE {var}*) (OPTIMIZE {({SPEED | SPACE | SAFETY | COMPILATION-SPEED} {0 | 1 | 2 | 3})}*) (DECLARATION {non-standard-decl-name}*) (:DYNAMIC-EXTENT {var}*) ;GCL-specific. -- Special Form: DEFMACRO Package:LISP Syntax: (defmacro name defmacro-lambda-list {decl | doc}* {form}*) Defines a macro as the global macro definition of the symbol NAME. The complete syntax of a defmacro-lambda-list is: ( [&whole var] [&environment var] {pseudo-var}* [&optional {var | (pseudo-var [initform [pseudo-var]])}*] {[{&rest | &body} pseudo-var] [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* [&allow-other-keys]] [&aux {var | (pseudo-var [initform])}*] | . var}) where pseudo-var is either a symbol or a list of the following form: ( {pseudo-var}* [&optional {var | (pseudo-var [initform [pseudo-var]])}*] {[{&rest | &body} pseudo-var] [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* [ &allow-other-keys ] ] [&aux {var | (pseudo-var [initform])}*] | . var}) As a special case, a non-NIL symbol is accepcted as a defmacro-lambda-list: (DEFMACRO ...) is equivalent to (DEFMACRO (&REST ) ...). The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). See the type doc of LIST for the backquote macro useful for defining macros. Also, see the function doc of PPRINT for the output-formatting. -- Variable: *EVALHOOK* Package:LISP If *EVALHOOK* is not NIL, its value must be a function that can receive two arguments: a form to evaluate and an environment. This function does the evaluation instead of EVAL. -- Function: FUNCTIONP (x) Package:LISP Returns T if X is a function, suitable for use by FUNCALL or APPLY. Returns NIL otherwise. -- Constant: LAMBDA-PARAMETERS-LIMIT Package:LISP The exclusive upper bound on the number of distinct parameter names that may appear in a single lambda-list. Actually, however, there is no such upper bound in GCL. -- Special Form: FLET Package:LISP Syntax: (flet ({(name lambda-list {decl | doc}* {form}*)}*) . body) Evaluates BODY as a PROGN, with local function definitions in effect. BODY is the scope of each local function definition. Since the scope does not include the function definitions themselves, the local function can reference externally defined functions of the same name. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored. -- Macro: ECASE Package:LISP Syntax: (ecase keyform {({key | ({key}*)} {form}*)}*) Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error. -- Special Form: PROG2 Package:LISP Syntax: (prog2 first second {forms}*) Evaluates FIRST, SECOND, and FORMs in order, and returns the (single) value of SECOND. -- Special Form: PROGV Package:LISP Syntax: (progv symbols values {form}*) SYMBOLS must evaluate to a list of variables. VALUES must evaluate to a list of initial values. Evaluates FORMs as a PROGN, with each variable bound (as special) to the corresponding value. -- Special Form: QUOTE Package:LISP Syntax: (quote x) or 'x Simply returns X without evaluating it. -- Special Form: DOTIMES Package:LISP Syntax: (dotimes (var countform [result]) {decl}* {tag | statement}*) Executes STATEMENTs, with VAR bound to each number between 0 (inclusive) and the value of COUNTFORM (exclusive). Then returns the value(s) of RESULT (which defaults to NIL). -- Function: SPECIAL-FORM-P (symbol) Package:LISP Returns T if SYMBOL globally names a special form; NIL otherwise. The special forms defined in Steele's manual are: block if progv catch labels quote compiler-let let return-from declare let* setq eval-when macrolet tagbody flet multiple-value-call the function multiple-value-prog1 throw go progn unwind-protect In addition, GCL implements the following macros as special forms, though of course macro-expanding functions such as MACROEXPAND work correctly for these macros. and incf prog1 case locally prog2 cond loop psetq decf multiple-value-bind push defmacro multiple-value-list return defun multiple-value-set setf do or unless do* pop when dolist prog dotimes prog* -- Special Form: FUNCTION Package:LISP Syntax: (function x) or #'x If X is a lambda expression, creates and returns a lexical closure of X in the current lexical environment. If X is a symbol that names a function, returns that function. -- Constant: MULTIPLE-VALUES-LIMIT Package:LISP The exclusive upper bound on the number of values that may be returned from a function. Actually, however, there is no such upper bound in GCL. -- Function: APPLYHOOK (function args evalhookfn applyhookfn &optional (env nil)) Package:LISP Applies FUNCTION to ARGS, with *EVALHOOK* bound to EVALHOOKFN and with *APPLYHOOK* bound to APPLYHOOKFN. Ignores the hook function once, for the top-level application of FUNCTION to ARGS. -- Variable: *MACROEXPAND-HOOK* Package:LISP Holds a function that can take two arguments (a macro expansion function and the macro form to be expanded) and returns the expanded form. This function is whenever a macro-expansion takes place. Initially this is set to #'FUNCALL. -- Special Form: PROG* Package:LISP Syntax: (prog* ({var | (var [init])}*) {decl}* {tag | statement}*) Creates a NIL block, binds VARs sequentially, and then executes STATEMENTs. -- Special Form: BLOCK Package:LISP Syntax: (block name {form}*) The FORMs are evaluated in order, but it is possible to exit the block using (RETURN-FROM name value). The RETURN-FROM must be lexically contained within the block. -- Special Form: PROGN Package:LISP Syntax: (progn {form}*) Evaluates FORMs in order, and returns whatever the last FORM returns. -- Function: APPLY (function arg &rest more-args) Package:LISP Applies FUNCTION. The arguments to the function consist of all ARGs except for the last, and all elements of the last ARG. -- Special Form: LABELS Package:LISP Syntax: (labels ({(name lambda-list {decl | doc}* {form}*)}*) . body) Evaluates BODY as a PROGN, with the local function definitions in effect. The scope of the locally defined functions include the function definitions themselves, so their definitions may include recursive references. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored. -- Special Form: RETURN Package:LISP Syntax: (return [result]) Returns from the lexically surrounding NIL block. The value of RESULT, which defaults to NIL, is returned as the value of the block. -- Macro: TYPECASE Package:LISP Syntax: (typecase keyform {(type {form}*)}*) Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value of the last FORM. If not, simply returns NIL. -- Special Form: AND Package:LISP Syntax: (and {form}*) Evaluates FORMs in order from left to right. If any FORM evaluates to NIL, returns immediately with the value NIL. Else, returns the value(s) of the last FORM. -- Special Form: LET Package:LISP Syntax: (let ({var | (var [value])}*) {decl}* {form}*) Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) all at once, then evaluates FORMs as a PROGN. -- Special Form: COND Package:LISP Syntax: (cond {(test {form}*)}*) Evaluates each TEST in order until one evaluates to a non-NIL value. Then evaluates the associated FORMs in order and returns the value(s) of the last FORM. If no forms follow the TEST, then returns the value of the TEST. Returns NIL, if all TESTs evaluate to NIL. -- Function: GET-SETF-METHOD-MULTIPLE-VALUE (form) Package:LISP Returns the five values (or five 'gangs') constituting the SETF method for FORM. See the doc of DEFINE-SETF-METHOD for the meanings of the gangs. The third value (i.e., the list of store variables) may consist of any number of elements. See the doc of GET-SETF-METHOD for comparison. -- Special Form: CATCH Package:LISP Syntax: (catch tag {form}*) Sets up a catcher with that value TAG. Then evaluates FORMs as a PROGN, but may possibly abort the evaluation by a THROW form that specifies the value EQ to the catcher tag. -- Macro: DEFINE-MODIFY-MACRO Package:LISP Syntax: (define-modify-macro name lambda-list fun [doc]) Defines a read-modify-write macro, like PUSH and INCF. The defined macro will expand a form (NAME place val1 ... valn) into a form that in effect SETFs the value of the call (FUN PLACE arg1 ... argm) into PLACE, where arg1 ... argm are parameters in LAMBDA-LIST which are bound to the forms VAL1 ... VALn. The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). -- Function: MACROEXPAND-1 (form &optional (env nil)) Package:LISP If FORM is a macro form, then expands it once. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro. -- Function: FUNCALL (function &rest arguments) Package:LISP Applies FUNCTION to the ARGUMENTs -- Constant: CALL-ARGUMENTS-LIMIT Package:LISP The upper exclusive bound on the number of arguments that may be passed to a function. Actually, however, there is no such upper bound in GCL. -- Special Form: CASE Package:LISP Syntax: (case keyform {({key | ({key}*)} {form}*)}*) Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, simply returns NIL. -- Macro: DEFINE-SETF-METHOD Package:LISP Syntax: (define-setf-method access-fun defmacro-lambda-list {decl | doc}* {form}*) Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). When a form (setf (ACCESS-FUN arg1 ... argn) value) is being evaluated, the FORMs are first evaluated as a PROGN with the parameters in DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. Assuming that the last FORM returns five values (temp-var-1 ... temp-var-k) (value-from-1 ... value-form-k) (store-var) storing-form access-form in order, the whole SETF is then expanded into (let* ((temp-var-1 value-from-1) ... (temp-k value-form-k) (store-var VALUE)) storing-from) Incidentally, the five values are called the five gangs of a SETF method. The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation 'NAME 'setf). -- Special Form: COMPILER-LET Package:LISP Syntax: (compiler-let ({var | (var [value])}*) {form}*) When interpreted, this form works just like a LET form with all VARs declared special. When compiled, FORMs are processed with the VARs bound at compile time, but no bindings occur when the compiled code is executed. -- Function: VALUES (&rest args) Package:LISP Returns ARGs in order, as values. -- Special Form: MULTIPLE-VALUE-LIST Package:LISP Syntax: (multiple-value-list form) Evaluates FORM, and returns a list of multiple values it returned. -- Special Form: MULTIPLE-VALUE-PROG1 Package:LISP Syntax: (multiple-value-prog1 form {form}*) Evaluates the first FORM, saves all the values produced, then evaluates the other FORMs. Returns the saved values. -- Special Form: MACROLET Package:LISP Syntax: (macrolet ({(name defmacro-lambda-list {decl | doc}* . body)}*) {form}*) Evaluates FORMs as a PROGN, with the local macro definitions in effect. See the doc of DEFMACRO for the complete syntax of a defmacro-lambda-list. Doc-strings for local macros are simply ignored. -- Special Form: GO Package:LISP Syntax: (go tag) Jumps to the specified TAG established by a lexically surrounding TAGBODY. -- Special Form: PROG Package:LISP Syntax: (prog ({var | (var [init])}*) {decl}* {tag | statement}*) Creates a NIL block, binds VARs in parallel, and then executes STATEMENTs. -- Variable: *APPLYHOOK* Package:LISP Used to substitute another function for the implicit APPLY normally done within EVAL. If *APPLYHOOK* is not NIL, its value must be a function which takes three arguments: a function to be applied, a list of arguments, and an environment. This function does the application instead of APPLY. -- Special Form: RETURN-FROM Package:LISP Syntax: (return-from name [result]) Returns from the lexically surrounding block whose name is NAME. The value of RESULT, which defaults to NIL, is returned as the value of the block. -- Special Form: UNLESS Package:LISP Syntax: (unless test {form}*) If TEST evaluates to NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL. -- Special Form: MULTIPLE-VALUE-SETQ Package:LISP Syntax: (multiple-value-setq variables form) Sets each variable in the list VARIABLES to the corresponding value of FORM. Returns the value assigned to the first variable. -- Special Form: LOCALLY Package:LISP Syntax: (locally {decl}* {form}*) Gives local pervasive declarations. -- Function: IDENTITY (x) Package:LISP Simply returns X. -- Function: NOT (x) Package:LISP Returns T if X is NIL; NIL otherwise. -- Macro: DEFCONSTANT Package:LISP Syntax: (defconstant name initial-value [doc]) Declares that the variable NAME is a constant whose value is the value of INITIAL-VALUE. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable). -- Function: VALUES-LIST (list) Package:LISP Returns all of the elements of LIST in order, as values. -- Function: ERROR (control-string &rest args) Package:LISP Signals a fatal error. -- Special Form: IF Package:LISP Syntax: (if test then [else]) If TEST evaluates to non-NIL, then evaluates THEN and returns the result. If not, evaluates ELSE (which defaults to NIL) and returns the result. -- Special Form: UNWIND-PROTECT Package:LISP Syntax: (unwind-protect protected-form {cleanup-form}*) Evaluates PROTECTED-FORM and returns whatever it returned. Guarantees that CLEANUP-FORMs be always evaluated before exiting from the UNWIND-PROTECT form. -- Function: EVALHOOK (form evalhookfn applyhookfn &optional (env nil)) Package:LISP Evaluates FORM with *EVALHOOK* bound to EVALHOOKFN and *APPLYHOOK* bound to APPLYHOOKFN. Ignores these hooks once, for the top-level evaluation of FORM. -- Special Form: OR Package:LISP Syntax: (or {form}*) Evaluates FORMs in order from left to right. If any FORM evaluates to non-NIL, quits and returns that (single) value. If the last FORM is reached, returns whatever values it returns. -- Macro: CTYPECASE Package:LISP Syntax: (ctypecase keyplace {(type {form}*)}*) Evaluates KEYPLACE and tries to find the TYPE in which the value of KEYPLACE belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error. -- Function: EVAL (exp) Package:LISP Evaluates EXP and returns the result(s). -- Macro: PSETF Package:LISP Syntax: (psetf {place newvalue}*) Similar to SETF, but evaluates all NEWVALUEs first, and then replaces the value in each PLACE with the value of the corresponding NEWVALUE. Returns NIL always. -- Special Form: THROW Package:LISP Syntax: (throw tag result) Evaluates TAG and aborts the execution of the most recent CATCH form that sets up a catcher with the same tag value. The CATCH form returns whatever RESULT returned. -- Macro: DEFPARAMETER Package:LISP Syntax: (defparameter name initial-value [doc]) Declares the variable NAME as a special variable and initializes the value. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable). -- Macro: DEFVAR Package:LISP Syntax: (defvar name [initial-value [doc]]) Declares the variable NAME as a special variable and, optionally, initializes it. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable).  File: gcl-si.info, Node: Compilation, Next: Symbols, Prev: Special Forms and Functions, Up: Top 7 Compilation ************* -- Function: COMPILE (name &optional (definition nil)) Package:LISP If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. In this case, COMPILE compiles the function, installs the compiled function as the global function definition of NAME, and returns NAME. If DEFINITION is non-NIL, it must be a lambda expression and NAME must be a symbol. COMPILE compiles the lambda expression, installs the compiled function as the function definition of NAME, and returns NAME. There is only one exception for this: If NAME is NIL, then the compiled function is not installed but is simply returned as the value of COMPILE. In any case, COMPILE creates temporary files whose filenames are "gazonk***". By default, i.e. if :LEAVE-GAZONK is not supplied or is NIL, these files are automatically deleted after compilation. -- Function: LINK (files image &optional post extra-libs (run-user-init t) &aux raw init) Package:LISP On systems where dlopen is used for relocations, one cannot make custom images containing loaded binary object files simply by loading the files and executing save-system. This function is provided for such cases. After compiling source files into objects, LINK can be called with a list of binary and source FILES which would otherwise normally be loaded in sequence before saving the image to IMAGE. LINK will use the system C linker to link the binary files thus supplied with GCL's objects, using EXTRA-LIBS as well if provided, and producing a raw_IMAGE executable. This executable is then run to initialize first GCL's objects, followed by the supplied files, in order, if RUN-USER-INIT is set. In such a case, source files are loaded at their position in the sequence. Any optional code which should be run after file initialization can be supplied in the POST variable. The image is then saved using save-system to IMAGE. This method of creating lisp images may also have the advantage that all new object files are kept out of the lisp core and placed instead in the final image's .text section. This should in principle reduce the core size, speed up garbage collection, and forego any performance penalty induced by data cache flushing on some machines. In both the RAW and SAVED image, any calls to LOAD binary object files which have been specified in this list will bypass the normal load procedure, and simply initialize the already linked in module. One can rely on this feature by disabling RUN-USER-INIT, and instead passing the normal build commands in POST. In the course of executing this code, binary modules previously linked into the .text section of the executable will be initialized at the same point at which they would have normally been loaded into the lisp core, in the executable's .data section. In this way, the user can choose to take advantage of the aforementioned possible benefits of this linking method in a relatively transparent way. All binary objects specified in FILES must have been compiled with :SYSTEM-P set to T. -- Special Form: EVAL-WHEN Package:LISP Syntax: (eval-when ({situation}*) {form}*) A situation must be either COMPILE, LOAD, or EVAL. The interpreter evaluates only when EVAL is specified. If COMPILE is specified, FORMs are evaluated at compile time. If LOAD is specified, the compiler arranges so that FORMs be evaluated when the compiled code is loaded. -- Function: COMPILE-FILE (input-pathname &key output-file (load nil) (message-file nil) ;GCL specific keywords: system-p c-debug c-file h-file data-file) Package:LISP Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then ".lsp" is used as the default file type for the source file. :LOAD specifies whether to load the generated fasl file after compilation. :MESSAGE-FILE specifies the log file for the compiler messages. It defaults to the value of the variable COMPILER:*DEFAULT-MESSAGE-FILE*. A non-NIL value of COMPILER::*COMPILE-PRINT* forces the compiler to indicate the form currently being compiled. More keyword parameters are accepted, depending on the version. Most versions of GCL can receive :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters, with which you can control the intermediate files generated by the GCL compiler. Also :C-DEBUG will pass the -g flag to the C compiler. By top level forms in a file, we mean the value of *top-level-forms* after doing (TF form) for each form read from a file. We define TF as follows: (defun TF (x) (when (consp x) (setq x (macroexpand x)) (when (consp x) (cond ((member (car x) '(progn eval-when)) (mapcar 'tf (cdr x))) (t (push x *top-level-forms*)))))) Among the common lisp special forms only DEFUN and DEFMACRO will cause actual native machine code to be generated. The rest will be specially treated in an init section of the .data file. This is done so that things like putprop,setq, and many other forms would use up space which could not be usefully freed, if we were to compile to native machine code. If you have other 'ordinary' top level forms which you need to have compiled fully to machine code you may either set compiler::*COMPILE-ORDINARIES* to t, or put them inside a (PROGN 'COMPILE ...forms-which-need-to-be-compiled) The compiler will take each of them and make a temporary function which will be compiled and invoked once. It is permissible to wrap a (PROGN 'COMPILE ..) around the whole file. Currently this construction binds the compiler::*COMPILE-ORDINARIES* flag to t. Setting this flag globally to a non nil value to cause all top level forms to generate machine code. This might be useful in a system such as PCL, where a number of top level lambda expressions are given. Note that most common lisps will simply ignore the top level atom 'compile, since it has no side effects. Defentry, clines, and defcfun also result in machine code being generated. subsection Evaluation at Compile time ************************************* In GCL the eval-when behaviour was changed in order to allow more efficient init code, and also to bring it into line with the resolution passed by the X3j13 committee. Evaluation at compile time is controlled by placing eval-when special forms in the code, or by the value of the variable compiler::*eval-when-defaults* [default value :defaults]. If that variable has value :defaults, then the following hold: Eval at Compile Type of Top Level Form Partial: defstructs, defvar, defparameter Full: defmacro, defconstant, defsetf, define-setf-method, deftype, package ops, proclaim None: defun, others By 'partial' we mean (see the X3J13 Common Lisp document (doc/compile-file-handling-of-top-level-forms) for more detail), that functions will not be defined, values will not be set, but other miscellaneous compiler properties will be set: eg properties to inline expand defstruct accessors and testers, defstruct properties allowing subsequent defstructs to include this one, any type hierarch information, special variable information will be set up. Example: (defun foo () 3) (defstruct jo a b) As a side effect of compiling these two forms, foo would not have its function cell changed. Neither would jo-a, although it would gain a property which allows it to expand inline to a structure access. Thus if it had a previous definition (as commonly happens from previously loading the file), this previous definition would not be touched, and could well be inconsistent with the compiler properties. Unfortunately this is what the CL standard says to do, and I am just trying to follow it. If you prefer a more intuitive scheme, of evaling all forms in the file, so that there are no inconsistencies, (previous behaviour of AKCL) you may set compiler::*eval-when-defaults* to '(compile eval load). The variable compiler::*FASD-DATA* [default t] controls whether an ascii output is used for the data section of the object file. The data section will be in ascii if *fasd-data* is nil or if the system-p keyword is supplied to compile-file and *fasd-data* is not eq to :system-p. The old GCL variable *compile-time-too* has disappeared. See OPTIMIZE on how to enable warnings of slow constructs. -- Function: PROCLAIM (decl-spec) Package:LISP Puts the declaration given by DECL-SPEC into effect globally. See the doc of DECLARE for possible DECL-SPECs. -- Function: PROVIDE (module-name) Package:LISP Adds the specified module to the list of modules maintained in *MODULES*. -- Function: COMPILED-FUNCTION-P (x) Package:LISP Returns T if X is a compiled function; NIL otherwise. -- Function: GPROF-START () Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with -enable-gprof. This function starts the profiling timers and counters. -- Function: GPROF-QUIT () Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with -enable-gprof. This function reports the profiling results in the form of a call graph to standard output, and clears the profiling arrays. Please note that lisp functions are not (yet) displayed with their lisp names. Please see also the PROFILE function. -- Function: GPROF-SET (begin end) Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with -enable-gprof. This function sets the address range used by GPROF-START in specifying the section of the running program which is to be profiled. All subsequent calls to GPROF-START will use this new address range. By default, the range is set to begin at the starting address of the .text section, and to end at the current end of the running core. These default values can be restored by calling GPROF-SET with both argments set to 0. -- Variable: *DEFAULT-SYSTEM-P* Pakcage:COMPILER Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-C-FILE* Pakcage:COMPILER Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-H-FILE* Pakcage:COMPILER Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL. -- Variable: *DEFAULT-DATA-FILE* Pakcage:COMPILER Specifies the default setting of :DATA-FILE used by COMPILE. Defaults to NIL. -- Variable: *FEATURES* Package:LISP List of symbols that name features of the current version of GCL. These features are used to decide the read-time conditionalization facility provided by '#+' and '#-' read macros. When the GCL reader encounters #+ feature-description form it reads FORM in the usual manner if FEATURE-DESCRIPTION is true. Otherwise, the reader just skips FORM. #- feature-description form is equivalent to #- (not feature-description) form A feature-description may be a symbol, which is true only when it is an element of *FEATURES*. Or else, it must be one of the following: (and feature-desciption-1 ... feature-desciption-n) (or feature-desciption-1 ... feature-desciption-n) (not feature-desciption) The AND description is true only when all of its sub-descriptions are true. The OR description is true only when at least one of its sub-descriptions is true. The NOT description is true only when its sub-description is false.  File: gcl-si.info, Node: Symbols, Next: Operating System, Prev: Compilation, Up: Top 8 Symbols ********* -- Function: GENSYM (&optional (x nil)) Package:LISP Creates and returns a new uninterned symbol whose name is a prefix string (defaults to "G"), followed by a decimal number. The number is incremented by each call to GENSYM. X, if an integer, resets the counter. If X is a string, it becomes the new prefix. -- Function: KEYWORDP (x) Package:LISP Returns T if X is a symbol and it belongs to the KEYWORD package; NIL otherwise. -- Function: REMPROP (symbol indicator) Package:LISP Look on property list of SYMBOL for property with specified INDICATOR. If found, splice this indicator and its value out of the plist, and return T. If not found, returns NIL with no side effects. -- Function: SYMBOL-PACKAGE (symbol) Package:LISP Returns the contents of the package cell of the symbol SYMBOL. -- Variable: *PACKAGE* Package:LISP The current package. -- Function: SHADOWING-IMPORT (symbols &optional (package *package*)) Package:LISP Imports SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol of the same name is already present, then it is uninterned. SYMBOLS must be a list of symbols or a symbol. -- Macro: REMF Package:LISP Syntax: (remf place indicator) PLACE may be any place expression acceptable to SETF, and is expected to hold a property list or NIL. This list is destructively altered to remove the property specified by INDICATOR. Returns T if such a property was present; NIL otherwise. -- Function: MAKUNBOUND (symbol) Package:LISP Makes empty the value slot of SYMBOL. Returns SYMBOL. -- Function: USE-PACKAGE (packages-to-use &optional (package *package*)) Package:LISP Adds all packages in PACKAGE-TO-USE list to the use list for PACKAGE so that the external symbols of the used packages are available as internal symbols in PACKAGE. -- Function: MAKE-SYMBOL (string) Package:LISP Creates and returns a new uninterned symbol whose print name is STRING. -- Special Form: PSETQ Package:LISP Syntax: (psetq {var form}*) Similar to SETQ, but evaluates all FORMs first, and then assigns each value to the corresponding VAR. Returns NIL always. -- Function: PACKAGE-USED-BY-LIST (package) Package:LISP Returns the list of packages that use PACKAGE. -- Function: SYMBOLP (x) Package:LISP Returns T if X is a symbol; NIL otherwise. -- Constant: NIL Package:LISP Holds NIL. -- Function: SET (symbol value) Package:LISP Assigns the value of VALUE to the dynamic variable named by SYMBOL, and returns the value assigned. -- Special Form: SETQ Package:LISP Syntax: (setq {var form}*) VARs are not evaluated and must be symbols. Assigns the value of the first FORM to the first VAR, then assigns the value of the second FORM to the second VAR, and so on. Returns the last value assigned. -- Function: UNUSE-PACKAGE (packages-to-unuse &optional (package *package*)) Package:LISP Removes PACKAGES-TO-UNUSE from the use list for PACKAGE. -- Constant: T Package:LISP Holds T. -- Function: PACKAGE-USE-LIST (package) Package:LISP Returns the list of packages used by PACKAGE. -- Function: LIST-ALL-PACKAGES () Package:LISP Returns a list of all existing packages. -- Function: COPY-SYMBOL (symbol &optional (copy-props nil)) Package:LISP Returns a new uninterned symbol with the same print name as SYMBOL. If COPY-PROPS is NIL, the function, the variable, and the property slots of the new symbol have no value. Otherwise, these slots are given the values of the corresponding slots of SYMBOL. -- Function: SYMBOL-PLIST (symbol) Package:LISP Returns the property list of SYMBOL. -- Function: SYMBOL-NAME (symbol) Package:LISP Returns the print name of the symbol SYMBOL. -- Function: FIND-SYMBOL (name &optional (package *package*)) Package:LISP Returns the symbol named NAME in PACKAGE. If such a symbol is found, then the second value is :INTERN, :EXTERNAL, or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL. -- Function: SHADOW (symbols &optional (package *package*)) Package:LISP Creates an internal symbol in PACKAGE with the same name as each of the specified SYMBOLS. SYMBOLS must be a list of symbols or a symbol. -- Function: FBOUNDP (symbol) Package:LISP Returns T if SYMBOL has a global function definition or if SYMBOL names a special form or a macro; NIL otherwise. -- Function: MACRO-FUNCTION (symbol) Package:LISP If SYMBOL globally names a macro, then returns the expansion function. Returns NIL otherwise. -- Function: IN-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) Package:LISP Sets *PACKAGE* to the package with PACKAGE-NAME, creating the package if it does not exist. If the package already exists then it is modified to agree with USE and NICKNAMES arguments. Any new nicknames are added without removing any old ones not specified. If any package in the USE list is not currently used, then it is added to the use list. -- Function: MAKE-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) Package:LISP Makes a new package having the specified PACKAGE-NAME and NICKNAMES. The package will inherit all external symbols from each package in the USE list. -- Function: PACKAGE-SHADOWING-SYMBOLS (package) Package:LISP Returns the list of symbols that have been declared as shadowing symbols in PACKAGE. -- Function: INTERN (name &optional (package *package*)) Package:LISP Returns a symbol having the specified name, creating it if necessary. Returns as the second value one of the symbols :INTERNAL, :EXTERNAL, :INHERITED, and NIL. -- Function: EXPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS external symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol. -- Function: PACKAGEP (x) Package:LISP Returns T if X is a package; NIL otherwise. -- Function: SYMBOL-FUNCTION (symbol) Package:LISP Returns the current global function definition named by SYMBOL. -- Function: SYMBOL-VALUE (symbol) Package:LISP Returns the current value of the dynamic (special) variable named by SYMBOL. -- Function: BOUNDP (symbol) Package:LISP Returns T if the global variable named by SYMBOL has a value; NIL otherwise. -- Function: DOCUMENTATION (symbol doc-type) Package:LISP Returns the doc-string of DOC-TYPE for SYMBOL; NIL if none exists. Possible doc-types are: FUNCTION (special forms, macros, and functions) VARIABLE (dynamic variables, including constants) TYPE (types defined by DEFTYPE) STRUCTURE (structures defined by DEFSTRUCT) SETF (SETF methods defined by DEFSETF, DEFINE-SETF-METHOD, and DEFINE-MODIFY-MACRO) All built-in special forms, macros, functions, and variables have their doc-strings. -- Function: GENTEMP (&optional (prefix "t") (package *package*)) Package:LISP Creates a new symbol interned in the package PACKAGE with the given PREFIX. -- Function: RENAME-PACKAGE (package new-name &optional (new-nicknames nil)) Package:LISP Replaces the old name and nicknames of PACKAGE with NEW-NAME and NEW-NICKNAMES. -- Function: UNINTERN (symbol &optional (package *package*)) Package:LISP Makes SYMBOL no longer present in PACKAGE. Returns T if SYMBOL was present; NIL otherwise. If PACKAGE is the home package of SYMBOL, then makes SYMBOL uninterned. -- Function: UNEXPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS no longer accessible as external symbols in PACKAGE. SYMBOLS must be a list of symbols or a symbol. -- Function: PACKAGE-NICKNAMES (package) Package:LISP Returns as a list the nickname strings for the specified PACKAGE. -- Function: IMPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS internal symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol. -- Function: GET (symbol indicator &optional (default nil)) Package:LISP Looks on the property list of SYMBOL for the specified INDICATOR. If this is found, returns the associated value. Otherwise, returns DEFAULT. -- Function: FIND-ALL-SYMBOLS (string-or-symbol) Package:LISP Returns a list of all symbols that have the specified name. -- Function: FMAKUNBOUND (symbol) Package:LISP Discards the global function definition named by SYMBOL. Returns SYMBOL. -- Function: PACKAGE-NAME (package) Package:LISP Returns the string that names the specified PACKAGE. -- Function: FIND-PACKAGE (name) Package:LISP Returns the specified package if it already exists; NIL otherwise. NAME may be a string that is the name or nickname of the package. NAME may also be a symbol, in which case the symbol's print name is used. -- Function: APROPOS-LIST (string &optional (package nil)) Package:LISP Returns, as a list, all symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched.  File: gcl-si.info, Node: Operating System, Next: Structures, Prev: Symbols, Up: Top 9 Operating System ****************** * Menu: * Command Line:: * Operating System Definitions::  File: gcl-si.info, Node: Command Line, Next: Operating System Definitions, Prev: Operating System, Up: Operating System 9.1 Command Line ================ The variable si::*command-args* is set to the list of strings passed in when gcl is invoked. Various flags are understood. '-eval' Call read and then eval on the command argument following '-eval' '-load' Load the file whose pathname is specified after '-load'. '-f' Replace si::*command-args* by the the list starting after '-f'. Open the file following '-f' for input, skip the first line, and then read and eval the rest of the forms in the file. This can be used as with the shells to write small shell programs: #!/usr/local/bin/gcl.exe -f (format t "hello world ~a~%" (nth 1 si::*command-args*)) The value si::*command-args* will have the appropriate value. Thus if the above 2 line file is made executable and called 'foo' then tutorial% foo billy hello world billy NOTE: On many systems (eg SunOs) the first line of an executable script file such as: #!/usr/local/bin/gcl.exe -f only reads the first 32 characters! So if your pathname where the executable together with the '-f' amount to more than 32 characters the file will not be recognized. Also the executable must be the actual large binary file, [or a link to it], and not just a '/bin/sh' script. In latter case the '/bin/sh' interpreter would get invoked on the file. Alternately one could invoke the file 'foo' without making it executable: tutorial% gcl -f foo "from bill" hello world from bill Finally perhaps the best way (why do we save the best for last.. I guess because we only figure it out after all the others..) The following file 'myhello' has 4 lines: #!/bin/sh #| Lisp will skip the next 2 lines on reading exec gcl -f "$0" $ |# (format t "hello world ~a~%" (nth 1 si::*command-args*)) marie% chmod a+x myhello marie% myhello bill hello world bill The advantage of this method is that 'gcl' can itself be a shell script, which sets up environment and so on. Also the normal path will be searched to find 'gcl' The disadvantage is that this would cause 2 invocations of 'sh' and one invocation of 'gcl'. The plan using 'gcl.exe' bypasses the 'sh' entirely. Inded invoking 'gcl.exe' to print 'hello world' is faster on most systems than a similar 'csh' or 'bash' script, but slightly slower than the old 'sh'. '-batch' Do not enter the command print loop. Useful if the other command line arguments do something. Do not print the License and acknowledgement information. Note if your program does print any License information, it must print the GCL header information also. '-dir' Directory where the executable binary that is running is located. Needed by save and friends. This gets set as si::*system-directory* '-libdir' -libdir /d/wfs/gcl-2.0/ would mean that the files like gcl-tk/tk.o would be found by concatting the path to the libdir path, ie in /d/wfs/gcl-2.0/gcl-tk/tk.o '-compile' Invoke the compiler on the filename following '-compile'. Other flags affect compilation. '-o-file' If nil follows '-o-file' then do not produce an '.o' file. '-c-file' If '-c-file' is specified, leave the intermediate '.c' file there. '-h-file' If '-h-file' is specified, leave the intermediate '.h' file there. '-data-file' If '-data-file' is specified, leave the intermediate '.data' file there. '-system-p' If '-system-p' is specified then invoke 'compile-file' with the ':system-p t' keyword argument, meaning that the C init function will bear a name based on the name of the file, so that it may be invoked by name by C code.  File: gcl-si.info, Node: Operating System Definitions, Prev: Command Line, Up: Operating System 9.2 Operating System Definitions ================================ -- Function: GET-DECODED-TIME () Package:LISP Returns the current time in decoded time format. Returns nine values: second, minute, hour, date, month, year, day-of-week, daylight-saving-time-p, and time-zone. -- Function: HOST-NAMESTRING (pathname) Package:LISP Returns the host part of PATHNAME as a string. -- Function: RENAME-FILE (file new-name) Package:LISP Renames the file FILE to NEW-NAME. FILE may be a string, a pathname, or a stream. -- Function: FILE-AUTHOR (file) Package:LISP Returns the author name of the specified file, as a string. FILE may be a string or a stream -- Function: PATHNAME-HOST (pathname) Package:LISP Returns the host slot of PATHNAME. -- Function: FILE-POSITION (file-stream &optional position) Package:LISP Sets the file pointer of the specified file to POSITION, if POSITION is given. Otherwise, returns the current file position of the specified file. -- Function: DECODE-UNIVERSAL-TIME (universal-time &optional (timezone -9)) Package:LISP Converts UNIVERSAL-TIME into a decoded time at the TIMEZONE. Returns nine values: second, minute, hour, date, month (1 - 12), year, day-of-week (0 - 6), daylight-saving-time-p, and time-zone. TIMEZONE in GCL defaults to 6, the time zone of Austin, Texas. -- Function: USER-HOMEDIR-PATHNAME (&optional host) Package:LISP Returns the home directory of the logged in user as a pathname. HOST is ignored. -- Variable: *MODULES* Package:LISP A list of names of the modules that have been loaded into GCL. -- Function: SHORT-SITE-NAME () Package:LISP Returns a string that identifies the physical location of the current GCL. -- Function: DIRECTORY (name) Package:LISP Returns a list of files that match NAME. NAME may be a string, a pathname, or a file stream. -- Function: SOFTWARE-VERSION () Package:LISP Returns a string that identifies the software version of the software under which GCL is currently running. -- Constant: INTERNAL-TIME-UNITS-PER-SECOND Package:LISP The number of internal time units that fit into a second. -- Function: ENOUGH-NAMESTRING (pathname &optional (defaults *default-pathname-defaults*)) Package:LISP Returns a string which uniquely identifies PATHNAME with respect to DEFAULTS. -- Function: REQUIRE (module-name &optional (pathname)) Package:LISP If the specified module is not present, then loads the appropriate file(s). PATHNAME may be a single pathname or it may be a list of pathnames. -- Function: ENCODE-UNIVERSAL-TIME (second minute hour date month year &optional (timezone )) Package:LISP Does the inverse operation of DECODE-UNIVERSAL-TIME. -- Function: LISP-IMPLEMENTATION-VERSION () Package:LISP Returns a string that tells you when the current GCL implementation is brought up. -- Function: MACHINE-INSTANCE () Package:LISP Returns a string that identifies the machine instance of the machine on which GCL is currently running. -- Function: ROOM (&optional (x t)) Package:LISP Displays information about storage allocation in the following format. for each type class the number of pages so-far allocated for the type class the maximum number of pages for the type class the percentage of used cells to cells so-far allocated the number of times the garbage collector has been called to collect cells of the type class the implementation types that belongs to the type class the number of pages actually allocated for contiguous blocks the maximum number of pages for contiguous blocks the number of times the garbage collector has been called to collect contiguous blocks the number of pages in the hole the maximum number of pages for relocatable blocks the number of times the garbage collector has been called to collect relocatable blocks the total number of pages allocated for cells the total number of pages allocated the number of available pages the number of pages GCL can use. The number of times the garbage collector has been called is not shown, if the number is zero. The optional X is ignored. -- Function: GET-UNIVERSAL-TIME () Package:LISP Returns the current time as a single integer in universal time format. -- Function: GET-INTERNAL-RUN-TIME () Package:LISP Returns the run time in the internal time format. This is useful for finding CPU usage. If the operating system allows, a second value containing CPU usage of child processes is returned. -- Variable: *DEFAULT-PATHNAME-DEFAULTS* Package:LISP The default pathname-defaults pathname. -- Function: LONG-SITE-NAME () Package:LISP Returns a string that identifies the physical location of the current GCL. -- Function: DELETE-FILE (file) Package:LISP Deletes FILE. -- Function: GET-INTERNAL-REAL-TIME () Package:LISP Returns the real time in the internal time format. This is useful for finding elapsed time. -- Function: MACHINE-TYPE () Package:LISP Returns a string that identifies the machine type of the machine on which GCL is currently running. -- Macro: TIME Package:LISP Syntax: (time form) Evaluates FORM and outputs timing statistics on *TRACE-OUTPUT*. -- Function: SOFTWARE-TYPE () Package:LISP Returns a string that identifies the software type of the software under which GCL is currently running. -- Function: LISP-IMPLEMENTATION-TYPE () Package:LISP Returns a string that tells you that you are using a version of GCL. -- Function: SLEEP (n) Package:LISP This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number. -- Function: BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero floating-point-invalid-operation floating-point-overflow floating-point-underflow floating-point-inexact) Package:SI Break on the specified IEEE floating point error conditions. With no arguments, report the exceptions currently trapped. Disable the break by setting the key to nil, e.g. > (break-on-floaing-point-exceptions :division-by-zero t) (DIVISION-BY-ZERO) > (break-on-floaing-point-exceptions) (DIVISION-BY-ZERO) > (break-on-floaing-point-exceptions :division-by-zero nil) NIL On some of the most common platforms, the offending instruction will be disassembled, and the register arguments looked up in the saved context and reported in as operands. Within the error handler, addresses may be disassembled, and other registers inspected, using the functions defined in gcl_fpe.lsp.  File: gcl-si.info, Node: Structures, Next: Iteration and Tests, Prev: Operating System, Up: Top 10 Structures ************* -- Macro: DEFSTRUCT Package:LISP Syntax: (defstruct {name | (name {:conc-name | (:conc-name prefix-string) | :constructor | (:constructor symbol [lambda-list]) | :copier | (:copier symbol) | :predicate | (:predicate symbol) | (:include symbol) | (:print-function function) | (:type {vector | (vector type) | list}) | :named | (:static { nil | t}) (:initial-offset number)}*)} [doc] {slot-name | (slot-name [default-value-form] {:type type | :read-only flag}*) }* ) Defines a structure. The doc-string DOC, if supplied, is saved as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure). STATIC is gcl specific and makes the body non relocatable. See the files misc/rusage.lsp misc/cstruct.lsp, for examples of making a lisp structure correspond to a C structure. -- Function: HELP (&optional symbol) Package:LISP GCL specific: Prints the documentation associated with SYMBOL. With no argument, this function prints the greeting message to GCL beginners.  File: gcl-si.info, Node: Iteration and Tests, Next: User Interface, Prev: Structures, Up: Top 11 Iteration and Tests ********************** -- Macro: DO-EXTERNAL-SYMBOLS Package:LISP Syntax: (do-external-symbols (var [package [result-form]]) {decl}* {tag | statement}*) Executes STATEMENTs once for each external symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). -- Special Form: DO* Package:LISP Syntax: (do* ({(var [init [step]])}*) (endtest {result}*) {decl}* {tag | statement}*) Just like DO, but performs variable bindings and assignments in serial, just like LET* and SETQ do. -- Macro: DO-ALL-SYMBOLS Package:LISP Syntax: (do-all-symbols (var [result-form]) {decl}* {tag | statement}*) Executes STATEMENTs once for each symbol in each package, with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). -- Function: YES-OR-NO-P (&optional (format-string nil) &rest args) Package:LISP Asks the user a question whose answer is either 'YES' or 'NO'. If FORMAT- STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Yes or No)" is printed. Otherwise, no prompt will appear. -- Function: MAPHASH #'hash-table Package:LISP For each entry in HASH-TABLE, calls FUNCTION on the key and value of the entry; returns NIL. -- Function: MAPCAR (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs and returns the results as a list. -- Special Form: DOLIST Package:LISP Syntax: (dolist (var listform [result]) {decl}* {tag | statement}*) Executes STATEMENTs, with VAR bound to each member of the list value of LISTFORM. Then returns the value(s) of RESULT (which defaults to NIL). -- Function: EQ (x y) Package:LISP Returns T if X and Y are the same identical object; NIL otherwise. -- Function: EQUALP (x y) Package:LISP Returns T if X and Y are EQUAL, if they are characters and satisfy CHAR-EQUAL, if they are numbers and have the same numerical value, or if they have components that are all EQUALP. Returns NIL otherwise. -- Function: EQUAL (x y) Package:LISP Returns T if X and Y are EQL or if they are of the same type and corresponding components are EQUAL. Returns NIL otherwise. Strings and bit-vectors are EQUAL if they are the same length and have identical components. Other arrays must be EQ to be EQUAL. -- Macro: DO-SYMBOLS Package:LISP Syntax: (do-symbols (var [package [result-form]]) {decl}* {tag | statement}*) Executes STATEMENTs once for each symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). -- Special Form: LOOP Package:LISP Syntax: (loop {form}*) Executes FORMs repeatedly until exited by a THROW or RETURN. The FORMs are surrounded by an implicit NIL block.  File: gcl-si.info, Node: User Interface, Next: Doc, Prev: Iteration and Tests, Up: Top 12 User Interface ***************** -- Special Variable: - Package:LISP Holds the top-level form that GCL is currently evaluating. -- Function: - (number &rest more-numbers) Package:LISP Subtracts the second and all subsequent NUMBERs from the first NUMBER. With one arg, negates it. -- Macro: UNTRACE Package:LISP Syntax: (untrace {function-name}*) Removes tracing from the specified functions. With no FUNCTION-NAMEs, untraces all functions. -- Variable: *** Package:LISP Gets the previous value of ** when GCL evaluates a top-level form. -- Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) Package:LISP Returns an input stream which will supply the characters of String between Start and End in order. -- Macro: STEP Package:LISP Syntax: (step form) Evaluates FORM in the single-step mode and returns the value. -- Variable: *BREAK-ENABLE* Package:LISP GCL specific: When an error occurrs, control enters to the break loop only if the value of this variable is non-NIL. -- Special Variable: / Package:LISP Holds a list of the values of the last top-level form. -- Function: DESCRIBE (x) Package:LISP Prints a description of the object X. -- Function: ED (&optional x) Package:LISP Invokes the editor. The action depends on the version of GCL. -- Variable: *DEBUG-IO* Package:LISP Holds the I/O stream used by the GCL debugger. -- Variable: *BREAK-ON-WARNINGS* Package:LISP When the function WARN is called, control enters to the break loop only if the value of this varialbe is non-NIL. -- Function: CERROR (continue-format-string error-format-string &rest args) Package:LISP Signals a correctable error. -- Variable: ** Package:LISP Gets the previous value of * when GCL evaluates a top-level form. -- Special Variable: +++ Package:LISP Gets the previous value of ++ when GCL evaluates a top-level form. -- Function: INSPECT (x) Package:LISP Shows the information about the object X in an interactive manner -- Special Variable: // Package:LISP Gets the previous value of / when GCL evaluates a top-level form. -- Variable: *TRACE-OUTPUT* Package:LISP The trace output stream. -- Special Variable: ++ Package:LISP Gets the previous value of + when GCL evaluates a top-level form. -- Variable: *ERROR-OUTPUT* Package:LISP Holds the output stream for error messages. -- Function: DRIBBLE (&optional pathname) Package:LISP If PATHNAME is given, begins to record the interaction to the specified file. If PATHNAME is not given, ends the recording. -- Variable: * Package:LISP Holds the value of the last top-level form. -- Special Variable: /// Package:LISP Gets the previous value of // when GCL evaluates a top-level form. -- Function: WARN (format-string &rest args) Package:LISP Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. -- Function: BREAK (&optional (format-string nil) &rest args) Package:LISP Enters a break loop. If FORMAT-STRING is non-NIL, formats FORMAT-STRING and ARGS to *ERROR-OUTPUT* before entering a break loop. Typing :HELP at the break loop will list the break-loop commands. -- Special Variable: + Package:LISP Holds the last top-level form. -- Macro: TRACE Package:LISP Syntax: (trace {function-name}*) Traces the specified functions. With no FUNCTION-NAMEs, returns a list of functions currently being traced. Additional Keywords are allowed in GCL with the syntax (trace {fn | (fn {:kw form}*)}*) For each FN naming a function, traces that function. Each :KW should be one of the ones listed below, and FORM should have the corresponding form. No :KW may be given more than once for the same FN. Returns a list of all FNs now traced which weren't already traced. EXAMPLE (Try this with your favorite factorial function FACT): ;; print entry args and exit values (trace FACT) ;; Break coming out of FACT if the value is bigger than 1000. (trace (fact :exit (progn (if (> (car values) 1000)(break "big result")) (car values)))) ;; Hairy example: ;;make arglist available without the si:: prefix (import 'si::arglist) (trace (fact :DECLARATIONS ((in-string "Here comes input: ") (out-string "Here comes output: ") all-values (silly (+ 3 4))) :COND (equal (rem (car arglist) 2) 0) :ENTRY (progn (cond ((equal (car arglist) 8) (princ "Entering FACT on input 8!! ") (setq out-string "Here comes output from inside (FACT 8): ")) (t (princ in-string))) (car arglist)) :EXIT (progn (setq all-values (cons (car values) all-values)) (princ out-string) (when (equal (car arglist) 8) ;; reset out-string (setq out-string "Here comes output: ")) (cons 'fact values)) :ENTRYCOND (not (= (car arglist) 6)) :EXITCOND (not (= (car values) (* 6 (car arglist)))) :DEPTH 5)) Syntax is ':keyword' form1 ':keyword' form2 ... ':declarations' DEFAULT: NIL FORM is ((var1 form1 )(var2 form2 )...), where the var_i are symbols distinct from each other and from all symbols which are similarly declared for currently traced functions. Each form is evaluated immediately. Upon any invocation of a traced function when not already inside a traced function call, each var is bound to that value of form . ':COND' DEFAULT: T Here, FORM is any Lisp form to be evaluated (by EVAL) upon entering a call of FN, in the environment where si::ARGLIST is bound to the current list of arguments of FN. Note that even if the evaluation of FORM changes the value of SI::ARGLIST (e.g. by evaluation of (SETQ si::ARGLIST ...)), the list of arguments passed to FN is unchanged. Users may alter args passed by destructively modifying the list structure of SI::ARGLIST however. The call is traced (thus invoking the :ENTRYCOND and :EXITCOND forms, at least) if and only if FORM does not evaluate to NIL. ':ENTRYCOND' DEFAULT: T This is evaluated (by EVAL) if the :COND form evaluates to non-NIL, both in an environment where SI::ARGLIST is bound to the current list of arguments of FN. If non-NIL, the :ENTRY form is then evaluated and printed with the trace "prompt". ':ENTRY' DEFAULT: (CONS (QUOTE x) SI::ARGLIST), where x is the symbol we call FN If the :COND and :ENTRYCOND forms evaluate to non-NIL, then the trace "prompt" is printed and then this FORM is evaluated (by EVAL) in an environment where SI::ARGLIST is bound to the current list of arguments of FN. The result is then printed. ':EXITCOND' DEFAULT: T This is evaluated (by EVAL) in the environment described below for the :EXIT form. The :EXIT form is then evaluated and printed with the "prompt" if and only if the result here is non-NIL. ':EXIT' DEFAULT: (CONS (QUOTE x) VALUES), where x is the symbol we call FN Upon exit from tracing a given call, this FORM is evaluated (after the appropriate trace "prompt" is printed), using EVAL in an environment where SI::ARGLIST is bound to the current list of arguments of FN and VALUES is bound to the list of values returned by FN (recalling that Common Lisp functions may return multiple values). ':DEPTH' DEFAULT: No depth limit FORM is simply a positive integer specifying the maximum nesting of traced calls of FN, i.e. of calls of FN in which the :COND form evaluated to non-NIL. For calls of FN in which this limit is exceeded, even the :COND form is not evaluated, and the call is not traced.  File: gcl-si.info, Node: Doc, Next: Type, Prev: User Interface, Up: Top 13 Doc ****** -- Function: APROPOS (string &optional (package nil)) Package:LISP Prints those symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched. -- Function: INFO (string &optional (list-of-info-files *default-info-files*)) PACKAGE:SI Find all documentation about STRING in LIST-OF-INFO-FILES. The search is done for STRING as a substring of a node name, or for STRING in the indexed entries in the first index for each info file. Typically that should be a variable and function definition index, if the info file is about a programming language. If the windowing system is connected, then a choice box is offered and double clicking on an item brings up its documentation. Otherwise a list of choices is offered and the user may select some of these choices. list-of-info-files is of the form ("gcl-si.info" "gcl-tk.info" "gcl.info") The above list is the default value of *default-info-files*, a variable in the SI package. To find these files in the file system, the search path *info-paths* is consulted as is the master info directory 'dir'. see *Index *default-info-files*:: and *Index *info-paths*::. For example (info "defun") 0: DEFUN :(gcl-si.info)Special Forms and Functions. 1: (gcl.info)defun. Enter n, all, none, or multiple choices eg 1 3 : 1 Info from file /home/wfs/gcl-doc/gcl.info: defun [Macro] --------------------------------------------------------------------------- `Defun' function-name lambda-list [[{declaration}* | documentation]] ... would list the node '(gcl.info)defun'. That is the node entitled 'defun' from the info file gcl.info. That documentation is based on the ANSI common lisp standard. The choice DEFUN :(gcl-si.info)Special Forms and Functions. refers to the documentation on DEFUN from the info file gcl-si.info in the node Special Forms And Functions. This is an index reference and only the part of the node which refers to 'defun' will be printed. (info "factor" '("maxima.info")) would search the maxima info files index and nodes for 'factor'. -- Variable: *info-paths* Package SI: A list of strings such as '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" "/usr/local/gnu/info/" ) saying where to look for the info files. It is used implicitly by 'info', see *Index info::. Looking for maxima.info would look for the file maxima.info in all the directories listed in *info-paths*. If nto found then it would look for 'dir' in the *info-paths* directories, and if it were found it would look in the 'dir' for a menu item such as * maxima: (/home/wfs/maxima-5.0/info/maxima.info). If such an entry exists then the directory there would be used for the purpose of finding 'maxima.info'  File: gcl-si.info, Node: Type, Next: GCL Specific, Prev: Doc, Up: Top 14 Type ******* -- Function: COERCE (x type) Package:LISP Coerces X to an object of the type TYPE. -- Function: TYPE-OF (x) Package:LISP Returns the type of X. -- Function: CONSTANTP (symbol) Package:LISP Returns T if the variable named by SYMBOL is a constant; NIL otherwise. -- Function: TYPEP (x type) Package:LISP Returns T if X is of the type TYPE; NIL otherwise. -- Function: COMMONP (x) Package:LISP Returns T if X is a Common Lisp object; NIL otherwise. -- Function: SUBTYPEP (type1 type2) Package:LISP Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If it could not determine, then returns NIL as the second value. Otherwise, the second value is T. -- Macro: CHECK-TYPE Package:LISP Syntax: (check-type place typespec [string]) Signals an error, if the contents of PLACE are not of the specified type. -- Macro: ASSERT Package:LISP Syntax: (assert test-form [({place}*) [string {arg}*]]) Signals an error if the value of TEST-FORM is NIL. STRING is an format string used as the error message. ARGs are arguments to the format string. -- Macro: DEFTYPE Package:LISP Syntax: (deftype name lambda-list {decl | doc}* {form}*) Defines a new type-specifier abbreviation in terms of an 'expansion' function (lambda lambda-list1 {decl}* {form}*) where lambda-list1 is identical to LAMBDA-LIST except that all optional parameters with no default value specified in LAMBDA-LIST defaults to the symbol '*', but not to NIL. When the type system of GCL encounters a type specifier (NAME arg1 ... argn), it calls the expansion function with the arguments arg1 ... argn, and uses the returned value instead of the original type specifier. When the symbol NAME is used as a type specifier, the expansion function is called with no argument. The doc-string DOC, if supplied, is saved as the TYPE doc of NAME, and is retrieved by (documentation 'NAME 'type). -- Declaration: DYNAMIC-EXTENT Package:LISP Declaration to allow locals to be cons'd on the C stack. For example (defun foo (&rest l) (declare (:dynamic-extent l)) ...) will cause l to be a list formed on the C stack of the foo function frame. Of course passing L out as a value of foo will cause havoc. (setq x (make-list n)) (setq x (cons a b)) (setq x (list a b c ..)) also are handled on the stack, for dynamic-extent x.  File: gcl-si.info, Node: GCL Specific, Next: C Interface, Prev: Type, Up: Top 15 GCL Specific *************** -- Function: SYSTEM (string) Package:LISP GCL specific: Executes a Shell command as if STRING is an input to the Shell. Not all versions of GCL support this function. At least on POSIX systems, this call should return two integers represeting the exit status and any possible terminating signal respectively. -- Variable: *TMP-DIR* Package:COMPILER GCL specific: Directory in which temporary "gazonk" files used by the compiler are to be created. -- Variable: *IGNORE-MAXIMUM-PAGES* Package:SI GCL specific: Tells the GCL memory manager whether (non-NIL) or not (NIL) it should expand memory whenever the maximum allocatable pages have been used up. -- Variable: *OPTIMIZE-MAXIMUM-PAGES* Package:SI GCL specific: Tells the GCL memory manager whether to attempt to adjust the maximum allowable pages for each type to approximately optimize the garbage collection load in the current process. Defaults to T. Set to NIL if you care more about memory usage than runtime. -- Function: MACHINE-VERSION () Package:LISP Returns a string that identifies the machine version of the machine on which GCL is currently running. -- Function: BY () Package:LISP GCL specific: Exits from GCL. -- Macro: DEFCFUN Package:LISP Syntax: (defcfun header n {element}*) GCL specific: Defines a C-language function which calls Lisp functions and/or handles Lisp objects. HEADER gives the header of the C function as a string. Non-negative-integer is the number of the main stack entries used by the C function, primarily for protecting Lisp objects from being garbage-collected. Each ELEMENT may give a C code fragment as a string, or it may be a list ((symbol {arg}*) {place}*) which, when executed, calls the Lisp function named by SYMBOL with the specified arguments and saves the value(s) to the specified places. The DEFCFUN form has the above meanings only after compiled; The GCL interpreter simply ignores this form. An example which defines a C function list2 of two arguments, but which calls the 'lisp' function CONS by name, and refers to the constant 'NIL. Note to be loaded by 'load' the function should be static. (defCfun "static object list2(x,y) object x,y;" 0 "object z;" ('NIL z) ((CONS y z) z) ((CONS x z) z) "return(z);" ) In lisp the operations in the body would be (setq z 'nil) (setq z (cons y z)) (setq z (cons x z)) Syntax: (defCfun header non-negative-integer { string | ( function-symbol { value }* ) | (( function-symbol { value }* ) { place }* ) }) value: place: { C-expr | ( C-type C-expr ) } C-function-name: C-expr: { string | symbol } C-type: { object | int | char | float | double } -- Macro: CLINES Package:LISP Syntax: (clines {string}*) GCL specific: The GCL compiler embeds STRINGs into the intermediate C language code. The interpreter ignores this form. -- Function: ALLOCATE (type number &optional (really-allocate nil)) Package:LISP GCL specific: Sets the maximum number of pages for the type class of the GCL implementation type TYPE to NUMBER. If REALLY-ALLOCATE is given a non-NIL value, then the specified number of pages will be allocated immediately. -- Function: GBC (x) Package:LISP GCL specific: Invokes the garbage collector (GC) with the collection level specified by X. NIL as the argument causes GC to collect cells only. T as the argument causes GC to collect everything. -- Function: SAVE (pathname) Package:LISP GCL specific: Saves the current GCL core image into a program file specified by PATHNAME. This function depends on the version of GCL. The function si::save-system is to be preferred in almost all circumstances. Unlike save, it makes the relocatable section permanent, and causes no future gc of currently loaded .o files. -- Function: HELP* (string &optional (package 'lisp)) Package:LISP GCL specific: Prints the documentation associated with those symbols in the specified package whose print names contain STRING as substring. STRING may be a symbol, in which case the print-name of that symbol is used. If PACKAGE is NIL, then all packages are searched. -- Macro: DEFLA Package:LISP Syntax: (defla name lambda-list {decl | doc}* {form}*) GCL specific: Used to DEFine Lisp Alternative. For the interpreter, DEFLA is equivalent to DEFUN, but the compiler ignores this form. -- Function: PROCLAMATION (decl-spec) Package:LISP GCL specific: Returns T if the specified declaration is globally in effect; NIL otherwise. See the doc of DECLARE for possible DECL-SPECs. -- Macro: DEFENTRY Package:LISP Syntax: (defentry name arg-types c-function) GCL specific: The compiler defines a Lisp function whose body consists of a calling sequence to the C language function specified by C-FUNCTION. The interpreter ignores this form. The ARG-TYPES specifies the C types of the arguments which C-FUNCTION requires. The list of allowed types is (object char int float double string). Code will be produced to coerce from a lisp object to the appropriate type before passing the argument to the C-FUNCTION. The c-function should be of the form (c-result-type c-fname) where c-result-type is a member of (void object char int float double string). c-fname may be a symbol (in which case it will be downcased) or a string. If c-function is not a list, then (object c-function) is assumed. In order for C code to be loaded in by 'load' you should declare any variables and functions to be static. If you will link them in at build time, of course you are allowed to define new externals. Sample usage: --File begin----- ;; JOE takes X a lisp string and Y a fixnum and returns a character. (clines "#include \"foo.ch\"") (defentry joe (string int) (char "our_c_fun")) ---File end------ ---File foo.ch--- /* C function for extracting the i'th element of a string */ static char our_c_fun(p,i) char *p; int i; { return p[i]; } -----File end--- One must be careful of storage allocation issues when passing a string. If the C code invokes storage allocation (either by calling 'malloc' or 'make_cons' etc), then there is a possibility of a garbage collection, so that if the string passed was not constructed with ':static t' when its array was constructed, then it could move. If the C function may allocate storage, then you should pass a copy: (defun safe-c-string (x) (let* ((n (length x)) (a (make-array (+ n 1) :element-type 'string-char :static t :fill-pointer n))) (si::copy-array-portion x y 0 0 n) (setf (aref a n) (code-char 0))) a) -- Function: COPY-ARRAY-PORTION (x,y,i1,i2,n1) Package:SI Copy elements from X to Y starting at X[i1] to Y[i2] and doing N1 elements if N1 is supplied otherwise, doing the length of X - I1 elements. If the types of the arrays are not the same, this has implementation dependent results. -- Function: BYE ( &optional (exit-status 0)) Package:LISP GCL specific: Exits from GCL with exit-status. -- Function: USE-FAST-LINKS (turn-on) Package:LISP GCL specific: If TURN-ON is not nil, the fast link mechanism is enabled, so that ordinary function calls will not appear in the invocation stack, and calls will be much faster. This is the default. If you anticipate needing to see a stack trace in the debugger, then you should turn this off. * Menu: * Bignums::  File: gcl-si.info, Node: Bignums, Prev: GCL Specific, Up: GCL Specific 15.1 Bignums ============ A directory mp was added to hold the new multi precision arithmetic code. The layout and a fair amount of code in the mp directory is an enhanced version of gpari version 34. The gpari c code was rewritten to be more efficient, and gcc assembler macros were added to allow inlining of operations not possible to do in C. On a 68K machine, this allows the C version to be as efficient as the very carefully written assembler in the gpari distribution. For the main machines, an assembler file (produced by gcc) based on this new method, is included. This is for sites which do not have gcc, or do not wish to compile the whole system with gcc. Bignum arithmetic is much faster now. Many changes were made to cmpnew also, to add 'integer' as a new type. It differs from variables of other types, in that storage is associated to each such variable, and assignments mean copying the storage. This allows a function which does a good deal of bignum arithmetic, to do very little consing in the heap. An example is the computation of PI-INV in scratchpad, which calculates the inverse of pi to a prescribed number of bits accuracy. That function is now about 20 times faster, and no longer causes garbage collection. In versions of GCL where HAVE_ALLOCA is defined, the temporary storage growth is on the C stack, although this often not so critical (for example it makes virtually no difference in the PI-INV example, since in spite of the many operations, only one storage allocation takes place. Below is the actual code for PI-INV On a sun3/280 (cli.com) Here is the comparison of lucid and gcl before and after on that pi-inv. Times are in seconds with multiples of the gcl/akcl time in parentheses. On a sun3/280 (cli.com) pi-inv akcl-566 franz lucid old kcl/akcl ---------------------------------------- 10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) 20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) (defun pi-inv (bits &aux (m 0)) (declare (integer bits m)) (let* ((n (+ bits (integer-length bits) 11)) (tt (truncate (ash 1 n) 882)) (d (* 4 882 882)) (s 0)) (declare (integer s d tt n)) (do ((i 2 (+ i 2)) (j 1123 (+ j 21460))) ((zerop tt) (cons s (- (+ n 2)))) (declare (integer i j)) (setq s (+ s (* j tt)) m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) tt (truncate (* m tt) (* d (the integer (expt i 3))))))))  File: gcl-si.info, Node: C Interface, Next: System Definitions, Prev: GCL Specific, Up: Top 16 C Interface ************** * Menu: * Available Symbols::  File: gcl-si.info, Node: Available Symbols, Prev: C Interface, Up: C Interface 16.1 Available Symbols ====================== When GCL is built, those symbols in the system libraries which are referenced by functions linked in in the list of objects given in 'unixport/makefile', become available for reference by GCL code. On some systems it is possible with 'faslink' to load '.o' files which reference other libraries, but in general this practice is not portable.  File: gcl-si.info, Node: System Definitions, Next: Debugging, Prev: C Interface, Up: Top 17 System Definitions ********************* -- Function: ALLOCATE-CONTIGUOUS-PAGES (number &optional (really-allocate nil)) Package:SI GCL specific: Sets the maximum number of pages for contiguous blocks to NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified number of pages will be allocated immediately. -- Function: FREEZE-DEFSTRUCT (name) Package:SI The inline defstruct type checker will be made more efficient, in that it will only check for types which currently include NAME. After calling this the defstruct should not be altered. -- Function: MAXIMUM-ALLOCATABLE-PAGES (type) Package:SI GCL specific: Returns the current maximum number of pages for the type class of the GCL implementation type TYPE. -- Function: ALLOCATED-RELOCATABLE-PAGES () Package:SI GCL specific: Returns the number of pages currently allocated for relocatable blocks. -- Function: PUTPROP (symbol value indicator) Package:SI Give SYMBOL the VALUE on INDICATOR property. -- Function: ALLOCATED-PAGES (type) Package:SI GCL specific: Returns the number of pages currently allocated for the type class of the GCL implementation type TYPE. -- Function: ALLOCATE-RELOCATABLE-PAGES (number) Package:SI GCL specific: Sets the maximum number of pages for relocatable blocks to NUMBER. -- Function: ALLOCATED-CONTIGUOUS-PAGES () Package:SI GCL specific: Returns the number of pages currently allocated for contiguous blocks. -- Function: MAXIMUM-CONTIGUOUS-PAGES () Package:SI GCL specific: Returns the current maximum number of pages for contiguous blocks. -- Function: GET-HOLE-SIZE () Package:SI GCL specific: Returns as a fixnum the size of the memory hole (in pages). -- Function: SPECIALP (symbol) Package:SI GCL specific: Returns T if the SYMBOL is a globally special variable; NIL otherwise. -- Function: OUTPUT-STREAM-STRING (string-output-stream) Package:SI GCL specific: Returns the string corresponding to the STRING-OUTPUT-STREAM. -- Function: GET-STRING-INPUT-STREAM-INDEX (string-input-stream) Package:SI GCL specific: Returns the current index of the STRING-INPUT-STREAM. -- Function: STRING-CONCATENATE (&rest strings) Package:SI GCL specific: Returns the result of concatenating the given STRINGS. -- Function: BDS-VAR (i) Package:SI GCL specific: Returns the symbol of the i-th entity in the bind stack. -- Function: ERROR-SET (form) Package:SI GCL specific: Evaluates the FORM in the null environment. If the evaluation of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first value and the result of the evaluation as the rest of the values. If, in the course of the evaluation, a non-local jump from the FORM is atempted, SI:ERROR-SET traps the jump and returns the corresponding jump tag as its value. -- Function: COMPILED-FUNCTION-NAME (compiled-function-object) Package:SI GCL specific: Returns the name of the COMPILED-FUNCTION-OBJECT. -- Function: STRUCTUREP (object) Package:SI GCL specific: Returns T if the OBJECT is a structure; NIL otherwise. -- Function: IHS-VS (i) Package:SI GCL specific: Returns the value stack index of the i-th entity in the invocation history stack. -- Function: UNIVERSAL-ERROR-HANDLER (error-name correctable function-name continue-format-string error-format-string &rest args) Package:SI GCL specific: Starts the error handler of GCL. When an error is detected, GCL calls SI:UNIVERSAL-ERROR-HANDLER with the specified arguments. ERROR-NAME is the name of the error. CORRECTABLE is T for a correctable error and NIL for a fatal error. FUNCTION-NAME is the name of the function that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the format strings of the error message. ARGS are the arguments to the format strings. To change the error handler of GCL, redefine SI:UNIVERSAL-ERROR- HANDLER. -- Variable: *INTERRUPT-ENABLE* Package:SI GCL specific: If the value of SI:*INTERRUPT-ENABLE* is non-NIL, GCL signals an error on the terminal interrupt (this is the default case). If it is NIL, GCL ignores the interrupt and assigns T to SI:*INTERRUPT-ENABLE*. -- Function: CHDIR (pathname) Package:SI GCL/UNIX specific: Changes the current working directory to the specified pathname. -- Function: COPY-STREAM (in-stream out-stream) Package:SI GCL specific: Copies IN-STREAM to OUT-STREAM until the end-of-file on IN- STREAM. -- Function: INIT-SYSTEM () Package:SI GCL specific: Initializes the library and the compiler of GCL. Since they have already been initialized in the standard image of GCL, calling SI:INIT- SYSTEM will cause an error. -- Variable: *INDENT-FORMATTED-OUTPUT* Package:SI GCL specific: The FORMAT directive ~% indents the next line if the value of this variable is non-NIL. If NIL, ~% simply does Newline. -- Function: SET-HOLE-SIZE (fixnum) Package:SI GCL specific: Sets the size of the memory hole (in pages). -- Function: FRS-BDS (i) Package:SI GCL specific: Returns the bind stack index of the i-th entity in the frame stack. -- Function: IHS-FUN (i) Package:SI GCL specific: Returns the function value of the i-th entity in the invocation history stack. -- Function: *MAKE-CONSTANT (symbol value) Package:SI GCL specific: Makes the SYMBOL a constant with the specified VALUE. -- Function: FIXNUMP (object) Package:SI GCL specific: Returns T if the OBJECT is a fixnum; NIL otherwise. -- Function: BDS-VAL (i) Package:SI GCL specific: Returns the value of the i-th entity in the bind stack. -- Function: STRING-TO-OBJECT (string) Package:SI GCL specific: (SI:STRING-TO-OBJECT STRING) is equivalent to (READ-FROM-STRING STRING), but much faster. -- Variable: *SYSTEM-DIRECTORY* Package:SI GCL specific: Holds the name of the system directory of GCL. -- Function: FRS-IHS (i) Package:SI GCL specific: Returns the invocation history stack index of the i-th entity in the frame stack. -- Function: RESET-GBC-COUNT () Package:SI GCL specific: Resets the counter of the garbage collector that records how many times the garbage collector has been called for each implementation type. -- Function: CATCH-BAD-SIGNALS () Package:SI GCL/BSD specific: Installs a signal catcher for bad signals: SIGILL, SIGIOT, SIGEMT, SIGBUS, SIGSEGV, SIGSYS. The signal catcher, upon catching the signal, signals an error (and enter the break-level). Since the internal memory of GCL may be broken, the user should check the signal and exit from GCL if necessary. When the signal is caught during garbage collection, GCL terminates immediately. -- Function: RESET-STACK-LIMITS () Package:SI GCL specific: Resets the stack limits to the normal state. When a stack has overflowed, GCL extends the limit for the stack in order to execute the error handler. After processing the error, GCL resets the stack limit by calling SI:RESET-STACK-LIMITS. -- Variable: *GBC-MESSAGE* Package:SI GCL specific: If the value of SI:*GBC-MESSAGE* is non-NIL, the garbage collector prints some information on the terminal. Usually SI:*GBC-MESSAGE* should be set NIL. -- Variable: *GBC-NOTIFY* Package:SI GCL specific: If the value is non-NIL, the garbage collector prints a very brief one line message about the area causing the collection, and the time spent in internal time units. -- Variable: *AFTER-GBC-HOOK* Package:SI Defaults to nil, but may be set to a function of one argument TYPE which is a lisp variable indicating the TYPE which caused the current collection. -- Funcition: ALLOCATED (type) Package:SI Returns 6 values: nfree number free npages number of pages maxpage number of pages to grow to nppage number per page gbccount number of gc's due to running out of items of this size nused number of items used Note that all items of the same size are stored on similar pages. Thus for example on a 486 under linux the following basic types are all the same size and so will share the same allocated information: CONS BIGNUM RATIO COMPLEX STRUCTURE. -- Function: *MAKE-SPECIAL (symbol) Package:SI GCL specific: Makes the SYMBOL globally special. -- Function: MAKE-STRING-OUTPUT-STREAM-FROM-STRING (string) Package:SI GCL specific: Creates a string-output-stream corresponding to the STRING and returns it. The STRING should have a fill-pointer. -- Variable: *IGNORE-EOF-ON-TERMINAL-IO* Package:SI GCL specific: If the value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is non-NIL, GCL ignores the eof-character (usually ^D) on the terminal and the terminal never becomes end-of-file. The default value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is NIL. -- Function: ADDRESS (object) Package:SI GCL specific: Returns the address of the OBJECT as a fixnum. The address of an object depends on the version of GCL. E.g. (SI:ADDRESS NIL) returns 1879062044 on GCL/AOSVS dated March 14, 1986. -- Variable: *LISP-MAXPAGES* Package:SI GCL specific: Holds the maximum number of pages (1 page = 2048 bytes) for the GCL process. The result of changing the value of SI:*LISP-MAXPAGES* is unpredictable. -- Function: ARGC () Package:SI GCL specific: Returns the number of arguments on the command line that invoked the GCL process. -- Function: NANI (fixnum) Package:SI GCL specific: Returns the object in the address FIXNUM. This function is the inverse of SI:ADDRESS. Although SI:ADDRESS is a harmless operation, SI:NANI is quite dangerous and should be used with care. -- Variable: *NOTIFY-GBC* Package:SI GCL specific: If the value of this variable is non-NIL, then the garbage collector notifies that it begins to run whenever it is invoked. Otherwise, garbage collection begins silently. -- Function: SAVE-SYSTEM (pathname) Package:SI GCL specific: Saves the current GCL core imange into a program file specified by PATHNAME. This function differs from SAVE in that the contiguous and relocatable areas are made permanent in the saved image. Usually the standard image of GCL interpreter/compiler is saved by SI:SAVE-SYSTEM. This function causes an exit from lisp. Various changes are made to the memory of the running system, such as closing files and resetting io streams. It would not be possible to continue normally. -- Function: UNCATCH-BAD-SIGNALS () Package:SI GCL/BSD specific: Undoes the effect of SI:CATCH-BAD-SIGNALS. -- Function: VS (i) Package:SI GCL specific: Returns the i-th entity in the value stack. -- Function: DISPLACED-ARRAY-P (array) Package:SI GCL specific: Returns T if the ARRAY is a displaced array; NIL otherwise. -- Function: ARGV (fixnum) Package:SI GCL specific: Returns the FIXNUM-th argument on the command line that invoked the GCL process. -- Variable: *DEFAULT-TIME-ZONE* Package:SI GCL specific: Holds the default time zone. The initial value of SI:*DEFAULT- TIME-ZONE* is 6 (the time zone of Austin, Texas). -- Function: GETENV (string) Package:SI GCL/UNIX specific: Returns the environment with the name STRING as a string; if the environment specified by STRING is not found, returns NIL. -- Function: FASLINK (file string) Package:SI GCL/BSD specific: Loads the FASL file FILE while linking the object files and libraries specified by STRING. For example, (faslink "foo.o" "bar.o boo.o -lpixrect") loads foo.o while linking two object files (bar.o and boo.o) and the library pixrect. Usually, foo.o consists of the C language interface for the functions defined in the object files or the libraries. A more portable way of making references to C code, is to build it in at the time of the original make. If foo.c references things in -lpixrect, and foo.o is its compilation in the gcl/unixport directory (cd gcl/unixport ; make "EXTRAS= foo.o -lpixrect ") should add them. If EXTRAS was already joe.o in the unixport/makefile you should of course add joe.o to the above "EXTRAS= joe.o foo.o.." Faslink does not work on most UNIX systems which are derived from SYS V or AIX. -- Function: TOP-LEVEL () Package:SI GCL specific: Starts the standard top-level listner of GCL. When the GCL process is invoked, it calls SI:TOP-LEVEL by (FUNCALL 'SI:TOP-LEVEL). To change the top-level of GCL, redefine SI:TOP-LEVEL and save the core imange in a file. When the saved imange is invoked, it will start the redefined top-level. -- Function: FRS-VS (i) Package:SI GCL specific: Returns the value stack index of the i-th entity in the frame stack. -- Function: WRITE-DEBUG-SYMBOLS (start file &key (main-file "/usr/local/schelter/xgcl/unixport/raw_gcl") (output-file "debug-symbols.o" )) Package:SI Write out a file of debug-symbols using address START as the place where FILE will be loaded into the running executable MAIN-FILE. The last is a keyword argument. -- Function: PROF (x y) Package:SI These functions in the SI package are GCL specific, and allow monitoring the run time of functions loaded into GCL, as well as the basic functions. Sample Usage: (si::set-up-profile 1000000) (si::prof 0 90) run program (si::prof 0 0) ;; turn off profile (si::display-prof) (si::clear-profile) (si::prof 0 90) ;; start profile again run program .. Profile can be stopped with (si::prof 0 0) and restarted with (si::prof 0 90) The START-ADDRESS will correspond to the beginning of the profile array, and the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the profile array. Thus if the profile array is 1,000,000 bytes long and the code segment is 5 megabytes long you can profile the whole thing using a scale of 50 Note that long runs may result in overflow, and so an understating of the time in a function. You must run intensively however since, with a scale of 128 it takes 6,000,000 times through a loop to overflow the sampling in one part of the code. -- Function: CATCH-FATAL (i) Package:SI Sets the value of the C variable catch_fatal to I which should be an integer. If catch_fatal is 1, then most unrecoverable fatal errors will be caught. Upon catching such an error catch_fatal becomes -1, to avoid recursive errors. The top level loop automatically sets catch_fatal to 1, if the value is less than zero. Catching can be turned off by making catch_fatal = 0. -- Variable: *MULTIPLY-STACKS* Package:SI If this variable is set to a positive fixnum, then the next time through the TOP-LEVEL loop, the loop will be exited. The size of the stacks will be multiplied by the value of *multiply-stacks*, and the TOP-LEVEL will be called again. Thus to double the size of the stacks: >(setq si::*multiply-stacks* 2) [exits top level and reinvokes it, with the new stacks in place] > We must exit TOP-LEVEL, because it and any other lisp functions maintain many pointers into the stacks, which would be incorrect when the stacks have been moved. Interrupting the process of growing the stacks, can leave you in an inconsistent state. -- Function: GBC-TIME (&optional x) Package:SI Sets the internal C variable gc_time to X if X is supplied and then returns gc_time. If gc_time is greater or equal to 0, then gc_time is incremented by the garbage collector, according to the number of internal time units spent there. The initial value of gc_time is -1. -- Function: FWRITE (string start count stream) Package:SI Write from STRING starting at char START (or 0 if it is nil) COUNT characters (or to end if COUNT is nil) to STREAM. STREAM must be a stream such as returned by FP-OUTPUT-STREAM. Returns nil if it fails. -- Function: FREAD (string start count stream) Package:SI Read characters into STRING starting at char START (or 0 if it is nil) COUNT characters (or from start to length of STRING if COUNT is nil). Characters are read from STREAM. STREAM must be a stream such as returned by FP-INPUT-STREAM. Returns nil if it fails. Return number of characters read if it succeeds. -- Function: SGC-ON (&optional ON) Package:SI If ON is not nil then SGC (stratified garbage collection) is turned on. If ON is supplied and is nil, then SGC is turned off. If ON is not supplied, then it returns T if SGC is on, and NIL if SGC is off. The purpose of SGC is to prevent paging activity during garbage collection. It is efficient if the actual number of pages being written to form a small percentage of the total image size. The image should be built as compactly as possible. This can be accomplished by using a settings such as (si::allocate-growth 'cons 1 10 50 20) to limit the growth in the cons maxpage to 10 pages per time. Then just before calling si::save-system to save your image you can do something like: (si::set-hole-size 500)(gbc nil) (si::sgc-on t) (si::save-system ..) This makes the saved image come up with SGC on. We have set a reasonably large hole size. This is so that allocation of pages either because they fill up, or through specific calls to si::allocate, will not need to move all the relocatable data. Moving relocatable data requires turning SGC off, performing a full gc, and then turning it back on. New relocatable data is collected by SGC, but moving the old requires going through all pages of memory to change pointers into it. Using si::*notify-gbc* gives information about the number of pages used by SGC. Note that SGC is only available on operating systems which provide the mprotect system call, to write protect pages. Otherwise we cannot tell which pages have been written too. -- Function: ALLOCATE-SGC (type min-pages max-pages percent-free) Package:SI If MIN-PAGES is 0, then this type will not be swept by SGC. Otherwise this is the minimum number of pages to make available to SGC. MAX-PAGES is the upper limit of such pages. Only pages with PERCENT-FREE objects on them, will be assigned to SGC. A list of the previous values for min, max and percent are returned. -- Function: ALLOCATE-GROWTH (type min max percent percent-free) Package:SI The next time after a garbage collection for TYPE, if PERCENT-FREE of the objects of this TYPE are not actually free, and if the maximum number of pages for this type has already been allocated, then the maximum number will be increased by PERCENT of the old maximum, subject to the condition that this increment be at least MIN pages and at most MAX pages. A list of the previous values for min, max, percent, and percent-free for the type TYPE is returned. A value of 0 means use the system default, and if an argument is out of range then the current values are returned with no change made. Examples: (si::allocate-growth 'cons 1 10 50 10) would insist that after a garbage collection for cons, there be at least 10% cons's free. If not the number of cons pages would be grown by 50% or 10 pages which ever was smaller. This might be reasonable if you were trying to build an image which was 'full', ie had few free objects of this type. (si::allocate-growth 'fixnum 0 10000 30 40) would grow space till there were normally 40% free fixnums, usually growing by 30% per time. (si::allocate-growth 'cons 0 0 0 40) would require 40% free conses after garbage collection for conses, and would use system defaults for the the rate to grow towards this goal. (si::allocate-growth 'cons -1 0 0 0) would return the current values, but not make any changes. -- Function: OPEN-FASD (stream direction eof-value table) Package:SI Given file STREAM open for input or output in DIRECTION, set it up to start writing or reading in fasd format. When reading from this stream the EOF-VALUE will be returned when the end a fasd end of dump marker is encountered. TABLE should be an eq hashtable on output, a vector on input, or nil. In this last case a default one will be constructed. We shall refer to the result as a 'fasd stream'. It is suitable as the arg to CLOSE-FASD, READ-FASD-TOP, and as the second second arg to WRITE-FASD. As a lisp object it is actually a vector, whose body coincides with: struct fasd { object stream; /* lisp object of type stream */ object table; /* hash table used in dumping or vector on input*/ object eof; /* lisp object to be returned on coming to eof mark */ object direction; /* holds Cnil or Kinput or Koutput */ object package; /* the package symbols are in by default */ object index; /* integer. The current_dump index on write */ object filepos; /* nil or the position of the start */ object table_length; /* On read it is set to the size dump array needed or 0 */ object macro ; } We did not use a defstruct for this, because we want the compiler to use this and it makes bootstrapping more difficult. It is in "cmpnew/fasdmacros.lsp" -- Function: WRITE-FASD-TOP (X FASD-STREAM) Package:SI Write X to FASD-STREAM. -- Function: READ-FASD-TOP (FASD-STREAM) Package:SI Read the next object from FASD-STREAM. Return the eof-value of FASD-STREAM if we encounter an eof marker put out by CLOSE-FASD. Encountering end of actual file stream causes an error. -- Function: CLOSE-FASD (FASD-STREAM) Package:SI On output write an eof marker to the associated file stream, and then make FASD-STREAM invalid for further output. It also attempts to write information to the stream on the size of the index table needed to read from the stream from the last open. This is useful in growing the array. It does not alter the file stream, other than for writing this information to it. The file stream may be reopened for further use. It is an error to OPEN-FASD the same file or file stream again with out first calling CLOSE-FASD. -- Function: FIND-SHARING-TOP (x table) Package:SI X is any lisp object and TABLE is an eq hash table. This walks through X making entries to indicate the frequency of symbols,lists, and arrays. Initially items get -1 when they are first met, and this is decremented by 1 each time the object occurs. Call this function on all the objects in a fasd file, which you wish to share structure. -- Variable: *LOAD-PATHNAME* Package:SI Load binds this to the pathname of the file being loaded. -- Macro: DEFINE-INLINE-FUNCTION (fname vars &body body) Package:SI This is equivalent to defun except that VARS may not contain &optional, &rest, &key or &aux. Also a compiler property is added, which essentially saves the body and turns this into a let of the VARS and then execution of the body. This last is done using si::DEFINE-COMPILER-MACRO Example: (si::define-inline-function myplus (a b c) (+ a b c)) -- Macro: DEFINE-COMPILER-MACRO (fname vars &body body) Package:SI FNAME may be the name of a function, but at compile time the macro expansion given by this is used. (si::define-compiler-macro mycar (a) '(car ,a)) -- Function: DBL () Package:SI Invoke a top level loop, in which debug commands may be entered. These commands may also be entered at breaks, or in the error handler. See SOURCE-LEVEL-DEBUG -- Function: NLOAD (file) Package:SI Load a file with the readtable bound to a special readtable, which permits tracking of source line information as the file is loaded. see SOURCE-LEVEL-DEBUG -- Function: BREAK-FUNCTION (function &optional line absolute) Package:SI Set a breakpoint for a FUNCTION at LINE if the function has source information loaded. If ABSOLUTE is not nil, then the line is understood to be relative to the beginning of the buffer. See also dbl-break-function, the emacs command. -- Function: XDR-OPEN (stream) Package:SI Returns an object suitable for passing to XDR-READ if the stream is an input stream, and XDR-WRITE if it was an output stream. Note the stream must be a unix stream, on which si::fp-input-stream or si::fp-output-stream would act as the identity. -- Function: FP-INPUT-STREAM (stream) Package:SI Return a unix stream for input associated to STREAM if possible, otherwise return nil. -- Function: FP-OUTPUT-STREAM (stream) Package:SI Return a unix stream for output associated to STREAM if possible, otherwise return nil. -- Function: XDR-READ (stream element) Package:SI Read one item from STREAM of type the type of ELEMENT. The representation of the elements is machine independent. The xdr routines are what is used by the basic unix rpc calls. -- Function: XDR-WRITE (stream element) Package:SI Write to STREAM the given ELEMENT. -- Variable: *TOP-LEVEL-HOOK* Package:SI If this variable is has a function as its value at start up time, then it is run immediately after the init.lsp file is loaded. This is useful for starting up an alternate top level loop. -- Function: RUN-PROCESS (string arglist) Package:SI Execute the command STRING in a subshell passing the strings in the list ARGLIST as arguments to the command. Return a two way stream associated to this. Use si::fp-output-stream to get an associated output stream or si::fp-input-stream. Bugs: It does not properly deallocate everything, so that it will fail if you call it too many times. -- Variable: *CASE-FOLD-SEARCH* Package: SI Non nil means that a string-match should ignore case -- Function: STRING-MATCH (pattern string &optional start end) Package: SI Match regexp PATTERN in STRING starting in string starting at START and ending at END. Return -1 if match not found, otherwise return the start index of the first matchs. The variable *MATCH-DATA* will be set to a fixnum array of sufficient size to hold the matches, to be obtained with match-beginning and match-end. If it already contains such an array, then the contents of it will be over written. The form of a regexp pattern is discussed in *Note Regular Expressions::. -- Function: MATCH-BEGINNING (index) Returns the beginning of the I'th match from the previous STRING-MATCH, where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* vector is not a fixnum array. -- Function: MATCH-END (index) Returns the end of the I'th match from the previous STRING-MATCH -- Function: SOCKET (port &key host server async myaddr myport daemon) Establishes a socket connection to the specified PORT under a variety of circumstances. If HOST is specified, then it is a string designating the IP address of the server to which we are the client. ASYNC specifies that the connection should be made asynchronously, and the call return immediately. MYADDR and MYPORT can specify the IP address and port respectively of a client connection, for example when the running machine has several network interfaces. If SERVER is specified, then it is a function which will handle incoming connections to this PORT. DAEMON specifies that the running process should be forked to handle incoming connections in the background. If DAEMON is set to the keyword PERSISTENT, then the backgrounded process will survive when the parent process exits, and the SOCKET call returns NIL. Any other non-NIL setting of DAEMON causes the socket call to return the process id of the backgrounded process. DAEMON currently only works on BSD and Linux based systems. If DAEMON is not set or nil, or if the socket is not a SERVER socket, then the SOCKET call returns a two way stream. In this case, the running process is responsible for all I/O operations on the stream. Specifically, if a SERVER socket is created as a non-DAEMON, then the running process must LISTEN for connections, ACCEPT them when present, and call the SERVER function on the stream returned by ACCEPT. -- Function: ACCEPT (stream) Creates a new two-way stream to handle an individual incoming connection to STREAM, which must have been created with the SOCKET function with the SERVER keyword set. ACCEPT should only be invoked when LISTEN on STREAM returns T. If the STREAM was created with the DAEMON keyword set in the call to SOCKET, ACCEPT is unnecessary and will be called automatically as needed. * Menu: * Regular Expressions::  File: gcl-si.info, Node: Regular Expressions, Prev: System Definitions, Up: System Definitions 17.1 Regular Expressions ======================== The function 'string-match' (*Index string-match::) is used to match a regular expression against a string. If the variable '*case-fold-search*' is not nil, case is ignored in the match. To determine the extent of the match use *Index match-beginning:: and *Index match-end::. Regular expressions are implemented using Henry Spencer's package (thank you Henry!), and much of the description of regular expressions below is copied verbatim from his manual entry. Code for delimited searches, case insensitive searches, and speedups to allow fast searching of long files was contributed by W. Schelter. The speedups use an adaptation by Schelter of the Boyer and Moore string search algorithm to the case of branched regular expressions. These allow such expressions as 'not_there|really_not' to be searched for 30 times faster than in GNU emacs (1995), and 200 times faster than in the original Spencer method. Expressions such as [a-u]bcdex get a speedup of 60 and 194 times respectively. This is based on searching a string of 50000 characters (such as the file tk.lisp). * A regular expression is a string containing zero or more branches which are separated by '|'. A match of the regular expression against a string is simply a match of the string with one of the branches. * Each branch consists of zero or more pieces, concatenated. A matching string must contain an initial substring matching the first piece, immediately followed by a second substring matching the second piece and so on. * Each piece is an atom optionally followed by '+', '*', or '?'. * An atom followed by '+' matches a sequence of 1 or more matches of the atom. * An atom followed by '*' matches a sequence of 0 or more matches of the atom. * An atom followed by '?' matches a match of the atom, or the null string. * An atom is - a regular expression in parentheses matching a match for the regular expression - a range see below - a '.' matching any single character - a '^' matching the null string at the beginning of the input string - a '$' matching the null string at the end of the input string - a '\' followed by a single character matching that character - a single character with no other significance (matching that character). * A range is a sequence of characters enclosed in '[]'. It normally matches any single character from the sequence. - If the sequence begins with '^', it matches any single character not from the rest of the sequence. - If two characters in the sequence are separated by '-', this is shorthand for the full list of ASCII characters between them (e.g. '[0-9]' matches any decimal digit). - To include a literal ']' in the sequence, make it the first character (following a possible '^'). - To include a literal '-', make it the first or last character. Ordering Multiple Matches ------------------------- In general there may be more than one way to match a regular expression to an input string. For example, consider the command (string-match "(a*)b*" "aabaaabb") Considering only the rules given so far, the value of (list-matches 0 1) might be '("aabb" "aa")' or '("aaab" "aaa")' or '("ab" "a")' or any of several other combinations. To resolve this potential ambiguity string-match chooses among alternatives using the rule first then longest. In other words, it considers the possible matches in order working from left to right across the input string and the pattern, and it attempts to match longer pieces of the input string before shorter ones. More specifically, the following rules apply in decreasing order of priority: [1] If a regular expression could match two different parts of an input string then it will match the one that begins earliest. [2] If a regular expression contains | operators then the leftmost matching sub-expression is chosen. [3] In *, +, and ? constructs, longer matches are chosen in preference to shorter ones. [4] In sequences of expression components the components are considered from left to right. In the example from above, (a*)b* matches aab: the (a*) portion of the pattern is matched first and it consumes the leading aa; then the b* portion of the pattern consumes the next b. Or, consider the following example: (string-match "(ab|a)(b*)c" "xabc") ==> 1 (list-matches 0 1 2 3) ==> ("abc" "ab" "" NIL) (match-beginning 0) ==> 1 (match-end 0) ==> 4 (match-beginning 1) ==> 1 (match-end 1) ==> 3 (match-beginning 2) ==> 3 (match-end 2) ==> 3 (match-beginning 3) ==> -1 (match-end 3) ==> -1 In the above example the return value of '1' (which is '> -1') indicates that a match was found. The entire match runs from 1 to 4. Rule 4 specifies that (ab|a) gets first shot at the input string and Rule 2 specifies that the ab sub-expression is checked before the a sub-expression. Thus the b has already been claimed before the (b*) component is checked and (b*) must match an empty string. The special characters in the string '"\()[]+.*|^$?"', must be quoted, if a simple string search is desired. The function re-quote-string is provided for this purpose. (re-quote-string "*standard*") ==> "\\*standard\\*" (string-match (re-quote-string "*standard*") "X *standard* ") ==> 2 (string-match "*standard*" "X *standard* ") Error: Regexp Error: ?+* follows nothing Note there is actually just one '\' before the '*' but the printer makes two so that the string can be read, since '\' is also the lisp quote character. In the last example an error is signalled since the special character '*' must follow an atom if it is interpreted as a regular expression.  File: gcl-si.info, Node: Debugging, Next: Miscellaneous, Prev: System Definitions, Up: Top 18 Debugging ************ * Menu: * Source Level Debugging in Emacs:: * Low Level Debug Functions::  File: gcl-si.info, Node: Source Level Debugging in Emacs, Next: Low Level Debug Functions, Prev: Debugging, Up: Debugging 18.1 Source Level Debugging in Emacs ==================================== In emacs load (load "dbl.el") from the gcl/doc directory. [ It also requires gcl.el from that directory. Your system administrator should do make in the doc directory, so that these files are copied to the standard location.] OVERVIEW: Lisp files loaded with si::nload will have source line information about them recorded. Break points may be set, and functions stepped. Source code will be automatically displayed in the other window, with a little arrow beside the current line. The backtrace (command :bt) will show line information and you will get automatic display of the source as you move up and down the stack. FUNCTIONS: break points which have been set. si::nload (file) load a lisp file collecting source line information. si::break-function (function &optional line absolute) set up a breakpoint for FUNCTION at LINE relative to start or ABSOLUTE EMACS COMMANDS: M-x dbl makes a dbl buffer, suitable for running an inferior gcl. It has special keybindings for stepping and viewing sources. You may start your favorite gcl program in the dbl shell buffer. Inferior Dbl Mode: Major mode for interacting with an inferior Dbl process. The following commands are available: C-c l dbl-find-line ESC d dbl-:down ESC u dbl-:up ESC c dbl-:r ESC n dbl-:next ESC i dbl-:step ESC s dbl-:step M-x dbl-display-frame displays in the other window the last line referred to in the dbl buffer. ESC i and ESC n in the dbl window, call dbl to step and next and then update the other window with the current file and position. If you are in a source file, you may select a point to break at, by doing C-x SPC. Commands: Many commands are inherited from shell mode. Additionally we have: M-x dbl-display-frame display frames file in other window ESC i advance one line in program ESC n advance one line in program (skip over calls). M-x send-dbl-command used for special printing of an arg at the current point. C-x SPACE sets break point at current line. ------------------- When visiting a lisp buffer (if gcl.el is loaded in your emacs) the command c-m-x evaluates the current defun into the process running in the other window. Line information will be kept. This line information allows you to set break points at a given line (by typing C-x \space on the line in the source file where you want the break to occur. Once stopped within a function you may single step with M-s. This moves one line at a time in the source code, displaying a little arrow beside your current position. M-c is like M-s, except that function invocations are skipped over, rather than entered into. M-c continues execution. Keywords typed at top level, in the debug loop have a special meaning: :delete [n1] [n2] .. - delete all break points or just n1,n2 :disable [n1] [n2] .. - disable all break points or just n1,n2 :enable [n1] [n2] .. - enable all break points or just n1,n2 :info [:bkpt] -print information about :break [fun] [line] - break at the current location, or if fun is supplied in fun. Break at the beginning unless a line offset from the beginning of fun is supplied. :fr [n] go to frame n When in frame n, if the frame is interpreted, typing the name of locals, will print their values. If it is compiled you must use (si::loc j) to print 'locj'. Autodisplay of the source will take place if it is interpreted and the line can be determined. :up [n] go up n frames from the current frame. :down [n] go down n frames :bt [n] back trace starting at the current frame and going to top level If n is specified show only n frames. :r If stopped in a function resume. If at top level in the dbl loop, exit and resume an outer loop. :q quit the computation back to top level dbl loop. :step step to the next line with line information :next step to the next line with line information skipping over function invocations. Files: debug.lsp dbl.el gcl.el  File: gcl-si.info, Node: Low Level Debug Functions, Prev: Source Level Debugging in Emacs, Up: Debugging 18.2 Low Level Debug Functions ============================== Use the following functions to directly access GCL stacks. (SI:VS i) Returns the i-th entity in VS. (SI:IHS-VS i) Returns the VS index of the i-th entity in IHS. (SI:IHS-FUN i) Returns the function of the i-th entity in IHS. (SI:FRS-VS i) Returns the VS index of the i-th entity in FRS. (SI:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. (SI:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. (SI:BDS-VAR i) Returns the symbol of the i-th entity in BDS. (SI:BDS-VAL i) Returns the value of the i-th entity in BDS. (SI:SUPER-GO i tag) Jumps to the specified tag established by the TAGBODY frame at FRS[i]. Both arguments are evaluated. If FRS[i] happens to be a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is performed.  File: gcl-si.info, Node: Miscellaneous, Next: Compiler Definitions, Prev: Debugging, Up: Top 19 Miscellaneous **************** * Menu: * Environment:: * Inititialization:: * Low Level X Interface::  File: gcl-si.info, Node: Environment, Next: Inititialization, Prev: Miscellaneous, Up: Miscellaneous 19.1 Environment ================ The environment in GCL which is passed to macroexpand and other functions requesting an environment, should be a list of 3 lists. The first list looks like ((v1 val1) (v2 val2) ..) where vi are variables and vali are their values. The second is a list of ((fname1 . fbody1) (fname2 . fbody2) ...) where fbody1 is either (macro lambda-list lambda-body) or (lambda-list lambda-body) depending on whether this is a macro or a function. The third list contains tags and blocks.  File: gcl-si.info, Node: Inititialization, Next: Low Level X Interface, Prev: Environment, Up: Miscellaneous 19.2 Initialization =================== If the file init.lsp exists in the current directory, it is loaded at startup. The first argument passed to the executable image should be the system directory. Normally this would be gcl/unixport. This directory is stored in the si::*system-directory* variable. If the file sys-init.lsp exists in the system directory, it is loaded before init.lsp. See also si::*TOP-LEVEL-HOOK*.  File: gcl-si.info, Node: Low Level X Interface, Prev: Inititialization, Up: Miscellaneous 19.3 Low Level X Interface ========================== A sample program for drawing things on X windows from lisp is included in the file gcl/lsp/littleXlsp.lsp That routine invokes the corresponding C routines in XLIB. So in order to use it you must 'faslink' in the X routines. Directions are given at the beginning of the lisp file, for either building them into the image or using faslink. This program is also a good tutorial on invoking C from lisp. See also defentry and faslink.  File: gcl-si.info, Node: Compiler Definitions, Next: Function and Variable Index, Prev: Miscellaneous, Up: Top 20 Compiler Definitions *********************** -- Function: EMIT-FN (turn-on) Package:COMPILER If TURN-ON is t, the subsequent calls to COMPILE-FILE will cause compilation of foo.lisp to emit a foo.fn as well as foo.o. The .fn file contains cross referencing information as well as information useful to the collection utilities in cmpnew/collectfn This latter file must be manually loaded to call emit-fn. -- Variable: *CMPINCLUDE-STRING* Package:COMPILER If it is a string it holds the text of the cmpinclude.h file appropriate for this version. Otherwise the usual #include of *cmpinclude* will be used. To disable this feature set *cmpinclude-string* to NIL in the init-form. -- Function: EMIT-FN (turn-on) Package:COMPILER If TURN-ON is t, then subsequent calls to compile-file on a file foo.lisp cause output of a file foo.fn. This .fn file contains lisp structures describing the functions in foo.lisp. Some tools for analyzing this data base are WHO-CALLS, LIST-UNDEFINED-FUNCTIONS, LIST-UNCALLED-FUNCTIONS, and MAKE-PROCLAIMS. Usage: (compiler::emit-fn t) (compile-file "foo1.lisp") (compile-file "foo2.lisp") This would create foo1.fn and foo2.fn. These may be loaded using LOAD. Each time compile-file is called the data base is cleared. Immediately after the compilation, the data base consists of data from the compilation. Thus if you wished to find functions called but not defined in the current file, you could do (list-undefined-functions), immediately following the compilation. If you have a large system, you would load all the .fn files before using the above tools. -- Function: MAKE-ALL-PROCLAIMS (&rest directories) Package:COMPILER For each D in DIRECTORIES all files in (directory D) are loaded. For example (make-all-proclaims "lsp/*.fn" "cmpnew/*.fn") would load any files in lsp/*.fn and cmpnew/*.fn. [See EMIT-FN for details on creation of .fn files] Then calculations on the newly loaded .fn files are made, to determine function proclamations. If number of values of a function cannot be determined [for example because of a final funcall, or call of a function totally unknown at this time] then return type * is assigned. Finally a file sys-proclaim.lisp is written out. This file contains function proclamations. (load "sys-proclaim.lisp") (compile-file "foo1.lisp") (compile-file "foo2.lisp") -- Function: MAKE-PROCLAIMS (&optional (stream *standard-output*)) Package:COMPILER Write to STREAM the function proclaims from the current data base. Usually a number of .fn files are loaded prior to running this. See EMIT-FN for details on how to collect this. Simply use LOAD to load in .fn files. -- Function: LIST-UNDEFINED-FUNCTIONS () Package:COMPILER Return a list of all functions called but not defined, in the current data base (see EMIT-FN). Sample: (compiler::emit-fn t) (compile-file "foo1.lisp") (compiler::list-undefined-functions) or (mapcar 'load (directory "*.fn")) (compiler::list-undefined-functions) -- Function: WHO-CALLS (function-name) Package:COMPILER List all functions in the data base [see emit-fn] which call FUNCTION-NAME. -- Function: LIST-UNCALLED-FUNCTIONS () Package:COMPILER Examine the current data base [see emit-fn] for any functions or macros which are called but are not: fboundp, OR defined in the data base, OR having special compiler optimizer properties which would eliminate an actual call. -- Variable: *CC* Package:COMPILER Has value a string which controls which C compiler is used by GCL. Usually this string is obtained from the machine.defs file, but may be reset by the user, to change compilers or add an include path. -- Variable: *SPLIT-FILES* Package:COMPILER This affects the behaviour of compile-file, and is useful for cases where the C compiler cannot handle large C files resulting from lisp compilation. This scheme should allow arbitrarily long lisp files to be compiled. If the value [default NIL] is a positive integer, then the source file will be compiled into several object files whose names have 0,1,2,.. prepended, and which will be loaded by the main object file. File 0 will contain compilation of top level forms thru position *split-files* in the lisp source file, and file 1 the next forms, etc. Thus a 180k file would probably result in three object files (plus the master object file of the same name) if *split-files* was set to 60000. The package information will be inserted in each file. -- Variable: *COMPILE-ORDINARIES* Package:COMPILER If this has a non nil value [default = nil], then all top level forms will be compiled into machine instructions. Otherwise only defun's, defmacro's, and top level forms beginning with (progn 'compile ...) will do so.  File: gcl-si.info, Node: Function and Variable Index, Prev: Compiler Definitions, Up: Top Appendix A Function and Variable Index ************************************** [index] * Menu: * *: Numbers. (line 557) * * <1>: User Interface. (line 107) * **: User Interface. (line 74) * ***: User Interface. (line 25) * *AFTER-GBC-HOOK*: System Definitions. (line 254) * *APPLYHOOK*: Special Forms and Functions. (line 613) * *BREAK-ENABLE*: User Interface. (line 44) * *BREAK-ON-WARNINGS*: User Interface. (line 64) * *CASE-FOLD-SEARCH*: System Definitions. (line 733) * *CC*: Compiler Definitions. (line 101) * *CMPINCLUDE-STRING*: Compiler Definitions. (line 15) * *COMPILE-ORDINARIES*: Compiler Definitions. (line 123) * *DEBUG-IO*: User Interface. (line 61) * *DEFAULT-C-FILE*: Compilation. (line 239) * *DEFAULT-DATA-FILE*: Compilation. (line 247) * *DEFAULT-H-FILE*: Compilation. (line 243) * *DEFAULT-PATHNAME-DEFAULTS*: Operating System Definitions. (line 157) * *DEFAULT-SYSTEM-P*: Compilation. (line 235) * *DEFAULT-TIME-ZONE*: System Definitions. (line 365) * *ERROR-OUTPUT*: User Interface. (line 98) * *EVALHOOK*: Special Forms and Functions. (line 239) * *FEATURES*: Compilation. (line 251) * *GBC-MESSAGE*: System Definitions. (line 244) * *GBC-NOTIFY*: System Definitions. (line 249) * *IGNORE-EOF-ON-TERMINAL-IO*: System Definitions. (line 292) * *IGNORE-MAXIMUM-PAGES*: GCL Specific. (line 19) * *INDENT-FORMATTED-OUTPUT*: System Definitions. (line 164) * *info-paths*: Doc. (line 61) * *INTERRUPT-ENABLE*: System Definitions. (line 139) * *LISP-MAXPAGES*: System Definitions. (line 307) * *LOAD-PATHNAME*: System Definitions. (line 640) * *LOAD-VERBOSE*: Streams and Reading. (line 595) * *MACROEXPAND-HOOK*: Special Forms and Functions. (line 367) * *MAKE-CONSTANT: System Definitions. (line 186) * *MAKE-SPECIAL: System Definitions. (line 281) * *MODULES*: Operating System Definitions. (line 57) * *MULTIPLY-STACKS*: System Definitions. (line 458) * *NOTIFY-GBC*: System Definitions. (line 326) * *OPTIMIZE-MAXIMUM-PAGES*: GCL Specific. (line 24) * *PACKAGE*: Symbols. (line 33) * *PRINT-ARRAY*: Streams and Reading. (line 131) * *PRINT-BASE*: Streams and Reading. (line 44) * *PRINT-CASE*: Streams and Reading. (line 107) * *PRINT-CIRCLE*: Streams and Reading. (line 598) * *PRINT-ESCAPE*: Streams and Reading. (line 443) * *PRINT-GENSYM*: Streams and Reading. (line 314) * *PRINT-LENGTH*: Streams and Reading. (line 399) * *PRINT-LEVEL*: Streams and Reading. (line 216) * *PRINT-PRETTY*: Streams and Reading. (line 602) * *PRINT-RADIX*: Streams and Reading. (line 220) * *QUERY-IO*: Streams and Reading. (line 258) * *RANDOM-STATE*: Numbers. (line 205) * *READ-BASE*: Streams and Reading. (line 261) * *READ-DEFAULT-FLOAT-FORMAT*: Streams and Reading. (line 66) * *READ-SUPPRESS*: Streams and Reading. (line 465) * *READLINE-PREFIX*: Streams and Reading. (line 711) * *READTABLE*: Streams and Reading. (line 13) * *SPLIT-FILES*: Compiler Definitions. (line 107) * *STANDARD-INPUT*: Streams and Reading. (line 640) * *STANDARD-OUTPUT*: Streams and Reading. (line 434) * *SYSTEM-DIRECTORY*: System Definitions. (line 208) * *TERMINAL-IO*: Streams and Reading. (line 287) * *TMP-DIR*: GCL Specific. (line 15) * *TOP-LEVEL-HOOK*: System Definitions. (line 716) * *TRACE-OUTPUT*: User Interface. (line 91) * +: Numbers. (line 658) * + <1>: User Interface. (line 128) * ++: User Interface. (line 94) * +++: User Interface. (line 78) * -: User Interface. (line 6) * - <1>: User Interface. (line 10) * -batch: Command Line. (line 61) * -c-file: Command Line. (line 80) * -compile: Command Line. (line 75) * -data-file: Command Line. (line 84) * -dir: Command Line. (line 66) * -eval: Command Line. (line 10) * -f: Command Line. (line 14) * -h-file: Command Line. (line 82) * -libdir: Command Line. (line 70) * -load: Command Line. (line 12) * -o-file: Command Line. (line 78) * -system-p: Command Line. (line 87) * /: Numbers. (line 199) * / <1>: User Interface. (line 48) * //: User Interface. (line 87) * ///: User Interface. (line 110) * /=: Numbers. (line 72) * 1+: Numbers. (line 208) * 1-: Numbers. (line 411) * <: Numbers. (line 562) * <=: Numbers. (line 416) * =: Numbers. (line 663) * >: Numbers. (line 743) * >=: Numbers. (line 594) * ABS: Numbers. (line 707) * ACCEPT: System Definitions. (line 788) * ACONS: Lists. (line 254) * ACOS: Numbers. (line 603) * ACOSH: Numbers. (line 631) * ADDRESS: System Definitions. (line 299) * ADJOIN: Lists. (line 383) * ADJUST-ARRAY: Sequences and Arrays and Hash Tables. (line 549) * ADJUSTABLE-ARRAY-P: Sequences and Arrays and Hash Tables. (line 250) * ALLOCATE: GCL Specific. (line 102) * ALLOCATE-CONTIGUOUS-PAGES: System Definitions. (line 6) * ALLOCATE-GROWTH: System Definitions. (line 546) * ALLOCATE-RELOCATABLE-PAGES: System Definitions. (line 44) * ALLOCATE-SGC: System Definitions. (line 537) * ALLOCATED: System Definitions. (line 259) * ALLOCATED-CONTIGUOUS-PAGES: System Definitions. (line 50) * ALLOCATED-PAGES: System Definitions. (line 38) * ALLOCATED-RELOCATABLE-PAGES: System Definitions. (line 27) * ALPHA-CHAR-P: Characters. (line 151) * ALPHANUMERICP: Characters. (line 230) * AND: Special Forms and Functions. (line 441) * APPEND: Lists. (line 585) * APPLY: Special Forms and Functions. (line 401) * APPLYHOOK: Special Forms and Functions. (line 359) * APROPOS: Doc. (line 6) * APROPOS-LIST: Symbols. (line 315) * AREF: Sequences and Arrays and Hash Tables. (line 634) * ARGC: System Definitions. (line 312) * ARGV: System Definitions. (line 359) * ARRAY-DIMENSION: Sequences and Arrays and Hash Tables. (line 108) * ARRAY-DIMENSION-LIMIT: Sequences and Arrays and Hash Tables. (line 595) * ARRAY-DIMENSIONS: Sequences and Arrays and Hash Tables. (line 236) * ARRAY-ELEMENT-TYPE: Sequences and Arrays and Hash Tables. (line 484) * ARRAY-HAS-FILL-POINTER-P: Sequences and Arrays and Hash Tables. (line 459) * ARRAY-IN-BOUNDS-P: Sequences and Arrays and Hash Tables. (line 367) * ARRAY-RANK: Sequences and Arrays and Hash Tables. (line 29) * ARRAY-RANK-LIMIT: Sequences and Arrays and Hash Tables. (line 526) * ARRAY-ROW-MAJOR-INDEX: Sequences and Arrays and Hash Tables. (line 102) * ARRAY-TOTAL-SIZE: Sequences and Arrays and Hash Tables. (line 690) * ARRAY-TOTAL-SIZE-LIMIT: Sequences and Arrays and Hash Tables. (line 440) * ARRAYP: Sequences and Arrays and Hash Tables. (line 391) * ASH: Numbers. (line 432) * ASIN: Numbers. (line 246) * ASINH: Numbers. (line 257) * ASSERT: Type. (line 48) * ASSOC: Lists. (line 579) * ASSOC-IF: Lists. (line 536) * ASSOC-IF-NOT: Lists. (line 444) * ATAN: Numbers. (line 456) * ATANH: Numbers. (line 471) * ATOM: Lists. (line 559) * BDS-VAL: System Definitions. (line 196) * BDS-VAR: System Definitions. (line 91) * BIT: Sequences and Arrays and Hash Tables. (line 618) * BIT-AND: Numbers. (line 284) * BIT-ANDC1: Numbers. (line 224) * BIT-ANDC2: Numbers. (line 314) * BIT-EQV: Sequences and Arrays and Hash Tables. (line 65) * BIT-IOR: Sequences and Arrays and Hash Tables. (line 651) * BIT-NAND: Numbers. (line 49) * BIT-NOR: Numbers. (line 393) * BIT-NOT: Sequences and Arrays and Hash Tables. (line 495) * BIT-ORC1: Sequences and Arrays and Hash Tables. (line 503) * BIT-ORC2: Sequences and Arrays and Hash Tables. (line 580) * BIT-VECTOR-P: Sequences and Arrays and Hash Tables. (line 536) * BIT-XOR: Sequences and Arrays and Hash Tables. (line 403) * BLOCK: Special Forms and Functions. (line 382) * BOOLE: Numbers. (line 135) * BOOLE-1: Numbers. (line 493) * BOOLE-2: Numbers. (line 554) * BOOLE-AND: Numbers. (line 512) * BOOLE-ANDC1: Numbers. (line 459) * BOOLE-ANDC2: Numbers. (line 526) * BOOLE-C1: Numbers. (line 43) * BOOLE-C2: Numbers. (line 155) * BOOLE-CLR: Numbers. (line 163) * BOOLE-EQV: Numbers. (line 329) * BOOLE-IOR: Numbers. (line 166) * BOOLE-NAND: Numbers. (line 238) * BOOLE-NOR: Numbers. (line 600) * BOOLE-ORC1: Numbers. (line 784) * BOOLE-ORC2: Numbers. (line 102) * BOOLE-SET: Numbers. (line 332) * BOOLE-XOR: Numbers. (line 698) * BOTH-CASE-P: Characters. (line 20) * BOUNDP: Symbols. (line 230) * BREAK: User Interface. (line 120) * BREAK-FUNCTION: System Definitions. (line 676) * BREAK-ON-FLOATING-POINT-EXCEPTIONS: Operating System Definitions. (line 207) * BUTLAST: Lists. (line 281) * BY: GCL Specific. (line 39) * BYE: GCL Specific. (line 213) * BYTE: Numbers. (line 251) * BYTE-POSITION: Numbers. (line 298) * BYTE-SIZE: Numbers. (line 341) * CAAAAR: Lists. (line 293) * CAAADR: Lists. (line 497) * CAAAR: Lists. (line 200) * CAADAR: Lists. (line 492) * CAADDR: Lists. (line 158) * CAADR: Lists. (line 367) * CAAR: Lists. (line 30) * CADAAR: Lists. (line 487) * CADADR: Lists. (line 153) * CADAR: Lists. (line 362) * CADDAR: Lists. (line 148) * CADDDR: Lists. (line 313) * CADDR: Lists. (line 574) * CADR: Lists. (line 237) * CALL-ARGUMENTS-LIMIT: Special Forms and Functions. (line 514) * CAR: Lists. (line 460) * CASE: Special Forms and Functions. (line 519) * CATCH: Special Forms and Functions. (line 478) * CATCH-BAD-SIGNALS: System Definitions. (line 225) * CATCH-FATAL: System Definitions. (line 448) * CCASE: Special Forms and Functions. (line 53) * CDAAAR: Lists. (line 482) * CDAADR: Lists. (line 143) * CDAAR: Lists. (line 357) * CDADAR: Lists. (line 138) * CDADDR: Lists. (line 308) * CDADR: Lists. (line 569) * CDAR: Lists. (line 232) * CDDAAR: Lists. (line 133) * CDDADR: Lists. (line 303) * CDDAR: Lists. (line 564) * CDDDAR: Lists. (line 298) * CDDDDR: Lists. (line 502) * CDDDR: Lists. (line 210) * CDDR: Lists. (line 419) * CDR: Lists. (line 103) * CEILING: Numbers. (line 402) * CERROR: User Interface. (line 68) * CHAR: Sequences and Arrays and Hash Tables. (line 629) * CHAR-BIT: Characters. (line 162) * CHAR-BITS: Characters. (line 235) * CHAR-BITS-LIMIT: Characters. (line 137) * CHAR-CODE: Characters. (line 89) * CHAR-CODE-LIMIT: Numbers. (line 84) * CHAR-CONTROL-BIT: Characters. (line 94) * CHAR-DOWNCASE: Characters. (line 39) * CHAR-EQUAL: Characters. (line 179) * CHAR-FONT: Characters. (line 104) * CHAR-FONT-LIMIT: Characters. (line 35) * CHAR-GREATERP: Characters. (line 223) * CHAR-HYPER-BIT: Characters. (line 80) * CHAR-INT: Numbers. (line 63) * CHAR-LESSP: Characters. (line 97) * CHAR-META-BIT: Characters. (line 121) * CHAR-NAME: Characters. (line 13) * CHAR-NOT-EQUAL: Characters. (line 130) * CHAR-NOT-GREATERP: Characters. (line 186) * CHAR-NOT-LESSP: Characters. (line 52) * CHAR-SUPER-BIT: Characters. (line 32) * CHAR-UPCASE: Characters. (line 206) * CHAR/=: Characters. (line 218) * CHAR<: Characters. (line 109) * CHAR<=: Characters. (line 74) * CHAR=: Characters. (line 146) * CHAR>: Characters. (line 193) * CHAR>=: Characters. (line 115) * CHARACTER: Characters. (line 174) * CHARACTERP: Characters. (line 141) * CHDIR: System Definitions. (line 145) * CHECK-TYPE: Type. (line 39) * CIS: Numbers. (line 717) * CLEAR-INPUT: Streams and Reading. (line 284) * CLEAR-OUTPUT: Streams and Reading. (line 162) * CLINES: GCL Specific. (line 93) * CLOSE: Streams and Reading. (line 393) * CLOSE-FASD: System Definitions. (line 618) * CLRHASH: Sequences and Arrays and Hash Tables. (line 412) * CODE-CHAR: Characters. (line 83) * COERCE: Type. (line 6) * COMMONP: Type. (line 27) * COMPILE: Compilation. (line 6) * COMPILE-FILE: Compilation. (line 77) * COMPILED-FUNCTION-NAME: System Definitions. (line 107) * COMPILED-FUNCTION-P: Compilation. (line 196) * COMPILER-LET: Special Forms and Functions. (line 550) * COMPLEX: Numbers. (line 568) * COMPLEXP: Numbers. (line 507) * CONCATENATE: Sequences and Arrays and Hash Tables. (line 464) * COND: Special Forms and Functions. (line 460) * CONJUGATE: Numbers. (line 712) * CONS: Lists. (line 118) * CONSP: Lists. (line 55) * CONSTANTP: Type. (line 16) * COPY-ALIST: Lists. (line 287) * COPY-ARRAY-PORTION: GCL Specific. (line 207) * COPY-LIST: Lists. (line 190) * COPY-READTABLE: Streams and Reading. (line 447) * COPY-SEQ: Sequences and Arrays and Hash Tables. (line 17) * COPY-STREAM: System Definitions. (line 151) * COPY-SYMBOL: Symbols. (line 131) * COPY-TREE: Lists. (line 554) * COS: Numbers. (line 443) * COSH: Numbers. (line 462) * COUNT: Sequences and Arrays and Hash Tables. (line 529) * COUNT-IF: Sequences and Arrays and Hash Tables. (line 512) * COUNT-IF-NOT: Sequences and Arrays and Hash Tables. (line 380) * CTYPECASE: Special Forms and Functions. (line 724) * DBL: System Definitions. (line 662) * DECF: Numbers. (line 448) * DECLARE: Special Forms and Functions. (line 164) * DECODE-FLOAT: Numbers. (line 366) * DECODE-UNIVERSAL-TIME: Operating System Definitions. (line 42) * DEFCFUN: GCL Specific. (line 44) * DEFCONSTANT: Special Forms and Functions. (line 666) * DEFENTRY: GCL Specific. (line 153) * DEFINE-COMPILER-MACRO: System Definitions. (line 654) * DEFINE-INLINE-FUNCTION: System Definitions. (line 644) * DEFINE-MODIFY-MACRO: Special Forms and Functions. (line 488) * DEFINE-SETF-METHOD: Special Forms and Functions. (line 530) * DEFLA: GCL Specific. (line 136) * DEFMACRO: Special Forms and Functions. (line 207) * DEFPARAMETER: Special Forms and Functions. (line 760) * DEFSETF: Special Forms and Functions. (line 79) * DEFSTRUCT: Structures. (line 6) * DEFTYPE: Type. (line 58) * DEFUN: Special Forms and Functions. (line 141) * DEFVAR: Special Forms and Functions. (line 770) * DELETE: Sequences and Arrays and Hash Tables. (line 267) * DELETE-DUPLICATES: Sequences and Arrays and Hash Tables. (line 702) * DELETE-FILE: Operating System Definitions. (line 166) * DELETE-IF: Sequences and Arrays and Hash Tables. (line 211) * DELETE-IF-NOT: Sequences and Arrays and Hash Tables. (line 132) * DENOMINATOR: Numbers. (line 529) * DEPOSIT-FIELD: Numbers. (line 278) * DESCRIBE: User Interface. (line 51) * DIGIT-CHAR: Characters. (line 240) * DIGIT-CHAR-P: Characters. (line 212) * DIRECTORY: Operating System Definitions. (line 67) * DIRECTORY-NAMESTRING: Streams and Reading. (line 455) * DISASSEMBLE: Characters. (line 59) * DISPLACED-ARRAY-P: System Definitions. (line 353) * DO: Streams and Reading. (line 188) * DO*: Iteration and Tests. (line 18) * DO-ALL-SYMBOLS: Iteration and Tests. (line 28) * DO-EXTERNAL-SYMBOLS: Iteration and Tests. (line 6) * DO-SYMBOLS: Iteration and Tests. (line 90) * DOCUMENTATION: Symbols. (line 236) * DOLIST: Iteration and Tests. (line 59) * DOTIMES: Special Forms and Functions. (line 306) * DOUBLE-FLOAT-EPSILON: Numbers. (line 754) * DOUBLE-FLOAT-NEGATIVE-EPSILON: Numbers. (line 188) * DPB: Numbers. (line 701) * DRIBBLE: User Interface. (line 101) * DYNAMIC-EXTENT: Type. (line 77) * ECASE: Special Forms and Functions. (line 269) * ED: User Interface. (line 56) * EIGHTH: Lists. (line 76) * ELT: Sequences and Arrays and Hash Tables. (line 324) * EMIT-FN: Compiler Definitions. (line 6) * EMIT-FN <1>: Compiler Definitions. (line 21) * ENCODE-UNIVERSAL-TIME: Operating System Definitions. (line 97) * ENDP: Lists. (line 465) * ENOUGH-NAMESTRING: Operating System Definitions. (line 83) * EQ: Iteration and Tests. (line 69) * EQL: Numbers. (line 175) * EQUAL: Iteration and Tests. (line 82) * EQUALP: Iteration and Tests. (line 74) * ERROR: Special Forms and Functions. (line 682) * ERROR-SET: System Definitions. (line 97) * ETYPECASE: Special Forms and Functions. (line 111) * EVAL: Special Forms and Functions. (line 735) * EVAL-WHEN: Compilation. (line 65) * EVALHOOK: Special Forms and Functions. (line 707) * EVENP: Numbers. (line 476) * EVERY: Sequences and Arrays and Hash Tables. (line 732) * EXP: Numbers. (line 360) * EXPORT: Symbols. (line 208) * EXPT: Numbers. (line 616) * FASLINK: System Definitions. (line 377) * FBOUNDP: Symbols. (line 164) * FCEILING: Numbers. (line 216) * FFLOOR: Numbers. (line 642) * FIFTH: Lists. (line 40) * FILE-AUTHOR: Operating System Definitions. (line 24) * FILE-LENGTH: Streams and Reading. (line 102) * FILE-NAMESTRING: Streams and Reading. (line 422) * FILE-POSITION: Operating System Definitions. (line 35) * FILE-WRITE-DATE: Streams and Reading. (line 606) * FILL: Sequences and Arrays and Hash Tables. (line 639) * FILL-POINTER: Sequences and Arrays and Hash Tables. (line 386) * FIND: Sequences and Arrays and Hash Tables. (line 113) * FIND-ALL-SYMBOLS: Symbols. (line 291) * FIND-IF: Sequences and Arrays and Hash Tables. (line 58) * FIND-IF-NOT: Sequences and Arrays and Hash Tables. (line 695) * FIND-PACKAGE: Symbols. (line 307) * FIND-SHARING-TOP: System Definitions. (line 630) * FIND-SYMBOL: Symbols. (line 149) * FINISH-OUTPUT: Streams and Reading. (line 172) * FIRST: Lists. (line 372) * FIXNUMP: System Definitions. (line 191) * FLET: Special Forms and Functions. (line 255) * FLOAT: Numbers. (line 534) * FLOAT-DIGITS: Numbers. (line 802) * FLOAT-PRECISION: Numbers. (line 691) * FLOAT-RADIX: Numbers. (line 465) * FLOAT-SIGN: Numbers. (line 520) * FLOATP: Numbers. (line 483) * FLOOR: Numbers. (line 790) * FMAKUNBOUND: Symbols. (line 296) * FORCE-OUTPUT: Streams and Reading. (line 126) * FORMAT: Streams and Reading. (line 519) * FOURTH: Lists. (line 318) * FP-INPUT-STREAM: System Definitions. (line 692) * FP-OUTPUT-STREAM: System Definitions. (line 698) * FREAD: System Definitions. (line 492) * FREEZE-DEFSTRUCT: System Definitions. (line 14) * FRESH-LINE: Streams and Reading. (line 488) * FROUND: Numbers. (line 380) * FRS-BDS: System Definitions. (line 174) * FRS-IHS: System Definitions. (line 212) * FRS-VS: System Definitions. (line 410) * FTRUNCATE: Numbers. (line 169) * FUNCALL: Special Forms and Functions. (line 509) * FUNCTION: Special Forms and Functions. (line 345) * FUNCTIONP: Special Forms and Functions. (line 244) * FWRITE: System Definitions. (line 484) * GBC: GCL Specific. (line 110) * GBC-TIME: System Definitions. (line 475) * GCD: Numbers. (line 763) * GENSYM: Symbols. (line 6) * GENTEMP: Symbols. (line 247) * GET: Symbols. (line 284) * GET-DECODED-TIME: Operating System Definitions. (line 6) * GET-DISPATCH-MACRO-CHARACTER: Streams and Reading. (line 470) * GET-HOLE-SIZE: System Definitions. (line 62) * GET-INTERNAL-REAL-TIME: Operating System Definitions. (line 169) * GET-INTERNAL-RUN-TIME: Operating System Definitions. (line 150) * GET-MACRO-CHARACTER: Streams and Reading. (line 512) * GET-OUTPUT-STREAM-STRING: Streams and Reading. (line 671) * GET-PROPERTIES: Lists. (line 541) * GET-SETF-METHOD-MULTIPLE-VALUE: Special Forms and Functions. (line 471) * GET-STRING-INPUT-STREAM-INDEX: System Definitions. (line 80) * GET-UNIVERSAL-TIME: Operating System Definitions. (line 144) * GETENV: System Definitions. (line 370) * GETF: Lists. (line 424) * GETHASH: Sequences and Arrays and Hash Tables. (line 297) * GO: Special Forms and Functions. (line 595) * GPROF-QUIT: Compilation. (line 210) * GPROF-SET: Compilation. (line 221) * GPROF-START: Compilation. (line 201) * GRAPHIC-CHAR-P: Characters. (line 124) * HASH-TABLE-COUNT: Sequences and Arrays and Hash Tables. (line 231) * HASH-TABLE-P: Sequences and Arrays and Hash Tables. (line 375) * HELP: Structures. (line 33) * HELP*: GCL Specific. (line 127) * HOST-NAMESTRING: Operating System Definitions. (line 13) * IDENTITY: Special Forms and Functions. (line 656) * IF: Special Forms and Functions. (line 687) * IHS-FUN: System Definitions. (line 180) * IHS-VS: System Definitions. (line 118) * IMAGPART: Numbers. (line 422) * IMPORT: Symbols. (line 278) * IN-PACKAGE: Symbols. (line 176) * INCF: Numbers. (line 115) * INFO: Doc. (line 12) * INIT-SYSTEM: System Definitions. (line 157) * INPUT-STREAM-P: Streams and Reading. (line 410) * INSPECT: User Interface. (line 82) * INT-CHAR: Numbers. (line 58) * INTEGER-DECODE-FLOAT: Numbers. (line 20) * INTEGER-LENGTH: Numbers. (line 581) * INTEGERP: Numbers. (line 427) * INTERN: Symbols. (line 201) * INTERNAL-TIME-UNITS-PER-SECOND: Operating System Definitions. (line 79) * INTERSECTION: Lists. (line 215) * ISQRT: Numbers. (line 732) * KEYWORDP: Symbols. (line 14) * LABELS: Special Forms and Functions. (line 407) * LAMBDA-LIST-KEYWORDS: Special Forms and Functions. (line 6) * LAMBDA-PARAMETERS-LIMIT: Special Forms and Functions. (line 250) * LAST: Lists. (line 195) * LCM: Numbers. (line 438) * LDB: Numbers. (line 335) * LDB-TEST: Numbers. (line 78) * LDIFF: Lists. (line 431) * LEAST-NEGATIVE-DOUBLE-FLOAT: Numbers. (line 213) * LEAST-NEGATIVE-LONG-FLOAT: Numbers. (line 639) * LEAST-NEGATIVE-SHORT-FLOAT: Numbers. (line 408) * LEAST-NEGATIVE-SINGLE-FLOAT: Numbers. (line 69) * LEAST-POSITIVE-DOUBLE-FLOAT: Numbers. (line 688) * LEAST-POSITIVE-LONG-FLOAT: Numbers. (line 275) * LEAST-POSITIVE-SHORT-FLOAT: Numbers. (line 46) * LEAST-POSITIVE-SINGLE-FLOAT: Numbers. (line 504) * LENGTH: Lists. (line 81) * LET: Special Forms and Functions. (line 451) * LET*: Special Forms and Functions. (line 122) * LINK: Compilation. (line 22) * LISP-IMPLEMENTATION-TYPE: Operating System Definitions. (line 195) * LISP-IMPLEMENTATION-VERSION: Operating System Definitions. (line 103) * LIST: Lists. (line 123) * LIST*: Lists. (line 471) * LIST-ALL-PACKAGES: Symbols. (line 126) * LIST-LENGTH: Lists. (line 205) * LIST-UNCALLED-FUNCTIONS: Compiler Definitions. (line 93) * LIST-UNDEFINED-FUNCTIONS: Compiler Definitions. (line 73) * LISTEN: Streams and Reading. (line 290) * LISTP: Lists. (line 65) * LOAD: Streams and Reading. (line 16) * LOCALLY: Special Forms and Functions. (line 648) * LOG: Numbers. (line 182) * LOGAND: Numbers. (line 549) * LOGANDC1: Numbers. (line 499) * LOGANDC2: Numbers. (line 576) * LOGBITP: Numbers. (line 749) * LOGCOUNT: Numbers. (line 757) * LOGEQV: Numbers. (line 385) * LOGIOR: Numbers. (line 191) * LOGNAND: Numbers. (line 293) * LOGNOR: Numbers. (line 647) * LOGNOT: Numbers. (line 12) * LOGORC1: Numbers. (line 35) * LOGORC2: Numbers. (line 150) * LOGTEST: Numbers. (line 677) * LOGXOR: Numbers. (line 738) * LONG-FLOAT-EPSILON: Numbers. (line 376) * LONG-FLOAT-NEGATIVE-EPSILON: Numbers. (line 590) * LONG-SITE-NAME: Operating System Definitions. (line 160) * LOOP: Iteration and Tests. (line 102) * LOWER-CASE-P: Characters. (line 69) * MACHINE-INSTANCE: Operating System Definitions. (line 109) * MACHINE-TYPE: Operating System Definitions. (line 175) * MACHINE-VERSION: GCL Specific. (line 33) * MACRO-FUNCTION: Symbols. (line 170) * MACROEXPAND: Special Forms and Functions. (line 64) * MACROEXPAND-1: Special Forms and Functions. (line 502) * MACROLET: Special Forms and Functions. (line 583) * MAKE-ALL-PROCLAIMS: Compiler Definitions. (line 43) * MAKE-ARRAY: Sequences and Arrays and Hash Tables. (line 329) * MAKE-BROADCAST-STREAM: Streams and Reading. (line 233) * MAKE-CHAR: Characters. (line 168) * MAKE-CONCATENATED-STREAM: Streams and Reading. (line 144) * MAKE-DISPATCH-MACRO-CHARACTER: Streams and Reading. (line 427) * MAKE-ECHO-STREAM: Streams and Reading. (line 6) * MAKE-HASH-TABLE: Sequences and Arrays and Hash Tables. (line 304) * MAKE-LIST: Lists. (line 18) * MAKE-PACKAGE: Symbols. (line 187) * MAKE-PATHNAME: Streams and Reading. (line 298) * MAKE-PROCLAIMS: Compiler Definitions. (line 65) * MAKE-RANDOM-STATE: Numbers. (line 608) * MAKE-SEQUENCE: Sequences and Arrays and Hash Tables. (line 573) * MAKE-STRING: Sequences and Arrays and Hash Tables. (line 170) * MAKE-STRING-INPUT-STREAM: Streams and Reading. (line 48) * MAKE-STRING-INPUT-STREAM <1>: User Interface. (line 29) * MAKE-STRING-OUTPUT-STREAM: Streams and Reading. (line 583) * MAKE-STRING-OUTPUT-STREAM-FROM-STRING: System Definitions. (line 286) * MAKE-SYMBOL: Symbols. (line 67) * MAKE-SYNONYM-STREAM: Streams and Reading. (line 589) * MAKE-TWO-WAY-STREAM: Streams and Reading. (line 437) * MAKUNBOUND: Symbols. (line 54) * MAP: Sequences and Arrays and Hash Tables. (line 518) * MAPC: Lists. (line 108) * MAPCAN: Lists. (line 70) * MAPCAR: Iteration and Tests. (line 53) * MAPCON: Lists. (line 389) * MAPHASH: Iteration and Tests. (line 47) * MAPL: Lists. (line 113) * MAPLIST: Lists. (line 524) * MASK-FIELD: Numbers. (line 110) * MATCH-BEGINNING: System Definitions. (line 748) * MATCH-END: System Definitions. (line 755) * MAX: Numbers. (line 515) * MAXIMUM-ALLOCATABLE-PAGES: System Definitions. (line 21) * MAXIMUM-CONTIGUOUS-PAGES: System Definitions. (line 56) * MEMBER: Lists. (line 590) * MEMBER-IF: Lists. (line 548) * MEMBER-IF-NOT: Lists. (line 454) * MERGE: Sequences and Arrays and Hash Tables. (line 725) * MERGE-PATHNAMES: Streams and Reading. (line 620) * MIN: Numbers. (line 355) * MINUSP: Numbers. (line 30) * MISMATCH: Sequences and Arrays and Hash Tables. (line 427) * MOD: Numbers. (line 773) * MODF: Numbers. (line 778) * MOST-NEGATIVE-DOUBLE-FLOAT: Numbers. (line 196) * MOST-NEGATIVE-FIXNUM: Numbers. (line 587) * MOST-NEGATIVE-LONG-FLOAT: Numbers. (line 636) * MOST-NEGATIVE-SHORT-FLOAT: Numbers. (line 390) * MOST-NEGATIVE-SINGLE-FLOAT: Numbers. (line 40) * MOST-POSITIVE-DOUBLE-FLOAT: Numbers. (line 674) * MOST-POSITIVE-FIXNUM: Numbers. (line 221) * MOST-POSITIVE-LONG-FLOAT: Numbers. (line 262) * MOST-POSITIVE-SHORT-FLOAT: Numbers. (line 17) * MOST-POSITIVE-SINGLE-FLOAT: Numbers. (line 496) * MULTIPLE-VALUE-BIND: Special Forms and Functions. (line 155) * MULTIPLE-VALUE-CALL: Special Forms and Functions. (line 71) * MULTIPLE-VALUE-LIST: Special Forms and Functions. (line 566) * MULTIPLE-VALUE-PROG1: Special Forms and Functions. (line 574) * MULTIPLE-VALUE-SETQ: Special Forms and Functions. (line 639) * MULTIPLE-VALUES-LIMIT: Special Forms and Functions. (line 354) * NAME-CHAR: Characters. (line 6) * NAMESTRING: Streams and Reading. (line 382) * NANI: System Definitions. (line 318) * NBUTLAST: Lists. (line 97) * NCONC: Lists. (line 45) * NIL: Symbols. (line 92) * NINTERSECTION: Lists. (line 6) * NINTH: Lists. (line 477) * NLOAD: System Definitions. (line 669) * NOT: Special Forms and Functions. (line 661) * NOTANY: Sequences and Arrays and Hash Tables. (line 489) * NOTEVERY: Sequences and Arrays and Hash Tables. (line 598) * NRECONC: Lists. (line 519) * NREVERSE: Sequences and Arrays and Hash Tables. (line 589) * NSET-DIFFERENCE: Lists. (line 334) * NSET-EXCLUSIVE-OR: Lists. (line 247) * NSTRING-CAPITALIZE: Sequences and Arrays and Hash Tables. (line 541) * NSTRING-DOWNCASE: Sequences and Arrays and Hash Tables. (line 362) * NSTRING-UPCASE: Sequences and Arrays and Hash Tables. (line 87) * NSUBLIS: Lists. (line 323) * NSUBST: Lists. (line 221) * NSUBST-IF: Lists. (line 185) * NSUBST-IF-NOT: Lists. (line 92) * NSUBSTITUTE: Sequences and Arrays and Hash Tables. (line 176) * NSUBSTITUTE-IF: Sequences and Arrays and Hash Tables. (line 155) * NSUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables. (line 47) * NTH: Lists. (line 24) * NTHCDR: Lists. (line 163) * NULL: Lists. (line 35) * NUMBERP: Numbers. (line 669) * NUMERATOR: Numbers. (line 105) * NUNION: Lists. (line 274) * ODDP: Numbers. (line 722) * OPEN: Streams and Reading. (line 22) * OPEN-FASD: System Definitions. (line 578) * OR: Special Forms and Functions. (line 714) * OUTPUT-STREAM-P: Streams and Reading. (line 252) * OUTPUT-STREAM-STRING: System Definitions. (line 74) * PACKAGE-NAME: Symbols. (line 302) * PACKAGE-NICKNAMES: Symbols. (line 273) * PACKAGE-SHADOWING-SYMBOLS: Symbols. (line 195) * PACKAGE-USE-LIST: Symbols. (line 121) * PACKAGE-USED-BY-LIST: Symbols. (line 82) * PACKAGEP: Symbols. (line 214) * PAIRLIS: Lists. (line 168) * PARSE-INTEGER: Numbers. (line 652) * PARSE-NAMESTRING: Streams and Reading. (line 499) * PATHNAME: Streams and Reading. (line 416) * PATHNAME-DEVICE: Streams and Reading. (line 476) * PATHNAME-DIRECTORY: Streams and Reading. (line 507) * PATHNAME-HOST: Operating System Definitions. (line 30) * PATHNAME-NAME: Streams and Reading. (line 578) * PATHNAME-TYPE: Streams and Reading. (line 309) * PATHNAME-VERSION: Streams and Reading. (line 649) * PATHNAMEP: Streams and Reading. (line 366) * PEEK-CHAR: Streams and Reading. (line 245) * PHASE: Numbers. (line 129) * PI: Numbers. (line 93) * PLUSP: Numbers. (line 797) * POP: Lists. (line 341) * POSITION: Sequences and Arrays and Hash Tables. (line 22) * POSITION-IF: Sequences and Arrays and Hash Tables. (line 718) * POSITION-IF-NOT: Sequences and Arrays and Hash Tables. (line 604) * PPRINT: Streams and Reading. (line 55) * PRIN1: Streams and Reading. (line 150) * PRIN1-TO-STRING: Streams and Reading. (line 613) * PRINC: Streams and Reading. (line 156) * PRINC-TO-STRING: Streams and Reading. (line 633) * PRINT: Streams and Reading. (line 112) * PROBE-FILE: Streams and Reading. (line 643) * PROCLAIM: Compilation. (line 184) * PROCLAMATION: GCL Specific. (line 146) * PROF: System Definitions. (line 425) * PROG: Special Forms and Functions. (line 604) * PROG*: Special Forms and Functions. (line 373) * PROG1: Special Forms and Functions. (line 132) * PROG2: Special Forms and Functions. (line 280) * PROGN: Special Forms and Functions. (line 392) * PROGV: Special Forms and Functions. (line 289) * PROVIDE: Compilation. (line 190) * PSETF: Special Forms and Functions. (line 740) * PSETQ: Symbols. (line 73) * PUSH: Lists. (line 349) * PUSHNEW: Lists. (line 395) * PUTPROP: System Definitions. (line 33) * QUOTE: Special Forms and Functions. (line 299) * RANDOM: Numbers. (line 809) * RANDOM-STATE-P: Numbers. (line 683) * RASSOC: Lists. (line 86) * RASSOC-IF: Lists. (line 13) * RASSOC-IF-NOT: Lists. (line 513) * RATIONAL: Numbers. (line 88) * RATIONALIZE: Numbers. (line 727) * RATIONALP: Numbers. (line 768) * READ: Streams and Reading. (line 376) * READ-BYTE: Streams and Reading. (line 627) * READ-CHAR: Streams and Reading. (line 239) * READ-CHAR-NO-HANG: Streams and Reading. (line 481) * READ-DELIMITED-LIST: Streams and Reading. (line 677) * READ-FASD-TOP: System Definitions. (line 611) * READ-FROM-STRING: Streams and Reading. (line 203) * READ-LINE: Streams and Reading. (line 318) * READ-PRESERVING-WHITESPACE: Streams and Reading. (line 72) * READLINE-OFF: Streams and Reading. (line 706) * READLINE-ON: Streams and Reading. (line 685) * READTABLEP: Streams and Reading. (line 371) * REALPART: Numbers. (line 158) * REDUCE: Sequences and Arrays and Hash Tables. (line 738) * REM: Numbers. (line 350) * REMF: Symbols. (line 43) * REMHASH: Sequences and Arrays and Hash Tables. (line 660) * REMOVE: Sequences and Arrays and Hash Tables. (line 275) * REMOVE-DUPLICATES: Sequences and Arrays and Hash Tables. (line 710) * REMOVE-IF: Sequences and Arrays and Hash Tables. (line 224) * REMOVE-IF-NOT: Sequences and Arrays and Hash Tables. (line 140) * REMPROP: Symbols. (line 20) * RENAME-FILE: Operating System Definitions. (line 18) * RENAME-PACKAGE: Symbols. (line 253) * REPLACE: Sequences and Arrays and Hash Tables. (line 396) * REQUIRE: Operating System Definitions. (line 90) * RESET-GBC-COUNT: System Definitions. (line 218) * RESET-STACK-LIMITS: System Definitions. (line 236) * REST: Lists. (line 242) * RETURN: Special Forms and Functions. (line 420) * RETURN-FROM: Special Forms and Functions. (line 620) * REVAPPEND: Lists. (line 227) * REVERSE: Sequences and Arrays and Hash Tables. (line 81) * ROOM: Operating System Definitions. (line 115) * ROTATEF: Numbers. (line 304) * ROUND: Numbers. (line 543) * RPLACA: Lists. (line 264) * RPLACD: Lists. (line 449) * RUN-PROCESS: System Definitions. (line 722) * SAVE: GCL Specific. (line 118) * SAVE-SYSTEM: System Definitions. (line 331) * SBIT: Sequences and Arrays and Hash Tables. (line 34) * SCALE-FLOAT: Numbers. (line 626) * SCHAR: Characters. (line 26) * SEARCH: Sequences and Arrays and Hash Tables. (line 558) * SECOND: Lists. (line 269) * SET: Symbols. (line 95) * SET-CHAR-BIT: Characters. (line 246) * SET-DIFFERENCE: Lists. (line 530) * SET-DISPATCH-MACRO-CHARACTER: Streams and Reading. (line 85) * SET-EXCLUSIVE-OR: Lists. (line 407) * SET-HOLE-SIZE: System Definitions. (line 169) * SET-MACRO-CHARACTER: Streams and Reading. (line 119) * SET-SYNTAX-FROM-CHAR: Streams and Reading. (line 403) * SETF: Special Forms and Functions. (line 18) * SETQ: Symbols. (line 101) * SEVENTH: Lists. (line 173) * SGC-ON: System Definitions. (line 501) * SHADOW: Symbols. (line 157) * SHADOWING-IMPORT: Symbols. (line 36) * SHIFTF: Numbers. (line 265) * SHORT-FLOAT-EPSILON: Numbers. (line 146) * SHORT-FLOAT-NEGATIVE-EPSILON: Numbers. (line 346) * SHORT-SITE-NAME: Operating System Definitions. (line 61) * SIGNUM: Numbers. (line 6) * SIMPLE-BIT-VECTOR-P: Sequences and Arrays and Hash Tables. (line 568) * SIMPLE-STRING-P: Sequences and Arrays and Hash Tables. (line 219) * SIMPLE-VECTOR-P: Sequences and Arrays and Hash Tables. (line 679) * SIN: Numbers. (line 97) * SINGLE-FLOAT-EPSILON: Numbers. (line 573) * SINGLE-FLOAT-NEGATIVE-EPSILON: Numbers. (line 787) * SINH: Numbers. (line 124) * SIXTH: Lists. (line 290) * SLEEP: Operating System Definitions. (line 201) * SOCKET: System Definitions. (line 758) * SOFTWARE-TYPE: Operating System Definitions. (line 189) * SOFTWARE-VERSION: Operating System Definitions. (line 73) * SOME: Sequences and Arrays and Hash Tables. (line 164) * SORT: Sequences and Arrays and Hash Tables. (line 371) * SPECIAL-FORM-P: Special Forms and Functions. (line 316) * SPECIALP: System Definitions. (line 68) * SQRT: Numbers. (line 621) * STABLE-SORT: Sequences and Arrays and Hash Tables. (line 645) * STANDARD-CHAR-P: Characters. (line 199) * STEP: User Interface. (line 36) * STREAM-ELEMENT-TYPE: Streams and Reading. (line 134) * STREAMP: Streams and Reading. (line 80) * STRING: Sequences and Arrays and Hash Tables. (line 282) * STRING-CAPITALIZE: Sequences and Arrays and Hash Tables. (line 39) * STRING-CHAR-P: Characters. (line 45) * STRING-CONCATENATE: System Definitions. (line 85) * STRING-DOWNCASE: Sequences and Arrays and Hash Tables. (line 611) * STRING-EQUAL: Sequences and Arrays and Hash Tables. (line 185) * STRING-GREATERP: Sequences and Arrays and Hash Tables. (line 318) * STRING-LEFT-TRIM: Sequences and Arrays and Hash Tables. (line 684) * STRING-LESSP: Sequences and Arrays and Hash Tables. (line 746) * STRING-MATCH: System Definitions. (line 736) * STRING-NOT-EQUAL: Sequences and Arrays and Hash Tables. (line 120) * STRING-NOT-GREATERP: Sequences and Arrays and Hash Tables. (line 193) * STRING-NOT-LESSP: Sequences and Arrays and Hash Tables. (line 623) * STRING-RIGHT-TRIM: Sequences and Arrays and Hash Tables. (line 126) * STRING-TO-OBJECT: System Definitions. (line 202) * STRING-TRIM: Sequences and Arrays and Hash Tables. (line 478) * STRING-UPCASE: Sequences and Arrays and Hash Tables. (line 290) * STRING/=: Sequences and Arrays and Hash Tables. (line 310) * STRING<: Sequences and Arrays and Hash Tables. (line 74) * STRING<=: Sequences and Arrays and Hash Tables. (line 671) * STRING=: Sequences and Arrays and Hash Tables. (line 148) * STRING>: Sequences and Arrays and Hash Tables. (line 199) * STRING>=: Sequences and Arrays and Hash Tables. (line 94) * STRINGP: Sequences and Arrays and Hash Tables. (line 206) * STRUCTUREP: System Definitions. (line 112) * SUBLIS: Lists. (line 507) * SUBSEQ: Sequences and Arrays and Hash Tables. (line 11) * SUBSETP: Lists. (line 178) * SUBST: Lists. (line 377) * SUBST-IF: Lists. (line 329) * SUBST-IF-NOT: Lists. (line 259) * SUBSTITUTE: Sequences and Arrays and Hash Tables. (line 451) * SUBSTITUTE-IF: Sequences and Arrays and Hash Tables. (line 418) * SUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables. (line 241) * SUBTYPEP: Type. (line 32) * SVREF: Sequences and Arrays and Hash Tables. (line 255) * SXHASH: Numbers. (line 488) * SYMBOL-FUNCTION: Symbols. (line 219) * SYMBOL-NAME: Symbols. (line 144) * SYMBOL-PACKAGE: Symbols. (line 28) * SYMBOL-PLIST: Symbols. (line 139) * SYMBOL-VALUE: Symbols. (line 224) * SYMBOLP: Symbols. (line 87) * SYSTEM: GCL Specific. (line 6) * T: Symbols. (line 118) * TAGBODY: Special Forms and Functions. (line 103) * TAILP: Lists. (line 50) * TAN: Numbers. (line 233) * TANH: Numbers. (line 241) * TENTH: Lists. (line 60) * TERPRI: Streams and Reading. (line 167) * THE: Special Forms and Functions. (line 9) * THIRD: Lists. (line 128) * THROW: Special Forms and Functions. (line 750) * TIME: Operating System Definitions. (line 181) * TOP-LEVEL: System Definitions. (line 401) * TRACE: User Interface. (line 131) * TREE-EQUAL: Lists. (line 414) * TRUENAME: Streams and Reading. (line 460) * TRUNCATE: Numbers. (line 323) * TYPE-OF: Type. (line 11) * TYPECASE: Special Forms and Functions. (line 430) * TYPEP: Type. (line 22) * UNCATCH-BAD-SIGNALS: System Definitions. (line 343) * UNEXPORT: Symbols. (line 267) * UNINTERN: Symbols. (line 260) * UNION: Lists. (line 438) * UNIVERSAL-ERROR-HANDLER: System Definitions. (line 124) * UNLESS: Special Forms and Functions. (line 630) * UNREAD-CHAR: Streams and Reading. (line 387) * UNTRACE: User Interface. (line 16) * UNUSE-PACKAGE: Symbols. (line 112) * UNWIND-PROTECT: Special Forms and Functions. (line 697) * UPPER-CASE-P: Characters. (line 157) * USE-FAST-LINKS: GCL Specific. (line 218) * USE-PACKAGE: Symbols. (line 59) * USER-HOMEDIR-PATHNAME: Operating System Definitions. (line 51) * VALUES: Special Forms and Functions. (line 561) * VALUES-LIST: Special Forms and Functions. (line 677) * VECTOR: Sequences and Arrays and Hash Tables. (line 6) * VECTOR-POP: Sequences and Arrays and Hash Tables. (line 444) * VECTOR-PUSH: Sequences and Arrays and Hash Tables. (line 470) * VECTOR-PUSH-EXTEND: Sequences and Arrays and Hash Tables. (line 260) * VECTORP: Sequences and Arrays and Hash Tables. (line 666) * VS: System Definitions. (line 348) * WARN: User Interface. (line 114) * WHEN: Special Forms and Functions. (line 44) * WHO-CALLS: Compiler Definitions. (line 87) * WITH-INPUT-FROM-STRING: Streams and Reading. (line 273) * WITH-OPEN-FILE: Streams and Reading. (line 178) * WITH-OPEN-STREAM: Streams and Reading. (line 264) * WITH-OUTPUT-TO-STRING: Streams and Reading. (line 92) * WRITE: Streams and Reading. (line 661) * WRITE-BYTE: Streams and Reading. (line 139) * WRITE-CHAR: Streams and Reading. (line 494) * WRITE-DEBUG-SYMBOLS: System Definitions. (line 416) * WRITE-FASD-TOP: System Definitions. (line 606) * WRITE-LINE: Streams and Reading. (line 654) * WRITE-STRING: Streams and Reading. (line 210) * WRITE-TO-STRING: Streams and Reading. (line 356) * XDR-OPEN: System Definitions. (line 684) * XDR-READ: System Definitions. (line 704) * XDR-WRITE: System Definitions. (line 711) * Y-OR-N-P: Streams and Reading. (line 224) * YES-OR-NO-P: Iteration and Tests. (line 38) * ZEROP: Numbers. (line 480)  Tag Table: Node: Top291 Node: Numbers1147 Node: Sequences and Arrays and Hash Tables23544 Node: Characters49337 Node: Lists56733 Node: Streams and Reading70507 Node: Special Forms and Functions95894 Node: Compilation121157 Node: Symbols133797 Node: Operating System143555 Node: Command Line143745 Node: Operating System Definitions147751 Node: Structures155050 Node: Iteration and Tests156602 Node: User Interface160052 Node: Doc169078 Node: Type172327 Node: GCL Specific174987 Node: Bignums183411 Node: C Interface186101 Node: Available Symbols186263 Node: System Definitions186742 Node: Regular Expressions217047 Node: Debugging223137 Node: Source Level Debugging in Emacs223338 Node: Low Level Debug Functions227583 Node: Miscellaneous228583 Node: Environment228791 Node: Inititialization229416 Node: Low Level X Interface229960 Node: Compiler Definitions230557 Node: Function and Variable Index235852  End Tag Table  Local Variables: coding: utf-8 End: gcl-2.6.14/info/chap-19.texi0000644000175000017500000026734414360276512014003 0ustar cammcamm @node Filenames, Files, Hash Tables, Top @chapter Filenames @menu * Overview of Filenames:: * Pathnames:: * Logical Pathnames:: * Filenames Dictionary:: @end menu @node Overview of Filenames, Pathnames, Filenames, Filenames @section Overview of Filenames @c including concept-filenames There are many kinds of @i{file systems}, varying widely both in their superficial syntactic details, and in their underlying power and structure. The facilities provided by @r{Common Lisp} for referring to and manipulating @i{files} has been chosen to be compatible with many kinds of @i{file systems}, while at the same time minimizing the program-visible differences between kinds of @i{file systems}. Since @i{file systems} vary in their conventions for naming @i{files}, there are two distinct ways to represent @i{filenames}: as @i{namestrings} and as @i{pathnames}. @menu * Namestrings as Filenames:: * Pathnames as Filenames:: * Parsing Namestrings Into Pathnames:: @end menu @node Namestrings as Filenames, Pathnames as Filenames, Overview of Filenames, Overview of Filenames @subsection Namestrings as Filenames A @i{namestring} @IGindex namestring is a @i{string} that represents a @i{filename}. In general, the syntax of @i{namestrings} involves the use of @i{implementation-defined} conventions, usually those customary for the @i{file system} in which the named @i{file} resides. The only exception is the syntax of a @i{logical pathname} @i{namestring}, which is defined in this specification; see @ref{Syntax of Logical Pathname Namestrings}. A @i{conforming program} must never unconditionally use a @i{literal} @i{namestring} other than a @i{logical pathname} @i{namestring} because @r{Common Lisp} does not define any @i{namestring} syntax other than that for @i{logical pathnames} that would be guaranteed to be portable. However, a @i{conforming program} can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable @i{namestrings}. A @i{namestring} can be @i{coerced} to a @i{pathname} by the @i{functions} @b{pathname} or @b{parse-namestring}. @node Pathnames as Filenames, Parsing Namestrings Into Pathnames, Namestrings as Filenames, Overview of Filenames @subsection Pathnames as Filenames @i{Pathnames} @IGindex pathname are structured @i{objects} that can represent, in an @i{implementation-independent} way, the @i{filenames} that are used natively by an underlying @i{file system}. In addition, @i{pathnames} can also represent certain partially composed @i{filenames} for which an underlying @i{file system} might not have a specific @i{namestring} representation. A @i{pathname} need not correspond to any file that actually exists, and more than one @i{pathname} can refer to the same file. For example, the @i{pathname} with a version of @t{:newest} might refer to the same file as a @i{pathname} with the same components except a certain number as the version. Indeed, a @i{pathname} with version @t{:newest} might refer to different files as time passes, because the meaning of such a @i{pathname} depends on the state of the file system. Some @i{file systems} naturally use a structural model for their @i{filenames}, while others do not. Within the @r{Common Lisp} @i{pathname} model, all @i{filenames} are seen as having a particular structure, even if that structure is not reflected in the underlying @i{file system}. The nature of the mapping between structure imposed by @i{pathnames} and the structure, if any, that is used by the underlying @i{file system} is @i{implementation-defined}. Every @i{pathname} has six components: a host, a device, a directory, a name, a type, and a version. By naming @i{files} with @i{pathnames}, @r{Common Lisp} programs can work in essentially the same way even in @i{file systems} that seem superficially quite different. For a detailed description of these components, see @ref{Pathname Components}. The mapping of the @i{pathname} components into the concepts peculiar to each @i{file system} is @i{implementation-defined}. There exist conceivable @i{pathnames} for which there is no mapping to a syntactically valid @i{filename} in a particular @i{implementation}. An @i{implementation} may use various strategies in an attempt to find a mapping; for example, an @i{implementation} may quietly truncate @i{filenames} that exceed length limitations imposed by the underlying @i{file system}, or ignore certain @i{pathname} components for which the @i{file system} provides no support. If such a mapping cannot be found, an error of @i{type} @b{file-error} is signaled. The time at which this mapping and associated error signaling occurs is @i{implementation-dependent}. Specifically, it may occur at the time the @i{pathname} is constructed, when coercing a @i{pathname} to a @i{namestring}, or when an attempt is made to @i{open} or otherwise access the @i{file} designated by the @i{pathname}. Figure 19--1 lists some @i{defined names} that are applicable to @i{pathnames}. @format @group @noindent @w{ *default-pathname-defaults* namestring pathname-name } @w{ directory-namestring open pathname-type } @w{ enough-namestring parse-namestring pathname-version } @w{ file-namestring pathname pathnamep } @w{ file-string-length pathname-device translate-pathname } @w{ host-namestring pathname-directory truename } @w{ make-pathname pathname-host user-homedir-pathname } @w{ merge-pathnames pathname-match-p wild-pathname-p } @noindent @w{ Figure 19--1: Pathname Operations } @end group @end format @node Parsing Namestrings Into Pathnames, , Pathnames as Filenames, Overview of Filenames @subsection Parsing Namestrings Into Pathnames Parsing is the operation used to convert a @i{namestring} into a @i{pathname}. Except in the case of parsing @i{logical pathname} @i{namestrings}, this operation is @i{implementation-dependent}, because the format of @i{namestrings} is @i{implementation-dependent}. A @i{conforming implementation} is free to accommodate other @i{file system} features in its @i{pathname} representation and provides a parser that can process such specifications in @i{namestrings}. @i{Conforming programs} must not depend on any such features, since those features will not be portable. @c end of including concept-filenames @node Pathnames, Logical Pathnames, Overview of Filenames, Filenames @section Pathnames @c including concept-pathnames @menu * Pathname Components:: * Interpreting Pathname Component Values:: * Merging Pathnames:: @end menu @node Pathname Components, Interpreting Pathname Component Values, Pathnames, Pathnames @subsection Pathname Components A @i{pathname} has six components: a host, a device, a directory, a name, a type, and a version. @menu * The Pathname Host Component:: * The Pathname Device Component:: * The Pathname Directory Component:: * The Pathname Name Component:: * The Pathname Type Component:: * The Pathname Version Component:: @end menu @node The Pathname Host Component, The Pathname Device Component, Pathname Components, Pathname Components @subsubsection The Pathname Host Component The name of the file system on which the file resides, or the name of a @i{logical host}. @node The Pathname Device Component, The Pathname Directory Component, The Pathname Host Component, Pathname Components @subsubsection The Pathname Device Component Corresponds to the ``device'' or ``file structure'' concept in many host file systems: the name of a logical or physical device containing files. @node The Pathname Directory Component, The Pathname Name Component, The Pathname Device Component, Pathname Components @subsubsection The Pathname Directory Component Corresponds to the ``directory'' concept in many host file systems: the name of a group of related files. @node The Pathname Name Component, The Pathname Type Component, The Pathname Directory Component, Pathname Components @subsubsection The Pathname Name Component The ``name'' part of a group of @i{files} that can be thought of as conceptually related. @node The Pathname Type Component, The Pathname Version Component, The Pathname Name Component, Pathname Components @subsubsection The Pathname Type Component Corresponds to the ``filetype'' or ``extension'' concept in many host file systems. This says what kind of file this is. This component is always a @i{string}, @b{nil}, @t{:wild}, or @t{:unspecific}. @node The Pathname Version Component, , The Pathname Type Component, Pathname Components @subsubsection The Pathname Version Component Corresponds to the ``version number'' concept in many host file systems. The version is either a positive @i{integer} or a @i{symbol} from the following list: @b{nil}, @t{:wild}, @t{:unspecific}, or @t{:newest} (refers to the largest version number that already exists in the file system when reading a file, or to a version number greater than any already existing in the file system when writing a new file). Implementations can define other special version @i{symbols}. @node Interpreting Pathname Component Values, Merging Pathnames, Pathname Components, Pathnames @subsection Interpreting Pathname Component Values @menu * Strings in Component Values:: * Special Characters in Pathname Components:: * Case in Pathname Components:: * Local Case in Pathname Components:: * Common Case in Pathname Components:: * Special Pathname Component Values:: * NIL as a Component Value:: * ->WILD as a Component Value:: * ->UNSPECIFIC as a Component Value:: * Relation between component values NIL and ->UNSPECIFIC:: * Restrictions on Wildcard Pathnames:: * Restrictions on Examining Pathname Components:: * Restrictions on Examining a Pathname Host Component:: * Restrictions on Examining a Pathname Device Component:: * Restrictions on Examining a Pathname Directory Component:: * Directory Components in Non-Hierarchical File Systems:: * Restrictions on Examining a Pathname Name Component:: * Restrictions on Examining a Pathname Type Component:: * Restrictions on Examining a Pathname Version Component:: * Notes about the Pathname Version Component:: * Restrictions on Constructing Pathnames:: @end menu @node Strings in Component Values, Special Characters in Pathname Components, Interpreting Pathname Component Values, Interpreting Pathname Component Values @subsubsection Strings in Component Values @node Special Characters in Pathname Components, Case in Pathname Components, Strings in Component Values, Interpreting Pathname Component Values @subsubsection Special Characters in Pathname Components @i{Strings} in @i{pathname} component values never contain special @i{characters} that represent separation between @i{pathname} fields, such as @i{slash} in @r{Unix} @i{filenames}. Whether separator @i{characters} are permitted as part of a @i{string} in a @i{pathname} component is @i{implementation-defined}; however, if the @i{implementation} does permit it, it must arrange to properly ``quote'' the character for the @i{file system} when constructing a @i{namestring}. For example, @example ;; In a TOPS-20 implementation, which uses @t{^}V to quote (NAMESTRING (MAKE-PATHNAME :HOST "OZ" :NAME "")) @result{} #P"OZ:PS:@t{^}V" @i{NOT}@result{} #P"OZ:PS:" @end example @node Case in Pathname Components, Local Case in Pathname Components, Special Characters in Pathname Components, Interpreting Pathname Component Values @subsubsection Case in Pathname Components @i{Namestrings} always use local file system @i{case} conventions, but @r{Common Lisp} @i{functions} that manipulate @i{pathname} components allow the caller to select either of two conventions for representing @i{case} in component values by supplying a value for the @t{:case} keyword argument. Figure 19--2 lists the functions relating to @i{pathnames} that permit a @t{:case} argument: @format @group @noindent @w{ make-pathname pathname-directory pathname-name } @w{ pathname-device pathname-host pathname-type } @noindent @w{ Figure 19--2: Pathname functions using a :CASE argument} @end group @end format @node Local Case in Pathname Components, Common Case in Pathname Components, Case in Pathname Components, Interpreting Pathname Component Values @subsubsection Local Case in Pathname Components For the functions in @i{Figure~19--2}, a value of @t{:local} @c @IKindex{local} for the @t{:case} argument (the default for these functions) indicates that the functions should receive and yield @i{strings} in component values as if they were already represented according to the host @i{file system}'s convention for @i{case}. If the @i{file system} supports both @i{cases}, @i{strings} given or received as @i{pathname} component values under this protocol are to be used exactly as written. If the file system only supports one @i{case}, the @i{strings} will be translated to that @i{case}. @node Common Case in Pathname Components, Special Pathname Component Values, Local Case in Pathname Components, Interpreting Pathname Component Values @subsubsection Common Case in Pathname Components For the functions in @i{Figure~19--2}, a value of @t{:common} @c @IKindex{common} for the @t{:case} argument that these @i{functions} should receive and yield @i{strings} in component values according to the following conventions: @table @asis @item @t{*} All @i{uppercase} means to use a file system's customary @i{case}. @item @t{*} All @i{lowercase} means to use the opposite of the customary @i{case}. @item @t{*} Mixed @i{case} represents itself. @end table Note that these conventions have been chosen in such a way that translation from @t{:local} to @t{:common} and back to @t{:local} is information-preserving. @node Special Pathname Component Values, NIL as a Component Value, Common Case in Pathname Components, Interpreting Pathname Component Values @subsubsection Special Pathname Component Values @node NIL as a Component Value, ->WILD as a Component Value, Special Pathname Component Values, Interpreting Pathname Component Values @subsubsection NIL as a Component Value As a @i{pathname} component value, @b{nil} represents that the component is ``unfilled''; see @ref{Merging Pathnames}. The value of any @i{pathname} component can be @b{nil}. When constructing a @i{pathname}, @b{nil} in the host component might mean a default host rather than an actual @b{nil} in some @i{implementations}. @node ->WILD as a Component Value, ->UNSPECIFIC as a Component Value, NIL as a Component Value, Interpreting Pathname Component Values @subsubsection :WILD as a Component Value If @t{:wild} @c @IKindex{wild} is the value of a @i{pathname} component, that component is considered to be a wildcard, which matches anything. A @i{conforming program} must be prepared to encounter a value of @t{:wild} as the value of any @i{pathname} component, or as an @i{element} of a @i{list} that is the value of the directory component. When constructing a @i{pathname}, a @i{conforming program} may use @t{:wild} as the value of any or all of the directory, name, type, or version component, but must not use @t{:wild} as the value of the host, or device component. If @t{:wild} is used as the value of the directory component in the construction of a @i{pathname}, the effect is equivalent to specifying the list @t{(:absolute :wild-inferiors)}, or the same as @t{(:absolute :wild)} in a @i{file system} that does not support @t{:wild-inferiors}. @c @IKindex{wild-inferiors} @node ->UNSPECIFIC as a Component Value, Relation between component values NIL and ->UNSPECIFIC, ->WILD as a Component Value, Interpreting Pathname Component Values @subsubsection :UNSPECIFIC as a Component Value If @t{:unspecific} @c @IKindex{unspecific} is the value of a @i{pathname} component, the component is considered to be ``absent'' or to ``have no meaning'' in the @i{filename} being represented by the @i{pathname}. Whether a value of @t{:unspecific} is permitted for any component on any given @i{file system} accessible to the @i{implementation} is @i{implementation-defined}. A @i{conforming program} must never unconditionally use a @t{:unspecific} as the value of a @i{pathname} component because such a value is not guaranteed to be permissible in all implementations. However, a @i{conforming program} can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable @i{pathname} components. And certainly a @i{conforming program} should be prepared for the possibility that any components of a @i{pathname} could be @t{:unspecific}. When @i{reading}_1 the value of any @i{pathname} component, @i{conforming programs} should be prepared for the value to be @t{:unspecific}. When @i{writing}_1 the value of any @i{pathname} component, the consequences are undefined if @t{:unspecific} is given for a @i{pathname} in a @i{file system} for which it does not make sense. @node Relation between component values NIL and ->UNSPECIFIC, Restrictions on Wildcard Pathnames, ->UNSPECIFIC as a Component Value, Interpreting Pathname Component Values @subsubsection Relation between component values NIL and :UNSPECIFIC If a @i{pathname} is converted to a @i{namestring}, the @i{symbols} @b{nil} and @t{:unspecific} cause the field to be treated as if it were empty. That is, both @b{nil} and @t{:unspecific} cause the component not to appear in the @i{namestring}. However, when merging a @i{pathname} with a set of defaults, only a @b{nil} value for a component will be replaced with the default for that component, while a value of @t{:unspecific} will be left alone as if the field were ``filled''; see the @i{function} @b{merge-pathnames} and @ref{Merging Pathnames}. @node Restrictions on Wildcard Pathnames, Restrictions on Examining Pathname Components, Relation between component values NIL and ->UNSPECIFIC, Interpreting Pathname Component Values @subsubsection Restrictions on Wildcard Pathnames Wildcard @i{pathnames} can be used with @b{directory} but not with @b{open}, and return true from @b{wild-pathname-p}. When examining wildcard components of a wildcard @i{pathname}, conforming programs must be prepared to encounter any of the following additional values in any component or any element of a @i{list} that is the directory component: @table @asis @item @t{*} The @i{symbol} @t{:wild}, which matches anything. @item @t{*} A @i{string} containing @i{implementation-dependent} special wildcard @i{characters}. @item @t{*} Any @i{object}, representing an @i{implementation-dependent} wildcard pattern. @end table @node Restrictions on Examining Pathname Components, Restrictions on Examining a Pathname Host Component, Restrictions on Wildcard Pathnames, Interpreting Pathname Component Values @subsubsection Restrictions on Examining Pathname Components The space of possible @i{objects} that a @i{conforming program} must be prepared to @i{read}_1 as the value of a @i{pathname} component is substantially larger than the space of possible @i{objects} that a @i{conforming program} is permitted to @i{write}_1 into such a component. While the values discussed in the subsections of this section, in @ref{Special Pathname Component Values}, and in @ref{Restrictions on Wildcard Pathnames} apply to values that might be seen when reading the component values, substantially more restrictive rules apply to constructing pathnames; see @ref{Restrictions on Constructing Pathnames}. When examining @i{pathname} components, @i{conforming programs} should be aware of the following restrictions. @node Restrictions on Examining a Pathname Host Component, Restrictions on Examining a Pathname Device Component, Restrictions on Examining Pathname Components, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Host Component It is @i{implementation-dependent} what @i{object} is used to represent the host. @node Restrictions on Examining a Pathname Device Component, Restrictions on Examining a Pathname Directory Component, Restrictions on Examining a Pathname Host Component, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Device Component The device might be a @i{string}, @t{:wild}, @t{:unspecific}, or @b{nil}. Note that @t{:wild} might result from an attempt to @i{read}_1 the @i{pathname} component, even though portable programs are restricted from @i{writing}_1 such a component value; see @ref{Restrictions on Wildcard Pathnames} and @ref{Restrictions on Constructing Pathnames}. @node Restrictions on Examining a Pathname Directory Component, Directory Components in Non-Hierarchical File Systems, Restrictions on Examining a Pathname Device Component, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Directory Component The directory might be a @i{string}, @t{:wild}, @t{:unspecific}, or @b{nil}. The directory can be a @i{list} of @i{strings} and @i{symbols}. The @i{car} of the @i{list} is one of the symbols @t{:absolute} @c @IKindex{absolute} or @t{:relative} @c @IKindex{relative} , meaning: @table @asis @item @t{:absolute} A @i{list} whose @i{car} is the symbol @t{:absolute} represents a directory path starting from the root directory. The list @t{(:absolute)} represents the root directory. The list @t{(:absolute "foo" "bar" "baz")} represents the directory called @t{"/foo/bar/baz"} in Unix (except possibly for @i{case}). @item @t{:relative} A @i{list} whose @i{car} is the symbol @t{:relative} represents a directory path starting from a default directory. The list @t{(:relative)} has the same meaning as @b{nil} and hence is not used. The list @t{(:relative "foo" "bar")} represents the directory named @t{"bar"} in the directory named @t{"foo"} in the default directory. @end table Each remaining element of the @i{list} is a @i{string} or a @i{symbol}. Each @i{string} names a single level of directory structure. The @i{strings} should contain only the directory names themselves---no punctuation characters. In place of a @i{string}, at any point in the @i{list}, @i{symbols} can occur to indicate special file notations. Figure 19--3 lists the @i{symbols} that have standard meanings. Implementations are permitted to add additional @i{objects} of any @i{type} that is disjoint from @b{string} if necessary to represent features of their file systems that cannot be represented with the standard @i{strings} and @i{symbols}. Supplying any non-@i{string}, including any of the @i{symbols} listed below, to a file system for which it does not make sense signals an error of @i{type} @b{file-error}. For example, Unix does not support @t{:wild-inferiors} in most implementations. @c @IKindex{wild} @c @IKindex{wild-inferiors} @c @IKindex{up} @c @IKindex{back} @format @group @noindent @w{ Symbol Meaning } @w{ @t{:wild} Wildcard match of one level of directory structure } @w{ @t{:wild-inferiors} Wildcard match of any number of directory levels } @w{ @t{:up} Go upward in directory structure (semantic) } @w{ @t{:back} Go upward in directory structure (syntactic) } @noindent @w{ Figure 19--3: Special Markers In Directory Component } @end group @end format The following notes apply to the previous figure: @table @asis @item Invalid Combinations Using @t{:absolute} or @t{:wild-inferiors} immediately followed by @t{:up} or @t{:back} signals an error of @i{type} @b{file-error}. @item Syntactic vs Semantic ``Syntactic'' means that the action of @t{:back} depends only on the @i{pathname} and not on the contents of the file system. ``Semantic'' means that the action of @t{:up} depends on the contents of the file system; to resolve a @i{pathname} containing @t{:up} to a @i{pathname} whose directory component contains only @t{:absolute} and @i{strings} requires probing the file system. @t{:up} differs from @t{:back} only in file systems that support multiple names for directories, perhaps via symbolic links. For example, suppose that there is a directory @t{(:absolute "X" "Y" "Z")} linked to @t{(:absolute "A" "B" "C")} and there also exist directories @t{(:absolute "A" "B" "Q")} and @t{(:absolute "X" "Y" "Q")}. Then @t{(:absolute "X" "Y" "Z" :up "Q")} designates @t{(:absolute "A" "B" "Q")} while @t{(:absolute "X" "Y" "Z" :back "Q")} designates @t{(:absolute "X" "Y" "Q")} @end table @node Directory Components in Non-Hierarchical File Systems, Restrictions on Examining a Pathname Name Component, Restrictions on Examining a Pathname Directory Component, Interpreting Pathname Component Values @subsubsection Directory Components in Non-Hierarchical File Systems In non-hierarchical @i{file systems}, the only valid @i{list} values for the directory component of a @i{pathname} are @t{(:absolute @i{string})} and @t{(:absolute :wild)}. @t{:relative} directories and the keywords @t{:wild-inferiors}, @t{:up}, and @t{:back} are not used in non-hierarchical @i{file systems}. @node Restrictions on Examining a Pathname Name Component, Restrictions on Examining a Pathname Type Component, Directory Components in Non-Hierarchical File Systems, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Name Component The name might be a @i{string}, @t{:wild}, @t{:unspecific}, or @b{nil}. @node Restrictions on Examining a Pathname Type Component, Restrictions on Examining a Pathname Version Component, Restrictions on Examining a Pathname Name Component, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Type Component The type might be a @i{string}, @t{:wild}, @t{:unspecific}, or @b{nil}. @node Restrictions on Examining a Pathname Version Component, Notes about the Pathname Version Component, Restrictions on Examining a Pathname Type Component, Interpreting Pathname Component Values @subsubsection Restrictions on Examining a Pathname Version Component The version can be any @i{symbol} or any @i{integer}. The symbol @t{:newest} refers to the largest version number that already exists in the @i{file system} when reading, overwriting, appending, superseding, or directory listing an existing @i{file}. The symbol @t{:newest} refers to the smallest version number greater than any existing version number when creating a new file. The symbols @b{nil}, @t{:unspecific}, and @t{:wild} have special meanings and restrictions; see @ref{Special Pathname Component Values} and @ref{Restrictions on Constructing Pathnames}. Other @i{symbols} and @i{integers} have @i{implementation-defined} meaning. @node Notes about the Pathname Version Component, Restrictions on Constructing Pathnames, Restrictions on Examining a Pathname Version Component, Interpreting Pathname Component Values @subsubsection Notes about the Pathname Version Component It is suggested, but not required, that implementations do the following: @table @asis @item @t{*} Use positive @i{integers} starting at 1 as version numbers. @item @t{*} Recognize the symbol @t{:oldest} to designate the smallest existing version number. @item @t{*} Use @i{keywords} for other special versions. @end table @node Restrictions on Constructing Pathnames, , Notes about the Pathname Version Component, Interpreting Pathname Component Values @subsubsection Restrictions on Constructing Pathnames When constructing a @i{pathname} from components, conforming programs must follow these rules: @table @asis @item @t{*} Any component can be @b{nil}. @b{nil} in the host might mean a default host rather than an actual @b{nil} in some implementations. @item @t{*} The host, device, directory, name, and type can be @i{strings}. There are @i{implementation-dependent} limits on the number and type of @i{characters} in these @i{strings}. @item @t{*} The directory can be a @i{list} of @i{strings} and @i{symbols}. There are @i{implementation-dependent} limits on the @i{list}'s length and contents. @item @t{*} The version can be @t{:newest}. @item @t{*} Any component can be taken from the corresponding component of another @i{pathname}. When the two @i{pathnames} are for different file systems (in implementations that support multiple file systems), an appropriate translation occurs. If no meaningful translation is possible, an error is signaled. The definitions of ``appropriate'' and ``meaningful'' are @i{implementation-dependent}. @item @t{*} An implementation might support other values for some components, but a portable program cannot use those values. A conforming program can use @i{implementation-dependent} values but this can make it non-portable; for example, it might work only with @r{Unix} file systems. @end table @node Merging Pathnames, , Interpreting Pathname Component Values, Pathnames @subsection Merging Pathnames Merging takes a @i{pathname} with unfilled components and supplies values for those components from a source of defaults. If a component's value is @b{nil}, that component is considered to be unfilled. If a component's value is any @i{non-nil} @i{object}, including @t{:unspecific}, that component is considered to be filled. Except as explicitly specified otherwise, for functions that manipulate or inquire about @i{files} in the @i{file system}, the pathname argument to such a function is merged with @b{*default-pathname-defaults*} before accessing the @i{file system} (as if by @b{merge-pathnames}). @menu * Examples of Merging Pathnames:: @end menu @node Examples of Merging Pathnames, , Merging Pathnames, Merging Pathnames @subsubsection Examples of Merging Pathnames Although the following examples are possible to execute only in @i{implementations} which permit @t{:unspecific} in the indicated position andwhich permit four-letter type components, they serve to illustrate the basic concept of @i{pathname} merging. @example (pathname-type (merge-pathnames (make-pathname :type "LISP") (make-pathname :type "TEXT"))) @result{} "LISP" (pathname-type (merge-pathnames (make-pathname :type nil) (make-pathname :type "LISP"))) @result{} "LISP" (pathname-type (merge-pathnames (make-pathname :type :unspecific) (make-pathname :type "LISP"))) @result{} :UNSPECIFIC @end example @c end of including concept-pathnames @node Logical Pathnames, Filenames Dictionary, Pathnames, Filenames @section Logical Pathnames @c including concept-logical-pathnames @menu * Syntax of Logical Pathname Namestrings:: * Logical Pathname Components:: @end menu @node Syntax of Logical Pathname Namestrings, Logical Pathname Components, Logical Pathnames, Logical Pathnames @subsection Syntax of Logical Pathname Namestrings The syntax of a @i{logical pathname} @i{namestring} is as follows. (Note that unlike many notational descriptions in this document, this is a syntactic description of character sequences, not a structural description of @i{objects}.) @w{@i{logical-pathname} ::=@r{[}!@i{host} @i{host-marker}@r{]} } @w{ @r{[}!@i{@i{relative-directory-marker}}@r{]} @{!@i{directory} @i{directory-marker}@}* } @w{ @r{[}!@i{name}@r{]} @r{[}@i{type-marker} !@i{type} @r{[}@i{version-marker} !@i{version}@r{]}@r{]}} @w{@i{host} ::=!@i{word}} @w{@i{directory} ::=!@i{word} | !@i{wildcard-word} | !@i{wild-inferiors-word}} @w{@i{name} ::=!@i{word} | !@i{wildcard-word}} @w{@i{type} ::=!@i{word} | !@i{wildcard-word}} @w{@i{version} ::=!@i{pos-int} | @i{newest-word} | @i{wildcard-version}} @i{host-marker}---a @i{colon}. @i{relative-directory-marker}---a @i{semicolon}. @i{directory-marker}---a @i{semicolon}. @i{type-marker}---a @i{dot}. @i{version-marker}---a @i{dot}. @i{wild-inferiors-word}---The two character sequence ``@t{**}'' (two @i{asterisks}). @i{newest-word}---The six character sequence ``@t{newest}'' or the six character sequence ``@t{NEWEST}''. @i{wildcard-version}---an @i{asterisk}. @i{wildcard-word}---one or more @i{asterisks}, uppercase letters, digits, and hyphens, including at least one @i{asterisk}, with no two @i{asterisks} adjacent. @i{word}---one or more uppercase letters, digits, and hyphens. @i{pos-int}---a positive @i{integer}. @menu * Additional Information about Parsing Logical Pathname Namestrings:: * The Host part of a Logical Pathname Namestring:: * The Device part of a Logical Pathname Namestring:: * The Directory part of a Logical Pathname Namestring:: * The Type part of a Logical Pathname Namestring:: * The Version part of a Logical Pathname Namestring:: * Wildcard Words in a Logical Pathname Namestring:: * Lowercase Letters in a Logical Pathname Namestring:: * Other Syntax in a Logical Pathname Namestring:: @end menu @node Additional Information about Parsing Logical Pathname Namestrings, The Host part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings, Syntax of Logical Pathname Namestrings @subsubsection Additional Information about Parsing Logical Pathname Namestrings @node The Host part of a Logical Pathname Namestring, The Device part of a Logical Pathname Namestring, Additional Information about Parsing Logical Pathname Namestrings, Syntax of Logical Pathname Namestrings @subsubsection The Host part of a Logical Pathname Namestring The @i{host} must have been defined as a @i{logical pathname} host; this can be done by using @b{setf} of @b{logical-pathname-translations}. The @i{logical pathname} host name @t{"SYS"} is reserved for the implementation. The existence and meaning of @t{SYS:} @i{logical pathnames} is @i{implementation-defined}. @node The Device part of a Logical Pathname Namestring, The Directory part of a Logical Pathname Namestring, The Host part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection The Device part of a Logical Pathname Namestring There is no syntax for a @i{logical pathname} device since the device component of a @i{logical pathname} is always @t{:unspecific}; see @ref{Unspecific Components of a Logical Pathname}. @node The Directory part of a Logical Pathname Namestring, The Type part of a Logical Pathname Namestring, The Device part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection The Directory part of a Logical Pathname Namestring If a @i{relative-directory-marker} precedes the @i{directories}, the directory component parsed is as @i{relative}; otherwise, the directory component is parsed as @i{absolute}. If a @i{wild-inferiors-marker} is specified, it parses into @t{:wild-inferiors}. @node The Type part of a Logical Pathname Namestring, The Version part of a Logical Pathname Namestring, The Directory part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection The Type part of a Logical Pathname Namestring The @i{type} of a @i{logical pathname} for a @i{source file} is @t{"LISP"}. This should be translated into whatever type is appropriate in a physical pathname. @node The Version part of a Logical Pathname Namestring, Wildcard Words in a Logical Pathname Namestring, The Type part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection The Version part of a Logical Pathname Namestring Some @i{file systems} do not have @i{versions}. @i{Logical pathname} translation to such a @i{file system} ignores the @i{version}. This implies that a program cannot rely on being able to store more than one version of a file named by a @i{logical pathname}. If a @i{wildcard-version} is specified, it parses into @t{:wild}. @node Wildcard Words in a Logical Pathname Namestring, Lowercase Letters in a Logical Pathname Namestring, The Version part of a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection Wildcard Words in a Logical Pathname Namestring Each @i{asterisk} in a @i{wildcard-word} matches a sequence of zero or more characters. The @i{wildcard-word} ``@t{*}'' parses into @t{:wild}; other @i{wildcard-words} parse into @i{strings}. @node Lowercase Letters in a Logical Pathname Namestring, Other Syntax in a Logical Pathname Namestring, Wildcard Words in a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection Lowercase Letters in a Logical Pathname Namestring When parsing @i{words} and @i{wildcard-words}, lowercase letters are translated to uppercase. @node Other Syntax in a Logical Pathname Namestring, , Lowercase Letters in a Logical Pathname Namestring, Syntax of Logical Pathname Namestrings @subsubsection Other Syntax in a Logical Pathname Namestring The consequences of using characters other than those specified here in a @i{logical pathname} @i{namestring} are unspecified. The consequences of using any value not specified here as a @i{logical pathname} component are unspecified. @node Logical Pathname Components, , Syntax of Logical Pathname Namestrings, Logical Pathnames @subsection Logical Pathname Components @menu * Unspecific Components of a Logical Pathname:: * Null Strings as Components of a Logical Pathname:: @end menu @node Unspecific Components of a Logical Pathname, Null Strings as Components of a Logical Pathname, Logical Pathname Components, Logical Pathname Components @subsubsection Unspecific Components of a Logical Pathname The device component of a @i{logical pathname} is always @t{:unspecific}; no other component of a @i{logical pathname} can be @t{:unspecific}. @node Null Strings as Components of a Logical Pathname, , Unspecific Components of a Logical Pathname, Logical Pathname Components @subsubsection Null Strings as Components of a Logical Pathname The null string, @t{""}, is not a valid value for any component of a @i{logical pathname}. @c end of including concept-logical-pathnames @node Filenames Dictionary, , Logical Pathnames, Filenames @section Filenames Dictionary @c including dict-pathnames @menu * pathname (System Class):: * logical-pathname (System Class):: * pathname:: * make-pathname:: * pathnamep:: * pathname-host:: * load-logical-pathname-translations:: * logical-pathname-translations:: * logical-pathname:: * *default-pathname-defaults*:: * namestring:: * parse-namestring:: * wild-pathname-p:: * pathname-match-p:: * translate-logical-pathname:: * translate-pathname:: * merge-pathnames:: @end menu @node pathname (System Class), logical-pathname (System Class), Filenames Dictionary, Filenames Dictionary @subsection pathname [System Class] @subsubheading Class Precedence List:: @b{pathname}, @b{t} @subsubheading Description:: A @i{pathname} is a structured @i{object} which represents a @i{filename}. There are two kinds of @i{pathnames}---@i{physical pathnames} and @i{logical pathnames}. @node logical-pathname (System Class), pathname, pathname (System Class), Filenames Dictionary @subsection logical-pathname [System Class] @subsubheading Class Precedence List:: @b{logical-pathname}, @b{pathname}, @b{t} @subsubheading Description:: A @i{pathname} that uses a @i{namestring} syntax that is @i{implementation-independent}, and that has component values that are @i{implementation-independent}. @i{Logical pathnames} do not refer directly to @i{filenames} @subsubheading See Also:: @ref{File System Concepts}, @ref{Sharpsign P}, @ref{Printing Pathnames} @node pathname, make-pathname, logical-pathname (System Class), Filenames Dictionary @subsection pathname [Function] @code{pathname} @i{pathspec} @result{} @i{pathname} @subsubheading Arguments and Values:: @i{pathspec}---a @i{pathname designator}. @i{pathname}---a @i{pathname}. @subsubheading Description:: Returns the @i{pathname} denoted by @i{pathspec}. If the @i{pathspec} @i{designator} is a @i{stream}, the @i{stream} can be either open or closed; in both cases, the @b{pathname} returned corresponds to the @i{filename} used to open the @i{file}. @b{pathname} returns the same @i{pathname} for a @i{file stream} after it is closed as it did when it was open. If the @i{pathspec} @i{designator} is a @i{file stream} created by opening a @i{logical pathname}, a @i{logical pathname} is returned. @subsubheading Examples:: @example ;; There is a great degree of variability permitted here. The next ;; several examples are intended to illustrate just a few of the many ;; possibilities. Whether the name is canonicalized to a particular ;; case (either upper or lower) depends on both the file system and the ;; implementation since two different implementations using the same ;; file system might differ on many issues. How information is stored ;; internally (and possibly presented in #S notation) might vary, ;; possibly requiring `accessors' such as PATHNAME-NAME to perform case ;; conversion upon access. The format of a namestring is dependent both ;; on the file system and the implementation since, for example, one ;; implementation might include the host name in a namestring, and ;; another might not. #S notation would generally only be used in a ;; situation where no appropriate namestring could be constructed for use ;; with #P. (setq p1 (pathname "test")) @result{} #P"CHOCOLATE:TEST" ; with case canonicalization (e.g., VMS) @i{OR}@result{} #P"VANILLA:test" ; without case canonicalization (e.g., Unix) @i{OR}@result{} #P"test" @i{OR}@result{} #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST") @i{OR}@result{} #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test") (setq p2 (pathname "test")) @result{} #P"CHOCOLATE:TEST" @i{OR}@result{} #P"VANILLA:test" @i{OR}@result{} #P"test" @i{OR}@result{} #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST") @i{OR}@result{} #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test") (pathnamep p1) @result{} @i{true} (eq p1 (pathname p1)) @result{} @i{true} (eq p1 p2) @result{} @i{true} @i{OR}@result{} @i{false} (with-open-file (stream "test" :direction :output) (pathname stream)) @result{} #P"ORANGE-CHOCOLATE:>Gus>test.lisp.newest" @end example @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node make-pathname, pathnamep, pathname, Filenames Dictionary @subsection make-pathname [Function] @code{make-pathname} @i{@r{&key} host device directory name type version defaults case}@* @result{} @i{pathname} @subsubheading Arguments and Values:: @i{host}---a @i{valid physical pathname host}. Complicated defaulting behavior; see below. @i{device}---a @i{valid pathname device}. Complicated defaulting behavior; see below. @i{directory}---a @i{valid pathname directory}. Complicated defaulting behavior; see below. @i{name}---a @i{valid pathname name}. Complicated defaulting behavior; see below. @i{type}---a @i{valid pathname type}. Complicated defaulting behavior; see below. @i{version}---a @i{valid pathname version}. Complicated defaulting behavior; see below. @i{defaults}---a @i{pathname designator}. The default is a @i{pathname} whose host component is the same as the host component of the @i{value} of @b{*default-pathname-defaults*}, and whose other components are all @b{nil}. @i{case}---one of @t{:common} or @t{:local}. The default is @t{:local}. @i{pathname}---a @i{pathname}. @subsubheading Description:: Constructs and returns a @i{pathname} from the supplied keyword arguments. After the components supplied explicitly by @i{host}, @i{device}, @i{directory}, @i{name}, @i{type}, and @i{version} are filled in, the merging rules used by @b{merge-pathnames} are used to fill in any unsupplied components from the defaults supplied by @i{defaults}. Whenever a @i{pathname} is constructed the components may be canonicalized if appropriate. For the explanation of the arguments that can be supplied for each component, see @ref{Pathname Components}. If @i{case} is supplied, it is treated as described in @ref{Case in Pathname Components}. The resulting @i{pathname} is a @i{logical pathname} if and only its host component is a @i{logical host} or a @i{string} that names a defined @i{logical host}. If the @i{directory} is a @i{string}, it should be the name of a top level directory, and should not contain any punctuation characters; that is, specifying a @i{string}, @i{str}, is equivalent to specifying the list @t{(:absolute @i{str})}. Specifying the symbol @t{:wild} is equivalent to specifying the list @t{(:absolute :wild-inferiors)}, or @t{(:absolute :wild)} in a file system that does not support @t{:wild-inferiors}. @subsubheading Examples:: @example ;; Implementation A -- an implementation with access to a single ;; Unix file system. This implementation happens to never display ;; the `host' information in a namestring, since there is only one host. (make-pathname :directory '(:absolute "public" "games") :name "chess" :type "db") @result{} #P"/public/games/chess.db" ;; Implementation B -- an implementation with access to one or more ;; VMS file systems. This implementation displays `host' information ;; in the namestring only when the host is not the local host. ;; It uses a double colon to separate a host name from the host's local ;; file name. (make-pathname :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB") @result{} #P"SYS$DISK:[PUBLIC.GAMES]CHESS.DB" (make-pathname :host "BOBBY" :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB") @result{} #P"BOBBY::SYS$DISK:[PUBLIC.GAMES]CHESS.DB" ;; Implementation C -- an implementation with simultaneous access to ;; multiple file systems from the same Lisp image. In this ;; implementation, there is a convention that any text preceding the ;; first colon in a pathname namestring is a host name. (dolist (case '(:common :local)) (dolist (host '("MY-LISPM" "MY-VAX" "MY-UNIX")) (print (make-pathname :host host :case case :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB")))) @t{ |> } #P"MY-LISPM:>public>games>chess.db" @t{ |> } #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB" @t{ |> } #P"MY-UNIX:/public/games/chess.db" @t{ |> } #P"MY-LISPM:>public>games>chess.db" @t{ |> } #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB" @t{ |> } #P"MY-UNIX:/PUBLIC/GAMES/CHESS.DB" @result{} NIL @end example @subsubheading Affected By:: The @i{file system}. @subsubheading See Also:: @ref{merge-pathnames} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @subsubheading Notes:: Portable programs should not supply @t{:unspecific} for any component. See @ref{->UNSPECIFIC as a Component Value}. @node pathnamep, pathname-host, make-pathname, Filenames Dictionary @subsection pathnamep [Function] @code{pathnamep} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{pathname}; otherwise, returns @i{false}. @subsubheading Examples:: @example (setq q "test") @result{} "test" (pathnamep q) @result{} @i{false} (setq q (pathname "test")) @result{} #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL) (pathnamep q) @result{} @i{true} (setq q (logical-pathname "SYS:SITE;FOO.SYSTEM")) @result{} #P"SYS:SITE;FOO.SYSTEM" (pathnamep q) @result{} @i{true} @end example @subsubheading Notes:: @example (pathnamep @i{object}) @equiv{} (typep @i{object} 'pathname) @end example @node pathname-host, load-logical-pathname-translations, pathnamep, Filenames Dictionary @subsection pathname-host, pathname-device, pathname-directory, @subheading pathname-name, pathname-type, pathname-version @flushright @i{[Function]} @end flushright @code{pathname-host} @i{pathname @r{&key} case} @result{} @i{host} @code{pathname-device} @i{pathname @r{&key} case} @result{} @i{device} @code{pathname-directory} @i{pathname @r{&key} case} @result{} @i{directory} @code{pathname-name} @i{pathname @r{&key} case} @result{} @i{name} @code{pathname-type} @i{pathname @r{&key} case} @result{} @i{type} @code{pathname-version} @i{pathname} @result{} @i{version} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @i{case}---one of @t{:local} or @t{:common}. The default is @t{:local}. @i{host}---a @i{valid pathname host}. @i{device}---a @i{valid pathname device}. @i{directory}---a @i{valid pathname directory}. @i{name}---a @i{valid pathname name}. @i{type}---a @i{valid pathname type}. @i{version}---a @i{valid pathname version}. @subsubheading Description:: These functions return the components of @i{pathname}. If the @i{pathname} @i{designator} is a @i{pathname}, it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. If @i{case} is supplied, it is treated as described in @ref{Case in Pathname Components}. @subsubheading Examples:: @example (setq q (make-pathname :host "KATHY" :directory "CHAPMAN" :name "LOGIN" :type "COM")) @result{} #P"KATHY::[CHAPMAN]LOGIN.COM" (pathname-host q) @result{} "KATHY" (pathname-name q) @result{} "LOGIN" (pathname-type q) @result{} "COM" ;; Because namestrings are used, the results shown in the remaining ;; examples are not necessarily the only possible results. Mappings ;; from namestring representation to pathname representation are ;; dependent both on the file system involved and on the implementation ;; (since there may be several implementations which can manipulate the ;; the same file system, and those implementations are not constrained ;; to agree on all details). Consult the documentation for each ;; implementation for specific information on how namestrings are treated ;; that implementation. ;; VMS (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP")) @result{} (:ABSOLUTE "FOO" "BAR") (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP") :case :common) @result{} (:ABSOLUTE "FOO" "BAR") ;; Unix (pathname-directory "foo.l") @result{} NIL (pathname-device "foo.l") @result{} :UNSPECIFIC (pathname-name "foo.l") @result{} "foo" (pathname-name "foo.l" :case :local) @result{} "foo" (pathname-name "foo.l" :case :common) @result{} "FOO" (pathname-type "foo.l") @result{} "l" (pathname-type "foo.l" :case :local) @result{} "l" (pathname-type "foo.l" :case :common) @result{} "L" (pathname-type "foo") @result{} :UNSPECIFIC (pathname-type "foo" :case :common) @result{} :UNSPECIFIC (pathname-type "foo.") @result{} "" (pathname-type "foo." :case :common) @result{} "" (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local) @result{} (:ABSOLUTE "foo" "bar") (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local) @result{} (:ABSOLUTE "FOO" "BAR") (pathname-directory (parse-namestring "../baz.lisp")) @result{} (:RELATIVE :UP) (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz")) @result{} (:ABSOLUTE "foo" "BAR" :UP "Mum") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz") :case :common) @result{} (:ABSOLUTE "FOO" "bar" :UP "Mum") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l")) @result{} (:ABSOLUTE "foo" :WILD "bar") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l") :case :common) @result{} (:ABSOLUTE "FOO" :WILD "BAR") ;; Symbolics LMFS (pathname-directory (parse-namestring ">foo>**>bar>baz.lisp")) @result{} (:ABSOLUTE "foo" :WILD-INFERIORS "bar") (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp")) @result{} (:ABSOLUTE "foo" :WILD "bar") (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp") :case :common) @result{} (:ABSOLUTE "FOO" :WILD "BAR") (pathname-device (parse-namestring ">foo>baz.lisp")) @result{} :UNSPECIFIC @end example @subsubheading Affected By:: The @i{implementation} and the host @i{file system}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if its first argument is not a @i{pathname}. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node load-logical-pathname-translations, logical-pathname-translations, pathname-host, Filenames Dictionary @subsection load-logical-pathname-translations [Function] @code{load-logical-pathname-translations} @i{host} @result{} @i{just-loaded} @subsubheading Arguments and Values:: @i{host}---a @i{string}. @i{just-loaded}---a @i{generalized boolean}. @subsubheading Description:: Searches for and loads the definition of a @i{logical host} named @i{host}, if it is not already defined. The specific nature of the search is @i{implementation-defined}. If the @i{host} is already defined, no attempt to find or load a definition is attempted, and @i{false} is returned. If the @i{host} is not already defined, but a definition is successfully found and loaded, @i{true} is returned. Otherwise, an error is signaled. @subsubheading Examples:: @example (translate-logical-pathname "hacks:weather;barometer.lisp.newest") @t{ |> } Error: The logical host HACKS is not defined. (load-logical-pathname-translations "HACKS") @t{ |> } ;; Loading SYS:SITE;HACKS.TRANSLATIONS @t{ |> } ;; Loading done. @result{} @i{true} (translate-logical-pathname "hacks:weather;barometer.lisp.newest") @result{} #P"HELIUM:[SHARED.HACKS.WEATHER]BAROMETER.LSP;0" (load-logical-pathname-translations "HACKS") @result{} @i{false} @end example @subsubheading Exceptional Situations:: If no definition is found, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @b{logical-pathname} @subsubheading Notes:: @i{Logical pathname} definitions will be created not just by @i{implementors} but also by @i{programmers}. As such, it is important that the search strategy be documented. For example, an @i{implementation} might define that the definition of a @i{host} is to be found in a file called ``@i{host}.translations'' in some specifically named directory. @node logical-pathname-translations, logical-pathname, load-logical-pathname-translations, Filenames Dictionary @subsection logical-pathname-translations [Accessor] @code{logical-pathname-translations} @i{host} @result{} @i{translations} (setf (@code{ logical-pathname-translations} @i{host}) new-translations)@* @subsubheading Arguments and Values:: @i{host}--a @i{logical host designator}. @i{translations}, @i{new-translations}---a @i{list}. @subsubheading Description:: Returns the host's @i{list} of translations. Each translation is a @i{list} of at least two elements: @i{from-wildcard} and @i{to-wildcard}. Any additional elements are @i{implementation-defined}. @i{From-wildcard} is a @i{logical pathname} whose host is @i{host}. @i{To-wildcard} is a @i{pathname}. [Reviewer Note by Laddaga: Can this be a logical pathname?] @t{(setf (logical-pathname-translations @i{host}) @i{translations})} sets a @i{logical pathname} host's @i{list} of @i{translations}. If @i{host} is a @i{string} that has not been previously used as a @i{logical pathname} host, a new @i{logical pathname} host is defined; otherwise an existing host's translations are replaced. @i{logical pathname} host names are compared with @b{string-equal}. When setting the translations list, each @i{from-wildcard} can be a @i{logical pathname} whose host is @i{host} or a @i{logical pathname} namestring parseable by @t{(parse-namestring @i{string} @i{host})}, where @i{host} represents the appropriate @i{object} as defined by @b{parse-namestring}. Each @i{to-wildcard} can be anything coercible to a @i{pathname} by @t{(pathname @i{to-wildcard})}. If @i{to-wildcard} coerces to a @i{logical pathname}, @b{translate-logical-pathname} will perform repeated translation steps when it uses it. @i{host} is either the host component of a @i{logical pathname} or a @i{string} that has been defined as a @i{logical pathname} host name by @b{setf} of @b{logical-pathname-translations}. @subsubheading Examples:: [Reviewer Note by Laddaga: Shouldn't there be some @t{*.*}'s in the list of translations for @t{PROG} below?] @example ;;;A very simple example of setting up a logical pathname host. No ;;;translations are necessary to get around file system restrictions, so ;;;all that is necessary is to specify the root of the physical directory ;;;tree that contains the logical file system. ;;;The namestring syntax on the right-hand side is implementation-dependent. (setf (logical-pathname-translations "foo") '(("**;*.*.*" "MY-LISPM:>library>foo>**>"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "foo:bar;baz;mum.quux.3") @result{} #P"MY-LISPM:>library>foo>bar>baz>mum.quux.3" ;;;A more complex example, dividing the files among two file servers ;;;and several different directories. This Unix doesn't support ;;;:WILD-INFERIORS in the directory, so each directory level must ;;;be translated individually. No file name or type translations ;;;are required except for .MAIL to .MBX. ;;;The namestring syntax on the right-hand side is implementation-dependent. (setf (logical-pathname-translations "prog") '(("RELEASED;*.*.*" "MY-UNIX:/sys/bin/my-prog/") ("RELEASED;*;*.*.*" "MY-UNIX:/sys/bin/my-prog/*/") ("EXPERIMENTAL;*.*.*" "MY-UNIX:/usr/Joe/development/prog/") ("EXPERIMENTAL;DOCUMENTATION;*.*.*" "MY-VAX:SYS$DISK:[JOE.DOC]") ("EXPERIMENTAL;*;*.*.*" "MY-UNIX:/usr/Joe/development/prog/*/") ("MAIL;**;*.MAIL" "MY-VAX:SYS$DISK:[JOE.MAIL.PROG...]*.MBX"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:mail;save;ideas.mail.3") @result{} #P"MY-VAX:SYS$DISK:[JOE.MAIL.PROG.SAVE]IDEAS.MBX.3" ;;;Example translations for a program that uses three files main.lisp, ;;;auxiliary.lisp, and documentation.lisp. These translations might be ;;;supplied by a software supplier as examples. ;;;For Unix with long file names (setf (logical-pathname-translations "prog") '(("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") @result{} #P"/lib/prog/documentation.lisp" ;;;For Unix with 14-character file names, using .lisp as the type (setf (logical-pathname-translations "prog") '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") ("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") @result{} #P"/lib/prog/docum.lisp" ;;;For Unix with 14-character file names, using .l as the type ;;;The second translation shortens the compiled file type to .b (setf (logical-pathname-translations "prog") `(("**;*.LISP.*" ,(logical-pathname "PROG:**;*.L.*")) (,(compile-file-pathname (logical-pathname "PROG:**;*.LISP.*")) ,(logical-pathname "PROG:**;*.B.*")) ("CODE;DOCUMENTATION.*.*" "/lib/prog/documentatio.*") ("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") @result{} #P"/lib/prog/documentatio.l" ;;;For a Cray with 6 character names and no directories, types, or versions. (setf (logical-pathname-translations "prog") (let ((l '(("MAIN" "PGMN") ("AUXILIARY" "PGAUX") ("DOCUMENTATION" "PGDOC"))) (logpath (logical-pathname "prog:code;")) (phypath (pathname "XXX"))) (append ;; Translations for source files (mapcar #'(lambda (x) (let ((log (first x)) (phy (second x))) (list (make-pathname :name log :type "LISP" :version :wild :defaults logpath) (make-pathname :name phy :defaults phypath)))) l) ;; Translations for compiled files (mapcar #'(lambda (x) (let* ((log (first x)) (phy (second x)) (com (compile-file-pathname (make-pathname :name log :type "LISP" :version :wild :defaults logpath)))) (setq phy (concatenate 'string phy "B")) (list com (make-pathname :name phy :defaults phypath)))) l)))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") @result{} #P"PGDOC" @end example @subsubheading Exceptional Situations:: If @i{host} is incorrectly supplied, an error of @i{type} @b{type-error} is signaled. @subsubheading See Also:: @b{logical-pathname}, @ref{Pathnames as Filenames} @subsubheading Notes:: Implementations can define additional @i{functions} that operate on @i{logical pathname} hosts, for example to specify additional translation rules or options. @node logical-pathname, *default-pathname-defaults*, logical-pathname-translations, Filenames Dictionary @subsection logical-pathname [Function] @code{logical-pathname} @i{pathspec} @result{} @i{logical-pathname} @subsubheading Arguments and Values:: @i{pathspec}---a @i{logical pathname}, a @i{logical pathname} @i{namestring}, or a @i{stream}. @i{logical-pathname}---a @i{logical pathname}. @subsubheading Description:: @b{logical-pathname} converts @i{pathspec} to a @i{logical pathname} and returns the new @i{logical pathname}. If @i{pathspec} is a @i{logical pathname} @i{namestring}, it should contain a host component and its following @i{colon}. If @i{pathspec} is a @i{stream}, it should be one for which @b{pathname} returns a @i{logical pathname}. If @i{pathspec} is a @i{stream}, the @i{stream} can be either open or closed. @b{logical-pathname} returns the same @i{logical pathname} after a file is closed as it did when the file was open. It is an error if @i{pathspec} is a @i{stream} that is created with @b{make-two-way-stream}, @b{make-echo-stream}, @b{make-broadcast-stream}, @b{make-concatenated-stream}, @b{make-string-input-stream}, or @b{make-string-output-stream}. @subsubheading Exceptional Situations:: Signals an error of @i{type} @b{type-error} if @i{pathspec} isn't supplied correctly. @subsubheading See Also:: @b{logical-pathname}, @ref{translate-logical-pathname} , @ref{Logical Pathnames} @node *default-pathname-defaults*, namestring, logical-pathname, Filenames Dictionary @subsection *default-pathname-defaults* [Variable] @subsubheading Value Type:: a @i{pathname} @i{object}. @subsubheading Initial Value:: An @i{implementation-dependent} @i{pathname}, typically in the working directory that was current when @r{Common Lisp} was started up. @subsubheading Description:: a @i{pathname}, used as the default whenever a @i{function} needs a default @i{pathname} and one is not supplied. @subsubheading Examples:: @example ;; This example illustrates a possible usage for a hypothetical Lisp running on a ;; DEC TOPS-20 file system. Since pathname conventions vary between Lisp ;; implementations and host file system types, it is not possible to provide a ;; general-purpose, conforming example. *default-pathname-defaults* @result{} #P"PS:" (merge-pathnames (make-pathname :name "CALENDAR")) @result{} #P"PS:CALENDAR" (let ((*default-pathname-defaults* (pathname ""))) (merge-pathnames (make-pathname :name "CALENDAR"))) @result{} #P"CALENDAR" @end example @subsubheading Affected By:: The @i{implementation}. @node namestring, parse-namestring, *default-pathname-defaults*, Filenames Dictionary @subsection namestring, file-namestring, directory-namestring, @subheading host-namestring, enough-namestring @flushright @i{[Function]} @end flushright @code{namestring} @i{pathname} @result{} @i{namestring} @code{file-namestring} @i{pathname} @result{} @i{namestring} @code{directory-namestring} @i{pathname} @result{} @i{namestring} @code{host-namestring} @i{pathname} @result{} @i{namestring} @code{enough-namestring} @i{pathname @r{&optional} defaults} @result{} @i{namestring} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @i{defaults}---a @i{pathname designator}. The default is the @i{value} of @b{*default-pathname-defaults*}. @i{namestring}---a @i{string} or @b{nil}. [Editorial Note by KMP: Under what circumstances can NIL be returned??] @subsubheading Description:: These functions convert @i{pathname} into a namestring. The name represented by @i{pathname} is returned as a @i{namestring} in an @i{implementation-dependent} canonical form. @b{namestring} returns the full form of @i{pathname}. @b{file-namestring} returns just the name, type, and version components of @i{pathname}. @b{directory-namestring} returns the directory name portion. @b{host-namestring} returns the host name. @b{enough-namestring} returns an abbreviated namestring that is just sufficient to identify the file named by @i{pathname} when considered relative to the @i{defaults}. It is required that @example (merge-pathnames (enough-namestring pathname defaults) defaults) @equiv{} (merge-pathnames (parse-namestring pathname nil defaults) defaults) @end example in all cases, and the result of @b{enough-namestring} is the shortest reasonable @i{string} that will satisfy this criterion. It is not necessarily possible to construct a valid @i{namestring} by concatenating some of the three shorter @i{namestrings} in some order. @subsubheading Examples:: @example (namestring "getty") @result{} "getty" (setq q (make-pathname :host "kathy" :directory (pathname-directory *default-pathname-defaults*) :name "getty")) @result{} #S(PATHNAME :HOST "kathy" :DEVICE NIL :DIRECTORY @i{directory-name} :NAME "getty" :TYPE NIL :VERSION NIL) (file-namestring q) @result{} "getty" (directory-namestring q) @result{} @i{directory-name} (host-namestring q) @result{} "kathy" @end example @example ;;;Using Unix syntax and the wildcard conventions used by the ;;;particular version of Unix on which this example was created: (namestring (translate-pathname "/usr/dmr/hacks/frob.l" "/usr/d*/hacks/*.l" "/usr/d*/backup/hacks/backup-*.*")) @result{} "/usr/dmr/backup/hacks/backup-frob.l" (namestring (translate-pathname "/usr/dmr/hacks/frob.l" "/usr/d*/hacks/fr*.l" "/usr/d*/backup/hacks/backup-*.*")) @result{} "/usr/dmr/backup/hacks/backup-ob.l" ;;;This is similar to the above example but uses two different hosts, ;;;U: which is a Unix and V: which is a VMS. Note the translation ;;;of file type and alphabetic case conventions. (namestring (translate-pathname "U:/usr/dmr/hacks/frob.l" "U:/usr/d*/hacks/*.l" "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*")) @result{} "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-FROB.LSP" (namestring (translate-pathname "U:/usr/dmr/hacks/frob.l" "U:/usr/d*/hacks/fr*.l" "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*")) @result{} "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-OB.LSP" @end example @subsubheading See Also:: @ref{truename} , @ref{merge-pathnames} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node parse-namestring, wild-pathname-p, namestring, Filenames Dictionary @subsection parse-namestring [Function] @code{parse-namestring} @i{thing @r{&optional} host default-pathname @r{&key} start end junk-allowed}@* @result{} @i{pathname, position} @subsubheading Arguments and Values:: @i{thing}---a @i{string}, a @i{pathname}, or a @i{stream associated with a file}. @i{host}---a @i{valid pathname host}, a @i{logical host}, or @b{nil}. @i{default-pathname}---a @i{pathname designator}. The default is the @i{value} of @b{*default-pathname-defaults*}. @i{start}, @i{end}---@i{bounding index designators} of @i{thing}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{junk-allowed}---a @i{generalized boolean}. The default is @i{false}. @i{pathname}---a @i{pathname}, or @b{nil}. @i{position}---a @i{bounding index designator} for @i{thing}. @subsubheading Description:: Converts @i{thing} into a @i{pathname}. The @i{host} supplies a host name with respect to which the parsing occurs. If @i{thing} is a @i{stream associated with a file}, processing proceeds as if the @i{pathname} used to open that @i{file} had been supplied instead. If @i{thing} is a @i{pathname}, the @i{host} and the host component of @i{thing} are compared. If they match, two values are immediately returned: @i{thing} and @i{start}; otherwise (if they do not match), an error is signaled. Otherwise (if @i{thing} is a @i{string}), @b{parse-namestring} parses the name of a @i{file} within the substring of @i{thing} bounded by @i{start} and @i{end}. If @i{thing} is a @i{string} then the substring of @i{thing} @i{bounded} by @i{start} and @i{end} is parsed into a @i{pathname} as follows: @table @asis @item @t{*} If @i{host} is a @i{logical host} then @i{thing} is parsed as a @i{logical pathname} @i{namestring} on the @i{host}. @item @t{*} If @i{host} is @b{nil} and @i{thing} is a syntactically valid @i{logical pathname} @i{namestring} containing an explicit host, then it is parsed as a @i{logical pathname} @i{namestring}. @item @t{*} If @i{host} is @b{nil}, @i{default-pathname} is a @i{logical pathname}, and @i{thing} is a syntactically valid @i{logical pathname} @i{namestring} without an explicit host, then it is parsed as a @i{logical pathname} @i{namestring} on the host that is the host component of @i{default-pathname}. @item @t{*} Otherwise, the parsing of @i{thing} is @i{implementation-defined}. @end table In the first of these cases, the host portion of the @i{logical pathname} namestring and its following @i{colon} are optional. If the host portion of the namestring and @i{host} are both present and do not match, an error is signaled. If @i{junk-allowed} is @i{true}, then the @i{primary value} is the @i{pathname} parsed or, if no syntactically correct @i{pathname} was seen, @b{nil}. If @i{junk-allowed} is @i{false}, then the entire substring is scanned, and the @i{primary value} is the @i{pathname} parsed. In either case, the @i{secondary value} is the index into @i{thing} of the delimiter that terminated the parse, or the index beyond the substring if the parse terminated at the end of the substring (as will always be the case if @i{junk-allowed} is @i{false}). Parsing a @i{null} @i{string} always succeeds, producing a @i{pathname} with all components (except the host) equal to @b{nil}. If @i{thing} contains an explicit host name and no explicit device name, then it is @i{implementation-defined} whether @b{parse-namestring} will supply the standard default device for that host as the device component of the resulting @i{pathname}. @subsubheading Examples:: @example (setq q (parse-namestring "test")) @result{} #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL) (pathnamep q) @result{} @i{true} (parse-namestring "test") @result{} #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL), 4 (setq s (open @i{xxx})) @result{} # (parse-namestring s) @result{} #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME @i{xxx} :TYPE NIL :VERSION NIL), 0 (parse-namestring "test" nil nil :start 2 :end 4 ) @result{} #S(PATHNAME ...), 15 (parse-namestring "foo.lisp") @result{} #P"foo.lisp" @end example @subsubheading Exceptional Situations:: If @i{junk-allowed} is @i{false}, an error of @i{type} @b{parse-error} is signaled if @i{thing} does not consist entirely of the representation of a @i{pathname}, possibly surrounded on either side by @i{whitespace}_1 characters if that is appropriate to the cultural conventions of the implementation. If @i{host} is supplied and not @b{nil}, and @i{thing} contains a manifest host name, an error of @i{type} @b{error} is signaled if the hosts do not match. If @i{thing} is a @i{logical pathname} namestring and if the host portion of the namestring and @i{host} are both present and do not match, an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{->UNSPECIFIC as a Component Value}, @ref{Pathnames as Filenames} @node wild-pathname-p, pathname-match-p, parse-namestring, Filenames Dictionary @subsection wild-pathname-p [Function] @code{wild-pathname-p} @i{pathname @r{&optional} field-key} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @i{Field-key}---one of @t{:host}, @t{:device} @t{:directory}, @t{:name}, @t{:type}, @t{:version}, or @b{nil}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{wild-pathname-p} tests @i{pathname} for the presence of wildcard components. If @i{pathname} is a @i{pathname} (as returned by @b{pathname}) it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. If @i{field-key} is not supplied or @b{nil}, @b{wild-pathname-p} returns true if @i{pathname} has any wildcard components, @b{nil} if @i{pathname} has none. If @i{field-key} is @i{non-nil}, @b{wild-pathname-p} returns true if the indicated component of @i{pathname} is a wildcard, @b{nil} if the component is not a wildcard. @subsubheading Examples:: @example ;;;The following examples are not portable. They are written to run ;;;with particular file systems and particular wildcard conventions. ;;;Other implementations will behave differently. These examples are ;;;intended to be illustrative, not to be prescriptive. (wild-pathname-p (make-pathname :name :wild)) @result{} @i{true} (wild-pathname-p (make-pathname :name :wild) :name) @result{} @i{true} (wild-pathname-p (make-pathname :name :wild) :type) @result{} @i{false} (wild-pathname-p (pathname "s:>foo>**>")) @result{} @i{true} ;Lispm (wild-pathname-p (pathname :name "F*O")) @result{} @i{true} ;Most places @end example @subsubheading Exceptional Situations:: If @i{pathname} is not a @i{pathname}, a @i{string}, or a @i{stream associated with a file} an error of @i{type} @b{type-error} is signaled. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @subsubheading Notes:: Not all implementations support wildcards in all fields. See @ref{->WILD as a Component Value} and @ref{Restrictions on Wildcard Pathnames}. @node pathname-match-p, translate-logical-pathname, wild-pathname-p, Filenames Dictionary @subsection pathname-match-p [Function] @code{pathname-match-p} @i{pathname wildcard} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @i{wildcard}---a @i{designator} for a @i{wild} @i{pathname}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{pathname-match-p} returns true if @i{pathname} matches @i{wildcard}, otherwise @b{nil}. The matching rules are @i{implementation-defined} but should be consistent with @b{directory}. Missing components of @i{wildcard} default to @t{:wild}. It is valid for @i{pathname} to be a wild @i{pathname}; a wildcard field in @i{pathname} only matches a wildcard field in @i{wildcard} (@i{i.e.}, @b{pathname-match-p} is not commutative). It is valid for @i{wildcard} to be a non-wild @i{pathname}. @subsubheading Exceptional Situations:: If @i{pathname} or @i{wildcard} is not a @i{pathname}, @i{string}, or @i{stream associated with a file} an error of @i{type} @b{type-error} is signaled. @subsubheading See Also:: @ref{directory} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node translate-logical-pathname, translate-pathname, pathname-match-p, Filenames Dictionary @subsection translate-logical-pathname [Function] @code{translate-logical-pathname} @i{pathname @r{&key}} @result{} @i{physical-pathname} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}, or a @i{logical pathname} @i{namestring}. @i{physical-pathname}---a @i{physical pathname}. @subsubheading Description:: Translates @i{pathname} to a @i{physical pathname}, which it returns. If @i{pathname} is a @i{stream}, the @i{stream} can be either open or closed. @b{translate-logical-pathname} returns the same physical pathname after a file is closed as it did when the file was open. It is an error if @i{pathname} is a @i{stream} that is created with @b{make-two-way-stream}, @b{make-echo-stream}, @b{make-broadcast-stream}, @b{make-concatenated-stream}, @b{make-string-input-stream}, @b{make-string-output-stream}. If @i{pathname} is a @i{logical pathname} namestring, the host portion of the @i{logical pathname} namestring and its following @i{colon} are required. @i{Pathname} is first coerced to a @i{pathname}. If the coerced @i{pathname} is a physical pathname, it is returned. If the coerced @i{pathname} is a @i{logical pathname}, the first matching translation (according to @b{pathname-match-p}) of the @i{logical pathname} host is applied, as if by calling @b{translate-pathname}. If the result is a @i{logical pathname}, this process is repeated. When the result is finally a physical pathname, it is returned. If no translation matches, an error is signaled. @b{translate-logical-pathname} might perform additional translations, typically to provide translation of file types to local naming conventions, to accomodate physical file systems with limited length names, or to deal with special character requirements such as translating hyphens to underscores or uppercase letters to lowercase. Any such additional translations are @i{implementation-defined}. Some implementations do no additional translations. There are no specified keyword arguments for @b{translate-logical-pathname}, but implementations are permitted to extend it by adding keyword arguments. @subsubheading Examples:: See @b{logical-pathname-translations}. @subsubheading Exceptional Situations:: If @i{pathname} is incorrectly supplied, an error of @i{type} @b{type-error} is signaled. If no translation matches, an error of @i{type} @b{file-error} is signaled. [Editorial Note by KMP: Is file-error really right, or should it be pathname-error?] @subsubheading See Also:: @ref{logical-pathname} , @ref{logical-pathname-translations} , @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node translate-pathname, merge-pathnames, translate-logical-pathname, Filenames Dictionary @subsection translate-pathname [Function] @code{translate-pathname} @i{source from-wildcard to-wildcard @r{&key}}@* @result{} @i{translated-pathname} @subsubheading Arguments and Values:: @i{source}---a @i{pathname designator}. @i{from-wildcard}---a @i{pathname designator}. @i{to-wildcard}---a @i{pathname designator}. @i{translated-pathname}---a @i{pathname}. @subsubheading Description:: @b{translate-pathname} translates @i{source} (that matches @i{from-wildcard}) into a corresponding @i{pathname} that matches @i{to-wildcard}, and returns the corresponding @i{pathname}. The resulting @i{pathname} is @i{to-wildcard} with each wildcard or missing field replaced by a portion of @i{source}. A ``wildcard field'' is a @i{pathname} component with a value of @t{:wild}, a @t{:wild} element of a @i{list}-valued directory component, or an @i{implementation-defined} portion of a component, such as the @t{"*"} in the complex wildcard string @t{"foo*bar"} that some implementations support. An implementation that adds other wildcard features, such as regular expressions, must define how @b{translate-pathname} extends to those features. A ``missing field'' is a @i{pathname} component with a value of @b{nil}. The portion of @i{source} that is copied into the resulting @i{pathname} is @i{implementation-defined}. Typically it is determined by the user interface conventions of the file systems involved. Usually it is the portion of @i{source} that matches a wildcard field of @i{from-wildcard} that is in the same position as the wildcard or missing field of @i{to-wildcard}. If there is no wildcard field in @i{from-wildcard} at that position, then usually it is the entire corresponding @i{pathname} component of @i{source}, or in the case of a @i{list}-valued directory component, the entire corresponding @i{list} element. During the copying of a portion of @i{source} into the resulting @i{pathname}, additional @i{implementation-defined} translations of @i{case} or file naming conventions might occur, especially when @i{from-wildcard} and @i{to-wildcard} are for different hosts. It is valid for @i{source} to be a wild @i{pathname}; in general this will produce a wild result. It is valid for @i{from-wildcard} and/or @i{to-wildcard} to be non-wild @i{pathnames}. There are no specified keyword arguments for @b{translate-pathname}, but implementations are permitted to extend it by adding keyword arguments. @b{translate-pathname} maps customary case in @i{source} into customary case in the output @i{pathname}. @subsubheading Examples:: @example ;; The results of the following five forms are all implementation-dependent. ;; The second item in particular is shown with multiple results just to ;; emphasize one of many particular variations which commonly occurs. (pathname-name (translate-pathname "foobar" "foo*" "*baz")) @result{} "barbaz" (pathname-name (translate-pathname "foobar" "foo*" "*")) @result{} "foobar" @i{OR}@result{} "bar" (pathname-name (translate-pathname "foobar" "*" "foo*")) @result{} "foofoobar" (pathname-name (translate-pathname "bar" "*" "foo*")) @result{} "foobar" (pathname-name (translate-pathname "foobar" "foo*" "baz*")) @result{} "bazbar" (defun translate-logical-pathname-1 (pathname rules) (let ((rule (assoc pathname rules :test #'pathname-match-p))) (unless rule (error "No translation rule for ~A" pathname)) (translate-pathname pathname (first rule) (second rule)))) (translate-logical-pathname-1 "FOO:CODE;BASIC.LISP" '(("FOO:DOCUMENTATION;" "MY-UNIX:/doc/foo/") ("FOO:CODE;" "MY-UNIX:/lib/foo/") ("FOO:PATCHES;*;" "MY-UNIX:/lib/foo/patch/*/"))) @result{} #P"MY-UNIX:/lib/foo/basic.l" ;;;This example assumes one particular set of wildcard conventions ;;;Not all file systems will run this example exactly as written (defun rename-files (from to) (dolist (file (directory from)) (rename-file file (translate-pathname file from to)))) (rename-files "/usr/me/*.lisp" "/dev/her/*.l") ;Renames /usr/me/init.lisp to /dev/her/init.l (rename-files "/usr/me/pcl*/*" "/sys/pcl/*/") ;Renames /usr/me/pcl-5-may/low.lisp to /sys/pcl/pcl-5-may/low.lisp ;In some file systems the result might be /sys/pcl/5-may/low.lisp (rename-files "/usr/me/pcl*/*" "/sys/library/*/") ;Renames /usr/me/pcl-5-may/low.lisp to /sys/library/pcl-5-may/low.lisp ;In some file systems the result might be /sys/library/5-may/low.lisp (rename-files "/usr/me/foo.bar" "/usr/me2/") ;Renames /usr/me/foo.bar to /usr/me2/foo.bar (rename-files "/usr/joe/*-recipes.text" "/usr/jim/cookbook/joe's-*-rec.text") ;Renames /usr/joe/lamb-recipes.text to /usr/jim/cookbook/joe's-lamb-rec.text ;Renames /usr/joe/pork-recipes.text to /usr/jim/cookbook/joe's-pork-rec.text ;Renames /usr/joe/veg-recipes.text to /usr/jim/cookbook/joe's-veg-rec.text @end example @subsubheading Exceptional Situations:: If any of @i{source}, @i{from-wildcard}, or @i{to-wildcard} is not a @i{pathname}, a @i{string}, or a @i{stream associated with a file} an error of @i{type} @b{type-error} is signaled. @t{(pathname-match-p @i{source from-wildcard})} must be true or an error of @i{type} @b{error} is signaled. @subsubheading See Also:: @ref{namestring} , @ref{pathname-host} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @subsubheading Notes:: The exact behavior of @b{translate-pathname} cannot be dictated by the @r{Common Lisp} language and must be allowed to vary, depending on the user interface conventions of the file systems involved. The following is an implementation guideline. One file system performs this operation by examining each piece of the three @i{pathnames} in turn, where a piece is a @i{pathname} component or a @i{list} element of a structured component such as a hierarchical directory. Hierarchical directory elements in @i{from-wildcard} and @i{to-wildcard} are matched by whether they are wildcards, not by depth in the directory hierarchy. If the piece in @i{to-wildcard} is present and not wild, it is copied into the result. If the piece in @i{to-wildcard} is @t{:wild} or @b{nil}, the piece in @i{source} is copied into the result. Otherwise, the piece in @i{to-wildcard} might be a complex wildcard such as @t{"foo*bar"} and the piece in @i{from-wildcard} should be wild; the portion of the piece in @i{source} that matches the wildcard portion of the piece in @i{from-wildcard} replaces the wildcard portion of the piece in @i{to-wildcard} and the value produced is used in the result. @node merge-pathnames, , translate-pathname, Filenames Dictionary @subsection merge-pathnames [Function] @code{merge-pathnames} @i{pathname @r{&optional} default-pathname default-version}@* @result{} @i{merged-pathname} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @i{default-pathname}---a @i{pathname designator}. The default is the @i{value} of @b{*default-pathname-defaults*}. @i{default-version}---a @i{valid pathname version}. The default is @t{:newest}. @i{merged-pathname}---a @i{pathname}. @subsubheading Description:: Constructs a @i{pathname} from @i{pathname} by filling in any unsupplied components with the corresponding values from @i{default-pathname} and @i{default-version}. Defaulting of pathname components is done by filling in components taken from another @i{pathname}. This is especially useful for cases such as a program that has an input file and an output file. Unspecified components of the output pathname will come from the input pathname, except that the type should not default to the type of the input pathname but rather to the appropriate default type for output from the program; for example, see the @i{function} @b{compile-file-pathname}. If no version is supplied, @i{default-version} is used. If @i{default-version} is @b{nil}, the version component will remain unchanged. If @i{pathname} explicitly specifies a host and not a device, and if the host component of @i{default-pathname} matches the host component of @i{pathname}, then the device is taken from the @i{default-pathname}; otherwise the device will be the default file device for that host. If @i{pathname} does not specify a host, device, directory, name, or type, each such component is copied from @i{default-pathname}. If @i{pathname} does not specify a name, then the version, if not provided, will come from @i{default-pathname}, just like the other components. If @i{pathname} does specify a name, then the version is not affected by @i{default-pathname}. If this process leaves the version missing, the @i{default-version} is used. If the host's file name syntax provides a way to input a version without a name or type, the user can let the name and type default but supply a version different from the one in @i{default-pathname}. If @i{pathname} is a @i{stream}, @i{pathname} effectively becomes @t{(pathname @i{pathname})}. @b{merge-pathnames} can be used on either an open or a closed @i{stream}. If @i{pathname} is a @i{pathname} it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. @b{merge-pathnames} recognizes a @i{logical pathname} @i{namestring} when @i{default-pathname} is a @i{logical pathname}, or when the @i{namestring} begins with the name of a defined @i{logical host} followed by a @i{colon}. In the first of these two cases, the host portion of the @i{logical pathname} @i{namestring} and its following @i{colon} are optional. @b{merge-pathnames} returns a @i{logical pathname} if and only if its first argument is a @i{logical pathname}, or its first argument is a @i{logical pathname} @i{namestring} with an explicit host, or its first argument does not specify a host and the @i{default-pathname} is a @i{logical pathname}. @i{Pathname} merging treats a relative directory specially. If @t{(pathname-directory @i{pathname})} is a @i{list} whose @i{car} is @t{:relative}, and @t{(pathname-directory @i{default-pathname})} is a @i{list}, then the merged directory is the value of @example (append (pathname-directory @i{default-pathname}) (cdr ;remove :relative from the front (pathname-directory @i{pathname}))) @end example except that if the resulting @i{list} contains a @i{string} or @t{:wild} immediately followed by @t{:back}, both of them are removed. This removal of redundant @t{:back} @i{keywords} is repeated as many times as possible. If @t{(pathname-directory @i{default-pathname})} is not a @i{list} or @t{(pathname-directory @i{pathname})} is not a @i{list} whose @i{car} is @t{:relative}, the merged directory is @t{(or (pathname-directory @i{pathname}) (pathname-directory @i{default-pathname}))} @b{merge-pathnames} maps customary case in @i{pathname} into customary case in the output @i{pathname}. @subsubheading Examples:: @example (merge-pathnames "CMUC::FORMAT" "CMUC::PS:.FASL") @result{} #P"CMUC::PS:FORMAT.FASL.0" @end example @subsubheading See Also:: @b{*default-pathname-defaults*}, @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @subsubheading Notes:: The net effect is that if just a name is supplied, the host, device, directory, and type will come from @i{default-pathname}, but the version will come from @i{default-version}. If nothing or just a directory is supplied, the name, type, and version will come from @i{default-pathname} together. @c end of including dict-pathnames @c %**end of chapter gcl-2.6.14/info/iteration.texi0000755000175000017500000000641014360276512014623 0ustar cammcamm@node Iteration and Tests, User Interface, Structures, Top @chapter Iteration and Tests @deffn {Macro} DO-EXTERNAL-SYMBOLS Package:LISP Syntax: @example (do-external-symbols (var [package [result-form]]) @{decl@}* @{tag | statement@}*) @end example Executes STATEMENTs once for each external symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). @end deffn @deffn {Special Form} DO* Package:LISP Syntax: @example (do* (@{(var [init [step]])@}*) (endtest @{result@}*) @{decl@}* @{tag | statement@}*) @end example Just like DO, but performs variable bindings and assignments in serial, just like LET* and SETQ do. @end deffn @deffn {Macro} DO-ALL-SYMBOLS Package:LISP Syntax: @example (do-all-symbols (var [result-form]) @{decl@}* @{tag | statement@}*) @end example Executes STATEMENTs once for each symbol in each package, with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). @end deffn @defun YES-OR-NO-P (&optional (format-string nil) &rest args) Package:LISP Asks the user a question whose answer is either 'YES' or 'NO'. If FORMAT- STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Yes or No)" is printed. Otherwise, no prompt will appear. @end defun @defun MAPHASH #'hash-table Package:LISP For each entry in HASH-TABLE, calls FUNCTION on the key and value of the entry; returns NIL. @end defun @defun MAPCAR (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs and returns the results as a list. @end defun @deffn {Special Form} DOLIST Package:LISP Syntax: @example (dolist (var listform [result]) @{decl@}* @{tag | statement@}*) @end example Executes STATEMENTs, with VAR bound to each member of the list value of LISTFORM. Then returns the value(s) of RESULT (which defaults to NIL). @end deffn @defun EQ (x y) Package:LISP Returns T if X and Y are the same identical object; NIL otherwise. @end defun @defun EQUALP (x y) Package:LISP Returns T if X and Y are EQUAL, if they are characters and satisfy CHAR-EQUAL, if they are numbers and have the same numerical value, or if they have components that are all EQUALP. Returns NIL otherwise. @end defun @defun EQUAL (x y) Package:LISP Returns T if X and Y are EQL or if they are of the same type and corresponding components are EQUAL. Returns NIL otherwise. Strings and bit-vectors are EQUAL if they are the same length and have identical components. Other arrays must be EQ to be EQUAL. @end defun @deffn {Macro} DO-SYMBOLS Package:LISP Syntax: @example (do-symbols (var [package [result-form]]) @{decl@}* @{tag | statement@}*) @end example Executes STATEMENTs once for each symbol in the PACKAGE (which defaults to the current package), with VAR bound to the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). @end deffn @deffn {Special Form} LOOP Package:LISP Syntax: @example (loop @{form@}*) @end example Executes FORMs repeatedly until exited by a THROW or RETURN. The FORMs are surrounded by an implicit NIL block. @end deffn gcl-2.6.14/info/gcl.info-30000644000175000017500000107147014360276512013522 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: VALUES Forms as Places, Next: THE Forms as Places, Prev: Function Call Forms as Places, Up: Kinds of Places 5.1.2.3 VALUES Forms as Places .............................. A values form can be used as a place, provided that each of its subforms is also a place form. A form such as (setf (values place-1 \dots place-n) values-form) does the following: 1. The subforms of each nested place are evaluated in left-to-right order. 2. The values-form is evaluated, and the first store variable from each place is bound to its return values as if by multiple-value-bind. 3. If the setf expansion for any place involves more than one store variable, then the additional store variables are bound to nil. 4. The storing forms for each place are evaluated in left-to-right order. The storing form in the setf expansion of values returns as multiple values_2 the values of the store variables in step 2. That is, the number of values returned is the same as the number of place forms. This may be more or fewer values than are produced by the values-form.  File: gcl.info, Node: THE Forms as Places, Next: APPLY Forms as Places, Prev: VALUES Forms as Places, Up: Kinds of Places 5.1.2.4 THE Forms as Places ........................... A the form can be used as a place, in which case the declaration is transferred to the newvalue form, and the resulting setf is analyzed. For example, (setf (the integer (cadr x)) (+ y 3)) is processed as if it were (setf (cadr x) (the integer (+ y 3)))  File: gcl.info, Node: APPLY Forms as Places, Next: Setf Expansions and Places, Prev: THE Forms as Places, Up: Kinds of Places 5.1.2.5 APPLY Forms as Places ............................. The following situations involving setf of apply must be supported: * (setf (apply #'aref array {subscript}* more-subscripts) new-element) * (setf (apply #'bit array {subscript}* more-subscripts) new-element) * (setf (apply #'sbit array {subscript}* more-subscripts) new-element) In all three cases, the element of array designated by the concatenation of subscripts and more-subscripts (i.e., the same element which would be read by the call to apply if it were not part of a setf form) is changed to have the value given by new-element. For these usages, the function name (aref, bit, or sbit) must refer to the global function definition, rather than a locally defined function. No other standardized function is required to be supported, but an implementation may define such support. An implementation may also define support for implementation-defined operators. If a user-defined function is used in this context, the following equivalence is true, except that care is taken to preserve proper left-to-right evaluation of argument subforms: (setf (apply #'name {arg}*) val) == (apply #'(setf name) val {arg}*)  File: gcl.info, Node: Setf Expansions and Places, Next: Macro Forms as Places, Prev: APPLY Forms as Places, Up: Kinds of Places 5.1.2.6 Setf Expansions and Places .................................. Any compound form for which the operator has a setf expander defined can be used as a place. The operator must refer to the global function definition, rather than a locally defined function or macro.  File: gcl.info, Node: Macro Forms as Places, Next: Symbol Macros as Places, Prev: Setf Expansions and Places, Up: Kinds of Places 5.1.2.7 Macro Forms as Places ............................. A macro form can be used as a place, in which case Common Lisp expands the macro form as if by macroexpand-1 and then uses the macro expansion in place of the original place. Such macro expansion is attempted only after exhausting all other possibilities other than expanding into a call to a function named (setf reader).  File: gcl.info, Node: Symbol Macros as Places, Next: Other Compound Forms as Places, Prev: Macro Forms as Places, Up: Kinds of Places 5.1.2.8 Symbol Macros as Places ............................... A reference to a symbol that has been established as a symbol macro can be used as a place. In this case, setf expands the reference and then analyzes the resulting form.  File: gcl.info, Node: Other Compound Forms as Places, Prev: Symbol Macros as Places, Up: Kinds of Places 5.1.2.9 Other Compound Forms as Places ...................................... For any other compound form for which the operator is a symbol f, the setf form expands into a call to the function named (setf f). The first argument in the newly constructed function form is newvalue and the remaining arguments are the remaining elements of place. This expansion occurs regardless of whether f or (setf f) is defined as a function locally, globally, or not at all. For example, (setf (f arg1 arg2 ...) new-value) expands into a form with the same effect and value as (let ((#:temp-1 arg1) ;force correct order of evaluation (#:temp-2 arg2) ... (#:temp-0 new-value)) (funcall (function (setf f)) #:temp-0 #:temp-1 #:temp-2...)) A function named (setf f) must return its first argument as its only value in order to preserve the semantics of setf.  File: gcl.info, Node: Treatment of Other Macros Based on SETF, Prev: Kinds of Places, Up: Generalized Reference 5.1.3 Treatment of Other Macros Based on SETF --------------------------------------------- For each of the "read-modify-write" operators in Figure 5-9, and for any additional macros defined by the programmer using define-modify-macro, an exception is made to the normal rule of left-to-right evaluation of arguments. Evaluation of argument forms occurs in left-to-right order, with the exception that for the place argument, the actual read of the "old value" from that place happens after all of the argument form evaluations, and just before a "new value" is computed and written back into the place. Specifically, each of these operators can be viewed as involving a form with the following general syntax: (operator {preceding-form}* place {following-form}*) The evaluation of each such form proceeds like this: 1. Evaluate each of the preceding-forms, in left-to-right order. 2. Evaluate the subforms of the place, in the order specified by the second value of the setf expansion for that place. 3. Evaluate each of the following-forms, in left-to-right order. 4. Read the old value from place. 5. Compute the new value. 6. Store the new value into place. decf pop pushnew incf push remf Figure 5-9: Read-Modify-Write Macros  File: gcl.info, Node: Transfer of Control to an Exit Point, Next: Data and Control Flow Dictionary, Prev: Generalized Reference, Up: Data and Control Flow 5.2 Transfer of Control to an Exit Point ======================================== When a transfer of control is initiated by go, return-from, or throw the following events occur in order to accomplish the transfer of control. Note that for go, the exit point is the form within the tagbody that is being executed at the time the go is performed; for return-from, the exit point is the corresponding block form; and for throw, the exit point is the corresponding catch form. 1. Intervening exit points are "abandoned" (i.e., their extent ends and it is no longer valid to attempt to transfer control through them). 2. The cleanup clauses of any intervening unwind-protect clauses are evaluated. 3. Intervening dynamic bindings of special variables, catch tags, condition handlers, and restarts are undone. 4. The extent of the exit point being invoked ends, and control is passed to the target. The extent of an exit being "abandoned" because it is being passed over ends as soon as the transfer of control is initiated. That is, event 1 occurs at the beginning of the initiation of the transfer of control. The consequences are undefined if an attempt is made to transfer control to an exit point whose dynamic extent has ended. Events 2 and 3 are actually performed interleaved, in the order corresponding to the reverse order in which they were established. The effect of this is that the cleanup clauses of an unwind-protect see the same dynamic bindings of variables and catch tags as were visible when the unwind-protect was entered. Event 4 occurs at the end of the transfer of control.  File: gcl.info, Node: Data and Control Flow Dictionary, Prev: Transfer of Control to an Exit Point, Up: Data and Control Flow 5.3 Data and Control Flow Dictionary ==================================== * Menu: * apply:: * defun:: * fdefinition:: * fboundp:: * fmakunbound:: * flet:: * funcall:: * function (Special Operator):: * function-lambda-expression:: * functionp:: * compiled-function-p:: * call-arguments-limit:: * lambda-list-keywords:: * lambda-parameters-limit:: * defconstant:: * defparameter:: * destructuring-bind:: * let:: * progv:: * setq:: * psetq:: * block:: * catch:: * go:: * return-from:: * return:: * tagbody:: * throw:: * unwind-protect:: * nil:: * not:: * t:: * eq:: * eql:: * equal:: * equalp:: * identity:: * complement:: * constantly:: * every:: * and:: * cond:: * if:: * or:: * when:: * case:: * typecase:: * multiple-value-bind:: * multiple-value-call:: * multiple-value-list:: * multiple-value-prog1:: * multiple-value-setq:: * values:: * values-list:: * multiple-values-limit:: * nth-value:: * prog:: * prog1:: * progn:: * define-modify-macro:: * defsetf:: * define-setf-expander:: * get-setf-expansion:: * setf:: * shiftf:: * rotatef:: * control-error:: * program-error:: * undefined-function::  File: gcl.info, Node: apply, Next: defun, Prev: Data and Control Flow Dictionary, Up: Data and Control Flow Dictionary 5.3.1 apply [Function] ---------------------- 'apply' function &rest args^+ => {result}* Arguments and Values:: ...................... function--a function designator. args--a spreadable argument list designator. results--the values returned by function. Description:: ............. Applies the function to the args. When the function receives its arguments via &rest, it is permissible (but not required) for the implementation to bind the rest parameter to an object that shares structure with the last argument to apply. Because a function can neither detect whether it was called via apply nor whether (if so) the last argument to apply was a constant, conforming programs must neither rely on the list structure of a rest list to be freshly consed, nor modify that list structure. setf can be used with apply in certain circumstances; see *note APPLY Forms as Places::. Examples:: .......... (setq f '+) => + (apply f '(1 2)) => 3 (setq f #'-) => # (apply f '(1 2)) => -1 (apply #'max 3 5 '(2 7 3)) => 7 (apply 'cons '((+ 2 3) 4)) => ((+ 2 3) . 4) (apply #'+ '()) => 0 (defparameter *some-list* '(a b c)) (defun strange-test (&rest x) (eq x *some-list*)) (apply #'strange-test *some-list*) => implementation-dependent (defun bad-boy (&rest x) (rplacd x 'y)) (bad-boy 'a 'b 'c) has undefined consequences. (apply #'bad-boy *some-list*) has undefined consequences. (defun foo (size &rest keys &key double &allow-other-keys) (let ((v (apply #'make-array size :allow-other-keys t keys))) (if double (concatenate (type-of v) v v) v))) (foo 4 :initial-contents '(a b c d) :double t) => #(A B C D A B C D) See Also:: .......... *note funcall:: , *note fdefinition:: , function, *note Evaluation::, *note APPLY Forms as Places::  File: gcl.info, Node: defun, Next: fdefinition, Prev: apply, Up: Data and Control Flow Dictionary 5.3.2 defun [Macro] ------------------- 'defun' function-name lambda-list [[{declaration}* | documentation]] {form}* => function-name Arguments and Values:: ...................... function-name--a function name. lambda-list--an ordinary lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. forms--an implicit progn. block-name--the function block name of the function-name. Description:: ............. Defines a new function named function-name in the global environment. The body of the function defined by defun consists of forms; they are executed as an implicit progn when the function is called. defun can be used to define a new function, to install a corrected version of an incorrect definition, to redefine an already-defined function, or to redefine a macro as a function. defun implicitly puts a block named block-name around the body forms (but not the forms in the lambda-list) of the function defined. Documentation is attached as a documentation string to name (as kind function) and to the function object. Evaluating defun causes function-name to be a global name for the function specified by the lambda expression (lambda lambda-list [[{declaration}* | documentation]] (block block-name {form}*)) processed in the lexical environment in which defun was executed. (None of the arguments are evaluated at macro expansion time.) defun is not required to perform any compile-time side effects. In particular, defun does not make the function definition available at compile time. An implementation may choose to store information about the function for the purposes of compile-time error-checking (such as checking the number of arguments on calls), or to enable the function to be expanded inline. Examples:: .......... (defun recur (x) (when (> x 0) (recur (1- x)))) => RECUR (defun ex (a b &optional c (d 66) &rest keys &key test (start 0)) (list a b c d keys test start)) => EX (ex 1 2) => (1 2 NIL 66 NIL NIL 0) (ex 1 2 3 4 :test 'equal :start 50) => (1 2 3 4 (:TEST EQUAL :START 50) EQUAL 50) (ex :test 1 :start 2) => (:TEST 1 :START 2 NIL NIL 0) ;; This function assumes its callers have checked the types of the ;; arguments, and authorizes the compiler to build in that assumption. (defun discriminant (a b c) (declare (number a b c)) "Compute the discriminant for a quadratic equation." (- (* b b) (* 4 a c))) => DISCRIMINANT (discriminant 1 2/3 -2) => 76/9 ;; This function assumes its callers have not checked the types of the ;; arguments, and performs explicit type checks before making any assumptions. (defun careful-discriminant (a b c) "Compute the discriminant for a quadratic equation." (check-type a number) (check-type b number) (check-type c number) (locally (declare (number a b c)) (- (* b b) (* 4 a c)))) => CAREFUL-DISCRIMINANT (careful-discriminant 1 2/3 -2) => 76/9 See Also:: .......... *note flet:: , labels, *note block:: , *note return-from:: , declare, *note documentation:: , *note Evaluation::, *note Ordinary Lambda Lists::, *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... return-from can be used to return prematurely from a function defined by defun. Additional side effects might take place when additional information (typically debugging information) about the function definition is recorded.  File: gcl.info, Node: fdefinition, Next: fboundp, Prev: defun, Up: Data and Control Flow Dictionary 5.3.3 fdefinition [Accessor] ---------------------------- 'fdefinition' function-name => definition (setf (' fdefinition' function-name) new-definition) Arguments and Values:: ...................... function-name--a function name. In the non-setf case, the name must be fbound in the global environment. definition--Current global function definition named by function-name. new-definition--a function. Description:: ............. fdefinition accesses the current global function definition named by function-name. The definition may be a function or may be an object representing a special form or macro. The value returned by fdefinition when fboundp returns true but the function-name denotes a macro or special form is not well-defined, but fdefinition does not signal an error. Exceptional Situations:: ........................ Should signal an error of type type-error if function-name is not a function name. An error of type undefined-function is signaled in the non-setf case if function-name is not fbound. See Also:: .......... *note fboundp:: , *note fmakunbound:: , *note macro-function:: , *note special-operator-p:: , *note symbol-function:: Notes:: ....... fdefinition cannot access the value of a lexical function name produced by flet or labels; it can access only the global function value. setf can be used with fdefinition to replace a global function definition when the function-name's function definition does not represent a special form. setf of fdefinition requires a function as the new value. It is an error to set the fdefinition of a function-name to a symbol, a list, or the value returned by fdefinition on the name of a macro or special form.  File: gcl.info, Node: fboundp, Next: fmakunbound, Prev: fdefinition, Up: Data and Control Flow Dictionary 5.3.4 fboundp [Function] ------------------------ 'fboundp' name => generalized-boolean Pronunciation:: ............... pronounced ,ef 'baund p\=e Arguments and Values:: ...................... name--a function name. generalized-boolean--a generalized boolean. Description:: ............. Returns true if name is fbound; otherwise, returns false. Examples:: .......... (fboundp 'car) => true (fboundp 'nth-value) => false (fboundp 'with-open-file) => true (fboundp 'unwind-protect) => true (defun my-function (x) x) => MY-FUNCTION (fboundp 'my-function) => true (let ((saved-definition (symbol-function 'my-function))) (unwind-protect (progn (fmakunbound 'my-function) (fboundp 'my-function)) (setf (symbol-function 'my-function) saved-definition))) => false (fboundp 'my-function) => true (defmacro my-macro (x) `',x) => MY-MACRO (fboundp 'my-macro) => true (fmakunbound 'my-function) => MY-FUNCTION (fboundp 'my-function) => false (flet ((my-function (x) x)) (fboundp 'my-function)) => false Exceptional Situations:: ........................ Should signal an error of type type-error if name is not a function name. See Also:: .......... *note symbol-function:: , *note fmakunbound:: , *note fdefinition:: Notes:: ....... It is permissible to call symbol-function on any symbol that is fbound. fboundp is sometimes used to "guard" an access to the function cell, as in: (if (fboundp x) (symbol-function x)) Defining a setf expander F does not cause the setf function (setf F) to become defined.  File: gcl.info, Node: fmakunbound, Next: flet, Prev: fboundp, Up: Data and Control Flow Dictionary 5.3.5 fmakunbound [Function] ---------------------------- 'fmakunbound' name => name Pronunciation:: ............... pronounced ,ef 'mak e n,baund or pronounced ,ef 'm\=a k e n,baund Arguments and Values:: ...................... name--a function name. Description:: ............. Removes the function or macro definition, if any, of name in the global environment. Examples:: .......... (defun add-some (x) (+ x 19)) => ADD-SOME (fboundp 'add-some) => true (flet ((add-some (x) (+ x 37))) (fmakunbound 'add-some) (add-some 1)) => 38 (fboundp 'add-some) => false Exceptional Situations:: ........................ Should signal an error of type type-error if name is not a function name. The consequences are undefined if name is a special operator. See Also:: .......... *note fboundp:: , *note makunbound::  File: gcl.info, Node: flet, Next: funcall, Prev: fmakunbound, Up: Data and Control Flow Dictionary 5.3.6 flet, labels, macrolet [Special Operator] ----------------------------------------------- 'flet' ({(function-name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}* => {result}* 'labels' ({(function-name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}* => {result}* 'macrolet' ({(name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}* => {result}* Arguments and Values:: ...................... function-name--a function name. name--a symbol. lambda-list--a lambda list; for flet and labels, it is an ordinary lambda list; for macrolet, it is a macro lambda list. local-declaration--a declare expression; not evaluated. declaration--a declare expression; not evaluated. local-documentation--a string; not evaluated. local-forms, forms--an implicit progn. results--the values of the forms. Description:: ............. flet, labels, and macrolet define local functions and macros, and execute forms using the local definitions. Forms are executed in order of occurrence. The body forms (but not the lambda list) of each function created by flet and labels and each macro created by macrolet are enclosed in an implicit block whose name is the function block name of the function-name or name, as appropriate. The scope of the declarations between the list of local function/macro definitions and the body forms in flet and labels does not include the bodies of the locally defined functions, except that for labels, any inline, notinline, or ftype declarations that refer to the locally defined functions do apply to the local function bodies. That is, their scope is the same as the function name that they affect. The scope of these declarations does not include the bodies of the macro expander functions defined by macrolet. flet flet defines locally named functions and executes a series of forms with these definition bindings. Any number of such local functions can be defined. The scope of the name binding encompasses only the body. Within the body of flet, function-names matching those defined by flet refer to the locally defined functions rather than to the global function definitions of the same name. Also, within the scope of flet, global setf expander definitions of the function-name defined by flet do not apply. Note that this applies to (defsetf f ...), not (defmethod (setf f) ...). The names of functions defined by flet are in the lexical environment; they retain their local definitions only within the body of flet. The function definition bindings are visible only in the body of flet, not the definitions themselves. Within the function definitions, local function names that match those being defined refer to functions or macros defined outside the flet. flet can locally shadow a global function name, and the new definition can refer to the global definition. Any local-documentation is attached to the corresponding local function (if one is actually created) as a documentation string. labels labels is equivalent to flet except that the scope of the defined function names for labels encompasses the function definitions themselves as well as the body. macrolet macrolet establishes local macro definitions, using the same format used by defmacro. Within the body of macrolet, global setf expander definitions of the names defined by the macrolet do not apply; rather, setf expands the macro form and recursively process the resulting form. The macro-expansion functions defined by macrolet are defined in the lexical environment in which the macrolet form appears. Declarations and macrolet and symbol-macrolet definitions affect the local macro definitions in a macrolet, but the consequences are undefined if the local macro definitions reference any local variable or function bindings that are visible in that lexical environment. Any local-documentation is attached to the corresponding local macro function as a documentation string. Examples:: .......... (defun foo (x flag) (macrolet ((fudge (z) ;The parameters x and flag are not accessible ; at this point; a reference to flag would be to ; the global variable of that name. ` (if flag (* ,z ,z) ,z))) ;The parameters x and flag are accessible here. (+ x (fudge x) (fudge (+ x 1))))) == (defun foo (x flag) (+ x (if flag (* x x) x) (if flag (* (+ x 1) (+ x 1)) (+ x 1)))) after macro expansion. The occurrences of x and flag legitimately refer to the parameters of the function foo because those parameters are visible at the site of the macro call which produced the expansion. (flet ((flet1 (n) (+ n n))) (flet ((flet1 (n) (+ 2 (flet1 n)))) (flet1 2))) => 6 (defun dummy-function () 'top-level) => DUMMY-FUNCTION (funcall #'dummy-function) => TOP-LEVEL (flet ((dummy-function () 'shadow)) (funcall #'dummy-function)) => SHADOW (eq (funcall #'dummy-function) (funcall 'dummy-function)) => true (flet ((dummy-function () 'shadow)) (eq (funcall #'dummy-function) (funcall 'dummy-function))) => false (defun recursive-times (k n) (labels ((temp (n) (if (zerop n) 0 (+ k (temp (1- n)))))) (temp n))) => RECURSIVE-TIMES (recursive-times 2 3) => 6 (defmacro mlets (x &environment env) (let ((form `(babbit ,x))) (macroexpand form env))) => MLETS (macrolet ((babbit (z) `(+ ,z ,z))) (mlets 5)) => 10 (flet ((safesqrt (x) (sqrt (abs x)))) ;; The safesqrt function is used in two places. (safesqrt (apply #'+ (map 'list #'safesqrt '(1 2 3 4 5 6))))) => 3.291173 (defun integer-power (n k) (declare (integer n)) (declare (type (integer 0 *) k)) (labels ((expt0 (x k a) (declare (integer x a) (type (integer 0 *) k)) (cond ((zerop k) a) ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a))))) (expt1 (x k a) (declare (integer x a) (type (integer 0 *) k)) (cond ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a)))))) (expt0 n k 1))) => INTEGER-POWER (defun example (y l) (flet ((attach (x) (setq l (append l (list x))))) (declare (inline attach)) (dolist (x y) (unless (null (cdr x)) (attach x))) l)) (example '((a apple apricot) (b banana) (c cherry) (d) (e)) '((1) (2) (3) (4 2) (5) (6 3 2))) => ((1) (2) (3) (4 2) (5) (6 3 2) (A APPLE APRICOT) (B BANANA) (C CHERRY)) See Also:: .......... declare, *note defmacro:: , *note defun:: , *note documentation:: , *note let:: , *note Evaluation::, *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... It is not possible to define recursive functions with flet. labels can be used to define mutually recursive functions. If a macrolet form is a top level form, the body forms are also processed as top level forms. See *note File Compilation::.  File: gcl.info, Node: funcall, Next: function (Special Operator), Prev: flet, Up: Data and Control Flow Dictionary 5.3.7 funcall [Function] ------------------------ 'funcall' function &rest args => {result}* Arguments and Values:: ...................... function--a function designator. args--arguments to the function. results--the values returned by the function. Description:: ............. funcall applies function to args. If function is a symbol, it is coerced to a function as if by finding its functional value in the global environment. Examples:: .......... (funcall #'+ 1 2 3) => 6 (funcall 'car '(1 2 3)) => 1 (funcall 'position 1 '(1 2 3 2 1) :start 1) => 4 (cons 1 2) => (1 . 2) (flet ((cons (x y) `(kons ,x ,y))) (let ((cons (symbol-function '+))) (funcall #'cons (funcall 'cons 1 2) (funcall cons 1 2)))) => (KONS (1 . 2) 3) Exceptional Situations:: ........................ An error of type undefined-function should be signaled if function is a symbol that does not have a global definition as a function or that has a global definition as a macro or a special operator. See Also:: .......... *note apply:: , function, *note Evaluation:: Notes:: ....... (funcall function arg1 arg2 ...) == (apply function arg1 arg2 ... nil) == (apply function (list arg1 arg2 ...)) The difference between funcall and an ordinary function call is that in the former case the function is obtained by ordinary evaluation of a form, and in the latter case it is obtained by the special interpretation of the function position that normally occurs.  File: gcl.info, Node: function (Special Operator), Next: function-lambda-expression, Prev: funcall, Up: Data and Control Flow Dictionary 5.3.8 function [Special Operator] --------------------------------- 'function' name => function Arguments and Values:: ...................... name--a function name or lambda expression. function--a function object. Description:: ............. The value of function is the functional value of name in the current lexical environment. If name is a function name, the functional definition of that name is that established by the innermost lexically enclosing flet, labels, or macrolet form, if there is one. Otherwise the global functional definition of the function name is returned. If name is a lambda expression, then a lexical closure is returned. In situations where a closure over the same set of bindings might be produced more than once, the various resulting closures might or might not be eq. It is an error to use function on a function name that does not denote a function in the lexical environment in which the function form appears. Specifically, it is an error to use function on a symbol that denotes a macro or special form. An implementation may choose not to signal this error for performance reasons, but implementations are forbidden from defining the failure to signal an error as a useful behavior. Examples:: .......... (defun adder (x) (function (lambda (y) (+ x y)))) The result of (adder 3) is a function that adds 3 to its argument: (setq add3 (adder 3)) (funcall add3 5) => 8 This works because function creates a closure of the lambda expression that is able to refer to the value 3 of the variable x even after control has returned from the function adder. See Also:: .......... *note defun:: , *note fdefinition:: , *note flet:: , labels, *note symbol-function:: , *note Symbols as Forms::, *note Sharpsign Single-Quote::, *note Printing Other Objects:: Notes:: ....... The notation #'name may be used as an abbreviation for (function name).  File: gcl.info, Node: function-lambda-expression, Next: functionp, Prev: function (Special Operator), Up: Data and Control Flow Dictionary 5.3.9 function-lambda-expression [Function] ------------------------------------------- 'function-lambda-expression' function => lambda-expression, closure-p, name Arguments and Values:: ...................... function--a function. lambda-expression--a lambda expression or nil. closure-p--a generalized boolean. name--an object. Description:: ............. Returns information about function as follows: The primary value, lambda-expression, is function's defining lambda expression, or nil if the information is not available. The lambda expression may have been pre-processed in some ways, but it should remain a suitable argument to compile or function. Any implementation may legitimately return nil as the lambda-expression of any function. The secondary value, closure-p, is nil if function's definition was enclosed in the null lexical environment or something non-nil if function's definition might have been enclosed in some non-null lexical environment. Any implementation may legitimately return true as the closure-p of any function. The tertiary value, name, is the "name" of function. The name is intended for debugging only and is not necessarily one that would be valid for use as a name in defun or function, for example. By convention, nil is used to mean that function has no name. Any implementation may legitimately return nil as the name of any function. Examples:: .......... The following examples illustrate some possible return values, but are not intended to be exhaustive: (function-lambda-expression #'(lambda (x) x)) => NIL, false, NIL OR=> NIL, true, NIL OR=> (LAMBDA (X) X), true, NIL OR=> (LAMBDA (X) X), false, NIL (function-lambda-expression (funcall #'(lambda () #'(lambda (x) x)))) => NIL, false, NIL OR=> NIL, true, NIL OR=> (LAMBDA (X) X), true, NIL OR=> (LAMBDA (X) X), false, NIL (function-lambda-expression (funcall #'(lambda (x) #'(lambda () x)) nil)) => NIL, true, NIL OR=> (LAMBDA () X), true, NIL NOT=> NIL, false, NIL NOT=> (LAMBDA () X), false, NIL (flet ((foo (x) x)) (setf (symbol-function 'bar) #'foo) (function-lambda-expression #'bar)) => NIL, false, NIL OR=> NIL, true, NIL OR=> (LAMBDA (X) (BLOCK FOO X)), true, NIL OR=> (LAMBDA (X) (BLOCK FOO X)), false, FOO OR=> (SI::BLOCK-LAMBDA FOO (X) X), false, FOO (defun foo () (flet ((bar (x) x)) #'bar)) (function-lambda-expression (foo)) => NIL, false, NIL OR=> NIL, true, NIL OR=> (LAMBDA (X) (BLOCK BAR X)), true, NIL OR=> (LAMBDA (X) (BLOCK BAR X)), true, (:INTERNAL FOO 0 BAR) OR=> (LAMBDA (X) (BLOCK BAR X)), false, "BAR in FOO" Notes:: ....... Although implementations are free to return "nil, true, nil" in all cases, they are encouraged to return a lambda expression as the primary value in the case where the argument was created by a call to compile or eval (as opposed to being created by loading a compiled file).  File: gcl.info, Node: functionp, Next: compiled-function-p, Prev: function-lambda-expression, Up: Data and Control Flow Dictionary 5.3.10 functionp [Function] --------------------------- 'functionp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type function; otherwise, returns false. Examples:: .......... (functionp 'append) => false (functionp #'append) => true (functionp (symbol-function 'append)) => true (flet ((f () 1)) (functionp #'f)) => true (functionp (compile nil '(lambda () 259))) => true (functionp nil) => false (functionp 12) => false (functionp '(lambda (x) (* x x))) => false (functionp #'(lambda (x) (* x x))) => true Notes:: ....... (functionp object) == (typep object 'function)  File: gcl.info, Node: compiled-function-p, Next: call-arguments-limit, Prev: functionp, Up: Data and Control Flow Dictionary 5.3.11 compiled-function-p [Function] ------------------------------------- 'compiled-function-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type compiled-function; otherwise, returns false. Examples:: .......... (defun f (x) x) => F (compiled-function-p #'f) => false OR=> true (compiled-function-p 'f) => false (compile 'f) => F (compiled-function-p #'f) => true (compiled-function-p 'f) => false (compiled-function-p (compile nil '(lambda (x) x))) => true (compiled-function-p #'(lambda (x) x)) => false OR=> true (compiled-function-p '(lambda (x) x)) => false See Also:: .......... *note compile:: , *note compile-file:: , *note compiled-function:: Notes:: ....... (compiled-function-p object) == (typep object 'compiled-function)  File: gcl.info, Node: call-arguments-limit, Next: lambda-list-keywords, Prev: compiled-function-p, Up: Data and Control Flow Dictionary 5.3.12 call-arguments-limit [Constant Variable] ----------------------------------------------- Constant Value:: ................ An integer not smaller than 50 and at least as great as the value of lambda-parameters-limit, the exact magnitude of which is implementation-dependent. Description:: ............. The upper exclusive bound on the number of arguments that may be passed to a function. See Also:: .......... *note lambda-parameters-limit:: , *note multiple-values-limit::  File: gcl.info, Node: lambda-list-keywords, Next: lambda-parameters-limit, Prev: call-arguments-limit, Up: Data and Control Flow Dictionary 5.3.13 lambda-list-keywords [Constant Variable] ----------------------------------------------- Constant Value:: ................ a list, the elements of which are implementation-dependent, but which must contain at least the symbols &allow-other-keys, &aux, &body, &environment, &key, &optional, &rest, and &whole. Description:: ............. A list of all the lambda list keywords used in the implementation, including the additional ones used only by macro definition forms. See Also:: .......... *note defun:: , *note flet:: , *note defmacro:: , macrolet, *note The Evaluation Model::  File: gcl.info, Node: lambda-parameters-limit, Next: defconstant, Prev: lambda-list-keywords, Up: Data and Control Flow Dictionary 5.3.14 lambda-parameters-limit [Constant Variable] -------------------------------------------------- Constant Value:: ................ implementation-dependent, but not smaller than 50. Description:: ............. A positive integer that is the upper exclusive bound on the number of parameter names that can appear in a single lambda list. See Also:: .......... *note call-arguments-limit:: Notes:: ....... Implementors are encouraged to make the value of lambda-parameters-limit as large as possible.  File: gcl.info, Node: defconstant, Next: defparameter, Prev: lambda-parameters-limit, Up: Data and Control Flow Dictionary 5.3.15 defconstant [Macro] -------------------------- 'defconstant' name initial-value [documentation] => name Arguments and Values:: ...................... name--a symbol; not evaluated. initial-value--a form; evaluated. documentation--a string; not evaluated. Description:: ............. defconstant causes the global variable named by name to be given a value that is the result of evaluating initial-value. A constant defined by defconstant can be redefined with defconstant. However, the consequences are undefined if an attempt is made to assign a value to the symbol using another operator, or to assign it to a different value using a subsequent defconstant. If documentation is supplied, it is attached to name as a documentation string of kind variable. defconstant normally appears as a top level form, but it is meaningful for it to appear as a non-top-level form. However, the compile-time side effects described below only take place when defconstant appears as a top level form. The consequences are undefined if there are any bindings of the variable named by name at the time defconstant is executed or if the value is not eql to the value of initial-value. The consequences are undefined when constant symbols are rebound as either lexical or dynamic variables. In other words, a reference to a symbol declared with defconstant always refers to its global value. The side effects of the execution of defconstant must be equivalent to at least the side effects of the execution of the following code: (setf (symbol-value 'name) initial-value) (setf (documentation 'name 'variable) 'documentation) If a defconstant form appears as a top level form, the compiler must recognize that name names a constant variable. An implementation may choose to evaluate the value-form at compile time, load time, or both. Therefore, users must ensure that the initial-value can be evaluated at compile time (regardless of whether or not references to name appear in the file) and that it always evaluates to the same value. [Editorial Note by KMP: Does "same value" here mean eql or similar?] [Reviewer Note by Moon: Probably depends on whether load time is compared to compile time, or two compiles.] Examples:: .......... (defconstant this-is-a-constant 'never-changing "for a test") => THIS-IS-A-CONSTANT this-is-a-constant => NEVER-CHANGING (documentation 'this-is-a-constant 'variable) => "for a test" (constantp 'this-is-a-constant) => true See Also:: .......... *note declaim:: , *note defparameter:: , defvar, *note documentation:: , *note proclaim:: , *note Constant Variables::, *note Compilation::  File: gcl.info, Node: defparameter, Next: destructuring-bind, Prev: defconstant, Up: Data and Control Flow Dictionary 5.3.16 defparameter, defvar [Macro] ----------------------------------- 'defparameter' name initial-value [documentation] => name 'defvar' name [initial-value [documentation]] => name Arguments and Values:: ...................... name--a symbol; not evaluated. initial-value--a form; for defparameter, it is always evaluated, but for defvar it is evaluated only if name is not already bound. documentation--a string; not evaluated. Description:: ............. defparameter and defvar establish name as a dynamic variable. defparameter unconditionally assigns the initial-value to the dynamic variable named name. defvar, by contrast, assigns initial-value (if supplied) to the dynamic variable named name only if name is not already bound. If no initial-value is supplied, defvar leaves the value cell of the dynamic variable named name undisturbed; if name was previously bound, its old value persists, and if it was previously unbound, it remains unbound. If documentation is supplied, it is attached to name as a documentation string of kind variable. defparameter and defvar normally appear as a top level form, but it is meaningful for them to appear as non-top-level forms. However, the compile-time side effects described below only take place when they appear as top level forms. Examples:: .......... (defparameter *p* 1) => *P* *p* => 1 (constantp '*p*) => false (setq *p* 2) => 2 (defparameter *p* 3) => *P* *p* => 3 (defvar *v* 1) => *V* *v* => 1 (constantp '*v*) => false (setq *v* 2) => 2 (defvar *v* 3) => *V* *v* => 2 (defun foo () (let ((*p* 'p) (*v* 'v)) (bar))) => FOO (defun bar () (list *p* *v*)) => BAR (foo) => (P V) The principal operational distinction between defparameter and defvar is that defparameter makes an unconditional assignment to name, while defvar makes a conditional one. In practice, this means that defparameter is useful in situations where loading or reloading the definition would want to pick up a new value of the variable, while defvar is used in situations where the old value would want to be retained if the file were loaded or reloaded. For example, one might create a file which contained: (defvar *the-interesting-numbers* '()) (defmacro define-interesting-number (name n) `(progn (defvar ,name ,n) (pushnew ,name *the-interesting-numbers*) ',name)) (define-interesting-number *my-height* 168) ;cm (define-interesting-number *my-weight* 13) ;stones Here the initial value, (), for the variable *the-interesting-numbers* is just a seed that we are never likely to want to reset to something else once something has been grown from it. As such, we have used defvar to avoid having the *interesting-numbers* information reset if the file is loaded a second time. It is true that the two calls to define-interesting-number here would be reprocessed, but if there were additional calls in another file, they would not be and that information would be lost. On the other hand, consider the following code: (defparameter *default-beep-count* 3) (defun beep (&optional (n *default-beep-count*)) (dotimes (i n) (si: Here we could easily imagine editing the code to change the initial value of *default-beep-count*, and then reloading the file to pick up the new value. In order to make value updating easy, we have used defparameter. On the other hand, there is potential value to using defvar in this situation. For example, suppose that someone had predefined an alternate value for *default-beep-count*, or had loaded the file and then manually changed the value. In both cases, if we had used defvar instead of defparameter, those user preferences would not be overridden by (re)loading the file. The choice of whether to use defparameter or defvar has visible consequences to programs, but is nevertheless often made for subjective reasons. Side Effects:: .............. If a defvar or defparameter form appears as a top level form, the compiler must recognize that the name has been proclaimed special. However, it must neither evaluate the initial-value form nor assign the dynamic variable named name at compile time. There may be additional (implementation-defined) compile-time or run-time side effects, as long as such effects do not interfere with the correct operation of conforming programs. Affected By:: ............. defvar is affected by whether name is already bound. See Also:: .......... *note declaim:: , *note defconstant:: , *note documentation:: , *note Compilation:: Notes:: ....... It is customary to name dynamic variables with an asterisk at the beginning and end of the name. e.g., *foo* is a good name for a dynamic variable, but not for a lexical variable; foo is a good name for a lexical variable, but not for a dynamic variable. This naming convention is observed for all defined names in Common Lisp; however, neither conforming programs nor conforming implementations are obliged to adhere to this convention. The intent of the permission for additional side effects is to allow implementations to do normal "bookkeeping" that accompanies definitions. For example, the macro expansion of a defvar or defparameter form might include code that arranges to record the name of the source file in which the definition occurs. defparameter and defvar might be defined as follows: (defmacro defparameter (name initial-value &optional (documentation nil documentation-p)) `(progn (declaim (special ,name)) (setf (symbol-value ',name) ,initial-value) ,(when documentation-p `(setf (documentation ',name 'variable) ',documentation)) ',name)) (defmacro defvar (name &optional (initial-value nil initial-value-p) (documentation nil documentation-p)) `(progn (declaim (special ,name)) ,(when initial-value-p `(unless (boundp ',name) (setf (symbol-value ',name) ,initial-value))) ,(when documentation-p `(setf (documentation ',name 'variable) ',documentation)) ',name))  File: gcl.info, Node: destructuring-bind, Next: let, Prev: defparameter, Up: Data and Control Flow Dictionary 5.3.17 destructuring-bind [Macro] --------------------------------- 'destructuring-bind' lambda-list expression {declaration}* {form}* => {result}* Arguments and Values:: ...................... lambda-list--a destructuring lambda list. expression--a form. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. destructuring-bind binds the variables specified in lambda-list to the corresponding values in the tree structure resulting from the evaluation of expression; then destructuring-bind evaluates forms. The lambda-list supports destructuring as described in *note Destructuring Lambda Lists::. Examples:: .......... (defun iota (n) (loop for i from 1 to n collect i)) ;helper (destructuring-bind ((a &optional (b 'bee)) one two three) `((alpha) ,@(iota 3)) (list a b three two one)) => (ALPHA BEE 3 2 1) Exceptional Situations:: ........................ If the result of evaluating the expression does not match the destructuring pattern, an error of type error should be signaled. See Also:: .......... macrolet, *note defmacro::  File: gcl.info, Node: let, Next: progv, Prev: destructuring-bind, Up: Data and Control Flow Dictionary 5.3.18 let, let* [Special Operator] ----------------------------------- 'let' ({var | (var [init-form])}*) {declaration}* {form}* => {result}* 'let*' ({var | (var [init-form])}*) {declaration}* {form}* => {result}* Arguments and Values:: ...................... var--a symbol. init-form--a form. declaration--a declare expression; not evaluated. form--a form. results--the values returned by the forms. Description:: ............. let and let* create new variable bindings and execute a series of forms that use these bindings. let performs the bindings in parallel and let* does them sequentially. The form (let ((var1 init-form-1) (var2 init-form-2) ... (varm init-form-m)) declaration1 declaration2 ... declarationp form1 form2 ... formn) first evaluates the expressions init-form-1, init-form-2, and so on, in that order, saving the resulting values. Then all of the variables varj are bound to the corresponding values; each binding is lexical unless there is a special declaration to the contrary. The expressions formk are then evaluated in order; the values of all but the last are discarded (that is, the body of a let is an implicit progn). let* is similar to let, but the bindings of variables are performed sequentially rather than in parallel. The expression for the init-form of a var can refer to vars previously bound in the let*. The form (let* ((var1 init-form-1) (var2 init-form-2) ... (varm init-form-m)) declaration1 declaration2 ... declarationp form1 form2 ... formn) first evaluates the expression init-form-1, then binds the variable var1 to that value; then it evaluates init-form-2 and binds var2, and so on. The expressions formj are then evaluated in order; the values of all but the last are discarded (that is, the body of let* is an implicit progn). For both let and let*, if there is not an init-form associated with a var, var is initialized to nil. The special form let has the property that the scope of the name binding does not include any initial value form. For let*, a variable's scope also includes the remaining initial value forms for subsequent variable bindings. Examples:: .......... (setq a 'top) => TOP (defun dummy-function () a) => DUMMY-FUNCTION (let ((a 'inside) (b a)) (format nil "~S ~S ~S" a b (dummy-function))) => "INSIDE TOP TOP" (let* ((a 'inside) (b a)) (format nil "~S ~S ~S" a b (dummy-function))) => "INSIDE INSIDE TOP" (let ((a 'inside) (b a)) (declare (special a)) (format nil "~S ~S ~S" a b (dummy-function))) => "INSIDE TOP INSIDE" The code (let (x) (declare (integer x)) (setq x (gcd y z)) ...) is incorrect; although x is indeed set before it is used, and is set to a value of the declared type integer, nevertheless x initially takes on the value nil in violation of the type declaration. See Also:: .......... *note progv::  File: gcl.info, Node: progv, Next: setq, Prev: let, Up: Data and Control Flow Dictionary 5.3.19 progv [Special Operator] ------------------------------- 'progv' symbols values {form}* => {result}* Arguments and Values:: ...................... symbols--a list of symbols; evaluated. values--a list of objects; evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. progv creates new dynamic variable bindings and executes each form using those bindings. Each form is evaluated in order. progv allows binding one or more dynamic variables whose names may be determined at run time. Each form is evaluated in order with the dynamic variables whose names are in symbols bound to corresponding values. If too few values are supplied, the remaining symbols are bound and then made to have no value. If too many values are supplied, the excess values are ignored. The bindings of the dynamic variables are undone on exit from progv. Examples:: .......... (setq *x* 1) => 1 (progv '(*x*) '(2) *x*) => 2 *x* => 1 Assuming *x* is not globally special, (let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))) => (3 4) See Also:: .......... *note let:: , *note Evaluation:: Notes:: ....... Among other things, progv is useful when writing interpreters for languages embedded in Lisp; it provides a handle on the mechanism for binding dynamic variables.  File: gcl.info, Node: setq, Next: psetq, Prev: progv, Up: Data and Control Flow Dictionary 5.3.20 setq [Special Form] -------------------------- 'setq' {!pair}* => result pair ::=var form Pronunciation:: ............... pronounced 'set ,ky\"u Arguments and Values:: ...................... var--a symbol naming a variable other than a constant variable. form--a form. result--the primary value of the last form, or nil if no pairs were supplied. Description:: ............. Assigns values to variables. (setq var1 form1 var2 form2 ...) is the simple variable assignment statement of Lisp. First form1 is evaluated and the result is stored in the variable var1, then form2 is evaluated and the result stored in var2, and so forth. setq may be used for assignment of both lexical and dynamic variables. If any var refers to a binding made by symbol-macrolet, then that var is treated as if setf (not setq) had been used. Examples:: .......... ;; A simple use of SETQ to establish values for variables. (setq a 1 b 2 c 3) => 3 a => 1 b => 2 c => 3 ;; Use of SETQ to update values by sequential assignment. (setq a (1+ b) b (1+ a) c (+ a b)) => 7 a => 3 b => 4 c => 7 ;; This illustrates the use of SETQ on a symbol macro. (let ((x (list 10 20 30))) (symbol-macrolet ((y (car x)) (z (cadr x))) (setq y (1+ z) z (1+ y)) (list x y z))) => ((21 22 30) 21 22) Side Effects:: .............. The primary value of each form is assigned to the corresponding var. See Also:: .......... *note psetq:: , *note set:: , *note setf::  File: gcl.info, Node: psetq, Next: block, Prev: setq, Up: Data and Control Flow Dictionary 5.3.21 psetq [Macro] -------------------- 'psetq' {!pair}* => nil pair ::=var form Pronunciation:: ............... psetq: pronounced Arguments and Values:: ...................... var--a symbol naming a variable other than a constant variable. form--a form. Description:: ............. Assigns values to variables. This is just like setq, except that the assignments happen "in parallel." That is, first all of the forms are evaluated, and only then are the variables set to the resulting values. In this way, the assignment to one variable does not affect the value computation of another in the way that would occur with setq's sequential assignment. If any var refers to a binding made by symbol-macrolet, then that var is treated as if psetf (not psetq) had been used. Examples:: .......... ;; A simple use of PSETQ to establish values for variables. ;; As a matter of style, many programmers would prefer SETQ ;; in a simple situation like this where parallel assignment ;; is not needed, but the two have equivalent effect. (psetq a 1 b 2 c 3) => NIL a => 1 b => 2 c => 3 ;; Use of PSETQ to update values by parallel assignment. ;; The effect here is very different than if SETQ had been used. (psetq a (1+ b) b (1+ a) c (+ a b)) => NIL a => 3 b => 2 c => 3 ;; Use of PSETQ on a symbol macro. (let ((x (list 10 20 30))) (symbol-macrolet ((y (car x)) (z (cadr x))) (psetq y (1+ z) z (1+ y)) (list x y z))) => ((21 11 30) 21 11) ;; Use of parallel assignment to swap values of A and B. (let ((a 1) (b 2)) (psetq a b b a) (values a b)) => 2, 1 Side Effects:: .............. The values of forms are assigned to vars. See Also:: .......... psetf, *note setq::  File: gcl.info, Node: block, Next: catch, Prev: psetq, Up: Data and Control Flow Dictionary 5.3.22 block [Special Operator] ------------------------------- 'block' name form* => {result}* Arguments and Values:: ...................... name--a symbol. form--a form. results--the values of the forms if a normal return occurs, or else, if an explicit return occurs, the values that were transferred. Description:: ............. block establishes a block named name and then evaluates forms as an implicit progn. The special operators block and return-from work together to provide a structured, lexical, non-local exit facility. At any point lexically contained within forms, return-from can be used with the given name to return control and values from the block form, except when an intervening block with the same name has been established, in which case the outer block is shadowed by the inner one. The block named name has lexical scope and dynamic extent. Once established, a block may only be exited once, whether by normal return or explicit return. Examples:: .......... (block empty) => NIL (block whocares (values 1 2) (values 3 4)) => 3, 4 (let ((x 1)) (block stop (setq x 2) (return-from stop) (setq x 3)) x) => 2 (block early (return-from early (values 1 2)) (values 3 4)) => 1, 2 (block outer (block inner (return-from outer 1)) 2) => 1 (block twin (block twin (return-from twin 1)) 2) => 2 ;; Contrast behavior of this example with corresponding example of CATCH. (block b (flet ((b1 () (return-from b 1))) (block b (b1) (print 'unreachable)) 2)) => 1 See Also:: .......... *note return:: , *note return-from:: , *note Evaluation:: Notes:: .......  File: gcl.info, Node: catch, Next: go, Prev: block, Up: Data and Control Flow Dictionary 5.3.23 catch [Special Operator] ------------------------------- 'catch' tag {form}* => {result}* Arguments and Values:: ...................... tag--a catch tag; evaluated. forms--an implicit progn. results--if the forms exit normally, the values returned by the forms; if a throw occurs to the tag, the values that are thrown. Description:: ............. catch is used as the destination of a non-local control transfer by throw. Tags are used to find the catch to which a throw is transferring control. (catch 'foo form) catches a (throw 'foo form) but not a (throw 'bar form). The order of execution of catch follows: 1. Tag is evaluated. It serves as the name of the catch. 2. Forms are then evaluated as an implicit progn, and the results of the last form are returned unless a throw occurs. 3. If a throw occurs during the execution of one of the forms, control is transferred to the catch form whose tag is eq to the tag argument of the throw and which is the most recently established catch with that tag. No further evaluation of forms occurs. 4. The tag established by catch is disestablished just before the results are returned. If during the execution of one of the forms, a throw is executed whose tag is eq to the catch tag, then the values specified by the throw are returned as the result of the dynamically most recently established catch form with that tag. The mechanism for catch and throw works even if throw is not within the lexical scope of catch. throw must occur within the dynamic extent of the evaluation of the body of a catch with a corresponding tag. Examples:: .......... (catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4) => 3 (catch 'dummy-tag 1 2 3 4) => 4 (defun throw-back (tag) (throw tag t)) => THROW-BACK (catch 'dummy-tag (throw-back 'dummy-tag) 2) => T ;; Contrast behavior of this example with corresponding example of BLOCK. (catch 'c (flet ((c1 () (throw 'c 1))) (catch 'c (c1) (print 'unreachable)) 2)) => 2 Exceptional Situations:: ........................ An error of type control-error is signaled if throw is done when there is no suitable catch tag. See Also:: .......... *note throw:: , *note Evaluation:: Notes:: ....... It is customary for symbols to be used as tags, but any object is permitted. However, numbers should not be used because the comparison is done using eq. catch differs from block in that catch tags have dynamic scope while block names have lexical scope.  File: gcl.info, Node: go, Next: return-from, Prev: catch, Up: Data and Control Flow Dictionary 5.3.24 go [Special Operator] ---------------------------- 'go' tag => # Arguments and Values:: ...................... tag--a go tag. Description:: ............. go transfers control to the point in the body of an enclosing tagbody form labeled by a tag eql to tag. If there is no such tag in the body, the bodies of lexically containing tagbody forms (if any) are examined as well. If several tags are eql to tag, control is transferred to whichever matching tag is contained in the innermost tagbody form that contains the go. The consequences are undefined if there is no matching tag lexically visible to the point of the go. The transfer of control initiated by go is performed as described in *note Transfer of Control to an Exit Point::. Examples:: .......... (tagbody (setq val 2) (go lp) (incf val 3) lp (incf val 4)) => NIL val => 6 The following is in error because there is a normal exit of the tagbody before the go is executed. (let ((a nil)) (tagbody t (setq a #'(lambda () (go t)))) (funcall a)) The following is in error because the tagbody is passed over before the go form is executed. (funcall (block nil (tagbody a (return #'(lambda () (go a)))))) See Also:: .......... *note tagbody::  File: gcl.info, Node: return-from, Next: return, Prev: go, Up: Data and Control Flow Dictionary 5.3.25 return-from [Special Operator] ------------------------------------- 'return-from' name [result] => # Arguments and Values:: ...................... name--a block tag; not evaluated. result--a form; evaluated. The default is nil. Description:: ............. Returns control and multiple values_2 from a lexically enclosing block. A block form named name must lexically enclose the occurrence of return-from; any values yielded by the evaluation of result are immediately returned from the innermost such lexically enclosing block. The transfer of control initiated by return-from is performed as described in *note Transfer of Control to an Exit Point::. Examples:: .......... (block alpha (return-from alpha) 1) => NIL (block alpha (return-from alpha 1) 2) => 1 (block alpha (return-from alpha (values 1 2)) 3) => 1, 2 (let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a) => 2 (defun temp (x) (if x (return-from temp 'dummy)) 44) => TEMP (temp nil) => 44 (temp t) => DUMMY (block out (flet ((exit (n) (return-from out n))) (block out (exit 1))) 2) => 1 (block nil (unwind-protect (return-from nil 1) (return-from nil 2))) => 2 (dolist (flag '(nil t)) (block nil (let ((x 5)) (declare (special x)) (unwind-protect (return-from nil) (print x)))) (print 'here)) |> 5 |> HERE |> 5 |> HERE => NIL (dolist (flag '(nil t)) (block nil (let ((x 5)) (declare (special x)) (unwind-protect (if flag (return-from nil)) (print x)))) (print 'here)) |> 5 |> HERE |> 5 |> HERE => NIL The following has undefined consequences because the block form exits normally before the return-from form is attempted. (funcall (block nil #'(lambda () (return-from nil)))) is an error. See Also:: .......... *note block:: , *note return:: , *note Evaluation::  File: gcl.info, Node: return, Next: tagbody, Prev: return-from, Up: Data and Control Flow Dictionary 5.3.26 return [Macro] --------------------- 'return' [result] => # Arguments and Values:: ...................... result--a form; evaluated. The default is nil. Description:: ............. Returns, as if by return-from, from the block named nil. Examples:: .......... (block nil (return) 1) => NIL (block nil (return 1) 2) => 1 (block nil (return (values 1 2)) 3) => 1, 2 (block nil (block alpha (return 1) 2)) => 1 (block alpha (block nil (return 1)) 2) => 2 (block nil (block nil (return 1) 2)) => 1 See Also:: .......... *note block:: , *note return-from:: , *note Evaluation:: Notes:: ....... (return) == (return-from nil) (return form) == (return-from nil form) The implicit blocks established by macros such as do are often named nil, so that return can be used to exit from such forms.  File: gcl.info, Node: tagbody, Next: throw, Prev: return, Up: Data and Control Flow Dictionary 5.3.27 tagbody [Special Operator] --------------------------------- 'tagbody' {tag | statement}* => nil Arguments and Values:: ...................... tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. Description:: ............. Executes zero or more statements in a lexical environment that provides for control transfers to labels indicated by the tags. The statements in a tagbody are evaluated in order from left to right, and their values are discarded. If at any time there are no remaining statements, tagbody returns nil. However, if (go tag) is evaluated, control jumps to the part of the body labeled with the tag. (Tags are compared with eql.) A tag established by tagbody has lexical scope and has dynamic extent. Once tagbody has been exited, it is no longer valid to go to a tag in its body. It is permissible for go to jump to a tagbody that is not the innermost tagbody containing that go; the tags established by a tagbody only shadow other tags of like name. The determination of which elements of the body are tags and which are statements is made prior to any macro expansion of that element. If a statement is a macro form and its macro expansion is an atom, that atom is treated as a statement, not a tag. Examples:: .......... (let (val) (tagbody (setq val 1) (go point-a) (incf val 16) point-c (incf val 04) (go point-b) (incf val 32) point-a (incf val 02) (go point-c) (incf val 64) point-b (incf val 08)) val) => 15 (defun f1 (flag) (let ((n 1)) (tagbody (setq n (f2 flag #'(lambda () (go out)))) out (prin1 n)))) => F1 (defun f2 (flag escape) (if flag (funcall escape) 2)) => F2 (f1 nil) |> 2 => NIL (f1 t) |> 1 => NIL See Also:: .......... *note go:: Notes:: ....... The macros in Figure 5-10 have implicit tagbodies. do do-external-symbols dotimes do* do-symbols prog do-all-symbols dolist prog* Figure 5-10: Macros that have implicit tagbodies.  File: gcl.info, Node: throw, Next: unwind-protect, Prev: tagbody, Up: Data and Control Flow Dictionary 5.3.28 throw [Special Operator] ------------------------------- 'throw' tag result-form => # Arguments and Values:: ...................... tag--a catch tag; evaluated. result-form--a form; evaluated as described below. Description:: ............. throw causes a non-local control transfer to a catch whose tag is eq to tag. Tag is evaluated first to produce an object called the throw tag; then result-form is evaluated, and its results are saved. If the result-form produces multiple values, then all the values are saved. The most recent outstanding catch whose tag is eq to the throw tag is exited; the saved results are returned as the value or values of catch. The transfer of control initiated by throw is performed as described in *note Transfer of Control to an Exit Point::. Examples:: .......... (catch 'result (setq i 0 j 0) (loop (incf j 3) (incf i) (if (= i 3) (throw 'result (values i j))))) => 3, 9 (catch nil (unwind-protect (throw nil 1) (throw nil 2))) => 2 The consequences of the following are undefined because the catch of b is passed over by the first throw, hence portable programs must assume that its dynamic extent is terminated. The binding of the catch tag is not yet disestablished and therefore it is the target of the second throw. (catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))) The following prints "The inner catch returns :SECOND-THROW" and then returns :outer-catch. (catch 'foo (format t "The inner catch returns ~s.~ (catch 'foo (unwind-protect (throw 'foo :first-throw) (throw 'foo :second-throw)))) :outer-catch) |> The inner catch returns :SECOND-THROW => :OUTER-CATCH Exceptional Situations:: ........................ If there is no outstanding catch tag that matches the throw tag, no unwinding of the stack is performed, and an error of type control-error is signaled. When the error is signaled, the dynamic environment is that which was in force at the point of the throw. See Also:: .......... *note block:: , *note catch:: , *note return-from:: , *note unwind-protect:: , *note Evaluation:: Notes:: ....... catch and throw are normally used when the exit point must have dynamic scope (e.g., the throw is not lexically enclosed by the catch), while block and return are used when lexical scope is sufficient.  File: gcl.info, Node: unwind-protect, Next: nil, Prev: throw, Up: Data and Control Flow Dictionary 5.3.29 unwind-protect [Special Operator] ---------------------------------------- 'unwind-protect' protected-form {cleanup-form}* => {result}* Arguments and Values:: ...................... protected-form--a form. cleanup-form--a form. results--the values of the protected-form. Description:: ............. unwind-protect evaluates protected-form and guarantees that cleanup-forms are executed before unwind-protect exits, whether it terminates normally or is aborted by a control transfer of some kind. unwind-protect is intended to be used to make sure that certain side effects take place after the evaluation of protected-form. If a non-local exit occurs during execution of cleanup-forms, no special action is taken. The cleanup-forms of unwind-protect are not protected by that unwind-protect. unwind-protect protects against all attempts to exit from protected-form, including go, handler-case, ignore-errors, restart-case, return-from, throw, and with-simple-restart. Undoing of handler and restart bindings during an exit happens in parallel with the undoing of the bindings of dynamic variables and catch tags, in the reverse order in which they were established. The effect of this is that cleanup-form sees the same handler and restart bindings, as well as dynamic variable bindings and catch tags, as were visible when the unwind-protect was entered. Examples:: .......... (tagbody (let ((x 3)) (unwind-protect (if (numberp x) (go out)) (print x))) out ...) When go is executed, the call to print is executed first, and then the transfer of control to the tag out is completed. (defun dummy-function (x) (setq state 'running) (unless (numberp x) (throw 'abort 'not-a-number)) (setq state (1+ x))) => DUMMY-FUNCTION (catch 'abort (dummy-function 1)) => 2 state => 2 (catch 'abort (dummy-function 'trash)) => NOT-A-NUMBER state => RUNNING (catch 'abort (unwind-protect (dummy-function 'trash) (setq state 'aborted))) => NOT-A-NUMBER state => ABORTED The following code is not correct: (unwind-protect (progn (incf *access-count*) (perform-access)) (decf *access-count*)) If an exit occurs before completion of incf, the decf form is executed anyway, resulting in an incorrect value for *access-count*. The correct way to code this is as follows: (let ((old-count *access-count*)) (unwind-protect (progn (incf *access-count*) (perform-access)) (setq *access-count* old-count))) ;;; The following returns 2. (block nil (unwind-protect (return 1) (return 2))) ;;; The following has undefined consequences. (block a (block b (unwind-protect (return-from a 1) (return-from b 2)))) ;;; The following returns 2. (catch nil (unwind-protect (throw nil 1) (throw nil 2))) ;;; The following has undefined consequences because the catch of B is ;;; passed over by the first THROW, hence portable programs must assume ;;; its dynamic extent is terminated. The binding of the catch tag is not ;;; yet disestablished and therefore it is the target of the second throw. (catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))) ;;; The following prints "The inner catch returns :SECOND-THROW" ;;; and then returns :OUTER-CATCH. (catch 'foo (format t "The inner catch returns ~s.~ (catch 'foo (unwind-protect (throw 'foo :first-throw) (throw 'foo :second-throw)))) :outer-catch) ;;; The following returns 10. The inner CATCH of A is passed over, but ;;; because that CATCH is disestablished before the THROW to A is executed, ;;; it isn't seen. (catch 'a (catch 'b (unwind-protect (1+ (catch 'a (throw 'b 1))) (throw 'a 10)))) ;;; The following has undefined consequences because the extent of ;;; the (CATCH 'BAR ...) exit ends when the (THROW 'FOO ...) ;;; commences. (catch 'foo (catch 'bar (unwind-protect (throw 'foo 3) (throw 'bar 4) (print 'xxx)))) ;;; The following returns 4; XXX is not printed. ;;; The (THROW 'FOO ...) has no effect on the scope of the BAR ;;; catch tag or the extent of the (CATCH 'BAR ...) exit. (catch 'bar (catch 'foo (unwind-protect (throw 'foo 3) (throw 'bar 4) (print 'xxx)))) ;;; The following prints 5. (block nil (let ((x 5)) (declare (special x)) (unwind-protect (return) (print x)))) See Also:: .......... *note catch:: , *note go:: , *note handler-case:: , *note restart-case:: , *note return:: , *note return-from:: , *note throw:: , *note Evaluation::  File: gcl.info, Node: nil, Next: not, Prev: unwind-protect, Up: Data and Control Flow Dictionary 5.3.30 nil [Constant Variable] ------------------------------ Constant Value:: ................ nil. Description:: ............. nil represents both boolean (and generalized boolean) false and the empty list. Examples:: .......... nil => NIL See Also:: .......... *note t::  File: gcl.info, Node: not, Next: t, Prev: nil, Up: Data and Control Flow Dictionary 5.3.31 not [Function] --------------------- 'not' x => boolean Arguments and Values:: ...................... x--a generalized boolean (i.e., any object). boolean--a boolean. Description:: ............. Returns t if x is false; otherwise, returns nil. Examples:: .......... (not nil) => T (not '()) => T (not (integerp 'sss)) => T (not (integerp 1)) => NIL (not 3.7) => NIL (not 'apple) => NIL See Also:: .......... *note null:: Notes:: ....... not is intended to be used to invert the 'truth value' of a boolean (or generalized boolean) whereas null is intended to be used to test for the empty list. Operationally, not and null compute the same result; which to use is a matter of style.  File: gcl.info, Node: t, Next: eq, Prev: not, Up: Data and Control Flow Dictionary 5.3.32 t [Constant Variable] ---------------------------- Constant Value:: ................ t. Description:: ............. The boolean representing true, and the canonical generalized boolean representing true. Although any object other than nil is considered true, t is generally used when there is no special reason to prefer one such object over another. The symbol t is also sometimes used for other purposes as well. For example, as the name of a class, as a designator (e.g., a stream designator) or as a special symbol for some syntactic reason (e.g., in case and typecase to label the otherwise-clause). Examples:: .......... t => T (eq t 't) => true (find-class 't) => # (case 'a (a 1) (t 2)) => 1 (case 'b (a 1) (t 2)) => 2 (prin1 'hello t) |> HELLO => HELLO See Also:: .......... *note NIL::  File: gcl.info, Node: eq, Next: eql, Prev: t, Up: Data and Control Flow Dictionary 5.3.33 eq [Function] -------------------- 'eq' x y => generalized-boolean Arguments and Values:: ...................... x--an object. y--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if its arguments are the same, identical object; otherwise, returns false. Examples:: .......... (eq 'a 'b) => false (eq 'a 'a) => true (eq 3 3) => true OR=> false (eq 3 3.0) => false (eq 3.0 3.0) => true OR=> false (eq #c(3 -4) #c(3 -4)) => true OR=> false (eq #c(3 -4.0) #c(3 -4)) => false (eq (cons 'a 'b) (cons 'a 'c)) => false (eq (cons 'a 'b) (cons 'a 'b)) => false (eq '(a . b) '(a . b)) => true OR=> false (progn (setq x (cons 'a 'b)) (eq x x)) => true (progn (setq x '(a . b)) (eq x x)) => true (eq #\A #\A) => true OR=> false (let ((x "Foo")) (eq x x)) => true (eq "Foo" "Foo") => true OR=> false (eq "Foo" (copy-seq "Foo")) => false (eq "FOO" "foo") => false (eq "string-seq" (copy-seq "string-seq")) => false (let ((x 5)) (eq x x)) => true OR=> false See Also:: .......... *note eql:: , *note equal:: , *note equalp:: , *note =:: , *note Compilation:: Notes:: ....... Objects that appear the same when printed are not necessarily eq to each other. Symbols that print the same usually are eq to each other because of the use of the intern function. However, numbers with the same value need not be eq, and two similar lists are usually not identical. An implementation is permitted to make "copies" of characters and numbers at any time. The effect is that Common Lisp makes no guarantee that eq is true even when both its arguments are "the same thing" if that thing is a character or number. Most Common Lisp operators use eql rather than eq to compare objects, or else they default to eql and only use eq if specifically requested to do so. However, the following operators are defined to use eq rather than eql in a way that cannot be overridden by the code which employs them: catch getf throw get remf get-properties remprop Figure 5-11: Operators that always prefer EQ over EQL  File: gcl.info, Node: eql, Next: equal, Prev: eq, Up: Data and Control Flow Dictionary 5.3.34 eql [Function] --------------------- 'eql' x y => generalized-boolean Arguments and Values:: ...................... x--an object. y--an object. generalized-boolean--a generalized boolean. Description:: ............. The value of eql is true of two objects, x and y, in the folowing cases: 1. If x and y are eq. 2. If x and y are both numbers of the same type and the same value. 3. If they are both characters that represent the same character. Otherwise the value of eql is false. If an implementation supports positive and negative zeros as distinct values, then (eql 0.0 -0.0) returns false. Otherwise, when the syntax -0.0 is read it is interpreted as the value 0.0, and so (eql 0.0 -0.0) returns true. Examples:: .......... (eql 'a 'b) => false (eql 'a 'a) => true (eql 3 3) => true (eql 3 3.0) => false (eql 3.0 3.0) => true (eql #c(3 -4) #c(3 -4)) => true (eql #c(3 -4.0) #c(3 -4)) => false (eql (cons 'a 'b) (cons 'a 'c)) => false (eql (cons 'a 'b) (cons 'a 'b)) => false (eql '(a . b) '(a . b)) => true OR=> false (progn (setq x (cons 'a 'b)) (eql x x)) => true (progn (setq x '(a . b)) (eql x x)) => true (eql #\A #\A) => true (eql "Foo" "Foo") => true OR=> false (eql "Foo" (copy-seq "Foo")) => false (eql "FOO" "foo") => false Normally (eql 1.0s0 1.0d0) is false, under the assumption that 1.0s0 and 1.0d0 are of distinct data types. However, implementations that do not provide four distinct floating-point formats are permitted to "collapse" the four formats into some smaller number of them; in such an implementation (eql 1.0s0 1.0d0) might be true. See Also:: .......... *note eq:: , *note equal:: , *note equalp:: , *note =:: , *note char=:: Notes:: ....... eql is the same as eq, except that if the arguments are characters or numbers of the same type then their values are compared. Thus eql tells whether two objects are conceptually the same, whereas eq tells whether two objects are implementationally identical. It is for this reason that eql, not eq, is the default comparison predicate for operators that take sequences as arguments. eql may not be true of two floats even when they represent the same value. = is used to compare mathematical values. Two complex numbers are considered to be eql if their real parts are eql and their imaginary parts are eql. For example, (eql #C(4 5) #C(4 5)) is true and (eql #C(4 5) #C(4.0 5.0)) is false. Note that while (eql #C(5.0 0.0) 5.0) is false, (eql #C(5 0) 5) is true. In the case of (eql #C(5.0 0.0) 5.0) the two arguments are of different types, and so cannot satisfy eql. In the case of (eql #C(5 0) 5), #C(5 0) is not a complex number, but is automatically reduced to the integer 5.  File: gcl.info, Node: equal, Next: equalp, Prev: eql, Up: Data and Control Flow Dictionary 5.3.35 equal [Function] ----------------------- 'equal' x y => generalized-boolean Arguments and Values:: ...................... x--an object. y--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if x and y are structurally similar (isomorphic) objects. Objects are treated as follows by equal. Symbols, Numbers, and Characters equal is true of two objects if they are symbols that are eq, if they are numbers that are eql, or if they are characters that are eql. Conses For conses, equal is defined recursively as the two cars being equal and the two cdrs being equal. Arrays Two arrays are equal only if they are eq, with one exception: strings and bit vectors are compared element-by-element (using eql). If either x or y has a fill pointer, the fill pointer limits the number of elements examined by equal. Uppercase and lowercase letters in strings are considered by equal to be different. Pathnames Two pathnames are equal if and only if all the corresponding components (host, device, and so on) are equivalent. Whether or not uppercase and lowercase letters are considered equivalent in strings appearing in components is implementation-dependent. pathnames that are equal should be functionally equivalent. Other (Structures, hash-tables, instances, ...) Two other objects are equal only if they are eq. equal does not descend any objects other than the ones explicitly specified above. Figure 5-12 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of equal, with upper entries taking priority over lower ones. Type Behavior number uses eql character uses eql cons descends bit vector descends string descends pathname "functionally equivalent" structure uses eq Other array uses eq hash table uses eq Other object uses eq Figure 5-12: Summary and priorities of behavior of equal Any two objects that are eql are also equal. equal may fail to terminate if x or y is circular. Examples:: .......... (equal 'a 'b) => false (equal 'a 'a) => true (equal 3 3) => true (equal 3 3.0) => false (equal 3.0 3.0) => true (equal #c(3 -4) #c(3 -4)) => true (equal #c(3 -4.0) #c(3 -4)) => false (equal (cons 'a 'b) (cons 'a 'c)) => false (equal (cons 'a 'b) (cons 'a 'b)) => true (equal #\A #\A) => true (equal #\A #\a) => false (equal "Foo" "Foo") => true (equal "Foo" (copy-seq "Foo")) => true (equal "FOO" "foo") => false (equal "This-string" "This-string") => true (equal "This-string" "this-string") => false See Also:: .......... *note eq:: , *note eql:: , *note equalp:: , *note =:: , *note string=:: , string-equal, *note char=:: , char-equal, *note tree-equal:: Notes:: ....... Object equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, equal and equalp are not appropriate for every application. A rough rule of thumb is that two objects are equal if and only if their printed representations are the same.  File: gcl.info, Node: equalp, Next: identity, Prev: equal, Up: Data and Control Flow Dictionary 5.3.36 equalp [Function] ------------------------ 'equalp' x y => generalized-boolean Arguments and Values:: ...................... x--an object. y--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if x and y are equal, or if they have components that are of the same type as each other and if those components are equalp; specifically, equalp returns true in the following cases: Characters If two characters are char-equal. Numbers If two numbers are the same under =. Conses If the two cars in the conses are equalp and the two cdrs in the conses are equalp. Arrays If two arrays have the same number of dimensions, the dimensions match, and the corresponding active elements are equalp. The types for which the arrays are specialized need not match; for example, a string and a general array that happens to contain the same characters are equalp. Because equalp performs element-by-element comparisons of strings and ignores the case of characters, case distinctions are ignored when equalp compares strings. Structures If two structures S_1 and S_2 have the same class and the value of each slot in S_1 is the same under equalp as the value of the corresponding slot in S_2. Hash Tables equalp descends hash-tables by first comparing the count of entries and the :test function; if those are the same, it compares the keys of the tables using the :test function and then the values of the matching keys using equalp recursively. equalp does not descend any objects other than the ones explicitly specified above. Figure 5-13 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of equalp, with upper entries taking priority over lower ones. Type Behavior number uses = character uses char-equal cons descends bit vector descends string descends pathname same as equal structure descends, as described above Other array descends hash table descends, as described above Other object uses eq Figure 5-13: Summary and priorities of behavior of equalp Examples:: .......... (equalp 'a 'b) => false (equalp 'a 'a) => true (equalp 3 3) => true (equalp 3 3.0) => true (equalp 3.0 3.0) => true (equalp #c(3 -4) #c(3 -4)) => true (equalp #c(3 -4.0) #c(3 -4)) => true (equalp (cons 'a 'b) (cons 'a 'c)) => false (equalp (cons 'a 'b) (cons 'a 'b)) => true (equalp #\A #\A) => true (equalp #\A #\a) => true (equalp "Foo" "Foo") => true (equalp "Foo" (copy-seq "Foo")) => true (equalp "FOO" "foo") => true (setq array1 (make-array 6 :element-type 'integer :initial-contents '(1 1 1 3 5 7))) => #(1 1 1 3 5 7) (setq array2 (make-array 8 :element-type 'integer :initial-contents '(1 1 1 3 5 7 2 6) :fill-pointer 6)) => #(1 1 1 3 5 7) (equalp array1 array2) => true (setq vector1 (vector 1 1 1 3 5 7)) => #(1 1 1 3 5 7) (equalp array1 vector1) => true See Also:: .......... *note eq:: , *note eql:: , *note equal:: , *note =:: , *note string=:: , string-equal, *note char=:: , char-equal Notes:: ....... Object equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, equal and equalp are not appropriate for every application.  File: gcl.info, Node: identity, Next: complement, Prev: equalp, Up: Data and Control Flow Dictionary 5.3.37 identity [Function] -------------------------- 'identity' object => object Arguments and Values:: ...................... object--an object. Description:: ............. Returns its argument object. Examples:: .......... (identity 101) => 101 (mapcan #'identity (list (list 1 2 3) '(4 5 6))) => (1 2 3 4 5 6) Notes:: ....... identity is intended for use with functions that require a function as an argument. (eql x (identity x)) returns true for all possible values of x, but (eq x (identity x)) might return false when x is a number or character. identity could be defined by (defun identity (x) x)  File: gcl.info, Node: complement, Next: constantly, Prev: identity, Up: Data and Control Flow Dictionary 5.3.38 complement [Function] ---------------------------- 'complement' function => complement-function Arguments and Values:: ...................... function--a function. complement-function--a function. Description:: ............. Returns a function that takes the same arguments as function, and has the same side-effect behavior as function, but returns only a single value: a generalized boolean with the opposite truth value of that which would be returned as the primary value of function. That is, when the function would have returned true as its primary value the complement-function returns false, and when the function would have returned false as its primary value the complement-function returns true. Examples:: .......... (funcall (complement #'zerop) 1) => true (funcall (complement #'characterp) #\A) => false (funcall (complement #'member) 'a '(a b c)) => false (funcall (complement #'member) 'd '(a b c)) => true See Also:: .......... *note not:: Notes:: ....... (complement x) == #'(lambda (&rest arguments) (not (apply x arguments))) In Common Lisp, functions with names like "xxx-if-not" are related to functions with names like "xxx-if" in that (xxx-if-not f . arguments) == (xxx-if (complement f) . arguments) For example, (find-if-not #'zerop '(0 0 3)) == (find-if (complement #'zerop) '(0 0 3)) => 3 Note that since the "xxx-if-not" functions and the :test-not arguments have been deprecated, uses of "xxx-if" functions or :test arguments with complement are preferred.  File: gcl.info, Node: constantly, Next: every, Prev: complement, Up: Data and Control Flow Dictionary 5.3.39 constantly [Function] ---------------------------- 'constantly' value => function Arguments and Values:: ...................... value--an object. function--a function. Description:: ............. constantly returns a function that accepts any number of arguments, that has no side-effects, and that always returns value. Examples:: .......... (mapcar (constantly 3) '(a b c d)) => (3 3 3 3) (defmacro with-vars (vars &body forms) `((lambda ,vars ,@forms) ,@(mapcar (constantly nil) vars))) => WITH-VARS (macroexpand '(with-vars (a b) (setq a 3 b (* a a)) (list a b))) => ((LAMBDA (A B) (SETQ A 3 B (* A A)) (LIST A B)) NIL NIL), true See Also:: .......... *note not:: Notes:: ....... constantly could be defined by: (defun constantly (object) #'(lambda (&rest arguments) object))  File: gcl.info, Node: every, Next: and, Prev: constantly, Up: Data and Control Flow Dictionary 5.3.40 every, some, notevery, notany [Function] ----------------------------------------------- 'every' predicate &rest sequences^+ => generalized-boolean 'some' predicate &rest sequences^+ => result 'notevery' predicate &rest sequences^+ => generalized-boolean 'notany' predicate &rest sequences^+ => generalized-boolean Arguments and Values:: ...................... predicate--a designator for a function of as many arguments as there are sequences. sequence--a sequence. result--an object. generalized-boolean--a generalized boolean. Description:: ............. every, some, notevery, and notany test elements of sequences for satisfaction of a given predicate. The first argument to predicate is an element of the first sequence; each succeeding argument is an element of a succeeding sequence. Predicate is first applied to the elements with index 0 in each of the sequences, and possibly then to the elements with index 1, and so on, until a termination criterion is met or the end of the shortest of the sequences is reached. every returns false as soon as any invocation of predicate returns false. If the end of a sequence is reached, every returns true. Thus, every returns true if and only if every invocation of predicate returns true. some returns the first non-nil value which is returned by an invocation of predicate. If the end of a sequence is reached without any invocation of the predicate returning true, some returns false. Thus, some returns true if and only if some invocation of predicate returns true. notany returns false as soon as any invocation of predicate returns true. If the end of a sequence is reached, notany returns true. Thus, notany returns true if and only if it is not the case that any invocation of predicate returns true. notevery returns true as soon as any invocation of predicate returns false. If the end of a sequence is reached, notevery returns false. Thus, notevery returns true if and only if it is not the case that every invocation of predicate returns true. Examples:: .......... (every #'characterp "abc") => true (some #'= '(1 2 3 4 5) '(5 4 3 2 1)) => true (notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) => false (notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) => true Exceptional Situations:: ........................ Should signal type-error if its first argument is neither a symbol nor a function or if any subsequent argument is not a proper sequence. Other exceptional situations are possible, depending on the nature of the predicate. See Also:: .......... *note and:: , *note or:: , *note Traversal Rules and Side Effects:: Notes:: ....... (notany predicate {sequence}*) == (not (some predicate {sequence}*)) (notevery predicate {sequence}*) == (not (every predicate {sequence}*))  File: gcl.info, Node: and, Next: cond, Prev: every, Up: Data and Control Flow Dictionary 5.3.41 and [Macro] ------------------ 'and' {form}* => {result}* Arguments and Values:: ...................... form--a form. results--the values resulting from the evaluation of the last form, or the symbols nil or t. Description:: ............. The macro and evaluates each form one at a time from left to right. As soon as any form evaluates to nil, and returns nil without evaluating the remaining forms. If all forms but the last evaluate to true values, and returns the results produced by evaluating the last form. If no forms are supplied, (and) returns t. and passes back multiple values from the last subform but not from subforms other than the last. Examples:: .......... (if (and (>= n 0) (< n (length a-simple-vector)) (eq (elt a-simple-vector n) 'foo)) (princ "Foo!")) The above expression prints Foo! if element n of a-simple-vector is the symbol foo, provided also that n is indeed a valid index for a-simple-vector. Because and guarantees left-to-right testing of its parts, elt is not called if n is out of range. (setq temp1 1 temp2 1 temp3 1) => 1 (and (incf temp1) (incf temp2) (incf temp3)) => 2 (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)) => true (decf temp3) => 1 (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)) => NIL (and (eql temp1 temp2) (eql temp2 temp3)) => true (and) => T See Also:: .......... *note cond:: , *note every:: , *note if:: , *note or:: , *note when:: Notes:: ....... (and form) == (let () form) (and form1 form2 ...) == (when form1 (and form2 ...))  File: gcl.info, Node: cond, Next: if, Prev: and, Up: Data and Control Flow Dictionary 5.3.42 cond [Macro] ------------------- 'cond' {!clause}* => {result}* clause ::=(test-form {form}*) Arguments and Values:: ...................... test-form--a form. forms--an implicit progn. results--the values of the forms in the first clause whose test-form yields true, or the primary value of the test-form if there are no forms in that clause, or else nil if no test-form yields true. Description:: ............. cond allows the execution of forms to be dependent on test-form. Test-forms are evaluated one at a time in the order in which they are given in the argument list until a test-form is found that evaluates to true. If there are no forms in that clause, the primary value of the test-form is returned by the cond form. Otherwise, the forms associated with this test-form are evaluated in order, left to right, as an implicit progn, and the values returned by the last form are returned by the cond form. Once one test-form has yielded true, no additional test-forms are evaluated. If no test-form yields true, nil is returned. Examples:: .......... (defun select-options () (cond ((= a 1) (setq a 2)) ((= a 2) (setq a 3)) ((and (= a 3) (floor a 2))) (t (floor a 3)))) => SELECT-OPTIONS (setq a 1) => 1 (select-options) => 2 a => 2 (select-options) => 3 a => 3 (select-options) => 1 (setq a 5) => 5 (select-options) => 1, 2 See Also:: .......... *note if:: , *note case:: .  File: gcl.info, Node: if, Next: or, Prev: cond, Up: Data and Control Flow Dictionary 5.3.43 if [Special Operator] ---------------------------- 'if' test-form then-form [else-form] => {result}* Arguments and Values:: ...................... Test-form--a form. Then-form--a form. Else-form--a form. The default is nil. results--if the test-form yielded true, the values returned by the then-form; otherwise, the values returned by the else-form. Description:: ............. if allows the execution of a form to be dependent on a single test-form. First test-form is evaluated. If the result is true, then then-form is selected; otherwise else-form is selected. Whichever form is selected is then evaluated. Examples:: .......... (if t 1) => 1 (if nil 1 2) => 2 (defun test () (dolist (truth-value '(t nil 1 (a b c))) (if truth-value (print 'true) (print 'false)) (prin1 truth-value))) => TEST (test) |> TRUE T |> FALSE NIL |> TRUE 1 |> TRUE (A B C) => NIL See Also:: .......... *note cond:: , unless, *note when:: Notes:: ....... (if test-form then-form else-form) == (cond (test-form then-form) (t else-form))  File: gcl.info, Node: or, Next: when, Prev: if, Up: Data and Control Flow Dictionary 5.3.44 or [Macro] ----------------- 'or' {form}* => {results}* Arguments and Values:: ...................... form--a form. results--the values or primary value (see below) resulting from the evaluation of the last form executed or nil. Description:: ............. or evaluates each form, one at a time, from left to right. The evaluation of all forms terminates when a form evaluates to true (i.e., something other than nil). If the evaluation of any form other than the last returns a primary value that is true, or immediately returns that value (but no additional values) without evaluating the remaining forms. If every form but the last returns false as its primary value, or returns all values returned by the last form. If no forms are supplied, or returns nil. Examples:: .......... (or) => NIL (setq temp0 nil temp1 10 temp2 20 temp3 30) => 30 (or temp0 temp1 (setq temp2 37)) => 10 temp2 => 20 (or (incf temp1) (incf temp2) (incf temp3)) => 11 temp1 => 11 temp2 => 20 temp3 => 30 (or (values) temp1) => 11 (or (values temp1 temp2) temp3) => 11 (or temp0 (values temp1 temp2)) => 11, 20 (or (values temp0 temp1) (values temp2 temp3)) => 20, 30 See Also:: .......... *note and:: , some, unless  File: gcl.info, Node: when, Next: case, Prev: or, Up: Data and Control Flow Dictionary 5.3.45 when, unless [Macro] --------------------------- 'when' test-form {form}* => {result}* 'unless' test-form {form}* => {result}* Arguments and Values:: ...................... test-form--a form. forms--an implicit progn. results--the values of the forms in a when form if the test-form yields true or in an unless form if the test-form yields false; otherwise nil. Description:: ............. when and unless allow the execution of forms to be dependent on a single test-form. In a when form, if the test-form yields true, the forms are evaluated in order from left to right and the values returned by the forms are returned from the when form. Otherwise, if the test-form yields false, the forms are not evaluated, and the when form returns nil. In an unless form, if the test-form yields false, the forms are evaluated in order from left to right and the values returned by the forms are returned from the unless form. Otherwise, if the test-form yields false, the forms are not evaluated, and the unless form returns nil. Examples:: .......... (when t 'hello) => HELLO (unless t 'hello) => NIL (when nil 'hello) => NIL (unless nil 'hello) => HELLO (when t) => NIL (unless nil) => NIL (when t (prin1 1) (prin1 2) (prin1 3)) |> 123 => 3 (unless t (prin1 1) (prin1 2) (prin1 3)) => NIL (when nil (prin1 1) (prin1 2) (prin1 3)) => NIL (unless nil (prin1 1) (prin1 2) (prin1 3)) |> 123 => 3 (let ((x 3)) (list (when (oddp x) (incf x) (list x)) (when (oddp x) (incf x) (list x)) (unless (oddp x) (incf x) (list x)) (unless (oddp x) (incf x) (list x)) (if (oddp x) (incf x) (list x)) (if (oddp x) (incf x) (list x)) (if (not (oddp x)) (incf x) (list x)) (if (not (oddp x)) (incf x) (list x)))) => ((4) NIL (5) NIL 6 (6) 7 (7)) See Also:: .......... *note and:: , *note cond:: , *note if:: , *note or:: Notes:: ....... (when test {form}^+) == (and test (progn {form}^+)) (when test {form}^+) == (cond (test {form}^+)) (when test {form}^+) == (if test (progn {form}^+) nil) (when test {form}^+) == (unless (not test) {form}^+) (unless test {form}^+) == (cond ((not test) {form}^+)) (unless test {form}^+) == (if test nil (progn {form}^+)) (unless test {form}^+) == (when (not test) {form}^+)  File: gcl.info, Node: case, Next: typecase, Prev: when, Up: Data and Control Flow Dictionary 5.3.46 case, ccase, ecase [Macro] --------------------------------- 'case' keyform {!normal-clause}* [!otherwise-clause] => {result}* 'ccase' keyplace {!normal-clause}* => {result}* 'ecase' keyform {!normal-clause}* => {result}* normal-clause ::=(keys {form}*) otherwise-clause ::=({otherwise | t} {form}*) clause ::=normal-clause | otherwise-clause Arguments and Values:: ...................... keyform--a form; evaluated to produce a test-key. keyplace--a form; evaluated initially to produce a test-key. Possibly also used later as a place if no keys match. test-key--an object produced by evaluating keyform or keyplace. keys--a designator for a list of objects. In the case of case, the symbols t and otherwise may not be used as the keys designator. To refer to these symbols by themselves as keys, the designators (t) and (otherwise), respectively, must be used instead. forms--an implicit progn. results--the values returned by the forms in the matching clause. Description:: ............. These macros allow the conditional execution of a body of forms in a clause that is selected by matching the test-key on the basis of its identity. The keyform or keyplace is evaluated to produce the test-key. Each of the normal-clauses is then considered in turn. If the test-key is the same as any key for that clause, the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the case, ccase, or ecase form. These macros differ only in their behavior when no normal-clause matches; specifically: case If no normal-clause matches, and there is an otherwise-clause, then that otherwise-clause automatically matches; the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the case. If there is no otherwise-clause, case returns nil. ccase If no normal-clause matches, a correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (member key1 key2 ...). The store-value restart can be used to correct the error. If the store-value restart is invoked, its argument becomes the new test-key, and is stored in keyplace as if by (setf keyplace test-key). Then ccase starts over, considering each clause anew. [Reviewer Note by Barmar: Will it prompt for multiple values if keyplace is a VALUES general ref?] The subforms of keyplace might be evaluated again if none of the cases holds. ecase If no normal-clause matches, a non-correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (member key1 key2 ...). Note that in contrast with ccase, the caller of ecase may rely on the fact that ecase does not return if a normal-clause does not match. Examples:: .......... (dolist (k '(1 2 3 :four #\v () t 'other)) (format t "~S " (case k ((1 2) 'clause1) (3 'clause2) (nil 'no-keys-so-never-seen) ((nil) 'nilslot) ((:four #\v) 'clause4) ((t) 'tslot) (otherwise 'others)))) |> CLAUSE1 CLAUSE1 CLAUSE2 CLAUSE4 CLAUSE4 NILSLOT TSLOT OTHERS => NIL (defun add-em (x) (apply #'+ (mapcar #'decode x))) => ADD-EM (defun decode (x) (ccase x ((i uno) 1) ((ii dos) 2) ((iii tres) 3) ((iv cuatro) 4))) => DECODE (add-em '(uno iii)) => 4 (add-em '(uno iiii)) |> Error: The value of X, IIII, is not I, UNO, II, DOS, III, |> TRES, IV, or CUATRO. |> 1: Supply a value to use instead. |> 2: Return to Lisp Toplevel. |> Debug> |>>:CONTINUE 1<<| |> Value to evaluate and use for X: |>>'IV<<| => 5 Side Effects:: .............. The debugger might be entered. If the store-value restart is invoked, the value of keyplace might be changed. Affected By:: ............. ccase and ecase, since they might signal an error, are potentially affected by existing handlers and *debug-io*. Exceptional Situations:: ........................ ccase and ecase signal an error of type type-error if no normal-clause matches. See Also:: .......... *note cond:: , *note typecase:: , *note setf:: , *note Generalized Reference:: Notes:: ....... (case test-key {(({key}*) {form}*)}*) == (let ((#1=#:g0001 test-key)) (cond {((member #1# '({key}*)) {form}*)}*)) The specific error message used by ecase and ccase can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use case with an otherwise-clause that explicitly signals an error with an appropriate message.  File: gcl.info, Node: typecase, Next: multiple-value-bind, Prev: case, Up: Data and Control Flow Dictionary 5.3.47 typecase, ctypecase, etypecase [Macro] --------------------------------------------- 'typecase' keyform {!normal-clause}* [!otherwise-clause] => {result}* 'ctypecase' keyplace {!normal-clause}* => {result}* 'etypecase' keyform {!normal-clause}* => {result}* normal-clause ::=(type {form}*) otherwise-clause ::=({otherwise | t} {form}*) clause ::=normal-clause | otherwise-clause Arguments and Values:: ...................... keyform--a form; evaluated to produce a test-key. keyplace--a form; evaluated initially to produce a test-key. Possibly also used later as a place if no types match. test-key--an object produced by evaluating keyform or keyplace. type--a type specifier. forms--an implicit progn. results--the values returned by the forms in the matching clause. Description:: ............. These macros allow the conditional execution of a body of forms in a clause that is selected by matching the test-key on the basis of its type. The keyform or keyplace is evaluated to produce the test-key. Each of the normal-clauses is then considered in turn. If the test-key is of the type given by the clauses's type, the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the typecase, ctypecase, or etypecase form. These macros differ only in their behavior when no normal-clause matches; specifically: typecase If no normal-clause matches, and there is an otherwise-clause, then that otherwise-clause automatically matches; the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the typecase. If there is no otherwise-clause, typecase returns nil. ctypecase If no normal-clause matches, a correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (or type1 type2 ...). The store-value restart can be used to correct the error. If the store-value restart is invoked, its argument becomes the new test-key, and is stored in keyplace as if by (setf keyplace test-key). Then ctypecase starts over, considering each clause anew. If the store-value restart is invoked interactively, the user is prompted for a new test-key to use. The subforms of keyplace might be evaluated again if none of the cases holds. etypecase If no normal-clause matches, a non-correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (or type1 type2 ...). Note that in contrast with ctypecase, the caller of etypecase may rely on the fact that etypecase does not return if a normal-clause does not match. In all three cases, is permissible for more than one clause to specify a matching type, particularly if one is a subtype of another; the earliest applicable clause is chosen. Examples:: .......... ;;; (Note that the parts of this example which use TYPE-OF ;;; are implementation-dependent.) (defun what-is-it (x) (format t "~&~S is ~A.~ x (typecase x (float "a float") (null "a symbol, boolean false, or the empty list") (list "a list") (t (format nil "a(n) ~(~A~)" (type-of x)))))) => WHAT-IS-IT (map 'nil #'what-is-it '(nil (a b) 7.0 7 box)) |> NIL is a symbol, boolean false, or the empty list. |> (A B) is a list. |> 7.0 is a float. |> 7 is a(n) integer. |> BOX is a(n) symbol. => NIL (setq x 1/3) => 1/3 (ctypecase x (integer (* x 4)) (symbol (symbol-value x))) |> Error: The value of X, 1/3, is neither an integer nor a symbol. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Return to Lisp Toplevel. |> Debug> |>>:CONTINUE 1<<| |> Use value: |>>3.7<<| |> Error: The value of X, 3.7, is neither an integer nor a symbol. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Return to Lisp Toplevel. |> Debug> |>>:CONTINUE 1<<| |> Use value: |>>12<<| => 48 x => 12 Affected By:: ............. ctypecase and etypecase, since they might signal an error, are potentially affected by existing handlers and *debug-io*. Exceptional Situations:: ........................ ctypecase and etypecase signal an error of type type-error if no normal-clause matches. The compiler may choose to issue a warning of type style-warning if a clause will never be selected because it is completely shadowed by earlier clauses. See Also:: .......... *note case:: , *note cond:: , *note setf:: , *note Generalized Reference:: Notes:: ....... (typecase test-key {(type {form}*)}*) == (let ((#1=#:g0001 test-key)) (cond {((typep #1# 'type) {form}*)}*)) The specific error message used by etypecase and ctypecase can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use typecase with an otherwise-clause that explicitly signals an error with an appropriate message.  File: gcl.info, Node: multiple-value-bind, Next: multiple-value-call, Prev: typecase, Up: Data and Control Flow Dictionary 5.3.48 multiple-value-bind [Macro] ---------------------------------- 'multiple-value-bind' ({var}*) values-form {declaration}* {form}* => {result}* Arguments and Values:: ...................... var--a symbol naming a variable; not evaluated. values-form--a form; evaluated. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. Creates new variable bindings for the vars and executes a series of forms that use these bindings. The variable bindings created are lexical unless special declarations are specified. Values-form is evaluated, and each of the vars is bound to the respective value returned by that form. If there are more vars than values returned, extra values of nil are given to the remaining vars. If there are more values than vars, the excess values are discarded. The vars are bound to the values over the execution of the forms, which make up an implicit progn. The consequences are unspecified if a type declaration is specified for a var, but the value to which that var is bound is not consistent with the type declaration. The scopes of the name binding and declarations do not include the values-form. Examples:: .......... (multiple-value-bind (f r) (floor 130 11) (list f r)) => (11 9) See Also:: .......... *note let:: , *note multiple-value-call:: Notes:: ....... (multiple-value-bind ({var}*) values-form {form}*) == (multiple-value-call #'(lambda (&optional {var}* &rest #1=#:ignore) (declare (ignore #1#)) {form}*) values-form)  File: gcl.info, Node: multiple-value-call, Next: multiple-value-list, Prev: multiple-value-bind, Up: Data and Control Flow Dictionary 5.3.49 multiple-value-call [Special Operator] --------------------------------------------- 'multiple-value-call' function-form form* => {result}* Arguments and Values:: ...................... function-form--a form; evaluated to produce function. function--a function designator resulting from the evaluation of function-form. form--a form. results--the values returned by the function. Description:: ............. Applies function to a list of the objects collected from groups of multiple values_2. multiple-value-call first evaluates the function-form to obtain function, and then evaluates each form. All the values of each form are gathered together (not just one value from each) and given as arguments to the function. Examples:: .......... (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)) => (1 / 2 3 / / 2 0.5) (+ (floor 5 3) (floor 19 4)) == (+ 1 4) => 5 (multiple-value-call #'+ (floor 5 3) (floor 19 4)) == (+ 1 2 4 3) => 10 See Also:: .......... *note multiple-value-list:: , *note multiple-value-bind::  File: gcl.info, Node: multiple-value-list, Next: multiple-value-prog1, Prev: multiple-value-call, Up: Data and Control Flow Dictionary 5.3.50 multiple-value-list [Macro] ---------------------------------- 'multiple-value-list' form => list Arguments and Values:: ...................... form--a form; evaluated as described below. list--a list of the values returned by form. Description:: ............. multiple-value-list evaluates form and creates a list of the multiple values_2 it returns. Examples:: .......... (multiple-value-list (floor -3 4)) => (-1 1) See Also:: .......... *note values-list:: , *note multiple-value-call:: Notes:: ....... multiple-value-list and values-list are inverses of each other. (multiple-value-list form) == (multiple-value-call #'list form)  File: gcl.info, Node: multiple-value-prog1, Next: multiple-value-setq, Prev: multiple-value-list, Up: Data and Control Flow Dictionary 5.3.51 multiple-value-prog1 [Special Operator] ---------------------------------------------- 'multiple-value-prog' 1 => first-form {form}* first-form-results Arguments and Values:: ...................... first-form--a form; evaluated as described below. form--a form; evaluated as described below. first-form-results--the values resulting from the evaluation of first-form. Description:: ............. multiple-value-prog1 evaluates first-form and saves all the values produced by that form. It then evaluates each form from left to right, discarding their values. Examples:: .......... (setq temp '(1 2 3)) => (1 2 3) (multiple-value-prog1 (values-list temp) (setq temp nil) (values-list temp)) => 1, 2, 3 See Also:: .......... *note prog1::  File: gcl.info, Node: multiple-value-setq, Next: values, Prev: multiple-value-prog1, Up: Data and Control Flow Dictionary 5.3.52 multiple-value-setq [Macro] ---------------------------------- 'multiple-value-setq' vars form => result Arguments and Values:: ...................... vars--a list of symbols that are either variable names or names of symbol macros. form--a form. result--The primary value returned by the form. Description:: ............. multiple-value-setq assigns values to vars. The form is evaluated, and each var is assigned to the corresponding value returned by that form. If there are more vars than values returned, nil is assigned to the extra vars. If there are more values than vars, the extra values are discarded. If any var is the name of a symbol macro, then it is assigned as if by setf. Specifically, (multiple-value-setq (symbol_1 ... symbol_n) value-producing-form) is defined to always behave in the same way as (values (setf (values symbol_1 ... symbol_n) value-producing-form)) in order that the rules for order of evaluation and side-effects be consistent with those used by setf. See *note VALUES Forms as Places::. Examples:: .......... (multiple-value-setq (quotient remainder) (truncate 3.2 2)) => 1 quotient => 1 remainder => 1.2 (multiple-value-setq (a b c) (values 1 2)) => 1 a => 1 b => 2 c => NIL (multiple-value-setq (a b) (values 4 5 6)) => 4 a => 4 b => 5 See Also:: .......... *note setq:: , *note symbol-macrolet::  File: gcl.info, Node: values, Next: values-list, Prev: multiple-value-setq, Up: Data and Control Flow Dictionary 5.3.53 values [Accessor] ------------------------ 'values' &rest object => {object}* (setf (' values' &rest place) new-values) Arguments and Values:: ...................... object--an object. place--a place. new-value--an object. Description:: ............. values returns the objects as multiple values_2. setf of values is used to store the multiple values_2 new-values into the places. See *note VALUES Forms as Places::. Examples:: .......... (values) => (values 1) => 1 (values 1 2) => 1, 2 (values 1 2 3) => 1, 2, 3 (values (values 1 2 3) 4 5) => 1, 4, 5 (defun polar (x y) (values (sqrt (+ (* x x) (* y y))) (atan y x))) => POLAR (multiple-value-bind (r theta) (polar 3.0 4.0) (vector r theta)) => #(5.0 0.927295) Sometimes it is desirable to indicate explicitly that a function returns exactly one value. For example, the function (defun foo (x y) (floor (+ x y) y)) => FOO returns two values because floor returns two values. It may be that the second value makes no sense, or that for efficiency reasons it is desired not to compute the second value. values is the standard idiom for indicating that only one value is to be returned: (defun foo (x y) (values (floor (+ x y) y))) => FOO This works because values returns exactly one value for each of args; as for any function call, if any of args produces more than one value, all but the first are discarded. See Also:: .......... *note values-list:: , *note multiple-value-bind:: , *note multiple-values-limit:: , *note Evaluation:: Notes:: ....... Since values is a function, not a macro or special form, it receives as arguments only the primary values of its argument forms.  File: gcl.info, Node: values-list, Next: multiple-values-limit, Prev: values, Up: Data and Control Flow Dictionary 5.3.54 values-list [Function] ----------------------------- 'values-list' list => {element}* Arguments and Values:: ...................... list--a list. elements--the elements of the list. Description:: ............. Returns the elements of the list as multiple values_2. Examples:: .......... (values-list nil) => (values-list '(1)) => 1 (values-list '(1 2)) => 1, 2 (values-list '(1 2 3)) => 1, 2, 3 Exceptional Situations:: ........................ Should signal type-error if its argument is not a proper list. See Also:: .......... *note multiple-value-bind:: , *note multiple-value-list:: , *note multiple-values-limit:: , *note values:: Notes:: ....... (values-list list) == (apply #'values list) (equal x (multiple-value-list (values-list x))) returns true for all lists x.  File: gcl.info, Node: multiple-values-limit, Next: nth-value, Prev: values-list, Up: Data and Control Flow Dictionary 5.3.55 multiple-values-limit [Constant Variable] ------------------------------------------------ Constant Value:: ................ An integer not smaller than 20, the exact magnitude of which is implementation-dependent. Description:: ............. The upper exclusive bound on the number of values that may be returned from a function, bound or assigned by multiple-value-bind or multiple-value-setq, or passed as a first argument to nth-value. (If these individual limits might differ, the minimum value is used.) See Also:: .......... *note lambda-parameters-limit:: , *note call-arguments-limit:: Notes:: ....... Implementors are encouraged to make this limit as large as possible.  File: gcl.info, Node: nth-value, Next: prog, Prev: multiple-values-limit, Up: Data and Control Flow Dictionary 5.3.56 nth-value [Macro] ------------------------ 'nth-value' n form => object Arguments and Values:: ...................... n--a non-negative integer; evaluated. form--a form; evaluated as described below. object--an object. Description:: ............. Evaluates n and then form, returning as its only value the nth value yielded by form, or nil if n is greater than or equal to the number of values returned by form. (The first returned value is numbered 0.) Examples:: .......... (nth-value 0 (values 'a 'b)) => A (nth-value 1 (values 'a 'b)) => B (nth-value 2 (values 'a 'b)) => NIL (let* ((x 83927472397238947423879243432432432) (y 32423489732) (a (nth-value 1 (floor x y))) (b (mod x y))) (values a b (= a b))) => 3332987528, 3332987528, true See Also:: .......... *note multiple-value-list:: , *note nth:: Notes:: ....... Operationally, the following relationship is true, although nth-value might be more efficient in some implementations because, for example, some consing might be avoided. (nth-value n form) == (nth n (multiple-value-list form))  File: gcl.info, Node: prog, Next: prog1, Prev: nth-value, Up: Data and Control Flow Dictionary 5.3.57 prog, prog* [Macro] -------------------------- 'prog' ({var | (var [init-form])}*) {declaration}* {tag | statement}* => {result}* 'prog*' ({var | (var [init-form])}*) {declaration}* {tag | statement}* => {result}* Arguments and Values:: ...................... var--variable name. init-form--a form. declaration--a declare expression; not evaluated. tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. results--nil if a normal return occurs, or else, if an explicit return occurs, the values that were transferred. Description:: ............. Three distinct operations are performed by prog and prog*: they bind local variables, they permit use of the return statement, and they permit use of the go statement. A typical prog looks like this: (prog (var1 var2 (var3 init-form-3) var4 (var5 init-form-5)) {declaration}* statement1 tag1 statement2 statement3 statement4 tag2 statement5 ... ) For prog, init-forms are evaluated first, in the order in which they are supplied. The vars are then bound to the corresponding values in parallel. If no init-form is supplied for a given var, that var is bound to nil. The body of prog is executed as if it were a tagbody form; the go statement can be used to transfer control to a tag. Tags label statements. prog implicitly establishes a block named nil around the entire prog form, so that return can be used at any time to exit from the prog form. The difference between prog* and prog is that in prog* the binding and initialization of the vars is done sequentially, so that the init-form for each one can use the values of previous ones. Examples:: .......... (prog* ((y z) (x (car y))) (return x)) returns the car of the value of z. (setq a 1) => 1 (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) => /= (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) => = (prog () 'no-return-value) => NIL (defun king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog (x y z) ;Initialize x, y, z to NIL (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err (cerror "Will self-pair extraneous items" "Mismatch - gleep! ~S" y) (setq z y) (go rejoin))) => KING-OF-CONFUSION This can be accomplished more perspicuously as follows: (defun prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '() (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) (cerror "Will self-pair extraneous items" "Mismatch - gleep! ~S" y) (setq z y)))) => PRINCE-OF-CLARITY See Also:: .......... *note block:: , *note let:: , *note tagbody:: , *note go:: , *note return:: , *note Evaluation:: Notes:: ....... prog can be explained in terms of block, let, and tagbody as follows: (prog variable-list declaration . body) == (block nil (let variable-list declaration (tagbody . body)))  File: gcl.info, Node: prog1, Next: progn, Prev: prog, Up: Data and Control Flow Dictionary 5.3.58 prog1, prog2 [Macro] --------------------------- 'prog' 1 => first-form {form}* result-1 'prog' 2 => first-form second-form {form}* result-2 Arguments and Values:: ...................... first-form--a form; evaluated as described below. second-form--a form; evaluated as described below. forms--an implicit progn; evaluated as described below. result-1--the primary value resulting from the evaluation of first-form. result-2--the primary value resulting from the evaluation of second-form. Description:: ............. prog1 evaluates first-form and then forms, yielding as its only value the primary value yielded by first-form. prog2 evaluates first-form, then second-form, and then forms, yielding as its only value the primary value yielded by first-form. Examples:: .......... (setq temp 1) => 1 (prog1 temp (print temp) (incf temp) (print temp)) |> 1 |> 2 => 1 (prog1 temp (setq temp nil)) => 2 temp => NIL (prog1 (values 1 2 3) 4) => 1 (setq temp (list 'a 'b 'c)) (prog1 (car temp) (setf (car temp) 'alpha)) => A temp => (ALPHA B C) (flet ((swap-symbol-values (x y) (setf (symbol-value x) (prog1 (symbol-value y) (setf (symbol-value y) (symbol-value x)))))) (let ((*foo* 1) (*bar* 2)) (declare (special *foo* *bar*)) (swap-symbol-values '*foo* '*bar*) (values *foo* *bar*))) => 2, 1 (setq temp 1) => 1 (prog2 (incf temp) (incf temp) (incf temp)) => 3 temp => 4 (prog2 1 (values 2 3 4) 5) => 2 See Also:: .......... *note multiple-value-prog1:: , *note progn:: Notes:: ....... prog1 and prog2 are typically used to evaluate one or more forms with side effects and return a value that must be computed before some or all of the side effects happen. (prog1 {form}*) == (values (multiple-value-prog1 {form}*)) (prog2 form1 {form}*) == (let () form1 (prog1 {form}*))  File: gcl.info, Node: progn, Next: define-modify-macro, Prev: prog1, Up: Data and Control Flow Dictionary 5.3.59 progn [Special Operator] ------------------------------- 'progn' {form}* => {result}* Arguments and Values:: ...................... forms--an implicit progn. results--the values of the forms. Description:: ............. progn evaluates forms, in the order in which they are given. The values of each form but the last are discarded. If progn appears as a top level form, then all forms within that progn are considered by the compiler to be top level forms. Examples:: .......... (progn) => NIL (progn 1 2 3) => 3 (progn (values 1 2 3)) => 1, 2, 3 (setq a 1) => 1 (if a (progn (setq a nil) 'here) (progn (setq a t) 'there)) => HERE a => NIL See Also:: .......... *note prog1:: , prog2, *note Evaluation:: Notes:: ....... Many places in Common Lisp involve syntax that uses implicit progns. That is, part of their syntax allows many forms to be written that are to be evaluated sequentially, discarding the results of all forms but the last and returning the results of the last form. Such places include, but are not limited to, the following: the body of a lambda expression; the bodies of various control and conditional forms (e.g., case, catch, progn, and when).  File: gcl.info, Node: define-modify-macro, Next: defsetf, Prev: progn, Up: Data and Control Flow Dictionary 5.3.60 define-modify-macro [Macro] ---------------------------------- 'define-modify-macro' name lambda-list function [documentation] => name Arguments and Values:: ...................... name--a symbol. lambda-list--a define-modify-macro lambda list function--a symbol. documentation--a string; not evaluated. Description:: ............. define-modify-macro defines a macro named name to read and write a place. The arguments to the new macro are a place, followed by the arguments that are supplied in lambda-list. Macros defined with define-modify-macro correctly pass the environment parameter to get-setf-expansion. When the macro is invoked, function is applied to the old contents of the place and the lambda-list arguments to obtain the new value, and the place is updated to contain the result. Except for the issue of avoiding multiple evaluation (see below), the expansion of a define-modify-macro is equivalent to the following: (defmacro name (reference . lambda-list) documentation `(setf ,reference (function ,reference ,arg1 ,arg2 ...))) where arg1, arg2, ..., are the parameters appearing in lambda-list; appropriate provision is made for a rest parameter. The subforms of the macro calls defined by define-modify-macro are evaluated as specified in *note Evaluation of Subforms to Places::. Documentation is attached as a documentation string to name (as kind function) and to the macro function. If a define-modify-macro form appears as a top level form, the compiler must store the macro definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Examples:: .......... (define-modify-macro appendf (&rest args) append "Append onto list") => APPENDF (setq x '(a b c) y x) => (A B C) (appendf x '(d e f) '(1 2 3)) => (A B C D E F 1 2 3) x => (A B C D E F 1 2 3) y => (A B C) (define-modify-macro new-incf (&optional (delta 1)) +) (define-modify-macro unionf (other-set &rest keywords) union) Side Effects:: .............. A macro definition is assigned to name. See Also:: .......... *note defsetf:: , *note define-setf-expander:: , *note documentation:: , *note Syntactic Interaction of Documentation Strings and Declarations::  File: gcl.info, Node: defsetf, Next: define-setf-expander, Prev: define-modify-macro, Up: Data and Control Flow Dictionary 5.3.61 defsetf [Macro] ---------------------- The "short form": 'defsetf' access-fn update-fn [documentation] => access-fn The "long form": 'defsetf' access-fn lambda-list ({store-variable}*) [[{declaration}* | documentation]] {form}* => access-fn Arguments and Values:: ...................... access-fn--a symbol which names a function or a macro. update-fn--a symbol naming a function or macro. lambda-list--a defsetf lambda list. store-variable--a symbol (a variable name). declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. Description:: ............. defsetf defines how to setf a place of the form (access-fn ...) for relatively simple cases. (See define-setf-expander for more general access to this facility.) It must be the case that the function or macro named by access-fn evaluates all of its arguments. defsetf may take one of two forms, called the "short form" and the "long form," which are distinguished by the type of the second argument. When the short form is used, update-fn must name a function (or macro) that takes one more argument than access-fn takes. When setf is given a place that is a call on access-fn, it expands into a call on update-fn that is given all the arguments to access-fn and also, as its last argument, the new value (which must be returned by update-fn as its value). The long form defsetf resembles defmacro. The lambda-list describes the arguments of access-fn. The store-variables describe the value or values to be stored into the place. The body must compute the expansion of a setf of a call on access-fn. The expansion function is defined in the same lexical environment in which the defsetf form appears. During the evaluation of the forms, the variables in the lambda-list and the store-variables are bound to names of temporary variables, generated as if by gensym or gentemp, that will be bound by the expansion of setf to the values of those subforms. This binding permits the forms to be written without regard for order-of-evaluation issues. defsetf arranges for the temporary variables to be optimized out of the final result in cases where that is possible. The body code in defsetf is implicitly enclosed in a block whose name is access-fn defsetf ensures that subforms of the place are evaluated exactly once. Documentation is attached to access-fn as a documentation string of kind setf. If a defsetf form appears as a top level form, the compiler must make the setf expander available so that it may be used to expand calls to setf later on in the file. Users must ensure that the forms, if any, can be evaluated at compile time if the access-fn is used in a place later in the same file. The compiler must make these setf expanders available to compile-time calls to get-setf-expansion when its environment argument is a value received as the environment parameter of a macro. Examples:: .......... The effect of (defsetf symbol-value set) is built into the Common Lisp system. This causes the form (setf (symbol-value foo) fu) to expand into (set foo fu). Note that (defsetf car rplaca) would be incorrect because rplaca does not return its last argument. (defun middleguy (x) (nth (truncate (1- (list-length x)) 2) x)) => MIDDLEGUY (defun set-middleguy (x v) (unless (null x) (rplaca (nthcdr (truncate (1- (list-length x)) 2) x) v)) v) => SET-MIDDLEGUY (defsetf middleguy set-middleguy) => MIDDLEGUY (setq a (list 'a 'b 'c 'd) b (list 'x) c (list 1 2 3 (list 4 5 6) 7 8 9)) => (1 2 3 (4 5 6) 7 8 9) (setf (middleguy a) 3) => 3 (setf (middleguy b) 7) => 7 (setf (middleguy (middleguy c)) 'middleguy-symbol) => MIDDLEGUY-SYMBOL a => (A 3 C D) b => (7) c => (1 2 3 (4 MIDDLEGUY-SYMBOL 6) 7 8 9) An example of the use of the long form of defsetf: (defsetf subseq (sequence start &optional end) (new-sequence) `(progn (replace ,sequence ,new-sequence :start1 ,start :end1 ,end) ,new-sequence)) => SUBSEQ (defvar *xy* (make-array '(10 10))) (defun xy (&key ((x x) 0) ((y y) 0)) (aref *xy* x y)) => XY (defun set-xy (new-value &key ((x x) 0) ((y y) 0)) (setf (aref *xy* x y) new-value)) => SET-XY (defsetf xy (&key ((x x) 0) ((y y) 0)) (store) `(set-xy ,store 'x ,x 'y ,y)) => XY (get-setf-expansion '(xy a b)) => (#:t0 #:t1), (a b), (#:store), ((lambda (&key ((x #:x)) ((y #:y))) (set-xy #:store 'x #:x 'y #:y)) #:t0 #:t1), (xy #:t0 #:t1) (xy 'x 1) => NIL (setf (xy 'x 1) 1) => 1 (xy 'x 1) => 1 (let ((a 'x) (b 'y)) (setf (xy a 1 b 2) 3) (setf (xy b 5 a 9) 14)) => 14 (xy 'y 0 'x 1) => 1 (xy 'x 1 'y 2) => 3 See Also:: .......... *note documentation:: , *note setf:: , *note define-setf-expander:: , *note get-setf-expansion:: , *note Generalized Reference::, *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... forms must include provision for returning the correct value (the value or values of store-variable). This is handled by forms rather than by defsetf because in many cases this value can be returned at no extra cost, by calling a function that simultaneously stores into the place and returns the correct value. A setf of a call on access-fn also evaluates all of access-fn's arguments; it cannot treat any of them specially. This means that defsetf cannot be used to describe how to store into a generalized reference to a byte, such as (ldb field reference). define-setf-expander is used to handle situations that do not fit the restrictions imposed by defsetf and gives the user additional control.  File: gcl.info, Node: define-setf-expander, Next: get-setf-expansion, Prev: defsetf, Up: Data and Control Flow Dictionary 5.3.62 define-setf-expander [Macro] ----------------------------------- 'define-setf-expander' access-fn lambda-list [[{declaration}* | documentation]] {form}* => access-fn Arguments and Values:: ...................... access-fn--a symbol that names a function or macro. lambda-list - macro lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. forms--an implicit progn. Description:: ............. define-setf-expander specifies the means by which setf updates a place that is referenced by access-fn. When setf is given a place that is specified in terms of access-fn and a new value for the place, it is expanded into a form that performs the appropriate update. The lambda-list supports destructuring. See *note Macro Lambda Lists::. Documentation is attached to access-fn as a documentation string of kind setf. Forms constitute the body of the setf expander definition and must compute the setf expansion for a call on setf that references the place by means of the given access-fn. The setf expander function is defined in the same lexical environment in which the define-setf-expander form appears. While forms are being executed, the variables in lambda-list are bound to parts of the place form. The body forms (but not the lambda-list) in a define-setf-expander form are implicitly enclosed in a block whose name is access-fn. The evaluation of forms must result in the five values described in *note Setf Expansions::. If a define-setf-expander form appears as a top level form, the compiler must make the setf expander available so that it may be used to expand calls to setf later on in the file. Programmers must ensure that the forms can be evaluated at compile time if the access-fn is used in a place later in the same file. The compiler must make these setf expanders available to compile-time calls to get-setf-expansion when its environment argument is a value received as the environment parameter of a macro. Examples:: .......... (defun lastguy (x) (car (last x))) => LASTGUY (define-setf-expander lastguy (x &environment env) "Set the last element in a list to the given value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion x env) (let ((store (gensym))) (values dummies vals `(,store) `(progn (rplaca (last ,getter) ,store) ,store) `(lastguy ,getter))))) => LASTGUY (setq a (list 'a 'b 'c 'd) b (list 'x) c (list 1 2 3 (list 4 5 6))) => (1 2 3 (4 5 6)) (setf (lastguy a) 3) => 3 (setf (lastguy b) 7) => 7 (setf (lastguy (lastguy c)) 'lastguy-symbol) => LASTGUY-SYMBOL a => (A B C 3) b => (7) c => (1 2 3 (4 5 LASTGUY-SYMBOL)) ;;; Setf expander for the form (LDB bytespec int). ;;; Recall that the int form must itself be suitable for SETF. (define-setf-expander ldb (bytespec int &environment env) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env);Get setf expansion for int. (let ((btemp (gensym)) ;Temp var for byte specifier. (store (gensym)) ;Temp var for byte to store. (stemp (first stores))) ;Temp var for int to store. (if (cdr stores) (error "Can't expand this.")) ;;; Return the setf expansion for LDB as five values. (values (cons btemp temps) ;Temporary variables. (cons bytespec vals) ;Value forms. (list store) ;Store variables. `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) ;Storing form. `(ldb ,btemp ,access-form) ;Accessing form. )))) See Also:: .......... *note setf:: , *note defsetf:: , *note documentation:: , *note get-setf-expansion:: , *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... define-setf-expander differs from the long form of defsetf in that while the body is being executed the variables in lambda-list are bound to parts of the place form, not to temporary variables that will be bound to the values of such parts. In addition, define-setf-expander does not have defsetf's restriction that access-fn must be a function or a function-like macro; an arbitrary defmacro destructuring pattern is permitted in lambda-list.  File: gcl.info, Node: get-setf-expansion, Next: setf, Prev: define-setf-expander, Up: Data and Control Flow Dictionary 5.3.63 get-setf-expansion [Function] ------------------------------------ 'get-setf-expansion' place &optional environment => vars, vals, store-vars, writer-form, reader-form Arguments and Values:: ...................... place--a place. environment--an environment object. vars, vals, store-vars, writer-form, reader-form--a setf expansion. Description:: ............. Determines five values constituting the setf expansion for place in environment; see *note Setf Expansions::. If environment is not supplied or nil, the environment is the null lexical environment. Examples:: .......... (get-setf-expansion 'x) => NIL, NIL, (#:G0001), (SETQ X #:G0001), X ;;; This macro is like POP (defmacro xpop (place &environment env) (multiple-value-bind (dummies vals new setter getter) (get-setf-expansion place env) `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter)) (if (cdr new) (error "Can't expand this.")) (prog1 (car ,(car new)) (setq ,(car new) (cdr ,(car new))) ,setter)))) (defsetf frob (x) (value) `(setf (car ,x) ,value)) => FROB ;;; The following is an error; an error might be signaled at macro expansion time (flet ((frob (x) (cdr x))) ;Invalid (xpop (frob z))) See Also:: .......... *note defsetf:: , *note define-setf-expander:: , *note setf:: Notes:: ....... Any compound form is a valid place, since any compound form whose operator f has no setf expander are expanded into a call to (setf f).  File: gcl.info, Node: setf, Next: shiftf, Prev: get-setf-expansion, Up: Data and Control Flow Dictionary 5.3.64 setf, psetf [Macro] -------------------------- 'setf' {!pair}* => {result}* 'psetf' {!pair}* => nil pair ::=place newvalue Arguments and Values:: ...................... place--a place. newvalue--a form. results--the multiple values_2 returned by the storing form for the last place, or nil if there are no pairs. Description:: ............. setf changes the value of place to be newvalue. (setf place newvalue) expands into an update form that stores the result of evaluating newvalue into the location referred to by place. Some place forms involve uses of accessors that take optional arguments. Whether those optional arguments are permitted by setf, or what their use is, is up to the setf expander function and is not under the control of setf. The documentation for any function that accepts &optional, &rest, or &key arguments and that claims to be usable with setf must specify how those arguments are treated. If more than one pair is supplied, the pairs are processed sequentially; that is, (setf place-1 newvalue-1 place-2 newvalue-2 ... place-N newvalue-N) is precisely equivalent to (progn (setf place-1 newvalue-1) (setf place-2 newvalue-2) ... (setf place-N newvalue-N)) For psetf, if more than one pair is supplied then the assignments of new values to places are done in parallel. More precisely, all subforms (in both the place and newvalue forms) that are to be evaluated are evaluated from left to right; after all evaluations have been performed, all of the assignments are performed in an unpredictable order. For detailed treatment of the expansion of setf and psetf, see *note Kinds of Places::. Examples:: .......... (setq x (cons 'a 'b) y (list 1 2 3)) => (1 2 3) (setf (car x) 'x (cadr y) (car x) (cdr x) y) => (1 X 3) x => (X 1 X 3) y => (1 X 3) (setq x (cons 'a 'b) y (list 1 2 3)) => (1 2 3) (psetf (car x) 'x (cadr y) (car x) (cdr x) y) => NIL x => (X 1 A 3) y => (1 A 3) Affected By:: ............. define-setf-expander, defsetf, *macroexpand-hook* See Also:: .......... *note define-setf-expander:: , *note defsetf:: , macroexpand-1, *note rotatef:: , *note shiftf:: , *note Generalized Reference::  File: gcl.info, Node: shiftf, Next: rotatef, Prev: setf, Up: Data and Control Flow Dictionary 5.3.65 shiftf [Macro] --------------------- 'shiftf' {place}^+ newvalue => old-value-1 Arguments and Values:: ...................... place--a place. newvalue--a form; evaluated. old-value-1--an object (the old value of the first place). Description:: ............. shiftf modifies the values of each place by storing newvalue into the last place, and shifting the values of the second through the last place into the remaining places. If newvalue produces more values than there are store variables, the extra values are ignored. If newvalue produces fewer values than there are store variables, the missing values are set to nil. In the form (shiftf place1 place2 ... placen newvalue), the values in place1 through placen are read and saved, and newvalue is evaluated, for a total of n+1 values in all. Values 2 through n+1 are then stored into place1 through placen, respectively. It is as if all the places form a shift register; the newvalue is shifted in from the right, all values shift over to the left one place, and the value shifted out of place1 is returned. For information about the evaluation of subforms of places, see *note Evaluation of Subforms to Places::. Examples:: .......... (setq x (list 1 2 3) y 'trash) => TRASH (shiftf y x (cdr x) '(hi there)) => TRASH x => (2 3) y => (1 HI THERE) (setq x (list 'a 'b 'c)) => (A B C) (shiftf (cadr x) 'z) => B x => (A Z C) (shiftf (cadr x) (cddr x) 'q) => Z x => (A (C) . Q) (setq n 0) => 0 (setq x (list 'a 'b 'c 'd)) => (A B C D) (shiftf (nth (setq n (+ n 1)) x) 'z) => B x => (A Z C D) Affected By:: ............. define-setf-expander, defsetf, *macroexpand-hook* See Also:: .......... *note setf:: , *note rotatef:: , *note Generalized Reference:: Notes:: ....... The effect of (shiftf place1 place2 ... placen newvalue) is roughly equivalent to (let ((var1 place1) (var2 place2) ... (varn placen) (var0 newvalue)) (setf place1 var2) (setf place2 var3) ... (setf placen var0) var1) except that the latter would evaluate any subforms of each place twice, whereas shiftf evaluates them once. For example, (setq n 0) => 0 (setq x (list 'a 'b 'c 'd)) => (A B C D) (prog1 (nth (setq n (+ n 1)) x) (setf (nth (setq n (+ n 1)) x) 'z)) => B x => (A B Z D)  File: gcl.info, Node: rotatef, Next: control-error, Prev: shiftf, Up: Data and Control Flow Dictionary 5.3.66 rotatef [Macro] ---------------------- 'rotatef' {place}* => nil Arguments and Values:: ...................... place--a place. Description:: ............. rotatef modifies the values of each place by rotating values from one place into another. If a place produces more values than there are store variables, the extra values are ignored. If a place produces fewer values than there are store variables, the missing values are set to nil. In the form (rotatef place1 place2 ... placen), the values in place1 through placen are read and written. Values 2 through n and value 1 are then stored into place1 through placen. It is as if all the places form an end-around shift register that is rotated one place to the left, with the value of place1 being shifted around the end to placen. For information about the evaluation of subforms of places, see *note Evaluation of Subforms to Places::. Examples:: .......... (let ((n 0) (x (list 'a 'b 'c 'd 'e 'f 'g))) (rotatef (nth (incf n) x) (nth (incf n) x) (nth (incf n) x)) x) => (A C D B E F G) See Also:: .......... *note define-setf-expander:: , *note defsetf:: , *note setf:: , *note shiftf:: , *macroexpand-hook*, *note Generalized Reference:: Notes:: ....... The effect of (rotatef place1 place2 ... placen) is roughly equivalent to (psetf place1 place2 place2 place3 ... placen place1) except that the latter would evaluate any subforms of each place twice, whereas rotatef evaluates them once.  File: gcl.info, Node: control-error, Next: program-error, Prev: rotatef, Up: Data and Control Flow Dictionary 5.3.67 control-error [Condition Type] ------------------------------------- Class Precedence List:: ....................... control-error, error, serious-condition, condition, t Description:: ............. The type control-error consists of error conditions that result from invalid dynamic transfers of control in a program. The errors that result from giving throw a tag that is not active or from giving go or return-from a tag that is no longer dynamically available are of type control-error.  File: gcl.info, Node: program-error, Next: undefined-function, Prev: control-error, Up: Data and Control Flow Dictionary 5.3.68 program-error [Condition Type] ------------------------------------- Class Precedence List:: ....................... program-error, error, serious-condition, condition, t Description:: ............. The type program-error consists of error conditions related to incorrect program syntax. The errors that result from naming a go tag or a block tag that is not lexically apparent are of type program-error.  File: gcl.info, Node: undefined-function, Prev: program-error, Up: Data and Control Flow Dictionary 5.3.69 undefined-function [Condition Type] ------------------------------------------ Class Precedence List:: ....................... undefined-function, cell-error, error, serious-condition, condition, t Description:: ............. The type undefined-function consists of error conditions that represent attempts to read the definition of an undefined function. The name of the cell (see cell-error) is the function name which was funbound. See Also:: .......... *note cell-error-name::  File: gcl.info, Node: Iteration, Next: Objects, Prev: Data and Control Flow, Up: Top 6 Iteration *********** * Menu: * The LOOP Facility:: * Iteration Dictionary::  File: gcl.info, Node: The LOOP Facility, Next: Iteration Dictionary, Prev: Iteration, Up: Iteration 6.1 The LOOP Facility ===================== * Menu: * Overview of the Loop Facility:: * Variable Initialization and Stepping Clauses:: * Value Accumulation Clauses:: * Termination Test Clauses:: * Unconditional Execution Clauses:: * Conditional Execution Clauses:: * Miscellaneous Clauses:: * Examples of Miscellaneous Loop Features:: * Notes about Loop::  File: gcl.info, Node: Overview of the Loop Facility, Next: Variable Initialization and Stepping Clauses, Prev: The LOOP Facility, Up: The LOOP Facility 6.1.1 Overview of the Loop Facility ----------------------------------- The loop macro performs iteration. * Menu: * Simple vs Extended Loop:: * Simple Loop:: * Extended Loop:: * Loop Keywords:: * Parsing Loop Clauses:: * Expanding Loop Forms:: * Summary of Loop Clauses:: * Summary of Variable Initialization and Stepping Clauses:: * Summary of Value Accumulation Clauses:: * Summary of Termination Test Clauses:: * Summary of Unconditional Execution Clauses:: * Summary of Conditional Execution Clauses:: * Summary of Miscellaneous Clauses:: * Order of Execution:: * Destructuring:: * Restrictions on Side-Effects::  File: gcl.info, Node: Simple vs Extended Loop, Next: Simple Loop, Prev: Overview of the Loop Facility, Up: Overview of the Loop Facility 6.1.1.1 Simple vs Extended Loop ............................... loop forms are partitioned into two categories: simple loop forms and extended loop forms.  File: gcl.info, Node: Simple Loop, Next: Extended Loop, Prev: Simple vs Extended Loop, Up: Overview of the Loop Facility 6.1.1.2 Simple Loop ................... A simple loop form is one that has a body containing only compound forms. Each form is evaluated in turn from left to right. When the last form has been evaluated, then the first form is evaluated again, and so on, in a never-ending cycle. A simple loop form establishes an implicit block named nil. The execution of a simple loop can be terminated by explicitly transfering control to the implicit block (using return or return-from) or to some exit point outside of the block (e.g., using throw, go, or return-from).  File: gcl.info, Node: Extended Loop, Next: Loop Keywords, Prev: Simple Loop, Up: Overview of the Loop Facility 6.1.1.3 Extended Loop ..................... An extended loop form is one that has a body containing atomic expressions. When the loop macro processes such a form, it invokes a facility that is commonly called "the Loop Facility." The Loop Facility provides standardized access to mechanisms commonly used in iterations through Loop schemas, which are introduced by loop keywords. The body of an extended loop form is divided into loop clauses, each which is in turn made up of loop keywords and forms.  File: gcl.info, Node: Loop Keywords, Next: Parsing Loop Clauses, Prev: Extended Loop, Up: Overview of the Loop Facility 6.1.1.4 Loop Keywords ..................... Loop keywords are not true keywords_1; they are special symbols, recognized by name rather than object identity, that are meaningful only to the loop facility. A loop keyword is a symbol but is recognized by its name (not its identity), regardless of the packages in which it is accessible. In general, loop keywords are not external symbols of the COMMON-LISP package, except in the coincidental situation that a symbol with the same name as a loop keyword was needed for some other purpose in Common Lisp. For example, there is a symbol in the COMMON-LISP package whose name is "UNLESS" but not one whose name is "UNTIL". If no loop keywords are supplied in a loop form, the Loop Facility executes the loop body repeatedly; see *note Simple Loop::.  File: gcl.info, Node: Parsing Loop Clauses, Next: Expanding Loop Forms, Prev: Loop Keywords, Up: Overview of the Loop Facility 6.1.1.5 Parsing Loop Clauses ............................ The syntactic parts of an extended loop form are called clauses; the rules for parsing are determined by that clause's keyword. The following example shows a loop form with six clauses: (loop for i from 1 to (compute-top-value) ; first clause while (not (unacceptable i)) ; second clause collect (square i) ; third clause do (format t "Working on ~D now" i) ; fourth clause when (evenp i) ; fifth clause do (format t "~D is a non-odd number" i) finally (format t "About to exit!")) ; sixth clause Each loop keyword introduces either a compound loop clause or a simple loop clause that can consist of a loop keyword followed by a single form. The number of forms in a clause is determined by the loop keyword that begins the clause and by the auxiliary keywords in the clause. The keywords do, doing, initially, and finally are the only loop keywords that can take any number of forms and group them as an implicit progn. Loop clauses can contain auxiliary keywords, which are sometimes called prepositions. For example, the first clause in the code above includes the prepositions from and to, which mark the value from which stepping begins and the value at which stepping ends. For detailed information about loop syntax, see the macro loop.  File: gcl.info, Node: Expanding Loop Forms, Next: Summary of Loop Clauses, Prev: Parsing Loop Clauses, Up: Overview of the Loop Facility 6.1.1.6 Expanding Loop Forms ............................ A loop macro form expands into a form containing one or more binding forms (that establish bindings of loop variables) and a block and a tagbody (that express a looping control structure). The variables established in loop are bound as if by let or lambda. Implementations can interleave the setting of initial values with the bindings. However, the assignment of the initial values is always calculated in the order specified by the user. A variable is thus sometimes bound to a meaningless value of the correct type, and then later in the prologue it is set to the true initial value by using setq. One implication of this interleaving is that it is implementation-dependent whether the lexical environment in which the initial value forms (variously called the form1, form2, form3, step-fun, vector, hash-table, and package) in any for-as-subclause, except for-as-equals-then, are evaluated includes only the loop variables preceding that form or includes more or all of the loop variables; the form1 and form2 in a for-as-equals-then form includes the lexical environment of all the loop variables. After the form is expanded, it consists of three basic parts in the tagbody: the loop prologue, the loop body, and the loop epilogue. Loop prologue The loop prologue contains forms that are executed before iteration begins, such as any automatic variable initializations prescribed by the variable clauses, along with any initially clauses in the order they appear in the source. Loop body The loop body contains those forms that are executed during iteration, including application-specific calculations, termination tests, and variable stepping_1. Loop epilogue The loop epilogue contains forms that are executed after iteration terminates, such as finally clauses, if any, along with any implicit return value from an accumulation clause or an termination-test clause. Some clauses from the source form contribute code only to the loop prologue; these clauses must come before other clauses that are in the main body of the loop form. Others contribute code only to the loop epilogue. All other clauses contribute to the final translated form in the same order given in the original source form of the loop. Expansion of the loop macro produces an implicit block named nil unless named is supplied. Thus, return-from (and sometimes return) can be used to return values from loop or to exit loop.  File: gcl.info, Node: Summary of Loop Clauses, Next: Summary of Variable Initialization and Stepping Clauses, Prev: Expanding Loop Forms, Up: Overview of the Loop Facility 6.1.1.7 Summary of Loop Clauses ............................... Loop clauses fall into one of the following categories:  File: gcl.info, Node: Summary of Variable Initialization and Stepping Clauses, Next: Summary of Value Accumulation Clauses, Prev: Summary of Loop Clauses, Up: Overview of the Loop Facility 6.1.1.8 Summary of Variable Initialization and Stepping Clauses ............................................................... The for and as constructs provide iteration control clauses that establish a variable to be initialized. for and as clauses can be combined with the loop keyword and to get parallel initialization and stepping_1. Otherwise, the initialization and stepping_1 are sequential. The with construct is similar to a single let clause. with clauses can be combined using the loop keyword and to get parallel initialization. For more information, see *note Variable Initialization and Stepping Clauses::.  File: gcl.info, Node: Summary of Value Accumulation Clauses, Next: Summary of Termination Test Clauses, Prev: Summary of Variable Initialization and Stepping Clauses, Up: Overview of the Loop Facility 6.1.1.9 Summary of Value Accumulation Clauses ............................................. The collect (or collecting) construct takes one form in its clause and adds the value of that form to the end of a list of values. By default, the list of values is returned when the loop finishes. The append (or appending) construct takes one form in its clause and appends the value of that form to the end of a list of values. By default, the list of values is returned when the loop finishes. The nconc (or nconcing) construct is similar to the append construct, but its list values are concatenated as if by the function nconc. By default, the list of values is returned when the loop finishes. The sum (or summing) construct takes one form in its clause that must evaluate to a number and accumulates the sum of all these numbers. By default, the cumulative sum is returned when the loop finishes. The count (or counting) construct takes one form in its clause and counts the number of times that the form evaluates to true. By default, the count is returned when the loop finishes. The minimize (or minimizing) construct takes one form in its clause and determines the minimum value obtained by evaluating that form. By default, the minimum value is returned when the loop finishes. The maximize (or maximizing) construct takes one form in its clause and determines the maximum value obtained by evaluating that form. By default, the maximum value is returned when the loop finishes. For more information, see *note Value Accumulation Clauses::.  File: gcl.info, Node: Summary of Termination Test Clauses, Next: Summary of Unconditional Execution Clauses, Prev: Summary of Value Accumulation Clauses, Up: Overview of the Loop Facility 6.1.1.10 Summary of Termination Test Clauses ............................................ The for and as constructs provide a termination test that is determined by the iteration control clause. The repeat construct causes termination after a specified number of iterations. (It uses an internal variable to keep track of the number of iterations.) The while construct takes one form, a test, and terminates the iteration if the test evaluates to false. A while clause is equivalent to the expression (if (not test) (loop-finish)). The until construct is the inverse of while; it terminates the iteration if the test evaluates to any non-nil value. An until clause is equivalent to the expression (if test (loop-finish)). The always construct takes one form and terminates the loop if the form ever evaluates to false; in this case, the loop form returns nil. Otherwise, it provides a default return value of t. The never construct takes one form and terminates the loop if the form ever evaluates to true; in this case, the loop form returns nil. Otherwise, it provides a default return value of t. The thereis construct takes one form and terminates the loop if the form ever evaluates to a non-nil object; in this case, the loop form returns that object. Otherwise, it provides a default return value of nil. If multiple termination test clauses are specified, the loop form terminates if any are satisfied. For more information, see *note Termination Test Clauses::.  File: gcl.info, Node: Summary of Unconditional Execution Clauses, Next: Summary of Conditional Execution Clauses, Prev: Summary of Termination Test Clauses, Up: Overview of the Loop Facility 6.1.1.11 Summary of Unconditional Execution Clauses ................................................... The do (or doing) construct evaluates all forms in its clause. The return construct takes one form. Any values returned by the form are immediately returned by the loop form. It is equivalent to the clause do (return-from block-name value), where block-name is the name specified in a named clause, or nil if there is no named clause. For more information, see *note Unconditional Execution Clauses::.  File: gcl.info, Node: Summary of Conditional Execution Clauses, Next: Summary of Miscellaneous Clauses, Prev: Summary of Unconditional Execution Clauses, Up: Overview of the Loop Facility 6.1.1.12 Summary of Conditional Execution Clauses ................................................. The if and when constructs take one form as a test and a clause that is executed when the test yields true. The clause can be a value accumulation, unconditional, or another conditional clause; it can also be any combination of such clauses connected by the loop and keyword. The loop unless construct is similar to the loop when construct except that it complements the test result. The loop else construct provides an optional component of if, when, and unless clauses that is executed when an if or when test yields false or when an unless test yields true. The component is one of the clauses described under if. The loop end construct provides an optional component to mark the end of a conditional clause. For more information, see *note Conditional Execution Clauses::.  File: gcl.info, Node: Summary of Miscellaneous Clauses, Next: Order of Execution, Prev: Summary of Conditional Execution Clauses, Up: Overview of the Loop Facility 6.1.1.13 Summary of Miscellaneous Clauses ......................................... The loop named construct gives a name for the block of the loop. The loop initially construct causes its forms to be evaluated in the loop prologue, which precedes all loop code except for initial settings supplied by the constructs with, for, or as. The loop finally construct causes its forms to be evaluated in the loop epilogue after normal iteration terminates. For more information, see *note Miscellaneous Clauses::.  File: gcl.info, Node: Order of Execution, Next: Destructuring, Prev: Summary of Miscellaneous Clauses, Up: Overview of the Loop Facility 6.1.1.14 Order of Execution ........................... With the exceptions listed below, clauses are executed in the loop body in the order in which they appear in the source. Execution is repeated until a clause terminates the loop or until a return, go, or throw form is encountered which transfers control to a point outside of the loop. The following actions are exceptions to the linear order of execution: * All variables are initialized first, regardless of where the establishing clauses appear in the source. The order of initialization follows the order of these clauses. * The code for any initially clauses is collected into one progn in the order in which the clauses appear in the source. The collected code is executed once in the loop prologue after any implicit variable initializations. * The code for any finally clauses is collected into one progn in the order in which the clauses appear in the source. The collected code is executed once in the loop epilogue before any implicit values from the accumulation clauses are returned. Explicit returns anywhere in the source, however, will exit the loop without executing the epilogue code. * A with clause introduces a variable binding and an optional initial value. The initial values are calculated in the order in which the with clauses occur. * Iteration control clauses implicitly perform the following actions: - initialize variables; - step variables, generally between each execution of the loop body; - perform termination tests, generally just before the execution of the loop body.  File: gcl.info, Node: Destructuring, Next: Restrictions on Side-Effects, Prev: Order of Execution, Up: Overview of the Loop Facility 6.1.1.15 Destructuring ...................... The d-type-spec argument is used for destructuring. If the d-type-spec argument consists solely of the type fixnum, float, t, or nil, the of-type keyword is optional. The of-type construct is optional in these cases to provide backwards compatibility; thus, the following two expressions are the same: ;;; This expression uses the old syntax for type specifiers. (loop for i fixnum upfrom 3 ...) ;;; This expression uses the new syntax for type specifiers. (loop for i of-type fixnum upfrom 3 ...) ;; Declare X and Y to be of type VECTOR and FIXNUM respectively. (loop for (x y) of-type (vector fixnum) in l do ...) A type specifier for a destructuring pattern is a tree of type specifiers with the same shape as the tree of variable names, with the following exceptions: * When aligning the trees, an atom in the tree of type specifiers that matches a cons in the variable tree declares the same type for each variable in the subtree rooted at the cons. * A cons in the tree of type specifiers that matches an atom in the tree of variable names is a compound type specifer. Destructuring allows binding of a set of variables to a corresponding set of values anywhere that a value can normally be bound to a single variable. During loop expansion, each variable in the variable list is matched with the values in the values list. If there are more variables in the variable list than there are values in the values list, the remaining variables are given a value of nil. If there are more values than variables listed, the extra values are discarded. To assign values from a list to the variables a, b, and c, the for clause could be used to bind the variable numlist to the car of the supplied form, and then another for clause could be used to bind the variables a, b, and c sequentially. ;; Collect values by using FOR constructs. (loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) for a of-type integer = (first numlist) and b of-type integer = (second numlist) and c of-type float = (third numlist) collect (list c b a)) => ((4.0 2 1) (8.3 6 5) (10.4 9 8)) Destructuring makes this process easier by allowing the variables to be bound in each loop iteration. Types can be declared by using a list of type-spec arguments. If all the types are the same, a shorthand destructuring syntax can be used, as the second example illustrates. ;; Destructuring simplifies the process. (loop for (a b c) of-type (integer integer float) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) => ((4.0 2 1) (8.3 6 5) (10.4 9 8)) ;; If all the types are the same, this way is even simpler. (loop for (a b c) of-type float in '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4)) collect (list c b a)) => ((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0)) If destructuring is used to declare or initialize a number of groups of variables into types, the loop keyword and can be used to simplify the process further. ;; Initialize and declare variables in parallel by using the AND construct.\kern-7pt (loop with (a b) of-type float = '(1.0 2.0) and (c d) of-type integer = '(3 4) and (e f) return (list a b c d e f)) => (1.0 2.0 3 4 NIL NIL) If nil is used in a destructuring list, no variable is provided for its place. (loop for (a nil b) = '(1 2 3) do (return (list a b))) => (1 3) Note that dotted lists can specify destructuring. (loop for (x . y) = '(1 . 2) do (return y)) => 2 (loop for ((a . b) (c . d)) of-type ((float . float) (integer . integer)) in '(((1.2 . 2.4) (3 . 4)) ((3.4 . 4.6) (5 . 6))) collect (list a b c d)) => ((1.2 2.4 3 4) (3.4 4.6 5 6)) An error of type program-error is signaled (at macro expansion time) if the same variable is bound twice in any variable-binding clause of a single loop expression. Such variables include local variables, iteration control variables, and variables found by destructuring.  File: gcl.info, Node: Restrictions on Side-Effects, Prev: Destructuring, Up: Overview of the Loop Facility 6.1.1.16 Restrictions on Side-Effects ..................................... See *note Traversal Rules and Side Effects::.  File: gcl.info, Node: Variable Initialization and Stepping Clauses, Next: Value Accumulation Clauses, Prev: Overview of the Loop Facility, Up: The LOOP Facility 6.1.2 Variable Initialization and Stepping Clauses -------------------------------------------------- * Menu: * Iteration Control:: * The for-as-arithmetic subclause:: * Examples of for-as-arithmetic subclause:: * The for-as-in-list subclause:: * Examples of for-as-in-list subclause:: * The for-as-on-list subclause:: * Examples of for-as-on-list subclause:: * The for-as-equals-then subclause:: * Examples of for-as-equals-then subclause:: * The for-as-across subclause:: * Examples of for-as-across subclause:: * The for-as-hash subclause:: * The for-as-package subclause:: * Examples of for-as-package subclause:: * Local Variable Initializations:: * Examples of WITH clause::  File: gcl.info, Node: Iteration Control, Next: The for-as-arithmetic subclause, Prev: Variable Initialization and Stepping Clauses, Up: Variable Initialization and Stepping Clauses 6.1.2.1 Iteration Control ......................... Iteration control clauses allow direction of loop iteration. The loop keywords for and as designate iteration control clauses. Iteration control clauses differ with respect to the specification of termination tests and to the initialization and stepping_1 of loop variables. Iteration clauses by themselves do not cause the Loop Facility to return values, but they can be used in conjunction with value-accumulation clauses to return values. All variables are initialized in the loop prologue. A variable binding has lexical scope unless it is proclaimed special; thus, by default, the variable can be accessed only by forms that lie textually within the loop. Stepping assignments are made in the loop body before any other forms are evaluated in the body. The variable argument in iteration control clauses can be a destructuring list. A destructuring list is a tree whose non-nil atoms are variable names. See *note Destructuring::. The iteration control clauses for, as, and repeat must precede any other loop clauses, except initially, with, and named, since they establish variable bindings. When iteration control clauses are used in a loop, the corresponding termination tests in the loop body are evaluated before any other loop body code is executed. If multiple iteration clauses are used to control iteration, variable initialization and stepping_1 occur sequentially by default. The and construct can be used to connect two or more iteration clauses when sequential binding and stepping_1 are not necessary. The iteration behavior of clauses joined by and is analogous to the behavior of the macro do with respect to do*. The for and as clauses iterate by using one or more local loop variables that are initialized to some value and that can be modified or stepped_1 after each iteration. For these clauses, iteration terminates when a local variable reaches some supplied value or when some other loop clause terminates iteration. At each iteration, variables can be stepped_1 by an increment or a decrement or can be assigned a new value by the evaluation of a form). Destructuring can be used to assign values to variables during iteration. The for and as keywords are synonyms; they can be used interchangeably. There are seven syntactic formats for these constructs. In each syntactic format, the type of var can be supplied by the optional type-spec argument. If var is a destructuring list, the type supplied by the type-spec argument must appropriately match the elements of the list. By convention, for introduces new iterations and as introduces iterations that depend on a previous iteration specification.  File: gcl.info, Node: The for-as-arithmetic subclause, Next: Examples of for-as-arithmetic subclause, Prev: Iteration Control, Up: Variable Initialization and Stepping Clauses 6.1.2.2 The for-as-arithmetic subclause ....................................... In the for-as-arithmetic subclause, the for or as construct iterates from the value supplied by form1 to the value supplied by form2 in increments or decrements denoted by form3. Each expression is evaluated only once and must evaluate to a number. The variable var is bound to the value of form1 in the first iteration and is stepped_1 by the value of form3 in each succeeding iteration, or by 1 if form3 is not provided. The following loop keywords serve as valid prepositions within this syntax. At least one of the prepositions must be used; and at most one from each line may be used in a single subclause. from | downfrom | upfrom to | downto | upto | below | above by The prepositional phrases in each subclause may appear in any order. For example, either "from x by y" or "by y from x" is permitted. However, because left-to-right order of evaluation is preserved, the effects will be different in the case of side effects. Consider: (let ((x 1)) (loop for i from x by (incf x) to 10 collect i)) => (1 3 5 7 9) (let ((x 1)) (loop for i by (incf x) from x to 10 collect i)) => (2 4 6 8 10) The descriptions of the prepositions follow: from The loop keyword from specifies the value from which stepping_1 begins, as supplied by form1. Stepping_1 is incremental by default. If decremental stepping_1 is desired, the preposition downto or above must be used with form2. For incremental stepping_1, the default from value is 0. downfrom, upfrom The loop keyword downfrom indicates that the variable var is decreased in decrements supplied by form3; the loop keyword upfrom indicates that var is increased in increments supplied by form3. to The loop keyword to marks the end value for stepping_1 supplied in form2. Stepping_1 is incremental by default. If decremental stepping_1 is desired, the preposition downfrom must be used with form1, or else the preposition downto or above should be used instead of to with form2. downto, upto The loop keyword downto specifies decremental stepping; the loop keyword upto specifies incremental stepping. In both cases, the amount of change on each step is specified by form3, and the loop terminates when the variable var passes the value of form2. Since there is no default for form1 in decremental stepping_1, a form1 value must be supplied (using from or downfrom) when downto is supplied. below, above The loop keywords below and above are analogous to upto and downto respectively. These keywords stop iteration just before the value of the variable var reaches the value supplied by form2; the end value of form2 is not included. Since there is no default for form1 in decremental stepping_1, a form1 value must be supplied (using from or downfrom) when above is supplied. by The loop keyword by marks the increment or decrement supplied by form3. The value of form3 can be any positive number. The default value is 1. In an iteration control clause, the for or as construct causes termination when the supplied limit is reached. That is, iteration continues until the value var is stepped to the exclusive or inclusive limit supplied by form2. The range is exclusive if form3 increases or decreases var to the value of form2 without reaching that value; the loop keywords below and above provide exclusive limits. An inclusive limit allows var to attain the value of form2; to, downto, and upto provide inclusive limits.  File: gcl.info, Node: Examples of for-as-arithmetic subclause, Next: The for-as-in-list subclause, Prev: The for-as-arithmetic subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.3 Examples of for-as-arithmetic subclause ............................................... ;; Print some numbers. (loop for i from 1 to 3 do (print i)) |> 1 |> 2 |> 3 => NIL ;; Print every third number. (loop for i from 10 downto 1 by 3 do (print i)) |> 10 |> 7 |> 4 |> 1 => NIL ;; Step incrementally from the default starting value. (loop for i below 3 do (print i)) |> 0 |> 1 |> 2 => NIL  File: gcl.info, Node: The for-as-in-list subclause, Next: Examples of for-as-in-list subclause, Prev: Examples of for-as-arithmetic subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.4 The for-as-in-list subclause .................................... In the for-as-in-list subclause, the for or as construct iterates over the contents of a list. It checks for the end of the list as if by using endp. The variable var is bound to the successive elements of the list in form1 before each iteration. At the end of each iteration, the function step-fun is applied to the list; the default value for step-fun is cdr. The loop keywords in and by serve as valid prepositions in this syntax. The for or as construct causes termination when the end of the list is reached.  File: gcl.info, Node: Examples of for-as-in-list subclause, Next: The for-as-on-list subclause, Prev: The for-as-in-list subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.5 Examples of for-as-in-list subclause ............................................ ;; Print every item in a list. (loop for item in '(1 2 3) do (print item)) |> 1 |> 2 |> 3 => NIL ;; Print every other item in a list. (loop for item in '(1 2 3 4 5) by #'cddr do (print item)) |> 1 |> 3 |> 5 => NIL ;; Destructure a list, and sum the x values using fixnum arithmetic. (loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3)) unless (eq item 'B) sum x) => 4  File: gcl.info, Node: The for-as-on-list subclause, Next: Examples of for-as-on-list subclause, Prev: Examples of for-as-in-list subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.6 The for-as-on-list subclause .................................... In the for-as-on-list subclause, the for or as construct iterates over a list. It checks for the end of the list as if by using atom. The variable var is bound to the successive tails of the list in form1. At the end of each iteration, the function step-fun is applied to the list; the default value for step-fun is cdr. The loop keywords on and by serve as valid prepositions in this syntax. The for or as construct causes termination when the end of the list is reached.  File: gcl.info, Node: Examples of for-as-on-list subclause, Next: The for-as-equals-then subclause, Prev: The for-as-on-list subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.7 Examples of for-as-on-list subclause ............................................ ;; Collect successive tails of a list. (loop for sublist on '(a b c d) collect sublist) => ((A B C D) (B C D) (C D) (D)) ;; Print a list by using destructuring with the loop keyword ON. (loop for (item) on '(1 2 3) do (print item)) |> 1 |> 2 |> 3 => NIL  File: gcl.info, Node: The for-as-equals-then subclause, Next: Examples of for-as-equals-then subclause, Prev: Examples of for-as-on-list subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.8 The for-as-equals-then subclause ........................................ In the for-as-equals-then subclause the for or as construct initializes the variable var by setting it to the result of evaluating form1 on the first iteration, then setting it to the result of evaluating form2 on the second and subsequent iterations. If form2 is omitted, the construct uses form1 on the second and subsequent iterations. The loop keywords = and then serve as valid prepositions in this syntax. This construct does not provide any termination tests.  File: gcl.info, Node: Examples of for-as-equals-then subclause, Next: The for-as-across subclause, Prev: The for-as-equals-then subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.9 Examples of for-as-equals-then subclause ................................................ ;; Collect some numbers. (loop for item = 1 then (+ item 10) for iteration from 1 to 5 collect item) => (1 11 21 31 41)  File: gcl.info, Node: The for-as-across subclause, Next: Examples of for-as-across subclause, Prev: Examples of for-as-equals-then subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.10 The for-as-across subclause .................................... In the for-as-across subclause the for or as construct binds the variable var to the value of each element in the array vector. The loop keyword across marks the array vector; across is used as a preposition in this syntax. Iteration stops when there are no more elements in the supplied array that can be referenced. Some implementations might recognize a the special form in the vector form to produce more efficient code.  File: gcl.info, Node: Examples of for-as-across subclause, Next: The for-as-hash subclause, Prev: The for-as-across subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.11 Examples of for-as-across subclause ............................................ (loop for char across (the simple-string (find-message channel)) do (write-char char stream))  File: gcl.info, Node: The for-as-hash subclause, Next: The for-as-package subclause, Prev: Examples of for-as-across subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.12 The for-as-hash subclause .................................. In the for-as-hash subclause the for or as construct iterates over the elements, keys, and values of a hash-table. In this syntax, a compound preposition is used to designate access to a hash table. The variable var takes on the value of each hash key or hash value in the supplied hash-table. The following loop keywords serve as valid prepositions within this syntax: being The keyword being introduces either the Loop schema hash-key or hash-value. each, the The loop keyword each follows the loop keyword being when hash-key or hash-value is used. The loop keyword the is used with hash-keys and hash-values only for ease of reading. This agreement isn't required. hash-key, hash-keys These loop keywords access each key entry of the hash table. If the name hash-value is supplied in a using construct with one of these Loop schemas, the iteration can optionally access the keyed value. The order in which the keys are accessed is undefined; empty slots in the hash table are ignored. hash-value, hash-values These loop keywords access each value entry of a hash table. If the name hash-key is supplied in a using construct with one of these Loop schemas, the iteration can optionally access the key that corresponds to the value. The order in which the keys are accessed is undefined; empty slots in the hash table are ignored. using The loop keyword using introduces the optional key or the keyed value to be accessed. It allows access to the hash key if iteration is over the hash values, and the hash value if iteration is over the hash keys. in, of These loop prepositions introduce hash-table. In effect being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of} is a compound preposition. Iteration stops when there are no more hash keys or hash values to be referenced in the supplied hash-table.  File: gcl.info, Node: The for-as-package subclause, Next: Examples of for-as-package subclause, Prev: The for-as-hash subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.13 The for-as-package subclause ..................................... In the for-as-package subclause the for or as construct iterates over the symbols in a package. In this syntax, a compound preposition is used to designate access to a package. The variable var takes on the value of each symbol in the supplied package. The following loop keywords serve as valid prepositions within this syntax: being The keyword being introduces either the Loop schema symbol, present-symbol, or external-symbol. each, the The loop keyword each follows the loop keyword being when symbol, present-symbol, or external-symbol is used. The loop keyword the is used with symbols, present-symbols, and external-symbols only for ease of reading. This agreement isn't required. present-symbol, present-symbols These Loop schemas iterate over the symbols that are present in a package. The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled. symbol, symbols These Loop schemas iterate over symbols that are accessible in a given package. The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled. external-symbol, external-symbols These Loop schemas iterate over the external symbols of a package. The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled. in, of These loop prepositions introduce package. In effect being {each | the} {symbol | symbols | present-symbol | present-symbols | external-symbol | external-symbols} {in | of} is a compound preposition. Iteration stops when there are no more symbols to be referenced in the supplied package.  File: gcl.info, Node: Examples of for-as-package subclause, Next: Local Variable Initializations, Prev: The for-as-package subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.14 Examples of for-as-package subclause ............................................. (let ((*package* (make-package "TEST-PACKAGE-1"))) ;; For effect, intern some symbols (read-from-string "(THIS IS A TEST)") (export (intern "THIS")) (loop for x being each present-symbol of *package* do (print x))) |> A |> TEST |> THIS |> IS => NIL  File: gcl.info, Node: Local Variable Initializations, Next: Examples of WITH clause, Prev: Examples of for-as-package subclause, Up: Variable Initialization and Stepping Clauses 6.1.2.15 Local Variable Initializations ....................................... When a loop form is executed, the local variables are bound and are initialized to some value. These local variables exist until loop iteration terminates, at which point they cease to exist. Implicit variables are also established by iteration control clauses and the into preposition of accumulation clauses. The with construct initializes variables that are local to a loop. The variables are initialized one time only. If the optional type-spec argument is supplied for the variable var, but there is no related expression to be evaluated, var is initialized to an appropriate default value for its type. For example, for the types t, number, and float, the default values are nil, 0, and 0.0 respectively. The consequences are undefined if a type-spec argument is supplied for var if the related expression returns a value that is not of the supplied type. By default, the with construct initializes variables sequentially; that is, one variable is assigned a value before the next expression is evaluated. However, by using the loop keyword and to join several with clauses, initializations can be forced to occur in parallel; that is, all of the supplied forms are evaluated, and the results are bound to the respective variables simultaneously. Sequential binding is used when it is desireable for the initialization of some variables to depend on the values of previously bound variables. For example, suppose the variables a, b, and c are to be bound in sequence: (loop with a = 1 with b = (+ a 2) with c = (+ b 3) return (list a b c)) => (1 3 6) The execution of the above loop is equivalent to the execution of the following code: (block nil (let* ((a 1) (b (+ a 2)) (c (+ b 3))) (tagbody (next-loop (return (list a b c)) (go next-loop) end-loop)))) If the values of previously bound variables are not needed for the initialization of other local variables, an and clause can be used to specify that the bindings are to occur in parallel: (loop with a = 1 and b = 2 and c = 3 return (list a b c)) => (1 2 3) The execution of the above loop is equivalent to the execution of the following code: (block nil (let ((a 1) (b 2) (c 3)) (tagbody (next-loop (return (list a b c)) (go next-loop) end-loop))))  File: gcl.info, Node: Examples of WITH clause, Prev: Local Variable Initializations, Up: Variable Initialization and Stepping Clauses 6.1.2.16 Examples of WITH clause ................................ ;; These bindings occur in sequence. (loop with a = 1 with b = (+ a 2) with c = (+ b 3) return (list a b c)) => (1 3 6) ;; These bindings occur in parallel. (setq a 5 b 10) => 10 (loop with a = 1 and b = (+ a 2) and c = (+ b 3) return (list a b c)) => (1 7 13) ;; This example shows a shorthand way to declare local variables ;; that are of different types. (loop with (a b c) of-type (float integer float) return (format nil "~A ~A ~A" a b c)) => "0.0 0 0.0" ;; This example shows a shorthand way to declare local variables ;; that are the same type. (loop with (a b c) of-type float return (format nil "~A ~A ~A" a b c)) => "0.0 0.0 0.0"  File: gcl.info, Node: Value Accumulation Clauses, Next: Termination Test Clauses, Prev: Variable Initialization and Stepping Clauses, Up: The LOOP Facility 6.1.3 Value Accumulation Clauses -------------------------------- The constructs collect, collecting, append, appending, nconc, nconcing, count, counting, maximize, maximizing, minimize, minimizing, sum, and summing, allow values to be accumulated in a loop. The constructs collect, collecting, append, appending, nconc, and nconcing, designate clauses that accumulate values in lists and return them. The constructs count, counting, maximize, maximizing, minimize, minimizing, sum, and summing designate clauses that accumulate and return numerical values. During each iteration, the constructs collect and collecting collect the value of the supplied form into a list. When iteration terminates, the list is returned. The argument var is set to the list of collected values; if var is supplied, the loop does not return the final list automatically. If var is not supplied, it is equivalent to supplying an internal name for var and returning its value in a finally clause. The var argument is bound as if by the construct with. No mechanism is provided for declaring the type of var; it must be of type list. The constructs append, appending, nconc, and nconcing are similar to collect except that the values of the supplied form must be lists. * The append keyword causes its list values to be concatenated into a single list, as if they were arguments to the function append. * The nconc keyword causes its list values to be concatenated into a single list, as if they were arguments to the function nconc. The argument var is set to the list of concatenated values; if var is supplied, loop does not return the final list automatically. The var argument is bound as if by the construct with. A type cannot be supplied for var; it must be of type list. The construct nconc destructively modifies its argument lists. The count construct counts the number of times that the supplied form returns true. The argument var accumulates the number of occurrences; if var is supplied, loop does not return the final count automatically. The var argument is bound as if by the construct with to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the function 1+. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the count. The default type is implementation-dependent; but it must be a supertype of type fixnum. The maximize and minimize constructs compare the value of the supplied form obtained during the first iteration with values obtained in successive iterations. The maximum (for maximize) or minimum (for minimize) value encountered is determined (as if by the function max for maximize and as if by the function min for minimize) and returned. If the maximize or minimize clause is never executed, the accumulated value is unspecified. The argument var accumulates the maximum or minimum value; if var is supplied, loop does not return the maximum or minimum automatically. The var argument is bound as if by the construct with. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the maximum or minimum value. The default type is implementation-dependent; but it must be a supertype of type real. The sum construct forms a cumulative sum of the successive primary values of the supplied form at each iteration. The argument var is used to accumulate the sum; if var is supplied, loop does not return the final sum automatically. The var argument is bound as if by the construct with to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the function +. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the sum. The default type is implementation-dependent; but it must be a supertype of type number. If into is used, the construct does not provide a default return value; however, the variable is available for use in any finally clause. Certain kinds of accumulation clauses can be combined in a loop if their destination is the same (the result of loop or an into var) because they are considered to accumulate conceptually compatible quantities. In particular, any elements of following sets of accumulation clauses can be mixed with other elements of the same set for the same destination in a loop form: * collect, append, nconc * sum, count * maximize, minimize ;; Collect every name and the kids in one list by using ;; COLLECT and APPEND. (loop for name in '(fred sue alice joe june) for kids in '((bob ken) () () (kris sunshine) ()) collect name append kids) => (FRED BOB KEN SUE ALICE JOE KRIS SUNSHINE JUNE) Any two clauses that do not accumulate the same type of object can coexist in a loop only if each clause accumulates its values into a different variable. * Menu: * Examples of COLLECT clause:: * Examples of APPEND and NCONC clauses:: * Examples of COUNT clause:: * Examples of MAXIMIZE and MINIMIZE clauses:: * Examples of SUM clause::  File: gcl.info, Node: Examples of COLLECT clause, Next: Examples of APPEND and NCONC clauses, Prev: Value Accumulation Clauses, Up: Value Accumulation Clauses 6.1.3.1 Examples of COLLECT clause .................................. ;; Collect all the symbols in a list. (loop for i in '(bird 3 4 turtle (1 . 4) horse cat) when (symbolp i) collect i) => (BIRD TURTLE HORSE CAT) ;; Collect and return odd numbers. (loop for i from 1 to 10 if (oddp i) collect i) => (1 3 5 7 9) ;; Collect items into local variable, but don't return them. (loop for i in '(a b c d) by #'cddr collect i into my-list finally (print my-list)) |> (A C) => NIL  File: gcl.info, Node: Examples of APPEND and NCONC clauses, Next: Examples of COUNT clause, Prev: Examples of COLLECT clause, Up: Value Accumulation Clauses 6.1.3.2 Examples of APPEND and NCONC clauses ............................................ ;; Use APPEND to concatenate some sublists. (loop for x in '((a) (b) ((c))) append x) => (A B (C)) ;; NCONC some sublists together. Note that only lists made by the ;; call to LIST are modified. (loop for i upfrom 0 as x in '(a b (c)) nconc (if (evenp i) (list x) nil)) => (A (C))  File: gcl.info, Node: Examples of COUNT clause, Next: Examples of MAXIMIZE and MINIMIZE clauses, Prev: Examples of APPEND and NCONC clauses, Up: Value Accumulation Clauses 6.1.3.3 Examples of COUNT clause ................................ (loop for i in '(a b nil c nil d e) count i) => 5  File: gcl.info, Node: Examples of MAXIMIZE and MINIMIZE clauses, Next: Examples of SUM clause, Prev: Examples of COUNT clause, Up: Value Accumulation Clauses 6.1.3.4 Examples of MAXIMIZE and MINIMIZE clauses ................................................. (loop for i in '(2 1 5 3 4) maximize i) => 5 (loop for i in '(2 1 5 3 4) minimize i) => 1 ;; In this example, FIXNUM applies to the internal variable that holds ;; the maximum value. (setq series '(1.2 4.3 5.7)) => (1.2 4.3 5.7) (loop for v in series maximize (round v) of-type fixnum) => 6 ;; In this example, FIXNUM applies to the variable RESULT. (loop for v of-type float in series minimize (round v) into result of-type fixnum finally (return result)) => 1  File: gcl.info, Node: Examples of SUM clause, Prev: Examples of MAXIMIZE and MINIMIZE clauses, Up: Value Accumulation Clauses 6.1.3.5 Examples of SUM clause .............................. (loop for i of-type fixnum in '(1 2 3 4 5) sum i) => 15 (setq series '(1.2 4.3 5.7)) => (1.2 4.3 5.7) (loop for v in series sum (* 2.0 v)) => 22.4  File: gcl.info, Node: Termination Test Clauses, Next: Unconditional Execution Clauses, Prev: Value Accumulation Clauses, Up: The LOOP Facility 6.1.4 Termination Test Clauses ------------------------------ The repeat construct causes iteration to terminate after a specified number of times. The loop body executes n times, where n is the value of the expression form. The form argument is evaluated one time in the loop prologue. If the expression evaluates to 0 or to a negative number, the loop body is not evaluated. The constructs always, never, thereis, while, until, and the macro loop-finish allow conditional termination of iteration within a loop. The constructs always, never, and thereis provide specific values to be returned when a loop terminates. Using always, never, or thereis in a loop with value accumulation clauses that are not into causes an error of type program-error to be signaled (at macro expansion time). Since always, never, and thereis use the return-from special operator to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to any of these constructs. In all other respects these constructs behave like the while and until constructs. The always construct takes one form and terminates the loop if the form ever evaluates to nil; in this case, it returns nil. Otherwise, it provides a default return value of t. If the value of the supplied form is never nil, some other construct can terminate the iteration. The never construct terminates iteration the first time that the value of the supplied form is non-nil; the loop returns nil. If the value of the supplied form is always nil, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is t. The thereis construct terminates iteration the first time that the value of the supplied form is non-nil; the loop returns the value of the supplied form. If the value of the supplied form is always nil, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is nil. There are two differences between the thereis and until constructs: * The until construct does not return a value or nil based on the value of the supplied form. * The until construct executes any finally clause. Since thereis uses the return-from special operator to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to thereis. The while construct allows iteration to continue until the supplied form evaluates to false. The supplied form is reevaluated at the location of the while clause. The until construct is equivalent to while (not form)\dots. If the value of the supplied form is non-nil, iteration terminates. Termination-test control constructs can be used anywhere within the loop body. The termination tests are used in the order in which they appear. If an until or while clause causes termination, any clauses that precede it in the source are still evaluated. If the until and while constructs cause termination, control is passed to the loop epilogue, where any finally clauses will be executed. There are two differences between the never and until constructs: * The until construct does not return t or nil based on the value of the supplied form. * The until construct does not bypass any finally clauses. Since never uses the return-from special operator to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to never. In most cases it is not necessary to use loop-finish because other loop control clauses terminate the loop. The macro loop-finish is used to provide a normal exit from a nested conditional inside a loop. Since loop-finish transfers control to the loop epilogue, using loop-finish within a finally expression can cause infinite looping. * Menu: * Examples of REPEAT clause:: * Examples of ALWAYS:: * Examples of WHILE and UNTIL clauses::  File: gcl.info, Node: Examples of REPEAT clause, Next: Examples of ALWAYS, Prev: Termination Test Clauses, Up: Termination Test Clauses 6.1.4.1 Examples of REPEAT clause ................................. (loop repeat 3 do (format t "~&What I say three times is true.~ |> What I say three times is true. |> What I say three times is true. |> What I say three times is true. => NIL (loop repeat -15 do (format t "What you see is what you expect~ => NIL  File: gcl.info, Node: Examples of ALWAYS, Next: Examples of WHILE and UNTIL clauses, Prev: Examples of REPEAT clause, Up: Termination Test Clauses 6.1.4.2 Examples of ALWAYS, NEVER, and THEREIS clauses ...................................................... ;; Make sure I is always less than 11 (two ways). ;; The FOR construct terminates these loops. (loop for i from 0 to 10 always (< i 11)) => T (loop for i from 0 to 10 never (> i 11)) => T ;; If I exceeds 10 return I; otherwise, return NIL. ;; The THEREIS construct terminates this loop. (loop for i from 0 thereis (when (> i 10) i) ) => 11 ;;; The FINALLY clause is not evaluated in these examples. (loop for i from 0 to 10 always (< i 9) finally (print "you won't see this")) => NIL (loop never t finally (print "you won't see this")) => NIL (loop thereis "Here is my value" finally (print "you won't see this")) => "Here is my value" ;; The FOR construct terminates this loop, so the FINALLY clause ;; is evaluated. (loop for i from 1 to 10 thereis (> i 11) finally (prin1 'got-here)) |> GOT-HERE => NIL ;; If this code could be used to find a counterexample to Fermat's ;; last theorem, it would still not return the value of the ;; counterexample because all of the THEREIS clauses in this example ;; only return T. But if Fermat is right, that won't matter ;; because this won't terminate. (loop for z upfrom 2 thereis (loop for n upfrom 3 below (log z 2) thereis (loop for x below z thereis (loop for y below z thereis (= (+ (expt x n) (expt y n)) (expt z n))))))  File: gcl.info, Node: Examples of WHILE and UNTIL clauses, Prev: Examples of ALWAYS, Up: Termination Test Clauses 6.1.4.3 Examples of WHILE and UNTIL clauses ........................................... (loop while (hungry-p) do (eat)) ;; UNTIL NOT is equivalent to WHILE. (loop until (not (hungry-p)) do (eat)) ;; Collect the length and the items of STACK. (let ((stack '(a b c d e f))) (loop for item = (length stack) then (pop stack) collect item while stack)) => (6 A B C D E F) ;; Use WHILE to terminate a loop that otherwise wouldn't terminate. ;; Note that WHILE occurs after the WHEN. (loop for i fixnum from 3 when (oddp i) collect i while (< i 5)) => (3 5)  File: gcl.info, Node: Unconditional Execution Clauses, Next: Conditional Execution Clauses, Prev: Termination Test Clauses, Up: The LOOP Facility 6.1.5 Unconditional Execution Clauses ------------------------------------- The do and doing constructs evaluate the supplied forms wherever they occur in the expanded form of loop. The form argument can be any compound form. Each form is evaluated in every iteration. Because every loop clause must begin with a loop keyword, the keyword do is used when no control action other than execution is required. The return construct takes one form. Any values returned by the form are immediately returned by the loop form. It is equivalent to the clause do (return-from block-name value), where block-name is the name specified in a named clause, or nil if there is no named clause. * Menu: * Examples of unconditional execution::  File: gcl.info, Node: Examples of unconditional execution, Prev: Unconditional Execution Clauses, Up: Unconditional Execution Clauses 6.1.5.1 Examples of unconditional execution ........................................... ;; Print numbers and their squares. ;; The DO construct applies to multiple forms. (loop for i from 1 to 3 do (print i) (print (* i i))) |> 1 |> 1 |> 2 |> 4 |> 3 |> 9 => NIL  File: gcl.info, Node: Conditional Execution Clauses, Next: Miscellaneous Clauses, Prev: Unconditional Execution Clauses, Up: The LOOP Facility 6.1.6 Conditional Execution Clauses ----------------------------------- The if, when, and unless constructs establish conditional control in a loop. If the test passes, the succeeding loop clause is executed. If the test does not pass, the succeeding clause is skipped, and program control moves to the clause that follows the loop keyword else. If the test does not pass and no else clause is supplied, control is transferred to the clause or construct following the entire conditional clause. If conditional clauses are nested, each else is paired with the closest preceding conditional clause that has no associated else or end. In the if and when clauses, which are synonymous, the test passes if the value of form is true. In the unless clause, the test passes if the value of form is false. Clauses that follow the test expression can be grouped by using the loop keyword and to produce a conditional block consisting of a compound clause. The loop keyword it can be used to refer to the result of the test expression in a clause. Use the loop keyword it in place of the form in a return clause or an accumulation clause that is inside a conditional execution clause. If multiple clauses are connected with and, the it construct must be in the first clause in the block. The optional loop keyword end marks the end of the clause. If this keyword is not supplied, the next loop keyword marks the end. The construct end can be used to distinguish the scoping of compound clauses. * Menu: * Examples of WHEN clause::  File: gcl.info, Node: Examples of WHEN clause, Prev: Conditional Execution Clauses, Up: Conditional Execution Clauses 6.1.6.1 Examples of WHEN clause ............................... ;; Signal an exceptional condition. (loop for item in '(1 2 3 a 4 5) when (not (numberp item)) return (cerror "enter new value" "non-numeric value: ~s" item)) Error: non-numeric value: A ;; The previous example is equivalent to the following one. (loop for item in '(1 2 3 a 4 5) when (not (numberp item)) do (return (cerror "Enter new value" "non-numeric value: ~s" item))) Error: non-numeric value: A ;; This example parses a simple printed string representation from ;; BUFFER (which is itself a string) and returns the index of the ;; closing double-quote character. (let ((buffer "\"a\" \"b\"")) (loop initially (unless (char= (char buffer 0) #\") (loop-finish)) for i of-type fixnum from 1 below (length (the string buffer)) when (char= (char buffer i) #\") return i)) => 2 ;; The collected value is returned. (loop for i from 1 to 10 when (> i 5) collect i finally (prin1 'got-here)) |> GOT-HERE => (6 7 8 9 10) ;; Return both the count of collected numbers and the numbers. (loop for i from 1 to 10 when (> i 5) collect i into number-list and count i into number-count finally (return (values number-count number-list))) => 5, (6 7 8 9 10)  File: gcl.info, Node: Miscellaneous Clauses, Next: Examples of Miscellaneous Loop Features, Prev: Conditional Execution Clauses, Up: The LOOP Facility 6.1.7 Miscellaneous Clauses --------------------------- * Menu: * Control Transfer Clauses:: * Examples of NAMED clause:: * Initial and Final Execution::  File: gcl.info, Node: Control Transfer Clauses, Next: Examples of NAMED clause, Prev: Miscellaneous Clauses, Up: Miscellaneous Clauses 6.1.7.1 Control Transfer Clauses ................................ The named construct establishes a name for an implicit block surrounding the entire loop so that the return-from special operator can be used to return values from or to exit loop. Only one name per loop form can be assigned. If used, the named construct must be the first clause in the loop expression. The return construct takes one form. Any values returned by the form are immediately returned by the loop form. This construct is similar to the return-from special operator and the return macro. The return construct does not execute any finally clause that the loop form is given.  File: gcl.info, Node: Examples of NAMED clause, Next: Initial and Final Execution, Prev: Control Transfer Clauses, Up: Miscellaneous Clauses 6.1.7.2 Examples of NAMED clause ................................ ;; Just name and return. (loop named max for i from 1 to 10 do (print i) do (return-from max 'done)) |> 1 => DONE  File: gcl.info, Node: Initial and Final Execution, Prev: Examples of NAMED clause, Up: Miscellaneous Clauses 6.1.7.3 Initial and Final Execution ................................... The initially and finally constructs evaluate forms that occur before and after the loop body. The initially construct causes the supplied compound-forms to be evaluated in the loop prologue, which precedes all loop code except for initial settings supplied by constructs with, for, or as. The code for any initially clauses is executed in the order in which the clauses appeared in the loop. The finally construct causes the supplied compound-forms to be evaluated in the loop epilogue after normal iteration terminates. The code for any finally clauses is executed in the order in which the clauses appeared in the loop. The collected code is executed once in the loop epilogue before any implicit values are returned from the accumulation clauses. An explicit transfer of control (e.g., by return, go, or throw) from the loop body, however, will exit the loop without executing the epilogue code. Clauses such as return, always, never, and thereis can bypass the finally clause. return (or return-from, if the named option was supplied) can be used after finally to return values from a loop. Such an explicit return inside the finally clause takes precedence over returning the accumulation from clauses supplied by such keywords as collect, nconc, append, sum, count, maximize, and minimize; the accumulation values for these preempted clauses are not returned by loop if return or return-from is used.  File: gcl.info, Node: Examples of Miscellaneous Loop Features, Next: Notes about Loop, Prev: Miscellaneous Clauses, Up: The LOOP Facility 6.1.8 Examples of Miscellaneous Loop Features --------------------------------------------- (let ((i 0)) ; no loop keywords are used (loop (incf i) (if (= i 3) (return i)))) => 3 (let ((i 0)(j 0)) (tagbody (loop (incf j 3) (incf i) (if (= i 3) (go exit))) exit) j) => 9 In the following example, the variable x is stepped before y is stepped; thus, the value of y reflects the updated value of x: (loop for x from 1 to 10 for y = nil then x collect (list x y)) => ((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10)) In this example, x and y are stepped in parallel: (loop for x from 1 to 10 and y = nil then x collect (list x y)) => ((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9)) * Menu: * Examples of clause grouping::  File: gcl.info, Node: Examples of clause grouping, Prev: Examples of Miscellaneous Loop Features, Up: Examples of Miscellaneous Loop Features 6.1.8.1 Examples of clause grouping ................................... ;; Group conditional clauses. (loop for i in '(1 324 2345 323 2 4 235 252) when (oddp i) do (print i) and collect i into odd-numbers and do (terpri) else ; I is even. collect i into even-numbers finally (return (values odd-numbers even-numbers))) |> 1 |> |> 2345 |> |> 323 |> |> 235 => (1 2345 323 235), (324 2 4 252) ;; Collect numbers larger than 3. (loop for i in '(1 2 3 4 5 6) when (and (> i 3) i) collect it) ; IT refers to (and (> i 3) i). => (4 5 6) ;; Find a number in a list. (loop for i in '(1 2 3 4 5 6) when (and (> i 3) i) return it) => 4 ;; The above example is similar to the following one. (loop for i in '(1 2 3 4 5 6) thereis (and (> i 3) i)) => 4 ;; Nest conditional clauses. (let ((list '(0 3.0 apple 4 5 9.8 orange banana))) (loop for i in list when (numberp i) when (floatp i) collect i into float-numbers else ; Not (floatp i) collect i into other-numbers else ; Not (numberp i) when (symbolp i) collect i into symbol-list else ; Not (symbolp i) do (error "found a funny value in list ~S, value ~S~ finally (return (values float-numbers other-numbers symbol-list)))) => (3.0 9.8), (0 4 5), (APPLE ORANGE BANANA) ;; Without the END preposition, the last AND would apply to the ;; inner IF rather than the outer one. (loop for x from 0 to 3 do (print x) if (zerop (mod x 2)) do (princ " a") and if (zerop (floor x 2)) do (princ " b") end and do (princ " c")) |> 0 a b c |> 1 |> 2 a c |> 3 => NIL  File: gcl.info, Node: Notes about Loop, Prev: Examples of Miscellaneous Loop Features, Up: The LOOP Facility 6.1.9 Notes about Loop ---------------------- Types can be supplied for loop variables. It is not necessary to supply a type for any variable, but supplying the type can ensure that the variable has a correctly typed initial value, and it can also enable compiler optimizations (depending on the implementation). The clause repeat n ... is roughly equivalent to a clause such as (loop for internal-variable downfrom (- n 1) to 0 ...) but in some implementations, the repeat construct might be more efficient. Within the executable parts of the loop clauses and around the entire loop form, variables can be bound by using let. Use caution when using a variable named IT (in any package) in connection with loop, since it is a loop keyword that can be used in place of a form in certain contexts. There is no standardized mechanism for users to add extensions to loop.  File: gcl.info, Node: Iteration Dictionary, Prev: The LOOP Facility, Up: Iteration 6.2 Iteration Dictionary ======================== * Menu: * do:: * dotimes:: * dolist:: * loop:: * loop-finish::  File: gcl.info, Node: do, Next: dotimes, Prev: Iteration Dictionary, Up: Iteration Dictionary 6.2.1 do, do* [Macro] --------------------- 'do' ({var | (var [init-form [step-form]])}*) (end-test-form {result-form}*) {declaration}* {tag | statement}* => {result}* 'do*' ({var | (var [init-form [step-form]])}*) (end-test-form {result-form}*) {declaration}* {tag | statement}* => {result}* Arguments and Values:: ...................... var--a symbol. init-form--a form. step-form--a form. end-test-form--a form. result-forms--an implicit progn. declaration--a declare expression; not evaluated. tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. results--if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-forms. Description:: ............. do iterates over a group of statements while a test condition holds. do accepts an arbitrary number of iteration vars which are bound within the iteration and stepped in parallel. An initial value may be supplied for each iteration variable by use of an init-form. Step-forms may be used to specify how the vars should be updated on succeeding iterations through the loop. Step-forms may be used both to generate successive values or to accumulate results. If the end-test-form condition is met prior to an execution of the body, the iteration terminates. Tags label statements. do* is exactly like do except that the bindings and steppings of the vars are performed sequentially rather than in parallel. Before the first iteration, all the init-forms are evaluated, and each var is bound to the value of its respective init-form, if supplied. This is a binding, not an assignment; when the loop terminates, the old values of those variables will be restored. For do, all of the init-forms are evaluated before any var is bound. The init-forms can refer to the bindings of the vars visible before beginning execution of do. For do*, the first init-form is evaluated, then the first var is bound to that value, then the second init-form is evaluated, then the second var is bound, and so on; in general, the kth init-form can refer to the new binding of the jth var if j < k, and otherwise to the old binding of the jth var. At the beginning of each iteration, after processing the variables, the end-test-form is evaluated. If the result is false, execution proceeds with the body of the do (or do*) form. If the result is true, the result-forms are evaluated in order as an implicit progn, and then do or do* returns. At the beginning of each iteration other than the first, vars are updated as follows. All the step-forms, if supplied, are evaluated, from left to right, and the resulting values are assigned to the respective vars. Any var that has no associated step-form is not assigned to. For do, all the step-forms are evaluated before any var is updated; the assignment of values to vars is done in parallel, as if by psetq. Because all of the step-forms are evaluated before any of the vars are altered, a step-form when evaluated always has access to the old values of all the vars, even if other step-forms precede it. For do*, the first step-form is evaluated, then the value is assigned to the first var, then the second step-form is evaluated, then the value is assigned to the second var, and so on; the assignment of values to variables is done sequentially, as if by setq. For either do or do*, after the vars have been updated, the end-test-form is evaluated as described above, and the iteration continues. The remainder of the do (or do*) form constitutes an implicit tagbody. Tags may appear within the body of a do loop for use by go statements appearing in the body (but such go statements may not appear in the variable specifiers, the end-test-form, or the result-forms). When the end of a do body is reached, the next iteration cycle (beginning with the evaluation of step-forms) occurs. An implicit block named nil surrounds the entire do (or do*) form. A return statement may be used at any point to exit the loop immediately. Init-form is an initial value for the var with which it is associated. If init-form is omitted, the initial value of var is nil. If a declaration is supplied for a var, init-form must be consistent with the declaration. Declarations can appear at the beginning of a do (or do*) body. They apply to code in the do (or do*) body, to the bindings of the do (or do*) vars, to the step-forms, to the end-test-form, and to the result-forms. Examples:: .......... (do ((temp-one 1 (1+ temp-one)) (temp-two 0 (1- temp-two))) ((> (- temp-one temp-two) 5) temp-one)) => 4 (do ((temp-one 1 (1+ temp-one)) (temp-two 0 (1+ temp-one))) ((= 3 temp-two) temp-one)) => 3 (do* ((temp-one 1 (1+ temp-one)) (temp-two 0 (1+ temp-one))) ((= 3 temp-two) temp-one)) => 2 (do ((j 0 (+ j 1))) (nil) ;Do forever. (format t "~ (let ((item (read))) (if (null item) (return) ;Process items until NIL seen. (format t "~&Output ~D: ~S" j item)))) |> Input 0: |>>banana<<| |> Output 0: BANANA |> Input 1: |>>(57 boxes)<<| |> Output 1: (57 BOXES) |> Input 2: |>>NIL<<| => NIL (setq a-vector (vector 1 nil 3 nil)) (do ((i 0 (+ i 1)) ;Sets every null element of a-vector to zero. (n (array-dimension a-vector 0))) ((= i n)) (when (null (aref a-vector i)) (setf (aref a-vector i) 0))) => NIL a-vector => #(1 0 3 0) (do ((x e (cdr x)) (oldx x x)) ((null x)) body) is an example of parallel assignment to index variables. On the first iteration, the value of oldx is whatever value x had before the do was entered. On succeeding iterations, oldx contains the value that x had on the previous iteration. (do ((x foo (cdr x)) (y bar (cdr y)) (z '() (cons (f (car x) (car y)) z))) ((or (null x) (null y)) (nreverse z))) does the same thing as (mapcar #'f foo bar). The step computation for z is an example of the fact that variables are stepped in parallel. Also, the body of the loop is empty. (defun list-reverse (list) (do ((x list (cdr x)) (y '() (cons (car x) y))) ((endp x) y))) As an example of nested iterations, consider a data structure that is a list of conses. The car of each cons is a list of symbols, and the cdr of each cons is a list of equal length containing corresponding values. Such a data structure is similar to an association list, but is divided into "frames"; the overall structure resembles a rib-cage. A lookup function on such a data structure might be: (defun ribcage-lookup (sym ribcage) (do ((r ribcage (cdr r))) ((null r) nil) (do ((s (caar r) (cdr s)) (v (cdar r) (cdr v))) ((null s)) (when (eq (car s) sym) (return-from ribcage-lookup (car v)))))) => RIBCAGE-LOOKUP See Also:: .......... other iteration functions ( *note dolist:: , *note dotimes:: , and *note loop:: ) and more primitive functionality ( *note tagbody:: , *note go:: , *note block:: , *note return:: , *note let:: , and *note setq:: ) Notes:: ....... If end-test-form is nil, the test will never succeed. This provides an idiom for "do forever": the body of the do or do* is executed repeatedly. The infinite loop can be terminated by the use of return, return-from, go to an outer level, or throw. A do form may be explained in terms of the more primitive forms block, return, let, loop, tagbody, and psetq as follows: (block nil (let ((var1 init1) (var2 init2) ... (varn initn)) declarations (loop (when end-test (return (progn . result))) (tagbody . tagbody) (psetq var1 step1 var2 step2 ... varn stepn)))) do* is similar, except that let* and setq replace the let and psetq, respectively.  File: gcl.info, Node: dotimes, Next: dolist, Prev: do, Up: Iteration Dictionary 6.2.2 dotimes [Macro] --------------------- 'dotimes' (var count-form [result-form]) {declaration}* {tag | statement}* => {result}* Arguments and Values:: ...................... var--a symbol. count-form--a form. result-form--a form. declaration--a declare expression; not evaluated. tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. results--if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-form or nil if there is no result-form. Description:: ............. dotimes iterates over a series of integers. dotimes evaluates count-form, which should produce an integer. If count-form is zero or negative, the body is not executed. dotimes then executes the body once for each integer from 0 up to but not including the value of count-form, in the order in which the tags and statements occur, with var bound to each integer. Then result-form is evaluated. At the time result-form is processed, var is bound to the number of times the body was executed. Tags label statements. An implicit block named nil surrounds dotimes. return may be used to terminate the loop immediately without performing any further iterations, returning zero or more values. The body of the loop is an implicit tagbody; it may contain tags to serve as the targets of go statements. Declarations may appear before the body of the loop. The scope of the binding of var does not include the count-form, but the result-form is included. It is implementation-dependent whether dotimes establishes a new binding of var on each iteration or whether it establishes a binding for var once at the beginning and then assigns it on any subsequent iterations. Examples:: .......... (dotimes (temp-one 10 temp-one)) => 10 (setq temp-two 0) => 0 (dotimes (temp-one 10 t) (incf temp-two)) => T temp-two => 10 Here is an example of the use of dotimes in processing strings: ;;; True if the specified subsequence of the string is a ;;; palindrome (reads the same forwards and backwards). (defun palindromep (string &optional (start 0) (end (length string))) (dotimes (k (floor (- end start) 2) t) (unless (char-equal (char string (+ start k)) (char string (- end k 1))) (return nil)))) (palindromep "Able was I ere I saw Elba") => T (palindromep "A man, a plan, a canal--Panama!") => NIL (remove-if-not #'alpha-char-p ;Remove punctuation. "A man, a plan, a canal--Panama!") => "AmanaplanacanalPanama" (palindromep (remove-if-not #'alpha-char-p "A man, a plan, a canal--Panama!")) => T (palindromep (remove-if-not #'alpha-char-p "Unremarkable was I ere I saw Elba Kramer, nu?")) => T (palindromep (remove-if-not #'alpha-char-p "A man, a plan, a cat, a ham, a yak, a yam, a hat, a canal--Panama!")) => T See Also:: .......... *note do:: , *note dolist:: , *note tagbody:: Notes:: ....... go may be used within the body of dotimes to transfer control to a statement labeled by a tag.  File: gcl.info, Node: dolist, Next: loop, Prev: dotimes, Up: Iteration Dictionary 6.2.3 dolist [Macro] -------------------- 'dolist' (var list-form [result-form]) {declaration}* {tag | statement}* => {result}* Arguments and Values:: ...................... var--a symbol. list-form--a form. result-form--a form. declaration--a declare expression; not evaluated. tag--a go tag; not evaluated. statement--a compound form; evaluated as described below. results--if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-form or nil if there is no result-form. Description:: ............. dolist iterates over the elements of a list. The body of dolist is like a tagbody. It consists of a series of tags and statements. dolist evaluates list-form, which should produce a list. It then executes the body once for each element in the list, in the order in which the tags and statements occur, with var bound to the element. Then result-form is evaluated. tags label statements. At the time result-form is processed, var is bound to nil. An implicit block named nil surrounds dolist. return may be used to terminate the loop immediately without performing any further iterations, returning zero or more values. The scope of the binding of var does not include the list-form, but the result-form is included. It is implementation-dependent whether dolist establishes a new binding of var on each iteration or whether it establishes a binding for var once at the beginning and then assigns it on any subsequent iterations. Examples:: .......... (setq temp-two '()) => NIL (dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two)) => (4 3 2 1) (setq temp-two 0) => 0 (dolist (temp-one '(1 2 3 4)) (incf temp-two)) => NIL temp-two => 4 (dolist (x '(a b c d)) (prin1 x) (princ " ")) |> A B C D => NIL See Also:: .......... *note do:: , *note dotimes:: , *note tagbody:: , *note Traversal Rules and Side Effects:: Notes:: ....... go may be used within the body of dolist to transfer control to a statement labeled by a tag.  File: gcl.info, Node: loop, Next: loop-finish, Prev: dolist, Up: Iteration Dictionary 6.2.4 loop [Macro] ------------------ The "simple" loop form: 'loop' {compound-form}* => {result}* The "extended" loop form: 'loop' [!name-clause] {!variable-clause}* {!main-clause}* => {result}* name-clause ::=named name variable-clause ::=!with-clause | !initial-final | !for-as-clause with-clause ::=with var1 [type-spec] [= form1] {and var2 [type-spec] [= form2]}* main-clause ::=!unconditional | !accumulation | !conditional | !termination-test | !initial-final initial-final ::=initially {compound-form}^+ | finally {compound-form}^+ unconditional ::={do | doing} {compound-form}^+ | return {form | it} accumulation ::=!list-accumulation | !numeric-accumulation list-accumulation ::={collect | collecting | append | appending | nconc | nconcing} {form | it} [into simple-var] numeric-accumulation ::={count | counting | sum | summing | } maximize | maximizing | minimize | minimizing {form | it} [into simple-var] [type-spec] conditional ::={if | when | unless} form !selectable-clause {and !selectable-clause}* [else !selectable-clause {and !selectable-clause}*] [end] selectable-clause ::=!unconditional | !accumulation | !conditional termination-test ::=while form | until form | repeat form | always form | never form | thereis form for-as-clause ::={for | as} !for-as-subclause {and !for-as-subclause}* for-as-subclause ::=!for-as-arithmetic | !for-as-in-list | !for-as-on-list | !for-as-equals-then | !for-as-across | !for-as-hash | !for-as-package for-as-arithmetic ::=var [type-spec] !for-as-arithmetic-subclause for-as-arithmetic-subclause ::=!arithmetic-up | !arithmetic-downto | !arithmetic-downfrom arithmetic-up ::=[[{from | upfrom} form1 | {to | upto | below} form2 | by form3]]^+ arithmetic-downto ::=[[{from form1}^1 | {{downto | above} form2}^1 | by form3]] arithmetic-downfrom ::=[[{downfrom form1}^1 | {to | downto | above} form2 | by form3]] for-as-in-list ::=var [type-spec] in form1 [by step-fun] for-as-on-list ::=var [type-spec] on form1 [by step-fun] for-as-equals-then ::=var [type-spec] = form1 [then form2] for-as-across ::=var [type-spec] across vector for-as-hash ::=var [type-spec] being {each | the} {{hash-key | hash-keys} {in | of} hash-table [using (hash-value other-var)] | {hash-value | hash-values} {in | of} hash-table [using (hash-key other-var)]} for-as-package ::=var [type-spec] being {each | the} {symbol | symbols | present-symbol | present-symbols | external-symbol | external-symbols} [{in | of} package] type-spec ::=!simple-type-spec | !destructured-type-spec simple-type-spec ::=fixnum | float | t | nil destructured-type-spec ::=of-type d-type-spec d-type-spec ::=type-specifier | (d-type-spec . d-type-spec) var ::=!d-var-spec var1 ::=!d-var-spec var2 ::=!d-var-spec other-var ::=!d-var-spec d-var-spec ::=simple-var | nil | (!d-var-spec . !d-var-spec) Arguments and Values:: ...................... compound-form--a compound form. name--a symbol. simple-var--a symbol (a variable name). form, form1, form2, form3--a form. step-fun--a form that evaluates to a function of one argument. vector--a form that evaluates to a vector. hash-table--a form that evaluates to a hash table. package--a form that evaluates to a package designator. type-specifier--a type specifier. This might be either an atomic type specifier or a compound type specifier, which introduces some additional complications to proper parsing in the face of destructuring; for further information, see *note Destructuring::. result--an object. Description:: ............. For details, see *note The LOOP Facility::. Examples:: .......... ;; An example of the simple form of LOOP. (defun sqrt-advisor () (loop (format t "~&Number: ") (let ((n (parse-integer (read-line) :junk-allowed t))) (when (not n) (return)) (format t "~&The square root of ~D is ~D.~%" n (sqrt n))))) => SQRT-ADVISOR (sqrt-advisor) |> Number: |>>5 [<-~]<<| |> The square root of 5 is 2.236068. |> Number: |>>4 [<-~]<<| |> The square root of 4 is 2. |> Number: |>>done [<-~]<<| => NIL ;; An example of the extended form of LOOP. (defun square-advisor () (loop as n = (progn (format t "~&Number: ") (parse-integer (read-line) :junk-allowed t)) while n do (format t "~&The square of ~D is ~D.~ => SQUARE-ADVISOR (square-advisor) |> Number: |>>4 [<-~]<<| |> The square of 4 is 16. |> Number: |>>23 [<-~]<<| |> The square of 23 is 529. |> Number: |>>done [<-~]<<| => NIL ;; Another example of the extended form of LOOP. (loop for n from 1 to 10 when (oddp n) collect n) => (1 3 5 7 9) See Also:: .......... *note do:: , *note dolist:: , *note dotimes:: , *note return:: , *note go:: , *note throw:: , *note Destructuring:: Notes:: ....... Except that loop-finish cannot be used within a simple loop form, a simple loop form is related to an extended loop form in the following way: (loop {compound-form}*) == (loop do {compound-form}*)  File: gcl.info, Node: loop-finish, Prev: loop, Up: Iteration Dictionary 6.2.5 loop-finish [Local Macro] ------------------------------- Syntax:: ........ 'loop-finish' => # Description:: ............. The loop-finish macro can be used lexically within an extended loop form to terminate that form "normally." That is, it transfers control to the loop epilogue of the lexically innermost extended loop form. This permits execution of any finally clause (for effect) and the return of any accumulated result. Examples:: .......... ;; Terminate the loop, but return the accumulated count. (loop for i in '(1 2 3 stop-here 4 5 6) when (symbolp i) do (loop-finish) count i) => 3 ;; The preceding loop is equivalent to: (loop for i in '(1 2 3 stop-here 4 5 6) until (symbolp i) count i) => 3 ;; While LOOP-FINISH can be used can be used in a variety of ;; situations it is really most needed in a situation where a need ;; to exit is detected at other than the loop's `top level' ;; (where UNTIL or WHEN often work just as well), or where some ;; computation must occur between the point where a need to exit is ;; detected and the point where the exit actually occurs. For example: (defun tokenize-sentence (string) (macrolet ((add-word (wvar svar) `(when ,wvar (push (coerce (nreverse ,wvar) 'string) ,svar) (setq ,wvar nil)))) (loop with word = '() and sentence = '() and endpos = nil for i below (length string) do (let ((char (aref string i))) (case char (#\Space (add-word word sentence)) (#\. (setq endpos (1+ i)) (loop-finish)) (otherwise (push char word)))) finally (add-word word sentence) (return (values (nreverse sentence) endpos))))) => TOKENIZE-SENTENCE (tokenize-sentence "this is a sentence. this is another sentence.") => ("this" "is" "a" "sentence"), 19 (tokenize-sentence "this is a sentence") => ("this" "is" "a" "sentence"), NIL Side Effects:: .............. Transfers control. Exceptional Situations:: ........................ Whether or not loop-finish is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of loop-finish are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use loop-finish outside of loop are undefined. See Also:: .......... *note loop:: , *note The LOOP Facility:: Notes:: .......  File: gcl.info, Node: Objects, Next: Structures, Prev: Iteration, Up: Top 7 Objects ********* * Menu: * Object Creation and Initialization:: * Changing the Class of an Instance:: * Reinitializing an Instance:: * Meta-Objects:: * Slots:: * Generic Functions and Methods:: * Objects Dictionary::  File: gcl.info, Node: Object Creation and Initialization, Next: Changing the Class of an Instance, Prev: Objects, Up: Objects 7.1 Object Creation and Initialization ====================================== The generic function make-instance creates and returns a new instance of a class. The first argument is a class or the name of a class, and the remaining arguments form an initialization argument list . The initialization of a new instance consists of several distinct steps, including the following: combining the explicitly supplied initialization arguments with default values for the unsupplied initialization arguments, checking the validity of the initialization arguments, allocating storage for the instance, filling slots with values, and executing user-supplied methods that perform additional initialization. Each step of make-instance is implemented by a generic function to provide a mechanism for customizing that step. In addition, make-instance is itself a generic function and thus also can be customized. The object system specifies system-supplied primary methods for each step and thus specifies a well-defined standard behavior for the entire initialization process. The standard behavior provides four simple mechanisms for controlling initialization: * Declaring a symbol to be an initialization argument for a slot. An initialization argument is declared by using the :initarg slot option to defclass. This provides a mechanism for supplying a value for a slot in a call to make-instance. * Supplying a default value form for an initialization argument. Default value forms for initialization arguments are defined by using the :default-initargs class option to defclass. If an initialization argument is not explicitly provided as an argument to make-instance, the default value form is evaluated in the lexical environment of the defclass form that defined it, and the resulting value is used as the value of the initialization argument. * Supplying a default initial value form for a slot. A default initial value form for a slot is defined by using the :initform slot option to defclass. If no initialization argument associated with that slot is given as an argument to make-instance or is defaulted by :default-initargs, this default initial value form is evaluated in the lexical environment of the defclass form that defined it, and the resulting value is stored in the slot. The :initform form for a local slot may be used when creating an instance, when updating an instance to conform to a redefined class, or when updating an instance to conform to the definition of a different class. The :initform form for a shared slot may be used when defining or re-defining the class. * Defining methods for initialize-instance and shared-initialize. The slot-filling behavior described above is implemented by a system-supplied primary method for initialize-instance which invokes shared-initialize. The generic function shared-initialize implements the parts of initialization shared by these four situations: when making an instance, when re-initializing an instance, when updating an instance to conform to a redefined class, and when updating an instance to conform to the definition of a different class. The system-supplied primary method for shared-initialize directly implements the slot-filling behavior described above, and initialize-instance simply invokes shared-initialize. * Menu: * Initialization Arguments:: * Declaring the Validity of Initialization Arguments:: * Defaulting of Initialization Arguments:: * Rules for Initialization Arguments:: * Shared-Initialize:: * Initialize-Instance:: * Definitions of Make-Instance and Initialize-Instance::  File: gcl.info, Node: Initialization Arguments, Next: Declaring the Validity of Initialization Arguments, Prev: Object Creation and Initialization, Up: Object Creation and Initialization 7.1.1 Initialization Arguments ------------------------------ An initialization argument controls object creation and initialization. It is often convenient to use keyword symbols to name initialization arguments, but the name of an initialization argument can be any symbol, including nil. An initialization argument can be used in two ways: to fill a slot with a value or to provide an argument for an initialization method. A single initialization argument can be used for both purposes. An initialization argument list is a property list of initialization argument names and values. Its structure is identical to a property list and also to the portion of an argument list processed for &key parameters. As in those lists, if an initialization argument name appears more than once in an initialization argument list, the leftmost occurrence supplies the value and the remaining occurrences are ignored. The arguments to make-instance (after the first argument) form an initialization argument list. An initialization argument can be associated with a slot. If the initialization argument has a value in the initialization argument list, the value is stored into the slot of the newly created object, overriding any :initform form associated with the slot. A single initialization argument can initialize more than one slot. An initialization argument that initializes a shared slot stores its value into the shared slot, replacing any previous value. An initialization argument can be associated with a method. When an object is created and a particular initialization argument is supplied, the generic functions initialize-instance, shared-initialize, and allocate-instance are called with that initialization argument's name and value as a keyword argument pair. If a value for the initialization argument is not supplied in the initialization argument list, the method's lambda list supplies a default value. Initialization arguments are used in four situations: when making an instance, when re-initializing an instance, when updating an instance to conform to a redefined class, and when updating an instance to conform to the definition of a different class. Because initialization arguments are used to control the creation and initialization of an instance of some particular class, we say that an initialization argument is "an initialization argument for" that class.  File: gcl.info, Node: Declaring the Validity of Initialization Arguments, Next: Defaulting of Initialization Arguments, Prev: Initialization Arguments, Up: Object Creation and Initialization 7.1.2 Declaring the Validity of Initialization Arguments -------------------------------------------------------- Initialization arguments are checked for validity in each of the four situations that use them. An initialization argument may be valid in one situation and not another. For example, the system-supplied primary method for make-instance defined for the class standard-class checks the validity of its initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid in that situation. There are two means for declaring initialization arguments valid. * Initialization arguments that fill slots are declared as valid by the :initarg slot option to defclass. The :initarg slot option is inherited from superclasses. Thus the set of valid initialization arguments that fill slots for a class is the union of the initialization arguments that fill slots declared as valid by that class and its superclasses. Initialization arguments that fill slots are valid in all four contexts. * Initialization arguments that supply arguments to methods are declared as valid by defining those methods. The keyword name of each keyword parameter specified in the method's lambda list becomes an initialization argument for all classes for which the method is applicable. The presence of &allow-other-keys in the lambda list of an applicable method disables validity checking of initialization arguments. Thus method inheritance controls the set of valid initialization arguments that supply arguments to methods. The generic functions for which method definitions serve to declare initialization arguments valid are as follows: - Making an instance of a class: allocate-instance, initialize-instance, and shared-initialize. Initialization arguments declared as valid by these methods are valid when making an instance of a class. - Re-initializing an instance: reinitialize-instance and shared-initialize. Initialization arguments declared as valid by these methods are valid when re-initializing an instance. - Updating an instance to conform to a redefined class: update-instance-for-redefined-class and shared-initialize. Initialization arguments declared as valid by these methods are valid when updating an instance to conform to a redefined class. - Updating an instance to conform to the definition of a different class: update-instance-for-different-class and shared-initialize. Initialization arguments declared as valid by these methods are valid when updating an instance to conform to the definition of a different class. The set of valid initialization arguments for a class is the set of valid initialization arguments that either fill slots or supply arguments to methods, along with the predefined initialization argument :allow-other-keys. The default value for :allow-other-keys is nil. Validity checking of initialization arguments is disabled if the value of the initialization argument :allow-other-keys is true.  File: gcl.info, Node: Defaulting of Initialization Arguments, Next: Rules for Initialization Arguments, Prev: Declaring the Validity of Initialization Arguments, Up: Object Creation and Initialization 7.1.3 Defaulting of Initialization Arguments -------------------------------------------- A default value form can be supplied for an initialization argument by using the :default-initargs class option. If an initialization argument is declared valid by some particular class, its default value form might be specified by a different class. In this case :default-initargs is used to supply a default value for an inherited initialization argument. The :default-initargs option is used only to provide default values for initialization arguments; it does not declare a symbol as a valid initialization argument name. Furthermore, the :default-initargs option is used only to provide default values for initialization arguments when making an instance. The argument to the :default-initargs class option is a list of alternating initialization argument names and forms. Each form is the default value form for the corresponding initialization argument. The default value form of an initialization argument is used and evaluated only if that initialization argument does not appear in the arguments to make-instance and is not defaulted by a more specific class. The default value form is evaluated in the lexical environment of the defclass form that supplied it; the resulting value is used as the initialization argument's value. The initialization arguments supplied to make-instance are combined with defaulted initialization arguments to produce a defaulted initialization argument list. A defaulted initialization argument list is a list of alternating initialization argument names and values in which unsupplied initialization arguments are defaulted and in which the explicitly supplied initialization arguments appear earlier in the list than the defaulted initialization arguments. Defaulted initialization arguments are ordered according to the order in the class precedence list of the classes that supplied the default values. There is a distinction between the purposes of the :default-initargs and the :initform options with respect to the initialization of slots. The :default-initargs class option provides a mechanism for the user to give a default value form for an initialization argument without knowing whether the initialization argument initializes a slot or is passed to a method. If that initialization argument is not explicitly supplied in a call to make-instance, the default value form is used, just as if it had been supplied in the call. In contrast, the :initform slot option provides a mechanism for the user to give a default initial value form for a slot. An :initform form is used to initialize a slot only if no initialization argument associated with that slot is given as an argument to make-instance or is defaulted by :default-initargs. The order of evaluation of default value forms for initialization arguments and the order of evaluation of :initform forms are undefined. If the order of evaluation is important, initialize-instance or shared-initialize methods should be used instead.  File: gcl.info, Node: Rules for Initialization Arguments, Next: Shared-Initialize, Prev: Defaulting of Initialization Arguments, Up: Object Creation and Initialization 7.1.4 Rules for Initialization Arguments ---------------------------------------- The :initarg slot option may be specified more than once for a given slot. The following rules specify when initialization arguments may be multiply defined: * A given initialization argument can be used to initialize more than one slot if the same initialization argument name appears in more than one :initarg slot option. * A given initialization argument name can appear in the lambda list of more than one initialization method. * A given initialization argument name can appear both in an :initarg slot option and in the lambda list of an initialization method. [Reviewer Note by The next three paragraphs could be replaced by "If two or more initialization arguments that initialize the same slot appear in the defaulted initialization argument list, the leftmost of these supplies the value, even if they have different names." And the rest would follow from the rules above.] If two or more initialization arguments that initialize the same slot are given in the arguments to make-instance, the leftmost of these initialization arguments in the initialization argument list supplies the value, even if the initialization arguments have different names. If two or more different initialization arguments that initialize the same slot have default values and none is given explicitly in the arguments to make-instance, the initialization argument that appears in a :default-initargs class option in the most specific of the classes supplies the value. If a single :default-initargs class option specifies two or more initialization arguments that initialize the same slot and none is given explicitly in the arguments to make-instance, the leftmost in the :default-initargs class option supplies the value, and the values of the remaining default value forms are ignored. Initialization arguments given explicitly in the arguments to make-instance appear to the left of defaulted initialization arguments. Suppose that the classes C_1 and C_2 supply the values of defaulted initialization arguments for different slots, and suppose that C_1 is more specific than C_2; then the defaulted initialization argument whose value is supplied by C_1 is to the left of the defaulted initialization argument whose value is supplied by C_2 in the defaulted initialization argument list. If a single :default-initargs class option supplies the values of initialization arguments for two different slots, the initialization argument whose value is specified farther to the left in the :default-initargs class option appears farther to the left in the defaulted initialization argument list. [Reviewer Note by Barmar: End of claim made three paragraphs back.] If a slot has both an :initform form and an :initarg slot option, and the initialization argument is defaulted using :default-initargs or is supplied to make-instance, the captured :initform form is neither used nor evaluated. The following is an example of the above rules: (defclass q () ((x :initarg a))) (defclass r (q) ((x :initarg b)) (:default-initargs a 1 b 2)) Defaulted Form Initialization Argument List Contents of Slot X _____________________________________________________________________________ (make-instance 'r) (a 1 b 2) 1 (make-instance 'r 'a 3) (a 3 b 2) 3 (make-instance 'r 'b 4) (b 4 a 1) 4 (make-instance 'r 'a 1 'a 2) (a 1 a 2 b 2) 1  File: gcl.info, Node: Shared-Initialize, Next: Initialize-Instance, Prev: Rules for Initialization Arguments, Up: Object Creation and Initialization 7.1.5 Shared-Initialize ----------------------- The generic function shared-initialize is used to fill the slots of an instance using initialization arguments and :initform forms when an instance is created, when an instance is re-initialized, when an instance is updated to conform to a redefined class, and when an instance is updated to conform to a different class. It uses standard method combination. It takes the following arguments: the instance to be initialized, a specification of a set of names of slots accessible in that instance, and any number of initialization arguments. The arguments after the first two must form an initialization argument list. The second argument to shared-initialize may be one of the following: * It can be a (possibly empty) list of slot names, which specifies the set of those slot names. * It can be the symbol t, which specifies the set of all of the slots. There is a system-supplied primary method for shared-initialize whose first parameter specializer is the class standard-object. This method behaves as follows on each slot, whether shared or local: * If an initialization argument in the initialization argument list specifies a value for that slot, that value is stored into the slot, even if a value has already been stored in the slot before the method is run. The affected slots are independent of which slots are indicated by the second argument to shared-initialize. * Any slots indicated by the second argument that are still unbound at this point are initialized according to their :initform forms. For any such slot that has an :initform form, that form is evaluated in the lexical environment of its defining defclass form and the result is stored into the slot. For example, if a before method stores a value in the slot, the :initform form will not be used to supply a value for the slot. If the second argument specifies a name that does not correspond to any slots accessible in the instance, the results are unspecified. * The rules mentioned in *note Rules for Initialization Arguments:: are obeyed. The generic function shared-initialize is called by the system-supplied primary methods for reinitialize-instance, update-instance-for-different-class, update-instance-for-redefined-class, and initialize-instance. Thus, methods can be written for shared-initialize to specify actions that should be taken in all of these contexts.  File: gcl.info, Node: Initialize-Instance, Next: Definitions of Make-Instance and Initialize-Instance, Prev: Shared-Initialize, Up: Object Creation and Initialization 7.1.6 Initialize-Instance ------------------------- The generic function initialize-instance is called by make-instance to initialize a newly created instance. It uses standard method combination. Methods for initialize-instance can be defined in order to perform any initialization that cannot be achieved simply by supplying initial values for slots. During initialization, initialize-instance is invoked after the following actions have been taken: * The defaulted initialization argument list has been computed by combining the supplied initialization argument list with any default initialization arguments for the class. * The validity of the defaulted initialization argument list has been checked. If any of the initialization arguments has not been declared as valid, an error is signaled. * A new instance whose slots are unbound has been created. The generic function initialize-instance is called with the new instance and the defaulted initialization arguments. There is a system-supplied primary method for initialize-instance whose parameter specializer is the class standard-object. This method calls the generic function shared-initialize to fill in the slots according to the initialization arguments and the :initform forms for the slots; the generic function shared-initialize is called with the following arguments: the instance, t, and the defaulted initialization arguments. Note that initialize-instance provides the defaulted initialization argument list in its call to shared-initialize, so the first step performed by the system-supplied primary method for shared-initialize takes into account both the initialization arguments provided in the call to make-instance and the defaulted initialization argument list. Methods for initialize-instance can be defined to specify actions to be taken when an instance is initialized. If only after methods for initialize-instance are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of initialize-instance. The object system provides two functions that are useful in the bodies of initialize-instance methods. The function slot-boundp returns a generic boolean value that indicates whether a specified slot has a value; this provides a mechanism for writing after methods for initialize-instance that initialize slots only if they have not already been initialized. The function slot-makunbound causes the slot to have no value.  File: gcl.info, Node: Definitions of Make-Instance and Initialize-Instance, Prev: Initialize-Instance, Up: Object Creation and Initialization 7.1.7 Definitions of Make-Instance and Initialize-Instance ---------------------------------------------------------- The generic function make-instance behaves as if it were defined as follows, except that certain optimizations are permitted: (defmethod make-instance ((class standard-class) &rest initargs) ... (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) (defmethod make-instance ((class-name symbol) &rest initargs) (apply #'make-instance (find-class class-name) initargs)) The elided code in the definition of make-instance augments the initargs with any defaulted initialization arguments and checks the resulting initialization arguments to determine whether an initialization argument was supplied that neither filled a slot nor supplied an argument to an applicable method. The generic function initialize-instance behaves as if it were defined as follows, except that certain optimizations are permitted: (defmethod initialize-instance ((instance standard-object) &rest initargs) (apply #'shared-initialize instance t initargs))) These procedures can be customized. Customizing at the Programmer Interface level includes using the :initform, :initarg, and :default-initargs options to defclass, as well as defining methods for make-instance, allocate-instance, and initialize-instance. It is also possible to define methods for shared-initialize, which would be invoked by the generic functions reinitialize-instance, update-instance-for-redefined-class, update-instance-for-different-class, and initialize-instance. The meta-object level supports additional customization. Implementations are permitted to make certain optimizations to initialize-instance and shared-initialize. The description of shared-initialize in Chapter~7 mentions the possible optimizations.  File: gcl.info, Node: Changing the Class of an Instance, Next: Reinitializing an Instance, Prev: Object Creation and Initialization, Up: Objects 7.2 Changing the Class of an Instance ===================================== The function change-class can be used to change the class of an instance from its current class, C_{from}, to a different class, C_{to}; it changes the structure of the instance to conform to the definition of the class C_{to}. Note that changing the class of an instance may cause slots to be added or deleted. Changing the class of an instance does not change its identity as defined by the eq function. When change-class is invoked on an instance, a two-step updating process takes place. The first step modifies the structure of the instance by adding new local slots and discarding local slots that are not specified in the new version of the instance. The second step initializes the newly added local slots and performs any other user-defined actions. These two steps are further described in the two following sections. * Menu: * Modifying the Structure of the Instance:: * Initializing Newly Added Local Slots (Changing the Class of an Instance):: * Customizing the Change of Class of an Instance::  File: gcl.info, Node: Modifying the Structure of the Instance, Next: Initializing Newly Added Local Slots (Changing the Class of an Instance), Prev: Changing the Class of an Instance, Up: Changing the Class of an Instance 7.2.1 Modifying the Structure of the Instance --------------------------------------------- In order to make the instance conform to the class C_{to}, local slots specified by the class C_{to} that are not specified by the class C_{from} are added, and local slots not specified by the class C_{to} that are specified by the class C_{from} are discarded. The values of local slots specified by both the class C_{to} and the class C_{from} are retained. If such a local slot was unbound, it remains unbound. The values of slots specified as shared in the class C_{from} and as local in the class C_{to} are retained. This first step of the update does not affect the values of any shared slots.  File: gcl.info, Node: Initializing Newly Added Local Slots (Changing the Class of an Instance), Next: Customizing the Change of Class of an Instance, Prev: Modifying the Structure of the Instance, Up: Changing the Class of an Instance 7.2.2 Initializing Newly Added Local Slots ------------------------------------------ The second step of the update initializes the newly added slots and performs any other user-defined actions. This step is implemented by the generic function update-instance-for-different-class. The generic function update-instance-for-different-class is invoked by change-class after the first step of the update has been completed. The generic function update-instance-for-different-class is invoked on arguments computed by change-class. The first argument passed is a copy of the instance being updated and is an instance of the class C_{from}; this copy has dynamic extent within the generic function change-class. The second argument is the instance as updated so far by change-class and is an instance of the class C_{to}. The remaining arguments are an initialization argument list. There is a system-supplied primary method for update-instance-for-different-class that has two parameter specializers, each of which is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see *note Declaring the Validity of Initialization Arguments::.) Then it calls the generic function shared-initialize with the following arguments: the new instance, a list of names of the newly added slots, and the initialization arguments it received.  File: gcl.info, Node: Customizing the Change of Class of an Instance, Prev: Initializing Newly Added Local Slots (Changing the Class of an Instance), Up: Changing the Class of an Instance 7.2.3 Customizing the Change of Class of an Instance ---------------------------------------------------- Methods for update-instance-for-different-class may be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-different-class are defined, they will be run after the system-supplied primary method for initialization and will not interfere with the default behavior of update-instance-for-different-class. Methods for shared-initialize may be defined to customize class redefinition. For more information, see *note Shared-Initialize::.  File: gcl.info, Node: Reinitializing an Instance, Next: Meta-Objects, Prev: Changing the Class of an Instance, Up: Objects 7.3 Reinitializing an Instance ============================== The generic function reinitialize-instance may be used to change the values of slots according to initialization arguments. The process of reinitialization changes the values of some slots and performs any user-defined actions. It does not modify the structure of an instance to add or delete slots, and it does not use any :initform forms to initialize slots. The generic function reinitialize-instance may be called directly. It takes one required argument, the instance. It also takes any number of initialization arguments to be used by methods for reinitialize-instance or for shared-initialize. The arguments after the required instance must form an initialization argument list. There is a system-supplied primary method for reinitialize-instance whose parameter specializer is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see *note Declaring the Validity of Initialization Arguments::.) Then it calls the generic function shared-initialize with the following arguments: the instance, nil, and the initialization arguments it received. * Menu: * Customizing Reinitialization::  File: gcl.info, Node: Customizing Reinitialization, Prev: Reinitializing an Instance, Up: Reinitializing an Instance 7.3.1 Customizing Reinitialization ---------------------------------- Methods for reinitialize-instance may be defined to specify actions to be taken when an instance is updated. If only after methods for reinitialize-instance are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of reinitialize-instance. Methods for shared-initialize may be defined to customize class redefinition. For more information, see *note Shared-Initialize::.  File: gcl.info, Node: Meta-Objects, Next: Slots, Prev: Reinitializing an Instance, Up: Objects 7.4 Meta-Objects ================ The implementation of the object system manipulates classes, methods, and generic functions. The object system contains a set of generic functions defined by methods on classes; the behavior of those generic functions defines the behavior of the object system. The instances of the classes on which those methods are defined are called meta-objects. * Menu: * Standard Meta-objects::  File: gcl.info, Node: Standard Meta-objects, Prev: Meta-Objects, Up: Meta-Objects 7.4.1 Standard Meta-objects --------------------------- The object system supplies a set of meta-objects, called standard meta-objects. These include the class standard-object and instances of the classes standard-method, standard-generic-function, and method-combination. [Editorial Note by KMP: This is said redundantly in the definition of STANDARD-METHOD.] * The class standard-method is the default class of methods defined by the defmethod and defgeneric forms. * The class standard-generic-function is the default class of generic functions defined by the forms defmethod, defgeneric, and defclass. * The class named standard-object is an instance of the class standard-class and is a superclass of every class that is an instance of standard-class except itself and structure-class. * Every method combination object is an instance of a subclass of class method-combination.  File: gcl.info, Node: Slots, Next: Generic Functions and Methods, Prev: Meta-Objects, Up: Objects 7.5 Slots ========= * Menu: * Introduction to Slots:: * Accessing Slots:: * Inheritance of Slots and Slot Options:: gcl-2.6.14/info/doc.texi0000755000175000017500000000600114360276512013366 0ustar cammcamm@node Doc, Type, User Interface, Top @chapter Doc @defun APROPOS (string &optional (package nil)) Package:LISP Prints those symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched. @end defun @defun INFO (string &optional (list-of-info-files *default-info-files*)) PACKAGE:SI Find all documentation about STRING in LIST-OF-INFO-FILES. The search is done for STRING as a substring of a node name, or for STRING in the indexed entries in the first index for each info file. Typically that should be a variable and function definition index, if the info file is about a programming language. If the windowing system is connected, then a choice box is offered and double clicking on an item brings up its documentation. Otherwise a list of choices is offered and the user may select some of these choices. list-of-info-files is of the form @example ("gcl-si.info" "gcl-tk.info" "gcl.info") @end example The above list is the default value of *default-info-files*, a variable in the SI package. To find these files in the file system, the search path *info-paths* is consulted as is the master info directory @file{dir}. see *Index *default-info-files*:: and *Index *info-paths*::. For example @example (info "defun") 0: DEFUN :(gcl-si.info)Special Forms and Functions. 1: (gcl.info)defun. Enter n, all, none, or multiple choices eg 1 3 : 1 Info from file /home/wfs/gcl-doc/gcl.info: defun [Macro] --------------------------------------------------------------------------- `Defun' function-name lambda-list [[@{declaration@}* | documentation]] ... @end example would list the node @code{(gcl.info)defun}. That is the node entitled @code{defun} from the info file gcl.info. That documentation is based on the ANSI common lisp standard. The choice @example DEFUN :(gcl-si.info)Special Forms and Functions. @end example refers to the documentation on DEFUN from the info file gcl-si.info in the node @i{Special Forms And Functions}. This is an index reference and only the part of the node which refers to @code{defun} will be printed. @example (info "factor" '("maxima.info")) @end example would search the maxima info files index and nodes for @code{factor}. @end defun @defvar *info-paths* Package SI: A list of strings such as @example '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" "/usr/local/gnu/info/" ) @end example saying where to look for the info files. It is used implicitly by @code{info}, see *Index info::. Looking for maxima.info would look for the file maxima.info in all the directories listed in *info-paths*. If nto found then it would look for @file{dir} in the *info-paths* directories, and if it were found it would look in the @file{dir} for a menu item such as @example * maxima: (/home/wfs/maxima-5.0/info/maxima.info). @end example @noindent If such an entry exists then the directory there would be used for the purpose of finding @code{maxima.info} @end defvar gcl-2.6.14/info/debug.texi0000755000175000017500000001241214360276512013712 0ustar cammcamm@c Copyright (c) 1994 William Schelter. @node Debugging, Miscellaneous, System Definitions, Top @chapter Debugging @menu * Source Level Debugging in Emacs:: * Low Level Debug Functions:: @end menu @node Source Level Debugging in Emacs, Low Level Debug Functions, Debugging, Debugging @section Source Level Debugging in Emacs In emacs load (load "dbl.el") from the gcl/doc directory. [ It also requires gcl.el from that directory. Your system administrator should do make in the doc directory, so that these files are copied to the standard location.] OVERVIEW: Lisp files loaded with si::nload will have source line information about them recorded. Break points may be set, and functions stepped. Source code will be automatically displayed in the other window, with a little arrow beside the current line. The backtrace (command :bt) will show line information and you will get automatic display of the source as you move up and down the stack. FUNCTIONS: break points which have been set. si::nload (file) load a lisp file collecting source line information. si::break-function (function &optional line absolute) set up a breakpoint for FUNCTION at LINE relative to start or ABSOLUTE EMACS COMMANDS: M-x dbl makes a dbl buffer, suitable for running an inferior gcl. It has special keybindings for stepping and viewing sources. You may start your favorite gcl program in the dbl shell buffer. Inferior Dbl Mode: Major mode for interacting with an inferior Dbl process. The following commands are available: C-c l dbl-find-line ESC d dbl-:down ESC u dbl-:up ESC c dbl-:r ESC n dbl-:next ESC i dbl-:step ESC s dbl-:step M-x dbl-display-frame displays in the other window the last line referred to in the dbl buffer. ESC i and ESC n in the dbl window, call dbl to step and next and then update the other window with the current file and position. If you are in a source file, you may select a point to break at, by doing C-x SPC. Commands: Many commands are inherited from shell mode. Additionally we have: M-x dbl-display-frame display frames file in other window ESC i advance one line in program ESC n advance one line in program (skip over calls). M-x send-dbl-command used for special printing of an arg at the current point. C-x SPACE sets break point at current line. ---------------------------- When visiting a lisp buffer (if gcl.el is loaded in your emacs) the command c-m-x evaluates the current defun into the process running in the other window. Line information will be kept. This line information allows you to set break points at a given line (by typing C-x \space on the line in the source file where you want the break to occur. Once stopped within a function you may single step with M-s. This moves one line at a time in the source code, displaying a little arrow beside your current position. M-c is like M-s, except that function invocations are skipped over, rather than entered into. M-c continues execution. Keywords typed at top level, in the debug loop have a special meaning: @itemize @asis{} @item :delete [n1] [n2] .. -- delete all break points or just n1,n2 @item :disable [n1] [n2] .. -- disable all break points or just n1,n2 @item :enable [n1] [n2] .. -- enable all break points or just n1,n2 @item :info [:bkpt] --print information about @item :break [fun] [line] -- break at the current location, or if fun is supplied in fun. Break at the beginning unless a line offset from the beginning of fun is supplied. @item :fr [n] go to frame n When in frame n, if the frame is interpreted, typing the name of locals, will print their values. If it is compiled you must use (si::loc j) to print `locj'. Autodisplay of the source will take place if it is interpreted and the line can be determined. @item :up [n] go up n frames from the current frame. @item :down [n] go down n frames @item :bt [n] back trace starting at the current frame and going to top level If n is specified show only n frames. @item :r If stopped in a function resume. If at top level in the dbl loop, exit and resume an outer loop. @item :q quit the computation back to top level dbl loop. @item :step step to the next line with line information @item :next step to the next line with line information skipping over function invocations. @end itemize Files: debug.lsp dbl.el gcl.el @node Low Level Debug Functions, , Source Level Debugging in Emacs, Debugging @section Low Level Debug Functions Use the following functions to directly access GCL stacks. @example (SI:VS i) Returns the i-th entity in VS. (SI:IHS-VS i) Returns the VS index of the i-th entity in IHS. (SI:IHS-FUN i) Returns the function of the i-th entity in IHS. (SI:FRS-VS i) Returns the VS index of the i-th entity in FRS. (SI:FRS-BDS i) Returns the BDS index of the i-th entity in FRS. (SI:FRS-IHS i) Returns the IHS index of the i-th entity in FRS. (SI:BDS-VAR i) Returns the symbol of the i-th entity in BDS. (SI:BDS-VAL i) Returns the value of the i-th entity in BDS. (SI:SUPER-GO i tag) Jumps to the specified tag established by the TAGBODY frame at FRS[i]. Both arguments are evaluated. If FRS[i] happens to be a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is performed. @end example gcl-2.6.14/info/gcl-si.pdf0000644000175000017500000100710514360276512013603 0ustar cammcamm%PDF-1.5 % 5 0 obj <> stream xE1 0wōИ%yPMJũ:H-rw&l!b~&c'8k'F~*DUg]XMVUnз|.c7&Hhm(ϼKfE' endstream endobj 14 0 obj <> stream xڵWms8~O7&HH\8vΦ7ש$e@ ޯ]Iؐu}OѮEϮ\cVZ[4\p4r#f%זJ!-HV5aʙs 0HG̶璷6{zI VCluȳ\)5\_NƳ'zFx1V@dW\= ETJJrdH f`y5J`K7JwS!\z?$`igDͪ!#UlkS 6uG=̊_$t>J! ߶]m6i-ߗU\&˴SMYgǘO$lͲ;URyB3U Qycs|CAR;(匛l~K8|<y0.=>#"`!PHiXe-F('7Q;U=y1xռotsJɪڰZKh\$mUh/꒨|֡LAgS8? endstream endobj 17 0 obj <> stream xڽXYSF~ϯSJf=MA6>y0%VDzsȧX(pjF===3_`}5ly~Vb[} S0ߊ76|?Y4 <+erPJ8kryij 3ts1igZs"rx2s4w&([q\׵mM#[xCRY$Z=w8"`lwd%>Fŵ>MJ\4mUPf7BN}_D|rfeMNVIǠ4;F=YʍjQN!VI}}vO+Q0ï-h3s7/>iLUhƳP55^#^*ˢnm9aU3 /GYLQ\DQ#UaQW]$kgwr7fKy1q׽q!~FC])|8Z3L7ZNC[q0cp*ۃ[2E1ٽ BH iIZ3,$mjy4Z(IO'1 Z=e8Y3'?ዴ53~<!~c8Ku Aasԍв(v;M[zonG\I6ܘCױ>6D ,~0n;*iڗ"e+ˊ̠7?D%oJb?V2lSJb?$gHnixC$1XWoxvՙ!RTUJ$Bӝ\v1kN;3Fې+G4zу }CLQ9&*"F2_"1]ʤY{Q"5fޔ F6QDhszS&A͊|q7nr\7d4]ge bJ(4l4mr6zp^g 6Q'0J 6xpP)6GEO-O=T XK\vcW \*j˹yo||Dp4{/zֺ{S%isG$TCq_0 3ݳ.t*e~&.E.Zt| -x[(g J01Od7K7gsde\?-=bWUTpIQIa@UiѭhR'mz,rp]ԐTF2M߿ex endstream endobj 20 0 obj <> stream xXs8O76,{(=r61 7QIlZ#š:sSIjۏlS YzZϨE<7bb,1t>]eZ#}91{ߌhh_(o,PA4Qc7"L|8Eu!53"č9`Gʀr=hx0r廴 c.e~l csW>2lrW|r׌p@F<b2^kqOq.fz_n+n8Y;cr][[ly7/$J tOɠK7㾦Gq2'dbL2ڠ硧Gl{6]V8rKuVRTB/ ![ \nvkpGNB[em70jV=kPTT@)d&O C }Z܈jJ:t|7#A@=SٻR\sD+f[oZb{ (5Y˛"ָM(2yq6t3%+Az[K ܣR$DaS:WX;#l d5 \%(n\n:CC8sN'sOH${L3xt2 y!,/rp7:rb'KPyroE`[#CSàEB75YB<}EvRKin ╩7kYE0S`ZjӞciE58^Sl2;I|1̦CM#7GZx0;pRmZ&4eU!Jp֫fV;W:+$\T]Kφv Mp*K,d &нtk> WM௟/u٫t0)Ώo8~׺hWy7bw6MG!(4M^%svKt0%B.\L>O[&§Tjs !=Ч<9!P(Ah詓 ~/`KeVj؋v?TQ_+]2xUTS;H~>I:|Jx "ۖwK>C 2Ҟ,nipqed=ngwQhL+HA^օ@TA͏Ճnb%I{"e۠0MվN5FaֲB~:L$!4Pڈ=:-_lnnઠyt2&vS ĸR̺N.!EMPP_bxYzlVEvBH4&4!7z5+W 4$NNi;aC]]ePly?.4/Sb<47`9l7J]s> stream xڵX[s8~_SAEHovB28v&i@l%ekC 8=8; B::76Qs6kco$jķ H}#^7cJjn,ƘJu#Oz>UgsfPJ!eb> bToO/j9vam>h)e377 Ʋw]浔ɪφmIJYur8 ]`C PB9y \3`Ld)Om$Հ.)[\_lov\FyHpU qr)oͪj,8h6ָS@ w%A( F<. 2m<+D)8D6Dz4t[bGB+Gdֵd-qq&Uonbz.h:+@,ۖPU!˪ˌ&Z*;Y}6`s{`"`pV״ߢzUܜpZCF(,$f-1cr:oᫍ_ vM\ 1.^F/:/գ'IOL=KҥOùU6_UE ԘRO9(77V5'0&?jOw8+zKp cTON.)'7+\"hS@gҚ8|}#5ɖڂڮ$ƗC0BER.kQcΆj-*lQgDm~/"XfGa~G@˛ahϵ[R4)<8Ūu_K%e&ڏG}94^4:i'uojd`s'@Ϡ[Wd/H#<Y侄%U5^,Vy)˚7ױ!+V^yV!]JmVH!~.jA9"UdRvbh9ꁶ%떠@Yj yt&f5üEeqk@PǮLY9͚'.NM"˖͕ZO;s?m endstream endobj 26 0 obj <> stream xڭX[o6~߯ a+('SjȎ0G$Y;VhPQ|*[[5bȷG"/VhhQF"Z{.Yi鸌1p\ι=;?:.!~@?j>2gDB2{?(#fQJ"!|e!( -yT]WwUe l,Gр5wD]!AfT(+Q_dgWF:7e^itT/Q b Y/SeD7~N߼>^% A\O}k`6QG$aܵOJ3,OKwdWZL*}AE'w<(OK8gzh*}LeZdIo :mQciLǥM :75>4C=L!KDX c!I(!ߍnLB>]n7(xjRxm/ Y+qo>4xJ[;z@5*:ĈyW%T2חؽۡ;^ I8,qcȗ.(Ӷ櫢JZ[z#6V]|S>*a;E$]}omB͛V[&r$*]T'2[fyґU5IR#STy2o2<)d|{ݜdݜlC%-arPpGe_G7ɣ@P歝7Z#v鲿APFIwqE[=>>^Ԟ덚Rb L9P|_uWM px/ך!ﶼ0x؅[C d0 dat0D9cVIY&JojAM\Qo(&=ڀVE7٪?g4-A8Qz=dUoj2c#[-⩊1HW齙+CO;j$ac';1 ?.=- >kJ"5&^)z鲅޾LPvn5;CedLH Zix'+4UtN91< Dם.&dYfjkw}^%A]mXbohKf(zn',PTp9=A=0xƓEuz+)r*Mhn-=hq.9?~A endstream endobj 29 0 obj <> stream xڵXmSF_OtzL?c0M|8䐴ۓ3:=/l|43Bc6Rők0ǎ"yv##]3wË!Źi9<3ӬɥZ\10NIJ*߫G ,/Qa;S,O# YFvdX` {:rCS,Gnd~)TmvaDг/=av,̪lD#/G?7XYL$Fo|Bj8%70O'ha߳`֦*p͵ԓֈ { 4s,iB˲ZfMݝʮթ#+~ºrɔ@W*lCmFms3e5!^l8|0ȻU,U6#4^?2s!j=HrF`U\u(xM endstream endobj 32 0 obj <> stream xڽr6_Ԛ AO!mC J4{;.EZ1m1DB{Q.] t)G MQgޔyuLIRma IW8!*[i~tgG {\uoKa9.Q_]->s 1JU)WCb\J $A \go#{Yrplx:%P0/6~xԂ1EP,˗hH,W,k{a+4ZզJۢ\7v>aKV5R>f9 MMr9)NT 2trih|K /t½" @jVR*Bbl]e 4^"Ƙf^TZ I^EiQG"TBhv7bQ ¯`uLSg6H84hj:M/'}5S S1zڐSj>p7dhK}Vcİi,} v̤#3Efj׻qU*Ͷ2cCN[Tt<=_]R1\q cjU)uлshLcfmk jcVI4prt58u6iܬM׫r:OI|>LFW=c:K:3cE :'͍EY۝Xlb/؉AXk.bj*vV*#tզ ^,S#ŴHp*>tdfU(5VňLz/=ѷUjk { ylGzSxsEJꨇh -O F&zN,qQ ya6h?5"#n.iZe˱;U8ymh|o)Zcdeu,eGb:v'޺ y`Rd$Gdُ==-=Ľp=њ(jl p8TxS52|yϞFÖ8WJܶNyDI%~5CzxdtTmގʲT7҇ûGOp벯bY 6o3/~ឨ;OZtOܡjA8HQm8QԼJٍ.El(eZeiDP=~ClhOtj4'6U}ǯN{Xğ2]_:]fyZ~Fޥe}N`^qzкBE endstream endobj 35 0 obj <> stream xXKsHc+dYN%K^Kr#$Q@ (LdOqJCO}_725 8Gg 㙁SOoi#/^6-Rjj綏|6 Q49jnJVZQc./iqr>.1G<OLe}2Dyxs!,e@>b c]ixiߌbOh| \[zHJM %3^ 3S4"Y% o`vnV`pKj}bj2Asf 3pl^b,Rqq%-Gbl\'73tHg@LfBY0v2Y6cnMpᵭ@:3dU/aME4W7!w`HJRD@Y"knKǷA<2A^[vRU!+YM*]/ <ΨoV lpiE4My2x^έe-W` kb7Z[(8Gg(8i{; Pax£Ϗ4\aXcbN%.e4YV3?u3UEKeq:\8T7V'E ,LYK`` T4Ԕ-i4m|L~Gk/;m;^,u2ǽp[򵈈ƕKvu8vA%jTt= }M *}+.*b%XQ6W2T[)ľg%*==A.џ vaE'~fXB9D]ӂU^սv6:iSn 9},یgΜsz<;)#2)ĩ9~qһj س3E{A3B#PI(^`G"YIIe$PQmqDjn 'u4k *j#&,aESa[a=@^&ͤEjyR FПMo\J<0Tn_ɵN~ )J2m}xCд=] /Y(.αzSO p0}3"+?' {^7s:=A|hx/H荍( endstream endobj 38 0 obj <> stream xXYsH~_S„9'YmdHUql$p9ɿߞ bkek.s=6p>_XxuF 800E! 8`M)5kf"ɲ//+c`C.@1Y57Ί\u(q2/RVQ15S/s"E'DB-(u ®\x%ܒ,,-3%=ϯvV"[75gK;(rB :y;zSْכ2עZVj2x.HC]|6q%:8"D-Yp M$&#0H.b^9(mԪ4f\Fؾx~ds0l 凡6 `qA5X֨-`; 8@8vȯﴧW2[$+P8*n4 u rDMFk{'6, ˫`'C?&#h4j<.a/W@1ؖ7jt<_̟hXzWiŶԩM?ѯ1,lȥ/J^})E uQrG|]\$hB2~%OjaBtܬ^uxI~;uVxpnIbQ N#Eq/*#QNd#4AWo~uv#IDHC:E|iKd{P-Ty}_N RxJ ed倧Xk ^YƂ-$bm &^K~3 *>25ɳrt4.A ؆֠L:)Խy9:3/HXgyR юfbh:5R w:^"=l o*GOR\0ɶ7|D> stream xڭW[sF~)ao\Ҧ3+ȵh( V ;H3Bp|Y !udoE d@N}b߈nߚбE8 =!ϰI|H HXV l@Jx}"z1 Ц)ذ[ӭܮGAw^Tiʹa 0 :B]ZzA/)xZ*3zt%<ʼn|E]3ޥV͕\pS.);VE>&cDB1F)߸k((`8/*`@U ܳz5Xi ^T)*Ja4_̯QGIx<$(+^c"{]xA0:>*^1aba'cB2A=-֪^ HgAt}P0.{w_V=c!aH_HLUiqjuլKJ:+vZY۴U= +MNJ|}y`?!X[燸b8SA-ܖD[3;SFh . AM> <\ȱI!O"?|Z]e "W(ŭƟq i d \ֳȞ_muxO7,rx5.ֹE"=3'fiJo\wTu }#} hCs:CcH^Dqgd ]j<OW}kLDK{5џc) #2YK:yad mdŻ]mH]X7*?.#/lQj1-d]9p'Md,ZUa&r0A &U" _|)Z4^x LO9EL&"c7AfQY''HD}qQ2ߚվ O EC" S'IGL7Y&N?eO204{|̗EYwfLyk>1+[u5Ofhrx:N@Rz#O *QiMYӱOb9 endstream endobj 44 0 obj <> stream xڭXr6}W)C&BxI+;jeɑئ3QhHBRiӎp`XgѠ1ˍ243:$pj I |#ykE2-sn-0'<ڲ8/wំ`(NjOE5Ke*ܠR2}3j௡=L^p* 2B0ܦwA`ϲ $Zk[ٴ`tYQ#'yd:YXCN0=x@3 q ЦbZဩKHLæB./y\ŏeUn[,bRlFߌ¡"U'x93s6`Hv2Hg8%w*ObhgV'hSm6"'0$`]3 8S`q 6.ۼr/W|t9C, ੜsH0A20*mU%.-y_\[\GEl*O "f\uR2Q)J㥀zla}9ߗ/3ȣ)*{=<_MЛLj2FYu4 Rҧ lD3y.-0(SykU҇ޑ>x:Dhġ@,!'e{< ,Xsfe["$v$_:@ժ$^ g kaGl:ՙ.M:=̈́3]wŻ]cʯ%FXfEO)Omϲ.)L@gD:/О /蟡=N.Zh|Ua}uJ묈 wI{_+rR]V1ՓI dYsB  C=  6HL$> stream xڽXs8~G9TuIlrV]۸[-$3Ч]iV,ҦKkmZ$4k!xV>~9%^a|9 q=N˅MN5ħ=7|G߬eWWF) \זLG\#Ee75W?-`n$#6svLyġMCEt(Lu+ȰL o ӓ}Пr-@X|U(%kyazF4n 2QO,_Ȱ?PBL\ʹ-{,[%*ʅM\&9&Wh 4Q'n _EUIj*B:[>zg.7Ɵ1 I|`Qr!"Xȩ܃|c998Jow=^ͭ0/18aVUV"ώRbKswl-C=:_W .$*-Mj)T@5yQO7^N8Y ׫4"RX7*Jp{t7])X[M3;߮}G> stream xWmoH~O'ʖ}zIXTImC 7bǭO:Ŋ<<3X_-ly-dz+4ޞ {(Bl%w,LQ+Y|cUK);eٓ!qVΧF҅aG`e! 0SSϝbeI=(#4?|{YeiՍϩS}Zged_郙,7Fa2[T0 +ݎ2ag=pǗ/eHKX9F,ǣxڇ`j̶k+fP(U uC$ظ4pC 4s޸ o$ ,`CPԔB2;oZWG}4}w!A$# G/jq۪2}/>D!v04@G1_Ȱ.2EBMϛhAXjZdzn 414J.{.D4BNȾ0,GvQٕ[H4;fGoe$&r oOx7򃲨T_aY|u:$qhObA.ꈳte$5#'`vch_Mz6xBZ:^W_$HmD[yG" "\U)= )ʢ4==z vIp9QW\ǵKCz%yN_}48C<B>!Bn5n r*/oy]VJrOO({u[mt^z{jтQiftuWvdXz,_U5 %uhԳ Bq:B]?oֆ T'Wt2,f9ZJëy|u"TY2x /}2 wU¥aV;bW>BY'QoƫREfGn\s>Bs~QtʷM4~3 yL͢hM#χ͎ɝeʵw׷&և2sO endstream endobj 53 0 obj <> stream xڭU[O0~߯v˦M*NIИ$,q86aѸM˹}9;>(E1fh+CCh@ (;C4A4LPVcz'SJ4cs_y>gJ/d+caJJC/xYδʓVks$H>O PHd;OfG$~9NM; ٽc1^^x,{Y;cʼn8[]/$ )ZCR+TM zΪT8]% l8s~wtxƄO^eiE^eAA@&^Sk/c^v&Vlxv=6:O=erq5UeaSx;]y"birUc7A{6 F7%,ԉBQ#Ҳ`%L akJqN,ԥ-urs`p}ꃕN!vFת.$Ugbۣϣ/I@=>@)Q&qJ@u+vA/_ZAuf:/ԍe 5WecztTe-ٺq`ӨyL?ҙ t_Ctr_*uԻ;+"H[]sCE35gd=nE vOd=+;LJ9zҴ_8n1mXg5:fgU~{OJSLk01,KYCT`^Hb ΪbqkjtN\\6rYTmzn`ڈ%и [֕ՙ|-2Z}Zyӱs]6) -疮v(怛!&8̼CcIo0\U endstream endobj 56 0 obj <> stream xڭXms6 _޵ĉMM[긶]V"3V[r$I-GmƗ\L xςZt{~;=n y/9vpm:A/2 ஃ#4Qo0v-TV}]#4eҷ-A)ϤQm#\\ڴ[~ϴmfi?uY֓,t]<ճ,eqxO>:f3CxK9L8B[,eUk#wH9jBɴ>B4,}L\}IzFr-?c5SY6Eȫ\(&}Lj!͏@MQXWe$F1B#0 ?Û0߂ҹFg꤬&f L]ټ3œ _7z#AÕ +|Xwىe::Yi x aqER֗0 I FO􈽲$Y.֕N8qj<n8zDO޷f-N7r ϥtm<07}Fwh>=Up|>|tf\K=M|ECg3جMEҫn׋Wv@Lf L7 enm8+|mx͡|@Rg5Н- b)SHsr׹!f~je,9ʅ\jIض h}YKȊT:e1EVoP3 X:/t)v}Z>Zg/d20']Ã?Ac-) 0$xAuqK3dIݴy \nqTh0KMwEƆ4ͷ""s~[=&CZ ^i+ ^r z}^ G#l MI $ud.\y,-D?̓8gѿ.8 ߲u]ٸ÷ww9zo6mĞ 2bbPU|Rɂ((/`ijt&)VYzfBJFE9oiWt\⺠Պ`ivй4䯚4-2rDTŷVE){/ E2%[K^%>X#~/GX:qftj4s$w[4! }X=&!>Laq8ms@t0Xoba, `W0E՚ܛڡb%=b2&7W~x 3CuGnzs,K-ڼ\'ypƎ;hX+n(Y,hp6H)R)Jv -RҠEb7rMG1O]`{@X&hސt9|Yi4z UD  ,_*L߭AV)'rpĈЈyPԮn{ (tubDOh@Pxa> stream xXQo8~_Te@ '-9ml]k .6ɿ?ǰ6Iҝ f<{fc|1?bp*ıC'$F0H`fn`&G7 \.Y13P9v@\`0suVfbGA84۵J fAhX-ټHצ. Ykigu($LR5s s}> _2Y O\\@nli4;=ݱ5?h.c2>j6Xҳ݃R,x16XOeBx3( p}`FQ Ãd2L=dzL=Y<O;y0琣,_4_SRы~VAz3$F}U'e;2A4ȗl!P:$vWۉ̙7zC|S|$FCP 9*YZ,RxuӐ+P_$yw=݃&j9rޔy."_ƥi^K88s{csO%d{Z-s&tue,ѻh:vF)|}+,Ln⑞D\=F<=@ I\87k֣>+̢UMd MYJrg`Z'2Q4D Բ!f|@~ 2hڞ>p5x8 X {bGiRNa")C+X\ssy)A*׋p#O-STseb)0lysNyYVa0]`Th8hKA /usB]ŀ-&"]jKl,iju[n1ӎcRwa7*}]t/^e^RuDO endstream endobj 62 0 obj <> stream xYmOH~R֑oRN&YNmS];Np!*ݝN yv=;2<;X_,jGkM֛z,ȍ[4('dޝZsnGaKOdN~Sz>HVI!aWK0Jp^WMFPF-GD$B7}O?){ܢDpaفE\!d8wN%vKvةmuA`+,-Bﵪ,"I v}"8,zJNdyvz!_x4=BW',s8x@O?&RCs嫬iIvkyvw;'ΛoJ((yY,VV d>%J{T#~zI q0 .`۽ZU[Л~wDH7(~&Lsm&srd=y6d(fbW E]!TxDکs_ԳVF'eޞ;EU;ˁ+ξu;.rBe06Tɳl*F~Ls51:AC^@"txQ\((|@Sey9i6:7-1~  ȹ\}VZ9/j3eZguOqXJx?Ow#]h]ul!w[(1[RW ˹ .fmt/u\at'\.5P XUkWj5l alk֛jmn&j'8 s5 +*kwBH8WYe1xJˣA1X/QÛq2L>tp'+s[e@6D|Գv<)6ymϓ\d= ˓>$^ɓahMMD94KtaYS dWno{z)\ AP2RqB)t  5 uYϪٰ!Z?(Y}1]CpYi6IkywQuҘ~Zbp\:N= ]Bh%p&ֱB)ArBj#`{.ʈE.p (I f1 ii:ޝo;X'+=g飝bT} " zLx{.rttN֐]:mxg',h 9^HŽ w8ߤHȼRB`CC]F࡮9 %o\,(_ QܨpҼRp4L;M|A~<dZrOW[HʼnćA#|L~iuQ1Z!6ޔֲMA;XM Q wrnLJo̵;9nfݜ`DmNcI[ҀcKmS/`nY؍A& fF"8 )oH웼Ӈ X+/`S-( ЊV/%%9 PuLVlZ703@83κ'@)87 endstream endobj 65 0 obj <> stream xX]o6}߯0`?nFi\$Nj+ۊ\dɕ&)Yr4N> CX{ϽEÚ Xs|L-ZhhDa-Ұan\$fh{T-`lޖhë[X6D.c~+t˹8+>xXL)a6A\̳,\Vdqi(],Dd [Jԁ(A1Wmp9g4<@j9}Nٰ]7x`eq;.ڿdzyFH*8x,7,0 6%ˊ' \{k҅XOD\d7atUHX :E!V~Iƭr.*S?,\Eɕ"P!ϔ5,"|5@֯leiN>g|ͯ@B#xjCr"k$lzħDVe[ù?zN5'gǾ^> stream xXn8}߯P`+*^t+Ї4Ql4"LBeɕ&ٯ!/8.9!g i}B ͬw#!^L"Etފz0lfpe&^]jnEFo :┸ҮXu:,t %c7"\ }9D^YWW%YSnEr=(PKXh9䵭 K9]Ny!r"kcqgxeњ[CA@WH hdފ7's$/DN6+>r@5W$dU3w ,Eza'!lIFAwHrUH16VՃUuq7ZVs{^J^e҈F\ +sm5]zuYLq\z^Y^Bbm+qy+iھfDIȱkUʄoߊT(Ұ[U7b…bKlz@WA}v|34I$l$'(#_ќaފ^>A72'u5s!2/1y Ѵ/n@v;e`.\M-{ uH])@kѬZ,ٳ lj4yc8IbtI{_GƋXGuJ#8`#E3s };?4U礪gb#7*a-f؃+'lKGQr1TȌC%O~\ }~?xgUl Rɪ;|uB8į %x{88>{ unhQW횩+Z̜ +)̒b';pBF &*sOu&]\56/ endstream endobj 71 0 obj <> stream xڭo۶WE^dXi>nUST FR7(F}~ȒC<<`Ui fLKV9楬jI*caY'x]S{T}O){9w86ipl{po|O+Jb:[qQ|'HŪ(ӆP82w޻C bfDaH@[!"rEbQՍl#K[:GpmxM.!`Ntv7ʤCT#(ؿ=؀˵T2RK#tv>Er%1-_nw&?&]ˢܟN3OOi#gu u !?ý}c"P뱍{;,BiiuG.ܗag5R-*ʝSp.߸/KEV]bf^2dnwH˝쌩 ծJu@*UdC6BpgD&|'v{Tal&E)"X5NZR T z>i2O/gsI˻tS*Lgdzzabbi y2K`@0rv"8Xp=/ʒV^+H]KyEFdUn`K9p%m @]PMD YVVFAeF|pPpB <$pui6h [faʅ VN m'J2 8e y}G~QB8>ǯ_^ .Cf԰n{b|5Y67N,?/NNeoMjŀDU4Yd !-ZmFToN˶&M`EGOX(eC="8Ynoy߷B( -,6l(m~zCi# 0'!9ru`q ]֛2yj etǍJߥ1I[)޴GE0W} Sp[R}4 qpeN=,gqc_nui ݂e10 3gh _$Q"KDTC *IBml.l雰6=>*g+ٓ.eFD4'IYUqՀ=%!­p>%[Ѻ~ xt njqPy50oS604љ͚b'ܢ3@3;)P$yT\ T~=?^%s*Ү2dS9 '{BM/hVK{4kx:A|Ϯ@.D>!L͋Kea> ;4PGeֹ"Au ںQ-aZzr>=L yor Cwl5ERLP*qiجZ-d2DZ %LoPYԏd8d׉1c:;Rӓh\ɯRm*%&w5o!%(z> stream xڭXms8~3̀3%oCnB[MCbہ߮Vv}!j%] f8?ǘxs ؑ1#,4kG"4/"YWXBS}#,,$H<0j| b!Яk!8\Gƙ"Zn`3 KDvȄr:]sͪ4Ͼ*7yG-7vF_:;Ѿh(j\k+l.nJ]ZЋۡ7ԋ2yFKy,Y+5KW^eQW)Y﷔m }5-eS/^72CJV[`$Dnki;QG ,^o&x4P+`mu"M$IZf_, rekӌ~Ïó(׺+*-4^9ƶ<pf!E#]c|t'eY}D"+Y C6rX.ifj$>LG>Us׻=|e+ l ʌjE}"Ll]8QwgV0` /G,}ʍT\?Z5̰.>d0vp9 Lh[ByQvs0ťKga j'o3JL }.O%x;'`VTv"grm7Ԁ⎎:E詑&+%R.mӰc4ŗ:j3[AФ\i0~~9?͡6$ަYx|oȸdU^V.]˴Nλ }cm~<">^.?HvN+;?,}K<@n _9n.KjhI&&.y\/&Iw6g?EUFGI/agGЯ ]̾x%/#]![buv羝.rMm 2fa{/ƨ. 8Jb|]Ɛtp\GS9>fj I݊%aG>FHa a)hᾊ3 .1P.["ǒ9.2eGA%Pץ ;^ L4XDOgV&ojץ' 0ODIMҫcԘ~ N'}+(q`DO\['Rr4~`&^AgtUr {$ endstream endobj 77 0 obj <> stream xڭXmo8 ~*or.qPjk,;('Ne")!7C#2qنxdEHn gӶ_ '܏،r1K؁܈UB B\Y%c#ϳsB0ܲo|Nw!EdżVۮ0SfMYt`9bw{g0)3ԛf;4,w;Mn{,-yMiA DjJy9|hZqc|&[@y\m ̘ϒQrO z$wjGK--eIj=WxU`:sS &4h jx WH\8%x%QenR/i\sY6w$ўr%pliy? .%C (0/ ckIj%޶l`oÝ0͂0mSI7Oo $drУ9ݞk5=gxr>O7i'Lns(ߎcn%iPyIKk1'(~N a8cF14$I%|ngXZU)ev(lu<] $PxAh6کNxԽёu$TZ,('aO.pyφ5*x[ܶZ^VmYڮk^6y/؊08ǩRA19YJS)21*`y%gfeQuR6vFKg ;)Z Os:aYd1:ǂ74 s{U(Lp5"Epy`-Wf5AK5=8e= WD]W<pQ[8ޥ(ں㲀*[nTױ~wRK(JoE뚧m;zYuknIX~h\E:hߏH K+vޒuSaaS y!{Z@Yy!t 4!hC BQVU`pʎ-qj'L" WZ0)`ي2U{K*~Gy<R?RT]ʢudžz&suz(gpv.˟&E%pn +ygPܲ| )YdO2" Jp,+ÚoWŜ>{0",υ?a;(QⲺ))ugtoœ"qj&V+FeU8--n"zH1f:#-ɑ/PO)úfրMU\I1 xNLX 7S; +Tv8k?tv"{c/NOy endstream endobj 80 0 obj <> stream xX_sD Sxpfƻ^{ !$.C!<ӚK\=j؉L3Jڕ~v7l/g˭md|s) n[r#Z<0c20o1~b1ūR.ɖIdiيƇEo~RqH, 1굕2("s| n0ZjAlYyb18Bh7s07,jʷ]F\3"]<` ln[{izء -k s otim HݦbMoP_ƂvUtru1<ҢQu-iJMjDGTj$b\6󂾻{edžU:R$ ruR84b˿@YGeR'> :|NE>Щ|˒:,ЊmJ6 sd#siqkGfmbYۥ*h,~zd6;[Ú{IƓ`)YR튬$PQn 2 @ ]ञOh=Wif4?ϣM_X ؏@V:V*>j1dZgAtj_9㆚k +joFOSw_NGz5w*,Uc0sm骣îx')S+ҁmFIO"Jrn%b!C0!NYHVvk^ѪhF/P;6mCZs ,h`eccgh/C{0߱p#D}1&+8!^[qٕ,')WFqTbͲ/P[Y㟜/*ٞPmebuD0f#AS&-`ٱCC,;e?ME]L5+şwIA!&o9sƣqca GN+eǭd:&+6L]aV}ҩ05ngp6mx(h+!_>]v@'G*v"DE_5^fq|fpޣpZHx :.h::i2jzksL/jg}+r- c?ae[5m\u/x#[xRɚPVOu䦵ĸ&³12@W R?Km&YWۼQvB(A3yAúԞQOb?}'kn endstream endobj 83 0 obj <> stream xڵXmo6_!`@'+z]IǵnA$Be)ٯߑGْy@xw=B_ jG m,V~b:dIhH  ddsCJЇ͒8)GL&j|rBPG1}:\&+ϊ!7(%2( bTmGqdlj1:HgTsz26hl<55ە氭Co9iȒG墸h.Fa:͐N#/+&KsKb% i~ֱўul[αYkQ,s\7!"CgHON.Ih6y\uNsg%4qI{c+GG$!ꛉG<] N\LZ#(}I5RBˆ3=e28!$tDIiU GcC07X{Q^I|HgԬD 7kT"ˇ3 ]; 6>UTe?y#ٞ:ryy-Xjr<9[IX()-+=7fPR[ E~n08tP#R^fړSB\#+ )xw'\Ec/ւvU#$ٗfxj: nVҔ0lհG\5r%.sY/P4kKd}fboD9.q=n=yӒRP$NWI}+ l +p꫺UR-Ew}F`wgkqe)*גl=Ή}Eݤh].gu'vb!5d%, }ϥ6^|_ZWA$t{PGʵLR脵eχDBU%dFRcSƒֆއ ت Vxv+ 6wDTzZi\ͣ,]p],1(:m'Y&&oyg-x O|h@ijhn <<ʕ%0ظMԄQi6RJ^ _i=mϿdK(;:!Cw , :Uv N;܅G4"2w& -ia~0يlW8χytlߧwBR&ol?$œ9m U& @ B׭MJ(xv؜~8 (lg,Ouȷѫ3˝l̉1 oK ǵFZvQ@Yo%Qb_阵 endstream endobj 86 0 obj <> stream xڵXms8~ᙠ"!ڻNJ9/M;M?,L1ߟ'J:I&eWg_1ذ6|m#]Fb#80ByL 8&y3(}۰"e S3)f?d@| 5Oz , 뜿%۠#זʈ+#Laʭǃ17EdeE>v QDr~l@'Éb :6r=LQDV7UV,Y1c:A/xvky"cXؕhI: uzf`oƣ| _NX,,FgVly2T!GakOFg.¾ay$:~uH@竊ՍN W*[7.A,L *,g+V) ʹd(SWƔ`lӣ"tǣ*hJ!oyU\ˆEH&l\\6WfΊ8=Nr5Ї.ӴЧ.\FgG<%yڠѩ|xx8$O =`]Y& y1r]eLY1kd!(O 8vHTm? uH"H{)eg]EYXg1lds f 5UuIeuc[,A1&e.XnҲ-I6\s8ѹ]:k\`hΛ^kq$)h3z7֎ ZdvyvBo"YY5/b˻d5\AfYA&BeP]q@MܽMvNTOQ3ɝz *Z@I40'J.Vih"82(T:~XR$^Al/(<2JnJ@ $:=NO^ v7V#zvmpdvضyGnyW.e9"P\ǹO/"y㜱za{Nik&jKG/瓋[? XEξtgG͏qJnڔ[̧YwILJ3(Mr;2 4Cq D9[sCIr5c/OueO8 ɢMZ{ܳ94.*$pT00,jx5+I|B{ةdbyUHټD2xr~ibR/ endstream endobj 89 0 obj <> stream xXmoH~Kǖ}Rr&rM?{bHͿٝ˻efvy[_-jZ>?ך?c!KB7Vh`QNBX͆{ C8s;NLO|[I@t8uZ䟵ԛCnQJBcj'oץZeo:;sxoFEFIts=F6r^۸ L,>',NddHAD=-y& /oh'hv] 0Zr*uWJAQ'2u1p,EħJjZa7*pgyD\  hrQ0_zFD-׵h >SޢƯ_T\MeNU𛽗erd01L3ȝUf_W*Y Y 湝:{>lWӅJoivی d#<p ]i?p~wRQDbi/fǓh5ʉQX1/ziI_51blnZ]U]> 8#x<g{ 2[ nf$4СDW׬@a]:{ }}]AP`3H<^h'ؤAϖE _ 8K*[_b}nwHVI@5`̘RIBYt0}SԆ.}!OG?tȍ5 Ѧ:3anyx"`%V Uoj [菇Ԩ%ys?URʨ#HyR.wRjx M{ D>> Q"1 4E3jݶa͵jb/Zg@+'FAʄ4{bXc0Sc  !mc0SYsڲ{h- JAyo>3ƁG#-0NJ/ #!@! Ú'DYg8ռ}^R!Z7ij$7 ahv2V8$+C>Fp^.) `s-rN z{iz K}J/#*J4F>l.atz}=ԯnt,˛[Rufy@M|6Sy/|dzi?.!ܰ[(a}yZI|xdk{BYwEߒ}h)@ =|Zag; ,xӺ5aְ |٤4Kq|d_[e&P퍝K42U-טuV\#d)]d/@s;f]/px:sda@O\Z nn`=ae;Gc_vbH=aVY߹am~sc] pӳtfIPjSMօ/lZCHkCe30'4j[Å endstream endobj 92 0 obj <> stream xXYo6~P]ݧ$l\8Gc-Fcueɫcr*&KGp7C9_Gk`zO3_:'DO)'ˢѧ҈0 F'SaT Bd%FU]{vx8 ͺGm6YY|C)IU??{VUa`Vҵ*5AVk5dE$Nhh'^;(Xtb(]y~NffIĨ~ȾjeU`s+v Bxh HSiUwSfTYq7i6P.JGͪ20Wo.T7[l '[V75Gxxr:⚲Y&JZﴭtL N hVRz~cJmVZ.@M`8Nw/ƥgzp:8A2AB0M.D-JO1Ֆ8`dߍO ZU(Ѣ~ DgE~;֟nXWˡ$҄scpjO0xWb4lX6I&iKW=zt>.Z\sxFc׏TBylE,FNoIhʶAXI#/ a% 5qp6?gc|Gm%9#F}`I0>zH4{1߬&KQ+_tN(~+(T/-S23SixC:aoVf&<$'3C7EVeB}2$DRxO$^YXC[c_+Tm{܊u&wr~׬48WܐFRָe%K3X<EH<3`<_xPYLW~{s\e͝떅 Y*U{vnwfzGgso:9ypQ<]ݶ&Է4okۀ- #/ȷnh.Z`vH `+|:$>t:c(=$^L۾OOR[19Tֶ>r= a+B"zBpwDl,5٬U[D>sH)-̉D_tޙ`ݙzݔ92zU8t$ wb}8Y҅-FԞZT~wwi/RGIk3N ӱv_vge8}px6DS g⥭\B@}mqxai!^gsL"<CO>ZPOd3AV$+@bҗ6$@Z੔YY-Lid?Ehs&eCŻw{I˖谰?;2̚~۱hTZ-'l|r0H>'Se}ad2׉5 ~JK l-Ec((}n0[VZdАC|gQxF|=>Z<5BZ+[ <vIOmb`I|ܸ?;/hy endstream endobj 95 0 obj <> stream xX]o6}߯0(ixȒ,0 Mْ+߾YRYې+s%}x+M<( [a(᱗4OXBH"ϪIB-y0AQ OPL1SLMN_f+.3۔ '4 j.r`vS檨xdH^H>0/iJ;h(gf `w$4 LOfgo'6O ׵l6 PEzYcnfJoRNC\<_F.o]mV {ZKDi-nz,aH JI|1X!՜ X iqz28:ΚcL¾C(o-rEVј&d p3MBg7m3Rm/uvA?:9-feY#m۝d+k{6;}o8v,lBAs};*3|Ƽ1X;UUˠٌa !A6<H n44聼҉ I*g#醲}רގUe^ˬ)֢n[Cx8*z(i/}ofX`i'eB΍V:ݱn(_΋ jSľGqS|pXROYM&{%1Mv+T[́αQOH_ŀ ?G #yx=tG.22'{H?('Vݱ!ª;b CNݱEiÛDEiz9>s?ڍo//NfG4;L\_,$awYjsC1l K {41B.#(dh"Zg P|X؇QQ[?Ɯ > stream xXmo6_O"j^u`X,ɕݯdI: l@yw$;>g닅,W!ߵ[uh<ra "0 *TIBM^9R*(å9բA* A@|0 GTM}:w8Y\yY<'B0<,} .Ň>^ &FH0N6b^2n`0-Č,\$eg=X͋ԦK` B܃D #OMMH&y5_N+$,EV0qd.3r055ڹ>V؎KݚXב?Hp}1\(wi@xWR :R9*ݾ aP6%F[ZMjs)v^ )sj2Mr<ώI&E*O"^&*1%习gaP#ugeerR18qz!`|NÕ9J|RZh|]G<1T8fm"W۸v\wAwrt7n lڗC#z8mkCdMms,@N,%bԞ|Hv`}}SEȴR2zahQ#*b#a7|Dq"50ZǨzZѩz~(wBH&ӷ7e }?5SbsBR{>Y*WqORI5HZ( ]M.G 5hWg>ycNXg=> jϙ,}F)D>).4cͱ1Å~2:羝f{J|{ʅgzְ9as%y3hC\4ѫ3N] B6Ě'CDAh'%yUouE֢si 쨗k{kLJMph=e$.D 0GWZ.VMJR0|FUUm%?}׎j(IY[mw jFQ$N]Ds%WKpf^<TvTCژ> stream xX]o6}߯0嗾Vl,wA# J$GpN|dlt~:fE}>;`<Ma~XbJF icU<-,?jU>6m@EL5"W8" HhHl]L,&*p S0:}o?XIp. ఉ-2We15=sfsrXj9dt9cW$LUpvQq*;ZY5k0YܤM;w#Kh.%B6Tp:ob}NΉtZ׈Sob%dvٷ!?s|%|5u:w).e9?t ^s[>v$ KL8K>%h}$="ql؃vmMY?I( ix͇Nȥisg rUY1"uOc܈+tZ@jI]_«2}ETs`T~[pߕT6M;]w9v Ⰻͷn)WwU4D_3hTÙ?LQC1=o`ylR؎JojCV.y5s֮SWXV5[R?nGn:)Y”;<}[4Q "-COf&ƑST OmIx?$f endstream endobj 104 0 obj <> stream xWmoH~R֖=O{~p`Sb诿z!ٙ3ƭ > ;x:!6k SHL[PU2h3B`&Ue1yЎuY߰)CQ? beY(t]"=SO$ƓƗVgm\iOM-wFbŖM)"^[M2L1uFY~.zvQ-jm{6& SXZz"Bh5yc\۸W*"L{#a* K_-3/0T=}*UǼYUE_p%*^\ML:Y1Wo)lX{&g1,".搤n2=s$ 6!I&˾-4W|ϲF u) ݭ^l >DSJ_(vPSjY\R(nQ\Z& EY1Ө Iy3e$O/H] y[R8"oli%Z2b{MC|qN}ACT[ T]/A)AeFEasnꗰDBQL/], 6[8^0x2y?"O6VІ$>V `Z5iăn 4x~Nv ݤ>BԧL% Q,Nn?1bCQjۿY endstream endobj 107 0 obj <> stream xXmoF_5l7XO3N\9aUnF96/u;.Ъ53̮[<Ϛ_ZB/V0E!VlS|I~hzK)Z(  {vWYxݣ(䜨\*`BOgɑd3Q ;3۸~@#p߇B~ 8mabIC;;DΫ끧6Dzui0ҏlXeV]BSm1jI}viz8G!τ_sqr4C1ScYWYYgBFN!;"ʅ x[C>kB] f6r8ZewEe_,OT=OfKɹ|c8Scj]B/~@)hG?$FJ* *nt%Jî)apdwwXC?n~:=sΜ`=ΥZuVq^,* iE(jE/ FiZeV[h`2$d}0lv+u2P@4a6$nA 🝾Y^ M d",xo8oU`mzHi6V"lz$~k)&ʘkHi˓ڇXPVr?ՆHnSh= %J 􂇯k S6umj& H/md79d=Yak,818y< 7},AYm^:>4J(<2Jm^zbX~ W> endstream endobj 110 0 obj <> stream x[8SXB!&>&# {Z"d&IaqL锂vR,O"ȅ E5zgnHPD$@(]FFV3[y7)j3v:DŽޜ6ż]k!Bp(U:,i}]Cil, #|k3cC<Ȯ#qHE›a"Z V6i`}ge9 [j,ԀFVS7ŏ8jq R?(h:k ̘Ͻ{5q C-8[mM\T3V6Kl ; _򭀣ݖ I[(!Ck0Qn͟p>q$}1: B/qE7aYsN_V`Sl6t?JݨdYRý'eYÍKe]X꾉1}U'+.% .p@y]j5 y\^ef!߰7gD݂(p\9Ղm u,/벍> stream xݘ[OH+FԵzҷ41YE&MܖHLLUό|:A >\w zs@qq%g0%_,߈{dƘ\VGq@x%.2__+7 C!zxjIp sySH[FL7rv<_MDn $DTcV4³o-y\-wAvY%:zY4T+d zֵFřUc\L)HDN^3Jb]6](#WΤS8Ar+/nuE&<0Q~Hhfnt$"[{:rc asYEZi4l y}V;#XE_ML|y($/}7ei~~Gz"O6[f2[ew7dk볝0N4'ø Jbߧ*&!5^]^nbwEP^7m&7rlR'MjC^FL;Ţ`lh$SEڷʼTMKB}_CNs#+YɄ&6jvVQw5 MR6Y 0T٣38'cOV5Q/>&q't:"FgZѠ)`}Q<ѧb?qdwUhP |N%{<e7^e= hXT4^O[SЏ.TjkO%PjBujHTB>qnk$X뉺cOĉ9l@] YOCASW+sm˦Eغ8~7t յ\_E%ܜps,ϔZ</R8YE&߱uY0g(A_!\t endstream endobj 116 0 obj <> stream xWmOF_a;[IJKM jbYB+ 3oh,K0F-[>kzƟM*aru0IZ9UyΪ]/%Q>񨨷>׫l^yV;8ķm&5׺,Z mCx!Li)7&Pd[*scaZ]piwGp+bJ>@k\ 'B&R*rZiq}hONAG5A)ߙӻ>S!v&rxR'j77I5/ϯiyϸe1.Zg]CB_!F,*zAi V߆mCeBA0(fPO{@MiI'D?<׽wo,nDsbT6/Ao=Llz[dQ#j`!T*ȡIUuwㆾ*pÓ``dVE o}E>kC=C$h?oN$㽆:%,BS U‰FXr)RI"Y<eGrUU -2[DWN7s 8RE18=4뉪zQp sodGƅ`ZGL'g5nɑ E7F7a#;^M;M !|&j&:|&sw^.(NDѻ=c }ضL `@M ?Aoܾ%6x&<(_g endstream endobj 119 0 obj <> stream xݗm8ߧTu?%qQ*ޖY0רz۟;;+OO0{`rH` A2|L~T`@97RJaKY=wL )2+!#934Ty\n5eES>N5 Fx_Bv BWIye8vHәCB>Lގ&S> /0]\;Z/J7AlTs #2+ EL+Ed&UR DCaGE̶IHis}W\̥?{! Ev>*U={͵,R+E\%B &dwUT&ŦXQO$f1t;-vQaV';vqV}.gb-rwyZ޵aȐ!O81v=n79v@ )--̶5& Z%`4FqtӏZ|2&O=$]`RT q1lTE^y<{åUQe:^BH~ rSaYIufh*D sBqUc;ACpf;j׾xs%~c9HFqSP2ҥ)>LmjFq=Q7ӯN7S.kpz k*[ӆ\J}aZs q8x`Gj:~x5ݲNvO~~o>=J^j((S`B(z1=lwr?N !Vm<?KWϳqsmεwcO=(H^|SKG%}"|O-(VE;lXR endstream endobj 122 0 obj <> stream xXYoF~ P s%j*D5 <"B Bك)3(l7R`E?8JV^ˉ`yFMW *TiixBYRVcZ!Fl΅MjxńO}\SJ#{91gYW3]Qcdx5$Zh5Ek% 2S[q Gۡ]LtLhY ?B?ˑ ,SKTL%4@2i6jdLt-b[ƦA6uԅidj=M|6ž'<]_q 6 &/k.>OFW/ +1mG;Ҵ,!j @!u2~}>=c $)@yAAlۓOIːO46OXYJ{rC4b05x=A>ja!0qSg@Tmx0iRjTK[ #`6q3lҤϲ"cO`/ ).Cxp#IӲIp*uZ5"a&ɴU]dI%kC%=`[MW"Y;%\g}.[lΈjz+.WX%2IÈ?m^ח0?'Bn '%b6`&<C@-]NAO#1CjUFm몟Yq̅9< ss@zϦ3$A3[j\ ea!5Gs̀FJ]UT5L[3U=[z pθބcmR1ŸfmŻ9;u%F31Y{y][ǀͲ2pJǁ?DwC0:.fы|Ì h&Pl%p@l9|,rgs`8p8G$j-i&&M&eO0$0Ƌ:iLJK14k\"V^͚:ma|Z,+W-ߢ[ՠ{ ǻ{x:|c}Ws%`cv}vlC|F07yvsw^f 9U5RXmWl>ɿ\l)G CT)ѿdQIzb~ԑamIGhq6?G.ϒ.QPg rӿ3 endstream endobj 125 0 obj <> stream xVMo8@+-*VAH!EӃj+QGj%fm9tnLCyr; L88@qc'tp0E1N6R}vhQG0 +ϧT{G(" ̺OM9U*?wY19'J>P ݔ?:'ַ& פ FVUU(|!ah)8"žI@#1 (¼-6ɘ ե@/Օ}|Lj ּ̽dKoaRF}RPޕF$)KF^|m.nme)n/'BmRΊ(Zn >H*=Őؾh]eYr>EŢ6ȑr\Vګ",-[~)b"JE9K[`XH~){C{4NOm8A,%BXQL"ڹp]Yi*wOlWF r^拦7Q#1 ۜ($=/b) _ހF(e,6. ;ϜwW'oZO8M[fq:i=B"xǮ& mfRݝ!FQnWnY4[R>9K70-[;l`tXw{m.0woN;-8R7R)M4@^ī,Mm'! w/F6l6N$ N >I4 _ƁSkox9Ԃ endstream endobj 128 0 obj <> stream xڭXmo6_!`@'+^O#.ۓաE$ZKE͑`Y<=wAÚ 9^; SK&Lkፆ] QW 7_]+x62!:02(E[QFbY zia kiu:r^&"No)0Fc8 .h4qebRk"%c蕮XW#EZ}̖)2C^O#zfZdž?lF0xm$iDAV ?-7<o_MG#ȡ{g)gXB#BQY.l=j 6rN.s8#7Yz/ư%T/LZwJ6ar=I \7+=xTMC bq!C,V1E8L]h\H]7:*AEk6" R(^Y\[)LL:֩\z<]sިݤ#k08yo>Gɐd1 毇ň(Cy%+(!yL"y^]S%n|̱e{S(D}͊7R}"$ӌۦ@aLd7 l:I]ƻ6|i(YkyI)c1jT*J6!ks9 (E-V֕]^q>NO!tran-PgHjjԂ|S>~9?adAU|ntȽw]/fV |O΃G1NA3j7 endstream endobj 131 0 obj <> stream xT[O0}߯C쭴AbyF FDQ= &Yn ㈦#H$ʏO&c7[dJLoZ(4N5n>ti~y@RDmz_eůJ_G-j9L AKel5S  Qij&2 ۭldc<ށ\̬)O[l`8m)3#;;r=fM:Vz.1KATjJp;oU trfp=wF#u7s~Ke1)$'eq~}1gmzm6FRc/y@=lb{ 'SHw;uc4gK?p-}s]WF(=՚a9]ݷNiͅ8݅R:y(;;3\kr@]qojIPfs1)f]R3S02Suen=~MѻX/E ~ T endstream endobj 134 0 obj <> stream xXo6_a,pt)"Ϡ/NlslWX֖\Inv{g8-'6!89qf/=޳<Vo]EXE=[&\y[g (h؂+ILJ+آ.x[ 9,"idZovU5C[}Uzqn#zoVj嘾׬X2-wMaK-}mTAJVK.U5ppg@Õ/<g?rDN 8?ߤ-IHUmi#Xc}}0eSȬvd*Cʠme^4E۸%zO{`b*EGDeG@ץ D cÙ`'E@ڽ~j G:M'8QI vJ9->/ R+ H/gs *4I"$2f!*&os,d1z? Qء9_QVX kwXsqu*ˮFڋd!fCK2r.MCwoȤэw 7, &T{piXs QS`24`ȵ83A6w3Pi8Mi0&ӈ5ɠb\CcY2Wvp҅͵ZgӃ駬~$*A:[]sQ%h[Gئuo]1=єw+\ԩ 2{{tl^{>5)2mic o6JTk wIFTۙ$s%_W iS՚$ms)q,>/Ѳhrq,ڹƩ&xUWX?*p>[ŕ^KhUF^ ]gEH?Vv 2@vzh9>$Ve;We1M/"A(f:6 ൯+[HB[Fi|h/euZȡ RscGo +!/ck߁fRcEm{#b Ƣ 5SJ]d=o6JvV>HbjฦO7"W]D m_:]TVu\j5ѹ~{,k@-Rt$wue/ksO/a ~Ѽ`)Ԣ >[P 5 -NUY뗊$Yt:Ji?HCLe.`YqkX-$.}]xo׿èIN endstream endobj 137 0 obj <> stream xڭXwnk( ,OmȒ*mV7T@q|zwfg[7͉O3;;/zXτYge1̀u=f;ͱ{v 7`3.Nn۶u&$]]Awgd=2U_L[^#'6̻(oS;Z OLuAv>BZXDpp'1{:\qZ׹kjyEiѲAH1hרt~7p]-m_eDI IXjO4͑&L]װG@bpµ\-/r=q ^AzVQ_[V=lWt"#a_.cbH QYE+F0T?t/u=m]4Zuf`Az)kksY :K<ک+O01M\@nwJ[y뻯y=WN66wJq)hP˕X~IO|G5WѪ4K TK q[ZQzWu'dƑ]NIcERyug3M.'%ؓ0@gxpe\wo52?dl8&g \W~ >tˢoG~qpq1-fP$dэtzB0}i B`=7Ct#+Q6`ttӓ}[zfo@,ʊ(1mbdW w+> lIs0`GAnK CH?k989F(B8>V 0 N2#P:xGΉ}1܌& =+>Nn厎j IK݄ gHZpBF\Pu"ޥxܶ|ǰ[qآqyo˪j#:cVgjV43(ֺ(ˢDWhA᭰ف^dWV*YÛa9MW<:Zܼ+ܝdF.0tHjZX&LI9-CDIۄZT8 !n$YV O!,~(Ov b ON%8}6;ȉ .̱>5JK*cL8jUL? ɒ2he2 ^>v/Fb op>Շ`NweJN%RJ|Vlm `xX9 k!s5uu۞YaycY+1UV|~2FSS U& /Ѽ}rfrPfZUFxq}+Y\`UwqR/)vގ[}z#=Ȑ"^(s hW=G} 講:p1Ӏ3Ԛip %YQI`¸ȉM|NkuTHa{]p+V@U$A5'7mWI6AdBoU('cp,L`2A1LB&7[MsJaIwhBj䥾eD>Eo["s8HJlq0U/t!}/%-TbkOE =Q\>񤑬S j22(.qRdʯ)MMr>*Y~PG~oz+8Fvװ˝r'i.ۮ:R¶<iw`(P~2p@? ,H=T(a&ǘ09ԪLY4cSϚD6XT 0į#9TO#.Ϩ8QQy3)!} :o&DXjPodL?&a7/c0DO O;i endstream endobj 140 0 obj <> stream xXKs6Wԡ@, GzZ\QшYBqJx!׵*N¾K%,:UrwopQ"tx@,GD$d,?:[3n1F"s="2*Ia<;tɴ' rv#VlBmcYp8"jee#`֎1ŪpeVpsKl絼Nt' /FaG\f.8|[ީӋAhJ\l=rz37 '%,l[0KO Y?O UJH+t}^=M/µތ|<ݞK3jN80u u%z6Ɖ3~Nޤ}l ) >/HVWeaCUCJt:|w1&]zfKU|G\AIjqIRzCQJ!."L$Z&̢(Glvw'&zSb&?@5ˀ!4S<1+Zv (y_jVBiި-a.CtYoixˢ]c>  = Jf*6G[jMk9~[z̍MP8\Uu~ ƞXj ԔKQ YKr O=JvF1>6j6`'%4.S+Zj v-jjj|PL۶ۊVI~GS:&y;L2B@]F5I:z5'$8fUw~ȉ(EզE5O48+m\q{;WЦ.=^ 5o[6^Ck>tFe!^}"\!Ly endstream endobj 143 0 obj <> stream xXmsF_C\WO,RW@~H|Uk0J(H.h|4& Rul./'&]\wRuClr424eAcS֘7ǃM WꦖYċAp@sL@:XWPO_Ǥ"xˊ!=nHi|D͛]ߴ!tMC\SO({c$LgݓHBBCјr ܵDo9w@oz ~=`9$LrĤ y:/ EJ(~FM cX6c2JkgCd [25iU6AS-*oƳtykyA R /|3PJ0 0'{{_bO۸4>kS>8a@4 Z;Ғ 6{Gկctv0pn!]-Q\f[JWP*0Tp'6ǮV' j!V$yߢ$~JMԨMt1 .*,C5r]$b s2`qRjΥxFCoZyv+AsQ*ήKKq]d~?-{Rl*P΍Ҁr5T3xX팅t@p4!>Ij9Ԟ'pb=nKQ QUeel $ ^<;6]ړ[-9qp纹!a1+n EQf@7R]h:-Jp83v#ep.-󪎗xb TZcy߄7Q}me`6`c[V l?+/ҤJrli\!<<&w};N1?@ =U'M|zt ?R$-'NR}Lwwg3.6h|8B_h勉NdL\Pt5SABl|1Ay$ \ߔQ2iʊw5z`.I!gעj |M\Q1cv*mayaK[!+ICeb# Mn}R ťc:J*4@9H$6 I䒮|oɵhgĞzKyQh "2*}J<55ZofJv-FP$6RYHyؾLu,1M" B1ZpMoaI3uE]&",S$J02i;a/=@eM=NN7ԯ3 S~zFjA! PMs`皾oiEJb=o2a]$b6DN@W3SD]V([Mi5wَo'h~X Gϑ|:<1N1u7]`ߟ%`O c!?F|'yGة.=2ׂ`V֒TL~@,O .HUFwIڨN endstream endobj 146 0 obj <> stream xW[S8~_]bǦO6]HvwAMN#\Ac|߹'?)gp^gO8!CfSqHcn8qX8]QDY^~};Z >xDŽrUE<`!~w z${ۛXi=}9ukŢRSήU^Eaeîl'*kms흺5|+'wnL6Da&Չ0tE(O2/6JN/zJ0D1LE$'6cT(=g0r7{88F>'}cy@6StMe3׊XxqЛKp֫SEf3o-p,- #~䫉ffＴw 7ݏTUw\: Nwh7o3xoЈl'Ǝ2oN\^FBPm@ ?frZܱy?w-K- ,r0 &Gv(tY'xۡYÚO=p~]ZbHiqP6Zja$Qku<ּM˦ZOEQXGU-g6@!X3b>; wt"AaeAgruY] $@`.hKi72o+9XX3ӑ}5ј\{1xL>rĩGbk8 (*<.C\rhu Tjsx`&q )7V{mB< u InC )T9RsNý.,e9j_ |8Kۨ0 }0U/S PxyFZRp  Zlin/P0[ %D@Ƙe'l tmWk[Ȥo-nf4LUe =:;@V)x5:PJመPܺZHntL(c=1em7j :Z8rϺ .Bjxb}. 7:΀!y'snu4s>5 endstream endobj 149 0 obj <> stream xڥX[s۶~Ф)3jmI&S&a )*$G/緟],@=Vڱg^]`y&.Iߝ>a ,',0Ixp0'L"،WMb~{ݝ(pDQR?㖠}UI.~᯳n1>9fah~vcxv!LAsx7<Ǥ?0׃\'(#n8ʞlƀ[C/v[5n+o#!f-gط N= G :w|¡.:ja]~<;5#q`}XI8[ǡHI`5j[dfQ.]fWNyhWhUEC,vE~WUlP PW;;qGƬEߟ`aC{ M~/W®.ڠTQ%ds賎;)J]`Aԙ7 9euo˺j{C2o0 b+ NyA@KC1box{9mu?Q98ֆUkI#ʯ-H4ö8fEZ*Iޤ`T)> Z'*WcB9PtUa9JimH2?K^rqaZ0 }Op_eC Ge4N2^#WEQ!#ˌbN(Eǒ4 ?MD,_RmhXF\c'.՘T;.2f} w=`xͫpG x.*|/di!SjRJYg qC7C#&ptj-oi8U)TWv ]QbAbl6Kk5MhA(JP4hE %}׮0#F4MRهP2ҖY]׾VdROfAqq38dZmMohѬc^pkiƪhk;UD.SQ8D&_,S9Fr#\uF@OѪęna5E|` }{$)2\ (%J#d9U6ڿ Jrr0EhxVcc&:jɒ֍W0>#{@ɒ#| Q2El4Vɯ+\4veKP˨n1U\*2Dj:@SpJĻʎjszJƚ*/>Rl?fs]8we/yȱ~I7lOMԋZ+%U t͎>Du)[ZkV?T=V[D#0Ydm5n* nk^p 3'!ZӪhRح9 ҂^4<ʒ3i%^:44׶\.q+;. b4O9ق,I"S2yKPiۻ"Oi">чJTyO~a^u*Ka[r,#~cCWHu)H`B7TeȅuloG‡:Xߋ\jkhEHԃoJuu80Rk]܉ủh cb?^u)F}{xQo vX_h|7^9z;@$N貣*+vL۱hXb򫺑*{j_uRP+JEIMiqHE= tS%wA_,hGV ށ!h{CRѥxLHGu-z#G4}s7E?Ǫ endstream endobj 152 0 obj <> stream xڵX]s8}_᧎ԪIܝ}P@4MteihJ'1suε-Wa+ ߵ+<^] (r#lK (b/>ڃ;Ds(0YU*<[@TE}}Y` ѡADZ37զȤ/6OlshUjSu'Zz$+QX`Ug`ϗ97r)b|r1^ںHnLr$6+>ƿ^Bjog=0FA2ҏ/ e[l3aԌQ7]֑̈"?b< Rמx=M8{u>" ^52۞##Wo2\_'#xIx'zp;u3!g|Q5 Y/u?v_k5O"W-*5hh]V2 b$zSɨh'[KGE^8kvdta.i;nY6b)䛊q +SpO A%ϧ"_T&u1;߫Cײ VXtWM=ݶiÕQ?]!懻wQвCm&M ya0I/$v_o~ ..X}>ws%2:I :Xv}GguL8`} N!Rʇ/}V'I4'^gYvr F7agrQHec!zUg.w[-$G3PH! O KQSnZ^xMouf(ClyU׷d>O*ɴʭC&obH -FY$DACg_+y%R2j qo#шw&]uB,8d2QaW%?g>KU ]!$|:͆3g?8ӛG,& ѴrNp]ܘ:n1 I$gjD N"O[8m$= bsDvX|'U;@tC+!0j*pq & iCu@tzΠ3RsԞS5>&&}nW]f-Ltj> stream xڽXs8O7&sR-Y{r iKNL؜m+luҤa:Ldj]ak0Â8xo.,X3|4->}4Q7=b۶:QtQ{PL.zmyg6py}3e1u:k@·I/u؟I2h0ı3H#|Mr{3WqYCVRͷ҂x%0קLϘUTIIJ/dmfċ*0Ϛ3…G}<TDZOqK8Uա k?ޕI*Uw9؀[2KG@> &77ȑ`n<PL9r \J8q1KH):XY9Dӽ >DLWd~jРnp|]+] l p\ ީ]Pix/*k_Rч1~$|YH\PϪ=UDȑf`)94uq(Le?+4vE=.s{t\WZK*ŬDҗS\h).EApyTSl2e[cw$b¼{i&("Y? ^0??0a/n|^h2I9 z-X^re\,Ղ-9*ָJ: '# E]]*nTld}]Y2Qg;:a8Gljņv?8T`~4g@53ϷRF22Ѣ~v@pxƴp:GG2 ѻNaFrث,$]`>)O6#bv^|m\趪rv&*8=_ѥCʃyĖ@c"Mo.OAOs>otR_˼@7tlj|'zyp?xS֡:euJf7t0@68 ͆}qxKC%+iPi)vi@^ ; TkuaM^NLp[_x>\ 5ԗz(zށe1s5jFBN9r$IyXUiF z'uu7öHdq}7^d\|Qݑ<p[CBU9n¦_9nz7R_lsvK1]2`r4+"~l~^.E| W3hr5@~g٫\Y2|dDa͟=AFY @m?>ZJ%IW\S4yQ7(֏9]Q`.7?@GRY_~|*BU $ϒC3.(sHj@:}1/y5 endstream endobj 158 0 obj <> stream xXs6~әfL +}jˉn˕ԹĆ"U)Ja{ ]~vAOY1+Y[s/armbZ[oT5r|߷#Ga/J]–EJΕLb3}OKp>O+teYHܘ oWطŪw-Õo1&AǏr=%Wnz=1~%ӉF,k.EGdndl!U:u1Uꔇfh^ގӸ PM#p!Td9vo7#r5aܨ曆eiУPyV(|lMYcލlQ64؏S@$%͏֨V(0z\6tGNP5/k@mwwAJzMHow<, xg߈)Ĺx;S0$V@C| 伿7ks9k0JXKUuHT<[nĹ,<1/p(j|#l[:˒!b7gi[vCtЙ O҈8{l SNXދ40YnD}Oꇜ~|6?3AׄСggIT};ʈps1k{Wt"marI>P:^'ms[ e]!:^@I?Ξhm[ (]/(1{>V]% IIs#LFI/g00.D(t,MUJcbi| xu;Y(LjC$ & ƇДsRJ`Y~EH8\@E4q˗0zezHFX=[&b!T֯V/)Q %ɏ@V3wd=aPsWV5͌5j~rgӾ2V9&ѵVCNO~M]׃9]^q  0iL7q7Syf~/{0K\s㢳8[<=6dﲵsknVaJmk3Ul'sJ}`^U/8تOR4YZBL["uІ{zS~bʭ };I`A==,UM2碟};)`"kM zhZ' `>K5$T9NSƨVK8khp 3%7m?XI}8bh'+[=aZg=2u6JU8 ?}?_}ԉ j;m v[) ;Wf0AD;#<4#hu#7C|+;UէGcۑPA 2BeT Tg%쓱 endstream endobj 161 0 obj <> stream xڭXW6‡}hŪ%Y~p:eUH;zNc~}Wrj>Jj`Âp Zdao-[>6FS{ȷ=c^տaP#wa }R"7)ä Ǧivo{ˌ'E7a &$BE,\Nr1m9)Vie, &XԶ 0s3M_nγRЇ]~ByДreA4}9m~kqP+6L j)uiˮ4`RDv-[,ZfQ&i˓نD6qx7DEIA6_,j05V%Tx"ƢA<-jƅQVC ɞ'"D(yr'EZMUB8]mlȢ 6/P#/LEqd^qcL/f팤uvoZƪ$iP6)Vpp;H D JBJJA"-txXKlQ*VwdlaG0(>SA'i!UүhH %cm^3@4ا /2($m= tK1 Y`nE1Ŧ׶:*s(/c[*JE]̋FСB]5RDo{ȅVhl#MJ_ [uIP ت e>D<}0\I|1K\y4#Ҫ$:Y-`oo/נXeE__6*&EVF7ֺANWītob T x"ڂ$!jPf LM}`b IX]sz,>^Xg<*,{*81 Fy\UGz{}@Ӊ2C=O>FgFbvwDVPþ?:,^e, 9 .ĘVs>b'7N&O^E$WF{3~'T=xR"1<=-l+tNUa9_NNO+Nw}q  ϶.ԁgLP(QaO 7%X IDW]oZ̪ &&+[[P]T TACj?j\ r|鑆\VVİ.G{N/^we iɒu\UTUDJ ODi!/qN]T=1~#u}hvGB!Yo2U<۪ȕIݲ۽ &йE^?H>/ endstream endobj 164 0 obj <> stream xXo6~_A &VD蛓(lEX-4HHyi0 - x<>wN a'!,iἸ Pd)VN,Jb=[aҗE; gV #UKq,SډF^P~!Ďe(őKC5%៴ڋe1:(^s2'?EĬ靁(u|y La#I/]v_^S95k}HCԀ.Ak# q ۮf Z 0&Wj!ʺ|zOGjmpn1Y9BzR'1"AP0^>db|g"GEnD\dkרЮXG>dSD$z7w? PRo"Zužq`֌\(NF?qT !imJ!xE]f2Z.w_)޴l#EAuO@p]U r$1QWXc~J^kWWZROCB"] $иȧ'"H W5pQ*KXpy_[Bs\u~VX֭Xfj @E~Ϳ%!B坸_psQb}R*/hjV\{VfW?OFo3eĺb[[h⮞79pׯN9)ۀEW.wWl-)}DbRj؋P0DqLIQG#Xsjf HI׵WפԢN#/\Z5 :6R޼T (wl>L`Q-o*IKˉ)ѹabǠg!Li|4ϛn^X4{W*7ΌCPQgPZx6So,Yw8g"7VD?)' sI"9>9J=!I89jkZ|[n-olg[%5l! pڧv(&Sd|yO2 Jpo ɼMGs<-{Z$YvB)JGl=}k\ C> stream xڭWYsF~ϯfUp MV:H8IJ,lOp.cK[b>_5s xN:vĮ, 72\ώH+3`ŮqYIR-ns ˏ,MyU(W'v O8b5? =絩قBf>U3+djp J8)}iƸ)T{XV3ڴM{p=#µ)TgL C>vRvn)E?^;cOש ģkٶH{SI4/ MYƈ]QȤBwM"h#ZL[Mmd<صXP6Q` B Y,hQHO 4ŝ<|<mϏ;+}<{n&uhE={tY_;/3"*I{fk^J#y\H&mZbqXm䲪]{S'su 8R1;շ:Lb~ӷS Bۉ._)ġyہ݉= wBDoО-EA PR<^"me40ComEOrD&iup|8}jMd)LuE(D'{>2Uǔ7D[O@#!hQtc L6wFEߩBf|QRQLi {uԍ GڎnEL7uVmZS*♊ɷ*R*2!.]C]βV=p!81)~)[B1m^a%=GeC[]`&K7]ش^A ۀi|/0ie ~q:N0}ۏ0>W|p}].&ky+g"/%jf,o$o+p/K&T5M{EI\"CTUvͰQ%OfL!2 Xo1s)T6B3tCUg$u!"8WIR344X=ݲ* G Nxj}l'L~B>o}! uJajcBa?dSC5;K0wArjr9]& TSWuco 2H(ِmZvNxt<ȩAp@&E#s|;._ >d ;ԩx<(GAyBcvIy]Ὗ,9UCDzjiH1Z& -Zzw RH#"kK5YYKK4Ug0ӊnB JaG -a옡`Kgk-mV I>/'IHVz#d~DFMpcei M,nvaq0QߐT6(Sqc:6k3i좧,v+7͞%fBfۜRASE}gxv {z'5s:ܑgy/ yHC R Esk)|QCNh; Ѱ }Oc-䎉(@L$`24K&s%Q6䩛v.3@Bm$4Ҟu{EZ}$}+ endstream endobj 170 0 obj <> stream xeQAN0 HMzDnH&uEہ{loZPh;3 C^nC"TD~DyQqL$N,/Xן`+%i;)䡮SakH Aqk(hUC8͍XQ'ُ~z8=(rl7M/O" Ԛ(Ċb=bM!e.l[c)HVvL>kk:w ^gf)4D+n((XM9 c{(]-> stream xS(T0T0BCs# 2PHU4g endstream endobj 176 0 obj <> stream xVs6 _7SJG_rnٜrDۺȒ+qHvE  @fk?KKڛӹٖ[&k^Ͳ 熦cc IËh~F7\4BKz#:CeUccn`:-Npʅ[ZNHڏRlی}ujed|llL.3؁NdFoBNDAB57rw]2ɛj_Z]+\7E;a p4,DSoO'/ 4qy"BD[Vz$p#PK^qefBtϯ5P;>yŖ~#Yk<4vg,-h _d.u'pZ%DҲ$9"oa,۶EƓc&1Qt/KZi_VU-PMR҆g&U =|3" MAS"M2c lȼ'3(-`Li⻼]F_QA$J@ uF`Vک[˕9ȼt%xɾy` y d*$+\dMaǽఀP)}EU3gC0H{*iIXܑ`9]t^04ON]ʥ}ݪjd5[W fҲfP|pjX樮> stream xXs6 _MU%蛛(Gce^F]eɕY}A*vl鮷]?H?OggE>[zY/|8laynb++<}~s$xڌ + ݋/Ӌ`[QXmZDiVv$"};0|d,f1ri`xz\=X?Ԓ&O{l9sTUӮe(]%YڷfGPĉ*kei뎨ȷm N9;QqE`Wifriyn4e-MʼW'۶i]3P;ʤG87uޗMp+1dɀYP3mEe ׼s[myY9'Ym' 2'Uݐgڟ Y 9ȏ#b)_NgC\I+0Z)JmCS<6ЏK kil& X-;"n֣y>cEw^ ah~0!€% #}YJVͨiZxJ+!\,i^EZSJڴDl(k0UeGgNqL(fj8F^1tӣYa:,\t_P(Dˮs ":un~_4s / ql\U!˃Zxը&yG0}+L CZuF}ݠgꌸBfe+Y8 ?kB%1#fp82uIsڂt6sѾ2T͝Z,=s z] pUmYЕE Bo 8S";uAʲ\Qqݠt# wV yHAɍy$SB]'O)"{{ 5mV{bA8B xAW8@I)1);27if}v%8p c!TZm"UzKOFVy_|t2s8+& \"D:n;bdq2Ny*~Tڄ]4a>Z%gFjkopQI$1觍1f] N,GywGPRO_b7 ]H_Vd/[-iNN^/&\k}vj^.V(?l^!YzrQQc+Ek ̞eg5<%'K,QoO֭V5xhks^=ψ\@_=oe?ttcI߲~.A?(b(o qg endstream endobj 183 0 obj <> stream xXs6 BZ:"4qzޜwvt%OzmG6ۮA~YXrB 5[o֫ci N,%\{5\ÛdQc˂kq;p=<ɈG >qwdȒq,#ʑN>h#:c#;Lի'ؾGipC_ߦ#4v|%2[ .SbX]iv#R&oNtE'S"oX ULeE>8@}`EҊbOqˉ]HǨ&5IYV]hHd^|۪VՐU$ o}iIgIU7@Zqko^4Yd Hr",JO2\/ ] p&L`zBA˸L\d#ۤҐ gWh g_cC5X.#ᰃj`i>I-WfT)hg-'@ؒ5 9'j, N{}!e1o_Y:~Lg7P&HEd M^npGzO[ޢ,f3MKV5M{&'f9֋rJ5&mg6LQqwV҇4uߝ>;/~ x99/O|%Ibg)92)GJ?x# 24K"y ֆĥ ż~\hz, #iàas%U, "Z.@[Dt6DχoȌFǴ͖>|0Palf=E@[D!ռVv (b4MN 0 גRp1U{Z5#8!;4ݣCEЋ9fW/>ժM(Ot}y`zk)q?ƃE1IzmE\#I^ ю :&,xtvOTjɪbJ'Y9o=jB'"ty$wKS}z8蝝Ҭ`:ظi^ j'Nu:-ʼΗaH ;ED#wAߵc}l֝ӊ^U1zT[ǥ}s $ҰiC(jDư[hm Շۋ LE"DBRT®jx> stream xY[S8~_'ڡ˖|Sd$JpcmH1=]e[:::; 6Æۘ._FWm!6FsvQHc47i~3#/a1f=u]s ?_M0KEB`"VEeYԡ<ɢsidrYEB( ThċtuigTG,[¨lzb2[UJǨxh0 jtHs;UhBFhZ2;XN0a_ѷ'H3Q f<7Bߜ`ɤL$-|NWQrYd6/yi㉭<3K %]qlLrg- Hef/ɷb%2y/#(fs)spjԳ!U/pL:&{Gf3qI~ə-w'u΃وN>F YOC{[ %bw~Ouxϊ+s 8qBVMBHU=5;G0l |㎠損\qg.ۚ@gq!]FqJs #>*USP~2b>Đlm(mt,e4g:X-T4DPRGyF zgG@I#-(o(%Xb`HApq7.Լ?y~<(/cE`=Y*Z%~.{7T7r ER%*zYJcBR]%8Tbm$C9ҊRU}Z3ܾJKr`D1iqy}wqӅZTn/bBH wc5(;H>|Cd'=li݇ 8 'yNA !;z-(|y ЦIޯսF`@0ѧ$cC#oS|(cHp'QdB>[.~q%~   ]Hz@Mo FliW gXA'ԏ7{> Iv Z T7-U>Y̽{U?5U255k2~g"|>>舆fz]b^ I@zuG /< &:9z}x{4,AY?> stream xXmo6_O\DDQT 9g{ÊyNʒƶ{d9ua뀡)Hޑ. o MbbRp`U]=$#R <ՍjS5BӲ[#0W:XTuF. z7AyU(sD1i s]Fg-,V@P/MZBzLJ2,y&(!ߊֈv.Uݔ9'q_1J֘\I䎐壱Ƴ3ڝb6cF |>TFĿ8ƞ󣰼D7b`^O+s6 !ΚK8$A!.y9]47`Ñ Lë&I"7$ ]'iٶ$,\U ^ xx~0?nSGk㺉쀎 kmRsлZ$ykl=r=>zO56lVN#guگwh@M]ӥ;/϶,۾1}%,=tҝ ~OT"f"b3Lx+3xTI0T0x5BUDT`aDߧs2:cp}"hCWҵz>> stream xWYoF~[A>'ǑHt"E$"$Wah;\Eacof}l͂?[ %ڛ G-3b[K֚ik^%XW͍m3C`k벤J. '2 /6#ۓT_;pBƳ"-cz2T_%ӛ Wm3}nheR|"=EfھAQNľ~ ;\Hf HSYxK>q"9cbpcɱdFltw|>T+Q]ZƱXeoWf%Y&mG;~ic:FWm]9aEy,HEWTCXB5id)ٗWUgjӥZ Txݽ)'<%R=?dDvGK&WPzQ@P[ N +]I:sEly{&>K6Yٷ>T?t.K%n YmWtd~|͒-LI <|cl-e =bܪz$(/h'8YYW̏]{q39<nF{ǩx|,3U >DD70c'$m0[|>ƃЧ iMm1۔bXN%"~A_` f_ 0IiQoΗ(K!Kx'*-&9T-otO5F!7.UDu2~(s~DC^>|Bvvx'o$OdYa䶼U#|!Rdא8#أHiu bhh }ZwGlip+~wcTv$ph1ԫ endstream endobj 195 0 obj <> stream xXmOH~R:®_-BkH8,±S^c]+ggvg}fU5 ~l-tҒn9p42c+fG횱i9_u-Jp]ou!G߿&0֊ vMQwmZ˥&٫4_=Ҋ_.eJ(ץ*pcXR ^vD JQ7e.ƞO|$YQ5Ih9=x )KAA:Ngs\FonӲW8XmFhxV|rzTX5r.Q[&aKНwqEĔ\5C>ܡ鞁e>,#XN8NNG'd|8 !d󥠁OJou'`Rf$K9+F9k1yf(JvP}(+1fq9&Gh)UYhĕ`~ȘφI,{@Z#N[7*nuQ"p=UZ PM˖ڰo-U )9 ãG*QL}kxEFh=(7W9ك$%A߁cYů=ݱFۮR<8&0N?y?;4c=RA,jô,{|pTj&Yx@\'{$K%3ݶ-6`$&+=P.]q_j[)`!u87cԤ(QU^bЕ)#7$fEXPA62uTs('.Ʈ1HW(4C;f3</S~P`vˤlh8͠=z>٢!V <ᭈȸن enV0KlxR*5(<\Nv[m!c >QߡaHO +m8VlGPpj7{{ b_x-Er4I8=֍.R( L.:~`q֩ Azhի^('^z8iy}D/Ag_Ǥ`=@Ӄɷ[^R+'=.FrBx\|[$>P_o-Z.xJtj*0ȣmw$)"ikbc*g>:M. +#&/yZ~ 䆐=J+^Ϡl60aES^*y|4G!bMZBs$LkZV4( /3o\.G!w׻S@!XEf^90:vifc&SSbIҕb׻5hM#FLv7N"cӟD_24P8i-n颫0߫Zd\f\qr4kQ! endstream endobj 198 0 obj <> stream xWo6_*bUSdsvuNR&ix-ZPx݇,nǭЃk+z~Yub7|i‰edͳ,o!F⸲B6BA^h dD\jgv$غLۼ*o43aqľME.GN'ѵ}DDo9̰}4I}g3AHkt!;V=+B&C@j102BwN& 2C^vv5~5?;l~J(k+kOҪlrxު4&EAS #J}HՃa]VVQ|=.IӞhB2U£?O3C Xwfd4OU G/1gz}fz^N=aXoU=VLV VY2(pc҂hȪ3 Y}~H U1|I|^^w]cIcF&Sܻ|3>v+N #/EGzE,S 2G4Pi <"#I-RAFU, bٻЖRe2/bF(m8W*kH7bMCGT l -vpj& ijUA͔a&aU:NRZiz z(T{̸iC ۷J]L st0N #D't"tO~WBZ~XWO$jծ뒢-u|{DOi0C"r7N !7f]պIDmIw׈ykZ/ $Oyl~BRZxej[z y SKa3HuC4~9n$/@%*l<4i`av4 Љ)"WI(߄xDďFHPD,STTQAiRs> stream x]s8~MJ"y;d{7u5+K>InAɲl;> >ep \#KlxؑF1pЈ6ײX178~`y)Wif2=(wN=3p\g!_iWO 6(>Sl.a]P) N60uH嶘l8.~֔'7B;4,+n$YMfH}$˻'(;ڱ4WCxciֲq?6p?Vf`qLf!F5ӜƢ\"f>=?2\k]*i^b:Z`g[1jwt3R\£ ^嚴+\ȥYNi(KygySM4nA_^bSdY[_!qFu`k9AzVRډBM}>![,;n9WI+;CމOlEτͳEH>v= !LڑoƱ0'|揳xz7[DZOL73q)5x@M#YG{QMϸOU͗`oz:u?Z$h'm" 1*tAy̞kbt1>mkw2AΪ^̾4X݈#D1rfi0q R)߅R@eZfr')П݌tO:f: 1v$*v{IU CH`'~Ya4G^d?z$X'g O'_YUҹ2?XZn\ZbnZ; v$w։E Q(q]>}_K|߉sߚsd Sv@!^;(yJC,LJ RhMlZSHM$/)T%Ɨ=!!4}$ڤ]e CrHb-zڪq EQt&WzoE w \hd+rqAػq (]Q + +¾.OX4hABǜ \9C >&6m:&\ ~PtPM aBG 0p]P $Af=WslNֺ䷪T$+vtEV8V>K TTGQP @xzY'%s@`е%MJ/SyҗEMfor m.-ہ[ewYV]Dߴ,(^q;-ILi OHǹ}VCa~4c1Q㌑`A2xuq04kHVEZbNpl p}~( 0;2Մ*Jj샸&rBLSHC0 RˏI(4o>4p9 O5ӌq8'lFCLvDKÍ1XSA> stream xXKs6W@!Hc˩[v$%MB6kTIʎw Hddұ=b\Vkekz~Yu7be⾓ZW,w-?NDzdEWJŷqCn"qb.|3ɬHKTtnSIÍm?-up|4kɁYl%Hrȋ(Yz#_LJb?V(ܥ_ddYʑx+}X@ _4#>Zߡߏ6d #2MV9Nb5 j.ڭ X0YђN8jgAmt@sBm/퀰U jC1ؒA8Ȯ견`8z :$Rx`nT-Q6{w%k U=:o,CiѬLXcX3zS>~{`MS9܅K jfMh$&|lNjS{:^tq=QAUQI^ iɶWۊPrk<]<㪠ˬ)OAxP! q#>8ԉTݚ@%>14KilҲS6`iSPZ#WU&IG4^1*HZ#x<ۧoIq9*Xx|c c* '>Taj#q#G\"uQZҁ"<@ڀUw+!s-˙ꜸEwK )N6iBrF+)D"d3L {r4}y#@t!Ȑ# =*@?WW.1]Eث ^ŽvVB]Њ*0Eh7W(ݣ]Iid\olil0;`blګ^gԖB!ό"\F7d$±׈MpȌwfHd!w%d蔄*, )NN )s`vZzۙ&V*/TmՀ˶ qi}FL ;eӘ GC(l 1ujDbk9&[2-M '$|xC"fv;^k٠LJ_yMA"Ւr2UmJz[vŦgX= y{PW:_v)EB h^#pt}{;p|󛻜]@Wn~j<nՅ endstream endobj 207 0 obj <> stream xWYsH~_eMqdpRvF0(#2ࣜtOH٪]צ2=MO}aeFl#p7!6;ݷ~d°Cv 8bG+E3]e=<6L'd"xN^谲ZK$Ƌ):+ 2<ǶM}~MӍˁ]Ӌot}zˮWɚ쐄$GxhJlR)m"oI1Un7L+[\6uSܥ:[)YJ+Y;0Ldz|Uʯi@:5lۊ|ALMwZPB^?M'QEwB+ܽ_Ewr@ {('(ٚ'U @w|YIbfy&c*葖ZZuuOYqs?~`]IDA0Dr|}ƑTE!wYEHB2Q8.L20/2J b!IWgBkCh+S|V.qt|6Dw=>!6Y\o!Md'm1w!CzSHb)_lȵl[hrEj( h3[e%җr/rd򓬱2m6˒bWc-@^!rJ:Ɯ;F '$&d媭Vs4]k}xȦʦH};0ʿYNN*eU[^Qyn]e_u={EШZU셢{T ]5mofVZs϶l8Ս^#d+@\n(!Et80 {!ltt%gWDxt(>#/O&\Kb݋(i>D\YPI4(bMz[Wӈaʒ& -EO|wAZy6Ne { }6p-.hK^PL~Hּn#7jjN%$9=>wLEvKM;)rUQW;i-aѧ&P xvpܨ;GT K uu'۬* u0dU&)w샨N)w|R\ oBւQ³zt_NWhbEUm'J&RO[7_{JR{hLNWv%>[RВLCAF<,bK }6}:j:]j(@ 0Aq^tGs{mOcnLؿx4 RM>$|K#a ~"Q'B_$9GE4Y`GͿȭt<<0`Ɵg C endstream endobj 210 0 obj <> stream xWo6_*"UMͅcZlXt"L\IN[wQKfl@y߼hPÁ5BoR5cNLtcȠHsEbjqrsVy$Bsˍl'b;LQ/wDs^HFf䑪^(WcϠԎ}ߕ-/ qp~NΦa4}X$}{Ȱh#ߙ jt#_L1;@n+R;z8Xh]!^ՈiOnxB4 x2,zr%>DHCr-@D ƝDZmț>R2ZLFokTeWH.!_4f8owhu`:(rq \›&*E*̅[CY-cEoQ!d2ۋK-x4撯sּ(`|ĺLo/@7Rh0^c?B=)Dy:Ht#_G'YVO NS|\&nWxTAן+ 픯1}v$gt4K;<3YClKXyW6</U)un%porg6:Mpk6mrw>]WMO"8 4kt_l|23A9$U%*ikՋW*w"$MW.mJCjvJMWfXC8r :|8BVҲV*RЗ/|6DQ҂D,DOSb@ pjg萸6IQgaR3י7ql7,PмѨ 9Bi! \ϳ=?Tj_Eר~*y$>6QU=41M??Y߻`_u bC &2}JDэۼUwpƆ*-hG*;d|ڣ }UPtUқ*&o8iJ~y endstream endobj 213 0 obj <> stream xWo6~_ "UoYYKvEŦmJt;Hlm `xw<}Z[5~X/N|{nܚ,,X\iX'vJ6#`K ]mOyI+'v⳺nq과 @`jjϓ?.iQNAZN 'K||F/NŹq;"n$"<=;pz_O㉱Or<$ ;3N#/X{~DPY/Xb Y73e;23sgGCYJW}0 ; Y^nr%#SrNhoiM)1k4Hv7x8,<VHM])M8ܧ1H!)#wc#8Z_h[] (@-TQ-q"آIVr:\LE<,A'@@7F;Wv`h}~#Kʪ֝RYT坖&$%Q-#7.^㹠ŔI]Qn;!@\a<wYĶZ(a{sQHSo8W5)tOh1G1:\{>ۙw;]VT$]ZL0Jz픦g= k(1^tJ3 -?R1:g~SESiM#b44R.(iJ `AĚw43 1tުrNG!uS(}!G݅#z-xZ`RBVJPPBAD].pJl%燤9^1e\DuƇAjKH}Ϛ P!ـxq]f?6gn-gn}y.4)adǣ# 8#TShߩ2aIGZrC1P' sjH8UYY{nZ2DiZ[ UqHQ'qa@^T@RSz0o|`wfn>j

8KҴ5y}qg@Z5%tA/XQ= endstream endobj 216 0 obj <> stream xݔMS0U-@pB χ[Jӈ,$"*24u@t+tGp7{~8 endstream endobj 219 0 obj <> stream xڕr=_SoLP,ҹ,?ء 0קfI8KFwOL=|DE=৶kI:${d^F}`6q:05'voлOEA5hLb; UVă R= y+S#H[YNSJaZ]X [evj6rEŸ$Z{=hfiwBB_k}X60&^UH^l$ePYW%l D'1g\A,ֲ徝F1L?E3k(eI?ucN!u Upď9-@QZ2ՃFmXΨ~#3m[f(he<3U^͒O5 ;S~}ٚ,,He"W#UԜUS;R,^\m#H?ߜdmphP4? zW^ULcr_ӭi7~p7pePP?#wqEfn 0H8W fUv-H BA8Kb>U*o[7L?=M8w '',C{*v%C1VKh؍Hs/+zԠ:+@rqn3Gqk3&g]ibC*toMd0S)XUGu+%,.*[g ڬ,JEc>q}Jۦ|p %o؛&fԦGKdX/t=3!~AVKF"J'a _MRL5+V=Tgi5ŐрeH9hjZvd`nC˕ fg#C !6VELԧGUJ5ͬXp?;lCcd]{IeIgIwvS@#2W򗨔\8$u"j $PXд-L.MX/2'#i)bV/y~NHCZfy$M |dEr͏+#7bfsЀ9c!n[, t9$xRxȂK6d Zk{]߶=+Wƿ۹ر7~<<ɀ9@ (wO|NZGPKVDDF2 YgVfJ'rXlr_S30(ͧ3!nb:3lnrcm"?KYIXh>HU*92)>X1/_ ﯮo~hG09h6[)5qU0eRդIS1rkޜYQ2{2"OyKco_PC@Z+[Pgs6I~ٱr:$|{/9; Zފ MӇw'ljkl8Yԡj<A] *e%KNKTT`FXaq́r iYg@9} 7zWz; )zx4Hfc @Jq!n'MqaќT")%~r{x@JGN?qr&L&YivG{s ezzN FF+RzȵA$iXH]R+^YK5VVVd3DX,!R5Ʊi0d(NsGѫFiɴG<%Ukxm֙o,tR)QK$=c< 4Ug?XAGZ\] h91O3b\؀ZԀGnxovG9뿗Zĝ"O~ભ endstream endobj 222 0 obj <> stream xڝn8}؇m94S:tgkded:FG; ߷.ʲ=#*b]7sϛ%>Y^>.f?\3u27fKg^da:[,wYyN%ȻfnA`-4o3'Bi3yJdyXM[JL?\3s(qa;'I坐 +3T"~b*<-nȉYi{lȞ$˘!ȈTiu=#?]oU_4?N ?V9N(lO=5afUݶyZtѯu7zBi?DyR|gxDVɝd^#$SQI6! 6F,VBɊ`  j ڴ։,Ie~kZ c i(+"AW tkPj0TH?c%C j1+@3˲Aug&~,к#/~1܂3 #N#Y Ry˝E.`}V0uQ2P><[yŕ ]jE@\ t: fۭ?s~ؙX=jBϫud; 'eA&ƽ(9 FA"5|"wHtHS>;Fa[5L.jAha™ ÓT:x˕&Zͥ 1s{*-q(а\# (&G8\[l8=B7SmছS S&;9}O/uR++,4㐩#m7$yl*YrȢF22p>5[o&edcS"KW\-q+yLuG2R#UFTZ=5 XS6x] <۪躂>%ǂ[6Lw0(zw088#{fKFJRɒжR!KFpɽؿ0%$߷[c={ˍLЁLΌ_scI=7od}@knJ)}#yx<u.5`V] v4*m^IARJCKrv^wt2"?5ћgtwsVC%/. endstream endobj 225 0 obj <> stream xڝks6 YoiI/5M;sD굢i(ɉӽg @E@`/X!U^~ڮ~|,XmHdh4X M0#$t00ny 2z|*ʶY"o$pd5'c粭R4Z+7h7"/oc`]O:u:v si GUdm_QVU``(붷w~%fSN!J\MVDq" l DVf$ LX"S92 AWF:;5pF.,n]| y[0((ъFaXqy s|h"Ȣ*4yK۪2G(w0yaPD:*/eEm_3󲡑K4Nh@wT',FX"vd})]Ed/ޟ)fej/jgDK>(,[Fs' 8#pn jK{'4Ν+ VŹaD "{Q@9E:_iؿ5eʪr#- IUɮ-|o##o?s?{=c7`+#d/k5@T[^!}e޷N ɓ 7հh Dr{c0>Ie&G>"uyW׷ K,YUK6 5ci>,"OG:)fJ69Z)) uˤ_ G>s;ZHG' ݣ{sivne=5aF% vkLi %|i>UEP2?+ں`FSHkZ?\^[a4 ?!S!:usUUQiզ"7MiBxh{I&p#-M/M վ5v6!nN,lj,N`( FqP|?s|eOa}}l/3L`/ŽfJS]ι2 #儵ĀŨAH-->IozQŹ'_`@q!ie1 !% @<>%_7G4ąfzcHO5qQ#үp&"Kw#3މD*9h)\4J` ox :S}āI2bӡq灦Ҿ斻 p9)F=cJ5-{MAay+58o QĦ&m8^m}h_oʂ|3CAsBBxXw/ O2ǣv$+ J1>U` %' %m,^w0V o~B~ a/*d_V-MYsxAk7N5_F͙n蟹egb~ 2m_Nzw,E_|6{> stream xWoF _GTIwM6C:lhg[,hyFEZbHGGoy[QogtX&^[cgnc+]`6bIq81;-R*QYOJl3򮨫JY&Ba18,|ę8N./" ymxck=ov? ]hH ]. 9 MDhg+yt~vM{1cJJv}S3KnZ'7ۢ .5윈[hK9@ߘJ̹NWXwy"͗JE<_8vU;bYDhoYʚ{v;qtt>/jEwE& d_U&?vܳ\$rb):pL|)?Lp"G~Ml9ŀk! ْUk:xDG}"*-Gr!L!]є OdQA +HkDaa:FkeXpyWx(HL;R;"c7NJ%.X*|WP#E!ysn"GCJ\!tQ+X!s83 DUmDbN 7Zd͂}g"PW 2P8 5MrȞöVkWu'VJV nEEJ X$I`,0{{ K/; !vm$F*d)R;ʶqW ^8W!0V-6Kk3lgV R;gƅ^']?f{3a63 >hb=R m;.e.dJ;[x)<7 +5)_@lKE byOV@បM_U8t I(A&H9ki/\`LIUu!c~]HvxhШW#NeJ1 B\g#/2ɂ>LtW)$ ̎52j gFnWQi_G*k:$>AJ7y3?,} ` \uyH5 TlFT>LTe]a'AY;XyB s^OS&zz1c6l֬6-Rמ@;xՕ5/t6}}:)n<}3 _Yxb_S'ۋF: Ā:2p:%d0=2KM)TA<_7O w{q'}ܸ0 7dܐQ=G 1`@ }[P{cP5-;`u0 50Qj@ dN `‘KʣH6`vF,)MoiHAk@vBK[!p{zc jL endstream endobj 231 0 obj <> stream xڭUSH ~3Ʈ3 b[M۶AEǛӐLʕK+Ib{Lː0fD -i >uH3z vmv_RWCM*nև[ éۆm 4LS z,FQg;9 IDHZk{Z*4e%ݺdTH6Ɋ`LX ?P- X MAImޗe'uTH*)fX{ ېY$ţI\TPKy"p7'C7,Uwۛ{X-ڿ#NJg{SygXD_i_YÞeqqr0a~ԕhځa젗3Y +rtuc.ImSߑ lYojƲM\ ,8rTǩF9p0ɣmx4q=U 7;÷213 gMO-dG ~*,sl{|JW2x'ޢP]n,aVĬS]|d'ы"ނ_xX\  _Y> stream xS(T0T0BCs# 2PHU4g endstream endobj 237 0 obj <> stream xڭXKSHpaKNYHGr"I*2"K^I{e˶H<~~=ٳO|v/^^O{Eh7\'ؕݠ7}|<aJj r"! )~wlKEV1FN;#p::-l\?_~uFA@m{ jm.О|ּȲp:7JhCy=:+"h`Z ).)x&!!z@B Fq,[ o(2ޜ5'<l)p@m:V𘷼NJlp*+Z<.V9 &9"GMkxuI\,]x0kę|lpyj>x;~|q4ŞCK';n !hZ5ņ,<Ո{m0AZ۬ȯ+-<:꣉%y$Y_lh[Sb,Mbx6w ?]SZJ(9.D,(6lN}Bp }&bXrV9)߷pN-)p a6oH|#-h(k:37W`+ZI,11z!&le8mV5HYq%^36bQ*1g^(>1uIO6sprL /YBNIY^MfL߼=<v^Gv'B(fa~NB \D1l ,fMLɃ>jUkc&N/)*KYj 8A?ѡ(M^ޓz]q+_9>. Kf[>[rh)9 6UFykw4uJ8N5R r8=>hDhi؃^<-"㙨ۙQFEEê.7!hܦs`YA278E3a"F &c&P֮wK{Pwm)+aZ@pNrnWVBn7?U߾;=~w~| ᣟ`uH'~.E_߰JŲn.,+mD`-koû 7ԏF;e`U%] Ɂj@1 ]@sݑv8aJ1FpIl}ful pZI5Ai:-xb*XMTo?|;,5Ki*#Z:f4qi @Lhٔ4QE5@ (TEQ1Q4 endstream endobj 240 0 obj <> stream xWmS8~ŸnV7K} \VbnS$j#EE:s/= d+yǐэ t 6e5ېHFɇ>!G~=~}Jho8G7u|A6̊K-ِݞ0|O35%|oˋyӹK a vݏOyHxU76tD0ѯVi]W $5S9%[]測dPf/hq%cΐ(5ٹYD:,mǎ08 ?:I_A׊9M /$Ȅ7ֻg &#v1V%vׅCm%9Zf\=xV@ZOzq1Sos/FyiF0{@8yϿ+N5#VhAR竺a ;eQ7)&)"NjVՉUEۉ 83`3kpJ'!ԠYlYl l! lFM)'KɽӋcZ^^+jk E2 XHEW sw&U4mO]2Eٸ6ڂk2dY<]'7tVQ\7@lI3cl9[wڡa߶4TPK?H{0*j15vd-{4RTo.!֯5] 1]eawew:dvNu^zgGz'OJJyQM S&su%7޺r{5Zs`𼱻bwC04R0J@NZjCGGQzHeUf$7ΰwR!=:٠ /?n@-:RAy |ZC+P%f)v]씼Ɠa};0 endstream endobj 243 0 obj <> stream xڽXYsH~_'VN!.$x 76Ka[UؒW H!*#_C #sx51^KC8vD˜\"4kG*4&"^ock/;R߭:20:ϗeOCIa# MZn` ) KEv(-}<f4>ًsŽ$[6̓5dZ`y Gc SLD{,tмxi|LZ6` 2O|O$=ՆD*ڽa#/hrlqh& *s܋۴$A= ֢ =w~AIwP_ؖAnXI7γ9Gh}ȱ8=Q2;k)-pC+{]ߎdR 2{=/|H w BJ'kx}ivW0ڽ0&PgjJ{Z?8{:T۴@+0|O ݂m采Ȥ\;у~*!VB][$jc]io$XQ'f a~ <=m6\-sƏYj'2d#`N<$о&s= TozI7i{o4EfAHB(aR(U17%eHȌas3nROd/jR\Jl c.%7ݳm)@W[ {QU,h Rwu:V'S(R2ѱ h2j.]\-" EvZ^Vb:^I\&nԽU,:BA8V8ݴ>ɿ+W̪5@'0J(j~p6jvW/?\I1'ܤj"4177Щ+}t,mf4E8TlqXZ\;2W)`*uO/?Y VW_C4q!;iSa7fZR9>BQ u1;u8|UnxliӦt? PpaW >d {}]s$ESf)P L!j}9s=܃WJ\E-B3N)d"F\rPBԶL?e8 gP>bJVxp1ݴ8<' F9M2pO_+&%4^r_FDLWV9%yL3q|S$V ޏ{-/([⫄XlW %ͪ P B$OMvERjG\%10Ș}iPtI +J.yeGTut wOmBk2@ M&ɘA޵f:"՛ endstream endobj 246 0 obj <> stream xڭXYsH~_AC„r;XJ8T,ሊbo!GQIU1q̈́< 6GSK& ̀kѵ},Ϳgnb:mzD,O3D|.$їӎolV쫤z{jkq,ɰ}ӘirYh<ݨLuE f k6u,Oq\=Y|en}25m3h5AvAǂC"˴v`_3a>lG3:5NpG<_7&P:̵RmLфJxzQCȭ"Ʊi"!c,\$su|K0`@ƠՎ$A#OX%&-RXh4x.JE%ubzr_&y+Y\Z4zn5m c=.&!5%v_>1=Ipb먥y6d8lڱ֋GqdWDV(xJ 78[yn'2weX,=#Y$2f54B V@3,O\^+dE?Y-!T¼E2[e&q |*4i^9@vD鞿!rۧ'p]48 `-#?h[!{&-op%g Խ qj9 {qmKbTNLmap' }ܚ2/Gm8C[qv A|6=&P&khU\;lDwq!NwiLÄbpy)k} ~R {:櫢ns(*(-WW*Z)zSFnFLsB&BT=xf1?ol (  ^pR$V/Xi|T\*լC[bp2:|6yD/]B_j^6Ȇ#T-dyJϱIUQW-i8xPhQЫD~# yS@ oYA51Q(6pSCÖg=cDdYpgf\I/8CؗrW:)z796 ')Vؕn8 z) -`}UМ)MR.G|YtU%\`^o8bDNEx;l%x JrVei*CfylWTBMJQM5&(yɟjg~{ P6C^w\ZM>g%mmj` OlXW8pn1o[qSB[W~}R??p4 s͓L&ryT0_]"H1L endstream endobj 249 0 obj <> stream xXr6}W%3!B\xK[Ψeז$y%&R/ RDŎt1v]bQS? vb:cHԚ-YXDd>Y*)snGWa|pXh9[di%%`za. erEL"*tׇ3':":$}KpyVZVCjp~nhTD{1' mT>f߶,|cw)ώ>]2;O\>$F?hSσvk_%Cf}> ZS&̜i1|7rpաE}sVaGQ磛+=S#"hM^-l E2ac{0|+'bU񁏊xLW lÎXFp{}Ct'W~T w#ρx;'qv JA` 3#.`"qv$_lI_J@X׶ LW^ޟʅ !o/U{v^7+{`h/ˤJrX {@G&պ+61Zs{ԋvyB!|LD%(Gs:Rm?Eh'4z9vB_P)(~hy+t\jv1SPRuuy=9>^+,~6ُ Cc _D&*7[Wm9U|Zw@CU%OAD;>R}J.CsJZF[W+lC?Y [IvWҢQwiې|4)ej܆OIEʾ"HR5jLLJN20QvHGd^v ?(\}!(?:}Gd*g6ya<м&8#5N疸"20c`It _^v 6/zP _ûa/̘Q$.|NJt1%r,u>`$ mxy1y $7u,b(W`;E ИFSb)]h|::,'-jjք__Y]糗UZ٦ʆeUzT߸Q3l8˺{:9zxdn>Fgjmg.mQ> ٚݢt[ 6w'HcA@>29 _Mm28mg4/ciKCAD??\O$fяcD iZMe9>BYq'3 8 {f 8O7)" O@&8+4M5}pHḱ|lxk4GyzHlH5fl5><̢Ž*@ҽDx,Q*Q, Z U2 m(* SEn-TJ3ݼ9 2j2u'` endstream endobj 252 0 obj <> stream xmRn0+x*( dIq6p[8Efb22}] (Ps((_Հr\ #Ԥx^Q,+ 9u7&Ha@š(zómnOQu=R\% ׾Kf~:h`GG-̲r+0쿫O}B9ОO0mf[X &͏M[0ͫIخCRa?LdQiU b͇zf<* 6Ϡ}izߙO{;炿> stream x]s6~S~if\ͽ})H$tN{wHJ ʾPrL)6tᦙmy#-PL<_ T,u> BUTb\ s## -ez 4Ћ p]Bo(1ܥ?(]i= ИfDצ~' ! s>5ަe[]}S;J?V*J '93r*]i ]94xj &_ ~úi7=eqQASJWEdXRKnClr _v%W%o(J@G)ۆίT[\(l5 Kү:j1#4fy@:3T[ =M&4:$>(ٖ,;)}+a6(gW.%ͤ<fޗ407Pd,,];aB\ZS2+|ۗ70XO xzb\!=_;(ך ;iWl̈́NS' :̟ΩE|aAj?#2P ^t]1IМ"kkD`q_Dq 1 -g]E=" Y ~$[.`c[_" @k7Y[\ +֚2#k{4HBYԮyRm/T_iv_bvmk䳚r njU|V' >2Nߵ%OGFV W+'d !;䱔#& 5~I#̞- ^ep>^CeٺI׿* endstream endobj 258 0 obj <> stream xXYs6~ϯI[nx7C6PR l|䬔]Vxz z *wy4$iRo(':ٗl;iu 8Km+HHŠ%~sS;+yO FXz$ ]JNtf$=Z/)i|Re̿m2_s"dPVunVw (7[TE%*%i NhdUf~4Y p">1D䄺-Wc+Z #[͈.*h0,Bi L^H[`lq(!z=ƞ/5&{U "DbqZžeQ; ;tGUܘ.k*&R`$֊x[d402#{S7Ɵw*6m,싦+b f4D{gmRQͮUN6'`*۹u'hQ < 2K]éh7bcUS8ʮY%]s+ZMkΖfؓIg4 e^mJ2V(oT-l{kS'unåus -Dq`ٶNNxTW9$M.& 9$t|?n<#ْNR 5@Ɩ6RQѲ1K53j4({o nccscdM A{bY`zbb 䅣;\83X9=}!z R?i(&aۦas8.Uۦt#)?e%ewH:(q2.y ( /#{l_X%6NtKzbF^'T@:!C;gR;ftjPc=cb>^גq9Re ;U c*9I#JDEP6d/l>?_.Wzix OOE[]K&qFsPrP6ҥ$O> ` $b3hMj1Q <ф+;5y͙k$E@SAiiJk rI f$!rJ.z f3~[% H8pԽ0qjɸĖ[|)$ ]3*[0nɘv9q W8qԣ@&>w+% טS)T 3@DGnl_hs:żH_Y!EIEh[tys.._W_b~"{b$$L)L)T;} Bc[\+ej)c@)rSE\8rږF*;|$6!.Tȕcoj\jN{׷0͑A }3v L]&@*88A5xj _÷>믿pufiJ1}H4S6^SU1GhER3OXbN۸?ڙA.m\~% ނyu\[;ؓK)x}v&ѳַcûp߀(7 e54M۞^_d)H Q\i} WۜFvXr*t?C endstream endobj 261 0 obj <> stream xڭXms8~O7(/~%MblқTِN.oظyvviG6p58%!3cGNDڠA];B#Y~6OWNKkF,y9 ʹuӍ51GY]5I\nSF EvH=yhuV_kPjGf^a;U*ELWds" Sf=yzmƃ}{ "9+Ÿ)Lq~ͧJIgi- ^rzU8-*E&O.qONE\fP2O\FmRsyptȥMA{n>Ar>\|2OBrG:i[Q;{L1iJZ:Ԑ2CQ.@ 9BD?oXI|&7p,BE0CoZ}uY8\5VA2)>QDŽ6yψ/oS=*.E;3+x &e_,-b,v6T#5WJ*1h QYg7+Qw DnAգtaĕ 8*py7\r|~<\-kH$ i?|jL՛ty+.nn`z}V V VŚ(曊 Lo ɋ2]66\v'PQf:=i㩓E> stream xڽXYs6~S ȾҨcˉt:(Py4q~}%9Ϥcπ޻vAYXY܇ʶ kbz)+% 4L򣝄O? enrVs9q E[prMX>$UY[z:s(%'H\cZrrJ(r+"SeaWG}n/2w*I$6ExzQlhUˢ3En2pc'ڍ}5!le^dl@SZ$Evl'Ibv6{V xk R`M<+<K5⇇س laWM^) (J)-;b.DK2;qBBo/OΧ*PPo|=GH \Zz+YZHGUhEӒ ^a" =xӋWS|əl$v3Y-mԵ9ƺ].EK!o%r7%uՉ2r?dE.q/BgA;0BH Ʈ#WkB#EQP;g|q]eQ\@JOe]mWW*q,ԧs-=eI|CS/EEwg]]SA?NϐRlwe%Z_`(Tq]n1$ݏJ|'En}9)crX3%e  䭲MOPiEYZ3c_g_6jmU-?ku-]U#bOXuύ}2>'2{]_1v޾oY %IHxtQb8 ;HbP!}LI?lu.IC # [$AဆA+}"* / ByNZ¥ᰊ 橽^Ӎ>ť(x@cg yP-CЗ ;wΓ#yځ$ckb}c]WWf'#dHR0F,۪~ J35]X~r endstream endobj 267 0 obj <> stream xڭW[s8~_GU˖| ,8iw$6Qw6ҭgl9IhԈ ꒐Fl^n]#庮X1j7Udŭ[׍̡RCr}BjX,$erhf[MV_$5(%!cĶ\!SX'Vm-mMY)܇526kstrr@Vʑ$K~*iYۀ3R%5aB2 J$Vֶdg4}W`oER,9[(Ul>ćl U}lK,S3\FIl͇pYZ8GN@48 r%Ib%ͦHR}NJImr5`-qdOa~v~:F'u e"Б#ɾ,I510;DB虁 t"E"$djF%>u)"`ӡi&iUQѻrf9t'{ݤ{^ntsGe\82  Bt>ͯSMɺmvmSﯩP7@uzcx1 ]Fu> stream xVmo6_O(z ;mv[D;B$ѥȣ856`0؀Ļ"_ ' 8S'ي:O OXք VʂQ_VQr9;Tک^Os9d<.D5zu.T*u;QQF9aI½هٛ_rA-߬拟rXo?.V2 `>.{dL}yT= θzi  vGi` )L•vmLܴ2Q|*mAKYLRK`nbX G7+l74GxFdz/Xח'ăT+N$\%X>z뽣YNP5_B;ӳ  y򿠍MJ&>;ߤj &Fӻ*R22k`Y7o{ ]59`] 0NvWr.q==*W}Ojpݟ0riI[\5.";#l{r7V8q}s"&*LM=~nBrB[Os?|A$HAԑKħH$K :ܒl_V endstream endobj 273 0 obj <> stream xڍVYs6~S fL$o؍)X~HHWx8ָ@I4oZgE>VZZow4qZn,Sф2!qd. H#{G}O! 깶>YC+;:8u!Լi[8<&A+O#Uwg9~Lcˁ@m?""AHV^_\+]!5/vb{pzbb8J"tjJ#hSJRs/(^ە7(יpon.W$ ( +#LU6$]8YIƐ\D;J@Q}C<tN~UZ 1#QP}^W9~~׌ώX؃95y=03HyV^y}vE;F~,] P E܋bΦn۱gJ.e=tsr=^A/7pI7XjC+fdE1&}DuCP{$Y]!azY2*4ϟ.._2ET`I@ *G+!F5~|<Ҵg][_o.t ´ccH3 MM kt4i)NgX7)ŝ M0nƸODtN*"(0XpV/ѢR(? -.}\\p3JOP Tl FwZт}_aZp7z:ޡÙ@ԃQU;<smA¥Ah0+bN} ׺A0A3HhxTKH|*vPg)%T13B\C!+w=WG4G/Bv^_=[s%UGng:<@0p!'m5 dR\'UlmGdž8q endstream endobj 276 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 279 0 obj <> stream xWmo6_!lBf[֝c:HAX-4wǣlq!FDǻsQ{[VcMسxǍ;1kK!n,#+(/ q_#=%ZskUuV#B 2L1(A,tRF\X{ځF%9ߓٰ;pN}Fȍ,N}^҉EިgToh膱E9 gTqlvP<.شpGFΝ~qU+҇ġdtr viTj^;E)ik;0UCP74UjӡQ' Nȷ&Z8#uHw&z"( .@aC6́i NkW 3g-‹_e.,3ڛl0U) = #V橵`*KEIÉ-Qȴ \\іl;{FuĊ,zcum' c@^}~W;0saB !cBH6 zWe^gU7x+=*RNM2L)8FL ۼ e7$.Dą !q#Fc  7JEmJU`ǼNw&v~ bïr*n1*SCTíޢ%[TԎp~m`G. CfU>gm,4;3g8rNlC"$t (H']O #cD$@.DnZ;U]lF斍85mȡ{  J˛Bg Xnȿխ 8[(xv7+*#՝&Td+@|t@â\!u?|fhGʈE&-4:raދ!8Α{e&*}IeEjǬ:s9^zYћ (F8MA紈pQ@h4,ŲxEDS%C^;PA.|lhXa"`/ /]H#.ih 6BefYE#Ϫw\ҥ@ZB7O$վzOA5YZ͜Z=6Gq7O`sŒ ZHxM{z[Li'm-NeW~v"鏆V]!"Nso 7$O.ӻo@EߜP_{ڃ\=xFzwl۽Ts$_rP^_oJwgʄbd0EV4P$PT_]E׼F֬(R{滿y endstream endobj 282 0 obj <> stream xWmSF_ R$-DӤ1l`>r%ݽ= BL{ݻ}Fcds}b ױc'vp#v,"#1ϓ_ viqY7TNJl4-/d23#j~qu=$ѲCva9]DM)L/b7JCh`cM mwYx4lVyݘ0M+ pZ8d*If2+у&Mȹ\4_߀–+Z'ejd n"J]awmǒk ,UYUpW&CtAB:oo3yB@j5S&TivUU]-&/߀ih082!p+2eZ4#lOp-qO'[o5؁#ZSۑ} 9\"dp|JMZGӹ3)@3J5?wA ]^-^6W p˟ҨW 6Յċ 6lOQ!)6.;}pZˈ(ifjrgN*>-m P|w؀J9ɤ" NйNqdg4`Ji5vp I"%:8MC%%…]\M) hAYl^G{N 5 ‰j1hH8  YzuRj !^*IZo>*x[xh c- beS0P@ |Xs٤`3-ETEXD)."#%N8CB.Tɀr3(mfbo6a#YJJZdGU%z RLpw5vϬ4oP*Gth8_ԙV_E<[ ֫5->ϟ8O}S|KI"CN]*”0@> @dV9$_TˀzuNtuޖ4^"cm: M-Q/ʕ;t*Q塈F"ZYAã?B`.UB8LY}z]Bmfz&<*x^+~¨6UޖϮ~冣3d\+r,zgF+}ќXD<7Y!iBeFMI>M4 hǃx|`j;“U/5Q+gm6*X},,oz5`E8|C$O} ! endstream endobj 285 0 obj <> stream xڭWSF~_T7o@Dj3!B>YrNrH'c;O~>[[*zu*,K5[X2\rAb;g!an t%<Ц\8n q8G{v'"/sE ,Y#t"eQ'\u%??9KPxzGv%X.\C #;gۿ6ռew+͢YȖ:2a/}srFJX+%k<+v^oCc~JXuѕM +޻x}q}n,lcn{ Ӂ5̖hgB?g%nȱ3?LղQp'IM064wx`;ʢiVUu+? 8? ,tj;z cFv%Xn~U-oN*;#Q̸&y^HCDx9MN'ɿǰ9NS$\9d[Kρa{/BwǑ3Q"TAc)| 7򒠼 Krn M- ,N/'ѻ;>:Z )`S0GycpG]mDn䗲Y$hVIҼfAlm|w AHmyధ񎆾l2qG>dGFKG+c)L11fB7{1n\uiW"8^ٕobNQLWp@?I'DŽ)֪nQ%~:իuGKGKZݖ:%KWzNF:pA9 4mM yʷC;GRJPƿˌpŀQs^BYY 4nIHR#r)nrF Z. B6#|ACuY\YW$fh<ܦQbK{R>J@[ThI8a@+34AC55 -+rجLJ~,{LxwtJ\λsk y<:3 8osQYtl0{]xތͧ~TˮVGYysRR]fϽZ? endstream endobj 288 0 obj <> stream xXQs8~_᧎I’lپ7J/8iB|ul6+΄ d:!Jow]Ǡ ?8 3M;FxgPߠof:_Ï(jru,ιe"u%għN%ώ(D~ܠIqkۦOe'aqEha 3Z.+C X (s=䪐sv01{_\ޮ [!@M߭ȺMF`z}Ǽ }5V鬌t(M8gQ%e%({¡ ^f- XlYֶWgiqﶜ:f$: CX meL /k@Hz޹P@<:x圦? Z싩EVa]*uQiA /+<˷p[ܖ1F|!rYmsNk(_QEAh}1 ms=CTxFvW,T9][H̢c@d8[ۉ}Ĝk҅5Rn"RfK+e nDi*F?<ػgb 7)MJp6vOJMJXRjy_WɋOXRkV#nȮHj?Z? Rk$4zcFG[4:\E;n ~?]'nq˖LCSS2*A ^m~AEZr9@FO}5˪6Y.4黶g"Ej٫Oڲ|ʕduU,U*ֹŦ't,_8؝* {]q7t^ojh;tGdУM[^a[p2 lQ7Q1(p'jGt> stream xڥWmsF_DJtzA"3!.nlbt&XHDL [nVw{Ͼok8scLWƇn axnz,#c]0cf<:~ggG$t`fp pO|*hDHvDJZ:XAKVƱ9#DqW ]RRR u)N@:1ɉiZJya>f%$C/7 i"4oTQ$./T"U|X}Y=YĢT>kmRtVX[å jzgQAt'Hh<0fgb%z  c}ڗ~hkJi2q\_hSbI,vx:>eRcզJ T>?-5.tGqեo-3p27%ہnkq_`&N9u j)lm1xh<'=?^VYr>[i ay[ ϳq}s6(Hj 37 bQoMdZ,yYS_0'Y'Šn9\5xM16XLCZУ uǥxU-q7n`6O\tFkzɳȲRM U*Z_V1ЃvH˵x"5pWwԡny6&k09-)X 5T[$Եּ7W4Q#-2l,7 }A \oIiVhVKW]2{RzړHav/&}/wy}' enUˤj0v('z)*ERzuZ+MC r]ziD=\õ# DR$R{F> stream xڝWs6_ARcM΍;ĤNrp>&w`a}w&N~h;[.p+׵{zqYeq+X\Y\H*+N#'gA2n^ Gay4řp<,GFLq_Zڵ8zھʛB38gҗ {], dp|G٤"2nvy\/hLyF)i?_MR:;}U͋۶1=#1N<̖m7Y.Ymh*݉ufƃUlYE Qxr%svv֕J`>.# B"qYY=H|\;J9ɮ˪>*޻i4Od6+hd"_$*+Nb9TG5挜9tqq(VWo/_Ϻ\ k 2t(;`X  j~|ͱw~/?`',ػ>󥧅M/gʐ"08=>UjH0 MY9 =漹{iscl~vpˇ,i%UXj&h׫zZCKgط_8RDXGJW0PqPށ]/N`_l aT$K(Bsm=q8 $鼤~e?-[( 5)4`tf"!%kT! ,(G݇mΖvRK{%>Kg: 2^U RvS%,%zMv+{#RGT=vF ڵIә,a p \Nt3R0qq@YedЧsYġ.$}$pll&te|ʭ!U'D+B\9:vG<mҐ")(:>׸{㆏8N0 r^Rg#"oi۔ Px_/ঞ3Zdݝ@>u@ksn^P0 $Փ>1Bd:#D`/O3xu9J JRXoA ) H C'ӌt["k?U0VbGHuRoAlD[noڅlzjKc~tfbgt@1j]KWpO>nQ CT:T> stream xڽWn6}W}X+RyK7vteEՖcJr}Bٖ ސ$gpӑ =gV8?$·rH'Y8o\J5A$߄ '?;CT HW-CDZ?m(-چEby\srbWw }ej |C@‘⋓HHT+nQd7ҕ<"Rzg\lyf/{%b@e0 <@D[ٙ S9|cZ <`*ud-0y("p 232w v:i}\[zA^y52Wґ?hgZ@$*'Sv.0FjeLWj15EA$VyӲ b l>/ulV-k.8;B *5JIB]_ɻ,7CYEyӘ7\F;K9x](qh1ϚYc*b61٪oQFJ< )@QB䵖yq3AbA #](%G~W f!r'Uze>T= ARJ;YƗofоm;]~-@u|-_5!*y-, ],6O,NY?ӱv{0\6L JmV~wt  -nQJ$ZЯ*BHiItFAI8\ Nx؜2԰[ h{;6O2 øc;7-QtWij% {N!Q*7]Glxo. R3p1C03D-?D->VEAIެyؔ6ʆEj?Pg9@94|:?eAuG$?vכV]7NWyde(@{,Slhvj OX(h0W5 KNOM_,f3~&X8сxJEgDf9摊 e> ,qmi{D + grYVH="GpuWRpZ֊Yͳ9ȍA(γ GK^l\6iQ|/@o endstream endobj 301 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 304 0 obj <> stream xڭXYs~ϯ`Cr0&{'{BZZRZ+=h"=TMڙ!h|}@/^7Bo]{YyW7܋BY6a$X&SoUh7Al}TiBoC,]#4Jc;rh-BmNࢗ|M̼PEkr}Zi^Z{wHX7nnn?]?2ڰj:]?- &oe'.2@=MX.6dUu|wMdQH#B:+2g*n*v& b @ӹs +dyەk7'!P4ƻJ|+;ϯ&24˾a6cIQ$ غ3CW!i0"qQm!3Ϯk_P-)1#Т/.X'18^es-ך6ZUezT !l=ךӪ Z'~Kb rPtQ(6a')>`_w,{s`*|Cdu?##M1b8#RXr+pNd6gMW̑FKN*2Odxw3=Y999њ c[)3 Є:㌽ṪRB SF`%6"dBhibd%.+MDuSɴ&]ʅ1=ފj& Jx \0Pvos8g*q=:~2@Bd^[E.nm8,P:d-%#N2:%w,ɲwA0ub ,f#.?h|GxACYihl14[rzuL{Qj4\*nj.++찵L58D%@WF>GooItg_m! ^7hWΦl+#N3&?uR|~5K#=&,Sp ϼzDQUޣ#=2'(HS+&R ՖD#ʘJŷMRH>_Qmb̛_KqB3 FTU?Ϲ[&8E-z?2YAG*.>99mB5Ԑ%xD|&Y(Nwq5D` -BAi3&5+mR+Hϳ99^US RM29AȈ ( g1` ,{e7U ;SIan-`󆯝=似+3oQlM+fsՆNotͯ_Q }8KRNƒ#wa<2ʱM$˯NƮ ?* 3!X1dnIDd YsΛB> hښgCJ`¯y{"8X7a8 -8"a˻=~p4 A!FsjvyT RݱH~m3~y' *O@>iI69g-:Rֹkϴ3`'RxLkE<(J9cGQ21h4?2nַXNJH??j endstream endobj 307 0 obj <> stream xڅTMo0 WLj-+a6,إIƨcg6~bHY")G>!I&?&$ѝ <C2Q?FcG3vB$Ku:V  lw&B1΋Wvfy~54P®hpJ)߾X.]9akAoQ2iǡ;^?};"hf >[2J_q%/$ endstream endobj 310 0 obj <> stream xWr6}W(q-~U)u[Ev9l$R%6( ejB9qBr=3Xw+B^ys+Mr5]L9ήM+PBU#.b0 Ax"=7O#!BKj]LCf5W? hxZ6ߵбHyfhB< O8PzB+5)dɒp*acdFڔ頉2i_^ju}M?7ch}`i.ĕ\"ꪉx߁nr 4tFh8~#m51*e|?c+MM_Cџϣ{o\t 3w!D rcŋv2l=ݻbهJؑ[vlR;gi^0/*όV\f9=d-家6rHCQ8umb-!ٝ~&skZo o\ ,(-tȵpts\%mhðL?]ݯx.r"I#'يjUefK(˓}a+t+P PeB_VCBJ8n4nHކ _yu'[`3a"ETl^ߘN.ꏇ{<=_C/AWM zŔC ԋH*^vO: TN,+(':^E&Z%}D֬?뜅t1Ή<޳=q]nYĬsAUN?w1m/[%E{1-ÇMjEY>E8S endstream endobj 313 0 obj <> stream xڅVYOH~_Ma۷XbViw4 硫vpBUu}Uձ~YOZ/sӕoIͼLZ%SKnּ!?[A&8K6ro @˾$wwSPpMeHjzɰ֝/3'eNgKeuReS34g۵1,v̘|}ߓBQ@2' 1(8U>]%jA~,^=#7"P:fEnF#+'La,v}̆CGaٞ,ln55u#Qٙ5e*d nξ~@ٙsszp:aC7=EWLbVA̕ڨV5tMjebI0K5Tޓ`jĢDPw,"*'b5ѽ'9gχ5ˤtMT=lA9t}`uoFG]|'y0~ %s:R܅=zɴj$S Qazac'ʞUgTP9ÃsA\ Yj1ǰV &z5~:J9OAb`@8ZGo9'_x~[ mgnTy =YV1Nع?>^f2LFb0!d3@S/k1uȣWV|܏FӯL|`PCkBn,,J] 0xRa<x{bI [^s?~Z endstream endobj 316 0 obj <> stream xڭXYsE~WxGxrl%dc yK#iblCVxMPqe藑;r;=sFbv97r;uRw܌߷#?hQ;i5P#7=7 PZAj'n@ #O?[~Pq :9Oxdq⋮\YULu4 =}:s9~a̘.8v]n}Qi R;My!E CeՔc/r5qFBn՛Z;@aHJk/p[QɃZujFgSy@嚷,0f:OQ2MZ;Փo.{k^B85UukpՆv(`t{T-U.khaopp3֒\FCQD}}~BVk=+Y]`$?DڮF)h.`VmA%ZվVj1@4jZv 3hrPm4]쭪SK7ٶhc߇+4d@"$"?<7TSI֙K%B`~][ӛWC!%v>]O/'7pӐa8jP(Dk]B;p4[[U~HPh道Qο3~=vfs˘ K3mdW7kvt̺>{?Y)ۘSMjIb9N<!jD.APU@tM;<eUZ%CPF otR|zSx,MH&+h[VRhh( {XɧH^^Ng~9wHMqC h(d9!?wMKg@7ڍ^&~tF 4wT !d GڮmVdb,Wle}dUi FJ.Ĩ ]uuJne^N4`Bmd qhˁMjYfE C|؆uHJ/\)"UǒدCN c!:-g2 nο'wj>Ԏ۞\c'@Bu?Ї ȖV5{QgbY =, A!/T ̀zs_!8'8op#p|j`SWuoaţvT\3*!^;BT)xqVfU^(vJ^ xwBɐT`H }έ\Npvh a;>a/'vpbU @Pu_M.eN( uw09LoR9ꂻUIS*|NҀokyYdR/#NG X< kB_wJB[#Qrיb8G?>FS|,|_C'>бZl}X46MHDJD1btS)Bh0/&捲'd$B"cK3IC]Íu`r/$bFyL qF75^as>'I1=3 48Q!).T>'$0`PNxvsR'KػܡbhӇkf L;JO:~X7#|1z ,tf!3`yaYӞc;:MT"C`ɼS/1&]Q)_8biBƒtGAӵ/`iJ"Z-i3/igiܴCb.O4Y7²m !j{9\Zd9?YE endstream endobj 319 0 obj <> stream xڭXo6B؇E."VE=OXQ"36Yr%9wǣd)VDX-níЃ_J˙gqṋٍ# 5[|M>DYBسɕ^wD?f5ۋآVzzr҉+FB]>kOiv-&+ LՍG 컉%%rV h¾6$ύfEfs?#`ࢯ ̦o.htx;{v1AbA땺QUM4ߕAZuhCCG/F ]O02YEDJ_apm1\#&}iΖaVm^`A 9<`4f `cIuL5B/2 $ BR=sx7XQz`?&TC*q@LH*p1@0dqnT90:E(2!} ɆbJ0M5 B|.v`曜bω_3|!Q}s] hl_`6 PuGe<\qژܟE\̍HϷW Nciej UNV4j + i!L/Җb8g};Mmr̉hpn|h}{v?tGIFәYqaACR `\"֕i@uc#6Hx2b֌$7UWrQsxߌ/SmT;޳uQzPio$x_9}?7Tp{yJιsȲ(׹k.b"䡏*?X½*68<eI?璥:8z;H)I!YL@E3ݔا+՜ݤnțj1^ JG ]h1ZA=J9\\CMY`HmMmk"!g_G/HTSӺ_z:7zeQ Ȱ5=<ģy {2jsV1q:xr=8fEn6/znB,i" κ+0Ğ FD qHh@kؓ&Z)qLqV9"7hc!fD%aA+,a 0daB$]`{X|˿ďu endstream endobj 322 0 obj <> stream xڭXr}Wt X .F"k#$B2+OtH*QRk>C&4 -៥Ņݵ ˌHh&BM8f*YoM8.˙Ắ~~# ;8{~Y3}LJP5j8}_3 ~ޕqU/JkGŒT_Uz:qV]Ѵ #*:Ɍ%$$i^)ŲOxaMtGg Y2B.p /e6(]V]wmWMLc-P^$Mm v<fض);ooN/r,ѴuVnXK9bvha|C|g|"ꗓ!ܡRq5 8lғJVR%UɦLx8[Zn4?)4VyC6(\8vCw,Ŭv8Y[ACa`z{OmBMD(t?)$ziOVI/Ɨ1؜Ũo]B OPGHSBѦ42*|!|8 ,lCU 2_sws{1XRRKM*k%ECT@|d\W/zappD|:7vhcq" {Ƿ˃'ꇈz=v5T\Q:++Sp^@Jd*5myRZC_R98y?ځ~2b8bei+*AkADzS,d)4)~ rq~{ju\! -3Wuc GP"1Fl ugYBH (dkr <ɚSM^=Aس6Mat WM}x=g 4=G´z=~`R4K&cD~1o~t[=|~!#Q^ޫ˫m?I~;#0rqB/KwKЕ8~c*qU T֥3툿CJbAHY1`9}rYn:zWΝp5%?7 1m4ڲ&}<} y͵5lQ^3|eA~-%ХA s_A2?aY!G9}ƭ#S֘k v*jGW wyV렉>蓉T<.>h̒5^%[RTT(z8CZ }N,6Q lSk x؁0!U ,*e>Jn캮 jIzhMNNd[N3<Ѿttw@1TNGzC VCࢰK?& /R6 (P ֘Ov =A(0*UE:b*) ~ >UѵFȔj!Gf) 7 IedK˩;MpؐT;NX\₄Kj`; Xتg7%VurOB[-v7,t'K5;SvklM Yhȁ]D1R@ N /2TCL 7D@])x (_`!2nReEY ӸjB3ޤ})g)'9y8h>KWL,\˴=wb̈;N<03(4ϩ-ޑ̏_zw^,T[ MbDx}+HH0%cp`Ҿ#$ L@eZЊѐ \[j?OPWDPџ2λf]UfN,`O7g= endstream endobj 325 0 obj <> stream xڭXmo6~bWmRDzM`-PY+zmጴZ[EE "p^XW,"x^u7v!DƋu~g W.Xp$HZw2o/X [&N,ٵrUepTC,(39 q)|@ٜ!># C9yP߲lDۉSufyjJ_W$!Z_+%ژoBwX.mن腢P&uO;>{K_rǴ4UNG<3mвJgGլC:!WYczd>Slzt mQQ\&=@qyU0A*F8.!9GP4B'vKi4++Gߜ×U=k.79OVޫY#BSz6*; Fq ս*aOczLaC`AȿhBPW\?f4 i`_muQu௸:-k_ܸիtPD2ɧ Nu'հ*W5O4eKs#B2-ٯxNu.1t?Cs~~˻['(bGec1K0 >r<=gZis"E[%I8g&2-H%d ib2gR7?m<'t-.gNS~Ϻ2A^;} "`<""Ga}]1*59DP!5 ?Ǧ3.J{Aĕ}*NMF{*f3lj>*dሄưO>*8@SR:Qm_MLXDN+⿔ o?ŪceS9yV5syJe'c=υHB wyڏ%ȧ˛ϣ2Oj:T7 ;>i}x2(qSShr?|/ݬOWo\'?!5h,F3;+^YZ wA _l`H4)R8w)Mێ%~ Ae>-u{A*G([D`ZDN1&eY/ 'CaD EAD,Қ4o?rA8eIt<5O"Plo:x+jbXkB2Ja MM]1pI@6T:ӵidYRh#"VДtz=VBi^1T?'}^[AGXJL^!H z{+=a=@amuz&iVPO#0^.:Sapn9|mnʴ=>R HLgP ͛4CՓq,<]]=&F1|--iJd x8bkW]Ǘx݄MvM6M@`i#ش3.B=U#f8P.i ԐC5U;Q >}A  ~$RryV16kZZ&7j$sQؘW47Ck D?PzuiH-J͵>6] endstream endobj 328 0 obj <> stream xڕXY6~S+",=&AӦH/tQ6DAڲ Dgs~M)Q "HFu^H*DteJ%*"*+X꯻u&r:[gUR?&6d~V\EЉ(jA/㣙_^jj={AJ9_gKL#Q˩A3 a{oĞK˷j3KDI%)j- TǺ]E4ߨ؊R%r4Rj^<\fGr8B%D-2~\Ȥ*J,<2)є< g6Ŵm%HW2ِxϒdgi|Ad ED \<[Q!7gPEB´堇DnոRjNjtZekTZ v I/m=NJ.[^m܇VpҼnMf !XB :ՕEn7v& AcYOnN"z:N6W[;5*ԁ|qa!Z+q"EVc<͕53cC޾ppCq{[wezo?<]!Q}2뫽g_>L]X][%fYEX"`|kxUm^\Tgݷ ^Lp. f/g@ endstream endobj 331 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 334 0 obj <> stream xuSM0+|t$>  !*qIl̦q.="J7ofLo? fnq(T3ԢFL-[nj6Ljd53%r+ЭԤeuU5ǷV4 X*Aq0 D!kHhu& _I\}<$>(v/tT&Lm2KҁaП6q71oRL92. 8~Vk<\&;$)^[0f4Y{@O[ԃ Lf'd \R]JJ'7.¿"0?fh=yos `?jKc($\p:n5~B=w/v״@~P&gSؿt}Q5⾬ "(?OnߙŬݜ.2`>]\JtQt i0;_, endstream endobj 337 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 340 0 obj <> stream xWKs6W!gBxdvձ-W;uh8HW(Q+{lX~011 ΍u+?1gA#xhӏ&q)4A͉'Um.pXSs\7ܲYgٽKx7yUƞ,fjˏVeOz 3(xE\^Nqdvb .^ʻ:{Sx]ܡiҢ[44,B/70o5VOx38]ȒxO%ͧIe6  :L^[}NdkUI)$)f9{?Ju='J~cfc޲}I(f<ϵ>IQݵJJ.kjY+C5 C=Tj핽:Q'6ck#+杭 GJ)RY򝚅j^^Al7 M}ySTzs}S4-/*kF0L\>ggG`L$Pq(}UCdEx|{ qL2 [ql Ǽ.hcgY%לfuX5`R2f@*CTyPIL̓^9z,y86D7jfm*P)Kdc섴LAn'ܷYn>b֙YbF*9xl2m8zL PSOg=T˪y9alz=?8N--o7#KN{=28kD-쾉bQцd*f*R'Z[,^ Z1}"Ll5m⻛'\ț3{1UØΕb ibNb ~A/(@[,[mWT8`6iBU}7xt{(!x.7sVbm:ríE/$te/d3G_Y.V]t:_!.Dmڼ^ Yf<+ӢPYs̆`'{sCwɑɔ\/Yw3e*[8=yI`%J'P,\up06-ͧŧJ³ٵa 8sC}=G3;LD8(A J.A,!CHzM=7݇;"ECgTLVLb ]1__VLɨ`B*=˶=wN<ȨxsTֶz&v{L?ٺ=e:W6hM y]Dn2> 7z!px=%!w]̤o/z˵ٺz\עyg5UW$&qX endstream endobj 343 0 obj <> stream xڽXYs6~S)>ɲ(cKD$yifB.@Hv<\.~411| lxuF ء#Z$0Cg)zg^lˑ3S1nO}.>fEdeIH:c!vX+8DLY]N'}\<ϰM%urrX?lF7G/sb! GJl l;:NF40\όo׫쀜ktś9g`I!$pŒL'+Fc6s~maC," l@I"W(6=V/Q'+x # ƒӹ4V*Cy-ϳ~@ʬNTHe yYNkJ}h\.j<x.+mF Hh=`D̩,y APKAXgby! l<YUt& =nSsfŵkJȯ4i vɡCPě c-NM'ыj]-$( m];^EH&UzX *Xim6x=aAp!!dfoIZi{$ 9B?ts7yֻT%O4U+0̔}az});qYQK]V7eI/d]gܒ|'Gdt|ϕVUYY"B &M!#/&<7[lDEcӦrBRŊRj{ժ9qWϙj!9~~b2=u{> stream xWMs6W*S2I#=23)W2Ih YSJRqC{w,YtLG!X}݇=3z7_ˑc%{6%:]7mk{Ѧwu#V(tcqa2Ț,ɛø+0ƤT}A;3G6ע[DU3 qųP-WO}}L5łdBZ+m{OJn!F,j6pʊ;V.I(Dd+Q@= O{=1ĴڬDJM:f{2imǃV9.xW΀ZË\f%ijGotpKz\R>ǧ̲gxBb]i܇h]Zee.j/Gv1#aaENj(N`y4|&ŤѬt`a{x6jk<!v]nkђF|#"#q_J&,8o"% U5u҂m,AJD Q2B Lج1>]nVXyZ>˳F֨Z;ýJԡmPZcͲ-8x2D&}ԱmXqy*<Fզcy, g)gxrMG6e ҺД ]1,R봹.ҕZ37v~Wc>u#qۺպ%\weR { ҡS Tɷ.'$Xd7eufVM,Hc|cg]. WѳFVFE+7MXd,;iua:ڰ\gJQ@v%>ϒ=@rZ(zq\05 ($| 8=L-Bgt庪b\˳*;b.uFezv35͊Q\hG4ZUi;DJJV_nl!FU;J@xl<;}%DG@mM-: ,]pY{NpƉ>B$~>K+kיB%tiLmD4GqG*'X)v,mX?VY'hcQO .%˖mnqp=``;-CHP[(bP/R3tYbp`\Vڋ`PJĸeؖJߘ}aOC}v3L2`$t ݧN6c>Hg>+CYaLq3+YQx]pA`F\|T?:v ¯}'Bo&;DzZ9eJf ϳ$~g2h.?Í,.@/`5w2,f! 5Qqћp;RB`R.,PfbaSE endstream endobj 349 0 obj <> stream xڭXYs8 ~_GK8Ik4}m:DGJ6v$>\Mc֙vkomYfhL 4昡hΘ=МЇH.F8z,s7} 74J/ћ|]"*ޞ;cfy6>e8ke1y,2>M.W ;AؼH״]g/P rLf}I#uL9`dkdzف~7zrEsycx1$U#󵸱~72\՗nʼ"zqG'i#^l]V<c5j@"?b_|Qg_3 J3@e;&"x90ⅱ80CNfg~{g`GU"dftb ձ|B wGwL r$w"1[#LDF8_+S 4Ko(X@#Qle 2$$H QNJRcӃ[7(]g%XX~~3{H9~J"1:Zd9p{ r(sŖۆx mVMd)TSaZv/ÓV0L'q U:_\O.f#xsAN%G!4:g E`I(=hb0hM FY> 7L\i*yrg;fv0+߈|Ib,Z!decIږEFN/=55 vND"JN۝hSIlB_hre-Z|*HAl(&[Y1x,$2HփZh6]OIHe'K2MJ_)mLb$Obs,&}&Jn\<hfLoX ogVsp^1|X#/rz~y2 @jnz3M;*o1shV+1?V @0ٰ5857Y)4T "'|{4^D!p(*i?Ю)RpT)o\G]eo&!( zm=u> stream xڭXoF B&UwzqRqJѢEmǓ,/JED<?q̈́?yM-kgBhdp-h׸}uR ˲tmUhGyZE^>5;̵< 5pnI!ƅ ;`>oGGee'8gư|9јir)l|NxXyN |k;$t3#GGj626Qz]3OPw'JS&/VlHȕXTn}"7SuƸN<9MZQ<"zdiu՗cD|Q[VKvq'GMiqMYv޸ȲDI-G0neCѽ dn<^Qq8=Wv?.Bq~Wg3a[:7!L`7#52 l4IݔۏO$NcCՐoʄ,u<*rܯ~rclHnRd|D˨ )t'17g}O#JH۲@RIk*!*Ӏ[㢑NLB8Tt^Qf׷s[Gق*g\MѷUN_qo{^hm~6d6BKc&->WJ"h,/'Wz)*r<֌#ܩNЪ+LN_dQi e0 &6ca㓔yjbŅ6`ϮWlcðj`1P56 pqDCB}_^>fM\9ڗq=R"БXHM# 2G@i@A4U#kg+NX 9ahkB%yo7042"˾qb\.@'_P~鷗K\ΖkN(*U -hM7G^E@ާ`-P4/ 'Y "`KsiC noaxXQe\,HXNBũ"zEԤB%tJ]u$ZpV?BYߞ`:Q²J2/pde/KAz lݍyP6 endstream endobj 355 0 obj <> stream xڵXKs6WHuB WzblQQR4mz)XbCI_],(Q{t쑀bǷ  f8njЅ6ƫ89w ر3#3Xd0ώyd?MWË!F꼚XiR[a؎WLO"ʬͫ/urٱxEpRh؎Hn2iF>sl?0-SsCqvak9qCی (R'mgX č̏?0J\vƊrb<0{LUrbqWAlגˬ%B^qye-|Mtk6qxH  Fnu;5;q蚋jXH̤hUZlLs< E)8jbP~lO]kZr%k(DAz|Kg]#5KޮiZ>-\q@a{a+\ lQ2<[N 7=>> 6x$b|7gw$mʐ@! Qh%6˪[앨oAc/dUQ@tV5ZlhޮD.3o]˞+ /?a^ "̷q%o$\mfCUZ BRqR}6 FAHn"â>nq/u)6rLpqHcCο8#8;`iQѼe^/Ԛ'`\bVjU Bsi(a$ޡH_ϓ7SD`A4DP-QXjCE2a1o?44*{!B0\eQ)3Ѫ\=`K`646bG=t+*ߔBRF_$Z>DmjASQ/iIB(e}_K<ɪ=dd^S(R -PM!6j_h+e`_M_P/غE9 E̤:f 105Pu$7U@ce"_+4M+7ĐMGbɊAc) "mæ4xOYK/x`_@]J\MS%R@p9twdZԲX,Qpz~Wə]̓2؇qz\)`ɫř=\R^.I(OS -d݌[,ۅϮ@hGm{.flLeq3o[=ViH :)=vo<SugŻtzf%WW{ݨ' OŮsCۍ'([R픻-0ߓUzKBd}O qC_͔g>C'sqjSIG-rWfXE5P7TZEK -*C`n#xLo|MϓJgooӧp|C* cuU,`tMd];I24;y6 +1VqBY6*A/'7SK:eJ;r8Bh]I@vHiU4&?v]L|4)9ܕyMhv1c;@L>$w|;1w (>uUDT"_6v{޵Hf  -R6C6e<ó F=qT^AXwUW._-VSLS㷟PA endstream endobj 358 0 obj <> stream xڭr8}5TU xejĞX15X%&h"-I&Fqv_rX8'>K;;'X*g}QFW3/gҝ?ԍt_"kg-~u$Ypb<4^YŎ'Spi<%K<;9Y9?_^\!8HRao\ QJ&dp@*+_-̂Œ w<! ]4 #W9\Ĭ,~yyyb FnypL/3$o bc߽,ժFm6 g.aύٺ<~uyV|BXۙGlhԴUOoWV&S8(+Z}qW0FeEP^mw~[vj$`PDtӔBwcId2L%=୪ey.wBIN\F`᷒o 7'̭1|%En:& ~F$XpP;X3x38'2W<Ċy[* d\BdꦦYy_a/4Unh1+Y]wj  IXb^Q(C]@уHt;zaP,m47v"w[VFJeը.MAա7H!U_t4T)>KR8Z=m|EXPUvN jBuJp!x ,Db A Cy%iI0o6{a&%!+`crrz?VA?TzEv넖W]y]<3}:aL cѷƉ H02qo<aI0fޔje&l:QL="ɨk{(Z=Gsn :(#}.0˖[ ո 1mU[0H$*q.U9 "dJcelp0=uLd=m[Ӵ(v}PeAmYWhTўD mk j"t}6^"9-9 =@C@aP$ hwyr jhSQKqvj/Pd721+,.PBS.;/$@ 1dAH)X7MF7=28HwȈJY{ C)iKHx~ cW W/O/73FY"@tKty^qfT͖"E^Ѩ]yrDiQ`V=d ٶ#fM@JU& LlQ㸶‚#-`Pgyu5K=9`^2sn>P0Xy^śۋח*B؏Y;DPtM″Z*+1{THX/?۪=M5X QL4G#12Mښ:5,k&sz{`vicqRD/0 Ѹ4NZCx?5t^fC PlWk(>w]VVD8Qs~ 0 ZbH{NbWЕʸ+eb2Pcq`^g6⚡f49LUE%E6+)Q0jz{yȃ5F4~1~D$rVHx4J/Ōز^M&Np+݉gw[\yO*b e6i?'43DfKbBlZq'&w*"CnP5Nj+ \URCjJq'i~U6=V4;]hlۼZי *<,qf ee@mL Q>P7FNǾ4SKm dS 'P3 endstream endobj 361 0 obj <> stream xYKsܸW\"HtURU,gYZn=P3 )>_޸|Hl4ݍ1'Oz!Q7;Ly2iJ/idlޗ29-S)Hݶ@'JX`TXۯGVx)G+һjߏ8q9x9 %/9XpԦVI4| M8iQ$/x1B1%biww4]W;\;2JB~0hʡ[_pAD* )%tȐ2Mfn;]ט5̒.7LJd%,$QDcY n f2`©Ei]ޕx1uGR-n2Dlߴ6$[%ЋH:hĊDҹY깭$gbl@^v |p2y[mI'?Fc?wCy?\\}hr) bVݾKp+h^Å%Aq``ȿ`8 ȑtpVP7RHkf 4d~9[~ƻCwK"b_^;Vo ._>[ R뷤lqơCJ~;ܱe7 |g}&pߡ GNU|&pC?Œ3{& ?8C RƗ1O0tON.ˮxqԶHxv9ǖ? ۶+ඒ4 0eDC0*WKmNIlt'ɧD~A`F<̽Wb0FtVܢ՞?z=x'l?_E0Dxxl6̍Iֽ- f/dC_KmQm>{Lo`r،^n4'{H M8~L$vZ=$\{@9@ȫyaPvnYtnڹ+Rr(Q.G_bI_k]Oo`ro0p 6LߐVTID#J5EI{ #}3 Ki}gBH9j\/k$fnU'`Oo{uXσCO/ endstream endobj 364 0 obj <> stream xڥY۶޿B_22CC]wGmuN$JbB >}xLsw3\,bwboLU4`f]Ͼ{Tூw3Tt6[o^̱˛2"OwtjBu;yVD)3(we{W~4u9ޱoez%{>~D2ɿyy0Õw4޳tŗì'lfݛe-|[47ݰ(*̖`ҸdS)UmH)V HDQu޲~jxvߝm*YʔdF=x+BF Ս+*ܶouʮ>ؾ2[F_eٍ`tfumy 2@lph9H'^ߒ%I?mukoPFaww`RKmL/EɧNd_l0I\'o,0@q/BG{c9ት}-J-'=7Dl-[[݁] ů( %~ Ђ˃-A-`##uQּLw5}D8FgԌŝqza-:JOEpEadeX`̃݁`yܴ6t]u3$`Le/tZv15><4cïO sE'|c6w'AC?.XmXca*LV7NN_EոJs/438- W@07(f(v5M~.-4I*@‚"[ iIw73iC+s0OI'\S&ZmqRۂ+P"Q–[v\Dfo1jġ QmN6Ƀzr|!M+WVO`ȿ8D(,vok_|&FǺsJ}'$×Ee{;CႅSz%B@RABBAJp%GVZ]N#N`P{F`+IZ]T B`G'D,^7Bt{IJ)4cap@ec/ ||urΧ2!Ktaf 0#OgU4S_q@Ux߿_?,у,O,SxRrH 9TmI.0 uJ=@ :^=SIR( 0>Jn72'_Q՘hӂ?XF!9EBF8I)Dju~;hn{C { @244#Ѿg$Pd0 -I=d&qIx偵/qX?'%1]rHsF 3.SVw6#9epoZ!yjcw0Τk،RO\ӇC.y0Aud8T92cSb*bЪnm5A0ݱS7/Z1XHe*~*WB:<#S|'&\٣wu l(x֮3[cerK!t>pHί`uHR_fC$ۏ!c|ҕk9oXwK&;`,x0b3ũ̷D8+EV*Cqhz6.rte%/ZiMmG[SOֳrNo endstream endobj 367 0 obj <> stream xڽks{_fL'ŖRHl83=G5hׁHnH3{{5 OMtd0]y|5QDE~gWOlI+?5Fu=EQ͋4?π`~b"{,nqyMNzȄ,VuڡPqпx9~4u#;j4ݱ+50-(AR1ʴK&nMþ:nlubժLmq&FrRw 2?L{1`x lox8CȜo0#1[Ӱ4MW6v oOԛO;k68@MH7Ƥ4U % ır-:RVH+ઢěJv[]X?veevVWI4xZNfCG} 'j\tQ,C@4iZ䙋^}OUw1fV.&mD/AKΌ<_.Yu^7o2iHǂ1AʚǷW>o|.ʢKzb*:1͢ۃ>OT;чM݊h)$,[E(eyu%B0zn >;B᎞f[1IGfLByppߒjDΧw<㽈x$e@@|PNB 3v@'Xx`ū?]uPf,{Ҝ'At,{t.LRL%8.0U"p..q'0cd|b?HgRX'-UN&?ʒbB(pcȖFL$,Rq.ĉOUOj9.kx#݂B2>Y i87P Y=6d5nj ?Lq:F~fԓ !i&\dZw(GL*VtxM\ L2McDi.y +VfZq`1f_:!Ǽ>L  I1Q\DI>10#DRe0HΉ-LAj<`,|2sK ٮ(۱Etlj9pu8Z\#Kƺ2,"]d:N8wp-a@_c8ӟO1=-vWه3$/%gx}eb[P2(ͅ/̫C&&e֩/8X4|(H–է?9K3qU:x [FW8h艿C-~†~&sз2Q Ls +I][|HWrQ(dH*L5( BI12 csR< jW%*9쪐tBŪknNiTTC(Cߕ4R7jLh{M0QߤҸυRqSIqܸmˁcQ@"K0iRjTC*?oI$)-1*#SQ !ZPG :Q ě"uvZS)"EM$J4Ȇ! Y," MM\qReI31{5:apNNy`I0CLSJX7խ*];SN%KCUsK+K t$4G*A TO0D]X4UM)b&l،sP2UcoߧS'3-iEZf Gm-MlgF.dkCikSȁ5A( V>,pQ?Q\^]_O%*HLoN>qhy5PxkIفX"2OBJqJtK9{C#vtZAC;RBK9Rn+wBOSؖ< c,(]j=%^I ze a1+yWbo5N l\ڭԪkUCKD endstream endobj 370 0 obj <> stream xڵXYs~ϯrI͇([MzIŘ"q`N?_sS/OtS &_RS )CG)%ƬPĹy|UdMV?Hư:2ĎJWvei X&ID4oK pݪnH2{ .$jYM=j17ʬ` jXOFP䭳A t脡 1Uxd%h ; Ģ-fhV8يgf./9 yO/ˬ(al%Yܔ]/ɬmvִ0vc(u~8L$Cj|!a Hc0˛sd듫O܏ hSo󚺝i_Jv6be+p& X5YD9lel(v}/1ŕU'lx=b|=rח\<\M7ĮDVqb3=ѵ6 *ptapG>wS:3R7q8y+͞EJ3pE7 GޕkScQ,Un3ꚷ'd:Q.Qb3+W,7:5!jp(&F9rpm3 7ejYZ{oJw^Ƞ@׊z'hIrM4Ա>-t>[&zZfc+LIYO)v{]d^搏ۚ[%>|`<_j:7|)'+ -FGtYp>bG"ofCT$6Tq.c.XeWYsvwsda%Oj7Mt4H7mh̼6FL1S9 RfoC bZ>FA`i*k+}q*_vzUјK8`OCaXȹ}]:Ӈ}'\crz #/M8q$$*fT[ݘUO2os QD\(_6$(.55'eFA $N1DoM6$ EW@Xq-C0d" '74Mcڒv2 8M%ɷ恧n|FɆ]29J^ 8gOYQUA;mk$1-x}!؛OsǾHY@dgw~'Wss;:Dˋ㺁;{J<+G V3\6kc 6c*FAOuM% ~X(Z8朤}r޾YEplM3nnU/Xgaulwmh; ⱸ.C*tp )a[s)I+BjEJOb+ b;ݮ8d:Km?iC:Hټ+.nĹ_)mP7UӚjozY)2hQPZZ,~U̖Ʊ2%!Ԁq7^2LzQ p4/p endstream endobj 373 0 obj <> stream xڵX[w6~SK, HͱDJy%H)EIuu 07:: 9iYlsa9s+e<Μ`i/'ʙqvZ(ܹj ׽OX>^E2r$ (/i[ܻg׆)>/H,\.oanZІQG@odȎ1}!%vXcpW囻.ӌɶˑ@DMWGѠɪkw]k8,h&ۊ8ZQUӨBحڍT#&x%TO&OC1&%?.s & U,Vvh4c۝3f'E/2XNHNVn--Zl3%Bښp.iLZl^3Qݍ˛ n|6;T|7!MuT[)&Ba=(h>6+DeUK[|j >B,4EN{oF gI/v((6"W뜨Kũ&T`<. C4`2Zۂ-B%;ZE|<.ZL!R%E_ }#gLL%ϵ&Lv5Owaz=wá쬪\G;~ԅQgkڏ̂%8L?5%05l5rS G™kR{-H# != iN Ja>cQP̻ /_([xFWҲAn*ǁeU"㠺oy j7}vЗwO﹵*K*;H;0`j΢I6a1NJ Rʼ.K! F:!^=`OMti Օ됛GhOHwP&%=cx~I/4tK=}4Q ڥj]CK6wR4JFPR8 VphbZ5YGal>+DM!6N *$G(vH8_ߺE/dyN'8d:E|HuyTG6T a}"?w^j #+bf ymhX"h>khz |@Ȉbz^GU>"&='ķ;`(V'nÝ F JIShDNOd@7JpHE K>aY^SzG.}Vz)ZqAEKl>5ӧ[hlB6!L};8PAu8HҺ ,kj}?L"tmQ<;?.] endstream endobj 376 0 obj <> stream xڕY[s۸~`_*1mm84I[K;﹁,fw: \?@r|SNwn{(g}凞/1+gs/6+2Wg1ƽ9]Cq2Uٕu.zQJ(AiEe(I24b}C(%aq7`Mr˵M)8ˁp*xQ~Ա[7FS^y:J&"0'ΧQn;V[[4O4Ԩݴ=T+oB4eh{}E/bbWW쑽}s/X: AӠq' ..ۖhђ,~I .):J]UuBfF?+ ~^f!}ّ=Ehܴ)a|`yݒd*+ZoJەl4ãQa s?~[p癜[m7}UcRvY16--T`1R<2 }Gǽ^(D$ %`b (< v%3>"]CjHR;>;F}s6ID{18}Q³HU=$AZ'N7Z(V$YAm"IH-w>_}u^qN fUWKb&PP;ҾEF6!r(R Yc%k'cDJtzj&\gVS!ƚS"旺00`RL.@9wiK^)O1qP.Rcьq)*c%"Kp" &\8WҪǖD /!c;u @݄Ic;D+SO-"݁!WPN*ZhwT@ G-۩M1 PWmyD5_)I!iR)i߽9=ugW0Dbsv7nG.UYEt7#зX$tW)͟Hh'x...q^KD)mTI^Iq49m_#n> stream xYߏ۸~_a}5H!=\H 'K>INn;!%ʑwDRoկ+G2 jwXz[<ە+\C"\*3y_c?&M6'٤VLF r%3Z{IWޝꢣcW}6^[O?tUsG;#d(Ʒk.HncaMڌtk-ݗJ3f pOKXʽd RnV@[h~Ig)fwI 2%-)m!$I[KƗhU@ }u8[OАzj'3k?⯢)5ʞ-70د1CB"w&Wm [\KG-LXͬ %0U⌗9_]È0 9ӳS%ҸB$ 0C2_@wiEHf,J\*L*GeȽ0K`KjP|.l<]pun2E )@swA 1 e|Q!}MIq9ۂwgȤiA_xvOfJ QlCijwϻ/nQZ]k3uDQh sMQ i7hG羺k*0`˻pD,&9Bqqg)Asht~5f99K'Jerv<8.DDFg.CW/!JgKXQ>?T:Ϸ;P2\¹ "j^,˂=1`x|-J1+絨,#yfa䵖fFJ &V#b76 k0K%%}H.stIE/}4~A&AcweVnQW0o;gHv,1*ȕI{s*>Z]fy!N:TwpqYmzmS4q0]}ڗ􂼙 ):N93N ,@sNd^a6ZL.l=#=lFq& F 1w#:KZ8܌e}O%ɔ+L-ByD#j!fOYihm:2ct~)'8&QJDOe9%x(3?CutT=:Eʓ X̘I OA^0)P.a > *c+~L*]wSTwc|[:!8:)u7uT(ĩ[`Cuw  a ̰:n^` Hfz ѫf->L*`!K|0zz^ML}Xuej`;( ɩrLx@{_Dⷍ79kj Fg* Q5% zk}@j' .],w-i }ʌ_#vi']"{b0#]>qF;b@9bS?q4x&Vuw~>at4.FR-ܢ:-ȡΙB:i~ANx҅,XdCgPjl ]-:s?4AٕE?F:'fڮry_0)%U4"k_ q lzO] n5?`HP-F88Yo5\;ibg4~bHYߟD2?by ׫t- endstream endobj 382 0 obj <> stream xڕXmo6_! Wt ؀Æ 0٦cmJr㑲i EчG x gxYD%+yti&˴TEt}s!oY^ʴnI^ƊܝUYl>w붡 LDUT^i^(e[8\(elMW m޸KaF ǶX }ܑ2J\[iLRuOUٷiR{,mTȦ*,ބԩ *K,s/rQ0U JEIM.xfCܙdR0q&:si+gC7ew3 -*m7xmcz2qRTkeIVhiU؛'22nw:0(bno9:)|Ir WU5>.af^\̕H\:/f\O괔> pUbL9 D jh^C 2q(LG/,ji|b, fcRVPد\,A6Mjdg*e\'@I Yi*% ,IYJſwe|:FO!Lr^gp8A*^@譿T LZn˄3ŧjY@L@~C2OnA|n/񷷿`SlZLiSOO_)ί{ǎKeګ.kfDcIpX*fԝN6aqtN?.qhLz*\U&4wfpK`a۲v&Rs.LMJWBlON 4'dqp|dWə/W#\t ŔkfvƋj4v0̯4R6'tgW/<=UZKxL WSLkJfPGQs\&H.Z@)Ŭ ".y2_{@_sʤ#Y~b E9(S6xT!|aS 4]:Q q ͗}i a >yr1UOw8:zGvS鴘97Uw6[nmۧ;5a|xw&R$L;*%n}sޏ~$:uEכ4X +=|tob7Aj$ @KƯvt_4ۈN@h{;+"M~觮kOsGuyX~phi\5-NvnJbHSu8|l+tUA:HN;B|0c ˧~l=WWTQ^HSH_D[*Ӣ6voIQ_Cϒ%By-i1(1ws+U|驱"x ALuO34%bFYRs<;YYv>R㏦'.u\BNc7(L=rX!sZA" lǥHO߼M )l+ 38nCT͊-P(Hm72 endstream endobj 385 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 388 0 obj <> stream xڍn=_CFZjm 87wzm+zEilE}d6"X,MX+~* _է?r?VO84JWAfPa@ $FJ7"u1nngyZ{Q҇%c/EzFY|בa۽*l8l^ n<MnU%O>2L9< ^I,̄{Oz~|,SYEsQPk78ʪEvMxk7NR7FUiyy^48zϰ*USSD/P^}[`is{hfEs >1]zF1|UqiPir[GUSN5ʒ9꫶~ՔzAj:痛W,ї&a$i~LuuՈzQ5hH37cU@Uv{'Ԏ={@m2x||4 V1zhQLntF NS(^1J6܀=!+Vj[_ĉ1Z5a~P?u,T]8p*?P ]Y7 ϽKSR|h"#hb<]y$܄V=A!Wo PdQvA0c{I[Rυ|fֽ H }t㿵B;CχJ $C,@X!))ù|2vtNȩA K~DF@'ǯK"?un73`azu `Hw0Վ2 tCps ʒ`>o#ٳT8B FTkr1y +*x$XC Z3{XI6LUC]ܩ`)6YhMV}fR'Xp%`[ͨoKͤ2iH=hVs6"]6@2=mQ|;F˞&vDpUpWr1Fݺwҥ>m\((897j#$3H(wϑ 1jX RHKkY2oz^4$JXchFXg\^l $ID?]{gZR $[ĚxCU r')CGS&Dzߙu,`̹j, k6P 5Gc`J8p<>s [. Z&U%WB3A3 ׅ<4ַ0qsX'X#F\bjѣcUg}t7Ũy\#FCG%^і\88ZN?bpoo@q`_+Q:.Ӷn a$`[o`B?=㗿r" c02p#}85,8Jtw+#Q)+a/GEw(N&ݓI\̨l4uE:NX| /FM=.H?yq%N_ʣA]w0wtԏͪ 7 q$;~@3gi2݃q@g&CKWb=#.PB,W镬)z ن`aqq鷏h3/2I3`Oź鱖Qn2`gFV.\$IWJ߂S4߿p%:[/=1)4"跖T2pkώ񍂯}ȓ3TR j/+5݉j$}J+N4EN\w'O2D/R/N?n [$ZTA;}%$QjL;>%2r/ 5-R;otJ|Jvf l~!7] S+}X/9@ endstream endobj 391 0 obj <> stream xڽWmo6_oXջ-k֦/ -qZ vI2m)U㑲ECH{3 ss>u\﹩tc4;ŌA2vwtqM=aȦ>š3RwGw<Fn/Lr )FL mT֥Zs"Y+p&[K$u(WɲG,[YIED!y2˫\@ ?gsS$kiHJ˺dMNe9) -ce'PfYU n}fRQtmC1)x\. ̆욦*uٴ=v~~k[!{׉KsS/h Cɍm1=Ұk;4 . xh뫚|mD _sCO>:'^bP#0sCۦ:^[Mv!w/Ac7Qb\I>JQXtiP1RX Ei wvB :ɉ3YN&}Hv/l[ 4ïq#=INTn!ƑOl eݵ\=",.*bԹkgCDXЩԅ"D$qtmkjJg{ lU@:H:^з!5}x=<V~BZb<+PTK>RUTyc[} V2Qb t#A&@-^$/NŲ%VhFSSE{h 0l\va썍x&2> .m+h(i5㊄'єuݜ#|Ju"{ g[s0{mJՋ"><t >;|MIydU4BޕM{vfۿuΗԬ4ZI͡8ShҾ.'44׭d{%GlUh<?r( ppFpi@ g]փe3%D2)|fQ.i!h9y^[UEڻjۋN-//T]Q3ȋ.m1#vg"ǂ$ۜ]a*y]qյ(cT[+=|W/Al(uerqAHv v.Ggo:?{3=*0tՃ&|A>z{ox~5|@0r`948Ozd*ڞ{7O_})E 3˫t%hc>g7ϯSmxƟO? endstream endobj 394 0 obj <> stream xڅVmo6_oZ%Zm[l1XL(, IAt7;2(G7H&q2ڴʲ8HfqѦKȴX4e$8+K%WTeurWkuU蟬Uf0+ kGǖa`v6,!zw6G`q{\SSHujh]*7qXnU4^)4Bi*YpH]9;rwr¬~fL$Y1MB{ uruvÁ 8NTeّJˉE)#{>EBXv@e #ل)G_Ce9$8qTֺ¾TL|ҁ_uކ0W"8b/g_m/9Wuaqp0,wL ?+@TkZ;pWBrg-Z=H4B4CW8ِwKPj,i{0L`kШ\:5$^9PN_Q P Y*y^ewgGx`W7÷ǂ^Dmaxv`ěY,X$e^4J,\^i|goqˊuH(9PkNP-zT 5w^읪VL㹘a[\__'{# >i7hPcXRhdCa/BPN>Efl="au+3uNJ!wc^XWI8 mnplO> stream xS(T0T0BCs# 2PHU4g endstream endobj 400 0 obj <> stream xXYs~ϯ`V@7Gnt8}C eX/oݤ*s5zzO3oŸ7ny7[mgg$:6-O%Oқy@#Hm8Vs;uZYnGuf]OYE-F1ll;:y[mƏ>G$ _D\+!ԣ3%'Bwo I0}hڪb8JuS'Cӆ "0W*̃J?wחbumkuwse__wym0U>sZ :Vg<:mk&xd9Jl `ǃ`pe6E<=(,ver0~3ݾ0Ooz[LzDҐ?APmHYtRJӂ9< 2ݘ QjlZI{pH?4o{}iON]^ܝ-'SNn.c#/ިM >"y,Pc~r{Ɋun3>}U/d M5WiXeLAkذzjӑRGJAo<#N 4f@ƙ-Tfvj)A֤bNix}}26S£ 41pNj6޷^v -?=ddȏsA-C{ൔRt āv˶ٷ̈́-QC*Lyp09{q?sjXY =0x\ .m} b܀m(ڵ`xt>H RXL>/]vuui[QguS (U1cKd[nYnJfs@mocLe#^Dlzb#E8?2tc_#YsޘPiYXucvX+c!Я`8$#-N|a5!|IA/!!RKdCSJxkD]O)5@Yœp֍(B18|J{aS@w+t@nLv-kuA"P4eКGl}1ZD!ˏ5슐Xְ&q9ZNУ~>f AEA 0Jro#{;@ 颤`TS!`gU[BEQRpH+d{I4ƧTS`) ^D,O:\||BdK]W%S5 əXa8tK#r glN:bg/rG"5|__(HC| ׎QHHH^~}Tqk@DP QtǗ~R7jc둧ETn7%;?⽁7c9.`{Y9*FGQ@ U85(0P=,?LZq>}lǁJ^$n8 wC ,yZU[RFT%@pH L>?7e}±A2wӁuAz I>{*) =1/?+ 5 endstream endobj 403 0 obj <> stream xڭXKsFWr1୪=8pK,FPD  f>A){_Ӱ#',6Ώskσ\8#2G~e|a0y s'y ި/ Cw^ty/S:^$ ݾZtE]=ס#DZĭ0RA.7~z:z]]Χ{3N o~p&F/.&b}7'qg}qy:Ut7ċB*nY+kTY2wny~zSOq5KsAZit5KT9Ój5KnpWosz0Ef~{ޫͶ =z-J\\My+8f,c3![_la~>뫥^oIǺ9uލ.T[*kD1eEW7ͱU'i7q5w~w"?D(<1OdlFUsr@`x"(IfpM[bI+5&xȗQh,MJm.A|o0g:CBaT[8j È\(qq >h.XWkJS^ ! ,A0G_6}kj B9 XIsi9'aEÊ>Q+(HR+Z30&E6hj=TOTeȘ2Ȕ zMPsc!b4OE /KΉqݵ#~*gK>zQ,mWllƻ ݎQZTp/<%,PZE+^-QB=KM}ggG/F+FiÑ^^* Ţf06uٲ% Qa[L5JO tys޷Zp []ԩ`USo(BpȇG$W"Є ̶XJC/F@dQr#䢈;*8_FW`9?Ot57ʳэ`m^ډȍn,~qT}d5}G;JJRE_NJ̒ 7-ݺfXHm 0iä(,.P"LxZŋu*GոnIIEyءWl$01v_"4<2L`PAP1[d\6퐼L^xm-0YtTRGDXZ"M'J-?BM*L.8̢aojG<ոc`?~,ځ;޽^Mf~˓L6mVFPlQapp\% cNx&5?"U\4+P0]\k9/Կټ=˞kJb$kzAC,WWRpz!#("4XgoLHi=U5[K^}(0 ʥiڷw7 endstream endobj 407 0 obj <> stream x-Ok0 :{8[56_u"z@`Ex9 k x@ltO$&+I@qLjfAӑ,rQ STUF;ܩ_Nc>˰*8oM/C:_2Ij+l,OX82sIS(xT˯m@ endstream endobj 410 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 415 0 obj <> stream xYr6+x$Dؑ#۱]S&>P,jcsqY&A"hA@,^7|I fMrI~| 8JɒͧDE0 pb9+74a 0/̌sa1<7]s-ғ}qv/vmxƍ$gq5d9e.c*=rR| \qADž?BEZ#1BD1= 㜜KA@$G--6qu.]3AϚHopCOdl3 vBpu1aB䄖0Yq->urY4EŴ_byF۪dA`Vy(aVb 5}/7⼪/D(d@|bg_*엃^~벫u<@K|;j; 5 ?nƢc <8YOYnꔾf1axH9t_f<8|(` bܱ_ˠλ0k<֯6OEwRk fA,qhez!GqYߘ!9A| O&C&CoYn [h.t =qwS 9hAaAVWpӊ'>dxqF\Y~EhrDOoJFn!=jaCݜde=@n 7S)]S^ a&wU[ݾGDQ{MmAفaS>5V :"*PB5y}aL8+ s<nD8x6sdT _N^l~.i endstream endobj 418 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 422 0 obj <> stream xXKo6W(WnhE)A^ˉ֑;EPu8^؀Z} ϳM=]g?p渃l}! $shŻo20LBsB[W '|[+i0]vm!!poC&Q '2b<}SH9<ɃG0k4|BOj.&L.4g87 ͕oOT}l/◮+=M}}ײVg)w0atLhAdȣ=MdDz+7Ò_ VsXz/gG#6e3P¤ބ~HGkO7S$YDX%,3އ*WU^퇴deH1I.߳kVi,#$jSۀ v]yxPڴpL#r Z[ ӛ)v\ZևS%QR-jtgB˛2OH> uS]$%W4N5 4mTpMK*ƭ;O9c(K07Qxc|9%ѯ\Cդq0:}%LCk-L{/B1a(]@Q7zmBzjg+w*JU> stream xX]o0}W1yk;mN*@ !YHiRҴlznꤣ]Z HUmv{Ϲ N0 'ՀsZf nZi`9H",Pe5\w-H *ss kDR˳@k<[A? *W$*kqkOWtsNqkIkF\Ja)68] 4K<Ww:f,L~84$UBaQf Un}a J|֝F P@(H̓n<ϒn~p=cF3VārR$dH{xW\c.J^(H}s[2 ub/:3w=kz:EU^wwZ\,{HmoꪘC-4p{Ri7I[hB Yht{`/r Y`bjTWjfW i<6 sΆ.˒- qR ſmH"8lg+Q㣙>Bp!1nyl_ILjMG0 `7-yݹd4XgPnˠ| Y檘L̕{?yNcy@v{۱Mp EQAPc9x:"2|zNqeb,hKzDI>S>CI6pm'I z:^zzm ho@޿f endstream endobj 7 0 obj <> stream x\Mo6W,g8@CSz ܂(zhR'ڮLvtH4_oIFw5μ*,kfcz ʹ> GFx T G%Ā*A"+8wM:!rlSAwI#?,PE(T `qJjQ|Q$s0P2D͌Q8sM gvޣdD),6ƚAPlzDvNPX]Օյ2}J!y>H Fy`-5C^苞*Wa-kܝօYxy5?6ʷ7?}6.޼._ߏ97~68َ+ɸ"io Y'm,Ο^3f5f sq[[YìaV9XϽڛa5?|>^ <3סtE4<ӗEe= Uz\ÜyVNX'Qxzs=9c(+ossy^QxV:_5< oos<9"uiO.ON1~&*Ɉb|͆&S9.ӗ.ЯͻܼU}=k ǔ7_/x\otz?6~:X&K~mT~!B$tۗ:z]NҷXʞcLi5u1;5yR m}]C;cc#}΅6kC?̗I~Yx@[yv$t\{RP[z%AʶoQ;K~9s:bmǵoKB&!5ĭznmx {soK/u}?2Junm~ՖڧRoAGظviۍ˶׌9S8Ծ-HEfg~7_jO>O66s؍ЁD9 qe~ٹ6.ߺEdvwlOvlك;b[o厷hiw˻МDeoAjӆ77t뜶do3R0`L9i~ HZ endstream endobj 513 0 obj <> stream x]Qn0+تxd!%N8$JR5GbːC^xq$M w; 'h;XU'\8+ܭĽmpwg1?أ fyMjhp4B[329߻EpZ][\IDpnYYxLdY 2(>+!)7uxCxN,,,O@y|HCjWk]r|TJvf0/H endstream endobj 515 0 obj <> stream xڕX XWDĵ"dW17wA@VAٷ ڈ(4&hbb\f5fL$)r|Vc&Ly}@ug?1&&L&p޺qSz]z3w3I$/T|_ 85yOF&=SÑLƅGvv;GzYl=k|i֯ͷ^==+=~+,-7gΌ:#(Ӭ#||{z{yZ;Yqz?Ǡa^!A^! nbn|+[0L3dF1yX2VXf3Ld&1df 3~{&cf0o0s{f>qd2'f9Y83k Yl`62ƕlcܘyc02VB9hj2y\ӦsLkoمl672lY!gW24ǂnam8h呻F?J9*s8e/ޗ4c,AL3yO{ō| ˢ)r "Ca:Q_S|~L%CU7N*B9TW N3.c24>Jrk ?/x߲sI}}`!vzYa4xDbI)S`,j1@_v~QRu0΂2ˡ>*v7a ب\DDp\(pT4C[1>Ux~Jǡ+T>_N*U?V y$^FZ :.Qq hn/(xġĒNY5m!etm6;zH5Dry֘S'Q&8FxGl inzZk=gna8o{8=YMMKDIL滼cKEq3[[> SRvyݧRh"4)TH` ƈ !+2U!:EzZ"=PMc:%21'ps?iȜ oLBJK}Ii@^wփ[D].;$m-r@+hj0X]>וi_|iCpF}ה-ACjdȣ7'}T^ykɏR+CRA0]pL_vqc@ )8 F)7!VE~uX a]ݏa$[X0&e5̤l@35s[d]H:Wù+0mUhsfg|E M!ςm ?33 pz\9xz /ޒCEcNܓmDF."7<N#lD{eopd>"7y빮;WZ#QxK V 8nRϜRGoc8 jb'wVxQmFY4pM~ܵwW{0"5|ͅVxs(6pGpeP>=6'@ {eEZvwB#e!PHR]FceNޅ/Yb3R4zPEMc=i1%}wXaڵW'g=6*ѕ?R>#Cq|uh"s|c`9l]H+d sUZupK),C#򾸾9|9n8r1X2L {N&QNȢ'iqx2[fJ}t%fPx国9g&P:g*@WI-xBz9GR/r>іz4F\1؃S{pĖZm@x lٱ|, }4z,:+ɵԩXA9L@P\nţVsW,s*`)p:WkUbiOԜ6>S-Tp-}!x6lأաNt݇sҜ죬]Kt,I5U؈8NjIJuX$đx]_0(Bf1B ,Ch8wq=O~hO/@Ty,lj{?4 <)RZ,6QÀ$B @j5RӞ}f`D ϡ9ҀiEN-/`5TI> %M{mBkk/4I5a-U?6ΘDCu8kZ)V6yQfksoNjJ Zx(/q"thD#4/Kcst脦kPΉ,V??W VŐs$Yj%jShl|jw6b3e!9chhjT ѳbBw1ZM>XUBFRBV{,T{Av Fӣ26E\\ٯc7kr%}>D$RD7Z ?h'W}t$m굪n U;OsI`;oQ }O0RlFQQ1I+Mk;.qMrH{)^T v98 1|)/?>w4#AAqBZh5[ÃMԕx0tzڔd06QIh6efY@Q4Ǟ}?c-O\G{ȘpДWiJtaK 3JHTM|jeH֓Sh2-EdJX޴p疚aѵAʩ"&l ʺ9 i!5Be0B&h9ٹUU}NsO=SߝYeo:etd2IA( FY8ߐ*-h/pKj7XeMISAK{?/#?-,7q1#)8? bK,Aҙ2Re}C >>OϹ\AvF5l9ÖĽ߇q~g !tk)"ȁ28ȥ<:`xN~Nfu,-j;&EypbDjI+ -CeǤZ5AKyjfl,B`񖸜Γ&/OS)QsFDU?\@̒"j˚(It8?x=\N\jR8ILOxH냃XFx xL&6Nwkq V'+FIMν`UYs~fl"N(eɫI8L.I2hHWb]NT؉5x.Z)C{I=E S'HO&x5tpQ(-oНQ-E]Ij ^VOu?Ȁ*%%޺!=N #;SO?+.$%?5)znt rAYkkў,k*i8^nM̵[9 |$ 1@D"==4꨸n^ͻu!yn`6eػ YʌiŞ-pH?>;s>wv9 č~5z:z|*hWpW5q &¶8 }`5:ZeuDYBTqxa@G/eC}rՆWoj,%+huQgP]swgqc@F?ަP`to]򾯩=; 9ww WTF} Ž?*yD~?Yf }|l)}"'8 cB$?XU/nR&Ni 2wXKqֺN)TXiOQ)ɩAE{2(r)@^RX>:YO; ('T=+ae<:(-:Vby=<ȣh g#z4flY6r߇2吱LΒN?F6f!5pa4C[-!&e=qBcfkMY;an]!toaW+/F ;,g Wv5R %NE-t%P 7pӾſ z$> stream x]Mo@=4 TԄ(ֈ&`IʲYzxe>^f2/U71hQNIp3XNyAd'gZ8~l \1R̫8A_v`I1lq2wʡԾө+[\)M_AM{idI F] 0p(RnCM+~j%a`#9ˡ9xc9]L2#=C&}zI_[^#9y?Z#̊ (lI!֍v$$u_ԞTp}퉛1vnnc8N7Ѓ,wN endstream endobj 518 0 obj <> stream xڭzX0ND3%n,`)RW鰔e˻^-H [xcnb4<$;}כ>ayXPݻS}XaݢQ?N81_(,?Ђω@QȑzW8|G8~HcLhzܸcƍ0? "hgpM2v¸qlmsq]Bwa;|gHHc85bmضOnnA\m~f۩<߀ nA~DWq/ѠΤfsN)/gыFQ)KJLCzR>՗zGYS?RRQRʆz@ 8ʖD PCapj5E>Pcqxj5DM>PSitSjE͡Rj!ZL-R˨ j%ZMQk:j=Hm6SFYu[lGg݋,cnJaF1Ƕ{Ykaޫ{鳸e}=N~ Z'YK~g~޺lt/}>A>\>G&UN4|PƠ6t=C|  piFXqmnԬQߌ>zռʊfҌR 3n5Pf1;IqʈXbB * e;츕薬kK f4fcJ3|~h9,|Z!t@{^$=2t ިݧlMvz:^ksY|p-0:R U$b!LV|[>}hMXvAt7=v {]x4H5jn)~t$W 񆐭j?D1^ť״{m`k T!/!ՍRrU R睷 vCiaf1{/pP ʨxBc~5pk_Յ]?UI67VDD961AcF?x+ WuB0AhNTQ2c>`}j >Fnl#ooYP5vlFks& Bcʂʪ8+^JAϭkQP }bOq , i$uwҼe@ *&)U}{ԓCn$J&4 0XiwȆE!b0!Z=%-:#ÓėQVρL9X|:>"+Z8&Š!_<.x%-:'C3qF<3!+}>*:"E+~l+;7$ڕ̈TWT"IZ}%BE4z`Xyьxj{2EIr{QEIE^Y;&dܜH(AM~|;V&0,]ߥ= i-4/`Aȝ;[cqr-0}'dfgDF76Z9Vt(jnϦetI ̅aiM[x|o`fϟ{>Mx]yo{{h5h5ҎOdPȳ,Хdd3&~ 8MG~[ru`L^Ư E I_y{#YQ`FF;O&tRԾ aU3z9ZXsox1|6Pz)58pNW7aHÖXLwj=x~b[LjfTSw9X<}Rp )kݵؿ~}˓ ?&TI|3y_+^%/  ĂtF} hN4Ers@z&]WϏ_K6nqXS`f6%]foE6oAz.Q5r;k R!#~~Ox;ֱ]*Ri$6~sꖃDp!+wO yKTg=.ڥRUzU02VfDfAgHv83%rlrQ\EӤhe~lVl<.\B;w1jP%<%0 Z,Ų $!rh<2:7> ;'XĩN=]IZM hPtU? B+Yd"B+ch,n=5Z_O/!ɛ++yc@s49VY %K%jl-" gJ [~V +`n1 g§Yٻ;?15gS/ YWXiY~q8 g2^3MP g"glXBR&zj_>`Mb'kϖ.[t"C^mLG>y6ԑMWe7Ȅm.g~5[|KhN6H< –sN;ºrO.Q=Mׇsoi2t5%`Fŕhe871>:)q1vjZy1hh)Iu O%B3Zűo >&Uf=Dsgri2t ԫ}7oSi5$H$i tP_kX8\(s =%0{8{Y {pD8\[vyHI}3Lwh|GܬoCf42E%F*e/hwf~G;maQi1m(O ڤ`Po妩Rdj*,aS"p-%z59Cb # 1K>%-UhӖw+ld$/V;nPqFTViL2Hґ$#H"ԙ\z^q]z]Il;d(kQ1.Sm,l<*`$/1 O'wJ&Ec!o̠^" |O(#(b.f J1u {᭖& TnNze%PQ3Ex< C޽'kKSJn>oGQ!`nT;!oaT+w@!-Ο^?ծWx2hmݟptܰspshώk2E2&pfГEϐO^ǭ%$*ki3̙E}gV/l|~y'sp}]߿Qܰ>rKGα4e ku;U(E$ D Ȉo&pk`SVg~AF_AsK13-s*P4Tܙ[GR!;elan9묰ev|p'Í_~Ax%q9IozwWSuH%jӵٺt2!ap&SǢy z>͜ױ鎿wxR1Z_|u FqH~xPR-1Kx/\4Pb8c-$,` VFEDD,:`H*rr!ф'/ɍ6~8GYwQ&`FETo9>`klӘð%k}[N`~{;ų x"ތW"B68~:< &+ H" e1ƣ A4wÊI{Bkl^"@qE0VB"$:~뼬G冓rA@JF3`Q>Gn_&ӣEr vI%zR.]M]#0ArYZ^h!v@c[عkW@LF>E%[o 1F5]G}L]ߍEVC}n)X$>,>{.0^r|ėtrYG-yFz,.؇(F6w]]Ģf9Z*G+G-c_?m̪=S޻GO,vA 4$CLrr&>-o؁Ze$I_q$3t1#Kd(.t9%=H7^A?;)`n0[ /y,kѯLzeP7184D4ϖز;z,> gC[Z9fzG> @0hɄF&x}%䂸e  ?#qf2]a'2* Oƣ$q{X1+`cPˎ|bnK3]Bט-?`;v\++4tA=/z4ɐs+SFqQKѽh$ 0GD[B d?t'w<$Slnh iAx\1%k0&'AS }W/w-%pw,I_7աVۍ'xY{x8 3'2IyR\;iF;̝`^}+3=Us3$ P,+ބys g Gm8VX?^;"*+7/3@a`g[3TV|Vo7[4h- gn[)`!xcr b[qG}QA:_I7)Gy"/Ib荦P~ 9Zjmt0Ӻrw@O\Y[]g]%HlbKm+"h&U@.@1O) T "{ ^?ƓVc8-ADGv~GrG\Ǚ0eH,Gz|{*Ba,fQoD]}2_D 60h=` O{zք*h k~8,.k y@ EW?D' fAf> >N[eU3hl-[I܆ĽU%d0:gbYM(_r@HZ™.*)70OMkde @h\bCЎ$CBCFF:7w i?y6DxCC)Y*0suWOecهeX|ނg sU&!Q-Pm"X.n_*\x2 ceU'h=#MIly{EqzSb2?Hyiu /eq|p_]Ч`S Pޑ 2'FZ[yxєd0ָo xPTT^^p~0;u݁UU5D21!t$$eեgV=dvU{\uIצ`槕9 &qeDcڧHC Ck((rR(A! v \}ɓ]Cr⤼l]0|<<&*ffExOG&eeCAvpA! M :O!=4<7<^g }٢}݂5TT}#W-l[zpd? :)g`oS>& Meѣmsش _\G҄ 7K!Fb,*.F}X--}o36:h6#b#9Ҳ^X$?"=.`VTmvA/3`oկ^k-8GYpSz("PhpǢ)ZqpJSUX&(PXYX2_I;++T\jߘ%q&Be&6&Qg czKv1e[$C;@Y,e8> {vjT;jyfP'ͪ U{J;kCDHP O#:-As֕Q™GQ*F0i* YT#6ڇdfdD4ڃDYdh:sxR@=cu})0Fu?s籈ܿۿhp]'qޠ tB㭥hJ+.I~ ; ʠB[o)l6 !S;:(1.߅̸FfU10Ξ$EBEFLCWU^ZWJQչYO&1 ̒ʹ=6: <I;>nN{Y^.uCU$iSw(>~ lحgo0y#d]`tƓvn߳/Ӷ*;|Jܑӧ׮p uxM5hfB/*+"#SxIڂ<3s  +T5Q=+뒱X(dkJ}BJSI )ǰG>s_mϖ!shaKBY&/I O1ASa \œlg|YW8XUj"}>2Gnf@ _R&2ot;_xῗ YJVn=P*~?B Q[hebȇŃh fwH WZ&#xgߒ\B,Fc됗yo+cG-wN҄A _m,2T9qKscQ1OkMAQ)drEXZc6x䦀\MJ+("눘{4%zz߾! UvًrSW|C uGI뢳vd|cTʭr+D"ܩ T|C<̀hⷳ}>bbCв f%zWѸsNsGs|Ba*?i4ı!{3q,'m^8wr_nrTdx$=ơќ$쮬^!}B? b3K w_OE)Mv!s jR!ΐF _:$E+,?)\4-F %0.qE;lAsn . sЅ k P'ǎÙFLE#4?u_(PgŦ*}'dhdHW;uSvڃFwij>QM+> )rM.;}j,rx58ze}ցj_°bKQɊ33MW g:Wkw}v-h5V<¬cki,יU-2!kCId2V~ä(IBBtGtƊFMu#]HUgap6CKoSx{] ެ)$e6^NkX,u A.m#_yt4찐&x)bC/X B/2d)/ uh8ȝeG1L|E $}C63[p>OdӞ7cXk:$`$ĤUuBW☀{nwČ0J4 R+QkPV/;ONENy/;([shsϳ{5>л) endstream endobj 519 0 obj <> stream x]QMk0WqK)&)uwA֭azdB!|=0c%ʊSw3gh{% NbB] {1oPkeZ_!z}v*FUbJjũ\B#$ >4vrlaoFUkVz\ ca&1Jt-ԪCPB)A%hZ]erʎ)Ibm?f͙#8)8^Aqr1v!m+}S z endstream endobj 521 0 obj <> stream xڍz\Er.TS~pjj[[pԁ[AQd#aF#"֭8qmVVm}0[W<^{3emMD"..7`Io`Ra(%  %pVQr9RvHĄ)`Ҥ'M 0(B%s|kێg`If8zol9!p|kL4wrm!ߞ(y9yp\ s\ñ艝<wxH[(eEYS6M)MR-5H ( R!=@I Q8j$5MRoQoSj".5LMRQӨ j&!5M͡Rj!ZL}L}B9Qj)ZN}JVRՔ ZKS&j3r(^8m:dlN~6kll|M[FFf0{\/9ܷ_M}o[lgf; b 50qAC=˰/Vɱ7\Yv`~/ &C;pwݛC >氉ô ׏\9su9|#qxddFIG F0{L؁cl]0\/B^Oe=Lnvk@zvھӚ˚ӚgӞo]ZXZSSVV٢Q .G!b FVY1h?a 4 sЋVB/^;%h1t!g6*R1 ~kMxW#_xFQx(4p^_lF?w,2n8oqm5۝{o7\e@GP-yAWX]7/e(+ĮZ2 mFn635!:ygXf8 uPY#?h f$u J9,^ьLVmokkO.$.J?Fqb+z!ZLY~Uk 8vl_k.c;hEhdg%,x9M˄,Ds!ZdJD&8<}{c v7iMop-dc«*/ rs {kG˦+~c{켳w6ֈ`ƤmۂU4[OUB]}D )UZ3-hmp k\r5kaiB%*uxHla]w7-?0~ylW0U|[xt#FJ/EXI)fUUN$ 9fJ} ee;2u!;z&+qXñ'[tZ>C^]n'!zgODpH^VeA& O!xw rd O"cq^V1p#7su0Ul{=&+gs[B&xP%fXT3݉yTG8Ј([/-V{Q* *RO>92O,[[szWb7H@:ZI3LL|o8#f;ٶք&ɿQz[{ůVeOb/K kJ #3;a Nɟwwp$;LffvVV1"dYq?+ÙcԊfN}mLV-DsvCqlf2I&D^U5{GMr8Y ~!zjIu.՝Ax? ;FVUiuM~#Y* ǿ}yӜV- 6&,iQKq^|uZ.5w|B%iiPȘHBmp5~Rc&*'cTl9֭ͭZ6Əp3e >5UG6|L*jnؒ0h*M ,Nwj1]٥;3ZQ i]E {b +ԂK% l$EI4[NNߟH|<*\BX^哿@VA2$gDADmqS-d2<|j s5G>g~<Ƅ}u$̹x>O%d%( qu]7XL VBx7FU)lѯ'غϗ  Fmv@,O H|{f;0@^̖™iQu4AAJ ./kWүΐ;Ghzox,n? _Ȧ;`^`+(Ԉ܌vMhiIc#oYL;bKQ("vPV=Αy ҝksI\{oZayպ?g&4 A5,FvafAKw+}zaf jD&TE(e `+ʡ.<-^t ޸y-03琂[|#\0;ɱ oEHC^餾Y8P/gBAѫ:3!/n EZi1!{!׿_}5lT+=FDpԲ߮]UIď{H{wb%EjWbQ戚ëmh1c-!, Ba8ο&j70+>`8ij&A32"dǗ ʼ.kw2*qY5j&;9Ǭۺb3WoN9.Q%y潸:"9 QA̵m<\<S/(Ftfɶ|F8pUw~yIno""仒LX͝>q. >|+Cr؂zӄb͌SnZOuf{]xw< l nDPtgFw>bF~6>6|NV5ܘo'87=$`\bj241d}DtQ'@nգh7Cu@KF6\FtO!.45q3ޜ"dKO{ެN证^C_kgzU@>8rYQt>FCgU l^ B߰l,M>ʡ_Fcl]9rádjلZsZY/ ɶDe Ϻ^_<1M38TYL.mtɼ(E\fw(skj3OG)Rs.RμOa汇aoN7I?}ٟL$N[-ivsȩǴ2Hzlrn."2$t3#ˀJxNM2T;r8bU&5Oqikh"B{lLV0f!m )$Vpgh0>ʡ"!]|FLc;{Kp#(0OƢVގrqYVDH&ʛI-׾9kzJ" !cM;*0 6#l|b;cچ$aBz/05հ 2'.u47DUpEPilFV)0}uo!/9`<3NYGX@L9lGgydxh `2"Q5Ih`"NoQH۵h$o ,z3S~K5ۏϟ;uƹ_#Σ&FjؚH N(O<\X  x*+0jWP3ϕ6̴sq|}utֶ, 0S[Cdf2/Ȏ{%9 Linsз`]Hf#gqwx8n=v҅" -{Ta YwzEw;d 8›]5G"lp+cQbUg̘|+ooĽJ zDŽߓFR¡?4!:y%0ej}́zXᲔ|p/Kƭ3{@a;`w͈b~FSt,C. 8>c澃B`MdZd}1u *e3HNlU p[>j| PLO&MO&?yf,B9ΡǛBs?M9nEB0PÅޖXobiS;^A]Q P 吷,n@L(*b-R*"x,#B:F)Lo'ltJUS Xc.EN:t¦sS\F~/ Yb8c}Maz@p 8 UDՂ,"Rf_=*7fSlQl|zw/?mxM`"^c;[/;"̂4ސX:%=sPOeF@*hiJMf60%ҠȈm7sO0H ~u]:QNbIU(M/0:";u0.ZĜ(%\fVJW:*a_zvihڊzs=,,N L'(<<Ԥ1I!\JDikD{Z[!slw.^pbQ\,$%'&G)Ic$DG QH" "b.YںBȅh}nr J> stream x]Pj sRJLK$l~I*4*&uf|dUsi}y+9Q';{ PZK#Y )FqnkrӷǽΏ !{\2[`d߫+ pxT> stream xcd`aa`ddqrv 64U4L?200Ac $X9j *23J45 --u ,sS2|K2RsKԒJ +}rbt;M̒ ԢT s~nAiIjo~JjQY \ ̌,?:~H[+x>㭛l͟Тwߒ9NE-]}9|5k8f|Ots'v~m+@-UKFoc](ߜI~sgeq.0{ ~'Mgb19M}<<7~(c endstream endobj 525 0 obj <> stream x]n0E /[UH)!BB*}{H Y;c'Yts}ǑvgQ604~SYszro9Eݚv_UTK>e :\4PnY8>4 بY'p(4gc~a=ky&9*L+, Üge3߷W;Z C SqQ/1NNH^E4%+1km kKI;b""NxVd7 &c `)Q *7$fْ8S?Ht?"Zan;^0*ƾ endstream endobj 527 0 obj <> stream xڵywxTպl6A *E AiB!! Id3 :HQ zRT8cY;|ܣϽLLZo"jPJ$ڼi.^rNgVa믨O O r0aVsZ)JT'ghID>&DLN!<>+$d̄cgy y:xQJ\fBltjh宸h%#98"-6!N<}.2}ٹSfe|nc ]2sv/IKUN P}i)ʸUi;2SFLM?FͧZHo~~PQo`3 r+4Ns:~J頾tEܢ+}zЋdEԃ۝ MfځT NKjmf ΟxRލ􀂈fA0,B9%6NZ[;/EWavBRS^L"BO @syvY2_ l +sQ\nT] o?PdA?W (TIܰ"Dbƙa94;{pA'gcM{[kӈ90q]{vE,%%.@[a7M nz ka %E[s!2$&9V)0i1}7I:憥{ZadU$g!ߢ4rwPgb+%٫ne/oTyVLК6nxvDvw:`ulU)'j(;8]N7%m[7:X"ќ5 n'i-}k}H45+6Cd~|?TZ(D%N n Lz) h;nFkt //ZuQ=&2M~6Oh"FaJ?GO|gfMmlZI2-ڑ-4ڕe y_篿y34ځc 4<pAث-G"ɚCo+m>^և d+ãVQ@1 )91-%%&!_?7%~TGOJ&/Zj4h⧟j8ukPLP$^a[ٷD,-9[ɤ+goIwe,Gou˶>]k; RtA@ׂYrNg.L}9x;@jԬ)[f0!9? ٤Sg{f¥yp̲f3Yv*NG*#띑s!u&Ð 'ko\xLf_jk)^\f:&`rTz&sgnj X:NZ^f%.O=q[f=/1&WA;p2lгZNxGj2SycTh0F^Tbo] lLxٳb/00iy04$\缨k)q_*'/ڲ!.z5FRBiLѴy}gh`s$H?SwK B0^Mk"0u0Qm p;! 4ȁc!aY)]e(׾k103񨳈 WȷH0oNa|ir5I ze4wˑx;~HǠgå{NgwƖ`0b]uq_?ɘJ#1 KjZ* vgC̎agk-y^Vn{ IN}w7EN qKm'YKRuC$GdUR 2p]觾 #h#r/o{B+!Bi+g+^Hg Jr;g~(;G-Usذ 5CHM\kBԮkFtsgˠx+:w{-lbjKrCr@ %g$TbsD얾E d|+kfHR< !8'?JAaD/OL[pDD3/ wvg? X'{䙘%)=NyIH0~ ?5Jw6scyIއ=r'bl:cJCO.\kSi79ud6fu񦄄`?V@M MyͻY.fzT2MVjBM>KDQd8I@H). V@h-\'Cǣ#mo1\ι#}'öTe!=e/Y#VpxWّR_HeOƠ p'⎤$TǕIs퉥zKbUn8|rkH|IrPqUȭ`d'D%ܣ/D,0uD=i Hg}u80hv>4\k7Yx0q$f͖C #pe$nq>$WM}Ub!^/AϢWjݽG;h61v+N1eszk&ijB#4!1N_ ePV{'IӼvwђ15;PM@f))L2t^u*]Frtx\ء&dP mzZc*z : ;|ă bM2f.%SJGg#㥯xUYM-Yt9otl}YٷQrif1}SpL~^pU1KjȼCk%r%@cSqYYTٞԶ4&%a h?IhinBl n&`\JޔN8{+3ab6 o;ZZ<^(j˜+QB\} ƽC<2&"@ۿVoWrMQ9LeQDEAL#ZwFyQTuu7:uN, #[TLWa}еCR4e -\UרtXX jҼW YfxMECHs yʫaGKKgF]6mP$Aغdٽ#a 2.U۵3/$$S@cer 3֗!tͤl v0P|eIظ:7gзki?eii>vfhuXCCCcǏvtϝUlvmJ)pN $AQ?2%Ɣ o{Wu|c9#M2+ NioRDB 1~S$!qG %"%"r2Sl2Nv|!᠀)|MZٽi[ʮ5[ː9KCk';Ge:E]R'pTUzGſ'kl]6fDX`â ѿ/_1qgreTk sr 93`v'N6 OS&D$VZ;55 wځX 8%tDN ?M "R6P$CҤq9K旡@DC'_`%Byo1zo<#"!+reh<+ !zG3 bc?wX)k/Oc!lғlwrUrͳn\3?)" a_aE?xj|/@\(>IZ?8OŁW|N QVUf[N]LdE9,Y_HF% ~szTUHt =ЭkbD7%? UuߺIV/ɇ\&Y_Lo!-6|՗%M$ ^8wH芍Z< H4pd}"XeJ,s`7eW-O@ӦYʤPCV LK ;MӝzX~|,uab!RxX*Zɔ!Oߧt nC`*);4eZCj9όAFAaq-J-wxhS1;HOi`|}H endstream endobj 528 0 obj <> stream x]n0~=* UH#!BmG;TeF9uWE3gh{% Nb^0ًyݹU fA~l[3 }~Bp>a [tѺ:8T!I@El9wV{7M:؜)/f,M]\?I'4%ePqiOcXts*ątL%'T.{Me#k>ͺ8:|1 {!"+x O߆/ch,lz[ԣ.Ml endstream endobj 530 0 obj <> stream xڭVyTSg!@@my}-j]@Zk,AY%$U`$BQEA֥ElRqأc~yA[۞9gΜ3|$;~<֖xN^~7oy;NJlgɣ}v}Ǿd2|%-ɝӭs!w8~aQK<kBuȹ;f[ i /|~vb:(D㥐[Îinb7)yT_ H}_+27/+ZIT4-PʜƾpB w' 3ln FM-C>oOO³4;{2ГqHk:P\{Fa<0xý 7P+樠ZXW PMWlʐD+@6ȵ]u"bB[n! h}Tvy# ?#,rdܐ77;Z<* 6/1* {k{]jquly$yArcUAEfv׋\G}*PP?7 ,宽؍ljɃmI )99qf7%YpG^rpm#pksMC~ev2`? H,xVI#*$m{}0`Su޶!S^WdFh.h}>I6xdbs9W֫߮@쑇MP,Mqq넰!S.y7u^GKn`[a$DIᧂhFΜԠ,qoeGNt, پS R:pȩreWF*'|6=(yƻ+^[Zu#сO78$z/|t]G7@ETݟ[)-\6W;;ҫ zT̪""J,j @ɡH!<23FC}uڊRYz8r|vU)5IJ8NM|k`nC>~I#PP¹lL74 Z Q(;FN섶 XZ 1 1q3µK3dI$\h`3A_A0m>ŠIEN%JQ|-\*kJ7vVz=XmD؍ZM8I}D"8ĉ-U~i:)l]ov.cS ؏,DY֞6?reVĢt'\m+U:-UPg`4!Dy-yG'vU}o::` endstream endobj 531 0 obj <> stream x]Mk0sR1Z`vYw=dBMB5QCg&FE]jt-:G%-zaT$f G,D1qCOQSsѴ1}]8rugSz YF˺qvW;|/+юjíhC] J<7MBK hdUUNP6۽+W)$+SyN7.=}O~|EXj7Qc CyN endstream endobj 533 0 obj <> stream xE]lKa߷ljC4ӃXHd"DjYY[]U֏ڃ"XT,[B $.$\ԙy{tc\ݲ}V[ZZ3_6{t},M u]b0;jZ9*ZAE:U`\.6j:N67/tr8y}hu*[=ilnyxfr-V{-:V Anf tnZ64X=] >cK.wvn+p{SWkP/yV\t-B5$88kF:T8_k {hK+I8<\BP6UM&0RM@xʭNۙ:2&N%uz#{;.`"&yl}P2ScC;=znO8)U-J-5iF gD6 ޠb9QGh.qK_|bXF[JL_uR&CH@TRe{өmrޘB={ϊE> P'Ô*{,*}~ endstream endobj 534 0 obj <> stream x]Qn0+08R*U!`"crCgǻ٨Z+Df ЏJ\"qr[L\p':[\\:/׶HCJ{es_Vjϐe j;˹'}fTENV$Ͻ\fEsIFiYUBE׋onlf2_i,-48 8x,`f!>Ϧo0WN>9:i K]PwF?|7c~Z¨0=kW/& endstream endobj 536 0 obj <> stream xڭWyTgb0~(M;tu,j㩵ZBVRY#KH __"K -ֶNNG;:3z3wz vs3srd{}y~/ 8[;&~Mxvaq")ngY|%f}d_i&"8~&!-*(,.>ge ֯{6!aCܦ<('$.% 8 ){4GWV2 ((|]V𓁪:DRY>""~B.KC3x\Zbꗖ'iJ :2Rӽ!SȨdaxFZGF9٫9 3+Vaqm7. o pІ.@O|E~-8GC!Z$ Ѣ l6#ґ9z*:›4MJҝJ=x:ڍCSd⬣YIUIMu)/X,V+nVګB僀o76{fgksoRum\wh4i9PZ(Ϲ4E /g *Id0zNk{+j3BƬ5[ n+-DR}aaQeJZLelϜ MUrk* yzEp 5¹El$] @μɓJ$04@f4#dDZfb҃cGXjռધ[#K 9NqO' 0VHɥtXZU^1W>rs b!mԏW MUO9 O>qcߟ)8nzb̶`-hqT6Oy2`vrxۻ_}WI4h:5CG%!uUPj/r,FY7 |;_mI/7ns[l@4"˗c>F$W?o!SMhk ֮EfWStd̨tX!.fW+KN|#-{”Bl:s!;vy#mY4M:#HWСSm$ޚ^{)Z+C@m2r&X4j \N3dPgCԶPDO'k| Q!i $[0D(Z|dOxMus&y =}r^^9 dO};}AjU5Ue WS!t7@6q[<5Äb򀶢Tՠ"{.o 4GjrsnS_Í_6@pֈ6lJ(c%dݚNq0 .b٥ϝކs0> stream x]Mo0 >v&>FHi0q:AiGH C! p/?NldΧh tgi~ t=ӱ.hF'V_٥_ agn@w<ۼXn$!N͋ƦU2pjsRB|)YEtb8lx$qH rSڎ4$I2c˱r9 +hƄ&&k.,+IjXŶND]e]*]T ٛQYf endstream endobj 539 0 obj <> stream xm{LSW聾{z'.Cq$o| @jiiiTl- wEt"e"G4Ee:9ΝgKvk$$7|~wHB($H-߶!5yK\Һԅ9BpSInZ'p5<4"!Iy s4:eV^1C6gdss:e\-['g+rzmd(BYl>wx.dJ},UWdVhzzyB$MNAi2:5%WPydt J$+"Dl& $. !AWq{i‡%oR363Piq1B3J@Ifw\QpB%.(aNfLˋ<p%z?Y]Yg `mAkE e> xxR^eQ\-; ƅdI${,@Q@cC-ɰ{w2T>Ø%ʲKt-=(VG-z1o|E,Gt=BS$$b,vdnj^ Z:{!ù' ؠv^c\;e30JކfZ T= ^R8nUlcP}#!- Jh~)ELGa(lVw,=[2z^ ?>܎'a,\qOZn=!nTnf*$*꼣q? R;tysTzZݪc; /`"pG둇yׯn hچ[A6F(5mmWih[gn_U&Uڸoy$ AX#ɍ‘xtKp>lO߭ۆ>a_O0kR[A{c.Z/0kg"2aj6ZT.%?Ƚ˶Ja_Х:[2h> stream x]n0EY*q !H,F!b)R1EcfrLPTJu'3'h;% l bQ rs͂c#r|-(~^ʈ;./j_? JdΔpVrվDө;Ez{T,]ȷ$nFݑeaCV9C%}K}ĭߍ!gaa,0:["_dbK&IL $Ri酂uLN f pm܆lؗ<7 fch6nOnv@*m{~Wm endstream endobj 542 0 obj <> stream xڵX PT׶mK߫"*߽'5!*`Dq@YGAh޴3t7@3281qFC|jMcLs;/'ׯ_ :k_տ?%hd' 9R̈́)aH[? D'r[xjF4;;{а(>6Ν=n owT_w#zmO_TQQalmcccyDN Xh3:6(*//"zY4;ڔ4)4$,:/%/BJr`N XL9Inq" RèFR(KʊMCS 5JMl);ʁAͤfQ)GʉZB-Q˩JʅrVSQk(7j-rSMЏQJ~}?wdDGZE\=P7<߷h9d!/޺;tЖ+>rxjD[l{v䤑e{;zПb4QMTpS,C_p/N=` , u`RcEG}Bi0xUqH)܄+pW|RyxAh3QꙥnÇ(ŕ! .C \: ,X.2l8`T-[Eȓ`N:r`A^~}cю{b-`%u]nBu^ASA-`fęmmyS}:Kȕ=/%iښȲh.ÔUǐ LDkBa>,G? <$. 䐖{z,ŽWXD A2v>OW8~4Q=C {0EY 2v,G+HzYk#7alQ4n:2J\.*"">[2ҘJEc-NDhVa{ن} lV9л_1Ȕ|*vI,k.t}tIdS{4!"jo XGrcG$aͼpnV^Jg>+ʩnwx>0z^7И;ȣZl ~Fb%}r1nH8x&_*%3S'svH.1E@V4n*jI84j$}CNuxefo\.Q} -@OBPG-1s@E*A@ %IX ch^h;b< W,3 |~'9_Ec >Ie݇εx*Mec饭VNޤ+pGB@^m' vkF/Ti\$Y5$X o 5oTU?@xŴ1DCҹǗ`7>ࢍ[}C\}Vf+ᒉGvᘴƌ> VU}A/* 0#Wv|Py] Stڶ M)kU'I)pf(㷁9){Ҋ@^92XXfސNwp Cm%ѠTaig F^#F1lj2;4U*9{.mttA( ѽ-@V1<1s=p HA3,69ذ}"<cG }^h2r49ccP!R g81#}c5IkЁG?j<}un1O=<'^p:#9aJ]>?eVx 40_Aa /P2WKvVI;8(ߛޝҘR^Z\:(f7;h3# :.OAΈ0X +ɡ9Pgm#ʚUL1VȳwZn>ċO<~<+^oI;Tq$2_2bkNd]S6+U&2yI,Nf٪VAߐ;'gš<}n ,gD汽O%82d_؊졊Y <;^=I6\TҤ_@A<}a"@5/a{FxF?-b)s~9qˆ(,4wo1?q}FzC5=Ì5U\{+} mPbh3^%$Tf TVnK6T,irS*9r27IYFlSJ/iPzO5CW7U2iX&2RԹ+$]MeeMg$G:9tއ[fBfgϠC}4gKcA`gΟ^KE%rn1q6G9@haI!an|J)fRrA)@A?X4|X̯-Aތʝ%WWԴe2^Ç2Ȁ`M- u/U#ݞjQMyOK=2F._Zzt0]sG`̐e2/,L9 J<9z{;0Nhם|JDd*24zp:Fŕ ?! 2-2?蕽YIёۥ TZõfMcGc7Ϣ]% _,L4(Xj?ƃa~ [lu!JFTd0 h1l yxlvcNGq=#&]tm1@hÇ;(Wdd)#RADUTTo^}<} ꮾ?GEiZ~-RiEg?GN#ɢ sw..mgS{2L0IEUUIݙ ,f_/_XQu,{FAN`o'7n A yEe3uIھ%/Y(ϒm ֪z7/\闟>wl+tQPՐLXM1rz]hxtLXHM\McUm59J{0w}g2Y7" f}}om)&$^`DoHջ|nW;$(1([^/+Ij 7ł"`)cd$AqxdBz,K 68UPE Á:ƭ .[[x^GajETAY}:Ub[Y%WҽrEBK.⊆c6`n|jAg,AZ%jdQ& "U +{jX~N%sp""mf_Y/ 'D ͯ|uHWWIm>Jbvy"nhFE4ZUEԀvr&kHc]>^G;I}ãJN|Ρ7rzf9ɡh<Mx .а&38I 6 ZN#M0E&I Sзlau F$U$ApL"l5ڡh"33y<.$%L kUff C姡($5ȇ<=nBQ.F(շQk;otѳ)`qREERS2Vͳ|yNF![A^nU171Z CTK"'TlW6ۙ6 =YUk;kZ[VF3iiŒ_%[߬O_X&SgmTR" `udb;֘~EabY8ތ2 Nݪ4&3ng 4 0?O`㪀oI4t=XhrZT`bZ? M 5 Qx endstream endobj 543 0 obj <> stream x]Pj0+渥R-ujb<5YC30oޛ7Yknt[aQqNڐe8,ɪVw1#dom_y_7usQۖ37@O\tVv}x^ N}%[MJ2o7IpqBfB(-5MIШC1Gxž;5q4=zMOHrm'g]T=mV endstream endobj 545 0 obj <> stream xcd`aa`ddu uv445gi2?d~1g{I |"_ Hu (!QVm``g``_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܮs JKR|SRb:EGoa[tEW_XlӦ}/X;a*|I<\=< p/c endstream endobj 546 0 obj <> stream x]Pj0+渥D =A\-un&!ƃ_zy̼E}@-Qgx IRPZYNZ4} ve~)E {nU :s 8'g8)WǗ 6#H8dY endstream endobj 548 0 obj <> stream xcd`aa`dd uurv44dgi2?d~1g{I |"_ Hu (!QVm``g``_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܮs JKR|SRb:EG_~er@tE⼼⼼+V,^Btif|];q|I<\=<ܫ.s/c endstream endobj 454 0 obj <> stream x\[sG~_Qo ~̀?4Rrw˃w2"Ն݈]YUY[jQ oبFHhcFmQc1WHצ1oF4x yc"{Qp)-( Vb*Ps$*b;n598&zIA9>"-񥡺oph)ḾRYJ 2D;VUD;^F;\=9h|!ipcکF+D])Z< 4 aLe 0Px}G'm ́=8В0ڒ& 4%,.%Si1T<#`2ka [@%-B F1@"@\NBXXh H`4!ڀFh1i1Ӱd e:܇怠 ? IXPvq-*nưU0FVp [ 5[I/#pP`c uA&+[((i 9> u餎~]qxA4ΐjɎ!z[dNn1@(`9207KM$ԡW6&q=9<2y&CD/9,~.ȗQ8l` )PpA>*D1r  ί!*4XA ίi1 ЃGD8AXSAA7S^\&im Y tA'6Db(="< ViJ@$)T ҀX `(y!1O5r9ew){EH"Z2 0 [e @k(sj#I@*FFO[ni: 71S OlAS8 cDK i2 Q@S z0 ]%'zuGx CXoc'\}aVחFbob@nyNh7i!T=OgPȴiǕ*  'Z{RQ8OTSзWntw`}):>f_@Z (j !i~ZgsLݍSz*'fjy[(9YB8{<7.AMR(sFЅp(x~Mb6`P x/- { [X<;)]W9b"ª9 \1]>>_ҩfRŠئM(8l^OP`_ ~\\aQVlӦ i̲/x~\\j)xyɥdɅ|13+/A)Hvn_|uHƴmK(q*iئM)TfZO3!PbǕ*gZUl( *u,bFuFzjg_3ٛPM@~ T TMR()Ubܘ}bg5Pl ze7{q h3ָlũb6PK%.ũ£8U £8UjӦj (Nzzb =*x3 RG5CU;TrC3UVu::z<Ǖ(Nڴ u7p '|X~\  [h(NbfW*_j 8 aዙa\| k):+L58#rcס*ۇfέ:t"TL7WJ J'\U *P<7|RfĨB`Q GBؗBS1ԥNfJIK[MTf:[D \5E"W͛q*3o|c)pJ:KԄrz_=O5i{\>LZTvӜzKG^:˞WgקdzߗWg.>6Y[ݻrupm<+BqZ{F vG,{F?%1})zp̅p{RSH7#xqĻpds lgD>>J' 8J*;/MhχȾ[ h Zvt`mx._sdWt8ҹD'_x&G釞;M8sO#{yDD0\s$G"=vH8=Ñȇ|5axm,]iZ厽${;%2cţAv32d7iVLGB}MqR| O|/ffc>x"s͑͝x$Gycj6SyKYϗQxP6Zc@~,w+]<"~{e"&i}oJqV 7z>=S~i \^ȑZR#TZ7FHdKvش7'?<{:ݜWh@ 'K]EeH494'嶽 /71j W~:K%;g쒭نm5}dߍ>[\ClG `J;4RM|ӗ߀ 'L,neIl90glG6|Gf|wOն={{N溾xۮ7lu~XI,hB%_,ӨzqQ z`팓}˾9sw{~bo׋_mԠ"Ix&_ovS^mzNz }Vڽ<3bc3abd30232a26232ce1529214de261>]/Size 562/W[1 3 2]/Filter/FlateDecode/Length 1443>> stream x5ypNWE,Al&!(Q KFŖEbKH4*E,YD;ƾDNmiө>wΝϛs{Rohkj]+孾a(UW)iG {_?_] QD9PDv=XvKO6U<[ěrL[zIć- /R-T*rHmvT :vP_vT"uxzny"=PID}P?4`Ciʘ!҈-ZR1뺃+4a@dǡ4eˠ4cOBx&Ҝ=H uiɞ*{ Ҋ=uH{dA߷"JߢESVA?K(/N(e5ptrZ8>>-)eK~YAɅo[&%-h3J {G( i|N)E?_E)!Ml]nd]fv kw'{`GK 4{-9м]fR\oϽg:vX?֛al#֟mζbۚm˚]4{[^i>mv"y3̬6R340+3yƚ<5ϣy̺2ψYf 5Ǭ&ne7l!Nx%p"JݿyU"5wK"rK"{^8'SRQ.N[3Eù-s[ 9y< R i[!r?K{-cOٳy"{d/J! ߔ endstream endobj startxref 264137 %%EOF gcl-2.6.14/info/chap-a.texi0000644000175000017500000000731114360276512013754 0ustar cammcamm @node Appendix, , Glossary (Glossary), Top @chapter Appendix @menu * Removed Language Features:: @end menu @node Removed Language Features, , Appendix, Appendix @section Removed Language Features @c including appendix-removed @menu * Requirements for removed and deprecated features:: * Removed Types:: * Removed Operators:: * Removed Argument Conventions:: * Removed Variables:: * Removed Reader Syntax:: * Packages No Longer Required:: @end menu @node Requirements for removed and deprecated features, Removed Types, Removed Language Features, Removed Language Features @subsection Requirements for removed and deprecated features For this standard, some features from the language described in @i{Common Lisp: The Language} have been removed, and others have been deprecated (and will most likely not appear in future @r{Common Lisp} standards). Which features were removed and which were deprecated was decided on a case-by-case basis by the X3J13 committee. @i{Conforming implementations} that wish to retain any removed features for compatibility must assure that such compatibility does not interfere with the correct function of @i{conforming programs}. For example, symbols corresponding to the names of removed functions may not appear in the the @t{COMMON-LISP} @i{package}. (Note, however, that this specification has been devised in such a way that there can be a package named @t{LISP} which can contain such symbols.) @i{Conforming implementations} must implement all deprecated features. For a list of deprecated features, see @ref{Deprecated Language Features}. @node Removed Types, Removed Operators, Requirements for removed and deprecated features, Removed Language Features @subsection Removed Types The @i{type} @t{string-char} @ICindex string-char was removed. @node Removed Operators, Removed Argument Conventions, Removed Types, Removed Language Features @subsection Removed Operators The functions @t{int-char} @ICindex int-char , @t{char-bits} @ICindex char-bits , @t{char-font} @ICindex char-font , @t{make-char} @ICindex make-char , @t{char-bit} @ICindex char-bit , @t{set-char-bit} @ICindex set-char-bit , @t{string-char-p} @ICindex string-char-p , and @t{commonp} @ICindex commonp were removed. The @i{special operator} @t{compiler-let} was removed. @node Removed Argument Conventions, Removed Variables, Removed Operators, Removed Language Features @subsection Removed Argument Conventions The @i{font} argument to @b{digit-char} @IRindex digit-char was removed. The @i{bits} and @i{font} arguments to @b{code-char} @IRindex code-char were removed. @node Removed Variables, Removed Reader Syntax, Removed Argument Conventions, Removed Language Features @subsection Removed Variables The variables @t{char-font-limit} @ICindex char-font-limit , @t{char-bits-limit} @ICindex char-bits-limit , @t{char-control-bit} @ICindex char-control-bit , @t{char-meta-bit} @ICindex char-meta-bit , @t{char-super-bit} @ICindex char-super-bit , @t{char-hyper-bit} @ICindex char-hyper-bit , and @t{*break-on-warnings*} @ICindex *break-on-warnings* were removed. @node Removed Reader Syntax, Packages No Longer Required, Removed Variables, Removed Language Features @subsection Removed Reader Syntax The ``@t{#,}'' @i{reader macro} in @i{standard syntax} was removed. @node Packages No Longer Required, , Removed Reader Syntax, Removed Language Features @subsection Packages No Longer Required The @i{packages} @t{LISP} @IPindex lisp , @t{USER} @IPindex user , and @t{SYSTEM} @IPindex system are no longer required. It is valid for @i{packages} with one or more of these names to be provided by a @i{conforming implementation} as extensions. @c end of including appendix-removed @c %**end of chapter gcl-2.6.14/info/chap-25.texi0000644000175000017500000016164414360276512013774 0ustar cammcamm @node Environment, Glossary (Glossary), System Construction, Top @chapter Environment @menu * The External Environment:: * Environment Dictionary:: @end menu @node The External Environment, Environment Dictionary, Environment, Environment @section The External Environment @c including concept-environment @menu * Top level loop:: * Debugging Utilities:: * Environment Inquiry:: * Time:: @end menu @node Top level loop, Debugging Utilities, The External Environment, The External Environment @subsection Top level loop The top level loop is the @r{Common Lisp} mechanism by which the user normally interacts with the @r{Common Lisp} system. This loop is sometimes referred to as the @i{Lisp read-eval-print loop} because it typically consists of an endless loop that reads an expression, evaluates it and prints the results. The top level loop is not completely specified; thus the user interface is @i{implementation-defined}. The top level loop prints all values resulting from the evaluation of a @i{form}. Figure 25--1 lists variables that are maintained by the @i{Lisp read-eval-print loop}. @format @group @noindent @w{ * + / - } @w{ ** ++ // } @w{ *** +++ /// } @noindent @w{ Figure 25--1: Variables maintained by the Read-Eval-Print Loop} @end group @end format @node Debugging Utilities, Environment Inquiry, Top level loop, The External Environment @subsection Debugging Utilities Figure 25--2 shows @i{defined names} relating to debugging. @format @group @noindent @w{ *debugger-hook* documentation step } @w{ apropos dribble time } @w{ apropos-list ed trace } @w{ break inspect untrace } @w{ describe invoke-debugger } @noindent @w{ Figure 25--2: Defined names relating to debugging} @end group @end format @node Environment Inquiry, Time, Debugging Utilities, The External Environment @subsection Environment Inquiry Environment inquiry @i{defined names} provide information about the hardware and software configuration on which a @r{Common Lisp} program is being executed. Figure 25--3 shows @i{defined names} relating to environment inquiry. @format @group @noindent @w{ *features* machine-instance short-site-name } @w{ lisp-implementation-type machine-type software-type } @w{ lisp-implementation-version machine-version software-version } @w{ long-site-name room } @noindent @w{ Figure 25--3: Defined names relating to environment inquiry. } @end group @end format @node Time, , Environment Inquiry, The External Environment @subsection Time Time is represented in four different ways in @r{Common Lisp}: @i{decoded time}, @i{universal time}, @i{internal time}, and seconds. @i{Decoded time} and @i{universal time} are used primarily to represent calendar time, and are precise only to one second. @i{Internal time} is used primarily to represent measurements of computer time (such as run time) and is precise to some @i{implementation-dependent} fraction of a second called an @i{internal time unit}, as specified by @b{internal-time-units-per-second}. An @i{internal time} can be used for either @i{absolute} and @i{relative} @i{time} measurements. Both a @i{universal time} and a @i{decoded time} can be used only for @i{absolute} @i{time} measurements. In the case of one function, @b{sleep}, time intervals are represented as a non-negative @i{real} number of seconds. Figure 25--4 shows @i{defined names} relating to @i{time}. @format @group @noindent @w{ decode-universal-time get-internal-run-time } @w{ encode-universal-time get-universal-time } @w{ get-decoded-time internal-time-units-per-second } @w{ get-internal-real-time sleep } @noindent @w{ Figure 25--4: Defined names involving Time. } @end group @end format @menu * Decoded Time:: * Universal Time:: * Internal Time:: * Seconds:: @end menu @node Decoded Time, Universal Time, Time, Time @subsubsection Decoded Time A @i{decoded time} @IGindex decoded time is an ordered series of nine values that, taken together, represent a point in calendar time (ignoring @i{leap seconds}): @table @asis @item @b{Second} An @i{integer} between 0 and~59, inclusive. @item @b{Minute} An @i{integer} between 0 and~59, inclusive. @item @b{Hour} An @i{integer} between 0 and~23, inclusive. @item @b{Date} An @i{integer} between 1 and~31, inclusive (the upper limit actually depends on the month and year, of course). @item @b{Month} An @i{integer} between 1 and 12, inclusive; 1~means January, 2~means February, and so on; 12~means December. @item @b{Year} An @i{integer} indicating the year A.D. However, if this @i{integer} is between 0 and 99, the ``obvious'' year is used; more precisely, that year is assumed that is equal to the @i{integer} modulo 100 and within fifty years of the current year (inclusive backwards and exclusive forwards). Thus, in the year 1978, year 28 is 1928 but year 27 is 2027. (Functions that return time in this format always return a full year number.) @item @b{Day of week} An @i{integer} between~0 and~6, inclusive; 0~means Monday, 1~means Tuesday, and so on; 6~means Sunday. @item @b{Daylight saving time flag} A @i{generalized boolean} that, if @i{true}, indicates that daylight saving time is in effect. @item @b{Time zone} A @i{time zone}. @end table Figure 25--5 shows @i{defined names} relating to @i{decoded time}. @format @group @noindent @w{ decode-universal-time get-decoded-time } @noindent @w{ Figure 25--5: Defined names involving time in Decoded Time.} @end group @end format @node Universal Time, Internal Time, Decoded Time, Time @subsubsection Universal Time @i{Universal time} @IGindex universal time is an @i{absolute} @i{time} represented as a single non-negative @i{integer}---the number of seconds since midnight, January 1, 1900 GMT (ignoring @i{leap seconds}). Thus the time 1 is 00:00:01 (that is, 12:00:01 a.m.) on January 1, 1900 GMT. Similarly, the time 2398291201 corresponds to time 00:00:01 on January 1, 1976 GMT. Recall that the year 1900 was not a leap year; for the purposes of @r{Common Lisp}, a year is a leap year if and only if its number is divisible by 4, except that years divisible by 100 are not leap years, except that years divisible by 400 are leap years. Therefore the year 2000 will be a leap year. Because @i{universal time} must be a non-negative @i{integer}, times before the base time of midnight, January 1, 1900 GMT cannot be processed by @r{Common Lisp}. @format @group @noindent @w{ decode-universal-time get-universal-time } @w{ encode-universal-time } @noindent @w{ Figure 25--6: Defined names involving time in Universal Time.} @end group @end format @node Internal Time, Seconds, Universal Time, Time @subsubsection Internal Time @i{Internal time} @IGindex internal time represents time as a single @i{integer}, in terms of an @i{implementation-dependent} unit called an @i{internal time unit}. Relative time is measured as a number of these units. Absolute time is relative to an arbitrary time base. Figure 25--7 shows @i{defined names} related to @i{internal time}. @format @group @noindent @w{ get-internal-real-time internal-time-units-per-second } @w{ get-internal-run-time } @noindent @w{ Figure 25--7: Defined names involving time in Internal Time.} @end group @end format @node Seconds, , Internal Time, Time @subsubsection Seconds One function, @b{sleep}, takes its argument as a non-negative @i{real} number of seconds. Informally, it may be useful to think of this as a @i{relative} @i{universal time}, but it differs in one important way: @i{universal times} are always non-negative @i{integers}, whereas the argument to @b{sleep} can be any kind of non-negative @i{real}, in order to allow for the possibility of fractional seconds. @format @group @noindent @w{ sleep } @noindent @w{ Figure 25--8: Defined names involving time in Seconds.} @end group @end format @c end of including concept-environment @node Environment Dictionary, , The External Environment, Environment @section Environment Dictionary @c including dict-environment @menu * decode-universal-time:: * encode-universal-time:: * get-universal-time:: * sleep:: * apropos:: * describe:: * describe-object:: * trace:: * step:: * time:: * internal-time-units-per-second:: * get-internal-real-time:: * get-internal-run-time:: * disassemble:: * documentation:: * room:: * ed:: * inspect:: * dribble:: * - (Variable):: * + (Variable):: * * (Variable):: * / (Variable):: * lisp-implementation-type:: * short-site-name:: * machine-instance:: * machine-type:: * machine-version:: * software-type:: * user-homedir-pathname:: @end menu @node decode-universal-time, encode-universal-time, Environment Dictionary, Environment Dictionary @subsection decode-universal-time [Function] @code{decode-universal-time} @i{universal-time @r{&optional} time-zone}@* @result{} @i{second, minute, hour, date, month, year, day, daylight-p, zone} @subsubheading Arguments and Values:: @i{universal-time}---a @i{universal time}. @i{time-zone}---a @i{time zone}. @i{second}, @i{minute}, @i{hour}, @i{date}, @i{month}, @i{year}, @i{day}, @i{daylight-p}, @i{zone}---a @i{decoded time}. @subsubheading Description:: Returns the @i{decoded time} represented by the given @i{universal time}. If @i{time-zone} is not supplied, it defaults to the current time zone adjusted for daylight saving time. If @i{time-zone} is supplied, daylight saving time information is ignored. The daylight saving time flag is @b{nil} if @i{time-zone} is supplied. @subsubheading Examples:: @example (decode-universal-time 0 0) @result{} 0, 0, 0, 1, 1, 1900, 0, @i{false}, 0 ;; The next two examples assume Eastern Daylight Time. (decode-universal-time 2414296800 5) @result{} 0, 0, 1, 4, 7, 1976, 6, @i{false}, 5 (decode-universal-time 2414293200) @result{} 0, 0, 1, 4, 7, 1976, 6, @i{true}, 5 ;; This example assumes that the time zone is Eastern Daylight Time ;; (and that the time zone is constant throughout the example). (let* ((here (nth 8 (multiple-value-list (get-decoded-time)))) ;Time zone (recently (get-universal-time)) (a (nthcdr 7 (multiple-value-list (decode-universal-time recently)))) (b (nthcdr 7 (multiple-value-list (decode-universal-time recently here))))) (list a b (equal a b))) @result{} ((T 5) (NIL 5) NIL) @end example @subsubheading Affected By:: @i{Implementation-dependent} mechanisms for calculating when or if daylight savings time is in effect for any given session. @subsubheading See Also:: @ref{encode-universal-time} , @ref{get-universal-time} , @ref{Time} @node encode-universal-time, get-universal-time, decode-universal-time, Environment Dictionary @subsection encode-universal-time [function] @subsubheading Syntax:: @code{encode-universal-time} @i{second minute hour date month year @r{&optional} time-zone}@* @result{} @i{universal-time} @subsubheading Arguments and Values:: @i{second}, @i{minute}, @i{hour}, @i{date}, @i{month}, @i{year}, @i{time-zone}---the corresponding parts of a @i{decoded time}. (Note that some of the nine values in a full @i{decoded time} are redundant, and so are not used as inputs to this function.) @i{universal-time}---a @i{universal time}. @subsubheading Description:: @b{encode-universal-time} converts a time from Decoded Time format to a @i{universal time}. If @i{time-zone} is supplied, no adjustment for daylight savings time is performed. @subsubheading Examples:: @example (encode-universal-time 0 0 0 1 1 1900 0) @result{} 0 (encode-universal-time 0 0 1 4 7 1976 5) @result{} 2414296800 ;; The next example assumes Eastern Daylight Time. (encode-universal-time 0 0 1 4 7 1976) @result{} 2414293200 @end example @subsubheading See Also:: @ref{decode-universal-time} , @b{get-decoded-time} @node get-universal-time, sleep, encode-universal-time, Environment Dictionary @subsection get-universal-time, get-decoded-time [Function] @code{get-universal-time} @i{<@i{no @i{arguments}}>} @result{} @i{universal-time} @code{get-decoded-time} @i{<@i{no @i{arguments}}>}@* @result{} @i{second, minute, hour, date, month, year, day, daylight-p, zone} @subsubheading Arguments and Values:: @i{universal-time}---a @i{universal time}. @i{second}, @i{minute}, @i{hour}, @i{date}, @i{month}, @i{year}, @i{day}, @i{daylight-p}, @i{zone}---a @i{decoded time}. @subsubheading Description:: @b{get-universal-time} returns the current time, represented as a @i{universal time}. @b{get-decoded-time} returns the current time, represented as a @i{decoded time}. @subsubheading Examples:: @example ;; At noon on July 4, 1976 in Eastern Daylight Time. (get-decoded-time) @result{} 0, 0, 12, 4, 7, 1976, 6, @i{true}, 5 ;; At exactly the same instant. (get-universal-time) @result{} 2414332800 ;; Exactly five minutes later. (get-universal-time) @result{} 2414333100 ;; The difference is 300 seconds (five minutes) (- * **) @result{} 300 @end example @subsubheading Affected By:: The time of day (@i{i.e.}, the passage of time), the system clock's ability to keep accurate time, and the accuracy of the system clock's initial setting. @subsubheading Exceptional Situations:: An error of @i{type} @b{error} might be signaled if the current time cannot be determined. @subsubheading See Also:: @ref{decode-universal-time} , @ref{encode-universal-time} , @ref{Time} @subsubheading Notes:: @example (get-decoded-time) @equiv{} (decode-universal-time (get-universal-time)) @end example No @i{implementation} is required to have a way to verify that the time returned is correct. However, if an @i{implementation} provides a validity check (@i{e.g.}, the failure to have properly initialized the system clock can be reliably detected) and that validity check fails, the @i{implementation} is strongly encouraged (but not required) to signal an error of @i{type} @b{error} (rather than, for example, returning a known-to-be-wrong value) that is @i{correctable} by allowing the user to interactively set the correct time. @node sleep, apropos, get-universal-time, Environment Dictionary @subsection sleep [Function] @code{sleep} @i{seconds} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{seconds}---a non-negative @i{real}. @subsubheading Description:: Causes execution to cease and become dormant for approximately the seconds of real time indicated by @i{seconds}, whereupon execution is resumed. @subsubheading Examples:: @example (sleep 1) @result{} NIL ;; Actually, since SLEEP is permitted to use approximate timing, ;; this might not always yield true, but it will often enough that ;; we felt it to be a productive example of the intent. (let ((then (get-universal-time)) (now (progn (sleep 10) (get-universal-time)))) (>= (- now then) 10)) @result{} @i{true} @end example @subsubheading Side Effects:: Causes processing to pause. @subsubheading Affected By:: The granularity of the scheduler. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{seconds} is not a non-negative @i{real}. @node apropos, describe, sleep, Environment Dictionary @subsection apropos, apropos-list [Function] @code{apropos} @i{string @r{&optional} package} @result{} @i{<@i{no @i{values}}>} @code{apropos-list} @i{string @r{&optional} package} @result{} @i{symbols} @subsubheading Arguments and Values:: @i{string}---a @i{string designator}. @i{package}---a @i{package designator} or @b{nil}. The default is @b{nil}. @i{symbols}---a @i{list} of @i{symbols}. @subsubheading Description:: These functions search for @i{interned} @i{symbols} whose @i{names} contain the substring @i{string}. For @b{apropos}, as each such @i{symbol} is found, its name is printed on @i{standard output}. In addition, if such a @i{symbol} is defined as a @i{function} or @i{dynamic variable}, information about those definitions might also be printed. For @b{apropos-list}, no output occurs as the search proceeds; instead a list of the matching @i{symbols} is returned when the search is complete. If @i{package} is @i{non-nil}, only the @i{symbols} @i{accessible} in that @i{package} are searched; otherwise all @i{symbols} @i{accessible} in any @i{package} are searched. Because a @i{symbol} might be available by way of more than one inheritance path, @b{apropos} might print information about the @i{same} @i{symbol} more than once, or @b{apropos-list} might return a @i{list} containing duplicate @i{symbols}. Whether or not the search is case-sensitive is @i{implementation-defined}. @subsubheading Affected By:: The set of @i{symbols} which are currently @i{interned} in any @i{packages} being searched. @b{apropos} is also affected by @b{*standard-output*}. @node describe, describe-object, apropos, Environment Dictionary @subsection describe [Function] @code{describe} @i{object @r{&optional} stream} @result{} @i{<@i{no @i{values}}>} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{stream}---an @i{output} @i{stream designator}. The default is @i{standard output}. @subsubheading Description:: @b{describe} displays information about @i{object} to @i{stream}. For example, @b{describe} of a @i{symbol} might show the @i{symbol}'s value, its definition, and each of its properties. @b{describe} of a @i{float} might show the number's internal representation in a way that is useful for tracking down round-off errors. In all cases, however, the nature and format of the output of @b{describe} is @i{implementation-dependent}. @b{describe} can describe something that it finds inside the @i{object}; in such cases, a notational device such as increased indentation or positioning in a table is typically used in order to visually distinguish such recursive descriptions from descriptions of the argument @i{object}. The actual act of describing the object is implemented by @b{describe-object}. @b{describe} exists as an interface primarily to manage argument defaulting (including conversion of arguments @b{t} and @b{nil} into @i{stream} @i{objects}) and to inhibit any return values from @b{describe-object}. @b{describe} is not intended to be an interactive function. In a @i{conforming implementation}, @b{describe} must not, by default, prompt for user input. User-defined methods for @b{describe-object} are likewise restricted. @subsubheading Side Effects:: Output to @i{standard output} or @i{terminal I/O}. @subsubheading Affected By:: @b{*standard-output*} and @b{*terminal-io*}, methods on @b{describe-object} and @b{print-object} for @i{objects} having user-defined @i{classes}. @subsubheading See Also:: @ref{inspect} , @ref{describe-object} @node describe-object, trace, describe, Environment Dictionary @subsection describe-object [Standard Generic Function] @subsubheading Syntax:: @code{describe-object} @i{object stream} @result{} @i{@i{implementation-dependent}} @subsubheading Method Signatures:: @code{describe-object} @i{(@i{object} standard-object) @i{stream}} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{stream}---a @i{stream}. @subsubheading Description:: The generic function @b{describe-object} prints a description of @i{object} to a @i{stream}. @b{describe-object} is called by @b{describe}; it must not be called by the user. Each implementation is required to provide a @i{method} on the @i{class} @b{standard-object} and @i{methods} on enough other @i{classes} so as to ensure that there is always an applicable @i{method}. Implementations are free to add @i{methods} for other @i{classes}. Users can write @i{methods} for @b{describe-object} for their own @i{classes} if they do not wish to inherit an implementation-supplied @i{method}. @i{Methods} on @b{describe-object} can recursively call @b{describe}. Indentation, depth limits, and circularity detection are all taken care of automatically, provided that each @i{method} handles exactly one level of structure and calls @b{describe} recursively if there are more structural levels. The consequences are undefined if this rule is not obeyed. In some implementations the @i{stream} argument passed to a @b{describe-object} method is not the original @i{stream}, but is an intermediate @i{stream} that implements parts of @b{describe}. @i{Methods} should therefore not depend on the identity of this @i{stream}. @subsubheading Examples:: @example (defclass spaceship () ((captain :initarg :captain :accessor spaceship-captain) (serial# :initarg :serial-number :accessor spaceship-serial-number))) (defclass federation-starship (spaceship) ()) (defmethod describe-object ((s spaceship) stream) (with-slots (captain serial#) s (format stream "~&~S is a spaceship of type ~S,~ ~ and with serial number ~D.~ s (type-of s) captain serial#))) (make-instance 'federation-starship :captain "Rachel Garrett" :serial-number "NCC-1701-C") @result{} # (describe *) @t{ |> } # is a spaceship of type FEDERATION-STARSHIP, @t{ |> } with Rachel Garrett at the helm and with serial number NCC-1701-C. @result{} <@i{no @i{values}}> @end example @subsubheading See Also:: @ref{describe} @subsubheading Notes:: The same implementation techniques that are applicable to @b{print-object} are applicable to @b{describe-object}. The reason for making the return values for @b{describe-object} unspecified is to avoid forcing users to include explicit @t{(values)} in all of their @i{methods}. @b{describe} takes care of that. @node trace, step, describe-object, Environment Dictionary @subsection trace, untrace [Macro] @code{trace} @i{@{@i{function-name}@}*} @result{} @i{trace-result} @code{untrace} @i{@{@i{function-name}@}*} @result{} @i{untrace-result} @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. @i{trace-result}---@i{implementation-dependent}, unless no @i{function-names} are supplied, in which case @i{trace-result} is a @i{list} of @i{function names}. @i{untrace-result}---@i{implementation-dependent}. @subsubheading Description:: @b{trace} and @b{untrace} control the invocation of the trace facility. Invoking @b{trace} with one or more @i{function-names} causes the denoted @i{functions} to be ``traced.'' Whenever a traced @i{function} is invoked, information about the call, about the arguments passed, and about any eventually returned values is printed to @i{trace output}. If @b{trace} is used with no @i{function-names}, no tracing action is performed; instead, a list of the @i{functions} currently being traced is returned. Invoking @b{untrace} with one or more function names causes those functions to be ``untraced'' (@i{i.e.}, no longer traced). If @b{untrace} is used with no @i{function-names}, all @i{functions} currently being traced are untraced. If a @i{function} to be traced has been open-coded (@i{e.g.}, because it was declared @b{inline}), a call to that @i{function} might not produce trace output. @subsubheading Examples:: @example (defun fact (n) (if (zerop n) 1 (* n (fact (- n 1))))) @result{} FACT (trace fact) @result{} (FACT) ;; Of course, the format of traced output is implementation-dependent. (fact 3) @t{ |> } 1 Enter FACT 3 @t{ |> } | 2 Enter FACT 2 @t{ |> } | 3 Enter FACT 1 @t{ |> } | | 4 Enter FACT 0 @t{ |> } | | 4 Exit FACT 1 @t{ |> } | 3 Exit FACT 1 @t{ |> } | 2 Exit FACT 2 @t{ |> } 1 Exit FACT 6 @result{} 6 @end example @subsubheading Side Effects:: Might change the definitions of the @i{functions} named by @i{function-names}. @subsubheading Affected By:: Whether the functions named are defined or already being traced. @subsubheading Exceptional Situations:: Tracing an already traced function, or untracing a function not currently being traced, should produce no harmful effects, but might signal a warning. @subsubheading See Also:: @b{*trace-output*}, @ref{step} @subsubheading Notes:: @b{trace} and @b{untrace} may also accept additional @i{implementation-dependent} argument formats. The format of the trace output is @i{implementation-dependent}. Although @b{trace} can be extended to permit non-standard options, @i{implementations} are nevertheless encouraged (but not required) to warn about the use of syntax or options that are neither specified by this standard nor added as an extension by the @i{implementation}, since they could be symptomatic of typographical errors or of reliance on features supported in @i{implementations} other than the current @i{implementation}. @node step, time, trace, Environment Dictionary @subsection step [Macro] @code{step} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{form}---a @i{form}; evaluated as described below. @i{results}---the @i{values} returned by the @i{form}. @subsubheading Description:: @b{step} implements a debugging paradigm wherein the programmer is allowed to @i{step} through the @i{evaluation} of a @i{form}. The specific nature of the interaction, including which I/O streams are used and whether the stepping has lexical or dynamic scope, is @i{implementation-defined}. @b{step} evaluates @i{form} in the current @i{environment}. A call to @b{step} can be compiled, but it is acceptable for an implementation to interactively step through only those parts of the computation that are interpreted. It is technically permissible for a @i{conforming implementation} to take no action at all other than normal @i{execution} of the @i{form}. In such a situation, @t{(step @i{form})} is equivalent to, for example, @t{(let () @i{form})}. In implementations where this is the case, the associated documentation should mention that fact. @subsubheading See Also:: @ref{trace} @subsubheading Notes:: @i{Implementations} are encouraged to respond to the typing of @t{?} or the pressing of a ``help key'' by providing help including a list of commands. @node time, internal-time-units-per-second, step, Environment Dictionary @subsection time [Macro] @code{time} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{form}---a @i{form}; evaluated as described below. @i{results}---the @i{values} returned by the @i{form}. @subsubheading Description:: @b{time} evaluates @i{form} in the current @i{environment} (lexical and dynamic). A call to @b{time} can be compiled. @b{time} prints various timing data and other information to @i{trace output}. The nature and format of the printed information is @i{implementation-defined}. Implementations are encouraged to provide such information as elapsed real time, machine run time, and storage management statistics. @subsubheading Affected By:: The accuracy of the results depends, among other things, on the accuracy of the corresponding functions provided by the underlying operating system. The magnitude of the results may depend on the hardware, the operating system, the lisp implementation, and the state of the global environment. Some specific issues which frequently affect the outcome are hardware speed, nature of the scheduler (if any), number of competing processes (if any), system paging, whether the call is interpreted or compiled, whether functions called are compiled, the kind of garbage collector involved and whether it runs, whether internal data structures (e.g., hash tables) are implicitly reorganized, @i{etc.} @subsubheading See Also:: @ref{get-internal-real-time} , @ref{get-internal-run-time} @subsubheading Notes:: In general, these timings are not guaranteed to be reliable enough for marketing comparisons. Their value is primarily heuristic, for tuning purposes. For useful background information on the complicated issues involved in interpreting timing results, see @i{Performance and Evaluation of Lisp Programs}. @node internal-time-units-per-second, get-internal-real-time, time, Environment Dictionary @subsection internal-time-units-per-second [Constant Variable] @subsubheading Constant Value:: A positive @i{integer}, the magnitude of which is @i{implementation-dependent}. @subsubheading Description:: The number of @i{internal time units} in one second. @subsubheading See Also:: @ref{get-internal-run-time} , @ref{get-internal-real-time} @subsubheading Notes:: These units form the basis of the Internal Time format representation. @node get-internal-real-time, get-internal-run-time, internal-time-units-per-second, Environment Dictionary @subsection get-internal-real-time [Function] @code{get-internal-real-time} @i{<@i{no @i{arguments}}>} @result{} @i{internal-time} @subsubheading Arguments and Values:: @i{internal-time}---a non-negative @i{integer}. @subsubheading Description:: @b{get-internal-real-time} returns as an @i{integer} the current time in @i{internal time units}, relative to an arbitrary time base. The difference between the values of two calls to this function is the amount of elapsed real time (@i{i.e.}, clock time) between the two calls. @subsubheading Affected By:: Time of day (@i{i.e.}, the passage of time). The time base affects the result magnitude. @subsubheading See Also:: @ref{internal-time-units-per-second} @node get-internal-run-time, disassemble, get-internal-real-time, Environment Dictionary @subsection get-internal-run-time [Function] @code{get-internal-run-time} @i{<@i{no @i{arguments}}>} @result{} @i{internal-time} @subsubheading Arguments and Values:: @i{internal-time}---a non-negative @i{integer}. @subsubheading Description:: Returns as an @i{integer} the current run time in @i{internal time units}. The precise meaning of this quantity is @i{implementation-defined}; it may measure real time, run time, CPU cycles, or some other quantity. The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which computational effort was expended on behalf of the executing program. @subsubheading Affected By:: The @i{implementation}, the time of day (@i{i.e.}, the passage of time). @subsubheading See Also:: @ref{internal-time-units-per-second} @subsubheading Notes:: Depending on the @i{implementation}, paging time and garbage collection time might be included in this measurement. Also, in a multitasking environment, it might not be possible to show the time for just the running process, so in some @i{implementations}, time taken by other processes during the same time interval might be included in this measurement as well. @node disassemble, documentation, get-internal-run-time, Environment Dictionary @subsection disassemble [Function] @code{disassemble} @i{fn} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{fn}---an @i{extended function designator} or a @i{lambda expression}. @subsubheading Description:: The @i{function} @b{disassemble} is a debugging aid that composes symbolic instructions or expressions in some @i{implementation-dependent} language which represent the code used to produce the @i{function} which is or is named by the argument @i{fn}. The result is displayed to @i{standard output} in an @i{implementation-dependent} format. If @i{fn} is a @i{lambda expression} or @i{interpreted function}, it is compiled first and the result is disassembled. If the @i{fn} @i{designator} is a @i{function name}, the @i{function} that it @i{names} is disassembled. (If that @i{function} is an @i{interpreted function}, it is first compiled but the result of this implicit compilation is not installed.) @subsubheading Examples:: @example (defun f (a) (1+ a)) @result{} F (eq (symbol-function 'f) (progn (disassemble 'f) (symbol-function 'f))) @result{} @i{true} @end example @subsubheading Affected By:: @b{*standard-output*}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{fn} is not an @i{extended function designator} or a @i{lambda expression}. @node documentation, room, disassemble, Environment Dictionary @subsection documentation, (setf documentation) [Standard Generic Function] @subsubheading Syntax:: @code{documentation} @i{x doc-type} @result{} @i{documentation} @code{(setf documentation)} @i{new-value x doc-type} @result{} @i{new-value} @subsubheading Argument Precedence Order:: @i{doc-type}, @i{object} @subsubheading Method Signatures:: @subsubheading Functions, Macros, and Special Forms documentation (@i{x} @code{function}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{function}) (doc-type (eql 't)) documentation (@i{x} @code{function}) (doc-type (eql 'function))@* (setf documentation) @i{new-value}(@i{x} @code{function}) (doc-type (eql 'function)) documentation (@i{x} @code{list}) (doc-type (eql 'function))@* (setf documentation) @i{new-value}(@i{x} @code{list}) (doc-type (eql 'function)) documentation (@i{x} @code{list}) (doc-type (eql 'compiler-macro))@* (setf documentation) @i{new-value}(@i{x} @code{list}) (doc-type (eql 'compiler-macro)) documentation (@i{x} @code{symbol}) (doc-type (eql 'function))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'function)) documentation (@i{x} @code{symbol}) (doc-type (eql 'compiler-macro))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'compiler-macro)) documentation (@i{x} @code{symbol}) (doc-type (eql 'setf))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'setf)) @subsubheading Method Combinations documentation (@i{x} @code{method-combination}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{method-combination}) (doc-type (eql 't)) documentation (@i{x} @code{method-combination}) (doc-type (eql 'method-combination))@* (setf documentation) @i{new-value}(@i{x} @code{method-combination}) (doc-type (eql 'method-combination)) documentation (@i{x} @code{symbol}) (doc-type (eql 'method-combination))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'method-combination)) @subsubheading Methods documentation (@i{x} @code{standard-method}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{standard-method}) (doc-type (eql 't)) @subsubheading Packages documentation (@i{x} @code{package}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{package}) (doc-type (eql 't)) @subsubheading Types, Classes, and Structure Names documentation (@i{x} @code{standard-class}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{standard-class}) (doc-type (eql 't)) documentation (@i{x} @code{standard-class}) (doc-type (eql 'type))@* (setf documentation) @i{new-value}(@i{x} @code{standard-class}) (doc-type (eql 'type)) documentation (@i{x} @code{structure-class}) (doc-type (eql 't))@* (setf documentation) @i{new-value}(@i{x} @code{structure-class}) (doc-type (eql 't)) documentation (@i{x} @code{structure-class}) (doc-type (eql 'type))@* (setf documentation) @i{new-value}(@i{x} @code{structure-class}) (doc-type (eql 'type)) documentation (@i{x} @code{symbol}) (doc-type (eql 'type))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'type)) documentation (@i{x} @code{symbol}) (doc-type (eql 'structure))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'structure)) @subsubheading Variables documentation (@i{x} @code{symbol}) (doc-type (eql 'variable))@* (setf documentation) @i{new-value}(@i{x} @code{symbol}) (doc-type (eql 'variable)) @subsubheading Arguments and Values:: @i{x}---an @i{object}. @i{doc-type}---a @i{symbol}. @i{documentation}---a @i{string}, or @b{nil}. @i{new-value}---a @i{string}. @subsubheading Description:: The @i{generic function} @b{documentation} returns the @i{documentation string} associated with the given @i{object} if it is available; otherwise it returns @b{nil}. The @i{generic function} @t{(setf documentation)} updates the @i{documentation string} associated with @i{x} to @i{new-value}. If @i{x} is a @i{list}, it must be of the form @t{(setf @i{symbol})}. @i{Documentation strings} are made available for debugging purposes. @i{Conforming programs} are permitted to use @i{documentation strings} when they are present, but should not depend for their correct behavior on the presence of those @i{documentation strings}. An @i{implementation} is permitted to discard @i{documentation strings} at any time for @i{implementation-defined} reasons. The nature of the @i{documentation string} returned depends on the @i{doc-type}, as follows: @table @asis @item @b{compiler-macro} Returns the @i{documentation string} of the @i{compiler macro} whose @i{name} is the @i{function name} @i{x}. @item @b{function} If @i{x} is a @i{function name}, returns the @i{documentation string} of the @i{function}, @i{macro}, or @i{special operator} whose @i{name} is @i{x}. If @i{x} is a @i{function}, returns the @i{documentation string} associated with @i{x}. @item @b{method-combination} If @i{x} is a @i{symbol}, returns the @i{documentation string} of the @i{method combination} whose @i{name} is @i{x}. If @i{x} is a @i{method combination}, returns the @i{documentation string} associated with @i{x}. @item @b{setf} Returns the @i{documentation string} of the @i{setf expander} whose @i{name} is the @i{symbol} @i{x}. @item @b{structure} Returns the @i{documentation string} associated with the @i{structure name} @i{x}. @item @b{t} Returns a @i{documentation string} specialized on the @i{class} of the argument @i{x} itself. For example, if @i{x} is a @i{function}, the @i{documentation string} associated with the @i{function} @i{x} is returned. @item @b{type} If @i{x} is a @i{symbol}, returns the @i{documentation string} of the @i{class} whose @i{name} is the @i{symbol} @i{x}, if there is such a @i{class}. Otherwise, it returns the @i{documentation string} of the @i{type} which is the @i{type specifier} @i{symbol} @i{x}. If @i{x} is a @i{structure class} or @i{standard class}, returns the @i{documentation string} associated with the @i{class} @i{x}. @item @b{variable} Returns the @i{documentation string} of the @i{dynamic variable} or @i{constant variable} whose @i{name} is the @i{symbol} @i{x}. @end table A @i{conforming implementation} or a @i{conforming program} may extend the set of @i{symbols} that are acceptable as the @i{doc-type}. @subsubheading Notes:: This standard prescribes no means to retrieve the @i{documentation strings} for individual slots specified in a @b{defclass} form, but @i{implementations} might still provide debugging tools and/or programming language extensions which manipulate this information. Implementors wishing to provide such support are encouraged to consult the @i{Metaobject Protocol} for suggestions about how this might be done. @node room, ed, documentation, Environment Dictionary @subsection room [Function] @code{room} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{x}---one of @b{t}, @b{nil}, or @t{:default}. @subsubheading Description:: @b{room} prints, to @i{standard output}, information about the state of internal storage and its management. This might include descriptions of the amount of memory in use and the degree of memory compaction, possibly broken down by internal data type if that is appropriate. The nature and format of the printed information is @i{implementation-dependent}. The intent is to provide information that a @i{programmer} might use to tune a @i{program} for a particular @i{implementation}. @t{(room nil)} prints out a minimal amount of information. @t{(room t)} prints out a maximal amount of information. @t{(room)} or @t{(room :default)} prints out an intermediate amount of information that is likely to be useful. @subsubheading Side Effects:: Output to @i{standard output}. @subsubheading Affected By:: @b{*standard-output*}. @node ed, inspect, room, Environment Dictionary @subsection ed [Function] @code{ed} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{x}---@b{nil}, a @i{pathname}, a @i{string}, or a @i{function name}. The default is @b{nil}. @subsubheading Description:: @b{ed} invokes the editor if the @i{implementation} provides a resident editor. If @i{x} is @b{nil}, the editor is entered. If the editor had been previously entered, its prior state is resumed, if possible. If @i{x} is a @i{pathname} or @i{string}, it is taken as the @i{pathname designator} for a @i{file} to be edited. If @i{x} is a @i{function name}, the text of its definition is edited. The means by which the function text is obtained is @i{implementation-defined}. @subsubheading Exceptional Situations:: The consequences are undefined if the @i{implementation} does not provide a resident editor. Might signal @b{type-error} if its argument is supplied but is not a @i{symbol}, a @i{pathname}, or @b{nil}. If a failure occurs when performing some operation on the @i{file system} while attempting to edit a @i{file}, an error of @i{type} @b{file-error} is signaled. An error of @i{type} @b{file-error} might be signaled if @i{x} is a @i{designator} for a @i{wild} @i{pathname}. @i{Implementation-dependent} additional conditions might be signaled as well. @subsubheading See Also:: @b{pathname}, @b{logical-pathname}, @ref{compile-file} , @ref{load} , @ref{Pathnames as Filenames} @node inspect, dribble, ed, Environment Dictionary @subsection inspect [Function] @code{inspect} @i{object} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @subsubheading Description:: @b{inspect} is an interactive version of @b{describe}. The nature of the interaction is @i{implementation-dependent}, but the purpose of @b{inspect} is to make it easy to wander through a data structure, examining and modifying parts of it. @subsubheading Side Effects:: @i{implementation-dependent}. @subsubheading Affected By:: @i{implementation-dependent}. @subsubheading Exceptional Situations:: @i{implementation-dependent}. @subsubheading See Also:: @ref{describe} @subsubheading Notes:: Implementations are encouraged to respond to the typing of @t{?} or a ``help key'' by providing help, including a list of commands. @node dribble, - (Variable), inspect, Environment Dictionary @subsection dribble [Function] @code{dribble} @i{@r{&optional} pathname} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{pathname}---a @i{pathname designator}. @subsubheading Description:: Either @i{binds} @b{*standard-input*} and @b{*standard-output*} or takes other appropriate action, so as to send a record of the input/output interaction to a file named by @i{pathname}. @b{dribble} is intended to create a readable record of an interactive session. If @i{pathname} is a @i{logical pathname}, it is translated into a physical pathname as if by calling @b{translate-logical-pathname}. @t{(dribble)} terminates the recording of input and output and closes the dribble file. If @b{dribble} is @i{called} while a @i{stream} to a ``dribble file'' is still open from a previous @i{call} to @b{dribble}, the effect is @i{implementation-defined}. For example, the already-@i{open} @i{stream} might be @i{closed}, or dribbling might occur both to the old @i{stream} and to a new one, or the old @i{stream} might stay open but not receive any further output, or the new request might be ignored, or some other action might be taken. @subsubheading Affected By:: The @i{implementation}. @subsubheading Exceptional Situations:: If a failure occurs when performing some operation on the @i{file system} while creating the dribble file, an error of @i{type} @b{file-error} is signaled. An error of @i{type} @b{file-error} might be signaled if @i{pathname} is a @i{designator} for a @i{wild} @i{pathname}. @subsubheading See Also:: @ref{Pathnames as Filenames} @subsubheading Notes:: @b{dribble} can return before subsequent @i{forms} are executed. It also can enter a recursive interaction loop, returning only when @t{(dribble)} is done. @b{dribble} is intended primarily for interactive debugging; its effect cannot be relied upon when used in a program. @node - (Variable), + (Variable), dribble, Environment Dictionary @subsection - [Variable] @subsubheading Value Type:: a @i{form}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{value} of @b{-} is the @i{form} that is currently being evaluated by the @i{Lisp read-eval-print loop}. @subsubheading Examples:: @example (format t "~&Evaluating ~S~ @t{ |> } Evaluating (FORMAT T "~&Evaluating ~S~ @result{} NIL @end example @subsubheading Affected By:: @i{Lisp read-eval-print loop}. @subsubheading See Also:: @b{+} (@i{variable}), @b{*} (@i{variable}), @ref{/} (@i{variable}), @ref{Top level loop} @node + (Variable), * (Variable), - (Variable), Environment Dictionary @subsection +, ++, +++ [Variable] @subsubheading Value Type:: an @i{object}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{variables} @b{+}, @b{++}, and @b{+++} are maintained by the @i{Lisp read-eval-print loop} to save @i{forms} that were recently @i{evaluated}. The @i{value} of @b{+} is the last @i{form} that was @i{evaluated}, the @i{value} of @b{++} is the previous value of @b{+}, and the @i{value} of @b{+++} is the previous value of @b{++}. @subsubheading Examples:: @example (+ 0 1) @result{} 1 (- 4 2) @result{} 2 (/ 9 3) @result{} 3 (list + ++ +++) @result{} ((/ 9 3) (- 4 2) (+ 0 1)) (setq a 1 b 2 c 3 d (list a b c)) @result{} (1 2 3) (setq a 4 b 5 c 6 d (list a b c)) @result{} (4 5 6) (list a b c) @result{} (4 5 6) (eval +++) @result{} (1 2 3) #.`(,@@++ d) @result{} (1 2 3 (1 2 3)) @end example @subsubheading Affected By:: @i{Lisp read-eval-print loop}. @subsubheading See Also:: @ref{-} (@i{variable}), @b{*} (@i{variable}), @ref{/} (@i{variable}), @ref{Top level loop} @node * (Variable), / (Variable), + (Variable), Environment Dictionary @subsection *, **, *** [Variable] @subsubheading Value Type:: an @i{object}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{variables} @b{*}, @b{**}, and @b{***} are maintained by the @i{Lisp read-eval-print loop} to save the values of results that are printed each time through the loop. The @i{value} of @b{*} is the most recent @i{primary value} that was printed, the @i{value} of @b{**} is the previous value of @b{*}, and the @i{value} of @b{***} is the previous value of @b{**}. If several values are produced, @b{*} contains the first value only; @b{*} contains @b{nil} if zero values are produced. The @i{values} of @b{*}, @b{**}, and @b{***} are updated immediately prior to printing the @i{return value} of a top-level @i{form} by the @i{Lisp read-eval-print loop}. If the @i{evaluation} of such a @i{form} is aborted prior to its normal return, the values of @b{*}, @b{**}, and @b{***} are not updated. @subsubheading Examples:: @example (values 'a1 'a2) @result{} A1, A2 'b @result{} B (values 'c1 'c2 'c3) @result{} C1, C2, C3 (list * ** ***) @result{} (C1 B A1) (defun cube-root (x) (expt x 1/3)) @result{} CUBE-ROOT (compile *) @result{} CUBE-ROOT (setq a (cube-root 27.0)) @result{} 3.0 (* * 9.0) @result{} 27.0 @end example @subsubheading Affected By:: @i{Lisp read-eval-print loop}. @subsubheading See Also:: @ref{-} (@i{variable}), @b{+} (@i{variable}), @ref{/} (@i{variable}), @ref{Top level loop} @subsubheading Notes:: @example * @equiv{} (car /) ** @equiv{} (car //) *** @equiv{} (car ///) @end example @node / (Variable), lisp-implementation-type, * (Variable), Environment Dictionary @subsection /, //, /// [Variable] @subsubheading Value Type:: a @i{proper list}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{variables} @b{/}, @b{//}, and @b{///} are maintained by the @i{Lisp read-eval-print loop} to save the values of results that were printed at the end of the loop. The @i{value} of @b{/} is a @i{list} of the most recent @i{values} that were printed, the @i{value} of @b{//} is the previous value of @b{/}, and the @i{value} of @b{///} is the previous value of @b{//}. The @i{values} of @b{/}, @b{//}, and @b{///} are updated immediately prior to printing the @i{return value} of a top-level @i{form} by the @i{Lisp read-eval-print loop}. If the @i{evaluation} of such a @i{form} is aborted prior to its normal return, the values of @b{/}, @b{//}, and @b{///} are not updated. @subsubheading Examples:: @example (floor 22 7) @result{} 3, 1 (+ (* (car /) 7) (cadr /)) @result{} 22 @end example @subsubheading Affected By:: @i{Lisp read-eval-print loop}. @subsubheading See Also:: @ref{-} (@i{variable}), @b{+} (@i{variable}), @b{*} (@i{variable}), @ref{Top level loop} @node lisp-implementation-type, short-site-name, / (Variable), Environment Dictionary @subsection lisp-implementation-type, @subheading lisp-implementation-version @flushright @i{[Function]} @end flushright @code{lisp-implementation-type} @i{<@i{no @i{arguments}}>} @result{} @i{description} @code{lisp-implementation-version} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: @b{lisp-implementation-type} and @b{lisp-implementation-version} identify the current implementation of @r{Common Lisp}. @b{lisp-implementation-type} returns a @i{string} that identifies the generic name of the particular @r{Common Lisp} implementation. @b{lisp-implementation-version} returns a @i{string} that identifies the version of the particular @r{Common Lisp} implementation. If no appropriate and relevant result can be produced, @b{nil} is returned instead of a @i{string}. @subsubheading Examples:: @example (lisp-implementation-type) @result{} "ACME Lisp" @i{OR}@result{} "Joe's Common Lisp" (lisp-implementation-version) @result{} "1.3a" @result{} "V2" @i{OR}@result{} "Release 17.3, ECO #6" @end example @node short-site-name, machine-instance, lisp-implementation-type, Environment Dictionary @subsection short-site-name, long-site-name [Function] @code{short-site-name} @i{<@i{no @i{arguments}}>} @result{} @i{description} @code{long-site-name} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: @b{short-site-name} and @b{long-site-name} return a @i{string} that identifies the physical location of the computer hardware, or @b{nil} if no appropriate @i{description} can be produced. @subsubheading Examples:: @example (short-site-name) @result{} "MIT AI Lab" @i{OR}@result{} "CMU-CSD" (long-site-name) @result{} "MIT Artificial Intelligence Laboratory" @i{OR}@result{} "CMU Computer Science Department" @end example @subsubheading Affected By:: The implementation, the location of the computer hardware, and the installation/configuration process. @node machine-instance, machine-type, short-site-name, Environment Dictionary @subsection machine-instance [Function] @code{machine-instance} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: Returns a @i{string} that identifies the particular instance of the computer hardware on which @r{Common Lisp} is running, or @b{nil} if no such @i{string} can be computed. @subsubheading Examples:: @example (machine-instance) @result{} "ACME.COM" @i{OR}@result{} "S/N 123231" @i{OR}@result{} "18.26.0.179" @i{OR}@result{} "AA-00-04-00-A7-A4" @end example @subsubheading Affected By:: The machine instance, and the @i{implementation}. @subsubheading See Also:: @ref{machine-type} , @ref{machine-version} @node machine-type, machine-version, machine-instance, Environment Dictionary @subsection machine-type [Function] @code{machine-type} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: Returns a @i{string} that identifies the generic name of the computer hardware on which @r{Common Lisp} is running. @subsubheading Examples:: @example (machine-type) @result{} "DEC PDP-10" @i{OR}@result{} "Symbolics LM-2" @end example @subsubheading Affected By:: The machine type. The implementation. @subsubheading See Also:: @ref{machine-version} @node machine-version, software-type, machine-type, Environment Dictionary @subsection machine-version [Function] @code{machine-version} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: Returns a @i{string} that identifies the version of the computer hardware on which @r{Common Lisp} is running, or @b{nil} if no such value can be computed. @subsubheading Examples:: @example (machine-version) @result{} "KL-10, microcode 9" @end example @subsubheading Affected By:: The machine version, and the @i{implementation}. @subsubheading See Also:: @ref{machine-type} , @ref{machine-instance} @node software-type, user-homedir-pathname, machine-version, Environment Dictionary @subsection software-type, software-version [Function] @code{software-type} @i{<@i{no @i{arguments}}>} @result{} @i{description} @code{software-version} @i{<@i{no @i{arguments}}>} @result{} @i{description} @subsubheading Arguments and Values:: @i{description}---a @i{string} or @b{nil}. @subsubheading Description:: @b{software-type} returns a @i{string} that identifies the generic name of any relevant supporting software, or @b{nil} if no appropriate or relevant result can be produced. @b{software-version} returns a @i{string} that identifies the version of any relevant supporting software, or @b{nil} if no appropriate or relevant result can be produced. @subsubheading Examples:: @example (software-type) @result{} "Multics" (software-version) @result{} "1.3x" @end example @subsubheading Affected By:: Operating system environment. @subsubheading Notes:: This information should be of use to maintainers of the @i{implementation}. @node user-homedir-pathname, , software-type, Environment Dictionary @subsection user-homedir-pathname [Function] @code{user-homedir-pathname} @i{@r{&optional} host} @result{} @i{pathname} @subsubheading Arguments and Values:: @i{host}---a @i{string}, a @i{list} of @i{strings}, or @t{:unspecific}. @i{pathname}---a @i{pathname}, or @b{nil}. @subsubheading Description:: @b{user-homedir-pathname} determines the @i{pathname} that corresponds to the user's home directory on @i{host}. If @i{host} is not supplied, its value is @i{implementation-dependent}. For a description of @t{:unspecific}, see @ref{Pathname Components}. The definition of home directory is @i{implementation-dependent}, but defined in @r{Common Lisp} to mean the directory where the user keeps personal files such as initialization files and mail. @b{user-homedir-pathname} returns a @i{pathname} without any name, type, or version component (those components are all @b{nil}) for the user's home directory on @i{host}. If it is impossible to determine the user's home directory on @i{host}, then @b{nil} is returned. @b{user-homedir-pathname} never returns @b{nil} if @i{host} is not supplied. @subsubheading Examples:: @example (pathnamep (user-homedir-pathname)) @result{} @i{true} @end example @subsubheading Affected By:: The host computer's file system, and the @i{implementation}. @c end of including dict-environment @c %**end of chapter gcl-2.6.14/info/makefile0000644000175000017500000001021114360276512013421 0ustar cammcamm.SUFFIXES: .SUFFIXES: .info .pdf .texi INFO_DIR=/usr/local/lib/info GCL_PDF=gcl-tk.pdf gcl-si.pdf gcl.pdf #GCL_DVI=gcl-tk.dvi gcl-si.dvi #gcl.dvi #GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html GCL_HTML=gcl-si/index.html gcl-tk/index.html gcl/index.html -include ../makedefs #HTML_CMD=texi2html -split_chapter HTML_CMD=$(MAKEINFO) --html all: gcl-tk.info gcl-si.info $(GCL_PDF) $(GCL_HTML) gcl.info .texi.info: rm -f $*.*gz -$(MAKEINFO) $*.texi - gzip $*.info-* GCL_SI= number.texi sequence.texi character.texi list.texi io.texi \ form.texi compile.texi symbol.texi system.texi structure.texi \ iteration.texi user-interface.texi doc.texi type.texi internal.texi \ c-interface.texi si-defs.texi debug.texi misc.texi compiler-defs.texi \ gcl-si-index.texi GCL_TK= general.texi widgets.texi control.texi GCL_MAN= chap-1.texi chap-2.texi chap-3.texi chap-4.texi chap-5.texi \ chap-6.texi chap-7.texi chap-8.texi chap-9.texi chap-10.texi chap-11.texi \ chap-12.texi chap-13.texi chap-14.texi chap-15.texi chap-16.texi chap-17.texi \ chap-18.texi chap-19.texi chap-20.texi chap-21.texi chap-22.texi chap-23.texi \ chap-24.texi chap-25.texi chap-26.texi chap-a.texi %.pdf: %.dvi -dvipdfm $< gcl-si.dvi: ${GCL_SI} gcl-si.texi -TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl-si.texi || true rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn gcl-si.info: ${GCL_SI} gcl-si.texi -$(MAKEINFO) gcl-si.texi gcl-tk.dvi: ${GCL_TK} gcl-tk.texi -TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl-tk.texi || true rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn gcl-tk.info: ${GCL_TK} gcl-tk.texi -$(MAKEINFO) gcl-tk.texi gcl.dvi: ${GCL_MAN} gcl.texi -TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl.texi || true rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn gcl.info: ${GCL_MAN} gcl.texi -$(MAKEINFO) gcl.texi #gcl-si_toc.html: ${GCL_SI} gcl-si.texi # $(HTML_CMD) gcl-si.texi #gcl-tk_toc.html: ${GCL_TK} gcl-tk.texi # $(HTML_CMD) gcl-tk.texi #gcl_toc.html: # $(HTML_CMD) gcl.texi gcl-si/index.html: ${GCL_SI} gcl-si.texi mkdir -p $(@D) touch $@ -$(HTML_CMD) gcl-si.texi gcl-tk/index.html: ${GCL_TK} gcl-tk.texi mkdir -p $(@D) touch $@ -$(HTML_CMD) gcl-tk.texi gcl/index.html: gcl.texi mkdir -p $(@D) touch $@ -$(HTML_CMD) gcl.texi install: #$(GCL_PDF) $(GCL_HTML) mkdir -p $(DESTDIR)${INFO_DIR} [ -f $(DESTDIR)$(INFO_DIR)dir ] || touch $(DESTDIR)$(INFO_DIR)dir grep gcl-si $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ echo "* GCL Doc: (gcl-si.info). GNU Common Lisp specific Documentation." >> $(DESTDIR)${INFO_DIR}dir grep gcl-tk $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ echo "* GCL TK Doc: (gcl-tk.info). TK window GCL interface." >> $(DESTDIR)${INFO_DIR}dir grep gcl.info $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ echo "* GCL Ansi Doc: (gcl.info). Ansi Common Lisp Specification." >> $(DESTDIR)${INFO_DIR}dir -cp *.info* $(DESTDIR)${INFO_DIR} # -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html # -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html # -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html # -cp gcl_*html gcl.html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html # -cp gcl-si*html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html # -cp gcl-tk*html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html # -cp gcl/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html # -cp gcl-si/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html # -cp gcl-tk/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html -mkdir -p $(DESTDIR)$(INFO_DIR)../doc # -cp -r gcl-si gcl gcl-tk $(DESTDIR)$(INFO_DIR)../doc -cp -r gcl gcl-si gcl-tk $(DESTDIR)$(INFO_DIR)../doc -cp *pdf $(DESTDIR)$(INFO_DIR)../doc FILE=gcl-si.texi srcs: fgrep '.texi' ${FILE} | sed -e "/@c/d" | \ awk '{ i++; printf("%s ",$$2); if ((i%5) == 0) printf("\\\n")}' tex: -TEXINPUTS=.:$$TEXINPUTS tex gcl-si.texi -TEXINPUTS=.:$$TEXINPUTS tex gcl-tk.texi -TEXINPUTS=.:$$TEXINPUTS tex gcl.texi @echo must do twice to get indices correct... @echo so do '$(MAKE) tex' again dist-clean: clean rm -f *.info* *.html *.pdf rm -rf gcl gcl-si gcl-tk clean: rm -rf gcl.IC gcl.IE gcl.IG gcl.IP gcl.IR gcl.IT gcl.fu .INTERMEDIATE: gcl-tk.dvi gcl-si.dvi gcl.dvi gcl-2.6.14/info/gcl-tk.texi0000755000175000017500000000350714360276512014012 0ustar cammcamm\input texinfo @c -*-texinfo-*- @c IMPORTANT.... @c some versions of texinfo.tex cause an error message 'unmatched paren @c for: @c @defun foo (a &optional (b 3)) @c ! unbalanced parens in @def arguments. @c ignore these by using 's' to scroll error messages in tex. @c @smallbook @setfilename gcl-tk.info @synindex vr fn @c to update the menus do: @c (texinfo-multiple-files-update "gcl-si.texi" t t) @setchapternewpage odd @dircategory GNU Common Lisp @direntry * gcl-tk: (gcl-tk.info). GNU TK Manual @end direntry @ifinfo This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @comment @center @titlefont{GCL TK Manual} @title GCL TK Manual @end titlepage @node Top, General, (dir), (dir) @top @menu * General:: * Widgets:: * Control:: --- The Detailed Node Listing --- General * Introduction:: * Getting Started:: * Common Features of Widgets:: * Return Values:: * Argument Lists:: * Lisp Functions Invoked from Graphics:: * Linked Variables:: * tkconnect:: Widgets * button:: * listbox:: * scale:: * canvas:: * menu:: * scrollbar:: * checkbutton:: * menubutton:: * text:: * entry:: * message:: * frame:: * label:: * radiobutton:: * toplevel:: Control * after:: * bind:: * destroy:: * tk-dialog:: * exit:: * focus:: * grab:: * tk-listbox-single-select:: * lower:: * tk-menu-bar:: * option:: * options:: * pack-old:: * pack:: * place:: * raise:: * selection:: * send:: * tk:: * tkerror:: * tkvars:: * tkwait:: * update:: * winfo:: * wm:: @end menu @include general.texi @include widgets.texi @include control.texi @summarycontents @contents @bye gcl-2.6.14/info/gcl-si-index.texi0000755000175000017500000000016614360276512015112 0ustar cammcamm@node Function and Variable Index, , Compiler Definitions, Top @appendix Function and Variable Index @printindex fn gcl-2.6.14/info/gcl-tk.info-20000644000175000017500000016354414360276512014140 0ustar cammcammThis is gcl-tk.info, produced by makeinfo version 6.7 from gcl-tk.texi. INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl-tk: (gcl-tk.info). GNU TK Manual END-INFO-DIR-ENTRY This is a Texinfo GCL TK Manual Copyright 1994 William F. Schelter  File: gcl-tk.info, Node: place, Next: raise, Prev: pack, Up: Control 3.15 place ========== place \- Geometry manager for fixed or rubber-sheet placement Synopsis -------- place window option value ?option value ...? place configure window option value ?option value ...? place forget window place info window place slaves window Description ----------- The placer is a geometry manager for Tk. It provides simple fixed placement of windows, where you specify the exact size and location of one window, called the slave, within another window, called the master. The placer also provides rubber-sheet placement, where you specify the size and location of the slave in terms of the dimensions of the master, so that the slave changes size and location in response to changes in the size of the master. Lastly, the placer allows you to mix these styles of placement so that, for example, the slave has a fixed width and height but is centered inside the master. If the first argument to the place command is a window path name or configure then the command arranges for the placer to manage the geometry of a slave whose path name is window. The remaining arguments consist of one or more option:value pairs that specify the way in which window's geometry is managed. If the placer is already managing window, then the option:value pairs modify the configuration for window. In this form the place command returns an empty string as result. The following option:value pairs are supported: :in master Master specifes the path name of the window relative to which window is to be placed. Master must either be window's parent or a descendant of window's parent. In addition, master and window must both be descendants of the same top-level window. These restrictions are necessary to guarantee that window is visible whenever master is visible. If this option isn't specified then the master defaults to window's parent. :x location Location specifies the x-coordinate within the master window of the anchor point for window. The location is specified in screen units (i.e. any of the forms accepted by Tk_GetPixels) and need not lie within the bounds of the master window. :relx location Location specifies the x-coordinate within the master window of the anchor point for window. In this case the location is specified in a relative fashion as a floating-point number: 0.0 corresponds to the left edge of the master and 1.0 corresponds to the right edge of the master. Location need not be in the range 0.0\-1.0. :y location Location specifies the y-coordinate within the master window of the anchor point for window. The location is specified in screen units (i.e. any of the forms accepted by Tk_GetPixels) and need not lie within the bounds of the master window. :rely location Location specifies the y-coordinate within the master window of the anchor point for window. In this case the value is specified in a relative fashion as a floating-point number: 0.0 corresponds to the top edge of the master and 1.0 corresponds to the bottom edge of the master. Location need not be in the range 0.0\-1.0. :anchor where Where specifies which point of window is to be positioned at the (x,y) location selected by the :x, :y, :relx, and :rely options. The anchor point is in terms of the outer area of window including its border, if any. Thus if where is se then the lower-right corner of window's border will appear at the given (x,y) location in the master. The anchor position defaults to nw. :width size Size specifies the width for window in screen units (i.e. any of the forms accepted by Tk_GetPixels). The width will be the outer width of window including its border, if any. If size is an empty string, or if no :width or :relwidth option is specified, then the width requested internally by the window will be used. :relwidth size Size specifies the width for window. In this case the width is specified as a floating-point number relative to the width of the master: 0.5 means window will be half as wide as the master, 1.0 means window will have the same width as the master, and so on. :height size Size specifies the height for window in screen units (i.e. any of the forms accepted by Tk_GetPixels). The height will be the outer dimension of window including its border, if any. If size is an empty string, or if no :height or :relheight option is specified, then the height requested internally by the window will be used. :relheight size Size specifies the height for window. In this case the height is specified as a floating-point number relative to the height of the master: 0.5 means window will be half as high as the master, 1.0 means window will have the same height as the master, and so on. :bordermode mode Mode determines the degree to which borders within the master are used in determining the placement of the slave. The default and most common value is inside. In this case the placer considers the area of the master to be the innermost area of the master, inside any border: an option of :x 0 corresponds to an x-coordinate just inside the border and an option of :relwidth 1.0 means window will fill the area inside the master's border. If mode is outside then the placer considers the area of the master to include its border; this mode is typically used when placing window outside its master, as with the options :x 0 :y 0 :anchor ne. Lastly, mode may be specified as ignore, in which case borders are ignored: the area of the master is considered to be its official X area, which includes any internal border but no external border. A bordermode of ignore is probably not very useful. If the same value is specified separately with two different options, such as :x and :relx, then the most recent option is used and the older one is ignored. The place slaves command returns a list of all the slave windows for which window is the master. If there are no slaves for window then an empty string is returned. The place forget command causes the placer to stop managing the geometry of window. As a side effect of this command window will be unmapped so that it doesn't appear on the screen. If window isn't currently managed by the placer then the command has no effect. Place forget returns an empty string as result. The place info command returns a list giving the current configuration of window. The list consists of option:value pairs in exactly the same form as might be specified to the place configure command. If the configuration of a window has been retrieved with place info, that configuration can be restored later by first using place forget to erase any existing information for the window and then invoking place configure with the saved information. "Fine Points" ------------- It is not necessary for the master window to be the parent of the slave window. This feature is useful in at least two situations. First, for complex window layouts it means you can create a hierarchy of subwindows whose only purpose is to assist in the layout of the parent. The "real children" of the parent (i.e. the windows that are significant for the application's user interface) can be children of the parent yet be placed inside the windows of the geometry-management hierarchy. This means that the path names of the "real children" don't reflect the geometry-management hierarchy and users can specify options for the real children without being aware of the structure of the geometry-management hierarchy. A second reason for having a master different than the slave's parent is to tie two siblings together. For example, the placer can be used to force a window always to be positioned centered just below one of its siblings by specifying the configuration :in sibling :relx 0.5 :rely 1.0 :anchor n :bordermode outside Whenever the sibling is repositioned in the future, the slave will be repositioned as well. Unlike many other geometry managers (such as the packer) the placer does not make any attempt to manipulate the geometry of the master windows or the parents of slave windows (i.e. it doesn't set their requested sizes). To control the sizes of these windows, make them windows like frames and canvases that provide configuration options for this purpose. Keywords -------- geometry manager, height, location, master, place, rubber sheet, slave, width  File: gcl-tk.info, Node: raise, Next: selection, Prev: place, Up: Control 3.16 raise ========== raise \- Change a window's position in the stacking order Synopsis -------- raise window ?aboveThis? Description ----------- If the aboveThis argument is omitted then the command raises window so that it is above all of its siblings in the stacking order (it will not be obscured by any siblings and will obscure any siblings that overlap it). If aboveThis is specified then it must be the path name of a window that is either a sibling of window or the descendant of a sibling of window. In this case the raise command will insert window into the stacking order just above aboveThis (or the ancestor of aboveThis that is a sibling of window); this could end up either raising or lowering window. Keywords -------- obscure, raise, stacking order  File: gcl-tk.info, Node: selection, Next: send, Prev: raise, Up: Control 3.17 selection ============== selection \- Manipulate the X selection Synopsis -------- selection option ?arg arg ...? Description ----------- This command provides a Tcl interface to the X selection mechanism and implements the full selection functionality described in the X Inter-Client Communication Conventions Manual (ICCCM), except that it supports only the primary selection. The first argument to selection determines the format of the rest of the arguments and the behavior of the command. The following forms are currently supported: selection :clear window If there is a selection anywhere on window's display, clear it so that no window owns the selection anymore. Returns an empty string. selection :get ?type? Retrieves the value of the primary selection and returns it as a result. Type specifies the form in which the selection is to be returned (the desired "target" for conversion, in ICCCM terminology), and should be an atom name such as STRING or FILE_NAME; see the Inter-Client Communication Conventions Manual for complete details. Type defaults to STRING. The selection :owner may choose to return the selection in any of several different representation formats, such as STRING, ATOM, INTEGER, etc. (this format is different than the selection type; see the ICCCM for all the confusing details). If the selection is returned in a non-string format, such as INTEGER or ATOM, the selection command converts it to string format as a collection of fields separated by spaces: atoms are converted to their textual names, and anything else is converted to hexadecimal integers. selection :handle window command ?type? ?format? Creates a handler for selection requests, such that command will be executed whenever the primary selection is owned by window and someone attempts to retrieve it in the form given by type (e.g. type is specified in the selection :get command). Type defaults to STRING. If command is an empty string then any existing handler for window and type is removed. When the selection is requested and window is the selection :owner and type is the requested type, command will be executed as a Tcl command with two additional numbers appended to it (with space separators). The two additional numbers are offset and maxBytes: offset specifies a starting character position in the selection and maxBytes gives the maximum number of bytes to retrieve. The command should return a value consisting of at most maxBytes of the selection, starting at position offset. For very large selections (larger than maxBytes) the selection will be retrieved using several invocations of command with increasing offset values. If command returns a string whose length is less than maxBytes, the return value is assumed to include all of the remainder of the selection; if the length of command's result is equal to maxBytes then command will be invoked again, until it eventually returns a result shorter than maxBytes. The value of maxBytes will always be relatively large (thousands of bytes). If command returns an error then the selection retrieval is rejected just as if the selection didn't exist at all. The format argument specifies the representation that should be used to transmit the selection to the requester (the second column of Table 2 of the ICCCM), and defaults to STRING. If format is STRING, the selection is transmitted as 8-bit ASCII characters (i.e. just in the form returned by command). If format is ATOM, then the return value from command is divided into fields separated by white space; each field is converted to its atom value, and the 32-bit atom value is transmitted instead of the atom name. For any other format, the return value from command is divided into fields separated by white space and each field is converted to a 32-bit integer; an array of integers is transmitted to the selection requester. The format argument is needed only for compatibility with selection requesters that don't use Tk. If the Tk toolkit is being used to retrieve the selection then the value is converted back to a string at the requesting end, so format is irrelevant. .RE selection :own ?window? ?command? If window is specified, then it becomes the new selection :owner and the command returns an empty string as result. The existing owner, if any, is notified that it has lost the selection. If command is specified, it is a Tcl script to execute when some other window claims ownership of the selection away from window. If neither window nor command is specified then the command returns the path name of the window in this application that owns the selection, or an empty string if no window in this application owns the selection. Keywords -------- clear, format, handler, ICCCM, own, selection, target, type  File: gcl-tk.info, Node: send, Next: tk, Prev: selection, Up: Control 3.18 send ========= send \- Execute a command in a different interpreter Synopsis -------- send interp cmd ?arg arg ...? Description ----------- This command arranges for cmd (and args) to be executed in the interpreter named by interp. It returns the result or error from that command execution. Interp must be the name of an interpreter registered on the display associated with the interpreter in which the command is invoked; it need not be within the same process or application. If no arg arguments are present, then the command to be executed is contained entirely within the cmd argument. If one or more args are present, they are concatenated to form the command to be executed, just as for the eval Tcl command. Security -------- The send command is potentially a serious security loophole, since any application that can connect to your X server can send scripts to your applications. These incoming scripts can use Tcl to read and write your files and invoke subprocesses under your name. Host-based access control such as that provided by xhost is particularly insecure, since it allows anyone with an account on particular hosts to connect to your server, and if disabled it allows anyone anywhere to connect to your server. In order to provide at least a small amount of security, Tk checks the access control being used by the server and rejects incoming sends unless (a) xhost-style access control is enabled (i.e. only certain hosts can establish connections) and (b) the list of enabled hosts is empty. This means that applications cannot connect to your server unless they use some other form of authorization such as that provide by xauth. Keywords -------- interpreter, remote execution, security, send  File: gcl-tk.info, Node: tk, Next: tkerror, Prev: send, Up: Control 3.19 tk ======= tk \- Manipulate Tk internal state Synopsis -------- tk option ?arg arg ...? Description ----------- The tk command provides access to miscellaneous elements of Tk's internal state. Most of the information manipulated by this command pertains to the application as a whole, or to a screen or display, rather than to a particular window. The command can take any of a number of different forms depending on the option argument. The legal forms are: tk :colormodel window ?newValue? If newValue isn't specified, this command returns the current color model in use for window's screen, which will be either color or monochrome. If newValue is specified, then it must be either color or monochrome or an abbreviation of one of them; the color model for window's screen is set to this value. The color model is used by Tk and its widgets to determine whether it should display in black and white only or use colors. A single color model is shared by all of the windows managed by one process on a given screen. The color model for a screen is set initially by Tk to monochrome if the display has four or fewer bit planes and to color otherwise. The color model will automatically be changed from color to monochrome if Tk fails to allocate a color because all entries in the colormap were in use. An application can change its own color model at any time (e.g. it might change the model to monochrome in order to conserve colormap entries, or it might set the model to color to use color on a four-bit display in special circumstances), but an application is not allowed to change the color model to color unless the screen has at least two bit planes. .RE Keywords -------- color model, internal state  File: gcl-tk.info, Node: tkerror, Next: tkvars, Prev: tk, Up: Control 3.20 tkerror ============ tkerror \- Command invoked to process background errors Synopsis -------- tkerror message Description ----------- The tkerror command doesn't exist as built-in part of Tk. Instead, individual applications or users can define a tkerror command (e.g. as a Tcl procedure) if they wish to handle background errors. A background error is one that occurs in a command that didn't originate with the application. For example, if an error occurs while executing a command specified with a bind of after command, then it is a background error. For a non-background error, the error can simply be returned up through nested Tcl command evaluations until it reaches the top-level code in the application; then the application can report the error in whatever way it wishes. When a background error occurs, the unwinding ends in the Tk library and there is no obvious way for Tk to report the error. When Tk detects a background error, it invokes the tkerror command, passing it the error message as its only argument. Tk assumes that the application has implemented the tkerror command, and that the command will report the error in a way that makes sense for the application. Tk will ignore any result returned by the tkerror command. If another Tcl error occurs within the tkerror command then Tk reports the error itself by writing a message to stderr. The Tk script library includes a default tkerror procedure that posts a dialog box containing the error message and offers the user a chance to see a stack trace that shows where the error occurred. Keywords -------- background error, reporting  File: gcl-tk.info, Node: tkvars, Next: tkwait, Prev: tkerror, Up: Control 3.21 tkvars =========== tkvars \- Variables used or set by Tk Description ----------- The following Tcl variables are either set or used by Tk at various times in its execution: tk_library Tk sets this variable hold the name of a directory containing a library of Tcl scripts related to Tk. These scripts include an initialization file that is normally processed whenever a Tk application starts up, plus other files containing procedures that implement default behaviors for widgets. The value of this variable is taken from the TK_LIBRARY environment variable, if one exists, or else from a default value compiled into Tk. tk_patchLevel Contains a decimal integer giving the current patch level for Tk. The patch level is incremented for each new release or patch, and it uniquely identifies an official version of Tk. tk_priv This variable is an array containing several pieces of information that are private to Tk. The elements of tk_priv are used by Tk library procedures and default bindings. They should not be accessed by any code outside Tk. tk_strictMotif This variable is set to zero by default. If an application sets it to one, then Tk attempts to adhere as closely as possible to Motif look-and-feel standards. For example, active elements such as buttons and scrollbar sliders will not change color when the pointer passes over them. tk_version Tk sets this variable in the interpreter for each application. The variable holds the current version number of the Tk library in the form major.minor. Major and minor are integers. The major version number increases in any Tk release that includes changes that are not backward compatible (i.e. whenever existing Tk applications and scripts may have to change to work with the new release). The minor version number increases with each new release of Tk, except that it resets to zero whenever the major version number changes. tkVersion Has the same value as tk_version. This variable is obsolete and will be deleted soon. Keywords -------- variables, version  File: gcl-tk.info, Node: tkwait, Next: update, Prev: tkvars, Up: Control 3.22 tkwait =========== tkwait \- Wait for variable to change or window to be destroyed Synopsis -------- tkwait :variable name tkwait :visibility name tkwait :window name Description ----------- The tkwait command waits for one of several things to happen, then it returns without taking any other actions. The return value is always an empty string. If the first argument is :variable (or any abbreviation of it) then the second argument is the name of a global variable and the command waits for that variable to be modified. If the first argument is :visibility (or any abbreviation of it) then the second argument is the name of a window and the tkwait command waits for a change in its visibility state (as indicated by the arrival of a VisibilityNotify event). This form is typically used to wait for a newly-created window to appear on the screen before taking some action. If the first argument is :window (or any abbreviation of it) then the second argument is the name of a window and the tkwait command waits for that window to be destroyed. This form is typically used to wait for a user to finish interacting with a dialog box before using the result of that interaction. While the tkwait command is waiting it processes events in the normal fashion, so the application will continue to respond to user interactions. Keywords -------- variable, visibility, wait, window  File: gcl-tk.info, Node: update, Next: winfo, Prev: tkwait, Up: Control 3.23 update =========== update \- Process pending events and/or when-idle handlers Synopsis -------- update ?:idletasks? Description ----------- This command is used to bring the entire application world "up to date." It flushes all pending output to the display, waits for the server to process that output and return errors or events, handles all pending events of any sort (including when-idle handlers), and repeats this set of operations until there are no pending events, no pending when-idle handlers, no pending output to the server, and no operations still outstanding at the server. If the idletasks keyword is specified as an argument to the command, then no new events or errors are processed; only when-idle idlers are invoked. This causes operations that are normally deferred, such as display updates and window layout calculations, to be performed immediately. The update :idletasks command is useful in scripts where changes have been made to the application's state and you want those changes to appear on the display immediately, rather than waiting for the script to complete. The update command with no options is useful in scripts where you are performing a long-running computation but you still want the application to respond to user interactions; if you occasionally call update then user input will be processed during the next call to update. Keywords -------- event, flush, handler, idle, update  File: gcl-tk.info, Node: winfo, Next: wm, Prev: update, Up: Control 3.24 winfo ========== winfo \- Return window-related information Synopsis -------- winfo option ?arg arg ...? Description ----------- The winfo command is used to retrieve information about windows managed by Tk. It can take any of a number of different forms, depending on the option argument. The legal forms are: winfo :atom name Returns a decimal string giving the integer identifier for the atom whose name is name. If no atom exists with the name name then a new one is created. winfo :atomname id Returns the textual name for the atom whose integer identifier is id. This command is the inverse of the winfo :atom command. Generates an error if no such atom exists. winfo :cells window Returns a decimal string giving the number of cells in the color map for window. winfo :children window Returns a list containing the path names of all the children of window. Top-level windows are returned as children of their logical parents. winfo :class window Returns the class name for window. winfo :containing rootX rootY Returns the path name for the window containing the point given by rootX and rootY. RootX and rootY are specified in screen units (i.e. any form acceptable to Tk_GetPixels) in the coordinate system of the root window (if a virtual-root window manager is in use then the coordinate system of the virtual root window is used). If no window in this application contains the point then an empty string is returned. In selecting the containing window, children are given higher priority than parents and among siblings the highest one in the stacking order is chosen. winfo :depth window Returns a decimal string giving the depth of window (number of bits per pixel). winfo :exists window Returns 1 if there exists a window named window, 0 if no such window exists. winfo :fpixels window number Returns a floating-point value giving the number of pixels in window corresponding to the distance given by number. Number may be specified in any of the forms acceptable to Tk_GetScreenMM, such as "2.0c" or "1i". The return value may be fractional; for an integer value, use winfo :pixels. winfo :geometry window Returns the geometry for window, in the form widthxheight+x+y. All dimensions are in pixels. winfo :height window Returns a decimal string giving window's height in pixels. When a window is first created its height will be 1 pixel; the height will eventually be changed by a geometry manager to fulfill the window's needs. If you need the true height immediately after creating a widget, invoke update to force the geometry manager to arrange it, or use winfo :reqheight to get the window's requested height instead of its actual height. winfo :id window Returns a hexadecimal string indicating the X identifier for window. winfo :interps Returns a list whose members are the names of all Tcl interpreters (e.g. all Tk-based applications) currently registered for the display of the invoking application. winfo :ismapped window Returns 1 if window is currently mapped, 0 otherwise. winfo :name window Returns window's name (i.e. its name within its parent, as opposed to its full path name). The command winfo :name . will return the name of the application. winfo :parent window Returns the path name of window's parent, or an empty string if window is the main window of the application. winfo :pathname id Returns the path name of the window whose X identifier is id. Id must be a decimal, hexadecimal, or octal integer and must correspond to a window in the invoking application. winfo :pixels window number Returns the number of pixels in window corresponding to the distance given by number. Number may be specified in any of the forms acceptable to Tk_GetPixels, such as "2.0c" or "1i". The result is rounded to the nearest integer value; for a fractional result, use winfo :fpixels. winfo :reqheight window Returns a decimal string giving window's requested height, in pixels. This is the value used by window's geometry manager to compute its geometry. winfo :reqwidth window Returns a decimal string giving window's requested width, in pixels. This is the value used by window's geometry manager to compute its geometry. winfo :rgb window color Returns a list containing three decimal values, which are the red, green, and blue intensities that correspond to color in the window given by window. Color may be specified in any of the forms acceptable for a color option. winfo :rootx window Returns a decimal string giving the x-coordinate, in the root window of the screen, of the upper-left corner of window's border (or window if it has no border). winfo :rooty window Returns a decimal string giving the y-coordinate, in the root window of the screen, of the upper-left corner of window's border (or window if it has no border). winfo :screen window Returns the name of the screen associated with window, in the form displayName.screenIndex. winfo :screencells window Returns a decimal string giving the number of cells in the default color map for window's screen. winfo :screendepth window Returns a decimal string giving the depth of the root window of window's screen (number of bits per pixel). winfo :screenheight window Returns a decimal string giving the height of window's screen, in pixels. winfo :screenmmheight window Returns a decimal string giving the height of window's screen, in millimeters. winfo :screenmmwidth window Returns a decimal string giving the width of window's screen, in millimeters. winfo :screenvisual window Returns one of the following strings to indicate the default visual type for window's screen: directcolor, grayscale, pseudocolor, staticcolor, staticgray, or truecolor. winfo :screenwidth window Returns a decimal string giving the width of window's screen, in pixels. winfo :toplevel window Returns the path name of the top-level window containing window. winfo :visual window Returns one of the following strings to indicate the visual type for window: directcolor, grayscale, pseudocolor, staticcolor, staticgray, or truecolor. winfo :vrootheight window Returns the height of the virtual root window associated with window if there is one; otherwise returns the height of window's screen. winfo :vrootwidth window Returns the width of the virtual root window associated with window if there is one; otherwise returns the width of window's screen. winfo :vrootx window Returns the x-offset of the virtual root window associated with window, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for window. winfo :vrooty window Returns the y-offset of the virtual root window associated with window, relative to the root window of its screen. This is normally either zero or negative. Returns 0 if there is no virtual root window for window. winfo :width window Returns a decimal string giving window's width in pixels. When a window is first created its width will be 1 pixel; the width will eventually be changed by a geometry manager to fulfill the window's needs. If you need the true width immediately after creating a widget, invoke update to force the geometry manager to arrange it, or use winfo :reqwidth to get the window's requested width instead of its actual width. winfo :x window Returns a decimal string giving the x-coordinate, in window's parent, of the upper-left corner of window's border (or window if it has no border). winfo :y window Returns a decimal string giving the y-coordinate, in window's parent, of the upper-left corner of window's border (or window if it has no border). Keywords -------- atom, children, class, geometry, height, identifier, information, interpreters, mapped, parent, path name, screen, virtual root, width, window  File: gcl-tk.info, Node: wm, Prev: winfo, Up: Control 3.25 wm ======= wm \- Communicate with window manager Synopsis -------- wm option window ?args? Description ----------- The wm command is used to interact with window managers in order to control such things as the title for a window, its geometry, or the increments in terms of which it may be resized. The wm command can take any of a number of different forms, depending on the option argument. All of the forms expect at least one additional argument, window, which must be the path name of a top-level window. The legal forms for the wm command are: wm :aspect window ?minNumer minDenom maxNumer maxDenom? If minNumer, minDenom, maxNumer, and maxDenom are all specified, then they will be passed to the window manager and the window manager should use them to enforce a range of acceptable aspect ratios for window. The aspect ratio of window (width/length) will be constrained to lie between minNumer/minDenom and maxNumer/maxDenom. If minNumer etc. are all specified as empty strings, then any existing aspect ratio restrictions are removed. If minNumer etc. are specified, then the command returns an empty string. Otherwise, it returns a Tcl list containing four elements, which are the current values of minNumer, minDenom, maxNumer, and maxDenom (if no aspect restrictions are in effect, then an empty string is returned). wm :client window ?name? If name is specified, this command stores name (which should be the name of the host on which the application is executing) in window's WM_CLIENT_MACHINE property for use by the window manager or session manager. The command returns an empty string in this case. If name isn't specified, the command returns the last name set in a wm :client command for window. If name is specified as an empty string, the command deletes the WM_CLIENT_MACHINE property from window. wm :command window ?value? If value is specified, this command stores value in window's WM_COMMAND property for use by the window manager or session manager and returns an empty string. Value must have proper list structure; the elements should contain the words of the command used to invoke the application. If value isn't specified then the command returns the last value set in a wm :command command for window. If value is specified as an empty string, the command deletes the WM_COMMAND property from window. wm :deiconify window Arrange for window to be displayed in normal (non-iconified) form. This is done by mapping the window. If the window has never been mapped then this command will not map the window, but it will ensure that when the window is first mapped it will be displayed in de-iconified form. Returns an empty string. wm :focusmodel window ?active|passive? If active or passive is supplied as an optional argument to the command, then it specifies the focus model for window. In this case the command returns an empty string. If no additional argument is supplied, then the command returns the current focus model for window. An active focus model means that window will claim the input focus for itself or its descendants, even at times when the focus is currently in some other application. Passive means that window will never claim the focus for itself: the window manager should give the focus to window at appropriate times. However, once the focus has been given to window or one of its descendants, the application may re-assign the focus among window's descendants. The focus model defaults to passive, and Tk's focus command assumes a passive model of focussing. wm :frame window If window has been reparented by the window manager into a decorative frame, the command returns the X window identifier for the outermost frame that contains window (the window whose parent is the root or virtual root). If window hasn't been reparented by the window manager then the command returns the X window identifier for window. wm :geometry window ?newGeometry? If newGeometry is specified, then the geometry of window is changed and an empty string is returned. Otherwise the current geometry for window is returned (this is the most recent geometry specified either by manual resizing or in a wm :geometry command). NewGeometry has the form =widthxheight\(+-x\(+-y, where any of =, widthxheight, or \(+-x\(+-y may be omitted. Width and height are positive integers specifying the desired dimensions of window. If window is gridded (see GRIDDED GEOMETRY MANAGEMENT below) then the dimensions are specified in grid units; otherwise they are specified in pixel units. X and y specify the desired location of window on the screen, in pixels. If x is preceded by +, it specifies the number of pixels between the left edge of the screen and the left edge of window's border; if preceded by - then x specifies the number of pixels between the right edge of the screen and the right edge of window's border. If y is preceded by + then it specifies the number of pixels between the top of the screen and the top of window's border; if y is preceded by - then it specifies the number of pixels between the bottom of window's border and the bottom of the screen. If newGeometry is specified as an empty string then any existing user-specified geometry for window is cancelled, and the window will revert to the size requested internally by its widgets. wm :grid window ?baseWidth baseHeight widthInc heightInc? This command indicates that window is to be managed as a gridded window. It also specifies the relationship between grid units and pixel units. BaseWidth and baseHeight specify the number of grid units corresponding to the pixel dimensions requested internally by window using Tk_GeometryRequest. WidthInc and heightInc specify the number of pixels in each horizontal and vertical grid unit. These four values determine a range of acceptable sizes for window, corresponding to grid-based widths and heights that are non-negative integers. Tk will pass this information to the window manager; during manual resizing, the window manager will restrict the window's size to one of these acceptable sizes. Furthermore, during manual resizing the window manager will display the window's current size in terms of grid units rather than pixels. If baseWidth etc. are all specified as empty strings, then window will no longer be managed as a gridded window. If baseWidth etc. are specified then the return value is an empty string. Otherwise the return value is a Tcl list containing four elements corresponding to the current baseWidth, baseHeight, widthInc, and heightInc; if window is not currently gridded, then an empty string is returned. Note: this command should not be needed very often, since the Tk_SetGrid library procedure and the setGrid option provide easier access to the same functionality. wm :group window ?pathName? If pathName is specified, it gives the path name for the leader of a group of related windows. The window manager may use this information, for example, to unmap all of the windows in a group when the group's leader is iconified. PathName may be specified as an empty string to remove window from any group association. If pathName is specified then the command returns an empty string; otherwise it returns the path name of window's current group leader, or an empty string if window isn't part of any group. wm :iconbitmap window ?bitmap? If bitmap is specified, then it names a bitmap in the standard forms accepted by Tk (see the Tk_GetBitmap manual entry for details). This bitmap is passed to the window manager to be displayed in window's icon, and the command returns an empty string. If an empty string is specified for bitmap, then any current icon bitmap is cancelled for window. If bitmap is specified then the command returns an empty string. Otherwise it returns the name of the current icon bitmap associated with window, or an empty string if window has no icon bitmap. wm :iconify window Arrange for window to be iconified. It window hasn't yet been mapped for the first time, this command will arrange for it to appear in the iconified state when it is eventually mapped. wm :iconmask window ?bitmap? If bitmap is specified, then it names a bitmap in the standard forms accepted by Tk (see the Tk_GetBitmap manual entry for details). This bitmap is passed to the window manager to be used as a mask in conjunction with the iconbitmap option: where the mask has zeroes no icon will be displayed; where it has ones, the bits from the icon bitmap will be displayed. If an empty string is specified for bitmap then any current icon mask is cancelled for window (this is equivalent to specifying a bitmap of all ones). If bitmap is specified then the command returns an empty string. Otherwise it returns the name of the current icon mask associated with window, or an empty string if no mask is in effect. wm :iconname window ?newName? If newName is specified, then it is passed to the window manager; the window manager should display newName inside the icon associated with window. In this case an empty string is returned as result. If newName isn't specified then the command returns the current icon name for window, or an empty string if no icon name has been specified (in this case the window manager will normally display the window's title, as specified with the wm :title command). wm :iconposition window ?x y? If x and y are specified, they are passed to the window manager as a hint about where to position the icon for window. In this case an empty string is returned. If x and y are specified as empty strings then any existing icon position hint is cancelled. If neither x nor y is specified, then the command returns a Tcl list containing two values, which are the current icon position hints (if no hints are in effect then an empty string is returned). wm :iconwindow window ?pathName? If pathName is specified, it is the path name for a window to use as icon for window: when window is iconified then pathName should be mapped to serve as icon, and when window is de-iconified then pathName will be unmapped again. If pathName is specified as an empty string then any existing icon window association for window will be cancelled. If the pathName argument is specified then an empty string is returned. Otherwise the command returns the path name of the current icon window for window, or an empty string if there is no icon window currently specified for window. Note: not all window managers support the notion of an icon window. wm :maxsize window ?width height? If width and height are specified, then window becomes resizable and width and height give its maximum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window's dimensions to be less than or equal to width and height. If width and height are specified as empty strings, then the maximum size option is cancelled for window. If width and height are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the maximum width and height currently in effect; if no maximum dimensions are in effect for window then an empty string is returned. See the sections on geometry management below for more information. wm :minsize window ?width height? If width and height are specified, then window becomes resizable and width and height give its minimum permissible dimensions. For gridded windows the dimensions are specified in grid units; otherwise they are specified in pixel units. During manual sizing, the window manager should restrict the window's dimensions to be greater than or equal to width and height. If width and height are specified as empty strings, then the minimum size option is cancelled for window. If width and height are specified, then the command returns an empty string. Otherwise it returns a Tcl list with two elements, which are the minimum width and height currently in effect; if no minimum dimensions are in effect for window then an empty string is returned. See the sections on geometry management below for more information. wm :overrideredirect window ?boolean? If boolean is specified, it must have a proper boolean form and the override-redirect flag for window is set to that value. If boolean is not specified then 1 or 0 is returned to indicate whether or not the override-redirect flag is currently set for window. Setting the override-redirect flag for a window causes it to be ignored by the window manager; among other things, this means that the window will not be reparented from the root window into a decorative frame and the user will not be able to manipulate the window using the normal window manager mechanisms. wm :positionfrom window ?who? If who is specified, it must be either program or user, or an abbreviation of one of these two. It indicates whether window's current position was requested by the program or by the user. Many window managers ignore program-requested initial positions and ask the user to manually position the window; if user is specified then the window manager should position the window at the given place without asking the user for assistance. If who is specified as an empty string, then the current position source is cancelled. If who is specified, then the command returns an empty string. Otherwise it returns user or window to indicate the source of the window's current position, or an empty string if no source has been specified yet. Most window managers interpret "no source" as equivalent to program. Tk will automatically set the position source to user when a wm :geometry command is invoked, unless the source has been set explicitly to program. wm :protocol window ?name? ?command? This command is used to manage window manager protocols such as WM_DELETE_WINDOW. Name is the name of an atom corresponding to a window manager protocol, such as WM_DELETE_WINDOW or WM_SAVE_YOURSELF or WM_TAKE_FOCUS. If both name and command are specified, then command is associated with the protocol specified by name. Name will be added to window's WM_PROTOCOLS property to tell the window manager that the application has a protocol handler for name, and command will be invoked in the future whenever the window manager sends a message to the client for that protocol. In this case the command returns an empty string. If name is specified but command isn't, then the current command for name is returned, or an empty string if there is no handler defined for name. If command is specified as an empty string then the current handler for name is deleted and it is removed from the WM_PROTOCOLS property on window; an empty string is returned. Lastly, if neither name nor command is specified, the command returns a list of all the protocols for which handlers are currently defined for window. Tk always defines a protocol handler for WM_DELETE_WINDOW, even if you haven't asked for one with wm :protocol. If a WM_DELETE_WINDOW message arrives when you haven't defined a handler, then Tk handles the message by destroying the window for which it was received. .RE wm :sizefrom window ?who? If who is specified, it must be either program or user, or an abbreviation of one of these two. It indicates whether window's current size was requested by the program or by the user. Some window managers ignore program-requested sizes and ask the user to manually size the window; if user is specified then the window manager should give the window its specified size without asking the user for assistance. If who is specified as an empty string, then the current size source is cancelled. If who is specified, then the command returns an empty string. Otherwise it returns user or window to indicate the source of the window's current size, or an empty string if no source has been specified yet. Most window managers interpret "no source" as equivalent to program. wm :state window Returns the current state of window: either normal, iconic, or withdrawn. wm :title window ?string? If string is specified, then it will be passed to the window manager for use as the title for window (the window manager should display this string in window's title bar). In this case the command returns an empty string. If string isn't specified then the command returns the current title for the window. The title for a window defaults to its name. wm :transient window ?master? If master is specified, then the window manager is informed that window is a transient window (e.g. pull-down menu) working on behalf of master (where master is the path name for a top-level window). Some window managers will use this information to manage window specially. If master is specified as an empty string then window is marked as not being a transient window any more. If master is specified, then the command returns an empty string. Otherwise the command returns the path name of window's current master, or an empty string if window isn't currently a transient window. wm :withdraw window Arranges for window to be withdrawn from the screen. This causes the window to be unmapped and forgotten about by the window manager. If the window has never been mapped, then this command causes the window to be mapped in the withdrawn state. Not all window managers appear to know how to handle windows that are mapped in the withdrawn state. Note: it sometimes seems to be necessary to withdraw a window and then re-map it (e.g. with wm :deiconify) to get some window managers to pay attention to changes in window attributes such as group. "Sources Of Geometry Information" --------------------------------- Size-related information for top-level windows can come from three sources. First, geometry requests come from the widgets that are descendants of a top-level window. Each widget requests a particular size for itself by calling Tk_GeometryRequest. This information is passed to geometry managers, which then request large enough sizes for parent windows so that they can layout the children properly. Geometry information passes upwards through the window hierarchy until eventually a particular size is requested for each top-level window. These requests are called internal requests in the discussion below. The second source of width and height information is through the wm :geometry command. Third, the user can request a particular size for a window using the interactive facilities of the window manager. The second and third types of geometry requests are called external requests in the discussion below; Tk treats these two kinds of requests identically. "Ungridded Geometry Management" ------------------------------- Tk allows the geometry of a top-level window to be managed in either of two general ways: ungridded or gridded. The ungridded form occurs if no wm :grid command has been issued for a top-level window. Ungridded management has several variants. In the simplest variant of ungridded windows, no wm :geometry, wm :minsize, or wm :maxsize commands have been invoked either. In this case, the window's size is determined totally by the internal requests emanating from the widgets inside the window: Tk will ask the window manager not to permit the user to resize the window interactively. If a wm :geometry command is invoked on an ungridded window, then the size in that command overrides any size requested by the window's widgets; from now on, the window's size will be determined entirely by the most recent information from wm :geometry commands. To go back to using the size requested by the window's widgets, issue a wm :geometry command with an empty geometry string. To enable interactive resizing of an ungridded window, one or both of the wm :maxsize and wm :minsize commands must be issued. The information from these commands will be passed to the window manager, and size changes within the specified range will be permitted. For ungridded windows the limits refer to the top-level window's dimensions in pixels. If only a wm :maxsize command is issued then the minimum dimensions default to 1; if only a wm :minsize command is issued then the maximum dimensions default to the size of the display. If the size of a window is changed interactively, it has the same effect as if wm :geometry had been invoked: from now on, internal geometry requests will be ignored. To return to internal control over the window's size, issue a wm :geometry command with an empty geometry argument. If a window has been manually resized or moved, the wm :geometry command will return the geometry that was requested interactively. "Gridded Geometry Management" ----------------------------- The second style of geometry management is called gridded. This approach occurs when one of the widgets of an application supports a range of useful sizes. This occurs, for example, in a text editor where the scrollbars, menus, and other adornments are fixed in size but the edit widget can support any number of lines of text or characters per line. In this case, it is usually desirable to let the user specify the number of lines or characters-per-line, either with the wm :geometry command or by interactively resizing the window. In the case of text, and in other interesting cases also, only discrete sizes of the window make sense, such as integral numbers of lines and characters-per-line; arbitrary pixel sizes are not useful. Gridded geometry management provides support for this kind of application. Tk (and the window manager) assume that there is a grid of some sort within the application and that the application should be resized in terms of grid units rather than pixels. Gridded geometry management is typically invoked by turning on the setGrid option for a widget; it can also be invoked with the wm :grid command or by calling Tk_SetGrid. In each of these approaches the particular widget (or sometimes code in the application as a whole) specifies the relationship between integral grid sizes for the window and pixel sizes. To return to non-gridded geometry management, invoke wm :grid with empty argument strings. When gridded geometry management is enabled then all the dimensions specified in wm :minsize, wm :maxsize, and wm :geometry commands are treated as grid units rather than pixel units. Interactive resizing is automatically enabled, and it will be carried out in even numbers of grid units rather than pixels. By default there are no limits on the minimum or maximum dimensions of a gridded window. As with ungridded windows, interactive resizing has exactly the same effect as invoking the wm :geometry command. For gridded windows, internally- and externally-requested dimensions work together: the externally-specified width and height determine the size of the window in grid units, and the information from the last wm :grid command maps from grid units to pixel units. Bugs ---- The window manager interactions seem too complicated, especially for managing geometry. Suggestions on how to simplify this would be greatly appreciated. Most existing window managers appear to have bugs that affect the operation of the wm command. For example, some changes won't take effect if the window is already active: the window will have to be withdrawn and de-iconified in order to make the change happen. Keywords -------- aspect ratio, deiconify, focus model, geometry, grid, group, icon, iconify, increments, position, size, title, top-level window, units, window manager gcl-2.6.14/info/widgets.texi0000755000175000017500000061634514360276512014311 0ustar cammcamm@c Copyright (c) 1994 William Schelter. @c Copyright (c) 1990 The Regents of the University of California. @c All rights reserved. @c @c Permission is hereby granted, without written agreement and without @c license or royalty fees, to use, copy, modify, and distribute this @c documentation for any purpose, provided that the above copyright @c notice and the following two paragraphs appear in all copies. @c @c IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY @c FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES @c ARISING OUT OF THE USE OF THIS DOCUMENTATION, EVEN IF THE UNIVERSITY OF @c CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @c @c THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, @c INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY @c AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS @c ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO @c PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. @node Widgets, Control, General, Top @chapter Widgets @menu * button:: * listbox:: * scale:: * canvas:: * menu:: * scrollbar:: * checkbutton:: * menubutton:: * text:: * entry:: * message:: * frame:: * label:: * radiobutton:: * toplevel:: @end menu @node button, listbox, Widgets, Widgets @section button @c @cartouche button \- Create and manipulate button widgets @unnumberedsubsec Synopsis @b{button}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Button @table @asis @item @code{@b{:command}} @flushright Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. @end table @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of three states for the button: @b{normal}@r{, }@b{active}, or @b{disabled}. In normal state the button is displayed using the @b{foreground}@r{ and }@b{background} options. The active state is typically used when the pointer is over the button. In active state the button is displayed using the @b{activeForeground} and @b{activeBackground} options. Disabled state means that the button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the @b{disabledForeground} and @b{background} options determine how the button is displayed. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. @end table @c @end cartouche @unnumberedsubsec Description The @b{button} command creates a new window (given by the @i{pathName} argument) and makes it into a button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the button such as its colors, font, text, and initial relief. The @b{button} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A button is a widget that displays a textual string or bitmap. It can display itself in either of three different ways, according to the @b{state} option; it can be made to appear raised, sunken, or flat; and it can be made to flash. When a user invokes the button (by pressing mouse button 1 with the cursor over the button), then the Tcl command specified in the @b{:command} option is invoked. @unnumberedsubsec A Button Widget's Arguments The @b{button} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for button widgets: @table @asis @item @i{pathName }@b{:activate} Change the button's state to @b{active} and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state active}'' instead. @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{button} command. @item @i{pathName }@b{:deactivate} Change the button's state to @b{normal} and redisplay the button using its normal foreground and background colors. This command is ignored if the button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state normal}'' instead. @item @i{pathName }@b{:flash} Flash the button. This is accomplished by redisplaying the button several times, alternating between active and normal colors. At the end of the flash the button is left in the same normal/active state as when the command was invoked. This command is ignored if the button's state is @b{disabled}. @item @i{pathName }@b{:invoke} Invoke the Tcl command associated with the button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the button. This command is ignored if the button's state is @b{disabled}. @end table @unnumberedsubsec "Default Bindings" Tk automatically creates class bindings for buttons that give them the following default behavior: @itemize @asis{} @item [1] The button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the button. @item [2] The button's relief is changed to sunken whenever mouse button 1 is pressed over the button, and the relief is restored to its original value when button 1 is later released. @item [3] If mouse button 1 is pressed over the button and later released over the button, the button is invoked. However, if the mouse is not over the button when button 1 is released, then no invocation occurs. @end itemize If the button's state is @b{disabled} then none of the above actions occur: the button is completely non-responsive. The behavior of buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Keywords button, widget @node listbox, scale, button, Widgets @section listbox @c @cartouche listbox \- Create and manipulate listbox widgets @unnumberedsubsec Synopsis @b{listbox}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example background foreground selectBackground xScrollCommand borderWidth font selectBorderWidth yScrollCommand cursor geometry selectForeground exportSelection relief setGrid @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Listbox None. @c @end cartouche @unnumberedsubsec Description The @b{listbox} command creates a new window (given by the @i{pathName} argument) and makes it into a listbox widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the listbox such as its colors, font, text, and relief. The @b{listbox} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A listbox is a widget that displays a list of strings, one per line. When first created, a new listbox has no elements in its list. Elements may be added or deleted using widget commands described below. In addition, one or more elements may be selected as described below. If a listbox is exporting its selection (see @b{exportSelection} option), then it will observe the standard X11 protocols for handling the selection; listbox selections are available as type @b{STRING}, consisting of a Tcl list with one entry for each selected element. For large lists only a subset of the list elements will be displayed in the listbox window at once; commands described below may be used to change the view in the window. Listboxes allow scrolling in both directions using the standard @b{xScrollCommand} and @b{yScrollCommand} options. They also support scanning, as described below. @unnumberedsubsec A Listbox's Arguments The @b{listbox} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for listbox widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{listbox} command. @item @i{pathName }@b{:curselection} Returns a list containing the indices of all of the elements in the listbox that are currently selected. If there are no elements selected in the listbox then an empty string is returned. @item @i{pathName }@b{:delete }@i{first }@r{?}@i{last}? Delete one or more elements of the listbox. @i{First}@r{ and }@i{last} give the integer indices of the first and last elements in the range to be deleted. If @i{last} isn't specified it defaults to @i{first}, i.e. a single element is deleted. An index of @b{0} corresponds to the first element in the listbox. Either @i{first}@r{ or }@i{last}@r{ may be specified as }@b{end}, in which case it refers to the last element of the listbox. This command returns an empty string @item @i{pathName }@b{:get }@i{index} Return the contents of the listbox element indicated by @i{index}. @i{Index} must be a non-negative integer (0 corresponds to the first element in the listbox), or it may also be specified as @b{end} to indicate the last element in the listbox. @item @i{pathName }@b{:insert }@i{index }@r{?}@i{element element ...}? Insert zero or more new elements in the list just before the element given by @i{index}@r{. If }@i{index} is specified as @b{end} then the new elements are added to the end of the list. Returns an empty string. @item @i{pathName }@b{:nearest }@i{y} Given a y-coordinate within the listbox window, this command returns the index of the (visible) listbox element nearest to that y-coordinate. @item @i{pathName }@b{:scan}@r{ }@i{option args} This command is used to implement scanning on listboxes. It has two forms, depending on @i{option}: @table @asis @item @i{pathName }@b{:scan :mark }@i{x y} Records @i{x}@r{ and }@i{y} and the current view in the listbox window; used in conjunction with later @b{scan dragto} commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. @item @i{pathName }@b{:scan :dragto }@i{x y}. This command computes the difference between its @i{x}@r{ and }@i{y} arguments and the @i{x}@r{ and }@i{y} arguments to the last @b{scan mark} command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the list at high speed through the window. The return value is an empty string. @end table @item @i{pathName }@b{:select }@i{option arg} This command is used to adjust the selection within a listbox. It has several forms, depending on @i{option}. In all of the forms the index @b{end} refers to the last element in the listbox. @table @asis @item @i{pathName }@b{:select :adjust }@i{index} Locate the end of the selection nearest to the element given by @i{index}@r{, and adjust that end of the selection to be at }@i{index} (i.e including but not going beyond @i{index}). The other end of the selection is made the anchor point for future @b{select to} commands. If the selection isn't currently in the listbox, then this command is identical to the @b{select from} widget command. Returns an empty string. @item @i{pathName }@b{:select :clear} If the selection is in this listbox then it is cleared so that none of the listbox's elements are selected anymore. @item @i{pathName }@b{:select :from }@i{index} Set the selection to consist of element @i{index}, and make @i{index}@r{ the anchor point for future }@b{select to} widget commands. Returns an empty string. @item @i{pathName }@b{:select :to }@i{index} Set the selection to consist of the elements from the anchor point to element @i{index}, inclusive. The anchor point is determined by the most recent @b{select from}@r{ or }@b{select adjust} command in this widget. If the selection isn't in this widget, this command is identical to @b{select from}. Returns an empty string. @end table @item @i{pathName }@b{:size} Returns a decimal string indicating the total number of elements in the listbox. @item @i{pathName }@b{:xview }@i{index} Adjust the view in the listbox so that character position @i{index} is displayed at the left edge of the widget. Returns an empty string. @item @i{pathName }@b{:yview }@i{index} Adjust the view in the listbox so that element @i{index} is displayed at the top of the widget. If @i{index}@r{ is specified as }@b{end} it indicates the last element of the listbox. Returns an empty string. @end table @unnumberedsubsec "Default Bindings" Tk automatically creates class bindings for listboxes that give them the following default behavior: @itemize @asis{} @item [1] When button 1 is pressed over a listbox, the element underneath the mouse cursor is selected. The mouse can be dragged to select a range of elements. @item [2] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. @item [3] The view in the listbox can be adjusted by dragging with mouse button 2. @end itemize The behavior of listboxes can be changed by defining new bindings for individual widgets or by redefining the class bindings. In addition, the procedure @b{tk_listboxSingleSelect} may be invoked to change listbox behavior so that only a single element may be selected at once. @unnumberedsubsec Keywords listbox, widget @node scale, canvas, listbox, Widgets @section scale @c @cartouche scale \- Create and manipulate scale widgets @unnumberedsubsec Synopsis @b{scale}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeForeground borderWidth font orient background cursor foreground relief @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Scale @table @asis @item @code{@b{:command}} @flushright Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 Specifies the prefix of a Tcl command to invoke whenever the value of the scale is changed interactively. The actual command consists of this option followed by a space and a number. The number indicates the new value of the scale. @end table @table @asis @item @code{@b{:from}} @flushright Name=@code{"@b{from}@r{"} Class=@code{"}@b{From}"} @end flushright @sp 1 Specifies the value corresponding to the left or top end of the scale. Must be an integer. @end table @table @asis @item @code{@b{:label}} @flushright Name=@code{"@b{label}@r{"} Class=@code{"}@b{Label}"} @end flushright @sp 1 Specifies a string to displayed as a label for the scale. For vertical scales the label is displayed just to the right of the top end of the scale. For horizontal scales the label is displayed just above the left end of the scale. @end table @table @asis @item @code{@b{:length}} @flushright Name=@code{"@b{length}@r{"} Class=@code{"}@b{Length}"} @end flushright @sp 1 Specifies the desired long dimension of the scale in screen units, that is in any of the forms acceptable to @b{Tk_GetPixels}. For vertical scales this is the scale's height; for horizontal scales it is the scale's width. @end table @table @asis @item @code{@b{:showvalue}} @flushright Name=@code{"@b{showValue}@r{"} Class=@code{"}@b{ShowValue}"} @end flushright @sp 1 Specifies a boolean value indicating whether or not the current value of the scale is to be displayed. @end table @table @asis @item @code{@b{:sliderforeground}} @flushright Name=@code{"@b{sliderForeground}@r{"} Class=@code{"}@b{sliderForeground}"} @end flushright @sp 1 Specifies the color to use for drawing the slider under normal conditions. When the mouse is in the slider window then the slider's color is determined by the @b{activeForeground} option. @end table @table @asis @item @code{@b{:sliderlength}} @flushright Name=@code{"@b{sliderLength}@r{"} Class=@code{"}@b{SliderLength}"} @end flushright @sp 1 Specfies the size of the slider, measured in screen units along the slider's long dimension. The value may be specified in any of the forms acceptable to @b{Tk_GetPixels}. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of two states for the scale: @b{normal}@r{ or }@b{disabled}. If the scale is disabled then the value may not be changed and the scale won't activate when the mouse enters it. @end table @table @asis @item @code{@b{:tickinterval}} @flushright Name=@code{"@b{tickInterval}@r{"} Class=@code{"}@b{TickInterval}"} @end flushright @sp 1 Must be an integer value. Determines the spacing between numerical tick-marks displayed below or to the left of the slider. If specified as 0, then no tick-marks will be displayed. @end table @table @asis @item @code{@b{:to}} @flushright Name=@code{"@b{to}@r{"} Class=@code{"}@b{To}"} @end flushright @sp 1 Specifies the value corresponding to the right or bottom end of the scale. Must be an integer. This value may be either less than or greater than the @b{from} option. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies the desired narrow dimension of the scale in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}). For vertical scales this is the scale's width; for horizontal scales this is the scale's height. @end table @c @end cartouche @unnumberedsubsec Description The @b{scale} command creates a new window (given by the @i{pathName} argument) and makes it into a scale widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scale such as its colors, orientation, and relief. The @b{scale} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A scale is a widget that displays a rectangular region and a small @i{slider}. The rectangular region corresponds to a range of integer values (determined by the @b{from}@r{ and }@b{to} options), and the position of the slider selects a particular integer value. The slider's position (and hence the scale's value) may be adjusted by clicking or dragging with the mouse as described in the BINDINGS section below. Whenever the scale's value is changed, a Tcl command is invoked (using the @b{command} option) to notify other interested widgets of the change. Three annotations may be displayed in a scale widget: a label appearing at the top-left of the widget (top-right for vertical scales), a number displayed just underneath the slider (just to the left of the slider for vertical scales), and a collection of numerical tick-marks just underneath the current value (just to the left of the current value for vertical scales). Each of these three annotations may be selectively enabled or disabled using the configuration options. @unnumberedsubsec A Scale's"Argumentsommand" The @b{scale} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for scale widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{scale} command. @item @i{pathName }@b{:get} Returns a decimal string giving the current value of the scale. @item @i{pathName }@b{:set}@r{ }@i{value} This command is invoked to change the current value of the scale, and hence the position at which the slider is displayed. @i{Value} gives the new value for the scale. @end table @unnumberedsubsec Bindings When a new scale is created, it is given the following initial behavior by default: @table @asis @item @b{} Change the slider display to use @b{activeForeground} instead of @b{sliderForeground}. @item @b{} Reset the slider display to use @b{sliderForeground} instead of @b{activeForeground}. @item @b{} Change the slider display so that the slider appears sunken rather than raised. Move the slider (and adjust the scale's value) to correspond to the current mouse position. @item @b{} Move the slider (and adjust the scale's value) to correspond to the current mouse position. @item @b{} Reset the slider display so that the slider appears raised again. @end table @unnumberedsubsec Keywords scale, widget @node canvas, menu, scale, Widgets @section canvas @c @cartouche canvas \- Create and manipulate canvas widgets @unnumberedsubsec Synopsis @b{canvas}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example background insertBorderWidth relief xScrollCommand borderWidth insertOffTime selectBackground yScrollCommand cursor insertOnTime selectBorderWidth insertBackground insertWidth selectForeground @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Canvas @table @asis @item @code{@b{:closeenough}} @flushright Name=@code{"@b{closeEnough}@r{"} Class=@code{"}@b{CloseEnough}"} @end flushright @sp 1 Specifies a floating-point value indicating how close the mouse cursor must be to an item before it is considered to be ``inside'' the item. Defaults to 1.0. @end table @table @asis @item @code{@b{:confine}} @flushright Name=@code{"@b{confine}@r{"} Class=@code{"}@b{Confine}"} @end flushright @sp 1 Specifies a boolean value that indicates whether or not it should be allowable to set the canvas's view outside the region defined by the @b{scrollRegion} argument. Defaults to true, which means that the view will be constrained within the scroll region. @end table @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired window height that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. @end table @table @asis @item @code{@b{:scrollincrement}} @flushright Name=@code{"@b{scrollIncrement}@r{"} Class=@code{"}@b{ScrollIncrement}"} @end flushright @sp 1 Specifies a distance used as increment during scrolling: when one of the arrow buttons on an associated scrollbar is pressed, the picture will shift by this distance. The distance may be specified in any of the forms described in the COORDINATES section below. @end table @table @asis @item @code{@b{:scrollregion}} @flushright Name=@code{"@b{scrollRegion}@r{"} Class=@code{"}@b{ScrollRegion}"} @end flushright @sp 1 Specifies a list with four coordinates describing the left, top, right, and bottom coordinates of a rectangular region. This region is used for scrolling purposes and is considered to be the boundary of the information in the canvas. Each of the coordinates may be specified in any of the forms given in the COORDINATES section below. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{width}"} @end flushright @sp 1 Specifies a desired window width that the canvas widget should request from its geometry manager. The value may be specified in any of the forms described in the COORDINATES section below. @end table @c @end cartouche @unnumberedsubsec Introduction The @b{canvas} command creates a new window (given by the @i{pathName} argument) and makes it into a canvas widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the canvas such as its colors and 3-D relief. The @b{canvas} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. Canvas widgets implement structured graphics. A canvas displays any number of @i{items}, which may be things like rectangles, circles, lines, and text. Items may be manipulated (e.g. moved or re-colored) and commands may be associated with items in much the same way that the @b{bind} command allows commands to be bound to widgets. For example, a particular command may be associated with the event so that the command is invoked whenever button 1 is pressed with the mouse cursor over an item. This means that items in a canvas can have behaviors defined by the Tcl scripts bound to them. @unnumberedsubsec Display List The items in a canvas are ordered for purposes of display, with the first item in the display list being displayed first, followed by the next item in the list, and so on. Items later in the display list obscure those that are earlier in the display list and are sometimes referred to as being ``on top'' of earlier items. When a new item is created it is placed at the end of the display list, on top of everything else. Widget commands may be used to re-arrange the order of the display list. @unnumberedsubsec Item Ids And Tags Items in a canvas widget may be named in either of two ways: by id or by tag. Each item has a unique identifying number which is assigned to that item when it is created. The id of an item never changes and id numbers are never re-used within the lifetime of a canvas widget. Each item may also have any number of @i{tags} associated with it. A tag is just a string of characters, and it may take any form except that of an integer. For example, ``x123'' is OK but ``123'' isn't. The same tag may be associated with many different items. This is commonly done to group items in various interesting ways; for example, all selected items might be given the tag ``selected''. The tag @b{all} is implicitly associated with every item in the canvas; it may be used to invoke operations on all the items in the canvas. The tag @b{current} is managed automatically by Tk; it applies to the @i{current item}, which is the topmost item whose drawn area covers the position of the mouse cursor. If the mouse is not in the canvas widget or is not over an item, then no item has the @b{current} tag. When specifying items in canvas widget commands, if the specifier is an integer then it is assumed to refer to the single item with that id. If the specifier is not an integer, then it is assumed to refer to all of the items in the canvas that have a tag matching the specifier. The symbol @i{tagOrId} is used below to indicate that an argument specifies either an id that selects a single item or a tag that selects zero or more items. Some widget commands only operate on a single item at a time; if @i{tagOrId} is specified in a way that names multiple items, then the normal behavior is for the command to use the first (lowest) of these items in the display list that is suitable for the command. Exceptions are noted in the widget command descriptions below. @unnumberedsubsec Coordinates All coordinates related to canvases are stored as floating-point numbers. Coordinates and distances are specified in screen units, which are floating-point numbers optionally followed by one of several letters. If no letter is supplied then the distance is in pixels. If the letter is @b{m} then the distance is in millimeters on the screen; if it is @b{c} then the distance is in centimeters; @b{i}@r{ means inches, and }@b{p} means printers points (1/72 inch). Larger y-coordinates refer to points lower on the screen; larger x-coordinates refer to points farther to the right. @unnumberedsubsec Transformations Normally the origin of the canvas coordinate system is at the upper-left corner of the window containing the canvas. It is possible to adjust the origin of the canvas coordinate system relative to the origin of the window using the @b{xview}@r{ and }@b{yview} widget commands; this is typically used for scrolling. Canvases do not support scaling or rotation of the canvas coordinate system relative to the window coordinate system. Indidividual items may be moved or scaled using widget commands described below, but they may not be rotated. @unnumberedsubsec Indices Text items support the notion of an @i{index} for identifying particular positions within the item. Indices are used for commands such as inserting text, deleting a range of characters, and setting the insertion cursor position. An index may be specified in any of a number of ways, and different types of items may support different forms for specifying indices. Text items support the following forms for an index; if you define new types of text-like items, it would be advisable to support as many of these forms as practical. Note that it is possible to refer to the character just after the last one in the text item; this is necessary for such tasks as inserting new text at the end of the item. @table @asis @item @i{number} A decimal number giving the position of the desired character within the text item. 0 refers to the first character, 1 to the next character, and so on. A number less than 0 is treated as if it were zero, and a number greater than the length of the text item is treated as if it were equal to the length of the text item. @item @b{end} Refers to the character just after the last one in the item (same as the number of characters in the item). @item @b{insert} Refers to the character just before which the insertion cursor is drawn in this item. @item @b{sel.first} Refers to the first selected character in the item. If the selection isn't in this item then this form is illegal. @item @b{sel.last} Refers to the last selected character in the item. If the selection isn't in this item then this form is illegal. @item @b{@@}@i{x,y} Refers to the character at the point given by @i{x} and @i{y}@r{, where }@i{x}@r{ and }@i{y} are specified in the coordinate system of the canvas. If @i{x}@r{ and }@i{y} lie outside the coordinates covered by the text item, then they refer to the first or last character in the line that is closest to the given point. @end table @unnumberedsubsec A Canvas Widget's Arguments The @b{canvas} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following widget commands are possible for canvas widgets: @table @asis @item @i{pathName }@b{:addtag }@i{tag searchSpec }@r{?}@i{arg arg ...}? For each item that meets the constraints specified by @i{searchSpec}@r{ and the }@i{arg}s, add @i{tag} to the list of tags associated with the item if it isn't already present on that list. It is possible that no items will satisfy the constraints given by @i{searchSpec and }@i{arg}s, in which case the command has no effect. This command returns an empty string as result. @i{SearchSpec}@r{ and }@i{arg}'s may take any of the following forms: @table @asis @item @b{above }@i{tagOrId} Selects the item just after (above) the one given by @i{tagOrId} in the display list. If @i{tagOrId} denotes more than one item, then the last (topmost) of these items in the display list is used. @item @b{all} Selects all the items in the canvas. @item @b{below }@i{tagOrId} Selects the item just before (below) the one given by @i{tagOrId} in the display list. If @i{tagOrId} denotes more than one item, then the first (lowest) of these items in the display list is used. @item @b{closest }@i{x y }@r{?}@i{halo}@r{? ?}@i{start}? Selects the item closest to the point given by @i{x}@r{ and }@i{y}. If more than one item is at the same closest distance (e.g. two items overlap the point), then the top-most of these items (the last one in the display list) is used. If @i{halo} is specified, then it must be a non-negative value. Any item closer than @i{halo} to the point is considered to overlap it. The @i{start} argument may be used to step circularly through all the closest items. If @i{start} is specified, it names an item using a tag or id (if by tag, it selects the first item in the display list with the given tag). Instead of selecting the topmost closest item, this form will select the topmost closest item that is below @i{start} in the display list; if no such item exists, then the selection behaves as if the @i{start} argument had not been specified. @item @b{enclosed}@r{ }@i{x1}@r{ }@i{y1}@r{ }@i{x2}@r{ }@i{y2} Selects all the items completely enclosed within the rectangular region given by @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. @i{X1}@r{ must be no greater then }@i{x2}@r{ and }@i{y1} must be no greater than @i{y2}. @item @b{overlapping}@r{ }@i{x1}@r{ }@i{y1}@r{ }@i{x2}@r{ }@i{y2} Selects all the items that overlap or are enclosed within the rectangular region given by @i{x1}@r{, }@i{y1}@r{, }@i{x2}, and @i{y2}. @i{X1}@r{ must be no greater then }@i{x2}@r{ and }@i{y1} must be no greater than @i{y2}. @item @b{withtag }@i{tagOrId} Selects all the items given by @i{tagOrId}. @end table @item @i{pathName }@b{:bbox }@i{tagOrId}@r{ ?}@i{tagOrId tagOrId ...}? Returns a list with four elements giving an approximate bounding box for all the items named by the @i{tagOrId} arguments. The list has the form ``@i{x1 y1 x2 y2}'' such that the drawn areas of all the named elements are within the region bounded by @i{x1}@r{ on the left, }@i{x2}@r{ on the right, }@i{y1} on the top, and @i{y2} on the bottom. The return value may overestimate the actual bounding box by a few pixels. If no items match any of the @i{tagOrId} arguments then an empty string is returned. @item @i{pathName }@b{:bind }@i{tagOrId}@r{ ?}@i{sequence}@r{? ?}@i{command}? This command associates @i{command} with all the items given by @i{tagOrId} such that whenever the event sequence given by @i{sequence} occurs for one of the items the command will be invoked. This widget command is similar to the @b{bind} command except that it operates on items in a canvas rather than entire widgets. See the @b{bind} manual entry for complete details on the syntax of @i{sequence} and the substitutions performed on @i{command} before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same @i{sequence}@r{ and }@i{tagOrId} (if the first character of @i{command}@r{ is ``+'' then }@i{command} augments an existing binding rather than replacing it). In this case the return value is an empty string. If @i{command}@r{ is omitted then the command returns the }@i{command} associated with @i{tagOrId}@r{ and }@i{sequence} (an error occurs if there is no such binding). If both @i{command}@r{ and }@i{sequence} are omitted then the command returns a list of all the sequences for which bindings have been defined for @i{tagOrId}. @end table The only events for which bindings may be specified are those related to the mouse and keyboard, such as @b{Enter}@r{, }@b{Leave}, @b{ButtonPress}@r{, }@b{Motion}@r{, and }@b{KeyPress}. The handling of events in canvases uses the current item defined in ITEM IDS AND TAGS above. @b{Enter}@r{ and }@b{Leave} events trigger for an item when it becomes the current item or ceases to be the current item; note that these events are different than @b{Enter}@r{ and }@b{Leave} events for windows. Mouse-related events are directed to the current item, if any. Keyboard-related events are directed to the focus item, if any (see the @b{focus} widget command below for more on this). It is possible for multiple commands to be bound to a single event sequence for a single object. This occurs, for example, if one command is associated with the item's id and another is associated with one of the item's tags. When this occurs, the first matching binding is used. A binding for the item's id has highest priority, followed by the oldest tag for the item and proceeding through all of the item's tags up through the most-recently-added one. If a binding is associated with the tag @b{all}, the binding will have lower priority than all other bindings associated with the item. @table @asis @item @i{pathName }@b{:canvasx }@i{screenx}@r{ ?}@i{gridspacing}? Given a screen x-coordinate @i{screenx} this command returns the canvas x-coordinate that is displayed at that location. If @i{gridspacing} is specified, then the canvas coordinate is rounded to the nearest multiple of @i{gridspacing} units. @item @i{pathName }@b{:canvasy }@i{screeny}@r{ ?}@i{gridspacing}? Given a screen y-coordinate @i{screeny} this command returns the canvas y-coordinate that is displayed at that location. If @i{gridspacing} is specified, then the canvas coordinate is rounded to the nearest multiple of @i{gridspacing} units. @item @i{pathName }@b{:configure ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{canvas} command. @item @i{pathName}@r{ }@b{:coords }@i{tagOrId }@r{?}@i{x0 y0 ...}? Query or modify the coordinates that define an item. If no coordinates are specified, this command returns a list whose elements are the coordinates of the item named by @i{tagOrId}. If coordinates are specified, then they replace the current coordinates for the named item. If @i{tagOrId} refers to multiple items, then the first one in the display list is used. @item @i{pathName }@b{:create }@i{type x y }@r{?}@i{x y ...}@r{? ?}@i{option value ...}? Create a new item in @i{pathName}@r{ of type }@i{type}. The exact format of the arguments after @b{type} depends on @b{type}, but usually they consist of the coordinates for one or more points, followed by specifications for zero or more item options. See the subsections on individual item types below for more on the syntax of this command. This command returns the id for the new item. @item @i{pathName }@b{:dchars }@i{tagOrId first }@r{?}@i{last}? For each item given by @i{tagOrId}, delete the characters in the range given by @i{first}@r{ and }@i{last}, inclusive. If some of the items given by @i{tagOrId} don't support text operations, then they are ignored. @i{First}@r{ and }@i{last} are indices of characters within the item(s) as described in INDICES above. If @i{last}@r{ is omitted, it defaults to }@i{first}. This command returns an empty string. @item @i{pathName }@b{:delete }@r{?}@i{tagOrId tagOrId ...}? Delete each of the items given by each @i{tagOrId}, and return an empty string. @item @i{pathName }@b{:dtag }@i{tagOrId }@r{?tagToDelete}? For each of the items given by @i{tagOrId}, delete the tag given by @i{tagToDelete} from the list of those associated with the item. If an item doesn't have the tag @i{tagToDelete} then the item is unaffected by the command. If @i{tagToDelete}@r{ is omitted then it defaults to }@i{tagOrId}. This command returns an empty string. @item @i{pathName }@b{:find }@i{searchCommand }@r{?}@i{arg arg ...}? This command returns a list consisting of all the items that meet the constraints specified by @i{searchCommand} and @i{arg}'s. @i{SearchCommand}@r{ and }@i{args} have any of the forms accepted by the @b{addtag} command. @item @i{pathName }@b{:focus }@r{?}@i{tagOrId}? Set the keyboard focus for the canvas widget to the item given by @i{tagOrId}. If @i{tagOrId} refers to several items, then the focus is set to the first such item in the display list that supports the insertion cursor. If @i{tagOrId} doesn't refer to any items, or if none of them support the insertion cursor, then the focus isn't changed. If @i{tagOrId} is an empty string, then the focus item is reset so that no item has the focus. If @i{tagOrId} is not specified then the command returns the id for the item that currently has the focus, or an empty string if no item has the focus. @end table Once the focus has been set to an item, the item will display the insertion cursor and all keyboard events will be directed to that item. The focus item within a canvas and the focus window on the screen (set with the @b{focus} command) are totally independent: a given item doesn't actually have the input focus unless (a) its canvas is the focus window and (b) the item is the focus item within the canvas. In most cases it is advisable to follow the @b{focus} widget command with the @b{focus} command to set the focus window to the canvas (if it wasn't there already). @table @asis @item @i{pathName }@b{:gettags}@r{ }@i{tagOrId} Return a list whose elements are the tags associated with the item given by @i{tagOrId}. If @i{tagOrId} refers to more than one item, then the tags are returned from the first such item in the display list. If @i{tagOrId} doesn't refer to any items, or if the item contains no tags, then an empty string is returned. @item @i{pathName }@b{:icursor }@i{tagOrId index} Set the position of the insertion cursor for the item(s) given by @i{tagOrId} to just before the character whose position is given by @i{index}. If some or all of the items given by @i{tagOrId} don't support an insertion cursor then this command has no effect on them. See INDICES above for a description of the legal forms for @i{index}. Note: the insertion cursor is only displayed in an item if that item currently has the keyboard focus (see the widget command @b{focus}, below), but the cursor position may be set even when the item doesn't have the focus. This command returns an empty string. @item @i{pathName }@b{:index }@i{tagOrId index} This command returns a decimal string giving the numerical index within @i{tagOrId}@r{ corresponding to }@i{index}. @i{Index} gives a textual description of the desired position as described in INDICES above. The return value is guaranteed to lie between 0 and the number of characters within the item, inclusive. If @i{tagOrId} refers to multiple items, then the index is processed in the first of these items that supports indexing operations (in display list order). @item @i{pathName }@b{:insert }@i{tagOrId beforeThis string} For each of the items given by @i{tagOrId}, if the item supports text insertion then @i{string} is inserted into the item's text just before the character whose index is @i{beforeThis}. See INDICES above for information about the forms allowed for @i{beforeThis}. This command returns an empty string. @item @i{pathName }@b{:itemconfigure }@i{tagOrId}@r{ ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? This command is similar to the @b{configure} widget command except that it modifies item-specific options for the items given by @i{tagOrId} instead of modifying options for the overall canvas widget. If no @i{option} is specified, returns a list describing all of the available options for the first item given by @i{tagOrId} (see @b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s) in each of the items given by @i{tagOrId}; in this case the command returns an empty string. The @i{option}@r{s and }@i{value}s are the same as those permissible in the @b{create} widget command when the item(s) were created; see the sections describing individual item types below for details on the legal options. @item @i{pathName }@b{:lower }@i{tagOrId }@r{?}@i{belowThis}? Move all of the items given by @i{tagOrId} to a new position in the display list just before the item given by @i{belowThis}. If @i{tagOrId} refers to more than one item then all are moved but the relative order of the moved items will not be changed. @i{BelowThis} is a tag or id; if it refers to more than one item then the first (lowest) of these items in the display list is used as the destination location for the moved items. This command returns an empty string. @item @i{pathName }@b{:move }@i{tagOrId xAmount yAmount} Move each of the items given by @i{tagOrId} in the canvas coordinate space by adding @i{xAmount} to the x-coordinate of each point associated with the item and @i{yAmount} to the y-coordinate of each point associated with the item. This command returns an empty string. @item @i{pathName }@b{:postscript }@r{?}@i{option value option value ...}? Generate a Postscript representation for part or all of the canvas. If the @b{:file} option is specified then the Postscript is written to a file and an empty string is returned; otherwise the Postscript is returned as the result of the command. The Postscript is created in Encapsulated Postscript form using version 3.0 of the Document Structuring Conventions. The @i{option}\-@i{value} argument pairs provide additional information to control the generation of Postscript. The following options are supported: @table @asis @item @b{:colormap }@i{varName} @i{VarName} must be the name of a global array variable that specifies a color mapping to use in the Postscript. Each element of @i{varName} must consist of Postscript code to set a particular color value (e.g. ``@b{1.0 1.0 0.0 setrgbcolor}''). When outputting color information in the Postscript, Tk checks to see if there is an element of @i{varName} with the same name as the color. If so, Tk uses the value of the element as the Postscript command to set the color. If this option hasn't been specified, or if there isn't an entry in @i{varName} for a given color, then Tk uses the red, green, and blue intensities from the X color. @item @b{:colormode }@i{mode} Specifies how to output color information. @i{Mode} must be either @b{color}@r{ (for full color output), }@b{gray} (convert all colors to their gray-scale equivalents) or @b{mono} (convert all colors to black or white). @item @b{:file }@i{fileName} Specifies the name of the file in which to write the Postscript. If this option isn't specified then the Postscript is returned as the result of the command instead of being written to a file. @item @b{:fontmap }@i{varName} @i{VarName} must be the name of a global array variable that specifies a font mapping to use in the Postscript. Each element of @i{varName} must consist of a Tcl list with two elements, which are the name and point size of a Postscript font. When outputting Postscript commands for a particular font, Tk checks to see if @i{varName} contains an element with the same name as the font. If there is such an element, then the font information contained in that element is used in the Postscript. Otherwise Tk attempts to guess what Postscript font to use. Tk's guesses generally only work for well-known fonts such as Times and Helvetica and Courier, and only if the X font name does not omit any dashes up through the point size. For example, \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but \fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the dashes to parse the font name). @item @b{:height }@i{size} Specifies the height of the area of the canvas to print. Defaults to the height of the canvas window. @item @b{:pageanchor }@i{anchor} Specifies which point of the printed area should be appear over the positioning point on the page (which is given by the @b{:pagex} and @b{:pagey} options). For example, @b{:pageanchor n} means that the top center of the printed area should be over the positioning point. Defaults to @b{center}. @item @b{:pageheight }@i{size} Specifies that the Postscript should be scaled in both x and y so that the printed area is @i{size} high on the Postscript page. @i{Size} consists of a floating-point number followed by @b{c}@r{ for centimeters, }@b{i}@r{ for inches, }@b{m} for millimeters, or @b{p} or nothing for printer's points (1/72 inch). Defaults to the height of the printed area on the screen. If both @b{:pageheight}@r{ and }@b{:pagewidth} are specified then the scale factor from the later option is used (non-uniform scaling is not implemented). @item @b{:pagewidth }@i{size} Specifies that the Postscript should be scaled in both x and y so that the printed area is @i{size} wide on the Postscript page. @i{Size}@r{ has the same form as for }@b{:pageheight}. Defaults to the width of the printed area on the screen. If both @b{:pageheight}@r{ and }@b{:pagewidth} are specified then the scale factor from the later option is used (non-uniform scaling is not implemented). @item @b{:pagex }@i{position} @i{Position} gives the x-coordinate of the positioning point on the Postscript page, using any of the forms allowed for @b{:pageheight}. Used in conjunction with the @b{:pagey}@r{ and }@b{:pageanchor} options to determine where the printed area appears on the Postscript page. Defaults to the center of the page. @item @b{:pagey }@i{position} @i{Position} gives the y-coordinate of the positioning point on the Postscript page, using any of the forms allowed for @b{:pageheight}. Used in conjunction with the @b{:pagex}@r{ and }@b{:pageanchor} options to determine where the printed area appears on the Postscript page. Defaults to the center of the page. @item @b{:rotate }@i{boolean} @i{Boolean} specifies whether the printed area is to be rotated 90 degrees. In non-rotated output the x-axis of the printed area runs along the short dimension of the page (``portrait'' orientation); in rotated output the x-axis runs along the long dimension of the page (``landscape'' orientation). Defaults to non-rotated. @item @b{:width }@i{size} Specifies the width of the area of the canvas to print. Defaults to the width of the canvas window. @item @b{:x }@i{position} Specifies the x-coordinate of the left edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the left edge of the window. @item @b{:y }@i{position} Specifies the y-coordinate of the top edge of the area of the canvas that is to be printed, in canvas coordinates, not window coordinates. Defaults to the coordinate of the top edge of the window. @end table @item @i{pathName }@b{:raise }@i{tagOrId }@r{?}@i{aboveThis}? Move all of the items given by @i{tagOrId} to a new position in the display list just after the item given by @i{aboveThis}. If @i{tagOrId} refers to more than one item then all are moved but the relative order of the moved items will not be changed. @i{AboveThis} is a tag or id; if it refers to more than one item then the last (topmost) of these items in the display list is used as the destination location for the moved items. This command returns an empty string. @item @i{pathName }@b{:scale }@i{tagOrId xOrigin yOrigin xScale yScale} Rescale all of the items given by @i{tagOrId} in canvas coordinate space. @i{XOrigin}@r{ and }@i{yOrigin} identify the origin for the scaling operation and @i{xScale}@r{ and }@i{yScale} identify the scale factors for x- and y-coordinates, respectively (a scale factor of 1.0 implies no change to that coordinate). For each of the points defining each item, the x-coordinate is adjusted to change the distance from @i{xOrigin} by a factor of @i{xScale}. Similarly, each y-coordinate is adjusted to change the distance from @i{yOrigin}@r{ by a factor of }@i{yScale}. This command returns an empty string. @item @i{pathName }@b{:scan}@r{ }@i{option args} This command is used to implement scanning on canvases. It has two forms, depending on @i{option}: @table @asis @item @i{pathName }@b{:scan :mark }@i{x y} Records @i{x}@r{ and }@i{y} and the canvas's current view; used in conjunction with later @b{scan dragto} commands. Typically this command is associated with a mouse button press in the widget and @i{x}@r{ and }@i{y} are the coordinates of the mouse. It returns an empty string. @item @i{pathName }@b{:scan :dragto }@i{x y}. This command computes the difference between its @i{x}@r{ and }@i{y} arguments (which are typically mouse coordinates) and the @i{x} and @i{y}@r{ arguments to the last }@b{scan mark} command for the widget. It then adjusts the view by 10 times the difference in coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the canvas at high speed through its window. The return value is an empty string. @end table @item @i{pathName }@b{:select }@i{option}@r{ ?}@i{tagOrId arg}? Manipulates the selection in one of several ways, depending on @i{option}. The command may take any of the forms described below. In all of the descriptions below, @i{tagOrId} must refer to an item that supports indexing and selection; if it refers to multiple items then the first of these that supports indexing and the selection is used. @i{Index} gives a textual description of a position within @i{tagOrId}, as described in INDICES above. @table @asis @item @i{pathName }@b{:select :adjust }@i{tagOrId index} Locate the end of the selection in @i{tagOrId} nearest to the character given by @i{index}, and adjust that end of the selection to be at @i{index} (i.e. including but not going beyond @i{index}). The other end of the selection is made the anchor point for future @b{select to} commands. If the selection isn't currently in @i{tagOrId} then this command behaves the same as the @b{select to} widget command. Returns an empty string. @item @i{pathName }@b{:select :clear} Clear the selection if it is in this widget. If the selection isn't in this widget then the command has no effect. Returns an empty string. @item @i{pathName }@b{:select :from }@i{tagOrId index} Set the selection anchor point for the widget to be just before the character given by @i{index}@r{ in the item given by }@i{tagOrId}. This command doesn't change the selection; it just sets the fixed end of the selection for future @b{select to} commands. Returns an empty string. @item @i{pathName }@b{:select :item} Returns the id of the selected item, if the selection is in an item in this canvas. If the selection is not in this canvas then an empty string is returned. @item @i{pathName }@b{:select :to }@i{tagOrId index} Set the selection to consist of those characters of @i{tagOrId} between the selection anchor point and @i{index}. The new selection will include the character given by @i{index}; it will include the character given by the anchor point only if @i{index} is greater than or equal to the anchor point. The anchor point is determined by the most recent @b{select adjust} or @b{select from} command for this widget. If the selection anchor point for the widget isn't currently in @i{tagOrId}, then it is set to the same character given by @i{index}. Returns an empty string. @end table @item @i{pathName }@b{:type}@i{ tagOrId} Returns the type of the item given by @i{tagOrId}, such as @b{rectangle}@r{ or }@b{text}. If @i{tagOrId} refers to more than one item, then the type of the first item in the display list is returned. If @i{tagOrId} doesn't refer to any items at all then an empty string is returned. @item @i{pathName }@b{:xview}@i{ index} Change the view in the canvas so that the canvas position given by @i{index} appears at the left edge of the window. This command is typically used by scrollbars to scroll the canvas. @i{Index} counts in units of scroll increments (the value of the @b{scrollIncrement} option): a value of 0 corresponds to the left edge of the scroll region (as defined by the @b{scrollRegion} option), a value of 1 means one scroll unit to the right of this, and so on. The return value is an empty string. @item @i{pathName }@b{:yview}@i{ index} Change the view in the canvas so that the canvas position given by @i{index} appears at the top edge of the window. This command is typically used by scrollbars to scroll the canvas. @i{Index} counts in units of scroll increments (the value of the @b{scrollIncrement} option): a value of 0 corresponds to the top edge of the scroll region (as defined by the @b{scrollRegion} option), a value of 1 means one scroll unit below this, and so on. The return value is an empty string. @end table @unnumberedsubsec Overview Of Item Types The sections below describe the various types of items supported by canvas widgets. Each item type is characterized by two things: first, the form of the @b{create} command used to create instances of the type; and second, a set of configuration options for items of that type, which may be used in the @b{create}@r{ and }@b{itemconfigure} widget commands. Most items don't support indexing or selection or the commands related to them, such as @b{index}@r{ and }@b{insert}. Where items do support these facilities, it is noted explicitly in the descriptions below (at present, only text items provide this support). @unnumberedsubsec Arc Items Items of type @b{arc} appear on the display as arc-shaped regions. An arc is a section of an oval delimited by two angles (specified by the @b{:start}@r{ and }@b{:extent} options) and displayed in one of several ways (specified by the @b{:style} option). Arcs are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create arc }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval that defines the arc. After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for arcs: @table @asis @item @b{:extent }@i{degrees} Specifies the size of the angular range occupied by the arc. The arc's range extends for @i{degrees} degrees counter-clockwise from the starting angle given by the @b{:start} option. @i{Degrees} may be negative. @item @b{:fill }@i{color} Fill the region of the arc with @i{color}. @i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. If @i{color} is an empty string (the default), then then the arc will not be filled. @item @b{:outline }@i{color} @i{Color} specifies a color to use for drawing the arc's outline; it may have any of the forms accepted by @b{Tk_GetColor}. This option defaults to @b{black}. If the arc's style is @b{arc} then this option is ignored (the section of perimeter is filled using the @b{:fill}@r{ option). If }@i{color} is specified as an empty string then no outline is drawn for the arc. @item @b{:start }@i{degrees} Specifies the beginning of the angular range occupied by the arc. @i{Degrees} is given in units of degrees measured counter-clockwise from the 3-o'clock position; it may be either positive or negative. @item @b{:stipple }@i{bitmap} Indicates that the arc should be filled in a stipple pattern; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If the @b{:fill} option hasn't been specified then this option has no effect. If @i{bitmap} is an empty string (the default), then filling is done in a solid fashion. @item @b{:style }@i{type} Specifies how to draw the arc. If @i{type}@r{ is }@b{pieslice} (the default) then the arc's region is defined by a section of the oval's perimeter plus two line segments, one between the center of the oval and each end of the perimeter section. If @i{type}@r{ is }@b{chord} then the arc's region is defined by a section of the oval's perimeter plus a single line segment connecting the two end points of the perimeter section. If @i{type}@r{ is }@b{arc} then the arc's region consists of a section of the perimeter alone. In this last case there is no outline for the arc and the @b{:outline} option is ignored. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:width }@i{outlineWidth} Specifies the width of the outline to be drawn around the arc's region, in any of the forms described in the COORDINATES section above. If the @b{:outline} option has been specified as an empty string then this option has no effect. Wide outlines will be drawn centered on the edges of the arc's region. This option defaults to 1.0. @end table @end table @unnumberedsubsec Bitmap Items Items of type @b{bitmap} appear on the display as images with two colors, foreground and background. Bitmaps are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create bitmap }@i{x y }@r{?}@i{option value option value ...}? The arguments @i{x}@r{ and }@i{y} specify the coordinates of a point used to position the bitmap on the display (see the @b{:anchor} option below for more information on how bitmaps are displayed). After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for bitmaps: @table @asis @item @b{:anchor }@i{anchorPos} @i{AnchorPos} tells how to position the bitmap relative to the positioning point for the item; it may have any of the forms accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} is @b{center} then the bitmap is centered on the point; if @i{anchorPos}@r{ is }@b{n} then the bitmap will be drawn so that its top center point is at the positioning point. This option defaults to @b{center}. @item @b{:background }@i{color} Specifies a color to use for each of the bitmap pixels whose value is 0. @i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. If this option isn't specified, or if it is specified as an empty string, then the background color for the canvas is used. @item @b{:bitmap }@i{bitmap} Specifies the bitmap to display in the item. @i{Bitmap}@r{ may have any of the forms accepted by }@b{Tk_GetBitmap}. @item @b{:foreground }@i{color} Specifies a color to use for each of the bitmap pixels whose value is 1. @i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor} and defaults to @b{black}. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @end table @end table @unnumberedsubsec Line Items Items of type @b{line} appear on the display as one or more connected line segments or curves. Lines are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create line }@i{x1 y1... xn yn }@r{?}@i{option value option value ...}? The arguments @i{x1}@r{ through }@i{yn} give the coordinates for a series of two or more points that describe a series of connected line segments. After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for lines: @table @asis @item @b{:arrow }@i{where} Indicates whether or not arrowheads are to be drawn at one or both ends of the line. @i{Where}@r{ must have one of the values }@b{none} (for no arrowheads), @b{first} (for an arrowhead at the first point of the line), @b{last} (for an arrowhead at the last point of the line), or @b{both} (for arrowheads at both ends). This option defaults to @b{none}. @item @b{:arrowshape }@i{shape} This option indicates how to draw arrowheads. The @i{shape} argument must be a list with three elements, each specifying a distance in any of the forms described in the COORDINATES section above. The first element of the list gives the distance along the line from the neck of the arrowhead to its tip. The second element gives the distance along the line from the trailing points of the arrowhead to the tip, and the third element gives the distance from the outside edge of the line to the trailing points. If this option isn't specified then Tk picks a ``reasonable'' shape. @item @b{:capstyle }@i{style} Specifies the ways in which caps are to be drawn at the endpoints of the line. @i{Style}@r{ may have any of the forms accepted by }@b{Tk_GetCapStyle} (@b{butt}@r{, }@b{projecting}@r{, or }@b{round}). If this option isn't specified then it defaults to @b{butt}. Where arrowheads are drawn the cap style is ignored. @item @b{:fill }@i{color} @i{Color} specifies a color to use for drawing the line; it may have any of the forms acceptable to @b{Tk_GetColor}. It may also be an empty string, in which case the line will be transparent. This option defaults to @b{black}. @item @b{:joinstyle }@i{style} Specifies the ways in which joints are to be drawn at the vertices of the line. @i{Style}@r{ may have any of the forms accepted by }@b{Tk_GetCapStyle} (@b{bevel}@r{, }@b{miter}@r{, or }@b{round}). If this option isn't specified then it defaults to @b{miter}. If the line only contains two points then this option is irrelevant. @item @b{:smooth }@i{boolean} @i{Boolean}@r{ must have one of the forms accepted by }@b{Tk_GetBoolean}. It indicates whether or not the line should be drawn as a curve. If so, the line is rendered as a set of Bezier splines: one spline is drawn for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated within a curve by duplicating the end-points of the desired line segment. @item @b{:splinesteps }@i{number} Specifies the degree of smoothness desired for curves: each spline will be approximated with @i{number} line segments. This option is ignored unless the @b{:smooth} option is true. @item @b{:stipple }@i{bitmap} Indicates that the line should be filled in a stipple pattern; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If @i{bitmap} is an empty string (the default), then filling is done in a solid fashion. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:width }@i{lineWidth} @i{LineWidth} specifies the width of the line, in any of the forms described in the COORDINATES section above. Wide lines will be drawn centered on the path specified by the points. If this option isn't specified then it defaults to 1.0. @end table @end table @unnumberedsubsec Oval Items Items of type @b{oval} appear as circular or oval regions on the display. Each oval may have an outline, a fill, or both. Ovals are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create oval }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give the coordinates of two diagonally opposite corners of a rectangular region enclosing the oval. The oval will include the top and left edges of the rectangle not the lower or right edges. If the region is square then the resulting oval is circular; otherwise it is elongated in shape. After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for ovals: @table @asis @item @b{:fill }@i{color} Fill the area of the oval with @i{color}. @i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. If @i{color} is an empty string (the default), then then the oval will not be filled. @item @b{:outline }@i{color} @i{Color} specifies a color to use for drawing the oval's outline; it may have any of the forms accepted by @b{Tk_GetColor}. This option defaults to @b{black}. If @i{color} is an empty string then no outline will be drawn for the oval. @item @b{:stipple }@i{bitmap} Indicates that the oval should be filled in a stipple pattern; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If the @b{:fill} option hasn't been specified then this option has no effect. If @i{bitmap} is an empty string (the default), then filling is done in a solid fashion. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:width }@i{outlineWidth} @i{outlineWidth} specifies the width of the outline to be drawn around the oval, in any of the forms described in the COORDINATES section above. If the @b{:outline} option hasn't been specified then this option has no effect. Wide outlines are drawn centered on the oval path defined by @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. This option defaults to 1.0. @end table @end table @unnumberedsubsec Polygon Items Items of type @b{polygon} appear as polygonal or curved filled regions on the display. Polygons are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create polygon }@i{x1 y1 ... xn yn }@r{?}@i{option value option value ...}? The arguments @i{x1}@r{ through }@i{yn} specify the coordinates for three or more points that define a closed polygon. The first and last points may be the same; whether they are or not, Tk will draw the polygon as a closed polygon. After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for polygons: @table @asis @item @b{:fill }@i{color} @i{Color} specifies a color to use for filling the area of the polygon; it may have any of the forms acceptable to @b{Tk_GetColor}. If @i{color} is an empty string then the polygon will be transparent. This option defaults to @b{black}. @item @b{:smooth }@i{boolean} @i{Boolean}@r{ must have one of the forms accepted by }@b{Tk_GetBoolean} It indicates whether or not the polygon should be drawn with a curved perimeter. If so, the outline of the polygon becomes a set of Bezier splines, one spline for the first and second line segments, one for the second and third, and so on. Straight-line segments can be generated in a smoothed polygon by duplicating the end-points of the desired line segment. @item @b{:splinesteps }@i{number} Specifies the degree of smoothness desired for curves: each spline will be approximated with @i{number} line segments. This option is ignored unless the @b{:smooth} option is true. @item @b{:stipple }@i{bitmap} Indicates that the polygon should be filled in a stipple pattern; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If @i{bitmap} is an empty string (the default), then filling is done in a solid fashion. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @end table @end table @unnumberedsubsec Rectangle Items Items of type @b{rectangle} appear as rectangular regions on the display. Each rectangle may have an outline, a fill, or both. Rectangles are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create rectangle }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give the coordinates of two diagonally opposite corners of the rectangle (the rectangle will include its upper and left edges but not its lower or right edges). After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for rectangles: @table @asis @item @b{:fill }@i{color} Fill the area of the rectangle with @i{color}, which may be specified in any of the forms accepted by @b{Tk_GetColor}. If @i{color} is an empty string (the default), then then the rectangle will not be filled. @item @b{:outline }@i{color} Draw an outline around the edge of the rectangle in @i{color}. @i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. This option defaults to @b{black}. If @i{color} is an empty string then no outline will be drawn for the rectangle. @item @b{:stipple }@i{bitmap} Indicates that the rectangle should be filled in a stipple pattern; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If the @b{:fill} option hasn't been specified then this option has no effect. If @i{bitmap} is an empty string (the default), then filling is done in a solid fashion. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:width }@i{outlineWidth} @i{OutlineWidth} specifies the width of the outline to be drawn around the rectangle, in any of the forms described in the COORDINATES section above. If the @b{:outline} option hasn't been specified then this option has no effect. Wide outlines are drawn centered on the rectangular path defined by @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. This option defaults to 1.0. @end table @end table @unnumberedsubsec Text Items A text item displays a string of characters on the screen in one or more lines. Text items support indexing and selection, along with the following text-related canvas widget commands: @b{dchars}, @b{focus}@r{, }@b{icursor}@r{, }@b{index}@r{, }@b{insert}, @b{select}. Text items are created with widget commands of the following form: @table @asis @item @i{pathName }@b{:create text }@i{x y }@r{?}@i{option value option value ...}? The arguments @i{x}@r{ and }@i{y} specify the coordinates of a point used to position the text on the display (see the options below for more information on how text is displayed). After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for text items: @table @asis @item @b{:anchor }@i{anchorPos} @i{AnchorPos} tells how to position the text relative to the positioning point for the text; it may have any of the forms accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} is @b{center} then the text is centered on the point; if @i{anchorPos}@r{ is }@b{n} then the text will be drawn such that the top center point of the rectangular region occupied by the text will be at the positioning point. This option defaults to @b{center}. @item @b{:fill }@i{color} @i{Color} specifies a color to use for filling the text characters; it may have any of the forms accepted by @b{Tk_GetColor}. If this option isn't specified then it defaults to @b{black}. @item @b{:font }@i{fontName} Specifies the font to use for the text item. @i{FontName}@r{ may be any string acceptable to }@b{Tk_GetFontStruct}. If this option isn't specified, it defaults to a system-dependent font. @item @b{:justify }@i{how} Specifies how to justify the text within its bounding region. @i{How}@r{ must be one of the values }@b{left}@r{, }@b{right}, or @b{center}. This option will only matter if the text is displayed as multiple lines. If the option is omitted, it defaults to @b{left}. @item @b{:stipple }@i{bitmap} Indicates that the text should be drawn in a stippled pattern rather than solid; @i{bitmap} specifies the stipple pattern to use, in any of the forms accepted by @b{Tk_GetBitmap}. If @i{bitmap} is an empty string (the default) then the text is drawn in a solid fashion. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:text }@i{string} @i{String} specifies the characters to be displayed in the text item. Newline characters cause line breaks. The characters in the item may also be changed with the @b{insert}@r{ and }@b{delete} widget commands. This option defaults to an empty string. @item @b{:width }@i{lineLength} Specifies a maximum line length for the text, in any of the forms described in the COORDINATES section abov. If this option is zero (the default) the text is broken into lines only at newline characters. However, if this option is non-zero then any line that would be longer than @i{lineLength} is broken just before a space character to make the line shorter than @i{lineLength}; the space character is treated as if it were a newline character. @end table @end table @unnumberedsubsec Window Items Items of type @b{window} cause a particular window to be displayed at a given position on the canvas. Window items are created with widget commands of the following form: @example @i{pathName }@b{:create window }@i{x y }@r{?}@i{option value option value ...}? @end example The arguments @i{x}@r{ and }@i{y} specify the coordinates of a point used to position the window on the display (see the @b{:anchor} option below for more information on how bitmaps are displayed). After the coordinates there may be any number of @i{option}@r{-}@i{value} pairs, each of which sets one of the configuration options for the item. These same @i{option}\-@i{value} pairs may be used in @b{itemconfigure} widget commands to change the item's configuration. The following options are supported for window items: @table @asis @item @b{:anchor }@i{anchorPos} @i{AnchorPos} tells how to position the window relative to the positioning point for the item; it may have any of the forms accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} is @b{center} then the window is centered on the point; if @i{anchorPos}@r{ is }@b{n} then the window will be drawn so that its top center point is at the positioning point. This option defaults to @b{center}. @item @b{:height }@i{pixels} Specifies the height to assign to the item's window. @i{Pixels} may have any of the forms described in the COORDINATES section above. If this option isn't specified, or if it is specified as an empty string, then the window is given whatever height it requests internally. @item @b{:tags }@i{tagList} Specifies a set of tags to apply to the item. @i{TagList} consists of a list of tag names, which replace any existing tags for the item. @i{TagList} may be an empty list. @item @b{:width }@i{pixels} Specifies the width to assign to the item's window. @i{Pixels} may have any of the forms described in the COORDINATES section above. If this option isn't specified, or if it is specified as an empty string, then the window is given whatever width it requests internally. @item @b{:window }@i{pathName} Specifies the window to associate with this item. The window specified by @i{pathName} must either be a child of the canvas widget or a child of some ancestor of the canvas widget. @i{PathName} may not refer to a top-level window. @end table @unnumberedsubsec Application-Defined Item Types It is possible for individual applications to define new item types for canvas widgets using C code. The interfaces for this mechanism are not presently documented, and it's possible they may change, but you should be able to see how they work by examining the code for some of the existing item types. @unnumberedsubsec Bindings In the current implementation, new canvases are not given any default behavior: you'll have to execute explicit Tcl commands to give the canvas its behavior. @unnumberedsubsec Credits Tk's canvas widget is a blatant ripoff of ideas from Joel Bartlett's @i{ezd}@r{ program. }@i{Ezd} provides structured graphics in a Scheme environment and preceded canvases by a year or two. Its simple mechanisms for placing and animating graphical objects inspired the functions of canvases. @unnumberedsubsec Keywords canvas, widget @node menu, scrollbar, canvas, Widgets @section menu @c @cartouche menu \- Create and manipulate menu widgets @unnumberedsubsec Synopsis @b{menu}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeBackground background disabledForeground activeBorderWidth borderWidth font activeForeground cursor foreground @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Menu @table @asis @item @code{@b{:postcommand}} @flushright Name=@code{"@b{postCommand}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 If this option is specified then it provides a Tcl command to execute each time the menu is posted. The command is invoked by the @b{post} widget command before posting the menu. @end table @table @asis @item @code{@b{:selector}} @flushright Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 For menu entries that are check buttons or radio buttons, this option specifies the color to display in the selector when the check button or radio button is selected. @end table @c @end cartouche @unnumberedsubsec Introduction The @b{menu} command creates a new top-level window (given by the @i{pathName} argument) and makes it into a menu widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menu such as its colors and font. The @b{menu} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A menu is a widget that displays a collection of one-line entries arranged in a column. There exist several different types of entries, each with different properties. Entries of different types may be combined in a single menu. Menu entries are not the same as entry widgets. In fact, menu entries are not even distinct widgets; the entire menu is one widget. Menu entries are displayed with up to three separate fields. The main field is a label in the form of text or a bitmap, which is determined by the @b{:label}@r{ or }@b{:bitmap} option for the entry. If the @b{:accelerator} option is specified for an entry then a second textual field is displayed to the right of the label. The accelerator typically describes a keystroke sequence that may be typed in the application to cause the same result as invoking the menu entry. The third field is a @i{selector}. The selector is present only for check-button or radio-button entries. It indicates whether the entry is selected or not, and is displayed to the left of the entry's string. In normal use, an entry becomes active (displays itself differently) whenever the mouse pointer is over the entry. If a mouse button is released over the entry then the entry is @i{invoked}. The effect of invocation is different for each type of entry; these effects are described below in the sections on individual entries. Entries may be @i{disabled}, which causes their labels and accelerators to be displayed with dimmer colors. A disabled entry cannot be activated or invoked. Disabled entries may be re-enabled, at which point it becomes possible to activate and invoke them again. @unnumberedsubsec Command Entries The most common kind of menu entry is a command entry, which behaves much like a button widget. When a command entry is invoked, a Tcl command is executed. The Tcl command is specified with the @b{:command} option. @unnumberedsubsec Separator Entries A separator is an entry that is displayed as a horizontal dividing line. A separator may not be activated or invoked, and it has no behavior other than its display appearance. @unnumberedsubsec Check-Button Entries A check-button menu entry behaves much like a check-button widget. When it is invoked it toggles back and forth between the selected and deselected states. When the entry is selected, a particular value is stored in a particular global variable (as determined by the @b{:onvalue}@r{ and }@b{:variable} options for the entry); when the entry is deselected another value (determined by the @b{:offvalue} option) is stored in the global variable. A selector box is displayed to the left of the label in a check-button entry. If the entry is selected then the box's center is displayed in the color given by the @b{selector} option for the menu; otherwise the box's center is displayed in the background color for the menu. If a @b{:command} option is specified for a check-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after toggling the entry's selected state. @unnumberedsubsec Radio-Button Entries A radio-button menu entry behaves much like a radio-button widget. Radio-button entries are organized in groups of which only one entry may be selected at a time. Whenever a particular entry becomes selected it stores a particular value into a particular global variable (as determined by the @b{:value} and @b{:variable} options for the entry). This action causes any previously-selected entry in the same group to deselect itself. Once an entry has become selected, any change to the entry's associated variable will cause the entry to deselect itself. Grouping of radio-button entries is determined by their associated variables: if two entries have the same associated variable then they are in the same group. A selector diamond is displayed to the left of the label in each radio-button entry. If the entry is selected then the diamond's center is displayed in the color given by the @b{selector} option for the menu; otherwise the diamond's center is displayed in the background color for the menu. If a @b{:command} option is specified for a radio-button entry, then its value is evaluated as a Tcl command each time the entry is invoked; this happens after selecting the entry. @unnumberedsubsec Cascade Entries A cascade entry is one with an associated menu (determined by the @b{:menu} option). Cascade entries allow the construction of cascading menus. When the entry is activated, the associated menu is posted just to the right of the entry; that menu remains posted until the higher-level menu is unposted or until some other entry is activated in the higher-level menu. The associated menu should normally be a child of the menu containing the cascade entry, in order for menu traversal to work correctly. A cascade entry posts its associated menu by invoking a Tcl command of the form @table @asis @item @i{menu}@b{ :post }@i{x y} where @i{menu}@r{ is the path name of the associated menu, }@i{x} and @i{y} are the root-window coordinates of the upper-right corner of the cascade entry, and @i{group} is the name of the menu's group (as determined in its last @b{post} widget command). The lower-level menu is unposted by executing a Tcl command with the form @item @i{menu}@b{:unpost} where @i{menu} is the name of the associated menu. @end table If a @b{:command} option is specified for a cascade entry then it is evaluated as a Tcl command each time the associated menu is posted (the evaluation occurs before the menu is posted). @unnumberedsubsec A Menu Widget's Arguments The @b{menu} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @table @asis @item @i{pathName option }@r{?}@i{arg arg ...}? @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. @end table Many of the widget commands for a menu take as one argument an indicator of which entry of the menu to operate on. These indicators are called @i{index}es and may be specified in any of the following forms: @table @asis @item @i{number} Specifies the entry numerically, where 0 corresponds to the top-most entry of the menu, 1 to the entry below it, and so on. @item @b{active} Indicates the entry that is currently active. If no entry is active then this form is equivalent to @b{none}. This form may not be abbreviated. @item @b{last} Indicates the bottommost entry in the menu. If there are no entries in the menu then this form is equivalent to @b{none}. This form may not be abbreviated. @item @b{none} Indicates ``no entry at all''; this is used most commonly with the @b{activate} option to deactivate all the entries in the menu. In most cases the specification of @b{none} causes nothing to happen in the widget command. This form may not be abbreviated. @item @b{@@}@i{number} In this form, @i{number} is treated as a y-coordinate in the menu's window; the entry spanning that y-coordinate is used. For example, ``@b{@@0}'' indicates the top-most entry in the window. If @i{number} is outside the range of the window then this form is equivalent to @b{none}. @item @i{pattern} If the index doesn't satisfy one of the above forms then this form is used. @i{Pattern} is pattern-matched against the label of each entry in the menu, in order from the top down, until a matching entry is found. The rules of @b{Tcl_StringMatch} are used. The following widget commands are possible for menu widgets: @item @i{pathName }@b{:activate }@i{index} Change the state of the entry indicated by @i{index}@r{ to }@b{active} and redisplay it using its active colors. Any previously-active entry is deactivated. If @i{index} is specified as @b{none}, or if the specified entry is disabled, then the menu ends up with no active entry. Returns an empty string. @item @i{pathName }@b{:add }@i{type }@r{?}@i{option value option value ...}? Add a new entry to the bottom of the menu. The new entry's type is given by @i{type}@r{ and must be one of }@b{cascade}, @b{checkbutton}@r{, }@b{command}@r{, }@b{radiobutton}@r{, or }@b{separator}, or a unique abbreviation of one of the above. If additional arguments are present, they specify any of the following options: @table @asis @item @b{:activebackground }@i{value} Specifies a background color to use for displaying this entry when it is active. If this option is specified as an empty string (the default), then the @b{activeBackground} option for the overall menu is used. This option is not available for separator entries. @item @b{:accelerator }@i{value} Specifies a string to display at the right side of the menu entry. Normally describes an accelerator keystroke sequence that may be typed to invoke the same function as the menu entry. This option is not available for separator entries. @item @b{:background }@i{value} Specifies a background color to use for displaying this entry when it is in the normal state (neither active nor disabled). If this option is specified as an empty string (the default), then the @b{background} option for the overall menu is used. This option is not available for separator entries. @item @b{:bitmap }@i{value} Specifies a bitmap to display in the menu instead of a textual label, in any of the forms accepted by @b{Tk_GetBitmap}. This option overrides the @b{:label} option but may be reset to an empty string to enable a textual label to be displayed. This option is not available for separator entries. @item @b{:command }@i{value} For command, checkbutton, and radiobutton entries, specifies a Tcl command to execute when the menu entry is invoked. For cascade entries, specifies a Tcl command to execute when the entry is activated (i.e. just before its submenu is posted). Not available for separator entries. @item @b{:font }@i{value} Specifies the font to use when drawing the label or accelerator string in this entry. If this option is specified as an empty string (the default) then the @b{font} option for the overall menu is used. This option is not available for separator entries. @item @b{:label }@i{value} Specifies a string to display as an identifying label in the menu entry. Not available for separator entries. @item @b{:menu }@i{value} Available only for cascade entries. Specifies the path name of the menu associated with this entry. @item @b{:offvalue }@i{value} Available only for check-button entries. Specifies the value to store in the entry's associated variable when the entry is deselected. @item @b{:onvalue }@i{value} Available only for check-button entries. Specifies the value to store in the entry's associated variable when the entry is selected. @item @b{:state }@i{value} Specifies one of three states for the entry: @b{normal}@r{, }@b{active}, or @b{disabled}. In normal state the entry is displayed using the @b{foreground}@r{ option for the menu and the }@b{background} option from the entry or the menu. The active state is typically used when the pointer is over the entry. In active state the entry is displayed using the @b{activeForeground} option for the menu along with the @b{activebackground} option from the entry. Disabled state means that the entry is insensitive: it doesn't activate and doesn't respond to mouse button presses or releases. In this state the entry is displayed according to the @b{disabledForeground} option for the menu and the @b{background} option from the entry. This option is not available for separator entries. @item @b{:underline }@i{value} Specifies the integer index of a character to underline in the entry. This option is typically used to indicate keyboard traversal characters. 0 corresponds to the first character of the text displayed in the entry, 1 to the next character, and so on. If a bitmap is displayed in the entry then this option is ignored. This option is not available for separator entries. @item @b{:value }@i{value} Available only for radio-button entries. Specifies the value to store in the entry's associated variable when the entry is selected. @item @b{:variable }@i{value} Available only for check-button and radio-button entries. Specifies the name of a global value to set when the entry is selected. For check-button entries the variable is also set when the entry is deselected. For radio-button entries, changing the variable causes the currently-selected entry to deselect itself. @end table @end table The @b{add} widget command returns an empty string. @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{menu} command. @item @i{pathName }@b{:delete }@i{index1}@r{ ?}@i{index2}? Delete all of the menu entries between @i{index1} and @i{index2} inclusive. If @i{index2}@r{ is omitted then it defaults to }@i{index1}. Returns an empty string. @item @i{pathName }@b{:disable }@i{index} Change the state of the entry given by @i{index}@r{ to }@b{disabled} and redisplay the entry using its disabled colors. Returns an empty string. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:entryconfigure }@i{index}@r{ :state disabled}'' instead. @item @i{pathName }@b{:enable }@i{index} Change the state of the entry given by @i{index}@r{ to }@b{normal} and redisplay the entry using its normal colors. Returns an empty string. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:entryconfigure }@i{index}@r{ :state normal}'' instead. @item @i{pathName }@b{:entryconfigure }@i{index}@r{ }@r{?}@i{options}? This command is similar to the @b{configure} command, except that it applies to the options for an individual entry, whereas @b{configure} applies to the options for the menu as a whole. @i{Options}@r{ may have any of the values accepted by the }@b{add} widget command. If @i{options} are specified, options are modified as indicated in the command and the command returns an empty string. If no @i{options} are specified, returns a list describing the current options for entry @i{index}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). @item @i{pathName }@b{:index }@i{index} Returns the numerical index corresponding to @i{index}, or @b{none}@r{ if }@i{index}@r{ was specified as }@b{none}. @item @i{pathName }@b{:invoke }@i{index} Invoke the action of the menu entry. See the sections on the individual entries above for details on what happens. If the menu entry is disabled then nothing happens. If the entry has a command associated with it then the result of that command is returned as the result of the @b{invoke} widget command. Otherwise the result is an empty string. Note: invoking a menu entry does not automatically unpost the menu. Normally the associated menubutton will take care of unposting the menu. @item @i{pathName }@b{:post }@i{x y} Arrange for the menu to be displayed on the screen at the root-window coordinates given by @i{x}@r{ and }@i{y}. These coordinates are adjusted if necessary to guarantee that the entire menu is visible on the screen. This command normally returns an empty string. If the @b{:postcommand} option has been specified, then its value is executed as a Tcl script before posting the menu and the result of that script is returned as the result of the @b{post} widget command. If an error returns while executing the command, then the error is returned without posting the menu. @item @i{pathName }@b{:unpost} Unmap the window so that it is no longer displayed. If a lower-level cascaded menu is posted, unpost that menu. Returns an empty string. @item @i{pathName }@b{:yposition }@i{index} Returns a decimal string giving the y-coordinate within the menu window of the topmost pixel in the entry specified by @i{index}. @end table @unnumberedsubsec Default Bindings Tk automatically creates class bindings for menus that give them the following default behavior: @itemize @asis{} @item [1] When the mouse cursor enters a menu, the entry underneath the mouse cursor is activated; as the mouse moves around the menu, the active entry changes to track the mouse. @item [2] When button 1 is released over a menu, the active entry (if any) is invoked. @item [3] A menu can be repositioned on the screen by dragging it with mouse button 2. @item [4] A number of other bindings are created to support keyboard menu traversal. See the manual entry for @b{tk_bindForTraversal} for details on these bindings. @end itemize Disabled menu entries are non-responsive: they don't activate and ignore mouse button presses and releases. The behavior of menus can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Bugs At present it isn't possible to use the option database to specify values for the options to individual entries. @unnumberedsubsec Keywords menu, widget @node scrollbar, checkbutton, menu, Widgets @section scrollbar @c @cartouche scrollbar \- Create and manipulate scrollbar widgets @unnumberedsubsec Synopsis @b{scrollbar}@i{ pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeForeground cursor relief background foreground repeatDelay borderWidth orient repeatInterval @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Scrollbar @table @asis @item @code{@b{:command}} @flushright Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 Specifies the prefix of a Tcl command to invoke to change the view in the widget associated with the scrollbar. When a user requests a view change by manipulating the scrollbar, a Tcl command is invoked. The actual command consists of this option followed by a space and a number. The number indicates the logical unit that should appear at the top of the associated window. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies the desired narrow dimension of the scrollbar window, not including 3-D border, if any. For vertical scrollbars this will be the width and for horizontal scrollbars this will be the height. The value may have any of the forms acceptable to @b{Tk_GetPixels}. @end table @c @end cartouche @unnumberedsubsec Description The @b{scrollbar} command creates a new window (given by the @i{pathName} argument) and makes it into a scrollbar widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the scrollbar such as its colors, orientation, and relief. The @b{scrollbar} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A scrollbar is a widget that displays two arrows, one at each end of the scrollbar, and a @i{slider} in the middle portion of the scrollbar. A scrollbar is used to provide information about what is visible in an @i{associated window} that displays an object of some sort (such as a file being edited or a drawing). The position and size of the slider indicate which portion of the object is visible in the associated window. For example, if the slider in a vertical scrollbar covers the top third of the area between the two arrows, it means that the associated window displays the top third of its object. Scrollbars can be used to adjust the view in the associated window by clicking or dragging with the mouse. See the BINDINGS section below for details. @unnumberedsubsec A Scrollbar Widget's Arguments The @b{scrollbar} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for scrollbar widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{scrollbar} command. @item @i{pathName }@b{:get} Returns a Tcl list containing four decimal values, which are the current @i{totalUnits}@r{, }@i{widnowUnits}@r{, }@i{firstUnit}, and @i{lastUnit} values for the scrollbar. These are the values from the most recent @b{set} widget command on the scrollbar. @item @i{pathName }@b{:set}@r{ }@i{totalUnits windowUnits firstUnit lastUnit} This command is invoked to give the scrollbar information about the widget associated with the scrollbar. @i{TotalUnits} is an integer value giving the total size of the object being displayed in the associated widget. The meaning of one unit depends on the associated widget; for example, in a text editor widget units might correspond to lines of text. @i{WindowUnits} indicates the total number of units that can fit in the associated window at one time. @i{FirstUnit} and @i{lastUnit} give the indices of the first and last units currently visible in the associated window (zero corresponds to the first unit of the object). This command should be invoked by the associated widget whenever its object or window changes size and whenever it changes the view in its window. @end table @unnumberedsubsec Bindings The description below assumes a vertically-oriented scrollbar. For a horizontally-oriented scrollbar replace the words ``up'', ``down'', ``top'', and ``bottom'' with ``left'', ``right'', ``left'', and ``right'', respectively A scrollbar widget is divided into five distinct areas. From top to bottom, they are: the top arrow, the top gap (the empty space between the arrow and the slider), the slider, the bottom gap, and the bottom arrow. Pressing mouse button 1 in each area has a different effect: @table @asis @item @b{top arrow} Causes the view in the associated window to shift up by one unit (i.e. the object appears to move down one unit in its window). If the button is held down the action will auto-repeat. @item @b{top gap} Causes the view in the associated window to shift up by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very top of the window will now appear at the very bottom). If the button is held down the action will auto-repeat. @item @b{slider} Pressing button 1 in this area has no immediate effect except to cause the slider to appear sunken rather than raised. However, if the mouse is moved with the button down then the slider will be dragged, adjusting the view as the mouse is moved. @item @b{bottom gap} Causes the view in the associated window to shift down by one less than the number of units in the window (i.e. the portion of the object that used to appear at the very bottom of the window will now appear at the very top). If the button is held down the action will auto-repeat. @item @b{bottom arrow} Causes the view in the associated window to shift down by one unit (i.e. the object appears to move up one unit in its window). If the button is held down the action will auto-repeat. Note: none of the actions described above has an immediate impact on the position of the slider in the scrollbar. It simply invokes the command specified in the @b{command} option to notify the associated widget that a change in view is desired. If the view is actually changed then the associated widget must invoke the scrollbar's @b{set} widget command to change what is displayed in the scrollbar. @end table @unnumberedsubsec Keywords scrollbar, widget @node checkbutton, menubutton, scrollbar, Widgets @section checkbutton @c @cartouche checkbutton \- Create and manipulate check-button widgets @unnumberedsubsec Synopsis @b{checkbutton}@i{ pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Checkbutton @table @asis @item @code{@b{:command}} @flushright Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button's global variable (@b{:variable} option) will be updated before the command is invoked. @end table @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. @end table @table @asis @item @code{@b{:offvalue}} @flushright Name=@code{"@b{offValue}@r{"} Class=@code{"}@b{Value}"} @end flushright @sp 1 Specifies value to store in the button's associated variable whenever this button is deselected. Defaults to ``0''. @end table @table @asis @item @code{@b{:onvalue}} @flushright Name=@code{"@b{onValue}@r{"} Class=@code{"}@b{Value}"} @end flushright @sp 1 Specifies value to store in the button's associated variable whenever this button is selected. Defaults to ``1''. @end table @table @asis @item @code{@b{:selector}} @flushright Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of three states for the check button: @b{normal}@r{, }@b{active}, or @b{disabled}. In normal state the check button is displayed using the @b{foreground}@r{ and }@b{background} options. The active state is typically used when the pointer is over the check button. In active state the check button is displayed using the @b{activeForeground} and @b{activeBackground} options. Disabled state means that the check button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the @b{disabledForeground} and @b{background} options determine how the check button is displayed. @end table @table @asis @item @code{@b{:variable}} @flushright Name=@code{"@b{variable}@r{"} Class=@code{"}@b{Variable}"} @end flushright @sp 1 Specifies name of global variable to set to indicate whether or not this button is selected. Defaults to the name of the button within its parent (i.e. the last element of the button window's path name). @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. @end table @c @end cartouche @unnumberedsubsec Description The @b{checkbutton} command creates a new window (given by the @i{pathName} argument) and makes it into a check-button widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the check button such as its colors, font, text, and initial relief. The @b{checkbutton} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A check button is a widget that displays a textual string or bitmap and a square called a @i{selector}. A check button has all of the behavior of a simple button, including the following: it can display itself in either of three different ways, according to the @b{state} option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button. In addition, check buttons can be @i{selected}. If a check button is selected then a special highlight appears in the selector, and a Tcl variable associated with the check button is set to a particular value (normally 1). If the check button is not selected, then the selector is drawn in a different fashion and the associated variable is set to a different value (typically 0). By default, the name of the variable associated with a check button is the same as the @i{name} used to create the check button. The variable name, and the ``on'' and ``off'' values stored in it, may be modified with options on the command line or in the option database. By default a check button is configured to select and deselect itself on alternate button clicks. In addition, each check button monitors its associated variable and automatically selects and deselects itself when the variables value changes to and from the button's ``on'' value. @unnumberedsubsec A Checkbutton Widget's Arguments The @b{checkbutton} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for check button widgets: @table @asis @item @i{pathName }@b{:activate} Change the check button's state to @b{active} and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the check button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state active}'' instead. @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{checkbutton} command. @item @i{pathName }@b{:deactivate} Change the check button's state to @b{normal} and redisplay the button using its normal foreground and background colors. This command is ignored if the check button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state normal}'' instead. @item @i{pathName }@b{:deselect} Deselect the check button: redisplay it without a highlight in the selector and set the associated variable to its ``off'' value. @item @i{pathName }@b{:flash} Flash the check button. This is accomplished by redisplaying the check button several times, alternating between active and normal colors. At the end of the flash the check button is left in the same normal/active state as when the command was invoked. This command is ignored if the check button's state is @b{disabled}. @item @i{pathName }@b{:invoke} Does just what would have happened if the user invoked the check button with the mouse: toggle the selection state of the button and invoke the Tcl command associated with the check button, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the check button. This command is ignored if the check button's state is @b{disabled}. @item @i{pathName }@b{:select} Select the check button: display it with a highlighted selector and set the associated variable to its ``on'' value. @item @i{pathName }@b{:toggle} Toggle the selection state of the button, redisplaying it and modifying its associated variable to reflect the new state. @end table @unnumberedsubsec Bindings Tk automatically creates class bindings for check buttons that give them the following default behavior: @itemize @asis{} @item [1] The check button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the check button. @item [2] The check button's relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released. @item [3] If mouse button 1 is pressed over the check button and later released over the check button, the check button is invoked (i.e. its selection state toggles and the command associated with the button is invoked, if there is one). However, if the mouse is not over the check button when button 1 is released, then no invocation occurs. @end itemize If the check button's state is @b{disabled} then none of the above actions occur: the check button is completely non-responsive. The behavior of check buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Keywords check button, widget @node menubutton, text, checkbutton, Widgets @section menubutton @c @cartouche menubutton \- Create and manipulate menubutton widgets @unnumberedsubsec Synopsis @b{menubutton}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padY underline @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Menubutton @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired height for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in lines of text. If this option isn't specified, the menu button's desired height is computed from the size of the bitmap or text being displayed in it. @end table @table @asis @item @code{@b{:menu}} @flushright Name=@code{"@b{menu}@r{"} Class=@code{"}@b{MenuName}"} @end flushright @sp 1 Specifies the path name of the menu associated with this menubutton. The menu must be a descendant of the menubutton in order for normal pull-down operation to work via the mouse. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of three states for the menu button: @b{normal}@r{, }@b{active}, or @b{disabled}. In normal state the menu button is displayed using the @b{foreground}@r{ and }@b{background} options. The active state is typically used when the pointer is over the menu button. In active state the menu button is displayed using the @b{activeForeground} and @b{activeBackground} options. Disabled state means that the menu button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the @b{disabledForeground} and @b{background} options determine how the button is displayed. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies a desired width for the menu button. If a bitmap is being displayed in the menu button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in characters. If this option isn't specified, the menu button's desired width is computed from the size of the bitmap or text being displayed in it. @end table @c @end cartouche @unnumberedsubsec Introduction The @b{menubutton} command creates a new window (given by the @i{pathName} argument) and makes it into a menubutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the menubutton such as its colors, font, text, and initial relief. The @b{menubutton} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A menubutton is a widget that displays a textual string or bitmap and is associated with a menu widget. In normal usage, pressing mouse button 1 over the menubutton causes the associated menu to be posted just underneath the menubutton. If the mouse is moved over the menu before releasing the mouse button, the button release causes the underlying menu entry to be invoked. When the button is released, the menu is unposted. Menubuttons are typically organized into groups called menu bars that allow scanning: if the mouse button is pressed over one menubutton (causing it to post its menu) and the mouse is moved over another menubutton in the same menu bar without releasing the mouse button, then the menu of the first menubutton is unposted and the menu of the new menubutton is posted instead. The @b{tk-menu-bar} procedure is used to set up menu bars for scanning; see that procedure for more details. @unnumberedsubsec A Menubutton Widget's Arguments The @b{menubutton} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for menubutton widgets: @table @asis @item @i{pathName }@b{:activate} Change the menu button's state to @b{active} and redisplay the menu button using its active foreground and background colors instead of normal colors. The command returns an empty string. This command is ignored if the menu button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state active}'' instead. @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{menubutton} command. @item @i{pathName }@b{:deactivate} Change the menu button's state to @b{normal} and redisplay the menu button using its normal foreground and background colors. The command returns an empty string. This command is ignored if the menu button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state normal}'' instead. @end table @unnumberedsubsec "Default Bindings" Tk automatically creates class bindings for menu buttons that give them the following default behavior: @itemize @asis{} @item [1] A menu button activates whenever the mouse passes over it and deactivates whenever the mouse leaves it. @item [2] A menu button's relief is changed to raised whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released or the mouse is dragged into another menu button in the same menu bar. @item [3] When mouse button 1 is pressed over a menu button, or when the mouse is dragged into a menu button with mouse button 1 pressed, the associated menu is posted; the mouse can be dragged across the menu and released over an entry in the menu to invoke that entry. The menu is unposted when button 1 is released outside either the menu or the menu button. The menu is also unposted when the mouse is dragged into another menu button in the same menu bar. @item [4] If mouse button 1 is pressed and released within the menu button, then the menu stays posted and keyboard traversal is possible as described in the manual entry for @b{tk-menu-bar}. @item [5] Menubuttons may also be posted by typing characters on the keyboard. See the manual entry for @b{tk-menu-bar} for full details on keyboard menu traversal. @item [6] If mouse button 2 is pressed over a menu button then the associated menu is posted and also @i{torn off}: it can then be dragged around on the screen with button 2 and the menu will not automatically unpost when entries in it are invoked. To close a torn off menu, click mouse button 1 over the associated menu button. @end itemize If the menu button's state is @b{disabled} then none of the above actions occur: the menu button is completely non-responsive. The behavior of menu buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Keywords menubutton, widget @node text, entry, menubutton, Widgets @section text @c @cartouche text \- Create and manipulate text widgets @unnumberedsubsec Synopsis @b{text}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example background foreground insertWidth selectBorderWidth borderWidth insertBackground padX selectForeground cursor insertBorderWidth padY setGrid exportSelection insertOffTime relief yScrollCommand font insertOnTime selectBackground @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Text @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies the desired height for the window, in units of characters. Must be at least one. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of two states for the text: @b{normal}@r{ or }@b{disabled}. If the text is disabled then characters may not be inserted or deleted and no insertion cursor will be displayed, even if the input focus is in the widget. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies the desired width for the window in units of characters. If the font doesn't have a uniform width then the width of the character ``0'' is used in translating from character units to screen units. @end table @table @asis @item @code{@b{:wrap}} @flushright Name=@code{"@b{wrap}@r{"} Class=@code{"}@b{Wrap}"} @end flushright @sp 1 Specifies how to handle lines in the text that are too long to be displayed in a single line of the text's window. The value must be @b{none}@r{ or }@b{char}@r{ or }@b{word}. A wrap mode of @b{none} means that each line of text appears as exactly one line on the screen; extra characters that don't fit on the screen are not displayed. In the other modes each line of text will be broken up into several screen lines if necessary to keep all the characters visible. In @b{char} mode a screen line break may occur after any character; in @b{word} mode a line break will only be made at word boundaries. @end table @c @end cartouche @unnumberedsubsec Description The @b{text} command creates a new window (given by the @i{pathName} argument) and makes it into a text widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the text such as its default background color and relief. The @b{text} command returns the path name of the new window. A text widget displays one or more lines of text and allows that text to be edited. Text widgets support three different kinds of annotations on the text, called tags, marks, and windows. Tags allow different portions of the text to be displayed with different fonts and colors. In addition, Tcl commands can be associated with tags so that commands are invoked when particular actions such as keystrokes and mouse button presses occur in particular ranges of the text. See TAGS below for more details. The second form of annotation consists of marks, which are floating markers in the text. Marks are used to keep track of various interesting positions in the text as it is edited. See MARKS below for more details. The third form of annotation allows arbitrary windows to be displayed in the text widget. See WINDOWS below for more details. @unnumberedsubsec Indices Many of the widget commands for texts take one or more indices as arguments. An index is a string used to indicate a particular place within a text, such as a place to insert characters or one endpoint of a range of characters to delete. Indices have the syntax @i{base modifier modifier modifier ...} Where @i{base}@r{ gives a starting point and the }@i{modifier}s adjust the index from the starting point (e.g. move forward or backward one character). Every index must contain a @i{base}, but the @i{modifier}s are optional. The @i{base} for an index must have one of the following forms: @table @asis @item @i{line}@b{.}@i{char} Indicates @i{char}@r{'th character on line }@i{line}. Lines are numbered from 1 for consistency with other UNIX programs that use this numbering scheme. Within a line, characters are numbered from 0. @item @b{@@}@i{x}@b{,}@i{y} Indicates the character that covers the pixel whose x and y coordinates within the text's window are @i{x}@r{ and }@i{y}. @item @b{end} Indicates the last character in the text, which is always a newline character. @item @i{mark} Indicates the character just after the mark whose name is @i{mark}. @item @i{tag}@b{.first} Indicates the first character in the text that has been tagged with @i{tag}. This form generates an error if no characters are currently tagged with @i{tag}. @item @i{tag}@b{.last} Indicates the character just after the last one in the text that has been tagged with @i{tag}. This form generates an error if no characters are currently tagged with @i{tag}. @end table If modifiers follow the base index, each one of them must have one of the forms listed below. Keywords such as @b{chars}@r{ and }@b{wordend} may be abbreviated as long as the abbreviation is unambiguous. @table @asis @item @b{+ }@i{count}@b{ chars} Adjust the index forward by @i{count} characters, moving to later lines in the text if necessary. If there are fewer than @i{count} characters in the text after the current index, then set the index to the last character in the text. Spaces on either side of @i{count} are optional. @item @b{-} @i{count}@b{ chars} Adjust the index backward by @i{count} characters, moving to earlier lines in the text if necessary. If there are fewer than @i{count} characters in the text before the current index, then set the index to the first character in the text. Spaces on either side of @i{count} are optional. @item @b{+ }@i{count}@b{ lines} Adjust the index forward by @i{count} lines, retaining the same character position within the line. If there are fewer than @i{count} lines after the line containing the current index, then set the index to refer to the same character position on the last line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of @i{count} are optional. @item @b{-} @i{count}@b{ lines} Adjust the index backward by @i{count} lines, retaining the same character position within the line. If there are fewer than @i{count} lines before the line containing the current index, then set the index to refer to the same character position on the first line of the text. Then, if the line is not long enough to contain a character at the indicated character position, adjust the character position to refer to the last character of the line (the newline). Spaces on either side of @i{count} are optional. @item @b{linestart} Adjust the index to refer to the first character on the line. @item @b{lineend} Adjust the index to refer to the last character on the line (the newline). @item @b{wordstart} Adjust the index to refer to the first character of the word containing the current index. A word consists of any number of adjacent characters that are letters, digits, or underscores, or a single character that is not one of these. @item @b{wordend} Adjust the index to refer to the character just after the last one of the word containing the current index. If the current index refers to the last character of the text then it is not modified. @end table If more than one modifier is present then they are applied in left-to-right order. For example, the index ``\fBend \- 1 chars'' refers to the next-to-last character in the text and ``\fBinsert wordstart \- 1 c'' refers to the character just before the first one in the word containing the insertion cursor. @unnumberedsubsec Tags The first form of annotation in text widgets is a tag. A tag is a textual string that is associated with some of the characters in a text. There may be any number of tags associated with characters in a text. Each tag may refer to a single character, a range of characters, or several ranges of characters. An individual character may have any number of tags associated with it. A priority order is defined among tags, and this order is used in implementing some of the tag-related functions described below. When a tag is defined (by associating it with characters or setting its display options or binding commands to it), it is given a priority higher than any existing tag. The priority order of tags may be redefined using the ``@i{pathName }@b{:tag :raise}@r{'' and ``}@i{pathName }@b{:tag :lower}'' widget commands. Tags serve three purposes in text widgets. First, they control the way information is displayed on the screen. By default, characters are displayed as determined by the @b{background}@r{, }@b{font}@r{, and }@b{foreground} options for the text widget. However, display options may be associated with individual tags using the ``@i{pathName }@b{:tag configure}'' widget command. If a character has been tagged, then the display options associated with the tag override the default display style. The following options are currently supported for tags: @table @asis @item @b{:background }@i{color} @i{Color} specifies the background color to use for characters associated with the tag. It may have any of the forms accepted by @b{Tk_GetColor}. @item @b{:bgstipple }@i{bitmap} @i{Bitmap} specifies a bitmap that is used as a stipple pattern for the background. It may have any of the forms accepted by @b{Tk_GetBitmap}. If @i{bitmap} hasn't been specified, or if it is specified as an empty string, then a solid fill will be used for the background. @item @b{:borderwidth }@i{pixels} @i{Pixels} specifies the width of a 3-D border to draw around the background. It may have any of the forms accepted by @b{Tk_GetPixels}. This option is used in conjunction with the @b{:relief} option to give a 3-D appearance to the background for characters; it is ignored unless the @b{:background} option has been set for the tag. @item @b{:fgstipple }@i{bitmap} @i{Bitmap} specifies a bitmap that is used as a stipple pattern when drawing text and other foreground information such as underlines. It may have any of the forms accepted by @b{Tk_GetBitmap}. If @i{bitmap} hasn't been specified, or if it is specified as an empty string, then a solid fill will be used. @item @b{:font }@i{fontName} @i{FontName} is the name of a font to use for drawing characters. It may have any of the forms accepted by @b{Tk_GetFontStruct}. @item @b{:foreground }@i{color} @i{Color} specifies the color to use when drawing text and other foreground information such as underlines. It may have any of the forms accepted by @b{Tk_GetColor}. @item @b{:relief }@i{relief} \fIRelief specifies the 3-D relief to use for drawing backgrounds, in any of the forms accepted by @b{Tk_GetRelief}. This option is used in conjunction with the @b{:borderwidth} option to give a 3-D appearance to the background for characters; it is ignored unless the @b{:background} option has been set for the tag. @item @b{:underline }@i{boolean} @i{Boolean} specifies whether or not to draw an underline underneath characters. It may have any of the forms accepted by @b{Tk_GetBoolean}. If a character has several tags associated with it, and if their display options conflict, then the options of the highest priority tag are used. If a particular display option hasn't been specified for a particular tag, or if it is specified as an empty string, then that option will never be used; the next-highest-priority tag's option will used instead. If no tag specifies a particular display optionl, then the default style for the widget will be used. The second purpose for tags is event bindings. You can associate bindings with a tag in much the same way you can associate bindings with a widget class: whenever particular X events occur on characters with the given tag, a given Tcl command will be executed. Tag bindings can be used to give behaviors to ranges of characters; among other things, this allows hypertext-like features to be implemented. For details, see the description of the @b{tag bind} widget command below. The third use for tags is in managing the selection. See THE SELECTION below. @end table @unnumberedsubsec Marks The second form of annotation in text widgets is a mark. Marks are used for remembering particular places in a text. They are something like tags, in that they have names and they refer to places in the file, but a mark isn't associated with particular characters. Instead, a mark is associated with the gap between two characters. Only a single position may be associated with a mark at any given time. If the characters around a mark are deleted the mark will still remain; it will just have new neighbor characters. In contrast, if the characters containing a tag are deleted then the tag will no longer have an association with characters in the file. Marks may be manipulated with the ``@i{pathName }@b{:mark}'' widget command, and their current locations may be determined by using the mark name as an index in widget commands. The name space for marks is different from that for tags: the same name may be used for both a mark and a tag, but they will refer to different things. Two marks have special significance. First, the mark @b{insert} is associated with the insertion cursor, as described under THE INSERTION CURSOR below. Second, the mark @b{current} is associated with the character closest to the mouse and is adjusted automatically to track the mouse position and any changes to the text in the widget (one exception: @b{current} is not updated in response to mouse motions if a mouse button is down; the update will be deferred until all mouse buttons have been released). Neither of these special marks may be unset. @unnumberedsubsec Windows The third form of annotation in text widgets is a window. Window support isn't implemented yet, but when it is it will be described here. @unnumberedsubsec The Selection Text widgets support the standard X selection. Selection support is implemented via tags. If the @b{exportSelection} option for the text widget is true then the @b{sel} tag will be associated with the selection: @itemize @asis{} @item [1] Whenever characters are tagged with @b{sel} the text widget will claim ownership of the selection. @item [2] Attempts to retrieve the selection will be serviced by the text widget, returning all the charaters with the @b{sel} tag. @item [3] If the selection is claimed away by another application or by another window within this application, then the @b{sel} tag will be removed from all characters in the text. @end itemize The @b{sel} tag is automatically defined when a text widget is created, and it may not be deleted with the ``@i{pathName }@b{:tag delete}'' widget command. Furthermore, the @b{selectBackground}, @b{selectBorderWidth}@r{, and }@b{selectForeground} options for the text widget are tied to the @b{:background}, @b{:borderwidth}@r{, and }@b{:foreground}@r{ options for the }@b{sel} tag: changes in either will automatically be reflected in the other. @unnumberedsubsec The Insertion Cursor The mark named @b{insert} has special significance in text widgets. It is defined automatically when a text widget is created and it may not be unset with the ``@i{pathName }@b{:mark unset}'' widget command. The @b{insert} mark represents the position of the insertion cursor, and the insertion cursor will automatically be drawn at this point whenever the text widget has the input focus. @unnumberedsubsec A Text Widget's Arguments The @b{text} command creates a new Tcl command whose name is the same as the path name of the text's window. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{PathName} is the name of the command, which is the same as the text widget's path name. @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for text widgets: @table @asis @item @i{pathName }@b{:compare}@r{ }@i{index1 op index2} Compares the indices given by @i{index1}@r{ and }@i{index2} according to the relational operator given by @i{op}, and returns 1 if the relationship is satisfied and 0 if it isn't. @i{Op} must be one of the operators <, <=, ==, >=, >, or !=. If @i{op} is == then 1 is returned if the two indices refer to the same character, if @i{op}@r{ is < then 1 is returned if }@i{index1} refers to an earlier character in the text than @i{index2}, and so on. @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? }@i{?value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{text} command. @item @i{pathName }@b{:debug }@r{?}@i{boolean}? If @i{boolean} is specified, then it must have one of the true or false values accepted by Tcl_GetBoolean. If the value is a true one then internal consistency checks will be turned on in the B-tree code associated with text widgets. If @i{boolean} has a false value then the debugging checks will be turned off. In either case the command returns an empty string. If @i{boolean}@r{ is not specified then the command returns }@b{on} or @b{off} to indicate whether or not debugging is turned on. There is a single debugging switch shared by all text widgets: turning debugging on or off in any widget turns it on or off for all widgets. For widgets with large amounts of text, the consistency checks may cause a noticeable slow-down. @item @i{pathName }@b{:delete }@i{index1 }@r{?}@i{index2}? Delete a range of characters from the text. If both @i{index1}@r{ and }@i{index2} are specified, then delete all the characters starting with the one given by @i{index1} and stopping just before @i{index2} (i.e. the character at @i{index2} is not deleted). If @i{index2} doesn't specify a position later in the text than @i{index1} then no characters are deleted. If @i{index2} isn't specified then the single character at @i{index1} is deleted. It is not allowable to delete characters in a way that would leave the text without a newline as the last character. The command returns an empty string. @item @i{pathName }@b{:get }@i{index1 }@r{?}@i{index2}? Return a range of characters from the text. The return value will be all the characters in the text starting with the one whose index is @i{index1} and ending just before the one whose index is @i{index2}@r{ (the character at }@i{index2} will not be returned). If @i{index2}@r{ is omitted then the single character at }@i{index1} is returned. If there are no characters in the specified range (e.g. @i{index1} is past the end of the file or @i{index2} is less than or equal to @i{index1}) then an empty string is returned. @item @i{pathName }@b{:index }@i{index} Returns the position corresponding to @i{index} in the form @i{line.char}@r{ where }@i{line}@r{ is the line number and }@i{char} is the character number. @i{Index} may have any of the forms described under INDICES above. @item @i{pathName }@b{:insert }\fIindex chars Inserts @i{chars} into the text just before the character at @i{index} and returns an empty string. It is not possible to insert characters after the last newline of the text. @item @i{pathName }@b{:mark }@i{option }@r{?}@i{arg arg ...}? This command is used to manipulate marks. The exact behavior of the command depends on the @i{option} argument that follows the @b{mark} argument. The following forms of the command are currently supported: @table @asis @item @i{pathName }@b{:mark :names} Returns a list whose elements are the names of all the marks that are currently set. @item @i{pathName }@b{:mark :set }@i{markName index} Sets the mark named @i{markName} to a position just before the character at @i{index}. If @i{markName} already exists, it is moved from its old position; if it doesn't exist, a new mark is created. This command returns an empty string. @item @i{pathName }@b{:mark :unset }@i{markName }@r{?}@i{markName markName ...}? Remove the mark corresponding to each of the @i{markName} arguments. The removed marks will not be usable in indices and will not be returned by future calls to ``@i{pathName }@b{:mark names}''. This command returns an empty string. @end table @item @i{pathName }@b{:scan}@r{ }@i{option args} This command is used to implement scanning on texts. It has two forms, depending on @i{option}: @table @asis @item @i{pathName }@b{:scan :mark }@i{y} Records @i{y} and the current view in the text window; used in conjunction with later @b{scan dragto} commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. @item @i{pathName }@b{:scan :dragto }@i{y} This command computes the difference between its @i{y} argument and the @i{y}@r{ argument to the last }@b{scan mark} command for the widget. It then adjusts the view up or down by 10 times the difference in y-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the text at high speed through the window. The return value is an empty string. @end table @item @i{pathName }@b{:tag }@i{option }@r{?}@i{arg arg ...}? This command is used to manipulate tags. The exact behavior of the command depends on the @i{option} argument that follows the @b{tag} argument. The following forms of the command are currently supported: @table @asis @item @i{pathName }@b{:tag :add }@i{tagName index1 }@r{?}@i{index2}? Associate the tag @i{tagName} with all of the characters starting with @i{index1} and ending just before @i{index2}@r{ (the character at }@i{index2} isn't tagged). If @i{index2} is omitted then the single character at @i{index1} is tagged. If there are no characters in the specified range (e.g. @i{index1} is past the end of the file or @i{index2} is less than or equal to @i{index1}) then the command has no effect. This command returns an empty string. @item @i{pathName }@b{:tag :bind }@i{tagName}@r{ ?}@i{sequence}@r{? ?}@i{command}? This command associates @i{command} with the tag given by @i{tagName}. Whenever the event sequence given by @i{sequence} occurs for a character that has been tagged with @i{tagName}, the command will be invoked. This widget command is similar to the @b{bind} command except that it operates on characters in a text rather than entire widgets. See the @b{bind} manual entry for complete details on the syntax of @i{sequence} and the substitutions performed on @i{command} before invoking it. If all arguments are specified then a new binding is created, replacing any existing binding for the same @i{sequence}@r{ and }@i{tagName} (if the first character of @i{command}@r{ is ``+'' then }@i{command} augments an existing binding rather than replacing it). In this case the return value is an empty string. If @i{command}@r{ is omitted then the command returns the }@i{command} associated with @i{tagName}@r{ and }@i{sequence} (an error occurs if there is no such binding). If both @i{command}@r{ and }@i{sequence} are omitted then the command returns a list of all the sequences for which bindings have been defined for @i{tagName}. The only events for which bindings may be specified are those related to the mouse and keyboard, such as @b{Enter}@r{, }@b{Leave}, @b{ButtonPress}@r{, }@b{Motion}@r{, and }@b{KeyPress}. Event bindings for a text widget use the @b{current} mark described under MARKS above. @b{Enter} events trigger for a character when it becomes the current character (i.e. the @b{current} mark moves to just in front of that character). @b{Leave} events trigger for a character when it ceases to be the current item (i.e. the @b{current} mark moves away from that character, or the character is deleted). These events are different than @b{Enter}@r{ and }@b{Leave} events for windows. Mouse and keyboard events are directed to the current character. It is possible for the current character to have multiple tags, and for each of them to have a binding for a particular event sequence. When this occurs, the binding from the highest priority tag is used. If a particular tag doesn't have a binding that matches an event, then the tag is ignored and tags with lower priority will be checked. If bindings are created for the widget as a whole using the @b{bind} command, then those bindings will supplement the tag bindings. This means that a single event can trigger two Tcl scripts, one for a widget-level binding and one for a tag-level binding. @item @i{pathName }@b{:tag :configure }@i{tagName}@r{ ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? This command is similar to the @b{configure} widget command except that it modifies options associated with the tag given by @i{tagName} instead of modifying options for the overall text widget. If no @i{option} is specified, the command returns a list describing all of the available options for @i{tagName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option}@r{ is specified with no }@i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given option(s) to have the given value(s) in @i{tagName}; in this case the command returns an empty string. See TAGS above for details on the options available for tags. @item @i{pathName }@b{:tag :delete }@i{tagName }@r{?}@i{tagName ...}? Deletes all tag information for each of the @i{tagName} arguments. The command removes the tags from all characters in the file and also deletes any other information associated with the tags, such as bindings and display information. The command returns an empty string. @item @i{pathName }@b{:tag :lower }@i{tagName }@r{?}@i{belowThis}? Changes the priority of tag @i{tagName} so that it is just lower in priority than the tag whose name is @i{belowThis}. If @i{belowThis}@r{ is omitted, then }@i{tagName}'s priority is changed to make it lowest priority of all tags. @item @i{pathName }@b{:tag :names }@r{?}@i{index}? Returns a list whose elements are the names of all the tags that are active at the character position given by @i{index}. If @i{index} is omitted, then the return value will describe all of the tags that exist for the text (this includes all tags that have been named in a ``@i{pathName }@b{:tag}'' widget command but haven't been deleted by a ``@i{pathName }@b{:tag :delete}'' widget command, even if no characters are currently marked with the tag). The list will be sorted in order from lowest priority to highest priority. @item @i{pathName }@b{:tag :nextrange }@i{tagName index1 }@r{?}@i{index2}? This command searches the text for a range of characters tagged with @i{tagName} where the first character of the range is no earlier than the character at @i{index1} and no later than the character just before @i{index2} (a range starting at @i{index2} will not be considered). If several matching ranges exist, the first one is chosen. The command's return value is a list containing two elements, which are the index of the first character of the range and the index of the character just after the last one in the range. If no matching range is found then the return value is an empty string. If @i{index2} is not given then it defaults to the end of the text. @item @i{pathName }@b{:tag :raise }@i{tagName }@r{?}@i{aboveThis}? Changes the priority of tag @i{tagName} so that it is just higher in priority than the tag whose name is @i{aboveThis}. If @i{aboveThis}@r{ is omitted, then }@i{tagName}'s priority is changed to make it highest priority of all tags. @item @i{pathName }@b{:tag :ranges }@i{tagName} Returns a list describing all of the ranges of text that have been tagged with @i{tagName}. The first two elements of the list describe the first tagged range in the text, the next two elements describe the second range, and so on. The first element of each pair contains the index of the first character of the range, and the second element of the pair contains the index of the character just after the last one in the range. If there are no characters tagged with @i{tag} then an empty string is returned. @item @i{pathName }@b{:tag :remove }@i{tagName index1 }@r{?}@i{index2}? Remove the tag @i{tagName} from all of the characters starting at @i{index1} and ending just before @i{index2}@r{ (the character at }@i{index2} isn't affected). If @i{index2} is omitted then the single character at @i{index1} is untagged. If there are no characters in the specified range (e.g. @i{index1} is past the end of the file or @i{index2} is less than or equal to @i{index1}) then the command has no effect. This command returns an empty string. @end table @item @i{pathName }@b{:yview }@r{?}@b{:pickplace}@r{? }@i{what} This command changes the view in the widget's window so that the line given by @i{what} is visible in the window. @i{What} may be either an absolute line number, where 0 corresponds to the first line of the file, or an index with any of the forms described under INDICES above. The first form (absolute line number) is used in the commands issued by scrollbars to control the widget's view. If the @b{:pickplace}@r{ option isn't specified then }@i{what} will appear at the top of the window. If @b{:pickplace} is specified then the widget chooses where @i{what} appears in the window: @itemize @asis{} @item [1] If @i{what} is already visible somewhere in the window then the command does nothing. @item [2] If @i{what} is only a few lines off-screen above the window then it will be positioned at the top of the window. @item [3] If @i{what} is only a few lines off-screen below the window then it will be positioned at the bottom of the window. @item [4] Otherwise, @i{what} will be centered in the window. @end itemize The @b{:pickplace} option is typically used after inserting text to make sure that the insertion cursor is still visible on the screen. This command returns an empty string. @end table @unnumberedsubsec Bindings Tk automatically creates class bindings for texts that give them the following default behavior: @itemize @asis{} @item [1] Pressing mouse button 1 in an text positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget. @item [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse. @item [3] If you double-press mouse button 1 then the word under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the word, and dragging the mouse will stroke out a selection whole words at a time. @item [4] If you triple-press mouse button 1 then the line under the mouse cursor will be selected, the insertion cursor will be positioned at the beginning of the line, and dragging the mouse will stroke out a selection whole line at a time. @item [5] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. If the selection was made in word or line mode then it will be adjusted in this same mode. @item [6] The view in the text can be adjusted by dragging with mouse button 2. @item [7] If the input focus is in a text widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor. @item [8] Control+h and the Backspace and Delete keys erase the character just before the insertion cursor. @item [9] Control+v inserts the current selection just before the insertion cursor. @item [10] Control+d deletes the selected characters; an error occurs if the selection is not in this widget. @end itemize If the text is disabled using the @b{state} option, then the text's view can still be adjusted and text in the text can still be selected, but no insertion cursor will be displayed and no text modifications will take place. The behavior of texts can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec "Performance Issues" Text widgets should run efficiently under a variety of conditions. The text widget uses about 2-3 bytes of main memory for each byte of text, so texts containing a megabyte or more should be practical on most workstations. Text is represented internally with a modified B-tree structure that makes operations relatively efficient even with large texts. Tags are included in the B-tree structure in a way that allows tags to span large ranges or have many disjoint smaller ranges without loss of efficiency. Marks are also implemented in a way that allows large numbers of marks. The only known mode of operation where a text widget may not run efficiently is if it has a very large number of different tags. Hundreds of tags should be fine, or even a thousand, but tens of thousands of tags will make texts consume a lot of memory and run slowly. @unnumberedsubsec Keywords text, widget @node entry, message, text, Widgets @section entry @c @cartouche entry \- Create and manipulate entry widgets @unnumberedsubsec Synopsis @b{entry}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example background foreground insertWidth selectForeground borderWidth insertBackground relief textVariable cursor insertBorderWidth scrollCommand exportSelection insertOffTime selectBackground font insertOnTime selectBorderWidth @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Entry @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of two states for the entry: @b{normal}@r{ or }@b{disabled}. If the entry is disabled then the value may not be changed using widget commands and no insertion cursor will be displayed, even if the input focus is in the widget. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies an integer value indicating the desired width of the entry window, in average-size characters of the widget's font. @end table @c @end cartouche @unnumberedsubsec Description The @b{entry} command creates a new window (given by the @i{pathName} argument) and makes it into an entry widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the entry such as its colors, font, and relief. The @b{entry} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. An entry is a widget that displays a one-line text string and allows that string to be edited using widget commands described below, which are typically bound to keystrokes and mouse actions. When first created, an entry's string is empty. A portion of the entry may be selected as described below. If an entry is exporting its selection (see the @b{exportSelection} option), then it will observe the standard X11 protocols for handling the selection; entry selections are available as type @b{STRING}. Entries also observe the standard Tk rules for dealing with the input focus. When an entry has the input focus it displays an @i{insertion cursor} to indicate where new characters will be inserted. Entries are capable of displaying strings that are too long to fit entirely within the widget's window. In this case, only a portion of the string will be displayed; commands described below may be used to change the view in the window. Entries use the standard @b{scrollCommand} mechanism for interacting with scrollbars (see the description of the @b{scrollCommand} option for details). They also support scanning, as described below. @unnumberedsubsec A Entry Widget's Arguments The @b{entry} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. Many of the widget commands for entries take one or more indices as arguments. An index specifies a particular character in the entry's string, in any of the following ways: @table @asis @item @i{number} Specifies the character as a numerical index, where 0 corresponds to the first character in the string. @item @b{end} Indicates the character just after the last one in the entry's string. This is equivalent to specifying a numerical index equal to the length of the entry's string. @item @b{insert} Indicates the character adjacent to and immediately following the insertion cursor. @item @b{sel.first} Indicates the first character in the selection. It is an error to use this form if the selection isn't in the entry window. @item @b{sel.last} Indicates the last character in the selection. It is an error to use this form if the selection isn't in the entry window. @item @b{@@}@i{number} In this form, @i{number} is treated as an x-coordinate in the entry's window; the character spanning that x-coordinate is used. For example, ``@b{@@0}'' indicates the left-most character in the window. @end table Abbreviations may be used for any of the forms above, e.g. ``@b{e}'' or ``@b{sel.f}''. In general, out-of-range indices are automatically rounded to the nearest legal value. The following commands are possible for entry widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{entry} command. @item @i{pathName }@b{:delete }@i{first }@r{?}@i{last}? Delete one or more elements of the entry. @i{First}@r{ and }@i{last} are indices of of the first and last characters in the range to be deleted. If @i{last} isn't specified it defaults to @i{first}, i.e. a single character is deleted. This command returns an empty string. @item @i{pathName }@b{:get} Returns the entry's string. @item @i{pathName }@b{:icursor }@i{index} Arrange for the insertion cursor to be displayed just before the character given by @i{index}. Returns an empty string. @item @i{pathName }@b{:index}@i{ index} Returns the numerical index corresponding to @i{index}. @item @i{pathName }@b{:insert }@i{index string} Insert the characters of @i{string} just before the character indicated by @i{index}. Returns an empty string. @item @i{pathName }@b{:scan}@r{ }@i{option args} This command is used to implement scanning on entries. It has two forms, depending on @i{option}: @table @asis @item @i{pathName }@b{:scan :mark }@i{x} Records @i{x} and the current view in the entry window; used in conjunction with later @b{scan dragto} commands. Typically this command is associated with a mouse button press in the widget. It returns an empty string. @item @i{pathName }@b{:scan :dragto }@i{x} This command computes the difference between its @i{x} argument and the @i{x}@r{ argument to the last }@b{scan mark} command for the widget. It then adjusts the view left or right by 10 times the difference in x-coordinates. This command is typically associated with mouse motion events in the widget, to produce the effect of dragging the entry at high speed through the window. The return value is an empty string. @end table @item @i{pathName }@b{:select }@i{option arg} This command is used to adjust the selection within an entry. It has several forms, depending on @i{option}: @table @asis @item @i{pathName }@b{:select :adjust }@i{index} Locate the end of the selection nearest to the character given by @i{index}@r{, and adjust that end of the selection to be at }@i{index} (i.e including but not going beyond @i{index}). The other end of the selection is made the anchor point for future @b{select to} commands. If the selection isn't currently in the entry, then a new selection is created to include the characters between @i{index} and the most recent selection anchor point, inclusive. Returns an empty string. @item @i{pathName }@b{:select :clear} Clear the selection if it is currently in this widget. If the selection isn't in this widget then the command has no effect. Returns an empty string. @item @i{pathName }@b{:select :from }@i{index} Set the selection anchor point to just before the character given by @i{index}. Doesn't change the selection. Returns an empty string. @item @i{pathName }@b{:select :to }@i{index} Set the selection to consist of the elements from the anchor point to element @i{index}, inclusive. The anchor point is determined by the most recent @b{select from}@r{ or }@b{select adjust} command in this widget. If the selection isn't in this widget then a new selection is created using the most recent anchor point specified for the widget. Returns an empty string. @end table @item @i{pathName }@b{:view }@i{index} Adjust the view in the entry so that element @i{index} is at the left edge of the window. Returns an empty string. @end table @unnumberedsubsec "Default Bindings" Tk automatically creates class bindings for entries that give them the following default behavior: @itemize @asis{} @item [1] Clicking mouse button 1 in an entry positions the insertion cursor just before the character underneath the mouse cursor and sets the input focus to this widget. @item [2] Dragging with mouse button 1 strokes out a selection between the insertion cursor and the character under the mouse. @item [3] The ends of the selection can be adjusted by dragging with mouse button 1 while the shift key is down; this will adjust the end of the selection that was nearest to the mouse cursor when button 1 was pressed. @item [4] The view in the entry can be adjusted by dragging with mouse button 2. @item [5] If the input focus is in an entry widget and characters are typed on the keyboard, the characters are inserted just before the insertion cursor. @item [6] Control-h and the Backspace and Delete keys erase the character just before the insertion cursor. @item [7] Control-w erases the word just before the insertion cursor. @item [8] Control-u clears the entry to an empty string. @item [9] Control-v inserts the current selection just before the insertion cursor. @item [10] Control-d deletes the selected characters; an error occurs if the selection is not in this widget. @end itemize If the entry is disabled using the @b{state} option, then the entry's view can still be adjusted and text in the entry can still be selected, but no insertion cursor will be displayed and no text modifications will take place. The behavior of entries can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Keywords entry, widget @node message, frame, entry, Widgets @section message @c @cartouche message \- Create and manipulate message widgets @unnumberedsubsec Synopsis @b{message}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example anchor cursor padX text background font padY textVariable borderWidth foreground relief width @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Message @table @asis @item @code{@b{:aspect}} @flushright Name=@code{"@b{aspect}@r{"} Class=@code{"}@b{Aspect}"} @end flushright @sp 1 Specifies a non-negative integer value indicating desired aspect ratio for the text. The aspect ratio is specified as 100*width/height. 100 means the text should be as wide as it is tall, 200 means the text should be twice as wide as it is tall, 50 means the text should be twice as tall as it is wide, and so on. Used to choose line length for text if @b{width} option isn't specified. Defaults to 150. @end table @table @asis @item @code{@b{:justify}} @flushright Name=@code{"@b{justify}@r{"} Class=@code{"}@b{Justify}"} @end flushright @sp 1 Specifies how to justify lines of text. Must be one of @b{left}@r{, }@b{center}@r{, or }@b{right}. Defaults to @b{left}. This option works together with the @b{anchor}@r{, }@b{aspect}, @b{padX}@r{, }@b{padY}@r{, and }@b{width} options to provide a variety of arrangements of the text within the window. The @b{aspect}@r{ and }@b{width} options determine the amount of screen space needed to display the text. The @b{anchor}@r{, }@b{padX}@r{, and }@b{padY} options determine where this rectangular area is displayed within the widget's window, and the @b{justify} option determines how each line is displayed within that rectangular region. For example, suppose @b{anchor}@r{ is }@b{e}@r{ and }@b{justify} is @b{left}, and that the message window is much larger than needed for the text. The the text will displayed so that the left edges of all the lines line up and the right edge of the longest line is @b{padX} from the right side of the window; the entire text block will be centered in the vertical span of the window. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies the length of lines in the window. The value may have any of the forms acceptable to @b{Tk_GetPixels}. If this option has a value greater than zero then the @b{aspect} option is ignored and the @b{width} option determines the line length. If this option has a value less than or equal to zero, then the @b{aspect} option determines the line length. @end table @c @end cartouche @unnumberedsubsec Description The @b{message} command creates a new window (given by the @i{pathName} argument) and makes it into a message widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the message such as its colors, font, text, and initial relief. The @b{message} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A message is a widget that displays a textual string. A message widget has three special features. First, it breaks up its string into lines in order to produce a given aspect ratio for the window. The line breaks are chosen at word boundaries wherever possible (if not even a single word would fit on a line, then the word will be split across lines). Newline characters in the string will force line breaks; they can be used, for example, to leave blank lines in the display. The second feature of a message widget is justification. The text may be displayed left-justified (each line starts at the left side of the window), centered on a line-by-line basis, or right-justified (each line ends at the right side of the window). The third feature of a message widget is that it handles control characters and non-printing characters specially. Tab characters are replaced with enough blank space to line up on the next 8-character boundary. Newlines cause line breaks. Other control characters (ASCII code less than 0x20) and characters not defined in the font are displayed as a four-character sequence \fB\ex@i{hh} where @i{hh} is the two-digit hexadecimal number corresponding to the character. In the unusual case where the font doesn't contain all of the characters in ``0123456789abcdef\ex'' then control characters and undefined characters are not displayed at all. @unnumberedsubsec A Message Widget's Arguments The @b{message} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for message widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{message} command. @end table @unnumberedsubsec "Default Bindings" When a new message is created, it has no default event bindings: messages are intended for output purposes only. @unnumberedsubsec Bugs Tabs don't work very well with text that is centered or right-justified. The most common result is that the line is justified wrong. @unnumberedsubsec Keywords message, widget @node frame, label, message, Widgets @section frame @c @cartouche frame \- Create and manipulate frame widgets @unnumberedsubsec Synopsis @b{frame}@i{ }@i{pathName }@r{?}@b{:class }@i{className}@r{? ?}@i{options}? @unnumberedsubsec Standard Options @example background cursor relief borderWidth geometry @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Frame @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies the desired height for the window in any of the forms acceptable to @b{Tk_GetPixels}. This option is only used if the @b{:geometry} option is unspecified. If this option is less than or equal to zero (and @b{:geometry} is not specified) then the window will not request any size at all. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies the desired width for the window in any of the forms acceptable to @b{Tk_GetPixels}. This option is only used if the @b{:geometry} option is unspecified. If this option is less than or equal to zero (and @b{:geometry} is not specified) then the window will not request any size at all. @end table @c @end cartouche @unnumberedsubsec Description The @b{frame} command creates a new window (given by the @i{pathName} argument) and makes it into a frame widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the frame such as its background color and relief. The @b{frame} command returns the path name of the new window. A frame is a simple widget. Its primary purpose is to act as a spacer or container for complex window layouts. The only features of a frame are its background color and an optional 3-D border to make the frame appear raised or sunken. In addition to the standard options listed above, a @b{:class} option may be specified on the command line. If it is specified, then the new widget's class will be set to @i{className} instead of @b{Frame}. Changing the class of a frame widget may be useful in order to use a special class name in database options referring to this widget and its children. Note: @b{:class} is handled differently than other command-line options and cannot be specified using the option database (it has to be processed before the other options are even looked up, since the new class name will affect the lookup of the other options). In addition, the @b{:class} option may not be queried or changed using the @b{config} command described below. @unnumberedsubsec A Frame Widget's Arguments The @b{frame} command creates a new Tcl command whose name is the same as the path name of the frame's window. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{PathName} is the name of the command, which is the same as the frame widget's path name. @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for frame widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? }@i{?value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{frame} command. @end table @unnumberedsubsec Bindings When a new frame is created, it has no default event bindings: frames are not intended to be interactive. @unnumberedsubsec Keywords frame, widget @node label, radiobutton, frame, Widgets @section label @c @cartouche label \- Create and manipulate label widgets @unnumberedsubsec Synopsis @b{label}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example anchor borderWidth foreground relief background cursor padX text bitmap font padY textVariable @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Label @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired height for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in lines of text. If this option isn't specified, the label's desired height is computed from the size of the bitmap or text being displayed in it. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies a desired width for the label. If a bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in characters. If this option isn't specified, the label's desired width is computed from the size of the bitmap or text being displayed in it. @end table @c @end cartouche @unnumberedsubsec Description The @b{label} command creates a new window (given by the @i{pathName} argument) and makes it into a label widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the label such as its colors, font, text, and initial relief. The @b{label} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A label is a widget that displays a textual string or bitmap. The label can be manipulated in a few simple ways, such as changing its relief or text, using the commands described below. @unnumberedsubsec A Label Widget's Arguments The @b{label} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for label widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{label} command. @end table @unnumberedsubsec Bindings When a new label is created, it has no default event bindings: labels are not intended to be interactive. @unnumberedsubsec Keywords label, widget @node radiobutton, toplevel, label, Widgets @section radiobutton @c @cartouche radiobutton \- Create and manipulate radio-button widgets @unnumberedsubsec Synopsis @b{radiobutton}@i{ }@i{pathName }@r{?}@i{options}? @unnumberedsubsec Standard Options @example activeBackground bitmap font relief activeForeground borderWidth foreground text anchor cursor padX textVariable background disabledForeground padX @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Radiobutton @table @asis @item @code{@b{:command}} @flushright Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} @end flushright @sp 1 Specifies a Tcl command to associate with the button. This command is typically invoked when mouse button 1 is released over the button window. The button's global variable (@b{:variable} option) will be updated before the command is invoked. @end table @table @asis @item @code{@b{:height}} @flushright Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} @end flushright @sp 1 Specifies a desired height for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in lines of text. If this option isn't specified, the button's desired height is computed from the size of the bitmap or text being displayed in it. @end table @table @asis @item @code{@b{:selector}} @flushright Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} @end flushright @sp 1 Specifies the color to draw in the selector when this button is selected. If specified as an empty string then no selector is drawn for the button. @end table @table @asis @item @code{@b{:state}} @flushright Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} @end flushright @sp 1 Specifies one of three states for the radio button: @b{normal}@r{, }@b{active}, or @b{disabled}. In normal state the radio button is displayed using the @b{foreground}@r{ and }@b{background} options. The active state is typically used when the pointer is over the radio button. In active state the radio button is displayed using the @b{activeForeground} and @b{activeBackground} options. Disabled state means that the radio button is insensitive: it doesn't activate and doesn't respond to mouse button presses. In this state the @b{disabledForeground} and @b{background} options determine how the radio button is displayed. @end table @table @asis @item @code{@b{:value}} @flushright Name=@code{"@b{value}@r{"} Class=@code{"}@b{Value}"} @end flushright @sp 1 Specifies value to store in the button's associated variable whenever this button is selected. Defaults to the name of the radio button. @end table @table @asis @item @code{@b{:variable}} @flushright Name=@code{"@b{variable}@r{"} Class=@code{"}@b{Variable}"} @end flushright @sp 1 Specifies name of global variable to set whenever this button is selected. Changes in this variable also cause the button to select or deselect itself. Defaults to the value @b{selectedButton}. @end table @table @asis @item @code{@b{:width}} @flushright Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} @end flushright @sp 1 Specifies a desired width for the button. If a bitmap is being displayed in the button then the value is in screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); for text it is in characters. If this option isn't specified, the button's desired width is computed from the size of the bitmap or text being displayed in it. @end table @c @end cartouche @unnumberedsubsec Description The @b{radiobutton} command creates a new window (given by the @i{pathName} argument) and makes it into a radiobutton widget. Additional options, described above, may be specified on the command line or in the option database to configure aspects of the radio button such as its colors, font, text, and initial relief. The @b{radiobutton} command returns its @i{pathName} argument. At the time this command is invoked, there must not exist a window named @i{pathName}, but @i{pathName}'s parent must exist. A radio button is a widget that displays a textual string or bitmap and a diamond called a @i{selector}. A radio button has all of the behavior of a simple button: it can display itself in either of three different ways, according to the @b{state} option; it can be made to appear raised, sunken, or flat; it can be made to flash; and it invokes a Tcl command whenever mouse button 1 is clicked over the check button. In addition, radio buttons can be @i{selected}. If a radio button is selected then a special highlight appears in the selector and a Tcl variable associated with the radio button is set to a particular value. If the radio button is not selected then the selector is drawn in a different fashion. Typically, several radio buttons share a single variable and the value of the variable indicates which radio button is to be selected. When a radio button is selected it sets the value of the variable to indicate that fact; each radio button also monitors the value of the variable and automatically selects and deselects itself when the variable's value changes. By default the variable @b{selectedButton} is used; its contents give the name of the button that is selected, or the empty string if no button associated with that variable is selected. The name of the variable for a radio button, plus the variable to be stored into it, may be modified with options on the command line or in the option database. By default a radio button is configured to select itself on button clicks. @unnumberedsubsec A Radiobutton Widget's Arguments The @b{radiobutton} command creates a new Tcl command whose name is @i{pathName}. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for radio-button widgets: @table @asis @item @i{pathName }@b{:activate} Change the radio button's state to @b{active} and redisplay the button using its active foreground and background colors instead of normal colors. This command is ignored if the radio button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state active}'' instead. @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{radiobutton} command. @item @i{pathName }@b{:deactivate} Change the radio button's state to @b{normal} and redisplay the button using its normal foreground and background colors. This command is ignored if the radio button's state is @b{disabled}. This command is obsolete and will eventually be removed; use ``@i{pathName }@b{:configure :state normal}'' instead. @item @i{pathName }@b{:deselect} Deselect the radio button: redisplay it without a highlight in the selector and set the associated variable to an empty string. If this radio button was not currently selected, then the command has no effect. @item @i{pathName }@b{:flash} Flash the radio button. This is accomplished by redisplaying the radio button several times, alternating between active and normal colors. At the end of the flash the radio button is left in the same normal/active state as when the command was invoked. This command is ignored if the radio button's state is @b{disabled}. @item @i{pathName }@b{:invoke} Does just what would have happened if the user invoked the radio button with the mouse: select the button and invoke its associated Tcl command, if there is one. The return value is the return value from the Tcl command, or an empty string if there is no command associated with the radio button. This command is ignored if the radio button's state is @b{disabled}. @item @i{pathName }@b{:select} Select the radio button: display it with a highlighted selector and set the associated variable to the value corresponding to this widget. @end table @unnumberedsubsec Bindings Tk automatically creates class bindings for radio buttons that give them the following default behavior: @itemize @asis{} @item [1] The radio button activates whenever the mouse passes over it and deactivates whenever the mouse leaves the radio button. @item [2] The radio button's relief is changed to sunken whenever mouse button 1 is pressed over it, and the relief is restored to its original value when button 1 is later released. @item [3] If mouse button 1 is pressed over the radio button and later released over the radio button, the radio button is invoked (i.e. it is selected and the command associated with the button is invoked, if there is one). However, if the mouse is not over the radio button when button 1 is released, then no invocation occurs. @end itemize The behavior of radio buttons can be changed by defining new bindings for individual widgets or by redefining the class bindings. @unnumberedsubsec Keywords radio button, widget @node toplevel, , radiobutton, Widgets @section toplevel @c @cartouche toplevel \- Create and manipulate toplevel widgets @unnumberedsubsec Synopsis @b{toplevel}@i{ }@i{pathName }@r{?}@b{:screen }@i{screenName}@r{? ?}@b{:class }@i{className}@r{? ?}@i{options}? @unnumberedsubsec Standard Options @example background geometry borderWidth relief @end example @xref{options}, for more information. @unnumberedsubsec Arguments for Toplevel @c @end cartouche @unnumberedsubsec Description The @b{toplevel} command creates a new toplevel widget (given by the @i{pathName} argument). Additional options, described above, may be specified on the command line or in the option database to configure aspects of the toplevel such as its background color and relief. The @b{toplevel} command returns the path name of the new window. A toplevel is similar to a frame except that it is created as a top-level window: its X parent is the root window of a screen rather than the logical parent from its path name. The primary purpose of a toplevel is to serve as a container for dialog boxes and other collections of widgets. The only features of a toplevel are its background color and an optional 3-D border to make the toplevel appear raised or sunken. Two special command-line options may be provided to the @b{toplevel} command: @b{:class}@r{ and }@b{:screen}@r{. If }@b{:class} is specified, then the new widget's class will be set to @i{className}@r{ instead of }@b{Toplevel}. Changing the class of a toplevel widget may be useful in order to use a special class name in database options referring to this widget and its children. The @b{:screen} option may be used to place the window on a different screen than the window's logical parent. Any valid screen name may be used, even one associated with a different display. Note: @b{:class}@r{ and }@b{:screen} are handled differently than other command-line options. They may not be specified using the option database (these options must have been processed before the new window has been created enough to use the option database; in particular, the new class name will affect the lookup of options in the database). In addition, @b{:class}@r{ and }@b{:screen} may not be queried or changed using the @b{config} command described below. However, the @b{winfo :class} command may be used to query the class of a window, and @b{winfo :screen} may be used to query its screen. @unnumberedsubsec A Toplevel Widget's Arguments The @b{toplevel} command creates a new Tcl command whose name is the same as the path name of the toplevel's window. This command may be used to invoke various operations on the widget. It has the following general form: @example @i{pathName option }@r{?}@i{arg arg ...}? @end example @i{PathName} is the name of the command, which is the same as the toplevel widget's path name. @i{Option}@r{ and the }@i{arg}s determine the exact behavior of the command. The following commands are possible for toplevel widgets: @table @asis @item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? Query or modify the configuration options of the widget. If no @i{option} is specified, returns a list describing all of the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for information on the format of this list). If @i{option} is specified with no @i{value}, then the command returns a list describing the one named option (this list will be identical to the corresponding sublist of the value returned if no @i{option} is specified). If one or more @i{option:value} pairs are specified, then the command modifies the given widget option(s) to have the given value(s); in this case the command returns an empty string. @i{Option}@r{ may have any of the values accepted by the }@b{toplevel} command. @end table @unnumberedsubsec Bindings When a new toplevel is created, it has no default event bindings: toplevels are not intended to be interactive. @unnumberedsubsec Keywords toplevel, widget gcl-2.6.14/info/gcl.info-40000644000175000017500000112366414360276512013526 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: Introduction to Slots, Next: Accessing Slots, Prev: Slots, Up: Slots 7.5.1 Introduction to Slots --------------------------- An object of metaclass standard-class has zero or more named slots. The slots of an object are determined by the class of the object. Each slot can hold one value. [Reviewer Note by Barmar: All symbols are valid variable names. Perhaps this means to preclude the use of named constants? We have a terminology problem to solve.] The name of a slot is a symbol that is syntactically valid for use as a variable name. When a slot does not have a value, the slot is said to be unbound. When an unbound slot is read, [Reviewer Note by Barmar: from an object whose metaclass is standard-class?] the generic function slot-unbound is invoked. The system-supplied primary method for slot-unbound on class t signals an error. If slot-unbound returns, its primary value is used that time as the value of the slot. The default initial value form for a slot is defined by the :initform slot option. When the :initform form is used to supply a value, it is evaluated in the lexical environment in which the defclass form was evaluated. The :initform along with the lexical environment in which the defclass form was evaluated is called a captured initialization form. For more details, see *note Object Creation and Initialization::. A local slot is defined to be a slot that is accessible to exactly one instance, namely the one in which the slot is allocated. A shared slot is defined to be a slot that is visible to more than one instance of a given class and its subclasses. A class is said to define a slot with a given name when the defclass form for that class contains a slot specifier with that name. Defining a local slot does not immediately create a slot; it causes a slot to be created each time an instance of the class is created. Defining a shared slot immediately creates a slot. The :allocation slot option to defclass controls the kind of slot that is defined. If the value of the :allocation slot option is :instance, a local slot is created. If the value of :allocation is :class, a shared slot is created. A slot is said to be accessible in an instance of a class if the slot is defined by the class of the instance or is inherited from a superclass of that class. At most one slot of a given name can be accessible in an instance. A shared slot defined by a class is accessible in all instances of that class. A detailed explanation of the inheritance of slots is given in *note Inheritance of Slots and Slot Options::.  File: gcl.info, Node: Accessing Slots, Next: Inheritance of Slots and Slot Options, Prev: Introduction to Slots, Up: Slots 7.5.2 Accessing Slots --------------------- Slots can be accessed in two ways: by use of the primitive function slot-value and by use of generic functions generated by the defclass form. The function slot-value can be used with any of the slot names specified in the defclass form to access a specific slot accessible in an instance of the given class. The macro defclass provides syntax for generating methods to read and write slots. If a reader method is requested, a method is automatically generated for reading the value of the slot, but no method for storing a value into it is generated. If a writer method is requested, a method is automatically generated for storing a value into the slot, but no method for reading its value is generated. If an accessor method is requested, a method for reading the value of the slot and a method for storing a value into the slot are automatically generated. Reader and writer methods are implemented using slot-value. When a reader or writer method is specified for a slot, the name of the generic function to which the generated method belongs is directly specified. If the name specified for the writer method is the symbol name, the name of the generic function for writing the slot is the symbol name, and the generic function takes two arguments: the new value and the instance, in that order. If the name specified for the accessor method is the symbol name, the name of the generic function for reading the slot is the symbol name, and the name of the generic function for writing the slot is the list (setf name). A generic function created or modified by supplying :reader, :writer, or :accessor slot options can be treated exactly as an ordinary generic function. Note that slot-value can be used to read or write the value of a slot whether or not reader or writer methods exist for that slot. When slot-value is used, no reader or writer methods are invoked. The macro with-slots can be used to establish a lexical environment in which specified slots are lexically available as if they were variables. The macro with-slots invokes the function slot-value to access the specified slots. The macro with-accessors can be used to establish a lexical environment in which specified slots are lexically available through their accessors as if they were variables. The macro with-accessors invokes the appropriate accessors to access the specified slots.  File: gcl.info, Node: Inheritance of Slots and Slot Options, Prev: Accessing Slots, Up: Slots 7.5.3 Inheritance of Slots and Slot Options ------------------------------------------- The set of the names of all slots accessible in an instance of a class C is the union of the sets of names of slots defined by C and its superclasses. The structure of an instance is the set of names of local slots in that instance. In the simplest case, only one class among C and its superclasses defines a slot with a given slot name. If a slot is defined by a superclass of C, the slot is said to be inherited. The characteristics of the slot are determined by the slot specifier of the defining class. Consider the defining class for a slot S. If the value of the :allocation slot option is :instance, then S is a local slot and each instance of C has its own slot named S that stores its own value. If the value of the :allocation slot option is :class, then S is a shared slot, the class that defined S stores the value, and all instances of C can access that single slot. If the :allocation slot option is omitted, :instance is used. In general, more than one class among C and its superclasses can define a slot with a given name. In such cases, only one slot with the given name is accessible in an instance of C, and the characteristics of that slot are a combination of the several slot specifiers, computed as follows: * All the slot specifiers for a given slot name are ordered from most specific to least specific, according to the order in C's class precedence list of the classes that define them. All references to the specificity of slot specifiers immediately below refers to this ordering. * The allocation of a slot is controlled by the most specific slot specifier. If the most specific slot specifier does not contain an :allocation slot option, :instance is used. Less specific slot specifiers do not affect the allocation. * The default initial value form for a slot is the value of the :initform slot option in the most specific slot specifier that contains one. If no slot specifier contains an :initform slot option, the slot has no default initial value form. * The contents of a slot will always be of type (and T_1 ... T_n) where T_1 ... T_n are the values of the :type slot options contained in all of the slot specifiers. If no slot specifier contains the :type slot option, the contents of the slot will always be of type t. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot are undefined. * The set of initialization arguments that initialize a given slot is the union of the initialization arguments declared in the :initarg slot options in all the slot specifiers. * The documentation string for a slot is the value of the :documentation slot option in the most specific slot specifier that contains one. If no slot specifier contains a :documentation slot option, the slot has no documentation string. A consequence of the allocation rule is that a shared slot can be shadowed. For example, if a class C_1 defines a slot named S whose value for the :allocation slot option is :class, that slot is accessible in instances of C_1 and all of its subclasses. However, if C_2 is a subclass of C_1 and also defines a slot named S, C_1's slot is not shared by instances of C_2 and its subclasses. When a class C_1 defines a shared slot, any subclass C_2 of C_1 will share this single slot unless the defclass form for C_2 specifies a slot of the same name or there is a superclass of C_2 that precedes C_1 in the class precedence list of C_2 that defines a slot of the same name. A consequence of the type rule is that the value of a slot satisfies the type constraint of each slot specifier that contributes to that slot. Because the result of attempting to store in a slot a value that does not satisfy the type constraint for the slot is undefined, the value in a slot might fail to satisfy its type constraint. The :reader, :writer, and :accessor slot options create methods rather than define the characteristics of a slot. Reader and writer methods are inherited in the sense described in *note Inheritance of Methods::. Methods that access slots use only the name of the slot and the type of the slot's value. Suppose a superclass provides a method that expects to access a shared slot of a given name, and a subclass defines a local slot with the same name. If the method provided by the superclass is used on an instance of the subclass, the method accesses the local slot.  File: gcl.info, Node: Generic Functions and Methods, Next: Objects Dictionary, Prev: Slots, Up: Objects 7.6 Generic Functions and Methods ================================= * Menu: * Introduction to Generic Functions:: * Introduction to Methods:: * Agreement on Parameter Specializers and Qualifiers:: * Congruent Lambda-lists for all Methods of a Generic Function:: * Keyword Arguments in Generic Functions and Methods:: * Method Selection and Combination:: * Inheritance of Methods::  File: gcl.info, Node: Introduction to Generic Functions, Next: Introduction to Methods, Prev: Generic Functions and Methods, Up: Generic Functions and Methods 7.6.1 Introduction to Generic Functions --------------------------------------- A generic function is a function whose behavior depends on the classes or identities of the arguments supplied to it. A generic function object is associated with a set of methods, a lambda list, a method combination_2, and other information. Like an ordinary function, a generic function takes arguments, performs a series of operations, and perhaps returns useful values. An ordinary function has a single body of code that is always executed when the function is called. A generic function has a set of bodies of code of which a subset is selected for execution. The selected bodies of code and the manner of their combination are determined by the classes or identities of one or more of the arguments to the generic function and by its method combination. Ordinary functions and generic functions are called with identical syntax. Generic functions are true functions that can be passed as arguments and used as the first argument to funcall and apply. A binding of a function name to a generic function can be established in one of several ways. It can be established in the global environment by ensure-generic-function, defmethod (implicitly, due to ensure-generic-function) or defgeneric (also implicitly, due to ensure-generic-function). No standardized mechanism is provided for establishing a binding of a function name to a generic function in the lexical environment. When a defgeneric form is evaluated, one of three actions is taken (due to ensure-generic-function): * If a generic function of the given name already exists, the existing generic function object is modified. Methods specified by the current defgeneric form are added, and any methods in the existing generic function that were defined by a previous defgeneric form are removed. Methods added by the current defgeneric form might replace methods defined by defmethod, defclass, define-condition, or defstruct. No other methods in the generic function are affected or replaced. * If the given name names an ordinary function, a macro, or a special operator, an error is signaled. * Otherwise a generic function is created with the methods specified by the method definitions in the defgeneric form. Some operators permit specification of the options of a generic function, such as the type of method combination it uses or its argument precedence order. These operators will be referred to as "operators that specify generic function options." The only standardized operator in this category is defgeneric. Some operators define methods for a generic function. These operators will be referred to as method-defining operators ; their associated forms are called method-defining forms. The standardized method-defining operators are listed in Figure 7-2. defgeneric defmethod defclass define-condition defstruct Figure 7-2: Standardized Method-Defining Operators Note that of the standardized method-defining operators only defgeneric can specify generic function options. defgeneric and any implementation-defined operators that can specify generic function options are also referred to as "operators that specify generic function options."  File: gcl.info, Node: Introduction to Methods, Next: Agreement on Parameter Specializers and Qualifiers, Prev: Introduction to Generic Functions, Up: Generic Functions and Methods 7.6.2 Introduction to Methods ----------------------------- Methods define the class-specific or identity-specific behavior and operations of a generic function. A method object is associated with code that implements the method's behavior, a sequence of parameter specializers that specify when the given method is applicable, a lambda list, and a sequence of qualifiers that are used by the method combination facility to distinguish among methods. A method object is not a function and cannot be invoked as a function. Various mechanisms in the object system take a method object and invoke its method function, as is the case when a generic function is invoked. When this occurs it is said that the method is invoked or called. A method-defining form contains the code that is to be run when the arguments to the generic function cause the method that it defines to be invoked. When a method-defining form is evaluated, a method object is created and one of four actions is taken: * If a generic function of the given name already exists and if a method object already exists that agrees with the new one on parameter specializers and qualifiers, the new method object replaces the old one. For a definition of one method agreeing with another on parameter specializers and qualifiers, see *note Agreement on Parameter Specializers and Qualifiers::. * If a generic function of the given name already exists and if there is no method object that agrees with the new one on parameter specializers and qualifiers, the existing generic function object is modified to contain the new method object. * If the given name names an ordinary function, a macro, or a special operator, an error is signaled. * Otherwise a generic function is created with the method specified by the method-defining form. If the lambda list of a new method is not congruent with the lambda list of the generic function, an error is signaled. If a method-defining operator that cannot specify generic function options creates a new generic function, a lambda list for that generic function is derived from the lambda list of the method in the method-defining form in such a way as to be congruent with it. For a discussion of congruence , see *note Congruent Lambda-lists for all Methods of a Generic Function::. Each method has a specialized lambda list, which determines when that method can be applied. A specialized lambda list is like an ordinary lambda list except that a specialized parameter may occur instead of the name of a required parameter. A specialized parameter is a list (variable-name parameter-specializer-name), where parameter-specializer-name is one of the following: a symbol denotes a parameter specializer which is the class named by that symbol. a class denotes a parameter specializer which is the class itself. (eql form) denotes a parameter specializer which satisfies the type specifier (eql object), where object is the result of evaluating form. The form form is evaluated in the lexical environment in which the method-defining form is evaluated. Note that form is evaluated only once, at the time the method is defined, not each time the generic function is called. Parameter specializer names are used in macros intended as the user-level interface (defmethod), while parameter specializers are used in the functional interface. Only required parameters may be specialized, and there must be a parameter specializer for each required parameter. For notational simplicity, if some required parameter in a specialized lambda list in a method-defining form is simply a variable name, its parameter specializer defaults to the class t. Given a generic function and a set of arguments, an applicable method is a method for that generic function whose parameter specializers are satisfied by their corresponding arguments. The following definition specifies what it means for a method to be applicable and for an argument to satisfy a parameter specializer. Let < A_1, ..., A_n> be the required arguments to a generic function in order. Let < P_1, ..., P_n> be the parameter specializers corresponding to the required parameters of the method M in order. The method M is applicable when each A_i is of the type specified by the type specifier P_i. Because every valid parameter specializer is also a valid type specifier, the function typep can be used during method selection to determine whether an argument satisfies a parameter specializer. A method all of whose parameter specializers are the class t is called a default method ; it is always applicable but may be shadowed by a more specific method. Methods can have qualifiers, which give the method combination procedure a way to distinguish among methods. A method that has one or more qualifiers is called a qualified method. A method with no qualifiers is called an unqualified method. A qualifier is any non-list. The qualifiers defined by the standardized method combination types are symbols. In this specification, the terms "primary method" and "auxiliary method" are used to partition methods within a method combination type according to their intended use. In standard method combination, primary methods are unqualified methods and auxiliary methods are methods with a single qualifier that is one of :around, :before, or :after. Methods with these qualifiers are called around methods, before methods, and after methods, respectively. When a method combination type is defined using the short form of define-method-combination, primary methods are methods qualified with the name of the type of method combination, and auxiliary methods have the qualifier :around. Thus the terms "primary method" and "auxiliary method" have only a relative definition within a given method combination type.  File: gcl.info, Node: Agreement on Parameter Specializers and Qualifiers, Next: Congruent Lambda-lists for all Methods of a Generic Function, Prev: Introduction to Methods, Up: Generic Functions and Methods 7.6.3 Agreement on Parameter Specializers and Qualifiers -------------------------------------------------------- Two methods are said to agree with each other on parameter specializers and qualifiers if the following conditions hold: 1. Both methods have the same number of required parameters. Suppose the parameter specializers of the two methods are P_{1,1}... P_{1,n} and P_{2,1}... P_{2,n}. 2. For each 1<= i<= n, P_{1,i} agrees with P_{2,i}. The parameter specializer P_{1,i} agrees with P_{2,i} if P_{1,i} and P_{2,i} are the same class or if P_{1,i}=(eql object_1), P_{2,i}=(eql object_2), and (eql object_1 object_2). Otherwise P_{1,i} and P_{2,i} do not agree. 3. The two lists of qualifiers are the same under equal.  File: gcl.info, Node: Congruent Lambda-lists for all Methods of a Generic Function, Next: Keyword Arguments in Generic Functions and Methods, Prev: Agreement on Parameter Specializers and Qualifiers, Up: Generic Functions and Methods 7.6.4 Congruent Lambda-lists for all Methods of a Generic Function ------------------------------------------------------------------ These rules define the congruence of a set of lambda lists, including the lambda list of each method for a given generic function and the lambda list specified for the generic function itself, if given. 1. Each lambda list must have the same number of required parameters. 2. Each lambda list must have the same number of optional parameters. Each method can supply its own default for an optional parameter. 3. If any lambda list mentions &rest or &key, each lambda list must mention one or both of them. 4. If the generic function lambda list mentions &key, each method must accept all of the keyword names mentioned after &key, either by accepting them explicitly, by specifying &allow-other-keys, or by specifying &rest but not &key. Each method can accept additional keyword arguments of its own. The checking of the validity of keyword names is done in the generic function, not in each method. A method is invoked as if the keyword argument pair whose name is :allow-other-keys and whose value is true were supplied, though no such argument pair will be passed. 5. The use of &allow-other-keys need not be consistent across lambda lists. If &allow-other-keys is mentioned in the lambda list of any applicable method or of the generic function, any keyword arguments may be mentioned in the call to the generic function. 6. The use of &aux need not be consistent across methods. If a method-defining operator that cannot specify generic function options creates a generic function, and if the lambda list for the method mentions keyword arguments, the lambda list of the generic function will mention &key (but no keyword arguments).  File: gcl.info, Node: Keyword Arguments in Generic Functions and Methods, Next: Method Selection and Combination, Prev: Congruent Lambda-lists for all Methods of a Generic Function, Up: Generic Functions and Methods 7.6.5 Keyword Arguments in Generic Functions and Methods -------------------------------------------------------- When a generic function or any of its methods mentions &key in a lambda list, the specific set of keyword arguments accepted by the generic function varies according to the applicable methods. The set of keyword arguments accepted by the generic function for a particular call is the union of the keyword arguments accepted by all applicable methods and the keyword arguments mentioned after &key in the generic function definition, if any. A method that has &rest but not &key does not affect the set of acceptable keyword arguments. If the lambda list of any applicable method or of the generic function definition contains &allow-other-keys, all keyword arguments are accepted by the generic function. The lambda list congruence rules require that each method accept all of the keyword arguments mentioned after &key in the generic function definition, by accepting them explicitly, by specifying &allow-other-keys, or by specifying &rest but not &key. Each method can accept additional keyword arguments of its own, in addition to the keyword arguments mentioned in the generic function definition. If a generic function is passed a keyword argument that no applicable method accepts, an error should be signaled; see *note Error Checking in Function Calls::. * Menu: * Examples of Keyword Arguments in Generic Functions and Methods::  File: gcl.info, Node: Examples of Keyword Arguments in Generic Functions and Methods, Prev: Keyword Arguments in Generic Functions and Methods, Up: Keyword Arguments in Generic Functions and Methods 7.6.5.1 Examples of Keyword Arguments in Generic Functions and Methods ...................................................................... For example, suppose there are two methods defined for width as follows: (defmethod width ((c character-class) &key font) ...) (defmethod width ((p picture-class) &key pixel-size) ...) Assume that there are no other methods and no generic function definition for width. The evaluation of the following form should signal an error because the keyword argument :pixel-size is not accepted by the applicable method. (width (make-instance `character-class :char #\Q) :font 'baskerville :pixel-size 10) The evaluation of the following form should signal an error. (width (make-instance `picture-class :glyph (glyph #\Q)) :font 'baskerville :pixel-size 10) The evaluation of the following form will not signal an error if the class named character-picture-class is a subclass of both picture-class and character-class. (width (make-instance `character-picture-class :char #\Q) :font 'baskerville :pixel-size 10)  File: gcl.info, Node: Method Selection and Combination, Next: Inheritance of Methods, Prev: Keyword Arguments in Generic Functions and Methods, Up: Generic Functions and Methods 7.6.6 Method Selection and Combination -------------------------------------- When a generic function is called with particular arguments, it must determine the code to execute. This code is called the effective method for those arguments. The effective method is a combination of the applicable methods in the generic function that calls some or all of the methods. If a generic function is called and no methods are applicable, the generic function no-applicable-method is invoked, with the results from that call being used as the results of the call to the original generic function. Calling no-applicable-method takes precedence over checking for acceptable keyword arguments; see *note Keyword Arguments in Generic Functions and Methods::. When the effective method has been determined, it is invoked with the same arguments as were passed to the generic function. Whatever values it returns are returned as the values of the generic function. * Menu: * Determining the Effective Method:: * Selecting the Applicable Methods:: * Sorting the Applicable Methods by Precedence Order:: * Applying method combination to the sorted list of applicable methods:: * Standard Method Combination:: * Declarative Method Combination:: * Built-in Method Combination Types::  File: gcl.info, Node: Determining the Effective Method, Next: Selecting the Applicable Methods, Prev: Method Selection and Combination, Up: Method Selection and Combination 7.6.6.1 Determining the Effective Method ........................................ The effective method is determined by the following three-step procedure: 1. Select the applicable methods. 2. Sort the applicable methods by precedence order, putting the most specific method first. 3. Apply method combination to the sorted list of applicable methods, producing the effective method.  File: gcl.info, Node: Selecting the Applicable Methods, Next: Sorting the Applicable Methods by Precedence Order, Prev: Determining the Effective Method, Up: Method Selection and Combination 7.6.6.2 Selecting the Applicable Methods ........................................ This step is described in *note Introduction to Methods::.  File: gcl.info, Node: Sorting the Applicable Methods by Precedence Order, Next: Applying method combination to the sorted list of applicable methods, Prev: Selecting the Applicable Methods, Up: Method Selection and Combination 7.6.6.3 Sorting the Applicable Methods by Precedence Order .......................................................... To compare the precedence of two methods, their parameter specializers are examined in order. The default examination order is from left to right, but an alternative order may be specified by the :argument-precedence-order option to defgeneric or to any of the other operators that specify generic function options. The corresponding parameter specializers from each method are compared. When a pair of parameter specializers agree, the next pair are compared for agreement. If all corresponding parameter specializers agree, the two methods must have different qualifiers; in this case, either method can be selected to precede the other. For information about agreement, see *note Agreement on Parameter Specializers and Qualifiers::. If some corresponding parameter specializers do not agree, the first pair of parameter specializers that do not agree determines the precedence. If both parameter specializers are classes, the more specific of the two methods is the method whose parameter specializer appears earlier in the class precedence list of the corresponding argument. Because of the way in which the set of applicable methods is chosen, the parameter specializers are guaranteed to be present in the class precedence list of the class of the argument. If just one of a pair of corresponding parameter specializers is (eql object), the method with that parameter specializer precedes the other method. If both parameter specializers are eql expressions, the specializers must agree (otherwise the two methods would not both have been applicable to this argument). The resulting list of applicable methods has the most specific method first and the least specific method last.  File: gcl.info, Node: Applying method combination to the sorted list of applicable methods, Next: Standard Method Combination, Prev: Sorting the Applicable Methods by Precedence Order, Up: Method Selection and Combination 7.6.6.4 Applying method combination to the sorted list of applicable methods ............................................................................ In the simple case--if standard method combination is used and all applicable methods are primary methods--the effective method is the most specific method. That method can call the next most specific method by using the function call-next-method. The method that call-next-method will call is referred to as the next method . The predicate next-method-p tests whether a next method exists. If call-next-method is called and there is no next most specific method, the generic function no-next-method is invoked. In general, the effective method is some combination of the applicable methods. It is described by a form that contains calls to some or all of the applicable methods, returns the value or values that will be returned as the value or values of the generic function, and optionally makes some of the methods accessible by means of call-next-method. The role of each method in the effective method is determined by its qualifiers and the specificity of the method. A qualifier serves to mark a method, and the meaning of a qualifier is determined by the way that these marks are used by this step of the procedure. If an applicable method has an unrecognized qualifier, this step signals an error and does not include that method in the effective method. When standard method combination is used together with qualified methods, the effective method is produced as described in *note Standard Method Combination::. Another type of method combination can be specified by using the :method-combination option of defgeneric or of any of the other operators that specify generic function options. In this way this step of the procedure can be customized. New types of method combination can be defined by using the define-method-combination macro.  File: gcl.info, Node: Standard Method Combination, Next: Declarative Method Combination, Prev: Applying method combination to the sorted list of applicable methods, Up: Method Selection and Combination 7.6.6.5 Standard Method Combination ................................... Standard method combination is supported by the class standard-generic-function. It is used if no other type of method combination is specified or if the built-in method combination type standard is specified. Primary methods define the main action of the effective method, while auxiliary methods modify that action in one of three ways. A primary method has no method qualifiers. An auxiliary method is a method whose qualifier is :before, :after, or :around. Standard method combination allows no more than one qualifier per method; if a method definition specifies more than one qualifier per method, an error is signaled. * A before method has the keyword :before as its only qualifier. A before method specifies code that is to be run before any primary methods. * An after method has the keyword :after as its only qualifier. An after method specifies code that is to be run after primary methods. * An around method has the keyword :around as its only qualifier. An around method specifies code that is to be run instead of other applicable methods, but which might contain explicit code which calls some of those shadowed methods (via call-next-method). The semantics of standard method combination is as follows: * If there are any around methods, the most specific around method is called. It supplies the value or values of the generic function. * Inside the body of an around method, call-next-method can be used to call the next method. When the next method returns, the around method can execute more code, perhaps based on the returned value or values. The generic function no-next-method is invoked if call-next-method is used and there is no applicable method to call. The function next-method-p may be used to determine whether a next method exists. * If an around method invokes call-next-method, the next most specific around method is called, if one is applicable. If there are no around methods or if call-next-method is called by the least specific around method, the other methods are called as follows: - All the before methods are called, in most-specific-first order. Their values are ignored. An error is signaled if call-next-method is used in a before method. - The most specific primary method is called. Inside the body of a primary method, call-next-method may be used to call the next most specific primary method. When that method returns, the previous primary method can execute more code, perhaps based on the returned value or values. The generic function no-next-method is invoked if call-next-method is used and there are no more applicable primary methods. The function next-method-p may be used to determine whether a next method exists. If call-next-method is not used, only the most specific primary method is called. - All the after methods are called in most-specific-last order. Their values are ignored. An error is signaled if call-next-method is used in an after method. * If no around methods were invoked, the most specific primary method supplies the value or values returned by the generic function. The value or values returned by the invocation of call-next-method in the least specific around method are those returned by the most specific primary method. In standard method combination, if there is an applicable method but no applicable primary method, an error is signaled. The before methods are run in most-specific-first order while the after methods are run in least-specific-first order. The design rationale for this difference can be illustrated with an example. Suppose class C_1 modifies the behavior of its superclass, C_2, by adding before methods and after methods. Whether the behavior of the class C_2 is defined directly by methods on C_2 or is inherited from its superclasses does not affect the relative order of invocation of methods on instances of the class C_1. Class C_1's before method runs before all of class C_2's methods. Class C_1's after method runs after all of class C_2's methods. By contrast, all around methods run before any other methods run. Thus a less specific around method runs before a more specific primary method. If only primary methods are used and if call-next-method is not used, only the most specific method is invoked; that is, more specific methods shadow more general ones.  File: gcl.info, Node: Declarative Method Combination, Next: Built-in Method Combination Types, Prev: Standard Method Combination, Up: Method Selection and Combination 7.6.6.6 Declarative Method Combination ...................................... The macro define-method-combination defines new forms of method combination. It provides a mechanism for customizing the production of the effective method. The default procedure for producing an effective method is described in *note Determining the Effective Method::. There are two forms of define-method-combination. The short form is a simple facility while the long form is more powerful and more verbose. The long form resembles defmacro in that the body is an expression that computes a Lisp form; it provides mechanisms for implementing arbitrary control structures within method combination and for arbitrary processing of method qualifiers.  File: gcl.info, Node: Built-in Method Combination Types, Prev: Declarative Method Combination, Up: Method Selection and Combination 7.6.6.7 Built-in Method Combination Types ......................................... The object system provides a set of built-in method combination types. To specify that a generic function is to use one of these method combination types, the name of the method combination type is given as the argument to the :method-combination option to defgeneric or to the :method-combination option to any of the other operators that specify generic function options. The names of the built-in method combination types are listed in Figure 7-3. + append max nconc progn and list min or standard Figure 7-3: Built-in Method Combination Types The semantics of the standard built-in method combination type is described in *note Standard Method Combination::. The other built-in method combination types are called simple built-in method combination types. The simple built-in method combination types act as though they were defined by the short form of define-method-combination. They recognize two roles for methods: * An around method has the keyword symbol :around as its sole qualifier. The meaning of :around methods is the same as in standard method combination. Use of the functions call-next-method and next-method-p is supported in around methods. * A primary method has the name of the method combination type as its sole qualifier. For example, the built-in method combination type and recognizes methods whose sole qualifier is and; these are primary methods. Use of the functions call-next-method and next-method-p is not supported in primary methods. The semantics of the simple built-in method combination types is as follows: * If there are any around methods, the most specific around method is called. It supplies the value or values of the generic function. * Inside the body of an around method, the function call-next-method can be used to call the next method. The generic function no-next-method is invoked if call-next-method is used and there is no applicable method to call. The function next-method-p may be used to determine whether a next method exists. When the next method returns, the around method can execute more code, perhaps based on the returned value or values. * If an around method invokes call-next-method, the next most specific around method is called, if one is applicable. If there are no around methods or if call-next-method is called by the least specific around method, a Lisp form derived from the name of the built-in method combination type and from the list of applicable primary methods is evaluated to produce the value of the generic function. Suppose the name of the method combination type is operator and the call to the generic function is of the form (generic-function a_1... a_n) Let M_1,...,M_k be the applicable primary methods in order; then the derived Lisp form is (operator < M_1 a_1... a_n>...< M_k a_1... a_n>) If the expression < M_i a_1... a_n> is evaluated, the method M_i will be applied to the arguments a_1... a_n. For example, if operator is or, the expression < M_i a_1... a_n> is evaluated only if < M_j a_1... a_n>, 1<= j keys, allow-other-keys-p Method Signatures:: ................... 'function-keywords' (method standard-method) Arguments and Values:: ...................... method--a method. keys--a list. allow-other-keys-p--a generalized boolean. Description:: ............. Returns the keyword parameter specifiers for a method. Two values are returned: a list of the explicitly named keywords and a generalized boolean that states whether &allow-other-keys had been specified in the method definition. Examples:: .......... (defmethod gf1 ((a integer) &optional (b 2) &key (c 3) ((:dee d) 4) e ((eff f))) (list a b c d e f)) => # (find-method #'gf1 '() (list (find-class 'integer))) => # (function-keywords *) => (:C :DEE :E EFF), false (defmethod gf2 ((a integer)) (list a b c d e f)) => # (function-keywords (find-method #'gf1 '() (list (find-class 'integer)))) => (), false (defmethod gf3 ((a integer) &key b c d &allow-other-keys) (list a b c d e f)) (function-keywords *) => (:B :C :D), true Affected By:: ............. defmethod See Also:: .......... *note defmethod::  File: gcl.info, Node: ensure-generic-function, Next: allocate-instance, Prev: function-keywords, Up: Objects Dictionary 7.7.2 ensure-generic-function [Function] ---------------------------------------- 'ensure-generic-function' function-name &key argument-precedence-order declare documentation environment generic-function-class lambda-list method-class method-combination => generic-function Arguments and Values:: ...................... function-name--a function name. The keyword arguments correspond to the option arguments of defgeneric, except that the :method-class and :generic-function-class arguments can be class objects as well as names. Method-combination - method combination object. Environment - the same as the &environment argument to macro expansion functions and is used to distinguish between compile-time and run-time environments. [Editorial Note by KMP: What about documentation. Missing from this arguments enumeration, and confusing in description below.] generic-function--a generic function object. Description:: ............. The function ensure-generic-function is used to define a globally named generic function with no methods or to specify or modify options and declarations that pertain to a globally named generic function as a whole. If function-name is not fbound in the global environment, a new generic function is created. If (fdefinition function-name) is an ordinary function, a macro, or a special operator, an error is signaled. If function-name is a list, it must be of the form (setf symbol). If function-name specifies a generic function that has a different value for any of the following arguments, the generic function is modified to have the new value: :argument-precedence-order, :declare, :documentation, :method-combination. If function-name specifies a generic function that has a different value for the :lambda-list argument, and the new value is congruent with the lambda lists of all existing methods or there are no methods, the value is changed; otherwise an error is signaled. If function-name specifies a generic function that has a different value for the :generic-function-class argument and if the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error is signaled. If function-name specifies a generic function that has a different value for the :method-class argument, the value is changed, but any existing methods are not changed. Affected By:: ............. Existing function binding of function-name. Exceptional Situations:: ........................ If (fdefinition function-name) is an ordinary function, a macro, or a special operator, an error of type error is signaled. If function-name specifies a generic function that has a different value for the :lambda-list argument, and the new value is not congruent with the lambda list of any existing method, an error of type error is signaled. If function-name specifies a generic function that has a different value for the :generic-function-class argument and if the new generic function class not is compatible with the old, an error of type error is signaled. See Also:: .......... *note defgeneric::  File: gcl.info, Node: allocate-instance, Next: reinitialize-instance, Prev: ensure-generic-function, Up: Objects Dictionary 7.7.3 allocate-instance [Standard Generic Function] --------------------------------------------------- Syntax:: ........ 'allocate-instance' class &rest initargs &key &allow-other-keys => new-instance Method Signatures:: ................... 'allocate-instance' (class standard-class) &rest initargs 'allocate-instance' (class structure-class) &rest initargs Arguments and Values:: ...................... class--a class. initargs--a list of keyword/value pairs (initialization argument names and values). new-instance--an object whose class is class. Description:: ............. The generic function allocate-instance creates and returns a new instance of the class, without initializing it. When the class is a standard class, this means that the slots are unbound; when the class is a structure class, this means the slots' values are unspecified. The caller of allocate-instance is expected to have already checked the initialization arguments. The generic function allocate-instance is called by make-instance, as described in *note Object Creation and Initialization::. See Also:: .......... *note defclass:: , *note make-instance:: , *note class-of:: , *note Object Creation and Initialization:: Notes:: ....... The consequences of adding methods to allocate-instance is unspecified. This capability might be added by the Metaobject Protocol.  File: gcl.info, Node: reinitialize-instance, Next: shared-initialize, Prev: allocate-instance, Up: Objects Dictionary 7.7.4 reinitialize-instance [Standard Generic Function] ------------------------------------------------------- Syntax:: ........ 'reinitialize-instance' instance &rest initargs &key &allow-other-keys => instance Method Signatures:: ................... 'reinitialize-instance' (instance standard-object) &rest initargs Arguments and Values:: ...................... instance--an object. initargs--an initialization argument list. Description:: ............. The generic function reinitialize-instance can be used to change the values of local slots of an instance according to initargs. This generic function can be called by users. The system-supplied primary method for reinitialize-instance checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. The method then calls the generic function shared-initialize with the following arguments: the instance, nil (which means no slots should be initialized according to their initforms), and the initargs it received. Side Effects:: .............. The generic function reinitialize-instance changes the values of local slots. Exceptional Situations:: ........................ The system-supplied primary method for reinitialize-instance signals an error if an initarg is supplied that is not declared as valid. See Also:: .......... *note Initialize-Instance:: , *note Shared-Initialize:: , *note update-instance-for-redefined-class:: , *note update-instance-for-different-class:: , *note slot-boundp:: , *note slot-makunbound:: , *note Reinitializing an Instance::, *note Rules for Initialization Arguments::, *note Declaring the Validity of Initialization Arguments:: Notes:: ....... Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for reinitialize-instance or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on reinitialize-instance or shared-initialize is declared as a valid initialization argument name for all classes for which that method is applicable.  File: gcl.info, Node: shared-initialize, Next: update-instance-for-different-class, Prev: reinitialize-instance, Up: Objects Dictionary 7.7.5 shared-initialize [Standard Generic Function] --------------------------------------------------- Syntax:: ........ 'shared-initialize' instance slot-names &rest initargs &key &allow-other-keys => instance Method Signatures:: ................... 'shared-initialize' (instance standard-object) slot-names &rest initargs Arguments and Values:: ...................... instance--an object. slot-names--a list or t. initargs--a list of keyword/value pairs (of initialization argument names and values). Description:: ............. The generic function shared-initialize is used to fill the slots of an instance using initargs and :initform forms. It is called when an instance is created, when an instance is re-initialized, when an instance is updated to conform to a redefined class, and when an instance is updated to conform to a different class. The generic function shared-initialize is called by the system-supplied primary method for initialize-instance, reinitialize-instance, update-instance-for-redefined-class, and update-instance-for-different-class. The generic function shared-initialize takes the following arguments: the instance to be initialized, a specification of a set of slot-names accessible in that instance, and any number of initargs. The arguments after the first two must form an initialization argument list. The system-supplied primary method on shared-initialize initializes the slots with values according to the initargs and supplied :initform forms. Slot-names indicates which slots should be initialized according to their :initform forms if no initargs are provided for those slots. The system-supplied primary method behaves as follows, regardless of whether the slots are local or shared: * If an initarg in the initialization argument list specifies a value for that slot, that value is stored into the slot, even if a value has already been stored in the slot before the method is run. * Any slots indicated by slot-names that are still unbound at this point are initialized according to their :initform forms. For any such slot that has an :initform form, that form is evaluated in the lexical environment of its defining defclass form and the result is stored into the slot. For example, if a before method stores a value in the slot, the :initform form will not be used to supply a value for the slot. * The rules mentioned in *note Rules for Initialization Arguments:: are obeyed. The slots-names argument specifies the slots that are to be initialized according to their :initform forms if no initialization arguments apply. It can be a list of slot names, which specifies the set of those slot names; or it can be the symbol t, which specifies the set of all of the slots. See Also:: .......... *note Initialize-Instance:: , *note reinitialize-instance:: , *note update-instance-for-redefined-class:: , *note update-instance-for-different-class:: , *note slot-boundp:: , *note slot-makunbound:: , *note Object Creation and Initialization::, *note Rules for Initialization Arguments::, *note Declaring the Validity of Initialization Arguments:: Notes:: ....... Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on shared-initialize is declared as a valid initarg name for all classes for which that method is applicable. Implementations are permitted to optimize :initform forms that neither produce nor depend on side effects, by evaluating these forms and storing them into slots before running any initialize-instance methods, rather than by handling them in the primary initialize-instance method. (This optimization might be implemented by having the allocate-instance method copy a prototype instance.) Implementations are permitted to optimize default initial value forms for initargs associated with slots by not actually creating the complete initialization argument list when the only method that would receive the complete list is the method on standard-object. In this case default initial value forms can be treated like :initform forms. This optimization has no visible effects other than a performance improvement.  File: gcl.info, Node: update-instance-for-different-class, Next: update-instance-for-redefined-class, Prev: shared-initialize, Up: Objects Dictionary 7.7.6 update-instance-for-different-class [Standard Generic Function] --------------------------------------------------------------------- Syntax:: ........ 'update-instance-for-different-class' previous current &rest initargs &key &allow-other-keys => implementation-dependent Method Signatures:: ................... 'update-instance-for-different-class' (previous standard-object) (current standard-object) &rest initargs Arguments and Values:: ...................... previous--a copy of the original instance. current--the original instance (altered). initargs--an initialization argument list. Description:: ............. The generic function update-instance-for-different-class is not intended to be called by programmers. Programmers may write methods for it. The function update-instance-for-different-class is called only by the function change-class. The system-supplied primary method on update-instance-for-different-class checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. This method then initializes slots with values according to the initargs, and initializes the newly added slots with values according to their :initform forms. It does this by calling the generic function shared-initialize with the following arguments: the instance (current), a list of names of the newly added slots, and the initargs it received. Newly added slots are those local slots for which no slot of the same name exists in the previous class. Methods for update-instance-for-different-class can be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-different-class are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of update-instance-for-different-class. Methods on update-instance-for-different-class can be defined to initialize slots differently from change-class. The default behavior of change-class is described in *note Changing the Class of an Instance::. The arguments to update-instance-for-different-class are computed by change-class. When change-class is invoked on an instance, a copy of that instance is made; change-class then destructively alters the original instance. The first argument to update-instance-for-different-class, previous, is that copy; it holds the old slot values temporarily. This argument has dynamic extent within change-class; if it is referenced in any way once update-instance-for-different-class returns, the results are undefined. The second argument to update-instance-for-different-class, current, is the altered original instance. The intended use of previous is to extract old slot values by using slot-value or with-slots or by invoking a reader generic function, or to run other methods that were applicable to instances of the original class. Examples:: .......... See the example for the function change-class. Exceptional Situations:: ........................ The system-supplied primary method on update-instance-for-different-class signals an error if an initialization argument is supplied that is not declared as valid. See Also:: .......... *note change-class:: , *note Shared-Initialize:: , *note Changing the Class of an Instance::, *note Rules for Initialization Arguments::, *note Declaring the Validity of Initialization Arguments:: Notes:: ....... Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for update-instance-for-different-class or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on update-instance-for-different-class or shared-initialize is declared as a valid initarg name for all classes for which that method is applicable. The value returned by update-instance-for-different-class is ignored by change-class.  File: gcl.info, Node: update-instance-for-redefined-class, Next: change-class, Prev: update-instance-for-different-class, Up: Objects Dictionary 7.7.7 update-instance-for-redefined-class [Standard Generic Function] --------------------------------------------------------------------- Syntax:: ........ 'update-instance-for-redefined-class' instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys => {result}* Method Signatures:: ................... 'update-instance-for-redefined-class' (instance standard-object) added-slots discarded-slots property-list &rest initargs Arguments and Values:: ...................... instance--an object. added-slots--a list. discarded-slots--a list. property-list--a list. initargs--an initialization argument list. result--an object. Description:: ............. The generic function update-instance-for-redefined-class is not intended to be called by programmers. Programmers may write methods for it. The generic function update-instance-for-redefined-class is called by the mechanism activated by make-instances-obsolete. The system-supplied primary method on update-instance-for-redefined-class checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. This method then initializes slots with values according to the initargs, and initializes the newly added-slots with values according to their :initform forms. It does this by calling the generic function shared-initialize with the following arguments: the instance, a list of names of the newly added-slots to instance, and the initargs it received. Newly added-slots are those local slots for which no slot of the same name exists in the old version of the class. When make-instances-obsolete is invoked or when a class has been redefined and an instance is being updated, a property-list is created that captures the slot names and values of all the discarded-slots with values in the original instance. The structure of the instance is transformed so that it conforms to the current class definition. The arguments to update-instance-for-redefined-class are this transformed instance, a list of added-slots to the instance, a list discarded-slots from the instance, and the property-list containing the slot names and values for slots that were discarded and had values. Included in this list of discarded slots are slots that were local in the old class and are shared in the new class. The value returned by update-instance-for-redefined-class is ignored. Examples:: .......... (defclass position () ()) (defclass x-y-position (position) ((x :initform 0 :accessor position-x) (y :initform 0 :accessor position-y))) ;;; It turns out polar coordinates are used more than Cartesian ;;; coordinates, so the representation is altered and some new ;;; accessor methods are added. (defmethod update-instance-for-redefined-class :before ((pos x-y-position) added deleted plist &key) ;; Transform the x-y coordinates to polar coordinates ;; and store into the new slots. (let ((x (getf plist 'x)) (y (getf plist 'y))) (setf (position-rho pos) (sqrt (+ (* x x) (* y y))) (position-theta pos) (atan y x)))) (defclass x-y-position (position) ((rho :initform 0 :accessor position-rho) (theta :initform 0 :accessor position-theta))) ;;; All instances of the old x-y-position class will be updated ;;; automatically. ;;; The new representation is given the look and feel of the old one. (defmethod position-x ((pos x-y-position)) (with-slots (rho theta) pos (* rho (cos theta)))) (defmethod (setf position-x) (new-x (pos x-y-position)) (with-slots (rho theta) pos (let ((y (position-y pos))) (setq rho (sqrt (+ (* new-x new-x) (* y y))) theta (atan y new-x)) new-x))) (defmethod position-y ((pos x-y-position)) (with-slots (rho theta) pos (* rho (sin theta)))) (defmethod (setf position-y) (new-y (pos x-y-position)) (with-slots (rho theta) pos (let ((x (position-x pos))) (setq rho (sqrt (+ (* x x) (* new-y new-y))) theta (atan new-y x)) new-y))) Exceptional Situations:: ........................ The system-supplied primary method on update-instance-for-redefined-class signals an error if an initarg is supplied that is not declared as valid. See Also:: .......... *note make-instances-obsolete:: , *note Shared-Initialize:: , *note Redefining Classes::, *note Rules for Initialization Arguments::, *note Declaring the Validity of Initialization Arguments:: Notes:: ....... Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for update-instance-for-redefined-class or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on update-instance-for-redefined-class or shared-initialize is declared as a valid initarg name for all classes for which that method is applicable.  File: gcl.info, Node: change-class, Next: slot-boundp, Prev: update-instance-for-redefined-class, Up: Objects Dictionary 7.7.8 change-class [Standard Generic Function] ---------------------------------------------- Syntax:: ........ 'change-class' instance new-class &key &allow-other-keys => instance Method Signatures:: ................... 'change-class' (instance standard-object) (new-class standard-class) &rest initargs 'change-class' (instance t) (new-class symbol) &rest initargs Arguments and Values:: ...................... instance--an object. new-class--a class designator. initargs--an initialization argument list. Description:: ............. The generic function change-class changes the class of an instance to new-class. It destructively modifies and returns the instance. If in the old class there is any slot of the same name as a local slot in the new-class, the value of that slot is retained. This means that if the slot has a value, the value returned by slot-value after change-class is invoked is eql to the value returned by slot-value before change-class is invoked. Similarly, if the slot was unbound, it remains unbound. The other slots are initialized as described in *note Changing the Class of an Instance::. After completing all other actions, change-class invokes update-instance-for-different-class. The generic function update-instance-for-different-class can be used to assign values to slots in the transformed instance. See *note Initializing Newly Added Local Slots (Changing the Class of an Instance)::. If the second of the above methods is selected, that method invokes change-class on instance, (find-class new-class), and the initargs. Examples:: .......... (defclass position () ()) (defclass x-y-position (position) ((x :initform 0 :initarg :x) (y :initform 0 :initarg :y))) (defclass rho-theta-position (position) ((rho :initform 0) (theta :initform 0))) (defmethod update-instance-for-different-class :before ((old x-y-position) (new rho-theta-position) &key) ;; Copy the position information from old to new to make new ;; be a rho-theta-position at the same position as old. (let ((x (slot-value old 'x)) (y (slot-value old 'y))) (setf (slot-value new 'rho) (sqrt (+ (* x x) (* y y))) (slot-value new 'theta) (atan y x)))) ;;; At this point an instance of the class x-y-position can be ;;; changed to be an instance of the class rho-theta-position using ;;; change-class: (setq p1 (make-instance 'x-y-position :x 2 :y 0)) (change-class p1 'rho-theta-position) ;;; The result is that the instance bound to p1 is now an instance of ;;; the class rho-theta-position. The update-instance-for-different-class ;;; method performed the initialization of the rho and theta slots based ;;; on the value of the x and y slots, which were maintained by ;;; the old instance. See Also:: .......... *note update-instance-for-different-class:: , *note Changing the Class of an Instance:: Notes:: ....... The generic function change-class has several semantic difficulties. First, it performs a destructive operation that can be invoked within a method on an instance that was used to select that method. When multiple methods are involved because methods are being combined, the methods currently executing or about to be executed may no longer be applicable. Second, some implementations might use compiler optimizations of slot access, and when the class of an instance is changed the assumptions the compiler made might be violated. This implies that a programmer must not use change-class inside a method if any methods for that generic function access any slots, or the results are undefined.  File: gcl.info, Node: slot-boundp, Next: slot-exists-p, Prev: change-class, Up: Objects Dictionary 7.7.9 slot-boundp [Function] ---------------------------- 'slot-boundp' instance slot-name => generalized-boolean Arguments and Values:: ...................... instance--an object. slot-name--a symbol naming a slot of instance. generalized-boolean--a generalized boolean. Description:: ............. Returns true if the slot named slot-name in instance is bound; otherwise, returns false. Exceptional Situations:: ........................ If no slot of the name slot-name exists in the instance, slot-missing is called as follows: (slot-missing (class-of instance) instance slot-name 'slot-boundp) (If slot-missing is invoked and returns a value, a boolean equivalent to its primary value is returned by slot-boundp.) The specific behavior depends on instance's metaclass. An error is never signaled if instance has metaclass standard-class. An error is always signaled if instance has metaclass built-in-class. The consequences are undefined if instance has any other metaclass-an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified. See Also:: .......... *note slot-makunbound:: , *note slot-missing:: Notes:: ....... The function slot-boundp allows for writing after methods on initialize-instance in order to initialize only those slots that have not already been bound. Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-boundp using the function slot-boundp-using-class described in the Metaobject Protocol.  File: gcl.info, Node: slot-exists-p, Next: slot-makunbound, Prev: slot-boundp, Up: Objects Dictionary 7.7.10 slot-exists-p [Function] ------------------------------- 'slot-exists-p' object slot-name => generalized-boolean Arguments and Values:: ...................... object--an object. slot-name--a symbol. generalized-boolean--a generalized boolean. Description:: ............. Returns true if the object has a slot named slot-name. Affected By:: ............. defclass, defstruct See Also:: .......... *note defclass:: , *note slot-missing:: Notes:: ....... Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-exists-p using the function slot-exists-p-using-class described in the Metaobject Protocol.  File: gcl.info, Node: slot-makunbound, Next: slot-missing, Prev: slot-exists-p, Up: Objects Dictionary 7.7.11 slot-makunbound [Function] --------------------------------- 'slot-makunbound' instance slot-name => instance Arguments and Values:: ...................... instance - instance. Slot-name--a symbol. Description:: ............. The function slot-makunbound restores a slot of the name slot-name in an instance to the unbound state. Exceptional Situations:: ........................ If no slot of the name slot-name exists in the instance, slot-missing is called as follows: (slot-missing (class-of instance) instance slot-name 'slot-makunbound) (Any values returned by slot-missing in this case are ignored by slot-makunbound.) The specific behavior depends on instance's metaclass. An error is never signaled if instance has metaclass standard-class. An error is always signaled if instance has metaclass built-in-class. The consequences are undefined if instance has any other metaclass-an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified. See Also:: .......... *note slot-boundp:: , *note slot-missing:: Notes:: ....... Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-makunbound using the function slot-makunbound-using-class described in the Metaobject Protocol.  File: gcl.info, Node: slot-missing, Next: slot-unbound, Prev: slot-makunbound, Up: Objects Dictionary 7.7.12 slot-missing [Standard Generic Function] ----------------------------------------------- Syntax:: ........ 'slot-missing' class object slot-name operation &optional new-value => {result}* Method Signatures:: ................... 'slot-missing' (class t) object slot-name operation &optional new-value Arguments and Values:: ...................... class--the class of object. object--an object. slot-name--a symbol (the name of a would-be slot). operation--one of the symbols setf, slot-boundp, slot-makunbound, or slot-value. new-value--an object. result--an object. Description:: ............. The generic function slot-missing is invoked when an attempt is made to access a slot in an object whose metaclass is standard-class and the slot of the name slot-name is not a name of a slot in that class. The default method signals an error. The generic function slot-missing is not intended to be called by programmers. Programmers may write methods for it. The generic function slot-missing may be called during evaluation of slot-value, (setf slot-value), slot-boundp, and slot-makunbound. For each of these operations the corresponding symbol for the operation argument is slot-value, setf, slot-boundp, and slot-makunbound respectively. The optional new-value argument to slot-missing is used when the operation is attempting to set the value of the slot. If slot-missing returns, its values will be treated as follows: * If the operation is setf or slot-makunbound, any values will be ignored by the caller. * If the operation is slot-value, only the primary value will be used by the caller, and all other values will be ignored. * If the operation is slot-boundp, any boolean equivalent of the primary value of the method might be is used, and all other values will be ignored. Exceptional Situations:: ........................ The default method on slot-missing signals an error of type error. See Also:: .......... *note defclass:: , *note slot-exists-p:: , *note slot-value:: Notes:: ....... The set of arguments (including the class of the instance) facilitates defining methods on the metaclass for slot-missing.  File: gcl.info, Node: slot-unbound, Next: slot-value, Prev: slot-missing, Up: Objects Dictionary 7.7.13 slot-unbound [Standard Generic Function] ----------------------------------------------- Syntax:: ........ 'slot-unbound' class instance slot-name => {result}* Method Signatures:: ................... 'slot-unbound' (class t) instance slot-name Arguments and Values:: ...................... class--the class of the instance. instance--the instance in which an attempt was made to read the unbound slot. slot-name--the name of the unbound slot. result--an object. Description:: ............. The generic function slot-unbound is called when an unbound slot is read in an instance whose metaclass is standard-class. The default method signals an error of type unbound-slot. The name slot of the unbound-slot condition is initialized to the name of the offending variable, and the instance slot of the unbound-slot condition is initialized to the offending instance. The generic function slot-unbound is not intended to be called by programmers. Programmers may write methods for it. The function slot-unbound is called only indirectly by slot-value. If slot-unbound returns, only the primary value will be used by the caller, and all other values will be ignored. Exceptional Situations:: ........................ The default method on slot-unbound signals an error of type unbound-slot. See Also:: .......... *note slot-makunbound:: Notes:: ....... An unbound slot may occur if no :initform form was specified for the slot and the slot value has not been set, or if slot-makunbound has been called on the slot.  File: gcl.info, Node: slot-value, Next: method-qualifiers, Prev: slot-unbound, Up: Objects Dictionary 7.7.14 slot-value [Function] ---------------------------- 'slot-value' object slot-name => value Arguments and Values:: ...................... object--an object. name--a symbol. value--an object. Description:: ............. The function slot-value returns the value of the slot named slot-name in the object. If there is no slot named slot-name, slot-missing is called. If the slot is unbound, slot-unbound is called. The macro setf can be used with slot-value to change the value of a slot. Examples:: .......... (defclass foo () ((a :accessor foo-a :initarg :a :initform 1) (b :accessor foo-b :initarg :b) (c :accessor foo-c :initform 3))) => # (setq foo1 (make-instance 'foo :a 'one :b 'two)) => # (slot-value foo1 'a) => ONE (slot-value foo1 'b) => TWO (slot-value foo1 'c) => 3 (setf (slot-value foo1 'a) 'uno) => UNO (slot-value foo1 'a) => UNO (defmethod foo-method ((x foo)) (slot-value x 'a)) => # (foo-method foo1) => UNO Exceptional Situations:: ........................ If an attempt is made to read a slot and no slot of the name slot-name exists in the object, slot-missing is called as follows: (slot-missing (class-of instance) instance slot-name 'slot-value) (If slot-missing is invoked, its primary value is returned by slot-value.) If an attempt is made to write a slot and no slot of the name slot-name exists in the object, slot-missing is called as follows: (slot-missing (class-of instance) instance slot-name 'setf new-value) (If slot-missing returns in this case, any values are ignored.) The specific behavior depends on object's metaclass. An error is never signaled if object has metaclass standard-class. An error is always signaled if object has metaclass built-in-class. The consequences are unspecified if object has any other metaclass-an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified. See Also:: .......... *note slot-missing:: , *note slot-unbound:: , *note with-slots:: Notes:: ....... Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-value using the function slot-value-using-class described in the Metaobject Protocol. Implementations may optimize slot-value by compiling it inline.  File: gcl.info, Node: method-qualifiers, Next: no-applicable-method, Prev: slot-value, Up: Objects Dictionary 7.7.15 method-qualifiers [Standard Generic Function] ---------------------------------------------------- Syntax:: ........ 'method-qualifiers' method => qualifiers Method Signatures:: ................... 'method-qualifiers' (method standard-method) Arguments and Values:: ...................... method--a method. qualifiers--a proper list. Description:: ............. Returns a list of the qualifiers of the method. Examples:: .......... (defmethod some-gf :before ((a integer)) a) => # (method-qualifiers *) => (:BEFORE) See Also:: .......... *note define-method-combination::  File: gcl.info, Node: no-applicable-method, Next: no-next-method, Prev: method-qualifiers, Up: Objects Dictionary 7.7.16 no-applicable-method [Standard Generic Function] ------------------------------------------------------- Syntax:: ........ 'no-applicable-method' generic-function &rest function-arguments => {result}* Method Signatures:: ................... 'no-applicable-method' (generic-function t) &rest function-arguments Arguments and Values:: ...................... generic-function--a generic function on which no applicable method was found. function-arguments--arguments to the generic-function. result--an object. Description:: ............. The generic function no-applicable-method is called when a generic function is invoked and no method on that generic function is applicable. The default method signals an error. The generic function no-applicable-method is not intended to be called by programmers. Programmers may write methods for it. Exceptional Situations:: ........................ The default method signals an error of type error. See Also:: ..........  File: gcl.info, Node: no-next-method, Next: remove-method, Prev: no-applicable-method, Up: Objects Dictionary 7.7.17 no-next-method [Standard Generic Function] ------------------------------------------------- Syntax:: ........ 'no-next-method' generic-function method &rest args => {result}* Method Signatures:: ................... 'no-next-method' (generic-function standard-generic-function) (method standard-method) &rest args Arguments and Values:: ...................... generic-function - generic function to which method belongs. method - method that contained the call to call-next-method for which there is no next method. args - arguments to call-next-method. result--an object. Description:: ............. The generic function no-next-method is called by call-next-method when there is no next method. The generic function no-next-method is not intended to be called by programmers. Programmers may write methods for it. Exceptional Situations:: ........................ The system-supplied method on no-next-method signals an error of type error. [Editorial Note by KMP: perhaps control-error??] See Also:: .......... *note call-next-method::  File: gcl.info, Node: remove-method, Next: make-instance, Prev: no-next-method, Up: Objects Dictionary 7.7.18 remove-method [Standard Generic Function] ------------------------------------------------ Syntax:: ........ 'remove-method' generic-function method => generic-function Method Signatures:: ................... 'remove-method' (generic-function standard-generic-function) method Arguments and Values:: ...................... generic-function--a generic function. method--a method. Description:: ............. The generic function remove-method removes a method from generic-function by modifying the generic-function (if necessary). remove-method must not signal an error if the method is not one of the methods on the generic-function. See Also:: .......... *note find-method::  File: gcl.info, Node: make-instance, Next: make-instances-obsolete, Prev: remove-method, Up: Objects Dictionary 7.7.19 make-instance [Standard Generic Function] ------------------------------------------------ Syntax:: ........ 'make-instance' class &rest initargs &key &allow-other-keys => instance Method Signatures:: ................... 'make-instance' (class standard-class) &rest initargs 'make-instance' (class symbol) &rest initargs Arguments and Values:: ...................... class--a class, or a symbol that names a class. initargs--an initialization argument list. instance--a fresh instance of class class. Description:: ............. The generic function make-instance creates and returns a new instance of the given class. If the second of the above methods is selected, that method invokes make-instance on the arguments (find-class class) and initargs. The initialization arguments are checked within make-instance. The generic function make-instance may be used as described in *note Object Creation and Initialization::. Exceptional Situations:: ........................ If any of the initialization arguments has not been declared as valid, an error of type error is signaled. See Also:: .......... *note defclass:: , *note class-of:: , *note allocate-instance:: , *note Initialize-Instance:: , *note Object Creation and Initialization::  File: gcl.info, Node: make-instances-obsolete, Next: make-load-form, Prev: make-instance, Up: Objects Dictionary 7.7.20 make-instances-obsolete [Standard Generic Function] ---------------------------------------------------------- Syntax:: ........ 'make-instances-obsolete' class => class Method Signatures:: ................... 'make-instances-obsolete' (class standard-class) 'make-instances-obsolete' (class symbol) Arguments and Values:: ...................... class--a class designator. Description:: ............. The function make-instances-obsolete has the effect of initiating the process of updating the instances of the class. During updating, the generic function update-instance-for-redefined-class will be invoked. The generic function make-instances-obsolete is invoked automatically by the system when defclass has been used to redefine an existing standard class and the set of local slots accessible in an instance is changed or the order of slots in storage is changed. It can also be explicitly invoked by the user. If the second of the above methods is selected, that method invokes make-instances-obsolete on (find-class class). Examples:: .......... See Also:: .......... *note update-instance-for-redefined-class:: , *note Redefining Classes::  File: gcl.info, Node: make-load-form, Next: make-load-form-saving-slots, Prev: make-instances-obsolete, Up: Objects Dictionary 7.7.21 make-load-form [Standard Generic Function] ------------------------------------------------- Syntax:: ........ 'make-load-form' object &optional environment => creation-form [, initialization-form ] Method Signatures:: ................... 'make-load-form' (object standard-object) &optional environment 'make-load-form' (object structure-object) &optional environment 'make-load-form' (object condition) &optional environment 'make-load-form' (object class) &optional environment Arguments and Values:: ...................... object--an object. environment--an environment object. creation-form--a form. initialization-form--a form. Description:: ............. The generic function make-load-form creates and returns one or two forms, a creation-form and an initialization-form, that enable load to construct an object equivalent to object. Environment is an environment object corresponding to the lexical environment in which the forms will be processed. The file compiler calls make-load-form to process certain classes of literal objects; see *note Additional Constraints on Externalizable Objects::. Conforming programs may call make-load-form directly, providing object is a generalized instance of standard-object, structure-object, or condition. The creation form is a form that, when evaluated at load time, should return an object that is equivalent to object. The exact meaning of equivalent depends on the type of object and is up to the programmer who defines a method for make-load-form; see *note Literal Objects in Compiled Files::. The initialization form is a form that, when evaluated at load time, should perform further initialization of the object. The value returned by the initialization form is ignored. If make-load-form returns only one value, the initialization form is nil, which has no effect. If object appears as a constant in the initialization form, at load time it will be replaced by the equivalent object constructed by the creation form; this is how the further initialization gains access to the object. Both the creation-form and the initialization-form may contain references to any externalizable object. However, there must not be any circular dependencies in creation forms. An example of a circular dependency is when the creation form for the object X contains a reference to the object Y, and the creation form for the object Y contains a reference to the object X. Initialization forms are not subject to any restriction against circular dependencies, which is the reason that initialization forms exist; see the example of circular data structures below. The creation form for an object is always evaluated before the initialization form for that object. When either the creation form or the initialization form references other objects that have not been referenced earlier in the file being compiled, the compiler ensures that all of the referenced objects have been created before evaluating the referencing form. When the referenced object is of a type which the file compiler processes using make-load-form, this involves evaluating the creation form returned for it. (This is the reason for the prohibition against circular references among creation forms). Each initialization form is evaluated as soon as possible after its associated creation form, as determined by data flow. If the initialization form for an object does not reference any other objects not referenced earlier in the file and processed by the file compiler using make-load-form, the initialization form is evaluated immediately after the creation form. If a creation or initialization form F does contain references to such objects, the creation forms for those other objects are evaluated before F, and the initialization forms for those other objects are also evaluated before F whenever they do not depend on the object created or initialized by F. Where these rules do not uniquely determine an order of evaluation between two creation/initialization forms, the order of evaluation is unspecified. While these creation and initialization forms are being evaluated, the objects are possibly in an uninitialized state, analogous to the state of an object between the time it has been created by allocate-instance and it has been processed fully by initialize-instance. Programmers writing methods for make-load-form must take care in manipulating objects not to depend on slots that have not yet been initialized. It is implementation-dependent whether load calls eval on the forms or does some other operation that has an equivalent effect. For example, the forms might be translated into different but equivalent forms and then evaluated, they might be compiled and the resulting functions called by load, or they might be interpreted by a special-purpose function different from eval. All that is required is that the effect be equivalent to evaluating the forms. The method specialized on class returns a creation form using the name of the class if the class has a proper name in environment, signaling an error of type error if it does not have a proper name. Evaluation of the creation form uses the name to find the class with that name, as if by calling find-class. If a class with that name has not been defined, then a class may be computed in an implementation-defined manner. If a class cannot be returned as the result of evaluating the creation form, then an error of type error is signaled. Both conforming implementations and conforming programs may further specialize make-load-form. Examples:: .......... (defclass obj () ((x :initarg :x :reader obj-x) (y :initarg :y :reader obj-y) (dist :accessor obj-dist))) => # (defmethod shared-initialize :after ((self obj) slot-names &rest keys) (declare (ignore slot-names keys)) (unless (slot-boundp self 'dist) (setf (obj-dist self) (sqrt (+ (expt (obj-x self) 2) (expt (obj-y self) 2)))))) => # (defmethod make-load-form ((self obj) &optional environment) (declare (ignore environment)) ;; Note that this definition only works because X and Y do not ;; contain information which refers back to the object itself. ;; For a more general solution to this problem, see revised example below. `(make-instance ',(class-of self) :x ',(obj-x self) :y ',(obj-y self))) => # (setq obj1 (make-instance 'obj :x 3.0 :y 4.0)) => # (obj-dist obj1) => 5.0 (make-load-form obj1) => (MAKE-INSTANCE 'OBJ :X '3.0 :Y '4.0) In the above example, an equivalent instance of obj is reconstructed by using the values of two of its slots. The value of the third slot is derived from those two values. Another way to write the make-load-form method in that example is to use make-load-form-saving-slots. The code it generates might yield a slightly different result from the make-load-form method shown above, but the operational effect will be the same. For example: ;; Redefine method defined above. (defmethod make-load-form ((self obj) &optional environment) (make-load-form-saving-slots self :slot-names '(x y) :environment environment)) => # ;; Try MAKE-LOAD-FORM on object created above. (make-load-form obj1) => (ALLOCATE-INSTANCE '#), (PROGN (SETF (SLOT-VALUE '# 'X) '3.0) (SETF (SLOT-VALUE '# 'Y) '4.0) (INITIALIZE-INSTANCE '#)) In the following example, instances of my-frob are "interned" in some way. An equivalent instance is reconstructed by using the value of the name slot as a key for searching existing objects. In this case the programmer has chosen to create a new object if no existing object is found; alternatively an error could have been signaled in that case. (defclass my-frob () ((name :initarg :name :reader my-name))) (defmethod make-load-form ((self my-frob) &optional environment) (declare (ignore environment)) `(find-my-frob ',(my-name self) :if-does-not-exist :create)) In the following example, the data structure to be dumped is circular, because each parent has a list of its children and each child has a reference back to its parent. If make-load-form is called on one object in such a structure, the creation form creates an equivalent object and fills in the children slot, which forces creation of equivalent objects for all of its children, grandchildren, etc. At this point none of the parent slots have been filled in. The initialization form fills in the parent slot, which forces creation of an equivalent object for the parent if it was not already created. Thus the entire tree is recreated at load time. At compile time, make-load-form is called once for each object in the tree. All of the creation forms are evaluated, in implementation-dependent order, and then all of the initialization forms are evaluated, also in implementation-dependent order. (defclass tree-with-parent () ((parent :accessor tree-parent) (children :initarg :children))) (defmethod make-load-form ((x tree-with-parent) &optional environment) (declare (ignore environment)) (values ;; creation form `(make-instance ',(class-of x) :children ',(slot-value x 'children)) ;; initialization form `(setf (tree-parent ',x) ',(slot-value x 'parent)))) In the following example, the data structure to be dumped has no special properties and an equivalent structure can be reconstructed simply by reconstructing the slots' contents. (defstruct my-struct a b c) (defmethod make-load-form ((s my-struct) &optional environment) (make-load-form-saving-slots s :environment environment)) Exceptional Situations:: ........................ The methods specialized on standard-object, structure-object, and condition all signal an error of type error. It is implementation-dependent whether calling make-load-form on a generalized instance of a system class signals an error or returns creation and initialization forms. See Also:: .......... *note compile-file:: , *note make-load-form-saving-slots:: , *note Additional Constraints on Externalizable Objects:: *note Evaluation::, *note Compilation:: Notes:: ....... The file compiler calls make-load-form in specific circumstances detailed in *note Additional Constraints on Externalizable Objects::. Some implementations may provide facilities for defining new subclasses of classes which are specified as system classes. (Some likely candidates include generic-function, method, and stream). Such implementations should document how the file compiler processes instances of such classes when encountered as literal objects, and should document any relevant methods for make-load-form.  File: gcl.info, Node: make-load-form-saving-slots, Next: with-accessors, Prev: make-load-form, Up: Objects Dictionary 7.7.22 make-load-form-saving-slots [Function] --------------------------------------------- 'make-load-form-saving-slots' object &key slot-names environment => creation-form, initialization-form Arguments and Values:: ...................... object--an object. slot-names--a list. environment--an environment object. creation-form--a form. initialization-form--a form. Description:: ............. Returns forms that, when evaluated, will construct an object equivalent to object, without executing initialization forms. The slots in the new object that correspond to initialized slots in object are initialized using the values from object. Uninitialized slots in object are not initialized in the new object. make-load-form-saving-slots works for any instance of standard-object or structure-object. Slot-names is a list of the names of the slots to preserve. If slot-names is not supplied, its value is all of the local slots. make-load-form-saving-slots returns two values, thus it can deal with circular structures. Whether the result is useful in an application depends on whether the object's type and slot contents fully capture the application's idea of the object's state. Environment is the environment in which the forms will be processed. See Also:: .......... *note make-load-form:: , *note make-instance:: , *note setf:: , *note slot-value:: , *note slot-makunbound:: Notes:: ....... make-load-form-saving-slots can be useful in user-written make-load-form methods. When the object is an instance of standard-object, make-load-form-saving-slots could return a creation form that calls allocate-instance and an initialization form that contains calls to setf of slot-value and slot-makunbound, though other functions of similar effect might actually be used.  File: gcl.info, Node: with-accessors, Next: with-slots, Prev: make-load-form-saving-slots, Up: Objects Dictionary 7.7.23 with-accessors [Macro] ----------------------------- 'with-accessors' ({slot-entry}*) instance-form {declaration}* {form}* => {result}* slot-entry ::=(variable-name accessor-name ) Arguments and Values:: ...................... variable-name--a variable name; not evaluated. accessor-name--a function name; not evaluated. instance-form--a form; evaluated. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. Creates a lexical environment in which the slots specified by slot-entry are lexically available through their accessors as if they were variables. The macro with-accessors invokes the appropriate accessors to access the slots specified by slot-entry. Both setf and setq can be used to set the value of the slot. Examples:: .......... (defclass thing () ((x :initarg :x :accessor thing-x) (y :initarg :y :accessor thing-y))) => # (defmethod (setf thing-x) :before (new-x (thing thing)) (format t "~&Changing X from ~D to ~D in ~S.~ (thing-x thing) new-x thing)) (setq thing1 (make-instance 'thing :x 1 :y 2)) => # (setq thing2 (make-instance 'thing :x 7 :y 8)) => # (with-accessors ((x1 thing-x) (y1 thing-y)) thing1 (with-accessors ((x2 thing-x) (y2 thing-y)) thing2 (list (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setq x1 (+ y1 x2)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setf (thing-x thing2) (list x1)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2))))) |> Changing X from 1 to 9 in #. |> Changing X from 7 to (9) in #. => ((1 1 2 2 7 7 8 8) 9 (9 9 2 2 7 7 8 8) (9) (9 9 2 2 (9) (9) 8 8)) Affected By:: ............. defclass Exceptional Situations:: ........................ The consequences are undefined if any accessor-name is not the name of an accessor for the instance. See Also:: .......... *note with-slots:: , *note symbol-macrolet:: Notes:: ....... A with-accessors expression of the form: (with-accessors (slot-entry_1 ...slot-entry_n) instance-form form_1 ...form_k) expands into the equivalent of (let ((in instance-form)) (symbol-macrolet (Q_1... Q_n) form_1 ...form_k)) where Q_i is (variable-name_i () (accessor-name_i in))  File: gcl.info, Node: with-slots, Next: defclass, Prev: with-accessors, Up: Objects Dictionary 7.7.24 with-slots [Macro] ------------------------- 'with-slots' ({slot-entry}*) instance-form {declaration}* {form}* => {result}* slot-entry ::=slot-name | (variable-name slot-name) Arguments and Values:: ...................... slot-name--a slot name; not evaluated. variable-name--a variable name; not evaluated. instance-form--a form; evaluted to produce instance. instance--an object. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. The macro with-slots establishes a lexical environment for referring to the slots in the instance named by the given slot-names as though they were variables. Within such a context the value of the slot can be specified by using its slot name, as if it were a lexically bound variable. Both setf and setq can be used to set the value of the slot. The macro with-slots translates an appearance of the slot name as a variable into a call to slot-value. Examples:: .......... (defclass thing () ((x :initarg :x :accessor thing-x) (y :initarg :y :accessor thing-y))) => # (defmethod (setf thing-x) :before (new-x (thing thing)) (format t "~&Changing X from ~D to ~D in ~S.~ (thing-x thing) new-x thing)) (setq thing (make-instance 'thing :x 0 :y 1)) => # (with-slots (x y) thing (incf x) (incf y)) => 2 (values (thing-x thing) (thing-y thing)) => 1, 2 (setq thing1 (make-instance 'thing :x 1 :y 2)) => # (setq thing2 (make-instance 'thing :x 7 :y 8)) => # (with-slots ((x1 x) (y1 y)) thing1 (with-slots ((x2 x) (y2 y)) thing2 (list (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setq x1 (+ y1 x2)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2)) (setf (thing-x thing2) (list x1)) (list x1 (thing-x thing1) y1 (thing-y thing1) x2 (thing-x thing2) y2 (thing-y thing2))))) |> Changing X from 7 to (9) in #. => ((1 1 2 2 7 7 8 8) 9 (9 9 2 2 7 7 8 8) (9) (9 9 2 2 (9) (9) 8 8)) Affected By:: ............. defclass Exceptional Situations:: ........................ The consequences are undefined if any slot-name is not the name of a slot in the instance. See Also:: .......... *note with-accessors:: , *note slot-value:: , *note symbol-macrolet:: Notes:: ....... A with-slots expression of the form: (with-slots (slot-entry_1 ...slot-entry_n) instance-form form_1 ...form_k) expands into the equivalent of (let ((in instance-form)) (symbol-macrolet (Q_1... Q_n) form_1 ...form_k)) where Q_i is (slot-entry_i () (slot-value in 'slot-entry_i)) if slot-entry_i is a symbol and is (variable-name_i () (slot-value in 'slot-name_i)) if slot-entry_i is of the form (variable-name_i slot-name_i)  File: gcl.info, Node: defclass, Next: defgeneric, Prev: with-slots, Up: Objects Dictionary 7.7.25 defclass [Macro] ----------------------- 'defclass' class-name ({superclass-name}*) ({slot-specifier}*) [[!class-option]] => new-class slot-specifier::=slot-name | (slot-name [[!slot-option]]) slot-name::= symbol slot-option::={:reader reader-function-name}* | {:writer writer-function-name}* | {:accessor reader-function-name}* | {:allocation allocation-type} | {:initarg initarg-name}* | {:initform form} | {:type type-specifier} | {:documentation string} function-name::= {symbol | (setf symbol)} class-option::=(:default-initargs . initarg-list) | (:documentation string) | (:metaclass class-name) Arguments and Values:: ...................... Class-name--a non-nil symbol. Superclass-name-a non-nil symbol. Slot-name-a symbol. The slot-name argument is a symbol that is syntactically valid for use as a variable name. Reader-function-name--a non-nil symbol. :reader can be supplied more than once for a given slot. Writer-function-name--a generic function name. :writer can be supplied more than once for a given slot. Reader-function-name--a non-nil symbol. :accessor can be supplied more than once for a given slot. Allocation-type--(member :instance :class). :allocation can be supplied once at most for a given slot. Initarg-name--a symbol. :initarg can be supplied more than once for a given slot. Form--a form. :init-form can be supplied once at most for a given slot. Type-specifier--a type specifier. :type can be supplied once at most for a given slot. Class-option-- refers to the class as a whole or to all class slots. Initarg-list--a list of alternating initialization argument names and default initial value forms. :default-initargs can be supplied at most once. Class-name--a non-nil symbol. :metaclass can be supplied once at most. new-class--the new class object. Description:: ............. The macro defclass defines a new named class. It returns the new class object as its result. The syntax of defclass provides options for specifying initialization arguments for slots, for specifying default initialization values for slots, and for requesting that methods on specified generic functions be automatically generated for reading and writing the values of slots. No reader or writer functions are defined by default; their generation must be explicitly requested. However, slots can always be accessed using slot-value. Defining a new class also causes a type of the same name to be defined. The predicate (typep object class-name) returns true if the class of the given object is the class named by class-name itself or a subclass of the class class-name. A class object can be used as a type specifier. Thus (typep object class) returns true if the class of the object is class itself or a subclass of class. The class-name argument specifies the proper name of the new class. If a class with the same proper name already exists and that class is an instance of standard-class, and if the defclass form for the definition of the new class specifies a class of class standard-class, the existing class is redefined, and instances of it (and its subclasses) are updated to the new definition at the time that they are next accessed. For details, see *note Redefining Classes::. Each superclass-name argument specifies a direct superclass of the new class. If the superclass list is empty, then the superclass defaults depending on the metaclass, with standard-object being the default for standard-class. The new class will inherit slots and methods from each of its direct superclasses, from their direct superclasses, and so on. For a discussion of how slots and methods are inherited, see *note Inheritance::. The following slot options are available: * The :reader slot option specifies that an unqualified method is to be defined on the generic function named reader-function-name to read the value of the given slot. * The :writer slot option specifies that an unqualified method is to be defined on the generic function named writer-function-name to write the value of the slot. * The :accessor slot option specifies that an unqualified method is to be defined on the generic function named reader-function-name to read the value of the given slot and that an unqualified method is to be defined on the generic function named (setf reader-function-name) to be used with setf to modify the value of the slot. * The :allocation slot option is used to specify where storage is to be allocated for the given slot. Storage for a slot can be located in each instance or in the class object itself. The value of the allocation-type argument can be either the keyword :instance or the keyword :class. If the :allocation slot option is not specified, the effect is the same as specifying :allocation :instance. - If allocation-type is :instance, a local slot of the name slot-name is allocated in each instance of the class. - If allocation-type is :class, a shared slot of the given name is allocated in the class object created by this defclass form. The value of the slot is shared by all instances of the class. If a class C_1 defines such a shared slot, any subclass C_2 of C_1 will share this single slot unless the defclass form for C_2 specifies a slot of the same name or there is a superclass of C_2 that precedes C_1 in the class precedence list of C_2 and that defines a slot of the same name. * The :initform slot option is used to provide a default initial value form to be used in the initialization of the slot. This form is evaluated every time it is used to initialize the slot. The lexical environment in which this form is evaluated is the lexical environment in which the defclass form was evaluated. Note that the lexical environment refers both to variables and to functions. For local slots, the dynamic environment is the dynamic environment in which make-instance is called; for shared slots, the dynamic environment is the dynamic environment in which the defclass form was evaluated. See *note Object Creation and Initialization::. No implementation is permitted to extend the syntax of defclass to allow (slot-name form) as an abbreviation for (slot-name :initform form). [Reviewer Note by Barmar: Can you extend this to mean something else?] * The :initarg slot option declares an initialization argument named initarg-name and specifies that this initialization argument initializes the given slot. If the initialization argument has a value in the call to initialize-instance, the value will be stored into the given slot, and the slot's :initform slot option, if any, is not evaluated. If none of the initialization arguments specified for a given slot has a value, the slot is initialized according to the :initform slot option, if specified. * The :type slot option specifies that the contents of the slot will always be of the specified data type. It effectively declares the result type of the reader generic function when applied to an object of this class. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot are undefined. The :type slot option is further discussed in *note Inheritance of Slots and Slot Options::. * The :documentation slot option provides a documentation string for the slot. :documentation can be supplied once at most for a given slot. [Reviewer Note by Barmar: How is this retrieved?] Each class option is an option that refers to the class as a whole. The following class options are available: * The :default-initargs class option is followed by a list of alternating initialization argument names and default initial value forms. If any of these initialization arguments does not appear in the initialization argument list supplied to make-instance, the corresponding default initial value form is evaluated, and the initialization argument name and the form's value are added to the end of the initialization argument list before the instance is created; see *note Object Creation and Initialization::. The default initial value form is evaluated each time it is used. The lexical environment in which this form is evaluated is the lexical environment in which the defclass form was evaluated. The dynamic environment is the dynamic environment in which make-instance was called. If an initialization argument name appears more than once in a :default-initargs class option, an error is signaled. * The :documentation class option causes a documentation string to be attached with the class object, and attached with kind type to the class-name. :documentation can be supplied once at most. * The :metaclass class option is used to specify that instances of the class being defined are to have a different metaclass than the default provided by the system (the class standard-class). Note the following rules of defclass for standard classes: * It is not required that the superclasses of a class be defined before the defclass form for that class is evaluated. * All the superclasses of a class must be defined before an instance of the class can be made. * A class must be defined before it can be used as a parameter specializer in a defmethod form. The object system can be extended to cover situations where these rules are not obeyed. Some slot options are inherited by a class from its superclasses, and some can be shadowed or altered by providing a local slot description. No class options except :default-initargs are inherited. For a detailed description of how slots and slot options are inherited, see *note Inheritance of Slots and Slot Options::. The options to defclass can be extended. It is required that all implementations signal an error if they observe a class option or a slot option that is not implemented locally. It is valid to specify more than one reader, writer, accessor, or initialization argument for a slot. No other slot option can appear more than once in a single slot description, or an error is signaled. If no reader, writer, or accessor is specified for a slot, the slot can only be accessed by the function slot-value. If a defclass form appears as a top level form, the compiler must make the class name be recognized as a valid type name in subsequent declarations (as for deftype) and be recognized as a valid class name for defmethod parameter specializers and for use as the :metaclass option of a subsequent defclass. The compiler must make the class definition available to be returned by find-class when its environment argument is a value received as the environment parameter of a macro. Exceptional Situations:: ........................ If there are any duplicate slot names, an error of type program-error is signaled. If an initialization argument name appears more than once in :default-initargs class option, an error of type program-error is signaled. If any of the following slot options appears more than once in a single slot description, an error of type program-error is signaled: :allocation, :initform, :type, :documentation. It is required that all implementations signal an error of type program-error if they observe a class option or a slot option that is not implemented locally. See Also:: .......... *note documentation:: , *note Initialize-Instance:: , *note make-instance:: , *note slot-value:: , *note Classes::, *note Inheritance::, *note Redefining Classes::, *note Determining the Class Precedence List::, *note Object Creation and Initialization::  File: gcl.info, Node: defgeneric, Next: defmethod, Prev: defclass, Up: Objects Dictionary 7.7.26 defgeneric [Macro] ------------------------- 'defgeneric' function-name gf-lambda-list [[!option | {!method-description}*]] => new-generic option ::=(:argument-precedence-order {parameter-name}^+) | (declare {gf-declaration}^+) | (:documentation gf-documentation) | (:method-combination method-combination {method-combination-argument}*) | (:generic-function-class generic-function-class) | (:method-class method-class) method-description ::=(:method {method-qualifier}* specialized-lambda-list [[{declaration}* | documentation]] {form}*) Arguments and Values:: ...................... function-name--a function name. generic-function-class--a non-nil symbol naming a class. gf-declaration--an optimize declaration specifier; other declaration specifiers are not permitted. gf-documentation--a string; not evaluated. gf-lambda-list--a generic function lambda list. method-class--a non-nil symbol naming a class. method-combination-argument--an object. method-combination-name--a symbol naming a method combination type. method-qualifiers, specialized-lambda-list, declarations, documentation, forms--as per defmethod. new-generic--the generic function object. parameter-name--a symbol that names a required parameter in the lambda-list. (If the :argument-precedence-order option is specified, each required parameter in the lambda-list must be used exactly once as a parameter-name.) Description:: ............. The macro defgeneric is used to define a generic function or to specify options and declarations that pertain to a generic function as a whole. If function-name is a list it must be of the form (setf symbol). If (fboundp function-name) is false, a new generic function is created. If (fdefinition function-name) is a generic function, that generic function is modified. If function-name names an ordinary function, a macro, or a special operator, an error is signaled. The effect of the defgeneric macro is as if the following three steps were performed: first, methods defined by previous defgeneric forms are removed; [Reviewer Note by Barmar: Shouldn't this (second) be first?] second, ensure-generic-function is called; and finally, methods specified by the current defgeneric form are added to the generic function. Each method-description defines a method on the generic function. The lambda list of each method must be congruent with the lambda list specified by the gf-lambda-list option. If no method descriptions are specified and a generic function of the same name does not already exist, a generic function with no methods is created. The gf-lambda-list argument of defgeneric specifies the shape of lambda lists for the methods on this generic function. All methods on the resulting generic function must have lambda lists that are congruent with this shape. If a defgeneric form is evaluated and some methods for that generic function have lambda lists that are not congruent with that given in the defgeneric form, an error is signaled. For further details on method congruence, see *note Congruent Lambda-lists for all Methods of a Generic Function::. The generic function passes to the method all the argument values passed to it, and only those; default values are not supported. Note that optional and keyword arguments in method definitions, however, can have default initial value forms and can use supplied-p parameters. The following options are provided. Except as otherwise noted, a given option may occur only once. * The :argument-precedence-order option is used to specify the order in which the required arguments in a call to the generic function are tested for specificity when selecting a particular method. Each required argument, as specified in the gf-lambda-list argument, must be included exactly once as a parameter-name so that the full and unambiguous precedence order is supplied. If this condition is not met, an error is signaled. [Reviewer Note by Barmar: What is the default order?] * The declare option is used to specify declarations that pertain to the generic function. An optimize declaration specifier is allowed. It specifies whether method selection should be optimized for speed or space, but it has no effect on methods. To control how a method is optimized, an optimize declaration must be placed directly in the defmethod form or method description. The optimization qualities speed and space are the only qualities this standard requires, but an implementation can extend the object system to recognize other qualities. A simple implementation that has only one method selection technique and ignores optimize declaration specifiers is valid. The special, ftype, function, inline, notinline, and declaration declarations are not permitted. Individual implementations can extend the declare option to support additional declarations. [Editorial Note by KMP: Does "additional" mean including special, ftype, etc.? Or only other things that are not mentioned here?] If an implementation notices a declaration specifier that it does not support and that has not been proclaimed as a non-standard declaration identifier name in a declaration proclamation, it should issue a warning. [Editorial Note by KMP: The wording of this previous sentence, particularly the word "and" suggests to me that you can 'proclaim declaration' of an unsupported declaration (e.g., ftype) in order to suppress the warning. That seems wrong. Perhaps it instead means to say "does not support or is both undefined and not proclaimed declaration."] The declare option may be specified more than once. The effect is the same as if the lists of declaration specifiers had been appended together into a single list and specified as a single declare option. * The :documentation argument is a documentation string to be attached to the generic function object, and to be attached with kind function to the function-name. * The :generic-function-class option may be used to specify that the generic function is to have a different class than the default provided by the system (the class standard-generic-function). The class-name argument is the name of a class that can be the class of a generic function. If function-name specifies an existing generic function that has a different value for the :generic-function-class argument and the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error is signaled. * The :method-class option is used to specify that all methods on this generic function are to have a different class from the default provided by the system (the class standard-method). The class-name argument is the name of a class that is capable of being the class of a method. [Reviewer Note by Barmar: Is change-class called on existing methods?] * The :method-combination option is followed by a symbol that names a type of method combination. The arguments (if any) that follow that symbol depend on the type of method combination. Note that the standard method combination type does not support any arguments. However, all types of method combination defined by the short form of define-method-combination accept an optional argument named order, defaulting to :most-specific-first, where a value of :most-specific-last reverses the order of the primary methods without affecting the order of the auxiliary methods. The method-description arguments define methods that will be associated with the generic function. The method-qualifier and specialized-lambda-list arguments in a method description are the same as for defmethod. The form arguments specify the method body. The body of the method is enclosed in an implicit block. If function-name is a symbol, this block bears the same name as the generic function. If function-name is a list of the form (setf symbol), the name of the block is symbol. Implementations can extend defgeneric to include other options. It is required that an implementation signal an error if it observes an option that is not implemented locally. defgeneric is not required to perform any compile-time side effects. In particular, the methods are not installed for invocation during compilation. An implementation may choose to store information about the generic function for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen). Examples:: .......... Exceptional Situations:: ........................ If function-name names an ordinary function, a macro, or a special operator, an error of type program-error is signaled. Each required argument, as specified in the gf-lambda-list argument, must be included exactly once as a parameter-name, or an error of type program-error is signaled. The lambda list of each method specified by a method-description must be congruent with the lambda list specified by the gf-lambda-list option, or an error of type error is signaled. If a defgeneric form is evaluated and some methods for that generic function have lambda lists that are not congruent with that given in the defgeneric form, an error of type error is signaled. A given option may occur only once, or an error of type program-error is signaled. [Reviewer Note by Barmar: This says that an error is signaled if you specify the same generic function class as it already has!] If function-name specifies an existing generic function that has a different value for the :generic-function-class argument and the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error of type error is signaled. Implementations can extend defgeneric to include other options. It is required that an implementation signal an error of type program-error if it observes an option that is not implemented locally. See Also:: .......... *note defmethod:: , *note documentation:: , *note ensure-generic-function:: , generic-function, *note Congruent Lambda-lists for all Methods of a Generic Function::  File: gcl.info, Node: defmethod, Next: find-class, Prev: defgeneric, Up: Objects Dictionary 7.7.27 defmethod [Macro] ------------------------ 'defmethod' function-name {method-qualifier}* specialized-lambda-list [[{declaration}* | documentation]] {form}* => new-method function-name::= {symbol | (setf symbol)} method-qualifier::= non-list specialized-lambda-list::= ({var | (var parameter-specializer-name)}* [&optional {var | (var [initform [supplied-p-parameter] ])}*] [&rest var] [&key{var | ({var | (keywordvar)} [initform [supplied-p-parameter] ])}* [&allow-other-keys] ] [&aux {var | (var [initform] )}*] ) parameter-specializer-name::= symbol | (eql eql-specializer-form) Arguments and Values:: ...................... declaration--a declare expression; not evaluated. documentation--a string; not evaluated. var--a variable name. eql-specializer-form--a form. Form--a form. Initform--a form. Supplied-p-parameter--variable name. new-method--the new method object. Description:: ............. The macro defmethod defines a method on a generic function. If (fboundp function-name) is nil, a generic function is created with default values for the argument precedence order (each argument is more specific than the arguments to its right in the argument list), for the generic function class (the class standard-generic-function), for the method class (the class standard-method), and for the method combination type (the standard method combination type). The lambda list of the generic function is congruent with the lambda list of the method being defined; if the defmethod form mentions keyword arguments, the lambda list of the generic function will mention &key (but no keyword arguments). If function-name names an ordinary function, a macro, or a special operator, an error is signaled. If a generic function is currently named by function-name, the lambda list of the method must be congruent with the lambda list of the generic function. If this condition does not hold, an error is signaled. For a definition of congruence in this context, see *note Congruent Lambda-lists for all Methods of a Generic Function::. Each method-qualifier argument is an object that is used by method combination to identify the given method. The method combination type might further restrict what a method qualifier can be. The standard method combination type allows for unqualified methods and methods whose sole qualifier is one of the keywords :before, :after, or :around. The specialized-lambda-list argument is like an ordinary lambda list except that the names of required parameters can be replaced by specialized parameters. A specialized parameter is a list of the form (var parameter-specializer-name). Only required parameters can be specialized. If parameter-specializer-name is a symbol it names a class; if it is a list, it is of the form (eql eql-specializer-form). The parameter specializer name (eql eql-specializer-form) indicates that the corresponding argument must be eql to the object that is the value of eql-specializer-form for the method to be applicable. The eql-specializer-form is evaluated at the time that the expansion of the defmethod macro is evaluated. If no parameter specializer name is specified for a given required parameter, the parameter specializer defaults to the class t. For further discussion, see *note Introduction to Methods::. The form arguments specify the method body. The body of the method is enclosed in an implicit block. If function-name is a symbol, this block bears the same name as the generic function. If function-name is a list of the form (setf symbol), the name of the block is symbol. The class of the method object that is created is that given by the method class option of the generic function on which the method is defined. If the generic function already has a method that agrees with the method being defined on parameter specializers and qualifiers, defmethod replaces the existing method with the one now being defined. For a definition of agreement in this context. see *note Agreement on Parameter Specializers and Qualifiers::. The parameter specializers are derived from the parameter specializer names as described in *note Introduction to Methods::. The expansion of the defmethod macro "refers to" each specialized parameter (see the description of ignore within the description of declare). This includes parameters that have an explicit parameter specializer name of t. This means that a compiler warning does not occur if the body of the method does not refer to a specialized parameter, while a warning might occur if the body of the method does not refer to an unspecialized parameter. For this reason, a parameter that specializes on t is not quite synonymous with an unspecialized parameter in this context. Declarations at the head of the method body that apply to the method's lambda variables are treated as bound declarations whose scope is the same as the corresponding bindings. Declarations at the head of the method body that apply to the functional bindings of call-next-method or next-method-p apply to references to those functions within the method body forms. Any outer bindings of the function names call-next-method and next-method-p, and declarations associated with such bindings are shadowed_2 within the method body forms. The scope of free declarations at the head of the method body is the entire method body, which includes any implicit local function definitions but excludes initialization forms for the lambda variables. defmethod is not required to perform any compile-time side effects. In particular, the methods are not installed for invocation during compilation. An implementation may choose to store information about the generic function for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen). Documentation is attached as a documentation string to the method object. Affected By:: ............. The definition of the referenced generic function. Exceptional Situations:: ........................ If function-name names an ordinary function, a macro, or a special operator, an error of type error is signaled. If a generic function is currently named by function-name, the lambda list of the method must be congruent with the lambda list of the generic function, or an error of type error is signaled. See Also:: .......... *note defgeneric:: , *note documentation:: , *note Introduction to Methods::, *note Congruent Lambda-lists for all Methods of a Generic Function::, *note Agreement on Parameter Specializers and Qualifiers::, *note Syntactic Interaction of Documentation Strings and Declarations::  File: gcl.info, Node: find-class, Next: next-method-p, Prev: defmethod, Up: Objects Dictionary 7.7.28 find-class [Accessor] ---------------------------- 'find-class' symbol &optional errorp environment => class (setf (' find-class' symbol &optional errorp environment) new-class) Arguments and Values:: ...................... symbol--a symbol. errorp--a generalized boolean. The default is true. environment - same as the &environment argument to macro expansion functions and is used to distinguish between compile-time and run-time environments. The &environment argument has dynamic extent; the consequences are undefined if the &environment argument is referred to outside the dynamic extent of the macro expansion function. class--a class object, or nil. Description:: ............. Returns the class object named by the symbol in the environment. If there is no such class, nil is returned if errorp is false; otherwise, if errorp is true, an error is signaled. The class associated with a particular symbol can be changed by using setf with find-class; or, if the new class given to setf is nil, the class association is removed (but the class object itself is not affected). The results are undefined if the user attempts to change or remove the class associated with a symbol that is defined as a type specifier in this standard. See *note Integrating Types and Classes::. When using setf of find-class, any errorp argument is evaluated for effect, but any values it returns are ignored; the errorp parameter is permitted primarily so that the environment parameter can be used. The environment might be used to distinguish between a compile-time and a run-time environment. Exceptional Situations:: ........................ If there is no such class and errorp is true, find-class signals an error of type error. See Also:: .......... *note defmacro:: , *note Integrating Types and Classes::  File: gcl.info, Node: next-method-p, Next: call-method, Prev: find-class, Up: Objects Dictionary 7.7.29 next-method-p [Local Function] ------------------------------------- Syntax:: ........ 'next-method-p' => generalized-boolean Arguments and Values:: ...................... generalized-boolean--a generalized boolean. Description:: ............. The locally defined function next-method-p can be used within the body forms (but not the lambda list) defined by a method-defining form to determine whether a next method exists. The function next-method-p has lexical scope and indefinite extent. Whether or not next-method-p is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of next-method-p are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use next-method-p outside of a method-defining form are undefined. See Also:: .......... *note call-next-method:: , *note defmethod:: , *note call-method::  File: gcl.info, Node: call-method, Next: call-next-method, Prev: next-method-p, Up: Objects Dictionary 7.7.30 call-method, make-method [Local Macro] --------------------------------------------- Syntax:: ........ 'call-method' method &optional next-method-list => {result}* 'make-method' form => method-object Arguments and Values:: ...................... method--a method object, or a list (see below); not evaluated. method-object--a method object. next-method-list--a list of method objects; not evaluated. results--the values returned by the method invocation. Description:: ............. The macro call-method is used in method combination. It hides the implementation-dependent details of how methods are called. The macro call-method has lexical scope and can only be used within an effective method form. [Editorial Note by KMP: This next paragraph still needs some work.] Whether or not call-method is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of call-method are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use call-method outside of an effective method form are undefined. The macro call-method invokes the specified method, supplying it with arguments and with definitions for call-next-method and for next-method-p. If the invocation of call-method is lexically inside of a make-method, the arguments are those that were supplied to that method. Otherwise the arguments are those that were supplied to the generic function. The definitions of call-next-method and next-method-p rely on the specified next-method-list. If method is a list, the first element of the list must be the symbol make-method and the second element must be a form. Such a list specifies a method object whose method function has a body that is the given form. Next-method-list can contain method objects or lists, the first element of which must be the symbol make-method and the second element of which must be a form. Those are the only two places where make-method can be used. The form used with make-method is evaluated in the null lexical environment augmented with a local macro definition for call-method and with bindings named by symbols not accessible from the COMMON-LISP-USER package. The call-next-method function available to method will call the first method in next-method-list. The call-next-method function available in that method, in turn, will call the second method in next-method-list, and so on, until the list of next methods is exhausted. If next-method-list is not supplied, the call-next-method function available to method signals an error of type control-error and the next-method-p function available to method returns nil. Examples:: .......... See Also:: .......... *note call-next-method:: , *note define-method-combination:: , *note next-method-p::  File: gcl.info, Node: call-next-method, Next: compute-applicable-methods, Prev: call-method, Up: Objects Dictionary 7.7.31 call-next-method [Local Function] ---------------------------------------- Syntax:: ........ 'call-next-method' &rest args => {result}* Arguments and Values:: ...................... arg--an object. results--the values returned by the method it calls. Description:: ............. The function call-next-method can be used within the body forms (but not the lambda list) of a method defined by a method-defining form to call the next method. If there is no next method, the generic function no-next-method is called. The type of method combination used determines which methods can invoke call-next-method. The standard method combination type allows call-next-method to be used within primary methods and around methods. For generic functions using a type of method combination defined by the short form of define-method-combination, call-next-method can be used in around methods only. When call-next-method is called with no arguments, it passes the current method's original arguments to the next method. Neither argument defaulting, nor using setq, nor rebinding variables with the same names as parameters of the method affects the values call-next-method passes to the method it calls. When call-next-method is called with arguments, the next method is called with those arguments. If call-next-method is called with arguments but omits optional arguments, the next method called defaults those arguments. The function call-next-method returns any values that are returned by the next method. The function call-next-method has lexical scope and indefinite extent and can only be used within the body of a method defined by a method-defining form. Whether or not call-next-method is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of call-next-method are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use call-next-method outside of a method-defining form are undefined. Affected By:: ............. defmethod, call-method, define-method-combination. Exceptional Situations:: ........................ When providing arguments to call-next-method, the following rule must be satisfied or an error of type error should be signaled: the ordered set of applicable methods for a changed set of arguments for call-next-method must be the same as the ordered set of applicable methods for the original arguments to the generic function. Optimizations of the error checking are possible, but they must not change the semantics of call-next-method. See Also:: .......... *note define-method-combination:: , *note defmethod:: , *note next-method-p:: , *note no-next-method:: , *note call-method:: , *note Method Selection and Combination::, *note Standard Method Combination::, *note Built-in Method Combination Types::  File: gcl.info, Node: compute-applicable-methods, Next: define-method-combination, Prev: call-next-method, Up: Objects Dictionary 7.7.32 compute-applicable-methods [Standard Generic Function] ------------------------------------------------------------- Syntax:: ........ 'compute-applicable-methods' generic-function function-arguments => methods Method Signatures:: ................... 'compute-applicable-methods' (generic-function standard-generic-function) Arguments and Values:: ...................... generic-function--a generic function. function-arguments--a list of arguments for the generic-function. methods--a list of method objects. Description:: ............. Given a generic-function and a set of function-arguments, the function compute-applicable-methods returns the set of methods that are applicable for those arguments sorted according to precedence order. See *note Method Selection and Combination::. Affected By:: ............. defmethod See Also:: .......... *note Method Selection and Combination::  File: gcl.info, Node: define-method-combination, Next: find-method, Prev: compute-applicable-methods, Up: Objects Dictionary 7.7.33 define-method-combination [Macro] ---------------------------------------- 'define-method-combination' name [[!short-form-option]] => name 'define-method-combination' name lambda-list ({method-group-specifier}*) [(:arguments . args-lambda-list)] [(:generic-function generic-function-symbol)] [[{declaration}* | documentation]] {form}* => name short-form-option ::=:documentation documentation | :identity-with-one-argument identity-with-one-argument | :operator operator method-group-specifier ::=(name {{qualifier-pattern}^+ | predicate} [[!long-form-option]]) long-form-option ::=:description description | :order order | :required required-p Arguments and Values:: ...................... args-lambda-list-- a define-method-combination arguments lambda list. declaration--a declare expression; not evaluated. description--a format control. documentation--a string; not evaluated. forms--an implicit progn that must compute and return the form that specifies how the methods are combined, that is, the effective method. generic-function-symbol--a symbol. identity-with-one-argument--a generalized boolean. lambda-list--ordinary lambda list. name--a symbol. Non-keyword, non-nil symbols are usually used. operator--an operator. Name and operator are often the same symbol. This is the default, but it is not required. order--:most-specific-first or :most-specific-last; evaluated. predicate--a symbol that names a function of one argument that returns a generalized boolean. qualifier-pattern--a list, or the symbol *. required-p--a generalized boolean. Description:: ............. The macro define-method-combination is used to define new types of method combination. There are two forms of define-method-combination. The short form is a simple facility for the cases that are expected to be most commonly needed. The long form is more powerful but more verbose. It resembles defmacro in that the body is an expression, usually using backquote, that computes a form. Thus arbitrary control structures can be implemented. The long form also allows arbitrary processing of method qualifiers. Short Form The short form syntax of define-method-combination is recognized when the second subform is a non-nil symbol or is not present. When the short form is used, name is defined as a type of method combination that produces a Lisp form (operator method-call method-call ...). The operator is a symbol that can be the name of a function, macro, or special operator. The operator can be supplied by a keyword option; it defaults to name. Keyword options for the short form are the following: * The :documentation option is used to document the method-combination type; see description of long form below. * The :identity-with-one-argument option enables an optimization when its value is true (the default is false). If there is exactly one applicable method and it is a primary method, that method serves as the effective method and operator is not called. This optimization avoids the need to create a new effective method and avoids the overhead of a function call. This option is designed to be used with operators such as progn, and, +, and max. * The :operator option specifies the name of the operator. The operator argument is a symbol that can be the name of a function, macro, or special form. These types of method combination require exactly one qualifier per method. An error is signaled if there are applicable methods with no qualifiers or with qualifiers that are not supported by the method combination type. A method combination procedure defined in this way recognizes two roles for methods. A method whose one qualifier is the symbol naming this type of method combination is defined to be a primary method. At least one primary method must be applicable or an error is signaled. A method with :around as its one qualifier is an auxiliary method that behaves the same as an around method in standard method combination. The function call-next-method can only be used in around methods; it cannot be used in primary methods defined by the short form of the define-method-combination macro. A method combination procedure defined in this way accepts an optional argument named order, which defaults to :most-specific-first. A value of :most-specific-last reverses the order of the primary methods without affecting the order of the auxiliary methods. The short form automatically includes error checking and support for around methods. For a discussion of built-in method combination types, see *note Built-in Method Combination Types::. Long Form The long form syntax of define-method-combination is recognized when the second subform is a list. The lambda-list receives any arguments provided after the name of the method combination type in the :method-combination option to defgeneric. A list of method group specifiers follows. Each specifier selects a subset of the applicable methods to play a particular role, either by matching their qualifiers against some patterns or by testing their qualifiers with a predicate. These method group specifiers define all method qualifiers that can be used with this type of method combination. The car of each method-group-specifier is a symbol which names a variable. During the execution of the forms in the body of define-method-combination, this variable is bound to a list of the methods in the method group. The methods in this list occur in the order specified by the :order option. If qualifier-pattern is a symbol it must be *. A method matches a qualifier-pattern if the method's list of qualifiers is equal to the qualifier-pattern (except that the symbol * in a qualifier-pattern matches anything). Thus a qualifier-pattern can be one of the following: the empty list, which matches unqualified methods; the symbol *, which matches all methods; a true list, which matches methods with the same number of qualifiers as the length of the list when each qualifier matches the corresponding list element; or a dotted list that ends in the symbol * (the * matches any number of additional qualifiers). Each applicable method is tested against the qualifier-patterns and predicates in left-to-right order. As soon as a qualifier-pattern matches or a predicate returns true, the method becomes a member of the corresponding method group and no further tests are made. Thus if a method could be a member of more than one method group, it joins only the first such group. If a method group has more than one qualifier-pattern, a method need only satisfy one of the qualifier-patterns to be a member of the group. The name of a predicate function can appear instead of qualifier-patterns in a method group specifier. The predicate is called for each method that has not been assigned to an earlier method group; it is called with one argument, the method's qualifier list. The predicate should return true if the method is to be a member of the method group. A predicate can be distinguished from a qualifier-pattern because it is a symbol other than nil or *. If there is an applicable method that does not fall into any method group, the function invalid-method-error is called. Method group specifiers can have keyword options following the qualifier patterns or predicate. Keyword options can be distinguished from additional qualifier patterns because they are neither lists nor the symbol *. The keyword options are as follows: * The :description option is used to provide a description of the role of methods in the method group. Programming environment tools use (apply #'format stream format-control (method-qualifiers method)) to print this description, which is expected to be concise. This keyword option allows the description of a method qualifier to be defined in the same module that defines the meaning of the method qualifier. In most cases, format-control will not contain any format directives, but they are available for generality. If :description is not supplied, a default description is generated based on the variable name and the qualifier patterns and on whether this method group includes the unqualified methods. * The :order option specifies the order of methods. The order argument is a form that evaluates to :most-specific-first or :most-specific-last. If it evaluates to any other value, an error is signaled. If :order is not supplied, it defaults to :most-specific-first. * The :required option specifies whether at least one method in this method group is required. If its value is true and the method group is empty (that is, no applicable methods match the qualifier patterns or satisfy the predicate), an error is signaled. If :required is not supplied, it defaults to nil. The use of method group specifiers provides a convenient syntax to select methods, to divide them among the possible roles, and to perform the necessary error checking. It is possible to perform further filtering of methods in the body forms by using normal list-processing operations and the functions method-qualifiers and invalid-method-error. It is permissible to use setq on the variables named in the method group specifiers and to bind additional variables. It is also possible to bypass the method group specifier mechanism and do everything in the body forms. This is accomplished by writing a single method group with * as its only qualifier-pattern; the variable is then bound to a list of all of the applicable methods, in most-specific-first order. The body forms compute and return the form that specifies how the methods are combined, that is, the effective method. The effective method is evaluated in the null lexical environment augmented with a local macro definition for call-method and with bindings named by symbols not accessible from the COMMON-LISP-USER package. Given a method object in one of the lists produced by the method group specifiers and a list of next methods, call-method will invoke the method such that call-next-method has available the next methods. When an effective method has no effect other than to call a single method, some implementations employ an optimization that uses the single method directly as the effective method, thus avoiding the need to create a new effective method. This optimization is active when the effective method form consists entirely of an invocation of the call-method macro whose first subform is a method object and whose second subform is nil or unsupplied. Each define-method-combination body is responsible for stripping off redundant invocations of progn, and, multiple-value-prog1, and the like, if this optimization is desired. The list (:arguments . lambda-list) can appear before any declarations or documentation string. This form is useful when the method combination type performs some specific behavior as part of the combined method and that behavior needs access to the arguments to the generic function. Each parameter variable defined by lambda-list is bound to a form that can be inserted into the effective method. When this form is evaluated during execution of the effective method, its value is the corresponding argument to the generic function; the consequences of using such a form as the place in a setf form are undefined. Argument correspondence is computed by dividing the :arguments lambda-list and the generic function lambda-list into three sections: the required parameters, the optional parameters, and the keyword and rest parameters. The arguments supplied to the generic function for a particular call are also divided into three sections; the required arguments section contains as many arguments as the generic function has required parameters, the optional arguments section contains as many arguments as the generic function has optional parameters, and the keyword/rest arguments section contains the remaining arguments. Each parameter in the required and optional sections of the :arguments lambda-list accesses the argument at the same position in the corresponding section of the arguments. If the section of the :arguments lambda-list is shorter, extra arguments are ignored. If the section of the :arguments lambda-list is longer, excess required parameters are bound to forms that evaluate to nil and excess optional parameters are bound to their initforms. The keyword parameters and rest parameters in the :arguments lambda-list access the keyword/rest section of the arguments. If the :arguments lambda-list contains &key, it behaves as if it also contained &allow-other-keys. In addition, &whole var can be placed first in the :arguments lambda-list. It causes var to be bound to a form that evaluates to a list of all of the arguments supplied to the generic function. This is different from &rest because it accesses all of the arguments, not just the keyword/rest arguments. Erroneous conditions detected by the body should be reported with method-combination-error or invalid-method-error; these functions add any necessary contextual information to the error message and will signal the appropriate error. The body forms are evaluated inside of the bindings created by the lambda list and method group specifiers. [Reviewer Note by Barmar: Are they inside or outside the :ARGUMENTS bindings?] Declarations at the head of the body are positioned directly inside of bindings created by the lambda list and outside of the bindings of the method group variables. Thus method group variables cannot be declared in this way. locally may be used around the body, however. Within the body forms, generic-function-symbol is bound to the generic function object. Documentation is attached as a documentation string to name (as kind method-combination) and to the method combination object. Note that two methods with identical specializers, but with different qualifiers, are not ordered by the algorithm described in Step 2 of the method selection and combination process described in *note Method Selection and Combination::. Normally the two methods play different roles in the effective method because they have different qualifiers, and no matter how they are ordered in the result of Step 2, the effective method is the same. If the two methods play the same role and their order matters, [Reviewer Note by Barmar: How does the system know when the order matters?] an error is signaled. This happens as part of the qualifier pattern matching in define-method-combination. If a define-method-combination form appears as a top level form, the compiler must make the method combination name be recognized as a valid method combination name in subsequent defgeneric forms. However, the method combination is executed no earlier than when the define-method-combination form is executed, and possibly as late as the time that generic functions that use the method combination are executed. Examples:: .......... Most examples of the long form of define-method-combination also illustrate the use of the related functions that are provided as part of the declarative method combination facility. ;;; Examples of the short form of define-method-combination (define-method-combination and :identity-with-one-argument t) (defmethod func and ((x class1) y) ...) ;;; The equivalent of this example in the long form is: (define-method-combination and (&optional (order :most-specific-first)) ((around (:around)) (primary (and) :order order :required t)) (let ((form (if (rest primary) `(and ,@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))) ;;; Examples of the long form of define-method-combination ;The default method-combination technique (define-method-combination standard () ((around (:around)) (before (:before)) (primary () :required t) (after (:after))) (flet ((call-methods (methods) (mapcar #'(lambda (method) `(call-method ,method)) methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@(call-methods before) (call-method ,(first primary) ,(rest primary))) ,@(call-methods (reverse after))) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))) ;A simple way to try several methods until one returns non-nil (define-method-combination or () ((methods (or))) `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) methods))) ;A more complete version of the preceding (define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or))) ;; Process the order argument (case order (:most-specific-first) (:most-specific-last (setq primary (reverse primary))) (otherwise (method-combination-error "~S is an invalid order.~@ :most-specific-first and :most-specific-last are the possible values." order))) ;; Must have a primary method (unless primary (method-combination-error "A primary method is required.")) ;; Construct the form that calls the primary methods (let ((form (if (rest primary) `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) ;; Wrap the around methods around that form (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))) ;The same thing, using the :order and :required keyword options (define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or) :order order :required t)) (let ((form (if (rest primary) `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary)) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))) ;This short-form call is behaviorally identical to the preceding (define-method-combination or :identity-with-one-argument t) ;Order methods by positive integer qualifiers ;:around methods are disallowed to keep the example small (define-method-combination example-method-combination () ((methods positive-integer-qualifier-p)) `(progn ,@(mapcar #'(lambda (method) `(call-method ,method)) (stable-sort methods #'< :key #'(lambda (method) (first (method-qualifiers method))))))) (defun positive-integer-qualifier-p (method-qualifiers) (and (= (length method-qualifiers) 1) (typep (first method-qualifiers) '(integer 0 *)))) ;;; Example of the use of :arguments (define-method-combination progn-with-lock () ((methods ())) (:arguments object) `(unwind-protect (progn (lock (object-lock ,object)) ,@(mapcar #'(lambda (method) `(call-method ,method)) methods)) (unlock (object-lock ,object)))) Side Effects:: .............. The compiler is not required to perform any compile-time side-effects. Exceptional Situations:: ........................ Method combination types defined with the short form require exactly one qualifier per method. An error of type error is signaled if there are applicable methods with no qualifiers or with qualifiers that are not supported by the method combination type. At least one primary method must be applicable or an error of type error is signaled. If an applicable method does not fall into any method group, the system signals an error of type error indicating that the method is invalid for the kind of method combination in use. If the value of the :required option is true and the method group is empty (that is, no applicable methods match the qualifier patterns or satisfy the predicate), an error of type error is signaled. If the :order option evaluates to a value other than :most-specific-first or :most-specific-last, an error of type error is signaled. See Also:: .......... *note call-method:: , *note call-next-method:: , *note documentation:: , *note method-qualifiers:: , *note method-combination-error:: , *note invalid-method-error:: , *note defgeneric:: , *note Method Selection and Combination::, *note Built-in Method Combination Types::, *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... The :method-combination option of defgeneric is used to specify that a generic function should use a particular method combination type. The first argument to the :method-combination option is the name of a method combination type and the remaining arguments are options for that type.  File: gcl.info, Node: find-method, Next: add-method, Prev: define-method-combination, Up: Objects Dictionary 7.7.34 find-method [Standard Generic Function] ---------------------------------------------- Syntax:: ........ 'find-method' generic-function method-qualifiers specializers &optional errorp => method Method Signatures:: ................... 'find-method' (generic-function standard-generic-function) method-qualifiers specializers &optional errorp Arguments and Values:: ...................... generic-function--a generic function. method-qualifiers--a list. specializers--a list. errorp--a generalized boolean. The default is true. method--a method object, or nil. Description:: ............. The generic function find-method takes a generic function and returns the method object that agrees on qualifiers and parameter specializers with the method-qualifiers and specializers arguments of find-method. Method-qualifiers contains the method qualifiers for the method. The order of the method qualifiers is significant. For a definition of agreement in this context, see *note Agreement on Parameter Specializers and Qualifiers::. The specializers argument contains the parameter specializers for the method. It must correspond in length to the number of required arguments of the generic function, or an error is signaled. This means that to obtain the default method on a given generic-function, a list whose elements are the class t must be given. If there is no such method and errorp is true, find-method signals an error. If there is no such method and errorp is false, find-method returns nil. Examples:: .......... (defmethod some-operation ((a integer) (b float)) (list a b)) => # (find-method #'some-operation '() (mapcar #'find-class '(integer float))) => # (find-method #'some-operation '() (mapcar #'find-class '(integer integer))) |> Error: No matching method (find-method #'some-operation '() (mapcar #'find-class '(integer integer)) nil) => NIL Affected By:: ............. add-method, defclass, defgeneric, defmethod Exceptional Situations:: ........................ If the specializers argument does not correspond in length to the number of required arguments of the generic-function, an an error of type error is signaled. If there is no such method and errorp is true, find-method signals an error of type error. See Also:: .......... *note Agreement on Parameter Specializers and Qualifiers::  File: gcl.info, Node: add-method, Next: initialize-instance, Prev: find-method, Up: Objects Dictionary 7.7.35 add-method [Standard Generic Function] --------------------------------------------- Syntax:: ........ 'add-method' generic-function method => generic-function Method Signatures:: ................... 'add-method' (generic-function standard-generic-function) (method method) Arguments and Values:: ...................... generic-function--a generic function object. method--a method object. Description:: ............. The generic function add-method adds a method to a generic function. If method agrees with an existing method of generic-function on parameter specializers and qualifiers, the existing method is replaced. Exceptional Situations:: ........................ The lambda list of the method function of method must be congruent with the lambda list of generic-function, or an error of type error is signaled. If method is a method object of another generic function, an error of type error is signaled. See Also:: .......... *note defmethod:: , *note defgeneric:: , *note find-method:: , *note remove-method:: , *note Agreement on Parameter Specializers and Qualifiers::  File: gcl.info, Node: initialize-instance, Next: class-name, Prev: add-method, Up: Objects Dictionary 7.7.36 initialize-instance [Standard Generic Function] ------------------------------------------------------ Syntax:: ........ 'initialize-instance' instance &rest initargs &key &allow-other-keys => instance Method Signatures:: ................... 'initialize-instance' (instance standard-object) &rest initargs Arguments and Values:: ...................... instance--an object. initargs--a defaulted initialization argument list. Description:: ............. Called by make-instance to initialize a newly created instance. The generic function is called with the new instance and the defaulted initialization argument list. The system-supplied primary method on initialize-instance initializes the slots of the instance with values according to the initargs and the :initform forms of the slots. It does this by calling the generic function shared-initialize with the following arguments: the instance, t (this indicates that all slots for which no initialization arguments are provided should be initialized according to their :initform forms), and the initargs. Programmers can define methods for initialize-instance to specify actions to be taken when an instance is initialized. If only after methods are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of initialize-instance. See Also:: .......... *note Shared-Initialize:: , *note make-instance:: , *note slot-boundp:: , *note slot-makunbound:: , *note Object Creation and Initialization::, *note Rules for Initialization Arguments::, *note Declaring the Validity of Initialization Arguments::  File: gcl.info, Node: class-name, Next: setf class-name, Prev: initialize-instance, Up: Objects Dictionary 7.7.37 class-name [Standard Generic Function] --------------------------------------------- Syntax:: ........ 'class-name' class => name Method Signatures:: ................... 'class-name' (class class) Arguments and Values:: ...................... class--a class object. name--a symbol. Description:: ............. Returns the name of the given class. See Also:: .......... *note find-class:: , *note Classes:: Notes:: ....... If S is a symbol such that S =(class-name C) and C =(find-class S), then S is the proper name of C. For further discussion, see *note Classes::. The name of an anonymous class is nil.  File: gcl.info, Node: setf class-name, Next: class-of, Prev: class-name, Up: Objects Dictionary 7.7.38 setf class-name [Standard Generic Function] -------------------------------------------------- Syntax:: ........ 'setf class-name' new-value class => new-value Method Signatures:: ................... 'setf class-name' new-value (class class) Arguments and Values:: ...................... new-value--a symbol. class--a class. Description:: ............. The generic function setf class-name sets the name of a class object. See Also:: .......... *note find-class:: , proper name, *note Classes::  File: gcl.info, Node: class-of, Next: unbound-slot, Prev: setf class-name, Up: Objects Dictionary 7.7.39 class-of [Function] -------------------------- 'class-of' object => class Arguments and Values:: ...................... object--an object. class--a class object. Description:: ............. Returns the class of which the object is a direct instance. Examples:: .......... (class-of 'fred) => # (class-of 2/3) => # (defclass book () ()) => # (class-of (make-instance 'book)) => # (defclass novel (book) ()) => # (class-of (make-instance 'novel)) => # (defstruct kons kar kdr) => KONS (class-of (make-kons :kar 3 :kdr 4)) => # See Also:: .......... *note make-instance:: , *note type-of::  File: gcl.info, Node: unbound-slot, Next: unbound-slot-instance, Prev: class-of, Up: Objects Dictionary 7.7.40 unbound-slot [Condition Type] ------------------------------------ Class Precedence List:: ....................... unbound-slot, cell-error, error, serious-condition, condition, t Description:: ............. The object having the unbound slot is initialized by the :instance initialization argument to make-condition, and is accessed by the function unbound-slot-instance. The name of the cell (see cell-error) is the name of the slot. See Also:: .......... *note cell-error-name:: , unbound-slot-object, *note Condition System Concepts::  File: gcl.info, Node: unbound-slot-instance, Prev: unbound-slot, Up: Objects Dictionary 7.7.41 unbound-slot-instance [Function] --------------------------------------- 'unbound-slot-instance' condition => instance Arguments and Values:: ...................... condition--a condition of type unbound-slot. instance--an object. Description:: ............. Returns the instance which had the unbound slot in the situation represented by the condition. See Also:: .......... *note cell-error-name:: , unbound-slot, *note Condition System Concepts::  File: gcl.info, Node: Structures, Next: Conditions, Prev: Objects, Up: Top 8 Structures ************ * Menu: * Structures Dictionary::  File: gcl.info, Node: Structures Dictionary, Prev: Structures, Up: Structures 8.1 Structures Dictionary ========================= * Menu: * defstruct:: * copy-structure::  File: gcl.info, Node: defstruct, Next: copy-structure, Prev: Structures Dictionary, Up: Structures Dictionary 8.1.1 defstruct [Macro] ----------------------- 'defstruct' name-and-options [documentation] {!slot-description}* => structure-name name-and-options ::=structure-name | (structure-name [[!options]]) options ::=!conc-name-option | {!constructor-option}* | !copier-option | !include-option | !initial-offset-option | !named-option | !predicate-option | !printer-option | !type-option conc-name-option ::=:conc-name | (:conc-name) | (:conc-name conc-name) constructor-option ::=:constructor | (:constructor) | (:constructor constructor-name) | (:constructor constructor-name constructor-arglist) copier-option ::=:copier | (:copier) | (:copier copier-name) predicate-option ::=:predicate | (:predicate) | (:predicate predicate-name) include-option ::=(:include included-structure-name {!slot-description}*) printer-option ::=!print-object-option | !print-function-option print-object-option ::=(:print-object printer-name) | (:print-object) print-function-option ::=(:print-function printer-name) | (:print-function) type-option ::=(:type type) named-option ::=:named initial-offset-option ::=(:initial-offset initial-offset) slot-description ::=slot-name | (slot-name [slot-initform [[!slot-option]]]) slot-option ::=:type slot-type | :read-only slot-read-only-p Arguments and Values:: ...................... conc-name--a string designator. constructor-arglist--a boa lambda list. constructor-name--a symbol. copier-name--a symbol. included-structure-name--an already-defined structure name. Note that a derived type is not permissible, even if it would expand into a structure name. initial-offset--a non-negative integer. predicate-name--a symbol. printer-name--a function name or a lambda expression. slot-name--a symbol. slot-initform--a form. slot-read-only-p--a generalized boolean. structure-name--a symbol. type--one of the type specifiers list, vector, or (vector size), or some other type specifier defined by the implementation to be appropriate. documentation--a string; not evaluated. Description:: ............. defstruct defines a structured type, named structure-type, with named slots as specified by the slot-options. defstruct defines readers for the slots and arranges for setf to work properly on such reader functions. Also, unless overridden, it defines a predicate named name-p, defines a constructor function named make-constructor-name, and defines a copier function named copy-constructor-name. All names of automatically created functions might automatically be declared inline (at the discretion of the implementation). If documentation is supplied, it is attached to structure-name as a documentation string of kind structure, and unless :type is used, the documentation is also attached to structure-name as a documentation string of kind type and as a documentation string to the class object for the class named structure-name. defstruct defines a constructor function that is used to create instances of the structure created by defstruct. The default name is make-structure-name. A different name can be supplied by giving the name as the argument to the constructor option. nil indicates that no constructor function will be created. After a new structure type has been defined, instances of that type normally can be created by using the constructor function for the type. A call to a constructor function is of the following form: (constructor-function-name slot-keyword-1 form-1 slot-keyword-2 form-2 ...) The arguments to the constructor function are all keyword arguments. Each slot keyword argument must be a keyword whose name corresponds to the name of a structure slot. All the keywords and forms are evaluated. If a slot is not initialized in this way, it is initialized by evaluating slot-initform in the slot description at the time the constructor function is called. If no slot-initform is supplied, the consequences are undefined if an attempt is later made to read the slot's value before a value is explicitly assigned. Each slot-initform supplied for a defstruct component, when used by the constructor function for an otherwise unsupplied component, is re-evaluated on every call to the constructor function. The slot-initform is not evaluated unless it is needed in the creation of a particular structure instance. If it is never needed, there can be no type-mismatch error, even if the type of the slot is specified; no warning should be issued in this case. For example, in the following sequence, only the last call is an error. (defstruct person (name 007 :type string)) (make-person :name "James") (make-person) It is as if the slot-initforms were used as initialization forms for the keyword parameters of the constructor function. The symbols which name the slots must not be used by the implementation as the names for the lambda variables in the constructor function, since one or more of those symbols might have been proclaimed special or might be defined as the name of a constant variable. The slot default init forms are evaluated in the lexical environment in which the defstruct form itself appears and in the dynamic environment in which the call to the constructor function appears. For example, if the form (gensym) were used as an initialization form, either in the constructor-function call or as the default initialization form in defstruct, then every call to the constructor function would call gensym once to generate a new symbol. Each slot-description in defstruct can specify zero or more slot-options. A slot-option consists of a pair of a keyword and a value (which is not a form to be evaluated, but the value itself). For example: (defstruct ship (x-position 0.0 :type short-float) (y-position 0.0 :type short-float) (x-velocity 0.0 :type short-float) (y-velocity 0.0 :type short-float) (mass *default-ship-mass* :type short-float :read-only t)) This specifies that each slot always contains a short float, and that the last slot cannot be altered once a ship is constructed. The available slot-options are: :type type This specifies that the contents of the slot is always of type type. This is entirely analogous to the declaration of a variable or function; it effectively declares the result type of the reader function. It is implementation-dependent whether the type is checked when initializing a slot or when assigning to it. Type is not evaluated; it must be a valid type specifier. :read-only x When x is true, this specifies that this slot cannot be altered; it will always contain the value supplied at construction time. setf will not accept the reader function for this slot. If x is false, this slot-option has no effect. X is not evaluated. When this option is false or unsupplied, it is implementation-dependent whether the ability to write the slot is implemented by a setf function or a setf expander. The following keyword options are available for use with defstruct. A defstruct option can be either a keyword or a list of a keyword and arguments for that keyword; specifying the keyword by itself is equivalent to specifying a list consisting of the keyword and no arguments. The syntax for defstruct options differs from the pair syntax used for slot-options. No part of any of these options is evaluated. :conc-name This provides for automatic prefixing of names of reader (or access) functions. The default behavior is to begin the names of all the reader functions of a structure with the name of the structure followed by a hyphen. :conc-name supplies an alternate prefix to be used. If a hyphen is to be used as a separator, it must be supplied as part of the prefix. If :conc-name is nil or no argument is supplied, then no prefix is used; then the names of the reader functions are the same as the slot names. If a non-nil prefix is given, the name of the reader function for each slot is constructed by concatenating that prefix and the name of the slot, and interning the resulting symbol in the package that is current at the time the defstruct form is expanded. Note that no matter what is supplied for :conc-name, slot keywords that match the slot names with no prefix attached are used with a constructor function. The reader function name is used in conjunction with setf. Here is an example: (defstruct (door (:conc-name dr-)) knob-color width material) => DOOR (setq my-door (make-door :knob-color 'red :width 5.0)) => #S(DOOR :KNOB-COLOR RED :WIDTH 5.0 :MATERIAL NIL) (dr-width my-door) => 5.0 (setf (dr-width my-door) 43.7) => 43.7 (dr-width my-door) => 43.7 Whether or not the :conc-name option is explicitly supplied, the following rule governs name conflicts of generated reader (or accessor) names: For any structure type S_1 having a reader function named R for a slot named X_1 that is inherited by another structure type S_2 that would have a reader function with the same name R for a slot named X_2, no definition for R is generated by the definition of S_2; instead, the definition of R is inherited from the definition of S_1. (In such a case, if X_1 and X_2 are different slots, the implementation might signal a style warning.) :constructor This option takes zero, one, or two arguments. If at least one argument is supplied and the first argument is not nil, then that argument is a symbol which specifies the name of the constructor function. If the argument is not supplied (or if the option itself is not supplied), the name of the constructor is produced by concatenating the string "MAKE-" and the name of the structure, interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no constructor function is defined. If :constructor is given as (:constructor name arglist), then instead of making a keyword driven constructor function, defstruct defines a "positional" constructor function, taking arguments whose meaning is determined by the argument's position and possibly by keywords. Arglist is used to describe what the arguments to the constructor will be. In the simplest case something like (:constructor make-foo (a b c)) defines make-foo to be a three-argument constructor function whose arguments are used to initialize the slots named a, b, and c. Because a constructor of this type operates "By Order of Arguments," it is sometimes known as a "boa constructor." For information on how the arglist for a "boa constructor" is processed, see *note Boa Lambda Lists::. It is permissible to use the :constructor option more than once, so that you can define several different constructor functions, each taking different parameters. [Reviewer Note by Barmar: What about (:constructor) and (:constructor nil). Should we worry about it?] defstruct creates the default-named keyword constructor function only if no explicit :constructor options are specified, or if the :constructor option is specified without a name argument. (:constructor nil) is meaningful only when there are no other :constructor options specified. It prevents defstruct from generating any constructors at all. Otherwise, defstruct creates a constructor function corresponding to each supplied :constructor option. It is permissible to specify multiple keyword constructor functions as well as multiple "boa constructors". :copier This option takes one argument, a symbol, which specifies the name of the copier function. If the argument is not provided or if the option itself is not provided, the name of the copier is produced by concatenating the string "COPY-" and the name of the structure, interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no copier function is defined. The automatically defined copier function is a function of one argument, which must be of the structure type being defined. The copier function creates a fresh structure that has the same type as its argument, and that has the same component values as the original structure; that is, the component values are not copied recursively. If the defstruct :type option was not used, the following equivalence applies: (copier-name x) = (copy-structure (the structure-name x)) :include This option is used for building a new structure definition as an extension of another structure definition. For example: (defstruct person name age sex) To make a new structure to represent an astronaut that has the attributes of name, age, and sex, and functions that operate on person structures, astronaut is defined with :include as follows: (defstruct (astronaut (:include person) (:conc-name astro-)) helmet-size (favorite-beverage 'tang)) :include causes the structure being defined to have the same slots as the included structure. This is done in such a way that the reader functions for the included structure also work on the structure being defined. In this example, an astronaut therefore has five slots: the three defined in person and the two defined in astronaut itself. The reader functions defined by the person structure can be applied to instances of the astronaut structure, and they work correctly. Moreover, astronaut has its own reader functions for components defined by the person structure. The following examples illustrate the use of astronaut structures: (setq x (make-astronaut :name 'buzz :age 45. :sex t :helmet-size 17.5)) (person-name x) => BUZZ (astro-name x) => BUZZ (astro-favorite-beverage x) => TANG (reduce #'+ astros :key #'person-age) ; obtains the total of the ages ; of the possibly empty ; sequence of astros The difference between the reader functions person-name and astro-name is that person-name can be correctly applied to any person, including an astronaut, while astro-name can be correctly applied only to an astronaut. An implementation might check for incorrect use of reader functions. At most one :include can be supplied in a single defstruct. The argument to :include is required and must be the name of some previously defined structure. If the structure being defined has no :type option, then the included structure must also have had no :type option supplied for it. If the structure being defined has a :type option, then the included structure must have been declared with a :type option specifying the same representation type. If no :type option is involved, then the structure name of the including structure definition becomes the name of a data type, and therefore a valid type specifier recognizable by typep; it becomes a subtype of the included structure. In the above example, astronaut is a subtype of person; hence (typep (make-astronaut) 'person) => true indicating that all operations on persons also work on astronauts. The structure using :include can specify default values or slot-options for the included slots different from those the included structure specifies, by giving the :include option as: (:include included-structure-name {slot-description}*) Each slot-description must have a slot-name that is the same as that of some slot in the included structure. If a slot-description has no slot-initform, then in the new structure the slot has no initial value. Otherwise its initial value form is replaced by the slot-initform in the slot-description. A normally writable slot can be made read-only. If a slot is read-only in the included structure, then it must also be so in the including structure. If a type is supplied for a slot, it must be a subtype of the type specified in the included structure. For example, if the default age for an astronaut is 45, then (defstruct (astronaut (:include person (age 45))) helmet-size (favorite-beverage 'tang)) If :include is used with the :type option, then the effect is first to skip over as many representation elements as needed to represent the included structure, then to skip over any additional elements supplied by the :initial-offset option, and then to begin allocation of elements from that point. For example: (defstruct (binop (:type list) :named (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) => BINOP (defstruct (annotated-binop (:type list) (:initial-offset 3) (:include binop)) commutative associative identity) => ANNOTATED-BINOP (make-annotated-binop :operator '* :operand-1 'x :operand-2 5 :commutative t :associative t :identity 1) => (NIL NIL BINOP * X 5 NIL NIL NIL T T 1) The first two nil elements stem from the :initial-offset of 2 in the definition of binop. The next four elements contain the structure name and three slots for binop. The next three nil elements stem from the :initial-offset of 3 in the definition of annotated-binop. The last three list elements contain the additional slots for an annotated-binop. :initial-offset :initial-offset instructs defstruct to skip over a certain number of slots before it starts allocating the slots described in the body. This option's argument is the number of slots defstruct should skip. :initial-offset can be used only if :type is also supplied. [Reviewer Note by Barmar: What are initial values of the skipped slots?] :initial-offset allows slots to be allocated beginning at a representational element other than the first. For example, the form (defstruct (binop (:type list) (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) => BINOP would result in the following behavior for make-binop: (make-binop :operator '+ :operand-1 'x :operand-2 5) => (NIL NIL + X 5) (make-binop :operand-2 4 :operator '*) => (NIL NIL * NIL 4) The selector functions binop-operator, binop-operand-1, and binop-operand-2 would be essentially equivalent to third, fourth, and fifth, respectively. Similarly, the form (defstruct (binop (:type list) :named (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) => BINOP would result in the following behavior for make-binop: (make-binop :operator '+ :operand-1 'x :operand-2 5) => (NIL NIL BINOP + X 5) (make-binop :operand-2 4 :operator '*) => (NIL NIL BINOP * NIL 4) The first two nil elements stem from the :initial-offset of 2 in the definition of binop. The next four elements contain the structure name and three slots for binop. :named :named specifies that the structure is named. If no :type is supplied, then the structure is always named. For example: (defstruct (binop (:type list)) (operator '? :type symbol) operand-1 operand-2) => BINOP This defines a constructor function make-binop and three selector functions, namely binop-operator, binop-operand-1, and binop-operand-2. (It does not, however, define a predicate binop-p, for reasons explained below.) The effect of make-binop is simply to construct a list of length three: (make-binop :operator '+ :operand-1 'x :operand-2 5) => (+ X 5) (make-binop :operand-2 4 :operator '*) => (* NIL 4) It is just like the function list except that it takes keyword arguments and performs slot defaulting appropriate to the binop conceptual data type. Similarly, the selector functions binop-operator, binop-operand-1, and binop-operand-2 are essentially equivalent to car, cadr, and caddr, respectively. They might not be completely equivalent because, for example, an implementation would be justified in adding error-checking code to ensure that the argument to each selector function is a length-3 list. binop is a conceptual data type in that it is not made a part of the Common Lisp type system. typep does not recognize binop as a type specifier, and type-of returns list when given a binop structure. There is no way to distinguish a data structure constructed by make-binop from any other list that happens to have the correct structure. There is not any way to recover the structure name binop from a structure created by make-binop. This can only be done if the structure is named. A named structure has the property that, given an instance of the structure, the structure name (that names the type) can be reliably recovered. For structures defined with no :type option, the structure name actually becomes part of the Common Lisp data-type system. type-of, when applied to such a structure, returns the structure name as the type of the object; typep recognizes the structure name as a valid type specifier. For structures defined with a :type option, type-of returns a type specifier such as list or (vector t), depending on the type supplied to the :type option. The structure name does not become a valid type specifier. However, if the :named option is also supplied, then the first component of the structure (as created by a defstruct constructor function) always contains the structure name. This allows the structure name to be recovered from an instance of the structure and allows a reasonable predicate for the conceptual type to be defined: the automatically defined name-p predicate for the structure operates by first checking that its argument is of the proper type (list, (vector t), or whatever) and then checking whether the first component contains the appropriate type name. Consider the binop example shown above, modified only to include the :named option: (defstruct (binop (:type list) :named) (operator '? :type symbol) operand-1 operand-2) => BINOP As before, this defines a constructor function make-binop and three selector functions binop-operator, binop-operand-1, and binop-operand-2. It also defines a predicate binop-p. The effect of make-binop is now to construct a list of length four: (make-binop :operator '+ :operand-1 'x :operand-2 5) => (BINOP + X 5) (make-binop :operand-2 4 :operator '*) => (BINOP * NIL 4) The structure has the same layout as before except that the structure name binop is included as the first list element. The selector functions binop-operator, binop-operand-1, and binop-operand-2 are essentially equivalent to cadr, caddr, and cadddr, respectively. The predicate binop-p is more or less equivalent to this definition: (defun binop-p (x) (and (consp x) (eq (car x) 'binop))) => BINOP-P The name binop is still not a valid type specifier recognizable to typep, but at least there is a way of distinguishing binop structures from other similarly defined structures. :predicate This option takes one argument, which specifies the name of the type predicate. If the argument is not supplied or if the option itself is not supplied, the name of the predicate is made by concatenating the name of the structure to the string "-P", interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no predicate is defined. A predicate can be defined only if the structure is named; if :type is supplied and :named is not supplied, then :predicate must either be unsupplied or have the value nil. :print-function, :print-object The :print-function and :print-object options specify that a print-object method for structures of type structure-name should be generated. These options are not synonyms, but do perform a similar service; the choice of which option (:print-function or :print-object) is used affects how the function named printer-name is called. Only one of these options may be used, and these options may be used only if :type is not supplied. If the :print-function option is used, then when a structure of type structure-name is to be printed, the designated printer function is called on three arguments: - the structure to be printed (a generalized instance of structure-name). - a stream to print to. - an integer indicating the current depth. The magnitude of this integer may vary between implementations; however, it can reliably be compared against *print-level* to determine whether depth abbreviation is appropriate. Specifying (:print-function printer-name) is approximately equivalent to specifying: (defmethod print-object ((object structure-name) stream) (funcall (function printer-name) object stream <>)) where the <> represents the printer's belief of how deep it is currently printing. It is implementation-dependent whether <> is always 0 and *print-level*, if non-nil, is re-bound to successively smaller values as printing descends recursively, or whether current-print-depth varies in value as printing descends recursively and *print-level* remains constant during the same traversal. If the :print-object option is used, then when a structure of type structure-name is to be printed, the designated printer function is called on two arguments: - the structure to be printed. - the stream to print to. Specifying (:print-object printer-name) is equivalent to specifying: (defmethod print-object ((object structure-name) stream) (funcall (function printer-name) object stream)) If no :type option is supplied, and if either a :print-function or a :print-object option is supplied, and if no printer-name is supplied, then a print-object method specialized for structure-name is generated that calls a function that implements the default printing behavior for structures using #S notation; see *note Printing Structures::. If neither a :print-function nor a :print-object option is supplied, then defstruct does not generate a print-object method specialized for structure-name and some default behavior is inherited either from a structure named in an :include option or from the default behavior for printing structures; see the function print-object and *note Printing Structures::. When *print-circle* is true, a user-defined print function can print objects to the supplied stream using write, prin1, princ, or format and expect circularities to be detected and printed using the #n# syntax. This applies to methods on print-object in addition to :print-function options. If a user-defined print function prints to a stream other than the one that was supplied, then circularity detection starts over for that stream. See the variable *print-circle*. :type :type explicitly specifies the representation to be used for the structure. Its argument must be one of these types: vector This produces the same result as specifying (vector t). The structure is represented as a general vector, storing components as vector elements. The first component is vector element 1 if the structure is :named, and element 0 otherwise. [Reviewer Note by Barmar: Do any implementations create non-simple vectors?] (vector element-type) The structure is represented as a (possibly specialized) vector, storing components as vector elements. Every component must be of a type that can be stored in a vector of the type specified. The first component is vector element 1 if the structure is :named, and element 0 otherwise. The structure can be :named only if the type symbol is a subtype of the supplied element-type. list The structure is represented as a list. The first component is the cadr if the structure is :named, and the car if it is not :named. Specifying this option has the effect of forcing a specific representation and of forcing the components to be stored in the order specified in defstruct in corresponding successive elements of the specified representation. It also prevents the structure name from becoming a valid type specifier recognizable by typep. For example: (defstruct (quux (:type list) :named) x y) should make a constructor that builds a list exactly like the one that list produces, with quux as its car. If this type is defined: (deftype quux () '(satisfies quux-p)) then this form (typep (make-quux) 'quux) should return precisely what this one does (typep (list 'quux nil nil) 'quux) If :type is not supplied, the structure is represented as an object of type structure-object. defstruct without a :type option defines a class with the structure name as its name. The metaclass of structure instances is structure-class. The consequences of redefining a defstruct structure are undefined. In the case where no defstruct options have been supplied, the following functions are automatically defined to operate on instances of the new structure: Predicate A predicate with the name structure-name-p is defined to test membership in the structure type. The predicate (structure-name-p object) is true if an object is of this type; otherwise it is false. typep can also be used with the name of the new type to test whether an object belongs to the type. Such a function call has the form (typep object 'structure-name). Component reader functions Reader functions are defined to read the components of the structure. For each slot name, there is a corresponding reader function with the name structure-name-slot-name. This function reads the contents of that slot. Each reader function takes one argument, which is an instance of the structure type. setf can be used with any of these reader functions to alter the slot contents. Constructor function A constructor function with the name make-structure-name is defined. This function creates and returns new instances of the structure type. Copier function A copier function with the name copy-structure-name is defined. The copier function takes an object of the structure type and creates a new object of the same type that is a copy of the first. The copier function creates a new structure with the same component entries as the original. Corresponding components of the two structure instances are eql. If a defstruct form appears as a top level form, the compiler must make the structure type name recognized as a valid type name in subsequent declarations (as for deftype) and make the structure slot readers known to setf. In addition, the compiler must save enough information about the structure type so that further defstruct definitions can use :include in a subsequent deftype in the same file to refer to the structure type name. The functions which defstruct generates are not defined in the compile time environment, although the compiler may save enough information about the functions to code subsequent calls inline. The #S reader macro might or might not recognize the newly defined structure type name at compile time. Examples:: .......... An example of a structure definition follows: (defstruct ship x-position y-position x-velocity y-velocity mass) This declares that every ship is an object with five named components. The evaluation of this form does the following: 1. It defines ship-x-position to be a function of one argument, a ship, that returns the x-position of the ship; ship-y-position and the other components are given similar function definitions. These functions are called the access functions, as they are used to access elements of the structure. 2. ship becomes the name of a type of which instances of ships are elements. ship becomes acceptable to typep, for example; (typep x 'ship) is true if x is a ship and false if x is any object other than a ship. 3. A function named ship-p of one argument is defined; it is a predicate that is true if its argument is a ship and is false otherwise. 4. A function called make-ship is defined that, when invoked, creates a data structure with five components, suitable for use with the access functions. Thus executing (setq ship2 (make-ship)) sets ship2 to a newly created ship object. One can supply the initial values of any desired component in the call to make-ship by using keyword arguments in this way: (setq ship2 (make-ship :mass *default-ship-mass* :x-position 0 :y-position 0)) This constructs a new ship and initializes three of its components. This function is called the "constructor function" because it constructs a new structure. 5. A function called copy-ship of one argument is defined that, when given a ship object, creates a new ship object that is a copy of the given one. This function is called the "copier function." setf can be used to alter the components of a ship: (setf (ship-x-position ship2) 100) This alters the x-position of ship2 to be 100. This works because defstruct behaves as if it generates an appropriate defsetf for each access function. ;;; ;;; Example 1 ;;; define town structure type ;;; area, watertowers, firetrucks, population, elevation are its components ;;; (defstruct town area watertowers (firetrucks 1 :type fixnum) ;an initialized slot population (elevation 5128 :read-only t)) ;a slot that can't be changed => TOWN ;create a town instance (setq town1 (make-town :area 0 :watertowers 0)) => #S(TOWN...) ;town's predicate recognizes the new instance (town-p town1) => true ;new town's area is as specified by make-town (town-area town1) => 0 ;new town's elevation has initial value (town-elevation town1) => 5128 ;setf recognizes reader function (setf (town-population town1) 99) => 99 (town-population town1) => 99 ;copier function makes a copy of town1 (setq town2 (copy-town town1)) => #S(TOWN...) (= (town-population town1) (town-population town2)) => true ;since elevation is a read-only slot, its value can be set only ;when the structure is created (setq town3 (make-town :area 0 :watertowers 3 :elevation 1200)) => #S(TOWN...) ;;; ;;; Example 2 ;;; define clown structure type ;;; this structure uses a nonstandard prefix ;;; (defstruct (clown (:conc-name bozo-)) (nose-color 'red) frizzy-hair-p polkadots) => CLOWN (setq funny-clown (make-clown)) => #S(CLOWN) ;use non-default reader name (bozo-nose-color funny-clown) => RED (defstruct (klown (:constructor make-up-klown) ;similar def using other (:copier clone-klown) ;customizing keywords (:predicate is-a-bozo-p)) nose-color frizzy-hair-p polkadots) => klown ;custom constructor now exists (fboundp 'make-up-klown) => true ;;; ;;; Example 3 ;;; define a vehicle structure type ;;; then define a truck structure type that includes ;;; the vehicle structure ;;; (defstruct vehicle name year (diesel t :read-only t)) => VEHICLE (defstruct (truck (:include vehicle (year 79))) load-limit (axles 6)) => TRUCK (setq x (make-truck :name 'mac :diesel t :load-limit 17)) => #S(TRUCK...) ;vehicle readers work on trucks (vehicle-name x) => MAC ;default taken from :include clause (vehicle-year x) => 79 (defstruct (pickup (:include truck)) ;pickup type includes truck camper long-bed four-wheel-drive) => PICKUP (setq x (make-pickup :name 'king :long-bed t)) => #S(PICKUP...) ;:include default inherited (pickup-year x) => 79 ;;; ;;; Example 4 ;;; use of BOA constructors ;;; (defstruct (dfs-boa ;BOA constructors (:constructor make-dfs-boa (a b c)) (:constructor create-dfs-boa (a &optional b (c 'cc) &rest d &aux e (f 'ff)))) a b c d e f) => DFS-BOA ;a, b, and c set by position, and the rest are uninitialized (setq x (make-dfs-boa 1 2 3)) => #(DFS-BOA...) (dfs-boa-a x) => 1 ;a and b set, c and f defaulted (setq x (create-dfs-boa 1 2)) => #(DFS-BOA...) (dfs-boa-b x) => 2 (eq (dfs-boa-c x) 'cc) => true ;a, b, and c set, and the rest are collected into d (setq x (create-dfs-boa 1 2 3 4 5 6)) => #(DFS-BOA...) (dfs-boa-d x) => (4 5 6) Exceptional Situations:: ........................ If any two slot names (whether present directly or inherited by the :include option) are the same under string=, defstruct should signal an error of type program-error. The consequences are undefined if the included-structure-name does not name a structure type. See Also:: .......... *note documentation:: , *note print-object:: , *note setf:: , *note subtypep:: , *note type-of:: , *note typep:: , *note Compilation:: Notes:: ....... The printer-name should observe the values of such printer-control variables as *print-escape*. The restriction against issuing a warning for type mismatches between a slot-initform and the corresponding slot's :type option is necessary because a slot-initform must be specified in order to specify slot options; in some cases, no suitable default may exist. The mechanism by which defstruct arranges for slot accessors to be usable with setf is implementation-dependent; for example, it may use setf functions, setf expanders, or some other implementation-dependent mechanism known to that implementation's code for setf.  File: gcl.info, Node: copy-structure, Prev: defstruct, Up: Structures Dictionary 8.1.2 copy-structure [Function] ------------------------------- 'copy-structure' structure => copy Arguments and Values:: ...................... structure--a structure. copy--a copy of the structure. Description:: ............. Returns a copy_6 of the structure. Only the structure itself is copied; not the values of the slots. See Also:: .......... the :copier option to *note defstruct:: Notes:: ....... The copy is the same as the given structure under equalp, but not under equal.  File: gcl.info, Node: Conditions, Next: Symbols, Prev: Structures, Up: Top 9 Conditions ************ * Menu: * Condition System Concepts:: * Conditions Dictionary::  File: gcl.info, Node: Condition System Concepts, Next: Conditions Dictionary, Prev: Conditions, Up: Conditions 9.1 Condition System Concepts ============================= Common Lisp constructs are described not only in terms of their behavior in situations during which they are intended to be used (see the "Description" part of each operator specification), but in all other situations (see the "Exceptional Situations" part of each operator specification). A situation is the evaluation of an expression in a specific context. A condition is an object that represents a specific situation that has been detected. Conditions are generalized instances of the class condition. A hierarchy of condition classes is defined in Common Lisp. A condition has slots that contain data relevant to the situation that the condition represents. An error is a situation in which normal program execution cannot continue correctly without some form of intervention (either interactively by the user or under program control). Not all errors are detected. When an error goes undetected, the effects can be implementation-dependent, implementation-defined, unspecified, or undefined. See *note Definitions::. All detected errors can be represented by conditions, but not all conditions represent errors. Signaling is the process by which a condition can alter the flow of control in a program by raising the condition which can then be handled. The functions error, cerror, signal, and warn are used to signal conditions. The process of signaling involves the selection and invocation of a handler from a set of active handlers. A handler is a function of one argument (the condition) that is invoked to handle a condition. Each handler is associated with a condition type, and a handler will be invoked only on a condition of the handler's associated type. Active handlers are established dynamically (see handler-bind or handler-case). Handlers are invoked in a dynamic environment equivalent to that of the signaler, except that the set of active handlers is bound in such a way as to include only those that were active at the time the handler being invoked was established. Signaling a condition has no side-effect on the condition, and there is no dynamic state contained in a condition. If a handler is invoked, it can address the situation in one of three ways: Decline It can decline to handle the condition. It does this by simply returning rather than transferring control. When this happens, any values returned by the handler are ignored and the next most recently established handler is invoked. If there is no such handler and the signaling function is error or cerror, the debugger is entered in the dynamic environment of the signaler. If there is no such handler and the signaling function is either signal or warn, the signaling function simply returns~nil. Handle It can handle the condition by performing a non-local transfer of control. This can be done either primitively by using go, return, throw or more abstractly by using a function such as abort or invoke-restart. Defer It can put off a decision about whether to handle or decline, by any of a number of actions, but most commonly by signaling another condition, resignaling the same condition, or forcing entry into the debugger. * Menu: * Condition Types:: * Creating Conditions:: * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: * Notes about the Condition System`s Background::  File: gcl.info, Node: Condition Types, Next: Creating Conditions, Prev: Condition System Concepts, Up: Condition System Concepts 9.1.1 Condition Types --------------------- Figure 9-1 lists the standardized condition types. Additional condition types can be defined by using define-condition. arithmetic-error floating-point-overflow simple-type-error cell-error floating-point-underflow simple-warning condition package-error storage-condition control-error parse-error stream-error division-by-zero print-not-readable style-warning end-of-file program-error type-error error reader-error unbound-slot file-error serious-condition unbound-variable floating-point-inexact simple-condition undefined-function floating-point-invalid-operation simple-error warning Figure 9-1: Standardized Condition Types All condition types are subtypes of type condition. That is, (typep c 'condition) => true if and only if c is a condition. Implementations must define all specified subtype relationships. Except where noted, all subtype relationships indicated in this document are not mutually exclusive. A condition inherits the structure of its supertypes. The metaclass of the class condition is not specified. Names of condition types may be used to specify supertype relationships in define-condition, but the consequences are not specified if an attempt is made to use a condition type as a superclass in a defclass form. Figure 9-2 shows operators that define condition types and creating conditions. define-condition make-condition Figure 9-2: Operators that define and create conditions. Figure 9-3 shows operators that read the value of condition slots. arithmetic-error-operands simple-condition-format-arguments arithmetic-error-operation simple-condition-format-control cell-error-name stream-error-stream file-error-pathname type-error-datum package-error-package type-error-expected-type print-not-readable-object unbound-slot-instance Figure 9-3: Operators that read condition slots. * Menu: * Serious Conditions::  File: gcl.info, Node: Serious Conditions, Prev: Condition Types, Up: Condition Types 9.1.1.1 Serious Conditions .......................... A serious condition is a condition serious enough to require interactive intervention if not handled. Serious conditions are typically signaled with error or cerror; non-serious conditions are typically signaled with signal or warn.  File: gcl.info, Node: Creating Conditions, Next: Printing Conditions, Prev: Condition Types, Up: Condition System Concepts 9.1.2 Creating Conditions ------------------------- The function make-condition can be used to construct a condition object explicitly. Functions such as error, cerror, signal, and warn operate on conditions and might create condition objects implicitly. Macros such as ccase, ctypecase, ecase, etypecase, check-type, and assert might also implicitly create (and signal) conditions. * Menu: * Condition Designators::  File: gcl.info, Node: Condition Designators, Prev: Creating Conditions, Up: Creating Conditions 9.1.2.1 Condition Designators ............................. A number of the functions in the condition system take arguments which are identified as condition designators . By convention, those arguments are notated as datum &rest arguments Taken together, the datum and the arguments are "designators for a condition of default type default-type." How the denoted condition is computed depends on the type of the datum: * If the datum is a symbol naming a condition type ... The denoted condition is the result of (apply #'make-condition datum arguments) * If the datum is a format control ... The denoted condition is the result of (make-condition defaulted-type :format-control datum :format-arguments arguments) where the defaulted-type is a subtype of default-type. * If the datum is a condition ... The denoted condition is the datum itself. In this case, unless otherwise specified by the description of the operator in question, the arguments must be null; that is, the consequences are undefined if any arguments were supplied. Note that the default-type gets used only in the case where the datum string is supplied. In the other situations, the resulting condition is not necessarily of type default-type. Here are some illustrations of how different condition designators can denote equivalent condition objects: (let ((c (make-condition 'arithmetic-error :operator '/ :operands '(7 0)))) (error c)) == (error 'arithmetic-error :operator '/ :operands '(7 0)) (error "Bad luck.") == (error 'simple-error :format-control "Bad luck." :format-arguments '())  File: gcl.info, Node: Printing Conditions, Next: Signaling and Handling Conditions, Prev: Creating Conditions, Up: Condition System Concepts 9.1.3 Printing Conditions ------------------------- If the :report argument to define-condition is used, a print function is defined that is called whenever the defined condition is printed while the value of *print-escape* is false. This function is called the condition reporter ; the text which it outputs is called a report message . When a condition is printed and *print-escape* is false, the condition reporter for the condition is invoked. Conditions are printed automatically by functions such as invoke-debugger, break, and warn. When *print-escape* is true, the object should print in an abbreviated fashion according to the style of the implementation (e.g., by print-unreadable-object). It is not required that a condition can be recreated by reading its printed representation. No function is provided for directly accessing or invoking condition reporters. * Menu: * Recommended Style in Condition Reporting:: * Capitalization and Punctuation in Condition Reports:: * Leading and Trailing Newlines in Condition Reports:: * Embedded Newlines in Condition Reports:: * Note about Tabs in Condition Reports:: * Mentioning Containing Function in Condition Reports::  File: gcl.info, Node: Recommended Style in Condition Reporting, Next: Capitalization and Punctuation in Condition Reports, Prev: Printing Conditions, Up: Printing Conditions 9.1.3.1 Recommended Style in Condition Reporting ................................................ In order to ensure a properly aesthetic result when presenting report messages to the user, certain stylistic conventions are recommended. There are stylistic recommendations for the content of the messages output by condition reporters, but there are no formal requirements on those programs. If a program violates the recommendations for some message, the display of that message might be less aesthetic than if the guideline had been observed, but the program is still considered a conforming program. The requirements on a program or implementation which invokes a condition reporter are somewhat stronger. A conforming program must be permitted to assume that if these style guidelines are followed, proper aesthetics will be maintained. Where appropriate, any specific requirements on such routines are explicitly mentioned below.  File: gcl.info, Node: Capitalization and Punctuation in Condition Reports, Next: Leading and Trailing Newlines in Condition Reports, Prev: Recommended Style in Condition Reporting, Up: Printing Conditions 9.1.3.2 Capitalization and Punctuation in Condition Reports ........................................................... It is recommended that a report message be a complete sentences, in the proper case and correctly punctuated. In English, for example, this means the first letter should be uppercase, and there should be a trailing period. (error "This is a message") ; Not recommended (error "this is a message.") ; Not recommended (error "This is a message.") ; Recommended instead  File: gcl.info, Node: Leading and Trailing Newlines in Condition Reports, Next: Embedded Newlines in Condition Reports, Prev: Capitalization and Punctuation in Condition Reports, Up: Printing Conditions 9.1.3.3 Leading and Trailing Newlines in Condition Reports .......................................................... It is recommended that a report message not begin with any introductory text, such as "Error: " or "Warning: " or even just freshline or newline. Such text is added, if appropriate to the context, by the routine invoking the condition reporter. It is recommended that a report message not be followed by a trailing freshline or newline. Such text is added, if appropriate to the context, by the routine invoking the condition reporter. (error "This is a message.~ (error "~&This is a message.") ; Not recommended (error "~&This is a message.~ (error "This is a message.") ; Recommended instead  File: gcl.info, Node: Embedded Newlines in Condition Reports, Next: Note about Tabs in Condition Reports, Prev: Leading and Trailing Newlines in Condition Reports, Up: Printing Conditions 9.1.3.4 Embedded Newlines in Condition Reports .............................................. Especially if it is long, it is permissible and appropriate for a report message to contain one or more embedded newlines. If the calling routine conventionally inserts some additional prefix (such as "Error: " or ";; Error: ") on the first line of the message, it must also assure that an appropriate prefix will be added to each subsequent line of the output, so that the left edge of the message output by the condition reporter will still be properly aligned. (defun test () (error "This is an error message.~%It has two lines.")) ;; Implementation A (test) This is an error message. It has two lines. ;; Implementation B (test) ;; Error: This is an error message. ;; It has two lines. ;; Implementation C (test) >> Error: This is an error message. It has two lines.  File: gcl.info, Node: Note about Tabs in Condition Reports, Next: Mentioning Containing Function in Condition Reports, Prev: Embedded Newlines in Condition Reports, Up: Printing Conditions 9.1.3.5 Note about Tabs in Condition Reports ............................................ Because the indentation of a report message might be shifted to the right or left by an arbitrary amount, special care should be taken with the semi-standard character (in those implementations that support such a character). Unless the implementation specifically defines its behavior in this context, its use should be avoided.  File: gcl.info, Node: Mentioning Containing Function in Condition Reports, Prev: Note about Tabs in Condition Reports, Up: Printing Conditions 9.1.3.6 Mentioning Containing Function in Condition Reports ........................................................... The name of the containing function should generally not be mentioned in report messages. It is assumed that the debugger will make this information accessible in situations where it is necessary and appropriate.  File: gcl.info, Node: Signaling and Handling Conditions, Next: Assertions, Prev: Printing Conditions, Up: Condition System Concepts 9.1.4 Signaling and Handling Conditions --------------------------------------- The operation of the condition system depends on the ordering of active applicable handlers from most recent to least recent. Each handler is associated with a type specifier that must designate a subtype of type condition. A handler is said to be applicable to a condition if that condition is of the type designated by the associated type specifier. Active handlers are established by using handler-bind (or an abstraction based on handler-bind, such as handler-case or ignore-errors). Active handlers can be established within the dynamic scope of other active handlers. At any point during program execution, there is a set of active handlers. When a condition is signaled, the most recent active applicable handler for that condition is selected from this set. Given a condition, the order of recentness of active applicable handlers is defined by the following two rules: 1. Each handler in a set of active handlers H_1 is more recent than every handler in a set H_2 if the handlers in H_2 were active when the handlers in H_1 were established. 2. Let h_1 and h_2 be two applicable active handlers established by the same form. Then h_1 is more recent than h_2 if h_1 was defined to the left of h_2 in the form that established them. Once a handler in a handler binding form (such as handler-bind or handler-case) has been selected, all handlers in that form become inactive for the remainder of the signaling process. While the selected handler runs, no other handler established by that form is active. That is, if the handler declines, no other handler established by that form will be considered for possible invocation. Figure 9-4 shows operators relating to the handling of conditions. handler-bind handler-case ignore-errors Figure 9-4: Operators relating to handling conditions. * Menu: * Signaling:: * Resignaling a Condition:: * Restarts:: * Interactive Use of Restarts:: * Interfaces to Restarts:: * Restart Tests:: * Associating a Restart with a Condition::  File: gcl.info, Node: Signaling, Next: Resignaling a Condition, Prev: Signaling and Handling Conditions, Up: Signaling and Handling Conditions 9.1.4.1 Signaling ................. When a condition is signaled, the most recent applicable active handler is invoked. Sometimes a handler will decline by simply returning without a transfer of control. In such cases, the next most recent applicable active handler is invoked. If there are no applicable handlers for a condition that has been signaled, or if all applicable handlers decline, the condition is unhandled. The functions cerror and error invoke the interactive condition handler (the debugger) rather than return if the condition being signaled, regardless of its type, is unhandled. In contrast, signal returns nil if the condition being signaled, regardless of its type, is unhandled. The variable *break-on-signals* can be used to cause the debugger to be entered before the signaling process begins. Figure 9-5 shows defined names relating to the signaling of conditions. *break-on-signals* error warn cerror signal Figure 9-5: Defined names relating to signaling conditions.  File: gcl.info, Node: Resignaling a Condition, Next: Restarts, Prev: Signaling, Up: Signaling and Handling Conditions 9.1.4.2 Resignaling a Condition ............................... During the dynamic extent of the signaling process for a particular condition object, signaling the same condition object again is permitted if and only if the situation represented in both cases are the same. For example, a handler might legitimately signal the condition object that is its argument in order to allow outer handlers first opportunity to handle the condition. (Such a handlers is sometimes called a "default handler.") This action is permitted because the situation which the second signaling process is addressing is really the same situation. On the other hand, in an implementation that implemented asynchronous keyboard events by interrupting the user process with a call to signal, it would not be permissible for two distinct asynchronous keyboard events to signal identical condition objects at the same time for different situations.  File: gcl.info, Node: Restarts, Next: Interactive Use of Restarts, Prev: Resignaling a Condition, Up: Signaling and Handling Conditions 9.1.4.3 Restarts ................ The interactive condition handler returns only through non-local transfer of control to specially defined restarts that can be set up either by the system or by user code. Transferring control to a restart is called "invoking" the restart. Like handlers, active restarts are established dynamically, and only active restarts can be invoked. An active restart can be invoked by the user from the debugger or by a program by using invoke-restart. A restart contains a function to be called when the restart is invoked, an optional name that can be used to find or invoke the restart, and an optional set of interaction information for the debugger to use to enable the user to manually invoke a restart. The name of a restart is used by invoke-restart. Restarts that can be invoked only within the debugger do not need names. Restarts can be established by using restart-bind, restart-case, and with-simple-restart. A restart function can itself invoke any other restart that was active at the time of establishment of the restart of which the function is part. The restarts established by a restart-bind form, a restart-case form, or a with-simple-restart form have dynamic extent which extends for the duration of that form's execution. Restarts of the same name can be ordered from least recent to most recent according to the following two rules: 1. Each restart in a set of active restarts R_1 is more recent than every restart in a set R_2 if the restarts in R_2 were active when the restarts in R_1 were established. 2. Let r_1 and r_2 be two active restarts with the same name established by the same form. Then r_1 is more recent than r_2 if r_1 was defined to the left of r_2 in the form that established them. If a restart is invoked but does not transfer control, the values resulting from the restart function are returned by the function that invoked the restart, either invoke-restart or invoke-restart-interactively.  File: gcl.info, Node: Interactive Use of Restarts, Next: Interfaces to Restarts, Prev: Restarts, Up: Signaling and Handling Conditions 9.1.4.4 Interactive Use of Restarts ................................... For interactive handling, two pieces of information are needed from a restart: a report function and an interactive function. The report function is used by a program such as the debugger to present a description of the action the restart will take. The report function is specified and established by the :report-function keyword to restart-bind or the :report keyword to restart-case. The interactive function, which can be specified using the :interactive-function keyword to restart-bind or :interactive keyword to restart-case, is used when the restart is invoked interactively, such as from the debugger, to produce a suitable list of arguments. invoke-restart invokes the most recently established restart whose name is the same as the first argument to invoke-restart. If a restart is invoked interactively by the debugger and does not transfer control but rather returns values, the precise action of the debugger on those values is implementation-defined.  File: gcl.info, Node: Interfaces to Restarts, Next: Restart Tests, Prev: Interactive Use of Restarts, Up: Signaling and Handling Conditions 9.1.4.5 Interfaces to Restarts .............................. Some restarts have functional interfaces, such as abort, continue, muffle-warning, store-value, and use-value. They are ordinary functions that use find-restart and invoke-restart internally, that have the same name as the restarts they manipulate, and that are provided simply for notational convenience. Figure 9-6 shows defined names relating to restarts. abort invoke-restart-interactively store-value compute-restarts muffle-warning use-value continue restart-bind with-simple-restart find-restart restart-case invoke-restart restart-name Figure 9-6: Defined names relating to restarts.  File: gcl.info, Node: Restart Tests, Next: Associating a Restart with a Condition, Prev: Interfaces to Restarts, Up: Signaling and Handling Conditions 9.1.4.6 Restart Tests ..................... Each restart has an associated test, which is a function of one argument (a condition or nil) which returns true if the restart should be visible in the current situation. This test is created by the :test-function option to restart-bind or the :test option to restart-case.  File: gcl.info, Node: Associating a Restart with a Condition, Prev: Restart Tests, Up: Signaling and Handling Conditions 9.1.4.7 Associating a Restart with a Condition .............................................. A restart can be "associated with" a condition explicitly by with-condition-restarts, or implicitly by restart-case. Such an assocation has dynamic extent. A single restart may be associated with several conditions at the same time. A single condition may have several associated restarts at the same time. Active restarts associated with a particular condition can be detected by calling a function such as find-restart, supplying that condition as the condition argument. Active restarts can also be detected without regard to any associated condition by calling such a function without a condition argument, or by supplying a value of nil for such an argument.  File: gcl.info, Node: Assertions, Next: Notes about the Condition System`s Background, Prev: Signaling and Handling Conditions, Up: Condition System Concepts 9.1.5 Assertions ---------------- Conditional signaling of conditions based on such things as key match, form evaluation, and type are handled by assertion operators. Figure 9-7 shows operators relating to assertions. assert check-type ecase ccase ctypecase etypecase Figure 9-7: Operators relating to assertions.  File: gcl.info, Node: Notes about the Condition System`s Background, Prev: Assertions, Up: Condition System Concepts 9.1.6 Notes about the Condition System's Background --------------------------------------------------- For a background reference to the abstract concepts detailed in this section, see Exceptional Situations in Lisp. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material.  File: gcl.info, Node: Conditions Dictionary, Prev: Condition System Concepts, Up: Conditions 9.2 Conditions Dictionary ========================= * Menu: * condition:: * warning:: * style-warning:: * serious-condition:: * error (Condition Type):: * cell-error:: * cell-error-name:: * parse-error:: * storage-condition:: * assert:: * error:: * cerror:: * check-type:: * simple-error:: * invalid-method-error:: * method-combination-error:: * signal:: * simple-condition:: * simple-condition-format-control:: * warn:: * simple-warning:: * invoke-debugger:: * break:: * *debugger-hook*:: * *break-on-signals*:: * handler-bind:: * handler-case:: * ignore-errors:: * define-condition:: * make-condition:: * restart:: * compute-restarts:: * find-restart:: * invoke-restart:: * invoke-restart-interactively:: * restart-bind:: * restart-case:: * restart-name:: * with-condition-restarts:: * with-simple-restart:: * abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: * abort (Function)::  File: gcl.info, Node: condition, Next: warning, Prev: Conditions Dictionary, Up: Conditions Dictionary 9.2.1 condition [Condition Type] -------------------------------- [Reviewer Note by Barrett: I think CONDITION-RESTARTS is not fully integrated.] Class Precedence List:: ....................... condition, t Description:: ............. All types of conditions, whether error or non-error, must inherit from this type. No additional subtype relationships among the specified subtypes of type condition are allowed, except when explicitly mentioned in the text; however implementations are permitted to introduce additional types and one of these types can be a subtype of any number of the subtypes of type condition. Whether a user-defined condition type has slots that are accessible by with-slots is implementation-dependent. Furthermore, even in an implementation in which user-defined condition types would have slots, it is implementation-dependent whether any condition types defined in this document have such slots or, if they do, what their names might be; only the reader functions documented by this specification may be relied upon by portable code. Conforming code must observe the following restrictions related to conditions: * define-condition, not defclass, must be used to define new condition types. * make-condition, not make-instance, must be used to create condition objects explicitly. * The :report option of define-condition, not defmethod for print-object, must be used to define a condition reporter. * slot-value, slot-boundp, slot-makunbound, and with-slots must not be used on condition objects. Instead, the appropriate accessor functions (defined by define-condition) should be used.  File: gcl.info, Node: warning, Next: style-warning, Prev: condition, Up: Conditions Dictionary 9.2.2 warning [Condition Type] ------------------------------ Class Precedence List:: ....................... warning, condition, t Description:: ............. The type warning consists of all types of warnings. See Also:: .......... style-warning  File: gcl.info, Node: style-warning, Next: serious-condition, Prev: warning, Up: Conditions Dictionary 9.2.3 style-warning [Condition Type] ------------------------------------ Class Precedence List:: ....................... style-warning, warning, condition, t Description:: ............. The type style-warning includes those conditions that represent situations involving code that is conforming code but that is nevertheless considered to be faulty or substandard. See Also:: .......... *note muffle-warning:: Notes:: ....... An implementation might signal such a condition if it encounters code that uses deprecated features or that appears unaesthetic or inefficient. An 'unused variable' warning must be of type style-warning. In general, the question of whether code is faulty or substandard is a subjective decision to be made by the facility processing that code. The intent is that whenever such a facility wishes to complain about code on such subjective grounds, it should use this condition type so that any clients who wish to redirect or muffle superfluous warnings can do so without risking that they will be redirecting or muffling other, more serious warnings.  File: gcl.info, Node: serious-condition, Next: error (Condition Type), Prev: style-warning, Up: Conditions Dictionary 9.2.4 serious-condition [Condition Type] ---------------------------------------- Class Precedence List:: ....................... serious-condition, condition, t Description:: ............. All conditions serious enough to require interactive intervention if not handled should inherit from the type serious-condition. This condition type is provided primarily so that it may be included as a superclass of other condition types; it is not intended to be signaled directly. Notes:: ....... Signaling a serious condition does not itself force entry into the debugger. However, except in the unusual situation where the programmer can assure that no harm will come from failing to handle a serious condition, such a condition is usually signaled with error rather than signal in order to assure that the program does not continue without handling the condition. (And conversely, it is conventional to use signal rather than error to signal conditions which are not serious conditions, since normally the failure to handle a non-serious condition is not reason enough for the debugger to be entered.)  File: gcl.info, Node: error (Condition Type), Next: cell-error, Prev: serious-condition, Up: Conditions Dictionary 9.2.5 error [Condition Type] ---------------------------- Class Precedence List:: ....................... error, serious-condition, condition, t Description:: ............. The type error consists of all conditions that represent errors.  File: gcl.info, Node: cell-error, Next: cell-error-name, Prev: error (Condition Type), Up: Conditions Dictionary 9.2.6 cell-error [Condition Type] --------------------------------- Class Precedence List:: ....................... cell-error, error, serious-condition, condition, t Description:: ............. The type cell-error consists of error conditions that occur during a location access. The name of the offending cell is initialized by the :name initialization argument to make-condition, and is accessed by the function cell-error-name. See Also:: .......... *note cell-error-name::  File: gcl.info, Node: cell-error-name, Next: parse-error, Prev: cell-error, Up: Conditions Dictionary 9.2.7 cell-error-name [Function] -------------------------------- 'cell-error-name' condition => name Arguments and Values:: ...................... condition--a condition of type cell-error. name--an object. Description:: ............. Returns the name of the offending cell involved in the situation represented by condition. The nature of the result depends on the specific type of condition. For example, if the condition is of type unbound-variable, the result is the name of the unbound variable which was being accessed, if the condition is of type undefined-function, this is the name of the undefined function which was being accessed, and if the condition is of type unbound-slot, this is the name of the slot which was being accessed. See Also:: .......... cell-error, unbound-slot, unbound-variable, undefined-function, *note Condition System Concepts::  File: gcl.info, Node: parse-error, Next: storage-condition, Prev: cell-error-name, Up: Conditions Dictionary 9.2.8 parse-error [Condition Type] ---------------------------------- Class Precedence List:: ....................... parse-error, error, serious-condition, condition, t Description:: ............. The type parse-error consists of error conditions that are related to parsing. See Also:: .......... *note parse-namestring:: , *note reader-error::  File: gcl.info, Node: storage-condition, Next: assert, Prev: parse-error, Up: Conditions Dictionary 9.2.9 storage-condition [Condition Type] ---------------------------------------- Class Precedence List:: ....................... storage-condition, serious-condition, condition, t Description:: ............. The type storage-condition consists of serious conditions that relate to problems with memory management that are potentially due to implementation-dependent limits rather than semantic errors in conforming programs, and that typically warrant entry to the debugger if not handled. Depending on the details of the implementation, these might include such problems as stack overflow, memory region overflow, and storage exhausted. Notes:: ....... While some Common Lisp operations might signal storage-condition because they are defined to create objects, it is unspecified whether operations that are not defined to create objects create them anyway and so might also signal storage-condition. Likewise, the evaluator itself might create objects and so might signal storage-condition. (The natural assumption might be that such object creation is naturally inefficient, but even that is implementation-dependent.) In general, the entire question of how storage allocation is done is implementation-dependent, and so any operation might signal storage-condition at any time. Because such a condition is indicative of a limitation of the implementation or of the image rather than an error in a program, objects of type storage-condition are not of type error.  File: gcl.info, Node: assert, Next: error, Prev: storage-condition, Up: Conditions Dictionary 9.2.10 assert [Macro] --------------------- 'assert' test-form [({place}*) [datum-form {argument-form}*]] => nil Arguments and Values:: ...................... test-form--a form; always evaluated. place--a place; evaluated if an error is signaled. datum-form--a form that evaluates to a datum. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled. argument-form--a form that evaluates to an argument. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled. datum, arguments--designators for a condition of default type error. (These designators are the result of evaluating datum-form and each of the argument-forms.) Description:: ............. assert assures that test-form evaluates to true. If test-form evaluates to false, assert signals a correctable error (denoted by datum and arguments). Continuing from this error using the continue restart makes it possible for the user to alter the values of the places before assert evaluates test-form again. If the value of test-form is non-nil, assert returns nil. The places are generalized references to data upon which test-form depends, whose values can be changed by the user in attempting to correct the error. Subforms of each place are only evaluated if an error is signaled, and might be re-evaluated if the error is re-signaled (after continuing without actually fixing the problem). The order of evaluation of the places is not specified; see *note Evaluation of Subforms to Places::. If a place form is supplied that produces more values than there are store variables, the extra values are ignored. If the supplied form produces fewer values than there are store variables, the missing values are set to nil. Examples:: .......... (setq x (make-array '(3 5) :initial-element 3)) => #2A((3 3 3 3 3) (3 3 3 3 3) (3 3 3 3 3)) (setq y (make-array '(3 5) :initial-element 7)) => #2A((7 7 7 7 7) (7 7 7 7 7) (7 7 7 7 7)) (defun matrix-multiply (a b) (let ((*print-array* nil)) (assert (and (= (array-rank a) (array-rank b) 2) (= (array-dimension a 1) (array-dimension b 0))) (a b) "Cannot multiply ~S by ~S." a b) (really-matrix-multiply a b))) => MATRIX-MULTIPLY (matrix-multiply x y) |> Correctable error in MATRIX-MULTIPLY: |> Cannot multiply # by #. |> Restart options: |> 1: You will be prompted for one or more new values. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Value for A: |>>x<<| |> Value for B: |>>(make-array '(5 3) :initial-element 6)<<| => #2A((54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54)) (defun double-safely (x) (assert (numberp x) (x)) (+ x x)) (double-safely 4) => 8 (double-safely t) |> Correctable error in DOUBLE-SAFELY: The value of (NUMBERP X) must be non-NIL. |> Restart options: |> 1: You will be prompted for one or more new values. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Value for X: |>>7<<| => 14 Affected By:: ............. *break-on-signals* The set of active condition handlers. See Also:: .......... *note check-type:: , *note error:: , *note Generalized Reference:: Notes:: ....... The debugger need not include the test-form in the error message, and the places should not be included in the message, but they should be made available for the user's perusal. If the user gives the "continue" command, the values of any of the references can be altered. The details of this depend on the implementation's style of user interface.  File: gcl.info, Node: error, Next: cerror, Prev: assert, Up: Conditions Dictionary 9.2.11 error [Function] ----------------------- 'error' datum &rest arguments => # Arguments and Values:: ...................... datum, arguments--designators for a condition of default type simple-error. Description:: ............. error effectively invokes signal on the denoted condition. If the condition is not handled, (invoke-debugger condition) is done. As a consequence of calling invoke-debugger, error cannot directly return; the only exit from error can come by non-local transfer of control in a handler or by use of an interactive debugging command. Examples:: .......... (defun factorial (x) (cond ((or (not (typep x 'integer)) (minusp x)) (error "~S is not a valid argument to FACTORIAL." x)) ((zerop x) 1) (t (* x (factorial (- x 1)))))) => FACTORIAL (factorial 20) => 2432902008176640000 (factorial -1) |> Error: -1 is not a valid argument to FACTORIAL. |> To continue, type :CONTINUE followed by an option number: |> 1: Return to Lisp Toplevel. |> Debug> (setq a 'fred) => FRED (if (numberp a) (1+ a) (error "~S is not a number." A)) |> Error: FRED is not a number. |> To continue, type :CONTINUE followed by an option number: |> 1: Return to Lisp Toplevel. |> Debug> |>>:Continue 1<<| |> Return to Lisp Toplevel. (define-condition not-a-number (error) ((argument :reader not-a-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a number." (not-a-number-argument condition))))) => NOT-A-NUMBER (if (numberp a) (1+ a) (error 'not-a-number :argument a)) |> Error: FRED is not a number. |> To continue, type :CONTINUE followed by an option number: |> 1: Return to Lisp Toplevel. |> Debug> |>>:Continue 1<<| |> Return to Lisp Toplevel. Side Effects:: .............. Handlers for the specified condition, if any, are invoked and might have side effects. Program execution might stop, and the debugger might be entered. Affected By:: ............. Existing handler bindings. *break-on-signals* Signals an error of type type-error if datum and arguments are not designators for a condition. See Also:: .......... *note cerror:: , *note signal:: , *note format:: , *note ignore-errors:: , *break-on-signals*, *note handler-bind:: , *note Condition System Concepts:: Notes:: ....... Some implementations may provide debugger commands for interactively returning from individual stack frames. However, it should be possible for the programmer to feel confident about writing code like: (defun wargames:no-win-scenario () (if (error "pushing the button would be stupid.")) (push-the-button)) In this scenario, there should be no chance that error will return and the button will get pushed. While the meaning of this program is clear and it might be proven 'safe' by a formal theorem prover, such a proof is no guarantee that the program is safe to execute. Compilers have been known to have bugs, computers to have signal glitches, and human beings to manually intervene in ways that are not always possible to predict. Those kinds of errors, while beyond the scope of the condition system to formally model, are not beyond the scope of things that should seriously be considered when writing code that could have the kinds of sweeping effects hinted at by this example.  File: gcl.info, Node: cerror, Next: check-type, Prev: error, Up: Conditions Dictionary 9.2.12 cerror [Function] ------------------------ 'cerror' continue-format-control datum &rest arguments => nil Arguments and Values:: ...................... Continue-format-control--a format control. [Reviewer Note by Barmar: What is continue-format-control used for??] datum, arguments--designators for a condition of default type simple-error. Description:: ............. cerror effectively invokes error on the condition named by datum. As with any function that implicitly calls error, if the condition is not handled, (invoke-debugger condition) is executed. While signaling is going on, and while in the debugger if it is reached, it is possible to continue code execution (i.e., to return from cerror) using the continue restart. If datum is a condition, arguments can be supplied, but are used only in conjunction with the continue-format-control. Examples:: .......... (defun real-sqrt (n) (when (minusp n) (setq n (- n)) (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n)) (sqrt n)) (real-sqrt 4) => 2.0 (real-sqrt -9) |> Correctable error in REAL-SQRT: Tried to take sqrt(-9). |> Restart options: |> 1: Return sqrt(9) instead. |> 2: Top level. |> Debug> |>>:continue 1<<| => 3.0 (define-condition not-a-number (error) ((argument :reader not-a-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a number." (not-a-number-argument condition))))) (defun assure-number (n) (loop (when (numberp n) (return n)) (cerror "Enter a number." 'not-a-number :argument n) (format t "~&Type a number: ") (setq n (read)) (fresh-line))) (assure-number 'a) |> Correctable error in ASSURE-NUMBER: A is not a number. |> Restart options: |> 1: Enter a number. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Type a number: |>>1/2<<| => 1/2 (defun assure-large-number (n) (loop (when (and (numberp n) (> n 73)) (return n)) (cerror "Enter a number~:[~; a bit larger than ~D~]." "~*~A is not a large number." (numberp n) n) (format t "~&Type a large number: ") (setq n (read)) (fresh-line))) (assure-large-number 10000) => 10000 (assure-large-number 'a) |> Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. |> Restart options: |> 1: Enter a number. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Type a large number: |>>88<<| => 88 (assure-large-number 37) |> Correctable error in ASSURE-LARGE-NUMBER: 37 is not a large number. |> Restart options: |> 1: Enter a number a bit larger than 37. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Type a large number: |>>259<<| => 259 (define-condition not-a-large-number (error) ((argument :reader not-a-large-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a large number." (not-a-large-number-argument condition))))) (defun assure-large-number (n) (loop (when (and (numberp n) (> n 73)) (return n)) (cerror "Enter a number~3*~:[~; a bit larger than ~*~D~]." 'not-a-large-number :argument n :ignore (numberp n) :ignore n :allow-other-keys t) (format t "~&Type a large number: ") (setq n (read)) (fresh-line))) (assure-large-number 'a) |> Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. |> Restart options: |> 1: Enter a number. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Type a large number: |>>88<<| => 88 (assure-large-number 37) |> Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. |> Restart options: |> 1: Enter a number a bit larger than 37. |> 2: Top level. |> Debug> |>>:continue 1<<| |> Type a large number: |>>259<<| => 259 Affected By:: ............. *break-on-signals*. Existing handler bindings. See Also:: .......... *note error:: , *note format:: , *note handler-bind:: , *break-on-signals*, simple-type-error Notes:: ....... If datum is a condition type rather than a string, the format directive ~* may be especially useful in the continue-format-control in order to ignore the keywords in the initialization argument list. For example: (cerror "enter a new value to replace ~*~s" 'not-a-number :argument a)  File: gcl.info, Node: check-type, Next: simple-error, Prev: cerror, Up: Conditions Dictionary 9.2.13 check-type [Macro] ------------------------- 'check-type' place typespec [string] => nil Arguments and Values:: ...................... place--a place. typespec--a type specifier. string--a string; evaluated. Description:: ............. check-type signals a correctable error of type type-error if the contents of place are not of the type typespec. check-type can return only if the store-value restart is invoked, either explicitly from a handler or implicitly as one of the options offered by the debugger. If the store-value restart is invoked, check-type stores the new value that is the argument to the restart invocation (or that is prompted for interactively by the debugger) in place and starts over, checking the type of the new value and signaling another error if it is still not of the desired type. The first time place is evaluated, it is evaluated by normal evaluation rules. It is later evaluated as a place if the type check fails and the store-value restart is used; see *note Evaluation of Subforms to Places::. string should be an English description of the type, starting with an indefinite article ("a" or "an"). If string is not supplied, it is computed automatically from typespec. The automatically generated message mentions place, its contents, and the desired type. An implementation may choose to generate a somewhat differently worded error message if it recognizes that place is of a particular form, such as one of the arguments to the function that called check-type. string is allowed because some applications of check-type may require a more specific description of what is wanted than can be generated automatically from typespec. Examples:: .......... (setq aardvarks '(sam harry fred)) => (SAM HARRY FRED) (check-type aardvarks (array * (3))) |> Error: The value of AARDVARKS, (SAM HARRY FRED), |> is not a 3-long array. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Return to Lisp Toplevel. |> Debug> |>>:CONTINUE 1<<| |> Use Value: |>>#(SAM FRED HARRY)<<| => NIL aardvarks => # (map 'list #'identity aardvarks) => (SAM FRED HARRY) (setq aardvark-count 'foo) => FOO (check-type aardvark-count (integer 0 *) "A positive integer") |> Error: The value of AARDVARK-COUNT, FOO, is not a positive integer. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Top level. |> Debug> |>>:CONTINUE 2<<| (defmacro define-adder (name amount) (check-type name (and symbol (not null)) "a name for an adder function") (check-type amount integer) `(defun ,name (x) (+ x ,amount))) (macroexpand '(define-adder add3 3)) => (defun add3 (x) (+ x 3)) (macroexpand '(define-adder 7 7)) |> Error: The value of NAME, 7, is not a name for an adder function. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Top level. |> Debug> |>>:Continue 1<<| |> Specify a value to use instead. |> Type a form to be evaluated and used instead: |>>'ADD7<<| => (defun add7 (x) (+ x 7)) (macroexpand '(define-adder add5 something)) |> Error: The value of AMOUNT, SOMETHING, is not an integer. |> To continue, type :CONTINUE followed by an option number: |> 1: Specify a value to use instead. |> 2: Top level. |> Debug> |>>:Continue 1<<| |> Type a form to be evaluated and used instead: |>>5<<| => (defun add5 (x) (+ x 5)) Control is transferred to a handler. Side Effects:: .............. The debugger might be entered. Affected By:: ............. *break-on-signals* The implementation. See Also:: .......... *note Condition System Concepts:: Notes:: ....... (check-type place typespec) == (assert (typep place 'typespec) (place) 'type-error :datum place :expected-type 'typespec)  File: gcl.info, Node: simple-error, Next: invalid-method-error, Prev: check-type, Up: Conditions Dictionary 9.2.14 simple-error [Condition Type] ------------------------------------ Class Precedence List:: ....................... simple-error, simple-condition, error, serious-condition, condition, t Description:: ............. The type simple-error consists of conditions that are signaled by error or cerror when a format control is supplied as the function's first argument.  File: gcl.info, Node: invalid-method-error, Next: method-combination-error, Prev: simple-error, Up: Conditions Dictionary 9.2.15 invalid-method-error [Function] -------------------------------------- 'invalid-method-error' method format-control &rest args => implementation-dependent Arguments and Values:: ...................... method--a method. format-control--a format control. args--format arguments for the format-control. Description:: ............. The function invalid-method-error is used to signal an error of type error when there is an applicable method whose qualifiers are not valid for the method combination type. The error message is constructed by using the format-control suitable for format and any args to it. Because an implementation may need to add additional contextual information to the error message, invalid-method-error should be called only within the dynamic extent of a method combination function. The function invalid-method-error is called automatically when a method fails to satisfy every qualifier pattern and predicate in a define-method-combination form. A method combination function that imposes additional restrictions should call invalid-method-error explicitly if it encounters a method it cannot accept. Whether invalid-method-error returns to its caller or exits via throw is implementation-dependent. Side Effects:: .............. The debugger might be entered. Affected By:: ............. *break-on-signals* See Also:: .......... *note define-method-combination::  File: gcl.info, Node: method-combination-error, Next: signal, Prev: invalid-method-error, Up: Conditions Dictionary 9.2.16 method-combination-error [Function] ------------------------------------------ 'method-combination-error' format-control &rest args => implementation-dependent Arguments and Values:: ...................... format-control--a format control. args--format arguments for format-control. Description:: ............. The function method-combination-error is used to signal an error in method combination. The error message is constructed by using a format-control suitable for format and any args to it. Because an implementation may need to add additional contextual information to the error message, method-combination-error should be called only within the dynamic extent of a method combination function. Whether method-combination-error returns to its caller or exits via throw is implementation-dependent. Side Effects:: .............. The debugger might be entered. Affected By:: ............. *break-on-signals* See Also:: .......... *note define-method-combination::  File: gcl.info, Node: signal, Next: simple-condition, Prev: method-combination-error, Up: Conditions Dictionary 9.2.17 signal [Function] ------------------------ 'signal' datum &rest arguments => nil Arguments and Values:: ...................... datum, arguments--designators for a condition of default type simple-condition. Description:: ............. Signals the condition denoted by the given datum and arguments. If the condition is not handled, signal returns nil. Examples:: .......... (defun handle-division-conditions (condition) (format t "Considering condition for division condition handling~ (when (and (typep condition 'arithmetic-error) (eq '/ (arithmetic-error-operation condition))) (invoke-debugger condition))) HANDLE-DIVISION-CONDITIONS (defun handle-other-arithmetic-errors (condition) (format t "Considering condition for arithmetic condition handling~ (when (typep condition 'arithmetic-error) (abort))) HANDLE-OTHER-ARITHMETIC-ERRORS (define-condition a-condition-with-no-handler (condition) ()) A-CONDITION-WITH-NO-HANDLER (signal 'a-condition-with-no-handler) NIL (handler-bind ((condition #'handle-division-conditions) (condition #'handle-other-arithmetic-errors)) (signal 'a-condition-with-no-handler)) Considering condition for division condition handling Considering condition for arithmetic condition handling NIL (handler-bind ((arithmetic-error #'handle-division-conditions) (arithmetic-error #'handle-other-arithmetic-errors)) (signal 'arithmetic-error :operation '* :operands '(1.2 b))) Considering condition for division condition handling Considering condition for arithmetic condition handling Back to Lisp Toplevel Side Effects:: .............. The debugger might be entered due to *break-on-signals*. Handlers for the condition being signaled might transfer control. Affected By:: ............. Existing handler bindings. *break-on-signals* See Also:: .......... *break-on-signals*, *note error:: , simple-condition, *note Signaling and Handling Conditions:: Notes:: ....... If (typep datum *break-on-signals*) yields true, the debugger is entered prior to beginning the signaling process. The continue restart can be used to continue with the signaling process. This is also true for all other functions and macros that should, might, or must signal conditions.  File: gcl.info, Node: simple-condition, Next: simple-condition-format-control, Prev: signal, Up: Conditions Dictionary 9.2.18 simple-condition [Condition Type] ---------------------------------------- Class Precedence List:: ....................... simple-condition, condition, t Description:: ............. The type simple-condition represents conditions that are signaled by signal whenever a format-control is supplied as the function's first argument. The format control and format arguments are initialized with the initialization arguments named :format-control and :format-arguments to make-condition, and are accessed by the functions simple-condition-format-control and simple-condition-format-arguments. If format arguments are not supplied to make-condition, nil is used as a default. See Also:: .......... *note simple-condition-format-control:: , simple-condition-format-arguments  File: gcl.info, Node: simple-condition-format-control, Next: warn, Prev: simple-condition, Up: Conditions Dictionary 9.2.19 simple-condition-format-control, simple-condition-format-arguments ------------------------------------------------------------------------- [Function] 'simple-condition-format-control' condition => format-control 'simple-condition-format-arguments' condition => format-arguments Arguments and Values:: ...................... condition--a condition of type simple-condition. format-control--a format control. format-arguments--a list. Description:: ............. simple-condition-format-control returns the format control needed to process the condition's format arguments. simple-condition-format-arguments returns a list of format arguments needed to process the condition's format control. Examples:: .......... (setq foo (make-condition 'simple-condition :format-control "Hi ~S" :format-arguments '(ho))) => # (apply #'format nil (simple-condition-format-control foo) (simple-condition-format-arguments foo)) => "Hi HO" See Also:: .......... *note simple-condition:: , *note Condition System Concepts::  File: gcl.info, Node: warn, Next: simple-warning, Prev: simple-condition-format-control, Up: Conditions Dictionary 9.2.20 warn [Function] ---------------------- 'warn' datum &rest arguments => nil Arguments and Values:: ...................... datum, arguments--designators for a condition of default type simple-warning. Description:: ............. Signals a condition of type warning. If the condition is not handled, reports the condition to error output. The precise mechanism for warning is as follows: The warning condition is signaled While the warning condition is being signaled, the muffle-warning restart is established for use by a handler. If invoked, this restart bypasses further action by warn, which in turn causes warn to immediately return nil. If no handler for the warning condition is found If no handlers for the warning condition are found, or if all such handlers decline, then the condition is reported to error output by warn in an implementation-dependent format. nil is returned The value returned by warn if it returns is nil. Examples:: .......... (defun foo (x) (let ((result (* x 2))) (if (not (typep result 'fixnum)) (warn "You're using very big numbers.")) result)) => FOO (foo 3) => 6 (foo most-positive-fixnum) |> Warning: You're using very big numbers. => 4294967294 (setq *break-on-signals* t) => T (foo most-positive-fixnum) |> Break: Caveat emptor. |> To continue, type :CONTINUE followed by an option number. |> 1: Return from Break. |> 2: Abort to Lisp Toplevel. |> Debug> :continue 1 |> Warning: You're using very big numbers. => 4294967294 Side Effects:: .............. A warning is issued. The debugger might be entered. Affected By:: ............. Existing handler bindings. *break-on-signals*, *error-output*. Exceptional Situations:: ........................ If datum is a condition and if the condition is not of type warning, or arguments is non-nil, an error of type type-error is signaled. If datum is a condition type, the result of (apply #'make-condition datum arguments) must be of type warning or an error of type type-error is signaled. See Also:: .......... *break-on-signals*, *note muffle-warning:: , *note signal::  File: gcl.info, Node: simple-warning, Next: invoke-debugger, Prev: warn, Up: Conditions Dictionary 9.2.21 simple-warning [Condition Type] -------------------------------------- Class Precedence List:: ....................... simple-warning, simple-condition, warning, condition, t Description:: ............. The type simple-warning represents conditions that are signaled by warn whenever a format control is supplied as the function's first argument.  File: gcl.info, Node: invoke-debugger, Next: break, Prev: simple-warning, Up: Conditions Dictionary 9.2.22 invoke-debugger [Function] --------------------------------- 'invoke-debugger' condition => # Arguments and Values:: ...................... condition--a condition object. Description:: ............. invoke-debugger attempts to enter the debugger with condition. If *debugger-hook* is not nil, it should be a function (or the name of a function) to be called prior to entry to the standard debugger. The function is called with *debugger-hook* bound to nil, and the function must accept two arguments: the condition and the value of *debugger-hook* prior to binding it to nil. If the function returns normally, the standard debugger is entered. The standard debugger never directly returns. Return can occur only by a non-local transfer of control, such as the use of a restart function. Examples:: .......... (ignore-errors ;Normally, this would suppress debugger entry (handler-bind ((error #'invoke-debugger)) ;But this forces debugger entry (error "Foo."))) Debug: Foo. To continue, type :CONTINUE followed by an option number: 1: Return to Lisp Toplevel. Debug> Side Effects:: .............. *debugger-hook* is bound to nil, program execution is discontinued, and the debugger is entered. Affected By:: ............. *debug-io* and *debugger-hook*. See Also:: .......... *note error:: , *note break::  File: gcl.info, Node: break, Next: *debugger-hook*, Prev: invoke-debugger, Up: Conditions Dictionary 9.2.23 break [Function] ----------------------- 'break' &optional format-control &rest format-arguments => nil Arguments and Values:: ...................... format-control--a format control. The default is implementation-dependent. format-arguments--format arguments for the format-control. Description:: ............. break formats format-control and format-arguments and then goes directly into the debugger without allowing any possibility of interception by programmed error-handling facilities. If the continue restart is used while in the debugger, break immediately returns nil without taking any unusual recovery action. break binds *debugger-hook* to nil before attempting to enter the debugger. Examples:: .......... (break "You got here with arguments: ~:S." '(FOO 37 A)) |> BREAK: You got here with these arguments: FOO, 37, A. |> To continue, type :CONTINUE followed by an option number: |> 1: Return from BREAK. |> 2: Top level. |> Debug> :CONTINUE 1 |> Return from BREAK. => NIL Side Effects:: .............. The debugger is entered. Affected By:: ............. *debug-io*. See Also:: .......... *note error:: , *note invoke-debugger:: . Notes:: ....... break is used as a way of inserting temporary debugging "breakpoints" in a program, not as a way of signaling errors. For this reason, break does not take the continue-format-control argument that cerror takes. This and the lack of any possibility of interception by condition handling are the only program-visible differences between break and cerror. The user interface aspects of break and cerror are permitted to vary more widely, in order to accomodate the interface needs of the implementation. For example, it is permissible for a Lisp read-eval-print loop to be entered by break rather than the conventional debugger. break could be defined by: (defun break (&optional (format-control "Break") &rest format-arguments) (with-simple-restart (continue "Return from BREAK.") (let ((*debugger-hook* nil)) (invoke-debugger (make-condition 'simple-condition :format-control format-control :format-arguments format-arguments)))) nil)  File: gcl.info, Node: *debugger-hook*, Next: *break-on-signals*, Prev: break, Up: Conditions Dictionary 9.2.24 *debugger-hook* [Variable] --------------------------------- Value Type:: ............ a designator for a function of two arguments (a condition and the value of *debugger-hook* at the time the debugger was entered), or nil. Initial Value:: ............... nil. Description:: ............. When the value of *debugger-hook* is non-nil, it is called prior to normal entry into the debugger, either due to a call to invoke-debugger or due to automatic entry into the debugger from a call to error or cerror with a condition that is not handled. The function may either handle the condition (transfer control) or return normally (allowing the standard debugger to run). To minimize recursive errors while debugging, *debugger-hook* is bound to nil by invoke-debugger prior to calling the function. Examples:: .......... (defun one-of (choices &optional (prompt "Choice")) (let ((n (length choices)) (i)) (do ((c choices (cdr c)) (i 1 (+ i 1))) ((null c)) (format t "~&[~D] ~A~ (do () ((typep i `(integer 1 ,n))) (format t "~&~A: " prompt) (setq i (read)) (fresh-line)) (nth (- i 1) choices))) (defun my-debugger (condition me-or-my-encapsulation) (format t "~&Fooey: ~A" condition) (let ((restart (one-of (compute-restarts)))) (if (not restart) (error "My debugger got an error.")) (let ((*debugger-hook* me-or-my-encapsulation)) (invoke-restart-interactively restart)))) (let ((*debugger-hook* #'my-debugger)) (+ 3 'a)) |> Fooey: The argument to +, A, is not a number. |> [1] Supply a replacement for A. |> [2] Return to Cloe Toplevel. |> Choice: 1 |> Form to evaluate and use: (+ 5 'b) |> Fooey: The argument to +, B, is not a number. |> [1] Supply a replacement for B. |> [2] Supply a replacement for A. |> [3] Return to Cloe Toplevel. |> Choice: 1 |> Form to evaluate and use: 1 => 9 Affected By:: ............. invoke-debugger Notes:: ....... When evaluating code typed in by the user interactively, it is sometimes useful to have the hook function bind *debugger-hook* to the function that was its second argument so that recursive errors can be handled using the same interactive facility.  File: gcl.info, Node: *break-on-signals*, Next: handler-bind, Prev: *debugger-hook*, Up: Conditions Dictionary 9.2.25 *break-on-signals* [Variable] ------------------------------------ Value Type:: ............ a type specifier. Initial Value:: ............... nil. Description:: ............. When (typep condition *break-on-signals*) returns true, calls to signal, and to other operators such as error that implicitly call signal, enter the debugger prior to signaling the condition. The continue restart can be used to continue with the normal signaling process when a break occurs process due to *break-on-signals*. Examples:: .......... *break-on-signals* => NIL (ignore-errors (error 'simple-error :format-control "Fooey!")) => NIL, # (let ((*break-on-signals* 'error)) (ignore-errors (error 'simple-error :format-control "Fooey!"))) |> Break: Fooey! |> BREAK entered because of *BREAK-ON-SIGNALS*. |> To continue, type :CONTINUE followed by an option number: |> 1: Continue to signal. |> 2: Top level. |> Debug> |>>:CONTINUE 1<<| |> Continue to signal. => NIL, # (let ((*break-on-signals* 'error)) (error 'simple-error :format-control "Fooey!")) |> Break: Fooey! |> BREAK entered because of *BREAK-ON-SIGNALS*. |> To continue, type :CONTINUE followed by an option number: |> 1: Continue to signal. |> 2: Top level. |> Debug> |>>:CONTINUE 1<<| |> Continue to signal. |> Error: Fooey! |> To continue, type :CONTINUE followed by an option number: |> 1: Top level. |> Debug> |>>:CONTINUE 1<<| |> Top level. See Also:: .......... *note break:: , *note signal:: , *note warn:: , *note error:: , *note typep:: , *note Condition System Concepts:: Notes:: ....... *break-on-signals* is intended primarily for use in debugging code that does signaling. When setting *break-on-signals*, the user is encouraged to choose the most restrictive specification that suffices. Setting *break-on-signals* effectively violates the modular handling of condition signaling. In practice, the complete effect of setting *break-on-signals* might be unpredictable in some cases since the user might not be aware of the variety or number of calls to signal that are used in code called only incidentally. *break-on-signals* enables an early entry to the debugger but such an entry does not preclude an additional entry to the debugger in the case of operations such as error and cerror.  File: gcl.info, Node: handler-bind, Next: handler-case, Prev: *break-on-signals*, Up: Conditions Dictionary 9.2.26 handler-bind [Macro] --------------------------- 'handler-bind' ({!binding}*) {form}* => {result}* binding ::=(type handler) Arguments and Values:: ...................... type--a type specifier. handler--a form; evaluated to produce a handler-function. handler-function--a designator for a function of one argument. forms--an implicit progn. results--the values returned by the forms. Description:: ............. Executes forms in a dynamic environment where the indicated handler bindings are in effect. Each handler should evaluate to a handler-function, which is used to handle conditions of the given type during execution of the forms. This function should take a single argument, the condition being signaled. If more than one handler binding is supplied, the handler bindings are searched sequentially from top to bottom in search of a match (by visual analogy with typecase). If an appropriate type is found, the associated handler is run in a dynamic environment where none of these handler bindings are visible (to avoid recursive errors). If the handler declines, the search continues for another handler. If no appropriate handler is found, other handlers are sought from dynamically enclosing contours. If no handler is found outside, then signal returns or error enters the debugger. Examples:: .......... In the following code, if an unbound variable error is signaled in the body (and not handled by an intervening handler), the first function is called. (handler-bind ((unbound-variable #'(lambda ...)) (error #'(lambda ...))) ...) If any other kind of error is signaled, the second function is called. In either case, neither handler is active while executing the code in the associated function. (defun trap-error-handler (condition) (format *error-output* "~&~A~&" condition) (throw 'trap-errors nil)) (defmacro trap-errors (&rest forms) `(catch 'trap-errors (handler-bind ((error #'trap-error-handler)) ,@forms))) (list (trap-errors (signal "Foo.") 1) (trap-errors (error "Bar.") 2) (+ 1 2)) |> Bar. => (1 NIL 3) Note that "Foo." is not printed because the condition made by signal is a simple condition, which is not of type error, so it doesn't trigger the handler for error set up by trap-errors. See Also:: .......... *note handler-case::  File: gcl.info, Node: handler-case, Next: ignore-errors, Prev: handler-bind, Up: Conditions Dictionary 9.2.27 handler-case [Macro] --------------------------- 'handler-case' expression [[{!error-clause}* | !no-error-clause]] => {result}* clause ::=!error-clause | !no-error-clause error-clause ::=(typespec ([var]) {declaration}* {form}*) no-error-clause ::=(:no-error lambda-list {declaration}* {form}*) Arguments and Values:: ...................... expression--a form. typespec--a type specifier. var--a variable name. lambda-list--an ordinary lambda list. declaration--a declare expression; not evaluated. form--a form. results--In the normal situation, the values returned are those that result from the evaluation of expression; in the exceptional situation when control is transferred to a clause, the value of the last form in that clause is returned. Description:: ............. handler-case executes expression in a dynamic environment where various handlers are active. Each error-clause specifies how to handle a condition matching the indicated typespec. A no-error-clause allows the specification of a particular action if control returns normally. If a condition is signaled for which there is an appropriate error-clause during the execution of expression (i.e., one for which (typep condition 'typespec) returns true) and if there is no intervening handler for a condition of that type, then control is transferred to the body of the relevant error-clause. In this case, the dynamic state is unwound appropriately (so that the handlers established around the expression are no longer active), and var is bound to the condition that had been signaled. If more than one case is provided, those cases are made accessible in parallel. That is, in (handler-case form (typespec1 (var1) form1) (typespec2 (var2) form2)) if the first clause (containing form1) has been selected, the handler for the second is no longer visible (or vice versa). The clauses are searched sequentially from top to bottom. If there is type overlap between typespecs, the earlier of the clauses is selected. If var is not needed, it can be omitted. That is, a clause such as: (typespec (var) (declare (ignore var)) form) can be written (typespec () form). If there are no forms in a selected clause, the case, and therefore handler-case, returns nil. If execution of expression returns normally and no no-error-clause exists, the values returned by expression are returned by handler-case. If execution of expression returns normally and a no-error-clause does exist, the values returned are used as arguments to the function described by constructing (lambda lambda-list {form}*) from the no-error-clause, and the values of that function call are returned by handler-case. The handlers which were established around the expression are no longer active at the time of this call. Examples:: .......... (defun assess-condition (condition) (handler-case (signal condition) (warning () "Lots of smoke, but no fire.") ((or arithmetic-error control-error cell-error stream-error) (condition) (format nil "~S looks especially bad." condition)) (serious-condition (condition) (format nil "~S looks serious." condition)) (condition () "Hardly worth mentioning."))) => ASSESS-CONDITION (assess-condition (make-condition 'stream-error :stream *terminal-io*)) => "# looks especially bad." (define-condition random-condition (condition) () (:report (lambda (condition stream) (declare (ignore condition)) (princ "Yow" stream)))) => RANDOM-CONDITION (assess-condition (make-condition 'random-condition)) => "Hardly worth mentioning." See Also:: .......... *note handler-bind:: , *note ignore-errors:: , *note Condition System Concepts:: Notes:: ....... (handler-case form (type1 (var1) . body1) (type2 (var2) . body2) ...) is approximately equivalent to: (block #1=#:g0001 (let ((#2=#:g0002 nil)) (tagbody (handler-bind ((type1 #'(lambda (temp) (setq #1# temp) (go #3=#:g0003))) (type2 #'(lambda (temp) (setq #2# temp) (go #4=#:g0004))) ...) (return-from #1# form)) #3# (return-from #1# (let ((var1 #2#)) . body1)) #4# (return-from #1# (let ((var2 #2#)) . body2)) ...))) (handler-case form (type1 (var1) . body1) ... (:no-error (varN-1 varN-2 ...) . bodyN)) is approximately equivalent to: (block #1=#:error-return (multiple-value-call #'(lambda (varN-1 varN-2 ...) . bodyN) (block #2=#:normal-return (return-from #1# (handler-case (return-from #2# form) (type1 (var1) . body1) ...))))) gcl-2.6.14/info/io.texi0000755000175000017500000005643014360276512013243 0ustar cammcamm@node Streams and Reading, Special Forms and Functions, Lists, Top @chapter Streams and Reading @defun MAKE-ECHO-STREAM (input-stream output-stream) Package:LISP Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM. In addition, all input is echoed to OUTPUT-STREAM. @end defun @defvar *READTABLE* Package:LISP The current readtable. @end defvar @defun LOAD (filename &key (verbose *load-verbose*) (print nil) (if-does-not-exist :error)) Package:LISP Loads the file named by FILENAME into GCL. @end defun @defun OPEN (filename &key (direction :input) (element-type 'string-char) (if-exists :error) (if-does-not-exist :error)) Package:LISP Opens the file specified by FILENAME, which may be a string, a pathname, or a stream. Returns a stream for the open file. DIRECTION is :INPUT, :OUTPUT, :IO or :PROBE. ELEMENT-TYPE is STRING-CHAR, (UNSIGNED-BYTE n), UNSIGNED-BYTE, (SIGNED-BYTE n), SIGNED-BYTE, CHARACTER, BIT, (MOD n), or :DEFAULT. IF-EXISTS is :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE, or NIL. IF-DOES-NOT-EXIST is :ERROR, :CREATE, or NIL. If FILENAME begins with a vertical pipe sign: '|' then the resulting stream is actually a one way pipe. It will be open for reading or writing depending on the direction given. The rest of FILENAME in this case is passed to the /bin/sh command. See the posix description of popen for more details. @example (setq pipe (open "| wc < /tmp/jim")) (format t "File has ~%d lines" (read pipe)) (close pipe) @end example @end defun @defvar *PRINT-BASE* Package:LISP The radix in which the GCL printer prints integers and rationals. The value must be an integer from 2 to 36, inclusive. @end defvar @defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) Package:LISP Returns an input stream which will supply the characters of String between Start and End in order. @end defun @defun PPRINT (object &optional (stream *standard-output*)) Package:LISP Pretty-prints OBJECT. Returns OBJECT. Equivalent to (WRITE :STREAM STREAM :PRETTY T) The SI:PRETTY-PRINT-FORMAT property N (which must be a non-negative integer) of a symbol SYMBOL controls the pretty-printing of form (SYMBOL f1 ... fN fN+1 ... fM) in such a way that the subforms fN+1, ..., fM are regarded as the 'body' of the entire form. For instance, the property value of 2 is initially given to the symbol DO. @end defun @defvar *READ-DEFAULT-FLOAT-FORMAT* Package:LISP The floating-point format the GCL reader uses when reading floating-point numbers that have no exponent marker or have e or E for an exponent marker. Must be one of SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, and LONG-FLOAT. @end defvar @defun READ-PRESERVING-WHITESPACE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Reads an object from STREAM, preserving the whitespace that followed the object. @end defun @defun STREAMP (x) Package:LISP Returns T if X is a stream object; NIL otherwise. @end defun @defun SET-DISPATCH-MACRO-CHARACTER (disp-char sub-char function &optional (readtable *readtable*)) Package:LISP Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is read. @end defun @deffn {Macro} WITH-OUTPUT-TO-STRING Package:LISP Syntax: @example (with-output-to-string (var [string]) @{decl@}* @{form@}*) @end example Binds VAR to a string output stream that puts characters into STRING, which defaults to a new string. The stream is automatically closed on exit and the string is returned. @end deffn @defun FILE-LENGTH (file-stream) Package:LISP Returns the length of the specified file stream. @end defun @defvar *PRINT-CASE* Package:LISP The case in which the GCL printer should print ordinary symbols. The value must be one of the keywords :UPCASE, :DOWNCASE, and :CAPITALIZE. @end defvar @defun PRINT (object &optional (stream *standard-output*)) Package:LISP Outputs a newline character, and then prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (PROGN (TERPRI STREAM) (WRITE OBJECT :STREAM STREAM :ESCAPE T)). @end defun @defun SET-MACRO-CHARACTER (char function &optional (non-terminating-p nil) (readtable *readtable*)) Package:LISP Causes CHAR to be a macro character that, when seen by READ, causes FUNCTION to be called. @end defun @defun FORCE-OUTPUT (&optional (stream *standard-output*)) Package:LISP Attempts to force any buffered output to be sent. @end defun @defvar *PRINT-ARRAY* Package:LISP Whether the GCL printer should print array elements. @end defvar @defun STREAM-ELEMENT-TYPE (stream) Package:LISP Returns a type specifier for the kind of object returned by STREAM. @end defun @defun WRITE-BYTE (integer stream) Package:LISP Outputs INTEGER to the binary stream STREAM. Returns INTEGER. @end defun @defun MAKE-CONCATENATED-STREAM (&rest streams) Package:LISP Returns a stream which takes its input from each of the STREAMs in turn, going on to the next at end of stream. @end defun @defun PRIN1 (object &optional (stream *standard-output*)) Package:LISP Prints OBJECT in the mostly readable representation. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE T). @end defun @defun PRINC (object &optional (stream *standard-output*)) Package:LISP Prints OBJECT without escape characters. Returns OBJECT. Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE NIL). @end defun @defun CLEAR-OUTPUT (&optional (stream *standard-output*)) Package:LISP Clears the output stream STREAM. @end defun @defun TERPRI (&optional (stream *standard-output*)) Package:LISP Outputs a newline character. @end defun @defun FINISH-OUTPUT (&optional (stream *standard-output*)) Package:LISP Attempts to ensure that all output sent to STREAM has reached its destination, and only then returns. @end defun @deffn {Macro} WITH-OPEN-FILE Package:LISP Syntax: @example (with-open-file (stream filename @{options@}*) @{decl@}* @{form@}*) @end example Opens the file whose name is FILENAME, using OPTIONs, and binds the variable STREAM to a stream to/from the file. Then evaluates FORMs as a PROGN. The file is automatically closed on exit. @end deffn @deffn {Special Form} DO Package:LISP Syntax: @example (do (@{(var [init [step]])@}*) (endtest @{result@}*) @{decl@}* @{tag | statement@}*) @end example Creates a NIL block, binds each VAR to the value of the corresponding INIT, and then executes STATEMENTs repeatedly until ENDTEST is satisfied. After each iteration, assigns to each VAR the value of the corresponding STEP. When ENDTEST is satisfied, evaluates RESULTs as a PROGN and returns the value(s) of the last RESULT (or NIL if no RESULTs are supplied). Performs variable bindings and assignments all at once, just like LET and PSETQ do. @end deffn @defun READ-FROM-STRING (string &optional (eof-error-p t) (eof-value nil) &key (start 0) (end (length string)) (preserve-whitespace nil)) Package:LISP Reads an object from STRING. @end defun @defun WRITE-STRING (string &optional (stream *standard-output*) &key (start 0) (end (length string))) Package:LISP Outputs STRING and returns it. @end defun @defvar *PRINT-LEVEL* Package:LISP How many levels deep the GCL printer should print. Unlimited if NIL. @end defvar @defvar *PRINT-RADIX* Package:LISP Whether the GCL printer should print the radix indicator when printing integers and rationals. @end defvar @defun Y-OR-N-P (&optional (format-string nil) &rest args) Package:LISP Asks the user a question whose answer is either 'Y' or 'N'. If FORMAT-STRING is non-NIL, then FRESH-LINE operation is performed, a message is printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt "(Y or N)" is printed. Otherwise, no prompt will appear. @end defun @defun MAKE-BROADCAST-STREAM (&rest streams) Package:LISP Returns an output stream which sends its output to all of the given streams. @end defun @defun READ-CHAR (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Reads a character from STREAM. @end defun @defun PEEK-CHAR (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Peeks at the next character in the input stream STREAM. @end defun @defun OUTPUT-STREAM-P (stream) Package:LISP Returns non-nil if STREAM can handle output operations; NIL otherwise. @end defun @defvar *QUERY-IO* Package:LISP The query I/O stream. @end defvar @defvar *READ-BASE* Package:LISP The radix that the GCL reader reads numbers in. @end defvar @deffn {Macro} WITH-OPEN-STREAM Package:LISP Syntax: @example (with-open-stream (var stream) @{decl@}* @{form@}*) @end example Evaluates FORMs as a PROGN with VAR bound to the value of STREAM. The stream is automatically closed on exit. @end deffn @deffn {Macro} WITH-INPUT-FROM-STRING Package:LISP Syntax: @example (with-input-from-string (var string @{keyword value@}*) @{decl@}* @{form@}*) @end example Binds VAR to an input stream that returns characters from STRING and evaluates the FORMs. The stream is automatically closed on exit. Allowed keywords are :INDEX, :START, and :END. @end deffn @defun CLEAR-INPUT (&optional (stream *standard-input*)) Package:LISP Clears the input stream STREAM. @end defun @defvar *TERMINAL-IO* Package:LISP The terminal I/O stream. @end defvar @defun LISTEN (&optional (stream *standard-input*)) Package:LISP Returns T if a character is available on STREAM; NIL otherwise. This function does not correctly work in some versions of GCL because of the lack of such mechanism in the underlying operating system. @end defun @defun MAKE-PATHNAME (&key (defaults (parse-namestring "" (pathname-host *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults)) (directory (pathname-directory defaults)) (name (pathname-name defaults)) (type (pathname-type defaults)) (version (pathname-version defaults))) Package:LISP Create a pathname from HOST, DEVICE, DIRECTORY, NAME, TYPE and VERSION. @end defun @defun PATHNAME-TYPE (pathname) Package:LISP Returns the type slot of PATHNAME. @end defun @defvar *PRINT-GENSYM* Package:LISP Whether the GCL printer should prefix symbols with no home package with "#:". @end defvar @defun READ-LINE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Returns a line of text read from STREAM as a string, discarding the newline character. Note that when using line at a time input under unix, input forms will always be followed by a #\newline. Thus if you do >(read-line) "" nil the empty string will be returned. After lisp reads the (read-line) it then invokes (read-line). This happens before it does anything else and so happens before the newline character immediately following (read-line) has been read. Thus read-line immediately encounters a #\newline and so returns the empty string. If there had been other characters before the #\newline it would have been different: >(read-line) how are you " how are you" nil If you want to throw away "" input, you can do that with the following: (sloop::sloop while (equal (setq input (read-line)) "")) You may also want to use character at a time input, but that makes input editing harder. nicolas% stty cbreak nicolas% gcl GCL (GNU Common Lisp) Version(1.1.2) Mon Jan 9 12:58:22 MET 1995 Licensed under GNU Public Library License Contains Enhancements by W. Schelter >(let ((ifilename nil)) (format t "~%Input file name: ") (setq ifilename (read-line))) Input file name: /tmp/myfile "/tmp/myfile" >(bye)Bye. @end defun @defun WRITE-TO-STRING (object &key (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) Package:LISP Returns as a string the printed representation of OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode. @end defun @defun PATHNAMEP (x) Package:LISP Returns T if X is a pathname object; NIL otherwise. @end defun @defun READTABLEP (x) Package:LISP Returns T if X is a readtable object; NIL otherwise. @end defun @defun READ (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) Package:LISP Reads in the next object from STREAM. @end defun @defun NAMESTRING (pathname) Package:LISP Returns the full form of PATHNAME as a string. @end defun @defun UNREAD-CHAR (character &optional (stream *standard-input*)) Package:LISP Puts CHARACTER back on the front of the input stream STREAM. @end defun @defun CLOSE (stream &key (abort nil)) Package:LISP Closes STREAM. A non-NIL value of :ABORT indicates an abnormal termination. @end defun @defvar *PRINT-LENGTH* Package:LISP How many elements the GCL printer should print at each level of nested data object. Unlimited if NIL. @end defvar @defun SET-SYNTAX-FROM-CHAR (to-char from-char &optional (to-readtable *readtable*) (from-readtable nil)) Package:LISP Makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax of FROM-CHAR in FROM-READTABLE. @end defun @defun INPUT-STREAM-P (stream) Package:LISP Returns non-NIL if STREAM can handle input operations; NIL otherwise. @end defun @defun PATHNAME (x) Package:LISP Turns X into a pathname. X may be a string, symbol, stream, or pathname. @end defun @defun FILE-NAMESTRING (pathname) Package:LISP Returns the written representation of PATHNAME as a string. @end defun @defun MAKE-DISPATCH-MACRO-CHARACTER (char &optional (non-terminating-p nil) (readtable *readtable*)) Package:LISP Causes the character CHAR to be a dispatching macro character in READTABLE. @end defun @defvar *STANDARD-OUTPUT* Package:LISP The default output stream used by the GCL printer. @end defvar @defun MAKE-TWO-WAY-STREAM (input-stream output-stream) Package:LISP Returns a bidirectional stream which gets its input from INPUT-STREAM and sends its output to OUTPUT-STREAM. @end defun @defvar *PRINT-ESCAPE* Package:LISP Whether the GCL printer should put escape characters whenever appropriate. @end defvar @defun COPY-READTABLE (&optional (from-readtable *readtable*) (to-readtable nil)) Package:LISP Returns a copy of the readtable FROM-READTABLE. If TO-READTABLE is non-NIL, then copies into TO-READTABLE. Otherwise, creates a new readtable. @end defun @defun DIRECTORY-NAMESTRING (pathname) Package:LISP Returns the directory part of PATHNAME as a string. @end defun @defun TRUENAME (pathname) Package:LISP Returns the pathname for the actual file described by PATHNAME. @end defun @defvar *READ-SUPPRESS* Package:LISP When the value of this variable is NIL, the GCL reader operates normally. When it is non-NIL, then the reader parses input characters but much of what is read is not interpreted. @end defvar @defun GET-DISPATCH-MACRO-CHARACTER (disp-char sub-char &optional (readtable *readtable*)) Package:LISP Returns the macro-character function for SUB-CHAR under DISP-CHAR. @end defun @defun PATHNAME-DEVICE (pathname) Package:LISP Returns the device slot of PATHNAME. @end defun @defun READ-CHAR-NO-HANG (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) Package:LISP Returns the next character from STREAM if one is available; NIL otherwise. @end defun @defun FRESH-LINE (&optional (stream *standard-output*)) Package:LISP Outputs a newline if it is not positioned at the beginning of a line. Returns T if it output a newline; NIL otherwise. @end defun @defun WRITE-CHAR (char &optional (stream *standard-output*)) Package:LISP Outputs CHAR and returns it. @end defun @defun PARSE-NAMESTRING (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) (end (length thing)) (junk-allowed nil)) Package:LISP Parses a string representation of a pathname into a pathname. HOST is ignored. @end defun @defun PATHNAME-DIRECTORY (pathname) Package:LISP Returns the directory slot of PATHNAME. @end defun @defun GET-MACRO-CHARACTER (char &optional (readtable *readtable*)) Package:LISP Returns the function associated with CHAR and, as a second value, returns the non-terminating-p flag. @end defun @defun FORMAT (destination control-string &rest arguments) Package:LISP Provides various facilities for formatting output. DESTINATION controls where the result will go. If DESTINATION is T, then the output is sent to the standard output stream. If it is NIL, then the output is returned in a string as the value of the call. Otherwise, DESTINATION must be a stream to which the output will be sent. CONTROL-STRING is a string to be output, possibly with embedded formatting directives, which are flagged with the escape character "~". Directives generally expand into additional text to be output, usually consuming one or more of ARGUMENTs in the process. A few useful directives are: @example ~A, ~nA, ~n@@A Prints one argument as if by PRINC ~S, ~nS, ~n@@S Prints one argument as if by PRIN1 ~D, ~B, ~O, ~X Prints one integer in decimal, binary, octal, and hexa ~% Does TERPRI ~& Does FRESH-LINE @end example where n is the minimal width of the field in which the object is printed. ~nA and ~nS put padding spaces on the right; ~n@@A and ~n@@S put on the left. @example ~R is for printing numbers in various formats. ~nR prints arg in radix n. ~R prints arg as a cardinal english number: two ~:R prints arg as an ordinal english number: third ~@@R prints arg as an a Roman Numeral: VII ~:@@R prints arg as an old Roman Numeral: IIII ~C prints a character. ~:C represents non printing characters by their pretty names,eg Space ~@@C uses the #\ syntax to allow the reader to read it. ~F prints a floating point number arg. The full form is ~w,d,k,overflowchar,padcharF w represents the total width of the printed representation (variable if not present) d the number of fractional digits to display (format nil "~,2f" 10010.0314) --> "10010.03" k arg is multiplied by 10^k before printing it as a decimal number. overflowchar width w characters copies of the overflow character will be printed. eg(format t "X>~5,2,,'?F X>?????~10,2,1,'?,'bFX>bbb1000.34 "BIL" (format nil "~@@[x = ~d ~]~a" 8) --> "x = 8 BIL" @end example @end defun @defun PATHNAME-NAME (pathname) Package:LISP Returns the name slot of PATHNAME. @end defun @defun MAKE-STRING-OUTPUT-STREAM () Package:LISP Returns an output stream which will accumulate all output given it for the benefit of the function GET-OUTPUT-STREAM-STRING. @end defun @defun MAKE-SYNONYM-STREAM (symbol) Package:LISP Returns a stream which performs its operations on the stream which is the value of the dynamic variable named by SYMBOL. @end defun @defvar *LOAD-VERBOSE* Package:LISP The default for the VERBOSE argument to LOAD. @end defvar @defvar *PRINT-CIRCLE* Package:LISP Whether the GCL printer should take care of circular lists. @end defvar @defvar *PRINT-PRETTY* Package:LISP Whether the GCL printer should pretty-print. See the function doc of PPRINT for more information about pretty-printing. @end defvar @defun FILE-WRITE-DATE (file) Package:LISP Returns the time at which the specified file is written, as an integer in universal time format. FILE may be a string or a stream. @end defun @defun PRIN1-TO-STRING (object) Package:LISP Returns as a string the printed representation of OBJECT in the mostly readable representation. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE T). @end defun @defun MERGE-PATHNAMES (pathname &optional (defaults *default-pathname-defaults*) default-version) Package:LISP Fills in unspecified slots of PATHNAME from DEFAULTS. DEFAULT-VERSION is ignored in GCL. @end defun @defun READ-BYTE (stream &optional (eof-error-p t) (eof-value nil)) Package:LISP Reads the next byte from STREAM. @end defun @defun PRINC-TO-STRING (object) Package:LISP Returns as a string the printed representation of OBJECT without escape characters. Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE NIL). @end defun @defvar *STANDARD-INPUT* Package:LISP The default input stream used by the GCL reader. @end defvar @defun PROBE-FILE (file) Package:LISP Returns the truename of file if the file exists. Returns NIL otherwise. @end defun @defun PATHNAME-VERSION (pathname) Package:LISP Returns the version slot of PATHNAME. @end defun @defun WRITE-LINE (string &optional (stream *standard-output*) &key (start 0) (end (length string))) Package:LISP Outputs STRING and then outputs a newline character. Returns STRING. @end defun @defun WRITE (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) Package:LISP Prints OBJECT in the specified mode. See the variable docs of *PRINT-...* for the mode. @end defun @defun GET-OUTPUT-STREAM-STRING (stream) Package:LISP Returns a string of all the characters sent to STREAM made by MAKE-STRING-OUTPUT-STREAM since the last call to this function. @end defun @defun READ-DELIMITED-LIST (char &optional (stream *standard-input*) (recursive-p nil)) Package:LISP Reads objects from STREAM until the next character after an object's representation is CHAR. Returns a list of the objects read. @end defun @defun READLINE-ON () Package:SI Begins readline command editing mode when possible. In addition to the basic readline editing features, command word completion is implemented according to the following scheme: [[pkg]:[:]]txt pkg -- an optional package specifier. Defaults to the current package. The symbols in this package and those in the packages in this package's use list will be searched. :[:] -- an optional internal/external specifier. Defaults to external. The keyword package is denoted by a single colon at the beginning of the token. Only symbols of this type will be searched for completion. txt -- a string. Symbol names beginning with this string are completed. The comparison is case insensitive. @end defun @defun READLINE-OFF () Package:SI Disables readline command editing mode. @end defun @defvar *READLINE-PREFIX* Package:SI A string implicitly prepended to input text for use in readline command completion. If this string contains one or more colons, it is used to specify the default package and internal/external setting for searched symbols in the case that the supplied text itself contains no explicit package specification. If this string contains characters after the colon(s), or contains no colons at all, it is treated as a symbol name prefix. In this case, the prefix is matched first, then the supplied text, and the completion returned is relative to the supplied text itself, i.e. contains no prefix. For example, the setting ``maxima::$'' will complete input text ``int'' according to the internal symbols in the maxima package of the form ``maxima::$int...'', and return suggestions to the user of the form ``int...''. @end defvar gcl-2.6.14/info/chap-8.texi0000644000175000017500000012421414360276512013705 0ustar cammcamm @node Structures, Conditions, Objects, Top @chapter Structures @menu * Structures Dictionary:: @end menu @node Structures Dictionary, , Structures, Structures @section Structures Dictionary @c including dict-structures @menu * defstruct:: * copy-structure:: @end menu @node defstruct, copy-structure, Structures Dictionary, Structures Dictionary @subsection defstruct [Macro] @code{defstruct} @i{name-and-options @r{[}documentation@r{]} @{!@i{slot-description}@}*}@* @result{} @i{structure-name} @w{@i{name-and-options} ::=structure-name | @r{(}structure-name [[!@i{options}]]@r{)}} @w{@i{options} ::=!@i{conc-name-option} |} @w{ @{!@i{constructor-option}@}* |} @w{ !@i{copier-option} |} @w{ !@i{include-option} |} @w{ !@i{initial-offset-option} |} @w{ !@i{named-option} |} @w{ !@i{predicate-option} |} @w{ !@i{printer-option} |} @w{ !@i{type-option}} @w{@i{conc-name-option} ::=@t{:conc-name} | @r{(}@t{:conc-name}@r{)} | @r{(}@t{:conc-name} @i{conc-name}@r{)}} @w{@i{constructor-option} ::=@t{:constructor} |} @w{ @r{(}@t{:constructor}@r{)} |} @w{ @r{(}@t{:constructor} @i{constructor-name}@r{)} |} @w{ @r{(}@t{:constructor} @i{constructor-name} @i{constructor-arglist}@r{)}} @w{@i{copier-option} ::=@t{:copier} | @r{(}@t{:copier}@r{)} | @r{(}@t{:copier} @i{copier-name}@r{)}} @w{@i{predicate-option} ::=@t{:predicate} | @r{(}@t{:predicate}@r{)} | @r{(}@t{:predicate} @i{predicate-name}@r{)}} @w{@i{include-option} ::=@r{(}@t{:include} @i{included-structure-name} @{!@i{slot-description}@}*@r{)}} @w{@i{printer-option} ::=!@i{print-object-option} | !@i{print-function-option}} @w{@i{print-object-option} ::=@r{(}@t{:print-object} @i{printer-name}@r{)} | @r{(}@t{:print-object}@r{)}} @w{@i{print-function-option} ::=@r{(}@t{:print-function} @i{printer-name}@r{)} | @r{(}@t{:print-function}@r{)}} @w{@i{type-option} ::=@r{(}@t{:type} @i{type}@r{)}} @w{@i{named-option} ::=@t{:named}} @w{@i{initial-offset-option} ::=@r{(}@t{:initial-offset} @i{initial-offset}@r{)}} @w{@i{slot-description} ::=@i{slot-name} | } @w{ @r{(}@i{slot-name} @r{[}@i{slot-initform} [[!@i{slot-option}]]@r{]}@r{)}} @w{@i{slot-option} ::=@t{:type} @i{slot-type} | } @w{ @t{:read-only} @i{slot-read-only-p}} @subsubheading Arguments and Values:: @i{conc-name}---a @i{string designator}. @i{constructor-arglist}---a @i{boa lambda list}. @i{constructor-name}---a @i{symbol}. @i{copier-name}---a @i{symbol}. @i{included-structure-name}---an already-defined @i{structure name}. Note that a @i{derived type} is not permissible, even if it would expand into a @i{structure name}. @i{initial-offset}---a non-negative @i{integer}. @i{predicate-name}---a @i{symbol}. @i{printer-name}---a @i{function name} or a @i{lambda expression}. @i{slot-name}---a @i{symbol}. @i{slot-initform}---a @i{form}. @i{slot-read-only-p}---a @i{generalized boolean}. @i{structure-name}---a @i{symbol}. @i{type}---one of the @i{type specifiers} @b{list}, @b{vector}, or @t{(vector @i{size})}, or some other @i{type specifier} defined by the @i{implementation} to be appropriate. @i{documentation}---a @i{string}; not evaluated. @subsubheading Description:: @b{defstruct} defines a structured @i{type}, named @i{structure-type}, with named slots as specified by the @i{slot-options}. @b{defstruct} defines @i{readers} for the slots and arranges for @b{setf} to work properly on such @i{reader} functions. Also, unless overridden, it defines a predicate named @t{@i{name}-p}, defines a constructor function named @t{make-@i{constructor-name}}, and defines a copier function named @t{copy-@i{constructor-name}}. All names of automatically created functions might automatically be declared @b{inline} (at the discretion of the @i{implementation}). If @i{documentation} is supplied, it is attached to @i{structure-name} as a @i{documentation string} of kind @b{structure}, and unless @t{:type} is used, the @i{documentation} is also attached to @i{structure-name} as a @i{documentation string} of kind @b{type} and as a @i{documentation string} to the @i{class} @i{object} for the @i{class} named @i{structure-name}. @b{defstruct} defines a constructor function that is used to create instances of the structure created by @b{defstruct}. The default name is @t{make-@i{structure-name}}. A different name can be supplied by giving the name as the argument to the @i{constructor} option. @b{nil} indicates that no constructor function will be created. After a new structure type has been defined, instances of that type normally can be created by using the constructor function for the type. A call to a constructor function is of the following form: @w{ (@t{constructor-function-name}}@* @w{ @t{slot-keyword-1 form-1}}@* @w{ @t{slot-keyword-2 form-2}}@* @w{ ...)}@* The arguments to the constructor function are all keyword arguments. Each slot keyword argument must be a keyword whose name corresponds to the name of a structure slot. All the @i{keywords} and @i{forms} are evaluated. If a slot is not initialized in this way, it is initialized by evaluating @i{slot-initform} in the slot description at the time the constructor function is called. If no @i{slot-initform} is supplied, the consequences are undefined if an attempt is later made to read the slot's value before a value is explicitly assigned. Each @i{slot-initform} supplied for a @b{defstruct} component, when used by the constructor function for an otherwise unsupplied component, is re-evaluated on every call to the constructor function. The @i{slot-initform} is not evaluated unless it is needed in the creation of a particular structure instance. If it is never needed, there can be no type-mismatch error, even if the @i{type} of the slot is specified; no warning should be issued in this case. For example, in the following sequence, only the last call is an error. @example (defstruct person (name 007 :type string)) (make-person :name "James") (make-person) @end example It is as if the @i{slot-initforms} were used as @i{initialization forms} for the @i{keyword parameters} of the constructor function. The @i{symbols} which name the slots must not be used by the @i{implementation} as the @i{names} for the @i{lambda variables} in the constructor function, since one or more of those @i{symbols} might have been proclaimed @b{special} or might be defined as the name of a @i{constant variable}. The slot default init forms are evaluated in the @i{lexical environment} in which the @b{defstruct} form itself appears and in the @i{dynamic environment} in which the call to the constructor function appears. For example, if the form @t{(gensym)} were used as an initialization form, either in the constructor-function call or as the default initialization form in @b{defstruct}, then every call to the constructor function would call @b{gensym} once to generate a new @i{symbol}. Each @i{slot-description} in @b{defstruct} can specify zero or more @i{slot-options}. A @i{slot-option} consists of a pair of a keyword and a value (which is not a form to be evaluated, but the value itself). For example: @example (defstruct ship (x-position 0.0 :type short-float) (y-position 0.0 :type short-float) (x-velocity 0.0 :type short-float) (y-velocity 0.0 :type short-float) (mass *default-ship-mass* :type short-float :read-only t)) @end example This specifies that each slot always contains a @i{short float}, and that the last slot cannot be altered once a ship is constructed. The available slot-options are: @table @asis @item @t{:type} @i{type} This specifies that the contents of the slot is always of type @i{type}. This is entirely analogous to the declaration of a variable or function; it effectively declares the result type of the @i{reader} function. It is @i{implementation-dependent} whether the @i{type} is checked when initializing a slot or when assigning to it. @i{Type} is not evaluated; it must be a valid @i{type specifier}. @item @t{:read-only} @i{x} When @i{x} is @i{true}, this specifies that this slot cannot be altered; it will always contain the value supplied at construction time. @b{setf} will not accept the @i{reader} function for this slot. If @i{x} is @i{false}, this slot-option has no effect. @i{X} is not evaluated. When this option is @i{false} or unsupplied, it is @i{implementation-dependent} whether the ability to @i{write} the slot is implemented by a @i{setf function} or a @i{setf expander}. @end table The following keyword options are available for use with @b{defstruct}. A @b{defstruct} option can be either a keyword or a @i{list} of a keyword and arguments for that keyword; specifying the keyword by itself is equivalent to specifying a list consisting of the keyword and no arguments. The syntax for @b{defstruct} options differs from the pair syntax used for slot-options. No part of any of these options is evaluated. @table @asis @item @t{:conc-name} This provides for automatic prefixing of names of @i{reader} (or @i{access}) functions. The default behavior is to begin the names of all the @i{reader} functions of a structure with the name of the structure followed by a hyphen. @t{:conc-name} supplies an alternate prefix to be used. If a hyphen is to be used as a separator, it must be supplied as part of the prefix. If @t{:conc-name} is @b{nil} or no argument is supplied, then no prefix is used; then the names of the @i{reader} functions are the same as the slot names. If a @i{non-nil} prefix is given, the name of the @i{reader} @i{function} for each slot is constructed by concatenating that prefix and the name of the slot, and interning the resulting @i{symbol} in the @i{package} that is current at the time the @b{defstruct} form is expanded. Note that no matter what is supplied for @t{:conc-name}, slot keywords that match the slot names with no prefix attached are used with a constructor function. The @i{reader} function name is used in conjunction with @b{setf}. Here is an example: @example (defstruct (door (:conc-name dr-)) knob-color width material) @result{} DOOR (setq my-door (make-door :knob-color 'red :width 5.0)) @result{} #S(DOOR :KNOB-COLOR RED :WIDTH 5.0 :MATERIAL NIL) (dr-width my-door) @result{} 5.0 (setf (dr-width my-door) 43.7) @result{} 43.7 (dr-width my-door) @result{} 43.7 @end example Whether or not the @t{:conc-name} option is explicitly supplied, the following rule governs name conflicts of generated @i{reader} (or @i{accessor}) names: For any @i{structure} @i{type} S_1 having a @i{reader} function named R for a slot named X_1 that is inherited by another @i{structure} @i{type} S_2 that would have a @i{reader} function with the same name R for a slot named X_2, no definition for R is generated by the definition of S_2; instead, the definition of R is inherited from the definition of S_1. (In such a case, if X_1 and X_2 are different slots, the @i{implementation} might signal a style warning.) @item @t{:constructor} This option takes zero, one, or two arguments. If at least one argument is supplied and the first argument is not @b{nil}, then that argument is a @i{symbol} which specifies the name of the constructor function. If the argument is not supplied (or if the option itself is not supplied), the name of the constructor is produced by concatenating the string @t{"MAKE-"} and the name of the structure, interning the name in whatever @i{package} is current at the time @b{defstruct} is expanded. If the argument is provided and is @b{nil}, no constructor function is defined. If @t{:constructor} is given as @t{(:constructor @i{name} @i{arglist})}, then instead of making a keyword driven constructor function, @b{defstruct} defines a ``positional'' constructor function, taking arguments whose meaning is determined by the argument's position and possibly by keywords. @i{Arglist} is used to describe what the arguments to the constructor will be. In the simplest case something like @t{(:constructor make-foo (a b c))} defines @t{make-foo} to be a three-argument constructor function whose arguments are used to initialize the slots named @t{a}, @t{b}, and @t{c}. Because a constructor of this type operates ``By Order of Arguments,'' it is sometimes known as a ``boa constructor.'' For information on how the @i{arglist} for a ``boa constructor'' is processed, see @ref{Boa Lambda Lists}. It is permissible to use the @t{:constructor} option more than once, so that you can define several different constructor functions, each taking different parameters. [Reviewer Note by Barmar: What about (:constructor) and (:constructor nil). Should we worry about it?] @b{defstruct} creates the default-named keyword constructor function only if no explicit @t{:constructor} options are specified, or if the @t{:constructor} option is specified without a @i{name} argument. @t{(:constructor nil)} is meaningful only when there are no other @t{:constructor} options specified. It prevents @b{defstruct} from generating any constructors at all. Otherwise, @b{defstruct} creates a constructor function corresponding to each supplied @t{:constructor} option. It is permissible to specify multiple keyword constructor functions as well as multiple ``boa constructors''. @item @t{:copier} This option takes one argument, a @i{symbol}, which specifies the name of the copier function. If the argument is not provided or if the option itself is not provided, the name of the copier is produced by concatenating the string @t{"COPY-"} and the name of the structure, interning the name in whatever @i{package} is current at the time @b{defstruct} is expanded. If the argument is provided and is @b{nil}, no copier function is defined. The automatically defined copier function is a function of one @i{argument}, which must be of the structure type being defined. The copier function creates a @i{fresh} structure that has the same @i{type} as its @i{argument}, and that has the @i{same} component values as the original structure; that is, the component values are not copied recursively. If the @b{defstruct} @t{:type} option was not used, the following equivalence applies: @example (@i{copier-name} x) = (copy-structure (the @i{structure-name} x)) @end example @item @t{:include} This option is used for building a new structure definition as an extension of another structure definition. For example: @example (defstruct person name age sex) @end example To make a new structure to represent an astronaut that has the attributes of name, age, and sex, and @i{functions} that operate on @t{person} structures, @t{astronaut} is defined with @t{:include} as follows: @example (defstruct (astronaut (:include person) (:conc-name astro-)) helmet-size (favorite-beverage 'tang)) @end example @t{:include} causes the structure being defined to have the same slots as the included structure. This is done in such a way that the @i{reader} functions for the included structure also work on the structure being defined. In this example, an @t{astronaut} therefore has five slots: the three defined in @t{person} and the two defined in @t{astronaut} itself. The @i{reader} functions defined by the @t{person} structure can be applied to instances of the @t{astronaut} structure, and they work correctly. Moreover, @t{astronaut} has its own @i{reader} functions for components defined by the @t{person} structure. The following examples illustrate the use of @t{astronaut} structures: @example (setq x (make-astronaut :name 'buzz :age 45. :sex t :helmet-size 17.5)) (person-name x) @result{} BUZZ (astro-name x) @result{} BUZZ (astro-favorite-beverage x) @result{} TANG @end example @example (reduce #'+ astros :key #'person-age) ; obtains the total of the ages ; of the possibly empty ; sequence of astros @end example The difference between the @i{reader} functions @t{person-name} and @t{astro-name} is that @t{person-name} can be correctly applied to any @t{person}, including an @t{astronaut}, while @t{astro-name} can be correctly applied only to an @t{astronaut}. An implementation might check for incorrect use of @i{reader} functions. At most one @t{:include} can be supplied in a single @b{defstruct}. The argument to @t{:include} is required and must be the name of some previously defined structure. If the structure being defined has no @t{:type} option, then the included structure must also have had no @t{:type} option supplied for it. If the structure being defined has a @t{:type} option, then the included structure must have been declared with a @t{:type} option specifying the same representation @i{type}. If no @t{:type} option is involved, then the structure name of the including structure definition becomes the name of a @i{data type}, and therefore a valid @i{type specifier} recognizable by @b{typep}; it becomes a @i{subtype} of the included structure. In the above example, @t{astronaut} is a @i{subtype} of @t{person}; hence @example (typep (make-astronaut) 'person) @result{} @i{true} @end example indicating that all operations on persons also work on astronauts. The structure using @t{:include} can specify default values or slot-options for the included slots different from those the included structure specifies, by giving the @t{:include} option as: @example (:include @i{included-structure-name} @{@i{slot-description}@}*) @end example Each @i{slot-description} must have a @i{slot-name} that is the same as that of some slot in the included structure. If a @i{slot-description} has no @i{slot-initform}, then in the new structure the slot has no initial value. Otherwise its initial value form is replaced by the @i{slot-initform} in the @i{slot-description}. A normally writable slot can be made read-only. If a slot is read-only in the included structure, then it must also be so in the including structure. If a @i{type} is supplied for a slot, it must be a @i{subtype} of the @i{type} specified in the included structure. For example, if the default age for an astronaut is @t{45}, then @example (defstruct (astronaut (:include person (age 45))) helmet-size (favorite-beverage 'tang)) @end example If @t{:include} is used with the @t{:type} option, then the effect is first to skip over as many representation elements as needed to represent the included structure, then to skip over any additional elements supplied by the @t{:initial-offset} option, and then to begin allocation of elements from that point. For example: @example (defstruct (binop (:type list) :named (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) @result{} BINOP (defstruct (annotated-binop (:type list) (:initial-offset 3) (:include binop)) commutative associative identity) @result{} ANNOTATED-BINOP (make-annotated-binop :operator '* :operand-1 'x :operand-2 5 :commutative t :associative t :identity 1) @result{} (NIL NIL BINOP * X 5 NIL NIL NIL T T 1) @end example The first two @b{nil} elements stem from the @t{:initial-offset} of @t{2} in the definition of @t{binop}. The next four elements contain the structure name and three slots for @t{binop}. The next three @b{nil} elements stem from the @t{:initial-offset} of @t{3} in the definition of @t{annotated-binop}. The last three list elements contain the additional slots for an @t{annotated-binop}. @item @t{:initial-offset} @t{:initial-offset} instructs @b{defstruct} to skip over a certain number of slots before it starts allocating the slots described in the body. This option's argument is the number of slots @b{defstruct} should skip. @t{:initial-offset} can be used only if @t{:type} is also supplied. [Reviewer Note by Barmar: What are initial values of the skipped slots?] @t{:initial-offset} allows slots to be allocated beginning at a representational element other than the first. For example, the form @example (defstruct (binop (:type list) (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) @result{} BINOP @end example would result in the following behavior for @t{make-binop}: @example (make-binop :operator '+ :operand-1 'x :operand-2 5) @result{} (NIL NIL + X 5) (make-binop :operand-2 4 :operator '*) @result{} (NIL NIL * NIL 4) @end example The selector functions @t{binop-operator}, @t{binop-operand-1}, and @t{binop-operand-2} would be essentially equivalent to @b{third}, @b{fourth}, and @b{fifth}, respectively. Similarly, the form @example (defstruct (binop (:type list) :named (:initial-offset 2)) (operator '? :type symbol) operand-1 operand-2) @result{} BINOP @end example would result in the following behavior for @t{make-binop}: @example (make-binop :operator '+ :operand-1 'x :operand-2 5) @result{} (NIL NIL BINOP + X 5) (make-binop :operand-2 4 :operator '*) @result{} (NIL NIL BINOP * NIL 4) @end example The first two @b{nil} elements stem from the @t{:initial-offset} of @t{2} in the definition of @t{binop}. The next four elements contain the structure name and three slots for @t{binop}. @item @t{:named} @t{:named} specifies that the structure is named. If no @t{:type} is supplied, then the structure is always named. For example: @example (defstruct (binop (:type list)) (operator '? :type symbol) operand-1 operand-2) @result{} BINOP @end example This defines a constructor function @t{make-binop} and three selector functions, namely @t{binop-operator}, @t{binop-operand-1}, and @t{binop-operand-2}. (It does not, however, define a predicate @t{binop-p}, for reasons explained below.) The effect of @t{make-binop} is simply to construct a list of length three: @example (make-binop :operator '+ :operand-1 'x :operand-2 5) @result{} (+ X 5) (make-binop :operand-2 4 :operator '*) @result{} (* NIL 4) @end example It is just like the function @t{list} except that it takes keyword arguments and performs slot defaulting appropriate to the @t{binop} conceptual data type. Similarly, the selector functions @t{binop-operator}, @t{binop-operand-1}, and @t{binop-operand-2} are essentially equivalent to @b{car}, @b{cadr}, and @b{caddr}, respectively. They might not be completely equivalent because, for example, an implementation would be justified in adding error-checking code to ensure that the argument to each selector function is a length-3 list. @t{binop} is a conceptual data type in that it is not made a part of the @r{Common Lisp} type system. @b{typep} does not recognize @t{binop} as a @i{type specifier}, and @b{type-of} returns @t{list} when given a @t{binop} structure. There is no way to distinguish a data structure constructed by @t{make-binop} from any other @i{list} that happens to have the correct structure. There is not any way to recover the structure name @t{binop} from a structure created by @t{make-binop}. This can only be done if the structure is named. A named structure has the property that, given an instance of the structure, the structure name (that names the type) can be reliably recovered. For structures defined with no @t{:type} option, the structure name actually becomes part of the @r{Common Lisp} data-type system. @b{type-of}, when applied to such a structure, returns the structure name as the @i{type} of the @i{object}; @b{typep} recognizes the structure name as a valid @i{type specifier}. For structures defined with a @t{:type} option, @b{type-of} returns a @i{type specifier} such as @t{list} or @t{(vector t)}, depending on the type supplied to the @t{:type} option. The structure name does not become a valid @i{type specifier}. However, if the @t{:named} option is also supplied, then the first component of the structure (as created by a @b{defstruct} constructor function) always contains the structure name. This allows the structure name to be recovered from an instance of the structure and allows a reasonable predicate for the conceptual type to be defined: the automatically defined @i{name-p} predicate for the structure operates by first checking that its argument is of the proper type (@b{list}, @t{(vector t)}, or whatever) and then checking whether the first component contains the appropriate type name. Consider the @t{binop} example shown above, modified only to include the @t{:named} option: @example (defstruct (binop (:type list) :named) (operator '? :type symbol) operand-1 operand-2) @result{} BINOP @end example As before, this defines a constructor function @t{make-binop} and three selector functions @t{binop-operator}, @t{binop-operand-1}, and @t{binop-operand-2}. It also defines a predicate @t{binop-p}. The effect of @t{make-binop} is now to construct a list of length four: @example (make-binop :operator '+ :operand-1 'x :operand-2 5) @result{} (BINOP + X 5) (make-binop :operand-2 4 :operator '*) @result{} (BINOP * NIL 4) @end example The structure has the same layout as before except that the structure name @t{binop} is included as the first list element. The selector functions @t{binop-operator}, @t{binop-operand-1}, and @t{binop-operand-2} are essentially equivalent to @b{cadr}, @b{caddr}, and @b{cadddr}, respectively. The predicate @t{binop-p} is more or less equivalent to this definition: @example (defun binop-p (x) (and (consp x) (eq (car x) 'binop))) @result{} BINOP-P @end example The name @t{binop} is still not a valid @i{type specifier} recognizable to @b{typep}, but at least there is a way of distinguishing @t{binop} structures from other similarly defined structures. @item @t{:predicate} This option takes one argument, which specifies the name of the type predicate. If the argument is not supplied or if the option itself is not supplied, the name of the predicate is made by concatenating the name of the structure to the string @t{"-P"}, interning the name in whatever @i{package} is current at the time @b{defstruct} is expanded. If the argument is provided and is @b{nil}, no predicate is defined. A predicate can be defined only if the structure is named; if @t{:type} is supplied and @t{:named} is not supplied, then @t{:predicate} must either be unsupplied or have the value @b{nil}. @item @t{:print-function}, @t{:print-object} The @t{:print-function} and @t{:print-object} options specify that a @b{print-object} @i{method} for @i{structures} of type @i{structure-name} should be generated. These options are not synonyms, but do perform a similar service; the choice of which option (@t{:print-function} or @t{:print-object}) is used affects how the function named @i{printer-name} is called. Only one of these options may be used, and these options may be used only if @t{:type} is not supplied. If the @t{:print-function} option is used, then when a structure of type @i{structure-name} is to be printed, the designated printer function is called on three @i{arguments}: @table @asis @item -- the structure to be printed (a @i{generalized instance} of @i{structure-name}). @item -- a @i{stream} to print to. @item -- an @i{integer} indicating the current depth. The magnitude of this integer may vary between @i{implementations}; however, it can reliably be compared against @b{*print-level*} to determine whether depth abbreviation is appropriate. @end table Specifying @t{(:print-function @i{printer-name})} is approximately equivalent to specifying: @example (defmethod print-object ((object @i{structure-name}) stream) (funcall (function @i{printer-name}) object stream <<@i{current-print-depth}>>)) @end example where the <<@i{current-print-depth}>> represents the printer's belief of how deep it is currently printing. It is @i{implementation-dependent} whether <<@i{current-print-depth}>> is always 0 and @i{*print-level*}, if @i{non-nil}, is re-bound to successively smaller values as printing descends recursively, or whether @i{current-print-depth} varies in value as printing descends recursively and @i{*print-level*} remains constant during the same traversal. If the @t{:print-object} option is used, then when a structure of type @i{structure-name} is to be printed, the designated printer function is called on two arguments: @table @asis @item -- the structure to be printed. @item -- the stream to print to. @end table Specifying @t{(:print-object @i{printer-name})} is equivalent to specifying: @example (defmethod print-object ((object @i{structure-name}) stream) (funcall (function @i{printer-name}) object stream)) @end example If no @t{:type} option is supplied, and if either a @t{:print-function} or a @t{:print-object} option is supplied, and if no @i{printer-name} is supplied, then a @b{print-object} @i{method} @i{specialized} for @i{structure-name} is generated that calls a function that implements the default printing behavior for structures using @t{#S} notation; see @ref{Printing Structures}. If neither a @t{:print-function} nor a @t{:print-object} option is supplied, then @b{defstruct} does not generate a @b{print-object} @i{method} @i{specialized} for @i{structure-name} and some default behavior is inherited either from a structure named in an @t{:include} option or from the default behavior for printing structures; see the @i{function} @b{print-object} and @ref{Printing Structures}. When @b{*print-circle*} is @i{true}, a user-defined print function can print @i{objects} to the supplied @i{stream} using @b{write}, @b{prin1}, @b{princ}, or @b{format} and expect circularities to be detected and printed using the @t{#@i{n}#} syntax. This applies to @i{methods} on @b{print-object} in addition to @t{:print-function} options. If a user-defined print function prints to a @i{stream} other than the one that was supplied, then circularity detection starts over for that @i{stream}. See the @i{variable} @b{*print-circle*}. @item @t{:type} @t{:type} explicitly specifies the representation to be used for the structure. Its argument must be one of these @i{types}: @table @asis @item @b{vector} This produces the same result as specifying @t{(vector t)}. The structure is represented as a general @i{vector}, storing components as vector elements. The first component is vector element 1 if the structure is @t{:named}, and element 0 otherwise. [Reviewer Note by Barmar: Do any implementations create non-simple vectors?] @item @t{(vector @i{element-type})} The structure is represented as a (possibly specialized) @i{vector}, storing components as vector elements. Every component must be of a @i{type} that can be stored in a @i{vector} of the @i{type} specified. The first component is vector element 1 if the structure is @t{:named}, and element 0 otherwise. The structure can be @t{:named} only if the @i{type} @b{symbol} is a @i{subtype} of the supplied @i{element-type}. @item @b{list} The structure is represented as a @i{list}. The first component is the @i{cadr} if the structure is @t{:named}, and the @i{car} if it is not @t{:named}. @end table Specifying this option has the effect of forcing a specific representation and of forcing the components to be stored in the order specified in @b{defstruct} in corresponding successive elements of the specified representation. It also prevents the structure name from becoming a valid @i{type specifier} recognizable by @b{typep}. For example: @example (defstruct (quux (:type list) :named) x y) @end example should make a constructor that builds a @i{list} exactly like the one that @b{list} produces, with @t{quux} as its @i{car}. If this type is defined: @example (deftype quux () '(satisfies quux-p)) @end example then this form @example (typep (make-quux) 'quux) @end example should return precisely what this one does @example (typep (list 'quux nil nil) 'quux) @end example If @t{:type} is not supplied, the structure is represented as an @i{object} of @i{type} @b{structure-object}. @b{defstruct} without a @t{:type} option defines a @i{class} with the structure name as its name. The @i{metaclass} of structure @i{instances} is @b{structure-class}. @end table The consequences of redefining a @b{defstruct} structure are undefined. In the case where no @b{defstruct} options have been supplied, the following functions are automatically defined to operate on instances of the new structure: @table @asis @item Predicate A predicate with the name @t{@i{structure-name}-p} is defined to test membership in the structure type. The predicate @t{(@i{structure-name}-p @i{object})} is @i{true} if an @i{object} is of this @i{type}; otherwise it is @i{false}. @b{typep} can also be used with the name of the new @i{type} to test whether an @i{object} belongs to the @i{type}. Such a function call has the form @t{(typep @i{object} '@i{structure-name})}. @item Component reader functions @i{Reader} functions are defined to @i{read} the components of the structure. For each slot name, there is a corresponding @i{reader} function with the name @t{@i{structure-name}-@i{slot-name}}. This function @i{reads} the contents of that slot. Each @i{reader} function takes one argument, which is an instance of the structure type. @b{setf} can be used with any of these @i{reader} functions to alter the slot contents. @item Constructor function A constructor function with the name @t{make-@i{structure-name}} is defined. This function creates and returns new instances of the structure type. @item Copier function A copier function with the name @t{copy-@i{structure-name}} is defined. The copier function takes an object of the structure type and creates a new object of the same type that is a copy of the first. The copier function creates a new structure with the same component entries as the original. Corresponding components of the two structure instances are @b{eql}. @end table If a @b{defstruct} @i{form} appears as a @i{top level form}, the @i{compiler} must make the @i{structure} @i{type} name recognized as a valid @i{type} name in subsequent declarations (as for @b{deftype}) and make the structure slot readers known to @b{setf}. In addition, the @i{compiler} must save enough information about the @i{structure} @i{type} so that further @b{defstruct} definitions can use @t{:include} in a subsequent @b{deftype} in the same @i{file} to refer to the @i{structure} @i{type} name. The functions which @b{defstruct} generates are not defined in the compile time environment, although the @i{compiler} may save enough information about the functions to code subsequent calls inline. The @t{#S} @i{reader macro} might or might not recognize the newly defined @i{structure} @i{type} name at compile time. @subsubheading Examples:: An example of a structure definition follows: @example (defstruct ship x-position y-position x-velocity y-velocity mass) @end example This declares that every @t{ship} is an @i{object} with five named components. The evaluation of this form does the following: @table @asis @item 1. It defines @t{ship-x-position} to be a function of one argument, a ship, that returns the @t{x-position} of the ship; @t{ship-y-position} and the other components are given similar function definitions. These functions are called the @i{access} functions, as they are used to @i{access} elements of the structure. @item 2. @t{ship} becomes the name of a @i{type} of which instances of ships are elements. @t{ship} becomes acceptable to @b{typep}, for example; @t{(typep x 'ship)} is @i{true} if @t{x} is a ship and false if @t{x} is any @i{object} other than a ship. @item 3. A function named @t{ship-p} of one argument is defined; it is a predicate that is @i{true} if its argument is a ship and is @i{false} otherwise. @item 4. A function called @t{make-ship} is defined that, when invoked, creates a data structure with five components, suitable for use with the @i{access} functions. Thus executing @example (setq ship2 (make-ship)) @end example sets @t{ship2} to a newly created @t{ship} @i{object}. One can supply the initial values of any desired component in the call to @t{make-ship} by using keyword arguments in this way: @example (setq ship2 (make-ship :mass *default-ship-mass* :x-position 0 :y-position 0)) @end example This constructs a new ship and initializes three of its components. This function is called the ``constructor function'' because it constructs a new structure. @item 5. A function called @t{copy-ship} of one argument is defined that, when given a @t{ship} @i{object}, creates a new @t{ship} @i{object} that is a copy of the given one. This function is called the ``copier function.'' @end table @b{setf} can be used to alter the components of a @t{ship}: @example (setf (ship-x-position ship2) 100) @end example This alters the @t{x-position} of @t{ship2} to be @t{100}. This works because @b{defstruct} behaves as if it generates an appropriate @b{defsetf} for each @i{access} function. @example ;;; ;;; Example 1 ;;; define town structure type ;;; area, watertowers, firetrucks, population, elevation are its components ;;; (defstruct town area watertowers (firetrucks 1 :type fixnum) ;an initialized slot population (elevation 5128 :read-only t)) ;a slot that can't be changed @result{} TOWN ;create a town instance (setq town1 (make-town :area 0 :watertowers 0)) @result{} #S(TOWN...) ;town's predicate recognizes the new instance (town-p town1) @result{} @i{true} ;new town's area is as specified by make-town (town-area town1) @result{} 0 ;new town's elevation has initial value (town-elevation town1) @result{} 5128 ;setf recognizes reader function (setf (town-population town1) 99) @result{} 99 (town-population town1) @result{} 99 ;copier function makes a copy of town1 (setq town2 (copy-town town1)) @result{} #S(TOWN...) (= (town-population town1) (town-population town2)) @result{} @i{true} ;since elevation is a read-only slot, its value can be set only ;when the structure is created (setq town3 (make-town :area 0 :watertowers 3 :elevation 1200)) @result{} #S(TOWN...) ;;; ;;; Example 2 ;;; define clown structure type ;;; this structure uses a nonstandard prefix ;;; (defstruct (clown (:conc-name bozo-)) (nose-color 'red) frizzy-hair-p polkadots) @result{} CLOWN (setq funny-clown (make-clown)) @result{} #S(CLOWN) ;use non-default reader name (bozo-nose-color funny-clown) @result{} RED (defstruct (klown (:constructor make-up-klown) ;similar def using other (:copier clone-klown) ;customizing keywords (:predicate is-a-bozo-p)) nose-color frizzy-hair-p polkadots) @result{} klown ;custom constructor now exists (fboundp 'make-up-klown) @result{} @i{true} ;;; ;;; Example 3 ;;; define a vehicle structure type ;;; then define a truck structure type that includes ;;; the vehicle structure ;;; (defstruct vehicle name year (diesel t :read-only t)) @result{} VEHICLE (defstruct (truck (:include vehicle (year 79))) load-limit (axles 6)) @result{} TRUCK (setq x (make-truck :name 'mac :diesel t :load-limit 17)) @result{} #S(TRUCK...) ;vehicle readers work on trucks (vehicle-name x) @result{} MAC ;default taken from :include clause (vehicle-year x) @result{} 79 (defstruct (pickup (:include truck)) ;pickup type includes truck camper long-bed four-wheel-drive) @result{} PICKUP (setq x (make-pickup :name 'king :long-bed t)) @result{} #S(PICKUP...) ;:include default inherited (pickup-year x) @result{} 79 ;;; ;;; Example 4 ;;; use of BOA constructors ;;; (defstruct (dfs-boa ;BOA constructors (:constructor make-dfs-boa (a b c)) (:constructor create-dfs-boa (a &optional b (c 'cc) &rest d &aux e (f 'ff)))) a b c d e f) @result{} DFS-BOA ;a, b, and c set by position, and the rest are uninitialized (setq x (make-dfs-boa 1 2 3)) @result{} #(DFS-BOA...) (dfs-boa-a x) @result{} 1 ;a and b set, c and f defaulted (setq x (create-dfs-boa 1 2)) @result{} #(DFS-BOA...) (dfs-boa-b x) @result{} 2 (eq (dfs-boa-c x) 'cc) @result{} @i{true} ;a, b, and c set, and the rest are collected into d (setq x (create-dfs-boa 1 2 3 4 5 6)) @result{} #(DFS-BOA...) (dfs-boa-d x) @result{} (4 5 6) @end example @subsubheading Exceptional Situations:: If any two slot names (whether present directly or inherited by the @t{:include} option) are the @i{same} under @b{string=}, @b{defstruct} should signal an error of @i{type} @b{program-error}. The consequences are undefined if the @i{included-structure-name} does not name a @i{structure type}. @subsubheading See Also:: @ref{documentation} , @ref{print-object} , @ref{setf} , @ref{subtypep} , @ref{type-of} , @ref{typep} , @ref{Compilation} @subsubheading Notes:: The @i{printer-name} should observe the values of such printer-control variables as @b{*print-escape*}. The restriction against issuing a warning for type mismatches between a @i{slot-initform} and the corresponding slot's @t{:type} option is necessary because a @i{slot-initform} must be specified in order to specify slot options; in some cases, no suitable default may exist. The mechanism by which @b{defstruct} arranges for slot accessors to be usable with @b{setf} is @i{implementation-dependent}; for example, it may use @i{setf functions}, @i{setf expanders}, or some other @i{implementation-dependent} mechanism known to that @i{implementation}'s @i{code} for @b{setf}. @node copy-structure, , defstruct, Structures Dictionary @subsection copy-structure [Function] @code{copy-structure} @i{structure} @result{} @i{copy} @subsubheading Arguments and Values:: @i{structure}---a @i{structure}. @i{copy}---a copy of the @i{structure}. @subsubheading Description:: Returns a @i{copy}_6 of the @i{structure}. Only the @i{structure} itself is copied; not the values of the slots. @subsubheading See Also:: the @t{:copier} option to @ref{defstruct} @subsubheading Notes:: The @i{copy} is the @i{same} as the given @i{structure} under @b{equalp}, but not under @b{equal}. @c end of including dict-structures @c %**end of chapter gcl-2.6.14/info/gcl/0000755000175000017500000000000014360276512012473 5ustar cammcammgcl-2.6.14/info/gcl/Hash-Tables.html0000644000175000017500000000436014360276512015457 0ustar cammcamm Hash Tables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

18 Hash Tables

• Hash Table Concepts  
• Hash Tables Dictionary  
gcl-2.6.14/info/gcl/alphanumericp.html0000644000175000017500000001014514360276512016212 0ustar cammcamm alphanumericp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.9 alphanumericp [Function]

alphanumericp character ⇒ generalized-boolean

Arguments and Values::

character—a character.

generalized-boolean—a generalized boolean.

Description::

Returns true if character is an alphabetic_1 character or a numeric character; otherwise, returns false.

Examples::

 (alphanumericp #\Z) ⇒  true
 (alphanumericp #\9) ⇒  true
 (alphanumericp #\Newline) ⇒  false
 (alphanumericp #\#) ⇒  false

Affected By::

None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.)

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

alpha-char-p , graphic-char-p , digit-char-p

Notes::

Alphanumeric characters are graphic as defined by graphic-char-p. The alphanumeric characters are a subset of the graphic characters. The standard characters A through Z, a through z, and 0 through 9 are alphanumeric characters. 

 (alphanumericp x)
   ≡ (or (alpha-char-p x) (not (null (digit-char-p x))))
gcl-2.6.14/info/gcl/intersection.html0000644000175000017500000001666214360276512016102 0ustar cammcamm intersection (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.43 intersection, nintersection [Function]

intersection list-1 list-2 &key key test test-not ⇒ result-list

nintersection list-1 list-2 &key key test test-not ⇒ result-list

Arguments and Values::

list-1—a proper list.

list-2—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

result-list—a list.

Description::

intersection and nintersection return a list that contains every element that occurs in both list-1 and list-2.

nintersection is the destructive version of intersection. It performs the same operation, but may destroy list-1 using its cells to construct the result.

list-2 is not destroyed.

The intersection operation is described as follows. For all possible ordered pairs consisting of one element from list-1 and one element from list-2, :test or :test-not are used to determine whether they satisfy the test. The first argument to the :test or :test-not function is an element of list-1; the second argument is an element of list-2. If :test or :test-not is not supplied, eql is used. It is an error if :test and :test-not are supplied in the same function call.

If :key is supplied (and not nil), it is used to extract the part to be tested from the list element. The argument to the :key function is an element of either list-1 or list-2; the :key function typically returns part of the supplied element. If :key is not supplied or nil, the list-1 and list-2 elements are used.

For every pair that satifies the test, exactly one of the two elements of the pair will be put in the result. No element from either list appears in the result that does not satisfy the test for an element from the other list. If one of the lists contains duplicate elements, there may be duplication in the result.

There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result list may share cells with, or be eq to, either list-1 or list-2 if appropriate.

Examples::

 (setq list1 (list 1 1 2 3 4 a b c "A" "B" "C" "d")
       list2 (list 1 4 5 b c d "a" "B" "c" "D")) 
  ⇒  (1 4 5 B C D "a" "B" "c" "D")
 (intersection list1 list2) ⇒  (C B 4 1 1)
 (intersection list1 list2 :test 'equal) ⇒  ("B" C B 4 1 1)
 (intersection list1 list2 :test #'equalp) ⇒  ("d" "C" "B" "A" C B 4 1 1) 
 (nintersection list1 list2) ⇒  (1 1 4 B C)
 list1 ⇒  implementation-dependent ;e.g., (1 1 4 B C)
 list2 ⇒  implementation-dependent ;e.g., (1 4 5 B C D "a" "B" "c" "D")
 (setq list1 (copy-list '((1 . 2) (2 . 3) (3 . 4) (4 . 5))))
⇒  ((1 . 2) (2 . 3) (3 . 4) (4 . 5)) 
 (setq list2 (copy-list '((1 . 3) (2 . 4) (3 . 6) (4 . 8))))
⇒  ((1 . 3) (2 . 4) (3 . 6) (4 . 8)) 
 (nintersection list1 list2 :key #'cdr) ⇒  ((2 . 3) (3 . 4)) 
 list1 ⇒  implementation-dependent ;e.g., ((1 . 2) (2 . 3) (3 . 4)) 
 list2 ⇒  implementation-dependent ;e.g., ((1 . 3) (2 . 4) (3 . 6) (4 . 8))

Side Effects::

nintersection can modify list-1,

but not list-2.

Exceptional Situations::

Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists.

See Also::

union ,

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Since the nintersection side effect is not required, it should not be used in for-effect-only positions in portable code.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Examples-of-Inheritance.html0000644000175000017500000000576514360276512020005 0ustar cammcamm Examples of Inheritance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Inheritance  

4.3.4.1 Examples of Inheritance

 (defclass C1 () 
     ((S1 :initform 5.4 :type number) 
      (S2 :allocation :class)))

 (defclass C2 (C1) 
     ((S1 :initform 5 :type integer)
      (S2 :allocation :instance)
      (S3 :accessor C2-S3)))

Instances of the class C1 have a local slot named S1, whose default initial value is 5.4 and whose value should always be a number. The class C1 also has a shared slot named S2.

There is a local slot named S1 in instances of C2. The default initial value of S1 is 5. The value of S1 should always be of type (and integer number). There are also local slots named S2 and S3 in instances of C2. The class C2 has a method for C2-S3 for reading the value of slot S3; there is also a method for (setf C2-S3) that writes the value of S3.

gcl-2.6.14/info/gcl/simple_002dbase_002dstring.html0000644000175000017500000000651214360276512020212 0ustar cammcamm simple-base-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.4 simple-base-string [Type]

Supertypes::

simple-base-string, base-string, simple-string, string, vector, simple-array, array, sequence, t

Description::

The type simple-base-string is equivalent to

(simple-array base-char (*)).

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(simple-base-string{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *.

Compound Type Specifier Description::

This is equivalent to the type (simple-array base-char (size)); that is, the set of simple base strings of size size.

gcl-2.6.14/info/gcl/package_002dused_002dby_002dlist.html0000644000175000017500000000646714360276512021100 0ustar cammcamm package-used-by-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.26 package-used-by-list [Function]

package-used-by-list package ⇒ used-by-list

Arguments and Values::

package—a package designator.

used-by-list—a list of package objects.

Description::

package-used-by-list returns a list of other packages that use package.

Examples::

 (package-used-by-list (make-package 'temp)) ⇒  ()
 (make-package 'trash :use '(temp)) ⇒  #<PACKAGE "TRASH">
 (package-used-by-list 'temp) ⇒  (#<PACKAGE "TRASH">)

Exceptional Situations::

Should signal an error of type type-error if package is not a package.

See Also::

use-package , unuse-package

gcl-2.6.14/info/gcl/Introduction-_0028Types-and-Classes_0029.html0000644000175000017500000001155714360276512022433 0ustar cammcamm Introduction (Types and Classes) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes  

4.1 Introduction

A type is a (possibly infinite) set of objects. An object can belong to more than one type. Types are never explicitly represented as objects by Common Lisp. Instead, they are referred to indirectly by the use of type specifiers, which are objects that denote types.

New types can be defined using deftype, defstruct, defclass, and define-condition.

The function typep, a set membership test, is used to determine whether a given object is of a given type. The function subtypep, a subset test, is used to determine whether a given type is a subtype of another given type. The function type-of returns a particular type to which a given object belongs, even though that object must belong to one or more other types as well. (For example, every object is of type t, but type-of always returns a type specifier for a type more specific than t.)

Objects, not variables, have types. Normally, any variable can have any object as its value. It is possible to declare that a variable takes on only values of a given type by making an explicit type declaration. Types are arranged in a directed acyclic graph, except for the presence of equivalences.

Declarations can be made about types using declare, proclaim, declaim, or the. For more information about declarations, see Declarations.

Among the fundamental objects of the object system are classes. A class determines the structure and behavior of a set of other objects, which are called its instances. Every object is a direct instance of a class. The class of an object determines the set of operations that can be performed on the object. For more information, see Classes.

It is possible to write functions that have behavior specialized to the class of the objects which are their arguments. For more information, see Generic Functions and Methods.

The class of the class of an object is called its metaclass . For more information about metaclasses, see Meta-Objects.

Next: , Previous: , Up: Types and Classes  

gcl-2.6.14/info/gcl/Effect-of-Readtable-Case-on-the-Lisp-Printer.html0000644000175000017500000001077514360276512023441 0ustar cammcamm Effect of Readtable Case on the Lisp Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.10 Effect of Readtable Case on the Lisp Printer

When printer escaping is disabled, or the characters under consideration are not already quoted specifically by single escape or multiple escape syntax,

the readtable case of the current readtable affects the way the Lisp printer writes symbols in the following ways:

:upcase

When the readtable case is :upcase, uppercase characters are printed in the case specified by *print-case*, and lowercase characters are printed in their own case.

:downcase

When the readtable case is :downcase, uppercase characters are printed in their own case, and lowercase characters are printed in the case specified by *print-case*.

:preserve

When the readtable case is :preserve, all alphabetic characters are printed in their own case.

:invert

When the readtable case is :invert, the case of all alphabetic characters in single case symbol names is inverted. Mixed-case symbol names are printed as is.

The rules for escaping alphabetic characters in symbol names are affected by the readtable-case

if printer escaping is enabled.

Alphabetic characters are escaped as follows:

:upcase

When the readtable case is :upcase, all lowercase characters must be escaped.

:downcase

When the readtable case is :downcase, all uppercase characters must be escaped.

:preserve

When the readtable case is :preserve, no alphabetic characters need be escaped.

:invert

When the readtable case is :invert, no alphabetic characters need be escaped.

gcl-2.6.14/info/gcl/Examples-of-SUM-clause.html0000644000175000017500000000440714360276512017462 0ustar cammcamm Examples of SUM clause (ANSI and GNU Common Lisp Document)

Previous: , Up: Value Accumulation Clauses  

6.1.3.5 Examples of SUM clause

 (loop for i of-type fixnum in '(1 2 3 4 5)
       sum i)
⇒  15
 (setq series '(1.2 4.3 5.7))
⇒  (1.2 4.3 5.7)
 (loop for v in series 
       sum (* 2.0 v))
⇒  22.4
gcl-2.6.14/info/gcl/Introduction-to-Generic-Functions.html0000644000175000017500000001526014360276512022006 0ustar cammcamm Introduction to Generic Functions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.1 Introduction to Generic Functions

A generic function is a function whose behavior depends on the classes or identities of the arguments supplied to it. A generic function object is associated with a set of methods, a lambda list, a method combination_2, and other information.

Like an ordinary function, a generic function takes arguments, performs a series of operations, and perhaps returns useful values. An ordinary function has a single body of code that is always executed when the function is called. A generic function has a set of bodies of code of which a subset is selected for execution. The selected bodies of code and the manner of their combination are determined by the classes or identities of one or more of the arguments to the generic function and by its method combination.

Ordinary functions and generic functions are called with identical syntax.

Generic functions are true functions that can be passed as arguments and used as the first argument to funcall and apply.

A binding of a function name to a generic function can be established in one of several ways. It can be established in the global environment by ensure-generic-function, defmethod (implicitly, due to ensure-generic-function) or defgeneric (also implicitly, due to ensure-generic-function).

No standardized mechanism is provided for establishing a binding of a function name to a generic function in the lexical environment.

When a defgeneric form is evaluated, one of three actions is taken (due to ensure-generic-function):

*

If a generic function of the given name already exists, the existing generic function object is modified. Methods specified by the current defgeneric form are added, and any methods in the existing generic function that were defined by a previous defgeneric form are removed. Methods added by the current defgeneric form might replace methods defined by defmethod, defclass, define-condition, or defstruct. No other methods in the generic function are affected or replaced.

*

If the given name names an ordinary function, a macro, or a special operator, an error is signaled.

*

Otherwise a generic function is created with the methods specified by the method definitions in the defgeneric form.

Some operators permit specification of the options of a generic function, such as the type of method combination it uses or its argument precedence order. These operators will be referred to as “operators that specify generic function options.”

The only standardized operator in this category is defgeneric.

Some operators define methods for a generic function. These operators will be referred to as method-defining operators ; their associated forms are called method-defining forms. The standardized method-defining operators are listed in Figure 7–2. 

  defgeneric        defmethod  defclass  
  define-condition  defstruct            

  Figure 7–2: Standardized Method-Defining Operators

Note that of the standardized method-defining operators only defgeneric can specify generic function options. defgeneric and any implementation-defined operators that can specify generic function options are also referred to as “operators that specify generic function options.”

Next: , Previous: , Up: Generic Functions and Methods  

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Host-Component.html0000644000175000017500000000510414360276512025224 0ustar cammcamm Restrictions on Examining a Pathname Host Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.13 Restrictions on Examining a Pathname Host Component

It is implementation-dependent what object is used to represent the host.

gcl-2.6.14/info/gcl/remhash.html0000644000175000017500000000611414360276512015012 0ustar cammcamm remhash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.10 remhash [Function]

remhash key hash-table ⇒ generalized-boolean

Arguments and Values::

key—an object.

hash-table—a hash table.

generalized-boolean—a generalized boolean.

Description::

Removes the entry for key in hash-table, if any. Returns true if there was such an entry, or false otherwise.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32115666>
 (setf (gethash 100 table) "C") ⇒  "C"
 (gethash 100 table) ⇒  "C", true
 (remhash 100 table) ⇒  true
 (gethash 100 table) ⇒  NIL, false
 (remhash 100 table) ⇒  false

Side Effects::

The hash-table is modified.

gcl-2.6.14/info/gcl/Reader-Dictionary.html0000644000175000017500000001173214360276512016672 0ustar cammcamm Reader Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Reader  

23.2 Reader Dictionary

• readtable  
• copy-readtable  
• make-dispatch-macro-character  
• read  
• read-delimited-list  
• read-from-string  
• readtable-case  
• readtablep  
• set-dispatch-macro-character  
• set-macro-character  
• set-syntax-from-char  
• with-standard-io-syntax  
• *read-base*  
• *read-default-float-format*  
• *read-eval*  
• *read-suppress*  
• *readtable*  
• reader-error  
gcl-2.6.14/info/gcl/make_002dinstances_002dobsolete.html0000644000175000017500000000765314360276512021230 0ustar cammcamm make-instances-obsolete (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.20 make-instances-obsolete [Standard Generic Function]

Syntax::

make-instances-obsolete class ⇒ class

Method Signatures::

make-instances-obsolete (class standard-class)

make-instances-obsolete (class symbol)

Arguments and Values::

class—a class designator.

Description::

The function make-instances-obsolete has the effect of initiating the process of updating the instances of the class. During updating, the generic function update-instance-for-redefined-class will be invoked.

The generic function make-instances-obsolete is invoked automatically by the system when defclass has been used to redefine an existing standard class and the set of local slots accessible in an instance is changed or the order of slots in storage is changed. It can also be explicitly invoked by the user.

If the second of the above methods is selected, that method invokes make-instances-obsolete on (find-class class).

Examples::

See Also::

update-instance-for-redefined-class , Redefining Classes

gcl-2.6.14/info/gcl/extended_002dchar.html0000644000175000017500000000506414360276512016551 0ustar cammcamm extended-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.4 extended-char [Type]

Supertypes::

extended-char, character, t

Description::

The type extended-char is equivalent to the type (and character (not base-char)).

Notes::

The type extended-char might have no elements_4 in implementations in which all characters are of type base-char.

gcl-2.6.14/info/gcl/echo_002dstream.html0000644000175000017500000000573314360276512016250 0ustar cammcamm echo-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.4 echo-stream [System Class]

Class Precedence List::

echo-stream, stream, t

Description::

An echo stream is a bidirectional stream that gets its input from an associated input stream and sends its output to an associated output stream.

All input taken from the input stream is echoed to the output stream. Whether the input is echoed immediately after it is encountered, or after it has been read from the input stream is implementation-dependent.

See Also::

echo-stream-input-stream , echo-stream-output-stream, make-echo-stream

gcl-2.6.14/info/gcl/reader_002derror.html0000644000175000017500000000520014360276512016417 0ustar cammcamm reader-error (ANSI and GNU Common Lisp Document)

Previous: , Up: Reader Dictionary  

23.2.18 reader-error [Condition Type]

Class Precedence List::

reader-error, parse-error, stream-error, error, serious-condition, condition, t

Description::

The type reader-error consists of error conditions that are related to tokenization and parsing done by the Lisp reader.

See Also::

read , stream-error-stream , Reader Concepts

gcl-2.6.14/info/gcl/Rule-of-Float-Underflow-and-Overflow.html0000644000175000017500000000462714360276512022252 0ustar cammcamm Rule of Float Underflow and Overflow (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Floating-point Computations  

12.1.4.4 Rule of Float Underflow and Overflow

An error of type floating-point-overflow or floating-point-underflow should be signaled if a floating-point computation causes exponent overflow or underflow, respectively.

gcl-2.6.14/info/gcl/Destructuring-by-Lambda-Lists.html0000644000175000017500000000624614360276512021115 0ustar cammcamm Destructuring by Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Macro Lambda Lists  

3.4.4.1 Destructuring by Lambda Lists

Anywhere in a macro lambda list where a parameter name can appear, and where ordinary lambda list syntax (as described in Ordinary Lambda Lists) does not otherwise allow a list, a destructuring lambda list can appear in place of the parameter name. When this is done, then the argument that would match the parameter is treated as a (possibly dotted) list, to be used as an argument list for satisfying the parameters in the embedded lambda list. This is known as destructuring.

Destructuring is the process of decomposing a compound object into its component parts, using an abbreviated, declarative syntax, rather than writing it out by hand using the primitive component-accessing functions. Each component part is bound to a variable.

A destructuring operation requires an object to be decomposed, a pattern that specifies what components are to be extracted, and the names of the variables whose values are to be the components.

gcl-2.6.14/info/gcl/Syntax-of-a-Rational.html0000644000175000017500000000412714360276512017242 0ustar cammcamm Syntax of a Rational (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Constructing Numbers from Tokens  

2.3.2.1 Syntax of a Rational

gcl-2.6.14/info/gcl/digit_002dchar_002dp.html0000644000175000017500000000773414360276512016764 0ustar cammcamm digit-char-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.11 digit-char-p [Function]

digit-char-p char &optional radix ⇒ weight

Arguments and Values::

char—a character.

radix—a radix. The default is 10.

weight—either a non-negative integer less than radix, or false.

Description::

Tests whether char is a digit in the specified radix (i.e., with a weight less than radix). If it is a digit in that radix, its weight is returned as an integer; otherwise nil is returned.

Examples::

 (digit-char-p #\5)    ⇒  5
 (digit-char-p #\5 2)  ⇒  false
 (digit-char-p #\A)    ⇒  false
 (digit-char-p #\a)    ⇒  false
 (digit-char-p #\A 11) ⇒  10
 (digit-char-p #\a 11) ⇒  10
 (mapcar #'(lambda (radix) 
             (map 'list #'(lambda (x) (digit-char-p x radix)) 
                  "059AaFGZ"))
         '(2 8 10 16 36))
 ⇒  ((0 NIL NIL NIL NIL NIL NIL NIL)
     (0 5 NIL NIL NIL NIL NIL NIL)
     (0 5 9 NIL NIL NIL NIL NIL)
     (0 5 9 10 10 15 NIL NIL)
     (0 5 9 10 10 15 16 35))

Affected By::

None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.)

See Also::

alphanumericp

Notes::

Digits are graphic characters.

gcl-2.6.14/info/gcl/character.html0000644000175000017500000000642714360276512015326 0ustar cammcamm character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.6 character [Function]

character character ⇒ denoted-character

Arguments and Values::

character—a character designator.

denoted-character—a character.

Description::

Returns the character denoted by the character designator.

Examples::

 (character #\a) ⇒  #\a
 (character "a") ⇒  #\a
 (character 'a) ⇒  #\A
 (character '\a) ⇒  #\a
 (character 65.) is an error.
 (character 'apple) is an error.

Exceptional Situations::

Should signal an error of type type-error if object is not a character designator.

See Also::

coerce

Notes::

 (character object) ≡ (coerce object 'character)
gcl-2.6.14/info/gcl/stream_002delement_002dtype.html0000644000175000017500000000723614360276512020412 0ustar cammcamm stream-element-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.12 stream-element-type [Function]

stream-element-type stream ⇒ typespec

Arguments and Values::

stream—a stream.

typespec—a type specifier.

Description::

stream-element-type returns a type specifier that indicates the types of objects that may be read from or written to stream.

Streams created by open have an element type restricted to integer or a subtype of type character.

Examples::

;; Note that the stream must accomodate at least the specified type,
;; but might accomodate other types.  Further note that even if it does
;; accomodate exactly the specified type, the type might be specified in
;; any of several ways.
 (with-open-file (s "test" :element-type '(integer 0 1)
                           :if-exists :error
                           :direction :output)
   (stream-element-type s))
⇒  INTEGER
OR⇒ (UNSIGNED-BYTE 16)
OR⇒ (UNSIGNED-BYTE 8)
OR⇒ BIT
OR⇒ (UNSIGNED-BYTE 1)
OR⇒ (INTEGER 0 1)
OR⇒ (INTEGER 0 (2))

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream.

gcl-2.6.14/info/gcl/hash_002dtable_002dp.html0000644000175000017500000000613614360276512016754 0ustar cammcamm hash-table-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.3 hash-table-p [Function]

hash-table-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type hash-table; otherwise, returns false.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32511220>
 (hash-table-p table) ⇒  true
 (hash-table-p 37) ⇒  false
 (hash-table-p '((a . 1) (b . 2))) ⇒  false

Notes::

 (hash-table-p object) ≡ (typep object 'hash-table)
gcl-2.6.14/info/gcl/intern.html0000644000175000017500000001313614360276512014664 0ustar cammcamm intern (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.21 intern [Function]

intern string &optional package ⇒ symbol, status

Arguments and Values::

string—a string.

package—a package designator.

The default is the current package.

symbol—a symbol.

status—one of :inherited, :external, :internal, or nil.

Description::

intern enters a symbol named string into package. If a symbol whose name is the same as string is already accessible in package, it is returned. If no such symbol is accessible in package, a new symbol with the given name is created and entered into package as an internal symbol, or as an external symbol if the package is the KEYWORD package; package becomes the home package of the created symbol.

The first value returned by intern, symbol, is the symbol that was found or created. The meaning of the secondary value, status, is as follows:

:internal

The symbol was found and is present in package as an internal symbol.

:external

The symbol was found and is present as an external symbol.

:inherited

The symbol was found and is inherited via use-package (which implies that the symbol is internal).

nil

No pre-existing symbol was found, so one was created.

It is implementation-dependent whether the string that becomes the new symbol’s name is the given string or a copy of it. Once a string has been given as the string argument to intern in this situation where a new symbol is created, the consequences are undefined if a subsequent attempt is made to alter that string.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (intern "Never-Before") ⇒  |Never-Before|, NIL
 (intern "Never-Before") ⇒  |Never-Before|, :INTERNAL 
 (intern "NEVER-BEFORE" "KEYWORD") ⇒  :NEVER-BEFORE, NIL
 (intern "NEVER-BEFORE" "KEYWORD") ⇒  :NEVER-BEFORE, :EXTERNAL

See Also::

find-symbol , read , symbol, unintern , Symbols as Tokens

Notes::

intern does not need to do any name conflict checking because it never creates a new symbol if there is already an accessible symbol with the name given.

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/Examples-of-for_002das_002don_002dlist-subclause.html0000644000175000017500000000531714360276512024073 0ustar cammcamm Examples of for-as-on-list subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.7 Examples of for-as-on-list subclause

;; Collect successive tails of a list.
 (loop for sublist on '(a b c d)
       collect sublist)
⇒  ((A B C D) (B C D) (C D) (D))

;; Print a list by using destructuring with the loop keyword ON.
 (loop for (item) on '(1 2 3)
       do (print item))
 |>  1 
 |>  2 
 |>  3 
⇒  NIL
gcl-2.6.14/info/gcl/Examples-of-Semicolon.html0000644000175000017500000000405514360276512017473 0ustar cammcamm Examples of Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.1 Examples of Semicolon

 (+ 3 ; three
    4)
⇒  7
gcl-2.6.14/info/gcl/The-Lisp-Pretty-Printer.html0000644000175000017500000000521214360276512017714 0ustar cammcamm The Lisp Pretty Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer  

22.2 The Lisp Pretty Printer

• Pretty Printer Concepts  
• Examples of using the Pretty Printer  
• Notes about the Pretty Printer`s Background  
gcl-2.6.14/info/gcl/Restarts.html0000644000175000017500000001137314360276512015175 0ustar cammcamm Restarts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.3 Restarts

The interactive condition handler returns only through non-local transfer of control to specially defined restarts that can be set up either by the system or by user code. Transferring control to a restart is called “invoking” the restart. Like handlers, active restarts are established dynamically, and only active restarts can be invoked. An active restart can be invoked by the user from the debugger or by a program by using invoke-restart.

A restart contains a function to be called when the restart is invoked, an optional name that can be used to find or invoke the restart, and an optional set of interaction information for the debugger to use to enable the user to manually invoke a restart.

The name of a restart is used by invoke-restart. Restarts that can be invoked only within the debugger do not need names.

Restarts can be established by using restart-bind, restart-case, and with-simple-restart. A restart function can itself invoke any other restart that was active at the time of establishment of the restart of which the function is part.

The restarts established by a restart-bind form, a restart-case form, or a with-simple-restart form have dynamic extent which extends for the duration of that form’s execution.

Restarts of the same name can be ordered from least recent to most recent according to the following two rules:

1.

Each restart in a set of active restarts R_1 is more recent than every restart in a set R_2 if the restarts in R_2 were active when the restarts in R_1 were established.

2.

Let r_1 and r_2 be two active restarts with the same name established by the same form. Then r_1 is more recent than r_2 if r_1 was defined to the left of r_2 in the form that established them.

If a restart is invoked but does not transfer control, the values resulting from the restart function are returned by the function that invoked the restart, either invoke-restart or invoke-restart-interactively.

Next: , Previous: , Up: Signaling and Handling Conditions  

gcl-2.6.14/info/gcl/storage_002dcondition.html0000644000175000017500000000742614360276512017472 0ustar cammcamm storage-condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.9 storage-condition [Condition Type]

Class Precedence List::

storage-condition, serious-condition, condition, t

Description::

The type storage-condition consists of serious conditions that relate to problems with memory management that are potentially due to implementation-dependent limits rather than semantic errors in conforming programs, and that typically warrant entry to the debugger if not handled. Depending on the details of the implementation, these might include such problems as stack overflow, memory region overflow, and storage exhausted.

Notes::

While some Common Lisp operations might signal storage-condition because they are defined to create objects, it is unspecified whether operations that are not defined to create objects create them anyway and so might also signal storage-condition. Likewise, the evaluator itself might create objects and so might signal storage-condition. (The natural assumption might be that such object creation is naturally inefficient, but even that is implementation-dependent.) In general, the entire question of how storage allocation is done is implementation-dependent, and so any operation might signal storage-condition at any time. Because such a condition is indicative of a limitation of the implementation or of the image rather than an error in a program, objects of type storage-condition are not of type error.

gcl-2.6.14/info/gcl/file_002dlength.html0000644000175000017500000000662414360276512016237 0ustar cammcamm file-length (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.26 file-length [Function]

file-length stream ⇒ length

Arguments and Values::

stream—a stream associated with a file.

length—a non-negative integer or nil.

Description::

file-length returns the length of stream, or nil if the length cannot be determined.

For a binary file, the length is measured in units of the element type of the stream.

Examples::

 (with-open-file (s "decimal-digits.text" 
                    :direction :output :if-exists :error)
   (princ "0123456789" s)
   (truename s))
⇒  #P"A:>Joe>decimal-digits.text.1"
 (with-open-file (s "decimal-digits.text")
   (file-length s))
⇒  10

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream associated with a file.

See Also::

open

gcl-2.6.14/info/gcl/copy_002dstructure.html0000644000175000017500000000540114360276512017041 0ustar cammcamm copy-structure (ANSI and GNU Common Lisp Document)

Previous: , Up: Structures Dictionary  

8.1.2 copy-structure [Function]

copy-structure structure ⇒ copy

Arguments and Values::

structure—a structure.

copy—a copy of the structure.

Description::

Returns a copy_6 of the structure.

Only the structure itself is copied; not the values of the slots.

See Also::

the :copier option to defstruct

Notes::

The copy is the same as the given structure under equalp, but not under equal.

gcl-2.6.14/info/gcl/Arrays.html0000644000175000017500000000421614360276512014625 0ustar cammcamm Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

15 Arrays

• Array Concepts  
• Arrays Dictionary  
gcl-2.6.14/info/gcl/make_002dlist.html0000644000175000017500000000647314360276512015731 0ustar cammcamm make-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.18 make-list [Function]

make-list size &key initial-element ⇒ list

Arguments and Values::

size—a non-negative integer.

initial-element—an object. The default is nil.

list—a list.

Description::

Returns a list of length given by size, each of the elements of which is initial-element.

Examples::

 (make-list 5) ⇒  (NIL NIL NIL NIL NIL)
 (make-list 3 :initial-element 'rah) ⇒  (RAH RAH RAH)
 (make-list 2 :initial-element '(1 2 3)) ⇒  ((1 2 3) (1 2 3))
 (make-list 0) ⇒  NIL ;i.e., ()
 (make-list 0 :initial-element 'new-element) ⇒  NIL

Exceptional Situations::

Should signal an error of type type-error if size is not a non-negative integer.

See Also::

cons , list (Function)

gcl-2.6.14/info/gcl/Declarative-Method-Combination.html0000644000175000017500000000563414360276512021272 0ustar cammcamm Declarative Method Combination (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.6 Declarative Method Combination

The macro define-method-combination defines new forms of method combination. It provides a mechanism for customizing the production of the effective method. The default procedure for producing an effective method is described in Determining the Effective Method. There are two forms of define-method-combination. The short form is a simple facility while the long form is more powerful and more verbose. The long form resembles defmacro in that the body is an expression that computes a Lisp form; it provides mechanisms for implementing arbitrary control structures within method combination and for arbitrary processing of method qualifiers.

gcl-2.6.14/info/gcl/not.html0000644000175000017500000000620514360276512014164 0ustar cammcamm not (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.31 not [Function]

not x ⇒ boolean

Arguments and Values::

x—a generalized boolean (i.e., any object).

boolean—a boolean.

Description::

Returns t if x is false; otherwise, returns nil.

Examples::

 (not nil) ⇒  T
 (not '()) ⇒  T
 (not (integerp 'sss)) ⇒  T
 (not (integerp 1)) ⇒  NIL
 (not 3.7) ⇒  NIL
 (not 'apple) ⇒  NIL

See Also::

null

Notes::

not is intended to be used to invert the ‘truth value’ of a boolean (or generalized boolean) whereas null is intended to be used to test for the empty list. Operationally, not and null compute the same result; which to use is a matter of style.

gcl-2.6.14/info/gcl/defparameter.html0000644000175000017500000002441114360276512016022 0ustar cammcamm defparameter (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.16 defparameter, defvar [Macro]

defparameter name initial-value [documentation] ⇒ name

defvar name [initial-value [documentation]] ⇒ name

Arguments and Values::

name—a symbol; not evaluated.

initial-value—a form; for defparameter, it is always evaluated, but for defvar it is evaluated only if name is not already bound.

documentation—a string; not evaluated.

Description::

defparameter and defvar establish name as a dynamic variable.

defparameter unconditionally assigns the initial-value to the dynamic variable named name. defvar, by contrast, assigns initial-value (if supplied) to the dynamic variable named name only if name is not already bound.

If no initial-value is supplied, defvar leaves the value cell of the dynamic variable named name undisturbed; if name was previously bound, its old value persists, and if it was previously unbound, it remains unbound.

If documentation is supplied, it is attached to name as a documentation string of kind variable.

defparameter and defvar normally appear as a top level form, but it is meaningful for them to appear as non-top-level forms. However, the compile-time side effects described below only take place when they appear as top level forms.

Examples::

 (defparameter *p* 1) ⇒  *P*
 *p* ⇒  1
 (constantp '*p*) ⇒  false
 (setq *p* 2) ⇒  2
 (defparameter *p* 3) ⇒  *P*
 *p* ⇒  3

 (defvar *v* 1) ⇒  *V*
 *v* ⇒  1
 (constantp '*v*) ⇒  false
 (setq *v* 2) ⇒  2
 (defvar *v* 3) ⇒  *V*
 *v* ⇒  2

 (defun foo ()
   (let ((*p* 'p) (*v* 'v))
     (bar))) ⇒  FOO
 (defun bar () (list *p* *v*)) ⇒  BAR
 (foo) ⇒  (P V)

The principal operational distinction between defparameter and defvar is that defparameter makes an unconditional assignment to name, while defvar makes a conditional one. In practice, this means that defparameter is useful in situations where loading or reloading the definition would want to pick up a new value of the variable, while defvar is used in situations where the old value would want to be retained if the file were loaded or reloaded. For example, one might create a file which contained: 

 (defvar *the-interesting-numbers* '())
 (defmacro define-interesting-number (name n)
   `(progn (defvar ,name ,n)
           (pushnew ,name *the-interesting-numbers*)
           ',name))
 (define-interesting-number *my-height* 168) ;cm
 (define-interesting-number *my-weight* 13)  ;stones

Here the initial value, (), for the variable *the-interesting-numbers* is just a seed that we are never likely to want to reset to something else once something has been grown from it. As such, we have used defvar to avoid having the *interesting-numbers* information reset if the file is loaded a second time. It is true that the two calls to define-interesting-number here would be reprocessed, but if there were additional calls in another file, they would not be and that information would be lost. On the other hand, consider the following code: 

 (defparameter *default-beep-count* 3)
 (defun beep (&optional (n *default-beep-count*))
   (dotimes (i n) (si:

Here we could easily imagine editing the code to change the initial value of *default-beep-count*, and then reloading the file to pick up the new value. In order to make value updating easy, we have used defparameter.

On the other hand, there is potential value to using defvar in this situation. For example, suppose that someone had predefined an alternate value for *default-beep-count*, or had loaded the file and then manually changed the value. In both cases, if we had used defvar instead of defparameter, those user preferences would not be overridden by (re)loading the file.

The choice of whether to use defparameter or defvar has visible consequences to programs, but is nevertheless often made for subjective reasons.

Side Effects::

If a defvar or defparameter form appears as a top level form, the compiler must recognize that the name has been proclaimed special. However, it must neither evaluate the initial-value form nor assign the dynamic variable named name at compile time.

There may be additional (implementation-defined) compile-time or run-time side effects, as long as such effects do not interfere with the correct operation of conforming programs.

Affected By::

defvar is affected by whether name is already bound.

See Also::

declaim , defconstant , documentation , Compilation

Notes::

It is customary to name dynamic variables with an asterisk at the beginning and end of the name. e.g., *foo* is a good name for a dynamic variable, but not for a lexical variable; foo is a good name for a lexical variable, but not for a dynamic variable. This naming convention is observed for all defined names in Common Lisp; however, neither conforming programs nor conforming implementations are obliged to adhere to this convention.

The intent of the permission for additional side effects is to allow implementations to do normal “bookkeeping” that accompanies definitions. For example, the macro expansion of a defvar or defparameter form might include code that arranges to record the name of the source file in which the definition occurs.

defparameter and defvar might be defined as follows: 

 (defmacro defparameter (name initial-value 
                         &optional (documentation nil documentation-p))
   `(progn (declaim (special ,name))
           (setf (symbol-value ',name) ,initial-value)
           ,(when documentation-p
              `(setf (documentation ',name 'variable) ',documentation))
           ',name))
 (defmacro defvar (name &optional
                        (initial-value nil initial-value-p)
                        (documentation nil documentation-p))
   `(progn (declaim (special ,name))
           ,(when initial-value-p
              `(unless (boundp ',name)
                 (setf (symbol-value ',name) ,initial-value)))
           ,(when documentation-p
              `(setf (documentation ',name 'variable) ',documentation))
           ',name))

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/unbound_002dslot.html0000644000175000017500000000554214360276512016470 0ustar cammcamm unbound-slot (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.40 unbound-slot [Condition Type]

Class Precedence List::

unbound-slot, cell-error, error, serious-condition, condition, t

Description::

The object having the unbound slot is initialized by the :instance initialization argument to make-condition, and is accessed by the function unbound-slot-instance.

The name of the cell (see cell-error) is the name of the slot.

See Also::

cell-error-name , unbound-slot-object, Condition System Concepts

gcl-2.6.14/info/gcl/find_002dmethod.html0000644000175000017500000001413514360276512016233 0ustar cammcamm find-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.34 find-method [Standard Generic Function]

Syntax::

find-method generic-function method-qualifiers specializers &optional errorp
⇒ method

Method Signatures::

find-method (generic-function standard-generic-function) method-qualifiers specializers &optional errorp

Arguments and Values::

generic-function—a generic function.

method-qualifiers—a list.

specializers—a list.

errorp—a generalized boolean. The default is true.

method—a method object, or nil.

Description::

The generic function find-method takes a generic function and returns the method object that agrees on qualifiers and parameter specializers with the method-qualifiers and specializers arguments of find-method. Method-qualifiers contains the method qualifiers for the method. The order of the method qualifiers is significant. For a definition of agreement in this context, see Agreement on Parameter Specializers and Qualifiers.

The specializers argument contains the parameter specializers for the method. It must correspond in length to the number of required arguments of the generic function, or an error is signaled. This means that to obtain the default method on a given generic-function, a list whose elements are the class t must be given.

If there is no such method and errorp is true, find-method signals an error. If there is no such method and errorp is false, find-method returns nil.

Examples::

 (defmethod some-operation ((a integer) (b float)) (list a b))
⇒  #<STANDARD-METHOD SOME-OPERATION (INTEGER FLOAT) 26723357>
 (find-method #'some-operation '() (mapcar #'find-class '(integer float)))
⇒  #<STANDARD-METHOD SOME-OPERATION (INTEGER FLOAT) 26723357>
 (find-method #'some-operation '() (mapcar #'find-class '(integer integer)))
 |>  Error: No matching method
 (find-method #'some-operation '() (mapcar #'find-class '(integer integer)) nil)
⇒  NIL

Affected By::

add-method, defclass, defgeneric, defmethod

Exceptional Situations::

If the specializers argument does not correspond in length to the number of required arguments of the generic-function, an an error of type error is signaled.

If there is no such method and errorp is true, find-method signals an error of type error.

See Also::

Agreement on Parameter Specializers and Qualifiers

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/fboundp.html0000644000175000017500000001073014360276512015017 0ustar cammcamm fboundp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.4 fboundp [Function]

fboundp name ⇒ generalized-boolean

Pronunciation::

pronounced ,ef ’baund p\=e

Arguments and Values::

name—a function name.

generalized-boolean—a generalized boolean.

Description::

Returns true if name is fbound; otherwise, returns false.

Examples::

 (fboundp 'car) ⇒  true
 (fboundp 'nth-value) ⇒  false
 (fboundp 'with-open-file) ⇒  true
 (fboundp 'unwind-protect) ⇒  true
 (defun my-function (x) x) ⇒  MY-FUNCTION
 (fboundp 'my-function) ⇒  true
 (let ((saved-definition (symbol-function 'my-function)))
   (unwind-protect (progn (fmakunbound 'my-function)
                          (fboundp 'my-function))
     (setf (symbol-function 'my-function) saved-definition)))
⇒  false
 (fboundp 'my-function) ⇒  true
 (defmacro my-macro (x) `',x) ⇒  MY-MACRO
 (fboundp 'my-macro) ⇒  true
 (fmakunbound 'my-function) ⇒  MY-FUNCTION
 (fboundp 'my-function) ⇒  false
 (flet ((my-function (x) x))
   (fboundp 'my-function)) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if name is not a function name.

See Also::

symbol-function , fmakunbound , fdefinition

Notes::

It is permissible to call symbol-function on any symbol that is fbound.

fboundp is sometimes used to “guard” an access to the function cell, as in: 

(if (fboundp x) (symbol-function x))

Defining a setf expander F does not cause the setf function (setf F) to become defined.

gcl-2.6.14/info/gcl/Identity-of-Characters.html0000644000175000017500000000415714360276512017640 0ustar cammcamm Identity of Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.5 Identity of Characters

Two characters that are eql, char=, or char-equal are not necessarily eq.

gcl-2.6.14/info/gcl/Package-Prefixes-for-Symbols.html0000644000175000017500000001141614360276512020714 0ustar cammcamm Package Prefixes for Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.9 Package Prefixes for Symbols

Package prefixes are printed if necessary. The rules for package prefixes are as follows. When the symbol is printed, if it is in the KEYWORD package, then it is printed with a preceding colon; otherwise, if it is accessible in the current package, it is printed without any package prefix; otherwise, it is printed with a package prefix.

A symbol that is apparently uninterned is printed preceded by “#:”

if *print-gensym* is true and printer escaping is enabled; if *print-gensym* is false or printer escaping is disabled,

then the symbol is printed without a prefix, as if it were in the current package.

Because the #: syntax does not intern the following symbol, it is necessary to use circular-list syntax if *print-circle* is true and the same uninterned symbol appears several times in an expression to be printed. For example, the result of 

 (let ((x (make-symbol "FOO"))) (list x x))

would be printed as (#:foo #:foo) if *print-circle* were false, but as (#1=#:foo #1#) if *print-circle* were true.

A summary of the preceding package prefix rules follows:

foo:bar

foo:bar is printed when symbol bar is external in its home package foo and is not accessible in the current package.

foo::bar

foo::bar is printed when bar is internal in its home package foo and is not accessible in the current package.

:bar

:bar is printed when the home package of bar is the KEYWORD package.

#:bar

#:bar is printed when bar is apparently uninterned, even in the pathological case that bar has no home package but is nevertheless somehow accessible in the current package.

Next: , Previous: , Up: Default Print-Object Methods  

gcl-2.6.14/info/gcl/string_002dupcase.html0000644000175000017500000001723014360276512016620 0ustar cammcamm string-upcase (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.8 string-upcase, string-downcase, string-capitalize,

nstring-upcase, nstring-downcase, nstring-capitalize

[Function]

string-upcase string &key start end ⇒ cased-string

string-downcase string &key start end ⇒ cased-string

string-capitalize string &key start end ⇒ cased-string

nstring-upcase string &key start end ⇒ string

nstring-downcase string &key start end ⇒ string

nstring-capitalize string &key start end ⇒ string

Arguments and Values::

string—a string designator. For nstring-upcase, nstring-downcase, and nstring-capitalize, the string designator must be a string.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

cased-string—a string.

Description::

string-upcase, string-downcase, string-capitalize, nstring-upcase, nstring-downcase, nstring-capitalize change the case of the subsequence of string bounded by start and end as follows:

string-upcase

string-upcase returns a string just like string with all lowercase characters replaced by the corresponding uppercase characters. More precisely, each character of the result string is produced by applying the function char-upcase to the corresponding character of string.

string-downcase

string-downcase is like string-upcase except that all uppercase characters are replaced by the corresponding lowercase characters (using char-downcase).

string-capitalize

string-capitalize produces a copy of string such that, for every word in the copy, the first character of the “word,” if it has case, is uppercase and any other characters with case in the word are lowercase. For the purposes of string-capitalize, a “word” is defined to be a consecutive subsequence consisting of alphanumeric characters, delimited at each end either by a non-alphanumeric character or by an end of the string.

nstring-upcase, nstring-downcase, nstring-capitalize

nstring-upcase, nstring-downcase, and nstring-capitalize are identical to string-upcase, string-downcase, and string-capitalize respectively except that they modify string.

For string-upcase, string-downcase, and string-capitalize, string is not modified. However, if no characters in string require conversion, the result may be either string or a copy of it, at the implementation’s discretion.

Examples::

 (string-upcase "abcde") ⇒  "ABCDE"
 (string-upcase "Dr. Livingston, I presume?")
⇒  "DR. LIVINGSTON, I PRESUME?"
 (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
⇒  "Dr. LiVINGston, I presume?"
 (string-downcase "Dr. Livingston, I presume?")
⇒  "dr. livingston, i presume?"

 (string-capitalize "elm 13c arthur;fig don't") ⇒  "Elm 13c Arthur;Fig Don'T"
 (string-capitalize " hello ") ⇒  " Hello "
 (string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
⇒   "Occluded Casements Forestall Inadvertent Defenestration"
 (string-capitalize 'kludgy-hash-search) ⇒  "Kludgy-Hash-Search"
 (string-capitalize "DON'T!") ⇒  "Don'T!"    ;not "Don't!"
 (string-capitalize "pipe 13a, foo16c") ⇒  "Pipe 13a, Foo16c"

 (setq str (copy-seq "0123ABCD890a")) ⇒  "0123ABCD890a"
 (nstring-downcase str :start 5 :end 7) ⇒  "0123AbcD890a"
 str ⇒  "0123AbcD890a"

Side Effects::

nstring-upcase, nstring-downcase, and nstring-capitalize modify string as appropriate rather than constructing a new string.

See Also::

char-upcase , char-downcase

Notes::

The result is always of the same length as string.

Next: , Previous: , Up: Strings Dictionary  

gcl-2.6.14/info/gcl/Restrictions-on-Wildcard-Pathnames.html0000644000175000017500000000623714360276512022140 0ustar cammcamm Restrictions on Wildcard Pathnames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.11 Restrictions on Wildcard Pathnames

Wildcard pathnames can be used with directory but not with open, and return true from wild-pathname-p. When examining wildcard components of a wildcard pathname, conforming programs must be prepared to encounter any of the following additional values in any component or any element of a list that is the directory component:

*

The symbol :wild, which matches anything.

*

A string containing implementation-dependent special wildcard characters.

*

Any object, representing an implementation-dependent wildcard pattern.

gcl-2.6.14/info/gcl/Printer-Dictionary.html0000644000175000017500000001614314360276512017114 0ustar cammcamm Printer Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Printer  

22.4 Printer Dictionary

• copy-pprint-dispatch  
• formatter  
• pprint-dispatch  
• pprint-exit-if-list-exhausted  
• pprint-fill  
• pprint-indent  
• pprint-logical-block  
• pprint-newline  
• pprint-pop  
• pprint-tab  
• print-object  
• print-unreadable-object  
• set-pprint-dispatch  
• write  
• write-to-string  
• *print-array*  
• *print-base*  
• *print-case*  
• *print-circle*  
• *print-escape*  
• *print-gensym*  
• *print-level*  
• *print-lines*  
• *print-miser-width*  
• *print-pprint-dispatch*  
• *print-pretty*  
• *print-readably*  
• *print-right-margin*  
• print-not-readable  
• print-not-readable-object  
• format  
gcl-2.6.14/info/gcl/Examples-of-clause-grouping.html0000644000175000017500000001102114360276512020636 0ustar cammcamm Examples of clause grouping (ANSI and GNU Common Lisp Document)

Previous: , Up: Examples of Miscellaneous Loop Features  

6.1.8.1 Examples of clause grouping

;; Group conditional clauses.
 (loop for i in '(1 324 2345 323 2 4 235 252)
       when (oddp i)
         do (print i)
         and collect i into odd-numbers
         and do (terpri)
       else                              ; I is even.
         collect i into even-numbers
       finally
         (return (values odd-numbers even-numbers)))
 |>  1 
 |>  
 |>  2345 
 |>  
 |>  323 
 |>  
 |>  235 
⇒  (1 2345 323 235), (324 2 4 252)

;; Collect numbers larger than 3.
 (loop for i in '(1 2 3 4 5 6)
       when (and (> i 3) i)
       collect it)                      ; IT refers to (and (> i 3) i).
⇒  (4 5 6)

;; Find a number in a list.
 (loop for i in '(1 2 3 4 5 6)
       when (and (> i 3) i)
       return it)
⇒  4

;; The above example is similar to the following one.
 (loop for i in '(1 2 3 4 5 6)
       thereis (and (> i 3) i))
⇒  4

;; Nest conditional clauses.
 (let ((list '(0 3.0 apple 4 5 9.8 orange banana)))
   (loop for i in list
         when (numberp i)
           when (floatp i)
             collect i into float-numbers
           else                                  ; Not (floatp i)
             collect i into other-numbers
         else                                    ; Not (numberp i)
           when (symbolp i) 
             collect i into symbol-list
           else                                  ; Not (symbolp i)
             do (error "found a funny value in list ~S, value ~S~
         finally (return (values float-numbers other-numbers symbol-list))))
⇒  (3.0 9.8), (0 4 5), (APPLE ORANGE BANANA)

;; Without the END preposition, the last AND would apply to the
;; inner IF rather than the outer one.
 (loop for x from 0 to 3 
       do (print x)
       if (zerop (mod x 2))
         do (princ " a")
          and if (zerop (floor x 2))
                do (princ " b")
                end
          and do (princ " c"))
 |>  0  a b c
 |>  1 
 |>  2  a c
 |>  3 
⇒  NIL

Previous: , Up: Examples of Miscellaneous Loop Features  

gcl-2.6.14/info/gcl/evenp.html0000644000175000017500000000643114360276512014502 0ustar cammcamm evenp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.30 evenp, oddp [Function]

evenp integer ⇒ generalized-boolean

oddp integer ⇒ generalized-boolean

Arguments and Values::

integer—an integer.

generalized-boolean—a generalized boolean.

Description::

evenp returns true if integer is even (divisible by two); otherwise, returns false.

oddp returns true if integer is odd (not divisible by two); otherwise, returns false.

Examples::

 (evenp 0) ⇒  true
 (oddp 10000000000000000000000) ⇒  false
 (oddp -1) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if integer is not an integer.

Notes::

 (evenp integer) ≡ (not (oddp integer))
 (oddp integer)  ≡ (not (evenp integer))
gcl-2.6.14/info/gcl/_002aprint_002dcase_002a.html0000644000175000017500000001225714360276512017351 0ustar cammcamm *print-case* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.18 *print-case* [Variable]

Value Type::

One of the symbols :upcase, :downcase, or :capitalize.

Initial Value::

The symbol :upcase.

Description::

The value of *print-case* controls the case (upper, lower, or mixed) in which to print any uppercase characters in the names of symbols when vertical-bar syntax is not used.

*print-case* has an effect at all times when the value of *print-escape* is false. *print-case* also has an effect when the value of *print-escape* is true unless inside an escape context (i.e., unless between vertical-bars or after a slash).

Examples::

 (defun test-print-case ()
   (dolist (*print-case* '(:upcase :downcase :capitalize))
     (format t "~&~S ~S~
⇒  TEST-PC
;; Although the choice of which characters to escape is specified by
;; *PRINT-CASE*, the choice of how to escape those characters 
;; (i.e., whether single escapes or multiple escapes are used)
;; is implementation-dependent.  The examples here show two of the
;; many valid ways in which escaping might appear.
 (test-print-case) ;Implementation A
 |>  THIS-AND-THAT |And-something-elSE|
 |>  this-and-that a\n\d-\s\o\m\e\t\h\i\n\g-\e\lse
 |>  This-And-That A\n\d-\s\o\m\e\t\h\i\n\g-\e\lse
⇒  NIL
 (test-print-case) ;Implementation B
 |>  THIS-AND-THAT |And-something-elSE|
 |>  this-and-that a|nd-something-el|se
 |>  This-And-That A|nd-something-el|se
⇒  NIL

See Also::

write

Notes::

read normally converts lowercase characters appearing in symbols to corresponding uppercase characters, so that internally print names normally contain only uppercase characters.

If *print-escape* is true, lowercase characters in the name of a symbol are always printed in lowercase, and are preceded by a single escape character or enclosed by multiple escape characters; uppercase characters in the name of a symbol are printed in upper case, in lower case, or in mixed case so as to capitalize words, according to the value of *print-case*. The convention for what constitutes a “word” is the same as for string-capitalize.

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/make_002dpathname.html0000644000175000017500000001774314360276512016555 0ustar cammcamm make-pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.4 make-pathname [Function]

make-pathname &key host device directory name type version defaults case
⇒ pathname

Arguments and Values::

host—a valid physical pathname host. Complicated defaulting behavior; see below.

device—a valid pathname device. Complicated defaulting behavior; see below.

directory—a valid pathname directory. Complicated defaulting behavior; see below.

name—a valid pathname name. Complicated defaulting behavior; see below.

type—a valid pathname type. Complicated defaulting behavior; see below.

version—a valid pathname version. Complicated defaulting behavior; see below.

defaults—a pathname designator. The default is a pathname whose host component is the same as the host component of the value of *default-pathname-defaults*, and whose other components are all nil.

case—one of :common or :local. The default is :local.

pathname—a pathname.

Description::

Constructs and returns a pathname from the supplied keyword arguments.

After the components supplied explicitly by host, device, directory, name, type, and version are filled in, the merging rules used by merge-pathnames are used to fill in any unsupplied components from the defaults supplied by defaults.

Whenever a pathname is constructed the components may be canonicalized if appropriate. For the explanation of the arguments that can be supplied for each component, see Pathname Components.

If case is supplied, it is treated as described in Case in Pathname Components.

The resulting pathname is a logical pathname if and only its host component is a logical host or a string that names a defined logical host.

If the directory is a string, it should be the name of a top level directory, and should not contain any punctuation characters; that is, specifying a string, str, is equivalent to specifying the list (:absolute str). Specifying the symbol :wild is equivalent to specifying the list (:absolute :wild-inferiors), or (:absolute :wild) in a file system that does not support :wild-inferiors.

Examples::

 ;; Implementation A -- an implementation with access to a single
 ;;  Unix file system.  This implementation happens to never display
 ;;  the `host' information in a namestring, since there is only one host. 
 (make-pathname :directory '(:absolute "public" "games")
                :name "chess" :type "db")
⇒  #P"/public/games/chess.db" 

 ;; Implementation B -- an implementation with access to one or more
 ;;  VMS file systems.  This implementation displays `host' information
 ;;  in the namestring only when the host is not the local host.
 ;;  It uses a double colon to separate a host name from the host's local
 ;;  file name.
 (make-pathname :directory '(:absolute "PUBLIC" "GAMES")
                :name "CHESS" :type "DB")
⇒  #P"SYS$DISK:[PUBLIC.GAMES]CHESS.DB" 
 (make-pathname :host "BOBBY"
                :directory '(:absolute "PUBLIC" "GAMES")
                :name "CHESS" :type "DB")
⇒  #P"BOBBY::SYS$DISK:[PUBLIC.GAMES]CHESS.DB" 

 ;; Implementation C -- an implementation with simultaneous access to
 ;;  multiple file systems from the same Lisp image.  In this 
 ;;  implementation, there is a convention that any text preceding the
 ;;  first colon in a pathname namestring is a host name.
 (dolist (case '(:common :local))
   (dolist (host '("MY-LISPM" "MY-VAX" "MY-UNIX"))
     (print (make-pathname :host host :case case
                           :directory '(:absolute "PUBLIC" "GAMES")
                           :name "CHESS" :type "DB"))))
 |>  #P"MY-LISPM:>public>games>chess.db"
 |>  #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB"
 |>  #P"MY-UNIX:/public/games/chess.db"
 |>  #P"MY-LISPM:>public>games>chess.db" 
 |>  #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB" 
 |>  #P"MY-UNIX:/PUBLIC/GAMES/CHESS.DB" 
⇒  NIL

Affected By::

The file system.

See Also::

merge-pathnames , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Notes::

Portable programs should not supply :unspecific for any component. See ->UNSPECIFIC as a Component Value.

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/deftype.html0000644000175000017500000001444214360276512015026 0ustar cammcamm deftype (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.25 deftype [Macro]

deftype name lambda-list [[{declaration}* | documentation]] {form}* ⇒ name

Arguments and Values::

name—a symbol.

lambda-list—a deftype lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

Description::

deftype defines a derived type specifier named name.

The meaning of the new type specifier is given in terms of a function which expands the type specifier into another type specifier, which itself will be expanded if it contains references to another derived type specifier.

The newly defined type specifier may be referenced as a list of the form (name arg_1 arg_2 ...)\/. The number of arguments must be appropriate to the lambda-list. If the new type specifier takes no arguments, or if all of its arguments are optional, the type specifier may be used as an atomic type specifier.

The argument expressions to the type specifier, arg_1 ... arg_n, are not evaluated. Instead, these literal objects become the objects to which corresponding parameters become bound.

The body of the deftype form

(but not the lambda-list)

is

implicitly enclosed in a block named name,

and is evaluated as an implicit progn, returning a new type specifier.

The lexical environment of the body is the one which was current at the time the deftype form was evaluated, augmented by the variables in the lambda-list.

Recursive expansion of the type specifier returned as the expansion must terminate, including the expansion of type specifiers which are nested within the expansion.

The consequences are undefined if the result of fully expanding a type specifier contains any circular structure, except within the objects referred to by member and eql type specifiers.

Documentation is attached to name as a documentation string of kind type.

If a deftype form appears as a top level form, the compiler must ensure that the name is recognized in subsequent type declarations. The programmer must ensure that the body of a deftype form can be evaluated at compile time if the name is referenced in subsequent type declarations. If the expansion of a type specifier is not defined fully at compile time (perhaps because it expands into an unknown type specifier or a satisfies of a named function that isn’t defined in the compile-time environment), an implementation may ignore any references to this type in declarations and/or signal a warning.

Examples::

 (defun equidimensional (a)
   (or (< (array-rank a) 2)
       (apply #'= (array-dimensions a)))) ⇒  EQUIDIMENSIONAL
 (deftype square-matrix (&optional type size)
   `(and (array ,type (,size ,size))
         (satisfies equidimensional))) ⇒  SQUARE-MATRIX

See Also::

declare, defmacro , documentation , Type Specifiers, Syntactic Interaction of Documentation Strings and Declarations

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/Truenames.html0000644000175000017500000000616114360276512015330 0ustar cammcamm Truenames (ANSI and GNU Common Lisp Document)

Previous: , Up: File System Concepts  

20.1.3 Truenames

Many file systems permit more than one filename to designate a particular file.

Even where multiple names are possible, most file systems have a convention for generating a canonical filename in such situations. Such a canonical filename (or the pathname representing such a filename) is called a truename .

The truename of a file may differ from other filenames for the file because of symbolic links, version numbers, logical device translations in the file system, logical pathname translations within Common Lisp, or other artifacts of the file system.

The truename for a file is often, but not necessarily, unique for each file. For instance, a Unix file with multiple hard links could have several truenames.

• Examples of Truenames  
gcl-2.6.14/info/gcl/write_002dbyte.html0000644000175000017500000000736614360276512016140 0ustar cammcamm write-byte (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.15 write-byte [Function]

write-byte byte stream ⇒ byte

Arguments and Values::

byte—an integer of the stream element type of stream.

stream—a binary output stream.

Description::

write-byte writes one byte, byte, to stream.

Examples::

 (with-open-file (s "temp-bytes" 
                    :direction :output
                    :element-type 'unsigned-byte)
    (write-byte 101 s)) ⇒  101

Side Effects::

stream is modified.

Affected By::

The element type of the stream.

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream. Should signal an error of type error if stream is not a binary output stream.

Might signal an error of type type-error if byte is not an integer of the stream element type of stream.

See Also::

read-byte , write-char ,

write-sequence

gcl-2.6.14/info/gcl/with_002dsimple_002drestart.html0000644000175000017500000001517114360276512020432 0ustar cammcamm with-simple-restart (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.40 with-simple-restart [Macro]

with-simple-restart (name format-control {format-argument}*) {form}*
⇒ {result}*

Arguments and Values::

name—a symbol.

format-control—a format control.

format-argument—an object (i.e., a format argument).

forms—an implicit progn.

results—in the normal situation, the values returned by the forms; in the exceptional situation where the restart named name is invoked, two values—nil and t.

Description::

with-simple-restart establishes a restart.

If the restart designated by name is not invoked while executing forms, all values returned by the last of forms are returned. If the restart designated by name is invoked, control is transferred to with-simple-restart, which returns two values, nil and t.

If name is nil, an anonymous restart is established.

The format-control and format-arguments are used report the restart.

Examples::

 (defun read-eval-print-loop (level)
   (with-simple-restart (abort "Exit command level ~D." level)
     (loop
       (with-simple-restart (abort "Return to command level ~D." level)
         (let ((form (prog2 (fresh-line) (read) (fresh-line))))
           (prin1 (eval form)))))))
⇒  READ-EVAL-PRINT-LOOP
 (read-eval-print-loop 1)
 (+ 'a 3)
 |>  Error: The argument, A, to the function + was of the wrong type.
 |>         The function expected a number.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use this time.
 |>   2: Return to command level 1.
 |>   3: Exit command level 1.
 |>   4: Return to Lisp Toplevel.

 (defun compute-fixnum-power-of-2 (x)
   (with-simple-restart (nil "Give up on computing 2^~D." x)
     (let ((result 1))
       (dotimes (i x result)
         (setq result (* 2 result))
         (unless (fixnump result)
           (error "Power of 2 is too large."))))))
COMPUTE-FIXNUM-POWER-OF-2
 (defun compute-power-of-2 (x)
   (or (compute-fixnum-power-of-2 x) 'something big))
COMPUTE-POWER-OF-2
 (compute-power-of-2 10)
1024
 (compute-power-of-2 10000)
 |>  Error: Power of 2 is too large.
 |>  To continue, type :CONTINUE followed by an option number.
 |>   1: Give up on computing 2^10000.
 |>   2: Return to Lisp Toplevel
 |>  Debug> |>>:continue 1<<|
⇒  SOMETHING-BIG

See Also::

restart-case

Notes::

with-simple-restart is shorthand for one of the most common uses of restart-case.

with-simple-restart could be defined by: 

 (defmacro with-simple-restart ((restart-name format-control
                                              &rest format-arguments)
                                &body forms)
   `(restart-case (progn ,@forms)
      (,restart-name ()
          :report (lambda (stream)
                    (format stream ,format-control ,@format-arguments))
         (values nil t))))

Because the second return value is t in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or nil so that the two situations can be distinguished.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/short_002dsite_002dname.html0000644000175000017500000000652514360276512017530 0ustar cammcamm short-site-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.25 short-site-name, long-site-name [Function]

short-site-name <no arguments> ⇒ description

long-site-name <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

short-site-name and long-site-name return a string that identifies the physical location of the computer hardware, or nil if no appropriate description can be produced.

Examples::

 (short-site-name)
⇒  "MIT AI Lab"
OR⇒ "CMU-CSD"
 (long-site-name)
⇒  "MIT Artificial Intelligence Laboratory"
OR⇒ "CMU Computer Science Department"

Affected By::

The implementation, the location of the computer hardware, and the installation/configuration process.

gcl-2.6.14/info/gcl/lambda-_0028Symbol_0029.html0000644000175000017500000000765314360276512017202 0ustar cammcamm lambda (Symbol) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.1 lambda [Symbol]

Syntax::

lambda lambda-list [[{declaration}* | documentation]] {form}*

Arguments::

lambda-list—an ordinary lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

Description::

A lambda expression is a list that can be used in place of a function name in certain contexts to denote a function by directly describing its behavior rather than indirectly by referring to the name of an established function.

Documentation is attached to the denoted function (if any is actually created) as a documentation string.

See Also::

function, documentation , Lambda Expressions, Lambda Forms, Syntactic Interaction of Documentation Strings and Declarations

Notes::

The lambda form 

 ((lambda lambda-list . body) . arguments)

is semantically equivalent to the function form 

 (funcall #'(lambda lambda-list . body) . arguments)
gcl-2.6.14/info/gcl/boolean.html0000644000175000017500000000614714360276512015010 0ustar cammcamm boolean (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.2 boolean [Type]

Supertypes::

boolean, symbol, t

Description::

The type boolean contains the symbols t and nil, which represent true and false, respectively.

See Also::

t (constant variable), nil (constant variable), if , not , complement

Notes::

Conditional operations, such as if, permit the use of generalized booleans, not just booleans; any non-nil value, not just t, counts as true for a generalized boolean. However, as a matter of convention, the symbol t is considered the canonical value to use even for a generalized boolean when no better choice presents itself.

gcl-2.6.14/info/gcl/Initialize_002dInstance.html0000644000175000017500000001310314360276512017672 0ustar cammcamm Initialize-Instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.6 Initialize-Instance

The generic function initialize-instance is called by make-instance to initialize a newly created instance. It uses standard method combination. Methods for initialize-instance can be defined in order to perform any initialization that cannot be achieved simply by supplying initial values for slots.

During initialization, initialize-instance is invoked after the following actions have been taken:

*

The defaulted initialization argument list has been computed by combining the supplied initialization argument list with any default initialization arguments for the class.

*

The validity of the defaulted initialization argument list has been checked. If any of the initialization arguments has not been declared as valid, an error is signaled.

*

A new instance whose slots are unbound has been created.

The generic function initialize-instance is called with the new instance and the defaulted initialization arguments. There is a system-supplied primary method for initialize-instance whose parameter specializer is the class standard-object. This method calls the generic function shared-initialize to fill in the slots according to the initialization arguments and the :initform forms for the slots; the generic function shared-initialize is called with the following arguments: the instance, t, and the defaulted initialization arguments.

Note that initialize-instance provides the defaulted initialization argument list in its call to shared-initialize, so the first step performed by the system-supplied primary method for shared-initialize takes into account both the initialization arguments provided in the call to make-instance and the defaulted initialization argument list.

Methods for initialize-instance can be defined to specify actions to be taken when an instance is initialized. If only after methods for initialize-instance are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of initialize-instance.

The object system provides two functions that are useful in the bodies of initialize-instance methods. The function slot-boundp returns a generic boolean value that indicates whether a specified slot has a value; this provides a mechanism for writing after methods for initialize-instance that initialize slots only if they have not already been initialized. The function slot-makunbound causes the slot to have no value.

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/_002agensym_002dcounter_002a.html0000644000175000017500000000606514360276512020263 0ustar cammcamm *gensym-counter* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.8 *gensym-counter* [Variable]

Value Type::

a non-negative integer.

Initial Value::

implementation-dependent.

Description::

A number which will be used in constructing the name of the next symbol generated by the function gensym.

*gensym-counter* can be either assigned or bound at any time, but its value must always be a non-negative integer.

Affected By::

gensym.

See Also::

gensym

Notes::

The ability to pass a numeric argument to gensym has been deprecated; explicitly binding *gensym-counter* is now stylistically preferred.

gcl-2.6.14/info/gcl/member-_0028Type-Specifier_0029.html0000644000175000017500000000656114360276512020611 0ustar cammcamm member (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.18 member [Type Specifier]

Compound Type Specifier Kind::

Combining.

Compound Type Specifier Syntax::

(member{{object}*})

Compound Type Specifier Arguments::

object—an object.

Compound Type Specifier Description::

This denotes the set containing the named objects. An object is of this type if and only if it is eql to one of the specified objects.

The type specifiers (member) and nil are equivalent. * can be among the objects, but if so it denotes itself (the symbol *) and does not represent an unspecified value. The symbol member is not valid as a type specifier; and, specifically, it is not an abbreviation for either (member) or (member *).

See Also::

the type eql

gcl-2.6.14/info/gcl/FORMAT-Printer-Operations.html0000644000175000017500000000534514360276512020122 0ustar cammcamm FORMAT Printer Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.4 FORMAT Printer Operations

• Tilde A-> Aesthetic  
• Tilde S-> Standard  
• Tilde W-> Write  
gcl-2.6.14/info/gcl/Visible-Modification-of-Structures-with-respect-to-EQUALP.html0000644000175000017500000000517314360276512026173 0ustar cammcamm Visible Modification of Structures with respect to EQUALP (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.6 Visible Modification of Structures with respect to EQUALP

Any visible change to a slot of a structure is considered a visible modification with regard to equalp.

gcl-2.6.14/info/gcl/Examples-of-for_002das_002din_002dlist-subclause.html0000644000175000017500000000556114360276512024066 0ustar cammcamm Examples of for-as-in-list subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.5 Examples of for-as-in-list subclause

;; Print every item in a list.
 (loop for item in '(1 2 3) do (print item))
 |>  1
 |>  2
 |>  3
⇒  NIL

;; Print every other item in a list.
 (loop for item in '(1 2 3 4 5) by #'cddr
       do (print item))
 |>  1
 |>  3
 |>  5
⇒  NIL

;; Destructure a list, and sum the x values using fixnum arithmetic.
 (loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3))
       unless (eq item 'B) sum x)
⇒  4
gcl-2.6.14/info/gcl/Symbols-in-a-Package.html0000644000175000017500000000411014360276512017160 0ustar cammcamm Symbols in a Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.2 Symbols in a Package

gcl-2.6.14/info/gcl/array_002dhas_002dfill_002dpointer_002dp.html0000644000175000017500000000727114360276512022356 0ustar cammcamm array-has-fill-pointer-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.14 array-has-fill-pointer-p [Function]

array-has-fill-pointer-p array ⇒ generalized-boolean

Arguments and Values::

array—an array.

generalized-boolean—a generalized boolean.

Description::

Returns true if array has a fill pointer; otherwise returns false.

Examples::

 (array-has-fill-pointer-p (make-array 4)) ⇒  implementation-dependent
 (array-has-fill-pointer-p (make-array '(2 3))) ⇒  false
 (array-has-fill-pointer-p
   (make-array 8 
               :fill-pointer 2 
               :initial-element 'filler)) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

make-array , fill-pointer

Notes::

Since arrays of rank other than one cannot have a fill pointer, array-has-fill-pointer-p always returns nil when its argument is such an array.

gcl-2.6.14/info/gcl/unuse_002dpackage.html0000644000175000017500000001001314360276512016554 0ustar cammcamm unuse-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.17 unuse-package [Function]

unuse-package packages-to-unuse &optional package ⇒ t

Arguments and Values::

packages-to-unuse—a designator for a list of package designators.

package—a package designator. The default is the current package.

Description::

unuse-package causes package to cease inheriting all the external symbols of packages-to-unuse; unuse-package undoes the effects of use-package. The packages-to-unuse are removed from the use list of package.

Any symbols that have been imported into package continue to be present in package.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (export (intern "SHOES" (make-package 'temp)) 'temp) ⇒  T
 (find-symbol "SHOES") ⇒  NIL, NIL
 (use-package 'temp) ⇒  T
 (find-symbol "SHOES") ⇒  SHOES, :INHERITED
 (find (find-package 'temp) (package-use-list 'common-lisp-user)) ⇒  #<PACKAGE "TEMP">
 (unuse-package 'temp) ⇒  T
 (find-symbol "SHOES") ⇒  NIL, NIL

Side Effects::

The use list of package is modified.

Affected By::

Current state of the package system.

See Also::

use-package , package-use-list

gcl-2.6.14/info/gcl/Case-of-Implementation_002dDefined-Characters.html0000644000175000017500000000500214360276512023677 0ustar cammcamm Case of Implementation-Defined Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.7 Case of Implementation-Defined Characters

An implementation may define that other implementation-defined graphic characters have case. Such definitions must always be done in pairs—one uppercase character in one-to-one correspondence with one lowercase character.

gcl-2.6.14/info/gcl/file_002dstream.html0000644000175000017500000000533314360276512016245 0ustar cammcamm file-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.5 file-stream [System Class]

Class Precedence List::

file-stream, stream, t

Description::

An object of type file-stream is a stream the direct source or sink of which is a file. Such a stream is created explicitly by open and with-open-file, and implicitly by functions such as load that process files.

See Also::

load , open , with-open-file

gcl-2.6.14/info/gcl/Number-Concepts.html0000644000175000017500000000652614360276512016376 0ustar cammcamm Number Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers (Numbers)  

12.1 Number Concepts

• Numeric Operations  
• Implementation-Dependent Numeric Constants  
• Rational Computations  
• Floating-point Computations  
• Complex Computations  
• Interval Designators  
• Random-State Operations  
gcl-2.6.14/info/gcl/Notes-about-Style-for-Sharpsign-Vertical_002dBar.html0000644000175000017500000000602614360276512024324 0ustar cammcamm Notes about Style for Sharpsign Vertical-Bar (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.22 Notes about Style for Sharpsign Vertical-Bar

Some text editors that purport to understand Lisp syntax treat any |...| as balanced pairs that cannot nest (as if they were just balanced pairs of the multiple escapes used in notating certain symbols). To compensate for this deficiency, some programmers use the notation #||...#||...||#...||# instead of #|...#|...|#...|#. Note that this alternate usage is not a different reader macro; it merely exploits the fact that the additional vertical-bars occur within the comment in a way that tricks certain text editor into better supporting nested comments. As such, one might sometimes see code like: 

 #|| (+ #|| 3 ||# 4 5) ||#

Such code is equivalent to: 

 #| (+ #| 3 |# 4 5) |#
gcl-2.6.14/info/gcl/compiler_002dmacro_002dfunction.html0000644000175000017500000000672314360276512021245 0ustar cammcamm compiler-macro-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.8 compiler-macro-function [Accessor]

compiler-macro-function name &optional environment ⇒ function

(setf ( compiler-macro-function name &optional environment) new-function)

Arguments and Values::

name—a function name.

environment—an environment object.

function, new-function—a compiler macro function, or nil.

Description::

Accesses the compiler macro function named name, if any, in the environment.

A value of nil denotes the absence of a compiler macro function named name.

Exceptional Situations::

The consequences are undefined if environment is non-nil in a use of setf of compiler-macro-function.

See Also::

define-compiler-macro , Compiler Macros

gcl-2.6.14/info/gcl/Designators.html0000644000175000017500000001170414360276512015646 0ustar cammcamm Designators (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.12 Designators

A designator is an object that denotes another object.

Where a parameter of an operator is described as a designator, the description of the operator is written in a way that assumes that the value of the parameter is the denoted object; that is, that the parameter is already of the denoted type. (The specific nature of the object denoted by a “<<type>> designator” or a “designator for a <<type>>” can be found in the Glossary entry for “<<type>> designator.”)

For example, “nil” and “the value of *standard-output*” are operationally indistinguishable as stream designators. Similarly, the symbol foo and the string "FOO" are operationally indistinguishable as string designators.

Except as otherwise noted, in a situation where the denoted object might be used multiple times, it is implementation-dependent whether the object is coerced only once or whether the coercion occurs each time the object must be used.

For example, mapcar receives a function designator as an argument, and its description is written as if this were simply a function. In fact, it is implementation-dependent whether the function designator is coerced right away or whether it is carried around internally in the form that it was given as an argument and re-coerced each time it is needed. In most cases, conforming programs cannot detect the distinction, but there are some pathological situations (particularly those involving self-redefining or mutually-redefining functions) which do conform and which can detect this difference. The following program is a conforming program, but might or might not have portably correct results, depending on whether its correctness depends on one or the other of the results: 

 (defun add-some (x) 
   (defun add-some (x) (+ x 2))
   (+ x 1)) ⇒  ADD-SOME
 (mapcar 'add-some '(1 2 3 4))
⇒  (2 3 4 5)
OR⇒ (2 4 5 6)

In a few rare situations, there may be a need in a dictionary entry to refer to the object that was the original designator for a parameter. Since naming the parameter would refer to the denoted object, the phrase “the <<parameter-name>> designator” can be used to refer to the designator which was the argument from which the value of <<parameter-name>> was computed.

Next: , Previous: , Up: Notational Conventions  

gcl-2.6.14/info/gcl/Sharpsign-Left_002dParenthesis.html0000644000175000017500000000730314360276512021145 0ustar cammcamm Sharpsign Left-Parenthesis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.3 Sharpsign Left-Parenthesis

#( and ) are used to notate a simple vector.

If an unsigned decimal integer appears between the # and (, it specifies explicitly the length of the vector. The consequences are undefined if the number of objects specified before the closing ) exceeds the unsigned decimal integer. If the number of objects supplied before the closing ) is less than the unsigned decimal integer but greater than zero, the last object is used to fill all remaining elements of the vector.

[Editorial Note by Barmar: This should say "signals...".] The consequences are undefined if the unsigned decimal integer is non-zero and number of objects supplied before the closing ) is zero. For example, 

 #(a b c c c c)
 #6(a b c c c c)
 #6(a b c)
 #6(a b c c)

all mean the same thing: a vector of length 6 with elements a, b, and four occurrences of c. Other examples follow: 

 #(a b c)               ;A vector of length 3
 #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)
                        ;A vector containing the primes below 50
 #()                    ;An empty vector

The notation #() denotes an empty vector, as does #0().

For information on how the Lisp printer prints vectors, see Printing Strings, Printing Bit Vectors, or Printing Other Vectors.

gcl-2.6.14/info/gcl/Standard-Method-Combination.html0000644000175000017500000002010014360276512020570 0ustar cammcamm Standard Method Combination (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.5 Standard Method Combination

Standard method combination is supported by the class standard-generic-function. It is used if no other type of method combination is specified or if the built-in method combination type standard is specified.

Primary methods define the main action of the effective method, while auxiliary methods modify that action in one of three ways. A primary method has no method qualifiers.

An auxiliary method is a method whose qualifier is :before, :after, or :around. Standard method combination allows no more than one qualifier per method; if a method definition specifies more than one qualifier per method, an error is signaled.

*

A before method has the keyword :before as its only qualifier. A before method specifies code that is to be run before any primary methods.

*

An after method has the keyword :after as its only qualifier. An after method specifies code that is to be run after primary methods.

*

An around method has the keyword :around as its only qualifier. An around method specifies code that is to be run instead of other applicable methods, but which might contain explicit code which calls some of those shadowed methods (via call-next-method).

The semantics of standard method combination is as follows:

*

If there are any around methods, the most specific around method is called. It supplies the value or values of the generic function.

*

Inside the body of an around method, call-next-method can be used to call the next method. When the next method returns, the around method can execute more code, perhaps based on the returned value or values. The generic function no-next-method is invoked if call-next-method is used and there is no applicable method to call. The function next-method-p may be used to determine whether a next method exists.

*

If an around method invokes call-next-method, the next most specific around method is called, if one is applicable. If there are no around methods or if call-next-method is called by the least specific around method, the other methods are called as follows:

–

All the before methods are called, in most-specific-first order. Their values are ignored. An error is signaled if call-next-method is used in a before method.

–

The most specific primary method is called. Inside the body of a primary method, call-next-method may be used to call the next most specific primary method. When that method returns, the previous primary method can execute more code, perhaps based on the returned value or values. The generic function no-next-method is invoked if call-next-method is used and there are no more applicable primary methods. The function next-method-p may be used to determine whether a next method exists. If call-next-method is not used, only the most specific primary method is called.

–

All the after methods are called in most-specific-last order. Their values are ignored. An error is signaled if call-next-method is used in an after method.

*

If no around methods were invoked, the most specific primary method supplies the value or values returned by the generic function. The value or values returned by the invocation of call-next-method in the least specific around method are those returned by the most specific primary method.

In standard method combination, if there is an applicable method but no applicable primary method, an error is signaled.

The before methods are run in most-specific-first order while the after methods are run in least-specific-first order. The design rationale for this difference can be illustrated with an example. Suppose class C_1 modifies the behavior of its superclass, C_2, by adding before methods and after methods. Whether the behavior of the class C_2 is defined directly by methods on C_2 or is inherited from its superclasses does not affect the relative order of invocation of methods on instances of the class C_1. Class C_1’s before method runs before all of class C_2’s methods. Class C_1’s after method runs after all of class C_2’s methods.

By contrast, all around methods run before any other methods run. Thus a less specific around method runs before a more specific primary method.

If only primary methods are used and if call-next-method is not used, only the most specific method is invoked; that is, more specific methods shadow more general ones.

Next: , Previous: , Up: Method Selection and Combination  

gcl-2.6.14/info/gcl/_002afeatures_002a.html0000644000175000017500000002143014360276512016443 0ustar cammcamm *features* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.5 *features* [Variable]

Value Type::

a proper list.

Initial Value::

implementation-dependent.

Description::

The value of *features* is called the features list. It is a list of symbols, called features, that correspond to some aspect of the implementation or environment.

Most features have implementation-dependent meanings; The following meanings have been assigned to feature names:

:cltl1

If present, indicates that the LISP package purports to conform to the 1984 specification Common Lisp: The Language. It is possible, but not required, for a conforming implementation to have this feature because this specification specifies that its symbols are to be in the COMMON-LISP package, not the LISP package.

:cltl2

If present, indicates that the implementation purports to conform to Common Lisp: The Language, Second Edition. This feature must not be present in any conforming implementation, since conformance to that document is not compatible with conformance to this specification. The name, however, is reserved by this specification in order to help programs distinguish implementations which conform to that document from implementations which conform to this specification.

:ieee-floating-point

If present, indicates that the implementation purports to conform to the requirements of IEEE Standard for Binary Floating-Point Arithmetic.

:x3j13

If present, indicates that the implementation conforms to some particular working draft of this specification, or to some subset of features that approximates a belief about what this specification might turn out to contain. A conforming implementation might or might not contain such a feature. (This feature is intended primarily as a stopgap in order to provide implementors something to use prior to the availability of a draft standard, in order to discourage them from introducing the :draft-ansi-cl and :ansi-cl features prematurely.)

:draft-ansi-cl

If present, indicates that the implementation purports to conform to the first full draft of this specification, which went to public review in 1992. A conforming implementation which has the :draft-ansi-cl-2 or :ansi-cl feature is not permitted to retain the :draft-ansi-cl feature since incompatible changes were made subsequent to the first draft.

:draft-ansi-cl-2

If present, indicates that a second full draft of this specification has gone to public review, and that the implementation purports to conform to that specification. (If additional public review drafts are produced, this keyword will continue to refer to the second draft, and additional keywords will be added to identify conformance with such later drafts. As such, the meaning of this keyword can be relied upon not to change over time.) A conforming implementation which has the :ansi-cl feature is only permitted to retain the :draft-ansi-cl feature if the finally approved standard is not incompatible with the draft standard.

:ansi-cl

If present, indicates that this specification has been adopted by ANSI as an official standard, and that the implementation purports to conform.

:common-lisp

This feature must appear in *features* for any implementation that has one or more of the features :x3j13, :draft-ansi-cl, or :ansi-cl. It is intended that it should also appear in implementations which have the features :cltl1 or :cltl2, but this specification cannot force such behavior. The intent is that this feature should identify the language family named “Common Lisp,” rather than some specific dialect within that family.

See Also::

Use of Read-Time Conditionals, Standard Macro Characters

Notes::

The value of *features* is used by the #+ and #- reader syntax.

Symbols in the features list may be in any package, but in practice they are generally in the KEYWORD package. This is because KEYWORD is the package used by default when reading_2 feature expressions in the #+ and #- reader macros. Code that needs to name a feature_2 in a package P (other than KEYWORD) can do so by making explicit use of a package prefix for P, but note that such code must also assure that the package P exists in order for the feature expression to be read_2—even in cases where the feature expression is expected to fail.

It is generally considered wise for an implementation to include one or more features identifying the specific implementation, so that conditional expressions can be written which distinguish idiosyncrasies of one implementation from those of another. Since features are normally symbols in the KEYWORD package where name collisions might easily result, and since no uniquely defined mechanism is designated for deciding who has the right to use which symbol for what reason, a conservative strategy is to prefer names derived from one’s own company or product name, since those names are often trademarked and are hence less likely to be used unwittingly by another implementation.

Next: , Previous: , Up: System Construction Dictionary  

gcl-2.6.14/info/gcl/Reader-Concepts.html0000644000175000017500000000512214360276512016337 0ustar cammcamm Reader Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader  

23.1 Reader Concepts

• Dynamic Control of the Lisp Reader  
• Effect of Readtable Case on the Lisp Reader  
• Argument Conventions of Some Reader Functions  
gcl-2.6.14/info/gcl/lcm.html0000644000175000017500000000705114360276512014137 0ustar cammcamm lcm (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.34 lcm [Function]

lcm &rest integers ⇒ least-common-multiple

Arguments and Values::

integer—an integer.

least-common-multiple—a non-negative integer.

Description::

lcm returns the least common multiple of the integers.

If no integer is supplied, the integer 1 is returned.

If only one integer is supplied, the absolute value of that integer is returned.

For two arguments that are not both zero, 

 (lcm a b) ≡ (/ (abs (* a b)) (gcd a b))

If one or both arguments are zero, 

 (lcm a 0) ≡ (lcm 0 a) ≡ 0

For three or more arguments, 

 (lcm a b c ... z) ≡ (lcm (lcm a b) c ... z)

Examples::

 (lcm 10) ⇒  10
 (lcm 25 30) ⇒  150
 (lcm -24 18 10) ⇒  360
 (lcm 14 35) ⇒  70
 (lcm 0 5) ⇒  0
 (lcm 1 2 3 4 5 6) ⇒  60

Exceptional Situations::

Should signal type-error if any argument is not an integer.

See Also::

gcd

gcl-2.6.14/info/gcl/_002amodules_002a.html0000644000175000017500000000556414360276512016307 0ustar cammcamm *modules* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.10 *modules* [Variable]

Value Type::

a list of strings.

Initial Value::

implementation-dependent.

Description::

The value of *modules* is a list of names of the modules that have been loaded into the current Lisp image.

Affected By::

provide

See Also::

provide , require

Notes::

The variable *modules* is deprecated.

gcl-2.6.14/info/gcl/print_002dnot_002dreadable.html0000644000175000017500000000615214360276512020174 0ustar cammcamm print-not-readable (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.29 print-not-readable [Condition Type]

Class Precedence List::

print-not-readable, error, serious-condition, condition, t

Description::

The type print-not-readable consists of error conditions that occur during output while *print-readably* is true, as a result of attempting to write a printed representation with the Lisp printer that would not be correctly read back with the Lisp reader. The object which could not be printed is initialized by the :object initialization argument to make-condition, and is accessed by the function print-not-readable-object.

See Also::

print-not-readable-object

gcl-2.6.14/info/gcl/Processing-of-Top-Level-Forms.html0000644000175000017500000001624014360276512020773 0ustar cammcamm Processing of Top Level Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: File Compilation  

3.2.3.1 Processing of Top Level Forms

Processing of top level forms in the file compiler is defined as follows:

1.

If the form is a compiler macro form (not disabled by a notinline declaration), the implementation might or might not choose to compute the compiler macro expansion of the form and, having performed the expansion, might or might not choose to process the result as a top level form in the same processing mode (compile-time-too or not-compile-time). If it declines to obtain or use the expansion, it must process the original form.

2.

If the form is a macro form, its macro expansion is computed and processed as a top level form in the same processing mode (compile-time-too or not-compile-time).

3.

If the form is a progn form, each of its body forms is sequentially processed as a top level form in the same processing mode.

4.

If the form is a locally, macrolet, or symbol-macrolet, compile-file establishes the appropriate bindings and processes the body forms as top level forms with those bindings in effect in the same processing mode. (Note that this implies that the lexical environment in which top level forms are processed is not necessarily the null lexical environment.)

5.

If the form is an eval-when form, it is handled according to Figure 3–7.

plus .5 fil \offinterlineskip 

  CT   LT   E    Mode  Action    New Mode          
  _________________________________________________
  Yes  Yes  —  —   Process   compile-time-too  
  No   Yes  Yes   CTT  Process   compile-time-too  
  No   Yes  Yes   NCT  Process   not-compile-time  
  No   Yes  No   —   Process   not-compile-time  
  Yes  No   —  —   Evaluate  —               
  No   No   Yes   CTT  Evaluate  —               
  No   No   Yes   NCT  Discard   —               
  No   No   No   —   Discard   —

  Figure 3–7: EVAL-WHEN processing

Column CT indicates whether :compile-toplevel is specified. Column LT indicates whether :load-toplevel is specified. Column E indicates whether :execute is specified. Column Mode indicates the processing mode; a dash (—) indicates that the processing mode is not relevant.

The Action column specifies one of three actions:

Process: process the body as top level forms in the specified mode.

Evaluate: evaluate the body in the dynamic execution context of the compiler, using the evaluation environment as the global environment and the lexical environment in which the eval-when appears.

Discard: ignore the form.

The New Mode column indicates the new processing mode. A dash (—) indicates the compiler remains in its current mode.

6.

Otherwise, the form is a top level form that is not one of the special cases. In compile-time-too mode, the compiler first evaluates the form in the evaluation environment and then minimally compiles it. In not-compile-time mode, the form is simply minimally compiled. All subforms are treated as non-top-level forms.

Note that top level forms are processed in the order in which they textually appear in the file and that each top level form read by the compiler is processed before the next is read. However, the order of processing (including macro expansion) of subforms that are not top level forms and the order of further compilation is unspecified as long as Common Lisp semantics are preserved.

eval-when forms cause compile-time evaluation only at top level. Both :compile-toplevel and :load-toplevel situation specifications are ignored for non-top-level forms. For non-top-level forms, an eval-when specifying the :execute situation is treated as an implicit progn including the forms in the body of the eval-when form; otherwise, the forms in the body are ignored.

Next: , Previous: , Up: File Compilation  

gcl-2.6.14/info/gcl/multiple_002dvalue_002dprog1.html0000644000175000017500000000655114360276512020503 0ustar cammcamm multiple-value-prog1 (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.51 multiple-value-prog1 [Special Operator]

multiple-value-prog 1 ⇒ first-form {form}*

first-form-results

Arguments and Values::

first-form—a form; evaluated as described below.

form—a form; evaluated as described below.

first-form-results—the values resulting from the evaluation of first-form.

Description::

multiple-value-prog1 evaluates first-form and saves all the values produced by that form. It then evaluates each form from left to right, discarding their values.

Examples::

 (setq temp '(1 2 3)) ⇒  (1 2 3)
 (multiple-value-prog1
    (values-list temp)
    (setq temp nil)
    (values-list temp)) ⇒  1, 2, 3

See Also::

prog1

gcl-2.6.14/info/gcl/FORMAT-Miscellaneous-Operations.html0000644000175000017500000000562314360276512021301 0ustar cammcamm FORMAT Miscellaneous Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.8 FORMAT Miscellaneous Operations

• Tilde Left-Paren-> Case Conversion  
• Tilde Right-Paren-> End of Case Conversion  
• Tilde P-> Plural  
gcl-2.6.14/info/gcl/with_002dslots.html0000644000175000017500000001676214360276512016162 0ustar cammcamm with-slots (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.24 with-slots [Macro]

with-slots ({slot-entry}*) instance-form {declaration}* {form}*
⇒ {result}*

slot-entry ::=slot-name | (variable-name slot-name)

Arguments and Values::

slot-name—a slot name; not evaluated.

variable-name—a variable name; not evaluated.

instance-form—a form; evaluted to produce instance.

instance—an object.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

The macro with-slots establishes a lexical environment for referring to the slots in the instance named by the given slot-names as though they were variables. Within such a context the value of the slot can be specified by using its slot name, as if it were a lexically bound variable. Both setf and setq can be used to set the value of the slot.

The macro with-slots translates an appearance of the slot name as a variable into a call to slot-value.

Examples::

 (defclass thing ()
           ((x :initarg :x :accessor thing-x)
            (y :initarg :y :accessor thing-y)))
⇒  #<STANDARD-CLASS THING 250020173>
 (defmethod (setf thing-x) :before (new-x (thing thing))
   (format t "~&Changing X from ~D to ~D in ~S.~
           (thing-x thing) new-x thing))
 (setq thing (make-instance 'thing :x 0 :y 1)) ⇒  #<THING 62310540>
 (with-slots (x y) thing (incf x) (incf y)) ⇒  2
 (values (thing-x thing) (thing-y thing)) ⇒  1, 2
 (setq thing1 (make-instance 'thing :x 1 :y 2)) ⇒  #<THING 43135676>
 (setq thing2 (make-instance 'thing :x 7 :y 8)) ⇒  #<THING 43147374>
 (with-slots ((x1 x) (y1 y))
             thing1
   (with-slots ((x2 x) (y2 y))
               thing2
     (list (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2))
           (setq x1 (+ y1 x2))
           (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2))
           (setf (thing-x thing2) (list x1))
           (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2)))))
 |>  Changing X from 7 to (9) in #<THING 43147374>.
⇒  ((1 1 2 2 7 7 8 8)
     9
     (9 9 2 2 7 7 8 8) 
     (9)
     (9 9 2 2 (9) (9) 8 8))

Affected By::

defclass

Exceptional Situations::

The consequences are undefined if any slot-name is not the name of a slot in the instance.

See Also::

with-accessors , slot-value , symbol-macrolet

Notes::

A with-slots expression of the form: 


(with-slots (slot-entry_1 ...slot-entry_n) instance-form form_1 ...form_k)

expands into the equivalent of 


(let ((in instance-form))

 (symbol-macrolet (Q_1... Q_n) form_1 ...form_k))

where Q_i is 

(slot-entry_i () 
(slot-value in 'slot-entry_i))

if slot-entry_i is a symbol and is 

(variable-name_i () 
(slot-value in 'slot-name_i))

if slot-entry_i is of the form 

(variable-name_i 
slot-name_i)

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/Data-Type-Definition.html0000644000175000017500000000675514360276512017254 0ustar cammcamm Data Type Definition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types  

4.2.1 Data Type Definition

Information about type usage is located in the sections specified in Figure~4–1. Figure~4–7 lists some classes that are particularly relevant to the object system. Figure~9–1 lists the defined condition types. 

  Section                                Data Type                         
  _________________________________________________________________________
  Classes                        Object System types               
  Slots                          Object System types               
  Objects                        Object System types               
  Generic Functions and Methods  Object System types               
  Condition System Concepts      Condition System types            
  Types and Classes              Miscellaneous types               
  Syntax                         All types—read and print syntax  
  The Lisp Printer               All types—print syntax           
  Compilation                    All types—compilation issues     

           Figure 4–1: Cross-References to Data Type Information
gcl-2.6.14/info/gcl/Reinitializing-an-Instance.html0000644000175000017500000000736414360276512020512 0ustar cammcamm Reinitializing an Instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.3 Reinitializing an Instance

The generic function reinitialize-instance may be used to change the values of slots according to initialization arguments.

The process of reinitialization changes the values of some slots and performs any user-defined actions. It does not modify the structure of an instance to add or delete slots, and it does not use any :initform forms to initialize slots.

The generic function reinitialize-instance may be called directly. It takes one required argument, the instance. It also takes any number of initialization arguments to be used by methods for reinitialize-instance or for shared-initialize. The arguments after the required instance must form an initialization argument list.

There is a system-supplied primary method for reinitialize-instance whose parameter specializer is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see Declaring the Validity of Initialization Arguments.) Then it calls the generic function shared-initialize with the following arguments: the instance, nil, and the initialization arguments it received.

• Customizing Reinitialization  
gcl-2.6.14/info/gcl/System-Construction.html0000644000175000017500000000451014360276512017335 0ustar cammcamm System Construction (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

24 System Construction

• System Construction Concepts  
• System Construction Dictionary  
gcl-2.6.14/info/gcl/Random_002dState-Operations.html0000644000175000017500000000433714360276512020457 0ustar cammcamm Random-State Operations (ANSI and GNU Common Lisp Document)

Previous: , Up: Number Concepts  

12.1.7 Random-State Operations

Figure 12–10 lists some defined names that are applicable to random states. 

  *random-state*     random            
  make-random-state  random-state-p    

  Figure 12–10: Random-state defined names
gcl-2.6.14/info/gcl/format.html0000644000175000017500000001064414360276512014656 0ustar cammcamm format (ANSI and GNU Common Lisp Document)

Previous: , Up: Printer Dictionary  

22.4.31 format [Function]

format destination control-string &rest args ⇒ result

Arguments and Values::

destination—nil, t, a stream, or a string with a fill pointer.

control-string—a format control.

args—format arguments for control-string.

result—if destination is non-nil, then nil; otherwise, a string.

Description::

format produces formatted output by outputting the characters of control-string and observing that a tilde introduces a directive. The character after the tilde, possibly preceded by prefix parameters and modifiers, specifies what kind of formatting is desired. Most directives use one or more elements of args to create their output.

If destination is a string, a stream, or t, then the result is nil. Otherwise, the result is a string containing the ‘output.’

format is useful for producing nicely formatted text, producing good-looking messages, and so on. format can generate and return a string or output to destination.

For details on how the control-string is interpreted, see Formatted Output.

Affected By::

*standard-output*, *print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*.

Exceptional Situations::

If destination is a string with a fill pointer, the consequences are undefined if destructive modifications are performed directly on the string during the dynamic extent of the call.

See Also::

write , Documentation of Implementation-Defined Scripts

gcl-2.6.14/info/gcl/Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Programs.html0000644000175000017500000001350514360276512027273 0ustar cammcamm Constraints on the COMMON-LISP Package for Conforming Programs (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.3 Constraints on the COMMON-LISP Package for Conforming Programs

Except where explicitly allowed, the consequences are undefined if any of the following actions are performed on an external symbol of the COMMON-LISP package:

1.

Binding or altering its value (lexically or dynamically). (Some exceptions are noted below.)

2.

Defining,

undefining,

or binding it as a function. (Some exceptions are noted below.)

3.

Defining,

undefining,

or binding it as a macro

or compiler macro.

(Some exceptions are noted below.)

4.

Defining it as a type specifier (via defstruct, defclass, deftype, define-condition).

5.

Defining it as a structure (via defstruct).

6.

Defining it as a declaration with a declaration proclamation.

7.

Defining it as a symbol macro.

8.

Altering its home package.

9.

Tracing it (via trace).

10.

Declaring or proclaiming it special (via declare,

declaim,

or proclaim).

11.

Declaring or proclaiming its type or ftype (via declare,

declaim,

or proclaim). (Some exceptions are noted below.)

12.

Removing it from the COMMON-LISP package.

13.

Defining a setf expander for it (via defsetf or define-setf-method).

14.

Defining, undefining, or binding its setf function name.

15.

Defining it as a method combination type (via define-method-combination).

16.

Using it as the class-name argument to setf of find-class.

17.

Binding it as a catch tag.

18.

Binding it as a restart name.

19.

Defining a method for a standardized generic function which is applicable when all of the arguments are direct instances of standardized classes.

Next: , Previous: , Up: Standardized Packages  

gcl-2.6.14/info/gcl/Data_002ddirected-Destructuring-by-Lambda-Lists.html0000644000175000017500000000512214360276512024205 0ustar cammcamm Data-directed Destructuring by Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Macro Lambda Lists  

3.4.4.2 Data-directed Destructuring by Lambda Lists

In data-directed destructuring, the pattern is a sample object of the type to be decomposed. Wherever a component is to be extracted, a symbol appears in the pattern; this symbol is the name of the variable whose value will be that component.

gcl-2.6.14/info/gcl/file_002dstring_002dlength.html0000644000175000017500000000557714360276512020221 0ustar cammcamm file-string-length (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.28 file-string-length [Function]

file-string-length stream object ⇒ length

Arguments and Values::

stream—an output character file stream.

object—a string or a character.

length—a non-negative integer, or nil.

Description::

file-string-length returns the difference between what (file-position stream) would be after writing object and its current value, or nil if this cannot be determined.

The returned value corresponds to the current state of stream at the time of the call and might not be the same if it is called again when the state of the stream has changed.

gcl-2.6.14/info/gcl/Destructuring-Lambda-Lists.html0000644000175000017500000001300314360276512020472 0ustar cammcamm Destructuring Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.5 Destructuring Lambda Lists

A destructuring lambda list is used by destructuring-bind.

Destructuring lambda lists are closely related to macro lambda lists; see Macro Lambda Lists. A destructuring lambda list can contain all of the lambda list keywords listed for macro lambda lists except for &environment, and supports destructuring in the same way. Inner lambda lists nested within a macro lambda list have the syntax of destructuring lambda lists.

A destructuring lambda list has the following syntax:

reqvars ::={var | !lambda-list}*

optvars ::=[&optional {var |         ({var | !lambda-list} [init-form [supplied-p-parameter]])}*]

restvar ::=[{&rest | &body} {var | !lambda-list}]

keyvars ::=[&key {var |              ({var |          (keyword-name {var | !lambda-list})}    [init-form [supplied-p-parameter]])}*             [&allow-other-keys]]

auxvars ::=[&aux {var | (var [init-form])}*]

envvar ::=[&environment var]

wholevar ::=[&whole var]

lambda-list ::=(!wholevar !reqvars !optvars !restvar !keyvars !auxvars) |                 (!wholevar !reqvars !optvars . var)

gcl-2.6.14/info/gcl/make_002dconcatenated_002dstream.html0000644000175000017500000000663014360276512021342 0ustar cammcamm make-concatenated-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.47 make-concatenated-stream [Function]

make-concatenated-stream &rest input-streams ⇒ concatenated-stream

Arguments and Values::

input-stream—an input stream.

concatenated-stream—a concatenated stream.

Description::

Returns a concatenated stream that has the indicated input-streams initially associated with it.

Examples::

 (read (make-concatenated-stream
         (make-string-input-stream "1")
         (make-string-input-stream "2"))) ⇒  12

Exceptional Situations::

Should signal type-error if any argument is not an input stream.

See Also::

concatenated-stream-streams

gcl-2.6.14/info/gcl/time.html0000644000175000017500000001045214360276512014321 0ustar cammcamm time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.10 time [Macro]

time form ⇒ {result}*

Arguments and Values::

form—a form; evaluated as described below.

results—the values returned by the form.

Description::

time evaluates form in the current environment (lexical and dynamic). A call to time can be compiled.

time prints various timing data and other information to trace output. The nature and format of the printed information is implementation-defined. Implementations are encouraged to provide such information as elapsed real time, machine run time, and storage management statistics.

Affected By::

The accuracy of the results depends, among other things, on the accuracy of the corresponding functions provided by the underlying operating system.

The magnitude of the results may depend on the hardware, the operating system, the lisp implementation, and the state of the global environment. Some specific issues which frequently affect the outcome are hardware speed, nature of the scheduler (if any), number of competing processes (if any), system paging, whether the call is interpreted or compiled, whether functions called are compiled, the kind of garbage collector involved and whether it runs, whether internal data structures (e.g., hash tables) are implicitly reorganized, etc.

See Also::

get-internal-real-time , get-internal-run-time

Notes::

In general, these timings are not guaranteed to be reliable enough for marketing comparisons. Their value is primarily heuristic, for tuning purposes.

For useful background information on the complicated issues involved in interpreting timing results, see Performance and Evaluation of Lisp Programs.

gcl-2.6.14/info/gcl/Selecting-the-Applicable-Methods.html0000644000175000017500000000457514360276512021522 0ustar cammcamm Selecting the Applicable Methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.2 Selecting the Applicable Methods

This step is described in Introduction to Methods.

gcl-2.6.14/info/gcl/Documentation-of-Implementation_002dDefined-Scripts.html0000644000175000017500000000732014360276512025212 0ustar cammcamm Documentation of Implementation-Defined Scripts (ANSI and GNU Common Lisp Document)

Previous: , Up: Character Concepts  

13.1.10 Documentation of Implementation-Defined Scripts

An implementation must document the character scripts it supports. For each character script supported, the documentation must describe at least the following:

*

Character labels, glyphs, and descriptions. Character labels must be uniquely named using only Latin capital letters A–Z, hyphen (-), and digits 0–9.

*

Reader canonicalization. Any mechanisms by which read treats different characters as equivalent must be documented.

*

The impact on char-upcase, char-downcase, and the case-sensitive format directives. In particular, for each character with case, whether it is uppercase or lowercase, and which character is its equivalent in the opposite case.

*

The behavior of the case-insensitive functions char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, and char-not-lessp.

*

The behavior of any character predicates; in particular, the effects of alpha-char-p, lower-case-p, upper-case-p, both-case-p, graphic-char-p, and alphanumericp.

*

The interaction with file I/O, in particular, the supported coded character sets (for example, ISO8859/1-1987) and external encoding schemes supported are documented.

gcl-2.6.14/info/gcl/apropos.html0000644000175000017500000000767214360276512015060 0ustar cammcamm apropos (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.5 apropos, apropos-list [Function]

apropos string &optional package ⇒ <no values>

apropos-list string &optional package ⇒ symbols

Arguments and Values::

string—a string designator.

package—a package designator or nil. The default is nil.

symbols—a list of symbols.

Description::

These functions search for interned symbols whose names contain the substring string.

For apropos, as each such symbol is found, its name is printed on standard output. In addition, if such a symbol is defined as a function or dynamic variable, information about those definitions might also be printed.

For apropos-list, no output occurs as the search proceeds; instead a list of the matching symbols is returned when the search is complete.

If package is non-nil, only the symbols accessible in that package are searched; otherwise all symbols accessible in any package are searched.

Because a symbol might be available by way of more than one inheritance path, apropos might print information about the same symbol more than once, or apropos-list might return a list containing duplicate symbols.

Whether or not the search is case-sensitive is implementation-defined.

Affected By::

The set of symbols which are currently interned in any packages being searched.

apropos is also affected by *standard-output*.

gcl-2.6.14/info/gcl/Other-Syntax-in-a-Logical-Pathname-Namestring.html0000644000175000017500000000500414360276512023757 0ustar cammcamm Other Syntax in a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.9 Other Syntax in a Logical Pathname Namestring

The consequences of using characters other than those specified here in a logical pathname namestring are unspecified.

The consequences of using any value not specified here as a logical pathname component are unspecified.

gcl-2.6.14/info/gcl/function-_0028Special-Operator_0029.html0000644000175000017500000001245014360276512021502 0ustar cammcamm function (Special Operator) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.8 function [Special Operator]

function name ⇒ function

Arguments and Values::

name—a function name or lambda expression.

function—a function object.

Description::

The value of function is the functional value of name in the current lexical environment.

If name is a function name, the functional definition of that name is that established by the innermost lexically enclosing flet, labels, or macrolet form, if there is one. Otherwise the global functional definition of the function name is returned.

If name is a lambda expression, then a lexical closure is returned. In situations where a closure over the same set of bindings might be produced more than once, the various resulting closures might or might not be eq.

It is an error to use function on a function name that does not denote a function in the lexical environment in which the function form appears. Specifically, it is an error to use function on a symbol that denotes a macro or special form. An implementation may choose not to signal this error for performance reasons, but implementations are forbidden from defining the failure to signal an error as a useful behavior.

Examples::

 (defun adder (x) (function (lambda (y) (+ x y))))

The result of (adder 3) is a function that adds 3 to its argument: 

 (setq add3 (adder 3))
 (funcall add3 5) ⇒  8

This works because function creates a closure of the lambda expression that is able to refer to the value 3 of the variable x even after control has returned from the function adder.

See Also::

defun , fdefinition , flet , labels, symbol-function , Symbols as Forms, Sharpsign Single-Quote, Printing Other Objects

Notes::

The notation #'name may be used as an abbreviation for (function name).

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Tilde-Left_002dParen_002d_003e-Case-Conversion.html0000644000175000017500000000715414360276512023304 0ustar cammcamm Tilde Left-Paren-> Case Conversion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Miscellaneous Operations  

22.3.8.1 Tilde Left-Paren: Case Conversion

~(str~)

The contained control string str is processed, and what it produces is subject to case conversion.

With no flags, every uppercase character is converted to the corresponding lowercase character.

~:( capitalizes all words, as if by string-capitalize.

~@( capitalizes just the first word and forces the rest to lower case.

~:@( converts every lowercase character to the corresponding uppercase character.

In this example ~@( is used to cause the first word produced by ~@R to be capitalized: 

 (format nil "~@R ~(~@R~)" 14 14) 
⇒  "XIV xiv"
 (defun f (n) (format nil "~@(~R~) error~:P detected." n)) ⇒  F
 (f 0) ⇒  "Zero errors detected."
 (f 1) ⇒  "One error detected."
 (f 23) ⇒  "Twenty-three errors detected."

When case conversions appear nested, the outer conversion dominates, as illustrated in the following example: 

 (format nil "~@(how is ~:(BOB SMITH~)?~)")
 ⇒  "How is bob smith?"
 NOT⇒ "How is Bob Smith?"
gcl-2.6.14/info/gcl/Treatment-of-Exceptional-Situations.html0000644000175000017500000000463414360276512022346 0ustar cammcamm Treatment of Exceptional Situations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.4 Treatment of Exceptional Situations

A conforming implementation shall treat exceptional situations in a manner consistent with this specification.

gcl-2.6.14/info/gcl/optimize.html0000644000175000017500000001313714360276512015226 0ustar cammcamm optimize (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.25 optimize [Declaration]

Syntax::

(optimize {quality | (quality value)}*)

Arguments::

quality—an optimize quality.

value—one of the integers 0, 1, 2, or 3.

Valid Context::

declaration or proclamation

Description::

Advises the compiler that each quality should be given attention according to the specified corresponding value. Each quality must be a symbol naming an optimize quality; the names and meanings of the standard optimize qualities are shown in Figure 3–25. 

  Name               Meaning                            
  compilation-speed  speed of the compilation process   
  debug              ease of debugging                  
  safety             run-time error checking            
  space              both code size and run-time space  
  speed              speed of the object code           

             Figure 3–25: Optimize qualities

There may be other, implementation-defined optimize qualities.

A value 0 means that the corresponding quality is totally unimportant, and 3 that the quality is extremely important; 1 and 2 are intermediate values, with 1 the neutral value. (quality 3) can be abbreviated to quality.

Note that code which has the optimization (safety 3), or just safety, is called safe code.

The consequences are unspecified if a quality appears more than once with different values.

Examples::

 (defun often-used-subroutine (x y)
   (declare (optimize (safety 2)))
   (error-check x y)
   (hairy-setup x)
   (do ((i 0 (+ i 1))
        (z x (cdr z)))
       ((null z))
     ;; This inner loop really needs to burn.
     (declare (optimize speed))
     (declare (fixnum i))
     ))

See Also::

declare, declaim , proclaim , Declaration Scope

Notes::

An optimize declaration never applies to either a variable or a function binding. An optimize declaration can only be a free declaration. For more information, see Declaration Scope.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Satisfying-a-Two_002dArgument-Test.html0000644000175000017500000001340114360276512021632 0ustar cammcamm Satisfying a Two-Argument Test (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Rules about Test Functions  

17.2.1 Satisfying a Two-Argument Test

When an object O is being considered iteratively against each element E_i of a sequence S by an operator F listed in Figure 17–2, it is sometimes useful to control the way in which the presence of O is tested in S is tested by F. This control is offered on the basis of a function designated with either a :test or :test-not argument. 

  adjoin           nset-exclusive-or  search            
  assoc            nsublis            set-difference    
  count            nsubst             set-exclusive-or  
  delete           nsubstitute        sublis            
  find             nunion             subsetp           
  intersection     position           subst             
  member           pushnew            substitute        
  mismatch         rassoc             tree-equal        
  nintersection    remove             union             
  nset-difference  remove-duplicates                    

  Figure 17–2: Operators that have Two-Argument Tests to be Satisfied

The object O might not be compared directly to E_i. If a :key argument is provided, it is a designator for a function of one argument to be called with each E_i as an argument, and yielding an object Z_i to be used for comparison. (If there is no :key argument, Z_i is E_i.)

The function designated by the :key argument is never called on O itself. However, if the function operates on multiple sequences (e.g., as happens in set-difference), O will be the result of calling the :key function on an element of the other sequence.

A :test argument, if supplied to F, is a designator for a function of two arguments, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to satisfy the test

if this :test function returns a generalized boolean representing true.

A :test-not argument, if supplied to F, is designator for a function of two arguments, O and Z_i. An E_i is said (or, sometimes, an O and an E_i are said) to satisfy the test

if this :test-not function returns a generalized boolean representing false.

If neither a :test nor a :test-not argument is supplied, it is as if a :test argument of #'eql was supplied.

The consequences are unspecified if both a :test and a :test-not argument are supplied in the same call to F.

• Examples of Satisfying a Two-Argument Test  

Next: , Previous: , Up: Rules about Test Functions  

gcl-2.6.14/info/gcl/eval_002dwhen.html0000644000175000017500000002356614360276512015733 0ustar cammcamm eval-when (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.5 eval-when [Special Operator]

eval-when ({situation}*) {form}* ⇒ {result}*

Arguments and Values::

situation—One of the symbols :compile-toplevel , :load-toplevel , :execute , compile , load , or eval .

The use of eval, compile, and load is deprecated.

forms—an implicit progn.

results—the values of the forms if they are executed, or nil if they are not.

Description::

The body of an eval-when form is processed as an implicit progn, but only in the situations listed.

The use of the situations :compile-toplevel (or compile) and :load-toplevel (or load) controls whether and when evaluation occurs when eval-when appears as a top level form in code processed by compile-file. See File Compilation.

The use of the situation :execute (or eval) controls whether evaluation occurs for other eval-when forms; that is, those that are not top level forms, or those in code processed by eval or compile. If the :execute situation is specified in such a form, then the body forms are processed as an implicit progn; otherwise, the eval-when form returns nil.

eval-when normally appears as a top level form, but it is meaningful for it to appear as a non-top-level form. However, the compile-time side effects described in Compilation only take place when eval-when appears as a top level form.

Examples::

One example of the use of eval-when is that for the compiler to be able to read a file properly when it uses user-defined reader macros, it is necessary to write 

 (eval-when (:compile-toplevel :load-toplevel :execute)
   (set-macro-character #\$ #'(lambda (stream char)
                                (declare (ignore char))
                                (list 'dollar (read stream))))) ⇒  T

This causes the call to set-macro-character to be executed in the compiler’s execution environment, thereby modifying its reader syntax table. 

;;;     The EVAL-WHEN in this case is not at toplevel, so only the :EXECUTE
;;;     keyword is considered. At compile time, this has no effect.
;;;     At load time (if the LET is at toplevel), or at execution time
;;;     (if the LET is embedded in some other form which does not execute
;;;     until later) this sets (SYMBOL-FUNCTION 'FOO1) to a function which
;;;     returns 1.
 (let ((x 1))
   (eval-when (:execute :load-toplevel :compile-toplevel)
     (setf (symbol-function 'foo1) #'(lambda () x))))

;;;     If this expression occurs at the toplevel of a file to be compiled,
;;;     it has BOTH a compile time AND a load-time effect of setting
;;;     (SYMBOL-FUNCTION 'FOO2) to a function which returns 2.
 (eval-when (:execute :load-toplevel :compile-toplevel)
   (let ((x 2))
     (eval-when (:execute :load-toplevel :compile-toplevel)
       (setf (symbol-function 'foo2) #'(lambda () x)))))

;;;     If this expression occurs at the toplevel of a file to be compiled,
;;;     it has BOTH a compile time AND a load-time effect of setting the
;;;     function cell of FOO3 to a function which returns 3.
 (eval-when (:execute :load-toplevel :compile-toplevel)
   (setf (symbol-function 'foo3) #'(lambda () 3)))

;;; #4: This always does nothing. It simply returns NIL.
 (eval-when (:compile-toplevel)
   (eval-when (:compile-toplevel) 
     (print 'foo4)))

;;;     If this form occurs at toplevel of a file to be compiled, FOO5 is
;;;     printed at compile time. If this form occurs in a non-top-level
;;;     position, nothing is printed at compile time. Regardless of context,
;;;     nothing is ever printed at load time or execution time.
 (eval-when (:compile-toplevel) 
   (eval-when (:execute)
     (print 'foo5)))

;;;     If this form occurs at toplevel of a file to be compiled, FOO6 is
;;;     printed at compile time.  If this form occurs in a non-top-level
;;;     position, nothing is printed at compile time. Regardless of context,
;;;     nothing is ever printed at load time or execution time.
 (eval-when (:execute :load-toplevel)
   (eval-when (:compile-toplevel)
     (print 'foo6)))

See Also::

compile-file , Compilation

Notes::

The following effects are logical consequences of the definition of eval-when:

*

Execution of a single eval-when expression executes the body code at most once.

*

Macros intended for use in top level forms should be written so that side-effects are done by the forms in the macro expansion. The macro-expander itself should not do the side-effects.

For example:

Wrong: 

 (defmacro foo ()
   (really-foo)
   `(really-foo))

Right: 

 (defmacro foo ()
   `(eval-when (:compile-toplevel :execute :load-toplevel) (really-foo)))

Adherence to this convention means that such macros behave intuitively when appearing as non-top-level forms.

*

Placing a variable binding around an eval-when reliably captures the binding because the compile-time-too mode cannot occur (i.e., introducing a variable binding means that the eval-when is not a top level form). For example, 

 (let ((x 3))
   (eval-when (:execute :load-toplevel :compile-toplevel) (print x)))

prints 3 at execution (i.e., load) time, and does not print anything at compile time. This is important so that expansions of defun and defmacro can be done in terms of eval-when and can correctly capture the lexical environment. 

 (defun bar (x) (defun foo () (+ x 3)))

might expand into 

 (defun bar (x) 
   (progn (eval-when (:compile-toplevel) 
            (compiler::notice-function-definition 'foo '(x)))
          (eval-when (:execute :load-toplevel)
            (setf (symbol-function 'foo) #'(lambda () (+ x 3))))))

which would be treated by the above rules the same as 

 (defun bar (x) 
   (setf (symbol-function 'foo) #'(lambda () (+ x 3))))

when the definition of bar is not a top level form.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Condition-System-Concepts.html0000644000175000017500000001634014360276512020351 0ustar cammcamm Condition System Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions  

9.1 Condition System Concepts

Common Lisp constructs are described not only in terms of their behavior in situations during which they are intended to be used (see the “Description” part of each operator specification), but in all other situations (see the “Exceptional Situations” part of each operator specification).

A situation is the evaluation of an expression in a specific context. A condition is an object that represents a specific situation that has been detected. Conditions are generalized instances of the class condition. A hierarchy of condition classes is defined in Common Lisp. A condition has slots that contain data relevant to the situation that the condition represents.

An error is a situation in which normal program execution cannot continue correctly without some form of intervention (either interactively by the user or under program control). Not all errors are detected. When an error goes undetected, the effects can be implementation-dependent, implementation-defined, unspecified, or undefined. See Definitions. All detected errors can be represented by conditions, but not all conditions represent errors.

Signaling is the process by which a condition can alter the flow of control in a program by raising the condition which can then be handled. The functions error, cerror, signal, and warn are used to signal conditions.

The process of signaling involves the selection and invocation of a handler from a set of active handlers. A handler is a function of one argument (the condition) that is invoked to handle a condition. Each handler is associated with a condition type, and a handler will be invoked only on a condition of the handler’s associated type.

Active handlers are established dynamically (see handler-bind or handler-case). Handlers are invoked in a dynamic environment equivalent to that of the signaler, except that the set of active handlers is bound in such a way as to include only those that were active at the time the handler being invoked was established. Signaling a condition has no side-effect on the condition, and there is no dynamic state contained in a condition.

If a handler is invoked, it can address the situation in one of three ways:

Decline

It can decline to handle the condition. It does this by simply returning rather than transferring control. When this happens, any values returned by the handler are ignored and the next most recently established handler is invoked. If there is no such handler and the signaling function is error or cerror, the debugger is entered in the dynamic environment of the signaler. If there is no such handler and the signaling function is either signal or warn, the signaling function simply returns~nil.

Handle

It can handle the condition by performing a non-local transfer of control. This can be done either primitively by using go, return, throw or more abstractly by using a function such as abort or invoke-restart.

Defer

It can put off a decision about whether to handle or decline, by any of a number of actions, but most commonly by signaling another condition, resignaling the same condition, or forcing entry into the debugger.

• Condition Types  
• Creating Conditions  
• Printing Conditions  
• Signaling and Handling Conditions  
• Assertions  
• Notes about the Condition System`s Background  

Next: , Previous: , Up: Conditions  

gcl-2.6.14/info/gcl/or-_0028Type-Specifier_0029.html0000644000175000017500000000661214360276512017757 0ustar cammcamm or (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.21 or [Type Specifier]

Compound Type Specifier Kind::

Combining.

Compound Type Specifier Syntax::

(or{{typespec}*})

Compound Type Specifier Arguments::

typespec—a type specifier.

Compound Type Specifier Description::

This denotes the set of all objects of the type determined by the union of the typespecs. For example, the type list by definition is the same as (or null cons). Also, the value returned by position is an object of type (or null (integer 0 *)); i.e., either nil or a non-negative integer.

* is not permitted as an argument.

The type specifiers (or) and nil are equivalent. The symbol or is not valid as a type specifier; and, specifically, it is not an abbreviation for (or).

gcl-2.6.14/info/gcl/Seconds.html0000644000175000017500000000451114360276512014760 0ustar cammcamm Seconds (ANSI and GNU Common Lisp Document)

Previous: , Up: Time  

25.1.4.4 Seconds

One function, sleep, takes its argument as a non-negative real number of seconds. Informally, it may be useful to think of this as a relative universal time, but it differs in one important way: universal times are always non-negative integers, whereas the argument to sleep can be any kind of non-negative real, in order to allow for the possibility of fractional seconds. 

  sleep    

  Figure 25–8: Defined names involving time in Seconds.
gcl-2.6.14/info/gcl/Lexical-Variables.html0000644000175000017500000000615114360276512016653 0ustar cammcamm Lexical Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.3 Lexical Variables

A lexical variable is a variable that can be referenced only within the lexical scope of the form that establishes that variable; lexical variables have lexical scope. Each time a form creates a lexical binding of a variable, a fresh binding is established.

Within the scope of a binding for a lexical variable name, uses of that name as a variable are considered to be references to that binding except where the variable is shadowed_2 by a form that establishes a fresh binding for that variable name, or by a form that locally declares the name special.

A lexical variable always has a value. There is no operator that introduces a binding for a lexical variable without giving it an initial value, nor is there any operator that can make a lexical variable be unbound.

Bindings of lexical variables are found in the lexical environment.

gcl-2.6.14/info/gcl/ldiff.html0000644000175000017500000001530114360276512014445 0ustar cammcamm ldiff (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.30 ldiff, tailp [Function]

ldiff list object ⇒ result-list

tailp object list ⇒ generalized-boolean

Arguments and Values::

list—a list,

which might be a dotted list.

object—an object.

result-list—a list.

generalized-boolean—a generalized boolean.

Description::

If object is the same as some tail of list, tailp returns true; otherwise, it returns false.

If object is the same as some tail of list, ldiff returns a fresh list of the elements of list that precede object in the list structure of list; otherwise, it returns a copy_2 of list.

Examples::

 (let ((lists '#((a b c) (a b c . d))))
   (dotimes (i (length lists)) ()
     (let ((list (aref lists i)))
       (format t "~2&list=~S ~21T(tailp object list)~
                  ~44T(ldiff list object)~
         (let ((objects (vector list (cddr list) (copy-list (cddr list))
                                '(f g h) '() 'd 'x)))
           (dotimes (j (length objects)) ()
             (let ((object (aref objects j)))
               (format t "~& object=~S ~21T~S ~44T~S"
                       object (tailp object list) (ldiff list object))))))))
 |>  
 |>  list=(A B C)         (tailp object list)    (ldiff list object)
 |>   object=(A B C)      T                      NIL
 |>   object=(C)          T                      (A B)
 |>   object=(C)          NIL                    (A B C)
 |>   object=(F G H)      NIL                    (A B C)
 |>   object=NIL          T                      (A B C)
 |>   object=D            NIL                    (A B C)
 |>   object=X            NIL                    (A B C)
 |>  
 |>  list=(A B C . D)     (tailp object list)    (ldiff list object)
 |>   object=(A B C . D)  T                      NIL
 |>   object=(C . D)      T                      (A B)
 |>   object=(C . D)      NIL                    (A B C . D)
 |>   object=(F G H)      NIL                    (A B C . D)
 |>   object=NIL          NIL                    (A B C . D)
 |>   object=D            T                      (A B C)
 |>   object=X            NIL                    (A B C . D)
⇒  NIL

Side Effects::

Neither ldiff nor tailp modifies either of its arguments.

Exceptional Situations::

Should be prepared to signal an error of type type-error if list is not a proper list or a dotted list.

See Also::

set-difference

Notes::

If the list is a circular list, tailp will reliably yield a value only if the given object is in fact a tail of list. Otherwise, the consequences are unspecified: a given implementation which detects the circularity must return false, but since an implementation is not obliged to detect such a situation, tailp might just loop indefinitely without returning in that case.

tailp could be defined as follows: 

 (defun tailp (object list)
   (do ((list list (cdr list)))
       ((atom list) (eql list object))
      (if (eql object list)
          (return t))))

and ldiff could be defined by: 

(defun ldiff (list object)
  (do ((list list (cdr list))
       (r '() (cons (car list) r)))
      ((atom list)
       (if (eql list object) (nreverse r) (nreconc r list)))
    (when (eql object list)
      (return (nreverse r)))))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Scope.html0000644000175000017500000000466014360276512014440 0ustar cammcamm Scope (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.1 Scope, Purpose, and History

• Scope and Purpose  
• History  
gcl-2.6.14/info/gcl/Logical-Pathnames.html0000644000175000017500000000465314360276512016661 0ustar cammcamm Logical Pathnames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames  

19.3 Logical Pathnames

• Syntax of Logical Pathname Namestrings  
• Logical Pathname Components  
gcl-2.6.14/info/gcl/dribble.html0000644000175000017500000001135114360276512014765 0ustar cammcamm dribble (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.19 dribble [Function]

dribble &optional pathname ⇒ implementation-dependent

Arguments and Values::

pathname—a pathname designator.

Description::

Either binds *standard-input* and *standard-output* or takes other appropriate action, so as to send a record of the input/output interaction to a file named by pathname. dribble is intended to create a readable record of an interactive session.

If pathname is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname.

(dribble) terminates the recording of input and output and closes the dribble file.

If dribble is called while a stream to a “dribble file” is still open from a previous call to dribble, the effect is implementation-defined. For example, the already-open stream might be closed, or dribbling might occur both to the old stream and to a new one, or the old stream might stay open but not receive any further output, or the new request might be ignored, or some other action might be taken.

Affected By::

The implementation.

Exceptional Situations::

If a failure occurs when performing some operation on the file system while creating the dribble file, an error of type file-error is signaled.

An error of type file-error might be signaled if pathname is a designator for a wild pathname.

See Also::

Pathnames as Filenames

Notes::

dribble can return before subsequent forms are executed. It also can enter a recursive interaction loop, returning only when (dribble) is done.

dribble is intended primarily for interactive debugging; its effect cannot be relied upon when used in a program.

Next: , Previous: , Up: Environment Dictionary  

gcl-2.6.14/info/gcl/asin.html0000644000175000017500000002652414360276512014324 0ustar cammcamm asin (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.21 asin, acos, atan [Function]

asin number ⇒ radians

acos number ⇒ radians

atan number1 &optional number2 ⇒ radians

Arguments and Values::

number—a number.

number1—a number if number2 is not supplied, or a real if number2 is supplied.

number2—a real.

radians—a number (of radians).

Description::

asin, acos, and atan compute the arc sine, arc cosine, and arc tangent respectively.

The arc sine, arc cosine, and arc tangent (with only number1 supplied) functions can be defined mathematically for number or number1 specified as x as in Figure 12–13. 

  Function     Definition                            
  Arc sine      -i log  (ix+ \sqrt1-x^2 )          
  Arc cosine    (\pi/2) - arcsin  x                  
  Arc tangent   -i log  ((1+ix) \sqrt1/(1+x^2) )   

  Figure 12–13: Mathematical definition of arc sine, arc cosine, and arc tangent

These formulae are mathematically correct, assuming completely accurate computation. They are not necessarily the simplest ones for real-valued computations.

If both number1 and number2 are supplied for atan, the result is the arc tangent of number1/number2. The value of atan is always between -\pi (exclusive) and~\pi (inclusive)

when minus zero is not supported. The range of the two-argument arc tangent when minus zero is supported includes -\pi.

For a

real

number1, the result is

a real

and lies between -\pi/2 and~\pi/2 (both exclusive). number1 can be a complex if number2 is not supplied. If both are supplied, number2 can be zero provided number1 is not zero.

[Reviewer Note by Barmar: Should add “However, if the implementation distinguishes positive and negative zero, both may be signed zeros, and limits are used to define the result.”]

The following definition for arc sine determines the range and branch cuts:

arcsin z = -i log (iz+\sqrt1-z^2\Bigr)

The branch cut for the arc sine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is non-positive.

The following definition for arc cosine determines the range and branch cuts:

arccos z = \pi\over2 - arcsin z

or, which are equivalent,

arccos z = -i log (z+i \sqrt1-z^2\Bigr)
arccos z = 2 log (\sqrt(1+z)/2 + i \sqrt(1-z)/2)\overi

The branch cut for the arc cosine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. This is the same branch cut as for arc sine. The range is that strip of the complex plane containing numbers whose real part is between 0 and~\pi. A number with real part equal to 0 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi is in the range if and only if its imaginary part is non-positive.

The following definition for (one-argument) arc tangent determines the range and branch cuts:

arctan z = log (1+iz) - log (1-iz)\over2i

Beware of simplifying this formula; “obvious” simplifications are likely to alter the branch cuts or the values on the branch cuts incorrectly. The branch cut for the arc tangent function is in two pieces: one along the positive imaginary axis above i (exclusive), continuous with quadrant II, and one along the negative imaginary axis below -i (exclusive), continuous with quadrant IV. The points i and~-i are excluded from the domain. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is strictly positive; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is strictly negative. Thus the range of arc tangent is identical to that of arc sine with the points -\pi/2 and~\pi/2 excluded.

For atan, the signs of number1 (indicated as x) and number2 (indicated as y) are used to derive quadrant information. Figure 12–14 details various special cases.

The asterisk (*) indicates that the entry in the figure applies to implementations that support minus zero. 

   to 1pcy Condition  x Condition  Cartesian locus  Range of result          
   to 1pc y = 0        x > 0       Positive x-axis   0                       
   to 1pc* y = +0      x > 0       Positive x-axis  +0                       
   to 1pc* y = -0      x > 0       Positive x-axis  -0                       
   to 1pc y > 0        x > 0       Quadrant I       0 < result < \pi/2      
   to 1pc y > 0        x = 0       Positive y-axis  \pi/2                    
   to 1pc y > 0        x < 0       Quadrant II      \pi/2 < result < \pi    
   to 1pc y = 0        x < 0       Negative x-axis   \pi                     
   to 1pc* y = +0      x < 0       Negative x-axis  +\pi                     
   to 1pc* y = -0      x < 0       Negative x-axis  -\pi                     
   to 1pc y < 0        x < 0       Quadrant III     -\pi < result < -\pi/2  
   to 1pc y < 0        x = 0       Negative y-axis  -\pi/2                   
   to 1pc y < 0        x > 0       Quadrant IV      -\pi/2 < result < 0     
   to 1pc y = 0        x = 0       Origin           undefined consequences   
   to 1pc* y = +0      x = +0      Origin           +0                       
   to 1pc* y = -0      x = +0      Origin           -0                       
   to 1pc* y = +0      x = -0      Origin           +\pi                     
   to 1pc* y = -0      x = -0      Origin           -\pi                     

               Figure 12–14: Quadrant information for arc tangent

Examples::

 (asin 0) ⇒  0.0 
 (acos #c(0 1))  ⇒  #C(1.5707963267948966 -0.8813735870195432)
 (/ (atan 1 (sqrt 3)) 6)  ⇒  0.087266 
 (atan #c(0 2)) ⇒  #C(-1.5707964 0.54930615)

Exceptional Situations::

acos and asin should signal an error of type type-error if number is not a number. atan should signal type-error if one argument is supplied and that argument is not a number, or if two arguments are supplied and both of those arguments are not reals.

acos, asin, and atan might signal arithmetic-error.

See Also::

log , sqrt , Rule of Float Substitutability

Notes::

The result of either asin or acos can be a complex even if number is not a complex; this occurs when the absolute value of number is greater than one.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Examples-of-APPEND-and-NCONC-clauses.html0000644000175000017500000000502214360276512021540 0ustar cammcamm Examples of APPEND and NCONC clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Value Accumulation Clauses  

6.1.3.2 Examples of APPEND and NCONC clauses

;; Use APPEND to concatenate some sublists.
  (loop for x in '((a) (b) ((c)))
        append x)
⇒  (A B (C))

;; NCONC some sublists together.  Note that only lists made by the
;; call to LIST are modified.
  (loop for i upfrom 0 
        as x in '(a b (c))
        nconc (if (evenp i) (list x) nil))
⇒  (A (C))
gcl-2.6.14/info/gcl/Define_002dmodify_002dmacro-Lambda-Lists.html0000644000175000017500000000610214360276512022530 0ustar cammcamm Define-modify-macro Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.9 Define-modify-macro Lambda Lists

A define-modify-macro lambda list is used by define-modify-macro.

A define-modify-macro lambda list can contain the lambda list keywords shown in Figure 3–20. 

  &optional  &rest  

  Figure 3–20: Lambda List Keywords used by Define-modify-macro Lambda Lists

Define-modify-macro lambda lists are similar to ordinary lambda lists, but do not support keyword arguments. define-modify-macro has no need match keyword arguments, and a rest parameter is sufficient. Aux variables are also not supported, since define-modify-macro has no body forms which could refer to such bindings. See the macro define-modify-macro.

gcl-2.6.14/info/gcl/Case-in-Pathname-Components.html0000644000175000017500000000570414360276512020524 0ustar cammcamm Case in Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.3 Case in Pathname Components

Namestrings always use local file system case conventions, but Common Lisp functions that manipulate pathname components allow the caller to select either of two conventions for representing case in component values by supplying a value for the :case keyword argument. Figure 19–2 lists the functions relating to pathnames that permit a :case argument: 

  make-pathname    pathname-directory  pathname-name  
  pathname-device  pathname-host       pathname-type  

  Figure 19–2: Pathname functions using a :CASE argument
gcl-2.6.14/info/gcl/Declaring-the-Validity-of-Initialization-Arguments.html0000644000175000017500000001441414360276512025150 0ustar cammcamm Declaring the Validity of Initialization Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.2 Declaring the Validity of Initialization Arguments

Initialization arguments are checked for validity in each of the four situations that use them. An initialization argument may be valid in one situation and not another. For example, the system-supplied primary method for make-instance defined for the class standard-class checks the validity of its initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid in that situation.

There are two means for declaring initialization arguments valid.

*

Initialization arguments that fill slots are declared as valid by the :initarg slot option to defclass. The :initarg slot option is inherited from superclasses. Thus the set of valid initialization arguments that fill slots for a class is the union of the initialization arguments that fill slots declared as valid by that class and its superclasses. Initialization arguments that fill slots are valid in all four contexts.

*

Initialization arguments that supply arguments to methods are declared as valid by defining those methods. The keyword name of each keyword parameter specified in the method’s lambda list becomes an initialization argument for all classes for which the method is applicable.

The presence of &allow-other-keys in the lambda list of an applicable method disables validity checking of initialization arguments.

Thus method inheritance controls the set of valid initialization arguments that supply arguments to methods. The generic functions for which method definitions serve to declare initialization arguments valid are as follows:

–

Making an instance of a class: allocate-instance, initialize-instance, and shared-initialize. Initialization arguments declared as valid by these methods are valid when making an instance of a class.

–

Re-initializing an instance: reinitialize-instance and shared-initialize. Initialization arguments declared as valid by these methods are valid when re-initializing an instance.

–

Updating an instance to conform to a redefined class: update-instance-for-redefined-class and shared-initialize. Initialization arguments declared as valid by these methods are valid when updating an instance to conform to a redefined class.

–

Updating an instance to conform to the definition of a different class: update-instance-for-different-class and shared-initialize. Initialization arguments declared as valid by these methods are valid when updating an instance to conform to the definition of a different class.

The set of valid initialization arguments for a class is the set of valid initialization arguments that either fill slots or supply arguments to methods, along with the predefined initialization argument :allow-other-keys. The default value for :allow-other-keys is nil.

Validity checking of initialization arguments is disabled if the value of the initialization argument :allow-other-keys is true.

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/Use-of-Implementation_002dDefined-Language-Features.html0000644000175000017500000000641714360276512025013 0ustar cammcamm Use of Implementation-Defined Language Features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Programs  

1.5.2.1 Use of Implementation-Defined Language Features

Note that conforming code may rely on particular implementation-defined values or features. Also note that the requirements for conforming code and conforming implementations do not require that the results produced by conforming code always be the same when processed by a conforming implementation. The results may be the same, or they may differ.

Portable code is written using only standard characters.

Conforming code may run in all conforming implementations, but might have allowable implementation-defined behavior that makes it non-portable code. For example, the following are examples of forms that are conforming, but that might return different values in different implementations: 

 (evenp most-positive-fixnum) ⇒  implementation-dependent
 (random) ⇒  implementation-dependent
 (> lambda-parameters-limit 93) ⇒  implementation-dependent
 (char-name #\A) ⇒  implementation-dependent
gcl-2.6.14/info/gcl/Evaluation.html0000644000175000017500000001104014360276512015464 0ustar cammcamm Evaluation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.1 Evaluation

Execution of code can be accomplished by a variety of means ranging from direct interpretation of a form representing a program to invocation of compiled code produced by a compiler.

Evaluation is the process by which a program is executed in Common Lisp. The mechanism of evaluation is manifested both implicitly through the effect of the Lisp read-eval-print loop, and explicitly through the presence of the functions eval, compile, compile-file, and load. Any of these facilities might share the same execution strategy, or each might use a different one.

The behavior of a conforming program processed by eval and by compile-file might differ; see Semantic Constraints.

Evaluation can be understood in terms of a model in which an interpreter recursively traverses a form performing each step of the computation as it goes. This model, which describes the semantics of Common Lisp programs, is described in The Evaluation Model.

• Introduction to Environments  
• The Evaluation Model  
• Lambda Expressions  
• Closures and Lexical Binding  
• Shadowing  
• Extent  
• Return Values  
gcl-2.6.14/info/gcl/function_002dkeywords.html0000644000175000017500000001026614360276512017530 0ustar cammcamm function-keywords (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.1 function-keywords [Standard Generic Function]

Syntax::

function-keywords method ⇒ keys, allow-other-keys-p

Method Signatures::

function-keywords (method standard-method)

Arguments and Values::

method—a method.

keys—a list.

allow-other-keys-p—a generalized boolean.

Description::

Returns the keyword parameter specifiers for a method.

Two values are returned: a list of the explicitly named keywords and a generalized boolean that states whether &allow-other-keys had been specified in the method definition.

Examples::

 (defmethod gf1 ((a integer) &optional (b 2)
                 &key (c 3) ((:dee d) 4) e ((eff f)))
   (list a b c d e f))
⇒  #<STANDARD-METHOD GF1 (INTEGER) 36324653>
 (find-method #'gf1 '() (list (find-class 'integer))) 
⇒  #<STANDARD-METHOD GF1 (INTEGER) 36324653>
 (function-keywords *)
⇒  (:C :DEE :E EFF), false
 (defmethod gf2 ((a integer))
   (list a b c d e f))
⇒  #<STANDARD-METHOD GF2 (INTEGER) 42701775>
 (function-keywords (find-method #'gf1 '() (list (find-class 'integer))))
⇒  (), false
 (defmethod gf3 ((a integer) &key b c d &allow-other-keys)
   (list a b c d e f))
 (function-keywords *)
⇒  (:B :C :D), true

Affected By::

defmethod

See Also::

defmethod

gcl-2.6.14/info/gcl/make_002dload_002dform.html0000644000175000017500000004110214360276512017272 0ustar cammcamm make-load-form (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.21 make-load-form [Standard Generic Function]

Syntax::

make-load-form object &optional environment ⇒ creation-form [, initialization-form ]

Method Signatures::

make-load-form (object standard-object) &optional environment

make-load-form (object structure-object) &optional environment

make-load-form (object condition) &optional environment

make-load-form (object class) &optional environment

Arguments and Values::

object—an object.

environment—an environment object.

creation-form—a form.

initialization-form—a form.

Description::

The generic function make-load-form creates and returns one or two forms, a creation-form and an initialization-form, that enable load to construct an object equivalent to object. Environment is an environment object corresponding to the lexical environment in which the forms will be processed.

The file compiler calls make-load-form to process certain classes of literal objects; see Additional Constraints on Externalizable Objects.

Conforming programs may call make-load-form directly, providing object is a generalized instance of standard-object, structure-object, or condition.

The creation form is a form that, when evaluated at load time, should return an object that is equivalent to object. The exact meaning of equivalent depends on the type of object and is up to the programmer who defines a method for make-load-form; see Literal Objects in Compiled Files.

The initialization form is a form that, when evaluated at load time, should perform further initialization of the object. The value returned by the initialization form is ignored. If make-load-form returns only one value, the initialization form is nil, which has no effect. If object appears as a constant in the initialization form, at load time it will be replaced by the equivalent object constructed by the creation form; this is how the further initialization gains access to the object.

Both the creation-form and the initialization-form may contain references to any externalizable object. However, there must not be any circular dependencies in creation forms. An example of a circular dependency is when the creation form for the object X contains a reference to the object Y, and the creation form for the object Y contains a reference to the object X. Initialization forms are not subject to any restriction against circular dependencies, which is the reason that initialization forms exist; see the example of circular data structures below.

The creation form for an object is always evaluated before the initialization form for that object. When either the creation form or the initialization form references other objects that have not been referenced earlier in the file being compiled, the compiler ensures that all of the referenced objects have been created before evaluating the referencing form. When the referenced object is of a type which the file compiler processes using make-load-form, this involves evaluating the creation form returned for it. (This is the reason for the prohibition against circular references among creation forms).

Each initialization form is evaluated as soon as possible after its associated creation form, as determined by data flow. If the initialization form for an object does not reference any other objects not referenced earlier in the file and processed by the file compiler using make-load-form, the initialization form is evaluated immediately after the creation form. If a creation or initialization form F does contain references to such objects, the creation forms for those other objects are evaluated before F, and the initialization forms for those other objects are also evaluated before F whenever they do not depend on the object created or initialized by F. Where these rules do not uniquely determine an order of evaluation between two creation/initialization forms, the order of evaluation is unspecified.

While these creation and initialization forms are being evaluated, the objects are possibly in an uninitialized state, analogous to the state of an object between the time it has been created by allocate-instance and it has been processed fully by initialize-instance. Programmers writing methods for make-load-form must take care in manipulating objects not to depend on slots that have not yet been initialized.

It is implementation-dependent whether load calls eval on the forms or does some other operation that has an equivalent effect. For example, the forms might be translated into different but equivalent forms and then evaluated, they might be compiled and the resulting functions called by load, or they might be interpreted by a special-purpose function different from eval. All that is required is that the effect be equivalent to evaluating the forms.

The method specialized on class returns a creation form using the name of the class if the class has a proper name in environment, signaling an error of type error if it does not have a proper name. Evaluation of the creation form uses the name to find the class with that name, as if by calling find-class. If a class with that name has not been defined, then a class may be computed in an implementation-defined manner. If a class cannot be returned as the result of evaluating the creation form, then an error of type error is signaled.

Both conforming implementations and conforming programs may further specialize make-load-form.

Examples::

 (defclass obj ()
    ((x :initarg :x :reader obj-x)
     (y :initarg :y :reader obj-y)
     (dist :accessor obj-dist)))
⇒  #<STANDARD-CLASS OBJ 250020030>
 (defmethod shared-initialize :after ((self obj) slot-names &rest keys)
   (declare (ignore slot-names keys))
   (unless (slot-boundp self 'dist)
     (setf (obj-dist self)
           (sqrt (+ (expt (obj-x self) 2) (expt (obj-y self) 2))))))
⇒  #<STANDARD-METHOD SHARED-INITIALIZE (:AFTER) (OBJ T) 26266714>
 (defmethod make-load-form ((self obj) &optional environment)
   (declare (ignore environment))
   ;; Note that this definition only works because X and Y do not
   ;; contain information which refers back to the object itself.
   ;; For a more general solution to this problem, see revised example below.
   `(make-instance ',(class-of self)
                   :x ',(obj-x self) :y ',(obj-y self)))
⇒  #<STANDARD-METHOD MAKE-LOAD-FORM (OBJ) 26267532>
 (setq obj1 (make-instance 'obj :x 3.0 :y 4.0)) ⇒  #<OBJ 26274136>
 (obj-dist obj1) ⇒  5.0
 (make-load-form obj1) ⇒  (MAKE-INSTANCE 'OBJ :X '3.0 :Y '4.0)

In the above example, an equivalent instance of obj is reconstructed by using the values of two of its slots. The value of the third slot is derived from those two values.

Another way to write the make-load-form method in that example is to use make-load-form-saving-slots. The code it generates might yield a slightly different result from the make-load-form method shown above, but the operational effect will be the same. For example: 

 ;; Redefine method defined above.
 (defmethod make-load-form ((self obj) &optional environment)
    (make-load-form-saving-slots self
                                 :slot-names '(x y)
                                 :environment environment))
⇒  #<STANDARD-METHOD MAKE-LOAD-FORM (OBJ) 42755655>
 ;; Try MAKE-LOAD-FORM on object created above.
 (make-load-form obj1)
⇒  (ALLOCATE-INSTANCE '#<STANDARD-CLASS OBJ 250020030>),
    (PROGN
      (SETF (SLOT-VALUE '#<OBJ 26274136> 'X) '3.0)
      (SETF (SLOT-VALUE '#<OBJ 26274136> 'Y) '4.0)
      (INITIALIZE-INSTANCE '#<OBJ 26274136>))

In the following example, instances of my-frob are “interned” in some way. An equivalent instance is reconstructed by using the value of the name slot as a key for searching existing objects. In this case the programmer has chosen to create a new object if no existing object is found; alternatively an error could have been signaled in that case. 

 (defclass my-frob ()
    ((name :initarg :name :reader my-name)))
 (defmethod make-load-form ((self my-frob) &optional environment)
   (declare (ignore environment))
   `(find-my-frob ',(my-name self) :if-does-not-exist :create))

In the following example, the data structure to be dumped is circular, because each parent has a list of its children and each child has a reference back to its parent. If make-load-form is called on one object in such a structure, the creation form creates an equivalent object and fills in the children slot, which forces creation of equivalent objects for all of its children, grandchildren, etc. At this point none of the parent slots have been filled in. The initialization form fills in the parent slot, which forces creation of an equivalent object for the parent if it was not already created. Thus the entire tree is recreated at load time. At compile time, make-load-form is called once for each object in the tree. All of the creation forms are evaluated, in implementation-dependent order, and then all of the initialization forms are evaluated, also in implementation-dependent order. 

 (defclass tree-with-parent () ((parent :accessor tree-parent)
                                (children :initarg :children)))
 (defmethod make-load-form ((x tree-with-parent) &optional environment)
   (declare (ignore environment))
   (values
     ;; creation form
     `(make-instance ',(class-of x) :children ',(slot-value x 'children))
     ;; initialization form
     `(setf (tree-parent ',x) ',(slot-value x 'parent))))

In the following example, the data structure to be dumped has no special properties and an equivalent structure can be reconstructed simply by reconstructing the slots’ contents. 

 (defstruct my-struct a b c)
 (defmethod make-load-form ((s my-struct) &optional environment)
    (make-load-form-saving-slots s :environment environment))

Exceptional Situations::

The methods specialized on standard-object, structure-object, and condition all signal an error of type error.

It is implementation-dependent whether calling make-load-form on a generalized instance of a system class signals an error or returns creation and initialization forms.

See Also::

compile-file , make-load-form-saving-slots , Additional Constraints on Externalizable Objects Evaluation, Compilation

Notes::

The file compiler calls make-load-form in specific circumstances detailed in Additional Constraints on Externalizable Objects.

Some implementations may provide facilities for defining new subclasses of classes which are specified as system classes. (Some likely candidates include generic-function, method, and stream). Such implementations should document how the file compiler processes instances of such classes when encountered as literal objects, and should document any relevant methods for make-load-form.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/log.html0000644000175000017500000001217514360276512014150 0ustar cammcamm log (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.35 log [Function]

log number &optional base ⇒ logarithm

Arguments and Values::

number—a non-zero number.

base—a number.

logarithm—a number.

Description::

log returns the logarithm of number in base base. If base is not supplied its value is e, the base of the natural logarithms.

log may return a complex when given a

real

negative number. 

 (log -1.0) ≡ (complex 0.0 (float pi 0.0))

If base is zero, log returns zero.

The result of (log 8 2) may be either 3 or 3.0, depending on the implementation. An implementation can use floating-point calculations even if an exact integer result is possible.

The branch cut for the logarithm function of one argument (natural logarithm) lies along the negative real axis, continuous with quadrant II. The domain excludes the origin.

The mathematical definition of a complex logarithm is as follows, whether or not minus zero is supported by the implementation: 

(log x) ≡ (complex (log (abs x)) (phase x))

Therefore the range of the one-argument logarithm function is that strip of the complex plane containing numbers with imaginary parts between

-\pi (exclusive) and~\pi (inclusive) if minus zero is not supported, or -\pi (inclusive) and~\pi (inclusive) if minus zero is supported.

The two-argument logarithm function is defined as 

 (log base number)
 ≡ (/ (log number) (log base))

This defines the principal values precisely. The range of the two-argument logarithm function is the entire complex plane.

Examples::

 (log 100 10)
⇒  2.0
⇒  2
 (log 100.0 10) ⇒  2.0
 (log #c(0 1) #c(0 -1))
⇒  #C(-1.0 0.0)
OR⇒ #C(-1 0)
 (log 8.0 2) ⇒  3.0

 (log #c(-16 16) #c(2 2)) ⇒  3 or approximately #c(3.0 0.0)
                               or approximately 3.0 (unlikely)

Affected By::

The implementation.

See Also::

exp , expt, Rule of Float Substitutability

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Examples-of-WHILE-and-UNTIL-clauses.html0000644000175000017500000000512214360276512021475 0ustar cammcamm Examples of WHILE and UNTIL clauses (ANSI and GNU Common Lisp Document)

Previous: , Up: Termination Test Clauses  

6.1.4.3 Examples of WHILE and UNTIL clauses

 (loop while (hungry-p) do (eat))

;; UNTIL NOT is equivalent to WHILE.
 (loop until (not (hungry-p)) do (eat))

;; Collect the length and the items of STACK.
 (let ((stack '(a b c d e f)))
   (loop for item = (length stack) then (pop stack)
         collect item
         while stack))
⇒  (6 A B C D E F)

;; Use WHILE to terminate a loop that otherwise wouldn't terminate.
;; Note that WHILE occurs after the WHEN.
 (loop for i fixnum from 3
       when (oddp i) collect i
       while (< i 5))
⇒  (3 5)
gcl-2.6.14/info/gcl/update_002dinstance_002dfor_002ddifferent_002dclass.html0000644000175000017500000002013214360276512024536 0ustar cammcamm update-instance-for-different-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.6 update-instance-for-different-class [Standard Generic Function]

Syntax::

update-instance-for-different-class previous current &rest initargs &key &allow-other-keys ⇒ implementation-dependent

Method Signatures::

update-instance-for-different-class (previous standard-object) (current standard-object) &rest initargs

Arguments and Values::

previous—a copy of the original instance.

current—the original instance (altered).

initargs—an initialization argument list.

Description::

The generic function update-instance-for-different-class is not intended to be called by programmers. Programmers may write methods for it. The function update-instance-for-different-class is called only by the function change-class.

The system-supplied primary method on update-instance-for-different-class checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. This method then initializes slots with values according to the initargs, and initializes the newly added slots with values according to their :initform forms. It does this by calling the generic function shared-initialize with the following arguments: the instance (current), a list of names of the newly added slots, and the initargs it received. Newly added slots are those local slots for which no slot of the same name exists in the previous class.

Methods for update-instance-for-different-class can be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-different-class are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of update-instance-for-different-class.

Methods on update-instance-for-different-class can be defined to initialize slots differently from change-class. The default behavior of change-class is described in Changing the Class of an Instance.

The arguments to update-instance-for-different-class are computed by change-class. When change-class is invoked on an instance, a copy of that instance is made; change-class then destructively alters the original instance. The first argument to update-instance-for-different-class, previous, is that copy; it holds the old slot values temporarily. This argument has dynamic extent within change-class; if it is referenced in any way once update-instance-for-different-class returns, the results are undefined. The second argument to update-instance-for-different-class, current, is the altered original instance. The intended use of previous is to extract old slot values by using slot-value or with-slots or by invoking a reader generic function, or to run other methods that were applicable to instances of the original class.

Examples::

See the example for the function change-class.

Exceptional Situations::

The system-supplied primary method on update-instance-for-different-class signals an error if an initialization argument is supplied that is not declared as valid.

See Also::

change-class , Shared-Initialize , Changing the Class of an Instance, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments

Notes::

Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for update-instance-for-different-class or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on update-instance-for-different-class or shared-initialize is declared as a valid initarg name for all classes for which that method is applicable.

The value returned by update-instance-for-different-class is ignored by change-class.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/make_002darray.html0000644000175000017500000003236314360276512016071 0ustar cammcamm make-array (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.7 make-array [Function]

make-array dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset
⇒ new-array

Arguments and Values::

dimensions—a designator for a list of valid array dimensions.

element-type—a type specifier. The default is t.

initial-element—an object.

initial-contents—an object.

adjustable—a generalized boolean. The default is nil.

fill-pointer—a valid fill pointer for the array to be created, or t or nil. The default is nil.

displaced-to—an array or nil. The default is nil. This option must not be supplied if either initial-element or initial-contents is supplied.

displaced-index-offset—a valid array row-major index for displaced-to. The default is 0. This option must not be supplied unless a non-nil displaced-to is supplied.

new-array—an array.

Description::

Creates and returns an array constructed of the most specialized type that can accommodate elements of type given by element-type. If dimensions is nil then a zero-dimensional array is created.

Dimensions represents the dimensionality of the new array.

element-type indicates the type of the elements intended to be stored in the new-array. The new-array can actually store any objects of the type which results from upgrading element-type; see Array Upgrading.

If initial-element is supplied, it is used to initialize each element of new-array. If initial-element is supplied, it must be of the type given by element-type. initial-element cannot be supplied if either the :initial-contents option is supplied or displaced-to is non-nil. If initial-element is not supplied,

the consequences of later reading an uninitialized element of new-array are undefined

unless either initial-contents is supplied or displaced-to is non-nil.

initial-contents is used to initialize the contents of array. For example: 

 (make-array '(4 2 3) :initial-contents
             '(((a b c) (1 2 3))
              ((d e f) (3 1 2))
              ((g h i) (2 3 1))
              ((j k l) (0 0 0))))

initial-contents is composed of a nested structure of sequences. The numbers of levels in the structure must equal the rank of array. Each leaf of the nested structure must be of the type given by element-type. If array is zero-dimensional, then initial-contents specifies the single element. Otherwise, initial-contents must be a sequence whose length is equal to the first dimension; each element must be a nested structure for an array whose dimensions are the remaining dimensions, and so on. Initial-contents cannot be supplied if either initial-element is supplied or displaced-to is non-nil. If initial-contents is not supplied,

the consequences of later reading an uninitialized element of new-array are undefined

unless either initial-element is supplied or displaced-to is non-nil.

If adjustable is non-nil, the array is expressly adjustable (and so actually adjustable); otherwise, the array is not expressly adjustable (and it is implementation-dependent whether the array is actually adjustable).

If fill-pointer is non-nil, the array must be one-dimensional; that is, the array must be a vector. If fill-pointer is t, the length of the vector is used to initialize the fill pointer. If fill-pointer is an integer, it becomes the initial fill pointer for the vector.

If displaced-to is non-nil, make-array will create a displaced array and displaced-to is the target of that displaced array. In that case, the consequences are undefined if the actual array element type of displaced-to is not type equivalent to the actual array element type of the array being created. If displaced-to is nil, the array is not a displaced array.

The displaced-index-offset is made to be the index offset of the array. When an array A is given as the :displaced-to argument to make-array when creating array B, then array B is said to be displaced to array A. The total number of elements in an array, called the total size of the array, is calculated as the product of all the dimensions. It is required that the total size of A be no smaller than the sum of the total size of B plus the offset n supplied by the displaced-index-offset. The effect of displacing is that array B does not have any elements of its own, but instead maps accesses to itself into accesses to array A. The mapping treats both arrays as if they were one-dimensional by taking the elements in row-major order, and then maps an access to element k of array B to an access to element k+n of array A.

If make-array is called with adjustable, fill-pointer, and displaced-to each nil, then the result is a simple array.

If make-array is called with one or more of adjustable, fill-pointer, or displaced-to being true, whether the resulting array is a simple array is implementation-dependent.

When an array A is given as the :displaced-to argument to make-array when creating array B, then array B is said to be displaced to array A. The total number of elements in an array, called the total size of the array, is calculated as the product of all the dimensions. The consequences are unspecified if the total size of A is smaller than the sum of the total size of B plus the offset n supplied by the displaced-index-offset. The effect of displacing is that array B does not have any elements of its own, but instead maps accesses to itself into accesses to array A. The mapping treats both arrays as if they were one-dimensional by taking the elements in row-major order, and then maps an access to element k of array B to an access to element k+n of array A.

Examples::


 (make-array 5) ;; Creates a one-dimensional array of five elements.
 (make-array '(3 4) :element-type '(mod 16)) ;; Creates a 
                ;;two-dimensional array, 3 by 4, with four-bit elements.
 (make-array 5 :element-type 'single-float) ;; Creates an array of single-floats.

 (make-array nil :initial-element nil) ⇒  #0ANIL
 (make-array 4 :initial-element nil) ⇒  #(NIL NIL NIL NIL)
 (make-array '(2 4) 
              :element-type '(unsigned-byte 2) 
              :initial-contents '((0 1 2 3) (3 2 1 0)))
⇒  #2A((0 1 2 3) (3 2 1 0))
 (make-array 6
              :element-type 'character 
              :initial-element #\a 
              :fill-pointer 3) ⇒  "aaa"

The following is an example of making a displaced array. 

 (setq a (make-array '(4 3))) 
⇒  #<ARRAY 4x3 simple 32546632>
 (dotimes (i 4)
   (dotimes (j 3)
     (setf (aref a i j) (list i 'x j '= (* i j)))))
⇒  NIL
 (setq b (make-array 8 :displaced-to a
                       :displaced-index-offset 2))
⇒  #<ARRAY 8 indirect 32550757>
 (dotimes (i 8)
   (print (list i (aref b i))))
 |>  (0 (0 X 2 = 0)) 
 |>  (1 (1 X 0 = 0)) 
 |>  (2 (1 X 1 = 1)) 
 |>  (3 (1 X 2 = 2)) 
 |>  (4 (2 X 0 = 0)) 
 |>  (5 (2 X 1 = 2)) 
 |>  (6 (2 X 2 = 4)) 
 |>  (7 (3 X 0 = 0)) 
⇒  NIL

The last example depends on the fact that arrays are, in effect, stored in row-major order. 

 (setq a1 (make-array 50))
⇒  #<ARRAY 50 simple 32562043>
 (setq b1 (make-array 20 :displaced-to a1 :displaced-index-offset 10))
⇒  #<ARRAY 20 indirect 32563346>
 (length b1) ⇒  20

 (setq a2 (make-array 50 :fill-pointer 10))
⇒  #<ARRAY 50 fill-pointer 10 46100216>
 (setq b2 (make-array 20 :displaced-to a2 :displaced-index-offset 10))
⇒  #<ARRAY 20 indirect 46104010>
 (length a2) ⇒  10
 (length b2) ⇒  20

 (setq a3 (make-array 50 :fill-pointer 10))
⇒  #<ARRAY 50 fill-pointer 10 46105663>
 (setq b3 (make-array 20 :displaced-to a3 :displaced-index-offset 10
                         :fill-pointer 5))
⇒  #<ARRAY 20 indirect, fill-pointer 5 46107432>
 (length a3) ⇒  10
 (length b3) ⇒  5

See Also::

adjustable-array-p , aref , arrayp , array-element-type , array-rank-limit , array-dimension-limit , fill-pointer , upgraded-array-element-type

Notes::

There is no specified way to create an array for which adjustable-array-p definitely returns false. There is no specified way to create an array that is not a simple array.

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/Nesting-of-FORMAT-Operations.html0000644000175000017500000000720614360276512020506 0ustar cammcamm Nesting of FORMAT Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Additional Information about FORMAT Operations  

22.3.10.1 Nesting of FORMAT Operations

The case-conversion, conditional, iteration, and justification constructs can contain other formatting constructs by bracketing them. These constructs must nest properly with respect to each other. For example, it is not legitimate to put the start of a case-conversion construct in each arm of a conditional and the end of the case-conversion construct outside the conditional: 

 (format nil "~:[abc~:@(def~;ghi~
:@(jkl~]mno~)" x) ;Invalid!

This notation is invalid because the ~[...~;...~] and ~(...~) constructs are not properly nested.

The processing indirection caused by the ~? directive is also a kind of nesting for the purposes of this rule of proper nesting. It is not permitted to start a bracketing construct within a string processed under control of a ~? directive and end the construct at some point after the ~? construct in the string containing that construct, or vice versa. For example, this situation is invalid: 

 (format nil "~@?ghi~)" "abc~@(def") ;Invalid!

This notation is invalid because the ~? and ~(...~) constructs are not properly nested.

gcl-2.6.14/info/gcl/Parsing-Namestrings-Into-Pathnames.html0000644000175000017500000000514414360276512022105 0ustar cammcamm Parsing Namestrings Into Pathnames (ANSI and GNU Common Lisp Document)

Previous: , Up: Overview of Filenames  

19.1.3 Parsing Namestrings Into Pathnames

Parsing is the operation used to convert a namestring into a pathname.

Except in the case of parsing logical pathname namestrings,

this operation is implementation-dependent, because the format of namestrings is implementation-dependent.

A conforming implementation is free to accommodate other file system features in its pathname representation and provides a parser that can process such specifications in namestrings. Conforming programs must not depend on any such features, since those features will not be portable.

gcl-2.6.14/info/gcl/standard_002dclass.html0000644000175000017500000000464014360276512016740 0ustar cammcamm standard-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.10 standard-class [System Class]

Class Precedence List::

standard-class, class,

standard-object,

t

Description::

The class standard-class is the default class of classes defined by defclass.

gcl-2.6.14/info/gcl/Examples-of-Effect-of-Readtable-Case-on-the-Lisp-Printer.html0000644000175000017500000001233114360276512025605 0ustar cammcamm Examples of Effect of Readtable Case on the Lisp Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.11 Examples of Effect of Readtable Case on the Lisp Printer

 (defun test-readtable-case-printing ()
   (let ((*readtable* (copy-readtable nil))
         (*print-case* *print-case*))
     (format t "READTABLE-CASE *PRINT-CASE*  Symbol-name  Output~
              ~
              ~
     (dolist (readtable-case '(:upcase :downcase :preserve :invert))
       (setf (readtable-case *readtable*) readtable-case)
       (dolist (print-case '(:upcase :downcase :capitalize))
         (dolist (symbol '(|ZEBRA| |Zebra| |zebra|))
           (setq *print-case* print-case)
           (format t "~&:~A~15T:~A~29T~A~42T~A"
                   (string-upcase readtable-case)
                   (string-upcase print-case)
                   (symbol-name symbol)
                   (prin1-to-string symbol)))))))

The output from (test-readtable-case-printing) should be as follows: 

    READTABLE-CASE *PRINT-CASE*  Symbol-name  Output
    --------------------------------------------------
    :UPCASE        :UPCASE       ZEBRA        ZEBRA
    :UPCASE        :UPCASE       Zebra        |Zebra|
    :UPCASE        :UPCASE       zebra        |zebra|
    :UPCASE        :DOWNCASE     ZEBRA        zebra
    :UPCASE        :DOWNCASE     Zebra        |Zebra|
    :UPCASE        :DOWNCASE     zebra        |zebra|
    :UPCASE        :CAPITALIZE   ZEBRA        Zebra
    :UPCASE        :CAPITALIZE   Zebra        |Zebra|
    :UPCASE        :CAPITALIZE   zebra        |zebra|
    :DOWNCASE      :UPCASE       ZEBRA        |ZEBRA|
    :DOWNCASE      :UPCASE       Zebra        |Zebra|
    :DOWNCASE      :UPCASE       zebra        ZEBRA
    :DOWNCASE      :DOWNCASE     ZEBRA        |ZEBRA|
    :DOWNCASE      :DOWNCASE     Zebra        |Zebra|
    :DOWNCASE      :DOWNCASE     zebra        zebra
    :DOWNCASE      :CAPITALIZE   ZEBRA        |ZEBRA|
    :DOWNCASE      :CAPITALIZE   Zebra        |Zebra|
    :DOWNCASE      :CAPITALIZE   zebra        Zebra
    :PRESERVE      :UPCASE       ZEBRA        ZEBRA
    :PRESERVE      :UPCASE       Zebra        Zebra
    :PRESERVE      :UPCASE       zebra        zebra
    :PRESERVE      :DOWNCASE     ZEBRA        ZEBRA
    :PRESERVE      :DOWNCASE     Zebra        Zebra
    :PRESERVE      :DOWNCASE     zebra        zebra
    :PRESERVE      :CAPITALIZE   ZEBRA        ZEBRA
    :PRESERVE      :CAPITALIZE   Zebra        Zebra
    :PRESERVE      :CAPITALIZE   zebra        zebra
    :INVERT        :UPCASE       ZEBRA        zebra
    :INVERT        :UPCASE       Zebra        Zebra
    :INVERT        :UPCASE       zebra        ZEBRA
    :INVERT        :DOWNCASE     ZEBRA        zebra
    :INVERT        :DOWNCASE     Zebra        Zebra
    :INVERT        :DOWNCASE     zebra        ZEBRA
    :INVERT        :CAPITALIZE   ZEBRA        zebra
    :INVERT        :CAPITALIZE   Zebra        Zebra
    :INVERT        :CAPITALIZE   zebra        ZEBRA
gcl-2.6.14/info/gcl/Printing-Random-States.html0000644000175000017500000000557714360276512017650 0ustar cammcamm Printing Random States (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.18 Printing Random States

A specific syntax for printing objects of type random-state is not specified. However, every implementation must arrange to print a random state object in such a way that, within the same implementation, read can construct from the printed representation a copy of the random state object as if the copy had been made by make-random-state.

If the type random state is effectively implemented by using the machinery for defstruct, the usual structure syntax can then be used for printing random state objects; one might look something like 

 #S(RANDOM-STATE :DATA #(14 49 98436589 786345 8734658324 ... ))

where the components are implementation-dependent.

gcl-2.6.14/info/gcl/byte.html0000644000175000017500000000751414360276512014333 0ustar cammcamm byte (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.66 byte, byte-size, byte-position [Function]

byte size position ⇒ bytespec

byte-size bytespec ⇒ size

byte-position bytespec ⇒ position

Arguments and Values::

size, position—a non-negative integer.

bytespec—a byte specifier.

Description::

byte returns a byte specifier that indicates a byte of width size and whose bits have weights 2^position + size - 1\/ through 2^position, and whose representation is implementation-dependent.

byte-size returns the number of bits specified by bytespec.

byte-position returns the position specified by bytespec.

Examples::

 (setq b (byte 100 200)) ⇒  #<BYTE-SPECIFIER size 100 position 200>
 (byte-size b) ⇒  100
 (byte-position b) ⇒  200

See Also::

ldb , dpb

Notes::

 (byte-size (byte j k)) ≡ j
 (byte-position (byte j k)) ≡ k

A byte of size of 0 is permissible; it refers to a byte of width zero. For example, 

 (ldb (byte 0 3) #o7777) ⇒  0
 (dpb #o7777 (byte 0 3) 0) ⇒  0
gcl-2.6.14/info/gcl/read_002dbyte.html0000644000175000017500000001013014360276512015700 0ustar cammcamm read-byte (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.14 read-byte [Function]

read-byte stream &optional eof-error-p eof-value ⇒ byte

Arguments and Values::

stream—a binary input stream.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object. The default is nil.

byte—an integer, or the eof-value.

Description::

read-byte reads and returns one byte from stream.

If an end of file_2 occurs and eof-error-p is false, the eof-value is returned.

Examples::

 (with-open-file (s "temp-bytes" 
                     :direction :output
                     :element-type 'unsigned-byte)
    (write-byte 101 s)) ⇒  101
 (with-open-file (s "temp-bytes" :element-type 'unsigned-byte)
    (format t "~S ~S" (read-byte s) (read-byte s nil 'eof)))
 |>  101 EOF
⇒  NIL

Side Effects::

Modifies stream.

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream.

Should signal an error of type error if stream is not a binary input stream.

If there are no bytes remaining in the stream and eof-error-p is true, an error of type end-of-file is signaled.

See Also::

read-char ,

read-sequence ,

write-byte

gcl-2.6.14/info/gcl/get_002dproperties.html0000644000175000017500000000737614360276512017017 0ustar cammcamm get-properties (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.40 get-properties [Function]

get-properties plist indicator-list ⇒ indicator, value, tail

Arguments and Values::

plist—a property list.

indicator-list—a proper list (of indicators).

indicator—an object that is an element of indicator-list.

value—an object.

tail—a list.

Description::

get-properties is used to look up any of several property list entries all at once.

It searches the plist for the first entry whose indicator is identical to one of the objects in indicator-list. If such an entry is found, the indicator and value returned are the property indicator and its associated property value, and the tail returned is the tail of the plist that begins with the found entry (i.e., whose car is the indicator). If no such entry is found, the indicator, value, and tail are all nil.

Examples::

 (setq x '()) ⇒  NIL
 (setq *indicator-list* '(prop1 prop2)) ⇒  (PROP1 PROP2)
 (getf x 'prop1) ⇒  NIL
 (setf (getf x 'prop1) 'val1) ⇒  VAL1
 (eq (getf x 'prop1) 'val1) ⇒  true
 (get-properties x *indicator-list*) ⇒  PROP1, VAL1, (PROP1 VAL1)
 x ⇒  (PROP1 VAL1)

See Also::

get , getf

gcl-2.6.14/info/gcl/pathname-_0028System-Class_0029.html0000644000175000017500000000507514360276512020635 0ustar cammcamm pathname (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.1 pathname [System Class]

Class Precedence List::

pathname, t

Description::

A pathname is a structured object which represents a filename.

There are two kinds of pathnames—physical pathnames and logical pathnames.

gcl-2.6.14/info/gcl/char_002dname.html0000644000175000017500000001167414360276512015675 0ustar cammcamm char-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.20 char-name [Function]

char-name character ⇒ name

Arguments and Values::

character—a character.

name—a string or nil.

Description::

Returns a string that is the name of the character, or nil if the character has no name.

All non-graphic characters are required to have names unless they have some implementation-defined attribute which is not null. Whether or not other characters have names is implementation-dependent.

The standard characters <Newline> and <Space> have the respective names "Newline" and "Space". The semi-standard characters <Tab>, <Page>, <Rubout>, <Linefeed>, <Return>, and <Backspace> (if they are supported by the implementation) have the respective names "Tab", "Page", "Rubout", "Linefeed", "Return", and "Backspace" (in the indicated case, even though name lookup by “#\” and by the function name-char is not case sensitive).

Examples::

 (char-name #\ ) ⇒  "Space"
 (char-name #\Space) ⇒  "Space"
 (char-name #\Page) ⇒  "Page"

 (char-name #\a)
⇒  NIL
OR⇒ "LOWERCASE-a"
OR⇒ "Small-A"
OR⇒ "LA01"

 (char-name #\A)
⇒  NIL
OR⇒ "UPPERCASE-A"
OR⇒ "Capital-A"
OR⇒ "LA02"

 ;; Even though its CHAR-NAME can vary, #\A prints as #\A
 (prin1-to-string (read-from-string (format nil "#\\~A" (or (char-name #\A) "A"))))
⇒  "#\\A"

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

name-char , Printing Characters

Notes::

Non-graphic characters having names are written by the Lisp printer as “#\” followed by the their name; see Printing Characters.

gcl-2.6.14/info/gcl/zerop.html0000644000175000017500000000667314360276512014534 0ustar cammcamm zerop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.18 zerop [Function]

zerop number ⇒ generalized-boolean

Pronunciation::

pronounced ’z\=e (, )r\=o(, )p\=e

Arguments and Values::

number—a number.

generalized-boolean—a generalized boolean.

Description::

Returns true if number is zero (integer, float, or complex); otherwise, returns false.

Regardless of whether an implementation provides distinct representations for positive and negative floating-point zeros, (zerop -0.0) always returns true.

Examples::

 (zerop 0) ⇒  true
 (zerop 1) ⇒  false
 (zerop -0.0) ⇒  true
 (zerop 0/100) ⇒  true
 (zerop #c(0 0.0)) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if number is not a number.

Notes::

 (zerop number) ≡ (= number 0)
gcl-2.6.14/info/gcl/defclass.html0000644000175000017500000005001114360276512015142 0ustar cammcamm defclass (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.25 defclass [Macro]

defclass class-name ({superclass-name}*) ({slot-specifier}*) [[!class-option]]
⇒ new-class

 slot-specifier::=slot-name | (slot-name [[!slot-option]])

 slot-name::= symbol

 slot-option::={:reader reader-function-name}* |
                         {:writer writer-function-name}* |
                         {:accessor reader-function-name}* |
                         {:allocation allocation-type} |
                         {:initarg initarg-name}* |
                         {:initform form} |
                         {:type type-specifier} |
                         {:documentation string}

 function-name::= {symbol | (setf symbol)}

 class-option::=(:default-initargs . initarg-list) |
                          (:documentation string) |
                          (:metaclass class-name)

Arguments and Values::

Class-name—a non-nil symbol.

Superclass-name–a non-nil symbol.

Slot-name–a symbol. The slot-name argument is a symbol that is syntactically valid for use as a variable name.

Reader-function-name—a non-nil symbol. :reader can be supplied more than once for a given slot.

Writer-function-name—a generic function name. :writer can be supplied more than once for a given slot.

Reader-function-name—a non-nil symbol. :accessor can be supplied more than once for a given slot.

Allocation-type—(member :instance :class). :allocation can be supplied once at most for a given slot.

Initarg-name—a symbol. :initarg can be supplied more than once for a given slot.

Form—a form. :init-form can be supplied once at most for a given slot.

Type-specifier—a type specifier. :type can be supplied once at most for a given slot.

Class-option— refers to the class as a whole or to all class slots.

Initarg-list—a list of alternating initialization argument names and default initial value forms. :default-initargs can be supplied at most once.

Class-name—a non-nil symbol. :metaclass can be supplied once at most.

new-class—the new class object.

Description::

The macro defclass defines a new named class. It returns the new class object as its result.

The syntax of defclass provides options for specifying initialization arguments for slots, for specifying default initialization values for slots, and for requesting that methods on specified generic functions be automatically generated for reading and writing the values of slots. No reader or writer functions are defined by default; their generation must be explicitly requested. However, slots can always be accessed using slot-value.

Defining a new class also causes a type of the same name to be defined. The predicate (typep object class-name) returns true if the class of the given object is the class named by class-name itself or a subclass of the class class-name. A class object can be used as a type specifier. Thus (typep object class) returns true if the class of the object is class itself or a subclass of class.

The class-name argument specifies the proper name of the new class. If a class with the same proper name already exists and that class is an instance of standard-class, and if the defclass form for the definition of the new class specifies a class of class standard-class, the existing class is redefined, and instances of it (and its subclasses) are updated to the new definition at the time that they are next accessed. For details, see Redefining Classes.

Each superclass-name argument specifies a direct superclass of the new class. If the superclass list is empty, then the superclass defaults depending on the metaclass, with standard-object being the default for standard-class.

The new class will inherit slots and methods from each of its direct superclasses, from their direct superclasses, and so on. For a discussion of how slots and methods are inherited, see Inheritance.

The following slot options are available:

*

The :reader slot option specifies that an unqualified method is to be defined on the generic function named reader-function-name to read the value of the given slot.

*

The :writer slot option specifies that an unqualified method is to be defined on the generic function named writer-function-name to write the value of the slot.

*

The :accessor slot option specifies that an unqualified method is to be defined on the generic function named reader-function-name to read the value of the given slot and that an unqualified method is to be defined on the generic function named (setf reader-function-name) to be used with setf to modify the value of the slot.

*

The :allocation slot option is used to specify where storage is to be allocated for the given slot. Storage for a slot can be located in each instance or in the class object itself. The value of the allocation-type argument can be either the keyword :instance or the keyword :class. If the :allocation slot option is not specified, the effect is the same as specifying :allocation :instance.

–

If allocation-type is :instance, a local slot of the name slot-name is allocated in each instance of the class.

–

If allocation-type is :class, a shared slot of the given name is allocated in the class object created by this defclass form. The value of the slot is shared by all instances of the class. If a class C_1 defines such a shared slot, any subclass C_2 of C_1 will share this single slot unless the defclass form for C_2 specifies a slot of the same name or there is a superclass of C_2 that precedes C_1 in the class precedence list of C_2 and that defines a slot of the same name.

*

The :initform slot option is used to provide a default initial value form to be used in the initialization of the slot. This form is evaluated every time it is used to initialize the slot. The lexical environment in which this form is evaluated is the lexical environment in which the defclass form was evaluated. Note that the lexical environment refers both to variables and to functions. For local slots, the dynamic environment is the dynamic environment in which make-instance is called; for shared slots, the dynamic environment is the dynamic environment in which the defclass form was evaluated. See Object Creation and Initialization.

No implementation is permitted to extend the syntax of defclass to allow (slot-name form) as an abbreviation for (slot-name :initform form).

[Reviewer Note by Barmar: Can you extend this to mean something else?]

*

The :initarg slot option declares an initialization argument named initarg-name and specifies that this initialization argument initializes the given slot. If the initialization argument has a value in the call to initialize-instance, the value will be stored into the given slot, and the slot’s :initform slot option, if any, is not evaluated. If none of the initialization arguments specified for a given slot has a value, the slot is initialized according to the :initform slot option, if specified.

*

The :type slot option specifies that the contents of the slot will always be of the specified data type. It effectively declares the result type of the reader generic function when applied to an object of this class. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot are undefined. The :type slot option is further discussed in Inheritance of Slots and Slot Options.

*

The :documentation slot option provides a documentation string for the slot. :documentation can be supplied once at most for a given slot. [Reviewer Note by Barmar: How is this retrieved?]

Each class option is an option that refers to the class as a whole. The following class options are available:

*

The :default-initargs class option is followed by a list of alternating initialization argument names and default initial value forms. If any of these initialization arguments does not appear in the initialization argument list supplied to make-instance, the corresponding default initial value form is evaluated, and the initialization argument name and the form’s value are added to the end of the initialization argument list before the instance is created; see Object Creation and Initialization. The default initial value form is evaluated each time it is used. The lexical environment in which this form is evaluated is the lexical environment in which the defclass form was evaluated. The dynamic environment is the dynamic environment in which make-instance was called. If an initialization argument name appears more than once in a :default-initargs class option, an error is signaled.

*

The :documentation class option causes a documentation string to be attached with the class object, and attached with kind type to the class-name. :documentation can be supplied once at most.

*

The :metaclass class option is used to specify that instances of the class being defined are to have a different metaclass than the default provided by the system (the class standard-class).

Note the following rules of defclass for standard classes:

*

It is not required that the superclasses of a class be defined before the defclass form for that class is evaluated.

*

All the superclasses of a class must be defined before an instance of the class can be made.

*

A class must be defined before it can be used as a parameter specializer in a defmethod form.

The object system can be extended to cover situations where these rules are not obeyed.

Some slot options are inherited by a class from its superclasses, and some can be shadowed or altered by providing a local slot description. No class options except :default-initargs are inherited. For a detailed description of how slots and slot options are inherited, see Inheritance of Slots and Slot Options.

The options to defclass can be extended. It is required that all implementations signal an error if they observe a class option or a slot option that is not implemented locally.

It is valid to specify more than one reader, writer, accessor, or initialization argument for a slot. No other slot option can appear more than once in a single slot description, or an error is signaled.

If no reader, writer, or accessor is specified for a slot, the slot can only be accessed by the function slot-value.

If a defclass form appears as a top level form, the compiler must make the class name be recognized as a valid type name in subsequent declarations (as for deftype) and be recognized as a valid class name for defmethod parameter specializers and for use as the :metaclass option of a subsequent defclass. The compiler must make the class definition available to be returned by find-class when its environment argument is a value received as the environment parameter of a macro.

Exceptional Situations::

If there are any duplicate slot names, an error of type program-error is signaled.

If an initialization argument name appears more than once in :default-initargs class option, an error of type program-error is signaled.

If any of the following slot options appears more than once in a single slot description, an error of type program-error is signaled: :allocation, :initform, :type, :documentation.

It is required that all implementations signal an error of type program-error if they observe a class option or a slot option that is not implemented locally.

See Also::

documentation , Initialize-Instance , make-instance , slot-value , Classes, Inheritance, Redefining Classes, Determining the Class Precedence List, Object Creation and Initialization

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/import.html0000644000175000017500000001347514360276512014705 0ustar cammcamm import (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.6 import [Function]

import symbols &optional package ⇒ t

Arguments and Values::

symbols—a designator for a list of symbols.

package—a package designator.

The default is the current package.

Description::

import adds symbol or symbols to the internals of package, checking for name conflicts with existing symbols either present in package or accessible to it. Once the symbols have been imported, they may be referenced in the importing package without the use of a package prefix when using the Lisp reader.

A name conflict in import between the symbol being imported and a symbol inherited from some other package can be resolved in favor of the symbol being imported by making it a shadowing symbol, or in favor of the symbol already accessible by not doing the import. A name conflict in import with a symbol already present in the package may be resolved by uninterning that symbol, or by not doing the import.

The imported symbol is not automatically exported from the current package, but if it is already present and external, then the fact that it is external is not changed.

If any symbol to be imported has no home package (i.e., (symbol-package symbol) ⇒ nil), import sets the home package of the symbol to package.

If the symbol is already present in the importing package, import has no effect.

Examples::

 (import 'common-lisp::car (make-package 'temp :use nil)) ⇒  T
 (find-symbol "CAR" 'temp) ⇒  CAR, :INTERNAL
 (find-symbol "CDR" 'temp) ⇒  NIL, NIL

The form (import 'editor:buffer) takes the external symbol named buffer in the EDITOR package (this symbol was located when the form was read by the Lisp reader) and adds it to the current package as an internal symbol. The symbol buffer is then present in the current package.

Side Effects::

The package system is modified.

Affected By::

Current state of the package system.

Exceptional Situations::

import signals a correctable error of type package-error if any of the symbols to be imported has the same name (under string=) as some distinct symbol (under eql) already accessible in the package, even if the conflict is with a shadowing symbol of the package.

See Also::

shadow , export

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/Notes-about-the-Pretty-Printer_0060s-Background.html0000644000175000017500000000462214360276512024156 0ustar cammcamm Notes about the Pretty Printer`s Background (ANSI and GNU Common Lisp Document)

Previous: , Up: The Lisp Pretty Printer  

22.2.3 Notes about the Pretty Printer‘s Background

For a background reference to the abstract concepts detailed in this section, see XP: A Common Lisp Pretty Printing System. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material.

gcl-2.6.14/info/gcl/Effect-of-Readtable-Case-on-the-Lisp-Reader.html0000644000175000017500000000704314360276512023212 0ustar cammcamm Effect of Readtable Case on the Lisp Reader (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Concepts  

23.1.2 Effect of Readtable Case on the Lisp Reader

The readtable case of the current readtable affects the Lisp reader in the following ways:

:upcase

When the readtable case is :upcase, unescaped constituent characters are converted to uppercase, as specified in Reader Algorithm.

:downcase

When the readtable case is :downcase, unescaped constituent characters are converted to lowercase.

:preserve

When the readtable case is :preserve, the case of all characters remains unchanged.

:invert

When the readtable case is :invert, then if all of the unescaped letters in the extended token are of the same case, those (unescaped) letters are converted to the opposite case.

• Examples of Effect of Readtable Case on the Lisp Reader  
gcl-2.6.14/info/gcl/Left_002dParenthesis.html0000644000175000017500000000764414360276512017221 0ustar cammcamm Left-Parenthesis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.1 Left-Parenthesis

The left-parenthesis initiates reading of a list. read is called recursively to read successive objects until a right parenthesis is found in the input stream. A list of the objects read is returned. Thus 

 (a b c)

is read as a list of three objects (the symbols a, b, and c). The right parenthesis need not immediately follow the printed representation of the last object; whitespace_2 characters and comments may precede it.

If no objects precede the right parenthesis, it reads as a list of zero objects (the empty list).

If a token that is just a dot not immediately preceded by an escape character is read after some object then exactly one more object must follow the dot, possibly preceded or followed by whitespace_2 or a comment, followed by the right parenthesis: 

 (a b c . d)

This means that the cdr of the last cons in the list is not nil, but rather the object whose representation followed the dot. The above example might have been the result of evaluating 

 (cons 'a (cons 'b (cons 'c 'd)))

Similarly, 

 (cons 'this-one 'that-one) ⇒  (this-one . that-one)

It is permissible for the object following the dot to be a list: 

 (a b c d . (e f . (g))) ≡ (a b c d e f g)

For information on how the Lisp printer prints lists and conses, see Printing Lists and Conses.

gcl-2.6.14/info/gcl/floatp.html0000644000175000017500000000571314360276512014654 0ustar cammcamm floatp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.75 floatp [Function]

floatp object generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type float; otherwise, returns false.

Examples::

 (floatp 1.2d2) ⇒  true
 (floatp 1.212) ⇒  true
 (floatp 1.2s2) ⇒  true
 (floatp (expt 2 130)) ⇒  false

Notes::

 (floatp object) ≡ (typep object 'float)
gcl-2.6.14/info/gcl/Introduction-to-Methods.html0000644000175000017500000002344014360276512020066 0ustar cammcamm Introduction to Methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.2 Introduction to Methods

Methods define the class-specific or identity-specific behavior and operations of a generic function.

A method object is associated with code that implements the method’s behavior, a sequence of parameter specializers that specify when the given method is applicable, a lambda list, and a sequence of qualifiers that are used by the method combination facility to distinguish among methods.

A method object is not a function and cannot be invoked as a function. Various mechanisms in the object system take a method object and invoke its method function, as is the case when a generic function is invoked. When this occurs it is said that the method is invoked or called.

A method-defining form contains the code that is to be run when the arguments to the generic function cause the method that it defines to be invoked. When a method-defining form is evaluated, a method object is created and one of four actions is taken:

*

If a generic function of the given name already exists and if a method object already exists that agrees with the new one on parameter specializers and qualifiers, the new method object replaces the old one. For a definition of one method agreeing with another on parameter specializers and qualifiers, see Agreement on Parameter Specializers and Qualifiers.

*

If a generic function of the given name already exists and if there is no method object that agrees with the new one on parameter specializers and qualifiers, the existing generic function object is modified to contain the new method object.

*

If the given name names an ordinary function, a macro, or a special operator, an error is signaled.

*

Otherwise a generic function is created with the method specified by the method-defining form.

If the lambda list of a new method is not congruent with the lambda list of the generic function, an error is signaled. If a method-defining operator that cannot specify generic function options creates a new generic function, a lambda list for that generic function is derived from the lambda list of the method in the method-defining form in such a way as to be congruent with it. For a discussion of congruence , see Congruent Lambda-lists for all Methods of a Generic Function.

Each method has a specialized lambda list, which determines when that method can be applied. A specialized lambda list is like an ordinary lambda list except that a specialized parameter may occur instead of the name of a required parameter. A specialized parameter is a list (variable-name parameter-specializer-name), where parameter-specializer-name is one of the following:

a symbol

denotes a parameter specializer which is the class named by that symbol.

a class

denotes a parameter specializer which is the class itself.

(eql form)

denotes a parameter specializer which satisfies the type specifier (eql object), where object is the result of evaluating form. The form form is evaluated in the lexical environment in which the method-defining form is evaluated. Note that form is evaluated only once, at the time the method is defined, not each time the generic function is called.

Parameter specializer names are used in macros intended as the user-level interface (defmethod), while parameter specializers are used in the functional interface.

Only required parameters may be specialized, and there must be a parameter specializer for each required parameter. For notational simplicity, if some required parameter in a specialized lambda list in a method-defining form is simply a variable name, its parameter specializer defaults to the class t.

Given a generic function and a set of arguments, an applicable method is a method for that generic function whose parameter specializers are satisfied by their corresponding arguments. The following definition specifies what it means for a method to be applicable and for an argument to satisfy a parameter specializer.

Let < A_1, ..., A_n> be the required arguments to a generic function in order. Let < P_1, ..., P_n> be the parameter specializers corresponding to the required parameters of the method M in order. The method M is applicable when each A_i is of the type specified by the type specifier P_i. Because every valid parameter specializer is also a valid type specifier, the function typep can be used during method selection to determine whether an argument satisfies a parameter specializer.

A method all of whose parameter specializers are the class t is called a default method ; it is always applicable but may be shadowed by a more specific method.

Methods can have qualifiers, which give the method combination procedure a way to distinguish among methods. A method that has one or more qualifiers is called a qualified method. A method with no qualifiers is called an unqualified method. A qualifier is any non-list. The qualifiers defined by the standardized method combination types are symbols.

In this specification, the terms “primary method” and “auxiliary method” are used to partition methods within a method combination type according to their intended use. In standard method combination, primary methods are unqualified methods and auxiliary methods are methods with a single qualifier that is one of :around, :before, or :after. Methods with these qualifiers are called around methods, before methods, and after methods, respectively. When a method combination type is defined using the short form of define-method-combination, primary methods are methods qualified with the name of the type of method combination, and auxiliary methods have the qualifier :around. Thus the terms “primary method” and “auxiliary method” have only a relative definition within a given method combination type.

Next: , Previous: , Up: Generic Functions and Methods  

gcl-2.6.14/info/gcl/Printing-Symbols.html0000644000175000017500000000746714360276512016617 0ustar cammcamm Printing Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.8 Printing Symbols

When printer escaping is disabled,

only the characters of the symbol’s name are output

(but the case in which to print characters in the name is controlled by *print-case*; see Effect of Readtable Case on the Lisp Printer).

The remainder of this section applies only

when printer escaping is enabled.

When printing a symbol, the printer inserts enough single escape and/or multiple escape characters (backslashes and/or vertical-bars) so that if read were called with the same *readtable* and with *read-base* bound to the current output base, it would return the same symbol (if it is not apparently uninterned) or an uninterned symbol with the same print name (otherwise).

For example, if the value of *print-base* were 16 when printing the symbol face, it would have to be printed as \FACE or \Face or |FACE|, because the token face would be read as a hexadecimal number (decimal value 64206) if the value of *read-base* were 16.

For additional restrictions concerning characters with nonstandard syntax types in the current readtable, see the variable *print-readably*

For information about how the Lisp reader parses symbols, see Symbols as Tokens and Sharpsign Colon.

nil might be printed as ()

when *print-pretty* is true and printer escaping is enabled.

gcl-2.6.14/info/gcl/Variables-that-affect-the-Lisp-Reader.html0000644000175000017500000000505314360276512022343 0ustar cammcamm Variables that affect the Lisp Reader (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax  

2.1.2 Variables that affect the Lisp Reader

The Lisp reader is influenced not only by the current readtable, but also by various dynamic variables. Figure 2–2 lists the variables that influence the behavior of the Lisp reader. 

  *package*    *read-default-float-format*  *readtable*  
  *read-base*  *read-suppress*                           

  Figure 2–2: Variables that influence the Lisp reader.
gcl-2.6.14/info/gcl/name_002dchar.html0000644000175000017500000000627114360276512015672 0ustar cammcamm name-char (ANSI and GNU Common Lisp Document)

Previous: , Up: Characters Dictionary  

13.2.21 name-char [Function]

name-char name ⇒ char-p

Arguments and Values::

name—a string designator.

char-p—a character or nil.

Description::

Returns the character object whose name is name (as determined by string-equal—i.e., lookup is not case sensitive). If such a character does not exist, nil is returned.

Examples::

(name-char 'space) ⇒  #\Space
(name-char "space") ⇒  #\Space
(name-char "Space") ⇒  #\Space
(let ((x (char-name #\a)))
  (or (not x) (eql (name-char x) #\a))) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if name is not a string designator.

See Also::

char-name

gcl-2.6.14/info/gcl/Sharpsign-X.html0000644000175000017500000000456014360276512015531 0ustar cammcamm Sharpsign X (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.10 Sharpsign X

#Xrational reads rational in hexadecimal (radix 16). The digits above 9 are the letters A through F (the lowercase letters a through f are also acceptable). For example, 

 #xF00 ≡ 3840             
 #x105 ≡ 261 ;105_16

The consequences are undefined if the token immediately following the #X does not have the syntax of a hexadecimal (i.e., radix 16) rational.

gcl-2.6.14/info/gcl/Use-of-Triple-Semicolon.html0000644000175000017500000000430514360276512017704 0ustar cammcamm Use of Triple Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.5 Use of Triple Semicolon

Comments that begin with a triple semicolon are all aligned to the left margin. Usually they are used prior to a definition or set of definitions, rather than within a definition.

gcl-2.6.14/info/gcl/clrhash.html0000644000175000017500000000611414360276512015007 0ustar cammcamm clrhash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.13 clrhash [Function]

clrhash hash-table ⇒ hash-table

Arguments and Values::

hash-table—a hash table.

Description::

Removes all entries from hash-table, and then returns that empty hash table.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32004073>
 (dotimes (i 100) (setf (gethash i table) (format nil "~R" i))) ⇒  NIL
 (hash-table-count table) ⇒  100
 (gethash 57 table) ⇒  "fifty-seven", true
 (clrhash table) ⇒  #<HASH-TABLE EQL 0/120 32004073>
 (hash-table-count table) ⇒  0
 (gethash 57 table) ⇒  NIL, false

Side Effects::

The hash-table is modified.

gcl-2.6.14/info/gcl/identity.html0000644000175000017500000000604314360276512015215 0ustar cammcamm identity (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.37 identity [Function]

identity object ⇒ object

Arguments and Values::

object—an object.

Description::

Returns its argument object.

Examples::

 (identity 101) ⇒  101
 (mapcan #'identity (list (list 1 2 3) '(4 5 6))) ⇒  (1 2 3 4 5 6)

Notes::

identity is intended for use with functions that require a function as an argument.

(eql x (identity x)) returns true for all possible values of x, but (eq x (identity x)) might return false when x is a number or character.

identity could be defined by 

(defun identity (x) x)
gcl-2.6.14/info/gcl/set.html0000644000175000017500000001013714360276512014156 0ustar cammcamm set (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.19 set [Function]

set symbol value ⇒ value

Arguments and Values::

symbol—a symbol.

value—an object.

Description::

set changes the contents of the value cell of symbol to the given value. 

(set symbol value) ≡ (setf (symbol-value symbol) value)

Examples::

 (setf (symbol-value 'n) 1) ⇒  1
 (set 'n 2) ⇒  2
 (symbol-value 'n) ⇒  2
 (let ((n 3))
   (declare (special n))
   (setq n (+ n 1))
   (setf (symbol-value 'n) (* n 10))
   (set 'n (+ (symbol-value 'n) n))
   n) ⇒  80
 n ⇒  2
 (let ((n 3))
   (setq n (+ n 1))
   (setf (symbol-value 'n) (* n 10))
   (set 'n (+ (symbol-value 'n) n))
   n) ⇒  4
 n ⇒  44
 (defvar *n* 2)
 (let ((*n* 3))
   (setq *n* (+ *n* 1))
   (setf (symbol-value '*n*) (* *n* 10))
   (set '*n* (+ (symbol-value '*n*) *n*))
   *n*) ⇒  80
  *n* ⇒  2
 (defvar *even-count* 0) ⇒  *EVEN-COUNT*
 (defvar *odd-count* 0) ⇒  *ODD-COUNT*
 (defun tally-list (list)
   (dolist (element list)
     (set (if (evenp element) '*even-count* '*odd-count*)
          (+ element (if (evenp element) *even-count* *odd-count*)))))
 (tally-list '(1 9 4 3 2 7)) ⇒  NIL
 *even-count* ⇒  6
 *odd-count* ⇒  20

Side Effects::

The value of symbol is changed.

See Also::

setq , progv , symbol-value

Notes::

The function set is deprecated.

set cannot change the value of a lexical variable.

././@LongLink0000644000000000000000000000014700000000000011605 Lustar rootrootgcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Arguments_0022-Section-of-a-Dictionary-Entry.htmlgcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Arguments_0022-Section-of-a-Dictionary-Entry.ht0000644000175000017500000000573614360276512030670 0ustar cammcamm The "Compound Type Specifier Arguments" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.9 The "Compound Type Specifier Arguments" Section of a Dictionary Entry

This information describes type information for the structures defined in The "Compound Type Specifier Syntax" Section.

gcl-2.6.14/info/gcl/string.html0000644000175000017500000000767314360276512014704 0ustar cammcamm string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.7 string [Function]

string x ⇒ string

Arguments and Values::

x—a string, a symbol, or a character.

string—a string.

Description::

Returns a string described by x; specifically:

*

If x is a string, it is returned.

*

If x is a symbol, its name is returned.

*

If x is a character,

then a string containing that one character is returned.

*

string might perform additional, implementation-defined conversions.

Examples::

 (string "already a string") ⇒  "already a string"
 (string 'elm) ⇒  "ELM"
 (string #\c) ⇒  "c"

Exceptional Situations::

In the case where a conversion is defined neither by this specification nor by the implementation, an error of type type-error is signaled.

See Also::

coerce , string (type).

Notes::

coerce can be used to convert a sequence of characters to a string.

prin1-to-string, princ-to-string, write-to-string, or format (with a first argument of nil) can be used to get a string representation of a number or any other object.

gcl-2.6.14/info/gcl/first.html0000644000175000017500000001430514360276512014513 0ustar cammcamm first (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.21 first, second, third, fourth, fifth,

sixth, seventh, eighth, ninth, tenth

[Accessor]

first list ⇒ object (setf (first list) new-object)

second list ⇒ object (setf (second list) new-object)

third list ⇒ object (setf (third list) new-object)

fourth list ⇒ object (setf (fourth list) new-object)

fifth list ⇒ object (setf (fifth list) new-object)

sixth list ⇒ object (setf (sixth list) new-object)

seventh list ⇒ object (setf (seventh list) new-object)

eighth list ⇒ object (setf (eighth list) new-object)

ninth list ⇒ object (setf (ninth list) new-object)

tenth list ⇒ object (setf (tenth list) new-object)

Arguments and Values::

list—a list,

which might be a dotted list or a circular list.

object, new-object—an object.

Description::

The functions first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, and tenth access the first, second, third, fourth, fifth, sixth, seventh, eighth, ninth, and tenth elements of list, respectively. Specifically, 

 (first list)    ≡  (car list)
 (second list)   ≡  (car (cdr list))
 (third list)    ≡  (car (cddr list))
 (fourth list)   ≡  (car (cdddr list))
 (fifth list)    ≡  (car (cddddr list))
 (sixth list)    ≡  (car (cdr (cddddr list)))
 (seventh list)  ≡  (car (cddr (cddddr list)))
 (eighth list)   ≡  (car (cdddr (cddddr list)))
 (ninth list)    ≡  (car (cddddr (cddddr list)))
 (tenth list)    ≡  (car (cdr (cddddr (cddddr list))))

setf can also be used with any of these functions to change an existing component. The same equivalences apply. For example: 

 (setf (fifth list) new-object) ≡ (setf (car (cddddr list)) new-object)

Examples::

 (setq lst '(1 2 3 (4 5 6) ((V)) vi 7 8 9 10)) 
⇒  (1 2 3 (4 5 6) ((V)) VI 7 8 9 10)
 (first lst) ⇒  1
 (tenth lst) ⇒  10
 (fifth lst) ⇒  ((V))
 (second (fourth lst)) ⇒  5
 (sixth '(1 2 3)) ⇒  NIL
 (setf (fourth lst) "four") ⇒  "four"
 lst ⇒  (1 2 3 "four" ((V)) VI 7 8 9 10)

See Also::

car , nth

Notes::

first is functionally equivalent to car, second is functionally equivalent to cadr, third is functionally equivalent to caddr, and fourth is functionally equivalent to cadddr.

The ordinal numbering used here is one-origin, as opposed to the zero-origin numbering used by nth: 

 (fifth x) ≡ (nth 4 x)

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/go.html0000644000175000017500000000753214360276512013775 0ustar cammcamm go (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.24 go [Special Operator]

go tag ⇒ #<NoValue>

Arguments and Values::

tag—a go tag.

Description::

go transfers control to the point in the body of an enclosing tagbody form labeled by a tag eql to tag. If there is no such tag in the body, the bodies of lexically containing tagbody forms (if any) are examined as well. If several tags are eql to tag, control is transferred to whichever matching tag is contained in the innermost tagbody form that contains the go. The consequences are undefined if there is no matching tag lexically visible to the point of the go.

The transfer of control initiated by go is performed as described in Transfer of Control to an Exit Point.

Examples::

 (tagbody
   (setq val 2)
   (go lp)
   (incf val 3)
   lp (incf val 4)) ⇒  NIL
 val ⇒  6

The following is in error because there is a normal exit of the tagbody before the go is executed. 

 (let ((a nil)) 
   (tagbody t (setq a #'(lambda () (go t))))
   (funcall a))

The following is in error because the tagbody is passed over before the go form is executed. 

 (funcall (block nil
            (tagbody a (return #'(lambda () (go a))))))

See Also::

tagbody

gcl-2.6.14/info/gcl/case.html0000644000175000017500000002262614360276512014304 0ustar cammcamm case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.46 case, ccase, ecase [Macro]

case keyform {!normal-clause}* [!otherwise-clause] ⇒ {result}*

ccase keyplace {!normal-clause}* ⇒ {result}*

ecase keyform {!normal-clause}* ⇒ {result}*

normal-clause ::=(keys {form}*)

otherwise-clause ::=({otherwise | t} {form}*)

clause ::=normal-clause | otherwise-clause

Arguments and Values::

keyform—a form; evaluated to produce a test-key.

keyplace—a form; evaluated initially to produce a test-key. Possibly also used later as a place if no keys match.

test-key—an object produced by evaluating keyform or keyplace.

keys—a designator for a list of objects. In the case of case, the symbols t and otherwise may not be used as the keys designator. To refer to these symbols by themselves as keys, the designators (t) and (otherwise), respectively, must be used instead.

forms—an implicit progn.

results—the values returned by the forms in the matching clause.

Description::

These macros allow the conditional execution of a body of forms in a clause that is selected by matching the test-key on the basis of its identity.

The keyform or keyplace is evaluated to produce the test-key.

Each of the normal-clauses is then considered in turn. If the test-key is the same as any key for that clause, the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the case, ccase, or ecase form.

These macros differ only in their behavior when no normal-clause matches; specifically:

case

If no normal-clause matches, and there is an otherwise-clause, then that otherwise-clause automatically matches; the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the case.

If there is no otherwise-clause, case returns nil.

ccase

If no normal-clause matches, a correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (member key1 key2 ...). The store-value restart can be used to correct the error.

If the store-value restart is invoked, its argument becomes the new test-key, and is stored in keyplace as if by (setf keyplace test-key). Then ccase starts over, considering each clause anew.

[Reviewer Note by Barmar: Will it prompt for multiple values if keyplace is a VALUES general ref?]

The subforms of keyplace might be evaluated again if none of the cases holds.

ecase

If no normal-clause matches, a non-correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (member key1 key2 ...).

Note that in contrast with ccase, the caller of ecase may rely on the fact that ecase does not return if a normal-clause does not match.

Examples::

 (dolist (k '(1 2 3 :four #\v () t 'other))
    (format t "~S "
       (case k ((1 2) 'clause1)
               (3 'clause2)
               (nil 'no-keys-so-never-seen)
               ((nil) 'nilslot)
               ((:four #\v) 'clause4)
               ((t) 'tslot)
               (otherwise 'others)))) 
 |>  CLAUSE1 CLAUSE1 CLAUSE2 CLAUSE4 CLAUSE4 NILSLOT TSLOT OTHERS 
⇒  NIL
 (defun add-em (x) (apply #'+ (mapcar #'decode x)))
⇒  ADD-EM
 (defun decode (x)
   (ccase x
     ((i uno) 1)
     ((ii dos) 2)
     ((iii tres) 3)
     ((iv cuatro) 4)))
⇒  DECODE
 (add-em '(uno iii)) ⇒  4
 (add-em '(uno iiii))
 |>  Error: The value of X, IIII, is not I, UNO, II, DOS, III,
 |>         TRES, IV, or CUATRO.
 |>   1: Supply a value to use instead.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Value to evaluate and use for X: |>>'IV<<|
⇒  5

Side Effects::

The debugger might be entered. If the store-value restart is invoked, the value of keyplace might be changed.

Affected By::

ccase and ecase, since they might signal an error, are potentially affected by existing handlers and *debug-io*.

Exceptional Situations::

ccase and ecase signal an error of type type-error if no normal-clause matches.

See Also::

cond , typecase , setf , Generalized Reference

Notes::

(case test-key
  {(({key}*) {form}*)}*)
≡
(let ((#1=#:g0001 test-key))
  (cond {((member #1# '({key}*)) {form}*)}*))

The specific error message used by ecase and ccase can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use case with an otherwise-clause that explicitly signals an error with an appropriate message.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/values-_0028Type-Specifier_0029.html0000644000175000017500000000763514360276512020644 0ustar cammcamm values (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.22 values [Type Specifier]

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(values{!value-typespec})

[Reviewer Note by Barmar: Missing &key]

value-typespec ::={typespec}* [&optional {typespec}*] [&rest typespec ] [&allow-other-keys]

Compound Type Specifier Arguments::

typespec—a type specifier.

Compound Type Specifier Description::

This type specifier can be used only as the value-type in a function type specifier or a the special form. It is used to specify individual types when multiple values are involved. The &optional and &rest markers can appear in the value-type list; they indicate the parameter list of a function that, when given to multiple-value-call along with the values, would correctly receive those values.

The symbol * may not be among the value-types.

The symbol values is not valid as a type specifier; and, specifically, it is not an abbreviation for (values).

gcl-2.6.14/info/gcl/integer_002dlength.html0000644000175000017500000000770314360276512016754 0ustar cammcamm integer-length (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.57 integer-length [Function]

integer-length integer ⇒ number-of-bits

Arguments and Values::

integer—an integer.

number-of-bits—a non-negative integer.

Description::

Returns the number of bits needed to represent integer in binary two’s-complement format.

Examples::

 (integer-length 0) ⇒  0
 (integer-length 1) ⇒  1
 (integer-length 3) ⇒  2
 (integer-length 4) ⇒  3
 (integer-length 7) ⇒  3
 (integer-length -1) ⇒  0
 (integer-length -4) ⇒  2
 (integer-length -7) ⇒  3
 (integer-length -8) ⇒  3
 (integer-length (expt 2 9)) ⇒  10
 (integer-length (1- (expt 2 9))) ⇒  9
 (integer-length (- (expt 2 9))) ⇒  9
 (integer-length (- (1+ (expt 2 9)))) ⇒  10

Exceptional Situations::

Should signal an error of type type-error if integer is not an integer.

Notes::

This function could have been defined by: 

(defun integer-length (integer)
  (ceiling (log (if (minusp integer)
                    (- integer)
                    (1+ integer))
                2)))

If integer is non-negative, then its value can be represented in unsigned binary form in a field whose width in bits is no smaller than (integer-length integer). Regardless of the sign of integer, its value can be represented in signed binary two’s-complement form in a field whose width in bits is no smaller than (+ (integer-length integer) 1).

gcl-2.6.14/info/gcl/floating_002dpoint_002dinvalid_002doperation.html0000644000175000017500000000561314360276512023532 0ustar cammcamm floating-point-invalid-operation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.81 floating-point-invalid-operation [Condition Type]

Class Precedence List::

floating-point-invalid-operation, arithmetic-error, error, serious-condition, condition, t

Description::

The type floating-point-invalid-operation consists of error conditions that occur because of certain floating point traps.

It is implementation-dependent whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being signaled.

gcl-2.6.14/info/gcl/keywordp.html0000644000175000017500000000631714360276512015234 0ustar cammcamm keywordp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.4 keywordp [Function]

keywordp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is a keyword_1; otherwise, returns false.

Examples::

 (keywordp 'elephant) ⇒  false
 (keywordp 12) ⇒  false
 (keywordp :test) ⇒  true
 (keywordp ':test) ⇒  true
 (keywordp nil) ⇒  false
 (keywordp :nil) ⇒  true
 (keywordp '(:test)) ⇒  false
 (keywordp "hello") ⇒  false
 (keywordp ":hello") ⇒  false
 (keywordp '&optional) ⇒  false

See Also::

constantp , keyword , symbolp , symbol-package

gcl-2.6.14/info/gcl/set_002ddispatch_002dmacro_002dcharacter.html0000644000175000017500000001456614360276512022606 0ustar cammcamm set-dispatch-macro-character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.9 set-dispatch-macro-character, get-dispatch-macro-character

[Function]

get-dispatch-macro-character disp-char sub-char &optional readtable ⇒ function

set-dispatch-macro-character disp-char sub-char new-function &optional readtable ⇒ t

Arguments and Values::

disp-char—a character.

sub-char—a character.

readtable—a readtable designator.

The default is the current readtable.

function—a function designator or nil.

new-function—a function designator.

Description::

set-dispatch-macro-character causes new-function to be called when disp-char followed by sub-char is read. If sub-char is a lowercase letter, it is converted to its uppercase equivalent. It is an error if sub-char is one of the ten decimal digits.

set-dispatch-macro-character installs a new-function to be called when a particular dispatching macro character pair is read. New-function is installed as the dispatch function to be called when readtable is in use and when disp-char is followed by sub-char.

For more information about how the new-function is invoked, see Macro Characters.

get-dispatch-macro-character retrieves the dispatch function associated with disp-char and sub-char in readtable.

get-dispatch-macro-character returns the macro-character function for sub-char under disp-char, or nil if there is no function associated with sub-char. If sub-char is a decimal digit, get-dispatch-macro-character returns nil.

Examples::

 (get-dispatch-macro-character #\# #\{) ⇒  NIL
 (set-dispatch-macro-character #\# #\{        ;dispatch on #{
    #'(lambda(s c n)
        (let ((list (read s nil (values) t)))  ;list is object after #n{
          (when (consp list)                   ;return nth element of list
            (unless (and n (< 0 n (length list))) (setq n 0))
            (setq list (nth n list)))
         list))) ⇒  T
 #{(1 2 3 4) ⇒  1
 #3{(0 1 2 3) ⇒  3
 #{123 ⇒  123

If it is desired that #$foo : as if it were (dollars foo). 

(defun |#$-reader| (stream subchar arg)
   (declare (ignore subchar arg))
   (list 'dollars (read stream t nil t))) ⇒  |#$-reader|
 (set-dispatch-macro-character #\# #\$ #'|#$-reader|) ⇒  T

See Also::

Macro Characters

Side Effects::

The readtable is modified.

Affected By::

*readtable*.

Exceptional Situations::

For either function, an error is signaled if disp-char is not a dispatching macro character in readtable.

See Also::

readtable

Notes::

It is necessary to use make-dispatch-macro-character to set up the dispatch character before specifying its sub-characters.

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/Requiring-Non_002dNull-Rest-Parameters-in-The-_0022Syntax_0022-Section.html0000644000175000017500000000626114360276512027575 0ustar cammcamm Requiring Non-Null Rest Parameters in The "Syntax" Section (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.27 Requiring Non-Null Rest Parameters in The "Syntax" Section

In some cases it is useful to refer to all arguments equally as a single aggregation using a rest parameter while at the same time requiring at least one argument. A variety of imperative and declarative means are available in code for expressing such a restriction, however they generally do not manifest themselves in a lambda list. For descriptive purposes within this specification,

F &rest arguments^+

means the same as

F &rest arguments

but introduces the additional requirement that there be at least one argument.

gcl-2.6.14/info/gcl/describe_002dobject.html0000644000175000017500000001341314360276512017057 0ustar cammcamm describe-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.7 describe-object [Standard Generic Function]

Syntax::

describe-object object stream ⇒ implementation-dependent

Method Signatures::

describe-object (object standard-object) stream

Arguments and Values::

object—an object.

stream—a stream.

Description::

The generic function describe-object prints a description of object to a stream. describe-object is called by describe; it must not be called by the user.

Each implementation is required to provide a method on the class standard-object and methods on enough other classes so as to ensure that there is always an applicable method. Implementations are free to add methods for other classes. Users can write methods for describe-object for their own classes if they do not wish to inherit an implementation-supplied method.

Methods on describe-object can recursively call describe. Indentation, depth limits, and circularity detection are all taken care of automatically, provided that each method handles exactly one level of structure and calls describe recursively if there are more structural levels. The consequences are undefined if this rule is not obeyed.

In some implementations the stream argument passed to a describe-object method is not the original stream, but is an intermediate stream that implements parts of describe. Methods should therefore not depend on the identity of this stream.

Examples::

 (defclass spaceship ()
   ((captain :initarg :captain :accessor spaceship-captain)
    (serial# :initarg :serial-number :accessor spaceship-serial-number)))

 (defclass federation-starship (spaceship) ())

 (defmethod describe-object ((s spaceship) stream)
   (with-slots (captain serial#) s
     (format stream "~&~S is a spaceship of type ~S,~
                     ~
                       and with serial number ~D.~
             s (type-of s) captain serial#)))

 (make-instance 'federation-starship
                :captain "Rachel Garrett"
                :serial-number "NCC-1701-C")
⇒  #<FEDERATION-STARSHIP 26312465>

 (describe *)
 |>  #<FEDERATION-STARSHIP 26312465> is a spaceship of type FEDERATION-STARSHIP,
 |>  with Rachel Garrett at the helm and with serial number NCC-1701-C.
⇒  <no values>

See Also::

describe

Notes::

The same implementation techniques that are applicable to print-object are applicable to describe-object.

The reason for making the return values for describe-object unspecified is to avoid forcing users to include explicit (values) in all of their methods. describe takes care of that.

Next: , Previous: , Up: Environment Dictionary  

gcl-2.6.14/info/gcl/simple_002dtype_002derror.html0000644000175000017500000000576214360276512020112 0ustar cammcamm simple-type-error (ANSI and GNU Common Lisp Document)

Previous: , Up: Types and Classes Dictionary  

4.4.31 simple-type-error [Condition Type]

Class Precedence List::

simple-type-error, simple-condition, type-error, error, serious-condition, condition, t

Description::

Conditions of type simple-type-error are like conditions of type type-error, except that they provide an alternate mechanism for specifying how the condition is to be reported; see the type simple-condition.

See Also::

simple-condition,

simple-condition-format-control ,

simple-condition-format-arguments, type-error-datum , type-error-expected-type

gcl-2.6.14/info/gcl/Examples-of-MAXIMIZE-and-MINIMIZE-clauses.html0000644000175000017500000000536014360276512022402 0ustar cammcamm Examples of MAXIMIZE and MINIMIZE clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Value Accumulation Clauses  

6.1.3.4 Examples of MAXIMIZE and MINIMIZE clauses

 (loop for i in '(2 1 5 3 4)
       maximize i)
⇒  5
 (loop for i in '(2 1 5 3 4)
       minimize i)
⇒  1

;; In this example, FIXNUM applies to the internal variable that holds
;; the maximum value.
 (setq series '(1.2 4.3 5.7))
⇒  (1.2 4.3 5.7)
 (loop for v in series 
       maximize (round v) of-type fixnum)
⇒  6

;; In this example, FIXNUM applies to the variable RESULT.
 (loop for v of-type float in series
       minimize (round v) into result of-type fixnum
       finally (return result))
⇒  1
gcl-2.6.14/info/gcl/Common-Case-in-Pathname-Components.html0000644000175000017500000000576414360276512021760 0ustar cammcamm Common Case in Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.5 Common Case in Pathname Components

For the functions in Figure~19–2, a value of :common for the :case argument that these functions should receive and yield strings in component values according to the following conventions:

*

All uppercase means to use a file system’s customary case.

*

All lowercase means to use the opposite of the customary case.

*

Mixed case represents itself.

Note that these conventions have been chosen in such a way that translation from :local to :common and back to :local is information-preserving.

gcl-2.6.14/info/gcl/Termination-Test-Clauses.html0000644000175000017500000001755514360276512020201 0ustar cammcamm Termination Test Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.4 Termination Test Clauses

The repeat construct causes iteration to terminate after a specified number of times. The loop body executes n times, where n is the value of the expression form. The form argument is evaluated one time in the loop prologue. If the expression evaluates to 0 or to a negative number, the loop body is not evaluated.

The constructs always, never, thereis, while, until, and the macro loop-finish allow conditional termination of iteration within a loop.

The constructs always, never, and thereis provide specific values to be returned when a loop terminates. Using always, never, or thereis in a loop with value accumulation clauses that are not into causes an error of type program-error to be signaled (at macro expansion time). Since always, never, and thereis use

the return-from special operator

to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to any of these constructs. In all other respects these constructs behave like the while and until constructs.

The always construct takes one form and terminates the loop if the form ever evaluates to nil; in this case, it returns nil. Otherwise, it provides a default return value of t. If the value of the supplied form is never nil, some other construct can terminate the iteration.

The never construct terminates iteration the first time that the value of the supplied form is non-nil; the loop returns nil. If the value of the supplied form is always nil, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is t.

The thereis construct terminates iteration the first time that the value of the supplied form is non-nil; the loop returns the value of the supplied form. If the value of the supplied form is always nil, some other construct can terminate the iteration. Unless some other clause contributes a return value, the default value returned is nil.

There are two differences between the thereis and until constructs:

*

The until construct does not return a value or nil based on the value of the supplied form.

*

The until construct executes any finally clause. Since thereis uses

the return-from special operator

to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to thereis.

The while construct allows iteration to continue until the supplied form evaluates to false. The supplied form is reevaluated at the location of the while clause.

The until construct is equivalent to while (not form)\dots. If the value of the supplied form is non-nil, iteration terminates.

Termination-test control constructs can be used anywhere within the loop body. The termination tests are used in the order in which they appear. If an until or while clause causes termination, any clauses that precede it in the source are still evaluated. If the until and while constructs cause termination, control is passed to the loop epilogue, where any finally clauses will be executed.

There are two differences between the never and until constructs:

*

The until construct does not return t or nil based on the value of the supplied form.

*

The until construct does not bypass any finally clauses. Since never uses

the return-from special operator

to terminate iteration, any finally clause that is supplied is not evaluated when exit occurs due to never.

In most cases it is not necessary to use loop-finish because other loop control clauses terminate the loop. The macro loop-finish is used to provide a normal exit from a nested conditional inside a loop. Since loop-finish transfers control to the loop epilogue, using loop-finish within a finally expression can cause infinite looping.

• Examples of REPEAT clause  
• Examples of ALWAYS  
• Examples of WHILE and UNTIL clauses  

Next: , Previous: , Up: The LOOP Facility  

gcl-2.6.14/info/gcl/Constraints-on-Macros-and-Compiler-Macros.html0000644000175000017500000000542614360276512023265 0ustar cammcamm Constraints on Macros and Compiler Macros (ANSI and GNU Common Lisp Document)

Previous: , Up: File Compilation  

3.2.3.3 Constraints on Macros and Compiler Macros

Except where explicitly stated otherwise, no macro defined in the Common Lisp standard produces an expansion that could cause any of the subforms of the macro form to be treated as top level forms. If an implementation also provides a special operator definition of a Common Lisp macro, the special operator definition must be semantically equivalent in this respect.

Compiler macro expansions must also have the same top level evaluation semantics as the form which they replace. This is of concern both to conforming implementations and to conforming programs.

gcl-2.6.14/info/gcl/Interfaces-to-Restarts.html0000644000175000017500000000607414360276512017700 0ustar cammcamm Interfaces to Restarts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.5 Interfaces to Restarts

Some restarts have functional interfaces, such as abort, continue, muffle-warning, store-value, and use-value. They are ordinary functions that use find-restart and invoke-restart internally, that have the same name as the restarts they manipulate, and that are provided simply for notational convenience.

Figure 9–6 shows defined names relating to restarts. 

  abort             invoke-restart-interactively  store-value          
  compute-restarts  muffle-warning                use-value            
  continue          restart-bind                  with-simple-restart  
  find-restart      restart-case                                       
  invoke-restart    restart-name                                       

            Figure 9–6: Defined names relating to restarts.
gcl-2.6.14/info/gcl/Notes-about-the-Pathname-Version-Component.html0000644000175000017500000000550214360276512023457 0ustar cammcamm Notes about the Pathname Version Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.20 Notes about the Pathname Version Component

It is suggested, but not required, that implementations do the following:

*

Use positive integers starting at 1 as version numbers.

*

Recognize the symbol :oldest to designate the smallest existing version number.

*

Use keywords for other special versions.

gcl-2.6.14/info/gcl/_002aprint_002dgensym_002a.html0000644000175000017500000000575614360276512017746 0ustar cammcamm *print-gensym* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.21 *print-gensym* [Variable]

Value Type::

a generalized boolean.

Initial Value::

true.

Description::

Controls whether the prefix “#:” is printed before apparently uninterned symbols. The prefix is printed before such symbols if and only if the value of *print-gensym* is true.

Examples::

 (let ((*print-gensym* nil))
   (print (gensym)))
 |>  G6040 
⇒  #:G6040

See Also::

write , *print-escape*

gcl-2.6.14/info/gcl/The-LOOP-Facility.html0000644000175000017500000000733514360276512016422 0ustar cammcamm The LOOP Facility (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Iteration  

6.1 The LOOP Facility

• Overview of the Loop Facility  
• Variable Initialization and Stepping Clauses  
• Value Accumulation Clauses  
• Termination Test Clauses  
• Unconditional Execution Clauses  
• Conditional Execution Clauses  
• Miscellaneous Clauses  
• Examples of Miscellaneous Loop Features  
• Notes about Loop  
gcl-2.6.14/info/gcl/ash.html0000644000175000017500000001004014360276512014127 0ustar cammcamm ash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.56 ash [Function]

ash integer count ⇒ shifted-integer

Arguments and Values::

integer—an integer.

count—an integer.

shifted-integer—an integer.

Description::

ash performs the arithmetic shift operation on the binary representation of integer, which is treated as if it were binary.

ash shifts integer arithmetically left by count bit positions if count is positive, or right count bit positions if count is negative. The shifted value of the same sign as integer is returned.

Mathematically speaking, ash performs the computation floor(integer\cdot 2^count). Logically, ash moves all of the bits in integer to the left, adding zero-bits at the right, or moves them to the right, discarding bits.

ash is defined to behave as if integer were represented in two’s complement form, regardless of how integers are represented internally.

Examples::

 (ash 16 1) ⇒  32
 (ash 16 0) ⇒  16
 (ash 16 -1) ⇒  8
 (ash -100000000000000000000000000000000 -100) ⇒  -79

Exceptional Situations::

Should signal an error of type type-error if integer is not an integer. Should signal an error of type type-error if count is not an integer. Might signal arithmetic-error.

Notes::

 (logbitp j (ash n k))
 ≡ (and (>= j k) (logbitp (- j k) n))
gcl-2.6.14/info/gcl/character-_0028System-Class_0029.html0000644000175000017500000000554214360276512020773 0ustar cammcamm character (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.1 character [System Class]

Class Precedence List::

character, t

Description::

A character is an object that represents a unitary token in an aggregate quantity of text; see Character Concepts.

The types base-char and extended-char form an exhaustive partition of the type character.

See Also::

Character Concepts, Sharpsign Backslash, Printing Characters

gcl-2.6.14/info/gcl/Notes-about-Backquote.html0000644000175000017500000000545414360276512017505 0ustar cammcamm Notes about Backquote (ANSI and GNU Common Lisp Document)

Previous: , Up: Backquote  

2.4.6.1 Notes about Backquote

Since the exact manner in which the Lisp reader will parse an expression involving the backquote reader macro is not specified, an implementation is free to choose any representation that preserves the semantics described.

Often an implementation will choose a representation that facilitates pretty printing of the expression, so that (pprint `(a ,b)) will display `(a ,b) and not, for example, (list 'a b). However, this is not a requirement.

Implementors who have no particular reason to make one choice or another might wish to refer to IEEE Standard for the Scheme Programming Language, which identifies a popular choice of representation for such expressions that might provide useful to be useful compatibility for some user communities. There is no requirement, however, that any conforming implementation use this particular representation. This information is provided merely for cross-reference purposes.

gcl-2.6.14/info/gcl/Locating-a-Symbol-in-a-Package.html0000644000175000017500000000530114360276512020754 0ustar cammcamm Locating a Symbol in a Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.6 Locating a Symbol in a Package

When a symbol is to be located in a given package the following occurs:

–

The external symbols and internal symbols of the package are searched for the symbol.

–

The external symbols of the used packages are searched in some unspecified order. The order does not matter; see the rules for handling name conflicts listed below.

gcl-2.6.14/info/gcl/Accessibility-of-Symbols-in-a-Package.html0000644000175000017500000000765514360276512022370 0ustar cammcamm Accessibility of Symbols in a Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.5 Accessibility of Symbols in a Package

A symbol becomes accessible in a package if that is its home package when it is created, or if it is imported into that package, or by inheritance via use-package.

If a symbol is accessible in a package, it can be referred to when using the Lisp reader without a package prefix when that package is the current package, regardless of whether it is present or inherited.

Symbols from one package can be made accessible in another package in two ways.

–

Any individual symbol can be added to a package by use of import. After the call to import the symbol is present in the importing package. The status of the symbol in the package it came from (if any) is unchanged, and the home package for this symbol is unchanged. Once imported, a symbol is present in the importing package and can be removed only by calling unintern.

A symbol is shadowed_3 by another symbol in some package if the first symbol would be accessible by inheritance if not for the presence of the second symbol. See shadowing-import.

–

The second mechanism for making symbols from one package accessible in another is provided by use-package. All of the external symbols of the used package are inherited by the using package. The function unuse-package undoes the effects of a previous use-package.

gcl-2.6.14/info/gcl/add_002dmethod.html0000644000175000017500000000771314360276512016047 0ustar cammcamm add-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.35 add-method [Standard Generic Function]

Syntax::

add-method generic-function method ⇒ generic-function

Method Signatures::

add-method (generic-function standard-generic-function) (method method)

Arguments and Values::

generic-function—a generic function object.

method—a method object.

Description::

The generic function add-method adds a method to a generic function.

If method agrees with an existing method of generic-function on parameter specializers and qualifiers, the existing method is replaced.

Exceptional Situations::

The lambda list of the method function of method must be congruent with the lambda list of generic-function, or an error of type error is signaled.

If method is a method object of another generic function, an error of type error is signaled.

See Also::

defmethod , defgeneric , find-method , remove-method , Agreement on Parameter Specializers and Qualifiers

gcl-2.6.14/info/gcl/Types-and-Classes-Dictionary.html0000644000175000017500000001630614360276512020731 0ustar cammcamm Types and Classes Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Types and Classes  

4.4 Types and Classes Dictionary

• nil (Type)  
• boolean  
• function (System Class)  
• compiled-function  
• generic-function  
• standard-generic-function  
• class  
• built-in-class  
• structure-class  
• standard-class  
• method  
• standard-method  
• structure-object  
• standard-object  
• method-combination  
• t (System Class)  
• satisfies  
• member (Type Specifier)  
• not (Type Specifier)  
• and (Type Specifier)  
• or (Type Specifier)  
• values (Type Specifier)  
• eql (Type Specifier)  
• coerce  
• deftype  
• subtypep  
• type-of  
• typep  
• type-error  
• type-error-datum  
• simple-type-error  

Previous: , Up: Types and Classes  

gcl-2.6.14/info/gcl/end_002dof_002dfile.html0000644000175000017500000000505314360276512016571 0ustar cammcamm end-of-file (ANSI and GNU Common Lisp Document)

Previous: , Up: Streams Dictionary  

21.2.57 end-of-file [Condition Type]

Class Precedence List::

end-of-file, stream-error, error, serious-condition, condition, t

Description::

The type end-of-file consists of error conditions related to read operations that are done on streams that have no more data.

See Also::

stream-error-stream

gcl-2.6.14/info/gcl/two_002dway_002dstream.html0000644000175000017500000000540414360276512017404 0ustar cammcamm two-way-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.8 two-way-stream [System Class]

Class Precedence List::

two-way-stream, stream, t

Description::

A bidirectional composite stream that receives its input from an associated input stream and sends its output to an associated output stream.

See Also::

make-two-way-stream , two-way-stream-input-stream , two-way-stream-output-stream

gcl-2.6.14/info/gcl/package_002dnicknames.html0000644000175000017500000000616014360276512017375 0ustar cammcamm package-nicknames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.23 package-nicknames [Function]

package-nicknames package ⇒ nicknames

Arguments and Values::

package—a package designator.

nicknames—a list of strings.

Description::

Returns the list of nickname strings for package, not including the name of package.

Examples::

 (package-nicknames (make-package 'temporary
                                   :nicknames '("TEMP" "temp")))
⇒  ("temp" "TEMP")

Exceptional Situations::

Should signal an error of type type-error if package is not a package designator.

gcl-2.6.14/info/gcl/unwind_002dprotect.html0000644000175000017500000001774014360276512017024 0ustar cammcamm unwind-protect (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.29 unwind-protect [Special Operator]

unwind-protect protected-form {cleanup-form}* ⇒ {result}*

Arguments and Values::

protected-form—a form.

cleanup-form—a form.

results—the values of the protected-form.

Description::

unwind-protect evaluates protected-form and guarantees that cleanup-forms are executed before unwind-protect exits, whether it terminates normally or is aborted by a control transfer of some kind. unwind-protect is intended to be used to make sure that certain side effects take place after the evaluation of protected-form.

If a non-local exit occurs during execution of cleanup-forms, no special action is taken. The cleanup-forms of unwind-protect are not protected by that unwind-protect.

unwind-protect protects against all attempts to exit from protected-form, including go, handler-case, ignore-errors, restart-case, return-from, throw, and with-simple-restart.

Undoing of handler and restart bindings during an exit happens in parallel with the undoing of the bindings of dynamic variables and catch tags, in the reverse order in which they were established. The effect of this is that cleanup-form sees the same handler and restart bindings, as well as dynamic variable bindings and catch tags, as were visible when the unwind-protect was entered.

Examples::

 (tagbody
   (let ((x 3))
     (unwind-protect
       (if (numberp x) (go out))
       (print x)))
  out
   ...)

When go is executed, the call to print is executed first, and then the transfer of control to the tag out is completed. 

 (defun dummy-function (x)
    (setq state 'running)
    (unless (numberp x) (throw 'abort 'not-a-number))
    (setq state (1+ x))) ⇒  DUMMY-FUNCTION
 (catch 'abort (dummy-function 1)) ⇒  2
 state ⇒  2
 (catch 'abort (dummy-function 'trash)) ⇒  NOT-A-NUMBER
 state ⇒  RUNNING
 (catch 'abort (unwind-protect (dummy-function 'trash) 
                  (setq state 'aborted))) ⇒  NOT-A-NUMBER
 state ⇒  ABORTED

The following code is not correct: 

 (unwind-protect
   (progn (incf *access-count*)
          (perform-access))
   (decf *access-count*))

If an exit occurs before completion of incf, the decf form is executed anyway, resulting in an incorrect value for *access-count*. The correct way to code this is as follows: 

 (let ((old-count *access-count*))
   (unwind-protect
     (progn (incf *access-count*)
            (perform-access))
     (setq *access-count* old-count)))

;;; The following returns 2.
 (block nil   
   (unwind-protect (return 1)
     (return 2)))

;;; The following has undefined consequences.
 (block a    
   (block b
     (unwind-protect (return-from a 1)
       (return-from b 2))))

;;; The following returns 2.
 (catch nil 
   (unwind-protect (throw nil 1)
     (throw nil 2)))

;;; The following has undefined consequences because the catch of B is 
;;; passed over by the first THROW, hence portable programs must assume 
;;; its dynamic extent is terminated.  The binding of the catch tag is not
;;; yet disestablished and therefore it is the target of the second throw.
 (catch 'a
   (catch 'b
     (unwind-protect (throw 'a 1)
       (throw 'b 2))))

;;; The following prints "The inner catch returns :SECOND-THROW"
;;; and then returns :OUTER-CATCH.
 (catch 'foo
         (format t "The inner catch returns ~s.~
                 (catch 'foo
                     (unwind-protect (throw 'foo :first-throw)
                         (throw 'foo :second-throw))))
         :outer-catch)

;;; The following returns 10. The inner CATCH of A is passed over, but 
;;; because that CATCH is disestablished before the THROW to A is executed,
;;; it isn't seen.
 (catch 'a
   (catch 'b
     (unwind-protect (1+ (catch 'a (throw 'b 1)))
       (throw 'a 10))))

;;; The following has undefined consequences because the extent of
;;; the (CATCH 'BAR ...) exit ends when the (THROW 'FOO ...)
;;; commences.
 (catch 'foo
   (catch 'bar
       (unwind-protect (throw 'foo 3)
         (throw 'bar 4)
         (print 'xxx))))

;;; The following returns 4; XXX is not printed.
;;; The (THROW 'FOO ...) has no effect on the scope of the BAR
;;; catch tag or the extent of the (CATCH 'BAR ...) exit.
 (catch 'bar
   (catch 'foo
       (unwind-protect (throw 'foo 3)
         (throw 'bar 4)
         (print 'xxx))))

;;; The following prints 5.
 (block nil
   (let ((x 5))
     (declare (special x))
     (unwind-protect (return)
       (print x))))

See Also::

catch , go , handler-case , restart-case , return , return-from , throw , Evaluation

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Open-and-Closed-Streams.html0000644000175000017500000000571214360276512017652 0ustar cammcamm Open and Closed Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.3 Open and Closed Streams

Streams are either open or closed .

Except as explicitly specified otherwise, operations that create and return streams return open streams.

The action of closing a stream marks the end of its use as a source or sink of data, permitting the implementation to reclaim its internal data structures, and to free any external resources which might have been locked by the stream when it was opened.

Except as explicitly specified otherwise, the consequences are undefined when a closed stream is used where a stream is called for.

Coercion of streams to pathnames is permissible for closed streams; in some situations, such as for a truename computation, the result might be different for an open stream and for that same stream once it has been closed.

gcl-2.6.14/info/gcl/pop.html0000644000175000017500000000760714360276512014171 0ustar cammcamm pop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.20 pop [Macro]

pop place ⇒ element

Arguments and Values::

place—a place, the value of which is a list (possibly, but necessarily, a dotted list or circular list).

element—an object (the car of the contents of place).

Description::

pop reads the value of place, remembers the car of the list which was retrieved, writes the cdr of the list back into the place, and finally yields the car of the originally retrieved list.

For information about the evaluation of subforms of place, see Evaluation of Subforms to Places.

Examples::

 (setq stack '(a b c)) ⇒  (A B C)
 (pop stack) ⇒  A  
 stack ⇒  (B C)
 (setq llst '((1 2 3 4))) ⇒  ((1 2 3 4))
 (pop (car llst)) ⇒  1
 llst ⇒  ((2 3 4))

Side Effects::

The contents of place are modified.

See Also::

push , pushnew , Generalized Reference

Notes::

The effect of (pop place) is roughly equivalent to 

 (prog1 (car place) (setf place (cdr place)))

except that the latter would evaluate any subforms of place three times, while pop evaluates them only once.

gcl-2.6.14/info/gcl/Modified-BNF-Syntax.html0000644000175000017500000000440014360276512016766 0ustar cammcamm Modified BNF Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.2 Modified BNF Syntax

This specification uses an extended Backus Normal Form (BNF) to describe the syntax of Common Lisp macro forms and special forms. This section discusses the syntax of BNF expressions.

gcl-2.6.14/info/gcl/Resolution-of-Apparent-Conflicts-in-Exceptional-Situations.html0000644000175000017500000000544214360276512026642 0ustar cammcamm Resolution of Apparent Conflicts in Exceptional Situations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.5 Resolution of Apparent Conflicts in Exceptional Situations

If more than one passage in this specification appears to apply to the same situation but in conflicting ways, the passage that appears to describe the situation in the most specific way (not necessarily the passage that provides the most constrained kind of error detection) takes precedence.

gcl-2.6.14/info/gcl/General-Restrictions-on-Parameters-that-must-be-Trees.html0000644000175000017500000000441614360276512025534 0ustar cammcamm General Restrictions on Parameters that must be Trees (ANSI and GNU Common Lisp Document)

Previous: , Up: Conses as Trees  

14.1.1.1 General Restrictions on Parameters that must be Trees

Except as explicitly stated otherwise, for any standardized function that takes a parameter that is required to be a tree, the consequences are undefined if that tree is circular.

gcl-2.6.14/info/gcl/Summary-of-Termination-Test-Clauses.html0000644000175000017500000001013014360276512022214 0ustar cammcamm Summary of Termination Test Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.10 Summary of Termination Test Clauses

The for and as constructs provide a termination test that is determined by the iteration control clause.

The repeat construct causes termination after a specified number of iterations. (It uses an internal variable to keep track of the number of iterations.)

The while construct takes one form, a test, and terminates the iteration if the test evaluates to false. A while clause is equivalent to the expression (if (not test) (loop-finish)).

The until construct is the inverse of while; it terminates the iteration if the test evaluates to any non-nil value. An until clause is equivalent to the expression (if test (loop-finish)).

The always construct takes one form and terminates the loop if the form ever evaluates to false; in this case, the loop form returns nil. Otherwise, it provides a default return value of t.

The never construct takes one form and terminates the loop if the form ever evaluates to true; in this case, the loop form returns nil. Otherwise, it provides a default return value of t.

The thereis construct takes one form and terminates the loop if the form ever evaluates to a non-nil object; in this case, the loop form returns that object.

Otherwise, it provides a default return value of nil.

If multiple termination test clauses are specified, the loop form terminates if any are satisfied.

For more information, see Termination Test Clauses.

gcl-2.6.14/info/gcl/Processing-of-Defining-Macros.html0000644000175000017500000001223314360276512021043 0ustar cammcamm Processing of Defining Macros (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: File Compilation  

3.2.3.2 Processing of Defining Macros

Defining macros (such as defmacro or defvar) appearing within a file being processed by compile-file normally have compile-time side effects which affect how subsequent forms in the same file are compiled. A convenient model for explaining how these side effects happen is that the defining macro expands into one or more eval-when forms, and that the calls which cause the compile-time side effects to happen appear in the body of an (eval-when (:compile-toplevel) ...) form.

The compile-time side effects may cause information about the definition to be stored differently than if the defining macro had been processed in the ‘normal’ way (either interpretively or by loading the compiled file).

In particular, the information stored by the defining macros at compile time might or might not be available to the interpreter (either during or after compilation), or during subsequent calls to the compiler. For example, the following code is nonportable because it assumes that the compiler stores the macro definition of foo where it is available to the interpreter: 

 (defmacro foo (x) `(car ,x))
 (eval-when (:execute :compile-toplevel :load-toplevel)
   (print (foo '(a b c))))

A portable way to do the same thing would be to include the macro definition inside the eval-when form, as in: 

 (eval-when (:execute :compile-toplevel :load-toplevel)
   (defmacro foo (x) `(car ,x))
   (print (foo '(a b c))))

Figure 3–8 lists macros that make definitions available both in the compilation and run-time environments. It is not specified whether definitions made available in the compilation environment are available in the evaluation environment, nor is it specified whether they are available in subsequent compilation units or subsequent invocations of the compiler. As with eval-when, these compile-time side effects happen only when the defining macros appear at top level. 

  declaim                define-modify-macro   defsetf    
  defclass               define-setf-expander  defstruct  
  defconstant            defmacro              deftype    
  define-compiler-macro  defpackage            defvar     
  define-condition       defparameter                     

  Figure 3–8: Defining Macros That Affect the Compile-Time Environment

Next: , Previous: , Up: File Compilation  

gcl-2.6.14/info/gcl/Examples-of-Truenames.html0000644000175000017500000000712614360276512017510 0ustar cammcamm Examples of Truenames (ANSI and GNU Common Lisp Document)

Previous: , Up: Truenames  

20.1.3.1 Examples of Truenames

For example, a DEC TOPS-20 system with files PS:<JOE>FOO.TXT.1 and PS:<JOE>FOO.TXT.2 might permit the second file to be referred to as PS:<JOE>FOO.TXT.0, since the “.0” notation denotes “newest” version of several files. In the same file system, a “logical device” “JOE:” might be taken to refer to PS:<JOE>” and so the names JOE:FOO.TXT.2 or JOE:FOO.TXT.0 might refer to PS:<JOE>FOO.TXT.2. In all of these cases, the truename of the file would probably be PS:<JOE>FOO.TXT.2.

If a file is a symbolic link to another file (in a file system permitting such a thing), it is conventional for the truename to be the canonical name of the file after any symbolic links have been followed; that is, it is the canonical name of the file whose contents would become available if an input stream to that file were opened.

In the case of a file still being created (that is, of an output stream open to such a file), the exact truename of the file might not be known until the stream is closed. In this case, the function truename might return different values for such a stream before and after it was closed. In fact, before it is closed, the name returned might not even be a valid name in the file system—for example, while a file is being written, it might have version :newest and might only take on a specific numeric value later when the file is closed even in a file system where all files have numeric versions.

gcl-2.6.14/info/gcl/Externalizable-Objects.html0000644000175000017500000000770614360276512017733 0ustar cammcamm Externalizable Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Literal Objects in Compiled Files  

3.2.4.1 Externalizable Objects

The fact that the file compiler represents literal objects externally in a compiled file and must later reconstruct suitable equivalents of those objects when that file is loaded imposes a need for constraints on the nature of the objects that can be used as literal objects in code to be processed by the file compiler.

An object that can be used as a literal object in code to be processed by the file compiler is called an externalizable object .

We define that two objects are similar if they satisfy a two-place conceptual equivalence predicate (defined below), which is independent of the Lisp image so that the two objects in different Lisp images can be understood to be equivalent under this predicate. Further, by inspecting the definition of this conceptual predicate, the programmer can anticipate what aspects of an object are reliably preserved by file compilation.

The file compiler must cooperate with the loader in order to assure that in each case where an externalizable object is processed as a literal object, the loader will construct a similar object.

The set of objects that are externalizable objects are those for which the new conceptual term “similar” is defined, such that when a compiled file is loaded, an object can be constructed which can be shown to be similar to the original object which existed at the time the file compiler was operating.

gcl-2.6.14/info/gcl/type.html0000644000175000017500000002472214360276512014351 0ustar cammcamm type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.21 type [Declaration]

Syntax::

(type typespec {var}*)

(typespec {var}*)

Arguments::

typespec—a type specifier.

var—a variable name.

Valid Context::

declaration or proclamation

Binding Types Affected::

variable

Description::

Affects only variable bindings and specifies that the vars take on values only of the specified typespec. In particular, values assigned to the variables by setq, as well as the initial values of the vars must be of the specified typespec. type declarations never apply to function bindings (see ftype).

A type declaration of a symbol defined by symbol-macrolet is equivalent to wrapping a the expression around the expansion of that symbol,

although the symbol’s macro expansion is not actually affected.

The meaning of a type declaration is equivalent to changing each reference to a variable (var) within the scope of the declaration to (the typespec var), changing each expression assigned to the variable (new-value) within the scope of the declaration to (the typespec new-value), and executing (the typespec var) at the moment the scope of the declaration is entered.

A type declaration is valid in all declarations. The interpretation of a type declaration is as follows:

1.

During the execution of any reference to the declared variable within the scope of the declaration, the consequences are undefined if the value of the declared variable is not of the declared type.

2.

During the execution of any setq of the declared variable within the scope of the declaration, the consequences are undefined if the newly assigned value of the declared variable is not of the declared type.

3.

At the moment the scope of the declaration is entered, the consequences are undefined if the value of the declared variable is not of the declared type.

A type declaration affects only variable references within its scope.

If nested type declarations refer to the same variable, then the value of the variable must be a member of the intersection of the declared types.

If there is a local type declaration for a dynamic variable, and there is also a global type proclamation for that same variable, then the value of the variable within the scope of the local declaration must be a member of the intersection of the two declared types.

type declarations can be free declarations or bound declarations.

A symbol cannot be both the name of a type and the name of a declaration. Defining a symbol as the name of a class, structure, condition, or type, when the symbol has been declared as a declaration name, or vice versa, signals an error.

Within the lexical scope of an array type declaration, all references to array elements are assumed to satisfy the expressed array element type (as opposed to the upgraded array element type). A compiler can treat the code within the scope of the array type declaration as if each access of an array element were surrounded by an appropriate the form.

Examples::

 (defun f (x y)
   (declare (type fixnum x y))
   (let ((z (+ x y)))
     (declare (type fixnum z))
     z)) ⇒  F
 (f 1 2) ⇒  3
 ;; The previous definition of F is equivalent to
 (defun f (x y)
   ;; This declaration is a shorthand form of the TYPE declaration
   (declare (fixnum x y))
   ;; To declare the type of a return value, it's not necessary to
   ;; create a named variable.  A THE special form can be used instead.
   (the fixnum (+ x y))) ⇒  F
 (f 1 2) ⇒  3

 (defvar *one-array* (make-array 10 :element-type '(signed-byte 5)))
 (defvar *another-array* (make-array 10 :element-type '(signed-byte 8)))

 (defun frob (an-array)
   (declare (type (array (signed-byte 5) 1) an-array))
   (setf (aref an-array 1) 31)
   (setf (aref an-array 2) 127)
   (setf (aref an-array 3) (* 2 (aref an-array 3)))
   (let ((foo 0))
     (declare (type (signed-byte 5) foo))
     (setf foo (aref an-array 0))))

 (frob *one-array*)
 (frob *another-array*)

The above definition of frob is equivalent to: 

 (defun frob (an-array)
   (setf (the (signed-byte 5) (aref an-array 1)) 31)
   (setf (the (signed-byte 5) (aref an-array 2)) 127)
   (setf (the (signed-byte 5) (aref an-array 3))
         (* 2 (the (signed-byte 5) (aref an-array 3))))
   (let ((foo 0))
     (declare (type (signed-byte 5) foo))
     (setf foo (the (signed-byte 5) (aref an-array 0)))))

Given an implementation in which fixnums are 29 bits but fixnum arrays are upgraded to signed 32-bit arrays, the following could be compiled with all fixnum arithmetic: 

 (defun bump-counters (counters)
   (declare (type (array fixnum *) bump-counters))
   (dotimes (i (length counters))
     (incf (aref counters i))))

See Also::

declare, declaim , proclaim

Notes::

(typespec {var}*) is an abbreviation for (type typespec {var}*).

A type declaration for the arguments to a function does not necessarily imply anything about the type of the result. The following function is not permitted to be compiled using implementation-dependent fixnum-only arithmetic: 

 (defun f (x y) (declare (fixnum x y)) (+ x y))

To see why, consider (f most-positive-fixnum 1). Common Lisp defines that F must return a bignum here, rather than signal an error or produce a mathematically incorrect result. If you have special knowledge such “fixnum overflow” cases will not come up, you can declare the result value to be in the fixnum range, enabling some compilers to use more efficient arithmetic: 

 (defun f (x y)
   (declare (fixnum x y))
   (the fixnum (+ x y)))

Note, however, that in the three-argument case, because of the possibility of an implicit intermediate value growing too large, the following will not cause implementation-dependent fixnum-only arithmetic to be used: 

 (defun f (x y)
   (declare (fixnum x y z))
   (the fixnum (+ x y z)))

To see why, consider (f most-positive-fixnum 1 -1). Although the arguments and the result are all fixnums, an intermediate value is not a fixnum. If it is important that implementation-dependent fixnum-only arithmetic be selected in implementations that provide it, consider writing something like this instead: 

 (defun f (x y)
   (declare (fixnum x y z))
   (the fixnum (+ (the fixnum (+ x y)) z)))

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/array_002dtotal_002dsize_002dlimit.html0000644000175000017500000000573014360276512021501 0ustar cammcamm array-total-size-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.26 array-total-size-limit [Constant Variable]

Constant Value::

A positive

fixnum,

the exact magnitude of which is implementation-dependent, but which is not less than 1024.

Description::

The upper exclusive bound on the array total size of an array.

The actual limit on the array total size imposed by the implementation might vary according the element type of the array; in this case, the value of array-total-size-limit will be the smallest of these possible limits.

See Also::

make-array , array-element-type

gcl-2.6.14/info/gcl/copy_002dreadtable.html0000644000175000017500000001107614360276512016731 0ustar cammcamm copy-readtable (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.2 copy-readtable [Function]

copy-readtable &optional from-readtable to-readtable ⇒ readtable

Arguments and Values::

from-readtable—a readtable designator. The default is the current readtable.

to-readtable—a readtable or nil. The default is nil.

readtable—the to-readtable if it is non-nil, or else a fresh readtable.

Description::

copy-readtable copies from-readtable.

If to-readtable is nil, a new readtable is created and returned. Otherwise the readtable specified by to-readtable is modified and returned.

copy-readtable copies the setting of readtable-case.

Examples::

 (setq zvar 123) ⇒  123
 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) ⇒  T
 zvar ⇒  123
 (copy-readtable table2 *readtable*) ⇒  #<READTABLE 614000277>
 zvar ⇒  VAR
 (setq *readtable* (copy-readtable)) ⇒  #<READTABLE 46210223>
 zvar ⇒  VAR
 (setq *readtable* (copy-readtable nil)) ⇒  #<READTABLE 46302670>
 zvar ⇒  123

See Also::

readtable, readtable

Notes::

(setq *readtable* (copy-readtable nil))

restores the input syntax to standard Common Lisp syntax, even if the initial readtable has been clobbered (assuming it is not so badly clobbered that you cannot type in the above expression).

On the other hand, 

(setq *readtable* (copy-readtable))

replaces the current readtable with a copy of itself. This is useful if you want to save a copy of a readtable for later use, protected from alteration in the meantime. It is also useful if you want to locally bind the readtable to a copy of itself, as in: 

(let ((*readtable* (copy-readtable))) ...)
gcl-2.6.14/info/gcl/Note-about-Tabs-in-Condition-Reports.html0000644000175000017500000000524314360276512022255 0ustar cammcamm Note about Tabs in Condition Reports (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printing Conditions  

9.1.3.5 Note about Tabs in Condition Reports

Because the indentation of a report message might be shifted to the right or left by an arbitrary amount, special care should be taken with the semi-standard character <Tab> (in those implementations that support such a character). Unless the implementation specifically defines its behavior in this context, its use should be avoided.

gcl-2.6.14/info/gcl/find_002dall_002dsymbols.html0000644000175000017500000000644614360276512017667 0ustar cammcamm find-all-symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.5 find-all-symbols [Function]

find-all-symbols string ⇒ symbols

Arguments and Values::

string—a string designator.

symbols—a list of symbols.

Description::

find-all-symbols searches every registered package for symbols that have a name that is the same (under string=) as string. A list of all such symbols is returned. Whether or how the list is ordered is implementation-dependent.

Examples::

 (find-all-symbols 'car)
⇒  (CAR)
OR⇒ (CAR VEHICLES:CAR)
OR⇒ (VEHICLES:CAR CAR)
 (intern "CAR" (make-package 'temp :use nil)) ⇒  TEMP::CAR, NIL
 (find-all-symbols 'car)
⇒  (TEMP::CAR CAR)
OR⇒ (CAR TEMP::CAR)
OR⇒ (TEMP::CAR CAR VEHICLES:CAR)
OR⇒ (CAR TEMP::CAR VEHICLES:CAR)

See Also::

find-symbol

gcl-2.6.14/info/gcl/The-COMMON_002dLISP-Package.html0000644000175000017500000000752414360276512017645 0ustar cammcamm The COMMON-LISP Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.1 The COMMON-LISP Package

The COMMON-LISP package contains the primitives of the Common Lisp system as defined by this specification. Its external symbols include all of the defined names (except for defined names in the KEYWORD package) that are present in the Common Lisp system, such as car, cdr, *package*, etc. The COMMON-LISP package has the nickname CL.

The COMMON-LISP package has as external symbols those symbols enumerated in the figures in Symbols in the COMMON-LISP Package, and no others. These external symbols are present in the COMMON-LISP package but their home package need not be the COMMON-LISP package.

For example, the symbol HELP cannot be an external symbol of the COMMON-LISP package because it is not mentioned in Symbols in the COMMON-LISP Package. In contrast, the symbol variable must be an external symbol of the COMMON-LISP package even though it has no definition because it is listed in that section (to support its use as a valid second argument to the function documentation).

The COMMON-LISP package can have additional internal symbols.

gcl-2.6.14/info/gcl/Slots.html0000644000175000017500000000474714360276512014501 0ustar cammcamm Slots (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.5 Slots

• Introduction to Slots  
• Accessing Slots  
• Inheritance of Slots and Slot Options  
gcl-2.6.14/info/gcl/Examples-of-Self_002dEvaluating-Objects.html0000644000175000017500000000457714360276512022601 0ustar cammcamm Examples of Self-Evaluating Objects (ANSI and GNU Common Lisp Document)

Previous: , Up: The Evaluation Model  

3.1.2.13 Examples of Self-Evaluating Objects

Numbers, pathnames, and arrays are examples of self-evaluating objects. 

 3 ⇒  3
 #c(2/3 5/8) ⇒  #C(2/3 5/8)
 #p"S:[BILL]OTHELLO.TXT" ⇒  #P"S:[BILL]OTHELLO.TXT"
 #(a b c) ⇒  #(A B C)
 "fred smith" ⇒  "fred smith"
gcl-2.6.14/info/gcl/and-_0028Type-Specifier_0029.html0000644000175000017500000000617014360276512020100 0ustar cammcamm and (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.20 and [Type Specifier]

Compound Type Specifier Kind::

Combining.

Compound Type Specifier Syntax::

(and{{typespec}*})

Compound Type Specifier Arguments::

typespec—a type specifier.

Compound Type Specifier Description::

This denotes the set of all objects of the type determined by the intersection of the typespecs.

* is not permitted as an argument.

The type specifiers (and) and t are equivalent. The symbol and is not valid as a type specifier, and, specifically, it is not an abbreviation for (and).

gcl-2.6.14/info/gcl/Leading-and-Trailing-Newlines-in-Condition-Reports.html0000644000175000017500000000623514360276512025007 0ustar cammcamm Leading and Trailing Newlines in Condition Reports (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printing Conditions  

9.1.3.3 Leading and Trailing Newlines in Condition Reports

It is recommended that a report message not begin with any introductory text, such as “Error: ” or “Warning: ” or even just freshline or newline. Such text is added, if appropriate to the context, by the routine invoking the condition reporter.

It is recommended that a report message not be followed by a trailing freshline or newline. Such text is added, if appropriate to the context, by the routine invoking the condition reporter. 

 (error "This is a message.~
 (error "~&This is a message.")   ; Not recommended
 (error "~&This is a message.~

 (error "This is a message.")     ; Recommended instead
gcl-2.6.14/info/gcl/values_002dlist.html0000644000175000017500000000720414360276512016304 0ustar cammcamm values-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.54 values-list [Function]

values-list list ⇒ {element}*

Arguments and Values::

list—a list.

elements—the elements of the list.

Description::

Returns the elements of the list as multiple values_2.

Examples::

 (values-list nil) ⇒  <no values>
 (values-list '(1)) ⇒  1
 (values-list '(1 2)) ⇒  1, 2
 (values-list '(1 2 3)) ⇒  1, 2, 3

Exceptional Situations::

Should signal type-error if its argument is not a proper list.

See Also::

multiple-value-bind , multiple-value-list , multiple-values-limit , values

Notes::

 (values-list list) ≡ (apply #'values list)

(equal x (multiple-value-list (values-list x))) returns true for all lists x.

gcl-2.6.14/info/gcl/slot_002dunbound.html0000644000175000017500000001057414360276512016471 0ustar cammcamm slot-unbound (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.13 slot-unbound [Standard Generic Function]

Syntax::

slot-unbound class instance slot-name ⇒ {result}*

Method Signatures::

slot-unbound (class t) instance slot-name

Arguments and Values::

class—the class of the instance.

instance—the instance in which an attempt was made to read the unbound slot.

slot-name—the name of the unbound slot.

result—an object.

Description::

The generic function slot-unbound is called when an unbound slot is read in an instance whose metaclass is standard-class. The default method signals an error

of type unbound-slot. The name slot of the unbound-slot condition is initialized to the name of the offending variable, and the instance slot of the unbound-slot condition is initialized to the offending instance.

The generic function slot-unbound is not intended to be called by programmers. Programmers may write methods for it. The function slot-unbound is called only indirectly by slot-value.

If slot-unbound returns, only the primary value will be used by the caller, and all other values will be ignored.

Exceptional Situations::

The default method on slot-unbound signals an error of type unbound-slot.

See Also::

slot-makunbound

Notes::

An unbound slot may occur if no :initform form was specified for the slot and the slot value has not been set, or if slot-makunbound has been called on the slot.

gcl-2.6.14/info/gcl/Conses-as-Trees.html0000644000175000017500000000663014360276512016301 0ustar cammcamm Conses as Trees (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Cons Concepts  

14.1.1 Conses as Trees

A tree is a binary recursive data structure made up of conses and atoms: the conses are themselves also trees (sometimes called “subtrees” or “branches”), and the atoms are terminal nodes (sometimes called leaves ). Typically, the leaves represent data while the branches establish some relationship among that data. 

  caaaar  caddar  cdar       nsubst         
  caaadr  cadddr  cddaar     nsubst-if      
  caaar   caddr   cddadr     nsubst-if-not  
  caadar  cadr    cddar      nthcdr         
  caaddr  cdaaar  cdddar     sublis         
  caadr   cdaadr  cddddr     subst          
  caar    cdaar   cdddr      subst-if       
  cadaar  cdadar  cddr       subst-if-not   
  cadadr  cdaddr  copy-tree  tree-equal     
  cadar   cdadr   nsublis                   

  Figure 14–2: Some defined names relating to trees.
• General Restrictions on Parameters that must be Trees  
gcl-2.6.14/info/gcl/streamp.html0000644000175000017500000000575114360276512015044 0ustar cammcamm streamp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.13 streamp [Function]

streamp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type stream; otherwise, returns false.

streamp is unaffected by whether object, if it is a stream, is open or closed.

Examples::

 (streamp *terminal-io*) ⇒  true
 (streamp 1) ⇒  false

Notes::

 (streamp object) ≡ (typep object 'stream)
gcl-2.6.14/info/gcl/bit-_0028System-Class_0029.html0000644000175000017500000000465614360276512017622 0ustar cammcamm bit (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.12 bit [Type]

Supertypes::

bit, unsigned-byte, signed-byte, integer, rational,

real,

number, t

Description::

The type bit is equivalent to the type (integer 0 1) and (unsigned-byte 1).

gcl-2.6.14/info/gcl/Abstract-Classifications-of-Streams.html0000644000175000017500000000407214360276512022261 0ustar cammcamm Abstract Classifications of Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.5 Abstract Classifications of Streams

gcl-2.6.14/info/gcl/The-Type-part-of-a-Logical-Pathname-Namestring.html0000644000175000017500000000521714360276512024021 0ustar cammcamm The Type part of a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.5 The Type part of a Logical Pathname Namestring

The type of a logical pathname for a source file is "LISP". This should be translated into whatever type is appropriate in a physical pathname.

gcl-2.6.14/info/gcl/FORMAT-Radix-Control.html0000644000175000017500000000574714360276512017051 0ustar cammcamm FORMAT Radix Control (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.2 FORMAT Radix Control

• Tilde R-> Radix  
• Tilde D-> Decimal  
• Tilde B-> Binary  
• Tilde O-> Octal  
• Tilde X-> Hexadecimal  
gcl-2.6.14/info/gcl/Pathnames-as-Filenames.html0000644000175000017500000001446714360276512017617 0ustar cammcamm Pathnames as Filenames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of Filenames  

19.1.2 Pathnames as Filenames

Pathnames are structured objects that can represent, in an implementation-independent way, the filenames that are used natively by an underlying file system.

In addition, pathnames can also represent certain partially composed filenames for which an underlying file system might not have a specific namestring representation.

A pathname need not correspond to any file that actually exists, and more than one pathname can refer to the same file. For example, the pathname with a version of :newest might refer to the same file as a pathname with the same components except a certain number as the version. Indeed, a pathname with version :newest might refer to different files as time passes, because the meaning of such a pathname depends on the state of the file system.

Some file systems naturally use a structural model for their filenames, while others do not. Within the Common Lisp pathname model, all filenames are seen as having a particular structure, even if that structure is not reflected in the underlying file system. The nature of the mapping between structure imposed by pathnames and the structure, if any, that is used by the underlying file system is implementation-defined.

Every pathname has six components: a host, a device, a directory, a name, a type, and a version. By naming files with pathnames, Common Lisp programs can work in essentially the same way even in file systems that seem superficially quite different. For a detailed description of these components, see Pathname Components.

The mapping of the pathname components into the concepts peculiar to each file system is implementation-defined. There exist conceivable pathnames for which there is no mapping to a syntactically valid filename in a particular implementation. An implementation may use various strategies in an attempt to find a mapping; for example, an implementation may quietly truncate filenames that exceed length limitations imposed by the underlying file system, or ignore certain pathname components for which the file system provides no support. If such a mapping cannot be found, an error of type file-error is signaled.

The time at which this mapping and associated error signaling occurs is implementation-dependent. Specifically, it may occur at the time the pathname is constructed, when coercing a pathname to a namestring, or when an attempt is made to open or otherwise access the file designated by the pathname.

Figure 19–1 lists some defined names that are applicable to pathnames. 

  *default-pathname-defaults*  namestring          pathname-name          
  directory-namestring         open                pathname-type          
  enough-namestring            parse-namestring    pathname-version       
  file-namestring              pathname            pathnamep              
  file-string-length           pathname-device     translate-pathname     
  host-namestring              pathname-directory  truename               
  make-pathname                pathname-host       user-homedir-pathname  
  merge-pathnames              pathname-match-p    wild-pathname-p        

                     Figure 19–1: Pathname Operations

Next: , Previous: , Up: Overview of Filenames  

gcl-2.6.14/info/gcl/eq.html0000644000175000017500000001310214360276512013763 0ustar cammcamm eq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.33 eq [Function]

eq x y ⇒ generalized-boolean

Arguments and Values::

x—an object.

y—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if its arguments are the same, identical object; otherwise, returns false.

Examples::

 (eq 'a 'b) ⇒  false
 (eq 'a 'a) ⇒  true
 (eq 3 3)
⇒  true
OR⇒ false
 (eq 3 3.0) ⇒  false
 (eq 3.0 3.0)
⇒  true
OR⇒ false
 (eq #c(3 -4) #c(3 -4))
⇒  true
OR⇒ false
 (eq #c(3 -4.0) #c(3 -4)) ⇒  false
 (eq (cons 'a 'b) (cons 'a 'c)) ⇒  false
 (eq (cons 'a 'b) (cons 'a 'b)) ⇒  false
 (eq '(a . b) '(a . b))
⇒  true
OR⇒ false
 (progn (setq x (cons 'a 'b)) (eq x x)) ⇒  true
 (progn (setq x '(a . b)) (eq x x)) ⇒  true
 (eq #\A #\A)
⇒  true
OR⇒ false
 (let ((x "Foo")) (eq x x)) ⇒  true
 (eq "Foo" "Foo")
⇒  true
OR⇒ false
 (eq "Foo" (copy-seq "Foo")) ⇒  false
 (eq "FOO" "foo") ⇒  false
 (eq "string-seq" (copy-seq "string-seq")) ⇒  false
 (let ((x 5)) (eq x x))
⇒  true
OR⇒ false

See Also::

eql , equal , equalp , = , Compilation

Notes::

Objects that appear the same when printed are not necessarily eq to each other. Symbols that print the same usually are eq to each other because of the use of the intern function. However, numbers with the same value need not be eq, and two similar lists are usually not identical.

An implementation is permitted to make “copies” of characters and numbers at any time. The effect is that Common Lisp makes no guarantee that eq is true even when both its arguments are “the same thing” if that thing is a character or number.

Most Common Lisp operators use eql rather than eq to compare objects, or else they default to eql and only use eq if specifically requested to do so. However, the following operators are defined to use eq rather than eql in a way that cannot be overridden by the code which employs them: 

  catch           getf     throw  
  get             remf            
  get-properties  remprop  

  Figure 5–11: Operators that always prefer EQ over EQL

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Referenced-Publications.html0000644000175000017500000001555614360276512020071 0ustar cammcamm Referenced Publications (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.3 Referenced Publications

*

The Anatomy of Lisp, John Allen, McGraw-Hill, Inc., 1978.

*

The Art of Computer Programming, Volume 3, Donald E. Knuth, Addison-Wesley Company (Reading, MA), 1973.

*

The Art of the Metaobject Protocol, Kiczales et al., MIT Press (Cambridge, MA), 1991.

*

Common Lisp Object System Specification, D. Bobrow, L. DiMichiel, R.P. Gabriel, S. Keene, G. Kiczales, D. Moon, SIGPLAN Notices V23, September, 1988.

*

Common Lisp: The Language, Guy L. Steele Jr., Digital Press (Burlington, MA), 1984.

*

Common Lisp: The Language, Second Edition, Guy L. Steele Jr., Digital Press (Bedford, MA), 1990.

*

Exceptional Situations in Lisp, Kent M. Pitman, Proceedings of the First European Conference on the Practical Application of LISP\/ (EUROPAL ’90), Churchill College, Cambridge, England, March 27-29, 1990.

*

Flavors: A Non-Hierarchical Approach to Object-Oriented Programming, Howard I. Cannon, 1982.

*

IEEE Standard for Binary Floating-Point Arithmetic, ANSI/IEEE Std 754-1985, Institute of Electrical and Electronics Engineers, Inc. (New York), 1985.

*

IEEE Standard for the Scheme Programming Language, IEEE Std 1178-1990, Institute of Electrical and Electronic Engineers, Inc. (New York), 1991.

*

Interlisp Reference Manual, Third Revision, Teitelman, Warren, et al, Xerox Palo Alto Research Center (Palo Alto, CA), 1978.

*

ISO 6937/2, Information processing—Coded character sets for text communication—Part 2: Latin alphabetic and non-alphabetic graphic characters, ISO, 1983.

*

Lisp 1.5 Programmer’s Manual, John McCarthy, MIT Press (Cambridge, MA), August, 1962.

*

Lisp Machine Manual, D.L. Weinreb and D.A. Moon, Artificial Intelligence Laboratory, MIT (Cambridge, MA), July, 1981.

*

Maclisp Reference Manual, Revision~0, David A. Moon, Project MAC (Laboratory for Computer Science), MIT (Cambridge, MA), March, 1974.

*

NIL—A Perspective, JonL White, Macsyma User’s Conference, 1979.

*

Performance and Evaluation of Lisp Programs, Richard P. Gabriel, MIT Press (Cambridge, MA), 1985.

*

Principal Values and Branch Cuts in Complex APL, Paul Penfield Jr., APL 81 Conference Proceedings, ACM SIGAPL (San Francisco, September 1981), 248-256. Proceedings published as APL Quote Quad 12, 1 (September 1981).

*

The Revised Maclisp Manual, Kent M. Pitman, Technical Report 295, Laboratory for Computer Science, MIT (Cambridge, MA), May 1983.

*

Revised^3 Report on the Algorithmic Language Scheme, Jonathan Rees and William Clinger (editors), SIGPLAN Notices V21, #12, December, 1986.

*

S-1 Common Lisp Implementation, R.A. Brooks, R.P. Gabriel, and G.L. Steele, Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming, 108-113, 1982.

*

Smalltalk-80: The Language and its Implementation, A. Goldberg and D. Robson, Addison-Wesley, 1983.

*

Standard LISP Report, J.B. Marti, A.C. Hearn, M.L. Griss, and C. Griss, SIGPLAN Notices V14, #10, October, 1979.

*

Webster’s Third New International Dictionary the English Language, Unabridged, Merriam Webster (Springfield, MA), 1986.

*

XP: A Common Lisp Pretty Printing System, R.C. Waters, Memo 1102a, Artificial Intelligence Laboratory, MIT (Cambridge, MA), September 1989.

Next: , Previous: , Up: Introduction (Introduction)  

gcl-2.6.14/info/gcl/Interpreting-Pathname-Component-Values.html0000644000175000017500000001564214360276512022773 0ustar cammcamm Interpreting Pathname Component Values (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathnames  

19.2.2 Interpreting Pathname Component Values

• Strings in Component Values  
• Special Characters in Pathname Components  
• Case in Pathname Components  
• Local Case in Pathname Components  
• Common Case in Pathname Components  
• Special Pathname Component Values  
• NIL as a Component Value  
• ->WILD as a Component Value  
• ->UNSPECIFIC as a Component Value  
• Relation between component values NIL and ->UNSPECIFIC  
• Restrictions on Wildcard Pathnames  
• Restrictions on Examining Pathname Components  
• Restrictions on Examining a Pathname Host Component  
• Restrictions on Examining a Pathname Device Component  
• Restrictions on Examining a Pathname Directory Component  
• Directory Components in Non-Hierarchical File Systems  
• Restrictions on Examining a Pathname Name Component  
• Restrictions on Examining a Pathname Type Component  
• Restrictions on Examining a Pathname Version Component  
• Notes about the Pathname Version Component  
• Restrictions on Constructing Pathnames  

Next: , Previous: , Up: Pathnames  

gcl-2.6.14/info/gcl/Tilde-Tilde_002d_003e-Tilde.html0000644000175000017500000000404714360276512020001 0ustar cammcamm Tilde Tilde-> Tilde (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Basic Output  

22.3.1.5 Tilde Tilde: Tilde

This outputs a tilde. ~n~ outputs n tildes.

gcl-2.6.14/info/gcl/Directory-Components-in-Non_002dHierarchical-File-Systems.html0000644000175000017500000000561014360276512026154 0ustar cammcamm Directory Components in Non-Hierarchical File Systems (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.16 Directory Components in Non-Hierarchical File Systems

In non-hierarchical file systems, the only valid list values for the directory component of a pathname are (:absolute string) and (:absolute :wild). :relative directories and the keywords :wild-inferiors, :up, and :back are not used in non-hierarchical file systems.

gcl-2.6.14/info/gcl/The-Device-part-of-a-Logical-Pathname-Namestring.html0000644000175000017500000000532414360276512024276 0ustar cammcamm The Device part of a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.3 The Device part of a Logical Pathname Namestring

There is no syntax for a logical pathname device since the device component of a logical pathname is always :unspecific; see Unspecific Components of a Logical Pathname.

gcl-2.6.14/info/gcl/_002d-_0028Variable_0029.html0000644000175000017500000000606214360276512017037 0ustar cammcamm - (Variable) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.20 - [Variable]

Value Type::

a form.

Initial Value::

implementation-dependent.

Description::

The value of - is the form that is currently being evaluated by the Lisp read-eval-print loop.

Examples::

(format t "~&Evaluating ~S~
 |>  Evaluating (FORMAT T "~&Evaluating ~S~
⇒  NIL

Affected By::

Lisp read-eval-print loop.

See Also::

+ (variable), * (variable), / (variable), Top level loop

gcl-2.6.14/info/gcl/Lowercase-Letters-in-a-Logical-Pathname-Namestring.html0000644000175000017500000000506014360276512024760 0ustar cammcamm Lowercase Letters in a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.8 Lowercase Letters in a Logical Pathname Namestring

When parsing words and wildcard-words, lowercase letters are translated to uppercase.

gcl-2.6.14/info/gcl/Sharpsign-P.html0000644000175000017500000000444414360276512015522 0ustar cammcamm Sharpsign P (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.15 Sharpsign P

#P reads a following object, which must be a string.

#P<<expression>> is equivalent to #.(parse-namestring '<<expression>>), except that #P is not affected by *read-eval*.

For information on how the Lisp printer prints pathnames, see Printing Pathnames.

gcl-2.6.14/info/gcl/call_002darguments_002dlimit.html0000644000175000017500000000556314360276512020544 0ustar cammcamm call-arguments-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.12 call-arguments-limit [Constant Variable]

Constant Value::

An integer not smaller than 50 and at least as great as the value of lambda-parameters-limit, the exact magnitude of which is implementation-dependent.

Description::

The upper exclusive bound on the number of arguments that may be passed to a function.

See Also::

lambda-parameters-limit , multiple-values-limit

gcl-2.6.14/info/gcl/simple_002dcondition_002dformat_002dcontrol.html0000644000175000017500000000735514360276512023404 0ustar cammcamm simple-condition-format-control (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.19 simple-condition-format-control, simple-condition-format-arguments

[Function]

simple-condition-format-control condition ⇒ format-control

simple-condition-format-arguments condition ⇒ format-arguments

Arguments and Values::

condition—a condition of type simple-condition.

format-control—a format control.

format-arguments—a list.

Description::

simple-condition-format-control returns the format control needed to process the condition’s format arguments.

simple-condition-format-arguments returns a list of format arguments needed to process the condition’s format control.

Examples::

 (setq foo (make-condition 'simple-condition
                          :format-control "Hi ~S"
                          :format-arguments '(ho)))
⇒  #<SIMPLE-CONDITION 26223553>
 (apply #'format nil (simple-condition-format-control foo)
                     (simple-condition-format-arguments foo))
⇒  "Hi HO"

See Also::

simple-condition , Condition System Concepts

gcl-2.6.14/info/gcl/Determining-the-Class-Precedence-List.html0000644000175000017500000001153214360276512022415 0ustar cammcamm Determining the Class Precedence List (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.5 Determining the Class Precedence List

The defclass form for a class provides a total ordering on that class and its direct superclasses. This ordering is called the local precedence order . It is an ordered list of the class and its direct superclasses. The class precedence list for a class C is a total ordering on C and its superclasses that is consistent with the local precedence orders for each of C and its superclasses.

A class precedes its direct superclasses, and a direct superclass precedes all other direct superclasses specified to its right in the superclasses list of the defclass form. For every class C, define

R_C={(C,C_1),(C_1,C_2),...,(C_{n-1},C_n)}

where C_1,...,C_n are the direct superclasses of C in the order in which they are mentioned in the defclass form. These ordered pairs generate the total ordering on the class C and its direct superclasses.

Let S_C be the set of C and its superclasses. Let R be

R=\bigcup_{c\in S_C }R_c

.

[Reviewer Note by Barmar: “Consistent” needs to be defined, or maybe we should say “logically consistent”?]

The set R might or might not generate a partial ordering, depending on whether the R_c, c\in S_C, are consistent; it is assumed that they are consistent and that R generates a partial ordering. When the R_c are not consistent, it is said that R is inconsistent.

To compute the class precedence list for~C, topologically sort the elements of S_C with respect to the partial ordering generated by R. When the topological sort must select a class from a set of two or more classes, none of which are preceded by other classes with respect to~R, the class selected is chosen deterministically, as described below.

If R is inconsistent, an error is signaled.

• Topological Sorting  
• Examples of Class Precedence List Determination  

Next: , Previous: , Up: Classes  

gcl-2.6.14/info/gcl/symbol_002dpackage.html0000644000175000017500000001066514360276512016737 0ustar cammcamm symbol-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.12 symbol-package [Function]

symbol-package symbol ⇒ contents

Arguments and Values::

symbol—a symbol.

contents—a package object or nil.

Description::

Returns the home package of symbol.

Examples::

 (in-package "CL-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (symbol-package 'car) ⇒  #<PACKAGE "COMMON-LISP">
 (symbol-package 'bus) ⇒  #<PACKAGE "COMMON-LISP-USER">
 (symbol-package :optional) ⇒  #<PACKAGE "KEYWORD">
 ;; Gensyms are uninterned, so have no home package.
 (symbol-package (gensym)) ⇒  NIL
 (make-package 'pk1) ⇒  #<PACKAGE "PK1">
 (intern "SAMPLE1" "PK1") ⇒  PK1::SAMPLE1, NIL
 (export (find-symbol "SAMPLE1" "PK1") "PK1") ⇒  T
 (make-package 'pk2 :use '(pk1)) ⇒  #<PACKAGE "PK2">
 (find-symbol "SAMPLE1" "PK2") ⇒  PK1:SAMPLE1, :INHERITED
 (symbol-package 'pk1::sample1) ⇒  #<PACKAGE "PK1">
 (symbol-package 'pk2::sample1) ⇒  #<PACKAGE "PK1">
 (symbol-package 'pk1::sample2) ⇒  #<PACKAGE "PK1">
 (symbol-package 'pk2::sample2) ⇒  #<PACKAGE "PK2">
 ;; The next several forms create a scenario in which a symbol
 ;; is not really uninterned, but is "apparently uninterned",
 ;; and so SYMBOL-PACKAGE still returns NIL.
 (setq s3 'pk1::sample3) ⇒  PK1::SAMPLE3
 (import s3 'pk2) ⇒  T
 (unintern s3 'pk1) ⇒  T
 (symbol-package s3) ⇒  NIL
 (eq s3 'pk2::sample3) ⇒  T

Affected By::

import, intern, unintern

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

intern

gcl-2.6.14/info/gcl/number.html0000644000175000017500000000670314360276512014657 0ustar cammcamm number (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.1 number [System Class]

Class Precedence List::

number, t

Description::

The type number contains objects which represent mathematical numbers.

The types real and complex are disjoint subtypes of number.

The function = tests for numerical equality. The function eql, when its arguments are both numbers, tests that they have both the same type and numerical value. Two numbers that are the same under eql or = are not necessarily the same under eq.

Notes::

Common Lisp differs from mathematics on some naming issues. In mathematics, the set of real numbers is traditionally described as a subset of the complex numbers, but in Common Lisp, the type real and the type complex are disjoint. The Common Lisp type which includes all mathematical complex numbers is called number. The reasons for these differences include historical precedent, compatibility with most other popular computer languages, and various issues of time and space efficiency.

gcl-2.6.14/info/gcl/pathname_002dhost.html0000644000175000017500000002101614360276512016601 0ustar cammcamm pathname-host (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.6 pathname-host, pathname-device, pathname-directory,

pathname-name, pathname-type, pathname-version

[Function]

pathname-host pathname &key case ⇒ host

pathname-device pathname &key case ⇒ device

pathname-directory pathname &key case ⇒ directory

pathname-name pathname &key case ⇒ name

pathname-type pathname &key case ⇒ type

pathname-version pathname ⇒ version

Arguments and Values::

pathname—a pathname designator.

case—one of :local or :common. The default is :local.

host—a valid pathname host.

device—a valid pathname device.

directory—a valid pathname directory.

name—a valid pathname name.

type—a valid pathname type.

version—a valid pathname version.

Description::

These functions return the components of pathname.

If the pathname designator is a pathname, it represents the name used to open the file. This may be, but is not required to be, the actual name of the file.

If case is supplied, it is treated as described in Case in Pathname Components.

Examples::

 (setq q (make-pathname :host "KATHY"
                        :directory "CHAPMAN" 
                        :name "LOGIN" :type "COM"))
⇒  #P"KATHY::[CHAPMAN]LOGIN.COM"
 (pathname-host q) ⇒  "KATHY"
 (pathname-name q) ⇒  "LOGIN"
 (pathname-type q) ⇒  "COM"

 ;; Because namestrings are used, the results shown in the remaining
 ;; examples are not necessarily the only possible results.  Mappings
 ;; from namestring representation to pathname representation are 
 ;; dependent both on the file system involved and on the implementation
 ;; (since there may be several implementations which can manipulate the
 ;; the same file system, and those implementations are not constrained
 ;; to agree on all details). Consult the documentation for each
 ;; implementation for specific information on how namestrings are treated
 ;; that implementation.

 ;; VMS
 (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP"))
⇒  (:ABSOLUTE "FOO" "BAR")
 (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP") :case :common)
⇒  (:ABSOLUTE "FOO" "BAR")

 ;; Unix
 (pathname-directory "foo.l") ⇒  NIL
 (pathname-device "foo.l") ⇒  :UNSPECIFIC
 (pathname-name "foo.l") ⇒  "foo"
 (pathname-name "foo.l" :case :local) ⇒  "foo"
 (pathname-name "foo.l" :case :common) ⇒  "FOO"
 (pathname-type "foo.l") ⇒  "l"
 (pathname-type "foo.l" :case :local) ⇒  "l"
 (pathname-type "foo.l" :case :common) ⇒  "L"
 (pathname-type "foo") ⇒  :UNSPECIFIC
 (pathname-type "foo" :case :common) ⇒  :UNSPECIFIC
 (pathname-type "foo.") ⇒  ""
 (pathname-type "foo." :case :common) ⇒  ""
 (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local)
⇒  (:ABSOLUTE "foo" "bar")
 (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local)
⇒  (:ABSOLUTE "FOO" "BAR")
 (pathname-directory (parse-namestring "../baz.lisp"))
⇒  (:RELATIVE :UP)
 (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz"))
⇒  (:ABSOLUTE "foo" "BAR" :UP "Mum")
 (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz") :case :common)
⇒  (:ABSOLUTE "FOO" "bar" :UP "Mum")
 (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l"))
⇒  (:ABSOLUTE "foo" :WILD "bar")
 (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l") :case :common)
⇒  (:ABSOLUTE "FOO" :WILD "BAR")

 ;; Symbolics LMFS
 (pathname-directory (parse-namestring ">foo>**>bar>baz.lisp"))
⇒  (:ABSOLUTE "foo" :WILD-INFERIORS "bar")
 (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp"))
⇒  (:ABSOLUTE "foo" :WILD "bar")
 (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp") :case :common)
⇒  (:ABSOLUTE "FOO" :WILD "BAR")
 (pathname-device (parse-namestring ">foo>baz.lisp")) ⇒  :UNSPECIFIC

Affected By::

The implementation and the host file system.

Exceptional Situations::

Should signal an error of type type-error if its first argument is not a pathname.

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/Too-Many-Arguments.html0000644000175000017500000000513514360276512016773 0ustar cammcamm Too Many Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.4 Too Many Arguments

It is not permitted to supply too many arguments to a function. Too many arguments means more arguments than the number of required parameters plus the number of optional parameters; however, if the function uses &rest or &key, it is not possible for it to receive too many arguments.

If this situation occurs in a safe call,

an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/Rational-Computations.html0000644000175000017500000000560714360276512017625 0ustar cammcamm Rational Computations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.3 Rational Computations

The rules in this section apply to rational computations.

• Rule of Unbounded Rational Precision  
• Rule of Canonical Representation for Rationals  
• Rule of Float Substitutability  
gcl-2.6.14/info/gcl/Miscellaneous-Clauses.html0000644000175000017500000000525714360276512017572 0ustar cammcamm Miscellaneous Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.7 Miscellaneous Clauses

• Control Transfer Clauses  
• Examples of NAMED clause  
• Initial and Final Execution  
gcl-2.6.14/info/gcl/copy_002dtree.html0000644000175000017500000000774014360276512015750 0ustar cammcamm copy-tree (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.10 copy-tree [Function]

copy-tree tree ⇒ new-tree

Arguments and Values::

tree—a tree.

new-tree—a tree.

Description::

Creates a copy of a tree of conses.

If tree is not a cons, it is returned; otherwise, the result is a new cons of the results of calling copy-tree on the car and cdr of tree. In other words, all conses in the tree represented by tree are copied recursively, stopping only when non-conses are encountered.

copy-tree does not preserve circularities and the sharing of substructure.

Examples::

 (setq object (list (cons 1 "one")
                    (cons 2 (list 'a 'b 'c))))
⇒  ((1 . "one") (2 A B C))
 (setq object-too object) ⇒  ((1 . "one") (2 A B C))
 (setq copy-as-list (copy-list object))
 (setq copy-as-alist (copy-alist object))
 (setq copy-as-tree (copy-tree object))
 (eq object object-too) ⇒  true
 (eq copy-as-tree object) ⇒  false
 (eql copy-as-tree object) ⇒  false
 (equal copy-as-tree object) ⇒  true
 (setf (first (cdr (second object))) "a"
       (car (second object)) "two"
       (car object) '(one . 1)) ⇒  (ONE . 1)
 object ⇒  ((ONE . 1) ("two" "a" B C))
 object-too ⇒  ((ONE . 1) ("two" "a" B C))
 copy-as-list ⇒  ((1 . "one") ("two" "a" B C))
 copy-as-alist ⇒  ((1 . "one") (2 "a" B C))
 copy-as-tree ⇒  ((1 . "one") (2 A B C))

See Also::

tree-equal

gcl-2.6.14/info/gcl/when.html0000644000175000017500000001334014360276512014323 0ustar cammcamm when (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.45 when, unless [Macro]

when test-form {form}* ⇒ {result}*

unless test-form {form}* ⇒ {result}*

Arguments and Values::

test-form—a form.

forms—an implicit progn.

results—the values of the forms in a when form if the test-form yields true or in an unless form if the test-form yields false; otherwise nil.

Description::

when and unless allow the execution of forms to be dependent on a single test-form.

In a when form, if the test-form yields true, the forms are evaluated in order from left to right and the values returned by the forms are returned from the when form. Otherwise, if the test-form yields false, the forms are not evaluated, and the when form returns nil.

In an unless form, if the test-form yields false, the forms are evaluated in order from left to right and the values returned by the forms are returned from the unless form. Otherwise, if the test-form yields false, the forms are not evaluated, and the unless form returns nil.

Examples::

 (when t 'hello) ⇒  HELLO
 (unless t 'hello) ⇒  NIL
 (when nil 'hello) ⇒  NIL
 (unless nil 'hello) ⇒  HELLO
 (when t) ⇒  NIL
 (unless nil) ⇒  NIL
 (when t (prin1 1) (prin1 2) (prin1 3))
 |>  123
⇒  3
 (unless t (prin1 1) (prin1 2) (prin1 3)) ⇒  NIL
 (when nil (prin1 1) (prin1 2) (prin1 3)) ⇒  NIL
 (unless nil (prin1 1) (prin1 2) (prin1 3))
 |>  123
⇒  3
 (let ((x 3))
   (list (when (oddp x) (incf x) (list x))
         (when (oddp x) (incf x) (list x))
         (unless (oddp x) (incf x) (list x))
         (unless (oddp x) (incf x) (list x))
         (if (oddp x) (incf x) (list x)) 
         (if (oddp x) (incf x) (list x)) 
         (if (not (oddp x)) (incf x) (list x)) 
         (if (not (oddp x)) (incf x) (list x))))
⇒  ((4) NIL (5) NIL 6 (6) 7 (7))

See Also::

and , cond , if , or

Notes::

 (when test {form}^+) ≡ (and test (progn {form}^+))
 (when test {form}^+) ≡ (cond (test {form}^+))
 (when test {form}^+) ≡ (if test (progn {form}^+) nil)
 (when test {form}^+) ≡ (unless (not test) {form}^+)
 (unless test {form}^+) ≡ (cond ((not test) {form}^+))
 (unless test {form}^+) ≡ (if test nil (progn {form}^+))
 (unless test {form}^+) ≡ (when (not test) {form}^+)

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/quote.html0000644000175000017500000001017014360276512014515 0ustar cammcamm quote (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.7 quote [Special Operator]

quote object ⇒ object

Arguments and Values::

object—an object; not evaluated.

Description::

The quote special operator just returns object.

The consequences are undefined if literal objects (including quoted objects) are destructively modified.

Examples::

 (setq a 1) ⇒  1
 (quote (setq a 3)) ⇒  (SETQ A 3)
 a ⇒  1
 'a ⇒  A
 ''a ⇒  (QUOTE A) 
 '''a ⇒  (QUOTE (QUOTE A))
 (setq a 43) ⇒  43
 (list a (cons a 3)) ⇒  (43 (43 . 3))
 (list (quote a) (quote (cons a 3))) ⇒  (A (CONS A 3)) 
 1 ⇒  1
 '1 ⇒  1
 "foo" ⇒  "foo"
 '"foo" ⇒  "foo"
 (car '(a b)) ⇒  A
 '(car '(a b)) ⇒  (CAR (QUOTE (A B)))
 #(car '(a b)) ⇒  #(CAR (QUOTE (A B)))
 '#(car '(a b)) ⇒  #(CAR (QUOTE (A B)))

See Also::

Evaluation, Single-Quote,

Compiler Terminology

Notes::

The textual notation 'object is equivalent to (quote object); see Compiler Terminology.

Some objects, called self-evaluating objects, do not require quotation by quote. However, symbols and lists are used to represent parts of programs, and so would not be useable as constant data in a program without quote. Since quote suppresses the evaluation of these objects, they become data rather than program.

gcl-2.6.14/info/gcl/Character-Attributes.html0000644000175000017500000000613614360276512017407 0ustar cammcamm Character Attributes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.3 Character Attributes

Characters have only one standardized attribute: a code. A character’s code is a non-negative integer. This code is composed from a character script and a character label in an implementation-dependent way. See the functions char-code and code-char.

Additional, implementation-defined attributes of characters are also permitted so that, for example, two characters with the same code may differ in some other, implementation-defined way.

For any implementation-defined attribute there is a distinguished value called the null value for that attribute. A character for which each implementation-defined attribute has the null value for that attribute is called a simple character. If the implementation has no implementation-defined attributes, then all characters are simple characters.

gcl-2.6.14/info/gcl/dpb.html0000644000175000017500000001030514360276512014125 0ustar cammcamm dpb (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.68 dpb [Function]

dpb newbyte bytespec integer ⇒ result-integer

Pronunciation::

pronounced ,de ’pib or pronounced ,de ’pe b or pronounced ’d\=e ’p\=e ’b\=e

Arguments and Values::

newbyte—an integer.

bytespec—a byte specifier.

integer—an integer.

result-integer—an integer.

Description::

dpb (deposit byte) is used to replace a field of bits within integer. dpb returns an integer that is the same as integer except in the bits specified by bytespec.

Let s be the size specified by bytespec; then the low s bits of newbyte appear in the result in the byte specified by bytespec. Newbyte is interpreted as being right-justified, as if it were the result of ldb.

Examples::

 (dpb 1 (byte 1 10) 0) ⇒  1024
 (dpb -2 (byte 2 10) 0) ⇒  2048
 (dpb 1 (byte 2 10) 2048) ⇒  1024

See Also::

byte , deposit-field , ldb

Notes::

 (logbitp j (dpb m (byte s p) n))
 ≡ (if (and (>= j p) (< j (+ p s)))
        (logbitp (- j p) m)
        (logbitp j n))

In general, 

 (dpb x (byte 0 y) z) ⇒  z

for all valid values of x, y, and z.

Historically, the name “dpb” comes from a DEC PDP-10 assembly language instruction meaning “deposit byte.”

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Directory-Component.html0000644000175000017500000001661314360276512026262 0ustar cammcamm Restrictions on Examining a Pathname Directory Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.15 Restrictions on Examining a Pathname Directory Component

The directory might be a string, :wild, :unspecific, or nil.

The directory can be a list of strings and symbols.

The car of the list is one of the symbols :absolute or :relative , meaning:

:absolute

A list whose car is the symbol :absolute represents a directory path starting from the root directory. The list (:absolute) represents the root directory. The list (:absolute "foo" "bar" "baz") represents the directory called "/foo/bar/baz" in Unix (except possibly for case).

:relative

A list whose car is the symbol :relative represents a directory path starting from a default directory. The list (:relative) has the same meaning as nil and hence is not used. The list (:relative "foo" "bar") represents the directory named "bar" in the directory named "foo" in the default directory.

Each remaining element of the list is a string or a symbol.

Each string names a single level of directory structure. The strings should contain only the directory names themselves—no punctuation characters.

In place of a string, at any point in the list, symbols can occur to indicate special file notations. Figure 19–3 lists the symbols that have standard meanings. Implementations are permitted to add additional objects of any type that is disjoint from string if necessary to represent features of their file systems that cannot be represented with the standard strings and symbols.

Supplying any non-string, including any of the symbols listed below, to a file system for which it does not make sense signals an error of type file-error. For example, Unix does not support :wild-inferiors in most implementations. 

  Symbol           Meaning                                             
  :wild            Wildcard match of one level of directory structure  
  :wild-inferiors  Wildcard match of any number of directory levels    
  :up              Go upward in directory structure (semantic)         
  :back            Go upward in directory structure (syntactic)        

          Figure 19–3: Special Markers In Directory Component

The following notes apply to the previous figure:

Invalid Combinations

Using :absolute or :wild-inferiors immediately followed by :up or :back signals an error of type file-error.

Syntactic vs Semantic

“Syntactic” means that the action of :back depends only on the pathname and not on the contents of the file system.

“Semantic” means that the action of :up depends on the contents of the file system; to resolve a pathname containing :up to a pathname whose directory component contains only :absolute and strings requires probing the file system.

:up differs from :back only in file systems that support multiple names for directories, perhaps via symbolic links. For example, suppose that there is a directory (:absolute "X" "Y" "Z") linked to (:absolute "A" "B" "C") and there also exist directories (:absolute "A" "B" "Q") and (:absolute "X" "Y" "Q"). Then (:absolute "X" "Y" "Z" :up "Q") designates (:absolute "A" "B" "Q") while (:absolute "X" "Y" "Z" :back "Q") designates (:absolute "X" "Y" "Q")

Next: , Previous: , Up: Interpreting Pathname Component Values  

gcl-2.6.14/info/gcl/machine_002dtype.html0000644000175000017500000000602614360276512016420 0ustar cammcamm machine-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.27 machine-type [Function]

machine-type <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

Returns a string that identifies the generic name of the computer hardware on which Common Lisp is running.

Examples::

 (machine-type)
⇒  "DEC PDP-10"
OR⇒ "Symbolics LM-2"

Affected By::

The machine type. The implementation.

See Also::

machine-version

gcl-2.6.14/info/gcl/The-_0022Pronunciation_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000603314360276512025463 0ustar cammcamm The "Pronunciation" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.20 The "Pronunciation" Section of a Dictionary Entry

This offers a suggested pronunciation for defined names so that people not in verbal communication with the original designers can figure out how to pronounce words that are not in normal English usage. This information is advisory only, and is not considered part of the standard. For brevity, it is only provided for entries with names that are specific to Common Lisp and would not be found in Webster’s Third New International Dictionary the English Language, Unabridged.

gcl-2.6.14/info/gcl/The-_0022Supertypes_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000560514360276512025022 0ustar cammcamm The "Supertypes" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.23 The "Supertypes" Section of a Dictionary Entry

This appears in the dictionary entry for a type, and contains a list of the standardized types that must be supertypes of this type.

In implementations where there is a corresponding class, the order of the classes in the class precedence list is consistent with the order presented in this section.

gcl-2.6.14/info/gcl/funcall.html0000644000175000017500000001056114360276512015010 0ustar cammcamm funcall (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.7 funcall [Function]

funcall function &rest args ⇒ {result}*

Arguments and Values::

function—a function designator.

args—arguments to the function.

results—the values returned by the function.

Description::

funcall applies function to args.

If function is a symbol, it is coerced to a function as if by finding its functional value in the global environment.

Examples::

 (funcall #'+ 1 2 3) ⇒  6
 (funcall 'car '(1 2 3)) ⇒  1
 (funcall 'position 1 '(1 2 3 2 1) :start 1) ⇒  4
 (cons 1 2) ⇒  (1 . 2)
 (flet ((cons (x y) `(kons ,x ,y)))
   (let ((cons (symbol-function '+)))
     (funcall #'cons
              (funcall 'cons 1 2)
              (funcall cons 1 2))))
⇒  (KONS (1 . 2) 3)

Exceptional Situations::

An error of type undefined-function should be signaled if function is a symbol that does not have a global definition as a function or that has a global definition as a macro or a special operator.

See Also::

apply , function, Evaluation

Notes::

 (funcall function arg1 arg2 ...)
 ≡ (apply function arg1 arg2 ... nil)
 ≡ (apply function (list arg1 arg2 ...))

The difference between funcall and an ordinary function call is that in the former case the function is obtained by ordinary evaluation of a form, and in the latter case it is obtained by the special interpretation of the function position that normally occurs.

gcl-2.6.14/info/gcl/Environment-Objects.html0000644000175000017500000000601414360276512017255 0ustar cammcamm Environment Objects (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction to Environments  

3.1.1.5 Environment Objects

Some operators make use of an object, called an environment object , that represents the set of lexical bindings needed to perform semantic analysis on a form in a given lexical environment. The set of bindings in an environment object may be a subset of the bindings that would be needed to actually perform an evaluation; for example, values associated with variable names and function names in the corresponding lexical environment might not be available in an environment object.

The type and nature of an environment object is implementation-dependent. The values of environment parameters to macro functions are examples of environment objects.

The object nil when used as an environment object denotes the null lexical environment; see The Null Lexical Environment.

gcl-2.6.14/info/gcl/Escape-Characters-and-Potential-Numbers.html0000644000175000017500000000546714360276512022760 0ustar cammcamm Escape Characters and Potential Numbers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers as Tokens  

2.3.1.2 Escape Characters and Potential Numbers

A potential number cannot contain any escape characters. An escape character robs the following character of all syntactic qualities, forcing it to be strictly alphabetic_2 and therefore unsuitable for use in a potential number. For example, all of the following representations are interpreted as symbols, not numbers: 

 \256   25\64   1.0\E6   |100|   3\.14159   |3/4|   3\/4   5||

In each case, removing the escape character (or characters) would cause the token to be a potential number.

gcl-2.6.14/info/gcl/realp.html0000644000175000017500000000570514360276512014473 0ustar cammcamm realp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.52 realp [Function]

realp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type real; otherwise, returns false.

Examples::

 (realp 12) ⇒  true
 (realp #c(5/3 7.2)) ⇒  false
 (realp nil) ⇒  false
 (realp (cons 1 2)) ⇒  false

Notes::

 (realp object) ≡ (typep object 'real)
gcl-2.6.14/info/gcl/catch.html0000644000175000017500000001363614360276512014454 0ustar cammcamm catch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.23 catch [Special Operator]

catch tag {form}* ⇒ {result}*

Arguments and Values::

tag—a catch tag; evaluated.

forms—an implicit progn.

results—if the forms exit normally, the values returned by the forms; if a throw occurs to the tag, the values that are thrown.

Description::

catch is used as the destination of a non-local control transfer by throw. Tags are used to find the catch to which a throw is transferring control. (catch 'foo form) catches a (throw 'foo form) but not a (throw 'bar form).

The order of execution of catch follows:

1.

Tag is evaluated. It serves as the name of the catch.

2.

Forms are then evaluated as an implicit progn, and the results of the last form are returned unless a throw occurs.

3.

If a throw occurs during the execution of one of the forms, control is transferred to the catch form whose tag is eq to the tag argument of the throw and which is the most recently established catch with that tag. No further evaluation of forms occurs.

4.

The tag established by catch is disestablished just before the results are returned.

If during the execution of one of the forms, a throw is executed whose tag is eq to the catch tag, then the values specified by the throw are returned as the result of the dynamically most recently established catch form with that tag.

The mechanism for catch and throw works even if throw is not within the lexical scope of catch. throw must occur within the dynamic extent of the evaluation of the body of a catch with a corresponding tag.

Examples::

 (catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4) ⇒  3
 (catch 'dummy-tag 1 2 3 4) ⇒  4
 (defun throw-back (tag) (throw tag t)) ⇒  THROW-BACK
 (catch 'dummy-tag (throw-back 'dummy-tag) 2) ⇒  T

 ;; Contrast behavior of this example with corresponding example of BLOCK.
 (catch 'c
   (flet ((c1 () (throw 'c 1)))
     (catch 'c (c1) (print 'unreachable))
     2)) ⇒  2

Exceptional Situations::

An error of type control-error is signaled if throw is done when there is no suitable catch tag.

See Also::

throw , Evaluation

Notes::

It is customary for symbols to be used as tags, but any object is permitted. However, numbers should not be used because the comparison is done using eq.

catch differs from block in that catch tags have dynamic scope while block names have lexical scope.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/with_002dpackage_002diterator.html0000644000175000017500000002263014360276512020677 0ustar cammcamm with-package-iterator (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.13 with-package-iterator [Macro]

with-package-iterator (name package-list-form &rest symbol-types) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

name—a symbol.

package-list-form—a form; evaluated once to produce a package-list.

package-list—a designator for a list of package designators.

symbol-type—one of the symbols :internal, :external, or :inherited.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values of the forms.

Description::

Within the lexical scope of the body forms, the name is defined via macrolet such that successive invocations of (name) will return the symbols, one by one, from the packages in package-list.

It is unspecified whether symbols inherited from multiple packages are returned more than once. The order of symbols returned does not necessarily reflect the order of packages in package-list. When package-list has more than one element, it is unspecified whether duplicate symbols are returned once or more than once.

Symbol-types controls which symbols that are accessible in a package are returned as follows:

:internal

The symbols that are present in the package, but that are not exported.

:external

The symbols that are present in the package and are exported.

:inherited

The symbols that are exported by used packages and that are not shadowed.

When more than one argument is supplied for symbol-types, a symbol is returned if its accessibility matches any one of the symbol-types supplied. Implementations may extend this syntax by recognizing additional symbol accessibility types.

An invocation of (name) returns four values as follows:

1.

A flag that indicates whether a symbol is returned (true means that a symbol is returned).

2.

A symbol that is accessible in one the indicated packages.

3.

The accessibility type for that symbol; i.e., one of the symbols :internal, :external, or :inherited.

4.

The package from which the symbol was obtained. The package is one of the packages present or named in package-list.

After all symbols have been returned by successive invocations of (name), then only one value is returned, namely nil.

The meaning of the second, third, and fourth values is that the returned symbol is accessible in the returned package in the way indicated by the second return value as follows:

:internal

Means present and not exported.

:external

Means present and exported.

:inherited

Means not present (thus not shadowed) but inherited from some used package.

It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the with-package-iterator form such as by returning some closure over the invocation form.

Any number of invocations of with-package-iterator can be nested, and the body of the innermost one can invoke all of the locally established macros, provided all those macros have distinct names.

Examples::

The following function should return t on any package, and signal an error if the usage of with-package-iterator does not agree with the corresponding usage of do-symbols. 

 (defun test-package-iterator (package)
   (unless (packagep package)
     (setq package (find-package package)))
   (let ((all-entries '())
         (generated-entries '()))
     (do-symbols (x package) 
       (multiple-value-bind (symbol accessibility) 
           (find-symbol (symbol-name x) package)
         (push (list symbol accessibility) all-entries)))
     (with-package-iterator (generator-fn package 
                             :internal :external :inherited)
       (loop     
         (multiple-value-bind (more? symbol accessibility pkg)
             (generator-fn)
           (unless more? (return))
           (let ((l (multiple-value-list (find-symbol (symbol-name symbol) 
                                                      package))))
             (unless (equal l (list symbol accessibility))
               (error "Symbol ~S not found as ~S in package ~A [~S]"
                      symbol accessibility (package-name package) l))
             (push l generated-entries)))))
     (unless (and (subsetp all-entries generated-entries :test #'equal)
                  (subsetp generated-entries all-entries :test #'equal))
      (error "Generated entries and Do-Symbols entries don't correspond"))
     t))

The following function prints out every present symbol (possibly more than once): 

 (defun print-all-symbols () 
   (with-package-iterator (next-symbol (list-all-packages)
                           :internal :external)
     (loop
       (multiple-value-bind (more? symbol) (next-symbol)
         (if more? 
            (print symbol)
            (return))))))

Exceptional Situations::

with-package-iterator signals an error of type program-error if no symbol-types are supplied or if a symbol-type is not recognized by the implementation is supplied.

The consequences are undefined if the local function named name established by with-package-iterator is called after it has returned false as its primary value.

See Also::

Traversal Rules and Side Effects

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/rplaca.html0000644000175000017500000000675514360276512014640 0ustar cammcamm rplaca (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.8 rplaca, rplacd [Function]

rplaca cons object ⇒ cons

rplacd cons object ⇒ cons

Pronunciation::

rplaca: pronounced ,r\=e ’plak e or pronounced ,re ’plak e

rplacd: pronounced ,r\=e ’plak de or pronounced ,re ’plak de or pronounced ,r\=e ’plak d\=e or pronounced ,re ’plak d\=e

Arguments and Values::

cons—a cons.

object—an object.

Description::

rplaca replaces the car of the cons with object.

rplacd replaces the cdr of the cons with object.

Examples::

 (defparameter *some-list* (list* 'one 'two 'three 'four)) ⇒  *some-list*
 *some-list* ⇒  (ONE TWO THREE . FOUR)
 (rplaca *some-list* 'uno) ⇒  (UNO TWO THREE . FOUR)
 *some-list* ⇒  (UNO TWO THREE . FOUR)
 (rplacd (last *some-list*) (list 'IV)) ⇒  (THREE IV)
 *some-list* ⇒  (UNO TWO THREE IV)

Side Effects::

The cons is modified.

Should signal an error of type type-error if cons is not a cons.

gcl-2.6.14/info/gcl/Generic-Function-Lambda-Lists.html0000644000175000017500000001136214360276512020775 0ustar cammcamm Generic Function Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.2 Generic Function Lambda Lists

A generic function lambda list is used to describe the overall shape of the argument list to be accepted by a generic function. Individual method signatures might contribute additional keyword parameters to the lambda list of the effective method.

A generic function lambda list is used by defgeneric.

A generic function lambda list has the following syntax:

lambda-list ::=({var}*                  [&optional {var | (var)}*]                  [&rest var]                  [&key {var | ({var |          (keyword-name var)})}* pt [&allow-other-keys]])                

A generic function lambda list can contain the lambda list keywords shown in Figure 3–14. 

  &allow-other-keys  &optional    
  &key               &rest        

  Figure 3–14: Lambda List Keywords used by Generic Function Lambda Lists

A generic function lambda list differs from an ordinary lambda list in the following ways:

Required arguments

Zero or more required parameters must be specified.

Optional and keyword arguments

Optional parameters and keyword parameters may not have default initial value forms nor use supplied-p parameters.

Use of &aux

The use of &aux is not allowed.

gcl-2.6.14/info/gcl/remove.html0000644000175000017500000002461014360276512014661 0ustar cammcamm remove (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.22 remove, remove-if, remove-if-not,

delete, delete-if, delete-if-not

[Function]

remove item sequence &key from-end test test-not start end count key ⇒ result-sequence

remove-if test sequence &key from-end start end count key ⇒ result-sequence

remove-if-not test sequence &key from-end start end count key ⇒ result-sequence

delete item sequence &key from-end test test-not start end count key ⇒ result-sequence

delete-if test sequence &key from-end start end count key ⇒ result-sequence

delete-if-not test sequence &key from-end start end count key ⇒ result-sequence

Arguments and Values::

item—an object.

sequence—a proper sequence.

test—a designator for a function of one argument that returns a generalized boolean.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

count—an integer or nil.

The default is nil.

key—a designator for a function of one argument, or nil.

result-sequence—a sequence.

Description::

remove, remove-if, and remove-if-not return a sequence from which the elements that satisfy the test have been removed.

delete, delete-if, and delete-if-not are like remove, remove-if, and remove-if-not respectively, but they may modify sequence.

If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list.

Supplying a from-end of true matters only when the count is provided; in that case only the rightmost count elements satisfying the test are deleted.

Count, if supplied, limits the number of elements removed or deleted; if more than count elements satisfy the test, then of these elements only the leftmost or rightmost, depending on from-end, are deleted or removed, as many as specified by count.

If count is supplied and negative, the behavior is as if zero had been supplied instead.

If count is nil, all matching items are affected.

For all these functions, elements not removed or deleted occur in the same order in the result as they did in sequence.

remove, remove-if, remove-if-not return a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been removed. This is a non-destructive operation. If any elements need to be removed, the result will be a copy. The result of remove may share with sequence; the result may be identical to the input sequence if no elements need to be removed.

delete, delete-if, and delete-if-not return a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been deleted. Sequence may be destroyed and used to construct the result; however, the result might or might not be identical to sequence.

delete, when sequence is a list, is permitted to setf any part, car or cdr, of the top-level list structure in that sequence. When sequence is a vector, delete is permitted to change the dimensions of the vector and to slide its elements into new positions without permuting them to produce the resulting vector.

delete-if is constrained to behave exactly as follows: 

 (delete nil sequence
             :test #'(lambda (ignore item) (funcall test item))
             ...)

Examples::

 (remove 4 '(1 3 4 5 9)) ⇒  (1 3 5 9)
 (remove 4 '(1 2 4 1 3 4 5)) ⇒  (1 2 1 3 5)
 (remove 4 '(1 2 4 1 3 4 5) :count 1) ⇒  (1 2 1 3 4 5)
 (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) ⇒  (1 2 4 1 3 5)
 (remove 3 '(1 2 4 1 3 4 5) :test #'>) ⇒  (4 3 4 5)
 (setq lst '(list of four elements)) ⇒  (LIST OF FOUR ELEMENTS)
 (setq lst2 (copy-seq lst)) ⇒  (LIST OF FOUR ELEMENTS)
 (setq lst3 (delete 'four lst)) ⇒  (LIST OF ELEMENTS)
 (equal lst lst2) ⇒  false
 (remove-if #'oddp '(1 2 4 1 3 4 5)) ⇒  (2 4 4)
 (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) 
⇒  (1 2 4 1 3 5)
 (remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t)
⇒  (1 2 3 4 5 6 8)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete 4 tester) ⇒  (1 2 1 3 5)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete 4 tester :count 1) ⇒  (1 2 1 3 4 5)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete 4 tester :count 1 :from-end t) ⇒  (1 2 4 1 3 5)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete 3 tester :test #'>) ⇒  (4 3 4 5)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete-if #'oddp tester) ⇒  (2 4 4)
 (setq tester (list 1 2 4 1 3 4 5)) ⇒  (1 2 4 1 3 4 5)
 (delete-if #'evenp tester :count 1 :from-end t) ⇒  (1 2 4 1 3 5)    
 (setq tester (list 1 2 3 4 5 6)) ⇒  (1 2 3 4 5 6) 
 (delete-if #'evenp tester) ⇒  (1 3 5) 
 tester ⇒  implementation-dependent

 (setq foo (list 'a 'b 'c)) ⇒  (A B C)
 (setq bar (cdr foo)) ⇒  (B C)
 (setq foo (delete 'b foo)) ⇒  (A C)
 bar ⇒  ((C)) or ...
 (eq (cdr foo) (car bar)) ⇒  T or ...

Side Effects::

For delete, delete-if, and delete-if-not, sequence may be destroyed and used to construct the result.

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

The functions delete-if-not and remove-if-not are deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Hash-Table-Concepts.html0000644000175000017500000000454314360276512017053 0ustar cammcamm Hash Table Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables  

18.1 Hash Table Concepts

• Hash-Table Operations  
• Modifying Hash Table Keys  
gcl-2.6.14/info/gcl/Conditions-Dictionary.html0000644000175000017500000002301514360276512017576 0ustar cammcamm Conditions Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Conditions  

9.2 Conditions Dictionary

• condition  
• warning  
• style-warning  
• serious-condition  
• error (Condition Type)  
• cell-error  
• cell-error-name  
• parse-error  
• storage-condition  
• assert  
• error  
• cerror  
• check-type  
• simple-error  
• invalid-method-error  
• method-combination-error  
• signal  
• simple-condition  
• simple-condition-format-control  
• warn  
• simple-warning  
• invoke-debugger  
• break  
• *debugger-hook*  
• *break-on-signals*  
• handler-bind  
• handler-case  
• ignore-errors  
• define-condition  
• make-condition  
• restart  
• compute-restarts  
• find-restart  
• invoke-restart  
• invoke-restart-interactively  
• restart-bind  
• restart-case  
• restart-name  
• with-condition-restarts  
• with-simple-restart  
• abort (Restart)  
• continue  
• muffle-warning  
• store-value  
• use-value  
• abort (Function)  

Previous: , Up: Conditions  

gcl-2.6.14/info/gcl/Examples-of-Class-Precedence-List-Determination.html0000644000175000017500000001435714360276512024362 0ustar cammcamm Examples of Class Precedence List Determination (ANSI and GNU Common Lisp Document)

Previous: , Up: Determining the Class Precedence List  

4.3.5.2 Examples of Class Precedence List Determination

This example determines a class precedence list for the class pie. The following classes are defined: 

 (defclass pie (apple cinnamon) ())

 (defclass apple (fruit) ())

 (defclass cinnamon (spice) ())

 (defclass fruit (food) ())

 (defclass spice (food) ())

 (defclass food () ())

The set S_{pie}~= {pie, apple, cinnamon, fruit, spice, food, standard-object, t }. The set R~= { (pie, apple), (apple, cinnamon), (apple, fruit), (cinnamon, spice), \break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) }.

The class pie is not preceded by anything, so it comes first; the result so far is (pie). Remove pie from S and pairs mentioning pie from R to get S~= {apple, cinnamon, fruit, spice, food, standard-object, t } and R~=~{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) }.

The class apple is not preceded by anything, so it is next; the result is (pie apple). Removing apple and the relevant pairs results in S~= { cinnamon, fruit, spice, food, standard-object, t } and R~= { (cinnamon, spice), (fruit, food), (spice, food), (food, standard-object),\break (standard-object, t) }.

The classes cinnamon and fruit are not preceded by anything, so the one with a direct subclass rightmost in the class precedence list computed so far goes next. The class apple is a direct subclass of fruit, and the class pie is a direct subclass of cinnamon. Because apple appears to the right of pie in the class precedence list, fruit goes next, and the result so far is (pie apple fruit). S~= { cinnamon, spice, food, standard-object, t }; R~= {(cinnamon, spice), (spice, food),\break (food, standard-object), (standard-object, t) }.

The class cinnamon is next, giving the result so far as (pie apple fruit cinnamon). At this point S~= { spice, food, standard-object, t }; R~= { (spice, food), (food, standard-object), (standard-object, t) }.

The classes spice, food, standard-object, and t are added in that order, and the class precedence list is (pie apple fruit cinnamon spice food standard-object t).

It is possible to write a set of class definitions that cannot be ordered. For example: 

 (defclass new-class (fruit apple) ())

 (defclass apple (fruit) ())

The class fruit must precede apple because the local ordering of superclasses must be preserved. The class apple must precede fruit because a class always precedes its own superclasses. When this situation occurs, an error is signaled, as happens here when the system tries to compute the class precedence list of new-class.

The following might appear to be a conflicting set of definitions: 

 (defclass pie (apple cinnamon) ())

 (defclass pastry (cinnamon apple) ())

 (defclass apple () ())

 (defclass cinnamon () ())

The class precedence list for pie is (pie apple cinnamon standard-object t).

The class precedence list for pastry is (pastry cinnamon apple standard-object t).

It is not a problem for apple to precede cinnamon in the ordering of the superclasses of pie but not in the ordering for pastry. However, it is not possible to build a new class that has both pie and pastry as superclasses.

Previous: , Up: Determining the Class Precedence List  

gcl-2.6.14/info/gcl/shadow.html0000644000175000017500000001266014360276512014653 0ustar cammcamm shadow (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.9 shadow [Function]

shadow symbol-names &optional package ⇒ t

Arguments and Values::

symbol-names—a designator for a list of string designators.

package—a package designator.

The default is the current package.

Description::

shadow assures that symbols with names given by symbol-names are present in the package.

Specifically, package is searched for symbols with the names supplied by symbol-names.

For each such name, if a corresponding symbol is not present in package (directly, not by inheritance), then a corresponding symbol is created with that name, and inserted into package as an internal symbol. The corresponding symbol, whether pre-existing or newly created, is then added, if not already present, to the shadowing symbols list of package.

Examples::

 (package-shadowing-symbols (make-package 'temp)) ⇒  NIL
 (find-symbol 'car 'temp) ⇒  CAR, :INHERITED
 (shadow 'car 'temp) ⇒  T
 (find-symbol 'car 'temp) ⇒  TEMP::CAR, :INTERNAL
 (package-shadowing-symbols 'temp) ⇒  (TEMP::CAR)

 (make-package 'test-1) ⇒  #<PACKAGE "TEST-1">
 (intern "TEST" (find-package 'test-1)) ⇒  TEST-1::TEST, NIL
 (shadow 'test-1::test (find-package 'test-1)) ⇒  T
 (shadow 'TEST (find-package 'test-1)) ⇒  T
 (assert (not (null (member 'test-1::test (package-shadowing-symbols
                                            (find-package 'test-1))))))

 (make-package 'test-2) ⇒  #<PACKAGE "TEST-2">
 (intern "TEST" (find-package 'test-2)) ⇒  TEST-2::TEST, NIL
 (export 'test-2::test (find-package 'test-2)) ⇒  T
 (use-package 'test-2 (find-package 'test-1))    ;should not error

Side Effects::

shadow changes the state of the package system in such a way that the package consistency rules do not hold across the change.

Affected By::

Current state of the package system.

See Also::

package-shadowing-symbols , Package Concepts

Notes::

If a symbol with a name in symbol-names already exists in package, but by inheritance, the inherited symbol becomes shadowed_3 by a newly created internal symbol.

Next: , Previous: , Up: Packages Dictionary  

././@LongLink0000644000000000000000000000015200000000000011601 Lustar rootrootgcl-2.6.14/info/gcl/Initializing-Newly-Added-Local-Slots-_0028Changing-the-Class-of-an-Instance_0029.htmlgcl-2.6.14/info/gcl/Initializing-Newly-Added-Local-Slots-_0028Changing-the-Class-of-an-Instance_00290000644000175000017500000001017014360276512030514 0ustar cammcamm Initializing Newly Added Local Slots (Changing the Class of an Instance) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Changing the Class of an Instance  

7.2.2 Initializing Newly Added Local Slots

The second step of the update initializes the newly added slots and performs any other user-defined actions. This step is implemented by the generic function update-instance-for-different-class. The generic function update-instance-for-different-class is invoked by change-class after the first step of the update has been completed.

The generic function update-instance-for-different-class is invoked on arguments computed by change-class. The first argument passed is a copy of the instance being updated and is an instance of the class C_{from}; this copy has dynamic extent within the generic function change-class. The second argument is the instance as updated so far by change-class and is an instance of the class C_{to}. The remaining arguments are an initialization argument list.

There is a system-supplied primary method for update-instance-for-different-class that has two parameter specializers, each of which is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see Declaring the Validity of Initialization Arguments.) Then it calls the generic function shared-initialize with the following arguments: the new instance, a list of names of the newly added slots, and the initialization arguments it received.

gcl-2.6.14/info/gcl/Input.html0000644000175000017500000001075414360276512014467 0ustar cammcamm Input (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.2 Input, Output, and Bidirectional Streams

A stream, whether a character stream or a binary stream, can be an input stream (source of data), an output stream (sink for data), both, or (e.g., when “:direction :probe” is given to open) neither.

Figure 21–2 shows operators relating to input streams. 

  clear-input  read-byte            read-from-string            
  listen       read-char            read-line                   
  peek-char    read-char-no-hang    read-preserving-whitespace  
  read         read-delimited-list  unread-char                 

        Figure 21–2: Operators relating to Input Streams.

Figure 21–3 shows operators relating to output streams. 

  clear-output   prin1            write            
  finish-output  prin1-to-string  write-byte       
  force-output   princ            write-char       
  format         princ-to-string  write-line       
  fresh-line     print            write-string     
  pprint         terpri           write-to-string  

  Figure 21–3: Operators relating to Output Streams.

A stream that is both an input stream and an output stream is called a bidirectional stream . See the functions input-stream-p and output-stream-p.

Any of the operators listed in Figure~21–2 or Figure~21–3 can be used with bidirectional streams. In addition, Figure 21–4 shows a list of operators that relate specificaly to bidirectional streams. 

  y-or-n-p  yes-or-no-p    

  Figure 21–4: Operators relating to Bidirectional Streams.
gcl-2.6.14/info/gcl/make_002drandom_002dstate.html0000644000175000017500000001136414360276512020017 0ustar cammcamm make-random-state (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.40 make-random-state [Function]

make-random-state &optional state ⇒ new-state

Arguments and Values::

state—a random state, or nil, or t. The default is nil.

new-state—a random state object.

Description::

Creates a fresh object of type random-state suitable for use as the value of *random-state*.

If state is a random state object, the new-state is a copy_5 of that object. If state is nil, the new-state is a copy_5 of the current random state. If state is t, the new-state is a fresh random state object that has been randomly initialized by some means.

Examples::

 (let* ((rs1 (make-random-state nil))
        (rs2 (make-random-state t))
        (rs3 (make-random-state rs2))
        (rs4 nil))
   (list (loop for i from 1 to 10 
               collect (random 100)
               when (= i 5)
                do (setq rs4 (make-random-state)))
         (loop for i from 1 to 10 collect (random 100 rs1))
         (loop for i from 1 to 10 collect (random 100 rs2))
         (loop for i from 1 to 10 collect (random 100 rs3))
         (loop for i from 1 to 10 collect (random 100 rs4))))
⇒  ((29 25 72 57 55 68 24 35 54 65)
    (29 25 72 57 55 68 24 35 54 65)
    (93 85 53 99 58 62 2 23 23 59)
    (93 85 53 99 58 62 2 23 23 59)
    (68 24 35 54 65 54 55 50 59 49))

Exceptional Situations::

Should signal an error of type type-error if state is not a random state, or nil, or t.

See Also::

random , random-state

Notes::

One important use of make-random-state is to allow the same series of pseudo-random numbers to be generated many times within a single program.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Restrictions-on-Constructing-Pathnames.html0000644000175000017500000000743114360276512023066 0ustar cammcamm Restrictions on Constructing Pathnames (ANSI and GNU Common Lisp Document)

Previous: , Up: Interpreting Pathname Component Values  

19.2.2.21 Restrictions on Constructing Pathnames

When constructing a pathname from components, conforming programs must follow these rules:

*

Any component can be nil. nil in the host might mean a default host rather than an actual nil in some implementations.

*

The host, device, directory, name, and type can be strings. There are implementation-dependent limits on the number and type of characters in these strings.

*

The directory can be a list of strings and symbols. There are implementation-dependent limits on the list’s length and contents.

*

The version can be :newest.

*

Any component can be taken from the corresponding component of another pathname. When the two pathnames are for different file systems (in implementations that support multiple file systems), an appropriate translation occurs. If no meaningful translation is possible, an error is signaled. The definitions of “appropriate” and “meaningful” are implementation-dependent.

*

An implementation might support other values for some components, but a portable program cannot use those values. A conforming program can use implementation-dependent values but this can make it non-portable; for example, it might work only with Unix file systems.

gcl-2.6.14/info/gcl/Interning-a-Symbol-in-the-KEYWORD-Package.html0000644000175000017500000000510514360276512022635 0ustar cammcamm Interning a Symbol in the KEYWORD Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.7 Interning a Symbol in the KEYWORD Package

The KEYWORD package is treated differently than other packages in that special actions are taken when a symbol is interned in it. In particular, when a symbol is interned in the KEYWORD package, it is automatically made to be an external symbol and is automatically made to be a constant variable with itself as a value.

gcl-2.6.14/info/gcl/nil.html0000644000175000017500000000504014360276512014142 0ustar cammcamm nil (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.30 nil [Constant Variable]

Constant Value::

nil.

Description::

nil represents both boolean (and generalized boolean) false and the empty list.

Examples::

 nil ⇒  NIL

See Also::

t

gcl-2.6.14/info/gcl/type_002derror.html0000644000175000017500000000556714360276512016156 0ustar cammcamm type-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.29 type-error [Condition Type]

Class Precedence List::

type-error, error, serious-condition, condition, t

Description::

The type type-error represents a situation in which an object is not of the expected type. The “offending datum” and “expected type” are initialized by the initialization arguments named :datum and :expected-type to make-condition, and are accessed by the functions type-error-datum and type-error-expected-type.

See Also::

type-error-datum , type-error-expected-type

gcl-2.6.14/info/gcl/Required-Language-Features.html0000644000175000017500000000513714360276512020444 0ustar cammcamm Required Language Features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.1 Required Language Features

A conforming implementation shall accept all features (including deprecated features) of the language specified in this standard, with the meanings defined in this standard.

A conforming implementation shall not require the inclusion of substitute or additional language elements in code in order to accomplish a feature of the language that is specified in this standard.

gcl-2.6.14/info/gcl/Determining-the-Effective-Method.html0000644000175000017500000000530514360276512021523 0ustar cammcamm Determining the Effective Method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.1 Determining the Effective Method

The effective method is determined by the following three-step procedure:

1.

Select the applicable methods.

2.

Sort the applicable methods by precedence order, putting the most specific method first.

3.

Apply method combination to the sorted list of applicable methods, producing the effective method.

gcl-2.6.14/info/gcl/readtablep.html0000644000175000017500000000601714360276512015470 0ustar cammcamm readtablep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.8 readtablep [Function]

readtablep object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type readtable; otherwise, returns false.

Examples::

 (readtablep *readtable*) ⇒  true
 (readtablep (copy-readtable)) ⇒  true
 (readtablep '*readtable*) ⇒  false

Notes::

 (readtablep object) ≡ (typep object 'readtable)
gcl-2.6.14/info/gcl/terpri.html0000644000175000017500000001031214360276512014663 0ustar cammcamm terpri (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.19 terpri, fresh-line [Function]

terpri &optional output-stream ⇒ nil

fresh-line &optional output-stream ⇒ generalized-boolean

Arguments and Values::

output-stream – an output stream designator. The default is standard output.

generalized-boolean—a generalized boolean.

Description::

terpri outputs a newline to output-stream.

fresh-line is similar to terpri but outputs a newline only if the output-stream is not already at the start of a line. If for some reason this cannot be determined, then a newline is output anyway. fresh-line returns true if it outputs a newline; otherwise it returns false.

Examples::

 (with-output-to-string (s)
    (write-string "some text" s)
    (terpri s)
    (terpri s)
    (write-string "more text" s))
⇒  "some text

more text"
 (with-output-to-string (s)
    (write-string "some text" s)
    (fresh-line s)
    (fresh-line s)
    (write-string "more text" s))
⇒  "some text
more text"

Side Effects::

The output-stream is modified.

Affected By::

*standard-output*, *terminal-io*.

Exceptional Situations::

None.

[Reviewer Note by Barmar: What if stream is closed?]

Notes::

terpri is identical in effect to 

 (write-char #\Newline output-stream)
gcl-2.6.14/info/gcl/Tilde-Newline_002d_003e-Ignored-Newline.html0000644000175000017500000000670614360276512022272 0ustar cammcamm Tilde Newline-> Ignored Newline (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Miscellaneous Pseudo-Operations  

22.3.9.3 Tilde Newline: Ignored Newline

Tilde immediately followed by a newline ignores the newline and any following non-newline whitespace_1 characters. With a :, the newline is ignored, but any following whitespace_1 is left in place. With an @, the newline is left in place, but any following whitespace_1 is ignored. For example: 

 (defun type-clash-error (fn nargs argnum right-type wrong-type)
   (format *error-output*
           "~&~S requires its ~:[~:R~;~*~]~ 
           argument to be of type ~S,~
           with an argument of type ~S.~
           fn (eql nargs 1) argnum right-type wrong-type))
 (type-clash-error 'aref nil 2 'integer 'vector)  prints:
AREF requires its second argument to be of type INTEGER,
but it was called with an argument of type VECTOR.
NIL
 (type-clash-error 'car 1 1 'list 'short-float)  prints:
CAR requires its argument to be of type LIST,
but it was called with an argument of type SHORT-FLOAT.
NIL

Note that in this example newlines appear in the output only as specified by the ~& and ~% directives; the actual newline characters in the control string are suppressed because each is preceded by a tilde.

gcl-2.6.14/info/gcl/Examples-of-WITH-clause.html0000644000175000017500000000560014360276512017565 0ustar cammcamm Examples of WITH clause (ANSI and GNU Common Lisp Document)

Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.16 Examples of WITH clause

;; These bindings occur in sequence.
 (loop with a = 1 
       with b = (+ a 2) 
       with c = (+ b 3)
       return (list a b c))
⇒  (1 3 6)

;; These bindings occur in parallel.
 (setq a 5 b 10)
⇒  10
 (loop with a = 1
       and b = (+ a 2)
       and c = (+ b 3)
       return (list a b c))
⇒  (1 7 13)

;; This example shows a shorthand way to declare local variables 
;; that are of different types.
 (loop with (a b c) of-type (float integer float)
       return (format nil "~A ~A ~A" a b c))
⇒  "0.0 0 0.0"

;; This example shows a shorthand way to declare local variables 
;; that are the same type.
 (loop with (a b c) of-type float 
       return (format nil "~A ~A ~A" a b c))
⇒  "0.0 0.0 0.0"
gcl-2.6.14/info/gcl/Feature-Expressions.html0000644000175000017500000000620214360276512017274 0ustar cammcamm Feature Expressions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Features  

24.1.2.1 Feature Expressions

Boolean combinations of features, called feature expressions , are used by the #+ and #- reader macros in order to direct conditional reading of expressions by the Lisp reader.

The rules for interpreting a feature expression are as follows:

feature

If a symbol naming a feature is used as a feature expression, the feature expression succeeds if that feature is present; otherwise it fails.

(not feature-conditional)

A not feature expression succeeds if its argument feature-conditional fails; otherwise, it succeeds.

(and {feature-conditional}*)

An and feature expression succeeds if all of its argument feature-conditionals succeed; otherwise, it fails.

(or {feature-conditional}*)

An or feature expression succeeds if any of its argument feature-conditionals succeed; otherwise, it fails.

gcl-2.6.14/info/gcl/max.html0000644000175000017500000001122514360276512014147 0ustar cammcamm max (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.16 max, min [Function]

max &rest reals^+ ⇒ max-real

min &rest reals^+ ⇒ min-real

Arguments and Values::

real—a real.

max-real, min-real—a real.

Description::

max returns the real that is greatest (closest to positive infinity). min returns the real that is least (closest to negative infinity).

For max, the implementation has the choice of returning the largest argument as is or applying the rules of floating-point contagion, taking all the arguments into consideration for contagion purposes. Also, if one or more of the arguments are =, then any one of them may be chosen as the value to return. For example, if the reals are a mixture of rationals and floats, and the largest argument is a rational, then the implementation is free to produce either that rational or its float approximation; if the largest argument is a float of a smaller format than the largest format of any float argument, then the implementation is free to return the argument in its given format or expanded to the larger format. Similar remarks apply to min (replacing “largest argument” by “smallest argument”).

Examples::

 (max 3) ⇒  3 
 (min 3) ⇒  3
 (max 6 12) ⇒  12 
 (min 6 12) ⇒  6
 (max -6 -12) ⇒  -6 
 (min -6 -12) ⇒  -12
 (max 1 3 2 -7) ⇒  3 
 (min 1 3 2 -7) ⇒  -7
 (max -2 3 0 7) ⇒  7 
 (min -2 3 0 7) ⇒  -2
 (max 5.0 2) ⇒  5.0 
 (min 5.0 2)
⇒  2
OR⇒ 2.0
 (max 3.0 7 1)
⇒  7
OR⇒ 7.0 
 (min 3.0 7 1)
⇒  1
OR⇒ 1.0
 (max 1.0s0 7.0d0) ⇒  7.0d0
 (min 1.0s0 7.0d0)
⇒  1.0s0
OR⇒ 1.0d0
 (max 3 1 1.0s0 1.0d0)
⇒  3
OR⇒ 3.0d0
 (min 3 1 1.0s0 1.0d0)
⇒  1
OR⇒ 1.0s0 
OR⇒ 1.0d0

Exceptional Situations::

Should signal an error of type type-error if any number is not a real.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Visible-Modification-of-Objects-with-respect-to-EQ-and-EQL.html0000644000175000017500000000504114360276512026070 0ustar cammcamm Visible Modification of Objects with respect to EQ and EQL (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.1 Visible Modification of Objects with respect to EQ and EQL

No standardized function is provided that is capable of visibly modifying an object with regard to eq or eql.

gcl-2.6.14/info/gcl/Vectors.html0000644000175000017500000000374314360276512015015 0ustar cammcamm Vectors (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.5 Vectors

An array of rank one (i.e., a one-dimensional array) is called a vector .

gcl-2.6.14/info/gcl/prog.html0000644000175000017500000001665414360276512014344 0ustar cammcamm prog (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.57 prog, prog* [Macro]

prog ({var | (var [init-form])}*) {declaration}* {tag | statement}*
⇒ {result}*

prog* ({var | (var [init-form])}*) {declaration}* {tag | statement}*
⇒ {result}*

Arguments and Values::

var—variable name.

init-form—a form.

declaration—a declare expression; not evaluated.

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

results—nil if a normal return occurs, or else, if an explicit return occurs, the values that were transferred.

Description::

Three distinct operations are performed by prog and prog*: they bind local variables, they permit use of the return statement, and they permit use of the go statement. A typical prog looks like this: 

 (prog (var1 var2 (var3 init-form-3) var4 (var5 init-form-5))
       {declaration}*
       statement1
  tag1
       statement2
       statement3
       statement4
  tag2
       statement5
       ...
       )

For prog, init-forms are evaluated first, in the order in which they are supplied. The vars are then bound to the corresponding values in parallel. If no init-form is supplied for a given var, that var is bound to nil.

The body of prog is executed as if it were a tagbody form; the go statement can be used to transfer control to a tag. Tags label statements.

prog implicitly establishes a block named nil around the entire prog form, so that return can be used at any time to exit from the prog form.

The difference between prog* and prog is that in prog* the binding and initialization of the vars is done sequentially, so that the init-form for each one can use the values of previous ones.

Examples::

(prog* ((y z) (x (car y)))
       (return x))

returns the car of the value of z. 

 (setq a 1) ⇒  1
 (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) ⇒  /=
 (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) ⇒  =
 (prog () 'no-return-value) ⇒  NIL

 (defun king-of-confusion (w)
   "Take a cons of two lists and make a list of conses.
    Think of this function as being like a zipper."
   (prog (x y z)          ;Initialize x, y, z to NIL
        (setq y (car w) z (cdr w))
    loop
        (cond ((null y) (return x))
              ((null z) (go err)))
    rejoin
        (setq x (cons (cons (car y) (car z)) x))
        (setq y (cdr y) z (cdr z))
        (go loop)
    err
        (cerror "Will self-pair extraneous items"
                "Mismatch - gleep!  ~S" y)
        (setq z y)
        (go rejoin))) ⇒  KING-OF-CONFUSION

This can be accomplished more perspicuously as follows: 

 (defun prince-of-clarity (w)
   "Take a cons of two lists and make a list of conses.
    Think of this function as being like a zipper."
   (do ((y (car w) (cdr y))
        (z (cdr w) (cdr z))
        (x '() (cons (cons (car y) (car z)) x)))
       ((null y) x)
     (when (null z)
       (cerror "Will self-pair extraneous items"
              "Mismatch - gleep!  ~S" y)
       (setq z y)))) ⇒  PRINCE-OF-CLARITY

See Also::

block , let , tagbody , go , return , Evaluation

Notes::

prog can be explained in terms of block, let, and tagbody as follows: 

 (prog variable-list declaration . body)
    ≡ (block nil (let variable-list declaration (tagbody . body)))

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Return-values-in-The-_0022Syntax_0022-Section.html0000644000175000017500000000607114360276512023257 0ustar cammcamm Return values in The "Syntax" Section (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.28 Return values in The "Syntax" Section

An evaluation arrow “⇒” precedes a list of values to be returned. For example:

F a b c ⇒ x

indicates that F is an operator that has three required parameters (i.e., a, b, and c) and that returns one value (i.e., x). If more than one value is returned by an operator, the names of the values are separated by commas, as in:

F a b c ⇒ x, y, z

gcl-2.6.14/info/gcl/getf.html0000644000175000017500000001404014360276512014305 0ustar cammcamm getf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.41 getf [Accessor]

getf plist indicator &optional default ⇒ value

(setf ( getf place indicator &optional default) new-value)

Arguments and Values::

plist—a property list.

place—a place, the value of which is a property list.

indicator—an object.

default—an object. The default is nil.

value—an object.

new-value—an object.

Description::

getf finds a property on the plist whose property indicator is identical to indicator, and returns its corresponding property value.

If there are multiple properties_1 with that property indicator, getf uses the first such property.

If there is no property with that property indicator, default is returned.

setf of getf may be used to associate a new object with an existing indicator in the property list held by place, or to create a new assocation if none exists.

If there are multiple properties_1 with that property indicator, setf of getf associates the new-value with the first such property.

When a getf form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored.

setf of getf is permitted to either write the value of place itself, or modify of any part, car or cdr, of the list structure held by place.

Examples::

 (setq x '()) ⇒  NIL
 (getf x 'prop1) ⇒  NIL
 (getf x 'prop1 7) ⇒  7
 (getf x 'prop1) ⇒  NIL
 (setf (getf x 'prop1) 'val1) ⇒  VAL1
 (eq (getf x 'prop1) 'val1) ⇒  true
 (getf x 'prop1) ⇒  VAL1
 (getf x 'prop1 7) ⇒  VAL1
 x ⇒  (PROP1 VAL1)

;; Examples of implementation variation permitted.
 (setq foo (list 'a 'b 'c 'd 'e 'f)) ⇒  (A B C D E F)
 (setq bar (cddr foo)) ⇒  (C D E F)
 (remf foo 'c) ⇒  true
 foo ⇒  (A B E F)
 bar
⇒  (C D E F)
OR⇒ (C)
OR⇒ (NIL)
OR⇒ (C NIL)
OR⇒ (C D)

See Also::

get , get-properties , setf , Function Call Forms as Places

Notes::

There is no way (using getf) to distinguish an absent property from one whose value is default; but see get-properties.

Note that while supplying a default argument to getf in a setf situation is sometimes not very interesting, it is still important because some macros, such as push and incf, require a place argument which data is both read from and written to. In such a context, if a default argument is to be supplied for the read situation, it must be syntactically valid for the write situation as well. For example, 

 (let ((plist '()))
   (incf (getf plist 'count 0))
   plist) ⇒  (COUNT 1)

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Removed-Reader-Syntax.html0000644000175000017500000000417614360276512017456 0ustar cammcamm Removed Reader Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.6 Removed Reader Syntax

The “#,” reader macro in standard syntax was removed.

gcl-2.6.14/info/gcl/print_002dunreadable_002dobject.html0000644000175000017500000001073314360276512021205 0ustar cammcamm print-unreadable-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.12 print-unreadable-object [Macro]

print-unreadable-object (object stream &key type identity) {form}* ⇒ nil

Arguments and Values::

object—an object; evaluated.

stream— a stream designator; evaluated.

type—a generalized boolean; evaluated.

identity—a generalized boolean; evaluated.

forms—an implicit progn.

Description::

Outputs a printed representation of object on stream, beginning with “#<” and ending with “>”. Everything output to stream by the body forms is enclosed in the the angle brackets. If type is true, the output from forms is preceded by a brief description of the object’s type and a space character. If identity is true, the output from forms is followed by a space character and a representation of the object’s identity, typically a storage address.

If either type or identity is not supplied, its value is false. It is valid to omit the body forms. If type and identity are both true and there are no body forms, only one space character separates the type and the identity.

Examples::

;; Note that in this example, the precise form of the output ;; is implementation-dependent. 

 (defmethod print-object ((obj airplane) stream)
   (print-unreadable-object (obj stream :type t :identity t)
     (princ (tail-number obj) stream)))

 (prin1-to-string my-airplane)
⇒  "#<Airplane NW0773 36000123135>"
OR⇒ "#<FAA:AIRPLANE NW0773 17>"

Exceptional Situations::

If *print-readably* is true, print-unreadable-object signals an error of type print-not-readable without printing anything.

gcl-2.6.14/info/gcl/logand.html0000644000175000017500000002026514360276512014632 0ustar cammcamm logand (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.62 logand, logandc1, logandc2, logeqv, logior,

lognand, lognor, lognot, logorc1, logorc2,

logxor

[Function]

logand &rest integers ⇒ result-integer

logandc 1 ⇒ integer-1 integer-2 result-integer logandc 2 ⇒ integer-1 integer-2 result-integer logeqv &rest integers ⇒ result-integer

logior &rest integers ⇒ result-integer

lognand integer-1 integer-2 ⇒ result-integer

lognor integer-1 integer-2 ⇒ result-integer

lognot integer ⇒ result-integer

logorc 1 ⇒ integer-1 integer-2 result-integer logorc 2 ⇒ integer-1 integer-2 result-integer logxor &rest integers ⇒ result-integer

Arguments and Values::

integers—integers.

integer—an integer.

integer-1—an integer.

integer-2—an integer.

result-integer—an integer.

Description::

The functions logandc1, logandc2, logand, logeqv, logior, lognand, lognor, lognot, logorc1, logorc2, and logxor perform bit-wise logical operations on their arguments, that are treated as if they were binary.

Figure 12–17 lists the meaning of each of the functions. Where an ‘identity’ is shown, it indicates the value yielded by the function when no arguments are supplied. 

  Function  Identity  Operation performed                         
  logandc1  —       and complement of integer-1 with integer-2  
  logandc2  —       and integer-1 with complement of integer-2  
  logand    -1        and                                         
  logeqv    -1        equivalence (exclusive nor)                 
  logior    0         inclusive or                                
  lognand   —       complement of integer-1 and integer-2       
  lognor    —       complement of integer-1 or integer-2        
  lognot    —       complement                                  
  logorc1   —       or complement of integer-1 with integer-2   
  logorc2   —       or integer-1 with complement of integer-2   
  logxor    0         exclusive or                                

       Figure 12–17: Bit-wise Logical Operations on Integers

Negative integers are treated as if they were in two’s-complement notation.

Examples::

 (logior 1 2 4 8) ⇒  15
 (logxor 1 3 7 15) ⇒  10
 (logeqv) ⇒  -1
 (logand 16 31) ⇒  16
 (lognot 0) ⇒  -1
 (lognot 1) ⇒  -2
 (lognot -1) ⇒  0
 (lognot (1+ (lognot 1000))) ⇒  999

;;; In the following example, m is a mask.  For each bit in
;;; the mask that is a 1, the corresponding bits in x and y are
;;; exchanged.  For each bit in the mask that is a 0, the 
;;; corresponding bits of x and y are left unchanged.
 (flet ((show (m x y)
          (format t "~
                  m x y)))
   (let ((m #o007750)
         (x #o452576)
         (y #o317407))
     (show m x y)
     (let ((z (logand (logxor x y) m)))
       (setq x (logxor z x))
       (setq y (logxor z y))
       (show m x y))))
 |>  m = #o007750
 |>  x = #o452576
 |>  y = #o317407
 |>  
 |>  m = #o007750
 |>  x = #o457426
 |>  y = #o312557
⇒  NIL

Exceptional Situations::

Should signal type-error if any argument is not an integer.

See Also::

boole

Notes::

(logbitp k -1) returns true for all values of k.

Because the following functions are not associative, they take exactly two arguments rather than any number of arguments. 

 (lognand n1 n2) ≡ (lognot (logand n1 n2))
 (lognor n1 n2) ≡ (lognot (logior n1 n2))
 (logandc1 n1 n2) ≡ (logand (lognot n1) n2)
 (logandc2 n1 n2) ≡ (logand n1 (lognot n2))
 (logiorc1 n1 n2) ≡ (logior (lognot n1) n2)
 (logiorc2 n1 n2) ≡ (logior n1 (lognot n2))
 (logbitp j (lognot x)) ≡ (not (logbitp j x))

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Visible-Modification-of-Arrays-with-respect-to-EQUALP.html0000644000175000017500000000547014360276512025251 0ustar cammcamm Visible Modification of Arrays with respect to EQUALP (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.7 Visible Modification of Arrays with respect to EQUALP

In an array, any visible change to an active element, to the fill pointer (if the array can and does have one), or to the dimensions (if the array is actually adjustable) is considered a visible modification with regard to equalp.

gcl-2.6.14/info/gcl/proclaim.html0000644000175000017500000001225014360276512015167 0ustar cammcamm proclaim (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.16 proclaim [Function]

proclaim declaration-specifier ⇒ implementation-dependent

Arguments and Values::

declaration-specifier—a declaration specifier.

Description::

Establishes the declaration specified by declaration-specifier in the global environment.

Such a declaration, sometimes called a global declaration or a proclamation, is always in force unless locally shadowed.

Names of variables and functions within declaration-specifier refer to dynamic variables and global function definitions, respectively.

Figure 3–22 shows a list of declaration identifiers that can be used with proclaim. 

  declaration  inline     optimize  type  
  ftype        notinline  special         

  Figure 3–22: Global Declaration Specifiers

An implementation is free to support other (implementation-defined) declaration identifiers as well.

Examples::

 (defun declare-variable-types-globally (type vars)
   (proclaim `(type ,type ,@vars))
   type)

 ;; Once this form is executed, the dynamic variable *TOLERANCE*
 ;; must always contain a float.
 (declare-variable-types-globally 'float '(*tolerance*))
⇒  FLOAT

See Also::

declaim , declare, Compilation

Notes::

Although the execution of a proclaim form has effects that might affect compilation, the compiler does not make any attempt to recognize and specially process proclaim forms. A proclamation such as the following, even if a top level form, does not have any effect until it is executed: 

(proclaim '(special *x*))

If compile time side effects are desired, eval-when may be useful. For example: 

 (eval-when (:execute :compile-toplevel :load-toplevel)
   (proclaim '(special *x*)))

In most such cases, however, it is preferrable to use declaim for this purpose.

Since proclaim forms are ordinary function forms, macro forms can expand into them.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/A-specifier-for-a-rest-parameter.html0000644000175000017500000000626014360276512021447 0ustar cammcamm A specifier for a rest parameter (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.3 A specifier for a rest parameter

&rest, if present, must be followed by a single rest parameter specifier, which in turn must be followed by another lambda list keyword or the end of the lambda list. After all optional parameter specifiers have been processed, then there may or may not be a rest parameter. If there is a rest parameter, it is bound to a list of all as-yet-unprocessed arguments. If no unprocessed arguments remain, the rest parameter is bound to the empty list. If there is no rest parameter and there are no keyword parameters, then an error should be signaled if any unprocessed arguments remain; see Error Checking in Function Calls. The value of a rest parameter is permitted, but not required, to share structure with the last argument to apply.

gcl-2.6.14/info/gcl/hash_002dtable_002drehash_002dthreshold.html0000644000175000017500000000707714360276512022436 0ustar cammcamm hash-table-rehash-threshold (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.6 hash-table-rehash-threshold [Function]

hash-table-rehash-threshold hash-table ⇒ rehash-threshold

Arguments and Values::

hash-table—a hash table.

rehash-threshold—a real of type (real 0 1).

Description::

Returns the current rehash threshold of hash-table, which is suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table.

Examples::

 (setq table (make-hash-table :size 100 :rehash-threshold 0.5))
⇒  #<HASH-TABLE EQL 0/100 2562446>
 (hash-table-rehash-threshold table) ⇒  0.5

Exceptional Situations::

Should signal an error of type type-error if hash-table is not a hash table.

See Also::

make-hash-table , hash-table-rehash-size

gcl-2.6.14/info/gcl/The-COMMON_002dLISP_002dUSER-Package.html0000644000175000017500000000557414360276512021074 0ustar cammcamm The COMMON-LISP-USER Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.5 The COMMON-LISP-USER Package

The COMMON-LISP-USER package is the current package when a Common Lisp system starts up. This package uses the COMMON-LISP package. The COMMON-LISP-USER package has the nickname CL-USER.

The COMMON-LISP-USER package can have additional symbols interned within it; it can use other implementation-defined packages.

gcl-2.6.14/info/gcl/Restrictions-on-Side_002dEffects.html0000644000175000017500000000415514360276512021377 0ustar cammcamm Restrictions on Side-Effects (ANSI and GNU Common Lisp Document)

Previous: , Up: Overview of the Loop Facility  

6.1.1.16 Restrictions on Side-Effects

See Traversal Rules and Side Effects.

gcl-2.6.14/info/gcl/Examples-of-Potential-Numbers.html0000644000175000017500000000725514360276512021120 0ustar cammcamm Examples of Potential Numbers (ANSI and GNU Common Lisp Document)

Previous: , Up: Numbers as Tokens  

2.3.1.3 Examples of Potential Numbers

As examples, the tokens in Figure 2–10 are potential numbers, but they are not actually numbers, and so are reserved tokens; a conforming implementation is permitted, but not required, to define their meaning. 

  1b5000                       777777q                1.7J  -3/4+6.7J  12/25/83  
  27^19                      3^4/5                6//7  3.1.2.6    ^-43^   
  3.141_592_653_589_793_238_4  -3.7+2.6i-6.17j+19.6k  

                     Figure 2–10: Examples of reserved tokens

The tokens in Figure 2–11 are not potential numbers; they are always treated as symbols: 

  /     /5     +  1+  1-     
  foo+  ab.cd  _  ^   ^/-  

  Figure 2–11: Examples of symbols

The tokens in Figure 2–12 are potential numbers if the current input base is 16, but they are always treated as symbols if the current input base is 10. 

  bad-face  25-dec-83  a/b  fad_cafe  f^ 

  Figure 2–12: Examples of symbols or potential numbers
gcl-2.6.14/info/gcl/_002aprint_002dright_002dmargin_002a.html0000644000175000017500000000615314360276512021474 0ustar cammcamm *print-right-margin* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.28 *print-right-margin* [Variable]

Value Type::

a non-negative integer, or nil.

Initial Value::

nil.

Description::

If it is non-nil, it specifies the right margin (as integer number of ems) to use when the pretty printer is making layout decisions.

If it is nil, the right margin is taken to be the maximum line length such that output can be displayed without wraparound or truncation. If this cannot be determined, an implementation-dependent value is used.

Notes::

This measure is in units of ems in order to be compatible with implementation-defined variable-width fonts while still not requiring the language to provide support for fonts.

gcl-2.6.14/info/gcl/Files.html0000644000175000017500000000427414360276512014432 0ustar cammcamm Files (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

20 Files

• File System Concepts  
• Files Dictionary  
gcl-2.6.14/info/gcl/Examples-of-NAMED-clause.html0000644000175000017500000000442414360276512017641 0ustar cammcamm Examples of NAMED clause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Miscellaneous Clauses  

6.1.7.2 Examples of NAMED clause

;; Just name and return.
 (loop named max
       for i from 1 to 10
       do (print i)
       do (return-from max 'done))
 |>  1 
⇒  DONE
gcl-2.6.14/info/gcl/Examples-of-Transfer-of-Control-during-a-Destructive-Operation.html0000644000175000017500000000600214360276512027302 0ustar cammcamm Examples of Transfer of Control during a Destructive Operation (ANSI and GNU Common Lisp Document)

Previous: , Up: Transfer of Control during a Destructive Operation  

3.7.2.1 Examples of Transfer of Control during a Destructive Operation

The following examples illustrate some of the many ways in which the implementation-dependent nature of the modification can manifest itself. 

 (let ((a (list 2 1 4 3 7 6 'five)))
   (ignore-errors (sort a #'<))
   a)
⇒  (1 2 3 4 6 7 FIVE)
OR⇒ (2 1 4 3 7 6 FIVE)
OR⇒ (2)

 (prog foo ((a (list 1 2 3 4 5 6 7 8 9 10)))
   (sort a #'(lambda (x y) (if (zerop (random 5)) (return-from foo a) (> x y)))))
⇒  (1 2 3 4 5 6 7 8 9 10)
OR⇒ (3 4 5 6 2 7 8 9 10 1)
OR⇒ (1 2 4 3)
gcl-2.6.14/info/gcl/typecase.html0000644000175000017500000002404714360276512015205 0ustar cammcamm typecase (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.47 typecase, ctypecase, etypecase [Macro]

typecase keyform {!normal-clause}* [!otherwise-clause] ⇒ {result}*

ctypecase keyplace {!normal-clause}* ⇒ {result}*

etypecase keyform {!normal-clause}* ⇒ {result}*

normal-clause ::=(type {form}*)

otherwise-clause ::=({otherwise | t} {form}*)

clause ::=normal-clause | otherwise-clause

Arguments and Values::

keyform—a form; evaluated to produce a test-key.

keyplace—a form; evaluated initially to produce a test-key. Possibly also used later as a place if no types match.

test-key—an object produced by evaluating keyform or keyplace.

type—a type specifier.

forms—an implicit progn.

results—the values returned by the forms in the matching clause.

Description::

These macros allow the conditional execution of a body of forms in a clause that is selected by matching the test-key on the basis of its type.

The keyform or keyplace is evaluated to produce the test-key.

Each of the normal-clauses is then considered in turn. If the test-key is of the type given by the clauses’s type, the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the typecase, ctypecase, or etypecase form.

These macros differ only in their behavior when no normal-clause matches; specifically:

typecase

If no normal-clause matches, and there is an otherwise-clause, then that otherwise-clause automatically matches; the forms in that clause are evaluated as an implicit progn, and the values it returns are returned as the value of the typecase.

If there is no otherwise-clause, typecase returns nil.

ctypecase

If no normal-clause matches, a correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (or type1 type2 ...). The store-value restart can be used to correct the error.

If the store-value restart is invoked, its argument becomes the new test-key, and is stored in keyplace as if by (setf keyplace test-key). Then ctypecase starts over, considering each clause anew.

If the store-value restart is invoked interactively, the user is prompted for a new test-key to use.

The subforms of keyplace might be evaluated again if none of the cases holds.

etypecase

If no normal-clause matches, a non-correctable error of type type-error is signaled. The offending datum is the test-key and the expected type is type equivalent to (or type1 type2 ...).

Note that in contrast with ctypecase, the caller of etypecase may rely on the fact that etypecase does not return if a normal-clause does not match.

In all three cases, is permissible for more than one clause to specify a matching type, particularly if one is a subtype of another; the earliest applicable clause is chosen.

Examples::

;;; (Note that the parts of this example which use TYPE-OF 
;;;  are implementation-dependent.)
 (defun what-is-it (x)
   (format t "~&~S is ~A.~
           x (typecase x
               (float "a float")
               (null "a symbol, boolean false, or the empty list")
               (list "a list")
               (t (format nil "a(n) ~(~A~)" (type-of x))))))
⇒  WHAT-IS-IT
 (map 'nil #'what-is-it '(nil (a b) 7.0 7 box))
 |>  NIL is a symbol, boolean false, or the empty list.
 |>  (A B) is a list.
 |>  7.0 is a float.
 |>  7 is a(n) integer.
 |>  BOX is a(n) symbol.
⇒  NIL
 (setq x 1/3)
⇒  1/3
 (ctypecase x
     (integer (* x 4))
     (symbol  (symbol-value x)))
 |>  Error: The value of X, 1/3, is neither an integer nor a symbol.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Use value: |>>3.7<<|
 |>  Error: The value of X, 3.7, is neither an integer nor a symbol.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Use value: |>>12<<|
⇒  48
 x ⇒  12

Affected By::

ctypecase and etypecase, since they might signal an error, are potentially affected by existing handlers and *debug-io*.

Exceptional Situations::

ctypecase and etypecase signal an error of type type-error if no normal-clause matches.

The compiler may choose to issue a warning of type style-warning if a clause will never be selected because it is completely shadowed by earlier clauses.

See Also::

case , cond , setf , Generalized Reference

Notes::

(typecase test-key
  {(type {form}*)}*)
≡
(let ((#1=#:g0001 test-key))
  (cond {((typep #1# 'type) {form}*)}*))

The specific error message used by etypecase and ctypecase can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use typecase with an otherwise-clause that explicitly signals an error with an appropriate message.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/make_002decho_002dstream.html0000644000175000017500000000700414360276512017624 0ustar cammcamm make-echo-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.45 make-echo-stream [Function]

make-echo-stream input-stream output-stream ⇒ echo-stream

Arguments and Values::

input-stream—an input stream.

output-stream—an output stream.

echo-stream—an echo stream.

Description::

Creates and returns an echo stream that takes input from input-stream and sends output to output-stream.

Examples::

 (let ((out (make-string-output-stream)))
    (with-open-stream 
        (s (make-echo-stream
            (make-string-input-stream "this-is-read-and-echoed")
            out))
      (read s)
      (format s " * this-is-direct-output")
      (get-output-stream-string out)))
⇒  "this-is-read-and-echoed * this-is-direct-output"

See Also::

echo-stream-input-stream , echo-stream-output-stream, make-two-way-stream

gcl-2.6.14/info/gcl/reinitialize_002dinstance.html0000644000175000017500000001270714360276512020332 0ustar cammcamm reinitialize-instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.4 reinitialize-instance [Standard Generic Function]

Syntax::

reinitialize-instance instance &rest initargs &key &allow-other-keys ⇒ instance

Method Signatures::

reinitialize-instance (instance standard-object) &rest initargs

Arguments and Values::

instance—an object.

initargs—an initialization argument list.

Description::

The generic function reinitialize-instance can be used to change the values of local slots of an instance according to initargs. This generic function can be called by users.

The system-supplied primary method for reinitialize-instance checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. The method then calls the generic function shared-initialize with the following arguments: the instance, nil (which means no slots should be initialized according to their initforms), and the initargs it received.

Side Effects::

The generic function reinitialize-instance changes the values of local slots.

Exceptional Situations::

The system-supplied primary method for reinitialize-instance signals an error if an initarg is supplied that is not declared as valid.

See Also::

Initialize-Instance , Shared-Initialize , update-instance-for-redefined-class , update-instance-for-different-class , slot-boundp , slot-makunbound , Reinitializing an Instance, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments

Notes::

Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for reinitialize-instance or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on reinitialize-instance or shared-initialize is declared as a valid initialization argument name for all classes for which that method is applicable.

gcl-2.6.14/info/gcl/Prevention-of-Name-Conflicts-in-Packages.html0000644000175000017500000001433514360276512023042 0ustar cammcamm Prevention of Name Conflicts in Packages (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction to Packages  

11.1.1.7 Prevention of Name Conflicts in Packages

Within one package, any particular name can refer to at most one symbol. A name conflict is said to occur when there would be more than one candidate symbol. Any time a name conflict is about to occur, a correctable error is signaled.

The following rules apply to name conflicts:

–

Name conflicts are detected when they become possible, that is, when the package structure is altered. Name conflicts are not checked during every name lookup.

–

If the same symbol is accessible to a package through more than one path, there is no name conflict. A symbol cannot conflict with itself. Name conflicts occur only between distinct symbols with the same name (under string=).

–

Every package has a list of shadowing symbols. A shadowing symbol takes precedence over any other symbol of the same name that would otherwise be accessible in the package. A name conflict involving a shadowing symbol is always resolved in favor of the shadowing symbol, without signaling an error (except for one exception involving import). See shadow and shadowing-import.

–

The functions use-package, import, and export check for name conflicts.

–

shadow and shadowing-import never signal a name-conflict error.

–

unuse-package and unexport do not need to do any name-conflict checking. unintern does name-conflict checking only when a symbol being uninterned is a shadowing symbol .

–

Giving a shadowing symbol to unintern can uncover a name conflict that had previously been resolved by the shadowing.

–

Package functions signal name-conflict errors of type package-error before making any change to the package structure. When multiple changes are to be made, it is permissible for the implementation to process each change separately. For example, when export is given a list of symbols, aborting from a name conflict caused by the second symbol in the list might still export the first symbol in the list. However, a name-conflict error caused by export of a single symbol will be signaled before that symbol’s accessibility in any package is changed.

–

Continuing from a name-conflict error must offer the user a chance to resolve the name conflict in favor of either of the candidates. The package structure should be altered to reflect the resolution of the name conflict, via shadowing-import, unintern, or unexport.

–

A name conflict in use-package between a symbol present in the using package and an external symbol of the used package is resolved in favor of the first symbol by making it a shadowing symbol, or in favor of the second symbol by uninterning the first symbol from the using package.

–

A name conflict in export or unintern due to a package’s inheriting two distinct symbols with the same name (under string=) from two other packages can be resolved in favor of either symbol by importing it into the using package and making it a shadowing symbol , just as with use-package.

Previous: , Up: Introduction to Packages  

gcl-2.6.14/info/gcl/Applying-method-combination-to-the-sorted-list-of-applicable-methods.html0000644000175000017500000001155214360276512030530 0ustar cammcamm Applying method combination to the sorted list of applicable methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.4 Applying method combination to the sorted list of applicable methods

In the simple case—if standard method combination is used and all applicable methods are primary methods—the effective method is the most specific method. That method can call the next most specific method by using the function call-next-method. The method that call-next-method will call is referred to as the next method . The predicate next-method-p tests whether a next method exists. If call-next-method is called and there is no next most specific method, the generic function no-next-method is invoked.

In general, the effective method is some combination of the applicable methods. It is described by a form that contains calls to some or all of the applicable methods, returns the value or values that will be returned as the value or values of the generic function, and optionally makes some of the methods accessible by means of call-next-method.

The role of each method in the effective method is determined by its qualifiers and the specificity of the method. A qualifier serves to mark a method, and the meaning of a qualifier is determined by the way that these marks are used by this step of the procedure. If an applicable method has an unrecognized qualifier, this step signals an error and does not include that method in the effective method.

When standard method combination is used together with qualified methods, the effective method is produced as described in Standard Method Combination.

Another type of method combination can be specified by using the :method-combination option of defgeneric or of any of the other operators that specify generic function options. In this way this step of the procedure can be customized.

New types of method combination can be defined by using the define-method-combination macro.

Next: , Previous: , Up: Method Selection and Combination  

gcl-2.6.14/info/gcl/Lambda-Expressions.html0000644000175000017500000000513614360276512017066 0ustar cammcamm Lambda Expressions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.3 Lambda Expressions

In a lambda expression, the body is evaluated in a lexical environment that is formed by adding the binding of each parameter in the lambda list with the corresponding value from the arguments to the current lexical environment.

For further discussion of how bindings are established based on the lambda list, see Lambda Lists.

The body of a lambda expression is an implicit progn; the values it returns are returned by the lambda expression.

gcl-2.6.14/info/gcl/Other-Compound-Forms-as-Places.html0000644000175000017500000000612114360276512021116 0ustar cammcamm Other Compound Forms as Places (ANSI and GNU Common Lisp Document)

Previous: , Up: Kinds of Places  

5.1.2.9 Other Compound Forms as Places

For any other compound form for which the operator is a symbol f, the setf form expands into a call to the function named (setf f). The first argument in the newly constructed function form is newvalue and the remaining arguments are the remaining elements of place. This expansion occurs regardless of whether f or (setf f) is defined as a function locally, globally, or not at all. For example,

(setf (f arg1 arg2 ...) new-value)

expands into a form with the same effect and value as 

 (let ((#:temp-1 arg1)          ;force correct order of evaluation
       (#:temp-2 arg2)
       ...
       (#:temp-0 new-value))
   (funcall (function (setf f)) #:temp-0 #:temp-1 #:temp-2...))

A function named (setf f) must return its first argument as its only value in order to preserve the semantics of setf.

gcl-2.6.14/info/gcl/synonym_002dstream_002dsymbol.html0000644000175000017500000000537614360276512021024 0ustar cammcamm synonym-stream-symbol (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.39 synonym-stream-symbol [Function]

synonym-stream-symbol synonym-stream ⇒ symbol

Arguments and Values::

synonym-stream—a synonym stream.

symbol—a symbol.

Description::

Returns the symbol whose symbol-value the synonym-stream is using.

See Also::

make-synonym-stream

gcl-2.6.14/info/gcl/throw.html0000644000175000017500000001345414360276512014533 0ustar cammcamm throw (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.28 throw [Special Operator]

throw tag result-form ⇒ #<NoValue>

Arguments and Values::

tag—a catch tag; evaluated.

result-form—a form; evaluated as described below.

Description::

throw causes a non-local control transfer to a catch whose tag is eq to tag.

Tag is evaluated first to produce an object called the throw tag; then result-form is evaluated, and its results are saved. If the result-form produces multiple values, then all the values are saved. The most recent outstanding catch whose tag is eq to the throw tag is exited; the saved results are returned as the value or values of catch.

The transfer of control initiated by throw is performed as described in Transfer of Control to an Exit Point.

Examples::

 (catch 'result
    (setq i 0 j 0)
    (loop (incf j 3) (incf i)
          (if (= i 3) (throw 'result (values i j))))) ⇒  3, 9


 (catch nil 
   (unwind-protect (throw nil 1)
     (throw nil 2))) ⇒  2

The consequences of the following are undefined because the catch of b is passed over by the first throw, hence portable programs must assume that its dynamic extent is terminated. The binding of the catch tag is not yet disestablished and therefore it is the target of the second throw. 

 (catch 'a
   (catch 'b
     (unwind-protect (throw 'a 1)
       (throw 'b 2))))

The following prints “The inner catch returns :SECOND-THROW” and then returns :outer-catch. 

 (catch 'foo
         (format t "The inner catch returns ~s.~
                 (catch 'foo
                     (unwind-protect (throw 'foo :first-throw)
                         (throw 'foo :second-throw))))
         :outer-catch)
 |>  The inner catch returns :SECOND-THROW
⇒  :OUTER-CATCH

Exceptional Situations::

If there is no outstanding catch tag that matches the throw tag, no unwinding of the stack is performed, and an error of type control-error is signaled. When the error is signaled, the dynamic environment is that which was in force at the point of the throw.

See Also::

block , catch , return-from , unwind-protect , Evaluation

Notes::

catch and throw are normally used when the exit point must have dynamic scope (e.g., the throw is not lexically enclosed by the catch), while block and return are used when lexical scope is sufficient.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/makunbound.html0000644000175000017500000000613514360276512015531 0ustar cammcamm makunbound (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.18 makunbound [Function]

makunbound symbol ⇒ symbol

Arguments and Values::

symbol—a symbol

Description::

Makes the symbol be unbound, regardless of whether it was previously bound.

Examples::

 (setf (symbol-value 'a) 1)
 (boundp 'a) ⇒  true
 a ⇒  1
 (makunbound 'a) ⇒  A
 (boundp 'a) ⇒  false

Side Effects::

The value cell of symbol is modified.

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

boundp , fmakunbound

gcl-2.6.14/info/gcl/symbol_002dname.html0000644000175000017500000000575614360276512016271 0ustar cammcamm symbol-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.11 symbol-name [Function]

symbol-name symbol ⇒ name

Arguments and Values::

symbol—a symbol.

name—a string.

Description::

symbol-name returns the name of symbol.

The consequences are undefined if name is ever modified.

Examples::

 (symbol-name 'temp) ⇒  "TEMP" 
 (symbol-name :start) ⇒  "START"
 (symbol-name (gensym)) ⇒  "G1234" ;for example

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

gcl-2.6.14/info/gcl/synonym_002dstream.html0000644000175000017500000000607414360276512017045 0ustar cammcamm synonym-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.7 synonym-stream [System Class]

Class Precedence List::

synonym-stream, stream, t

Description::

A stream that is an alias for another stream, which is the value of a dynamic variable whose name is the synonym stream symbol of the synonym stream.

Any operations on a synonym stream will be performed on the stream that is then the value of the dynamic variable named by the synonym stream symbol. If the value of the variable should change, or if the variable should be bound, then the stream will operate on the new value of the variable.

See Also::

make-synonym-stream , synonym-stream-symbol

gcl-2.6.14/info/gcl/Whitespace-Characters.html0000644000175000017500000000447014360276512017537 0ustar cammcamm Whitespace Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.9 Whitespace Characters

Whitespace_2 characters are used to separate tokens.

Space and newline are whitespace_2 characters in standard syntax.

gcl-2.6.14/info/gcl/string-_0028System-Class_0029.html0000644000175000017500000000727114360276512020346 0ustar cammcamm string (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.1 string [System Class]

Class Precedence List::

string, vector, array, sequence, t

Description::

A string is a specialized vector whose elements are of type character or a subtype of type character. When used as a type specifier for object creation, string means (vector character).

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(string{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *.

Compound Type Specifier Description::

This denotes the union of all types (array c (size)) for all subtypes c of character; that is, the set of strings of size size.

See Also::

String Concepts, Double-Quote, Printing Strings

gcl-2.6.14/info/gcl/print_002dnot_002dreadable_002dobject.html0000644000175000017500000000536414360276512022114 0ustar cammcamm print-not-readable-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.30 print-not-readable-object [Function]

print-not-readable-object condition ⇒ object

Arguments and Values::

condition—a condition of type print-not-readable.

object—an object.

Description::

Returns the object that could not be printed readably in the situation represented by condition.

See Also::

print-not-readable, Conditions

gcl-2.6.14/info/gcl/next_002dmethod_002dp.html0000644000175000017500000000672714360276512017206 0ustar cammcamm next-method-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.29 next-method-p [Local Function]

Syntax::

next-method-p <no arguments> ⇒ generalized-boolean

Arguments and Values::

generalized-boolean—a generalized boolean.

Description::

The locally defined function next-method-p can be used

within the body forms (but not the lambda list)

defined by a method-defining form to determine whether a next method exists.

The function next-method-p has lexical scope and indefinite extent.

Whether or not next-method-p is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of next-method-p are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use next-method-p outside of a method-defining form are undefined.

See Also::

call-next-method , defmethod , call-method

gcl-2.6.14/info/gcl/The-_0022Arguments_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000542514360276512024604 0ustar cammcamm The "Arguments" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.2 The "Arguments" Section of a Dictionary Entry

This information describes the syntax information of entries such as those for declarations and special expressions which are never evaluated as forms, and so do not return values.

gcl-2.6.14/info/gcl/Printer.html0000644000175000017500000000503614360276512015010 0ustar cammcamm Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

22 Printer

• The Lisp Printer  
• The Lisp Pretty Printer  
• Formatted Output  
• Printer Dictionary  
gcl-2.6.14/info/gcl/Examples-of-Associativity-and-Commutativity-in-Numeric-Operations.html0000644000175000017500000001004114360276512030127 0ustar cammcamm Examples of Associativity and Commutativity in Numeric Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numeric Operations  

12.1.1.2 Examples of Associativity and Commutativity in Numeric Operations

Consider the following expression, in which we assume that 1.0 and 1.0e-15 both denote single floats: 

 (+ 1/3 2/3 1.0d0 1.0 1.0e-15)

One conforming implementation might process the arguments from left to right, first adding 1/3 and 2/3 to get 1, then converting that to a double float for combination with 1.0d0, then successively converting and adding 1.0 and 1.0e-15.

Another conforming implementation might process the arguments from right to left, first performing a single float addition of 1.0 and 1.0e-15 (perhaps losing accuracy in the process), then converting the sum to a double float and adding 1.0d0, then converting 2/3 to a double float and adding it, and then converting 1/3 and adding that.

A third conforming implementation might first scan all the arguments, process all the rationals first to keep that part of the computation exact, then find an argument of the largest floating-point format among all the arguments and add that, and then add in all other arguments, converting each in turn (all in a perhaps misguided attempt to make the computation as accurate as possible).

In any case, all three strategies are legitimate.

A conforming program could control the order by writing, for example, 

 (+ (+ 1/3 2/3) (+ 1.0d0 1.0e-15) 1.0)
gcl-2.6.14/info/gcl/Shorthand-notation-for-Type-Declarations.html0000644000175000017500000000436214360276512023262 0ustar cammcamm Shorthand notation for Type Declarations (ANSI and GNU Common Lisp Document)

Previous: , Up: Declaration Identifiers  

3.3.3.1 Shorthand notation for Type Declarations

A type specifier can be used as a declaration identifier. (type-specifier {var}*) is taken as shorthand for (type type-specifier {var}*).

gcl-2.6.14/info/gcl/pprint_002dnewline.html0000644000175000017500000001744014360276512017012 0ustar cammcamm pprint-newline (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.8 pprint-newline [Function]

pprint-newline kind &optional stream ⇒ nil

Arguments and Values::

kind—one of :linear, :fill, :miser, or :mandatory.

stream—a stream designator. The default is standard output.

Description::

If stream is a pretty printing stream and the value of *print-pretty* is true, a line break is inserted in the output when the appropriate condition below is satisfied; otherwise, pprint-newline has no effect.

Kind specifies the style of conditional newline. This parameter is treated as follows:

:linear

This specifies a “linear-style” conditional newline.

A line break is inserted if and only if the immediately containing section cannot be printed on one line. The effect of this is that line breaks are either inserted at every linear-style conditional newline in a logical block or at none of them.

:miser

This specifies a “miser-style” conditional newline.

A line break is inserted if and only if the immediately containing section cannot be printed on one line and miser style is in effect in the immediately containing logical block. The effect of this is that miser-style conditional newlines act like linear-style conditional newlines, but only when miser style is in effect. Miser style is in effect for a logical block if and only if the starting position of the logical block is less than or equal to *print-miser-width* ems from the right margin.

:fill

This specifies a “fill-style” conditional newline.

A line break is inserted if and only if either (a) the following section cannot be printed on the end of the current line, (b) the preceding section was not printed on a single line, or (c) the immediately containing section cannot be printed on one line and miser style is in effect in the immediately containing logical block. If a logical block is broken up into a number of subsections by fill-style conditional newlines, the basic effect is that the logical block is printed with as many subsections as possible on each line. However, if miser style is in effect, fill-style conditional newlines act like linear-style conditional newlines.

:mandatory

This specifies a “mandatory-style” conditional newline.

A line break is always inserted. This implies that none of the containing sections can be printed on a single line and will therefore trigger the insertion of line breaks at linear-style conditional newlines in these sections.

When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are omitted from the output and indentation is introduced at the beginning of the next line. By default, the indentation causes the following line to begin in the same horizontal position as the first character in the immediately containing logical block. (The indentation can be changed via pprint-indent.)

There are a variety of ways unconditional newlines can be introduced into the output (i.e., via terpri or by printing a string containing a newline character). As with mandatory conditional newlines, this prevents any of the containing sections from being printed on one line. In general, when an unconditional newline is encountered, it is printed out without suppression of the preceding blanks and without any indentation following it. However, if a per-line prefix has been specified (see pprint-logical-block), this prefix will always be printed no matter how a newline originates.

Examples::

See Examples of using the Pretty Printer.

Side Effects::

Output to stream.

Affected By::

*print-pretty*, *print-miser*. The presence of containing logical blocks. The placement of newlines and conditional newlines.

Exceptional Situations::

An error of type type-error is signaled if kind is not one of :linear, :fill, :miser, or :mandatory.

See Also::

Tilde Underscore-> Conditional Newline, Examples of using the Pretty Printer

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Purpose-of-Compiler-Macros.html0000644000175000017500000000751114360276512020416 0ustar cammcamm Purpose of Compiler Macros (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.2 Purpose of Compiler Macros

The purpose of the compiler macro facility is to permit selective source code transformations as optimization advice to the compiler. When a compound form is being processed (as by the compiler), if the operator names a compiler macro then the compiler macro function may be invoked on the form, and the resulting expansion recursively processed in preference to performing the usual processing on the original form according to its normal interpretation as a function form or macro form.

A compiler macro function, like a macro function, is a function of two arguments: the entire call form and the environment. Unlike an ordinary macro function, a compiler macro function can decline to provide an expansion merely by returning a value that is the same as the original form. The consequences are undefined if a compiler macro function destructively modifies any part of its form argument.

The form passed to the compiler macro function can either be a list whose car is the function name, or a list whose car is funcall and whose cadr is a list (function name); note that this affects destructuring of the form argument by the compiler macro function. define-compiler-macro arranges for destructuring of arguments to be performed correctly for both possible formats.

When compile-file chooses to expand a top level form that is a compiler macro form, the expansion is also treated as a top level form for the purposes of eval-when processing; see Processing of Top Level Forms.

gcl-2.6.14/info/gcl/copy_002dlist.html0000644000175000017500000000764614360276512015771 0ustar cammcamm copy-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.14 copy-list [Function]

copy-list list ⇒ copy

Arguments and Values::

list—a proper list or a dotted list.

copy—a list.

Description::

Returns a copy of list. If list is a dotted list, the resulting list will also be a dotted list.

Only the list structure of list is copied; the elements of the resulting list are the same as the corresponding elements of the given list.

Examples::

 (setq lst (list 1 (list 2 3))) ⇒  (1 (2 3))
 (setq slst lst) ⇒  (1 (2 3))
 (setq clst (copy-list lst)) ⇒  (1 (2 3))
 (eq slst lst) ⇒  true
 (eq clst lst) ⇒  false
 (equal clst lst) ⇒  true
 (rplaca lst "one") ⇒  ("one" (2 3))
 slst ⇒  ("one" (2 3))
 clst ⇒  (1 (2 3))
 (setf (caadr lst) "two") ⇒  "two"
 lst ⇒  ("one" ("two" 3))
 slst ⇒  ("one" ("two" 3))
 clst ⇒  (1 ("two" 3))

Exceptional Situations::

The consequences are undefined if list is a circular list.

See Also::

copy-alist , copy-seq , copy-tree

Notes::

The copy created is equal to list, but not eq.

gcl-2.6.14/info/gcl/count.html0000644000175000017500000001252614360276512014517 0ustar cammcamm count (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.10 count, count-if, count-if-not [Function]

count item sequence &key from-end start end key test test-not ⇒ n

count-if predicate sequence &key from-end start end key ⇒ n

count-if-not predicate sequence &key from-end start end key ⇒ n

Arguments and Values::

item—an object.

sequence—a proper sequence.

predicate—a designator for a function of one argument that returns a generalized boolean.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

key—a designator for a function of one argument, or nil.

n—a non-negative integer less than or equal to the length of sequence.

Description::

count, count-if, and count-if-not count and return the number of elements in the sequence bounded by start and end that satisfy the test.

The from-end has no direct effect on the result. However, if from-end is true, the elements of sequence will be supplied as arguments to the test, test-not, and key in reverse order, which may change the side-effects, if any, of those functions.

Examples::

 (count #\a "how many A's are there in here?") ⇒  2
 (count-if-not #'oddp '((1) (2) (3) (4)) :key #'car) ⇒  2
 (count-if #'upper-case-p "The Crying of Lot 49" :start 4) ⇒  2

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

Rules about Test Functions,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

The function count-if-not is deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/concatenate.html0000644000175000017500000001216114360276512015646 0ustar cammcamm concatenate (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.20 concatenate [Function]

concatenate result-type &rest sequences ⇒ result-sequence

Arguments and Values::

result-type—a sequence type specifier.

sequences—a sequence.

result-sequence—a proper sequence of type result-type.

Description::

concatenate returns a sequence that contains all the individual elements of all the sequences in the order that they are supplied. The sequence is of type result-type, which must be a subtype of type sequence.

All of the sequences are copied from; the result does not share any structure with any of the sequences. Therefore, if only one sequence is provided and it is of type result-type, concatenate is required to copy sequence rather than simply returning it.

It is an error if any element of the sequences cannot be an element of the sequence result.

[Reviewer Note by Barmar: Should signal?]

If the result-type is a subtype of list, the result will be a list.

If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled.

Examples::

(concatenate 'string "all" " " "together" " " "now") ⇒  "all together now"
(concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011)
⇒  (#\A #\B #\C D E F 1 2 3 1 0 1 1)
(concatenate 'list) ⇒  NIL

  (concatenate '(vector * 2) "a" "bc") should signal an error

Exceptional Situations::

An error is signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector.

An error of type type-error should be signaled if result-type specifies the number of elements and the sum of sequences is different from that number.

See Also::

append

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Syntax-of-a-Complex.html0000644000175000017500000000603714360276512017102 0ustar cammcamm Syntax of a Complex (ANSI and GNU Common Lisp Document)

Previous: , Up: Constructing Numbers from Tokens  

2.3.2.5 Syntax of a Complex

A complex has a Cartesian structure, with a real part and an imaginary part each of which is a

real.

The parts of a complex are not necessarily floats but both parts must be of the same type:

[Editorial Note by KMP: This is not the same as saying they must be the same type. Maybe we mean they are of the same ‘precision’ or ‘format’? GLS had suggestions which are not yet merged.] either both are rationals, or both are of the same float subtype. When constructing a complex, if the specified parts are not the same type, the parts are converted to be the same type internally (i.e., the rational part is converted to a float). An object of type (complex rational) is converted internally and represented thereafter as a rational if its imaginary part is an integer whose value is 0.

For further information, see Sharpsign C and Printing Complexes.

gcl-2.6.14/info/gcl/Sequences-Dictionary.html0000644000175000017500000001245714360276512017430 0ustar cammcamm Sequences Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Sequences  

17.3 Sequences Dictionary

• sequence  
• copy-seq  
• elt  
• fill  
• make-sequence  
• subseq  
• map  
• map-into  
• reduce  
• count  
• length  
• reverse  
• sort  
• find  
• position  
• search  
• mismatch  
• replace  
• substitute  
• concatenate  
• merge  
• remove  
• remove-duplicates  
gcl-2.6.14/info/gcl/Tilde-W_002d_003e-Write.html0000644000175000017500000000540014360276512017171 0ustar cammcamm Tilde W-> Write (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Printer Operations  

22.3.4.3 Tilde W: Write

An argument, any object, is printed obeying every printer control variable (as by write). In addition, ~W interacts correctly with depth abbreviation, by not resetting the depth counter to zero. ~W does not accept parameters. If given the colon modifier, ~W binds *print-pretty* to true. If given the at-sign modifier, ~W binds *print-level* and *print-length* to nil.

~W provides automatic support for the detection of circularity and sharing. If the value of *print-circle* is not nil and ~W is applied to an argument that is a circular (or shared) reference, an appropriate #n# marker is inserted in the output instead of printing the argument.

gcl-2.6.14/info/gcl/Examples-of-Printer-Behavior.html0000644000175000017500000000653114360276512020724 0ustar cammcamm Examples of Printer Behavior (ANSI and GNU Common Lisp Document)

Previous: , Up: The Lisp Printer  

22.1.4 Examples of Printer Behavior

 (let ((*print-escape* t)) (fresh-line) (write #\a))
 |>  #\a
⇒  #\a
 (let ((*print-escape* nil) (*print-readably* nil))
   (fresh-line)
   (write #\a))
 |>  a
⇒  #\a
 (progn (fresh-line) (prin1 #\a))
 |>  #\a
⇒  #\a
 (progn (fresh-line) (print #\a))
 |>  
 |>  #\a
⇒  #\a
 (progn (fresh-line) (princ #\a))
 |>  a
⇒  #\a

 (dolist (val '(t nil))
   (let ((*print-escape* val) (*print-readably* val))
     (print '#\a) 
     (prin1 #\a) (write-char #\Space)
     (princ #\a) (write-char #\Space)
     (write #\a)))
 |>  #\a #\a a #\a
 |>  #\a #\a a a
⇒  NIL

 (progn (fresh-line) (write '(let ((a 1) (b 2)) (+ a b))))
 |>  (LET ((A 1) (B 2)) (+ A B))
⇒  (LET ((A 1) (B 2)) (+ A B))

 (progn (fresh-line) (pprint '(let ((a 1) (b 2)) (+ a b))))
 |>  (LET ((A 1)
 |>        (B 2))               
 |>    (+ A B))
⇒  (LET ((A 1) (B 2)) (+ A B))

 (progn (fresh-line) 
        (write '(let ((a 1) (b 2)) (+ a b)) :pretty t))
 |>  (LET ((A 1)
 |>        (B 2))
 |>    (+ A B))                 
⇒  (LET ((A 1) (B 2)) (+ A B))

 (with-output-to-string (s)  
    (write 'write :stream s)
    (prin1 'prin1 s))
⇒  "WRITEPRIN1"
gcl-2.6.14/info/gcl/unexport.html0000644000175000017500000001040114360276512015241 0ustar cammcamm unexport (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.14 unexport [Function]

unexport symbols &optional package ⇒ t

Arguments and Values::

symbols—a designator for a list of symbols.

package—a package designator.

The default is the current package.

Description::

unexport reverts external symbols in package to internal status; it undoes the effect of export.

unexport works only on symbols present in package, switching them back to internal status. If unexport is given a symbol that is already accessible as an internal symbol in package, it does nothing.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (export (intern "CONTRABAND" (make-package 'temp)) 'temp) ⇒  T
 (find-symbol "CONTRABAND") ⇒  NIL, NIL 
 (use-package 'temp) ⇒  T 
 (find-symbol "CONTRABAND") ⇒  CONTRABAND, :INHERITED
 (unexport 'contraband 'temp) ⇒  T
 (find-symbol "CONTRABAND") ⇒  NIL, NIL

Side Effects::

Package system is modified.

Affected By::

Current state of the package system.

Exceptional Situations::

If unexport is given a symbol not accessible in package at all, an error of type package-error is signaled.

The consequences are undefined if package is the KEYWORD package or the COMMON-LISP package.

See Also::

export , Package Concepts

gcl-2.6.14/info/gcl/Packages.html0000644000175000017500000000433614360276512015105 0ustar cammcamm Packages (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

11 Packages

• Package Concepts  
• Packages Dictionary  
gcl-2.6.14/info/gcl/Sharpsign-Right_002dParenthesis.html0000644000175000017500000000416114360276512021327 0ustar cammcamm Sharpsign Right-Parenthesis (ANSI and GNU Common Lisp Document)

Previous: , Up: Sharpsign  

2.4.8.25 Sharpsign Right-Parenthesis

This is not valid reader syntax.

The Lisp reader will signal an error

of type reader-error

upon encountering #).

gcl-2.6.14/info/gcl/Type-Relationships.html0000644000175000017500000001024114360276512017122 0ustar cammcamm Type Relationships (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types  

4.2.2 Type Relationships

*

The types cons, symbol, array, number, character, hash-table,

function,

readtable, package, pathname, stream, random-state, condition, restart, and any single other type created by defstruct,

define-condition,

or defclass are pairwise disjoint, except for type relations explicitly established by specifying superclasses in defclass

or define-condition

or the :include option of destruct.

*

Any two types created by defstruct are disjoint unless one is a supertype of the other by virtue of the defstruct :include option.

[Editorial Note by KMP: The comments in the source say gray suggested some change from “common superclass” to “common subclass” in the following, but the result looks suspicious to me.]

*

Any two distinct classes created by defclass or define-condition are disjoint unless they have a common subclass or one class is a subclass of the other.

*

An implementation may be extended to add other subtype relationships between the specified types, as long as they do not violate the type relationships and disjointness requirements specified here. An implementation may define additional types that are subtypes or supertypes of any specified types, as long as each additional type is a subtype of type t and a supertype of type nil and the disjointness requirements are not violated.

At the discretion of the implementation, either standard-object or structure-object might appear in any class precedence list for a system class that does not already specify either standard-object or structure-object. If it does, it must precede the class t and follow all other standardized classes.

gcl-2.6.14/info/gcl/Loop-Keywords.html0000644000175000017500000000575314360276512016111 0ustar cammcamm Loop Keywords (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.4 Loop Keywords

Loop keywords are not true keywords_1; they are special symbols, recognized by name rather than object identity, that are meaningful only to the loop facility. A loop keyword is a symbol but is recognized by its name (not its identity), regardless of the packages in which it is accessible.

In general, loop keywords are not external symbols of the COMMON-LISP package, except in the coincidental situation that a symbol with the same name as a loop keyword was needed for some other purpose in Common Lisp. For example, there is a symbol in the COMMON-LISP package whose name is "UNLESS" but not one whose name is "UNTIL".

If no loop keywords are supplied in a loop form, the Loop Facility executes the loop body repeatedly; see Simple Loop.

gcl-2.6.14/info/gcl/load_002dtime_002dvalue.html0000644000175000017500000002175414360276512017477 0ustar cammcamm load-time-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.6 load-time-value [Special Operator]

load-time-value form &optional read-only-p ⇒ object

Arguments and Values::

form—a form; evaluated as described below.

read-only-p—a boolean; not evaluated.

object—the primary value resulting from evaluating form.

Description::

load-time-value provides a mechanism for delaying evaluation of form until the expression is in the run-time environment; see Compilation.

Read-only-p designates whether the result can be considered a constant object. If t, the result is a read-only quantity that can, if appropriate to the implementation, be copied into read-only space and/or coalesced with similar constant objects from other programs. If nil (the default), the result must be neither copied nor coalesced; it must be considered to be potentially modifiable data.

If a load-time-value expression is processed by compile-file, the compiler performs its normal semantic processing (such as macro expansion and translation into machine code) on form, but arranges for the execution of form to occur at load time in a null lexical environment, with the result of this evaluation then being treated as a literal object at run time. It is guaranteed that the evaluation of form will take place only once when the file is loaded, but the order of evaluation with respect to the evaluation of top level forms in the file is implementation-dependent.

If a load-time-value expression appears within a function compiled with compile, the form is evaluated at compile time in a null lexical environment. The result of this compile-time evaluation is treated as a literal object in the compiled code.

If a load-time-value expression is processed by eval, form is evaluated in a null lexical environment, and one value is returned. Implementations that implicitly compile (or partially compile) expressions processed by eval might evaluate form only once, at the time this compilation is performed.

If the same list (load-time-value form) is evaluated or compiled more than once, it is implementation-dependent whether form is evaluated only once or is evaluated more than once. This can happen both when an expression being evaluated or compiled shares substructure, and when the same form is processed by eval or compile multiple times. Since a load-time-value expression can be referenced in more than one place and can be evaluated multiple times by eval, it is implementation-dependent whether each execution returns a fresh object or returns the same object as some other execution. Users must use caution when destructively modifying the resulting object.

If two lists (load-time-value form) that are the same under equal but are not identical are evaluated or compiled, their values always come from distinct evaluations of form. Their values may not be coalesced unless read-only-p is t.

Examples::

;;; The function INCR1 always returns the same value, even in different images.
;;; The function INCR2 always returns the same value in a given image, 
;;; but the value it returns might vary from image to image.
(defun incr1 (x) (+ x #.(random 17)))
(defun incr2 (x) (+ x (load-time-value (random 17))))

;;; The function FOO1-REF references the nth element of the first of 
;;; the *FOO-ARRAYS* that is available at load time.  It is permissible for
;;; that array to be modified (e.g., by SET-FOO1-REF); FOO1-REF will see the
;;; updated values.
(defvar *foo-arrays* (list (make-array 7) (make-array 8)))
(defun foo1-ref (n) (aref (load-time-value (first *my-arrays*) nil) n))
(defun set-foo1-ref (n val) 
  (setf (aref (load-time-value (first *my-arrays*) nil) n) val))

;;; The function BAR1-REF references the nth element of the first of 
;;; the *BAR-ARRAYS* that is available at load time.  The programmer has
;;; promised that the array will be treated as read-only, so the system 
;;; can copy or coalesce the array.
(defvar *bar-arrays* (list (make-array 7) (make-array 8)))
(defun bar1-ref (n) (aref (load-time-value (first *my-arrays*) t) n))

;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced
;;; even though NIL was specified, because the object was already read-only
;;; when it was written as a literal vector rather than created by a constructor.
;;; User programs must treat the vector v as read-only.
(defun baz-ref (n)
  (let ((v (load-time-value #(A B C) nil)))
    (values (svref v n) v)))

;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced
;;; even though NIL was specified in the outer situation because T was specified
;;; in the inner situation.  User programs must treat the vector v as read-only.
(defun baz-ref (n)
  (let ((v (load-time-value (load-time-value (vector 1 2 3) t) nil)))
    (values (svref v n) v)))

See Also::

compile-file , compile , eval , Minimal Compilation, Compilation

Notes::

load-time-value must appear outside of quoted structure in a “for evaluation” position. In situations which would appear to call for use of load-time-value within a quoted structure, the backquote reader macro is probably called for; see Backquote.

Specifying nil for read-only-p is not a way to force an object to become modifiable if it has already been made read-only. It is only a way to say that, for an object that is modifiable, this operation is not intended to make that object read-only.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Packages-Dictionary.html0000644000175000017500000001522014360276512017202 0ustar cammcamm Packages Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Packages  

11.2 Packages Dictionary

• package  
• export  
• find-symbol  
• find-package  
• find-all-symbols  
• import  
• list-all-packages  
• rename-package  
• shadow  
• shadowing-import  
• delete-package  
• make-package  
• with-package-iterator  
• unexport  
• unintern  
• in-package  
• unuse-package  
• use-package  
• defpackage  
• do-symbols  
• intern  
• package-name  
• package-nicknames  
• package-shadowing-symbols  
• package-use-list  
• package-used-by-list  
• packagep  
• *package*  
• package-error  
• package-error-package  
gcl-2.6.14/info/gcl/formatter.html0000644000175000017500000000717514360276512015376 0ustar cammcamm formatter (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.2 formatter [Macro]

formatter control-string ⇒ function

Arguments and Values::

control-string—a format string; not evaluated.

function—a function.

Description::

Returns a function which has behavior equivalent to: 

  #'(lambda (*standard-output* &rest arguments)
      (apply #'format t control-string arguments)
      arguments-tail)

where arguments-tail is either the tail of arguments which has as its car the argument that would be processed next if there were more format directives in the control-string, or else nil if no more arguments follow the most recently processed argument.

Examples::

(funcall (formatter "~&~A~A") *standard-output* 'a 'b 'c)
 |>  AB
⇒  (C)

(format t (formatter "~&~A~A") 'a 'b 'c)
 |>  AB
⇒  NIL

Exceptional Situations::

Might signal an error (at macro expansion time or at run time) if the argument is not a valid format string.

See Also::

format

gcl-2.6.14/info/gcl/simple_002dbit_002dvector_002dp.html0000644000175000017500000000607114360276512020757 0ustar cammcamm simple-bit-vector-p (ANSI and GNU Common Lisp Document)

Previous: , Up: Arrays Dictionary  

15.2.36 simple-bit-vector-p [Function]

simple-bit-vector-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type simple-bit-vector; otherwise, returns false.

Examples::

 (simple-bit-vector-p (make-array 6)) ⇒  false
 (simple-bit-vector-p #*) ⇒  true

See Also::

simple-vector-p

Notes::

 (simple-bit-vector-p object) ≡ (typep object 'simple-bit-vector)
gcl-2.6.14/info/gcl/append.html0000644000175000017500000000666314360276512014643 0ustar cammcamm append (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.26 append [Function]

append &rest lists ⇒ result

Arguments and Values::

list—each must be a proper list except the last, which may be any object.

result—an object. This will be a list unless the last list was not a list and all preceding lists were null.

Description::

append returns a new list that is the concatenation of the copies. lists are left unchanged; the list structure of each of lists except the last is copied. The last argument is not copied; it becomes the cdr of the final dotted pair of the concatenation of the preceding lists, or is returned directly if there are no preceding non-empty lists.

Examples::

 (append '(a b c) '(d e f) '() '(g)) ⇒  (A B C D E F G)
 (append '(a b c) 'd) ⇒  (A B C . D)
 (setq lst '(a b c)) ⇒  (A B C)
 (append lst '(d)) ⇒  (A B C D)
 lst ⇒  (A B C)
 (append) ⇒  NIL
 (append 'a) ⇒  A

See Also::

nconc , concatenate

gcl-2.6.14/info/gcl/two_002dway_002dstream_002dinput_002dstream.html0000644000175000017500000000604214360276512023151 0ustar cammcamm two-way-stream-input-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.43 two-way-stream-input-stream, two-way-stream-output-stream

[Function]

two-way-stream-input-stream two-way-stream ⇒ input-stream

two-way-stream-output-stream two-way-stream ⇒ output-stream

Arguments and Values::

two-way-stream—a two-way stream.

input-stream—an input stream.

output-stream—an output stream.

Description::

two-way-stream-input-stream returns the stream from which two-way-stream receives input.

two-way-stream-output-stream returns the stream to which two-way-stream sends output.

gcl-2.6.14/info/gcl/Notes-about-the-Implementation-of-Compiler-Macros.html0000644000175000017500000000620014360276512024714 0ustar cammcamm Notes about the Implementation of Compiler Macros (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.5 Notes about the Implementation of Compiler Macros

Although it is technically permissible, as described above, for eval to treat compiler macros in the same situations as compiler might, this is not necessarily a good idea in interpreted implementations.

Compiler macros exist for the purpose of trading compile-time speed for run-time speed. Programmers who write compiler macros tend to assume that the compiler macros can take more time than normal functions and macros in order to produce code which is especially optimal for use at run time. Since eval in an interpreted implementation might perform semantic analysis of the same form multiple times, it might be inefficient in general for the implementation to choose to call compiler macros on every such evaluation.

Nevertheless, the decision about what to do in these situations is left to each implementation.

gcl-2.6.14/info/gcl/aref.html0000644000175000017500000001040514360276512014276 0ustar cammcamm aref (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.10 aref [Accessor]

aref array &rest subscripts ⇒ element

(setf ( aref array &rest subscripts) new-element)

Arguments and Values::

array—an array.

subscripts—a list of valid array indices for the array.

element, new-element—an object.

Description::

Accesses the array element specified by the subscripts. If no subscripts are supplied and array is zero rank, aref accesses the sole element of array.

aref ignores fill pointers. It is permissible to use aref to access any array element, whether active or not.

Examples::

If the variable foo names a 3-by-5 array, then the first index could be 0, 1, or 2, and then second index could be 0, 1, 2, 3, or 4. The array elements can be referred to by using the function aref; for example, (aref foo 2 1) refers to element (2, 1) of the array. 

 (aref (setq alpha (make-array 4)) 3) ⇒  implementation-dependent
 (setf (aref alpha 3) 'sirens) ⇒  SIRENS
 (aref alpha 3) ⇒  SIRENS
 (aref (setq beta (make-array '(2 4) 
                    :element-type '(unsigned-byte 2)
                    :initial-contents '((0 1 2 3) (3 2 1 0))))
        1 2) ⇒  1
 (setq gamma '(0 2))
 (apply #'aref beta gamma) ⇒  2
 (setf (apply #'aref beta gamma) 3) ⇒  3
 (apply #'aref beta gamma) ⇒  3
 (aref beta 0 2) ⇒  3

See Also::

bit (Array) , char , elt , row-major-aref , svref ,

Compiler Terminology

gcl-2.6.14/info/gcl/ftype.html0000644000175000017500000001007514360276512014513 0ustar cammcamm ftype (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.23 ftype [Declaration]

Syntax::

(ftype type {function-name}*)

Arguments::

function-name—a function name.

type—a type specifier.

Valid Context::

declaration or proclamation

Binding Types Affected::

function

Description::

Specifies that the functions named by function-names are of the functional type type. For example: 

 (declare (ftype (function (integer list) t) ith)
          (ftype (function (number) float) sine cosine))

If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition. ftype declarations never apply to variable bindings (see type).

The lexically apparent bindings of function-names must not be macro definitions. (This is because ftype declares the functional definition of each function name to be of a particular subtype of function, and macros do not denote functions.)

ftype

declarations can be free declarations or bound declarations. ftype declarations of functions that appear before the body of a flet or labels

form that defines that function are bound declarations. Such declarations in other contexts are free declarations.

See Also::

declare, declaim , proclaim

gcl-2.6.14/info/gcl/Tilde-Less_002dThan_002dSign_002d_003e-Logical-Block.html0000644000175000017500000001530614360276512024115 0ustar cammcamm Tilde Less-Than-Sign-> Logical Block (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Pretty Printer Operations  

22.3.5.2 Tilde Less-Than-Sign: Logical Block

~<...~:>

If ~:> is used to terminate a ~<...~>, the directive is equivalent to a call to pprint-logical-block. The argument corresponding to the ~<...~:> directive is treated in the same way as the list argument to pprint-logical-block, thereby providing automatic support for non-list arguments and the detection of circularity, sharing, and depth abbreviation. The portion of the control-string nested within the ~<...~:> specifies the :prefix (or :per-line-prefix), :suffix, and body of the pprint-logical-block.

The control-string portion enclosed by ~<...~:> can be divided into segments ~<prefix~;body~;suffix~:> by ~; directives. If the first section is terminated by ~@;, it specifies a per-line prefix rather than a simple prefix. The prefix and suffix cannot contain format directives. An error is signaled if either the prefix or suffix fails to be a constant string or if the enclosed portion is divided into more than three segments.

If the enclosed portion is divided into only two segments, the suffix defaults to the null string. If the enclosed portion consists of only a single segment, both the prefix and the suffix default to the null string. If the colon modifier is used (i.e., ~:<...~:>), the prefix and suffix default to "(" and ")" (respectively) instead of the null string.

The body segment can be any arbitrary format string. This format string is applied to the elements of the list corresponding to the ~<...~:> directive as a whole. Elements are extracted from this list using pprint-pop, thereby providing automatic support for malformed lists, and the detection of circularity, sharing, and length abbreviation. Within the body segment, ~^ acts like pprint-exit-if-list-exhausted.

~<...~:> supports a feature not supported by pprint-logical-block. If ~:@> is used to terminate the directive (i.e., ~<...~:@>), then a fill-style conditional newline is automatically inserted after each group of blanks immediately contained in the body (except for blanks after a ~<Newline> directive). This makes it easy to achieve the equivalent of paragraph filling.

If the at-sign modifier is used with ~<...~:>, the entire remaining argument list is passed to the directive as its argument. All of the remaining arguments are always consumed by ~@<...~:>, even if they are not all used by the format string nested in the directive. Other than the difference in its argument, ~@<...~:> is exactly the same as ~<...~:> except that circularity detection is not applied if ~@<...~:> is encountered at top level in a format string. This ensures that circularity detection is applied only to data lists, not to format argument lists.

" . #n#" is printed if circularity or sharing has to be indicated for its argument as a whole.

To a considerable extent, the basic form of the directive ~<...~> is incompatible with the dynamic control of the arrangement of output by ~W, ~_, ~<...~:>, ~I, and ~:T. As a result, an error is signaled if any of these directives is nested within ~<...~>. Beyond this, an error is also signaled if the ~<...~:;...~> form of ~<...~> is used in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T.

See also Tilde Less-Than-Sign-> Justification.

Next: , Previous: , Up: FORMAT Pretty Printer Operations  

gcl-2.6.14/info/gcl/remove_002dmethod.html0000644000175000017500000000630314360276512016606 0ustar cammcamm remove-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.18 remove-method [Standard Generic Function]

Syntax::

remove-method generic-function method ⇒ generic-function

Method Signatures::

remove-method (generic-function standard-generic-function) method

Arguments and Values::

generic-function—a generic function.

method—a method.

Description::

The generic function remove-method removes a method from generic-function by modifying the generic-function (if necessary).

remove-method must not signal an error if the method is not one of the methods on the generic-function.

See Also::

find-method

gcl-2.6.14/info/gcl/pprint_002ddispatch.html0000644000175000017500000001014414360276512017142 0ustar cammcamm pprint-dispatch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.3 pprint-dispatch [Function]

pprint-dispatch object &optional table ⇒ function, found-p

Arguments and Values::

object—an object.

table—a pprint dispatch table, or nil. The default is the value of *print-pprint-dispatch*.

function—a function designator.

found-p—a generalized boolean.

Description::

Retrieves the highest priority function in table that is associated with a type specifier that matches object. The function is chosen by finding all of the type specifiers in table that match the object and selecting the highest priority function associated with any of these type specifiers. If there is more than one highest priority function, an arbitrary choice is made. If no type specifiers match the object, a function is returned that prints object

using print-object.

The secondary value, found-p, is true if a matching type specifier was found in table, or false otherwise.

If table is nil, retrieval is done in the initial pprint dispatch table.

Affected By::

The state of the table.

Exceptional Situations::

Should signal an error of type type-error if table is neither a pprint-dispatch-table nor nil.

Notes::

(let ((*print-pretty* t))
  (write object :stream s))
≡ (funcall (pprint-dispatch object) s object)
gcl-2.6.14/info/gcl/Removed-Language-Features.html0000644000175000017500000000640114360276512020260 0ustar cammcamm Removed Language Features (ANSI and GNU Common Lisp Document)

Previous: , Up: Appendix  

27.1 Removed Language Features

• Requirements for removed and deprecated features  
• Removed Types  
• Removed Operators  
• Removed Argument Conventions  
• Removed Variables  
• Removed Reader Syntax  
• Packages No Longer Required  
gcl-2.6.14/info/gcl/Character-Repertoires.html0000644000175000017500000000561114360276512017561 0ustar cammcamm Character Repertoires (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction to Scripts and Repertoires  

13.1.2.2 Character Repertoires

A repertoire is a type specifier for a subtype of type character.

This term is generally used when describing a collection of characters independent of their coding. Characters in repertoires are only identified by name, by glyph, or by character description.

A repertoire can contain characters from several scripts, and a character can appear in more than one repertoire.

For some examples of repertoires, see the coded character standards ISO 8859/1, ISO 8859/2, and ISO 6937/2. Note, however, that although the term “repertoire” is chosen for definitional compatibility with ISO terminology, no conforming implementation is required to use repertoires standardized by ISO or any other standards organization.

gcl-2.6.14/info/gcl/Lists-as-Sets.html0000644000175000017500000000511314360276512015774 0ustar cammcamm Lists as Sets (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses as Lists  

14.1.2.2 Lists as Sets

Lists are sometimes viewed as sets by considering their elements unordered and by assuming there is no duplication of elements. 

  adjoin         nset-difference    set-difference    union  
  intersection   nset-exclusive-or  set-exclusive-or         
  nintersection  nunion             subsetp                  

       Figure 14–5: Some defined names related to sets.
gcl-2.6.14/info/gcl/incf.html0000644000175000017500000000736614360276512014314 0ustar cammcamm incf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.33 incf, decf [Macro]

incf place [delta-form] ⇒ new-value

decf place [delta-form] ⇒ new-value

Arguments and Values::

place—a place.

delta-form—a form; evaluated to produce a delta. The default is 1.

delta—a number.

new-value—a number.

Description::

incf and decf are used for incrementing and decrementing the value of place, respectively.

The delta is added to (in the case of incf) or subtracted from (in the case of decf) the number in place and the result is stored in place.

Any necessary type conversions are performed automatically.

For information about the evaluation of subforms of places, see Evaluation of Subforms to Places.

Examples::

 (setq n 0)
 (incf n) ⇒  1      
 n ⇒  1
 (decf n 3) ⇒  -2   
 n ⇒  -2
 (decf n -5) ⇒  3      
 (decf n) ⇒  2      
 (incf n 0.5) ⇒  2.5
 (decf n) ⇒  1.5
 n ⇒  1.5

Side Effects::

Place is modified.

See Also::

+, - , 1+, 1-, setf

gcl-2.6.14/info/gcl/Implementation-Limits-on-Array-Rank.html0000644000175000017500000000436014360276512022167 0ustar cammcamm Implementation Limits on Array Rank (ANSI and GNU Common Lisp Document)

Previous: , Up: Array Elements  

15.1.1.9 Implementation Limits on Array Rank

An implementation may impose a limit on the rank of an array, but there is a minimum requirement on that limit. See the variable array-rank-limit.

gcl-2.6.14/info/gcl/random_002dstate_002dp.html0000644000175000017500000000631014360276512017334 0ustar cammcamm random-state-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.42 random-state-p [Function]

random-state-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type random-state; otherwise, returns false.

Examples::

 (random-state-p *random-state*) ⇒  true
 (random-state-p (make-random-state)) ⇒  true
 (random-state-p 'test-function) ⇒  false

See Also::

make-random-state , random-state

Notes::

 (random-state-p object) ≡ (typep object 'random-state)
gcl-2.6.14/info/gcl/bit_002dvector.html0000644000175000017500000000721314360276512016112 0ustar cammcamm bit-vector (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.5 bit-vector [System Class]

Class Precedence List::

bit-vector, vector, array, sequence, t

Description::

A bit vector is a vector the element type of which is bit.

The type bit-vector is a subtype of type vector, for bit-vector means (vector bit).

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(bit-vector{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *.

Compound Type Specifier Description::

This denotes the same type as the type (array bit (size)); that is, the set of bit vectors of size size.

See Also::

Sharpsign Asterisk, Printing Bit Vectors, Required Kinds of Specialized Arrays

gcl-2.6.14/info/gcl/Mentioning-Containing-Function-in-Condition-Reports.html0000644000175000017500000000462614360276512025336 0ustar cammcamm Mentioning Containing Function in Condition Reports (ANSI and GNU Common Lisp Document)

Previous: , Up: Printing Conditions  

9.1.3.6 Mentioning Containing Function in Condition Reports

The name of the containing function should generally not be mentioned in report messages. It is assumed that the debugger will make this information accessible in situations where it is necessary and appropriate.

gcl-2.6.14/info/gcl/Hash_002dTable-Operations.html0000644000175000017500000001125414360276512020065 0ustar cammcamm Hash-Table Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Table Concepts  

18.1.1 Hash-Table Operations

Figure 18–1 lists some defined names that are applicable to hash tables. The following rules apply to hash tables.

–

A hash table can only associate one value with a given key. If an attempt is made to add a second value for a given key, the second value will replace the first. Thus, adding a value to a hash table is a destructive operation; the hash table is modified.

–

There are four kinds of hash tables: those whose keys are compared with eq, those whose keys are compared with eql, those whose keys are compared with equal, and

those whose keys are compared with equalp.

–

Hash tables are created by make-hash-table. gethash is used to look up a key and find the associated value. New entries are added to hash tables using setf with gethash. remhash is used to remove an entry. For example: 

 (setq a (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32536573>
 (setf (gethash 'color a) 'brown) ⇒  BROWN
 (setf (gethash 'name a) 'fred) ⇒  FRED
 (gethash 'color a) ⇒  BROWN, true
 (gethash 'name a) ⇒  FRED, true
 (gethash 'pointy a) ⇒  NIL, false

In this example, the symbols color and name are being used as keys, and the symbols brown and fred are being used as the associated values. The hash table has two items in it, one of which associates from color to brown, and the other of which associates from name to fred.

–

A key or a value may be any object.

–

The existence of an entry in the hash table can be determined from the secondary value returned by gethash. 

  clrhash           hash-table-p     remhash  
  gethash           make-hash-table  sxhash   
  hash-table-count  maphash                   

     Figure 18–1: Hash-table defined names

Next: , Previous: , Up: Hash Table Concepts  

gcl-2.6.14/info/gcl/reverse.html0000644000175000017500000001210314360276512015031 0ustar cammcamm reverse (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.12 reverse, nreverse [Function]

reverse sequence ⇒ reversed-sequence

nreverse sequence ⇒ reversed-sequence

Arguments and Values::

sequence—a proper sequence.

reversed-sequence—a sequence.

Description::

reverse and nreverse return a new sequence of the same kind as sequence, containing the same elements, but in reverse order.

reverse and nreverse differ in that reverse always creates and returns a new sequence, whereas nreverse might modify and return the given sequence. reverse never modifies the given sequence.

For reverse, if sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list.

For nreverse, if sequence is a vector, the result is a vector that has the same actual array element type as sequence. If sequence is a list, the result is a list.

For nreverse, sequence might be destroyed and re-used to produce the result. The result might or might not be identical to sequence.

Specifically, when sequence is a list, nreverse is permitted to setf any part, car or cdr, of any cons that is part of the list structure of sequence. When sequence is a vector, nreverse is permitted to re-order the elements of sequence in order to produce the resulting vector.

Examples::

 (setq str "abc") ⇒  "abc"
 (reverse str) ⇒  "cba"
 str ⇒  "abc"
 (setq str (copy-seq str)) ⇒  "abc"
 (nreverse str) ⇒  "cba"
 str ⇒  implementation-dependent
 (setq l (list 1 2 3)) ⇒  (1 2 3)
 (nreverse l) ⇒  (3 2 1)
 l ⇒  implementation-dependent

Side Effects::

nreverse might either create a new sequence, modify the argument sequence, or both. (reverse does not modify sequence.)

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Form-Evaluation.html0000644000175000017500000000415614360276512016377 0ustar cammcamm Form Evaluation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.1 Form Evaluation

Forms fall into three categories: symbols, conses, and self-evaluating objects. The following sections explain these categories.

gcl-2.6.14/info/gcl/atom-_0028Type_0029.html0000644000175000017500000000431514360276512016366 0ustar cammcamm atom (Type) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.4 atom [Type]

Supertypes::

atom, t

Description::

It is equivalent to (not cons).

gcl-2.6.14/info/gcl/Examples-of-for_002das_002dacross-subclause.html0000644000175000017500000000466114360276512023331 0ustar cammcamm Examples of for-as-across subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.11 Examples of for-as-across subclause

 (loop for char across (the simple-string (find-message channel))
       do (write-char char stream))
gcl-2.6.14/info/gcl/make_002dpackage.html0000644000175000017500000001233114360276512016337 0ustar cammcamm make-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.12 make-package [Function]

make-package package-name &key nicknames use ⇒ package

Arguments and Values::

package-name—a string designator.

nicknames—a list of string designators. The default is the empty list.

use— a list of package designators.

The default is implementation-defined.

package—a package.

Description::

Creates a new package with the name package-name.

Nicknames are additional names which may be used to refer to the new package.

use specifies zero or more packages the external symbols of which are to be inherited by the new package. See the function use-package.

Examples::

 (make-package 'temporary :nicknames '("TEMP" "temp")) ⇒  #<PACKAGE "TEMPORARY">
 (make-package "OWNER" :use '("temp")) ⇒  #<PACKAGE "OWNER">
 (package-used-by-list 'temp) ⇒  (#<PACKAGE "OWNER">)
 (package-use-list 'owner) ⇒  (#<PACKAGE "TEMPORARY">)

Affected By::

The existence of other packages in the system.

Exceptional Situations::

The consequences are unspecified if packages denoted by use do not exist.

A correctable error is signaled if the package-name or any of the nicknames is already the name or nickname of an existing package.

See Also::

defpackage , use-package

Notes::

In situations where the packages to be used contain symbols which would conflict, it is necessary to first create the package with :use '(), then to use shadow or shadowing-import to address the conflicts, and then after that to use use-package once the conflicts have been addressed.

When packages are being created as part of the static definition of a program rather than dynamically by the program, it is generally considered more stylistically appropriate to use defpackage rather than make-package.

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/find_002dsymbol.html0000644000175000017500000001321014360276512016251 0ustar cammcamm find-symbol (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.3 find-symbol [Function]

find-symbol string &optional package ⇒ symbol, status

Arguments and Values::

string—a string.

package—a package designator.

The default is the current package.

symbol—a symbol accessible in the package, or nil.

status—one of :inherited, :external, :internal, or nil.

Description::

find-symbol locates a symbol whose name is string in a package. If a symbol named string is found in package, directly or by inheritance, the symbol found is returned as the first value; the second value is as follows:

:internal

If the symbol is present in package as an internal symbol.

:external

If the symbol is present in package as an external symbol.

:inherited

If the symbol is inherited by package through use-package, but is not present in package.

If no such symbol is accessible in package, both values are nil.

Examples::

 (find-symbol "NEVER-BEFORE-USED") ⇒  NIL, NIL
 (find-symbol "NEVER-BEFORE-USED") ⇒  NIL, NIL
 (intern "NEVER-BEFORE-USED") ⇒  NEVER-BEFORE-USED, NIL
 (intern "NEVER-BEFORE-USED") ⇒  NEVER-BEFORE-USED, :INTERNAL
 (find-symbol "NEVER-BEFORE-USED") ⇒  NEVER-BEFORE-USED, :INTERNAL
 (find-symbol "never-before-used") ⇒  NIL, NIL
 (find-symbol "CAR" 'common-lisp-user) ⇒  CAR, :INHERITED
 (find-symbol "CAR" 'common-lisp) ⇒  CAR, :EXTERNAL
 (find-symbol "NIL" 'common-lisp-user) ⇒  NIL, :INHERITED
 (find-symbol "NIL" 'common-lisp) ⇒  NIL, :EXTERNAL
 (find-symbol "NIL" (prog1 (make-package "JUST-TESTING" :use '())
                           (intern "NIL" "JUST-TESTING")))
⇒  JUST-TESTING::NIL, :INTERNAL
 (export 'just-testing::nil 'just-testing)
 (find-symbol "NIL" 'just-testing) ⇒  JUST-TESTING:NIL, :EXTERNAL
 (find-symbol "NIL" "KEYWORD")
⇒  NIL, NIL
OR⇒ :NIL, :EXTERNAL
 (find-symbol (symbol-name :nil) "KEYWORD") ⇒  :NIL, :EXTERNAL

Affected By::

intern, import, export, use-package, unintern, unexport, unuse-package

See Also::

intern , find-all-symbols

Notes::

find-symbol is operationally equivalent to intern, except that it never creates a new symbol.

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/use_002dvalue.html0000644000175000017500000000552614360276512015747 0ustar cammcamm use-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.45 use-value [Restart]

Data Arguments Required::

a value to use instead (once).

Description::

The use-value restart is generally used by handlers trying to recover from errors of types such as cell-error, where the handler may wish to supply a replacement datum for one-time use.

See Also::

Restarts, Interfaces to Restarts, invoke-restart , use-value (function), store-value (function and restart)

gcl-2.6.14/info/gcl/complement.html0000644000175000017500000001076714360276512015537 0ustar cammcamm complement (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.38 complement [Function]

complement function ⇒ complement-function

Arguments and Values::

function—a function.

complement-function—a function.

Description::

Returns a function that takes the same arguments as function, and has the same side-effect behavior as function, but returns only a single value: a generalized boolean with the opposite truth value of that which would be returned as the primary value of function. That is, when the function would have returned true as its primary value the complement-function returns false, and when the function would have returned false as its primary value the complement-function returns true.

Examples::

 (funcall (complement #'zerop) 1) ⇒  true
 (funcall (complement #'characterp) #\A) ⇒  false
 (funcall (complement #'member) 'a '(a b c)) ⇒  false
 (funcall (complement #'member) 'd '(a b c)) ⇒  true

See Also::

not

Notes::

 (complement x) ≡ #'(lambda (&rest arguments) (not (apply x arguments)))

In Common Lisp, functions with names like “xxx-if-not” are related to functions with names like “xxx-if” in that 

(xxx-if-not f . arguments) ≡ (xxx-if (complement f) . arguments)

For example, 

 (find-if-not #'zerop '(0 0 3)) ≡
 (find-if (complement #'zerop) '(0 0 3)) ⇒  3

Note that since the “xxx-if-not” functions and the :test-not arguments have been deprecated, uses of “xxx-if” functions or :test arguments with complement are preferred.

gcl-2.6.14/info/gcl/make_002dstring_002dinput_002dstream.html0000644000175000017500000000731014360276512022021 0ustar cammcamm make-string-input-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.49 make-string-input-stream [Function]

make-string-input-stream string &optional start end ⇒ string-stream

Arguments and Values::

string—a string.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

string-stream—an input string stream.

Description::

Returns an input string stream. This stream will supply, in order, the characters in the substring of string bounded by start and end. After the last character has been supplied, the string stream will then be at end of file.

Examples::

 (let ((string-stream (make-string-input-stream "1 one ")))
   (list (read string-stream nil nil)
         (read string-stream nil nil)
         (read string-stream nil nil)))
⇒  (1 ONE NIL)

 (read (make-string-input-stream "prefixtargetsuffix" 6 12)) ⇒  TARGET

See Also::

with-input-from-string

gcl-2.6.14/info/gcl/_002aprint_002dpprint_002ddispatch_002a.html0000644000175000017500000000735314360276512022220 0ustar cammcamm *print-pprint-dispatch* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.25 *print-pprint-dispatch* [Variable]

Value Type::

a pprint dispatch table.

Initial Value::

implementation-dependent, but the initial entries all use a special class of priorities that have the property that they are less than every priority that can be specified using set-pprint-dispatch, so that the initial contents of any entry can be overridden.

Description::

The pprint dispatch table which currently controls the pretty printer.

See Also::

*print-pretty*, Pretty Print Dispatch Tables

Notes::

The intent is that the initial value of this variable should cause ‘traditional’ pretty printing of code. In general, however, you can put a value in *print-pprint-dispatch* that makes pretty-printed output look exactly like non-pretty-printed output.

Setting *print-pretty* to true just causes the functions contained in the current pprint dispatch table to have priority over normal print-object methods; it has no magic way of enforcing that those functions actually produce pretty output. For details, see Pretty Print Dispatch Tables.

gcl-2.6.14/info/gcl/dolist.html0000644000175000017500000001251314360276512014661 0ustar cammcamm dolist (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Iteration Dictionary  

6.2.3 dolist [Macro]

dolist (var list-form [result-form]) {declaration}* {tag | statement}*
⇒ {result}*

Arguments and Values::

var—a symbol.

list-form—a form.

result-form—a form.

declaration—a declare expression; not evaluated.

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

results—if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-form or nil if there is no result-form.

Description::

dolist iterates over the elements of a list. The body of dolist is like a tagbody. It consists of a series of tags and statements.

dolist evaluates list-form, which should produce a list. It then executes the body once for each element in the list, in the order in which the tags and statements occur, with var bound to the element. Then result-form is evaluated. tags label statements.

At the time result-form is processed, var is bound to nil.

An implicit block named nil surrounds dolist. return may be used to terminate the loop immediately without performing any further iterations, returning zero or more values.

The scope of the binding of var does not include the list-form, but the result-form is included.

It is implementation-dependent whether dolist establishes a new binding of var on each iteration or whether it establishes a binding for var once at the beginning and then assigns it on any subsequent iterations.

Examples::

 (setq temp-two '()) ⇒  NIL
 (dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two)) ⇒  (4 3 2 1)

 (setq temp-two 0) ⇒  0
 (dolist (temp-one '(1 2 3 4)) (incf temp-two)) ⇒  NIL
 temp-two ⇒  4

 (dolist (x '(a b c d)) (prin1 x) (princ " ")) 
 |>  A B C D 
⇒  NIL

See Also::

do , dotimes , tagbody ,

Traversal Rules and Side Effects

Notes::

go may be used within the body of dolist to transfer control to a statement labeled by a tag.

Next: , Previous: , Up: Iteration Dictionary  

gcl-2.6.14/info/gcl/array.html0000644000175000017500000001525714360276512014511 0ustar cammcamm array (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.1 array [System Class]

Class Precedence List::

array, t

Description::

An array contains objects arranged according to a Cartesian coordinate system. An array provides mappings from a set of

fixnums

\left{i_0,i_1,\dots,i_{r-1}\right} to corresponding elements of the array, where 0 \le i_j < d_j, r is the rank of the array, and d_j is the size of dimension j of the array.

When an array is created, the program requesting its creation may declare that all elements are of a particular type, called the expressed array element type. The implementation is permitted to upgrade this type in order to produce the actual array element type, which is the element type for the array is actually specialized. See the function upgraded-array-element-type.

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(array{[{element-type | *} [dimension-spec]]})

dimension-spec ::=rank | * | ({dimension | *}*)

Compound Type Specifier Arguments::

dimension—a valid array dimension.

element-type—a type specifier.

rank—a non-negative fixnum.

Compound Type Specifier Description::

This denotes the set of arrays whose element type, rank, and dimensions match any given element-type, rank, and dimensions. Specifically:

If element-type is the symbol *, arrays are not excluded on the basis of their element type. Otherwise, only those arrays are included whose actual array element type

is the result of upgrading element-type; see Array Upgrading.

If the dimension-spec is a rank, the set includes only those arrays having that rank. If the dimension-spec is a list of dimensions, the set includes only those arrays having a rank given by the length of the dimensions, and having the indicated dimensions; in this case, * matches any value for the corresponding dimension. If the dimension-spec is the symbol *, the set is not restricted on the basis of rank or dimension.

See Also::

*print-array*, aref , make-array , vector, Sharpsign A, Printing Other Arrays

Notes::

Note that the type (array t) is a proper subtype of the type (array *). The reason is that the type (array t) is the set of arrays that can hold any object (the elements are of type t, which includes all objects). On the other hand, the type (array *) is the set of all arrays whatsoever, including for example arrays that can hold only characters. The type (array character) is not a subtype of the type (array t); the two sets are disjoint because the type (array character) is not the set of all arrays that can hold characters, but rather the set of arrays that are specialized to hold precisely characters and no other objects.

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/numberp.html0000644000175000017500000000570314360276512015036 0ustar cammcamm numberp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.44 numberp [Function]

numberp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type number; otherwise, returns false.

Examples::

 (numberp 12) ⇒  true
 (numberp (expt 2 130)) ⇒  true
 (numberp #c(5/3 7.2)) ⇒  true
 (numberp nil) ⇒  false
 (numberp (cons 1 2)) ⇒  false

Notes::

 (numberp object) ≡ (typep object 'number)
gcl-2.6.14/info/gcl/concatenated_002dstream.html0000644000175000017500000000677614360276512017772 0ustar cammcamm concatenated-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.3 concatenated-stream [System Class]

Class Precedence List::

concatenated-stream, stream, t

Description::

A concatenated stream is an input stream which is a composite stream of zero or more other input streams, such that the sequence of data which can be read from the concatenated stream is the same as the concatenation of the sequences of data which could be read from each of the constituent streams.

Input from a concatenated stream is taken from the first of the associated input streams until it reaches end of file_1; then that stream is discarded, and subsequent input is taken from the next input stream, and so on. An end of file on the associated input streams is always managed invisibly by the concatenated stream—the only time a client of a concatenated stream sees an end of file is when an attempt is made to obtain data from the concatenated stream but it has no remaining input streams from which to obtain such data.

See Also::

concatenated-stream-streams , make-concatenated-stream

gcl-2.6.14/info/gcl/serious_002dcondition.html0000644000175000017500000000663014360276512017513 0ustar cammcamm serious-condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.4 serious-condition [Condition Type]

Class Precedence List::

serious-condition, condition, t

Description::

All conditions serious enough to require interactive intervention if not handled should inherit from the type serious-condition. This condition type is provided primarily so that it may be included as a superclass of other condition types; it is not intended to be signaled directly.

Notes::

Signaling a serious condition does not itself force entry into the debugger. However, except in the unusual situation where the programmer can assure that no harm will come from failing to handle a serious condition, such a condition is usually signaled with error rather than signal in order to assure that the program does not continue without handling the condition. (And conversely, it is conventional to use signal rather than error to signal conditions which are not serious conditions, since normally the failure to handle a non-serious condition is not reason enough for the debugger to be entered.)

gcl-2.6.14/info/gcl/Corresponding-Characters-in-the-Other-Case.html0000644000175000017500000000511014360276512023361 0ustar cammcamm Corresponding Characters in the Other Case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.6 Corresponding Characters in the Other Case

The uppercase standard characters A through Z mentioned above respectively correspond to the lowercase standard characters a through z mentioned above. For example, the uppercase character E corresponds to the lowercase character e, and vice versa.

gcl-2.6.14/info/gcl/progn.html0000644000175000017500000000753714360276512014522 0ustar cammcamm progn (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.59 progn [Special Operator]

progn {form}* ⇒ {result}*

Arguments and Values::

forms—an implicit progn.

results—the values of the forms.

Description::

progn evaluates forms, in the order in which they are given.

The values of each form but the last are discarded.

If progn appears as a top level form, then all forms within that progn are considered by the compiler to be top level forms.

Examples::

 (progn) ⇒  NIL
 (progn 1 2 3) ⇒  3
 (progn (values 1 2 3)) ⇒  1, 2, 3
 (setq a 1) ⇒  1
 (if a
      (progn (setq a nil) 'here)
      (progn (setq a t) 'there)) ⇒  HERE
 a ⇒  NIL

See Also::

prog1 , prog2, Evaluation

Notes::

Many places in Common Lisp involve syntax that uses implicit progns. That is, part of their syntax allows many forms to be written that are to be evaluated sequentially, discarding the results of all forms but the last and returning the results of the last form. Such places include, but are not limited to, the following: the body of a lambda expression; the bodies of various control and conditional forms (e.g., case, catch, progn, and when).

gcl-2.6.14/info/gcl/float.html0000644000175000017500000000636414360276512014477 0ustar cammcamm float (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.74 float [Function]

float number &optional prototype ⇒ float

Arguments and Values::

number—a real.

prototype—a float.

float—a float.

Description::

float converts a

real

number to a float.

If a prototype is supplied, a float is returned that is mathematically equal to number but has the same format as prototype.

If prototype is not supplied, then if the number is already a float, it is returned; otherwise, a float is returned that is mathematically equal to number but is a single float.

Examples::

 (float 0) ⇒  0.0
 (float 1 .5) ⇒  1.0
 (float 1.0) ⇒  1.0
 (float 1/2) ⇒  0.5
⇒  1.0d0
OR⇒ 1.0
 (eql (float 1.0 1.0d0) 1.0d0) ⇒  true

See Also::

coerce

gcl-2.6.14/info/gcl/multiple_002dvalues_002dlimit.html0000644000175000017500000000610614360276512020750 0ustar cammcamm multiple-values-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.55 multiple-values-limit [Constant Variable]

Constant Value::

An integer not smaller than 20, the exact magnitude of which is implementation-dependent.

Description::

The upper exclusive bound on the number of values that may be returned from a function,

bound or assigned by multiple-value-bind or multiple-value-setq, or passed as a first argument to nth-value. (If these individual limits might differ, the minimum value is used.)

See Also::

lambda-parameters-limit , call-arguments-limit

Notes::

Implementors are encouraged to make this limit as large as possible.

gcl-2.6.14/info/gcl/Accessing-Slots.html0000644000175000017500000001240114360276512016360 0ustar cammcamm Accessing Slots (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Slots  

7.5.2 Accessing Slots

Slots can be accessed in two ways: by use of the primitive function slot-value and by use of generic functions generated by the defclass form.

The function slot-value can be used with any of the slot names specified in the defclass form to access a specific slot accessible in an instance of the given class.

The macro defclass provides syntax for generating methods to read and write slots. If a reader method is requested, a method is automatically generated for reading the value of the slot, but no method for storing a value into it is generated. If a writer method is requested, a method is automatically generated for storing a value into the slot, but no method for reading its value is generated. If an accessor method is requested, a method for reading the value of the slot and a method for storing a value into the slot are automatically generated. Reader and writer methods are implemented using slot-value.

When a reader or writer method is specified for a slot, the name of the generic function to which the generated method belongs is directly specified. If the name specified for the writer method is the symbol name, the name of the generic function for writing the slot is the symbol name, and the generic function takes two arguments: the new value and the instance, in that order. If the name specified for the accessor method is the symbol name, the name of the generic function for reading the slot is the symbol name, and the name of the generic function for writing the slot is the list (setf name).

A generic function created or modified by supplying :reader, :writer, or :accessor slot options can be treated exactly as an ordinary generic function.

Note that slot-value can be used to read or write the value of a slot whether or not reader or writer methods exist for that slot. When slot-value is used, no reader or writer methods are invoked.

The macro with-slots can be used to establish a lexical environment in which specified slots are lexically available as if they were variables. The macro with-slots invokes the function slot-value to access the specified slots.

The macro with-accessors can be used to establish a lexical environment in which specified slots are lexically available through their accessors as if they were variables. The macro with-accessors invokes the appropriate accessors to access the specified slots.

Next: , Previous: , Up: Slots  

gcl-2.6.14/info/gcl/Self_002dEvaluating-Objects.html0000644000175000017500000000532414360276512020412 0ustar cammcamm Self-Evaluating Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.12 Self-Evaluating Objects

A form that is neither a symbol nor a cons is defined to be a self-evaluating object. Evaluating such an object yields the same object as a result.

Certain specific symbols and conses might also happen to be “self-evaluating” but only as a special case of a more general set of rules for the evaluation of symbols and conses; such objects are not considered to be self-evaluating objects.

The consequences are undefined if literal objects (including self-evaluating objects) are destructively modified.

gcl-2.6.14/info/gcl/Customizing-the-Change-of-Class-of-an-Instance.html0000644000175000017500000000567314360276512024055 0ustar cammcamm Customizing the Change of Class of an Instance (ANSI and GNU Common Lisp Document)

Previous: , Up: Changing the Class of an Instance  

7.2.3 Customizing the Change of Class of an Instance

Methods for update-instance-for-different-class may be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-different-class are defined, they will be run after the system-supplied primary method for initialization and will not interfere with the default behavior of update-instance-for-different-class.

Methods for shared-initialize may be defined to customize class redefinition. For more information, see Shared-Initialize.

gcl-2.6.14/info/gcl/set_002ddifference.html0000644000175000017500000001645614360276512016730 0ustar cammcamm set-difference (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.46 set-difference, nset-difference [Function]

set-difference list-1 list-2 &key key test test-not ⇒ result-list

nset-difference list-1 list-2 &key key test test-not ⇒ result-list

Arguments and Values::

list-1—a proper list.

list-2—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

result-list—a list.

Description::

set-difference returns a list of elements of list-1 that do not appear in list-2.

nset-difference is the destructive version of set-difference. It may destroy list-1.

For all possible ordered pairs consisting of one element from list-1 and one element from list-2, the :test or :test-not function is used to determine whether they satisfy the test. The first argument to the :test or :test-not function is the part of an element of list-1 that is returned by the :key function (if supplied); the second argument is the part of an element of list-2 that is returned by the :key function (if supplied).

If :key is supplied, its argument is a list-1 or list-2 element. The :key function typically returns part of the supplied element. If :key is not supplied, the list-1 or list-2 element is used.

An element of list-1 appears in the result if and only if it does not match any element of list-2.

There is no guarantee that the order of elements in the result will reflect the ordering of the arguments in any particular way. The result list may share cells with, or be eq to, either of list-1 or list-2, if appropriate.

Examples::

 (setq lst1 (list "A" "b" "C" "d")
       lst2 (list "a" "B" "C" "d")) ⇒  ("a" "B" "C" "d")
 (set-difference lst1 lst2) ⇒  ("d" "C" "b" "A")
 (set-difference lst1 lst2 :test 'equal) ⇒  ("b" "A")
 (set-difference lst1 lst2 :test #'equalp) ⇒  NIL 
 (nset-difference lst1 lst2 :test #'string=) ⇒  ("A" "b")
 (setq lst1 '(("a" . "b") ("c" . "d") ("e" . "f")))
⇒  (("a" . "b") ("c" . "d") ("e" . "f")) 
 (setq lst2 '(("c" . "a") ("e" . "b") ("d" . "a")))
⇒  (("c" . "a") ("e" . "b") ("d" . "a")) 
 (nset-difference lst1 lst2 :test #'string= :key #'cdr)
⇒  (("c" . "d") ("e" . "f")) 
 lst1 ⇒  (("a" . "b") ("c" . "d") ("e" . "f")) 
 lst2 ⇒  (("c" . "a") ("e" . "b") ("d" . "a")) 

;; Remove all flavor names that contain "c" or "w".
 (set-difference '("strawberry" "chocolate" "banana"
                  "lemon" "pistachio" "rhubarb")
          '(#\c #\w)
          :test #'(lambda (s c) (find c s)))
⇒  ("banana" "rhubarb" "lemon")    ;One possible ordering.

Side Effects::

nset-difference may destroy list-1.

Exceptional Situations::

Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists.

See Also::

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/_002aprint_002dmiser_002dwidth_002a.html0000644000175000017500000000530714360276512021340 0ustar cammcamm *print-miser-width* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.24 *print-miser-width* [Variable]

Value Type::

a non-negative integer, or nil.

Initial Value::

implementation-dependent

Description::

If it is not nil, the pretty printer switches to a compact style of output (called miser style) whenever the width available for printing a substructure is less than or equal to this many ems.

gcl-2.6.14/info/gcl/Sharpsign.html0000644000175000017500000002676314360276512015335 0ustar cammcamm Sharpsign (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.8 Sharpsign

Sharpsign is a non-terminating dispatching macro character. It reads an optional sequence of digits and then one more character, and uses that character to select a function to run as a reader macro function.

The standard syntax includes constructs introduced by the # character. The syntax of these constructs is as follows: a character that identifies the type of construct is followed by arguments in some form. If the character is a letter, its case is not important; #O and #o are considered to be equivalent, for example.

Certain # constructs allow an unsigned decimal number to appear between the # and the character.

The reader macros associated with the dispatching macro character # are described later in this section and summarized in Figure 2–19. 

  dispatch char  purpose                  dispatch char  purpose                
  Backspace      signals error            {              undefined*             
  Tab            signals error            }              undefined*             
  Newline        signals error            +              read-time conditional  
  Linefeed       signals error            -              read-time conditional  
  Page           signals error            .              read-time evaluation   
  Return         signals error            /              undefined              
  Space          signals error            A, a           array                  
  !              undefined*               B, b           binary rational        
  "              undefined                C, c           complex number         
  #              reference to = label     D, d           undefined              
  $             undefined                E, e           undefined              
  %              undefined                F, f           undefined              
  &              undefined                G, g           undefined              
  ’              function abbreviation    H, h           undefined              
  (              simple vector            I, i           undefined              
  )              signals error            J, j           undefined              
  *              bit vector               K, k           undefined              
  ,              undefined                L, l           undefined              
  :              uninterned symbol        M, m           undefined              
  ;              undefined                N, n           undefined              
  <              signals error            O, o           octal rational         
  =              labels following object  P, p           pathname               
  >              undefined                Q, q           undefined              
  ?              undefined*               R, r           radix-n rational       
  @              undefined                S, s           structure              
  [              undefined*               T, t           undefined              
  \              character object         U, u           undefined              
  ]              undefined*               V, v           undefined              
  ^            undefined                W, w           undefined              
  _              undefined                X, x           hexadecimal rational   
  ‘              undefined                Y, y           undefined              
  |              balanced comment         Z, z           undefined              
  ~              undefined                Rubout         undefined              

           Figure 2–19: Standard # Dispatching Macro Character Syntax

The combinations marked by an asterisk (*) are explicitly reserved to the user. No conforming implementation defines them.

Note also that digits do not appear in the preceding table. This is because the notations #0, #1, ..., #9 are reserved for another purpose which occupies the same syntactic space. When a digit follows a sharpsign, it is not treated as a dispatch character. Instead, an unsigned integer argument is accumulated and passed as an argument to the reader macro for the character that follows the digits. For example, #2A((1 2) (3 4)) is a use of #A with an argument of 2.

• Sharpsign Backslash  
• Sharpsign Single-Quote  
• Sharpsign Left-Parenthesis  
• Sharpsign Asterisk  
• Examples of Sharpsign Asterisk  
• Sharpsign Colon  
• Sharpsign Dot  
• Sharpsign B  
• Sharpsign O  
• Sharpsign X  
• Sharpsign R  
• Sharpsign C  
• Sharpsign A  
• Sharpsign S  
• Sharpsign P  
• Sharpsign Equal-Sign  
• Sharpsign Sharpsign  
• Sharpsign Plus  
• Sharpsign Minus  
• Sharpsign Vertical-Bar  
• Examples of Sharpsign Vertical-Bar  
• Notes about Style for Sharpsign Vertical-Bar  
• Sharpsign Less-Than-Sign  
• Sharpsign Whitespace  
• Sharpsign Right-Parenthesis  

Next: , Previous: , Up: Standard Macro Characters  

gcl-2.6.14/info/gcl/condition.html0000644000175000017500000001024414360276512015350 0ustar cammcamm condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.1 condition [Condition Type]

[Reviewer Note by Barrett: I think CONDITION-RESTARTS is not fully integrated.]

Class Precedence List::

condition, t

Description::

All types of conditions, whether error or non-error, must inherit from this type.

No additional subtype relationships among the specified subtypes of type condition are allowed, except when explicitly mentioned in the text; however implementations are permitted to introduce additional types and one of these types can be a subtype of any number of the subtypes of type condition.

Whether a user-defined condition type has slots that are accessible by with-slots is implementation-dependent. Furthermore, even in an implementation in which user-defined condition types would have slots, it is implementation-dependent whether any condition types defined in this document have such slots or, if they do, what their names might be; only the reader functions documented by this specification may be relied upon by portable code.

Conforming code must observe the following restrictions related to conditions:

*

define-condition, not defclass, must be used to define new condition types.

*

make-condition, not make-instance, must be used to create condition objects explicitly.

*

The :report option of define-condition, not defmethod for print-object, must be used to define a condition reporter.

*

slot-value, slot-boundp, slot-makunbound, and with-slots must not be used on condition objects. Instead, the appropriate accessor functions (defined by define-condition) should be used.

gcl-2.6.14/info/gcl/Deprecated-Language-Features.html0000644000175000017500000000672514360276512020730 0ustar cammcamm Deprecated Language Features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.8 Deprecated Language Features

Deprecated language features are not expected to appear in future Common Lisp standards, but are required to be implemented for conformance with this standard; see Required Language Features.

Conforming programs can use deprecated features; however, it is considered good programming style to avoid them. It is permissible for the compiler to produce style warnings about the use of such features at compile time, but there should be no such warnings at program execution time.

• Deprecated Functions  
• Deprecated Argument Conventions  
• Deprecated Variables  
• Deprecated Reader Syntax  
gcl-2.6.14/info/gcl/pathname_002dmatch_002dp.html0000644000175000017500000000735414360276512017636 0ustar cammcamm pathname-match-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.14 pathname-match-p [Function]

pathname-match-p pathname wildcard ⇒ generalized-boolean

Arguments and Values::

pathname—a pathname designator.

wildcard—a designator for a wild pathname.

generalized-boolean—a generalized boolean.

Description::

pathname-match-p returns true if pathname matches wildcard, otherwise nil. The matching rules are implementation-defined but should be consistent with directory. Missing components of wildcard default to :wild.

It is valid for pathname to be a wild pathname; a wildcard field in pathname only matches a wildcard field in wildcard (i.e., pathname-match-p is not commutative). It is valid for wildcard to be a non-wild pathname.

Exceptional Situations::

If pathname or wildcard is not a pathname, string, or stream associated with a file an error of type type-error is signaled.

See Also::

directory , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

gcl-2.6.14/info/gcl/machine_002dinstance.html0000644000175000017500000000637514360276512017252 0ustar cammcamm machine-instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.26 machine-instance [Function]

machine-instance <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

Returns a string that identifies the particular instance of the computer hardware on which Common Lisp is running, or nil if no such string can be computed.

Examples::

 (machine-instance)
⇒  "ACME.COM"
OR⇒ "S/N 123231"
OR⇒ "18.26.0.179"
OR⇒ "AA-00-04-00-A7-A4"

Affected By::

The machine instance, and the implementation.

See Also::

machine-type , machine-version

gcl-2.6.14/info/gcl/Lambda-Forms.html0000644000175000017500000000505314360276512015630 0ustar cammcamm Lambda Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.11 Lambda Forms

A lambda form is similar to a function form, except that the function name is replaced by a lambda expression.

A lambda form is equivalent to using funcall of a lexical closure of the lambda expression on the given arguments. (In practice, some compilers are more likely to produce inline code for a lambda form than for an arbitrary named function that has been declared inline; however, such a difference is not semantic.)

For further information, see Lambda Expressions.

gcl-2.6.14/info/gcl/Character-Syntax-Types.html0000644000175000017500000002232714360276512017651 0ustar cammcamm Character Syntax Types (ANSI and GNU Common Lisp Document)

Previous: , Up: Character Syntax  

2.1.4 Character Syntax Types

The Lisp reader constructs an object from the input text by interpreting each character according to its syntax type. The Lisp reader cannot accept as input everything that the Lisp printer produces, and the Lisp reader has features that are not used by the Lisp printer. The Lisp reader can be used as a lexical analyzer for a more general user-written parser.

When the Lisp reader is invoked, it reads a single character from the input stream and dispatches according to the syntax type of that character. Every character that can appear in the input stream is of one of the syntax types shown in Figure~2–6. 

  constituent  macro character  single escape  
  invalid      multiple escape  whitespace_2   

  Figure 2–6: Possible Character Syntax Types

The syntax type of a character in a readtable determines how that character is interpreted by the Lisp reader while that readtable is the current readtable. At any given time, every character has exactly one syntax type.

Figure~2–7 lists the syntax type of each character in standard syntax. 

  character  syntax type                 character  syntax type             
  Backspace  constituent                 0–9       constituent             
  Tab        whitespace_2                :          constituent             
  Newline    whitespace_2                ;          terminating macro char  
  Linefeed   whitespace_2                <          constituent             
  Page       whitespace_2                =          constituent             
  Return     whitespace_2                >          constituent             
  Space      whitespace_2                ?          constituent*            
  !          constituent*                @          constituent             
  "          terminating macro char      A–Z       constituent             
  #          non-terminating macro char  [          constituent*            
  $         constituent                 \          single escape           
  %          constituent                 ]          constituent*            
  &          constituent                 ^          constituent             
  ’          terminating macro char      _          constituent             
  (          terminating macro char      ‘          terminating macro char  
  )          terminating macro char      a–z       constituent             
  *          constituent                 {          constituent*            
  +          constituent                 |          multiple escape         
  ,          terminating macro char      }          constituent*            
  -          constituent                 ~          constituent             
  .          constituent                 Rubout     constituent             
  /          constituent                 

            Figure 2–7: Character Syntax Types in Standard Syntax

The characters marked with an asterisk (*) are initially constituents, but they are not used in any standard Common Lisp notations. These characters are explicitly reserved to the programmer. ~ is not used in Common Lisp, and reserved to implementors. $ and % are alphabetic_2 characters, but are not used in the names of any standard Common Lisp defined names.

Whitespace_2 characters serve as separators but are otherwise ignored. Constituent and escape characters are accumulated to make a token, which is then interpreted as a number or symbol. Macro characters trigger the invocation of functions (possibly user-supplied) that can perform arbitrary parsing actions. Macro characters are divided into two kinds, terminating and non-terminating, depending on whether or not they terminate a token. The following are descriptions of each kind of syntax type.

• Constituent Characters  
• Constituent Traits  
• Invalid Characters  
• Macro Characters  
• Multiple Escape Characters  
• Examples of Multiple Escape Characters  
• Single Escape Character  
• Examples of Single Escape Characters  
• Whitespace Characters  
• Examples of Whitespace Characters  

Previous: , Up: Character Syntax  

gcl-2.6.14/info/gcl/Objects-with-Multiple-Notations.html0000644000175000017500000000447514360276512021502 0ustar cammcamm Objects with Multiple Notations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.7 Objects with Multiple Notations

Some objects in Common Lisp can be notated in more than one way. In such situations, the choice of which notation to use is technically arbitrary, but conventions may exist which convey a “point of view” or “sense of intent.”

gcl-2.6.14/info/gcl/Rule-of-Complex-Contagion.html0000644000175000017500000000464714360276512020231 0ustar cammcamm Rule of Complex Contagion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Complex Computations  

12.1.5.2 Rule of Complex Contagion

When a

real

and a complex are both part of a computation, the

real

is first converted to a complex by providing an imaginary part of 0.

gcl-2.6.14/info/gcl/copy_002dpprint_002ddispatch.html0000644000175000017500000000570714360276512020573 0ustar cammcamm copy-pprint-dispatch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.1 copy-pprint-dispatch [Function]

copy-pprint-dispatch &optional table ⇒ new-table

Arguments and Values::

table—a pprint dispatch table, or nil.

new-table—a fresh pprint dispatch table.

Description::

Creates and returns a copy of the specified table, or of the value of *print-pprint-dispatch* if no table is specified, or of the initial value of *print-pprint-dispatch* if nil is specified.

Exceptional Situations::

Should signal an error of type type-error if table is not a pprint dispatch table.

gcl-2.6.14/info/gcl/Examples-of-Sharpsign-Vertical_002dBar.html0000644000175000017500000001223514360276512022421 0ustar cammcamm Examples of Sharpsign Vertical-Bar (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.21 Examples of Sharpsign Vertical-Bar

The following are some examples that exploit the #|...|# notation: 

;;; In this example, some debugging code is commented out with #|...|#
;;; Note that this kind of comment can occur in the middle of a line
;;; (because a delimiter marks where the end of the comment occurs)
;;; where a semicolon comment can only occur at the end of a line 
;;; (because it comments out the rest of the line).
 (defun add3 (n) #|(format t "~&Adding 3 to ~D." n)|# (+ n 3))

;;; The examples that follow show issues related to #| ... |# nesting.

;;; In this first example, #| and |# always occur properly paired,
;;; so nesting works naturally.
 (defun mention-fun-fact-1a ()
   (format t "CL uses ; and #|...|# in comments."))
⇒  MENTION-FUN-FACT-1A
 (mention-fun-fact-1a)
 |>  CL uses ; and #|...|# in comments.
⇒  NIL
 #| (defun mention-fun-fact-1b ()
      (format t "CL uses ; and #|...|# in comments.")) |#
 (fboundp 'mention-fun-fact-1b) ⇒  NIL

;;; In this example, vertical-bar followed by sharpsign needed to appear
;;; in a string without any matching sharpsign followed by vertical-bar
;;; having preceded this.  To compensate, the programmer has included a
;;; slash separating the two characters.  In case 2a, the slash is 
;;; unnecessary but harmless, but in case 2b, the slash is critical to
;;; allowing the outer #| ... |# pair match.  If the slash were not present,
;;; the outer comment would terminate prematurely.
 (defun mention-fun-fact-2a ()
   (format t "Don't use |\# unmatched or you'll get in trouble!"))
⇒  MENTION-FUN-FACT-2A
 (mention-fun-fact-2a)
 |>  Don't use |# unmatched or you'll get in trouble!
⇒  NIL
 #| (defun mention-fun-fact-2b ()
      (format t "Don't use |\# unmatched or you'll get in trouble!") |#
 (fboundp 'mention-fun-fact-2b) ⇒  NIL

;;; In this example, the programmer attacks the mismatch problem in a
;;; different way.  The sharpsign vertical bar in the comment is not needed
;;; for the correct parsing of the program normally (as in case 3a), but 
;;; becomes important to avoid premature termination of a comment when such 
;;; a program is commented out (as in case 3b).
 (defun mention-fun-fact-3a () ; #|
   (format t "Don't use |# unmatched or you'll get in trouble!"))
⇒  MENTION-FUN-FACT-3A
 (mention-fun-fact-3a)
 |>  Don't use |# unmatched or you'll get in trouble!
⇒  NIL
 #|
 (defun mention-fun-fact-3b () ; #|
   (format t "Don't use |# unmatched or you'll get in trouble!"))
 |#
 (fboundp 'mention-fun-fact-3b) ⇒  NIL

Next: , Previous: , Up: Sharpsign  

gcl-2.6.14/info/gcl/Implementation_002dDefined-Packages.html0000644000175000017500000000472214360276512022073 0ustar cammcamm Implementation-Defined Packages (ANSI and GNU Common Lisp Document)

Previous: , Up: Standardized Packages  

11.1.2.9 Implementation-Defined Packages

Other, implementation-defined packages might be present in the initial Common Lisp environment.

It is recommended, but not required, that the documentation for a conforming implementation contain a full list of all package names initially present in that implementation but not specified in this specification. (See also the function list-all-packages.)

gcl-2.6.14/info/gcl/_002d.html0000644000175000017500000000717414360276512014176 0ustar cammcamm - (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.26 - [Function]

- number ⇒ negation

- minuend &rest subtrahends^+ ⇒ difference

Arguments and Values::

number, minuend, subtrahend—a number.

negation, difference—a number.

Description::

The function - performs arithmetic subtraction and negation.

If only one number is supplied, the negation of that number is returned.

If more than one argument is given, it subtracts all of the subtrahends from the minuend and returns the result.

The function - performs necessary type conversions.

Examples::

 (- 55.55) ⇒  -55.55
 (- #c(3 -5)) ⇒  #C(-3 5)
 (- 0) ⇒  0
 (eql (- 0.0) -0.0) ⇒  true
 (- #c(100 45) #c(0 45)) ⇒  100
 (- 10 1 2 3 4) ⇒  0

Exceptional Situations::

Might signal type-error if some argument is not a number. Might signal arithmetic-error.

See Also::

Numeric Operations, Rational Computations, Floating-point Computations, Complex Computations

gcl-2.6.14/info/gcl/Dictionary-Entries-for-Type-Specifiers.html0000644000175000017500000000714614360276512022702 0ustar cammcamm Dictionary Entries for Type Specifiers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.6 Dictionary Entries for Type Specifiers

The atomic type specifiers are those defined names listed in Figure~4–2. Such dictionary entries are of kind “Class,” “Condition Type,” “System Class,” or “Type.” A description of how to interpret a symbol naming one of these types or classes as an atomic type specifier is found in The "Description" Section of such dictionary entries.

The compound type specifiers are those defined names listed in Figure~4–3. Such dictionary entries are of kind “Class,” “System Class,” “Type,” or “Type Specifier.” A description of how to interpret as a compound type specifier a list whose car is such a symbol is found in the “Compound Type Specifier Kind,” “Compound Type Specifier Syntax,” “Compound Type Specifier Arguments,” and “Compound Type Specifier Description” sections of such dictionary entries.

gcl-2.6.14/info/gcl/FORMAT-Miscellaneous-Pseudo_002dOperations.html0000644000175000017500000000562514360276512023210 0ustar cammcamm FORMAT Miscellaneous Pseudo-Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.9 FORMAT Miscellaneous Pseudo-Operations

• Tilde Semicolon-> Clause Separator  
• Tilde Circumflex-> Escape Upward  
• Tilde Newline-> Ignored Newline  
gcl-2.6.14/info/gcl/Overview-of-Places-and-Generalized-Reference.html0000644000175000017500000001401414360276512023661 0ustar cammcamm Overview of Places and Generalized Reference (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generalized Reference  

5.1.1 Overview of Places and Generalized Reference

A generalized reference is the use of a form, sometimes called a place , as if it were a variable that could be read and written. The value of a place is the object to which the place form evaluates. The value of a place can be changed by using setf. The concept of binding a place is not defined in Common Lisp, but an implementation is permitted to extend the language by defining this concept.

Figure 5–1 contains examples of the use of setf. Note that the values returned by evaluating the forms in column two are not necessarily the same as those obtained by evaluating the forms in column three. In general, the exact macro expansion of a setf form is not guaranteed and can even be implementation-dependent; all that is guaranteed is that the expansion is an update form that works for that particular implementation, that the left-to-right evaluation of subforms is preserved, and that the ultimate result of evaluating setf is the value or values being stored. 

  Access function   Update Function   Update using setf              
  x                 (setq x datum)    (setf x datum)                 
  (car x)           (rplaca x datum)  (setf (car x) datum)           
  (symbol-value x)  (set x datum)     (setf (symbol-value x) datum)  

                     Figure 5–1: Examples of setf

Figure 5–2 shows operators relating to places and generalized reference. 

  assert                defsetf             push     
  ccase                 get-setf-expansion  remf     
  ctypecase             getf                rotatef  
  decf                  incf                setf     
  define-modify-macro   pop                 shiftf   
  define-setf-expander  psetf                        

  Figure 5–2: Operators relating to places and generalized reference.

Some of the operators above manipulate places and some manipulate setf expanders. A setf expansion can be derived from any place.

New setf expanders can be defined by using defsetf and define-setf-expander.

• Evaluation of Subforms to Places  
• Examples of Evaluation of Subforms to Places  
• Setf Expansions  
• Examples of Setf Expansions  

Next: , Previous: , Up: Generalized Reference  

gcl-2.6.14/info/gcl/float-_0028System-Class_0029.html0000644000175000017500000001404114360276512020136 0ustar cammcamm float (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.4 float [System Class]

Class Precedence List::

float,

real,

number, t

Description::

A float is a mathematical rational (but not a Common Lisp rational) of the form s\cdot f\cdot b^e-p, where s is +1 or -1, the sign; b is an integer greater than~1, the base or radix of the representation; p is a positive integer, the precision (in base-b digits) of the float; f is a positive integer between b^p-1 and b^p-1 (inclusive), the significand; and e is an integer, the exponent. The value of p and the range of~e depends on the implementation and on the type of float within that implementation. In addition, there is a floating-point zero; depending on the implementation, there can also be a “minus zero”. If there is no minus zero, then 0.0 and~-0.0 are both interpreted as simply a floating-point zero. (= 0.0 -0.0) is always true. If there is a minus zero, (eql -0.0 0.0) is false, otherwise it is true.

[Reviewer Note by Barmar: What about IEEE NaNs and infinities?]

[Reviewer Note by RWK: In the following, what is the “ordering”? precision? range? Can there be additional subtypes of float or does “others” in the list of four?]

The types short-float, single-float, double-float, and long-float are subtypes of type float. Any two of them must be either disjoint types or the same type; if the same type, then any other types between them in the above ordering must also be the same type. For example, if the type single-float and the type long-float are the same type, then the type double-float must be the same type also.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(float{[lower-limit [upper-limit]]})

Compound Type Specifier Arguments::

lower-limit, upper-limit—interval designators for type float. The defaults for each of lower-limit and upper-limit is the symbol *.

Compound Type Specifier Description::

This denotes the floats on the interval described by lower-limit and upper-limit.

See Also::

Figure~2–9, Constructing Numbers from Tokens, Printing Floats

Notes::

Note that all mathematical integers are representable not only as Common Lisp reals, but also as complex floats. For example, possible representations of the mathematical number 1 include the integer 1, the float 1.0, or the complex #C(1.0 0.0).

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/_002aprint_002dpretty_002a.html0000644000175000017500000001140514360276512017757 0ustar cammcamm *print-pretty* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.26 *print-pretty* [Variable]

Value Type::

a generalized boolean.

Initial Value::

implementation-dependent.

Description::

Controls whether the Lisp printer calls the pretty printer.

If it is false, the pretty printer is not used and

a minimum

of whitespace_1 is output when printing an expression.

If it is true, the pretty printer is used, and the Lisp printer will endeavor to insert extra whitespace_1 where appropriate to make expressions more readable.

*print-pretty* has an effect even when the value of *print-escape* is false.

Examples::

 (setq *print-pretty* 'nil) ⇒  NIL
 (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil)
 |>  (LET ((A 1) (B 2) (C 3)) (+ A B C))
⇒  NIL
 (let ((*print-pretty* t))
   (progn (write '(let ((a 1) (b 2) (c 3)) (+ a b c))) nil))
 |>  (LET ((A 1)
 |>        (B 2)
 |>        (C 3))
 |>    (+ A B C))
⇒  NIL
;; Note that the first two expressions printed by this next form
;; differ from the second two only in whether escape characters are printed.
;; In all four cases, extra whitespace is inserted by the pretty printer.
 (flet ((test (x)
          (let ((*print-pretty* t))
            (print x)
            (format t "~
            (terpri) (princ x) (princ " ")
            (format t "~
  (test '#'(lambda () (list "a" #’c #'d))))
 |>  #'(LAMBDA ()
 |>      (LIST "a" #’C #'D))
 |>  #'(LAMBDA ()
 |>      (LIST "a" #’C #'D))
 |>  #'(LAMBDA ()
 |>      (LIST a b 'C #'D)) 
 |>  #'(LAMBDA ()
 |>      (LIST a b 'C #'D))
⇒  NIL

See Also::

write

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Merging-Pathnames.html0000644000175000017500000000553014360276512016672 0ustar cammcamm Merging Pathnames (ANSI and GNU Common Lisp Document)

Previous: , Up: Pathnames  

19.2.3 Merging Pathnames

Merging takes a pathname with unfilled components and supplies values for those components from a source of defaults.

If a component’s value is nil, that component is considered to be unfilled. If a component’s value is any non-nil object, including :unspecific, that component is considered to be filled.

Except as explicitly specified otherwise, for functions that manipulate or inquire about files in the file system, the pathname argument to such a function is merged with *default-pathname-defaults* before accessing the file system (as if by merge-pathnames).

• Examples of Merging Pathnames  
gcl-2.6.14/info/gcl/Syntax.html0000644000175000017500000000525114360276512014652 0ustar cammcamm Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

2 Syntax

• Character Syntax  
• Reader Algorithm  
• Interpretation of Tokens  
• Standard Macro Characters  
gcl-2.6.14/info/gcl/Setf-Expansions.html0000644000175000017500000001146514360276512016416 0ustar cammcamm Setf Expansions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of Places and Generalized Reference  

5.1.1.3 Setf Expansions

Sometimes it is possible to avoid evaluating subforms of a place multiple times or in the wrong order. A

setf expansion

for a given access form can be expressed as an ordered collection of five objects:

List of temporary variables

a list of symbols naming temporary variables to be bound sequentially, as if by let*, to values resulting from value forms.

List of value forms

a list of forms (typically, subforms of the place) which when evaluated yield the values to which the corresponding temporary variables should be bound.

List of store variables

a list of symbols naming temporary store variables which are to hold the new values that will be assigned to the place.

Storing form

a form which can reference both the temporary and the store variables, and which changes the value of the place and guarantees to return as its values the values of the store variables, which are the correct values for setf to return.

Accessing form

a form which can reference the temporary variables, and which returns the value of the place.

The value returned by the accessing form is affected by execution of the storing form, but either of these forms might be evaluated any number of times.

It is possible to do more than one setf in parallel via psetf, shiftf, and rotatef. Because of this, the

setf expander

must produce new temporary and store variable names every time. For examples of how to do this, see gensym.

For each standardized accessor function F, unless it is explicitly documented otherwise, it is implementation-dependent whether the ability to use an F form as a setf place is implemented by a setf expander or a setf function. Also, it follows from this that it is implementation-dependent whether the name (setf F) is fbound.

Next: , Previous: , Up: Overview of Places and Generalized Reference  

gcl-2.6.14/info/gcl/_002aread_002deval_002a.html0000644000175000017500000000612114360276512017135 0ustar cammcamm *read-eval* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.15 *read-eval* [Variable]

Value Type::

a generalized boolean.

Initial Value::

true.

Description::

If it is true, the #. reader macro has its normal effect. Otherwise, that reader macro signals an error of type reader-error.

See Also::

*print-readably*

Notes::

If *read-eval* is false and *print-readably* is true, any method for print-object that would output a reference to the #. reader macro either outputs something different or signals an error of type print-not-readable.

gcl-2.6.14/info/gcl/Odd-Number-of-Keyword-Arguments.html0000644000175000017500000000510514360276512021305 0ustar cammcamm Odd Number of Keyword Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.7 Odd Number of Keyword Arguments

An odd number of arguments must not be supplied for the keyword parameters.

If this situation occurs in a safe call,

an error of type program-error must be signaled unless keyword argument checking is suppressed as described in Suppressing Keyword Argument Checking; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/logical_002dpathname_002dtranslations.html0000644000175000017500000002667214360276512022442 0ustar cammcamm logical-pathname-translations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.8 logical-pathname-translations [Accessor]

logical-pathname-translations host ⇒ translations

(setf ( logical-pathname-translations host) new-translations)

Arguments and Values::

host–a logical host designator.

translations, new-translations—a list.

Description::

Returns the host’s list of translations. Each translation is a list of at least two elements: from-wildcard and to-wildcard. Any additional elements are implementation-defined. From-wildcard is a logical pathname whose host is host. To-wildcard is a pathname.

[Reviewer Note by Laddaga: Can this be a logical pathname?]

(setf (logical-pathname-translations host) translations) sets a logical pathname host’s list of translations. If host is a string that has not been previously used as a logical pathname host, a new logical pathname host is defined; otherwise an existing host’s translations are replaced. logical pathname host names are compared with string-equal.

When setting the translations list, each from-wildcard can be a logical pathname whose host is host or a logical pathname namestring parseable by (parse-namestring string host), where host represents the appropriate object as defined by parse-namestring. Each to-wildcard can be anything coercible to a pathname by (pathname to-wildcard). If to-wildcard coerces to a logical pathname, translate-logical-pathname will perform repeated translation steps when it uses it.

host is either the host component of a logical pathname or a string that has been defined as a logical pathname host name by setf of logical-pathname-translations.

Examples::

[Reviewer Note by Laddaga: Shouldn’t there be some *.*’s in the list of translations for PROG below?] 

 ;;;A very simple example of setting up a logical pathname host.  No
 ;;;translations are necessary to get around file system restrictions, so
 ;;;all that is necessary is to specify the root of the physical directory
 ;;;tree that contains the logical file system.
 ;;;The namestring syntax on the right-hand side is implementation-dependent.
 (setf (logical-pathname-translations "foo")
       '(("**;*.*.*"              "MY-LISPM:>library>foo>**>")))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "foo:bar;baz;mum.quux.3")
⇒  #P"MY-LISPM:>library>foo>bar>baz>mum.quux.3"

 ;;;A more complex example, dividing the files among two file servers
 ;;;and several different directories.  This Unix doesn't support
 ;;;:WILD-INFERIORS in the directory, so each directory level must
 ;;;be translated individually.  No file name or type translations
 ;;;are required except for .MAIL to .MBX.
 ;;;The namestring syntax on the right-hand side is implementation-dependent.
 (setf (logical-pathname-translations "prog")
       '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
         ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
         ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
         ("EXPERIMENTAL;DOCUMENTATION;*.*.*"
                                  "MY-VAX:SYS$DISK:[JOE.DOC]")
         ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")
         ("MAIL;**;*.MAIL"        "MY-VAX:SYS$DISK:[JOE.MAIL.PROG...]*.MBX")))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "prog:mail;save;ideas.mail.3")
⇒  #P"MY-VAX:SYS$DISK:[JOE.MAIL.PROG.SAVE]IDEAS.MBX.3"

 ;;;Example translations for a program that uses three files main.lisp,
 ;;;auxiliary.lisp, and documentation.lisp.  These translations might be
 ;;;supplied by a software supplier as examples.

 ;;;For Unix with long file names
 (setf (logical-pathname-translations "prog")
       '(("CODE;*.*.*"             "/lib/prog/")))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "prog:code;documentation.lisp")
⇒  #P"/lib/prog/documentation.lisp"

 ;;;For Unix with 14-character file names, using .lisp as the type
 (setf (logical-pathname-translations "prog")
       '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
         ("CODE;*.*.*"             "/lib/prog/")))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "prog:code;documentation.lisp")
⇒  #P"/lib/prog/docum.lisp"

 ;;;For Unix with 14-character file names, using .l as the type
 ;;;The second translation shortens the compiled file type to .b
 (setf (logical-pathname-translations "prog")
       `(("**;*.LISP.*"            ,(logical-pathname "PROG:**;*.L.*"))
         (,(compile-file-pathname (logical-pathname "PROG:**;*.LISP.*"))
                                   ,(logical-pathname "PROG:**;*.B.*"))
         ("CODE;DOCUMENTATION.*.*" "/lib/prog/documentatio.*")
         ("CODE;*.*.*"             "/lib/prog/")))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "prog:code;documentation.lisp")
⇒  #P"/lib/prog/documentatio.l"

 ;;;For a Cray with 6 character names and no directories, types, or versions.
 (setf (logical-pathname-translations "prog")
       (let ((l '(("MAIN" "PGMN")
                  ("AUXILIARY" "PGAUX")
                  ("DOCUMENTATION" "PGDOC")))
             (logpath (logical-pathname "prog:code;"))
             (phypath (pathname "XXX")))
         (append
           ;; Translations for source files
           (mapcar #'(lambda (x)
                       (let ((log (first x))
                             (phy (second x)))
                         (list (make-pathname :name log
                                              :type "LISP"
                                              :version :wild
                                              :defaults logpath)
                               (make-pathname :name phy
                                              :defaults phypath))))
                   l)
           ;; Translations for compiled files
           (mapcar #'(lambda (x)
                       (let* ((log (first x))
                              (phy (second x))
                              (com (compile-file-pathname
                                     (make-pathname :name log
                                                    :type "LISP"
                                                    :version :wild
                                                    :defaults logpath))))
                         (setq phy (concatenate 'string phy "B"))
                         (list com
                               (make-pathname :name phy
                                              :defaults phypath))))
                   l))))

 ;;;Sample use of that logical pathname.  The return value
 ;;;is implementation-dependent.          
 (translate-logical-pathname "prog:code;documentation.lisp")
⇒  #P"PGDOC"

Exceptional Situations::

If host is incorrectly supplied, an error of type type-error is signaled.

See Also::

logical-pathname,

Pathnames as Filenames

Notes::

Implementations can define additional functions that operate on logical pathname hosts, for example to specify additional translation rules or options.

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/Missing-and-Additional-FORMAT-Arguments.html0000644000175000017500000000477014360276512022541 0ustar cammcamm Missing and Additional FORMAT Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Additional Information about FORMAT Operations  

22.3.10.2 Missing and Additional FORMAT Arguments

The consequences are undefined if no arg remains for a directive requiring an argument. However, it is permissible for one or more args to remain unprocessed by a directive; such args are ignored.

gcl-2.6.14/info/gcl/Uppercase-Characters.html0000644000175000017500000000451714360276512017374 0ustar cammcamm Uppercase Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.4 Uppercase Characters

An uppercase character is one that has a corresponding lowercase character that is different (and can be obtained using char-downcase).

Of the standard characters, only these are uppercase characters:

A B C D E F G H I J K L M N O P Q R S T U V W X Y Z

gcl-2.6.14/info/gcl/Visible-Modification-of-Hash-Tables-with-respect-to-EQUALP.html0000644000175000017500000000554214360276512026103 0ustar cammcamm Visible Modification of Hash Tables with respect to EQUALP (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.8 Visible Modification of Hash Tables with respect to EQUALP

In a hash table, any visible change to the count of entries in the hash table, to the keys, or to the values associated with the keys is considered a visible modification with regard to equalp.

Note that the visibility of modifications to the keys depends on the equivalence test of the hash table, not on the specification of equalp.

gcl-2.6.14/info/gcl/read_002dchar.html0000644000175000017500000001122414360276512015657 0ustar cammcamm read-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.17 read-char [Function]

read-char &optional input-stream eof-error-p eof-value recursive-p ⇒ char

Arguments and Values::

input-stream—an input stream designator. The default is standard input.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object. The default is nil.

recursive-p—a generalized boolean. The default is false.

char—a character or the eof-value.

Description::

read-char returns the next character from input-stream.

When input-stream is an echo stream, the character is echoed on input-stream the first time the character is seen. Characters that are not echoed by read-char are those that were put there by unread-char and hence are assumed to have been echoed already by a previous call to read-char.

If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader.

If an end of file_2 occurs and eof-error-p is false, eof-value is returned.

Examples::

 (with-input-from-string (is "0123")
    (do ((c (read-char is) (read-char is nil 'the-end)))
        ((not (characterp c)))
     (format t "~S " c)))
 |>  #\0 #\1 #\2 #\3
⇒  NIL

Affected By::

*standard-input*, *terminal-io*.

Exceptional Situations::

If an end of file_2 occurs before a character can be read, and eof-error-p is true, an error of type end-of-file is signaled.

See Also::

read-byte ,

read-sequence ,

write-char , read

Notes::

The corresponding output function is write-char.

gcl-2.6.14/info/gcl/Error-Checking-in-Function-Calls.html0000644000175000017500000000467114360276512021416 0ustar cammcamm Error Checking in Function Calls (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.5 Error Checking in Function Calls

• Argument Mismatch Detection  
gcl-2.6.14/info/gcl/Sharpsign-C.html0000644000175000017500000000644114360276512015504 0ustar cammcamm Sharpsign C (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.12 Sharpsign C

#C reads a following object, which must be a list of length two whose elements are both reals. These reals denote, respectively, the real and imaginary parts of a complex number.

If the two parts as notated are not of the same data type, then they are converted according to the rules of floating-point contagion described in Contagion in Numeric Operations.

#C(real imag) is equivalent to #.(complex (quote real) (quote imag)), except that #C is not affected by *read-eval*. See the function complex.

Figure 2–21 contains examples of the use of #C. 

  #C(3.0s1 2.0s-1)  ;A complex with small float parts.                
  #C(5 -3)          ;A “Gaussian integer”                             
  #C(5/3 7.0)       ;Will be converted internally to #C(1.66666 7.0)  
  #C(0 1)           ;The imaginary unit; that is, i.                  

                  Figure 2–21: Complex Number Example

For further information, see Printing Complexes and Syntax of a Complex.

gcl-2.6.14/info/gcl/vector.html0000644000175000017500000000644714360276512014676 0ustar cammcamm vector (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.29 vector [Function]

vector &rest objects ⇒ vector

Arguments and Values::

object—an object.

vector—a vector of type (vector t *).

Description::

Creates a fresh simple general vector whose size corresponds to the number of objects.

The vector is initialized to contain the objects.

Examples::

 (arrayp (setq v (vector 1 2 'sirens))) ⇒  true
 (vectorp v) ⇒  true
 (simple-vector-p v) ⇒  true         
 (length v) ⇒  3

See Also::

make-array

Notes::

vector is analogous to list. 

 (vector a_1 a_2 ... a_n)
  ≡ (make-array (list n) :element-type t
                          :initial-contents 
                            (list a_1 a_2 ... a_n))
gcl-2.6.14/info/gcl/Printing-Floats.html0000644000175000017500000000722114360276512016403 0ustar cammcamm Printing Floats (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.4 Printing Floats

If the magnitude of the float is either zero or between 10^-3 (inclusive) and 10^7 (exclusive), it is printed as the integer part of the number, then a decimal point, followed by the fractional part of the number; there is always at least one digit on each side of the decimal point. If the sign of the number (as determined by float-sign) is negative, then a minus sign is printed before the number. If the format of the number does not match that specified by *read-default-float-format*, then the exponent marker for that format and the digit 0 are also printed. For example, the base of the natural logarithms as a short float might be printed as 2.71828S0.

For non-zero magnitudes outside of the range 10^-3 to 10^7, a float is printed in computerized scientific notation. The representation of the number is scaled to be between 1 (inclusive) and 10 (exclusive) and then printed, with one digit before the decimal point and at least one digit after the decimal point. Next the exponent marker for the format is printed, except that if the format of the number matches that specified by *read-default-float-format*, then the exponent marker E is used. Finally, the power of ten by which the fraction must be multiplied to equal the original number is printed as a decimal integer. For example, Avogadro’s number as a short float is printed as 6.02S23.

For related information about the syntax of a float, see Syntax of a Float.

gcl-2.6.14/info/gcl/ignore_002derrors.html0000644000175000017500000001102214360276512016622 0ustar cammcamm ignore-errors (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.28 ignore-errors [Macro]

ignore-errors {form}* ⇒ {result}*

Arguments and Values::

forms—an implicit progn.

results—In the normal situation, the values of the forms are returned; in the exceptional situation, two values are returned: nil and the condition.

Description::

ignore-errors is used to prevent conditions of type error from causing entry into the debugger.

Specifically, ignore-errors executes forms in a dynamic environment where a handler for conditions of type error has been established; if invoked, it handles such conditions by returning two values, nil and the condition that was signaled, from the ignore-errors form.

If a normal return from the forms occurs, any values returned are returned by ignore-errors.

Examples::

 (defun load-init-file (program)
   (let ((win nil))
     (ignore-errors ;if this fails, don't enter debugger
       (load (merge-pathnames (make-pathname :name program :type :lisp)
                              (user-homedir-pathname)))
       (setq win t))
     (unless win (format t "~&Init file failed to load.~
     win))

 (load-init-file "no-such-program")
 |>  Init file failed to load.
NIL

See Also::

handler-case , Condition System Concepts

Notes::

 (ignore-errors . forms)

is equivalent to: 

 (handler-case (progn . forms)
   (error (condition) (values nil condition)))

Because the second return value is a condition in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or nil so that the two situations can be distinguished.

gcl-2.6.14/info/gcl/Summary-of-Variable-Initialization-and-Stepping-Clauses.html0000644000175000017500000000576614360276512026072 0ustar cammcamm Summary of Variable Initialization and Stepping Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.8 Summary of Variable Initialization and Stepping Clauses

The for and as constructs provide iteration control clauses that establish a variable to be initialized. for and as clauses can be combined with the loop keyword and to get parallel initialization and stepping_1. Otherwise, the initialization and stepping_1 are sequential.

The with construct is similar to a single let clause. with clauses can be combined using the loop keyword and to get parallel initialization.

For more information, see Variable Initialization and Stepping Clauses.

gcl-2.6.14/info/gcl/endp.html0000644000175000017500000000745514360276512014322 0ustar cammcamm endp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.23 endp [Function]

endp list ⇒ generalized-boolean

Arguments and Values::

list—a list,

which might be a dotted list or a circular list.

generalized-boolean—a generalized boolean.

Description::

Returns true if list is the empty list. Returns false if list is a cons.

Examples::

 (endp nil) ⇒  true
 (endp '(1 2)) ⇒  false
 (endp (cddr '(1 2))) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if list is not a list.

Notes::

The purpose of endp is to test for the end of proper list. Since endp does not descend into a cons, it is well-defined to pass it a dotted list. However, if shorter “lists” are iteratively produced by calling cdr on such a dotted list and those “lists” are tested with endp, a situation that has undefined consequences will eventually result when the non-nil atom (which is not in fact a list) finally becomes the argument to endp. Since this is the usual way in which endp is used, it is conservative programming style and consistent with the intent of endp to treat endp as simply a function on proper lists which happens not to enforce an argument type of proper list except when the argument is atomic.

gcl-2.6.14/info/gcl/Built_002din-Method-Combination-Types.html0000644000175000017500000001627714360276512022311 0ustar cammcamm Built-in Method Combination Types (ANSI and GNU Common Lisp Document)

Previous: , Up: Method Selection and Combination  

7.6.6.7 Built-in Method Combination Types

The object system provides a set of built-in method combination types. To specify that a generic function is to use one of these method combination types, the name of the method combination type is given as the argument to the :method-combination option to defgeneric or to the :method-combination option to any of the other operators that specify generic function options.

The names of the built-in method combination types are listed in Figure 7–3. 

  +    append  max  nconc  progn     
  and  list    min  or     standard  

  Figure 7–3: Built-in Method Combination Types

The semantics of the standard built-in method combination type is described in Standard Method Combination. The other built-in method combination types are called simple built-in method combination types.

The simple built-in method combination types act as though they were defined by the short form of define-method-combination. They recognize two roles for methods:

*

An around method has the keyword symbol :around as its sole qualifier. The meaning of :around methods is the same as in standard method combination. Use of the functions call-next-method and next-method-p is supported in around methods.

*

A primary method has the name of the method combination type as its sole qualifier. For example, the built-in method combination type and recognizes methods whose sole qualifier is and; these are primary methods. Use of the functions call-next-method and next-method-p is not supported in primary methods.

The semantics of the simple built-in method combination types is as follows:

*

If there are any around methods, the most specific around method is called. It supplies the value or values of the generic function.

*

Inside the body of an around method, the function call-next-method can be used to call the next method. The generic function no-next-method is invoked if call-next-method is used and there is no applicable method to call. The function next-method-p may be used to determine whether a next method exists. When the next method returns, the around method can execute more code, perhaps based on the returned value or values.

*

If an around method invokes call-next-method, the next most specific around method is called, if one is applicable. If there are no around methods or if call-next-method is called by the least specific around method, a Lisp form derived from the name of the built-in method combination type and from the list of applicable primary methods is evaluated to produce the value of the generic function. Suppose the name of the method combination type is operator and the call to the generic function is of the form

(generic-function a_1... a_n)

Let M_1,...,M_k be the applicable primary methods in order; then the derived Lisp form is

(operator < M_1

a_1... a_n>...< M_k a_1... a_n>)

If the expression < M_i a_1... a_n> is evaluated, the method M_i will be applied to the arguments a_1... a_n. For example, if operator is or, the expression < M_i a_1... a_n> is evaluated only if < M_j a_1... a_n>, 1<= j<i, returned nil.

The default order for the primary methods is :most-specific-first. However, the order can be reversed by supplying :most-specific-last as the second argument to the :method-combination option.

The simple built-in method combination types require exactly one qualifier per method. An error is signaled if there are applicable methods with no qualifiers or with qualifiers that are not supported by the method combination type. An error is signaled if there are applicable around methods and no applicable primary methods.

Previous: , Up: Method Selection and Combination  

gcl-2.6.14/info/gcl/eql-_0028Type-Specifier_0029.html0000644000175000017500000000577414360276512020130 0ustar cammcamm eql (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.23 eql [Type Specifier]

Compound Type Specifier Kind::

Combining.

Compound Type Specifier Syntax::

(eql{object})

Compound Type Specifier Arguments::

object—an object.

Compound Type Specifier Description::

Represents the type whose only element is object.

The argument object is required. The object can be *, but if so it denotes itself (the symbol *) and does not represent an unspecified value. The symbol eql is not valid as an atomic type specifier.

gcl-2.6.14/info/gcl/Tilde-Right_002dBracket_002d_003e-End-of-Conditional-Expression.html0000644000175000017500000000502714360276512026502 0ustar cammcamm Tilde Right-Bracket-> End of Conditional Expression (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.3 Tilde Right-Bracket: End of Conditional Expression

~] terminates a ~[. The consequences of using it elsewhere are undefined.

gcl-2.6.14/info/gcl/Examples-of-Declaration-Scope.html0000644000175000017500000001340614360276512021037 0ustar cammcamm Examples of Declaration Scope (ANSI and GNU Common Lisp Document)

Previous: , Up: Declaration Scope  

3.3.4.1 Examples of Declaration Scope

Here is an example illustrating the scope of bound declarations. 

 (let ((x 1))                ;[1] 1st occurrence of x
   (declare (special x))     ;[2] 2nd occurrence of x
   (let ((x 2))              ;[3] 3rd occurrence of x
     (let ((old-x x)         ;[4] 4th occurrence of x
           (x 3))            ;[5] 5th occurrence of x
       (declare (special x)) ;[6] 6th occurrence of x
       (list old-x x))))     ;[7] 7th occurrence of x
⇒  (2 3)

The first occurrence of x establishes a dynamic binding of x because of the special declaration for x in the second line. The third occurrence of x establishes a lexical binding of x (because there is no special declaration in the corresponding let form). The fourth occurrence of x x is a reference to the lexical binding of x established in the third line. The fifth occurrence of x establishes a dynamic binding of x for the body of the let form that begins on that line because of the special declaration for x in the sixth line. The reference to x in the fourth line is not affected by the special declaration in the sixth line because that reference is not within the “would-be lexical scope” of the variable x in the fifth line. The reference to x in the seventh line is a reference to the dynamic binding of x established in the fifth line.

Here is another example, to illustrate the scope of a free declaration. In the following: 

 (lambda (&optional (x (foo 1))) ;[1]
   (declare (notinline foo))     ;[2]
   (foo x))                      ;[3]

the call to foo in the first line might be compiled inline even though the call to foo in the third line must not be. This is because the notinline declaration for foo in the second line applies only to the body on the third line. In order to suppress inlining for both calls, one might write: 

 (locally (declare (notinline foo)) ;[1]
   (lambda (&optional (x (foo 1)))  ;[2]
     (foo x)))                      ;[3]

or, alternatively: 

 (lambda (&optional                               ;[1]
            (x (locally (declare (notinline foo)) ;[2]
                 (foo 1))))                       ;[3]
   (declare (notinline foo))                      ;[4]
   (foo x))                                       ;[5]

Finally, here is an example that shows the scope of declarations in an iteration form. 

 (let ((x  1))                     ;[1]
   (declare (special x))           ;[2]
     (let ((x 2))                  ;[3]
       (dotimes (i x x)            ;[4]
         (declare (special x)))))  ;[5]
⇒  1

In this example, the first reference to x on the fourth line is to the lexical binding of x established on the third line. However, the second occurrence of x on the fourth line lies within the scope of the free declaration on the fifth line (because this is the result-form of the dotimes) and therefore refers to the dynamic binding of x.

Previous: , Up: Declaration Scope  

gcl-2.6.14/info/gcl/cerror.html0000644000175000017500000002072114360276512014657 0ustar cammcamm cerror (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.12 cerror [Function]

cerror continue-format-control datum &rest arguments ⇒ nil

Arguments and Values::

Continue-format-control—a format control.

[Reviewer Note by Barmar: What is continue-format-control used for??]

datum, arguments—designators for a condition of default type simple-error.

Description::

cerror effectively invokes error on the condition named by datum. As with any function that implicitly calls error, if the condition is not handled, (invoke-debugger condition) is executed. While signaling is going on, and while in the debugger if it is reached, it is possible to continue code execution (i.e., to return from cerror) using the continue restart.

If datum is a condition, arguments can be supplied, but are used only in conjunction with the continue-format-control.

Examples::

 (defun real-sqrt (n)
   (when (minusp n)
     (setq n (- n))
     (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n))
   (sqrt n))

 (real-sqrt 4)
⇒  2.0

 (real-sqrt -9)
 |>  Correctable error in REAL-SQRT: Tried to take sqrt(-9).
 |>  Restart options:
 |>   1: Return sqrt(9) instead.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
⇒  3.0

 (define-condition not-a-number (error)
   ((argument :reader not-a-number-argument :initarg :argument))
   (:report (lambda (condition stream)
              (format stream "~S is not a number." 
                      (not-a-number-argument condition)))))

 (defun assure-number (n)
   (loop (when (numberp n) (return n))
         (cerror "Enter a number."
                 'not-a-number :argument n)
         (format t "~&Type a number: ")
         (setq n (read))
         (fresh-line)))

 (assure-number 'a)
 |>  Correctable error in ASSURE-NUMBER: A is not a number.
 |>  Restart options:
 |>   1: Enter a number.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Type a number: |>>1/2<<|
⇒  1/2

 (defun assure-large-number (n)
   (loop (when (and (numberp n) (> n 73)) (return n))
         (cerror "Enter a number~:[~; a bit larger than ~D~]."
                 "~*~A is not a large number." 
                 (numberp n) n)
         (format t "~&Type a large number: ")
         (setq n (read))
         (fresh-line)))

 (assure-large-number 10000)
⇒  10000

 (assure-large-number 'a)
 |>  Correctable error in ASSURE-LARGE-NUMBER: A is not a large number.
 |>  Restart options:
 |>   1: Enter a number.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Type a large number: |>>88<<|
⇒  88

 (assure-large-number 37)
 |>  Correctable error in ASSURE-LARGE-NUMBER: 37 is not a large number.
 |>  Restart options:
 |>   1: Enter a number a bit larger than 37.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Type a large number: |>>259<<|
⇒  259

 (define-condition not-a-large-number (error)
   ((argument :reader not-a-large-number-argument :initarg :argument))
   (:report (lambda (condition stream)
              (format stream "~S is not a large number." 
                      (not-a-large-number-argument condition)))))

 (defun assure-large-number (n)
   (loop (when (and (numberp n) (> n 73)) (return n))
         (cerror "Enter a number~3*~:[~; a bit larger than ~*~D~]."
                 'not-a-large-number
                 :argument n 
                 :ignore (numberp n)
                 :ignore n
                 :allow-other-keys t)
         (format t "~&Type a large number: ")
         (setq n (read))
         (fresh-line)))

 (assure-large-number 'a)
 |>  Correctable error in ASSURE-LARGE-NUMBER: A is not a large number.
 |>  Restart options:
 |>   1: Enter a number.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Type a large number: |>>88<<|
⇒  88

 (assure-large-number 37)
 |>  Correctable error in ASSURE-LARGE-NUMBER: A is not a large number.
 |>  Restart options:
 |>   1: Enter a number a bit larger than 37.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Type a large number: |>>259<<|
⇒  259

Affected By::

*break-on-signals*.

Existing handler bindings.

See Also::

error , format , handler-bind , *break-on-signals*, simple-type-error

Notes::

If datum is a condition type rather than a string, the format directive ~* may be especially useful in the continue-format-control in order to ignore the keywords in the initialization argument list. For example: 

(cerror "enter a new value to replace ~*~s" 
        'not-a-number
        :argument a)

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/complex.html0000644000175000017500000001031214360276512015025 0ustar cammcamm complex (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.46 complex [Function]

complex realpart &optional imagpart ⇒ complex

Arguments and Values::

realpart—a real.

imagpart—a real.

complex—a rational or a complex.

Description::

complex returns a number whose real part is realpart and whose imaginary part is imagpart.

If realpart is a rational and imagpart is the rational number zero, the result of complex is realpart, a rational. Otherwise, the result is a complex.

If either realpart or imagpart is a float, the non-float is converted to a float before the complex is created. If imagpart is not supplied, the imaginary part is a zero of the same type as realpart; i.e., (coerce 0 (type-of realpart)) is effectively used.

Type upgrading implies a movement upwards in the type hierarchy lattice. In the case of complexes, the type-specifier

[Reviewer Note by Barmar: What type specifier?] must be a subtype of (upgraded-complex-part-type type-specifier). If type-specifier1 is a subtype of type-specifier2, then (upgraded-complex-element-type 'type-specifier1) must also be a subtype of (upgraded-complex-element-type 'type-specifier2). Two disjoint types can be upgraded into the same thing.

Examples::

 (complex 0) ⇒  0
 (complex 0.0) ⇒  #C(0.0 0.0)
 (complex 1 1/2) ⇒  #C(1 1/2)
 (complex 1 .99) ⇒  #C(1.0 0.99)
 (complex 3/2 0.0) ⇒  #C(1.5 0.0)

See Also::

realpart , imagpart

Notes::

 #c(a b) ≡ #.(complex a b)
gcl-2.6.14/info/gcl/Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Implementations.html0000644000175000017500000001013414360276512030644 0ustar cammcamm Constraints on the COMMON-LISP Package for Conforming Implementations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.2 Constraints on the COMMON-LISP Package for Conforming Implementations

In a conforming implementation, an external symbol of the COMMON-LISP package can have a function, macro, or special operator definition, a global variable definition (or other status as a dynamic variable due to a special proclamation), or a type definition only if explicitly permitted in this standard. For example, fboundp yields false for any external symbol of the COMMON-LISP package that is not the name of a standardized function, macro or special operator, and boundp returns false for any external symbol of the COMMON-LISP package that is not the name of a standardized global variable. It also follows that conforming programs can use external symbols of the COMMON-LISP package as the names of local lexical variables with confidence that those names have not been proclaimed special by the implementation unless those symbols are names of standardized global variables.

A conforming implementation must not place any property on an external symbol of the COMMON-LISP package using a property indicator that is either an external symbol of any standardized package or a symbol that is otherwise accessible in the COMMON-LISP-USER package.

gcl-2.6.14/info/gcl/Stream-Variables.html0000644000175000017500000000736014360276512016530 0ustar cammcamm Stream Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Stream Concepts  

21.1.2 Stream Variables

Variables whose values must be streams are sometimes called stream variables .

Certain stream variables are defined by this specification to be the proper source of input or output in various situations where no specific stream has been specified instead. A complete list of such standardized stream variables appears in Figure 21–6. The consequences are undefined if at any time the value of any of these variables is not an open stream. 

  Glossary Term    Variable Name      
  debug I/O        *debug-io*         
  error output     *error-output*     
  query I/O        *query-io*         
  standard input   *standard-input*   
  standard output  *standard-output*  
  terminal I/O     *terminal-io*      
  trace output     *trace-output*     

  Figure 21–6: Standardized Stream Variables

Note that, by convention, standardized stream variables have names ending in “-input*” if they must be input streams, ending in “-output*” if they must be output streams, or ending in “-io*” if they must be bidirectional streams.

User programs may assign or bind any standardized stream variable except *terminal-io*.

gcl-2.6.14/info/gcl/pi.html0000644000175000017500000000621314360276512013773 0ustar cammcamm pi (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.22 pi [Constant Variable]

Value::

an implementation-dependent long float.

Description::

The best long float approximation to the mathematical constant \pi.

Examples::

 ;; In each of the following computations, the precision depends 
 ;; on the implementation.  Also, if `long float' is treated by 
 ;; the implementation as equivalent to some other float format 
 ;; (e.g., `double float') the exponent marker might be the marker
 ;; for that equivalent (e.g., `D' instead of `L').
 pi ⇒  3.141592653589793L0
 (cos pi) ⇒  -1.0L0

 (defun sin-of-degrees (degrees)
   (let ((x (if (floatp degrees) degrees (float degrees pi))))
     (sin (* x (/ (float pi x) 180)))))

Notes::

An approximation to \pi in some other precision can be obtained by writing (float pi x), where x is a float of the desired precision, or by writing (coerce pi type), where type is the desired type, such as short-float.

gcl-2.6.14/info/gcl/boole.html0000644000175000017500000002024314360276512014462 0ustar cammcamm boole (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.60 boole [Function]

boole op integer-1 integer-2 ⇒ result-integer

Arguments and Values::

Op—a bit-wise logical operation specifier.

integer-1—an integer.

integer-2—an integer.

result-integer—an integer.

Description::

boole performs bit-wise logical operations on integer-1 and integer-2, which are treated as if they were binary and in two’s complement representation.

The operation to be performed and the return value are determined by op.

boole returns the values specified for any op in Figure 12–16. 

  Op           Result                                      
  boole-1      integer-1                                   
  boole-2      integer-2                                   
  boole-andc1  and complement of integer-1 with integer-2  
  boole-andc2  and integer-1 with complement of integer-2  
  boole-and    and                                         
  boole-c1     complement of integer-1                     
  boole-c2     complement of integer-2                     
  boole-clr    always 0 (all zero bits)                    
  boole-eqv    equivalence (exclusive nor)                 
  boole-ior    inclusive or                                
  boole-nand   not-and                                     
  boole-nor    not-or                                      
  boole-orc1   or complement of integer-1 with integer-2   
  boole-orc2   or integer-1 with complement of integer-2   
  boole-set    always -1 (all one bits)                    
  boole-xor    exclusive or                                

         Figure 12–16: Bit-Wise Logical Operations

Examples::

 (boole boole-ior 1 16) ⇒  17
 (boole boole-and -2 5) ⇒  4
 (boole boole-eqv 17 15) ⇒  -31

;;; These examples illustrate the result of applying BOOLE and each
;;; of the possible values of OP to each possible combination of bits.
 (progn
   (format t "~&Results of (BOOLE <op> #b0011 #b0101) ...~
           ~
   (dolist (symbol '(boole-1     boole-2    boole-and  boole-andc1
                     boole-andc2 boole-c1   boole-c2   boole-clr
                     boole-eqv   boole-ior  boole-nand boole-nor
                     boole-orc1  boole-orc2 boole-set  boole-xor))
     (let ((result (boole (symbol-value symbol) #b0011 #b0101)))
       (format t "~& ~A~13T~3,' D~23T~:*~5,' B~31T ...~4,'0B~
               symbol result (logand result #b1111)))))
 |>  Results of (BOOLE <op> #b0011 #b0101) ...
 |>  ---Op-------Decimal-----Binary----Bits---
 |>   BOOLE-1       3          11    ...0011
 |>   BOOLE-2       5         101    ...0101
 |>   BOOLE-AND     1           1    ...0001
 |>   BOOLE-ANDC1   4         100    ...0100
 |>   BOOLE-ANDC2   2          10    ...0010
 |>   BOOLE-C1     -4        -100    ...1100
 |>   BOOLE-C2     -6        -110    ...1010
 |>   BOOLE-CLR     0           0    ...0000
 |>   BOOLE-EQV    -7        -111    ...1001
 |>   BOOLE-IOR     7         111    ...0111
 |>   BOOLE-NAND   -2         -10    ...1110
 |>   BOOLE-NOR    -8       -1000    ...1000
 |>   BOOLE-ORC1   -3         -11    ...1101
 |>   BOOLE-ORC2   -5        -101    ...1011
 |>   BOOLE-SET    -1          -1    ...1111
 |>   BOOLE-XOR     6         110    ...0110
⇒  NIL

Exceptional Situations::

Should signal type-error if its first argument is not a bit-wise logical operation specifier or if any subsequent argument is not an integer.

See Also::

logand

Notes::

In general, 

 (boole boole-and x y) ≡ (logand x y)

Programmers who would prefer to use numeric indices rather than bit-wise logical operation specifiers can get an equivalent effect by a technique such as the following: 

;; The order of the values in this `table' are such that
;; (logand (boole (elt boole-n-vector n) #b0101 #b0011) #b1111) => n
 (defconstant boole-n-vector
    (vector boole-clr   boole-and  boole-andc1 boole-2
            boole-andc2 boole-1    boole-xor   boole-ior
            boole-nor   boole-eqv  boole-c1    boole-orc1
            boole-c2    boole-orc2 boole-nand  boole-set))
⇒  BOOLE-N-VECTOR
 (proclaim '(inline boole-n))
⇒  implementation-dependent
 (defun boole-n (n integer &rest more-integers)
   (apply #'boole (elt boole-n-vector n) integer more-integers))
⇒  BOOLE-N
 (boole-n #b0111 5 3) ⇒  7
 (boole-n #b0001 5 3) ⇒  1
 (boole-n #b1101 5 3) ⇒  -3
 (loop for n from #b0000 to #b1111 collect (boole-n n 5 3))
⇒  (0 1 2 3 4 5 6 7 -8 -7 -6 -5 -4 -3 -2 -1)

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/char.html0000644000175000017500000001005714360276512014301 0ustar cammcamm char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.6 char, schar [Accessor]

char string index ⇒ character

schar string index ⇒ character

(setf (char string index) new-character)
(setf (schar string index) new-character)

Arguments and Values::

string—for char, a string; for schar, a simple string.

index—a valid array index for the string.

character, new-character—a character.

Description::

char and schar access the element of string specified by index.

char ignores fill pointers when accessing elements.

Examples::

 (setq my-simple-string (make-string 6 :initial-element #\A)) ⇒  "AAAAAA"
 (schar my-simple-string 4) ⇒  #\A
 (setf (schar my-simple-string 4) #\B) ⇒  #\B
 my-simple-string ⇒  "AAAABA"
 (setq my-filled-string
       (make-array 6 :element-type 'character
                     :fill-pointer 5
                     :initial-contents my-simple-string))
⇒  "AAAAB"
 (char my-filled-string 4) ⇒  #\B
 (char my-filled-string 5) ⇒  #\A
 (setf (char my-filled-string 3) #\C) ⇒  #\C
 (setf (char my-filled-string 5) #\D) ⇒  #\D
 (setf (fill-pointer my-filled-string) 6) ⇒  6
 my-filled-string ⇒  "AAACBD"

See Also::

aref , elt ,

Compiler Terminology

Notes::

 (char s j) ≡ (aref (the string s) j)
gcl-2.6.14/info/gcl/standard_002dobject.html0000644000175000017500000000500014360276512017070 0ustar cammcamm standard-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.14 standard-object [Class]

Class Precedence List::

standard-object, t

Description::

The class standard-object is an instance of standard-class and is a superclass of every class that is an instance of standard-class except itself.

gcl-2.6.14/info/gcl/_002aprint_002descape_002a.html0000644000175000017500000000736314360276512017700 0ustar cammcamm *print-escape* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.20 *print-escape* [Variable]

Value Type::

a generalized boolean.

Initial Value::

true.

Description::

If false, escape characters and package prefixes are not output when an expression is printed.

If true, an attempt is made to print an expression in such a way that it can be read again to produce an equal expression. (This is only a guideline; not a requirement. See *print-readably*.)

For more specific details of how the value of *print-escape* affects the printing of certain types, see Default Print-Object Methods.

Examples::

 (let ((*print-escape* t)) (write #\a))
 |>  #\a
⇒  #\a
 (let ((*print-escape* nil)) (write #\a))
 |>  a
⇒  #\a

Affected By::

princ, prin1, format

See Also::

write , readtable-case

Notes::

princ effectively binds *print-escape* to false. prin1 effectively binds *print-escape* to true.

gcl-2.6.14/info/gcl/Closures-and-Lexical-Binding.html0000644000175000017500000001516414360276512020656 0ustar cammcamm Closures and Lexical Binding (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.4 Closures and Lexical Binding

A lexical closure is a function that can refer to and alter the values of lexical bindings established by binding forms that textually include the function definition.

Consider this code, where x is not declared special: 

 (defun two-funs (x)
   (list (function (lambda () x))
         (function (lambda (y) (setq x y)))))
 (setq funs (two-funs 6))
 (funcall (car funs)) ⇒  6
 (funcall (cadr funs) 43) ⇒  43
 (funcall (car funs)) ⇒  43

The function special form coerces a lambda expression into a closure in which the lexical environment in effect when the special form is evaluated is captured along with the lambda expression.

The function two-funs returns a list of two functions, each of which refers to the binding of the variable x created on entry to the function two-funs when it was called. This variable has the value 6 initially, but setq can alter this binding. The lexical closure created for the first lambda expression does not “snapshot” the value 6 for x when the closure is created; rather it captures the binding of x. The second function can be used to alter the value in the same (captured) binding (to 43, in the example), and this altered variable binding then affects the value returned by the first function.

In situations where a closure of a lambda expression over the same set of bindings may be produced more than once, the various resulting closures may or may not be identical, at the discretion of the implementation. That is, two functions that are behaviorally indistinguishable might or might not be identical. Two functions that are behaviorally distinguishable are distinct. For example: 

 (let ((x 5) (funs '()))
   (dotimes (j 10)                          
     (push #'(lambda (z)                        
               (if (null z) (setq x 0) (+ x z)))
           funs))
   funs)

The result of the above form is a list of ten closures. Each requires only the binding of x. It is the same binding in each case, but the ten closure objects might or might not be identical. On the other hand, the result of the form 

 (let ((funs '()))     
   (dotimes (j 10)
     (let ((x 5))
       (push (function (lambda (z)
                        (if (null z) (setq x 0) (+ x z))))
             funs)))
  funs)

is also a list of ten closures. However, in this case no two of the closure objects can be identical because each closure is closed over a distinct binding of x, and these bindings can be behaviorally distinguished because of the use of setq.

The result of the form 

 (let ((funs '()))
   (dotimes (j 10)
     (let ((x 5))
       (push (function (lambda (z) (+ x z)))
            funs)))
   funs)

is a list of ten closure objects that might or might not be identical. A different binding of x is involved for each closure, but the bindings cannot be distinguished because their values are the same and immutable (there being no occurrence of setq on x). A compiler could internally transform the form to 

 (let ((funs '()))
   (dotimes (j 10)
     (push (function (lambda (z) (+ 5 z)))
           funs))
  funs)

where the closures may be identical.

It is possible that a closure does not close over any variable bindings. In the code fragment 

 (mapcar (function (lambda (x) (+ x 2))) y)

the function (lambda (x) (+ x 2)) contains no references to any outside object. In this case, the same closure might be returned for all evaluations of the function form.

Next: , Previous: , Up: Evaluation  

gcl-2.6.14/info/gcl/Treatment-of-Newline-during-Input-and-Output.html0000644000175000017500000000464514360276512023757 0ustar cammcamm Treatment of Newline during Input and Output (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.8 Treatment of Newline during Input and Output

When the character #\Newline is written to an output file, the implementation must take the appropriate action to produce a line division. This might involve writing out a record or translating #\Newline to a CR/LF sequence. When reading, a corresponding reverse transformation must take place.

gcl-2.6.14/info/gcl/Definitions.html0000644000175000017500000000563514360276512015645 0ustar cammcamm Definitions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.4 Definitions

This section contains notational conventions and definitions of terms used in this manual.

• Notational Conventions  
• Error Terminology  
• Sections Not Formally Part Of This Standard  
• Interpreting Dictionary Entries  
gcl-2.6.14/info/gcl/Arrays-Dictionary.html0000644000175000017500000001763014360276512016734 0ustar cammcamm Arrays Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Arrays  

15.2 Arrays Dictionary

• array  
• simple-array  
• vector (System Class)  
• simple-vector  
• bit-vector  
• simple-bit-vector  
• make-array  
• adjust-array  
• adjustable-array-p  
• aref  
• array-dimension  
• array-dimensions  
• array-element-type  
• array-has-fill-pointer-p  
• array-displacement  
• array-in-bounds-p  
• array-rank  
• array-row-major-index  
• array-total-size  
• arrayp  
• fill-pointer  
• row-major-aref  
• upgraded-array-element-type  
• array-dimension-limit  
• array-rank-limit  
• array-total-size-limit  
• simple-vector-p  
• svref  
• vector  
• vector-pop  
• vector-push  
• vectorp  
• bit (Array)  
• bit-and  
• bit-vector-p  
• simple-bit-vector-p  

Previous: , Up: Arrays  

gcl-2.6.14/info/gcl/Dynamic-Control-of-the-Arrangement-of-Output.html0000644000175000017500000001325014360276512023705 0ustar cammcamm Dynamic Control of the Arrangement of Output (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pretty Printer Concepts  

22.2.1.1 Dynamic Control of the Arrangement of Output

The actions of the pretty printer when a piece of output is too large to fit in the space available can be precisely controlled. Three concepts underlie the way these operations work—logical blocks , conditional newlines , and sections . Before proceeding further, it is important to define these terms.

The first line of Figure 22–3 shows a schematic piece of output. Each of the characters in the output is represented by “-”. The positions of conditional newlines are indicated by digits. The beginnings and ends of logical blocks are indicated by “<” and “>” respectively.

The output as a whole is a logical block and the outermost section. This section is indicated by the 0’s on the second line of Figure 1. Logical blocks nested within the output are specified by the macro pprint-logical-block. Conditional newline positions are specified by calls to pprint-newline. Each conditional newline defines two sections (one before it and one after it) and is associated with a third (the section immediately containing it).

The section after a conditional newline consists of: all the output up to, but not including, (a) the next conditional newline immediately contained in the same logical block; or if (a) is not applicable, (b) the next newline that is at a lesser level of nesting in logical blocks; or if (b) is not applicable, (c) the end of the output.

The section before a conditional newline consists of: all the output back to, but not including, (a) the previous conditional newline that is immediately contained in the same logical block; or if (a) is not applicable, (b) the beginning of the immediately containing logical block. The last four lines in Figure 1 indicate the sections before and after the four conditional newlines.

The section immediately containing a conditional newline is the shortest section that contains the conditional newline in question. In Figure 22–3, the first conditional newline is immediately contained in the section marked with 0’s, the second and third conditional newlines are immediately contained in the section before the fourth conditional newline, and the fourth conditional newline is immediately contained in the section after the first conditional newline. 

 <-1---<--<--2---3->--4-->->
 000000000000000000000000000
 11 111111111111111111111111
           22 222
              333 3333
        44444444444444 44444

  Figure 22–2: Example of Logical Blocks, Conditional Newlines, and Sections

Whenever possible, the pretty printer displays the entire contents of a section on a single line. However, if the section is too long to fit in the space available, line breaks are inserted at conditional newline positions within the section.

Next: , Previous: , Up: Pretty Printer Concepts  

gcl-2.6.14/info/gcl/Exceptional-Situations-in-the-Compiler.html0000644000175000017500000001055014360276512022727 0ustar cammcamm Exceptional Situations in the Compiler (ANSI and GNU Common Lisp Document)

Previous: , Up: Compilation  

3.2.5 Exceptional Situations in the Compiler

compile and compile-file are permitted to signal errors and warnings, including errors due to compile-time processing of (eval-when (:compile-toplevel) ...) forms, macro expansion, and conditions signaled by the compiler itself.

Conditions of type error might be signaled by the compiler in situations where the compilation cannot proceed without intervention.

In addition to situations for which the standard specifies that conditions of type warning must or might be signaled, warnings might be signaled in situations where the compiler can determine that the consequences are undefined or that a run-time error will be signaled. Examples of this situation are as follows: violating type declarations, altering or assigning the value of a constant defined with defconstant, calling built-in Lisp functions with a wrong number of arguments or malformed keyword argument lists, and using unrecognized declaration specifiers.

The compiler is permitted to issue warnings about matters of programming style as conditions of type style-warning. Examples of this situation are as follows: redefining a function using a different argument list, calling a function with a wrong number of arguments, not declaring ignore of a local variable that is not referenced, and referencing a variable declared ignore.

Both compile and compile-file are permitted (but not required) to establish a handler for conditions of type error. For example, they might signal a warning, and restart compilation from some implementation-dependent point in order to let the compilation proceed without manual intervention.

Both compile and compile-file return three values, the second two indicating whether the source code being compiled contained errors and whether style warnings were issued.

Some warnings might be deferred until the end of compilation. See with-compilation-unit.

Previous: , Up: Compilation  

gcl-2.6.14/info/gcl/map.html0000644000175000017500000001411014360276512014133 0ustar cammcamm map (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.7 map [Function]

map result-type function &rest sequences^+ ⇒ result

Arguments and Values::

result-type – a sequence type specifier, or nil.

function—a function designator. function must take as many arguments as there are sequences.

sequence—a proper sequence.

result—if result-type is a type specifier other than nil, then a sequence of the type it denotes; otherwise (if the result-type is nil), nil.

Description::

Applies function to successive sets of arguments in which one argument is obtained from each sequence. The function is called first on all the elements with index 0, then on all those with index 1, and so on. The result-type specifies the type of the resulting sequence.

map returns nil if result-type is nil. Otherwise, map returns a sequence such that element j is the result of applying function to element j of each of the sequences. The result sequence is as long as the shortest of the sequences. The consequences are undefined if the result of applying function to the successive elements of the sequences cannot be contained in a sequence of the type given by result-type.

If the result-type is a subtype of list, the result will be a list.

If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled.

Examples::

 (map 'string #'(lambda (x y)
                  (char "01234567890ABCDEF" (mod (+ x y) 16)))
       '(1 2 3 4)
       '(10 9 8 7)) ⇒  "AAAA"
 (setq seq '("lower" "UPPER" "" "123")) ⇒  ("lower" "UPPER" "" "123")
 (map nil #'nstring-upcase seq) ⇒  NIL
 seq ⇒  ("LOWER" "UPPER" "" "123")
 (map 'list #'- '(1 2 3 4)) ⇒  (-1 -2 -3 -4)
 (map 'string
      #'(lambda (x) (if (oddp x) #\1 #\0))
      '(1 2 3 4)) ⇒  "1010"

 (map '(vector * 4) #'cons "abc" "de") should signal an error

Exceptional Situations::

An error of type type-error must be signaled if the result-type is not a recognizable subtype of list, not a recognizable subtype of vector, and not nil.

Should be prepared to signal an error of type type-error if any sequence is not a proper sequence.

An error of type type-error should be signaled if result-type specifies the number of elements and the minimum length of the sequences is different from that number.

See Also::

Traversal Rules and Side Effects

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/special.html0000644000175000017500000001712414360276512015006 0ustar cammcamm special (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.26 special [Declaration]

Syntax::

(special {var}*)

Arguments::

var—a symbol.

Valid Context::

declaration or proclamation

Binding Types Affected::

variable

Description::

Specifies that all of the vars named are dynamic. This specifier affects variable bindings and affects references. All variable bindings affected are made to be dynamic bindings, and affected variable references refer to the current dynamic binding. For example: 

 (defun hack (thing *mod*)    ;The binding of the parameter
   (declare (special *mod*))  ; *mod* is visible to hack1,
   (hack1 (car thing)))       ; but not that of thing.
 (defun hack1 (arg)
   (declare (special *mod*))  ;Declare references to *mod*
                              ;within hack1 to be special.
   (if (atom arg) *mod*
       (cons (hack1 (car arg)) (hack1 (cdr arg)))))

A special declaration does not affect inner bindings of a var; the inner bindings implicitly shadow a special declaration and must be explicitly re-declared to be special. special declarations never apply to function bindings.

special declarations can be either bound declarations, affecting both a binding and references, or free declarations, affecting only references, depending on whether the declaration is attached to a variable binding.

When used in a proclamation, a special declaration specifier applies to all bindings as well as to all references of the mentioned variables. For example, after 

 (declaim (special x))

then in a function definition such as 

 (defun example (x) ...)

the parameter x is bound as a dynamic variable rather than as a lexical variable.

Examples::

(defun declare-eg (y)                 ;this y is special
 (declare (special y))
 (let ((y t))                         ;this y is lexical
      (list y
            (locally (declare (special y)) y)))) ;this y refers to the
                                                 ;special binding of y
⇒  DECLARE-EG 
 (declare-eg nil) ⇒  (T NIL) 

(setf (symbol-value 'x) 6)
(defun foo (x)                         ;a lexical binding of x
  (print x)
  (let ((x (1+ x)))                    ;a special binding of x
    (declare (special x))              ;and a lexical reference
    (bar))
  (1+ x))
(defun bar () 
  (print (locally (declare (special x))
           x)))
(foo 10) 
 |>  10
 |>  11
⇒  11

(setf (symbol-value 'x) 6)
(defun bar (x y)            ;[1] 1st occurrence of x
  (let ((old-x x)           ;[2] 2nd occurrence of x -- same as 1st occurrence
        (x y))              ;[3] 3rd occurrence of x
    (declare (special x))
    (list old-x x)))
(bar 'first 'second) ⇒  (FIRST SECOND)

 (defun few (x &optional (y *foo*))
   (declare (special *foo*))
   ...)

The reference to *foo* in the first line of this example is not special even though there is a special declaration in the second line. 

 (declaim (special prosp)) ⇒  implementation-dependent
 (setq prosp 1 reg 1) ⇒  1
 (let ((prosp 2) (reg 2))         ;the binding of prosp is special
    (set 'prosp 3) (set 'reg 3)   ;due to the preceding proclamation,
    (list prosp reg))             ;whereas the variable reg is lexical
⇒  (3 2)
 (list prosp reg) ⇒  (1 3)

 (declaim (special x))          ;x is always special.
 (defun example (x y)                                 
   (declare (special y))
   (let ((y 3) (x (* x 2)))
     (print (+ y (locally (declare (special y)) y)))
     (let ((y 4)) (declare (special y)) (foo x)))) ⇒  EXAMPLE

In the contorted code above, the outermost and innermost bindings of y are dynamic, but the middle binding is lexical. The two arguments to + are different, one being the value, which is 3, of the lexical variable y, and the other being the value of the dynamic variable named y (a binding of which happens, coincidentally, to lexically surround it at an outer level). All the bindings of x and references to x are dynamic, however, because of the proclamation that x is always special.

See Also::

defparameter , defvar

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/delete_002dfile.html0000644000175000017500000001051214360276512016207 0ustar cammcamm delete-file (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.8 delete-file [Function]

delete-file filespec ⇒ t

Arguments and Values::

filespec—a pathname designator.

Description::

Deletes the file specified by filespec.

If the filespec designator is an open stream, then filespec and the file associated with it are affected (if the file system permits), in which case filespec might be closed immediately, and the deletion might be immediate or delayed until filespec is explicitly closed, depending on the requirements of the file system.

It is implementation-dependent whether an attempt to delete a nonexistent file is considered to be successful.

delete-file returns true if it succeeds, or signals an error of type file-error if it does not.

The consequences are undefined if filespec has a wild component, or if filespec has a nil component and the file system does not permit a nil component.

Examples::

 (with-open-file (s "delete-me.text" :direction :output :if-exists :error))
⇒  NIL
 (setq p (probe-file "delete-me.text")) ⇒  #P"R:>fred>delete-me.text.1"
 (delete-file p) ⇒  T
 (probe-file "delete-me.text") ⇒  false
 (with-open-file (s "delete-me.text" :direction :output :if-exists :error)
   (delete-file s))
⇒  T
 (probe-file "delete-me.text") ⇒  false

Exceptional Situations::

If the deletion operation is not successful, an error of type file-error is signaled.

An error of type file-error might be signaled if filespec is wild.

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

gcl-2.6.14/info/gcl/Undefined-FORMAT-Modifier-Combinations.html0000644000175000017500000000447614360276512022442 0ustar cammcamm Undefined FORMAT Modifier Combinations (ANSI and GNU Common Lisp Document)

Previous: , Up: Additional Information about FORMAT Operations  

22.3.10.4 Undefined FORMAT Modifier Combinations

The consequences are undefined if colon or at-sign modifiers are given to a directive in a combination not specifically described here as being meaningful.

gcl-2.6.14/info/gcl/Introduction-to-Characters.html0000644000175000017500000000747514360276512020554 0ustar cammcamm Introduction to Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.1 Introduction to Characters

A character is an object that represents a unitary token (e.g., a letter, a special symbol, or a “control character”) in an aggregate quantity of text (e.g., a string or a text stream).

Common Lisp allows an implementation to provide support for international language characters as well as characters used in specialized arenas (e.g., mathematics).

The following figures contain lists of defined names applicable to characters.

Figure 13–1 lists some defined names relating to character attributes and character predicates. 

  alpha-char-p     char-not-equal     char>            
  alphanumericp    char-not-greaterp  char>=           
  both-case-p      char-not-lessp     digit-char-p     
  char-code-limit  char/=             graphic-char-p   
  char-equal       char<              lower-case-p     
  char-greaterp    char<=             standard-char-p  
  char-lessp       char=              upper-case-p     

       Figure 13–1: Character defined names – 1

Figure 13–2 lists some character construction and conversion defined names. 

  char-code      char-name    code-char   
  char-downcase  char-upcase  digit-char  
  char-int       character    name-char   

  Figure 13–2: Character defined names – 2
gcl-2.6.14/info/gcl/subst.html0000644000175000017500000001754214360276512014532 0ustar cammcamm subst (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.12 subst, subst-if, subst-if-not, nsubst, nsubst-if, nsubst-if-not

[Function]

subst new old tree &key key test test-not ⇒ new-tree

subst-if new predicate tree &key key ⇒ new-tree

subst-if-not new predicate tree &key key ⇒ new-tree

nsubst new old tree &key key test test-not ⇒ new-tree

nsubst-if new predicate tree &key key ⇒ new-tree

nsubst-if-not new predicate tree &key key ⇒ new-tree

Arguments and Values::

new—an object.

old—an object.

predicate—a symbol that names a function, or a function of one argument that returns a generalized boolean value.

tree—a tree.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

new-tree—a tree.

Description::

subst, subst-if, and subst-if-not perform substitution operations on tree. Each function searches tree for occurrences of a particular old item of an element or subexpression that satisfies the test.

nsubst, nsubst-if, and nsubst-if-not are like subst, subst-if, and subst-if-not respectively, except that the original tree is modified.

subst makes a copy of tree, substituting new for every subtree or leaf of tree (whether the subtree or leaf is a car or a cdr of its parent) such that old and the subtree or leaf satisfy the test.

nsubst is a destructive version of subst. The list structure of tree is altered by destructively replacing with new each leaf of the tree such that old and the leaf satisfy the test.

For subst, subst-if, and subst-if-not, if the functions succeed, a new copy of the tree is returned in which each occurrence of such an element is replaced by the new element or subexpression. If no changes are made, the original tree may be returned. The original tree is left unchanged, but the result tree may share storage with it.

For nsubst, nsubst-if, and nsubst-if-not the original tree is modified and returned as the function result, but the result may not be eq to tree.

Examples::

 (setq tree1 '(1 (1 2) (1 2 3) (1 2 3 4))) ⇒  (1 (1 2) (1 2 3) (1 2 3 4))
 (subst "two" 2 tree1) ⇒  (1 (1 "two") (1 "two" 3) (1 "two" 3 4))
 (subst "five" 5 tree1) ⇒  (1 (1 2) (1 2 3) (1 2 3 4))
 (eq tree1 (subst "five" 5 tree1)) ⇒  implementation-dependent
 (subst 'tempest 'hurricane
        '(shakespeare wrote (the hurricane)))
⇒  (SHAKESPEARE WROTE (THE TEMPEST))
 (subst 'foo 'nil '(shakespeare wrote (twelfth night)))
⇒  (SHAKESPEARE WROTE (TWELFTH NIGHT . FOO) . FOO)
 (subst '(a . cons) '(old . pair)
        '((old . spice) ((old . shoes) old . pair) (old . pair))
        :test #'equal)
⇒  ((OLD . SPICE) ((OLD . SHOES) A . CONS) (A . CONS))

 (subst-if 5 #'listp tree1) ⇒  5
 (subst-if-not '(x) #'consp tree1) 
⇒  (1 X)

 tree1 ⇒  (1 (1 2) (1 2 3) (1 2 3 4))
 (nsubst 'x 3 tree1 :key #'(lambda (y) (and (listp y) (third y)))) 
⇒  (1 (1 2) X X)
 tree1 ⇒  (1 (1 2) X X)

Side Effects::

nsubst, nsubst-if, and nsubst-if-not might alter the tree structure of tree.

See Also::

substitute , nsubstitute,

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

The functions subst-if-not and nsubst-if-not are deprecated.

One possible definition of subst: 

 (defun subst (old new tree &rest x &key test test-not key)
   (cond ((satisfies-the-test old tree :test test
                                 :test-not test-not :key key)
         new)
        ((atom tree) tree)
        (t (let ((a (apply #'subst old new (car tree) x))
                 (d (apply #'subst old new (cdr tree) x)))
             (if (and (eql a (car tree))
                      (eql d (cdr tree)))
                 tree
                 (cons a d))))))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/destructuring_002dbind.html0000644000175000017500000000745014360276512017653 0ustar cammcamm destructuring-bind (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.17 destructuring-bind [Macro]

destructuring-bind lambda-list expression {declaration}* {form}*
⇒ {result}*

Arguments and Values::

lambda-list—a destructuring lambda list.

expression—a form.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

destructuring-bind binds the variables specified in lambda-list to the corresponding values in the tree structure resulting from the evaluation of expression; then destructuring-bind evaluates forms.

The lambda-list supports destructuring as described in Destructuring Lambda Lists.

Examples::

 (defun iota (n) (loop for i from 1 to n collect i))       ;helper
 (destructuring-bind ((a &optional (b 'bee)) one two three)
     `((alpha) ,@(iota 3))
   (list a b three two one)) ⇒  (ALPHA BEE 3 2 1)

Exceptional Situations::

If the result of evaluating the expression does not match the destructuring pattern, an error of type error should be signaled.

See Also::

macrolet, defmacro

gcl-2.6.14/info/gcl/APPLY-Forms-as-Places.html0000644000175000017500000000734114360276512017145 0ustar cammcamm APPLY Forms as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.5 APPLY Forms as Places

The following situations involving setf of apply must be supported:

*

(setf (apply #'aref array {subscript}* more-subscripts) new-element)

*

(setf (apply #'bit array {subscript}* more-subscripts) new-element)

*

(setf (apply #'sbit array {subscript}* more-subscripts) new-element)

In all three cases, the element of array designated by the concatenation of subscripts and more-subscripts (i.e., the same element which would be read by the call to apply if it were not part of a setf form) is changed to have the value given by new-element.

For these usages, the function name (aref, bit, or sbit) must refer to the global function definition, rather than a locally defined function.

No other standardized function is required to be supported, but an implementation may define such support. An implementation may also define support for implementation-defined operators.

If a user-defined function is used in this context, the following equivalence is true, except that care is taken to preserve proper left-to-right evaluation of argument subforms: 

 (setf (apply #'name {arg}*) val)
 ≡ (apply #'(setf name) val {arg}*)
gcl-2.6.14/info/gcl/Modification-of-Literal-Objects.html0000644000175000017500000001326614360276512021361 0ustar cammcamm Modification of Literal Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Destructive Operations  

3.7.1 Modification of Literal Objects

The consequences are undefined if literal objects are destructively modified. For this purpose, the following operations are considered destructive:

random-state

Using it as an argument to the function random.

cons

Changing the car_1 or cdr_1 of the cons, or performing a destructive operation on an object which is either the car_2 or the cdr_2 of the cons.

array

Storing a new value into some element of the array, or performing a destructive operation on an object that is already such an element.

Changing the fill pointer, dimensions, or displacement of the array (regardless of whether the array is actually adjustable).

Performing a destructive operation on another array that is displaced to the array or that otherwise shares its contents with the array.

hash-table

Performing a destructive operation on any key.

Storing a new value_4 for any key, or performing a destructive operation on any object that is such a value.

Adding or removing entries from the hash table.

structure-object

Storing a new value into any slot, or performing a destructive operation on an object that is the value of some slot.

standard-object

Storing a new value into any slot, or performing a destructive operation on an object that is the value of some slot.

Changing the class of the object (e.g., using the function change-class).

readtable

Altering the readtable case.

Altering the syntax type of any character in this readtable.

Altering the reader macro function associated with any character in the readtable, or altering the reader macro functions associated with characters defined as dispatching macro characters in the readtable.

stream

Performing I/O operations on the stream, or closing the stream.

All other standardized types

[This category includes, for example, character, condition, function, method-combination, method, number, package, pathname, restart, and symbol.]

There are no standardized destructive operations defined on objects of these types.

Next: , Previous: , Up: Destructive Operations  

gcl-2.6.14/info/gcl/listen.html0000644000175000017500000000713414360276512014664 0ustar cammcamm listen (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.34 listen [Function]

listen &optional input-stream ⇒ generalized-boolean

Arguments and Values::

input-stream—an input stream designator. The default is standard input.

generalized-boolean—a generalized boolean.

Description::

Returns true if there is a character immediately available from input-stream; otherwise, returns false. On a non-interactive input-stream, listen returns true except when at end of file_1. If an end of file is encountered, listen returns false. listen is intended to be used when input-stream obtains characters from an interactive device such as a keyboard.

Examples::

 (progn (unread-char (read-char)) (list (listen) (read-char)))
 |>  |>>1<<|
⇒  (T #\1)
 (progn (clear-input) (listen))
⇒  NIL ;Unless you're a very fast typist!

Affected By::

*standard-input*

See Also::

interactive-stream-p , read-char-no-hang

gcl-2.6.14/info/gcl/Unconditional-Execution-Clauses.html0000644000175000017500000000625314360276512021533 0ustar cammcamm Unconditional Execution Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.5 Unconditional Execution Clauses

The do and doing constructs evaluate the supplied forms wherever they occur in the expanded form of loop. The form argument can be any compound form. Each form is evaluated in every iteration. Because every loop clause must begin with a loop keyword, the keyword do is used when no control action other than execution is required.

The return construct takes one form. Any values returned by the form are immediately returned by the loop form. It is equivalent to the clause do (return-from block-name value), where block-name is the name specified in a named clause, or nil if there is no named clause.

• Examples of unconditional execution  
gcl-2.6.14/info/gcl/Error-Terminology.html0000644000175000017500000002612214360276512016763 0ustar cammcamm Error Terminology (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Definitions  

1.4.2 Error Terminology

Situations in which errors might, should, or must be signaled are described in the standard. The wording used to describe such situations is intended to have precise meaning. The following list is a glossary of those meanings.

Safe code

This is code processed with the safety optimization at its highest setting (3). safety is a lexical property of code. The phrase “the function F should signal an error” means that if F is invoked from code processed with the highest safety optimization, an error is signaled. It is implementation-dependent whether F or the calling code signals the error.

Unsafe code

This is code processed with lower safety levels.

Unsafe code might do error checking. Implementations are permitted to treat all code as safe code all the time.

An error is signaled

This means that an error is signaled in both safe and unsafe code. Conforming code may rely on the fact that the error is signaled in both safe and unsafe code. Every implementation is required to detect the error in both safe and unsafe code. For example, “an error is signaled if unexport is given a symbol not accessible in the current package.”

If an explicit error type is not specified, the default is error.

An error should be signaled

This means that an error is signaled in safe code, and an error might be signaled in unsafe code. Conforming code may rely on the fact that the error is signaled in safe code. Every implementation is required to detect the error at least in safe code. When the error is not signaled, the “consequences are undefined” (see below). For example, “+ should signal an error of type type-error if any argument is not of type number.”

Should be prepared to signal an error

This is similar to “should be signaled” except that it does not imply that ‘extra effort’ has to be taken on the part of an operator to discover an erroneous situation if the normal action of that operator can be performed successfully with only ‘lazy’ checking. An implementation is always permitted to signal an error, but even in safe code, it is only required to signal the error when failing to signal it might lead to incorrect results. In unsafe code, the consequences are undefined.

For example, defining that “find should be prepared to signal an error of type type-error if its second argument is not a proper list” does not imply that an error is always signaled. The form 

 (find 'a '(a b . c))

must either signal an error of type type-error in safe code, else return A. In unsafe code, the consequences are undefined. By contrast, 

 (find 'd '(a b . c))

must signal an error of type type-error in safe code. In unsafe code, the consequences are undefined. Also, 

 (find 'd '#1=(a b . #1#))

in safe code might return nil (as an implementation-defined extension), might never return, or might signal an error of type type-error. In unsafe code, the consequences are undefined.

Typically, the “should be prepared to signal” terminology is used in type checking situations where there are efficiency considerations that make it impractical to detect errors that are not relevant to the correct operation of the operator.

The consequences are unspecified

This means that the consequences are unpredictable but harmless. Implementations are permitted to specify the consequences of this situation. No conforming code may depend on the results or effects of this situation, and all conforming code is required to treat the results and effects of this situation as unpredictable but harmless. For example, “if the second argument to shared-initialize specifies a name that does not correspond to any slots accessible in the object, the results are unspecified.”

The consequences are undefined

This means that the consequences are unpredictable. The consequences may range from harmless to fatal. No conforming code may depend on the results or effects. Conforming code must treat the consequences as unpredictable. In places where the words “must,” “must not,” or “may not” are used, then “the consequences are undefined” if the stated requirement is not met and no specific consequence is explicitly stated. An implementation is permitted to signal an error in this case.

For example: “Once a name has been declared by defconstant to be constant, any further assignment or binding of that variable has undefined consequences.”

An error might be signaled

This means that the situation has undefined consequences; however, if an error is signaled, it is of the specified type. For example, “open might signal an error of type file-error.”

The return values are unspecified

This means that only the number and nature of the return values of a form are not specified. However, the issue of whether or not any side-effects or transfer of control occurs is still well-specified.

A program can be well-specified even if it uses a function whose returns values are unspecified. For example, even if the return values of some function F are unspecified, an expression such as (length (list (F))) is still well-specified because it does not rely on any particular aspect of the value or values returned by F.

Implementations may be extended to cover this situation

This means that the situation has undefined consequences; however, a conforming implementation is free to treat the situation in a more specific way. For example, an implementation might define that an error is signaled, or that an error should be signaled, or even that a certain well-defined non-error behavior occurs.

No conforming code may depend on the consequences of such a situation; all conforming code must treat the consequences of the situation as undefined. Implementations are required to document how the situation is treated.

For example, “implementations may be extended to define other type specifiers to have a corresponding class.”

Implementations are free to extend the syntax

This means that in this situation implementations are permitted to define unambiguous extensions to the syntax of the form being described. No conforming code may depend on this extension. Implementations are required to document each such extension. All conforming code is required to treat the syntax as meaningless. The standard might disallow certain extensions while allowing others. For example, “no implementation is free to extend the syntax of defclass.”

A warning might be issued

This means that implementations are encouraged to issue a warning if the context is appropriate (e.g., when compiling). However, a conforming implementation is not required to issue a warning.

Next: , Previous: , Up: Definitions  

gcl-2.6.14/info/gcl/The-_0022Arguments-and-Values_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000612714360276512026601 0ustar cammcamm The "Arguments and Values" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.3 The "Arguments and Values" Section of a Dictionary Entry

An English language description of what arguments the operator accepts and what values it returns, including information about defaults for parameters corresponding to omittable arguments (such as optional parameters and keyword parameters). For special operators and macros, their arguments are not evaluated unless it is explicitly stated in their descriptions that they are evaluated.

gcl-2.6.14/info/gcl/hash_002dtable_002dsize.html0000644000175000017500000000622014360276512017461 0ustar cammcamm hash-table-size (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.7 hash-table-size [Function]

hash-table-size hash-table ⇒ size

Arguments and Values::

hash-table—a hash table.

size—a non-negative integer.

Description::

Returns the current size of hash-table, which is suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table.

Exceptional Situations::

Should signal an error of type type-error if hash-table is not a hash table.

See Also::

hash-table-count , make-hash-table

gcl-2.6.14/info/gcl/mod-_0028Function_0029.html0000644000175000017500000000734114360276512017053 0ustar cammcamm mod (Function) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.36 mod, rem [Function]

mod number divisor ⇒ modulus

rem number divisor ⇒ remainder

Arguments and Values::

number—a real.

divisor—a real.

modulus, remainder—a real.

Description::

mod and rem are generalizations of the modulus and remainder functions respectively.

mod performs the operation floor on number and divisor and returns the remainder of the floor operation.

rem performs the operation truncate on number and divisor and returns the remainder of the truncate operation.

mod and rem are the modulus and remainder functions when number and divisor are integers.

Examples::

 (rem -1 5) ⇒  -1
 (mod -1 5) ⇒  4
 (mod 13 4) ⇒  1
 (rem 13 4) ⇒  1
 (mod -13 4) ⇒  3
 (rem -13 4) ⇒  -1
 (mod 13 -4) ⇒  -3
 (rem 13 -4) ⇒  1
 (mod -13 -4) ⇒  -1
 (rem -13 -4) ⇒  -1
 (mod 13.4 1) ⇒  0.4
 (rem 13.4 1) ⇒  0.4
 (mod -13.4 1) ⇒  0.6
 (rem -13.4 1) ⇒  -0.4

See Also::

floor , truncate

Notes::

The result of mod is either zero or a

real

with the same sign as divisor.

gcl-2.6.14/info/gcl/Deprecated-Variables.html0000644000175000017500000000421214360276512017326 0ustar cammcamm Deprecated Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Deprecated Language Features  

1.8.3 Deprecated Variables

The variable *modules* is deprecated.

gcl-2.6.14/info/gcl/Simple-vs-Extended-Loop.html0000644000175000017500000000430214360276512017704 0ustar cammcamm Simple vs Extended Loop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.1 Simple vs Extended Loop

loop forms are partitioned into two categories: simple loop forms and extended loop forms.

gcl-2.6.14/info/gcl/Expanding-Loop-Forms.html0000644000175000017500000001254614360276512017301 0ustar cammcamm Expanding Loop Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.6 Expanding Loop Forms

A loop macro form expands into a form containing one or more binding forms (that establish bindings of loop variables) and a block and a tagbody (that express a looping control structure). The variables established in loop are bound as if by let or lambda.

Implementations can interleave the setting of initial values with the bindings. However, the assignment of the initial values is always calculated in the order specified by the user. A variable is thus sometimes bound to a meaningless value of the correct type, and then later in the prologue it is set to the true initial value by using setq.

One implication of this interleaving is that it is implementation-dependent whether the lexical environment in which the initial value forms (variously called the form1, form2, form3, step-fun, vector, hash-table, and package) in any for-as-subclause, except for-as-equals-then, are evaluated includes only the loop variables preceding that form or includes more or all of the loop variables; the form1 and form2 in a for-as-equals-then form includes the lexical environment of all the loop variables.

After the form is expanded, it consists of three basic parts in the tagbody: the loop prologue, the loop body, and the loop epilogue.

Loop prologue

The loop prologue contains forms that are executed before iteration begins, such as any automatic variable initializations prescribed by the variable clauses, along with any initially clauses in the order they appear in the source.

Loop body

The loop body contains those forms that are executed during iteration, including application-specific calculations, termination tests, and variable stepping_1.

Loop epilogue

The loop epilogue contains forms that are executed after iteration terminates, such as finally clauses, if any, along with any implicit return value from an accumulation clause or an termination-test clause.

Some clauses from the source form contribute code only to the loop prologue; these clauses must come before other clauses that are in the main body of the loop form. Others contribute code only to the loop epilogue. All other clauses contribute to the final translated form in the same order given in the original source form of the loop.

Expansion of the loop macro produces an implicit block named nil

unless named is supplied.

Thus, return-from (and sometimes return) can be used to return values from loop or to exit loop.

Next: , Previous: , Up: Overview of the Loop Facility  

gcl-2.6.14/info/gcl/Macro-Forms.html0000644000175000017500000001051114360276512015504 0ustar cammcamm Macro Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.9 Macro Forms

If the operator names a macro, its associated macro function is applied to the entire form and the result of that application is used in place of the original form.

Specifically, a symbol names a macro in a given lexical environment if macro-function is true of the symbol and that environment. The function returned by macro-function is a function of two arguments, called the expansion function. The expansion function is invoked by calling the macroexpand hook with the expansion function as its first argument, the entire macro form as its second argument, and an environment object (corresponding to the current lexical environment) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The value of the expansion function, which is passed through by the macroexpand hook, is a form. The returned form is evaluated in place of the original form.

The consequences are undefined if a macro function destructively modifies any part of its form argument.

A macro name is not a function designator, and cannot be used as the function argument to functions such as apply, funcall, or map.

An implementation is free to implement a Common Lisp special operator as a macro. An implementation is free to implement any macro operator as a special operator, but only if an equivalent definition of the macro is also provided.

Figure 3–3 lists some defined names that are applicable to macros. 

  *macroexpand-hook*  macro-function  macroexpand-1  
  defmacro            macroexpand     macrolet       

    Figure 3–3: Defined names applicable to macros

Next: , Previous: , Up: The Evaluation Model  

gcl-2.6.14/info/gcl/Glossary.html0000644000175000017500000077200514360276512015177 0ustar cammcamm Glossary (ANSI and GNU Common Lisp Document)

Previous: , Up: Glossary (Glossary)  

26.1 Glossary

Each entry in this glossary has the following parts:

*

the term being defined, set in boldface.

*

optional pronunciation, enclosed in square brackets and set in boldface, as in the following example: pronounced ’a ,list . The pronunciation key follows Webster’s Third New International Dictionary the English Language, Unabridged, except that “e” is used to notate the schwa (upside-down “e”) character.

*

the part or parts of speech, set in italics. If a term can be used as several parts of speech, there is a separate definition for each part of speech.

*

one or more definitions, organized as follows:

–

an optional number, present if there are several definitions. Lowercase letters might also be used in cases where subdefinitions of a numbered definition are necessary.

–

an optional part of speech, set in italics, present if the term is one of several parts of speech.

–

an optional discipline, set in italics, present if the term has a standard definition being repeated. For example, “Math.”

–

an optional context, present if this definition is meaningful only in that context. For example, “(of a symbol)”.

–

the definition.

–

an optional example sentence. For example, “This is an example of an example.”

–

optional cross references.

In addition, some terms have idiomatic usage in the Common Lisp community which is not shared by other communities, or which is not technically correct. Definitions labeled “Idiom.” represent such idiomatic usage; these definitions are sometimes followed by an explanatory note.

Words in this font are words with entries in the glossary. Words in example sentences do not follow this convention.

When an ambiguity arises, the longest matching substring has precedence. For example, “complex float” refers to a single glossary entry for “complex float” rather than the combined meaning of the glossary terms “complex” and “float.”

Subscript notation, as in “something_n” means that the nth definition of “something” is intended. This notation is used only in situations where the context might be insufficient to disambiguate.

The following are abbreviations used in the glossary:

Abbreviation Meaning

adj.

adjective

adv.

adverb

ANSI

compatible with one or more ANSI standards

Comp.

computers

Idiom.

idiomatic

IEEE

compatible with one or more IEEE standards

ISO

compatible with one or more ISO standards

Math.

mathematics

Trad.

traditional

n.

noun

v.

verb

v.t.

transitive verb

Non-alphabetic

()

pronounced ’nil , n. an alternative notation for writing the symbol~nil, used to emphasize the use of nil as an empty list.

A

absolute

adj. 1. (of a time) representing a specific point in time. 2. (of a pathname) representing a specific position in a directory hierarchy. See relative.

access

n., v.t. 1. v.t. (a place, or array) to read_1 or write_1 the value of the place or an element of the array. 2. n. (of a place) an attempt to access_1 the value of the place.

accessibility

n. the state of being accessible.

accessible

adj. 1. (of an object) capable of being referenced. 2. (of shared slots or local slots in an instance of a class) having been defined by the class of the instance or inherited from a superclass of that class. 3. (of a symbol in a package) capable of being referenced without a package prefix when that package is current, regardless of whether the symbol is present in that package or is inherited.

accessor

n. an operator that performs an access. See reader and writer.

active

adj. 1. (of a handler, a restart, or a catch tag) having been established but not yet disestablished. 2. (of an element of an array) having an index that is greater than or equal to zero, but less than the fill pointer (if any). For an array that has no fill pointer, all elements are considered active.

actual adjustability

n. (of an array) a generalized boolean that is associated with the array, representing whether the array is actually adjustable. See also expressed adjustability and adjustable-array-p.

actual argument

n. Trad. an argument.

actual array element type

n. (of an array) the type for which the array is actually specialized, which is the upgraded array element type of the expressed array element type of the array. See the function array-element-type.

actual complex part type

n. (of a complex) the type in which the real and imaginary parts of the complex are actually represented, which is the upgraded complex part type of the expressed complex part type of the complex.

actual parameter

n. Trad. an argument.

actually adjustable

adj. (of an array) such that adjust-array can adjust its characteristics by direct modification. A conforming program may depend on an array being actually adjustable only if either that array is known to have been expressly adjustable or if that array has been explicitly tested by adjustable-array-p.

adjustability

n. (of an array) 1. expressed adjustability. 2. actual adjustability.

adjustable

adj. (of an array) 1. expressly adjustable. 2. actually adjustable.

after method

n. a method having the qualifier :after.

alist

pronounced ’\=a ,list , n. an association list.

alphabetic

n., adj. 1. adj. (of a character) being one of the standard characters A through Z or a through z, or being any implementation-defined character that has case, or being some other graphic character defined by the implementation to be alphabetic_1. 2. a. n. one of several possible constituent traits of a character. For details, see Constituent Characters and Reader Algorithm. b. adj. (of a character) being a character that has syntax type constituent in the current readtable and that has the constituent trait alphabetic_{2a}. See Figure~2–8.

alphanumeric

adj. (of a character) being either an alphabetic_1 character or a numeric character.

ampersand

n. the standard character that is called “ampersand” (&). See Figure~2–5.

anonymous

adj. 1. (of a class or function) having no name 2. (of a restart) having a name of nil.

apparently uninterned

adj. having a home package of nil. (An apparently uninterned symbol might or might not be an uninterned symbol. Uninterned symbols have a home package of nil, but symbols which have been uninterned from their home package also have a home package of nil, even though they might still be interned in some other package.)

applicable

adj. 1. (of a handler) being an applicable handler. 2. (of a method) being an applicable method. 3. (of a restart) being an applicable restart.

applicable handler

n. (for a condition being signaled) an active handler for which the associated type contains the condition.

applicable method

n. (of a generic function called with arguments) a method of the generic function for which the arguments satisfy the parameter specializers of that method. See Selecting the Applicable Methods.

applicable restart

n. 1. (for a condition) an active handler for which the associated test returns true when given the condition as an argument. 2. (for no particular condition) an active handler for which the associated test returns true when given nil as an argument.

apply

v.t. (a function to a list) to call the function with arguments that are the elements of the list. “Applying the function + to a list of integers returns the sum of the elements of that list.”

argument

n. 1. (of a function) an object which is offered as data to the function when it is called.

2. (of a format control) a format argument.

argument evaluation order

n. the order in which arguments are evaluated in a function call. “The argument evaluation order for Common Lisp is left to right.” See Evaluation.

argument precedence order

n. the order in which the arguments to a generic function are considered when sorting the applicable methods into precedence order.

around method

n. a method having the qualifier :around.

array

n. an object of type array, which serves as a container for other objects arranged in a Cartesian coordinate system.

array element type

n. (of an array) 1. a type associated with the array, and of which all elements of the array are constrained to be members. 2. the actual array element type of the array. 3. the expressed array element type of the array.

array total size

n. the total number of elements in an array, computed by taking the product of the dimensions of the array. (The size of a zero-dimensional array is therefore one.)

assign

v.t. (a variable) to change the value of the variable in a binding that has already been established. See the special operator setq.

association list

n. a list of conses representing an association of keys with values, where the car of each cons is the key and the cdr is the value associated with that key.

asterisk

n. the standard character that is variously called “asterisk” or “star” (*). See Figure~2–5.

at-sign

n. the standard character that is variously called “commercial at” or “at sign” (@). See Figure~2–5.

atom

n. any object that is not a cons. “A vector is an atom.”

atomic

adj. being an atom. “The number 3, the symbol foo, and nil are atomic.”

atomic type specifier

n. a type specifier that is atomic. For every atomic type specifier, x, there is an equivalent compound type specifier with no arguments supplied, (x).

attribute

n. (of a character) a program-visible aspect of the character. The only standardized attribute of a character is its code_2, but implementations are permitted to have additional implementation-defined attributes. See Character Attributes. “An implementation that support fonts might make font information an attribute of a character, while others might represent font information separately from characters.”

aux variable

n. a variable that occurs in the part of a lambda list that was introduced by &aux. Unlike all other variables introduced by a lambda-list, aux variables are not parameters.

auxiliary method

n. a member of one of two sets of methods (the set of primary methods is the other) that form an exhaustive partition of the set of methods on the method’s generic function. How these sets are determined is dependent on the method combination type; see Introduction to Methods.

B

backquote

n. the standard character that is variously called “grave accent” or “backquote” (`). See Figure~2–5.

backslash

n. the standard character that is variously called “reverse solidus” or “backslash” (\). See Figure~2–5.

base character

n. a character

of type base-char.

base string

n. a string of type base-string.

before method

n. a method having the qualifier :before.

bidirectional

adj. (of a stream) being both an input stream and an output stream.

binary

adj. 1. (of a stream) being a stream that has an element type that is a subtype of type integer. The most fundamental operation on a binary input stream is read-byte and on a binary output stream is write-byte. See character. 2. (of a file) having been created by opening a binary stream. (It is implementation-dependent whether this is an detectable aspect of the file, or whether any given character file can be treated as a binary file.)

bind

v.t. (a variable) to establish a binding for the variable.

binding

n. an association between a name and that which the name denotes. “A lexical binding is a lexical association between a name and its value.”

bit

n. an object of type bit; that is, the integer 0 or the integer 1.

bit array

n. a specialized array that is of type (array bit), and whose elements are of type bit.

bit vector

n. a specialized vector that is of type bit-vector, and whose elements are of type bit.

bit-wise logical operation specifier

n. an object which names one of the sixteen possible bit-wise logical operations that can be performed by the boole function, and which is the value of exactly one of the constant variables boole-clr, boole-set, boole-1, boole-2, boole-c1, boole-c2, boole-and, boole-ior, boole-xor, boole-eqv, boole-nand, boole-nor, boole-andc1, boole-andc2, boole-orc1, or boole-orc2.

block

n. a named lexical exit point, established explicitly by block or implicitly by operators such as loop, do and prog, to which control and values may be transfered by using a return-from form with the name of the block.

block tag

n. the symbol that, within the lexical scope of a block form, names the block established by that block form. See return or return-from.

boa lambda list

n. a lambda list that is syntactically like an ordinary lambda list, but that is processed in “by order of argument” style. See Boa Lambda Lists.

body parameter

n. a parameter available in certain lambda lists which from the point of view of conforming programs is like a rest parameter in every way except that it is introduced by &body instead of &rest. (Implementations are permitted to provide extensions which distinguish body parameters and rest parameters—e.g., the forms for operators which were defined using a body parameter might be pretty printed slightly differently than forms for operators which were defined using rest parameters.)

boolean

n. an object of type boolean; that is, one of the following objects: the symbol~t (representing true), or the symbol~nil (representing false). See generalized boolean.

boolean equivalent

n. (of an object O_1) any object O_2 that has the same truth value as O_1 when both O_1 and O_2 are viewed as generalized booleans.

bound

adj., v.t. 1. adj. having an associated denotation in a binding. “The variables named by a let are bound within its body.” See unbound. 2. adj. having a local binding which shadows_2 another. “The variable *print-escape* is bound while in the princ function.” 3. v.t. the past tense of bind.

bound declaration

n. a declaration that refers to or is associated with a variable or function and that appears within the special form that establishes the variable or function, but before the body of that special form (specifically, at the head of that form’s body). (If a bound declaration refers to a function binding or a lexical variable binding, the scope of the declaration is exactly the scope of that binding. If the declaration refers to a dynamic variable binding, the scope of the declaration is what the scope of the binding would have been if it were lexical rather than dynamic.)

bounded

adj. (of a sequence S, by an ordered pair of bounding indices i_{start} and i_{end}) restricted to a subrange of the elements of S that includes each element beginning with (and including) the one indexed by i_{start} and continuing up to (but not including) the one indexed by i_{end}.

bounding index

n. (of a sequence with length n) either of a conceptual pair of integers, i_{start} and i_{end}, respectively called the “lower bounding index” and “upper bounding index”, such that 0 <= i_{start} <= i_{end} <= n, and which therefore delimit a subrange of the sequence bounded by i_{start} and i_{end}.

bounding index designator

(for a sequence) one of two objects that, taken together as an ordered pair, behave as a designator for bounding indices of the sequence; that is, they denote bounding indices of the sequence, and are either: an integer (denoting itself) and nil (denoting the length of the sequence), or two integers (each denoting themselves).

break loop

n. A variant of the normal Lisp read-eval-print loop that is recursively entered, usually because the ongoing evaluation of some other form has been suspended for the purpose of debugging. Often, a break loop provides the ability to exit in such a way as to continue the suspended computation. See the function break.

broadcast stream

n. an output stream of type broadcast-stream.

built-in class

n. a class that is a generalized instance of class built-in-class.

built-in type

n. one of the types in Figure~4–2.

byte

n. 1. adjacent bits within an integer. (The specific number of bits can vary from point to point in the program; see the function byte.) 2. an integer in a specified range. (The specific range can vary from point to point in the program; see the functions open and write-byte.)

byte specifier

n. An object of implementation-dependent nature that is returned by the function byte and that specifies the range of bits in an integer to be used as a byte by functions such as ldb.

C

cadr

pronounced ’ka ,de r , n. (of an object) the car of the cdr of that object.

call

v.t., n. 1. v.t. (a function with arguments) to cause the code represented by that function to be executed in an environment where bindings for the values of its parameters have been established based on the arguments. “Calling the function + with the arguments 5 and 1 yields a value of 6.” 2. n. a situation in which a function is called.

captured initialization form

n. an initialization form along with the lexical environment in which the form that defined the initialization form was evaluated. “Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified in the defclass form for the new class.”

car

n. 1. a. (of a cons) the component of a cons corresponding to the first argument to cons; the other component is the cdr. “The function rplaca modifies the car of a cons.” b. (of a list) the first element of the list, or nil if the list is the empty list. 2. the object that is held in the car_1. “The function car returns the car of a cons.”

case

n. (of a character) the property of being either uppercase or lowercase. Not all characters have case. “The characters #\A and #\a have case, but the character #\$ has no case.” See Characters With Case and the function both-case-p.

case sensitivity mode

n. one of the symbols :upcase, :downcase, :preserve, or :invert.

catch

n. an exit point which is established by a catch form within the dynamic scope of its body, which is named by a catch tag, and to which control and values may be thrown.

catch tag

n. an object which names an active catch. (If more than one catch is active with the same catch tag, it is only possible to throw to the innermost such catch because the outer one is shadowed_2.)

cddr

pronounced ’kud e ,de r or pronounced ’ke ,dude r , n. (of an object) the cdr of the cdr of that object.

cdr

pronounced ’ku ,de r , n. 1. a. (of a cons) the component of a cons corresponding to the second argument to cons; the other component is the car. “The function rplacd modifies the cdr of a cons.” b. (of a list L_1) either the list L_2 that contains the elements of L_1 that follow after the first, or else nil if L_1 is the empty list. 2. the object that is held in the cdr_1. “The function cdr returns the cdr of a cons.”

cell

n. Trad. (of an object) a conceptual slot of that object. The dynamic variable and global function bindings of a symbol are sometimes referred to as its value cell and function cell, respectively.

character

n., adj. 1. n. an object of type character; that is, an object that represents a unitary token in an aggregate quantity of text; see Character Concepts. 2. adj. a. (of a stream) having an element type that is a subtype of type character. The most fundamental operation on a character input stream is read-char and on a character output stream is write-char. See binary. b. (of a file) having been created by opening a character stream. (It is implementation-dependent whether this is an inspectable aspect of the file, or whether any given binary file can be treated as a character file.)

character code

n. 1. one of possibly several attributes of a character. 2. a non-negative integer less than the value of char-code-limit that is suitable for use as a character code_1.

character designator

n. a designator for a character; that is, an object that denotes a character and that is one of: a designator for a string of length one (denoting the character that is its only element),

or a character (denoting itself).

circular

adj. 1. (of a list) a circular list. 2. (of an arbitrary object) having a component, element, constituent_2, or subexpression (as appropriate to the context) that is the object itself.

circular list

n. a chain of conses that has no termination because some cons in the chain is the cdr of a later cons.

class

n. 1. an object that uniquely determines the structure and behavior of a set of other objects called its direct instances, that contributes structure and behavior to a set of other objects called its indirect instances, and that acts as a type specifier for a set of objects called its generalized instances. “The class integer is a subclass of the class number.” (Note that the phrase “the class foo” is often substituted for the more precise phrase “the class named foo”—in both cases, a class object (not a symbol) is denoted.) 2. (of an object) the uniquely determined class of which the object is a direct instance. See the function class-of. “The class of the object returned by gensym is symbol.” (Note that with this usage a phrase such as “its class is foo” is often substituted for the more precise phrase “its class is the class named foo”—in both cases, a class object (not a symbol) is denoted.)

class designator

n. a designator for a class; that is, an object that denotes a class and that is one of: a symbol (denoting the class named by that symbol; see the function find-class) or a class (denoting itself).

class precedence list

n. a unique total ordering on a class and its superclasses that is consistent with the local precedence orders for the class and its superclasses. For detailed information, see Determining the Class Precedence List.

close

v.t. (a stream) to terminate usage of the stream as a source or sink of data, permitting the implementation to reclaim its internal data structures, and to free any external resources which might have been locked by the stream when it was opened.

closed

adj. (of a stream) having been closed (see close). Some (but not all) operations that are valid on open streams are not valid on closed streams. See File Operations on Open and Closed Streams.

closure

n. a lexical closure.

coalesce

v.t. (literal objects that are similar) to consolidate the identity of those objects, such that they become the same object. See Compiler Terminology.

code

n. 1. Trad. any representation of actions to be performed, whether conceptual or as an actual object, such as forms, lambda expressions, objects of type function, text in a source file, or instruction sequences in a compiled file. This is a generic term; the specific nature of the representation depends on its context. 2. (of a character) a character code.

coerce

v.t. (an object to a type) to produce an object from the given object, without modifying that object, by following some set of coercion rules that must be specifically stated for any context in which this term is used. The resulting object is necessarily of the indicated type, except when that type is a subtype of type complex; in that case, if a complex rational with an imaginary part of zero would result, the result is a rational rather than a complex—see Rule of Canonical Representation for Complex Rationals.

colon

n. the standard character that is called “colon” (:). See Figure~2–5.

comma

n. the standard character that is called “comma” (,). See Figure~2–5.

compilation

n. the process of compiling code by the compiler.

compilation environment

n. 1. An environment that represents information known by the compiler about a form that is being compiled. See Compiler Terminology. 2. An object that represents the compilation environment_1 and that is used as a second argument to a macro function (which supplies a value for any &environment parameter in the macro function’s definition).

compilation unit

n. an interval during which a single unit of compilation is occurring. See the macro with-compilation-unit.

compile

v.t. 1. (code) to perform semantic preprocessing of the code, usually optimizing one or more qualities of the code, such as run-time speed of execution or run-time storage usage. The minimum semantic requirements of compilation are that it must remove all macro calls and arrange for all load time values to be resolved prior to run time. 2. (a function) to produce a new object of type compiled-function which represents the result of compiling the code represented by the function. See the function compile. 3. (a source file) to produce a compiled file from a source file. See the function compile-file.

compile time

n. the duration of time that the compiler is processing source code.

compile-time definition

n. a definition in the compilation environment.

compiled code

n. 1. compiled functions. 2. code that represents compiled functions, such as the contents of a compiled file.

compiled file

n. a file which represents the results of compiling the forms which appeared in a corresponding source file, and which can be loaded. See the function compile-file.

compiled function

n. an object of type compiled-function, which is a function that has been compiled, which contains no references to macros that must be expanded at run time, and which contains no unresolved references to load time values.

compiler

n. a facility that is part of Lisp and that translates code into an implementation-dependent form that might be represented or executed efficiently. The functions compile and compile-file permit programs to invoke the compiler.

compiler macro

n. an auxiliary macro definition for a globally defined function or macro which might or might not be called by any given conforming implementation and which must preserve the semantics of the globally defined function or macro but which might perform some additional optimizations. (Unlike a macro, a compiler macro does not extend the syntax of Common Lisp; rather, it provides an alternate implementation strategy for some existing syntax or functionality.)

compiler macro expansion

n. 1. the process of translating a form into another form by a compiler macro. 2. the form resulting from this process.

compiler macro form

n. a function form or macro form whose operator has a definition as a compiler macro, or a funcall form whose first argument is a function form whose argument is the name of a function that has a definition as a compiler macro.

compiler macro function

n. a function of two arguments, a form and an environment, that implements compiler macro expansion by producing either a form to be used in place of the original argument form or else nil, indicating that the original form should not be replaced. See Compiler Macros.

complex

n. an object of type complex.

complex float

n. an object of type complex which has a complex part type that is a subtype of float. A complex float is a complex, but it is not a float.

complex part type

n. (of a complex) 1. the type which is used to represent both the real part and the imaginary part of the complex. 2. the actual complex part type of the complex. 3. the expressed complex part type of the complex.

complex rational

n. an object of type complex which has a complex part type that is a subtype of rational. A complex rational is a complex, but it is not a rational. No complex rational has an imaginary part of zero because such a number is always represented by Common Lisp as an object of type rational; see Rule of Canonical Representation for Complex Rationals.

complex single float

n. an object of type complex which has a complex part type that is a subtype of single-float. A complex single float is a complex, but it is not a single float.

composite stream

n. a stream that is composed of one or more other streams. “make-synonym-stream creates a composite stream.”

compound form

n. a non-empty list which is a form: a special form, a lambda form, a macro form, or a function form.

compound type specifier

n. a type specifier that is a cons; i.e., a type specifier that is not an atomic type specifier. “(vector single-float) is a compound type specifier.”

concatenated stream

n. an input stream of type concatenated-stream.

condition

n. 1. an object which represents a situation—usually, but not necessarily, during signaling. 2. an object of type condition.

condition designator

n. one or more objects that, taken together, denote either an existing condition object or a condition object to be implicitly created. For details, see Condition Designators.

condition handler

n. a function that might be invoked by the act of signaling, that receives the condition being signaled as its only argument, and that is permitted to handle the condition or to decline. See Signaling.

condition reporter

n. a function that describes how a condition is to be printed when the Lisp printer is invoked while *print-escape* is false. See Printing Conditions.

conditional newline

n. a point in output where a newline might be inserted at the discretion of the pretty printer. There are four kinds of conditional newlines, called “linear-style,” “fill-style,” “miser-style,” and “mandatory-style.” See the function pprint-newline and Dynamic Control of the Arrangement of Output.

conformance

n. a state achieved by proper and complete adherence to the requirements of this specification. See Conformance.

conforming code

n. code that is all of part of a conforming program.

conforming implementation

n. an implementation, used to emphasize complete and correct adherance to all conformance criteria. A conforming implementation is capable of accepting a conforming program as input, preparing that program for execution, and executing the prepared program in accordance with this specification. An implementation which has been extended may still be a conforming implementation provided that no extension interferes with the correct function of any conforming program.

conforming processor

n. ANSI a conforming implementation.

conforming program

n. a program, used to emphasize the fact that the program depends for its correctness only upon documented aspects of Common Lisp, and can therefore be expected to run correctly in any conforming implementation.

congruent

n. conforming to the rules of lambda list congruency, as detailed in Congruent Lambda-lists for all Methods of a Generic Function.

cons

n.v. 1. n. a compound data object having two components called the car and the cdr. 2. v. to create such an object. 3. v. Idiom. to create any object, or to allocate storage.

constant

n. 1. a constant form. 2. a constant variable. 3. a constant object. 4. a self-evaluating object.

constant form

n. any form for which evaluation always yields the same value, that neither affects nor is affected by the environment in which it is evaluated (except that it is permitted to refer to the names of constant variables defined in the environment), and that neither affects nor is affected by the state of any object except those objects that are otherwise inaccessible parts of objects created by the form itself. “A car form in which the argument is a quote form is a constant form.”

constant object

n. an object that is constrained (e.g., by its context in a program or by the source from which it was obtained) to be immutable. “A literal object that has been processed by compile-file is a constant object.”

constant variable

n. a variable, the value of which can never change; that is, a keyword_1 or a named constant. “The symbols t, nil, :direction, and most-positive-fixnum are constant variables.”

constituent

n., adj. 1. a. n. the syntax type of a character that is part of a token. For details, see Constituent Characters. b. adj. (of a character) having the constituent_{1a} syntax type_2. c. n. a constituent_{1b} character. 2. n. (of a composite stream) one of possibly several objects that collectively comprise the source or sink of that stream.

constituent trait

n. (of a character) one of several classifications of a constituent character in a readtable. See Constituent Characters.

constructed stream

n. a stream whose source or sink is a Lisp object. Note that since a stream is another Lisp object, composite streams are considered constructed streams. “A string stream is a constructed stream.”

contagion

n. a process whereby operations on objects of differing types (e.g., arithmetic on mixed types of numbers) produce a result whose type is controlled by the dominance of one argument’s type over the types of the other arguments. See Contagion in Numeric Operations.

continuable

n. (of an error) an error that is correctable by the continue restart.

control form

n. 1. a form that establishes one or more places to which control can be transferred. 2. a form that transfers control.

copy

n. 1. (of a cons C) a fresh cons with the same car and cdr as C. 2. (of a list L) a fresh list with the same elements as L. (Only the list structure is fresh; the elements are the same.) See the function copy-list. 3. (of an association list A with elements A_i) a fresh list B with elements B_i, each of which is nil if A_i is nil, or else a copy of the cons A_i. See the function copy-alist. 4. (of a tree T) a fresh tree with the same leaves as T. See the function copy-tree. 5. (of a random state R) a fresh random state that, if used as an argument to to the function random would produce the same series of “random” values as R would produce.

6. (of a structure S) a fresh structure that has the same type as S, and that has slot values, each of which is the same as the corresponding slot value of S.

(Note that since the difference between a cons, a list, and a tree is a matter of “view” or “intention,” there can be no general-purpose function which, based solely on the type of an object, can determine which of these distinct meanings is intended. The distinction rests solely on the basis of the text description within this document. For example, phrases like “a copy of the given list” or “copy of the list x” imply the second definition.)

correctable

adj. (of an error) 1. (by a restart other than abort that has been associated with the error) capable of being corrected by invoking that restart. “The function cerror signals an error that is correctable by the continue restart.”

(Note that correctability is not a property of an error object, but rather a property of the dynamic environment that is in effect when the error is signaled. Specifically, the restart is “associated with” the error condition object. See Associating a Restart with a Condition.)

2. (when no specific restart is mentioned) correctable_1 by at least one restart. “import signals a correctable error of type package-error if any of the imported symbols has the same name as some distinct symbol already accessible in the package.”

current input base

n. (in a dynamic environment) the radix that is the value of *read-base* in that environment, and that is the default radix employed by the Lisp reader and its related functions.

current logical block

n. the context of the innermost lexically enclosing use of pprint-logical-block.

current output base

n. (in a dynamic environment) the radix that is the value of *print-base* in that environment, and that is the default radix employed by the Lisp printer and its related functions.

current package

n. (in a dynamic environment) the package that is the value of *package* in that environment, and that is the default package employed by the Lisp reader and Lisp printer, and their related functions.

current pprint dispatch table

n. (in a dynamic environment) the pprint dispatch table that is the value of *print-pprint-dispatch* in that environment, and that is the default pprint dispatch table employed by the pretty printer.

current random state

n. (in a dynamic environment) the random state that is the value of *random-state* in that environment, and that is the default random state employed by random.

current readtable

n. (in a dynamic environment) the readtable that is the value of *readtable* in that environment, and that affects the way in which expressions_2 are parsed into objects by the Lisp reader.

D

data type

n. Trad. a type.

debug I/O

n. the bidirectional stream that is the value of the variable *debug-io*.

debugger

n. a facility that allows the user to handle a condition interactively. For example, the debugger might permit interactive selection of a restart from among the active restarts, and it might perform additional implementation-defined services for the purposes of debugging.

declaration

n. a global declaration or local declaration.

declaration identifier

n. one of the symbols declaration, dynamic-extent, ftype, function, ignore, inline, notinline, optimize, special, or type; or a symbol which is the name of a type; or a symbol which has been declared to be a declaration identifier by using a declaration declaration.

declaration specifier

n. an expression that can appear at top level of a declare expression or a declaim form, or as the argument to proclaim, and which has a car which is a declaration identifier, and which has a cdr that is data interpreted according to rules specific to the declaration identifier.

declare

v. to establish a declaration. See declare, declaim, or proclaim.

decline

v. (of a handler) to return normally without having handled the condition being signaled, permitting the signaling process to continue as if the handler had not been present.

decoded time

n. absolute time, represented as an ordered series of nine objects which, taken together, form a description of a point in calendar time, accurate to the nearest second (except that leap seconds are ignored). See Decoded Time.

default method

n. a method having no parameter specializers other than the class t. Such a method is always an applicable method but might be shadowed_2 by a more specific method.

defaulted initialization argument list

n. a list of alternating initialization argument names and values in which unsupplied initialization arguments are defaulted, used in the protocol for initializing and reinitializing instances of classes.

define-method-combination arguments lambda list

n. a lambda list used by the :arguments option to define-method-combination. See Define-method-combination Arguments Lambda Lists.

define-modify-macro lambda list

n. a lambda list used by define-modify-macro. See Define-modify-macro Lambda Lists.

defined name

n. a symbol the meaning of which is defined by Common Lisp.

defining form

n. a form that has the side-effect of establishing a definition. “defun and defparameter are defining forms.”

defsetf lambda list

n. a lambda list that is like an ordinary lambda list except that it does not permit &aux and that it permits use of &environment. See Defsetf Lambda Lists.

deftype lambda list

n. a lambda list that is like a macro lambda list except that the default value for unsupplied optional parameters and keyword parameters is the symbol * (rather than nil). See Deftype Lambda Lists.

denormalized

adj., ANSI, IEEE (of a float) conforming to the description of “denormalized” as described by IEEE Standard for Binary Floating-Point Arithmetic. For example, in an implementation where the minimum possible exponent was -7 but where 0.001 was a valid mantissa, the number 1.0e-10 might be representable as 0.001e-7 internally even if the normalized representation would call for it to be represented instead as 1.0e-10 or 0.1e-9. By their nature, denormalized floats generally have less precision than normalized floats.

derived type

n. a type specifier which is defined in terms of an expansion into another type specifier. deftype defines derived types, and there may be other implementation-defined operators which do so as well.

derived type specifier

n. a type specifier for a derived type.

designator

n. an object that denotes another object. In the dictionary entry for an operator if a parameter is described as a designator for a type, the description of the operator is written in a way that assumes that appropriate coercion to that type has already occurred; that is, that the parameter is already of the denoted type. For more detailed information, see Designators.

destructive

adj. (of an operator) capable of modifying some program-visible aspect of one or more objects that are either explicit arguments to the operator or that can be obtained directly or indirectly from the global environment by the operator.

destructuring lambda list

n. an extended lambda list used in destructuring-bind and nested within macro lambda lists. See Destructuring Lambda Lists.

different

adj. not the same “The strings "FOO" and "foo" are different under equal but not under equalp.”

digit

n. (in a radix) a character that is among the possible digits (0 to 9, A to Z, and a to z) and that is defined to have an associated numeric weight as a digit in that radix. See Digits in a Radix.

dimension

n. 1. a non-negative integer indicating the number of objects an array can hold along one axis. If the array is a vector with a fill pointer, the fill pointer is ignored. “The second dimension of that array is 7.” 2. an axis of an array. “This array has six dimensions.”

direct instance

n. (of a class C) an object whose class is C itself, rather than some subclass of C. “The function make-instance always returns a direct instance of the class which is (or is named by) its first argument.”

direct subclass

n. (of a class C_1) a class C_2, such that C_1 is a direct superclass of C_2.

direct superclass

n. (of a class C_1) a class C_2 which was explicitly designated as a superclass of C_1 in the definition of C_1.

disestablish

v.t. to withdraw the establishment of an object, a binding, an exit point, a tag, a handler, a restart, or an environment.

disjoint

n. (of types) having no elements in common.

dispatching macro character

n. a macro character that has an associated table that specifies the function to be called for each character that is seen following the dispatching macro character. See the function make-dispatch-macro-character.

displaced array

n. an array which has no storage of its own, but which is instead indirected to the storage of another array, called its target, at a specified offset, in such a way that any attempt to access the displaced array implicitly references the target array.

distinct

adj. not identical.

documentation string

n. (in a defining form) A literal string which because of the context in which it appears (rather than because of some intrinsically observable aspect of the string) is taken as documentation. In some cases, the documentation string is saved in such a way that it can later be obtained by supplying either an object, or by supplying a name and a “kind” to the function documentation. “The body of code in a defmacro form can be preceded by a documentation string of kind function.”

dot

n. the standard character that is variously called “full stop,” “period,” or “dot” (.). See Figure~2–5.

dotted list

n. a list which has a terminating atom that is not nil. (An atom by itself is not a dotted list, however.)

dotted pair

n. 1. a cons whose cdr is a non-list. 2. any cons, used to emphasize the use of the cons as a symmetric data pair.

double float

n. an object of type double-float.

double-quote

n. the standard character that is variously called “quotation mark” or “double quote” ("). See Figure~2–5.

dynamic binding

n. a binding in a dynamic environment.

dynamic environment

n. that part of an environment that contains bindings with dynamic extent. A dynamic environment contains, among other things: exit points established by unwind-protect, and bindings of dynamic variables, exit points established by catch, condition handlers, and restarts.

dynamic extent

n. an extent whose duration is bounded by points of establishment and disestablishment within the execution of a particular form. See indefinite extent. “Dynamic variable bindings have dynamic extent.”

dynamic scope

n. indefinite scope along with dynamic extent.

dynamic variable

n. a variable the binding for which is in the dynamic environment. See special.

E

echo stream

n. a stream of type echo-stream.

effective method

n. the combination of applicable methods that are executed when a generic function is invoked with a particular sequence of arguments.

element

n. 1. (of a list) an object that is the car of one of the conses that comprise the list. 2. (of an array) an object that is stored in the array. 3. (of a sequence) an object that is an element of the list or array that is the sequence. 4. (of a type) an object that is a member of the set of objects designated by the type. 5. (of an input stream) a character or number (as appropriate to the element type of the stream) that is among the ordered series of objects that can be read from the stream (using read-char or read-byte, as appropriate to the stream). 6. (of an output stream) a character or number (as appropriate to the element type of the stream) that is among the ordered series of objects that has been or will be written to the stream (using write-char or write-byte, as appropriate to the stream). 7. (of a class) a generalized instance of the class.

element type

n. 1. (of an array) the array element type of the array. 2. (of a stream) the stream element type of the stream.

em

n. Trad. a context-dependent unit of measure commonly used in typesetting, equal to the displayed width of of a letter “M” in the current font. (The letter “M” is traditionally chosen because it is typically represented by the widest glyph in the font, and other characters’ widths are typically fractions of an em. In implementations providing non-Roman characters with wider characters than “M,” it is permissible for another character to be the implementation-defined reference character for this measure, and for “M” to be only a fraction of an em wide.) In a fixed width font, a line with n characters is n ems wide; in a variable width font, n ems is the expected upper bound on the width of such a line.

empty list

n. the list containing no elements. See ().

empty type

n. the type that contains no elements, and that is a subtype of all types (including itself). See nil.

end of file

n. 1. the point in an input stream beyond which there is no further data. Whether or not there is such a point on an interactive stream is implementation-defined. 2. a situation that occurs upon an attempt to obtain data from an input stream that is at the end of file_1.

environment

n. 1. a set of bindings. See Introduction to Environments. 2. an environment object. “macroexpand takes an optional environment argument.”

environment object

n. an object representing a set of lexical bindings, used in the processing of a form to provide meanings for names within that form. “macroexpand takes an optional environment argument.” (The object nil when used as an environment object denotes the null lexical environment; the values of environment parameters to macro functions are objects of implementation-dependent nature which represent the environment_1 in which the corresponding macro form is to be expanded.) See Environment Objects.

environment parameter

n. A parameter in a defining form f for which there is no corresponding argument; instead, this parameter receives as its value an environment object which corresponds to the lexical environment in which the defining form f appeared.

error

n. 1. (only in the phrase “is an error”) a situation in which the semantics of a program are not specified, and in which the consequences are undefined. 2. a condition which represents an error situation. See Error Terminology. 3. an object of type error.

error output

n. the output stream which is the value of the dynamic variable *error-output*.

escape

n., adj. 1. n. a single escape or a multiple escape. 2. adj. single escape or multiple escape.

establish

v.t. to build or bring into being a binding, a declaration, an exit point, a tag, a handler, a restart, or an environment. “let establishes lexical bindings.”

evaluate

v.t. (a form or an implicit progn) to execute the code represented by the form (or the series of forms making up the implicit progn) by applying the rules of evaluation, returning zero or more values.

evaluation

n. a model whereby forms are executed, returning zero or more values. Such execution might be implemented directly in one step by an interpreter or in two steps by first compiling the form and then executing the compiled code; this choice is dependent both on context and the nature of the implementation, but in any case is not in general detectable by any program. The evaluation model is designed in such a way that a conforming implementation might legitimately have only a compiler and no interpreter, or vice versa. See The Evaluation Model.

evaluation environment

n. a run-time environment in which macro expanders and code specified by eval-when to be evaluated are evaluated. All evaluations initiated by the compiler take place in the evaluation environment.

execute

v.t. Trad. (code) to perform the imperative actions represented by the code.

execution time

n. the duration of time that compiled code is being executed.

exhaustive partition

n. (of a type) a set of pairwise disjoint types that form an exhaustive union.

exhaustive union

n. (of a type) a set of subtypes of the type, whose union contains all elements of that type.

exit point

n. a point in a control form from which (e.g., block), through which (e.g., unwind-protect), or to which (e.g., tagbody) control and possibly values can be transferred both actively by using another control form and passively through the normal control and data flow of evaluation. “catch and block establish bindings for exit points to which throw and return-from, respectively, can transfer control and values; tagbody establishes a binding for an exit point with lexical extent to which go can transfer control; and unwind-protect establishes an exit point through which control might be transferred by operators such as throw, return-from, and go.”

explicit return

n. the act of transferring control (and possibly values) to a block by using return-from (or return).

explicit use

n. (of a variable V in a form F) a reference to V that is directly apparent in the normal semantics of F; i.e., that does not expose any undocumented details of the macro expansion of the form itself. References to V exposed by expanding subforms of F are, however, considered to be explicit uses of V.

exponent marker

n. a character that is used in the textual notation for a float to separate the mantissa from the exponent. The characters defined as exponent markers in the standard readtable are shown in Figure 26–1. For more information, see Character Syntax. “The exponent marker ‘d’ in ‘3.0d7’ indicates that this number is to be represented as a double float.” 

  Marker  Meaning                                  
  D or d  double-float                             
  E or e  float (see *read-default-float-format*)  
  F or f  single-float                             
  L or l  long-float                               
  S or s  short-float                              

           Figure 26–1: Exponent Markers
export

v.t. (a symbol in a package) to add the symbol to the list of external symbols of the package.

exported

adj. (of a symbol in a package) being an external symbol of the package.

expressed adjustability

n. (of an array) a generalized boolean that is conceptually (but not necessarily actually) associated with the array, representing whether the array is expressly adjustable. See also actual adjustability.

expressed array element type

n. (of an array) the type which is the array element type implied by a type declaration for the array, or which is the requested array element type at its time of creation, prior to any selection of an upgraded array element type. (Common Lisp does not provide a way of detecting this type directly at run time, but an implementation is permitted to make assumptions about the array’s contents and the operations which may be performed on the array when this type is noted during code analysis, even if those assumptions would not be valid in general for the upgraded array element type of the expressed array element type.)

expressed complex part type

n. (of a complex) the type which is implied as the complex part type by a type declaration for the complex, or which is the requested complex part type at its time of creation, prior to any selection of an upgraded complex part type. (Common Lisp does not provide a way of detecting this type directly at run time, but an implementation is permitted to make assumptions about the operations which may be performed on the complex when this type is noted during code analysis, even if those assumptions would not be valid in general for the upgraded complex part type of the expressed complex part type.)

expression

n. 1. an object, often used to emphasize the use of the object to encode or represent information in a specialized format, such as program text. “The second expression in a let form is a list of bindings.” 2. the textual notation used to notate an object in a source file. “The expression 'sample is equivalent to (quote sample).”

expressly adjustable

adj. (of an array) being actually adjustable by virtue of an explicit request for this characteristic having been made at the time of its creation. All arrays that are expressly adjustable are actually adjustable, but not necessarily vice versa.

extended character

n. a character

of type extended-char:

a character that is not a base character.

extended function designator

n. a designator for a function; that is, an object that denotes a function and that is one of: a function name (denoting the function it names in the global environment), or a function (denoting itself). The consequences are undefined if a function name is used as an extended function designator but it does not have a global definition as a function, or if it is a symbol that has a global definition as a macro or a special form. See also function designator.

extended lambda list

n. a list resembling an ordinary lambda list in form and purpose, but offering additional syntax or functionality not available in an ordinary lambda list. “defmacro uses extended lambda lists.”

extension

n. a facility in an implementation of Common Lisp that is not specified by this standard.

extent

n. the interval of time during which a reference to an object, a binding, an exit point, a tag, a handler, a restart, or an environment is defined.

external file format

n. an object of implementation-dependent nature which determines one of possibly several implementation-dependent ways in which characters are encoded externally in a character file.

external file format designator

n. a designator for an external file format; that is, an object that denotes an external file format and that is one of: the symbol :default (denoting an implementation-dependent default external file format that can accomodate at least the base characters), some other object defined by the implementation to be an external file format designator (denoting an implementation-defined external file format), or some other object defined by the implementation to be an external file format (denoting itself).

external symbol

n. (of a package) a symbol that is part of the ‘external interface’ to the package and that are inherited_3 by any other package that uses the package. When using the Lisp reader, if a package prefix is used, the name of an external symbol is separated from the package name by a single package marker while the name of an internal symbol is separated from the package name by a double package marker; see Symbols as Tokens.

externalizable object

n. an object that can be used as a literal object in code to be processed by the file compiler.

F

false

n. the symbol nil, used to represent the failure of a predicate test.

fbound

pronounced ’ef ,baund adj. (of a function name) bound in the function namespace. (The names of macros and special operators are fbound, but the nature and type of the object which is their value is implementation-dependent.

Further, defining a setf expander F does not cause the setf function (setf F) to become defined; as such, if there is a such a definition of a setf expander F, the function (setf F) can be fbound if and only if, by design or coincidence, a function binding for (setf F) has been independently established.)

See the functions fboundp and symbol-function.

feature

n. 1. an aspect or attribute of Common Lisp, of the implementation, or of the environment. 2. a symbol that names a feature_1. See Features. “The :ansi-cl feature is present in all conforming implementations.”

feature expression

n. A boolean combination of features used by the #+ and #- reader macros in order to direct conditional reading of expressions by the Lisp reader. See Feature Expressions.

features list

n. the list that is the value of *features*.

file

n. a named entry in a file system, having an implementation-defined nature.

file compiler

n. any compiler which compiles source code contained in a file, producing a compiled file as output. The compile-file function is the only interface to such a compiler provided by Common Lisp, but there might be other, implementation-defined mechanisms for invoking the file compiler.

file position

n. (in a stream) a non-negative integer that represents a position in the stream. Not all streams are able to represent the notion of file position; in the description of any operator which manipulates file positions, the behavior for streams that don’t have this notion must be explicitly stated. For binary streams, the file position represents the number of preceding bytes in the stream. For character streams, the constraint is more relaxed: file positions must increase monotonically, the amount of the increase between file positions corresponding to any two successive characters in the stream is implementation-dependent.

file position designator

n. (in a stream) a designator for a file position in that stream; that is, the symbol :start (denoting 0, the first file position in that stream), the symbol :end (denoting the last file position in that stream; i.e., the position following the last element of the stream), or a file position (denoting itself).

file stream

n. an object of type file-stream.

file system

n. a facility which permits aggregations of data to be stored in named files on some medium that is external to the Lisp image and that therefore persists from session to session.

filename

n. a handle, not necessarily ever directly represented as an object, that can be used to refer to a file in a file system. Pathnames and namestrings are two kinds of objects that substitute for filenames in Common Lisp.

fill pointer

n. (of a vector) an integer associated with a vector that represents the index above which no elements are active. (A fill pointer is a non-negative integer no larger than the total number of elements in the vector. Not all vectors have fill pointers.)

finite

adj. (of a type) having a finite number of elements. “The type specifier (integer 0 5) denotes a finite type, but the type specifiers integer and (integer 0) do not.”

fixnum

n. an integer of type fixnum.

float

n. an object of type float.

for-value

adj. (of a reference to a binding) being a reference that reads_1 the value of the binding.

form

n. 1. any object meant to be evaluated. 2. a symbol, a compound form, or a self-evaluating object. 3. (for an operator, as in “<<operator>> form”) a compound form having that operator as its first element. “A quote form is a constant form.”

formal argument

n. Trad. a parameter.

formal parameter

n. Trad. a parameter.

format

v.t. (a format control and format arguments) to perform output as if by format, using the format string and format arguments.

format argument

n. an object which is used as data by functions such as format which interpret format controls.

format control

n. a format string, or a function that obeys the argument conventions for a function returned by the formatter macro. See Compiling Format Strings.

format directive

n. 1. a sequence of characters in a format string which is introduced by a tilde, and which is specially interpreted by code which processes format strings to mean that some special operation should be performed, possibly involving data supplied by the format arguments that accompanied the format string. See the function format. “In "~D base 10 = ~8R", the character sequences ‘~D’ and ‘~8R’ are format directives.” 2. the conceptual category of all format directives_1 which use the same dispatch character. “Both "~3d" and "~3,'0D" are valid uses of the ‘~D’ format directive.”

format string

n. a string which can contain both ordinary text and format directives, and which is used in conjunction with format arguments to describe how text output should be formatted by certain functions, such as format.

free declaration

n. a declaration that is not a bound declaration. See declare.

fresh

adj. 1. (of an object yielded by a function) having been newly-allocated by that function. (The caller of a function that returns a fresh object may freely modify the object without fear that such modification will compromise the future correct behavior of that function.) 2. (of a binding for a name) newly-allocated; not shared with other bindings for that name.

freshline

n. a conceptual operation on a stream, implemented by the function fresh-line and by the format directive ~&, which advances the display position to the beginning of the next line (as if a newline had been typed, or the function terpri had been called) unless the stream is already known to be positioned at the beginning of a line. Unlike newline, freshline is not a character.

funbound

pronounced ’ef unbaund n. (of a function name) not fbound.

function

n.

1. an object representing code, which can be called with zero or more arguments, and which produces zero or more values. 2. an object of type function.

function block name

n. (of a function name) The symbol that would be used as the name of an implicit block which surrounds the body of a function having that function name. If the function name is a symbol, its function block name is the function name itself. If the function name is a list whose car is setf and whose cadr is a symbol, its function block name is the symbol that is the cadr of the function name. An implementation which supports additional kinds of function names must specify for each how the corresponding function block name is computed.

function cell

n. Trad. (of a symbol) The place which holds the definition of the global function binding, if any, named by that symbol, and which is accessed by symbol-function. See cell.

function designator

n. a designator for a function; that is, an object that denotes a function and that is one of: a symbol (denoting the function named by that symbol in the global environment), or a function (denoting itself). The consequences are undefined if a symbol is used as a function designator but it does not have a global definition as a function, or it has a global definition as a macro or a special form. See also extended function designator.

function form

n. a form that is a list and that has a first element which is the name of a function to be called on arguments which are the result of evaluating subsequent elements of the function form.

function name

n. (in an environment) A symbol or a list (setf symbol) that is the name of a function in that environment.

functional evaluation

n. the process of extracting a functional value from a function name or a lambda expression. The evaluator performs functional evaluation implicitly when it encounters a function name or a lambda expression in the car of a compound form, or explicitly when it encounters a function special form. Neither a use of a symbol as a function designator nor a use of the function symbol-function to extract the functional value of a symbol is considered a functional evaluation.

functional value

n. 1. (of a function name N in an environment E) The value of the binding named N in the function namespace for environment E; that is, the contents of the function cell named N in environment E. 2. (of an fbound symbol S) the contents of the symbol’s function cell; that is, the value of the binding named S in the function namespace of the global environment. (A name that is a macro name in the global environment or is a special operator might or might not be fbound. But if S is such a name and is fbound, the specific nature of its functional value is implementation-dependent; in particular, it might or might not be a function.)

further compilation

n. implementation-dependent compilation beyond minimal compilation. Further compilation is permitted to take place at run time. “Block compilation and generation of machine-specific instructions are examples of further compilation.”

G

general

adj. (of an array) having element type t, and consequently able to have any object as an element.

generalized boolean

n. an object used as a truth value, where the symbol~nil represents false and all other objects represent true. See boolean.

generalized instance

n. (of a class) an object the class of which is either that class itself, or some subclass of that class. (Because of the correspondence between types and classes, the term “generalized instance of X” implies “object of type X” and in cases where X is a class (or class name) the reverse is also true. The former terminology emphasizes the view of X as a class while the latter emphasizes the view of X as a type specifier.)

generalized reference

n. a reference to a location storing an object as if to a variable. (Such a reference can be either to read or write the location.) See Generalized Reference. See also place.

generalized synonym stream

n. (with a synonym stream symbol) 1. (to a stream) a synonym stream to the stream, or a composite stream which has as a target a generalized synonym stream to the stream. 2. (to a symbol) a synonym stream to the symbol, or a composite stream which has as a target a generalized synonym stream to the symbol.

generic function

n. a function whose behavior depends on the classes or identities of the arguments supplied to it and whose parts include, among other things, a set of methods, a lambda list, and a method combination type.

generic function lambda list

n. A lambda list that is used to describe data flow into a generic function. See Generic Function Lambda Lists.

gensym

n. Trad. an uninterned symbol. See the function gensym.

global declaration

n. a form that makes certain kinds of information about code globally available; that is, a proclaim form or a declaim form.

global environment

n. that part of an environment that contains bindings with indefinite scope and indefinite extent.

global variable

n. a dynamic variable or a constant variable.

glyph

n. a visual representation. “Graphic characters have associated glyphs.”

go

v. to transfer control to a go point. See the special operator go.

go point

one of possibly several exit points that are established by tagbody (or other abstractions, such as prog, which are built from tagbody).

go tag

n. the symbol or integer that, within the lexical scope of a tagbody form, names an exit point established by that tagbody form.

graphic

adj. (of a character) being a “printing” or “displayable” character that has a standard visual representation as a single glyph, such as A or * or =. Space is defined to be graphic. Of the standard characters, all but newline are graphic. See non-graphic.

H

handle

v. (of a condition being signaled) to perform a non-local transfer of control, terminating the ongoing signaling of the condition.

handler

n.

a condition handler.

hash table

n. an object of type hash-table, which provides a mapping from keys to values.

home package

n. (of a symbol) the package, if any, which is contents of the package cell of the symbol, and which dictates how the Lisp printer prints the symbol when it is not accessible in the current package. (Symbols which have nil in their package cell are said to have no home package, and also to be apparently uninterned.)

I

I/O customization variable

n. one of the stream variables in Figure 26–2, or some other (implementation-defined) stream variable that is defined by the implementation to be an I/O customization variable. 

  *debug-io*        *error-io*         query-io*       
  *standard-input*  *standard-output*  *trace-output*  

  Figure 26–2: Standardized I/O Customization Variables
identical

adj. the same under eq.

identifier

n. 1. a symbol used to identify or to distinguish names. 2. a string used the same way.

immutable

adj. not subject to change, either because no operator is provided which is capable of effecting such change or because some constraint exists which prohibits the use of an operator that might otherwise be capable of effecting such a change. Except as explicitly indicated otherwise, implementations are not required to detect attempts to modify immutable objects or cells; the consequences of attempting to make such modification are undefined. “Numbers are immutable.”

implementation

n. a system, mechanism, or body of code that implements the semantics of Common Lisp.

implementation limit

n. a restriction imposed by an implementation.

implementation-defined

adj. implementation-dependent, but required by this specification to be defined by each conforming implementation and to be documented by the corresponding implementor.

implementation-dependent

adj. describing a behavior or aspect of Common Lisp which has been deliberately left unspecified, that might be defined in some conforming implementations but not in others, and whose details may differ between implementations. A conforming implementation is encouraged (but not required) to document its treatment of each item in this specification which is marked implementation-dependent, although in some cases such documentation might simply identify the item as “undefined.”

implementation-independent

adj. used to identify or emphasize a behavior or aspect of Common Lisp which does not vary between conforming implementations.

implicit block

n. a block introduced by a macro form rather than by an explicit block form.

implicit compilation

n. compilation performed during evaluation.

implicit progn

n. an ordered set of adjacent forms appearing in another form, and defined by their context in that form to be executed as if within a progn.

implicit tagbody

n. an ordered set of adjacent forms and/or tags appearing in another form, and defined by their context in that form to be executed as if within a tagbody.

import

v.t. (a symbol into a package) to make the symbol be present in the package.

improper list

n. a list which is not a proper list: a circular list or a dotted list.

inaccessible

adj. not accessible.

indefinite extent

n. an extent whose duration is unlimited. “Most Common Lisp objects have indefinite extent.”

indefinite scope

n. scope that is unlimited.

indicator

n. a property indicator.

indirect instance

n. (of a class C_1) an object of class C_2, where C_2 is a subclass of C_1. “An integer is an indirect instance of the class number.”

inherit

v.t. 1. to receive or acquire a quality, trait, or characteristic; to gain access to a feature defined elsewhere. 2. (a class) to acquire the structure and behavior defined by a superclass. 3. (a package) to make symbols exported by another package accessible by using use-package.

initial pprint dispatch table

n. the value of *print-pprint-dispatch* at the time the Lisp image is started.

initial readtable

n. the value of *readtable* at the time the Lisp image is started.

initialization argument list

n. a property list of initialization argument names and values used in the protocol for initializing and reinitializing instances of classes. See Object Creation and Initialization.

initialization form

n. a form used to supply the initial value for a slot or variable. “The initialization form for a slot in a defclass form is introduced by the keyword :initform.”

input

adj. (of a stream) supporting input operations (i.e., being a “data source”). An input stream might also be an output stream, in which case it is sometimes called a bidirectional stream. See the function input-stream-p.

instance

n. 1. a direct instance. 2. a generalized instance. 3. an indirect instance.

integer

n. an object of type integer, which represents a mathematical integer.

interactive stream

n. a stream on which it makes sense to perform interactive querying. See Interactive Streams.

intern

v.t. 1. (a string in a package) to look up the string in the package, returning either a symbol with that name which was already accessible in the package or a newly created internal symbol of the package with that name. 2. Idiom. generally, to observe a protocol whereby objects which are equivalent or have equivalent names under some predicate defined by the protocol are mapped to a single canonical object.

internal symbol

n. (of a package) a symbol which is accessible in the package, but which is not an external symbol of the package.

internal time

n. time, represented as an integer number of internal time units. Absolute internal time is measured as an offset from an arbitrarily chosen, implementation-dependent base. See Internal Time.

internal time unit

n. a unit of time equal to 1/n of a second, for some implementation-defined integer value of n. See the variable internal-time-units-per-second.

interned

adj. Trad. 1. (of a symbol) accessible_3 in any package. 2. (of a symbol in a specific package) present in that package.

interpreted function

n. a function that is not a compiled function. (It is possible for there to be a conforming implementation which has no interpreted functions, but a conforming program must not assume that all functions are compiled functions.)

interpreted implementation

n. an implementation that uses an execution strategy for interpreted functions that does not involve a one-time semantic analysis pre-pass, and instead uses “lazy” (and sometimes repetitious) semantic analysis of forms as they are encountered during execution.

interval designator

n. (of type T) an ordered pair of objects that describe a subtype of T by delimiting an interval on the real number line. See Interval Designators.

invalid

n., adj. 1. n. a possible constituent trait of a character which if present signifies that the character cannot ever appear in a token except under the control of a single escape character. For details, see Constituent Characters. 2. adj. (of a character) being a character that has syntax type constituent in the current readtable and that has the constituent trait invalid_1. See Figure~2–8.

iteration form

n. a compound form whose operator is named in Figure 26–3, or a compound form that has an implementation-defined operator and that is defined by the implementation to be an iteration form. 

  do              do-external-symbols  dotimes  
  do*             do-symbols           loop     
  do-all-symbols  dolist                        

    Figure 26–3: Standardized Iteration Forms
iteration variable

n. a variable V, the binding for which was created by an explicit use of V in an iteration form.

K

key

n. an object used for selection during retrieval. See association list, property list, and hash table. Also, see Sequence Concepts.

keyword

n. 1. a symbol the home package of which is the KEYWORD package. 2. any symbol, usually but not necessarily in the KEYWORD package, that is used as an identifying marker in keyword-style argument passing. See lambda. 3. Idiom. a lambda list keyword.

keyword parameter

n. A parameter for which a corresponding keyword argument is optional. (There is no such thing as a required keyword argument.) If the argument is not supplied, a default value is used. See also supplied-p parameter.

keyword/value pair

n. two successive elements (a keyword and a value, respectively) of a property list.

L

lambda combination

n. Trad. a lambda form.

lambda expression

n. a list which can be used in place of a function name in certain contexts to denote a function by directly describing its behavior rather than indirectly by referring to the name of an established function; its name derives from the fact that its first element is the symbol lambda. See lambda.

lambda form

n. a form that is a list and that has a first element which is a lambda expression representing a function to be called on arguments which are the result of evaluating subsequent elements of the lambda form.

lambda list

n. a list that specifies a set of parameters (sometimes called lambda variables) and a protocol for receiving values for those parameters; that is, an ordinary lambda list, an extended lambda list, or a modified lambda list.

lambda list keyword

n. a symbol whose name begins with ampersand and that is specially recognized in a lambda list. Note that no standardized lambda list keyword is in the KEYWORD package.

lambda variable

n. a formal parameter, used to emphasize the variable’s relation to the lambda list that established it.

leaf

n. 1. an atom in a tree_1. 2. a terminal node of a tree_2.

leap seconds

n. additional one-second intervals of time that are occasionally inserted into the true calendar by official timekeepers as a correction similar to “leap years.” All Common Lisp time representations ignore leap seconds; every day is assumed to be exactly 86400 seconds long.

left-parenthesis

n. the standard character “(”, that is variously called “left parenthesis” or “open parenthesis” See Figure~2–5.

length

n. (of a sequence) the number of elements in the sequence. (Note that if the sequence is a vector with a fill pointer, its length is the same as the fill pointer even though the total allocated size of the vector might be larger.)

lexical binding

n. a binding in a lexical environment.

lexical closure

n. a function that, when invoked on arguments, executes the body of a lambda expression in the lexical environment that was captured at the time of the creation of the lexical closure, augmented by bindings of the function’s parameters to the corresponding arguments.

lexical environment

n. that part of the environment that contains bindings whose names have lexical scope. A lexical environment contains, among other things: ordinary bindings of variable names to values, lexically established bindings of function names to functions, macros, symbol macros, blocks, tags, and local declarations (see declare).

lexical scope

n. scope that is limited to a spatial or textual region within the establishing form. “The names of parameters to a function normally are lexically scoped.”

lexical variable

n. a variable the binding for which is in the lexical environment.

Lisp image

n. a running instantiation of a Common Lisp implementation. A Lisp image is characterized by a single address space in which any object can directly refer to any another in conformance with this specification, and by a single, common, global environment. (External operating systems sometimes call this a “core image,” “fork,” “incarnation,” “job,” or “process.” Note however, that the issue of a “process” in such an operating system is technically orthogonal to the issue of a Lisp image being defined here. Depending on the operating system, a single “process” might have multiple Lisp images, and multiple “processes” might reside in a single Lisp image. Hence, it is the idea of a fully shared address space for direct reference among all objects which is the defining characteristic. Note, too, that two “processes” which have a communication area that permits the sharing of some but not all objects are considered to be distinct Lisp images.)

Lisp printer

n. Trad. the procedure that prints the character representation of an object onto a stream. (This procedure is implemented by the function write.)

Lisp read-eval-print loop

n. Trad. an endless loop that reads_2 a form, evaluates it, and prints (i.e., writes_2) the results. In many implementations, the default mode of interaction with Common Lisp during program development is through such a loop.

Lisp reader

n. Trad. the procedure that parses character representations of objects from a stream, producing objects. (This procedure is implemented by the function read.)

list

n. 1. a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom. See also proper list, dotted list, or circular list. 2. the type that is the union of null and cons.

list designator

n. a designator for a list of objects; that is, an object that denotes a list and that is one of: a non-nil atom (denoting a singleton list whose element is that non-nil atom) or a proper list (denoting itself).

list structure

n. (of a list) the set of conses that make up the list. Note that while the car_{1b} component of each such cons is part of the list structure, the objects that are elements of the list (i.e., the objects that are the cars_2 of each cons in the list) are not themselves part of its list structure, even if they are conses, except in the (circular_2) case where the list actually contains one of its tails as an element. (The list structure of a list is sometimes redundantly referred to as its “top-level list structure” in order to emphasize that any conses that are elements of the list are not involved.)

literal

adj. (of an object) referenced directly in a program rather than being computed by the program; that is, appearing as data in a quote form, or, if the object is a self-evaluating object, appearing as unquoted data. “In the form (cons "one" '("two")), the expressions "one", ("two"), and "two" are literal objects.”

load

v.t. (a file) to cause the code contained in the file to be executed. See the function load.

load time

n. the duration of time that the loader is loading compiled code.

load time value

n. an object referred to in code by a load-time-value form. The value of such a form is some specific object which can only be computed in the run-time environment. In the case of file compilation, the value is computed once as part of the process of loading the compiled file, and not again. See the special operator load-time-value.

loader

n. a facility that is part of Lisp and that loads a file. See the function load.

local declaration

n. an expression which may appear only in specially designated positions of certain forms, and which provides information about the code contained within the containing form; that is, a declare expression.

local precedence order

n. (of a class) a list consisting of the class followed by its direct superclasses in the order mentioned in the defining form for the class.

local slot

n. (of a class) a slot accessible in only one instance, namely the instance in which the slot is allocated.

logical block

n. a conceptual grouping of related output used by the pretty printer. See the macro pprint-logical-block and Dynamic Control of the Arrangement of Output.

logical host

n. an object of implementation-dependent nature that is used as the representation of a “host” in a logical pathname, and that has an associated set of translation rules for converting logical pathnames belonging to that host into physical pathnames. See Logical Pathnames.

logical host designator

n. a designator for a logical host; that is, an object that denotes a logical host and that is one of: a string (denoting the logical host that it names), or a logical host (denoting itself). (Note that because the representation of a logical host is implementation-dependent, it is possible that an implementation might represent a logical host as the string that names it.)

logical pathname

n. an object of type logical-pathname.

long float

n. an object of type long-float.

loop keyword

n. Trad. a symbol that is a specially recognized part of the syntax of an extended loop form. Such symbols are recognized by their name (using string=), not by their identity; as such, they may be in any package. A loop keyword is not a keyword.

lowercase

adj. (of a character) being among standard characters corresponding to the small letters a through z, or being some other implementation-defined character that is defined by the implementation to be lowercase. See Characters With Case.

M

macro

n. 1. a macro form 2. a macro function. 3. a macro name.

macro character

n. a character which, when encountered by the Lisp reader in its main dispatch loop, introduces a reader macro_1. (Macro characters have nothing to do with macros.)

macro expansion

n. 1. the process of translating a macro form into another form. 2. the form resulting from this process.

macro form

n. a form that stands for another form (e.g., for the purposes of abstraction, information hiding, or syntactic convenience); that is, either a compound form whose first element is a macro name, or a form that is a symbol that names a symbol macro.

macro function

n. a function of two arguments, a form and an environment, that implements macro expansion by producing a form to be evaluated in place of the original argument form.

macro lambda list

n. an extended lambda list used in forms that establish macro definitions, such as defmacro and macrolet. See Macro Lambda Lists.

macro name

n. a name for which macro-function returns true and which when used as the first element of a compound form identifies that form as a macro form.

macroexpand hook

n. the function that is the value of *macroexpand-hook*.

mapping

n. 1. a type of iteration in which a function is successively applied to objects taken from corresponding entries in collections such as sequences or hash tables. 2. Math. a relation between two sets in which each element of the first set (the “domain”) is assigned one element of the second set (the “range”).

metaclass

n. 1. a class whose instances are classes. 2. (of an object) the class of the class of the object.

Metaobject Protocol

n. one of many possible descriptions of how a conforming implementation might implement various aspects of the object system. This description is beyond the scope of this document, and no conforming implementation is required to adhere to it except as noted explicitly in this specification. Nevertheless, its existence helps to establish normative practice, and implementors with no reason to diverge from it are encouraged to consider making their implementation adhere to it where possible. It is described in detail in The Art of the Metaobject Protocol.

method

n. an object that is part of a generic function and which provides information about how that generic function should behave when its arguments are objects of certain classes or with certain identities.

method combination

n. 1. generally, the composition of a set of methods to produce an effective method for a generic function. 2. an object of type method-combination, which represents the details of how the method combination_1 for one or more specific generic functions is to be performed.

method-defining form

n. a form that defines a method for a generic function, whether explicitly or implicitly. See Introduction to Generic Functions.

method-defining operator

n. an operator corresponding to a method-defining form. See Figure~7–1.

minimal compilation

n. actions the compiler must take at compile time. See Compilation Semantics.

modified lambda list

n. a list resembling an ordinary lambda list in form and purpose, but which deviates in syntax or functionality from the definition of an ordinary lambda list. See ordinary lambda list. “deftype uses a modified lambda list.”

most recent

adj. innermost; that is, having been established (and not yet disestablished) more recently than any other of its kind.

multiple escape

n., adj. 1. n. the syntax type of a character that is used in pairs to indicate that the enclosed characters are to be treated as alphabetic_2 characters with their case preserved. For details, see Multiple Escape Characters. 2. adj. (of a character) having the multiple escape syntax type. 3. n. a multiple escape_2 character. (In the standard readtable, vertical-bar is a multiple escape character.)

multiple values

n. 1. more than one value. “The function truncate returns multiple values.” 2. a variable number of values, possibly including zero or one. “The function values returns multiple values.” 3. a fixed number of values other than one. “The macro multiple-value-bind is among the few operators in Common Lisp which can detect and manipulate multiple values.”

N

name

n., v.t. 1. n. an identifier by which an object, a binding, or an exit point is referred to by association using a binding. 2. v.t. to give a name to. 3. n. (of an object having a name component) the object which is that component. “The string which is a symbol’s name is returned by symbol-name.” 4. n. (of a pathname) a. the name component, returned by pathname-name. b. the entire namestring, returned by namestring. 5. n. (of a character) a string that names the character and that has length greater than one. (All non-graphic characters are required to have names unless they have some implementation-defined attribute which is not null. Whether or not other characters have names is implementation-dependent.)

named constant

n. a variable that is defined by Common Lisp, by the implementation, or by user code (see the macro defconstant) to always yield the same value when evaluated. “The value of a named constant may not be changed by assignment or by binding.”

namespace

n. 1. bindings whose denotations are restricted to a particular kind. “The bindings of names to tags is the tag namespace.” 2. any mapping whose domain is a set of names. “A package defines a namespace.”

namestring

n. a string that represents a filename using either the standardized notation for naming logical pathnames described in Syntax of Logical Pathname Namestrings, or some implementation-defined notation for naming a physical pathname.

newline

n. the standard character <Newline>, notated for the Lisp reader as #\Newline.

next method

n. the next method to be invoked with respect to a given method for a particular set of arguments or argument classes. See Applying method combination to the sorted list of applicable methods.

nickname

n. (of a package) one of possibly several names that can be used to refer to the package but that is not the primary name of the package.

nil

n. the object that is at once the symbol named "NIL" in the COMMON-LISP package, the empty list, the boolean (or generalized boolean) representing false, and the name of the empty type.

non-atomic

adj. being other than an atom; i.e., being a cons.

non-constant variable

n. a variable that is not a constant variable.

non-correctable

adj. (of an error) not intentionally correctable. (Because of the dynamic nature of restarts, it is neither possible nor generally useful to completely prohibit an error from being correctable. This term is used in order to express an intent that no special effort should be made by code signaling an error to make that error correctable; however, there is no actual requirement on conforming programs or conforming implementations imposed by this term.)

non-empty

adj. having at least one element.

non-generic function

n. a function that is not a generic function.

non-graphic

adj. (of a character) not graphic. See Graphic Characters.

non-list

n., adj. other than a list; i.e., a non-nil atom.

non-local exit

n. a transfer of control (and sometimes values) to an exit point for reasons other than a normal return. “The operators go, throw, and return-from cause a non-local exit.”

non-nil

n., adj. not nil. Technically, any object which is not nil can be referred to as true, but that would tend to imply a unique view of the object as a generalized boolean. Referring to such an object as non-nil avoids this implication.

non-null lexical environment

n. a lexical environment that has additional information not present in the global environment, such as one or more bindings.

non-simple

adj. not simple.

non-terminating

adj. (of a macro character) being such that it is treated as a constituent character when it appears in the middle of an extended token. See Reader Algorithm.

non-top-level form

n. a form that, by virtue of its position as a subform of another form, is not a top level form. See Processing of Top Level Forms.

normal return

n. the natural transfer of control and values which occurs after the complete execution of a form.

normalized

adj., ANSI, IEEE (of a float) conforming to the description of “normalized” as described by IEEE Standard for Binary Floating-Point Arithmetic. See denormalized.

null

adj., n. 1. adj. a. (of a list) having no elements: empty. See empty list. b. (of a string) having a length of zero. (It is common, both within this document and in observed spoken behavior, to refer to an empty string by an apparent definite reference, as in “the null string” even though no attempt is made to intern_2 null strings. The phrase “a null string” is technically more correct, but is generally considered awkward by most Lisp programmers. As such, the phrase “the null string” should be treated as an indefinite reference in all cases except for anaphoric references.) c. (of an implementation-defined attribute of a character) An object to which the value of that attribute defaults if no specific value was requested. 2. n. an object of type null (the only such object being nil).

null lexical environment

n. the lexical environment which has no bindings.

number

n. an object of type number.

numeric

adj. (of a character) being one of the standard characters 0 through 9, or being some other graphic character defined by the implementation to be numeric.

O

object

n. 1. any Lisp datum. “The function cons creates an object which refers to two other objects.” 2. (immediately following the name of a type) an object which is of that type, used to emphasize that the object is not just a name for an object of that type but really an element of the type in cases where objects of that type (such as function or class) are commonly referred to by name. “The function symbol-function takes a function name and returns a function object.”

object-traversing

adj. operating in succession on components of an object. “The operators mapcar, maphash, with-package-iterator and count perform object-traversing operations.”

open

adj., v.t. (a file) 1. v.t. to create and return a stream to the file. 2. adj. (of a stream) having been opened_1, but not yet closed.

operator

n. 1. a function, macro, or special operator. 2. a symbol that names such a function, macro, or special operator. 3. (in a function special form) the cadr of the function special form, which might be either an operator_2 or a lambda expression. 4. (of a compound form) the car of the compound form, which might be either an operator_2 or a lambda expression, and which is never (setf symbol).

optimize quality

n. one of several aspects of a program that might be optimizable by certain compilers. Since optimizing one such quality might conflict with optimizing another, relative priorities for qualities can be established in an optimize declaration. The standardized optimize qualities are compilation-speed (speed of the compilation process),

debug (ease of debugging),

safety (run-time error checking), space (both code size and run-time space), and speed (of the object code). Implementations may define additional optimize qualities.

optional parameter

n. A parameter for which a corresponding positional argument is optional. If the argument is not supplied, a default value is used. See also supplied-p parameter.

ordinary function

n. a function that is not a generic function.

ordinary lambda list

n. the kind of lambda list used by lambda. See modified lambda list and extended lambda list. “defun uses an ordinary lambda list.”

otherwise inaccessible part

n. (of an object, O_1) an object, O_2, which would be made inaccessible if O_1 were made inaccessible. (Every object is an otherwise inaccessible part of itself.)

output

adj. (of a stream) supporting output operations (i.e., being a “data sink”). An output stream might also be an input stream, in which case it is sometimes called a bidirectional stream. See the function output-stream-p.

P

package

n. an object of type package.

package cell

n. Trad. (of a symbol) The place in a symbol that holds one of possibly several packages in which the symbol is interned, called the home package, or which holds nil if no such package exists or is known. See the function symbol-package.

package designator

n. a designator for a package; that is, an object that denotes a package and that is one of: a string designator (denoting the package that has the string that it designates as its name or as one of its nicknames), or a package (denoting itself).

package marker

n. a character which is used in the textual notation for a symbol to separate the package name from the symbol name, and which is colon in the standard readtable. See Character Syntax.

package prefix

n. a notation preceding the name of a symbol in text that is processed by the Lisp reader, which uses a package name followed by one or more package markers, and which indicates that the symbol is looked up in the indicated package.

package registry

n. A mapping of names to package objects. It is possible for there to be a package object which is not in this mapping; such a package is called an unregistered package. Operators such as find-package consult this mapping in order to find a package from its name. Operators such as do-all-symbols, find-all-symbols, and list-all-packages operate only on packages that exist in the package registry.

pairwise

adv. (of an adjective on a set) applying individually to all possible pairings of elements of the set. “The types A, B, and C are pairwise disjoint if A and B are disjoint, B and C are disjoint, and A and C are disjoint.”

parallel

adj. Trad. (of binding or assignment) done in the style of psetq, let, or do; that is, first evaluating all of the forms that produce values, and only then assigning or binding the variables (or places). Note that this does not imply traditional computational “parallelism” since the forms that produce values are evaluated sequentially. See sequential.

parameter

n. 1. (of a function) a variable in the definition of a function which takes on the value of a corresponding argument (or of a list of corresponding arguments) to that function when it is called, or which in some cases is given a default value because there is no corresponding argument. 2. (of a format directive) an object received as data flow by a format directive due to a prefix notation within the format string at the format directive’s point of use. See Formatted Output. “In "~3,'0D", the number 3 and the character #\0 are parameters to the ~D format directive.”

parameter specializer

n. 1. (of a method) an expression which constrains the method to be applicable only to argument sequences in which the corresponding argument matches the parameter specializer. 2. a class, or a list (eql object).

parameter specializer name

n. 1. (of a method definition) an expression used in code to name a parameter specializer. See Introduction to Methods. 2. a class,

a symbol naming a class,

or a list (eql form).

pathname

n. an object of type pathname, which is a structured representation of the name of a file. A pathname has six components: a “host,” a “device,” a “directory,” a “name,” a “type,” and a “version.”

pathname designator

n. a designator for a pathname; that is, an object that denotes a pathname and that is one of:

a pathname namestring

(denoting the corresponding pathname),

a stream associated with a file (denoting the pathname used to open the file; this may be, but is not required to be, the actual name of the file), or a pathname (denoting itself). See File Operations on Open and Closed Streams.

physical pathname

n. a pathname that is not a logical pathname.

[Editorial Note by KMP: Still need to reconcile some confusion in the uses of “generalized reference” and “place.” I think one was supposed to refer to the abstract concept, and the other to an object (a form), but the usages have become blurred.]

place

n. 1. a form which is suitable for use as a generalized reference. 2. the conceptual location referred to by such a place_1.

plist

pronounced ’p\=e ,list n. a property list.

portable

adj. (of code) required to produce equivalent results and observable side effects in all conforming implementations.

potential copy

n. (of an object O_1 subject to constriants) an object O_2 that if the specified constraints are satisfied by O_1 without any modification might or might not be identical to O_1, or else that must be a fresh object that resembles a copy of O_1 except that it has been modified as necessary to satisfy the constraints.

potential number

n. A textual notation that might be parsed by the Lisp reader in some conforming implementation as a number but is not required to be parsed as a number. No object is a potential number—either an object is a number or it is not. See Potential Numbers as Tokens.

pprint dispatch table

n. an object that can be the value of *print-pprint-dispatch* and hence can control how objects are printed when *print-pretty* is true. See Pretty Print Dispatch Tables.

predicate

n. a function that returns a generalized boolean as its first value.

present

n. 1. (of a feature in a Lisp image) a state of being that is in effect if and only if the symbol naming the feature is an element of the features list. 2. (of a symbol in a package) being accessible in that package directly, rather than being inherited from another package.

pretty print

v.t. (an object) to invoke the pretty printer on the object.

pretty printer

n. the procedure that prints the character representation of an object onto a stream when the value of *print-pretty* is true, and that uses layout techniques (e.g., indentation) that tend to highlight the structure of the object in a way that makes it easier for human readers to parse visually. See the variable *print-pprint-dispatch* and The Lisp Pretty Printer.

pretty printing stream

n. a stream that does pretty printing. Such streams are created by the function pprint-logical-block as a link between the output stream and the logical block.

primary method

n. a member of one of two sets of methods (the set of auxiliary methods is the other) that form an exhaustive partition of the set of methods on the method’s generic function. How these sets are determined is dependent on the method combination type; see Introduction to Methods.

primary value

n. (of values resulting from the evaluation of a form) the first value, if any, or else nil if there are no values. “The primary value returned by truncate is an integer quotient, truncated toward zero.”

principal

adj. (of a value returned by a Common Lisp function that implements a mathematically irrational or transcendental function defined in the complex domain) of possibly many (sometimes an infinite number of) correct values for the mathematical function, being the particular value which the corresponding Common Lisp function has been defined to return.

print name

n. Trad. (usually of a symbol) a name_3.

printer control variable

n. a variable whose specific purpose is to control some action of the Lisp printer; that is, one of the variables in Figure~22–1, or else some implementation-defined variable which is defined by the implementation to be a printer control variable.

printer escaping

n. The combined state of the printer control variables *print-escape* and *print-readably*. If the value of either *print-readably* or *print-escape* is true, then printer escaping is “enabled”; otherwise (if the values of both *print-readably* and *print-escape* are false), then printer escaping is “disabled”.

printing

adj. (of a character) being a graphic character other than space.

process

v.t. (a form by the compiler) to perform minimal compilation, determining the time of evaluation for a form, and possibly evaluating that form (if required).

processor

n., ANSI an implementation.

proclaim

v.t. (a proclamation) to establish that proclamation.

proclamation

n. a global declaration.

prog tag

n. Trad. a go tag.

program

n. Trad. Common Lisp code.

programmer

n. an active entity, typically a human, that writes a program, and that might or might not also be a user of the program.

programmer code

n. code that is supplied by the programmer; that is, code that is not system code.

proper list

n. A list terminated by the empty list. (The empty list is a proper list.) See improper list.

proper name

n. (of a class) a symbol that names the class whose name is that symbol. See the functions class-name and find-class.

proper sequence

n. a sequence which is not an improper list; that is, a vector or a proper list.

proper subtype

n. (of a type) a subtype of the type which is not the same type as the type (i.e., its elements are a “proper subset” of the type).

property

n. (of a property list) 1. a conceptual pairing of a property indicator and its associated property value on a property list. 2. a property value.

property indicator

n. (of a property list) the name part of a property, used as a key when looking up a property value on a property list.

property list

n.

1. a list containing an even number of elements that are alternating names (sometimes called indicators or keys) and values (sometimes called properties). When there is more than one name and value pair with the identical name in a property list, the first such pair determines the property.

2. (of a symbol) the component of the symbol containing a property list.

property value

n. (of a property indicator on a property list) the object associated with the property indicator on the property list.

purports to conform

v. makes a good-faith claim of conformance. This term expresses intention to conform, regardless of whether the goal of that intention is realized in practice. For example, language implementations have been known to have bugs, and while an implementation of this specification with bugs might not be a conforming implementation, it can still purport to conform. This is an important distinction in certain specific cases; e.g., see the variable *features*.

Q

qualified method

n. a method that has one or more qualifiers.

qualifier

n. (of a method for a generic function) one of possibly several objects used to annotate the method in a way that identifies its role in the method combination. The method combination type determines how many qualifiers are permitted for each method, which qualifiers are permitted, and the semantics of those qualifiers.

query I/O

n. the bidirectional stream that is the value of the variable *query-io*.

quoted object

n. an object which is the second element of a quote form.

R

radix

n. an integer between 2 and 36, inclusive, which can be used to designate a base with respect to which certain kinds of numeric input or output are performed. (There are n valid digit characters for any given radix n, and those digits are the first n digits in the sequence 0, 1, ..., 9, A, B, ..., Z, which have the weights 0, 1, ..., 9, 10, 11, ..., 35, respectively. Case is not significant in parsing numbers of radix greater than 10, so “9b8a” and “9B8A” denote the same radix 16 number.)

random state

n. an object of type random-state.

rank

n. a non-negative integer indicating the number of dimensions of an array.

ratio

n. an object of type ratio.

ratio marker

n. a character which is used in the textual notation for a ratio to separate the numerator from the denominator, and which is slash in the standard readtable. See Character Syntax.

rational

n. an object of type rational.

read

v.t.

1. (a binding or slot or component) to obtain the value of the binding or slot.

2. (an object from a stream) to parse an object from its representation on the stream.

readably

adv. (of a manner of printing an object O_1) in such a way as to permit the Lisp Reader to later parse the printed output into an object O_2 that is similar to O_1.

reader

n. 1. a function that reads_1 a variable or slot. 2. the Lisp reader.

reader macro

n. 1. a textual notation introduced by dispatch on one or two characters that defines special-purpose syntax for use by the Lisp reader, and that is implemented by a reader macro function. See Reader Algorithm. 2. the character or characters that introduce a reader macro_1; that is, a macro character or the conceptual pairing of a dispatching macro character and the character that follows it. (A reader macro is not a kind of macro.)

reader macro function

n. a function designator that denotes a function that implements a reader macro_2. See the functions set-macro-character and set-dispatch-macro-character.

readtable

n. an object of type readtable.

readtable case

n. an attribute of a readtable whose value is a case sensitivity mode, and that selects the manner in which characters in a symbol’s name are to be treated by the Lisp reader and the Lisp printer. See Effect of Readtable Case on the Lisp Reader and Effect of Readtable Case on the Lisp Printer.

readtable designator

n. a designator for a readtable; that is, an object that denotes a readtable and that is one of: nil (denoting the standard readtable), or a readtable (denoting itself).

recognizable subtype

n. (of a type) a subtype of the type which can be reliably detected to be such by the implementation. See the function subtypep.

reference

n., v.t. 1. n. an act or occurrence of referring to an object, a binding, an exit point, a tag, or an environment. 2. v.t. to refer to an object, a binding, an exit point, a tag, or an environment, usually by name.

registered package

n. a package object that is installed in the package registry. (Every registered package has a name that is a string, as well as zero or more string nicknames. All packages that are initially specified by Common Lisp or created by make-package or defpackage are registered packages. Registered packages can be turned into unregistered packages by delete-package.)

relative

adj. 1. (of a time) representing an offset from an absolute time in the units appropriate to that time. For example, a relative internal time is the difference between two absolute internal times, and is measured in internal time units. 2. (of a pathname) representing a position in a directory hierarchy by motion from a position other than the root, which might therefore vary. “The notation #P"../foo.text" denotes a relative pathname if the host file system is Unix.” See absolute.

repertoire

n., ISO a subtype of character. See Character Repertoires.

report

n. (of a condition) to call the function print-object on the condition in an environment where the value of *print-escape* is false.

report message

n. the text that is output by a condition reporter.

required parameter

n. A parameter for which a corresponding positional argument must be supplied when calling the function.

rest list

n. (of a function having a rest parameter) The list to which the rest parameter is bound on some particular call to the function.

rest parameter

n. A parameter which was introduced by &rest.

restart

n. an object of type restart.

restart designator

n. a designator for a restart; that is, an object that denotes a restart and that is one of: a non-nil symbol (denoting the most recently established active restart whose name is that symbol), or a restart (denoting itself).

restart function

n. a function that invokes a restart, as if by invoke-restart. The primary purpose of a restart function is to provide an alternate interface. By convention, a restart function usually has the same name as the restart which it invokes. Figure 26–4 shows a list of the standardized restart functions. 

  abort     muffle-warning  use-value  
  continue  store-value                

  Figure 26–4: Standardized Restart Functions
return

v.t. (of values) 1. (from a block) to transfer control and values from the block; that is, to cause the block to yield the values immediately without doing any further evaluation of the forms in its body. 2. (from a form) to yield the values.

return value

n. Trad. a value_1

right-parenthesis

n. the standard character “)”, that is variously called “right parenthesis” or “close parenthesis” See Figure~2–5.

run time

n. 1. load time 2. execution time

run-time compiler

n. refers to the compile function or to implicit compilation, for which the compilation and run-time environments are maintained in the same Lisp image.

run-time definition

n. a definition in the run-time environment.

run-time environment

n. the environment in which a program is executed.

S

safe

adj. 1. (of code) processed in a lexical environment where the the highest safety level (3) was in effect. See optimize. 2. (of a call) a safe call.

safe call

n. a call in which the call, the function being called, and the point of functional evaluation are all safe_1 code. For more detailed information, see Safe and Unsafe Calls.

same

adj. 1. (of objects under a specified predicate) indistinguishable by that predicate. “The symbol car, the string "car", and the string "CAR" are the same under string-equal”. 2. (of objects if no predicate is implied by context) indistinguishable by eql. Note that eq might be capable of distinguishing some numbers and characters which eql cannot distinguish, but the nature of such, if any, is implementation-dependent. Since eq is used only rarely in this specification, eql is the default predicate when none is mentioned explicitly. “The conses returned by two successive calls to cons are never the same.” 3. (of types) having the same set of elements; that is, each type is a subtype of the others. “The types specified by (integer 0 1), (unsigned-byte 1), and bit are the same.”

satisfy the test

v. (of an object being considered by a sequence function) 1. (for a one argument test) to be in a state such that the function which is the predicate argument to the sequence function returns true when given a single argument that is the result of calling the sequence function’s key argument on the object being considered. See Satisfying a One-Argument Test. 2. (for a two argument test) to be in a state such that the two-place predicate which is the sequence function’s test argument returns true when given a first argument that is the object being considered, and when given a second argument that is the result of calling the sequence function’s key argument on an element of the sequence function’s sequence argument which is being tested for equality; or to be in a state such that the test-not function returns false given the same arguments. See Satisfying a Two-Argument Test.

scope

n. the structural or textual region of code in which references to an object, a binding, an exit point, a tag, or an environment (usually by name) can occur.

script

n. ISO one of possibly several sets that form an exhaustive partition of the type character. See Character Scripts.

secondary value

n. (of values resulting from the evaluation of a form) the second value, if any, or else nil if there are fewer than two values. “The secondary value returned by truncate is a remainder.”

section

n. a partitioning of output by a conditional newline on a pretty printing stream. See Dynamic Control of the Arrangement of Output.

self-evaluating object

n. an object that is neither a symbol nor a cons. If a self-evaluating object is evaluated, it yields itself as its only value. “Strings are self-evaluating objects.”

semi-standard

adj. (of a language feature) not required to be implemented by any conforming implementation, but nevertheless recommended as the canonical approach in situations where an implementation does plan to support such a feature. The presence of semi-standard aspects in the language is intended to lessen portability problems and reduce the risk of gratuitous divergence among implementations that might stand in the way of future standardization.

semicolon

n. the standard character that is called “semicolon” (;). See Figure~2–5.

sequence

n. 1. an ordered collection of elements 2. a vector or a list.

sequence function

n. one of the functions in Figure~17–1, or an implementation-defined function that operates on one or more sequences. and that is defined by the implementation to be a sequence function.

sequential

adj. Trad. (of binding or assignment) done in the style of setq, let*, or do*; that is, interleaving the evaluation of the forms that produce values with the assignments or bindings of the variables (or places). See parallel.

sequentially

adv. in a sequential way.

serious condition

n. a condition of type serious-condition, which represents a situation that is generally sufficiently severe that entry into the debugger should be expected if the condition is signaled but not handled.

session

n. the conceptual aggregation of events in a Lisp image from the time it is started to the time it is terminated.

set

v.t. Trad. (any variable or a symbol that is the name of a dynamic variable) to assign the variable.

setf expander

n. a function used by setf to compute the setf expansion of a place.

setf expansion

n. a set of five expressions_1 that, taken together, describe how to store into a place and which subforms of the macro call associated with the place are evaluated. See Setf Expansions.

setf function

n. a function whose name is (setf symbol).

setf function name

n. (of a symbol S) the list (setf S).

shadow

v.t. 1. to override the meaning of. “That binding of X shadows an outer one.” 2. to hide the presence of. “That macrolet of F shadows the outer flet of F.” 3. to replace. “That package shadows the symbol cl:car with its own symbol car.”

shadowing symbol

n. (in a package) an element of the package’s shadowing symbols list.

shadowing symbols list

n. (of a package) a list, associated with the package, of symbols that are to be exempted from ‘symbol conflict errors’ detected when packages are used. See the function package-shadowing-symbols.

shared slot

n. (of a class) a slot accessible in more than one instance of a class; specifically, such a slot is accessible in all direct instances of the class and in those indirect instances whose class does not shadow_1 the slot.

sharpsign

n. the standard character that is variously called “number sign,” “sharp,” or “sharp sign” (#). See Figure~2–5.

short float

n. an object of type short-float.

sign

n. one of the standard characters “+” or “-”.

signal

v. to announce, using a standard protocol, that a particular situation, represented by a condition, has been detected. See Condition System Concepts.

signature

n. (of a method) a description of the parameters and parameter specializers for the method which determines the method’s applicability for a given set of required arguments, and which also describes the argument conventions for its other, non-required arguments.

similar

adj. (of two objects) defined to be equivalent under the similarity relationship.

similarity

n. a two-place conceptual equivalence predicate, which is independent of the Lisp image so that two objects in different Lisp images can be understood to be equivalent under this predicate. See Literal Objects in Compiled Files.

simple

adj. 1. (of an array) being of type simple-array. 2. (of a character) having no implementation-defined attributes, or else having implementation-defined attributes each of which has the null value for that attribute.

simple array

n. an array of type simple-array.

simple bit array

n. a bit array that is a simple array; that is, an object of type (simple-array bit).

simple bit vector

n. a bit vector of type simple-bit-vector.

simple condition

n. a condition of type simple-condition.

simple general vector

n. a simple vector.

simple string

n. a string of type simple-string.

simple vector

n. a vector of type simple-vector, sometimes called a “simple general vector.” Not all vectors that are simple are simple vectors—only those that have element type t.

single escape

n., adj. 1. n. the syntax type of a character that indicates that the next character is to be treated as an alphabetic_2 character with its case preserved. For details, see Single Escape Character. 2. adj. (of a character) having the single escape syntax type. 3. n. a single escape_2 character. (In the standard readtable, slash is the only single escape.)

single float

n. an object of type single-float.

single-quote

n. the standard character that is variously called “apostrophe,” “acute accent,” “quote,” or “single quote” ('). See Figure~2–5.

singleton

adj. (of a sequence) having only one element. “(list 'hello) returns a singleton list.”

situation

n. the evaluation of a form in a specific environment.

slash

n. the standard character that is variously called “solidus” or “slash” (/). See Figure~2–5.

slot

n. a component of an object that can store a value.

slot specifier

n. a representation of a slot that includes the name of the slot and zero or more slot options. A slot option pertains only to a single slot.

source code

n. code representing objects suitable for evaluation (e.g., objects created by read, by macro expansion,

or by compiler macro expansion).

source file

n. a file which contains a textual representation of source code, that can be edited, loaded, or compiled.

space

n. the standard character <Space>, notated for the Lisp reader as #\Space.

special form

n. a list, other than a macro form, which is a form with special syntax or special evaluation rules or both, possibly manipulating the evaluation environment or control flow or both. The first element of a special form is a special operator.

special operator

n. one of a fixed set of symbols, enumerated in Figure~3–2, that may appear in the car of a form in order to identify the form as a special form.

special variable

n. Trad. a dynamic variable.

specialize

v.t. (a generic function) to define a method for the generic function, or in other words, to refine the behavior of the generic function by giving it a specific meaning for a particular set of classes or arguments.

specialized

adj. 1. (of a generic function) having methods which specialize the generic function. 2. (of an array) having an actual array element type that is a proper subtype of the type t; see Array Elements. “(make-array 5 :element-type 'bit) makes an array of length five that is specialized for bits.”

specialized lambda list

n. an extended lambda list used in forms that establish method definitions, such as defmethod. See Specialized Lambda Lists.

spreadable argument list designator

n. a designator for a list of objects; that is, an object that denotes a list and that is a non-null list L1 of length n, whose last element is a list L2 of length m (denoting a list L3 of length m+n-1 whose elements are L1_i for i < n-1 followed by L2_j for j < m). “The list (1 2 (3 4 5)) is a spreadable argument list designator for the list (1 2 3 4 5).”

stack allocate

v.t. Trad. to allocate in a non-permanent way, such as on a stack. Stack-allocation is an optimization technique used in some implementations for allocating certain kinds of objects that have dynamic extent. Such objects are allocated on the stack rather than in the heap so that their storage can be freed as part of unwinding the stack rather than taking up space in the heap until the next garbage collection. What types (if any) can have dynamic extent can vary from implementation to implementation. No implementation is ever required to perform stack-allocation.

stack-allocated

adj. Trad. having been stack allocated.

standard character

n. a character of type standard-char, which is one of a fixed set of 96 such characters required to be present in all conforming implementations. See Standard Characters.

standard class

n. a class that is a generalized instance of class standard-class.

standard generic function

a function of type standard-generic-function.

standard input

n. the input stream which is the value of the dynamic variable *standard-input*.

standard method combination

n. the method combination named standard.

standard object

n. an object that is a generalized instance of class standard-object.

standard output

n. the output stream which is the value of the dynamic variable *standard-output*.

standard pprint dispatch table

n. A pprint dispatch table that is different from the initial pprint dispatch table, that implements pretty printing as described in this specification, and that, unlike other pprint dispatch tables, must never be modified by any program. (Although the definite reference “the standard pprint dispatch table” is generally used within this document, it is actually implementation-dependent whether a single object fills the role of the standard pprint dispatch table, or whether there might be multiple such objects, any one of which could be used on any given occasion where “the standard pprint dispatch table” is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.)

standard readtable

n. A readtable that is different from the initial readtable, that implements the expression syntax defined in this specification, and that, unlike other readtables, must never be modified by any program. (Although the definite reference “the standard readtable” is generally used within this document, it is actually implementation-dependent whether a single object fills the role of the standard readtable, or whether there might be multiple such objects, any one of which could be used on any given occasion where “the standard readtable” is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.)

standard syntax

n. the syntax represented by the standard readtable and used as a reference syntax throughout this document. See Character Syntax.

standardized

adj. (of a name, object, or definition) having been defined by Common Lisp. “All standardized variables that are required to hold bidirectional streams have “-io*” in their name.”

startup environment

n. the global environment of the running Lisp image from which the compiler was invoked.

step

v.t., n. 1. v.t. (an iteration variable) to assign the variable a new value at the end of an iteration, in preparation for a new iteration. 2. n. the code that identifies how the next value in an iteration is to be computed. 3. v.t. (code) to specially execute the code, pausing at intervals to allow user confirmation or intervention, usually for debugging.

stream

n. an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation.

stream associated with a file

n. a file stream, or a synonym stream the target of which is a stream associated with a file. Such a stream cannot be created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, or make-string-output-stream.

stream designator

n. a designator for a stream; that is, an object that denotes a stream and that is one of: t (denoting the value of *terminal-io*), nil (denoting the value of *standard-input* for input stream designators or denoting the value of *standard-output* for output stream designators), or a stream (denoting itself).

stream element type

n. (of a stream) the type of data for which the stream is specialized.

stream variable

n. a variable whose value must be a stream.

stream variable designator

n. a designator for a stream variable; that is, a symbol that denotes a stream variable and that is one of: t (denoting *terminal-io*), nil (denoting *standard-input* for input stream variable designators or denoting *standard-output* for output stream variable designators), or some other symbol (denoting itself).

string

n. a specialized vector that is of type string, and whose elements are of type character or a subtype of type character.

string designator

n. a designator for a string; that is, an object that denotes a string and that is one of: a character (denoting a singleton string that has the character as its only element), a symbol (denoting the string that is its name), or a string (denoting itself).

The intent is that this term be consistent with the behavior of string; implementations that extend string must extend the meaning of this term in a compatible way.

string equal

adj. the same under string-equal.

string stream

n. a stream of type string-stream.

structure

n. an object of type structure-object.

structure class

n. a class that is a generalized instance of class structure-class.

structure name

n. a name defined with defstruct. Usually, such a type is also a structure class, but there may be implementation-dependent situations in which this is not so, if the :type option to defstruct is used.

style warning

n. a condition of type style-warning.

subclass

n. a class that inherits from another class, called a superclass. (No class is a subclass of itself.)

subexpression

n. (of an expression) an expression that is contained within the expression. (In fact, the state of being a subexpression is not an attribute of the subexpression, but really an attribute of the containing expression since the same object can at once be a subexpression in one context, and not in another.)

subform

n. (of a form) an expression that is a subexpression of the form, and which by virtue of its position in that form is also a form. “(f x) and x, but not exit, are subforms of (return-from exit (f x)).”

subrepertoire

n. a subset of a repertoire.

subtype

n. a type whose membership is the same as or a proper subset of the membership of another type, called a supertype. (Every type is a subtype of itself.)

superclass

n. a class from which another class (called a subclass) inherits. (No class is a superclass of itself.) See subclass.

supertype

n. a type whose membership is the same as or a proper superset of the membership of another type, called a subtype. (Every type is a supertype of itself.) See subtype.

supplied-p parameter

n. a parameter which recieves its generalized boolean value implicitly due to the presence or absence of an argument corresponding to another parameter (such as an optional parameter or a rest parameter). See Ordinary Lambda Lists.

symbol

n. an object of type symbol.

symbol macro

n. a symbol that stands for another form. See the macro symbol-macrolet.

synonym stream

n. 1. a stream of type synonym-stream, which is consequently a stream that is an alias for another stream, which is the value of a dynamic variable whose name is the synonym stream symbol of the synonym stream. See the function make-synonym-stream. 2. (to a stream) a synonym stream which has the stream as the value of its synonym stream symbol. 3. (to a symbol) a synonym stream which has the symbol as its synonym stream symbol.

synonym stream symbol

n. (of a synonym stream) the symbol which names the dynamic variable which has as its value another stream for which the synonym stream is an alias.

syntax type

n. (of a character) one of several classifications, enumerated in Figure~2–6, that are used for dispatch during parsing by the Lisp reader. See Character Syntax Types.

system class

n. a class that may be of type built-in-class in a conforming implementation and hence cannot be inherited by classes defined by conforming programs.

system code

n. code supplied by the implementation to implement this specification (e.g., the definition of mapcar) or generated automatically in support of this specification (e.g., during method combination); that is, code that is not programmer code.

T

t

n. 1. a. the boolean representing true. b. the canonical generalized boolean representing true. (Although any object other than nil is considered true as a generalized boolean, t is generally used when there is no special reason to prefer one such object over another.) 2. the name of the type to which all objects belong—the supertype of all types (including itself). 3. the name of the superclass of all classes except itself.

tag

n. 1. a catch tag. 2. a go tag.

tail

n. (of a list) an object that is the same as either some cons which makes up that list or the atom (if any) which terminates the list. “The empty list is a tail of every proper list.”

target

n. 1. (of a constructed stream) a constituent of the constructed stream. “The target of a synonym stream is the value of its synonym stream symbol.” 2. (of a displaced array) the array to which the displaced array is displaced. (In the case of a chain of constructed streams or displaced arrays, the unqualified term “target” always refers to the immediate target of the first item in the chain, not the immediate target of the last item.)

terminal I/O

n. the bidirectional stream that is the value of the variable *terminal-io*.

terminating

n. (of a macro character) being such that, if it appears while parsing a token, it terminates that token. See Reader Algorithm.

tertiary value

n. (of values resulting from the evaluation of a form) the third value, if any, or else nil if there are fewer than three values.

throw

v. to transfer control and values to a catch. See the special operator throw.

tilde

n. the standard character that is called “tilde” (~). See Figure~2–5.

time

a representation of a point (absolute time) or an interval (relative time) on a time line. See decoded time, internal time, and universal time.

time zone

n. a rational multiple of 1/3600 between -24 (inclusive) and 24 (inclusive) that represents a time zone as a number of hours offset from Greenwich Mean Time. Time zone values increase with motion to the west, so Massachusetts, U.S.A. is in time zone 5, California, U.S.A. is time zone 8, and Moscow, Russia is time zone -3. (When “daylight savings time” is separately represented as an argument or return value, the time zone that accompanies it does not depend on whether daylight savings time is in effect.)

token

n. a textual representation for a number or a symbol. See Interpretation of Tokens.

top level form

n. a form which is processed specially by compile-file for the purposes of enabling compile time evaluation of that form. Top level forms include those forms which are not subforms of any other form, and certain other cases. See Processing of Top Level Forms.

trace output

n. the output stream which is the value of the dynamic variable *trace-output*.

tree

n. 1. a binary recursive data structure made up of conses and atoms: the conses are themselves also trees (sometimes called “subtrees” or “branches”), and the atoms are terminal nodes (sometimes called leaves). Typically, the leaves represent data while the branches establish some relationship among that data. 2. in general, any recursive data structure that has some notion of “branches” and leaves.

tree structure

n. (of a tree_1) the set of conses that make up the tree. Note that while the car_{1b} component of each such cons is part of the tree structure, the objects that are the cars_2 of each cons in the tree are not themselves part of its tree structure unless they are also conses.

true

n. any object that is not false and that is used to represent the success of a predicate test. See t_1.

truename

n. 1. the canonical filename of a file in the file system. See Truenames. 2. a pathname representing a truename_1.

two-way stream

n. a stream of type two-way-stream, which is a bidirectional composite stream that receives its input from an associated input stream and sends its output to an associated output stream.

type

n. 1. a set of objects, usually with common structure, behavior, or purpose. (Note that the expression “X is of type S_a” naturally implies that “X is of type S_b” if S_a is a subtype of S_b.) 2. (immediately following the name of a type) a subtype of that type. “The type vector is an array type.”

type declaration

n. a declaration that asserts that every reference to a specified binding within the scope of the declaration results in some object of the specified type.

type equivalent

adj. (of two types X and Y) having the same elements; that is, X is a subtype of Y and Y is a subtype of X.

type expand

n. to fully expand a type specifier, removing any references to derived types. (Common Lisp provides no program interface to cause this to occur, but the semantics of Common Lisp are such that every implementation must be able to do this internally, and some situations involving type specifiers are most easily described in terms of a fully expanded type specifier.)

type specifier

n. an expression that denotes a type. “The symbol random-state, the list (integer 3 5), the list (and list (not null)), and the class named standard-class are type specifiers.”

U

unbound

adj. not having an associated denotation in a binding. See bound.

unbound variable

n. a name that is syntactically plausible as the name of a variable but which is not bound in the variable namespace.

undefined function

n. a name that is syntactically plausible as the name of a function but which is not bound in the function namespace.

unintern

v.t. (a symbol in a package) to make the symbol not be present in that package. (The symbol might continue to be accessible by inheritance.)

uninterned

adj. (of a symbol) not accessible in any package; i.e., not interned_1.

universal time

n. time, represented as a non-negative integer number of seconds. Absolute universal time is measured as an offset from the beginning of the year 1900 (ignoring leap seconds). See Universal Time.

unqualified method

n. a method with no qualifiers.

unregistered package

n. a package object that is not present in the package registry. An unregistered package has no name; i.e., its name is nil. See the function delete-package.

unsafe

adj. (of code) not safe. (Note that, unless explicitly specified otherwise, if a particular kind of error checking is guaranteed only in a safe context, the same checking might or might not occur in that context if it were unsafe; describing a context as unsafe means that certain kinds of error checking are not reliably enabled but does not guarantee that error checking is definitely disabled.)

unsafe call

n. a call that is not a safe call. For more detailed information, see Safe and Unsafe Calls.

upgrade

v.t. (a declared type to an actual type) 1. (when creating an array) to substitute an actual array element type for an expressed array element type when choosing an appropriately specialized array representation. See the function upgraded-array-element-type. 2. (when creating a complex) to substitute an actual complex part type for an expressed complex part type when choosing an appropriately specialized complex representation. See the function upgraded-complex-part-type.

upgraded array element type

n. (of a type) a type that is a supertype of the type and that is used instead of the type whenever the type is used as an array element type for object creation or type discrimination. See Array Upgrading.

upgraded complex part type

n. (of a type) a type that is a supertype of the type and that is used instead of the type whenever the type is used as a complex part type for object creation or type discrimination. See the function upgraded-complex-part-type.

uppercase

adj. (of a character) being among standard characters corresponding to the capital letters A through Z, or being some other implementation-defined character that is defined by the implementation to be uppercase. See Characters With Case.

use

v.t. (a package P_1) to inherit the external symbols of P_1. (If a package P_2 uses P_1, the external symbols of P_1 become internal symbols of P_2 unless they are explicitly exported.) “The package CL-USER uses the package CL.”

use list

n. (of a package) a (possibly empty) list associated with each package which determines what other packages are currently being used by that package.

user

n. an active entity, typically a human, that invokes or interacts with a program at run time, but that is not necessarily a programmer.

V

valid array dimension

n. a fixnum suitable for use as an array dimension. Such a fixnum must be greater than or equal to zero, and less than the value of array-dimension-limit. When multiple array dimensions are to be used together to specify a multi-dimensional array, there is also an implied constraint that the product of all of the dimensions be less than the value of array-total-size-limit.

valid array index

n. (of an array) a fixnum suitable for use as one of possibly several indices needed to name an element of the array according to a multi-dimensional Cartesian coordinate system. Such a fixnum must be greater than or equal to zero, and must be less than the corresponding dimension_1 of the array. (Unless otherwise explicitly specified, the phrase “a list of valid array indices” further implies that the length of the list must be the same as the rank of the array.) “For a 2 by~3 array, valid array indices for the first dimension are 0 and~1, and valid array indices for the second dimension are 0, 1 and~2.”

valid array row-major index

n. (of an array, which might have any number of dimensions_2) a single fixnum suitable for use in naming any element of the array, by viewing the array’s storage as a linear series of elements in row-major order. Such a fixnum must be greater than or equal to zero, and less than the array total size of the array.

valid fill pointer

n. (of an array) a fixnum suitable for use as a fill pointer for the array. Such a fixnum must be greater than or equal to zero, and less than or equal to the array total size of the array.

[Editorial Note by KMP: The “valid pathname xxx” definitions were taken from text found in make-pathname, but look wrong to me. I’ll fix them later.]

valid logical pathname host

n. a string that has been defined as the name of a logical host. See the function load-logical-pathname-translations.

valid pathname device

n. a string, nil, :unspecific, or some other object defined by the implementation to be a valid pathname device.

valid pathname directory

n. a string, a list of strings, nil,

:wild,

:unspecific, or some other object defined by the implementation to be a valid directory component.

valid pathname host

n. a valid physical pathname host or a valid logical pathname host.

valid pathname name

n. a string, nil, :wild, :unspecific, or some other object defined by the implementation to be a valid pathname name.

valid pathname type

n. a string, nil, :wild, :unspecific.

valid pathname version

n. a non-negative integer, or one of :wild, :newest, :unspecific, or nil. The symbols :oldest, :previous, and :installed are semi-standard special version symbols.

valid physical pathname host

n. any of a string, a list of strings, or the symbol :unspecific, that is recognized by the implementation as the name of a host.

valid sequence index

n. (of a sequence) an integer suitable for use to name an element of the sequence. Such an integer must be greater than or equal to zero, and must be less than the length of the sequence.

(If the sequence is an array, the valid sequence index is further constrained to be a fixnum.)

value

n. 1. a. one of possibly several objects that are the result of an evaluation. b. (in a situation where exactly one value is expected from the evaluation of a form) the primary value returned by the form. c. (of forms in an implicit progn) one of possibly several objects that result from the evaluation of the last form, or nil if there are no forms. 2. an object associated with a name in a binding. 3. (of a symbol) the value of the dynamic variable named by that symbol. 4. an object associated with a key in an association list, a property list, or a hash table.

value cell

n. Trad. (of a symbol) The place which holds the value, if any, of the dynamic variable named by that symbol, and which is accessed by symbol-value. See cell.

variable

n. a binding in which a symbol is the name used to refer to an object.

vector

n. a one-dimensional array.

vertical-bar

n. the standard character that is called “vertical bar” (|). See Figure~2–5.

W

whitespace

n. 1. one or more characters that are either the graphic character #\Space or else non-graphic characters such as #\Newline that only move the print position. 2. a. n. the syntax type of a character that is a token separator. For details, see Whitespace Characters. b. adj. (of a character) having the whitespace_{2a} syntax type_2. c. n. a whitespace_{2b} character.

wild

adj. 1. (of a namestring) using an implementation-defined syntax for naming files, which might “match” any of possibly several possible filenames, and which can therefore be used to refer to the aggregate of the files named by those filenames. 2. (of a pathname) a structured representation of a name which might “match” any of possibly several pathnames, and which can therefore be used to refer to the aggregate of the files named by those pathnames. The set of wild pathnames includes, but is not restricted to, pathnames which have a component which is :wild, or which have a directory component which contains :wild or :wild-inferors. See the function wild-pathname-p.

write

v.t.

1. (a binding or slot or component) to change the value of the binding or slot.

2. (an object to a stream) to output a representation of the object to the stream.

writer

n. a function that writes_1 a variable or slot.

Y

yield

v.t. (values) to produce the values as the result of evaluation. “The form (+ 2 3) yields 5.”

Previous: , Up: Glossary (Glossary)  

gcl-2.6.14/info/gcl/Array-Elements.html0000644000175000017500000000742614360276512016222 0ustar cammcamm Array Elements (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Concepts  

15.1.1 Array Elements

An array contains a set of objects called elements that can be referenced individually according to a rectilinear coordinate system.

• Array Indices  
• Array Dimensions  
• Implementation Limits on Individual Array Dimensions  
• Array Rank  
• Vectors  
• Fill Pointers  
• Multidimensional Arrays  
• Storage Layout for Multidimensional Arrays  
• Implementation Limits on Array Rank  
gcl-2.6.14/info/gcl/ldb_002dtest.html0000644000175000017500000000627614360276512015562 0ustar cammcamm ldb-test (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.70 ldb-test [Function]

ldb-test bytespec integer ⇒ generalized-boolean

Arguments and Values::

bytespec—a byte specifier.

integer—an integer.

generalized-boolean—a generalized boolean.

Description::

Returns true if any of the bits of the byte in integer specified by bytespec is non-zero; otherwise returns false.

Examples::

 (ldb-test (byte 4 1) 16) ⇒  true
 (ldb-test (byte 3 1) 16) ⇒  false
 (ldb-test (byte 3 2) 16) ⇒  true

See Also::

byte , ldb , zerop

Notes::

 (ldb-test bytespec n) ≡
 (not (zerop (ldb bytespec n))) ≡
 (logtest (ldb bytespec -1) n)
gcl-2.6.14/info/gcl/shadowing_002dimport.html0000644000175000017500000001113114360276512017321 0ustar cammcamm shadowing-import (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.10 shadowing-import [Function]

shadowing-import symbols &optional package ⇒ t

Arguments and Values::

symbols—a designator for a list of symbols.

package —a package designator.

The default is the current package.

Description::

shadowing-import is like import, but it does not signal an error even if the importation of a symbol would shadow some symbol already accessible in package.

shadowing-import inserts each of symbols into package as an internal symbol, regardless of whether another symbol of the same name is shadowed by this action. If a different symbol of the same name is already present in package, that symbol is first uninterned from package. The new symbol is added to package’s shadowing-symbols list.

shadowing-import does name-conflict checking to the extent that it checks whether a distinct existing symbol with the same name is accessible; if so, it is shadowed by the new symbol, which implies that it must be uninterned if it was present in package.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (setq sym (intern "CONFLICT")) ⇒  CONFLICT
 (intern "CONFLICT" (make-package 'temp)) ⇒  TEMP::CONFLICT, NIL
 (package-shadowing-symbols 'temp) ⇒  NIL
 (shadowing-import sym 'temp) ⇒  T 
 (package-shadowing-symbols 'temp) ⇒  (CONFLICT)

Side Effects::

shadowing-import changes the state of the package system in such a way that the consistency rules do not hold across the change.

package’s shadowing-symbols list is modified.

Affected By::

Current state of the package system.

See Also::

import , unintern , package-shadowing-symbols

gcl-2.6.14/info/gcl/Constructing-Numbers-from-Tokens.html0000644000175000017500000000734514360276512021667 0ustar cammcamm Constructing Numbers from Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpretation of Tokens  

2.3.2 Constructing Numbers from Tokens

A real is constructed directly from a corresponding numeric token; see Figure~2–9.

A complex is notated as a #C (or #c) followed by a list of two reals; see Sharpsign C.

The reader macros #B, #O, #X, and #R may also be useful in controlling the input radix in which rationals are parsed; see Sharpsign B, Sharpsign O, Sharpsign X, and Sharpsign R.

This section summarizes the full syntax for numbers.

• Syntax of a Rational  
• Syntax of an Integer  
• Syntax of a Ratio  
• Syntax of a Float  
• Syntax of a Complex  
gcl-2.6.14/info/gcl/lisp_002dimplementation_002dtype.html0000644000175000017500000000717414360276512021463 0ustar cammcamm lisp-implementation-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.24 lisp-implementation-type,

lisp-implementation-version

[Function]

lisp-implementation-type <no arguments> ⇒ description

lisp-implementation-version <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

lisp-implementation-type and lisp-implementation-version identify the current implementation of Common Lisp.

lisp-implementation-type returns a string that identifies the generic name of the particular Common Lisp implementation.

lisp-implementation-version returns a string that identifies the version of the particular Common Lisp implementation.

If no appropriate and relevant result can be produced, nil is returned instead of a string.

Examples::

 (lisp-implementation-type)
⇒  "ACME Lisp"
OR⇒ "Joe's Common Lisp"
 (lisp-implementation-version)
⇒  "1.3a"
⇒  "V2"
OR⇒ "Release 17.3, ECO #6"
gcl-2.6.14/info/gcl/function-_0028System-Class_0029.html0000644000175000017500000002204014360276512020654 0ustar cammcamm function (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.3 function [System Class]

Class Precedence List::

function, t

Description::

A function is an object that represents code to be executed when an appropriate number of arguments is supplied. A function is produced by the function special form, the function coerce,

or the function compile. A function can be directly invoked by using it as the first argument to funcall, apply, or multiple-value-call.

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(function{[arg-typespec [value-typespec]]})

arg-typespec ::=({typespec}*                    [&optional {typespec}*]                    [&rest typespec]                    [&key {(keyword typespec )}*])

Compound Type Specifier Arguments::

typespec—a type specifier.

value-typespec—a type specifier.

Compound Type Specifier Description::

[Editorial Note by KMP: Isn’t there some context info about ftype declarations to be merged here?]

[Editorial Note by KMP: This could still use some cleaning up.]

[Editorial Note by Sandra: Still need clarification about what happens if the number of arguments doesn’t match the FUNCTION type declaration.]

The list form of the function type-specifier can be used only for declaration and not for discrimination. Every element of this type is a function that accepts arguments of the types specified by the argj-types and returns values that are members of the types specified by value-type. The &optional, &rest, &key,

and &allow-other-keys

markers can appear in the list of argument types.

The type specifier provided with &rest is the type of each actual argument, not the type of the corresponding variable.

The &key parameters should be supplied as lists of the form (keyword type). The keyword must be a valid keyword-name symbol as must be supplied in the actual arguments of a call.

This is usually a symbol in the KEYWORD package but can be any symbol.

When &key is given in a function type specifier lambda list, the keyword parameters given are exhaustive unless &allow-other-keys is also present. &allow-other-keys is an indication that other keyword arguments might actually be supplied and, if supplied, can be used. For example, the type of the function make-list could be declared as follows: 

 (function ((integer 0) &key (:initial-element t)) list)

The value-type can be a values type specifier in order to indicate the types of multiple values.

Consider a declaration of the following form: 

 (ftype (function (arg0-type arg1-type ...) val-type) f))

Any form (f arg0 arg1 ...) within the scope of that declaration is equivalent to the following: 

 (the val-type (f (the arg0-type arg0) (the arg1-type arg1) ...))

That is, the consequences are undefined if any of the arguments are not of the specified types or the result is not of the specified type. In particular, if any argument is not of the correct type, the result is not guaranteed to be of the specified type.

Thus, an ftype declaration for a function describes calls to the function, not the actual definition of the function.

Consider a declaration of the following form: 

 (type (function (arg0-type arg1-type ...) val-type) fn-valued-variable)

This declaration has the interpretation that, within the scope of the declaration, the consequences are unspecified if the value of fn-valued-variable is called with arguments not of the specified types; the value resulting from a valid call will be of type val-type.

As with variable type declarations, nested declarations imply intersections of types, as follows:

*

Consider the following two declarations of ftype: 

 (ftype (function (arg0-type1 arg1-type1 ...) val-type1) f))

and 

 (ftype (function (arg0-type2 arg1-type2 ...) val-type2) f))

If both these declarations are in effect, then within the shared scope of the declarations, calls to f can be treated as if f were declared as follows: 

 (ftype (function ((and arg0-type1 arg0-type2) (and arg1-type1 arg1-type2 ...) ...)
                  (and val-type1 val-type2)) 
        f))

It is permitted to ignore one or all of the ftype declarations in force.

*

If two (or more) type declarations are in effect for a variable, and they are both function declarations, the declarations combine similarly.

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/Principal-Values-and-Branch-Cuts.html0000644000175000017500000001022614360276512021407 0ustar cammcamm Principal Values and Branch Cuts (ANSI and GNU Common Lisp Document)

Previous: , Up: Complex Computations  

12.1.5.5 Principal Values and Branch Cuts

Many of the irrational and transcendental functions are multiply defined in the complex domain; for example, there are in general an infinite number of complex values for the logarithm function. In each such case, a principal value must be chosen for the function to return. In general, such values cannot be chosen so as to make the range continuous; lines in the domain called branch cuts must be defined, which in turn define the discontinuities in the range. Common Lisp defines the branch cuts, principal values, and boundary conditions for the complex functions following “Principal Values and Branch Cuts in Complex APL.” The branch cut rules that apply to each function are located with the description of that function.

Figure 12–9 lists the identities that are obeyed throughout the applicable portion of the complex domain, even on the branch cuts: 

  sin i z = i sinh z  sinh i z = i sin z        arctan i z = i arctanh z  
  cos i z = cosh z    cosh i z = cos z          arcsinh i z = i arcsin z  
  tan i z = i tanh z  arcsin i z = i arcsinh z  arctanh i z = i arctan z  

         Figure 12–9: Trigonometric Identities for Complex Domain

The quadrant numbers referred to in the discussions of branch cuts are as illustrated in Figure 12–10. 

                           Imaginary Axis
	                         |
	        		 |
	        	II       |        I
	        	         |
	        	         |
	        	         |
	       ______________________________________ Real Axis
	        	         |
	        	         |
	        	         |
	               III       |     	   IV
	        		 |
	        		 |
	        		 |
	        		 |

  Figure 12–9: Quadrant Numbering for Branch Cuts

gcl-2.6.14/info/gcl/nth_002dvalue.html0000644000175000017500000000744214360276512015743 0ustar cammcamm nth-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.56 nth-value [Macro]

nth-value n form ⇒ object

Arguments and Values::

n—a non-negative integer; evaluated.

form—a form; evaluated as described below.

object—an object.

Description::

Evaluates n and then form, returning as its only value the nth value yielded by form, or nil if n is greater than or equal to the number of values returned by form. (The first returned value is numbered 0.)

Examples::

 (nth-value 0 (values 'a 'b)) ⇒  A
 (nth-value 1 (values 'a 'b)) ⇒  B
 (nth-value 2 (values 'a 'b)) ⇒  NIL
 (let* ((x 83927472397238947423879243432432432)
        (y 32423489732)
        (a (nth-value 1 (floor x y)))
        (b (mod x y)))
   (values a b (= a b)))
⇒  3332987528, 3332987528, true

See Also::

multiple-value-list , nth

Notes::

Operationally, the following relationship is true, although nth-value might be more efficient in some implementations because, for example, some consing might be avoided. 

 (nth-value n form) ≡ (nth n (multiple-value-list form))
gcl-2.6.14/info/gcl/class.html0000644000175000017500000000516514360276512014475 0ustar cammcamm class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.7 class [System Class]

Class Precedence List::

class,

standard-object,

t

Description::

The type class represents objects that determine the structure and behavior of their instances. Associated with an object of type class is information describing its place in the directed acyclic graph of classes, its slots, and its options.

gcl-2.6.14/info/gcl/Macro-Forms-as-Places.html0000644000175000017500000000471514360276512017323 0ustar cammcamm Macro Forms as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.7 Macro Forms as Places

A macro form can be used as a place, in which case Common Lisp expands the macro form

as if by macroexpand-1

and then uses the macro expansion in place of the original place.

Such macro expansion is attempted only after exhausting all other possibilities other than expanding into a call to a function named (setf reader).

gcl-2.6.14/info/gcl/Multiple-Possible-Textual-Representations.html0000644000175000017500000001165114360276512023545 0ustar cammcamm Multiple Possible Textual Representations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of The Lisp Printer  

22.1.1.1 Multiple Possible Textual Representations

Most objects have more than one possible textual representation. For example, the positive integer with a magnitude of twenty-seven can be textually expressed in any of these ways: 

 27    27.    #o33    #x1B    #b11011    #.(* 3 3 3)    81/3

A list containing the two symbols A and B can also be textually expressed in a variety of ways: 

 (A B)    (a b)    (  a  b )    (\A |B|) 
(|\A|
  B
)

In general,

from the point of view of the Lisp reader,

wherever whitespace is permissible in a textual representation, any number of spaces and newlines can appear in standard syntax.

When a function such as print produces a printed representation, it must choose from among many possible textual representations. In most cases, it chooses a program readable representation, but in certain cases it might use a more compact notation that is not program-readable.

A number of option variables, called printer control variables , are provided to permit control of individual aspects of the printed representation of objects. Figure 22–1 shows the standardized printer control variables; there might also be implementation-defined printer control variables. 

  *print-array*   *print-gensym*       *print-pprint-dispatch*  
  *print-base*    *print-length*       *print-pretty*           
  *print-case*    *print-level*        *print-radix*            
  *print-circle*  *print-lines*        *print-readably*         
  *print-escape*  *print-miser-width*  *print-right-margin*     

       Figure 22–1: Standardized Printer Control Variables

In addition to the printer control variables, the following additional defined names relate to or affect the behavior of the Lisp printer: 

  *package*                    *read-eval*  readtable-case  
  *read-default-float-format*  *readtable*                  

   Figure 22–2: Additional Influences on the Lisp printer.

Next: , Previous: , Up: Overview of The Lisp Printer  

gcl-2.6.14/info/gcl/Sharpsign-Vertical_002dBar.html0000644000175000017500000000432714360276512020246 0ustar cammcamm Sharpsign Vertical-Bar (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.20 Sharpsign Vertical-Bar

#|...|# is treated as a comment by the reader. It must be balanced with respect to other occurrences of #| and |#, but otherwise may contain any characters whatsoever.

gcl-2.6.14/info/gcl/gethash.html0000644000175000017500000001217414360276512015011 0ustar cammcamm gethash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.9 gethash [Accessor]

gethash key hash-table &optional default ⇒ value, present-p

(setf ( gethash key hash-table &optional default) new-value)

Arguments and Values::

key—an object.

hash-table—a hash table.

default—an object. The default is nil.

value—an object.

present-p—a generalized boolean.

Description::

Value is the object in hash-table whose key is the same as key under the hash-table’s equivalence test. If there is no such entry, value is the default.

Present-p is true if an entry is found; otherwise, it is false.

setf may be used with gethash to modify the value associated with a given key, or to add a new entry.

When a gethash form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32206334>
 (gethash 1 table) ⇒  NIL, false
 (gethash 1 table 2) ⇒  2, false
 (setf (gethash 1 table) "one") ⇒  "one"
 (setf (gethash 2 table "two") "two") ⇒  "two"
 (gethash 1 table) ⇒  "one", true
 (gethash 2 table) ⇒  "two", true
 (gethash nil table) ⇒  NIL, false
 (setf (gethash nil table) nil) ⇒  NIL 
 (gethash nil table) ⇒  NIL, true
 (defvar *counters* (make-hash-table)) ⇒  *COUNTERS*
 (gethash 'foo *counters*) ⇒  NIL, false
 (gethash 'foo *counters* 0) ⇒  0, false
 (defmacro how-many (obj) `(values (gethash ,obj *counters* 0))) ⇒  HOW-MANY
 (defun count-it (obj) (incf (how-many obj))) ⇒  COUNT-IT
 (dolist (x '(bar foo foo bar bar baz)) (count-it x))
 (how-many 'foo) ⇒  2
 (how-many 'bar) ⇒  3
 (how-many 'quux) ⇒  0

See Also::

remhash

Notes::

The secondary value, present-p, can be used to distinguish the absence of an entry from the presence of an entry that has a value of default.

Next: , Previous: , Up: Hash Tables Dictionary  

gcl-2.6.14/info/gcl/Multidimensional-Arrays.html0000644000175000017500000000405614360276512020142 0ustar cammcamm Multidimensional Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.7 Multidimensional Arrays

gcl-2.6.14/info/gcl/Graphic-Characters.html0000644000175000017500000000613214360276512017015 0ustar cammcamm Graphic Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.1 Graphic Characters

Characters that are classified as graphic , or displayable, are each associated with a glyph, a visual representation of the character.

A graphic character is one that has a standard textual representation as a single glyph, such as A or * or =. Space, which effectively has a blank glyph, is defined to be a graphic.

Of the standard characters, newline is non-graphic and all others are graphic; see Standard Characters.

Characters that are not graphic are called non-graphic .

Non-graphic characters are sometimes informally called “formatting characters” or “control characters.”

#\Backspace, #\Tab, #\Rubout, #\Linefeed, #\Return, and #\Page, if they are supported by the implementation, are non-graphic.

gcl-2.6.14/info/gcl/make_002dinstance.html0000644000175000017500000001060214360276512016547 0ustar cammcamm make-instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.19 make-instance [Standard Generic Function]

Syntax::

make-instance class &rest initargs &key &allow-other-keys ⇒ instance

Method Signatures::

make-instance (class standard-class) &rest initargs

make-instance (class symbol) &rest initargs

Arguments and Values::

class—a class, or a symbol that names a class.

initargs—an initialization argument list.

instance—a fresh instance of class class.

Description::

The generic function make-instance creates and returns a new instance of the given class.

If the second of the above methods is selected, that method invokes make-instance on the arguments (find-class class) and initargs.

The initialization arguments are checked within make-instance.

The generic function make-instance may be used as described in Object Creation and Initialization.

Exceptional Situations::

If any of the initialization arguments has not been declared as valid, an error of type error is signaled.

See Also::

defclass , class-of , allocate-instance , Initialize-Instance , Object Creation and Initialization

gcl-2.6.14/info/gcl/Extended-Loop.html0000644000175000017500000000477514360276512016045 0ustar cammcamm Extended Loop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.3 Extended Loop

An extended loop form is one that has a body containing atomic expressions. When the loop macro processes such a form, it invokes a facility that is commonly called “the Loop Facility.”

The Loop Facility provides standardized access to mechanisms commonly used in iterations through Loop schemas, which are introduced by loop keywords.

The body of an extended loop form is divided into loop clauses, each which is in turn made up of loop keywords and forms.

gcl-2.6.14/info/gcl/complex-_0028System-Class_0029.html0000644000175000017500000001252114360276512020501 0ustar cammcamm complex (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.2 complex [System Class]

Class Precedence List::

complex, number, t

Description::

The type complex includes all mathematical complex numbers other than those included in the type rational. Complexes are expressed in Cartesian form with a real part and an imaginary part, each of which is a real. The real part and imaginary part are either both rational or both of the same float type. The imaginary part can be a float zero, but can never be a rational zero, for such a number is always represented by Common Lisp as a rational rather than a complex.

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(complex{[typespec | *]})

Compound Type Specifier Arguments::

typespec—a type specifier that denotes a subtype of type real.

Compound Type Specifier Description::

[Editorial Note by KMP: If you ask me, this definition is a complete mess. Looking at issue ARRAY-TYPE-ELEMENT-TYPE-SEMANTICS:UNIFY-UPGRADING does not help me figure it out, either. Anyone got any suggestions?]

Every element of this type is a complex whose real part and imaginary part are each of type

(upgraded-complex-part-type typespec).

This type encompasses those complexes that can result by giving numbers of type typespec to complex.

(complex type-specifier) refers to all complexes that can result from giving numbers of type type-specifier to the function complex, plus all other complexes of the same specialized representation.

See Also::

Rule of Canonical Representation for Complex Rationals, Constructing Numbers from Tokens, Printing Complexes

Notes::

The input syntax for a complex with real part r and imaginary part i is #C(r i). For further details, see Standard Macro Characters.

For every float, n, there is a complex which represents the same mathematical number and which can be obtained by (COERCE n 'COMPLEX).

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Tilde-G_002d_003e-General-Floating_002dPoint.html0000644000175000017500000000772014360276512022743 0ustar cammcamm Tilde G-> General Floating-Point (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Floating-Point Printers  

22.3.3.3 Tilde G: General Floating-Point

The next arg is printed as a float in either fixed-format or exponential notation as appropriate.

The full form is ~w,d,e,k,overflowchar,padchar,exponentcharG. The format in which to print arg depends on the magnitude (absolute value) of the arg. Let n be an integer such that 10^n-1 \le |arg| < 10^n. Let ee equal e+2, or 4 if e is omitted. Let ww equal w- ee, or nil if w is omitted. If d is omitted, first let q be the number of digits needed to print arg with no loss of information and without leading or trailing zeros; then let d equal (max q (min n 7)). Let dd equal d- n.

If 0 \le dd \le d, then arg is printed as if by the format directives

~ww,dd,,overflowchar,padcharF~ee@T

Note that the scale factor k is not passed to the ~F directive. For all other values of dd, arg is printed as if by the format directive

~w,d,e,k,overflowchar,padchar,exponentcharE

In either case, an @ modifier is supplied to the ~F or ~E directive if and only if one was supplied to the ~G directive.

~G binds *print-escape* to false

and *print-readably* to false.

gcl-2.6.14/info/gcl/Associativity-and-Commutativity-in-Numeric-Operations.html0000644000175000017500000000643614360276512025766 0ustar cammcamm Associativity and Commutativity in Numeric Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numeric Operations  

12.1.1.1 Associativity and Commutativity in Numeric Operations

For functions that are mathematically associative (and possibly commutative), a conforming implementation may process the arguments in any manner consistent with associative (and possibly commutative) rearrangement. This does not affect the order in which the argument forms are evaluated; for a discussion of evaluation order, see Function Forms. What is unspecified is only the order in which the parameter values are processed. This implies that implementations may differ in which automatic coercions are applied; see Contagion in Numeric Operations.

A conforming program can control the order of processing explicitly by separating the operations into separate (possibly nested) function forms, or by writing explicit calls to functions that perform coercions.

gcl-2.6.14/info/gcl/_002abreak_002don_002dsignals_002a.html0000644000175000017500000001341614360276512021106 0ustar cammcamm *break-on-signals* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.25 *break-on-signals* [Variable]

Value Type::

a type specifier.

Initial Value::

nil.

Description::

When (typep condition *break-on-signals*) returns true, calls to signal, and to other operators such as error that implicitly call signal, enter the debugger prior to signaling the condition.

The continue restart can be used to continue with the normal signaling process when a break occurs process due to *break-on-signals*.

Examples::

 *break-on-signals* ⇒  NIL
 (ignore-errors (error 'simple-error :format-control "Fooey!"))
⇒  NIL, #<SIMPLE-ERROR 32207172>

 (let ((*break-on-signals* 'error))
   (ignore-errors (error 'simple-error :format-control "Fooey!")))
 |>  Break: Fooey!
 |>  BREAK entered because of *BREAK-ON-SIGNALS*.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Continue to signal.
 |>   2: Top level.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Continue to signal.
⇒  NIL, #<SIMPLE-ERROR 32212257>

 (let ((*break-on-signals* 'error))
   (error 'simple-error :format-control "Fooey!"))
 |>  Break: Fooey!
 |>  BREAK entered because of *BREAK-ON-SIGNALS*.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Continue to signal.
 |>   2: Top level.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Continue to signal.
 |>  Error: Fooey!
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Top level.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Top level.

See Also::

break , signal , warn , error , typep , Condition System Concepts

Notes::

*break-on-signals* is intended primarily for use in debugging code that does signaling. When setting *break-on-signals*, the user is encouraged to choose the most restrictive specification that suffices. Setting *break-on-signals* effectively violates the modular handling of condition signaling. In practice, the complete effect of setting *break-on-signals* might be unpredictable in some cases since the user might not be aware of the variety or number of calls to signal that are used in code called only incidentally.

*break-on-signals* enables an early entry to the debugger but such an entry does not preclude an additional entry to the debugger in the case of operations such as error and cerror.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Printer-Dispatching.html0000644000175000017500000000505514360276512017244 0ustar cammcamm Printer Dispatching (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Lisp Printer  

22.1.2 Printer Dispatching

The Lisp printer makes its determination of how to print an object as follows:

If the value of *print-pretty* is true, printing is controlled by the current pprint dispatch table; see Pretty Print Dispatch Tables.

Otherwise (if the value of *print-pretty* is false), the object’s print-object method is used; see Default Print-Object Methods.

gcl-2.6.14/info/gcl/dotimes.html0000644000175000017500000001477414360276512015042 0ustar cammcamm dotimes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Iteration Dictionary  

6.2.2 dotimes [Macro]

dotimes (var count-form [result-form]) {declaration}* {tag | statement}*
⇒ {result}*

Arguments and Values::

var—a symbol.

count-form—a form.

result-form—a form.

declaration—a declare expression; not evaluated.

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

results—if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-form or nil if there is no result-form.

Description::

dotimes iterates over a series of integers.

dotimes evaluates count-form, which should produce an integer. If count-form is zero or negative, the body is not executed. dotimes then executes the body once for each integer from 0 up to but not including the value of count-form, in the order in which the tags and statements occur, with var bound to each integer. Then result-form is evaluated. At the time result-form is processed, var is bound to the number of times the body was executed. Tags label statements.

An implicit block named nil surrounds dotimes. return may be used to terminate the loop immediately without performing any further iterations, returning zero or more values.

The body of the loop is an implicit tagbody; it may contain tags to serve as the targets of go statements. Declarations may appear before the body of the loop.

The scope of the binding of var does not include the count-form, but the result-form is included.

It is implementation-dependent whether dotimes establishes a new binding of var on each iteration or whether it establishes a binding for var once at the beginning and then assigns it on any subsequent iterations.

Examples::

 (dotimes (temp-one 10 temp-one)) ⇒  10
 (setq temp-two 0) ⇒  0
 (dotimes (temp-one 10 t) (incf temp-two)) ⇒  T
 temp-two ⇒  10

Here is an example of the use of dotimes in processing strings: 

;;; True if the specified subsequence of the string is a
;;; palindrome (reads the same forwards and backwards).
 (defun palindromep (string &optional
                           (start 0)
                           (end (length string)))
   (dotimes (k (floor (- end start) 2) t)
    (unless (char-equal (char string (+ start k))
                        (char string (- end k 1)))
      (return nil))))
 (palindromep "Able was I ere I saw Elba") ⇒  T
 (palindromep "A man, a plan, a canal--Panama!") ⇒  NIL
 (remove-if-not #'alpha-char-p          ;Remove punctuation.
               "A man, a plan, a canal--Panama!")
⇒  "AmanaplanacanalPanama"
 (palindromep
  (remove-if-not #'alpha-char-p
                "A man, a plan, a canal--Panama!")) ⇒  T
 (palindromep
  (remove-if-not
   #'alpha-char-p
   "Unremarkable was I ere I saw Elba Kramer, nu?")) ⇒  T
 (palindromep
  (remove-if-not
   #'alpha-char-p
   "A man, a plan, a cat, a ham, a yak,
                  a yam, a hat, a canal--Panama!")) ⇒  T

See Also::

do , dolist , tagbody

Notes::

go may be used within the body of dotimes to transfer control to a statement labeled by a tag.

Next: , Previous: , Up: Iteration Dictionary  

gcl-2.6.14/info/gcl/Sharpsign-R.html0000644000175000017500000000721014360276512015516 0ustar cammcamm Sharpsign R (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.11 Sharpsign R

#nR

#radixRrational reads rational in radix radix. radix must consist of only digits that are interpreted as an integer in decimal radix; its value must be between 2 and 36 (inclusive). Only valid digits for the specified radix may be used.

For example, #3r102 is another way of writing 11 (decimal), and #11R32 is another way of writing 35 (decimal). For radices larger than 10, letters of the alphabet are used in order for the digits after 9. No alternate # notation exists for the decimal radix since a decimal point suffices.

Figure 2–20 contains examples of the use of #B, #O, #X, and #R. 

  #2r11010101  ;Another way of writing 213 decimal  
  #b11010101   ;Ditto                               
  #b+11010101  ;Ditto                               
  #o325        ;Ditto, in octal radix               
  #xD5         ;Ditto, in hexadecimal radix         
  #16r+D5      ;Ditto                               
  #o-300       ;Decimal -192, written in base 8     
  #3r-21010    ;Same thing in base 3                
  #25R-7H      ;Same thing in base 25               
  #xACCEDED    ;181202413, in hexadecimal radix     

        Figure 2–20: Radix Indicator Example

The consequences are undefined if the token immediately following the #nR does not have the syntax of a rational in radix n.

gcl-2.6.14/info/gcl/The-External-Environment.html0000644000175000017500000000523514360276512020170 0ustar cammcamm The External Environment (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment  

25.1 The External Environment

• Top level loop  
• Debugging Utilities  
• Environment Inquiry  
• Time  
gcl-2.6.14/info/gcl/Creating-Instances-of-Classes.html0000644000175000017500000000522214360276512021040 0ustar cammcamm Creating Instances of Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.3 Creating Instances of Classes

The generic function make-instance creates and returns a new instance of a class. The object system provides several mechanisms for specifying how a new instance is to be initialized. For example, it is possible to specify the initial values for slots in newly created instances either by giving arguments to make-instance or by providing default initial values. Further initialization activities can be performed by methods written for generic functions that are part of the initialization protocol. The complete initialization protocol is described in Object Creation and Initialization.

gcl-2.6.14/info/gcl/Generalized-Reference.html0000644000175000017500000000536714360276512017521 0ustar cammcamm Generalized Reference (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow  

5.1 Generalized Reference

• Overview of Places and Generalized Reference  
• Kinds of Places  
• Treatment of Other Macros Based on SETF  
gcl-2.6.14/info/gcl/The-for_002das_002dhash-subclause.html0000644000175000017500000001230714360276512021316 0ustar cammcamm The for-as-hash subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.12 The for-as-hash subclause

In the for-as-hash subclause the for or as construct iterates over the elements, keys, and values of a hash-table. In this syntax, a compound preposition is used to designate access to a hash table. The variable var takes on the value of each hash key or hash value in the supplied hash-table. The following loop keywords serve as valid prepositions within this syntax:

being

The keyword being introduces either the Loop schema hash-key or hash-value.

each, the

The loop keyword each follows the loop keyword being when hash-key or hash-value is used. The loop keyword the is used with hash-keys and hash-values only for ease of reading. This agreement isn’t required.

hash-key, hash-keys

These loop keywords access each key entry of the hash table. If the name hash-value is supplied in a using construct with one of these Loop schemas, the iteration can optionally access the keyed value. The order in which the keys are accessed is undefined; empty slots in the hash table are ignored.

hash-value, hash-values

These loop keywords access each value entry of a hash table. If the name hash-key is supplied in a using construct with one of these Loop schemas, the iteration can optionally access the key that corresponds to the value. The order in which the keys are accessed is undefined; empty slots in the hash table are ignored.

using

The loop keyword using introduces the optional key or the keyed value to be accessed. It allows access to the hash key if iteration is over the hash values, and the hash value if iteration is over the hash keys.

in, of

These loop prepositions introduce hash-table.

In effect

being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of}

is a compound preposition.

Iteration stops when there are no more hash keys or hash values to be referenced in the supplied hash-table.

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

gcl-2.6.14/info/gcl/Lambda-Lists.html0000644000175000017500000001754114360276512015645 0ustar cammcamm Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.4 Lambda Lists

A lambda list is a list that specifies a set of parameters (sometimes called lambda variables) and a protocol for receiving values for those parameters.

There are several kinds of lambda lists. 

 Context                                     Kind of Lambda List                             
 defun form                                  ordinary lambda list                            
 defmacro form                               macro lambda list                               
 lambda expression                           ordinary lambda list                            
 flet local function definition              ordinary lambda list                            
 labels local function definition            ordinary lambda list                            
 handler-case clause specification           ordinary lambda list                            
 restart-case clause specification           ordinary lambda list                            
 macrolet local macro definition             macro lambda list                               
 define-method-combination                   ordinary lambda list                            
 define-method-combination :arguments option define-method-combination arguments lambda list 
 defstruct :constructor option               boa lambda list                                 
 defgeneric form                             generic function lambda list                    
 defgeneric method clause                    specialized lambda list                         
 defmethod form                              specialized lambda list                         
 defsetf form                                defsetf lambda list                             
 define-setf-expander form                   macro lambda list                               
 deftype form                                deftype lambda list                             
 destructuring-bind form                     destructuring lambda list                       
 define-compiler-macro form                  macro lambda list                               
 define-modify-macro form                    define-modify-macro lambda list                 

                         Figure 3–10: What Kind of Lambda Lists to Use

Figure 3–11 lists some defined names that are applicable to lambda lists. 

  lambda-list-keywords  lambda-parameters-limit    

  Figure 3–11: Defined names applicable to lambda lists
• Ordinary Lambda Lists  
• Generic Function Lambda Lists  
• Specialized Lambda Lists  
• Macro Lambda Lists  
• Destructuring Lambda Lists  
• Boa Lambda Lists  
• Defsetf Lambda Lists  
• Deftype Lambda Lists  
• Define-modify-macro Lambda Lists  
• Define-method-combination Arguments Lambda Lists  
• Syntactic Interaction of Documentation Strings and Declarations  

Next: , Previous: , Up: Evaluation and Compilation  

gcl-2.6.14/info/gcl/THE-Forms-as-Places.html0000644000175000017500000000461714360276512016703 0ustar cammcamm THE Forms as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.4 THE Forms as Places

A the form can be used as a place, in which case the declaration is transferred to the newvalue form, and the resulting setf is analyzed. For example, 

 (setf (the integer (cadr x)) (+ y 3))

is processed as if it were 

 (setf (cadr x) (the integer (+ y 3)))
gcl-2.6.14/info/gcl/Tilde-B_002d_003e-Binary.html0000644000175000017500000000462614360276512017307 0ustar cammcamm Tilde B-> Binary (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Radix Control  

22.3.2.3 Tilde B: Binary

This is just like ~D but prints in binary radix (radix 2) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalB.

~B binds *print-escape* to false, *print-radix* to false, *print-base* to 2,

and *print-readably* to false.

gcl-2.6.14/info/gcl/deposit_002dfield.html0000644000175000017500000000676514360276512016577 0ustar cammcamm deposit-field (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.67 deposit-field [Function]

deposit-field newbyte bytespec integer ⇒ result-integer

Arguments and Values::

newbyte—an integer.

bytespec—a byte specifier.

integer—an integer.

result-integer—an integer.

Description::

Replaces a field of bits within integer; specifically, returns an integer that contains the bits of newbyte within the byte specified by bytespec, and elsewhere contains the bits of integer.

Examples::

 (deposit-field 7 (byte 2 1) 0) ⇒  6
 (deposit-field -1 (byte 4 0) 0) ⇒  15
 (deposit-field 0 (byte 2 1) -3) ⇒  -7

See Also::

byte , dpb

Notes::

 (logbitp j (deposit-field m (byte s p) n))
 ≡ (if (and (>= j p) (< j (+ p s)))
        (logbitp j m)
        (logbitp j n))

deposit-field is to mask-field as dpb is to ldb.

gcl-2.6.14/info/gcl/Congruent-Lambda_002dlists-for-all-Methods-of-a-Generic-Function.html0000644000175000017500000001203114360276512027214 0ustar cammcamm Congruent Lambda-lists for all Methods of a Generic Function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.4 Congruent Lambda-lists for all Methods of a Generic Function

These rules define the congruence of a set of lambda lists, including the lambda list of each method for a given generic function and the lambda list specified for the generic function itself, if given.

1.

Each lambda list must have the same number of required parameters.

2.

Each lambda list must have the same number of optional parameters. Each method can supply its own default for an optional parameter.

3.

If any lambda list mentions &rest or &key, each lambda list must mention one or both of them.

4.

If the generic function lambda list mentions &key, each method must accept all of the keyword names mentioned after &key, either by accepting them explicitly, by specifying &allow-other-keys, or by specifying &rest but not &key. Each method can accept additional keyword arguments of its own. The checking of the validity of keyword names is done in the generic function, not in each method. A method is invoked as if the keyword argument pair whose name is :allow-other-keys and whose value is true were supplied, though no such argument pair will be passed.

5.

The use of &allow-other-keys need not be consistent across lambda lists. If &allow-other-keys is mentioned in the lambda list of any applicable method or of the generic function, any keyword arguments may be mentioned in the call to the generic function.

6.

The use of &aux need not be consistent across methods.

If a method-defining operator that cannot specify generic function options creates a generic function, and if the lambda list for the method mentions keyword arguments, the lambda list of the generic function will mention &key (but no keyword arguments).

Next: , Previous: , Up: Generic Functions and Methods  

gcl-2.6.14/info/gcl/Wildcard-Words-in-a-Logical-Pathname-Namestring.html0000644000175000017500000000527414360276512024250 0ustar cammcamm Wildcard Words in a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.7 Wildcard Words in a Logical Pathname Namestring

Each asterisk in a wildcard-word matches a sequence of zero or more characters. The wildcard-word “*” parses into :wild; other wildcard-words parse into strings.

gcl-2.6.14/info/gcl/Similarity-of-Aggregate-Objects.html0000644000175000017500000000506014360276512021365 0ustar cammcamm Similarity of Aggregate Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Literal Objects in Compiled Files  

3.2.4.3 Similarity of Aggregate Objects

Of the types over which similarity is defined, some are treated as aggregate objects. For these types, similarity is defined recursively. We say that an object of these types has certain “basic qualities” and to satisfy the similarity relationship, the values of the corresponding qualities of the two objects must also be similar.

gcl-2.6.14/info/gcl/Generic-Functions-and-Methods.html0000644000175000017500000000711514360276512021050 0ustar cammcamm Generic Functions and Methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.6 Generic Functions and Methods

• Introduction to Generic Functions  
• Introduction to Methods  
• Agreement on Parameter Specializers and Qualifiers  
• Congruent Lambda-lists for all Methods of a Generic Function  
• Keyword Arguments in Generic Functions and Methods  
• Method Selection and Combination  
• Inheritance of Methods  
gcl-2.6.14/info/gcl/logical_002dpathname-_0028System-Class_0029.html0000644000175000017500000000553514360276512022716 0ustar cammcamm logical-pathname (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.2 logical-pathname [System Class]

Class Precedence List::

logical-pathname, pathname, t

Description::

A pathname that uses a namestring syntax that is implementation-independent, and that has component values that are implementation-independent. Logical pathnames do not refer directly to filenames

See Also::

File System Concepts, Sharpsign P, Printing Pathnames

gcl-2.6.14/info/gcl/translate_002dpathname.html0000644000175000017500000002465414360276512017634 0ustar cammcamm translate-pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.16 translate-pathname [Function]

translate-pathname source from-wildcard to-wildcard &key
⇒ translated-pathname

Arguments and Values::

source—a pathname designator.

from-wildcard—a pathname designator.

to-wildcard—a pathname designator.

translated-pathname—a pathname.

Description::

translate-pathname translates source (that matches from-wildcard) into a corresponding pathname that matches to-wildcard, and returns the corresponding pathname.

The resulting pathname is to-wildcard with each wildcard or missing field replaced by a portion of source. A “wildcard field” is a pathname component with a value of :wild, a :wild element of a list-valued directory component, or an implementation-defined portion of a component, such as the "*" in the complex wildcard string "foo*bar" that some implementations support. An implementation that adds other wildcard features, such as regular expressions, must define how translate-pathname extends to those features. A “missing field” is a pathname component with a value of nil.

The portion of source that is copied into the resulting pathname is implementation-defined. Typically it is determined by the user interface conventions of the file systems involved. Usually it is the portion of source that matches a wildcard field of from-wildcard that is in the same position as the wildcard or missing field of to-wildcard. If there is no wildcard field in from-wildcard at that position, then usually it is the entire corresponding pathname component of source, or in the case of a list-valued directory component, the entire corresponding list element.

During the copying of a portion of source into the resulting pathname, additional implementation-defined translations of case or file naming conventions might occur, especially when from-wildcard and to-wildcard are for different hosts.

It is valid for source to be a wild pathname; in general this will produce a wild result. It is valid for from-wildcard and/or to-wildcard to be non-wild pathnames.

There are no specified keyword arguments for translate-pathname, but implementations are permitted to extend it by adding keyword arguments.

translate-pathname maps customary case in source into customary case in the output pathname.

Examples::

 ;; The results of the following five forms are all implementation-dependent.
 ;; The second item in particular is shown with multiple results just to 
 ;; emphasize one of many particular variations which commonly occurs.
 (pathname-name (translate-pathname "foobar" "foo*" "*baz")) ⇒  "barbaz"
 (pathname-name (translate-pathname "foobar" "foo*" "*"))
⇒  "foobar"
OR⇒ "bar"
 (pathname-name (translate-pathname "foobar" "*"    "foo*")) ⇒  "foofoobar"
 (pathname-name (translate-pathname "bar"    "*"    "foo*")) ⇒  "foobar"
 (pathname-name (translate-pathname "foobar" "foo*" "baz*")) ⇒  "bazbar"

 (defun translate-logical-pathname-1 (pathname rules)
   (let ((rule (assoc pathname rules :test #'pathname-match-p)))
     (unless rule (error "No translation rule for ~A" pathname))
     (translate-pathname pathname (first rule) (second rule))))
 (translate-logical-pathname-1 "FOO:CODE;BASIC.LISP"
                       '(("FOO:DOCUMENTATION;" "MY-UNIX:/doc/foo/")
                         ("FOO:CODE;"          "MY-UNIX:/lib/foo/")
                         ("FOO:PATCHES;*;"     "MY-UNIX:/lib/foo/patch/*/")))
⇒  #P"MY-UNIX:/lib/foo/basic.l"

;;;This example assumes one particular set of wildcard conventions
;;;Not all file systems will run this example exactly as written
 (defun rename-files (from to)
   (dolist (file (directory from))
     (rename-file file (translate-pathname file from to))))
 (rename-files "/usr/me/*.lisp" "/dev/her/*.l")
   ;Renames /usr/me/init.lisp to /dev/her/init.l
 (rename-files "/usr/me/pcl*/*" "/sys/pcl/*/")
   ;Renames /usr/me/pcl-5-may/low.lisp to /sys/pcl/pcl-5-may/low.lisp
   ;In some file systems the result might be /sys/pcl/5-may/low.lisp
 (rename-files "/usr/me/pcl*/*" "/sys/library/*/")
   ;Renames /usr/me/pcl-5-may/low.lisp to /sys/library/pcl-5-may/low.lisp
   ;In some file systems the result might be /sys/library/5-may/low.lisp
 (rename-files "/usr/me/foo.bar" "/usr/me2/")
   ;Renames /usr/me/foo.bar to /usr/me2/foo.bar
 (rename-files "/usr/joe/*-recipes.text" "/usr/jim/cookbook/joe's-*-rec.text")
   ;Renames /usr/joe/lamb-recipes.text to /usr/jim/cookbook/joe's-lamb-rec.text
   ;Renames /usr/joe/pork-recipes.text to /usr/jim/cookbook/joe's-pork-rec.text
   ;Renames /usr/joe/veg-recipes.text to /usr/jim/cookbook/joe's-veg-rec.text

Exceptional Situations::

If any of source, from-wildcard, or to-wildcard is not a pathname, a string, or a stream associated with a file an error of type type-error is signaled.

(pathname-match-p source from-wildcard) must be true or an error of type error is signaled.

See Also::

namestring , pathname-host ,

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Notes::

The exact behavior of translate-pathname cannot be dictated by the Common Lisp language and must be allowed to vary, depending on the user interface conventions of the file systems involved.

The following is an implementation guideline. One file system performs this operation by examining each piece of the three pathnames in turn, where a piece is a pathname component or a list element of a structured component such as a hierarchical directory. Hierarchical directory elements in from-wildcard and to-wildcard are matched by whether they are wildcards, not by depth in the directory hierarchy. If the piece in to-wildcard is present and not wild, it is copied into the result. If the piece in to-wildcard is :wild or nil, the piece in source is copied into the result. Otherwise, the piece in to-wildcard might be a complex wildcard such as "foo*bar" and the piece in from-wildcard should be wild; the portion of the piece in source that matches the wildcard portion of the piece in from-wildcard replaces the wildcard portion of the piece in to-wildcard and the value produced is used in the result.

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/conjugate.html0000644000175000017500000000574414360276512015352 0ustar cammcamm conjugate (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.48 conjugate [Function]

conjugate number ⇒ conjugate

Arguments and Values::

number—a number.

conjugate—a number.

Description::

Returns the complex conjugate of number. The conjugate of a

real

number is itself.

Examples::

 (conjugate #c(0 -1)) ⇒  #C(0 1)
 (conjugate #c(1 1)) ⇒  #C(1 -1)
 (conjugate 1.5) ⇒  1.5
 (conjugate #C(3/5 4/5)) ⇒  #C(3/5 -4/5)
 (conjugate #C(0.0D0 -1.0D0)) ⇒  #C(0.0D0 1.0D0)
 (conjugate 3.7) ⇒  3.7

Notes::

For a complex number z, 

 (conjugate z) ≡ (complex (realpart z) (- (imagpart z)))
gcl-2.6.14/info/gcl/compute_002dapplicable_002dmethods.html0000644000175000017500000000721214360276512021712 0ustar cammcamm compute-applicable-methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.32 compute-applicable-methods [Standard Generic Function]

Syntax::

compute-applicable-methods generic-function function-arguments ⇒ methods

Method Signatures::

compute-applicable-methods (generic-function standard-generic-function)

Arguments and Values::

generic-function—a generic function.

function-arguments—a list of arguments for the generic-function.

methods—a list of method objects.

Description::

Given a generic-function and a set of function-arguments, the function compute-applicable-methods returns the set of methods that are applicable for those arguments sorted according to precedence order. See Method Selection and Combination.

Affected By::

defmethod

See Also::

Method Selection and Combination

gcl-2.6.14/info/gcl/Restart-Tests.html0000644000175000017500000000467114360276512016115 0ustar cammcamm Restart Tests (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.6 Restart Tests

Each restart has an associated test, which is a function of one argument (a condition or nil) which returns true if the restart should be visible in the current situation. This test is created by the :test-function option to restart-bind or the :test option to restart-case.

gcl-2.6.14/info/gcl/assoc.html0000644000175000017500000001555514360276512014504 0ustar cammcamm assoc (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.36 assoc, assoc-if, assoc-if-not [Function]

assoc item alist &key key test test-not ⇒ entry

assoc-if predicate alist &key key ⇒ entry

assoc-if-not predicate alist &key key ⇒ entry

Arguments and Values::

item—an object.

alist—an association list.

predicate—a designator for a function of one argument that returns a generalized boolean.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

entry—a cons that is an element of alist, or nil.

Description::

assoc, assoc-if, and assoc-if-not return the first cons in alist whose car satisfies the test, or nil if no such cons is found.

For assoc, assoc-if, and assoc-if-not, if nil appears in alist in place of a pair, it is ignored.

Examples::

 (setq values '((x . 100) (y . 200) (z . 50))) ⇒  ((X . 100) (Y . 200) (Z . 50))
 (assoc 'y values) ⇒  (Y . 200)
 (rplacd (assoc 'y values) 201) ⇒  (Y . 201)
 (assoc 'y values) ⇒  (Y . 201)
 (setq alist '((1 . "one")(2 . "two")(3 . "three"))) 
⇒  ((1 . "one") (2 . "two") (3 . "three"))
 (assoc 2 alist) ⇒  (2 . "two")
 (assoc-if #'evenp alist) ⇒  (2 . "two")
 (assoc-if-not #'(lambda(x) (< x 3)) alist) ⇒  (3 . "three")
 (setq alist '(("one" . 1)("two" . 2))) ⇒  (("one" . 1) ("two" . 2))
 (assoc "one" alist) ⇒  NIL
 (assoc "one" alist :test #'equalp) ⇒  ("one" . 1)
 (assoc "two" alist :key #'(lambda(x) (char x 2))) ⇒  NIL 
 (assoc #\o alist :key #'(lambda(x) (char x 2))) ⇒  ("two" . 2)
 (assoc 'r '((a . b) (c . d) (r . x) (s . y) (r . z))) ⇒   (R . X)
 (assoc 'goo '((foo . bar) (zoo . goo))) ⇒  NIL
 (assoc '2 '((1 a b c) (2 b c d) (-7 x y z))) ⇒  (2 B C D)
 (setq alist '(("one" . 1) ("2" . 2) ("three" . 3)))
⇒  (("one" . 1) ("2" . 2) ("three" . 3))
 (assoc-if-not #'alpha-char-p alist
               :key #'(lambda (x) (char x 0))) ⇒  ("2" . 2)

Exceptional Situations::

Should be prepared to signal an error of type type-error if alist is not an association list.

See Also::

rassoc , find , member (Function) , position ,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

The function assoc-if-not is deprecated.

It is possible to rplacd the result of assoc, provided that it is not nil, in order to “update” alist.

The two expressions 

 (assoc item list :test fn)

and 

 (find item list :test fn :key #'car)

are equivalent in meaning with one exception: if nil appears in alist in place of a pair, and item is nil, find will compute the car of the nil in alist, find that it is equal to item, and return nil, whereas assoc will ignore the nil in alist and continue to search for an actual cons whose car is nil.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/error.html0000644000175000017500000001543614360276512014523 0ustar cammcamm error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.11 error [Function]

error datum &rest arguments ⇒ #<NoValue>

Arguments and Values::

datum, arguments—designators for a condition of default type simple-error.

Description::

error effectively invokes signal on the denoted condition.

If the condition is not handled, (invoke-debugger condition) is done. As a consequence of calling invoke-debugger, error cannot directly return; the only exit from error can come by non-local transfer of control in a handler or by use of an interactive debugging command.

Examples::

 (defun factorial (x)
   (cond ((or (not (typep x 'integer)) (minusp x))
          (error "~S is not a valid argument to FACTORIAL." x))
         ((zerop x) 1)
         (t (* x (factorial (- x 1))))))
⇒  FACTORIAL
(factorial 20)
⇒  2432902008176640000
(factorial -1)
 |>  Error: -1 is not a valid argument to FACTORIAL.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return to Lisp Toplevel.
 |>  Debug> 

 (setq a 'fred)
⇒  FRED
 (if (numberp a) (1+ a) (error "~S is not a number." A))
 |>  Error: FRED is not a number.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return to Lisp Toplevel.
 |>  Debug> |>>:Continue 1<<|
 |>  Return to Lisp Toplevel.

 (define-condition not-a-number (error) 
                   ((argument :reader not-a-number-argument :initarg :argument))
   (:report (lambda (condition stream)
              (format stream "~S is not a number."
                      (not-a-number-argument condition)))))
⇒  NOT-A-NUMBER

 (if (numberp a) (1+ a) (error 'not-a-number :argument a))
 |>  Error: FRED is not a number.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return to Lisp Toplevel.
 |>  Debug> |>>:Continue 1<<|
 |>  Return to Lisp Toplevel.

Side Effects::

Handlers for the specified condition, if any, are invoked and might have side effects. Program execution might stop, and the debugger might be entered.

Affected By::

Existing handler bindings.

*break-on-signals*

Signals an error of type type-error if datum and arguments are not designators for a condition.

See Also::

cerror , signal , format , ignore-errors , *break-on-signals*, handler-bind , Condition System Concepts

Notes::

Some implementations may provide debugger commands for interactively returning from individual stack frames. However, it should be possible for the programmer to feel confident about writing code like: 

 (defun wargames:no-win-scenario ()
   (if (error "pushing the button would be stupid."))
   (push-the-button))

In this scenario, there should be no chance that error will return and the button will get pushed.

While the meaning of this program is clear and it might be proven ‘safe’ by a formal theorem prover, such a proof is no guarantee that the program is safe to execute. Compilers have been known to have bugs, computers to have signal glitches, and human beings to manually intervene in ways that are not always possible to predict. Those kinds of errors, while beyond the scope of the condition system to formally model, are not beyond the scope of things that should seriously be considered when writing code that could have the kinds of sweeping effects hinted at by this example.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/hash_002dtable.html0000644000175000017500000000601114360276512016037 0ustar cammcamm hash-table (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.1 hash-table [System Class]

Class Precedence List::

hash-table, t

Description::

Hash tables provide a way of mapping any object (a key) to an associated object (a value).

See Also::

Hash Table Concepts, Printing Other Objects

Notes::

The intent is that this mapping be implemented by a hashing mechanism, such as that described in Section 6.4 “Hashing” of The Art of Computer Programming, Volume 3 (pp506-549). In spite of this intent, no conforming implementation is required to use any particular technique to implement the mapping.

gcl-2.6.14/info/gcl/method_002dqualifiers.html0000644000175000017500000000640614360276512017461 0ustar cammcamm method-qualifiers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.15 method-qualifiers [Standard Generic Function]

Syntax::

method-qualifiers method ⇒ qualifiers

Method Signatures::

method-qualifiers (method standard-method)

Arguments and Values::

method—a method.

qualifiers—a proper list.

Description::

Returns a list of the qualifiers of the method.

Examples::

 (defmethod some-gf :before ((a integer)) a)
⇒  #<STANDARD-METHOD SOME-GF (:BEFORE) (INTEGER) 42736540>
 (method-qualifiers *) ⇒  (:BEFORE)

See Also::

define-method-combination

gcl-2.6.14/info/gcl/Tilde-Less_002dThan_002dSign_002d_003e-Justification.html0000644000175000017500000001461114360276512024324 0ustar cammcamm Tilde Less-Than-Sign-> Justification (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Layout Control  

22.3.6.2 Tilde Less-Than-Sign: Justification

~mincol,colinc,minpad,padchar<str~>

This justifies the text produced by processing str within a field at least mincol columns wide. str may be divided up into segments with ~;, in which case the spacing is evenly divided between the text segments.

With no modifiers, the leftmost text segment is left justified in the field, and the rightmost text segment is right justified. If there is only one text element, as a special case, it is right justified. The : modifier causes spacing to be introduced before the first text segment; the @ modifier causes spacing to be added after the last. The minpad parameter (default 0) is the minimum number of padding characters to be output between each segment. The padding character is supplied by padchar, which defaults to the space character. If the total width needed to satisfy these constraints is greater than mincol, then the width used is mincol+k*colinc for the smallest possible non-negative integer value k. colinc defaults to 1, and mincol defaults to 0.

Note that str may include format directives. All the clauses in str are processed in order; it is the resulting pieces of text that are justified.

The ~^ directive may be used to terminate processing of the clauses prematurely, in which case only the completely processed clauses are justified.

If the first clause of a ~< is terminated with ~:; instead of ~;, then it is used in a special way. All of the clauses are processed (subject to ~^ , of course), but the first one is not used in performing the spacing and padding. When the padded result has been determined, then if it will fit on the current line of output, it is output, and the text for the first clause is discarded. If, however, the padded text will not fit on the current line, then the text segment for the first clause is output before the padded text. The first clause ought to contain a newline (such as a ~% directive). The first clause is always processed, and so any arguments it refers to will be used; the decision is whether to use the resulting segment of text, not whether to process the first clause. If the ~:; has a prefix parameter n, then the padded text must fit on the current line with n character positions to spare to avoid outputting the first clause’s text. For example, the control string 

 "~

can be used to print a list of items separated by commas without breaking items over line boundaries, beginning each line with ;; . The prefix parameter 1 in ~1:; accounts for the width of the comma that will follow the justified item if it is not the last element in the list, or the period if it is. If ~:; has a second prefix parameter, then it is used as the width of the line, thus overriding the natural line width of the output stream. To make the preceding example use a line width of 50, one would write 

 "~

If the second argument is not supplied, then format uses the line width of the destination output stream. If this cannot be determined (for example, when producing a string result), then format uses 72 as the line length.

See also Tilde Less-Than-Sign-> Logical Block.

Next: , Previous: , Up: FORMAT Layout Control  

gcl-2.6.14/info/gcl/peek_002dchar.html0000644000175000017500000001363014360276512015673 0ustar cammcamm peek-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.16 peek-char [Function]

peek-char &optional peek-type input-stream eof-error-p eof-value recursive-p ⇒ char

Arguments and Values::

peek-type—a character or t or nil.

input-stream—input stream designator. The default is standard input.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object. The default is nil.

recursive-p—a generalized boolean. The default is false.

char—a character or the eof-value.

Description::

peek-char obtains the next character in input-stream without actually reading it, thus leaving the character to be read at a later time. It can also be used to skip over and discard intervening characters in the input-stream until a particular character is found.

If peek-type is not supplied or nil, peek-char returns the next character to be read from input-stream, without actually removing it from input-stream. The next time input is done from input-stream, the character will still be there. If peek-type is t, then peek-char skips over whitespace_2 characters, but not comments, and then performs the peeking operation on the next character. The last character examined, the one that starts an object, is not removed from input-stream. If peek-type is a character, then peek-char skips over input characters until a character that is char= to that character is found; that character is left in input-stream.

If an end of file_2 occurs and eof-error-p is false, eof-value is returned.

If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader.

When input-stream is an echo stream, characters that are only peeked at are not echoed. In the case that peek-type is not nil, the characters that are passed by peek-char are treated as if by read-char, and so are echoed unless they have been marked otherwise by unread-char.

Examples::

 (with-input-from-string (input-stream "    1 2 3 4 5")
    (format t "~S ~S ~S" 
            (peek-char t input-stream)
            (peek-char #\4 input-stream)
            (peek-char nil input-stream)))
 |>  #\1 #\4 #\4
⇒  NIL

Affected By::

*readtable*, *standard-input*, *terminal-io*.

Exceptional Situations::

If eof-error-p is true and an end of file_2 occurs an error of type end-of-file is signaled.

If peek-type is a character, an end of file_2 occurs, and eof-error-p is true, an error of type end-of-file is signaled.

If recursive-p is true and an end of file_2 occurs, an error of type end-of-file is signaled.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/Sharpsign-Equal_002dSign.html0000644000175000017500000000457314360276512017743 0ustar cammcamm Sharpsign Equal-Sign (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.16 Sharpsign Equal-Sign

#n=

#n=object reads as whatever object has object as its printed representation. However, that object is labeled by n, a required unsigned decimal integer, for possible reference by the syntax #n#. The scope of the label is the expression being read by the outermost call to read; within this expression, the same label may not appear twice.

gcl-2.6.14/info/gcl/Objects-Dictionary.html0000644000175000017500000002164214360276512017062 0ustar cammcamm Objects Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Objects  

7.7 Objects Dictionary

• function-keywords  
• ensure-generic-function  
• allocate-instance  
• reinitialize-instance  
• shared-initialize  
• update-instance-for-different-class  
• update-instance-for-redefined-class  
• change-class  
• slot-boundp  
• slot-exists-p  
• slot-makunbound  
• slot-missing  
• slot-unbound  
• slot-value  
• method-qualifiers  
• no-applicable-method  
• no-next-method  
• remove-method  
• make-instance  
• make-instances-obsolete  
• make-load-form  
• make-load-form-saving-slots  
• with-accessors  
• with-slots  
• defclass  
• defgeneric  
• defmethod  
• find-class  
• next-method-p  
• call-method  
• call-next-method  
• compute-applicable-methods  
• define-method-combination  
• find-method  
• add-method  
• initialize-instance  
• class-name  
• setf class-name  
• class-of  
• unbound-slot  
• unbound-slot-instance  

Previous: , Up: Objects  

gcl-2.6.14/info/gcl/translate_002dlogical_002dpathname.html0000644000175000017500000001342514360276512021706 0ustar cammcamm translate-logical-pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.15 translate-logical-pathname [Function]

translate-logical-pathname pathname &key ⇒ physical-pathname

Arguments and Values::

pathname—a pathname designator, or a logical pathname namestring.

physical-pathname—a physical pathname.

Description::

Translates pathname to a physical pathname, which it returns.

If pathname is a stream, the stream can be either open or closed. translate-logical-pathname returns the same physical pathname after a file is closed as it did when the file was open.

It is an error if pathname is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, make-string-output-stream.

If pathname is a logical pathname namestring, the host portion of the logical pathname namestring and its following colon are required.

Pathname is first coerced to a pathname. If the coerced pathname is a physical pathname, it is returned. If the coerced pathname is a logical pathname, the first matching translation (according to pathname-match-p) of the logical pathname host is applied, as if by calling translate-pathname. If the result is a logical pathname, this process is repeated. When the result is finally a physical pathname, it is returned. If no translation matches, an error is signaled.

translate-logical-pathname might perform additional translations, typically to provide translation of file types to local naming conventions, to accomodate physical file systems with limited length names, or to deal with special character requirements such as translating hyphens to underscores or uppercase letters to lowercase. Any such additional translations are implementation-defined. Some implementations do no additional translations.

There are no specified keyword arguments for translate-logical-pathname, but implementations are permitted to extend it by adding keyword arguments.

Examples::

See logical-pathname-translations.

Exceptional Situations::

If pathname is incorrectly supplied, an error of type type-error is signaled.

If no translation matches, an error of type file-error is signaled.

[Editorial Note by KMP: Is file-error really right, or should it be pathname-error?]

See Also::

logical-pathname , logical-pathname-translations , logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/Printing-Strings.html0000644000175000017500000000530414360276512016604 0ustar cammcamm Printing Strings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.12 Printing Strings

The characters of the string are output in order.

If printer escaping is enabled,

a double-quote is output before and after, and all double-quotes and single escapes are preceded by backslash. The printing of strings is not affected by *print-array*. Only the active elements of the string are printed.

For information on how the Lisp reader parses strings, see Double-Quote.

gcl-2.6.14/info/gcl/The-_0022Binding-Types-Affected_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000576514360276512027021 0ustar cammcamm The "Binding Types Affected" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.4 The "Binding Types Affected" Section of a Dictionary Entry

This information alerts the reader to the kinds of bindings that might potentially be affected by a declaration. Whether in fact any particular such binding is actually affected is dependent on additional factors as well. See The "Description" Section of the declaration in question for details.

gcl-2.6.14/info/gcl/Examples-of-ALWAYS.html0000644000175000017500000000744114360276512016545 0ustar cammcamm Examples of ALWAYS (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Termination Test Clauses  

6.1.4.2 Examples of ALWAYS, NEVER, and THEREIS clauses

;; Make sure I is always less than 11 (two ways).
;; The FOR construct terminates these loops.
 (loop for i from 0 to 10
       always (< i 11))
⇒  T
 (loop for i from 0 to 10
       never (> i 11))
⇒  T

;; If I exceeds 10 return I; otherwise, return NIL.
;; The THEREIS construct terminates this loop.
 (loop for i from 0
       thereis (when (> i 10) i) )
⇒  11

;;; The FINALLY clause is not evaluated in these examples.
 (loop for i from 0 to 10
       always (< i 9)
       finally (print "you won't see this"))
⇒  NIL
 (loop never t
       finally (print "you won't see this"))
⇒  NIL
 (loop thereis "Here is my value"
       finally (print "you won't see this"))
⇒  "Here is my value"

;; The FOR construct terminates this loop, so the FINALLY clause 
;; is evaluated.
 (loop for i from 1 to 10
       thereis (> i 11)
       finally (prin1 'got-here))
 |>  GOT-HERE
⇒  NIL

;; If this code could be used to find a counterexample to Fermat's
;; last theorem, it would still not return the value of the
;; counterexample because all of the THEREIS clauses in this example
;; only return T.  But if Fermat is right, that won't matter
;; because this won't terminate.

 (loop for z upfrom 2
       thereis
         (loop for n upfrom 3 below (log z 2)
               thereis
                 (loop for x below z
                       thereis
                         (loop for y below z
                               thereis (= (+ (expt x n) (expt y n))
                                          (expt z n))))))
gcl-2.6.14/info/gcl/block.html0000644000175000017500000001043414360276512014455 0ustar cammcamm block (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.22 block [Special Operator]

block name form* ⇒ {result}*

Arguments and Values::

name—a symbol.

form—a form.

results—the values of the forms if a normal return occurs, or else, if an explicit return occurs, the values that were transferred.

Description::

block establishes a block named name and then evaluates forms as an implicit progn.

The special operators block and return-from work together to provide a structured, lexical, non-local exit facility. At any point lexically contained within forms, return-from can be used with the given name to return control and values from the block form, except when an intervening block with the same name has been established, in which case the outer block is shadowed by the inner one.

The block named name has lexical scope and dynamic extent.

Once established, a block may only be exited once, whether by normal return or explicit return.

Examples::

 (block empty) ⇒  NIL
 (block whocares (values 1 2) (values 3 4)) ⇒  3, 4
 (let ((x 1)) 
   (block stop (setq x 2) (return-from stop) (setq x 3))
   x) ⇒  2
 (block early (return-from early (values 1 2)) (values 3 4)) ⇒  1, 2
 (block outer (block inner (return-from outer 1)) 2) ⇒  1
 (block twin (block twin (return-from twin 1)) 2) ⇒  2
 ;; Contrast behavior of this example with corresponding example of CATCH.
 (block b
   (flet ((b1 () (return-from b 1)))
     (block b (b1) (print 'unreachable))
     2)) ⇒  1

See Also::

return , return-from , Evaluation

Notes::

gcl-2.6.14/info/gcl/or.html0000644000175000017500000000736114360276512014010 0ustar cammcamm or (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.44 or [Macro]

or {form}* ⇒ {results}*

Arguments and Values::

form—a form.

results—the values or primary value (see below) resulting from the evaluation of the last form executed or nil.

Description::

or evaluates each form, one at a time, from left to right. The evaluation of all forms terminates when a form evaluates to true (i.e., something other than nil).

If the evaluation of any form other than the last returns a primary value that is true, or immediately returns that value (but no additional values) without evaluating the remaining forms. If every form but the last returns false as its primary value, or returns all values returned by the last form. If no forms are supplied, or returns nil.

Examples::

 (or) ⇒  NIL 
 (setq temp0 nil temp1 10 temp2 20 temp3 30) ⇒  30
 (or temp0 temp1 (setq temp2 37)) ⇒  10
 temp2 ⇒  20
 (or (incf temp1) (incf temp2) (incf temp3)) ⇒  11
 temp1 ⇒  11
 temp2 ⇒  20
 temp3 ⇒  30
 (or (values) temp1) ⇒  11
 (or (values temp1 temp2) temp3) ⇒  11
 (or temp0 (values temp1 temp2)) ⇒  11, 20
 (or (values temp0 temp1) (values temp2 temp3)) ⇒  20, 30

See Also::

and , some, unless

gcl-2.6.14/info/gcl/Examples-of-Setf-Expansions.html0000644000175000017500000001141214360276512020564 0ustar cammcamm Examples of Setf Expansions (ANSI and GNU Common Lisp Document)

Previous: , Up: Overview of Places and Generalized Reference  

5.1.1.4 Examples of Setf Expansions

Examples of the contents of the constituents of setf expansions follow.

For a variable x: 

  ()              ;list of temporary variables  
  ()              ;list of value forms          
  (g0001)         ;list of store variables      
  (setq x g0001)  ;storing form                 
  x               ;accessing form               

  Figure 5–3: Sample Setf Expansion of a Variable

For (car exp): 

  (g0002)                             ;list of temporary variables  
  (exp)                               ;list of value forms          
  (g0003)                             ;list of store variables      
  (progn (rplaca g0002 g0003) g0003)  ;storing form                 
  (car g0002)                         ;accessing form               

           Figure 5–4: Sample Setf Expansion of a CAR Form

For (subseq seq s e): 

  (g0004 g0005 g0006)         ;list of temporary variables  
  (seq s e)                   ;list of value forms          
  (g0007)                     ;list of store variables      
  (progn (replace g0004 g0007 :start1 g0005 :end1 g0006) g0007) 
                              ;storing form                 
  (subseq g0004 g0005 g0006)  ; accessing form              

     Figure 5–5: Sample Setf Expansion of a SUBSEQ Form

In some cases, if a subform of a place is itself a place, it is necessary to expand the subform in order to compute some of the values in the expansion of the outer place. For (ldb bs (car exp)): 

  (g0001 g0002)            ;list of temporary variables  
  (bs exp)                 ;list of value forms          
  (g0003)                  ;list of store variables      
  (progn (rplaca g0002 (dpb g0003 g0001 (car g0002))) g0003) 
                           ;storing form                 
  (ldb g0001 (car g0002))  ; accessing form              

     Figure 5–6: Sample Setf Expansion of a LDB Form
gcl-2.6.14/info/gcl/sin.html0000644000175000017500000000626514360276512014163 0ustar cammcamm sin (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.20 sin, cos, tan [Function]

sin radians ⇒ number

cos radians ⇒ number

tan radians ⇒ number

Arguments and Values::

radians—a number given in radians.

number—a number.

Description::

sin, cos, and tan return the sine, cosine, and tangent, respectively, of radians.

Examples::

 (sin 0) ⇒  0.0
 (cos 0.7853982) ⇒  0.707107
 (tan #c(0 1)) ⇒  #C(0.0 0.761594)

Exceptional Situations::

Should signal an error of type type-error if radians is not a number. Might signal arithmetic-error.

See Also::

asin , acos, atan, Rule of Float Substitutability

gcl-2.6.14/info/gcl/symbol_002dplist.html0000644000175000017500000000724614360276512016500 0ustar cammcamm symbol-plist (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.13 symbol-plist [Accessor]

symbol-plist symbol ⇒ plist

(setf ( symbol-plist symbol) new-plist)

Arguments and Values::

symbol—a symbol.

plist, new-plist—a property list.

Description::

Accesses the property list of symbol.

Examples::

 (setq sym (gensym)) ⇒  #:G9723
 (symbol-plist sym) ⇒  ()
 (setf (get sym 'prop1) 'val1) ⇒  VAL1
 (symbol-plist sym) ⇒  (PROP1 VAL1)
 (setf (get sym 'prop2) 'val2) ⇒  VAL2
 (symbol-plist sym) ⇒  (PROP2 VAL2 PROP1 VAL1)
 (setf (symbol-plist sym) (list 'prop3 'val3)) ⇒  (PROP3 VAL3)
 (symbol-plist sym) ⇒  (PROP3 VAL3)

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

get , remprop

Notes::

The use of setf should be avoided, since a symbol’s property list is a global resource that can contain information established and depended upon by unrelated programs in the same Lisp image.

gcl-2.6.14/info/gcl/pushnew.html0000644000175000017500000001405714360276512015061 0ustar cammcamm pushnew (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.45 pushnew [Macro]

pushnew item place &key key test test-not
⇒ new-place-value

Arguments and Values::

item—an object.

place—a place, the value of which is a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

new-place-value—a list (the new value of place).

Description::

pushnew tests whether item is the same as any existing element of the list stored in place. If item is not, it is prepended to the list, and the new list is stored in place.

pushnew returns the new list that is stored in place.

Whether or not item is already a member of the list that is in place is determined by comparisons using :test or :test-not. The first argument to the :test or :test-not function is item; the second argument is an element of the list in place as returned by the :key function (if supplied).

If :key is supplied, it is used to extract the part to be tested from both item and the list element, as for adjoin.

The argument to the :key function is an element of the list stored in place. The :key function typically returns part part of the element of the list. If :key is not supplied or nil, the list element is used.

For information about the evaluation of subforms of place, see Evaluation of Subforms to Places.

It is implementation-dependent whether or not pushnew actually executes the storing form for its place in the situation where the item is already a member of the list held by place.

Examples::

 (setq x '(a (b c) d)) ⇒  (A (B C) D)
 (pushnew 5 (cadr x)) ⇒  (5 B C)   
 x ⇒  (A (5 B C) D)
 (pushnew 'b (cadr x)) ⇒  (5 B C)  
 x ⇒  (A (5 B C) D)
 (setq lst '((1) (1 2) (1 2 3))) ⇒  ((1) (1 2) (1 2 3))
 (pushnew '(2) lst) ⇒  ((2) (1) (1 2) (1 2 3))
 (pushnew '(1) lst) ⇒  ((1) (2) (1) (1 2) (1 2 3))
 (pushnew '(1) lst :test 'equal) ⇒  ((1) (2) (1) (1 2) (1 2 3))
 (pushnew '(1) lst :key #'car) ⇒  ((1) (2) (1) (1 2) (1 2 3))

Side Effects::

The contents of place may be modified.

See Also::

push , adjoin , Generalized Reference

Notes::

The effect of 

 (pushnew item place :test p)

is roughly equivalent to 

 (setf place (adjoin item place :test p))

except that the subforms of place are evaluated only once, and item is evaluated before place.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/graphic_002dchar_002dp.html0000644000175000017500000000656414360276512017301 0ustar cammcamm graphic-char-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.12 graphic-char-p [Function]

graphic-char-p char ⇒ generalized-boolean

Arguments and Values::

char—a character.

generalized-boolean—a generalized boolean.

Description::

Returns true if character is a graphic character; otherwise, returns false.

Examples::

 (graphic-char-p #\G) ⇒  true
 (graphic-char-p #\#) ⇒  true
 (graphic-char-p #\Space) ⇒  true
 (graphic-char-p #\Newline) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

read , Character Syntax, Documentation of Implementation-Defined Scripts

gcl-2.6.14/info/gcl/Tilde-Semicolon_002d_003e-Clause-Separator.html0000644000175000017500000000470614360276512023003 0ustar cammcamm Tilde Semicolon-> Clause Separator (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Miscellaneous Pseudo-Operations  

22.3.9.1 Tilde Semicolon: Clause Separator

This separates clauses in ~[ and ~< constructs. The consequences of using it elsewhere are undefined.

gcl-2.6.14/info/gcl/finish_002doutput.html0000644000175000017500000001045114360276512016650 0ustar cammcamm finish-output (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.36 finish-output, force-output, clear-output [Function]

finish-output &optional output-stream ⇒ nil

force-output &optional output-stream ⇒ nil

clear-output &optional output-stream ⇒ nil

Arguments and Values::

output-stream—an output stream designator. The default is standard output.

Description::

finish-output, force-output, and clear-output exercise control over the internal handling of buffered stream output.

finish-output attempts to ensure that any buffered output sent to output-stream has reached its destination, and then returns.

force-output initiates the emptying of any internal buffers but does not wait for completion or acknowledgment to return.

clear-output attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the destination.

If any of these operations does not make sense for output-stream, then it does nothing. The precise actions of these functions are implementation-dependent.

Examples::

;; Implementation A
 (progn (princ "am i seen?") (clear-output))
⇒  NIL

;; Implementation B
 (progn (princ "am i seen?") (clear-output))
 |>  am i seen?
⇒  NIL

Affected By::

*standard-output*

Exceptional Situations::

Should signal an error of type type-error if output-stream is not a stream designator.

See Also::

clear-input

gcl-2.6.14/info/gcl/Modifying-the-Structure-of-the-Instance.html0000644000175000017500000000651314360276512023011 0ustar cammcamm Modifying the Structure of the Instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Changing the Class of an Instance  

7.2.1 Modifying the Structure of the Instance

In order to make the instance conform to the class C_{to}, local slots specified by the class C_{to} that are not specified by the class C_{from} are added, and local slots not specified by the class C_{to} that are specified by the class C_{from} are discarded.

The values of local slots specified by both the class C_{to} and the class C_{from} are retained. If such a local slot was unbound, it remains unbound.

The values of slots specified as shared in the class C_{from} and as local in the class C_{to} are retained.

This first step of the update does not affect the values of any shared slots.

gcl-2.6.14/info/gcl/_002f-_0028Variable_0029.html0000644000175000017500000000742614360276512017046 0ustar cammcamm / (Variable) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.23 /, //, /// [Variable]

Value Type::

a proper list.

Initial Value::

implementation-dependent.

Description::

The variables /, //, and /// are maintained by the Lisp read-eval-print loop to save the values of results that were printed at the end of the loop.

The value of / is a list of the most recent values that were printed, the value of // is the previous value of /, and the value of /// is the previous value of //.

The values of /, //, and /// are updated immediately prior to printing the return value of a top-level form by the Lisp read-eval-print loop. If the evaluation of such a form is aborted prior to its normal return, the values of /, //, and /// are not updated.

Examples::

 (floor 22 7) ⇒  3, 1
 (+ (* (car /) 7) (cadr /)) ⇒  22

Affected By::

Lisp read-eval-print loop.

See Also::

- (variable), + (variable), * (variable), Top level loop

gcl-2.6.14/info/gcl/copy_002dseq.html0000644000175000017500000000725314360276512015600 0ustar cammcamm copy-seq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.2 copy-seq [Function]

copy-seq sequence ⇒ copied-sequence

Arguments and Values::

sequence—a proper sequence.

copied-sequence—a proper sequence.

Description::

Creates a copy of sequence. The elements of the new sequence are the same as the corresponding elements of the given sequence.

If sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list.

Examples::

 (setq str "a string") ⇒  "a string"
 (equalp str (copy-seq str)) ⇒  true
 (eql str (copy-seq str)) ⇒  false

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

copy-list

Notes::

From a functional standpoint, 

 (copy-seq x) ≡ (subseq x 0)

However, the programmer intent is typically very different in these two cases.

gcl-2.6.14/info/gcl/vectorp.html0000644000175000017500000000577114360276512015055 0ustar cammcamm vectorp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.32 vectorp [Function]

vectorp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type vector; otherwise, returns false.

Examples::

 (vectorp "aaaaaa") ⇒  true
 (vectorp (make-array 6 :fill-pointer t)) ⇒  true
 (vectorp (make-array '(2 3 4))) ⇒  false
 (vectorp #*11) ⇒  true
 (vectorp #b11) ⇒  false

Notes::

 (vectorp object) ≡ (typep object 'vector)
gcl-2.6.14/info/gcl/nth.html0000644000175000017500000000706414360276512014161 0ustar cammcamm nth (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.22 nth [Accessor]

nth n list ⇒ object

(setf ( nth n list) new-object)

Arguments and Values::

n—a non-negative integer.

list—a list,

which might be a dotted list or a circular list.

object—an object.

new-object—an object.

Description::

nth locates the nth element of list, where the car of the list is the “zeroth” element.

Specifically, 

 (nth n list) ≡ (car (nthcdr n list))

nth may be used to specify a place to setf.

Specifically, 

 (setf (nth n list) new-object) ≡ (setf (car (nthcdr n list)) new-object)

Examples::

 (nth 0 '(foo bar baz)) ⇒  FOO
 (nth 1 '(foo bar baz)) ⇒  BAR
 (nth 3 '(foo bar baz)) ⇒  NIL
 (setq 0-to-3 (list 0 1 2 3)) ⇒  (0 1 2 3)
 (setf (nth 2 0-to-3) "two") ⇒  "two"
 0-to-3 ⇒  (0 1 "two" 3)

See Also::

elt , first , nthcdr

gcl-2.6.14/info/gcl/Symbol-Macros-as-Places.html0000644000175000017500000000440014360276512017654 0ustar cammcamm Symbol Macros as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.8 Symbol Macros as Places

A reference to a symbol that has been established as a symbol macro can be used as a place. In this case, setf expands the reference and then analyzes the resulting form.

gcl-2.6.14/info/gcl/internal_002dtime_002dunits_002dper_002dsecond.html0000644000175000017500000000555214360276512023575 0ustar cammcamm internal-time-units-per-second (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.11 internal-time-units-per-second [Constant Variable]

Constant Value::

A positive integer, the magnitude of which is implementation-dependent.

Description::

The number of internal time units in one second.

See Also::

get-internal-run-time , get-internal-real-time

Notes::

These units form the basis of the Internal Time format representation.

gcl-2.6.14/info/gcl/compiled_002dfunction.html0000644000175000017500000000607114360276512017454 0ustar cammcamm compiled-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.4 compiled-function [Type]

Supertypes::

compiled-function, function, t

Description::

Any function may be considered by an implementation to be a a compiled function if it contains no references to macros that must be expanded at run time, and it contains no unresolved references to load time values. See Compilation Semantics.

Functions whose definitions appear lexically within a file that has been compiled with compile-file and then loaded with load are of type compiled-function.

Functions produced by the compile function are of type compiled-function.

Other functions might also be of type compiled-function.

gcl-2.6.14/info/gcl/Examples-of-Feature-Expressions.html0000644000175000017500000001067214360276512021460 0ustar cammcamm Examples of Feature Expressions (ANSI and GNU Common Lisp Document)

Previous: , Up: Features  

24.1.2.2 Examples of Feature Expressions

For example, suppose that in implementation A, the features spice and perq are present, but the feature lispm is not present; in implementation B, the feature lispm is present, but the features spice and perq are not present; and in implementation C, none of the features spice, lispm, or perq are present. Figure 24–1 shows some sample expressions, and how they would be read_2 in these implementations. 

  (cons #+spice "Spice" #-spice "Lispm" x) 
  in implementation A ...    (CONS "Spice" X)             
    in implementation B ...  (CONS "Lispm" X)             
    in implementation C ...  (CONS "Lispm" X)             
  (cons #+spice "Spice" #+LispM "Lispm" x) 
  in implementation A ...    (CONS "Spice" X)             
    in implementation B ...  (CONS "Lispm" X)             
    in implementation C ...  (CONS X)                     
  (setq a '(1 2 #+perq 43 #+(not perq) 27)) 
  in implementation A ...    (SETQ A '(1 2 43))           
    in implementation B ...  (SETQ A '(1 2 27))           
    in implementation C ...  (SETQ A '(1 2 27))           
  (let ((a 3) #+(or spice lispm) (b 3)) (foo a)) 
  in implementation A ...    (LET ((A 3) (B 3)) (FOO A))  
    in implementation B ...  (LET ((A 3) (B 3)) (FOO A))  
    in implementation C ...  (LET ((A 3)) (FOO A))        
  (cons #+Lispm "#+Spice" #+Spice "foo" #-(or Lispm Spice) 7 x) 
  in implementation A ...    (CONS "foo" X)               
    in implementation B ...  (CONS "#+Spice" X)           
    in implementation C ...  (CONS 7 X)                   

              Figure 24–1: Features examples
gcl-2.6.14/info/gcl/elt.html0000644000175000017500000000721114360276512014146 0ustar cammcamm elt (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.3 elt [Accessor]

elt sequence index ⇒ object

(setf ( elt sequence index) new-object)

Arguments and Values::

sequence—a proper sequence.

index—a valid sequence index for sequence.

object—an object.

new-object—an object.

Description::

Accesses the element of sequence specified by index.

Examples::

 (setq str (copy-seq "0123456789")) ⇒  "0123456789"
 (elt str 6) ⇒  #\6
 (setf (elt str 0) #\#) ⇒  #\#
 str ⇒  "#123456789"

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if index is not a valid sequence index for sequence.

See Also::

aref , nth ,

Compiler Terminology

Notes::

aref may be used to access vector elements that are beyond the vector’s fill pointer.

gcl-2.6.14/info/gcl/read_002dchar_002dno_002dhang.html0000644000175000017500000001231714360276512020330 0ustar cammcamm read-char-no-hang (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.18 read-char-no-hang [Function]

read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p ⇒ char

Arguments and Values::

input-stream – an input stream designator. The default is standard input.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object. The default is nil.

recursive-p—a generalized boolean. The default is false.

char—a character or nil or the eof-value.

Description::

read-char-no-hang returns a character from input-stream if such a character is available. If no character is available, read-char-no-hang returns nil.

If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader.

If an end of file_2 occurs and eof-error-p is false, eof-value is returned.

Examples::

;; This code assumes an implementation in which a newline is not
;; required to terminate input from the console.
 (defun test-it ()
   (unread-char (read-char))
   (list (read-char-no-hang) 
         (read-char-no-hang) 
         (read-char-no-hang)))
⇒  TEST-IT
;; Implementation A, where a Newline is not required to terminate
;; interactive input on the console.
 (test-it)
 |>  |>>a<<|
⇒  (#\a NIL NIL)
;; Implementation B, where a Newline is required to terminate
;; interactive input on the console, and where that Newline remains
;; on the input stream.
 (test-it)
 |>  |>>a[<–~]<<|
⇒  (#\a #\Newline NIL)

Affected By::

*standard-input*, *terminal-io*.

Exceptional Situations::

If an end of file_2 occurs when eof-error-p is true, an error of type end-of-file is signaled .

See Also::

listen

Notes::

read-char-no-hang is exactly like read-char, except that if it would be necessary to wait in order to get a character (as from a keyboard), nil is immediately returned without waiting.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/ignore.html0000644000175000017500000001264314360276512014652 0ustar cammcamm ignore (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.19 ignore, ignorable [Declaration]

Syntax::

(ignore {var | (function fn)}*)

(ignorable {var | (function fn)}*)

Arguments::

var—a variable name.

fn—a function name.

Valid Context::

declaration

Binding Types Affected::

variable, function

Description::

The ignore and ignorable declarations refer to for-value references to variable bindings for the vars and to function bindings for the fns.

An ignore declaration specifies that for-value references to the indicated bindings will not occur within the scope of the declaration. Within the scope of such a declaration, it is desirable for a compiler to issue a warning about the presence of either a for-value reference to any var or fn, or a special declaration for any var.

An ignorable declaration specifies that for-value references to the indicated bindings might or might not occur within the scope of the declaration. Within the scope of such a declaration, it is not desirable for a compiler to issue a warning about the presence or absence of either a for-value reference to any var or fn, or a special declaration for any var.

When not within the scope of a ignore or ignorable declaration, it is desirable for a compiler to issue a warning about any var for which there is neither a for-value reference nor a special declaration, or about any fn for which there is no for-value reference.

Any warning about a “used” or “unused” binding must be of type style-warning, and may not affect program semantics.

The stream variables established by with-open-file, with-open-stream, with-input-from-string, and with-output-to-string, and all iteration variables are, by definition, always “used”. Using (declare (ignore v)), for such a variable v has unspecified consequences.

See Also::

declare

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Use-of-Quadruple-Semicolon.html0000644000175000017500000000454014360276512020410 0ustar cammcamm Use of Quadruple Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.6 Use of Quadruple Semicolon

Comments that begin with a quadruple semicolon are all aligned to the left margin, and generally contain only a short piece of text that serve as a title for the code which follows, and might be used in the header or footer of a program that prepares code for presentation as a hardcopy document.

gcl-2.6.14/info/gcl/stream_002derror_002dstream.html0000644000175000017500000000603614360276512020421 0ustar cammcamm stream-error-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.56 stream-error-stream [Function]

stream-error-stream condition ⇒ stream

Arguments and Values::

condition—a condition of type stream-error.

stream—a stream.

Description::

Returns the offending stream of a condition of type stream-error.

Examples::

 (with-input-from-string (s "(FOO")
   (handler-case (read s)
     (end-of-file (c)
       (format nil "~&End of file on ~S." (stream-error-stream c)))))
"End of file on #<String Stream>."

See Also::

stream-error, Conditions

gcl-2.6.14/info/gcl/The-Directory-part-of-a-Logical-Pathname-Namestring.html0000644000175000017500000000537114360276512025045 0ustar cammcamm The Directory part of a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.4 The Directory part of a Logical Pathname Namestring

If a relative-directory-marker precedes the directories, the directory component parsed is as relative; otherwise, the directory component is parsed as absolute.

If a wild-inferiors-marker is specified, it parses into :wild-inferiors.

gcl-2.6.14/info/gcl/sxhash.html0000644000175000017500000001413714360276512014665 0ustar cammcamm sxhash (ANSI and GNU Common Lisp Document)

Previous: , Up: Hash Tables Dictionary  

18.2.14 sxhash [Function]

sxhash object ⇒ hash-code

Arguments and Values::

object—an object.

hash-code—a non-negative fixnum.

Description::

sxhash returns a hash code for object.

The manner in which the hash code is computed is implementation-dependent, but subject to certain constraints:

1.

(equal x y) implies (= (sxhash x) (sxhash y)).

2.

For any two objects, x and y, both of which are bit vectors, characters, conses, numbers, pathnames, strings, or symbols, and which are similar, (sxhash x) and (sxhash y) yield the same mathematical value even if x and y exist in different Lisp images of the same implementation. See Literal Objects in Compiled Files.

3.

The hash-code for an object is always the same within a single session provided that the object is not visibly modified with regard to the equivalence test equal. See Modifying Hash Table Keys.

4.

The hash-code is intended for hashing. This places no verifiable constraint on a conforming implementation, but the intent is that an implementation should make a good-faith effort to produce hash-codes that are well distributed within the range of non-negative fixnums.

5.

Computation of the hash-code must terminate, even if the object contains circularities.

Examples::

 (= (sxhash (list 'list "ab")) (sxhash (list 'list "ab"))) ⇒  true
 (= (sxhash "a") (sxhash (make-string 1 :initial-element #\a))) ⇒  true
 (let ((r (make-random-state)))
   (= (sxhash r) (sxhash (make-random-state r))))
⇒  implementation-dependent

Affected By::

The implementation.

Notes::

Many common hashing needs are satisfied by make-hash-table and the related functions on hash tables. sxhash is intended for use where the pre-defined abstractions are insufficient. Its main intent is to allow the user a convenient means of implementing more complicated hashing paradigms than are provided through hash tables.

The hash codes returned by sxhash are not necessarily related to any hashing strategy used by any other function in Common Lisp.

For objects of types that equal compares with eq, item 3 requires that the hash-code be based on some immutable quality of the identity of the object. Another legitimate implementation technique would be to have sxhash assign (and cache) a random hash code for these objects, since there is no requirement that similar but non-eq objects have the same hash code.

Although similarity is defined for symbols in terms of both the symbol’s name and the packages in which the symbol is accessible, item 3 disallows using package information to compute the hash code, since changes to the package status of a symbol are not visible to equal.

Previous: , Up: Hash Tables Dictionary  

gcl-2.6.14/info/gcl/Specifiers-for-_0026aux-variables.html0000644000175000017500000000576214360276512021463 0ustar cammcamm Specifiers for &aux variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.7 Specifiers for &aux variables

These are not really parameters. If the lambda list keyword &aux is present, all specifiers after it are auxiliary variable specifiers. After all parameter specifiers have been processed, the auxiliary variable specifiers (those following &aux) are processed from left to right. For each one, init-form is evaluated and var is bound to that value (or to nil if no init-form was specified). &aux variable processing is analogous to let* processing. 

 (lambda (x y &aux (a (car x)) (b 2) c) (list x y a b c))
    ≡ (lambda (x y) (let* ((a (car x)) (b 2) c) (list x y a b c)))
gcl-2.6.14/info/gcl/Top-level-loop.html0000644000175000017500000000555514360276512016211 0ustar cammcamm Top level loop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The External Environment  

25.1.1 Top level loop

The top level loop is the Common Lisp mechanism by which the user normally interacts with the Common Lisp system. This loop is sometimes referred to as the Lisp read-eval-print loop because it typically consists of an endless loop that reads an expression, evaluates it and prints the results.

The top level loop is not completely specified; thus the user interface is implementation-defined. The top level loop prints all values resulting from the evaluation of a form. Figure 25–1 lists variables that are maintained by the Lisp read-eval-print loop. 

  *    +    /    -  
  **   ++   //      
  ***  +++  ///     

  Figure 25–1: Variables maintained by the Read-Eval-Print Loop
gcl-2.6.14/info/gcl/satisfies.html0000644000175000017500000000673714360276512015370 0ustar cammcamm satisfies (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.17 satisfies [Type Specifier]

Compound Type Specifier Kind::

Predicating.

Compound Type Specifier Syntax::

(satisfies{predicate-name})

Compound Type Specifier Arguments::

predicate-name—a symbol.

Compound Type Specifier Description::

This denotes the set of all objects that satisfy the predicate predicate-name, which must be a symbol whose global function definition is a one-argument predicate. A name is required for predicate-name; lambda expressions are not allowed. For example, the type specifier (and integer (satisfies evenp)) denotes the set of all even integers. The form (typep x '(satisfies p)) is equivalent to (if (p x) t nil).

The argument is required. The symbol * can be the argument, but it denotes itself (the symbol *), and does not represent an unspecified value.

The symbol satisfies is not valid as a type specifier.

gcl-2.6.14/info/gcl/Removed-Types.html0000644000175000017500000000424514360276512016071 0ustar cammcamm Removed Types (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.2 Removed Types

The type string-char was removed.

gcl-2.6.14/info/gcl/restart_002dcase.html0000644000175000017500000003410614360276512016432 0ustar cammcamm restart-case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.37 restart-case [Macro]

restart-case restartable-form {!clause} ⇒ {result}*

clause ::=( case-name lambda-list              [[:interactive interactive-expression | :report report-expression | :test test-expression]]              {declaration}* {form}*)

Arguments and Values::

restartable-form—a form.

case-name—a symbol or nil.

lambda-list—an ordinary lambda list.

interactive-expression—a symbol or a lambda expression.

report-expression—a string, a symbol, or a lambda expression.

test-expression—a symbol or a lambda expression.

declaration—a declare expression; not evaluated.

form—a form.

results—the values resulting from the evaluation of restartable-form, or the values returned by the last form executed in a chosen clause, or nil.

Description::

restart-case evaluates restartable-form in a dynamic environment where the clauses have special meanings as points to which control may be transferred. If restartable-form finishes executing and returns any values, all values returned are returned by restart-case and processing has completed. While restartable-form is executing, any code may transfer control to one of the clauses (see invoke-restart). If a transfer occurs, the forms in the body of that clause is evaluated and any values returned by the last such form are returned by restart-case. In this case, the dynamic state is unwound appropriately (so that the restarts established around the restartable-form are no longer active) prior to execution of the clause.

If there are no forms in a selected clause, restart-case returns nil.

If case-name is a symbol, it names this restart.

It is possible to have more than one clause use the same case-name. In this case, the first clause with that name is found by find-restart. The other clauses are accessible using compute-restarts.

Each arglist is an ordinary lambda list to be bound during the execution of its corresponding forms. These parameters are used by the restart-case clause to receive any necessary data from a call to invoke-restart.

By default, invoke-restart-interactively passes no arguments and all arguments must be optional in order to accomodate interactive restarting. However, the arguments need not be optional if the :interactive keyword has been used to inform invoke-restart-interactively about how to compute a proper argument list.

Keyword options have the following meaning.

:interactive

The value supplied by :interactive value must be a suitable argument to function. (function value) is evaluated in the current lexical environment. It should return a function of no arguments which returns arguments to be used by invoke-restart-interactively when it is invoked. invoke-restart-interactively is called in the dynamic environment available prior to any restart attempt, and uses query I/O for user interaction.

If a restart is invoked interactively but no :interactive option was supplied, the argument list used in the invocation is the empty list.

:report

If the value supplied by :report value is a lambda expression or a symbol, it must be acceptable to function. (function value) is evaluated in the current lexical environment. It should return a function of one argument, a stream, which prints on the stream a description of the restart. This function is called whenever the restart is printed while *print-escape* is nil.

If value is a string, it is a shorthand for 

 (lambda (stream) (write-string value stream))

If a named restart is asked to report but no report information has been supplied, the name of the restart is used in generating default report text.

When *print-escape* is nil, the printer uses the report information for a restart. For example, a debugger might announce the action of typing a “continue” command by: 

 (format t "~&~S -- ~A~

which might then display as something like: 

 :CONTINUE -- Return to command level

The consequences are unspecified if an unnamed restart is specified but no :report option is provided.

:test

The value supplied by :test value must be a suitable argument to function. (function value) is evaluated in the current lexical environment. It should return a function of one argument, the condition, that returns true if the restart is to be considered visible.

The default for this option is equivalent to (lambda (c) (declare (ignore c)) t).

If the restartable-form is a list whose car is any of the symbols signal, error, cerror, or warn (or is a macro form which macroexpands into such a list), then with-condition-restarts is used implicitly to associate the indicated restarts with the condition to be signaled.

Examples::

 (restart-case
     (handler-bind ((error #'(lambda (c)
                             (declare (ignore condition))
                             (invoke-restart 'my-restart 7))))
       (error "Foo."))
   (my-restart (&optional v) v))
⇒  7

 (define-condition food-error (error) ())
⇒  FOOD-ERROR
 (define-condition bad-tasting-sundae (food-error) 
   ((ice-cream :initarg :ice-cream :reader bad-tasting-sundae-ice-cream)
    (sauce :initarg :sauce :reader bad-tasting-sundae-sauce)
    (topping :initarg :topping :reader bad-tasting-sundae-topping))
   (:report (lambda (condition stream)
              (format stream "Bad tasting sundae with ~S, ~S, and ~S"
                      (bad-tasting-sundae-ice-cream condition)
                      (bad-tasting-sundae-sauce condition)
                      (bad-tasting-sundae-topping condition)))))
⇒  BAD-TASTING-SUNDAE
 (defun all-start-with-same-letter (symbol1 symbol2 symbol3)
   (let ((first-letter (char (symbol-name symbol1) 0)))
     (and (eql first-letter (char (symbol-name symbol2) 0))
          (eql first-letter (char (symbol-name symbol3) 0)))))
⇒  ALL-START-WITH-SAME-LETTER
 (defun read-new-value ()
   (format t "Enter a new value: ")
   (multiple-value-list (eval (read))))
⇒  READ-NEW-VALUE

 (defun verify-or-fix-perfect-sundae (ice-cream sauce topping)
   (do ()
      ((all-start-with-same-letter ice-cream sauce topping))
     (restart-case
       (error 'bad-tasting-sundae
              :ice-cream ice-cream
              :sauce sauce
              :topping topping)
       (use-new-ice-cream (new-ice-cream)
         :report "Use a new ice cream."
         :interactive read-new-value  
         (setq ice-cream new-ice-cream))
       (use-new-sauce (new-sauce)
         :report "Use a new sauce."
         :interactive read-new-value
         (setq sauce new-sauce))
       (use-new-topping (new-topping)
         :report "Use a new topping."
         :interactive read-new-value
         (setq topping new-topping))))
   (values ice-cream sauce topping))
⇒  VERIFY-OR-FIX-PERFECT-SUNDAE
 (verify-or-fix-perfect-sundae 'vanilla 'caramel 'cherry)
 |>  Error: Bad tasting sundae with VANILLA, CARAMEL, and CHERRY.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Use a new ice cream.
 |>   2: Use a new sauce.
 |>   3: Use a new topping.
 |>   4: Return to Lisp Toplevel.
 |>  Debug> |>>:continue 1<<|
 |>  Use a new ice cream.
 |>  Enter a new ice cream: |>>'chocolate<<|
⇒  CHOCOLATE, CARAMEL, CHERRY

See Also::

restart-bind , with-simple-restart .

Notes::

 (restart-case expression
    (name1 arglist1 ...options1... . body1)
    (name2 arglist2 ...options2... . body2))

is essentially equivalent to 

 (block #1=#:g0001
   (let ((#2=#:g0002 nil))
        (tagbody
        (restart-bind ((name1 #'(lambda (&rest temp)
                                (setq #2# temp)
                                (go #3=#:g0003))
                          ...slightly-transformed-options1...)
                       (name2 #'(lambda (&rest temp)
                                (setq #2# temp)
                                (go #4=#:g0004))
                          ...slightly-transformed-options2...))
        (return-from #1# expression))
          #3# (return-from #1#
                  (apply #'(lambda arglist1 . body1) #2#))
          #4# (return-from #1#
                  (apply #'(lambda arglist2 . body2) #2#)))))

Unnamed restarts are generally only useful interactively and an interactive option which has no description is of little value. Implementations are encouraged to warn if an unnamed restart is used and no report information is provided at compilation time. At runtime, this error might be noticed when entering the debugger. Since signaling an error would probably cause recursive entry into the debugger (causing yet another recursive error, etc.) it is suggested that the debugger print some indication of such problems when they occur but not actually signal errors. 

 (restart-case (signal fred)
   (a ...)
   (b ...))
 ≡
 (restart-case
     (with-condition-restarts fred 
                              (list (find-restart 'a) 
                                    (find-restart 'b))
       (signal fred))
   (a ...)
   (b ...))

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Inheritance-of-Methods.html0000644000175000017500000000467614360276512017632 0ustar cammcamm Inheritance of Methods (ANSI and GNU Common Lisp Document)

Previous: , Up: Generic Functions and Methods  

7.6.7 Inheritance of Methods

A subclass inherits methods in the sense that any method applicable to all instances of a class is also applicable to all instances of any subclass of that class.

The inheritance of methods acts the same way regardless of which of the method-defining operators created the methods.

The inheritance of methods is described in detail in Method Selection and Combination.

gcl-2.6.14/info/gcl/alpha_002dchar_002dp.html0000644000175000017500000000721714360276512016745 0ustar cammcamm alpha-char-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.8 alpha-char-p [Function]

alpha-char-p character ⇒ generalized-boolean

Arguments and Values::

character—a character.

generalized-boolean—a generalized boolean.

Description::

Returns true if character is an alphabetic_1 character; otherwise, returns false.

Examples::

 (alpha-char-p #\a) ⇒  true
 (alpha-char-p #\5) ⇒  false
 (alpha-char-p #\Newline) ⇒  false
 ;; This next example presupposes an implementation
 ;; in which #\\alpha is a defined character.
 (alpha-char-p #\\alpha) ⇒  implementation-dependent

Affected By::

None. (In particular, the results of this predicate are independent of any special syntax which might have been enabled in the current readtable.)

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

alphanumericp , Documentation of Implementation-Defined Scripts

gcl-2.6.14/info/gcl/Pathname-Components.html0000644000175000017500000000647114360276512017251 0ustar cammcamm Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathnames  

19.2.1 Pathname Components

A pathname has six components: a host, a device, a directory, a name, a type, and a version.

• The Pathname Host Component  
• The Pathname Device Component  
• The Pathname Directory Component  
• The Pathname Name Component  
• The Pathname Type Component  
• The Pathname Version Component  
gcl-2.6.14/info/gcl/Standard-Metaclasses.html0000644000175000017500000000576414360276512017377 0ustar cammcamm Standard Metaclasses (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction to Classes  

4.3.1.1 Standard Metaclasses

The object system provides a number of predefined metaclasses. These include the classes standard-class, built-in-class, and structure-class:

*

The class standard-class is the default class of classes defined by defclass.

*

The class built-in-class is the class whose instances are classes that have special implementations with restricted capabilities. Any class that corresponds to a standard type might be an instance of built-in-class. The predefined type specifiers that are required to have corresponding classes are listed in Figure~4–8. It is implementation-dependent whether each of these classes is implemented as a built-in class.

*

All classes defined by means of defstruct are instances of the class structure-class.

gcl-2.6.14/info/gcl/sqrt.html0000644000175000017500000001202214360276512014347 0ustar cammcamm sqrt (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.38 sqrt, isqrt [Function]

sqrt number ⇒ root

isqrt natural ⇒ natural-root

Arguments and Values::

number, root—a number.

natural, natural-root—a non-negative integer.

Description::

sqrt and isqrt compute square roots.

sqrt returns the principal square root of number. If the number is not a complex but is negative, then the result is a complex.

isqrt returns the greatest integer less than or equal to the exact positive square root of natural.

If number is a positive rational, it is implementation-dependent whether root is a rational or a float. If number is a negative rational, it is implementation-dependent whether root is a complex rational or a complex float.

The mathematical definition of complex square root (whether or not minus zero is supported) follows:

(sqrt x) = (exp (/ (log x) 2))

The branch cut for square root lies along the negative real axis, continuous with quadrant II. The range consists of the right half-plane, including the non-negative imaginary axis and excluding the negative imaginary axis.

Examples::

 (sqrt 9.0) ⇒  3.0
 (sqrt -9.0) ⇒  #C(0.0 3.0)
 (isqrt 9) ⇒  3
 (sqrt 12) ⇒  3.4641016
 (isqrt 12) ⇒  3
 (isqrt 300) ⇒  17
 (isqrt 325) ⇒  18
 (sqrt 25)
⇒  5
OR⇒ 5.0
 (isqrt 25) ⇒  5
 (sqrt -1) ⇒  #C(0.0 1.0)
 (sqrt #c(0 2)) ⇒  #C(1.0 1.0)

Exceptional Situations::

The function sqrt should signal type-error if its argument is not a number.

The function isqrt should signal type-error if its argument is not a non-negative integer.

The functions sqrt and isqrt might signal arithmetic-error.

See Also::

exp , log , Rule of Float Substitutability

Notes::

 (isqrt x) ≡ (values (floor (sqrt x)))

but it is potentially more efficient.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Syntax_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000617714360276512030542 0ustar cammcamm The "Compound Type Specifier Syntax" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.8 The "Compound Type Specifier Syntax" Section of a Dictionary Entry

This information about a type describes the syntax of a compound type specifier for that type.

Whether or not the type is acceptable as an atomic type specifier is not represented here; see Dictionary Entries for Type Specifiers.

gcl-2.6.14/info/gcl/undefined_002dfunction.html0000644000175000017500000000534314360276512017622 0ustar cammcamm undefined-function (ANSI and GNU Common Lisp Document)

Previous: , Up: Data and Control Flow Dictionary  

5.3.69 undefined-function [Condition Type]

Class Precedence List::

undefined-function, cell-error, error, serious-condition, condition, t

Description::

The type undefined-function consists of error conditions that represent attempts to read the definition of an undefined function.

The name of the cell (see cell-error) is the function name which was funbound.

See Also::

cell-error-name

gcl-2.6.14/info/gcl/Sharpsign-Minus.html0000644000175000017500000000442614360276512016416 0ustar cammcamm Sharpsign Minus (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.19 Sharpsign Minus

#- is like #+ except that it skips the expression if the test succeeds; that is, 

#-test expression ≡ #+(not test) expression

For examples, see Examples of Feature Expressions.

gcl-2.6.14/info/gcl/Examples-of-Miscellaneous-Loop-Features.html0000644000175000017500000000646514360276512023040 0ustar cammcamm Examples of Miscellaneous Loop Features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.8 Examples of Miscellaneous Loop Features

 (let ((i 0))                     ; no loop keywords are used
    (loop (incf i) (if (= i 3) (return i)))) ⇒  3
 (let ((i 0)(j 0))
    (tagbody
      (loop (incf j 3) (incf i) (if (= i 3) (go exit)))
      exit)
    j) ⇒  9

In the following example, the variable x is stepped before y is stepped; thus, the value of y reflects the updated value of x: 

 (loop for x from 1 to 10 
       for y = nil then x 
       collect (list x y))
⇒  ((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10))

In this example, x and y are stepped in parallel: 

 (loop for x from 1 to 10 
       and y = nil then x 
       collect (list x y))
⇒  ((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9))
• Examples of clause grouping  
gcl-2.6.14/info/gcl/Notational-Conventions.html0000644000175000017500000001070214360276512017774 0ustar cammcamm Notational Conventions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Definitions  

1.4.1 Notational Conventions

The following notational conventions are used throughout this document.

• Font Key  
• Modified BNF Syntax  
• Splicing in Modified BNF Syntax  
• Indirection in Modified BNF Syntax  
• Additional Uses for Indirect Definitions in Modified BNF Syntax  
• Special Symbols  
• Objects with Multiple Notations  
• Case in Symbols  
• Numbers (Objects with Multiple Notations)  
• Use of the Dot Character  
• NIL  
• Designators  
• Nonsense Words  
gcl-2.6.14/info/gcl/Examples-of-Whitespace-Characters.html0000644000175000017500000000426714360276512021721 0ustar cammcamm Examples of Whitespace Characters (ANSI and GNU Common Lisp Document)

Previous: , Up: Character Syntax Types  

2.1.4.10 Examples of Whitespace Characters

 (length '(this-that)) ⇒  1
 (length '(this - that)) ⇒  3
 (length '(a
           b)) ⇒  2
 (+ 34) ⇒  34
 (+ 3 4) ⇒  7
gcl-2.6.14/info/gcl/style_002dwarning.html0000644000175000017500000000670314360276512016642 0ustar cammcamm style-warning (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.3 style-warning [Condition Type]

Class Precedence List::

style-warning, warning, condition, t

Description::

The type style-warning includes those conditions that represent situations involving code that is conforming code but that is nevertheless considered to be faulty or substandard.

See Also::

muffle-warning

Notes::

An implementation might signal such a condition if it encounters code that uses deprecated features or that appears unaesthetic or inefficient.

An ‘unused variable’ warning must be of type style-warning.

In general, the question of whether code is faulty or substandard is a subjective decision to be made by the facility processing that code. The intent is that whenever such a facility wishes to complain about code on such subjective grounds, it should use this condition type so that any clients who wish to redirect or muffle superfluous warnings can do so without risking that they will be redirecting or muffling other, more serious warnings.

gcl-2.6.14/info/gcl/with_002doutput_002dto_002dstring.html0000644000175000017500000001432614360276512021414 0ustar cammcamm with-output-to-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.52 with-output-to-string [Macro]

with-output-to-string (var &optional string-form &key element-type) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

var—a variable name.

string-form—a form or nil; if non-nil, evaluated to produce string.

string—a string that has a fill pointer.

element-type—a type specifier; evaluated.

The default is character.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—If a string-form is not supplied or nil, a string; otherwise, the values returned by the forms.

Description::

with-output-to-string creates a

character output stream, performs a series of operations that may send results to this stream, and then closes the stream.

The element-type names the type of the elements of the stream; a stream is constructed of the most specialized type that can accommodate elements of the given type.

The body is executed as an implicit progn with var bound to an output string stream. All output to that string stream is saved in a string.

If string is supplied, element-type is ignored, and the output is incrementally appended to string as if by use of vector-push-extend.

The output stream is automatically closed on exit from with-output-from-string, no matter whether the exit is normal or abnormal.

The output string stream to which the variable var is bound has dynamic extent; its extent ends when the form is exited.

If no string is provided, then with-output-from-string

produces a stream that accepts characters and returns a string of the indicated element-type.

If string is provided, with-output-to-string returns the results of evaluating the last form.

The consequences are undefined if an attempt is made to assign the variable var.

Examples::

 (setq fstr (make-array '(0) :element-type 'base-char
                             :fill-pointer 0 :adjustable t)) ⇒  ""
 (with-output-to-string (s fstr)
    (format s "here's some output")
    (input-stream-p s)) ⇒  false
 fstr ⇒  "here's some output"

Side Effects::

The string is modified.

Exceptional Situations::

The consequences are undefined if destructive modifications are performed directly on the string during the dynamic extent of the call.

See Also::

make-string-output-stream , vector-push-extend,

Traversal Rules and Side Effects

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/Implementation-Limits-on-Individual-Array-Dimensions.html0000644000175000017500000000445614360276512025500 0ustar cammcamm Implementation Limits on Individual Array Dimensions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.3 Implementation Limits on Individual Array Dimensions

An implementation may impose a limit on dimensions of an array, but there is a minimum requirement on that limit. See the variable array-dimension-limit.

gcl-2.6.14/info/gcl/Errors-When-Calling-a-Next-Method.html0000644000175000017500000000563514360276512021464 0ustar cammcamm Errors When Calling a Next Method (ANSI and GNU Common Lisp Document)

Previous: , Up: Argument Mismatch Detection  

3.5.1.9 Errors When Calling a Next Method

If call-next-method is called with arguments, the ordered set of applicable methods for the changed set of arguments for call-next-method must be the same as the ordered set of applicable methods for the original arguments to the generic function, or else an error should be signaled.

The comparison between the set of methods applicable to the new arguments and the set applicable to the original arguments is insensitive to order differences among methods with the same specializers.

If call-next-method is called with arguments that specify a different ordered set of applicable methods and there is no next method available, the test for different methods and the associated error signaling (when present) takes precedence over calling no-next-method.

gcl-2.6.14/info/gcl/vector_002dpop.html0000644000175000017500000000741014360276512016131 0ustar cammcamm vector-pop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.30 vector-pop [Function]

vector-pop vector ⇒ element

Arguments and Values::

vector—a vector with a fill pointer.

element—an object.

Description::

Decreases the fill pointer of vector by one, and retrieves the element of vector that is designated by the new fill pointer.

Examples::

 (vector-push (setq fable (list 'fable))
              (setq fa (make-array 8
                                   :fill-pointer 2
                                   :initial-element 'sisyphus))) ⇒  2 
 (fill-pointer fa) ⇒  3 
 (eq (vector-pop fa) fable) ⇒  true
 (vector-pop fa) ⇒  SISYPHUS 
 (fill-pointer fa) ⇒  1

Side Effects::

The fill pointer is decreased by one.

Affected By::

The value of the fill pointer.

Exceptional Situations::

An error of type type-error is signaled if vector does not have a fill pointer.

If the fill pointer is zero, vector-pop signals an error of type error.

See Also::

vector-push , vector-push-extend, fill-pointer

gcl-2.6.14/info/gcl/Initializing-Newly-Added-Local-Slots-_0028Redefining-Classes_0029.html0000644000175000017500000001016614360276512027032 0ustar cammcamm Initializing Newly Added Local Slots (Redefining Classes) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Redefining Classes  

4.3.6.2 Initializing Newly Added Local Slots

The second step initializes the newly added local slots and performs any other user-defined actions. This step is implemented by the generic function update-instance-for-redefined-class, which is called after completion of the first step of modifying the structure of the instance.

The generic function update-instance-for-redefined-class takes four required arguments: the instance being updated after it has undergone the first step, a list of the names of local slots that were added, a list of the names of local slots that were discarded, and a property list containing the slot names and values of slots that were discarded and had values. Included among the discarded slots are slots that were local in the old class and that are shared in the new class.

The generic function update-instance-for-redefined-class also takes any number of initialization arguments. When it is called by the system to update an instance whose class has been redefined, no initialization arguments are provided.

There is a system-supplied primary method for update-instance-for-redefined-class whose parameter specializer for its instance argument is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see Declaring the Validity of Initialization Arguments.) Then it calls the generic function shared-initialize with the following arguments: the instance, the list of names of the newly added slots, and the initialization arguments it received.

gcl-2.6.14/info/gcl/Character-Encodings.html0000644000175000017500000000553714360276512017176 0ustar cammcamm Character Encodings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.9 Character Encodings

A character is sometimes represented merely by its code, and sometimes by another integer value which is composed from the code and all implementation-defined attributes (in an implementation-defined way that might vary between Lisp images even in the same implementation). This integer, returned by the function char-int, is called the character’s “encoding.” There is no corresponding function from a character’s encoding back to the character, since its primary intended uses include things like hashing where an inverse operation is not really called for.

gcl-2.6.14/info/gcl/Notes-about-Loop.html0000644000175000017500000000576014360276512016500 0ustar cammcamm Notes about Loop (ANSI and GNU Common Lisp Document)

Previous: , Up: The LOOP Facility  

6.1.9 Notes about Loop

Types can be supplied for loop variables. It is not necessary to supply a type for any variable, but supplying the type can ensure that the variable has a correctly typed initial value, and it can also enable compiler optimizations (depending on the implementation).

The clause repeat n ... is roughly equivalent to a clause such as 

 (loop for internal-variable downfrom (- n 1) to 0 ...)

but in some implementations, the repeat construct might be more efficient.

Within the executable parts of the loop clauses and around the entire loop form, variables can be bound by using let.

Use caution when using a variable named IT (in any package) in connection with loop, since it is a loop keyword that can be used in place of a form in certain contexts.

There is

no

standardized mechanism for users to add extensions to loop.

gcl-2.6.14/info/gcl/write_002dsequence.html0000644000175000017500000001063214360276512016773 0ustar cammcamm write-sequence (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.25 write-sequence [Function]

write-sequence sequence stream &key start end ⇒ sequence

sequence—a sequence.

stream—an output stream.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

Description::

write-sequence writes the elements of the subsequence of sequence bounded by start and end to stream.

Examples::

 (write-sequence "bookworms" *standard-output* :end 4)
  |>  book
 ⇒  "bookworms"

Side Effects::

Modifies stream.

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil.

Might signal an error of type type-error if an element of the bounded sequence is not a member of the stream element type of the stream.

See Also::

Compiler Terminology, read-sequence , write-string , write-line

Notes::

write-sequence is identical in effect to iterating over the indicated subsequence and writing one element at a time to stream, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the sequence is a vector with the same element type as the stream.

gcl-2.6.14/info/gcl/General-Restrictions-on-Parameters-that-must-be-Lists.html0000644000175000017500000000506214360276512025546 0ustar cammcamm General Restrictions on Parameters that must be Lists (ANSI and GNU Common Lisp Document)

Previous: , Up: Conses as Lists  

14.1.2.3 General Restrictions on Parameters that must be Lists

Except as explicitly specified otherwise, any standardized function that takes a parameter that is required to be a list should be prepared to signal an error of type type-error if the value received is a dotted list.

Except as explicitly specified otherwise, for any standardized function that takes a parameter that is required to be a list, the consequences are undefined if that list is circular.

gcl-2.6.14/info/gcl/Lexical-Environments.html0000644000175000017500000000705414360276512017435 0ustar cammcamm Lexical Environments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Environments  

3.1.1.3 Lexical Environments

A lexical environment for evaluation at some position in a program is that part of the environment that contains information having lexical scope within the forms containing that position. A lexical environment contains, among other things, the following:

*

bindings of lexical variables and symbol macros.

*

bindings of functions and macros. (Implicit in this is information about those compiler macros that are locally disabled.)

*

bindings of block tags.

*

bindings of go tags.

*

information about declarations.

The lexical environment that is active at any given position in a program being semantically processed is referred to by definite reference as “the current lexical environment,” or sometimes as just “the lexical environment.”

Within a given namespace, a name is said to be bound in a lexical environment if there is a binding associated with its name in the lexical environment or, if not, there is a binding associated with its name in the global environment.

gcl-2.6.14/info/gcl/documentation.html0000644000175000017500000002574314360276512016245 0ustar cammcamm documentation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.15 documentation, (setf documentation) [Standard Generic Function]

Syntax::

documentation x doc-type ⇒ documentation

(setf documentation) new-value x doc-type ⇒ new-value

Argument Precedence Order::

doc-type, object

Method Signatures::

Functions, Macros, and Special Forms

documentation (x function) (doc-type (eql ’t))
(setf documentation) new-value(x function) (doc-type (eql ’t))

documentation (x function) (doc-type (eql ’function))
(setf documentation) new-value(x function) (doc-type (eql ’function))

documentation (x list) (doc-type (eql ’function))
(setf documentation) new-value(x list) (doc-type (eql ’function))

documentation (x list) (doc-type (eql ’compiler-macro))
(setf documentation) new-value(x list) (doc-type (eql ’compiler-macro))

documentation (x symbol) (doc-type (eql ’function))
(setf documentation) new-value(x symbol) (doc-type (eql ’function))

documentation (x symbol) (doc-type (eql ’compiler-macro))
(setf documentation) new-value(x symbol) (doc-type (eql ’compiler-macro))

documentation (x symbol) (doc-type (eql ’setf))
(setf documentation) new-value(x symbol) (doc-type (eql ’setf))

Method Combinations

documentation (x method-combination) (doc-type (eql ’t))
(setf documentation) new-value(x method-combination) (doc-type (eql ’t))

documentation (x method-combination) (doc-type (eql ’method-combination))
(setf documentation) new-value(x method-combination) (doc-type (eql ’method-combination))

documentation (x symbol) (doc-type (eql ’method-combination))
(setf documentation) new-value(x symbol) (doc-type (eql ’method-combination))

Methods

documentation (x standard-method) (doc-type (eql ’t))
(setf documentation) new-value(x standard-method) (doc-type (eql ’t))

Packages

documentation (x package) (doc-type (eql ’t))
(setf documentation) new-value(x package) (doc-type (eql ’t))

Types, Classes, and Structure Names

documentation (x standard-class) (doc-type (eql ’t))
(setf documentation) new-value(x standard-class) (doc-type (eql ’t))

documentation (x standard-class) (doc-type (eql ’type))
(setf documentation) new-value(x standard-class) (doc-type (eql ’type))

documentation (x structure-class) (doc-type (eql ’t))
(setf documentation) new-value(x structure-class) (doc-type (eql ’t))

documentation (x structure-class) (doc-type (eql ’type))
(setf documentation) new-value(x structure-class) (doc-type (eql ’type))

documentation (x symbol) (doc-type (eql ’type))
(setf documentation) new-value(x symbol) (doc-type (eql ’type))

documentation (x symbol) (doc-type (eql ’structure))
(setf documentation) new-value(x symbol) (doc-type (eql ’structure))

Variables

documentation (x symbol) (doc-type (eql ’variable))
(setf documentation) new-value(x symbol) (doc-type (eql ’variable))

Arguments and Values::

x—an object.

doc-type—a symbol.

documentation—a string, or nil.

new-value—a string.

Description::

The generic function documentation returns the documentation string associated with the given object if it is available; otherwise it returns nil.

The generic function (setf documentation) updates the documentation string associated with x to new-value. If x is a list, it must be of the form (setf symbol).

Documentation strings are made available for debugging purposes. Conforming programs are permitted to use documentation strings when they are present, but should not depend for their correct behavior on the presence of those documentation strings. An implementation is permitted to discard documentation strings at any time for implementation-defined reasons.

The nature of the documentation string returned depends on the doc-type, as follows:

compiler-macro

Returns the documentation string of the compiler macro whose name is the function name x.

function

If x is a function name, returns the documentation string of the function, macro, or special operator whose name is x.

If x is a function, returns the documentation string associated with x.

method-combination

If x is a symbol, returns the documentation string of the method combination whose name is x.

If x is a method combination, returns the documentation string associated with x.

setf

Returns the documentation string of

the setf expander

whose name is the symbol x.

structure

Returns the documentation string associated with the structure name x.

t

Returns a documentation string specialized on the class of the argument x itself. For example, if x is a function, the documentation string associated with the function x is returned.

type

If x is a symbol, returns the documentation string of the class whose name is the symbol x, if there is such a class. Otherwise, it returns the documentation string of the type which is the type specifier symbol x.

If x is a structure class or standard class, returns the documentation string associated with the class x.

variable

Returns the documentation string of the dynamic variable or constant variable whose name is the symbol x.

A conforming implementation or a conforming program may extend the set of symbols that are acceptable as the doc-type.

Notes::

This standard prescribes no means to retrieve the documentation strings for individual slots specified in a defclass form, but implementations might still provide debugging tools and/or programming language extensions which manipulate this information. Implementors wishing to provide such support are encouraged to consult the Metaobject Protocol for suggestions about how this might be done.

Next: , Previous: , Up: Environment Dictionary  

gcl-2.6.14/info/gcl/array_002drank_002dlimit.html0000644000175000017500000000521614360276512017670 0ustar cammcamm array-rank-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.25 array-rank-limit [Constant Variable]

Constant Value::

A positive

fixnum,

the exact magnitude of which is implementation-dependent, but which is not less than 8.

Description::

The upper exclusive bound on the rank of an array.

See Also::

make-array

gcl-2.6.14/info/gcl/multiple_002dvalue_002dlist.html0000644000175000017500000000655314360276512020430 0ustar cammcamm multiple-value-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.50 multiple-value-list [Macro]

multiple-value-list form ⇒ list

Arguments and Values::

form—a form; evaluated as described below.

list—a list of the values returned by form.

Description::

multiple-value-list evaluates form and creates a list of the multiple values_2 it returns.

Examples::

 (multiple-value-list (floor -3 4)) ⇒  (-1 1)

See Also::

values-list , multiple-value-call

Notes::

multiple-value-list and values-list are inverses of each other. 

 (multiple-value-list form) ≡ (multiple-value-call #'list form)
gcl-2.6.14/info/gcl/Note-about-Printing-Numbers.html0000644000175000017500000000440714360276512020604 0ustar cammcamm Note about Printing Numbers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.6 Note about Printing Numbers

The printed representation of a number must not contain escape characters; see Escape Characters and Potential Numbers.

gcl-2.6.14/info/gcl/Tilde-Underscore_002d_003e-Conditional-Newline.html0000644000175000017500000000513014360276512023644 0ustar cammcamm Tilde Underscore-> Conditional Newline (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Pretty Printer Operations  

22.3.5.1 Tilde Underscore: Conditional Newline

Without any modifiers, ~_ is the same as (pprint-newline :linear). ~@_ is the same as (pprint-newline :miser). ~:_ is the same as (pprint-newline :fill). ~:@_ is the same as (pprint-newline :mandatory).

gcl-2.6.14/info/gcl/History.html0000644000175000017500000002745314360276512015035 0ustar cammcamm History (ANSI and GNU Common Lisp Document)

Previous: , Up: Scope  

1.1.2 History

Lisp is a family of languages with a long history. Early key ideas in Lisp were developed by John McCarthy during the 1956 Dartmouth Summer Research Project on Artificial Intelligence. McCarthy’s motivation was to develop an algebraic list processing language for artificial intelligence work. Implementation efforts for early dialects of Lisp were undertaken on the IBM~704, the IBM~7090, the Digital Equipment Corporation (DEC) PDP-1, the DEC~PDP-6, and the PDP-10. The primary dialect of Lisp between 1960 and 1965 was Lisp~1.5. By the early 1970’s there were two predominant dialects of Lisp, both arising from these early efforts: MacLisp and Interlisp. For further information about very early Lisp dialects, see The Anatomy of Lisp or Lisp 1.5 Programmer’s Manual.

MacLisp improved on the Lisp~1.5 notion of special variables and error handling. MacLisp also introduced the concept of functions that could take a variable number of arguments, macros, arrays, non-local dynamic exits, fast arithmetic, the first good Lisp compiler, and an emphasis on execution speed. By the end of the 1970’s, MacLisp was in use at over 50 sites. For further information about Maclisp, see Maclisp Reference Manual, Revision~0 or The Revised Maclisp Manual.

Interlisp introduced many ideas into Lisp programming environments and methodology. One of the Interlisp ideas that influenced Common Lisp was an iteration construct implemented by Warren Teitelman that inspired the loop macro used both on the Lisp Machines and in MacLisp, and now in Common Lisp. For further information about Interlisp, see Interlisp Reference Manual.

Although the first implementations of Lisp were on the IBM~704 and the IBM~7090, later work focussed on the DEC PDP-6 and, later, PDP-10 computers, the latter being the mainstay of Lisp and artificial intelligence work at such places as Massachusetts Institute of Technology (MIT), Stanford University, and Carnegie Mellon University (CMU) from the mid-1960’s through much of the 1970’s. The PDP-10 computer and its predecessor the PDP-6 computer were, by design, especially well-suited to Lisp because they had 36-bit words and 18-bit addresses. This architecture allowed a cons cell to be stored in one word; single instructions could extract the car and cdr parts. The PDP-6 and PDP-10 had fast, powerful stack instructions that enabled fast function calling. But the limitations of the PDP-10 were evident by 1973: it supported a small number of researchers using Lisp, and the small, 18-bit address space (2^18 = 262,144 words) limited the size of a single program. One response to the address space problem was the Lisp Machine, a special-purpose computer designed to run Lisp programs. The other response was to use general-purpose computers with address spaces larger than 18~bits, such as the DEC VAX and the S-1~Mark~IIA. For further information about S-1 Common Lisp, see S-1 Common Lisp Implementation.

The Lisp machine concept was developed in the late 1960’s. In the early 1970’s, Peter Deutsch, working with Daniel Bobrow, implemented a Lisp on the Alto, a single-user minicomputer, using microcode to interpret a byte-code implementation language. Shortly thereafter, Richard Greenblatt began work on a different hardware and instruction set design at MIT. Although the Alto was not a total success as a Lisp machine, a dialect of Interlisp known as Interlisp-D became available on the D-series machines manufactured by Xerox—the Dorado, Dandelion, Dandetiger, and Dove (or Daybreak). An upward-compatible extension of MacLisp called Lisp Machine Lisp became available on the early MIT Lisp Machines. Commercial Lisp machines from Xerox, Lisp Machines (LMI), and Symbolics were on the market by 1981. For further information about Lisp Machine Lisp, see Lisp Machine Manual.

During the late 1970’s, Lisp Machine Lisp began to expand towards a much fuller language. Sophisticated lambda lists, setf, multiple values, and structures like those in Common Lisp are the results of early experimentation with programming styles by the Lisp Machine group. Jonl White and others migrated these features to MacLisp. Around 1980, Scott Fahlman and others at CMU began work on a Lisp to run on the Scientific Personal Integrated Computing Environment (SPICE) workstation. One of the goals of the project was to design a simpler dialect than Lisp Machine Lisp.

The Macsyma group at MIT began a project during the late 1970’s called the New Implementation of Lisp (NIL) for the VAX, which was headed by White. One of the stated goals of the NIL project was to fix many of the historic, but annoying, problems with Lisp while retaining significant compatibility with MacLisp. At about the same time, a research group at Stanford University and Lawrence Livermore National Laboratory headed by Richard P. Gabriel began the design of a Lisp to run on the S-1~Mark~IIA supercomputer. S-1~Lisp, never completely functional, was the test bed for adapting advanced compiler techniques to Lisp implementation. Eventually the S-1 and NIL groups collaborated. For further information about the NIL project, see NIL—A Perspective.

The first effort towards Lisp standardization was made in 1969, when Anthony Hearn and Martin Griss at the University of Utah defined Standard Lisp—a subset of Lisp~1.5 and other dialects—to transport REDUCE, a symbolic algebra system. During the 1970’s, the Utah group implemented first a retargetable optimizing compiler for Standard Lisp, and then an extended implementation known as Portable Standard Lisp (PSL). By the mid 1980’s, PSL ran on about a dozen kinds of computers. For further information about Standard Lisp, see Standard LISP Report.

PSL and Franz Lisp—a MacLisp-like dialect for Unix machines—were the first examples of widely available Lisp dialects on multiple hardware platforms.

One of the most important developments in Lisp occurred during the second half of the 1970’s: Scheme. Scheme, designed by Gerald J. Sussman and Guy L. Steele Jr., is a simple dialect of Lisp whose design brought to Lisp some of the ideas from programming language semantics developed in the 1960’s. Sussman was one of the prime innovators behind many other advances in Lisp technology from the late 1960’s through the 1970’s. The major contributions of Scheme were lexical scoping, lexical closures, first-class continuations, and simplified syntax (no separation of value cells and function cells). Some of these contributions made a large impact on the design of Common Lisp. For further information about Scheme, see IEEE Standard for the Scheme Programming Language or Revised^3 Report on the Algorithmic Language Scheme.

In the late 1970’s object-oriented programming concepts started to make a strong impact on Lisp. At MIT, certain ideas from Smalltalk made their way into several widely used programming systems. Flavors, an object-oriented programming system with multiple inheritance, was developed at MIT for the Lisp machine community by Howard Cannon and others. At Xerox, the experience with Smalltalk and Knowledge Representation Language (KRL) led to the development of Lisp Object Oriented Programming System (LOOPS) and later Common LOOPS. For further information on Smalltalk, see Smalltalk-80: The Language and its Implementation. For further information on Flavors, see Flavors: A Non-Hierarchical Approach to Object-Oriented Programming.

These systems influenced the design of the Common Lisp Object System (CLOS). CLOS was developed specifically for this standardization effort, and was separately written up in Common Lisp Object System Specification. However, minor details of its design have changed slightly since that publication, and that paper should not be taken as an authoritative reference to the semantics of the object system as described in this document.

In 1980 Symbolics and LMI were developing Lisp Machine Lisp; stock-hardware implementation groups were developing NIL, Franz Lisp, and PSL; Xerox was developing Interlisp; and the SPICE project at CMU was developing a MacLisp-like dialect of Lisp called SpiceLisp.

In April 1981, after a DARPA-sponsored meeting concerning the splintered Lisp community, Symbolics, the SPICE project, the NIL project, and the S-1~Lisp project joined together to define Common Lisp. Initially spearheaded by White and Gabriel, the driving force behind this grassroots effort was provided by Fahlman, Daniel Weinreb, David Moon, Steele, and Gabriel. Common Lisp was designed as a description of a family of languages. The primary influences on Common Lisp were Lisp Machine Lisp, MacLisp, NIL, S-1~Lisp, Spice Lisp, and Scheme. Common Lisp: The Language is a description of that design. Its semantics were intentionally underspecified in places where it was felt that a tight specification would overly constrain Common Lisp research and use.

In 1986 X3J13 was formed as a technical working group to produce a draft for an ANSI Common Lisp standard. Because of the acceptance of Common Lisp, the goals of this group differed from those of the original designers. These new goals included stricter standardization for portability, an object-oriented programming system, a condition system, iteration facilities, and a way to handle large character sets. To accommodate those goals, a new language specification, this document, was developed.

Previous: , Up: Scope  

gcl-2.6.14/info/gcl/type_002dof.html0000644000175000017500000001441214360276512015416 0ustar cammcamm type-of (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.27 type-of [Function]

type-of object ⇒ typespec

Arguments and Values::

object—an object.

typespec—a type specifier.

Description::

Returns a type specifier, typespec, for a type that has the object as an element. The typespec satisfies the following:

1.

For any object that is an element of some built-in type:

a.

the type returned is a recognizable subtype of that built-in type.

b.

the type returned does not involve and, eql, member, not, or, satisfies, or values.

2.

For all objects, (typep object (type-of object)) returns true. Implicit in this is that type specifiers which are not valid for use with typep, such as the list form of the function type specifier, are never returned by type-of.

3.

The type returned by type-of is always a recognizable subtype of the class returned by class-of. That is, 

 (subtypep (type-of object) (class-of object)) ⇒  true, true
4.

For objects of metaclass structure-class or standard-class,

and for conditions,

type-of returns the proper name of the class returned by class-of if it has a proper name, and otherwise returns the class itself. In particular, for objects created by the constructor function of a structure defined with defstruct without a :type option, type-of returns the structure name; and for objects created by make-condition, the typespec is the name of the condition type.

5.

For each of the types short-float, single-float, double-float, or long-float of which the object is an element, the typespec is a recognizable subtype of that type.

Examples::

 (type-of 'a) ⇒  SYMBOL          
 (type-of '(1 . 2))
⇒  CONS
OR⇒ (CONS FIXNUM FIXNUM)
 (type-of #c(0 1))
⇒  COMPLEX
OR⇒ (COMPLEX INTEGER)
 (defstruct temp-struct x y z) ⇒  TEMP-STRUCT
 (type-of (make-temp-struct)) ⇒  TEMP-STRUCT
 (type-of "abc")
⇒  STRING
OR⇒ (STRING 3)
 (subtypep (type-of "abc") 'string) ⇒  true, true
 (type-of (expt 2 40))
⇒  BIGNUM
OR⇒ INTEGER
OR⇒ (INTEGER 1099511627776 1099511627776)
OR⇒ SYSTEM::TWO-WORD-BIGNUM
OR⇒ FIXNUM
 (subtypep (type-of 112312) 'integer) ⇒  true, true
 (defvar *foo* (make-array 5 :element-type t)) ⇒  *FOO*
 (class-name (class-of *foo*)) ⇒  VECTOR
 (type-of *foo*)
⇒  VECTOR
OR⇒ (VECTOR T 5)

See Also::

array-element-type , class-of , defstruct , typecase , typep , Types

Notes::

Implementors are encouraged to arrange for type-of to return

a portable value.

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/Tilde-Circumflex_002d_003e-Escape-Upward.html0000644000175000017500000001571414360276512022443 0ustar cammcamm Tilde Circumflex-> Escape Upward (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Miscellaneous Pseudo-Operations  

22.3.9.2 Tilde Circumflex: Escape Upward

~^

This is an escape construct. If there are no more arguments remaining to be processed, then the immediately enclosing ~{ or ~< construct is terminated. If there is no such enclosing construct, then the entire formatting operation is terminated. In the ~< case, the formatting is performed, but no more segments are processed before doing the justification. ~^ may appear anywhere in a ~{ construct. 

 (setq donestr "Done.~^ ~D warning~:P.~^ ~D error~:P.")
⇒  "Done.~^ ~D warning~:P.~^ ~D error~:P."
 (format nil donestr) ⇒  "Done."
 (format nil donestr 3) ⇒  "Done. 3 warnings."
 (format nil donestr 1 5) ⇒  "Done. 1 warning. 5 errors."

If a prefix parameter is given, then termination occurs if the parameter is zero. (Hence ~^ is equivalent to ~#^.) If two parameters are given, termination occurs if they are equal.

[Reviewer Note by Barmar: Which equality predicate?] If three parameters are given, termination occurs if the first is less than or equal to the second and the second is less than or equal to the third. Of course, this is useless if all the prefix parameters are constants; at least one of them should be a # or a V parameter.

If ~^ is used within a ~:{ construct, then it terminates the current iteration step because in the standard case it tests for remaining arguments of the current step only; the next iteration step commences immediately. ~:^ is used to terminate the iteration process.

~:^ may be used only if the command it would terminate is ~:{ or ~:@{ . The entire iteration process is terminated if and only if the sublist that is supplying the arguments for the current iteration step is the last sublist in the case of ~:{ , or the last format argument in the case of ~:@{ . ~:^ is not equivalent to ~#:^; the latter terminates the entire iteration if and only if no arguments remain for the current iteration step. For example: 

 (format nil "~:{ ~@?~:^ ...~} " '(("a") ("b"))) ⇒  "a...b"

If ~^ appears within a control string being processed under the control of a ~? directive, but not within any ~{ or ~< construct within that string, then the string being processed will be terminated, thereby ending processing of the ~? directive. Processing then continues within the string containing the ~? directive at the point following that directive.

If ~^ appears within a ~[ or ~( construct, then all the commands up to the ~^ are properly selected or case-converted, the ~[ or ~( processing is terminated, and the outward search continues for a ~{ or ~< construct to be terminated. For example: 

 (setq tellstr "~@(~@[~R~]~^ ~A!~)")
⇒  "~@(~@[~R~]~^ ~A!~)"
 (format nil tellstr 23) ⇒  "Twenty-three!"
 (format nil tellstr nil "losers") ⇒  " Losers!"
 (format nil tellstr 23 "losers") ⇒  "Twenty-three losers!"

Following are examples of the use of ~^ within a ~< construct. 

 (format nil "~15<~S~;~^~S~;~^~S~>" 'foo)
⇒   "            FOO"
 (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar)
⇒   "FOO         BAR"
 (format nil "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz)
⇒   "FOO   BAR   BAZ"

Next: , Previous: , Up: FORMAT Miscellaneous Pseudo-Operations  

gcl-2.6.14/info/gcl/write.html0000644000175000017500000002112714360276512014516 0ustar cammcamm write (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.14 write, prin1, print, pprint, princ [Function]

write object &key \writekeysstream
⇒ object

prin 1 ⇒ object &optional output-stream object princ object &optional output-stream ⇒ object

print object &optional output-stream ⇒ object

pprint object &optional output-stream ⇒ <no values>

Arguments and Values::

object—an object.

output-stream—an output stream designator. The default is standard output.

\writekeydescriptionsstream—an output stream designator. The default is standard output.

Description::

write, prin1, princ, print, and pprint write the printed representation of object to output-stream.

write is the general entry point to the Lisp printer. For each explicitly supplied keyword parameter named in Figure 22–6, the corresponding printer control variable is dynamically bound to its value while printing goes on; for each keyword parameter in Figure 22–6 that is not explicitly supplied, the value of the corresponding printer control variable is the same as it was at the time write was invoked. Once the appropriate bindings are established, the object is output by the Lisp printer. 

  Parameter        Corresponding Dynamic Variable  
  array            *print-array*                   
  base             *print-base*                    
  case             *print-case*                    
  circle           *print-circle*                  
  escape           *print-escape*                  
  gensym           *print-gensym*                  
  length           *print-length*                  
  level            *print-level*                   
  lines            *print-lines*                   
  miser-width      *print-miser-width*             
  pprint-dispatch  *print-pprint-dispatch*         
  pretty           *print-pretty*                  
  radix            *print-radix*                   
  readably         *print-readably*                
  right-margin     *print-right-margin*            

  Figure 22–6: Argument correspondences for the WRITE function.

prin1, princ, print, and pprint implicitly bind certain print parameters to particular values. The remaining parameter values are taken from *print-array*, *print-base*, *print-case*, *print-circle*, *print-escape*, *print-gensym*, *print-length*, *print-level*, *print-lines*, *print-miser-width*, *print-pprint-dispatch*, *print-pretty*, *print-radix*, and *print-right-margin*.

prin1 produces output suitable for input to read. It binds *print-escape* to true.

princ is just like prin1 except that the output has no escape characters. It binds *print-escape* to false

and *print-readably* to false.

The general rule is that output from princ is intended to look good to people, while output from prin1 is intended to be acceptable to read.

print is just like prin1 except that the printed representation of object is preceded by a newline and followed by a space.

pprint is just like print except that the trailing space is omitted and object is printed with the *print-pretty* flag non-nil to produce pretty output.

Output-stream specifies the stream to which output is to be sent.

Affected By::

*standard-output*, *terminal-io*, *print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*, *read-default-float-format*.

See Also::

readtable-case , FORMAT Printer Operations

Notes::

The functions prin1 and print do not bind *print-readably*. 

 (prin1 object output-stream)
≡ (write object :stream output-stream :escape t)

 (princ object output-stream)
≡ (write object stream output-stream :escape nil :readably nil)

 (print object output-stream)
≡ (progn (terpri output-stream)
           (write object :stream output-stream
                         :escape t)
           (write-char #\space output-stream))

 (pprint object output-stream)
≡ (write object :stream output-stream :escape t :pretty t)

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/get_002duniversal_002dtime.html0000644000175000017500000001231014360276512020217 0ustar cammcamm get-universal-time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.3 get-universal-time, get-decoded-time [Function]

get-universal-time <no arguments> ⇒ universal-time

get-decoded-time <no arguments>
⇒ second, minute, hour, date, month, year, day, daylight-p, zone

Arguments and Values::

universal-time—a universal time.

second, minute, hour, date, month, year, day, daylight-p, zone—a decoded time.

Description::

get-universal-time returns the current time, represented as a universal time.

get-decoded-time returns the current time, represented as a decoded time.

Examples::

;; At noon on July 4, 1976 in Eastern Daylight Time.
 (get-decoded-time) ⇒  0, 0, 12, 4, 7, 1976, 6, true, 5
;; At exactly the same instant.
 (get-universal-time) ⇒  2414332800
;; Exactly five minutes later.
 (get-universal-time) ⇒  2414333100
;; The difference is 300 seconds (five minutes)
 (- * **) ⇒  300

Affected By::

The time of day (i.e., the passage of time), the system clock’s ability to keep accurate time, and the accuracy of the system clock’s initial setting.

Exceptional Situations::

An error of type error might be signaled if the current time cannot be determined.

See Also::

decode-universal-time , encode-universal-time , Time

Notes::

 (get-decoded-time) ≡ (decode-universal-time (get-universal-time))

No implementation is required to have a way to verify that the time returned is correct. However, if an implementation provides a validity check (e.g., the failure to have properly initialized the system clock can be reliably detected) and that validity check fails, the implementation is strongly encouraged (but not required) to signal an error of type error (rather than, for example, returning a known-to-be-wrong value) that is correctable by allowing the user to interactively set the correct time.

Next: , Previous: , Up: Environment Dictionary  

gcl-2.6.14/info/gcl/y_002dor_002dn_002dp.html0000644000175000017500000001377714360276512016546 0ustar cammcamm y-or-n-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.37 y-or-n-p, yes-or-no-p [Function]

y-or-n-p &optional control &rest arguments ⇒ generalized-boolean

yes-or-no-p &optional control &rest arguments ⇒ generalized-boolean

Arguments and Values::

control—a format control.

arguments—format arguments for control.

generalized-boolean—a generalized boolean.

Description::

These functions ask a question and parse a response from the user. They return true if the answer is affirmative, or false if the answer is negative.

y-or-n-p is for asking the user a question whose answer is either “yes” or “no.” It is intended that the reply require the user to answer a yes-or-no question with a single character. yes-or-no-p is also for asking the user a question whose answer is either “Yes” or “No.” It is intended that the reply require the user to take more action than just a single keystroke, such as typing the full word yes or no followed by a newline.

y-or-n-p types out a message (if supplied), reads an answer in some implementation-dependent manner (intended to be short and simple, such as reading a single character such as Y or N). yes-or-no-p types out a message (if supplied), attracts the user’s attention (for example, by ringing the terminal’s bell), and reads an answer in some implementation-dependent manner (intended to be multiple characters, such as YES or NO).

If format-control is supplied and not nil, then a fresh-line operation is performed; then a message is printed as if format-control and arguments were given to format. In any case, yes-or-no-p and y-or-n-p will provide a prompt such as “(Y or N)” or “(Yes or No)” if appropriate.

All input and output are performed using query I/O.

Examples::

 (y-or-n-p "(t or nil) given by")
 |>  (t or nil) given by (Y or N) |>>Y<<|
⇒  true
 (yes-or-no-p "a ~S message" 'frightening) 
 |>  a FRIGHTENING message (Yes or No) |>>no<<|
⇒  false
 (y-or-n-p "Produce listing file?") 
 |>  Produce listing file?
 |>  Please respond with Y or N. |>>n<<|
⇒  false

Side Effects::

Output to and input from query I/O will occur.

Affected By::

*query-io*.

See Also::

format

Notes::

yes-or-no-p and yes-or-no-p do not add question marks to the end of the prompt string, so any desired question mark or other punctuation should be explicitly included in the text query.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/Backquote.html0000644000175000017500000001660314360276512015305 0ustar cammcamm Backquote (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.6 Backquote

The backquote introduces a template of a data structure to be built. For example, writing 

 `(cond ((numberp ,x) ,@y) (t (print ,x) ,@y))

is roughly equivalent to writing 

 (list 'cond 
       (cons (list 'numberp x) y) 
       (list* 't (list 'print x) y))

Where a comma occurs in the template, the expression following the comma is to be evaluated to produce an object to be inserted at that point. Assume b has the value 3, for example, then evaluating the form denoted by `(a b ,b ,(+ b 1) b) produces the result (a b 3 4 b).

If a comma is immediately followed by an at-sign, then the form following the at-sign is evaluated to produce a list of objects. These objects are then “spliced” into place in the template. For example, if x has the value (a b c), then 

 `(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x))
⇒  (x (a b c) a b c foo b bar (b c) baz b c)

The backquote syntax can be summarized formally as follows.

*

`basic is the same as 'basic, that is, (quote basic), for any expression basic that is not a list or a general vector.

*

`,form is the same as form, for any form, provided that the representation of form does not begin with at-sign or dot. (A similar caveat holds for all occurrences of a form after a comma.)

*

`,@form has undefined consequences.

*

`(x1 x2 x3 ... xn . atom) may be interpreted to mean 

 (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] (quote atom))

where the brackets are used to indicate a transformation of an xj as follows:

–

[form] is interpreted as (list `form), which contains a backquoted form that must then be further interpreted.

–

[,form] is interpreted as (list form).

–

[,@form] is interpreted as form.

*

`(x1 x2 x3 ... xn) may be interpreted to mean the same as the backquoted form `(x1 x2 x3 ... xn . nil), thereby reducing it to the previous case.

*

`(x1 x2 x3 ... xn . ,form) may be interpreted to mean 

 (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] form)

where the brackets indicate a transformation of an xj as described above.

*

`(x1 x2 x3 ... xn . ,@form) has undefined consequences.

*

`#(x1 x2 x3 ... xn) may be interpreted to mean (apply #'vector `(x1 x2 x3 ... xn)).

Anywhere “,@” may be used, the syntax “,.” may be used instead to indicate that it is permissible to operate destructively on the list structure produced by the form following the “,.” (in effect, to use nconc instead of append).

If the backquote syntax is nested, the innermost backquoted form should be expanded first. This means that if several commas occur in a row, the leftmost one belongs to the innermost backquote.

An implementation is free to interpret a backquoted form F_1 as any form F_2 that, when evaluated, will produce a result that is the same under equal as the result implied by the above definition, provided that the side-effect behavior of the substitute form F_2 is also consistent with the description given above. The constructed copy of the template might or might not share list structure with the template itself. As an example, the above definition implies that 

 `((,a b) ,c ,@d)

will be interpreted as if it were 

 (append (list (append (list a) (list 'b) 'nil)) (list c) d 'nil)

but it could also be legitimately interpreted to mean any of the following: 

 (append (list (append (list a) (list 'b))) (list c) d)
 (append (list (append (list a) '(b))) (list c) d)
 (list* (cons a '(b)) c d)
 (list* (cons a (list 'b)) c d)
 (append (list (cons a '(b))) (list c) d)
 (list* (cons a '(b)) c (copy-list d))
• Notes about Backquote  

Next: , Previous: , Up: Standard Macro Characters  

gcl-2.6.14/info/gcl/read_002dsequence.html0000644000175000017500000001274714360276512016565 0ustar cammcamm read-sequence (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.24 read-sequence [Function]

read-sequence sequence stream &key start end ⇒ position

sequence—a sequence.

stream—an input stream.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

position—an integer greater than or equal to zero, and less than or equal to the length of the sequence.

Description::

Destructively modifies sequence by replacing the elements of sequence bounded by start and end with elements read from stream.

Sequence is destructively modified by copying successive elements into it from stream. If the end of file for stream is reached before copying all elements of the subsequence, then the extra elements near the end of sequence are not updated.

Position is the index of the first element of sequence that was not updated, which might be less than end because the end of file was reached.

Examples::

 (defvar *data* (make-array 15 :initial-element nil))
 (values (read-sequence *data* (make-string-input-stream "test string")) *data*)
 ⇒  11, #(#\t #\e #\s #\t #\Space #\s #\t #\r #\i #\n #\g NIL NIL NIL NIL)

Side Effects::

Modifies stream and sequence.

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil.

Might signal an error of type type-error if an element read from the stream is not a member of the element type of the sequence.

See Also::

Compiler Terminology, write-sequence , read-line

Notes::

read-sequence is identical in effect to iterating over the indicated subsequence and reading one element at a time from stream and storing it into sequence, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the sequence is a vector with the same element type as the stream.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/shiftf.html0000644000175000017500000001322314360276512014645 0ustar cammcamm shiftf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.65 shiftf [Macro]

shiftf {place}^+ newvalue ⇒ old-value-1

Arguments and Values::

place—a place.

newvalue—a form; evaluated.

old-value-1—an object (the old value of the first place).

Description::

shiftf modifies the values of each place by storing newvalue into the last place, and shifting the values of the second through the last place into the remaining places.

If newvalue produces more values than there are store variables, the extra values are ignored. If newvalue produces fewer values than there are store variables, the missing values are set to nil.

In the form (shiftf place1 place2 ... placen newvalue), the values in place1 through placen are read and saved, and newvalue is evaluated, for a total of n+1 values in all. Values 2 through n+1 are then stored into place1 through placen, respectively. It is as if all the places form a shift register; the newvalue is shifted in from the right, all values shift over to the left one place, and the value shifted out of place1 is returned.

For information about the evaluation of subforms of places, see Evaluation of Subforms to Places.

Examples::

 (setq x (list 1 2 3) y 'trash) ⇒  TRASH
 (shiftf y x (cdr x) '(hi there)) ⇒  TRASH
 x ⇒  (2 3)
 y ⇒  (1 HI THERE)

 (setq x (list 'a 'b 'c)) ⇒  (A B C)
 (shiftf (cadr x) 'z) ⇒  B
 x ⇒  (A Z C)
 (shiftf (cadr x) (cddr x) 'q) ⇒  Z
 x ⇒  (A (C) . Q)
 (setq n 0) ⇒  0
 (setq x (list 'a 'b 'c 'd)) ⇒  (A B C D)
 (shiftf (nth (setq n (+ n 1)) x) 'z) ⇒  B
 x ⇒  (A Z C D)

Affected By::

define-setf-expander, defsetf, *macroexpand-hook*

See Also::

setf , rotatef , Generalized Reference

Notes::

The effect of (shiftf place1 place2 ... placen newvalue) is roughly equivalent to 

 (let ((var1 place1)
       (var2 place2)
       ...
       (varn placen)
       (var0 newvalue))
   (setf place1 var2)
   (setf place2 var3)
   ...
   (setf placen var0)
   var1)

except that the latter would evaluate any subforms of each place twice, whereas shiftf evaluates them once. For example, 

 (setq n 0) ⇒  0
 (setq x (list 'a 'b 'c 'd)) ⇒  (A B C D)
 (prog1 (nth (setq n (+ n 1)) x)
        (setf (nth (setq n (+ n 1)) x) 'z)) ⇒  B
 x ⇒  (A B Z D)

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Examples-of-for_002das_002dequals_002dthen-subclause.html0000644000175000017500000000504014360276512024725 0ustar cammcamm Examples of for-as-equals-then subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.9 Examples of for-as-equals-then subclause

;; Collect some numbers.
 (loop for item = 1 then (+ item 10)
       for iteration from 1 to 5
       collect item)
⇒  (1 11 21 31 41)
gcl-2.6.14/info/gcl/Data-and-Control-Flow.html0000644000175000017500000000506214360276512017320 0ustar cammcamm Data and Control Flow (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

5 Data and Control Flow

• Generalized Reference  
• Transfer of Control to an Exit Point  
• Data and Control Flow Dictionary  
gcl-2.6.14/info/gcl/string_002dstream.html0000644000175000017500000000560314360276512016634 0ustar cammcamm string-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.6 string-stream [System Class]

Class Precedence List::

string-stream, stream, t

Description::

A string stream is a stream which reads input from or writes output to an associated string.

The stream element type of a string stream is always a subtype of type character.

See Also::

make-string-input-stream , make-string-output-stream , with-input-from-string , with-output-to-string

gcl-2.6.14/info/gcl/Tilde-Asterisk_002d_003e-Go_002dTo.html0000644000175000017500000000607314360276512021062 0ustar cammcamm Tilde Asterisk-> Go-To (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.1 Tilde Asterisk: Go-To

The next arg is ignored. ~n* ignores the next n arguments.

~:* backs up in the list of arguments so that the argument last processed will be processed again. ~n:* backs up n arguments.

When within a ~{ construct (see below), the ignoring (in either direction) is relative to the list of arguments being processed by the iteration.

~n@* goes to the nth arg, where 0 means the first one; n defaults to 0, so ~@* goes back to the first arg. Directives after a ~n@* will take arguments in sequence beginning with the one gone to. When within a ~{ construct, the “goto” is relative to the list of arguments being processed by the iteration.

gcl-2.6.14/info/gcl/return_002dfrom.html0000644000175000017500000001170114360276512016311 0ustar cammcamm return-from (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.25 return-from [Special Operator]

return-from name [result] ⇒ #<NoValue>

Arguments and Values::

name—a block tag; not evaluated.

result—a form; evaluated. The default is nil.

Description::

Returns control and multiple values_2 from a lexically enclosing block.

A block form named name must lexically enclose the occurrence of return-from; any values yielded by the evaluation of result are immediately returned from the innermost such lexically enclosing block.

The transfer of control initiated by return-from is performed as described in Transfer of Control to an Exit Point.

Examples::

 (block alpha (return-from alpha) 1) ⇒  NIL
 (block alpha (return-from alpha 1) 2) ⇒  1
 (block alpha (return-from alpha (values 1 2)) 3) ⇒  1, 2
 (let ((a 0))
    (dotimes (i 10) (incf a) (when (oddp i) (return)))
    a) ⇒  2
 (defun temp (x)
    (if x (return-from temp 'dummy))
    44) ⇒  TEMP
 (temp nil) ⇒  44
 (temp t) ⇒  DUMMY
 (block out
   (flet ((exit (n) (return-from out n)))
     (block out (exit 1)))
   2) ⇒  1
 (block nil   
   (unwind-protect (return-from nil 1)
     (return-from nil 2)))
⇒  2
 (dolist (flag '(nil t))
   (block nil
     (let ((x 5))
       (declare (special x))
       (unwind-protect (return-from nil)
         (print x))))
   (print 'here))
 |>  5
 |>  HERE
 |>  5
 |>  HERE
⇒  NIL
 (dolist (flag '(nil t))
   (block nil
     (let ((x 5))
       (declare (special x))
       (unwind-protect
           (if flag (return-from nil))
         (print x))))
   (print 'here))
 |>  5
 |>  HERE
 |>  5
 |>  HERE
⇒  NIL

The following has undefined consequences because the block form exits normally before the return-from form is attempted. 

 (funcall (block nil #'(lambda () (return-from nil)))) is an error.

See Also::

block , return , Evaluation

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Rules-for-Initialization-Arguments.html0000644000175000017500000001565614360276512022204 0ustar cammcamm Rules for Initialization Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.4 Rules for Initialization Arguments

The :initarg slot option may be specified more than once for a given slot.

The following rules specify when initialization arguments may be multiply defined:

*

A given initialization argument can be used to initialize more than one slot if the same initialization argument name appears in more than one :initarg slot option.

*

A given initialization argument name can appear in the lambda list of more than one initialization method.

*

A given initialization argument name can appear both in an :initarg slot option and in the lambda list of an initialization method.

[Reviewer Note by The next three paragraphs could be replaced by “If two or more initialization arguments that initialize the same slot appear in the defaulted initialization argument list, the leftmost of these supplies the value, even if they have different names.” And the rest would follow from the rules above.]

If two or more initialization arguments that initialize the same slot are given in the arguments to make-instance, the leftmost of these initialization arguments in the initialization argument list supplies the value, even if the initialization arguments have different names.

If two or more different initialization arguments that initialize the same slot have default values and none is given explicitly in the arguments to make-instance, the initialization argument that appears in a :default-initargs class option in the most specific of the classes supplies the value. If a single :default-initargs class option specifies two or more initialization arguments that initialize the same slot and none is given explicitly in the arguments to make-instance, the leftmost in the :default-initargs class option supplies the value, and the values of the remaining default value forms are ignored.

Initialization arguments given explicitly in the arguments to make-instance appear to the left of defaulted initialization arguments. Suppose that the classes C_1 and C_2 supply the values of defaulted initialization arguments for different slots, and suppose that C_1 is more specific than C_2; then the defaulted initialization argument whose value is supplied by C_1 is to the left of the defaulted initialization argument whose value is supplied by C_2 in the defaulted initialization argument list. If a single :default-initargs class option supplies the values of initialization arguments for two different slots, the initialization argument whose value is specified farther to the left in the :default-initargs class option appears farther to the left in the defaulted initialization argument list.

[Reviewer Note by Barmar: End of claim made three paragraphs back.]

If a slot has both an :initform form and an :initarg slot option, and the initialization argument is defaulted using :default-initargs or is supplied to make-instance, the captured :initform form is neither used nor evaluated.

The following is an example of the above rules: 

 (defclass q () ((x :initarg a)))
 (defclass r (q) ((x :initarg b))
   (:default-initargs a 1 b 2))

                            Defaulted                                     
 Form                         Initialization Argument List Contents of Slot X 
 _____________________________________________________________________________
 (make-instance 'r)           (a 1 b 2)                    1                  
 (make-instance 'r 'a 3)      (a 3 b 2)                    3                  
 (make-instance 'r 'b 4)      (b 4 a 1)                    4                  
 (make-instance 'r 'a 1 'a 2) (a 1 a 2 b 2)                1

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/The-_0022Valid-Context_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000573414360276512025323 0ustar cammcamm The "Valid Context" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.31 The "Valid Context" Section of a Dictionary Entry

This information is used by dictionary entries such as “Declarations” in order to restrict the context in which the declaration may appear.

A given “Declaration” might appear in a declaration (i.e., a declare expression), a proclamation (i.e., a declaim or proclaim form), or both.

gcl-2.6.14/info/gcl/upper_002dcase_002dp.html0000644000175000017500000001024514360276512017004 0ustar cammcamm upper-case-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.15 upper-case-p, lower-case-p, both-case-p [Function]

upper-case-p character ⇒ generalized-boolean

lower-case-p character ⇒ generalized-boolean

both-case-p character ⇒ generalized-boolean

Arguments and Values::

character—a character.

generalized-boolean—a generalized boolean.

Description::

These functions test the case of a given character.

upper-case-p returns true if character is an uppercase character; otherwise, returns false.

lower-case-p returns true if character is a lowercase character; otherwise, returns false.

both-case-p returns true if character is a character with case; otherwise, returns false.

Examples::

 (upper-case-p #\A) ⇒  true
 (upper-case-p #\a) ⇒  false
 (both-case-p #\a) ⇒  true
 (both-case-p #\5) ⇒  false
 (lower-case-p #\5) ⇒  false
 (upper-case-p #\5) ⇒  false
 ;; This next example presupposes an implementation 
 ;; in which #\Bell is an implementation-defined character.
 (lower-case-p #\Bell) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

char-upcase , char-downcase, Characters With Case, Documentation of Implementation-Defined Scripts

gcl-2.6.14/info/gcl/Array-Rank.html0000644000175000017500000000461414360276512015335 0ustar cammcamm Array Rank (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.4 Array Rank

An array can have any number of dimensions (including zero). The number of dimensions is called the rank .

If the rank of an array is zero then the array is said to have no dimensions, and the product of the dimensions (see array-total-size) is then 1; a zero-rank array therefore has a single element.

gcl-2.6.14/info/gcl/_002aread_002dbase_002a.html0000644000175000017500000000761014360276512017124 0ustar cammcamm *read-base* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.13 *read-base* [Variable]

Value Type::

a radix.

Initial Value::

10.

Description::

Controls the interpretation of tokens by read as being integers or ratios.

The value of *read-base*, called the current input base , is the radix in which integers and ratios are to be read by the Lisp reader. The parsing of other numeric types (e.g., floats) is not affected by this option.

The effect of *read-base* on the reading of any particular rational number can be locally overridden by explicit use of the #O, #X, #B, or #nR syntax or by a trailing decimal point.

Examples::

 (dotimes (i 6)
   (let ((*read-base* (+ 10. i)))
     (let ((object (read-from-string "(\\DAD DAD |BEE| BEE 123. 123)")))
       (print (list *read-base* object)))))
 |>  (10 (DAD DAD BEE BEE 123 123))
 |>  (11 (DAD DAD BEE BEE 123 146))
 |>  (12 (DAD DAD BEE BEE 123 171))
 |>  (13 (DAD DAD BEE BEE 123 198))
 |>  (14 (DAD 2701 BEE BEE 123 227))
 |>  (15 (DAD 3088 BEE 2699 123 258))
⇒  NIL

Notes::

Altering the input radix can be useful when reading data files in special formats.

gcl-2.6.14/info/gcl/Constituent-Traits.html0000644000175000017500000001755114360276512017155 0ustar cammcamm Constituent Traits (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.2 Constituent Traits

Every character has one or more constituent traits that define how the character is to be interpreted by the Lisp reader when the character is a constituent character. These constituent traits are alphabetic_2, digit, package marker, plus sign, minus sign, dot, decimal point, ratio marker, exponent marker, and invalid. Figure~2–8 shows the constituent traits of the standard characters and of certain semi-standard characters; no mechanism is provided for changing the constituent trait of a character. Any character with the alphadigit constituent trait in that figure is a digit if the current input base is greater than that character’s digit value, otherwise the character is alphabetic_2. Any character quoted by a single escape is treated as an alphabetic_2 constituent, regardless of its normal syntax. 

 constituent traits         constituent traits                                   
 character                  character   
 ________________________________________________________________________________
 Backspace   invalid        {           alphabetic_2                             
 Tab         invalid*       }           alphabetic_2                             
 Newline     invalid*       +           alphabetic_2, plus sign                  
 Linefeed    invalid*       -           alphabetic_2, minus sign                 
 Page        invalid*       .           alphabetic_2, dot, decimal point         
 Return      invalid*       /           alphabetic_2, ratio marker               
 Space       invalid*       A, a        alphadigit                               
 !           alphabetic_2   B, b        alphadigit                               
 "           alphabetic_2*  C, c        alphadigit                               
 #           alphabetic_2*  D, d        alphadigit, double-float exponent marker 
 $          alphabetic_2   E, e        alphadigit, float exponent marker        
 %           alphabetic_2   F, f        alphadigit, single-float exponent marker 
 &           alphabetic_2   G, g        alphadigit                               
 ’           alphabetic_2*  H, h        alphadigit                               
 (           alphabetic_2*  I, i        alphadigit                               
 )           alphabetic_2*  J, j        alphadigit                               
 *           alphabetic_2   K, k        alphadigit                               
 ,           alphabetic_2*  L, l        alphadigit, long-float exponent marker   
 0-9         alphadigit     M, m        alphadigit                               
 :           package marker N, n        alphadigit                               
 ;           alphabetic_2*  O, o        alphadigit                               
 <           alphabetic_2   P, p        alphadigit                               
 =           alphabetic_2   Q, q        alphadigit                               
 >           alphabetic_2   R, r        alphadigit                               
 ?           alphabetic_2   S, s        alphadigit, short-float exponent marker  
 @           alphabetic_2   T, t        alphadigit                               
 [           alphabetic_2   U, u        alphadigit                               
 \           alphabetic_2*  V, v        alphadigit                               
 ]           alphabetic_2   W, w        alphadigit                               
 ^           alphabetic_2   X, x        alphadigit                               
 _           alphabetic_2   Y, y        alphadigit                               
 ‘           alphabetic_2*  Z, z        alphadigit                               
 |           alphabetic_2*  Rubout      invalid                                  
 ~           alphabetic_2

  Figure 2–8: Constituent Traits of Standard Characters and Semi-Standard Characters

The interpretations in this table apply only to characters whose syntax type is constituent. Entries marked with an asterisk (*) are normally shadowed_2 because the indicated characters are of syntax type whitespace_2, macro character, single escape, or multiple escape; these constituent traits apply to them only if their syntax types are changed to constituent.

Next: , Previous: , Up: Character Syntax Types  

gcl-2.6.14/info/gcl/logcount.html0000644000175000017500000000736314360276512015224 0ustar cammcamm logcount (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.64 logcount [Function]

logcount integer ⇒ number-of-on-bits

Arguments and Values::

integer—an integer.

number-of-on-bits—a non-negative integer.

Description::

Computes and returns the number of bits in the two’s-complement binary representation of integer that are ‘on’ or ‘set’. If integer is negative, the 0 bits are counted; otherwise, the 1 bits are counted.

Examples::

 (logcount 0) ⇒  0
 (logcount -1) ⇒  0
 (logcount 7) ⇒  3
 (logcount  13) ⇒  3 ;Two's-complement binary: ...0001101
 (logcount -13) ⇒  2 ;Two's-complement binary: ...1110011
 (logcount  30) ⇒  4 ;Two's-complement binary: ...0011110
 (logcount -30) ⇒  4 ;Two's-complement binary: ...1100010
 (logcount (expt 2 100)) ⇒  1
 (logcount (- (expt 2 100))) ⇒  100
 (logcount (- (1+ (expt 2 100)))) ⇒  1

Exceptional Situations::

Should signal type-error if its argument is not an integer.

Notes::

Even if the implementation does not represent integers internally in two’s complement binary, logcount behaves as if it did.

The following identity always holds: 

    (logcount x)
 ≡ (logcount (- (+ x 1)))
 ≡ (logcount (lognot x))
gcl-2.6.14/info/gcl/Printing-Lists-and-Conses.html0000644000175000017500000001210114360276512020232 0ustar cammcamm Printing Lists and Conses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.13 Printing Lists and Conses

Wherever possible, list notation is preferred over dot notation. Therefore the following algorithm is used to print a cons x:

1.

A left-parenthesis is printed.

2.

The car of x is printed.

3.

If the cdr of x is itself a cons, it is made to be the current cons (i.e., x becomes that cons),

a space

is printed, and step 2 is re-entered.

4.

If the cdr of x is not null,

a space,

a dot,

a space,

and the cdr of x are printed.

5.

A right-parenthesis is printed.

Actually, the above algorithm is only used when *print-pretty* is false. When *print-pretty* is true (or when pprint is used), additional whitespace_1 may replace the use of a single space, and a more elaborate algorithm with similar goals but more presentational flexibility is used; see Printer Dispatching.

Although the two expressions below are equivalent, and the reader accepts either one and produces the same cons, the printer always prints such a cons in the second form. 

 (a . (b . ((c . (d . nil)) . (e . nil))))
 (a b (c d) e)

The printing of conses is affected by *print-level*, *print-length*, and *print-circle*.

Following are examples of printed representations of lists: 

 (a . b)     ;A dotted pair of a and b
 (a.b)       ;A list of one element, the symbol named a.b
 (a. b)      ;A list of two elements a. and b
 (a .b)      ;A list of two elements a and .b
 (a b . c)   ;A dotted list of a and b with c at the end; two conses
 .iot        ;The symbol whose name is .iot
 (. b)       ;Invalid -- an error is signaled if an attempt is made to read 
             ;this syntax.
 (a .)       ;Invalid -- an error is signaled.
 (a .. b)    ;Invalid -- an error is signaled.
 (a . . b)   ;Invalid -- an error is signaled.
 (a b c ...) ;Invalid -- an error is signaled.
 (a \. b)    ;A list of three elements a, ., and b
 (a |.| b)   ;A list of three elements a, ., and b
 (a \... b)  ;A list of three elements a, ..., and b
 (a |...| b) ;A list of three elements a, ..., and b

For information on how the Lisp reader parses lists and conses, see Left-Parenthesis.

Next: , Previous: , Up: Default Print-Object Methods  

gcl-2.6.14/info/gcl/Examples-of-Resolution-of-Apparent-Conflict-in-Exceptional-Situations.html0000644000175000017500000000622414360276512030634 0ustar cammcamm Examples of Resolution of Apparent Conflict in Exceptional Situations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.6 Examples of Resolution of Apparent Conflict in Exceptional Situations

Suppose that function foo is a member of a set S of functions that operate on numbers. Suppose that one passage states that an error must be signaled if any function in S is ever given an argument of 17. Suppose that an apparently conflicting passage states that the consequences are undefined if foo receives an argument of 17. Then the second passage (the one specifically about foo) would dominate because the description of the situational context is the most specific, and it would not be required that foo signal an error on an argument of 17 even though other functions in the set S would be required to do so.

gcl-2.6.14/info/gcl/input_002dstream_002dp.html0000644000175000017500000000703514360276512017373 0ustar cammcamm input-stream-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.9 input-stream-p, output-stream-p [Function]

input-stream-p stream ⇒ generalized-boolean

output-stream-p stream ⇒ generalized-boolean

Arguments and Values::

stream—a stream.

generalized-boolean—a generalized boolean.

Description::

input-stream-p returns true if stream is an input stream; otherwise, returns false.

output-stream-p returns true if stream is an output stream; otherwise, returns false.

Examples::

 (input-stream-p *standard-input*) ⇒  true
 (input-stream-p *terminal-io*) ⇒  true
 (input-stream-p (make-string-output-stream)) ⇒  false

 (output-stream-p *standard-output*) ⇒  true
 (output-stream-p *terminal-io*) ⇒  true
 (output-stream-p (make-string-input-stream "jr")) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream.

gcl-2.6.14/info/gcl/fill_002dpointer.html0000644000175000017500000000716214360276512016443 0ustar cammcamm fill-pointer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.21 fill-pointer [Accessor]

fill-pointer vector ⇒ fill-pointer

(setf ( fill-pointer vector) new-fill-pointer)

Arguments and Values::

vector—a vector with a fill pointer.

fill-pointer, new-fill-pointer—a valid fill pointer for the vector.

Description::

Accesses the fill pointer of vector.

Examples::

 (setq a (make-array 8 :fill-pointer 4)) ⇒  #(NIL NIL NIL NIL)
 (fill-pointer a) ⇒  4
 (dotimes (i (length a)) (setf (aref a i) (* i i))) ⇒  NIL
 a ⇒  #(0 1 4 9)
 (setf (fill-pointer a) 3) ⇒  3
 (fill-pointer a) ⇒  3
 a ⇒  #(0 1 4)
 (setf (fill-pointer a) 8) ⇒  8
 a ⇒  #(0 1 4 9 NIL NIL NIL NIL)

Exceptional Situations::

Should signal an error of type type-error if vector is not a vector with a fill pointer.

See Also::

make-array , length

Notes::

There is no operator that will remove a vector’s fill pointer.

gcl-2.6.14/info/gcl/Pathnames.html0000644000175000017500000000502214360276512015300 0ustar cammcamm Pathnames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames  

19.2 Pathnames

• Pathname Components  
• Interpreting Pathname Component Values  
• Merging Pathnames  
gcl-2.6.14/info/gcl/The-for_002das_002darithmetic-subclause.html0000644000175000017500000001623614360276512022531 0ustar cammcamm The for-as-arithmetic subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.2 The for-as-arithmetic subclause

In the for-as-arithmetic subclause, the for or as construct iterates from the value supplied by form1 to the value supplied by form2 in increments or decrements denoted by form3. Each expression is evaluated only once and must evaluate to a number. The variable var is bound to the value of form1 in the first iteration and is stepped_1 by the value of form3 in each succeeding iteration, or by 1 if form3 is not provided. The following loop keywords serve as valid prepositions within this syntax. At least one of the prepositions must be used; and at most one from each line may be used in a single subclause.

from | downfrom | upfrom
to | downto | upto | below | above
by

The prepositional phrases in each subclause may appear in any order. For example, either “from x by y” or “by y from x” is permitted. However, because left-to-right order of evaluation is preserved, the effects will be different in the case of side effects.

Consider: 

(let ((x 1)) (loop for i from x by (incf x) to 10 collect i))
⇒  (1 3 5 7 9)
(let ((x 1)) (loop for i by (incf x) from x to 10 collect i))
⇒  (2 4 6 8 10)

The descriptions of the prepositions follow:

from

The loop keyword from specifies the value from which stepping_1 begins, as supplied by form1. Stepping_1 is incremental by default. If decremental stepping_1 is desired, the preposition downto or above must be used with form2. For incremental stepping_1, the default from value is 0.

downfrom, upfrom

The loop keyword downfrom indicates that the variable var is decreased in decrements supplied by form3; the loop keyword upfrom indicates that var is increased in increments supplied by form3.

to

The loop keyword to marks the end value for stepping_1 supplied in form2. Stepping_1 is incremental by default. If decremental stepping_1 is desired, the preposition downfrom must be used with form1, or else the preposition downto or above should be used instead of to with form2.

downto, upto

The loop keyword downto specifies decremental stepping; the loop keyword upto specifies incremental stepping. In both cases, the amount of change on each step is specified by form3, and the loop terminates when the variable var passes the value of form2. Since there is no default for form1 in decremental stepping_1, a form1 value must be supplied (using from or downfrom) when downto is supplied.

below, above

The loop keywords below and above are analogous to upto and downto respectively. These keywords stop iteration just before the value of the variable var reaches the value supplied by form2; the end value of form2 is not included. Since there is no default for form1 in decremental stepping_1, a form1 value must be supplied (using from or downfrom) when above is supplied.

by

The loop keyword by marks the increment or decrement supplied by form3. The value of form3 can be any positive number. The default value is 1.

In an iteration control clause, the for or as construct causes termination when the supplied limit is reached. That is, iteration continues until the value var is stepped to the exclusive or inclusive limit supplied by form2. The range is exclusive if form3 increases or decreases var to the value of form2 without reaching that value; the loop keywords below and above provide exclusive limits. An inclusive limit allows var to attain the value of form2; to, downto, and upto provide inclusive limits.

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

gcl-2.6.14/info/gcl/standard_002dmethod.html0000644000175000017500000000473014360276512017113 0ustar cammcamm standard-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.12 standard-method [System Class]

Class Precedence List::

standard-method, method,

standard-object,

t

Description::

The class standard-method is the default class of methods defined by the defmethod and defgeneric forms.

gcl-2.6.14/info/gcl/The-RECURSIVE_002dP-argument.html0000644000175000017500000001240414360276512020134 0ustar cammcamm The RECURSIVE-P argument (ANSI and GNU Common Lisp Document)

Previous: , Up: Argument Conventions of Some Reader Functions  

23.1.3.2 The RECURSIVE-P argument

If recursive-p is supplied and not nil, it specifies that this function call is not an outermost call to read but an embedded call, typically from a reader macro function. It is important to distinguish such recursive calls for three reasons.

1.

An outermost call establishes the context within which the #n= and #n# syntax is scoped. Consider, for example, the expression 

 (cons '#3=(p q r) '(x y . #3#))

If the single-quote reader macro were defined in this way: 

 (set-macro-character #\'       ;incorrect
    #'(lambda (stream char)
         (declare (ignore char))
         (list 'quote (read stream))))

then each call to the single-quote reader macro function would establish independent contexts for the scope of read information, including the scope of identifications between markers like “#3=” and “#3#”. However, for this expression, the scope was clearly intended to be determined by the outer set of parentheses, so such a definition would be incorrect. The correct way to define the single-quote reader macro uses recursive-p: 

 (set-macro-character #\'       ;correct
    #'(lambda (stream char)
         (declare (ignore char))
         (list 'quote (read stream t nil t))))
2.

A recursive call does not alter whether the reading process is to preserve whitespace_2 or not (as determined by whether the outermost call was to read or read-preserving-whitespace). Suppose again that single-quote were to be defined as shown above in the incorrect definition. Then a call to read-preserving-whitespace that read the expression 'foo<Space> would fail to preserve the space character following the symbol foo because the single-quote reader macro function calls read, not read-preserving-whitespace, to read the following expression (in this case foo). The correct definition, which passes the value true for recursive-p to read, allows the outermost call to determine whether whitespace_2 is preserved.

3.

When end-of-file is encountered and the eof-error-p argument is not nil, the kind of error that is signaled may depend on the value of recursive-p. If recursive-p is true, then the end-of-file is deemed to have occurred within the middle of a printed representation; if recursive-p is false, then the end-of-file may be deemed to have occurred between objects rather than within the middle of one.

Previous: , Up: Argument Conventions of Some Reader Functions  

gcl-2.6.14/info/gcl/Examples-of-COLLECT-clause.html0000644000175000017500000000522714360276512020104 0ustar cammcamm Examples of COLLECT clause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Value Accumulation Clauses  

6.1.3.1 Examples of COLLECT clause

;; Collect all the symbols in a list.
 (loop for i in '(bird 3 4 turtle (1 . 4) horse cat)
       when (symbolp i) collect i)
⇒  (BIRD TURTLE HORSE CAT)

;; Collect and return odd numbers.
 (loop for i from 1 to 10
       if (oddp i) collect i)
⇒  (1 3 5 7 9)

;; Collect items into local variable, but don't return them.
 (loop for i in '(a b c d) by #'cddr
       collect i into my-list
       finally (print my-list))
 |>  (A C) 
⇒  NIL
gcl-2.6.14/info/gcl/Compiler-Macros.html0000644000175000017500000000751614360276512016366 0ustar cammcamm Compiler Macros (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.1 Compiler Macros

A compiler macro can be defined for a name that also names a function or macro. That is, it is possible for a function name to name both a function and a compiler macro.

A function name names a compiler macro if compiler-macro-function is true of the function name in the lexical environment in which it appears. Creating a lexical binding for the function name not only creates a new local function or macro definition, but also shadows_2 the compiler macro.

The function returned by compiler-macro-function is a function of two arguments, called the expansion function. To expand a compiler macro, the expansion function is invoked by calling the macroexpand hook with the expansion function as its first argument, the entire compiler macro form as its second argument, and the current compilation environment (or with the current lexical environment, if the form is being processed by something other than compile-file) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The return value from the expansion function, which is passed through by the macroexpand hook, might either be the same form, or else a form that can, at the discretion of the code doing the expansion, be used in place of the original form. 

  *macroexpand-hook*  compiler-macro-function  define-compiler-macro  

        Figure 3–6: Defined names applicable to compiler macros
gcl-2.6.14/info/gcl/_002d_003eWILD-as-a-Component-Value.html0000644000175000017500000000620714360276512021232 0ustar cammcamm ->WILD as a Component Value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.8 :WILD as a Component Value

If :wild is the value of a pathname component, that component is considered to be a wildcard, which matches anything.

A conforming program must be prepared to encounter a value of :wild as the value of any pathname component, or as an element of a list that is the value of the directory component.

When constructing a pathname, a conforming program may use :wild as the value of any or all of the directory, name, type, or version component, but must not use :wild as the value of the host, or device component.

If :wild is used as the value of the directory component in the construction of a pathname, the effect is equivalent to specifying the list (:absolute :wild-inferiors), or the same as (:absolute :wild) in a file system that does not support :wild-inferiors.

gcl-2.6.14/info/gcl/Tilde-Right_002dBrace_002d_003e-End-of-Iteration.html0000644000175000017500000000467114360276512023505 0ustar cammcamm Tilde Right-Brace-> End of Iteration (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.5 Tilde Right-Brace: End of Iteration

~} terminates a ~{. The consequences of using it elsewhere are undefined.

gcl-2.6.14/info/gcl/do_002dsymbols.html0000644000175000017500000001633314360276512016127 0ustar cammcamm do-symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.20 do-symbols, do-external-symbols, do-all-symbols [Macro]

do-symbols (var [package [result-form]]) {declaration}* {tag | statement}*
⇒ {result}*

do-external-symbols (var [package [result-form]]) {declaration}* {tag | statement}*
⇒ {result}*

do-all-symbols (var [result-form]) {declaration}* {tag | statement}*
⇒ {result}*

Arguments and Values::

var—a variable name; not evaluated.

package—a package designator; evaluated.

The default in do-symbols and do-external-symbols is the current package.

result-form—a form; evaluated as described below. The default is nil.

declaration—a declare expression; not evaluated.

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

results—the values returned by the result-form if a normal return occurs, or else, if an explicit return occurs, the values that were transferred.

Description::

do-symbols, do-external-symbols, and do-all-symbols iterate over the symbols of packages. For each symbol in the set of packages chosen, the var is bound to the symbol, and the statements in the body are executed. When all the symbols have been processed, result-form is evaluated and returned as the value of the macro.

do-symbols iterates over the symbols accessible in package.

Statements may execute more than once for symbols that are inherited from multiple packages.

do-all-symbols iterates on every registered package. do-all-symbols will not process every symbol whatsoever, because a symbol not accessible in any registered package will not be processed. do-all-symbols may cause a symbol that is present in several packages to be processed more than once.

do-external-symbols iterates on the external symbols of package.

When result-form is evaluated, var is bound and has the value nil.

An implicit block named nil surrounds the entire do-symbols, do-external-symbols, or do-all-symbols form.

return or return-from may be used to terminate the iteration prematurely.

If execution of the body affects which symbols are contained in the set of packages over which iteration is occurring, other than to remove the symbol currently the value of var by using unintern, the consequences are undefined.

For each of these macros, the scope of the name binding does not include any initial value form, but the optional result forms are included.

Any tag in the body is treated as with tagbody.

Examples::

 (make-package 'temp :use nil) ⇒  #<PACKAGE "TEMP">
 (intern "SHY" 'temp) ⇒  TEMP::SHY, NIL ;SHY will be an internal symbol
                                         ;in the package TEMP
 (export (intern "BOLD" 'temp) 'temp)  ⇒  T  ;BOLD will be external  
 (let ((lst ()))
   (do-symbols (s (find-package 'temp)) (push s lst))
   lst)
⇒  (TEMP::SHY TEMP:BOLD)
OR⇒ (TEMP:BOLD TEMP::SHY)
 (let ((lst ()))
   (do-external-symbols (s (find-package 'temp) lst) (push s lst))
   lst) 
⇒  (TEMP:BOLD)
 (let ((lst ()))                                                     
   (do-all-symbols (s lst)
     (when (eq (find-package 'temp) (symbol-package s)) (push s lst)))
   lst)
⇒  (TEMP::SHY TEMP:BOLD)
OR⇒ (TEMP:BOLD TEMP::SHY)

See Also::

intern , export ,

Traversal Rules and Side Effects

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/array_002ddimensions.html0000644000175000017500000000635614360276512017327 0ustar cammcamm array-dimensions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.12 array-dimensions [Function]

array-dimensions array ⇒ dimensions

Arguments and Values::

array—an array.

dimensions—a list of integers.

Description::

Returns a list of the dimensions of array. (If array is a vector with a fill pointer, that fill pointer is ignored.)

Examples::

 (array-dimensions (make-array 4)) ⇒  (4)
 (array-dimensions (make-array '(2 3))) ⇒  (2 3)
 (array-dimensions (make-array 4 :fill-pointer 2)) ⇒  (4)

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

array-dimension

gcl-2.6.14/info/gcl/Requirements-for-removed-and-deprecated-features.html0000644000175000017500000000632214360276512024744 0ustar cammcamm Requirements for removed and deprecated features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.1 Requirements for removed and deprecated features

For this standard, some features from the language described in Common Lisp: The Language have been removed, and others have been deprecated (and will most likely not appear in future Common Lisp standards). Which features were removed and which were deprecated was decided on a case-by-case basis by the X3J13 committee.

Conforming implementations that wish to retain any removed features for compatibility must assure that such compatibility does not interfere with the correct function of conforming programs. For example, symbols corresponding to the names of removed functions may not appear in the the COMMON-LISP package. (Note, however, that this specification has been devised in such a way that there can be a package named LISP which can contain such symbols.)

Conforming implementations must implement all deprecated features. For a list of deprecated features, see Deprecated Language Features.

gcl-2.6.14/info/gcl/tree_002dequal.html0000644000175000017500000001100114360276512016066 0ustar cammcamm tree-equal (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.13 tree-equal [Function]

tree-equal tree-1 tree-2 &key test test-not ⇒ generalized-boolean

Arguments and Values::

tree-1—a tree.

tree-2—a tree.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

generalized-boolean—a generalized boolean.

Description::

tree-equal tests whether two trees are of the same shape and have the same leaves. tree-equal returns true if tree-1 and tree-2 are both atoms and satisfy the test, or if they are both conses and the car of tree-1 is tree-equal to the car of tree-2 and the cdr of tree-1 is tree-equal to the cdr of tree-2. Otherwise, tree-equal returns false.

tree-equal recursively compares conses but not any other objects that have components.

The first argument to the :test or :test-not function is tree-1 or a car or cdr of tree-1; the second argument is tree-2 or a car or cdr of tree-2.

Examples::

 (setq tree1 '(1 (1 2))
       tree2 '(1 (1 2))) ⇒  (1 (1 2))
 (tree-equal tree1 tree2) ⇒  true
 (eql tree1 tree2) ⇒  false
 (setq tree1 '('a ('b 'c))
       tree2 '('a ('b 'c))) ⇒  ('a ('b 'c)) 
⇒  ((QUOTE A) ((QUOTE B) (QUOTE C)))
 (tree-equal tree1 tree2 :test 'eq) ⇒  true

Exceptional Situations::

The consequences are undefined if both tree-1 and tree-2 are circular.

See Also::

equal ,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

gcl-2.6.14/info/gcl/Defsetf-Lambda-Lists.html0000644000175000017500000001116514360276512017217 0ustar cammcamm Defsetf Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.7 Defsetf Lambda Lists

A defsetf lambda list is used by defsetf.

A defsetf lambda list has the following syntax:

lambda-list ::=({var}*                 [&optional {var |         (var [init-form [supplied-p-parameter]])}*]                 [&rest var]                 [&key {var |              ({var |          (keyword-name var)}    [init-form [supplied-p-parameter]])}* pt [&allow-other-keys]]                 [&environment var]

A defsetf lambda list can contain the lambda list keywords shown in Figure 3–19. 

  &allow-other-keys  &key       &rest  
  &environment       &optional         

  Figure 3–19: Lambda List Keywords used by Defsetf Lambda Lists

A defsetf lambda list differs from an ordinary lambda list only in that it does not permit the use of &aux, and that it permits use of &environment, which introduces an environment parameter.

gcl-2.6.14/info/gcl/floor.html0000644000175000017500000002105414360276512014504 0ustar cammcamm floor (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.19 floor, ffloor, ceiling, fceiling,

truncate, ftruncate, round, fround

[Function]

floor number &optional divisor ⇒ quotient, remainder

ffloor number &optional divisor ⇒ quotient, remainder

ceiling number &optional divisor ⇒ quotient, remainder

fceiling number &optional divisor ⇒ quotient, remainder

truncate number &optional divisor ⇒ quotient, remainder

ftruncate number &optional divisor ⇒ quotient, remainder

round number &optional divisor ⇒ quotient, remainder

fround number &optional divisor ⇒ quotient, remainder

Arguments and Values::

number—a real.

divisor—a non-zero real. The default is the integer 1.

quotient—for floor, ceiling, truncate, and round: an integer; for ffloor, fceiling, ftruncate, and fround: a float.

remainder—a real.

Description::

These functions divide number by divisor, returning a quotient and remainder, such that

quotient\cdot divisor+remainder=number

The quotient always represents a mathematical integer. When more than one mathematical integer might be possible (i.e., when the remainder is not zero), the kind of rounding or truncation depends on the operator:

floor, ffloor

floor and ffloor produce a quotient that has been truncated toward negative infinity; that is, the quotient represents the largest mathematical integer that is not larger than the mathematical quotient.

ceiling, fceiling

ceiling and fceiling produce a quotient that has been truncated toward positive infinity; that is, the quotient represents the smallest mathematical integer that is not smaller than the mathematical result.

truncate, ftruncate

truncate and ftruncate produce a quotient that has been truncated towards zero; that is, the quotient represents the mathematical integer of the same sign as the mathematical quotient, and that has the greatest integral magnitude not greater than that of the mathematical quotient.

round, fround

round and fround produce a quotient that has been rounded to the nearest mathematical integer; if the mathematical quotient is exactly halfway between two integers, (that is, it has the form integer+1\over2), then the quotient has been rounded to the even (divisible by two) integer.

All of these functions perform type conversion operations on numbers.

The remainder is an integer if both x and y are integers, is a rational if both x and y are rationals, and is a float if either x or y is a float.

ffloor, fceiling, ftruncate, and fround handle arguments of different types in the following way: If number is a float, and divisor is not a float of longer format, then the first result is a float of the same type as number. Otherwise, the first result is of the type determined by contagion rules; see Contagion in Numeric Operations.

Examples::

 (floor 3/2) ⇒  1, 1/2
 (ceiling 3 2) ⇒  2, -1
 (ffloor 3 2) ⇒  1.0, 1
 (ffloor -4.7) ⇒  -5.0, 0.3
 (ffloor 3.5d0) ⇒  3.0d0, 0.5d0
 (fceiling 3/2) ⇒  2.0, -1/2
 (truncate 1) ⇒  1, 0
 (truncate .5) ⇒  0, 0.5
 (round .5) ⇒  0, 0.5
 (ftruncate -7 2) ⇒  -3.0, -1
 (fround -7 2) ⇒  -4.0, 1
 (dolist (n '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6))
   (format t "~&~4,1@F ~2,' D ~2,' D ~2,' D ~2,' D"
           n (floor n) (ceiling n) (truncate n) (round n)))
 |>  +2.6  2  3  2  3
 |>  +2.5  2  3  2  2
 |>  +2.4  2  3  2  2
 |>  +0.7  0  1  0  1
 |>  +0.3  0  1  0  0
 |>  -0.3 -1  0  0  0
 |>  -0.7 -1  0  0 -1
 |>  -2.4 -3 -2 -2 -2
 |>  -2.5 -3 -2 -2 -2
 |>  -2.6 -3 -2 -2 -3
⇒  NIL

Notes::

When only number is given, the two results are exact; the mathematical sum of the two results is always equal to the mathematical value of number.

(function number divisor) and (function (/ number divisor)) (where function is any of one of floor, ceiling, ffloor, fceiling, truncate, round, ftruncate, and fround) return the same first value, but they return different remainders as the second value. For example: 

 (floor 5 2) ⇒  2, 1
 (floor (/ 5 2)) ⇒  2, 1/2

If an effect is desired that is similar to round, but that always rounds up or down (rather than toward the nearest even integer) if the mathematical quotient is exactly halfway between two integers, the programmer should consider a construction such as (floor (+ x 1/2)) or (ceiling (- x 1/2)).

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Naming-Conventions-for-Rest-Parameters.html0000644000175000017500000000632314360276512022701 0ustar cammcamm Naming Conventions for Rest Parameters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.26 Naming Conventions for Rest Parameters

Within this specification, if the name of a rest parameter is chosen to be a plural noun, use of that name in parameter font refers to the list to which the rest parameter is bound. Use of the singular form of that name in parameter font refers to an element of that list.

For example, given a syntax description such as:

F &rest arguments

it is appropriate to refer either to the rest parameter named arguments by name, or to one of its elements by speaking of “an argument,” “some argument,” “each argument” etc.

gcl-2.6.14/info/gcl/Alphanumeric-Characters.html0000644000175000017500000000424714360276512020055 0ustar cammcamm Alphanumeric Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.9 Alphanumeric Characters

The set of alphanumeric characters is the union of the set of alphabetic_1 characters and the set of numeric characters.

gcl-2.6.14/info/gcl/Viewing-Integers-as-Bits-and-Bytes.html0000644000175000017500000000423014360276512021672 0ustar cammcamm Viewing Integers as Bits and Bytes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numeric Operations  

12.1.1.4 Viewing Integers as Bits and Bytes

gcl-2.6.14/info/gcl/package_002dshadowing_002dsymbols.html0000644000175000017500000000744314360276512021553 0ustar cammcamm package-shadowing-symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.24 package-shadowing-symbols [Function]

package-shadowing-symbols package ⇒ symbols

Arguments and Values::

package—a package designator.

symbols—a list of symbols.

Description::

Returns a list of symbols that have been declared as shadowing symbols in package by shadow or shadowing-import (or the equivalent defpackage options). All symbols on this list are present in package.

Examples::

 (package-shadowing-symbols (make-package 'temp)) ⇒  ()
 (shadow 'cdr 'temp) ⇒  T
 (package-shadowing-symbols 'temp) ⇒  (TEMP::CDR)
 (intern "PILL" 'temp) ⇒  TEMP::PILL, NIL
 (shadowing-import 'pill 'temp) ⇒  T
 (package-shadowing-symbols 'temp) ⇒  (PILL TEMP::CDR)

Exceptional Situations::

Should signal an error of type type-error if package is not a package designator.

See Also::

shadow , shadowing-import

Notes::

Whether the list of symbols is fresh is implementation-dependent.

gcl-2.6.14/info/gcl/Pretty-Printer-Concepts.html0000644000175000017500000001102314360276512020042 0ustar cammcamm Pretty Printer Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Lisp Pretty Printer  

22.2.1 Pretty Printer Concepts

The facilities provided by the pretty printer permit programs to redefine the way in which code is displayed, and allow the full power of pretty printing to be applied to complex combinations of data structures.

Whether any given style of output is in fact “pretty” is inherently a somewhat subjective issue. However, since the effect of the pretty printer can be customized by conforming programs, the necessary flexibility is provided for individual programs to achieve an arbitrary degree of aesthetic control.

By providing direct access to the mechanisms within the pretty printer that make dynamic decisions about layout, the macros and functions pprint-logical-block, pprint-newline, and pprint-indent make it possible to specify pretty printing layout rules as a part of any function that produces output. They also make it very easy for the detection of circularity and sharing, and abbreviation based on length and nesting depth to be supported by the function.

The pretty printer is driven entirely by dispatch based on the value of *print-pprint-dispatch*. The function set-pprint-dispatch makes it possible for conforming programs to associate new pretty printing functions with a type.

• Dynamic Control of the Arrangement of Output  
• Format Directive Interface  
• Compiling Format Strings  
• Pretty Print Dispatch Tables  
• Pretty Printer Margins  
gcl-2.6.14/info/gcl/slot_002dmissing.html0000644000175000017500000001337314360276512016470 0ustar cammcamm slot-missing (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.12 slot-missing [Standard Generic Function]

Syntax::

slot-missing class object slot-name operation &optional new-value ⇒ {result}*

Method Signatures::

slot-missing (class t) object slot-name operation &optional new-value

Arguments and Values::

class—the class of object.

object—an object.

slot-name—a symbol (the name of a would-be slot).

operation—one of the symbols setf, slot-boundp, slot-makunbound, or slot-value.

new-value—an object.

result—an object.

Description::

The generic function slot-missing is invoked when an attempt is made to access a slot in an object whose metaclass is standard-class and the slot of the name slot-name is not a name of a slot in that class. The default method signals an error.

The generic function slot-missing is not intended to be called by programmers. Programmers may write methods for it.

The generic function slot-missing may be called during evaluation of slot-value, (setf slot-value), slot-boundp, and slot-makunbound. For each of these operations the corresponding symbol for the operation argument is slot-value, setf, slot-boundp, and slot-makunbound respectively.

The optional new-value argument to slot-missing is used when the operation is attempting to set the value of the slot.

If slot-missing returns, its values will be treated as follows:

*

If the operation is setf or slot-makunbound, any values will be ignored by the caller.

*

If the operation is slot-value, only the primary value will be used by the caller, and all other values will be ignored.

*

If the operation is slot-boundp, any boolean equivalent of the primary value of the method might be is used, and all other values will be ignored.

Exceptional Situations::

The default method on slot-missing signals an error of type error.

See Also::

defclass , slot-exists-p , slot-value

Notes::

The set of arguments (including the class of the instance) facilitates defining methods on the metaclass for slot-missing.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/char_002dint.html0000644000175000017500000000654114360276512015544 0ustar cammcamm char-int (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.17 char-int [Function]

char-int character ⇒ integer

Arguments and Values::

character—a character.

integer—a non-negative integer.

Description::

Returns a non-negative integer encoding the character object. The manner in which the integer is computed is implementation-dependent. In contrast to sxhash, the result is not guaranteed to be independent of the particular Lisp image.

If character has no implementation-defined attributes, the results of char-int and char-code are the same. 

 (char= c1 c2) ≡ (= (char-int c1) (char-int c2))

for characters c1 and c2.

Examples::

 (char-int #\A) ⇒  65       ; implementation A
 (char-int #\A) ⇒  577      ; implementation B
 (char-int #\A) ⇒  262145   ; implementation C

See Also::

char-code

gcl-2.6.14/info/gcl/Conditions.html0000644000175000017500000000436714360276512015504 0ustar cammcamm Conditions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

9 Conditions

• Condition System Concepts  
• Conditions Dictionary  
gcl-2.6.14/info/gcl/Removed-Argument-Conventions.html0000644000175000017500000000440614360276512021051 0ustar cammcamm Removed Argument Conventions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.4 Removed Argument Conventions

The font argument to digit-char was removed. The bits and font arguments to code-char

were removed.

gcl-2.6.14/info/gcl/Conforming-Programs.html0000644000175000017500000000665714360276512017270 0ustar cammcamm Conforming Programs (ANSI and GNU Common Lisp Document)

Previous: , Up: Conformance  

1.5.2 Conforming Programs

Code conforming with the requirements of this standard shall adhere to the following:

1.

Conforming code shall use only those features of the language syntax and semantics that are either specified in this standard or defined using the extension mechanisms specified in the standard.

2.

Conforming code shall not rely on any particular interpretation of implementation-dependent features.

3.

Conforming code shall not depend on the consequences of undefined or unspecified situations.

4.

Conforming code does not use any constructions that are prohibited by the standard.

5.

Conforming code does not depend on extensions included in an implementation.

• Use of Implementation-Defined Language Features  
• Use of Read-Time Conditionals  
gcl-2.6.14/info/gcl/Serious-Conditions.html0000644000175000017500000000421714360276512017125 0ustar cammcamm Serious Conditions (ANSI and GNU Common Lisp Document)

Previous: , Up: Condition Types  

9.1.1.1 Serious Conditions

A serious condition is a condition serious enough to require interactive intervention if not handled. Serious conditions are typically signaled with error or cerror; non-serious conditions are typically signaled with signal or warn.

gcl-2.6.14/info/gcl/Additional-FORMAT-Parameters.html0000644000175000017500000000464414360276512020530 0ustar cammcamm Additional FORMAT Parameters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Additional Information about FORMAT Operations  

22.3.10.3 Additional FORMAT Parameters

The consequences are undefined if a format directive is given more parameters than it is described here as accepting.

gcl-2.6.14/info/gcl/Removed-Operators.html0000644000175000017500000000515014360276512016737 0ustar cammcamm Removed Operators (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.3 Removed Operators

The functions

int-char , char-bits , char-font , make-char , char-bit , set-char-bit , string-char-p ,

and commonp

were removed.

The special operator compiler-let was removed.

gcl-2.6.14/info/gcl/The-Initial-Readtable.html0000644000175000017500000000450414360276512017354 0ustar cammcamm The Initial Readtable (ANSI and GNU Common Lisp Document)

Previous: , Up: Readtables  

2.1.1.3 The Initial Readtable

The initial readtable is the readtable that is the current readtable at the time when the Lisp image starts. At that time, it conforms to standard syntax. The initial readtable is distinct from the standard readtable. It is permissible for a conforming program to modify the initial readtable.

gcl-2.6.14/info/gcl/find_002dclass.html0000644000175000017500000001173514360276512016063 0ustar cammcamm find-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.28 find-class [Accessor]

find-class symbol &optional errorp environment ⇒ class

(setf ( find-class symbol &optional errorp environment) new-class)

Arguments and Values::

symbol—a symbol.

errorp—a generalized boolean. The default is true.

environment – same as the &environment argument to macro expansion functions and is used to distinguish between compile-time and run-time environments.

The &environment argument has dynamic extent; the consequences are undefined if the &environment argument is referred to outside the dynamic extent of the macro expansion function.

class—a class object, or nil.

Description::

Returns the class object named by the symbol in the environment. If there is no such class, nil is returned if errorp is false; otherwise, if errorp is true, an error is signaled.

The class associated with a particular symbol can be changed by using setf with find-class;

or, if the new class given to setf is nil, the class association is removed (but the class object itself is not affected).

The results are undefined if the user attempts to change

or remove

the class associated with a symbol that is defined as a type specifier in this standard. See Integrating Types and Classes.

When using setf of find-class, any errorp argument is evaluated for effect, but any values it returns are ignored; the errorp parameter is permitted primarily so that the environment parameter can be used.

The environment might be used to distinguish between a compile-time and a run-time environment.

Exceptional Situations::

If there is no such class and errorp is true, find-class signals an error of type error.

See Also::

defmacro , Integrating Types and Classes

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/restart.html0000644000175000017500000000522714360276512015053 0ustar cammcamm restart (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.31 restart [System Class]

Class Precedence List::

restart, t

Description::

An object of type restart represents a function that can be called to perform some form of recovery action, usually a transfer of control to an outer point in the running program.

An implementation is free to implement a restart in whatever manner is most convenient; a restart has only dynamic extent relative to the scope of the binding form which establishes it.

gcl-2.6.14/info/gcl/every.html0000644000175000017500000001473614360276512014526 0ustar cammcamm every (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.40 every, some, notevery, notany [Function]

every predicate &rest sequences^+ ⇒ generalized-boolean

some predicate &rest sequences^+ ⇒ result

notevery predicate &rest sequences^+ ⇒ generalized-boolean

notany predicate &rest sequences^+ ⇒ generalized-boolean

Arguments and Values::

predicate—a designator for a function of as many arguments as there are sequences.

sequence—a sequence.

result—an object.

generalized-boolean—a generalized boolean.

Description::

every, some, notevery, and notany test elements of sequences for satisfaction of a given predicate. The first argument to predicate is an element of the first sequence; each succeeding argument is an element of a succeeding sequence.

Predicate is first applied to the elements with index 0 in each of the sequences, and possibly then to the elements with index 1, and so on, until a termination criterion is met or the end of the shortest of the sequences is reached.

every returns false as soon as any invocation of predicate returns false. If the end of a sequence is reached, every returns true. Thus, every returns true if and only if every invocation of predicate returns true.

some returns the first non-nil value which is returned by an invocation of predicate. If the end of a sequence is reached without any invocation of the predicate returning true, some returns false. Thus, some returns true if and only if some invocation of predicate returns true.

notany returns false as soon as any invocation of predicate returns true. If the end of a sequence is reached, notany returns true. Thus, notany returns true if and only if it is not the case that any invocation of predicate returns true.

notevery returns true as soon as any invocation of predicate returns false. If the end of a sequence is reached, notevery returns false. Thus, notevery returns true if and only if it is not the case that every invocation of predicate returns true.

Examples::

 (every #'characterp "abc") ⇒  true
 (some #'= '(1 2 3 4 5) '(5 4 3 2 1)) ⇒  true
 (notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) ⇒  false
 (notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) ⇒  true

Exceptional Situations::

Should signal type-error if its first argument is neither a symbol nor a function or if any subsequent argument is not a proper sequence.

Other exceptional situations are possible, depending on the nature of the predicate.

See Also::

and , or ,

Traversal Rules and Side Effects

Notes::

 (notany predicate {sequence}*) ≡ (not (some predicate {sequence}*))
 (notevery predicate {sequence}*) ≡ (not (every predicate {sequence}*))

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Examples-of-WHEN-clause.html0000644000175000017500000000676714360276512017572 0ustar cammcamm Examples of WHEN clause (ANSI and GNU Common Lisp Document)

Previous: , Up: Conditional Execution Clauses  

6.1.6.1 Examples of WHEN clause

;; Signal an exceptional condition.
 (loop for item in '(1 2 3 a 4 5)
       when (not (numberp item))
        return (cerror "enter new value" "non-numeric value: ~s" item))
Error: non-numeric value: A

;; The previous example is equivalent to the following one.
 (loop for item in '(1 2 3 a 4 5)
       when (not (numberp item))
        do (return 
            (cerror "Enter new value" "non-numeric value: ~s" item)))
Error: non-numeric value: A

;; This example parses a simple printed string representation from 
;; BUFFER (which is itself a string) and returns the index of the
;; closing double-quote character.
 (let ((buffer "\"a\" \"b\""))
   (loop initially (unless (char= (char buffer 0) #\")
                     (loop-finish))
         for i of-type fixnum from 1 below (length (the string buffer))
         when (char= (char buffer i) #\")
          return i))
⇒  2

;; The collected value is returned.
 (loop for i from 1 to 10
       when (> i 5)
         collect i
       finally (prin1 'got-here))
 |>  GOT-HERE
⇒  (6 7 8 9 10) 

;; Return both the count of collected numbers and the numbers.
 (loop for i from 1 to 10
       when (> i 5)
         collect i into number-list
         and count i into number-count
       finally (return (values number-count number-list)))
⇒  5, (6 7 8 9 10)
gcl-2.6.14/info/gcl/Simple-Loop.html0000644000175000017500000000520014360276512015516 0ustar cammcamm Simple Loop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.2 Simple Loop

A simple loop form is one that has a body containing only compound forms. Each form is evaluated in turn from left to right. When the last form has been evaluated, then the first form is evaluated again, and so on, in a never-ending cycle. A simple loop form establishes an implicit block named nil. The execution of a simple loop can be terminated by explicitly transfering control to the implicit block (using return or return-from) or to some exit point outside of the block (e.g., using throw, go, or return-from).

gcl-2.6.14/info/gcl/Array-Concepts.html0000644000175000017500000000434114360276512016215 0ustar cammcamm Array Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays  

15.1 Array Concepts

• Array Elements  
• Specialized Arrays  
gcl-2.6.14/info/gcl/special_002doperator_002dp.html0000644000175000017500000000640614360276512020215 0ustar cammcamm special-operator-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.29 special-operator-p [Function]

special-operator-p symbol ⇒ generalized-boolean

Arguments and Values::

symbol—a symbol.

generalized-boolean—a generalized boolean.

Description::

Returns true if symbol is a special operator; otherwise, returns false.

Examples::

 (special-operator-p 'if) ⇒  true
 (special-operator-p 'car) ⇒  false
 (special-operator-p 'one) ⇒  false

Exceptional Situations::

Should signal type-error if its argument is not a symbol.

Notes::

Historically, this function was called special-form-p. The name was finally declared a misnomer and changed, since it returned true for special operators, not special forms.

gcl-2.6.14/info/gcl/Floating_002dpoint-Computations.html0000644000175000017500000000636614360276512021421 0ustar cammcamm Floating-point Computations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.4 Floating-point Computations

The following rules apply to floating point computations.

• Rule of Float and Rational Contagion  
• Examples of Rule of Float and Rational Contagion  
• Rule of Float Approximation  
• Rule of Float Underflow and Overflow  
• Rule of Float Precision Contagion  
gcl-2.6.14/info/gcl/Printing-Other-Vectors.html0000644000175000017500000000725714360276512017670 0ustar cammcamm Printing Other Vectors (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.15 Printing Other Vectors

If *print-array* is true and *print-readably* is false, any

vector other than a string or bit vector is printed using general-vector syntax; this means that information about specialized vector representations does not appear. The printed representation of a zero-length vector is #(). The printed representation of a non-zero-length vector begins with #(. Following that, the first element of the vector is printed.

If there are any other elements, they are printed in turn, with each such additional element preceded by a space if *print-pretty* is false, or whitespace_1 if *print-pretty* is true.

A right-parenthesis after the last element terminates the printed representation of the vector. The printing of vectors is affected by *print-level* and *print-length*. If the vector has a fill pointer, then only those elements below the fill pointer are printed.

If both *print-array* and *print-readably* are false,

the vector is not printed as described above, but in a format (using #<) that is concise but not readable.

If *print-readably* is true, the vector prints in an implementation-defined manner; see the variable *print-readably*.

For information on how the Lisp reader parses these “other vectors,” see Sharpsign Left-Parenthesis.

gcl-2.6.14/info/gcl/apply.html0000644000175000017500000001167314360276512014516 0ustar cammcamm apply (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.1 apply [Function]

apply function &rest args^+ ⇒ {result}*

Arguments and Values::

function—a function designator.

args—a spreadable argument list designator.

results—the values returned by function.

Description::

Applies the function to the args.

When the function receives its arguments via &rest, it is permissible (but not required) for the implementation to bind the rest parameter to an object that shares structure with the last argument to apply. Because a function can neither detect whether it was called via apply nor whether (if so) the last argument to apply was a constant, conforming programs must neither rely on the list structure of a rest list to be freshly consed, nor modify that list structure.

setf can be used with apply in certain circumstances; see APPLY Forms as Places.

Examples::

 (setq f '+) ⇒  +
 (apply f '(1 2)) ⇒  3
 (setq f #'-) ⇒  #<FUNCTION ->
 (apply f '(1 2)) ⇒  -1
 (apply #'max 3 5 '(2 7 3)) ⇒  7
 (apply 'cons '((+ 2 3) 4)) ⇒  ((+ 2 3) . 4)
 (apply #'+ '()) ⇒  0

 (defparameter *some-list* '(a b c))
 (defun strange-test (&rest x) (eq x *some-list*))
 (apply #'strange-test *some-list*) ⇒  implementation-dependent

 (defun bad-boy (&rest x) (rplacd x 'y))
 (bad-boy 'a 'b 'c) has undefined consequences.
 (apply #'bad-boy *some-list*) has undefined consequences.

 (defun foo (size &rest keys &key double &allow-other-keys)
   (let ((v (apply #'make-array size :allow-other-keys t keys)))
     (if double (concatenate (type-of v) v v) v)))
 (foo 4 :initial-contents '(a b c d) :double t)
    ⇒  #(A B C D A B C D)

See Also::

funcall , fdefinition , function, Evaluation, APPLY Forms as Places

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/broadcast_002dstream.html0000644000175000017500000001365614360276512017277 0ustar cammcamm broadcast-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.2 broadcast-stream [System Class]

Class Precedence List::

broadcast-stream, stream, t

Description::

A broadcast stream is an output stream which has associated with it a set of zero or more output streams such that any output sent to the broadcast stream gets passed on as output to each of the associated output streams. (If a broadcast stream has no component streams, then all output to the broadcast stream is discarded.)

The set of operations that may be performed on a broadcast stream is the intersection of those for its associated output streams.

Some output operations (e.g., fresh-line) return values based on the state of the stream at the time of the operation.

Since these values might differ for each of the component streams, it is necessary to describe their return value specifically:

*

stream-element-type returns the value from the last component stream, or t if there are no component streams.

*

fresh-line returns the value from the last component stream, or nil if there are no component streams.

*

The functions file-length, file-position, file-string-length, and stream-external-format return the value from the last component stream; if there are no component streams, file-length and file-position return 0, file-string-length returns 1, and stream-external-format returns :default.

*

The functions streamp and output-stream-p always return true for broadcast streams.

*

The functions open-stream-p tests whether the broadcast stream is open_2, not whether its component streams are open.

*

The functions input-stream-p and interactive-stream-p return an implementation-defined, generalized boolean value.

*

For the input operations clear-input listen, peek-char, read-byte, read-char-no-hang, read-char, read-line, and unread-char, the consequences are undefined if the indicated operation is performed. However, an implementation is permitted to define such a behavior as an implementation-dependent extension.

For any output operations not having their return values explicitly specified above or elsewhere in this document, it is defined that the values returned by such an operation are the values resulting from performing the operation on the last of its component streams; the values resulting from performing the operation on all preceding streams are discarded. If there are no component streams, the value is implementation-dependent.

See Also::

broadcast-stream-streams , make-broadcast-stream

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/Definitions-of-Make_002dInstance-and-Initialize_002dInstance.html0000644000175000017500000001040714360276512026376 0ustar cammcamm Definitions of Make-Instance and Initialize-Instance (ANSI and GNU Common Lisp Document)

Previous: , Up: Object Creation and Initialization  

7.1.7 Definitions of Make-Instance and Initialize-Instance

The generic function make-instance behaves as if it were defined as follows, except that certain optimizations are permitted: 

 (defmethod make-instance ((class standard-class) &rest initargs)
   ...
   (let ((instance (apply #'allocate-instance class initargs)))
     (apply #'initialize-instance instance initargs)
     instance))

 (defmethod make-instance ((class-name symbol) &rest initargs)
   (apply #'make-instance (find-class class-name) initargs))

The elided code in the definition of make-instance augments the initargs with any defaulted initialization arguments and checks the resulting initialization arguments to determine whether an initialization argument was supplied that neither filled a slot nor supplied an argument to an applicable method.

The generic function initialize-instance behaves as if it were defined as follows, except that certain optimizations are permitted: 

 (defmethod initialize-instance ((instance standard-object) &rest initargs)
   (apply #'shared-initialize instance t initargs)))

These procedures can be customized.

Customizing at the Programmer Interface level includes using the :initform, :initarg, and :default-initargs options to defclass, as well as defining methods for make-instance, allocate-instance, and initialize-instance. It is also possible to define methods for shared-initialize, which would be invoked by the generic functions reinitialize-instance, update-instance-for-redefined-class, update-instance-for-different-class, and initialize-instance. The meta-object level supports additional customization.

Implementations are permitted to make certain optimizations to initialize-instance and shared-initialize. The description of shared-initialize in Chapter~7 mentions the possible optimizations.

gcl-2.6.14/info/gcl/Unrecognized-Keyword-Arguments.html0000644000175000017500000000513114360276512021402 0ustar cammcamm Unrecognized Keyword Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.5 Unrecognized Keyword Arguments

It is not permitted to supply a keyword argument to a function using a name that is not recognized by that function unless keyword argument checking is suppressed as described in Suppressing Keyword Argument Checking.

If this situation occurs in a safe call,

an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/compiled_002dfunction_002dp.html0000644000175000017500000000725014360276512020361 0ustar cammcamm compiled-function-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.11 compiled-function-p [Function]

compiled-function-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type compiled-function; otherwise, returns false.

Examples::

 (defun f (x) x) ⇒  F
 (compiled-function-p #'f)
⇒  false
OR⇒ true
 (compiled-function-p 'f) ⇒  false
 (compile 'f) ⇒  F
 (compiled-function-p #'f) ⇒  true
 (compiled-function-p 'f) ⇒  false
 (compiled-function-p (compile nil '(lambda (x) x)))
⇒  true
 (compiled-function-p #'(lambda (x) x))
⇒  false
OR⇒ true
 (compiled-function-p '(lambda (x) x)) ⇒  false

See Also::

compile , compile-file , compiled-function

Notes::

 (compiled-function-p object) ≡ (typep object 'compiled-function)
gcl-2.6.14/info/gcl/set_002dmacro_002dcharacter.html0000644000175000017500000001357114360276512020334 0ustar cammcamm set-macro-character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.10 set-macro-character, get-macro-character [Function]

get-macro-character char &optional readtable ⇒ function, non-terminating-p

set-macro-character char new-function &optional non-terminating-p readtable ⇒ t

Arguments and Values::

char—a character.

non-terminating-p—a generalized boolean. The default is false.

readtable—a readtable designator.

The default is the current readtable.

function—nil, or a designator for a function of two arguments.

new-function—a function designator.

Description::

get-macro-character returns as its primary value, function, the reader macro function associated with char in readtable (if any), or else nil if char is not a macro character in readtable. The secondary value, non-terminating-p, is true if char is a non-terminating macro character; otherwise, it is false.

set-macro-character causes char to be a macro character associated with the reader macro function new-function (or the designator for new-function) in readtable. If non-terminating-p is true, char becomes a non-terminating macro character; otherwise it becomes a terminating macro character.

Examples::

 (get-macro-character #\{) ⇒  NIL, false
 (not (get-macro-character #\;)) ⇒  false

The following is a possible definition for the single-quote reader macro in standard syntax: 

 (defun single-quote-reader (stream char)
   (declare (ignore char))
   (list 'quote (read stream t nil t))) ⇒  SINGLE-QUOTE-READER
 (set-macro-character #\' #'single-quote-reader) ⇒  T

Here single-quote-reader reads an object following the single-quote and returns a list of quote and that object. The char argument is ignored.

The following is a possible definition for the semicolon reader macro in standard syntax: 

 (defun semicolon-reader (stream char)
   (declare (ignore char))
   ;; First swallow the rest of the current input line.
   ;; End-of-file is acceptable for terminating the comment.
   (do () ((char= (read-char stream nil #\Newline t) #\Newline)))
   ;; Return zero values.
   (values)) ⇒  SEMICOLON-READER
 (set-macro-character #\; #'semicolon-reader) ⇒  T

Side Effects::

The readtable is modified.

See Also::

readtable

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/arithmetic_002derror.html0000644000175000017500000000572714360276512017324 0ustar cammcamm arithmetic-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.78 arithmetic-error [Condition Type]

Class Precedence List::

arithmetic-error, error, serious-condition, condition, t

Description::

The type arithmetic-error consists of error conditions that occur during arithmetic operations. The operation and operands are initialized with the initialization arguments named :operation and :operands to make-condition, and are accessed by the functions arithmetic-error-operation and arithmetic-error-operands.

See Also::

arithmetic-error-operation, arithmetic-error-operands

gcl-2.6.14/info/gcl/Rule-of-Float-Substitutability.html0000644000175000017500000001421214360276512021317 0ustar cammcamm Rule of Float Substitutability (ANSI and GNU Common Lisp Document)

Previous: , Up: Rational Computations  

12.1.3.3 Rule of Float Substitutability

When the arguments to an irrational mathematical function

[Reviewer Note by Barmar: There should be a table of these functions.] are all rational and the true mathematical result is also (mathematically) rational, then unless otherwise noted an implementation is free to return either an accurate rational result or a single float approximation. If the arguments are all rational but the result cannot be expressed as a rational number, then a single float approximation is always returned.

If the arguments to a mathematical function are all of type (or rational (complex rational)) and the true mathematical result is (mathematically) a complex number with rational real and imaginary parts, then unless otherwise noted an implementation is free to return either an accurate result of type (or rational (complex rational)) or a single float (permissible only if the imaginary part of the true mathematical result is zero) or (complex single-float). If the arguments are all of type (or rational (complex rational)) but the result cannot be expressed as a rational or complex rational, then the returned value will be of type single-float (permissible only if the imaginary part of the true mathematical result is zero) or (complex single-float). 

  Function  Sample Results                                   
  abs       (abs #c(3 4)) ⇒  5 or 5.0                       
  acos      (acos 1) ⇒  0 or 0.0                            
  acosh     (acosh 1) ⇒  0 or 0.0                           
  asin      (asin 0) ⇒  0 or 0.0                            
  asinh     (asinh 0) ⇒  0 or 0.0                           
  atan      (atan 0) ⇒  0 or 0.0                            
  atanh     (atanh 0) ⇒  0 or 0.0                           
  cis       (cis 0) ⇒  #c(1 0) or #c(1.0 0.0)               
  cos       (cos 0) ⇒  1 or 1.0                             
  cosh      (cosh 0) ⇒  1 or 1.0                            
  exp       (exp 0) ⇒  1 or 1.0                             
  expt      (expt 8 1/3) ⇒  2 or 2.0                        
  log       (log 1) ⇒  0 or 0.0                             
            (log 8 2) ⇒  3 or 3.0                           
  phase     (phase 7) ⇒  0 or 0.0                           
  signum    (signum #c(3 4)) ⇒  #c(3/5 4/5) or #c(0.6 0.8)  
  sin       (sin 0) ⇒  0 or 0.0                             
  sinh      (sinh 0) ⇒  0 or 0.0                            
  sqrt      (sqrt 4) ⇒  2 or 2.0                            
            (sqrt 9/16) ⇒  3/4 or 0.75                      
  tan       (tan 0) ⇒  0 or 0.0                             
  tanh      (tanh 0) ⇒  0 or 0.0                            

  Figure 12–8: Functions Affected by Rule of Float Substitutability

Previous: , Up: Rational Computations  

gcl-2.6.14/info/gcl/truename.html0000644000175000017500000001327214360276512015206 0ustar cammcamm truename (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.4 truename [Function]

truename filespec ⇒ truename

Arguments and Values::

filespec—a pathname designator.

truename—a physical pathname.

Description::

truename tries to find the file indicated by filespec and returns its truename. If the filespec designator is an open stream, its associated file is used.

If filespec is a stream, truename can be used whether the stream is open or closed. It is permissible for truename to return more specific information after the stream is closed than when the stream was open.

If filespec is a pathname it represents the name used to open the file. This may be, but is not required to be, the actual name of the file.

Examples::

;; An example involving version numbers.  Note that the precise nature of
;; the truename is implementation-dependent while the file is still open.
 (with-open-file (stream ">vistor>test.text.newest")
   (values (pathname stream)
           (truename stream)))
⇒  #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1"
OR⇒ #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.newest"
OR⇒ #P"S:>vistor>test.text.newest", #P"S:>vistor>_temp_._temp_.1"

;; In this case, the file is closed when the truename is tried, so the
;; truename information is reliable.
 (with-open-file (stream ">vistor>test.text.newest")
   (close stream)
   (values (pathname stream)
           (truename stream)))
⇒  #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1"

;; An example involving TOP-20's implementation-dependent concept 
;; of logical devices -- in this case, "DOC:" is shorthand for
;; "PS:<DOCUMENTATION>" ...
 (with-open-file (stream "CMUC::DOC:DUMPER.HLP")
   (values (pathname stream)
           (truename stream)))
⇒  #P"CMUC::DOC:DUMPER.HLP", #P"CMUC::PS:<DOCUMENTATION>DUMPER.HLP.13"

Exceptional Situations::

An error of type file-error is signaled if an appropriate file cannot be located within the file system for the given filespec,

or if the file system cannot perform the requested operation.

An error of type file-error is signaled if pathname is wild.

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Notes::

truename may be used to account for any filename translations performed by the file system.

Next: , Previous: , Up: Files Dictionary  

gcl-2.6.14/info/gcl/The-Current-Readtable.html0000644000175000017500000000475114360276512017411 0ustar cammcamm The Current Readtable (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Readtables  

2.1.1.1 The Current Readtable

Several readtables describing different syntaxes can exist, but at any given time only one, called the current readtable , affects the way in which expressions_2 are parsed into objects by the Lisp reader. The current readtable in a given dynamic environment is the value of *readtable* in that environment. To make a different readtable become the current readtable, *readtable* can be assigned or bound.

gcl-2.6.14/info/gcl/reduce.html0000644000175000017500000001453314360276512014636 0ustar cammcamm reduce (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.9 reduce [Function]

reduce function sequence &key key from-end start end initial-value ⇒ result

Arguments and Values::

function—a designator for a function that might be called with either zero or two arguments.

sequence—a proper sequence.

key—a designator for a function of one argument, or nil.

from-end—a generalized boolean. The default is false.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

initial-value—an object.

result—an object.

Description::

reduce uses a binary operation, function, to combine the elements of sequence bounded by start and end.

The function must accept as arguments two elements of sequence or the results from combining those elements. The function must also be able to accept no arguments.

If key is supplied, it is used is used to extract the values to reduce. The key function is applied exactly once to each element of sequence in the order implied by the reduction order but not to the value of initial-value, if supplied.

The key function typically returns part of the element of sequence. If key is not supplied or is nil, the sequence element itself is used.

The reduction is left-associative, unless from-end is true in which case it is right-associative.

If initial-value is supplied, it is logically placed before the subsequence (or after it if from-end is true) and included in the reduction operation.

In the normal case, the result of reduce is the combined result of function’s being applied to successive pairs of elements of sequence. If the subsequence contains exactly one element and no initial-value is given, then that element is returned and function is not called. If the subsequence is empty and an initial-value is given, then the initial-value is returned and function is not called. If the subsequence is empty and no initial-value is given, then the function is called with zero arguments, and reduce returns whatever function does. This is the only case where the function is called with other than two arguments.

Examples::

 (reduce #'* '(1 2 3 4 5)) ⇒  120
 (reduce #'append '((1) (2)) :initial-value '(i n i t)) ⇒  (I N I T 1 2)
 (reduce #'append '((1) (2)) :from-end t                  
                             :initial-value '(i n i t)) ⇒  (1 2 I N I T) 
 (reduce #'- '(1 2 3 4)) ≡ (- (- (- 1 2) 3) 4) ⇒  -8
 (reduce #'- '(1 2 3 4) :from-end t)    ;Alternating sum.
≡ (- 1 (- 2 (- 3 4))) ⇒  -2
 (reduce #'+ '()) ⇒  0
 (reduce #'+ '(3)) ⇒  3
 (reduce #'+ '(foo)) ⇒  FOO
 (reduce #'list '(1 2 3 4)) ⇒  (((1 2) 3) 4)
 (reduce #'list '(1 2 3 4) :from-end t) ⇒  (1 (2 (3 4)))
 (reduce #'list '(1 2 3 4) :initial-value 'foo) ⇒  ((((foo 1) 2) 3) 4)
 (reduce #'list '(1 2 3 4)
        :from-end t :initial-value 'foo) ⇒  (1 (2 (3 (4 foo))))

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

Traversal Rules and Side Effects

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Numbers-as-Tokens.html0000644000175000017500000001061014360276512016634 0ustar cammcamm Numbers as Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpretation of Tokens  

2.3.1 Numbers as Tokens

When a token is read, it is interpreted as a number or symbol. The token is interpreted as a number if it satisfies the syntax for numbers specified in Figure 2–9. 

 numeric-token ::= !integer | !ratio | !float                                              
 integer       ::= [sign] {decimal-digit}^+ decimal-point | [sign] {digit}^+               
 ratio         ::= [sign] {digit}^+ slash {digit}^+                                        
 float         ::= [sign] {decimal-digit}* decimal-point {decimal-digit}^+ [!exponent]   
                   | [sign] {decimal-digit}^+ [decimal-point {decimal-digit}*] !exponent 
 exponent      ::= exponent-marker [sign] {digit}^+                                        
 sign—a sign.
 slash—a slash
 decimal-point—a dot.
 exponent-marker—an exponent marker.
 decimal-digit—a digit in radix 10.
 digit—a digit in the current input radix.

  Figure 2–9: Syntax for Numeric Tokens

• Potential Numbers as Tokens  
• Escape Characters and Potential Numbers  
• Examples of Potential Numbers  
gcl-2.6.14/info/gcl/base_002dchar.html0000644000175000017500000001150314360276512015656 0ustar cammcamm base-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.2 base-char [Type]

Supertypes::

base-char, character, t

Description::

The type base-char is defined as the upgraded array element type of standard-char. An implementation can support additional subtypes of type character (besides the ones listed in this standard) that might or might not be supertypes of type base-char. In addition, an implementation can define base-char to be the same type as character.

Base characters are distinguished in the following respects:

1.

The type standard-char is a subrepertoire of the type base-char.

2.

The selection of base characters that are not standard characters is implementation defined.

3.

Only objects of the type base-char can be elements of a base string.

4.

No upper bound is specified for the number of characters in the base-char repertoire; the size of that repertoire is implementation-defined. The lower bound is~96, the number of standard characters.

Whether a character is a base character depends on the way that an implementation represents strings, and not any other properties of the implementation or the host operating system. For example, one implementation might encode all strings as characters having 16-bit encodings, and another might have two kinds of strings: those with characters having 8-bit encodings and those with characters having 16-bit encodings. In the first implementation, the type base-char is equivalent to the type character: there is only one kind of string. In the second implementation, the base characters might be those characters that could be stored in a string of characters having 8-bit encodings. In such an implementation, the type base-char is a proper subtype of the type character.

The type standard-char is a

subtype of type base-char.

Next: , Previous: , Up: Characters Dictionary  

gcl-2.6.14/info/gcl/remf.html0000644000175000017500000000754514360276512014325 0ustar cammcamm remf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.42 remf [Macro]

remf place indicator ⇒ generalized-boolean

Arguments and Values::

place—a place.

indicator—an object.

generalized-boolean—a generalized boolean.

Description::

remf removes from the property list stored in place a property_1 with a property indicator identical to indicator.

If there are multiple properties_1 with the identical key, remf only removes the first such property.

remf returns false if no such property was found, or true if a property was found.

The property indicator and the corresponding property value are removed in an undefined order by destructively splicing the property list.

remf is permitted to either setf place or to setf any part, car or cdr, of the list structure held by that place.

For information about the evaluation of subforms of place, see Evaluation of Subforms to Places.

Examples::

 (setq x (cons () ())) ⇒  (NIL)
 (setf (getf (car x) 'prop1) 'val1) ⇒  VAL1
 (remf (car x) 'prop1) ⇒  true
 (remf (car x) 'prop1) ⇒  false

Side Effects::

The property list stored in place is modified.

See Also::

remprop , getf

gcl-2.6.14/info/gcl/Structures-Dictionary.html0000644000175000017500000000427314360276512017655 0ustar cammcamm Structures Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Structures  

8.1 Structures Dictionary

• defstruct  
• copy-structure  
gcl-2.6.14/info/gcl/Examples-of-Rule-of-Float-and-Rational-Contagion.html0000644000175000017500000000606514360276512024350 0ustar cammcamm Examples of Rule of Float and Rational Contagion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Floating-point Computations  

12.1.4.2 Examples of Rule of Float and Rational Contagion

 ;;;; Combining rationals with floats.
 ;;; This example assumes an implementation in which 
 ;;; (float-radix 0.5) is 2 (as in IEEE) or 16 (as in IBM/360),
 ;;; or else some other implementation in which 1/2 has an exact 
 ;;;  representation in floating point.
 (+ 1/2 0.5) ⇒  1.0
 (- 1/2 0.5d0) ⇒  0.0d0
 (+ 0.5 -0.5 1/2) ⇒  0.5

 ;;;; Comparing rationals with floats.
 ;;; This example assumes an implementation in which the default float 
 ;;; format is IEEE single-float, IEEE double-float, or some other format
 ;;; in which 5/7 is rounded upwards by FLOAT.
 (< 5/7 (float 5/7)) ⇒  true
 (< 5/7 (rational (float 5/7))) ⇒  true
 (< (float 5/7) (float 5/7)) ⇒  false
gcl-2.6.14/info/gcl/Order-of-Execution.html0000644000175000017500000001066614360276512017010 0ustar cammcamm Order of Execution (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.14 Order of Execution

With the exceptions listed below, clauses are executed in the loop body in the order in which they appear in the source. Execution is repeated until a clause terminates the loop or until a return, go, or throw form is encountered which transfers control to a point outside of the loop. The following actions are exceptions to the linear order of execution:

*

All variables are initialized first, regardless of where the establishing clauses appear in the source. The order of initialization follows the order of these clauses.

*

The code for any initially clauses is collected into one progn in the order in which the clauses appear in the source. The collected code is executed once in the loop prologue after any implicit variable initializations.

*

The code for any finally clauses is collected into one progn in the order in which the clauses appear in the source. The collected code is executed once in the loop epilogue before any implicit values from the accumulation clauses are returned. Explicit returns anywhere in the source, however, will exit the loop without executing the epilogue code.

*

A with clause introduces a variable binding and an optional initial value. The initial values are calculated in the order in which the with clauses occur.

*

Iteration control clauses implicitly perform the following actions:

–

initialize variables;

–

step variables, generally between each execution of the loop body;

–

perform termination tests, generally just before the execution of the loop body.

Next: , Previous: , Up: Overview of the Loop Facility  

gcl-2.6.14/info/gcl/Pretty-Printer-Margins.html0000644000175000017500000000447314360276512017677 0ustar cammcamm Pretty Printer Margins (ANSI and GNU Common Lisp Document)

Previous: , Up: Pretty Printer Concepts  

22.2.1.5 Pretty Printer Margins

A primary goal of pretty printing is to keep the output between a pair of margins. The column where the output begins is taken as the left margin. If the current column cannot be determined at the time output begins, the left margin is assumed to be zero. The right margin is controlled by *print-right-margin*.

gcl-2.6.14/info/gcl/Tilde-Greater_002dThan_002dSign_002d_003e-End-of-Justification.html0000644000175000017500000000450414360276512026115 0ustar cammcamm Tilde Greater-Than-Sign-> End of Justification (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Layout Control  

22.3.6.3 Tilde Greater-Than-Sign: End of Justification

~> terminates a ~<. The consequences of using it elsewhere are undefined.

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Version-Component.html0000644000175000017500000000642514360276512025743 0ustar cammcamm Restrictions on Examining a Pathname Version Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.19 Restrictions on Examining a Pathname Version Component

The version can be any symbol or any integer.

The symbol :newest refers to the largest version number that already exists in the file system when reading, overwriting, appending, superseding, or directory listing an existing file. The symbol :newest refers to the smallest version number greater than any existing version number when creating a new file.

The symbols nil, :unspecific, and :wild have special meanings and restrictions; see Special Pathname Component Values and Restrictions on Constructing Pathnames.

Other symbols and integers have implementation-defined meaning.

gcl-2.6.14/info/gcl/list_002dlength.html0000644000175000017500000001042014360276512016260 0ustar cammcamm list-length (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.16 list-length [Function]

list-length list ⇒ length

Arguments and Values::

list—a proper list or a circular list.

length—a non-negative integer, or nil.

Description::

Returns the length of list if list is a proper list. Returns nil if list is a circular list.

Examples::

 (list-length '(a b c d)) ⇒  4
 (list-length '(a (b c) d)) ⇒  3
 (list-length '()) ⇒  0
 (list-length nil) ⇒  0
 (defun circular-list (&rest elements)
   (let ((cycle (copy-list elements))) 
     (nconc cycle cycle)))
 (list-length (circular-list 'a 'b)) ⇒  NIL
 (list-length (circular-list 'a)) ⇒  NIL
 (list-length (circular-list)) ⇒  0

Exceptional Situations::

Should signal an error of type type-error if list is not a proper list or a circular list.

See Also::

length

Notes::

list-length could be implemented as follows: 

 (defun list-length (x)  
   (do ((n 0 (+ n 2))           ;Counter.
        (fast x (cddr fast))    ;Fast pointer: leaps by 2.
        (slow x (cdr slow)))    ;Slow pointer: leaps by 1.
       (nil)
     ;; If fast pointer hits the end, return the count.
     (when (endp fast) (return n))
     (when (endp (cdr fast)) (return (+ n 1)))
     ;; If fast pointer eventually equals slow pointer,
     ;;  then we must be stuck in a circular list.
     ;; (A deeper property is the converse: if we are
     ;;  stuck in a circular list, then eventually the
     ;;  fast pointer will equal the slow pointer.
     ;;  That fact justifies this implementation.)
     (when (and (eq fast slow) (> n 0)) (return nil))))
gcl-2.6.14/info/gcl/subsetp.html0000644000175000017500000001207014360276512015046 0ustar cammcamm subsetp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.48 subsetp [Function]

subsetp list-1 list-2 &key key test test-not ⇒ generalized-boolean

Arguments and Values::

list-1—a proper list.

list-2—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

generalized-boolean—a generalized boolean.

Description::

subsetp returns true if every element of list-1 matches some element of list-2, and false otherwise.

Whether a list element is the same as another list element is determined by the functions specified by the keyword arguments. The first argument to the :test or :test-not function is typically part of an element of list-1 extracted by the :key function; the second argument is typically part of an element of list-2 extracted by the :key function.

The argument to the :key function is an element of either list-1 or list-2; the return value is part of the element of the supplied list element. If :key is not supplied or nil, the list-1 or list-2 element itself is supplied to the :test or :test-not function.

Examples::

 (setq cosmos '(1 "a" (1 2))) ⇒  (1 "a" (1 2))
 (subsetp '(1) cosmos) ⇒  true
 (subsetp '((1 2)) cosmos) ⇒  false
 (subsetp '((1 2)) cosmos :test 'equal) ⇒  true
 (subsetp '(1 "A") cosmos :test #'equalp) ⇒  true
 (subsetp '((1) (2)) '((1) (2))) ⇒  false
 (subsetp '((1) (2)) '((1) (2)) :key #'car) ⇒  true

Exceptional Situations::

Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists.

See Also::

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Valid-Patterns-for-Tokens.html0000644000175000017500000001603414360276512020247 0ustar cammcamm Valid Patterns for Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpretation of Tokens  

2.3.5 Valid Patterns for Tokens

The valid patterns for tokens are summarized in Figure 2–17. 

  nnnnn              a number                                           
  xxxxx              a symbol in the current package                    
  :xxxxx             a symbol in the the KEYWORD package                
  ppppp:xxxxx        an external symbol in the ppppp package            
  ppppp::xxxxx       a (possibly internal) symbol in the ppppp package  
  :nnnnn             undefined                                          
  ppppp:nnnnn        undefined                                          
  ppppp::nnnnn       undefined                                          
  ::aaaaa            undefined                                          
  aaaaa:             undefined                                          
  aaaaa:aaaaa:aaaaa  undefined                                          

                 Figure 2–17: Valid patterns for tokens

Note that nnnnn has number syntax, neither xxxxx nor ppppp has number syntax, and aaaaa has any syntax.

A summary of rules concerning package markers follows. In each case, examples are offered to illustrate the case; for presentational simplicity, the examples assume that the readtable case of the current readtable is :upcase.

1.

If there is a single package marker, and it occurs at the beginning of the token, then the token is interpreted as a symbol in the KEYWORD package. It also sets the symbol-value of the newly-created symbol to that same symbol so that the symbol will self-evaluate.

For example, :bar, when read, interns BAR as an external symbol in the KEYWORD package.

2.

If there is a single package marker not at the beginning or end of the token, then it divides the token into two parts. The first part specifies a package; the second part is the name of an external symbol available in that package.

For example, foo:bar, when read, looks up BAR among the external symbols of the package named FOO.

3.

If there are two adjacent package markers not at the beginning or end of the token, then they divide the token into two parts. The first part specifies a package; the second part is the name of a symbol within that package (possibly an internal symbol).

For example, foo::bar, when read, interns BAR in the package named FOO.

4.

If the token contains no package markers, and does not have potential number syntax, then the entire token is the name of the symbol. The symbol is looked up in the current package.

For example, bar, when read, interns BAR in the current package.

5.

The consequences are unspecified if any other pattern of package markers in a token is used. All other uses of package markers within names of symbols are not defined by this standard but are reserved for implementation-dependent use.

For example, assuming the readtable case of the current readtable is :upcase, editor:buffer refers to the external symbol named BUFFER present in the package named editor, regardless of whether there is a symbol named BUFFER in the current package. If there is no package named editor, or if no symbol named BUFFER is present in editor, or if BUFFER is not exported by editor, the reader signals a correctable error. If editor::buffer is seen, the effect is exactly the same as reading buffer with the EDITOR package being the current package.

Next: , Previous: , Up: Interpretation of Tokens  

gcl-2.6.14/info/gcl/Examples-of-Suppressing-Keyword-Argument-Checking.html0000644000175000017500000000634214360276512025001 0ustar cammcamm Examples of Suppressing Keyword Argument Checking (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.6 Examples of Suppressing Keyword Argument Checking

;;; The caller can supply :ALLOW-OTHER-KEYS T to suppress checking.
 ((lambda (&key x) x) :x 1 :y 2 :allow-other-keys t) ⇒  1
;;; The callee can use &ALLOW-OTHER-KEYS to suppress checking.
 ((lambda (&key x &allow-other-keys) x) :x 1 :y 2) ⇒  1
;;; :ALLOW-OTHER-KEYS NIL is always permitted.
 ((lambda (&key) t) :allow-other-keys nil) ⇒  T
;;; As with other keyword arguments, only the left-most pair
;;; named :ALLOW-OTHER-KEYS has any effect.
 ((lambda (&key x) x) 
  :x 1 :y 2 :allow-other-keys t :allow-other-keys nil)
⇒  1
;;; Only the left-most pair named :ALLOW-OTHER-KEYS has any effect,
;;; so in safe code this signals a PROGRAM-ERROR (and might enter the
;;; debugger).  In unsafe code, the consequences are undefined.
 ((lambda (&key x) x)                   ;This call is not valid
  :x 1 :y 2 :allow-other-keys nil :allow-other-keys t)
gcl-2.6.14/info/gcl/pairlis.html0000644000175000017500000001025514360276512015027 0ustar cammcamm pairlis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.38 pairlis [Function]

pairlis keys data &optional alist ⇒ new-alist

Arguments and Values::

keys—a proper list.

data—a proper list.

alist—an association list. The default is the empty list.

new-alist—an association list.

Description::

Returns an association list that associates elements of keys to corresponding elements of data. The consequences are undefined if keys and data are not of the same length.

If alist is supplied, pairlis returns a modified alist with the new pairs prepended to it. The new pairs may appear in the resulting association list in either forward or backward order. The result of 

 (pairlis '(one two) '(1 2) '((three . 3) (four . 19)))

might be 

 ((one . 1) (two . 2) (three . 3) (four . 19))

or 

 ((two . 2) (one . 1) (three . 3) (four . 19))

Examples::

 (setq keys '(1 2 3)
        data '("one" "two" "three")
        alist '((4 . "four"))) ⇒  ((4 . "four"))
 (pairlis keys data) ⇒  ((3 . "three") (2 . "two") (1 . "one"))
 (pairlis keys data alist)
⇒  ((3 . "three") (2 . "two") (1 . "one") (4 . "four"))
 alist ⇒  ((4 . "four"))

Exceptional Situations::

Should be prepared to signal an error of type type-error if keys and data are not proper lists.

See Also::

acons

gcl-2.6.14/info/gcl/Language-Subsets.html0000644000175000017500000000521214360276512016532 0ustar cammcamm Language Subsets (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.7 Language Subsets

The language described in this standard contains no subsets, though subsets are not forbidden.

For a language to be considered a subset, it must have the property that any valid program in that language has equivalent semantics and will run directly (with no extralingual pre-processing, and no special compatibility packages) in any conforming implementation of the full language.

A language that conforms to this requirement shall be described as being a “subset of Common Lisp as specified by ANSI <<standard number>>.”

gcl-2.6.14/info/gcl/abort-_0028Restart_0029.html0000644000175000017500000000630114360276512017235 0ustar cammcamm abort (Restart) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.41 abort [Restart]

Data Arguments Required::

None.

Description::

The intent of the abort restart is to allow return to the innermost “command level.” Implementors are encouraged to make sure that there is always a restart named abort around any user code so that user code can call abort at any time and expect something reasonable to happen; exactly what the reasonable thing is may vary somewhat. Typically, in an interactive listener, the invocation of abort returns to the Lisp reader phase of the Lisp read-eval-print loop, though in some batch or multi-processing situations there may be situations in which having it kill the running process is more appropriate.

See Also::

Restarts, Interfaces to Restarts, invoke-restart , abort (Function) (function)

gcl-2.6.14/info/gcl/Notes-about-FORMAT.html0000644000175000017500000000477414360276512016563 0ustar cammcamm Notes about FORMAT (ANSI and GNU Common Lisp Document)

Previous: , Up: Formatted Output  

22.3.12 Notes about FORMAT

Formatted output is performed not only by format, but by certain other functions that accept a format control the way format does. For example, error-signaling functions such as cerror accept format controls.

Note that the meaning of nil and t as destinations to format are different than those of nil and t as stream designators.

The ~^ should appear only at the beginning of a ~< clause, because it aborts the entire clause in which it appears (as well as all following clauses).

gcl-2.6.14/info/gcl/The-Pathname-Host-Component.html0000644000175000017500000000424314360276512020512 0ustar cammcamm The Pathname Host Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathname Components  

19.2.1.1 The Pathname Host Component

The name of the file system on which the file resides, or the name of a logical host.

gcl-2.6.14/info/gcl/Condition-Types.html0000644000175000017500000001247014360276512016415 0ustar cammcamm Condition Types (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Condition System Concepts  

9.1.1 Condition Types

Figure 9–1 lists the standardized condition types. Additional condition types can be defined by using define-condition. 

 arithmetic-error                 floating-point-overflow  simple-type-error  
 cell-error                       floating-point-underflow simple-warning     
 condition                        package-error            storage-condition  
 control-error                    parse-error              stream-error       
 division-by-zero                 print-not-readable       style-warning      
 end-of-file                      program-error            type-error         
 error                            reader-error             unbound-slot       
 file-error                       serious-condition        unbound-variable   
 floating-point-inexact           simple-condition         undefined-function 
 floating-point-invalid-operation simple-error             warning            

                    Figure 9–1: Standardized Condition Types

All condition types are subtypes of type condition. That is, 

 (typep c 'condition) ⇒  true

if and only if c is a condition.

Implementations must define all specified subtype relationships. Except where noted, all subtype relationships indicated in this document are not mutually exclusive. A condition inherits the structure of its supertypes.

The metaclass of the class condition is not specified. Names of condition types may be used to specify supertype relationships in define-condition, but the consequences are not specified if an attempt is made to use a condition type as a superclass in a defclass form.

Figure 9–2 shows operators that define condition types and creating conditions. 

  define-condition  make-condition    

  Figure 9–2: Operators that define and create conditions.

Figure 9–3 shows operators that read the value of condition slots. 

  arithmetic-error-operands   simple-condition-format-arguments  
  arithmetic-error-operation  simple-condition-format-control    
  cell-error-name             stream-error-stream                
  file-error-pathname         type-error-datum                   
  package-error-package       type-error-expected-type           
  print-not-readable-object   unbound-slot-instance              

         Figure 9–3: Operators that read condition slots.
• Serious Conditions  
gcl-2.6.14/info/gcl/check_002dtype.html0000644000175000017500000001753414360276512016077 0ustar cammcamm check-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.13 check-type [Macro]

check-type place typespec [string] ⇒ nil

Arguments and Values::

place—a place.

typespec—a type specifier.

string—a string; evaluated.

Description::

check-type signals a correctable error of type type-error if the contents of place are not of the type typespec.

check-type can return only if the store-value restart is invoked, either explicitly from a handler or implicitly as one of the options offered by the debugger. If the store-value restart is invoked, check-type stores the new value that is the argument to the restart invocation (or that is prompted for interactively by the debugger) in place and starts over, checking the type of the new value and signaling another error if it is still not of the desired type.

The first time place is evaluated, it is evaluated by normal evaluation rules. It is later evaluated as a place if the type check fails and the store-value restart is used; see Evaluation of Subforms to Places.

string should be an English description of the type, starting with an indefinite article (“a” or “an”). If string is not supplied, it is computed automatically from typespec. The automatically generated message mentions place, its contents, and the desired type. An implementation may choose to generate a somewhat differently worded error message if it recognizes that place is of a particular form, such as one of the arguments to the function that called check-type. string is allowed because some applications of check-type may require a more specific description of what is wanted than can be generated automatically from typespec.

Examples::

 (setq aardvarks '(sam harry fred))
⇒  (SAM HARRY FRED)
 (check-type aardvarks (array * (3)))
 |>  Error: The value of AARDVARKS, (SAM HARRY FRED),
 |>         is not a 3-long array.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>:CONTINUE 1<<|
 |>  Use Value: |>>#(SAM FRED HARRY)<<|
⇒  NIL
 aardvarks
⇒  #<ARRAY-T-3 13571>
 (map 'list #'identity aardvarks)
⇒  (SAM FRED HARRY)
 (setq aardvark-count 'foo)
⇒  FOO
 (check-type aardvark-count (integer 0 *) "A positive integer")
 |>  Error: The value of AARDVARK-COUNT, FOO, is not a positive integer.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Top level.
 |>  Debug> |>>:CONTINUE 2<<|

 (defmacro define-adder (name amount)
   (check-type name (and symbol (not null)) "a name for an adder function")
   (check-type amount integer)
   `(defun ,name (x) (+ x ,amount)))

 (macroexpand '(define-adder add3 3))
⇒  (defun add3 (x) (+ x 3))

 (macroexpand '(define-adder 7 7))
 |>  Error: The value of NAME, 7, is not a name for an adder function.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Top level.
 |>  Debug> |>>:Continue 1<<|
 |>  Specify a value to use instead.
 |>  Type a form to be evaluated and used instead: |>>'ADD7<<|
⇒  (defun add7 (x) (+ x 7))

 (macroexpand '(define-adder add5 something))
 |>  Error: The value of AMOUNT, SOMETHING, is not an integer.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a value to use instead.
 |>   2: Top level.
 |>  Debug> |>>:Continue 1<<|
 |>  Type a form to be evaluated and used instead: |>>5<<|
⇒  (defun add5 (x) (+ x 5))

Control is transferred to a handler.

Side Effects::

The debugger might be entered.

Affected By::

*break-on-signals*

The implementation.

See Also::

Condition System Concepts

Notes::

 (check-type place typespec)
 ≡ (assert (typep place 'typespec) (place)
            'type-error :datum place :expected-type 'typespec)

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/get_002dsetf_002dexpansion.html0000644000175000017500000001046114360276512020223 0ustar cammcamm get-setf-expansion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.63 get-setf-expansion [Function]

get-setf-expansion place &optional environment
⇒ vars, vals, store-vars, writer-form, reader-form

Arguments and Values::

place—a place.

environment—an environment object.

vars, vals, store-vars, writer-form, reader-form—a setf expansion.

Description::

Determines five values constituting the setf expansion for place in environment; see Setf Expansions.

If environment is not supplied or nil, the environment is the null lexical environment.

Examples::

 (get-setf-expansion 'x)
⇒  NIL, NIL, (#:G0001), (SETQ X #:G0001), X 

;;; This macro is like POP 

 (defmacro xpop (place &environment env)
   (multiple-value-bind (dummies vals new setter getter)
                        (get-setf-expansion place env)
      `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
         (if (cdr new) (error "Can't expand this."))
         (prog1 (car ,(car new))
                (setq ,(car new) (cdr ,(car new)))
                ,setter))))

 (defsetf frob (x) (value) 
     `(setf (car ,x) ,value)) ⇒  FROB
;;; The following is an error; an error might be signaled at macro expansion time
 (flet ((frob (x) (cdr x)))  ;Invalid
   (xpop (frob z)))

See Also::

defsetf , define-setf-expander , setf

Notes::

Any compound form is a valid place, since any compound form whose operator f has no setf expander are expanded into a call to (setf f).

gcl-2.6.14/info/gcl/Introduction-to-Classes.html0000644000175000017500000002064514360276512020064 0ustar cammcamm Introduction to Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.1 Introduction to Classes

A class is an object that determines the structure and behavior of a set of other objects, which are called its instances .

A class can inherit structure and behavior from other classes. A class whose definition refers to other classes for the purpose of inheriting from them is said to be a subclass of each of those classes. The classes that are designated for purposes of inheritance are said to be superclasses of the inheriting class.

A class can have a name. The function class-name takes a class object and returns its name. The name of an anonymous class is nil. A symbol can name a class. The function find-class takes a symbol and returns the class that the symbol names. A class has a proper name if the name is a symbol and if the name of the class names that class. That is, a class~C has the proper name~S if S= (class-name C) and C= (find-class S). Notice that it is possible for (find-class S_1) = (find-class S_2) and S_1!= S_2. If C= (find-class S), we say that C is the class named S.

A class C_1 is a direct superclass of a class C_2 if C_2 explicitly designates C_1 as a superclass in its definition. In this case C_2 is a direct subclass of C_1. A class C_n is a superclass of a class C_1 if there exists a series of classes C_2,...,C_{n-1} such that C_{i+1} is a direct superclass of C_i for 1 <= i<n. In this case, C_1 is a subclass of C_n. A class is considered neither a superclass nor a subclass of itself. That is, if C_1 is a superclass of C_2, then C_1 != C_2. The set of classes consisting of some given class C along with all of its superclasses is called “C and its superclasses.”

Each class has a class precedence list , which is a total ordering on the set of the given class and its superclasses. The total ordering is expressed as a list ordered from most specific to least specific. The class precedence list is used in several ways. In general, more specific classes can shadow _1 features that would otherwise be inherited from less specific classes. The method selection and combination process uses the class precedence list to order methods from most specific to least specific.

When a class is defined, the order in which its direct superclasses are mentioned in the defining form is important. Each class has a local precedence order , which is a list consisting of the class followed by its direct superclasses in the order mentioned in the defining form.

A class precedence list is always consistent with the local precedence order of each class in the list. The classes in each local precedence order appear within the class precedence list in the same order. If the local precedence orders are inconsistent with each other, no class precedence list can be constructed, and an error is signaled. The class precedence list and its computation is discussed in Determining the Class Precedence List.

classes are organized into a directed acyclic graph. There are two distinguished classes, named t and standard-object. The class named t has no superclasses. It is a superclass of every class except itself. The class named standard-object is an instance of the class standard-class and is a superclass of every class that is an instance of the class standard-class except itself.

[Reviewer Note by Barmar: This or something like it needs to be said in the introduction.] There is a mapping from the object system class space into the type space. Many of the standard types specified in this document have a corresponding class that has the same name as the type. Some types do not have a corresponding class. The integration of the type and class systems is discussed in Integrating Types and Classes.

Classes are represented by objects that are themselves instances of classes. The class of the class of an object is termed the metaclass of that object. When no misinterpretation is possible, the term metaclass is used to refer to a class that has instances that are themselves classes. The metaclass determines the form of inheritance used by the classes that are its instances and the representation of the instances of those classes. The object system provides a default metaclass, standard-class, that is appropriate for most programs.

Except where otherwise specified, all classes mentioned in this standard are instances of the class standard-class, all generic functions are instances of the class standard-generic-function, and all methods are instances of the class standard-method.

• Standard Metaclasses  

Next: , Previous: , Up: Classes  

gcl-2.6.14/info/gcl/step.html0000644000175000017500000000710214360276512014334 0ustar cammcamm step (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.9 step [Macro]

step form ⇒ {result}*

Arguments and Values::

form—a form; evaluated as described below.

results—the values returned by the form.

Description::

step implements a debugging paradigm wherein the programmer is allowed to step through the evaluation of a form. The specific nature of the interaction,

including which I/O streams are used and whether the stepping has lexical or dynamic scope,

is implementation-defined.

step evaluates form in the current environment. A call to step can be compiled, but it is acceptable for an implementation to interactively step through only those parts of the computation that are interpreted.

It is technically permissible for a conforming implementation to take no action at all other than normal execution of the form. In such a situation, (step form) is equivalent to, for example, (let () form). In implementations where this is the case, the associated documentation should mention that fact.

See Also::

trace

Notes::

Implementations are encouraged to respond to the typing of ? or the pressing of a “help key” by providing help including a list of commands.

gcl-2.6.14/info/gcl/Language-Extensions.html0000644000175000017500000001134414360276512017244 0ustar cammcamm Language Extensions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.6 Language Extensions

A language extension is any documented implementation-defined behavior of a defined name in this standard that varies from the behavior described in this standard, or a documented consequence of a situation that the standard specifies as undefined, unspecified, or extendable by the implementation. For example, if this standard says that “the results are unspecified,” an extension would be to specify the results.

[Reviewer Note by Barmar: This contradicts previous definitions of conforming code.] If the correct behavior of a program depends on the results provided by an extension, only implementations with the same extension will execute the program correctly. Note that such a program might be non-conforming. Also, if this standard says that “an implementation may be extended,” a conforming, but possibly non-portable, program can be written using an extension.

An implementation can have extensions, provided they do not alter the behavior of conforming code and provided they are not explicitly prohibited by this standard.

The term “extension” refers only to extensions available upon startup. An implementation is free to allow or prohibit redefinition of an extension.

The following list contains specific guidance to implementations concerning certain types of extensions.

Extra return values

An implementation must return exactly the number of return values specified by this standard unless the standard specifically indicates otherwise.

Unsolicited messages

No output can be produced by a function other than that specified in the standard or due to the signaling of conditions detected by the function.

Unsolicited output, such as garbage collection notifications and autoload heralds, should not go directly to the stream that is the value of a stream variable defined in this standard, but can go indirectly to terminal I/O by using a synonym stream to *terminal-io*.

Progress reports from such functions as load and compile are considered solicited, and are not covered by this prohibition.

Implementation of macros and special forms

Macros and special operators defined in this standard must not be functions.

Next: , Previous: , Up: Introduction (Introduction)  

gcl-2.6.14/info/gcl/Variable-Names-as-Places.html0000644000175000017500000000416414360276512017762 0ustar cammcamm Variable Names as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.1 Variable Names as Places

The name of a lexical variable or dynamic variable can be used as a place.

gcl-2.6.14/info/gcl/Satisfying-a-One_002dArgument-Test.html0000644000175000017500000001163314360276512021607 0ustar cammcamm Satisfying a One-Argument Test (ANSI and GNU Common Lisp Document)

Previous: , Up: Rules about Test Functions  

17.2.2 Satisfying a One-Argument Test

When using one of the functions in Figure 17–3, the elements E of a sequence S are filtered not on the basis of the presence or absence of an object O under a two argument predicate, as with the functions described in Satisfying a Two-Argument Test, but rather on the basis of a one argument predicate. 

  assoc-if       member-if           rassoc-if          
  assoc-if-not   member-if-not       rassoc-if-not      
  count-if       nsubst-if           remove-if          
  count-if-not   nsubst-if-not       remove-if-not      
  delete-if      nsubstitute-if      subst-if           
  delete-if-not  nsubstitute-if-not  subst-if-not       
  find-if        position-if         substitute-if      
  find-if-not    position-if-not     substitute-if-not  

  Figure 17–3: Operators that have One-Argument Tests to be Satisfied

The element E_i might not be considered directly. If a :key argument is provided, it is a designator for a function of one argument to be called with each E_i as an argument, and yielding an object Z_i to be used for comparison. (If there is no :key argument, Z_i is E_i.)

Functions defined in this specification and having a name that ends in “-if” accept a first argument that is a designator for a function of one argument, Z_i. An E_i is said to satisfy the test if this :test function returns a generalized boolean representing true.

Functions defined in this specification and having a name that ends in “-if-not” accept a first argument that is a designator for a function of one argument, Z_i. An E_i is said to satisfy the test if this :test function returns a generalized boolean representing false.

• Examples of Satisfying a One-Argument Test  

Previous: , Up: Rules about Test Functions  

gcl-2.6.14/info/gcl/Control-Transfer-Clauses.html0000644000175000017500000000554014360276512020164 0ustar cammcamm Control Transfer Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Miscellaneous Clauses  

6.1.7.1 Control Transfer Clauses

The named construct establishes a name for an implicit block surrounding the

entire

loop so that the return-from special operator can be used to return values from or to exit loop. Only one name per loop form can be assigned. If used, the named construct must be the first clause in the loop expression.

The return construct takes one form. Any values returned by the form are immediately returned by the loop form.

This construct is similar to the return-from special operator and the return macro. The return construct

does not execute any finally clause that

the loop form

is given.

gcl-2.6.14/info/gcl/union.html0000644000175000017500000001463714360276512014524 0ustar cammcamm union (ANSI and GNU Common Lisp Document)

Previous: , Up: Conses Dictionary  

14.2.49 union, nunion [Function]

union list-1 list-2 &key key test test-not ⇒ result-list

nunion list-1 list-2 &key key test test-not ⇒ result-list

Arguments and Values::

list-1—a proper list.

list-2—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

result-list—a list.

Description::

union and nunion return a list that contains every element that occurs in either list-1 or list-2.

For all possible ordered pairs consisting of one element from list-1 and one element from list-2, :test or :test-not is used to determine whether they satisfy the test. The first argument to the :test or :test-not function is the part of the element of list-1 extracted by the :key function (if supplied); the second argument is the part of the element of list-2 extracted by the :key function (if supplied).

The argument to the :key function is an element of list-1 or list-2; the return value is part of the supplied element. If :key is not supplied or nil, the element of list-1 or list-2 itself is supplied to the :test or :test-not function.

For every matching pair, one of the two elements of the pair will be in the result. Any element from either list-1 or list-2 that matches no element of the other will appear in the result.

If there is a duplication between list-1 and list-2, only one of the duplicate instances will be in the result. If either list-1 or list-2 has duplicate entries within it, the redundant entries might or might not appear in the result.

The order of elements in the result do not have to reflect the ordering of list-1 or list-2 in any way. The result list may be eq to either list-1 or list-2 if appropriate.

Examples::

 (union '(a b c) '(f a d))
⇒  (A B C F D)
OR⇒ (B C F A D)
OR⇒ (D F A B C)
 (union '((x 5) (y 6)) '((z 2) (x 4)) :key #'car)
⇒  ((X 5) (Y 6) (Z 2))
OR⇒ ((X 4) (Y 6) (Z 2))

 (setq lst1 (list 1 2 '(1 2) "a" "b")
       lst2 (list 2 3 '(2 3) "B" "C"))
⇒  (2 3 (2 3) "B" "C")
 (nunion lst1 lst2)
⇒  (1 (1 2) "a" "b" 2 3 (2 3) "B" "C") 
OR⇒ (1 2 (1 2) "a" "b" "C" "B" (2 3) 3)

Side Effects::

nunion is permitted to modify any part, car or cdr, of the list structure of list-1 or list-2.

Exceptional Situations::

Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists.

See Also::

intersection ,

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Since the nunion side effect is not required, it should not be used in for-effect-only positions in portable code.

Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/short_002dfloat.html0000644000175000017500000002030414360276512016272 0ustar cammcamm short-float (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.5 short-float, single-float, double-float, long-float [Type]

Supertypes::

short-float: short-float, float,

real,

number, t

single-float: single-float, float,

real,

number, t

double-float: double-float, float,

real,

number, t

long-float: long-float, float,

real,

number, t

Description::

For the four defined subtypes of type float, it is true that intermediate between the type short-float and the type long-float are the type single-float and the type double-float. The precise definition of these categories is implementation-defined. The precision (measured in “bits”, computed as p\log_2b) and the exponent size (also measured in “bits,” computed as \log_2(n+1), where n is the maximum exponent value) is recommended to be at least as great as the values in Figure 12–11. Each of the defined subtypes of type float might or might not have a minus zero. 

  Format  Minimum Precision  Minimum Exponent Size  
  __________________________________________________
  Short   13 bits            5 bits                 
  Single  24 bits            8 bits                 
  Double  50 bits            8 bits                 
  Long    50 bits            8 bits                 

  Figure 12–11: Recommended Minimum Floating-Point Precision and Exponent Size

There can be fewer than four internal representations for floats. If there are fewer distinct representations, the following rules apply:

–

If there is only one, it is the type single-float. In this representation, an object is simultaneously of types single-float, double-float, short-float, and long-float.

–

Two internal representations can be arranged in either of the following ways:

*

Two types are provided: single-float and short-float. An object is simultaneously of types single-float, double-float, and long-float.

*

Two types are provided: single-float and double-float. An object is simultaneously of types single-float and short-float, or double-float and long-float.

–

Three internal representations can be arranged in either of the following ways:

*

Three types are provided: short-float, single-float, and double-float. An object can simultaneously be of type double-float and long-float.

*

Three types are provided: single-float, double-float, and long-float. An object can simultaneously be of types single-float and short-float.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(short-float{[short-lower-limit [short-upper-limit]]}) (single-float{[single-lower-limit [single-upper-limit]]}) (double-float{[double-lower-limit [double-upper-limit]]}) (long-float{[long-lower-limit [long-upper-limit]]})

Compound Type Specifier Arguments::

short-lower-limit, short-upper-limit—interval designators for type short-float. The defaults for each of lower-limit and upper-limit is the symbol *.

single-lower-limit, single-upper-limit—interval designators for type single-float. The defaults for each of lower-limit and upper-limit is the symbol *.

double-lower-limit, double-upper-limit—interval designators for type double-float. The defaults for each of lower-limit and upper-limit is the symbol *.

long-lower-limit, long-upper-limit—interval designators for type long-float. The defaults for each of lower-limit and upper-limit is the symbol *.

Compound Type Specifier Description::

Each of these denotes the set of floats of the indicated type that are on the interval specified by the interval designators.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/phase.html0000644000175000017500000000776014360276512014473 0ustar cammcamm phase (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.49 phase [Function]

phase number ⇒ phase

Arguments and Values::

number—a number.

phase—a number.

Description::

phase returns the phase of number (the angle part of its polar representation) in radians, in the range

-\pi (exclusive) if minus zero is not supported, or -\pi (inclusive) if minus zero is supported,

to \pi (inclusive). The phase of a positive

real

number is zero; that of a negative

real

number is \pi. The phase of zero is defined to be zero.

If number is a complex float, the result is a float of the same type as the components of number. If number is a float, the result is a float of the same type. If number is a rational or a complex rational, the result is a single float.

The branch cut for phase lies along the negative real axis, continuous with quadrant II. The range consists of that portion of the real axis between -\pi (exclusive) and~\pi (inclusive).

The mathematical definition of phase is as follows:

(phase x) = (atan (imagpart x) (realpart x))

Examples::

 (phase 1) ⇒  0.0s0
 (phase 0) ⇒  0.0s0
 (phase (cis 30)) ⇒  -1.4159266
 (phase #c(0 1)) ⇒  1.5707964

Exceptional Situations::

Should signal type-error if its argument is not a number. Might signal arithmetic-error.

See Also::

Rule of Float Substitutability

gcl-2.6.14/info/gcl/defconstant.html0000644000175000017500000001400114360276512015665 0ustar cammcamm defconstant (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.15 defconstant [Macro]

defconstant name initial-value [documentation] ⇒ name

Arguments and Values::

name—a symbol; not evaluated.

initial-value—a form; evaluated.

documentation—a string; not evaluated.

Description::

defconstant causes the global variable named by name to be given a value that is the result of evaluating initial-value.

A constant defined by defconstant can be redefined with defconstant. However, the consequences are undefined if an attempt is made to assign a value to the symbol using another operator, or to assign it to a different value using a subsequent defconstant.

If documentation is supplied, it is attached to name as a documentation string of kind variable.

defconstant normally appears as a top level form, but it is meaningful for it to appear as a non-top-level form. However, the compile-time side effects described below only take place when defconstant appears as a top level form.

The consequences are undefined if there are any bindings of the variable named by name at the time defconstant is executed or if the value is not eql to the value of initial-value.

The consequences are undefined when constant symbols are rebound as either lexical or dynamic variables. In other words, a reference to a symbol declared with defconstant always refers to its global value.

The side effects of the execution of defconstant must be equivalent to at least the side effects of the execution of the following code: 

 (setf (symbol-value 'name) initial-value)
 (setf (documentation 'name 'variable) 'documentation)

If a defconstant form appears as a top level form, the compiler must recognize that name names a constant variable. An implementation may choose to evaluate the value-form at compile time, load time, or both. Therefore, users must ensure that the initial-value can be evaluated at compile time (regardless of whether or not references to name appear in the file) and that it always evaluates to the same value.

[Editorial Note by KMP: Does “same value” here mean eql or similar?]

[Reviewer Note by Moon: Probably depends on whether load time is compared to compile time, or two compiles.]

Examples::

 (defconstant this-is-a-constant 'never-changing "for a test") ⇒  THIS-IS-A-CONSTANT
this-is-a-constant ⇒  NEVER-CHANGING
 (documentation 'this-is-a-constant 'variable) ⇒  "for a test"
 (constantp 'this-is-a-constant) ⇒  true

See Also::

declaim , defparameter , defvar, documentation , proclaim , Constant Variables, Compilation

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/The-Lisp-Printer.html0000644000175000017500000000531514360276512016433 0ustar cammcamm The Lisp Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer  

22.1 The Lisp Printer

• Overview of The Lisp Printer  
• Printer Dispatching  
• Default Print-Object Methods  
• Examples of Printer Behavior  
gcl-2.6.14/info/gcl/define_002dmethod_002dcombination.html0000644000175000017500000007322514360276512021522 0ustar cammcamm define-method-combination (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.33 define-method-combination [Macro]

define-method-combination name [[!short-form-option]]
⇒ name

define-method-combination name lambda-list ({method-group-specifier}*) [(:arguments . args-lambda-list)] [(:generic-function generic-function-symbol)] [[{declaration}* | documentation]] {form}*
⇒ name

short-form-option ::=:documentation documentation |                        :identity-with-one-argument identity-with-one-argument |                       :operator operator

method-group-specifier ::=(name {{qualifier-pattern}^+ | predicate} [[!long-form-option]])

long-form-option ::=:description description |                      :order order |                      :required required-p

Arguments and Values::

args-lambda-list— a define-method-combination arguments lambda list.

declaration—a declare expression; not evaluated.

description—a format control.

documentation—a string; not evaluated.

forms—an implicit progn that must compute and return the form that specifies how the methods are combined, that is, the effective method.

generic-function-symbol—a symbol.

identity-with-one-argument—a generalized boolean.

lambda-list—ordinary lambda list.

name—a symbol. Non-keyword, non-nil symbols are usually used.

operator—an operator. Name and operator are often the same symbol. This is the default, but it is not required.

order—:most-specific-first or :most-specific-last; evaluated.

predicate—a symbol that names a function of one argument that returns a generalized boolean.

qualifier-pattern—a list, or the symbol *.

required-p—a generalized boolean.

Description::

The macro define-method-combination is used to define new types of method combination.

There are two forms of define-method-combination. The short form is a simple facility for the cases that are expected to be most commonly needed. The long form is more powerful but more verbose. It resembles defmacro in that the body is an expression, usually using backquote, that computes a form. Thus arbitrary control structures can be implemented. The long form also allows arbitrary processing of method qualifiers.

Short Form

The short form syntax of define-method-combination is recognized when the second subform is a non-nil symbol or is not present. When the short form is used, name is defined as a type of method combination that produces a Lisp form (operator method-call method-call ...). The operator is a symbol that can be the name of a function, macro, or special operator. The operator can be supplied by a keyword option; it defaults to name.

Keyword options for the short form are the following:

*

The :documentation option is used to document the method-combination type; see description of long form below.

*

The :identity-with-one-argument option enables an optimization when its value is true (the default is false). If there is exactly one applicable method and it is a primary method, that method serves as the effective method and operator is not called. This optimization avoids the need to create a new effective method and avoids the overhead of a function call. This option is designed to be used with operators such as progn, and, +, and max.

*

The :operator option specifies the name of the operator. The operator argument is a symbol that can be the name of a function, macro, or special form.

These types of method combination require exactly one qualifier per method. An error is signaled if there are applicable methods with no qualifiers or with qualifiers that are not supported by the method combination type.

A method combination procedure defined in this way recognizes two roles for methods. A method whose one qualifier is the symbol naming this type of method combination is defined to be a primary method. At least one primary method must be applicable or an error is signaled. A method with :around as its one qualifier is an auxiliary method that behaves the same as an around method in standard method combination. The function call-next-method can only be used in around methods; it cannot be used in primary methods defined by the short form of the define-method-combination macro.

A method combination procedure defined in this way accepts an optional argument named order, which defaults to :most-specific-first. A value of :most-specific-last reverses the order of the primary methods without affecting the order of the auxiliary methods.

The short form automatically includes error checking and support for around methods.

For a discussion of built-in method combination types, see Built-in Method Combination Types.

Long Form

The long form syntax of define-method-combination is recognized when the second subform is a list.

The lambda-list receives any arguments provided after the name of the method combination type in the :method-combination option to defgeneric.

A list of method group specifiers follows. Each specifier selects a subset of the applicable methods to play a particular role, either by matching their qualifiers against some patterns or by testing their qualifiers with a predicate. These method group specifiers define all method qualifiers that can be used with this type of method combination.

The car of each method-group-specifier is a symbol which names a variable. During the execution of the forms in the body of define-method-combination, this variable is bound to a list of the methods in the method group. The methods in this list occur in the order specified by the :order option.

If qualifier-pattern is a symbol it must be *. A method matches a qualifier-pattern if the method’s list of qualifiers is equal to the qualifier-pattern (except that the symbol * in a qualifier-pattern matches anything). Thus a qualifier-pattern can be one of the following: the empty list, which matches unqualified methods; the symbol *, which matches all methods; a true list, which matches methods with the same number of qualifiers as the length of the list when each qualifier matches the corresponding list element; or a dotted list that ends in the symbol * (the * matches any number of additional qualifiers).

Each applicable method is tested against the qualifier-patterns and predicates in left-to-right order. As soon as a qualifier-pattern matches or a predicate returns true, the method becomes a member of the corresponding method group and no further tests are made. Thus if a method could be a member of more than one method group, it joins only the first such group. If a method group has more than one qualifier-pattern, a method need only satisfy one of the qualifier-patterns to be a member of the group.

The name of a predicate function can appear instead of qualifier-patterns in a method group specifier. The predicate is called for each method that has not been assigned to an earlier method group; it is called with one argument, the method’s qualifier list. The predicate should return true if the method is to be a member of the method group. A predicate can be distinguished from a qualifier-pattern because it is a symbol other than nil or *.

If there is an applicable method that does not fall into any method group, the function invalid-method-error is called.

Method group specifiers can have keyword options following the qualifier patterns or predicate. Keyword options can be distinguished from additional qualifier patterns because they are neither lists nor the symbol *. The keyword options are as follows:

*

The :description option is used to provide a description of the role of methods in the method group. Programming environment tools use (apply #'format stream format-control (method-qualifiers method)) to print this description, which is expected to be concise. This keyword option allows the description of a method qualifier to be defined in the same module that defines the meaning of the method qualifier. In most cases, format-control will not contain any format directives, but they are available for generality. If :description is not supplied, a default description is generated based on the variable name and the qualifier patterns and on whether this method group includes the unqualified methods.

*

The :order option specifies the order of methods. The order argument is a form that evaluates to :most-specific-first or :most-specific-last. If it evaluates to any other value, an error is signaled. If :order is not supplied, it defaults to :most-specific-first.

*

The :required option specifies whether at least one method in this method group is required. If its value is true and the method group is empty (that is, no applicable methods match the qualifier patterns or satisfy the predicate), an error is signaled. If :required is not supplied, it defaults to nil.

The use of method group specifiers provides a convenient syntax to select methods, to divide them among the possible roles, and to perform the necessary error checking. It is possible to perform further filtering of methods in the body forms by using normal list-processing operations and the functions method-qualifiers and invalid-method-error. It is permissible to use setq on the variables named in the method group specifiers and to bind additional variables. It is also possible to bypass the method group specifier mechanism and do everything in the body forms. This is accomplished by writing a single method group with * as its only qualifier-pattern; the variable is then bound to a list of all of the applicable methods, in most-specific-first order.

The body forms compute and return the form that specifies how the methods are combined, that is, the effective method. The effective method is evaluated in the null lexical environment augmented with a local macro definition for call-method and with bindings named by symbols not accessible from the COMMON-LISP-USER package. Given a method object in one of the lists produced by the method group specifiers and a list of next methods, call-method will invoke the method such that call-next-method has available the next methods.

When an effective method has no effect other than to call a single method, some implementations employ an optimization that uses the single method directly as the effective method, thus avoiding the need to create a new effective method. This optimization is active when the effective method form consists entirely of an invocation of the call-method macro whose first subform is a method object and whose second subform is nil or unsupplied. Each define-method-combination body is responsible for stripping off redundant invocations of progn, and, multiple-value-prog1, and the like, if this optimization is desired.

The list (:arguments . lambda-list) can appear before any declarations or documentation string. This form is useful when the method combination type performs some specific behavior as part of the combined method and that behavior needs access to the arguments to the generic function. Each parameter variable defined by lambda-list is bound to a form that can be inserted into the effective method. When this form is evaluated during execution of the effective method, its value is the corresponding argument to the generic function; the consequences of using such a form as the place in a setf form are undefined.

Argument correspondence is computed by dividing the :arguments lambda-list and the generic function lambda-list into three sections: the required parameters, the optional parameters, and the keyword and rest parameters. The arguments supplied to the generic function for a particular call are also divided into three sections; the required arguments section contains as many arguments as the generic function has required parameters, the optional arguments section contains as many arguments as the generic function has optional parameters, and the keyword/rest arguments section contains the remaining arguments. Each parameter in the required and optional sections of the :arguments lambda-list accesses the argument at the same position in the corresponding section of the arguments. If the section of the :arguments lambda-list is shorter, extra arguments are ignored. If the section of the :arguments lambda-list is longer, excess required parameters are bound to forms that evaluate to nil and excess optional parameters are bound to their initforms. The keyword parameters and rest parameters in the :arguments lambda-list access the keyword/rest section of the arguments. If the :arguments lambda-list contains &key, it behaves as if it also contained &allow-other-keys.

In addition, &whole var can be placed first in the :arguments lambda-list. It causes var to be bound to a form that evaluates to a list of all of the arguments supplied to the generic function. This is different from &rest because it accesses all of the arguments, not just the keyword/rest arguments.

Erroneous conditions detected by the body should be reported with method-combination-error or invalid-method-error; these functions add any necessary contextual information to the error message and will signal the appropriate error.

The body forms are evaluated inside of the bindings created by the lambda list and method group specifiers.

[Reviewer Note by Barmar: Are they inside or outside the :ARGUMENTS bindings?] Declarations at the head of the body are positioned directly inside of bindings created by the lambda list and outside of the bindings of the method group variables. Thus method group variables cannot be declared in this way. locally may be used around the body, however.

Within the body forms, generic-function-symbol is bound to the generic function object.

Documentation is attached as a documentation string to name (as kind method-combination) and to the method combination object.

Note that two methods with identical specializers, but with different qualifiers, are not ordered by the algorithm described in Step 2 of the method selection and combination process described in Method Selection and Combination. Normally the two methods play different roles in the effective method because they have different qualifiers, and no matter how they are ordered in the result of Step 2, the effective method is the same. If the two methods play the same role and their order matters,

[Reviewer Note by Barmar: How does the system know when the order matters?] an error is signaled. This happens as part of the qualifier pattern matching in define-method-combination.

If a define-method-combination form appears as a top level form, the compiler must make the method combination name be recognized as a valid method combination name in subsequent defgeneric forms. However, the method combination is executed no earlier than when the define-method-combination form is executed, and possibly as late as the time that generic functions that use the method combination are executed.

Examples::

Most examples of the long form of define-method-combination also illustrate the use of the related functions that are provided as part of the declarative method combination facility. 

;;; Examples of the short form of define-method-combination

 (define-method-combination and :identity-with-one-argument t) 

 (defmethod func and ((x class1) y) ...)

;;; The equivalent of this example in the long form is:

 (define-method-combination and 
         (&optional (order :most-specific-first))
         ((around (:around))
          (primary (and) :order order :required t))
   (let ((form (if (rest primary)
                   `(and ,@(mapcar #'(lambda (method)
                                       `(call-method ,method))
                                   primary))
                   `(call-method ,(first primary)))))
     (if around
         `(call-method ,(first around)
                       (,@(rest around)
                        (make-method ,form)))
         form)))

;;; Examples of the long form of define-method-combination

;The default method-combination technique
 (define-method-combination standard ()
         ((around (:around))
          (before (:before))
          (primary () :required t)
          (after (:after)))
   (flet ((call-methods (methods)
            (mapcar #'(lambda (method)
                        `(call-method ,method))
                    methods)))
     (let ((form (if (or before after (rest primary))
                     `(multiple-value-prog1
                        (progn ,@(call-methods before)
                               (call-method ,(first primary)
                                            ,(rest primary)))
                        ,@(call-methods (reverse after)))
                     `(call-method ,(first primary)))))
       (if around
           `(call-method ,(first around)
                         (,@(rest around)
                          (make-method ,form)))
           form))))

;A simple way to try several methods until one returns non-nil
 (define-method-combination or ()
         ((methods (or)))
   `(or ,@(mapcar #'(lambda (method)
                      `(call-method ,method))
                  methods)))

;A more complete version of the preceding
 (define-method-combination or 
         (&optional (order ':most-specific-first))
         ((around (:around))
          (primary (or)))
   ;; Process the order argument
   (case order
     (:most-specific-first)
     (:most-specific-last (setq primary (reverse primary)))
     (otherwise (method-combination-error "~S is an invalid order.~@
     :most-specific-first and :most-specific-last are the possible values."
                                          order)))
   ;; Must have a primary method
   (unless primary
     (method-combination-error "A primary method is required."))
   ;; Construct the form that calls the primary methods
   (let ((form (if (rest primary)
                   `(or ,@(mapcar #'(lambda (method)
                                      `(call-method ,method))
                                  primary))
                   `(call-method ,(first primary)))))
     ;; Wrap the around methods around that form
     (if around
         `(call-method ,(first around)
                       (,@(rest around)
                        (make-method ,form)))
         form)))

;The same thing, using the :order and :required keyword options
 (define-method-combination or 
         (&optional (order ':most-specific-first))
         ((around (:around))
          (primary (or) :order order :required t))
   (let ((form (if (rest primary)
                   `(or ,@(mapcar #'(lambda (method)
                                      `(call-method ,method))
                                  primary))
                   `(call-method ,(first primary)))))
     (if around
         `(call-method ,(first around)
                       (,@(rest around)
                        (make-method ,form)))
         form)))

;This short-form call is behaviorally identical to the preceding
 (define-method-combination or :identity-with-one-argument t)

;Order methods by positive integer qualifiers
;:around methods are disallowed to keep the example small
 (define-method-combination example-method-combination ()
         ((methods positive-integer-qualifier-p))
   `(progn ,@(mapcar #'(lambda (method)
                         `(call-method ,method))
                     (stable-sort methods #'<
                       :key #'(lambda (method)
                                (first (method-qualifiers method)))))))

 (defun positive-integer-qualifier-p (method-qualifiers)
   (and (= (length method-qualifiers) 1)
        (typep (first method-qualifiers) '(integer 0 *))))

;;; Example of the use of :arguments
 (define-method-combination progn-with-lock ()
         ((methods ()))
   (:arguments object)
   `(unwind-protect
        (progn (lock (object-lock ,object))
               ,@(mapcar #'(lambda (method)
                             `(call-method ,method))
                         methods))
      (unlock (object-lock ,object))))

Side Effects::

The compiler is not required to perform any compile-time side-effects.

Exceptional Situations::

Method combination types defined with the short form require exactly one qualifier per method. An error of type error is signaled if there are applicable methods with no qualifiers or with qualifiers that are not supported by the method combination type. At least one primary method must be applicable or an error of type error is signaled.

If an applicable method does not fall into any method group, the system signals an error of type error indicating that the method is invalid for the kind of method combination in use.

If the value of the :required option is true and the method group is empty (that is, no applicable methods match the qualifier patterns or satisfy the predicate), an error of type error is signaled.

If the :order option evaluates to a value other than :most-specific-first or :most-specific-last, an error of type error is signaled.

See Also::

call-method , call-next-method , documentation , method-qualifiers , method-combination-error , invalid-method-error , defgeneric , Method Selection and Combination, Built-in Method Combination Types, Syntactic Interaction of Documentation Strings and Declarations

Notes::

The :method-combination option of defgeneric is used to specify that a generic function should use a particular method combination type. The first argument to the :method-combination option is the name of a method combination type and the remaining arguments are options for that type.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/Environment.html0000644000175000017500000000443414360276512015672 0ustar cammcamm Environment (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

25 Environment

• The External Environment  
• Environment Dictionary  
gcl-2.6.14/info/gcl/cons.html0000644000175000017500000000635314360276512014332 0ustar cammcamm cons (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.5 cons [Function]

cons object-1 object-2 ⇒ cons

Arguments and Values::

object-1—an object.

object-2—an object.

cons—a cons.

Description::

Creates a fresh cons, the car of which is object-1 and the cdr of which is object-2.

Examples::

 (cons 1 2) ⇒  (1 . 2)
 (cons 1 nil) ⇒  (1)
 (cons nil 2) ⇒  (NIL . 2)
 (cons nil nil) ⇒  (NIL)
 (cons 1 (cons 2 (cons 3 (cons 4 nil)))) ⇒  (1 2 3 4)
 (cons 'a 'b) ⇒  (A . B)
 (cons 'a (cons 'b (cons 'c '()))) ⇒  (A B C)
 (cons 'a '(b c d)) ⇒  (A B C D)

See Also::

list (Function)

Notes::

If object-2 is a list, cons can be thought of as producing a new list which is like it but has object-1 prepended.

gcl-2.6.14/info/gcl/Decoded-Time.html0000644000175000017500000000730514360276512015611 0ustar cammcamm Decoded Time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Time  

25.1.4.1 Decoded Time

A decoded time is an ordered series of nine values that, taken together, represent a point in calendar time (ignoring leap seconds):

Second

An integer between 0 and~59, inclusive.

Minute

An integer between 0 and~59, inclusive.

Hour

An integer between 0 and~23, inclusive.

Date

An integer between 1 and~31, inclusive (the upper limit actually depends on the month and year, of course).

Month

An integer between 1 and 12, inclusive; 1~means January, 2~means February, and so on; 12~means December.

Year

An integer indicating the year A.D. However, if this integer is between 0 and 99, the “obvious” year is used; more precisely, that year is assumed that is equal to the integer modulo 100 and within fifty years of the current year (inclusive backwards and exclusive forwards). Thus, in the year 1978, year 28 is 1928 but year 27 is 2027. (Functions that return time in this format always return a full year number.)

Day of week

An integer between~0 and~6, inclusive; 0~means Monday, 1~means Tuesday, and so on; 6~means Sunday.

Daylight saving time flag

A generalized boolean that, if true, indicates that daylight saving time is in effect.

Time zone

A time zone.

Figure 25–5 shows defined names relating to decoded time. 

  decode-universal-time  get-decoded-time  

  Figure 25–5: Defined names involving time in Decoded Time.
gcl-2.6.14/info/gcl/Printing-Complexes.html0000644000175000017500000000470714360276512017120 0ustar cammcamm Printing Complexes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.5 Printing Complexes

A complex is printed as #C, an open parenthesis, the printed representation of its real part, a space, the printed representation of its imaginary part, and finally a close parenthesis.

For related information about the syntax of a complex, see Syntax of a Complex and Sharpsign C.

gcl-2.6.14/info/gcl/Data-and-Control-Flow-Dictionary.html0000644000175000017500000003114014360276512021417 0ustar cammcamm Data and Control Flow Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Data and Control Flow  

5.3 Data and Control Flow Dictionary

• apply  
• defun  
• fdefinition  
• fboundp  
• fmakunbound  
• flet  
• funcall  
• function (Special Operator)  
• function-lambda-expression  
• functionp  
• compiled-function-p  
• call-arguments-limit  
• lambda-list-keywords  
• lambda-parameters-limit  
• defconstant  
• defparameter  
• destructuring-bind  
• let  
• progv  
• setq  
• psetq  
• block  
• catch  
• go  
• return-from  
• return  
• tagbody  
• throw  
• unwind-protect  
• nil  
• not  
• t  
• eq  
• eql  
• equal  
• equalp  
• identity  
• complement  
• constantly  
• every  
• and  
• cond  
• if  
• or  
• when  
• case  
• typecase  
• multiple-value-bind  
• multiple-value-call  
• multiple-value-list  
• multiple-value-prog1  
• multiple-value-setq  
• values  
• values-list  
• multiple-values-limit  
• nth-value  
• prog  
• prog1  
• progn  
• define-modify-macro  
• defsetf  
• define-setf-expander  
• get-setf-expansion  
• setf  
• shiftf  
• rotatef  
• control-error  
• program-error  
• undefined-function  

Previous: , Up: Data and Control Flow  

gcl-2.6.14/info/gcl/pprint_002dtab.html0000644000175000017500000000764314360276512016123 0ustar cammcamm pprint-tab (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.10 pprint-tab [Function]

pprint-tab kind colnum colinc &optional stream ⇒ nil

Arguments and Values::

kind—one of :line, :section, :line-relative, or :section-relative.

colnum—a non-negative integer.

colinc—a non-negative integer.

stream—an output stream designator.

Description::

Specifies tabbing to stream as performed by the standard ~T format directive.

If stream is a pretty printing stream and the value of *print-pretty* is true,

tabbing is performed; otherwise, pprint-tab has no effect.

The arguments colnum and colinc correspond to the two parameters to ~T and are in terms of ems. The kind argument specifies the style of tabbing. It must be one of :line (tab as by ~T), :section (tab as by ~:T, but measuring horizontal positions relative to the start of the dynamically enclosing section), :line-relative (tab as by ~@T), or :section-relative (tab as by ~:@T, but measuring horizontal positions relative to the start of the dynamically enclosing section).

Exceptional Situations::

An error is signaled if kind is not one of :line, :section, :line-relative, or :section-relative.

See Also::

pprint-logical-block

gcl-2.6.14/info/gcl/Environment-Dictionary.html0000644000175000017500000001535614360276512020002 0ustar cammcamm Environment Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Environment  

25.2 Environment Dictionary

• decode-universal-time  
• encode-universal-time  
• get-universal-time  
• sleep  
• apropos  
• describe  
• describe-object  
• trace  
• step  
• time  
• internal-time-units-per-second  
• get-internal-real-time  
• get-internal-run-time  
• disassemble  
• documentation  
• room  
• ed  
• inspect  
• dribble  
• - (Variable)  
• + (Variable)  
• * (Variable)  
• / (Variable)  
• lisp-implementation-type  
• short-site-name  
• machine-instance  
• machine-type  
• machine-version  
• software-type  
• user-homedir-pathname  
gcl-2.6.14/info/gcl/Strings-Dictionary.html0000644000175000017500000000752414360276512017125 0ustar cammcamm Strings Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Strings  

16.2 Strings Dictionary

• string (System Class)  
• base-string  
• simple-string  
• simple-base-string  
• simple-string-p  
• char  
• string  
• string-upcase  
• string-trim  
• string=  
• stringp  
• make-string  
gcl-2.6.14/info/gcl/macro_002dfunction.html0000644000175000017500000001270114360276512016756 0ustar cammcamm macro-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.11 macro-function [Accessor]

macro-function symbol &optional environment ⇒ function

(setf ( macro-function symbol &optional environment) new-function)

Arguments and Values::

symbol—a symbol.

environment—an environment object.

function—a macro function or nil.

new-function—a macro function.

Description::

Determines whether symbol has a function definition as a macro in the specified environment.

If so, the macro expansion function, a function of two arguments, is returned. If symbol has no function definition in the lexical environment environment, or its definition is not a macro, macro-function returns nil.

It is possible for both macro-function and

special-operator-p

to return true of symbol. The macro definition must be available for use by programs that understand only the standard Common Lisp special forms.

Examples::

 (defmacro macfun (x) '(macro-function 'macfun)) ⇒  MACFUN 
 (not (macro-function 'macfun)) ⇒  false 

 (macrolet ((foo (&environment env)
               (if (macro-function 'bar env)
                  ''yes
                  ''no)))
    (list (foo)
          (macrolet ((bar () :beep))
             (foo))))

⇒  (NO YES)

Affected By::

(setf macro-function), defmacro, and macrolet.

Exceptional Situations::

The consequences are undefined if environment is non-nil in a use of setf of macro-function.

See Also::

defmacro , Evaluation

Notes::

setf can be used with macro-function to install a macro as a symbol’s global function definition: 

 (setf (macro-function symbol) fn)

The value installed must be a function that accepts two arguments, the entire macro call and an environment, and computes the expansion for that call. Performing this operation causes symbol to have only that macro definition as its global function definition; any previous definition, whether as a macro or as a function, is lost.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/digit_002dchar.html0000644000175000017500000000716114360276512016051 0ustar cammcamm digit-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.10 digit-char [Function]

digit-char weight &optional radix ⇒ char

Arguments and Values::

weight—a non-negative integer.

radix—a radix. The default is 10.

char—a character or false.

Description::

If weight is less than radix, digit-char returns a character which has that weight when considered as a digit in the specified radix. If the resulting character is to be an alphabetic_1 character, it will be an uppercase character.

If weight is greater than or equal to radix, digit-char returns false.

Examples::

 (digit-char 0) ⇒  #\0
 (digit-char 10 11) ⇒  #\A
 (digit-char 10 10) ⇒  false
 (digit-char 7) ⇒  #\7
 (digit-char 12) ⇒  false
 (digit-char 12 16) ⇒  #\C  ;not #\c
 (digit-char 6 2) ⇒  false
 (digit-char 1 2) ⇒  #\1

See Also::

digit-char-p , graphic-char-p , Character Syntax

Notes::

gcl-2.6.14/info/gcl/realpart.html0000644000175000017500000000665314360276512015205 0ustar cammcamm realpart (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.50 realpart, imagpart [Function]

realpart number ⇒ real

imagpart number ⇒ real

Arguments and Values::

number—a number.

real—a real.

Description::

realpart and imagpart return the real and imaginary parts of number respectively. If number is

real,

then realpart returns number and imagpart returns (* 0 number), which has the effect that the imaginary part of a rational is 0 and that of a float is a floating-point zero of the same format.

Examples::

 (realpart #c(23 41)) ⇒  23
 (imagpart #c(23 41.0)) ⇒  41.0
 (realpart #c(23 41.0)) ⇒  23.0
 (imagpart 23.0) ⇒  0.0

Exceptional Situations::

Should signal an error of type type-error if number is not a number.

See Also::

complex

gcl-2.6.14/info/gcl/copy_002dalist.html0000644000175000017500000000723214360276512016121 0ustar cammcamm copy-alist (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.37 copy-alist [Function]

copy-alist alist ⇒ new-alist

Arguments and Values::

alist—an association list.

new-alist—an association list.

Description::

copy-alist returns a copy of alist.

The list structure of alist is copied, and the elements of alist which are conses are also copied (as conses only). Any other objects which are referred to, whether directly or indirectly, by the alist continue to be shared.

Examples::

(defparameter *alist* (acons 1 "one" (acons 2 "two" '())))
*alist* ⇒  ((1 . "one") (2 . "two"))
(defparameter *list-copy* (copy-list *alist*))
*list-copy* ⇒  ((1 . "one") (2 . "two"))
(defparameter *alist-copy* (copy-alist *alist*))
*alist-copy* ⇒  ((1 . "one") (2 . "two"))
(setf (cdr (assoc 2 *alist-copy*)) "deux") ⇒  "deux"
*alist-copy* ⇒  ((1 . "one") (2 . "deux"))
*alist* ⇒  ((1 . "one") (2 . "two"))
(setf (cdr (assoc 1 *list-copy*)) "uno") ⇒  "uno"
*list-copy* ⇒  ((1 . "uno") (2 . "two"))
*alist* ⇒  ((1 . "uno") (2 . "two"))

See Also::

copy-list

gcl-2.6.14/info/gcl/echo_002dstream_002dinput_002dstream.html0000644000175000017500000000600014360276512022002 0ustar cammcamm echo-stream-input-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.44 echo-stream-input-stream, echo-stream-output-stream [Function]

echo-stream-input-stream echo-stream ⇒ input-stream

echo-stream-output-stream echo-stream ⇒ output-stream

Arguments and Values::

echo-stream—an echo stream.

input-stream—an input stream.

output-stream—an output stream.

Description::

echo-stream-input-stream returns the input stream from which echo-stream receives input.

echo-stream-output-stream returns the output stream to which echo-stream sends output.

gcl-2.6.14/info/gcl/array_002drow_002dmajor_002dindex.html0000644000175000017500000000757514360276512021325 0ustar cammcamm array-row-major-index (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.18 array-row-major-index [Function]

array-row-major-index array &rest subscripts ⇒ index

Arguments and Values::

array—an array.

subscripts—a list of valid array indices for the array.

index—a valid array row-major index for the array.

Description::

Computes the position according to the row-major ordering of array for the element that is specified by subscripts, and returns the offset of the element in the computed position from the beginning of array.

For a one-dimensional array, the result of array-row-major-index equals subscript.

array-row-major-index ignores fill pointers.

Examples::

 (setq a (make-array '(4 7) :element-type '(unsigned-byte 8)))
 (array-row-major-index a 1 2) ⇒  9
 (array-row-major-index 
    (make-array '(2 3 4) 
                :element-type '(unsigned-byte 8)
                :displaced-to a
                :displaced-index-offset 4)
    0 2 1) ⇒  9

Notes::

A possible definition of array-row-major-index, with no error-checking, is 

 (defun array-row-major-index (a &rest subscripts)
   (apply #'+ (maplist #'(lambda (x y)
                            (* (car x) (apply #'* (cdr y))))
                       subscripts
                       (array-dimensions a))))
gcl-2.6.14/info/gcl/method_002dcombination.html0000644000175000017500000000537514360276512017623 0ustar cammcamm method-combination (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.15 method-combination [System Class]

Class Precedence List::

method-combination, t

Description::

Every method combination object is an indirect instance of the class method-combination. A method combination object represents the information about the method combination being used by a generic function. A method combination object contains information about both the type of method combination and the arguments being used with that type.

gcl-2.6.14/info/gcl/simple_002dstring_002dp.html0000644000175000017500000000606214360276512017537 0ustar cammcamm simple-string-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.5 simple-string-p [Function]

simple-string-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type simple-string; otherwise, returns false.

Examples::

 (simple-string-p "aaaaaa") ⇒  true
 (simple-string-p (make-array 6 
                              :element-type 'character 
                              :fill-pointer t)) ⇒  false

Notes::

 (simple-string-p object) ≡ (typep object 'simple-string)
gcl-2.6.14/info/gcl/multiple_002dvalue_002dcall.html0000644000175000017500000000744314360276512020367 0ustar cammcamm multiple-value-call (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.49 multiple-value-call [Special Operator]

multiple-value-call function-form form* ⇒ {result}*

Arguments and Values::

function-form—a form; evaluated to produce function.

function—a function designator resulting from the evaluation of function-form.

form—a form.

results—the values returned by the function.

Description::

Applies function to a list of the objects collected from groups of multiple values_2.

multiple-value-call first evaluates the function-form to obtain function, and then evaluates each form. All the values of each form are gathered together (not just one value from each) and given as arguments to the function.

Examples::

 (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))
⇒  (1 / 2 3 / / 2 0.5)
 (+ (floor 5 3) (floor 19 4)) ≡ (+ 1 4)
⇒  5
 (multiple-value-call #'+ (floor 5 3) (floor 19 4)) ≡ (+ 1 2 4 3)
⇒  10

See Also::

multiple-value-list , multiple-value-bind

gcl-2.6.14/info/gcl/Printing-Numbers.html0000644000175000017500000000404414360276512016566 0ustar cammcamm Printing Numbers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.1 Printing Numbers

gcl-2.6.14/info/gcl/Introduction-_0028Introduction_0029.html0000644000175000017500000000674614360276512021661 0ustar cammcamm Introduction (Introduction) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

1 Introduction

• Scope  
• Organization of the Document  
• Referenced Publications  
• Definitions  
• Conformance  
• Language Extensions  
• Language Subsets  
• Deprecated Language Features  
• Symbols in the COMMON-LISP Package  
gcl-2.6.14/info/gcl/cell_002derror_002dname.html0000644000175000017500000000651614360276512017475 0ustar cammcamm cell-error-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.7 cell-error-name [Function]

cell-error-name condition ⇒ name

Arguments and Values::

condition—a condition of type cell-error.

name—an object.

Description::

Returns the name of the offending cell involved in the situation represented by condition.

The nature of the result depends on the specific type of condition. For example, if the condition is of type unbound-variable, the result is the name of the unbound variable which was being accessed, if the condition is of type undefined-function, this is the name of the undefined function which was being accessed, and if the condition is of type unbound-slot, this is the name of the slot which was being accessed.

See Also::

cell-error, unbound-slot, unbound-variable, undefined-function, Condition System Concepts

gcl-2.6.14/info/gcl/_002apackage_002a.html0000644000175000017500000000761114360276512016225 0ustar cammcamm *package* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.28 *package* [Variable]

Value Type::

a package object.

Initial Value::

the COMMON-LISP-USER package.

Description::

Whatever package object is currently the value of *package* is referred to as the current package.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 *package* ⇒  #<PACKAGE "COMMON-LISP-USER">
 (make-package "SAMPLE-PACKAGE" :use '("COMMON-LISP"))
⇒  #<PACKAGE "SAMPLE-PACKAGE">
 (list 
   (symbol-package
     (let ((*package* (find-package 'sample-package)))
       (setq *some-symbol* (read-from-string "just-testing"))))
   *package*)
⇒  (#<PACKAGE "SAMPLE-PACKAGE"> #<PACKAGE "COMMON-LISP-USER">)
 (list (symbol-package (read-from-string "just-testing"))
       *package*)
⇒  (#<PACKAGE "COMMON-LISP-USER"> #<PACKAGE "COMMON-LISP-USER">)
 (eq 'foo (intern "FOO")) ⇒  true
 (eq 'foo (let ((*package* (find-package 'sample-package)))
            (intern "FOO")))
⇒  false

Affected By::

load, compile-file, in-package

See Also::

compile-file , in-package , load , package

gcl-2.6.14/info/gcl/NIL.html0000644000175000017500000001156614360276512014014 0ustar cammcamm NIL (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.11 NIL

nil has a variety of meanings. It is a symbol in the COMMON-LISP package with the name "NIL", it is boolean (and generalized boolean) false, it is the empty list, and it is the name of the empty type (a subtype of all types).

Within Common Lisp, nil can be notated interchangeably as either NIL or (). By convention, the choice of notation offers a hint as to which of its many roles it is playing. 

  For Evaluation?  Notation  Typically Implied Role       
  ________________________________________________________
  Yes              nil       use as a boolean.            
  Yes              'nil      use as a symbol.             
  Yes              '()       use as an empty list         
  No               nil       use as a symbol or boolean.  
  No               ()        use as an empty list.        

               Figure 1–1: Notations for NIL

Within this document only, nil is also sometimes notated as false to emphasize its role as a boolean.

For example: 

 (print ())                          ;avoided
 (defun three nil 3)                 ;avoided 
 '(nil nil)                          ;list of two symbols
 '(() ())                            ;list of empty lists
 (defun three () 3)                  ;Emphasize empty parameter list.
 (append '() '()) ⇒  ()              ;Emphasize use of empty lists
 (not nil) ⇒  true                   ;Emphasize use as Boolean false
 (get 'nil 'color)                   ;Emphasize use as a symbol

A function is sometimes said to “be false” or “be true” in some circumstance. Since no function object can be the same as nil and all function objects represent true when viewed as booleans, it would be meaningless to say that the function was literally false and uninteresting to say that it was literally true. Instead, these phrases are just traditional alternative ways of saying that the function “returns false” or “returns true,” respectively.

Next: , Previous: , Up: Notational Conventions  

gcl-2.6.14/info/gcl/Printing-Conditions.html0000644000175000017500000001111614360276512017262 0ustar cammcamm Printing Conditions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Condition System Concepts  

9.1.3 Printing Conditions

If the :report argument to define-condition is used, a print function is defined that is called whenever the defined condition is printed while the value of *print-escape* is false. This function is called the condition reporter ; the text which it outputs is called a report message .

When a condition is printed and *print-escape* is false, the condition reporter for the condition is invoked. Conditions are printed automatically by functions such as invoke-debugger, break, and warn.

When *print-escape* is true, the object should print in an abbreviated fashion according to the style of the implementation (e.g., by print-unreadable-object). It is not required that a condition can be recreated by reading its printed representation.

No function is provided for directly accessing or invoking condition reporters.

• Recommended Style in Condition Reporting  
• Capitalization and Punctuation in Condition Reports  
• Leading and Trailing Newlines in Condition Reports  
• Embedded Newlines in Condition Reports  
• Note about Tabs in Condition Reports  
• Mentioning Containing Function in Condition Reports  
gcl-2.6.14/info/gcl/pathname.html0000644000175000017500000001320414360276512015156 0ustar cammcamm pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.3 pathname [Function]

pathname pathspec ⇒ pathname

Arguments and Values::

pathspec—a pathname designator.

pathname—a pathname.

Description::

Returns the pathname denoted by pathspec.

If the pathspec designator is a stream, the stream can be either open or closed; in both cases, the pathname returned corresponds to the filename used to open the file. pathname returns the same pathname for a file stream after it is closed as it did when it was open.

If the pathspec designator is a file stream created by opening a logical pathname, a logical pathname is returned.

Examples::

 ;; There is a great degree of variability permitted here.  The next
 ;; several examples are intended to illustrate just a few of the many
 ;; possibilities.  Whether the name is canonicalized to a particular
 ;; case (either upper or lower) depends on both the file system and the
 ;; implementation since two different implementations using the same
 ;; file system might differ on many issues.  How information is stored
 ;; internally (and possibly presented in #S notation) might vary,
 ;; possibly requiring `accessors' such as PATHNAME-NAME to perform case
 ;; conversion upon access.  The format of a namestring is dependent both
 ;; on the file system and the implementation since, for example, one
 ;; implementation might include the host name in a namestring, and
 ;; another might not.  #S notation would generally only be used in a
 ;; situation where no appropriate namestring could be constructed for use
 ;; with #P.
 (setq p1 (pathname "test"))
⇒  #P"CHOCOLATE:TEST" ; with case canonicalization (e.g., VMS)
OR⇒ #P"VANILLA:test"   ; without case canonicalization (e.g., Unix)
OR⇒ #P"test"
OR⇒ #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST")
OR⇒ #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test")
 (setq p2 (pathname "test"))
⇒  #P"CHOCOLATE:TEST"
OR⇒ #P"VANILLA:test"
OR⇒ #P"test"
OR⇒ #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST")
OR⇒ #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test")
 (pathnamep p1) ⇒  true
 (eq p1 (pathname p1)) ⇒  true
 (eq p1 p2)
⇒  true
OR⇒ false
 (with-open-file (stream "test" :direction :output)
   (pathname stream))
⇒  #P"ORANGE-CHOCOLATE:>Gus>test.lisp.newest"

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/Transfer-of-Control-to-an-Exit-Point.html0000644000175000017500000001066114360276512022203 0ustar cammcamm Transfer of Control to an Exit Point (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow  

5.2 Transfer of Control to an Exit Point

When a transfer of control is initiated by go, return-from, or throw the following events occur in order to accomplish the transfer of control. Note that for go, the exit point is the form within the tagbody that is being executed at the time the go is performed; for return-from, the exit point is the corresponding block form; and for throw, the exit point is the corresponding catch form.

1.

Intervening exit points are “abandoned” (i.e., their extent ends and it is no longer valid to attempt to transfer control through them).

2.

The cleanup clauses of any intervening unwind-protect clauses are evaluated.

3.

Intervening dynamic bindings of special variables, catch tags, condition handlers, and restarts are undone.

4.

The extent of the exit point being invoked ends, and control is passed to the target.

The extent of an exit being “abandoned” because it is being passed over ends as soon as the transfer of control is initiated. That is, event 1 occurs at the beginning of the initiation of the transfer of control. The consequences are undefined if an attempt is made to transfer control to an exit point whose dynamic extent has ended.

Events 2 and 3 are actually performed interleaved, in the order corresponding to the reverse order in which they were established. The effect of this is that the cleanup clauses of an unwind-protect see the same dynamic bindings of variables and catch tags as were visible when the unwind-protect was entered.

Event 4 occurs at the end of the transfer of control.

Next: , Previous: , Up: Data and Control Flow  

gcl-2.6.14/info/gcl/Nonsense-Words.html0000644000175000017500000000517614360276512016256 0ustar cammcamm Nonsense Words (ANSI and GNU Common Lisp Document)

Previous: , Up: Notational Conventions  

1.4.1.13 Nonsense Words

When a word having no pre-attached semantics is required (e.g., in an example), it is common in the Lisp community to use one of the words “foo,” “bar,” “baz,” and “quux.” For example, in 

 (defun foo (x) (+ x 1))

the use of the name foo is just a shorthand way of saying “please substitute your favorite name here.”

These nonsense words have gained such prevalance of usage, that it is commonplace for newcomers to the community to begin to wonder if there is an attached semantics which they are overlooking—there is not.

gcl-2.6.14/info/gcl/Implications-of-Strings-Being-Arrays.html0000644000175000017500000000464314360276512022335 0ustar cammcamm Implications of Strings Being Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: String Concepts  

16.1.1 Implications of Strings Being Arrays

Since all strings are arrays, all rules which apply generally to arrays also apply to strings. See Array Concepts.

For example, strings can have fill pointers, and strings are also subject to the rules of element type upgrading that apply to arrays.

gcl-2.6.14/info/gcl/Transfer-of-Control-during-a-Destructive-Operation.html0000644000175000017500000000533014360276512025127 0ustar cammcamm Transfer of Control during a Destructive Operation (ANSI and GNU Common Lisp Document)

Previous: , Up: Destructive Operations  

3.7.2 Transfer of Control during a Destructive Operation

Should a transfer of control out of a destructive operation occur (e.g., due to an error) the state of the object being modified is implementation-dependent.

• Examples of Transfer of Control during a Destructive Operation  
gcl-2.6.14/info/gcl/Specifiers-for-the-required-parameters.html0000644000175000017500000000556014360276512023004 0ustar cammcamm Specifiers for the required parameters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.1 Specifiers for the required parameters

These are all the parameter specifiers up to the first lambda list keyword; if there are no lambda list keywords, then all the specifiers are for required parameters. Each required parameter is specified by a parameter variable var. var is bound as a lexical variable unless it is declared special.

If there are n required parameters (n may be zero), there must be at least n passed arguments, and the required parameters are bound to the first n passed arguments; see Error Checking in Function Calls. The other parameters are then processed using any remaining arguments.

gcl-2.6.14/info/gcl/ldb.html0000644000175000017500000001073314360276512014126 0ustar cammcamm ldb (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.69 ldb [Accessor]

ldb bytespec integer ⇒ byte

(setf ( ldb bytespec place) new-byte)

Pronunciation::

pronounced ’lid ib or pronounced ’lid e b or pronounced ’el ’d\=e ’b\=e

Arguments and Values::

bytespec—a byte specifier.

integer—an integer.

byte, new-byte—a non-negative integer.

Description::

ldb extracts and returns the byte of integer specified by bytespec.

ldb returns an integer in which the bits with weights 2^(s-1) through 2^0 are the same as those in integer with weights 2^(p+s-1) through 2^p, and all other bits zero; s is (byte-size bytespec) and p is (byte-position bytespec).

setf may be used with ldb to modify a byte within the integer that is stored in a given place.

The order of evaluation, when an ldb form is supplied to setf, is exactly left-to-right.

The effect is to perform a dpb operation and then store the result back into the place.

Examples::

 (ldb (byte 2 1) 10) ⇒  1
 (setq a (list 8)) ⇒  (8)
 (setf (ldb (byte 2 1) (car a)) 1) ⇒  1
 a ⇒  (10)

See Also::

byte , byte-position, byte-size, dpb

Notes::

 (logbitp j (ldb (byte s p) n))
    ≡ (and (< j s) (logbitp (+ j p) n))

In general, 

 (ldb (byte 0 x) y) ⇒  0

for all valid values of x and y.

Historically, the name “ldb” comes from a DEC PDP-10 assembly language instruction meaning “load byte.”

gcl-2.6.14/info/gcl/Symbols-Dictionary.html0000644000175000017500000001162214360276512017116 0ustar cammcamm Symbols Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Symbols  

10.2 Symbols Dictionary

• symbol  
• keyword  
• symbolp  
• keywordp  
• make-symbol  
• copy-symbol  
• gensym  
• *gensym-counter*  
• gentemp  
• symbol-function  
• symbol-name  
• symbol-package  
• symbol-plist  
• symbol-value  
• get  
• remprop  
• boundp  
• makunbound  
• set  
• unbound-variable  
gcl-2.6.14/info/gcl/locally.html0000644000175000017500000001147014360276512015023 0ustar cammcamm locally (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.27 locally [Special Operator]

locally {declaration}* {form}* ⇒ {result}*

Arguments and Values::

Declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values of the forms.

Description::

Sequentially evaluates a body of forms in a lexical environment where the given declarations have effect.

Examples::

 (defun sample-function (y)  ;this y is regarded as special
   (declare (special y))                                
   (let ((y t))              ;this y is regarded as lexical
     (list y
           (locally (declare (special y))
             ;; this next y is regarded as special
             y))))
⇒  SAMPLE-FUNCTION
 (sample-function nil) ⇒  (T NIL) 
 (setq x '(1 2 3) y '(4 . 5)) ⇒  (4 . 5)

;;; The following declarations are not notably useful in specific.
;;; They just offer a sample of valid declaration syntax using LOCALLY.
 (locally (declare (inline floor) (notinline car cdr))
          (declare (optimize space))
    (floor (car x) (cdr y))) ⇒  0, 1

;;; This example shows a definition of a function that has a particular set
;;; of OPTIMIZE settings made locally to that definition.
 (locally (declare (optimize (safety 3) (space 3) (speed 0)))
   (defun frob (w x y &optional (z (foo x y)))
     (mumble x y z w)))
⇒  FROB

;;; This is like the previous example, except that the optimize settings
;;; remain in effect for subsequent definitions in the same compilation unit.
 (declaim (optimize (safety 3) (space 3) (speed 0)))
 (defun frob (w x y &optional (z (foo x y)))
   (mumble x y z w))
⇒  FROB

See Also::

declare

Notes::

The special declaration may be used with locally to affect references to, rather than bindings of, variables.

If a locally form is a top level form, the body forms are also processed as top level forms. See File Compilation.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/values.html0000644000175000017500000001207214360276512014662 0ustar cammcamm values (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.53 values [Accessor]

values &rest object ⇒ {object}*

(setf ( values &rest place) new-values)

Arguments and Values::

object—an object.

place—a place.

new-value—an object.

Description::

values returns the objects as multiple values_2.

setf of values is used to store the multiple values_2 new-values into the places. See VALUES Forms as Places.

Examples::

 (values) ⇒  <no values>
 (values 1) ⇒  1
 (values 1 2) ⇒  1, 2
 (values 1 2 3) ⇒  1, 2, 3
 (values (values 1 2 3) 4 5) ⇒  1, 4, 5
 (defun polar (x y)
   (values (sqrt (+ (* x x) (* y y))) (atan y x))) ⇒  POLAR
 (multiple-value-bind (r theta) (polar 3.0 4.0)
   (vector r theta))
⇒  #(5.0 0.927295)

Sometimes it is desirable to indicate explicitly that a function returns exactly one value. For example, the function 

 (defun foo (x y)
   (floor (+ x y) y)) ⇒  FOO

returns two values because floor returns two values. It may be that the second value makes no sense, or that for efficiency reasons it is desired not to compute the second value. values is the standard idiom for indicating that only one value is to be returned: 

 (defun foo (x y)
   (values (floor (+ x y) y))) ⇒  FOO

This works because values returns exactly one value for each of args; as for any function call, if any of args produces more than one value, all but the first are discarded.

See Also::

values-list , multiple-value-bind , multiple-values-limit , Evaluation

Notes::

Since values is a function, not a macro or special form, it receives as arguments only the primary values of its argument forms.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Introduction-to-Scripts-and-Repertoires.html0000644000175000017500000000502314360276512023150 0ustar cammcamm Introduction to Scripts and Repertoires (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.2 Introduction to Scripts and Repertoires

• Character Scripts  
• Character Repertoires  
gcl-2.6.14/info/gcl/Examples-of-Satisfying-a-Two_002dArgument-Test.html0000644000175000017500000000701014360276512024007 0ustar cammcamm Examples of Satisfying a Two-Argument Test (ANSI and GNU Common Lisp Document)

Previous: , Up: Satisfying a Two-Argument Test  

17.2.1.1 Examples of Satisfying a Two-Argument Test

 (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equal)
⇒  (foo bar "BAR" "foo" "bar")
 (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equalp)
⇒  (foo bar "BAR" "bar")
 (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string-equal)
⇒  (bar "BAR" "bar")
 (remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string=)
⇒  (BAR "BAR" "foo" "bar")

 (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'eql)
⇒  (1)
 (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'=)
⇒  (1 1.0 #C(1.0 0.0))
 (remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test (complement #'=))
⇒  (1 1.0 #C(1.0 0.0))

 (count 1 '((one 1) (uno 1) (two 2) (dos 2)) :key #'cadr) ⇒  2

 (count 2.0 '(1 2 3) :test #'eql :key #'float) ⇒  1

 (count "FOO" (list (make-pathname :name "FOO" :type "X")  
                    (make-pathname :name "FOO" :type "Y"))
        :key #'pathname-name
        :test #'equal)
⇒  2
gcl-2.6.14/info/gcl/FORMAT-Layout-Control.html0000644000175000017500000000543114360276512017245 0ustar cammcamm FORMAT Layout Control (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.6 FORMAT Layout Control

• Tilde T-> Tabulate  
• Tilde Less-Than-Sign-> Justification  
• Tilde Greater-Than-Sign-> End of Justification  
gcl-2.6.14/info/gcl/Scope-and-Purpose.html0000644000175000017500000000421014360276512016622 0ustar cammcamm Scope and Purpose (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Scope  

1.1.1 Scope and Purpose

The specification set forth in this document is designed to promote the portability of Common Lisp programs among a variety of data processing systems. It is a language specification aimed at an audience of implementors and knowledgeable programmers. It is neither a tutorial nor an implementation guide.

gcl-2.6.14/info/gcl/continue.html0000644000175000017500000000670214360276512015212 0ustar cammcamm continue (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.42 continue [Restart]

Data Arguments Required::

None.

Description::

The continue restart is generally part of protocols where there is a single “obvious” way to continue, such as in break and cerror. Some user-defined protocols may also wish to incorporate it for similar reasons. In general, however, it is more reliable to design a special purpose restart with a name that more directly suits the particular application.

Examples::

 (let ((x 3))
   (handler-bind ((error #'(lambda (c)
                             (let ((r (find-restart 'continue c)))
                               (when r (invoke-restart r))))))
     (cond ((not (floatp x))
            (cerror "Try floating it." "~D is not a float." x)
            (float x))
           (t x)))) ⇒  3.0

See Also::

Restarts, Interfaces to Restarts, invoke-restart , continue (function), assert , cerror

gcl-2.6.14/info/gcl/Value-Accumulation-Clauses.html0000644000175000017500000002471114360276512020461 0ustar cammcamm Value Accumulation Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.3 Value Accumulation Clauses

The constructs collect, collecting, append, appending, nconc, nconcing, count, counting, maximize, maximizing, minimize, minimizing, sum, and summing, allow values to be accumulated in a loop.

The constructs collect, collecting, append, appending, nconc, and nconcing, designate clauses that accumulate values in lists and return them. The constructs count, counting, maximize, maximizing, minimize, minimizing, sum, and summing designate clauses that accumulate and return numerical values.

During each iteration, the constructs collect and collecting collect the value of the supplied form into a list. When iteration terminates, the list is returned. The argument var is set to the list of collected values; if var is supplied, the loop does not return the final list automatically. If var is not supplied, it is equivalent to supplying an internal name for var and returning its value in a finally clause. The var argument is bound as if by the construct with. No mechanism is provided for declaring the type of var; it must be of type list.

The constructs append, appending, nconc, and nconcing are similar to collect except that the values of the supplied form must be lists.

*

The append keyword causes its list values to be concatenated into a single list, as if they were arguments to the function append.

*

The nconc keyword causes its list values to be concatenated into a single list, as if they were arguments to the function nconc.

The argument var is set to the list of concatenated values; if var is supplied, loop does not return the final list automatically. The var argument is bound as if by the construct with. A type cannot be supplied for var; it must be of type list. The construct nconc destructively modifies its argument lists.

The count construct counts the number of times that the supplied form returns true. The argument var accumulates the number of occurrences; if var is supplied, loop does not return the final count automatically. The var argument is bound as if by the construct with to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the function 1+. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the count. The default type is implementation-dependent; but it must be a supertype of type fixnum.

The maximize and minimize constructs compare the value of the supplied form obtained during the first iteration with values obtained in successive iterations. The maximum (for maximize) or minimum (for minimize) value encountered is determined (as if by the function max for maximize and as if by the function min for minimize) and returned. If the maximize or minimize clause is never executed, the accumulated value is unspecified. The argument var accumulates the maximum or minimum value; if var is supplied, loop does not return the maximum or minimum automatically. The var argument is bound as if by the construct with. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the maximum or minimum value. The default type is implementation-dependent; but it must be a supertype of type real.

The sum construct forms a cumulative sum of the successive primary values of the supplied form at each iteration. The argument var is used to accumulate the sum; if var is supplied, loop does not return the final sum automatically. The var argument is bound as if by the construct with to a zero of the appropriate type. Subsequent values (including any necessary coercions) are computed as if by the function +. If into var is used, a type can be supplied for var with the type-spec argument; the consequences are unspecified if a nonnumeric type is supplied. If there is no into variable, the optional type-spec argument applies to the internal variable that is keeping the sum. The default type is implementation-dependent; but it must be a supertype of type number.

If into is used, the construct does not provide a default return value; however, the variable is available for use in any finally clause.

Certain kinds of accumulation clauses can be combined in a loop if their destination is the same (the result of loop or an into var) because they are considered to accumulate conceptually compatible quantities. In particular, any elements of following sets of accumulation clauses can be mixed with other elements of the same set for the same destination in a loop form:

*

collect, append, nconc

*

sum, count

*

maximize, minimize 

;; Collect every name and the kids in one list by using 
;; COLLECT and APPEND.
 (loop for name in '(fred sue alice joe june)
       for kids in '((bob ken) () () (kris sunshine) ())
       collect name
       append kids)
⇒  (FRED BOB KEN SUE ALICE JOE KRIS SUNSHINE JUNE)

Any two clauses that do not accumulate the same type of object can coexist in a loop only if each clause accumulates its values into a different variable.

• Examples of COLLECT clause  
• Examples of APPEND and NCONC clauses  
• Examples of COUNT clause  
• Examples of MAXIMIZE and MINIMIZE clauses  
• Examples of SUM clause  

Next: , Previous: , Up: The LOOP Facility  

gcl-2.6.14/info/gcl/The-for_002das_002dacross-subclause.html0000644000175000017500000000554414360276512021672 0ustar cammcamm The for-as-across subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.10 The for-as-across subclause

In the for-as-across subclause the for or as construct binds the variable var to the value of each element in the array vector. The loop keyword across marks the array vector; across is used as a preposition in this syntax. Iteration stops when there are no more elements in the supplied array that can be referenced. Some implementations might recognize a the special form in the vector form to produce more efficient code.

gcl-2.6.14/info/gcl/logbitp.html0000644000175000017500000000721114360276512015022 0ustar cammcamm logbitp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.63 logbitp [Function]

logbitp index integer ⇒ generalized-boolean

Arguments and Values::

index—a non-negative integer.

integer—an integer.

generalized-boolean—a generalized boolean.

Description::

logbitp is used to test the value of a particular bit in integer, that is treated as if it were binary. The value of logbitp is true if the bit in integer whose index is index (that is, its weight is 2^index) is a one-bit; otherwise it is false.

Negative integers are treated as if they were in two’s-complement notation.

Examples::

 (logbitp 1 1) ⇒  false
 (logbitp 0 1) ⇒  true
 (logbitp 3 10) ⇒  true
 (logbitp 1000000 -1) ⇒  true
 (logbitp 2 6) ⇒  true
 (logbitp 0 6) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if index is not a non-negative integer. Should signal an error of type type-error if integer is not an integer.

Notes::

 (logbitp k n) ≡ (ldb-test (byte 1 k) n)
gcl-2.6.14/info/gcl/Kinds-of-Places.html0000644000175000017500000001000214360276512016231 0ustar cammcamm Kinds of Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generalized Reference  

5.1.2 Kinds of Places

Several kinds of places are defined by Common Lisp; this section enumerates them. This set can be extended by implementations and by programmer code.

• Variable Names as Places  
• Function Call Forms as Places  
• VALUES Forms as Places  
• THE Forms as Places  
• APPLY Forms as Places  
• Setf Expansions and Places  
• Macro Forms as Places  
• Symbol Macros as Places  
• Other Compound Forms as Places  
gcl-2.6.14/info/gcl/coerce.html0000644000175000017500000002113614360276512014624 0ustar cammcamm coerce (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.24 coerce [Function]

coerce object result-type ⇒ result

Arguments and Values::

object—an object.

result-type—a type specifier.

result—an object, of type result-type except in situations described in Rule of Canonical Representation for Complex Rationals.

Description::

Coerces the object to type result-type.

If object is already of type result-type, the object itself is returned, regardless of whether it would have been possible in general to coerce an object of some other type to result-type.

Otherwise, the object is coerced to type result-type according to the following rules:

sequence

If the result-type is a recognizable subtype of list, and the object is a sequence, then the result is a list that has the same elements as object.

If the result-type is a recognizable subtype of vector, and the object is a sequence, then the result is a vector that has the same elements as object. If result-type is a specialized type, the result has an actual array element type that is the result of upgrading the element type part of that specialized type. If no element type is specified, the element type defaults to t. If the implementation cannot determine the element type, an error is signaled.

character

If the result-type is character and the object is a character designator, the result is the character it denotes.

complex

If the result-type is complex and the object is a number, then the result is obtained by constructing a complex whose real part is the object and whose imaginary part is the result of coercing an integer zero to the type of the object (using coerce). (If the real part is a rational, however, then the result must be represented as a rational rather than a complex; see Rule of Canonical Representation for Complex Rationals. So, for example, (coerce 3 'complex) is permissible, but will return 3, which is not a complex.)

float

If the result-type is any of float, short-float, single-float, double-float, long-float, and the object is a

real,

then the result is a float of type result-type which is equal in sign and magnitude to the object to whatever degree of representational precision is permitted by that float representation. (If the result-type is float and object is not already a float, then the result is a single float.)

function

If the result-type is function, and object is any

function name

that is fbound but that is globally defined neither as a macro name nor as a special operator, then the result is the functional value of object.

If the result-type is function, and object is a lambda expression, then the result is a closure of object in the null lexical environment.

t

Any object can be coerced to an object of type t. In this case, the object is simply returned.

Examples::

 (coerce '(a b c) 'vector) ⇒  #(A B C)
 (coerce 'a 'character) ⇒  #\A
 (coerce 4.56 'complex) ⇒  #C(4.56 0.0)
 (coerce 4.5s0 'complex) ⇒  #C(4.5s0 0.0s0)
 (coerce 7/2 'complex) ⇒  7/2
 (coerce 0 'short-float) ⇒  0.0s0
 (coerce 3.5L0 'float) ⇒  3.5L0
 (coerce 7/2 'float) ⇒  3.5
 (coerce (cons 1 2) t) ⇒  (1 . 2)

All the following forms should signal an error: 

 (coerce '(a b c) '(vector * 4))
 (coerce #(a b c) '(vector * 4))
 (coerce '(a b c) '(vector * 2))
 (coerce #(a b c) '(vector * 2))
 (coerce "foo" '(string 2))
 (coerce #(#\a #\b #\c) '(string 2))
 (coerce '(0 1) '(simple-bit-vector 3))

Exceptional Situations::

If a coercion is not possible, an error of type type-error is signaled.

(coerce x 'nil) always signals an error of type type-error.

An error of type error is signaled if the result-type is function but object is a symbol that is not fbound or if the symbol names a macro or a special operator.

An error of type type-error should be signaled if result-type specifies the number of elements and object is of a different length.

See Also::

rational (Function) , floor , char-code , char-int

Notes::

Coercions from floats to rationals and from ratios to integers are not provided because of rounding problems. 

 (coerce x 't) ≡ (identity x) ≡ x

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/Syntactic-Interaction-of-Documentation-Strings-and-Declarations.html0000644000175000017500000000546414360276512027616 0ustar cammcamm Syntactic Interaction of Documentation Strings and Declarations (ANSI and GNU Common Lisp Document)

Previous: , Up: Lambda Lists  

3.4.11 Syntactic Interaction of Documentation Strings and Declarations

In a number of situations, a documentation string can appear amidst a series of declare expressions prior to a series of forms.

In that case, if a string S appears where a documentation string is permissible and is not followed by either a declare expression or a form then S is taken to be a form; otherwise, S is taken as a documentation string. The consequences are unspecified if more than one such documentation string is present.

gcl-2.6.14/info/gcl/Suppressing-Keyword-Argument-Checking.html0000644000175000017500000000546514360276512022630 0ustar cammcamm Suppressing Keyword Argument Checking (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.5 Suppressing Keyword Argument Checking

If &allow-other-keys was specified in the lambda list of a function, keyword_2 argument checking is suppressed in calls to that function.

If the :allow-other-keys argument is true in a call to a function, keyword_2 argument checking is suppressed in that call.

The :allow-other-keys argument is permissible in all situations involving keyword_2 arguments, even when its associated value is false.

gcl-2.6.14/info/gcl/Changing-the-Class-of-an-Instance.html0000644000175000017500000000776014360276512021472 0ustar cammcamm Changing the Class of an Instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.2 Changing the Class of an Instance

The function change-class can be used to change the class of an instance from its current class, C_{from}, to a different class, C_{to}; it changes the structure of the instance to conform to the definition of the class C_{to}.

Note that changing the class of an instance may cause slots to be added or deleted. Changing the class of an instance does not change its identity as defined by the eq function.

When change-class is invoked on an instance, a two-step updating process takes place. The first step modifies the structure of the instance by adding new local slots and discarding local slots that are not specified in the new version of the instance. The second step initializes the newly added local slots and performs any other user-defined actions. These two steps are further described in the two following sections.

• Modifying the Structure of the Instance  
• Initializing Newly Added Local Slots (Changing the Class of an Instance)  
• Customizing the Change of Class of an Instance  
gcl-2.6.14/info/gcl/declaim.html0000644000175000017500000000600514360276512014760 0ustar cammcamm declaim (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.17 declaim [Macro]

declaim {declaration-specifier}* ⇒ implementation-dependent

Arguments and Values::

declaration-specifier—a declaration specifier; not evaluated.

Description::

Establishes the declarations specified by the declaration-specifiers.

If a use of this macro appears as a top level form in a file being processed by the file compiler, the proclamations are also made at compile-time. As with other defining macros, it is unspecified whether or not the compile-time side-effects of a declaim persist after the file has been compiled.

Examples::

See Also::

declare, proclaim

gcl-2.6.14/info/gcl/No-Arguments-or-Values-in-The-_0022Syntax_0022-Section.html0000644000175000017500000000563014360276512024675 0ustar cammcamm No Arguments or Values in The "Syntax" Section (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.29 No Arguments or Values in The "Syntax" Section

If no arguments are permitted, or no values are returned, a special notation is used to make this more visually apparent. For example,

F <no arguments> ⇒ <no values>

indicates that F is an operator that accepts no arguments and returns no values.

gcl-2.6.14/info/gcl/Abstract-Classifications-of-Streams-_0028Introduction-to-Streams_0029.html0000644000175000017500000000423614360276512030121 0ustar cammcamm Abstract Classifications of Streams (Introduction to Streams) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.1 Abstract Classifications of Streams

gcl-2.6.14/info/gcl/defgeneric.html0000644000175000017500000004067214360276512015465 0ustar cammcamm defgeneric (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.26 defgeneric [Macro]

defgeneric function-name gf-lambda-list [[!option | {!method-description}*]]
⇒ new-generic

option ::=(:argument-precedence-order {parameter-name}^+) |            (declare {gf-declaration}^+) |            (:documentation gf-documentation) |            (:method-combination method-combination {method-combination-argument}*) |            (:generic-function-class generic-function-class) |            (:method-class method-class)

method-description ::=(:method {method-qualifier}* specialized-lambda-list [[{declaration}* | documentation]] {form}*)

Arguments and Values::

function-name—a function name.

generic-function-class—a non-nil symbol naming a class.

gf-declaration—an optimize declaration specifier; other declaration specifiers are not permitted.

gf-documentation—a string; not evaluated.

gf-lambda-list—a generic function lambda list.

method-class—a non-nil symbol naming a class.

method-combination-argument—an object.

method-combination-name—a symbol naming a method combination type.

method-qualifiers, specialized-lambda-list, declarations, documentation, forms—as per defmethod.

new-generic—the generic function object.

parameter-name—a symbol that names a required parameter in the lambda-list. (If the :argument-precedence-order option is specified, each required parameter in the lambda-list must be used exactly once as a parameter-name.)

Description::

The macro defgeneric is used to define a generic function or to specify options and declarations that pertain to a generic function as a whole.

If function-name is a list it must be of the form (setf symbol). If (fboundp function-name) is false, a new generic function is created.

If (fdefinition function-name) is a generic function, that

generic function is modified. If function-name names an ordinary function, a macro, or a special operator, an error is signaled.

The effect of the defgeneric macro is as if the following three steps were performed: first, methods defined by previous defgeneric forms are removed;

[Reviewer Note by Barmar: Shouldn’t this (second) be first?] second, ensure-generic-function is called; and finally, methods specified by the current defgeneric form are added to the generic function.

Each method-description defines a method on the generic function. The lambda list of each method must be congruent with the lambda list specified by the gf-lambda-list option. If no method descriptions are specified and a generic function of the same name does not already exist, a generic function with no methods is created.

The gf-lambda-list argument of defgeneric specifies the shape of lambda lists for the methods on this generic function. All methods on the resulting generic function must have lambda lists that are congruent with this shape. If a defgeneric form is evaluated and some methods for that generic function have lambda lists that are not congruent with that given in the defgeneric form, an error is signaled. For further details on method congruence, see Congruent Lambda-lists for all Methods of a Generic Function.

The generic function passes to the method all the argument values passed to it, and only those; default values are not supported. Note that optional and keyword arguments in method definitions, however, can have default initial value forms and can use supplied-p parameters.

The following options are provided.

Except as otherwise noted,

a given option may occur only once.

*

The :argument-precedence-order option is used to specify the order in which the required arguments in a call to the generic function are tested for specificity when selecting a particular method. Each required argument, as specified in the gf-lambda-list argument, must be included exactly once as a parameter-name so that the full and unambiguous precedence order is supplied. If this condition is not met, an error is signaled.

[Reviewer Note by Barmar: What is the default order?]

*

The declare option is used to specify declarations that pertain to the generic function.

An optimize declaration specifier is allowed. It specifies whether method selection should be optimized for speed or space, but it has no effect on methods. To control how a method is optimized, an optimize declaration must be placed directly in the defmethod form or method description. The optimization qualities speed and space are the only qualities this standard requires, but an implementation can extend the object system to recognize other qualities. A simple implementation that has only one method selection technique and ignores optimize declaration specifiers is valid.

The special, ftype, function, inline, notinline, and declaration declarations are not permitted. Individual implementations can extend the declare option to support additional declarations.

[Editorial Note by KMP: Does “additional” mean including special, ftype, etc.? Or only other things that are not mentioned here?] If an implementation notices a declaration specifier that it does not support and that has not been proclaimed as a non-standard declaration identifier name in a declaration proclamation, it should issue a warning. [Editorial Note by KMP: The wording of this previous sentence, particularly the word “and” suggests to me that you can ‘proclaim declaration’ of an unsupported declaration (e.g., ftype) in order to suppress the warning. That seems wrong. Perhaps it instead means to say “does not support or is both undefined and not proclaimed declaration.”]

The declare option may be specified more than once. The effect is the same as if the lists of declaration specifiers had been appended together into a single list and specified as a single declare option.

*

The :documentation argument is a documentation string to be attached to the generic function object, and to be attached with kind function to the function-name.

*

The :generic-function-class option may be used to specify that the generic function is to have a different class than the default provided by the system (the class standard-generic-function). The class-name argument is the name of a class that can be the class of a generic function. If function-name specifies an existing generic function that has a different value for the :generic-function-class argument and the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error is signaled.

*

The :method-class option is used to specify that all methods on this generic function are to have a different class from the default provided by the system (the class standard-method). The class-name argument is the name of a class that is capable of being the class of a method.

[Reviewer Note by Barmar: Is change-class called on existing methods?]

*

The :method-combination option is followed by a symbol that names a type of method combination. The arguments (if any) that follow that symbol depend on the type of method combination. Note that the standard method combination type does not support any arguments. However, all types of method combination defined by the short form of define-method-combination accept an optional argument named order, defaulting to :most-specific-first, where a value of :most-specific-last reverses the order of the primary methods without affecting the order of the auxiliary methods.

The method-description arguments define methods that will be associated with the generic function. The method-qualifier and specialized-lambda-list arguments in a method description are the same as for defmethod.

The form arguments specify the method body. The body of the method is enclosed in an implicit block. If function-name is a symbol, this block bears the same name as the generic function. If function-name is a list of the form (setf symbol), the name of the block is symbol.

Implementations can extend defgeneric to include other options. It is required that an implementation signal an error if it observes an option that is not implemented locally.

defgeneric is not required to perform any compile-time side effects. In particular, the methods are not installed for invocation during compilation. An implementation may choose to store information about the generic function for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen).

Examples::

Exceptional Situations::

If function-name names an ordinary function, a macro, or a special operator, an error of type program-error is signaled.

Each required argument, as specified in the gf-lambda-list argument, must be included exactly once as a parameter-name, or an error of type program-error is signaled.

The lambda list of each method specified by a method-description must be congruent with the lambda list specified by the gf-lambda-list option, or an error of type error is signaled.

If a defgeneric form is evaluated and some methods for that generic function have lambda lists that are not congruent with that given in the defgeneric form, an error of type error is signaled.

A given option may occur only once, or an error of type program-error is signaled.

[Reviewer Note by Barmar: This says that an error is signaled if you specify the same generic function class as it already has!] If function-name specifies an existing generic function that has a different value for the :generic-function-class argument and the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error of type error is signaled.

Implementations can extend defgeneric to include other options. It is required that an implementation signal an error of type program-error if it observes an option that is not implemented locally.

See Also::

defmethod , documentation , ensure-generic-function ,

generic-function,

Congruent Lambda-lists for all Methods of a Generic Function

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/print_002dobject.html0000644000175000017500000002140314360276512016431 0ustar cammcamm print-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.11 print-object [Standard Generic Function]

Syntax::

print-object object stream ⇒ object

Method Signatures::

print-object (object standard-object) stream

print-object (object structure-object) stream

Arguments and Values::

object—an object.

stream—a stream.

Description::

The generic function print-object writes the printed representation of object to stream. The function print-object is called by the Lisp printer; it should not be called by the user.

Each implementation is required to provide a method on the class standard-object and on the class structure-object. In addition, each implementation must provide methods on enough other classes so as to ensure that there is always an applicable method. Implementations are free to add methods for other classes. Users may write methods for print-object for their own classes if they do not wish to inherit an implementation-dependent method.

The method on the class structure-object prints the object in the default #S notation; see Printing Structures.

Methods on print-object are responsible for implementing their part of the semantics of the printer control variables, as follows:

*print-readably*

All methods for print-object must obey *print-readably*. This includes both user-defined methods and implementation-defined methods. Readable printing of structures and standard objects is controlled by their print-object method, not by their make-load-form method. Similarity for these objects is application dependent and hence is defined to be whatever these methods do; see Similarity of Literal Objects.

*print-escape*

Each method must implement *print-escape*.

*print-pretty*

The method may wish to perform specialized line breaking or other output conditional on the value of *print-pretty*. For further information, see (for example) the macro pprint-fill. See also Pretty Print Dispatch Tables and Examples of using the Pretty Printer.

*print-length*

Methods that produce output of indefinite length must obey *print-length*.

For further information, see (for example) the macros pprint-logical-block and pprint-pop. See also Pretty Print Dispatch Tables and Examples of using the Pretty Printer.

*print-level*

The printer takes care of *print-level* automatically, provided that each method handles exactly one level of structure and calls write (or an equivalent function) recursively if there are more structural levels. The printer’s decision of whether an object has components (and therefore should not be printed when the printing depth is not less than *print-level*) is implementation-dependent. In some implementations its print-object method is not called; in others the method is called, and the determination that the object has components is based on what it tries to write to the stream.

*print-circle*

When the value of *print-circle* is true, a user-defined

print-object method

can print objects to the supplied stream using write, prin1, princ, or format and expect circularities to be detected and printed using the #n# syntax. If a user-defined

print-object method

prints to a stream other than the one that was supplied, then circularity detection starts over for that stream. See *print-circle*.

*print-base*,

*print-radix*, *print-case*, *print-gensym*, and *print-array* These printer control variables apply to specific types of objects and are handled by the methods for those objects.

If these rules are not obeyed, the results are undefined.

In general, the printer and the print-object methods should not rebind the print control variables as they operate recursively through the structure, but this is implementation-dependent.

In some implementations the stream argument passed to a print-object method is not the original stream, but is an intermediate stream that implements part of the printer. methods should therefore not depend on the identity of this stream.

See Also::

pprint-fill , pprint-logical-block , pprint-pop , write , *print-readably*, *print-escape*, *print-pretty*, *print-length*, Default Print-Object Methods,

Printing Structures,

Pretty Print Dispatch Tables, Examples of using the Pretty Printer

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/division_002dby_002dzero.html0000644000175000017500000000513214360276512017713 0ustar cammcamm division-by-zero (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.80 division-by-zero [Condition Type]

Class Precedence List::

division-by-zero, arithmetic-error, error, serious-condition, condition, t

Description::

The type division-by-zero consists of error conditions that occur because of division by zero.

gcl-2.6.14/info/gcl/Argument-Conventions-of-Some-Reader-Functions.html0000644000175000017500000000514014360276512024117 0ustar cammcamm Argument Conventions of Some Reader Functions (ANSI and GNU Common Lisp Document)

Previous: , Up: Reader Concepts  

23.1.3 Argument Conventions of Some Reader Functions

• The EOF-ERROR-P argument  
• The RECURSIVE-P argument  
gcl-2.6.14/info/gcl/Rule-of-Float-Precision-Contagion.html0000644000175000017500000000434114360276512021607 0ustar cammcamm Rule of Float Precision Contagion (ANSI and GNU Common Lisp Document)

Previous: , Up: Floating-point Computations  

12.1.4.5 Rule of Float Precision Contagion

The result of a numerical function is a float of the largest format among all the floating-point arguments to the function.

gcl-2.6.14/info/gcl/built_002din_002dclass.html0000644000175000017500000000612514360276512017333 0ustar cammcamm built-in-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.8 built-in-class [System Class]

Class Precedence List::

built-in-class, class,

standard-object,

t

Description::

A built-in class is a class whose instances have restricted capabilities or special representations. Attempting to use defclass to define subclasses of a built-in class signals an error of type error. Calling make-instance to create an instance of a built-in class signals an error of type error. Calling slot-value on an instance of a built-in class signals an error of type error. Redefining a built-in class or using change-class to change the class of an instance to or from a built-in class signals an error of type error. However, built-in classes can be used as parameter specializers in methods.

gcl-2.6.14/info/gcl/Logical-Operations-on-Integers.html0000644000175000017500000000637114360276512021253 0ustar cammcamm Logical Operations on Integers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numeric Operations  

12.1.1.5 Logical Operations on Integers

Logical operations require integers as arguments; an error of type type-error should be signaled if an argument is supplied that is not an integer. Integer arguments to logical operations are treated as if they were represented in two’s-complement notation.

Figure 12–5 shows defined names relating to logical operations on numbers. 

  ash          boole-ior       logbitp   
  boole        boole-nand      logcount  
  boole-1      boole-nor       logeqv    
  boole-2      boole-orc1      logior    
  boole-and    boole-orc2      lognand   
  boole-andc1  boole-set       lognor    
  boole-andc2  boole-xor       lognot    
  boole-c1     integer-length  logorc1   
  boole-c2     logand          logorc2   
  boole-clr    logandc1        logtest   
  boole-eqv    logandc2        logxor    

  Figure 12–5: Defined names relating to logical operations on numbers.
gcl-2.6.14/info/gcl/Streams-Dictionary.html0000644000175000017500000002663114360276512017112 0ustar cammcamm Streams Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Streams  

21.2 Streams Dictionary

• stream  
• broadcast-stream  
• concatenated-stream  
• echo-stream  
• file-stream  
• string-stream  
• synonym-stream  
• two-way-stream  
• input-stream-p  
• interactive-stream-p  
• open-stream-p  
• stream-element-type  
• streamp  
• read-byte  
• write-byte  
• peek-char  
• read-char  
• read-char-no-hang  
• terpri  
• unread-char  
• write-char  
• read-line  
• write-string  
• read-sequence  
• write-sequence  
• file-length  
• file-position  
• file-string-length  
• open  
• stream-external-format  
• with-open-file  
• close  
• with-open-stream  
• listen  
• clear-input  
• finish-output  
• y-or-n-p  
• make-synonym-stream  
• synonym-stream-symbol  
• broadcast-stream-streams  
• make-broadcast-stream  
• make-two-way-stream  
• two-way-stream-input-stream  
• echo-stream-input-stream  
• make-echo-stream  
• concatenated-stream-streams  
• make-concatenated-stream  
• get-output-stream-string  
• make-string-input-stream  
• make-string-output-stream  
• with-input-from-string  
• with-output-to-string  
• *debug-io*  
• *terminal-io*  
• stream-error  
• stream-error-stream  
• end-of-file  

Previous: , Up: Streams  

gcl-2.6.14/info/gcl/fmakunbound.html0000644000175000017500000000657414360276512015706 0ustar cammcamm fmakunbound (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.5 fmakunbound [Function]

fmakunbound name ⇒ name

Pronunciation::

pronounced ,ef ’mak e n,baund or pronounced ,ef ’m\=a k e n,baund

Arguments and Values::

name—a function name.

Description::

Removes the function or macro definition, if any, of name in the global environment.

Examples::

(defun add-some (x) (+ x 19)) ⇒  ADD-SOME
 (fboundp 'add-some) ⇒  true
 (flet ((add-some (x) (+ x 37)))
    (fmakunbound 'add-some)
    (add-some 1)) ⇒  38
 (fboundp 'add-some) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if name is not a function name.

The consequences are undefined if name is a special operator.

See Also::

fboundp , makunbound

gcl-2.6.14/info/gcl/random.html0000644000175000017500000001024514360276512014643 0ustar cammcamm random (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.41 random [Function]

random limit &optional random-state ⇒ random-number

Arguments and Values::

limit—a positive integer, or a positive float.

random-state—a random state. The default is the current random state.

random-number—a non-negative number less than limit and of the same type as limit.

Description::

Returns a pseudo-random number that is a non-negative number less than limit and of the same type as limit.

The random-state, which is modified by this function, encodes the internal state maintained by the random number generator.

An approximately uniform choice distribution is used. If limit is an integer, each of the possible results occurs with (approximate) probability 1/limit.

Examples::

 (<= 0 (random 1000) 1000) ⇒  true
 (let ((state1 (make-random-state))
       (state2 (make-random-state)))
   (= (random 1000 state1) (random 1000 state2))) ⇒  true

Side Effects::

The random-state is modified.

Exceptional Situations::

Should signal an error of type type-error if limit is not a positive integer or a positive real.

See Also::

make-random-state , random-state

Notes::

See Common Lisp: The Language for information about generating random numbers.

gcl-2.6.14/info/gcl/Declaration-Specifiers.html0000644000175000017500000000474714360276512017714 0ustar cammcamm Declaration Specifiers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Declarations  

3.3.2 Declaration Specifiers

A declaration specifier is an expression that can appear at top level of a declare expression or a declaim form, or as the argument to proclaim. It is a list whose car is a declaration identifier, and whose cdr is data interpreted according to rules specific to the declaration identifier.

gcl-2.6.14/info/gcl/The-for_002das_002dequals_002dthen-subclause.html0000644000175000017500000000571114360276512023272 0ustar cammcamm The for-as-equals-then subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.8 The for-as-equals-then subclause

In the for-as-equals-then subclause the for or as construct initializes the variable var by setting it to the result of evaluating form1 on the first iteration, then setting it to the result of evaluating form2 on the second and subsequent iterations. If form2 is omitted, the construct uses form1 on the second and subsequent iterations. The loop keywords = and then serve as valid prepositions in this syntax. This construct does not provide any termination tests.

gcl-2.6.14/info/gcl/_002arandom_002dstate_002a.html0000644000175000017500000000752514360276512017704 0ustar cammcamm *random-state* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.43 *random-state* [Variable]

Value Type::

a random state.

Initial Value::

implementation-dependent.

Description::

The current random state, which is used, for example, by the function random when a random state is not explicitly supplied.

Examples::

 (random-state-p *random-state*) ⇒  true
 (setq snap-shot (make-random-state))
 ;; The series from any given point is random,
 ;; but if you backtrack to that point, you get the same series.
 (list (loop for i from 1 to 10 collect (random))
       (let ((*random-state* snap-shot))
         (loop for i from 1 to 10 collect (random)))
       (loop for i from 1 to 10 collect (random))
       (let ((*random-state* snap-shot))
         (loop for i from 1 to 10 collect (random))))
⇒  ((19 16 44 19 96 15 76 96 13 61)
    (19 16 44 19 96 15 76 96 13 61)
    (16 67 0 43 70 79 58 5 63 50)
    (16 67 0 43 70 79 58 5 63 50))

Affected By::

The implementation.

random.

See Also::

make-random-state , random , random-state

Notes::

Binding *random-state* to a different random state object correctly saves and restores the old random state object.

gcl-2.6.14/info/gcl/Character-Names.html0000644000175000017500000000661214360276512016323 0ustar cammcamm Character Names (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.7 Character Names

The following character names must be present in all conforming implementations:

Newline

The character that represents the division between lines. An implementation must translate between #\Newline, a single-character representation, and whatever external representation(s) may be used.

Space

The space or blank character.

The following names are semi-standard; if an implementation supports them, they should be used for the described characters and no others.

Rubout

The rubout or delete character.

Page

The form-feed or page-separator character.

Tab

The tabulate character.

Backspace

The backspace character.

Return

The carriage return character.

Linefeed

The line-feed character.

In some implementations, one or more of these character names might denote a standard character; for example, #\Linefeed and #\Newline might be the same character in some implementations.

gcl-2.6.14/info/gcl/integerp.html0000644000175000017500000000567514360276512015213 0ustar cammcamm integerp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.58 integerp [Function]

integerp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type integer; otherwise, returns false.

Examples::

 (integerp 1) ⇒  true
 (integerp (expt 2 130)) ⇒  true
 (integerp 6/5) ⇒  false
 (integerp nil) ⇒  false

Notes::

 (integerp object) ≡ (typep object 'integer)
gcl-2.6.14/info/gcl/Packages-No-Longer-Required.html0000644000175000017500000000435214360276512020457 0ustar cammcamm Packages No Longer Required (ANSI and GNU Common Lisp Document)

Previous: , Up: Removed Language Features  

27.1.7 Packages No Longer Required

The packages LISP , USER , and SYSTEM

are no longer required. It is valid for packages with one or more of these names to be provided by a conforming implementation as extensions.

gcl-2.6.14/info/gcl/Syntax-of-a-Float.html0000644000175000017500000001320514360276512016533 0ustar cammcamm Syntax of a Float (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Constructing Numbers from Tokens  

2.3.2.4 Syntax of a Float

Floats can be written in either decimal fraction or computerized scientific notation: an optional sign, then a non-empty sequence of digits with an embedded decimal point, then an optional decimal exponent specification. If there is no exponent specifier, then the decimal point is required, and there must be digits after it. The exponent specifier consists of an exponent marker, an optional sign, and a non-empty sequence of digits. If no exponent specifier is present, or if the exponent marker e (or E) is used, then the format specified by *read-default-float-format* is used. See Figure~2–9.

An implementation may provide one or more kinds of float that collectively make up the type float. The letters s, f, d, and l (or their respective uppercase equivalents) explicitly specify the use of the types short-float, single-float, double-float, and long-float, respectively.

The internal format used for an external representation depends only on the exponent marker, and not on the number of decimal digits in the external representation.

Figure 2–14 contains examples of notations for floats: 

  0.0       ;Floating-point zero in default format                          
  0E0       ;As input, this is also floating-point zero in default format.  
            ;As output, this would appear as 0.0.                           
  0e0       ;As input, this is also floating-point zero in default format.  
            ;As output, this would appear as 0.0.                           
  -.0       ;As input, this might be a zero or a minus zero,                
            ; depending on whether the implementation supports              
            ; a distinct minus zero.                                        
            ;As output, 0.0 is zero and -0.0 is minus zero.                 
  0.        ;On input, the integer zero—not a floating-point number!      
            ;Whether this appears as 0 or 0. on output depends              
            ;on the value of *print-radix*.                                 
  0.0s0     ;A floating-point zero in short format                          
  0s0       ;As input, this is a floating-point zero in short format.       
            ;As output, such a zero would appear as 0.0s0                   
            ; (or as 0.0 if short-float was the default format).            
  6.02E+23  ;Avogadro’s number, in default format                           
  602E+21   ;Also Avogadro’s number, in default format                      

               Figure 2–14: Examples of Floating-point numbers

For information on how floats are printed, see Printing Floats.

Next: , Previous: , Up: Constructing Numbers from Tokens  

gcl-2.6.14/info/gcl/The-KEYWORD-Package.html0000644000175000017500000000604114360276512016555 0ustar cammcamm The KEYWORD Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.6 The KEYWORD Package

The KEYWORD package contains symbols, called keywords_1, that are typically used as special markers in programs and their associated data expressions_1.

Symbol tokens that start with a package marker are parsed by the Lisp reader as symbols in the KEYWORD package; see Symbols as Tokens. This makes it notationally convenient to use keywords when communicating between programs in different packages. For example, the mechanism for passing keyword parameters in a call uses keywords_1 to name the corresponding arguments; see Ordinary Lambda Lists.

Symbols in the KEYWORD package are, by definition, of type keyword.

gcl-2.6.14/info/gcl/Lowercase-Characters.html0000644000175000017500000000464514360276512017373 0ustar cammcamm Lowercase Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.5 Lowercase Characters

A lowercase character is one that has a corresponding uppercase character that is different (and can be obtained using char-upcase).

Of the standard characters, only these are lowercase characters:

a b c d e f g h i j k l m n o p q r s t u v w x y z

gcl-2.6.14/info/gcl/make_002dhash_002dtable.html0000644000175000017500000001375414360276512017436 0ustar cammcamm make-hash-table (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.2 make-hash-table [Function]

make-hash-table &key test size rehash-size rehash-threshold ⇒ hash-table

Arguments and Values::

test—a designator for one of the functions eq, eql, equal, or

equalp.

The default is eql.

size—a non-negative integer.

The default is implementation-dependent.

rehash-size—a real of type (or (integer 1 *) (float (1.0) *)). The default is implementation-dependent.

rehash-threshold—a real of type (real 0 1). The default is implementation-dependent.

hash-table—a hash table.

Description::

Creates and returns a new hash table.

test determines how keys are compared. An object is said to be present in the hash-table if that object is the same under the test as the key for some entry in the hash-table.

size is a hint to the implementation about how much initial space to allocate in the hash-table.

This information, taken together with the rehash-threshold, controls the approximate number of entries which it should be possible to insert before the table has to grow.

The actual size might be rounded up from size to the next ‘good’ size; for example, some implementations might round to the next prime number.

rehash-size specifies a minimum amount to increase the size of the hash-table when it becomes full enough to require rehashing; see rehash-theshold below.

If rehash-size is an integer, the expected growth rate for the table is additive and the integer is the number of entries to add; if it is a float, the expected growth rate for the table is multiplicative and the float is the ratio of the new size to the old size.

As with size, the actual size of the increase might be rounded up.

rehash-threshold specifies how full the hash-table can get before it must grow.

It specifies the maximum desired hash-table occupancy level.

The values of rehash-size and rehash-threshold do not constrain the implementation to use any particular method for computing when and by how much the size of hash-table should be enlarged. Such decisions are implementation-dependent, and these values only hints from the programmer to the implementation, and the implementation is permitted to ignore them.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 46142754>
 (setf (gethash "one" table) 1) ⇒  1
 (gethash "one" table) ⇒  NIL, false
 (setq table (make-hash-table :test 'equal)) ⇒  #<HASH-TABLE EQUAL 0/139 46145547>
 (setf (gethash "one" table) 1) ⇒  1
 (gethash "one" table) ⇒  1, T
 (make-hash-table :rehash-size 1.5 :rehash-threshold 0.7) 
⇒  #<HASH-TABLE EQL 0/120 46156620>

See Also::

gethash , hash-table

Next: , Previous: , Up: Hash Tables Dictionary  

gcl-2.6.14/info/gcl/package_002derror_002dpackage.html0000644000175000017500000000566114360276512020624 0ustar cammcamm package-error-package (ANSI and GNU Common Lisp Document)

Previous: , Up: Packages Dictionary  

11.2.30 package-error-package [Function]

package-error-package condition ⇒ package

Arguments and Values::

condition—a condition of type package-error.

package—a package designator.

Description::

Returns a designator for the offending package in the situation represented by the condition.

Examples::

 (package-error-package 
   (make-condition 'package-error
     :package (find-package "COMMON-LISP")))
⇒  #<Package "COMMON-LISP">

See Also::

package-error

gcl-2.6.14/info/gcl/Redefining-Classes.html0000644000175000017500000001467614360276512017044 0ustar cammcamm Redefining Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.6 Redefining Classes

A class that is a direct instance of standard-class can be redefined if the new class is also a direct instance of standard-class. Redefining a class modifies the existing class object to reflect the new class definition; it does not create a new class object for the class. Any method object created by a :reader, :writer, or :accessor option specified by the old defclass form is removed from the corresponding generic function. Methods specified by the new defclass form are added.

When the class C is redefined, changes are propagated to its instances and to instances of any of its subclasses. Updating such an instance occurs at an implementation-dependent time, but no later than the next time a slot of that instance is read or written. Updating an instance does not change its identity as defined by the function eq. The updating process may change the slots of that particular instance, but it does not create a new instance. Whether updating an instance consumes storage is implementation-dependent.

Note that redefining a class may cause slots to be added or deleted. If a class is redefined in a way that changes the set of local slots accessible in instances, the instances are updated. It is implementation-dependent whether instances are updated if a class is redefined in a way that does not change the set of local slots accessible in instances.

The value of a slot that is specified as shared both in the old class and in the new class is retained. If such a shared slot was unbound in the old class, it is unbound in the new class. Slots that were local in the old class and that are shared in the new class are initialized. Newly added shared slots are initialized.

Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified in the defclass form for the new class. If there was no initialization form, the slot is unbound.

If a class is redefined in such a way that the set of local slots accessible in an instance of the class is changed, a two-step process of updating the instances of the class takes place. The process may be explicitly started by invoking the generic function make-instances-obsolete. This two-step process can happen in other circumstances in some implementations. For example, in some implementations this two-step process is triggered if the order of slots in storage is changed.

The first step modifies the structure of the instance by adding new local slots and discarding local slots that are not defined in the new version of the class. The second step initializes the newly-added local slots and performs any other user-defined actions. These two steps are further specified in the next two sections.

• Modifying the Structure of Instances  
• Initializing Newly Added Local Slots (Redefining Classes)  
• Customizing Class Redefinition  

Next: , Previous: , Up: Classes  

gcl-2.6.14/info/gcl/inspect.html0000644000175000017500000000634514360276512015036 0ustar cammcamm inspect (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.18 inspect [Function]

inspect object ⇒ implementation-dependent

Arguments and Values::

object—an object.

Description::

inspect is an interactive version of describe. The nature of the interaction is implementation-dependent, but the purpose of inspect is to make it easy to wander through a data structure, examining and modifying parts of it.

Side Effects::

implementation-dependent.

Affected By::

implementation-dependent.

Exceptional Situations::

implementation-dependent.

See Also::

describe

Notes::

Implementations are encouraged to respond to the typing of ? or a “help key” by providing help, including a list of commands.

gcl-2.6.14/info/gcl/Symbols.html0000644000175000017500000000430214360276512015010 0ustar cammcamm Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

10 Symbols

• Symbol Concepts  
• Symbols Dictionary  
gcl-2.6.14/info/gcl/The-Pathname-Version-Component.html0000644000175000017500000000504514360276512021223 0ustar cammcamm The Pathname Version Component (ANSI and GNU Common Lisp Document)

Previous: , Up: Pathname Components  

19.2.1.6 The Pathname Version Component

Corresponds to the “version number” concept in many host file systems.

The version is either a positive integer or a symbol from the following list: nil, :wild, :unspecific, or :newest (refers to the largest version number that already exists in the file system when reading a file, or to a version number greater than any already existing in the file system when writing a new file). Implementations can define other special version symbols.

gcl-2.6.14/info/gcl/Internal-Time.html0000644000175000017500000000474414360276512016042 0ustar cammcamm Internal Time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Time  

25.1.4.3 Internal Time

Internal time represents time as a single integer, in terms of an implementation-dependent unit called an internal time unit. Relative time is measured as a number of these units. Absolute time is relative to an arbitrary time base.

Figure 25–7 shows defined names related to internal time. 

  get-internal-real-time  internal-time-units-per-second  
  get-internal-run-time                                   

  Figure 25–7: Defined names involving time in Internal Time.
gcl-2.6.14/info/gcl/butlast.html0000644000175000017500000001122414360276512015037 0ustar cammcamm butlast (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.28 butlast, nbutlast [Function]

butlast list &optional n ⇒ result-list

nbutlast list &optional n ⇒ result-list

Arguments and Values::

list—a list,

which might be a dotted list but must not be a circular list.

n—a non-negative integer.

result-list—a list.

Description::

butlast returns a copy of list from which the last n

conses

have been omitted. If n is not supplied, its value is 1. If there are fewer than n

conses

in list, nil is returned and, in the case of nbutlast, list is not modified.

nbutlast is like butlast, but nbutlast may modify list. It changes the cdr of the cons n+1 from the end of the list to nil.

Examples::

 (setq lst '(1 2 3 4 5 6 7 8 9)) ⇒  (1 2 3 4 5 6 7 8 9)
 (butlast lst) ⇒  (1 2 3 4 5 6 7 8)
 (butlast lst 5) ⇒  (1 2 3 4)
 (butlast lst (+ 5 5)) ⇒  NIL
 lst ⇒  (1 2 3 4 5 6 7 8 9)
 (nbutlast lst 3) ⇒  (1 2 3 4 5 6)
 lst ⇒  (1 2 3 4 5 6)
 (nbutlast lst 99) ⇒  NIL
 lst ⇒  (1 2 3 4 5 6)
 (butlast '(a b c d)) ⇒  (A B C)
 (butlast '((a b) (c d))) ⇒  ((A B))
 (butlast '(a)) ⇒  NIL
 (butlast nil) ⇒  NIL
 (setq foo (list 'a 'b 'c 'd)) ⇒  (A B C D)
 (nbutlast foo) ⇒  (A B C)
 foo ⇒  (A B C)
 (nbutlast (list 'a)) ⇒  NIL
 (nbutlast '()) ⇒  NIL

Exceptional Situations::

Should signal an error of type type-error if list is not a proper list or a dotted list.

Should signal an error of type type-error if n is not a non-negative integer.

Notes::

 (butlast list n) ≡ (ldiff list (last list n))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Argument-Mismatch-Detection.html0000644000175000017500000000746014360276512020631 0ustar cammcamm Argument Mismatch Detection (ANSI and GNU Common Lisp Document)

Previous: , Up: Error Checking in Function Calls  

3.5.1 Argument Mismatch Detection

• Safe and Unsafe Calls  
• Error Detection Time in Safe Calls  
• Too Few Arguments  
• Too Many Arguments  
• Unrecognized Keyword Arguments  
• Invalid Keyword Arguments  
• Odd Number of Keyword Arguments  
• Destructuring Mismatch  
• Errors When Calling a Next Method  
gcl-2.6.14/info/gcl/structure_002dclass.html0000644000175000017500000000473314360276512017203 0ustar cammcamm structure-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.9 structure-class [System Class]

Class Precedence List::

structure-class, class,

standard-object,

t

Description::

All classes defined by means of defstruct are instances of the class structure-class.

gcl-2.6.14/info/gcl/Shared_002dInitialize.html0000644000175000017500000001304114360276512017335 0ustar cammcamm Shared-Initialize (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.5 Shared-Initialize

The generic function shared-initialize is used to fill the slots of an instance using initialization arguments and :initform forms when an instance is created, when an instance is re-initialized, when an instance is updated to conform to a redefined class, and when an instance is updated to conform to a different class. It uses standard method combination. It takes the following arguments: the instance to be initialized, a specification of a set of names of slots accessible in that instance, and any number of initialization arguments. The arguments after the first two must form an initialization argument list.

The second argument to shared-initialize may be one of the following:

*

It can be a (possibly empty) list of slot names, which specifies the set of those slot names.

*

It can be the symbol t, which specifies the set of all of the slots.

There is a system-supplied primary method for shared-initialize whose first parameter specializer is the class standard-object. This method behaves as follows on each slot, whether shared or local:

*

If an initialization argument in the initialization argument list specifies a value for that slot, that value is stored into the slot, even if a value has already been stored in the slot before the method is run. The affected slots are independent of which slots are indicated by the second argument to shared-initialize.

*

Any slots indicated by the second argument that are still unbound at this point are initialized according to their :initform forms. For any such slot that has an :initform form, that form is evaluated in the lexical environment of its defining defclass form and the result is stored into the slot. For example, if a before method stores a value in the slot, the :initform form will not be used to supply a value for the slot. If the second argument specifies a name that does not correspond to any slots accessible in the instance, the results are unspecified.

*

The rules mentioned in Rules for Initialization Arguments are obeyed.

The generic function shared-initialize is called by the system-supplied primary methods for reinitialize-instance, update-instance-for-different-class, update-instance-for-redefined-class, and initialize-instance. Thus, methods can be written for shared-initialize to specify actions that should be taken in all of these contexts.

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/rationalp.html0000644000175000017500000000605014360276512015353 0ustar cammcamm rationalp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.55 rationalp [Function]

rationalp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type rational; otherwise, returns false.

Examples::

 (rationalp 12) ⇒  true
 (rationalp 6/5) ⇒  true
 (rationalp 1.212) ⇒  false

See Also::

rational (Function)

Notes::

 (rationalp object) ≡ (typep object 'rational)
gcl-2.6.14/info/gcl/string_002dtrim.html0000644000175000017500000001012314360276512016305 0ustar cammcamm string-trim (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.9 string-trim, string-left-trim, string-right-trim [Function]

string-trim character-bag string ⇒ trimmed-string

string-left-trim character-bag string ⇒ trimmed-string

string-right-trim character-bag string ⇒ trimmed-string

Arguments and Values::

character-bag—a sequence containing characters.

string—a string designator.

trimmed-string—a string.

Description::

string-trim returns a substring of string, with all characters in character-bag stripped off the beginning and end. string-left-trim is similar but strips characters off only the beginning; string-right-trim strips off only the end.

If no characters need to be trimmed from the string, then either string itself or a copy of it may be returned, at the discretion of the implementation.

All of these functions observe the fill pointer.

Examples::

 (string-trim "abc" "abcaakaaakabcaaa") ⇒  "kaaak"
 (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
        ") ⇒  "garbanzo beans"
 (string-trim " (*)" " ( *three (silly) words* ) ")
⇒  "three (silly) words"

 (string-left-trim "abc" "labcabcabc") ⇒  "labcabcabc"
 (string-left-trim " (*)" " ( *three (silly) words* ) ")
⇒  "three (silly) words* ) "

 (string-right-trim " (*)" " ( *three (silly) words* ) ") 
⇒  " ( *three (silly) words"

Affected By::

The implementation.

gcl-2.6.14/info/gcl/Unconditional-Transfer-of-Control-in-The-_0022Syntax_0022-Section.html0000644000175000017500000000554014360276512027113 0ustar cammcamm Unconditional Transfer of Control in The "Syntax" Section (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.30 Unconditional Transfer of Control in The "Syntax" Section

Some operators perform an unconditional transfer of control, and so never have any return values. Such operators are notated using a notation such as the following:

F a b c ⇒ #<NoValue>

gcl-2.6.14/info/gcl/_002b-_0028Variable_0029.html0000644000175000017500000000714214360276512017035 0ustar cammcamm + (Variable) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.21 +, ++, +++ [Variable]

Value Type::

an object.

Initial Value::

implementation-dependent.

Description::

The variables +, ++, and +++ are maintained by the Lisp read-eval-print loop to save forms that were recently evaluated.

The value of + is the last form that was evaluated, the value of ++ is the previous value of +, and the value of +++ is the previous value of ++.

Examples::

(+ 0 1) ⇒  1
(- 4 2) ⇒  2
(/ 9 3) ⇒  3
(list + ++ +++) ⇒  ((/ 9 3) (- 4 2) (+ 0 1))
(setq a 1 b 2 c 3 d (list a b c)) ⇒  (1 2 3)
(setq a 4 b 5 c 6 d (list a b c)) ⇒  (4 5 6)
(list a b c) ⇒  (4 5 6)
(eval +++) ⇒  (1 2 3)
#.`(,@++ d) ⇒  (1 2 3 (1 2 3))

Affected By::

Lisp read-eval-print loop.

See Also::

- (variable), * (variable), / (variable), Top level loop

gcl-2.6.14/info/gcl/Sharpsign-S.html0000644000175000017500000000607314360276512015525 0ustar cammcamm Sharpsign S (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.14 Sharpsign S

#s(name slot1 value1 slot2 value2 ...) denotes a structure. This is valid only if name is the name of a structure type already defined by defstruct and if the structure type has a standard constructor function. Let cm stand for the name of this constructor function; then this syntax is equivalent to 

 #.(cm keyword1 'value1 keyword2 'value2 ...)

where each keywordj is the result of computing 

 (intern (string slotj) (find-package 'keyword))

The net effect is that the constructor function is called with the specified slots having the specified values.

(This coercion feature is deprecated; in the future, keyword names will be taken in the package they are read in, so symbols that are actually in the KEYWORD package should be used if that is what is desired.)

Whatever object the constructor function returns is returned by the #S syntax.

For information on how the Lisp printer prints structures, see Printing Structures.

gcl-2.6.14/info/gcl/Compiler-Terminology.html0000644000175000017500000001762614360276512017455 0ustar cammcamm Compiler Terminology (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation  

3.2.1 Compiler Terminology

The following terminology is used in this section.

The compiler is a utility that translates code into an implementation-dependent form that might be represented or executed efficiently. The term compiler refers to both of the functions compile and compile-file.

The term compiled code refers to objects representing compiled programs, such as objects constructed by compile or by load when loading a compiled file.

The term implicit compilation refers to compilation performed during evaluation.

The term literal object refers to a quoted object or a self-evaluating object or an object that is a substructure of such an object. A constant variable is not itself a literal object.

The term coalesce is defined as follows. Suppose A and B are two literal constants in the source code, and that A' and B' are the corresponding objects in the compiled code. If A' and B' are eql but A and B are not eql, then it is said that A and B have been coalesced by the compiler.

The term minimal compilation refers to actions the compiler must take at compile time. These actions are specified in Compilation Semantics.

The verb process refers to performing minimal compilation, determining the time of evaluation for a form, and possibly evaluating that form (if required).

The term further compilation refers to implementation-dependent compilation beyond minimal compilation. That is, processing does not imply complete compilation. Block compilation and generation of machine-specific instructions are examples of further compilation. Further compilation is permitted to take place at run time.

Four different environments relevant to compilation are distinguished: the startup environment, the compilation environment, the evaluation environment, and the run-time environment.

The startup environment is the environment of the Lisp image from which the compiler was invoked.

The compilation environment is maintained by the compiler and is used to hold definitions and declarations to be used internally by the compiler. Only those parts of a definition needed for correct compilation are saved. The compilation environment is used as the environment argument to macro expanders called by the compiler. It is unspecified whether a definition available in the compilation environment can be used in an evaluation initiated in the startup environment or evaluation environment.

The evaluation environment is a run-time environment in which macro expanders and code specified by eval-when to be evaluated are evaluated. All evaluations initiated by the compiler take place in the evaluation environment.

The run-time environment is the environment in which the program being compiled will be executed.

The compilation environment inherits from the evaluation environment, and the compilation environment and evaluation environment might be identical. The evaluation environment inherits from the startup environment, and the startup environment and evaluation environment might be identical.

The term compile time refers to the duration of time that the compiler is processing source code. At compile time, only the compilation environment and the evaluation environment are available.

The term compile-time definition refers to a definition in the compilation environment. For example, when compiling a file, the definition of a function might be retained in the compilation environment if it is declared inline. This definition might not be available in the evaluation environment.

The term run time refers to the duration of time that the loader is loading compiled code or compiled code is being executed. At run time, only the run-time environment is available.

The term run-time definition refers to a definition in the run-time environment.

The term run-time compiler refers to the function compile or implicit compilation, for which the compilation and run-time environments are maintained in the same Lisp image. Note that when the run-time compiler is used, the run-time environment and startup environment are the same.

Next: , Previous: , Up: Compilation  

gcl-2.6.14/info/gcl/Structures.html0000644000175000017500000000410014360276512015537 0ustar cammcamm Structures (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

8 Structures

• Structures Dictionary  
gcl-2.6.14/info/gcl/upgraded_002darray_002delement_002dtype.html0000644000175000017500000001035714360276512022474 0ustar cammcamm upgraded-array-element-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.23 upgraded-array-element-type [Function]

upgraded-array-element-type typespec &optional environment ⇒ upgraded-typespec

Arguments and Values::

typespec—a type specifier.

environment—an environment object. The default is nil, denoting the null lexical environment and the current global environment.

upgraded-typespec—a type specifier.

Description::

Returns the element type of the most specialized array representation capable of holding items of the type denoted by typespec.

The typespec is a subtype of (and possibly type equivalent to) the upgraded-typespec.

If typespec is bit, the result is type equivalent to bit.

If typespec is base-char, the result is type equivalent to base-char.

If typespec is character, the result is type equivalent to character.

The purpose of upgraded-array-element-type is to reveal how an implementation does its upgrading.

The environment is used to expand any derived type specifiers that are mentioned in the typespec.

See Also::

array-element-type , make-array

Notes::

Except for storage allocation consequences and dealing correctly with the optional environment argument, upgraded-array-element-type could be defined as: 

 (defun upgraded-array-element-type (type &optional environment)
   (array-element-type (make-array 0 :element-type type)))
gcl-2.6.14/info/gcl/Error-Detection-Time-in-Safe-Calls.html0000644000175000017500000000476014360276512021605 0ustar cammcamm Error Detection Time in Safe Calls (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.2 Error Detection Time in Safe Calls

If an error is signaled in a safe call, the exact point of the signal is implementation-dependent. In particular, it might be signaled at compile time or at run time, and if signaled at run time, it might be prior to, during, or after executing the call. However, it is always prior to the execution of the body of the function being called.

gcl-2.6.14/info/gcl/program_002derror.html0000644000175000017500000000515214360276512016632 0ustar cammcamm program-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.68 program-error [Condition Type]

Class Precedence List::

program-error, error, serious-condition, condition, t

Description::

The type program-error consists of error conditions related to incorrect program syntax. The errors that result from naming a go tag or a block tag that is not lexically apparent are of type program-error.

gcl-2.6.14/info/gcl/_002adebugger_002dhook_002a.html0000644000175000017500000001237614360276512020030 0ustar cammcamm *debugger-hook* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.24 *debugger-hook* [Variable]

Value Type::

a designator for a function of two arguments (a condition and the value of *debugger-hook* at the time the debugger was entered), or nil.

Initial Value::

nil.

Description::

When the value of *debugger-hook* is non-nil, it is called prior to normal entry into the debugger, either due to a call to invoke-debugger or due to automatic entry into the debugger from a call to error or cerror with a condition that is not handled. The function may either handle the condition (transfer control) or return normally (allowing the standard debugger to run). To minimize recursive errors while debugging, *debugger-hook* is bound to nil by invoke-debugger prior to calling the function.

Examples::

 (defun one-of (choices &optional (prompt "Choice"))
   (let ((n (length choices)) (i))
     (do ((c choices (cdr c)) (i 1 (+ i 1)))
         ((null c))
       (format t "~&[~D] ~A~
     (do () ((typep i `(integer 1 ,n)))
       (format t "~&~A: " prompt)
       (setq i (read))
       (fresh-line))
     (nth (- i 1) choices)))

 (defun my-debugger (condition me-or-my-encapsulation)
   (format t "~&Fooey: ~A" condition)
   (let ((restart (one-of (compute-restarts))))
     (if (not restart) (error "My debugger got an error."))
     (let ((*debugger-hook* me-or-my-encapsulation))
       (invoke-restart-interactively restart))))

 (let ((*debugger-hook* #'my-debugger))
   (+ 3 'a))
 |>  Fooey: The argument to +, A, is not a number.
 |>   [1] Supply a replacement for A.
 |>   [2] Return to Cloe Toplevel.
 |>  Choice: 1
 |>   Form to evaluate and use: (+ 5 'b)
 |>   Fooey: The argument to +, B, is not a number.
 |>   [1] Supply a replacement for B.
 |>   [2] Supply a replacement for A.
 |>   [3] Return to Cloe Toplevel.
 |>  Choice: 1
 |>   Form to evaluate and use: 1
⇒  9

Affected By::

invoke-debugger

Notes::

When evaluating code typed in by the user interactively, it is sometimes useful to have the hook function bind *debugger-hook* to the function that was its second argument so that recursive errors can be handled using the same interactive facility.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/with_002dcondition_002drestarts.html0000644000175000017500000000765014360276512021315 0ustar cammcamm with-condition-restarts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.39 with-condition-restarts [Macro]

with-condition-restarts condition-form restarts-form {form}*
⇒ {result}*

Arguments and Values::

condition-form—a form; evaluated to produce a condition.

condition—a condition object resulting from the evaluation of condition-form.

restart-form—a form; evaluated to produce a restart-list.

restart-list—a list of restart objects resulting from the evaluation of restart-form.

forms—an implicit progn; evaluated.

results—the values returned by forms.

Description::

First, the condition-form and restarts-form are evaluated in normal left-to-right order; the primary values yielded by these evaluations are respectively called the condition and the restart-list.

Next, the forms are evaluated in a dynamic environment in which each restart in restart-list is associated with the condition. See Associating a Restart with a Condition.

See Also::

restart-case

Notes::

Usually this macro is not used explicitly in code, since restart-case handles most of the common cases in a way that is syntactically more concise.

gcl-2.6.14/info/gcl/progv.html0000644000175000017500000000770114360276512014523 0ustar cammcamm progv (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.19 progv [Special Operator]

progv symbols values {form}* ⇒ {result}*

Arguments and Values::

symbols—a list of symbols; evaluated.

values—a list of objects; evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

progv creates new dynamic variable bindings and executes each form using those bindings. Each form is evaluated in order.

progv allows binding one or more dynamic variables whose names may be determined at run time. Each form is evaluated in order with the dynamic variables whose names are in symbols bound to corresponding values. If too few values are supplied, the remaining symbols are bound and then made to have no value. If too many values are supplied, the excess values are ignored. The bindings of the dynamic variables are undone on exit from progv.

Examples::

 (setq *x* 1) ⇒  1
 (progv '(*x*) '(2) *x*) ⇒  2
 *x* ⇒  1

Assuming *x* is not globally special,

 (let ((*x* 3)) 
    (progv '(*x*) '(4) 
      (list *x* (symbol-value '*x*)))) ⇒  (3 4)

See Also::

let , Evaluation

Notes::

Among other things, progv is useful when writing interpreters for languages embedded in Lisp; it provides a handle on the mechanism for binding dynamic variables.

gcl-2.6.14/info/gcl/Boa-Lambda-Lists.html0000644000175000017500000001564614360276512016350 0ustar cammcamm Boa Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.6 Boa Lambda Lists

A boa lambda list is a lambda list that is syntactically like an ordinary lambda list, but that is processed in “by order of argument” style.

A boa lambda list is used only in a defstruct form, when explicitly specifying the lambda list of a constructor function (sometimes called a “boa constructor”).

The &optional, &rest, &aux,

&key, and &allow-other-keys

lambda list keywords are recognized in a boa lambda list. The way these lambda list keywords differ from their use in an ordinary lambda list follows.

Consider this example, which describes how destruct processes its :constructor option. 

 (:constructor create-foo
         (a &optional b (c 'sea) &rest d &aux e (f 'eff)))

This defines create-foo to be a constructor of one or more arguments. The first argument is used to initialize the a slot. The second argument is used to initialize the b slot. If there isn’t any second argument, then the default value given in the body of the defstruct (if given) is used instead. The third argument is used to initialize the c slot. If there isn’t any third argument, then the symbol sea is used instead. Any arguments following the third argument are collected into a list and used to initialize the d slot. If there are three or fewer arguments, then nil is placed in the d slot. The e slot is not initialized; its initial value is implementation-defined. Finally, the f slot is initialized to contain the symbol eff.

&key and &allow-other-keys arguments default in a manner similar to that of &optional arguments: if no default is supplied in the lambda list then the default value given in the body of the defstruct (if given) is used instead. For example: 

 (defstruct (foo (:constructor CREATE-FOO (a &optional b (c 'sea)
                                             &key (d 2)
                                             &aux e (f 'eff))))
   (a 1) (b 2) (c 3) (d 4) (e 5) (f 6))

 (create-foo 10) ⇒  #S(FOO A 10 B 2 C SEA D 2 E implemention-dependent F EFF)
 (create-foo 10 'bee 'see :d 'dee) 
⇒  #S(FOO A 10 B BEE C SEE D DEE E implemention-dependent F EFF)

If keyword arguments of the form ((key var) [default [svar]]) are specified, the slot name is matched with var (not key).

The actions taken in the b and e cases were carefully chosen to allow the user to specify all possible behaviors. The &aux variables can be used to completely override the default initializations given in the body.

If no default value is supplied for an aux variable variable, the consequences are undefined if an attempt is later made to read the corresponding slot’s value before a value is explicitly assigned. If such a slot has a :type option specified, this suppressed initialization does not imply a type mismatch situation; the declared type is only required to apply when the slot is finally assigned.

With this definition, the following can be written: 

 (create-foo 1 2)

instead of 

 (make-foo :a 1 :b 2)

and create-foo provides defaulting different from that of make-foo.

Additional arguments that do not correspond to slot names but are merely present to supply values used in subsequent initialization computations are allowed. For example, in the definition 

 (defstruct (frob (:constructor create-frob
                  (a &key (b 3 have-b) (c-token 'c) 
                          (c (list c-token (if have-b 7 2))))))
         a b c)

the c-token argument is used merely to supply a value used in the initialization of the c slot. The supplied-p parameters associated with optional parameters and keyword parameters might also be used this way.

Next: , Previous: , Up: Lambda Lists  

gcl-2.6.14/info/gcl/remove_002dduplicates.html0000644000175000017500000001547614360276512017476 0ustar cammcamm remove-duplicates (ANSI and GNU Common Lisp Document)

Previous: , Up: Sequences Dictionary  

17.3.23 remove-duplicates, delete-duplicates [Function]

remove-duplicates sequence &key from-end test test-not start end key
⇒ result-sequence

delete-duplicates sequence &key from-end test test-not start end key
⇒ result-sequence

Arguments and Values::

sequence—a proper sequence.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

key—a designator for a function of one argument, or nil.

result-sequence—a sequence.

Description::

remove-duplicates returns a modified copy of sequence from which any element that matches another element occurring in sequence has been removed.

If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list.

delete-duplicates is like remove-duplicates, but delete-duplicates may modify sequence.

The elements of sequence are compared pairwise, and if any two match, then the one occurring earlier in sequence is discarded, unless from-end is true, in which case the one later in sequence is discarded.

remove-duplicates and delete-duplicates return a sequence of the same type as sequence with enough elements removed so that no two of the remaining elements match. The order of the elements remaining in the result is the same as the order in which they appear in sequence.

remove-duplicates returns a sequence that may share with sequence or may be identical to sequence if no elements need to be removed.

delete-duplicates, when sequence is a list, is permitted to setf any part, car or cdr, of the top-level list structure in that sequence. When sequence is a vector, delete-duplicates is permitted to change the dimensions of the vector and to slide its elements into new positions without permuting them to produce the resulting vector.

Examples::

 (remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) ⇒  "aBcD"
 (remove-duplicates '(a b c b d d e)) ⇒  (A C B D E)
 (remove-duplicates '(a b c b d d e) :from-end t) ⇒  (A B C D E)
 (remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
     :test #'char-equal :key #'cadr) ⇒  ((BAR #\%) (BAZ #\A))
 (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) 
     :test #'char-equal :key #'cadr :from-end t) ⇒  ((FOO #\a) (BAR #\%))
 (setq tester (list 0 1 2 3 4 5 6))
 (delete-duplicates tester :key #'oddp :start 1 :end 6) ⇒  (0 4 5 6)

Side Effects::

delete-duplicates might destructively modify sequence.

Exceptional Situations::

Should signal an error of type type-error if sequence is not a proper sequence.

See Also::

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

These functions are useful for converting sequence into a canonical form suitable for representing a set.

Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/prog1.html0000644000175000017500000001213214360276512014410 0ustar cammcamm prog1 (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.58 prog1, prog2 [Macro]

prog 1 ⇒ first-form {form}* result-1 prog 2 ⇒ first-form second-form {form}* result-2

Arguments and Values::

first-form—a form; evaluated as described below.

second-form—a form; evaluated as described below.

forms—an implicit progn; evaluated as described below.

result-1—the primary value resulting from the evaluation of first-form.

result-2—the primary value resulting from the evaluation of second-form.

Description::

prog1 evaluates first-form and then forms, yielding as its only value the primary value yielded by first-form.

prog2 evaluates first-form, then second-form, and then forms, yielding as its only value the primary value yielded by first-form.

Examples::

 (setq temp 1) ⇒  1
 (prog1 temp (print temp) (incf temp) (print temp))
 |>  1
 |>  2
⇒  1
 (prog1 temp (setq temp nil)) ⇒  2
 temp ⇒  NIL
 (prog1 (values 1 2 3) 4) ⇒  1 
 (setq temp (list 'a 'b 'c))
 (prog1 (car temp) (setf (car temp) 'alpha)) ⇒  A
 temp ⇒  (ALPHA B C)
 (flet ((swap-symbol-values (x y)
          (setf (symbol-value x) 
                (prog1 (symbol-value y)
                       (setf (symbol-value y) (symbol-value x))))))
   (let ((*foo* 1) (*bar* 2))
     (declare (special *foo* *bar*))
     (swap-symbol-values '*foo* '*bar*)
     (values *foo* *bar*)))
⇒  2, 1
 (setq temp 1) ⇒  1
 (prog2 (incf temp) (incf temp) (incf temp)) ⇒  3
 temp ⇒  4
 (prog2 1 (values 2 3 4) 5) ⇒  2

See Also::

multiple-value-prog1 , progn

Notes::

prog1 and prog2 are typically used to evaluate one or more forms with side effects and return a value that must be computed before some or all of the side effects happen. 

 (prog1 {form}*) ≡ (values (multiple-value-prog1 {form}*))
 (prog2 form1 {form}*) ≡ (let () form1 (prog1 {form}*))

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Notes-about-the-Condition-System_0060s-Background.html0000644000175000017500000000447514360276512024464 0ustar cammcamm Notes about the Condition System`s Background (ANSI and GNU Common Lisp Document)

Previous: , Up: Condition System Concepts  

9.1.6 Notes about the Condition System‘s Background

For a background reference to the abstract concepts detailed in this section, see Exceptional Situations in Lisp. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material.

gcl-2.6.14/info/gcl/standard_002dgeneric_002dfunction.html0000644000175000017500000000513314360276512021540 0ustar cammcamm standard-generic-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.6 standard-generic-function [System Class]

Class Precedence List::

standard-generic-function, generic-function, function, t

Description::

The class standard-generic-function is the default class of generic functions established by defmethod, ensure-generic-function, defgeneric,

and defclass forms.

gcl-2.6.14/info/gcl/slot_002dvalue.html0000644000175000017500000001367614360276512016141 0ustar cammcamm slot-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.14 slot-value [Function]

slot-value object slot-name ⇒ value

Arguments and Values::

object—an object.

name—a symbol.

value—an object.

Description::

The function slot-value returns the value of the slot named slot-name in the object. If there is no slot named slot-name, slot-missing is called. If the slot is unbound, slot-unbound is called.

The macro setf can be used with slot-value to change the value of a slot.

Examples::

 (defclass foo () 
   ((a :accessor foo-a :initarg :a :initform 1)
    (b :accessor foo-b :initarg :b)
    (c :accessor foo-c :initform 3)))
⇒  #<STANDARD-CLASS FOO 244020371>
 (setq foo1 (make-instance 'foo :a 'one :b 'two))
⇒  #<FOO 36325624>
 (slot-value foo1 'a) ⇒  ONE
 (slot-value foo1 'b) ⇒  TWO
 (slot-value foo1 'c) ⇒  3
 (setf (slot-value foo1 'a) 'uno) ⇒  UNO
 (slot-value foo1 'a) ⇒  UNO
 (defmethod foo-method ((x foo))
   (slot-value x 'a))
⇒  #<STANDARD-METHOD FOO-METHOD (FOO) 42720573>
 (foo-method foo1) ⇒  UNO

Exceptional Situations::

If an attempt is made to read a slot and no slot of the name slot-name exists in the object, slot-missing is called as follows: 

 (slot-missing (class-of instance)
               instance
               slot-name
               'slot-value)

(If slot-missing is invoked, its primary value is returned by slot-value.)

If an attempt is made to write a slot and no slot of the name slot-name exists in the object, slot-missing is called as follows: 

 (slot-missing (class-of instance)
               instance
               slot-name
               'setf
               new-value)

(If slot-missing returns in this case, any values are ignored.)

The specific behavior depends on object’s metaclass. An error is never signaled if object has metaclass standard-class. An error is always signaled if object has metaclass built-in-class. The consequences are unspecified if object has any other metaclass–an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified.

See Also::

slot-missing , slot-unbound , with-slots

Notes::

Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-value using the function slot-value-using-class described in the Metaobject Protocol.

Implementations may optimize slot-value by compiling it inline.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/unbound_002dslot_002dinstance.html0000644000175000017500000000533114360276512020736 0ustar cammcamm unbound-slot-instance (ANSI and GNU Common Lisp Document)

Previous: , Up: Objects Dictionary  

7.7.41 unbound-slot-instance [Function]

unbound-slot-instance condition ⇒ instance

Arguments and Values::

condition—a condition of type unbound-slot.

instance—an object.

Description::

Returns the instance which had the unbound slot in the situation represented by the condition.

See Also::

cell-error-name , unbound-slot, Condition System Concepts

gcl-2.6.14/info/gcl/Tilde-P_002d_003e-Plural.html0000644000175000017500000000573114360276512017336 0ustar cammcamm Tilde P-> Plural (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Miscellaneous Operations  

22.3.8.3 Tilde P: Plural

If arg is not eql to the integer 1, a lowercase s is printed; if arg is eql to 1, nothing is printed. If arg is a floating-point 1.0, the s is printed.

~:P does the same thing, after doing a ~:* to back up one argument; that is, it prints a lowercase s if the previous argument was not 1.

~@P prints y if the argument is 1, or ies if it is not. ~:@P does the same thing, but backs up first. 

 (format nil "~D tr~:@P/~D win~:P" 7 1) ⇒  "7 tries/1 win"
 (format nil "~D tr~:@P/~D win~:P" 1 0) ⇒  "1 try/0 wins"
 (format nil "~D tr~:@P/~D win~:P" 1 3) ⇒  "1 try/3 wins"
gcl-2.6.14/info/gcl/open_002dstream_002dp.html0000644000175000017500000000654714360276512017204 0ustar cammcamm open-stream-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.11 open-stream-p [Function]

open-stream-p stream ⇒ generalized-boolean

Arguments and Values::

stream—a stream.

generalized-boolean—a generalized boolean.

Description::

Returns true if stream is an open stream; otherwise, returns false.

Streams are open until they have been explicitly closed with close, or until they are implicitly closed due to exit from a with-output-to-string, with-open-file, with-input-from-string, or with-open-stream form.

Examples::

 (open-stream-p *standard-input*) ⇒  true

Affected By::

close.

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream.

gcl-2.6.14/info/gcl/Extensions-to-Similarity-Rules.html0000644000175000017500000000575714360276512021372 0ustar cammcamm Extensions to Similarity Rules (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Literal Objects in Compiled Files  

3.2.4.5 Extensions to Similarity Rules

Some objects, such as streams, readtables, and methods are not externalizable objects under the definition of similarity given above. That is, such objects may not portably appear as literal objects in code to be processed by the file compiler.

An implementation is permitted to extend the rules of similarity, so that other kinds of objects are externalizable objects for that implementation.

If for some kind of object, similarity is neither defined by this specification nor by the implementation, then the file compiler must signal an error upon encountering such an object as a literal constant.

gcl-2.6.14/info/gcl/car.html0000644000175000017500000003207214360276512014132 0ustar cammcamm car (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.9 car, cdr,

caar, cadr, cdar, cddr,

caaar, caadr, cadar, caddr, cdaar, cdadr, cddar, cdddr,

caaaar, caaadr, caadar, caaddr, cadaar, cadadr, caddar, cadddr,

cdaaar, cdaadr, cdadar, cdaddr, cddaar, cddadr, cdddar, cddddr

[Accessor]

car x ⇒ object (setf (car x) new-object)

cdr x ⇒ object (setf (cdr x) new-object)

\vksip 5pt x ⇒ object (setf (\vksip 5pt x) new-object)

caar x ⇒ object (setf (caar x) new-object)

cadr x ⇒ object (setf (cadr x) new-object)

cdar x ⇒ object (setf (cdar x) new-object)

cddr x ⇒ object (setf (cddr x) new-object)

\vksip 5pt x ⇒ object (setf (\vksip 5pt x) new-object)

caaar x ⇒ object (setf (caaar x) new-object)

caadr x ⇒ object (setf (caadr x) new-object)

cadar x ⇒ object (setf (cadar x) new-object)

caddr x ⇒ object (setf (caddr x) new-object)

cdaar x ⇒ object (setf (cdaar x) new-object)

cdadr x ⇒ object (setf (cdadr x) new-object)

cddar x ⇒ object (setf (cddar x) new-object)

cdddr x ⇒ object (setf (cdddr x) new-object)

\vksip 5pt x ⇒ object (setf (\vksip 5pt x) new-object)

caaaar x ⇒ object (setf (caaaar x) new-object)

caaadr x ⇒ object (setf (caaadr x) new-object)

caadar x ⇒ object (setf (caadar x) new-object)

caaddr x ⇒ object (setf (caaddr x) new-object)

cadaar x ⇒ object (setf (cadaar x) new-object)

cadadr x ⇒ object (setf (cadadr x) new-object)

caddar x ⇒ object (setf (caddar x) new-object)

cadddr x ⇒ object (setf (cadddr x) new-object)

cdaaar x ⇒ object (setf (cdaaar x) new-object)

cdaadr x ⇒ object (setf (cdaadr x) new-object)

cdadar x ⇒ object (setf (cdadar x) new-object)

cdaddr x ⇒ object (setf (cdaddr x) new-object)

cddaar x ⇒ object (setf (cddaar x) new-object)

cddadr x ⇒ object (setf (cddadr x) new-object)

cdddar x ⇒ object (setf (cdddar x) new-object)

cddddr x ⇒ object (setf (cddddr x) new-object)

Pronunciation::

cadr: pronounced ’ka ,de r

caddr: pronounced ’kad e ,de r or pronounced ’ka ,dude r

cdr: pronounced ’ku ,de r

cddr: pronounced ’kud e ,de r or pronounced ’ke ,dude r

Arguments and Values::

x—a list.

object—an object.

new-object—an object.

Description::

If x is a cons, car returns the car of that cons. If x is nil, car returns nil.

If x is a cons, cdr returns the cdr of that cons. If x is nil, cdr returns nil.

Functions are provided which perform compositions of up to four car and cdr operations. Their names consist of a C, followed by two, three, or four occurrences of A or D, and finally an R. The series of A’s and D’s in each function’s name is chosen to identify the series of car and cdr operations that is performed by the function. The order in which the A’s and D’s appear is the inverse of the order in which the corresponding operations are performed. Figure 14–6 defines the relationships precisely. 

  This place ...  Is equivalent to this place ...  
  (caar x)        (car (car x))                    
  (cadr x)        (car (cdr x))                    
  (cdar x)        (cdr (car x))                    
  (cddr x)        (cdr (cdr x))                    
  (caaar x)       (car (car (car x)))              
  (caadr x)       (car (car (cdr x)))              
  (cadar x)       (car (cdr (car x)))              
  (caddr x)       (car (cdr (cdr x)))              
  (cdaar x)       (cdr (car (car x)))              
  (cdadr x)       (cdr (car (cdr x)))              
  (cddar x)       (cdr (cdr (car x)))              
  (cdddr x)       (cdr (cdr (cdr x)))              
  (caaaar x)      (car (car (car (car x))))        
  (caaadr x)      (car (car (car (cdr x))))        
  (caadar x)      (car (car (cdr (car x))))        
  (caaddr x)      (car (car (cdr (cdr x))))        
  (cadaar x)      (car (cdr (car (car x))))        
  (cadadr x)      (car (cdr (car (cdr x))))        
  (caddar x)      (car (cdr (cdr (car x))))        
  (cadddr x)      (car (cdr (cdr (cdr x))))        
  (cdaaar x)      (cdr (car (car (car x))))        
  (cdaadr x)      (cdr (car (car (cdr x))))        
  (cdadar x)      (cdr (car (cdr (car x))))        
  (cdaddr x)      (cdr (car (cdr (cdr x))))        
  (cddaar x)      (cdr (cdr (car (car x))))        
  (cddadr x)      (cdr (cdr (car (cdr x))))        
  (cdddar x)      (cdr (cdr (cdr (car x))))        
  (cddddr x)      (cdr (cdr (cdr (cdr x))))        

         Figure 14–6: CAR and CDR variants

setf can also be used with any of these functions to change an existing component of x, but setf will not make new components. So, for example, the car of a cons can be assigned with setf of car, but the car of nil cannot be assigned with setf of car. Similarly, the car of the car of a cons whose car is a cons can be assigned with setf of caar, but neither nil nor a cons whose car is nil can be assigned with setf of caar.

The argument x is permitted to be a dotted list or a circular list.

Examples::

 (car nil) ⇒  NIL  
 (cdr '(1 . 2)) ⇒  2
 (cdr '(1 2)) ⇒  (2)
 (cadr '(1 2)) ⇒  2 
 (car '(a b c)) ⇒  A
 (cdr '(a b c)) ⇒  (B C)

Exceptional Situations::

The functions car and cdr should signal type-error if they receive an argument which is not a list. The other functions (caar, cadr, ... cddddr) should behave for the purpose of error checking as if defined by appropriate calls to car and cdr.

See Also::

rplaca , first , rest

Notes::

The car of a cons can also be altered by using rplaca, and the cdr of a cons can be altered by using rplacd. 

(car x)    ≡ (first x)
(cadr x)   ≡ (second x) ≡ (car (cdr x))
(caddr x)  ≡ (third x)  ≡ (car (cdr (cdr x)))
(cadddr x) ≡ (fourth x) ≡ (car (cdr (cdr (cdr x))))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/handler_002dcase.html0000644000175000017500000002246214360276512016365 0ustar cammcamm handler-case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.27 handler-case [Macro]

handler-case expression [[{!error-clause}* | !no-error-clause]] ⇒ {result}*

clause ::=!error-clause | !no-error-clause

error-clause ::=(typespec ([var]) {declaration}* {form}*)

no-error-clause ::=(:no-error lambda-list {declaration}* {form}*)

Arguments and Values::

expression—a form.

typespec—a type specifier.

var—a variable name.

lambda-list—an ordinary lambda list.

declaration—a declare expression; not evaluated.

form—a form.

results—In the normal situation, the values returned are those that result from the evaluation of expression; in the exceptional situation when control is transferred to a clause, the value of the last form in that clause is returned.

Description::

handler-case executes expression in a dynamic environment where various handlers are active. Each error-clause specifies how to handle a condition matching the indicated typespec. A no-error-clause allows the specification of a particular action if control returns normally.

If a condition is signaled for which there is an appropriate error-clause during the execution of expression (i.e., one for which (typep condition 'typespec) returns true) and if there is no intervening handler for a condition of that type, then control is transferred to the body of the relevant error-clause. In this case, the dynamic state is unwound appropriately (so that the handlers established around the expression are no longer active), and var is bound to the condition that had been signaled. If more than one case is provided, those cases are made accessible in parallel. That is, in 

  (handler-case form
    (typespec1 (var1) form1)
    (typespec2 (var2) form2))

if the first clause (containing form1) has been selected, the handler for the second is no longer visible (or vice versa).

The clauses are searched sequentially from top to bottom. If there is type overlap between typespecs, the earlier of the clauses is selected.

If var is not needed, it can be omitted. That is, a clause such as: 

  (typespec (var) (declare (ignore var)) form)

can be written (typespec () form).

If there are no forms in a selected clause, the case, and therefore handler-case, returns nil. If execution of expression returns normally and no no-error-clause exists, the values returned by expression are returned by handler-case. If execution of expression returns normally and a no-error-clause does exist, the values returned are used as arguments to the function described by constructing (lambda lambda-list {form}*) from the no-error-clause, and the values of that function call are returned by handler-case. The handlers which were established around the expression are no longer active at the time of this call.

Examples::

 (defun assess-condition (condition)
   (handler-case (signal condition)
     (warning () "Lots of smoke, but no fire.")
     ((or arithmetic-error control-error cell-error stream-error)
        (condition)
       (format nil "~S looks especially bad." condition))
     (serious-condition (condition)
       (format nil "~S looks serious." condition))
     (condition () "Hardly worth mentioning.")))
⇒  ASSESS-CONDITION
 (assess-condition (make-condition 'stream-error :stream *terminal-io*))
⇒  "#<STREAM-ERROR 12352256> looks especially bad."
 (define-condition random-condition (condition) () 
   (:report (lambda (condition stream)
              (declare (ignore condition))
              (princ "Yow" stream))))
⇒  RANDOM-CONDITION
 (assess-condition (make-condition 'random-condition))
⇒  "Hardly worth mentioning."

See Also::

handler-bind , ignore-errors , Condition System Concepts

Notes::

 (handler-case form
   (type1 (var1) . body1)
   (type2 (var2) . body2) ...)

is approximately equivalent to: 

 (block #1=#:g0001
   (let ((#2=#:g0002 nil))
     (tagbody
       (handler-bind ((type1 #'(lambda (temp)
                                       (setq #1# temp)
                                       (go #3=#:g0003)))
                      (type2 #'(lambda (temp)
                                       (setq #2# temp)
                                       (go #4=#:g0004))) ...)
       (return-from #1# form))
         #3# (return-from #1# (let ((var1 #2#)) . body1))
         #4# (return-from #1# (let ((var2 #2#)) . body2)) ...)))

 (handler-case form
   (type1 (var1) . body1)
   ...
   (:no-error (varN-1 varN-2 ...) . bodyN))

is approximately equivalent to: 


 (block #1=#:error-return
  (multiple-value-call #'(lambda (varN-1 varN-2 ...) . bodyN)
     (block #2=#:normal-return
       (return-from #1#
         (handler-case (return-from #2# form)
           (type1 (var1) . body1) ...)))))

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Printing-Ratios.html0000644000175000017500000000525214360276512016416 0ustar cammcamm Printing Ratios (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.3 Printing Ratios

Ratios are printed as follows: the absolute value of the numerator is printed, as for an integer; then a /; then the denominator. The numerator and denominator are both printed in the radix specified by the current output base; they are obtained as if by numerator and denominator, and so ratios are printed in reduced form (lowest terms). If appropriate, a radix specifier can be printed; see *print-radix*. If the ratio is negative, a minus sign is printed before the numerator.

For related information about the syntax of a ratio, see Syntax of a Ratio.

gcl-2.6.14/info/gcl/Treatment-of-Other-Macros-Based-on-SETF.html0000644000175000017500000000751014360276512022417 0ustar cammcamm Treatment of Other Macros Based on SETF (ANSI and GNU Common Lisp Document)

Previous: , Up: Generalized Reference  

5.1.3 Treatment of Other Macros Based on SETF

For each of the “read-modify-write” operators in Figure 5–9, and for any additional macros defined by the programmer using define-modify-macro, an exception is made to the normal rule of left-to-right evaluation of arguments. Evaluation of argument forms occurs in left-to-right order, with the exception that for the place argument, the actual read of the “old value” from that place happens after all of the argument form evaluations, and just before a “new value” is computed and written back into the place.

Specifically, each of these operators can be viewed as involving a form with the following general syntax: 

 (operator {preceding-form}* place {following-form}*)

The evaluation of each such form proceeds like this:

1.

Evaluate each of the preceding-forms, in left-to-right order.

2.

Evaluate the subforms of the place, in the order specified by the second value of the setf expansion for that place.

3.

Evaluate each of the following-forms, in left-to-right order.

4.

Read the old value from place.

5.

Compute the new value.

6.

Store the new value into place. 

  decf  pop   pushnew  
  incf  push  remf     

  Figure 5–9: Read-Modify-Write Macros
gcl-2.6.14/info/gcl/Re_002dReading-Abbreviated-Expressions.html0000644000175000017500000000473014360276512022500 0ustar cammcamm Re-Reading Abbreviated Expressions (ANSI and GNU Common Lisp Document)

Previous: , Up: Standard Macro Characters  

2.4.9 Re-Reading Abbreviated Expressions

Note that the Lisp reader will generally signal an error of type reader-error when reading an expression_2 that has been abbreviated because of length or level limits (see *print-level*, *print-length*, and *print-lines*) due to restrictions on “..”, “...”, “#” followed by whitespace_1, and “#)”.

gcl-2.6.14/info/gcl/Examples-of-Single-Escape-Characters.html0000644000175000017500000000465314360276512022243 0ustar cammcamm Examples of Single Escape Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.8 Examples of Single Escape Characters

 ;; The following examples assume the readtable case of *readtable* 
 ;; and *print-case* are both :upcase.
 (eq 'abc '\A\B\C) ⇒  true
 (eq 'abc 'a\Bc) ⇒  true
 (eq 'abc '\ABC) ⇒  true
 (eq 'abc '\abc) ⇒  false
gcl-2.6.14/info/gcl/Tilde-Percent_002d_003e-Newline.html0000644000175000017500000000445114360276512020677 0ustar cammcamm Tilde Percent-> Newline (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Basic Output  

22.3.1.2 Tilde Percent: Newline

This outputs a #\Newline character, thereby terminating the current output line and beginning a new one. ~n% outputs n newlines. No arg is used.

gcl-2.6.14/info/gcl/Keyword-Arguments-in-Generic-Functions-and-Methods.html0000644000175000017500000001033314360276512025035 0ustar cammcamm Keyword Arguments in Generic Functions and Methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.5 Keyword Arguments in Generic Functions and Methods

When a generic function or any of its methods mentions &key in a lambda list, the specific set of keyword arguments accepted by the generic function varies according to the applicable methods. The set of keyword arguments accepted by the generic function for a particular call is the union of the keyword arguments accepted by all applicable methods and the keyword arguments mentioned after &key in the generic function definition, if any. A method that has &rest but not &key does not affect the set of acceptable keyword arguments. If the lambda list of any applicable method or of the generic function definition contains &allow-other-keys, all keyword arguments are accepted by the generic function.

The lambda list congruence rules require that each method accept all of the keyword arguments mentioned after &key in the generic function definition, by accepting them explicitly, by specifying &allow-other-keys, or by specifying &rest but not &key. Each method can accept additional keyword arguments of its own, in addition to the keyword arguments mentioned in the generic function definition.

If a generic function is passed a keyword argument that no applicable method accepts, an error should be signaled; see Error Checking in Function Calls.

• Examples of Keyword Arguments in Generic Functions and Methods  
gcl-2.6.14/info/gcl/Sharpsign-Single_002dQuote.html0000644000175000017500000000464714360276512020314 0ustar cammcamm Sharpsign Single-Quote (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.2 Sharpsign Single-Quote

Any expression preceded by #' (sharpsign followed by single-quote), as in #'expression, is treated by the Lisp reader as an abbreviation for and parsed identically to the expression (function expression). See function. For example, 

(apply #'+ l) ≡ (apply (function +) l)
gcl-2.6.14/info/gcl/Symbol-Concepts.html0000644000175000017500000000506414360276512016407 0ustar cammcamm Symbol Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols  

10.1 Symbol Concepts

Figure 10–1 lists some defined names that are applicable to the property lists of symbols. 

  get  remprop  symbol-plist  

  Figure 10–1: Property list defined names

Figure 10–2 lists some defined names that are applicable to the creation of and inquiry about symbols. 

  copy-symbol  keywordp     symbol-package  
  gensym       make-symbol  symbol-value    
  gentemp      symbol-name                  

  Figure 10–2: Symbol creation and inquiry defined names
gcl-2.6.14/info/gcl/Return-Values.html0000644000175000017500000000656614360276512016112 0ustar cammcamm Return Values (ANSI and GNU Common Lisp Document)

Previous: , Up: Evaluation  

3.1.7 Return Values

Ordinarily the result of calling a function is a single object. Sometimes, however, it is convenient for a function to compute several objects and return them.

In order to receive other than exactly one value from a form, one of several special forms or macros must be used to request those values. If a form produces multiple values which were not requested in this way, then the first value is given to the caller and all others are discarded; if the form produces zero values, then the caller receives nil as a value.

Figure 3–5 lists some operators for receiving multiple values_2. These operators can be used to specify one or more forms to evaluate and where to put the values returned by those forms. 

  multiple-value-bind  multiple-value-prog1  return-from  
  multiple-value-call  multiple-value-setq   throw        
  multiple-value-list  return                             

  Figure 3–5: Some operators applicable to receiving multiple values

The function values can produce multiple values_2. (values) returns zero values; (values form) returns the primary value returned by form; (values form1 form2) returns two values, the primary value of form1 and the primary value of form2; and so on.

See multiple-values-limit and values-list.

gcl-2.6.14/info/gcl/substitute.html0000644000175000017500000002421214360276512015575 0ustar cammcamm substitute (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.19 substitute, substitute-if, substitute-if-not,

nsubstitute, nsubstitute-if, nsubstitute-if-not

[Function]

substitute newitem olditem sequence &key from-end test test-not start end count key
⇒ result-sequence

substitute-if newitem predicate sequence &key from-end start end count key
⇒ result-sequence

substitute-if-not newitem predicate sequence &key from-end start end count key
⇒ result-sequence

nsubstitute newitem olditem sequence &key from-end test test-not start end count key
⇒ sequence

nsubstitute-if newitem predicate sequence &key from-end start end count key
⇒ sequence

nsubstitute-if-not newitem predicate sequence &key from-end start end count key
⇒ sequence

Arguments and Values::

newitem—an object.

olditem—an object.

sequence—a proper sequence.

predicate—a designator for a function of one argument that returns a generalized boolean.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

count—an integer or nil.

The default is nil.

key—a designator for a function of one argument, or nil.

result-sequence—a sequence.

Description::

substitute, substitute-if, and substitute-if-not return a copy of sequence in which each element that satisfies the test has been replaced with newitem.

nsubstitute, nsubstitute-if, and nsubstitute-if-not are like substitute, substitute-if, and substitute-if-not respectively, but they may modify sequence.

If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list.

Count, if supplied, limits the number of elements altered; if more than count elements satisfy the test, then of these elements only the leftmost or rightmost, depending on from-end, are replaced, as many as specified by count.

If count is supplied and negative, the behavior is as if zero had been supplied instead.

If count is nil, all matching items are affected.

Supplying a from-end of true matters only when the count is provided (and non-nil); in that case, only the rightmost count elements satisfying the test are removed (instead of the leftmost).

predicate, test, and test-not might be called more than once for each sequence element, and their side effects can happen in any order.

The result of all these functions is a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been replaced by newitem.

substitute, substitute-if, and substitute-if-not return a sequence which can share with sequence or may be identical to the input sequence if no elements need to be changed.

nsubstitute and nsubstitute-if are required to setf any car (if sequence is a list) or aref (if sequence is a vector) of sequence that is required to be replaced with newitem. If sequence is a list, none of the cdrs of the top-level list can be modified.

Examples::

 (substitute #\. #\SPACE "0 2 4 6") ⇒  "0.2.4.6"
 (substitute 9 4 '(1 2 4 1 3 4 5)) ⇒  (1 2 9 1 3 9 5)
 (substitute 9 4 '(1 2 4 1 3 4 5) :count 1) ⇒  (1 2 9 1 3 4 5)
 (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t)
⇒  (1 2 4 1 3 9 5)
 (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) ⇒  (9 9 4 9 3 4 5)

 (substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car)
⇒  ((1) (2) (3) 0)
 (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) ⇒  (9 2 4 9 9 4 9)
 (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t)
⇒  (1 2 4 1 3 9 5)

 (setq some-things (list 'a 'car 'b 'cdr 'c)) ⇒  (A CAR B CDR C)
 (nsubstitute-if "function was here" #'fboundp some-things
                 :count 1 :from-end t) ⇒  (A CAR B "function was here" C)
 some-things ⇒  (A CAR B "function was here" C)
 (setq alpha-tester (copy-seq "ab ")) ⇒  "ab "
 (nsubstitute-if-not #\z #'alpha-char-p alpha-tester) ⇒  "abz"
 alpha-tester ⇒  "abz"

Side Effects::

nsubstitute, nsubstitute-if, and nsubstitute-if-not modify sequence.

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

subst , nsubst,

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

The functions substitute-if-not and nsubstitute-if-not are deprecated.

nsubstitute and nsubstitute-if can be used in for-effect-only positions in code.

Because the side-effecting variants (e.g., nsubstitute) potentially change the path that is being traversed, their effects in the presence of shared or circular structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: 

 (defun test-it (fn)
   (let ((x (cons 'b nil)))
     (rplacd x x)
     (funcall fn 'a 'b x :count 1)))
 (test-it #'substitute) ⇒  (A . #1=(B . #1#))
 (test-it #'nsubstitute) ⇒  (A . #1#)

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/decode_002dfloat.html0000644000175000017500000002275014360276512016365 0ustar cammcamm decode-float (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.73 decode-float, scale-float, float-radix, float-sign,

float-digits, float-precision, integer-decode-float

[Function]

decode-float float ⇒ significand, exponent, sign

scale-float float integer ⇒ scaled-float

float-radix float ⇒ float-radix

float-sign float-1 &optional float-2 ⇒ signed-float

float-digits float ⇒ digits1

float-precision float ⇒ digits2

integer-decode-float float ⇒ significand, exponent, integer-sign

Arguments and Values::

digits1—a non-negative integer.

digits2—a non-negative integer.

exponent—an integer.

float—a float.

float-1—a float.

float-2—a float.

float-radix—an integer.

integer—a non-negative integer.

integer-sign—the integer -1, or the integer 1.

scaled-float—a float.

sign—A float of the same type as float but numerically equal to 1.0 or -1.0.

signed-float—a float.

significand—a float.

Description::

decode-float computes three values that characterize float. The first value is of the same type as float and represents the significand. The second value represents the exponent to which the radix (notated in this description by b) must be raised to obtain the value that, when multiplied with the first result, produces the absolute value of float. If float is zero, any integer value may be returned, provided that the identity shown for scale-float holds. The third value is of the same type as float and is 1.0 if float is greater than or equal to zero or -1.0 otherwise.

decode-float divides float by an integral power of b so as to bring its value between 1/b (inclusive) and~1 (exclusive), and returns the quotient as the first value. If float is zero, however, the result equals the absolute value of float (that is, if there is a negative zero, its significand is considered to be a positive zero).

scale-float returns (* float (expt (float b float) integer))\/, where b is the radix of the floating-point representation. float is not necessarily between 1/b and~1.

float-radix returns the radix of float.

float-sign returns a number z such that z and float-1 have the same sign and also such that z and float-2 have the same absolute value. If float-2 is not supplied, its value is (float 1 float-1). If an implementation has distinct representations for negative zero and positive zero, then (float-sign -0.0) ⇒ -1.0.

float-digits returns the number of radix b digits used in the representation of float (including any implicit digits, such as a “hidden bit”).

float-precision returns the number of significant radix b digits present in float; if float is a float zero, then the result is an integer zero.

For normalized floats, the results of float-digits and float-precision are the same, but the precision is less than the number of representation digits for a denormalized or zero number.

integer-decode-float computes three values that characterize float - the significand scaled so as to be an integer, and the same last two values that are returned by decode-float. If float is zero, integer-decode-float returns zero as the first value. The second value bears the same relationship to the first value as for decode-float: 

 (multiple-value-bind (signif expon sign)
                      (integer-decode-float f)
   (scale-float (float signif f) expon)) ≡ (abs f)

Examples::

 ;; Note that since the purpose of this functionality is to expose
 ;; details of the implementation, all of these examples are necessarily
 ;; very implementation-dependent.  Results may vary widely.
 ;; Values shown here are chosen consistently from one particular implementation.
 (decode-float .5) ⇒  0.5, 0, 1.0
 (decode-float 1.0) ⇒  0.5, 1, 1.0
 (scale-float 1.0 1) ⇒  2.0
 (scale-float 10.01 -2) ⇒  2.5025
 (scale-float 23.0 0) ⇒  23.0
 (float-radix 1.0) ⇒  2
 (float-sign 5.0) ⇒  1.0
 (float-sign -5.0) ⇒  -1.0
 (float-sign 0.0) ⇒  1.0
 (float-sign 1.0 0.0) ⇒  0.0
 (float-sign 1.0 -10.0) ⇒  10.0
 (float-sign -1.0 10.0) ⇒  -10.0
 (float-digits 1.0) ⇒  24
 (float-precision 1.0) ⇒  24
 (float-precision least-positive-single-float) ⇒  1
 (integer-decode-float 1.0) ⇒  8388608, -23, 1

Affected By::

The implementation’s representation for floats.

Exceptional Situations::

The functions decode-float, float-radix, float-digits, float-precision, and integer-decode-float should signal an error if their only argument is not a float.

The function scale-float should signal an error if its first argument is not a float or if its second argument is not an integer.

The function float-sign should signal an error if its first argument is not a float or if its second argument is supplied but is not a float.

Notes::

The product of the first result of decode-float or integer-decode-float, of the radix raised to the power of the second result, and of the third result is exactly equal to the value of float. 

 (multiple-value-bind (signif expon sign)
                      (decode-float f)
   (scale-float signif expon))
≡ (abs f)

and 

 (multiple-value-bind (signif expon sign)
                      (decode-float f)
   (* (scale-float signif expon) sign))
≡ f

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/The-Null-Lexical-Environment.html0000644000175000017500000000474514360276512020704 0ustar cammcamm The Null Lexical Environment (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Environments  

3.1.1.4 The Null Lexical Environment

The null lexical environment is equivalent to the global environment.

Although in general the representation of an environment object is implementation-dependent, nil can be used in any situation where an environment object is called for in order to denote the null lexical environment.

gcl-2.6.14/info/gcl/warning.html0000644000175000017500000000456714360276512015042 0ustar cammcamm warning (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.2 warning [Condition Type]

Class Precedence List::

warning, condition, t

Description::

The type warning consists of all types of warnings.

See Also::

style-warning

gcl-2.6.14/info/gcl/hash_002dtable_002drehash_002dsize.html0000644000175000017500000001023314360276512021400 0ustar cammcamm hash-table-rehash-size (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.5 hash-table-rehash-size [Function]

hash-table-rehash-size hash-table ⇒ rehash-size

Arguments and Values::

hash-table—a hash table.

rehash-size—a real of type (or (integer 1 *) (float (1.0) *)).

Description::

Returns the current rehash size of hash-table, suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table.

Examples::

 (setq table (make-hash-table :size 100 :rehash-size 1.4))
⇒  #<HASH-TABLE EQL 0/100 2556371>
 (hash-table-rehash-size table) ⇒  1.4

Exceptional Situations::

Should signal an error of type type-error if hash-table is not a hash table.

See Also::

make-hash-table , hash-table-rehash-threshold

Notes::

If the hash table was created with an integer rehash size, the result is an integer, indicating that the rate of growth of the hash-table when rehashed is intended to be additive; otherwise, the result is a float, indicating that the rate of growth of the hash-table when rehashed is intended to be multiplicative. However, this value is only advice to the implementation; the actual amount by which the hash-table will grow upon rehash is implementation-dependent.

gcl-2.6.14/info/gcl/boole_002d1.html0000644000175000017500000000663114360276512015275 0ustar cammcamm boole-1 (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.61 boole-1, boole-2, boole-and, boole-andc1, boole-andc2,

boole-c1, boole-c2, boole-clr, boole-eqv, boole-ior,

boole-nand, boole-nor, boole-orc1, boole-orc2, boole-set,

boole-xor

[Constant Variable]

Constant Value::

The identity and nature of the values of each of these variables is implementation-dependent, except that it must be distinct from each of the values of the others, and it must be a valid first argument to the function boole.

Description::

Each of these constants has a value which is one of the sixteen possible bit-wise logical operation specifiers.

Examples::

 (boole boole-ior 1 16) ⇒  17
 (boole boole-and -2 5) ⇒  4
 (boole boole-eqv 17 15) ⇒  -31

See Also::

boole

gcl-2.6.14/info/gcl/Tilde-Slash_002d_003e-Call-Function.html0000644000175000017500000001062414360276512021405 0ustar cammcamm Tilde Slash-> Call Function (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Pretty Printer Operations  

22.3.5.4 Tilde Slash: Call Function

~/name/

User defined functions can be called from within a format string by using the directive ~/name/. The colon modifier, the at-sign modifier, and arbitrarily many parameters can be specified with the ~/name/ directive. name can be any arbitrary string that does not contain a "/". All of the characters in name are treated as if they were upper case. If name contains a single colon (:) or double colon (::), then everything up to but not including the first ":" or "::" is taken to be a string that names a package. Everything after the first ":" or "::" (if any) is taken to be a string that names a symbol. The function corresponding to a ~/name/ directive is obtained by looking up the symbol that has the indicated name in the indicated package. If name does not contain a ":" or "::", then the whole name string is looked up in the COMMON-LISP-USER package.

When a ~/name/ directive is encountered, the indicated function is called with four or more arguments. The first four arguments are: the output stream, the format argument corresponding to the directive, a generalized boolean that is true if the colon modifier was used, and a generalized boolean that is true if the at-sign modifier was used. The remaining arguments consist of any parameters specified with the directive. The function should print the argument appropriately. Any values returned by the function are ignored.

The three functions pprint-linear, pprint-fill, and pprint-tabular are specifically designed so that they can be called by ~/.../ (i.e., ~/pprint-linear/, ~/pprint-fill/, and ~/pprint-tabular/). In particular they take colon and at-sign arguments.

Previous: , Up: FORMAT Pretty Printer Operations  

gcl-2.6.14/info/gcl/gcd.html0000644000175000017500000000662714360276512014131 0ustar cammcamm gcd (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.32 gcd [Function]

gcd &rest integers ⇒ greatest-common-denominator

Arguments and Values::

integer—an integer.

greatest-common-denominator—a non-negative integer.

Description::

Returns the greatest common divisor of integers. If only one integer is supplied, its absolute value is returned. If no integers are given, gcd returns 0, which is an identity for this operation.

Examples::

 (gcd) ⇒  0
 (gcd 60 42) ⇒  6
 (gcd 3333 -33 101) ⇒  1
 (gcd 3333 -33 1002001) ⇒  11
 (gcd 91 -49) ⇒  7
 (gcd 63 -42 35) ⇒  7
 (gcd 5) ⇒  5
 (gcd -4) ⇒  4

Exceptional Situations::

Should signal an error of type type-error if any integer is not an integer.

See Also::

lcm

Notes::

For three or more arguments, 

 (gcd b c ... z) ≡ (gcd (gcd a b) c ... z)
gcl-2.6.14/info/gcl/Condition-Designators.html0000644000175000017500000001025114360276512017566 0ustar cammcamm Condition Designators (ANSI and GNU Common Lisp Document)

Previous: , Up: Creating Conditions  

9.1.2.1 Condition Designators

A number of the functions in the condition system take arguments which are identified as condition designators . By convention, those arguments are notated as

datum &rest arguments

Taken together, the datum and the arguments are “designators for a condition of default type default-type.” How the denoted condition is computed depends on the type of the datum:

* If the datum is a symbol

naming a condition type ... The denoted condition is the result of 

 (apply #'make-condition datum arguments)
* If the datum is a format control ...

The denoted condition is the result of 

 (make-condition defaulted-type 
                 :format-control datum
                 :format-arguments arguments)

where the defaulted-type is a subtype of default-type.

* If the datum is a condition ...

The denoted condition is the datum itself. In this case, unless otherwise specified by the description of the operator in question, the arguments must be null; that is, the consequences are undefined if any arguments were supplied.

Note that the default-type gets used only in the case where the datum string is supplied. In the other situations, the resulting condition is not necessarily of type default-type.

Here are some illustrations of how different condition designators can denote equivalent condition objects: 

(let ((c (make-condition 'arithmetic-error :operator '/ :operands '(7 0))))
  (error c))
≡ (error 'arithmetic-error :operator '/ :operands '(7 0))

(error "Bad luck.")
≡ (error 'simple-error :format-control "Bad luck." :format-arguments '())
gcl-2.6.14/info/gcl/Definition-of-Similarity.html0000644000175000017500000002067114360276512020205 0ustar cammcamm Definition of Similarity (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Literal Objects in Compiled Files  

3.2.4.4 Definition of Similarity

Two objects S (in source code) and C (in compiled code) are defined to be similar if and only if they are both of one of the types listed here (or defined by the implementation) and they both satisfy all additional requirements of similarity indicated for that type.

number

Two numbers S and C are similar if they are of the same type and represent the same mathematical value.

character

Two simple characters S and C are similar if they have similar code attributes.

Implementations providing additional, implementation-defined attributes must define whether and how non-simple characters can be regarded as similar.

symbol

Two apparently uninterned symbols S and C are similar if their names are similar.

Two interned symbols S and C are similar if their names are similar, and if either S is accessible in the current package at compile time and C is accessible in the current package at load time, or C is accessible in the package that is similar to the home package of S.

(Note that similarity of symbols is dependent on neither the current readtable nor how the function read would parse the characters in the name of the symbol.)

package

Two packages S and C are similar if their names are similar.

Note that although a package object is an externalizable object, the programmer is responsible for ensuring that the corresponding package is already in existence when code referencing it as a literal object is loaded. The loader finds the corresponding package object as if by calling find-package with that name as an argument. An error is signaled by the loader if no package exists at load time.

random-state

Two random states S and C are similar if S would always produce the same sequence of pseudo-random numbers as a copy_5 of C when given as the random-state argument to the function random, assuming equivalent limit arguments in each case.

(Note that since C has been processed by the file compiler, it cannot be used directly as an argument to random because random would perform a side effect.)

cons

Two conses, S and C, are similar if the car_2 of S is similar to the car_2 of C, and the cdr_2 of S is similar to the cdr_2 of C.

array

Two one-dimensional arrays, S and C, are similar if the length of S is similar to the length of C, the actual array element type of S is similar to the actual array element type of C, and each active element of S is similar to the corresponding element of C.

Two arrays of rank other than one, S and C, are similar if the rank of S is similar to the rank of C, each dimension_1 of S is similar to the corresponding dimension_1 of C, the actual array element type of S is similar to the actual array element type of C, and each element of S is similar to the corresponding element of C.

In addition, if S is a simple array, then C must also be a simple array. If S is a displaced array, has a fill pointer, or is actually adjustable, C is permitted to lack any or all of these qualities.

hash-table

Two hash tables S and C are similar if they meet the following three requirements:

1.

They both have the same test (e.g., they are both eql hash tables).

2.

There is a unique one-to-one correspondence between the keys of the two hash tables, such that the corresponding keys are similar.

3.

For all keys, the values associated with two corresponding keys are similar.

If there is more than one possible one-to-one correspondence between the keys of S and C, the consequences are unspecified. A conforming program cannot use a table such as S as an externalizable constant.

pathname

Two pathnames S and C are similar if all corresponding pathname components are similar.

function

Functions are not externalizable objects.

structure-object and standard-object

A general-purpose concept of similarity does not exist for structures and standard objects. However, a conforming program is permitted to define a make-load-form method for any class K defined by that program that is a subclass of either structure-object or standard-object. The effect of such a method is to define that an object S of type K in source code is similar to an object C of type K in compiled code if C was constructed from code produced by calling make-load-form on S.

Next: , Previous: , Up: Literal Objects in Compiled Files  

gcl-2.6.14/info/gcl/code_002dchar.html0000644000175000017500000000623114360276512015660 0ustar cammcamm code-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.18 code-char [Function]

code-char code ⇒ char-p

Arguments and Values::

code—a character code.

char-p—a character or nil.

Description::

Returns a character with the code attribute given by code. If no such character exists and one cannot be created, nil is returned.

Examples::

(code-char 65.) ⇒  #\A  ;in an implementation using ASCII codes
(code-char (char-code #\Space)) ⇒  #\Space  ;in any implementation

Affected By::

The implementation’s character encoding.

See Also::

char-code

Notes::

gcl-2.6.14/info/gcl/The-_0022Class-Precedence-List_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000716314360276512026651 0ustar cammcamm The "Class Precedence List" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.5 The "Class Precedence List" Section of a Dictionary Entry

This appears in the dictionary entry for a class, and contains an ordered list of the classes defined by Common Lisp that must be in the class precedence list of this class.

It is permissible for other (implementation-defined) classes to appear in the implementation’s class precedence list for the class.

It is permissible for either standard-object or structure-object to appear in the implementation’s class precedence list; for details, see Type Relationships.

Except as explicitly indicated otherwise somewhere in this specification, no additional standardized classes may appear in the implementation’s class precedence list.

By definition of the relationship between classes and types, the classes listed in this section are also supertypes of the type denoted by the class.

gcl-2.6.14/info/gcl/file_002derror_002dpathname.html0000644000175000017500000000530314360276512020343 0ustar cammcamm file-error-pathname (ANSI and GNU Common Lisp Document)

Previous: , Up: Files Dictionary  

20.2.10 file-error-pathname [Function]

file-error-pathname condition ⇒ pathspec

Arguments and Values::

condition—a condition of type file-error.

pathspec—a pathname designator.

Description::

Returns the “offending pathname” of a condition of type file-error.

Exceptional Situations::

See Also::

file-error, Conditions

gcl-2.6.14/info/gcl/Logical-Pathname-Components.html0000644000175000017500000000510614360276512020613 0ustar cammcamm Logical Pathname Components (ANSI and GNU Common Lisp Document)

Previous: , Up: Logical Pathnames  

19.3.2 Logical Pathname Components

• Unspecific Components of a Logical Pathname  
• Null Strings as Components of a Logical Pathname  
gcl-2.6.14/info/gcl/mod-_0028System-Class_0029.html0000644000175000017500000000573714360276512017624 0ustar cammcamm mod (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.11 mod [Type Specifier]

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(mod{n})

Compound Type Specifier Arguments::

n—a positive integer.

Compound Type Specifier Description::

This denotes the set of non-negative integers less than n. This is equivalent to (integer 0 (n)) or to (integer 0 m), where m=n-1.

The argument is required, and cannot be *.

The symbol mod is not valid as a type specifier.

gcl-2.6.14/info/gcl/Objects.html0000644000175000017500000000624214360276512014756 0ustar cammcamm Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

7 Objects

• Object Creation and Initialization  
• Changing the Class of an Instance  
• Reinitializing an Instance  
• Meta-Objects  
• Slots  
• Generic Functions and Methods  
• Objects Dictionary  
gcl-2.6.14/info/gcl/Ordinary-Lambda-Lists.html0000644000175000017500000002106414360276512017425 0ustar cammcamm Ordinary Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.1 Ordinary Lambda Lists

An ordinary lambda list is used to describe how a set of arguments is received by an ordinary function. The defined names in Figure 3–12 are those which use ordinary lambda lists: 

  define-method-combination  handler-case  restart-case  
  defun                      labels                      
  flet                       lambda                      

  Figure 3–12: Standardized Operators that use Ordinary Lambda Lists

An ordinary lambda list can contain the lambda list keywords shown in Figure 3–13. 

  &allow-other-keys  &key       &rest  
  &aux               &optional         

  Figure 3–13: Lambda List Keywords used by Ordinary Lambda Lists

Each element of a lambda list is either a parameter specifier or a lambda list keyword. Implementations are free to provide additional lambda list keywords. For a list of all lambda list keywords used by the implementation, see lambda-list-keywords.

The syntax for ordinary lambda lists is as follows:

lambda-list ::=({var}*                  [&optional {var |         (var [init-form [supplied-p-parameter ]])}*]                  [&rest var]                  [&key {var |              ({var |          (keyword-name var)}    [init-form [supplied-p-parameter]])}* pt [&allow-other-keys]]                  [&aux {var | (var [init-form])}*])                

A var or supplied-p-parameter must be a symbol that is not the name of a constant variable.

An init-form can be any form. Whenever any init-form is evaluated for any parameter specifier, that form may refer to any parameter variable to the left of the specifier in which the init-form appears, including any supplied-p-parameter variables, and may rely on the fact that no other parameter variable has yet been bound (including its own parameter variable).

A keyword-name can be any symbol, but by convention is normally a keyword_1; all standardized functions follow that convention.

An ordinary lambda list has five parts, any or all of which may be empty. For information about the treatment of argument mismatches, see Error Checking in Function Calls.

• Specifiers for the required parameters  
• Specifiers for optional parameters  
• A specifier for a rest parameter  
• Specifiers for keyword parameters  
• Suppressing Keyword Argument Checking  
• Examples of Suppressing Keyword Argument Checking  
• Specifiers for &aux variables  
• Examples of Ordinary Lambda Lists  

Next: , Previous: , Up: Lambda Lists  

gcl-2.6.14/info/gcl/compile_002dfile_002dpathname.html0000644000175000017500000001140214360276512020637 0ustar cammcamm compile-file-pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.2 compile-file-pathname [Function]

compile-file-pathname input-file &key output-file &allow-other-keys ⇒ pathname

Arguments and Values::

input-file—a pathname designator. (Default fillers for unspecified components are taken from *default-pathname-defaults*.)

output-file—a pathname designator. The default is implementation-defined.

pathname—a pathname.

Description::

Returns the pathname that compile-file would write into, if given the same arguments.

The defaults for the output-file are taken from the pathname that results from merging the input-file with the value of *default-pathname-defaults*, except that the type component should default to the appropriate implementation-defined default type for compiled files.

If input-file is a logical pathname and output-file is unsupplied, the result is a logical pathname.

If input-file is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname.

If input-file is a stream, the stream can be either open or closed. compile-file-pathname returns the same pathname after a file is closed as it did when the file was open.

It is an error if input-file is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, make-string-output-stream.

If an implementation supports additional keyword arguments to compile-file, compile-file-pathname must accept the same arguments.

Examples::

See logical-pathname-translations.

Exceptional Situations::

An error of type file-error might be signaled if either input-file or output-file is wild.

See Also::

compile-file , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

gcl-2.6.14/info/gcl/symbol_002dvalue.html0000644000175000017500000001102714360276512016451 0ustar cammcamm symbol-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.14 symbol-value [Accessor]

symbol-value symbol ⇒ value

(setf ( symbol-value symbol) new-value)

Arguments and Values::

symbol—a symbol that must have a value.

value, new-value—an object.

Description::

Accesses the symbol’s value cell.

Examples::

 (setf (symbol-value 'a) 1) ⇒  1
 (symbol-value 'a) ⇒  1
 ;; SYMBOL-VALUE cannot see lexical variables.
 (let ((a 2)) (symbol-value 'a)) ⇒  1
 (let ((a 2)) (setq a 3) (symbol-value 'a)) ⇒  1
 ;; SYMBOL-VALUE can see dynamic variables.
 (let ((a 2)) 
   (declare (special a)) 
   (symbol-value 'a)) ⇒  2
 (let ((a 2)) 
   (declare (special a)) 
   (setq a 3)
   (symbol-value 'a)) ⇒  3
 (let ((a 2))
   (setf (symbol-value 'a) 3)
   a) ⇒  2
 a ⇒  3
 (symbol-value 'a) ⇒  3
 (let ((a 4))
   (declare (special a))
   (let ((b (symbol-value 'a)))
     (setf (symbol-value 'a) 5)
     (values a b))) ⇒  5, 4
 a ⇒  3
 (symbol-value :any-keyword) ⇒  :ANY-KEYWORD
 (symbol-value 'nil) ⇒  NIL
 (symbol-value '()) ⇒  NIL
 ;; The precision of this next one is implementation-dependent.
 (symbol-value 'pi) ⇒  3.141592653589793d0

Affected By::

makunbound, set, setq

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

Should signal unbound-variable if symbol is unbound and an attempt is made to read its value. (No such error is signaled on an attempt to write its value.)

See Also::

boundp , makunbound , set , setq

Notes::

symbol-value can be used to get the value of a constant variable. symbol-value cannot access the value of a lexical variable.

gcl-2.6.14/info/gcl/Traversal-Rules-and-Side-Effects.html0000644000175000017500000000662114360276512021420 0ustar cammcamm Traversal Rules and Side Effects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.6 Traversal Rules and Side Effects

The consequences are undefined when code executed during an object-traversing operation destructively modifies the object in a way that might affect the ongoing traversal operation. In particular, the following rules apply.

List traversal

For list traversal operations, the cdr chain of the list is not allowed to be destructively modified.

Array traversal

For array traversal operations, the array is not allowed to be adjusted and its fill pointer, if any, is not allowed to be changed.

Hash-table traversal

For hash table traversal operations, new elements may not be added or deleted except that the element corresponding to the current hash key may be changed or removed.

Package traversal

For package traversal operations (e.g., do-symbols), new symbols may not be interned in or uninterned from the package being traversed or any package that it uses except that the current symbol may be uninterned from the package being traversed.

gcl-2.6.14/info/gcl/length.html0000644000175000017500000000644114360276512014647 0ustar cammcamm length (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.11 length [Function]

length sequence ⇒ n

Arguments and Values::

sequence—a proper sequence.

n—a non-negative integer.

Description::

Returns the number of elements in sequence.

If sequence is a vector with a fill pointer, the active length as specified by the fill pointer is returned.

Examples::

 (length "abc") ⇒  3
 (setq str (make-array '(3) :element-type 'character 
                            :initial-contents "abc"
                            :fill-pointer t)) ⇒  "abc"
 (length str) ⇒  3
 (setf (fill-pointer str) 2) ⇒  2
 (length str) ⇒  2

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

list-length , sequence

gcl-2.6.14/info/gcl/Variable-Initialization-and-Stepping-Clauses.html0000644000175000017500000001270014360276512024017 0ustar cammcamm Variable Initialization and Stepping Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.2 Variable Initialization and Stepping Clauses

• Iteration Control  
• The for-as-arithmetic subclause  
• Examples of for-as-arithmetic subclause  
• The for-as-in-list subclause  
• Examples of for-as-in-list subclause  
• The for-as-on-list subclause  
• Examples of for-as-on-list subclause  
• The for-as-equals-then subclause  
• Examples of for-as-equals-then subclause  
• The for-as-across subclause  
• Examples of for-as-across subclause  
• The for-as-hash subclause  
• The for-as-package subclause  
• Examples of for-as-package subclause  
• Local Variable Initializations  
• Examples of WITH clause  
gcl-2.6.14/info/gcl/clear_002dinput.html0000644000175000017500000001110214360276512016247 0ustar cammcamm clear-input (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.35 clear-input [Function]

clear-input &optional input-stream ⇒ nil

Arguments and Values::

input-stream—an input stream designator. The default is standard input.

Description::

Clears any available input from input-stream.

If clear-input does not make sense for input-stream, then clear-input does nothing.

Examples::

;; The exact I/O behavior of this example might vary from implementation
;; to implementation depending on the kind of interactive buffering that
;; occurs.  (The call to SLEEP here is intended to help even out the 
;; differences in implementations which do not do line-at-a-time buffering.)

(defun read-sleepily (&optional (clear-p nil) (zzz 0))
  (list (progn (print '>) (read))
        ;; Note that input typed within the first ZZZ seconds 
        ;; will be discarded.
        (progn (print '>) 
               (if zzz (sleep zzz))
               (print '>>)
               (if clear-p (clear-input))
               (read))))

(read-sleepily)
 |>  > |>>10<<|
 |>  >
 |>  >> |>>20<<|
⇒  (10 20)

(read-sleepily t)
 |>  > |>>10<<|
 |>  >
 |>  >> |>>20<<|
⇒  (10 20)

(read-sleepily t 10)
 |>  > |>>10<<|
 |>  > |>>20<<|  ; Some implementations won't echo typeahead here.
 |>  >> |>>30<<|
⇒  (10 30)

Side Effects::

The input-stream is modified.

Affected By::

*standard-input*

Exceptional Situations::

Should signal an error of type type-error if input-stream is not a stream designator.

See Also::

clear-output

gcl-2.6.14/info/gcl/Double_002dQuote.html0000644000175000017500000000731414360276512016343 0ustar cammcamm Double-Quote (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.5 Double-Quote

Syntax: "<<text>>"

The double-quote is used to begin and end a string. When a double-quote is encountered, characters are read from the input stream and accumulated until another double-quote is encountered. If a single escape character is seen, the single escape character is discarded, the next character is accumulated, and accumulation continues. The accumulated characters up to but not including the matching double-quote are made into a simple string and returned.

It is implementation-dependent which attributes of the accumulated characters are removed in this process.

Examples of the use of the double-quote character are in Figure 2–18. 

  "Foo"                      ;A string with three characters in it  
  ""                         ;An empty string                       
  "\"APL\\360?\" he cried."  ;A string with twenty characters       
  "|x| = |-x|"               ;A ten-character string                

          Figure 2–18: Examples of the use of double-quote

Note that to place a single escape character or a double-quote into a string, such a character must be preceded by a single escape character. Note, too, that a multiple escape character need not be quoted by a single escape character within a string.

For information on how the Lisp printer prints strings, see Printing Strings.

gcl-2.6.14/info/gcl/Coercion-of-Streams-to-Pathnames.html0000644000175000017500000000605714360276512021506 0ustar cammcamm Coercion of Streams to Pathnames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: File System Concepts  

20.1.1 Coercion of Streams to Pathnames

A stream associated with a file is either a file stream or a synonym stream whose target is a stream associated with a file . Such streams can be used as pathname designators.

Normally, when a stream associated with a file is used as a pathname designator, it denotes the pathname used to open the file; this may be, but is not required to be, the actual name of the file.

Some functions, such as truename and delete-file, coerce streams to pathnames in a different way that involves referring to the actual file that is open, which might or might not be the file whose name was opened originally. Such special situations are always notated specifically and are not the default.

gcl-2.6.14/info/gcl/handler_002dbind.html0000644000175000017500000001331614360276512016364 0ustar cammcamm handler-bind (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.26 handler-bind [Macro]

handler-bind ({!binding}*) {form}* ⇒ {result}*

binding ::=(type handler)

Arguments and Values::

type—a type specifier.

handler—a form; evaluated to produce a handler-function.

handler-function—a designator for a function of one argument.

forms—an implicit progn.

results—the values returned by the forms.

Description::

Executes forms in a dynamic environment where the indicated handler bindings are in effect.

Each handler should evaluate to a handler-function, which is used to handle conditions of the given type during execution of the forms. This function should take a single argument, the condition being signaled.

If more than one handler binding is supplied, the handler bindings are searched sequentially from top to bottom in search of a match (by visual analogy with typecase). If an appropriate type is found, the associated handler is run in a dynamic environment where none of these handler bindings are visible (to avoid recursive errors). If the handler declines, the search continues for another handler.

If no appropriate handler is found, other handlers are sought from dynamically enclosing contours. If no handler is found outside, then signal returns or error enters the debugger.

Examples::

In the following code, if an unbound variable error is signaled in the body (and not handled by an intervening handler), the first function is called. 

 (handler-bind ((unbound-variable #'(lambda ...))
                (error #'(lambda ...)))
   ...)

If any other kind of error is signaled, the second function is called. In either case, neither handler is active while executing the code in the associated function. 

 (defun trap-error-handler (condition)
   (format *error-output* "~&~A~&" condition)
   (throw 'trap-errors nil))

 (defmacro trap-errors (&rest forms)
   `(catch 'trap-errors
      (handler-bind ((error #'trap-error-handler))
        ,@forms)))

 (list (trap-errors (signal "Foo.") 1)
       (trap-errors (error  "Bar.") 2)
       (+ 1 2))
 |>  Bar.
⇒  (1 NIL 3)

Note that “Foo.” is not printed because the condition made by signal is a simple condition, which is not of type error, so it doesn’t trigger the handler for error set up by trap-errors.

See Also::

handler-case

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/invoke_002drestart_002dinteractively.html0000644000175000017500000001311214360276512022334 0ustar cammcamm invoke-restart-interactively (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.35 invoke-restart-interactively [Function]

invoke-restart-interactively restart ⇒ {result}*

Arguments and Values::

restart—a restart designator.

results—the values returned by the function associated with restart, if that function returns.

Description::

invoke-restart-interactively calls the function associated with restart, prompting for any necessary arguments. If restart is a name, it must be valid in the current dynamic environment.

invoke-restart-interactively prompts for arguments by executing the code provided in the :interactive keyword to restart-case or :interactive-function keyword to restart-bind.

If no such options have been supplied in the corresponding restart-bind or restart-case, then the consequences are undefined if the restart takes required arguments. If the arguments are optional, an argument list of nil is used.

Once the arguments have been determined, invoke-restart-interactively executes the following: 

 (apply #'invoke-restart restart arguments)

Examples::

 (defun add3 (x) (check-type x number) (+ x 3))

 (add3 'seven)
 |>  Error: The value SEVEN was not of type NUMBER.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a different value to use.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>(invoke-restart-interactively 'store-value)<<|
 |>  Type a form to evaluate and use: |>>7<<|
⇒  10

Side Effects::

If prompting for arguments is necesary, some typeout may occur (on query I/O).

A non-local transfer of control might be done by the restart.

Affected By::

*query-io*, active restarts

Exceptional Situations::

If restart is not valid, an error of type control-error is signaled.

See Also::

find-restart , invoke-restart , restart-case , restart-bind

Notes::

invoke-restart-interactively is used internally by the debugger and may also be useful in implementing other portable, interactive debugging tools.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/_002aread_002dsuppress_002a.html0000644000175000017500000001576014360276512020103 0ustar cammcamm *read-suppress* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.16 *read-suppress* [Variable]

Value Type::

a generalized boolean.

Initial Value::

false.

Description::

This variable is intended primarily to support the operation of the read-time conditional notations #+ and #-. It is important for the reader macros which implement these notations to be able to skip over the printed representation of an expression despite the possibility that the syntax of the skipped expression may not be entirely valid for the current implementation, since #+ and #- exist in order to allow the same program to be shared among several Lisp implementations (including dialects other than Common Lisp) despite small incompatibilities of syntax.

If it is false, the Lisp reader operates normally.

If the value of *read-suppress* is true, read, read-preserving-whitespace, read-delimited-list, and read-from-string all return a primary value of nil when they complete successfully; however, they continue to parse the representation of an object in the normal way, in order to skip over the object, and continue to indicate end of file in the normal way. Except as noted below, any standardized reader macro_2 that is defined to read_2 a following object or token will do so, but not signal an error if the object read is not of an appropriate type or syntax. The standard syntax and its associated reader macros will not construct any new objects (e.g., when reading the representation of a symbol, no symbol will be constructed or interned).

Extended tokens

All extended tokens are completely uninterpreted. Errors such as those that might otherwise be signaled due to detection of invalid potential numbers, invalid patterns of package markers, and invalid uses of the dot character are suppressed.

Dispatching macro characters (including sharpsign)

Dispatching macro characters continue to parse an infix numerical argument, and invoke the dispatch function. The standardized sharpsign reader macros do not enforce any constraints on either the presence of or the value of the numerical argument.

#=

The #= notation is totally ignored. It does not read a following object. It produces no object, but is treated as whitespace_2.

##

The ## notation always produces nil.

No matter what the value of *read-suppress*, parentheses still continue to delimit and construct lists; the #( notation continues to delimit vectors; and comments, strings, and the single-quote and backquote notations continue to be interpreted properly. Such situations as '), #<, #), and #<Space> continue to signal errors.

Examples::

 (let ((*read-suppress* t))
   (mapcar #'read-from-string
           '("#(foo bar baz)" "#P(:type :lisp)" "#c1.2"
             "#.(PRINT 'FOO)" "#3AHELLO" "#S(INTEGER)"
             "#*ABC" "#\GARBAGE" "#RALPHA" "#3R444")))
⇒  (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)

See Also::

read , Syntax

Notes::

Programmers and implementations that define additional macro characters are strongly encouraged to make them respect *read-suppress* just as standardized macro characters do. That is, when the value of *read-suppress* is true, they should ignore type errors when reading a following object and the functions that implement dispatching macro characters should tolerate nil as their infix parameter value even if a numeric value would ordinarily be required.

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/Introduction-to-Environments.html0000644000175000017500000000726714360276512021163 0ustar cammcamm Introduction to Environments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.1 Introduction to Environments

A binding is an association between a name and that which the name denotes. Bindings are established in a lexical environment or a dynamic environment by particular special operators.

An environment is a set of bindings and other information used during evaluation (e.g., to associate meanings with names).

Bindings in an environment are partitioned into namespaces . A single name can simultaneously have more than one associated binding per environment, but can have only one associated binding per namespace.

• The Global Environment  
• Dynamic Environments  
• Lexical Environments  
• The Null Lexical Environment  
• Environment Objects  
gcl-2.6.14/info/gcl/namestring.html0000644000175000017500000001624414360276512015537 0ustar cammcamm namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.11 namestring, file-namestring, directory-namestring,

host-namestring, enough-namestring

[Function]

namestring pathname ⇒ namestring

file-namestring pathname ⇒ namestring

directory-namestring pathname ⇒ namestring

host-namestring pathname ⇒ namestring

enough-namestring pathname &optional defaults ⇒ namestring

Arguments and Values::

pathname—a pathname designator.

defaults—a pathname designator.

The default is the value of *default-pathname-defaults*.

namestring—a string or nil.

[Editorial Note by KMP: Under what circumstances can NIL be returned??]

Description::

These functions convert pathname into a namestring. The name represented by pathname is returned as a namestring in an implementation-dependent canonical form.

namestring returns the full form of pathname.

file-namestring returns just the name, type, and version components of pathname.

directory-namestring returns the directory name portion.

host-namestring returns the host name.

enough-namestring returns an abbreviated namestring that is just sufficient to identify the file named by pathname when considered relative to the defaults. It is required that 

 (merge-pathnames (enough-namestring pathname defaults) defaults)
≡ (merge-pathnames (parse-namestring pathname nil defaults) defaults)

in all cases, and the result of enough-namestring is the shortest reasonable string that will satisfy this criterion.

It is not necessarily possible to construct a valid namestring by concatenating some of the three shorter namestrings in some order.

Examples::

 (namestring "getty")            
⇒  "getty"
 (setq q (make-pathname :host "kathy" 
                         :directory 
                           (pathname-directory *default-pathname-defaults*)
                         :name "getty")) 
⇒  #S(PATHNAME :HOST "kathy" :DEVICE NIL :DIRECTORY directory-name 
       :NAME "getty" :TYPE NIL :VERSION NIL)
 (file-namestring q) ⇒  "getty"
 (directory-namestring q) ⇒  directory-name
 (host-namestring q) ⇒  "kathy" 

 ;;;Using Unix syntax and the wildcard conventions used by the
 ;;;particular version of Unix on which this example was created:
 (namestring
   (translate-pathname "/usr/dmr/hacks/frob.l"
                       "/usr/d*/hacks/*.l"
                       "/usr/d*/backup/hacks/backup-*.*"))
⇒  "/usr/dmr/backup/hacks/backup-frob.l"
 (namestring
   (translate-pathname "/usr/dmr/hacks/frob.l"
                       "/usr/d*/hacks/fr*.l"
                       "/usr/d*/backup/hacks/backup-*.*"))
⇒  "/usr/dmr/backup/hacks/backup-ob.l"

 ;;;This is similar to the above example but uses two different hosts,
 ;;;U: which is a Unix and V: which is a VMS.  Note the translation
 ;;;of file type and alphabetic case conventions.
 (namestring
   (translate-pathname "U:/usr/dmr/hacks/frob.l"
                       "U:/usr/d*/hacks/*.l"
                       "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*"))
⇒  "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-FROB.LSP"
 (namestring
   (translate-pathname "U:/usr/dmr/hacks/frob.l"
                       "U:/usr/d*/hacks/fr*.l"
                       "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*"))
⇒  "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-OB.LSP"

See Also::

truename , merge-pathnames , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/Byte-Operations-on-Integers.html0000644000175000017500000000556514360276512020610 0ustar cammcamm Byte Operations on Integers (ANSI and GNU Common Lisp Document)

Previous: , Up: Numeric Operations  

12.1.1.6 Byte Operations on Integers

The byte-manipulation functions use objects called byte specifiers to designate the size and position of a specific byte within an integer. The representation of a byte specifier is implementation-dependent; it might or might not be a number. The function byte will construct a byte specifier, which various other byte-manipulation functions will accept.

Figure 12–6 shows defined names relating to manipulating bytes of numbers. 

  byte           deposit-field  ldb-test    
  byte-position  dpb            mask-field  
  byte-size      ldb                        

  Figure 12–6: Defined names relating to byte manipulation.
gcl-2.6.14/info/gcl/in_002dpackage.html0000644000175000017500000000646514360276512016043 0ustar cammcamm in-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.16 in-package [Macro]

in-package name ⇒ package

Arguments and Values::

name—a string designator; not evaluated.

package—the package named by name.

Description::

Causes the the package named by name to become the current package—that is, the value of *package*. If no such package already exists, an error of type package-error is signaled.

Everything in-package does is also performed at compile time if the call appears as a top level form.

Side Effects::

The variable *package* is assigned. If the in-package form is a top level form, this assignment also occurs at compile time.

Exceptional Situations::

An error of type package-error is signaled if the specified package does not exist.

See Also::

package

gcl-2.6.14/info/gcl/readtable.html0000644000175000017500000000601714360276512015310 0ustar cammcamm readtable (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.1 readtable [System Class]

Class Precedence List::

readtable, t

Description::

A readtable maps characters into syntax types for the Lisp reader; see Syntax. A readtable also contains associations between macro characters and their reader macro functions, and records information about the case conversion rules to be used by the Lisp reader when parsing symbols.

Each simple character must be representable in the readtable. It is implementation-defined whether non-simple characters can have syntax descriptions in the readtable.

See Also::

Readtables, Printing Other Objects

gcl-2.6.14/info/gcl/Sharpsign-Sharpsign.html0000644000175000017500000000630514360276512017257 0ustar cammcamm Sharpsign Sharpsign (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.17 Sharpsign Sharpsign

#n#

#n#, where n is a required unsigned decimal integer, provides a reference to some object labeled by #n=; that is, #n# represents a pointer to the same (eq) object labeled by #n=. For example, a structure created in the variable y by this code: 

 (setq x (list 'p 'q))
 (setq y (list (list 'a 'b) x 'foo x))
 (rplacd (last y) (cdr y))

could be represented in this way: 

 ((a b) . #1=(#2=(p q) foo #2# . #1#))

Without this notation, but with *print-length* set to 10 and *print-circle* set to nil, the structure would print in this way: 

 ((a b) (p q) foo (p q) (p q) foo (p q) (p q) foo (p q) ...)

A reference #n# may only occur after a label #n=; forward references are not permitted. The reference may not appear as the labeled object itself (that is, #n=#n#) may not be written because the object labeled by #n= is not well defined in this case.

gcl-2.6.14/info/gcl/unbound_002dvariable.html0000644000175000017500000000517114360276512017272 0ustar cammcamm unbound-variable (ANSI and GNU Common Lisp Document)

Previous: , Up: Symbols Dictionary  

10.2.20 unbound-variable [Condition Type]

Class Precedence List::

unbound-variable, cell-error, error, serious-condition, condition, t

Description::

The type unbound-variable consists of error conditions that represent attempts to read the value of an unbound variable.

The name of the cell (see cell-error) is the name of the variable that was unbound.

See Also::

cell-error-name

gcl-2.6.14/info/gcl/write_002dstring.html0000644000175000017500000001055114360276512016471 0ustar cammcamm write-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.23 write-string, write-line [Function]

write-string string &optional output-stream &key start end ⇒ string

write-line string &optional output-stream &key start end ⇒ string

Arguments and Values::

string—a string.

output-stream – an output stream designator. The default is standard output.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

Description::

write-string writes the characters of the subsequence of string bounded by start and end to output-stream. write-line does the same thing, but then outputs a newline afterwards.

Examples::

 (prog1 (write-string "books" nil :end 4) (write-string "worms"))
 |>  bookworms
⇒  "books"
 (progn (write-char #\*)
        (write-line "test12" *standard-output* :end 5) 
        (write-line "*test2")
        (write-char #\*)
        nil)
 |>  *test1
 |>  *test2
 |>  *
⇒  NIL

Affected By::

*standard-output*, *terminal-io*.

See Also::

read-line , write-char

Notes::

write-line and write-string return string, not the substring bounded by start and end. 

 (write-string string)
≡ (dotimes (i (length string)
      (write-char (char string i)))

 (write-line string)
≡ (prog1 (write-string string) (terpri))
gcl-2.6.14/info/gcl/packagep.html0000644000175000017500000000573614360276512015147 0ustar cammcamm packagep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.27 packagep [Function]

packagep object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type package; otherwise, returns false.

Examples::

 (packagep *package*) ⇒  true 
 (packagep 'common-lisp) ⇒  false 
 (packagep (find-package 'common-lisp)) ⇒  true

Notes::

 (packagep object) ≡ (typep object 'package)
gcl-2.6.14/info/gcl/unread_002dchar.html0000644000175000017500000001155514360276512016231 0ustar cammcamm unread-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.20 unread-char [Function]

unread-char character &optional input-stream ⇒ nil

Arguments and Values::

character—a character; must be the last character that was read from input-stream.

input-stream—an input stream designator. The default is standard input.

Description::

unread-char places character back onto the front of input-stream so that it will again be the next character in input-stream.

When input-stream is an echo stream, no attempt is made to undo any echoing of the character that might already have been done on input-stream. However, characters placed on input-stream by unread-char are marked in such a way as to inhibit later re-echo by read-char.

It is an error to invoke unread-char twice consecutively on the same stream without an intervening call to read-char (or some other input operation which implicitly reads characters) on that stream.

Invoking peek-char or read-char commits all previous characters. The consequences of invoking unread-char on any character preceding that which is returned by peek-char (including those passed over by peek-char that has a non-nil peek-type) are unspecified. In particular, the consequences of invoking unread-char after peek-char are unspecified.

Examples::

 (with-input-from-string (is "0123")
    (dotimes (i 6)
      (let ((c (read-char is)))
        (if (evenp i) (format t "~&~S ~S~
 |>  0 #\0
 |>  2 #\1
 |>  4 #\2
⇒  NIL

Affected By::

*standard-input*, *terminal-io*.

See Also::

peek-char , read-char , Stream Concepts

Notes::

unread-char is intended to be an efficient mechanism for allowing the Lisp reader and other parsers to perform one-character lookahead in input-stream.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/random_002dstate.html0000644000175000017500000000577314360276512016443 0ustar cammcamm random-state (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.39 random-state [System Class]

Class Precedence List::

random-state, t

Description::

A random state object contains state information used by the pseudo-random number generator. The nature of a random state object is implementation-dependent. It can be printed out and successfully read back in by the same implementation, but might not function correctly as a random state in another implementation.

Implementations are required to provide a read syntax for objects of type random-state, but the specific nature of that syntax is implementation-dependent.

See Also::

random-state , random , Printing Random States

gcl-2.6.14/info/gcl/copy_002dsymbol.html0000644000175000017500000001265014360276512016312 0ustar cammcamm copy-symbol (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.6 copy-symbol [Function]

copy-symbol symbol &optional copy-properties ⇒ new-symbol

Arguments and Values::

symbol—a symbol.

copy-properties—a generalized boolean. The default is false.

new-symbol—a fresh, uninterned symbol.

Description::

copy-symbol returns a fresh, uninterned symbol, the name of which is string= to and possibly the same as the name of the given symbol.

If copy-properties is false, the new-symbol is neither bound nor fbound and has a null property list. If copy-properties is true, then the initial value of new-symbol is the value of symbol, the initial function definition of new-symbol is the functional value of symbol, and the property list of new-symbol is

a copy_2 of the property list of symbol.

Examples::

 (setq fred 'fred-smith) ⇒  FRED-SMITH
 (setf (symbol-value fred) 3) ⇒  3
 (setq fred-clone-1a (copy-symbol fred nil)) ⇒  #:FRED-SMITH
 (setq fred-clone-1b (copy-symbol fred nil)) ⇒  #:FRED-SMITH
 (setq fred-clone-2a (copy-symbol fred t))   ⇒  #:FRED-SMITH
 (setq fred-clone-2b (copy-symbol fred t))   ⇒  #:FRED-SMITH
 (eq fred fred-clone-1a) ⇒  false
 (eq fred-clone-1a fred-clone-1b) ⇒  false
 (eq fred-clone-2a fred-clone-2b) ⇒  false
 (eq fred-clone-1a fred-clone-2a) ⇒  false
 (symbol-value fred) ⇒  3
 (boundp fred-clone-1a) ⇒  false
 (symbol-value fred-clone-2a) ⇒  3
 (setf (symbol-value fred-clone-2a) 4) ⇒  4
 (symbol-value fred) ⇒  3
 (symbol-value fred-clone-2a) ⇒  4
 (symbol-value fred-clone-2b) ⇒  3
 (boundp fred-clone-1a) ⇒  false
 (setf (symbol-function fred) #'(lambda (x) x)) ⇒  #<FUNCTION anonymous>
 (fboundp fred) ⇒  true
 (fboundp fred-clone-1a) ⇒  false
 (fboundp fred-clone-2a) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

make-symbol

Notes::

Implementors are encouraged not to copy the string which is the symbol’s name unnecessarily. Unless there is a good reason to do so, the normal implementation strategy is for the new-symbol’s name to be identical to the given symbol’s name.

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/abs.html0000644000175000017500000000752314360276512014135 0ustar cammcamm abs (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.29 abs [Function]

abs number ⇒ absolute-value

Arguments and Values::

number—a number.

absolute-value—a non-negative real.

Description::

abs returns the absolute value of number.

If number is

a real,

the result is of the same type as number.

If number is a complex, the result is a positive

real

with the same magnitude as number. The result can be a float

[Reviewer Note by Barmar: Single-float.] even if number’s components are rationals and an exact rational result would have been possible. Thus the result of (abs #c(3 4)) can be either 5 or 5.0, depending on the implementation.

Examples::

 (abs 0) ⇒  0
 (abs 12/13) ⇒  12/13
 (abs -1.09) ⇒  1.09
 (abs #c(5.0 -5.0)) ⇒  7.071068
 (abs #c(5 5)) ⇒  7.071068
 (abs #c(3/5 4/5)) ⇒  1 or approximately 1.0
 (eql (abs -0.0) -0.0) ⇒  true

See Also::

Rule of Float Substitutability

Notes::

If number is a complex, the result is equivalent to the following:

(sqrt (+ (expt (realpart number) 2) (expt (imagpart number) 2)))

An implementation should not use this formula directly for all complexes but should handle very large or very small components specially to avoid intermediate overflow or underflow.

gcl-2.6.14/info/gcl/compute_002drestarts.html0000644000175000017500000001313714360276512017357 0ustar cammcamm compute-restarts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.32 compute-restarts [Function]

compute-restarts &optional condition ⇒ restarts

Arguments and Values::

condition—a condition object, or nil.

restarts—a list of restarts.

Description::

compute-restarts uses the dynamic state of the program to compute a list of the restarts which are currently active.

The resulting list is ordered so that the innermost (more-recently established) restarts are nearer the head of the list.

When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered.

compute-restarts returns all applicable restarts, including anonymous ones, even if some of them have the same name as others and would therefore not be found by find-restart when given a symbol argument.

Implementations are permitted, but not required, to return distinct lists from repeated calls to compute-restarts while in the same dynamic environment. The consequences are undefined if the list returned by compute-restarts is every modified.

Examples::

 ;; One possible way in which an interactive debugger might present
 ;; restarts to the user.
 (defun invoke-a-restart ()
   (let ((restarts (compute-restarts)))
     (do ((i 0 (+ i 1)) (r restarts (cdr r))) ((null r))
       (format t "~&~D: ~A~
     (let ((n nil) (k (length restarts)))
       (loop (when (and (typep n 'integer) (>= n 0) (< n k))
               (return t))
             (format t "~&Option: ")
             (setq n (read))
             (fresh-line))
       (invoke-restart-interactively (nth n restarts)))))

 (restart-case (invoke-a-restart)
   (one () 1)
   (two () 2)
   (nil () :report "Who knows?" 'anonymous)
   (one () 'I)
   (two () 'II))
 |>  0: ONE
 |>  1: TWO
 |>  2: Who knows?
 |>  3: ONE
 |>  4: TWO
 |>  5: Return to Lisp Toplevel.
 |>  Option: |>>4<<|
⇒  II

 ;; Note that in addition to user-defined restart points, COMPUTE-RESTARTS
 ;; also returns information about any system-supplied restarts, such as
 ;; the "Return to Lisp Toplevel" restart offered above.

Affected By::

Existing restarts.

See Also::

find-restart , invoke-restart , restart-bind

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Numbers-Dictionary.html0000644000175000017500000003522214360276512017103 0ustar cammcamm Numbers Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Numbers (Numbers)  

12.2 Numbers Dictionary

• number  
• complex (System Class)  
• real  
• float (System Class)  
• short-float  
• rational (System Class)  
• ratio  
• integer  
• signed-byte  
• unsigned-byte  
• mod (System Class)  
• bit (System Class)  
• fixnum  
• bignum  
• =  
• max  
• minusp  
• zerop  
• floor  
• sin  
• asin  
• pi  
• sinh  
• *  
• +  
• -  
• /  
• 1+  
• abs  
• evenp  
• exp  
• gcd  
• incf  
• lcm  
• log  
• mod (Function)  
• signum  
• sqrt  
• random-state  
• make-random-state  
• random  
• random-state-p  
• *random-state*  
• numberp  
• cis  
• complex  
• complexp  
• conjugate  
• phase  
• realpart  
• upgraded-complex-part-type  
• realp  
• numerator  
• rational (Function)  
• rationalp  
• ash  
• integer-length  
• integerp  
• parse-integer  
• boole  
• boole-1  
• logand  
• logbitp  
• logcount  
• logtest  
• byte  
• deposit-field  
• dpb  
• ldb  
• ldb-test  
• mask-field  
• most-positive-fixnum  
• decode-float  
• float  
• floatp  
• most-positive-short-float  
• short-float-epsilon  
• arithmetic-error  
• arithmetic-error-operands  
• division-by-zero  
• floating-point-invalid-operation  
• floating-point-inexact  
• floating-point-overflow  
• floating-point-underflow  

Previous: , Up: Numbers (Numbers)  

gcl-2.6.14/info/gcl/Features.html0000644000175000017500000000546614360276512015152 0ustar cammcamm Features (ANSI and GNU Common Lisp Document)

Previous: , Up: System Construction Concepts  

24.1.2 Features

A feature is an aspect or attribute of Common Lisp, of the implementation, or of the environment. A feature is identified by a symbol.

A feature is said to be present in a Lisp image if and only if the symbol naming it is an element of the list held by the variable *features*, which is called the features list .

• Feature Expressions  
• Examples of Feature Expressions  
gcl-2.6.14/info/gcl/Visible-Modifications-by-Language-Extensions.html0000644000175000017500000000536414360276512024042 0ustar cammcamm Visible Modifications by Language Extensions (ANSI and GNU Common Lisp Document)

Previous: , Up: Modifying Hash Table Keys  

18.1.2.9 Visible Modifications by Language Extensions

Implementations that extend the language by providing additional mutator functions (or additional behavior for existing mutator functions) must document how the use of these extensions interacts with equivalence tests and hash table searches.

Implementations that extend the language by defining additional acceptable equivalence tests for hash tables (allowing additional values for the :test argument to make-hash-table) must document the visible components of these tests.

gcl-2.6.14/info/gcl/Tilde-X_002d_003e-Hexadecimal.html0000644000175000017500000000455414360276512020315 0ustar cammcamm Tilde X-> Hexadecimal (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Radix Control  

22.3.2.5 Tilde X: Hexadecimal

This is just like ~D but prints in hexadecimal radix (radix 16) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalX.

~X binds *print-escape* to false, *print-radix* to false, *print-base* to 16,

and *print-readably* to false.

gcl-2.6.14/info/gcl/rassoc.html0000644000175000017500000001261214360276512014655 0ustar cammcamm rassoc (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.39 rassoc, rassoc-if, rassoc-if-not [Function]

rassoc item alist &key key test test-not ⇒ entry

rassoc-if predicate alist &key key ⇒ entry

rassoc-if-not predicate alist &key key ⇒ entry

Arguments and Values::

item—an object.

alist—an association list.

predicate—a designator for a function of one argument that returns a generalized boolean.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

entry—a cons that is an element of the alist, or nil.

Description::

rassoc, rassoc-if, and rassoc-if-not return the first cons whose cdr satisfies the test. If no such cons is found, nil is returned.

If nil appears in alist in place of a pair, it is ignored.

Examples::

 (setq alist '((1 . "one") (2 . "two") (3 . 3))) 
⇒  ((1 . "one") (2 . "two") (3 . 3))
 (rassoc 3 alist) ⇒  (3 . 3)
 (rassoc "two" alist) ⇒  NIL
 (rassoc "two" alist :test 'equal) ⇒  (2 . "two")
 (rassoc 1 alist :key #'(lambda (x) (if (numberp x) (/ x 3)))) ⇒  (3 . 3)
 (rassoc 'a '((a . b) (b . c) (c . a) (z . a))) ⇒  (C . A)
 (rassoc-if #'stringp alist) ⇒  (1 . "one")
 (rassoc-if-not #'vectorp alist) ⇒  (3 . 3)

See Also::

assoc ,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

The function rassoc-if-not is deprecated.

It is possible to rplaca the result of rassoc, provided that it is not nil, in order to “update” alist.

The expressions 

 (rassoc item list :test fn)

and 

 (find item list :test fn :key #'cdr)

are equivalent in meaning, except when the item is nil and nil appears in place of a pair in the alist. See the function assoc.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/The-Pathname-Type-Component.html0000644000175000017500000000453114360276512020516 0ustar cammcamm The Pathname Type Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathname Components  

19.2.1.5 The Pathname Type Component

Corresponds to the “filetype” or “extension” concept in many host file systems. This says what kind of file this is. This component is always a string, nil, :wild, or :unspecific.

gcl-2.6.14/info/gcl/Potential-Numbers-as-Tokens.html0000644000175000017500000001221014360276512020567 0ustar cammcamm Potential Numbers as Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers as Tokens  

2.3.1.1 Potential Numbers as Tokens

To allow implementors and future Common Lisp standards to extend the syntax of numbers, a syntax for potential numbers is defined that is more general than the syntax for numbers. A token is a potential number if it satisfies all of the following requirements:

1.

The token consists entirely of digits, signs, ratio markers, decimal points (.), extension characters (^ or _), and number markers. A number marker is a letter. Whether a letter may be treated as a number marker depends on context, but no letter that is adjacent to another letter may ever be treated as a number marker. Exponent markers are number markers.

2.

The token contains at least one digit. Letters may be considered to be digits, depending on the current input base, but only in tokens containing no decimal points.

3.

The token begins with a digit, sign, decimal point, or extension character,

[Reviewer Note by Barmar: This section is unnecessary because the first bullet already omits discussion of a colon (package marker).] but not a package marker. The syntax involving a leading package marker followed by a potential number is not well-defined. The consequences of the use of notation such as :1, :1/2, and :2^3 in a position where an expression appropriate for read is expected are unspecified.

4.

The token does not end with a sign.

If a potential number has number syntax, a number of the appropriate type is constructed and returned, if the number is representable in an implementation. A number will not be representable in an implementation if it is outside the boundaries set by the implementation-dependent constants for numbers. For example, specifying too large or too small an exponent for a float may make the number impossible to represent in the implementation. A ratio with denominator zero (such as -35/000) is not represented in any implementation. When a token with the syntax of a number cannot be converted to an internal number, an error of type reader-error is signaled. An error must not be signaled for specifying too many significant digits for a float; a truncated or rounded value should be produced.

If there is an ambiguity as to whether a letter should be treated as a digit or as a number marker, the letter is treated as a digit.

Next: , Previous: , Up: Numbers as Tokens  

gcl-2.6.14/info/gcl/list-_0028System-Class_0029.html0000644000175000017500000000756714360276512020023 0ustar cammcamm list (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.1 list [System Class]

Class Precedence List::

list, sequence, t

Description::

A list is a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom.

A proper list is a chain of conses terminated by the empty list , (), which is itself a proper list. A dotted list is a list which has a terminating atom that is not the empty list. A circular list is a chain of conses that has no termination because some cons in the chain is the cdr of a later cons.

Dotted lists and circular lists are also lists, but usually the unqualified term “list” within this specification means proper list. Nevertheless, the type list unambiguously includes dotted lists and circular lists.

For each element of a list there is a cons. The empty list has no elements and is not a cons.

The types cons and null form an exhaustive partition of the type list.

See Also::

Left-Parenthesis, Printing Lists and Conses

gcl-2.6.14/info/gcl/standard_002dchar.html0000644000175000017500000000527414360276512016554 0ustar cammcamm standard-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.3 standard-char [Type]

Supertypes::

standard-char,

base-char,

character, t

Description::

A fixed set of 96 characters required to be present in all conforming implementations. Standard characters are defined in Standard Characters.

Any character that is not simple is not a standard character.

See Also::

Standard Characters

gcl-2.6.14/info/gcl/define_002dcondition.html0000644000175000017500000004407214360276512017256 0ustar cammcamm define-condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.29 define-condition [Macro]

[Editorial Note by KMP: This syntax stuff is still very confused and needs lots of work.]

define-condition name ({parent-type}*) ({!slot-spec}*) {option}*
⇒ name

slot-spec ::=slot-name | (slot-name !slot-option)

slot-option ::=[[ {:reader symbol}* |                  {:writer !function-name}* |                  {:accessor symbol}* |                  {:allocation !allocation-type} |                  {:initarg symbol}* |                  {:initform form} |                  {:type type-specifier} ]]

option ::=[[ (:default-initargs . initarg-list) |             (:documentation string) |             (:report report-name) ]]

function-name ::={symbol | (setf symbol)}

allocation-type ::=:instance | :class

report-name ::=string | symbol | lambda expression

Arguments and Values::

name—a symbol.

parent-type—a symbol naming a condition type. If no parent-types are supplied, the parent-types default to (condition).

default-initargs—a list of keyword/value pairs.

[Editorial Note by KMP: This is all mixed up as to which is a slot option and which is a main option. I’ll sort that out. Also, some of this is implied by the bnf and needn’t be stated explicitly.]

Slot-spec – the name of a slot or a list consisting of the slot-name followed by zero or more slot-options.

Slot-name – a slot name (a symbol), the list of a slot name, or the list of slot name/slot form pairs.

Option – Any of the following:

:reader

:reader can be supplied more than once for a given slot and cannot be nil.

:writer

:writer can be supplied more than once for a given slot and must name a generic function.

:accessor

:accessor can be supplied more than once for a given slot and cannot be nil.

:allocation

:allocation can be supplied once at most for a given slot. The default if :allocation is not supplied is :instance.

:initarg

:initarg can be supplied more than once for a given slot.

:initform

:initform can be supplied once at most for a given slot.

:type

:type can be supplied once at most for a given slot.

:documentation

:documentation can be supplied once at most for a given slot.

:report

:report can be supplied once at most.

Description::

define-condition defines a new condition type called name, which is a subtype of

the type or types named by parent-type. Each parent-type argument specifies a direct supertype of the new condition. The new condition inherits slots and methods from each of its direct supertypes, and so on.

If a slot name/slot form pair is supplied, the slot form is a form that can be evaluated by make-condition to produce a default value when an explicit value is not provided. If no slot form is supplied, the contents of the slot is initialized in an implementation-dependent way.

If the type being defined and some other type from which it inherits have a slot by the same name, only one slot is allocated in the condition, but the supplied slot form overrides any slot form that might otherwise have been inherited from a parent-type. If no slot form is supplied, the inherited slot form (if any) is still visible.

Accessors are created according to the same rules as used by defclass.

A description of slot-options follows:

:reader

The :reader slot option specifies that an unqualified method is to be defined on the generic function named by the argument to :reader to read the value of the given slot.

*

The :initform slot option is used to provide a default initial value form to be used in the initialization of the slot. This form is evaluated every time it is used to initialize the slot. The lexical environment in which this form is evaluated is the lexical environment in which the define-condition form was evaluated. Note that the lexical environment refers both to variables and to functions. For local slots, the dynamic environment is the dynamic environment in which make-condition was called; for shared slots, the dynamic environment is the dynamic environment in which the define-condition form was evaluated.

[Reviewer Note by Barmar: Issue CLOS-CONDITIONS doesn’t say this.] No implementation is permitted to extend the syntax of define-condition to allow (slot-name form) as an abbreviation for (slot-name :initform form).

:initarg

The :initarg slot option declares an initialization argument named by its symbol argument and specifies that this initialization argument initializes the given slot. If the initialization argument has a value in the call to initialize-instance, the value is stored into the given slot, and the slot’s :initform slot option, if any, is not evaluated. If none of the initialization arguments specified for a given slot has a value, the slot is initialized according to the :initform slot option, if specified.

:type

The :type slot option specifies that the contents of the slot is always of the specified type. It effectively declares the result type of the reader generic function when applied to an object of this condition type. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot is undefined.

:default-initargs

[Editorial Note by KMP: This is an option, not a slot option.]

This option is treated the same as it would be defclass.

:documentation

[Editorial Note by KMP: This is both an option and a slot option.]

The :documentation slot option provides a documentation string for the slot.

:report

[Editorial Note by KMP: This is an option, not a slot option.]

Condition reporting is mediated through the print-object method for the condition type in question, with *print-escape* always being nil. Specifying (:report report-name) in the definition of a condition type C is equivalent to: 

 (defmethod print-object ((x c) stream)
   (if *print-escape* (call-next-method) (report-name x stream)))

If the value supplied by the argument to :report (report-name) is a symbol or a lambda expression, it must be acceptable to function. (function report-name) is evaluated in the current lexical environment. It should return a function of two arguments, a condition and a stream, that prints on the stream a description of the condition. This function is called whenever the condition is printed while *print-escape* is nil.

If report-name is a string, it is a shorthand for 

 (lambda (condition stream)
   (declare (ignore condition))
   (write-string report-name stream))

This option is processed after the new condition type has been defined, so use of the slot accessors within the :report function is permitted. If this option is not supplied, information about how to report this type of condition is inherited from the parent-type.

The consequences are unspecifed if an attempt is made to read a slot that has not been explicitly initialized and that has not been given a default value.

The consequences are unspecified if an attempt is made to assign the slots by using setf.

If a define-condition form appears as a top level form, the compiler must make name recognizable as a valid type name, and it must be possible to reference the condition type as the parent-type of another condition type in a subsequent define-condition form in the file being compiled.

Examples::

The following form defines a condition of type peg/hole-mismatch which inherits from a condition type called blocks-world-error: 

(define-condition peg/hole-mismatch 
                  (blocks-world-error)
                  ((peg-shape  :initarg :peg-shape
                               :reader peg/hole-mismatch-peg-shape)
                   (hole-shape :initarg :hole-shape
                               :reader peg/hole-mismatch-hole-shape))
  (:report (lambda (condition stream)
             (format stream "A ~A peg cannot go in a ~A hole."
                     (peg/hole-mismatch-peg-shape  condition)
                     (peg/hole-mismatch-hole-shape condition)))))

The new type has slots peg-shape and hole-shape, so make-condition accepts :peg-shape and :hole-shape keywords. The readers peg/hole-mismatch-peg-shape and peg/hole-mismatch-hole-shape apply to objects of this type, as illustrated in the :report information.

The following form defines a condition type named machine-error which inherits from error: 

(define-condition machine-error 
                  (error)
                  ((machine-name :initarg :machine-name
                                 :reader machine-error-machine-name))
  (:report (lambda (condition stream)
             (format stream "There is a problem with ~A."
                     (machine-error-machine-name condition)))))

Building on this definition, a new error condition can be defined which is a subtype of machine-error for use when machines are not available: 

(define-condition machine-not-available-error (machine-error) ()
  (:report (lambda (condition stream)
             (format stream "The machine ~A is not available."
                     (machine-error-machine-name condition)))))

This defines a still more specific condition, built upon machine-not-available-error, which provides a slot initialization form for machine-name but which does not provide any new slots or report information. It just gives the machine-name slot a default initialization: 

(define-condition my-favorite-machine-not-available-error
                  (machine-not-available-error)
  ((machine-name :initform "mc.lcs.mit.edu")))

Note that since no :report clause was given, the information inherited from machine-not-available-error is used to report this type of condition. 

 (define-condition ate-too-much (error) 
     ((person :initarg :person :reader ate-too-much-person)
      (weight :initarg :weight :reader ate-too-much-weight)
      (kind-of-food :initarg :kind-of-food
                    :reader :ate-too-much-kind-of-food)))
⇒  ATE-TOO-MUCH
 (define-condition ate-too-much-ice-cream (ate-too-much)
   ((kind-of-food :initform 'ice-cream)
    (flavor       :initarg :flavor
                  :reader ate-too-much-ice-cream-flavor
                  :initform 'vanilla ))
   (:report (lambda (condition stream)
              (format stream "~A ate too much ~A ice-cream"
                      (ate-too-much-person condition)
                      (ate-too-much-ice-cream-flavor condition)))))
⇒  ATE-TOO-MUCH-ICE-CREAM
 (make-condition 'ate-too-much-ice-cream
                 :person 'fred
                 :weight 300
                 :flavor 'chocolate)
⇒  #<ATE-TOO-MUCH-ICE-CREAM 32236101>
 (format t "~A" *)
 |>  FRED ate too much CHOCOLATE ice-cream
⇒  NIL

See Also::

make-condition , defclass , Condition System Concepts

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/signal.html0000644000175000017500000001210114360276512014631 0ustar cammcamm signal (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.17 signal [Function]

signal datum &rest arguments ⇒ nil

Arguments and Values::

datum, arguments—designators for a condition of default type simple-condition.

Description::

Signals the condition denoted by the given datum and arguments. If the condition is not handled, signal returns nil.

Examples::

 (defun handle-division-conditions (condition)
   (format t "Considering condition for division condition handling~
   (when (and (typep condition 'arithmetic-error)
              (eq '/ (arithmetic-error-operation condition)))
     (invoke-debugger condition)))
HANDLE-DIVISION-CONDITIONS
 (defun handle-other-arithmetic-errors (condition)
   (format t "Considering condition for arithmetic condition handling~
   (when (typep condition 'arithmetic-error)
     (abort)))
HANDLE-OTHER-ARITHMETIC-ERRORS
 (define-condition a-condition-with-no-handler (condition) ())
A-CONDITION-WITH-NO-HANDLER
 (signal 'a-condition-with-no-handler)
NIL
 (handler-bind ((condition #'handle-division-conditions)
                  (condition #'handle-other-arithmetic-errors))
   (signal 'a-condition-with-no-handler))
Considering condition for division condition handling
Considering condition for arithmetic condition handling
NIL
 (handler-bind ((arithmetic-error #'handle-division-conditions)
                  (arithmetic-error #'handle-other-arithmetic-errors))
   (signal 'arithmetic-error :operation '* :operands '(1.2 b)))
Considering condition for division condition handling
Considering condition for arithmetic condition handling
Back to Lisp Toplevel

Side Effects::

The debugger might be entered due to *break-on-signals*.

Handlers for the condition being signaled might transfer control.

Affected By::

Existing handler bindings.

*break-on-signals*

See Also::

*break-on-signals*, error , simple-condition, Signaling and Handling Conditions

Notes::

If (typep datum *break-on-signals*) yields true, the debugger is entered prior to beginning the signaling process. The continue restart can be used to continue with the signaling process. This is also true for all other functions and macros that should, might, or must signal conditions.

gcl-2.6.14/info/gcl/Type-Specifiers.html0000644000175000017500000003267514360276512016411 0ustar cammcamm Type Specifiers (ANSI and GNU Common Lisp Document)

Previous: , Up: Types  

4.2.3 Type Specifiers

Type specifiers can be symbols, classes, or lists. Figure~4–2 lists symbols that are standardized atomic type specifiers, and Figure~4–3 lists standardized compound type specifier names. For syntax information, see the dictionary entry for the corresponding type specifier. It is possible to define new type specifiers using defclass, define-condition, defstruct, or deftype. 

 arithmetic-error                 function           simple-condition          
 array                            generic-function   simple-error              
 atom                             hash-table         simple-string             
 base-char                        integer            simple-type-error         
 base-string                      keyword            simple-vector             
 bignum                           list               simple-warning            
 bit                              logical-pathname   single-float              
 bit-vector                       long-float         standard-char             
 broadcast-stream                 method             standard-class            
 built-in-class                   method-combination standard-generic-function 
 cell-error                       nil                standard-method           
 character                        null               standard-object           
 class                            number             storage-condition         
 compiled-function                package            stream                    
 complex                          package-error      stream-error              
 concatenated-stream              parse-error        string                    
 condition                        pathname           string-stream             
 cons                             print-not-readable structure-class           
 control-error                    program-error      structure-object          
 division-by-zero                 random-state       style-warning             
 double-float                     ratio              symbol                    
 echo-stream                      rational           synonym-stream            
 end-of-file                      reader-error       t                         
 error                            readtable          two-way-stream            
 extended-char                    real               type-error                
 file-error                       restart            unbound-slot              
 file-stream                      sequence           unbound-variable          
 fixnum                           serious-condition  undefined-function        
 float                            short-float        unsigned-byte             
 floating-point-inexact           signed-byte        vector                    
 floating-point-invalid-operation simple-array       warning                   
 floating-point-overflow          simple-base-string                           
 floating-point-underflow         simple-bit-vector                            

                 Figure 4–2: Standardized Atomic Type Specifiers

\indent If a type specifier is a list, the car of the list is a symbol, and the rest of the list is subsidiary type information. Such a type specifier is called a compound type specifier . Except as explicitly stated otherwise, the subsidiary items can be unspecified. The unspecified subsidiary items are indicated by writing *. For example, to completely specify a vector, the type of the elements and the length of the vector must be present. 

 (vector double-float 100)

The following leaves the length unspecified: 

 (vector double-float *)

The following leaves the element type unspecified: 

 (vector * 100)

Suppose that two type specifiers are the same except that the first has a * where the second has a more explicit specification. Then the second denotes a subtype of the type denoted by the first.

If a list has one or more unspecified items at the end, those items can be dropped. If dropping all occurrences of * results in a singleton list, then the parentheses can be dropped as well (the list can be replaced by the symbol in its car). For example, (vector double-float *) can be abbreviated to (vector double-float), and (vector * *) can be abbreviated to (vector) and then to vector. 

  and           long-float    simple-base-string  
  array         member        simple-bit-vector   
  base-string   mod           simple-string       
  bit-vector    not           simple-vector       
  complex       or            single-float        
  cons          rational      string              
  double-float  real          unsigned-byte       
  eql           satisfies     values              
  float         short-float   vector              
  function      signed-byte                       
  integer       simple-array                      

  Figure 4–3: Standardized Compound Type Specifier Names

Figure 4–4 show the defined names that can be used as compound type specifier names but that cannot be used as atomic type specifiers. 

  and     mod  satisfies  
  eql     not  values     
  member  or              

  Figure 4–4: Standardized Compound-Only Type Specifier Names

New type specifiers can come into existence in two ways.

*

Defining a structure by using defstruct without using the :type specifier or defining a class by using defclass or define-condition automatically causes the name of the structure or class to be a new type specifier symbol.

*

deftype can be used to define derived type specifiers , which act as ‘abbreviations’ for other type specifiers.

A class object can be used as a type specifier. When used this way, it denotes the set of all members of that class.

Figure 4–5 shows some defined names relating to types and declarations. 

  coerce            defstruct  subtypep  
  declaim           deftype    the       
  declare           ftype      type      
  defclass          locally    type-of   
  define-condition  proclaim   typep     

  Figure 4–5: Defined names relating to types and declarations.

Figure 4–6 shows all defined names that are type specifier names, whether for atomic type specifiers or compound type specifiers; this list is the union of the lists in Figure~4–2 and Figure~4–3. 

 and                              function           simple-array              
 arithmetic-error                 generic-function   simple-base-string        
 array                            hash-table         simple-bit-vector         
 atom                             integer            simple-condition          
 base-char                        keyword            simple-error              
 base-string                      list               simple-string             
 bignum                           logical-pathname   simple-type-error         
 bit                              long-float         simple-vector             
 bit-vector                       member             simple-warning            
 broadcast-stream                 method             single-float              
 built-in-class                   method-combination standard-char             
 cell-error                       mod                standard-class            
 character                        nil                standard-generic-function 
 class                            not                standard-method           
 compiled-function                null               standard-object           
 complex                          number             storage-condition         
 concatenated-stream              or                 stream                    
 condition                        package            stream-error              
 cons                             package-error      string                    
 control-error                    parse-error        string-stream             
 division-by-zero                 pathname           structure-class           
 double-float                     print-not-readable structure-object          
 echo-stream                      program-error      style-warning             
 end-of-file                      random-state       symbol                    
 eql                              ratio              synonym-stream            
 error                            rational           t                         
 extended-char                    reader-error       two-way-stream            
 file-error                       readtable          type-error                
 file-stream                      real               unbound-slot              
 fixnum                           restart            unbound-variable          
 float                            satisfies          undefined-function        
 floating-point-inexact           sequence           unsigned-byte             
 floating-point-invalid-operation serious-condition  values                    
 floating-point-overflow          short-float        vector                    
 floating-point-underflow         signed-byte        warning                   

                  Figure 4–6: Standardized Type Specifier Names

Previous: , Up: Types  

gcl-2.6.14/info/gcl/Visible-Modification-of-Conses-with-respect-to-EQUAL.html0000644000175000017500000000524614360276512025123 0ustar cammcamm Visible Modification of Conses with respect to EQUAL (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.3 Visible Modification of Conses with respect to EQUAL

Any visible change to the car or the cdr of a cons is considered a visible modification with regard to equal.

gcl-2.6.14/info/gcl/Array-Dimensions.html0000644000175000017500000000510014360276512016541 0ustar cammcamm Array Dimensions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.2 Array Dimensions

An axis of an array is called a dimension .

Each dimension is a non-negative

fixnum;

if any dimension of an array is zero, the array has no elements. It is permissible for a dimension to be zero, in which case the array has no elements, and any attempt to access an element is an error. However, other properties of the array, such as the dimensions themselves, may be used.

gcl-2.6.14/info/gcl/write_002dto_002dstring.html0000644000175000017500000001210014360276512017551 0ustar cammcamm write-to-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.15 write-to-string, prin1-to-string, princ-to-string [Function]

write-to-string object &key \writekeys
⇒ string

prin 1 ⇒ -to-string object string

princ-to-string object ⇒ string

Arguments and Values::

object—an object.

\writekeydescriptions

string—a string.

Description::

write-to-string, prin1-to-string, and princ-to-string are used to create a string consisting of the printed representation of object. Object is effectively printed as if by write, prin1, or princ, respectively, and the characters that would be output are made into a string.

write-to-string is the general output function. It has the ability to specify all the parameters applicable to the printing of object.

prin1-to-string acts like write-to-string with :escape t, that is, escape characters are written where appropriate.

princ-to-string acts like write-to-string with

:escape nil :readably nil.

Thus no escape characters are written.

All other keywords that would be specified to write-to-string are default values when prin1-to-string or princ-to-string is invoked.

The meanings and defaults for the keyword arguments to write-to-string are the same as those for write.

Examples::

 (prin1-to-string "abc") ⇒  "\"abc\""
 (princ-to-string "abc") ⇒  "abc"

Affected By::

*print-escape*, *print-radix*, *print-base*, *print-circle*, *print-pretty*, *print-level*, *print-length*, *print-case*, *print-gensym*, *print-array*, *read-default-float-format*.

See Also::

write

Notes::

 (write-to-string object {key argument}*)
≡ (with-output-to-string (#1=#:string-stream) 
     (write object :stream #1# {key argument}*))

 (princ-to-string object)
≡ (with-output-to-string (string-stream)
     (princ object string-stream))

 (prin1-to-string object)
≡ (with-output-to-string (string-stream)
     (prin1 object string-stream))
gcl-2.6.14/info/gcl/class_002dof.html0000644000175000017500000000643614360276512015551 0ustar cammcamm class-of (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.39 class-of [Function]

class-of object ⇒ class

Arguments and Values::

object—an object.

class—a class object.

Description::

Returns the class of which the object is a direct instance.

Examples::

 (class-of 'fred) ⇒  #<BUILT-IN-CLASS SYMBOL 610327300>
 (class-of 2/3) ⇒  #<BUILT-IN-CLASS RATIO 610326642>

 (defclass book () ()) ⇒  #<STANDARD-CLASS BOOK 33424745>
 (class-of (make-instance 'book)) ⇒  #<STANDARD-CLASS BOOK 33424745>

 (defclass novel (book) ()) ⇒  #<STANDARD-CLASS NOVEL 33424764>
 (class-of (make-instance 'novel)) ⇒  #<STANDARD-CLASS NOVEL 33424764>

 (defstruct kons kar kdr) ⇒  KONS
 (class-of (make-kons :kar 3 :kdr 4)) ⇒  #<STRUCTURE-CLASS KONS 250020317>

See Also::

make-instance , type-of

gcl-2.6.14/info/gcl/method_002dcombination_002derror.html0000644000175000017500000000703214360276512021412 0ustar cammcamm method-combination-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.16 method-combination-error [Function]

method-combination-error format-control &rest args ⇒ implementation-dependent

Arguments and Values::

format-control—a format control.

args—format arguments for format-control.

Description::

The function method-combination-error is used to signal an error in method combination.

The error message is constructed by using a format-control suitable for format and any args to it. Because an implementation may need to add additional contextual information to the error message, method-combination-error should be called only within the dynamic extent of a method combination function.

Whether method-combination-error returns to its caller or exits via throw is implementation-dependent.

Side Effects::

The debugger might be entered.

Affected By::

*break-on-signals*

See Also::

define-method-combination

gcl-2.6.14/info/gcl/Too-Few-Arguments.html0000644000175000017500000000472114360276512016610 0ustar cammcamm Too Few Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.3 Too Few Arguments

It is not permitted to supply too few arguments to a function. Too few arguments means fewer arguments than the number of required parameters for the function.

If this situation occurs in a safe call,

an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/Standard-Macro-Characters.html0000644000175000017500000000776214360276512020251 0ustar cammcamm Standard Macro Characters (ANSI and GNU Common Lisp Document)

Previous: , Up: Syntax  

2.4 Standard Macro Characters

If the reader encounters a macro character, then its associated reader macro function is invoked and may produce an object to be returned. This function may read the characters following the macro character in the stream in any syntax and return the object represented by that syntax.

Any character can be made to be a macro character. The macro characters defined initially in a conforming implementation include the following:

• Left-Parenthesis  
• Right-Parenthesis  
• Single-Quote  
• Semicolon  
• Double-Quote  
• Backquote  
• Comma  
• Sharpsign  
• Re-Reading Abbreviated Expressions  
gcl-2.6.14/info/gcl/Sharpsign-Plus.html0000644000175000017500000000611614360276512016244 0ustar cammcamm Sharpsign Plus (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.18 Sharpsign Plus

#+ provides a read-time conditionalization facility; the syntax is #+test expression. If the feature expression test succeeds, then this textual notation represents an object whose printed representation is expression. If the feature expression test fails, then this textual notation is treated as whitespace_2; that is, it is as if the “#+ test expression” did not appear and only a space appeared in its place.

For a detailed description of success and failure in feature expressions, see Feature Expressions.

#+ operates by first reading the feature expression and then skipping over the form if the feature expression fails.

While reading the test, the current package is the KEYWORD package.

Skipping over the form is accomplished by binding *read-suppress* to true and then calling read.

For examples, see Examples of Feature Expressions.

gcl-2.6.14/info/gcl/invoke_002drestart.html0000644000175000017500000001117714360276512017015 0ustar cammcamm invoke-restart (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.34 invoke-restart [Function]

invoke-restart restart &rest arguments ⇒ {result}*

Arguments and Values::

restart—a restart designator.

argument—an object.

results—the values returned by the function associated with restart, if that function returns.

Description::

Calls the function associated with restart, passing arguments to it. Restart must be valid in the current dynamic environment.

Examples::

 (defun add3 (x) (check-type x number) (+ x 3))

 (foo 'seven)
 |>  Error: The value SEVEN was not of type NUMBER.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Specify a different value to use.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>(invoke-restart 'store-value 7)<<|
⇒  10

Side Effects::

A non-local transfer of control might be done by the restart.

Affected By::

Existing restarts.

Exceptional Situations::

If restart is not valid, an error of type control-error is signaled.

See Also::

find-restart , restart-bind , restart-case , invoke-restart-interactively

Notes::

The most common use for invoke-restart is in a handler. It might be used explicitly, or implicitly through invoke-restart-interactively or a restart function.

Restart functions call invoke-restart, not vice versa. That is, invoke-restart provides primitive functionality, and restart functions are non-essential “syntactic sugar.”

gcl-2.6.14/info/gcl/Tilde-A_002d_003e-Aesthetic.html0000644000175000017500000000667214360276512017776 0ustar cammcamm Tilde A-> Aesthetic (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Printer Operations  

22.3.4.1 Tilde A: Aesthetic

An arg, any object, is printed without escape characters (as by princ). If arg is a string, its characters will be output verbatim. If arg is nil it will be printed as nil; the colon modifier (~:A) will cause an arg of nil to be printed as (), but if arg is a composite structure, such as a list or vector, any contained occurrences of nil will still be printed as nil.

~mincolA inserts spaces on the right, if necessary, to make the width at least mincol columns. The @ modifier causes the spaces to be inserted on the left rather than the right.

~mincol,colinc,minpad,padcharA is the full form of ~A, which allows control of the padding. The string is padded on the right (or on the left if the @ modifier is used) with at least minpad copies of padchar; padding characters are then inserted colinc characters at a time until the total width is at least mincol. The defaults are 0 for mincol and minpad, 1 for colinc, and the space character for padchar.

~A binds *print-escape* to false,

and *print-readably* to false.

gcl-2.6.14/info/gcl/Single-Escape-Character.html0000644000175000017500000000504114360276512017672 0ustar cammcamm Single Escape Character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.7 Single Escape Character

A single escape is used to indicate that the next character is to be treated as an alphabetic_2 character with its case preserved, no matter what the character is or which constituent traits it has.

Slash is a single escape character in standard syntax.

gcl-2.6.14/info/gcl/upgraded_002dcomplex_002dpart_002dtype.html0000644000175000017500000000645014360276512022341 0ustar cammcamm upgraded-complex-part-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.51 upgraded-complex-part-type [Function]

upgraded-complex-part-type typespec &optional environment ⇒ upgraded-typespec

Arguments and Values::

typespec—a type specifier.

environment—an environment object. The default is nil, denoting the null lexical environment and the and current global environment.

upgraded-typespec—a type specifier.

Description::

upgraded-complex-part-type returns the part type of the most specialized complex number representation that can hold parts of type typespec.

The typespec is a subtype of (and possibly type equivalent to) the upgraded-typespec.

The purpose of upgraded-complex-part-type is to reveal how an implementation does its upgrading.

See Also::

complex (function and type)

Notes::

gcl-2.6.14/info/gcl/Summary-of-Unconditional-Execution-Clauses.html0000644000175000017500000000561514360276512023571 0ustar cammcamm Summary of Unconditional Execution Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.11 Summary of Unconditional Execution Clauses

The do (or doing) construct evaluates all forms in its clause.

The return construct takes one

form. Any values returned by the form are immediately returned by the loop form. It is equivalent to the clause do (return-from block-name value), where block-name is the name specified in a named clause, or nil if there is no named clause.

For more information, see Unconditional Execution Clauses.

gcl-2.6.14/info/gcl/with_002daccessors.html0000644000175000017500000001534714360276512017001 0ustar cammcamm with-accessors (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.23 with-accessors [Macro]

with-accessors ({slot-entry}*) instance-form {declaration}* {form}*
⇒ {result}*

slot-entry ::=(variable-name accessor-name )

Arguments and Values::

variable-name—a variable name; not evaluated.

accessor-name—a function name; not evaluated.

instance-form—a form; evaluated.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

Creates a lexical environment in which the slots specified by slot-entry are lexically available through their accessors as if they were variables. The macro with-accessors invokes the appropriate accessors to access the slots specified by slot-entry. Both setf and setq can be used to set the value of the slot.

Examples::

 (defclass thing ()
           ((x :initarg :x :accessor thing-x)
            (y :initarg :y :accessor thing-y)))
⇒  #<STANDARD-CLASS THING 250020173>
 (defmethod (setf thing-x) :before (new-x (thing thing))
   (format t "~&Changing X from ~D to ~D in ~S.~
           (thing-x thing) new-x thing))
 (setq thing1 (make-instance 'thing :x 1 :y 2)) ⇒  #<THING 43135676>
 (setq thing2 (make-instance 'thing :x 7 :y 8)) ⇒  #<THING 43147374>
 (with-accessors ((x1 thing-x) (y1 thing-y))
                 thing1
   (with-accessors ((x2 thing-x) (y2 thing-y))
                   thing2
     (list (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2))
           (setq x1 (+ y1 x2))
           (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2))
           (setf (thing-x thing2) (list x1))
           (list x1 (thing-x thing1) y1 (thing-y thing1)
                 x2 (thing-x thing2) y2 (thing-y thing2)))))
 |>  Changing X from 1 to 9 in #<THING 43135676>.
 |>  Changing X from 7 to (9) in #<THING 43147374>.
⇒  ((1 1 2 2 7 7 8 8)
     9
     (9 9 2 2 7 7 8 8) 
     (9)
     (9 9 2 2 (9) (9) 8 8))

Affected By::

defclass

Exceptional Situations::

The consequences are undefined if any accessor-name is not the name of an accessor for the instance.

See Also::

with-slots , symbol-macrolet

Notes::

A with-accessors expression of the form: 


(with-accessors (slot-entry_1 ...slot-entry_n) instance-form form_1 ...form_k)

expands into the equivalent of 


(let ((in instance-form))

 (symbol-macrolet (Q_1... Q_n) form_1 ...form_k))

where Q_i is 

(variable-name_i () 
(accessor-name_i in))

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/typep.html0000644000175000017500000001620614360276512014527 0ustar cammcamm typep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.28 typep [Function]

typep object type-specifier &optional environment ⇒ generalized-boolean

Arguments and Values::

object—an object.

type-specifier—any type specifier except

values, or a type specifier list whose first element is either function or values.

environment—an environment object. The default is nil, denoting the null lexical environment and the and current global environment.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of the type specified by type-specifier; otherwise, returns false.

A type-specifier of the form (satisfies fn) is handled by applying the function fn to object.

(typep object '(array type-specifier)), where type-specifier is not *, returns true if and only if object is an array that could be the result of supplying type-specifier as the :element-type argument to make-array. (array *) refers to all arrays regardless of element type, while (array type-specifier) refers only to those arrays that can result from giving type-specifier as the :element-type argument to make-array. A similar interpretation applies to (simple-array type-specifier) and (vector type-specifier). See Array Upgrading.

(typep object '(complex type-specifier)) returns true for all complex numbers that can result from giving numbers of type type-specifier to the function complex, plus all other complex numbers of the same specialized representation. Both the real and the imaginary parts of any such complex number must satisfy: 

 (typep realpart 'type-specifier)
 (typep imagpart 'type-specifier)

See the function upgraded-complex-part-type.

Examples::

 (typep 12 'integer) ⇒  true
 (typep (1+ most-positive-fixnum) 'fixnum) ⇒  false
 (typep nil t) ⇒  true
 (typep nil nil) ⇒  false
 (typep 1 '(mod 2)) ⇒  true
 (typep #c(1 1) '(complex (eql 1))) ⇒  true
;; To understand this next example, you might need to refer to
;; Rule of Canonical Representation for Complex Rationals.
 (typep #c(0 0) '(complex (eql 0))) ⇒  false

Let A_x and A_y be two type specifiers that denote different types, but for which 

 (upgraded-array-element-type 'A_x)

and 

 (upgraded-array-element-type 'A_y)

denote the same type. Notice that 

 (typep (make-array 0 :element-type 'A_x) '(array A_x)) ⇒  true
 (typep (make-array 0 :element-type 'A_y) '(array A_y)) ⇒  true
 (typep (make-array 0 :element-type 'A_x) '(array A_y)) ⇒  true
 (typep (make-array 0 :element-type 'A_y) '(array A_x)) ⇒  true

Exceptional Situations::

An error of type error is signaled if type-specifier is values, or a type specifier list whose first element is either function or values.

The consequences are undefined if the type-specifier is not a type specifier.

See Also::

type-of , upgraded-array-element-type , upgraded-complex-part-type , Type Specifiers

Notes::

Implementations are encouraged to recognize and optimize the case of (typep x (the class y)), since it does not involve any need for expansion of deftype information at runtime.

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/stream.html0000644000175000017500000000537714360276512014670 0ustar cammcamm stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.1 stream [System Class]

Class Precedence List::

stream, t

Description::

A stream is an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation.

For more complete information, see Stream Concepts.

See Also::

Stream Concepts, Printing Other Objects, Printer, Reader

gcl-2.6.14/info/gcl/vector_002dpush.html0000644000175000017500000001357214360276512016320 0ustar cammcamm vector-push (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.31 vector-push, vector-push-extend [Function]

vector-push new-element vector ⇒ new-index-p

vector-push-extend new-element vector &optional extension ⇒ new-index

Arguments and Values::

new-element—an object.

vector—a vector with a fill pointer.

extension—a positive integer. The default is implementation-dependent.

new-index-p—a valid array index for vector, or nil.

new-index—a valid array index for vector.

Description::

vector-push and vector-push-extend store new-element in vector. vector-push attempts to store new-element in the element of vector designated by the fill pointer, and to increase the fill pointer by one. If the (>= (fill-pointer vector) (array-dimension vector 0)), neither vector nor its fill pointer are affected. Otherwise, the store and increment take place and vector-push returns the former value of the fill pointer which is one less than the one it leaves in vector.

vector-push-extend is just like vector-push except that if the fill pointer gets too large, vector is extended using adjust-array so that it can contain more elements. Extension is the minimum number of elements to be added to vector if it must be extended.

vector-push and vector-push-extend return the index of new-element in vector. If (>= (fill-pointer vector) (array-dimension vector 0)), vector-push returns nil.

Examples::

 (vector-push (setq fable (list 'fable))
              (setq fa (make-array 8 
                                   :fill-pointer 2
                                   :initial-element 'first-one))) ⇒  2 
 (fill-pointer fa) ⇒  3 
 (eq (aref fa 2) fable) ⇒  true
 (vector-push-extend #\X
                    (setq aa 
                          (make-array 5
                                      :element-type 'character
                                      :adjustable t
                                      :fill-pointer 3))) ⇒  3 
 (fill-pointer aa) ⇒  4 
 (vector-push-extend #\Y aa 4) ⇒  4 
 (array-total-size aa) ⇒  at least 5 
 (vector-push-extend #\Z aa 4) ⇒  5 
 (array-total-size aa) ⇒  9 ;(or more)

Affected By::

The value of the fill pointer.

How vector was created.

Exceptional Situations::

An error of type error is signaled by vector-push-extend if it tries to extend vector and vector is not actually adjustable.

An error of type error is signaled if vector does not have a fill pointer.

See Also::

adjustable-array-p , fill-pointer , vector-pop

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/The-EOF_002dERROR_002dP-argument.html0000644000175000017500000000743414360276512020544 0ustar cammcamm The EOF-ERROR-P argument (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Conventions of Some Reader Functions  

23.1.3.1 The EOF-ERROR-P argument

Eof-error-p in input function calls controls what happens if input is from a file (or any other input source that has a definite end) and the end of the file is reached. If eof-error-p is true (the default), an error of type end-of-file is signaled at end of file. If it is false, then no error is signaled, and instead the function returns eof-value.

Functions such as read that read the representation of an object rather than a single character always signals an error, regardless of eof-error-p, if the file ends in the middle of an object representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, read signals an error. If a file ends in a symbol or a number immediately followed by end-of-file, read reads the symbol or number successfully and when called again will act according to eof-error-p. Similarly, the function read-line successfully reads the last line of a file even if that line is terminated by end-of-file rather than the newline character. Ignorable text, such as lines containing only whitespace_2 or comments, are not considered to begin an object; if read begins to read an expression but sees only such ignorable text, it does not consider the file to end in the middle of an object. Thus an eof-error-p argument controls what happens when the file ends between objects.

gcl-2.6.14/info/gcl/Syntax-of-a-Ratio.html0000644000175000017500000000670214360276512016550 0ustar cammcamm Syntax of a Ratio (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Constructing Numbers from Tokens  

2.3.2.3 Syntax of a Ratio

Ratios can be written as an optional sign followed by two non-empty sequences of digits separated by a slash; see Figure~2–9. The second sequence may not consist entirely of zeros. Examples of ratios are in Figure 2–13. 

  2/3                 ;This is in canonical form                  
  4/6                 ;A non-canonical form for 2/3               
  -17/23              ;A ratio preceded by a sign                 
  -30517578125/32768  ;This is (-5/2)^15                        
  10/5                ;The canonical form for this is 2           
  #o-101/75           ;Octal notation for -65/61                  
  #3r120/21           ;Ternary notation for 15/7                  
  #Xbc/ad             ;Hexadecimal notation for 188/173           
  #xFADED/FACADE      ;Hexadecimal notation for 1027565/16435934  

                  Figure 2–13: Examples of Ratios

[Reviewer Note by Barmar: #o, #3r, #X, and #x mentioned above are not in the syntax rules defined just above that.]

For information on how ratios are printed, see Printing Ratios.

gcl-2.6.14/info/gcl/Specifiers-for-keyword-parameters.html0000644000175000017500000001576114360276512022076 0ustar cammcamm Specifiers for keyword parameters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.4 Specifiers for keyword parameters

If &key is present, all specifiers up to the next lambda list keyword or the end of the list are keyword parameter specifiers. When keyword parameters are processed, the same arguments are processed that would be made into a list for a rest parameter. It is permitted to specify both &rest and &key. In this case the remaining arguments are used for both purposes; that is, all remaining arguments are made into a list for the rest parameter, and are also processed for the &key parameters.

If &key is specified, there must remain an even number of arguments; see Odd Number of Keyword Arguments.

These arguments are considered as pairs, the first argument in each pair being interpreted as a name and the second as the corresponding value. The first object of each pair must be a symbol; see Invalid Keyword Arguments. The keyword parameter specifiers may optionally be followed by the lambda list keyword &allow-other-keys.

In each keyword parameter specifier must be a name var for the parameter variable.

If the var appears alone or in a (var init-form) combination, the keyword name used when matching arguments to parameters is a symbol in the KEYWORD package whose name is the same (under string=) as var’s. If the notation ((keyword-name var) init-form) is used, then the keyword name used to match arguments to parameters is keyword-name, which may be a symbol in any package. (Of course, if it is not a symbol in the KEYWORD package, it does not necessarily self-evaluate, so care must be taken when calling the function to make sure that normal evaluation still yields the keyword name.)

Thus 

 (defun foo (&key radix (type 'integer)) ...)

means exactly the same as 

 (defun foo (&key ((:radix radix)) ((:type type) 'integer)) ...)

The keyword parameter specifiers are, like all parameter specifiers, effectively processed from left to right. For each keyword parameter specifier, if there is an argument pair whose name matches that specifier’s name (that is, the names are eq), then the parameter variable for that specifier is bound to the second item (the value) of that argument pair. If more than one such argument pair matches, the leftmost argument pair is used. If no such argument pair exists, then the init-form for that specifier is evaluated and the parameter variable is bound to that value (or to nil if no init-form was specified). supplied-p-parameter is treated as for &optional parameters: it is bound to true if there was a matching argument pair, and to false otherwise.

Unless keyword argument checking is suppressed, an argument pair must a name matched by a parameter specifier; see Unrecognized Keyword Arguments.

If keyword argument checking is suppressed, then it is permitted for an argument pair to match no parameter specifier, and the argument pair is ignored, but such an argument pair is accessible through the rest parameter if one was supplied. The purpose of these mechanisms is to allow sharing of argument lists among several lambda expressions and to allow either the caller or the called lambda expression to specify that such sharing may be taking place.

Note that if &key is present, a keyword argument of :allow-other-keys is always permitted—regardless of whether the associated value is true or false. However, if the value is false, other non-matching keywords are not tolerated (unless &allow-other-keys was used).

Furthermore, if the receiving argument list specifies a regular argument which would be flagged by :allow-other-keys, then :allow-other-keys has both its special-cased meaning (identifying whether additional keywords are permitted) and its normal meaning (data flow into the function in question).

Next: , Previous: , Up: Ordinary Lambda Lists  

gcl-2.6.14/info/gcl/The-for_002das_002din_002dlist-subclause.html0000644000175000017500000000576714360276512022436 0ustar cammcamm The for-as-in-list subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.4 The for-as-in-list subclause

In the for-as-in-list subclause, the for or as construct iterates over the contents of a list. It checks for the end of the list as if by using endp. The variable var is bound to the successive elements of the list in form1 before each iteration. At the end of each iteration, the function step-fun is applied to the list; the default value for step-fun is cdr. The loop keywords in and by serve as valid prepositions in this syntax. The for or as construct causes termination when the end of the list is reached.

gcl-2.6.14/info/gcl/most_002dpositive_002dfixnum.html0000644000175000017500000000531614360276512020634 0ustar cammcamm most-positive-fixnum (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.72 most-positive-fixnum, most-negative-fixnum [Constant Variable]

Constant Value::

implementation-dependent.

Description::

most-positive-fixnum is that fixnum closest in value to positive infinity provided by the implementation,

and greater than or equal to both 2^15 - 1 and array-dimension-limit.

most-negative-fixnum is that fixnum closest in value to negative infinity provided by the implementation,

and less than or equal to -2^15.

gcl-2.6.14/info/gcl/minusp.html0000644000175000017500000000630014360276512014673 0ustar cammcamm minusp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.17 minusp, plusp [Function]

minusp real ⇒ generalized-boolean

plusp real ⇒ generalized-boolean

Arguments and Values::

real—a real.

generalized-boolean—a generalized boolean.

Description::

minusp returns true if real is less than zero; otherwise, returns false.

plusp returns true if real is greater than zero; otherwise, returns false.

Regardless of whether an implementation provides distinct representations for positive and negative float zeros, (minusp -0.0) always returns false.

Examples::

 (minusp -1) ⇒  true
 (plusp 0) ⇒  false
 (plusp least-positive-single-float) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if real is not a real.

gcl-2.6.14/info/gcl/return.html0000644000175000017500000000671714360276512014713 0ustar cammcamm return (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.26 return [Macro]

return [result] ⇒ #<NoValue>

Arguments and Values::

result—a form; evaluated. The default is nil.

Description::

Returns, as if by return-from, from the block named nil.

Examples::

 (block nil (return) 1) ⇒  NIL
 (block nil (return 1) 2) ⇒  1
 (block nil (return (values 1 2)) 3) ⇒  1, 2
 (block nil (block alpha (return 1) 2)) ⇒  1
 (block alpha (block nil (return 1)) 2) ⇒  2
 (block nil (block nil (return 1) 2)) ⇒  1

See Also::

block , return-from , Evaluation

Notes::

 (return) ≡ (return-from nil)
 (return form) ≡ (return-from nil form)

The implicit blocks established by macros such as do are often named nil, so that return can be used to exit from such forms.

gcl-2.6.14/info/gcl/rotatef.html0000644000175000017500000001060114360276512015023 0ustar cammcamm rotatef (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.66 rotatef [Macro]

rotatef {place}* ⇒ nil

Arguments and Values::

place—a place.

Description::

rotatef modifies the values of each place by rotating values from one place into another.

If a place produces more values than there are store variables, the extra values are ignored. If a place produces fewer values than there are store variables, the missing values are set to nil.

In the form (rotatef place1 place2 ... placen), the values in place1 through placen are read and written. Values 2 through n and value 1 are then stored into place1 through placen. It is as if all the places form an end-around shift register that is rotated one place to the left, with the value of place1 being shifted around the end to placen.

For information about the evaluation of subforms of places, see Evaluation of Subforms to Places.

Examples::

 (let ((n 0)
        (x (list 'a 'b 'c 'd 'e 'f 'g)))
    (rotatef (nth (incf n) x)
             (nth (incf n) x)
             (nth (incf n) x))
    x) ⇒  (A C D B E F G)

See Also::

define-setf-expander , defsetf , setf , shiftf , *macroexpand-hook*, Generalized Reference

Notes::

The effect of (rotatef place1 place2 ... placen) is roughly equivalent to 

 (psetf place1 place2
        place2 place3
        ...
        placen place1)

except that the latter would evaluate any subforms of each place twice, whereas rotatef evaluates them once.

gcl-2.6.14/info/gcl/_002aload_002dpathname_002a.html0000644000175000017500000000742514360276512020017 0ustar cammcamm *load-pathname* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.7 *load-pathname*, *load-truename* [Variable]

Value Type::

The value of *load-pathname* must always be a pathname or nil. The value of *load-truename* must always be a physical pathname or nil.

Initial Value::

nil.

Description::

During a call to load, *load-pathname* is bound to the pathname denoted by the the first argument to load, merged against the defaults; that is, it is bound to (pathname (merge-pathnames filespec)). During the same time interval, *load-truename* is bound to the truename of the file being loaded.

At other times, the value of these variables is nil.

If a break loop is entered while load is ongoing, it is implementation-dependent whether these variables retain the values they had just prior to entering the break loop or whether they are bound to nil.

The consequences are unspecified if an attempt is made to assign or bind either of these variables.

Affected By::

The file system.

See Also::

load

gcl-2.6.14/info/gcl/Deprecated-Functions.html0000644000175000017500000000527714360276512017402 0ustar cammcamm Deprecated Functions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Deprecated Language Features  

1.8.1 Deprecated Functions

The functions in Figure 1–2 are deprecated. 

  assoc-if-not   nsubst-if-not       require            
  count-if-not   nsubstitute-if-not  set                
  delete-if-not  position-if-not     subst-if-not       
  find-if-not    provide             substitute-if-not  
  gentemp        rassoc-if-not                          
  member-if-not  remove-if-not                          

            Figure 1–2: Deprecated Functions
gcl-2.6.14/info/gcl/1_002b.html0000644000175000017500000000670114360276512014250 0ustar cammcamm 1+ (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.28 1+, 1- [Function]

1 + ⇒ number successor 1 - ⇒ number predecessor

Arguments and Values::

number—a number.

successor, predecessor—a number.

Description::

1+ returns a number that is one more than its argument number. 1- returns a number that is one less than its argument number.

Examples::

 (1+ 99) ⇒  100 
 (1- 100) ⇒  99 
 (1+ (complex 0.0)) ⇒  #C(1.0 0.0) 
 (1- 5/3) ⇒  2/3

Exceptional Situations::

Might signal type-error if its argument is not a number. Might signal arithmetic-error.

See Also::

incf , decf

Notes::

 (1+ number) ≡ (+ number 1)
 (1- number) ≡ (- number 1)

Implementors are encouraged to make the performance of both the previous expressions be the same.

gcl-2.6.14/info/gcl/parse_002dinteger.html0000644000175000017500000001202414360276512016575 0ustar cammcamm parse-integer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.59 parse-integer [Function]

parse-integer string &key start end radix junk-allowed ⇒ integer, pos

Arguments and Values::

string—a string.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

radix—a radix. The default is 10.

junk-allowed—a generalized boolean. The default is false.

integer—an integer or false.

pos—a bounding index of string.

Description::

parse-integer parses an integer in the specified radix from the substring of string delimited by start and end.

parse-integer expects an optional sign (+ or -) followed by a a non-empty sequence of digits to be interpreted in the specified radix. Optional leading and trailing whitespace_1 is ignored.

parse-integer does not recognize the syntactic radix-specifier prefixes #O, #B, #X, and #nR, nor does it recognize a trailing decimal point.

If junk-allowed is false, an error of type parse-error is signaled if substring does not consist entirely of the representation of a signed integer, possibly surrounded on either side by whitespace_1 characters.

The first value returned is either the integer that was parsed, or else nil if no syntactically correct integer was seen but junk-allowed was true.

The second value is either the index into the string of the delimiter that terminated the parse, or the upper bounding index of the substring if the parse terminated at the end of the substring (as is always the case if junk-allowed is false).

Examples::

 (parse-integer "123") ⇒  123, 3
 (parse-integer "123" :start 1 :radix 5) ⇒  13, 3
 (parse-integer "no-integer" :junk-allowed t) ⇒  NIL, 0

Exceptional Situations::

If junk-allowed is false, an error is signaled if substring does not consist entirely of the representation of an integer, possibly surrounded on either side by whitespace_1 characters.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Package-Concepts.html0000644000175000017500000000445714360276512016502 0ustar cammcamm Package Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages  

11.1 Package Concepts

• Introduction to Packages  
• Standardized Packages  
gcl-2.6.14/info/gcl/sublis.html0000644000175000017500000001607214360276512014670 0ustar cammcamm sublis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.11 sublis, nsublis [Function]

sublis alist tree &key key test test-not ⇒ new-tree

nsublis alist tree &key key test test-not ⇒ new-tree

Arguments and Values::

alist—an association list.

tree—a tree.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

new-tree—a tree.

Description::

sublis makes substitutions for objects in tree (a structure of conses). nsublis is like sublis but destructively modifies the relevant parts of the tree.

sublis looks at all subtrees and leaves of tree; if a subtree or leaf appears as a key in alist (that is, the key and the subtree or leaf satisfy the test), it is replaced by the object with which that key is associated. This operation is non-destructive. In effect, sublis can perform several subst operations simultaneously.

If sublis succeeds, a new copy of tree is returned in which each occurrence of such a subtree or leaf is replaced by the object with which it is associated. If no changes are made, the original tree is returned. The original tree is left unchanged, but the result tree may share cells with it.

nsublis is permitted to modify tree but otherwise returns the same values as sublis.

Examples::

 (sublis '((x . 100) (z . zprime))
         '(plus x (minus g z x p) 4 . x))
⇒  (PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100)
 (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y)))
         '(* (/ (+ x y) (+ x p)) (- x y))
         :test #'equal)
⇒  (* (/ (- X Y) (+ X P)) (+ X Y))
 (setq tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4)))))
⇒  (1 (1 2) ((1 2 3)) (((1 2 3 4))))
 (sublis '((3 . "three")) tree1) 
⇒  (1 (1 2) ((1 2 "three")) (((1 2 "three" 4))))
 (sublis '((t . "string"))
          (sublis '((1 . "") (4 . 44)) tree1)
          :key #'stringp)
⇒  ("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44))))
 tree1 ⇒  (1 (1 2) ((1 2 3)) (((1 2 3 4))))
 (setq tree2 '("one" ("one" "two") (("one" "Two" "three"))))
⇒  ("one" ("one" "two") (("one" "Two" "three"))) 
 (sublis '(("two" . 2)) tree2) 
⇒  ("one" ("one" "two") (("one" "Two" "three"))) 
 tree2 ⇒  ("one" ("one" "two") (("one" "Two" "three"))) 
 (sublis '(("two" . 2)) tree2 :test 'equal) 
⇒  ("one" ("one" 2) (("one" "Two" "three"))) 

 (nsublis '((t . 'temp))
           tree1
           :key #'(lambda (x) (or (atom x) (< (list-length x) 3))))
⇒  ((QUOTE TEMP) (QUOTE TEMP) QUOTE TEMP)

Side Effects::

nsublis modifies tree.

See Also::

subst ,

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Because the side-effecting variants (e.g., nsublis) potentially change the path that is being traversed, their effects in the presence of shared or circular structure structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: 

 (defun test-it (fn)
   (let* ((shared-piece (list 'a 'b))
          (data (list shared-piece shared-piece)))
     (funcall fn '((a . b) (b . a)) data)))
 (test-it #'sublis) ⇒  ((B A) (B A))
 (test-it #'nsublis) ⇒  ((A B) (A B))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Standard-Characters.html0000644000175000017500000002377114360276512017210 0ustar cammcamm Standard Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax  

2.1.3 Standard Characters

All implementations must support a character repertoire called standard-char; characters that are members of that repertoire are called standard characters .

The standard-char repertoire consists of the non-graphic character newline, the graphic character space, and the following additional ninety-four graphic characters or their equivalents: 

  Graphic ID  Glyph  Description  Graphic ID  Glyph  Description  
  LA01        a      small a      LN01        n      small n      
  LA02        A      capital A    LN02        N      capital N    
  LB01        b      small b      LO01        o      small o      
  LB02        B      capital B    LO02        O      capital O    
  LC01        c      small c      LP01        p      small p      
  LC02        C      capital C    LP02        P      capital P    
  LD01        d      small d      LQ01        q      small q      
  LD02        D      capital D    LQ02        Q      capital Q    
  LE01        e      small e      LR01        r      small r      
  LE02        E      capital E    LR02        R      capital R    
  LF01        f      small f      LS01        s      small s      
  LF02        F      capital F    LS02        S      capital S    
  LG01        g      small g      LT01        t      small t      
  LG02        G      capital G    LT02        T      capital T    
  LH01        h      small h      LU01        u      small u      
  LH02        H      capital H    LU02        U      capital U    
  LI01        i      small i      LV01        v      small v      
  LI02        I      capital I    LV02        V      capital V    
  LJ01        j      small j      LW01        w      small w      
  LJ02        J      capital J    LW02        W      capital W    
  LK01        k      small k      LX01        x      small x      
  LK02        K      capital K    LX02        X      capital X    
  LL01        l      small l      LY01        y      small y      
  LL02        L      capital L    LY02        Y      capital Y    
  LM01        m      small m      LZ01        z      small z      
  LM02        M      capital M    LZ02        Z      capital Z    

  Figure 2–3: Standard Character Subrepertoire (Part 1 of 3: Latin Characters)


  Graphic ID  Glyph  Description  Graphic ID  Glyph  Description  
  ND01        1      digit 1      ND06        6      digit 6      
  ND02        2      digit 2      ND07        7      digit 7      
  ND03        3      digit 3      ND08        8      digit 8      
  ND04        4      digit 4      ND09        9      digit 9      
  ND05        5      digit 5      ND10        0      digit 0      

  Figure 2–4: Standard Character Subrepertoire (Part 2 of 3: Numeric Characters)


  Graphic ID  Glyph  Description                              
  SP02        !      exclamation mark                         
  SC03        $     dollar sign                              
  SP04        "      quotation mark, or double quote          
  SP05        '      apostrophe, or [single] quote            
  SP06        (      left parenthesis, or open parenthesis    
  SP07        )      right parenthesis, or close parenthesis  
  SP08        ,      comma                                    
  SP09        _      low line, or underscore                  
  SP10        -      hyphen, or minus [sign]                  
  SP11        .      full stop, period, or dot                
  SP12        /      solidus, or slash                        
  SP13        :      colon                                    
  SP14        ;      semicolon                                
  SP15        ?      question mark                            
  SA01        +      plus [sign]                              
  SA03        <      less-than [sign]                         
  SA04        =      equals [sign]                            
  SA05        >      greater-than [sign]                      
  SM01        #      number sign, or sharp[sign]              
  SM02        %      percent [sign]                           
  SM03        &      ampersand                                
  SM04        *      asterisk, or star                        
  SM05        @      commercial at, or at-sign                
  SM06        [      left [square] bracket                    
  SM07        \      reverse solidus, or backslash            
  SM08        ]      right [square] bracket                   
  SM11        {      left curly bracket, or left brace        
  SM13        |      vertical bar                             
  SM14        }      right curly bracket, or right brace      
  SD13        `      grave accent, or backquote               
  SD15        ^      circumflex accent                        
  SD19        ~      tilde                                    

  Figure 2–5: Standard Character Subrepertoire (Part 3 of 3: Special Characters)

The graphic IDs are not used within Common Lisp, but are provided for cross reference purposes with ISO 6937/2. Note that the first letter of the graphic ID categorizes the character as follows: L—Latin, N—Numeric, S—Special.

Next: , Previous: , Up: Character Syntax  

gcl-2.6.14/info/gcl/software_002dtype.html0000644000175000017500000000670414360276512016651 0ustar cammcamm software-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.29 software-type, software-version [Function]

software-type <no arguments> ⇒ description

software-version <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

software-type returns a string that identifies the generic name of any relevant supporting software, or nil if no appropriate or relevant result can be produced.

software-version returns a string that identifies the version of any relevant supporting software, or nil if no appropriate or relevant result can be produced.

Examples::

 (software-type) ⇒  "Multics"
 (software-version) ⇒  "1.3x"

Affected By::

Operating system environment.

Notes::

This information should be of use to maintainers of the implementation.

gcl-2.6.14/info/gcl/shared_002dinitialize.html0000644000175000017500000002111514360276512017436 0ustar cammcamm shared-initialize (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.5 shared-initialize [Standard Generic Function]

Syntax::

shared-initialize instance slot-names &rest initargs &key &allow-other-keys ⇒ instance

Method Signatures::

shared-initialize (instance standard-object) slot-names &rest initargs

Arguments and Values::

instance—an object.

slot-names—a list or t.

initargs—a list of keyword/value pairs (of initialization argument names and values).

Description::

The generic function shared-initialize is used to fill the slots of an instance using initargs and :initform forms. It is called when an instance is created, when an instance is re-initialized, when an instance is updated to conform to a redefined class, and when an instance is updated to conform to a different class. The generic function shared-initialize is called by the system-supplied primary method for initialize-instance, reinitialize-instance, update-instance-for-redefined-class, and update-instance-for-different-class.

The generic function shared-initialize takes the following arguments: the instance to be initialized, a specification of a set of slot-names accessible in that instance, and any number of initargs. The arguments after the first two must form an initialization argument list. The system-supplied primary method on shared-initialize initializes the slots with values according to the initargs and supplied :initform forms. Slot-names indicates which slots should be initialized according to their :initform forms if no initargs are provided for those slots.

The system-supplied primary method behaves as follows, regardless of whether the slots are local or shared:

*

If an initarg in the initialization argument list specifies a value for that slot, that value is stored into the slot, even if a value has already been stored in the slot before the method is run.

*

Any slots indicated by slot-names that are still unbound at this point are initialized according to their :initform forms. For any such slot that has an :initform form, that form is evaluated in the lexical environment of its defining defclass form and the result is stored into the slot. For example, if a before method stores a value in the slot, the :initform form will not be used to supply a value for the slot.

*

The rules mentioned in Rules for Initialization Arguments are obeyed.

The slots-names argument specifies the slots that are to be initialized according to their :initform forms if no initialization arguments apply. It can be a list of slot names, which specifies the set of those slot names; or it can be the symbol t, which specifies the set of all of the slots.

See Also::

Initialize-Instance , reinitialize-instance , update-instance-for-redefined-class , update-instance-for-different-class , slot-boundp , slot-makunbound , Object Creation and Initialization, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments

Notes::

Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on shared-initialize is declared as a valid initarg name for all classes for which that method is applicable.

Implementations are permitted to optimize :initform forms that neither produce nor depend on side effects, by evaluating these forms and storing them into slots before running any initialize-instance methods, rather than by handling them in the primary initialize-instance method. (This optimization might be implemented by having the allocate-instance method copy a prototype instance.)

Implementations are permitted to optimize default initial value forms for initargs associated with slots by not actually creating the complete initialization argument list when the only method that would receive the complete list is the method on standard-object. In this case default initial value forms can be treated like :initform forms. This optimization has no visible effects other than a performance improvement.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/Constant-Variables.html0000644000175000017500000000540514360276512017064 0ustar cammcamm Constant Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.5 Constant Variables

Certain variables, called constant variables, are reserved as “named constants.” The consequences are undefined if an attempt is made to assign a value to, or create a binding for a constant variable, except that a ‘compatible’ redefinition of a constant variable using defconstant is permitted; see the macro defconstant.

Keywords, symbols defined by Common Lisp or the implementation as constant (such as nil, t, and pi), and symbols declared as constant using defconstant are constant variables.

gcl-2.6.14/info/gcl/file_002derror.html0000644000175000017500000000576014360276512016107 0ustar cammcamm file-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.9 file-error [Condition Type]

Class Precedence List::

file-error, error, serious-condition, condition, t

Description::

The type file-error consists of error conditions that occur during an attempt to open or close a file, or during some low-level transactions with a file system. The “offending pathname” is initialized by the :pathname initialization argument to make-condition, and is accessed by the function file-error-pathname.

See Also::

file-error-pathname, open , probe-file , directory , ensure-directories-exist

gcl-2.6.14/info/gcl/Printing-Structures.html0000644000175000017500000000602614360276512017340 0ustar cammcamm Printing Structures (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.20 Printing Structures

By default, a structure of type S is printed using #S syntax. This behavior can be customized by specifying a :print-function or :print-object option to the defstruct form that defines S, or by writing a print-object method that is specialized for objects of type S.

Different structures might print out in different ways; the default notation for structures is: 

 #S(structure-name {slot-key slot-value}*)

where #S indicates structure syntax, structure-name is a structure name, each slot-key is an initialization argument name for a slot in the structure, and each corresponding slot-value is a representation of the object in that slot.

For information on how the Lisp reader parses structures, see Sharpsign S.

gcl-2.6.14/info/gcl/Package-System-Consistency-Rules.html0000644000175000017500000000761214360276512021573 0ustar cammcamm Package System Consistency Rules (ANSI and GNU Common Lisp Document)

Previous: , Up: Interpretation of Tokens  

2.3.6 Package System Consistency Rules

The following rules apply to the package system as long as the value of *package* is not changed:

Read-read consistency

Reading the same symbol name always results in the same symbol.

Print-read consistency

An interned symbol always prints as a sequence of characters that, when read back in, yields the same symbol.

For information about how the Lisp printer treats symbols, see Printing Symbols.

Print-print consistency

If two interned symbols are not the same, then their printed representations will be different sequences of characters.

These rules are true regardless of any implicit interning. As long as the current package is not changed, results are reproducible regardless of the order of loading files or the exact history of what symbols were typed in when. If the value of *package* is changed and then changed back to the previous value, consistency is maintained. The rules can be violated by changing the value of *package*, forcing a change to symbols or to packages or to both by continuing from an error, or calling one of the following functions: unintern, unexport, shadow, shadowing-import, or unuse-package.

An inconsistency only applies if one of the restrictions is violated between two of the named symbols. shadow, unexport, unintern, and shadowing-import can only affect the consistency of symbols with the same names (under string=) as the ones supplied as arguments.

gcl-2.6.14/info/gcl/Strings.html0000644000175000017500000000430614360276512015015 0ustar cammcamm Strings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

16 Strings

• String Concepts  
• Strings Dictionary  
gcl-2.6.14/info/gcl/Splicing-in-Modified-BNF-Syntax.html0000644000175000017500000001232714360276512021147 0ustar cammcamm Splicing in Modified BNF Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.3 Splicing in Modified BNF Syntax

The primary extension used is the following:

[[O]]

An expression of this form appears whenever a list of elements is to be spliced into a larger structure and the elements can appear in any order. The symbol O represents a description of the syntax of some number of syntactic elements to be spliced; that description must be of the form

O_1 | ... | O_l

where each O_i can be of the form S or of the form S* or of the form S^1.

The expression [[O]] means that a list of the form

(O_{i_1}... O_{i_j}) 1<= j

is spliced into the enclosing expression, such that if n != m and 1<= n,m<= j, then either O_{i_n}!= O_{i_m} or O_{i_n} = O_{i_m} = Q_k, where for some 1<= k <= n, O_k is of the form Q_k*.

Furthermore, for each O_{i_n} that is of the form Q_k^1, that element is required to appear somewhere in the list to be spliced.

For example, the expression

(x [[A | B* | C]] y)

means that at most one A, any number of B’s, and at most one C can occur in any order. It is a description of any of these: 

 (x y)
 (x B A C y)
 (x A B B B B B C y)
 (x C B A B B B y)

but not any of these: 

 (x B B A A C C y)
 (x C B C y)

In the first case, both A and C appear too often, and in the second case C appears too often.

The notation [[O_1 | O_2 | ...]]^+ adds the additional restriction that at least one item from among the possible choices must be used. For example:

(x [[A | B* | C]]^+ y)

means that at most one A, any number of B’s, and at most one C can occur in any order, but that in any case at least one of these options must be selected. It is a description of any of these: 

 (x B y)
 (x B A C y)
 (x A B B B B B C y)
 (x C B A B B B y)

but not any of these: 

 (x y)
 (x B B A A C C y)
 (x C B C y)

In the first case, no item was used; in the second case, both A and C appear too often; and in the third case C appears too often.

Also, the expression:

(x [[A^1 | B^1 | C]] y)

can generate exactly these and no others: 

 (x A B C y)
 (x A C B y)
 (x A B y)
 (x B A C y)
 (x B C A y)
 (x B A y)
 (x C A B y)
 (x C B A y)

Next: , Previous: , Up: Notational Conventions  

gcl-2.6.14/info/gcl/Tilde-Question_002dMark_002d_003e-Recursive-Processing.html0000644000175000017500000000737314360276512025134 0ustar cammcamm Tilde Question-Mark-> Recursive Processing (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.6 Tilde Question-Mark: Recursive Processing

The next arg must be a format control, and the one after it a list; both are consumed by the ~? directive. The two are processed as a control-string, with the elements of the list as the arguments. Once the recursive processing has been finished, the processing of the control string containing the ~? directive is resumed. Example: 

 (format nil "~? ~D" "<~A ~D>" '("Foo" 5) 7) ⇒  "<Foo 5> 7"
 (format nil "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) ⇒  "<Foo 5> 7"

Note that in the second example three arguments are supplied to the format string "<~A ~D>", but only two are processed and the third is therefore ignored.

With the @ modifier, only one arg is directly consumed. The arg must be a string; it is processed as part of the control string as if it had appeared in place of the ~@? construct, and any directives in the recursively processed control string may consume arguments of the control string containing the ~@? directive. Example: 

 (format nil "~@? ~D" "<~A ~D>" "Foo" 5 7) ⇒  "<Foo 5> 7"
 (format nil "~@? ~D" "<~A ~D>" "Foo" 5 14 7) ⇒  "<Foo 5> 14"
gcl-2.6.14/info/gcl/real.html0000644000175000017500000000734214360276512014312 0ustar cammcamm real (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.3 real [System Class]

Class Precedence List::

real, number, t

Description::

The type real includes all numbers that represent mathematical real numbers, though there are mathematical real numbers (e.g., irrational numbers) that do not have an exact representation in Common Lisp. Only reals can be ordered using the <, >, <=, and >= functions.

The types rational and float are disjoint subtypes of type real.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(real{[lower-limit [upper-limit]]})

Compound Type Specifier Arguments::

lower-limit, upper-limit—interval designators for type real. The defaults for each of lower-limit and upper-limit is the symbol *.

Compound Type Specifier Description::

This denotes the reals on the interval described by lower-limit and upper-limit.

gcl-2.6.14/info/gcl/_002aload_002dprint_002a.html0000644000175000017500000000564714360276512017362 0ustar cammcamm *load-print* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.9 *load-print*, *load-verbose* [Variable]

Value Type::

a generalized boolean.

Initial Value::

The initial value of *load-print* is false. The initial value of *load-verbose* is implementation-dependent.

Description::

The value of *load-print* is the default value of the :print argument to load. The value of *load-verbose* is the default value of the :verbose argument to load.

See Also::

load

gcl-2.6.14/info/gcl/Safe-and-Unsafe-Calls.html0000644000175000017500000001414314360276512017255 0ustar cammcamm Safe and Unsafe Calls (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.1 Safe and Unsafe Calls

A call is a safe call if each of the following is either safe code or system code (other than system code that results from macro expansion of programmer code):

*

the call.

*

the definition of the function being called.

*

the point of functional evaluation

The following special cases require some elaboration:

*

If the function being called is a generic function, it is considered safe if all of the following are

safe code or system code:

–

its definition (if it was defined explicitly).

–

the method definitions for all applicable methods.

–

the definition of its method combination.

*

For the form (coerce x 'function), where x is a lambda expression, the value of the optimize quality safety in the global environment at the time the coerce is executed applies to the resulting function.

*

For a call to the function ensure-generic-function, the value of the optimize quality safety in the environment object passed as the :environment argument applies to the resulting generic function.

*

For a call to compile with a lambda expression as the argument, the value of the optimize quality safety in the global environment at the time compile is called applies to the resulting compiled function.

*

For a call to compile with only one argument, if the original definition of the function was safe, then the resulting compiled function must also be safe.

*

A call to a method by call-next-method must be considered safe if each of the following is

safe code or system code:

–

the definition of the generic function (if it was defined explicitly).

–

the method definitions for all applicable methods.

–

the definition of the method combination.

–

the point of entry into the body of the method defining form, where the binding of call-next-method is established.

–

the point of functional evaluation of the name call-next-method.

An unsafe call is a call that is not a safe call.

The informal intent is that the programmer can rely on a call to be safe, even when system code is involved, if all reasonable steps have been taken to ensure that the call is safe. For example, if a programmer calls mapcar from safe code and supplies a function that was compiled as safe, the implementation is required to ensure that mapcar makes a safe call as well.

Next: , Previous: , Up: Argument Mismatch Detection  

gcl-2.6.14/info/gcl/Character-Scripts.html0000644000175000017500000000613114360276512016703 0ustar cammcamm Character Scripts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Scripts and Repertoires  

13.1.2.1 Character Scripts

A script is one of possibly several sets that form an exhaustive partition of the type character.

The number of such sets and boundaries between them is implementation-defined. Common Lisp does not require these sets to be types, but an implementation is permitted to define such types as an extension. Since no character from one script can ever be a member of another script, it is generally more useful to speak about character repertoires.

Although the term “script” is chosen for definitional compatibility with ISO terminology, no conforming implementation is required to use any particular scripts standardized by ISO or by any other standards organization.

Whether and how the script or scripts used by any given implementation are named is implementation-dependent.

gcl-2.6.14/info/gcl/Subtypes-of-STRING.html0000644000175000017500000000435114360276512016610 0ustar cammcamm Subtypes of STRING (ANSI and GNU Common Lisp Document)

Previous: , Up: String Concepts  

16.1.2 Subtypes of STRING

All functions that operate on strings will operate on subtypes of string as well.

However, the consequences are undefined if a character is inserted into a string for which the element type of the string does not include that character.

gcl-2.6.14/info/gcl/The-_0022Syntax_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000725314360276512024126 0ustar cammcamm The "Syntax" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.24 The "Syntax" Section of a Dictionary Entry

This section describes how to use the defined name in code. The "Syntax” description for a generic function describes the lambda list of the generic function itself, while The "Method Signatures” describe the lambda lists of the defined methods. The "Syntax” description for an ordinary function, a macro, or a special operator describes its parameters.

For example, an operator description might say:

F x y &optional z &key k

This description indicates that the function F has two required parameters, x and y. In addition, there is an optional parameter z and a keyword parameter k.

For macros and special operators, syntax is given in modified BNF notation; see Modified BNF Syntax. For functions a lambda list is given. In both cases, however, the outermost parentheses are omitted, and default value information is omitted.

gcl-2.6.14/info/gcl/Signaling.html0000644000175000017500000000644114360276512015301 0ustar cammcamm Signaling (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.1 Signaling

When a condition is signaled, the most recent applicable active handler is invoked. Sometimes a handler will decline by simply returning without a transfer of control. In such cases, the next most recent applicable active handler is invoked.

If there are no applicable handlers for a condition that has been signaled, or if all applicable handlers decline, the condition is unhandled.

The functions cerror and error invoke the interactive condition handler (the debugger) rather than return if the condition being signaled, regardless of its type, is unhandled. In contrast, signal returns nil if the condition being signaled, regardless of its type, is unhandled.

The variable *break-on-signals* can be used to cause the debugger to be entered before the signaling process begins.

Figure 9–5 shows defined names relating to the signaling of conditions. 

  *break-on-signals*  error   warn  
  cerror              signal        

  Figure 9–5: Defined names relating to signaling conditions.
gcl-2.6.14/info/gcl/initialize_002dinstance.html0000644000175000017500000001111014360276512017766 0ustar cammcamm initialize-instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.36 initialize-instance [Standard Generic Function]

Syntax::

initialize-instance instance &rest initargs &key &allow-other-keys ⇒ instance

Method Signatures::

initialize-instance (instance standard-object) &rest initargs

Arguments and Values::

instance—an object.

initargs—a defaulted initialization argument list.

Description::

Called by make-instance to initialize a newly created instance. The generic function is called with the new instance and the defaulted initialization argument list.

The system-supplied primary method on initialize-instance initializes the slots of the instance with values according to the initargs and the :initform forms of the slots. It does this by calling the generic function shared-initialize with the following arguments: the instance, t (this indicates that all slots for which no initialization arguments are provided should be initialized according to their :initform forms), and the initargs.

Programmers can define methods for initialize-instance to specify actions to be taken when an instance is initialized. If only after methods are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of initialize-instance.

See Also::

Shared-Initialize , make-instance , slot-boundp , slot-makunbound , Object Creation and Initialization, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments

gcl-2.6.14/info/gcl/Conses-as-Lists.html0000644000175000017500000001055214360276512016313 0ustar cammcamm Conses as Lists (ANSI and GNU Common Lisp Document)

Previous: , Up: Cons Concepts  

14.1.2 Conses as Lists

A list is a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom.

A proper list is a list terminated by the empty list. The empty list is a proper list, but is not a cons.

An improper list is a list that is not a proper list; that is, it is a circular list or a dotted list.

A dotted list is a list that has a terminating atom that is not the empty list. A non-nil atom by itself is not considered to be a list of any kind—not even a dotted list.

A circular list is a chain of conses that has no termination because some cons in the chain is the cdr of a later cons. 

  append      last           nbutlast  rest       
  butlast     ldiff          nconc     revappend  
  copy-alist  list           ninth     second     
  copy-list   list*          nreconc   seventh    
  eighth      list-length    nth       sixth      
  endp        make-list      nthcdr    tailp      
  fifth       member         pop       tenth      
  first       member-if      push      third      
  fourth      member-if-not  pushnew              

  Figure 14–3: Some defined names relating to lists.
• Lists as Association Lists  
• Lists as Sets  
• General Restrictions on Parameters that must be Lists  
gcl-2.6.14/info/gcl/Printing-Integers.html0000644000175000017500000000520014360276512016726 0ustar cammcamm Printing Integers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.2 Printing Integers

Integers are printed in the radix specified by the current output base in positional notation, most significant digit first. If appropriate, a radix specifier can be printed; see *print-radix*. If an integer is negative, a minus sign is printed and then the absolute value of the integer is printed. The integer zero is represented by the single digit 0 and never has a sign. A decimal point might be printed, depending on the value of *print-radix*.

For related information about the syntax of an integer, see Syntax of an Integer.

gcl-2.6.14/info/gcl/wild_002dpathname_002dp.html0000644000175000017500000001175014360276512017474 0ustar cammcamm wild-pathname-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.13 wild-pathname-p [Function]

wild-pathname-p pathname &optional field-key ⇒ generalized-boolean

Arguments and Values::

pathname—a pathname designator.

Field-key—one of :host, :device :directory, :name, :type, :version, or nil.

generalized-boolean—a generalized boolean.

Description::

wild-pathname-p tests pathname for the presence of wildcard components.

If pathname is a pathname (as returned by pathname) it represents the name used to open the file. This may be, but is not required to be, the actual name of the file.

If field-key is not supplied or nil, wild-pathname-p returns true if pathname has any wildcard components, nil if pathname has none. If field-key is non-nil, wild-pathname-p returns true if the indicated component of pathname is a wildcard, nil if the component is not a wildcard.

Examples::

 ;;;The following examples are not portable.  They are written to run
 ;;;with particular file systems and particular wildcard conventions.
 ;;;Other implementations will behave differently.  These examples are
 ;;;intended to be illustrative, not to be prescriptive.

 (wild-pathname-p (make-pathname :name :wild)) ⇒  true
 (wild-pathname-p (make-pathname :name :wild) :name) ⇒  true
 (wild-pathname-p (make-pathname :name :wild) :type) ⇒  false
 (wild-pathname-p (pathname "s:>foo>**>")) ⇒  true ;Lispm
 (wild-pathname-p (pathname :name "F*O")) ⇒  true ;Most places

Exceptional Situations::

If pathname is not a pathname, a string, or a stream associated with a file an error of type type-error is signaled.

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Notes::

Not all implementations support wildcards in all fields. See ->WILD as a Component Value and Restrictions on Wildcard Pathnames.

gcl-2.6.14/info/gcl/open.html0000644000175000017500000003540414360276512014330 0ustar cammcamm open (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.29 open [Function]

open filespec &key direction element-type if-exists if-does-not-exist external-format
⇒ stream

Arguments and Values::

filespec—a pathname designator.

direction—one of :input, :output, :io, or :probe. The default is :input.

element-type—a type specifier for recognizable subtype of character; or a type specifier for a finite recognizable subtype of integer; or one of the symbols signed-byte, unsigned-byte, or :default. The default is character.

if-exists—one of :error, :new-version, :rename, :rename-and-delete, :overwrite, :append, :supersede, or nil. The default is :new-version if the version component of filespec is :newest, or :error otherwise.

if-does-not-exist—one of :error, :create, or nil. The default is :error if direction is :input or if-exists is :overwrite or :append; :create if direction is :output or :io, and if-exists is neither :overwrite nor :append; or nil when direction is :probe.

external-format—an external file format designator. The default is :default.

stream—a file stream or nil.

Description::

open creates, opens, and returns a file stream that is connected to the file specified by filespec. Filespec is the name of the file to be opened. If the filespec designator is a stream, that stream is not closed first or otherwise affected.

The keyword arguments to open specify the characteristics of the file stream that is returned, and how to handle errors.

If direction is :input or :probe, or if if-exists is not :new-version and the version component of the filespec is :newest, then the file opened is that file already existing in the file system that has a version greater than that of any other file in the file system whose other pathname components are the same as those of filespec.

An implementation is required to recognize all of the open keyword options and to do something reasonable in the context of the host operating system. For example, if a file system does not support distinct file versions and does not distinguish the notions of deletion and expunging, :new-version might be treated the same as :rename or :supersede, and :rename-and-delete might be treated the same as :supersede.

:direction

These are the possible values for direction, and how they affect the nature of the stream that is created:

:input

Causes the creation of an input file stream.

:output

Causes the creation of an output file stream.

:io

Causes the creation of a bidirectional file stream.

:probe

Causes the creation of a “no-directional” file stream; in effect, the file stream is created and then closed prior to being returned by open.

:element-type

The element-type specifies the unit of transaction for the file stream. If it is :default, the unit is determined by file system, possibly based on the file.

:if-exists

if-exists specifies the action to be taken if direction is :output or :io and a file of the name filespec already exists. If direction is :input, not supplied, or :probe, if-exists is ignored. These are the results of open as modified by if-exists:

:error

An error of type file-error is signaled.

:new-version

A new file is created with a larger version number.

:rename

The existing file is renamed to some other name and then a new file is created.

:rename-and-delete

The existing file is renamed to some other name, then it is deleted but not expunged, and then a new file is created.

:overwrite

Output operations on the stream destructively modify the existing file. If direction is :io the file is opened in a bidirectional mode that allows both reading and writing. The file pointer is initially positioned at the beginning of the file; however, the file is not truncated back to length zero when it is opened.

:append

Output operations on the stream destructively modify the existing file. The file pointer is initially positioned at the end of the file.

If direction is :io, the file is opened in a bidirectional mode that allows both reading and writing.

:supersede

The existing file is superseded; that is, a new file with the same name as the old one is created. If possible, the implementation should not destroy the old file until the new stream is closed.

nil

No file or stream is created; instead, nil is returned to indicate failure.

:if-does-not-exist

if-does-not-exist specifies the action to be taken if a file of name filespec does not already exist. These are the results of open as modified by if-does-not-exist:

:error

An error of type file-error is signaled.

:create

An empty file is created. Processing continues as if the file had already existed but no processing as directed by if-exists is performed.

nil

No file or stream is created; instead, nil is returned to indicate failure.

:external-format

This option selects an external file format for the file: The only standardized value for this option is :default, although implementations are permitted to define additional external file formats and implementation-dependent values returned by stream-external-format can also be used by conforming programs.

The external-format is meaningful for any kind of file stream whose element type is a subtype of character. This option is ignored for streams for which it is not meaningful; however, implementations may define other element types for which it is meaningful. The consequences are unspecified if a character is written that cannot be represented by the given external file format.

When a file is opened, a file stream is constructed to serve as the file system’s ambassador to the Lisp environment; operations on the file stream are reflected by operations on the file in the file system.

A file can be deleted, renamed, or destructively modified by open.

For information about opening relative pathnames, see Merging Pathnames.

Examples::

 (open filespec :direction :probe)  ⇒  #<Closed Probe File Stream...>
 (setq q (merge-pathnames (user-homedir-pathname) "test"))
⇒  #<PATHNAME :HOST NIL :DEVICE device-name :DIRECTORY directory-name
    :NAME "test" :TYPE NIL :VERSION :NEWEST>
 (open filespec :if-does-not-exist :create) ⇒  #<Input File Stream...>
 (setq s (open filespec :direction :probe)) ⇒  #<Closed Probe File Stream...>
 (truename s) ⇒  #<PATHNAME :HOST NIL :DEVICE device-name :DIRECTORY
    directory-name :NAME filespec :TYPE extension :VERSION 1>
 (open s :direction :output :if-exists nil) ⇒  NIL

Affected By::

The nature and state of the host computer’s file system.

Exceptional Situations::

If if-exists is :error, (subject to the constraints on the meaning of if-exists listed above), an error of type file-error is signaled.

If if-does-not-exist is :error (subject to the constraints on the meaning of if-does-not-exist listed above), an error of type file-error is signaled.

If it is impossible for an implementation to handle some option in a manner close to what is specified here, an error of type error might be signaled.

An error of type file-error is signaled if (wild-pathname-p filespec) returns true.

An error of type error is signaled if the external-format is not understood by the implementation.

The various file systems in existence today have widely differing capabilities, and some aspects of the file system are beyond the scope of this specification to define. A given implementation might not be able to support all of these options in exactly the manner stated. An implementation is required to recognize all of these option keywords and to try to do something “reasonable” in the context of the host file system. Where necessary to accomodate the file system, an implementation deviate slightly from the semantics specified here without being disqualified for consideration as a conforming implementation. If it is utterly impossible for an implementation to handle some option in a manner similar to what is specified here, it may simply signal an error.

With regard to the :element-type option, if a type is requested that is not supported by the file system, a substitution of types such as that which goes on in upgrading is permissible. As a minimum requirement, it should be the case that opening an output stream to a file in a given element type and later opening an input stream to the same file in the same element type should work compatibly.

See Also::

with-open-file , close , pathname, logical-pathname,

Merging Pathnames,

Pathnames as Filenames

Notes::

open does not automatically close the file when an abnormal exit occurs.

When element-type is a subtype of character, read-char and/or write-char can be used on the resulting file stream.

When element-type is a subtype of integer, read-byte and/or write-byte can be used on the resulting file stream.

When element-type is :default, the type can be determined by using stream-element-type.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/t.html0000644000175000017500000000627014360276512013631 0ustar cammcamm t (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.32 t [Constant Variable]

Constant Value::

t.

Description::

The boolean representing true, and the canonical generalized boolean representing true. Although any object other than nil is considered true, t is generally used when there is no special reason to prefer one such object over another.

The symbol t is also sometimes used for other purposes as well. For example, as the name of a class, as a designator (e.g., a stream designator) or as a special symbol for some syntactic reason (e.g., in case and typecase to label the otherwise-clause).

Examples::

 t ⇒  T 
 (eq t 't) ⇒  true
 (find-class 't) ⇒  #<CLASS T 610703333>
 (case 'a (a 1) (t 2)) ⇒  1
 (case 'b (a 1) (t 2)) ⇒  2
 (prin1 'hello t)
 |>  HELLO
⇒  HELLO

See Also::

NIL

gcl-2.6.14/info/gcl/The-_0022Argument-Precedence-Order_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000544014360276512027522 0ustar cammcamm The "Argument Precedence Order" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.16 The "Argument Precedence Order" Section of a Dictionary Entry

This information describes the argument precedence order. If it is omitted, the argument precedence order is the default (left to right).

gcl-2.6.14/info/gcl/The-_0022Constant-Value_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000537714360276512025510 0ustar cammcamm The "Constant Value" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.11 The "Constant Value" Section of a Dictionary Entry

This information describes the unchanging type and value of a constant variable.

gcl-2.6.14/info/gcl/Namestrings-as-Filenames.html0000644000175000017500000000630314360276512020157 0ustar cammcamm Namestrings as Filenames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of Filenames  

19.1.1 Namestrings as Filenames

A namestring is a string that represents a filename.

In general, the syntax of namestrings involves the use of implementation-defined conventions, usually those customary for the file system in which the named file resides. The only exception is the syntax of a logical pathname namestring, which is defined in this specification; see Syntax of Logical Pathname Namestrings.

A conforming program must never unconditionally use a literal namestring other than a logical pathname namestring because Common Lisp does not define any namestring syntax other than that for logical pathnames that would be guaranteed to be portable. However, a conforming program can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable namestrings.

A namestring can be coerced to a pathname by the functions pathname or parse-namestring.

gcl-2.6.14/info/gcl/The-Host-part-of-a-Logical-Pathname-Namestring.html0000644000175000017500000000556314360276512024021 0ustar cammcamm The Host part of a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.2 The Host part of a Logical Pathname Namestring

The host must have been defined as a logical pathname host; this can be done by using setf of logical-pathname-translations.

The logical pathname host name "SYS" is reserved for the implementation. The existence and meaning of SYS: logical pathnames is implementation-defined.

gcl-2.6.14/info/gcl/Iteration-Control.html0000644000175000017500000001333714360276512016744 0ustar cammcamm Iteration Control (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.1 Iteration Control

Iteration control clauses allow direction of loop iteration. The loop keywords for and as designate iteration control clauses. Iteration control clauses differ with respect to the specification of termination tests and to the initialization and stepping_1 of loop variables. Iteration clauses by themselves do not cause the Loop Facility to return values, but they can be used in conjunction with value-accumulation clauses to return values.

All variables are initialized in the loop prologue. A variable binding has lexical scope unless it is proclaimed special; thus, by default, the variable can be accessed only by forms that lie textually within the loop. Stepping assignments are made in the loop body before any other forms are evaluated in the body.

The variable argument in iteration control clauses can be a destructuring list. A destructuring list is a tree whose non-nil atoms are variable names. See Destructuring.

The iteration control clauses for, as, and repeat must precede any other loop clauses, except initially, with, and named, since they establish variable bindings. When iteration control clauses are used in a loop, the corresponding termination tests in the loop body are evaluated before any other loop body code is executed.

If multiple iteration clauses are used to control iteration, variable initialization and stepping_1 occur sequentially by default. The and construct can be used to connect two or more iteration clauses when sequential binding and stepping_1 are not necessary. The iteration behavior of clauses joined by and is analogous to the behavior of the macro do with respect to do*.

The for and as clauses iterate by using one or more local loop variables that are initialized to some value and that can be modified or stepped_1 after each iteration. For these clauses, iteration terminates when a local variable reaches some supplied value or when some other loop clause terminates iteration. At each iteration, variables can be stepped_1 by an increment or a decrement or can be assigned a new value by the evaluation of a form). Destructuring can be used to assign values to variables during iteration.

The for and as keywords are synonyms; they can be used interchangeably. There are seven syntactic formats for these constructs. In each syntactic format, the type of var can be supplied by the optional type-spec argument. If var is a destructuring list, the type supplied by the type-spec argument must appropriately match the elements of the list. By convention, for introduces new iterations and as introduces iterations that depend on a previous iteration specification.

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

gcl-2.6.14/info/gcl/Function-Call-Forms-as-Places.html0000644000175000017500000002643714360276512020725 0ustar cammcamm Function Call Forms as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.2 Function Call Forms as Places

A function form can be used as a place if it falls into one of the following categories:

*

A function call form whose first element is the name of any one of the functions in Figure 5–7.

[Editorial Note by KMP: Note that what are in some places still called ‘condition accessors’ are deliberately omitted from this table, and are not labeled as accessors in their entries. I have not yet had time to do a full search for these items and eliminate stray references to them as ‘accessors’, which they are not, but I will do that at some point.] 

  aref    cdadr                    get                            
  bit     cdar                     gethash                        
  caaaar  cddaar                   logical-pathname-translations  
  caaadr  cddadr                   macro-function                 
  caaar   cddar                    ninth                          
  caadar  cdddar                   nth                            
  caaddr  cddddr                   readtable-case                 
  caadr   cdddr                    rest                           
  caar    cddr                     row-major-aref                 
  cadaar  cdr                      sbit                           
  cadadr  char                     schar                          
  cadar   class-name               second                         
  caddar  compiler-macro-function  seventh                        
  cadddr  documentation            sixth                          
  caddr   eighth                   slot-value                     
  cadr    elt                      subseq                         
  car     fdefinition              svref                          
  cdaaar  fifth                    symbol-function                
  cdaadr  fill-pointer             symbol-plist                   
  cdaar   find-class               symbol-value                   
  cdadar  first                    tenth                          
  cdaddr  fourth                   third                          

       Figure 5–7: Functions that setf can be used with—1

In the case of subseq, the replacement value must be a sequence whose elements might be contained by the sequence argument to subseq, but does not have to be a sequence of the same type as the sequence of which the subsequence is specified. If the length of the replacement value does not equal the length of the subsequence to be replaced, then the shorter length determines the number of elements to be stored, as for replace.

*

A function call form whose first element is the name of a selector function constructed by defstruct.

The function name must refer to the global function definition, rather than a locally defined function.

*

A function call form whose first element is the name of any one of the functions in Figure 5–8, provided that the supplied argument to that function is in turn a place form; in this case the new place has stored back into it the result of applying the supplied “update” function. 

  Function name  Argument that is a place  Update function used      
  ldb            second                    dpb                       
  mask-field     second                    deposit-field             
  getf           first                     implementation-dependent  

         Figure 5–8: Functions that setf can be used with—2

During the setf expansion of these forms, it is necessary to call

get-setf-expansion

in order to figure out how the inner, nested generalized variable must be treated.

The information from

get-setf-expansion

is used as follows.

ldb

In a form such as:

(setf (ldb byte-spec place-form) value-form)

the place referred to by the place-form must always be both read and written; note that the update is to the generalized variable specified by place-form, not to any object of type integer.

Thus this setf should generate code to do the following:

1.

Evaluate byte-spec (and bind it into a temporary variable).

2.

Bind the temporary variables for place-form.

3.

Evaluate value-form (and bind

its value or values into the store variable).

4.

Do the read from place-form.

5.

Do the write into place-form with the given bits of the integer fetched in step 4 replaced with the value from step 3.

If the evaluation of value-form in step 3 alters what is found in place-form, such as setting different bits of integer, then the change of the bits denoted by byte-spec is to that altered integer, because step 4 is done after the value-form evaluation. Nevertheless, the evaluations required for binding the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen. For example: 

 (setq integer #x69) ⇒  #x69
 (rotatef (ldb (byte 4 4) integer) 
          (ldb (byte 4 0) integer))
 integer ⇒  #x96
;;; This example is trying to swap two independent bit fields 
;;; in an integer.  Note that the generalized variable of 
;;; interest here is just the (possibly local) program variable
;;; integer.
mask-field

This case is the same as ldb in all essential aspects.

getf

In a form such as:

(setf (getf place-form ind-form) value-form)

the place referred to by place-form must always be both read and written; note that the update is to the generalized variable specified by place-form, not necessarily to the particular list that is the property list in question.

Thus this setf should generate code to do the following:

1.

Bind the temporary variables for place-form.

2.

Evaluate ind-form (and bind it into a temporary variable).

3.

Evaluate value-form (and bind

its value or values into the store variable).

4.

Do the read from place-form.

5.

Do the write into place-form with a possibly-new property list obtained by combining the values from steps 2, 3, and 4. (Note that the phrase “possibly-new property list” can mean that the former property list is somehow destructively re-used, or it can mean partial or full copying of it. Since either copying or destructive re-use can occur, the treatment of the resultant value for the possibly-new property list must proceed as if it were a different copy needing to be stored back into the generalized variable.)

If the evaluation of value-form in step 3 alters what is found in place-form, such as setting a different named property in the list, then the change of the property denoted by ind-form is to that altered list, because step 4 is done after the value-form evaluation. Nevertheless, the evaluations required for binding the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen.

For example: 

 (setq s (setq r (list (list 'a 1 'b 2 'c 3)))) ⇒  ((a 1 b 2 c 3))
 (setf (getf (car r) 'b) 
       (progn (setq r nil) 6)) ⇒  6
 r ⇒  NIL
 s ⇒  ((A 1 B 6 C 3))
;;; Note that the (setq r nil) does not affect the actions of 
;;; the SETF because the value of R had already been saved in 
;;; a temporary variable as part of the step 1. Only the CAR
;;; of this value will be retrieved, and subsequently modified 
;;; after the value computation.

Next: , Previous: , Up: Kinds of Places  

gcl-2.6.14/info/gcl/mapc.html0000644000175000017500000001733014360276512014305 0ustar cammcamm mapc (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.34 mapc, mapcar, mapcan, mapl, maplist, mapcon [Function]

mapc function &rest lists^+ ⇒ list-1

mapcar function &rest lists^+ ⇒ result-list

mapcan function &rest lists^+ ⇒ concatenated-results

mapl function &rest lists^+ ⇒ list-1

maplist function &rest lists^+ ⇒ result-list

mapcon function &rest lists^+ ⇒ concatenated-results

Arguments and Values::

function—a designator for a function that must take as many arguments as there are lists.

list—a proper list.

list-1—the first list (which must be a proper list).

result-list—a list.

concatenated-results—a list.

Description::

The mapping operation involves applying function to successive sets of arguments in which one argument is obtained from each sequence. Except for mapc and mapl, the result contains the results returned by function. In the cases of mapc and mapl, the resulting sequence is list.

function is called first on all the elements with index 0, then on all those with index 1, and so on. result-type specifies the type of the resulting sequence.

If function is a symbol, it is coerced to a function as if by symbol-function.

mapcar operates on successive elements of the lists. function is applied to the first element of each list, then to the second element of each list, and so on. The iteration terminates when the shortest list runs out, and excess elements in other lists are ignored. The value returned by mapcar is a list of the results of successive calls to function.

mapc is like mapcar except that the results of applying function are not accumulated. The list argument is returned.

maplist is like mapcar except that function is applied to successive sublists of the lists. function is first applied to the lists themselves, and then to the cdr of each list, and then to the cdr of the cdr of each list, and so on.

mapl is like maplist except that the results of applying function are not accumulated; list-1 is returned.

mapcan and mapcon are like mapcar and maplist respectively, except that the results of applying function are combined into a list by the use of nconc rather than list. That is, 

 (mapcon f x1 ... xn)
   ≡ (apply #'nconc (maplist f x1 ... xn))

and similarly for the relationship between mapcan and mapcar.

Examples::

 (mapcar #'car '((1 a) (2 b) (3 c))) ⇒  (1 2 3) 
 (mapcar #'abs '(3 -4 2 -5 -6)) ⇒  (3 4 2 5 6)
 (mapcar #'cons '(a b c) '(1 2 3)) ⇒  ((A . 1) (B . 2) (C . 3))

 (maplist #'append '(1 2 3 4) '(1 2) '(1 2 3)) 
⇒  ((1 2 3 4 1 2 1 2 3) (2 3 4 2 2 3)) 
 (maplist #'(lambda (x) (cons 'foo x)) '(a b c d))
⇒  ((FOO A B C D) (FOO B C D) (FOO C D) (FOO D))
 (maplist #'(lambda (x) (if (member (car x) (cdr x)) 0 1)) '(a b a c d b c))
⇒  (0 0 1 0 1 1 1)
;An entry is 1 if the corresponding element of the input
;  list was the last instance of that element in the input list.

 (setq dummy nil) ⇒  NIL 
 (mapc #'(lambda (&rest x) (setq dummy (append dummy x)))
        '(1 2 3 4)
        '(a b c d e)
        '(x y z)) ⇒  (1 2 3 4) 
 dummy ⇒  (1 A X 2 B Y 3 C Z)                   

 (setq dummy nil) ⇒  NIL 
 (mapl #'(lambda (x) (push x dummy)) '(1 2 3 4)) ⇒  (1 2 3 4) 
 dummy ⇒  ((4) (3 4) (2 3 4) (1 2 3 4)) 

 (mapcan #'(lambda (x y) (if (null x) nil (list x y)))
          '(nil nil nil d e)
          '(1 2 3 4 5 6)) ⇒  (D 4 E 5) 
 (mapcan #'(lambda (x) (and (numberp x) (list x)))
          '(a 1 b c 3 4 d 5))
⇒  (1 3 4 5)

In this case the function serves as a filter; this is a standard Lisp idiom using mapcan. 

 (mapcon #'list '(1 2 3 4)) ⇒  ((1 2 3 4) (2 3 4) (3 4) (4))

Exceptional Situations::

Should be prepared to signal an error of type type-error if any list is not a proper list.

See Also::

dolist , map ,

Traversal Rules and Side Effects

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Evaluation-of-Subforms-to-Places.html0000644000175000017500000001350114360276512021515 0ustar cammcamm Evaluation of Subforms to Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of Places and Generalized Reference  

5.1.1.1 Evaluation of Subforms to Places

The following rules apply to the evaluation of subforms in a place:

1.

The evaluation ordering of subforms within a place is determined by the order specified by the second value returned by

get-setf-expansion.

For all places defined by this specification (e.g., getf, ldb, ...), this order of evaluation is left-to-right.

When a place is derived from a macro expansion, this rule is applied after the macro is expanded to find the appropriate place.

Places defined by using defmacro or

define-setf-expander

use the evaluation order defined by those definitions. For example, consider the following: 

 (defmacro wrong-order (x y) `(getf ,y ,x))

This following form evaluates place2 first and then place1 because that is the order they are evaluated in the macro expansion: 

 (push value (wrong-order place1 place2))
2.

For the macros that manipulate places (push, pushnew, remf, incf, decf, shiftf, rotatef, psetf, setf, pop, and those defined by define-modify-macro) the subforms of the macro call are evaluated exactly once in left-to-right order, with the subforms of the places evaluated in the order specified in (1).

push, pushnew, remf, incf, decf, shiftf, rotatef, psetf, pop evaluate all subforms before modifying any of the place locations. setf (in the case when setf has more than two arguments) performs its operation on each pair in sequence. For example, in 

 (setf place1 value1 place2 value2 ...)

the subforms of place1 and value1 are evaluated, the location specified by place1 is modified to contain the value returned by value1, and then the rest of the setf form is processed in a like manner.

3.

For check-type, ctypecase, and ccase, subforms of the place are evaluated once as in (1), but might be evaluated again if the type check fails in the case of check-type or none of the cases hold in ctypecase and ccase.

4.

For assert, the order of evaluation of the generalized references is not specified.

Rules 2, 3 and 4 cover all standardized macros that manipulate places.

Next: , Previous: , Up: Overview of Places and Generalized Reference  

gcl-2.6.14/info/gcl/functionp.html0000644000175000017500000000657114360276512015377 0ustar cammcamm functionp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.10 functionp [Function]

functionp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type function; otherwise, returns false.

Examples::

 (functionp 'append) ⇒  false
 (functionp #'append) ⇒  true
 (functionp (symbol-function 'append)) ⇒  true
 (flet ((f () 1)) (functionp #'f)) ⇒  true
 (functionp (compile nil '(lambda () 259))) ⇒  true
 (functionp nil) ⇒  false
 (functionp 12) ⇒  false
 (functionp '(lambda (x) (* x x))) ⇒  false
 (functionp #'(lambda (x) (* x x))) ⇒  true

Notes::

 (functionp object) ≡ (typep object 'function)
gcl-2.6.14/info/gcl/_002adefault_002dpathname_002ddefaults_002a.html0000644000175000017500000000707714360276512023004 0ustar cammcamm *default-pathname-defaults* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.10 *default-pathname-defaults* [Variable]

Value Type::

a pathname object.

Initial Value::

An implementation-dependent pathname, typically in the working directory that was current when Common Lisp was started up.

Description::

a pathname, used as the default whenever a function needs a default pathname and one is not supplied.

Examples::

 ;; This example illustrates a possible usage for a hypothetical Lisp running on a
 ;; DEC TOPS-20 file system.  Since pathname conventions vary between Lisp 
 ;; implementations and host file system types, it is not possible to provide a
 ;; general-purpose, conforming example.
 *default-pathname-defaults* ⇒  #P"PS:<FRED>"
 (merge-pathnames (make-pathname :name "CALENDAR"))
⇒  #P"PS:<FRED>CALENDAR"
 (let ((*default-pathname-defaults* (pathname "<MARY>")))
   (merge-pathnames (make-pathname :name "CALENDAR")))
⇒  #P"<MARY>CALENDAR"

Affected By::

The implementation.

gcl-2.6.14/info/gcl/Multiple-Escape-Characters.html0000644000175000017500000000527114360276512020434 0ustar cammcamm Multiple Escape Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.5 Multiple Escape Characters

A pair of multiple escape characters is used to indicate that an enclosed sequence of characters, including possible macro characters and whitespace_2 characters, are to be treated as alphabetic_2 characters with case preserved. Any single escape and multiple escape characters that are to appear in the sequence must be preceded by a single escape character.

Vertical-bar is a multiple escape character in standard syntax.

gcl-2.6.14/info/gcl/mismatch.html0000644000175000017500000001251014360276512015165 0ustar cammcamm mismatch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.17 mismatch [Function]

mismatch sequence-1 sequence-2 &key from-end test test-not key start1 start2 end1 end2
⇒ position

Arguments and Values::

Sequence-1—a sequence.

Sequence-2—a sequence.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start1, end1—bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively.

start2, end2—bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively.

key—a designator for a function of one argument, or nil.

position—a bounding index of sequence-1, or nil.

Description::

The specified subsequences of sequence-1 and sequence-2 are compared element-wise.

The key argument is used for both the sequence-1 and the sequence-2.

If sequence-1 and sequence-2 are of equal length and match in every element, the result is false. Otherwise, the result is a non-negative integer, the index within sequence-1 of the leftmost or rightmost position, depending on from-end, at which the two subsequences fail to match. If one subsequence is shorter than and a matching prefix of the other, the result is the index relative to sequence-1 beyond the last position tested.

If from-end is true, then one plus the index of the rightmost position in which the sequences differ is returned. In effect, the subsequences are aligned at their right-hand ends; then, the last elements are compared, the penultimate elements, and so on. The index returned is an index relative to sequence-1.

Examples::

 (mismatch "abcd" "ABCDE" :test #'char-equal) ⇒  4
 (mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t) ⇒  3
 (mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp) ⇒  NIL
 (mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4) ⇒  NIL

See Also::

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/revappend.html0000644000175000017500000001210314360276512015342 0ustar cammcamm revappend (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.27 revappend, nreconc [Function]

revappend list tail ⇒ result-list

nreconc list tail ⇒ result-list

Arguments and Values::

list—a proper list.

tail—an object.

result-list—an object.

Description::

revappend constructs a copy_2 of list, but with the elements in reverse order. It then appends (as if by nconc) the tail to that reversed list and returns the result.

nreconc reverses the order of elements in list (as if by nreverse). It then appends (as if by nconc) the tail to that reversed list and returns the result.

The resulting list shares list structure with tail.

Examples::

 (let ((list-1 (list 1 2 3))
       (list-2 (list 'a 'b 'c)))
   (print (revappend list-1 list-2))
   (print (equal list-1 '(1 2 3)))
   (print (equal list-2 '(a b c))))
 |>  (3 2 1 A B C) 
 |>  T
 |>  T
⇒  T

 (revappend '(1 2 3) '()) ⇒  (3 2 1)
 (revappend '(1 2 3) '(a . b)) ⇒  (3 2 1 A . B)
 (revappend '() '(a b c)) ⇒  (A B C)
 (revappend '(1 2 3) 'a) ⇒  (3 2 1 . A)
 (revappend '() 'a) ⇒  A   ;degenerate case

 (let ((list-1 '(1 2 3))
       (list-2 '(a b c)))
   (print (nreconc list-1 list-2))
   (print (equal list-1 '(1 2 3)))
   (print (equal list-2 '(a b c))))
 |>  (3 2 1 A B C) 
 |>  NIL
 |>  T
⇒  T

Side Effects::

revappend does not modify either of its arguments. nreconc is permitted to modify list but not tail.

Although it might be implemented differently, nreconc is constrained to have side-effect behavior equivalent to: 

 (nconc (nreverse list) tail)

See Also::

reverse , nreverse, nconc

Notes::

The following functional equivalences are true, although good implementations will typically use a faster algorithm for achieving the same effect: 

 (revappend list tail) ≡ (nconc (reverse list) tail)
 (nreconc list tail) ≡ (nconc (nreverse list) tail)

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Tilde-O_002d_003e-Octal.html0000644000175000017500000000464314360276512017141 0ustar cammcamm Tilde O-> Octal (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Radix Control  

22.3.2.4 Tilde O: Octal

This is just like ~D but prints in octal radix (radix 8) instead of decimal. The full form is therefore ~mincol,padchar,commachar,comma-intervalO.

~O binds *print-escape* to false, *print-radix* to false, *print-base* to 8,

and *print-readably* to false.

gcl-2.6.14/info/gcl/Strings-in-Component-Values.html0000644000175000017500000000440614360276512020617 0ustar cammcamm Strings in Component Values (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.1 Strings in Component Values

gcl-2.6.14/info/gcl/Characters-With-Case.html0000644000175000017500000000453214360276512017226 0ustar cammcamm Characters With Case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.3 Characters With Case

The characters with case are a subset of the alphabetic_1 characters. A character with case has the property of being either uppercase or lowercase. Every character with case is in one-to-one correspondence with some other character with the opposite case.

gcl-2.6.14/info/gcl/Macro-Characters.html0000644000175000017500000001315414360276512016503 0ustar cammcamm Macro Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.4 Macro Characters

When the Lisp reader encounters a macro character on an input stream, special parsing of subsequent characters on the input stream is performed.

A macro character has an associated function called a reader macro function that implements its specialized parsing behavior. An association of this kind can be established or modified under control of a conforming program by using the functions set-macro-character and set-dispatch-macro-character.

Upon encountering a macro character, the Lisp reader calls its reader macro function, which parses one specially formatted object from the input stream. The function either returns the parsed object, or else it returns no values to indicate that the characters scanned by the function are being ignored (e.g., in the case of a comment). Examples of macro characters are backquote, single-quote, left-parenthesis, and right-parenthesis.

A macro character is either terminating or non-terminating. The difference between terminating and non-terminating macro characters lies in what happens when such characters occur in the middle of a token. If a non-terminating macro character occurs in the middle of a token, the function associated with the non-terminating macro character is not called, and the non-terminating macro character does not terminate the token’s name; it becomes part of the name as if the macro character were really a constituent character. A terminating macro character terminates any token, and its associated reader macro function is called no matter where the character appears. The only non-terminating macro character in standard syntax is sharpsign.

If a character is a dispatching macro character C_1, its reader macro function is a function supplied by the implementation. This function reads decimal digit characters until a non-digit C_2 is read. If any digits were read, they are converted into a corresponding integer infix parameter P; otherwise, the infix parameter P is nil. The terminating non-digit C_2 is a character (sometimes called a “sub-character” to emphasize its subordinate role in the dispatching) that is looked up in the dispatch table associated with the dispatching macro character C_1. The reader macro function associated with the sub-character C_2 is invoked with three arguments: the stream, the sub-character C_2, and the infix parameter P. For more information about dispatch characters, see the function set-dispatch-macro-character.

For information about the macro characters that are available in standard syntax, see Standard Macro Characters.

Next: , Previous: , Up: Character Syntax Types  

gcl-2.6.14/info/gcl/The-_0022Description_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000541614360276512025122 0ustar cammcamm The "Description" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.12 The "Description" Section of a Dictionary Entry

A summary of the operator and all intended aspects of the operator, but does not necessarily include all the fields referenced below it (“Side Effects,” “Exceptional Situations,” etc.)

gcl-2.6.14/info/gcl/let.html0000644000175000017500000001555314360276512014156 0ustar cammcamm let (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.18 let, let* [Special Operator]

let ({var | (var [init-form])}*) {declaration}* {form}* ⇒ {result}*

let* ({var | (var [init-form])}*) {declaration}* {form}* ⇒ {result}*

Arguments and Values::

var—a symbol.

init-form—a form.

declaration—a declare expression; not evaluated.

form—a form.

results—the values returned by the forms.

Description::

let and let* create new variable bindings and execute a series of forms that use these bindings. let performs the bindings in parallel and let* does them sequentially.

The form 

 (let ((var1 init-form-1)
       (var2 init-form-2)
       ...
       (varm init-form-m))
   declaration1
   declaration2
   ...
   declarationp
   form1
   form2
   ...
   formn)

first evaluates the expressions init-form-1, init-form-2, and so on,

in that order, saving the resulting values. Then all of the variables varj are bound to the corresponding values; each binding is lexical unless there is a special declaration to the contrary. The expressions formk are then evaluated in order; the values of all but the last are discarded (that is, the body of a let is an implicit progn).

let* is similar to let, but the bindings of variables are performed sequentially rather than in parallel. The expression for the init-form of a var can refer to vars previously bound in the let*.

The form 

 (let* ((var1 init-form-1)
        (var2 init-form-2)
        ...
        (varm init-form-m))
   declaration1
   declaration2
   ...
   declarationp
   form1
   form2
   ...
   formn)

first evaluates the expression init-form-1, then binds the variable var1 to that value; then it evaluates init-form-2 and binds

var2, and so on. The expressions formj are then evaluated in order; the values of all but the last are discarded (that is, the body of let* is an implicit progn).

For both let and let*, if there is not an init-form associated with a var, var is initialized to nil.

The special form let has the property that the scope of the name binding does not include any initial value form. For let*, a variable’s scope also includes the remaining initial value forms for subsequent variable bindings.

Examples::

 (setq a 'top) ⇒  TOP
 (defun dummy-function () a) ⇒  DUMMY-FUNCTION
 (let ((a 'inside) (b a))
    (format nil "~S ~S ~S" a b (dummy-function))) ⇒  "INSIDE TOP TOP" 
 (let* ((a 'inside) (b a))
    (format nil "~S ~S ~S" a b (dummy-function))) ⇒  "INSIDE INSIDE TOP" 
 (let ((a 'inside) (b a))
    (declare (special a))
    (format nil "~S ~S ~S" a b (dummy-function))) ⇒  "INSIDE TOP INSIDE"

The code 

 (let (x)
   (declare (integer x))
   (setq x (gcd y z))
   ...)

is incorrect; although x is indeed set before it is used, and is set to a value of the declared type integer, nevertheless x initially takes on the value nil in violation of the type declaration.

See Also::

progv

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Summary-of-Miscellaneous-Clauses.html0000644000175000017500000000537414360276512021627 0ustar cammcamm Summary of Miscellaneous Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.13 Summary of Miscellaneous Clauses

The loop named construct gives a name for the block of the loop.

The loop initially construct causes its forms to be evaluated in the loop prologue, which precedes all loop code except for initial settings supplied by the constructs with, for, or as.

The loop finally construct causes its forms to be evaluated in the loop epilogue after normal iteration terminates.

For more information, see Miscellaneous Clauses.

gcl-2.6.14/info/gcl/Summary-of-Loop-Clauses.html0000644000175000017500000000437114360276512017731 0ustar cammcamm Summary of Loop Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.7 Summary of Loop Clauses

Loop clauses fall into one of the following categories:

gcl-2.6.14/info/gcl/signum.html0000644000175000017500000001031514360276512014663 0ustar cammcamm signum (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.37 signum [Function]

signum number ⇒ signed-prototype

Arguments and Values::

number—a number.

signed-prototype—a number.

Description::

signum determines a numerical value that indicates whether number is negative, zero, or positive.

For a rational, signum returns one of -1, 0, or 1 according to whether number is negative, zero, or positive. For a float, the result is a float of the same format whose value is minus one, zero, or one. For a complex number z, (signum z) is a complex number of the same phase but with unit magnitude, unless z is a complex zero, in which case the result is z.

For rational arguments, signum is a rational function, but it may be irrational for complex arguments.

If number is a float, the result is a float. If number is a rational, the result is a rational. If number is a complex float, the result is a complex float. If number is a complex rational, the result is a complex, but it is implementation-dependent whether that result is a complex rational or a complex float.

Examples::

 (signum 0) ⇒  0
 (signum 99) ⇒  1
 (signum 4/5) ⇒  1
 (signum -99/100) ⇒  -1
 (signum 0.0) ⇒  0.0
 (signum #c(0 33)) ⇒  #C(0.0 1.0)
 (signum #c(7.5 10.0)) ⇒  #C(0.6 0.8)
 (signum #c(0.0 -14.7)) ⇒  #C(0.0 -1.0)
 (eql (signum -0.0) -0.0) ⇒  true

See Also::

Rule of Float Substitutability

Notes::

 (signum x) ≡ (if (zerop x) x (/ x (abs x)))
gcl-2.6.14/info/gcl/parse_002dnamestring.html0000644000175000017500000002114414360276512017312 0ustar cammcamm parse-namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.12 parse-namestring [Function]

parse-namestring thing &optional host default-pathname &key start end junk-allowed
⇒ pathname, position

Arguments and Values::

thing—a string, a pathname, or a stream associated with a file.

host—a valid pathname host, a logical host, or nil.

default-pathname—a pathname designator. The default is the value of *default-pathname-defaults*.

start, end—bounding index designators of thing. The defaults for start and end are 0 and nil, respectively.

junk-allowed—a generalized boolean. The default is false.

pathname—a pathname, or nil.

position—a bounding index designator for thing.

Description::

Converts thing into a pathname.

The host supplies a host name with respect to which the parsing occurs.

If thing is a stream associated with a file, processing proceeds as if the pathname used to open that file had been supplied instead.

If thing is a pathname, the host and the host component of thing are compared. If they match, two values are immediately returned: thing and start; otherwise (if they do not match), an error is signaled.

Otherwise (if thing is a string), parse-namestring parses the name of a file within the substring of thing bounded by start and end.

If thing is a string then the substring of thing bounded by start and end is parsed into a pathname as follows:

*

If host is a logical host then thing is parsed as a logical pathname namestring on the host.

*

If host is nil and thing is a syntactically valid logical pathname namestring containing an explicit host, then it is parsed as a logical pathname namestring.

*

If host is nil, default-pathname is a logical pathname, and thing is a syntactically valid logical pathname namestring without an explicit host, then it is parsed as a logical pathname namestring on the host that is the host component of default-pathname.

*

Otherwise, the parsing of thing is implementation-defined.

In the first of these cases, the host portion of the logical pathname namestring and its following colon are optional.

If the host portion of the namestring and host are both present and do not match, an error is signaled.

If junk-allowed is true, then the primary value is the pathname parsed or, if no syntactically correct pathname was seen, nil. If junk-allowed is false, then the entire substring is scanned, and the primary value is the pathname parsed.

In either case, the secondary value is the index into thing of the delimiter that terminated the parse, or the index beyond the substring if the parse terminated at the end of the substring (as will always be the case if junk-allowed is false).

Parsing a null string always succeeds, producing a pathname with all components (except the host) equal to nil.

If thing contains an explicit host name and no explicit device name, then it is implementation-defined whether parse-namestring will supply the standard default device for that host as the device component of the resulting pathname.

Examples::

 (setq q (parse-namestring "test"))  
⇒  #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" 
       :TYPE NIL :VERSION NIL)
 (pathnamep q) ⇒  true
 (parse-namestring "test") 
⇒  #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test"
       :TYPE NIL :VERSION NIL), 4
 (setq s (open xxx)) ⇒  #<Input File Stream...>
 (parse-namestring s) 
⇒  #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME xxx 
       :TYPE NIL :VERSION NIL), 0
 (parse-namestring "test" nil nil :start 2 :end 4 )
 ⇒  #S(PATHNAME ...), 15
 (parse-namestring "foo.lisp")
⇒  #P"foo.lisp"

Exceptional Situations::

If junk-allowed is false, an error of type parse-error is signaled if thing does not consist entirely of the representation of a pathname, possibly surrounded on either side by whitespace_1 characters if that is appropriate to the cultural conventions of the implementation.

If host is supplied and not nil, and thing contains a manifest host name, an error of type error is signaled if the hosts do not match.

If thing is a logical pathname namestring and if the host portion of the namestring and host are both present and do not match, an error of type error is signaled.

See Also::

pathname, logical-pathname, File System Concepts,

->UNSPECIFIC as a Component Value,

Pathnames as Filenames

Next: , Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/svref.html0000644000175000017500000000714514360276512014515 0ustar cammcamm svref (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.28 svref [Accessor]

svref simple-vector index ⇒ element

(setf ( svref simple-vector index) new-element)

Arguments and Values::

simple-vector—a simple vector.

index—a valid array index for the simple-vector.

element, new-element—an object (whose type is a subtype of the array element type of the simple-vector).

Description::

Accesses the element of simple-vector specified by index.

Examples::

 (simple-vector-p (setq v (vector 1 2 'sirens))) ⇒  true
 (svref v 0) ⇒  1
 (svref v 2) ⇒  SIRENS
 (setf (svref v 1) 'newcomer) ⇒  NEWCOMER               
 v ⇒  #(1 NEWCOMER SIRENS)

See Also::

aref , sbit, schar, vector ,

Compiler Terminology

Notes::

svref is identical to aref except that it requires its first argument to be a simple vector. 

 (svref v i) ≡ (aref (the simple-vector v) i)
gcl-2.6.14/info/gcl/not-_0028Type-Specifier_0029.html0000644000175000017500000000574314360276512020143 0ustar cammcamm not (Type Specifier) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.19 not [Type Specifier]

Compound Type Specifier Kind::

Combining.

Compound Type Specifier Syntax::

(not{typespec})

Compound Type Specifier Arguments::

typespec—a type specifier.

Compound Type Specifier Description::

This denotes the set of all objects that are not of the type typespec.

The argument is required, and cannot be *.

The symbol not is not valid as a type specifier.

gcl-2.6.14/info/gcl/keyword.html0000644000175000017500000000545014360276512015051 0ustar cammcamm keyword (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.2 keyword [Type]

Supertypes::

keyword, symbol, t

Description::

The type keyword includes all symbols interned the KEYWORD package.

Interning a symbol in the KEYWORD package has three automatic effects:

1.

It causes the symbol to become bound to itself.

2.

It causes the symbol to become an external symbol of the KEYWORD package.

3.

It causes the symbol to become a constant variable.

See Also::

keywordp

gcl-2.6.14/info/gcl/ratio.html0000644000175000017500000000534114360276512014502 0ustar cammcamm ratio (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.7 ratio [System Class]

Class Precedence List::

ratio, rational,

real,

number, t

Description::

A ratio is a number representing the mathematical ratio of two non-zero integers, the numerator and denominator, whose greatest common divisor is one, and of which the denominator is positive and greater than one.

See Also::

Figure~2–9, Constructing Numbers from Tokens, Printing Ratios

gcl-2.6.14/info/gcl/list-_0028Function_0029.html0000644000175000017500000001101114360276512017234 0ustar cammcamm list (Function) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.15 list, list* [Function]

list &rest objects ⇒ list

list* &rest objects^+ ⇒ result

Arguments and Values::

object—an object.

list—a list.

result—an object.

Description::

list returns a list containing the supplied objects.

list* is like list except that the last argument to list becomes the car of the last cons constructed, while the last argument to list* becomes the cdr of the last cons constructed. Hence, any given call to list* always produces one fewer conses than a call to list with the same number of arguments.

If the last argument to list* is a list, the effect is to construct a new list which is similar, but which has additional elements added to the front corresponding to the preceding arguments of list*.

If list* receives only one object, that object is returned, regardless of whether or not it is a list.

Examples::

 (list 1) ⇒  (1)
 (list* 1) ⇒  1
 (setq a 1) ⇒  1
 (list a 2) ⇒  (1 2)
 '(a 2) ⇒  (A 2)
 (list 'a 2) ⇒  (A 2)
 (list* a 2) ⇒  (1 . 2)
 (list) ⇒  NIL ;i.e., ()
 (setq a '(1 2)) ⇒  (1 2)
 (eq a (list* a)) ⇒  true
 (list 3 4 'a (car '(b . c)) (+ 6 -2)) ⇒  (3 4 A B 4)
 (list* 'a 'b 'c 'd) ≡ (cons 'a (cons 'b (cons 'c 'd))) ⇒  (A B C . D)
 (list* 'a 'b 'c '(d e f)) ⇒  (A B C D E F)

See Also::

cons

Notes::

 (list* x) ≡ x

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Sharpsign-B.html0000644000175000017500000000430214360276512015475 0ustar cammcamm Sharpsign B (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.8 Sharpsign B

#Brational reads rational in binary (radix 2). For example, 

 #B1101 ≡ 13 ;1101_2
 #b101/11 ≡ 5/3

The consequences are undefined if the token immediately following the #B does not have the syntax of a binary (i.e., radix 2) rational.

gcl-2.6.14/info/gcl/read_002ddelimited_002dlist.html0000644000175000017500000001630714360276512020332 0ustar cammcamm read-delimited-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.5 read-delimited-list [Function]

read-delimited-list char &optional input-stream recursive-p ⇒ list

Arguments and Values::

char—a character.

input-stream—an input stream designator. The default is standard input.

recursive-p—a generalized boolean. The default is false.

list—a list of the objects read.

Description::

read-delimited-list reads objects from input-stream until the next character after an object’s representation (ignoring whitespace_2 characters and comments) is char.

read-delimited-list looks ahead at each step for the next non-whitespace_2 character and peeks at it as if with peek-char. If it is char, then the character is consumed and the list of objects is returned. If it is a constituent or escape character, then read is used to read an object, which is added to the end of the list. If it is a macro character, its reader macro function is called; if the function returns a value, that value is added to the list. The peek-ahead process is then repeated.

If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function.

It is an error to reach end-of-file during the operation of read-delimited-list.

The consequences are undefined if char has a syntax type of whitespace_2 in the current readtable.

Examples::

 (read-delimited-list #\]) 1 2 3 4 5 6 ]
⇒  (1 2 3 4 5 6)

Suppose you wanted #{a b c ... z} to read as a list of all pairs of the elements a, b, c, ..., z, for example. 

 #{p q z a}  reads as  ((p q) (p z) (p a) (q z) (q a) (z a))

This can be done by specifying a macro-character definition for #{ that does two things: reads in all the items up to the }, and constructs the pairs. read-delimited-list performs the first task. 

 (defun |#{-reader| (stream char arg)
   (declare (ignore char arg))
   (mapcon #'(lambda (x)
              (mapcar #'(lambda (y) (list (car x) y)) (cdr x)))
          (read-delimited-list #\} stream t))) ⇒  |#{-reader|

 (set-dispatch-macro-character #\# #\{ #'|#{-reader|) ⇒  T 
 (set-macro-character #\} (get-macro-character #\) nil))

Note that true is supplied for the recursive-p argument.

It is necessary here to give a definition to the character } as well to prevent it from being a constituent. If the line 

 (set-macro-character #\} (get-macro-character #\) nil))

shown above were not included, then the } in 

 #{ p q z a}

would be considered a constituent character, part of the symbol named a}. This could be corrected by putting a space before the }, but it is better to call set-macro-character.

Giving } the same definition as the standard definition of the character ) has the twin benefit of making it terminate tokens for use with read-delimited-list and also making it invalid for use in any other context. Attempting to read a stray } will signal an error.

Affected By::

*standard-input*, *readtable*, *terminal-io*.

See Also::

read , peek-char , read-char , unread-char .

Notes::

read-delimited-list is intended for use in implementing reader macros. Usually it is desirable for char to be a terminating macro character so that it can be used to delimit tokens; however, read-delimited-list makes no attempt to alter the syntax specified for char by the current readtable. The caller must make any necessary changes to the readtable syntax explicitly.

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/macroexpand.html0000644000175000017500000002064214360276512015666 0ustar cammcamm macroexpand (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.12 macroexpand, macroexpand-1 [Function]

macroexpand form &optional env ⇒ expansion, expanded-p

macroexpand- 1 ⇒ form &optional env expansion, expanded-p

Arguments and Values::

form—a form.

env—an environment object. The default is nil.

expansion—a form.

expanded-p—a generalized boolean.

Description::

macroexpand and macroexpand-1 expand macros.

If form is a macro form, then macroexpand-1 expands the macro form call once.

macroexpand repeatedly expands form until it is no longer a macro form. In effect, macroexpand calls macroexpand-1 repeatedly until the secondary value it returns is nil.

If form is a macro form, then the expansion is a macro expansion and expanded-p is true. Otherwise, the expansion is the given form and expanded-p is false.

Macro expansion is carried out as follows. Once macroexpand-1 has determined that the form is a macro form, it obtains an appropriate expansion function for the macro or symbol macro. The value of *macroexpand-hook* is

coerced to a function and

then called as a function of three arguments: the expansion function, the form, and the env. The value returned from this call is taken to be the expansion of the form.

In addition to macro definitions in the global environment, any local macro definitions established within env by macrolet or symbol-macrolet are considered. If only form is supplied as an argument, then the environment is effectively null, and only global macro definitions as established by defmacro are considered. Macro definitions are shadowed by local function definitions.

Examples::

 (defmacro alpha (x y) `(beta ,x ,y)) ⇒  ALPHA
 (defmacro beta (x y) `(gamma ,x ,y)) ⇒  BETA
 (defmacro delta (x y) `(gamma ,x ,y)) ⇒  EPSILON
 (defmacro expand (form &environment env)
   (multiple-value-bind (expansion expanded-p)
       (macroexpand form env)
     `(values ',expansion ',expanded-p))) ⇒  EXPAND
 (defmacro expand-1 (form &environment env)
   (multiple-value-bind (expansion expanded-p)
       (macroexpand-1 form env)
     `(values ',expansion ',expanded-p))) ⇒  EXPAND-1

;; Simple examples involving just the global environment
 (macroexpand-1 '(alpha a b)) ⇒  (BETA A B), true
 (expand-1 (alpha a b)) ⇒  (BETA A B), true
 (macroexpand '(alpha a b)) ⇒  (GAMMA A B), true
 (expand (alpha a b)) ⇒  (GAMMA A B), true
 (macroexpand-1 'not-a-macro) ⇒  NOT-A-MACRO, false
 (expand-1 not-a-macro) ⇒  NOT-A-MACRO, false
 (macroexpand '(not-a-macro a b)) ⇒  (NOT-A-MACRO A B), false
 (expand (not-a-macro a b)) ⇒  (NOT-A-MACRO A B), false

;; Examples involving lexical environments
 (macrolet ((alpha (x y) `(delta ,x ,y)))
   (macroexpand-1 '(alpha a b))) ⇒  (BETA A B), true
 (macrolet ((alpha (x y) `(delta ,x ,y)))
   (expand-1 (alpha a b))) ⇒  (DELTA A B), true
 (macrolet ((alpha (x y) `(delta ,x ,y)))
   (macroexpand '(alpha a b))) ⇒  (GAMMA A B), true
 (macrolet ((alpha (x y) `(delta ,x ,y)))
   (expand (alpha a b))) ⇒  (GAMMA A B), true
 (macrolet ((beta (x y) `(epsilon ,x ,y)))
   (expand (alpha a b))) ⇒  (EPSILON A B), true
 (let ((x (list 1 2 3)))
   (symbol-macrolet ((a (first x)))
     (expand a))) ⇒  (FIRST X), true
 (let ((x (list 1 2 3)))
   (symbol-macrolet ((a (first x)))
     (macroexpand 'a))) ⇒  A, false
 (symbol-macrolet ((b (alpha x y)))
   (expand-1 b)) ⇒  (ALPHA X Y), true
 (symbol-macrolet ((b (alpha x y)))
   (expand b)) ⇒  (GAMMA X Y), true
 (symbol-macrolet ((b (alpha x y))
                   (a b))
   (expand-1 a)) ⇒  B, true
 (symbol-macrolet ((b (alpha x y))
                   (a b))
   (expand a)) ⇒  (GAMMA X Y), true

;; Examples of shadowing behavior
 (flet ((beta (x y) (+ x y)))
   (expand (alpha a b))) ⇒  (BETA A B), true
 (macrolet ((alpha (x y) `(delta ,x ,y)))
   (flet ((alpha (x y) (+ x y)))
     (expand (alpha a b)))) ⇒  (ALPHA A B), false
 (let ((x (list 1 2 3)))
   (symbol-macrolet ((a (first x)))
     (let ((a x))
       (expand a)))) ⇒  A, false

Affected By::

defmacro, setf of macro-function, macrolet, symbol-macrolet

See Also::

*macroexpand-hook*, defmacro , setf of macro-function , macrolet, symbol-macrolet , Evaluation

Notes::

Neither macroexpand nor macroexpand-1 makes any explicit attempt to expand macro forms that are either subforms of the form or subforms of the expansion. Such expansion might occur implicitly, however, due to the semantics or implementation of the macro function.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/floating_002dpoint_002dinexact.html0000644000175000017500000000561114360276512021067 0ustar cammcamm floating-point-inexact (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.82 floating-point-inexact [Condition Type]

Class Precedence List::

floating-point-inexact, arithmetic-error, error, serious-condition, condition, t

Description::

The type floating-point-inexact consists of error conditions that occur because of certain floating point traps.

It is implementation-dependent whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being signaled.

gcl-2.6.14/info/gcl/make_002dsynonym_002dstream.html0000644000175000017500000000675214360276512020433 0ustar cammcamm make-synonym-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.38 make-synonym-stream [Function]

make-synonym-stream symbol ⇒ synonym-stream

Arguments and Values::

symbol—a symbol that names a dynamic variable.

synonym-stream—a synonym stream.

Description::

Returns a synonym stream whose synonym stream symbol is symbol.

Examples::

 (setq a-stream (make-string-input-stream "a-stream")
        b-stream (make-string-input-stream "b-stream"))
⇒  #<String Input Stream> 
 (setq s-stream (make-synonym-stream 'c-stream))
⇒  #<SYNONYM-STREAM for C-STREAM> 
 (setq c-stream a-stream)
⇒  #<String Input Stream> 
 (read s-stream) ⇒  A-STREAM
 (setq c-stream b-stream)
⇒  #<String Input Stream> 
 (read s-stream) ⇒  B-STREAM

Exceptional Situations::

Should signal type-error if its argument is not a symbol.

See Also::

Stream Concepts

gcl-2.6.14/info/gcl/The-Consing-Dot.html0000644000175000017500000000463114360276512016227 0ustar cammcamm The Consing Dot (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpretation of Tokens  

2.3.3 The Consing Dot

If a token consists solely of dots (with no escape characters), then an error of type reader-error is signaled, except in one circumstance: if the token is a single dot and appears in a situation where dotted pair notation permits a dot, then it is accepted as part of such syntax and no error is signaled. See Left-Parenthesis.

gcl-2.6.14/info/gcl/Tilde-Right_002dParen_002d_003e-End-of-Case-Conversion.html0000644000175000017500000000460114360276512024567 0ustar cammcamm Tilde Right-Paren-> End of Case Conversion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Miscellaneous Operations  

22.3.8.2 Tilde Right-Paren: End of Case Conversion

~) terminates a ~(. The consequences of using it elsewhere are undefined.

gcl-2.6.14/info/gcl/FORMAT-Basic-Output.html0000644000175000017500000000577614360276512016705 0ustar cammcamm FORMAT Basic Output (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.1 FORMAT Basic Output

• Tilde C-> Character  
• Tilde Percent-> Newline  
• Tilde Ampersand-> Fresh-Line  
• Tilde Vertical-Bar-> Page  
• Tilde Tilde-> Tilde  
gcl-2.6.14/info/gcl/Rule-of-Canonical-Representation-for-Rationals.html0000644000175000017500000000624114360276512024300 0ustar cammcamm Rule of Canonical Representation for Rationals (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Rational Computations  

12.1.3.2 Rule of Canonical Representation for Rationals

If any computation produces a result that is a mathematical ratio of two integers such that the denominator evenly divides the numerator, then the result is converted to the equivalent integer.

If the denominator does not evenly divide the numerator, the canonical representation of a rational number is as the ratio that numerator and that denominator, where the greatest common divisor of the numerator and denominator is one, and where the denominator is positive and greater than one.

When used as input (in the default syntax), the notation -0 always denotes the integer 0. A conforming implementation must not have a representation of “minus zero” for integers that is distinct from its representation of zero for integers. However, such a distinction is possible for floats; see the type float.

gcl-2.6.14/info/gcl/Special-Symbols.html0000644000175000017500000002032614360276512016372 0ustar cammcamm Special Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.6 Special Symbols

The special symbols described here are used as a notational convenience within this document, and are part of neither the Common Lisp language nor its environment.

⇒

This indicates evaluation. For example: 

 (+ 4 5) ⇒  9

This means that the result of evaluating the form (+ 4 5) is 9.

If a form returns multiple values, those values might be shown separated by spaces, line breaks, or commas. For example: 

 (truncate 7 5)
⇒  1 2
 (truncate 7 5) 
⇒  1
   2
 (truncate 7 5)
⇒  1, 2

Each of the above three examples is equivalent, and specifies that (truncate 7 5) returns two values, which are 1 and 2.

Some conforming implementations actually type an arrow (or some other indicator) before showing return values, while others do not.

OR⇒

The notation “OR⇒” is used to denote one of several possible alternate results. The example 

 (char-name #\a)
⇒  NIL
OR⇒ "LOWERCASE-a"
OR⇒ "Small-A"
OR⇒ "LA01"

indicates that nil, "LOWERCASE-a", "Small-A", "LA01" are among the possible results of (char-name #\a)—each with equal preference. Unless explicitly specified otherwise, it should not be assumed that the set of possible results shown is exhaustive. Formally, the above example is equivalent to 

 (char-name #\a) ⇒  implementation-dependent

but it is intended to provide additional information to illustrate some of the ways in which it is permitted for implementations to diverge.

NOT⇒

The notation “NOT⇒” is used to denote a result which is not possible. This might be used, for example, in order to emphasize a situation where some anticipated misconception might lead the reader to falsely believe that the result might be possible. For example, 

 (function-lambda-expression 
    (funcall #'(lambda (x) #'(lambda () x)) nil))
⇒  NIL, true, NIL
OR⇒ (LAMBDA () X), true, NIL
NOT⇒ NIL, false, NIL
NOT⇒ (LAMBDA () X), false, NIL
≡

This indicates code equivalence. For example: 

 (gcd x (gcd y z)) ≡ (gcd (gcd x y) z)

This means that the results and observable side-effects of evaluating the form (gcd x (gcd y z)) are always the same as the results and observable side-effects of (gcd (gcd x y) z) for any x, y, and z.

|>

Common Lisp specifies input and output with respect to a non-interactive stream model. The specific details of how interactive input and output are mapped onto that non-interactive model are implementation-defined.

For example, conforming implementations are permitted to differ in issues of how interactive input is terminated. For example, the function read terminates when the final delimiter is typed on a non-interactive stream. In some implementations, an interactive call to read returns as soon as the final delimiter is typed, even if that delimiter is not a newline. In other implementations, a final newline is always required. In still other implementations, there might be a command which “activates” a buffer full of input without the command itself being visible on the program’s input stream.

In the examples in this document, the notation “ |> ” precedes lines where interactive input and output occurs. Within such a scenario, “|>>this notation<<|” notates user input.

For example, the notation 

 (+ 1 (print (+ (sqrt (read)) (sqrt (read)))))
 |>  |>>9 16 <<|
 |>  7
⇒  8

shows an interaction in which “(+ 1 (print (+ (sqrt (read)) (sqrt (read)))))” is a form to be evaluated, “9 16 ” is interactive input, “7” is interactive output, and “8” is the value yielded from the evaluation.

The use of this notation is intended to disguise small differences in interactive input and output behavior between implementations.

Sometimes, the non-interactive stream model calls for a newline. How that newline character is interactively entered is an implementation-defined detail of the user interface, but in that case, either the notation “<Newline>” or “[<–~]” might be used. 

 (progn (format t "~&Who? ") (read-line))
 |>  Who? |>>Fred, Mary, and Sally [<–~]<<|
⇒  "Fred, Mary, and Sally", false

Next: , Previous: , Up: Notational Conventions  

gcl-2.6.14/info/gcl/Debugging-Utilities.html0000644000175000017500000000471514360276512017234 0ustar cammcamm Debugging Utilities (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The External Environment  

25.1.2 Debugging Utilities

Figure 25–2 shows defined names relating to debugging. 

  *debugger-hook*  documentation    step     
  apropos          dribble          time     
  apropos-list     ed               trace    
  break            inspect          untrace  
  describe         invoke-debugger           

  Figure 25–2: Defined names relating to debugging
gcl-2.6.14/info/gcl/user_002dhomedir_002dpathname.html0000644000175000017500000000741214360276512020703 0ustar cammcamm user-homedir-pathname (ANSI and GNU Common Lisp Document)

Previous: , Up: Environment Dictionary  

25.2.30 user-homedir-pathname [Function]

user-homedir-pathname &optional host ⇒ pathname

Arguments and Values::

host—a string, a list of strings, or :unspecific.

pathname—a pathname, or nil.

Description::

user-homedir-pathname determines the pathname that corresponds to the user’s home directory on host. If host is not supplied, its value is implementation-dependent.

For a description of :unspecific, see Pathname Components.

The definition of home directory is implementation-dependent, but defined in Common Lisp to mean the directory where the user keeps personal files such as initialization files and mail.

user-homedir-pathname returns a pathname without any name, type, or version component (those components are all nil) for the user’s home directory on host.

If it is impossible to determine the user’s home directory on host, then nil is returned. user-homedir-pathname never returns nil if host is not supplied.

Examples::

 (pathnamep (user-homedir-pathname)) ⇒  true

Affected By::

The host computer’s file system, and the implementation.

gcl-2.6.14/info/gcl/Sorting-the-Applicable-Methods-by-Precedence-Order.html0000644000175000017500000001153714360276512024742 0ustar cammcamm Sorting the Applicable Methods by Precedence Order (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Method Selection and Combination  

7.6.6.3 Sorting the Applicable Methods by Precedence Order

To compare the precedence of two methods, their parameter specializers are examined in order. The default examination order is from left to right, but an alternative order may be specified by the :argument-precedence-order option to defgeneric or to any of the other operators that specify generic function options.

The corresponding parameter specializers from each method are compared. When a pair of parameter specializers agree, the next pair are compared for agreement. If all corresponding parameter specializers agree, the two methods must have different qualifiers; in this case, either method can be selected to precede the other. For information about agreement, see Agreement on Parameter Specializers and Qualifiers.

If some corresponding parameter specializers do not agree, the first pair of parameter specializers that do not agree determines the precedence. If both parameter specializers are classes, the more specific of the two methods is the method whose parameter specializer appears earlier in the class precedence list of the corresponding argument. Because of the way in which the set of applicable methods is chosen, the parameter specializers are guaranteed to be present in the class precedence list of the class of the argument.

If just one of a pair of corresponding parameter specializers is (eql object), the method with that parameter specializer precedes the other method. If both parameter specializers are eql expressions, the specializers must agree (otherwise the two methods would not both have been applicable to this argument).

The resulting list of applicable methods has the most specific method first and the least specific method last.

Next: , Previous: , Up: Method Selection and Combination  

gcl-2.6.14/info/gcl/fixnum.html0000644000175000017500000000503114360276512014666 0ustar cammcamm fixnum (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.13 fixnum [Type]

Supertypes::

fixnum, integer, rational,

real,

number, t

Description::

A fixnum is an integer whose value is between most-negative-fixnum and most-positive-fixnum inclusive. Exactly which integers are fixnums is implementation-defined.

The type fixnum is required to be a supertype of (signed-byte 16).

gcl-2.6.14/info/gcl/Default-Print_002dObject-Methods.html0000644000175000017500000001366014360276512021322 0ustar cammcamm Default Print-Object Methods (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Lisp Printer  

22.1.3 Default Print-Object Methods

This section describes the default behavior of print-object methods for the standardized types.

• Printing Numbers  
• Printing Integers  
• Printing Ratios  
• Printing Floats  
• Printing Complexes  
• Note about Printing Numbers  
• Printing Characters  
• Printing Symbols  
• Package Prefixes for Symbols  
• Effect of Readtable Case on the Lisp Printer  
• Examples of Effect of Readtable Case on the Lisp Printer  
• Printing Strings  
• Printing Lists and Conses  
• Printing Bit Vectors  
• Printing Other Vectors  
• Printing Other Arrays  
• Examples of Printing Arrays  
• Printing Random States  
• Printing Pathnames  
• Printing Structures  
• Printing Other Objects  
gcl-2.6.14/info/gcl/symbolp.html0000644000175000017500000000616414360276512015055 0ustar cammcamm symbolp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.3 symbolp [Function]

symbolp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type symbol; otherwise, returns false.

Examples::

 (symbolp 'elephant) ⇒  true
 (symbolp 12) ⇒  false
 (symbolp nil) ⇒  true
 (symbolp '()) ⇒  true
 (symbolp :test) ⇒  true
 (symbolp "hello") ⇒  false

See Also::

keywordp , symbol, typep

Notes::

 (symbolp object) ≡ (typep object 'symbol)
gcl-2.6.14/info/gcl/restart_002dname.html0000644000175000017500000000641514360276512016441 0ustar cammcamm restart-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.38 restart-name [Function]

restart-name restart ⇒ name

Arguments and Values::

restart—a restart.

name—a symbol.

Description::

Returns the name of the restart, or nil if the restart is not named.

Examples::

 (restart-case 
     (loop for restart in (compute-restarts)
               collect (restart-name restart))
   (case1 () :report "Return 1." 1)
   (nil   () :report "Return 2." 2)
   (case3 () :report "Return 3." 3)
   (case1 () :report "Return 4." 4))
⇒  (CASE1 NIL CASE3 CASE1 ABORT)
 ;; In the example above the restart named ABORT was not created
 ;; explicitly, but was implicitly supplied by the system.

See Also::

compute-restarts

find-restart

gcl-2.6.14/info/gcl/Characters-Dictionary.html0000644000175000017500000001251114360276512017543 0ustar cammcamm Characters Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Characters  

13.2 Characters Dictionary

• character (System Class)  
• base-char  
• standard-char  
• extended-char  
• char=  
• character  
• characterp  
• alpha-char-p  
• alphanumericp  
• digit-char  
• digit-char-p  
• graphic-char-p  
• standard-char-p  
• char-upcase  
• upper-case-p  
• char-code  
• char-int  
• code-char  
• char-code-limit  
• char-name  
• name-char  
gcl-2.6.14/info/gcl/VALUES-Forms-as-Places.html0000644000175000017500000000632014360276512017253 0ustar cammcamm VALUES Forms as Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.3 VALUES Forms as Places

A values form can be used as a place, provided that each of its subforms is also a place form.

A form such as

(setf (values place-1 \dots place-n) values-form)

does the following:

1.

The subforms of each nested place are evaluated in left-to-right order.

2.

The values-form is evaluated, and the first store variable from each place is bound to its return values as if by multiple-value-bind.

3.

If the setf expansion for any place involves more than one store variable, then the additional store variables are bound to nil.

4.

The storing forms for each place are evaluated in left-to-right order.

The storing form in the setf expansion of values returns as multiple values_2 the values of the store variables in step 2. That is, the number of values returned is the same as the number of place forms. This may be more or fewer values than are produced by the values-form.

gcl-2.6.14/info/gcl/characterp.html0000644000175000017500000000653614360276512015507 0ustar cammcamm characterp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.7 characterp [Function]

characterp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type character; otherwise, returns false.

Examples::

 (characterp #\a) ⇒  true
 (characterp 'a) ⇒  false
 (characterp "a") ⇒  false
 (characterp 65.) ⇒  false
 (characterp #\Newline) ⇒  true
 ;; This next example presupposes an implementation 
 ;; in which #\Rubout is an implementation-defined character.
 (characterp #\Rubout) ⇒  true

See Also::

character (type and function), typep

Notes::

 (characterp object) ≡ (typep object 'character)
gcl-2.6.14/info/gcl/Formatted-Output.html0000644000175000017500000002302714360276512016610 0ustar cammcamm Formatted Output (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer  

22.3 Formatted Output

[Editorial Note by KMP: This is transplanted from FORMAT and will need a bit of work before it looks good standing alone. Bear with me.]

format is useful for producing nicely formatted text, producing good-looking messages, and so on. format can generate and return a string or output to destination.

The control-string argument to format is actually a format control. That is, it can be either a format string or a function, for example a function returned by the formatter macro.

If it is a function, the function is called with the appropriate output stream as its first argument and the data arguments to format as its remaining arguments. The function should perform whatever output is necessary and return the unused tail of the arguments (if any).

The compilation process performed by formatter produces a function that would do with its arguments as the format interpreter would do with those arguments.

The remainder of this section describes what happens if the control-string is a format string.

Control-string is composed of simple text (characters) and embedded directives.

format writes the simple text as is; each embedded directive specifies further text output that is to appear at the corresponding point within the simple text. Most directives use one or more elements of args to create their output.

A directive consists of a tilde, optional prefix parameters separated by commas, optional colon and at-sign modifiers, and a single character indicating what kind of directive this is.

There is no required ordering between the at-sign and colon modifier.

The case of the directive character is ignored. Prefix parameters are notated as signed (sign is optional) decimal numbers, or as a single-quote followed by a character. For example, ~5,'0d can be used to print an integer in decimal radix in five columns with leading zeros, or ~5,'*d to get leading asterisks.

In place of a prefix parameter to a directive, V (or v) can be used. In this case, format takes an argument from args as a parameter to the directive. The argument should be an integer or character. If the arg used by a V parameter is nil, the effect is as if the parameter had been omitted. # can be used in place of a prefix parameter; it represents the number of args remaining to be processed. When used within a recursive format, in the context of ~? or ~{, the # prefix parameter represents the number of format arguments remaining within the recursive call.

Examples of format strings: 

  "~S"        ;This is an S directive with no parameters or modifiers.  
  "~3,-4:@s"  ;This is an S directive with two parameters, 3 and -4,    
              ; and both the colon and at-sign flags.                   
  "~,+4S"     ;Here the first prefix parameter is omitted and takes     
              ; on its default value, while the second parameter is 4.  

             Figure 22–5: Examples of format control strings

format sends the output to destination. If destination is nil, format creates and returns a string containing the output from control-string. If destination is non-nil, it must be a string with a fill pointer, a stream, or the symbol t. If destination is a string with a fill pointer, the output is added to the end of the string. If destination is a stream, the output is sent to that stream. If destination is t, the output is sent to standard output.

In the description of the directives that follows, the term arg in general refers to the next item of the set of args to be processed. The word or phrase at the beginning of each description is a mnemonic for the directive.

format directives do not bind any of the printer control variables (*print-...*) except as specified in the following descriptions. Implementations may specify the binding of new, implementation-specific printer control variables for each format directive, but they may neither bind any standard printer control variables not specified in description of a format directive nor fail to bind any standard printer control variables as specified in the description.

• FORMAT Basic Output  
• FORMAT Radix Control  
• FORMAT Floating-Point Printers  
• FORMAT Printer Operations  
• FORMAT Pretty Printer Operations  
• FORMAT Layout Control  
• FORMAT Control-Flow Operations  
• FORMAT Miscellaneous Operations  
• FORMAT Miscellaneous Pseudo-Operations  
• Additional Information about FORMAT Operations  
• Examples of FORMAT  
• Notes about FORMAT  

Next: , Previous: , Up: Printer  

gcl-2.6.14/info/gcl/equalp.html0000644000175000017500000001734614360276512014663 0ustar cammcamm equalp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.36 equalp [Function]

equalp x y ⇒ generalized-boolean

Arguments and Values::

x—an object.

y—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if x and y are equal, or if they have components that are of the same type as each other and if those components are equalp; specifically, equalp returns true in the following cases:

Characters

If two characters are char-equal.

Numbers

If two numbers are the same under =.

Conses

If the two cars in the conses are equalp and the two cdrs in the conses are equalp.

Arrays

If two arrays have the same number of dimensions, the dimensions match, and the corresponding active elements are equalp. The types for which the arrays are specialized need not match; for example, a string and a general array that happens to contain the same characters are equalp. Because equalp performs element-by-element comparisons of strings and ignores the case of characters, case distinctions are ignored when equalp compares strings.

Structures

If two structures S_1 and S_2 have the same class and the value of each slot in S_1 is the same under equalp as the value of the corresponding slot in S_2.

Hash Tables

equalp descends hash-tables by first comparing the count of entries and the :test function; if those are the same, it compares the keys of the tables using the :test function and then the values of the matching keys using equalp recursively.

equalp does not descend any objects other than the ones explicitly specified above. Figure 5–13 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of equalp, with upper entries taking priority over lower ones. 

  Type          Behavior                      
  number        uses =                        
  character     uses char-equal               
  cons          descends                      
  bit vector    descends                      
  string        descends                      
  pathname      same as equal                 
  structure     descends, as described above  
  Other array   descends                      
  hash table    descends, as described above  
  Other object  uses eq                       

  Figure 5–13: Summary and priorities of behavior of equalp

Examples::

 (equalp 'a 'b) ⇒  false
 (equalp 'a 'a) ⇒  true
 (equalp 3 3) ⇒  true
 (equalp 3 3.0) ⇒  true
 (equalp 3.0 3.0) ⇒  true
 (equalp #c(3 -4) #c(3 -4)) ⇒  true
 (equalp #c(3 -4.0) #c(3 -4)) ⇒  true
 (equalp (cons 'a 'b) (cons 'a 'c)) ⇒  false
 (equalp (cons 'a 'b) (cons 'a 'b)) ⇒  true
 (equalp #\A #\A) ⇒  true
 (equalp #\A #\a) ⇒  true
 (equalp "Foo" "Foo") ⇒  true
 (equalp "Foo" (copy-seq "Foo")) ⇒  true
 (equalp "FOO" "foo") ⇒  true

 (setq array1 (make-array 6 :element-type 'integer
                            :initial-contents '(1 1 1 3 5 7))) 
⇒  #(1 1 1 3 5 7)
 (setq array2 (make-array 8 :element-type 'integer
                            :initial-contents '(1 1 1 3 5 7 2 6)
                            :fill-pointer 6))
⇒  #(1 1 1 3 5 7)
 (equalp array1 array2) ⇒  true
 (setq vector1 (vector 1 1 1 3 5 7)) ⇒  #(1 1 1 3 5 7)
 (equalp array1 vector1) ⇒  true

See Also::

eq , eql , equal , = , string= , string-equal, char= , char-equal

Notes::

Object equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, equal and equalp are not appropriate for every application.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Sections-Not-Formally-Part-Of-This-Standard.html0000644000175000017500000000700314360276512023402 0ustar cammcamm Sections Not Formally Part Of This Standard (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Definitions  

1.4.3 Sections Not Formally Part Of This Standard

Front matter and back matter, such as the “Table of Contents,” “Index,” “Figures,” “Credits,” and “Appendix” are not considered formally part of this standard, so that we retain the flexibility needed to update these sections even at the last minute without fear of needing a formal vote to change those parts of the document. These items are quite short and very useful, however, and it is not recommended that they be removed even in an abridged version of this document.

Within the concept sections, subsections whose names begin with the words “Note” or “Notes” or “Example” or “Examples” are provided for illustration purposes only, and are not considered part of the standard.

An attempt has been made to place these sections last in their parent section, so that they could be removed without disturbing the contiguous numbering of the surrounding sections in order to produce a document of smaller size.

Likewise, the “Examples” and “Notes” sections in a dictionary entry are not considered part of the standard and could be removed if necessary.

Nevertheless, the examples provide important clarifications and consistency checks for the rest of the material, and such abridging is not recommended unless absolutely unavoidable.

gcl-2.6.14/info/gcl/pathnamep.html0000644000175000017500000000631414360276512015342 0ustar cammcamm pathnamep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.5 pathnamep [Function]

pathnamep object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type pathname; otherwise, returns false.

Examples::

 (setq q "test")  ⇒  "test"
 (pathnamep q) ⇒  false
 (setq q (pathname "test"))
⇒  #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL
       :VERSION NIL)
 (pathnamep q) ⇒  true 
 (setq q (logical-pathname "SYS:SITE;FOO.SYSTEM"))
⇒  #P"SYS:SITE;FOO.SYSTEM"
 (pathnamep q) ⇒  true

Notes::

 (pathnamep object) ≡ (typep object 'pathname)
gcl-2.6.14/info/gcl/_002aprint_002dlines_002a.html0000644000175000017500000000745214360276512017551 0ustar cammcamm *print-lines* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.23 *print-lines* [Variable]

Value Type::

a non-negative integer, or nil.

Initial Value::

nil.

Description::

When the value of *print-lines* is other than nil, it is a limit on the number of output lines produced when something is pretty printed. If an attempt is made to go beyond that many lines, “..” is printed at the end of the last line followed by all of the suffixes (closing delimiters) that are pending to be printed.

Examples::

 (let ((*print-right-margin* 25) (*print-lines* 3))
   (pprint '(progn (setq a 1 b 2 c 3 d 4))))
 |>  (PROGN (SETQ A 1
 |>               B 2
 |>               C 3 ..))
⇒  <no values>

Notes::

The “..” notation is intentionally different than the “...” notation used for level abbreviation, so that the two different situations can be visually distinguished.

This notation is used to increase the likelihood that the Lisp reader will signal an error if an attempt is later made to read the abbreviated output. Note however that if the truncation occurs in a string, as in "This string has been trunc..", the problem situation cannot be detected later and no such error will be signaled.

gcl-2.6.14/info/gcl/Tilde-C_002d_003e-Character.html0000644000175000017500000001105214360276512017747 0ustar cammcamm Tilde C-> Character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Basic Output  

22.3.1.1 Tilde C: Character

The next arg should be a character; it is printed according to the modifier flags.

~C prints the character as if by using write-char if it is a simple character. Characters that are not simple are not necessarily printed as if by write-char, but are displayed in an implementation-defined, abbreviated format. For example, 

 (format nil "~C" #\A) ⇒  "A"
 (format nil "~C" #\Space) ⇒  " "

~:C is the same as ~C for printing characters, but other characters are “spelled out.” The intent is that this is a “pretty” format for printing characters. For simple characters that are not printing, what is spelled out is the name of the character (see char-name). For characters that are not simple and not printing, what is spelled out is implementation-defined. For example, 

 (format nil "~:C" #\A) ⇒  "A"
 (format nil "~:C" #\Space) ⇒  "Space"
;; This next example assumes an implementation-defined "Control" attribute.
 (format nil "~:C" #\Control-Space)
⇒  "Control-Space"
OR⇒ "c-Space"

~:@C prints what ~:C would, and then if the character requires unusual shift keys on the keyboard to type it, this fact is mentioned. For example, 

 (format nil "~:@C" #\Control-Partial) ⇒  "Control-\partial (Top-F)"

This is the format used for telling the user about a key he is expected to type, in prompts, for instance. The precise output may depend not only on the implementation, but on the particular I/O devices in use.

~@C prints the character in a way that the Lisp reader can understand, using #\ syntax.

~@C binds *print-escape* to t.

Next: , Previous: , Up: FORMAT Basic Output  

gcl-2.6.14/info/gcl/Syntax-of-an-Integer.html0000644000175000017500000000503014360276512017236 0ustar cammcamm Syntax of an Integer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Constructing Numbers from Tokens  

2.3.2.2 Syntax of an Integer

Integers can be written as a sequence of digits, optionally preceded by a sign and optionally followed by a decimal point; see Figure~2–9. When a decimal point is used, the digits are taken to be in radix 10; when no decimal point is used, the digits are taken to be in radix given by the current input base.

For information on how integers are printed, see Printing Integers.

gcl-2.6.14/info/gcl/file_002dposition.html0000644000175000017500000001566014360276512016622 0ustar cammcamm file-position (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.27 file-position [Function]

file-position stream ⇒ position

file-position stream position-spec ⇒ success-p

Arguments and Values::

stream—a stream.

position-spec—a file position designator.

position—a file position or nil.

success-p—a generalized boolean.

Description::

Returns or changes the current position within a stream.

When position-spec is not supplied, file-position returns the current file position in the stream, or nil if this cannot be determined.

When position-spec is supplied, the file position in stream is set to that file position (if possible). file-position returns true if the repositioning is performed successfully, or false if it is not.

An integer returned by file-position of one argument should be acceptable as position-spec for use with the same file.

For a character file, performing a single read-char or write-char operation may cause the file position to be increased by more than 1 because of character-set translations (such as translating between the Common Lisp #\Newline character and an external ASCII carriage-return/line-feed sequence) and other aspects of the implementation. For a binary file, every read-byte or write-byte operation increases the file position by 1.

Examples::

 (defun tester ()
   (let ((noticed '()) file-written)
     (flet ((notice (x) (push x noticed) x))
       (with-open-file (s "test.bin" 
                          :element-type '(unsigned-byte 8)
                          :direction :output
                          :if-exists :error)
          (notice (file-position s)) ;1
          (write-byte 5 s) 
          (write-byte 6 s)
          (let ((p (file-position s)))
            (notice p) ;2
            (notice (when p (file-position s (1- p))))) ;3
          (write-byte 7 s)
          (notice (file-position s)) ;4
          (setq file-written (truename s)))
        (with-open-file (s file-written
                           :element-type '(unsigned-byte 8)
                           :direction :input)
          (notice (file-position s)) ;5
          (let ((length (file-length s)))
            (notice length) ;6
            (when length
              (dotimes (i length)
                (notice (read-byte s)))))) ;7,...
        (nreverse noticed))))
⇒  tester
 (tester)
⇒  (0 2 T 2 0 2 5 7)
OR⇒ (0 2 NIL 3 0 3 5 6 7)
OR⇒ (NIL NIL NIL NIL NIL NIL)

Side Effects::

When the position-spec argument is supplied, the file position in the stream might be moved.

Affected By::

The value returned by file-position increases monotonically as input or output operations are performed.

Exceptional Situations::

If position-spec is supplied, but is too large or otherwise inappropriate, an error is signaled.

See Also::

file-length , file-string-length , open

Notes::

Implementations that have character files represented as a sequence of records of bounded size might choose to encode the file position as, for example, <<record-number>>*<<max-record-size>>+<<character-within-record>>. This is a valid encoding because it increases monotonically as each character is read or written, though not necessarily by 1 at each step. An integer might then be considered “inappropriate” as position-spec to file-position if, when decoded into record number and character number, it turned out that the supplied record was too short for the specified character number.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/System-Construction-Dictionary.html0000644000175000017500000000765114360276512021451 0ustar cammcamm System Construction Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: System Construction  

24.2 System Construction Dictionary

• compile-file  
• compile-file-pathname  
• load  
• with-compilation-unit  
• *features*  
• *compile-file-pathname*  
• *load-pathname*  
• *compile-print*  
• *load-print*  
• *modules*  
• provide  
gcl-2.6.14/info/gcl/do.html0000644000175000017500000003225414360276512013771 0ustar cammcamm do (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Iteration Dictionary  

6.2.1 do, do* [Macro]

do ({var | (var [init-form [step-form]])}*) (end-test-form {result-form}*) {declaration}* {tag | statement}*
⇒ {result}*

do* ({var | (var [init-form [step-form]])}*) (end-test-form {result-form}*) {declaration}* {tag | statement}*
⇒ {result}*

Arguments and Values::

var—a symbol.

init-form—a form.

step-form—a form.

end-test-form—a form.

result-forms—an implicit progn.

declaration—a declare expression; not evaluated.

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

results—if a return or return-from form is executed, the values passed from that form; otherwise, the values returned by the result-forms.

Description::

do iterates over a group of statements while a test condition holds. do accepts an arbitrary number of iteration vars which are bound within the iteration and stepped in parallel. An initial value may be supplied for each iteration variable by use of an init-form. Step-forms may be used to specify how the vars should be updated on succeeding iterations through the loop. Step-forms may be used both to generate successive values or to accumulate results. If the end-test-form condition is met prior to an execution of the body, the iteration terminates. Tags label statements.

do* is exactly like do except that the bindings and steppings of the vars are performed sequentially rather than in parallel.

Before the first iteration, all the init-forms are evaluated, and each var is bound to the value of its respective init-form, if supplied. This is a binding, not an assignment; when the loop terminates, the old values of those variables will be restored. For do, all of the init-forms are evaluated before any var is bound. The init-forms can refer to the bindings of the vars visible before beginning execution of do. For do*, the first init-form is evaluated, then the first var is bound to that value, then the second init-form is evaluated, then the second var is bound, and so on; in general, the kth init-form can refer to the new binding of the jth var if j < k, and otherwise to the old binding of the jth var.

At the beginning of each iteration, after processing the variables, the end-test-form is evaluated. If the result is false, execution proceeds with the body of the do (or do*) form. If the result is true, the result-forms are evaluated in order as an implicit progn, and then do or do* returns.

At the beginning of each iteration other than the first, vars are updated as follows. All the step-forms, if supplied, are evaluated, from left to right, and the resulting values are assigned to the respective vars. Any var that has no associated step-form is not assigned to. For do, all the step-forms are evaluated before any var is updated; the assignment of values to vars is done in parallel, as if by psetq. Because all of the step-forms are evaluated before any of the vars are altered, a step-form when evaluated always has access to the old values of all the vars, even if other step-forms precede it. For do*, the first step-form is evaluated, then the value is assigned to the first var, then the second step-form is evaluated, then the value is assigned to the second var, and so on; the assignment of values to variables is done sequentially, as if by setq. For either do or do*, after the vars have been updated, the end-test-form is evaluated as described above, and the iteration continues.

The remainder of the do (or do*) form constitutes an implicit tagbody. Tags may appear within the body of a do loop for use by go statements appearing in the body (but such go statements may not appear in the variable specifiers, the end-test-form, or the result-forms). When the end of a do body is reached, the next iteration cycle (beginning with the evaluation of step-forms) occurs.

An implicit block named nil surrounds the entire do (or do*) form. A return statement may be used at any point to exit the loop immediately.

Init-form is an initial value for the var with which it is associated. If init-form is omitted, the initial value of var is nil. If a declaration is supplied for a var, init-form must be consistent with the declaration.

Declarations can appear at the beginning of a do (or do*) body. They apply to code in the do (or do*) body, to the bindings of the do (or do*) vars, to the step-forms, to the end-test-form, and to the result-forms.

Examples::

 (do ((temp-one 1 (1+ temp-one))
       (temp-two 0 (1- temp-two)))
      ((> (- temp-one temp-two) 5) temp-one)) ⇒  4

 (do ((temp-one 1 (1+ temp-one))
       (temp-two 0 (1+ temp-one)))     
      ((= 3 temp-two) temp-one)) ⇒  3

 (do* ((temp-one 1 (1+ temp-one))
        (temp-two 0 (1+ temp-one)))
       ((= 3 temp-two) temp-one)) ⇒  2                     

 (do ((j 0 (+ j 1)))
     (nil)                       ;Do forever.
   (format t "~
   (let ((item (read)))
     (if (null item) (return)   ;Process items until NIL seen.
         (format t "~&Output ~D: ~S" j item))))
 |>  Input 0: |>>banana<<|
 |>  Output 0: BANANA
 |>  Input 1: |>>(57 boxes)<<|
 |>  Output 1: (57 BOXES)
 |>  Input 2: |>>NIL<<|
⇒  NIL

 (setq a-vector (vector 1 nil 3 nil))
 (do ((i 0 (+ i 1))     ;Sets every null element of a-vector to zero.
      (n (array-dimension a-vector 0)))
     ((= i n))
   (when (null (aref a-vector i))
     (setf (aref a-vector i) 0))) ⇒  NIL
a-vector ⇒  #(1 0 3 0)

 (do ((x e (cdr x))
      (oldx x x))
     ((null x))
   body)

is an example of parallel assignment to index variables. On the first iteration, the value of oldx is whatever value x had before the do was entered. On succeeding iterations, oldx contains the value that x had on the previous iteration. 

 (do ((x foo (cdr x))
      (y bar (cdr y))
      (z '() (cons (f (car x) (car y)) z)))
     ((or (null x) (null y))
      (nreverse z)))

does the same thing as (mapcar #'f foo bar). The step computation for z is an example of the fact that variables are stepped in parallel. Also, the body of the loop is empty. 

 (defun list-reverse (list)
        (do ((x list (cdr x))
             (y '() (cons (car x) y)))
            ((endp x) y)))

As an example of nested iterations, consider a data structure that is a list of conses. The car of each cons is a list of symbols, and the cdr of each cons is a list of equal length containing corresponding values. Such a data structure is similar to an association list, but is divided into “frames”; the overall structure resembles a rib-cage. A lookup function on such a data structure might be: 

 (defun ribcage-lookup (sym ribcage)           
        (do ((r ribcage (cdr r)))
            ((null r) nil)
          (do ((s (caar r) (cdr s))
               (v (cdar r) (cdr v))) 
              ((null s))
            (when (eq (car s) sym)
              (return-from ribcage-lookup (car v)))))) ⇒  RIBCAGE-LOOKUP

See Also::

other iteration functions ( dolist , dotimes , and loop ) and more primitive functionality ( tagbody , go , block , return ,

let , and setq )

Notes::

If end-test-form is nil, the test will never succeed. This provides an idiom for “do forever”: the body of the do or do* is executed repeatedly. The infinite loop can be terminated by the use of return, return-from, go to an outer level, or throw.

A do form may be explained in terms of the more primitive forms block, return, let, loop, tagbody, and psetq as follows: 

 (block nil        
   (let ((var1 init1)
         (var2 init2)
         ...
         (varn initn))
     declarations
     (loop (when end-test (return (progn . result)))
           (tagbody . tagbody)
           (psetq var1 step1
                  var2 step2
                  ...
                  varn stepn))))

do* is similar, except that let* and setq replace the let and psetq, respectively.

Next: , Previous: , Up: Iteration Dictionary  

gcl-2.6.14/info/gcl/load_002dlogical_002dpathname_002dtranslations.html0000644000175000017500000001071214360276512024013 0ustar cammcamm load-logical-pathname-translations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.7 load-logical-pathname-translations [Function]

load-logical-pathname-translations host ⇒ just-loaded

Arguments and Values::

host—a string.

just-loaded—a generalized boolean.

Description::

Searches for and loads the definition of a logical host named host, if it is not already defined. The specific nature of the search is implementation-defined.

If the host is already defined, no attempt to find or load a definition is attempted, and false is returned. If the host is not already defined, but a definition is successfully found and loaded, true is returned. Otherwise, an error is signaled.

Examples::

 (translate-logical-pathname "hacks:weather;barometer.lisp.newest")
 |>  Error: The logical host HACKS is not defined.
 (load-logical-pathname-translations "HACKS")
 |>  ;; Loading SYS:SITE;HACKS.TRANSLATIONS
 |>  ;; Loading done.
⇒  true
 (translate-logical-pathname "hacks:weather;barometer.lisp.newest")
⇒  #P"HELIUM:[SHARED.HACKS.WEATHER]BAROMETER.LSP;0"
 (load-logical-pathname-translations "HACKS")
⇒  false

Exceptional Situations::

If no definition is found, an error of type error is signaled.

See Also::

logical-pathname

Notes::

Logical pathname definitions will be created not just by implementors but also by programmers. As such, it is important that the search strategy be documented. For example, an implementation might define that the definition of a host is to be found in a file called “host.translations” in some specifically named directory.

gcl-2.6.14/info/gcl/Dynamic-Control-of-the-Lisp-Reader.html0000644000175000017500000000453514360276512021657 0ustar cammcamm Dynamic Control of the Lisp Reader (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Concepts  

23.1.1 Dynamic Control of the Lisp Reader

Various aspects of the Lisp reader can be controlled dynamically. See Readtables and Variables that affect the Lisp Reader.

gcl-2.6.14/info/gcl/the.html0000644000175000017500000001252414360276512014145 0ustar cammcamm the (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.28 the [Special Operator]

the value-type form ⇒ {result}*

Arguments and Values::

value-type—a type specifier; not evaluated.

form—a form; evaluated.

results—the values resulting from the evaluation of form. These values must conform to the type supplied by value-type; see below.

Description::

the specifies that the values_{1a} returned by form are of the types specified by value-type. The consequences are undefined if any result is not of the declared type.

It is permissible for form to yield a different number of values than are specified by value-type, provided that the values for which types are declared are indeed of those types. Missing values are treated as nil for the purposes of checking their types.

Regardless of number of values declared by value-type, the number of values returned by the the special form is the same as the number of values returned by form.

Examples::

 (the symbol (car (list (gensym)))) ⇒  #:G9876
 (the fixnum (+ 5 7)) ⇒  12
 (the (values) (truncate 3.2 2)) ⇒  1, 1.2
 (the integer (truncate 3.2 2)) ⇒  1, 1.2
 (the (values integer) (truncate 3.2 2)) ⇒  1, 1.2
 (the (values integer float) (truncate 3.2 2))   ⇒  1, 1.2
 (the (values integer float symbol) (truncate 3.2 2)) ⇒  1, 1.2
 (the (values integer float symbol t null list) 
      (truncate 3.2 2)) ⇒  1, 1.2
 (let ((i 100))
    (declare (fixnum i))
    (the fixnum (1+ i))) ⇒  101
 (let* ((x (list 'a 'b 'c))
        (y 5))
    (setf (the fixnum (car x)) y)
    x) ⇒  (5 B C)

Exceptional Situations::

The consequences are undefined if the values yielded by the form are not of the type specified by value-type.

See Also::

values

Notes::

The values type specifier can be used to indicate the types of multiple values: 

 (the (values integer integer) (floor x y))
 (the (values string t)
      (gethash the-key the-string-table))

setf can be used with the type declarations. In this case the declaration is transferred to the form that specifies the new value. The resulting setf form is then analyzed.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/setf-class_002dname.html0000644000175000017500000000567614360276512017031 0ustar cammcamm setf class-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.38 setf class-name [Standard Generic Function]

Syntax::

setf class-name new-value class ⇒ new-value

Method Signatures::

setf class-name new-value (class class)

Arguments and Values::

new-value—a symbol.

class—a class.

Description::

The generic function setf class-name sets the name of a class object.

See Also::

find-class , proper name, Classes

gcl-2.6.14/info/gcl/Conses.html0000644000175000017500000000423414360276512014616 0ustar cammcamm Conses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

14 Conses

• Cons Concepts  
• Conses Dictionary  
gcl-2.6.14/info/gcl/Universal-Time.html0000644000175000017500000000577214360276512016240 0ustar cammcamm Universal Time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Time  

25.1.4.2 Universal Time

Universal time is an absolute time represented as a single non-negative integer—the number of seconds since midnight, January 1, 1900 GMT (ignoring leap seconds). Thus the time 1 is 00:00:01 (that is, 12:00:01 a.m.) on January 1, 1900 GMT. Similarly, the time 2398291201 corresponds to time 00:00:01 on January 1, 1976 GMT. Recall that the year 1900 was not a leap year; for the purposes of Common Lisp, a year is a leap year if and only if its number is divisible by 4, except that years divisible by 100 are not leap years, except that years divisible by 400 are leap years. Therefore the year 2000 will be a leap year. Because universal time must be a non-negative integer, times before the base time of midnight, January 1, 1900 GMT cannot be processed by Common Lisp. 

  decode-universal-time  get-universal-time  
  encode-universal-time                      

  Figure 25–6: Defined names involving time in Universal Time.
gcl-2.6.14/info/gcl/write_002dchar.html0000644000175000017500000000652114360276512016102 0ustar cammcamm write-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.21 write-char [Function]

write-char character &optional output-stream ⇒ character

Arguments and Values::

character—a character.

output-stream – an output stream designator. The default is standard output.

Description::

write-char outputs character to output-stream.

Examples::

 (write-char #\a)
 |>  a
⇒  #\a
 (with-output-to-string (s) 
   (write-char #\a s)
   (write-char #\Space s)
   (write-char #\b s))
⇒  "a b"

Side Effects::

The output-stream is modified.

Affected By::

*standard-output*, *terminal-io*.

See Also::

read-char , write-byte ,

write-sequence

gcl-2.6.14/info/gcl/define_002dsymbol_002dmacro.html0000644000175000017500000001313114360276512020334 0ustar cammcamm define-symbol-macro (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.13 define-symbol-macro [Macro]

define-symbol-macro symbol expansion
⇒ symbol

Arguments and Values::

symbol—a symbol.

expansion—a form.

Description::

Provides a mechanism for globally affecting the macro expansion of the indicated symbol.

Globally establishes an expansion function for the symbol macro named by symbol. The only guaranteed property of an expansion function for a symbol macro is that when it is applied to the form and the environment it returns the correct expansion. (In particular, it is implementation-dependent whether the expansion is conceptually stored in the expansion function, the environment, or both.)

Each global reference to symbol (i.e., not shadowed_2 by a binding for a variable or symbol macro named by the same symbol) is expanded by the normal macro expansion process; see Symbols as Forms. The expansion of a symbol macro is subject to further macro expansion in the same lexical environment as the symbol macro reference, exactly analogous to normal macros.

The consequences are unspecified if a special declaration is made for symbol while in the scope of this definition (i.e., when it is not shadowed_2 by a binding for a variable or symbol macro named by the same symbol).

Any use of setq to set the value of the symbol while in the scope of this definition is treated as if it were a setf. psetq of symbol is treated as if it were a psetf, and multiple-value-setq is treated as if it were a setf of values.

A binding for a symbol macro can be shadowed_2 by let or symbol-macrolet.

Examples::

(defvar *things* (list 'alpha 'beta 'gamma)) ⇒  *THINGS*

(define-symbol-macro thing1 (first *things*)) ⇒  THING1
(define-symbol-macro thing2 (second *things*)) ⇒  THING2
(define-symbol-macro thing3 (third *things*)) ⇒  THING3

thing1 ⇒  ALPHA
(setq thing1 'ONE) ⇒  ONE
*things* ⇒  (ONE BETA GAMMA)
(multiple-value-setq (thing2 thing3) (values 'two 'three)) ⇒  TWO
thing3 ⇒  THREE
*things* ⇒  (ONE TWO THREE)

(list thing2 (let ((thing2 2)) thing2)) ⇒  (TWO 2)

Exceptional Situations::

If symbol is already defined as a global variable, an error of type program-error is signaled.

See Also::

symbol-macrolet , macroexpand

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/_002aterminal_002dio_002a.html0000644000175000017500000000767614360276512017535 0ustar cammcamm *terminal-io* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.54 *terminal-io* [Variable]

Value Type::

a bidirectional stream.

Initial Value::

implementation-dependent, but it must be an open stream that is not a generalized synonym stream to an I/O customization variables but that might be a generalized synonym stream to the value of some I/O customization variable.

Description::

The value of *terminal-io*, called terminal I/O, is ordinarily a bidirectional stream that connects to the user’s console. Typically, writing to this stream would cause the output to appear on a display screen, for example, and reading from the stream would accept input from a keyboard. It is intended that standard input functions such as read and read-char, when used with this stream, cause echoing of the input into the output side of the stream. The means by which this is accomplished are implementation-dependent.

The effect of changing the value of *terminal-io*, either by binding or assignment, is implementation-defined.

Examples::

 (progn (prin1 'foo) (prin1 'bar *terminal-io*))
 |>  FOOBAR
⇒  BAR
 (with-output-to-string (*standard-output*)
   (prin1 'foo) 
   (prin1 'bar *terminal-io*))
 |>  BAR
⇒  "FOO"

See Also::

*debug-io*, *error-output*, *query-io*, *standard-input*, *standard-output*, *trace-output*

gcl-2.6.14/info/gcl/parse_002derror.html0000644000175000017500000000515314360276512016276 0ustar cammcamm parse-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.8 parse-error [Condition Type]

Class Precedence List::

parse-error, error, serious-condition, condition, t

Description::

The type parse-error consists of error conditions that are related to parsing.

See Also::

parse-namestring , reader-error

gcl-2.6.14/info/gcl/hash_002dtable_002dcount.html0000644000175000017500000000766514360276512017655 0ustar cammcamm hash-table-count (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.4 hash-table-count [Function]

hash-table-count hash-table ⇒ count

Arguments and Values::

hash-table—a hash table.

count—a non-negative integer.

Description::

Returns the number of entries in the hash-table. If hash-table has just been created or newly cleared (see clrhash) the entry count is 0.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32115135>
 (hash-table-count table) ⇒  0
 (setf (gethash 57 table) "fifty-seven") ⇒  "fifty-seven"
 (hash-table-count table) ⇒  1
 (dotimes (i 100) (setf (gethash i table) i)) ⇒  NIL
 (hash-table-count table) ⇒  100

Affected By::

clrhash, remhash, setf of gethash

See Also::

hash-table-size

Notes::

The following relationships are functionally correct, although in practice using hash-table-count is probably much faster: 

 (hash-table-count table) ≡
 (loop for value being the hash-values of table count t) ≡
 (let ((total 0))
   (maphash #'(lambda (key value)
                (declare (ignore key value))
                (incf total))
            table)
   total)
gcl-2.6.14/info/gcl/Local-Case-in-Pathname-Components.html0000644000175000017500000000555414360276512021557 0ustar cammcamm Local Case in Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.4 Local Case in Pathname Components

For the functions in Figure~19–2, a value of :local for the :case argument (the default for these functions) indicates that the functions should receive and yield strings in component values as if they were already represented according to the host file system’s convention for case.

If the file system supports both cases, strings given or received as pathname component values under this protocol are to be used exactly as written. If the file system only supports one case, the strings will be translated to that case.

gcl-2.6.14/info/gcl/find_002drestart.html0000644000175000017500000001135214360276512016435 0ustar cammcamm find-restart (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.33 find-restart [Function]

find-restart identifier &optional condition restart

Arguments and Values::

identifier—a non-nil symbol, or a restart.

condition—a condition object, or nil.

restart—a restart or nil.

Description::

find-restart searches for a particular restart in the current dynamic environment.

When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered.

If identifier is a symbol, then the innermost (most recently established) applicable restart with that name is returned. nil is returned if no such restart is found.

If identifier is a currently active restart, then it is returned. Otherwise, nil is returned.

Examples::

 (restart-case
     (let ((r (find-restart 'my-restart)))
       (format t "~S is named ~S" r (restart-name r)))
   (my-restart () nil))
 |>  #<RESTART 32307325> is named MY-RESTART
⇒  NIL
 (find-restart 'my-restart)
⇒  NIL

Affected By::

Existing restarts.

restart-case, restart-bind, with-condition-restarts.

See Also::

compute-restarts

Notes::

 (find-restart identifier)
 ≡ (find identifier (compute-restarts) :key :restart-name)

Although anonymous restarts have a name of nil, the consequences are unspecified if nil is given as an identifier. Occasionally, programmers lament that nil is not permissible as an identifier argument. In most such cases, compute-restarts can probably be used to simulate the desired effect.

gcl-2.6.14/info/gcl/Other-Subclasses-of-Stream.html0000644000175000017500000000703314360276512020405 0ustar cammcamm Other Subclasses of Stream (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction to Streams  

21.1.1.7 Other Subclasses of Stream

The class stream has a number of subclasses defined by this specification. Figure 21–5 shows some information about these subclasses. 

  Class                Related Operators             
  broadcast-stream     make-broadcast-stream         
                       broadcast-stream-streams      
  concatenated-stream  make-concatenated-stream      
                       concatenated-stream-streams   
  echo-stream          make-echo-stream              
                       echo-stream-input-stream      
                       echo-stream-output-stream     
  string-stream        make-string-input-stream      
                       with-input-from-string        
                       make-string-output-stream     
                       with-output-to-string         
                       get-output-stream-string      
  synonym-stream       make-synonym-stream           
                       synonym-stream-symbol         
  two-way-stream       make-two-way-stream           
                       two-way-stream-input-stream   
                       two-way-stream-output-stream  

  Figure 21–5: Defined Names related to Specialized Streams
gcl-2.6.14/info/gcl/set_002dpprint_002ddispatch.html0000644000175000017500000001221414360276512020403 0ustar cammcamm set-pprint-dispatch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.13 set-pprint-dispatch [Function]

set-pprint-dispatch type-specifier function &optional priority table ⇒ nil

Arguments and Values::

type-specifier—a type specifier.

function—a function, a function name, or nil.

priority—a real. The default is 0.

table—a pprint dispatch table. The default is the value of *print-pprint-dispatch*.

Description::

Installs an entry into the pprint dispatch table which is table.

Type-specifier is the key of the entry. The first action of set-pprint-dispatch is to remove any pre-existing entry associated with type-specifier. This guarantees that there will never be two entries associated with the same type specifier in a given pprint dispatch table. Equality of type specifiers is tested by equal.

Two values are associated with each type specifier in a pprint dispatch table: a function and a priority. The function must accept two arguments: the stream to which output is sent and the object to be printed. The function should pretty print the object to the stream. The function can assume that object satisfies the type given by type-specifier. The function must obey *print-readably*. Any values returned by the function are ignored.

Priority is a priority to resolve conflicts when an object matches more than one entry.

It is permissible for function to be nil. In this situation, there will be no type-specifier entry in table after set-pprint-dispatch returns.

Exceptional Situations::

An error is signaled if priority is not a real.

Notes::

Since pprint dispatch tables are often used to control the pretty printing of Lisp code, it is common for the type-specifier to be an expression of the form 

 (cons car-type cdr-type)

This signifies that the corresponding object must be a cons cell whose car matches the type specifier car-type and whose cdr matches the type specifier cdr-type. The cdr-type can be omitted in which case it defaults to t.

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Character-Concepts.html0000644000175000017500000000761314360276512017040 0ustar cammcamm Character Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters  

13.1 Character Concepts

• Introduction to Characters  
• Introduction to Scripts and Repertoires  
• Character Attributes  
• Character Categories  
• Identity of Characters  
• Ordering of Characters  
• Character Names  
• Treatment of Newline during Input and Output  
• Character Encodings  
• Documentation of Implementation-Defined Scripts  
gcl-2.6.14/info/gcl/Shadowing.html0000644000175000017500000001332414360276512015307 0ustar cammcamm Shadowing (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.5 Shadowing

If two forms that establish lexical bindings with the same name N are textually nested, then references to N within the inner form refer to the binding established by the inner form; the inner binding for N shadows the outer binding for N. Outside the inner form but inside the outer one, references to N refer to the binding established by the outer form. For example: 

 (defun test (x z)
   (let ((z (* x 2)))
     (print z))
   z)

The binding of the variable z by let shadows the parameter binding for the function test. The reference to the variable z in the print form refers to the let binding. The reference to z at the end of the function test refers to the parameter named z.

Constructs that are lexically scoped act as if new names were generated for each object on each execution. Therefore, dynamic shadowing cannot occur. For example: 

 (defun contorted-example (f g x)
   (if (= x 0)
       (funcall f)
       (block here
          (+ 5 (contorted-example g
                                  #'(lambda () (return-from here 4))
                                  (- x 1))))))

Consider the call (contorted-example nil nil 2). This produces 4. During the course of execution, there are three calls to contorted-example, interleaved with two blocks: 

 (contorted-example nil nil 2)
   (block here_1 ...)
     (contorted-example nil #'(lambda () (return-from here_1 4)) 1)
       (block here_2 ...)
         (contorted-example #'(lambda () (return-from here_1 4))
                            #'(lambda () (return-from here_2 4))
                            0)
             (funcall f)
                    where f ⇒  #'(lambda () (return-from here_1 4))
                 (return-from here_1 4)

At the time the funcall is executed there are two block exit points outstanding, each apparently named here. The return-from form executed as a result of the funcall operation refers to the outer outstanding exit point (here_1), not the inner one (here_2). It refers to that exit point textually visible at the point of execution of function (here abbreviated by the #' syntax) that resulted in creation of the function object actually invoked by funcall.

If, in this example, one were to change the (funcall f) to (funcall g), then the value of the call (contorted-example nil nil 2) would be 9. The value would change because funcall would cause the execution of (return-from here_2 4), thereby causing a return from the inner exit point (here_2). When that occurs, the value 4 is returned from the middle invocation of contorted-example, 5 is added to that to get 9, and that value is returned from the outer block and the outermost call to contorted-example. The point is that the choice of exit point returned from has nothing to do with its being innermost or outermost; rather, it depends on the lexical environment that is packaged up with a lambda expression when function is executed.

Next: , Previous: , Up: Evaluation  

gcl-2.6.14/info/gcl/Rule-of-Float-Approximation.html0000644000175000017500000000637214360276512020575 0ustar cammcamm Rule of Float Approximation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Floating-point Computations  

12.1.4.3 Rule of Float Approximation

Computations with floats are only approximate, although they are described as if the results were mathematically accurate. Two mathematically identical expressions may be computationally different because of errors inherent in the floating-point approximation process. The precision of a float is not necessarily correlated with the accuracy of that number. For instance, 3.142857142857142857 is a more precise approximation to \pi than 3.14159, but the latter is more accurate. The precision refers to the number of bits retained in the representation. When an operation combines a short float with a long float, the result will be a long float. Common Lisp functions assume that the accuracy of arguments to them does not exceed their precision. Therefore when two small floats are combined, the result is a small float. Common Lisp functions never convert automatically from a larger size to a smaller one.

gcl-2.6.14/info/gcl/Lambda_002dlist_002ddirected-Destructuring-by-Lambda-Lists.html0000644000175000017500000001325214360276512026140 0ustar cammcamm Lambda-list-directed Destructuring by Lambda Lists (ANSI and GNU Common Lisp Document)

Previous: , Up: Macro Lambda Lists  

3.4.4.4 Lambda-list-directed Destructuring by Lambda Lists

An extension of data-directed destructuring of trees is lambda-list-directed destructuring. This derives from the analogy between the three-element destructuring pattern

(first second third)

and the three-argument lambda list

(first second third)

Lambda-list-directed destructuring is identical to data-directed destructuring if no lambda list keywords appear in the pattern. Any list in the pattern (whether a sub-list or the whole pattern itself) that contains a lambda list keyword is interpreted specially. Elements of the list to the left of the first lambda list keyword are treated as destructuring patterns, as usual, but the remaining elements of the list are treated like a function’s lambda list except that where a variable would normally be required, an arbitrary destructuring pattern is allowed. Note that in case of ambiguity, lambda list syntax is preferred over destructuring syntax. Thus, after &optional a list of elements is a list of a destructuring pattern and a default value form.

The detailed behavior of each lambda list keyword in a lambda-list-directed destructuring pattern is as follows:

&optional

Each following element is a variable or a list of a destructuring pattern, a default value form, and a supplied-p variable. The default value and the supplied-p variable can be omitted. If the list being destructured ends early, so that it does not have an element to match against this destructuring (sub)-pattern, the default form is evaluated and destructured instead. The supplied-p variable receives the value nil if the default form is used, t otherwise.

&rest, &body

The next element is a destructuring pattern that matches the rest of the list. &body is identical to &rest but declares that what is being matched is a list of forms that constitutes the body of form. This next element must be the last unless a lambda list keyword follows it.

&aux

The remaining elements are not destructuring patterns at all, but are auxiliary variable bindings.

&whole

The next element is a destructuring pattern that matches the entire form in a macro, or the entire subexpression at inner levels.

&key

Each following element is one of

a variable,

or

a list of a variable, an optional initialization form, and an optional supplied-p variable.

or

a list of a list of a keyword and a destructuring pattern, an optional initialization form, and an optional supplied-p variable.

The rest of the list being destructured is taken to be alternating keywords and values and is taken apart appropriately.

&allow-other-keys

Stands by itself.

Previous: , Up: Macro Lambda Lists  

gcl-2.6.14/info/gcl/Customizing-Class-Redefinition.html0000644000175000017500000000617314360276512021363 0ustar cammcamm Customizing Class Redefinition (ANSI and GNU Common Lisp Document)

Previous: , Up: Redefining Classes  

4.3.6.3 Customizing Class Redefinition

[Reviewer Note by Barmar: This description is hard to follow.]

Methods for update-instance-for-redefined-class may be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-redefined-class are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of update-instance-for-redefined-class. Because no initialization arguments are passed to update-instance-for-redefined-class when it is called by the system, the initialization forms for slots that are filled by before methods for update-instance-for-redefined-class will not be evaluated by shared-initialize.

Methods for shared-initialize may be defined to customize class redefinition. For more information, see Shared-Initialize.

gcl-2.6.14/info/gcl/Defining-Classes.html0000644000175000017500000001072514360276512016504 0ustar cammcamm Defining Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.2 Defining Classes

The macro defclass is used to define a new named class.

The definition of a class includes:

*

The name of the new class. For newly-defined classes this name is a proper name.

*

The list of the direct superclasses of the new class.

*

A set of slot specifiers . Each slot specifier includes the name of the slot and zero or more slot options. A slot option pertains only to a single slot. If a class definition contains two slot specifiers with the same name, an error is signaled.

*

A set of class options. Each class option pertains to the class as a whole.

The slot options and class options of the defclass form provide mechanisms for the following:

*

Supplying a default initial value form for a given slot.

*

Requesting that methods for generic functions be automatically generated for reading or writing slots.

*

Controlling whether a given slot is shared by all instances of the class or whether each instance of the class has its own slot.

*

Supplying a set of initialization arguments and initialization argument defaults to be used in instance creation.

*

Indicating that the metaclass is to be other than the default. The :metaclass option is reserved for future use; an implementation can be extended to make use of the :metaclass option.

*

Indicating the expected type for the value stored in the slot.

*

Indicating the documentation string for the slot.

Next: , Previous: , Up: Classes  

gcl-2.6.14/info/gcl/Interpreting-Dictionary-Entries.html0000644000175000017500000002525014360276512021551 0ustar cammcamm Interpreting Dictionary Entries (ANSI and GNU Common Lisp Document)

Previous: , Up: Definitions  

1.4.4 Interpreting Dictionary Entries

The dictionary entry for each defined name is partitioned into sections. Except as explicitly indicated otherwise below, each section is introduced by a label identifying that section. The omission of a section implies that the section is either not applicable, or would provide no interesting information.

This section defines the significance of each potential section in a dictionary entry.

• The "Affected By" Section of a Dictionary Entry  
• The "Arguments" Section of a Dictionary Entry  
• The "Arguments and Values" Section of a Dictionary Entry  
• The "Binding Types Affected" Section of a Dictionary Entry  
• The "Class Precedence List" Section of a Dictionary Entry  
• Dictionary Entries for Type Specifiers  
• The "Compound Type Specifier Kind" Section of a Dictionary Entry  
• The "Compound Type Specifier Syntax" Section of a Dictionary Entry  
• The "Compound Type Specifier Arguments" Section of a Dictionary Entry  
• The "Compound Type Specifier Description" Section of a Dictionary Entry  
• The "Constant Value" Section of a Dictionary Entry  
• The "Description" Section of a Dictionary Entry  
• The "Examples" Section of a Dictionary Entry  
• The "Exceptional Situations" Section of a Dictionary Entry  
• The "Initial Value" Section of a Dictionary Entry  
• The "Argument Precedence Order" Section of a Dictionary Entry  
• The "Method Signature" Section of a Dictionary Entry  
• The "Name" Section of a Dictionary Entry  
• The "Notes" Section of a Dictionary Entry  
• The "Pronunciation" Section of a Dictionary Entry  
• The "See Also" Section of a Dictionary Entry  
• The "Side Effects" Section of a Dictionary Entry  
• The "Supertypes" Section of a Dictionary Entry  
• The "Syntax" Section of a Dictionary Entry  
• Special "Syntax" Notations for Overloaded Operators  
• Naming Conventions for Rest Parameters  
• Requiring Non-Null Rest Parameters in The "Syntax" Section  
• Return values in The "Syntax" Section  
• No Arguments or Values in The "Syntax" Section  
• Unconditional Transfer of Control in The "Syntax" Section  
• The "Valid Context" Section of a Dictionary Entry  
• The "Value Type" Section of a Dictionary Entry  

Previous: , Up: Definitions  

gcl-2.6.14/info/gcl/cell_002derror.html0000644000175000017500000000543414360276512016105 0ustar cammcamm cell-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.6 cell-error [Condition Type]

Class Precedence List::

cell-error, error, serious-condition, condition, t

Description::

The type cell-error consists of error conditions that occur during a location access. The name of the offending cell is initialized by the :name initialization argument to make-condition, and is accessed by the function cell-error-name.

See Also::

cell-error-name

gcl-2.6.14/info/gcl/Examples-of-Data_002ddirected-Destructuring-by-Lambda-Lists.html0000644000175000017500000000553614360276512026374 0ustar cammcamm Examples of Data-directed Destructuring by Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Macro Lambda Lists  

3.4.4.3 Examples of Data-directed Destructuring by Lambda Lists

An example pattern is

(a b c)

which destructures a list of three elements. The variable a is assigned to the first element, b to the second, etc. A more complex example is

((first . rest) . more)

The important features of data-directed destructuring are its syntactic simplicity and the ability to extend it to lambda-list-directed destructuring.

gcl-2.6.14/info/gcl/Similarity-of-Literal-Objects.html0000644000175000017500000000422514360276512021075 0ustar cammcamm Similarity of Literal Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Literal Objects in Compiled Files  

3.2.4.2 Similarity of Literal Objects

gcl-2.6.14/info/gcl/Rule-of-Canonical-Representation-for-Complex-Rationals.html0000644000175000017500000000615614360276512025712 0ustar cammcamm Rule of Canonical Representation for Complex Rationals (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Complex Computations  

12.1.5.3 Rule of Canonical Representation for Complex Rationals

If the result of any computation would be a complex number whose real part is of type rational and whose imaginary part is zero, the result is converted to the rational which is the real part. This rule does not apply to complex numbers whose parts are floats. For example, #C(5 0) and 5 are not different objects in Common Lisp (they are always the same under eql); #C(5.0 0.0) and 5.0 are always different objects in Common Lisp (they are never the same under eql, although they are the same under equalp and =).

gcl-2.6.14/info/gcl/symbol.html0000644000175000017500000002115214360276512014667 0ustar cammcamm symbol (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.1 symbol [System Class]

Class Precedence List::

symbol, t

Description::

Symbols are used for their object identity to name various entities in Common Lisp, including (but not limited to) linguistic entities such as variables and functions.

Symbols can be collected together into packages. A symbol is said to be interned in a package if it is accessible in that package; the same symbol can be interned in more than one package. If a symbol is not interned in any package, it is called uninterned.

An interned symbol is uniquely identifiable by its name from any package in which it is accessible.

Symbols have the following attributes. For historically reasons, these are sometimes referred to as cells, although the actual internal representation of symbols and their attributes is implementation-dependent.

Name

The name of a symbol is a string used to identify the symbol. Every symbol has a name,

and the consequences are undefined if that name is altered.

The name is used as part of the external, printed representation of the symbol; see Character Syntax. The function symbol-name returns the name of a given symbol.

A symbol may have any character in its name.

Package

The object in this cell is called the home package of the symbol. If the home package is nil, the symbol is sometimes said to have no home package.

When a symbol is first created, it has no home package. When it is first interned, the package in which it is initially interned becomes its home package. The home package of a symbol can be accessed by using the function symbol-package.

If a symbol is uninterned from the package which is its home package, its home package is set to nil. Depending on whether there is another package in which the symbol is interned, the symbol might or might not really be an uninterned symbol. A symbol with no home package is therefore called apparently uninterned.

The consequences are undefined if an attempt is made to alter the home package of a symbol external in the COMMON-LISP package or the KEYWORD package.

Property list

The property list of a symbol provides a mechanism for associating named attributes with that symbol. The operations for adding and removing entries are destructive to the property list. Common Lisp provides operators both for direct manipulation of property list objects (e.g., see getf, remf, and symbol-plist) and for implicit manipulation of a symbol’s property list by reference to the symbol (e.g., see get and remprop). The property list associated with a fresh symbol is initially null.

Value

If a symbol has a value attribute, it is said to be bound, and that fact can be detected by the function boundp. The object contained in the value cell of a bound symbol is the value of the global variable named by that symbol, and can be accessed by the function symbol-value. A symbol can be made to be unbound by the function makunbound.

The consequences are undefined if an attempt is made to change the value of a symbol that names a constant variable, or to make such a symbol be unbound.

Function

If a symbol has a function attribute, it is said to be fbound, and that fact can be detected by the function fboundp. If the symbol is the name of a function in the global environment, the function cell contains the function, and can be accessed by the function symbol-function. If the symbol is the name of either a macro in the global environment (see macro-function) or a special operator (see special-operator-p), the symbol is fbound, and can be accessed by the function symbol-function, but the object which the function cell contains is of implementation-dependent type and purpose. A symbol can be made to be funbound by the function fmakunbound.

The consequences are undefined if an attempt is made to change the functional value of a symbol that names a special form.

Operations on a symbol’s value cell and function cell are sometimes described in terms of their effect on the symbol itself, but the user should keep in mind that there is an intimate relationship between the contents of those cells and the global variable or global function definition, respectively.

Symbols are used as identifiers for lexical variables and lexical function definitions, but in that role, only their object identity is significant. Common Lisp provides no operation on a symbol that can have any effect on a lexical variable or on a lexical function definition.

See Also::

Symbols as Tokens, Potential Numbers as Tokens, Printing Symbols

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/Printing-Other-Objects.html0000644000175000017500000000564614360276512017634 0ustar cammcamm Printing Other Objects (ANSI and GNU Common Lisp Document)

Previous: , Up: Default Print-Object Methods  

22.1.3.21 Printing Other Objects

Other objects are printed in an implementation-dependent manner. It is not required that an implementation print those objects readably.

For example, hash tables, readtables, packages, streams, and functions might not print readably.

A common notation to use in this circumstance is #<...>. Since #< is not readable by the Lisp reader, the precise format of the text which follows is not important, but a common format to use is that provided by the print-unreadable-object macro.

For information on how the Lisp reader treats this notation, see Sharpsign Less-Than-Sign. For information on how to notate objects that cannot be printed readably, see Sharpsign Dot.

gcl-2.6.14/info/gcl/Assertions.html0000644000175000017500000000505514360276512015520 0ustar cammcamm Assertions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Condition System Concepts  

9.1.5 Assertions

Conditional signaling of conditions based on such things as key match, form evaluation, and type are handled by assertion operators. Figure 9–7 shows operators relating to assertions. 

  assert  check-type  ecase      
  ccase   ctypecase   etypecase  

  Figure 9–7: Operators relating to assertions.
gcl-2.6.14/info/gcl/Restrictions-on-Examining-Pathname-Components.html0000644000175000017500000000647714360276512024274 0ustar cammcamm Restrictions on Examining Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.12 Restrictions on Examining Pathname Components

The space of possible objects that a conforming program must be prepared to read_1 as the value of a pathname component is substantially larger than the space of possible objects that a conforming program is permitted to write_1 into such a component.

While the values discussed in the subsections of this section, in Special Pathname Component Values, and in Restrictions on Wildcard Pathnames apply to values that might be seen when reading the component values, substantially more restrictive rules apply to constructing pathnames; see Restrictions on Constructing Pathnames.

When examining pathname components, conforming programs should be aware of the following restrictions.

gcl-2.6.14/info/gcl/floating_002dpoint_002doverflow.html0000644000175000017500000000513614360276512021301 0ustar cammcamm floating-point-overflow (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.83 floating-point-overflow [Condition Type]

Class Precedence List::

floating-point-overflow, arithmetic-error, error, serious-condition, condition, t

Description::

The type floating-point-overflow consists of error conditions that occur because of floating-point overflow.

gcl-2.6.14/info/gcl/unintern.html0000644000175000017500000001215514360276512015227 0ustar cammcamm unintern (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.15 unintern [Function]

unintern symbol &optional package ⇒ generalized-boolean

Arguments and Values::

symbol—a symbol.

package—a package designator.

The default is the current package.

generalized-boolean—a generalized boolean.

Description::

unintern removes symbol from package. If symbol is present in package, it is removed from package and also from package’s shadowing symbols list if it is present there. If package is the home package for symbol, symbol is made to have no home package. Symbol may continue to be accessible in package by inheritance.

Use of unintern can result in a symbol that has no recorded home package, but that in fact is accessible in some package. Common Lisp does not check for this pathological case, and such symbols are always printed preceded by #:.

unintern returns true if it removes symbol, and nil otherwise.

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (setq temps-unpack (intern "UNPACK" (make-package 'temp))) ⇒  TEMP::UNPACK 
 (unintern temps-unpack 'temp) ⇒  T
 (find-symbol "UNPACK" 'temp) ⇒  NIL, NIL 
 temps-unpack ⇒  #:UNPACK

Side Effects::

unintern changes the state of the package system in such a way that the consistency rules do not hold across the change.

Affected By::

Current state of the package system.

Exceptional Situations::

Giving a shadowing symbol to unintern can uncover a name conflict that had previously been resolved by the shadowing. If package A uses packages B and C, A contains a shadowing symbol x, and B and C each contain external symbols named x, then removing the shadowing symbol x from A will reveal a name conflict between b:x and c:x if those two symbols are distinct. In this case unintern will signal an error.

See Also::

Package Concepts

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/Documentation-of-Implementation_002dDependent-Features.html0000644000175000017500000000533614360276512025716 0ustar cammcamm Documentation of Implementation-Dependent Features (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.2 Documentation of Implementation-Dependent Features

A conforming implementation shall be accompanied by a document that provides a definition of all implementation-defined aspects of the language defined by this specification.

In addition, a conforming implementation is encouraged (but not required) to document items in this standard that are identified as implementation-dependent, although in some cases such documentation might simply identify the item as “undefined.”

gcl-2.6.14/info/gcl/Conses-as-Forms.html0000644000175000017500000000604214360276512016302 0ustar cammcamm Conses as Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.7 Conses as Forms

A cons that is used as a form is called a compound form.

If the car of that compound form is a symbol, that symbol is the name of an operator, and the form is either a special form, a macro form, or a function form, depending on the function binding of the operator in the current lexical environment. If the operator is neither a special operator nor a macro name, it is assumed to be a function name (even if there is no definition for such a function).

If the car of the compound form is not a symbol, then that car must be a lambda expression, in which case the compound form is a lambda form.

How a compound form is processed depends on whether it is classified as a special form, a macro form, a function form, or a lambda form.

gcl-2.6.14/info/gcl/package_002derror.html0000644000175000017500000000556614360276512016567 0ustar cammcamm package-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.29 package-error [Condition Type]

Class Precedence List::

package-error, error, serious-condition, condition, t

Description::

The type package-error consists of error conditions related to operations on packages. The offending package (or package name) is initialized by the :package initialization argument to make-condition, and is accessed by the function package-error-package.

See Also::

package-error-package , Conditions

gcl-2.6.14/info/gcl/no_002dnext_002dmethod.html0000644000175000017500000000762414360276512017360 0ustar cammcamm no-next-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.17 no-next-method [Standard Generic Function]

Syntax::

no-next-method generic-function method &rest args ⇒ {result}*

Method Signatures::

no-next-method (generic-function standard-generic-function) (method standard-method) &rest args

Arguments and Values::

generic-function – generic function to which method belongs.

method – method that contained the call to call-next-method for which there is no next method.

args – arguments to call-next-method.

result—an object.

Description::

The generic function no-next-method is called by call-next-method when there is no next method.

The generic function no-next-method is not intended to be called by programmers. Programmers may write methods for it.

Exceptional Situations::

The system-supplied method on no-next-method signals an error of type error. [Editorial Note by KMP: perhaps control-error??]

See Also::

call-next-method

gcl-2.6.14/info/gcl/Printing-Characters.html0000644000175000017500000000577714360276512017250 0ustar cammcamm Printing Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.7 Printing Characters

When printer escaping is disabled,

a character prints as itself; it is sent directly to the output stream.

When printer escaping is enabled,

then #\ syntax is used.

When the printer types out the name of a character, it uses the same table as the #\ reader macro would use; therefore any character name that is typed out is acceptable as input (in that implementation). If a non-graphic character has a standardized name_5, that name is preferred over non-standard names for printing in #\ notation. For the graphic standard characters, the character itself is always used for printing in #\ notation—even if the character also has a name_5.

For details about the #\ reader macro, see Sharpsign Backslash.

gcl-2.6.14/info/gcl/Sharpsign-A.html0000644000175000017500000000672414360276512015506 0ustar cammcamm Sharpsign A (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.13 Sharpsign A

#nA

#nAobject constructs an n-dimensional array, using object as the value of the :initial-contents argument to make-array.

For example, #2A((0 1 5) (foo 2 (hot dog))) represents a 2-by-3 matrix: 

 0       1       5
 foo     2       (hot dog)

In contrast, #1A((0 1 5) (foo 2 (hot dog))) represents a vector of length 2 whose elements are lists: 

 (0 1 5) (foo 2 (hot dog))

#0A((0 1 5) (foo 2 (hot dog))) represents a zero-dimensional array whose sole element is a list: 

 ((0 1 5) (foo 2 (hot dog)))

#0A foo represents a zero-dimensional array whose sole element is the symbol foo. The notation #1A foo is not valid because foo is not a sequence.

If some dimension of the array whose representation is being parsed is found to be 0, all dimensions to the right (i.e., the higher numbered dimensions) are also considered to be 0.

For information on how the Lisp printer prints arrays, see Printing Strings, Printing Bit Vectors, Printing Other Vectors, or Printing Other Arrays.

gcl-2.6.14/info/gcl/fill.html0000644000175000017500000001004714360276512014311 0ustar cammcamm fill (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.4 fill [Function]

fill sequence item &key start end ⇒ sequence

Arguments and Values::

sequence—a proper sequence.

item—a sequence.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

Description::

Replaces the elements of sequence bounded by start and end with item.

Examples::

 (fill (list 0 1 2 3 4 5) '(444)) ⇒  ((444) (444) (444) (444) (444) (444))
 (fill (copy-seq "01234") #\e :start 3) ⇒  "012ee"
 (setq x (vector 'a 'b 'c 'd 'e)) ⇒  #(A B C D E)
 (fill x 'z :start 1 :end 3) ⇒  #(A Z Z D E)
 x ⇒  #(A Z Z D E)
 (fill x 'p) ⇒  #(P P P P P)
 x ⇒  #(P P P P P)

Side Effects::

Sequence is destructively modified.

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil.

See Also::

replace , nsubstitute

Notes::

(fill sequence item) ≡ (nsubstitute-if item (constantly t) sequence)

gcl-2.6.14/info/gcl/Symbols-as-Forms.html0000644000175000017500000001124314360276512016477 0ustar cammcamm Symbols as Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.2 Symbols as Forms

If a form is a symbol, then it is either a symbol macro or a variable.

The symbol names a symbol macro if there is a binding of the symbol as a symbol macro in the current lexical environment

(see define-symbol-macro and symbol-macrolet).

If the symbol is a symbol macro, its expansion function is obtained. The expansion function is a function of two arguments, and is invoked by calling the macroexpand hook with the expansion function as its first argument, the symbol as its second argument, and an environment object (corresponding to the current lexical environment) as its third argument. The macroexpand hook, in turn, calls the expansion function with the form as its first argument and the environment as its second argument. The value of the expansion function, which is passed through by the macroexpand hook, is a form. This resulting form is processed in place of the original symbol.

If a form is a symbol that is not a symbol macro, then it is the name of a variable, and the value of that variable is returned. There are three kinds of variables: lexical variables, dynamic variables, and constant variables. A variable can store one object. The main operations on a variable are to read_1 and to write_1 its value.

An error of type unbound-variable should be signaled if an unbound variable is referenced.

Non-constant variables can be assigned by using setq or bound_3 by using let. Figure 3–1 lists some defined names that are applicable to assigning, binding, and defining variables. 

  boundp        let                  progv         
  defconstant   let*                 psetq         
  defparameter  makunbound           set           
  defvar        multiple-value-bind  setq          
  lambda        multiple-value-setq  symbol-value  

  Figure 3–1: Some Defined Names Applicable to Variables

The following is a description of each kind of variable.

Next: , Previous: , Up: The Evaluation Model  

gcl-2.6.14/info/gcl/use_002dpackage.html0000644000175000017500000001223714360276512016223 0ustar cammcamm use-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.18 use-package [Function]

use-package packages-to-use &optional package ⇒ t

Arguments and Values::

packages-to-use—a designator for a list of package designators. The KEYWORD package may not be supplied.

package—a package designator. The KEYWORD package cannot be supplied. The default is the current package.

Description::

use-package causes package to inherit all the external symbols of packages-to-use. The inherited symbols become accessible as internal symbols of package.

Packages-to-use are added to the use list of package if they are not there already. All external symbols in packages-to-use become accessible in package as internal symbols. use-package does not cause any new symbols to be present in package but only makes them accessible by inheritance.

use-package checks for name conflicts between the newly imported symbols and those already accessible in package. A name conflict in use-package between two external symbols inherited by package from packages-to-use may be resolved in favor of either symbol by importing one of them into package and making it a shadowing symbol.

Examples::

 (export (intern "LAND-FILL" (make-package 'trash)) 'trash) ⇒  T
 (find-symbol "LAND-FILL" (make-package 'temp)) ⇒  NIL, NIL
 (package-use-list 'temp) ⇒  (#<PACKAGE "TEMP">)
 (use-package 'trash 'temp) ⇒  T
 (package-use-list 'temp) ⇒  (#<PACKAGE "TEMP"> #<PACKAGE "TRASH">)
 (find-symbol "LAND-FILL" 'temp) ⇒  TRASH:LAND-FILL, :INHERITED

Side Effects::

The use list of package may be modified.

See Also::

unuse-package , package-use-list , Package Concepts

Notes::

It is permissible for a package P_1 to use a package P_2 even if P_2 already uses P_1. The using of packages is not transitive, so no problem results from the apparent circularity.

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/Character-Syntax.html0000644000175000017500000000637314360276512016552 0ustar cammcamm Character Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax  

2.1 Character Syntax

The Lisp reader takes characters from a stream, interprets them as a printed representation of an object, constructs that object, and returns it.

The syntax described by this chapter is called the standard syntax . Operations are provided by Common Lisp so that various aspects of the syntax information represented by a readtable can be modified under program control; see Reader. Except as explicitly stated otherwise, the syntax used throughout this document is standard syntax.

• Readtables  
• Variables that affect the Lisp Reader  
• Standard Characters  
• Character Syntax Types  
gcl-2.6.14/info/gcl/arithmetic_002derror_002doperands.html0000644000175000017500000000635114360276512021577 0ustar cammcamm arithmetic-error-operands (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.79 arithmetic-error-operands, arithmetic-error-operation [Function]

arithmetic-error-operands condition ⇒ operands

arithmetic-error-operation condition ⇒ operation

Arguments and Values::

condition—a condition of type arithmetic-error.

operands—a list.

operation—a function designator.

Description::

arithmetic-error-operands returns a list of the operands which were used in the offending call to the operation that signaled the condition.

arithmetic-error-operation returns a list of the offending operation in the offending call that signaled the condition.

See Also::

arithmetic-error, Conditions

Notes::

gcl-2.6.14/info/gcl/Array-Upgrading.html0000644000175000017500000000716714360276512016370 0ustar cammcamm Array Upgrading (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Specialized Arrays  

15.1.2.1 Array Upgrading

The upgraded array element type of a type T_1 is a type T_2 that is a supertype of T_1 and that is used instead of T_1 whenever T_1 is used as an array element type for object creation or type discrimination.

During creation of an array, the element type that was requested is called the expressed array element type . The upgraded array element type of the expressed array element type becomes the actual array element type of the array that is created.

Type upgrading implies a movement upwards in the type hierarchy lattice. A type is always a subtype of its upgraded array element type. Also, if a type T_x is a subtype of another type T_y, then the upgraded array element type of T_x must be a subtype of the upgraded array element type of T_y. Two disjoint types can be upgraded to the same type.

The upgraded array element type T_2 of a type T_1 is a function only of T_1 itself; that is, it is independent of any other property of the array for which T_2 will be used, such as rank, adjustability, fill pointers, or displacement. The function upgraded-array-element-type can be used by conforming programs to predict how the implementation will upgrade a given type.

gcl-2.6.14/info/gcl/Tilde-Ampersand_002d_003e-Fresh_002dLine.html0000644000175000017500000000460114360276512022211 0ustar cammcamm Tilde Ampersand-> Fresh-Line (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Basic Output  

22.3.1.3 Tilde Ampersand: Fresh-Line

Unless it can be determined that the output stream is already at the beginning of a line, this outputs a newline. ~n& calls fresh-line and then outputs n- 1 newlines. ~0& does nothing.

gcl-2.6.14/info/gcl/Comma.html0000644000175000017500000000410314360276512014413 0ustar cammcamm Comma (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.7 Comma

The comma is part of the backquote syntax; see Backquote. Comma is invalid if used other than inside the body of a backquote expression as described above.

gcl-2.6.14/info/gcl/NIL-as-a-Component-Value.html0000644000175000017500000000513314360276512017636 0ustar cammcamm NIL as a Component Value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.7 NIL as a Component Value

As a pathname component value, nil represents that the component is “unfilled”; see Merging Pathnames.

The value of any pathname component can be nil.

When constructing a pathname, nil in the host component might mean a default host rather than an actual nil in some implementations.

gcl-2.6.14/info/gcl/Examples-of-Keyword-Arguments-in-Generic-Functions-and-Methods.html0000644000175000017500000000721314360276512027216 0ustar cammcamm Examples of Keyword Arguments in Generic Functions and Methods (ANSI and GNU Common Lisp Document)

Previous: , Up: Keyword Arguments in Generic Functions and Methods  

7.6.5.1 Examples of Keyword Arguments in Generic Functions and Methods

For example, suppose there are two methods defined for width as follows: 

 (defmethod width ((c character-class) &key font) ...)

 (defmethod width ((p picture-class) &key pixel-size) ...)

Assume that there are no other methods and no generic function definition for width. The evaluation of the following form should signal an error because the keyword argument :pixel-size is not accepted by the applicable method. 

 (width (make-instance `character-class :char #\Q) 
        :font 'baskerville :pixel-size 10)

The evaluation of the following form should signal an error. 

 (width (make-instance `picture-class :glyph (glyph #\Q)) 
        :font 'baskerville :pixel-size 10)

The evaluation of the following form will not signal an error if the class named character-picture-class is a subclass of both picture-class and character-class. 

 (width (make-instance `character-picture-class :char #\Q)
        :font 'baskerville :pixel-size 10)
gcl-2.6.14/info/gcl/Array-Indices.html0000644000175000017500000000433014360276512016013 0ustar cammcamm Array Indices (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.1 Array Indices

An array element is referred to by a (possibly empty) series of indices. The length of the series must equal the rank of the array.

Each index must be a non-negative fixnum

less than the corresponding array dimension. Array indexing is zero-origin.

gcl-2.6.14/info/gcl/Specialized-Arrays.html0000644000175000017500000000770614360276512017066 0ustar cammcamm Specialized Arrays (ANSI and GNU Common Lisp Document)

Previous: , Up: Array Concepts  

15.1.2 Specialized Arrays

An array can be a general array, meaning each element may be any object, or it may be a specialized array, meaning that each element must be of a restricted type.

The phrasing “an array specialized to type <<type>>” is sometimes used to emphasize the element type of an array. This phrasing is tolerated even when the <<type>> is t, even though an array specialized to type t is a general array, not a specialized array.

Figure 15–1 lists some defined names that are applicable to array creation, access, and information operations. 

 adjust-array             array-in-bounds-p      svref                       
 adjustable-array-p       array-rank             upgraded-array-element-type 
 aref                     array-rank-limit       upgraded-complex-part-type  
 array-dimension          array-row-major-index  vector                      
 array-dimension-limit    array-total-size       vector-pop                  
 array-dimensions         array-total-size-limit vector-push                 
 array-element-type       fill-pointer           vector-push-extend          
 array-has-fill-pointer-p make-array                                         

           Figure 15–1: General Purpose Array-Related Defined Names
• Array Upgrading  
• Required Kinds of Specialized Arrays  
gcl-2.6.14/info/gcl/Stream-Arguments-to-Standardized-Functions.html0000644000175000017500000001272514360276512023566 0ustar cammcamm Stream Arguments to Standardized Functions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Stream Concepts  

21.1.3 Stream Arguments to Standardized Functions

The operators in Figure 21–7 accept stream arguments that might be either open or closed streams. 

  broadcast-stream-streams     file-author       pathnamep                     
  close                        file-namestring   probe-file                    
  compile-file                 file-write-date   rename-file                   
  compile-file-pathname        host-namestring   streamp                       
  concatenated-stream-streams  load              synonym-stream-symbol         
  delete-file                  logical-pathname  translate-logical-pathname    
  directory                    merge-pathnames   translate-pathname            
  directory-namestring         namestring        truename                      
  dribble                      open              two-way-stream-input-stream   
  echo-stream-input-stream     open-stream-p     two-way-stream-output-stream  
  echo-stream-ouput-stream     parse-namestring  wild-pathname-p               
  ed                           pathname          with-open-file                
  enough-namestring            pathname-match-p                                

        Figure 21–7: Operators that accept either Open or Closed Streams

The operators in Figure 21–8 accept stream arguments that must be open streams. 

 clear-input              output-stream-p         read-char-no-hang          
 clear-output             peek-char               read-delimited-list        
 file-length              pprint                  read-line                  
 file-position            pprint-fill             read-preserving-whitespace 
 file-string-length       pprint-indent           stream-element-type        
 finish-output            pprint-linear           stream-external-format     
 force-output             pprint-logical-block    terpri                     
 format                   pprint-newline          unread-char                
 fresh-line               pprint-tab              with-open-stream           
 get-output-stream-string pprint-tabular          write                      
 input-stream-p           prin1                   write-byte                 
 interactive-stream-p     princ                   write-char                 
 listen                   print                   write-line                 
 make-broadcast-stream    print-object            write-string               
 make-concatenated-stream print-unreadable-object y-or-n-p                   
 make-echo-stream         read                    yes-or-no-p                
 make-synonym-stream      read-byte                                          
 make-two-way-stream      read-char                                          

             Figure 21–8: Operators that accept Open Streams only
gcl-2.6.14/info/gcl/Additional-Information-about-Parsing-Logical-Pathname-Namestrings.html0000644000175000017500000000477614360276512030036 0ustar cammcamm Additional Information about Parsing Logical Pathname Namestrings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.1 Additional Information about Parsing Logical Pathname Namestrings

gcl-2.6.14/info/gcl/Use-of-Read_002dTime-Conditionals.html0000644000175000017500000000627114360276512021366 0ustar cammcamm Use of Read-Time Conditionals (ANSI and GNU Common Lisp Document)

Previous: , Up: Conforming Programs  

1.5.2.2 Use of Read-Time Conditionals

Use of #+ and #- does not automatically disqualify a program from being conforming. A program which uses #+ and #- is considered conforming if there is no set of features in which the program would not be conforming. Of course, conforming programs are not necessarily working programs. The following program is conforming: 

(defun foo ()
  #+ACME (acme:initialize-something)
  (print 'hello-there))

However, this program might or might not work, depending on whether the presence of the feature ACME really implies that a function named acme:initialize-something is present in the environment. In effect, using #+ or #- in a conforming program means that the variable *features*

becomes just one more piece of input data to that program. Like any other data coming into a program, the programmer is responsible for assuring that the program does not make unwarranted assumptions on the basis of input data.

gcl-2.6.14/info/gcl/Readtables.html0000644000175000017500000000663614360276512015442 0ustar cammcamm Readtables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax  

2.1.1 Readtables

Syntax information for use by the Lisp reader is embodied in an object called a readtable . Among other things, the readtable contains the association between characters and syntax types.

Figure 2–1 lists some defined names that are applicable to readtables. 

  *readtable*                    readtable-case                
  copy-readtable                 readtablep                    
  get-dispatch-macro-character   set-dispatch-macro-character  
  get-macro-character            set-macro-character           
  make-dispatch-macro-character  set-syntax-from-char          

              Figure 2–1: Readtable defined names
• The Current Readtable  
• The Standard Readtable  
• The Initial Readtable  
gcl-2.6.14/info/gcl/Introduction-to-Packages.html0000644000175000017500000001316614360276512020205 0ustar cammcamm Introduction to Packages (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Package Concepts  

11.1.1 Introduction to Packages

A package establishes a mapping from names to symbols. At any given time, one package is current. The current package is the one that is the value of *package*. When using the Lisp reader, it is possible to refer to symbols in packages other than the current one through the use of package prefixes in the printed representation of the symbol.

Figure 11–1 lists some defined names that are applicable to packages. Where an operator takes an argument that is either a symbol or a list of symbols, an argument of nil is treated as an empty list of symbols. Any package argument may be either a string, a symbol, or a package. If a symbol is supplied, its name will be used as the package name. 

  *modules*            import                     provide           
  *package*            in-package                 rename-package    
  defpackage           intern                     require           
  do-all-symbols       list-all-packages          shadow            
  do-external-symbols  make-package               shadowing-import  
  do-symbols           package-name               unexport          
  export               package-nicknames          unintern          
  find-all-symbols     package-shadowing-symbols  unuse-package     
  find-package         package-use-list           use-package       
  find-symbol          package-used-by-list                         

         Figure 11–1: Some Defined Names related to Packages
• Package Names and Nicknames  
• Symbols in a Package  
• Internal and External Symbols  
• Package Inheritance  
• Accessibility of Symbols in a Package  
• Locating a Symbol in a Package  
• Prevention of Name Conflicts in Packages  

Next: , Previous: , Up: Package Concepts  

gcl-2.6.14/info/gcl/eql.html0000644000175000017500000001433014360276512014143 0ustar cammcamm eql (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.34 eql [Function]

eql x y ⇒ generalized-boolean

Arguments and Values::

x—an object.

y—an object.

generalized-boolean—a generalized boolean.

Description::

The value of eql is true of two objects, x and y, in the folowing cases:

1.

If x and y are eq.

2.

If x and y are both numbers of the same type and the same value.

3.

If they are both characters that represent the same character.

Otherwise the value of eql is false.

If an implementation supports positive and negative zeros as distinct values, then (eql 0.0 -0.0) returns false. Otherwise, when the syntax -0.0 is read it is interpreted as the value 0.0, and so (eql 0.0 -0.0) returns true.

Examples::

 (eql 'a 'b) ⇒  false
 (eql 'a 'a) ⇒  true
 (eql 3 3) ⇒  true
 (eql 3 3.0) ⇒  false
 (eql 3.0 3.0) ⇒  true
 (eql #c(3 -4) #c(3 -4)) ⇒  true
 (eql #c(3 -4.0) #c(3 -4)) ⇒  false
 (eql (cons 'a 'b) (cons 'a 'c)) ⇒  false
 (eql (cons 'a 'b) (cons 'a 'b)) ⇒  false
 (eql '(a . b) '(a . b))
⇒  true
OR⇒ false
 (progn (setq x (cons 'a 'b)) (eql x x)) ⇒  true
 (progn (setq x '(a . b)) (eql x x)) ⇒  true
 (eql #\A #\A) ⇒  true
 (eql "Foo" "Foo")
⇒  true
OR⇒ false
 (eql "Foo" (copy-seq "Foo")) ⇒  false
 (eql "FOO" "foo") ⇒  false

Normally (eql 1.0s0 1.0d0) is false, under the assumption that 1.0s0 and 1.0d0 are of distinct data types. However, implementations that do not provide four distinct floating-point formats are permitted to “collapse” the four formats into some smaller number of them; in such an implementation (eql 1.0s0 1.0d0) might be true.

See Also::

eq , equal , equalp , = , char=

Notes::

eql is the same as eq, except that if the arguments are characters or numbers of the same type then their values are compared. Thus eql tells whether two objects are conceptually the same, whereas eq tells whether two objects are implementationally identical. It is for this reason that eql, not eq, is the default comparison predicate for operators that take sequences as arguments.

eql may not be true of two floats even when they represent the same value. = is used to compare mathematical values.

Two complex numbers are considered to be eql if their real parts are eql and their imaginary parts are eql. For example, (eql #C(4 5) #C(4 5)) is true and (eql #C(4 5) #C(4.0 5.0)) is false. Note that while (eql #C(5.0 0.0) 5.0) is false, (eql #C(5 0) 5) is true. In the case of (eql #C(5.0 0.0) 5.0) the two arguments are of different types, and so cannot satisfy eql. In the case of (eql #C(5 0) 5), #C(5 0) is not a complex number, but is automatically reduced to the integer 5.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Filenames-Dictionary.html0000644000175000017500000001172514360276512017375 0ustar cammcamm Filenames Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Filenames  

19.4 Filenames Dictionary

• pathname (System Class)  
• logical-pathname (System Class)  
• pathname  
• make-pathname  
• pathnamep  
• pathname-host  
• load-logical-pathname-translations  
• logical-pathname-translations  
• logical-pathname  
• *default-pathname-defaults*  
• namestring  
• parse-namestring  
• wild-pathname-p  
• pathname-match-p  
• translate-logical-pathname  
• translate-pathname  
• merge-pathnames  
gcl-2.6.14/info/gcl/Examples-of-Printing-Arrays.html0000644000175000017500000000566614360276512020605 0ustar cammcamm Examples of Printing Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.17 Examples of Printing Arrays

 (let ((a (make-array '(3 3)))
       (*print-pretty* t)
       (*print-array* t))
   (dotimes (i 3) (dotimes (j 3) (setf (aref a i j) (format nil "<~D,~D>" i j))))
   (print a)
   (print (make-array 9 :displaced-to a)))
 |>  #2A(("<0,0>" "<0,1>" "<0,2>") 
 |>      ("<1,0>" "<1,1>" "<1,2>") 
 |>      ("<2,0>" "<2,1>" "<2,2>")) 
 |>  #("<0,0>" "<0,1>" "<0,2>" "<1,0>" "<1,1>" "<1,2>" "<2,0>" "<2,1>" "<2,2>") 
⇒  #<ARRAY 9 indirect 36363476>
gcl-2.6.14/info/gcl/adjoin.html0000644000175000017500000001166214360276512014633 0ustar cammcamm adjoin (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.44 adjoin [Function]

adjoin item list &key key test test-not ⇒ new-list

Arguments and Values::

item—an object.

list—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

new-list—a list.

Description::

Tests whether item is the same as an existing element of list. If the item is not an existing element, adjoin adds it to list (as if by cons) and returns the resulting list; otherwise, nothing is added and the original list is returned.

The test, test-not, and key affect how it is determined whether item is the same as an element of list. For details, see Satisfying a Two-Argument Test.\ifvmode\else\endgraf \ifdim \prevdepth>-1000pt \NIS\parskip \normalparskip\relax\fi

Examples::

 (setq slist '()) ⇒  NIL 
 (adjoin 'a slist) ⇒  (A) 
 slist ⇒  NIL 
 (setq slist (adjoin '(test-item 1) slist)) ⇒  ((TEST-ITEM 1)) 
 (adjoin '(test-item 1) slist) ⇒  ((TEST-ITEM 1) (TEST-ITEM 1)) 
 (adjoin '(test-item 1) slist :test 'equal) ⇒  ((TEST-ITEM 1)) 
 (adjoin '(new-test-item 1) slist :key #'cadr) ⇒  ((TEST-ITEM 1)) 
 (adjoin '(new-test-item 1) slist) ⇒  ((NEW-TEST-ITEM 1) (TEST-ITEM 1))

Exceptional Situations::

Should be prepared to signal an error of type type-error if list is not a proper list.

See Also::

pushnew ,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated. 

 (adjoin item list :key fn)
   ≡ (if (member (fn item) list :key fn) list (cons item list))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Pretty-Print-Dispatch-Tables.html0000644000175000017500000000744314360276512020717 0ustar cammcamm Pretty Print Dispatch Tables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pretty Printer Concepts  

22.2.1.4 Pretty Print Dispatch Tables

A pprint dispatch table is a mapping from keys to pairs of values. Each key is a type specifier. The values associated with a key are a “function” (specifically, a function designator or nil) and a “numerical priority” (specifically, a real). Basic insertion and retrieval is done based on the keys with the equality of keys being tested by equal.

When *print-pretty* is true, the current pprint dispatch table (in *print-pprint-dispatch*) controls how objects are printed. The information in this table takes precedence over all other mechanisms for specifying how to print objects. In particular, it has priority over user-defined print-object methods

because the current pprint dispatch table is consulted first.

The function is chosen from the current pprint dispatch table by finding the highest priority function that is associated with a type specifier that matches the object; if there is more than one such function, it is implementation-dependent which is used.

However, if there is no information in the table about how to pretty print a particular kind of object, a function is invoked which uses print-object to print the object. The value of *print-pretty* is still true when this function is called, and individual methods for print-object might still elect to produce output in a special format conditional on the value of *print-pretty*.

gcl-2.6.14/info/gcl/make_002dstring.html0000644000175000017500000000634714360276512016264 0ustar cammcamm make-string (ANSI and GNU Common Lisp Document)

Previous: , Up: Strings Dictionary  

16.2.12 make-string [Function]

make-string size &key initial-element element-type ⇒ string

Arguments and Values::

size—a valid array dimension.

initial-element—a character.

The default is implementation-dependent.

element-type—a type specifier. The default is character.

string—a simple string.

Description::

make-string returns a simple string of length size whose elements have been initialized to initial-element.

The element-type names the type of the elements of the string; a string is constructed of the most specialized type that can accommodate elements of the given type.

Examples::

 (make-string 10 :initial-element #\5) ⇒  "5555555555"
 (length (make-string 10)) ⇒  10

Affected By::

The implementation.

gcl-2.6.14/info/gcl/Additional-Information-about-FORMAT-Operations.html0000644000175000017500000000612514360276512024137 0ustar cammcamm Additional Information about FORMAT Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.10 Additional Information about FORMAT Operations

• Nesting of FORMAT Operations  
• Missing and Additional FORMAT Arguments  
• Additional FORMAT Parameters  
• Undefined FORMAT Modifier Combinations  
gcl-2.6.14/info/gcl/compile_002dfile.html0000644000175000017500000002150214360276512016376 0ustar cammcamm compile-file (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.1 compile-file [Function]

compile-file input-file &key output-file verbose print external-format
⇒ output-truename, warnings-p, failure-p

Arguments and Values::

input-file—a pathname designator. (Default fillers for unspecified components are taken from *default-pathname-defaults*.)

output-file—a pathname designator. The default is implementation-defined.

verbose—a generalized boolean. The default is the value of *compile-verbose*.

print—a generalized boolean. The default is the value of *compile-print*.

external-format—an external file format designator. The default is :default.

output-truename—a pathname (the truename of the output file), or nil.

warnings-p—a generalized boolean.

failure-p—a generalized boolean.

Description::

compile-file transforms the contents of the file specified by input-file into implementation-dependent binary data which are placed in the file specified by output-file.

The file to which input-file refers should be a source file. output-file can be used to specify an output pathname;

the actual pathname of the compiled file to which compiled code will be output is computed as if by calling compile-file-pathname.

If input-file or output-file is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname.

If verbose is true, compile-file prints a message in the form of a comment (i.e., with a leading semicolon) to standard output indicating what file is being compiled and other useful information. If verbose is false, compile-file does not print this information.

If print is true, information about top level forms in the file being compiled is printed to standard output. Exactly what is printed is implementation-dependent, but nevertheless some information is printed. If print is nil, no information is printed.

The external-format specifies the external file format to be used when opening the file; see the function open. compile-file and load must cooperate in such a way that the resulting compiled file can be loaded without specifying an external file format anew; see the function load.

compile-file binds *readtable* and *package* to the values they held before processing the file.

*compile-file-truename* is bound by compile-file to hold the truename of the pathname of the file being compiled.

*compile-file-pathname* is bound by compile-file to hold a pathname denoted by the first argument to compile-file, merged against the defaults; that is, (pathname (merge-pathnames input-file)).

The compiled functions contained in the compiled file become available for use when the compiled file is loaded into Lisp.

Any function definition that is processed by the compiler, including #'(lambda ...) forms and local function definitions made by flet, labels and defun forms, result in an object of type compiled-function.

The primary value returned by compile-file, output-truename, is the truename of the output file, or nil if the file could not be created.

The secondary value, warnings-p, is false if no conditions of type error or warning were detected by the compiler, and true otherwise.

The tertiary value, failure-p, is false if no conditions of type error or warning (other than style-warning) were detected by the compiler, and true otherwise.

For general information about how files are processed by the file compiler, see File Compilation.

Programs to be compiled by the file compiler must only contain externalizable objects; for details on such objects, see Literal Objects in Compiled Files. For information on how to extend the set of externalizable objects, see the function make-load-form and Additional Constraints on Externalizable Objects.

Affected By::

*error-output*,

*standard-output*, *compile-verbose*, *compile-print*

The computer’s file system.

Exceptional Situations::

For information about errors detected during the compilation process, see Exceptional Situations in the Compiler.

An error of type file-error might be signaled if (wild-pathname-p input-file)\/ returns true.

If either the attempt to open the source file for input or the attempt to open the compiled file for output fails, an error of type file-error is signaled.

See Also::

compile , declare, eval-when , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: System Construction Dictionary  

gcl-2.6.14/info/gcl/simple_002derror.html0000644000175000017500000000506314360276512016455 0ustar cammcamm simple-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.14 simple-error [Condition Type]

Class Precedence List::

simple-error, simple-condition, error, serious-condition, condition, t

Description::

The type simple-error consists of conditions that are signaled by error or cerror when a

format control

is supplied as the function’s first argument.

gcl-2.6.14/info/gcl/call_002dmethod.html0000644000175000017500000001441314360276512016225 0ustar cammcamm call-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.30 call-method, make-method [Local Macro]

Syntax::

call-method method &optional next-method-list ⇒ {result}*

make-method form ⇒ method-object

Arguments and Values::

method—a method object, or a list (see below); not evaluated.

method-object—a method object.

next-method-list—a list of method objects; not evaluated.

results—the values returned by the method invocation.

Description::

The macro call-method is used in method combination. It hides the implementation-dependent details of how methods are called. The macro call-method has lexical scope and can only be used within an effective method form.

[Editorial Note by KMP: This next paragraph still needs some work.]

Whether or not call-method is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of call-method are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use call-method outside of an effective method form are undefined.

The macro call-method invokes the specified method, supplying it with arguments and with definitions for call-next-method and for next-method-p. If the invocation of call-method is lexically inside of a make-method, the arguments are those that were supplied to that method. Otherwise the arguments are those that were supplied to the generic function. The definitions of call-next-method and next-method-p rely on the specified next-method-list.

If method is a list, the first element of the list must be the symbol make-method and the second element must be a form. Such a list specifies a method object whose method function has a body that is the given form.

Next-method-list can contain method objects or lists, the first element of which must be the symbol make-method and the second element of which must be a form.

Those are the only two places where make-method can be used. The form used with make-method is evaluated in the null lexical environment augmented with a local macro definition for call-method and with bindings named by symbols not accessible from the COMMON-LISP-USER package.

The call-next-method function available to method will call the first method in next-method-list. The call-next-method function available in that method, in turn, will call the second method in next-method-list, and so on, until the list of next methods is exhausted.

If next-method-list is not supplied, the call-next-method function available to method signals an error of type control-error and the next-method-p function available to method returns nil.

Examples::

See Also::

call-next-method , define-method-combination , next-method-p

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/_002acompile_002dfile_002dpathname_002a.html0000644000175000017500000000753714360276512022121 0ustar cammcamm *compile-file-pathname* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.6 *compile-file-pathname*, *compile-file-truename* [Variable]

Value Type::

The value of *compile-file-pathname* must always be a pathname or nil. The value of *compile-file-truename* must always be a physical pathname or nil.

Initial Value::

nil.

Description::

During a call to compile-file, *compile-file-pathname* is bound to the pathname denoted by the first argument to compile-file, merged against the defaults; that is, it is bound to (pathname (merge-pathnames input-file)). During the same time interval, *compile-file-truename* is bound to the truename of the file being compiled.

At other times, the value of these variables is nil.

If a break loop is entered while compile-file is ongoing, it is implementation-dependent whether these variables retain the values they had just prior to entering the break loop or whether they are bound to nil.

The consequences are unspecified if an attempt is made to assign or bind either of these variables.

Affected By::

The file system.

See Also::

compile-file

gcl-2.6.14/info/gcl/Sequence-Concepts.html0000644000175000017500000001053014360276512016704 0ustar cammcamm Sequence Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences  

17.1 Sequence Concepts

A sequence is an ordered collection of elements, implemented as either a vector or a list.

Sequences can be created by the function make-sequence, as well as other functions that create objects of types that are subtypes of sequence (e.g., list, make-list, mapcar, and vector).

A sequence function is a function defined by this specification or added as an extension by the implementation that operates on one or more sequences. Whenever a sequence function must construct and return a new vector, it always returns a simple vector. Similarly, any strings constructed will be simple strings. 

  concatenate        length              remove             
  copy-seq           map                 remove-duplicates  
  count              map-into            remove-if          
  count-if           merge               remove-if-not      
  count-if-not       mismatch            replace            
  delete             notany              reverse            
  delete-duplicates  notevery            search             
  delete-if          nreverse            some               
  delete-if-not      nsubstitute         sort               
  elt                nsubstitute-if      stable-sort        
  every              nsubstitute-if-not  subseq             
  fill               position            substitute         
  find               position-if         substitute-if      
  find-if            position-if-not     substitute-if-not  
  find-if-not        reduce                                 

        Figure 17–1: Standardized Sequence Functions
• General Restrictions on Parameters that must be Sequences  
././@LongLink0000644000000000000000000000015100000000000011600 Lustar rootrootgcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Description_0022-Section-of-a-Dictionary-Entry.htmlgcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Description_0022-Section-of-a-Dictionary-Entry.0000644000175000017500000000562614360276512030650 0ustar cammcamm The "Compound Type Specifier Description" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.10 The "Compound Type Specifier Description" Section of a Dictionary Entry

This information describes the meaning of the structures defined in The "Compound Type Specifier Syntax" Section.

gcl-2.6.14/info/gcl/_002areadtable_002a.html0000644000175000017500000000705314360276512016555 0ustar cammcamm *readtable* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.17 *readtable* [Variable]

Value Type::

a readtable.

Initial Value::

A readtable that conforms to the description of Common Lisp syntax in Syntax.

Description::

The value of *readtable* is called the current readtable. It controls the parsing behavior of the Lisp reader, and can also influence the Lisp printer (e.g., see the function readtable-case).

Examples::

 (readtablep *readtable*) ⇒  true
 (setq zvar 123) ⇒  123
 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) ⇒  T
 zvar ⇒  123
 (setq *readtable* table2) ⇒  #<READTABLE>
 zvar ⇒  VAR
 (setq *readtable* (copy-readtable nil)) ⇒  #<READTABLE>
 zvar ⇒  123

Affected By::

compile-file, load

See Also::

compile-file , load , readtable , The Current Readtable

gcl-2.6.14/info/gcl/Iteration.html0000644000175000017500000000435514360276512015326 0ustar cammcamm Iteration (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

6 Iteration

• The LOOP Facility  
• Iteration Dictionary  
gcl-2.6.14/info/gcl/set_002dsyntax_002dfrom_002dchar.html0000644000175000017500000001267414360276512021156 0ustar cammcamm set-syntax-from-char (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.11 set-syntax-from-char [Function]

set-syntax-from-char to-char from-char &optional to-readtable from-readtable ⇒ t

Arguments and Values::

to-char—a character.

from-char—a character.

to-readtable—a readtable. The default is the current readtable.

from-readtable—a readtable designator. The default is the standard readtable.

Description::

set-syntax-from-char makes the syntax of to-char in to-readtable be the same as the syntax of from-char in from-readtable.

set-syntax-from-char copies the syntax types of from-char. If from-char is a macro character, its reader macro function is copied also. If the character is a dispatching macro character, its entire dispatch table of reader macro functions is copied. The constituent traits of from-char are not copied.

A macro definition from a character such as " can be copied to another character; the standard definition for " looks for another character that is the same as the character that invoked it. The definition of ( can not be meaningfully copied to {, on the other hand. The result is that lists are of the form {a b c), not {a b c}, because the definition always looks for a closing parenthesis, not a closing brace.

Examples::

 (set-syntax-from-char #\7 #\;) ⇒  T
 123579 ⇒  1235

Side Effects::

The to-readtable is modified.

Affected By::

The existing values in the from-readtable.

See Also::

set-macro-character , make-dispatch-macro-character , Character Syntax Types

Notes::

The constituent traits of a character are “hard wired” into the parser for extended tokens. For example, if the definition of S is copied to *, then * will become a constituent that is alphabetic_2 but that cannot be used as a short float exponent marker. For further information, see Constituent Traits.

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/rename_002dfile.html0000644000175000017500000001312714360276512016221 0ustar cammcamm rename-file (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.7 rename-file [Function]

rename-file filespec new-name ⇒ defaulted-new-name, old-truename, new-truename

Arguments and Values::

filespec—a pathname designator.

new-name—a pathname designator other than a stream.

defaulted-new-name—a pathname

old-truename—a physical pathname.

new-truename—a physical pathname.

Description::

rename-file modifies the file system in such a way that the file indicated by filespec is renamed to defaulted-new-name.

It is an error to specify a filename containing a wild component, for filespec to contain a nil component where the file system does not permit a nil component, or for the result of defaulting missing components of new-name from filespec to contain a nil component where the file system does not permit a nil component.

If new-name is a logical pathname, rename-file returns a logical pathname as its primary value.

rename-file returns three values if successful. The primary value, defaulted-new-name, is the resulting name which is composed of new-name with any missing components filled in by performing a merge-pathnames operation using filespec as the defaults. The secondary value, old-truename, is the truename of the file before it was renamed. The tertiary value, new-truename, is the truename of the file after it was renamed.

If the filespec designator is an open stream, then the stream itself and the file associated with it are affected (if the file system permits).

Examples::

;; An example involving logical pathnames.
 (with-open-file (stream "sys:chemistry;lead.text"
                         :direction :output :if-exists :error)
   (princ "eureka" stream)
   (values (pathname stream) (truename stream)))
⇒  #P"SYS:CHEMISTRY;LEAD.TEXT.NEWEST", #P"Q:>sys>chem>lead.text.1"
 (rename-file "sys:chemistry;lead.text" "gold.text")
⇒  #P"SYS:CHEMISTRY;GOLD.TEXT.NEWEST",
   #P"Q:>sys>chem>lead.text.1",
   #P"Q:>sys>chem>gold.text.1"

Exceptional Situations::

If the renaming operation is not successful, an error of type file-error is signaled.

An error of type file-error might be signaled if filespec is wild.

See Also::

truename , pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: Files Dictionary  

gcl-2.6.14/info/gcl/Examples-of-COUNT-clause.html0000644000175000017500000000446314360276512017710 0ustar cammcamm Examples of COUNT clause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Value Accumulation Clauses  

6.1.3.3 Examples of COUNT clause

 (loop for i in '(a b nil c nil d e)
       count i)
⇒  5
gcl-2.6.14/info/gcl/Additional-Constraints-on-Externalizable-Objects.html0000644000175000017500000001753114360276512024715 0ustar cammcamm Additional Constraints on Externalizable Objects (ANSI and GNU Common Lisp Document)

Previous: , Up: Literal Objects in Compiled Files  

3.2.4.6 Additional Constraints on Externalizable Objects

If two literal objects appearing in the source code for a single file processed with the file compiler are the identical, the corresponding objects in the compiled code must also be the identical.

With the exception of symbols and packages, any two literal objects in code being processed by the file compiler may be coalesced if and only if they are similar; if they are either both symbols or both packages, they may only be coalesced if and only if they are identical.

Objects containing circular references can be externalizable objects. The file compiler is required to preserve eqlness of substructures within a file. Preserving eqlness means that subobjects that are the same in the source code must be the same in the corresponding compiled code.

In addition, the following are constraints on the handling of literal objects by the file compiler:

array: If an array in the source code is a simple array, then the corresponding array in the compiled code will also be a simple array. If an array in the source code is displaced, has a fill pointer, or is actually adjustable, the corresponding array in the compiled code might lack any or all of these qualities. If an array in the source code has a fill pointer, then the corresponding array in the compiled code might be only the size implied by the fill pointer.

packages: The loader is required to find the corresponding package object as if by calling find-package with the package name as an argument. An error of type package-error is signaled if no package of that name exists at load time.

random-state: A constant random state object cannot be used as the state argument to the function random because random modifies this data structure.

structure, standard-object: Objects of type structure-object and standard-object may appear in compiled constants if there is an appropriate make-load-form method defined for that type.

The file compiler calls make-load-form on any object that is referenced as a literal object if the object is a generalized instance of standard-object, structure-object, condition, or any of a (possibly empty) implementation-dependent set of other classes. The file compiler only calls make-load-form once for any given object within a single file.

symbol: In order to guarantee that compiled files can be loaded correctly, users must ensure that the packages referenced in those files are defined consistently at compile time and load time. Conforming programs must satisfy the following requirements:

1.

The current package when a top level form in the file is processed by compile-file must be the same as the current package when the code corresponding to that top level form in the compiled file is executed by load. In particular:

a.

Any top level form in a file that alters the current package must change it to a package of the same name both at compile time and at load time.

b.

If the first non-atomic top level form in the file is not an in-package form, then the current package at the time load is called must be a package with the same name as the package that was the current package at the time compile-file was called.

2.

For all symbols appearing lexically within a top level form that were accessible in the package that was the current package during processing of that top level form at compile time, but whose home package was another package, at load time there must be a symbol with the same name that is accessible in both the load-time current package and in the package with the same name as the compile-time home package.

3.

For all symbols represented in the compiled file that were external symbols in their home package at compile time, there must be a symbol with the same name that is an external symbol in the package with the same name at load time.

If any of these conditions do not hold, the package in which the loader looks for the affected symbols is unspecified. Implementations are permitted to signal an error or to define this behavior.

Previous: , Up: Literal Objects in Compiled Files  

gcl-2.6.14/info/gcl/error-_0028Condition-Type_0029.html0000644000175000017500000000462714360276512020511 0ustar cammcamm error (Condition Type) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.5 error [Condition Type]

Class Precedence List::

error, serious-condition, condition, t

Description::

The type error consists of all conditions that represent errors.

gcl-2.6.14/info/gcl/Creating-Conditions.html0000644000175000017500000000527014360276512017230 0ustar cammcamm Creating Conditions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Condition System Concepts  

9.1.2 Creating Conditions

The function make-condition can be used to construct a condition object explicitly. Functions such as error, cerror, signal, and warn operate on conditions and might create condition objects implicitly. Macros such as ccase, ctypecase, ecase, etypecase, check-type, and assert might also implicitly create (and signal) conditions.

• Condition Designators  
gcl-2.6.14/info/gcl/Lists-as-Association-Lists.html0000644000175000017500000000501714360276512020431 0ustar cammcamm Lists as Association Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses as Lists  

14.1.2.1 Lists as Association Lists

An association list is a list of conses representing an association of keys with values, where the car of each cons is the key and the cdr is the value associated with that key. 

  acons  assoc-if      pairlis  rassoc-if      
  assoc  assoc-if-not  rassoc   rassoc-if-not  

  Figure 14–4: Some defined names related to assocation lists.
gcl-2.6.14/info/gcl/Package-Inheritance.html0000644000175000017500000000604414360276512017147 0ustar cammcamm Package Inheritance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.4 Package Inheritance

Packages can be built up in layers. From one point of view, a package is a single collection of mappings from strings into internal symbols and external symbols. However, some of these mappings might be established within the package itself, while other mappings are inherited from other packages via use-package. A symbol is said to be present in a package if the mapping is in the package itself and is not inherited from somewhere else.

There is no way to inherit the internal symbols of another package; to refer to an internal symbol using the Lisp reader, a package containing the symbol must be made to be the current package, a package prefix must be used, or the symbol must be imported into the current package.

gcl-2.6.14/info/gcl/Agreement-on-Parameter-Specializers-and-Qualifiers.html0000644000175000017500000000635714360276512025130 0ustar cammcamm Agreement on Parameter Specializers and Qualifiers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.3 Agreement on Parameter Specializers and Qualifiers

Two methods are said to agree with each other on parameter specializers and qualifiers if the following conditions hold:

1.

Both methods have the same number of required parameters. Suppose the parameter specializers of the two methods are P_{1,1}... P_{1,n} and P_{2,1}... P_{2,n}.

2.

For each 1<= i<= n, P_{1,i} agrees with P_{2,i}. The parameter specializer P_{1,i} agrees with P_{2,i} if P_{1,i} and P_{2,i} are the same class or if P_{1,i}=(eql object_1), P_{2,i}=(eql object_2), and (eql object_1 object_2). Otherwise P_{1,i} and P_{2,i} do not agree.

3.

The two lists of qualifiers are the same under equal.

gcl-2.6.14/info/gcl/replace.html0000644000175000017500000001253714360276512015004 0ustar cammcamm replace (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.18 replace [Function]

replace sequence-1 sequence-2 &key start1 end1 start2 end2 ⇒ sequence-1

Arguments and Values::

sequence-1—a sequence.

sequence-2—a sequence.

start1, end1—bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively.

start2, end2—bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively.

Description::

Destructively modifies sequence-1 by replacing the elements of subsequence-1 bounded by start1 and end1 with the elements of subsequence-2 bounded by start2 and end2.

Sequence-1 is destructively modified by copying successive elements into it from sequence-2. Elements of the subsequence of sequence-2 bounded by start2 and end2 are copied into the subsequence of sequence-1 bounded by start1 and end1. If these subsequences are not of the same length, then the shorter length determines how many elements are copied; the extra elements near the end of the longer subsequence are not involved in the operation. The number of elements copied can be expressed as: 

 (min (- end1 start1) (- end2 start2))

If sequence-1 and sequence-2 are the same object and the region being modified overlaps the region being copied from, then it is as if the entire source region were copied to another place and only then copied back into the target region. However, if sequence-1 and sequence-2 are not the same, but the region being modified overlaps the region being copied from (perhaps because of shared list structure or displaced arrays), then after the replace operation the subsequence of sequence-1 being modified will have unpredictable contents. It is an error if the elements of sequence-2 are not of a type that can be stored into sequence-1.

Examples::

 (replace "abcdefghij" "0123456789" :start1 4 :end1 7 :start2 4) 
⇒  "abcd456hij"
 (setq lst "012345678") ⇒  "012345678"
 (replace lst lst :start1 2 :start2 0) ⇒  "010123456"
 lst ⇒  "010123456"

Side Effects::

The sequence-1 is modified.

See Also::

fill

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Cons-Concepts.html0000644000175000017500000000536514360276512016050 0ustar cammcamm Cons Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses  

14.1 Cons Concepts

A cons is a compound data object having two components called the car and the cdr. 

  car  cons    rplacd  
  cdr  rplaca          

  Figure 14–1: Some defined names relating to conses.

Depending on context, a group of connected conses can be viewed in a variety of different ways. A variety of operations is provided to support each of these various views.

• Conses as Trees  
• Conses as Lists  
gcl-2.6.14/info/gcl/The-_0022Examples_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000542014360276512024410 0ustar cammcamm The "Examples" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.13 The "Examples" Section of a Dictionary Entry

Examples of use of the operator. These examples are not considered part of the standard; see Sections Not Formally Part Of This Standard.

gcl-2.6.14/info/gcl/Interactive-Streams.html0000644000175000017500000000674614360276512017267 0ustar cammcamm Interactive Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.4 Interactive Streams

An interactive stream is one on which it makes sense to perform interactive querying.

The precise meaning of an interactive stream is implementation-defined, and may depend on the underlying operating system. Some examples of the things that an implementation might choose to use as identifying characteristics of an interactive stream include:

*

The stream is connected to a person (or equivalent) in such a way that the program can prompt for information and expect to receive different input depending on the prompt.

*

The program is expected to prompt for input and support “normal input editing”.

*

read-char might wait for the user to type something before returning instead of immediately returning a character or end-of-file.

The general intent of having some streams be classified as interactive streams is to allow them to be distinguished from streams containing batch (or background or command-file) input. Output to batch streams is typically discarded or saved for later viewing, so interactive queries to such streams might not have the expected effect.

Terminal I/O might or might not be an interactive stream.

gcl-2.6.14/info/gcl/_002b.html0000644000175000017500000000625014360276512014166 0ustar cammcamm + (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.25 + [Function]

+ &rest numbers ⇒ sum

Arguments and Values::

number—a number.

sum—a number.

Description::

Returns the sum of numbers, performing any necessary type conversions in the process. If no numbers are supplied, 0 is returned.

Examples::

 (+) ⇒  0
 (+ 1) ⇒  1
 (+ 31/100 69/100) ⇒  1
 (+ 1/5 0.8) ⇒  1.0

Exceptional Situations::

Might signal type-error if some argument is not a number. Might signal arithmetic-error.

See Also::

Numeric Operations, Rational Computations, Floating-point Computations, Complex Computations

gcl-2.6.14/info/gcl/Filenames.html0000644000175000017500000000503414360276512015266 0ustar cammcamm Filenames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

19 Filenames

• Overview of Filenames  
• Pathnames  
• Logical Pathnames  
• Filenames Dictionary  
gcl-2.6.14/info/gcl/Conses-Dictionary.html0000644000175000017500000002237514360276512016727 0ustar cammcamm Conses Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Conses  

14.2 Conses Dictionary

• list (System Class)  
• null (System Class)  
• cons (System Class)  
• atom (Type)  
• cons  
• consp  
• atom  
• rplaca  
• car  
• copy-tree  
• sublis  
• subst  
• tree-equal  
• copy-list  
• list (Function)  
• list-length  
• listp  
• make-list  
• push  
• pop  
• first  
• nth  
• endp  
• null  
• nconc  
• append  
• revappend  
• butlast  
• last  
• ldiff  
• nthcdr  
• rest  
• member (Function)  
• mapc  
• acons  
• assoc  
• copy-alist  
• pairlis  
• rassoc  
• get-properties  
• getf  
• remf  
• intersection  
• adjoin  
• pushnew  
• set-difference  
• set-exclusive-or  
• subsetp  
• union  

Previous: , Up: Conses  

gcl-2.6.14/info/gcl/File-Streams.html0000644000175000017500000000531014360276512015653 0ustar cammcamm File Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Streams  

21.1.1.6 File Streams

Some streams, called file streams , provide access to files. An object of class file-stream is used to represent a file stream.

The basic operation for opening a file is open, which typically returns a file stream (see its dictionary entry for details). The basic operation for closing a stream is close. The macro with-open-file is useful to express the common idiom of opening a file for the duration of a given body of code, and assuring that the resulting stream is closed upon exit from that body.

gcl-2.6.14/info/gcl/Evaluation-and-Compilation.html0000644000175000017500000000667314360276512020520 0ustar cammcamm Evaluation and Compilation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

3 Evaluation and Compilation

• Evaluation  
• Compilation  
• Declarations  
• Lambda Lists  
• Error Checking in Function Calls  
• Traversal Rules and Side Effects  
• Destructive Operations  
• Evaluation and Compilation Dictionary  
gcl-2.6.14/info/gcl/Loading.html0000644000175000017500000000621414360276512014741 0ustar cammcamm Loading (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Concepts  

24.1.1 Loading

To load a file is to treat its contents as code and execute that code. The file may contain source code or compiled code .

A file containing source code is called a source file . Loading a source file is accomplished essentially by sequentially reading_2 the forms in the file, evaluating each immediately after it is read.

A file containing compiled code is called a compiled file . Loading a compiled file is similar to loading a source file, except that the file does not contain text but rather an implementation-dependent representation of pre-digested expressions created by the compiler. Often, a compiled file can be loaded more quickly than a source file. See Compilation.

The way in which a source file is distinguished from a compiled file is implementation-dependent.

gcl-2.6.14/info/gcl/with_002dinput_002dfrom_002dstring.html0000644000175000017500000001377014360276512021536 0ustar cammcamm with-input-from-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.51 with-input-from-string [Macro]

with-input-from-string (var string &key index start end) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

var—a variable name.

string—a form; evaluated to produce a string.

index—a place.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

result—the values returned by the forms.

Description::

Creates an

input string stream,

provides an opportunity to perform operations on the stream (returning zero or more values), and then closes the string stream.

String is evaluated first, and var is bound to a character input string stream that supplies characters from the subsequence of the resulting string bounded by start and end. The body is executed as an implicit progn.

The input string stream is automatically closed on exit from with-input-from-string, no matter whether the exit is normal or abnormal.

The input string stream to which the variable var is bound has dynamic extent; its extent ends when the form is exited.

The index is a pointer within the string to be advanced. If with-input-from-string is exited normally, then index will have as its value the index into the string indicating the first character not read which is (length string) if all characters were used. The place specified by index is not updated as reading progresses, but only at the end of the operation.

start and index may both specify the same variable, which is a pointer within the string to be advanced, perhaps repeatedly by some containing loop.

The consequences are undefined if an attempt is made to assign the variable var.

Examples::

 (with-input-from-string (s "XXX1 2 3 4xxx"
                             :index ind
                             :start 3 :end 10)
    (+ (read s) (read s) (read s))) ⇒  6
 ind ⇒  9
 (with-input-from-string (s "Animal Crackers" :index j :start 6)
   (read s)) ⇒  CRACKERS

The variable j is set to 15.

Side Effects::

The value of the place named by index, if any, is modified.

See Also::

make-string-input-stream ,

Traversal Rules and Side Effects

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/allocate_002dinstance.html0000644000175000017500000001076614360276512017431 0ustar cammcamm allocate-instance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.3 allocate-instance [Standard Generic Function]

Syntax::

allocate-instance class &rest initargs &key &allow-other-keys ⇒ new-instance

Method Signatures::

allocate-instance (class standard-class) &rest initargs

allocate-instance (class structure-class) &rest initargs

Arguments and Values::

class—a class.

initargs—a list of keyword/value pairs (initialization argument names and values).

new-instance—an object whose class is class.

Description::

The generic function allocate-instance creates and returns a new instance of the class, without initializing it. When the class is a standard class, this means that the slots are unbound; when the class is a structure class, this means the slots’ values are unspecified.

The caller of allocate-instance is expected to have already checked the initialization arguments.

The generic function allocate-instance is called by make-instance, as described in Object Creation and Initialization.

See Also::

defclass , make-instance , class-of , Object Creation and Initialization

Notes::

The consequences of adding methods to allocate-instance is unspecified. This capability might be added by the Metaobject Protocol.

gcl-2.6.14/info/gcl/Compiling-Format-Strings.html0000644000175000017500000000517014360276512020162 0ustar cammcamm Compiling Format Strings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pretty Printer Concepts  

22.2.1.3 Compiling Format Strings

A format string is essentially a program in a special-purpose language that performs printing, and that is interpreted by the function format. The formatter macro provides the efficiency of using a compiled function to do that same printing but without losing the textual compactness of format strings.

A format control is either a format string or a function that was returned by the the formatter macro.

gcl-2.6.14/info/gcl/boundp.html0000644000175000017500000000667214360276512014663 0ustar cammcamm boundp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.17 boundp [Function]

boundp symbol ⇒ generalized-boolean

Arguments and Values::

symbol—a symbol.

generalized-boolean—a generalized boolean.

Description::

Returns true if symbol is bound; otherwise, returns false.

Examples::

 (setq x 1) ⇒  1
 (boundp 'x) ⇒  true
 (makunbound 'x) ⇒  X
 (boundp 'x) ⇒  false
 (let ((x 2)) (boundp 'x)) ⇒  false
 (let ((x 2)) (declare (special x)) (boundp 'x)) ⇒  true

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

set , setq , symbol-value , makunbound

Notes::

The function bound determines only whether a symbol has a value in the global environment; any lexical bindings are ignored.

gcl-2.6.14/info/gcl/make_002ddispatch_002dmacro_002dcharacter.html0000644000175000017500000000737314360276512022726 0ustar cammcamm make-dispatch-macro-character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.3 make-dispatch-macro-character [Function]

make-dispatch-macro-character char &optional non-terminating-p readtable ⇒ t

Arguments and Values::

char—a character.

non-terminating-p—a generalized boolean. The default is false.

readtable—a readtable. The default is the current readtable.

Description::

make-dispatch-macro-character makes char be a dispatching macro character in readtable.

Initially, every character in the dispatch table associated with the char has an associated function that signals an error of type reader-error.

If non-terminating-p is true, the dispatching macro character is made a non-terminating macro character; if non-terminating-p is false, the dispatching macro character is made a terminating macro character.

Examples::

 (get-macro-character #\{) ⇒  NIL, false
 (make-dispatch-macro-character #\{) ⇒  T
 (not (get-macro-character #\{)) ⇒  false

The readtable is altered.

See Also::

readtable , set-dispatch-macro-character

gcl-2.6.14/info/gcl/Meta_002dObjects.html0000644000175000017500000000507714360276512016317 0ustar cammcamm Meta-Objects (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.4 Meta-Objects

The implementation of the object system manipulates classes, methods, and generic functions. The object system contains a set of generic functions defined by methods on classes; the behavior of those generic functions defines the behavior of the object system. The instances of the classes on which those methods are defined are called meta-objects.

• Standard Meta-objects  
gcl-2.6.14/info/gcl/constantp.html0000644000175000017500000001432614360276512015400 0ustar cammcamm constantp (ANSI and GNU Common Lisp Document)

Previous: , Up: Evaluation and Compilation Dictionary  

3.8.30 constantp [Function]

constantp form &optional environment ⇒ generalized-boolean

Arguments and Values::

form—a form.

environment—an environment object. The default is nil.

generalized-boolean—a generalized boolean.

Description::

Returns true if form can be determined by the implementation to be a constant form in the indicated environment; otherwise, it returns false indicating either that the form is not a constant form or that it cannot be determined whether or not form is a constant form.

The following kinds of forms are considered constant forms:

*

Self-evaluating objects (such as numbers, characters, and the various kinds of arrays) are always considered constant forms and must be recognized as such by constantp.

*

Constant variables, such as keywords, symbols defined by Common Lisp as constant (such as nil, t, and pi), and symbols declared as constant by the user in the indicated environment using defconstant are always considered constant forms and must be recognized as such by constantp.

*

quote forms are always considered constant forms and must be recognized as such by constantp.

*

An implementation is permitted, but not required, to detect additional constant forms. If it does, it is also permitted, but not required, to make use of information in the environment. Examples of constant forms for which constantp might or might not return true are: (sqrt pi), (+ 3 2), (length '(a b c)), and (let ((x 7)) (zerop x)).

If an implementation chooses to make use of the environment information, such actions as expanding macros or performing function inlining are permitted to be used, but not required; however, expanding compiler macros is not permitted.

Examples::

 (constantp 1) ⇒  true
 (constantp 'temp) ⇒  false
 (constantp ''temp)) ⇒  true
 (defconstant this-is-a-constant 'never-changing) ⇒  THIS-IS-A-CONSTANT 
 (constantp 'this-is-a-constant) ⇒  true
 (constantp "temp") ⇒  true
 (setq a 6) ⇒  6 
 (constantp a) ⇒  true
 (constantp '(sin pi)) ⇒  implementation-dependent
 (constantp '(car '(x))) ⇒  implementation-dependent
 (constantp '(eql x x)) ⇒  implementation-dependent
 (constantp '(typep x 'nil)) ⇒  implementation-dependent
 (constantp '(typep x 't)) ⇒  implementation-dependent
 (constantp '(values this-is-a-constant)) ⇒  implementation-dependent
 (constantp '(values 'x 'y)) ⇒  implementation-dependent
 (constantp '(let ((a '(a b c))) (+ (length a) 6))) ⇒  implementation-dependent

Affected By::

The state of the global environment (e.g., which symbols have been declared to be the names of constant variables).

See Also::

defconstant

Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/The-Pathname-Directory-Component.html0000644000175000017500000000437014360276512021542 0ustar cammcamm The Pathname Directory Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathname Components  

19.2.1.3 The Pathname Directory Component

Corresponds to the “directory” concept in many host file systems: the name of a group of related files.

gcl-2.6.14/info/gcl/Minimal-Declaration-Processing-Requirements.html0000644000175000017500000000651114360276512023770 0ustar cammcamm Minimal Declaration Processing Requirements (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Declarations  

3.3.1 Minimal Declaration Processing Requirements

In general, an implementation is free to ignore declaration specifiers except for the declaration , notinline , safety , and special declaration specifiers.

A declaration declaration must suppress warnings about unrecognized declarations of the kind that it declares. If an implementation does not produce warnings about unrecognized declarations, it may safely ignore this declaration.

A notinline declaration must be recognized by any implementation that supports inline functions or compiler macros in order to disable those facilities. An implementation that does not use inline functions or compiler macros may safely ignore this declaration.

A safety declaration that increases the current safety level must always be recognized. An implementation that always processes code as if safety were high may safely ignore this declaration.

A special declaration must be processed by all implementations.

gcl-2.6.14/info/gcl/Invalid-Keyword-Arguments.html0000644000175000017500000000516014360276512020336 0ustar cammcamm Invalid Keyword Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.6 Invalid Keyword Arguments

It is not permitted to supply a keyword argument to a function using a name that is not a symbol.

If this situation occurs in a safe call,

an error of type program-error must be signaled unless keyword argument checking is suppressed as described in Suppressing Keyword Argument Checking; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/hash_002dtable_002dtest.html0000644000175000017500000000626014360276512017472 0ustar cammcamm hash-table-test (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.8 hash-table-test [Function]

hash-table-test hash-table ⇒ test

Arguments and Values::

hash-table—a hash table.

test—a function designator. For the four standardized hash table test functions (see make-hash-table), the test value returned is always a symbol. If an implementation permits additional tests, it is implementation-dependent whether such tests are returned as function objects or function names.

Description::

Returns the test used for comparing keys in hash-table.

Exceptional Situations::

Should signal an error of type type-error if hash-table is not a hash table.

See Also::

make-hash-table

gcl-2.6.14/info/gcl/Signaling-and-Handling-Conditions.html0000644000175000017500000001402014360276512021662 0ustar cammcamm Signaling and Handling Conditions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Condition System Concepts  

9.1.4 Signaling and Handling Conditions

The operation of the condition system depends on the ordering of active applicable handlers from most recent to least recent.

Each handler is associated with a type specifier that must designate a subtype of type condition. A handler is said to be applicable to a condition if that condition is of the type designated by the associated type specifier.

Active handlers are established by using handler-bind (or an abstraction based on handler-bind, such as handler-case or ignore-errors).

Active handlers can be established within the dynamic scope of other active handlers. At any point during program execution, there is a set of active handlers. When a condition is signaled, the most recent active applicable handler for that condition is selected from this set. Given a condition, the order of recentness of active applicable handlers is defined by the following two rules:

1.

Each handler in a set of active handlers H_1 is more recent than every handler in a set H_2 if the handlers in H_2 were active when the handlers in H_1 were established.

2.

Let h_1 and h_2 be two applicable active handlers established by the same form. Then h_1 is more recent than h_2 if h_1 was defined to the left of h_2 in the form that established them.

Once a handler in a handler binding form (such as handler-bind or handler-case) has been selected, all handlers in that form become inactive for the remainder of the signaling process. While the selected handler runs, no other handler established by that form is active. That is, if the handler declines, no other handler established by that form will be considered for possible invocation.

Figure 9–4 shows operators relating to the handling of conditions. 

  handler-bind  handler-case  ignore-errors  

  Figure 9–4: Operators relating to handling conditions.
• Signaling  
• Resignaling a Condition  
• Restarts  
• Interactive Use of Restarts  
• Interfaces to Restarts  
• Restart Tests  
• Associating a Restart with a Condition  

Next: , Previous: , Up: Condition System Concepts  

gcl-2.6.14/info/gcl/Digits-in-a-Radix.html0000644000175000017500000000533214360276512016476 0ustar cammcamm Digits in a Radix (ANSI and GNU Common Lisp Document)

Previous: , Up: Character Categories  

13.1.4.10 Digits in a Radix

What qualifies as a digit depends on the radix (an integer between 2 and 36, inclusive). The potential digits are:

0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z

Their respective weights are 0, 1, 2, ... 35. In any given radix n, only the first n potential digits are considered to be digits. For example, the digits in radix 2 are 0 and 1, the digits in radix 10 are 0 through 9, and the digits in radix 16 are 0 through F.

Case is not significant in digits; for example, in radix 16, both F and f are digits with weight 15.

gcl-2.6.14/info/gcl/concatenated_002dstream_002dstreams.html0000644000175000017500000000572414360276512022106 0ustar cammcamm concatenated-stream-streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.46 concatenated-stream-streams [Function]

concatenated-stream-streams concatenated-stream ⇒ streams

Arguments and Values::

concatenated-stream – a concatenated stream.

streams—a list of input streams.

Description::

Returns a list of input streams that constitute the ordered set of streams the concatenated-stream still has to read from, starting with the current one it is reading from. The list may be empty if no more streams remain to be read.

The consequences are undefined if the list structure of the streams is ever modified.

gcl-2.6.14/info/gcl/get_002dinternal_002drun_002dtime.html0000644000175000017500000000731614360276512021307 0ustar cammcamm get-internal-run-time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.13 get-internal-run-time [Function]

get-internal-run-time <no arguments> ⇒ internal-time

Arguments and Values::

internal-time—a non-negative integer.

Description::

Returns as an integer the current run time in internal time units. The precise meaning of this quantity is implementation-defined; it may measure real time, run time, CPU cycles, or some other quantity. The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which computational effort was expended on behalf of the executing program.

Affected By::

The implementation, the time of day (i.e., the passage of time).

See Also::

internal-time-units-per-second

Notes::

Depending on the implementation, paging time and garbage collection time might be included in this measurement. Also, in a multitasking environment, it might not be possible to show the time for just the running process, so in some implementations, time taken by other processes during the same time interval might be included in this measurement as well.

gcl-2.6.14/info/gcl/structure_002dobject.html0000644000175000017500000000547414360276512017347 0ustar cammcamm structure-object (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.13 structure-object [Class]

Class Precedence List::

structure-object, t

Description::

The class structure-object is an instance of structure-class and is a superclass of every class that is an instance of structure-class except itself, and is a superclass of every class that is defined by defstruct.

See Also::

defstruct , Sharpsign S, Printing Structures

gcl-2.6.14/info/gcl/Resignaling-a-Condition.html0000644000175000017500000000602514360276512017770 0ustar cammcamm Resignaling a Condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.2 Resignaling a Condition

During the dynamic extent of the signaling process for a particular condition object, signaling the same condition object again is permitted if and only if the situation represented in both cases are the same.

For example, a handler might legitimately signal the condition object that is its argument in order to allow outer handlers first opportunity to handle the condition. (Such a handlers is sometimes called a “default handler.”) This action is permitted because the situation which the second signaling process is addressing is really the same situation.

On the other hand, in an implementation that implemented asynchronous keyboard events by interrupting the user process with a call to signal, it would not be permissible for two distinct asynchronous keyboard events to signal identical condition objects at the same time for different situations.

gcl-2.6.14/info/gcl/Local-Variable-Initializations.html0000644000175000017500000001305414360276512021311 0ustar cammcamm Local Variable Initializations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.15 Local Variable Initializations

When a loop form is executed, the local variables are bound and are initialized to some value. These local variables exist until loop iteration terminates, at which point they cease to exist. Implicit variables are also established by iteration control clauses and the into preposition of accumulation clauses.

The with construct initializes variables that are local to a loop. The variables are initialized one time only. If the optional type-spec argument is supplied for the variable var, but there is no related expression to be evaluated, var is initialized to an appropriate default value for its type. For example, for the types t, number, and float, the default values are nil, 0, and 0.0 respectively. The consequences are undefined if a type-spec argument is supplied for var if the related expression returns a value that is not of the supplied type. By default, the with construct initializes variables sequentially; that is, one variable is assigned a value before the next expression is evaluated. However, by using the loop keyword and to join several with clauses, initializations can be forced to occur in parallel; that is, all of the supplied forms are evaluated, and the results are bound to the respective variables simultaneously.

Sequential binding is used when it is desireable for the initialization of some variables to depend on the values of previously bound variables. For example, suppose the variables a, b, and c are to be bound in sequence: 

 (loop with a = 1 
       with b = (+ a 2) 
       with c = (+ b 3)
       return (list a b c))
⇒  (1 3 6)

The execution of the above loop is equivalent to the execution of the following code: 

 (block nil
   (let* ((a 1)
          (b (+ a 2))
          (c (+ b 3)))
     (tagbody
         (next-loop (return (list a b c))
                    (go next-loop)
                    end-loop))))

If the values of previously bound variables are not needed for the initialization of other local variables, an and clause can be used to specify that the bindings are to occur in parallel: 

 (loop with a = 1 
       and b = 2 
       and c = 3
       return (list a b c))
⇒  (1 2 3)

The execution of the above loop is equivalent to the execution of the following code: 

 (block nil
   (let ((a 1)
         (b 2)
         (c 3))
     (tagbody
         (next-loop (return (list a b c))
                    (go next-loop)
                    end-loop))))

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Device-Component.html0000644000175000017500000000600214360276512025504 0ustar cammcamm Restrictions on Examining a Pathname Device Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.14 Restrictions on Examining a Pathname Device Component

The device might be a string, :wild, :unspecific, or nil.

Note that :wild might result from an attempt to read_1 the pathname component, even though portable programs are restricted from writing_1 such a component value; see Restrictions on Wildcard Pathnames and Restrictions on Constructing Pathnames.

gcl-2.6.14/info/gcl/Classes.html0000644000175000017500000000772714360276512014773 0ustar cammcamm Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes  

4.3 Classes

While the object system is general enough to describe all standardized classes (including, for example, number, hash-table, and symbol), Figure 4–7 contains a list of classes that are especially relevant to understanding the object system. 

  built-in-class    method-combination         standard-object   
  class             standard-class             structure-class   
  generic-function  standard-generic-function  structure-object  
  method            standard-method                              

                Figure 4–7: Object System Classes
• Introduction to Classes  
• Defining Classes  
• Creating Instances of Classes  
• Inheritance  
• Determining the Class Precedence List  
• Redefining Classes  
• Integrating Types and Classes  
gcl-2.6.14/info/gcl/cis.html0000644000175000017500000000542614360276512014146 0ustar cammcamm cis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.45 cis [Function]

cis radians ⇒ number

Arguments and Values::

radians—a real.

number—a complex.

Description::

cis returns the value of~e^i\cdot radians, which is a complex in which the real part is equal to the cosine of radians, and the imaginary part is equal to the sine of radians.

Examples::

 (cis 0) ⇒  #C(1.0 0.0)

See Also::

Rule of Float Substitutability

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Name-Component.html0000644000175000017500000000514314360276512025172 0ustar cammcamm Restrictions on Examining a Pathname Name Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.17 Restrictions on Examining a Pathname Name Component

The name might be a string, :wild, :unspecific, or nil.

gcl-2.6.14/info/gcl/The-Pathname-Name-Component.html0000644000175000017500000000433114360276512020453 0ustar cammcamm The Pathname Name Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathname Components  

19.2.1.4 The Pathname Name Component

The “name” part of a group of files that can be thought of as conceptually related.

gcl-2.6.14/info/gcl/Interpretation-of-Tokens.html0000644000175000017500000000615214360276512020237 0ustar cammcamm Interpretation of Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax  

2.3 Interpretation of Tokens

• Numbers as Tokens  
• Constructing Numbers from Tokens  
• The Consing Dot  
• Symbols as Tokens  
• Valid Patterns for Tokens  
• Package System Consistency Rules  
gcl-2.6.14/info/gcl/Inheritance.html0000644000175000017500000000527014360276512015616 0ustar cammcamm Inheritance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Classes  

4.3.4 Inheritance

A class can inherit methods, slots, and some defclass options from its superclasses. Other sections describe the inheritance of methods, the inheritance of slots and slot options, and the inheritance of class options.

• Examples of Inheritance  
• Inheritance of Class Options  
gcl-2.6.14/info/gcl/Examples-of-Sharpsign-Asterisk.html0000644000175000017500000000456614360276512021273 0ustar cammcamm Examples of Sharpsign Asterisk (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.5 Examples of Sharpsign Asterisk

For example, 

  #*101111
 #6*101111
 #6*101
 #6*1011

all mean the same thing: a vector of length 6 with elements 1, 0, 1, 1, 1, and 1.

For example: 

 #*         ;An empty bit-vector
gcl-2.6.14/info/gcl/Sharpsign-Colon.html0000644000175000017500000000471214360276512016373 0ustar cammcamm Sharpsign Colon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.6 Sharpsign Colon

Syntax: #:<<symbol-name>>

#: introduces an uninterned symbol whose name is symbol-name. Every time this syntax is encountered, a distinct uninterned symbol is created. The symbol-name must have the syntax of a symbol with no package prefix.

For information on how the Lisp reader prints uninterned symbols, see Printing Symbols.

gcl-2.6.14/info/gcl/call_002dnext_002dmethod.html0000644000175000017500000001472614360276512017660 0ustar cammcamm call-next-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.31 call-next-method [Local Function]

Syntax::

call-next-method &rest args ⇒ {result}*

Arguments and Values::

arg—an object.

results—the values returned by the method it calls.

Description::

The function call-next-method can be used

within the body forms (but not the lambda list)

of a method defined by a method-defining form to call the next method.

If there is no next method, the generic function no-next-method is called.

The type of method combination used determines which methods can invoke call-next-method. The standard method combination type allows call-next-method to be used within primary methods and around methods. For generic functions using a type of method combination defined by the short form of define-method-combination, call-next-method can be used in around methods only.

When call-next-method is called with no arguments, it passes the current method’s original arguments to the next method. Neither argument defaulting, nor using setq, nor rebinding variables with the same names as parameters of the method affects the values call-next-method passes to the method it calls.

When call-next-method is called with arguments, the next method is called with those arguments.

If call-next-method is called with arguments but omits optional arguments, the next method called defaults those arguments.

The function call-next-method returns any values that are returned by the next method.

The function call-next-method has lexical scope and indefinite extent and can only be used within the body of a method defined by a method-defining form.

Whether or not call-next-method is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of call-next-method are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use call-next-method outside of a method-defining form are undefined.

Affected By::

defmethod, call-method, define-method-combination.

Exceptional Situations::

When providing arguments to call-next-method, the following rule must be satisfied or an error of type error should be signaled: the ordered set of applicable methods for a changed set of arguments for call-next-method must be the same as the ordered set of applicable methods for the original arguments to the generic function. Optimizations of the error checking are possible, but they must not change the semantics of call-next-method.

See Also::

define-method-combination , defmethod , next-method-p , no-next-method , call-method , Method Selection and Combination, Standard Method Combination, Built-in Method Combination Types

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/_002aprint_002dbase_002a.html0000644000175000017500000001263414360276512017347 0ustar cammcamm *print-base* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.17 *print-base*, *print-radix* [Variable]

Value Type::

*print-base*—a radix. *print-radix*—a generalized boolean.

Initial Value::

The initial value of *print-base* is 10. The initial value of *print-radix* is false.

Description::

*print-base* and *print-radix* control the printing of rationals. The value of *print-base* is called the current output base .

The value of *print-base* is the radix in which the printer will print rationals. For radices above 10, letters of the alphabet are used to represent digits above 9.

If the value of *print-radix* is true, the printer will print a radix specifier to indicate the radix in which it is printing a rational number. The radix specifier is always printed using lowercase letters. If *print-base* is 2, 8, or 16, then the radix specifier used is #b, #o, or #x, respectively. For integers, base ten is indicated by a trailing decimal point instead of a leading radix specifier; for ratios, #10r is used.

Examples::

 (let ((*print-base* 24.) (*print-radix* t)) 
   (print 23.))
 |>  #24rN
⇒  23
 (setq *print-base* 10) ⇒  10
 (setq *print-radix* nil) ⇒  NIL                                          
 (dotimes (i 35)
    (let ((*print-base* (+ i 2)))           ;print the decimal number 40 
      (write 40)                            ;in each base from 2 to 36
      (if (zerop (mod i 10)) (terpri) (format t " "))))
 |>  101000
 |>  1111 220 130 104 55 50 44 40 37 34
 |>  31 2C 2A 28 26 24 22 20 1J 1I
 |>  1H 1G 1F 1E 1D 1C 1B 1A 19 18
 |>  17 16 15 14 
⇒  NIL
 (dolist (pb '(2 3 8 10 16))               
    (let ((*print-radix* t)                 ;print the integer 10 and 
          (*print-base* pb))                ;the ratio 1/10 in bases 2, 
     (format t "~&~S  ~S~
 |>  #b1010  #b1/1010
 |>  #3r101  #3r1/101
 |>  #o12  #o1/12
 |>  10.  #10r1/10
 |>  #xA  #x1/A
⇒  NIL

Affected By::

Might be bound by format, and write, write-to-string.

See Also::

format , write , write-to-string

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/maphash.html0000644000175000017500000001042114360276512015000 0ustar cammcamm maphash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.11 maphash [Function]

maphash function hash-table ⇒ nil

Arguments and Values::

function—a designator for a function of two arguments, the key and the value.

hash-table—a hash table.

Description::

Iterates over all entries in the hash-table. For each entry, the function is called with two arguments–the key and the value of that entry.

The consequences are unspecified if any attempt is made to add or remove an entry from the hash-table while a maphash is in progress, with two exceptions: the function can use can use setf of gethash to change the value part of the entry currently being processed, or it can use remhash to remove that entry.

Examples::

 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32304110>
 (dotimes (i 10) (setf (gethash i table) i)) ⇒  NIL
 (let ((sum-of-squares 0))
    (maphash #'(lambda (key val) 
                 (let ((square (* val val)))
                   (incf sum-of-squares square)
                   (setf (gethash key table) square)))
             table)
    sum-of-squares) ⇒  285
 (hash-table-count table) ⇒  10
 (maphash #'(lambda (key val)
               (when (oddp val) (remhash key table)))
           table) ⇒  NIL
 (hash-table-count table) ⇒  5
 (maphash #'(lambda (k v) (print (list k v))) table)
(0 0) 
(8 64) 
(2 4) 
(6 36) 
(4 16) 
⇒  NIL

Side Effects::

None, other than any which might be done by the function.

See Also::

loop , with-hash-table-iterator ,

Traversal Rules and Side Effects

gcl-2.6.14/info/gcl/if.html0000644000175000017500000000742414360276512013766 0ustar cammcamm if (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.43 if [Special Operator]

if test-form then-form [else-form] ⇒ {result}*

Arguments and Values::

Test-form—a form.

Then-form—a form.

Else-form—a form. The default is nil.

results—if the test-form yielded true, the values returned by the then-form; otherwise, the values returned by the else-form.

Description::

if allows the execution of a form to be dependent on a single test-form.

First test-form is evaluated. If the result is true, then then-form is selected; otherwise else-form is selected. Whichever form is selected is then evaluated.

Examples::

 (if t 1) ⇒  1
 (if nil 1 2) ⇒  2 
 (defun test ()
   (dolist (truth-value '(t nil 1 (a b c)))
     (if truth-value (print 'true) (print 'false))
     (prin1 truth-value))) ⇒  TEST
 (test)
 |>  TRUE T
 |>  FALSE NIL
 |>  TRUE 1
 |>  TRUE (A B C)
⇒  NIL

See Also::

cond , unless, when

Notes::

 (if test-form then-form else-form)
 ≡ (cond (test-form then-form) (t else-form))
gcl-2.6.14/info/gcl/File-System-Concepts.html0000644000175000017500000000721114360276512017277 0ustar cammcamm File System Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files  

20.1 File System Concepts

This section describes the Common Lisp interface to file systems. The model used by this interface assumes that files are named by filenames , that a filename can be represented by a pathname object, and that given a pathname a stream can be constructed that connects to a file whose filename it represents.

For information about opening and closing files, and manipulating their contents, see Streams.

Figure 20–1 lists some operators that are applicable to files and directories. 

  compile-file  file-length      open            
  delete-file   file-position    probe-file      
  directory     file-write-date  rename-file     
  file-author   load             with-open-file  

    Figure 20–1: File and Directory Operations
• Coercion of Streams to Pathnames  
• File Operations on Open and Closed Streams  
• Truenames  
gcl-2.6.14/info/gcl/Printer-Escaping.html0000644000175000017500000000567514360276512016550 0ustar cammcamm Printer Escaping (ANSI and GNU Common Lisp Document)

Previous: , Up: Overview of The Lisp Printer  

22.1.1.2 Printer Escaping

The variable *print-escape* controls whether the Lisp printer tries to produce notations such as escape characters and package prefixes.

The variable *print-readably* can be used to override many of the individual aspects controlled by the other printer control variables when program-readable output is especially important.

One of the many effects of making the value of *print-readably* be true is that the Lisp printer behaves as if *print-escape* were also true. For notational convenience, we say that if the value of either *print-readably* or *print-escape* is true, then printer escaping is “enabled”; and we say that if the values of both *print-readably* and *print-escape* are false, then printer escaping is “disabled”.

gcl-2.6.14/info/gcl/array_002drank.html0000644000175000017500000000626014360276512016104 0ustar cammcamm array-rank (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.17 array-rank [Function]

array-rank array ⇒ rank

Arguments and Values::

array—an array.

rank—a non-negative integer.

Description::

Returns the number of dimensions of array.

Examples::

 (array-rank (make-array '())) ⇒  0
 (array-rank (make-array 4)) ⇒  1
 (array-rank (make-array '(4))) ⇒  1
 (array-rank (make-array '(2 3))) ⇒  2

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

array-rank-limit , make-array

gcl-2.6.14/info/gcl/with_002dhash_002dtable_002diterator.html0000644000175000017500000001470514360276512021770 0ustar cammcamm with-hash-table-iterator (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Hash Tables Dictionary  

18.2.12 with-hash-table-iterator [Macro]

with-hash-table-iterator (name hash-table) {declaration}* {form}* ⇒ {result}*

Arguments and Values::

name—a name suitable for the first argument to macrolet.

hash-table—a form, evaluated once, that should produce a hash table.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by forms.

Description::

Within the lexical scope of the body, name is defined via macrolet such that successive invocations of (name) return the items, one by one, from the hash table that is obtained by evaluating hash-table only once.

An invocation (name) returns three values as follows:

1.

A generalized boolean that is true if an entry is returned.

2.

The key from the hash-table entry.

3.

The value from the hash-table entry.

After all entries have been returned by successive invocations of (name), then only one value is returned, namely nil.

It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the with-hash-table-iterator form such as by returning some closure over the invocation form.

Any number of invocations of with-hash-table-iterator can be nested, and the body of the innermost one can invoke all of the locally established macros, provided all of those macros have distinct names.

Examples::

The following function should return t on any hash table, and signal an error if the usage of with-hash-table-iterator does not agree with the corresponding usage of maphash. 

 (defun test-hash-table-iterator (hash-table)
   (let ((all-entries '())
         (generated-entries '())
         (unique (list nil)))
     (maphash #'(lambda (key value) (push (list key value) all-entries))
              hash-table)
     (with-hash-table-iterator (generator-fn hash-table)
       (loop     
         (multiple-value-bind (more? key value) (generator-fn)
           (unless more? (return))
           (unless (eql value (gethash key hash-table unique))
             (error "Key ~S not found for value ~S" key value))
           (push (list key value) generated-entries))))
     (unless (= (length all-entries)
                (length generated-entries)
                (length (union all-entries generated-entries
                               :key #'car :test (hash-table-test hash-table))))
       (error "Generated entries and Maphash entries don't correspond"))
     t))

The following could be an acceptable definition of maphash, implemented by with-hash-table-iterator. 

 (defun maphash (function hash-table)
   (with-hash-table-iterator (next-entry hash-table)
     (loop (multiple-value-bind (more key value) (next-entry)
             (unless more (return nil))
             (funcall function key value)))))

Exceptional Situations::

The consequences are undefined if the local function named name established by with-hash-table-iterator is called after it has returned false as its primary value.

See Also::

Traversal Rules and Side Effects

Next: , Previous: , Up: Hash Tables Dictionary  

gcl-2.6.14/info/gcl/Define_002dmethod_002dcombination-Arguments-Lambda-Lists.html0000644000175000017500000000632414360276512025673 0ustar cammcamm Define-method-combination Arguments Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.10 Define-method-combination Arguments Lambda Lists

A define-method-combination arguments lambda list is used by the :arguments option to define-method-combination.

A define-method-combination arguments lambda list can contain the lambda list keywords shown in Figure 3–21. 

  &allow-other-keys  &key       &rest   
  &aux               &optional  &whole  

  Figure 3–21: Lambda List Keywords used by Define-method-combination arguments Lambda Lists

Define-method-combination arguments lambda lists are similar to ordinary lambda lists, but also permit the use of &whole.

gcl-2.6.14/info/gcl/Tilde-Dollarsign_002d_003e-Monetary-Floating_002dPoint.html0000644000175000017500000001156014360276512025071 0ustar cammcamm Tilde Dollarsign-> Monetary Floating-Point (ANSI and GNU Common Lisp Document)

Previous: , Up: FORMAT Floating-Point Printers  

22.3.3.4 Tilde Dollarsign: Monetary Floating-Point

The next arg is printed as a float in fixed-format notation.

The full form is ~d,n,w,padchar$. The parameter d is the number of digits to print after the decimal point (default value 2); n is the minimum number of digits to print before the decimal point (default value 1); w is the minimum total width of the field to be printed (default value 0).

First padding and the sign are output. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. If the : modifier is used, the sign appears before any padding, and otherwise after the padding. If w is supplied and the number of other characters to be output is less than w, then copies of padchar (which defaults to a space) are output to make the total field width equal w. Then n digits are printed for the integer part of arg, with leading zeros if necessary; then a decimal point; then d digits of fraction, properly rounded.

If the magnitude of arg is so large that more than m digits would have to be printed, where m is the larger of w and 100, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive ~w,q,,,,padcharE, where w and padchar are present or omitted according to whether they were present or omitted in the ~$ directive, and where q=d+n- 1, where d and n are the (possibly default) values given to the ~$ directive.

If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion.

If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w.

~$ binds *print-escape* to false

and *print-readably* to false.

Previous: , Up: FORMAT Floating-Point Printers  

gcl-2.6.14/info/gcl/Customizing-Reinitialization.html0000644000175000017500000000506614360276512021217 0ustar cammcamm Customizing Reinitialization (ANSI and GNU Common Lisp Document)

Previous: , Up: Reinitializing an Instance  

7.3.1 Customizing Reinitialization

Methods for reinitialize-instance may be defined to specify actions to be taken when an instance is updated. If only after methods for reinitialize-instance are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of reinitialize-instance.

Methods for shared-initialize may be defined to customize class redefinition. For more information, see Shared-Initialize.

gcl-2.6.14/info/gcl/find.html0000644000175000017500000001306014360276512014301 0ustar cammcamm find (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.14 find, find-if, find-if-not [Function]

find item sequence &key from-end test test-not start end key ⇒ element

find-if predicate sequence &key from-end start end key ⇒ element

find-if-not predicate sequence &key from-end start end key ⇒ element

Arguments and Values::

item—an object.

sequence—a proper sequence.

predicate—a designator for a function of one argument that returns a generalized boolean.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

key—a designator for a function of one argument, or nil.

element—an element of the sequence, or nil.

Description::

find, find-if, and find-if-not each search for an element of the sequence bounded by start and end that satisfies the predicate predicate or that satisfies the test test or test-not, as appropriate.

If from-end is true, then the result is the rightmost element that satisfies the test.

If the sequence contains an element that satisfies the test, then the leftmost or rightmost sequence element, depending on from-end, is returned; otherwise nil is returned.

Examples::

 (find #\d "here are some letters that can be looked at" :test #'char>)
⇒  #\Space 
 (find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) ⇒  3
 (find-if-not #'complexp                                    
             '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0))
             :start 2) ⇒  NIL

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

position , Rules about Test Functions,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

The function find-if-not is deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Tilde-D_002d_003e-Decimal.html0000644000175000017500000000673314360276512017424 0ustar cammcamm Tilde D-> Decimal (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Radix Control  

22.3.2.2 Tilde D: Decimal

An arg, which should be an integer, is printed in decimal radix. ~D will never put a decimal point after the number.

~mincolD uses a column width of mincol; spaces are inserted on the left if the number requires fewer than mincol columns for its digits and sign. If the number doesn’t fit in mincol columns, additional columns are used as needed.

~mincol,padcharD uses padchar as the pad character instead of space.

If arg is not an integer, it is printed in ~A format and decimal base.

The @ modifier causes the number’s sign to be printed always; the default is to print it only if the number is negative.

The : modifier causes commas to be printed between groups of digits; commachar may be used to change the character used as the comma. comma-interval must be an integer and defaults to 3. When the : modifier is given to any of these directives, the commachar is printed between groups of comma-interval digits.

Thus the most general form of ~D is ~mincol,padchar,commachar,comma-intervalD.

~D binds *print-escape* to false, *print-radix* to false, *print-base* to 10,

and *print-readably* to false.

gcl-2.6.14/info/gcl/Sharpsign-Backslash.html0000644000175000017500000000646214360276512017220 0ustar cammcamm Sharpsign Backslash (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.1 Sharpsign Backslash

Syntax: #\<<x>>

When the token x is a single character long, this parses as the literal character char. Uppercase and lowercase letters are distinguished after #\; #\A and #\a denote different character objects. Any single character works after #\, even those that are normally special to read, such as left-parenthesis and right-parenthesis.

In the single character case, the x must be followed by a non-constituent character. After #\ is read, the reader backs up over the slash and then reads a token, treating the initial slash as a single escape character (whether it really is or not in the current readtable).

When the token x is more than one character long, the x must have the syntax of a symbol with no embedded package markers. In this case, the sharpsign backslash notation parses as the character whose name is (string-upcase x); see Character Names.

For information about how the Lisp printer prints character objects, see Printing Characters.

gcl-2.6.14/info/gcl/setq.html0000644000175000017500000001076114360276512014342 0ustar cammcamm setq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.20 setq [Special Form]

setq {!pair}* ⇒ result

pair ::=var form

Pronunciation::

pronounced ’set ,ky\"u

Arguments and Values::

var—a symbol naming a variable other than a constant variable.

form—a form.

result—the primary value of the last form, or nil if no pairs were supplied.

Description::

Assigns values to variables.

(setq var1 form1 var2 form2 ...) is the simple variable assignment statement of Lisp. First form1 is evaluated and the result is stored in the variable var1, then form2 is evaluated and the result stored in var2, and so forth. setq may be used for assignment of both lexical and dynamic variables.

If any var refers to a binding made by symbol-macrolet, then that var is treated as if setf (not setq) had been used.

Examples::

 ;; A simple use of SETQ to establish values for variables.
 (setq a 1 b 2 c 3) ⇒  3
 a ⇒  1
 b ⇒  2
 c ⇒  3

 ;; Use of SETQ to update values by sequential assignment.
 (setq a (1+ b) b (1+ a) c (+ a b)) ⇒  7
 a ⇒  3
 b ⇒  4
 c ⇒  7

 ;; This illustrates the use of SETQ on a symbol macro.
 (let ((x (list 10 20 30)))
   (symbol-macrolet ((y (car x)) (z (cadr x)))
     (setq y (1+ z) z (1+ y))
     (list x y z)))
⇒  ((21 22 30) 21 22)

Side Effects::

The primary value of each form is assigned to the corresponding var.

See Also::

psetq , set , setf

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/defun.html0000644000175000017500000001572014360276512014467 0ustar cammcamm defun (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.2 defun [Macro]

defun function-name lambda-list [[{declaration}* | documentation]] {form}*
⇒ function-name

Arguments and Values::

function-name—a function name.

lambda-list—an ordinary lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

forms—an implicit progn.

block-name—the function block name of the function-name.

Description::

Defines a new function named function-name in the global environment. The body of the function defined by defun consists of forms; they are executed as an implicit progn when the function is called. defun can be used to define a new function, to install a corrected version of an incorrect definition, to redefine an already-defined function, or to redefine a macro as a function.

defun implicitly puts a block named block-name around the body forms

(but not the forms in the lambda-list)

of the function defined.

Documentation is attached as a documentation string to name (as kind function) and to the function object.

Evaluating defun causes function-name to be a global name for the function specified by the lambda expression 

 (lambda lambda-list
   [[{declaration}* | documentation]]
   (block block-name {form}*))

processed in the lexical environment in which defun was executed.

(None of the arguments are evaluated at macro expansion time.)

defun is not required to perform any compile-time side effects. In particular, defun does not make the function definition available at compile time. An implementation may choose to store information about the function for the purposes of compile-time error-checking (such as checking the number of arguments on calls), or to enable the function to be expanded inline.

Examples::

 (defun recur (x)
  (when (> x 0)
    (recur (1- x)))) ⇒  RECUR 
 (defun ex (a b &optional c (d 66) &rest keys &key test (start 0))
    (list a b c d keys test start)) ⇒  EX 
 (ex 1 2) ⇒  (1 2 NIL 66 NIL NIL 0)
 (ex 1 2 3 4 :test 'equal :start 50) 
⇒  (1 2 3 4 (:TEST EQUAL :START 50) EQUAL 50)
 (ex :test 1 :start 2) ⇒  (:TEST 1 :START 2 NIL NIL 0)

 ;; This function assumes its callers have checked the types of the
 ;; arguments, and authorizes the compiler to build in that assumption.
 (defun discriminant (a b c)
   (declare (number a b c))
   "Compute the discriminant for a quadratic equation."
   (- (* b b) (* 4 a c))) ⇒  DISCRIMINANT
 (discriminant 1 2/3 -2) ⇒  76/9

 ;; This function assumes its callers have not checked the types of the
 ;; arguments, and performs explicit type checks before making any assumptions. 
 (defun careful-discriminant (a b c)
   "Compute the discriminant for a quadratic equation."
   (check-type a number)
   (check-type b number)
   (check-type c number)
   (locally (declare (number a b c))
     (- (* b b) (* 4 a c)))) ⇒  CAREFUL-DISCRIMINANT
 (careful-discriminant 1 2/3 -2) ⇒  76/9

See Also::

flet , labels, block , return-from , declare, documentation , Evaluation, Ordinary Lambda Lists, Syntactic Interaction of Documentation Strings and Declarations

Notes::

return-from can be used to return prematurely from a function defined by defun.

Additional side effects might take place when additional information (typically debugging information) about the function definition is recorded.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/_002a.html0000644000175000017500000000632114360276512014164 0ustar cammcamm * (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.24 * [Function]

* &rest numbers ⇒ product

Arguments and Values::

number—a number.

product—a number.

Description::

Returns the product of numbers, performing any necessary type conversions in the process. If no numbers are supplied, 1 is returned.

Examples::

 (*) ⇒  1
 (* 3 5) ⇒  15
 (* 1.0 #c(22 33) 55/98) ⇒  #C(12.346938775510203 18.520408163265305)

Exceptional Situations::

Might signal type-error if some argument is not a number. Might signal arithmetic-error.

See Also::

Numeric Operations, Rational Computations, Floating-point Computations, Complex Computations

gcl-2.6.14/info/gcl/Rule-of-Unbounded-Rational-Precision.html0000644000175000017500000000463114360276512022317 0ustar cammcamm Rule of Unbounded Rational Precision (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Rational Computations  

12.1.3.1 Rule of Unbounded Rational Precision

Rational computations cannot overflow in the usual sense (though there may not be enough storage to represent a result), since integers and ratios may in principle be of any magnitude.

gcl-2.6.14/info/gcl/Sharpsign-O.html0000644000175000017500000000431314360276512015514 0ustar cammcamm Sharpsign O (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.9 Sharpsign O

#Orational reads rational in octal (radix 8). For example, 

 #o37/15 ≡ 31/13
 #o777 ≡ 511
 #o105 ≡ 69 ;105_8

The consequences are undefined if the token immediately following the #O does not have the syntax of an octal (i.e., radix 8) rational.

gcl-2.6.14/info/gcl/stringp.html0000644000175000017500000000574614360276512015063 0ustar cammcamm stringp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.11 stringp [Function]

stringp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type string; otherwise, returns false.

Examples::

 (stringp "aaaaaa") ⇒  true
 (stringp #\a) ⇒  false

See Also::

typep , string (type)

Notes::

 (stringp object) ≡ (typep object 'string)
gcl-2.6.14/info/gcl/Examples-of-Multiple-Escape-Characters.html0000644000175000017500000000471314360276512022612 0ustar cammcamm Examples of Multiple Escape Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.6 Examples of Multiple Escape Characters

 ;; The following examples assume the readtable case of *readtable* 
 ;; and *print-case* are both :upcase.
 (eq 'abc 'ABC) ⇒  true
 (eq 'abc '|ABC|) ⇒  true
 (eq 'abc 'a|B|c) ⇒  true
 (eq 'abc '|abc|) ⇒  false
gcl-2.6.14/info/gcl/make_002dcondition.html0000644000175000017500000000737314360276512016744 0ustar cammcamm make-condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.30 make-condition [Function]

make-condition type &rest slot-initializations ⇒ condition

Arguments and Values::

type—a type specifier (for a subtype of condition).

slot-initializations—an initialization argument list.

condition—a condition.

Description::

Constructs and returns a condition of type type using slot-initializations for the initial values of the slots. The newly created condition is returned.

Examples::

 (defvar *oops-count* 0)

 (setq a (make-condition 'simple-error
                         :format-control "This is your ~:R error."
                         :format-arguments (list (incf *oops-count*))))
⇒  #<SIMPLE-ERROR 32245104>

 (format t "~&~A~
 |>  This is your first error.
⇒  NIL

 (error a)
 |>  Error: This is your first error.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return to Lisp Toplevel.
 |>  Debug>

Affected By::

The set of defined condition types.

See Also::

define-condition , Condition System Concepts

gcl-2.6.14/info/gcl/Function-Forms.html0000644000175000017500000001241614360276512016236 0ustar cammcamm Function Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.10 Function Forms

If the operator is a symbol naming a function, the form represents a function form, and the cdr of the list contains the forms which when evaluated will supply the arguments passed to the function.

When a function name is not defined, an error of type undefined-function should be signaled at run time; see Semantic Constraints.

A function form is evaluated as follows:

The subforms in the cdr of the original form are evaluated in left-to-right order in the current lexical and dynamic environments. The primary value of each such evaluation becomes an argument to the named function; any additional values returned by the subforms are discarded.

The functional value of the operator is retrieved from the lexical environment, and that function is invoked with the indicated arguments.

Although the order of evaluation of the argument subforms themselves is strictly left-to-right, it is not specified whether the definition of the operator in a function form is looked up before the evaluation of the argument subforms, after the evaluation of the argument subforms, or between the evaluation of any two argument subforms if there is more than one such argument subform. For example, the following might return 23 or~24. 

 (defun foo (x) (+ x 3))
 (defun bar () (setf (symbol-function 'foo) #'(lambda (x) (+ x 4))))
 (foo (progn (bar) 20))

A binding for a function name can be established in one of several ways. A binding for a function name in the global environment can be established by defun, setf of fdefinition, setf of symbol-function, ensure-generic-function, defmethod (implicitly, due to ensure-generic-function), or defgeneric. A binding for a function name in the lexical environment can be established by flet or labels.

Figure 3–4 lists some defined names that are applicable to functions. 

  apply                 fdefinition  mapcan               
  call-arguments-limit  flet         mapcar               
  complement            fmakunbound  mapcon               
  constantly            funcall      mapl                 
  defgeneric            function     maplist              
  defmethod             functionp    multiple-value-call  
  defun                 labels       reduce               
  fboundp               map          symbol-function      

      Figure 3–4: Some function-related defined names

Next: , Previous: , Up: The Evaluation Model  

gcl-2.6.14/info/gcl/gensym.html0000644000175000017500000001274014360276512014667 0ustar cammcamm gensym (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.7 gensym [Function]

gensym &optional x ⇒ new-symbol

Arguments and Values::

x—a string or a non-negative integer. Complicated defaulting behavior; see below.

new-symbol—a fresh, uninterned symbol.

Description::

Creates and returns a fresh, uninterned symbol, as if by calling make-symbol. (The only difference between gensym and make-symbol is in how the new-symbol’s name is determined.)

The name of the new-symbol is the concatenation of a prefix, which defaults to "G", and

a suffix, which is the decimal representation of a number that defaults to the value of *gensym-counter*.

If x is supplied, and is a string, then that string is used as a prefix instead of "G" for this call to gensym only.

If x is supplied, and is an integer, then that integer, instead of the value of *gensym-counter*, is used as the suffix for this call to gensym only.

If and only if no explicit suffix is supplied, *gensym-counter* is incremented after it is used.

Examples::

 (setq sym1 (gensym)) ⇒  #:G3142
 (symbol-package sym1) ⇒  NIL
 (setq sym2 (gensym 100)) ⇒  #:G100
 (setq sym3 (gensym 100)) ⇒  #:G100
 (eq sym2 sym3) ⇒  false
 (find-symbol "G100") ⇒  NIL, NIL
 (gensym "T") ⇒  #:T3143
 (gensym) ⇒  #:G3144

Side Effects::

Might increment *gensym-counter*.

Affected By::

*gensym-counter*

Exceptional Situations::

Should signal an error of type type-error if x is not a string or a non-negative integer.

See Also::

gentemp , *gensym-counter*

Notes::

The ability to pass a numeric argument to gensym has been deprecated; explicitly binding *gensym-counter* is now stylistically preferred. (The somewhat baroque conventions for the optional argument are historical in nature, and supported primarily for compatibility with older dialects of Lisp. In modern code, it is recommended that the only kind of argument used be a string prefix. In general, though, to obtain more flexible control of the new-symbol’s name, consider using make-symbol instead.)

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/generic_002dfunction.html0000644000175000017500000000641314360276512017274 0ustar cammcamm generic-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.5 generic-function [System Class]

Class Precedence List::

generic-function, function, t

Description::

A generic function is a function whose behavior depends on the classes or identities of the arguments supplied to it. A generic function object contains a set of methods, a lambda list, a method combination type, and other information. The methods define the class-specific behavior and operations of the generic function; a method is said to specialize a generic function. When invoked, a generic function executes a subset of its methods based on the classes or identities of its arguments.

A generic function can be used in the same ways that an ordinary function can be used; specifically, a generic function can be used as an argument to funcall and apply, and can be given a global or a local name.

gcl-2.6.14/info/gcl/The-for_002das_002don_002dlist-subclause.html0000644000175000017500000000571614360276512022436 0ustar cammcamm The for-as-on-list subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.6 The for-as-on-list subclause

In the for-as-on-list subclause, the for or as construct iterates over a list. It checks for the end of the list as if by using atom.

The variable var is bound to the successive tails of the list in form1. At the end of each iteration, the function step-fun is applied to the list; the default value for step-fun is cdr. The loop keywords on and by serve as valid prepositions in this syntax. The for or as construct causes termination when the end of the list is reached.

gcl-2.6.14/info/gcl/exp.html0000644000175000017500000001462014360276512014160 0ustar cammcamm exp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.31 exp, expt [Function]

exp number ⇒ result

expt base-number power-number ⇒ result

Arguments and Values::

number—a number.

base-number—a number.

power-number—a number.

result—a number.

Description::

exp and expt perform exponentiation.

exp returns e raised to the power number, where e is the base of the natural logarithms. exp has no branch cut.

expt returns base-number raised to the power power-number. If the base-number is a rational and power-number is an integer, the calculation is exact and the result will be of type rational; otherwise a floating-point approximation might result.

For expt of a complex rational to an integer power, the calculation must be exact and the result is of type (or rational (complex rational)).

The result of expt can be a complex, even when neither argument is a complex, if base-number is negative and power-number is not an integer. The result is always the principal complex value. For example, (expt -8 1/3) is not permitted to return -2, even though -2 is one of the cube roots of -8. The principal cube root is a complex approximately equal to #C(1.0 1.73205), not -2.

expt is defined as b^x = e^x log b\/. This defines the principal values precisely. The range of expt is the entire complex plane. Regarded as a function of x, with b fixed, there is no branch cut. Regarded as a function of b, with x fixed, there is in general a branch cut along the negative real axis, continuous with quadrant II. The domain excludes the origin. By definition, 0^0=1. If b=0 and the real part of x is strictly positive, then b^x=0. For all other values of x, 0^x is an error.

When power-number is an integer 0, then the result is always the value one in the type of base-number, even if the base-number is zero (of any type). That is: 

 (expt x 0) ≡ (coerce 1 (type-of x))

If power-number is a zero of any other type, then the result is also the value one, in the type of the arguments after the application of the contagion rules in Contagion in Numeric Operations, with one exception: the consequences are undefined if base-number is zero when power-number is zero and not of type integer.

Examples::

 (exp 0) ⇒  1.0
 (exp 1) ⇒  2.718282
 (exp (log 5)) ⇒  5.0 
 (expt 2 8) ⇒  256
 (expt 4 .5) ⇒  2.0
 (expt #c(0 1) 2) ⇒  -1
 (expt #c(2 2) 3) ⇒  #C(-16 16)
 (expt #c(2 2) 4) ⇒  -64

See Also::

log , Rule of Float Substitutability

Notes::

Implementations of expt are permitted to use different algorithms for the cases of a power-number of type rational and a power-number of type float.

Note that by the following logic, (sqrt (expt x 3)) is not equivalent to (expt x 3/2). 

 (setq x (exp (/ (* 2 pi #c(0 1)) 3)))         ;exp(2.pi.i/3)
 (expt x 3) ⇒  1 ;except for round-off error
 (sqrt (expt x 3)) ⇒  1 ;except for round-off error
 (expt x 3/2) ⇒  -1 ;except for round-off error

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/multiple_002dvalue_002dsetq.html0000644000175000017500000001057314360276512020426 0ustar cammcamm multiple-value-setq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.52 multiple-value-setq [Macro]

multiple-value-setq vars form ⇒ result

Arguments and Values::

vars—a list of symbols that are either variable names or names of symbol macros.

form—a form.

result—The primary value returned by the form.

Description::

multiple-value-setq assigns values to vars.

The form is evaluated, and each var is assigned to the corresponding value returned by that form. If there are more vars than values returned, nil is assigned to the extra vars. If there are more values than vars, the extra values are discarded.

If any var is the name of a symbol macro, then it is assigned as if by setf. Specifically, 

 (multiple-value-setq (symbol_1 ... symbol_n) value-producing-form)

is defined to always behave in the same way as 

 (values (setf (values symbol_1 ... symbol_n) value-producing-form))

in order that the rules for order of evaluation and side-effects be consistent with those used by setf.

See VALUES Forms as Places.

Examples::

 (multiple-value-setq (quotient remainder) (truncate 3.2 2)) ⇒  1
 quotient ⇒  1
 remainder ⇒  1.2
 (multiple-value-setq (a b c) (values 1 2)) ⇒  1
 a ⇒  1
 b ⇒  2
 c ⇒  NIL
 (multiple-value-setq (a b) (values 4 5 6)) ⇒  4
 a ⇒  4
 b ⇒  5

See Also::

setq , symbol-macrolet

gcl-2.6.14/info/gcl/Compilation-Semantics.html0000644000175000017500000000717614360276512017576 0ustar cammcamm Compilation Semantics (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation  

3.2.2 Compilation Semantics

Conceptually, compilation is a process that traverses code, performs certain kinds of syntactic and semantic analyses using information (such as proclamations and macro definitions) present in the compilation environment, and produces equivalent, possibly more efficient code.

• Compiler Macros  
• Purpose of Compiler Macros  
• Naming of Compiler Macros  
• When Compiler Macros Are Used  
• Notes about the Implementation of Compiler Macros  
• Minimal Compilation  
• Semantic Constraints  
gcl-2.6.14/info/gcl/Sharpsign-Dot.html0000644000175000017500000000503614360276512016047 0ustar cammcamm Sharpsign Dot (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.7 Sharpsign Dot

#.foo is read as the object resulting from the evaluation of the object represented by foo. The evaluation is done during the read process, when the #. notation is encountered. The #. syntax therefore performs a read-time evaluation of foo.

The normal effect of #. is inhibited when the value of *read-eval* is false.

In that situation, an error of type reader-error is signaled.

For an object that does not have a convenient printed representation, a form that computes the object can be given using the #. notation.

gcl-2.6.14/info/gcl/subseq.html0000644000175000017500000001214114360276512014662 0ustar cammcamm subseq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.6 subseq [Accessor]

subseq sequence start &optional end ⇒ subsequence

(setf ( subseq sequence start &optional end) new-subsequence)

Arguments and Values::

sequence—a proper sequence.

start, end—bounding index designators of sequence. The default for end is nil.

subsequence—a proper sequence.

new-subsequence—a proper sequence.

Description::

subseq creates a sequence that is a copy of the subsequence of sequence bounded by start and end.

Start specifies an offset into the original sequence and marks the beginning position of the subsequence. end marks the position following the last element of the subsequence.

subseq always allocates a new sequence for a result; it never shares storage with an old sequence. The result subsequence is always of the same type as sequence.

If sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list.

setf may be used with subseq to destructively replace elements of a subsequence with elements taken from a sequence of new values. If the subsequence and the new sequence are not of equal length, the shorter length determines the number of elements that are replaced. The remaining elements at the end of the longer sequence are not modified in the operation.

Examples::

 (setq str "012345") ⇒  "012345"
 (subseq str 2) ⇒  "2345"
 (subseq str 3 5) ⇒  "34"
 (setf (subseq str 4) "abc") ⇒  "abc"
 str ⇒  "0123ab"
 (setf (subseq str 0 2) "A") ⇒  "A"
 str ⇒  "A123ab"

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should be prepared to signal an error of type type-error if new-subsequence is not a proper sequence.

See Also::

replace

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Modifying-Hash-Table-Keys.html0000644000175000017500000001350414360276512020130 0ustar cammcamm Modifying Hash Table Keys (ANSI and GNU Common Lisp Document)

Previous: , Up: Hash Table Concepts  

18.1.2 Modifying Hash Table Keys

The function supplied as the :test argument to make-hash-table specifies the ‘equivalence test’ for the hash table it creates.

An object is ‘visibly modified’ with regard to an equivalence test if there exists some set of objects (or potential objects) which are equivalent to the object before the modification but are no longer equivalent afterwards.

If an object O_1 is used as a key in a hash table H and is then visibly modified with regard to the equivalence test of H, then the consequences are unspecified if O_1, or any object O_2 equivalent to O_1 under the equivalence test (either before or after the modification), is used as a key in further operations on H. The consequences of using O_1 as a key are unspecified even if O_1 is visibly modified and then later modified again in such a way as to undo the visible modification.

Following are specifications of the modifications which are visible to the equivalence tests which must be supported by hash tables. The modifications are described in terms of modification of components, and are defined recursively. Visible modifications of components of the object are visible modifications of the object.

• Visible Modification of Objects with respect to EQ and EQL  
• Visible Modification of Objects with respect to EQUAL  
• Visible Modification of Conses with respect to EQUAL  
• Visible Modification of Bit Vectors and Strings with respect to EQUAL  
• Visible Modification of Objects with respect to EQUALP  
• Visible Modification of Structures with respect to EQUALP  
• Visible Modification of Arrays with respect to EQUALP  
• Visible Modification of Hash Tables with respect to EQUALP  
• Visible Modifications by Language Extensions  

Previous: , Up: Hash Table Concepts  

gcl-2.6.14/info/gcl/Files-Dictionary.html0000644000175000017500000000703014360276512016526 0ustar cammcamm Files Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Files  

20.2 Files Dictionary

• directory  
• probe-file  
• ensure-directories-exist  
• truename  
• file-author  
• file-write-date  
• rename-file  
• delete-file  
• file-error  
• file-error-pathname  
gcl-2.6.14/info/gcl/package.html0000644000175000017500000000512114360276512014753 0ustar cammcamm package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.1 package [System Class]

Class Precedence List::

package, t

Description::

A package is a namespace that maps symbol names to symbols; see Package Concepts.

See Also::

Package Concepts, Printing Other Objects, Symbols as Tokens

gcl-2.6.14/info/gcl/Tilde-T_002d_003e-Tabulate.html0000644000175000017500000001160614360276512017642 0ustar cammcamm Tilde T-> Tabulate (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Layout Control  

22.3.6.1 Tilde T: Tabulate

This spaces over to a given column. ~colnum,colincT will output sufficient spaces to move the cursor to column colnum. If the cursor is already at or beyond column colnum, it will output spaces to move it to column colnum+k*colinc for the smallest positive integer k possible, unless colinc is zero, in which case no spaces are output if the cursor is already at or beyond column colnum. colnum and colinc default to 1.

If for some reason the current absolute column position cannot be determined by direct inquiry, format may be able to deduce the current column position by noting that certain directives (such as ~%, or ~&, or ~A with the argument being a string containing a newline) cause the column position to be reset to zero, and counting the number of characters emitted since that point. If that fails, format may attempt a similar deduction on the riskier assumption that the destination was at column zero when format was invoked. If even this heuristic fails or is implementationally inconvenient, at worst the ~T operation will simply output two spaces.

~@T performs relative tabulation. ~colrel,colinc@T outputs colrel spaces and then outputs the smallest non-negative number of additional spaces necessary to move the cursor to a column that is a multiple of colinc. For example, the directive ~3,8@T outputs three spaces and then moves the cursor to a “standard multiple-of-eight tab stop” if not at one already. If the current output column cannot be determined, however, then colinc is ignored, and exactly colrel spaces are output.

If the colon modifier is used with the ~T directive, the tabbing computation is done relative to the horizontal position where the section immediately containing the directive begins, rather than with respect to a horizontal position of zero. The numerical parameters are both interpreted as being in units of ems and both default to 1. ~n,m:T is the same as (pprint-tab :section n m). ~n,m:@T is the same as (pprint-tab :section-relative n m).

Next: , Previous: , Up: FORMAT Layout Control  

gcl-2.6.14/info/gcl/The-_0022Method-Signature_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000001046114360276512026012 0ustar cammcamm The "Method Signature" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.17 The "Method Signature" Section of a Dictionary Entry

The description of a generic function includes descriptions of the methods that are defined on that generic function by the standard. A method signature is used to describe the parameters and parameter specializers for each method. Methods defined for the generic function must be of the form described by the method signature.

F (x class) (y t) &optional z &key k

This signature indicates that this method on the generic function F has two required parameters: x, which must be a generalized instance of the class class; and y, which can be any object (i.e., a generalized instance of the class t). In addition, there is an optional parameter z and a keyword parameter k. This signature also indicates that this method on F is a primary method and has no qualifiers.

For each parameter, the argument supplied must be in the intersection of the type specified in the description of the corresponding generic function and the type given in the signature of some method (including not only those methods defined in this specification, but also implementation-defined or user-defined methods in situations where the definition of such methods is permitted).

gcl-2.6.14/info/gcl/The-for_002das_002dpackage-subclause.html0000644000175000017500000001340314360276512021764 0ustar cammcamm The for-as-package subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.13 The for-as-package subclause

In the for-as-package subclause the for or as construct iterates over the symbols in a package. In this syntax, a compound preposition is used to designate access to a package. The variable var takes on the value of each symbol in the supplied package. The following loop keywords serve as valid prepositions within this syntax:

being

The keyword being introduces either the Loop schema symbol, present-symbol, or external-symbol.

each, the

The loop keyword each follows the loop keyword being when symbol, present-symbol, or external-symbol is used. The loop keyword the is used with symbols, present-symbols, and external-symbols only for ease of reading. This agreement isn’t required.

present-symbol, present-symbols

These Loop schemas iterate over the symbols

that are present in a package.

The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled.

symbol, symbols

These Loop schemas iterate over symbols that are accessible in a given package. The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled.

external-symbol, external-symbols

These Loop schemas iterate over the external symbols of a package. The package to be iterated over is supplied in the same way that package arguments to find-package are supplied. If the package for the iteration is not supplied, the current package is used. If a package that does not exist is supplied, an error of type package-error is signaled.

in, of

These loop prepositions introduce package.

In effect

being {each | the} {symbol | symbols | present-symbol | present-symbols | external-symbol | external-symbols} {in | of}

is a compound preposition.

Iteration stops when there are no more symbols to be referenced in the supplied package.

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

gcl-2.6.14/info/gcl/Sharpsign-Asterisk.html0000644000175000017500000000703014360276512017102 0ustar cammcamm Sharpsign Asterisk (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.4 Sharpsign Asterisk

Syntax: #*<<bits>>

A simple bit vector is constructed containing the indicated bits (0’s and 1’s), where the leftmost bit has index zero and the subsequent bits have increasing indices.

Syntax: #<<n>>*<<bits>>

With an argument n, the vector to be created is of length n. If the number of bits is less than n but greater than zero, the last bit is used to fill all remaining bits of the bit vector.

The notations #* and #0* each denote an empty bit vector.

Regardless of whether the optional numeric argument n is provided, the token that follows the asterisk is delimited by a normal token delimiter. However, (unless the value of *read-suppress* is true) an error of type reader-error is signaled if that token is not composed entirely of 0’s and 1’s, or if n was supplied and the token is composed of more than n bits, or if n is greater than one, but no bits were specified. Neither a single escape nor a multiple escape is permitted in this token.

For information on how the Lisp printer prints bit vectors, see Printing Bit Vectors.

gcl-2.6.14/info/gcl/symbol_002dfunction.html0000644000175000017500000001376114360276512017171 0ustar cammcamm symbol-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.10 symbol-function [Accessor]

symbol-function symbol ⇒ contents

(setf ( symbol-function symbol) new-contents)

Arguments and Values::

symbol—a symbol.

contents—

If the symbol is globally defined as a macro or a special operator, an object of implementation-dependent nature and identity is returned. If the symbol is not globally defined as either a macro or a special operator, and if the symbol is fbound, a function object is returned.

new-contents—a function.

Description::

Accesses the symbol’s function cell.

Examples::

 (symbol-function 'car) ⇒  #<FUNCTION CAR>
 (symbol-function 'twice) is an error   ;because TWICE isn't defined.
 (defun twice (n) (* n 2)) ⇒  TWICE
 (symbol-function 'twice) ⇒  #<FUNCTION TWICE>
 (list (twice 3)
       (funcall (function twice) 3)
       (funcall (symbol-function 'twice) 3))
⇒  (6 6 6)
 (flet ((twice (x) (list x x)))
   (list (twice 3)
         (funcall (function twice) 3)
         (funcall (symbol-function 'twice) 3)))
⇒  ((3 3) (3 3) 6)   
 (setf (symbol-function 'twice) #'(lambda (x) (list x x)))
⇒  #<FUNCTION anonymous>
 (list (twice 3)
       (funcall (function twice) 3)
       (funcall (symbol-function 'twice) 3))
⇒  ((3 3) (3 3) (3 3))
 (fboundp 'defun) ⇒  true
 (symbol-function 'defun)
⇒  implementation-dependent
 (functionp (symbol-function 'defun))
⇒  implementation-dependent
 (defun symbol-function-or-nil (symbol)
   (if (and (fboundp symbol) 
            (not (macro-function symbol))
            (not (special-operator-p symbol)))
       (symbol-function symbol)
       nil)) ⇒  SYMBOL-FUNCTION-OR-NIL
 (symbol-function-or-nil 'car) ⇒  #<FUNCTION CAR>
 (symbol-function-or-nil 'defun) ⇒  NIL

Affected By::

defun

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

Should signal undefined-function if symbol is not fbound and an attempt is made to read its definition. (No such error is signaled on an attempt to write its definition.)

See Also::

fboundp , fmakunbound , macro-function ,

special-operator-p

Notes::

symbol-function cannot access the value of a lexical function name produced by flet or labels; it can access only the global function value.

setf may be used with symbol-function to replace a global function definition when the symbol’s function definition does not represent a special operator. 

(symbol-function symbol) ≡ (fdefinition symbol)

However, fdefinition accepts arguments other than just symbols.

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/Semantic-Constraints.html0000644000175000017500000001437614360276512017444 0ustar cammcamm Semantic Constraints (ANSI and GNU Common Lisp Document)

Previous: , Up: Compilation Semantics  

3.2.2.7 Semantic Constraints

All conforming programs must obey the following constraints, which are designed to minimize the observable differences between compiled and interpreted programs:

*

Definitions of any referenced macros must be present in the compilation environment. Any form that is a list beginning with a symbol that does not name a special operator or a macro defined in the compilation environment is treated by the compiler as a function call.

*

Special proclamations for dynamic variables must be made in the compilation environment. Any binding for which there is no special declaration or proclamation in the compilation environment is treated by the compiler as a lexical binding.

*

The definition of a function that is defined and declared inline in the compilation environment must be the same at run time.

*

Within a function named F, the compiler may (but is not required to) assume that an apparent recursive call to a function named F refers to the same definition of F, unless that function has been declared notinline. The consequences of redefining such a recursively defined function F while it is executing are undefined.

*

A call within a file to a named function that is defined in the same file refers to that function, unless that function has been declared notinline. The consequences are unspecified if functions are redefined individually at run time or multiply defined in the same file.

*

The argument syntax and number of return values for all functions whose ftype is declared at compile time must remain the same at run time.

*

Constant variables defined in the compilation environment must have a similar value at run time. A reference to a constant variable in source code is equivalent to a reference to a literal object that is the value of the constant variable.

*

Type definitions made with deftype or defstruct in the compilation environment must retain the same definition at run time. Classes defined by defclass in the compilation environment must be defined at run time to have the same superclasses and same metaclass.

This implies that subtype/supertype relationships of type specifiers must not change between compile time and run time.

*

Type declarations present in the compilation environment must accurately describe the corresponding values at run time; otherwise, the consequences are undefined. It is permissible for an unknown type to appear in a declaration at compile time, though a warning might be signaled in such a case.

*

Except in the situations explicitly listed above, a function defined in the evaluation environment is permitted to have a different definition or a different signature at run time, and the run-time definition prevails.

Conforming programs should not be written using any additional assumptions about consistency between the run-time environment and the startup, evaluation, and compilation environments.

Except where noted, when a compile-time and a run-time definition are different, one of the following occurs at run time:

*

an error of type error is signaled

*

the compile-time definition prevails

*

the run-time definition prevails

If the compiler processes a function form whose operator is not defined at compile time, no error is signaled at compile time.

Previous: , Up: Compilation Semantics  

gcl-2.6.14/info/gcl/rename_002dpackage.html0000644000175000017500000000727214360276512016701 0ustar cammcamm rename-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.8 rename-package [Function]

rename-package package new-name &optional new-nicknames ⇒ package-object

Arguments and Values::

package—a package designator.

new-name—a package designator.

new-nicknames—a list of string designators. The default is the empty list.

package-object—the renamed package object.

Description::

Replaces the name and nicknames of package. The old name and all of the old nicknames of package are eliminated and are replaced by new-name and new-nicknames.

The consequences are undefined if new-name or any new-nickname conflicts with any existing package names.

Examples::

 (make-package 'temporary :nicknames '("TEMP")) ⇒  #<PACKAGE "TEMPORARY">
 (rename-package 'temp 'ephemeral) ⇒  #<PACKAGE "EPHEMERAL">
 (package-nicknames (find-package 'ephemeral)) ⇒  ()
 (find-package 'temporary) ⇒  NIL
 (rename-package 'ephemeral 'temporary '(temp fleeting))
⇒  #<PACKAGE "TEMPORARY">
 (package-nicknames (find-package 'temp)) ⇒  ("TEMP" "FLEETING")

See Also::

make-package

gcl-2.6.14/info/gcl/encode_002duniversal_002dtime.html0000644000175000017500000000725714360276512020713 0ustar cammcamm encode-universal-time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.2 encode-universal-time [function]

Syntax::

encode-universal-time second minute hour date month year &optional time-zone
⇒ universal-time

Arguments and Values::

second, minute, hour, date, month, year, time-zone—the corresponding parts of a decoded time. (Note that some of the nine values in a full decoded time are redundant, and so are not used as inputs to this function.)

universal-time—a universal time.

Description::

encode-universal-time converts a time from Decoded Time format to a universal time.

If time-zone is supplied, no adjustment for daylight savings time is performed.

Examples::

 (encode-universal-time 0 0 0 1 1 1900 0) ⇒  0
 (encode-universal-time 0 0 1 4 7 1976 5) ⇒  2414296800
;; The next example assumes Eastern Daylight Time.
 (encode-universal-time 0 0 1 4 7 1976) ⇒  2414293200

See Also::

decode-universal-time , get-decoded-time

gcl-2.6.14/info/gcl/Special-Forms.html0000644000175000017500000000745514360276512016040 0ustar cammcamm Special Forms (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.8 Special Forms

A special form is a form with special syntax, special evaluation rules, or both, possibly manipulating the evaluation environment, control flow, or both. A special operator has access to the current lexical environment and the current dynamic environment. Each special operator defines the manner in which its subexpressions are treated—which are forms, which are special syntax, etc.

Some special operators create new lexical or dynamic environments for use during the evaluation of subforms of the special form. For example, block creates a new lexical environment that is the same as the one in force at the point of evaluation of the block form with the addition of a binding of the block name to an exit point from the block.

The set of special operator names is fixed in Common Lisp; no way is provided for the user to define a special operator. Figure 3–2 lists all of the Common Lisp symbols that have definitions as special operators. 

  block      let*                  return-from      
  catch      load-time-value       setq             
  eval-when  locally               symbol-macrolet  
  flet       macrolet              tagbody          
  function   multiple-value-call   the              
  go         multiple-value-prog1  throw            
  if         progn                 unwind-protect   
  labels     progv                                  
  let        quote                                  

      Figure 3–2: Common Lisp Special Operators
gcl-2.6.14/info/gcl/Sharpsign-Whitespace.html0000644000175000017500000000445114360276512017415 0ustar cammcamm Sharpsign Whitespace (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.24 Sharpsign Whitespace

# followed immediately by whitespace_1 is not valid reader syntax. The Lisp reader will signal an error of type reader-error if it encounters the reader macro notation #<Newline> or #<Space>.

gcl-2.6.14/info/gcl/The-Standard-Readtable.html0000644000175000017500000000467614360276512017535 0ustar cammcamm The Standard Readtable (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Readtables  

2.1.1.2 The Standard Readtable

The standard readtable conforms to standard syntax. The consequences are undefined if an attempt is made to modify the standard readtable. To achieve the effect of altering or extending standard syntax, a copy of the standard readtable can be created; see the function copy-readtable.

The readtable case of the standard readtable is :upcase.

gcl-2.6.14/info/gcl/type_002derror_002ddatum.html0000644000175000017500000000721114360276512017722 0ustar cammcamm type-error-datum (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.30 type-error-datum, type-error-expected-type [Function]

type-error-datum condition ⇒ datum

type-error-expected-type condition ⇒ expected-type

Arguments and Values::

condition—a condition of type type-error.

datum—an object.

expected-type—a type specifier.

Description::

type-error-datum returns the offending datum in the situation represented by the condition.

type-error-expected-type returns the expected type of the offending datum in the situation represented by the condition.

Examples::

 (defun fix-digits (condition)
   (check-type condition type-error)
   (let* ((digits '(zero one two three four
                   five six seven eight nine))
         (val (position (type-error-datum condition) digits)))
     (if (and val (subtypep 'fixnum (type-error-expected-type condition)))
         (store-value 7))))

 (defun foo (x)
   (handler-bind ((type-error #'fix-digits))
     (check-type x number)
     (+ x 3)))

 (foo 'seven)
⇒  10

See Also::

type-error, Conditions

gcl-2.6.14/info/gcl/Organization-of-the-Document.html0000644000175000017500000001153514360276512020766 0ustar cammcamm Organization of the Document (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.2 Organization of the Document

This is a reference document, not a tutorial document. Where possible and convenient, the order of presentation has been chosen so that the more primitive topics precede those that build upon them; however, linear readability has not been a priority.

This document is divided into chapters by topic. Any given chapter might contain conceptual material, dictionary entries, or both.

Defined names within the dictionary portion of a chapter are grouped in a way that brings related topics into physical proximity. Many such groupings were possible, and no deep significance should be inferred from the particular grouping that was chosen. To see defined names grouped alphabetically, consult the index. For a complete list of defined names, see Symbols in the COMMON-LISP Package.

In order to compensate for the sometimes-unordered portions of this document, a glossary has been provided; see Glossary. The glossary provides connectivity by providing easy access to definitions of terms, and in some cases by providing examples or cross references to additional conceptual material.

For information about notational conventions used in this document, see Definitions.

For information about conformance, see Conformance.

For information about extensions and subsets, see Language Extensions and Language Subsets.

For information about how programs in the language are parsed by the Lisp reader, see Syntax.

For information about how programs in the language are compiled and executed, see Evaluation and Compilation.

For information about data types, see Types and Classes. Not all types and classes are defined in this chapter; many are defined in chapter corresponding to their topic–for example, the numeric types are defined in Numbers (Numbers). For a complete list of standardized types, see Figure~4–2.

For information about general purpose control and data flow, see Data and Control Flow or Iteration.

Next: , Previous: , Up: Introduction (Introduction)  

gcl-2.6.14/info/gcl/read_002dfrom_002dstring.html0000644000175000017500000001346614360276512017673 0ustar cammcamm read-from-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.6 read-from-string [Function]

read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace
⇒ object, position

Arguments and Values::

string—a string.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object.

The default is nil.

start, end—bounding index designators of string. The defaults for start and end are 0 and nil, respectively.

preserve-whitespace—a generalized boolean. The default is false.

object—an object (parsed by the Lisp reader) or the eof-value.

position—an integer greater than or equal to zero, and less than or equal to one more than the length of the string.

Description::

Parses the printed representation of an object from the subsequence of string bounded by start and end, as if read had been called on an input stream containing those same characters.

If preserve-whitespace is true, the operation will preserve whitespace_2 as read-preserving-whitespace would do.

If an object is successfully parsed, the primary value, object, is the object that was parsed. If eof-error-p is false and if the end of the substring is reached, eof-value is returned.

The secondary value, position, is the index of the first character in the bounded string that was not read. The position may depend upon the value of preserve-whitespace. If the entire string was read, the position returned is either the length of the string or one greater than the length of the string.

Examples::

 (read-from-string " 1 3 5" t nil :start 2) ⇒  3, 5
 (read-from-string "(a b c)") ⇒  (A B C), 7

Exceptional Situations::

If the end of the supplied substring occurs before an object can be read, an error is signaled if eof-error-p is true. An error is signaled if the end of the substring occurs in the middle of an incomplete object.

See Also::

read , read-preserving-whitespace

Notes::

The reason that position is allowed to be beyond the length of the string is to permit (but not require) the implementation to work by simulating the effect of a trailing delimiter at the end of the bounded string. When preserve-whitespace is true, the position might count the simulated delimiter.

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/make_002dbroadcast_002dstream.html0000644000175000017500000000706514360276512020657 0ustar cammcamm make-broadcast-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.41 make-broadcast-stream [Function]

make-broadcast-stream &rest streams ⇒ broadcast-stream

Arguments and Values::

stream—an output stream.

broadcast-stream—a broadcast stream.

Description::

Returns a broadcast stream.

Examples::

 (setq a-stream (make-string-output-stream)
        b-stream (make-string-output-stream)) ⇒  #<String Output Stream>
 (format (make-broadcast-stream a-stream b-stream)
          "this will go to both streams") ⇒  NIL
 (get-output-stream-string a-stream) ⇒  "this will go to both streams"
 (get-output-stream-string b-stream) ⇒  "this will go to both streams"

Exceptional Situations::

Should signal an error of type type-error if any stream is not an output stream.

See Also::

broadcast-stream-streams

gcl-2.6.14/info/gcl/Literal-Objects-in-Compiled-Files.html0000644000175000017500000001077114360276512021550 0ustar cammcamm Literal Objects in Compiled Files (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation  

3.2.4 Literal Objects in Compiled Files

The functions eval and compile are required to ensure that literal objects referenced within the resulting interpreted or compiled code objects are the same as the corresponding objects in the source code. compile-file, on the other hand, must produce a compiled file that, when loaded with load, constructs the objects defined by the source code and produces references to them.

In the case of compile-file, objects constructed by load of the compiled file cannot be spoken of as being the same as the objects constructed at compile time, because the compiled file may be loaded into a different Lisp image than the one in which it was compiled. This section defines the concept of similarity which relates objects in the evaluation environment to the corresponding objects in the run-time environment.

The constraints on literal objects described in this section apply only to compile-file; eval and compile do not copy or coalesce constants.

• Externalizable Objects  
• Similarity of Literal Objects  
• Similarity of Aggregate Objects  
• Definition of Similarity  
• Extensions to Similarity Rules  
• Additional Constraints on Externalizable Objects  
gcl-2.6.14/info/gcl/Single_002dQuote.html0000644000175000017500000000513714360276512016353 0ustar cammcamm Single-Quote (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.3 Single-Quote

Syntax: '<<exp>>

A single-quote introduces an expression to be “quoted.” Single-quote followed by an expression exp is treated by the Lisp reader as an abbreviation for and is parsed identically to the expression (quote exp). See the special operator quote.

• Examples of Single-Quote  
gcl-2.6.14/info/gcl/array_002ddisplacement.html0000644000175000017500000001043114360276512017614 0ustar cammcamm array-displacement (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.15 array-displacement [Function]

array-displacement array ⇒ displaced-to, displaced-index-offset

Arguments and Values::

array—an array.

displaced-to—an array or nil.

displaced-index-offset—a non-negative fixnum.

Description::

If the array is a displaced array, returns the values of the :displaced-to and :displaced-index-offset options for the array (see the functions make-array and adjust-array). If the array is not a displaced array, nil and 0 are returned.

If array-displacement is called on an array for which a non-nil object was provided as the :displaced-to argument to make-array or adjust-array, it must return that object as its first value. It is implementation-dependent whether array-displacement returns a non-nil primary value for any other array.

Examples::

 (setq a1 (make-array 5)) ⇒  #<ARRAY 5 simple 46115576>
 (setq a2 (make-array 4 :displaced-to a1
                        :displaced-index-offset 1))
⇒  #<ARRAY 4 indirect 46117134>
 (array-displacement a2)
⇒  #<ARRAY 5 simple 46115576>, 1
 (setq a3 (make-array 2 :displaced-to a2
                        :displaced-index-offset 2))
⇒  #<ARRAY 2 indirect 46122527>
 (array-displacement a3)
⇒  #<ARRAY 4 indirect 46117134>, 2

Exceptional Situations::

Should signal an error of type type-error if array is not an array.

See Also::

make-array

gcl-2.6.14/info/gcl/describe.html0000644000175000017500000001056614360276512015151 0ustar cammcamm describe (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.6 describe [Function]

describe object &optional stream ⇒ <no values>

Arguments and Values::

object—an object.

stream—an output stream designator. The default is standard output.

Description::

describe displays information about object

to stream.

For example, describe of a symbol might show the symbol’s value, its definition, and each of its properties. describe of a float might show the number’s internal representation in a way that is useful for tracking down round-off errors. In all cases, however, the nature and format of the output of describe is implementation-dependent.

describe can describe something that it finds inside the object; in such cases, a notational device such as increased indentation or positioning in a table is typically used in order to visually distinguish such recursive descriptions from descriptions of the argument object.

The actual act of describing the object is implemented by describe-object. describe exists as an interface primarily to manage argument defaulting (including conversion of arguments t and nil into stream objects) and to inhibit any return values from describe-object.

describe is not intended to be an interactive function. In a conforming implementation, describe must not, by default, prompt for user input. User-defined methods for describe-object are likewise restricted.

Side Effects::

Output to standard output or terminal I/O.

Affected By::

*standard-output* and *terminal-io*, methods on describe-object and print-object for objects having user-defined classes.

See Also::

inspect , describe-object

gcl-2.6.14/info/gcl/_002aprint_002dreadably_002a.html0000644000175000017500000001554114360276512020220 0ustar cammcamm *print-readably* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.27 *print-readably* [Variable]

Value Type::

a generalized boolean.

Initial Value::

false.

Description::

If *print-readably* is true, some special rules for printing objects go into effect. Specifically, printing any object O_1 produces a printed representation that, when seen by the Lisp reader while the standard readtable is in effect, will produce an object O_2 that is similar to O_1. The printed representation produced might or might not be the same as the printed representation produced when *print-readably* is false. If printing an object readably is not possible, an error of type print-not-readable is signaled rather than using a syntax (e.g., the “#<” syntax) that would not be readable by the same implementation. If the value of some other printer control variable is such that these requirements would be violated, the value of that other variable is ignored.

Specifically, if *print-readably* is true, printing proceeds as if *print-escape*, *print-array*, and *print-gensym* were also true, and as if *print-length*, *print-level*, and *print-lines* were false.

If *print-readably* is false, the normal rules for printing and the normal interpretations of other printer control variables are in effect.

Individual methods for print-object, including user-defined methods, are responsible for implementing these requirements.

If *read-eval* is false and *print-readably* is true, any such method that would output a reference to the “#.” reader macro will either output something else or will signal an error (as described above).

Examples::

 (let ((x (list "a" '\a (gensym) '((a (b (c))) d e f g)))
       (*print-escape* nil)
       (*print-gensym* nil)
       (*print-level* 3)
       (*print-length* 3))
   (write x)
   (let ((*print-readably* t))
     (terpri)
     (write x)
     :done))
 |>  (a a G4581 ((A #) D E ...))
 |>  ("a" |a| #:G4581 ((A (B (C))) D E F G))
⇒  :DONE

;; This is setup code is shared between the examples
;; of three hypothetical implementations which follow.
 (setq table (make-hash-table)) ⇒  #<HASH-TABLE EQL 0/120 32005763> 
 (setf (gethash table 1) 'one) ⇒  ONE
 (setf (gethash table 2) 'two) ⇒  TWO

;; Implementation A
 (let ((*print-readably* t)) (print table))
 Error: Can't print #<HASH-TABLE EQL 0/120 32005763> readably.

;; Implementation B
;; No standardized #S notation for hash tables is defined, 
;; but there might be an implementation-defined notation.
 (let ((*print-readably* t)) (print table))
 |>  #S(HASH-TABLE :TEST EQL :SIZE 120 :CONTENTS (1 ONE 2 TWO))
⇒  #<HASH-TABLE EQL 0/120 32005763>

;; Implementation C
;; Note that #. notation can only be used if *READ-EVAL* is true.
;; If *READ-EVAL* were false, this same implementation might have to
;; signal an error unless it had yet another printing strategy to fall
;; back on.
 (let ((*print-readably* t)) (print table))
 |>  #.(LET ((HASH-TABLE (MAKE-HASH-TABLE)))
 |>      (SETF (GETHASH 1 HASH-TABLE) ONE)
 |>      (SETF (GETHASH 2 HASH-TABLE) TWO)
 |>      HASH-TABLE)
⇒  #<HASH-TABLE EQL 0/120 32005763>

See Also::

write , print-unreadable-object

Notes::

The rules for “similarity” imply that #A or #( syntax cannot be used for arrays of element type other than t. An implementation will have to use another syntax or signal an error of type print-not-readable.

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Rule-of-Complex-Substitutability.html0000644000175000017500000000445514360276512021671 0ustar cammcamm Rule of Complex Substitutability (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Complex Computations  

12.1.5.1 Rule of Complex Substitutability

Except during the execution of irrational and transcendental functions, no numerical function ever yields a complex unless one or more of its arguments is a complex.

gcl-2.6.14/info/gcl/remprop.html0000644000175000017500000001305214360276512015046 0ustar cammcamm remprop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.16 remprop [Function]

remprop symbol indicator ⇒ generalized-boolean

Arguments and Values::

symbol—a symbol.

indicator—an object.

generalized-boolean—a generalized boolean.

Description::

remprop removes from the property list_2 of symbol a property_1 with a property indicator identical to indicator.

If there are multiple properties_1 with the identical key, remprop only removes the first such property.

remprop returns false if no such property was found, or true if a property was found.

The property indicator and the corresponding property value are removed in an undefined order by destructively splicing the property list.

The permissible side-effects correspond to those permitted for remf, such that: 

 (remprop x y) ≡ (remf (symbol-plist x) y)

Examples::

 (setq test (make-symbol "PSEUDO-PI")) ⇒  #:PSEUDO-PI
 (symbol-plist test) ⇒  ()
 (setf (get test 'constant) t) ⇒  T
 (setf (get test 'approximation) 3.14) ⇒  3.14
 (setf (get test 'error-range) 'noticeable) ⇒  NOTICEABLE
 (symbol-plist test) 
⇒  (ERROR-RANGE NOTICEABLE APPROXIMATION 3.14 CONSTANT T)
 (setf (get test 'approximation) nil) ⇒  NIL
 (symbol-plist test) 
⇒  (ERROR-RANGE NOTICEABLE APPROXIMATION NIL CONSTANT T)
 (get test 'approximation) ⇒  NIL
 (remprop test 'approximation) ⇒  true
 (get test 'approximation) ⇒  NIL
 (symbol-plist test)
⇒  (ERROR-RANGE NOTICEABLE CONSTANT T)
 (remprop test 'approximation) ⇒  NIL
 (symbol-plist test)
⇒  (ERROR-RANGE NOTICEABLE CONSTANT T)
 (remprop test 'error-range) ⇒  true
 (setf (get test 'approximation) 3) ⇒  3
 (symbol-plist test)
⇒  (APPROXIMATION 3 CONSTANT T)

Side Effects::

The property list of symbol is modified.

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

remf , symbol-plist

Notes::

Numbers and characters are not recommended for use as indicators in portable code since remprop tests with eq rather than eql, and consequently the effect of using such indicators is implementation-dependent. Of course, if you’ve gotten as far as needing to remove such a property, you don’t have much choice—the time to have been thinking about this was when you used setf of get to establish the property.

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/Macro-Lambda-Lists.html0000644000175000017500000003043614360276512016702 0ustar cammcamm Macro Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.4 Macro Lambda Lists

A macro lambda list is used in describing macros defined by the operators in Figure 3–17. 

  define-compiler-macro  defmacro  macrolet  
  define-setf-expander                       

  Figure 3–17: Operators that use Macro Lambda Lists

With the additional restriction that an environment parameter may appear only once (at any of the positions indicated), a macro lambda list has the following syntax:

reqvars ::={var | !pattern}*

optvars ::=[&optional {var |         ({var | !pattern} [init-form [supplied-p-parameter]])}*]

restvar ::=[{&rest | &body} {var | !pattern}]

keyvars ::=[&key {var |              ({var |          (keyword-name {var | !pattern})}    [init-form [supplied-p-parameter]])}*             [&allow-other-keys]]

auxvars ::=[&aux {var | (var [init-form])}*]

envvar ::=[&environment var]

wholevar ::=[&whole var]

lambda-list ::=(!wholevar !envvar !reqvars !envvar !optvars !envvar                 !restvar !envvar !keyvars !envvar !auxvars !envvar) |                 (!wholevar !envvar !reqvars !envvar !optvars !envvar . var)

pattern ::=(!wholevar !reqvars !optvars !restvar !keyvars !auxvars) |             (!wholevar !reqvars !optvars . var)

A macro lambda list can contain the lambda list keywords shown in Figure 3–18. 

  &allow-other-keys  &environment  &rest   
  &aux               &key          &whole  
  &body              &optional             

  Figure 3–18: Lambda List Keywords used by Macro Lambda Lists

Optional parameters (introduced by &optional) and keyword parameters (introduced by &key) can be supplied in a macro lambda list, just as in an ordinary lambda list. Both may contain default initialization forms and supplied-p parameters.

&body

is identical in function to &rest, but it can be used to inform certain output-formatting and editing functions that the remainder of the form is treated as a body, and should be indented accordingly. Only one of &body or &rest can be used at any particular level; see Destructuring by Lambda Lists.

&body can appear at any level of a macro lambda list; for details, see Destructuring by Lambda Lists.

&whole

is followed by a single variable that is bound to the entire macro-call form; this is the value that the macro function receives as its first argument.

If &whole and a following variable appear, they must appear first in lambda-list,

before any other parameter or lambda list keyword.

&whole can appear at any level of a macro lambda list. At inner levels, the &whole variable is bound to the corresponding part of the argument, as with &rest, but unlike &rest, other arguments are also allowed. The use of &whole does not affect the pattern of arguments specified.

&environment

is followed by a single variable that is bound to an environment representing the lexical environment in which the macro call is to be interpreted. This environment should be used with

macro-function,

get-setf-expansion,

compiler-macro-function,

and macroexpand (for example) in computing the expansion of the macro, to ensure that any lexical bindings or definitions established in the compilation environment are taken into account.

&environment can only appear at the top level of a macro lambda list, and can only appear once, but can appear anywhere in that list;

the &environment parameter is bound along with &whole before any other variables in the lambda list, regardless of where &environment appears in the lambda list.

The object that is bound to the environment parameter has dynamic extent.

Destructuring allows a macro lambda list to express the structure of a macro call syntax. If no lambda list keywords appear, then the macro lambda list is a tree containing parameter names at the leaves. The pattern and the macro form must have compatible tree structure; that is, their tree structure must be equivalent, or it must differ only in that some leaves of the pattern match non-atomic objects of the macro form.

For information about error detection in this situation, see Destructuring Mismatch.

A destructuring lambda list (whether at top level or embedded) can be dotted, ending in a parameter name. This situation is treated exactly as if the parameter name that ends the list had appeared preceded by &rest.

It is permissible for a macro form (or a subexpression of a macro form) to be a dotted list only when (... &rest var) or (... . var) is used to match it. It is the responsibility of the macro to recognize and deal with such situations.

[Editorial Note by KMP: Apparently the dotted-macro-forms cleanup doesn’t allow for the macro to ‘manually’ notice dotted forms and fix them as well. It shouldn’t be required that this be done only by &REST or a dotted pattern; it should only matter that ultimately the non-macro result of a full-macro expansion not contain dots. Anyway, I plan to address this editorially unless someone raises an objection.]

• Destructuring by Lambda Lists  
• Data-directed Destructuring by Lambda Lists  
• Examples of Data-directed Destructuring by Lambda Lists  
• Lambda-list-directed Destructuring by Lambda Lists  

Next: , Previous: , Up: Lambda Lists  

gcl-2.6.14/info/gcl/The-_0022Compound-Type-Specifier-Kind_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000675314360276512030141 0ustar cammcamm The "Compound Type Specifier Kind" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.7 The "Compound Type Specifier Kind" Section of a Dictionary Entry

An “abbreviating” type specifier is one that describes a subtype for which it is in principle possible to enumerate the elements, but for which in practice it is impractical to do so.

A “specializing” type specifier is one that describes a subtype by restricting the type of one or more components of the type, such as element type or complex part type.

A “predicating” type specifier is one that describes a subtype containing only those objects that satisfy a given predicate.

A “combining” type specifier is one that describes a subtype in a compositional way, using combining operations (such as “and,” “or,” and “not”) on other types.

gcl-2.6.14/info/gcl/lambda_002dlist_002dkeywords.html0000644000175000017500000000615114360276512020542 0ustar cammcamm lambda-list-keywords (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.13 lambda-list-keywords [Constant Variable]

Constant Value::

a list, the elements of which are implementation-dependent, but which must contain at least the symbols &allow-other-keys, &aux, &body, &environment, &key, &optional, &rest, and &whole.

Description::

A list of all the lambda list keywords used in the implementation, including the additional ones used only by macro definition forms.

See Also::

defun , flet , defmacro , macrolet, The Evaluation Model

gcl-2.6.14/info/gcl/simple_002dvector.html0000644000175000017500000000676014360276512016633 0ustar cammcamm simple-vector (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.4 simple-vector [Type]

Supertypes::

simple-vector, vector, simple-array, array, sequence, t

Description::

The type of a vector that is not displaced to another array, has no fill pointer, is not expressly adjustable and is able to hold elements of any type is a subtype of type simple-vector.

The type simple-vector is a subtype of type vector, and is a subtype of type (vector t).

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(simple-vector{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *. The default is the symbol *.

Compound Type Specifier Description::

This is the same as (simple-array t (size)).

gcl-2.6.14/info/gcl/File-Operations-on-Open-and-Closed-Streams.html0000644000175000017500000000701214360276512023255 0ustar cammcamm File Operations on Open and Closed Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: File System Concepts  

20.1.2 File Operations on Open and Closed Streams

Many functions that perform file operations accept either open or closed streams as arguments; see Stream Arguments to Standardized Functions.

Of these, the functions in Figure 20–2 treat open and closed streams differently. 

  delete-file  file-author      probe-file  
  directory    file-write-date  truename    

  Figure 20–2: File Functions that Treat Open and Closed Streams Differently

Since treatment of open streams by the file system may vary considerably between implementations, however, a closed stream might be the most reliable kind of argument for some of these functions—in particular, those in Figure 20–3. For example, in some file systems, open files are written under temporary names and not renamed until closed and/or are held invisible until closed. In general, any code that is intended to be portable should use such functions carefully. 

  directory  probe-file  truename  

  Figure 20–3: File Functions where Closed Streams Might Work Best
gcl-2.6.14/info/gcl/Rule-of-Float-and-Rational-Contagion.html0000644000175000017500000000574414360276512022175 0ustar cammcamm Rule of Float and Rational Contagion (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Floating-point Computations  

12.1.4.1 Rule of Float and Rational Contagion

When rationals and floats are combined by a numerical function, the rational is first converted to a float of the same format. For functions such as + that take more than two arguments, it is permitted that part of the operation be carried out exactly using rationals and the rest be done using floating-point arithmetic.

When rationals and floats are compared by a numerical function, the function rational is effectively called to convert the float to a rational and then an exact comparison is performed. In the case of complex numbers, the real and imaginary parts are effectively handled individually.

gcl-2.6.14/info/gcl/defmethod.html0000644000175000017500000003271514360276512015330 0ustar cammcamm defmethod (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.27 defmethod [Macro]

defmethod function-name {method-qualifier}* specialized-lambda-list [[{declaration}* | documentation]] {form}*
⇒ new-method

function-name::= {symbol | (setf symbol)}

method-qualifier::= non-list

 specialized-lambda-list::= ({var | (var parameter-specializer-name)}*
                             [&optional {var | (var [initform [supplied-p-parameter] ])}*]
                             [&rest var]
                             [&key{var | ({var | (keywordvar)} [initform [supplied-p-parameter] ])}*
                                          [&allow-other-keys] ]
                             [&aux {var | (var [initform] )}*] )

 parameter-specializer-name::= symbol | (eql eql-specializer-form)

Arguments and Values::

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

var—a variable name.

eql-specializer-form—a form.

Form—a form.

Initform—a form.

Supplied-p-parameter—variable name.

new-method—the new method object.

Description::

The macro defmethod defines a method on a generic function.

If (fboundp function-name) is nil, a generic function is created with default values for the argument precedence order (each argument is more specific than the arguments to its right in the argument list), for the generic function class (the class standard-generic-function), for the method class (the class standard-method), and for the method combination type (the standard method combination type). The lambda list of the generic function is congruent with the lambda list of the method being defined; if the defmethod form mentions keyword arguments, the lambda list of the generic function will mention &key (but no keyword arguments). If function-name names an ordinary function, a macro, or a special operator, an error is signaled.

If a generic function is currently named by function-name, the lambda list of the method must be congruent with the lambda list of the generic function. If this condition does not hold, an error is signaled. For a definition of congruence in this context, see Congruent Lambda-lists for all Methods of a Generic Function.

Each method-qualifier argument is an object that is used by method combination to identify the given method. The method combination type might further restrict what a method qualifier can be. The standard method combination type allows for unqualified methods and methods whose sole qualifier is one of the keywords :before, :after, or :around.

The specialized-lambda-list argument is like an ordinary lambda list except that the names of required parameters can be replaced by specialized parameters. A specialized parameter is a list of the form (var parameter-specializer-name). Only required parameters can be specialized. If parameter-specializer-name is a symbol it names a class; if it is a list, it is of the form (eql eql-specializer-form). The parameter specializer name (eql eql-specializer-form) indicates that the corresponding argument must be eql to the object that is the value of eql-specializer-form for the method to be applicable. The eql-specializer-form is evaluated at the time that the expansion of the defmethod macro is evaluated. If no parameter specializer name is specified for a given required parameter, the parameter specializer defaults to the class t. For further discussion, see Introduction to Methods.

The form arguments specify the method body. The body of the method is enclosed in an implicit block. If function-name is a symbol, this block bears the same name as the generic function. If function-name is a list of the form (setf symbol), the name of the block is symbol.

The class of the method object that is created is that given by the method class option of the generic function on which the method is defined.

If the generic function already has a method that agrees with the method being defined on parameter specializers and qualifiers, defmethod replaces the existing method with the one now being defined. For a definition of agreement in this context. see Agreement on Parameter Specializers and Qualifiers.

The parameter specializers are derived from the parameter specializer names as described in Introduction to Methods.

The expansion of the defmethod macro “refers to” each specialized parameter (see the description of ignore within the description of declare). This includes parameters that have an explicit parameter specializer name of t. This means that a compiler warning does not occur if the body of the method does not refer to a specialized parameter, while a warning might occur if the body of the method does not refer to an unspecialized parameter. For this reason, a parameter that specializes on t is not quite synonymous with an unspecialized parameter in this context.

Declarations at the head of the method body that apply to the method’s lambda variables are treated as bound declarations whose scope is the same as the corresponding bindings.

Declarations at the head of the method body that apply to the functional bindings of call-next-method or next-method-p apply to references to those functions within the method body forms. Any outer bindings of the function names call-next-method and next-method-p, and declarations associated with such bindings are shadowed_2 within the method body forms.

The scope of free declarations at the head of the method body is the entire method body, which includes any implicit local function definitions but excludes initialization forms for the lambda variables.

defmethod is not required to perform any compile-time side effects. In particular, the methods are not installed for invocation during compilation. An implementation may choose to store information about the generic function for the purposes of compile-time error-checking (such as checking the number of arguments on calls, or noting that a definition for the function name has been seen).

Documentation is attached as a documentation string to the method object.

Affected By::

The definition of the referenced generic function.

Exceptional Situations::

If function-name names an ordinary function, a macro, or a special operator, an error of type error is signaled.

If a generic function is currently named by function-name, the lambda list of the method must be congruent with the lambda list of the generic function, or an error of type error is signaled.

See Also::

defgeneric , documentation , Introduction to Methods, Congruent Lambda-lists for all Methods of a Generic Function, Agreement on Parameter Specializers and Qualifiers, Syntactic Interaction of Documentation Strings and Declarations

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/Implementation_002dDependent-Numeric-Constants.html0000644000175000017500000000660514360276512024303 0ustar cammcamm Implementation-Dependent Numeric Constants (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.2 Implementation-Dependent Numeric Constants

Figure 12–7 shows defined names relating to implementation-dependent details about numbers. 

  double-float-epsilon           most-negative-fixnum           
  double-float-negative-epsilon  most-negative-long-float       
  least-negative-double-float    most-negative-short-float      
  least-negative-long-float      most-negative-single-float     
  least-negative-short-float     most-positive-double-float     
  least-negative-single-float    most-positive-fixnum           
  least-positive-double-float    most-positive-long-float       
  least-positive-long-float      most-positive-short-float      
  least-positive-short-float     most-positive-single-float     
  least-positive-single-float    short-float-epsilon            
  long-float-epsilon             short-float-negative-epsilon   
  long-float-negative-epsilon    single-float-epsilon           
  most-negative-double-float     single-float-negative-epsilon  

  Figure 12–7: Defined names relating to implementation-dependent details about numbers.
gcl-2.6.14/info/gcl/The-_0022Value-Type_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000460014360276512024624 0ustar cammcamm The "Value Type" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Previous: , Up: Interpreting Dictionary Entries  

1.4.4.32 The "Value Type" Section of a Dictionary Entry

This information describes any type restrictions on a dynamic variable.

gcl-2.6.14/info/gcl/interactive_002dstream_002dp.html0000644000175000017500000000670414360276512020553 0ustar cammcamm interactive-stream-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.10 interactive-stream-p [Function]

interactive-stream-p stream ⇒ generalized-boolean

Arguments and Values::

stream—a stream.

generalized-boolean—a generalized boolean.

Description::

Returns true if stream is an interactive stream; otherwise, returns false.

Examples::

 (when (> measured limit)
   (let ((error (round (* (- measured limit) 100)
                       limit)))
     (unless (if (interactive-stream-p *query-io*)
                 (yes-or-no-p "The frammis is out of tolerance by ~D
                               Is it safe to proceed? " error)
                 (< error 15))  ;15
       (error "The frammis is out of tolerance by ~D

Exceptional Situations::

Should signal an error of type type-error if stream is not a stream.

See Also::

Stream Concepts

gcl-2.6.14/info/gcl/room.html0000644000175000017500000000644714360276512014350 0ustar cammcamm room (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.16 room [Function]

room &optional x ⇒ implementation-dependent

Arguments and Values::

x—one of t, nil, or :default.

Description::

room prints, to standard output, information about the state of internal storage and its management. This might include descriptions of the amount of memory in use and the degree of memory compaction, possibly broken down by internal data type if that is appropriate. The nature and format of the printed information is implementation-dependent. The intent is to provide information that a programmer might use to tune a program for a particular implementation.

(room nil) prints out a minimal amount of information. (room t) prints out a maximal amount of information.

(room) or (room :default) prints out an intermediate amount of information that is likely to be useful.

Side Effects::

Output to standard output.

Affected By::

*standard-output*.

gcl-2.6.14/info/gcl/Conformance-Statement.html0000644000175000017500000000617214360276512017563 0ustar cammcamm Conformance Statement (ANSI and GNU Common Lisp Document)

Previous: , Up: Conforming Implementations  

1.5.1.7 Conformance Statement

A conforming implementation shall produce a conformance statement as a consequence of using the implementation, or that statement shall be included in the accompanying documentation. If the implementation conforms in all respects with this standard, the conformance statement shall be

“<<Implementation>> conforms with the requirements of ANSI <<standard number>>”

If the implementation conforms with some but not all of the requirements of this standard, then the conformance statement shall be

“<<Implementation>> conforms with the requirements of ANSI <<standard number>> with the following exceptions: <<reference to or complete list of the requirements of the standard with which the implementation does not conform>>.”

gcl-2.6.14/info/gcl/no_002dapplicable_002dmethod.html0000644000175000017500000000725614360276512020477 0ustar cammcamm no-applicable-method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.16 no-applicable-method [Standard Generic Function]

Syntax::

no-applicable-method generic-function &rest function-arguments ⇒ {result}*

Method Signatures::

no-applicable-method (generic-function t) &rest function-arguments

Arguments and Values::

generic-function—a generic function on which no applicable method was found.

function-arguments—arguments to the generic-function.

result—an object.

Description::

The generic function no-applicable-method is called when a generic function is invoked and no method on that generic function is applicable. The default method signals an error.

The generic function no-applicable-method is not intended to be called by programmers. Programmers may write methods for it.

Exceptional Situations::

The default method signals an error of type error.

See Also::

gcl-2.6.14/info/gcl/Font-Key.html0000644000175000017500000000777714360276512015037 0ustar cammcamm Font Key (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.1 Font Key

Fonts are used in this document to convey information.

name

Denotes a formal term whose meaning is defined in the Glossary. When this font is used, the Glossary definition takes precedence over normal English usage.

Sometimes a glossary term appears subscripted, as in “whitespace_2.” Such a notation selects one particular Glossary definition out of several, in this case the second. The subscript notation for Glossary terms is generally used where the context might be insufficient to disambiguate among the available definitions.

name

Denotes the introduction of a formal term locally to the current text. There is still a corresponding glossary entry, and is formally equivalent to a use of “name,” but the hope is that making such uses conspicuous will save the reader a trip to the glossary in some cases.

name

Denotes a symbol in the COMMON-LISP package. For information about case conventions, see Case in Symbols.

name

Denotes a sample name or piece of code that a programmer might write in Common Lisp.

This font is also used for certain standardized names that are not names of external symbols of the COMMON-LISP package, such as keywords_1, package names, and loop keywords.

name

Denotes the name of a parameter or value.

In some situations the notation “<<name>>” (i.e., the same font, but with surrounding “angle brackets”) is used instead in order to provide better visual separation from surrounding characters. These “angle brackets” are metasyntactic, and never actually appear in program input or output.

gcl-2.6.14/info/gcl/Visible-Modification-of-Objects-with-respect-to-EQUAL.html0000644000175000017500000000545114360276512025260 0ustar cammcamm Visible Modification of Objects with respect to EQUAL (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.2 Visible Modification of Objects with respect to EQUAL

As a consequence of the behavior for equal, the rules for visible modification of objects not explicitly mentioned in this section are inherited from those in Visible Modification of Objects with respect to EQ and EQL.

gcl-2.6.14/info/gcl/Specifiers-for-optional-parameters.html0000644000175000017500000000636114360276512022233 0ustar cammcamm Specifiers for optional parameters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Ordinary Lambda Lists  

3.4.1.2 Specifiers for optional parameters

If &optional is present, the optional parameter specifiers are those following &optional up to the next lambda list keyword or the end of the list. If optional parameters are specified, then each one is processed as follows. If any unprocessed arguments remain, then the parameter variable var is bound to the next remaining argument, just as for a required parameter. If no arguments remain, however, then init-form is evaluated, and the parameter variable is bound to the resulting value (or to nil if no init-form appears in the parameter specifier). If another variable name supplied-p-parameter appears in the specifier, it is bound to true if an argument had been available, and to false if no argument remained (and therefore init-form had to be evaluated). Supplied-p-parameter is bound not to an argument but to a value indicating whether or not an argument had been supplied for the corresponding var.

gcl-2.6.14/info/gcl/string_003d.html0000644000175000017500000002374214360276512015425 0ustar cammcamm string= (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.10 string=, string/=, string<, string>, string<=, string>=,

string-equal, string-not-equal, string-lessp,

string-greaterp, string-not-greaterp, string-not-lessp

[Function]

string= string1 string2 &key start1 end1 start2 end2 ⇒ generalized-boolean

string/= string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string< string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string> string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string<= string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string>= string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string-equal string1 string2 &key start1 end1 start2 end2 ⇒ generalized-boolean

string-not-equal string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string-lessp string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string-greaterp string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string-not-greaterp string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

string-not-lessp string1 string2 &key start1 end1 start2 end2 ⇒ mismatch-index

Arguments and Values::

string1—a string designator.

string2—a string designator.

start1, end1—bounding index designators of string1. The defaults for start and end are 0 and nil, respectively.

start2, end2—bounding index designators of string2. The defaults for start and end are 0 and nil, respectively.

generalized-boolean—a generalized boolean.

mismatch-index—a bounding index of string1, or nil.

Description::

These functions perform lexicographic comparisons on string1 and string2. string= and string-equal are called equality functions; the others are called inequality functions. The comparison operations these functions perform are restricted to the subsequence of string1 bounded by start1 and end1 and to the subsequence of string2 bounded by start2 and end2.

A string a is equal to a string b if it contains the same number of characters, and the corresponding characters are the same under char= or char-equal, as appropriate.

A string a is less than a string b if in the first position in which they differ the character of a is less than the corresponding character of b according to char< or char-lessp as appropriate, or if string a is a proper prefix of string b (of shorter length and matching in all the characters of a).

The equality functions return a generalized boolean that is true if the strings are equal, or false otherwise.

The inequality functions return a mismatch-index that is true if the strings are not equal, or false otherwise. When the mismatch-index is true, it is an integer representing the first character position at which the two substrings differ, as an offset from the beginning of string1.

The comparison has one of the following results:

string=

string= is true if the supplied substrings are of the same length and contain the same characters in corresponding positions; otherwise it is false.

string/=

string/= is true if the supplied substrings are different; otherwise it is false.

string-equal

string-equal is just like string= except that differences in case are ignored; two characters are considered to be the same if char-equal is true of them.

string<

string< is true if substring1 is less than substring2; otherwise it is false.

string>

string> is true if substring1 is greater than substring2; otherwise it is false.

string-lessp, string-greaterp

string-lessp and string-greaterp are exactly like string< and string>, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if char-lessp were used instead of char< for comparing characters.

string<=

string<= is true if substring1 is less than or equal to substring2; otherwise it is false.

string>=

string>= is true if substring1 is greater than or equal to substring2; otherwise it is false.

string-not-greaterp, string-not-lessp

string-not-greaterp and string-not-lessp are exactly like string<= and string>=, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if char-lessp were used instead of char< for comparing characters.

Examples::

 (string= "foo" "foo") ⇒  true
 (string= "foo" "Foo") ⇒  false
 (string= "foo" "bar") ⇒  false
 (string= "together" "frog" :start1 1 :end1 3 :start2 2) ⇒  true
 (string-equal "foo" "Foo") ⇒  true
 (string= "abcd" "01234abcd9012" :start2 5 :end2 9) ⇒  true
 (string< "aaaa" "aaab") ⇒  3
 (string>= "aaaaa" "aaaa") ⇒  4
 (string-not-greaterp "Abcde" "abcdE") ⇒  5
 (string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7
                                      :start2 2 :end2 6) ⇒  6
 (string-not-equal "AAAA" "aaaA") ⇒  false

See Also::

char=

Notes::

equal calls string= if applied to two strings.

Next: , Previous: , Up: Strings Dictionary  

gcl-2.6.14/info/gcl/Examples-of-REPEAT-clause.html0000644000175000017500000000465314360276512020001 0ustar cammcamm Examples of REPEAT clause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Termination Test Clauses  

6.1.4.1 Examples of REPEAT clause

 (loop repeat 3
       do (format t "~&What I say three times is true.~
 |>  What I say three times is true.
 |>  What I say three times is true.
 |>  What I say three times is true.
⇒  NIL
 (loop repeat -15
   do (format t "What you see is what you expect~
⇒  NIL
gcl-2.6.14/info/gcl/rational-_0028Function_0029.html0000644000175000017500000001030414360276512020076 0ustar cammcamm rational (Function) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.54 rational, rationalize [Function]

rational number ⇒ rational

rationalize number ⇒ rational

Arguments and Values::

number—a real.

rational—a rational.

Description::

rational and rationalize convert

reals

to rationals.

If number is already rational, it is returned.

If number is a float, rational returns a rational that is mathematically equal in value to the float. rationalize returns a rational that approximates the float to the accuracy of the underlying floating-point representation.

rational assumes that the float is completely accurate.

rationalize assumes that the float is accurate only to the precision of the floating-point representation.

Examples::

 (rational 0) ⇒  0
 (rationalize -11/100) ⇒  -11/100
 (rational .1) ⇒  13421773/134217728 ;implementation-dependent
 (rationalize .1) ⇒  1/10

Affected By::

The implementation.

Exceptional Situations::

Should signal an error of type type-error if number is not a real. Might signal arithmetic-error.

Notes::

It is always the case that 

 (float (rational x) x) ≡ x

and 

 (float (rationalize x) x) ≡ x

That is, rationalizing a float by either method and then converting it back to a float of the same format produces the original number.

gcl-2.6.14/info/gcl/member-_0028Function_0029.html0000644000175000017500000001310714360276512017540 0ustar cammcamm member (Function) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.33 member, member-if, member-if-not [Function]

member item list &key key test test-not ⇒ tail

member-if predicate list &key key ⇒ tail

member-if-not predicate list &key key ⇒ tail

Arguments and Values::

item—an object.

list—a proper list.

predicate—a designator for a function of one argument that returns a generalized boolean.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

tail—a list.

Description::

member, member-if, and member-if-not each search list for item or for a top-level element that satisfies the test. The argument to the predicate function is an element of list.

If some element satisfies the test, the tail of list beginning with this element is returned; otherwise nil is returned.

list is searched on the top level only.

Examples::

 (member 2 '(1 2 3)) ⇒  (2 3)                                 
 (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr) ⇒  ((3 . 4))
 (member 'e '(a b c d)) ⇒  NIL

 (member-if #'listp '(a b nil c d)) ⇒  (NIL C D)
 (member-if #'numberp '(a #\Space 5/3 foo)) ⇒  (5/3 FOO)
 (member-if-not #'zerop 
                 '(3 6 9 11 . 12)
                 :key #'(lambda (x) (mod x 3))) ⇒  (11 . 12)

Exceptional Situations::

Should be prepared to signal an error of type type-error if list is not a proper list.

See Also::

find , position ,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

The function member-if-not is deprecated.

In the following 

 (member 'a '(g (a y) c a d e a f)) ⇒  (A D E A F)

the value returned by member is identical to the portion of the list beginning with a. Thus rplaca on the result of member can be used to alter the part of the list where a was found (assuming a check has been made that member did not return nil).

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/logical_002dpathname.html0000644000175000017500000000773414360276512017251 0ustar cammcamm logical-pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames Dictionary  

19.4.9 logical-pathname [Function]

logical-pathname pathspec ⇒ logical-pathname

Arguments and Values::

pathspec—a logical pathname, a logical pathname namestring, or a stream.

logical-pathname—a logical pathname.

Description::

logical-pathname converts pathspec to a logical pathname and returns the new logical pathname. If pathspec is a logical pathname namestring, it should contain a host component and its following colon. If pathspec is a stream, it should be one for which pathname returns a logical pathname.

If pathspec is a stream, the stream can be either open or closed. logical-pathname returns the same logical pathname after a file is closed as it did when the file was open.

It is an error if pathspec is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, or make-string-output-stream.

Exceptional Situations::

Signals an error of type type-error if pathspec isn’t supplied correctly.

See Also::

logical-pathname, translate-logical-pathname , Logical Pathnames

gcl-2.6.14/info/gcl/bit_002dand.html0000644000175000017500000002033314360276512015350 0ustar cammcamm bit-and (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.34 bit-and, bit-andc1, bit-andc2, bit-eqv,

bit-ior, bit-nand, bit-nor, bit-not, bit-orc1, bit-orc2, bit-xor

[Function]

bit-and bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-andc1 bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-andc2 bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-eqv bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-ior bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-nand bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-nor bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-orc1 bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-orc2 bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-xor bit-array1 bit-array2 &optional opt-arg ⇒ resulting-bit-array

bit-not bit-array &optional opt-arg ⇒ resulting-bit-array

Arguments and Values::

bit-array, bit-array1, bit-array2—a bit array.

Opt-arg—a bit array, or t, or nil. The default is nil.

Bit-array, bit-array1, bit-array2, and opt-arg (if an array) must all be of the same rank and dimensions.

resulting-bit-array—a bit array.

Description::

These functions perform bit-wise logical operations on bit-array1 and bit-array2 and return an array of matching rank and dimensions, such that any given bit of the result is produced by operating on corresponding bits from each of the arguments.

In the case of bit-not, an array of rank and dimensions matching bit-array is returned that contains a copy of bit-array with all the bits inverted.

If opt-arg is of type (array bit) the contents of the result are destructively placed into opt-arg. If opt-arg is the symbol t, bit-array or bit-array1 is replaced with the result; if opt-arg is nil or omitted, a new array is created to contain the result.

Figure 15–4 indicates the logical operation performed by each of the functions.

2 

Function                                                   Operation                                   
_______________________________________________________________________________________________________
                                                           
bit-and                                                    and                                         
bit-eqv                                                    equivalence (exclusive nor)                 
bit-not                                                    complement                                  
bit-ior                                                    inclusive or                                
bit-xor                                                    exclusive or                                
bit-nand                                                   complement of bit-array1 and bit-array2     
bit-nor                                                    complement of bit-array1 or bit-array2      
bit-andc1                                                  and complement of bit-array1 with bit-array2
bit-andc2                                                  and bit-array1 with complement of bit-array2
bit-orc1                                                   or complement of bit-array1 with bit-array2 
bit-orc2                                                   or bit-array1 with complement of bit-array2 
  Figure 15–3: Bit-wise Logical Operations on Bit Arrays

Examples::

 (bit-and (setq ba #*11101010) #*01101011) ⇒  #*01101010
 (bit-and #*1100 #*1010) ⇒  #*1000      
 (bit-andc1 #*1100 #*1010) ⇒  #*0010
 (setq rba (bit-andc2 ba #*00110011 t)) ⇒  #*11001000
 (eq rba ba) ⇒  true
 (bit-not (setq ba #*11101010)) ⇒  #*00010101
 (setq rba (bit-not ba 
                     (setq tba (make-array 8 
                                           :element-type 'bit))))
⇒  #*00010101
 (equal rba tba) ⇒  true
 (bit-xor #*1100 #*1010) ⇒  #*0110

See Also::

lognot, logand

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/with_002dstandard_002dio_002dsyntax.html0000644000175000017500000001275114360276512021661 0ustar cammcamm with-standard-io-syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.12 with-standard-io-syntax [Macro]

with-standard-io-syntax {form}* ⇒ {result}*

Arguments and Values::

forms—an implicit progn.

results—the values returned by the forms.

Description::

Within the dynamic extent of the body of forms, all reader/printer control variables, including any implementation-defined ones not specified by this standard, are bound to values that produce standard read/print behavior. The values for the variables specified by this standard are listed in Figure 23–1.

[Reviewer Note by Barrett: *print-pprint-dispatch* should probably be mentioned here, too.] 

  Variable                     Value                               
  *package*                    The CL-USER package                 
  *print-array*                t                                   
  *print-base*                 10                                  
  *print-case*                 :upcase                             
  *print-circle*               nil                                 
  *print-escape*               t                                   
  *print-gensym*               t                                   
  *print-length*               nil                                 
  *print-level*                nil                                 
  *print-lines*                nil                                 
  *print-miser-width*          nil                                 
  *print-pprint-dispatch*      The standard pprint dispatch table  
  *print-pretty*               nil                                 
  *print-radix*                nil                                 
  *print-readably*             t                                   
  *print-right-margin*         nil                                 
  *read-base*                  10                                  
  *read-default-float-format*  single-float                        
  *read-eval*                  t                                   
  *read-suppress*              nil                                 
  *readtable*                  The standard readtable              

         Figure 23–1: Values of standard control variables

Examples::

 (with-open-file (file pathname :direction :output)
   (with-standard-io-syntax
     (print data file)))

;;; ... Later, in another Lisp:

 (with-open-file (file pathname :direction :input)
   (with-standard-io-syntax
     (setq data (read file))))
gcl-2.6.14/info/gcl/Naming-of-Compiler-Macros.html0000644000175000017500000000572514360276512020177 0ustar cammcamm Naming of Compiler Macros (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.3 Naming of Compiler Macros

Compiler macros may be defined for function names that name macros as well as functions.

Compiler macro definitions are strictly global. There is no provision for defining local compiler macros in the way that macrolet defines local macros. Lexical bindings of a function name shadow any compiler macro definition associated with the name as well as its global function or macro definition.

Note that the presence of a compiler macro definition does not affect the values returned by

functions that access function definitions (e.g., fboundp) or macro definitions (e.g., macroexpand). Compiler macros are global, and the function compiler-macro-function is sufficient to resolve their interaction with other lexical and global definitions.

gcl-2.6.14/info/gcl/Associating-a-Restart-with-a-Condition.html0000644000175000017500000000553214360276512022605 0ustar cammcamm Associating a Restart with a Condition (ANSI and GNU Common Lisp Document)

Previous: , Up: Signaling and Handling Conditions  

9.1.4.7 Associating a Restart with a Condition

A restart can be “associated with” a condition explicitly by with-condition-restarts, or implicitly by restart-case. Such an assocation has dynamic extent.

A single restart may be associated with several conditions at the same time. A single condition may have several associated restarts at the same time.

Active restarts associated with a particular condition can be detected by calling a function such as find-restart, supplying that condition as the condition argument. Active restarts can also be detected without regard to any associated condition by calling such a function without a condition argument, or by supplying a value of nil for such an argument.

gcl-2.6.14/info/gcl/Format-Directive-Interface.html0000644000175000017500000000716014360276512020427 0ustar cammcamm Format Directive Interface (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pretty Printer Concepts  

22.2.1.2 Format Directive Interface

The primary interface to operations for dynamically determining the arrangement of output is provided through the functions and macros of the pretty printer. Figure 22–3 shows the defined names related to pretty printing. 

  *print-lines*            pprint-dispatch                pprint-pop           
  *print-miser-width*      pprint-exit-if-list-exhausted  pprint-tab           
  *print-pprint-dispatch*  pprint-fill                    pprint-tabular       
  *print-right-margin*     pprint-indent                  set-pprint-dispatch  
  copy-pprint-dispatch     pprint-linear                  write                
  format                   pprint-logical-block                                
  formatter                pprint-newline                                      

             Figure 22–3: Defined names related to pretty printing.

Figure 22–4 identifies a set of format directives which serve as an alternate interface to the same pretty printing operations in a more textually compact form. 

  ~I   ~W      ~<...~:>  
  ~:T  ~/.../  ~_        

  Figure 22–4: Format directives related to Pretty Printing
gcl-2.6.14/info/gcl/Tilde-Left_002dBrace_002d_003e-Iteration.html0000644000175000017500000001523714360276512022214 0ustar cammcamm Tilde Left-Brace-> Iteration (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.4 Tilde Left-Brace: Iteration

~{str~}

This is an iteration construct. The argument should be a list, which is used as a set of arguments as if for a recursive call to format. The string str is used repeatedly as the control string. Each iteration can absorb as many elements of the list as it likes as arguments; if str uses up two arguments by itself, then two elements of the list will get used up each time around the loop. If before any iteration step the list is empty, then the iteration is terminated. Also, if a prefix parameter n is given, then there will be at most n repetitions of processing of str. Finally, the ~^ directive can be used to terminate the iteration prematurely.

For example: 

 (format nil "The winners are:~{ ~S~}." 
         '(fred harry jill)) 
⇒  "The winners are: FRED HARRY JILL."                           
 (format nil "Pairs:~{ <~S,~S>~}." 
         '(a 1 b 2 c 3))
⇒  "Pairs: <A,1> <B,2> <C,3>."

~:{ str~} is similar, but the argument should be a list of sublists. At each repetition step, one sublist is used as the set of arguments for processing str; on the next repetition, a new sublist is used, whether or not all of the last sublist had been processed. For example: 

 (format nil "Pairs:~:{ <~S,~S>~} ." 
                 '((a 1) (b 2) (c 3)))
⇒  "Pairs: <A,1> <B,2> <C,3>."

~@{ str~} is similar to ~{ str~} , but instead of using one argument that is a list, all the remaining arguments are used as the list of arguments for the iteration. Example: 

 (format nil "Pairs:~@{ <~S,~S>~} ." 'a 1 'b 2 'c 3)
⇒  "Pairs: <A,1> <B,2> <C,3>."

If the iteration is terminated before all the remaining arguments are consumed, then any arguments not processed by the iteration remain to be processed by any directives following the iteration construct.

~:@{ str~} combines the features of ~:{ str~} and ~@{ str~} . All the remaining arguments are used, and each one must be a list. On each iteration, the next argument is used as a list of arguments to str. Example: 

 (format nil "Pairs:~:@{ <~S,~S>~} ." 
              '(a 1) '(b 2) '(c 3)) 
⇒  "Pairs: <A,1> <B,2> <C,3>."

Terminating the repetition construct with ~:} instead of ~} forces str to be processed at least once, even if the initial list of arguments is null. However, this will not override an explicit prefix parameter of zero.

If str is empty, then an argument is used as str. It must be a format control and precede any arguments processed by the iteration. As an example, the following are equivalent: 

    (apply #'format stream string arguments)
 ≡ (format stream "~1{~:}" string arguments)

This will use string as a formatting string. The ~1{ says it will be processed at most once, and the ~:} says it will be processed at least once. Therefore it is processed exactly once, using arguments as the arguments. This case may be handled more clearly by the ~? directive, but this general feature of ~{ is more powerful than ~?.

Next: , Previous: , Up: FORMAT Control-Flow Operations  

gcl-2.6.14/info/gcl/get_002dinternal_002dreal_002dtime.html0000644000175000017500000000636014360276512021424 0ustar cammcamm get-internal-real-time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.12 get-internal-real-time [Function]

get-internal-real-time <no arguments> ⇒ internal-time

Arguments and Values::

internal-time—a non-negative integer.

Description::

get-internal-real-time returns as an integer the current time in internal time units, relative to an arbitrary time base. The difference between the values of two calls to this function is the amount of elapsed real time (i.e., clock time) between the two calls.

Affected By::

Time of day (i.e., the passage of time). The time base affects the result magnitude.

See Also::

internal-time-units-per-second

gcl-2.6.14/info/gcl/Examples-of-Satisfying-a-One_002dArgument-Test.html0000644000175000017500000000511214360276512023760 0ustar cammcamm Examples of Satisfying a One-Argument Test (ANSI and GNU Common Lisp Document)

Previous: , Up: Satisfying a One-Argument Test  

17.2.2.1 Examples of Satisfying a One-Argument Test

 (count-if #'zerop '(1 #C(0.0 0.0) 0 0.0d0 0.0s0 3)) ⇒  4

 (remove-if-not #'symbolp '(0 1 2 3 4 5 6 7 8 9 A B C D E F))
⇒  (A B C D E F)
 (remove-if (complement #'symbolp) '(0 1 2 3 4 5 6 7 8 9 A B C D E F))
⇒  (A B C D E F)

 (count-if #'zerop '("foo" "" "bar" "" "" "baz" "quux") :key #'length)
⇒  3
gcl-2.6.14/info/gcl/The-Version-part-of-a-Logical-Pathname-Namestring.html0000644000175000017500000000546314360276512024530 0ustar cammcamm The Version part of a Logical Pathname Namestring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax of Logical Pathname Namestrings  

19.3.1.6 The Version part of a Logical Pathname Namestring

Some file systems do not have versions. Logical pathname translation to such a file system ignores the version. This implies that a program cannot rely on being able to store more than one version of a file named by a logical pathname.

If a wildcard-version is specified, it parses into :wild.

gcl-2.6.14/info/gcl/Use-of-Double-Semicolon.html0000644000175000017500000000452614360276512017664 0ustar cammcamm Use of Double Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.4 Use of Double Semicolon

Comments that begin with a double semicolon are all aligned to the same level of indentation as a form would be at that same position in the code. The text of such a comment usually describes the state of the program at the point where the comment occurs, the code which follows the comment, or both.

gcl-2.6.14/info/gcl/change_002dclass.html0000644000175000017500000001722514360276512016370 0ustar cammcamm change-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.8 change-class [Standard Generic Function]

Syntax::

change-class instance new-class &key &allow-other-keys ⇒ instance

Method Signatures::

change-class (instance standard-object) (new-class standard-class) &rest initargs

change-class (instance t) (new-class symbol) &rest initargs

Arguments and Values::

instance—an object.

new-class—a class designator.

initargs—an initialization argument list.

Description::

The generic function change-class changes the class of an instance to new-class. It destructively modifies and returns the instance.

If in the old class there is any slot of the same name as a local slot in the new-class, the value of that slot is retained. This means that if the slot has a value, the value returned by slot-value after change-class is invoked is eql to the value returned by slot-value before change-class is invoked. Similarly, if the slot was unbound, it remains unbound. The other slots are initialized as described in Changing the Class of an Instance.

After completing all other actions, change-class invokes update-instance-for-different-class. The generic function update-instance-for-different-class can be used to assign values to slots in the transformed instance.

See Initializing Newly Added Local Slots (Changing the Class of an Instance).

If the second of the above methods is selected, that method invokes change-class on instance, (find-class new-class), and the initargs.

Examples::


 (defclass position () ())

 (defclass x-y-position (position)
     ((x :initform 0 :initarg :x)
      (y :initform 0 :initarg :y)))

 (defclass rho-theta-position (position)
     ((rho :initform 0)
      (theta :initform 0)))

 (defmethod update-instance-for-different-class :before ((old x-y-position) 
                                                         (new rho-theta-position)
                                                         &key)
   ;; Copy the position information from old to new to make new
   ;; be a rho-theta-position at the same position as old.
   (let ((x (slot-value old 'x))
         (y (slot-value old 'y)))
     (setf (slot-value new 'rho) (sqrt (+ (* x x) (* y y)))
           (slot-value new 'theta) (atan y x))))

;;; At this point an instance of the class x-y-position can be
;;; changed to be an instance of the class rho-theta-position using
;;; change-class:

 (setq p1 (make-instance 'x-y-position :x 2 :y 0))

 (change-class p1 'rho-theta-position)

;;; The result is that the instance bound to p1 is now an instance of
;;; the class rho-theta-position.   The update-instance-for-different-class
;;; method performed the initialization of the rho and theta slots based
;;; on the value of the x and y slots, which were maintained by
;;; the old instance.

See Also::

update-instance-for-different-class , Changing the Class of an Instance

Notes::

The generic function change-class has several semantic difficulties. First, it performs a destructive operation that can be invoked within a method on an instance that was used to select that method. When multiple methods are involved because methods are being combined, the methods currently executing or about to be executed may no longer be applicable. Second, some implementations might use compiler optimizations of slot access, and when the class of an instance is changed the assumptions the compiler made might be violated. This implies that a programmer must not use change-class inside a method if any methods for that generic function access any slots, or the results are undefined.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/declare.html0000644000175000017500000001720214360276512014762 0ustar cammcamm declare (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.18 declare [Symbol]

Syntax::

declare {declaration-specifier}*

Arguments::

declaration-specifier—a declaration specifier; not evaluated.

Description::

A declare expression, sometimes called a declaration, can occur only at the beginning of the bodies of certain forms; that is, it may be preceded only by other declare expressions, or by a documentation string if the context permits.

A declare expression can occur in a lambda expression or in any of the forms listed in Figure 3–23. 

  defgeneric                 do-external-symbols   prog                      
  define-compiler-macro      do-symbols            prog*                     
  define-method-combination  dolist                restart-case              
  define-setf-expander       dotimes               symbol-macrolet           
  defmacro                   flet                  with-accessors            
  defmethod                  handler-case          with-hash-table-iterator  
  defsetf                    labels                with-input-from-string    
  deftype                    let                   with-open-file            
  defun                      let*                  with-open-stream          
  destructuring-bind         locally               with-output-to-string     
  do                         macrolet              with-package-iterator     
  do*                        multiple-value-bind   with-slots                
  do-all-symbols             pprint-logical-block                            

       Figure 3–23: Standardized Forms In Which Declarations Can Occur

A declare expression can only occur where specified by the syntax of these forms. The consequences of attempting to evaluate a declare expression are undefined. In situations where such expressions can appear, explicit checks are made for their presence and they are never actually evaluated; it is for this reason that they are called “declare expressions” rather than “declare forms.”

Macro forms cannot expand into declarations; declare expressions must appear as actual subexpressions of the form to which they refer.

Figure 3–24 shows a list of declaration identifiers that can be used with declare. 

  dynamic-extent  ignore     optimize  
  ftype           inline     special   
  ignorable       notinline  type      

  Figure 3–24: Local Declaration Specifiers

An implementation is free to support other (implementation-defined) declaration identifiers as well.

Examples::

 (defun nonsense (k x z)
   (foo z x)                     ;First call to foo
   (let ((j (foo k x))           ;Second call to foo
         (x (* k k)))
     (declare (inline foo) (special x z))
     (foo x j z)))               ;Third call to foo

In this example, the inline declaration applies only to the third call to foo, but not to the first or second ones. The special declaration of x causes let to make a dynamic binding for x, and causes the reference to x in the body of let to be a dynamic reference. The reference to x in the second call to foo is a local reference to the second parameter of nonsense. The reference to x in the first call to foo is a local reference, not a special one. The special declaration of z causes the reference to z in the third call to foo to be a dynamic reference; it does not refer to the parameter to nonsense named z, because that parameter binding has not been declared to be special. (The special declaration of z does not appear in the body of defun, but in an inner form, and therefore does not affect the binding of the parameter.)

Exceptional Situations::

The consequences of trying to use a declare expression as a form to be evaluated are undefined.

[Editorial Note by KMP: Probably we need to say something here about ill-formed declare expressions.]

See Also::

proclaim , Type Specifiers, declaration, dynamic-extent, ftype, ignorable, ignore, inline, notinline, optimize, type

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/muffle_002dwarning.html0000644000175000017500000000753214360276512016761 0ustar cammcamm muffle-warning (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.43 muffle-warning [Restart]

Data Arguments Required::

None.

Description::

This restart is established by warn so that handlers of warning conditions have a way to tell warn that a warning has already been dealt with and that no further action is warranted.

Examples::

 (defvar *all-quiet* nil) ⇒  *ALL-QUIET*
 (defvar *saved-warnings* '()) ⇒  *SAVED-WARNINGS*
 (defun quiet-warning-handler (c)
   (when *all-quiet*
     (let ((r (find-restart 'muffle-warning c)))
       (when r 
         (push c *saved-warnings*)
         (invoke-restart r)))))
⇒  CUSTOM-WARNING-HANDLER
 (defmacro with-quiet-warnings (&body forms)
   `(let ((*all-quiet* t)
          (*saved-warnings* '()))
      (handler-bind ((warning #'quiet-warning-handler))
        ,@forms
        *saved-warnings*)))
⇒  WITH-QUIET-WARNINGS
 (setq saved
   (with-quiet-warnings
     (warn "Situation #1.")
     (let ((*all-quiet* nil))
       (warn "Situation #2."))
     (warn "Situation #3.")))
 |>  Warning: Situation #2.
⇒  (#<SIMPLE-WARNING 42744421> #<SIMPLE-WARNING 42744365>)
 (dolist (s saved) (format t "~&~A~
 |>  Situation #3.
 |>  Situation #1.
⇒  NIL

See Also::

Restarts, Interfaces to Restarts, invoke-restart , muffle-warning (function), warn

gcl-2.6.14/info/gcl/pprint_002dpop.html0000644000175000017500000001520414360276512016143 0ustar cammcamm pprint-pop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.9 pprint-pop [Local Macro]

Syntax::

pprint-pop <no arguments> ⇒ object

Arguments and Values::

object—an element of the list being printed in the lexically current logical block, or nil.

Description::

Pops one element from the list being printed in the lexically current logical block, obeying *print-length* and *print-circle* as described below.

Each time pprint-pop is called, it pops the next value off the list passed to the lexically current logical block and returns it. However, before doing this, it performs three tests:

*

If the remaining ‘list’ is not a list, “. ” is printed followed by the remaining ‘list.’ (This makes it easier to write printing functions that are robust in the face of malformed arguments.)

*

If *print-length* is non-nil, and pprint-pop has already been called *print-length* times within the immediately containing logical block, “...” is printed. (This makes it easy to write printing functions that properly handle *print-length*.)

*

If *print-circle* is non-nil, and the remaining list is a circular (or shared) reference, then “. ” is printed followed by an appropriate “#n#” marker. (This catches instances of cdr circularity and sharing in lists.)

If either of the three conditions above occurs, the indicated output is printed on the pretty printing stream created by the immediately containing pprint-logical-block and the execution of the immediately containing pprint-logical-block is terminated except for the printing of the suffix.

If pprint-logical-block is given a ‘list’ argument of nil—because it is not processing a list—pprint-pop can still be used to obtain support for *print-length*. In this situation, the first and third tests above are disabled and pprint-pop always returns nil. See Examples of using the Pretty Printer—specifically, the pprint-vector example.

Whether or not pprint-pop is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of pprint-pop are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use pprint-pop outside of pprint-logical-block are undefined.

Side Effects::

Might cause output to the pretty printing stream associated with the lexically current logical block.

Affected By::

*print-length*, *print-circle*.

Exceptional Situations::

An error is signaled (either at macro expansion time or at run time) if a usage of pprint-pop occurs where there is no lexically containing pprint-logical-block form.

The consequences are undefined if pprint-pop is executed outside of the dynamic extent of this pprint-logical-block.

See Also::

pprint-exit-if-list-exhausted , pprint-logical-block .

Notes::

It is frequently a good idea to call pprint-exit-if-list-exhausted before calling pprint-pop.

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Alphabetic-Characters.html0000644000175000017500000000515714360276512017502 0ustar cammcamm Alphabetic Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.2 Alphabetic Characters

The alphabetic_1 characters are a subset of the graphic characters. Of the standard characters, only these are the alphabetic_1 characters:

A B C D E F G H I J K L M N O P Q R S T U V W X Y Z

a b c d e f g h i j k l m n o p q r s t u v w x y z

Any implementation-defined character that has case must be alphabetic_1. For each implementation-defined graphic character that has no case, it is implementation-defined whether that character is alphabetic_1.

gcl-2.6.14/info/gcl/Sharpsign-Less_002dThan_002dSign.html0000644000175000017500000000457514360276512021144 0ustar cammcamm Sharpsign Less-Than-Sign (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sharpsign  

2.4.8.23 Sharpsign Less-Than-Sign

#< is not valid reader syntax. The Lisp reader will signal an error

of type reader-error

on encountering #<. This syntax is typically used in the printed representation of objects that cannot be read back in.

gcl-2.6.14/info/gcl/simple_002dwarning.html0000644000175000017500000000474114360276512016773 0ustar cammcamm simple-warning (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.21 simple-warning [Condition Type]

Class Precedence List::

simple-warning, simple-condition, warning, condition, t

Description::

The type simple-warning represents conditions that are signaled by warn whenever a

format control

is supplied as the function’s first argument.

gcl-2.6.14/info/gcl/Inheritance-of-Slots-and-Slot-Options.html0000644000175000017500000001744114360276512022435 0ustar cammcamm Inheritance of Slots and Slot Options (ANSI and GNU Common Lisp Document)

Previous: , Up: Slots  

7.5.3 Inheritance of Slots and Slot Options

The set of the names of all slots accessible in an instance of a class C is the union of the sets of names of slots defined by C and its superclasses. The structure of an instance is the set of names of local slots in that instance.

In the simplest case, only one class among C and its superclasses defines a slot with a given slot name. If a slot is defined by a superclass of C, the slot is said to be inherited. The characteristics of the slot are determined by the slot specifier of the defining class. Consider the defining class for a slot S. If the value of the :allocation slot option is :instance, then S is a local slot and each instance of C has its own slot named S that stores its own value. If the value of the :allocation slot option is :class, then S is a shared slot, the class that defined S stores the value, and all instances of C can access that single slot. If the :allocation slot option is omitted, :instance is used.

In general, more than one class among C and its superclasses can define a slot with a given name. In such cases, only one slot with the given name is accessible in an instance of C, and the characteristics of that slot are a combination of the several slot specifiers, computed as follows:

*

All the slot specifiers for a given slot name are ordered from most specific to least specific, according to the order in C’s class precedence list of the classes that define them. All references to the specificity of slot specifiers immediately below refers to this ordering.

*

The allocation of a slot is controlled by the most specific slot specifier. If the most specific slot specifier does not contain an :allocation slot option, :instance is used. Less specific slot specifiers do not affect the allocation.

*

The default initial value form for a slot is the value of the :initform slot option in the most specific slot specifier that contains one. If no slot specifier contains an :initform slot option, the slot has no default initial value form.

*

The contents of a slot will always be of type (and T_1 ... T_n) where T_1 ... T_n are the values of the :type slot options contained in all of the slot specifiers. If no slot specifier contains the :type slot option, the contents of the slot will always be of type t. The consequences of attempting to store in a slot a value that does not satisfy the type of the slot are undefined.

*

The set of initialization arguments that initialize a given slot is the union of the initialization arguments declared in the :initarg slot options in all the slot specifiers.

*

The documentation string for a slot is the value of the :documentation slot option in the most specific slot specifier that contains one. If no slot specifier contains a :documentation slot option, the slot has no documentation string.

A consequence of the allocation rule is that a shared slot can be shadowed. For example, if a class C_1 defines a slot named S whose value for the :allocation slot option is :class, that slot is accessible in instances of C_1 and all of its subclasses. However, if C_2 is a subclass of C_1 and also defines a slot named S, C_1’s slot is not shared by instances of C_2 and its subclasses. When a class C_1 defines a shared slot, any subclass C_2 of C_1 will share this single slot unless the defclass form for C_2 specifies a slot of the same name or there is a superclass of C_2 that precedes C_1 in the class precedence list of C_2 that defines a slot of the same name.

A consequence of the type rule is that the value of a slot satisfies the type constraint of each slot specifier that contributes to that slot. Because the result of attempting to store in a slot a value that does not satisfy the type constraint for the slot is undefined, the value in a slot might fail to satisfy its type constraint.

The :reader, :writer, and :accessor slot options create methods rather than define the characteristics of a slot. Reader and writer methods are inherited in the sense described in Inheritance of Methods.

Methods that access slots use only the name of the slot and the type of the slot’s value. Suppose a superclass provides a method that expects to access a shared slot of a given name, and a subclass defines a local slot with the same name. If the method provided by the superclass is used on an instance of the subclass, the method accesses the local slot.

Previous: , Up: Slots  

gcl-2.6.14/info/gcl/sort.html0000644000175000017500000002236014360276512014353 0ustar cammcamm sort (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.13 sort, stable-sort [Function]

sort sequence predicate &key key ⇒ sorted-sequence

stable-sort sequence predicate &key key ⇒ sorted-sequence

Arguments and Values::

sequence—a proper sequence.

predicate—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

sorted-sequence—a sequence.

Description::

sort and stable-sort destructively sort sequences according to the order determined by the predicate function.

If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list.

sort determines the relationship between two elements by giving keys extracted from the elements to the predicate. The first argument to the predicate function is the part of one element of sequence extracted by the key function (if supplied); the second argument is the part of another element of sequence extracted by the key function (if supplied). Predicate should return true if and only if the first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then the predicate should return false.

The argument to the key function is the sequence element. The return value of the key function becomes an argument to predicate. If key is not supplied or nil, the sequence element itself is used. There is no guarantee on the number of times the key will be called.

If the key and predicate always return, then the sorting operation will always terminate, producing a sequence containing the same elements as sequence (that is, the result is a permutation of sequence). This is guaranteed even if the predicate does not really consistently represent a total order (in which case the elements will be scrambled in some unpredictable way, but no element will be lost). If the key consistently returns meaningful keys, and the predicate does reflect some total ordering criterion on those keys, then the elements of the sorted-sequence will be properly sorted according to that ordering.

The sorting operation performed by sort is not guaranteed stable. Elements considered equal by the predicate might or might not stay in their original order. The predicate is assumed to consider two elements x and y to be equal if (funcall predicate x y) and (funcall predicate y x) are both false. stable-sort guarantees stability.

The sorting operation can be destructive in all cases. In the case of a vector argument, this is accomplished by permuting the elements in place. In the case of a list, the list is destructively reordered in the same manner as for nreverse.

Examples::

 (setq tester (copy-seq "lkjashd")) ⇒  "lkjashd"
 (sort tester #'char-lessp) ⇒  "adhjkls"
 (setq tester (list '(1 2 3) '(4 5 6) '(7 8 9))) ⇒  ((1 2 3) (4 5 6) (7 8 9))
 (sort tester #'> :key #'car)  ⇒  ((7 8 9) (4 5 6) (1 2 3)) 
 (setq tester (list 1 2 3 4 5 6 7 8 9 0)) ⇒  (1 2 3 4 5 6 7 8 9 0)
 (stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y))))
⇒  (1 3 5 7 9 2 4 6 8 0)
 (sort (setq committee-data
             (vector (list (list "JonL" "White") "Iteration")
                     (list (list "Dick" "Waters") "Iteration")
                     (list (list "Dick" "Gabriel") "Objects")
                     (list (list "Kent" "Pitman") "Conditions")
                     (list (list "Gregor" "Kiczales") "Objects")
                     (list (list "David" "Moon") "Objects")
                     (list (list "Kathy" "Chapman") "Editorial")
                     (list (list "Larry" "Masinter") "Cleanup")
                     (list (list "Sandra" "Loosemore") "Compiler")))
       #'string-lessp :key #'cadar)
⇒  #((("Kathy" "Chapman") "Editorial")
     (("Dick" "Gabriel") "Objects")
     (("Gregor" "Kiczales") "Objects")
     (("Sandra" "Loosemore") "Compiler")
     (("Larry" "Masinter") "Cleanup")
     (("David" "Moon") "Objects")
     (("Kent" "Pitman") "Conditions")
     (("Dick" "Waters") "Iteration")
     (("JonL" "White") "Iteration"))
 ;; Note that individual alphabetical order within `committees'
 ;; is preserved.
 (setq committee-data 
       (stable-sort committee-data #'string-lessp :key #'cadr))
⇒  #((("Larry" "Masinter") "Cleanup")
     (("Sandra" "Loosemore") "Compiler")
     (("Kent" "Pitman") "Conditions")
     (("Kathy" "Chapman") "Editorial")
     (("Dick" "Waters") "Iteration")
     (("JonL" "White") "Iteration")
     (("Dick" "Gabriel") "Objects")
     (("Gregor" "Kiczales") "Objects")
     (("David" "Moon") "Objects"))

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

merge ,

Compiler Terminology,

Traversal Rules and Side Effects,

Destructive Operations

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/compile.html0000644000175000017500000001504514360276512015016 0ustar cammcamm compile (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.3 compile [Function]

compile name &optional definition ⇒ function, warnings-p, failure-p

Arguments and Values::

name—a function name, or nil.

definition—a lambda expression or a function. The default is the function definition of name if it names a function, or the macro function of name if it names a macro. The consequences are undefined if no definition is supplied when the name is nil.

function—the function-name,

or a compiled function.

warnings-p—a generalized boolean.

failure-p—a generalized boolean.

Description::

Compiles an interpreted function.

compile produces a compiled function from definition. If the definition is a lambda expression, it is coerced to a function.

If the definition is already a compiled function, compile either produces that function itself (i.e., is an identity operation) or an equivalent function.

[Editorial Note by KMP: There are a number of ambiguities here that still need resolution.] If the name is nil, the resulting compiled function is returned directly as the primary value. If a non-nil name is given, then the resulting compiled function replaces the existing function definition of name and the name is returned as the primary value; if name is a symbol that names a macro, its macro function is updated and the name is returned as the primary value.

Literal objects appearing in code processed by the compile function are neither copied nor coalesced. The code resulting from the execution of compile references objects that are eql to the corresponding objects in the source code.

compile is permitted, but not required, to establish a handler for conditions of type error. For example, the handler might issue a warning and restart compilation from some implementation-dependent point in order to let the compilation proceed without manual intervention.

The secondary value, warnings-p, is false if no conditions of type error or warning were detected by the compiler, and true otherwise.

The tertiary value, failure-p, is false if no conditions of type error or warning (other than style-warning) were detected by the compiler, and true otherwise.

Examples::

 (defun foo () "bar") ⇒  FOO
 (compiled-function-p #'foo) ⇒  implementation-dependent
 (compile 'foo) ⇒  FOO 
 (compiled-function-p #'foo) ⇒  true
 (setf (symbol-function 'foo)
       (compile nil '(lambda () "replaced"))) ⇒  #<Compiled-Function>
 (foo) ⇒  "replaced"

Affected By::

*error-output*,

*macroexpand-hook*.

The presence of macro definitions and proclamations.

Exceptional Situations::

The consequences are undefined if the lexical environment surrounding the function to be compiled contains any bindings other than those for macros, symbol macros, or declarations.

For information about errors detected during the compilation process, see Exceptional Situations in the Compiler.

See Also::

compile-file

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/subtypep.html0000644000175000017500000002754314360276512015247 0ustar cammcamm subtypep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.26 subtypep [Function]

subtypep type-1 type-2 &optional environment ⇒ subtype-p, valid-p

Arguments and Values::

type-1—a type specifier.

type-2—a type specifier.

environment—an environment object. The default is nil, denoting the null lexical environment and the current global environment.

subtype-p—a generalized boolean.

valid-p—a generalized boolean.

Description::

If type-1 is a recognizable subtype of type-2, the first value is true. Otherwise, the first value is false, indicating that either type-1 is not a subtype of type-2, or else type-1 is a subtype of type-2 but is not a recognizable subtype.

A second value is also returned indicating the ‘certainty’ of the first value. If this value is true, then the first value is an accurate indication of the subtype relationship. (The second value is always true when the first value is true.)

Figure 4–9 summarizes the possible combinations of values that might result. 

  Value 1  Value 2  Meaning                                               
  true     true     type-1 is definitely a subtype of type-2.             
  false    true     type-1 is definitely not a subtype of type-2.         
  false    false    subtypep could not determine the relationship,        
                    so type-1 might or might not be a subtype of type-2.  

               Figure 4–9: Result possibilities for subtypep

subtypep is permitted to return the values false and false only when at least one argument involves one of these type specifiers: and, eql, the list form of function, member, not, or, satisfies, or values. (A type specifier ‘involves’ such a symbol if, after being type expanded, it contains that symbol in a position that would call for its meaning as a type specifier to be used.) One consequence of this is that if neither type-1 nor type-2 involves any of these type specifiers, then subtypep is obliged to determine the relationship accurately. In particular, subtypep returns the values true and true if the arguments are equal and do not involve any of these type specifiers.

subtypep never returns a second value of nil when both type-1 and type-2 involve only the names in Figure~4–2, or names of types defined by defstruct, define-condition, or defclass, or derived types that expand into only those names. While type specifiers listed in Figure~4–2 and names of defclass and defstruct can in some cases be implemented as derived types, subtypep regards them as primitive.

The relationships between types reflected by subtypep are those specific to the particular implementation. For example, if an implementation supports only a single type of floating-point numbers, in that implementation (subtypep 'float 'long-float) returns the values true and true (since the two types are identical).

For all T1 and T2 other than *, (array T1) and (array T2) are two different type specifiers that always refer to the same sets of things if and only if they refer to arrays of exactly the same specialized representation, i.e., if (upgraded-array-element-type 'T1) and (upgraded-array-element-type 'T2) return two different type specifiers that always refer to the same sets of objects. This is another way of saying that `(array type-specifier) and `(array ,(upgraded-array-element-type 'type-specifier)) refer to the same set of specialized array representations. For all T1 and T2 other than *, the intersection of (array T1) and (array T2) is the empty set if and only if they refer to arrays of different, distinct specialized representations.

Therefore, 

 (subtypep '(array T1) '(array T2)) ⇒  true

if and only if 

 (upgraded-array-element-type 'T1)  and
 (upgraded-array-element-type 'T2)

return two different type specifiers that always refer to the same sets of objects.

For all type-specifiers T1 and T2 other than *, 

 (subtypep '(complex T1) '(complex T2)) ⇒  true, true

if:

1.

T1 is a subtype of T2, or

2.

(upgraded-complex-part-type 'T1) and (upgraded-complex-part-type 'T2) return two different type specifiers that always refer to the same sets of objects; in this case, (complex T1) and (complex T2) both refer to the same specialized representation.

The values are false and true otherwise.

The form 

 (subtypep '(complex single-float) '(complex float))

must return true in all implementations, but 

 (subtypep '(array single-float) '(array float))

returns true only in implementations that do not have a specialized array representation for single floats distinct from that for other floats.

Examples::

 (subtypep 'compiled-function 'function) ⇒  true, true
 (subtypep 'null 'list) ⇒  true, true
 (subtypep 'null 'symbol) ⇒  true, true
 (subtypep 'integer 'string) ⇒  false, true
 (subtypep '(satisfies dummy) nil) ⇒  false, implementation-dependent
 (subtypep '(integer 1 3) '(integer 1 4)) ⇒  true, true
 (subtypep '(integer (0) (0)) 'nil) ⇒  true, true
 (subtypep 'nil '(integer (0) (0))) ⇒  true, true
 (subtypep '(integer (0) (0)) '(member)) ⇒  true, true ;or false, false
 (subtypep '(member) 'nil) ⇒  true, true ;or false, false
 (subtypep 'nil '(member)) ⇒  true, true ;or false, false

Let <aet-x> and <aet-y> be two distinct type specifiers that do not always refer to the same sets of objects in a given implementation, but for which make-array, will return an object of the same array type.

Thus, in each case, 

  (subtypep (array-element-type (make-array 0 :element-type '<aet-x>))
            (array-element-type (make-array 0 :element-type '<aet-y>)))
⇒  true, true

  (subtypep (array-element-type (make-array 0 :element-type '<aet-y>))
            (array-element-type (make-array 0 :element-type '<aet-x>)))
⇒  true, true

If (array <aet-x>) and (array <aet-y>) are different names for exactly the same set of objects, these names should always refer to the same sets of objects. That implies that the following set of tests are also true: 

 (subtypep '(array <aet-x>) '(array <aet-y>)) ⇒  true, true
 (subtypep '(array <aet-y>) '(array <aet-x>)) ⇒  true, true

See Also::

Types

Notes::

The small differences between the subtypep specification for the array and complex types are necessary because there is no creation function for complexes which allows the specification of the resultant part type independently of the actual types of the parts. Thus in the case of the type complex, the actual type of the parts is referred to, although a number can be a member of more than one type. For example, 17 is of type (mod 18) as well as type (mod 256) and type integer; and 2.3f5 is of type single-float as well as type float.

Next: , Previous: , Up: Types and Classes Dictionary  

gcl-2.6.14/info/gcl/Special-_0022Syntax_0022-Notations-for-Overloaded-Operators.html0000644000175000017500000000674414360276512026144 0ustar cammcamm Special "Syntax" Notations for Overloaded Operators (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.25 Special "Syntax" Notations for Overloaded Operators

If two descriptions exist for the same operation but with different numbers of arguments, then the extra arguments are to be treated as optional. For example, this pair of lines:

file-position stream ⇒ position

file-position stream position-spec ⇒ success-p

is operationally equivalent to this line:

file-position stream &optional position-spec ⇒ result

and differs only in that it provides on opportunity to introduce different names for parameter and values for each case. The separated (multi-line) notation is used when an operator is overloaded in such a way that the parameters are used in different ways depending on how many arguments are supplied (e.g., for the function /) or the return values are different in the two cases (e.g., for the function file-position).

gcl-2.6.14/info/gcl/The-Evaluation-Model.html0000644000175000017500000001102614360276512017244 0ustar cammcamm The Evaluation Model (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.2 The Evaluation Model

A Common Lisp system evaluates forms with respect to lexical, dynamic, and global environments. The following sections describe the components of the Common Lisp evaluation model.

• Form Evaluation  
• Symbols as Forms  
• Lexical Variables  
• Dynamic Variables  
• Constant Variables  
• Symbols Naming Both Lexical and Dynamic Variables  
• Conses as Forms  
• Special Forms  
• Macro Forms  
• Function Forms  
• Lambda Forms  
• Self-Evaluating Objects  
• Examples of Self-Evaluating Objects  
gcl-2.6.14/info/gcl/_002acompile_002dprint_002a.html0000644000175000017500000000557514360276512020073 0ustar cammcamm *compile-print* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.8 *compile-print*, *compile-verbose* [Variable]

Value Type::

a generalized boolean.

Initial Value::

implementation-dependent.

Description::

The value of *compile-print* is the default value of the :print argument to compile-file. The value of *compile-verbose* is the default value of the :verbose argument to compile-file.

See Also::

compile-file

gcl-2.6.14/info/gcl/method.html0000644000175000017500000000647314360276512014653 0ustar cammcamm method (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.11 method [System Class]

Class Precedence List::

method, t

Description::

A method is an object that represents a modular part of the behavior of a generic function.

A method contains code to implement the method’s behavior, a sequence of parameter specializers that specify when the given method is applicable, and a sequence of qualifiers that is used by the method combination facility to distinguish among methods. Each required parameter of each method has an associated parameter specializer, and the method will be invoked only on arguments that satisfy its parameter specializers.

The method combination facility controls the selection of methods, the order in which they are run, and the values that are returned by the generic function. The object system offers a default method combination type and provides a facility for declaring new types of method combination.

See Also::

Generic Functions and Methods

gcl-2.6.14/info/gcl/slot_002dexists_002dp.html0000644000175000017500000000625214360276512017241 0ustar cammcamm slot-exists-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.10 slot-exists-p [Function]

slot-exists-p object slot-name ⇒ generalized-boolean

Arguments and Values::

object—an object.

slot-name—a symbol.

generalized-boolean—a generalized boolean.

Description::

Returns true if the object has a slot named slot-name.

Affected By::

defclass, defstruct

See Also::

defclass , slot-missing

Notes::

Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-exists-p using the function slot-exists-p-using-class described in the Metaobject Protocol.

gcl-2.6.14/info/gcl/export.html0000644000175000017500000001461314360276512014707 0ustar cammcamm export (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.2 export [Function]

export symbols &optional package ⇒ t

Arguments and Values::

symbols—a designator for a list of symbols.

package—a package designator.

The default is the current package.

Description::

export makes one or more symbols that are accessible in package (whether directly or by inheritance) be external symbols of that package.

If any of the symbols is already accessible as an external symbol of package, export has no effect on that symbol. If the symbol is present in package as an internal symbol, it is simply changed to external status. If it is accessible as an internal symbol via use-package, it is first imported into package, then exported. (The symbol is then present in the package whether or not package continues to use the package through which the symbol was originally inherited.)

export makes each symbol accessible to all the packages that use package. All of these packages are checked for name conflicts: (export s p) does (find-symbol (symbol-name s) q) for each package q in (package-used-by-list p). Note that in the usual case of an export during the initial definition of a package, the result of package-used-by-list is nil and the name-conflict checking takes negligible time. When multiple changes are to be made, for example when export is given a list of symbols, it is permissible for the implementation to process each change separately, so that aborting from a name conflict caused by any but the first symbol in the list does not unexport the first symbol in the list. However, aborting from a name-conflict error caused by export of one of symbols does not leave that symbol accessible to some packages and inaccessible to others; with respect to each of symbols processed, export behaves as if it were as an atomic operation.

A name conflict in export between one of symbols being exported and a symbol already present in a package that would inherit the newly-exported symbol may be resolved in favor of the exported symbol by uninterning the other one, or in favor of the already-present symbol by making it a shadowing symbol.

Examples::

 (make-package 'temp :use nil) ⇒  #<PACKAGE "TEMP">
 (use-package 'temp) ⇒  T
 (intern "TEMP-SYM" 'temp) ⇒  TEMP::TEMP-SYM, NIL
 (find-symbol "TEMP-SYM") ⇒  NIL, NIL
 (export (find-symbol "TEMP-SYM" 'temp) 'temp) ⇒  T
 (find-symbol "TEMP-SYM") ⇒  TEMP-SYM, :INHERITED

Side Effects::

The package system is modified.

Affected By::

Accessible symbols.

Exceptional Situations::

If any of the symbols is not accessible at all in package, an error of type package-error is signaled that is correctable by permitting the user to interactively specify whether that symbol should be imported.

See Also::

import , unexport , Package Concepts

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/Declaration-Scope.html0000644000175000017500000001154114360276512016657 0ustar cammcamm Declaration Scope (ANSI and GNU Common Lisp Document)

Previous: , Up: Declarations  

3.3.4 Declaration Scope

Declarations can be divided into two kinds: those that apply to the bindings of variables or functions; and those that do not apply to bindings.

A declaration that appears at the head of a binding form and applies to a variable or function binding made by that form is called a bound declaration ; such a declaration affects both the binding and any references within the scope of the declaration.

Declarations that are not bound declarations are called free declarations .

A free declaration in a form F1 that applies to a binding for a name N established by some form F2 of which F1 is a subform affects only references to N within F1; it does not to apply to other references to N outside of F1, nor does it affect the manner in which the binding of N by F2 is established.

Declarations that do not apply to bindings can only appear as free declarations.

The scope of a bound declaration is the same as the lexical scope of the binding to which it applies; for special variables, this means the scope that the binding would have had had it been a lexical binding.

Unless explicitly stated otherwise, the scope of a free declaration includes only the body subforms of the form at whose head it appears, and no other subforms. The scope of free declarations specifically does not include initialization forms for bindings established by the form containing the declarations.

Some iteration forms include step, end-test, or result subforms that are also included in the scope of declarations that appear in the iteration form. Specifically, the iteration forms and subforms involved are:

*

do, do*: step-forms, end-test-form, and result-forms.

*

dolist, dotimes: result-form

*

do-all-symbols, do-external-symbols, do-symbols: result-form

• Examples of Declaration Scope  

Previous: , Up: Declarations  

gcl-2.6.14/info/gcl/Iteration-Dictionary.html0000644000175000017500000000517014360276512017425 0ustar cammcamm Iteration Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Iteration  

6.2 Iteration Dictionary

• do  
• dotimes  
• dolist  
• loop  
• loop-finish  
gcl-2.6.14/info/gcl/get.html0000644000175000017500000001471014360276512014143 0ustar cammcamm get (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.15 get [Accessor]

get symbol indicator &optional default ⇒ value

(setf ( get symbol indicator &optional default) new-value)

Arguments and Values::

symbol—a symbol.

indicator—an object.

default—an object. The default is nil.

value—if the indicated property exists, the object that is its value; otherwise, the specified default.

new-value—an object.

Description::

get finds a property on the property list_2 of symbol whose property indicator is identical to indicator, and returns its corresponding property value.

If there are multiple properties_1 with that property indicator, get uses the first such property.

If there is no property with that property indicator, default is returned.

setf of get may be used to associate a new object with an existing indicator already on the symbol’s property list, or to create a new assocation if none exists.

If there are multiple properties_1 with that property indicator, setf of get associates the new-value with the first such property.

When a get form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored.

Examples::

 (defun make-person (first-name last-name)
   (let ((person (gensym "PERSON")))
     (setf (get person 'first-name) first-name)
     (setf (get person 'last-name) last-name)
     person)) ⇒  MAKE-PERSON
 (defvar *john* (make-person "John" "Dow")) ⇒  *JOHN*
 *john* ⇒  #:PERSON4603
 (defvar *sally* (make-person "Sally" "Jones")) ⇒  *SALLY*
 (get *john* 'first-name) ⇒  "John"
 (get *sally* 'last-name) ⇒  "Jones"
 (defun marry (man woman married-name)
   (setf (get man 'wife) woman)
   (setf (get woman 'husband) man)
   (setf (get man 'last-name) married-name)
   (setf (get woman 'last-name) married-name)
   married-name) ⇒  MARRY
 (marry *john* *sally* "Dow-Jones") ⇒  "Dow-Jones"
 (get *john* 'last-name) ⇒  "Dow-Jones"
 (get (get *john* 'wife) 'first-name) ⇒  "Sally"
 (symbol-plist *john*)
⇒  (WIFE #:PERSON4604 LAST-NAME "Dow-Jones" FIRST-NAME "John")
 (defmacro age (person &optional (default ''thirty-something)) 
   `(get ,person 'age ,default)) ⇒  AGE
 (age *john*) ⇒  THIRTY-SOMETHING
 (age *john* 20) ⇒  20
 (setf (age *john*) 25) ⇒  25
 (age *john*) ⇒  25
 (age *john* 20) ⇒  25

Exceptional Situations::

Should signal an error of type type-error if symbol is not a symbol.

See Also::

getf , symbol-plist , remprop

Notes::

 (get x y) ≡ (getf (symbol-plist x) y)

Numbers and characters are not recommended for use as indicators in portable code since get tests with eq rather than eql, and consequently the effect of using such indicators is implementation-dependent.

There is no way using get to distinguish an absent property from one whose value is default. However, see get-properties.

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/Overview-of-The-Lisp-Printer.html0000644000175000017500000000602014360276512020633 0ustar cammcamm Overview of The Lisp Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Lisp Printer  

22.1.1 Overview of The Lisp Printer

Common Lisp provides a representation of most objects in the form of printed text called the printed representation. Functions such as print take an object and send the characters of its printed representation to a stream. The collection of routines that does this is known as the (Common Lisp) printer.

Reading a printed representation typically produces an object that is equal to the originally printed object.

• Multiple Possible Textual Representations  
• Printer Escaping  
gcl-2.6.14/info/gcl/set_002dexclusive_002dor.html0000644000175000017500000001562314360276512017726 0ustar cammcamm set-exclusive-or (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.47 set-exclusive-or, nset-exclusive-or [Function]

set-exclusive-or list-1 list-2 &key key test test-not ⇒ result-list

nset-exclusive-or list-1 list-2 &key key test test-not ⇒ result-list

Arguments and Values::

list-1—a proper list.

list-2—a proper list.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

result-list—a list.

Description::

set-exclusive-or returns a list of elements that appear in exactly one of list-1 and list-2.

nset-exclusive-or is the destructive version of set-exclusive-or.

For all possible ordered pairs consisting of one element from list-1 and one element from list-2, the :test or :test-not function is used to determine whether they satisfy the test.

If :key is supplied, it is used to extract the part to be tested from the list-1 or list-2 element. The first argument to the :test or :test-not function is the part of an element of list-1 extracted by the :key function (if supplied); the second argument is the part of an element of list-2 extracted by the :key function (if supplied). If :key is not supplied or nil, the list-1 or list-2 element is used.

The result contains precisely those elements of list-1 and list-2 that appear in no matching pair.

The result list of set-exclusive-or might share storage with one of list-1 or list-2.

Examples::

 (setq lst1 (list 1 "a" "b")
       lst2 (list 1 "A" "b")) ⇒  (1 "A" "b")
 (set-exclusive-or lst1 lst2) ⇒  ("b" "A" "b" "a")
 (set-exclusive-or lst1 lst2 :test #'equal) ⇒  ("A" "a")
 (set-exclusive-or lst1 lst2 :test 'equalp) ⇒  NIL 
 (nset-exclusive-or lst1 lst2) ⇒  ("a" "b" "A" "b") 
 (setq lst1 (list (("a" . "b") ("c" . "d") ("e" . "f"))))
⇒  (("a" . "b") ("c" . "d") ("e" . "f"))
 (setq lst2 (list (("c" . "a") ("e" . "b") ("d" . "a"))))
⇒  (("c" . "a") ("e" . "b") ("d" . "a")) 
 (nset-exclusive-or lst1 lst2 :test #'string= :key #'cdr)
⇒  (("c" . "d") ("e" . "f") ("c" . "a") ("d" . "a")) 
 lst1 ⇒  (("a" . "b") ("c" . "d") ("e" . "f"))
 lst2 ⇒  (("c" . "a") ("d" . "a"))

Side Effects::

nset-exclusive-or is permitted to modify any part, car or cdr, of the list structure of list-1 or list-2.

Exceptional Situations::

Should be prepared to signal an error of type type-error if list-1 and list-2 are not proper lists.

See Also::

Compiler Terminology,

Traversal Rules and Side Effects

Notes::

The :test-not parameter is deprecated.

Since the nset-exclusive-or side effect is not required, it should not be used in for-effect-only positions in portable code.

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/rest.html0000644000175000017500000000665714360276512014354 0ustar cammcamm rest (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.32 rest [Accessor]

rest list ⇒ tail

(setf ( rest list) new-tail)

Arguments and Values::

list—a list,

which might be a dotted list or a circular list.

tail—an object.

Description::

rest performs the same operation as cdr, but mnemonically complements first. Specifically, 

 (rest list) ≡ (cdr list)
 (setf (rest list) new-tail) ≡ (setf (cdr list) new-tail)

Examples::

 (rest '(1 2)) ⇒  (2)
 (rest '(1 . 2)) ⇒  2
 (rest '(1)) ⇒  NIL
 (setq *cons* '(1 . 2)) ⇒  (1 . 2)
 (setf (rest *cons*) "two") ⇒  "two"
 *cons* ⇒  (1 . "two")

See Also::

cdr, nthcdr

Notes::

rest is often preferred stylistically over cdr when the argument is to being subjectively viewed as a list rather than as a cons.

gcl-2.6.14/info/gcl/defpackage.html0000644000175000017500000003526314360276512015444 0ustar cammcamm defpackage (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.19 defpackage [Macro]

defpackage defined-package-name [[!option]] ⇒ package

option ::={(:nicknames {nickname}*)}* |             (:documentation string) |             {(:use {package-name}*)}* |             {(:shadow {!symbol-name}*)}* |             {(:shadowing-import-from package-name {!symbol-name}*)}* |             {(:import-from package-name {!symbol-name}*)}* |             {(:export {!symbol-name}*)}* |             {(:intern {!symbol-name}*)}* |             (:size integer)

symbol-name ::=(symbol | string)

Arguments and Values::

defined-package-name—a string designator.

package-name—a package designator.

nickname—a string designator.

symbol-name—a string designator.

package—the package named package-name.

Description::

defpackage creates a package as specified and returns the package.

If defined-package-name already refers to an existing package, the name-to-package mapping for that name is not changed. If the new definition is at variance with the current state of that package, the consequences are undefined; an implementation might choose to modify the existing package to reflect the new definition. If defined-package-name is a symbol, its name is used.

The standard options are described below.

:nicknames

The arguments to :nicknames set the package’s nicknames to the supplied names.

:documentation

The argument to :documentation specifies a documentation string; it is attached as a documentation string to the package. At most one :documentation option can appear in a single defpackage form.

:use

The arguments to :use set the packages that the package named by package-name will inherit from. If :use is not supplied,

it defaults to the same implementation-dependent value as the :use argument to make-package.

:shadow

The arguments to :shadow, symbol-names, name symbols that are to be created in the package being defined. These symbols are added to the list of shadowing symbols effectively as if by shadow.

:shadowing-import-from

The symbols named by the argument symbol-names are found (involving a lookup as if by find-symbol) in the specified package-name. The resulting symbols are imported into the package being defined, and placed on the shadowing symbols list as if by shadowing-import. In no case are symbols created in any package other than the one being defined.

:import-from

The symbols named by the argument symbol-names are found in the package named by package-name and they are imported into the package being defined. In no case are symbols created in any package other than the one being defined.

:export

The symbols named by the argument symbol-names are found or created in the package being defined and exported. The :export option interacts with the :use option, since inherited symbols can be used rather than new ones created. The :export option interacts with the :import-from and :shadowing-import-from options, since imported symbols can be used rather than new ones created. If an argument to the :export option is accessible as an (inherited) internal symbol via use-package, that the symbol named by symbol-name is first imported into the package being defined, and is then exported from that package.

:intern

The symbols named by the argument symbol-names are found or created in the package being defined. The :intern option interacts with the :use option, since inherited symbols can be used rather than new ones created.

:size

The argument to the :size option declares the approximate number of symbols expected in the package. This is an efficiency hint only and might be ignored by an implementation.

The order in which the options appear in a defpackage form is irrelevant. The order in which they are executed is as follows:

1.

:shadow and :shadowing-import-from.

2.

:use.

3.

:import-from and :intern.

4.

:export.

Shadows are established first, since they might be necessary to block spurious name conflicts when the :use option is processed. The :use option is executed next so that :intern and :export options can refer to normally inherited symbols. The :export option is executed last so that it can refer to symbols created by any of the other options; in particular, shadowing symbols and imported symbols can be made external.

If a defpackage form appears as a top level form, all of the actions normally performed by this macro at load time must also be performed at compile time.

Examples::

 (defpackage "MY-PACKAGE"
   (:nicknames "MYPKG" "MY-PKG")
   (:use "COMMON-LISP")
   (:shadow "CAR" "CDR")
   (:shadowing-import-from "VENDOR-COMMON-LISP"  "CONS")
   (:import-from "VENDOR-COMMON-LISP"  "GC")
   (:export "EQ" "CONS" "FROBOLA")
   )

 (defpackage my-package
   (:nicknames mypkg :MY-PKG)  ; remember Common Lisp conventions for case
   (:use common-lisp)          ; conversion on symbols
   (:shadow CAR :cdr #:cons)                              
   (:export "CONS")            ; this is the shadowed one.
   )

Affected By::

Existing packages.

Exceptional Situations::

If one of the supplied :nicknames already refers to an existing package, an error of type package-error is signaled.

An error of type program-error should be signaled if :size or :documentation appears more than once.

Since implementations might allow extended options an error of type program-error should be signaled if an option is present that is not actually supported in the host implementation.

The collection of symbol-name arguments given to the options :shadow, :intern, :import-from, and :shadowing-import-from must all be disjoint; additionally, the symbol-name arguments given to :export and :intern must be disjoint. Disjoint in this context is defined as no two of the symbol-names being string= with each other. If either condition is violated, an error of type program-error should be signaled.

For the :shadowing-import-from and :import-from options, a correctable error of type package-error is signaled if no symbol is accessible in the package named by package-name for one of the argument symbol-names.

Name conflict errors are handled by the underlying calls to make-package, use-package, import, and export. See Package Concepts.

See Also::

documentation , Package Concepts, Compilation

Notes::

The :intern option is useful if an :import-from or a :shadowing-import-from option in a subsequent call to defpackage (for some other package) expects to find these symbols accessible but not necessarily external.

It is recommended that the entire package definition is put in a single place, and that all the package definitions of a program are in a single file. This file can be loaded before loading or compiling anything else that depends on those packages. Such a file can be read in the COMMON-LISP-USER package, avoiding any initial state issues.

defpackage cannot be used to create two “mutually recursive” packages, such as: 

 (defpackage my-package
   (:use common-lisp your-package)    ;requires your-package to exist first
   (:export "MY-FUN"))                
 (defpackage your-package
   (:use common-lisp)
   (:import-from my-package "MY-FUN") ;requires my-package to exist first
   (:export "MY-FUN"))

However, nothing prevents the user from using the package-affecting functions such as use-package, import, and export to establish such links after a more standard use of defpackage.

The macroexpansion of defpackage could usefully canonicalize the names into strings, so that even if a source file has random symbols in the defpackage form, the compiled file would only contain strings.

Frequently additional implementation-dependent options take the form of a keyword standing by itself as an abbreviation for a list (keyword T); this syntax should be properly reported as an unrecognized option in implementations that do not support it.

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/array_002din_002dbounds_002dp.html0000644000175000017500000000725414360276512020430 0ustar cammcamm array-in-bounds-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.16 array-in-bounds-p [Function]

array-in-bounds-p array &rest subscripts ⇒ generalized-boolean

Arguments and Values::

array—an array.

subscripts—a list of integers of length equal to the rank of the array.

generalized-boolean—a generalized boolean.

Description::

Returns true if the subscripts are all in bounds for array; otherwise returns false. (If array is a vector with a fill pointer, that fill pointer is ignored.)

Examples::

 (setq a (make-array '(7 11) :element-type 'string-char))
 (array-in-bounds-p a 0  0) ⇒  true
 (array-in-bounds-p a 6 10) ⇒  true
 (array-in-bounds-p a 0 -1) ⇒  false
 (array-in-bounds-p a 0 11) ⇒  false
 (array-in-bounds-p a 7  0) ⇒  false

See Also::

array-dimensions

Notes::

 (array-in-bounds-p array subscripts)   
 ≡ (and (not (some #'minusp (list subscripts)))
         (every #'< (list subscripts) (array-dimensions array)))
gcl-2.6.14/info/gcl/store_002dvalue.html0000644000175000017500000000702014360276512016276 0ustar cammcamm store-value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.44 store-value [Restart]

Data Arguments Required::

a value to use instead (on an ongoing basis).

Description::

The store-value restart is generally used by handlers trying to recover from errors of types such as cell-error or type-error, which may wish to supply a replacement datum to be stored permanently.

Examples::

 (defun type-error-auto-coerce (c)
   (when (typep c 'type-error)
     (let ((r (find-restart 'store-value c)))
       (handler-case (let ((v (coerce (type-error-datum c)
                                      (type-error-expected-type c))))
                       (invoke-restart r v))
         (error ()))))) ⇒  TYPE-ERROR-AUTO-COERCE
 (let ((x 3))
   (handler-bind ((type-error #'type-error-auto-coerce))
     (check-type x float)
     x)) ⇒  3.0

See Also::

Restarts, Interfaces to Restarts, invoke-restart , store-value (function), ccase, check-type , ctypecase, use-value (function and restart)

gcl-2.6.14/info/gcl/The-_0022Affected-By_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000530314360276512024703 0ustar cammcamm The "Affected By" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.1 The "Affected By" Section of a Dictionary Entry

For an operator, anything that can affect the side effects of or values returned by the operator.

For a variable, anything that can affect the value of the variable including functions that bind or assign it.

gcl-2.6.14/info/gcl/tagbody.html0000644000175000017500000001230114360276512015007 0ustar cammcamm tagbody (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.27 tagbody [Special Operator]

tagbody {tag | statement}* ⇒ nil

Arguments and Values::

tag—a go tag; not evaluated.

statement—a compound form; evaluated as described below.

Description::

Executes zero or more statements in a lexical environment that provides for control transfers to labels indicated by the tags.

The statements in a tagbody are evaluated in order from left to right, and their values are discarded. If at any time there are no remaining statements, tagbody returns nil. However, if (go tag) is evaluated, control jumps to the part of the body labeled with the tag. (Tags are compared with eql.)

A tag established by tagbody has lexical scope and has dynamic extent. Once tagbody has been exited, it is no longer valid to go to a tag in its body. It is permissible for go to jump to a tagbody that is not the innermost tagbody containing that go; the tags established by a tagbody only shadow other tags of like name.

The determination of which elements of the body are tags and which are statements is made prior to any macro expansion of that element. If a statement is a macro form and its macro expansion is an atom, that atom is treated as a statement, not a tag.

Examples::

 (let (val)
    (tagbody
      (setq val 1)
      (go point-a)
      (incf val 16)
     point-c
      (incf val 04)
      (go point-b)
      (incf val 32)
     point-a
      (incf val 02)
      (go point-c)
      (incf val 64)
     point-b
      (incf val 08))
    val)
⇒  15
 (defun f1 (flag)
   (let ((n 1))
     (tagbody 
       (setq n (f2 flag #'(lambda () (go out))))
      out
       (prin1 n))))
⇒  F1
 (defun f2 (flag escape)
   (if flag (funcall escape) 2))
⇒  F2
 (f1 nil)
 |>  2
⇒  NIL
 (f1 t)
 |>  1
⇒  NIL

See Also::

go

Notes::

The macros in Figure 5–10 have implicit tagbodies. 

  do              do-external-symbols  dotimes  
  do*             do-symbols           prog     
  do-all-symbols  dolist               prog*    

  Figure 5–10: Macros that have implicit tagbodies.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Method-Selection-and-Combination.html0000644000175000017500000001174214360276512021531 0ustar cammcamm Method Selection and Combination (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Generic Functions and Methods  

7.6.6 Method Selection and Combination

When a generic function is called with particular arguments, it must determine the code to execute. This code is called the effective method for those arguments. The effective method is a combination of the applicable methods in the generic function that calls some or all of the methods.

If a generic function is called and no methods are applicable, the generic function no-applicable-method is invoked, with the results from that call being used as the results of the call to the original generic function. Calling no-applicable-method takes precedence over checking for acceptable keyword arguments; see Keyword Arguments in Generic Functions and Methods.

When the effective method has been determined, it is invoked with the same arguments as were passed to the generic function. Whatever values it returns are returned as the values of the generic function.

• Determining the Effective Method  
• Selecting the Applicable Methods  
• Sorting the Applicable Methods by Precedence Order  
• Applying method combination to the sorted list of applicable methods  
• Standard Method Combination  
• Declarative Method Combination  
• Built-in Method Combination Types  
gcl-2.6.14/info/gcl/Printing-Bit-Vectors.html0000644000175000017500000000522314360276512017314 0ustar cammcamm Printing Bit Vectors (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.14 Printing Bit Vectors

A bit vector is printed as #* followed by the bits of the bit vector in order. If *print-array* is false, then the bit vector is printed in a format (using #<) that is concise but not readable. Only the active elements of the bit vector are printed.

[Reviewer Note by Barrett: Need to provide for #5*0 as an alternate notation for #*00000.]

For information on Lisp reader parsing of bit vectors, see Sharpsign Asterisk.

gcl-2.6.14/info/gcl/array_002delement_002dtype.html0000644000175000017500000001011114360276512020217 0ustar cammcamm array-element-type (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.13 array-element-type [Function]

array-element-type array ⇒ typespec

Arguments and Values::

array—an array.

typespec—a type specifier.

Description::

Returns a type specifier which represents the actual array element type of the array, which is the set of objects that such an array can hold. (Because of array upgrading, this type specifier can in some cases denote a supertype of the expressed array element type of the array.)

Examples::

 (array-element-type (make-array 4)) ⇒  T
 (array-element-type (make-array 12 :element-type '(unsigned-byte 8))) 
⇒  implementation-dependent
 (array-element-type (make-array 12 :element-type '(unsigned-byte 5)))
⇒  implementation-dependent

 (array-element-type (make-array 5 :element-type '(mod 5)))

could be (mod 5), (mod 8), fixnum, t, or any other type of which (mod 5) is a subtype.

Affected By::

The implementation.

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

array, make-array , subtypep , upgraded-array-element-type

gcl-2.6.14/info/gcl/FORMAT-Pretty-Printer-Operations.html0000644000175000017500000000611114360276512021377 0ustar cammcamm FORMAT Pretty Printer Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.5 FORMAT Pretty Printer Operations

The following constructs provide access to the pretty printer:

• Tilde Underscore-> Conditional Newline  
• Tilde Less-Than-Sign-> Logical Block  
• Tilde I-> Indent  
• Tilde Slash-> Call Function  
gcl-2.6.14/info/gcl/bignum.html0000644000175000017500000000435714360276512014653 0ustar cammcamm bignum (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.14 bignum [Type]

Supertypes::

bignum, integer, rational,

real,

number, t

Description::

The type bignum is defined to be exactly (and integer (not fixnum)).

gcl-2.6.14/info/gcl/provide.html0000644000175000017500000001366614360276512015045 0ustar cammcamm provide (ANSI and GNU Common Lisp Document)

Previous: , Up: System Construction Dictionary  

24.2.11 provide, require [Function]

provide module-name ⇒ implementation-dependent

require module-name &optional pathname-list ⇒ implementation-dependent

Arguments and Values::

module-name—a string designator.

pathname-list—nil, or a designator for a non-empty list of pathname designators. The default is nil.

Description::

provide adds the module-name to the list held by *modules*, if such a name is not already present.

require tests for the presence of the module-name in the list held by *modules*. If it is present, require immediately returns.

Otherwise, an attempt is made to load an appropriate set of files as follows: The pathname-list argument, if non-nil, specifies a list of pathnames to be loaded in order, from left to right. If the pathname-list is nil, an implementation-dependent mechanism will be invoked in an attempt to load the module named module-name; if no such module can be loaded, an error of type error is signaled.

Both functions use string= to test for the presence of a module-name.

Examples::

;;; This illustrates a nonportable use of REQUIRE, because it
;;; depends on the implementation-dependent file-loading mechanism.

(require "CALCULUS")

;;; This use of REQUIRE is nonportable because of the literal 
;;; physical pathname.  

(require "CALCULUS" "/usr/lib/lisp/calculus")

;;; One form of portable usage involves supplying a logical pathname,
;;; with appropriate translations defined elsewhere.

(require "CALCULUS" "lib:calculus")

;;; Another form of portable usage involves using a variable or
;;; table lookup function to determine the pathname, which again
;;; must be initialized elsewhere.

(require "CALCULUS" *calculus-module-pathname*)

Side Effects::

provide modifies *modules*.

Affected By::

The specific action taken by require is affected by calls to provide (or, in general, any changes to the value of *modules*).

Exceptional Situations::

Should signal an error of type type-error if module-name is not a string designator.

If require fails to perform the requested operation due to a problem while interacting with the file system, an error of type file-error is signaled.

An error of type file-error might be signaled if any pathname in pathname-list is a designator for a wild pathname.

See Also::

*modules*,

Pathnames as Filenames

Notes::

The functions provide and require are deprecated.

If a module consists of a single package, it is customary for the package and module names to be the same.

Previous: , Up: System Construction Dictionary  

gcl-2.6.14/info/gcl/most_002dpositive_002dshort_002dfloat.html0000644000175000017500000002043514360276512022237 0ustar cammcamm most-positive-short-float (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.76 most-positive-short-float, least-positive-short-float,

least-positive-normalized-short-float,

most-positive-double-float, least-positive-double-float,

least-positive-normalized-double-float,

most-positive-long-float, least-positive-long-float,

least-positive-normalized-long-float,

most-positive-single-float, least-positive-single-float,

least-positive-normalized-single-float,

most-negative-short-float, least-negative-short-float,

least-negative-normalized-short-float,

most-negative-single-float, least-negative-single-float,

least-negative-normalized-single-float,

most-negative-double-float, least-negative-double-float,

least-negative-normalized-double-float,

most-negative-long-float, least-negative-long-float,

least-negative-normalized-long-float

[Constant Variable]

Constant Value::

implementation-dependent.

Description::

These constant variables provide a way for programs to examine the implementation-defined limits for the various float formats.

Of these variables, each which has “-normalized” in its name must have a value which is a normalized float, and each which does not have “-normalized” in its name may have a value which is either a normalized float or a denormalized float, as appropriate.

Of these variables, each which has “short-float” in its name must have a value which is a short float, each which has “single-float” in its name must have a value which is a single float, each which has “double-float” in its name must have a value which is a double float, and each which has “long-float” in its name must have a value which is a long float.

*

most-positive-short-float, most-positive-single-float, most-positive-double-float, most-positive-long-float

Each of these constant variables has as its value the positive float of the largest magnitude (closest in value to, but not equal to, positive infinity) for the float format implied by its name.

*

least-positive-short-float, least-positive-normalized-short-float, least-positive-single-float, least-positive-normalized-single-float, least-positive-double-float, least-positive-normalized-double-float, least-positive-long-float, least-positive-normalized-long-float

Each of these constant variables has as its value the smallest positive (nonzero) float for the float format implied by its name.

*

least-negative-short-float, least-negative-normalized-short-float, least-negative-single-float, least-negative-normalized-single-float, least-negative-double-float, least-negative-normalized-double-float, least-negative-long-float, least-negative-normalized-long-float

Each of these constant variables has as its value the negative (nonzero) float of the smallest magnitude for the float format implied by its name. (If an implementation supports minus zero as a different object from positive zero, this value must not be minus zero.)

*

most-negative-short-float, most-negative-single-float, most-negative-double-float, most-negative-long-float

Each of these constant variables has as its value the negative float of the largest magnitude (closest in value to, but not equal to, negative infinity) for the float format implied by its name.

Notes::

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Minimal-Compilation.html0000644000175000017500000000715114360276512017227 0ustar cammcamm Minimal Compilation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.6 Minimal Compilation

Minimal compilation is defined as follows:

*

All compiler macro calls appearing in the source code being compiled are expanded, if at all, at compile time; they will not be expanded at run time.

*

All macro and symbol macro calls appearing in the source code being compiled are expanded at compile time in such a way that they will not be expanded again at run time. macrolet

and symbol-macrolet

are effectively replaced by forms corresponding to their bodies in which calls to macros are replaced by their expansions.

*

The first argument in a load-time-value

form in source code processed by compile

is evaluated at compile time; in source code processed by compile-file , the compiler arranges for it to be evaluated at load time. In either case, the result of the evaluation is remembered and used later as the value of the load-time-value form at execution time.

gcl-2.6.14/info/gcl/Numbers-_0028Numbers_0029.html0000644000175000017500000000437414360276512017540 0ustar cammcamm Numbers (Numbers) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

12 Numbers

• Number Concepts  
• Numbers Dictionary  
gcl-2.6.14/info/gcl/Examples-of-Effect-of-Readtable-Case-on-the-Lisp-Reader.html0000644000175000017500000000707114360276512025371 0ustar cammcamm Examples of Effect of Readtable Case on the Lisp Reader (ANSI and GNU Common Lisp Document)

Previous: , Up: Effect of Readtable Case on the Lisp Reader  

23.1.2.1 Examples of Effect of Readtable Case on the Lisp Reader

 (defun test-readtable-case-reading ()
   (let ((*readtable* (copy-readtable nil)))
     (format t "READTABLE-CASE  Input   Symbol-name~
              ~
              ~
     (dolist (readtable-case '(:upcase :downcase :preserve :invert))
       (setf (readtable-case *readtable*) readtable-case)
       (dolist (input '("ZEBRA" "Zebra" "zebra"))
         (format t "~&:~A~16T~A~24T~A"
                 (string-upcase readtable-case)
                 input
                 (symbol-name (read-from-string input)))))))

The output from (test-readtable-case-reading) should be as follows: 

 READTABLE-CASE     Input Symbol-name
 -------------------------------------
    :UPCASE         ZEBRA   ZEBRA
    :UPCASE         Zebra   ZEBRA
    :UPCASE         zebra   ZEBRA
    :DOWNCASE       ZEBRA   zebra
    :DOWNCASE       Zebra   zebra
    :DOWNCASE       zebra   zebra
    :PRESERVE       ZEBRA   ZEBRA
    :PRESERVE       Zebra   Zebra
    :PRESERVE       zebra   zebra
    :INVERT         ZEBRA   zebra
    :INVERT         Zebra   Zebra
    :INVERT         zebra   ZEBRA
gcl-2.6.14/info/gcl/numerator.html0000644000175000017500000000673114360276512015404 0ustar cammcamm numerator (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.53 numerator, denominator [Function]

numerator rational ⇒ numerator

denominator rational ⇒ denominator

Arguments and Values::

rational—a rational.

numerator—an integer.

denominator—a positive integer.

Description::

numerator and denominator reduce rational to canonical form and compute the numerator or denominator of that number.

numerator and denominator return the numerator or denominator of the canonical form of rational.

If rational is an integer, numerator returns rational and denominator returns 1.

Examples::

 (numerator 1/2) ⇒  1
 (denominator 12/36) ⇒  3
 (numerator -1) ⇒  -1
 (denominator (/ -33)) ⇒  33
 (numerator (/ 8 -6)) ⇒  -4
 (denominator (/ 8 -6)) ⇒  3

See Also::

/

Notes::

 (gcd (numerator x) (denominator x)) ⇒  1
gcl-2.6.14/info/gcl/break.html0000644000175000017500000001306214360276512014447 0ustar cammcamm break (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.23 break [Function]

break &optional format-control &rest format-arguments ⇒ nil

Arguments and Values::

format-control—a format control.

The default is implementation-dependent.

format-arguments—format arguments for the format-control.

Description::

break formats format-control and format-arguments and then goes directly into the debugger without allowing any possibility of interception by programmed error-handling facilities.

If the continue restart is used while in the debugger, break immediately returns nil without taking any unusual recovery action.

break binds *debugger-hook* to nil before attempting to enter the debugger.

Examples::

 (break "You got here with arguments: ~:S." '(FOO 37 A))
 |>  BREAK: You got here with these arguments: FOO, 37, A.
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return from BREAK.
 |>   2: Top level.
 |>  Debug> :CONTINUE 1
 |>  Return from BREAK.
⇒  NIL

Side Effects::

The debugger is entered.

Affected By::

*debug-io*.

See Also::

error , invoke-debugger .

Notes::

break is used as a way of inserting temporary debugging “breakpoints” in a program, not as a way of signaling errors. For this reason, break does not take the continue-format-control argument that cerror takes. This and the lack of any possibility of interception by condition handling are the only program-visible differences between break and cerror.

The user interface aspects of break and cerror are permitted to vary more widely, in order to accomodate the interface needs of the implementation. For example, it is permissible for a Lisp read-eval-print loop to be entered by break rather than the conventional debugger.

break could be defined by: 

 (defun break (&optional (format-control "Break") &rest format-arguments)
   (with-simple-restart (continue "Return from BREAK.")
     (let ((*debugger-hook* nil))
       (invoke-debugger
           (make-condition 'simple-condition
                           :format-control format-control
                           :format-arguments format-arguments))))
   nil)

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Visible-Modification-of-Bit-Vectors-and-Strings-with-respect-to-EQUAL.html0000644000175000017500000000565614360276512030226 0ustar cammcamm Visible Modification of Bit Vectors and Strings with respect to EQUAL (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.4 Visible Modification of Bit Vectors and Strings with respect to EQUAL

For a vector of type bit-vector or of type string, any visible change to an active element of the vector, or to the length of the vector (if it is actually adjustable or has a fill pointer) is considered a visible modification with regard to equal.

gcl-2.6.14/info/gcl/merge.html0000644000175000017500000001714414360276512014467 0ustar cammcamm merge (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.21 merge [Function]

merge result-type sequence-1 sequence-2 predicate &key key ⇒ result-sequence

Arguments and Values::

result-type—a sequence type specifier.

sequence-1—a sequence.

sequence-2—a sequence.

predicate—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

result-sequence—a proper sequence of type result-type.

Description::

Destructively merges sequence-1 with sequence-2 according to an order determined by the predicate. merge determines the relationship between two elements by giving keys extracted from the sequence elements to the predicate.

The first argument to the predicate function is an element of sequence-1 as returned by the key (if supplied); the second argument is an element of sequence-2 as returned by the key (if supplied). Predicate should return true if and only if its first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then predicate should return false. merge considers two elements x and y to be equal if (funcall predicate x y) and (funcall predicate y x) both yield false.

The argument to the key is the sequence element. Typically, the return value of the key becomes the argument to predicate. If key is not supplied or nil, the sequence element itself is used. The key may be executed more than once for each sequence element, and its side effects may occur in any order.

If key and predicate return, then the merging operation will terminate. The result of merging two sequences x and y is a new sequence of type result-type z, such that the length of z is the sum of the lengths of x and y, and z contains all the elements of x and y. If x1 and x2 are two elements of x, and x1 precedes x2 in x, then x1 precedes x2 in z, and similarly for elements of y. In short, z is an interleaving of x and y.

If x and y were correctly sorted according to the predicate, then z will also be correctly sorted. If x or y is not so sorted, then z will not be sorted, but will nevertheless be an interleaving of x and y.

The merging operation is guaranteed stable; if two or more elements are considered equal by the predicate, then the elements from sequence-1 will precede those from sequence-2 in the result.

sequence-1 and/or sequence-2 may be destroyed.

If the result-type is a subtype of list, the result will be a list.

If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled.

Examples::

 (setq test1 (list 1 3 4 6 7))
 (setq test2 (list 2 5 8))
 (merge 'list test1 test2 #'<) ⇒  (1 2 3 4 5 6 7 8)
 (setq test1 (copy-seq "BOY"))
 (setq test2 (copy-seq :nosy"))
 (merge 'string test1 test2 #'char-lessp) ⇒  "BnOosYy"
 (setq test1 (vector ((red . 1) (blue . 4))))
 (setq test2 (vector ((yellow . 2) (green . 7))))
 (merge 'vector test1 test2 #'< :key #'cdr) 
⇒  #((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7)) 

 (merge '(vector * 4) '(1 5) '(2 4 6) #'<) should signal an error

Exceptional Situations::

An error must be signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector.

An error of type type-error should be signaled if result-type specifies the number of elements and the sum of the lengths of sequence-1 and sequence-2 is different from that number.

See Also::

sort , stable-sort,

Compiler Terminology,

Traversal Rules and Side Effects

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/package_002duse_002dlist.html0000644000175000017500000000663614360276512017652 0ustar cammcamm package-use-list (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.25 package-use-list [Function]

package-use-list package ⇒ use-list

Arguments and Values::

package—a package designator.

use-list—a list of package objects.

Description::

Returns a list of other packages used by package.

Examples::

 (package-use-list (make-package 'temp)) ⇒  (#<PACKAGE "COMMON-LISP">)
 (use-package 'common-lisp-user 'temp) ⇒  T
 (package-use-list 'temp) ⇒  (#<PACKAGE "COMMON-LISP"> #<PACKAGE "COMMON-LISP-USER">)

Exceptional Situations::

Should signal an error of type type-error if package is not a package designator.

See Also::

use-package , unuse-package

gcl-2.6.14/info/gcl/Standardized-Packages.html0000644000175000017500000001116014360276512017510 0ustar cammcamm Standardized Packages (ANSI and GNU Common Lisp Document)

Previous: , Up: Package Concepts  

11.1.2 Standardized Packages

This section describes the packages that are available in every conforming implementation. A summary of the names and nicknames of those standardized packages is given in Figure 11–2. 

  Name              Nicknames  
  COMMON-LISP       CL         
  COMMON-LISP-USER  CL-USER    
  KEYWORD           none       

  Figure 11–2: Standardized Package Names
• The COMMON-LISP Package  
• Constraints on the COMMON-LISP Package for Conforming Implementations  
• Constraints on the COMMON-LISP Package for Conforming Programs  
• Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs  
• The COMMON-LISP-USER Package  
• The KEYWORD Package  
• Interning a Symbol in the KEYWORD Package  
• Notes about The KEYWORD Package  
• Implementation-Defined Packages  
gcl-2.6.14/info/gcl/_002a-_0028Variable_0029.html0000644000175000017500000001042214360276512017027 0ustar cammcamm * (Variable) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.22 *, **, *** [Variable]

Value Type::

an object.

Initial Value::

implementation-dependent.

Description::

The variables *, **, and *** are maintained by the Lisp read-eval-print loop to save the values of results that are printed each time through the loop.

The value of * is the most recent primary value that was printed, the value of ** is the previous value of *, and the value of *** is the previous value of **.

If several values are produced, * contains the first value only; * contains nil if zero values are produced.

The values of *, **, and *** are updated immediately prior to printing the return value of a top-level form by the Lisp read-eval-print loop. If the evaluation of such a form is aborted prior to its normal return, the values of *, **, and *** are not updated.

Examples::

(values 'a1 'a2) ⇒  A1, A2
'b ⇒  B
(values 'c1 'c2 'c3) ⇒  C1, C2, C3
(list * ** ***) ⇒  (C1 B A1)

(defun cube-root (x) (expt x 1/3)) ⇒  CUBE-ROOT
(compile *) ⇒  CUBE-ROOT
(setq a (cube-root 27.0)) ⇒  3.0
(* * 9.0) ⇒  27.0

Affected By::

Lisp read-eval-print loop.

See Also::

- (variable), + (variable), / (variable), Top level loop

Notes::

 *   ≡ (car /)
 **  ≡ (car //)
 *** ≡ (car ///)
gcl-2.6.14/info/gcl/Evaluation-and-Compilation-Dictionary.html0000644000175000017500000001536314360276512022617 0ustar cammcamm Evaluation and Compilation Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Evaluation and Compilation  

3.8 Evaluation and Compilation Dictionary

• lambda (Symbol)  
• lambda  
• compile  
• eval  
• eval-when  
• load-time-value  
• quote  
• compiler-macro-function  
• define-compiler-macro  
• defmacro  
• macro-function  
• macroexpand  
• define-symbol-macro  
• symbol-macrolet  
• *macroexpand-hook*  
• proclaim  
• declaim  
• declare  
• ignore  
• dynamic-extent  
• type  
• inline  
• ftype  
• declaration  
• optimize  
• special  
• locally  
• the  
• special-operator-p  
• constantp  
gcl-2.6.14/info/gcl/array_002dtotal_002dsize.html0000644000175000017500000000744514360276512017722 0ustar cammcamm array-total-size (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.19 array-total-size [Function]

array-total-size array ⇒ size

Arguments and Values::

array—an array.

size—a non-negative integer.

Description::

Returns the array total size of the array.

Examples::

 (array-total-size (make-array 4)) ⇒  4
 (array-total-size (make-array 4 :fill-pointer 2)) ⇒  4
 (array-total-size (make-array 0)) ⇒  0
 (array-total-size (make-array '(4 2))) ⇒  8
 (array-total-size (make-array '(4 0))) ⇒  0
 (array-total-size (make-array '())) ⇒  1

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

make-array , array-dimensions

Notes::

If the array is a vector with a fill pointer, the fill pointer is ignored when calculating the array total size.

Since the product of no arguments is one, the array total size of a zero-dimensional array is one. 

 (array-total-size x)
    ≡ (apply #'* (array-dimensions x))
    ≡ (reduce #'* (array-dimensions x))
gcl-2.6.14/info/gcl/multiple_002dvalue_002dbind.html0000644000175000017500000001121614360276512020361 0ustar cammcamm multiple-value-bind (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.48 multiple-value-bind [Macro]

multiple-value-bind ({var}*) values-form {declaration}* {form}*
⇒ {result}*

Arguments and Values::

var—a symbol naming a variable; not evaluated.

values-form—a form; evaluated.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

Creates new variable bindings for the vars and executes a series of forms that use these bindings.

The variable bindings created are lexical unless special declarations are specified.

Values-form is evaluated, and each of the vars is bound to the respective value returned by that form. If there are more vars than values returned, extra values of nil are given to the remaining vars. If there are more values than vars, the excess values are discarded. The vars are bound to the values over the execution of the forms, which make up an implicit progn. The consequences are unspecified if a type declaration is specified for a var, but the value to which that var is bound is not consistent with the type declaration.

The scopes of the name binding and declarations do not include the values-form.

Examples::

 (multiple-value-bind (f r) 
     (floor 130 11)
   (list f r)) ⇒  (11 9)

See Also::

let , multiple-value-call

Notes::

 (multiple-value-bind ({var}*) values-form {form}*)
 ≡ (multiple-value-call #'(lambda (&optional {var}* &rest #1=#:ignore)
                             (declare (ignore #1#))
                             {form}*)
                         values-form)
gcl-2.6.14/info/gcl/Destructuring-Mismatch.html0000644000175000017500000000503414360276512017770 0ustar cammcamm Destructuring Mismatch (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Argument Mismatch Detection  

3.5.1.8 Destructuring Mismatch

When matching a destructuring lambda list against a form, the pattern and the form must have compatible tree structure, as described in Macro Lambda Lists.

Otherwise, in a safe call, an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.

gcl-2.6.14/info/gcl/bit_002dvector_002dp.html0000644000175000017500000000630214360276512017015 0ustar cammcamm bit-vector-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.35 bit-vector-p [Function]

bit-vector-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type bit-vector; otherwise, returns false.

Examples::

 (bit-vector-p (make-array 6 
                           :element-type 'bit 
                           :fill-pointer t)) ⇒  true
 (bit-vector-p #*) ⇒  true
 (bit-vector-p (make-array 6)) ⇒  false

See Also::

typep

Notes::

 (bit-vector-p object) ≡ (typep object 'bit-vector)
gcl-2.6.14/info/gcl/make_002dtwo_002dway_002dstream.html0000644000175000017500000000701614360276512020770 0ustar cammcamm make-two-way-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.42 make-two-way-stream [Function]

make-two-way-stream input-stream output-stream ⇒ two-way-stream

Arguments and Values::

input-stream—a stream.

output-stream—a stream.

two-way-stream—a two-way stream.

Description::

Returns a two-way stream that gets its input from input-stream and sends its output to output-stream.

Examples::

 (with-output-to-string (out)
    (with-input-from-string (in "input...")
      (let ((two (make-two-way-stream in out)))
        (format two "output...")
        (setq what-is-read (read two))))) ⇒  "output..."
 what-is-read ⇒  INPUT...

Exceptional Situations::

Should signal an error of type type-error if input-stream is not an input stream. Should signal an error of type type-error if output-stream is not an output stream.

gcl-2.6.14/info/gcl/sinh.html0000644000175000017500000001755414360276512014336 0ustar cammcamm sinh (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.23 sinh, cosh, tanh, asinh, acosh, atanh [Function]

sinh number ⇒ result

cosh number ⇒ result

tanh number ⇒ result

asinh number ⇒ result

acosh number ⇒ result

atanh number ⇒ result

Arguments and Values::

number—a number.

result—a number.

Description::

These functions compute the hyperbolic sine, cosine, tangent, arc sine, arc cosine, and arc tangent functions, which are mathematically defined for an argument x as given in Figure 12–15. 

  Function                Definition                                  
  Hyperbolic sine          (e^x-e^-x)/2                             
  Hyperbolic cosine        (e^x+e^-x)/2                             
  Hyperbolic tangent       (e^x-e^-x)/(e^x+e^-x)                  
  Hyperbolic arc sine      log  (x+\sqrt1+x^2)                      
  Hyperbolic arc cosine    2 log  (\sqrt(x+1)/2 + \sqrt(x-1)/2)   
  Hyperbolic arc tangent   (log  (1+x) - log (1-x))/2                 

    Figure 12–15: Mathematical definitions for hyperbolic functions

The following definition for the inverse hyperbolic cosine determines the range and branch cuts:

arccosh z = 2 log (\sqrt(z+1)/2 + \sqrt(z-1)/2\Bigr).

The branch cut for the inverse hyperbolic cosine function lies along the real axis to the left of~1 (inclusive), extending indefinitely along the negative real axis, continuous with quadrant II and (between 0 and~1) with quadrant I. The range is that half-strip of the complex plane containing numbers whose real part is non-negative and whose imaginary part is between -\pi (exclusive) and~\pi (inclusive). A number with real part zero is in the range if its imaginary part is between zero (inclusive) and~\pi (inclusive).

The following definition for the inverse hyperbolic sine determines the range and branch cuts:

arcsinh z = log (z+\sqrt1+z^2\Bigr).

The branch cut for the inverse hyperbolic sine function is in two pieces: one along the positive imaginary axis above i (inclusive), continuous with quadrant I, and one along the negative imaginary axis below -i (inclusive), continuous with quadrant III. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and~\pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is non-positive; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is non-negative.

The following definition for the inverse hyperbolic tangent determines the range and branch cuts:

arctanh z = log (1+z) - log (1-z)\over2.

Note that:

i arctan z = arctanh iz.

The branch cut for the inverse hyperbolic tangent function is in two pieces: one along the negative real axis to the left of -1 (inclusive), continuous with quadrant III, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant I. The points -1 and~1 are excluded from the domain. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and \pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is strictly negative; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is strictly positive. Thus the range of the inverse hyperbolic tangent function is identical to that of the inverse hyperbolic sine function with the points -\pi i/2 and~\pi i/2 excluded.

Examples::

 (sinh 0) ⇒  0.0 
 (cosh (complex 0 -1)) ⇒  #C(0.540302 -0.0)

Exceptional Situations::

Should signal an error of type type-error if number is not a number. Might signal arithmetic-error.

See Also::

log , sqrt , Rule of Float Substitutability

Notes::

The result of acosh may be a complex even if number is not a complex; this occurs when number is less than one. Also, the result of atanh may be a complex even if number is not a complex; this occurs when the absolute value of number is greater than one.

The branch cut formulae are mathematically correct, assuming completely accurate computation. Implementors should consult a good text on numerical analysis. The formulae given above are not necessarily the simplest ones for real-valued computations; they are chosen to define the branch cuts in desirable ways for the complex case.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Use-of-Single-Semicolon.html0000644000175000017500000000467114360276512017674 0ustar cammcamm Use of Single Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.3 Use of Single Semicolon

Comments that begin with a single semicolon are all aligned to the same column at the right (sometimes called the “comment column”). The text of such a comment generally applies only to the line on which it appears. Occasionally two or three contain a single sentence together; this is sometimes indicated by indenting all but the first with an additional space (after the semicolon).

gcl-2.6.14/info/gcl/The-Pathname-Device-Component.html0000644000175000017500000000444414360276512020777 0ustar cammcamm The Pathname Device Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Pathname Components  

19.2.1.2 The Pathname Device Component

Corresponds to the “device” or “file structure” concept in many host file systems: the name of a logical or physical device containing files.

gcl-2.6.14/info/gcl/Use-of-the-Dot-Character.html0000644000175000017500000000600314360276512017712 0ustar cammcamm Use of the Dot Character (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.10 Use of the Dot Character

The dot appearing by itself in an expression such as

(item1 item2 . tail)

means that tail represents a list of objects at the end of a list. For example,

(A B C . (D E F))

is notationally equivalent to:

(A B C D E F)

Although dot is a valid constituent character in a symbol, no standardized symbols contain the character dot, so a period that follows a reference to a symbol at the end of a sentence in this document should always be interpreted as a period and never as part of the symbol’s name. For example, within this document, a sentence such as “This sample sentence refers to the symbol car.” refers to a symbol whose name is "CAR" (with three letters), and never to a four-letter symbol "CAR."

gcl-2.6.14/info/gcl/warn.html0000644000175000017500000001324614360276512014336 0ustar cammcamm warn (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.20 warn [Function]

warn datum &rest arguments ⇒ nil

Arguments and Values::

datum, arguments—designators for a condition of default type simple-warning.

Description::

Signals a condition of type warning. If the condition is not handled, reports the condition to error output.

The precise mechanism for warning is as follows:

The warning condition is signaled

While the warning condition is being signaled, the muffle-warning restart is established for use by a handler. If invoked, this restart bypasses further action by warn, which in turn causes warn to immediately return nil.

If no handler for the warning condition is found

If no handlers for the warning condition are found, or if all such handlers decline, then the condition is reported to error output by warn in an implementation-dependent format.

nil is returned

The value returned by warn if it returns is nil.

Examples::

  (defun foo (x)
    (let ((result (* x 2)))
      (if (not (typep result 'fixnum))
          (warn "You're using very big numbers."))
      result))
⇒  FOO

  (foo 3)
⇒  6

  (foo most-positive-fixnum)
 |>  Warning: You're using very big numbers.
⇒  4294967294

  (setq *break-on-signals* t)
⇒  T

  (foo most-positive-fixnum)
 |>  Break: Caveat emptor.
 |>  To continue, type :CONTINUE followed by an option number.
 |>   1: Return from Break.
 |>   2: Abort to Lisp Toplevel.
 |>  Debug> :continue 1
 |>  Warning: You're using very big numbers.
⇒  4294967294

Side Effects::

A warning is issued. The debugger might be entered.

Affected By::

Existing handler bindings.

*break-on-signals*, *error-output*.

Exceptional Situations::

If datum is a condition and if the condition is not of type warning, or arguments is non-nil, an error of type type-error is signaled.

If datum is a condition type, the result of (apply #'make-condition datum arguments) must be of type warning or an error of type type-error is signaled.

See Also::

*break-on-signals*, muffle-warning , signal

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Null-Strings-as-Components-of-a-Logical-Pathname.html0000644000175000017500000000446114360276512024376 0ustar cammcamm Null Strings as Components of a Logical Pathname (ANSI and GNU Common Lisp Document)

Previous: , Up: Logical Pathname Components  

19.3.2.2 Null Strings as Components of a Logical Pathname

The null string, "", is not a valid value for any component of a logical pathname.

gcl-2.6.14/info/gcl/Examples-of-Single_002dQuote.html0000644000175000017500000000376514360276512020536 0ustar cammcamm Examples of Single-Quote (ANSI and GNU Common Lisp Document)

Previous: , Up: Single-Quote  

2.4.3.1 Examples of Single-Quote

 'foo ⇒  FOO
 ''foo ⇒  (QUOTE FOO)
 (car ''foo) ⇒  QUOTE
gcl-2.6.14/info/gcl/FORMAT-Control_002dFlow-Operations.html0000644000175000017500000000710314360276512021466 0ustar cammcamm FORMAT Control-Flow Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.7 FORMAT Control-Flow Operations

• Tilde Asterisk-> Go-To  
• Tilde Left-Bracket-> Conditional Expression  
• Tilde Right-Bracket-> End of Conditional Expression  
• Tilde Left-Brace-> Iteration  
• Tilde Right-Brace-> End of Iteration  
• Tilde Question-Mark-> Recursive Processing  
gcl-2.6.14/info/gcl/Overview-of-Filenames.html0000644000175000017500000000623014360276512017473 0ustar cammcamm Overview of Filenames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Filenames  

19.1 Overview of Filenames

There are many kinds of file systems, varying widely both in their superficial syntactic details, and in their underlying power and structure. The facilities provided by Common Lisp for referring to and manipulating files has been chosen to be compatible with many kinds of file systems, while at the same time minimizing the program-visible differences between kinds of file systems.

Since file systems vary in their conventions for naming files, there are two distinct ways to represent filenames: as namestrings and as pathnames.

• Namestrings as Filenames  
• Pathnames as Filenames  
• Parsing Namestrings Into Pathnames  
gcl-2.6.14/info/gcl/declaration.html0000644000175000017500000000633214360276512015652 0ustar cammcamm declaration (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.24 declaration [Declaration]

Syntax::

(declaration {name}*)

Arguments::

name—a symbol.

Valid Context::

proclamation only

Description::

Advises the compiler that each name is a valid but potentially non-standard declaration name. The purpose of this is to tell one compiler not to issue warnings for declarations meant for another compiler or other program processor.

Examples::

 (declaim (declaration author target-language target-machine))
 (declaim (target-language ada))
 (declaim (target-machine IBM-650))
 (defun strangep (x)
   (declare (author "Harry Tweeker"))
   (member x '(strange weird odd peculiar)))

See Also::

declaim , proclaim

gcl-2.6.14/info/gcl/The-_0022Side-Effects_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000520714360276512025076 0ustar cammcamm The "Side Effects" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.22 The "Side Effects" Section of a Dictionary Entry

Anything that is changed as a result of the evaluation of the form containing this operator.

gcl-2.6.14/info/gcl/Time.html0000644000175000017500000000763614360276512014273 0ustar cammcamm Time (ANSI and GNU Common Lisp Document)

Previous: , Up: The External Environment  

25.1.4 Time

Time is represented in four different ways in Common Lisp: decoded time, universal time, internal time, and seconds. Decoded time and universal time are used primarily to represent calendar time, and are precise only to one second. Internal time is used primarily to represent measurements of computer time (such as run time) and is precise to some implementation-dependent fraction of a second called an internal time unit, as specified by internal-time-units-per-second. An internal time can be used for either absolute and relative time measurements. Both a universal time and a decoded time can be used only for absolute time measurements. In the case of one function, sleep, time intervals are represented as a non-negative real number of seconds.

Figure 25–4 shows defined names relating to time. 

  decode-universal-time   get-internal-run-time           
  encode-universal-time   get-universal-time              
  get-decoded-time        internal-time-units-per-second  
  get-internal-real-time  sleep                           

        Figure 25–4: Defined names involving Time.
• Decoded Time  
• Universal Time  
• Internal Time  
• Seconds  
gcl-2.6.14/info/gcl/nconc.html0000644000175000017500000001166714360276512014474 0ustar cammcamm nconc (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.25 nconc [Function]

nconc &rest lists ⇒ concatenated-list

Arguments and Values::

list—each but the last must be a list (which might be a dotted list but must not be a circular list); the last list may be any object.

concatenated-list—a list.

Description::

Returns a list that is the concatenation of lists. If no lists are supplied, (nconc) returns nil.

nconc is defined using the following recursive relationship: 

 (nconc) ⇒  ()
 (nconc nil . lists) ≡ (nconc . lists)
 (nconc list) ⇒  list
 (nconc list-1 list-2) ≡ (progn (rplacd (last list-1) list-2) list-1)
 (nconc list-1 list-2 . lists) ≡ (nconc (nconc list-1 list-2) . lists)

Examples::

 (nconc) ⇒  NIL
 (setq x '(a b c)) ⇒  (A B C)
 (setq y '(d e f)) ⇒  (D E F)
 (nconc x y) ⇒  (A B C D E F)
 x ⇒  (A B C D E F)

Note, in the example, that the value of x is now different, since its last cons has been rplacd’d to the value of y. If (nconc x y) were evaluated again, it would yield a piece of a circular list, whose printed representation would be (A B C D E F D E F D E F ...), repeating forever; if the *print-circle* switch were non-nil, it would be printed as (A B C . #1=(D E F . #1#)). 

 (setq foo (list 'a 'b 'c 'd 'e)
       bar (list 'f 'g 'h 'i 'j)
       baz (list 'k 'l 'm)) ⇒  (K L M)
 (setq foo (nconc foo bar baz)) ⇒  (A B C D E F G H I J K L M)
 foo ⇒  (A B C D E F G H I J K L M)
 bar ⇒  (F G H I J K L M)
 baz ⇒  (K L M)

 (setq foo (list 'a 'b 'c 'd 'e)
       bar (list 'f 'g 'h 'i 'j)
       baz (list 'k 'l 'm)) ⇒  (K L M)
 (setq foo (nconc nil foo bar nil baz)) ⇒  (A B C D E F G H I J K L M) 
 foo ⇒  (A B C D E F G H I J K L M)
 bar ⇒  (F G H I J K L M)
 baz ⇒  (K L M)

Side Effects::

The lists are modified rather than copied.

See Also::

append , concatenate

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/get_002doutput_002dstream_002dstring.html0000644000175000017500000001034714360276512022070 0ustar cammcamm get-output-stream-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.48 get-output-stream-string [Function]

get-output-stream-string string-output-stream ⇒ string

Arguments and Values::

string-output-stream—a stream.

string—a string.

Description::

Returns a string containing, in order, all the characters that have been output to string-output-stream. This operation clears any characters on string-output-stream, so the string contains only those characters which have been output since the last call to get-output-stream-string or since the creation of the string-output-stream, whichever occurred most recently.

Examples::

 (setq a-stream (make-string-output-stream)
        a-string "abcdefghijklm") ⇒  "abcdefghijklm"
 (write-string a-string a-stream) ⇒  "abcdefghijklm"
 (get-output-stream-string a-stream) ⇒  "abcdefghijklm"
 (get-output-stream-string a-stream) ⇒  ""

Side Effects::

The string-output-stream is cleared.

Exceptional Situations::

The consequences are undefined if stream-output-string is closed.

The consequences are undefined if string-output-stream is a stream that was not produced by make-string-output-stream.

The consequences are undefined if string-output-stream was created implicitly by with-output-to-string or format.

See Also::

make-string-output-stream

gcl-2.6.14/info/gcl/Restrictions-on-Examining-a-Pathname-Type-Component.html0000644000175000017500000000513714360276512025236 0ustar cammcamm Restrictions on Examining a Pathname Type Component (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.18 Restrictions on Examining a Pathname Type Component

The type might be a string, :wild, :unspecific, or nil.

gcl-2.6.14/info/gcl/loop_002dfinish.html0000644000175000017500000001255314360276512016266 0ustar cammcamm loop-finish (ANSI and GNU Common Lisp Document)

Previous: , Up: Iteration Dictionary  

6.2.5 loop-finish [Local Macro]

Syntax::

loop-finish <no arguments> ⇒ #<NoValue>

Description::

The loop-finish macro can be used lexically within an extended loop form to terminate that form “normally.” That is, it transfers control to the loop epilogue of the lexically innermost extended loop form. This permits execution of any finally clause (for effect) and the return of any accumulated result.

Examples::

;; Terminate the loop, but return the accumulated count.
 (loop for i in '(1 2 3 stop-here 4 5 6)
       when (symbolp i) do (loop-finish)
       count i)
⇒  3

;; The preceding loop is equivalent to:
 (loop for i in '(1 2 3 stop-here 4 5 6)
       until (symbolp i)
       count i)
⇒  3

;; While LOOP-FINISH can be used can be used in a variety of 
;; situations it is really most needed in a situation where a need
;; to exit is detected at other than the loop's `top level'
;; (where UNTIL or WHEN often work just as well), or where some 
;; computation must occur between the point where a need to exit is
;; detected and the point where the exit actually occurs.  For example:
 (defun tokenize-sentence (string)
   (macrolet ((add-word (wvar svar)
                `(when ,wvar
                   (push (coerce (nreverse ,wvar) 'string) ,svar)
                   (setq ,wvar nil))))
     (loop with word = '() and sentence = '() and endpos = nil
           for i below (length string)
           do (let ((char (aref string i)))
                (case char
                  (#\Space (add-word word sentence))
                  (#\. (setq endpos (1+ i)) (loop-finish))
                  (otherwise (push char word))))
           finally (add-word word sentence)
                   (return (values (nreverse sentence) endpos)))))
⇒  TOKENIZE-SENTENCE

 (tokenize-sentence "this is a sentence. this is another sentence.")
⇒  ("this" "is" "a" "sentence"), 19

 (tokenize-sentence "this is a sentence")
⇒  ("this" "is" "a" "sentence"), NIL

Side Effects::

Transfers control.

Exceptional Situations::

Whether or not loop-finish is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of loop-finish are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use loop-finish outside of loop are undefined.

See Also::

loop , The LOOP Facility

Notes::

Previous: , Up: Iteration Dictionary  

gcl-2.6.14/info/gcl/Capitalization-and-Punctuation-in-Condition-Reports.html0000644000175000017500000000552014360276512025371 0ustar cammcamm Capitalization and Punctuation in Condition Reports (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printing Conditions  

9.1.3.2 Capitalization and Punctuation in Condition Reports

It is recommended that a report message be a complete sentences, in the proper case and correctly punctuated. In English, for example, this means the first letter should be uppercase, and there should be a trailing period. 

 (error "This is a message")  ; Not recommended
 (error "this is a message.") ; Not recommended

 (error "This is a message.") ; Recommended instead
gcl-2.6.14/info/gcl/last.html0000644000175000017500000001102114360276512014317 0ustar cammcamm last (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.29 last [Function]

last list &optional n ⇒ tail

Arguments and Values::

list—a list,

which might be a dotted list but must not be a circular list.

n—a non-negative integer. The default is 1.

tail—an object.

Description::

last returns the last n conses (not the last n elements) of list). If list is (), last returns ().

If n is zero, the atom that terminates list is returned. If n is greater than or equal to the number of cons cells in list, the result is list.

Examples::

 (last nil) ⇒  NIL
 (last '(1 2 3)) ⇒  (3)
 (last '(1 2 . 3)) ⇒  (2 . 3)
 (setq x (list 'a 'b 'c 'd)) ⇒  (A B C D)
 (last x) ⇒  (D)
 (rplacd (last x) (list 'e 'f)) x ⇒  (A B C D E F)
 (last x) ⇒  (F)

 (last '(a b c))   ⇒  (C)

 (last '(a b c) 0) ⇒  ()
 (last '(a b c) 1) ⇒  (C)
 (last '(a b c) 2) ⇒  (B C)
 (last '(a b c) 3) ⇒  (A B C)
 (last '(a b c) 4) ⇒  (A B C)

 (last '(a . b) 0) ⇒  B
 (last '(a . b) 1) ⇒  (A . B)
 (last '(a . b) 2) ⇒  (A . B)

Exceptional Situations::

The consequences are undefined if list is a circular list.

Should signal an error of type type-error if n is not a non-negative integer.

See Also::

butlast , nth

Notes::

The following code could be used to define last. 

 (defun last (list &optional (n 1))
   (check-type n (integer 0))
   (do ((l list (cdr l))
        (r list)
        (i 0 (+ i 1)))
       ((atom l) r)
     (if (>= i n) (pop r))))

Next: , Previous: , Up: Conses Dictionary  

gcl-2.6.14/info/gcl/Restrictions-on-Composite-Streams.html0000644000175000017500000000464614360276512022051 0ustar cammcamm Restrictions on Composite Streams (ANSI and GNU Common Lisp Document)

Previous: , Up: Stream Concepts  

21.1.4 Restrictions on Composite Streams

The consequences are undefined if any component of a composite stream is closed before the composite stream is closed.

The consequences are undefined if the synonym stream symbol is not bound to an open stream from the time of the synonym stream’s creation until the time it is closed.

gcl-2.6.14/info/gcl/make_002dload_002dform_002dsaving_002dslots.html0000644000175000017500000001125614360276512023050 0ustar cammcamm make-load-form-saving-slots (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.22 make-load-form-saving-slots [Function]

make-load-form-saving-slots object &key slot-names environment
⇒ creation-form, initialization-form

Arguments and Values::

object—an object.

slot-names—a list.

environment—an environment object.

creation-form—a form.

initialization-form—a form.

Description::

Returns forms that, when evaluated, will construct an object equivalent to object, without executing initialization forms. The slots in the new object that correspond to initialized slots in object are initialized using the values from object. Uninitialized slots in object are not initialized in the new object. make-load-form-saving-slots works for any instance of standard-object or structure-object.

Slot-names is a list of the names of the slots to preserve. If slot-names is not supplied, its value is all of the local slots.

make-load-form-saving-slots returns two values, thus it can deal with circular structures. Whether the result is useful in an application depends on whether the object’s type and slot contents fully capture the application’s idea of the object’s state.

Environment is the environment in which the forms will be processed.

See Also::

make-load-form , make-instance , setf , slot-value , slot-makunbound

Notes::

make-load-form-saving-slots can be useful in user-written make-load-form methods.

When the object is an instance of standard-object, make-load-form-saving-slots could return a creation form that calls allocate-instance and an initialization form that contains calls to setf of slot-value and slot-makunbound, though other functions of similar effect might actually be used.

gcl-2.6.14/info/gcl/pprint_002dlogical_002dblock.html0000644000175000017500000002242414360276512020521 0ustar cammcamm pprint-logical-block (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.7 pprint-logical-block [Macro]

pprint-logical-block (stream-symbol object &key prefix per-line-prefix suffix) {declaration}* {form}*
⇒ nil

Arguments and Values::

stream-symbol—a stream variable designator.

object—an object; evaluated.

:prefix—a string; evaluated. Complicated defaulting behavior; see below.

:per-line-prefix—a string; evaluated. Complicated defaulting behavior; see below.

:suffix—a string; evaluated. The default is the null string.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

Description::

Causes printing to be grouped into a logical block.

The logical block is printed to the stream that is the value of the variable denoted by stream-symbol. During the execution of the forms, that variable is bound to a pretty printing stream that supports decisions about the arrangement of output and then forwards the output to the destination stream.

All the standard printing functions (e.g., write, princ, and terpri) can be used to print output to the pretty printing stream. All and only the output sent to this pretty printing stream is treated as being in the logical block.

The prefix specifies a prefix to be printed before the beginning of the logical block. The per-line-prefix specifies a prefix that is printed before the block and at the beginning of each new line in the block. The :prefix and :pre-line-prefix arguments are mutually exclusive. If neither :prefix nor :per-line-prefix is specified, a prefix of the null string is assumed.

The suffix specifies a suffix that is printed just after the logical block.

The object is normally a list that the body forms are responsible for printing. If object is not a list, it is printed using write. (This makes it easier to write printing functions that are robust in the face of malformed arguments.) If *print-circle* is non-nil and object is a circular (or shared) reference to a cons, then an appropriate “#n#” marker is printed. (This makes it easy to write printing functions that provide full support for circularity and sharing abbreviation.) If *print-level* is not nil and the logical block is at a dynamic nesting depth of greater than *print-level* in logical blocks, “#” is printed. (This makes easy to write printing functions that provide full support for depth abbreviation.)

If either of the three conditions above occurs, the indicated output is printed on stream-symbol and the body forms are skipped along with the printing of the :prefix and :suffix. (If the body forms are not to be responsible for printing a list, then the first two tests above can be turned off by supplying nil for the object argument.)

In addition to the object argument of pprint-logical-block, the arguments of the standard printing functions (such as write, print, prin1, and pprint, as well as the arguments of the standard format directives such as ~A, ~S, (and ~W) are all checked (when necessary) for circularity and sharing. However, such checking is not applied to the arguments of the functions write-line, write-string, and write-char or to the literal text output by format. A consequence of this is that you must use one of the latter functions if you want to print some literal text in the output that is not supposed to be checked for circularity or sharing.

The body forms of a pprint-logical-block form must not perform any side-effects on the surrounding environment; for example, no variables must be assigned which have not been bound within its scope.

The pprint-logical-block macro may be used regardless of the value of *print-pretty*.

Affected By::

*print-circle*, *print-level*.

Exceptional Situations::

An error of type type-error is signaled if any of the :suffix, :prefix, or :per-line-prefix is supplied but does not evaluate to a string.

An error is signaled if :prefix and :pre-line-prefix are both used.

pprint-logical-block and the pretty printing stream it creates have dynamic extent. The consequences are undefined if, outside of this extent, output is attempted to the pretty printing stream it creates.

It is also unspecified what happens if, within this extent, any output is sent directly to the underlying destination stream.

See Also::

pprint-pop , pprint-exit-if-list-exhausted , Tilde Less-Than-Sign-> Logical Block

Notes::

One reason for using the pprint-logical-block macro when the value of *print-pretty* is nil would be to allow it to perform checking for dotted lists, as well as (in conjunction with pprint-pop) checking for *print-level* or *print-length* being exceeded.

Detection of circularity and sharing is supported by the pretty printer by in essence performing requested output twice. On the first pass, circularities and sharing are detected and the actual outputting of characters is suppressed. On the second pass, the appropriate “#n=” and “#n#” markers are inserted and characters are output. This is why the restriction on side-effects is necessary. Obeying this restriction is facilitated by using pprint-pop, instead of an ordinary pop when traversing a list being printed by the body forms of the pprint-logical-block form.)

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Numeric-Operations.html0000644000175000017500000001424514360276512017112 0ustar cammcamm Numeric Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.1 Numeric Operations

Common Lisp provides a large variety of operations related to numbers. This section provides an overview of those operations by grouping them into categories that emphasize some of the relationships among them.

Figure 12–1 shows operators relating to arithmetic operations. 

  *  1+         gcd   
  +  1-         incf  
  -  conjugate  lcm   
  /  decf             

  Figure 12–1: Operators relating to Arithmetic.

Figure 12–2 shows defined names relating to exponential, logarithmic, and trigonometric operations. 

  abs    cos    signum  
  acos   cosh   sin     
  acosh  exp    sinh    
  asin   expt   sqrt    
  asinh  isqrt  tan     
  atan   log    tanh    
  atanh  phase          
  cis    pi             

  Figure 12–2: Defined names relating to Exponentials, Logarithms, and Trigonometry.

Figure 12–3 shows operators relating to numeric comparison and predication. 

  /=  >=      oddp   
  <   evenp   plusp  
  <=  max     zerop  
  =   min            
  >   minusp         

  Figure 12–3: Operators for numeric comparison and predication.

Figure 12–4 shows defined names relating to numeric type manipulation and coercion. 

  ceiling          float-radix           rational     
  complex          float-sign            rationalize  
  decode-float     floor                 realpart     
  denominator      fround                rem          
  fceiling         ftruncate             round        
  ffloor           imagpart              scale-float  
  float            integer-decode-float  truncate     
  float-digits     mod                                
  float-precision  numerator                          

  Figure 12–4: Defined names relating to numeric type manipulation and coercion.
• Associativity and Commutativity in Numeric Operations  
• Examples of Associativity and Commutativity in Numeric Operations  
• Contagion in Numeric Operations  
• Viewing Integers as Bits and Bytes  
• Logical Operations on Integers  
• Byte Operations on Integers  

Next: , Previous: , Up: Number Concepts  

gcl-2.6.14/info/gcl/invoke_002ddebugger.html0000644000175000017500000000767014360276512017120 0ustar cammcamm invoke-debugger (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.22 invoke-debugger [Function]

invoke-debugger condition ⇒ #<NoValue>

Arguments and Values::

condition—a condition object.

Description::

invoke-debugger attempts to enter the debugger with condition.

If *debugger-hook* is not nil, it should be a function (or the name of a function) to be called prior to entry to the standard debugger. The function is called with *debugger-hook* bound to nil, and the function must accept two arguments: the condition and the value of *debugger-hook* prior to binding it to nil. If the function returns normally, the standard debugger is entered.

The standard debugger never directly returns. Return can occur only by a non-local transfer of control, such as the use of a restart function.

Examples::

 (ignore-errors ;Normally, this would suppress debugger entry
   (handler-bind ((error #'invoke-debugger)) ;But this forces debugger entry
     (error "Foo.")))
Debug: Foo.
To continue, type :CONTINUE followed by an option number:
 1: Return to Lisp Toplevel.
Debug>

Side Effects::

*debugger-hook* is bound to nil, program execution is discontinued, and the debugger is entered.

Affected By::

*debug-io* and *debugger-hook*.

See Also::

error , break

gcl-2.6.14/info/gcl/Overview-of-the-Loop-Facility.html0000644000175000017500000001223114360276512021017 0ustar cammcamm Overview of the Loop Facility (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.1 Overview of the Loop Facility

The loop macro performs iteration.

• Simple vs Extended Loop  
• Simple Loop  
• Extended Loop  
• Loop Keywords  
• Parsing Loop Clauses  
• Expanding Loop Forms  
• Summary of Loop Clauses  
• Summary of Variable Initialization and Stepping Clauses  
• Summary of Value Accumulation Clauses  
• Summary of Termination Test Clauses  
• Summary of Unconditional Execution Clauses  
• Summary of Conditional Execution Clauses  
• Summary of Miscellaneous Clauses  
• Order of Execution  
• Destructuring  
• Restrictions on Side-Effects  
gcl-2.6.14/info/gcl/Types.html0000644000175000017500000000477714360276512014504 0ustar cammcamm Types (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes  

4.2 Types

• Data Type Definition  
• Type Relationships  
• Type Specifiers  
gcl-2.6.14/info/gcl/The-_0022Initial-Value_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000551614360276512025303 0ustar cammcamm The "Initial Value" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.15 The "Initial Value" Section of a Dictionary Entry

This information describes the initial value of a dynamic variable. Since this variable might change, see type restrictions in The "Value Type" Section.

gcl-2.6.14/info/gcl/FORMAT-Floating_002dPoint-Printers.html0000644000175000017500000000611714360276512021462 0ustar cammcamm FORMAT Floating-Point Printers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.3 FORMAT Floating-Point Printers

• Tilde F-> Fixed-Format Floating-Point  
• Tilde E-> Exponential Floating-Point  
• Tilde G-> General Floating-Point  
• Tilde Dollarsign-> Monetary Floating-Point  
gcl-2.6.14/info/gcl/equal.html0000644000175000017500000001670714360276512014503 0ustar cammcamm equal (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.35 equal [Function]

equal x y ⇒ generalized-boolean

Arguments and Values::

x—an object.

y—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if x and y are structurally similar (isomorphic) objects. Objects are treated as follows by equal.

Symbols, Numbers, and Characters

equal is true of two objects if they are symbols that are eq, if they are numbers that are eql, or if they are characters that are eql.

Conses

For conses, equal is defined recursively as the two cars being equal and the two cdrs being equal.

Arrays

Two arrays are equal only if they are eq, with one exception: strings and bit vectors are compared element-by-element (using eql). If either x or y has a fill pointer, the fill pointer limits the number of elements examined by equal. Uppercase and lowercase letters in strings are considered by equal to be different.

Pathnames

Two pathnames are equal if and only if all the corresponding components (host, device, and so on) are equivalent. Whether or not uppercase and lowercase letters are considered equivalent in strings appearing in components is implementation-dependent. pathnames that are equal should be functionally equivalent.

Other (Structures, hash-tables, instances, ...)

Two other objects are equal only if they are eq.

equal does not descend any objects other than the ones explicitly specified above. Figure 5–12 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of equal, with upper entries taking priority over lower ones. 

  Type          Behavior                   
  number        uses eql                   
  character     uses eql                   
  cons          descends                   
  bit vector    descends                   
  string        descends                   
  pathname      “functionally equivalent”  
  structure     uses eq                    
  Other array   uses eq                    
  hash table    uses eq                    
  Other object  uses eq                    

  Figure 5–12: Summary and priorities of behavior of equal

Any two objects that are eql are also equal.

equal may fail to terminate if x or y is circular.

Examples::

 (equal 'a 'b) ⇒  false
 (equal 'a 'a) ⇒  true
 (equal 3 3) ⇒  true
 (equal 3 3.0) ⇒  false
 (equal 3.0 3.0) ⇒  true
 (equal #c(3 -4) #c(3 -4)) ⇒  true
 (equal #c(3 -4.0) #c(3 -4)) ⇒  false
 (equal (cons 'a 'b) (cons 'a 'c)) ⇒  false
 (equal (cons 'a 'b) (cons 'a 'b)) ⇒  true
 (equal #\A #\A) ⇒  true
 (equal #\A #\a) ⇒  false
 (equal "Foo" "Foo") ⇒  true
 (equal "Foo" (copy-seq "Foo")) ⇒  true
 (equal "FOO" "foo") ⇒  false
 (equal "This-string" "This-string") ⇒  true
 (equal "This-string" "this-string") ⇒  false

See Also::

eq , eql , equalp , = , string= , string-equal, char= , char-equal, tree-equal

Notes::

Object equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, equal and equalp are not appropriate for every application.

A rough rule of thumb is that two objects are equal if and only if their printed representations are the same.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/t-_0028System-Class_0029.html0000644000175000017500000000463614360276512017305 0ustar cammcamm t (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.16 t [System Class]

Class Precedence List::

t

Description::

The set of all objects. The type t is a supertype of every type, including itself. Every object is of type t.

gcl-2.6.14/info/gcl/file_002dauthor.html0000644000175000017500000000703714360276512016257 0ustar cammcamm file-author (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.5 file-author [Function]

file-author pathspec ⇒ author

Arguments and Values::

pathspec—a pathname designator.

author—a string or nil.

Description::

Returns a string naming the author of the file specified by pathspec, or nil if the author’s name cannot be determined.

Examples::

 (with-open-file (stream ">relativity>general.text")
   (file-author s))
⇒  "albert"

Affected By::

The host computer’s file system.

Other users of the file named by pathspec.

Exceptional Situations::

An error of type file-error is signaled if pathspec is wild.

An error of type file-error is signaled if the file system cannot perform the requested operation.

See Also::

pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

gcl-2.6.14/info/gcl/Destructuring.html0000644000175000017500000001627614360276512016237 0ustar cammcamm Destructuring (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.15 Destructuring

The d-type-spec argument is used for destructuring. If the d-type-spec argument consists solely of the type fixnum, float, t, or nil, the of-type keyword is optional. The of-type construct is optional in these cases to provide backwards compatibility; thus, the following two expressions are the same: 

;;; This expression uses the old syntax for type specifiers.
 (loop for i fixnum upfrom 3 ...)

;;; This expression uses the new syntax for type specifiers.
 (loop for i of-type fixnum upfrom 3 ...)

;; Declare X and Y to be of type VECTOR and FIXNUM respectively.
 (loop for (x y) of-type (vector fixnum) 
       in l do ...)

A type specifier for a destructuring pattern is a tree of type specifiers with the same shape as the tree of variable names, with the following exceptions:

*

When aligning the trees, an atom in the tree of type specifiers that matches a cons in the variable tree declares the same type for each variable in the subtree rooted at the cons.

*

A cons in the tree of type specifiers that matches an atom in the tree of variable names is a compound type specifer.

Destructuring allows binding of a set of variables to a corresponding set of values anywhere that a value can normally be bound to a single variable. During loop expansion, each variable in the variable list is matched with the values in the values list. If there are more variables in the variable list than there are values in the values list, the remaining variables are given a value of nil. If there are more values than variables listed, the extra values are discarded.

To assign values from a list to the variables a, b, and c, the for clause could be used to bind the variable numlist to the car of the supplied form, and then another for clause could be used to bind the variables a, b, and c sequentially. 

;; Collect values by using FOR constructs.
 (loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
       for a of-type integer = (first numlist)
       and b of-type integer = (second numlist)
       and c of-type float = (third numlist)
       collect (list c b a))
⇒  ((4.0 2 1) (8.3 6 5) (10.4 9 8))

Destructuring makes this process easier by allowing the variables to be bound in each loop iteration. Types can be declared by using a list of type-spec arguments. If all the types are the same, a shorthand destructuring syntax can be used, as the second example illustrates. 

;; Destructuring simplifies the process.
 (loop for (a b c) of-type (integer integer float) in
       '((1 2 4.0) (5 6 8.3) (8 9 10.4))
       collect (list c b a))
⇒  ((4.0 2 1) (8.3 6 5) (10.4 9 8))

;; If all the types are the same, this way is even simpler.
 (loop for (a b c) of-type float in
       '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4))
       collect (list c b a))
⇒  ((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0))

If destructuring is used to declare or initialize a number of groups of variables into types, the loop keyword and can be used to simplify the process further. 

;; Initialize and declare variables in parallel by using the AND construct.\kern-7pt
 (loop with (a b) of-type float = '(1.0 2.0)
       and (c d) of-type integer = '(3 4)
       and (e f)
       return (list a b c d e f))
⇒  (1.0 2.0 3 4 NIL NIL)

If nil is used in a destructuring list, no variable is provided for its place. 

 (loop for (a nil b) = '(1 2 3)
       do (return (list a b)))
⇒  (1 3)

Note that dotted lists can specify destructuring. 

 (loop for (x . y) = '(1 . 2)
       do (return y))
⇒  2
 (loop for ((a . b) (c . d)) of-type ((float . float) (integer . integer)) in
       '(((1.2 . 2.4) (3 . 4)) ((3.4 . 4.6) (5 . 6)))
       collect (list a b c d))
⇒  ((1.2 2.4 3 4) (3.4 4.6 5 6))

An error of type program-error is signaled (at macro expansion time) if the same variable is bound twice in any variable-binding clause of a single loop expression. Such variables include local variables, iteration control variables, and variables found by destructuring.

Next: , Previous: , Up: Overview of the Loop Facility  

gcl-2.6.14/info/gcl/Examples-of-Ordinary-Lambda-Lists.html0000644000175000017500000001471014360276512021603 0ustar cammcamm Examples of Ordinary Lambda Lists (ANSI and GNU Common Lisp Document)

Previous: , Up: Ordinary Lambda Lists  

3.4.1.8 Examples of Ordinary Lambda Lists

Here are some examples involving optional parameters and rest parameters: 

 ((lambda (a b) (+ a (* b 3))) 4 5) ⇒  19
 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5) ⇒  19
 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4) ⇒  10
 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)))
⇒  (2 NIL 3 NIL NIL)
 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6)
⇒  (6 T 3 NIL NIL)
 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3)
⇒  (6 T 3 T NIL)
 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8)
⇒  (6 T 3 T (8))
 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x))
  6 3 8 9 10 11)
⇒  (6 t 3 t (8 9 10 11))

Here are some examples involving keyword parameters: 

 ((lambda (a b &key c d) (list a b c d)) 1 2) ⇒  (1 2 NIL NIL)
 ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6) ⇒  (1 2 6 NIL)
 ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8) ⇒  (1 2 NIL 8)
 ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8) ⇒  (1 2 6 8)
 ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6) ⇒  (1 2 6 8)
 ((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6) ⇒  (:a 1 6 8)
 ((lambda (a b &key c d) (list a b c d)) :a :b :c :d) ⇒  (:a :b :d NIL)
 ((lambda (a b &key ((:sea c)) d) (list a b c d)) 1 2 :sea 6) ⇒  (1 2 6 NIL)
 ((lambda (a b &key ((c c)) d) (list a b c d)) 1 2 'c 6) ⇒  (1 2 6 NIL)

Here are some examples involving optional parameters, rest parameters, and keyword parameters together: 

 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) 1)   
⇒  (1 3 NIL 1 ()) 
 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) 1 2)
⇒  (1 2 NIL 1 ())
 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) :c 7)
⇒  (:c 7 NIL :c ())
 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) 1 6 :c 7)
⇒  (1 6 7 1 (:c 7))
 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) 1 6 :d 8)
⇒  (1 6 NIL 8 (:d 8))
 ((lambda (a &optional (b 3) &rest x &key c (d a))
    (list a b c d x)) 1 6 :d 8 :c 9 :d 10)
⇒  (1 6 9 8 (:d 8 :c 9 :d 10))

As an example of the use of &allow-other-keys and :allow-other-keys, consider a function that takes two named arguments of its own and also accepts additional named arguments to be passed to make-array: 

 (defun array-of-strings (str dims &rest named-pairs
                          &key (start 0) end &allow-other-keys)
   (apply #'make-array dims
          :initial-element (subseq str start end)
          :allow-other-keys t
          named-pairs))

This function takes a string and dimensioning information and returns an array of the specified dimensions, each of whose elements is the specified string. However, :start and :end named arguments may be used to specify that a substring of the given string should be used. In addition, the presence of &allow-other-keys in the lambda list indicates that the caller may supply additional named arguments; the rest parameter provides access to them. These additional named arguments are passed to make-array. The function make-array normally does not allow the named arguments :start and :end to be used, and an error should be signaled if such named arguments are supplied to make-array. However, the presence in the call to make-array of the named argument :allow-other-keys with a true value causes any extraneous named arguments, including :start and :end, to be acceptable and ignored.

Previous: , Up: Ordinary Lambda Lists  

gcl-2.6.14/info/gcl/sleep.html0000644000175000017500000000661414360276512014500 0ustar cammcamm sleep (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.4 sleep [Function]

sleep seconds ⇒ nil

Arguments and Values::

seconds—a non-negative real.

Description::

Causes execution to cease and become dormant for approximately the seconds of real time indicated by seconds, whereupon execution is resumed.

Examples::

 (sleep 1) ⇒  NIL 

;; Actually, since SLEEP is permitted to use approximate timing, 
;; this might not always yield true, but it will often enough that
;; we felt it to be a productive example of the intent.
 (let ((then (get-universal-time))
       (now  (progn (sleep 10) (get-universal-time))))
   (>= (- now then) 10))
⇒  true

Side Effects::

Causes processing to pause.

Affected By::

The granularity of the scheduler.

Exceptional Situations::

Should signal an error of type type-error if seconds is not a non-negative real.

gcl-2.6.14/info/gcl/_002f.html0000644000175000017500000001020414360276512014164 0ustar cammcamm / (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.27 / [Function]

/ number ⇒ reciprocal

/ numerator &rest denominators^+ ⇒ quotient

Arguments and Values::

number, denominator—a non-zero number.

numerator, quotient, reciprocal—a number.

Description::

The function / performs division or reciprocation.

If no denominators are supplied, the function / returns the reciprocal of number.

If at least one denominator is supplied, the function / divides the numerator by all of the denominators and returns the resulting quotient.

If each argument is either an integer or a ratio, and the result is not an integer, then it is a ratio.

The function / performs necessary type conversions.

If any argument is a float then the rules of floating-point contagion apply; see Floating-point Computations.

Examples::

 (/ 12 4) ⇒  3
 (/ 13 4) ⇒  13/4
 (/ -8) ⇒  -1/8
 (/ 3 4 5) ⇒  3/20
 (/ 0.5) ⇒  2.0
 (/ 20 5) ⇒  4
 (/ 5 20) ⇒  1/4
 (/ 60 -2 3 5.0) ⇒  -2.0
 (/ 2 #c(2 2)) ⇒  #C(1/2 -1/2)

Exceptional Situations::

The consequences are unspecified if any argument other than the first is zero. If there is only one argument, the consequences are unspecified if it is zero.

Might signal type-error if some argument is not a number. Might signal division-by-zero if division by zero is attempted. Might signal arithmetic-error.

See Also::

floor , ceiling, truncate, round

gcl-2.6.14/info/gcl/char_002dcode.html0000644000175000017500000000606614360276512015666 0ustar cammcamm char-code (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.16 char-code [Function]

char-code character ⇒ code

Arguments and Values::

character—a character.

code—a character code.

Description::

char-code returns the code attribute of character.

Examples::

;; An implementation using ASCII character encoding 
;; might return these values:
(char-code #\$) ⇒  36
(char-code #\a) ⇒  97

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

char-code-limit

gcl-2.6.14/info/gcl/restart_002dbind.html0000644000175000017500000002016714360276512016435 0ustar cammcamm restart-bind (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.36 restart-bind [Macro]

restart-bind ({(name function {!key-val-pair}*)}) {form}*
⇒ {result}*

key-val-pair ::=:interactive-function interactive-function |                   :report-function report-function |                   :test-function test-function

Arguments and Values::

name—a symbol; not evaluated.

function—a form; evaluated.

forms—an implicit progn.

interactive-function—a form; evaluated.

report-function—a form; evaluated.

test-function—a form; evaluated.

results—the values returned by the forms.

Description::

restart-bind executes the body of forms in a dynamic environment where restarts with the given names are in effect.

If a name is nil, it indicates an anonymous restart; if a name is a non-nil symbol, it indicates a named restart.

The function, interactive-function, and report-function are unconditionally evaluated in the current lexical and dynamic environment prior to evaluation of the body. Each of these forms must evaluate to a function.

If invoke-restart is done on that restart, the function which resulted from evaluating function is called, in the dynamic environment of the invoke-restart, with the arguments given to invoke-restart. The function may either perform a non-local transfer of control or may return normally.

If the restart is invoked interactively from the debugger (using invoke-restart-interactively), the arguments are defaulted by calling the function which resulted from evaluating interactive-function. That function may optionally prompt interactively on query I/O, and should return a list of arguments to be used by invoke-restart-interactively when invoking the restart.

If a restart is invoked interactively but no interactive-function is used, then an argument list of nil is used. In that case, the function must be compatible with an empty argument list.

If the restart is presented interactively (e.g., by the debugger), the presentation is done by calling the function which resulted from evaluating report-function. This function must be a function of one argument, a stream. It is expected to print a description of the action that the restart takes to that stream. This function is called any time the restart is printed while *print-escape* is nil.

In the case of interactive invocation, the result is dependent on the value of :interactive-function as follows.

:interactive-function

Value is evaluated in the current lexical environment and should return a function of no arguments which constructs a list of arguments to be used by invoke-restart-interactively when invoking this restart. The function may prompt interactively using query I/O if necessary.

:report-function

Value is evaluated in the current lexical environment and should return a function of one argument, a stream, which prints on the stream a summary of the action that this restart takes. This function is called whenever the restart is reported (printed while *print-escape* is nil). If no :report-function option is provided, the manner in which the restart is reported is implementation-dependent.

:test-function

Value is evaluated in the current lexical environment and should return a function of one argument, a condition, which returns true if the restart is to be considered visible.

Affected By::

*query-io*.

See Also::

restart-case , with-simple-restart

Notes::

restart-bind is primarily intended to be used to implement restart-case and might be useful in implementing other macros. Programmers who are uncertain about whether to use restart-case or restart-bind should prefer restart-case for the cases where it is powerful enough, using restart-bind only in cases where its full generality is really needed.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Summary-of-Value-Accumulation-Clauses.html0000644000175000017500000001117014360276512022511 0ustar cammcamm Summary of Value Accumulation Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.9 Summary of Value Accumulation Clauses

The collect (or collecting) construct takes one form in its clause and adds the value of that form to the end of a list of values. By default, the list of values is returned when the loop finishes.

The append (or appending) construct takes one form in its clause and appends the value of that form to the end of a list of values. By default, the list of values is returned when the loop finishes.

The nconc (or nconcing) construct is similar to the append construct, but its list values are concatenated as if by the function nconc. By default, the list of values is returned when the loop finishes.

The sum (or summing) construct takes one form in its clause that must evaluate to a number and accumulates the sum of all these numbers. By default, the cumulative sum is returned when the loop finishes.

The count (or counting) construct takes one form in its clause and counts the number of times that the form evaluates to true. By default, the count is returned when the loop finishes.

The minimize (or minimizing) construct takes one form in its clause and determines the minimum value obtained by evaluating that form. By default, the minimum value is returned when the loop finishes.

The maximize (or maximizing) construct takes one form in its clause and determines the maximum value obtained by evaluating that form. By default, the maximum value is returned when the loop finishes.

For more information, see Value Accumulation Clauses.

Next: , Previous: , Up: Overview of the Loop Facility  

gcl-2.6.14/info/gcl/Appendix.html0000644000175000017500000000377214360276512015142 0ustar cammcamm Appendix (ANSI and GNU Common Lisp Document)

Previous: , Up: Top  

27 Appendix

• Removed Language Features  
gcl-2.6.14/info/gcl/Numeric-Characters.html0000644000175000017500000000476714360276512017056 0ustar cammcamm Numeric Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Categories  

13.1.4.8 Numeric Characters

The numeric characters are a subset of the graphic characters. Of the standard characters, only these are numeric characters:

0 1 2 3 4 5 6 7 8 9

For each implementation-defined graphic character that has no case, the implementation must define whether or not it is a numeric character.

gcl-2.6.14/info/gcl/simple_002darray.html0000644000175000017500000001163014360276512016437 0ustar cammcamm simple-array (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.2 simple-array [Type]

Supertypes::

simple-array, array, t

Description::

The type of an array that is not displaced to another array, has no fill pointer, and is not expressly adjustable is a subtype of type simple-array. The concept of a simple array exists to allow the implementation to use a specialized representation and to allow the user to declare that certain values will always be simple arrays.

The types simple-vector, simple-string, and simple-bit-vector are disjoint subtypes of type simple-array, for they respectively mean (simple-array t (*)), the union of all (simple-array c (*)) for any c being a subtype of type character, and (simple-array bit (*)).

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(simple-array{[{element-type | *} [dimension-spec]]})

dimension-spec ::=rank | * | ({dimension | *}*)

Compound Type Specifier Arguments::

dimension—a valid array dimension.

element-type—a type specifier.

rank—a non-negative fixnum.

Compound Type Specifier Description::

This compound type specifier is treated exactly as the corresponding compound type specifier for type array would be treated, except that the set is further constrained to include only simple arrays.

Notes::

It is implementation-dependent whether displaced arrays, vectors with fill pointers, or arrays that are actually adjustable are simple arrays.

(simple-array *) refers to all simple arrays regardless of element type, (simple-array type-specifier) refers only to those simple arrays that can result from giving type-specifier as the :element-type argument to make-array.

gcl-2.6.14/info/gcl/logtest.html0000644000175000017500000000677414360276512015060 0ustar cammcamm logtest (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.65 logtest [Function]

logtest integer-1 integer-2 ⇒ generalized-boolean

Arguments and Values::

integer-1—an integer.

integer-2—an integer.

generalized-boolean—a generalized boolean.

Description::

Returns true if any of the bits designated by the 1’s in integer-1 is 1 in integer-2; otherwise it is false. integer-1 and integer-2 are treated as if they were binary.

Negative integer-1 and integer-2 are treated as if they were represented in two’s-complement binary.

Examples::

 (logtest 1 7) ⇒  true
 (logtest 1 2) ⇒  false
 (logtest -2 -1) ⇒  true
 (logtest 0 -1) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if integer-1 is not an integer. Should signal an error of type type-error if integer-2 is not an integer.

Notes::

 (logtest x y) ≡ (not (zerop (logand x y)))
gcl-2.6.14/info/gcl/ensure_002ddirectories_002dexist.html0000644000175000017500000001012714360276512021447 0ustar cammcamm ensure-directories-exist (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.3 ensure-directories-exist [Function]

ensure-directories-exist pathspec &key verbose ⇒ pathspec, created

Arguments and Values::

pathspec—a pathname designator.

verbose—a generalized boolean.

created—a generalized boolean.

Description::

Tests whether the directories containing the specified file actually exist, and attempts to create them if they do not.

If the containing directories do not exist and if verbose is true, then the implementation is permitted (but not required) to perform output to standard output saying what directories were created. If the containing directories exist, or if verbose is false, this function performs no output.

The primary value is the given pathspec so that this operation can be straightforwardly composed with other file manipulation expressions. The secondary value, created, is true if any directories were created.

Affected By::

The host computer’s file system.

Exceptional Situations::

An error of type file-error is signaled if the host, device, or directory part of pathspec is wild.

If the directory creation attempt is not successful, an error of type file-error is signaled; if this occurs, it might be the case that none, some, or all of the requested creations have actually occurred within the file system.

See Also::

probe-file , open ,

Pathnames as Filenames

gcl-2.6.14/info/gcl/Deftype-Lambda-Lists.html0000644000175000017500000000516314360276512017240 0ustar cammcamm Deftype Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.8 Deftype Lambda Lists

A deftype lambda list is used by deftype.

A deftype lambda list has the same syntax as a macro lambda list, and can therefore contain the lambda list keywords as a macro lambda list.

A deftype lambda list differs from a macro lambda list only in that if no init-form is supplied for an optional parameter or keyword parameter in the lambda-list, the default value for that parameter is the symbol * (rather than nil).

gcl-2.6.14/info/gcl/Hash-Tables-Dictionary.html0000644000175000017500000001045214360276512017561 0ustar cammcamm Hash Tables Dictionary (ANSI and GNU Common Lisp Document)

Previous: , Up: Hash Tables  

18.2 Hash Tables Dictionary

• hash-table  
• make-hash-table  
• hash-table-p  
• hash-table-count  
• hash-table-rehash-size  
• hash-table-rehash-threshold  
• hash-table-size  
• hash-table-test  
• gethash  
• remhash  
• maphash  
• with-hash-table-iterator  
• clrhash  
• sxhash  
gcl-2.6.14/info/gcl/The-_0022Notes_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000562114360276512023725 0ustar cammcamm The "Notes" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.19 The "Notes" Section of a Dictionary Entry

Information not found elsewhere in this description which pertains to this operator. Among other things, this might include cross reference information, code equivalences, stylistic hints, implementation hints, typical uses. This information is not considered part of the standard; any conforming implementation or conforming program is permitted to ignore the presence of this information.

gcl-2.6.14/info/gcl/acons.html0000644000175000017500000000702414360276512014467 0ustar cammcamm acons (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.35 acons [Function]

acons key datum alist ⇒ new-alist

Arguments and Values::

key—an object.

datum—an object.

alist—an association list.

new-alist—an association list.

Description::

Creates a fresh cons, the cdr of which is alist and the car of which is another fresh cons, the car of which is key and the cdr of which is datum.

Examples::

 (setq alist '()) ⇒  NIL
 (acons 1 "one" alist) ⇒  ((1 . "one"))
 alist ⇒  NIL
 (setq alist (acons 1 "one" (acons 2 "two" alist))) ⇒  ((1 . "one") (2 . "two"))
 (assoc 1 alist) ⇒  (1 . "one")
 (setq alist (acons 1 "uno" alist)) ⇒  ((1 . "uno") (1 . "one") (2 . "two"))
 (assoc 1 alist) ⇒  (1 . "uno")

See Also::

assoc , pairlis

Notes::

(acons key datum alist) ≡ (cons (cons key datum) alist)
gcl-2.6.14/info/gcl/floating_002dpoint_002dunderflow.html0000644000175000017500000000473714360276512021451 0ustar cammcamm floating-point-underflow (ANSI and GNU Common Lisp Document)

Previous: , Up: Numbers Dictionary  

12.2.84 floating-point-underflow [Condition Type]

Class Precedence List::

floating-point-underflow, arithmetic-error, error, serious-condition, condition, t

Description::

The type floating-point-underflow consists of error conditions that occur because of floating-point underflow.

gcl-2.6.14/info/gcl/array_002ddimension.html0000644000175000017500000000651314360276512017137 0ustar cammcamm array-dimension (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.11 array-dimension [Function]

array-dimension array axis-number ⇒ dimension

Arguments and Values::

array—an array.

axis-number—an integer greater than or equal to zero and less than the rank of the array.

dimension—a non-negative integer.

Description::

array-dimension returns the axis-number dimension_1 of array. (Any fill pointer is ignored.)

Examples::

 (array-dimension (make-array 4) 0) ⇒  4
 (array-dimension (make-array '(2 3)) 1) ⇒  3

Affected By::

None.

See Also::

array-dimensions , length

Notes::

 (array-dimension array n) ≡ (nth n (array-dimensions array))
gcl-2.6.14/info/gcl/list_002dall_002dpackages.html0000644000175000017500000000566614360276512020013 0ustar cammcamm list-all-packages (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.7 list-all-packages [Function]

list-all-packages <no arguments> ⇒ packages

Arguments and Values::

packages—a list of package objects.

Description::

list-all-packages returns a

fresh

list of

all registered packages.

Examples::

 (let ((before (list-all-packages)))
    (make-package 'temp)
    (set-difference (list-all-packages) before)) ⇒  (#<PACKAGE "TEMP">)

Affected By::

defpackage, delete-package, make-package

gcl-2.6.14/info/gcl/Rules-about-Test-Functions.html0000644000175000017500000000503314360276512020447 0ustar cammcamm Rules about Test Functions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences  

17.2 Rules about Test Functions

• Satisfying a Two-Argument Test  
• Satisfying a One-Argument Test  
gcl-2.6.14/info/gcl/Introduction-to-Streams.html0000644000175000017500000001134114360276512020076 0ustar cammcamm Introduction to Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Stream Concepts  

21.1.1 Introduction to Streams

A stream is an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation. A character stream is a source or sink of characters. A binary stream is a source or sink of bytes.

Some operations may be performed on any kind of stream; Figure 21–1 provides a list of standardized operations that are potentially useful with any kind of stream. 

  close                 stream-element-type  
  input-stream-p        streamp              
  interactive-stream-p  with-open-stream     
  output-stream-p                            

  Figure 21–1: Some General-Purpose Stream Operations

Other operations are only meaningful on certain stream types. For example, read-char is only defined for character streams and read-byte is only defined for binary streams.

• Abstract Classifications of Streams (Introduction to Streams)  
• Input  
• Open and Closed Streams  
• Interactive Streams  
• Abstract Classifications of Streams  
• File Streams  
• Other Subclasses of Stream  
gcl-2.6.14/info/gcl/The-_0022Exceptional-Situations_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000634414360276512027253 0ustar cammcamm The "Exceptional Situations" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.14 The "Exceptional Situations" Section of a Dictionary Entry

Three kinds of information may appear here:

*

Situations that are detected by the function and formally signaled.

*

Situations that are handled by the function.

*

Situations that may be detected by the function.

This field does not include conditions that could be signaled by functions passed to and called by this operator as arguments or through dynamic variables, nor by executing subforms of this operator if it is a macro or special operator.

gcl-2.6.14/info/gcl/eval.html0000644000175000017500000001163314360276512014314 0ustar cammcamm eval (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.4 eval [Function]

eval form ⇒ {result}*

Arguments and Values::

form—a form.

results—the values yielded by the evaluation of form.

Description::

Evaluates form in the current dynamic environment and the null lexical environment.

eval is a user interface to the evaluator.

The evaluator expands macro calls as if through the use of macroexpand-1.

Constants appearing in code processed by eval are not copied nor coalesced. The code resulting from the execution of eval references objects that are eql to the corresponding objects in the source code.

Examples::

 (setq form '(1+ a) a 999) ⇒  999
 (eval form) ⇒  1000
 (eval 'form) ⇒  (1+ A)
 (let ((a '(this would break if eval used local value))) (eval form))
⇒  1000

See Also::

macroexpand-1, The Evaluation Model

Notes::

To obtain the current dynamic value of a symbol, use of symbol-value is equivalent (and usually preferable) to use of eval.

Note that an eval form involves two levels of evaluation for its argument. First, form is evaluated by the normal argument evaluation mechanism as would occur with any call. The object that results from this normal argument evaluation becomes the value of the form parameter, and is then evaluated as part of the eval form. For example: 

 (eval (list 'cdr (car '((quote (a . b)) c)))) ⇒  b

The argument form (list 'cdr (car '((quote (a . b)) c))) is evaluated in the usual way to produce the argument (cdr (quote (a . b))); eval then evaluates its argument, (cdr (quote (a . b))), to produce b. Since a single evaluation already occurs for any argument form in any function form, eval is sometimes said to perform “an extra level of evaluation.”

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/System-Construction-Concepts.html0000644000175000017500000000460714360276512021120 0ustar cammcamm System Construction Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction  

24.1 System Construction Concepts

• Loading  
• Features  
gcl-2.6.14/info/gcl/Right_002dParenthesis.html0000644000175000017500000000424214360276512017373 0ustar cammcamm Right-Parenthesis (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.2 Right-Parenthesis

The right-parenthesis is invalid except when used in conjunction with the left parenthesis character. For more information, see Reader Algorithm.

gcl-2.6.14/info/gcl/nthcdr.html0000644000175000017500000000675114360276512014654 0ustar cammcamm nthcdr (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.31 nthcdr [Function]

nthcdr n list ⇒ tail

Arguments and Values::

n—a non-negative integer.

list—a list,

which might be a dotted list or a circular list.

tail—an object.

Description::

Returns the tail of list that would be obtained by calling cdr n times in succession.

Examples::

 (nthcdr 0 '()) ⇒  NIL
 (nthcdr 3 '()) ⇒  NIL
 (nthcdr 0 '(a b c)) ⇒  (A B C)
 (nthcdr 2 '(a b c)) ⇒  (C)
 (nthcdr 4 '(a b c)) ⇒  ()
 (nthcdr 1 '(0 . 1)) ⇒  1

 (locally (declare (optimize (safety 3)))
   (nthcdr 3 '(0 . 1)))
 Error: Attempted to take CDR of 1.

Exceptional Situations::

Should signal an error of type type-error if n is not a non-negative integer.

For n being an integer greater than 1, the error checking done by (nthcdr n list) is the same as for (nthcdr (- n 1) (cdr list)); see the function cdr.

See Also::

cdr, nth , rest

gcl-2.6.14/info/gcl/Examples-of-Evaluation-of-Subforms-to-Places.html0000644000175000017500000000542714360276512023703 0ustar cammcamm Examples of Evaluation of Subforms to Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of Places and Generalized Reference  

5.1.1.2 Examples of Evaluation of Subforms to Places

 (let ((ref2 (list '())))
   (push (progn (princ "1") 'ref-1)
         (car (progn (princ "2") ref2)))) 
 |>  12
⇒  (REF1)

 (let (x)
    (push (setq x (list 'a))
          (car (setq x (list 'b))))
     x)
⇒  (((A) . B))

push first evaluates (setq x (list 'a)) ⇒ (a), then evaluates (setq x (list 'b)) ⇒ (b), then modifies the car of this latest value to be ((a) . b).

gcl-2.6.14/info/gcl/readtable_002dcase.html0000644000175000017500000000766514360276512016703 0ustar cammcamm readtable-case (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.7 readtable-case [Accessor]

readtable-case readtable ⇒ mode

(setf ( readtable-case readtable) mode)

Arguments and Values::

readtable—a readtable.

mode—a case sensitivity mode.

Description::

Accesses the readtable case of readtable, which affects the way in which the Lisp Reader reads symbols and the way in which the Lisp Printer writes symbols.

Examples::

See Examples of Effect of Readtable Case on the Lisp Reader and Examples of Effect of Readtable Case on the Lisp Printer.

Exceptional Situations::

Should signal an error of type type-error if readtable is not a readtable. Should signal an error of type type-error if mode is not a case sensitivity mode.

See Also::

readtable , *print-escape*, Reader Algorithm, Effect of Readtable Case on the Lisp Reader, Effect of Readtable Case on the Lisp Printer

Notes::

copy-readtable copies the readtable case of the readtable.

gcl-2.6.14/info/gcl/Interval-Designators.html0000644000175000017500000001033314360276512017425 0ustar cammcamm Interval Designators (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.6 Interval Designators

The compound type specifier form of the numeric type specifiers in Figure 12–10 permit the user to specify an interval on the real number line which describe a subtype of the type which would be described by the corresponding atomic type specifier. A subtype of some type T is specified using an ordered pair of objects called interval designators for type T.

The first of the two interval designators for type T can be any of the following:

a number N of type T

This denotes a lower inclusive bound of N. That is, elements of the subtype of T will be greater than or equal to N.

a singleton list whose element is

a number M of type T This denotes a lower exclusive bound of M. That is, elements of the subtype of T will be greater than M.

the symbol *

This denotes the absence of a lower bound on the interval.

The second of the two interval designators for type T can be any of the following:

a number N of type T

This denotes an upper inclusive bound of N. That is, elements of the subtype of T will be less than or equal to N.

a singleton list whose element is

a number M of type T This denotes an upper exclusive bound of M. That is, elements of the subtype of T will be less than M.

the symbol *

This denotes the absence of an upper bound on the interval.

Next: , Previous: , Up: Number Concepts  

gcl-2.6.14/info/gcl/_002aread_002ddefault_002dfloat_002dformat_002a.html0000644000175000017500000000753514360276512023355 0ustar cammcamm *read-default-float-format* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.14 *read-default-float-format* [Variable]

Value Type::

one of the atomic type specifiers short-float, single-float, double-float, or long-float, or else some other type specifier defined by the implementation to be acceptable.

Initial Value::

The symbol single-float.

Description::

Controls the floating-point format that is to be used when reading a floating-point number that has no exponent marker or that has e or E for an exponent marker. Other exponent markers explicitly prescribe the floating-point format to be used.

The printer uses *read-default-float-format* to guide the choice of exponent markers when printing floating-point numbers.

Examples::

 (let ((*read-default-float-format* 'double-float))
   (read-from-string "(1.0 1.0e0 1.0s0 1.0f0 1.0d0 1.0L0)"))
⇒  (1.0   1.0   1.0   1.0 1.0   1.0)   ;Implementation has float format F.
⇒  (1.0   1.0   1.0s0 1.0 1.0   1.0)   ;Implementation has float formats S and F.
⇒  (1.0d0 1.0d0 1.0   1.0 1.0d0 1.0d0) ;Implementation has float formats F and D.
⇒  (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0d0) ;Implementation has float formats S, F, D.
⇒  (1.0d0 1.0d0 1.0   1.0 1.0d0 1.0L0) ;Implementation has float formats F, D, L.
⇒  (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0L0) ;Implementation has formats S, F, D, L.
gcl-2.6.14/info/gcl/Printing-Other-Arrays.html0000644000175000017500000001202714360276512017473 0ustar cammcamm Printing Other Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.16 Printing Other Arrays

If *print-array* is true and *print-readably* is false, any

array other than a vector is printed using #nA format. Let n be the rank of the array. Then # is printed, then n as a decimal integer, then A, then n open parentheses. Next the elements are scanned in row-major order, using write on each element, and separating elements from each other with whitespace_1. The array’s dimensions are numbered 0 to n-1 from left to right, and are enumerated with the rightmost index changing fastest. Every time the index for dimension j is incremented, the following actions are taken:

*

If j < n-1, then a close parenthesis is printed.

*

If incrementing the index for dimension j caused it to equal dimension j, that index is reset to zero and the index for dimension j-1 is incremented (thereby performing these three steps recursively), unless j=0, in which case the entire algorithm is terminated. If incrementing the index for dimension j did not cause it to equal dimension j, then a space is printed.

*

If j < n-1, then an open parenthesis is printed.

This causes the contents to be printed in a format suitable for :initial-contents to make-array. The lists effectively printed by this procedure are subject to truncation by *print-level* and *print-length*.

If the array is of a specialized type, containing bits or characters, then the innermost lists generated by the algorithm given above can instead be printed using bit-vector or string syntax, provided that these innermost lists would not be subject to truncation by *print-length*.

If both *print-array* and *print-readably* are false,

then the array is printed in a format (using #<) that is concise but not readable.

If *print-readably* is true, the array prints in an implementation-defined manner; see the variable *print-readably*.

In particular, this may be important for arrays having some dimension 0.

For information on how the Lisp reader parses these “other arrays,” see Sharpsign A.

Next: , Previous: , Up: Default Print-Object Methods  

gcl-2.6.14/info/gcl/ensure_002dgeneric_002dfunction.html0000644000175000017500000001511114360276512021236 0ustar cammcamm ensure-generic-function (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.2 ensure-generic-function [Function]

ensure-generic-function function-name &key argument-precedence-order declare documentation environment generic-function-class lambda-list method-class method-combination
⇒ generic-function

Arguments and Values::

function-name—a function name.

The keyword arguments correspond to the option arguments of defgeneric, except that the :method-class and :generic-function-class arguments can be class objects as well as names.

Method-combination – method combination object.

Environment – the same as the &environment argument to macro expansion functions and is used to distinguish between compile-time and run-time environments.

[Editorial Note by KMP: What about documentation. Missing from this arguments enumeration, and confusing in description below.]

generic-function—a generic function object.

Description::

The function ensure-generic-function is used to define a globally named generic function with no methods or to specify or modify options and declarations that pertain to a globally named generic function as a whole.

If function-name is not fbound in the global environment, a new generic function is created. If

(fdefinition function-name)

is an ordinary function, a macro, or a special operator, an error is signaled.

If function-name is a list, it must be of the form (setf symbol). If function-name specifies a generic function that has a different value for any of the following arguments, the generic function is modified to have the new value: :argument-precedence-order, :declare, :documentation, :method-combination.

If function-name specifies a generic function that has a different value for the :lambda-list argument, and the new value is congruent with the lambda lists of all existing methods or there are no methods, the value is changed; otherwise an error is signaled.

If function-name specifies a generic function that has a different value for the :generic-function-class argument and if the new generic function class is compatible with the old, change-class is called to change the class of the generic function; otherwise an error is signaled.

If function-name specifies a generic function that has a different value for the :method-class argument, the value is changed, but any existing methods are not changed.

Affected By::

Existing function binding of function-name.

Exceptional Situations::

If

(fdefinition function-name)

is an ordinary function, a macro, or a special operator, an error of type error is signaled.

If function-name specifies a generic function that has a different value for the :lambda-list argument, and the new value is not congruent with the lambda list of any existing method, an error of type error is signaled.

If function-name specifies a generic function that has a different value for the :generic-function-class argument and if the new generic function class not is compatible with the old, an error of type error is signaled.

See Also::

defgeneric

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/load.html0000644000175000017500000002314714360276512014307 0ustar cammcamm load (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.3 load [Function]

load filespec &key verbose print if-does-not-exist external-format
⇒ generalized-boolean

Arguments and Values::

filespec—a stream, or a pathname designator. The default is taken from *default-pathname-defaults*.

verbose—a generalized boolean. The default is the value of *load-verbose*.

print—a generalized boolean. The default is the value of *load-print*.

if-does-not-exist—a generalized boolean. The default is true.

external-format—an external file format designator. The default is :default.

generalized-boolean—a generalized boolean.

Description::

load loads the file named by filespec into the Lisp environment.

The manner in which a source file is distinguished from a compiled file is implementation-dependent. If the file specification is not complete and both a source file and a compiled file exist which might match, then which of those files load selects is implementation-dependent.

If filespec is a stream, load determines what kind of stream it is and loads directly from the stream.

If filespec is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname.

load sequentially executes each form it encounters in the file named by filespec. If the file is a source file and the implementation chooses to perform implicit compilation, load must recognize top level forms as described in Processing of Top Level Forms and arrange for each top level form to be executed before beginning implicit compilation of the next. (Note, however, that processing of eval-when forms by load is controlled by the :execute situation.)

If verbose is true, load prints a message in the form of a comment (i.e., with a leading semicolon) to standard output indicating what file is being loaded and other useful information.

If verbose is false, load does not print this information.

If print is true, load incrementally prints information to standard output showing the progress of the loading process. For a source file, this information might mean printing the values yielded by each form in the file as soon as those values are returned. For a compiled file, what is printed might not reflect precisely the contents of the source file, but some information is generally printed. If print is false, load does not print this information.

If the file named by filespec is successfully loaded, load returns true.

[Reviewer Note by Loosemore: What happens if the file cannot be loaded for some reason other than that it doesn’t exist?] [Editorial Note by KMP: i.e., can it return NIL? must it?]

If the file does not exist, the specific action taken depends on if-does-not-exist: if it is nil, load returns nil; otherwise, load signals an error.

The external-format specifies the external file format to be used when opening the file (see the function open), except that when the file named by filespec is a compiled file, the external-format is ignored. compile-file and load cooperate in an implementation-dependent way to assure the preservation of the similarity of characters referred to in the source file at the time the source file was processed by the file compiler under a given external file format, regardless of the value of external-format at the time the compiled file is loaded.

load binds *readtable* and *package* to the values they held before loading the file.

*load-truename* is bound by load to hold the truename of the pathname of the file being loaded.

*load-pathname* is bound by load to hold a pathname that represents filespec merged against the defaults. That is, (pathname (merge-pathnames filespec)).

Examples::

;Establish a data file...
 (with-open-file (str "data.in" :direction :output :if-exists :error)
   (print 1 str) (print '(setq a 888) str) t)
⇒  T
 (load "data.in") ⇒  true
 a ⇒  888
 (load (setq p (merge-pathnames "data.in")) :verbose t)
; Loading contents of file /fred/data.in
; Finished loading /fred/data.in
⇒  true
 (load p :print t) 
; Loading contents of file /fred/data.in
;  1
;  888
; Finished loading /fred/data.in
⇒  true

 ;----[Begin file SETUP]----
 (in-package "MY-STUFF")
 (defmacro compile-truename () `',*compile-file-truename*)
 (defvar *my-compile-truename* (compile-truename) "Just for debugging.")
 (defvar *my-load-pathname* *load-pathname*)
 (defun load-my-system ()
   (dolist (module-name '("FOO" "BAR" "BAZ"))
     (load (merge-pathnames module-name *my-load-pathname*))))
 ;----[End of file SETUP]----

 (load "SETUP")
 (load-my-system)

Affected By::

The implementation, and the host computer’s file system.

Exceptional Situations::

If :if-does-not-exist is supplied and is true, or is not supplied, load signals an error of type file-error if the file named by filespec does not exist,

or if the file system cannot perform the requested operation.

An error of type file-error might be signaled if (wild-pathname-p filespec) returns true.

See Also::

error , merge-pathnames , *load-verbose*, *default-pathname-defaults*, pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Next: , Previous: , Up: System Construction Dictionary  

gcl-2.6.14/info/gcl/Special-Characters-in-Pathname-Components.html0000644000175000017500000000616214360276512023305 0ustar cammcamm Special Characters in Pathname Components (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.2 Special Characters in Pathname Components

Strings in pathname component values never contain special characters that represent separation between pathname fields, such as slash in Unix filenames. Whether separator characters are permitted as part of a string in a pathname component is implementation-defined; however, if the implementation does permit it, it must arrange to properly “quote” the character for the file system when constructing a namestring. For example, 

 ;; In a TOPS-20 implementation, which uses ^V to quote 
 (NAMESTRING (MAKE-PATHNAME :HOST "OZ" :NAME "<TEST>"))
⇒  #P"OZ:PS:^V<TEST^V>"
NOT⇒ #P"OZ:PS:<TEST>"
gcl-2.6.14/info/gcl/cons-_0028System-Class_0029.html0000644000175000017500000000767314360276512020010 0ustar cammcamm cons (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.3 cons [System Class]

Class Precedence List::

cons, list, sequence, t

Description::

A cons is a compound object having two components, called the car and cdr. These form a dotted pair. Each component can be any object.

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(cons{[car-typespec [cdr-typespec]]})

Compound Type Specifier Arguments::

car-typespec—a type specifier, or the symbol *. The default is the symbol *.

cdr-typespec—a type specifier, or the symbol *. The default is the symbol *.

Compound Type Specifier Description::

This denotes the set of conses whose car is constrained to be of type car-typespec and whose cdr is constrained to be of type cdr-typespec. (If either car-typespec or cdr-typespec is *, it is as if the type t had been denoted.)

See Also::

Left-Parenthesis, Printing Lists and Conses

gcl-2.6.14/info/gcl/base_002dstring.html0000644000175000017500000000655614360276512016263 0ustar cammcamm base-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.2 base-string [Type]

Supertypes::

base-string, string, vector, array, sequence, t

Description::

The type base-string is equivalent to

(vector base-char).

The base string representation is the most efficient string representation that can hold an arbitrary sequence of standard characters.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(base-string{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *.

Compound Type Specifier Description::

This is equivalent to the type (vector base-char size); that is, the set of base strings of size size.

gcl-2.6.14/info/gcl/stream_002derror.html0000644000175000017500000000551014360276512016454 0ustar cammcamm stream-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.55 stream-error [Condition Type]

Class Precedence List::

stream-error, error, serious-condition, condition, t

Description::

The type stream-error consists of error conditions that are related to receiving input from or sending output to a stream. The “offending stream” is initialized by the :stream initialization argument to make-condition, and is accessed by the function stream-error-stream.

See Also::

stream-error-stream

gcl-2.6.14/info/gcl/and.html0000644000175000017500000001126614360276512014131 0ustar cammcamm and (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.41 and [Macro]

and {form}* ⇒ {result}*

Arguments and Values::

form—a form.

results—the values resulting from the evaluation of the last form, or the symbols nil or t.

Description::

The macro and evaluates each form one at a time from left to right. As soon as any form evaluates to nil, and returns nil without evaluating the remaining forms. If all forms but the last evaluate to true values, and returns the results produced by evaluating the last form.

If no forms are supplied, (and) returns t.

and passes back multiple values from the last subform but not from subforms other than the last.

Examples::

 (if (and (>= n 0)
          (< n (length a-simple-vector))
          (eq (elt a-simple-vector n) 'foo))
     (princ "Foo!"))

The above expression prints Foo! if element n of a-simple-vector is the symbol foo, provided also that n is indeed a valid index for a-simple-vector. Because and guarantees left-to-right testing of its parts, elt is not called if n is out of range. 

 (setq temp1 1 temp2 1 temp3 1) ⇒  1 
 (and (incf temp1) (incf temp2) (incf temp3)) ⇒  2 
 (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)) ⇒  true
 (decf temp3) ⇒  1 
 (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)) ⇒  NIL 
 (and (eql temp1 temp2) (eql temp2 temp3)) ⇒  true
 (and) ⇒  T

See Also::

cond , every , if , or , when

Notes::

 (and form) ≡ (let () form)
 (and form1 form2 ...) ≡ (when form1 (and form2 ...))

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/inline.html0000644000175000017500000001551714360276512014650 0ustar cammcamm inline (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.22 inline, notinline [Declaration]

Syntax::

(inline {function-name}*)

(notinline {function-name}*)

Arguments::

function-name—a function name.

Valid Context::

declaration or proclamation

Binding Types Affected::

function

Description::

inline specifies that it is desirable for the compiler to produce inline calls to the functions named by function-names; that is, the code for a specified function-name

should be integrated into the calling routine, appearing “in line” in place of a procedure call. A compiler is free to ignore this declaration. inline declarations never apply to variable bindings.

If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition.

While no conforming implementation is required to perform inline expansion of user-defined functions, those implementations that do attempt to recognize the following paradigm:

To define a function f that is not inline by default but for which (declare (inline f)) will make f be locally inlined, the proper definition sequence is: 

 (declaim (inline f))
 (defun f ...)
 (declaim (notinline f))

The inline proclamation preceding the defun form ensures that the compiler has the opportunity save the information necessary for inline expansion, and the notinline proclamation following the defun form prevents f from being expanded inline everywhere.

notinline specifies that it is

undesirable to compile the functions named by function-names in-line. A compiler is not free to ignore this declaration; calls to the specified functions must be implemented as out-of-line subroutine calls.

If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition.

In the presence of a compiler macro definition for function-name, a notinline declaration prevents that

compiler macro from being used.

An inline declaration may be used to encourage use of compiler macro definitions. inline and notinline declarations otherwise have no effect when the lexically visible definition of function-name is a macro definition.

inline and notinline declarations can be free declarations or bound declarations. inline and notinline declarations of functions that appear before the body of a flet or labels

form that defines that function are bound declarations. Such declarations in other contexts are free declarations.

Examples::

 ;; The globally defined function DISPATCH should be open-coded,
 ;; if the implementation supports inlining, unless a NOTINLINE 
 ;; declaration overrides this effect.
 (declaim (inline dispatch))
 (defun dispatch (x) (funcall (get (car x) 'dispatch) x))
 ;; Here is an example where inlining would be encouraged.
 (defun top-level-1 () (dispatch (read-command)))
 ;; Here is an example where inlining would be prohibited.
 (defun top-level-2 ()
   (declare (notinline dispatch))
   (dispatch (read-command)))
 ;; Here is an example where inlining would be prohibited.
 (declaim (notinline dispatch))
 (defun top-level-3 () (dispatch (read-command)))
 ;; Here is an example where inlining would be encouraged.
 (defun top-level-4 () 
   (declare (inline dispatch))
   (dispatch (read-command)))

See Also::

declare, declaim , proclaim

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Symbols-in-the-COMMON_002dLISP-Package.html0000644000175000017500000011422214360276512021731 0ustar cammcamm Symbols in the COMMON-LISP Package (ANSI and GNU Common Lisp Document)

Previous: , Up: Introduction (Introduction)  

1.9 Symbols in the COMMON-LISP Package

The figures on the next twelve pages contain a complete enumeration of the 978 external symbols in the COMMON-LISP package. 

  &allow-other-keys            *print-miser-width*          
  &aux                         *print-pprint-dispatch*      
  &body                        *print-pretty*               
  &environment                 *print-radix*                
  &key                         *print-readably*             
  &optional                    *print-right-margin*         
  &rest                        *query-io*                   
  &whole                       *random-state*               
  *                            *read-base*                  
  **                           *read-default-float-format*  
  ***                          *read-eval*                  
  *break-on-signals*           *read-suppress*              
  *compile-file-pathname*      *readtable*                  
  *compile-file-truename*      *standard-input*             
  *compile-print*              *standard-output*            
  *compile-verbose*            *terminal-io*                
  *debug-io*                   *trace-output*               
  *debugger-hook*              +                            
  *default-pathname-defaults*  ++                           
  *error-output*               +++                          
  *features*                   -                            
  *gensym-counter*             /                            
  *load-pathname*              //                           
  *load-print*                 ///                          
  *load-truename*              /=                           
  *load-verbose*               1+                           
  *macroexpand-hook*           1-                           
  *modules*                    <                            
  *package*                    <=                           
  *print-array*                =                            
  *print-base*                 >                            
  *print-case*                 >=                           
  *print-circle*               abort                        
  *print-escape*               abs                          
  *print-gensym*               acons                        
  *print-length*               acos                         
  *print-level*                acosh                        
  *print-lines*                add-method                   

  Figure 1–4: Symbols in the COMMON-LISP package (part one of twelve).


  adjoin                      atom          boundp                    
  adjust-array                base-char     break                     
  adjustable-array-p          base-string   broadcast-stream          
  allocate-instance           bignum        broadcast-stream-streams  
  alpha-char-p                bit           built-in-class            
  alphanumericp               bit-and       butlast                   
  and                         bit-andc1     byte                      
  append                      bit-andc2     byte-position             
  apply                       bit-eqv       byte-size                 
  apropos                     bit-ior       caaaar                    
  apropos-list                bit-nand      caaadr                    
  aref                        bit-nor       caaar                     
  arithmetic-error            bit-not       caadar                    
  arithmetic-error-operands   bit-orc1      caaddr                    
  arithmetic-error-operation  bit-orc2      caadr                     
  array                       bit-vector    caar                      
  array-dimension             bit-vector-p  cadaar                    
  array-dimension-limit       bit-xor       cadadr                    
  array-dimensions            block         cadar                     
  array-displacement          boole         caddar                    
  array-element-type          boole-1       cadddr                    
  array-has-fill-pointer-p    boole-2       caddr                     
  array-in-bounds-p           boole-and     cadr                      
  array-rank                  boole-andc1   call-arguments-limit      
  array-rank-limit            boole-andc2   call-method               
  array-row-major-index       boole-c1      call-next-method          
  array-total-size            boole-c2      car                       
  array-total-size-limit      boole-clr     case                      
  arrayp                      boole-eqv     catch                     
  ash                         boole-ior     ccase                     
  asin                        boole-nand    cdaaar                    
  asinh                       boole-nor     cdaadr                    
  assert                      boole-orc1    cdaar                     
  assoc                       boole-orc2    cdadar                    
  assoc-if                    boole-set     cdaddr                    
  assoc-if-not                boole-xor     cdadr                     
  atan                        boolean       cdar                      
  atanh                       both-case-p   cddaar                    

  Figure 1–5: Symbols in the COMMON-LISP package (part two of twelve).


  cddadr             clear-input                  copy-tree                  
  cddar              clear-output                 cos                        
  cdddar             close                        cosh                       
  cddddr             clrhash                      count                      
  cdddr              code-char                    count-if                   
  cddr               coerce                       count-if-not               
  cdr                compilation-speed            ctypecase                  
  ceiling            compile                      debug                      
  cell-error         compile-file                 decf                       
  cell-error-name    compile-file-pathname        declaim                    
  cerror             compiled-function            declaration                
  change-class       compiled-function-p          declare                    
  char               compiler-macro               decode-float               
  char-code          compiler-macro-function      decode-universal-time      
  char-code-limit    complement                   defclass                   
  char-downcase      complex                      defconstant                
  char-equal         complexp                     defgeneric                 
  char-greaterp      compute-applicable-methods   define-compiler-macro      
  char-int           compute-restarts             define-condition           
  char-lessp         concatenate                  define-method-combination  
  char-name          concatenated-stream          define-modify-macro        
  char-not-equal     concatenated-stream-streams  define-setf-expander       
  char-not-greaterp  cond                         define-symbol-macro        
  char-not-lessp     condition                    defmacro                   
  char-upcase        conjugate                    defmethod                  
  char/=             cons                         defpackage                 
  char<              consp                        defparameter               
  char<=             constantly                   defsetf                    
  char=              constantp                    defstruct                  
  char>              continue                     deftype                    
  char>=             control-error                defun                      
  character          copy-alist                   defvar                     
  characterp         copy-list                    delete                     
  check-type         copy-pprint-dispatch         delete-duplicates          
  cis                copy-readtable               delete-file                
  class              copy-seq                     delete-if                  
  class-name         copy-structure               delete-if-not              
  class-of           copy-symbol                  delete-package             

    Figure 1–6: Symbols in the COMMON-LISP package (part three of twelve).  


  denominator                    eq                   
  deposit-field                  eql                  
  describe                       equal                
  describe-object                equalp               
  destructuring-bind             error                
  digit-char                     etypecase            
  digit-char-p                   eval                 
  directory                      eval-when            
  directory-namestring           evenp                
  disassemble                    every                
  division-by-zero               exp                  
  do                             export               
  do*                            expt                 
  do-all-symbols                 extended-char        
  do-external-symbols            fboundp              
  do-symbols                     fceiling             
  documentation                  fdefinition          
  dolist                         ffloor               
  dotimes                        fifth                
  double-float                   file-author          
  double-float-epsilon           file-error           
  double-float-negative-epsilon  file-error-pathname  
  dpb                            file-length          
  dribble                        file-namestring      
  dynamic-extent                 file-position        
  ecase                          file-stream          
  echo-stream                    file-string-length   
  echo-stream-input-stream       file-write-date      
  echo-stream-output-stream      fill                 
  ed                             fill-pointer         
  eighth                         find                 
  elt                            find-all-symbols     
  encode-universal-time          find-class           
  end-of-file                    find-if              
  endp                           find-if-not          
  enough-namestring              find-method          
  ensure-directories-exist       find-package         
  ensure-generic-function        find-restart         

  Figure 1–7: Symbols in the COMMON-LISP package (part four of twelve).


  find-symbol                       get-internal-run-time        
  finish-output                     get-macro-character          
  first                             get-output-stream-string     
  fixnum                            get-properties               
  flet                              get-setf-expansion           
  float                             get-universal-time           
  float-digits                      getf                         
  float-precision                   gethash                      
  float-radix                       go                           
  float-sign                        graphic-char-p               
  floating-point-inexact            handler-bind                 
  floating-point-invalid-operation  handler-case                 
  floating-point-overflow           hash-table                   
  floating-point-underflow          hash-table-count             
  floatp                            hash-table-p                 
  floor                             hash-table-rehash-size       
  fmakunbound                       hash-table-rehash-threshold  
  force-output                      hash-table-size              
  format                            hash-table-test              
  formatter                         host-namestring              
  fourth                            identity                     
  fresh-line                        if                           
  fround                            ignorable                    
  ftruncate                         ignore                       
  ftype                             ignore-errors                
  funcall                           imagpart                     
  function                          import                       
  function-keywords                 in-package                   
  function-lambda-expression        incf                         
  functionp                         initialize-instance          
  gcd                               inline                       
  generic-function                  input-stream-p               
  gensym                            inspect                      
  gentemp                           integer                      
  get                               integer-decode-float         
  get-decoded-time                  integer-length               
  get-dispatch-macro-character      integerp                     
  get-internal-real-time            interactive-stream-p         

  Figure 1–8: Symbols in the COMMON-LISP package (part five of twelve).


  intern                                  lisp-implementation-type            
  internal-time-units-per-second          lisp-implementation-version         
  intersection                            list                                
  invalid-method-error                    list*                               
  invoke-debugger                         list-all-packages                   
  invoke-restart                          list-length                         
  invoke-restart-interactively            listen                              
  isqrt                                   listp                               
  keyword                                 load                                
  keywordp                                load-logical-pathname-translations  
  labels                                  load-time-value                     
  lambda                                  locally                             
  lambda-list-keywords                    log                                 
  lambda-parameters-limit                 logand                              
  last                                    logandc1                            
  lcm                                     logandc2                            
  ldb                                     logbitp                             
  ldb-test                                logcount                            
  ldiff                                   logeqv                              
  least-negative-double-float             logical-pathname                    
  least-negative-long-float               logical-pathname-translations       
  least-negative-normalized-double-float  logior                              
  least-negative-normalized-long-float    lognand                             
  least-negative-normalized-short-float   lognor                              
  least-negative-normalized-single-float  lognot                              
  least-negative-short-float              logorc1                             
  least-negative-single-float             logorc2                             
  least-positive-double-float             logtest                             
  least-positive-long-float               logxor                              
  least-positive-normalized-double-float  long-float                          
  least-positive-normalized-long-float    long-float-epsilon                  
  least-positive-normalized-short-float   long-float-negative-epsilon         
  least-positive-normalized-single-float  long-site-name                      
  least-positive-short-float              loop                                
  least-positive-single-float             loop-finish                         
  length                                  lower-case-p                        
  let                                     machine-instance                    
  let*                                    machine-type                        

     Figure 1–9: Symbols in the COMMON-LISP package (part six of twelve).    


  machine-version                mask-field                  
  macro-function                 max                         
  macroexpand                    member                      
  macroexpand-1                  member-if                   
  macrolet                       member-if-not               
  make-array                     merge                       
  make-broadcast-stream          merge-pathnames             
  make-concatenated-stream       method                      
  make-condition                 method-combination          
  make-dispatch-macro-character  method-combination-error    
  make-echo-stream               method-qualifiers           
  make-hash-table                min                         
  make-instance                  minusp                      
  make-instances-obsolete        mismatch                    
  make-list                      mod                         
  make-load-form                 most-negative-double-float  
  make-load-form-saving-slots    most-negative-fixnum        
  make-method                    most-negative-long-float    
  make-package                   most-negative-short-float   
  make-pathname                  most-negative-single-float  
  make-random-state              most-positive-double-float  
  make-sequence                  most-positive-fixnum        
  make-string                    most-positive-long-float    
  make-string-input-stream       most-positive-short-float   
  make-string-output-stream      most-positive-single-float  
  make-symbol                    muffle-warning              
  make-synonym-stream            multiple-value-bind         
  make-two-way-stream            multiple-value-call         
  makunbound                     multiple-value-list         
  map                            multiple-value-prog1        
  map-into                       multiple-value-setq         
  mapc                           multiple-values-limit       
  mapcan                         name-char                   
  mapcar                         namestring                  
  mapcon                         nbutlast                    
  maphash                        nconc                       
  mapl                           next-method-p               
  maplist                        nil                         

  Figure 1–10: Symbols in the COMMON-LISP package (part seven of twelve).


  nintersection         package-error                  
  ninth                 package-error-package          
  no-applicable-method  package-name                   
  no-next-method        package-nicknames              
  not                   package-shadowing-symbols      
  notany                package-use-list               
  notevery              package-used-by-list           
  notinline             packagep                       
  nreconc               pairlis                        
  nreverse              parse-error                    
  nset-difference       parse-integer                  
  nset-exclusive-or     parse-namestring               
  nstring-capitalize    pathname                       
  nstring-downcase      pathname-device                
  nstring-upcase        pathname-directory             
  nsublis               pathname-host                  
  nsubst                pathname-match-p               
  nsubst-if             pathname-name                  
  nsubst-if-not         pathname-type                  
  nsubstitute           pathname-version               
  nsubstitute-if        pathnamep                      
  nsubstitute-if-not    peek-char                      
  nth                   phase                          
  nth-value             pi                             
  nthcdr                plusp                          
  null                  pop                            
  number                position                       
  numberp               position-if                    
  numerator             position-if-not                
  nunion                pprint                         
  oddp                  pprint-dispatch                
  open                  pprint-exit-if-list-exhausted  
  open-stream-p         pprint-fill                    
  optimize              pprint-indent                  
  or                    pprint-linear                  
  otherwise             pprint-logical-block           
  output-stream-p       pprint-newline                 
  package               pprint-pop                     

  Figure 1–11: Symbols in the COMMON-LISP package (part eight of twelve).


  pprint-tab                 read-char                   
  pprint-tabular             read-char-no-hang           
  prin1                      read-delimited-list         
  prin1-to-string            read-from-string            
  princ                      read-line                   
  princ-to-string            read-preserving-whitespace  
  print                      read-sequence               
  print-not-readable         reader-error                
  print-not-readable-object  readtable                   
  print-object               readtable-case              
  print-unreadable-object    readtablep                  
  probe-file                 real                        
  proclaim                   realp                       
  prog                       realpart                    
  prog*                      reduce                      
  prog1                      reinitialize-instance       
  prog2                      rem                         
  progn                      remf                        
  program-error              remhash                     
  progv                      remove                      
  provide                    remove-duplicates           
  psetf                      remove-if                   
  psetq                      remove-if-not               
  push                       remove-method               
  pushnew                    remprop                     
  quote                      rename-file                 
  random                     rename-package              
  random-state               replace                     
  random-state-p             require                     
  rassoc                     rest                        
  rassoc-if                  restart                     
  rassoc-if-not              restart-bind                
  ratio                      restart-case                
  rational                   restart-name                
  rationalize                return                      
  rationalp                  return-from                 
  read                       revappend                   
  read-byte                  reverse                     

  Figure 1–12: Symbols in the COMMON-LISP package (part nine of twelve).


  room                          simple-bit-vector                  
  rotatef                       simple-bit-vector-p                
  round                         simple-condition                   
  row-major-aref                simple-condition-format-arguments  
  rplaca                        simple-condition-format-control    
  rplacd                        simple-error                       
  safety                        simple-string                      
  satisfies                     simple-string-p                    
  sbit                          simple-type-error                  
  scale-float                   simple-vector                      
  schar                         simple-vector-p                    
  search                        simple-warning                     
  second                        sin                                
  sequence                      single-float                       
  serious-condition             single-float-epsilon               
  set                           single-float-negative-epsilon      
  set-difference                sinh                               
  set-dispatch-macro-character  sixth                              
  set-exclusive-or              sleep                              
  set-macro-character           slot-boundp                        
  set-pprint-dispatch           slot-exists-p                      
  set-syntax-from-char          slot-makunbound                    
  setf                          slot-missing                       
  setq                          slot-unbound                       
  seventh                       slot-value                         
  shadow                        software-type                      
  shadowing-import              software-version                   
  shared-initialize             some                               
  shiftf                        sort                               
  short-float                   space                              
  short-float-epsilon           special                            
  short-float-negative-epsilon  special-operator-p                 
  short-site-name               speed                              
  signal                        sqrt                               
  signed-byte                   stable-sort                        
  signum                        standard                           
  simple-array                  standard-char                      
  simple-base-string            standard-char-p                    

  Figure 1–13: Symbols in the COMMON-LISP package (part ten of twelve).


  standard-class             sublis                      
  standard-generic-function  subseq                      
  standard-method            subsetp                     
  standard-object            subst                       
  step                       subst-if                    
  storage-condition          subst-if-not                
  store-value                substitute                  
  stream                     substitute-if               
  stream-element-type        substitute-if-not           
  stream-error               subtypep                    
  stream-error-stream        svref                       
  stream-external-format     sxhash                      
  streamp                    symbol                      
  string                     symbol-function             
  string-capitalize          symbol-macrolet             
  string-downcase            symbol-name                 
  string-equal               symbol-package              
  string-greaterp            symbol-plist                
  string-left-trim           symbol-value                
  string-lessp               symbolp                     
  string-not-equal           synonym-stream              
  string-not-greaterp        synonym-stream-symbol       
  string-not-lessp           t                           
  string-right-trim          tagbody                     
  string-stream              tailp                       
  string-trim                tan                         
  string-upcase              tanh                        
  string/=                   tenth                       
  string<                    terpri                      
  string<=                   the                         
  string=                    third                       
  string>                    throw                       
  string>=                   time                        
  stringp                    trace                       
  structure                  translate-logical-pathname  
  structure-class            translate-pathname          
  structure-object           tree-equal                  
  style-warning              truename                    

  Figure 1–14: Symbols in the COMMON-LISP package (part eleven of twelve).


  truncate                             values-list               
  two-way-stream                       variable                  
  two-way-stream-input-stream          vector                    
  two-way-stream-output-stream         vector-pop                
  type                                 vector-push               
  type-error                           vector-push-extend        
  type-error-datum                     vectorp                   
  type-error-expected-type             warn                      
  type-of                              warning                   
  typecase                             when                      
  typep                                wild-pathname-p           
  unbound-slot                         with-accessors            
  unbound-slot-instance                with-compilation-unit     
  unbound-variable                     with-condition-restarts   
  undefined-function                   with-hash-table-iterator  
  unexport                             with-input-from-string    
  unintern                             with-open-file            
  union                                with-open-stream          
  unless                               with-output-to-string     
  unread-char                          with-package-iterator     
  unsigned-byte                        with-simple-restart       
  untrace                              with-slots                
  unuse-package                        with-standard-io-syntax   
  unwind-protect                       write                     
  update-instance-for-different-class  write-byte                
  update-instance-for-redefined-class  write-char                
  upgraded-array-element-type          write-line                
  upgraded-complex-part-type           write-sequence            
  upper-case-p                         write-string              
  use-package                          write-to-string           
  use-value                            y-or-n-p                  
  user-homedir-pathname                yes-or-no-p               
  values                               zerop                     

  Figure 1–15: Symbols in the COMMON-LISP package (part twelve of twelve).

Previous: , Up: Introduction (Introduction)  

gcl-2.6.14/info/gcl/Documentation-of-Extensions.html0000644000175000017500000000530014360276512020727 0ustar cammcamm Documentation of Extensions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conforming Implementations  

1.5.1.3 Documentation of Extensions

A conforming implementation shall be accompanied by a document that separately describes any features accepted by the implementation that are not specified in this standard, but that do not cause any ambiguity or contradiction when added to the language standard. Such extensions shall be described as being “extensions to Common Lisp as specified by ANSI <<standard number>>.”

gcl-2.6.14/info/gcl/trace.html0000644000175000017500000001367114360276512014467 0ustar cammcamm trace (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.8 trace, untrace [Macro]

trace {function-name}* ⇒ trace-result

untrace {function-name}* ⇒ untrace-result

Arguments and Values::

function-name—a function name.

trace-result—implementation-dependent, unless no function-names are supplied, in which case trace-result is a list of function names.

untrace-result—implementation-dependent.

Description::

trace and untrace control the invocation of the trace facility.

Invoking trace with one or more function-names causes the denoted functions to be “traced.” Whenever a traced function is invoked, information about the call, about the arguments passed, and about any eventually returned values is printed to trace output. If trace is used with no function-names, no tracing action is performed; instead, a list of the functions currently being traced is returned.

Invoking untrace with one or more function names causes those functions to be “untraced” (i.e., no longer traced). If untrace is used with no function-names, all functions currently being traced are untraced.

If a function to be traced has been open-coded (e.g., because it was declared inline), a call to that function might not produce trace output.

Examples::

 (defun fact (n) (if (zerop n) 1 (* n (fact (- n 1)))))
⇒  FACT
 (trace fact)
⇒  (FACT)
;; Of course, the format of traced output is implementation-dependent.
 (fact 3)
 |>  1 Enter FACT 3
 |>  | 2 Enter FACT 2
 |>  |   3 Enter FACT 1
 |>  |   | 4 Enter FACT 0
 |>  |   | 4 Exit FACT 1
 |>  |   3 Exit FACT 1
 |>  | 2 Exit FACT 2
 |>  1 Exit FACT 6
⇒  6

Side Effects::

Might change the definitions of the functions named by function-names.

Affected By::

Whether the functions named are defined or already being traced.

Exceptional Situations::

Tracing an already traced function, or untracing a function not currently being traced, should produce no harmful effects, but might signal a warning.

See Also::

*trace-output*, step

Notes::

trace and untrace may also accept additional implementation-dependent argument formats. The format of the trace output is implementation-dependent.

Although trace can be extended to permit non-standard options, implementations are nevertheless encouraged (but not required) to warn about the use of syntax or options that are neither specified by this standard nor added as an extension by the implementation, since they could be symptomatic of typographical errors or of reliance on features supported in implementations other than the current implementation.

Next: , Previous: , Up: Environment Dictionary  

gcl-2.6.14/info/gcl/Inheritance-of-Class-Options.html0000644000175000017500000000527714360276512020723 0ustar cammcamm Inheritance of Class Options (ANSI and GNU Common Lisp Document)

Previous: , Up: Inheritance  

4.3.4.2 Inheritance of Class Options

The :default-initargs class option is inherited. The set of defaulted initialization arguments for a class is the union of the sets of initialization arguments supplied in the :default-initargs class options of the class and its superclasses. When more than one default initial value form is supplied for a given initialization argument, the default initial value form that is used is the one supplied by the class that is most specific according to the class precedence list.

If a given :default-initargs class option specifies an initialization argument of the same name more than once, an error of type program-error is signaled.

gcl-2.6.14/info/gcl/cond.html0000644000175000017500000001030714360276512014305 0ustar cammcamm cond (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.42 cond [Macro]

cond {!clause}* ⇒ {result}*

clause ::=(test-form {form}*)

Arguments and Values::

test-form—a form.

forms—an implicit progn.

results—the values of the forms in the first clause whose test-form yields true, or the primary value of the test-form if there are no forms in that clause, or else nil if no test-form yields true.

Description::

cond allows the execution of forms to be dependent on test-form.

Test-forms are evaluated one at a time in the order in which they are given in the argument list until a test-form is found that evaluates to true.

If there are no forms in that clause, the primary value of the test-form is returned by the cond form. Otherwise, the forms associated with this test-form are evaluated in order, left to right, as an implicit progn, and the values returned by the last form are returned by the cond form.

Once one test-form has yielded true, no additional test-forms are evaluated. If no test-form yields true, nil is returned.

Examples::

 (defun select-options ()
   (cond ((= a 1) (setq a 2))
         ((= a 2) (setq a 3))
         ((and (= a 3) (floor a 2)))
         (t (floor a 3)))) ⇒  SELECT-OPTIONS
 (setq a 1) ⇒  1
 (select-options) ⇒  2
 a ⇒  2
 (select-options) ⇒  3
 a ⇒  3
 (select-options) ⇒  1
 (setq a 5) ⇒  5
 (select-options) ⇒  1, 2

See Also::

if , case .

gcl-2.6.14/info/gcl/slot_002dboundp.html0000644000175000017500000001062114360276512016277 0ustar cammcamm slot-boundp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.9 slot-boundp [Function]

slot-boundp instance slot-name ⇒ generalized-boolean

Arguments and Values::

instance—an object.

slot-name—a symbol naming a slot of instance.

generalized-boolean—a generalized boolean.

Description::

Returns true if the slot named slot-name in instance is bound; otherwise, returns false.

Exceptional Situations::

If no slot of the name slot-name exists in the instance, slot-missing is called as follows: 

 (slot-missing (class-of instance)
               instance
               slot-name
               'slot-boundp)

(If slot-missing is invoked and returns a value, a boolean equivalent to its primary value is returned by slot-boundp.)

The specific behavior depends on instance’s metaclass. An error is never signaled if instance has metaclass standard-class. An error is always signaled if instance has metaclass built-in-class. The consequences are undefined if instance has any other metaclass–an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified.

See Also::

slot-makunbound , slot-missing

Notes::

The function slot-boundp allows for writing after methods on initialize-instance in order to initialize only those slots that have not already been bound.

Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-boundp using the function slot-boundp-using-class described in the Metaobject Protocol.

gcl-2.6.14/info/gcl/defmacro.html0000644000175000017500000002377114360276512015153 0ustar cammcamm defmacro (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.10 defmacro [Macro]

defmacro name lambda-list [[{declaration}* | documentation]] {form}*
⇒ name

Arguments and Values::

name—a symbol.

lambda-list—a macro lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

Description::

Defines name as a macro by associating a macro function with that name in the global environment.

The macro function is defined in the same lexical environment in which the defmacro form appears.

The parameter variables in lambda-list are bound to destructured portions of the macro call.

The expansion function accepts two arguments, a form and an environment. The expansion function returns a form. The body of the expansion function is specified by forms. Forms are executed in order. The value of the last form executed is returned as the expansion of the macro.

The body forms of the expansion function (but not the lambda-list)

are implicitly enclosed in a block whose name is name.

The lambda-list conforms to the requirements described in Macro Lambda Lists.

Documentation is attached as a documentation string to name (as kind function) and to the macro function.

defmacro can be used to redefine a macro or to replace a function definition with a macro definition.

Recursive expansion of the form returned must terminate, including the expansion of other macros which are subforms of other forms returned.

The consequences are undefined if the result of fully macroexpanding a form contains any circular list structure except in literal objects.

If a defmacro form appears as a top level form, the compiler must store the macro definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Users must ensure that the body of the macro can be evaluated at compile time if it is referenced within the file being compiled.

Examples::

 (defmacro mac1 (a b) "Mac1 multiplies and adds" 
            `(+ ,a (* ,b 3))) ⇒  MAC1 
 (mac1 4 5) ⇒  19 
 (documentation 'mac1 'function) ⇒  "Mac1 multiplies and adds" 
 (defmacro mac2 (&optional (a 2 b) (c 3 d) &rest x) `'(,a ,b ,c ,d ,x)) ⇒  MAC2 
 (mac2 6) ⇒  (6 T 3 NIL NIL) 
 (mac2 6 3 8) ⇒  (6 T 3 T (8)) 
 (defmacro mac3 (&whole r a &optional (b 3) &rest x &key c (d a))
    `'(,r ,a ,b ,c ,d ,x)) ⇒  MAC3 
 (mac3 1 6 :d 8 :c 9 :d 10) ⇒  ((MAC3 1 6 :D 8 :C 9 :D 10) 1 6 9 8 (:D 8 :C 9 :D 10))

The stipulation that an embedded destructuring lambda list is permitted only where ordinary lambda list syntax would permit a parameter name but not a list is made to prevent ambiguity. For example, the following is not valid: 

 (defmacro loser (x &optional (a b &rest c) &rest z)
   ...)

because ordinary lambda list syntax does permit a list following &optional; the list (a b &rest c) would be interpreted as describing an optional parameter named a whose default value is that of the form b, with a supplied-p parameter named &rest (not valid), and an extraneous symbol c in the list (also not valid). An almost correct way to express this is 

 (defmacro loser (x &optional ((a b &rest c)) &rest z)
   ...)

The extra set of parentheses removes the ambiguity. However, the definition is now incorrect because a macro call such as (loser (car pool)) would not provide any argument form for the lambda list (a b &rest c), and so the default value against which to match the lambda list would be nil because no explicit default value was specified. The consequences of this are unspecified since the empty list, nil, does not have forms to satisfy the parameters a and b. The fully correct definition would be either 

 (defmacro loser (x &optional ((a b &rest c) '(nil nil)) &rest z)
   ...)

or 

 (defmacro loser (x &optional ((&optional a b &rest c)) &rest z)
   ...)

These differ slightly: the first requires that if the macro call specifies a explicitly then it must also specify b explicitly, whereas the second does not have this requirement. For example, 

 (loser (car pool) ((+ x 1)))

would be a valid call for the second definition but not for the first. 

 (defmacro dm1a (&whole x) `',x)
 (macroexpand '(dm1a))  ⇒  (QUOTE (DM1A))
 (macroexpand '(dm1a a)) is an error.

 (defmacro dm1b (&whole x a &optional b) `'(,x ,a ,b))
 (macroexpand '(dm1b))  is an error.
 (macroexpand '(dm1b q))  ⇒  (QUOTE ((DM1B Q) Q NIL))
 (macroexpand '(dm1b q r)) ⇒  (QUOTE ((DM1B Q R) Q R))
 (macroexpand '(dm1b q r s)) is an error.

 (defmacro dm2a (&whole form a b) `'(form ,form a ,a b ,b))
 (macroexpand '(dm2a x y)) ⇒  (QUOTE (FORM (DM2A X Y) A X B Y))
 (dm2a x y) ⇒  (FORM (DM2A X Y) A X B Y)

 (defmacro dm2b (&whole form a (&whole b (c . d) &optional (e 5)) 
                 &body f &environment env)
   ``(,',form ,,a ,',b ,',(macroexpand c env) ,',d ,',e ,',f))
 ;Note that because backquote is involved, implementations may differ
 ;slightly in the nature (though not the functionality) of the expansion.
 (macroexpand '(dm2b x1 (((incf x2) x3 x4)) x5 x6))
 ⇒  (LIST* '(DM2B X1 (((INCF X2) X3 X4))
                   X5 X6)
            X1
            '((((INCF X2) X3 X4)) (SETQ X2 (+ X2 1)) (X3 X4) 5 (X5 X6))),
     T
 (let ((x1 5))
   (macrolet ((segundo (x) `(cadr ,x)))
     (dm2b x1 (((segundo x2) x3 x4)) x5 x6)))
 ⇒  ((DM2B X1 (((SEGUNDO X2) X3 X4)) X5 X6)
      5 (((SEGUNDO X2) X3 X4)) (CADR X2) (X3 X4) 5 (X5 X6))

See Also::

define-compiler-macro ,

destructuring-bind , documentation , macroexpand , *macroexpand-hook*, macrolet, macro-function , Evaluation, Compilation, Syntactic Interaction of Documentation Strings and Declarations

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Types-and-Classes.html0000644000175000017500000000527714360276512016633 0ustar cammcamm Types and Classes (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

4 Types and Classes

• Introduction (Types and Classes)  
• Types  
• Classes  
• Types and Classes Dictionary  
gcl-2.6.14/info/gcl/Initial-and-Final-Execution.html0000644000175000017500000000744114360276512020510 0ustar cammcamm Initial and Final Execution (ANSI and GNU Common Lisp Document)

Previous: , Up: Miscellaneous Clauses  

6.1.7.3 Initial and Final Execution

The initially and finally constructs evaluate forms that occur before and after the loop body.

The initially construct causes the supplied compound-forms to be evaluated in the loop prologue, which precedes all loop code except for initial settings supplied by constructs with, for, or as. The code for any initially clauses is executed in the order in which the clauses appeared in the loop.

The finally construct causes the supplied compound-forms to be evaluated in the loop epilogue after normal iteration terminates. The code for any finally clauses is executed in the order in which the clauses appeared in the loop. The collected code is executed once in the loop epilogue before any implicit values are returned from the accumulation clauses. An explicit transfer of control (e.g., by return, go, or throw) from the loop body, however, will exit the loop without executing the epilogue code.

Clauses such as return, always, never, and thereis can bypass the finally clause.

return (or return-from, if the named option was supplied)

can be used after finally to return values from a loop.

Such an explicit return

inside the finally clause takes precedence over returning the accumulation from clauses supplied by such keywords as collect, nconc, append, sum, count, maximize, and minimize; the accumulation values for these preempted clauses are not returned by loop if return or return-from is used.

././@LongLink0000644000000000000000000000015700000000000011606 Lustar rootrootgcl-2.6.14/info/gcl/Some-Exceptions-to-Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Programs.htmlgcl-2.6.14/info/gcl/Some-Exceptions-to-Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Pro0000644000175000017500000001102714360276512030733 0ustar cammcamm Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.4 Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs

If an external symbol of the COMMON-LISP package is not globally defined as a standardized dynamic variable or constant variable, it is allowed to lexically bind it and to declare the type of that binding, and it is allowed to locally establish it as a symbol macro (e.g., with symbol-macrolet).

Unless explicitly specified otherwise, if an external symbol of the COMMON-LISP package is globally defined as a standardized dynamic variable, it is permitted to bind or assign that dynamic variable provided that the “Value Type” constraints on the dynamic variable are maintained, and that the new value of the variable is consistent with the stated purpose of the variable.

If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind it as a function (e.g., with flet), to declare the ftype of that binding, and (in implementations which provide the ability to do so) to trace that binding.

If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind it as a macro (e.g., with macrolet).

If an external symbol of the COMMON-LISP package is not defined as a standardized function, macro, or special operator, it is allowed to lexically bind its setf function name as a function, and to declare the ftype of that binding.

gcl-2.6.14/info/gcl/Invalid-Characters.html0000644000175000017500000000471014360276512017026 0ustar cammcamm Invalid Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.3 Invalid Characters

Characters with the constituent trait invalid cannot ever appear in a token except under the control of a single escape character. If an invalid character is encountered while an object is being read, an error of type reader-error is signaled. If an invalid character is preceded by a single escape character, it is treated as an alphabetic_2 constituent instead.

gcl-2.6.14/info/gcl/define_002dmodify_002dmacro.html0000644000175000017500000001323314360276512020321 0ustar cammcamm define-modify-macro (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.60 define-modify-macro [Macro]

define-modify-macro name lambda-list function [documentation] ⇒ name

Arguments and Values::

name—a symbol.

lambda-list—a define-modify-macro lambda list

function—a symbol.

documentation—a string; not evaluated.

Description::

define-modify-macro defines a macro named name to read and write a place.

The arguments to the new macro are a place, followed by the arguments that are supplied in lambda-list.

Macros defined with define-modify-macro correctly pass the environment parameter to

get-setf-expansion.

When the macro is invoked, function is applied to the old contents of the place and the lambda-list arguments to obtain the new value, and the place is updated to contain the result.

Except for the issue of avoiding multiple evaluation (see below), the expansion of a define-modify-macro is equivalent to the following: 

 (defmacro name (reference . lambda-list)
   documentation
   `(setf ,reference
          (function ,reference ,arg1 ,arg2 ...)))

where arg1, arg2, ..., are the parameters appearing in lambda-list; appropriate provision is made for a rest parameter.

The subforms of the macro calls defined by define-modify-macro are evaluated as specified in Evaluation of Subforms to Places.

Documentation is attached as a documentation string to name (as kind function) and to the macro function.

If a define-modify-macro form appears as a top level form, the compiler must store the macro definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly.

Examples::

 (define-modify-macro appendf (&rest args) 
    append "Append onto list") ⇒  APPENDF
 (setq x '(a b c) y x) ⇒  (A B C)
 (appendf x '(d e f) '(1 2 3)) ⇒  (A B C D E F 1 2 3)
 x ⇒  (A B C D E F 1 2 3)
 y ⇒  (A B C)
 (define-modify-macro new-incf (&optional (delta 1)) +)
 (define-modify-macro unionf (other-set &rest keywords) union)

Side Effects::

A macro definition is assigned to name.

See Also::

defsetf ,

define-setf-expander ,

documentation , Syntactic Interaction of Documentation Strings and Declarations

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Symbols-as-Tokens.html0000644000175000017500000001726114360276512016662 0ustar cammcamm Symbols as Tokens (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpretation of Tokens  

2.3.4 Symbols as Tokens

Any token that is not a potential number, does not contain a package marker, and does not consist entirely of dots will always be interpreted as a symbol. Any token that is a potential number but does not fit the number syntax is a reserved token and has an implementation-dependent interpretation. In all other cases, the token is construed to be the name of a symbol.

Examples of the printed representation of symbols are in Figure 2–15. For presentational simplicity, these examples assume that the readtable case of the current readtable is :upcase. 

  FROBBOZ         The symbol whose name is FROBBOZ.                
  frobboz         Another way to notate the same symbol.           
  fRObBoz         Yet another way to notate it.                    
  unwind-protect  A symbol with a hyphen in its name.              
  +$             The symbol named +$.                            
  1+              The symbol named 1+.                             
  +1              This is the integer 1, not a symbol.             
  pascal_style    This symbol has an underscore in its name.       
  file.rel.43     This symbol has periods in its name.             
  \(              The symbol whose name is (.                      
  \+1             The symbol whose name is +1.                     
  +\1             Also the symbol whose name is +1.                
  \frobboz        The symbol whose name is fROBBOZ.                
  3.14159265\s0   The symbol whose name is 3.14159265s0.           
  3.14159265\S0   A different symbol, whose name is 3.14159265S0.  
  3.14159265s0    A possible short float approximation to \pi.     

  Figure 2–15: Examples of the printed representation of symbols (Part 1 of 2)


  APL\\360               The symbol whose name is APL\360.       
  apl\\360               Also the symbol whose name is APL\360.  
  \(b^2\)\ -\ 4*a*c    The name is (B^2) - 4*A*C.            
                         Parentheses and two spaces in it.       
  \(\b^2\)\ -\4*\a*\c  The name is (b^2) - 4*a*c.            
                         Letters explicitly lowercase.           
  |"|                    The same as writing \".                 
  |(b^2) - 4*a*c|      The name is (b^2) - 4*a*c.            
  |frobboz|              The name is frobboz, not FROBBOZ.       
  |APL\360|              The name is APL360.                     
  |APL\\360|             The name is APL\360.                    
  |apl\\360|             The name is apl\360.                    
  |\|\||                 Same as \|\| —the name is ||.          
  |(B^2) - 4*A*C|      The name is (B^2) - 4*A*C.            
                         Parentheses and two spaces in it.       
  |(b^2) - 4*a*c|      The name is (b^2) - 4*a*c.            

  Figure 2–16: Examples of the printed representation of symbols (Part 2 of 2)

In the process of parsing a symbol, it is implementation-dependent which implementation-defined attributes are removed from the characters forming a token that represents a symbol.

When parsing the syntax for a symbol, the Lisp reader looks up the name of that symbol in the current package. This lookup may involve looking in other packages whose external symbols are inherited by the current package. If the name is found, the corresponding symbol is returned. If the name is not found (that is, there is no symbol of that name accessible in the current package), a new symbol is created and is placed in the current package as an internal symbol. The current package becomes the owner (home package) of the symbol, and the symbol becomes interned in the current package. If the name is later read again while this same package is current, the same symbol will be found and returned.

Next: , Previous: , Up: Interpretation of Tokens  

gcl-2.6.14/info/gcl/_002d_003eUNSPECIFIC-as-a-Component-Value.html0000644000175000017500000000725414360276512022126 0ustar cammcamm ->UNSPECIFIC as a Component Value (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.9 :UNSPECIFIC as a Component Value

If :unspecific is the value of a pathname component, the component is considered to be “absent” or to “have no meaning” in the filename being represented by the pathname.

Whether a value of :unspecific is permitted for any component on any given file system accessible to the implementation is implementation-defined. A conforming program must never unconditionally use a :unspecific as the value of a pathname component because such a value is not guaranteed to be permissible in all implementations. However, a conforming program can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable pathname components. And certainly a conforming program should be prepared for the possibility that any components of a pathname could be :unspecific.

When reading_1 the value of any pathname component, conforming programs should be prepared for the value to be :unspecific.

When writing_1 the value of any pathname component, the consequences are undefined if :unspecific is given for a pathname in a file system for which it does not make sense.

gcl-2.6.14/info/gcl/Removed-Variables.html0000644000175000017500000000516514360276512016677 0ustar cammcamm Removed Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Removed Language Features  

27.1.5 Removed Variables

The variables

char-font-limit , char-bits-limit , char-control-bit , char-meta-bit , char-super-bit , char-hyper-bit ,

and *break-on-warnings*

were removed.

gcl-2.6.14/info/gcl/delete_002dpackage.html0000644000175000017500000002036414360276512016671 0ustar cammcamm delete-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.11 delete-package [Function]

delete-package package ⇒ generalized-boolean

Arguments and Values::

package—a package designator.

generalized-boolean—a generalized boolean.

Description::

delete-package deletes package from all package system data structures. If the operation is successful, delete-package returns true, otherwise nil. The effect of delete-package is that the name and nicknames of package cease to be recognized package names. The package object is still a package (i.e., packagep is true of it) but package-name returns nil. The consequences of deleting the COMMON-LISP package or the KEYWORD package are undefined. The consequences of invoking any other package operation on package once it has been deleted are unspecified. In particular, the consequences of invoking find-symbol, intern and other functions that look for a symbol name in a package are unspecified if they are called with *package* bound to the deleted package or with the deleted package as an argument.

If package is a package object that has already been deleted, delete-package immediately returns nil.

After this operation completes, the home package of any symbol whose home package had previously been package is implementation-dependent. Except for this, symbols accessible in package are not modified in any other way; symbols whose home package is not package remain unchanged.

Examples::

 (setq *foo-package* (make-package "FOO" :use nil))
 (setq *foo-symbol*  (intern "FOO" *foo-package*))
 (export *foo-symbol* *foo-package*)

 (setq *bar-package* (make-package "BAR" :use '("FOO")))
 (setq *bar-symbol*  (intern "BAR" *bar-package*))
 (export *foo-symbol* *bar-package*)
 (export *bar-symbol* *bar-package*)

 (setq *baz-package* (make-package "BAZ" :use '("BAR")))

 (symbol-package *foo-symbol*) ⇒  #<PACKAGE "FOO">
 (symbol-package *bar-symbol*) ⇒  #<PACKAGE "BAR">

 (prin1-to-string *foo-symbol*) ⇒  "FOO:FOO"
 (prin1-to-string *bar-symbol*) ⇒  "BAR:BAR"

 (find-symbol "FOO" *bar-package*) ⇒  FOO:FOO, :EXTERNAL

 (find-symbol "FOO" *baz-package*) ⇒  FOO:FOO, :INHERITED
 (find-symbol "BAR" *baz-package*) ⇒  BAR:BAR, :INHERITED

 (packagep *foo-package*) ⇒  true
 (packagep *bar-package*) ⇒  true
 (packagep *baz-package*) ⇒  true

 (package-name *foo-package*) ⇒  "FOO"
 (package-name *bar-package*) ⇒  "BAR"
 (package-name *baz-package*) ⇒  "BAZ"

 (package-use-list *foo-package*) ⇒  ()
 (package-use-list *bar-package*) ⇒  (#<PACKAGE "FOO">)
 (package-use-list *baz-package*) ⇒  (#<PACKAGE "BAR">)

 (package-used-by-list *foo-package*) ⇒  (#<PACKAGE "BAR">)
 (package-used-by-list *bar-package*) ⇒  (#<PACKAGE "BAZ">)
 (package-used-by-list *baz-package*) ⇒  ()

 (delete-package *bar-package*)
 |>  Error: Package BAZ uses package BAR.
 |>  If continued, BAZ will be made to unuse-package BAR,
 |>  and then BAR will be deleted.
 |>  Type :CONTINUE to continue.
 |>  Debug> |>>:CONTINUE<<|
⇒  T

 (symbol-package *foo-symbol*) ⇒  #<PACKAGE "FOO">
 (symbol-package *bar-symbol*) is unspecified

 (prin1-to-string *foo-symbol*) ⇒  "FOO:FOO"
 (prin1-to-string *bar-symbol*) is unspecified

 (find-symbol "FOO" *bar-package*) is unspecified

 (find-symbol "FOO" *baz-package*) ⇒  NIL, NIL
 (find-symbol "BAR" *baz-package*) ⇒  NIL, NIL

 (packagep *foo-package*) ⇒  T
 (packagep *bar-package*) ⇒  T
 (packagep *baz-package*) ⇒  T

 (package-name *foo-package*) ⇒  "FOO"
 (package-name *bar-package*) ⇒  NIL
 (package-name *baz-package*) ⇒  "BAZ"

 (package-use-list *foo-package*) ⇒  ()
 (package-use-list *bar-package*) is unspecified
 (package-use-list *baz-package*) ⇒  ()

 (package-used-by-list *foo-package*) ⇒  ()
 (package-used-by-list *bar-package*) is unspecified
 (package-used-by-list *baz-package*) ⇒  ()

Exceptional Situations::

If the package designator is a name that does not currently name a package, a correctable error of type package-error is signaled. If correction is attempted, no deletion action is attempted; instead, delete-package immediately returns nil.

If package is used by other packages, a correctable error of type package-error is signaled. If correction is attempted, unuse-package is effectively called to remove any dependencies, causing package’s external symbols to cease being accessible to those packages that use package. delete-package then deletes package just as it would have had there been no packages that used it.

See Also::

unuse-package

Next: , Previous: , Up: Packages Dictionary  

gcl-2.6.14/info/gcl/with_002dopen_002dfile.html0000644000175000017500000001535714360276512017343 0ustar cammcamm with-open-file (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.31 with-open-file [macro]

Syntax::

with-open-file (stream filespec {options}*) {declaration}* {form}*
⇒ results

Arguments and Values::

stream – a variable.

filespec—a pathname designator.

options – forms; evaluated.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

with-open-file uses open to create a file stream

to file named by filespec. Filespec is the name of the file to be opened. Options are used as keyword arguments to open.

The stream object to which the stream variable is bound has dynamic extent; its extent ends when the form is exited.

with-open-file evaluates the forms as an implicit progn with stream bound to

the value returned by open.

When control leaves the body, either normally or abnormally (such as by use of throw), the file is automatically closed. If a new output file is being written, and control leaves abnormally, the file is aborted and the file system is left, so far as possible, as if the file had never been opened.

It is possible by the use of :if-exists nil or :if-does-not-exist nil for stream to be bound to nil.

Users of :if-does-not-exist nil should check for a valid stream.

The consequences are undefined if an attempt is made to assign the stream variable. The compiler may choose to issue a warning if such an attempt is detected.

Examples::

 (setq p (merge-pathnames "test"))
⇒  #<PATHNAME :HOST NIL :DEVICE device-name :DIRECTORY directory-name
    :NAME "test" :TYPE NIL :VERSION :NEWEST>
 (with-open-file (s p :direction :output :if-exists :supersede)
    (format s "Here are a couple~
 (with-open-file (s p)
    (do ((l (read-line s) (read-line s nil 'eof)))
        ((eq l 'eof) "Reached end of file.")
     (format t "~&*** ~A~
 |>  *** Here are a couple
 |>  *** of test data lines
⇒  "Reached end of file."

;; Normally one would not do this intentionally because it is
;; not perspicuous, but beware when using :IF-DOES-NOT-EXIST NIL
;; that this doesn't happen to you accidentally...
 (with-open-file (foo "no-such-file" :if-does-not-exist nil)
   (read foo))
 |>  |>>hello?<<|
⇒  HELLO? ;This value was read from the terminal, not a file!

;; Here's another bug to avoid...
 (with-open-file (foo "no-such-file" :direction :output :if-does-not-exist nil)
   (format foo "Hello"))
⇒  "Hello" ;FORMAT got an argument of NIL!

Side Effects::

Creates a stream to the file named by filename (upon entry), and closes the stream (upon exit). In some implementations, the file might be locked in some way while it is open. If the stream is an output stream, a file might be created.

Affected By::

The host computer’s file system.

Exceptional Situations::

See the function open.

See Also::

open , close , pathname, logical-pathname,

Pathnames as Filenames

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/assert.html0000644000175000017500000001714514360276512014672 0ustar cammcamm assert (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.10 assert [Macro]

assert test-form [({place}*) [datum-form {argument-form}*]]
⇒ nil

Arguments and Values::

test-form—a form; always evaluated.

place—a place; evaluated if an error is signaled.

datum-form—a form that evaluates to a datum. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled.

argument-form—a form that evaluates to an argument. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled.

datum, arguments—designators for a condition of default type error. (These designators are the result of evaluating datum-form and each of the argument-forms.)

Description::

assert assures that test-form evaluates to true. If test-form evaluates to false, assert signals a correctable error (denoted by datum and arguments). Continuing from this error using the continue restart makes it possible for the user to alter the values of the places before assert evaluates test-form again. If the value of test-form is non-nil, assert returns nil.

The places are generalized references to data upon which test-form depends, whose values can be changed by the user in attempting to correct the error. Subforms of each place are only evaluated if an error is signaled, and might be re-evaluated if the error is re-signaled (after continuing without actually fixing the problem).

The order of evaluation of the places is not specified; see Evaluation of Subforms to Places.

If a place form is supplied that produces more values than there are store variables, the extra values are ignored. If the supplied form produces fewer values than there are store variables, the missing values are set to nil.

Examples::

 (setq x (make-array '(3 5) :initial-element 3))
⇒  #2A((3 3 3 3 3) (3 3 3 3 3) (3 3 3 3 3))
 (setq y (make-array '(3 5) :initial-element 7))
⇒  #2A((7 7 7 7 7) (7 7 7 7 7) (7 7 7 7 7))
 (defun matrix-multiply (a b)
   (let ((*print-array* nil))
     (assert (and (= (array-rank a) (array-rank b) 2)
                  (= (array-dimension a 1) (array-dimension b 0)))
             (a b)
             "Cannot multiply ~S by ~S." a b)
            (really-matrix-multiply a b))) ⇒  MATRIX-MULTIPLY
 (matrix-multiply x y)
 |>  Correctable error in MATRIX-MULTIPLY: 
 |>  Cannot multiply #<ARRAY ...> by #<ARRAY ...>.
 |>  Restart options:
 |>   1: You will be prompted for one or more new values.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Value for A: |>>x<<|
 |>  Value for B: |>>(make-array '(5 3) :initial-element 6)<<|
⇒  #2A((54 54 54 54 54)
       (54 54 54 54 54)
       (54 54 54 54 54)
       (54 54 54 54 54)
       (54 54 54 54 54))

 (defun double-safely (x) (assert (numberp x) (x)) (+ x x))
 (double-safely 4) 
⇒  8

 (double-safely t)
 |>  Correctable error in DOUBLE-SAFELY: The value of (NUMBERP X) must be non-NIL.
 |>  Restart options:
 |>   1: You will be prompted for one or more new values.
 |>   2: Top level.
 |>  Debug> |>>:continue 1<<|
 |>  Value for X: |>>7<<|
⇒  14

Affected By::

*break-on-signals*

The set of active condition handlers.

See Also::

check-type , error , Generalized Reference

Notes::

The debugger need not include the test-form in the error message, and the places should not be included in the message, but they should be made available for the user’s perusal. If the user gives the “continue” command, the values of any of the references can be altered. The details of this depend on the implementation’s style of user interface.

Next: , Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/Required-Kinds-of-Specialized-Arrays.html0000644000175000017500000001001714360276512022301 0ustar cammcamm Required Kinds of Specialized Arrays (ANSI and GNU Common Lisp Document)

Previous: , Up: Specialized Arrays  

15.1.2.2 Required Kinds of Specialized Arrays

Vectors whose elements are restricted to type

character or a subtype of character

are called strings . Strings are of type string. Figure 15–2 lists some defined names related to strings.

Strings are specialized arrays and might logically have been included in this chapter. However, for purposes of readability most information about strings does not appear in this chapter; see instead Strings. 

  char                string-equal         string-upcase  
  make-string         string-greaterp      string/=       
  nstring-capitalize  string-left-trim     string<        
  nstring-downcase    string-lessp         string<=       
  nstring-upcase      string-not-equal     string=        
  schar               string-not-greaterp  string>        
  string              string-not-lessp     string>=       
  string-capitalize   string-right-trim                   
  string-downcase     string-trim                         

      Figure 15–2: Operators that Manipulate Strings

Vectors whose elements are restricted to type bit are called bit vectors . Bit vectors are of type bit-vector. Figure 15–3 lists some defined names for operations on bit arrays. 

  bit        bit-ior   bit-orc2  
  bit-and    bit-nand  bit-xor   
  bit-andc1  bit-nor   sbit      
  bit-andc2  bit-not             
  bit-eqv    bit-orc1            

  Figure 15–3: Operators that Manipulate Bit Arrays
gcl-2.6.14/info/gcl/dynamic_002dextent.html0000644000175000017500000002406014360276512016764 0ustar cammcamm dynamic-extent (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.20 dynamic-extent [Declaration]

Syntax::

(dynamic-extent [[{var}* | (function fn)*]])

Arguments::

var—a variable name.

fn—a function name.

Valid Context::

declaration

Binding Types Affected::

variable, function

Description::

In some containing form, F, this declaration asserts for each var_i (which need not be bound by F), and for each value v_{ij} that var_i takes on, and for each object x_{ijk} that is an otherwise inaccessible part of v_{ij} at any time when v_{ij} becomes the value of var_i, that just after the execution of F terminates, x_{ijk} is either inaccessible (if F established a binding for var_i) or still an otherwise inaccessible part of the current value of var_i (if F did not establish a binding for var_i).

The same relation holds for each fn_i, except that the bindings are in the function namespace.

The compiler is permitted to use this information in any way that is appropriate to the implementation and that does not conflict with the semantics of Common Lisp.

dynamic-extent declarations can be free declarations or bound declarations.

The vars and fns named in a dynamic-extent declaration must not refer to symbol macro or macro bindings.

Examples::

Since stack allocation of the initial value entails knowing at the object’s creation time that the object can be stack-allocated, it is not generally useful to make a dynamic-extent declaration for variables which have no lexically apparent initial value. For example, it is probably useful to write: 

 (defun f ()
   (let ((x (list 1 2 3)))
     (declare (dynamic-extent x))
         ...))

This would permit those compilers that wish to do so to stack allocate the list held by the local variable x. It is permissible, but in practice probably not as useful, to write: 

 (defun g (x) (declare (dynamic-extent x)) ...)
 (defun f () (g (list 1 2 3)))

Most compilers would probably not stack allocate the argument to g in f because it would be a modularity violation for the compiler to assume facts about g from within f. Only an implementation that was willing to be responsible for recompiling f if the definition of g changed incompatibly could legitimately stack allocate the list argument to g in f.

Here is another example: 

 (declaim (inline g))
 (defun g (x) (declare (dynamic-extent x)) ...)
 (defun f () (g (list 1 2 3)))

 (defun f ()
   (flet ((g (x) (declare (dynamic-extent x)) ...))
     (g (list 1 2 3))))

In the previous example, some compilers might determine that optimization was possible and others might not.

A variant of this is the so-called “stack allocated rest list” that can be achieved (in implementations supporting the optimization) by: 

 (defun f (&rest x)
   (declare (dynamic-extent x))
   ...)

Note that although the initial value of x is not explicit, the f function is responsible for assembling the list x from the passed arguments, so the f function can be optimized by the compiler to construct a stack-allocated list instead of a heap-allocated list in implementations that support such.

In the following example, 

 (let ((x (list 'a1 'b1 'c1))
       (y (cons 'a2 (cons 'b2 (cons 'c2 nil)))))
   (declare (dynamic-extent x y))
   ...)

The otherwise inaccessible parts of x are three conses, and the otherwise inaccessible parts of y are three other conses. None of the symbols a1, b1, c1, a2, b2, c2, or nil is an otherwise inaccessible part of x or y because each is interned and hence accessible by the package (or packages) in which it is interned. However, if a freshly allocated uninterned symbol had been used, it would have been an otherwise inaccessible part of the list which contained it. 

;; In this example, the implementation is permitted to stack allocate
;; the list that is bound to X.
 (let ((x (list 1 2 3)))
   (declare (dynamic-extent x))
   (print x)
   :done)
 |>  (1 2 3)
⇒  :DONE

;; In this example, the list to be bound to L can be stack-allocated.
 (defun zap (x y z)
   (do ((l (list x y z) (cdr l)))
       ((null l))
     (declare (dynamic-extent l))
     (prin1 (car l)))) ⇒  ZAP
 (zap 1 2 3)
 |>  123
⇒  NIL

;; Some implementations might open-code LIST-ALL-PACKAGES in a way
;; that permits using stack allocation of the list to be bound to L.
 (do ((l (list-all-packages) (cdr l)))
     ((null l))
   (declare (dynamic-extent l))
   (let ((name (package-name (car l))))
     (when (string-search "COMMON-LISP" name) (print name))))
 |>  "COMMON-LISP"
 |>  "COMMON-LISP-USER"
⇒  NIL

;; Some implementations might have the ability to stack allocate 
;; rest lists.  A declaration such as the following should be a cue
;; to such implementations that stack-allocation of the rest list
;; would be desirable.
 (defun add (&rest x)
   (declare (dynamic-extent x))
   (apply #'+ x)) ⇒  ADD
 (add 1 2 3) ⇒  6

 (defun zap (n m)
   ;; Computes (RANDOM (+ M 1)) at relative speed of roughly O(N).
   ;; It may be slow, but with a good compiler at least it
   ;; doesn't waste much heap storage.  :-}
   (let ((a (make-array n)))
     (declare (dynamic-extent a))
     (dotimes (i n) 
       (declare (dynamic-extent i))
       (setf (aref a i) (random (+ i 1))))
     (aref a m))) ⇒  ZAP
 (< (zap 5 3) 3) ⇒  true

The following are in error, since the value of x is used outside of its extent: 

 (length (list (let ((x (list 1 2 3)))  ; Invalid
                (declare (dynamic-extent x))
                x)))

 (progn (let ((x (list 1 2 3)))  ; Invalid
          (declare (dynamic-extent x))
          x)
        nil)

See Also::

declare

Notes::

The most common optimization is to stack allocate the initial value of the objects named by the vars.

It is permissible for an implementation to simply ignore this declaration.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/signed_002dbyte.html0000644000175000017500000000671714360276512016256 0ustar cammcamm signed-byte (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.9 signed-byte [Type]

Supertypes::

signed-byte, integer, rational,

real,

number, t

Description::

The atomic type specifier signed-byte denotes the same type as is denoted by the type specifier integer; however, the list forms of these two type specifiers have different semantics.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(signed-byte{[s | *]})

Compound Type Specifier Arguments::

s—a positive integer.

Compound Type Specifier Description::

This denotes the set of integers that can be represented in two’s-complement form in a byte of s bits. This is equivalent to (integer -2^s-1 2^s-1-1). The type signed-byte or the type (signed-byte *) is the same as the type integer.

gcl-2.6.14/info/gcl/char_002dupcase.html0000644000175000017500000001215714360276512016232 0ustar cammcamm char-upcase (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.14 char-upcase, char-downcase [Function]

char-upcase character ⇒ corresponding-character

char-downcase character ⇒ corresponding-character

Arguments and Values::

character, corresponding-character—a character.

Description::

If character is a lowercase character, char-upcase returns the corresponding uppercase character. Otherwise, char-upcase just returns the given character.

If character is an uppercase character, char-downcase returns the corresponding lowercase character. Otherwise, char-downcase just returns the given character.

The result only ever differs from character in its code attribute; all implementation-defined attributes are preserved.

Examples::

 (char-upcase #\a) ⇒  #\A
 (char-upcase #\A) ⇒  #\A
 (char-downcase #\a) ⇒  #\a
 (char-downcase #\A) ⇒  #\a
 (char-upcase #\9) ⇒  #\9
 (char-downcase #\9) ⇒  #\9
 (char-upcase #\@) ⇒  #\@
 (char-downcase #\@) ⇒  #\@
 ;; Note that this next example might run for a very long time in 
 ;; some implementations if CHAR-CODE-LIMIT happens to be very large
 ;; for that implementation.
 (dotimes (code char-code-limit)
   (let ((char (code-char code)))
     (when char
       (unless (cond ((upper-case-p char) (char= (char-upcase (char-downcase char)) char))
                     ((lower-case-p char) (char= (char-downcase (char-upcase char)) char))
                     (t (and (char= (char-upcase (char-downcase char)) char)
                             (char= (char-downcase (char-upcase char)) char))))
         (return char)))))
⇒  NIL

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

See Also::

upper-case-p , alpha-char-p , Characters With Case, Documentation of Implementation-Defined Scripts

Notes::

If the corresponding-char is different than character, then both the character and the corresponding-char have case.

Since char-equal ignores the case of the characters it compares, the corresponding-character is always the same as character under char-equal.

gcl-2.6.14/info/gcl/Case-in-Symbols.html0000644000175000017500000000663214360276512016275 0ustar cammcamm Case in Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.8 Case in Symbols

While case is significant in the process of interning a symbol, the Lisp reader, by default, attempts to canonicalize the case of a symbol prior to interning; see Effect of Readtable Case on the Lisp Reader. As such, case in symbols is not, by default, significant. Throughout this document, except as explicitly noted otherwise, the case in which a symbol appears is not significant; that is, HELLO, Hello, hElLo, and hello are all equivalent ways to denote a symbol whose name is "HELLO".

The characters backslash and vertical-bar are used to explicitly quote the case and other parsing-related aspects of characters. As such, the notations |hello| and \h\e\l\l\o are equivalent ways to refer to a symbol whose name is "hello", and which is distinct from any symbol whose name is "HELLO".

The symbols that correspond to Common Lisp defined names have uppercase names even though their names generally appear in lowercase in this document.

gcl-2.6.14/info/gcl/adjustable_002darray_002dp.html0000644000175000017500000000647214360276512020201 0ustar cammcamm adjustable-array-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.9 adjustable-array-p [Function]

adjustable-array-p array ⇒ generalized-boolean

Arguments and Values::

array—an array.

generalized-boolean—a generalized boolean.

Description::

Returns true if and only if adjust-array could return a value which is identical to array when given that array as its first argument.

Examples::

 (adjustable-array-p 
   (make-array 5
               :element-type 'character 
               :adjustable t 
               :fill-pointer 3)) ⇒  true
 (adjustable-array-p (make-array 4)) ⇒  implementation-dependent

Exceptional Situations::

Should signal an error of type type-error if its argument is not an array.

See Also::

adjust-array , make-array

gcl-2.6.14/info/gcl/symbol_002dmacrolet.html0000644000175000017500000001511514360276512017145 0ustar cammcamm symbol-macrolet (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.14 symbol-macrolet [Special Operator]

symbol-macrolet ({(symbol expansion )}*) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

symbol—a symbol.

expansion—a form.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

symbol-macrolet provides a mechanism for affecting the macro expansion environment for symbols.

symbol-macrolet lexically establishes expansion functions for each of the symbol macros named by symbols.

The only guaranteed property of an expansion function for a symbol macro is that when it is applied to the form and the environment it returns the correct expansion. (In particular, it is implementation-dependent whether the expansion is conceptually stored in the expansion function, the environment, or both.)

Each reference to symbol as a variable within the lexical scope of symbol-macrolet is expanded by the normal macro expansion process; see Symbols as Forms. The expansion of a symbol macro is subject to further macro expansion in the same lexical environment as the symbol macro invocation, exactly analogous to normal macros.

Exactly the same declarations are allowed as for let with one exception: symbol-macrolet signals an error if a special declaration names one of the symbols being defined by symbol-macrolet.

When the forms of the symbol-macrolet form are expanded, any use of setq to set the value of one of the specified variables is treated as if it were a setf. psetq of a symbol defined as a symbol macro is treated as if it were a psetf, and multiple-value-setq is treated as if it were a setf of values.

The use of symbol-macrolet can be shadowed by let. In other words, symbol-macrolet only substitutes for occurrences of symbol that would be in the scope of a lexical binding of symbol surrounding the forms.

Examples::

;;; The following is equivalent to
;;;   (list 'foo (let ((x 'bar)) x)),
;;; not
;;;   (list 'foo (let (('foo 'bar)) 'foo))
 (symbol-macrolet ((x 'foo))
   (list x (let ((x 'bar)) x))) 
⇒  (foo bar)
NOT⇒ (foo foo) 

 (symbol-macrolet ((x '(foo x)))
   (list x))
⇒  ((FOO X))

Exceptional Situations::

If an attempt is made to bind a symbol that is defined as a global variable, an error of type program-error is signaled.

If declaration contains a special declaration that names one of the symbols being bound by symbol-macrolet, an error of type program-error is signaled.

See Also::

with-slots , macroexpand

Notes::

The special form symbol-macrolet is the basic mechanism that is used to implement with-slots.

If a symbol-macrolet form is a top level form, the forms are also processed as top level forms. See File Compilation.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/disassemble.html0000644000175000017500000000751014360276512015657 0ustar cammcamm disassemble (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.14 disassemble [Function]

disassemble fn ⇒ nil

Arguments and Values::

fn—an extended function designator or a lambda expression.

Description::

The function disassemble is a debugging aid that composes symbolic instructions or expressions in some implementation-dependent language which represent the code used to produce the function which is or is named by the argument fn. The result is displayed to standard output in an implementation-dependent format.

If fn is a lambda expression or interpreted function, it is compiled first and the result is disassembled.

If the fn designator is a function name, the function that it names is disassembled.

(If that function is an interpreted function, it is first compiled but the result of this implicit compilation is not installed.)

Examples::

 (defun f (a) (1+ a)) ⇒  F
 (eq (symbol-function 'f)
     (progn (disassemble 'f)
            (symbol-function 'f))) ⇒  true

Affected By::

*standard-output*.

Exceptional Situations::

Should signal an error of type type-error if fn is not an extended function designator or a lambda expression.

gcl-2.6.14/info/gcl/Symbols-Naming-Both-Lexical-and-Dynamic-Variables.html0000644000175000017500000000550414360276512024525 0ustar cammcamm Symbols Naming Both Lexical and Dynamic Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.6 Symbols Naming Both Lexical and Dynamic Variables

The same symbol can name both a lexical variable and a dynamic variable, but never in the same lexical environment.

In the following example, the symbol x is used, at different times, as the name of a lexical variable and as the name of a dynamic variable. 

 (let ((x 1))            ;Binds a special variable X
   (declare (special x))
   (let ((x 2))          ;Binds a lexical variable X
     (+ x                ;Reads a lexical variable X
        (locally (declare (special x))
                 x))))   ;Reads a special variable X
⇒  3
gcl-2.6.14/info/gcl/Parsing-Loop-Clauses.html0000644000175000017500000000720614360276512017275 0ustar cammcamm Parsing Loop Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.5 Parsing Loop Clauses

The syntactic parts of an extended loop form are called clauses; the rules for parsing are determined by that clause’s keyword. The following example shows a loop form with six clauses: 

 (loop for i from 1 to (compute-top-value)       ; first clause
       while (not (unacceptable i))              ; second clause
       collect (square i)                        ; third clause
       do (format t "Working on ~D now" i)       ; fourth clause
       when (evenp i)                            ; fifth clause
         do (format t "~D is a non-odd number" i)
       finally (format t "About to exit!"))      ; sixth clause

Each loop keyword introduces either a compound loop clause or a simple loop clause that can consist of a loop keyword followed by a single form. The number of forms in a clause is determined by the loop keyword that begins the clause and by the auxiliary keywords in the clause. The keywords do,

doing,

initially, and finally are the only loop keywords that can take any number of forms and group them as an implicit progn.

Loop clauses can contain auxiliary keywords, which are sometimes called prepositions. For example, the first clause in the code above includes the prepositions from and to, which mark the value from which stepping begins and the value at which stepping ends.

For detailed information about loop syntax, see the macro loop.

gcl-2.6.14/info/gcl/The-_0022See-Also_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000000526414360276512024250 0ustar cammcamm The "See Also" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.21 The "See Also" Section of a Dictionary Entry

List of references to other parts of this standard that offer information relevant to this operator. This list is not part of the standard.

gcl-2.6.14/info/gcl/defstruct.html0000644000175000017500000015250314360276512015372 0ustar cammcamm defstruct (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Structures Dictionary  

8.1.1 defstruct [Macro]

defstruct name-and-options [documentation] {!slot-description}*
⇒ structure-name

name-and-options ::=structure-name | (structure-name [[!options]])

options ::=!conc-name-option |             {!constructor-option}* |             !copier-option |             !include-option |             !initial-offset-option |             !named-option |             !predicate-option |             !printer-option |             !type-option

conc-name-option ::=:conc-name | (:conc-name) | (:conc-name conc-name)

constructor-option ::=:constructor |                        (:constructor) |                        (:constructor constructor-name) |                        (:constructor constructor-name constructor-arglist)

copier-option ::=:copier | (:copier) | (:copier copier-name)

predicate-option ::=:predicate | (:predicate) | (:predicate predicate-name)

include-option ::=(:include included-structure-name {!slot-description}*)

printer-option ::=!print-object-option | !print-function-option

print-object-option ::=(:print-object printer-name) | (:print-object)

print-function-option ::=(:print-function printer-name) | (:print-function)

type-option ::=(:type type)

named-option ::=:named

initial-offset-option ::=(:initial-offset initial-offset)

slot-description ::=slot-name |                       (slot-name [slot-initform [[!slot-option]]])

slot-option ::=:type slot-type |                  :read-only slot-read-only-p

Arguments and Values::

conc-name—a string designator.

constructor-arglist—a boa lambda list.

constructor-name—a symbol.

copier-name—a symbol.

included-structure-name—an already-defined structure name.

Note that a derived type is not permissible, even if it would expand into a structure name.

initial-offset—a non-negative integer.

predicate-name—a symbol.

printer-name—a function name or a lambda expression.

slot-name—a symbol.

slot-initform—a form.

slot-read-only-p—a generalized boolean.

structure-name—a symbol.

type—one of the type specifiers list, vector, or (vector size), or some other type specifier defined by the implementation to be appropriate.

documentation—a string; not evaluated.

Description::

defstruct defines a structured type, named structure-type, with named slots as specified by the slot-options.

defstruct defines readers for the slots and arranges for setf to work properly on such reader functions. Also, unless overridden, it defines a predicate named name-p, defines a constructor function named make-constructor-name, and defines a copier function named copy-constructor-name. All names of automatically created functions might automatically be declared inline (at the discretion of the implementation).

If documentation is supplied, it is attached to structure-name as a documentation string of kind structure,

and unless :type is used, the documentation is also attached to structure-name as a documentation string of kind type and as a documentation string to the class object for the class named structure-name.

defstruct defines a constructor function that is used to create instances of the structure created by defstruct. The default name is make-structure-name. A different name can be supplied by giving the name as the argument to the constructor option. nil indicates that no constructor function will be created.

After a new structure type has been defined, instances of that type normally can be created by using the constructor function for the type. A call to a constructor function is of the following form:

 (constructor-function-name
  slot-keyword-1 form-1
  slot-keyword-2 form-2
  ...)

The arguments to the constructor function are all keyword arguments. Each slot keyword argument must be a keyword whose name corresponds to the name of a structure slot. All the keywords and forms are evaluated. If a slot is not initialized in this way, it is initialized by evaluating slot-initform in the slot description

at the time the constructor function is called.

If no slot-initform is supplied, the consequences are undefined if an attempt is later made to read the slot’s value before a value is explicitly assigned.

Each slot-initform supplied for a defstruct component, when used by the constructor function for an otherwise unsupplied component, is re-evaluated on every call to the constructor function.

The slot-initform is not evaluated unless it is needed in the creation of a particular structure instance. If it is never needed, there can be no type-mismatch error, even if the type of the slot is specified; no warning should be issued in this case.

For example, in the following sequence, only the last call is an error. 

 (defstruct person (name 007 :type string)) 
 (make-person :name "James")
 (make-person)

It is as if the slot-initforms were used as initialization forms for the keyword parameters of the constructor function.

The symbols which name the slots must not be used by the implementation as the names for the lambda variables in the constructor function, since one or more of those symbols might have been proclaimed special or might be defined as the name of a constant variable. The slot default init forms are evaluated in the lexical environment in which the defstruct form itself appears and in the dynamic environment in which the call to the constructor function appears.

For example, if the form (gensym) were used as an initialization form, either in the constructor-function call or as the default initialization form in defstruct, then every call to the constructor function would call gensym once to generate a new symbol.

Each slot-description in defstruct can specify zero or more slot-options.

A slot-option consists of a pair of a keyword and a value (which is not a form to be evaluated, but the value itself). For example: 

 (defstruct ship
   (x-position 0.0 :type short-float)
   (y-position 0.0 :type short-float)
   (x-velocity 0.0 :type short-float)
   (y-velocity 0.0 :type short-float)
   (mass *default-ship-mass* :type short-float :read-only t))

This specifies that each slot always contains a short float, and that the last slot cannot be altered once a ship is constructed.

The available slot-options are:

:type type

This specifies that the contents of the slot is always of type type. This is entirely analogous to the declaration of a variable or function; it effectively declares the result type of the reader function. It is implementation-dependent whether the type is checked when initializing a slot or when assigning to it. Type is not evaluated; it must be a valid type specifier.

:read-only x

When x is true, this specifies that this slot cannot be altered; it will always contain the value supplied at construction time. setf will not accept the reader function for this slot. If x is false, this slot-option has no effect. X is not evaluated.

When this option is false or unsupplied, it is implementation-dependent whether the ability to write the slot is implemented by a setf function or a setf expander.

The following keyword options are available for use with defstruct. A defstruct option can be either a keyword or a list of a keyword and arguments for that keyword; specifying the keyword by itself is equivalent to specifying a list consisting of the keyword and no arguments. The syntax for defstruct options differs from the pair syntax used for slot-options. No part of any of these options is evaluated.

:conc-name

This provides for automatic prefixing of names of reader (or access) functions. The default behavior is to begin the names of all the reader functions of a structure with the name of the structure followed by a hyphen.

:conc-name supplies an alternate prefix to be used. If a hyphen is to be used as a separator, it must be supplied as part of the prefix. If :conc-name is nil or no argument is supplied, then no prefix is used; then the names of the reader functions are the same as the slot names. If a non-nil prefix is given, the name of the reader function for each slot is constructed by concatenating that prefix and the name of the slot, and interning the resulting symbol in the package that is current at the time the defstruct form is expanded.

Note that no matter what is supplied for :conc-name, slot keywords that match the slot names with no prefix attached are used with a constructor function. The reader function name is used in conjunction with setf. Here is an example: 

 (defstruct (door (:conc-name dr-)) knob-color width material) ⇒  DOOR
 (setq my-door (make-door :knob-color 'red :width 5.0)) 
⇒  #S(DOOR :KNOB-COLOR RED :WIDTH 5.0 :MATERIAL NIL)
 (dr-width my-door) ⇒  5.0
 (setf (dr-width my-door) 43.7) ⇒  43.7
 (dr-width my-door) ⇒  43.7

Whether or not the :conc-name option is explicitly supplied, the following rule governs name conflicts of generated reader (or accessor) names: For any structure type S_1 having a reader function named R for a slot named X_1 that is inherited by another structure type S_2 that would have a reader function with the same name R for a slot named X_2, no definition for R is generated by the definition of S_2; instead, the definition of R is inherited from the definition of S_1. (In such a case, if X_1 and X_2 are different slots, the implementation might signal a style warning.)

:constructor

This option takes zero, one, or two arguments. If at least one argument is supplied and the first argument is not nil, then that argument is a symbol which specifies the name of the constructor function. If the argument is not supplied (or if the option itself is not supplied), the name of the constructor is produced by concatenating the string "MAKE-" and the name of the structure, interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no constructor function is defined.

If :constructor is given as (:constructor name arglist), then instead of making a keyword driven constructor function, defstruct defines a “positional” constructor function, taking arguments whose meaning is determined by the argument’s position and possibly by keywords. Arglist is used to describe what the arguments to the constructor will be. In the simplest case something like (:constructor make-foo (a b c)) defines make-foo to be a three-argument constructor function whose arguments are used to initialize the slots named a, b, and c.

Because a constructor of this type operates “By Order of Arguments,” it is sometimes known as a “boa constructor.”

For information on how the arglist for a “boa constructor” is processed, see Boa Lambda Lists.

It is permissible to use the :constructor option more than once, so that you can define several different constructor functions, each taking different parameters.

[Reviewer Note by Barmar: What about (:constructor) and (:constructor nil). Should we worry about it?]

defstruct creates the default-named keyword constructor function only if no explicit :constructor options are specified, or if the :constructor option is specified without a name argument.

(:constructor nil) is meaningful only when there are no other :constructor options specified. It prevents defstruct from generating any constructors at all.

Otherwise, defstruct creates a constructor function corresponding to each supplied :constructor option. It is permissible to specify multiple keyword constructor functions as well as multiple “boa constructors”.

:copier

This option takes one argument, a symbol, which specifies the name of the copier function. If the argument is not provided or if the option itself is not provided, the name of the copier is produced by concatenating the string "COPY-" and the name of the structure, interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no copier function is defined.

The automatically defined copier function is a function of one argument,

which must be of the structure type being defined.

The copier function creates a fresh structure that has the same type as its argument, and that has the same component values as the original structure; that is, the component values are not copied recursively.

If the defstruct :type option was not used, the following equivalence applies: 

 (copier-name x) = (copy-structure (the structure-name x))
:include

This option is used for building a new structure definition as an extension of another structure definition. For example: 

 (defstruct person name age sex)

To make a new structure to represent an astronaut that has the attributes of name, age, and sex, and functions that operate on person structures, astronaut is defined with :include as follows: 

 (defstruct (astronaut (:include person)
                       (:conc-name astro-))
    helmet-size
    (favorite-beverage 'tang))

:include causes the structure being defined to have the same slots as the included structure. This is done in such a way that the reader functions for the included structure also work on the structure being defined. In this example, an astronaut therefore has five slots: the three defined in person and the two defined in astronaut itself. The reader functions defined by the person structure can be applied to instances of the astronaut structure, and they work correctly. Moreover, astronaut has its own reader functions for components defined by the person structure. The following examples illustrate the use of astronaut structures: 

 (setq x (make-astronaut :name 'buzz
                         :age 45.
                         :sex t
                         :helmet-size 17.5))
 (person-name x) ⇒  BUZZ
 (astro-name x) ⇒  BUZZ
 (astro-favorite-beverage x) ⇒  TANG

 (reduce #'+ astros :key #'person-age) ; obtains the total of the ages 
                                       ; of the possibly empty
                                       ; sequence of astros

The difference between the reader functions person-name and astro-name is that person-name can be correctly applied to any person, including an astronaut, while astro-name can be correctly applied only to an astronaut. An implementation might check for incorrect use of reader functions.

At most one :include can be supplied in a single defstruct. The argument to :include is required and must be the name of some previously defined structure. If the structure being defined has no :type option, then the included structure must also have had no :type option supplied for it. If the structure being defined has a :type option, then the included structure must have been declared with a :type option specifying the same representation type.

If no :type option is involved, then the structure name of the including structure definition becomes the name of a data type, and therefore a valid type specifier recognizable by typep; it becomes a subtype of the included structure. In the above example, astronaut is a subtype of person; hence 

 (typep (make-astronaut) 'person) ⇒  true

indicating that all operations on persons also work on astronauts.

The structure using :include can specify default values or slot-options for the included slots different from those the included structure specifies, by giving the :include option as: 

 (:include included-structure-name {slot-description}*)

Each slot-description must have a slot-name that is the same as that of some slot in the included structure. If a slot-description has no slot-initform, then in the new structure the slot has no initial value. Otherwise its initial value form is replaced by the slot-initform in the slot-description. A normally writable slot can be made read-only. If a slot is read-only in the included structure, then it must also be so in the including structure. If a type is supplied for a slot, it must be a subtype of the type specified in the included structure.

For example, if the default age for an astronaut is 45, then 

 (defstruct (astronaut (:include person (age 45)))
    helmet-size
    (favorite-beverage 'tang))

If :include is used with the :type option, then the effect is first to skip over as many representation elements as needed to represent the included structure, then to skip over any additional elements supplied by the :initial-offset option, and then to begin allocation of elements from that point. For example: 

 (defstruct (binop (:type list) :named (:initial-offset 2))
   (operator '? :type symbol)   
   operand-1
   operand-2) ⇒  BINOP
 (defstruct (annotated-binop (:type list)
                             (:initial-offset 3)
                             (:include binop))
  commutative associative identity) ⇒  ANNOTATED-BINOP
 (make-annotated-binop :operator '*
                       :operand-1 'x
                       :operand-2 5
                       :commutative t
                       :associative t
                       :identity 1)
   ⇒  (NIL NIL BINOP * X 5 NIL NIL NIL T T 1)

The first two nil elements stem from the :initial-offset of 2 in the definition of binop. The next four elements contain the structure name and three slots for binop. The next three nil elements stem from the :initial-offset of 3 in the definition of annotated-binop. The last three list elements contain the additional slots for an annotated-binop.

:initial-offset

:initial-offset instructs defstruct to skip over a certain number of slots before it starts allocating the slots described in the body. This option’s argument is the number of slots defstruct should skip. :initial-offset can be used only if :type is also supplied.

[Reviewer Note by Barmar: What are initial values of the skipped slots?]

:initial-offset allows slots to be allocated beginning at a representational element other than the first. For example, the form 

 (defstruct (binop (:type list) (:initial-offset 2))
   (operator '? :type symbol)
   operand-1
   operand-2) ⇒  BINOP

would result in the following behavior for make-binop: 

 (make-binop :operator '+ :operand-1 'x :operand-2 5)
⇒  (NIL NIL + X 5)
 (make-binop :operand-2 4 :operator '*)
⇒  (NIL NIL * NIL 4)

The selector functions binop-operator, binop-operand-1, and binop-operand-2 would be essentially equivalent to third, fourth, and fifth, respectively. Similarly, the form 

 (defstruct (binop (:type list) :named (:initial-offset 2))
   (operator '? :type symbol)
   operand-1
   operand-2) ⇒  BINOP

would result in the following behavior for make-binop: 

 (make-binop :operator '+ :operand-1 'x :operand-2 5) ⇒  (NIL NIL BINOP + X 5)
 (make-binop :operand-2 4 :operator '*) ⇒  (NIL NIL BINOP * NIL 4)

The first two nil elements stem from the :initial-offset of 2 in the definition of binop. The next four elements contain the structure name and three slots for binop.

:named

:named specifies that the structure is named. If no :type is supplied, then the structure is always named.

For example: 

 (defstruct (binop (:type list))
   (operator '? :type symbol)
   operand-1
   operand-2) ⇒  BINOP

This defines a constructor function make-binop and three selector functions, namely binop-operator, binop-operand-1, and binop-operand-2. (It does not, however, define a predicate binop-p, for reasons explained below.)

The effect of make-binop is simply to construct a list of length three: 

 (make-binop :operator '+ :operand-1 'x :operand-2 5) ⇒  (+ X 5)  
 (make-binop :operand-2 4 :operator '*) ⇒  (* NIL 4)

It is just like the function list except that it takes keyword arguments and performs slot defaulting appropriate to the binop conceptual data type. Similarly, the selector functions binop-operator, binop-operand-1, and binop-operand-2 are essentially equivalent to car, cadr, and caddr, respectively. They might not be completely equivalent because, for example, an implementation would be justified in adding error-checking code to ensure that the argument to each selector function is a length-3 list.

binop is a conceptual data type in that it is not made a part of the Common Lisp type system. typep does not recognize binop as a type specifier, and type-of returns list when given a binop structure. There is no way to distinguish a data structure constructed by make-binop from any other list that happens to have the correct structure.

There is not any way to recover the structure name binop from a structure created by make-binop. This can only be done if the structure is named. A named structure has the property that, given an instance of the structure, the structure name (that names the type) can be reliably recovered. For structures defined with no :type option, the structure name actually becomes part of the Common Lisp data-type system. type-of, when applied to such a structure, returns the structure name as the type of the object; typep recognizes the structure name as a valid type specifier.

For structures defined with a :type option, type-of returns a type specifier such as list or (vector t), depending on the type supplied to the :type option. The structure name does not become a valid type specifier. However, if the :named option is also supplied, then the first component of the structure (as created by a defstruct constructor function) always contains the structure name. This allows the structure name to be recovered from an instance of the structure and allows a reasonable predicate for the conceptual type to be defined: the automatically defined name-p predicate for the structure operates by first checking that its argument is of the proper type (list, (vector t), or whatever) and then checking whether the first component contains the appropriate type name.

Consider the binop example shown above, modified only to include the :named option: 

 (defstruct (binop (:type list) :named)
   (operator '? :type symbol)
   operand-1
   operand-2) ⇒  BINOP

As before, this defines a constructor function make-binop and three selector functions binop-operator, binop-operand-1, and binop-operand-2. It also defines a predicate binop-p. The effect of make-binop is now to construct a list of length four: 

 (make-binop :operator '+ :operand-1 'x :operand-2 5) ⇒  (BINOP + X 5)
 (make-binop :operand-2 4 :operator '*) ⇒  (BINOP * NIL 4)

The structure has the same layout as before except that the structure name binop is included as the first list element. The selector functions binop-operator, binop-operand-1, and binop-operand-2 are essentially equivalent to cadr, caddr, and cadddr, respectively. The predicate binop-p is more or less equivalent to this definition: 

 (defun binop-p (x)
   (and (consp x) (eq (car x) 'binop))) ⇒  BINOP-P

The name binop is still not a valid type specifier recognizable to typep, but at least there is a way of distinguishing binop structures from other similarly defined structures.

:predicate

This option takes one argument, which specifies the name of the type predicate. If the argument is not supplied or if the option itself is not supplied, the name of the predicate is made by concatenating the name of the structure to the string "-P", interning the name in whatever package is current at the time defstruct is expanded. If the argument is provided and is nil, no predicate is defined. A predicate can be defined only if the structure is named; if :type is supplied and :named is not supplied, then :predicate must either be unsupplied or have the value nil.

:print-function, :print-object

The :print-function and :print-object options specify that a print-object method for structures of type structure-name should be generated. These options are not synonyms, but do perform a similar service; the choice of which option (:print-function or :print-object) is used affects how the function named printer-name is called. Only one of these options may be used, and these options may be used only if :type is not supplied.

If the :print-function option is used, then when a structure of type structure-name is to be printed, the designated printer function is called on three arguments:

–

the structure to be printed (a generalized instance of structure-name).

–

a stream to print to.

–

an integer indicating the current depth. The magnitude of this integer may vary between implementations; however, it can reliably be compared against *print-level* to determine whether depth abbreviation is appropriate.

Specifying (:print-function printer-name) is approximately equivalent to specifying: 

 (defmethod print-object ((object structure-name) stream)
   (funcall (function printer-name) object stream <<current-print-depth>>))

where the <<current-print-depth>> represents the printer’s belief of how deep it is currently printing. It is implementation-dependent whether <<current-print-depth>> is always 0 and *print-level*, if non-nil, is re-bound to successively smaller values as printing descends recursively, or whether current-print-depth varies in value as printing descends recursively and *print-level* remains constant during the same traversal.

If the :print-object option is used, then when a structure of type structure-name is to be printed, the designated printer function is called on two arguments:

–

the structure to be printed.

–

the stream to print to.

Specifying (:print-object printer-name) is equivalent to specifying: 

 (defmethod print-object ((object structure-name) stream)
   (funcall (function printer-name) object stream))

If no :type option is supplied, and if either a :print-function or a :print-object option is supplied, and if no printer-name is supplied, then a print-object method specialized for structure-name is generated that calls a function that implements the default printing behavior for structures using #S notation; see Printing Structures.

If neither a :print-function nor a :print-object option is supplied, then defstruct does not generate a print-object method specialized for structure-name and some default behavior is inherited either from a structure named in an :include option or from the default behavior for printing structures; see the function print-object and Printing Structures.

When *print-circle* is true, a user-defined print function can print objects to the supplied stream using write, prin1, princ, or format and expect circularities to be detected and printed using the #n# syntax. This applies to methods on print-object in addition to :print-function options. If a user-defined print function prints to a stream other than the one that was supplied, then circularity detection starts over for that stream. See the variable *print-circle*.

:type

:type explicitly specifies the representation to be used for the structure. Its argument must be one of these types:

vector

This produces the same result as specifying (vector t). The structure is represented as a general vector, storing components as vector elements. The first component is vector element 1 if the structure is :named, and element 0 otherwise.

[Reviewer Note by Barmar: Do any implementations create non-simple vectors?]

(vector element-type)

The structure is represented as a (possibly specialized) vector, storing components as vector elements. Every component must be of a type that can be stored in a vector of the type specified. The first component is vector element 1 if the structure is :named, and element 0 otherwise. The structure can be :named only if the type symbol is a subtype of the supplied element-type.

list

The structure is represented as a list. The first component is the cadr if the structure is :named, and the car if it is not :named.

Specifying this option has the effect of forcing a specific representation and of forcing the components to be stored in the order specified in defstruct in corresponding successive elements of the specified representation. It also prevents the structure name from becoming a valid type specifier recognizable by typep.

For example: 

 (defstruct (quux (:type list) :named) x y)

should make a constructor that builds a list exactly like the one that list produces, with quux as its car.

If this type is defined: 

 (deftype quux () '(satisfies quux-p))

then this form 

 (typep (make-quux) 'quux)

should return precisely what this one does 

 (typep (list 'quux nil nil) 'quux)

If :type is not supplied, the structure is represented as an object of type structure-object.

defstruct without a :type option defines a class with the structure name as its name. The metaclass of structure instances is structure-class.

The consequences of redefining a defstruct structure are undefined.

In the case where no defstruct options have been supplied, the following functions are automatically defined to operate on instances of the new structure:

Predicate

A predicate with the name structure-name-p is defined to test membership in the structure type. The predicate (structure-name-p object) is true if an object is of this type; otherwise it is false. typep can also be used with the name of the new type to test whether an object belongs to the type. Such a function call has the form (typep object 'structure-name).

Component reader functions

Reader functions are defined to read the components of the structure. For each slot name, there is a corresponding reader function with the name structure-name-slot-name. This function reads the contents of that slot. Each reader function takes one argument, which is an instance of the structure type. setf can be used with any of these reader functions to alter the slot contents.

Constructor function

A constructor function with the name make-structure-name is defined. This function creates and returns new instances of the structure type.

Copier function

A copier function with the name copy-structure-name is defined. The copier function takes an object of the structure type and creates a new object of the same type that is a copy of the first. The copier function creates a new structure with the same component entries as the original. Corresponding components of the two structure instances are eql.

If a defstruct form appears as a top level form, the compiler must make the structure type name recognized as a valid type name in subsequent declarations (as for deftype) and make the structure slot readers known to setf. In addition, the compiler must save enough information about the structure type so that further defstruct definitions can use :include in a subsequent deftype in the same file to refer to the structure type name. The functions which defstruct generates are not defined in the compile time environment, although the compiler may save enough information about the functions to code subsequent calls inline. The #S reader macro might or might not recognize the newly defined structure type name at compile time.

Examples::

An example of a structure definition follows: 

 (defstruct ship
   x-position
   y-position
   x-velocity
   y-velocity
   mass)

This declares that every ship is an object with five named components. The evaluation of this form does the following:

1.

It defines ship-x-position to be a function of one argument, a ship, that returns the x-position of the ship; ship-y-position and the other components are given similar function definitions. These functions are called the access functions, as they are used to access elements of the structure.

2.

ship becomes the name of a type of which instances of ships are elements. ship becomes acceptable to typep, for example; (typep x 'ship) is true if x is a ship and false if x is any object other than a ship.

3.

A function named ship-p of one argument is defined; it is a predicate that is true if its argument is a ship and is false otherwise.

4.

A function called make-ship is defined that, when invoked, creates a data structure with five components, suitable for use with the access functions. Thus executing 

 (setq ship2 (make-ship))

sets ship2 to a newly created ship object. One can supply the initial values of any desired component in the call to make-ship by using keyword arguments in this way: 

 (setq ship2 (make-ship :mass *default-ship-mass*
                        :x-position 0
                        :y-position 0))

This constructs a new ship and initializes three of its components. This function is called the “constructor function” because it constructs a new structure.

5.

A function called copy-ship of one argument is defined that, when given a ship object, creates a new ship object that is a copy of the given one. This function is called the “copier function.”

setf can be used to alter the components of a ship: 

 (setf (ship-x-position ship2) 100)

This alters the x-position of ship2 to be 100. This works because defstruct behaves as if it generates an appropriate defsetf for each access function. 

;;;
;;; Example 1
;;; define town structure type
;;; area, watertowers, firetrucks, population, elevation are its components
;;;
 (defstruct town
             area
             watertowers
             (firetrucks 1 :type fixnum)    ;an initialized slot
             population 
             (elevation 5128 :read-only t)) ;a slot that can't be changed
⇒  TOWN
;create a town instance
 (setq town1 (make-town :area 0 :watertowers 0)) ⇒  #S(TOWN...)
;town's predicate recognizes the new instance
 (town-p town1) ⇒  true
;new town's area is as specified by make-town
 (town-area town1) ⇒  0
;new town's elevation has initial value
 (town-elevation town1) ⇒  5128
;setf recognizes reader function
 (setf (town-population town1) 99) ⇒  99
 (town-population town1) ⇒  99
;copier function makes a copy of town1
 (setq town2 (copy-town town1)) ⇒  #S(TOWN...)
 (= (town-population town1) (town-population town2))  ⇒  true
;since elevation is a read-only slot, its value can be set only
;when the structure is created
 (setq town3 (make-town :area 0 :watertowers 3 :elevation 1200))
⇒  #S(TOWN...)
;;;
;;; Example 2
;;; define clown structure type
;;; this structure uses a nonstandard prefix
;;;
 (defstruct (clown (:conc-name bozo-))
             (nose-color 'red)         
             frizzy-hair-p polkadots) ⇒  CLOWN
 (setq funny-clown (make-clown)) ⇒  #S(CLOWN)
;use non-default reader name
 (bozo-nose-color funny-clown) ⇒  RED        
 (defstruct (klown (:constructor make-up-klown) ;similar def using other
             (:copier clone-klown)              ;customizing keywords
             (:predicate is-a-bozo-p))
             nose-color frizzy-hair-p polkadots) ⇒  klown
;custom constructor now exists
 (fboundp 'make-up-klown) ⇒  true
;;;
;;; Example 3
;;; define a vehicle structure type
;;; then define a truck structure type that includes 
;;; the vehicle structure
;;;
 (defstruct vehicle name year (diesel t :read-only t)) ⇒  VEHICLE
 (defstruct (truck (:include vehicle (year 79)))
             load-limit                          
             (axles 6)) ⇒  TRUCK
 (setq x (make-truck :name 'mac :diesel t :load-limit 17))
⇒  #S(TRUCK...)
;vehicle readers work on trucks
 (vehicle-name x)
⇒  MAC
;default taken from :include clause 
 (vehicle-year x)
⇒  79 
 (defstruct (pickup (:include truck))     ;pickup type includes truck
             camper long-bed four-wheel-drive) ⇒  PICKUP
 (setq x (make-pickup :name 'king :long-bed t)) ⇒  #S(PICKUP...)
;:include default inherited
 (pickup-year x) ⇒  79
;;;
;;; Example 4
;;; use of BOA constructors
;;;
 (defstruct (dfs-boa                      ;BOA constructors
               (:constructor make-dfs-boa (a b c)) 
               (:constructor create-dfs-boa
                 (a &optional b (c 'cc) &rest d &aux e (f 'ff))))
             a b c d e f) ⇒  DFS-BOA
;a, b, and c set by position, and the rest are uninitialized
 (setq x (make-dfs-boa 1 2 3)) ⇒  #(DFS-BOA...)
 (dfs-boa-a x) ⇒  1
;a and b set, c and f defaulted
 (setq x (create-dfs-boa 1 2)) ⇒  #(DFS-BOA...)
 (dfs-boa-b x) ⇒  2
 (eq (dfs-boa-c x) 'cc) ⇒  true
;a, b, and c set, and the rest are collected into d
 (setq x (create-dfs-boa 1 2 3 4 5 6)) ⇒  #(DFS-BOA...)
 (dfs-boa-d x) ⇒  (4 5 6)

Exceptional Situations::

If any two slot names (whether present directly or inherited by the :include option) are the same under string=, defstruct should signal an error of type program-error.

The consequences are undefined if the included-structure-name does not name a structure type.

See Also::

documentation , print-object , setf , subtypep , type-of , typep , Compilation

Notes::

The printer-name should observe the values of such printer-control variables as *print-escape*.

The restriction against issuing a warning for type mismatches between a slot-initform and the corresponding slot’s :type option is necessary because a slot-initform must be specified in order to specify slot options; in some cases, no suitable default may exist.

The mechanism by which defstruct arranges for slot accessors to be usable with setf is implementation-dependent; for example, it may use setf functions, setf expanders, or some other implementation-dependent mechanism known to that implementation’s code for setf.

Next: , Previous: , Up: Structures Dictionary  

gcl-2.6.14/info/gcl/consp.html0000644000175000017500000000614714360276512014513 0ustar cammcamm consp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.6 consp [Function]

consp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type cons; otherwise, returns false.

Examples::

 (consp nil) ⇒  false
 (consp (cons 1 2)) ⇒  true

The empty list is not a cons, so 

 (consp '()) ≡ (consp 'nil) ⇒  false

See Also::

listp

Notes::

 (consp object) ≡ (typep object 'cons) ≡ (not (typep object 'atom)) ≡ (typep object '(not atom))
gcl-2.6.14/info/gcl/Defaulting-of-Initialization-Arguments.html0000644000175000017500000001417314360276512023003 0ustar cammcamm Defaulting of Initialization Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.3 Defaulting of Initialization Arguments

A default value form can be supplied for an initialization argument by using the :default-initargs class option. If an initialization argument is declared valid by some particular class, its default value form might be specified by a different class. In this case :default-initargs is used to supply a default value for an inherited initialization argument.

The :default-initargs option is used only to provide default values for initialization arguments; it does not declare a symbol as a valid initialization argument name. Furthermore, the :default-initargs option is used only to provide default values for initialization arguments when making an instance.

The argument to the :default-initargs class option is a list of alternating initialization argument names and forms. Each form is the default value form for the corresponding initialization argument. The default value form of an initialization argument is used and evaluated only if that initialization argument does not appear in the arguments to make-instance and is not defaulted by a more specific class. The default value form is evaluated in the lexical environment of the defclass form that supplied it; the resulting value is used as the initialization argument’s value.

The initialization arguments supplied to make-instance are combined with defaulted initialization arguments to produce a defaulted initialization argument list. A defaulted initialization argument list is a list of alternating initialization argument names and values in which unsupplied initialization arguments are defaulted and in which the explicitly supplied initialization arguments appear earlier in the list than the defaulted initialization arguments. Defaulted initialization arguments are ordered according to the order in the class precedence list of the classes that supplied the default values.

There is a distinction between the purposes of the :default-initargs and the :initform options with respect to the initialization of slots. The :default-initargs class option provides a mechanism for the user to give a default value form for an initialization argument without knowing whether the initialization argument initializes a slot or is passed to a method. If that initialization argument is not explicitly supplied in a call to make-instance, the default value form is used, just as if it had been supplied in the call. In contrast, the :initform slot option provides a mechanism for the user to give a default initial value form for a slot. An :initform form is used to initialize a slot only if no initialization argument associated with that slot is given as an argument to make-instance or is defaulted by :default-initargs.

The order of evaluation of default value forms for initialization arguments and the order of evaluation of :initform forms are undefined. If the order of evaluation is important, initialize-instance or shared-initialize methods should be used instead.

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/Dynamic-Variables.html0000644000175000017500000001040614360276512016654 0ustar cammcamm Dynamic Variables (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Evaluation Model  

3.1.2.4 Dynamic Variables

A variable is a dynamic variable if one of the following conditions hold:

*

It is locally declared or globally proclaimed special.

*

It occurs textually within a form that creates a dynamic binding for a variable of the same name, and the binding is not shadowed_2 by a form that creates a lexical binding of the same variable name.

A dynamic variable can be referenced at any time in any program; there is no textual limitation on references to dynamic variables. At any given time, all dynamic variables with a given name refer to exactly one binding, either in the dynamic environment or in the global environment.

The value part of the binding for a dynamic variable might be empty; in this case, the dynamic variable is said to have no value, or to be unbound. A dynamic variable can be made unbound by using makunbound.

The effect of binding a dynamic variable is to create a new binding to which all references to that dynamic variable in any program refer for the duration of the evaluation of the form that creates the dynamic binding.

A dynamic variable can be referenced outside the dynamic extent of a form that binds it. Such a variable is sometimes called a “global variable” but is still in all respects just a dynamic variable whose binding happens to exist in the global environment rather than in some dynamic environment.

A dynamic variable is unbound unless and until explicitly assigned a value, except for those variables whose initial value is defined in this specification or by an implementation.

Next: , Previous: , Up: The Evaluation Model  

gcl-2.6.14/info/gcl/package_002dname.html0000644000175000017500000000673314360276512016353 0ustar cammcamm package-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.22 package-name [Function]

package-name package ⇒ name

Arguments and Values::

package—a package designator.

name—a string

or nil.

Description::

package-name returns the string that names package,

or nil if the package designator is a package object that has no name (see the function delete-package).

Examples::

 (in-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (package-name *package*) ⇒  "COMMON-LISP-USER"
 (package-name (symbol-package :test)) ⇒  "KEYWORD"
 (package-name (find-package 'common-lisp)) ⇒  "COMMON-LISP"

 (defvar *foo-package* (make-package "FOO"))
 (rename-package "FOO" "FOO0")
 (package-name *foo-package*) ⇒  "FOO0"

Exceptional Situations::

Should signal an error of type type-error if package is not a package designator.

gcl-2.6.14/info/gcl/Integrating-Types-and-Classes.html0000644000175000017500000002360614360276512021100 0ustar cammcamm Integrating Types and Classes (ANSI and GNU Common Lisp Document)

Previous: , Up: Classes  

4.3.7 Integrating Types and Classes

The object system maps the space of classes into the space of types. Every class that has a proper name has a corresponding type with the same name.

The proper name of every class is a valid type specifier. In addition, every class object is a valid type specifier. Thus the expression (typep object class) evaluates to true if the class of object is class itself or a subclass of class. The evaluation of the expression (subtypep class1 class2) returns the values true and true if class1 is a subclass of class2 or if they are the same class; otherwise it returns the values false and true. If I is an instance of some class C named S and C is an instance of standard-class, the evaluation of the expression (type-of I\/) returns S if S is the proper name of C; otherwise, it returns C.

Because the names of classes and class objects are type specifiers, they may be used in the special form the and in type declarations.

Many but not all of the predefined type specifiers have a corresponding class with the same proper name as the type. These type specifiers are listed in Figure~4–8. For example, the type array has a corresponding class named array. No type specifier that is a list, such as (vector double-float 100), has a corresponding class. The operator deftype does not create any classes.

Each class that corresponds to a predefined type specifier can be implemented in one of three ways, at the discretion of each implementation. It can be a standard class, a structure class,

or a system class.

A built-in class is one whose generalized instances have restricted capabilities or special representations. Attempting to use defclass to define subclasses of a built-in-class signals an error. Calling make-instance to create a generalized instance of a built-in class signals an error. Calling slot-value on a generalized instance of a built-in class signals an error. Redefining a built-in class or using change-class to change the class of an object to or from a built-in class signals an error. However, built-in classes can be used as parameter specializers in methods.

It is possible to determine whether a class is a built-in class by checking the metaclass. A standard class is an instance of the class standard-class, a built-in class is an instance of the class built-in-class, and a structure class is an instance of the class structure-class.

Each structure type created by defstruct without using the :type option has a corresponding class. This class is a generalized instance of the class structure-class. The :include option of defstruct creates a direct subclass of the class that corresponds to the included structure type.

It is implementation-dependent whether slots are involved in the operation of functions defined in this specification on instances of classes defined in this specification, except when slots are explicitly defined by this specification.

If in a particular implementation a class defined in this specification has slots that are not defined by this specfication, the names of these slots must not be external symbols of packages defined in this specification nor otherwise accessible in the CL-USER package.

The purpose of specifying that many of the standard type specifiers have a corresponding class is to enable users to write methods that discriminate on these types. Method selection requires that a class precedence list can be determined for each class.

The hierarchical relationships among the type specifiers are mirrored by relationships among the classes corresponding to those types.

Figure~4–8 lists the set of classes that correspond to predefined type specifiers. 

 arithmetic-error                 generic-function   simple-error              
 array                            hash-table         simple-type-error         
 bit-vector                       integer            simple-warning            
 broadcast-stream                 list               standard-class            
 built-in-class                   logical-pathname   standard-generic-function 
 cell-error                       method             standard-method           
 character                        method-combination standard-object           
 class                            null               storage-condition         
 complex                          number             stream                    
 concatenated-stream              package            stream-error              
 condition                        package-error      string                    
 cons                             parse-error        string-stream             
 control-error                    pathname           structure-class           
 division-by-zero                 print-not-readable structure-object          
 echo-stream                      program-error      style-warning             
 end-of-file                      random-state       symbol                    
 error                            ratio              synonym-stream            
 file-error                       rational           t                         
 file-stream                      reader-error       two-way-stream            
 float                            readtable          type-error                
 floating-point-inexact           real               unbound-slot              
 floating-point-invalid-operation restart            unbound-variable          
 floating-point-overflow          sequence           undefined-function        
 floating-point-underflow         serious-condition  vector                    
 function                         simple-condition   warning                   

       Figure 4–8: Classes that correspond to pre-defined type specifiers

The class precedence list information specified in the entries for each of these classes are those that are required by the object system.

Individual implementations may be extended to define other type specifiers to have a corresponding class. Individual implementations may be extended to add other subclass relationships and to add other elements to the class precedence lists as long as they do not violate the type relationships and disjointness requirements specified by this standard. A standard class defined with no direct superclasses is guaranteed to be disjoint from all of the classes in the table, except for the class named t.

Previous: , Up: Classes  

gcl-2.6.14/info/gcl/Numbers-_0028Objects-with-Multiple-Notations_0029.html0000644000175000017500000000446214360276512024232 0ustar cammcamm Numbers (Objects with Multiple Notations) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.9 Numbers

Although Common Lisp provides a variety of ways for programs to manipulate the input and output radix for rational numbers, all numbers in this document are in decimal notation unless explicitly noted otherwise.

gcl-2.6.14/info/gcl/unsigned_002dbyte.html0000644000175000017500000000725514360276512016617 0ustar cammcamm unsigned-byte (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.10 unsigned-byte [Type]

Supertypes::

unsigned-byte, signed-byte, integer, rational,

real,

number, t

Description::

The atomic type specifier unsigned-byte denotes the same type as is denoted by the type specifier (integer 0 *).

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(unsigned-byte{[s | *]})

Compound Type Specifier Arguments::

s—a positive integer.

Compound Type Specifier Description::

This denotes the set of non-negative integers that can be represented in a byte of size s (bits). This is equivalent to (mod m) for m=2^s, or to (integer 0 n) for n=2^s-1. The type unsigned-byte or the type (unsigned-byte *) is the same as the type (integer 0 *), the set of non-negative integers.

Notes::

The type (unsigned-byte 1) is also called bit.

gcl-2.6.14/info/gcl/slot_002dmakunbound.html0000644000175000017500000001007014360276512017151 0ustar cammcamm slot-makunbound (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.11 slot-makunbound [Function]

slot-makunbound instance slot-name ⇒ instance

Arguments and Values::

instance – instance.

Slot-name—a symbol.

Description::

The function slot-makunbound restores a slot of the name slot-name in an instance to the unbound state.

Exceptional Situations::

If no slot of the name slot-name exists in the instance, slot-missing is called as follows: 

(slot-missing (class-of instance)
              instance
              slot-name
              'slot-makunbound)

(Any values returned by slot-missing in this case are ignored by slot-makunbound.)

The specific behavior depends on instance’s metaclass. An error is never signaled if instance has metaclass standard-class. An error is always signaled if instance has metaclass built-in-class. The consequences are undefined if instance has any other metaclass–an error might or might not be signaled in this situation. Note in particular that the behavior for conditions and structures is not specified.

See Also::

slot-boundp , slot-missing

Notes::

Although no implementation is required to do so, implementors are strongly encouraged to implement the function slot-makunbound using the function slot-makunbound-using-class described in the Metaobject Protocol.

gcl-2.6.14/info/gcl/Setf-Expansions-and-Places.html0000644000175000017500000000445214360276512020361 0ustar cammcamm Setf Expansions and Places (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Kinds of Places  

5.1.2.6 Setf Expansions and Places

Any compound form for which the operator has a

setf expander

defined can be used as a place.

The operator must refer to the global function definition, rather than a locally defined function or macro.

gcl-2.6.14/info/gcl/adjust_002darray.html0000644000175000017500000003133314360276512016442 0ustar cammcamm adjust-array (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.8 adjust-array [Function]

adjust-array array new-dimensions &key element-type initial-element initial-contents fill-pointer displaced-to displaced-index-offset
⇒ adjusted-array

Arguments and Values::

array—an array.

new-dimensions—a valid array dimension or a list of valid array dimensions.

element-type—a type specifier.

initial-element—an object. Initial-element must not be supplied if either initial-contents or displaced-to is supplied.

initial-contents—an object. If array has rank greater than zero, then initial-contents is composed of nested sequences, the depth of which must equal the rank of array. Otherwise, array is zero-dimensional and initial-contents supplies the single element. initial-contents must not be supplied if either initial-element or displaced-to is given.

fill-pointer—a valid fill pointer for the array to be created, or t, or nil. The default is nil.

displaced-to—an array or nil. initial-elements and initial-contents must not be supplied if displaced-to is supplied.

displaced-index-offset—an object of type (fixnum 0 n) where n is (array-total-size displaced-to). displaced-index-offset may be supplied only if displaced-to is supplied.

adjusted-array—an array.

Description::

adjust-array changes the dimensions or elements of array. The result is an array of the same type and rank as array, that is either the modified array, or a newly created array to which array can be displaced, and that has the given new-dimensions.

New-dimensions specify the size of each dimension of array.

Element-type specifies the type of the elements of the resulting array. If element-type is supplied, the consequences are unspecified if the upgraded array element type of element-type is not the same as the actual array element type of array.

If initial-contents is supplied, it is treated as for make-array. In this case none of the original contents of array appears in the resulting array.

If fill-pointer is an integer, it becomes the fill pointer for the resulting array. If fill-pointer is the symbol t, it indicates that the size of the resulting array should be used as the fill pointer. If fill-pointer is nil, it indicates that the fill pointer should be left as it is.

If displaced-to non-nil, a displaced array is created. The resulting array shares its contents with the array given by displaced-to. The resulting array cannot contain more elements than the array it is displaced to. If displaced-to is not supplied or nil, the resulting array is not a displaced array. If array A is created displaced to array B and subsequently array B is given to adjust-array, array A will still be displaced to array B. Although array might be a displaced array, the resulting array is not a displaced array unless displaced-to is supplied and not nil.

The interaction between adjust-array and displaced arrays is as follows given three arrays, A, B, and~C:

A is not displaced before or after the call
 (adjust-array A ...)

The dimensions of A are altered, and the contents rearranged as appropriate. Additional elements of A are taken from initial-element. The use of initial-contents causes all old contents to be discarded.

A is not displaced before, but is displaced to

C after the call 

 (adjust-array A ... :displaced-to C)

None of the original contents of A appears in A afterwards; A now contains the contents of C, without any rearrangement of C.

A is displaced to B

before the call, and is displaced to C after the call 

 (adjust-array A ... :displaced-to B)
 (adjust-array A ... :displaced-to C)

B and C might be the same. The contents of B do not appear in A afterward unless such contents also happen to be in C If displaced-index-offset is not supplied in the adjust-array call, it defaults to zero; the old offset into B is not retained.

A is displaced to B before the call, but not displaced

afterward. 

 (adjust-array A ... :displaced-to B)
 (adjust-array A ... :displaced-to nil)

A gets a new “data region,” and contents of B are copied into it as appropriate to maintain the existing old contents; additional elements of A are taken from initial-element if supplied. However, the use of initial-contents causes all old contents to be discarded.

If displaced-index-offset is supplied, it specifies the offset of the resulting array from the beginning of the array that it is displaced to. If displaced-index-offset is not supplied, the offset is~0. The size of the resulting array plus the offset value cannot exceed the size of the array that it is displaced to.

If only new-dimensions and an initial-element argument are supplied, those elements of array that are still in bounds appear in the resulting array. The elements of the resulting array that are not in the bounds of array are initialized to initial-element; if initial-element is not provided,

the consequences of later reading any such new element of new-array before it has been initialized are undefined.

If initial-contents or displaced-to is supplied, then none of the original contents of array appears in the new array.

The consequences are unspecified if array is adjusted to a size smaller than its fill pointer without supplying the fill-pointer argument so that its fill-pointer is properly adjusted in the process.

If A is displaced to B, the consequences are unspecified if B is adjusted in such a way that it no longer has enough elements to satisfy A.

If adjust-array is applied to an array that is actually adjustable, the array returned is identical to array. If the array returned by adjust-array is distinct from array, then the argument array is unchanged.

Note that if an array A is displaced to another array B, and B is displaced to another array C, and B is altered by adjust-array, A must now refer to the adjust contents of B. This means that an implementation cannot collapse the chain to make A refer to C directly and forget that the chain of reference passes through B. However, caching techniques are permitted as long as they preserve the semantics specified here.

Examples::

 (adjustable-array-p
  (setq ada (adjust-array
              (make-array '(2 3)
                          :adjustable t
                          :initial-contents '((a b c) (1 2 3)))
              '(4 6)))) ⇒  T 
 (array-dimensions ada) ⇒  (4 6) 
 (aref ada 1 1) ⇒  2 
 (setq beta (make-array '(2 3) :adjustable t))
⇒  #2A((NIL NIL NIL) (NIL NIL NIL)) 
 (adjust-array beta '(4 6) :displaced-to ada)
⇒  #2A((A B C NIL NIL NIL)
       (1 2 3 NIL NIL NIL)
       (NIL NIL NIL NIL NIL NIL) 
       (NIL NIL NIL NIL NIL NIL))
 (array-dimensions beta) ⇒  (4 6)
 (aref beta 1 1) ⇒  2

Suppose that the 4-by-4 array in m looks like this: 

#2A(( alpha     beta      gamma     delta )
    ( epsilon   zeta      eta       theta )
    ( iota      kappa     lambda    mu    )
    ( nu        xi        omicron   pi    ))

Then the result of 

 (adjust-array m '(3 5) :initial-element 'baz)

is a 3-by-5 array with contents 

#2A(( alpha     beta      gamma     delta     baz )
    ( epsilon   zeta      eta       theta     baz )
    ( iota      kappa     lambda    mu        baz ))

Exceptional Situations::

An error of type error is signaled if fill-pointer is supplied and non-nil but array has no fill pointer.

See Also::

adjustable-array-p , make-array , array-dimension-limit , array-total-size-limit , array

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/listp.html0000644000175000017500000000632114360276512014516 0ustar cammcamm listp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.17 listp [Function]

listp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type list; otherwise, returns false.

Examples::

 (listp nil) ⇒  true
 (listp (cons 1 2)) ⇒  true
 (listp (make-array 6)) ⇒  false
 (listp t) ⇒  false

See Also::

consp

Notes::

If object is a cons, listp does not check whether object is a proper list; it returns true for any kind of list. 

 (listp object) ≡ (typep object 'list) ≡ (typep object '(or cons null))
gcl-2.6.14/info/gcl/Additional-Uses-for-Indirect-Definitions-in-Modified-BNF-Syntax.html0000644000175000017500000000740414360276512027160 0ustar cammcamm Additional Uses for Indirect Definitions in Modified BNF Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.5 Additional Uses for Indirect Definitions in Modified BNF Syntax

In some cases, an auxiliary definition in the BNF might appear to be unused within the BNF, but might still be useful elsewhere. For example, consider the following definitions:

case keyform {!normal-clause}* [!otherwise-clause] ⇒ {result}*

ccase keyplace {!normal-clause}* ⇒ {result}*

ecase keyform {!normal-clause}* ⇒ {result}*

normal-clause ::=(keys {form}*)

otherwise-clause ::=({otherwise | t} {form}*)

clause ::=normal-clause | otherwise-clause

Here the term “clause” might appear to be “dead” in that it is not used in the BNF. However, the purpose of the BNF is not just to guide parsing, but also to define useful terms for reference in the descriptive text which follows. As such, the term “clause” might appear in text that follows, as shorthand for “normal-clause or otherwise-clause.”

gcl-2.6.14/info/gcl/Compilation.html0000644000175000017500000000564314360276512015647 0ustar cammcamm Compilation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.2 Compilation

• Compiler Terminology  
• Compilation Semantics  
• File Compilation  
• Literal Objects in Compiled Files  
• Exceptional Situations in the Compiler  
gcl-2.6.14/info/gcl/atom.html0000644000175000017500000000571414360276512014330 0ustar cammcamm atom (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.7 atom [Function]

atom object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type atom; otherwise, returns false.

Examples::

 (atom 'sss) ⇒  true
 (atom (cons 1 2)) ⇒  false
 (atom nil) ⇒  true
 (atom '()) ⇒  true
 (atom 3) ⇒  true

Notes::

 (atom object) ≡ (typep object 'atom) ≡ (not (consp object))
 ≡ (not (typep object 'cons)) ≡ (typep object '(not cons))
gcl-2.6.14/info/gcl/File-Compilation.html0000644000175000017500000001155514360276512016523 0ustar cammcamm File Compilation (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation  

3.2.3 File Compilation

The function compile-file performs compilation of forms in a file following the rules specified in Compilation Semantics, and produces an output file that can be loaded by using load.

Normally, the top level forms appearing in a file compiled with compile-file are evaluated only when the resulting compiled file is loaded, and not when the file is compiled. However, it is typically the case that some forms in the file need to be evaluated at compile time so the remainder of the file can be read and compiled correctly.

The eval-when special form can be used to control whether a top level form is evaluated at compile time, load time, or both. It is possible to specify any of three situations with eval-when, denoted by the symbols :compile-toplevel, :load-toplevel, and :execute. For top level eval-when forms, :compile-toplevel specifies that the compiler must evaluate the body at compile time, and :load-toplevel specifies that the compiler must arrange to evaluate the body at load time. For non-top level eval-when forms, :execute specifies that the body must be executed in the run-time environment.

The behavior of this form can be more precisely understood in terms of a model of how compile-file processes forms in a file to be compiled. There are two processing modes, called “not-compile-time” and “compile-time-too”.

Successive forms are read from the file by compile-file and processed in not-compile-time mode; in this mode, compile-file arranges for forms to be evaluated only at load time and not at compile time. When compile-file is in compile-time-too mode, forms are evaluated both at compile time and load time.

• Processing of Top Level Forms  
• Processing of Defining Macros  
• Constraints on Macros and Compiler Macros  

Next: , Previous: , Up: Compilation  

gcl-2.6.14/info/gcl/array_002ddimension_002dlimit.html0000644000175000017500000000527314360276512020725 0ustar cammcamm array-dimension-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.24 array-dimension-limit [Constant Variable]

Constant Value::

A positive

fixnum,

the exact magnitude of which is implementation-dependent, but which is not less than 1024.

Description::

The upper exclusive bound on each individual dimension of an array.

See Also::

make-array

gcl-2.6.14/info/gcl/class_002dname.html0000644000175000017500000000634414360276512016063 0ustar cammcamm class-name (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.37 class-name [Standard Generic Function]

Syntax::

class-name class ⇒ name

Method Signatures::

class-name (class class)

Arguments and Values::

class—a class object.

name—a symbol.

Description::

Returns the name of the given class.

See Also::

find-class , Classes

Notes::

If S is a symbol such that S =(class-name C) and C =(find-class S), then S is the proper name of C. For further discussion, see Classes.

The name of an anonymous class is nil.

gcl-2.6.14/info/gcl/Syntax-of-Logical-Pathname-Namestrings.html0000644000175000017500000001707714360276512022660 0ustar cammcamm Syntax of Logical Pathname Namestrings (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Logical Pathnames  

19.3.1 Syntax of Logical Pathname Namestrings

The syntax of a logical pathname namestring is as follows. (Note that unlike many notational descriptions in this document, this is a syntactic description of character sequences, not a structural description of objects.)

logical-pathname ::=[!host host-marker]                       [!relative-directory-marker] {!directory directory-marker}*                       [!name] [type-marker !type [version-marker !version]]

host ::=!word

directory ::=!word | !wildcard-word | !wild-inferiors-word

name ::=!word | !wildcard-word

type ::=!word | !wildcard-word

version ::=!pos-int | newest-word | wildcard-version

host-marker—a colon.

relative-directory-marker—a semicolon.

directory-marker—a semicolon.

type-marker—a dot.

version-marker—a dot.

wild-inferiors-word—The two character sequence “**” (two asterisks).

newest-word—The six character sequence “newest” or the six character sequence “NEWEST”.

wildcard-version—an asterisk.

wildcard-word—one or more asterisks, uppercase letters, digits, and hyphens, including at least one asterisk, with no two asterisks adjacent.

word—one or more uppercase letters, digits, and hyphens.

pos-int—a positive integer.

• Additional Information about Parsing Logical Pathname Namestrings  
• The Host part of a Logical Pathname Namestring  
• The Device part of a Logical Pathname Namestring  
• The Directory part of a Logical Pathname Namestring  
• The Type part of a Logical Pathname Namestring  
• The Version part of a Logical Pathname Namestring  
• Wildcard Words in a Logical Pathname Namestring  
• Lowercase Letters in a Logical Pathname Namestring  
• Other Syntax in a Logical Pathname Namestring  

Next: , Previous: , Up: Logical Pathnames  

gcl-2.6.14/info/gcl/pprint_002dindent.html0000644000175000017500000001054314360276512016627 0ustar cammcamm pprint-indent (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.6 pprint-indent [Function]

pprint-indent relative-to n &optional stream ⇒ nil

Arguments and Values::

relative-to—either :block or :current.

n—a real.

stream—an output stream designator. The default is standard output.

Description::

pprint-indent specifies the indentation to use in a logical block on stream.

If stream is a pretty printing stream and the value of *print-pretty* is true, pprint-indent sets the indentation in the innermost dynamically enclosing logical block; otherwise, pprint-indent has no effect.

N specifies the indentation in ems. If relative-to is :block, the indentation is set to the horizontal position of the first character in the dynamically current logical block plus n ems. If relative-to is :current, the indentation is set to the current output position plus n ems. (For robustness in the face of variable-width fonts, it is advisable to use :current with an n of zero whenever possible.)

N can be negative; however, the total indentation cannot be moved left of the beginning of the line or left of the end of the rightmost per-line prefix—an attempt to move beyond one of these limits is treated the same as an attempt to move to that limit. Changes in indentation caused by pprint-indent do not take effect until after the next line break. In addition, in miser mode all calls to pprint-indent are ignored, forcing the lines corresponding to the logical block to line up under the first character in the block.

Exceptional Situations::

An error is signaled if relative-to is any object other than :block or :current.

See Also::

Tilde I-> Indent

gcl-2.6.14/info/gcl/String-Concepts.html0000644000175000017500000000451114360276512016404 0ustar cammcamm String Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings  

16.1 String Concepts

• Implications of Strings Being Arrays  
• Subtypes of STRING  
gcl-2.6.14/info/gcl/Sequences.html0000644000175000017500000000461714360276512015324 0ustar cammcamm Sequences (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

17 Sequences

• Sequence Concepts  
• Rules about Test Functions  
• Sequences Dictionary  
gcl-2.6.14/info/gcl/Tilde-Vertical_002dBar_002d_003e-Page.html0000644000175000017500000000434714360276512021501 0ustar cammcamm Tilde Vertical-Bar-> Page (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Basic Output  

22.3.1.4 Tilde Vertical-Bar: Page

This outputs a page separator character, if possible. ~n| does this n times.

gcl-2.6.14/info/gcl/defsetf.html0000644000175000017500000002430614360276512015006 0ustar cammcamm defsetf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.61 defsetf [Macro]

The “short form”:

defsetf access-fn update-fn [documentation]
⇒ access-fn

The “long form”:

defsetf access-fn lambda-list ({store-variable}*) [[{declaration}* | documentation]] {form}*
⇒ access-fn

Arguments and Values::

access-fn—a symbol which names a function or a macro.

update-fn—a symbol naming a function or macro.

lambda-list—a defsetf lambda list.

store-variable—a symbol (a variable name).

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

Description::

defsetf defines how to setf a place of the form (access-fn ...) for relatively simple cases. (See define-setf-expander for more general access to this facility.)

It must be the case that the function or macro named by access-fn evaluates all of its arguments.

defsetf may take one of two forms, called the “short form” and the “long form,” which are distinguished by the type of the second argument.

When the short form is used, update-fn must name a function (or macro) that takes one more argument than access-fn takes. When setf is given a place that is a call on access-fn, it expands into a call on update-fn that is given all the arguments to access-fn and also, as its last argument, the new value (which must be returned by update-fn as its value).

The long form defsetf resembles defmacro. The lambda-list describes the arguments of access-fn. The store-variables describe the value

or values

to be stored into the place. The body must compute the expansion of a setf of a call on access-fn.

The expansion function is defined in the same lexical environment in which the defsetf form appears.

During the evaluation of the forms, the variables in the lambda-list and the store-variables are bound to names of temporary variables, generated as if by gensym or gentemp, that will be bound by the expansion of setf to the values of those subforms. This binding permits the forms to be written without regard for order-of-evaluation issues. defsetf arranges for the temporary variables to be optimized out of the final result in cases where that is possible.

The body code in defsetf is implicitly enclosed in a block whose name is access-fn

defsetf ensures that subforms of the place are evaluated exactly once.

Documentation is attached to access-fn as a documentation string of kind setf.

If a defsetf form appears as a top level form, the compiler must make the setf expander available so that it may be used to expand calls to setf later on in the file. Users must ensure that the forms, if any, can be evaluated at compile time if the access-fn is used in a place later in the same file. The compiler must make these setf expanders available to compile-time calls to get-setf-expansion when its environment argument is a value received as the environment parameter of a macro.

Examples::

The effect of 

 (defsetf symbol-value set)

is built into the Common Lisp system. This causes the form (setf (symbol-value foo) fu) to expand into (set foo fu).

Note that 

 (defsetf car rplaca)

would be incorrect because rplaca does not return its last argument. 

 (defun middleguy (x) (nth (truncate (1- (list-length x)) 2) x)) ⇒  MIDDLEGUY
 (defun set-middleguy (x v)
    (unless (null x)
      (rplaca (nthcdr (truncate (1- (list-length x)) 2) x) v))
    v) ⇒  SET-MIDDLEGUY
 (defsetf middleguy set-middleguy) ⇒  MIDDLEGUY
 (setq a (list 'a 'b 'c 'd)
       b (list 'x)
       c (list 1 2 3 (list 4 5 6) 7 8 9)) ⇒  (1 2 3 (4 5 6) 7 8 9)
 (setf (middleguy a) 3) ⇒  3
 (setf (middleguy b) 7) ⇒  7
 (setf (middleguy (middleguy c)) 'middleguy-symbol) ⇒  MIDDLEGUY-SYMBOL
 a ⇒  (A 3 C D)
 b ⇒  (7)
 c ⇒  (1 2 3 (4 MIDDLEGUY-SYMBOL 6) 7 8 9)

An example of the use of the long form of defsetf: 

 (defsetf subseq (sequence start &optional end) (new-sequence)
   `(progn (replace ,sequence ,new-sequence
                    :start1 ,start :end1 ,end)
           ,new-sequence)) ⇒  SUBSEQ

 (defvar *xy* (make-array '(10 10)))
 (defun xy (&key ((x x) 0) ((y y) 0)) (aref *xy* x y)) ⇒  XY
 (defun set-xy (new-value &key ((x x) 0) ((y y) 0))
   (setf (aref *xy* x y) new-value)) ⇒  SET-XY
 (defsetf xy (&key ((x x) 0) ((y y) 0)) (store)
   `(set-xy ,store 'x ,x 'y ,y)) ⇒  XY
 (get-setf-expansion '(xy a b))
⇒  (#:t0 #:t1),
   (a b),
   (#:store),
   ((lambda (&key ((x #:x)) ((y #:y))) 
      (set-xy #:store 'x #:x 'y #:y))
    #:t0 #:t1),
   (xy #:t0 #:t1)
 (xy 'x 1) ⇒  NIL
 (setf (xy 'x 1) 1) ⇒  1
 (xy 'x 1) ⇒  1
 (let ((a 'x) (b 'y))
   (setf (xy a 1 b 2) 3)
   (setf (xy b 5 a 9) 14))
⇒  14
 (xy 'y 0 'x 1) ⇒  1
 (xy 'x 1 'y 2) ⇒  3

See Also::

documentation , setf ,

define-setf-expander , get-setf-expansion ,

Generalized Reference, Syntactic Interaction of Documentation Strings and Declarations

Notes::

forms must include provision for returning the correct value (the value

or values

of store-variable). This is handled by forms rather than by defsetf because in many cases this value can be returned at no extra cost, by calling a function that simultaneously stores into the place and returns the correct value.

A setf of a call on access-fn also evaluates all of access-fn’s arguments; it cannot treat any of them specially. This means that defsetf cannot be used to describe how to store into a generalized reference to a byte, such as (ldb field reference).

define-setf-expander

is used to handle situations that do not fit the restrictions imposed by defsetf and gives the user additional control.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Examples-of-Rule-of-Canonical-Representation-for-Complex-Rationals.html0000644000175000017500000000543214360276512030064 0ustar cammcamm Examples of Rule of Canonical Representation for Complex Rationals (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Complex Computations  

12.1.5.4 Examples of Rule of Canonical Representation for Complex Rationals

 #c(1.0 1.0) ⇒  #C(1.0 1.0)
 #c(0.0 0.0) ⇒  #C(0.0 0.0)
 #c(1.0 1) ⇒  #C(1.0 1.0)
 #c(0.0 0) ⇒  #C(0.0 0.0)
 #c(1 1) ⇒  #C(1 1)
 #c(0 0) ⇒  0
 (typep #c(1 1) '(complex (eql 1))) ⇒  true
 (typep #c(0 0) '(complex (eql 0))) ⇒  false
gcl-2.6.14/info/gcl/General-Restrictions-on-Parameters-that-must-be-Sequences.html0000644000175000017500000000441314360276512026402 0ustar cammcamm General Restrictions on Parameters that must be Sequences (ANSI and GNU Common Lisp Document)

Previous: , Up: Sequence Concepts  

17.1.1 General Restrictions on Parameters that must be Sequences

In general, lists (including association lists and property lists) that are treated as sequences must be proper lists.

gcl-2.6.14/info/gcl/simple_002dbit_002dvector.html0000644000175000017500000000662314360276512020055 0ustar cammcamm simple-bit-vector (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.6 simple-bit-vector [Type]

Supertypes::

simple-bit-vector, bit-vector, vector, simple-array, array, sequence, t

Description::

The type of a bit vector that is not displaced to another array, has no fill pointer, and is not expressly adjustable is a subtype of type simple-bit-vector.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(simple-bit-vector{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *. The default is the symbol *.

Compound Type Specifier Description::

This denotes the same type as the type (simple-array bit (size)); that is, the set of simple bit vectors of size size.

gcl-2.6.14/info/gcl/stream_002dexternal_002dformat.html0000644000175000017500000000651014360276512021104 0ustar cammcamm stream-external-format (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.30 stream-external-format [Function]

stream-external-format stream ⇒ format

Arguments and Values::

stream—a file stream.

format—an external file format.

Description::

Returns an external file format designator for the stream.

Examples::

 (with-open-file (stream "test" :direction :output)
   (stream-external-format stream))
⇒  :DEFAULT
OR⇒ :ISO8859/1-1987
OR⇒ (:ASCII :SAIL)
OR⇒ ACME::PROPRIETARY-FILE-FORMAT-17
OR⇒ #<FILE-FORMAT :ISO646-1983 2343673>

See Also::

the :external-format argument to the function open and the with-open-file macro.

Notes::

The format returned is not necessarily meaningful to other implementations.

gcl-2.6.14/info/gcl/Initialization-Arguments.html0000644000175000017500000001245614360276512020323 0ustar cammcamm Initialization Arguments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Object Creation and Initialization  

7.1.1 Initialization Arguments

An initialization argument controls object creation and initialization. It is often convenient to use keyword symbols to name initialization arguments, but the name of an initialization argument can be any symbol, including nil. An initialization argument can be used in two ways: to fill a slot with a value or to provide an argument for an initialization method. A single initialization argument can be used for both purposes.

An initialization argument list is a property list of initialization argument names and values. Its structure is identical to a property list and also to the portion of an argument list processed for &key parameters. As in those lists, if an initialization argument name appears more than once in an initialization argument list, the leftmost occurrence supplies the value and the remaining occurrences are ignored. The arguments to make-instance (after the first argument) form an initialization argument list.

An initialization argument can be associated with a slot. If the initialization argument has a value in the initialization argument list, the value is stored into the slot of the newly created object, overriding any :initform form associated with the slot. A single initialization argument can initialize more than one slot. An initialization argument that initializes a shared slot stores its value into the shared slot, replacing any previous value.

An initialization argument can be associated with a method. When an object is created and a particular initialization argument is supplied, the generic functions initialize-instance, shared-initialize, and allocate-instance are called with that initialization argument’s name and value as a keyword argument pair. If a value for the initialization argument is not supplied in the initialization argument list, the method’s lambda list supplies a default value.

Initialization arguments are used in four situations: when making an instance, when re-initializing an instance, when updating an instance to conform to a redefined class, and when updating an instance to conform to the definition of a different class.

Because initialization arguments are used to control the creation and initialization of an instance of some particular class, we say that an initialization argument is “an initialization argument for” that class.

Next: , Previous: , Up: Object Creation and Initialization  

gcl-2.6.14/info/gcl/index.html0000644000175000017500000102131014360276512014466 0ustar cammcamm Top (ANSI and GNU Common Lisp Document)

ANSI and GNU Common Lisp Document

Next: , Previous: , Up: (dir)  

Top

• Introduction (Introduction)  
• Syntax  
• Evaluation and Compilation  
• Types and Classes  
• Data and Control Flow  
• Iteration  
• Objects  
• Structures  
• Conditions  
• Symbols  
• Packages  
• Numbers (Numbers)  
• Characters  
• Conses  
• Arrays  
• Strings  
• Sequences  
• Hash Tables  
• Filenames  
• Files  
• Streams  
• Printer  
• Reader  
• System Construction  
• Environment  
• Glossary (Glossary)  
• Appendix   

 — The Detailed Node Listing —

Introduction
• Scope  
• Organization of the Document  
• Referenced Publications  
• Definitions  
• Conformance  
• Language Extensions  
• Language Subsets  
• Deprecated Language Features  
• Symbols in the COMMON-LISP Package   

Scope, Purpose, and History
• Scope and Purpose  
• History   

Definitions
• Notational Conventions  
• Error Terminology  
• Sections Not Formally Part Of This Standard  
• Interpreting Dictionary Entries   

Notational Conventions
• Font Key  
• Modified BNF Syntax  
• Splicing in Modified BNF Syntax  
• Indirection in Modified BNF Syntax  
• Additional Uses for Indirect Definitions in Modified BNF Syntax  
• Special Symbols  
• Objects with Multiple Notations  
• Case in Symbols  
• Numbers (Objects with Multiple Notations)  
• Use of the Dot Character  
• NIL  
• Designators  
• Nonsense Words   

Interpreting Dictionary Entries
• The "Affected By" Section of a Dictionary Entry  
• The "Arguments" Section of a Dictionary Entry  
• The "Arguments and Values" Section of a Dictionary Entry  
• The "Binding Types Affected" Section of a Dictionary Entry  
• The "Class Precedence List" Section of a Dictionary Entry  
• Dictionary Entries for Type Specifiers  
• The "Compound Type Specifier Kind" Section of a Dictionary Entry  
• The "Compound Type Specifier Syntax" Section of a Dictionary Entry  
• The "Compound Type Specifier Arguments" Section of a Dictionary Entry  
• The "Compound Type Specifier Description" Section of a Dictionary Entry  
• The "Constant Value" Section of a Dictionary Entry  
• The "Description" Section of a Dictionary Entry  
• The "Examples" Section of a Dictionary Entry  
• The "Exceptional Situations" Section of a Dictionary Entry  
• The "Initial Value" Section of a Dictionary Entry  
• The "Argument Precedence Order" Section of a Dictionary Entry  
• The "Method Signature" Section of a Dictionary Entry  
• The "Name" Section of a Dictionary Entry  
• The "Notes" Section of a Dictionary Entry  
• The "Pronunciation" Section of a Dictionary Entry  
• The "See Also" Section of a Dictionary Entry  
• The "Side Effects" Section of a Dictionary Entry  
• The "Supertypes" Section of a Dictionary Entry  
• The "Syntax" Section of a Dictionary Entry  
• Special "Syntax" Notations for Overloaded Operators  
• Naming Conventions for Rest Parameters  
• Requiring Non-Null Rest Parameters in The "Syntax" Section  
• Return values in The "Syntax" Section  
• No Arguments or Values in The "Syntax" Section  
• Unconditional Transfer of Control in The "Syntax" Section  
• The "Valid Context" Section of a Dictionary Entry  
• The "Value Type" Section of a Dictionary Entry   

Conformance
• Conforming Implementations  
• Conforming Programs   

Conforming Implementations
• Required Language Features  
• Documentation of Implementation-Dependent Features  
• Documentation of Extensions  
• Treatment of Exceptional Situations  
• Resolution of Apparent Conflicts in Exceptional Situations  
• Examples of Resolution of Apparent Conflict in Exceptional Situations  
• Conformance Statement   

Conforming Programs
• Use of Implementation-Defined Language Features  
• Use of Read-Time Conditionals   

Deprecated Language Features
• Deprecated Functions  
• Deprecated Argument Conventions  
• Deprecated Variables  
• Deprecated Reader Syntax   

Syntax
• Character Syntax  
• Reader Algorithm  
• Interpretation of Tokens  
• Standard Macro Characters   

Character Syntax
• Readtables  
• Variables that affect the Lisp Reader  
• Standard Characters  
• Character Syntax Types   

Readtables
• The Current Readtable  
• The Standard Readtable  
• The Initial Readtable   

Character Syntax Types
• Constituent Characters  
• Constituent Traits  
• Invalid Characters  
• Macro Characters  
• Multiple Escape Characters  
• Examples of Multiple Escape Characters  
• Single Escape Character  
• Examples of Single Escape Characters  
• Whitespace Characters  
• Examples of Whitespace Characters   

Interpretation of Tokens
• Numbers as Tokens  
• Constructing Numbers from Tokens  
• The Consing Dot  
• Symbols as Tokens  
• Valid Patterns for Tokens  
• Package System Consistency Rules   

Numbers as Tokens
• Potential Numbers as Tokens  
• Escape Characters and Potential Numbers  
• Examples of Potential Numbers   

Constructing Numbers from Tokens
• Syntax of a Rational  
• Syntax of an Integer  
• Syntax of a Ratio  
• Syntax of a Float  
• Syntax of a Complex   

Standard Macro Characters
• Left-Parenthesis  
• Right-Parenthesis  
• Single-Quote  
• Semicolon  
• Double-Quote  
• Backquote  
• Comma  
• Sharpsign  
• Re-Reading Abbreviated Expressions   

Single-Quote
• Examples of Single-Quote   

Semicolon
• Examples of Semicolon  
• Notes about Style for Semicolon  
• Use of Single Semicolon  
• Use of Double Semicolon  
• Use of Triple Semicolon  
• Use of Quadruple Semicolon  
• Examples of Style for Semicolon   

Backquote
• Notes about Backquote   

Sharpsign
• Sharpsign Backslash  
• Sharpsign Single-Quote  
• Sharpsign Left-Parenthesis  
• Sharpsign Asterisk  
• Examples of Sharpsign Asterisk  
• Sharpsign Colon  
• Sharpsign Dot  
• Sharpsign B  
• Sharpsign O  
• Sharpsign X  
• Sharpsign R  
• Sharpsign C  
• Sharpsign A  
• Sharpsign S  
• Sharpsign P  
• Sharpsign Equal-Sign  
• Sharpsign Sharpsign  
• Sharpsign Plus  
• Sharpsign Minus  
• Sharpsign Vertical-Bar  
• Examples of Sharpsign Vertical-Bar  
• Notes about Style for Sharpsign Vertical-Bar  
• Sharpsign Less-Than-Sign  
• Sharpsign Whitespace  
• Sharpsign Right-Parenthesis   

Evaluation and Compilation
• Evaluation  
• Compilation  
• Declarations  
• Lambda Lists  
• Error Checking in Function Calls  
• Traversal Rules and Side Effects  
• Destructive Operations  
• Evaluation and Compilation Dictionary   

Evaluation
• Introduction to Environments  
• The Evaluation Model  
• Lambda Expressions  
• Closures and Lexical Binding  
• Shadowing  
• Extent  
• Return Values   

Introduction to Environments
• The Global Environment  
• Dynamic Environments  
• Lexical Environments  
• The Null Lexical Environment  
• Environment Objects   

The Evaluation Model
• Form Evaluation  
• Symbols as Forms  
• Lexical Variables  
• Dynamic Variables  
• Constant Variables  
• Symbols Naming Both Lexical and Dynamic Variables  
• Conses as Forms  
• Special Forms  
• Macro Forms  
• Function Forms  
• Lambda Forms  
• Self-Evaluating Objects  
• Examples of Self-Evaluating Objects   

Compilation
• Compiler Terminology  
• Compilation Semantics  
• File Compilation  
• Literal Objects in Compiled Files  
• Exceptional Situations in the Compiler   

Compilation Semantics
• Compiler Macros  
• Purpose of Compiler Macros  
• Naming of Compiler Macros  
• When Compiler Macros Are Used  
• Notes about the Implementation of Compiler Macros  
• Minimal Compilation  
• Semantic Constraints   

File Compilation
• Processing of Top Level Forms  
• Processing of Defining Macros  
• Constraints on Macros and Compiler Macros   

Literal Objects in Compiled Files
• Externalizable Objects  
• Similarity of Literal Objects  
• Similarity of Aggregate Objects  
• Definition of Similarity  
• Extensions to Similarity Rules  
• Additional Constraints on Externalizable Objects   

Declarations
• Minimal Declaration Processing Requirements  
• Declaration Specifiers  
• Declaration Identifiers  
• Declaration Scope   

Declaration Identifiers
• Shorthand notation for Type Declarations   

Declaration Scope
• Examples of Declaration Scope   

Lambda Lists
• Ordinary Lambda Lists  
• Generic Function Lambda Lists  
• Specialized Lambda Lists  
• Macro Lambda Lists  
• Destructuring Lambda Lists  
• Boa Lambda Lists  
• Defsetf Lambda Lists  
• Deftype Lambda Lists  
• Define-modify-macro Lambda Lists  
• Define-method-combination Arguments Lambda Lists  
• Syntactic Interaction of Documentation Strings and Declarations   

Ordinary Lambda Lists
• Specifiers for the required parameters  
• Specifiers for optional parameters  
• A specifier for a rest parameter  
• Specifiers for keyword parameters  
• Suppressing Keyword Argument Checking  
• Examples of Suppressing Keyword Argument Checking  
• Specifiers for &aux variables  
• Examples of Ordinary Lambda Lists   

Macro Lambda Lists
• Destructuring by Lambda Lists  
• Data-directed Destructuring by Lambda Lists  
• Examples of Data-directed Destructuring by Lambda Lists  
• Lambda-list-directed Destructuring by Lambda Lists   

Error Checking in Function Calls
• Argument Mismatch Detection   

Argument Mismatch Detection
• Safe and Unsafe Calls  
• Error Detection Time in Safe Calls  
• Too Few Arguments  
• Too Many Arguments  
• Unrecognized Keyword Arguments  
• Invalid Keyword Arguments  
• Odd Number of Keyword Arguments  
• Destructuring Mismatch  
• Errors When Calling a Next Method   

Destructive Operations
• Modification of Literal Objects  
• Transfer of Control during a Destructive Operation   

Transfer of Control during a Destructive Operation
• Examples of Transfer of Control during a Destructive Operation   

Evaluation and Compilation Dictionary
• lambda (Symbol)  
• lambda  
• compile  
• eval  
• eval-when  
• load-time-value  
• quote  
• compiler-macro-function  
• define-compiler-macro  
• defmacro  
• macro-function  
• macroexpand  
• define-symbol-macro  
• symbol-macrolet  
• *macroexpand-hook*  
• proclaim  
• declaim  
• declare  
• ignore  
• dynamic-extent  
• type  
• inline  
• ftype  
• declaration  
• optimize  
• special  
• locally  
• the  
• special-operator-p  
• constantp   

Types and Classes
• Introduction (Types and Classes)  
• Types  
• Classes  
• Types and Classes Dictionary   

Types
• Data Type Definition  
• Type Relationships  
• Type Specifiers   

Classes
• Introduction to Classes  
• Defining Classes  
• Creating Instances of Classes  
• Inheritance  
• Determining the Class Precedence List  
• Redefining Classes  
• Integrating Types and Classes   

Introduction to Classes
• Standard Metaclasses   

Inheritance
• Examples of Inheritance  
• Inheritance of Class Options   

Determining the Class Precedence List
• Topological Sorting  
• Examples of Class Precedence List Determination   

Redefining Classes
• Modifying the Structure of Instances  
• Initializing Newly Added Local Slots (Redefining Classes)  
• Customizing Class Redefinition   

Types and Classes Dictionary
• nil (Type)  
• boolean  
• function (System Class)  
• compiled-function  
• generic-function  
• standard-generic-function  
• class  
• built-in-class  
• structure-class  
• standard-class  
• method  
• standard-method  
• structure-object  
• standard-object  
• method-combination  
• t (System Class)  
• satisfies  
• member (Type Specifier)  
• not (Type Specifier)  
• and (Type Specifier)  
• or (Type Specifier)  
• values (Type Specifier)  
• eql (Type Specifier)  
• coerce  
• deftype  
• subtypep  
• type-of  
• typep  
• type-error  
• type-error-datum  
• simple-type-error   

Data and Control Flow
• Generalized Reference  
• Transfer of Control to an Exit Point  
• Data and Control Flow Dictionary   

Generalized Reference
• Overview of Places and Generalized Reference  
• Kinds of Places  
• Treatment of Other Macros Based on SETF   

Overview of Places and Generalized Reference
• Evaluation of Subforms to Places  
• Examples of Evaluation of Subforms to Places  
• Setf Expansions  
• Examples of Setf Expansions   

Kinds of Places
• Variable Names as Places  
• Function Call Forms as Places  
• VALUES Forms as Places  
• THE Forms as Places  
• APPLY Forms as Places  
• Setf Expansions and Places  
• Macro Forms as Places  
• Symbol Macros as Places  
• Other Compound Forms as Places   

Data and Control Flow Dictionary
• apply  
• defun  
• fdefinition  
• fboundp  
• fmakunbound  
• flet  
• funcall  
• function (Special Operator)  
• function-lambda-expression  
• functionp  
• compiled-function-p  
• call-arguments-limit  
• lambda-list-keywords  
• lambda-parameters-limit  
• defconstant  
• defparameter  
• destructuring-bind  
• let  
• progv  
• setq  
• psetq  
• block  
• catch  
• go  
• return-from  
• return  
• tagbody  
• throw  
• unwind-protect  
• nil  
• not  
• t  
• eq  
• eql  
• equal  
• equalp  
• identity  
• complement  
• constantly  
• every  
• and  
• cond  
• if  
• or  
• when  
• case  
• typecase  
• multiple-value-bind  
• multiple-value-call  
• multiple-value-list  
• multiple-value-prog1  
• multiple-value-setq  
• values  
• values-list  
• multiple-values-limit  
• nth-value  
• prog  
• prog1  
• progn  
• define-modify-macro  
• defsetf  
• define-setf-expander  
• get-setf-expansion  
• setf  
• shiftf  
• rotatef  
• control-error  
• program-error  
• undefined-function   

Iteration
• The LOOP Facility  
• Iteration Dictionary   

The LOOP Facility
• Overview of the Loop Facility  
• Variable Initialization and Stepping Clauses  
• Value Accumulation Clauses  
• Termination Test Clauses  
• Unconditional Execution Clauses  
• Conditional Execution Clauses  
• Miscellaneous Clauses  
• Examples of Miscellaneous Loop Features  
• Notes about Loop   

Overview of the Loop Facility
• Simple vs Extended Loop  
• Simple Loop  
• Extended Loop  
• Loop Keywords  
• Parsing Loop Clauses  
• Expanding Loop Forms  
• Summary of Loop Clauses  
• Summary of Variable Initialization and Stepping Clauses  
• Summary of Value Accumulation Clauses  
• Summary of Termination Test Clauses  
• Summary of Unconditional Execution Clauses  
• Summary of Conditional Execution Clauses  
• Summary of Miscellaneous Clauses  
• Order of Execution  
• Destructuring  
• Restrictions on Side-Effects   

Variable Initialization and Stepping Clauses
• Iteration Control  
• The for-as-arithmetic subclause  
• Examples of for-as-arithmetic subclause  
• The for-as-in-list subclause  
• Examples of for-as-in-list subclause  
• The for-as-on-list subclause  
• Examples of for-as-on-list subclause  
• The for-as-equals-then subclause  
• Examples of for-as-equals-then subclause  
• The for-as-across subclause  
• Examples of for-as-across subclause  
• The for-as-hash subclause  
• The for-as-package subclause  
• Examples of for-as-package subclause  
• Local Variable Initializations  
• Examples of WITH clause   

Value Accumulation Clauses
• Examples of COLLECT clause  
• Examples of APPEND and NCONC clauses  
• Examples of COUNT clause  
• Examples of MAXIMIZE and MINIMIZE clauses  
• Examples of SUM clause   

Termination Test Clauses
• Examples of REPEAT clause  
• Examples of ALWAYS  
• Examples of WHILE and UNTIL clauses   

Unconditional Execution Clauses
• Examples of unconditional execution   

Conditional Execution Clauses
• Examples of WHEN clause   

Miscellaneous Clauses
• Control Transfer Clauses  
• Examples of NAMED clause  
• Initial and Final Execution   

Examples of Miscellaneous Loop Features
• Examples of clause grouping   

Iteration Dictionary
• do  
• dotimes  
• dolist  
• loop  
• loop-finish   

Objects
• Object Creation and Initialization  
• Changing the Class of an Instance  
• Reinitializing an Instance  
• Meta-Objects  
• Slots  
• Generic Functions and Methods  
• Objects Dictionary   

Object Creation and Initialization
• Initialization Arguments  
• Declaring the Validity of Initialization Arguments  
• Defaulting of Initialization Arguments  
• Rules for Initialization Arguments  
• Shared-Initialize  
• Initialize-Instance  
• Definitions of Make-Instance and Initialize-Instance   

Changing the Class of an Instance
• Modifying the Structure of the Instance  
• Initializing Newly Added Local Slots (Changing the Class of an Instance)  
• Customizing the Change of Class of an Instance   

Reinitializing an Instance
• Customizing Reinitialization   

Meta-Objects
• Standard Meta-objects   

Slots
• Introduction to Slots  
• Accessing Slots  
• Inheritance of Slots and Slot Options   

Generic Functions and Methods
• Introduction to Generic Functions  
• Introduction to Methods  
• Agreement on Parameter Specializers and Qualifiers  
• Congruent Lambda-lists for all Methods of a Generic Function  
• Keyword Arguments in Generic Functions and Methods  
• Method Selection and Combination  
• Inheritance of Methods   

Keyword Arguments in Generic Functions and Methods
• Examples of Keyword Arguments in Generic Functions and Methods   

Method Selection and Combination
• Determining the Effective Method  
• Selecting the Applicable Methods  
• Sorting the Applicable Methods by Precedence Order  
• Applying method combination to the sorted list of applicable methods  
• Standard Method Combination  
• Declarative Method Combination  
• Built-in Method Combination Types   

Objects Dictionary
• function-keywords  
• ensure-generic-function  
• allocate-instance  
• reinitialize-instance  
• shared-initialize  
• update-instance-for-different-class  
• update-instance-for-redefined-class  
• change-class  
• slot-boundp  
• slot-exists-p  
• slot-makunbound  
• slot-missing  
• slot-unbound  
• slot-value  
• method-qualifiers  
• no-applicable-method  
• no-next-method  
• remove-method  
• make-instance  
• make-instances-obsolete  
• make-load-form  
• make-load-form-saving-slots  
• with-accessors  
• with-slots  
• defclass  
• defgeneric  
• defmethod  
• find-class  
• next-method-p  
• call-method  
• call-next-method  
• compute-applicable-methods  
• define-method-combination  
• find-method  
• add-method  
• initialize-instance  
• class-name  
• (setf class-name)  
• class-of  
• unbound-slot  
• unbound-slot-instance   

Structures
• Structures Dictionary   

Structures Dictionary
• defstruct  
• copy-structure   

Conditions
• Condition System Concepts  
• Conditions Dictionary   

Condition System Concepts
• Condition Types  
• Creating Conditions  
• Printing Conditions  
• Signaling and Handling Conditions  
• Assertions  
• Notes about the Condition System`s Background   

Condition Types
• Serious Conditions   

Creating Conditions
• Condition Designators   

Printing Conditions
• Recommended Style in Condition Reporting  
• Capitalization and Punctuation in Condition Reports  
• Leading and Trailing Newlines in Condition Reports  
• Embedded Newlines in Condition Reports  
• Note about Tabs in Condition Reports  
• Mentioning Containing Function in Condition Reports   

Signaling and Handling Conditions
• Signaling  
• Resignaling a Condition  
• Restarts  
• Interactive Use of Restarts  
• Interfaces to Restarts  
• Restart Tests  
• Associating a Restart with a Condition   

Conditions Dictionary
• condition  
• warning  
• style-warning  
• serious-condition  
• error (Condition Type)  
• cell-error  
• cell-error-name  
• parse-error  
• storage-condition  
• assert  
• error  
• cerror  
• check-type  
• simple-error  
• invalid-method-error  
• method-combination-error  
• signal  
• simple-condition  
• simple-condition-format-control  
• warn  
• simple-warning  
• invoke-debugger  
• break  
• *debugger-hook*  
• *break-on-signals*  
• handler-bind  
• handler-case  
• ignore-errors  
• define-condition  
• make-condition  
• restart  
• compute-restarts  
• find-restart  
• invoke-restart  
• invoke-restart-interactively  
• restart-bind  
• restart-case  
• restart-name  
• with-condition-restarts  
• with-simple-restart  
• abort (Restart)  
• continue  
• muffle-warning  
• store-value  
• use-value  
• abort (Function)   

Symbols
• Symbol Concepts  
• Symbols Dictionary   

Symbols Dictionary
• symbol  
• keyword  
• symbolp  
• keywordp  
• make-symbol  
• copy-symbol  
• gensym  
• *gensym-counter*  
• gentemp  
• symbol-function  
• symbol-name  
• symbol-package  
• symbol-plist  
• symbol-value  
• get  
• remprop  
• boundp  
• makunbound  
• set  
• unbound-variable   

Packages
• Package Concepts  
• Packages Dictionary   

Package Concepts
• Introduction to Packages  
• Standardized Packages   

Introduction to Packages
• Package Names and Nicknames  
• Symbols in a Package  
• Internal and External Symbols  
• Package Inheritance  
• Accessibility of Symbols in a Package  
• Locating a Symbol in a Package  
• Prevention of Name Conflicts in Packages   

Standardized Packages
• The COMMON-LISP Package  
• Constraints on the COMMON-LISP Package for Conforming Implementations  
• Constraints on the COMMON-LISP Package for Conforming Programs  
• Some Exceptions to Constraints on the COMMON-LISP Package for Conforming Programs  
• The COMMON-LISP-USER Package  
• The KEYWORD Package  
• Interning a Symbol in the KEYWORD Package  
• Notes about The KEYWORD Package  
• Implementation-Defined Packages   

Packages Dictionary
• package  
• export  
• find-symbol  
• find-package  
• find-all-symbols  
• import  
• list-all-packages  
• rename-package  
• shadow  
• shadowing-import  
• delete-package  
• make-package  
• with-package-iterator  
• unexport  
• unintern  
• in-package  
• unuse-package  
• use-package  
• defpackage  
• do-symbols  
• intern  
• package-name  
• package-nicknames  
• package-shadowing-symbols  
• package-use-list  
• package-used-by-list  
• packagep  
• *package*  
• package-error  
• package-error-package   

Numbers
• Number Concepts  
• Numbers Dictionary   

Number Concepts
• Numeric Operations  
• Implementation-Dependent Numeric Constants  
• Rational Computations  
• Floating-point Computations  
• Complex Computations  
• Interval Designators  
• Random-State Operations   

Numeric Operations
• Associativity and Commutativity in Numeric Operations  
• Examples of Associativity and Commutativity in Numeric Operations  
• Contagion in Numeric Operations  
• Viewing Integers as Bits and Bytes  
• Logical Operations on Integers  
• Byte Operations on Integers   

Rational Computations
• Rule of Unbounded Rational Precision  
• Rule of Canonical Representation for Rationals  
• Rule of Float Substitutability   

Floating-point Computations
• Rule of Float and Rational Contagion  
• Examples of Rule of Float and Rational Contagion  
• Rule of Float Approximation  
• Rule of Float Underflow and Overflow  
• Rule of Float Precision Contagion   

Complex Computations
• Rule of Complex Substitutability  
• Rule of Complex Contagion  
• Rule of Canonical Representation for Complex Rationals  
• Examples of Rule of Canonical Representation for Complex Rationals  
• Principal Values and Branch Cuts   

Numbers Dictionary
• number  
• complex (System Class)  
• real  
• float (System Class)  
• short-float  
• rational (System Class)  
• ratio  
• integer  
• signed-byte  
• unsigned-byte  
• mod (System Class)  
• bit (System Class)  
• fixnum  
• bignum  
• =  
• max  
• minusp  
• zerop  
• floor  
• sin  
• asin  
• pi  
• sinh  
• *  
• +  
• -  
• /  
• 1+  
• abs  
• evenp  
• exp  
• gcd  
• incf  
• lcm  
• log  
• mod (Function)  
• signum  
• sqrt  
• random-state  
• make-random-state  
• random  
• random-state-p  
• *random-state*  
• numberp  
• cis  
• complex  
• complexp  
• conjugate  
• phase  
• realpart  
• upgraded-complex-part-type  
• realp  
• numerator  
• rational (Function)  
• rationalp  
• ash  
• integer-length  
• integerp  
• parse-integer  
• boole  
• boole-1  
• logand  
• logbitp  
• logcount  
• logtest  
• byte  
• deposit-field  
• dpb  
• ldb  
• ldb-test  
• mask-field  
• most-positive-fixnum  
• decode-float  
• float  
• floatp  
• most-positive-short-float  
• short-float-epsilon  
• arithmetic-error  
• arithmetic-error-operands  
• division-by-zero  
• floating-point-invalid-operation  
• floating-point-inexact  
• floating-point-overflow  
• floating-point-underflow   

Characters
• Character Concepts  
• Characters Dictionary   

Character Concepts
• Introduction to Characters  
• Introduction to Scripts and Repertoires  
• Character Attributes  
• Character Categories  
• Identity of Characters  
• Ordering of Characters  
• Character Names  
• Treatment of Newline during Input and Output  
• Character Encodings  
• Documentation of Implementation-Defined Scripts   

Introduction to Scripts and Repertoires
• Character Scripts  
• Character Repertoires   

Character Categories
• Graphic Characters  
• Alphabetic Characters  
• Characters With Case  
• Uppercase Characters  
• Lowercase Characters  
• Corresponding Characters in the Other Case  
• Case of Implementation-Defined Characters  
• Numeric Characters  
• Alphanumeric Characters  
• Digits in a Radix   

Characters Dictionary
• character (System Class)  
• base-char  
• standard-char  
• extended-char  
• char=  
• character  
• characterp  
• alpha-char-p  
• alphanumericp  
• digit-char  
• digit-char-p  
• graphic-char-p  
• standard-char-p  
• char-upcase  
• upper-case-p  
• char-code  
• char-int  
• code-char  
• char-code-limit  
• char-name  
• name-char   

Conses
• Cons Concepts  
• Conses Dictionary   

Cons Concepts
• Conses as Trees  
• Conses as Lists   

Conses as Trees
• General Restrictions on Parameters that must be Trees   

Conses as Lists
• Lists as Association Lists  
• Lists as Sets  
• General Restrictions on Parameters that must be Lists   

Conses Dictionary
• list (System Class)  
• null (System Class)  
• cons (System Class)  
• atom (Type)  
• cons  
• consp  
• atom  
• rplaca  
• car  
• copy-tree  
• sublis  
• subst  
• tree-equal  
• copy-list  
• list (Function)  
• list-length  
• listp  
• make-list  
• push  
• pop  
• first  
• nth  
• endp  
• null  
• nconc  
• append  
• revappend  
• butlast  
• last  
• ldiff  
• nthcdr  
• rest  
• member (Function)  
• mapc  
• acons  
• assoc  
• copy-alist  
• pairlis  
• rassoc  
• get-properties  
• getf  
• remf  
• intersection  
• adjoin  
• pushnew  
• set-difference  
• set-exclusive-or  
• subsetp  
• union   

Arrays
• Array Concepts  
• Arrays Dictionary   

Array Concepts
• Array Elements  
• Specialized Arrays   

Array Elements
• Array Indices  
• Array Dimensions  
• Implementation Limits on Individual Array Dimensions  
• Array Rank  
• Vectors  
• Fill Pointers  
• Multidimensional Arrays  
• Storage Layout for Multidimensional Arrays  
• Implementation Limits on Array Rank   

Specialized Arrays
• Array Upgrading  
• Required Kinds of Specialized Arrays   

Arrays Dictionary
• array  
• simple-array  
• vector (System Class)  
• simple-vector  
• bit-vector  
• simple-bit-vector  
• make-array  
• adjust-array  
• adjustable-array-p  
• aref  
• array-dimension  
• array-dimensions  
• array-element-type  
• array-has-fill-pointer-p  
• array-displacement  
• array-in-bounds-p  
• array-rank  
• array-row-major-index  
• array-total-size  
• arrayp  
• fill-pointer  
• row-major-aref  
• upgraded-array-element-type  
• array-dimension-limit  
• array-rank-limit  
• array-total-size-limit  
• simple-vector-p  
• svref  
• vector  
• vector-pop  
• vector-push  
• vectorp  
• bit (Array)  
• bit-and  
• bit-vector-p  
• simple-bit-vector-p   

Strings
• String Concepts  
• Strings Dictionary   

String Concepts
• Implications of Strings Being Arrays  
• Subtypes of STRING   

Strings Dictionary
• string (System Class)  
• base-string  
• simple-string  
• simple-base-string  
• simple-string-p  
• char  
• string  
• string-upcase  
• string-trim  
• string=  
• stringp  
• make-string   

Sequences
• Sequence Concepts  
• Rules about Test Functions  
• Sequences Dictionary   

Sequence Concepts
• General Restrictions on Parameters that must be Sequences   

Rules about Test Functions
• Satisfying a Two-Argument Test  
• Satisfying a One-Argument Test   

Satisfying a Two-Argument Test
• Examples of Satisfying a Two-Argument Test   

Satisfying a One-Argument Test
• Examples of Satisfying a One-Argument Test   

Sequences Dictionary
• sequence  
• copy-seq  
• elt  
• fill  
• make-sequence  
• subseq  
• map  
• map-into  
• reduce  
• count  
• length  
• reverse  
• sort  
• find  
• position  
• search  
• mismatch  
• replace  
• substitute  
• concatenate  
• merge  
• remove  
• remove-duplicates   

Hash Tables
• Hash Table Concepts  
• Hash Tables Dictionary   

Hash Table Concepts
• Hash-Table Operations  
• Modifying Hash Table Keys   

Modifying Hash Table Keys
• Visible Modification of Objects with respect to EQ and EQL  
• Visible Modification of Objects with respect to EQUAL  
• Visible Modification of Conses with respect to EQUAL  
• Visible Modification of Bit Vectors and Strings with respect to EQUAL  
• Visible Modification of Objects with respect to EQUALP  
• Visible Modification of Structures with respect to EQUALP  
• Visible Modification of Arrays with respect to EQUALP  
• Visible Modification of Hash Tables with respect to EQUALP  
• Visible Modifications by Language Extensions   

Hash Tables Dictionary
• hash-table  
• make-hash-table  
• hash-table-p  
• hash-table-count  
• hash-table-rehash-size  
• hash-table-rehash-threshold  
• hash-table-size  
• hash-table-test  
• gethash  
• remhash  
• maphash  
• with-hash-table-iterator  
• clrhash  
• sxhash   

Filenames
• Overview of Filenames  
• Pathnames  
• Logical Pathnames  
• Filenames Dictionary   

Overview of Filenames
• Namestrings as Filenames  
• Pathnames as Filenames  
• Parsing Namestrings Into Pathnames   

Pathnames
• Pathname Components  
• Interpreting Pathname Component Values  
• Merging Pathnames   

Pathname Components
• The Pathname Host Component  
• The Pathname Device Component  
• The Pathname Directory Component  
• The Pathname Name Component  
• The Pathname Type Component  
• The Pathname Version Component   

Interpreting Pathname Component Values
• Strings in Component Values  
• Special Characters in Pathname Components  
• Case in Pathname Components  
• Local Case in Pathname Components  
• Common Case in Pathname Components  
• Special Pathname Component Values  
• NIL as a Component Value  
• ->WILD as a Component Value  
• ->UNSPECIFIC as a Component Value  
• Relation between component values NIL and ->UNSPECIFIC  
• Restrictions on Wildcard Pathnames  
• Restrictions on Examining Pathname Components  
• Restrictions on Examining a Pathname Host Component  
• Restrictions on Examining a Pathname Device Component  
• Restrictions on Examining a Pathname Directory Component  
• Directory Components in Non-Hierarchical File Systems  
• Restrictions on Examining a Pathname Name Component  
• Restrictions on Examining a Pathname Type Component  
• Restrictions on Examining a Pathname Version Component  
• Notes about the Pathname Version Component  
• Restrictions on Constructing Pathnames   

Merging Pathnames
• Examples of Merging Pathnames   

Logical Pathnames
• Syntax of Logical Pathname Namestrings  
• Logical Pathname Components   

Syntax of Logical Pathname Namestrings
• Additional Information about Parsing Logical Pathname Namestrings  
• The Host part of a Logical Pathname Namestring  
• The Device part of a Logical Pathname Namestring  
• The Directory part of a Logical Pathname Namestring  
• The Type part of a Logical Pathname Namestring  
• The Version part of a Logical Pathname Namestring  
• Wildcard Words in a Logical Pathname Namestring  
• Lowercase Letters in a Logical Pathname Namestring  
• Other Syntax in a Logical Pathname Namestring   

Logical Pathname Components
• Unspecific Components of a Logical Pathname  
• Null Strings as Components of a Logical Pathname   

Filenames Dictionary
• pathname (System Class)  
• logical-pathname (System Class)  
• pathname  
• make-pathname  
• pathnamep  
• pathname-host  
• load-logical-pathname-translations  
• logical-pathname-translations  
• logical-pathname  
• *default-pathname-defaults*  
• namestring  
• parse-namestring  
• wild-pathname-p  
• pathname-match-p  
• translate-logical-pathname  
• translate-pathname  
• merge-pathnames   

Files
• File System Concepts  
• Files Dictionary   

File System Concepts
• Coercion of Streams to Pathnames  
• File Operations on Open and Closed Streams  
• Truenames   

Truenames
• Examples of Truenames   

Files Dictionary
• directory  
• probe-file  
• ensure-directories-exist  
• truename  
• file-author  
• file-write-date  
• rename-file  
• delete-file  
• file-error  
• file-error-pathname   

Streams
• Stream Concepts  
• Streams Dictionary   

Stream Concepts
• Introduction to Streams  
• Stream Variables  
• Stream Arguments to Standardized Functions  
• Restrictions on Composite Streams   

Introduction to Streams
• Abstract Classifications of Streams (Introduction to Streams)  
• Input  
• Open and Closed Streams  
• Interactive Streams  
• Abstract Classifications of Streams  
• File Streams  
• Other Subclasses of Stream   

Streams Dictionary
• stream  
• broadcast-stream  
• concatenated-stream  
• echo-stream  
• file-stream  
• string-stream  
• synonym-stream  
• two-way-stream  
• input-stream-p  
• interactive-stream-p  
• open-stream-p  
• stream-element-type  
• streamp  
• read-byte  
• write-byte  
• peek-char  
• read-char  
• read-char-no-hang  
• terpri  
• unread-char  
• write-char  
• read-line  
• write-string  
• read-sequence  
• write-sequence  
• file-length  
• file-position  
• file-string-length  
• open  
• stream-external-format  
• with-open-file  
• close  
• with-open-stream  
• listen  
• clear-input  
• finish-output  
• y-or-n-p  
• make-synonym-stream  
• synonym-stream-symbol  
• broadcast-stream-streams  
• make-broadcast-stream  
• make-two-way-stream  
• two-way-stream-input-stream  
• echo-stream-input-stream  
• make-echo-stream  
• concatenated-stream-streams  
• make-concatenated-stream  
• get-output-stream-string  
• make-string-input-stream  
• make-string-output-stream  
• with-input-from-string  
• with-output-to-string  
• *debug-io*  
• *terminal-io*  
• stream-error  
• stream-error-stream  
• end-of-file   

Printer
• The Lisp Printer  
• The Lisp Pretty Printer  
• Formatted Output  
• Printer Dictionary   

The Lisp Printer
• Overview of The Lisp Printer  
• Printer Dispatching  
• Default Print-Object Methods  
• Examples of Printer Behavior   

Overview of The Lisp Printer
• Multiple Possible Textual Representations  
• Printer Escaping   

Default Print-Object Methods
• Printing Numbers  
• Printing Integers  
• Printing Ratios  
• Printing Floats  
• Printing Complexes  
• Note about Printing Numbers  
• Printing Characters  
• Printing Symbols  
• Package Prefixes for Symbols  
• Effect of Readtable Case on the Lisp Printer  
• Examples of Effect of Readtable Case on the Lisp Printer  
• Printing Strings  
• Printing Lists and Conses  
• Printing Bit Vectors  
• Printing Other Vectors  
• Printing Other Arrays  
• Examples of Printing Arrays  
• Printing Random States  
• Printing Pathnames  
• Printing Structures  
• Printing Other Objects   

The Lisp Pretty Printer
• Pretty Printer Concepts  
• Examples of using the Pretty Printer  
• Notes about the Pretty Printer`s Background   

Pretty Printer Concepts
• Dynamic Control of the Arrangement of Output  
• Format Directive Interface  
• Compiling Format Strings  
• Pretty Print Dispatch Tables  
• Pretty Printer Margins   

Formatted Output
• FORMAT Basic Output  
• FORMAT Radix Control  
• FORMAT Floating-Point Printers  
• FORMAT Printer Operations  
• FORMAT Pretty Printer Operations  
• FORMAT Layout Control  
• FORMAT Control-Flow Operations  
• FORMAT Miscellaneous Operations  
• FORMAT Miscellaneous Pseudo-Operations  
• Additional Information about FORMAT Operations  
• Examples of FORMAT  
• Notes about FORMAT   

FORMAT Basic Output
• Tilde C-> Character  
• Tilde Percent-> Newline  
• Tilde Ampersand-> Fresh-Line  
• Tilde Vertical-Bar-> Page  
• Tilde Tilde-> Tilde   

FORMAT Radix Control
• Tilde R-> Radix  
• Tilde D-> Decimal  
• Tilde B-> Binary  
• Tilde O-> Octal  
• Tilde X-> Hexadecimal   

FORMAT Floating-Point Printers
• Tilde F-> Fixed-Format Floating-Point  
• Tilde E-> Exponential Floating-Point  
• Tilde G-> General Floating-Point  
• Tilde Dollarsign-> Monetary Floating-Point   

FORMAT Printer Operations
• Tilde A-> Aesthetic  
• Tilde S-> Standard  
• Tilde W-> Write   

FORMAT Pretty Printer Operations
• Tilde Underscore-> Conditional Newline  
• Tilde Less-Than-Sign-> Logical Block  
• Tilde I-> Indent  
• Tilde Slash-> Call Function   

FORMAT Layout Control
• Tilde T-> Tabulate  
• Tilde Less-Than-Sign-> Justification  
• Tilde Greater-Than-Sign-> End of Justification   

FORMAT Control-Flow Operations
• Tilde Asterisk-> Go-To  
• Tilde Left-Bracket-> Conditional Expression  
• Tilde Right-Bracket-> End of Conditional Expression  
• Tilde Left-Brace-> Iteration  
• Tilde Right-Brace-> End of Iteration  
• Tilde Question-Mark-> Recursive Processing   

FORMAT Miscellaneous Operations
• Tilde Left-Paren-> Case Conversion  
• Tilde Right-Paren-> End of Case Conversion  
• Tilde P-> Plural   

FORMAT Miscellaneous Pseudo-Operations
• Tilde Semicolon-> Clause Separator  
• Tilde Circumflex-> Escape Upward  
• Tilde Newline-> Ignored Newline   

Additional Information about FORMAT Operations
• Nesting of FORMAT Operations  
• Missing and Additional FORMAT Arguments  
• Additional FORMAT Parameters  
• Undefined FORMAT Modifier Combinations   

Printer Dictionary
• copy-pprint-dispatch  
• formatter  
• pprint-dispatch  
• pprint-exit-if-list-exhausted  
• pprint-fill  
• pprint-indent  
• pprint-logical-block  
• pprint-newline  
• pprint-pop  
• pprint-tab  
• print-object  
• print-unreadable-object  
• set-pprint-dispatch  
• write  
• write-to-string  
• *print-array*  
• *print-base*  
• *print-case*  
• *print-circle*  
• *print-escape*  
• *print-gensym*  
• *print-level*  
• *print-lines*  
• *print-miser-width*  
• *print-pprint-dispatch*  
• *print-pretty*  
• *print-readably*  
• *print-right-margin*  
• print-not-readable  
• print-not-readable-object  
• format   

Reader
• Reader Concepts  
• Reader Dictionary   

Reader Concepts
• Dynamic Control of the Lisp Reader  
• Effect of Readtable Case on the Lisp Reader  
• Argument Conventions of Some Reader Functions   

Effect of Readtable Case on the Lisp Reader
• Examples of Effect of Readtable Case on the Lisp Reader   

Argument Conventions of Some Reader Functions
• The EOF-ERROR-P argument  
• The RECURSIVE-P argument   

Reader Dictionary
• readtable  
• copy-readtable  
• make-dispatch-macro-character  
• read  
• read-delimited-list  
• read-from-string  
• readtable-case  
• readtablep  
• set-dispatch-macro-character  
• set-macro-character  
• set-syntax-from-char  
• with-standard-io-syntax  
• *read-base*  
• *read-default-float-format*  
• *read-eval*  
• *read-suppress*  
• *readtable*  
• reader-error   

System Construction
• System Construction Concepts  
• System Construction Dictionary   

System Construction Concepts
• Loading  
• Features   

Features
• Feature Expressions  
• Examples of Feature Expressions   

System Construction Dictionary
• compile-file  
• compile-file-pathname  
• load  
• with-compilation-unit  
• *features*  
• *compile-file-pathname*  
• *load-pathname*  
• *compile-print*  
• *load-print*  
• *modules*  
• provide   

Environment
• The External Environment  
• Environment Dictionary   

The External Environment
• Top level loop  
• Debugging Utilities  
• Environment Inquiry  
• Time   

Time
• Decoded Time  
• Universal Time  
• Internal Time  
• Seconds   

Environment Dictionary
• decode-universal-time  
• encode-universal-time  
• get-universal-time  
• sleep  
• apropos  
• describe  
• describe-object  
• trace  
• step  
• time  
• internal-time-units-per-second  
• get-internal-real-time  
• get-internal-run-time  
• disassemble  
• documentation  
• room  
• ed  
• inspect  
• dribble  
• -  
• +  
• *  
• /  
• lisp-implementation-type  
• short-site-name  
• machine-instance  
• machine-type  
• machine-version  
• software-type  
• user-homedir-pathname   

Glossary
• Glossary   

Appendix
• Removed Language Features   

Removed Language Features
• Requirements for removed and deprecated features  
• Removed Types  
• Removed Operators  
• Removed Argument Conventions  
• Removed Variables  
• Removed Reader Syntax  
• Packages No Longer Required  

Next: , Previous: , Up: (dir)  

gcl-2.6.14/info/gcl/with_002dcompilation_002dunit.html0000644000175000017500000001222414360276512020746 0ustar cammcamm with-compilation-unit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: System Construction Dictionary  

24.2.4 with-compilation-unit [Macro]

with-compilation-unit ([[!option]]) {form}* ⇒ {result}*

option ::=:override override

Arguments and Values::

override—a generalized boolean; evaluated. The default is nil.

forms—an implicit progn.

results—the values returned by the forms.

Description::

Executes forms from left to right. Within the dynamic environment of with-compilation-unit, actions deferred by the compiler until the end of compilation will be deferred until the end of the outermost call to with-compilation-unit.

The set of options permitted may be extended by the implementation, but the only standardized keyword is :override.

If nested dynamically only the outer call to with-compilation-unit has any effect unless the value associated with :override is true, in which case warnings are deferred only to the end of the innermost call for which override is true.

The function compile-file provides the effect of 

 (with-compilation-unit (:override nil) ...)

around its code.

Any implementation-dependent extensions can only be provided as the result of an explicit programmer request by use of an implementation-dependent keyword. Implementations are forbidden from attaching additional meaning to a use of this macro which involves either no keywords or just the keyword :override.

Examples::

If an implementation would normally defer certain kinds of warnings, such as warnings about undefined functions, to the end of a compilation unit (such as a file), the following example shows how to cause those warnings to be deferred to the end of the compilation of several files. 

 (defun compile-files (&rest files)
   (with-compilation-unit ()
     (mapcar #'(lambda (file) (compile-file file)) files)))

 (compile-files "A" "B" "C")

Note however that if the implementation does not normally defer any warnings, use of with-compilation-unit might not have any effect.

See Also::

compile , compile-file

Next: , Previous: , Up: System Construction Dictionary  

gcl-2.6.14/info/gcl/Modifying-the-Structure-of-Instances.html0000644000175000017500000000643714360276512022423 0ustar cammcamm Modifying the Structure of Instances (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Redefining Classes  

4.3.6.1 Modifying the Structure of Instances

[Reviewer Note by Barmar: What about shared slots that are deleted?]

The first step modifies the structure of instances of the redefined class to conform to its new class definition. Local slots specified by the new class definition that are not specified as either local or shared by the old class are added, and slots not specified as either local or shared by the new class definition that are specified as local by the old class are discarded. The names of these added and discarded slots are passed as arguments to update-instance-for-redefined-class as described in the next section.

The values of local slots specified by both the new and old classes are retained. If such a local slot was unbound, it remains unbound.

The value of a slot that is specified as shared in the old class and as local in the new class is retained. If such a shared slot was unbound, the local slot is unbound.

gcl-2.6.14/info/gcl/Package-Names-and-Nicknames.html0000644000175000017500000000545414360276512020433 0ustar cammcamm Package Names and Nicknames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.1 Package Names and Nicknames

Each package has a name (a string) and perhaps some nicknames (also strings). These are assigned when the package is created and can be changed later.

There is a single namespace for packages. The function find-package translates a package name or nickname into the associated package. The function package-name returns the name of a package. The function package-nicknames returns a list of all nicknames for a package. rename-package removes a package’s current name and nicknames and replaces them with new ones specified by the caller.

gcl-2.6.14/info/gcl/Complex-Computations.html0000644000175000017500000000641414360276512017460 0ustar cammcamm Complex Computations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Number Concepts  

12.1.5 Complex Computations

The following rules apply to complex computations:

• Rule of Complex Substitutability  
• Rule of Complex Contagion  
• Rule of Canonical Representation for Complex Rationals  
• Examples of Rule of Canonical Representation for Complex Rationals  
• Principal Values and Branch Cuts  
gcl-2.6.14/info/gcl/Declaration-Identifiers.html0000644000175000017500000000620314360276512020052 0ustar cammcamm Declaration Identifiers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Declarations  

3.3.3 Declaration Identifiers

Figure 3–9 shows a list of all declaration identifiers

defined by this standard. 

  declaration     ignore     special  
  dynamic-extent  inline     type     
  ftype           notinline           
  ignorable       optimize            

  Figure 3–9: Common Lisp Declaration Identifiers

An implementation is free to support other (implementation-defined) declaration identifiers as well. A warning might be issued if a declaration identifier is not among those defined above, is not defined by the implementation, is not a type name, and has not been declared in a declaration proclamation.

• Shorthand notation for Type Declarations  
gcl-2.6.14/info/gcl/Conforming-Implementations.html0000644000175000017500000000732514360276512020637 0ustar cammcamm Conforming Implementations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conformance  

1.5.1 Conforming Implementations

A conforming implementation shall adhere to the requirements outlined in this section.

• Required Language Features  
• Documentation of Implementation-Dependent Features  
• Documentation of Extensions  
• Treatment of Exceptional Situations  
• Resolution of Apparent Conflicts in Exceptional Situations  
• Examples of Resolution of Apparent Conflict in Exceptional Situations  
• Conformance Statement  
gcl-2.6.14/info/gcl/Extent.html0000644000175000017500000001137214360276512014634 0ustar cammcamm Extent (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation  

3.1.6 Extent

Contorted-example works only because the function named by f is invoked during the extent of the exit point. Once the flow of execution has left the block, the exit point is disestablished. For example: 

 (defun invalid-example ()
   (let ((y (block here #'(lambda (z) (return-from here z)))))
     (if (numberp y) y (funcall y 5))))

One might expect the call (invalid-example) to produce 5 by the following incorrect reasoning: let binds y to the value of block; this value is a function resulting from the lambda expression. Because y is not a number, it is invoked on the value 5. The return-from should then return this value from the exit point named here, thereby exiting from the block again and giving y the value 5 which, being a number, is then returned as the value of the call to invalid-example.

The argument fails only because exit points have dynamic extent. The argument is correct up to the execution of return-from. The execution of return-from should signal an error of type control-error, however, not because it cannot refer to the exit point, but because it does correctly refer to an exit point and that exit point has been disestablished.

A reference by name to a dynamic exit point binding such as a catch tag refers to the most recently established binding of that name that has not been disestablished. For example: 

 (defun fun1 (x)
   (catch 'trap (+ 3 (fun2 x))))
 (defun fun2 (y)
   (catch 'trap (* 5 (fun3 y))))
 (defun fun3 (z)
   (throw 'trap z))

Consider the call (fun1 7). The result is 10. At the time the throw is executed, there are two outstanding catchers with the name trap: one established within procedure fun1, and the other within procedure fun2. The latter is the more recent, and so the value 7 is returned from catch in fun2. Viewed from within fun3, the catch in fun2 shadows the one in fun1. Had fun2 been defined as 

 (defun fun2 (y)
   (catch 'snare (* 5 (fun3 y))))

then the two exit points would have different names, and therefore the one in fun1 would not be shadowed. The result would then have been 7.

Next: , Previous: , Up: Evaluation  

gcl-2.6.14/info/gcl/Indirection-in-Modified-BNF-Syntax.html0000644000175000017500000000545114360276512021646 0ustar cammcamm Indirection in Modified BNF Syntax (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Notational Conventions  

1.4.1.4 Indirection in Modified BNF Syntax

An indirection extension is introduced in order to make this new syntax more readable:

!O

If O is a non-terminal symbol, the right-hand side of its definition is substituted for the entire expression !O. For example, the following BNF is equivalent to the BNF in the previous example:

(x [[!O]] y)

O ::=A | B* | C

gcl-2.6.14/info/gcl/_002aprint_002darray_002a.html0000644000175000017500000000635214360276512017553 0ustar cammcamm *print-array* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.16 *print-array* [Variable]

Value Type::

a generalized boolean.

Initial Value::

implementation-dependent.

Description::

Controls the format in which arrays are printed. If it is false, the contents of arrays other than strings are never printed. Instead, arrays are printed in a concise form using #< that gives enough information for the user to be able to identify the array, but does not include the entire array contents. If it is true, non-string arrays are printed using #(...), #*, or #nA syntax.

Affected By::

The implementation.

See Also::

Sharpsign Left-Parenthesis, Sharpsign Less-Than-Sign

gcl-2.6.14/info/gcl/with_002dopen_002dstream.html0000644000175000017500000000744414360276512017715 0ustar cammcamm with-open-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.33 with-open-stream [Macro]

with-open-stream (var stream) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

var—a variable name.

stream—a form; evaluated to produce a stream.

declaration—a declare expression; not evaluated.

forms—an implicit progn.

results—the values returned by the forms.

Description::

with-open-stream performs a series of operations on stream, returns a value, and then closes the stream.

Var is bound to the value of stream, and then forms are executed as an implicit progn. stream is automatically closed on exit from with-open-stream, no matter whether the exit is normal or abnormal.

The stream has dynamic extent; its extent ends when the form is exited.

The consequences are undefined if an attempt is made to assign the the variable var with the forms.

Examples::

 (with-open-stream (s (make-string-input-stream "1 2 3 4"))
    (+ (read s) (read s) (read s))) ⇒  6

Side Effects::

The stream is closed (upon exit).

See Also::

close

gcl-2.6.14/info/gcl/define_002dsetf_002dexpander.html0000644000175000017500000002025514360276512020502 0ustar cammcamm define-setf-expander (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.62 define-setf-expander [Macro]

define-setf-expander access-fn lambda-list [[{declaration}* | documentation]] {form}*
⇒ access-fn

Arguments and Values::

access-fn—a symbol that names a function or macro.

lambda-list – macro lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

forms—an implicit progn.

Description::

define-setf-expander specifies the means by which setf updates a place that is referenced by access-fn.

When setf is given a place that is specified in terms of access-fn and a new value for the place, it is expanded into a form that performs the appropriate update.

The lambda-list supports destructuring. See Macro Lambda Lists.

Documentation is attached to access-fn as a documentation string of kind setf.

Forms constitute the body of the

setf expander

definition and must compute the setf expansion for a call on setf that references the place by means of the given access-fn.

The setf expander function is defined in the same lexical environment in which the define-setf-expander form appears.

While forms are being executed, the variables in lambda-list are bound to parts of the place form.

The body forms (but not the lambda-list)

in a define-setf-expander form are implicitly enclosed in a block whose name is access-fn.

The evaluation of forms must result in the five values described in Setf Expansions.

If a define-setf-expander form appears as a top level form, the compiler must make the setf expander available so that it may be used to expand calls to setf later on in the file. Programmers must ensure that the forms can be evaluated at compile time if the access-fn is used in a place later in the same file. The compiler must make these setf expanders available to compile-time calls to get-setf-expansion when its environment argument is a value received as the environment parameter of a macro.

Examples::

 (defun lastguy (x) (car (last x))) ⇒  LASTGUY
 (define-setf-expander lastguy (x &environment env)
   "Set the last element in a list to the given value."
   (multiple-value-bind (dummies vals newval setter getter)
       (get-setf-expansion x env)
     (let ((store (gensym)))
       (values dummies
               vals
               `(,store)
               `(progn (rplaca (last ,getter) ,store) ,store)
               `(lastguy ,getter))))) ⇒  LASTGUY
 (setq a (list 'a 'b 'c 'd)
       b (list 'x)
       c (list 1 2 3 (list 4 5 6))) ⇒  (1 2 3 (4 5 6))
 (setf (lastguy a) 3) ⇒  3
 (setf (lastguy b) 7) ⇒  7
 (setf (lastguy (lastguy c)) 'lastguy-symbol) ⇒  LASTGUY-SYMBOL
 a ⇒  (A B C 3)
 b ⇒  (7)
 c ⇒  (1 2 3 (4 5 LASTGUY-SYMBOL))

;;; Setf expander for the form (LDB bytespec int).
;;; Recall that the int form must itself be suitable for SETF.
 (define-setf-expander ldb (bytespec int &environment env)
   (multiple-value-bind (temps vals stores
                          store-form access-form)
       (get-setf-expansion int env);Get setf expansion for int.
     (let ((btemp (gensym))     ;Temp var for byte specifier.
           (store (gensym))     ;Temp var for byte to store.
           (stemp (first stores))) ;Temp var for int to store.
       (if (cdr stores) (error "Can't expand this."))
;;; Return the setf expansion for LDB as five values.
       (values (cons btemp temps)       ;Temporary variables.
               (cons bytespec vals)     ;Value forms.
               (list store)             ;Store variables.
               `(let ((,stemp (dpb ,store ,btemp ,access-form)))
                  ,store-form
                  ,store)               ;Storing form.
               `(ldb ,btemp ,access-form) ;Accessing form.
              ))))

See Also::

setf , defsetf , documentation , get-setf-expansion , Syntactic Interaction of Documentation Strings and Declarations

Notes::

define-setf-expander differs from the long form of defsetf in that while the body is being executed the variables in lambda-list are bound to parts of the place form, not to temporary variables that will be bound to the values of such parts. In addition, define-setf-expander does not have defsetf’s restriction that access-fn must be a function or a function-like macro; an arbitrary defmacro destructuring pattern is permitted in lambda-list.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/lambda.html0000644000175000017500000000727114360276512014610 0ustar cammcamm lambda (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.2 lambda [Macro]

lambda lambda-list [[{declaration}* | documentation]] {form}* ⇒ function

Arguments and Values::

lambda-list—an ordinary lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

function—a function.

Description::

Provides a shorthand notation for a function special form involving a lambda expression such that: 

    (lambda lambda-list [[{declaration}* | documentation]] {form}*)
 ≡ (function (lambda lambda-list [[{declaration}* | documentation]] {form}*))
 ≡ #'(lambda lambda-list [[{declaration}* | documentation]] {form}*)

Examples::

 (funcall (lambda (x) (+ x 3)) 4) ⇒  7

See Also::

lambda (symbol)

Notes::

This macro could be implemented by: 

(defmacro lambda (&whole form &rest bvl-decls-and-body)
  (declare (ignore bvl-decls-and-body))
  `#',form)
gcl-2.6.14/info/gcl/Examples-of-Merging-Pathnames.html0000644000175000017500000000531514360276512021051 0ustar cammcamm Examples of Merging Pathnames (ANSI and GNU Common Lisp Document)

Previous: , Up: Merging Pathnames  

19.2.3.1 Examples of Merging Pathnames

Although the following examples are possible to execute only in implementations which permit :unspecific in the indicated position andwhich permit four-letter type components, they serve to illustrate the basic concept of pathname merging. 

 (pathname-type 
   (merge-pathnames (make-pathname :type "LISP")
                    (make-pathname :type "TEXT")))
⇒  "LISP"

 (pathname-type 
   (merge-pathnames (make-pathname :type nil)
                    (make-pathname :type "LISP")))
⇒  "LISP"

 (pathname-type 
   (merge-pathnames (make-pathname :type :unspecific)
                    (make-pathname :type "LISP")))
⇒  :UNSPECIFIC
gcl-2.6.14/info/gcl/function_002dlambda_002dexpression.html0000644000175000017500000001466614360276512021756 0ustar cammcamm function-lambda-expression (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.9 function-lambda-expression [Function]

function-lambda-expression function
⇒ lambda-expression, closure-p, name

Arguments and Values::

function—a function.

lambda-expression—a lambda expression or nil.

closure-p—a generalized boolean.

name—an object.

Description::

Returns information about function as follows:

The primary value, lambda-expression, is function’s defining lambda expression, or nil if the information is not available. The lambda expression may have been pre-processed in some ways, but it should remain a suitable argument to compile or function. Any implementation may legitimately return nil as the lambda-expression of any function.

The secondary value, closure-p, is nil if function’s definition was enclosed in the null lexical environment or something non-nil if function’s definition might have been enclosed in some non-null lexical environment. Any implementation may legitimately return true as the closure-p of any function.

The tertiary value, name, is the “name” of function. The name is intended for debugging only and is not necessarily one that would be valid for use as a name in defun or function, for example. By convention, nil is used to mean that function has no name. Any implementation may legitimately return nil as the name of any function.

Examples::

The following examples illustrate some possible return values, but are not intended to be exhaustive: 

 (function-lambda-expression #'(lambda (x) x))
⇒  NIL, false, NIL
OR⇒ NIL, true, NIL
OR⇒ (LAMBDA (X) X), true, NIL
OR⇒ (LAMBDA (X) X), false, NIL

 (function-lambda-expression
    (funcall #'(lambda () #'(lambda (x) x))))
⇒  NIL, false, NIL
OR⇒ NIL, true, NIL
OR⇒ (LAMBDA (X) X), true, NIL
OR⇒ (LAMBDA (X) X), false, NIL

 (function-lambda-expression 
    (funcall #'(lambda (x) #'(lambda () x)) nil))
⇒  NIL, true, NIL
OR⇒ (LAMBDA () X), true, NIL
NOT⇒ NIL, false, NIL
NOT⇒ (LAMBDA () X), false, NIL

 (flet ((foo (x) x))
   (setf (symbol-function 'bar) #'foo)
   (function-lambda-expression #'bar))
⇒  NIL, false, NIL
OR⇒ NIL, true, NIL
OR⇒ (LAMBDA (X) (BLOCK FOO X)), true, NIL
OR⇒ (LAMBDA (X) (BLOCK FOO X)), false, FOO
OR⇒ (SI::BLOCK-LAMBDA FOO (X) X), false, FOO

 (defun foo ()
   (flet ((bar (x) x))
     #'bar))
 (function-lambda-expression (foo))
⇒  NIL, false, NIL
OR⇒ NIL, true, NIL
OR⇒ (LAMBDA (X) (BLOCK BAR X)), true, NIL
OR⇒ (LAMBDA (X) (BLOCK BAR X)), true, (:INTERNAL FOO 0 BAR)
OR⇒ (LAMBDA (X) (BLOCK BAR X)), false, "BAR in FOO"

Notes::

Although implementations are free to return “nil, true, nil” in all cases, they are encouraged to return a lambda expression as the primary value in the case where the argument was created by a call to compile or eval (as opposed to being created by loading a compiled file).

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/abort-_0028Function_0029.html0000644000175000017500000002403614360276512017403 0ustar cammcamm abort (Function) (ANSI and GNU Common Lisp Document)

Previous: , Up: Conditions Dictionary  

9.2.46 abort, continue, muffle-warning, store-value, use-value [Function]

abort &optional condition ⇒ #<NoValue>

continue &optional condition ⇒ nil

muffle-warning &optional condition ⇒ #<NoValue>

store-value value &optional condition ⇒ nil

use-value value &optional condition ⇒ nil

Arguments and Values::

value—an object.

condition—a condition object, or nil.

Description::

Transfers control to the most recently established applicable restart having the same name as the function. That is, the function abort searches for an applicable abort restart, the function continue searches for an applicable continue restart, and so on.

If no such restart exists, the functions continue, store-value, and use-value return nil, and the functions abort and muffle-warning signal an error of type control-error.

When condition is non-nil, only those restarts are considered that are either explicitly associated with that condition, or not associated with any condition; that is, the excluded restarts are those that are associated with a non-empty set of conditions of which the given condition is not an element. If condition is nil, all restarts are considered.

Examples::

;;; Example of the ABORT retart

 (defmacro abort-on-error (&body forms)
   `(handler-bind ((error #'abort))
      ,@forms)) ⇒  ABORT-ON-ERROR
 (abort-on-error (+ 3 5)) ⇒  8
 (abort-on-error (error "You lose."))
 |>  Returned to Lisp Top Level.

;;; Example of the CONTINUE restart

 (defun real-sqrt (n)
   (when (minusp n)
     (setq n (- n))
     (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n))
   (sqrt n))

 (real-sqrt 4) ⇒  2
 (real-sqrt -9)
 |>  Error: Tried to take sqrt(-9).
 |>  To continue, type :CONTINUE followed by an option number:
 |>   1: Return sqrt(9) instead.
 |>   2: Return to Lisp Toplevel.
 |>  Debug> |>>(continue)<<|
 |>  Return sqrt(9) instead.
⇒  3

 (handler-bind ((error #'(lambda (c) (continue))))
   (real-sqrt -9)) ⇒  3

;;; Example of the MUFFLE-WARNING restart

 (defun count-down (x)
   (do ((counter x (1- counter)))
       ((= counter 0) 'done)
     (when (= counter 1)
       (warn "Almost done"))
     (format t "~&~D~
⇒  COUNT-DOWN
 (count-down 3)
 |>  3
 |>  2
 |>  Warning: Almost done
 |>  1
⇒  DONE
 (defun ignore-warnings-while-counting (x)
   (handler-bind ((warning #'ignore-warning))
     (count-down x)))
⇒  IGNORE-WARNINGS-WHILE-COUNTING
 (defun ignore-warning (condition)
   (declare (ignore condition))
   (muffle-warning))
⇒  IGNORE-WARNING
 (ignore-warnings-while-counting 3)
 |>  3
 |>  2
 |>  1
⇒  DONE

;;; Example of the STORE-VALUE and USE-VALUE restarts

 (defun careful-symbol-value (symbol)
   (check-type symbol symbol)
   (restart-case (if (boundp symbol)
                     (return-from careful-symbol-value 
                                  (symbol-value symbol))
                     (error 'unbound-variable
                            :name symbol))
     (use-value (value)
       :report "Specify a value to use this time."
       value)
     (store-value (value)
       :report "Specify a value to store and use in the future."
       (setf (symbol-value symbol) value))))
 (setq a 1234) ⇒  1234
 (careful-symbol-value 'a) ⇒  1234
 (makunbound 'a) ⇒  A
 (careful-symbol-value 'a)
 |>  Error: A is not bound.
 |>  To continue, type :CONTINUE followed by an option number.
 |>   1: Specify a value to use this time.
 |>   2: Specify a value to store and use in the future.
 |>   3: Return to Lisp Toplevel.
 |>  Debug> |>>(use-value 12)<<|
⇒  12
 (careful-symbol-value 'a)
 |>  Error: A is not bound.
 |>  To continue, type :CONTINUE followed by an option number.
 |>    1: Specify a value to use this time.
 |>    2: Specify a value to store and use in the future.
 |>    3: Return to Lisp Toplevel.
 |>  Debug> |>>(store-value 24)<<|
⇒  24
 (careful-symbol-value 'a)
⇒  24

;;; Example of the USE-VALUE restart

 (defun add-symbols-with-default (default &rest symbols)
   (handler-bind ((sys:unbound-symbol
                    #'(lambda (c)
                        (declare (ignore c)) 
                        (use-value default))))
     (apply #'+ (mapcar #'careful-symbol-value symbols))))
⇒  ADD-SYMBOLS-WITH-DEFAULT
 (setq x 1 y 2) ⇒  2
 (add-symbols-with-default 3 'x 'y 'z) ⇒  6

Side Effects::

A transfer of control may occur if an appropriate restart is available, or (in the case of the function abort or the function muffle-warning) execution may be stopped.

Affected By::

Each of these functions can be affected by the presence of a restart having the same name.

Exceptional Situations::

If an appropriate abort restart is not available for the function abort, or an appropriate muffle-warning restart is not available for the function muffle-warning, an error of type control-error is signaled.

See Also::

invoke-restart , Restarts, Interfaces to Restarts, assert , ccase, cerror , check-type , ctypecase, use-value , warn

Notes::

 (abort condition) ≡ (invoke-restart 'abort)
 (muffle-warning)  ≡ (invoke-restart 'muffle-warning)
 (continue)        ≡ (let ((r (find-restart 'continue))) (if r (invoke-restart r)))
 (use-value x) ≡ (let ((r (find-restart 'use-value))) (if r (invoke-restart r x)))
 (store-value x) ≡ (let ((r (find-restart 'store-value))) (if r (invoke-restart r x)))

No functions defined in this specification are required to provide a use-value restart.

Previous: , Up: Conditions Dictionary  

gcl-2.6.14/info/gcl/complexp.html0000644000175000017500000000577614360276512015227 0ustar cammcamm complexp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.47 complexp [Function]

complexp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type complex; otherwise, returns false.

Examples::

 (complexp 1.2d2) ⇒  false
 (complexp #c(5/3 7.2)) ⇒  true

See Also::

complex (function and type), typep

Notes::

 (complexp object) ≡ (typep object 'complex)
gcl-2.6.14/info/gcl/Dynamic-Environments.html0000644000175000017500000000665414360276512017445 0ustar cammcamm Dynamic Environments (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Environments  

3.1.1.2 Dynamic Environments

A dynamic environment for evaluation is that part of an environment that contains bindings whose duration is bounded by points of establishment and disestablishment within the execution of the form that established the binding. A dynamic environment contains, among other things, the following:

*

bindings for dynamic variables.

*

information about active catch tags.

*

information about exit points established by unwind-protect.

*

information about active handlers and restarts.

The dynamic environment that is active at any given point in the execution of a program is referred to by definite reference as “the current dynamic environment,” or sometimes as just “the dynamic environment.”

Within a given namespace, a name is said to be bound in a dynamic environment if there is a binding associated with its name in the dynamic environment or, if not, there is a binding associated with its name in the global environment.

gcl-2.6.14/info/gcl/flet.html0000644000175000017500000003022714360276512014317 0ustar cammcamm flet (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.6 flet, labels, macrolet [Special Operator]

flet ({(function-name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}*
⇒ {result}*

labels ({(function-name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}*
⇒ {result}*

macrolet ({(name lambda-list [[{local-declaration}* | local-documentation]] {local-form}*)}*) {declaration}* {form}*
⇒ {result}*

Arguments and Values::

function-name—a function name.

name—a symbol.

lambda-list—a lambda list; for flet and labels, it is an ordinary lambda list; for macrolet, it is a macro lambda list.

local-declaration—a declare expression; not evaluated.

declaration—a declare expression; not evaluated.

local-documentation—a string; not evaluated.

local-forms, forms—an implicit progn.

results—the values of the forms.

Description::

flet, labels, and macrolet define local functions and macros, and execute forms using the local definitions. Forms are executed in order of occurrence.

The body forms (but not the lambda list)

of each function created by flet and labels and each macro created by macrolet are enclosed in an implicit block whose name is the function block name of the function-name or name, as appropriate.

The scope of the declarations between the list of local function/macro definitions and the body forms in flet and labels does not include the bodies of the locally defined functions, except that for labels, any inline, notinline, or ftype declarations that refer to the locally defined functions do apply to the local function bodies. That is, their scope is the same as the function name that they affect.

The scope of these declarations does not include the bodies of the macro expander functions defined by macrolet.

flet

flet defines locally named functions and executes a series of forms with these definition bindings. Any number of such local functions can be defined.

The scope of the name binding encompasses only the body. Within the body of flet, function-names matching those defined by flet refer to the locally defined functions rather than to the global function definitions of the same name.

Also, within the scope of flet, global setf expander definitions of the function-name defined by flet do not apply. Note that this applies to (defsetf f ...), not (defmethod (setf f) ...).

The names of functions defined by flet are in the lexical environment; they retain their local definitions only within the body of flet. The function definition bindings are visible only in the body of flet, not the definitions themselves. Within the function definitions, local function names that match those being defined refer to functions or macros defined outside the flet. flet can locally shadow a global function name, and the new definition can refer to the global definition.

Any local-documentation is attached to the corresponding local function (if one is actually created) as a documentation string.

labels

labels is equivalent to flet except that the scope of the defined function names for labels encompasses the function definitions themselves as well as the body.

macrolet

macrolet establishes local macro definitions, using the same format used by defmacro.

Within the body of macrolet, global setf expander definitions of the names defined by the macrolet do not apply; rather, setf expands the macro form and recursively process the resulting form.

The macro-expansion functions defined by macrolet are defined in the

lexical environment in which the macrolet form appears. Declarations and macrolet and symbol-macrolet definitions affect the local macro definitions in a macrolet, but the consequences are undefined if the local macro definitions reference any local variable or function bindings that are visible in that lexical environment.

Any local-documentation is attached to the corresponding local macro function as a documentation string.

Examples::

 (defun foo (x flag)
   (macrolet ((fudge (z)
                 ;The parameters x and flag are not accessible
                 ; at this point; a reference to flag would be to
                 ; the global variable of that name.
                 ` (if flag (* ,z ,z) ,z)))
    ;The parameters x and flag are accessible here.
     (+ x
        (fudge x)
        (fudge (+ x 1)))))
 ≡
 (defun foo (x flag)
   (+ x
      (if flag (* x x) x)
      (if flag (* (+ x 1) (+ x 1)) (+ x 1))))

after macro expansion. The occurrences of x and flag legitimately refer to the parameters of the function foo because those parameters are visible at the site of the macro call which produced the expansion. 

 (flet ((flet1 (n) (+ n n)))
    (flet ((flet1 (n) (+ 2 (flet1 n))))
      (flet1 2))) ⇒  6

 (defun dummy-function () 'top-level) ⇒  DUMMY-FUNCTION 
 (funcall #'dummy-function) ⇒  TOP-LEVEL 
 (flet ((dummy-function () 'shadow)) 
      (funcall #'dummy-function)) ⇒  SHADOW 
 (eq (funcall #'dummy-function) (funcall 'dummy-function))
⇒  true 
 (flet ((dummy-function () 'shadow))
   (eq (funcall #'dummy-function)
       (funcall 'dummy-function)))
⇒  false 

 (defun recursive-times (k n)
   (labels ((temp (n) 
              (if (zerop n) 0 (+ k (temp (1- n))))))
     (temp n))) ⇒  RECURSIVE-TIMES
 (recursive-times 2 3) ⇒  6

 (defmacro mlets (x &environment env) 
    (let ((form `(babbit ,x)))
      (macroexpand form env))) ⇒  MLETS
 (macrolet ((babbit (z) `(+ ,z ,z))) (mlets 5)) ⇒  10

 (flet ((safesqrt (x) (sqrt (abs x))))
  ;; The safesqrt function is used in two places.
   (safesqrt (apply #'+ (map 'list #'safesqrt '(1 2 3 4 5 6)))))
⇒  3.291173

 (defun integer-power (n k)     
   (declare (integer n))         
   (declare (type (integer 0 *) k))
   (labels ((expt0 (x k a)
              (declare (integer x a) (type (integer 0 *) k))
              (cond ((zerop k) a)
                    ((evenp k) (expt1 (* x x) (floor k 2) a))
                    (t (expt0 (* x x) (floor k 2) (* x a)))))
            (expt1 (x k a)
              (declare (integer x a) (type (integer 0 *) k))
              (cond ((evenp k) (expt1 (* x x) (floor k 2) a))
                    (t (expt0 (* x x) (floor k 2) (* x a))))))
    (expt0 n k 1))) ⇒  INTEGER-POWER

 (defun example (y l)
   (flet ((attach (x)
            (setq l (append l (list x)))))
     (declare (inline attach))
     (dolist (x y)
       (unless (null (cdr x))
         (attach x)))
     l))

 (example '((a apple apricot) (b banana) (c cherry) (d) (e))
          '((1) (2) (3) (4 2) (5) (6 3 2)))
⇒  ((1) (2) (3) (4 2) (5) (6 3 2) (A APPLE APRICOT) (B BANANA) (C CHERRY))

See Also::

declare, defmacro , defun , documentation , let , Evaluation, Syntactic Interaction of Documentation Strings and Declarations

Notes::

It is not possible to define recursive functions with flet. labels can be used to define mutually recursive functions.

If a macrolet form is a top level form, the body forms are also processed as top level forms. See File Compilation.

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Printing-Pathnames.html0000644000175000017500000000510014360276512017065 0ustar cammcamm Printing Pathnames (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Default Print-Object Methods  

22.1.3.19 Printing Pathnames

When printer escaping is enabled,

the syntax #P"..." is how a pathname is printed by write and the other functions herein described. The "..." is the namestring representation of the pathname.

When printer escaping is disabled,

write writes a pathname P by writing (namestring P) instead.

For information on how the Lisp reader parses pathnames, see Sharpsign P.

gcl-2.6.14/info/gcl/setf.html0000644000175000017500000001323114360276512014322 0ustar cammcamm setf (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.64 setf, psetf [Macro]

setf {!pair}* ⇒ {result}*

psetf {!pair}* ⇒ nil

pair ::=place newvalue

Arguments and Values::

place—a place.

newvalue—a form.

results—the multiple values_2 returned by the storing form for the last place, or nil if there are no pairs.

Description::

setf changes the value of place to be newvalue.

(setf place newvalue) expands into an update form that stores the result of evaluating newvalue into the location referred to by place. Some place forms involve uses of accessors that take optional arguments. Whether those optional arguments are permitted by setf, or what their use is, is up to the setf expander function and is not under the control of setf. The documentation for any function that accepts &optional, &rest, or &key arguments and that claims to be usable with setf must specify how those arguments are treated.

If more than one pair is supplied, the pairs are processed sequentially; that is, 

 (setf place-1 newvalue-1
       place-2 newvalue-2
       ...
       place-N newvalue-N)

is precisely equivalent to 

 (progn (setf place-1 newvalue-1)
        (setf place-2 newvalue-2)
        ...
        (setf place-N newvalue-N))

For psetf, if more than one pair is supplied then the assignments of new values to places are done in parallel. More precisely, all subforms (in both the place and newvalue forms) that are to be evaluated are evaluated from left to right; after all evaluations have been performed, all of the assignments are performed in an unpredictable order.

For detailed treatment of the expansion of setf and psetf, see Kinds of Places.

Examples::

 (setq x (cons 'a 'b) y (list 1 2 3)) ⇒  (1 2 3) 
 (setf (car x) 'x (cadr y) (car x) (cdr x) y) ⇒  (1 X 3) 
 x ⇒  (X 1 X 3) 
 y ⇒  (1 X 3) 
 (setq x (cons 'a 'b) y (list 1 2 3)) ⇒  (1 2 3) 
 (psetf (car x) 'x (cadr y) (car x) (cdr x) y) ⇒  NIL 
 x ⇒  (X 1 A 3) 
 y ⇒  (1 A 3)

Affected By::

define-setf-expander, defsetf, *macroexpand-hook*

See Also::

define-setf-expander , defsetf , macroexpand-1, rotatef , shiftf , Generalized Reference

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/Tilde-S_002d_003e-Standard.html0000644000175000017500000000456314360276512017644 0ustar cammcamm Tilde S-> Standard (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Printer Operations  

22.3.4.2 Tilde S: Standard

This is just like ~A, but arg is printed with escape characters (as by prin1 rather than princ). The output is therefore suitable for input to read. ~S accepts all the arguments and modifiers that ~A does.

~S binds *print-escape* to t.

gcl-2.6.14/info/gcl/simple_002dvector_002dp.html0000644000175000017500000000623714360276512017537 0ustar cammcamm simple-vector-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.27 simple-vector-p [Function]

simple-vector-p object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type simple-vector; otherwise, returns false..

Examples::

 (simple-vector-p (make-array 6)) ⇒  true
 (simple-vector-p "aaaaaa") ⇒  false
 (simple-vector-p (make-array 6 :fill-pointer t)) ⇒  false

See Also::

simple-vector

Notes::

 (simple-vector-p object) ≡ (typep object 'simple-vector)
gcl-2.6.14/info/gcl/Tilde-R_002d_003e-Radix.html0000644000175000017500000000732114360276512017145 0ustar cammcamm Tilde R-> Radix (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Radix Control  

22.3.2.1 Tilde R: Radix

~nR prints arg in radix n. The modifier flags and any remaining parameters are used as for the ~D directive. ~D is the same as ~10R. The full form is ~radix,mincol,padchar,commachar,comma-intervalR.

If no prefix parameters are given to ~R, then a different interpretation is given. The argument should be an integer. For example, if arg is 4:

*

~R prints arg as a cardinal English number: four.

*

~:R prints arg as an ordinal English number: fourth.

*

~@R prints arg as a Roman numeral: IV.

*

~:@R prints arg as an old Roman numeral: IIII.

For example: 

 (format nil "~,,' ,4:B" 13) ⇒  "1101"
 (format nil "~,,' ,4:B" 17) ⇒  "1 0001"
 (format nil "~19,0,' ,4:B" 3333) ⇒  "0000 1101 0000 0101"
 (format nil "~3,,,' ,2:R" 17) ⇒  "1 22"
 (format nil "~,,'|,2:D" #xFFFF) ⇒   "6|55|35"

If and only if the first parameter, n, is supplied, ~R binds *print-escape* to false, *print-radix* to false, *print-base* to n,

and *print-readably* to false.

If and only if no parameters are supplied, ~R binds *print-base* to 10.

gcl-2.6.14/info/gcl/map_002dinto.html0000644000175000017500000001324614360276512015563 0ustar cammcamm map-into (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.8 map-into [Function]

map-into result-sequence function &rest sequences ⇒ result-sequence

Arguments and Values::

result-sequence—a proper sequence.

function—a designator for a function of as many arguments as there are sequences.

sequence—a proper sequence.

Description::

Destructively modifies result-sequence to contain the results of applying function to each element in the argument sequences in turn.

result-sequence and each element of sequences can each be either a list or a vector. If result-sequence and each element of sequences are not all the same length, the iteration terminates when the shortest sequence (of any of the sequences or the result-sequence) is exhausted. If result-sequence is a vector with a fill pointer, the fill pointer is ignored when deciding how many iterations to perform, and afterwards the fill pointer is set to the number of times function was applied. If result-sequence is longer than the shortest element of sequences, extra elements at the end of result-sequence are left unchanged. If result-sequence is nil, map-into immediately returns nil, since nil is a sequence of length zero.

If function has side effects, it can count on being called first on all of the elements with index 0, then on all of those numbered 1, and so on.

Examples::

 (setq a (list 1 2 3 4) b (list 10 10 10 10)) ⇒  (10 10 10 10)
 (map-into a #'+ a b) ⇒  (11 12 13 14)
 a ⇒  (11 12 13 14)
 b ⇒  (10 10 10 10)
 (setq k '(one two three)) ⇒  (ONE TWO THREE)
 (map-into a #'cons k a) ⇒  ((ONE . 11) (TWO . 12) (THREE . 13) 14)
 (map-into a #'gensym) ⇒  (#:G9090 #:G9091 #:G9092 #:G9093)
 a ⇒  (#:G9090 #:G9091 #:G9092 #:G9093)

Exceptional Situations::

Should be prepared to signal an error of type type-error if result-sequence is not a proper sequence. Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

Notes::

map-into differs from map in that it modifies an existing sequence rather than creating a new one. In addition, map-into can be called with only two arguments, while map requires at least three arguments.

map-into could be defined by: 

 (defun map-into (result-sequence function &rest sequences)
   (loop for index below (apply #'min 
                                (length result-sequence)
                                (mapcar #'length sequences))
         do (setf (elt result-sequence index)
                  (apply function
                         (mapcar #'(lambda (seq) (elt seq index))
                                 sequences))))
   result-sequence)

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/char_002dcode_002dlimit.html0000644000175000017500000000550114360276512017443 0ustar cammcamm char-code-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.19 char-code-limit [Constant Variable]

Constant Value::

A non-negative integer, the exact magnitude of which is implementation-dependent, but which is not less than 96 (the number of standard characters).

Description::

The upper exclusive bound on the value returned by the function char-code.

See Also::

char-code

Notes::

The value of char-code-limit might be larger than the actual number of characters supported by the implementation.

gcl-2.6.14/info/gcl/Summary-of-Conditional-Execution-Clauses.html0000644000175000017500000000652214360276512023224 0ustar cammcamm Summary of Conditional Execution Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Overview of the Loop Facility  

6.1.1.12 Summary of Conditional Execution Clauses

The if and when constructs take one form as a test and a clause that is executed when the test yields true. The clause can be a value accumulation, unconditional, or another conditional clause; it can also be any combination of such clauses connected by the loop and keyword.

The loop unless construct is similar to the loop when construct except that it complements the test result.

The loop else construct provides an optional component of if, when, and unless clauses that is executed when an if or when test yields false or when an unless test yields true. The component is one of the clauses described under if.

The loop end construct provides an optional component to mark the end of a conditional clause.

For more information, see Conditional Execution Clauses.

gcl-2.6.14/info/gcl/Deprecated-Reader-Syntax.html0000644000175000017500000000454714360276512020117 0ustar cammcamm Deprecated Reader Syntax (ANSI and GNU Common Lisp Document)

Previous: , Up: Deprecated Language Features  

1.8.4 Deprecated Reader Syntax

The #S reader macro forces keyword names into the KEYWORD package; see Sharpsign S. This feature is deprecated; in the future, keyword names will be taken in the package they are read in, so symbols that are actually in the KEYWORD package should be used if that is what is desired.

gcl-2.6.14/info/gcl/_002adebug_002dio_002a.html0000644000175000017500000002033414360276512016772 0ustar cammcamm *debug-io* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.53 *debug-io*, *error-output*, *query-io*,

*standard-input*, *standard-output*,

*trace-output*

[Variable]

Value Type::

For *standard-input*: an input stream

For *error-output*, *standard-output*, and *trace-output*: an output stream.

For *debug-io*, *query-io*: a bidirectional stream.

Initial Value::

implementation-dependent, but it must be an open stream that is not a generalized synonym stream to an I/O customization variables but that might be a generalized synonym stream to the value of some I/O customization variable. The initial value might also be a generalized synonym stream to either the symbol *terminal-io* or to the stream that is its value.

Description::

These variables are collectively called the standardized I/O customization variables. They can be bound or assigned in order to change the default destinations for input and/or output used by various standardized operators and facilities.

The value of *debug-io*, called debug I/O, is a stream to be used for interactive debugging purposes.

The value of *error-output*, called error output, is a stream to which warnings and non-interactive error messages should be sent.

The value of *query-io*, called query I/O, is a bidirectional stream to be used when asking questions of the user. The question should be output to this stream, and the answer read from it.

The value of *standard-input*, called standard input, is a stream that is used by many operators as a default source of input when no specific input stream is explicitly supplied.

The value of *standard-output*, called standard output, is a stream that is used by many operators as a default destination for output when no specific output stream is explicitly supplied.

The value of *trace-output*, called trace output, is the stream on which traced functions (see trace) and the time macro print their output.

Examples::

 (with-output-to-string (*error-output*)
   (warn "this string is sent to *error-output*"))
 ⇒  "Warning: this string is sent to *error-output*
" ;The exact format of this string is implementation-dependent.

 (with-input-from-string (*standard-input* "1001")
    (+ 990 (read))) ⇒  1991                       

 (progn (setq out (with-output-to-string (*standard-output*)
                     (print "print and format t send things to")
                     (format t "*standard-output* now going to a string")))
        :done)
⇒  :DONE
 out
⇒  "
\"print and format t send things to\" *standard-output* now going to a string"

 (defun fact (n) (if (< n 2) 1 (* n (fact (- n 1)))))
⇒  FACT
 (trace fact)
⇒  (FACT)
;; Of course, the format of traced output is implementation-dependent.
 (with-output-to-string (*trace-output*)
   (fact 3)) 
⇒  "
1 Enter FACT 3
| 2 Enter FACT 2
|   3 Enter FACT 1
|   3 Exit FACT 1
| 2 Exit FACT 2
1 Exit FACT 6"

See Also::

*terminal-io*, synonym-stream, Time , trace , Conditions, Reader, Printer

Notes::

The intent of the constraints on the initial value of the I/O customization variables is to ensure that it is always safe to bind or assign such a variable to the value of another I/O customization variable, without unduly restricting implementation flexibility.

It is common for an implementation to make the initial values of *debug-io* and *query-io* be the same stream, and to make the initial values of *error-output* and *standard-output* be the same stream.

The functions y-or-n-p and yes-or-no-p use query I/O for their input and output.

In the normal Lisp read-eval-print loop, input is read from standard input. Many input functions, including read and read-char, take a stream argument that defaults to standard input.

In the normal Lisp read-eval-print loop, output is sent to standard output. Many output functions, including print and write-char, take a stream argument that defaults to standard output.

A program that wants, for example, to divert output to a file should do so by binding *standard-output*; that way error messages sent to *error-output* can still get to the user by going through *terminal-io* (if *error-output* is bound to *terminal-io*), which is usually what is desired.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/standard_002dchar_002dp.html0000644000175000017500000000620414360276512017453 0ustar cammcamm standard-char-p (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.13 standard-char-p [Function]

standard-char-p character ⇒ generalized-boolean

Arguments and Values::

character—a character.

generalized-boolean—a generalized boolean.

Description::

Returns true if character is of type standard-char; otherwise, returns false.

Examples::

 (standard-char-p #\Space) ⇒  true
 (standard-char-p #\~) ⇒  true
 ;; This next example presupposes an implementation
 ;; in which #\Bell is a defined character.
 (standard-char-p #\Bell) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if character is not a character.

gcl-2.6.14/info/gcl/Destructive-Operations.html0000644000175000017500000000516414360276512020011 0ustar cammcamm Destructive Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.7 Destructive Operations

• Modification of Literal Objects  
• Transfer of Control during a Destructive Operation  
gcl-2.6.14/info/gcl/vector-_0028System-Class_0029.html0000644000175000017500000001304214360276512020333 0ustar cammcamm vector (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.3 vector [System Class]

Class Precedence List::

vector, array, sequence, t

Description::

Any one-dimensional array is a vector.

The type vector is a subtype of type array; for all types x, (vector x) is the same as (array x (*)).

The type (vector t), the type string, and the type bit-vector are disjoint subtypes of type vector.

Compound Type Specifier Kind::

Specializing.

Compound Type Specifier Syntax::

(vector{[{element-type | *} [{size | *}]]})

Compound Type Specifier Arguments::

size—a non-negative fixnum.

element-type—a type specifier.

Compound Type Specifier Description::

This denotes the set of specialized vectors whose element type and dimension match the specified values. Specifically:

If element-type is the symbol *, vectors are not excluded on the basis of their element type. Otherwise, only those vectors are included whose actual array element type

is the result of upgrading element-type; see Array Upgrading.

If a size is specified, the set includes only those vectors whose only dimension is size. If the symbol * is specified instead of a size, the set is not restricted on the basis of dimension.

See Also::

Required Kinds of Specialized Arrays, Sharpsign Left-Parenthesis, Printing Other Vectors, Sharpsign A

Notes::

The type (vector e s) is equivalent to the type (array e (s)).

The type (vector bit) has the name bit-vector.

The union of all types (vector C), where C is any subtype of character, has the name string.

(vector *) refers to all vectors regardless of element type, (vector type-specifier) refers only to those vectors that can result from giving type-specifier as the :element-type argument to make-array.

Next: , Previous: , Up: Arrays Dictionary  

gcl-2.6.14/info/gcl/pprint_002dfill.html0000644000175000017500000001556714360276512016307 0ustar cammcamm pprint-fill (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.5 pprint-fill, pprint-linear, pprint-tabular [Function]

pprint-fill stream object &optional colon-p at-sign-p ⇒ nil

pprint-linear stream object &optional colon-p at-sign-p ⇒ nil

pprint-tabular stream object &optional colon-p at-sign-p tabsize ⇒ nil

Arguments and Values::

stream—an output stream designator.

object—an object.

colon-p—a generalized boolean. The default is true.

at-sign-p—a generalized boolean. The default is implementation-dependent.

tabsize—a non-negative integer. The default is 16.

Description::

The functions pprint-fill, pprint-linear, and pprint-tabular specify particular ways of pretty printing a list to stream. Each function prints parentheses around the output if and only if colon-p is true. Each function ignores its at-sign-p argument. (Both arguments are included even though only one is needed so that these functions can be used via ~/.../ and as set-pprint-dispatch functions, as well as directly.) Each function handles abbreviation and the detection of circularity and sharing correctly, and uses write to print object when it is a non-list.

If object is a list and if the value of *print-pretty* is false, each of these functions prints object using a minimum of whitespace, as described in Printing Lists and Conses. Otherwise (if object is a list and if the value of *print-pretty* is true):

*

The function pprint-linear prints a list either all on one line, or with each element on a separate line.

*

The function pprint-fill prints a list with as many elements as possible on each line.

*

The function pprint-tabular is the same as pprint-fill except that it prints the elements so that they line up in columns. The tabsize specifies the column spacing in ems, which is the total spacing from the leading edge of one column to the leading edge of the next.

Examples::

Evaluating the following with a line length of 25 produces the output shown. 

(progn (princ "Roads ") 
       (pprint-tabular *standard-output* '(elm main maple center) nil nil 8))
Roads ELM     MAIN
      MAPLE   CENTER

Side Effects::

Performs output to the indicated stream.

Affected By::

The cursor position on the indicated stream, if it can be determined.

Notes::

The function pprint-tabular could be defined as follows: 

(defun pprint-tabular (s list &optional (colon-p t) at-sign-p (tabsize nil))
  (declare (ignore at-sign-p))
  (when (null tabsize) (setq tabsize 16))
  (pprint-logical-block (s list :prefix (if colon-p "(" "")
                                :suffix (if colon-p ")" ""))
    (pprint-exit-if-list-exhausted)
    (loop (write (pprint-pop) :stream s)
          (pprint-exit-if-list-exhausted)
          (write-char #\Space s)
          (pprint-tab :section-relative 0 tabsize s)
          (pprint-newline :fill s))))

Note that it would have been inconvenient to specify this function using format, because of the need to pass its tabsize argument through to a ~:T format directive nested within an iteration over a list.

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/_002amacroexpand_002dhook_002a.html0000644000175000017500000001233614360276512020541 0ustar cammcamm *macroexpand-hook* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.15 *macroexpand-hook* [Variable]

Value Type::

a designator for a function of three arguments: a macro function, a macro form, and an environment object.

Initial Value::

a designator for a function that is equivalent to the function funcall, but that might have additional implementation-dependent side-effects.

Description::

Used as the expansion interface hook by macroexpand-1 to control the macro expansion process. When a macro form is to be expanded, this function is called with three arguments: the macro function, the macro form, and the environment in which the macro form is to be expanded.

The environment object has dynamic extent; the consequences are undefined if the environment object is referred to outside the dynamic extent of the macro expansion function.

Examples::

 (defun hook (expander form env)
    (format t "Now expanding: ~S~
    (funcall expander form env)) ⇒  HOOK 
 (defmacro machook (x y) `(/ (+ ,x ,y) 2)) ⇒  MACHOOK 
 (macroexpand '(machook 1 2)) ⇒  (/ (+ 1 2) 2), true 
 (let ((*macroexpand-hook* #'hook)) (macroexpand '(machook 1 2)))
 |>  Now expanding (MACHOOK 1 2) 
⇒  (/ (+ 1 2) 2), true

See Also::

macroexpand , macroexpand-1, funcall , Evaluation

Notes::

The net effect of the chosen initial value is to just invoke the macro function, giving it the macro form and environment as its two arguments.

Users or user programs can assign this variable to customize or trace the macro expansion mechanism. Note, however, that this variable is a global resource, potentially shared by multiple programs; as such, if any two programs depend for their correctness on the setting of this variable, those programs may not be able to run in the same Lisp image. For this reason, it is frequently best to confine its uses to debugging situations.

Users who put their own function into *macroexpand-hook* should consider saving the previous value of the hook, and calling that value from their own.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/loop.html0000644000175000017500000004536514360276512014347 0ustar cammcamm loop (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Iteration Dictionary  

6.2.4 loop [Macro]

The “simple” loop form:

loop {compound-form}* ⇒ {result}*

The “extended” loop form:

loop [!name-clause] {!variable-clause}* {!main-clause}* ⇒ {result}*

name-clause ::=named name

variable-clause ::=!with-clause | !initial-final | !for-as-clause

with-clause ::=with var1 [type-spec] [= form1] {and var2 [type-spec] [= form2]}*

main-clause ::=!unconditional | !accumulation | !conditional | !termination-test | !initial-final

initial-final ::=initially {compound-form}^+ | finally {compound-form}^+

unconditional ::={do | doing} {compound-form}^+ | return {form | it}

accumulation ::=!list-accumulation | !numeric-accumulation

list-accumulation ::={collect | collecting | append | appending | nconc | nconcing} {form | it}                        [into simple-var]

numeric-accumulation ::={count | counting | sum | summing | }                          maximize | maximizing | minimize | minimizing {form | it}                           [into simple-var] [type-spec]

conditional ::={if | when | unless} form !selectable-clause {and !selectable-clause}*                  [else !selectable-clause {and !selectable-clause}*]                  [end]

selectable-clause ::=!unconditional | !accumulation | !conditional

termination-test ::=while form | until form | repeat form | always form | never form | thereis form

for-as-clause ::={for | as} !for-as-subclause {and !for-as-subclause}*

for-as-subclause ::=!for-as-arithmetic | !for-as-in-list | !for-as-on-list | !for-as-equals-then |                      !for-as-across | !for-as-hash | !for-as-package

for-as-arithmetic ::=var [type-spec] !for-as-arithmetic-subclause

for-as-arithmetic-subclause ::=!arithmetic-up | !arithmetic-downto | !arithmetic-downfrom

arithmetic-up ::=[[{from | upfrom} form1 | {to | upto | below} form2 | by form3]]^+

arithmetic-downto ::=[[{from form1}^1 | {{downto | above} form2}^1 | by form3]]

arithmetic-downfrom ::=[[{downfrom form1}^1 | {to | downto | above} form2 | by form3]]

for-as-in-list ::=var [type-spec] in form1 [by step-fun]

for-as-on-list ::=var [type-spec] on form1 [by step-fun]

for-as-equals-then ::=var [type-spec] = form1 [then form2]

for-as-across ::=var [type-spec] across vector

for-as-hash ::=var [type-spec] being {each | the}                  {{hash-key | hash-keys} {in | of} hash-table                  [using (hash-value other-var)] |                  {hash-value | hash-values} {in | of} hash-table                  [using (hash-key other-var)]}

for-as-package ::=var [type-spec] being {each | the}                     {symbol | symbols |                    present-symbol | present-symbols |                    external-symbol | external-symbols}                     [{in | of} package]

type-spec ::=!simple-type-spec | !destructured-type-spec

simple-type-spec ::=fixnum | float | t | nil

destructured-type-spec ::=of-type d-type-spec

d-type-spec ::=type-specifier | (d-type-spec . d-type-spec)

var ::=!d-var-spec

var1 ::=!d-var-spec

var2 ::=!d-var-spec

other-var ::=!d-var-spec

d-var-spec ::=simple-var | nil | (!d-var-spec . !d-var-spec)

Arguments and Values::

compound-form—a compound form.

name—a symbol.

simple-var—a symbol (a variable name).

form, form1, form2, form3—a form.

step-fun—a form that evaluates to a function of one argument.

vector—a form that evaluates to a vector.

hash-table—a form that evaluates to a hash table.

package—a form that evaluates to a package designator.

type-specifier—a type specifier. This might be either an atomic type specifier or a compound type specifier, which introduces some additional complications to proper parsing in the face of destructuring; for further information, see Destructuring.

result—an object.

Description::

For details, see The LOOP Facility.

Examples::

;; An example of the simple form of LOOP.
 (defun sqrt-advisor ()
   (loop (format t "~&Number: ")
         (let ((n (parse-integer (read-line) :junk-allowed t)))
           (when (not n) (return))
           (format t "~&The square root of ~D is ~D.~%" n (sqrt n)))))
⇒  SQRT-ADVISOR
 (sqrt-advisor)
 |>  Number: |>>5 [<–~]<<|
 |>  The square root of 5 is 2.236068.
 |>  Number: |>>4 [<–~]<<|
 |>  The square root of 4 is 2.
 |>  Number: |>>done [<–~]<<|
⇒  NIL

;; An example of the extended form of LOOP.
 (defun square-advisor ()
   (loop as n = (progn (format t "~&Number: ")
                       (parse-integer (read-line) :junk-allowed t))
         while n
         do (format t "~&The square of ~D is ~D.~
⇒  SQUARE-ADVISOR
 (square-advisor)
 |>  Number: |>>4 [<–~]<<|
 |>  The square of 4 is 16.
 |>  Number: |>>23 [<–~]<<|
 |>  The square of 23 is 529.
 |>  Number: |>>done [<–~]<<|
⇒  NIL

;; Another example of the extended form of LOOP.
 (loop for n from 1 to 10
       when (oddp n)
         collect n)
⇒  (1 3 5 7 9)

See Also::

do , dolist , dotimes , return , go , throw , Destructuring

Notes::

Except that loop-finish cannot be used within a simple loop form, a simple loop form is related to an extended loop form in the following way: 

 (loop {compound-form}*) ≡ (loop do {compound-form}*)

Next: , Previous: , Up: Iteration Dictionary  

gcl-2.6.14/info/gcl/Character-Categories.html0000644000175000017500000001151314360276512017341 0ustar cammcamm Character Categories (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.4 Character Categories

There are several (overlapping) categories of characters that have no formally associated type but that are nevertheless useful to name. They include graphic characters, alphabetic_1 characters, characters with case (uppercase and lowercase characters), numeric characters, alphanumeric characters, and digits (in a given radix).

For each implementation-defined attribute of a character, the documentation for that implementation must specify whether characters that differ only in that attribute are permitted to differ in whether are not they are members of one of the aforementioned categories.

Note that these terms are defined independently of any special syntax which might have been enabled in the current readtable.

• Graphic Characters  
• Alphabetic Characters  
• Characters With Case  
• Uppercase Characters  
• Lowercase Characters  
• Corresponding Characters in the Other Case  
• Case of Implementation-Defined Characters  
• Numeric Characters  
• Alphanumeric Characters  
• Digits in a Radix  
gcl-2.6.14/info/gcl/find_002dpackage.html0000644000175000017500000000700714360276512016346 0ustar cammcamm find-package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Packages Dictionary  

11.2.4 find-package [Function]

find-package name ⇒ package

Arguments and Values::

name—a string designator or a package object.

package—a package object or nil.

Description::

If name is a string designator, find-package locates and returns the package whose name or nickname is name. This search is case sensitive. If there is no such package, find-package returns nil.

If name is a package object, that package object is returned.

Examples::

 (find-package 'common-lisp) ⇒  #<PACKAGE "COMMON-LISP">
 (find-package "COMMON-LISP-USER") ⇒  #<PACKAGE "COMMON-LISP-USER">
 (find-package 'not-there) ⇒  NIL

Affected By::

The set of packages created by the implementation.

defpackage, delete-package, make-package, rename-package

See Also::

make-package

gcl-2.6.14/info/gcl/Specialized-Lambda-Lists.html0000644000175000017500000001313714360276512020074 0ustar cammcamm Specialized Lambda Lists (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Lambda Lists  

3.4.3 Specialized Lambda Lists

A specialized lambda list is used to specialize a method for a particular signature and to describe how arguments matching that signature are received by the method. The defined names in Figure 3–15 use specialized lambda lists in some way; see the dictionary entry for each for information about how. 

  defmethod  defgeneric    

  Figure 3–15: Standardized Operators that use Specialized Lambda Lists

A specialized lambda list can contain the lambda list keywords shown in Figure 3–16. 

  &allow-other-keys  &key       &rest  
  &aux               &optional         

  Figure 3–16: Lambda List Keywords used by Specialized Lambda Lists

A specialized lambda list is syntactically the same as an ordinary lambda list except that each required parameter may optionally be associated with a class or object for which that parameter is specialized.

lambda-list ::=({var | (var [specializer])}*                 [&optional {var |         (var [init-form [supplied-p-parameter]])}*]                 [&rest var]                 [&key {var |              ({var |          (keyword-name var)}    [init-form [supplied-p-parameter]])}* [&allow-other-keys]]                 [&aux {var | (var [init-form])}*])                

gcl-2.6.14/info/gcl/Streams.html0000644000175000017500000000427414360276512015006 0ustar cammcamm Streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

21 Streams

• Stream Concepts  
• Streams Dictionary  
gcl-2.6.14/info/gcl/pprint_002dexit_002dif_002dlist_002dexhausted.html0000644000175000017500000001005214360276512023437 0ustar cammcamm pprint-exit-if-list-exhausted (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.4 pprint-exit-if-list-exhausted [Local Macro]

Syntax::

pprint-exit-if-list-exhausted <no arguments> ⇒ nil

Description::

Tests whether or not the list passed to the lexically current logical block has been exhausted; see Dynamic Control of the Arrangement of Output. If this list has been reduced to nil, pprint-exit-if-list-exhausted terminates the execution of the lexically current logical block except for the printing of the suffix. Otherwise pprint-exit-if-list-exhausted returns nil.

Whether or not pprint-exit-if-list-exhausted is fbound in the global environment is implementation-dependent; however, the restrictions on redefinition and shadowing of pprint-exit-if-list-exhausted are the same as for symbols in the COMMON-LISP package which are fbound in the global environment. The consequences of attempting to use pprint-exit-if-list-exhausted outside of pprint-logical-block are undefined.

Exceptional Situations::

An error is signaled (at macro expansion time or at run time) if pprint-exit-if-list-exhausted is used anywhere other than lexically within a call on pprint-logical-block. Also, the consequences of executing pprint-if-list-exhausted outside of the dynamic extent of the pprint-logical-block which lexically contains it are undefined.

See Also::

pprint-logical-block , pprint-pop .

gcl-2.6.14/info/gcl/decode_002duniversal_002dtime.html0000644000175000017500000001077614360276512020701 0ustar cammcamm decode-universal-time (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.1 decode-universal-time [Function]

decode-universal-time universal-time &optional time-zone
⇒ second, minute, hour, date, month, year, day, daylight-p, zone

Arguments and Values::

universal-time—a universal time.

time-zone—a time zone.

second, minute, hour, date, month, year, day, daylight-p, zone—a decoded time.

Description::

Returns the decoded time represented by the given universal time.

If time-zone is not supplied, it defaults to the current time zone adjusted for daylight saving time.

If time-zone is supplied, daylight saving time information is ignored. The daylight saving time flag is nil if time-zone is supplied.

Examples::

 (decode-universal-time 0 0) ⇒  0, 0, 0, 1, 1, 1900, 0, false, 0

;; The next two examples assume Eastern Daylight Time.
 (decode-universal-time 2414296800 5) ⇒  0, 0, 1, 4, 7, 1976, 6, false, 5
 (decode-universal-time 2414293200) ⇒  0, 0, 1, 4, 7, 1976, 6, true, 5

;; This example assumes that the time zone is Eastern Daylight Time
;; (and that the time zone is constant throughout the example).
 (let* ((here (nth 8 (multiple-value-list (get-decoded-time)))) ;Time zone
        (recently (get-universal-time))
        (a (nthcdr 7 (multiple-value-list (decode-universal-time recently))))
        (b (nthcdr 7 (multiple-value-list (decode-universal-time recently here)))))
   (list a b (equal a b))) ⇒  ((T 5) (NIL 5) NIL)

Affected By::

Implementation-dependent mechanisms for calculating when or if daylight savings time is in effect for any given session.

See Also::

encode-universal-time , get-universal-time , Time

gcl-2.6.14/info/gcl/Reader-Algorithm.html0000644000175000017500000002413514360276512016514 0ustar cammcamm Reader Algorithm (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Syntax  

2.2 Reader Algorithm

This section describes the algorithm used by the Lisp reader to parse objects from an input character stream, including how the Lisp reader processes macro characters.

When dealing with tokens, the reader’s basic function is to distinguish representations of symbols from those of numbers. When a token is accumulated, it is assumed to represent a number if it satisfies the syntax for numbers listed in Figure~2–9. If it does not represent a number, it is then assumed to be a potential number if it satisfies the rules governing the syntax for a potential number. If a valid token is neither a representation of a number nor a potential number, it represents a symbol.

The algorithm performed by the Lisp reader is as follows:

1.

If at end of file, end-of-file processing is performed as specified in read. Otherwise, one character, x, is read from the input stream, and dispatched according to the syntax type of x to one of steps 2 to 7.

2.

If x is an invalid character, an error of type reader-error is signaled.

3.

If x is a whitespace_2 character, then it is discarded and step 1 is re-entered.

4.

If x is a terminating or non-terminating macro character then its associated reader macro function is called with two arguments, the input stream and x.

The reader macro function may read characters from the input stream; if it does, it will see those characters following the macro character. The Lisp reader may be invoked recursively from the reader macro function.

The reader macro function must not have any side effects other than on the input stream; because of backtracking and restarting of the read operation, front ends to the Lisp reader (e.g., “editors” and “rubout handlers”) may cause the reader macro function to be called repeatedly during the reading of a single expression in which x only appears once.

The reader macro function may return zero values or one value. If one value is returned, then that value is returned as the result of the read operation; the algorithm is done. If zero values are returned, then step 1 is re-entered.

5.

If x is a single escape character then the next character, y, is read, or an error of type end-of-file is signaled if at the end of file. y is treated as if it is a constituent whose only constituent trait is alphabetic_2. y is used to begin a token, and step 8 is entered.

6.

If x is a multiple escape character then a token (initially containing no characters) is begun and step 9 is entered.

7.

If x is a constituent character, then it begins a token. After the token is read in, it will be interpreted either as a Lisp object or as being of invalid syntax. If the token represents an object, that object is returned as the result of the read operation. If the token is of invalid syntax, an error is signaled. If x is a character with case, it might be replaced with the corresponding character of the opposite case, depending on the readtable case of the current readtable, as outlined in Effect of Readtable Case on the Lisp Reader. X is used to begin a token, and step 8 is entered.

8.

At this point a token is being accumulated, and an even number of multiple escape characters have been encountered. If at end of file, step 10 is entered. Otherwise, a character, y, is read, and one of the following actions is performed according to its syntax type:

*

If y is a constituent or non-terminating macro character:

–

If y is a character with case, it might be replaced with the corresponding character of the opposite case, depending on the readtable case of the current readtable, as outlined in Effect of Readtable Case on the Lisp Reader.

–

Y is appended to the token being built.

–

Step 8 is repeated.

*

If y is a single escape character, then the next character, z, is read, or an error of type end-of-file is signaled if at end of file. Z is treated as if it is a constituent whose only constituent trait is alphabetic_2. Z is appended to the token being built, and step 8 is repeated.

*

If y is a multiple escape character, then step 9 is entered.

*

If y is an invalid character, an error of type reader-error is signaled.

*

If y is a terminating macro character, then it terminates the token. First the character y is unread (see unread-char), and then step 10 is entered.

*

If y is a whitespace_2 character, then it terminates the token. First the character y is unread if appropriate (see read-preserving-whitespace), and then step 10 is entered.

9.

At this point a token is being accumulated, and an odd number of multiple escape characters have been encountered. If at end of file, an error of type end-of-file is signaled. Otherwise, a character, y, is read, and one of the following actions is performed according to its syntax type:

*

If y is a constituent, macro, or whitespace_2 character, y is treated as a constituent whose only constituent trait is alphabetic_2. Y is appended to the token being built, and step 9 is repeated.

*

If y is a single escape character, then the next character, z, is read, or an error of type end-of-file is signaled if at end of file. Z is treated as a constituent whose only constituent trait is alphabetic_2. Z is appended to the token being built, and step 9 is repeated.

*

If y is a multiple escape character, then step 8 is entered.

*

If y is an invalid character, an error of type reader-error is signaled.

10.

An entire token has been accumulated. The object represented by the token is returned as the result of the read operation, or an error of type reader-error is signaled if the token is not of valid syntax.

Next: , Previous: , Up: Syntax  

gcl-2.6.14/info/gcl/Deprecated-Argument-Conventions.html0000644000175000017500000000633714360276512021515 0ustar cammcamm Deprecated Argument Conventions (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Deprecated Language Features  

1.8.2 Deprecated Argument Conventions

The ability to pass a numeric argument to gensym has been deprecated.

The :test-not argument to the functions in Figure 1–3 are deprecated. 

  adjoin             nset-difference    search            
  assoc              nset-exclusive-or  set-difference    
  count              nsublis            set-exclusive-or  
  delete             nsubst             sublis            
  delete-duplicates  nsubstitute        subsetp           
  find               nunion             subst             
  intersection       position           substitute        
  member             rassoc             tree-equal        
  mismatch           remove             union             
  nintersection      remove-duplicates                    

  Figure 1–3: Functions with Deprecated :TEST-NOT Arguments

The use of the situation names compile, load, and eval in eval-when is deprecated.

gcl-2.6.14/info/gcl/make_002dstring_002doutput_002dstream.html0000644000175000017500000000726014360276512022226 0ustar cammcamm make-string-output-stream (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.50 make-string-output-stream [Function]

make-string-output-stream &key element-type ⇒ string-stream

Arguments and Values::

element-type—a type specifier. The default is character.

string-stream—an output string stream.

Description::

Returns

an output string stream that accepts characters and makes available (via get-output-stream-string) a string that contains the characters that were actually output.

The element-type names the type of the elements of the string; a string is constructed of the most specialized type that can accommodate elements of that element-type.

Examples::

 (let ((s (make-string-output-stream)))
   (write-string "testing... " s)
   (prin1 1234 s)
   (get-output-stream-string s))
⇒  "testing... 1234"

None..

See Also::

get-output-stream-string , with-output-to-string

gcl-2.6.14/info/gcl/close.html0000644000175000017500000001234414360276512014472 0ustar cammcamm close (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.32 close [Function]

close stream &key abort ⇒ result

Arguments and Values::

stream—a stream (either open or closed).

abort—a generalized boolean. The default is false.

result—t if the stream was open at the time it was received as an argument, or implementation-dependent otherwise.

Description::

close closes stream. Closing a stream means that it may no longer be used in input or output operations. The act of closing a file stream ends the association between the stream and its associated file; the transaction with the file system is terminated, and input/output may no longer be performed on the stream.

If abort is true, an attempt is made to clean up any side effects of having created stream. If stream performs output to a file that was created when the stream was created, the file is deleted and any previously existing file is not superseded.

It is permissible to close an already closed stream, but in that case the result is implementation-dependent.

After stream is closed, it is still possible to perform the following query operations upon it:

streamp, pathname, truename, merge-pathnames, pathname-host, pathname-device, pathname-directory,pathname-name, pathname-type, pathname-version, namestring, file-namestring, directory-namestring, host-namestring, enough-namestring, open, probe-file, and directory.

The effect of close on a constructed stream is to close the argument stream only. There is no effect on the constituents of composite streams.

For a stream created with make-string-output-stream, the result of get-output-stream-string is unspecified after close.

Examples::

 (setq s (make-broadcast-stream)) ⇒  #<BROADCAST-STREAM>
 (close s) ⇒  T
 (output-stream-p s) ⇒  true

Side Effects::

The stream is closed (if necessary). If abort is true and the stream is an output file stream, its associated file might be deleted.

See Also::

open

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/Notes-about-The-KEYWORD-Package.html0000644000175000017500000000570214360276512020756 0ustar cammcamm Notes about The KEYWORD Package (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standardized Packages  

11.1.2.8 Notes about The KEYWORD Package

It is generally best to confine the use of keywords to situations in which there are a finitely enumerable set of names to be selected between. For example, if there were two states of a light switch, they might be called :on and :off.

In situations where the set of names is not finitely enumerable (i.e., where name conflicts might arise) it is frequently best to use symbols in some package other than KEYWORD so that conflicts will be naturally avoided. For example, it is generally not wise for a program to use a keyword_1 as a property indicator, since if there were ever another program that did the same thing, each would clobber the other’s data.

gcl-2.6.14/info/gcl/psetq.html0000644000175000017500000001114414360276512014516 0ustar cammcamm psetq (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.21 psetq [Macro]

psetq {!pair}* ⇒ nil

pair ::=var form

Pronunciation::

psetq: pronounced

Arguments and Values::

var—a symbol naming a variable other than a constant variable.

form—a form.

Description::

Assigns values to variables.

This is just like setq, except that the assignments happen “in parallel.” That is, first all of the forms are evaluated, and only then are the variables set to the resulting values. In this way, the assignment to one variable does not affect the value computation of another in the way that would occur with setq’s sequential assignment.

If any var refers to a binding made by symbol-macrolet, then that var is treated as if psetf (not psetq) had been used.

Examples::

 ;; A simple use of PSETQ to establish values for variables.
 ;; As a matter of style, many programmers would prefer SETQ 
 ;; in a simple situation like this where parallel assignment
 ;; is not needed, but the two have equivalent effect.
 (psetq a 1 b 2 c 3) ⇒  NIL
 a ⇒  1
 b ⇒  2
 c ⇒  3

 ;; Use of PSETQ to update values by parallel assignment.
 ;; The effect here is very different than if SETQ had been used.
 (psetq a (1+ b) b (1+ a) c (+ a b)) ⇒  NIL
 a ⇒  3
 b ⇒  2
 c ⇒  3

 ;; Use of PSETQ on a symbol macro.
 (let ((x (list 10 20 30)))
   (symbol-macrolet ((y (car x)) (z (cadr x)))
     (psetq y (1+ z) z (1+ y))
     (list x y z)))
⇒  ((21 11 30) 21 11)

 ;; Use of parallel assignment to swap values of A and B.
 (let ((a 1) (b 2))
   (psetq a b  b a)
   (values a b))
⇒  2, 1

Side Effects::

The values of forms are assigned to vars.

See Also::

psetf, setq

Next: , Previous: , Up: Data and Control Flow Dictionary  

gcl-2.6.14/info/gcl/broadcast_002dstream_002dstreams.html0000644000175000017500000000527114360276512021415 0ustar cammcamm broadcast-stream-streams (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.40 broadcast-stream-streams [Function]

broadcast-stream-streams broadcast-stream ⇒ streams

Arguments and Values::

broadcast-stream—a broadcast stream.

streams—a list of streams.

Description::

Returns a list of output streams that constitute all the streams to which the broadcast-stream is broadcasting.

gcl-2.6.14/info/gcl/Topological-Sorting.html0000644000175000017500000001202314360276512017256 0ustar cammcamm Topological Sorting (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Determining the Class Precedence List  

4.3.5.1 Topological Sorting

Topological sorting proceeds by finding a class C in~S_C such that no other class precedes that element according to the elements in~R. The class C is placed first in the result. Remove C from S_C, and remove all pairs of the form (C,D), D\in S_C, from R. Repeat the process, adding classes with no predecessors to the end of the result. Stop when no element can be found that has no predecessor.

If S_C is not empty and the process has stopped, the set R is inconsistent. If every class in the finite set of classes is preceded by another, then R contains a loop. That is, there is a chain of classes C_1,...,C_n such that C_i precedes C_{i+1}, 1<= i<n, and C_n precedes C_1.

Sometimes there are several classes from S_C with no predecessors. In this case select the one that has a direct subclass rightmost in the class precedence list computed so far. (If there is no such candidate class, R does not generate a partial ordering—the R_c, c\in S_C, are inconsistent.)

In more precise terms, let {N_1,...,N_m}, m>= 2, be the classes from S_C with no predecessors. Let (C_1... C_n), n>= 1, be the class precedence list constructed so far. C_1 is the most specific class, and C_n is the least specific. Let 1<= j<= n be the largest number such that there exists an i where 1<= i<= m and N_i is a direct superclass of C_j; N_i is placed next.

The effect of this rule for selecting from a set of classes with no predecessors is that the classes in a simple superclass chain are adjacent in the class precedence list and that classes in each relatively separated subgraph are adjacent in the class precedence list. For example, let T_1 and T_2 be subgraphs whose only element in common is the class J. Suppose that no superclass of J appears in either T_1 or T_2, and that J is in the superclass chain of every class in both T_1 and T_2. Let C_1 be the bottom of T_1; and let C_2 be the bottom of T_2. Suppose C is a class whose direct superclasses are C_1 and C_2 in that order, then the class precedence list for C starts with C and is followed by all classes in T_1 except J. All the classes of T_2 are next. The class J and its superclasses appear last.

Next: , Previous: , Up: Determining the Class Precedence List  

gcl-2.6.14/info/gcl/Internal-and-External-Symbols.html0000644000175000017500000000577014360276512021114 0ustar cammcamm Internal and External Symbols (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Packages  

11.1.1.3 Internal and External Symbols

The mappings in a package are divided into two classes, external and internal. The symbols targeted by these different mappings are called external symbols and internal symbols of the package. Within a package, a name refers to one symbol or to none; if it does refer to a symbol, then it is either external or internal in that package, but not both. External symbols

are part of the package’s public interface to other packages. Symbols become external symbols of a given package if they have been exported from that package.

A symbol has the same name no matter what package it is present in, but it might be an external symbol of some packages and an internal symbol of others.

gcl-2.6.14/info/gcl/merge_002dpathnames.html0000644000175000017500000001765614360276512017125 0ustar cammcamm merge-pathnames (ANSI and GNU Common Lisp Document)

Previous: , Up: Filenames Dictionary  

19.4.17 merge-pathnames [Function]

merge-pathnames pathname &optional default-pathname default-version
⇒ merged-pathname

Arguments and Values::

pathname—a pathname designator.

default-pathname—a pathname designator.

The default is the value of *default-pathname-defaults*.

default-version—a valid pathname version.

The default is :newest.

merged-pathname—a pathname.

Description::

Constructs a pathname from pathname by filling in any unsupplied components with the corresponding values from default-pathname and default-version.

Defaulting of pathname components is done by filling in components taken from another pathname.

This is especially useful for cases such as a program that has an input file and an output file. Unspecified components of the output pathname will come from the input pathname, except that the type should not default to the type of the input pathname but rather to the appropriate default type for output from the program; for example, see the function compile-file-pathname.

If no version is supplied, default-version is used. If default-version is nil, the version component will remain unchanged.

If pathname explicitly specifies a host and not a device, and if the host component of default-pathname matches the host component of pathname, then the device is taken from the default-pathname; otherwise the device will be the default file device for that host. If pathname does not specify a host, device, directory, name, or type, each such component is copied from default-pathname. If pathname does not specify a name, then the version, if not provided, will come from default-pathname, just like the other components. If pathname does specify a name, then the version is not affected by default-pathname. If this process leaves the version missing, the default-version is used. If the host’s file name syntax provides a way to input a version without a name or type, the user can let the name and type default but supply a version different from the one in default-pathname.

If pathname is a stream, pathname effectively becomes (pathname pathname). merge-pathnames can be used on either an open or a closed stream.

If pathname is a pathname it represents the name used to open the file. This may be, but is not required to be, the actual name of the file.

merge-pathnames recognizes a logical pathname namestring when default-pathname is a logical pathname,

or when the namestring begins with the name of a defined logical host followed by a colon. In the first of these two cases,

the host portion of the logical pathname namestring and its following colon are optional.

merge-pathnames returns a logical pathname if and only if its first argument is a logical pathname,

or its first argument is a logical pathname namestring with an explicit host, or its first argument does not specify a host and the default-pathname is a logical pathname.

Pathname merging treats a relative directory specially. If (pathname-directory pathname) is a list whose car is :relative, and (pathname-directory default-pathname) is a list, then the merged directory is the value of 

 (append (pathname-directory default-pathname)
         (cdr  ;remove :relative from the front
           (pathname-directory pathname)))

except that if the resulting list contains a string or :wild immediately followed by :back, both of them are removed. This removal of redundant :back keywords is repeated as many times as possible. If (pathname-directory default-pathname) is not a list or (pathname-directory pathname) is not a list whose car is :relative, the merged directory is (or (pathname-directory pathname) (pathname-directory default-pathname))

merge-pathnames maps customary case in pathname into customary case in the output pathname.

Examples::

 (merge-pathnames "CMUC::FORMAT"
                  "CMUC::PS:<LISPIO>.FASL")
⇒  #P"CMUC::PS:<LISPIO>FORMAT.FASL.0"

See Also::

*default-pathname-defaults*, pathname, logical-pathname, File System Concepts,

Pathnames as Filenames

Notes::

The net effect is that if just a name is supplied, the host, device, directory, and type will come from default-pathname, but the version will come from default-version. If nothing or just a directory is supplied, the name, type, and version will come from default-pathname together.

Previous: , Up: Filenames Dictionary  

gcl-2.6.14/info/gcl/push.html0000644000175000017500000000750614360276512014350 0ustar cammcamm push (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.19 push [Macro]

push item place ⇒ new-place-value

Arguments and Values::

item—an object.

place—a place, the value of which may be any object.

new-place-value—a list (the new value of place).

Description::

push prepends item to the list that is stored in place, stores the resulting list in place, and returns the list.

For information about the evaluation of subforms of place, see Evaluation of Subforms to Places.

Examples::

 (setq llst '(nil)) ⇒  (NIL)
 (push 1 (car llst)) ⇒  (1)
 llst ⇒  ((1))
 (push 1 (car llst)) ⇒  (1 1)
 llst ⇒  ((1 1))
 (setq x '(a (b c) d)) ⇒  (A (B C) D)
 (push 5 (cadr x)) ⇒  (5 B C)  
 x ⇒  (A (5 B C) D)

Side Effects::

The contents of place are modified.

See Also::

pop , pushnew , Generalized Reference

Notes::

The effect of (push item place) is equivalent to 

 (setf place (cons item place))

except that the subforms of place are evaluated only once, and item is evaluated before place.

gcl-2.6.14/info/gcl/Unspecific-Components-of-a-Logical-Pathname.html0000644000175000017500000000472314360276512023525 0ustar cammcamm Unspecific Components of a Logical Pathname (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Logical Pathname Components  

19.3.2.1 Unspecific Components of a Logical Pathname

The device component of a logical pathname is always :unspecific; no other component of a logical pathname can be :unspecific.

gcl-2.6.14/info/gcl/Constituent-Characters.html0000644000175000017500000000514214360276512017757 0ustar cammcamm Constituent Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Syntax Types  

2.1.4.1 Constituent Characters

Constituent characters are used in tokens. A token is a representation of a number or a symbol. Examples of constituent characters are letters and digits.

Letters in symbol names are sometimes converted to letters in the opposite case when the name is read; see Effect of Readtable Case on the Lisp Reader. Case conversion can be suppressed by the use of single escape or multiple escape characters.

gcl-2.6.14/info/gcl/Tilde-Left_002dBracket_002d_003e-Conditional-Expression.html0000644000175000017500000001316014360276512025206 0ustar cammcamm Tilde Left-Bracket-> Conditional Expression (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Control-Flow Operations  

22.3.7.2 Tilde Left-Bracket: Conditional Expression

~[str0~;str1~;...~;strn~]

This is a set of control strings, called clauses, one of which is chosen and used. The clauses are separated by ~; and the construct is terminated by ~]. For example,

"~[Siamese~;Manx~;Persian~] Cat"

The argth clause is selected, where the first clause is number 0. If a prefix parameter is given (as ~n[), then the parameter is used instead of an argument. If arg is out of range then no clause is selected and no error is signaled. After the selected alternative has been processed, the control string continues after the ~].

~[str0~;str1~;...~;strn~:;default~] has a default case. If the last ~; used to separate clauses is ~:; instead, then the last clause is an else clause that is performed if no other clause is selected. For example:

"~[Siamese~;Manx~;Persian~:;Alley~] Cat"

~:[alternative~;consequent~] selects the alternative control string if arg is false, and selects the consequent control string otherwise.

~@[consequent~] tests the argument. If it is true, then the argument is not used up by the ~[ command but remains as the next one to be processed, and the one clause consequent is processed. If the arg is false, then the argument is used up, and the clause is not processed. The clause therefore should normally use exactly one argument, and may expect it to be non-nil. For example: 

 (setq *print-level* nil *print-length* 5)
 (format nil
        "~@[ print level = ~D~]~@[ print length = ~D~]"
        *print-level* *print-length*)
⇒   " print length = 5"

Note also that 

 (format stream "...~@[str~]..." ...)
≡ (format stream "...~:[~;~:*str~]..." ...)

The combination of ~[ and # is useful, for example, for dealing with English conventions for printing lists: 

 (setq foo "Items:~#[ none~; ~S~; ~S and ~S~
           ~:;~@{~#[~; and~] ~S~^ ,~}~].")
 (format nil foo) ⇒   "Items: none."
 (format nil foo 'foo) ⇒   "Items: FOO."
 (format nil foo 'foo 'bar) ⇒   "Items: FOO and BAR."
 (format nil foo 'foo 'bar 'baz) ⇒   "Items: FOO, BAR, and BAZ."
 (format nil foo 'foo 'bar 'baz 'quux) ⇒   "Items: FOO, BAR, BAZ, and QUUX."

Next: , Previous: , Up: FORMAT Control-Flow Operations  

gcl-2.6.14/info/gcl/The-_0022Name_0022-Section-of-a-Dictionary-Entry.html0000644000175000017500000001256714360276512023524 0ustar cammcamm The "Name" Section of a Dictionary Entry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Dictionary Entries  

1.4.4.18 The "Name" Section of a Dictionary Entry

This section introduces the dictionary entry. It is not explicitly labeled. It appears preceded and followed by a horizontal bar.

In large print at left, the defined name appears; if more than one defined name is to be described by the entry, all such names are shown separated by commas.

In somewhat smaller italic print at right is an indication of what kind of dictionary entry this is. Possible values are:

Accessor

This is an accessor function.

Class

This is a class.

Condition Type

This is a subtype of type condition.

Constant Variable

This is a constant variable.

Declaration

This is a declaration identifier.

Function

This is a function.

Local Function

This is a function that is defined only lexically within the scope of some other macro form.

Local Macro

This is a macro that is defined only lexically within the scope of some other macro form.

Macro

This is a macro.

Restart

This is a restart.

Special Operator

This is a special operator.

Standard Generic Function

This is a standard generic function.

Symbol

This is a symbol that is specially recognized in some particular situation, such as the syntax of a macro.

System Class

This is like class, but it identifies a class that is potentially a built-in class. (No class is actually required to be a built-in class.)

Type

This is an atomic type specifier, and depending on information for each particular entry, may subject to form other type specifiers.

Type Specifier

This is a defined name that is not an atomic type specifier, but that can be used in constructing valid type specifiers.

Variable

This is a dynamic variable.

Next: , Previous: , Up: Interpreting Dictionary Entries  

gcl-2.6.14/info/gcl/Stream-Concepts.html0000644000175000017500000000530514360276512016373 0ustar cammcamm Stream Concepts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams  

21.1 Stream Concepts

• Introduction to Streams  
• Stream Variables  
• Stream Arguments to Standardized Functions  
• Restrictions on Composite Streams  
gcl-2.6.14/info/gcl/simple_002dstring.html0000644000175000017500000000701214360276512016626 0ustar cammcamm simple-string (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Strings Dictionary  

16.2.3 simple-string [Type]

Supertypes::

simple-string, string, vector, simple-array, array, sequence, t

Description::

A simple string is a specialized one-dimensional simple array whose elements are of type character or a subtype of type character. When used as a type specifier for object creation, simple-string means (simple-array character (size)).

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(simple-string{[size]})

Compound Type Specifier Arguments::

size—a non-negative fixnum, or the symbol *.

Compound Type Specifier Description::

This denotes the union of all types (simple-array c (size)) for all subtypes c of character; that is, the set of simple strings of size size.

gcl-2.6.14/info/gcl/sequence.html0000644000175000017500000000550014360276512015171 0ustar cammcamm sequence (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.1 sequence [System Class]

Class Precedence List::

sequence, t

Description::

Sequences are ordered collections of objects, called the elements of the sequence.

The types vector and the type list are disjoint subtypes of type sequence, but are not necessarily an exhaustive partition of sequence.

When viewing a vector as a sequence, only the active elements of that vector are considered elements of the sequence; that is, sequence operations respect the fill pointer when given sequences represented as vectors.

gcl-2.6.14/info/gcl/_002aprint_002dcircle_002a.html0000644000175000017500000001024714360276512017674 0ustar cammcamm *print-circle* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.19 *print-circle* [Variable]

Value Type::

a generalized boolean.

Initial Value::

false.

Description::

Controls the attempt to detect circularity and sharing in an object being printed.

If false, the printing process merely proceeds by recursive descent without attempting to detect circularity and sharing.

If true, the printer will endeavor to detect cycles and sharing in the structure to be printed, and to use #n= and #n# syntax to indicate the circularities or shared components.

If true, a user-defined

print-object method

can print objects to the supplied stream using write, prin1, princ, or format and expect circularities and sharing to be detected and printed using the #n# syntax.

If a user-defined

print-object method

prints to a stream other than the one that was supplied, then circularity detection starts over for that stream.

Note that implementations should not use #n# notation when the Lisp reader would automatically assure sharing without it (e.g., as happens with interned symbols).

Examples::

 (let ((a (list 1 2 3)))
   (setf (cdddr a) a)
   (let ((*print-circle* t))
     (write a)
     :done))
 |>  #1=(1 2 3 . #1#)
⇒  :DONE

See Also::

write

Notes::

An attempt to print a circular structure with *print-circle* set to nil may lead to looping behavior and failure to terminate.

gcl-2.6.14/info/gcl/Ordering-of-Characters.html0000644000175000017500000001041014360276512017605 0ustar cammcamm Ordering of Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Character Concepts  

13.1.6 Ordering of Characters

The total ordering on characters is guaranteed to have the following properties:

*

If two characters have the same implementation-defined attributes, then their ordering by char< is consistent with the numerical ordering by the predicate < on their code attributes.

*

If two characters differ in any attribute, then they are not char=.

[Reviewer Note by Barmar: I wonder if we should say that the ordering may be dependent on the implementation-defined attributes.]

*

The total ordering is not necessarily the same as the total ordering on the integers produced by applying char-int to the characters.

*

While alphabetic_1 standard characters of a given case must obey a partial ordering, they need not be contiguous; it is permissible for uppercase and lowercase characters to be interleaved. Thus (char<= #\a x #\z) is not a valid way of determining whether or not x is a lowercase character.

Of the standard characters, those which are alphanumeric obey the following partial ordering: 

 A<B<C<D<E<F<G<H<I<J<K<L<M<N<O<P<Q<R<S<T<U<V<W<X<Y<Z
 a<b<c<d<e<f<g<h<i<j<k<l<m<n<o<p<q<r<s<t<u<v<w<x<y<z
 0<1<2<3<4<5<6<7<8<9
 either 9<A or Z<0
 either 9<a or z<0

This implies that, for standard characters, alphabetic_1 ordering holds within each case (uppercase and lowercase), and that the numeric characters as a group are not interleaved with alphabetic characters. However, the ordering or possible interleaving of uppercase characters and lowercase characters is implementation-defined.

gcl-2.6.14/info/gcl/simple_002dcondition.html0000644000175000017500000000630114360276512017306 0ustar cammcamm simple-condition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.18 simple-condition [Condition Type]

Class Precedence List::

simple-condition, condition, t

Description::

The type simple-condition represents conditions that are signaled by signal whenever a format-control is supplied as the function’s first argument.

The format control and format arguments are initialized with the initialization arguments named :format-control

and :format-arguments to make-condition, and are accessed by the functions

simple-condition-format-control

and simple-condition-format-arguments. If format arguments are not supplied to make-condition, nil is used as a default.

See Also::

simple-condition-format-control ,

simple-condition-format-arguments

gcl-2.6.14/info/gcl/Examples-of-Style-for-Semicolon.html0000644000175000017500000000530314360276512021352 0ustar cammcamm Examples of Style for Semicolon (ANSI and GNU Common Lisp Document)

Previous: , Up: Semicolon  

2.4.4.7 Examples of Style for Semicolon

;;;; Math Utilities

;;; FIB computes the the Fibonacci function in the traditional
;;; recursive way.

(defun fib (n)
  (check-type n integer)
  ;; At this point we're sure we have an integer argument.
  ;; Now we can get down to some serious computation.
  (cond ((< n 0)
         ;; Hey, this is just supposed to be a simple example.
         ;; Did you really expect me to handle the general case?
         (error "FIB got ~D as an argument." n))
        ((< n 2) n)             ;fib[0]=0 and fib[1]=1
        ;; The cheap cases didn't work.
        ;; Nothing more to do but recurse.
        (t (+ (fib (- n 1))     ;The traditional formula
              (fib (- n 2)))))) ; is fib[n-1]+fib[n-2].
gcl-2.6.14/info/gcl/Interactive-Use-of-Restarts.html0000644000175000017500000000623314360276512020603 0ustar cammcamm Interactive Use of Restarts (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Signaling and Handling Conditions  

9.1.4.4 Interactive Use of Restarts

For interactive handling, two pieces of information are needed from a restart: a report function and an interactive function.

The report function is used by a program such as the debugger to present a description of the action the restart will take. The report function is specified and established by the :report-function keyword to restart-bind or the :report keyword to restart-case.

The interactive function, which can be specified using the :interactive-function keyword to restart-bind or :interactive keyword to restart-case, is used when the restart is invoked interactively, such as from the debugger, to produce a suitable list of arguments.

invoke-restart invokes the most recently established restart whose name is the same as the first argument to invoke-restart. If a restart is invoked interactively by the debugger and does not transfer control but rather returns values, the precise action of the debugger on those values is implementation-defined.

gcl-2.6.14/info/gcl/search.html0000644000175000017500000001201114360276512014621 0ustar cammcamm search (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.16 search [Function]

search sequence-1 sequence-2 &key from-end test test-not key start1 start2 end1 end2
⇒ position

Arguments and Values::

Sequence-1—a sequence.

Sequence-2—a sequence.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

key—a designator for a function of one argument, or nil.

start1, end1—bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively.

start2, end2—bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively.

position—a bounding index of sequence-2, or nil.

Description::

Searches sequence-2 for a subsequence that matches sequence-1.

The implementation may choose to search sequence-2 in any order; there is no guarantee on the number of times the test is made. For example, when start-end is true, the sequence might actually be searched from left to right instead of from right to left (but in either case would return the rightmost matching subsequence). If the search succeeds, search returns the offset into sequence-2 of the first element of the leftmost or rightmost matching subsequence, depending on from-end; otherwise search returns nil.

If from-end is true, the index of the leftmost element of the rightmost matching subsequence is returned.

Examples::

 (search "dog" "it's a dog's life") ⇒  7
 (search '(0 1) '(2 4 6 1 3 5) :key #'oddp) ⇒  2

See Also::

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/Visible-Modification-of-Objects-with-respect-to-EQUALP.html0000644000175000017500000000554614360276512025405 0ustar cammcamm Visible Modification of Objects with respect to EQUALP (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Modifying Hash Table Keys  

18.1.2.5 Visible Modification of Objects with respect to EQUALP

As a consequence of the behavior for equalp, the rules for visible modification of objects not explicitly mentioned in this section are inherited from those in Visible Modification of Objects with respect to EQUAL.

gcl-2.6.14/info/gcl/gentemp.html0000644000175000017500000001425214360276512015024 0ustar cammcamm gentemp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.9 gentemp [Function]

gentemp &optional prefix package ⇒ new-symbol

Arguments and Values::

prefix—a string. The default is "T".

package—a package designator. The default is the current package.

new-symbol—a fresh, interned symbol.

Description::

gentemp creates and returns a fresh symbol, interned in the indicated package. The symbol is guaranteed to be one that was not previously accessible in package. It is neither bound nor fbound, and has a null property list.

The name of the new-symbol is the concatenation of the prefix and a suffix, which is taken from an internal counter used only by gentemp. (If a symbol by that name is already accessible in package, the counter is incremented as many times as is necessary to produce a name that is not already the name of a symbol accessible in package.)

Examples::

 (gentemp) ⇒  T1298
 (gentemp "FOO") ⇒  FOO1299
 (find-symbol "FOO1300") ⇒  NIL, NIL
 (gentemp "FOO") ⇒  FOO1300
 (find-symbol "FOO1300") ⇒  FOO1300, :INTERNAL
 (intern "FOO1301") ⇒  FOO1301, :INTERNAL
 (gentemp "FOO") ⇒  FOO1302
 (gentemp) ⇒  T1303

Side Effects::

Its internal counter is incremented one or more times.

Interns the new-symbol in package.

Affected By::

The current state of its internal counter, and the current state of the package.

Exceptional Situations::

Should signal an error of type type-error if prefix is not a string. Should signal an error of type type-error if package is not a package designator.

See Also::

gensym

Notes::

The function gentemp is deprecated.

If package is the KEYWORD package, the result is an external symbol of package. Otherwise, the result is an internal symbol of package.

The gentemp internal counter is independent of *gensym-counter*, the counter used by gensym. There is no provision for accessing the gentemp internal counter.

Just because gentemp creates a symbol which did not previously exist does not mean that such a symbol might not be seen in the future (e.g., in a data file—perhaps even created by the same program in another session). As such, this symbol is not truly unique in the same sense as a gensym would be. In particular, programs which do automatic code generation should be careful not to attach global attributes to such generated symbols (e.g., special declarations) and then write them into a file because such global attributes might, in a different session, end up applying to other symbols that were automatically generated on another day for some other purpose.

Next: , Previous: , Up: Symbols Dictionary  

gcl-2.6.14/info/gcl/null.html0000644000175000017500000000621014360276512014332 0ustar cammcamm null (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.24 null [Function]

null object ⇒ boolean

Arguments and Values::

object—an object.

boolean—a boolean.

Description::

Returns t if object is the empty list; otherwise, returns nil.

Examples::

 (null '()) ⇒  T
 (null nil) ⇒  T
 (null t) ⇒  NIL
 (null 1) ⇒  NIL

See Also::

not

Notes::

null is intended to be used to test for the empty list whereas not is intended to be used to invert a boolean (or generalized boolean). Operationally, null and not compute the same result; which to use is a matter of style. 

 (null object) ≡ (typep object 'null) ≡ (eq object '())
gcl-2.6.14/info/gcl/ed.html0000644000175000017500000000757314360276512013765 0ustar cammcamm ed (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.17 ed [Function]

ed &optional x ⇒ implementation-dependent

Arguments and Values::

x—nil, a pathname, a string, or a function name.

The default is nil.

Description::

ed invokes the editor if the implementation provides a resident editor.

If x is nil, the editor is entered. If the editor had been previously entered, its prior state is resumed, if possible.

If x is a pathname or string, it is taken as the pathname designator for a file to be edited.

If x is a function name, the text of its definition is edited. The means by which the function text is obtained is implementation-defined.

Exceptional Situations::

The consequences are undefined if the implementation does not provide a resident editor.

Might signal type-error if its argument is supplied but is not a symbol, a pathname, or nil.

If a failure occurs when performing some operation on the file system while attempting to edit a file, an error of type file-error is signaled.

An error of type file-error might be signaled if x is a designator for a wild pathname.

Implementation-dependent additional conditions might be signaled as well.

See Also::

pathname,

logical-pathname,

compile-file , load ,

Pathnames as Filenames

gcl-2.6.14/info/gcl/Contagion-in-Numeric-Operations.html0000644000175000017500000000524514360276512021435 0ustar cammcamm Contagion in Numeric Operations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numeric Operations  

12.1.1.3 Contagion in Numeric Operations

For information about the contagion rules for implicit coercions of arguments in numeric operations, see Rule of Float Precision Contagion, Rule of Float and Rational Contagion, and Rule of Complex Contagion.

gcl-2.6.14/info/gcl/Examples-of-FORMAT.html0000644000175000017500000001601714360276512016534 0ustar cammcamm Examples of FORMAT (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Formatted Output  

22.3.11 Examples of FORMAT

 (format nil "foo") ⇒  "foo"
 (setq x 5) ⇒  5
 (format nil "The answer is ~D." x) ⇒  "The answer is 5."
 (format nil "The answer is ~3D." x) ⇒  "The answer is   5."
 (format nil "The answer is ~3,'0D." x) ⇒  "The answer is 005."
 (format nil "The answer is ~:D." (expt 47 x))
⇒  "The answer is 229,345,007."
 (setq y "elephant") ⇒  "elephant"
 (format nil "Look at the ~A!" y) ⇒  "Look at the elephant!"
 (setq n 3) ⇒  3
 (format nil "~D item~:P found." n) ⇒  "3 items found."
 (format nil "~R dog~:[s are~; is~] here." n (= n 1))
⇒  "three dogs are here."
 (format nil "~R dog~:*~[s are~; is~:;s are~] here." n)
⇒  "three dogs are here."
 (format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n)
⇒  "Here are three puppies."

 (defun foo (x)
   (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F"
           x x x x x x)) ⇒  FOO
 (foo 3.14159)  ⇒  "  3.14| 31.42|  3.14|3.1416|3.14|3.14159"
 (foo -3.14159) ⇒  " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159"
 (foo 100.0)    ⇒  "100.00|******|100.00| 100.0|100.00|100.0"
 (foo 1234.0)   ⇒  "1234.00|******|??????|1234.0|1234.00|1234.0"
 (foo 0.006)    ⇒  "  0.01|  0.06|  0.01| 0.006|0.01|0.006"

 (defun foo (x)  
    (format nil
           "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~
            ~9,3,2,-2,'
           x x x x))
 (foo 3.14159)  ⇒  "  3.14E+0| 31.42$-01|+.003E+03|  3.14E+0"
 (foo -3.14159) ⇒  " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0"
 (foo 1100.0)   ⇒  "  1.10E+3| 11.00$+02|+.001E+06|  1.10E+3"
 (foo 1100.0L0) ⇒  "  1.10L+3| 11.00$+02|+.001L+06|  1.10L+3"
 (foo 1.1E13)   ⇒  "*********| 11.00$+12|+.001E+16| 1.10E+13"
 (foo 1.1L120)  ⇒  "*********|??????????|
 (foo 1.1L1200) ⇒  "*********|??????????|

As an example of the effects of varying the scale factor, the code 

 (dotimes (k 13)
   (format t "~
           (- k 5) (- k 5) 3.14159))

produces the following output: 

Scale factor -5: | 0.000003E+06|
Scale factor -4: | 0.000031E+05|
Scale factor -3: | 0.000314E+04|
Scale factor -2: | 0.003142E+03|
Scale factor -1: | 0.031416E+02|
Scale factor  0: | 0.314159E+01|
Scale factor  1: | 3.141590E+00|
Scale factor  2: | 31.41590E-01|
Scale factor  3: | 314.1590E-02|
Scale factor  4: | 3141.590E-03|
Scale factor  5: | 31415.90E-04|
Scale factor  6: | 314159.0E-05|
Scale factor  7: | 3141590.E-06|

 (defun foo (x)
   (format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'
          x x x x))                                     
 (foo 0.0314159) ⇒  "  3.14E-2|314.2$-04|0.314E-01|  3.14E-2"
 (foo 0.314159)  ⇒  "  0.31   |0.314    |0.314    | 0.31    "
 (foo 3.14159)   ⇒  "   3.1   | 3.14    | 3.14    |  3.1    "
 (foo 31.4159)   ⇒  "   31.   | 31.4    | 31.4    |  31.    "
 (foo 314.159)   ⇒  "  3.14E+2| 314.    | 314.    |  3.14E+2"
 (foo 3141.59)   ⇒  "  3.14E+3|314.2$+01|0.314E+04|  3.14E+3"
 (foo 3141.59L0) ⇒  "  3.14L+3|314.2$+01|0.314L+04|  3.14L+3"
 (foo 3.14E12)   ⇒  "*********|314.0$+10|0.314E+13| 3.14E+12"
 (foo 3.14L120)  ⇒  "*********|?????????|
 (foo 3.14L1200) ⇒  "*********|?????????|

 (format nil "~10<foo~;bar~>")   ⇒  "foo    bar"
 (format nil "~10:<foo~;bar~>")  ⇒  "  foo  bar"
 (format nil "~10<foobar~>")     ⇒  "    foobar"
 (format nil "~10:<foobar~>")    ⇒  "    foobar"
 (format nil "~10:@<foo~;bar~>") ⇒  "  foo bar "
 (format nil "~10@<foobar~>")    ⇒  "foobar    "
 (format nil "~10:@<foobar~>")   ⇒  "  foobar  "

  (FORMAT NIL "Written to ~A." #P"foo.bin")
  ⇒  "Written to foo.bin."

Next: , Previous: , Up: Formatted Output  

gcl-2.6.14/info/gcl/make_002dsequence.html0000644000175000017500000001222214360276512016553 0ustar cammcamm make-sequence (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.5 make-sequence [Function]

make-sequence result-type size &key initial-element ⇒ sequence

Arguments and Values::

result-type—a sequence type specifier.

size—a non-negative integer.

initial-element—an object. The default is implementation-dependent.

sequence—a proper sequence.

Description::

Returns a sequence of the type result-type and of length size, each of the elements of which has been initialized to initial-element.

If the result-type is a subtype of list, the result will be a list.

If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled.

Examples::

 (make-sequence 'list 0) ⇒  ()
 (make-sequence 'string 26 :initial-element #\.) 
⇒  ".........................."
 (make-sequence '(vector double-float) 2
                :initial-element 1d0)
⇒  #(1.0d0 1.0d0)

 (make-sequence '(vector * 2) 3) should signal an error
 (make-sequence '(vector * 4) 3) should signal an error

Affected By::

The implementation.

Exceptional Situations::

The consequences are unspecified if initial-element is not an object which can be stored in the resulting sequence.

An error of type type-error must be signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector.

An error of type type-error should be signaled if result-type specifies the number of elements and size is different from that number.

See Also::

make-array , make-list

Notes::

 (make-sequence 'string 5) ≡ (make-string 5)

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/machine_002dversion.html0000644000175000017500000000614014360276512017121 0ustar cammcamm machine-version (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Environment Dictionary  

25.2.28 machine-version [Function]

machine-version <no arguments> ⇒ description

Arguments and Values::

description—a string or nil.

Description::

Returns a string that identifies the version of the computer hardware on which Common Lisp is running, or nil if no such value can be computed.

Examples::

 (machine-version) ⇒  "KL-10, microcode 9"

Affected By::

The machine version, and the implementation.

See Also::

machine-type , machine-instance

gcl-2.6.14/info/gcl/read.html0000644000175000017500000002213314360276512014275 0ustar cammcamm read (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Reader Dictionary  

23.2.4 read, read-preserving-whitespace [Function]

read &optional input-stream eof-error-p eof-value recursive-p ⇒ object

read-preserving-whitespace &optional input-stream eof-error-p eof-value recursive-p
⇒ object

Arguments and Values::

input-stream—an input stream designator.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object.

The default is nil.

recursive-p—a generalized boolean. The default is false.

object—an object (parsed by the Lisp reader) or the eof-value.

Description::

read parses the printed representation of an object from input-stream and builds such an object.

read-preserving-whitespace is like read but preserves any whitespace_2 character that delimits the printed representation of the object. read-preserving-whitespace is exactly like read when the recursive-p argument to read-preserving-whitespace is true.

When *read-suppress* is false, read throws away the delimiting character required by certain printed representations if it is a whitespace_2 character; but read preserves the character (using unread-char) if it is syntactically meaningful, because it could be the start of the next expression.

If a file ends in a symbol or a number immediately followed by an end of file_1, read reads the symbol or number successfully; when called again, it sees the end of file_1 and only then acts according to eof-error-p. If a file contains ignorable text at the end, such as blank lines and comments, read does not consider it to end in the middle of an object.

If recursive-p is true, the call to read is expected to be made from within some function that itself has been called from read or from a similar input function, rather than from the top level.

Both functions return the object read from input-stream. Eof-value is returned if eof-error-p is false and end of file is reached before the beginning of an object.

Examples::

 (read)
 |>  |>>'a<<|
⇒  (QUOTE A)
 (with-input-from-string (is " ") (read is nil 'the-end)) ⇒  THE-END
 (defun skip-then-read-char (s c n)
    (if (char= c #\{) (read s t nil t) (read-preserving-whitespace s))
    (read-char-no-hang s)) ⇒  SKIP-THEN-READ-CHAR
 (let ((*readtable* (copy-readtable nil)))
    (set-dispatch-macro-character #\# #\{ #'skip-then-read-char)
    (set-dispatch-macro-character #\# #\} #'skip-then-read-char)
    (with-input-from-string (is "#{123 x #}123 y")
      (format t "~S ~S" (read is) (read is)))) ⇒  #\x, #\Space, NIL

As an example, consider this reader macro definition: 

 (defun slash-reader (stream char)
   (declare (ignore char))
   `(path . ,(loop for dir = (read-preserving-whitespace stream t nil t)
                   then (progn (read-char stream t nil t)
                               (read-preserving-whitespace stream t nil t))
                   collect dir
                   while (eql (peek-char nil stream nil nil t) #\/))))
 (set-macro-character #\/ #'slash-reader)

Consider now calling read on this expression: 

 (zyedh /usr/games/zork /usr/games/boggle)

The / macro reads objects separated by more / characters; thus /usr/games/zork is intended to read as (path usr games zork). The entire example expression should therefore be read as 

 (zyedh (path usr games zork) (path usr games boggle))

However, if read had been used instead of read-preserving-whitespace, then after the reading of the symbol zork, the following space would be discarded; the next call to peek-char would see the following /, and the loop would continue, producing this interpretation: 

 (zyedh (path usr games zork usr games boggle))

There are times when whitespace_2 should be discarded. If a command interpreter takes single-character commands, but occasionally reads an object then if the whitespace_2 after a symbol is not discarded it might be interpreted as a command some time later after the symbol had been read.

Affected By::

*standard-input*, *terminal-io*, *readtable*, *read-default-float-format*, *read-base*, *read-suppress*, *package*, *read-eval*.

Exceptional Situations::

read signals an error of type end-of-file, regardless of eof-error-p, if the file ends in the middle of an object representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, read signals an error. This is detected when read or read-preserving-whitespace is called with recursive-p and eof-error-p non-nil, and end-of-file is reached before the beginning of an object.

If eof-error-p is true, an error of type end-of-file is signaled at the end of file.

See Also::

peek-char , read-char , unread-char , read-from-string , read-delimited-list , parse-integer , Syntax, Reader Concepts

Next: , Previous: , Up: Reader Dictionary  

gcl-2.6.14/info/gcl/bit-_0028Array_0029.html0000644000175000017500000000775614360276512016355 0ustar cammcamm bit (Array) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.33 bit, sbit [Accessor]

bit bit-array &rest subscripts ⇒ bit

sbit bit-array &rest subscripts ⇒ bit

(setf (bit bit-array &rest subscripts) new-bit)
(setf (sbit bit-array &rest subscripts) new-bit)

Arguments and Values::

bit-array—for bit, a bit array; for sbit, a simple bit array.

subscripts—a list of valid array indices for the bit-array.

bit—a bit.

Description::

bit and sbit access the bit-array element specified by subscripts.

These functions ignore the fill pointer when accessing elements.

Examples::

 (bit (setq ba (make-array 8 
                            :element-type 'bit 
                            :initial-element 1))
       3) ⇒  1
 (setf (bit ba 3) 0) ⇒  0
 (bit ba 3) ⇒  0
 (sbit ba 5) ⇒  1
 (setf (sbit ba 5) 1) ⇒  1
 (sbit ba 5) ⇒  1

See Also::

aref ,

Compiler Terminology

Notes::

bit and sbit are like aref except that they require arrays to be a bit array and a simple bit array, respectively.

bit and sbit, unlike char and schar, allow the first argument to be an array of any rank.

gcl-2.6.14/info/gcl/_003d.html0000644000175000017500000002024214360276512014166 0ustar cammcamm = (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.15 =, /=, <, >, <=, >= [Function]

= &rest numbers^+ ⇒ generalized-boolean

/= &rest numbers^+ ⇒ generalized-boolean

< &rest numbers^+ ⇒ generalized-boolean

> &rest numbers^+ ⇒ generalized-boolean

<= &rest numbers^+ ⇒ generalized-boolean

>= &rest numbers^+ ⇒ generalized-boolean

Arguments and Values::

number—for <, >, <=, >=: a real; for =, /=: a number.

generalized-boolean—a generalized boolean.

Description::

=, /=, <, >, <=, and >= perform arithmetic comparisons on their arguments as follows:

=

The value of = is true if all numbers are the same in value; otherwise it is false. Two complexes are considered equal by = if their real and imaginary parts are equal according to =.

/=

The value of /= is true if no two numbers are the same in value; otherwise it is false.

<

The value of < is true if the numbers are in monotonically increasing order; otherwise it is false.

>

The value of > is true if the numbers are in monotonically decreasing order; otherwise it is false.

<=

The value of <= is true if the numbers are in monotonically nondecreasing order; otherwise it is false.

>=

The value of >= is true if the numbers are in monotonically nonincreasing order; otherwise it is false.

=, /=, <, >, <=, and >= perform necessary type conversions.

Examples::

The uses of these functions are illustrated in Figure 12–12. 

  (= 3 3) is true.              (/= 3 3) is false.             
  (= 3 5) is false.             (/= 3 5) is true.              
  (= 3 3 3 3) is true.          (/= 3 3 3 3) is false.         
  (= 3 3 5 3) is false.         (/= 3 3 5 3) is false.         
  (= 3 6 5 2) is false.         (/= 3 6 5 2) is true.          
  (= 3 2 3) is false.           (/= 3 2 3) is false.           
  (< 3 5) is true.              (<= 3 5) is true.              
  (< 3 -5) is false.            (<= 3 -5) is false.            
  (< 3 3) is false.             (<= 3 3) is true.              
  (< 0 3 4 6 7) is true.        (<= 0 3 4 6 7) is true.        
  (< 0 3 4 4 6) is false.       (<= 0 3 4 4 6) is true.        
  (> 4 3) is true.              (>= 4 3) is true.              
  (> 4 3 2 1 0) is true.        (>= 4 3 2 1 0) is true.        
  (> 4 3 3 2 0) is false.       (>= 4 3 3 2 0) is true.        
  (> 4 3 1 2 0) is false.       (>= 4 3 1 2 0) is false.       
  (= 3) is true.                (/= 3) is true.                
  (< 3) is true.                (<= 3) is true.                
  (= 3.0 #c(3.0 0.0)) is true.  (/= 3.0 #c(3.0 1.0)) is true.  
  (= 3 3.0) is true.            (= 3.0s0 3.0d0) is true.       
  (= 0.0 -0.0) is true.         (= 5/2 2.5) is true.           
  (> 0.0 -0.0) is false.        (= 0 -0.0) is true.            
  (<= 0 x 9) is true if x is between 0 and 9, inclusive
  (< 0.0 x 1.0) is true if x is between 0.0 and 1.0, exclusive
  (< -1 j (length v)) is true if j is a valid array index for a vector v

         Figure 12–12: Uses of /=, =, <, >, <=, and >=

Exceptional Situations::

Might signal type-error if some argument is not a real. Might signal arithmetic-error if otherwise unable to fulfill its contract.

Notes::

= differs from eql in that (= 0.0 -0.0) is always true, because = compares the mathematical values of its operands, whereas eql compares the representational values, so to speak.

Next: , Previous: , Up: Numbers Dictionary  

gcl-2.6.14/info/gcl/Tilde-I_002d_003e-Indent.html0000644000175000017500000000462514360276512017312 0ustar cammcamm Tilde I-> Indent (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Pretty Printer Operations  

22.3.5.3 Tilde I: Indent

~nI is the same as (pprint-indent :block n).

~n:I is the same as (pprint-indent :current n). In both cases, n defaults to zero, if it is omitted.

gcl-2.6.14/info/gcl/The-Global-Environment.html0000644000175000017500000000555414360276512017612 0ustar cammcamm The Global Environment (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction to Environments  

3.1.1.1 The Global Environment

The global environment is that part of an environment that contains bindings with both indefinite scope and indefinite extent. The global environment contains, among other things, the following:

*

bindings of dynamic variables and constant variables.

*

bindings of functions, macros, and special operators.

*

bindings of compiler macros.

*

bindings of type and class names

*

information about proclamations.

gcl-2.6.14/info/gcl/Tilde-F_002d_003e-Fixed_002dFormat-Floating_002dPoint.html0000644000175000017500000001602714360276512024322 0ustar cammcamm Tilde F-> Fixed-Format Floating-Point (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Floating-Point Printers  

22.3.3.1 Tilde F: Fixed-Format Floating-Point

The next arg is printed as a float.

The full form is ~w,d,k,overflowchar,padcharF. The parameter w is the width of the field to be printed; d is the number of digits to print after the decimal point; k is a scale factor that defaults to zero.

Exactly w characters will be output. First, leading copies of the character padchar (which defaults to a space) are printed, if necessary, to pad the field on the left. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. Then a sequence of digits, containing a single embedded decimal point, is printed; this represents the magnitude of the value of arg times 10^k, rounded to d fractional digits. When rounding up and rounding down would produce printed values equidistant from the scaled value of arg, then the implementation is free to use either one. For example, printing the argument 6.375 using the format ~4,2F may correctly produce either 6.37 or 6.38. Leading zeros are not permitted, except that a single zero digit is output before the decimal point if the printed value is less than one, and this single zero digit is not output at all if w=d+1.

If it is impossible to print the value in the required format in a field of width w, then one of two actions is taken. If the parameter overflowchar is supplied, then w copies of that parameter are printed instead of the scaled value of arg. If the overflowchar parameter is omitted, then the scaled value is printed using more than w characters, as many more as may be needed.

If the w parameter is omitted, then the field is of variable width. In effect, a value is chosen for w in such a way that no leading pad characters need to be printed and exactly d characters will follow the decimal point. For example, the directive ~,2F will print exactly two digits after the decimal point and as many as necessary before the decimal point.

If the parameter d is omitted, then there is no constraint on the number of digits to appear after the decimal point. A value is chosen for d in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter w and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero, then a single zero digit should appear after the decimal point if permitted by the width constraint.

If both w and d are omitted, then the effect is to print the value using ordinary free-format output; prin1 uses this format for any number whose magnitude is either zero or between 10^-3 (inclusive) and 10^7 (exclusive).

If w is omitted, then if the magnitude of arg is so large (or, if d is also omitted, so small) that more than 100 digits would have to be printed, then an implementation is free, at its discretion, to print the number using exponential notation instead, as if by the directive ~E (with all parameters to ~E defaulted, not taking their values from the ~F directive).

If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If w and d are not supplied and the number has no exact decimal representation, for example 1/3, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed.

If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w.

~F binds *print-escape* to false

and *print-readably* to false.

Next: , Previous: , Up: FORMAT Floating-Point Printers  

gcl-2.6.14/info/gcl/Embedded-Newlines-in-Condition-Reports.html0000644000175000017500000000633014360276512022622 0ustar cammcamm Embedded Newlines in Condition Reports (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printing Conditions  

9.1.3.4 Embedded Newlines in Condition Reports

Especially if it is long, it is permissible and appropriate for a report message to contain one or more embedded newlines.

If the calling routine conventionally inserts some additional prefix (such as “Error: ” or “;; Error: ”) on the first line of the message, it must also assure that an appropriate prefix will be added to each subsequent line of the output, so that the left edge of the message output by the condition reporter will still be properly aligned. 

 (defun test ()
   (error "This is an error message.~%It has two lines."))

 ;; Implementation A
 (test)
 This is an error message.
 It has two lines.

 ;; Implementation B
 (test)
 ;; Error: This is an error message.
 ;;        It has two lines.

 ;; Implementation C
 (test)
 >> Error: This is an error message. 
           It has two lines.
gcl-2.6.14/info/gcl/Special-Pathname-Component-Values.html0000644000175000017500000000432614360276512021676 0ustar cammcamm Special Pathname Component Values (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.6 Special Pathname Component Values

gcl-2.6.14/info/gcl/Recommended-Style-in-Condition-Reporting.html0000644000175000017500000000621114360276512023200 0ustar cammcamm Recommended Style in Condition Reporting (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printing Conditions  

9.1.3.1 Recommended Style in Condition Reporting

In order to ensure a properly aesthetic result when presenting report messages to the user, certain stylistic conventions are recommended.

There are stylistic recommendations for the content of the messages output by condition reporters, but there are no formal requirements on those programs. If a program violates the recommendations for some message, the display of that message might be less aesthetic than if the guideline had been observed, but the program is still considered a conforming program.

The requirements on a program or implementation which invokes a condition reporter are somewhat stronger. A conforming program must be permitted to assume that if these style guidelines are followed, proper aesthetics will be maintained. Where appropriate, any specific requirements on such routines are explicitly mentioned below.

gcl-2.6.14/info/gcl/Conformance.html0000644000175000017500000000525614360276512015623 0ustar cammcamm Conformance (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Introduction (Introduction)  

1.5 Conformance

This standard presents the syntax and semantics to be implemented by a conforming implementation (and its accompanying documentation). In addition, it imposes requirements on conforming programs.

• Conforming Implementations  
• Conforming Programs  
gcl-2.6.14/info/gcl/invalid_002dmethod_002derror.html0000644000175000017500000001011714360276512020534 0ustar cammcamm invalid-method-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conditions Dictionary  

9.2.15 invalid-method-error [Function]

invalid-method-error method format-control &rest args ⇒ implementation-dependent

Arguments and Values::

method—a method.

format-control—a format control.

args—format arguments for the format-control.

Description::

The function invalid-method-error is used to signal an error of type error when there is an applicable method whose qualifiers are not valid for the method combination type. The error message is constructed by using the format-control suitable for format and any args to it. Because an implementation may need to add additional contextual information to the error message, invalid-method-error should be called only within the dynamic extent of a method combination function.

The function invalid-method-error is called automatically when a method fails to satisfy every qualifier pattern and predicate in a define-method-combination form. A method combination function that imposes additional restrictions should call invalid-method-error explicitly if it encounters a method it cannot accept.

Whether invalid-method-error returns to its caller or exits via throw is implementation-dependent.

Side Effects::

The debugger might be entered.

Affected By::

*break-on-signals*

See Also::

define-method-combination

gcl-2.6.14/info/gcl/_002aprint_002dlevel_002a.html0000644000175000017500000001405314360276512017541 0ustar cammcamm *print-level* (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Printer Dictionary  

22.4.22 *print-level*, *print-length* [Variable]

Value Type::

a non-negative integer, or nil.

Initial Value::

nil.

Description::

*print-level* controls how many levels deep a nested object will print. If it is false, then no control is exercised. Otherwise, it is an integer indicating the maximum level to be printed. An object to be printed is at level 0; its components (as of a list or vector) are at level 1; and so on. If an object to be recursively printed has components and is at a level equal to or greater than the value of *print-level*, then the object is printed as “#”.

*print-length* controls how many elements at a given level are printed. If it is false, there is no limit to the number of components printed. Otherwise, it is an integer indicating the maximum number of elements of an object to be printed. If exceeded, the printer will print “...” in place of the other elements. In the case of a dotted list, if the list contains exactly as many elements as the value of *print-length*, the terminating atom is printed rather than printing “...”

*print-level* and *print-length* affect the printing of an any object printed with a list-like syntax. They do not affect the printing of symbols, strings, and bit vectors.

Examples::

 (setq a '(1 (2 (3 (4 (5 (6))))))) ⇒  (1 (2 (3 (4 (5 (6))))))
 (dotimes (i 8) 
   (let ((*print-level* i)) 
     (format t "~&~D -- ~S~
 |>  0 -- #
 |>  1 -- (1 #)
 |>  2 -- (1 (2 #))
 |>  3 -- (1 (2 (3 #)))
 |>  4 -- (1 (2 (3 (4 #))))
 |>  5 -- (1 (2 (3 (4 (5 #)))))
 |>  6 -- (1 (2 (3 (4 (5 (6))))))
 |>  7 -- (1 (2 (3 (4 (5 (6))))))
⇒  NIL

 (setq a '(1 2 3 4 5 6)) ⇒  (1 2 3 4 5 6)
 (dotimes (i 7) 
   (let ((*print-length* i)) 
     (format t "~&~D -- ~S~
 |>  0 -- (...)
 |>  1 -- (1 ...)
 |>  2 -- (1 2 ...)
 |>  3 -- (1 2 3 ...)
 |>  4 -- (1 2 3 4 ...)
 |>  5 -- (1 2 3 4 5 6)
 |>  6 -- (1 2 3 4 5 6)
⇒  NIL

(dolist (level-length '((0 1) (1 1) (1 2) (1 3) (1 4) 
                        (2 1) (2 2) (2 3) (3 2) (3 3) (3 4)))
 (let ((*print-level*  (first  level-length))
       (*print-length* (second level-length)))
   (format t "~&~D ~D -- ~S~
           *print-level* *print-length* 
           '(if (member x y) (+ (car x) 3) '(foo . #(a b c d "Baz"))))))
 |>  0 1 -- #
 |>  1 1 -- (IF ...)
 |>  1 2 -- (IF # ...)
 |>  1 3 -- (IF # # ...)
 |>  1 4 -- (IF # # #)
 |>  2 1 -- (IF ...)
 |>  2 2 -- (IF (MEMBER X ...) ...)
 |>  2 3 -- (IF (MEMBER X Y) (+ # 3) ...)
 |>  3 2 -- (IF (MEMBER X ...) ...)
 |>  3 3 -- (IF (MEMBER X Y) (+ (CAR X) 3) ...)
 |>  3 4 -- (IF (MEMBER X Y) (+ (CAR X) 3) '(FOO . #(A B C D ...)))
⇒  NIL

See Also::

write

Next: , Previous: , Up: Printer Dictionary  

gcl-2.6.14/info/gcl/Semicolon.html0000644000175000017500000000713014360276512015312 0ustar cammcamm Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Standard Macro Characters  

2.4.4 Semicolon

Syntax: ;<<text>>

A semicolon introduces characters that are to be ignored, such as comments. The semicolon and all characters up to and including the next newline or end of file are ignored.

• Examples of Semicolon  
• Notes about Style for Semicolon  
• Use of Single Semicolon  
• Use of Double Semicolon  
• Use of Triple Semicolon  
• Use of Quadruple Semicolon  
• Examples of Style for Semicolon  
gcl-2.6.14/info/gcl/Storage-Layout-for-Multidimensional-Arrays.html0000644000175000017500000000467514360276512023612 0ustar cammcamm Storage Layout for Multidimensional Arrays (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.8 Storage Layout for Multidimensional Arrays

Multidimensional arrays store their components in row-major order; that is, internally a multidimensional array is stored as a one-dimensional array, with the multidimensional index sets ordered lexicographically, last index varying fastest.

gcl-2.6.14/info/gcl/Examples-of-for_002das_002dpackage-subclause.html0000644000175000017500000000530714360276512023430 0ustar cammcamm Examples of for-as-package subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.14 Examples of for-as-package subclause

 (let ((*package* (make-package "TEST-PACKAGE-1")))
   ;; For effect, intern some symbols
   (read-from-string "(THIS IS A TEST)")
   (export (intern "THIS"))
   (loop for x being each present-symbol of *package*
          do (print x)))
 |>  A 
 |>  TEST 
 |>  THIS
 |>  IS 
⇒  NIL
gcl-2.6.14/info/gcl/arrayp.html0000644000175000017500000000623314360276512014663 0ustar cammcamm arrayp (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.20 arrayp [Function]

arrayp object ⇒ generalized-boolean

Arguments and Values::

object—an object.

generalized-boolean—a generalized boolean.

Description::

Returns true if object is of type array; otherwise, returns false.

Examples::

 (arrayp (make-array '(2 3 4) :adjustable t)) ⇒  true
 (arrayp (make-array 6)) ⇒  true
 (arrayp #*1011) ⇒  true
 (arrayp "hi") ⇒  true
 (arrayp 'hi) ⇒  false
 (arrayp 12) ⇒  false

See Also::

typep

Notes::

 (arrayp object) ≡ (typep object 'array)
gcl-2.6.14/info/gcl/position.html0000644000175000017500000001253514360276512015233 0ustar cammcamm position (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Sequences Dictionary  

17.3.15 position, position-if, position-if-not [Function]

position item sequence &key from-end test test-not start end key ⇒ position

position-if predicate sequence &key from-end start end key ⇒ position

position-if-not predicate sequence &key from-end start end key ⇒ position

Arguments and Values::

item—an object.

sequence—a proper sequence.

predicate—a designator for a function of one argument that returns a generalized boolean.

from-end—a generalized boolean. The default is false.

test—a designator for a function of two arguments that returns a generalized boolean.

test-not—a designator for a function of two arguments that returns a generalized boolean.

start, end—bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.

key—a designator for a function of one argument, or nil.

position—a bounding index of sequence, or nil.

Description::

position, position-if, and position-if-not each search sequence for an element that satisfies the test.

The position returned is the index within sequence of the leftmost (if from-end is true) or of the rightmost (if from-end is false) element that satisfies the test; otherwise nil is returned. The index returned is relative to the left-hand end of the entire sequence, regardless of the value of start, end, or from-end.

Examples::

 (position #\a "baobab" :from-end t) ⇒  4
 (position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) ⇒  2
 (position 595 '()) ⇒  NIL
 (position-if-not #'integerp '(1 2 3 4 5.0)) ⇒  4

Exceptional Situations::

Should be prepared to signal an error of type type-error if sequence is not a proper sequence.

See Also::

find ,

Traversal Rules and Side Effects

Notes::

The :test-not argument is deprecated.

The function position-if-not is deprecated.

Next: , Previous: , Up: Sequences Dictionary  

gcl-2.6.14/info/gcl/control_002derror.html0000644000175000017500000000522314360276512016642 0ustar cammcamm control-error (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.67 control-error [Condition Type]

Class Precedence List::

control-error, error, serious-condition, condition, t

Description::

The type control-error consists of error conditions that result from invalid dynamic transfers of control in a program. The errors that result from giving throw a tag that is not active or from giving go or return-from a tag that is no longer dynamically available are of type control-error.

gcl-2.6.14/info/gcl/read_002dline.html0000644000175000017500000001221514360276512015672 0ustar cammcamm read-line (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Streams Dictionary  

21.2.22 read-line [Function]

read-line &optional input-stream eof-error-p eof-value recursive-p
⇒ line, missing-newline-p

Arguments and Values::

input-stream—an input stream designator. The default is standard input.

eof-error-p—a generalized boolean. The default is true.

eof-value—an object. The default is nil.

recursive-p—a generalized boolean. The default is false.

line—a string or the eof-value.

missing-newline-p—a generalized boolean.

Description::

Reads from input-stream a line of text that is terminated by a newline or end of file.

If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader.

The primary value, line, is the line that is read, represented as a string (without the trailing newline, if any). If eof-error-p is false and the end of file for input-stream is reached before any characters are read, eof-value is returned as the line.

The secondary value, missing-newline-p, is a generalized boolean that is false if the line was terminated by a newline, or true if the line was terminated by the end of file for input-stream (or if the line is the eof-value).

Examples::

 (setq a "line 1
 line2")
⇒  "line 1
 line2"
 (read-line (setq input-stream (make-string-input-stream a)))
⇒  "line 1", false
 (read-line input-stream)
⇒  "line2", true
 (read-line input-stream nil nil)
⇒  NIL, true

Affected By::

*standard-input*, *terminal-io*.

Exceptional Situations::

If an end of file_2 occurs before any characters are read in the line, an error is signaled if eof-error-p is true.

See Also::

read

Notes::

The corresponding output function is write-line.

Next: , Previous: , Up: Streams Dictionary  

gcl-2.6.14/info/gcl/char_003d.html0000644000175000017500000002563014360276512015032 0ustar cammcamm char= (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Characters Dictionary  

13.2.5 char=, char/=, char<, char>, char<=, char>=,

char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp,

char-not-lessp

[Function]

char= &rest characters^+ ⇒ generalized-boolean

char/= &rest characters^+ ⇒ generalized-boolean

char< &rest characters^+ ⇒ generalized-boolean

char> &rest characters^+ ⇒ generalized-boolean

char<= &rest characters^+ ⇒ generalized-boolean

char>= &rest characters^+ ⇒ generalized-boolean

char-equal &rest characters^+ ⇒ generalized-boolean

char-not-equal &rest characters^+ ⇒ generalized-boolean

char-lessp &rest characters^+ ⇒ generalized-boolean

char-greaterp &rest characters^+ ⇒ generalized-boolean

char-not-greaterp &rest characters^+ ⇒ generalized-boolean

char-not-lessp &rest characters^+ ⇒ generalized-boolean

Arguments and Values::

character—a character.

generalized-boolean—a generalized boolean.

Description::

These predicates compare characters.

char= returns true if all characters are the same; otherwise, it returns false.

If two characters differ in any implementation-defined attributes, then they are not char=.

char/= returns true if all characters are different; otherwise, it returns false.

char< returns true if the characters are monotonically increasing; otherwise, it returns false.

If two characters have identical implementation-defined attributes, then their ordering by char< is consistent with the numerical ordering by the predicate < on their codes.

char> returns true if the characters are monotonically decreasing; otherwise, it returns false.

If two characters have identical implementation-defined attributes, then their ordering by char> is consistent with the numerical ordering by the predicate > on their codes.

char<= returns true if the characters are monotonically nondecreasing; otherwise, it returns false.

If two characters have identical implementation-defined attributes, then their ordering by char<= is consistent with the numerical ordering by the predicate <= on their codes.

char>= returns true if the characters are monotonically nonincreasing; otherwise, it returns false.

If two characters have identical implementation-defined attributes, then their ordering by char>= is consistent with the numerical ordering by the predicate >= on their codes.

char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, and char-not-lessp are similar to char=, char/=, char<, char>, char<=, char>=, respectively, except that they ignore differences in case and

might have an implementation-defined behavior for non-simple characters. For example, an implementation might define that char-equal, etc. ignore certain implementation-defined attributes. The effect, if any, of each implementation-defined attribute upon these functions must be specified as part of the definition of that attribute.

Examples::

 (char= #\d #\d) ⇒  true
 (char= #\A #\a) ⇒  false
 (char= #\d #\x) ⇒  false
 (char= #\d #\D) ⇒  false
 (char/= #\d #\d) ⇒  false
 (char/= #\d #\x) ⇒  true
 (char/= #\d #\D) ⇒  true
 (char= #\d #\d #\d #\d) ⇒  true
 (char/= #\d #\d #\d #\d) ⇒  false
 (char= #\d #\d #\x #\d) ⇒  false
 (char/= #\d #\d #\x #\d) ⇒  false
 (char= #\d #\y #\x #\c) ⇒  false
 (char/= #\d #\y #\x #\c) ⇒  true
 (char= #\d #\c #\d) ⇒  false
 (char/= #\d #\c #\d) ⇒  false
 (char< #\d #\x) ⇒  true
 (char<= #\d #\x) ⇒  true
 (char< #\d #\d) ⇒  false
 (char<= #\d #\d) ⇒  true
 (char< #\a #\e #\y #\z) ⇒  true
 (char<= #\a #\e #\y #\z) ⇒  true
 (char< #\a #\e #\e #\y) ⇒  false
 (char<= #\a #\e #\e #\y) ⇒  true
 (char> #\e #\d) ⇒  true
 (char>= #\e #\d) ⇒  true
 (char> #\d #\c #\b #\a) ⇒  true
 (char>= #\d #\c #\b #\a) ⇒  true
 (char> #\d #\d #\c #\a) ⇒  false
 (char>= #\d #\d #\c #\a) ⇒  true
 (char> #\e #\d #\b #\c #\a) ⇒  false
 (char>= #\e #\d #\b #\c #\a) ⇒  false
 (char> #\z #\A) ⇒  implementation-dependent
 (char> #\Z #\a) ⇒  implementation-dependent
 (char-equal #\A #\a) ⇒  true
 (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp)
⇒  (#\A #\a #\b #\B #\c #\C)
 (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char<)
⇒  (#\A #\B #\C #\a #\b #\c) ;Implementation A
⇒  (#\a #\b #\c #\A #\B #\C) ;Implementation B
⇒  (#\a #\A #\b #\B #\c #\C) ;Implementation C
⇒  (#\A #\a #\B #\b #\C #\c) ;Implementation D
⇒  (#\A #\B #\a #\b #\C #\c) ;Implementation E

Exceptional Situations::

Should signal an error of type program-error if at least one character is not supplied.

See Also::

Character Syntax, Documentation of Implementation-Defined Scripts

Notes::

If characters differ in their code attribute or any implementation-defined attribute, they are considered to be different by char=.

There is no requirement that (eq c1 c2) be true merely because (char= c1 c2) is true. While eq can distinguish two characters that char= does not, it is distinguishing them not as characters, but in some sense on the basis of a lower level implementation characteristic. If (eq c1 c2) is true, then (char= c1 c2) is also true. eql and equal compare characters in the same way that char= does.

The manner in which case is used by char-equal, char-not-equal, char-lessp, char-greaterp, char-not-greaterp, and char-not-lessp implies an ordering for standard characters such that A=a, B=b, and so on, up to Z=z, and furthermore either 9<A or Z<0.

Next: , Previous: , Up: Characters Dictionary  

gcl-2.6.14/info/gcl/make_002dsymbol.html0000644000175000017500000001027414360276512016255 0ustar cammcamm make-symbol (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Symbols Dictionary  

10.2.5 make-symbol [Function]

make-symbol name ⇒ new-symbol

Arguments and Values::

name—a string.

new-symbol—a fresh, uninterned symbol.

Description::

make-symbol creates and returns a fresh, uninterned symbol whose name is the given name. The new-symbol is neither bound nor fbound and has a null property list.

It is implementation-dependent whether the string that becomes the new-symbol’s name is the given name or a copy of it. Once a string has been given as the name argument to make-symbol, the consequences are undefined if a subsequent attempt is made to alter that string.

Examples::

 (setq temp-string "temp") ⇒  "temp"
 (setq temp-symbol (make-symbol temp-string)) ⇒  #:|temp|
 (symbol-name temp-symbol) ⇒  "temp"
 (eq (symbol-name temp-symbol) temp-string) ⇒  implementation-dependent
 (find-symbol "temp") ⇒  NIL, NIL
 (eq (make-symbol temp-string) (make-symbol temp-string)) ⇒  false

Exceptional Situations::

Should signal an error of type type-error if name is not a string.

See Also::

copy-symbol

Notes::

No attempt is made by make-symbol to convert the case of the name to uppercase. The only case conversion which ever occurs for symbols is done by the Lisp reader. The program interface to symbol creation retains case, and the program interface to interning symbols is case-sensitive.

gcl-2.6.14/info/gcl/row_002dmajor_002daref.html0000644000175000017500000000676714360276512017351 0ustar cammcamm row-major-aref (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Arrays Dictionary  

15.2.22 row-major-aref [Accessor]

row-major-aref array index ⇒ element

(setf ( row-major-aref array index) new-element)

Arguments and Values::

array—an array.

index—a valid array row-major index for the array.

element, new-element—an object.

Description::

Considers array as a vector by viewing its elements in row-major order, and returns the element of that vector which is referred to by the given index.

row-major-aref is valid for use with setf.

See Also::

aref , array-row-major-index

Notes::

 (row-major-aref array index) ≡
   (aref (make-array (array-total-size array)
                     :displaced-to array
                     :element-type (array-element-type array))
         index)

 (aref array i1 i2 ...) ≡
     (row-major-aref array (array-row-major-index array i1 i2))
gcl-2.6.14/info/gcl/Relation-between-component-values-NIL-and-_002d_003eUNSPECIFIC.html0000644000175000017500000000606314360276512026151 0ustar cammcamm Relation between component values NIL and ->UNSPECIFIC (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Interpreting Pathname Component Values  

19.2.2.10 Relation between component values NIL and :UNSPECIFIC

If a pathname is converted to a namestring, the symbols nil and :unspecific cause the field to be treated as if it were empty. That is, both nil and :unspecific cause the component not to appear in the namestring.

However, when merging a pathname with a set of defaults, only a nil value for a component will be replaced with the default for that component, while a value of :unspecific will be left alone as if the field were “filled”; see the function merge-pathnames and Merging Pathnames.

gcl-2.6.14/info/gcl/Fill-Pointers.html0000644000175000017500000000530614360276512016054 0ustar cammcamm Fill Pointers (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Array Elements  

15.1.1.6 Fill Pointers

A fill pointer is a non-negative integer no larger than the total number of elements in a vector. Not all vectors have fill pointers. See the functions make-array and adjust-array.

An element of a vector is said to be active if it has an index that is greater than or equal to zero, but less than the fill pointer (if any). For an array that has no fill pointer, all elements are considered active.

Only vectors may have fill pointers; multidimensional arrays may not. A multidimensional array that is displaced to a vector that has a fill pointer can be created.

gcl-2.6.14/info/gcl/Tilde-E_002d_003e-Exponential-Floating_002dPoint.html0000644000175000017500000002035014360276512023644 0ustar cammcamm Tilde E-> Exponential Floating-Point (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: FORMAT Floating-Point Printers  

22.3.3.2 Tilde E: Exponential Floating-Point

The next arg is printed as a float in exponential notation.

The full form is ~w,d,e,k,overflowchar,padchar,exponentcharE. The parameter w is the width of the field to be printed; d is the number of digits to print after the decimal point; e is the number of digits to use when printing the exponent; k is a scale factor that defaults to one (not zero).

Exactly w characters will be output. First, leading copies of the character padchar (which defaults to a space) are printed, if necessary, to pad the field on the left. If the arg is negative, then a minus sign is printed; if the arg is not negative, then a plus sign is printed if and only if the @ modifier was supplied. Then a sequence of digits containing a single embedded decimal point is printed. The form of this sequence of digits depends on the scale factor k. If k is zero, then d digits are printed after the decimal point, and a single zero digit appears before the decimal point if the total field width will permit it. If k is positive, then it must be strictly less than d+2; k significant digits are printed before the decimal point, and d- k+1 digits are printed after the decimal point. If k is negative, then it must be strictly greater than - d; a single zero digit appears before the decimal point if the total field width will permit it, and after the decimal point are printed first - k zeros and then d+k significant digits. The printed fraction must be properly rounded. When rounding up and rounding down would produce printed values equidistant from the scaled value of arg, then the implementation is free to use either one. For example, printing the argument 637.5 using the format ~8,2E may correctly produce either 6.37E+2 or 6.38E+2.

Following the digit sequence, the exponent is printed. First the character parameter exponentchar is printed; if this parameter is omitted, then the exponent marker that prin1 would use is printed, as determined from the type of the float and the current value of *read-default-float-format*. Next, either a plus sign or a minus sign is printed, followed by e digits representing the power of ten by which the printed fraction must be multiplied to properly represent the rounded value of arg.

If it is impossible to print the value in the required format in a field of width w, possibly because k is too large or too small or because the exponent cannot be printed in e character positions, then one of two actions is taken. If the parameter overflowchar is supplied, then w copies of that parameter are printed instead of the scaled value of arg. If the overflowchar parameter is omitted, then the scaled value is printed using more than w characters, as many more as may be needed; if the problem is that d is too small for the supplied k or that e is too small, then a larger value is used for d or e as may be needed.

If the w parameter is omitted, then the field is of variable width. In effect a value is chosen for w in such a way that no leading pad characters need to be printed.

If the parameter d is omitted, then there is no constraint on the number of digits to appear. A value is chosen for d in such a way that as many digits as possible may be printed subject to the width constraint imposed by the parameter w, the constraint of the scale factor k, and the constraint that no trailing zero digits may appear in the fraction, except that if the fraction to be printed is zero then a single zero digit should appear after the decimal point.

If the parameter e is omitted, then the exponent is printed using the smallest number of digits necessary to represent its value.

If all of w, d, and e are omitted, then the effect is to print the value using ordinary free-format exponential-notation output; prin1 uses

a similar

format for any non-zero number whose magnitude is less than 10^-3 or greater than or equal to 10^7.

The only difference is that the ~E directive always prints a plus or minus sign in front of the exponent, while prin1 omits the plus sign if the exponent is non-negative.

If arg is a rational number, then it is coerced to be a single float and then printed. Alternatively, an implementation is permitted to process a rational number by any other method that has essentially the same behavior but avoids loss of precision or overflow because of the coercion. If w and d are unsupplied and the number has no exact decimal representation, for example 1/3, some precision cutoff must be chosen by the implementation since only a finite number of digits may be printed.

If arg is a complex number or some non-numeric object, then it is printed using the format directive ~wD, thereby printing it in decimal radix and a minimum field width of w.

~E binds *print-escape* to false

and *print-readably* to false.

Next: , Previous: , Up: FORMAT Floating-Point Printers  

gcl-2.6.14/info/gcl/Characters.html0000644000175000017500000000441014360276512015437 0ustar cammcamm Characters (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

13 Characters

• Character Concepts  
• Characters Dictionary  
gcl-2.6.14/info/gcl/Declarations.html0000644000175000017500000000715214360276512015776 0ustar cammcamm Declarations (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation  

3.3 Declarations

Declarations provide a way of specifying information for use by program processors, such as the evaluator or the compiler.

Local declarations

can be embedded in executable code using declare. Global declarations , or proclamations , are established by proclaim or declaim.

The the special form provides a shorthand notation for making a local declaration about the type of the value of a given form.

The consequences are undefined if a program violates a declaration or a proclamation.

• Minimal Declaration Processing Requirements  
• Declaration Specifiers  
• Declaration Identifiers  
• Declaration Scope  
gcl-2.6.14/info/gcl/When-Compiler-Macros-Are-Used.html0000644000175000017500000000752614360276512020671 0ustar cammcamm When Compiler Macros Are Used (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Compilation Semantics  

3.2.2.4 When Compiler Macros Are Used

The presence of a compiler macro definition for a function or macro indicates that it is desirable for the compiler to use the expansion of the compiler macro instead of the original function form or macro form. However, no language processor (compiler, evaluator, or other code walker) is ever required to actually invoke compiler macro functions, or to make use of the resulting expansion if it does invoke a compiler macro function.

When the compiler encounters a form during processing that represents a call to a compiler macro name (that is not declared notinline), the compiler might expand the compiler macro, and might use the expansion in place of the original form.

When eval encounters a form during processing that represents a call to a compiler macro name (that is not declared notinline), eval might expand the compiler macro, and might use the expansion in place of the original form.

There are two situations in which a compiler macro definition must not be applied by any language processor:

*

The global function name binding associated with the compiler macro is shadowed by a lexical binding of the function name.

*

The function name has been declared or proclaimed notinline and the call form appears within the scope of the declaration.

It is unspecified whether compiler macros are expanded or used in any other situations.

gcl-2.6.14/info/gcl/Conditional-Execution-Clauses.html0000644000175000017500000001055014360276512021163 0ustar cammcamm Conditional Execution Clauses (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The LOOP Facility  

6.1.6 Conditional Execution Clauses

The if, when, and unless constructs establish conditional control in a loop. If the test passes, the succeeding loop clause is executed. If the test does not pass, the succeeding clause is skipped, and program control moves to the clause that follows the loop keyword else. If the test does not pass and no else clause is supplied, control is transferred to the clause or construct following the entire conditional clause.

If conditional clauses are nested, each else is paired with the closest preceding conditional clause that has no associated else or end.

In the if and when clauses, which are synonymous, the test passes if the value of form is true.

In the unless clause, the test passes if the value of form is false.

Clauses that follow the test expression can be grouped by using the loop keyword and to produce a conditional block consisting of a compound clause.

The loop keyword it can be used to refer to the result of the test expression in a clause. Use the loop keyword it in place of the form in a return clause or an accumulation clause that is inside a conditional execution clause. If multiple clauses are connected with and, the it construct must be in the first clause in the block.

The optional loop keyword end marks the end of the clause. If this keyword is not supplied, the next loop keyword marks the end. The construct end can be used to distinguish the scoping of compound clauses.

• Examples of WHEN clause  

Next: , Previous: , Up: The LOOP Facility  

gcl-2.6.14/info/gcl/short_002dfloat_002depsilon.html0000644000175000017500000000723514360276512020421 0ustar cammcamm short-float-epsilon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.77 short-float-epsilon, short-float-negative-epsilon,

single-float-epsilon, single-float-negative-epsilon,

double-float-epsilon, double-float-negative-epsilon,

long-float-epsilon, long-float-negative-epsilon

[Constant Variable]

Constant Value::

implementation-dependent.

Description::

The value of each of the constants short-float-epsilon, single-float-epsilon, double-float-epsilon, and long-float-epsilon is the smallest positive float \epsilon of the given format, such that the following expression is true when evaluated:

(not (= (float 1 \epsilon) (+ (float 1 \epsilon) \epsilon)))\/

The value of each of the constants short-float-negative-epsilon, single-float-negative-epsilon, double-float-negative-epsilon, and long-float-negative-epsilon is the smallest positive float \epsilon of the given format, such that the following expression is true when evaluated:

(not (= (float 1 \epsilon) (- (float 1 \epsilon) \epsilon)))\/

gcl-2.6.14/info/gcl/lambda_002dparameters_002dlimit.html0000644000175000017500000000561014360276512021200 0ustar cammcamm lambda-parameters-limit (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.14 lambda-parameters-limit [Constant Variable]

Constant Value::

implementation-dependent, but not smaller than 50.

Description::

A positive integer that is the upper exclusive bound on the number of parameter names that can appear in a single lambda list.

See Also::

call-arguments-limit

Notes::

Implementors are encouraged to make the value of lambda-parameters-limit as large as possible.

gcl-2.6.14/info/gcl/nil-_0028Type_0029.html0000644000175000017500000000520214360276512016204 0ustar cammcamm nil (Type) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Types and Classes Dictionary  

4.4.1 nil [Type]

Supertypes::

all types

Description::

The type nil contains no objects and so is also called the empty type. The type nil is a subtype of every type. No object is of type nil.

Notes::

The type containing the object nil is the type null, not the type nil.

gcl-2.6.14/info/gcl/Standard-Meta_002dobjects.html0000644000175000017500000000614614360276512020113 0ustar cammcamm Standard Meta-objects (ANSI and GNU Common Lisp Document)

Previous: , Up: Meta-Objects  

7.4.1 Standard Meta-objects

The object system supplies a set of meta-objects, called standard meta-objects. These include the class standard-object and instances of the classes standard-method, standard-generic-function, and method-combination.

[Editorial Note by KMP: This is said redundantly in the definition of STANDARD-METHOD.]

*

The class standard-method is the default class of methods defined by the defmethod and defgeneric forms.

*

The class standard-generic-function is the default class of generic functions defined by the forms defmethod, defgeneric,

and defclass.

*

The class named standard-object is an instance of the class standard-class and is a superclass of every class that is an instance of standard-class except itself and structure-class.

*

Every method combination object is an instance of a subclass of class method-combination.

gcl-2.6.14/info/gcl/Examples-of-for_002das_002darithmetic-subclause.html0000644000175000017500000000555214360276512024170 0ustar cammcamm Examples of for-as-arithmetic subclause (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Variable Initialization and Stepping Clauses  

6.1.2.3 Examples of for-as-arithmetic subclause

;; Print some numbers.
 (loop for i from 1 to 3
       do (print i))
 |>  1
 |>  2
 |>  3
⇒  NIL

;; Print every third number.
 (loop for i from 10 downto 1 by 3
       do (print i))
 |>  10 
 |>  7 
 |>  4 
 |>  1 
⇒  NIL

;; Step incrementally from the default starting value.
 (loop for i below 3
       do (print i))
 |>  0
 |>  1
 |>  2
⇒  NIL
gcl-2.6.14/info/gcl/define_002dcompiler_002dmacro.html0000644000175000017500000002467214360276512020655 0ustar cammcamm define-compiler-macro (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

3.8.9 define-compiler-macro [Macro]

define-compiler-macro name lambda-list [[{declaration}* | documentation]] {form}*
⇒ name

Arguments and Values::

name—a function name.

lambda-list—a macro lambda list.

declaration—a declare expression; not evaluated.

documentation—a string; not evaluated.

form—a form.

Description::

[Editorial Note by KMP: This definition probably needs to be fully expanded to not refer through the definition of defmacro, but should suffice for now.]

This is the normal mechanism for defining a compiler macro function. Its manner of definition is the same as for defmacro; the only differences are:

*

The name can be a function name naming any function or macro.

*

The expander function is installed as a compiler macro function for the name, rather than as a macro function.

*

The &whole argument is bound to the form argument that is passed to the compiler macro function. The remaining lambda-list parameters are specified as if this form contained the function name in the car and the actual arguments in the cdr, but if the car of the actual form is the symbol funcall, then the destructuring of the arguments is actually performed using its cddr instead.

*

Documentation is attached as a documentation string to name (as kind compiler-macro) and to the compiler macro function.

*

Unlike an ordinary macro, a compiler macro can decline to provide an expansion merely by returning a form that is the same as the original (which can be obtained by using &whole).

Examples::

 (defun square (x) (expt x 2)) ⇒  SQUARE
 (define-compiler-macro square (&whole form arg)
   (if (atom arg)
       `(expt ,arg 2)
       (case (car arg)
         (square (if (= (length arg) 2)
                     `(expt ,(nth 1 arg) 4)
                     form))
         (expt   (if (= (length arg) 3)
                     (if (numberp (nth 2 arg))
                         `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg)))
                         `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg))))
                     form))
         (otherwise `(expt ,arg 2))))) ⇒  SQUARE
 (square (square 3)) ⇒  81
 (macroexpand '(square x)) ⇒  (SQUARE X), false
 (funcall (compiler-macro-function 'square) '(square x) nil)
⇒  (EXPT X 2)
 (funcall (compiler-macro-function 'square) '(square (square x)) nil)
⇒  (EXPT X 4)
 (funcall (compiler-macro-function 'square) '(funcall #'square x) nil)
⇒  (EXPT X 2)

 (defun distance-positional (x1 y1 x2 y2)
   (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2))))
⇒  DISTANCE-POSITIONAL
 (defun distance (&key (x1 0) (y1 0) (x2 x1) (y2 y1))
   (distance-positional x1 y1 x2 y2))
⇒  DISTANCE
 (define-compiler-macro distance (&whole form
                                  &rest key-value-pairs
                                  &key (x1 0  x1-p)
                                       (y1 0  y1-p)
                                       (x2 x1 x2-p)
                                       (y2 y1 y2-p)
                                  &allow-other-keys
                                  &environment env)
   (flet ((key (n) (nth (* n 2) key-value-pairs))
          (arg (n) (nth (1+ (* n 2)) key-value-pairs))
          (simplep (x)
            (let ((expanded-x (macroexpand x env)))
              (or (constantp expanded-x env)
                  (symbolp expanded-x)))))
     (let ((n (/ (length key-value-pairs) 2)))
       (multiple-value-bind (x1s y1s x2s y2s others)
           (loop for (key) on key-value-pairs by #'cddr
                 count (eq key ':x1) into x1s
                 count (eq key ':y1) into y1s
                 count (eq key ':x2) into x2s
                 count (eq key ':y1) into y2s
                 count (not (member key '(:x1 :x2 :y1 :y2)))
                   into others
                 finally (return (values x1s y1s x2s y2s others)))
         (cond ((and (= n 4)
                     (eq (key 0) :x1)
                     (eq (key 1) :y1)
                     (eq (key 2) :x2)
                     (eq (key 3) :y2))
                `(distance-positional ,x1 ,y1 ,x2 ,y2))
               ((and (if x1-p (and (= x1s 1) (simplep x1)) t)
                     (if y1-p (and (= y1s 1) (simplep y1)) t)
                     (if x2-p (and (= x2s 1) (simplep x2)) t)
                     (if y2-p (and (= y2s 1) (simplep y2)) t)
                     (zerop others))
                `(distance-positional ,x1 ,y1 ,x2 ,y2))
               ((and (< x1s 2) (< y1s 2) (< x2s 2) (< y2s 2)
                     (zerop others))
                (let ((temps (loop repeat n collect (gensym))))
                  `(let ,(loop for i below n
                               collect (list (nth i temps) (arg i)))
                     (distance
                       ,@(loop for i below n
                               append (list (key i) (nth i temps)))))))
               (t form))))))
⇒  DISTANCE
 (dolist (form
           '((distance :x1 (setq x 7) :x2 (decf x) :y1 (decf x) :y2 (decf x))
             (distance :x1 (setq x 7) :y1 (decf x) :x2 (decf x) :y2 (decf x))
             (distance :x1 (setq x 7) :y1 (incf x))
             (distance :x1 (setq x 7) :y1 (incf x) :x1 (incf x))
             (distance :x1 a1 :y1 b1 :x2 a2 :y2 b2)
             (distance :x1 a1 :x2 a2 :y1 b1 :y2 b2)
             (distance :x1 a1 :y1 b1 :z1 c1 :x2 a2 :y2 b2 :z2 c2)))
   (print (funcall (compiler-macro-function 'distance) form nil)))
 |>  (LET ((#:G6558 (SETQ X 7))
 |>        (#:G6559 (DECF X))
 |>        (#:G6560 (DECF X))
 |>        (#:G6561 (DECF X)))
 |>    (DISTANCE :X1 #:G6558 :X2 #:G6559 :Y1 #:G6560 :Y2 #:G6561)) 
 |>  (DISTANCE-POSITIONAL (SETQ X 7) (DECF X) (DECF X) (DECF X)) 
 |>  (LET ((#:G6567 (SETQ X 7))
 |>        (#:G6568 (INCF X)))
 |>    (DISTANCE :X1 #:G6567 :Y1 #:G6568)) 
 |>  (DISTANCE :X1 (SETQ X 7) :Y1 (INCF X) :X1 (INCF X)) 
 |>  (DISTANCE-POSITIONAL A1 B1 A2 B2) 
 |>  (DISTANCE-POSITIONAL A1 B1 A2 B2) 
 |>  (DISTANCE :X1 A1 :Y1 B1 :Z1 C1 :X2 A2 :Y2 B2 :Z2 C2) 
⇒  NIL

See Also::

compiler-macro-function , defmacro , documentation , Syntactic Interaction of Documentation Strings and Declarations

Notes::

The consequences of writing a compiler macro definition for a function in the COMMON-LISP package are undefined; it is quite possible that in some implementations such an attempt would override an equivalent or equally important definition. In general, it is recommended that a programmer only write compiler macro definitions for functions he or she personally maintains–writing a compiler macro definition for a function maintained elsewhere is normally considered a violation of traditional rules of modularity and data abstraction.

Next: , Previous: , Up: Evaluation and Compilation Dictionary  

gcl-2.6.14/info/gcl/Notes-about-Style-for-Semicolon.html0000644000175000017500000000436614360276512021402 0ustar cammcamm Notes about Style for Semicolon (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Semicolon  

2.4.4.2 Notes about Style for Semicolon

Some text editors make assumptions about desired indentation based on the number of semicolons that begin a comment. The following style conventions are common, although not by any means universal.

gcl-2.6.14/info/gcl/constantly.html0000644000175000017500000000643114360276512015563 0ustar cammcamm constantly (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.39 constantly [Function]

constantly value ⇒ function

Arguments and Values::

value—an object.

function—a function.

Description::

constantly returns a function that accepts any number of arguments, that has no side-effects, and that always returns value.

Examples::

 (mapcar (constantly 3) '(a b c d)) ⇒  (3 3 3 3)
 (defmacro with-vars (vars &body forms)
   `((lambda ,vars ,@forms) ,@(mapcar (constantly nil) vars)))
⇒  WITH-VARS
 (macroexpand '(with-vars (a b) (setq a 3 b (* a a)) (list a b)))
⇒  ((LAMBDA (A B) (SETQ A 3 B (* A A)) (LIST A B)) NIL NIL), true

See Also::

not

Notes::

constantly could be defined by: 

 (defun constantly (object)
   #'(lambda (&rest arguments) object))
gcl-2.6.14/info/gcl/Introduction-to-Slots.html0000644000175000017500000001246114360276512017570 0ustar cammcamm Introduction to Slots (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Slots  

7.5.1 Introduction to Slots

An object of metaclass standard-class has zero or more named slots. The slots of an object are determined by the class of the object. Each slot can hold one value.

[Reviewer Note by Barmar: All symbols are valid variable names. Perhaps this means to preclude the use of named constants? We have a terminology problem to solve.] The name of a slot is a symbol that is syntactically valid for use as a variable name.

When a slot does not have a value, the slot is said to be unbound. When an unbound slot is read,

[Reviewer Note by Barmar: from an object whose metaclass is standard-class?] the generic function slot-unbound is invoked. The system-supplied primary method for slot-unbound on class t signals an error.

If slot-unbound returns, its primary value is used that time as the value of the slot.

The default initial value form for a slot is defined by the :initform slot option. When the :initform form is used to supply a value, it is evaluated in the lexical environment in which the defclass form was evaluated. The :initform along with the lexical environment in which the defclass form was evaluated is called a captured initialization form. For more details, see Object Creation and Initialization.

A local slot is defined to be a slot that is accessible to exactly one instance, namely the one in which the slot is allocated. A shared slot is defined to be a slot that is visible to more than one instance of a given class and its subclasses.

A class is said to define a slot with a given name when the defclass form for that class contains a slot specifier with that name. Defining a local slot does not immediately create a slot; it causes a slot to be created each time an instance of the class is created. Defining a shared slot immediately creates a slot.

The :allocation slot option to defclass controls the kind of slot that is defined. If the value of the :allocation slot option is :instance, a local slot is created. If the value of :allocation is :class, a shared slot is created.

A slot is said to be accessible in an instance of a class if the slot is defined by the class of the instance or is inherited from a superclass of that class. At most one slot of a given name can be accessible in an instance. A shared slot defined by a class is accessible in all instances of that class. A detailed explanation of the inheritance of slots is given in Inheritance of Slots and Slot Options.

Next: , Previous: , Up: Slots  

gcl-2.6.14/info/gcl/fdefinition.html0000644000175000017500000001105214360276512015656 0ustar cammcamm fdefinition (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Data and Control Flow Dictionary  

5.3.3 fdefinition [Accessor]

fdefinition function-name ⇒ definition

(setf ( fdefinition function-name) new-definition)

Arguments and Values::

function-name—a function name.

In the non-setf case, the name must be fbound in the global environment.

definition—Current global function definition named by function-name.

new-definition—a function.

Description::

fdefinition accesses the current global function definition named by function-name. The definition may be a function or may be an object representing a special form or macro.

The value returned by fdefinition when fboundp returns true but the function-name denotes a macro or special form is not well-defined, but fdefinition does not signal an error.

Exceptional Situations::

Should signal an error of type type-error if function-name is not a function name.

An error of type undefined-function is signaled in the non-setf case if function-name is not fbound.

See Also::

fboundp , fmakunbound , macro-function ,

special-operator-p ,

symbol-function

Notes::

fdefinition cannot access the value of a lexical function name produced by flet or labels; it can access only the global function value.

setf can be used with fdefinition to replace a global function definition when the function-name’s function definition does not represent a special form.

setf of fdefinition requires a function as the new value. It is an error to set the fdefinition of a function-name to a symbol, a list, or the value returned by fdefinition on the name of a macro or special form.

gcl-2.6.14/info/gcl/Reader.html0000644000175000017500000000425614360276512014572 0ustar cammcamm Reader (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

23 Reader

• Reader Concepts  
• Reader Dictionary  
gcl-2.6.14/info/gcl/null-_0028System-Class_0029.html0000644000175000017500000000535114360276512020007 0ustar cammcamm null (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Conses Dictionary  

14.2.2 null [System Class]

Class Precedence List::

null, symbol, list, sequence, t

Description::

The only object of type null is nil, which represents the empty list and can also be notated ().

See Also::

Symbols as Tokens, Left-Parenthesis, Printing Symbols

gcl-2.6.14/info/gcl/Glossary-_0028Glossary_0029.html0000644000175000017500000000407114360276512020112 0ustar cammcamm Glossary (Glossary) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Top  

26 Glossary

• Glossary  
gcl-2.6.14/info/gcl/rational-_0028System-Class_0029.html0000644000175000017500000000700114360276512020640 0ustar cammcamm rational (System Class) (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.6 rational [System Class]

Class Precedence List::

rational,

real,

number, t

Description::

The canonical representation of a rational is as an integer if its value is integral, and otherwise as a ratio.

The types integer and ratio are disjoint subtypes of type rational.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(rational{[lower-limit [upper-limit]]})

Compound Type Specifier Arguments::

lower-limit, upper-limit—interval designators for type rational. The defaults for each of lower-limit and upper-limit is the symbol *.

Compound Type Specifier Description::

This denotes the rationals on the interval described by lower-limit and upper-limit.

gcl-2.6.14/info/gcl/file_002dwrite_002ddate.html0000644000175000017500000000734114360276512017470 0ustar cammcamm file-write-date (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.6 file-write-date [Function]

file-write-date pathspec ⇒ date

Arguments and Values::

pathspec—a pathname designator.

date—a universal time or nil.

Description::

Returns a universal time representing the time at which the file specified by pathspec was last written (or created), or returns nil if such a time cannot be determined.

Examples::

 (with-open-file (s "noel.text" 
                    :direction :output :if-exists :error)
   (format s "~&Dear Santa,~2
                Please leave lots of toys.~2
             ~2
   (truename s))
⇒  #P"CUPID:/susan/noel.text"
 (with-open-file (s "noel.text")
   (file-write-date s))
⇒  2902600800

Affected By::

The host computer’s file system.

Exceptional Situations::

An error of type file-error is signaled if pathspec is wild.

An error of type file-error is signaled if the file system cannot perform the requested operation.

See Also::

Universal Time,

Pathnames as Filenames

gcl-2.6.14/info/gcl/integer.html0000644000175000017500000001014314360276512015015 0ustar cammcamm integer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.8 integer [System Class]

Class Precedence List::

integer, rational,

real,

number, t

Description::

An integer is a mathematical integer. There is no limit on the magnitude of an integer.

The types fixnum and bignum form an exhaustive partition of type integer.

Compound Type Specifier Kind::

Abbreviating.

Compound Type Specifier Syntax::

(integer{[lower-limit [upper-limit]]})

Compound Type Specifier Arguments::

lower-limit, upper-limit—interval designators for type integer. The defaults for each of lower-limit and upper-limit is the symbol *.

Compound Type Specifier Description::

This denotes the integers on the interval described by lower-limit and upper-limit.

See Also::

Figure~2–9, Constructing Numbers from Tokens, Printing Integers

Notes::

The type (integer lower upper), where lower and upper are most-negative-fixnum and most-positive-fixnum, respectively, is also called fixnum.

The type (integer 0 1) is also called bit. The type (integer 0 *) is also called unsigned-byte.

gcl-2.6.14/info/gcl/Examples-of-using-the-Pretty-Printer.html0000644000175000017500000003675214360276512022365 0ustar cammcamm Examples of using the Pretty Printer (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The Lisp Pretty Printer  

22.2.2 Examples of using the Pretty Printer

As an example of the interaction of logical blocks, conditional newlines, and indentation, consider the function simple-pprint-defun below. This function prints out lists whose cars are defun in the standard way assuming that the list has exactly length 4. 

(defun simple-pprint-defun (*standard-output* list)
  (pprint-logical-block (*standard-output* list :prefix "(" :suffix ")")
    (write (first list))
    (write-char #\Space)
    (pprint-newline :miser)
    (pprint-indent :current 0)
    (write (second list))
    (write-char #\Space)
    (pprint-newline :fill)
    (write (third list))
    (pprint-indent :block 1)
    (write-char #\Space)
    (pprint-newline :linear)
    (write (fourth list))))

Suppose that one evaluates the following: 

(simple-pprint-defun *standard-output* '(defun prod (x y) (* x y)))

If the line width available is greater than or equal to 26, then all of the output appears on one line. If the line width available is reduced to 25, a line break is inserted at the linear-style conditional newline

before the expression (* x y), producing the output shown. The (pprint-indent :block 1) causes (* x y) to be printed at a relative indentation of 1 in the logical block. 

 (DEFUN PROD (X Y) 
   (* X Y))

If the line width available is 15, a line break is also inserted at the fill style conditional newline before the argument list. The call on (pprint-indent :current 0) causes the argument list to line up under the function name. 

(DEFUN PROD
       (X Y)
  (* X Y))

If *print-miser-width* were greater than or equal to 14, the example output above would have been as follows, because all indentation changes are ignored in miser mode and line breaks are inserted at miser-style conditional newlines. 

 (DEFUN
  PROD
  (X Y)
  (* X Y))

As an example of a per-line prefix, consider that evaluating the following produces the output shown with a line width of 20 and *print-miser-width* of nil. 

 (pprint-logical-block (*standard-output* nil :per-line-prefix ";;; ")
   (simple-pprint-defun *standard-output* '(defun prod (x y) (* x y))))

 ;;; (DEFUN PROD
 ;;;        (X Y)
 ;;;   (* X Y))

As a more complex (and realistic) example, consider the function pprint-let below. This specifies how to print a let form in the traditional style. It is more complex than the example above, because it has to deal with nested structure. Also, unlike the example above it contains complete code to readably print any possible list that begins with the symbol let. The outermost pprint-logical-block form handles the printing of the input list as a whole and specifies that parentheses should be printed in the output. The second pprint-logical-block form handles the list of binding pairs. Each pair in the list is itself printed by the innermost pprint-logical-block. (A loop form is used instead of merely decomposing the pair into two objects so that readable output will be produced no matter whether the list corresponding to the pair has one element, two elements, or (being malformed) has more than two elements.) A space and a fill-style conditional newline

are placed after each pair except the last. The loop at the end of the topmost pprint-logical-block form prints out the forms in the body of the let form separated by spaces and linear-style conditional newlines. 

 (defun pprint-let (*standard-output* list)
   (pprint-logical-block (nil list :prefix "(" :suffix ")")
     (write (pprint-pop))
     (pprint-exit-if-list-exhausted)
     (write-char #\Space)
     (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")")
       (pprint-exit-if-list-exhausted)
       (loop (pprint-logical-block (nil (pprint-pop) :prefix "(" :suffix ")")
               (pprint-exit-if-list-exhausted)
               (loop (write (pprint-pop))
                     (pprint-exit-if-list-exhausted)
                     (write-char #\Space)
                     (pprint-newline :linear)))
             (pprint-exit-if-list-exhausted)
             (write-char #\Space)
             (pprint-newline :fill)))
     (pprint-indent :block 1)
     (loop (pprint-exit-if-list-exhausted)
           (write-char #\Space)
           (pprint-newline :linear)
           (write (pprint-pop)))))

Suppose that one evaluates the following with *print-level* being 4, and *print-circle* being true. 

 (pprint-let *standard-output*
             '#1=(let (x (*print-length* (f (g 3))) 
                       (z . 2) (k (car y)))
                   (setq x (sqrt z)) #1#))

If the line length is greater than or equal to 77, the output produced appears on one line. However, if the line length is 76, line breaks are inserted at the linear-style conditional newlines separating the forms in the body and the output below is produced. Note that, the degenerate binding pair x is printed readably even though it fails to be a list; a depth abbreviation marker is printed in place of (g 3); the binding pair (z . 2) is printed readably even though it is not a proper list; and appropriate circularity markers are printed. 

 #1=(LET (X (*PRINT-LENGTH* (F #)) (Z . 2) (K (CAR Y))) 
      (SETQ X (SQRT Z))
      #1#)

If the line length is reduced to 35, a line break is inserted at one of the fill-style conditional newlines separating the binding pairs. 

 #1=(LET (X (*PRINT-PRETTY* (F #))
          (Z . 2) (K (CAR Y)))
      (SETQ X (SQRT Z))
      #1#)

Suppose that the line length is further reduced to 22 and *print-length* is set to 3. In this situation, line breaks are inserted after both the first and second binding pairs. In addition, the second binding pair is itself broken across two lines. Clause (b) of the description of fill-style conditional newlines (see the function pprint-newline) prevents the binding pair (z . 2) from being printed at the end of the third line. Note that the length abbreviation hides the circularity from view and therefore the printing of circularity markers disappears. 

 (LET (X
       (*PRINT-LENGTH*
        (F #))
       (Z . 2) ...)
   (SETQ X (SQRT Z))
   ...)

The next function prints a vector using “#(...)” notation. 

(defun pprint-vector (*standard-output* v)
  (pprint-logical-block (nil nil :prefix "#(" :suffix ")")
    (let ((end (length v)) (i 0))
      (when (plusp end)
        (loop (pprint-pop)
              (write (aref v i))
              (if (= (incf i) end) (return nil))
              (write-char #\Space)
              (pprint-newline :fill))))))

Evaluating the following with a line length of 15 produces the output shown. 

 (pprint-vector *standard-output* '#(12 34 567 8 9012 34 567 89 0 1 23))

 #(12 34 567 8 
   9012 34 567 
   89 0 1 23)

As examples of the convenience of specifying pretty printing with format strings, consider that the functions simple-pprint-defun and pprint-let used as examples above can be compactly defined as follows. (The function pprint-vector cannot be defined using format because the data structure it traverses is not a list.) 

(defun simple-pprint-defun (*standard-output* list)
  (format T "~:<~W ~@_~:I~W ~:_~W~1I ~_~W~:>" list))

(defun pprint-let (*standard-output* list)
  (format T "~:<~W~^~:<~@{~:<~@{~W~^~_~}~:>~^~:_~}~:>~1I~@{~^~_~W~}~:>" list))

In the following example, the first form restores *print-pprint-dispatch* to the equivalent of its initial value. The next two forms then set up a special way to pretty print ratios. Note that the more specific type specifier has to be associated with a higher priority. 

 (setq *print-pprint-dispatch* (copy-pprint-dispatch nil))

 (set-pprint-dispatch 'ratio
   #'(lambda (s obj)
       (format s "#.(/ ~W ~W)" 
                 (numerator obj) (denominator obj))))

 (set-pprint-dispatch '(and ratio (satisfies minusp))
   #'(lambda (s obj)
       (format s "#.(- (/ ~W ~W))" 
               (- (numerator obj)) (denominator obj)))
   5)

 (pprint '(1/3 -2/3))
 (#.(/ 1 3) #.(- (/ 2 3)))

The following two forms illustrate the definition of pretty printing functions for types of code. The first form illustrates how to specify the traditional method for printing quoted objects using single-quote. Note the care taken to ensure that data lists that happen to begin with quote will be printed readably. The second form specifies that lists beginning with the symbol my-let should print the same way that lists beginning with let print when the initial pprint dispatch table is in effect. 

 (set-pprint-dispatch '(cons (member quote)) () 
   #'(lambda (s list)
       (if (and (consp (cdr list)) (null (cddr list)))
          (funcall (formatter "'~W") s (cadr list))
          (pprint-fill s list))))

 (set-pprint-dispatch '(cons (member my-let)) 
                      (pprint-dispatch '(let) nil))

The next example specifies a default method for printing lists that do not correspond to function calls. Note that the functions pprint-linear, pprint-fill, and pprint-tabular are all defined with optional colon-p and at-sign-p arguments so that they can be used as pprint dispatch functions as well as ~/.../ functions. 

 (set-pprint-dispatch '(cons (not (and symbol (satisfies fboundp))))
                      #'pprint-fill -5)

 ;; Assume a line length of 9
 (pprint '(0 b c d e f g h i j k))
 (0 b c d
  e f g h
  i j k)

This final example shows how to define a pretty printing function for a user defined data structure. 

 (defstruct family mom kids)

 (set-pprint-dispatch 'family
   #'(lambda (s f)
       (funcall (formatter "~@<#<~;~W and ~2I~_~/pprint-fill/~;>~:>")
               s (family-mom f) (family-kids f))))

The pretty printing function for the structure family specifies how to adjust the layout of the output so that it can fit aesthetically into a variety of line widths. In addition, it obeys the printer control variables *print-level*, *print-length*, *print-lines*, *print-circle* and *print-escape*, and can tolerate several different kinds of malformity in the data structure. The output below shows what is printed out with a right margin of 25, *print-pretty* being true, *print-escape* being false, and a malformed kids list. 

 (write (list 'principal-family
              (make-family :mom "Lucy"
                           :kids '("Mark" "Bob" . "Dan")))
        :right-margin 25 :pretty T :escape nil :miser-width nil)
 (PRINCIPAL-FAMILY
  #<Lucy and
      Mark Bob . Dan>)

Note that a pretty printing function for a structure is different from the structure’s print-object method. While print-object methods are permanently associated with a structure, pretty printing functions are stored in pprint dispatch tables and can be rapidly changed to reflect different printing needs. If there is no pretty printing function for a structure in the current pprint dispatch table, its print-object method is used instead.

Next: , Previous: , Up: The Lisp Pretty Printer  

gcl-2.6.14/info/gcl/Examples-of-unconditional-execution.html0000644000175000017500000000466714360276512022423 0ustar cammcamm Examples of unconditional execution (ANSI and GNU Common Lisp Document)

Previous: , Up: Unconditional Execution Clauses  

6.1.5.1 Examples of unconditional execution

;; Print numbers and their squares.
;; The DO construct applies to multiple forms.
 (loop for i from 1 to 3
       do (print i)
          (print (* i i)))
 |>  1 
 |>  1 
 |>  2 
 |>  4 
 |>  3 
 |>  9 
⇒  NIL
gcl-2.6.14/info/gcl/directory.html0000644000175000017500000001040714360276512015367 0ustar cammcamm directory (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.1 directory [Function]

directory pathspec &key ⇒ pathnames

Arguments and Values::

pathspec—a pathname designator, which may contain wild components.

pathnames—a list of

physical pathnames.

Description::

Determines which, if any, files that are present in the file system have names matching pathspec, and returns a

fresh

list of pathnames corresponding to the truenames of those files.

An implementation may be extended to accept implementation-defined keyword arguments to directory.

Affected By::

The host computer’s file system.

Exceptional Situations::

If the attempt to obtain a directory listing is not successful, an error of type file-error is signaled.

See Also::

pathname,

logical-pathname,

ensure-directories-exist , File System Concepts, File Operations on Open and Closed Streams,

Pathnames as Filenames

Notes::

If the pathspec is not wild, the resulting list will contain either zero or one elements.

Common Lisp specifies “&key” in the argument list to directory even though no standardized keyword arguments to directory are defined. “:allow-other-keys t” may be used in conforming programs in order to quietly ignore any additional keywords which are passed by the program but not supported by the implementation.

gcl-2.6.14/info/gcl/mask_002dfield.html0000644000175000017500000000767714360276512016066 0ustar cammcamm mask-field (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Numbers Dictionary  

12.2.71 mask-field [Accessor]

mask-field bytespec integer ⇒ masked-integer

(setf ( mask-field bytespec place) new-masked-integer)

Arguments and Values::

bytespec—a byte specifier.

integer—an integer.

masked-integer, new-masked-integer—a non-negative integer.

Description::

mask-field performs a “mask” operation on integer. It returns an integer that has the same bits as integer in the byte specified by bytespec, but that has zero-bits everywhere else.

setf may be used with mask-field to modify a byte within the integer that is stored in a given place. The effect is to perform a deposit-field operation and then store the result back into the place.

Examples::

 (mask-field (byte 1 5) -1) ⇒  32
 (setq a 15) ⇒  15
 (mask-field (byte 2 0) a) ⇒  3
 a ⇒  15
 (setf (mask-field (byte 2 0) a) 1) ⇒  1
 a ⇒  13

See Also::

byte , ldb

Notes::

 (ldb bs (mask-field bs n)) ≡ (ldb bs n)
 (logbitp j (mask-field (byte s p) n))
   ≡ (and (>= j p) (< j s) (logbitp j n))
 (mask-field bs n) ≡ (logand n (dpb -1 bs 0))
gcl-2.6.14/info/gcl/Environment-Inquiry.html0000644000175000017500000000523514360276512017330 0ustar cammcamm Environment Inquiry (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: The External Environment  

25.1.3 Environment Inquiry

Environment inquiry defined names provide information about the hardware and software configuration on which a Common Lisp program is being executed.

Figure 25–3 shows defined names relating to environment inquiry. 

  *features*                   machine-instance  short-site-name   
  lisp-implementation-type     machine-type      software-type     
  lisp-implementation-version  machine-version   software-version  
  long-site-name               room                                

    Figure 25–3: Defined names relating to environment inquiry.
gcl-2.6.14/info/gcl/update_002dinstance_002dfor_002dredefined_002dclass.html0000644000175000017500000002173114360276512024523 0ustar cammcamm update-instance-for-redefined-class (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects Dictionary  

7.7.7 update-instance-for-redefined-class [Standard Generic Function]

Syntax::

update-instance-for-redefined-class instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys
⇒ {result}*

Method Signatures::

update-instance-for-redefined-class (instance standard-object) added-slots discarded-slots property-list &rest initargs

Arguments and Values::

instance—an object.

added-slots—a list.

discarded-slots—a list.

property-list—a list.

initargs—an initialization argument list.

result—an object.

Description::

The generic function update-instance-for-redefined-class is not intended to be called by programmers. Programmers may write methods for it. The generic function update-instance-for-redefined-class is called by the mechanism activated by make-instances-obsolete.

The system-supplied primary method on update-instance-for-redefined-class checks the validity of initargs and signals an error if an initarg is supplied that is not declared as valid. This method then initializes slots with values according to the initargs, and initializes the newly added-slots with values according to their :initform forms. It does this by calling the generic function shared-initialize with the following arguments: the instance, a list of names of the newly added-slots to instance, and the initargs it received. Newly added-slots are those local slots for which no slot of the same name exists in the old version of the class.

When make-instances-obsolete is invoked or when a class has been redefined and an instance is being updated, a property-list is created that captures the slot names and values of all the discarded-slots with values in the original instance. The structure of the instance is transformed so that it conforms to the current class definition. The arguments to update-instance-for-redefined-class are this transformed instance, a list of added-slots to the instance, a list discarded-slots from the instance, and the property-list containing the slot names and values for slots that were discarded and had values. Included in this list of discarded slots are slots that were local in the old class and are shared in the new class.

The value returned by update-instance-for-redefined-class is ignored.

Examples::


 (defclass position () ())

 (defclass x-y-position (position)
     ((x :initform 0 :accessor position-x)
      (y :initform 0 :accessor position-y)))

;;; It turns out polar coordinates are used more than Cartesian 
;;; coordinates, so the representation is altered and some new
;;; accessor methods are added.

 (defmethod update-instance-for-redefined-class :before
    ((pos x-y-position) added deleted plist &key)
   ;; Transform the x-y coordinates to polar coordinates
   ;; and store into the new slots.
   (let ((x (getf plist 'x))
         (y (getf plist 'y)))
     (setf (position-rho pos) (sqrt (+ (* x x) (* y y)))
           (position-theta pos) (atan y x))))

 (defclass x-y-position (position)
     ((rho :initform 0 :accessor position-rho)
      (theta :initform 0 :accessor position-theta)))

;;; All instances of the old x-y-position class will be updated
;;; automatically.

;;; The new representation is given the look and feel of the old one.

 (defmethod position-x ((pos x-y-position))  
    (with-slots (rho theta) pos (* rho (cos theta))))

 (defmethod (setf position-x) (new-x (pos x-y-position))
    (with-slots (rho theta) pos
      (let ((y (position-y pos)))
        (setq rho (sqrt (+ (* new-x new-x) (* y y)))
              theta (atan y new-x))
        new-x)))

 (defmethod position-y ((pos x-y-position))
    (with-slots (rho theta) pos (* rho (sin theta))))

 (defmethod (setf position-y) (new-y (pos x-y-position))
    (with-slots (rho theta) pos
      (let ((x (position-x pos)))
        (setq rho (sqrt (+ (* x x) (* new-y new-y)))
              theta (atan new-y x))
        new-y)))

Exceptional Situations::

The system-supplied primary method on update-instance-for-redefined-class signals an error if an initarg is supplied that is not declared as valid.

See Also::

make-instances-obsolete , Shared-Initialize , Redefining Classes, Rules for Initialization Arguments, Declaring the Validity of Initialization Arguments

Notes::

Initargs are declared as valid by using the :initarg option to defclass, or by defining methods for update-instance-for-redefined-class or shared-initialize. The keyword name of each keyword parameter specifier in the lambda list of any method defined on update-instance-for-redefined-class or shared-initialize is declared as a valid initarg name for all classes for which that method is applicable.

Next: , Previous: , Up: Objects Dictionary  

gcl-2.6.14/info/gcl/probe_002dfile.html0000644000175000017500000000760214360276512016062 0ustar cammcamm probe-file (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Files Dictionary  

20.2.2 probe-file [Function]

probe-file pathspec ⇒ truename

Arguments and Values::

pathspec—a pathname designator.

truename—a physical pathname or nil.

Description::

probe-file tests whether a file exists.

probe-file returns false if there is no file named pathspec, and otherwise returns the truename of pathspec.

If the pathspec designator is an open stream, then probe-file produces the truename of its associated file.

If pathspec is a stream, whether open or closed, it is coerced to a pathname as if by the function pathname.

Affected By::

The host computer’s file system.

Exceptional Situations::

An error of type file-error is signaled if pathspec is wild.

An error of type file-error is signaled if the file system cannot perform the requested operation.

See Also::

truename , open , ensure-directories-exist , pathname,

logical-pathname,

File System Concepts, File Operations on Open and Closed Streams,

Pathnames as Filenames

gcl-2.6.14/info/gcl/Object-Creation-and-Initialization.html0000644000175000017500000001724114360276512022063 0ustar cammcamm Object Creation and Initialization (ANSI and GNU Common Lisp Document)

Next: , Previous: , Up: Objects  

7.1 Object Creation and Initialization

The generic function make-instance creates and returns a new instance of a class. The first argument is a class or the name of a class, and the remaining arguments form an initialization argument list .

The initialization of a new instance consists of several distinct steps, including the following: combining the explicitly supplied initialization arguments with default values for the unsupplied initialization arguments, checking the validity of the initialization arguments, allocating storage for the instance, filling slots with values, and executing user-supplied methods that perform additional initialization. Each step of make-instance is implemented by a generic function to provide a mechanism for customizing that step. In addition, make-instance is itself a generic function and thus also can be customized.

The object system specifies system-supplied primary methods for each step and thus specifies a well-defined standard behavior for the entire initialization process. The standard behavior provides four simple mechanisms for controlling initialization:

*

Declaring a symbol to be an initialization argument for a slot. An initialization argument is declared by using the :initarg slot option to defclass. This provides a mechanism for supplying a value for a slot in a call to make-instance.

*

Supplying a default value form for an initialization argument. Default value forms for initialization arguments are defined by using the :default-initargs class option to defclass. If an initialization argument is not explicitly provided as an argument to make-instance, the default value form is evaluated in the lexical environment of the defclass form that defined it, and the resulting value is used as the value of the initialization argument.

*

Supplying a default initial value form for a slot. A default initial value form for a slot is defined by using the :initform slot option to defclass. If no initialization argument associated with that slot is given as an argument to make-instance or is defaulted by :default-initargs, this default initial value form is evaluated in the lexical environment of the defclass form that defined it, and the resulting value is stored in the slot. The :initform form for a local slot may be used when creating an instance, when updating an instance to conform to a redefined class, or when updating an instance to conform to the definition of a different class. The :initform form for a shared slot may be used when defining or re-defining the class.

*

Defining methods for initialize-instance and shared-initialize. The slot-filling behavior described above is implemented by a system-supplied primary method for initialize-instance which invokes shared-initialize. The generic function shared-initialize implements the parts of initialization shared by these four situations: when making an instance, when re-initializing an instance, when updating an instance to conform to a redefined class, and when updating an instance to conform to the definition of a different class. The system-supplied primary method for shared-initialize directly implements the slot-filling behavior described above, and initialize-instance simply invokes shared-initialize.

• Initialization Arguments  
• Declaring the Validity of Initialization Arguments  
• Defaulting of Initialization Arguments  
• Rules for Initialization Arguments  
• Shared-Initialize  
• Initialize-Instance  
• Definitions of Make-Instance and Initialize-Instance  

Next: , Previous: , Up: Objects  

gcl-2.6.14/info/chap-12.texi0000644000175000017500000051510614360276512013764 0ustar cammcamm @node Numbers (Numbers), Characters, Packages, Top @chapter Numbers @menu * Number Concepts:: * Numbers Dictionary:: @end menu @node Number Concepts, Numbers Dictionary, Numbers (Numbers), Numbers (Numbers) @section Number Concepts @c including concept-numbers @menu * Numeric Operations:: * Implementation-Dependent Numeric Constants:: * Rational Computations:: * Floating-point Computations:: * Complex Computations:: * Interval Designators:: * Random-State Operations:: @end menu @node Numeric Operations, Implementation-Dependent Numeric Constants, Number Concepts, Number Concepts @subsection Numeric Operations @r{Common Lisp} provides a large variety of operations related to @i{numbers}. This section provides an overview of those operations by grouping them into categories that emphasize some of the relationships among them. Figure 12--1 shows @i{operators} relating to arithmetic operations. @format @group @noindent @w{ * 1+ gcd } @w{ + 1- incf } @w{ - conjugate lcm } @w{ / decf } @noindent @w{ Figure 12--1: Operators relating to Arithmetic.} @end group @end format Figure 12--2 shows @i{defined names} relating to exponential, logarithmic, and trigonometric operations. @format @group @noindent @w{ abs cos signum } @w{ acos cosh sin } @w{ acosh exp sinh } @w{ asin expt sqrt } @w{ asinh isqrt tan } @w{ atan log tanh } @w{ atanh phase } @w{ cis pi } @noindent @w{ Figure 12--2: Defined names relating to Exponentials, Logarithms, and Trigonometry.} @end group @end format Figure 12--3 shows @i{operators} relating to numeric comparison and predication. @format @group @noindent @w{ /= >= oddp } @w{ < evenp plusp } @w{ <= max zerop } @w{ = min } @w{ > minusp } @noindent @w{ Figure 12--3: Operators for numeric comparison and predication.} @end group @end format Figure 12--4 shows @i{defined names} relating to numeric type manipulation and coercion. @format @group @noindent @w{ ceiling float-radix rational } @w{ complex float-sign rationalize } @w{ decode-float floor realpart } @w{ denominator fround rem } @w{ fceiling ftruncate round } @w{ ffloor imagpart scale-float } @w{ float integer-decode-float truncate } @w{ float-digits mod } @w{ float-precision numerator } @noindent @w{ Figure 12--4: Defined names relating to numeric type manipulation and coercion.} @end group @end format @menu * Associativity and Commutativity in Numeric Operations:: * Examples of Associativity and Commutativity in Numeric Operations:: * Contagion in Numeric Operations:: * Viewing Integers as Bits and Bytes:: * Logical Operations on Integers:: * Byte Operations on Integers:: @end menu @node Associativity and Commutativity in Numeric Operations, Examples of Associativity and Commutativity in Numeric Operations, Numeric Operations, Numeric Operations @subsubsection Associativity and Commutativity in Numeric Operations For functions that are mathematically associative (and possibly commutative), a @i{conforming implementation} may process the @i{arguments} in any manner consistent with associative (and possibly commutative) rearrangement. This does not affect the order in which the @i{argument} @i{forms} are @i{evaluated}; for a discussion of evaluation order, see @ref{Function Forms}. What is unspecified is only the order in which the @i{parameter} @i{values} are processed. This implies that @i{implementations} may differ in which automatic @i{coercions} are applied; see @ref{Contagion in Numeric Operations}. A @i{conforming program} can control the order of processing explicitly by separating the operations into separate (possibly nested) @i{function forms}, or by writing explicit calls to @i{functions} that perform coercions. @node Examples of Associativity and Commutativity in Numeric Operations, Contagion in Numeric Operations, Associativity and Commutativity in Numeric Operations, Numeric Operations @subsubsection Examples of Associativity and Commutativity in Numeric Operations Consider the following expression, in which we assume that @t{1.0} and @t{1.0e-15} both denote @i{single floats}: @example (+ 1/3 2/3 1.0d0 1.0 1.0e-15) @end example One @i{conforming implementation} might process the @i{arguments} from left to right, first adding @t{1/3} and @t{2/3} to get @t{1}, then converting that to a @i{double float} for combination with @t{1.0d0}, then successively converting and adding @t{1.0} and @t{1.0e-15}. Another @i{conforming implementation} might process the @i{arguments} from right to left, first performing a @i{single float} addition of @t{1.0} and @t{1.0e-15} (perhaps losing accuracy in the process), then converting the sum to a @i{double float} and adding @t{1.0d0}, then converting @t{2/3} to a @i{double float} and adding it, and then converting @t{1/3} and adding that. A third @i{conforming implementation} might first scan all the @i{arguments}, process all the @i{rationals} first to keep that part of the computation exact, then find an @i{argument} of the largest floating-point format among all the @i{arguments} and add that, and then add in all other @i{arguments}, converting each in turn (all in a perhaps misguided attempt to make the computation as accurate as possible). In any case, all three strategies are legitimate. A @i{conforming program} could control the order by writing, for example, @example (+ (+ 1/3 2/3) (+ 1.0d0 1.0e-15) 1.0) @end example @node Contagion in Numeric Operations, Viewing Integers as Bits and Bytes, Examples of Associativity and Commutativity in Numeric Operations, Numeric Operations @subsubsection Contagion in Numeric Operations For information about the contagion rules for implicit coercions of @i{arguments} in numeric operations, see @ref{Rule of Float Precision Contagion}, @ref{Rule of Float and Rational Contagion}, and @ref{Rule of Complex Contagion}. @node Viewing Integers as Bits and Bytes, Logical Operations on Integers, Contagion in Numeric Operations, Numeric Operations @subsubsection Viewing Integers as Bits and Bytes @node Logical Operations on Integers, Byte Operations on Integers, Viewing Integers as Bits and Bytes, Numeric Operations @subsubsection Logical Operations on Integers Logical operations require @i{integers} as arguments; an error of @i{type} @b{type-error} should be signaled if an argument is supplied that is not an @i{integer}. @i{Integer} arguments to logical operations are treated as if they were represented in two's-complement notation. Figure 12--5 shows @i{defined names} relating to logical operations on numbers. @format @group @noindent @w{ ash boole-ior logbitp } @w{ boole boole-nand logcount } @w{ boole-1 boole-nor logeqv } @w{ boole-2 boole-orc1 logior } @w{ boole-and boole-orc2 lognand } @w{ boole-andc1 boole-set lognor } @w{ boole-andc2 boole-xor lognot } @w{ boole-c1 integer-length logorc1 } @w{ boole-c2 logand logorc2 } @w{ boole-clr logandc1 logtest } @w{ boole-eqv logandc2 logxor } @noindent @w{ Figure 12--5: Defined names relating to logical operations on numbers.} @end group @end format @node Byte Operations on Integers, , Logical Operations on Integers, Numeric Operations @subsubsection Byte Operations on Integers The byte-manipulation @i{functions} use @i{objects} called @i{byte specifiers} to designate the size and position of a specific @i{byte} within an @i{integer}. The representation of a @i{byte specifier} is @i{implementation-dependent}; it might or might not be a @i{number}. The @i{function} @b{byte} will construct a @i{byte specifier}, which various other byte-manipulation @i{functions} will accept. Figure 12--6 shows @i{defined names} relating to manipulating @i{bytes} of @i{numbers}. @format @group @noindent @w{ byte deposit-field ldb-test } @w{ byte-position dpb mask-field } @w{ byte-size ldb } @noindent @w{ Figure 12--6: Defined names relating to byte manipulation.} @end group @end format @node Implementation-Dependent Numeric Constants, Rational Computations, Numeric Operations, Number Concepts @subsection Implementation-Dependent Numeric Constants Figure 12--7 shows @i{defined names} relating to @i{implementation-dependent} details about @i{numbers}. @format @group @noindent @w{ double-float-epsilon most-negative-fixnum } @w{ double-float-negative-epsilon most-negative-long-float } @w{ least-negative-double-float most-negative-short-float } @w{ least-negative-long-float most-negative-single-float } @w{ least-negative-short-float most-positive-double-float } @w{ least-negative-single-float most-positive-fixnum } @w{ least-positive-double-float most-positive-long-float } @w{ least-positive-long-float most-positive-short-float } @w{ least-positive-short-float most-positive-single-float } @w{ least-positive-single-float short-float-epsilon } @w{ long-float-epsilon short-float-negative-epsilon } @w{ long-float-negative-epsilon single-float-epsilon } @w{ most-negative-double-float single-float-negative-epsilon } @noindent @w{ Figure 12--7: Defined names relating to implementation-dependent details about numbers.} @end group @end format @node Rational Computations, Floating-point Computations, Implementation-Dependent Numeric Constants, Number Concepts @subsection Rational Computations The rules in this section apply to @i{rational} computations. @menu * Rule of Unbounded Rational Precision:: * Rule of Canonical Representation for Rationals:: * Rule of Float Substitutability:: @end menu @node Rule of Unbounded Rational Precision, Rule of Canonical Representation for Rationals, Rational Computations, Rational Computations @subsubsection Rule of Unbounded Rational Precision Rational computations cannot overflow in the usual sense (though there may not be enough storage to represent a result), since @i{integers} and @i{ratios} may in principle be of any magnitude. @node Rule of Canonical Representation for Rationals, Rule of Float Substitutability, Rule of Unbounded Rational Precision, Rational Computations @subsubsection Rule of Canonical Representation for Rationals If any computation produces a result that is a mathematical ratio of two integers such that the denominator evenly divides the numerator, then the result is converted to the equivalent @i{integer}. If the denominator does not evenly divide the numerator, the canonical representation of a @i{rational} number is as the @i{ratio} that numerator and that denominator, where the greatest common divisor of the numerator and denominator is one, and where the denominator is positive and greater than one. When used as input (in the default syntax), the notation @t{-0} always denotes the @i{integer} @t{0}. A @i{conforming implementation} must not have a representation of ``minus zero'' for @i{integers} that is distinct from its representation of zero for @i{integers}. However, such a distinction is possible for @i{floats}; see the @i{type} @b{float}. @node Rule of Float Substitutability, , Rule of Canonical Representation for Rationals, Rational Computations @subsubsection Rule of Float Substitutability When the arguments to an irrational mathematical @i{function} [Reviewer Note by Barmar: There should be a table of these functions.] are all @i{rational} and the true mathematical result is also (mathematically) rational, then unless otherwise noted an implementation is free to return either an accurate @i{rational} result or a @i{single float} approximation. If the arguments are all @i{rational} but the result cannot be expressed as a @i{rational} number, then a @i{single float} approximation is always returned. If the arguments to a mathematical @i{function} are all of type @t{(or rational (complex rational))} and the true mathematical result is (mathematically) a complex number with rational real and imaginary parts, then unless otherwise noted an implementation is free to return either an accurate result of type @t{(or rational (complex rational))} or a @i{single float} (permissible only if the imaginary part of the true mathematical result is zero) or @t{(complex single-float)}. If the arguments are all of type @t{(or rational (complex rational))} but the result cannot be expressed as a @i{rational} or @i{complex rational}, then the returned value will be of @i{type} @b{single-float} (permissible only if the imaginary part of the true mathematical result is zero) or @t{(complex single-float)}. @format @group @noindent @w{ Function Sample Results } @w{ @b{abs} @t{(abs #c(3 4)) @result{} 5 @i{or} 5.0} } @w{ @b{acos} @t{(acos 1) @result{} 0 @i{or} 0.0} } @w{ @b{acosh} @t{(acosh 1) @result{} 0 @i{or} 0.0} } @w{ @b{asin} @t{(asin 0) @result{} 0 @i{or} 0.0} } @w{ @b{asinh} @t{(asinh 0) @result{} 0 @i{or} 0.0} } @w{ @b{atan} @t{(atan 0) @result{} 0 @i{or} 0.0} } @w{ @b{atanh} @t{(atanh 0) @result{} 0 @i{or} 0.0} } @w{ @b{cis} @t{(cis 0) @result{} #c(1 0) @i{or} #c(1.0 0.0)} } @w{ @b{cos} @t{(cos 0) @result{} 1 @i{or} 1.0} } @w{ @b{cosh} @t{(cosh 0) @result{} 1 @i{or} 1.0} } @w{ @b{exp} @t{(exp 0) @result{} 1 @i{or} 1.0} } @w{ @b{expt} @t{(expt 8 1/3) @result{} 2 @i{or} 2.0} } @w{ @b{log} @t{(log 1) @result{} 0 @i{or} 0.0} } @w{ @t{(log 8 2) @result{} 3 @i{or} 3.0} } @w{ @b{phase} @t{(phase 7) @result{} 0 @i{or} 0.0} } @w{ @b{signum} @t{(signum #c(3 4)) @result{} #c(3/5 4/5) @i{or} #c(0.6 0.8)} } @w{ @b{sin} @t{(sin 0) @result{} 0 @i{or} 0.0} } @w{ @b{sinh} @t{(sinh 0) @result{} 0 @i{or} 0.0} } @w{ @b{sqrt} @t{(sqrt 4) @result{} 2 @i{or} 2.0} } @w{ @t{(sqrt 9/16) @result{} 3/4 @i{or} 0.75} } @w{ @b{tan} @t{(tan 0) @result{} 0 @i{or} 0.0} } @w{ @b{tanh} @t{(tanh 0) @result{} 0 @i{or} 0.0} } @noindent @w{ Figure 12--8: Functions Affected by Rule of Float Substitutability} @end group @end format @node Floating-point Computations, Complex Computations, Rational Computations, Number Concepts @subsection Floating-point Computations The following rules apply to floating point computations. @menu * Rule of Float and Rational Contagion:: * Examples of Rule of Float and Rational Contagion:: * Rule of Float Approximation:: * Rule of Float Underflow and Overflow:: * Rule of Float Precision Contagion:: @end menu @node Rule of Float and Rational Contagion, Examples of Rule of Float and Rational Contagion, Floating-point Computations, Floating-point Computations @subsubsection Rule of Float and Rational Contagion When @i{rationals} and @i{floats} are combined by a numerical function, the @i{rational} is first converted to a @i{float} of the same format. For @i{functions} such as @b{+} that take more than two arguments, it is permitted that part of the operation be carried out exactly using @i{rationals} and the rest be done using floating-point arithmetic. When @i{rationals} and @i{floats} are compared by a numerical function, the @i{function} @b{rational} is effectively called to convert the @i{float} to a @i{rational} and then an exact comparison is performed. In the case of @i{complex} numbers, the real and imaginary parts are effectively handled individually. @node Examples of Rule of Float and Rational Contagion, Rule of Float Approximation, Rule of Float and Rational Contagion, Floating-point Computations @subsubsection Examples of Rule of Float and Rational Contagion @example ;;;; Combining rationals with floats. ;;; This example assumes an implementation in which ;;; (float-radix 0.5) is 2 (as in IEEE) or 16 (as in IBM/360), ;;; or else some other implementation in which 1/2 has an exact ;;; representation in floating point. (+ 1/2 0.5) @result{} 1.0 (- 1/2 0.5d0) @result{} 0.0d0 (+ 0.5 -0.5 1/2) @result{} 0.5 ;;;; Comparing rationals with floats. ;;; This example assumes an implementation in which the default float ;;; format is IEEE single-float, IEEE double-float, or some other format ;;; in which 5/7 is rounded upwards by FLOAT. (< 5/7 (float 5/7)) @result{} @i{true} (< 5/7 (rational (float 5/7))) @result{} @i{true} (< (float 5/7) (float 5/7)) @result{} @i{false} @end example @node Rule of Float Approximation, Rule of Float Underflow and Overflow, Examples of Rule of Float and Rational Contagion, Floating-point Computations @subsubsection Rule of Float Approximation Computations with @i{floats} are only approximate, although they are described as if the results were mathematically accurate. Two mathematically identical expressions may be computationally different because of errors inherent in the floating-point approximation process. The precision of a @i{float} is not necessarily correlated with the accuracy of that number. For instance, 3.142857142857142857 is a more precise approximation to \pi than 3.14159, but the latter is more accurate. The precision refers to the number of bits retained in the representation. When an operation combines a @i{short float} with a @i{long float}, the result will be a @i{long float}. @r{Common Lisp} functions assume that the accuracy of arguments to them does not exceed their precision. Therefore when two @i{small floats} are combined, the result is a @i{small float}. @r{Common Lisp} functions never convert automatically from a larger size to a smaller one. @node Rule of Float Underflow and Overflow, Rule of Float Precision Contagion, Rule of Float Approximation, Floating-point Computations @subsubsection Rule of Float Underflow and Overflow An error of @i{type} @b{floating-point-overflow} or @b{floating-point-underflow} should be signaled if a floating-point computation causes exponent overflow or underflow, respectively. @node Rule of Float Precision Contagion, , Rule of Float Underflow and Overflow, Floating-point Computations @subsubsection Rule of Float Precision Contagion The result of a numerical function is a @i{float} of the largest format among all the floating-point arguments to the @i{function}. @node Complex Computations, Interval Designators, Floating-point Computations, Number Concepts @subsection Complex Computations The following rules apply to @i{complex} computations: @menu * Rule of Complex Substitutability:: * Rule of Complex Contagion:: * Rule of Canonical Representation for Complex Rationals:: * Examples of Rule of Canonical Representation for Complex Rationals:: * Principal Values and Branch Cuts:: @end menu @node Rule of Complex Substitutability, Rule of Complex Contagion, Complex Computations, Complex Computations @subsubsection Rule of Complex Substitutability Except during the execution of irrational and transcendental @i{functions}, no numerical @i{function} ever @i{yields} a @i{complex} unless one or more of its @i{arguments} is a @i{complex}. @node Rule of Complex Contagion, Rule of Canonical Representation for Complex Rationals, Rule of Complex Substitutability, Complex Computations @subsubsection Rule of Complex Contagion When a @i{real} and a @i{complex} are both part of a computation, the @i{real} is first converted to a @i{complex} by providing an imaginary part of @t{0}. @node Rule of Canonical Representation for Complex Rationals, Examples of Rule of Canonical Representation for Complex Rationals, Rule of Complex Contagion, Complex Computations @subsubsection Rule of Canonical Representation for Complex Rationals If the result of any computation would be a @i{complex} number whose real part is of @i{type} @b{rational} and whose imaginary part is zero, the result is converted to the @i{rational} which is the real part. This rule does not apply to @i{complex} numbers whose parts are @i{floats}. For example, @t{#C(5 0)} and @t{5} are not @i{different} @i{objects} in @r{Common Lisp} (they are always the @i{same} under @b{eql}); @t{#C(5.0 0.0)} and @t{5.0} are always @i{different} @i{objects} in @r{Common Lisp} (they are never the @i{same} under @b{eql}, although they are the @i{same} under @b{equalp} and @b{=}). @node Examples of Rule of Canonical Representation for Complex Rationals, Principal Values and Branch Cuts, Rule of Canonical Representation for Complex Rationals, Complex Computations @subsubsection Examples of Rule of Canonical Representation for Complex Rationals @example #c(1.0 1.0) @result{} #C(1.0 1.0) #c(0.0 0.0) @result{} #C(0.0 0.0) #c(1.0 1) @result{} #C(1.0 1.0) #c(0.0 0) @result{} #C(0.0 0.0) #c(1 1) @result{} #C(1 1) #c(0 0) @result{} 0 (typep #c(1 1) '(complex (eql 1))) @result{} @i{true} (typep #c(0 0) '(complex (eql 0))) @result{} @i{false} @end example @node Principal Values and Branch Cuts, , Examples of Rule of Canonical Representation for Complex Rationals, Complex Computations @subsubsection Principal Values and Branch Cuts Many of the irrational and transcendental functions are multiply defined in the complex domain; for example, there are in general an infinite number of complex values for the logarithm function. In each such case, a @i{principal} @i{value} must be chosen for the function to return. In general, such values cannot be chosen so as to make the range continuous; lines in the domain called branch cuts must be defined, which in turn define the discontinuities in the range. @r{Common Lisp} defines the branch cuts, @i{principal} @i{values}, and boundary conditions for the complex functions following ``Principal Values and Branch Cuts in Complex APL.'' The branch cut rules that apply to each function are located with the description of that function. Figure 12--9 lists the identities that are obeyed throughout the applicable portion of the complex domain, even on the branch cuts: @format @group @noindent @w{ sin i z = i sinh z sinh i z = i sin z arctan i z = i arctanh z } @w{ cos i z = cosh z cosh i z = cos z arcsinh i z = i arcsin z } @w{ tan i z = i tanh z arcsin i z = i arcsinh z arctanh i z = i arctan z } @noindent @w{ Figure 12--9: Trigonometric Identities for Complex Domain } @end group @end format The quadrant numbers referred to in the discussions of branch cuts are as illustrated in Figure 12--10. @example Imaginary Axis | | II | I | | | ______________________________________ Real Axis | | | III | IV | | | | @end example @w{ Figure 12--9: Quadrant Numbering for Branch Cuts} @node Interval Designators, Random-State Operations, Complex Computations, Number Concepts @subsection Interval Designators The @i{compound type specifier} form of the numeric @i{type specifiers} in Figure 12--10 permit the user to specify an interval on the real number line which describe a @i{subtype} of the @i{type} which would be described by the corresponding @i{atomic type specifier}. A @i{subtype} of some @i{type} @i{T} is specified using an ordered pair of @i{objects} called @i{interval designators} for @i{type} @i{T}. The first of the two @i{interval designators} for @i{type} @i{T} can be any of the following: @table @asis @item a number @i{N} of @i{type} @i{T} This denotes a lower inclusive bound of @i{N}. That is, @i{elements} of the @i{subtype} of @i{T} will be greater than or equal to @i{N}. @item a @i{singleton} @i{list} whose @i{element} is a number @i{M} of @i{type} @i{T} This denotes a lower exclusive bound of @i{M}. That is, @i{elements} of the @i{subtype} of @i{T} will be greater than @i{M}. @item the symbol @b{*} This denotes the absence of a lower bound on the interval. @end table The second of the two @i{interval designators} for @i{type} @i{T} can be any of the following: @table @asis @item a number @i{N} of @i{type} @i{T} This denotes an upper inclusive bound of @i{N}. That is, @i{elements} of the @i{subtype} of @i{T} will be less than or equal to @i{N}. @item a @i{singleton} @i{list} whose @i{element} is a number @i{M} of @i{type} @i{T} This denotes an upper exclusive bound of @i{M}. That is, @i{elements} of the @i{subtype} of @i{T} will be less than @i{M}. @item the symbol @b{*} This denotes the absence of an upper bound on the interval. @end table @node Random-State Operations, , Interval Designators, Number Concepts @subsection Random-State Operations Figure 12--10 lists some @i{defined names} that are applicable to @i{random states}. @format @group @noindent @w{ *random-state* random } @w{ make-random-state random-state-p } @noindent @w{ Figure 12--10: Random-state defined names} @end group @end format @c end of including concept-numbers @node Numbers Dictionary, , Number Concepts, Numbers (Numbers) @section Numbers Dictionary @c including dict-numbers @menu * number:: * complex (System Class):: * real:: * float (System Class):: * short-float:: * rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: * mod (System Class):: * bit (System Class):: * fixnum:: * bignum:: * =:: * max:: * minusp:: * zerop:: * floor:: * sin:: * asin:: * pi:: * sinh:: * *:: * +:: * -:: * /:: * 1+:: * abs:: * evenp:: * exp:: * gcd:: * incf:: * lcm:: * log:: * mod (Function):: * signum:: * sqrt:: * random-state:: * make-random-state:: * random:: * random-state-p:: * *random-state*:: * numberp:: * cis:: * complex:: * complexp:: * conjugate:: * phase:: * realpart:: * upgraded-complex-part-type:: * realp:: * numerator:: * rational (Function):: * rationalp:: * ash:: * integer-length:: * integerp:: * parse-integer:: * boole:: * boole-1:: * logand:: * logbitp:: * logcount:: * logtest:: * byte:: * deposit-field:: * dpb:: * ldb:: * ldb-test:: * mask-field:: * most-positive-fixnum:: * decode-float:: * float:: * floatp:: * most-positive-short-float:: * short-float-epsilon:: * arithmetic-error:: * arithmetic-error-operands:: * division-by-zero:: * floating-point-invalid-operation:: * floating-point-inexact:: * floating-point-overflow:: * floating-point-underflow:: @end menu @node number, complex (System Class), Numbers Dictionary, Numbers Dictionary @subsection number [System Class] @subsubheading Class Precedence List:: @b{number}, @b{t} @subsubheading Description:: The @i{type} @b{number} contains @i{objects} which represent mathematical numbers. The @i{types} @b{real} and @b{complex} are @i{disjoint} @i{subtypes} of @b{number}. The @i{function} @b{=} tests for numerical equality. The @i{function} @b{eql}, when its arguments are both @i{numbers}, tests that they have both the same @i{type} and numerical value. Two @i{numbers} that are the @i{same} under @b{eql} or @b{=} are not necessarily the @i{same} under @b{eq}. @subsubheading Notes:: @r{Common Lisp} differs from mathematics on some naming issues. In mathematics, the set of real numbers is traditionally described as a subset of the complex numbers, but in @r{Common Lisp}, the @i{type} @b{real} and the @i{type} @b{complex} are disjoint. The @r{Common Lisp} type which includes all mathematical complex numbers is called @b{number}. The reasons for these differences include historical precedent, compatibility with most other popular computer languages, and various issues of time and space efficiency. @node complex (System Class), real, number, Numbers Dictionary @subsection complex [System Class] @subsubheading Class Precedence List:: @b{complex}, @b{number}, @b{t} @subsubheading Description:: The @i{type} @b{complex} includes all mathematical complex numbers other than those included in the @i{type} @b{rational}. @i{Complexes} are expressed in Cartesian form with a real part and an imaginary part, each of which is a @i{real}. The real part and imaginary part are either both @i{rational} or both of the same @i{float} @i{type}. The imaginary part can be a @i{float} zero, but can never be a @i{rational} zero, for such a number is always represented by @r{Common Lisp} as a @i{rational} rather than a @i{complex}. @subsubheading Compound Type Specifier Kind:: Specializing. @subsubheading Compound Type Specifier Syntax:: (@code{complex}@{@i{@t{[}typespec | @b{*}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{typespec}---a @i{type specifier} that denotes a @i{subtype} of @i{type} @b{real}. @subsubheading Compound Type Specifier Description:: [Editorial Note by KMP: If you ask me, this definition is a complete mess. Looking at issue ARRAY-TYPE-ELEMENT-TYPE-SEMANTICS:UNIFY-UPGRADING does not help me figure it out, either. Anyone got any suggestions?] Every element of this @i{type} is a @i{complex} whose real part and imaginary part are each of type @t{(upgraded-complex-part-type @i{typespec})}. This @i{type} encompasses those @i{complexes} that can result by giving numbers of @i{type} @i{typespec} to @b{complex}. @t{(complex @i{type-specifier})} refers to all @i{complexes} that can result from giving @i{numbers} of @i{type} @i{type-specifier} to the @i{function} @b{complex}, plus all other @i{complexes} of the same specialized representation. @subsubheading See Also:: @ref{Rule of Canonical Representation for Complex Rationals}, @ref{Constructing Numbers from Tokens}, @ref{Printing Complexes} @subsubheading Notes:: The input syntax for a @i{complex} with real part r and imaginary part i is @t{#C(r i)}. For further details, see @ref{Standard Macro Characters}. For every @i{float}, n, there is a @i{complex} which represents the same mathematical number and which can be obtained by @t{(COERCE n 'COMPLEX)}. @node real, float (System Class), complex (System Class), Numbers Dictionary @subsection real [System Class] @subsubheading Class Precedence List:: @b{real}, @b{number}, @b{t} @subsubheading Description:: The @i{type} @b{real} includes all @i{numbers} that represent mathematical real numbers, though there are mathematical real numbers (@i{e.g.}, irrational numbers) that do not have an exact representation in @r{Common Lisp}. Only @i{reals} can be ordered using the @b{<}, @b{>}, @b{<=}, and @b{>=} functions. The @i{types} @b{rational} and @b{float} are @i{disjoint} @i{subtypes} of @i{type} @b{real}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{real}@{@i{@t{[}lower-limit @r{[}upper-limit@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{lower-limit}, @i{upper-limit}---@i{interval designators} for @i{type} @b{real}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the @i{reals} on the interval described by @i{lower-limit} and @i{upper-limit}. @node float (System Class), short-float, real, Numbers Dictionary @subsection float [System Class] @subsubheading Class Precedence List:: @b{float}, @b{real}, @b{number}, @b{t} @subsubheading Description:: A @i{float} is a mathematical rational (but @i{not} a @r{Common Lisp} @i{rational}) of the form s\cdot f\cdot b^@r{e-p}, where s is +1 or -1, the @i{sign}; b is an @i{integer} greater than~1, the @i{base} or @i{radix} of the representation; p is a positive @i{integer}, the @i{precision} (in base-b digits) of the @i{float}; f is a positive @i{integer} between b^@r{p-1} and b^p-1 (inclusive), the significand; and e is an @i{integer}, the exponent. The value of p and the range of~e depends on the implementation and on the type of @i{float} within that implementation. In addition, there is a floating-point zero; depending on the implementation, there can also be a ``minus zero''. If there is no minus zero, then 0.0 and~-0.0 are both interpreted as simply a floating-point zero. @t{(= 0.0 -0.0)} is always true. If there is a minus zero, @t{(eql -0.0 0.0)} is @i{false}, otherwise it is @i{true}. [Reviewer Note by Barmar: What about IEEE NaNs and infinities?] [Reviewer Note by RWK: In the following, what is the ``ordering''? precision? range? Can there be additional subtypes of float or does ``others'' in the list of four?] The @i{types} @b{short-float}, @b{single-float}, @b{double-float}, and @b{long-float} are @i{subtypes} of @i{type} @b{float}. Any two of them must be either @i{disjoint} @i{types} or the @i{same} @i{type}; if the @i{same} @i{type}, then any other @i{types} between them in the above ordering must also be the @i{same} @i{type}. For example, if the @i{type} @b{single-float} and the @i{type} @b{long-float} are the @i{same} @i{type}, then the @i{type} @b{double-float} must be the @i{same} @i{type} also. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{float}@{@i{@t{[}lower-limit @r{[}upper-limit@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{lower-limit}, @i{upper-limit}---@i{interval designators} for @i{type} @b{float}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the @i{floats} on the interval described by @i{lower-limit} and @i{upper-limit}. @subsubheading See Also:: @i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Floats} @subsubheading Notes:: Note that all mathematical integers are representable not only as @r{Common Lisp} @i{reals}, but also as @i{complex floats}. For example, possible representations of the mathematical number 1 include the @i{integer} @t{1}, the @i{float} @t{1.0}, or the @i{complex} @t{#C(1.0 0.0)}. @node short-float, rational (System Class), float (System Class), Numbers Dictionary @subsection short-float, single-float, double-float, long-float [Type] @subsubheading Supertypes:: @b{short-float}: @b{short-float}, @b{float}, @b{real}, @b{number}, @b{t} @b{single-float}: @b{single-float}, @b{float}, @b{real}, @b{number}, @b{t} @b{double-float}: @b{double-float}, @b{float}, @b{real}, @b{number}, @b{t} @b{long-float}: @b{long-float}, @b{float}, @b{real}, @b{number}, @b{t} @subsubheading Description:: For the four defined @i{subtypes} of @i{type} @b{float}, it is true that intermediate between the @i{type} @b{short-float} and the @i{type} @b{long-float} are the @i{type} @b{single-float} and the @i{type} @b{double-float}. The precise definition of these categories is @i{implementation-defined}. The precision (measured in ``bits'', computed as p\log_2b) and the exponent size (also measured in ``bits,'' computed as \log_2(n+1), where n is the maximum exponent value) is recommended to be at least as great as the values in Figure 12--11. Each of the defined @i{subtypes} of @i{type} @b{float} might or might not have a minus zero. @format @group @noindent @w{ @b{Format} @b{Minimum Precision} @b{Minimum Exponent Size} } @w{ __________________________________________________} @w{ Short 13 bits 5 bits } @w{ Single 24 bits 8 bits } @w{ Double 50 bits 8 bits } @w{ Long 50 bits 8 bits } @noindent @w{ Figure 12--11: Recommended Minimum Floating-Point Precision and Exponent Size} @end group @end format There can be fewer than four internal representations for @i{floats}. If there are fewer distinct representations, the following rules apply: @table @asis @item -- If there is only one, it is the @i{type} @b{single-float}. In this representation, an @i{object} is simultaneously of @i{types} @b{single-float}, @b{double-float}, @b{short-float}, and @b{long-float}. @item -- Two internal representations can be arranged in either of the following ways: @table @asis @item @t{*} Two @i{types} are provided: @b{single-float} and @b{short-float}. An @i{object} is simultaneously of @i{types} @b{single-float}, @b{double-float}, and @b{long-float}. @item @t{*} Two @i{types} are provided: @b{single-float} and @b{double-float}. An @i{object} is simultaneously of @i{types} @b{single-float} and @b{short-float}, or @b{double-float} and @b{long-float}. @end table @item -- Three internal representations can be arranged in either of the following ways: @table @asis @item @t{*} Three @i{types} are provided: @b{short-float}, @b{single-float}, and @b{double-float}. An @i{object} can simultaneously be of @i{type} @b{double-float} and @b{long-float}. @item @t{*} Three @i{types} are provided: @b{single-float}, @b{double-float}, and @b{long-float}. An @i{object} can simultaneously be of @i{types} @b{single-float} and @b{short-float}. @end table @end table @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{short-float}@{@i{@t{[}short-lower-limit @r{[}short-upper-limit@r{]}@t{]}}@}) (@code{single-float}@{@i{@t{[}single-lower-limit @r{[}single-upper-limit@r{]}@t{]}}@}) (@code{double-float}@{@i{@t{[}double-lower-limit @r{[}double-upper-limit@r{]}@t{]}}@}) (@code{long-float}@{@i{@t{[}long-lower-limit @r{[}long-upper-limit@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{short-lower-limit}, @i{short-upper-limit}---@i{interval designators} for @i{type} @b{short-float}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @i{single-lower-limit}, @i{single-upper-limit}---@i{interval designators} for @i{type} @b{single-float}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @i{double-lower-limit}, @i{double-upper-limit}---@i{interval designators} for @i{type} @b{double-float}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @i{long-lower-limit}, @i{long-upper-limit}---@i{interval designators} for @i{type} @b{long-float}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: Each of these denotes the set of @i{floats} of the indicated @i{type} that are on the interval specified by the @i{interval designators}. @node rational (System Class), ratio, short-float, Numbers Dictionary @subsection rational [System Class] @subsubheading Class Precedence List:: @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: The canonical representation of a @i{rational} is as an @i{integer} if its value is integral, and otherwise as a @i{ratio}. The @i{types} @b{integer} and @b{ratio} are @i{disjoint} @i{subtypes} of @i{type} @b{rational}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{rational}@{@i{@t{[}lower-limit @r{[}upper-limit@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{lower-limit}, @i{upper-limit}---@i{interval designators} for @i{type} @b{rational}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the @i{rationals} on the interval described by @i{lower-limit} and @i{upper-limit}. @node ratio, integer, rational (System Class), Numbers Dictionary @subsection ratio [System Class] @subsubheading Class Precedence List:: @b{ratio}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: A @i{ratio} is a @i{number} representing the mathematical ratio of two non-zero integers, the numerator and denominator, whose greatest common divisor is one, and of which the denominator is positive and greater than one. @subsubheading See Also:: @i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Ratios} @node integer, signed-byte, ratio, Numbers Dictionary @subsection integer [System Class] @subsubheading Class Precedence List:: @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: An @i{integer} is a mathematical integer. There is no limit on the magnitude of an @i{integer}. The @i{types} @b{fixnum} and @b{bignum} form an @i{exhaustive partition} of @i{type} @b{integer}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{integer}@{@i{@t{[}lower-limit @r{[}upper-limit@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{lower-limit}, @i{upper-limit}---@i{interval designators} for @i{type} @b{integer}. The defaults for each of @i{lower-limit} and @i{upper-limit} is the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the @i{integers} on the interval described by @i{lower-limit} and @i{upper-limit}. @subsubheading See Also:: @i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Integers} @subsubheading Notes:: The @i{type} @t{(integer @i{lower} @i{upper})}, where @i{lower} and @i{upper} are @b{most-negative-fixnum} and @b{most-positive-fixnum}, respectively, is also called @b{fixnum}. The @i{type} @t{(integer 0 1)} is also called @b{bit}. The @i{type} @t{(integer 0 *)} is also called @b{unsigned-byte}. @node signed-byte, unsigned-byte, integer, Numbers Dictionary @subsection signed-byte [Type] @subsubheading Supertypes:: @b{signed-byte}, @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: The atomic @i{type specifier} @b{signed-byte} denotes the same type as is denoted by the @i{type specifier} @b{integer}; however, the list forms of these two @i{type specifiers} have different semantics. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{signed-byte}@{@i{@t{[}s | @b{*}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{s}---a positive @i{integer}. @subsubheading Compound Type Specifier Description:: This denotes the set of @i{integers} that can be represented in two's-complement form in a @i{byte} of @i{s} bits. This is equivalent to @t{(integer -2^@r{s-1} 2^@r{s-1}-1)}. The type @b{signed-byte} or the type @t{(signed-byte *)} is the same as the @i{type} @b{integer}. @node unsigned-byte, mod (System Class), signed-byte, Numbers Dictionary @subsection unsigned-byte [Type] @subsubheading Supertypes:: @b{unsigned-byte}, @b{signed-byte}, @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: The atomic @i{type specifier} @b{unsigned-byte} denotes the same type as is denoted by the @i{type specifier} @t{(integer 0 *)}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{unsigned-byte}@{@i{@t{[}@i{s} | @b{*}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{s}---a positive @i{integer}. @subsubheading Compound Type Specifier Description:: This denotes the set of non-negative @i{integers} that can be represented in a byte of size @i{s} (bits). This is equivalent to @t{(mod @i{m})} for @i{m}=2^s, or to @t{(integer 0 @i{n})} for @i{n}=2^s-1. The @i{type} @b{unsigned-byte} or the type @t{(unsigned-byte *)} is the same as the type @t{(integer 0 *)}, the set of non-negative @i{integers}. @subsubheading Notes:: The @i{type} @t{(unsigned-byte 1)} is also called @b{bit}. @node mod (System Class), bit (System Class), unsigned-byte, Numbers Dictionary @subsection mod [Type Specifier] @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{mod}@{@i{n}@}) @subsubheading Compound Type Specifier Arguments:: @i{n}---a positive @i{integer}. @subsubheading Compound Type Specifier Description:: This denotes the set of non-negative @i{integers} less than @i{n}. This is equivalent to @t{(integer 0 (@i{n}))} or to @t{(integer 0 @i{m})}, where @i{m}=@i{n}-1. The argument is required, and cannot be @b{*}. The symbol @b{mod} is not valid as a @i{type specifier}. @node bit (System Class), fixnum, mod (System Class), Numbers Dictionary @subsection bit [Type] @subsubheading Supertypes:: @b{bit}, @b{unsigned-byte}, @b{signed-byte}, @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: The @i{type} @b{bit} is equivalent to the @i{type} @t{(integer 0 1)} and @t{(unsigned-byte 1)}. @node fixnum, bignum, bit (System Class), Numbers Dictionary @subsection fixnum [Type] @subsubheading Supertypes:: @b{fixnum}, @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: A @i{fixnum} is an @i{integer} whose value is between @b{most-negative-fixnum} and @b{most-positive-fixnum} inclusive. Exactly which @i{integers} are @i{fixnums} is @i{implementation-defined}. The @i{type} @b{fixnum} is required to be a supertype of @t{(signed-byte 16)}. @node bignum, =, fixnum, Numbers Dictionary @subsection bignum [Type] @subsubheading Supertypes:: @b{bignum}, @b{integer}, @b{rational}, @b{real}, @b{number}, @b{t} @subsubheading Description:: The @i{type} @b{bignum} is defined to be exactly @t{(and integer (not fixnum))}. @node =, max, bignum, Numbers Dictionary @subsection =, /=, <, >, <=, >= [Function] @code{=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @code{/=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @code{<} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @code{>} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @code{<=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @code{>=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{number}---for @b{<}, @b{>}, @b{<=}, @b{>=}: a @i{real}; for @b{=}, @b{/=}: a @i{number}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{=}, @b{/=}, @b{<}, @b{>}, @b{<=}, and @b{>=} perform arithmetic comparisons on their arguments as follows: @table @asis @item @b{=} The value of @b{=} is @i{true} if all @i{numbers} are the same in value; otherwise it is @i{false}. Two @i{complexes} are considered equal by @b{=} if their real and imaginary parts are equal according to @b{=}. @item @b{/=} The value of @b{/=} is @i{true} if no two @i{numbers} are the same in value; otherwise it is @i{false}. @item @b{<} The value of @b{<} is @i{true} if the @i{numbers} are in monotonically increasing order; otherwise it is @i{false}. @item @b{>} The value of @b{>} is @i{true} if the @i{numbers} are in monotonically decreasing order; otherwise it is @i{false}. @item @b{<=} The value of @b{<=} is @i{true} if the @i{numbers} are in monotonically nondecreasing order; otherwise it is @i{false}. @item @b{>=} The value of @b{>=} is @i{true} if the @i{numbers} are in monotonically nonincreasing order; otherwise it is @i{false}. @end table @b{=}, @b{/=}, @b{<}, @b{>}, @b{<=}, and @b{>=} perform necessary type conversions. @subsubheading Examples:: The uses of these functions are illustrated in Figure 12--12. @format @group @noindent @w{ @t{(= 3 3)} is @i{true}. @t{(/= 3 3)} is @i{false}. } @w{ @t{(= 3 5)} is @i{false}. @t{(/= 3 5)} is @i{true}. } @w{ @t{(= 3 3 3 3)} is @i{true}. @t{(/= 3 3 3 3)} is @i{false}. } @w{ @t{(= 3 3 5 3)} is @i{false}. @t{(/= 3 3 5 3)} is @i{false}. } @w{ @t{(= 3 6 5 2)} is @i{false}. @t{(/= 3 6 5 2)} is @i{true}. } @w{ @t{(= 3 2 3)} is @i{false}. @t{(/= 3 2 3)} is @i{false}. } @w{ @t{(< 3 5)} is @i{true}. @t{(<= 3 5)} is @i{true}. } @w{ @t{(< 3 -5)} is @i{false}. @t{(<= 3 -5)} is @i{false}. } @w{ @t{(< 3 3)} is @i{false}. @t{(<= 3 3)} is @i{true}. } @w{ @t{(< 0 3 4 6 7)} is @i{true}. @t{(<= 0 3 4 6 7)} is @i{true}. } @w{ @t{(< 0 3 4 4 6)} is @i{false}. @t{(<= 0 3 4 4 6)} is @i{true}. } @w{ @t{(> 4 3)} is @i{true}. @t{(>= 4 3)} is @i{true}. } @w{ @t{(> 4 3 2 1 0)} is @i{true}. @t{(>= 4 3 2 1 0)} is @i{true}. } @w{ @t{(> 4 3 3 2 0)} is @i{false}. @t{(>= 4 3 3 2 0)} is @i{true}. } @w{ @t{(> 4 3 1 2 0)} is @i{false}. @t{(>= 4 3 1 2 0)} is @i{false}. } @w{ @t{(= 3)} is @i{true}. @t{(/= 3)} is @i{true}. } @w{ @t{(< 3)} is @i{true}. @t{(<= 3)} is @i{true}. } @w{ @t{(= 3.0 #c(3.0 0.0))} is @i{true}. @t{(/= 3.0 #c(3.0 1.0))} is @i{true}. } @w{ @t{(= 3 3.0)} is @i{true}. @t{(= 3.0s0 3.0d0)} is @i{true}. } @w{ @t{(= 0.0 -0.0)} is @i{true}. @t{(= 5/2 2.5)} is @i{true}. } @w{ @t{(> 0.0 -0.0)} is @i{false}. @t{(= 0 -0.0)} is @i{true}. } @w{ @t{(<= 0 x 9)} is @i{true} if @t{x} is between @t{0} and @t{9}, inclusive} @w{ @t{(< 0.0 x 1.0)} is @i{true} if @t{x} is between @t{0.0} and @t{1.0}, exclusive} @w{ @t{(< -1 j (length v))} is @i{true} if @t{j} is a @i{valid array index} for a @i{vector} @t{v}} @noindent @w{ Figure 12--12: Uses of /=, =, <, >, <=, and >= } @end group @end format @subsubheading Exceptional Situations:: Might signal @b{type-error} if some @i{argument} is not a @i{real}. Might signal @b{arithmetic-error} if otherwise unable to fulfill its contract. @subsubheading Notes:: @b{=} differs from @b{eql} in that @t{(= 0.0 -0.0)} is always true, because @b{=} compares the mathematical values of its operands, whereas @b{eql} compares the representational values, so to speak. @node max, minusp, =, Numbers Dictionary @subsection max, min [Function] @code{max} @i{@r{&rest} reals^+} @result{} @i{max-real} @code{min} @i{@r{&rest} reals^+} @result{} @i{min-real} @subsubheading Arguments and Values:: @i{real}---a @i{real}. @i{max-real}, @i{min-real}---a @i{real}. @subsubheading Description:: @b{max} returns the @i{real} that is greatest (closest to positive infinity). @b{min} returns the @i{real} that is least (closest to negative infinity). For @b{max}, the implementation has the choice of returning the largest argument as is or applying the rules of floating-point @i{contagion}, taking all the arguments into consideration for @i{contagion} purposes. Also, if one or more of the arguments are @b{=}, then any one of them may be chosen as the value to return. For example, if the @i{reals} are a mixture of @i{rationals} and @i{floats}, and the largest argument is a @i{rational}, then the implementation is free to produce either that @i{rational} or its @i{float} approximation; if the largest argument is a @i{float} of a smaller format than the largest format of any @i{float} argument, then the implementation is free to return the argument in its given format or expanded to the larger format. Similar remarks apply to @b{min} (replacing ``largest argument'' by ``smallest argument''). @subsubheading Examples:: @example (max 3) @result{} 3 (min 3) @result{} 3 (max 6 12) @result{} 12 (min 6 12) @result{} 6 (max -6 -12) @result{} -6 (min -6 -12) @result{} -12 (max 1 3 2 -7) @result{} 3 (min 1 3 2 -7) @result{} -7 (max -2 3 0 7) @result{} 7 (min -2 3 0 7) @result{} -2 (max 5.0 2) @result{} 5.0 (min 5.0 2) @result{} 2 @i{OR}@result{} 2.0 (max 3.0 7 1) @result{} 7 @i{OR}@result{} 7.0 (min 3.0 7 1) @result{} 1 @i{OR}@result{} 1.0 (max 1.0s0 7.0d0) @result{} 7.0d0 (min 1.0s0 7.0d0) @result{} 1.0s0 @i{OR}@result{} 1.0d0 (max 3 1 1.0s0 1.0d0) @result{} 3 @i{OR}@result{} 3.0d0 (min 3 1 1.0s0 1.0d0) @result{} 1 @i{OR}@result{} 1.0s0 @i{OR}@result{} 1.0d0 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if any @i{number} is not a @i{real}. @node minusp, zerop, max, Numbers Dictionary @subsection minusp, plusp [Function] @code{minusp} @i{real} @result{} @i{generalized-boolean} @code{plusp} @i{real} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{real}---a @i{real}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{minusp} returns @i{true} if @i{real} is less than zero; otherwise, returns @i{false}. @b{plusp} returns @i{true} if @i{real} is greater than zero; otherwise, returns @i{false}. Regardless of whether an @i{implementation} provides distinct representations for positive and negative @i{float} zeros, @t{(minusp -0.0)} always returns @i{false}. @subsubheading Examples:: @example (minusp -1) @result{} @i{true} (plusp 0) @result{} @i{false} (plusp least-positive-single-float) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{real} is not a @i{real}. @node zerop, floor, minusp, Numbers Dictionary @subsection zerop [Function] @code{zerop} @i{number} @result{} @i{generalized-boolean} @subsubheading Pronunciation:: pronounced 'z\=e (, )r\=o@r{}(, )p\=e @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{number} is zero (@i{integer}, @i{float}, or @i{complex}); otherwise, returns @i{false}. Regardless of whether an @i{implementation} provides distinct representations for positive and negative floating-point zeros, @t{(zerop -0.0)} always returns @i{true}. @subsubheading Examples:: @example (zerop 0) @result{} @i{true} (zerop 1) @result{} @i{false} (zerop -0.0) @result{} @i{true} (zerop 0/100) @result{} @i{true} (zerop #c(0 0.0)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{number} is not a @i{number}. @subsubheading Notes:: @example (zerop @i{number}) @equiv{} (= @i{number} 0) @end example @node floor, sin, zerop, Numbers Dictionary @subsection floor, ffloor, ceiling, fceiling, @subheading truncate, ftruncate, round, fround @flushright @i{[Function]} @end flushright @code{floor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{ffloor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{ceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{fceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{truncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{ftruncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{round} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @code{fround} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @subsubheading Arguments and Values:: @i{number}---a @i{real}. @i{divisor}---a non-zero @i{real}. The default is the @i{integer} @t{1}. @i{quotient}---for @b{floor}, @b{ceiling}, @b{truncate}, and @b{round}: an @i{integer}; for @b{ffloor}, @b{fceiling}, @b{ftruncate}, and @b{fround}: a @i{float}. @i{remainder}---a @i{real}. @subsubheading Description:: These functions divide @i{number} by @i{divisor}, returning a @i{quotient} and @i{remainder}, such that @i{quotient}@r{\cdot} @i{divisor}+@i{remainder}=@i{number} The @i{quotient} always represents a mathematical integer. When more than one mathematical integer might be possible (@i{i.e.}, when the remainder is not zero), the kind of rounding or truncation depends on the @i{operator}: @table @asis @item @b{floor}, @b{ffloor} @b{floor} and @b{ffloor} produce a @i{quotient} that has been truncated toward negative infinity; that is, the @i{quotient} represents the largest mathematical integer that is not larger than the mathematical quotient. @item @b{ceiling}, @b{fceiling} @b{ceiling} and @b{fceiling} produce a @i{quotient} that has been truncated toward positive infinity; that is, the @i{quotient} represents the smallest mathematical integer that is not smaller than the mathematical result. @item @b{truncate}, @b{ftruncate} @b{truncate} and @b{ftruncate} produce a @i{quotient} that has been truncated towards zero; that is, the @i{quotient} represents the mathematical integer of the same sign as the mathematical quotient, and that has the greatest integral magnitude not greater than that of the mathematical quotient. @item @b{round}, @b{fround} @b{round} and @b{fround} produce a @i{quotient} that has been rounded to the nearest mathematical integer; if the mathematical quotient is exactly halfway between two integers, (that is, it has the form @i{integer}+1\over2), then the @i{quotient} has been rounded to the even (divisible by two) integer. @end table All of these functions perform type conversion operations on @i{numbers}. The @i{remainder} is an @i{integer} if both @t{x} and @t{y} are @i{integers}, is a @i{rational} if both @t{x} and @t{y} are @i{rationals}, and is a @i{float} if either @t{x} or @t{y} is a @i{float}. @b{ffloor}, @b{fceiling}, @b{ftruncate}, and @b{fround} handle arguments of different @i{types} in the following way: If @i{number} is a @i{float}, and @i{divisor} is not a @i{float} of longer format, then the first result is a @i{float} of the same @i{type} as @i{number}. Otherwise, the first result is of the @i{type} determined by @i{contagion} rules; see @ref{Contagion in Numeric Operations}. @subsubheading Examples:: @example (floor 3/2) @result{} 1, 1/2 (ceiling 3 2) @result{} 2, -1 (ffloor 3 2) @result{} 1.0, 1 (ffloor -4.7) @result{} -5.0, 0.3 (ffloor 3.5d0) @result{} 3.0d0, 0.5d0 (fceiling 3/2) @result{} 2.0, -1/2 (truncate 1) @result{} 1, 0 (truncate .5) @result{} 0, 0.5 (round .5) @result{} 0, 0.5 (ftruncate -7 2) @result{} -3.0, -1 (fround -7 2) @result{} -4.0, 1 (dolist (n '(2.6 2.5 2.4 0.7 0.3 -0.3 -0.7 -2.4 -2.5 -2.6)) (format t "~&~4,1@@F ~2,' D ~2,' D ~2,' D ~2,' D" n (floor n) (ceiling n) (truncate n) (round n))) @t{ |> } +2.6 2 3 2 3 @t{ |> } +2.5 2 3 2 2 @t{ |> } +2.4 2 3 2 2 @t{ |> } +0.7 0 1 0 1 @t{ |> } +0.3 0 1 0 0 @t{ |> } -0.3 -1 0 0 0 @t{ |> } -0.7 -1 0 0 -1 @t{ |> } -2.4 -3 -2 -2 -2 @t{ |> } -2.5 -3 -2 -2 -2 @t{ |> } -2.6 -3 -2 -2 -3 @result{} NIL @end example @subsubheading Notes:: When only @i{number} is given, the two results are exact; the mathematical sum of the two results is always equal to the mathematical value of @i{number}. @t{(@i{function} @i{number} @i{divisor})} and @t{(@i{function} (/ @i{number} @i{divisor}))} (where @i{function} is any of one of @b{floor}, @b{ceiling}, @b{ffloor}, @b{fceiling}, @b{truncate}, @b{round}, @b{ftruncate}, and @b{fround}) return the same first value, but they return different remainders as the second value. For example: @example (floor 5 2) @result{} 2, 1 (floor (/ 5 2)) @result{} 2, 1/2 @end example If an effect is desired that is similar to @b{round}, but that always rounds up or down (rather than toward the nearest even integer) if the mathematical quotient is exactly halfway between two integers, the programmer should consider a construction such as @t{(floor (+ x 1/2))} or @t{(ceiling (- x 1/2))}. @node sin, asin, floor, Numbers Dictionary @subsection sin, cos, tan [Function] @code{sin} @i{radians} @result{} @i{number} @code{cos} @i{radians} @result{} @i{number} @code{tan} @i{radians} @result{} @i{number} @subsubheading Arguments and Values:: @i{radians}---a @i{number} given in radians. @i{number}---a @i{number}. @subsubheading Description:: @b{sin}, @b{cos}, and @b{tan} return the sine, cosine, and tangent, respectively, of @i{radians}. @subsubheading Examples:: @example (sin 0) @result{} 0.0 (cos 0.7853982) @result{} 0.707107 (tan #c(0 1)) @result{} #C(0.0 0.761594) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{radians} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{asin} , @b{acos}, @b{atan}, @ref{Rule of Float Substitutability} @node asin, pi, sin, Numbers Dictionary @subsection asin, acos, atan [Function] @code{asin} @i{number} @result{} @i{radians} @code{acos} @i{number} @result{} @i{radians} @code{atan} @i{number1 @r{&optional} number2} @result{} @i{radians} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{number1}---a @i{number} if @i{number2} is not supplied, or a @i{real} if @i{number2} is supplied. @i{number2}---a @i{real}. @i{radians}---a @i{number} (of radians). @subsubheading Description:: @b{asin}, @b{acos}, and @b{atan} compute the arc sine, arc cosine, and arc tangent respectively. The arc sine, arc cosine, and arc tangent (with only @i{number1} supplied) functions can be defined mathematically for @i{number} or @i{number1} specified as @i{x} as in Figure 12--13. @format @group @noindent @w{ Function Definition } @w{ Arc sine -i @t{log} (ix+ \sqrt@r{1-x^2} ) } @w{ Arc cosine (\pi/2) - @t{arcsin} x } @w{ Arc tangent -i @t{log} ((1+ix) \sqrt@r{1/(1+x^2)} ) } @noindent @w{ Figure 12--13: Mathematical definition of arc sine, arc cosine, and arc tangent} @end group @end format These formulae are mathematically correct, assuming completely accurate computation. They are not necessarily the simplest ones for real-valued computations. If both @i{number1} and @i{number2} are supplied for @b{atan}, the result is the arc tangent of @i{number1}/@i{number2}. The value of @b{atan} is always between -\pi (exclusive) and~\pi (inclusive) when minus zero is not supported. The range of the two-argument arc tangent when minus zero is supported includes -\pi. For a @i{real} @i{number1}, the result is a @i{real} and lies between -\pi/2 and~\pi/2 (both exclusive). @i{number1} can be a @i{complex} if @i{number2} is not supplied. If both are supplied, @i{number2} can be zero provided @i{number1} is not zero. [Reviewer Note by Barmar: Should add ``However, if the implementation distinguishes positive and negative zero, both may be signed zeros, and limits are used to define the result.''] The following definition for arc sine determines the range and branch cuts: @center @t{arcsin} z = -i @t{log} (iz+\sqrt@r{1-z^2}\Bigr) The branch cut for the arc sine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is non-positive. The following definition for arc cosine determines the range and branch cuts: @center @t{arccos} z = \pi\over2 - @t{arcsin} z or, which are equivalent, @center @t{arccos} z = -i @t{log} (z+i \sqrt@r{1-z^2}\Bigr) @center @t{arccos} z = @t{2 @t{log} (\sqrt@r{(1+z)/2} + i \sqrt@r{(1-z)/2})}\over@r{i} The branch cut for the arc cosine function is in two pieces: one along the negative real axis to the left of~-1 (inclusive), continuous with quadrant II, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant IV. This is the same branch cut as for arc sine. The range is that strip of the complex plane containing numbers whose real part is between 0 and~\pi. A number with real part equal to 0 is in the range if and only if its imaginary part is non-negative; a number with real part equal to \pi is in the range if and only if its imaginary part is non-positive. The following definition for (one-argument) arc tangent determines the range and branch cuts: @center @t{arctan} z = @i{@i{@t{log} (1+iz) - @t{log} (1-iz)}\over@i{2i}} Beware of simplifying this formula; ``obvious'' simplifications are likely to alter the branch cuts or the values on the branch cuts incorrectly. The branch cut for the arc tangent function is in two pieces: one along the positive imaginary axis above i (exclusive), continuous with quadrant II, and one along the negative imaginary axis below -i (exclusive), continuous with quadrant IV. The points i and~-i are excluded from the domain. The range is that strip of the complex plane containing numbers whose real part is between -\pi/2 and~\pi/2. A number with real part equal to -\pi/2 is in the range if and only if its imaginary part is strictly positive; a number with real part equal to \pi/2 is in the range if and only if its imaginary part is strictly negative. Thus the range of arc tangent is identical to that of arc sine with the points -\pi/2 and~\pi/2 excluded. For @b{atan}, the signs of @i{number1} (indicated as @i{x}) and @i{number2} (indicated as @i{y}) are used to derive quadrant information. Figure 12--14 details various special cases. The asterisk (*) indicates that the entry in the figure applies to implementations that support minus zero. @format @group @noindent @w{ to 1pc@r{}@i{y} Condition @i{x} Condition Cartesian locus Range of result } @w{ to 1pc@r{} y = 0 x > 0 Positive x-axis 0 } @w{ to 1pc* y = +0 x > 0 Positive x-axis +0 } @w{ to 1pc* y = -0 x > 0 Positive x-axis -0 } @w{ to 1pc@r{} y > 0 x > 0 Quadrant I 0 < result < \pi/2 } @w{ to 1pc@r{} y > 0 x = 0 Positive y-axis \pi/2 } @w{ to 1pc@r{} y > 0 x < 0 Quadrant II \pi/2 < result < \pi } @w{ to 1pc@r{} y = 0 x < 0 Negative x-axis \pi } @w{ to 1pc* y = +0 x < 0 Negative x-axis +\pi } @w{ to 1pc* y = -0 x < 0 Negative x-axis -\pi } @w{ to 1pc@r{} y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 } @w{ to 1pc@r{} y < 0 x = 0 Negative y-axis -\pi/2 } @w{ to 1pc@r{} y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 } @w{ to 1pc@r{} y = 0 x = 0 Origin undefined consequences } @w{ to 1pc* y = +0 x = +0 Origin +0 } @w{ to 1pc* y = -0 x = +0 Origin -0 } @w{ to 1pc* y = +0 x = -0 Origin +\pi } @w{ to 1pc* y = -0 x = -0 Origin -\pi } @noindent @w{ Figure 12--14: Quadrant information for arc tangent } @end group @end format @subsubheading Examples:: @example (asin 0) @result{} 0.0 (acos #c(0 1)) @result{} #C(1.5707963267948966 -0.8813735870195432) (/ (atan 1 (sqrt 3)) 6) @result{} 0.087266 (atan #c(0 2)) @result{} #C(-1.5707964 0.54930615) @end example @subsubheading Exceptional Situations:: @b{acos} and @b{asin} should signal an error of @i{type} @b{type-error} if @i{number} is not a @i{number}. @b{atan} should signal @b{type-error} if one argument is supplied and that argument is not a @i{number}, or if two arguments are supplied and both of those arguments are not @i{reals}. @b{acos}, @b{asin}, and @b{atan} might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{log} , @ref{sqrt} , @ref{Rule of Float Substitutability} @subsubheading Notes:: The result of either @b{asin} or @b{acos} can be a @i{complex} even if @i{number} is not a @i{complex}; this occurs when the absolute value of @i{number} is greater than one. @node pi, sinh, asin, Numbers Dictionary @subsection pi [Constant Variable] @subsubheading Value:: an @i{implementation-dependent} @i{long float}. @subsubheading Description:: The best @i{long float} approximation to the mathematical constant \pi. @subsubheading Examples:: @example ;; In each of the following computations, the precision depends ;; on the implementation. Also, if `long float' is treated by ;; the implementation as equivalent to some other float format ;; (e.g., `double float') the exponent marker might be the marker ;; for that equivalent (e.g., `D' instead of `L'). pi @result{} 3.141592653589793L0 (cos pi) @result{} -1.0L0 (defun sin-of-degrees (degrees) (let ((x (if (floatp degrees) degrees (float degrees pi)))) (sin (* x (/ (float pi x) 180))))) @end example @subsubheading Notes:: An approximation to \pi in some other precision can be obtained by writing @t{(float pi x)}, where @t{x} is a @i{float} of the desired precision, or by writing @t{(coerce pi @i{type})}, where @i{type} is the desired type, such as @b{short-float}. @node sinh, *, pi, Numbers Dictionary @subsection sinh, cosh, tanh, asinh, acosh, atanh [Function] @code{sinh} @i{number} @result{} @i{result} @code{cosh} @i{number} @result{} @i{result} @code{tanh} @i{number} @result{} @i{result} @code{asinh} @i{number} @result{} @i{result} @code{acosh} @i{number} @result{} @i{result} @code{atanh} @i{number} @result{} @i{result} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{result}---a @i{number}. @subsubheading Description:: These functions compute the hyperbolic sine, cosine, tangent, arc sine, arc cosine, and arc tangent functions, which are mathematically defined for an argument @i{x} as given in Figure 12--15. @format @group @noindent @w{ Function Definition } @w{ Hyperbolic sine (e^x-e^@i{-x})/2 } @w{ Hyperbolic cosine (e^x+e^@i{-x})/2 } @w{ Hyperbolic tangent (e^x-e^@i{-x})/(e^x+e^@i{-x}) } @w{ Hyperbolic arc sine @t{log} (x+\sqrt@i{1+x^2}) } @w{ Hyperbolic arc cosine 2 @t{log} (\sqrt@i{(x+1)/2} + \sqrt@i{(x-1)/2}) } @w{ Hyperbolic arc tangent (@t{log} (1+x) - @t{log} (1-x))/2 } @noindent @w{ Figure 12--15: Mathematical definitions for hyperbolic functions } @end group @end format The following definition for the inverse hyperbolic cosine determines the range and branch cuts: @center @t{arccosh} z = 2 @t{log} (\sqrt@i{(z+1)/2} + \sqrt@i{(z-1)/2}\Bigr). The branch cut for the inverse hyperbolic cosine function lies along the real axis to the left of~1 (inclusive), extending indefinitely along the negative real axis, continuous with quadrant II and (between 0 and~1) with quadrant I. The range is that half-strip of the complex plane containing numbers whose real part is non-negative and whose imaginary part is between -\pi (exclusive) and~\pi (inclusive). A number with real part zero is in the range if its imaginary part is between zero (inclusive) and~\pi (inclusive). The following definition for the inverse hyperbolic sine determines the range and branch cuts: @center @t{arcsinh} z = @t{log} (z+\sqrt@i{1+z^2}\Bigr). The branch cut for the inverse hyperbolic sine function is in two pieces: one along the positive imaginary axis above i (inclusive), continuous with quadrant I, and one along the negative imaginary axis below -i (inclusive), continuous with quadrant III. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and~\pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is non-positive; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is non-negative. The following definition for the inverse hyperbolic tangent determines the range and branch cuts: @center @t{arctanh} z = @i{@i{@t{log} (1+z) - @t{log} (1-z)}\over@r{2}}. Note that: @center i @t{arctan} z = @t{arctanh} iz. The branch cut for the inverse hyperbolic tangent function is in two pieces: one along the negative real axis to the left of -1 (inclusive), continuous with quadrant III, and one along the positive real axis to the right of~1 (inclusive), continuous with quadrant I. The points -1 and~1 are excluded from the domain. The range is that strip of the complex plane containing numbers whose imaginary part is between -\pi/2 and \pi/2. A number with imaginary part equal to -\pi/2 is in the range if and only if its real part is strictly negative; a number with imaginary part equal to \pi/2 is in the range if and only if its imaginary part is strictly positive. Thus the range of the inverse hyperbolic tangent function is identical to that of the inverse hyperbolic sine function with the points -\pi i/2 and~\pi i/2 excluded. @subsubheading Examples:: @example (sinh 0) @result{} 0.0 (cosh (complex 0 -1)) @result{} #C(0.540302 -0.0) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{number} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{log} , @ref{sqrt} , @ref{Rule of Float Substitutability} @subsubheading Notes:: The result of @b{acosh} may be a @i{complex} even if @i{number} is not a @i{complex}; this occurs when @i{number} is less than one. Also, the result of @b{atanh} may be a @i{complex} even if @i{number} is not a @i{complex}; this occurs when the absolute value of @i{number} is greater than one. The branch cut formulae are mathematically correct, assuming completely accurate computation. Implementors should consult a good text on numerical analysis. The formulae given above are not necessarily the simplest ones for real-valued computations; they are chosen to define the branch cuts in desirable ways for the complex case. @node *, +, sinh, Numbers Dictionary @subsection * [Function] @code{*} @i{@r{&rest} numbers} @result{} @i{product} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{product}---a @i{number}. @subsubheading Description:: Returns the product of @i{numbers}, performing any necessary type conversions in the process. If no @i{numbers} are supplied, @t{1} is returned. @subsubheading Examples:: @example (*) @result{} 1 (* 3 5) @result{} 15 (* 1.0 #c(22 33) 55/98) @result{} #C(12.346938775510203 18.520408163265305) @end example @subsubheading Exceptional Situations:: Might signal @b{type-error} if some @i{argument} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{Numeric Operations}, @ref{Rational Computations}, @ref{Floating-point Computations}, @ref{Complex Computations} @node +, -, *, Numbers Dictionary @subsection + [Function] @code{+} @i{@r{&rest} numbers} @result{} @i{sum} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{sum}---a @i{number}. @subsubheading Description:: Returns the sum of @i{numbers}, performing any necessary type conversions in the process. If no @i{numbers} are supplied, @t{0} is returned. @subsubheading Examples:: @example (+) @result{} 0 (+ 1) @result{} 1 (+ 31/100 69/100) @result{} 1 (+ 1/5 0.8) @result{} 1.0 @end example @subsubheading Exceptional Situations:: Might signal @b{type-error} if some @i{argument} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{Numeric Operations}, @ref{Rational Computations}, @ref{Floating-point Computations}, @ref{Complex Computations} @node -, /, +, Numbers Dictionary @subsection - [Function] @code{-} @i{number} @result{} @i{negation} @code{-} @i{minuend @r{&rest} subtrahends^+} @result{} @i{difference} @subsubheading Arguments and Values:: @i{number}, @i{minuend}, @i{subtrahend}---a @i{number}. @i{negation}, @i{difference}---a @i{number}. @subsubheading Description:: The @i{function} @b{-} performs arithmetic subtraction and negation. If only one @i{number} is supplied, the negation of that @i{number} is returned. If more than one @i{argument} is given, it subtracts all of the @i{subtrahends} from the @i{minuend} and returns the result. The @i{function} @b{-} performs necessary type conversions. @subsubheading Examples:: @example (- 55.55) @result{} -55.55 (- #c(3 -5)) @result{} #C(-3 5) (- 0) @result{} 0 (eql (- 0.0) -0.0) @result{} @i{true} (- #c(100 45) #c(0 45)) @result{} 100 (- 10 1 2 3 4) @result{} 0 @end example @subsubheading Exceptional Situations:: Might signal @b{type-error} if some @i{argument} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{Numeric Operations}, @ref{Rational Computations}, @ref{Floating-point Computations}, @ref{Complex Computations} @node /, 1+, -, Numbers Dictionary @subsection / [Function] @code{/} @i{number} @result{} @i{reciprocal} @code{/} @i{numerator @r{&rest} denominators^+} @result{} @i{quotient} @subsubheading Arguments and Values:: @i{number}, @i{denominator}---a non-zero @i{number}. @i{numerator}, @i{quotient}, @i{reciprocal}---a @i{number}. @subsubheading Description:: The @i{function} @b{/} performs division or reciprocation. If no @i{denominators} are supplied, the @i{function} @b{/} returns the reciprocal of @i{number}. If at least one @i{denominator} is supplied, the @i{function} @b{/} divides the @i{numerator} by all of the @i{denominators} and returns the resulting @i{quotient}. If each @i{argument} is either an @i{integer} or a @i{ratio}, and the result is not an @i{integer}, then it is a @i{ratio}. The @i{function} @b{/} performs necessary type conversions. If any @i{argument} is a @i{float} then the rules of floating-point contagion apply; see @ref{Floating-point Computations}. @subsubheading Examples:: @example (/ 12 4) @result{} 3 (/ 13 4) @result{} 13/4 (/ -8) @result{} -1/8 (/ 3 4 5) @result{} 3/20 (/ 0.5) @result{} 2.0 (/ 20 5) @result{} 4 (/ 5 20) @result{} 1/4 (/ 60 -2 3 5.0) @result{} -2.0 (/ 2 #c(2 2)) @result{} #C(1/2 -1/2) @end example @subsubheading Exceptional Situations:: The consequences are unspecified if any @i{argument} other than the first is zero. If there is only one @i{argument}, the consequences are unspecified if it is zero. Might signal @b{type-error} if some @i{argument} is not a @i{number}. Might signal @b{division-by-zero} if division by zero is attempted. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{floor} , @b{ceiling}, @b{truncate}, @b{round} @node 1+, abs, /, Numbers Dictionary @subsection 1+, 1- [Function] @code{1} @i{+} @result{} @i{number} @r{successor} @code{1} @i{-} @result{} @i{number} @r{predecessor} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{successor}, @i{predecessor}---a @i{number}. @subsubheading Description:: @b{1+} returns a @i{number} that is one more than its argument @i{number}. @b{1-} returns a @i{number} that is one less than its argument @i{number}. @subsubheading Examples:: @example (1+ 99) @result{} 100 (1- 100) @result{} 99 (1+ (complex 0.0)) @result{} #C(1.0 0.0) (1- 5/3) @result{} 2/3 @end example @subsubheading Exceptional Situations:: Might signal @b{type-error} if its @i{argument} is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{incf} , @b{decf} @subsubheading Notes:: @example (1+ @i{number}) @equiv{} (+ @i{number} 1) (1- @i{number}) @equiv{} (- @i{number} 1) @end example Implementors are encouraged to make the performance of both the previous expressions be the same. @node abs, evenp, 1+, Numbers Dictionary @subsection abs [Function] @code{abs} @i{number} @result{} @i{absolute-value} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{absolute-value}---a non-negative @i{real}. @subsubheading Description:: @b{abs} returns the absolute value of @i{number}. If @i{number} is a @i{real}, the result is of the same @i{type} as @i{number}. If @i{number} is a @i{complex}, the result is a positive @i{real} with the same magnitude as @i{number}. The result can be a @i{float} [Reviewer Note by Barmar: Single-float.] even if @i{number}'s components are @i{rationals} and an exact rational result would have been possible. Thus the result of @t{(abs #c(3 4))} can be either @t{5} or @t{5.0}, depending on the implementation. @subsubheading Examples:: @example (abs 0) @result{} 0 (abs 12/13) @result{} 12/13 (abs -1.09) @result{} 1.09 (abs #c(5.0 -5.0)) @result{} 7.071068 (abs #c(5 5)) @result{} 7.071068 (abs #c(3/5 4/5)) @result{} 1 or approximately 1.0 (eql (abs -0.0) -0.0) @result{} @i{true} @end example @subsubheading See Also:: @ref{Rule of Float Substitutability} @subsubheading Notes:: If @i{number} is a @i{complex}, the result is equivalent to the following: @t{(sqrt (+ (expt (realpart @i{number}) 2) (expt (imagpart @i{number}) 2)))} An implementation should not use this formula directly for all @i{complexes} but should handle very large or very small components specially to avoid intermediate overflow or underflow. @node evenp, exp, abs, Numbers Dictionary @subsection evenp, oddp [Function] @code{evenp} @i{integer} @result{} @i{generalized-boolean} @code{oddp} @i{integer} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{evenp} returns @i{true} if @i{integer} is even (divisible by two); otherwise, returns @i{false}. @b{oddp} returns @i{true} if @i{integer} is odd (not divisible by two); otherwise, returns @i{false}. @subsubheading Examples:: @example (evenp 0) @result{} @i{true} (oddp 10000000000000000000000) @result{} @i{false} (oddp -1) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{integer} is not an @i{integer}. @subsubheading Notes:: @example (evenp @i{integer}) @equiv{} (not (oddp @i{integer})) (oddp @i{integer}) @equiv{} (not (evenp @i{integer})) @end example @node exp, gcd, evenp, Numbers Dictionary @subsection exp, expt [Function] @code{exp} @i{number} @result{} @i{result} @code{expt} @i{base-number power-number} @result{} @i{result} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{base-number}---a @i{number}. @i{power-number}---a @i{number}. @i{result}---a @i{number}. @subsubheading Description:: @b{exp} and @b{expt} perform exponentiation. @b{exp} returns @i{e} raised to the power @i{number}, where @i{e} is the base of the natural logarithms. @b{exp} has no branch cut. @b{expt} returns @i{base-number} raised to the power @i{power-number}. If the @i{base-number} is a @i{rational} and @i{power-number} is an @i{integer}, the calculation is exact and the result will be of @i{type} @b{rational}; otherwise a floating-point approximation might result. For @b{expt} of a @i{complex rational} to an @i{integer} power, the calculation must be exact and the result is of type @t{(or rational (complex rational))}. The result of @b{expt} can be a @i{complex}, even when neither argument is a @i{complex}, if @i{base-number} is negative and @i{power-number} is not an @i{integer}. The result is always the @i{principal} @i{complex} @i{value}. For example, @t{(expt -8 1/3)} is not permitted to return @t{-2}, even though @t{-2} is one of the cube roots of @t{-8}. The @i{principal} cube root is a @i{complex} approximately equal to @t{#C(1.0 1.73205)}, not @t{-2}. @b{expt} is defined as @i{b^x = e^@i{x log b\/}}. This defines the @i{principal} @i{values} precisely. The range of @b{expt} is the entire complex plane. Regarded as a function of @i{x}, with @i{b} fixed, there is no branch cut. Regarded as a function of @i{b}, with @i{x} fixed, there is in general a branch cut along the negative real axis, continuous with quadrant II. The domain excludes the origin. By definition, 0^0=1. If @i{b}=0 and the real part of @i{x} is strictly positive, then @i{b^x}=0. For all other values of @i{x}, 0^@i{x} is an error. When @i{power-number} is an @i{integer} @t{0}, then the result is always the value one in the @i{type} of @i{base-number}, even if the @i{base-number} is zero (of any @i{type}). That is: @example (expt x 0) @equiv{} (coerce 1 (type-of x)) @end example If @i{power-number} is a zero of any other @i{type}, then the result is also the value one, in the @i{type} of the arguments after the application of the contagion rules in @ref{Contagion in Numeric Operations}, with one exception: the consequences are undefined if @i{base-number} is zero when @i{power-number} is zero and not of @i{type} @b{integer}. @subsubheading Examples:: @example (exp 0) @result{} 1.0 (exp 1) @result{} 2.718282 (exp (log 5)) @result{} 5.0 (expt 2 8) @result{} 256 (expt 4 .5) @result{} 2.0 (expt #c(0 1) 2) @result{} -1 (expt #c(2 2) 3) @result{} #C(-16 16) (expt #c(2 2) 4) @result{} -64 @end example @subsubheading See Also:: @ref{log} , @ref{Rule of Float Substitutability} @subsubheading Notes:: Implementations of @b{expt} are permitted to use different algorithms for the cases of a @i{power-number} of @i{type} @b{rational} and a @i{power-number} of @i{type} @b{float}. Note that by the following logic, @t{(sqrt (expt @i{x} 3))} is not equivalent to @t{(expt @i{x} 3/2)}. @example (setq x (exp (/ (* 2 pi #c(0 1)) 3))) ;exp(2.pi.i/3) (expt x 3) @result{} 1 ;except for round-off error (sqrt (expt x 3)) @result{} 1 ;except for round-off error (expt x 3/2) @result{} -1 ;except for round-off error @end example @node gcd, incf, exp, Numbers Dictionary @subsection gcd [Function] @code{gcd} @i{@r{&rest} integers} @result{} @i{greatest-common-denominator} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{greatest-common-denominator}---a non-negative @i{integer}. @subsubheading Description:: Returns the greatest common divisor of @i{integers}. If only one @i{integer} is supplied, its absolute value is returned. If no @i{integers} are given, @b{gcd} returns @t{0}, which is an identity for this operation. @subsubheading Examples:: @example (gcd) @result{} 0 (gcd 60 42) @result{} 6 (gcd 3333 -33 101) @result{} 1 (gcd 3333 -33 1002001) @result{} 11 (gcd 91 -49) @result{} 7 (gcd 63 -42 35) @result{} 7 (gcd 5) @result{} 5 (gcd -4) @result{} 4 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if any @i{integer} is not an @i{integer}. @subsubheading See Also:: @ref{lcm} @subsubheading Notes:: For three or more arguments, @example (gcd b c ... z) @equiv{} (gcd (gcd a b) c ... z) @end example @node incf, lcm, gcd, Numbers Dictionary @subsection incf, decf [Macro] @code{incf} @i{place @r{[}delta-form@r{]}} @result{} @i{new-value} @code{decf} @i{place @r{[}delta-form@r{]}} @result{} @i{new-value} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{delta-form}---a @i{form}; evaluated to produce a @i{delta}. The default is @t{1}. @i{delta}---a @i{number}. @i{new-value}---a @i{number}. @subsubheading Description:: @b{incf} and @b{decf} are used for incrementing and decrementing the @i{value} of @i{place}, respectively. The @i{delta} is added to (in the case of @b{incf}) or subtracted from (in the case of @b{decf}) the number in @i{place} and the result is stored in @i{place}. Any necessary type conversions are performed automatically. For information about the @i{evaluation} of @i{subforms} of @i{places}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (setq n 0) (incf n) @result{} 1 n @result{} 1 (decf n 3) @result{} -2 n @result{} -2 (decf n -5) @result{} 3 (decf n) @result{} 2 (incf n 0.5) @result{} 2.5 (decf n) @result{} 1.5 n @result{} 1.5 @end example @subsubheading Side Effects:: @i{Place} is modified. @subsubheading See Also:: @b{+}, @ref{-} , @b{1+}, @b{1-}, @ref{setf} @node lcm, log, incf, Numbers Dictionary @subsection lcm [Function] @code{lcm} @i{@r{&rest} integers} @result{} @i{least-common-multiple} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{least-common-multiple}---a non-negative @i{integer}. @subsubheading Description:: @b{lcm} returns the least common multiple of the @i{integers}. If no @i{integer} is supplied, the @i{integer} @t{1} is returned. If only one @i{integer} is supplied, the absolute value of that @i{integer} is returned. For two arguments that are not both zero, @example (lcm a b) @equiv{} (/ (abs (* a b)) (gcd a b)) @end example If one or both arguments are zero, @example (lcm a 0) @equiv{} (lcm 0 a) @equiv{} 0 @end example For three or more arguments, @example (lcm a b c ... z) @equiv{} (lcm (lcm a b) c ... z) @end example @subsubheading Examples:: @example (lcm 10) @result{} 10 (lcm 25 30) @result{} 150 (lcm -24 18 10) @result{} 360 (lcm 14 35) @result{} 70 (lcm 0 5) @result{} 0 (lcm 1 2 3 4 5 6) @result{} 60 @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if any argument is not an @i{integer}. @subsubheading See Also:: @ref{gcd} @node log, mod (Function), lcm, Numbers Dictionary @subsection log [Function] @code{log} @i{number @r{&optional} base} @result{} @i{logarithm} @subsubheading Arguments and Values:: @i{number}---a non-zero @i{number}. @i{base}---a @i{number}. @i{logarithm}---a @i{number}. @subsubheading Description:: @b{log} returns the logarithm of @i{number} in base @i{base}. If @i{base} is not supplied its value is @i{e}, the base of the natural logarithms. @b{log} may return a @i{complex} when given a @i{real} negative @i{number}. @example (log -1.0) @equiv{} (complex 0.0 (float pi 0.0)) @end example If @i{base} is zero, @b{log} returns zero. The result of @t{(log 8 2)} may be either @t{3} or @t{3.0}, depending on the implementation. An implementation can use floating-point calculations even if an exact integer result is possible. The branch cut for the logarithm function of one argument (natural logarithm) lies along the negative real axis, continuous with quadrant II. The domain excludes the origin. The mathematical definition of a complex logarithm is as follows, whether or not minus zero is supported by the implementation: @example (log @i{x}) @equiv{} (complex (log (abs @i{x})) (phase @i{x})) @end example Therefore the range of the one-argument logarithm function is that strip of the complex plane containing numbers with imaginary parts between -\pi (exclusive) and~\pi (inclusive) if minus zero is not supported, or -\pi (inclusive) and~\pi (inclusive) if minus zero is supported. The two-argument logarithm function is defined as @example (log @i{base} @i{number}) @equiv{} (/ (log @i{number}) (log @i{base})) @end example This defines the @i{principal} @i{values} precisely. The range of the two-argument logarithm function is the entire complex plane. @subsubheading Examples:: @example (log 100 10) @result{} 2.0 @result{} 2 (log 100.0 10) @result{} 2.0 (log #c(0 1) #c(0 -1)) @result{} #C(-1.0 0.0) @i{OR}@result{} #C(-1 0) (log 8.0 2) @result{} 3.0 @end example @example (log #c(-16 16) #c(2 2)) @result{} 3 or approximately #c(3.0 0.0) or approximately 3.0 (unlikely) @end example @subsubheading Affected By:: The implementation. @subsubheading See Also:: @ref{exp} , @b{expt}, @ref{Rule of Float Substitutability} @node mod (Function), signum, log, Numbers Dictionary @subsection mod, rem [Function] @code{mod} @i{number divisor} @result{} @i{modulus} @code{rem} @i{number divisor} @result{} @i{remainder} @subsubheading Arguments and Values:: @i{number}---a @i{real}. @i{divisor}---a @i{real}. @i{modulus}, @i{remainder}---a @i{real}. @subsubheading Description:: @b{mod} and @b{rem} are generalizations of the modulus and remainder functions respectively. @b{mod} performs the operation @b{floor} on @i{number} and @i{divisor} and returns the remainder of the @b{floor} operation. @b{rem} performs the operation @b{truncate} on @i{number} and @i{divisor} and returns the remainder of the @b{truncate} operation. @b{mod} and @b{rem} are the modulus and remainder functions when @i{number} and @i{divisor} are @i{integers}. @subsubheading Examples:: @example (rem -1 5) @result{} -1 (mod -1 5) @result{} 4 (mod 13 4) @result{} 1 (rem 13 4) @result{} 1 (mod -13 4) @result{} 3 (rem -13 4) @result{} -1 (mod 13 -4) @result{} -3 (rem 13 -4) @result{} 1 (mod -13 -4) @result{} -1 (rem -13 -4) @result{} -1 (mod 13.4 1) @result{} 0.4 (rem 13.4 1) @result{} 0.4 (mod -13.4 1) @result{} 0.6 (rem -13.4 1) @result{} -0.4 @end example @subsubheading See Also:: @ref{floor} , @b{truncate} @subsubheading Notes:: The result of @b{mod} is either zero or a @i{real} with the same sign as @i{divisor}. @node signum, sqrt, mod (Function), Numbers Dictionary @subsection signum [Function] @code{signum} @i{number} @result{} @i{signed-prototype} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{signed-prototype}---a @i{number}. @subsubheading Description:: @b{signum} determines a numerical value that indicates whether @i{number} is negative, zero, or positive. For a @i{rational}, @b{signum} returns one of @t{-1}, @t{0}, or @t{1} according to whether @i{number} is negative, zero, or positive. For a @i{float}, the result is a @i{float} of the same format whose value is minus one, zero, or one. For a @i{complex} number @t{z}, @t{(signum @i{z})} is a complex number of the same phase but with unit magnitude, unless @t{z} is a complex zero, in which case the result is @t{z}. For @i{rational} @i{arguments}, @b{signum} is a rational function, but it may be irrational for @i{complex} @i{arguments}. If @i{number} is a @i{float}, the result is a @i{float}. If @i{number} is a @i{rational}, the result is a @i{rational}. If @i{number} is a @i{complex float}, the result is a @i{complex float}. If @i{number} is a @i{complex rational}, the result is a @i{complex}, but it is @i{implementation-dependent} whether that result is a @i{complex rational} or a @i{complex float}. @subsubheading Examples:: @example (signum 0) @result{} 0 (signum 99) @result{} 1 (signum 4/5) @result{} 1 (signum -99/100) @result{} -1 (signum 0.0) @result{} 0.0 (signum #c(0 33)) @result{} #C(0.0 1.0) (signum #c(7.5 10.0)) @result{} #C(0.6 0.8) (signum #c(0.0 -14.7)) @result{} #C(0.0 -1.0) (eql (signum -0.0) -0.0) @result{} @i{true} @end example @subsubheading See Also:: @ref{Rule of Float Substitutability} @subsubheading Notes:: @example (signum x) @equiv{} (if (zerop x) x (/ x (abs x))) @end example @node sqrt, random-state, signum, Numbers Dictionary @subsection sqrt, isqrt [Function] @code{sqrt} @i{number} @result{} @i{root} @code{isqrt} @i{natural} @result{} @i{natural-root} @subsubheading Arguments and Values:: @i{number}, @i{root}---a @i{number}. @i{natural}, @i{natural-root}---a non-negative @i{integer}. @subsubheading Description:: @b{sqrt} and @b{isqrt} compute square roots. @b{sqrt} returns the @i{principal} square root of @i{number}. If the @i{number} is not a @i{complex} but is negative, then the result is a @i{complex}. @b{isqrt} returns the greatest @i{integer} less than or equal to the exact positive square root of @i{natural}. If @i{number} is a positive @i{rational}, it is @i{implementation-dependent} whether @i{root} is a @i{rational} or a @i{float}. If @i{number} is a negative @i{rational}, it is @i{implementation-dependent} whether @i{root} is a @i{complex rational} or a @i{complex float}. The mathematical definition of complex square root (whether or not minus zero is supported) follows: @t{(sqrt @i{x}) = (exp (/ (log @i{x}) 2))} The branch cut for square root lies along the negative real axis, continuous with quadrant II. The range consists of the right half-plane, including the non-negative imaginary axis and excluding the negative imaginary axis. @subsubheading Examples:: @example (sqrt 9.0) @result{} 3.0 (sqrt -9.0) @result{} #C(0.0 3.0) (isqrt 9) @result{} 3 (sqrt 12) @result{} 3.4641016 (isqrt 12) @result{} 3 (isqrt 300) @result{} 17 (isqrt 325) @result{} 18 (sqrt 25) @result{} 5 @i{OR}@result{} 5.0 (isqrt 25) @result{} 5 (sqrt -1) @result{} #C(0.0 1.0) (sqrt #c(0 2)) @result{} #C(1.0 1.0) @end example @subsubheading Exceptional Situations:: The @i{function} @b{sqrt} should signal @b{type-error} if its argument is not a @i{number}. The @i{function} @b{isqrt} should signal @b{type-error} if its argument is not a non-negative @i{integer}. The functions @b{sqrt} and @b{isqrt} might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{exp} , @ref{log} , @ref{Rule of Float Substitutability} @subsubheading Notes:: @example (isqrt x) @equiv{} (values (floor (sqrt x))) @end example but it is potentially more efficient. @node random-state, make-random-state, sqrt, Numbers Dictionary @subsection random-state [System Class] @subsubheading Class Precedence List:: @b{random-state}, @b{t} @subsubheading Description:: A @i{random state} @i{object} contains state information used by the pseudo-random number generator. The nature of a @i{random state} @i{object} is @i{implementation-dependent}. It can be printed out and successfully read back in by the same @i{implementation}, but might not function correctly as a @i{random state} in another @i{implementation}. @i{Implementations} are required to provide a read syntax for @i{objects} of @i{type} @b{random-state}, but the specific nature of that syntax is @i{implementation-dependent}. @subsubheading See Also:: @ref{random-state} , @ref{random} , @ref{Printing Random States} @node make-random-state, random, random-state, Numbers Dictionary @subsection make-random-state [Function] @code{make-random-state} @i{@r{&optional} state} @result{} @i{new-state} @subsubheading Arguments and Values:: @i{state}---a @i{random state}, or @b{nil}, or @b{t}. The default is @b{nil}. @i{new-state}---a @i{random state} @i{object}. @subsubheading Description:: Creates a @i{fresh} @i{object} of @i{type} @b{random-state} suitable for use as the @i{value} of @b{*random-state*}. If @i{state} is a @i{random state} @i{object}, the @i{new-state} is a @i{copy}_5 of that @i{object}. If @i{state} is @b{nil}, the @i{new-state} is a @i{copy}_5 of the @i{current random state}. If @i{state} is @b{t}, the @i{new-state} is a @i{fresh} @i{random state} @i{object} that has been randomly initialized by some means. @subsubheading Examples:: @example (let* ((rs1 (make-random-state nil)) (rs2 (make-random-state t)) (rs3 (make-random-state rs2)) (rs4 nil)) (list (loop for i from 1 to 10 collect (random 100) when (= i 5) do (setq rs4 (make-random-state))) (loop for i from 1 to 10 collect (random 100 rs1)) (loop for i from 1 to 10 collect (random 100 rs2)) (loop for i from 1 to 10 collect (random 100 rs3)) (loop for i from 1 to 10 collect (random 100 rs4)))) @result{} ((29 25 72 57 55 68 24 35 54 65) (29 25 72 57 55 68 24 35 54 65) (93 85 53 99 58 62 2 23 23 59) (93 85 53 99 58 62 2 23 23 59) (68 24 35 54 65 54 55 50 59 49)) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{state} is not a @i{random state}, or @b{nil}, or @b{t}. @subsubheading See Also:: @ref{random} , @ref{random-state} @subsubheading Notes:: One important use of @b{make-random-state} is to allow the same series of pseudo-random @i{numbers} to be generated many times within a single program. @node random, random-state-p, make-random-state, Numbers Dictionary @subsection random [Function] @code{random} @i{limit @r{&optional} random-state} @result{} @i{random-number} @subsubheading Arguments and Values:: @i{limit}---a positive @i{integer}, or a positive @i{float}. @i{random-state}---a @i{random state}. The default is the @i{current random state}. @i{random-number}---a non-negative @i{number} less than @i{limit} and of the same @i{type} as @i{limit}. @subsubheading Description:: Returns a pseudo-random number that is a non-negative @i{number} less than @i{limit} and of the same @i{type} as @i{limit}. The @i{random-state}, which is modified by this function, encodes the internal state maintained by the random number generator. An approximately uniform choice distribution is used. If @i{limit} is an @i{integer}, each of the possible results occurs with (approximate) probability 1/@i{limit}. @subsubheading Examples:: @example (<= 0 (random 1000) 1000) @result{} @i{true} (let ((state1 (make-random-state)) (state2 (make-random-state))) (= (random 1000 state1) (random 1000 state2))) @result{} @i{true} @end example @subsubheading Side Effects:: The @i{random-state} is modified. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{limit} is not a positive @i{integer} or a positive @i{real}. @subsubheading See Also:: @ref{make-random-state} , @ref{random-state} @subsubheading Notes:: See @i{Common Lisp: The Language} for information about generating random numbers. @node random-state-p, *random-state*, random, Numbers Dictionary @subsection random-state-p [Function] @code{random-state-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{random-state}; otherwise, returns @i{false}. @subsubheading Examples:: @example (random-state-p *random-state*) @result{} @i{true} (random-state-p (make-random-state)) @result{} @i{true} (random-state-p 'test-function) @result{} @i{false} @end example @subsubheading See Also:: @ref{make-random-state} , @ref{random-state} @subsubheading Notes:: @example (random-state-p @i{object}) @equiv{} (typep @i{object} 'random-state) @end example @node *random-state*, numberp, random-state-p, Numbers Dictionary @subsection *random-state* [Variable] @subsubheading Value Type:: a @i{random state}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{current random state}, which is used, for example, by the @i{function} @b{random} when a @i{random state} is not explicitly supplied. @subsubheading Examples:: @example (random-state-p *random-state*) @result{} @i{true} (setq snap-shot (make-random-state)) ;; The series from any given point is random, ;; but if you backtrack to that point, you get the same series. (list (loop for i from 1 to 10 collect (random)) (let ((*random-state* snap-shot)) (loop for i from 1 to 10 collect (random))) (loop for i from 1 to 10 collect (random)) (let ((*random-state* snap-shot)) (loop for i from 1 to 10 collect (random)))) @result{} ((19 16 44 19 96 15 76 96 13 61) (19 16 44 19 96 15 76 96 13 61) (16 67 0 43 70 79 58 5 63 50) (16 67 0 43 70 79 58 5 63 50)) @end example @subsubheading Affected By:: The @i{implementation}. @b{random}. @subsubheading See Also:: @ref{make-random-state} , @ref{random} , @b{random-state} @subsubheading Notes:: @i{Binding} @b{*random-state*} to a different @i{random state} @i{object} correctly saves and restores the old @i{random state} @i{object}. @node numberp, cis, *random-state*, Numbers Dictionary @subsection numberp [Function] @code{numberp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{number}; otherwise, returns @i{false}. @subsubheading Examples:: @example (numberp 12) @result{} @i{true} (numberp (expt 2 130)) @result{} @i{true} (numberp #c(5/3 7.2)) @result{} @i{true} (numberp nil) @result{} @i{false} (numberp (cons 1 2)) @result{} @i{false} @end example @subsubheading Notes:: @example (numberp @i{object}) @equiv{} (typep @i{object} 'number) @end example @node cis, complex, numberp, Numbers Dictionary @subsection cis [Function] @code{cis} @i{radians} @result{} @i{number} @subsubheading Arguments and Values:: @i{radians}---a @i{real}. @i{number}---a @i{complex}. @subsubheading Description:: @b{cis} returns the value of~@i{e}^@i{i\cdot @i{radians}}, which is a @i{complex} in which the real part is equal to the cosine of @i{radians}, and the imaginary part is equal to the sine of @i{radians}. @subsubheading Examples:: @example (cis 0) @result{} #C(1.0 0.0) @end example @subsubheading See Also:: @ref{Rule of Float Substitutability} @node complex, complexp, cis, Numbers Dictionary @subsection complex [Function] @code{complex} @i{realpart @r{&optional} imagpart} @result{} @i{complex} @subsubheading Arguments and Values:: @i{realpart}---a @i{real}. @i{imagpart}---a @i{real}. @i{complex}---a @i{rational} or a @i{complex}. @subsubheading Description:: @b{complex} returns a @i{number} whose real part is @i{realpart} and whose imaginary part is @i{imagpart}. If @i{realpart} is a @i{rational} and @i{imagpart} is the @i{rational} number zero, the result of @b{complex} is @i{realpart}, a @i{rational}. Otherwise, the result is a @i{complex}. If either @i{realpart} or @i{imagpart} is a @i{float}, the non-@i{float} is converted to a @i{float} before the @i{complex} is created. If @i{imagpart} is not supplied, the imaginary part is a zero of the same @i{type} as @i{realpart}; @i{i.e.}, @t{(coerce 0 (type-of @i{realpart}))} is effectively used. Type upgrading implies a movement upwards in the type hierarchy lattice. In the case of @i{complexes}, the @i{type-specifier} [Reviewer Note by Barmar: What type specifier?] must be a subtype of @t{(upgraded-complex-part-type @i{type-specifier})}. If @i{type-specifier1} is a subtype of @i{type-specifier2}, then @t{(upgraded-complex-element-type '@i{type-specifier1})} must also be a subtype of @t{(upgraded-complex-element-type '@i{type-specifier2})}. Two disjoint types can be upgraded into the same thing. @subsubheading Examples:: @example (complex 0) @result{} 0 (complex 0.0) @result{} #C(0.0 0.0) (complex 1 1/2) @result{} #C(1 1/2) (complex 1 .99) @result{} #C(1.0 0.99) (complex 3/2 0.0) @result{} #C(1.5 0.0) @end example @subsubheading See Also:: @ref{realpart} , @b{imagpart} @subsubheading Notes:: @example #c(a b) @equiv{} #.(complex a b) @end example @node complexp, conjugate, complex, Numbers Dictionary @subsection complexp [Function] @code{complexp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{complex}; otherwise, returns @i{false}. @subsubheading Examples:: @example (complexp 1.2d2) @result{} @i{false} (complexp #c(5/3 7.2)) @result{} @i{true} @end example @subsubheading See Also:: @ref{complex} (@i{function} and @i{type}), @ref{typep} @subsubheading Notes:: @example (complexp @i{object}) @equiv{} (typep @i{object} 'complex) @end example @node conjugate, phase, complexp, Numbers Dictionary @subsection conjugate [Function] @code{conjugate} @i{number} @result{} @i{conjugate} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{conjugate}---a @i{number}. @subsubheading Description:: Returns the complex conjugate of @i{number}. The conjugate of a @i{real} number is itself. @subsubheading Examples:: @example (conjugate #c(0 -1)) @result{} #C(0 1) (conjugate #c(1 1)) @result{} #C(1 -1) (conjugate 1.5) @result{} 1.5 (conjugate #C(3/5 4/5)) @result{} #C(3/5 -4/5) (conjugate #C(0.0D0 -1.0D0)) @result{} #C(0.0D0 1.0D0) (conjugate 3.7) @result{} 3.7 @end example @subsubheading Notes:: For a @i{complex} number @t{z}, @example (conjugate z) @equiv{} (complex (realpart z) (- (imagpart z))) @end example @node phase, realpart, conjugate, Numbers Dictionary @subsection phase [Function] @code{phase} @i{number} @result{} @i{phase} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{phase}---a @i{number}. @subsubheading Description:: @b{phase} returns the phase of @i{number} (the angle part of its polar representation) in radians, in the range -\pi (exclusive) if minus zero is not supported, or -\pi (inclusive) if minus zero is supported, to \pi (inclusive). The phase of a positive @i{real} number is zero; that of a negative @i{real} number is \pi. The phase of zero is defined to be zero. If @i{number} is a @i{complex float}, the result is a @i{float} of the same @i{type} as the components of @i{number}. If @i{number} is a @i{float}, the result is a @i{float} of the same @i{type}. If @i{number} is a @i{rational} or a @i{complex rational}, the result is a @i{single float}. The branch cut for @b{phase} lies along the negative real axis, continuous with quadrant II. The range consists of that portion of the real axis between -\pi (exclusive) and~\pi (inclusive). The mathematical definition of @b{phase} is as follows: @t{(phase @i{x}) = (atan (imagpart @i{x}) (realpart @i{x}))} @subsubheading Examples:: @example (phase 1) @result{} 0.0s0 (phase 0) @result{} 0.0s0 (phase (cis 30)) @result{} -1.4159266 (phase #c(0 1)) @result{} 1.5707964 @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its argument is not a @i{number}. Might signal @b{arithmetic-error}. @subsubheading See Also:: @ref{Rule of Float Substitutability} @node realpart, upgraded-complex-part-type, phase, Numbers Dictionary @subsection realpart, imagpart [Function] @code{realpart} @i{number} @result{} @i{real} @code{imagpart} @i{number} @result{} @i{real} @subsubheading Arguments and Values:: @i{number}---a @i{number}. @i{real}---a @i{real}. @subsubheading Description:: @b{realpart} and @b{imagpart} return the real and imaginary parts of @i{number} respectively. If @i{number} is @i{real}, then @b{realpart} returns @i{number} and @b{imagpart} returns @t{(* 0 @i{number})}, which has the effect that the imaginary part of a @i{rational} is @t{0} and that of a @i{float} is a floating-point zero of the same format. @subsubheading Examples:: @example (realpart #c(23 41)) @result{} 23 (imagpart #c(23 41.0)) @result{} 41.0 (realpart #c(23 41.0)) @result{} 23.0 (imagpart 23.0) @result{} 0.0 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{number} is not a @i{number}. @subsubheading See Also:: @ref{complex} @node upgraded-complex-part-type, realp, realpart, Numbers Dictionary @subsection upgraded-complex-part-type [Function] @code{upgraded-complex-part-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} @subsubheading Arguments and Values:: @i{typespec}---a @i{type specifier}. @i{environment}---an @i{environment} @i{object}. The default is @b{nil}, denoting the @i{null lexical environment} and the and current @i{global environment}. @i{upgraded-typespec}---a @i{type specifier}. @subsubheading Description:: @b{upgraded-complex-part-type} returns the part type of the most specialized @i{complex} number representation that can hold parts of @i{type} @i{typespec}. The @i{typespec} is a @i{subtype} of (and possibly @i{type equivalent} to) the @i{upgraded-typespec}. The purpose of @b{upgraded-complex-part-type} is to reveal how an implementation does its @i{upgrading}. @subsubheading See Also:: @ref{complex} (@i{function} and @i{type}) @subsubheading Notes:: @node realp, numerator, upgraded-complex-part-type, Numbers Dictionary @subsection realp [Function] @code{realp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{real}; otherwise, returns @i{false}. @subsubheading Examples:: @example (realp 12) @result{} @i{true} (realp #c(5/3 7.2)) @result{} @i{false} (realp nil) @result{} @i{false} (realp (cons 1 2)) @result{} @i{false} @end example @subsubheading Notes:: @example (realp @i{object}) @equiv{} (typep @i{object} 'real) @end example @node numerator, rational (Function), realp, Numbers Dictionary @subsection numerator, denominator [Function] @code{numerator} @i{rational} @result{} @i{numerator} @code{denominator} @i{rational} @result{} @i{denominator} @subsubheading Arguments and Values:: @i{rational}---a @i{rational}. @i{numerator}---an @i{integer}. @i{denominator}---a positive @i{integer}. @subsubheading Description:: @b{numerator} and @b{denominator} reduce @i{rational} to canonical form and compute the numerator or denominator of that number. @b{numerator} and @b{denominator} return the numerator or denominator of the canonical form of @i{rational}. If @i{rational} is an @i{integer}, @b{numerator} returns @i{rational} and @b{denominator} returns 1. @subsubheading Examples:: @example (numerator 1/2) @result{} 1 (denominator 12/36) @result{} 3 (numerator -1) @result{} -1 (denominator (/ -33)) @result{} 33 (numerator (/ 8 -6)) @result{} -4 (denominator (/ 8 -6)) @result{} 3 @end example @subsubheading See Also:: @ref{/} @subsubheading Notes:: @example (gcd (numerator x) (denominator x)) @result{} 1 @end example @node rational (Function), rationalp, numerator, Numbers Dictionary @subsection rational, rationalize [Function] @code{rational} @i{number} @result{} @i{rational} @code{rationalize} @i{number} @result{} @i{rational} @subsubheading Arguments and Values:: @i{number}---a @i{real}. @i{rational}---a @i{rational}. @subsubheading Description:: @b{rational} and @b{rationalize} convert @i{reals} to @i{rationals}. If @i{number} is already @i{rational}, it is returned. If @i{number} is a @i{float}, @b{rational} returns a @i{rational} that is mathematically equal in value to the @i{float}. @b{rationalize} returns a @i{rational} that approximates the @i{float} to the accuracy of the underlying floating-point representation. @b{rational} assumes that the @i{float} is completely accurate. @b{rationalize} assumes that the @i{float} is accurate only to the precision of the floating-point representation. @subsubheading Examples:: @example (rational 0) @result{} 0 (rationalize -11/100) @result{} -11/100 (rational .1) @result{} 13421773/134217728 ;implementation-dependent (rationalize .1) @result{} 1/10 @end example @subsubheading Affected By:: The @i{implementation}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{number} is not a @i{real}. Might signal @b{arithmetic-error}. @subsubheading Notes:: It is always the case that @example (float (rational x) x) @equiv{} x @end example and @example (float (rationalize x) x) @equiv{} x @end example That is, rationalizing a @i{float} by either method and then converting it back to a @i{float} of the same format produces the original @i{number}. @node rationalp, ash, rational (Function), Numbers Dictionary @subsection rationalp [Function] @code{rationalp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{rational}; otherwise, returns @i{false}. @subsubheading Examples:: @example (rationalp 12) @result{} @i{true} (rationalp 6/5) @result{} @i{true} (rationalp 1.212) @result{} @i{false} @end example @subsubheading See Also:: @ref{rational (Function)} @subsubheading Notes:: @example (rationalp @i{object}) @equiv{} (typep @i{object} 'rational) @end example @node ash, integer-length, rationalp, Numbers Dictionary @subsection ash [Function] @code{ash} @i{integer count} @result{} @i{shifted-integer} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{count}---an @i{integer}. @i{shifted-integer}---an @i{integer}. @subsubheading Description:: @b{ash} performs the arithmetic shift operation on the binary representation of @i{integer}, which is treated as if it were binary. @b{ash} shifts @i{integer} arithmetically left by @i{count} bit positions if @i{count} is positive, or right @i{count} bit positions if @i{count} is negative. The shifted value of the same sign as @i{integer} is returned. Mathematically speaking, @b{ash} performs the computation @t{floor}(@i{integer}\cdot 2^@i{count}). Logically, @b{ash} moves all of the bits in @i{integer} to the left, adding zero-bits at the right, or moves them to the right, discarding bits. @b{ash} is defined to behave as if @i{integer} were represented in two's complement form, regardless of how @i{integers} are represented internally. @subsubheading Examples:: @example (ash 16 1) @result{} 32 (ash 16 0) @result{} 16 (ash 16 -1) @result{} 8 (ash -100000000000000000000000000000000 -100) @result{} -79 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{integer} is not an @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{count} is not an @i{integer}. Might signal @b{arithmetic-error}. @subsubheading Notes:: @example (logbitp @i{j} (ash @i{n} @i{k})) @equiv{} (and (>= @i{j} @i{k}) (logbitp (- @i{j} @i{k}) @i{n})) @end example @node integer-length, integerp, ash, Numbers Dictionary @subsection integer-length [Function] @code{integer-length} @i{integer} @result{} @i{number-of-bits} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{number-of-bits}---a non-negative @i{integer}. @subsubheading Description:: Returns the number of bits needed to represent @i{integer} in binary two's-complement format. @subsubheading Examples:: @example (integer-length 0) @result{} 0 (integer-length 1) @result{} 1 (integer-length 3) @result{} 2 (integer-length 4) @result{} 3 (integer-length 7) @result{} 3 (integer-length -1) @result{} 0 (integer-length -4) @result{} 2 (integer-length -7) @result{} 3 (integer-length -8) @result{} 3 (integer-length (expt 2 9)) @result{} 10 (integer-length (1- (expt 2 9))) @result{} 9 (integer-length (- (expt 2 9))) @result{} 9 (integer-length (- (1+ (expt 2 9)))) @result{} 10 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{integer} is not an @i{integer}. @subsubheading Notes:: This function could have been defined by: @example (defun integer-length (integer) (ceiling (log (if (minusp integer) (- integer) (1+ integer)) 2))) @end example If @i{integer} is non-negative, then its value can be represented in unsigned binary form in a field whose width in bits is no smaller than @t{(integer-length @i{integer})}. Regardless of the sign of @i{integer}, its value can be represented in signed binary two's-complement form in a field whose width in bits is no smaller than @t{(+ (integer-length @i{integer}) 1)}. @node integerp, parse-integer, integer-length, Numbers Dictionary @subsection integerp [Function] @code{integerp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{integer}; otherwise, returns @i{false}. @subsubheading Examples:: @example (integerp 1) @result{} @i{true} (integerp (expt 2 130)) @result{} @i{true} (integerp 6/5) @result{} @i{false} (integerp nil) @result{} @i{false} @end example @subsubheading Notes:: @example (integerp @i{object}) @equiv{} (typep @i{object} 'integer) @end example @node parse-integer, boole, integerp, Numbers Dictionary @subsection parse-integer [Function] @code{parse-integer} @i{string @r{&key} start end radix junk-allowed} @result{} @i{integer, pos} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{radix}---a @i{radix}. The default is @t{10}. @i{junk-allowed}---a @i{generalized boolean}. The default is @i{false}. @i{integer}---an @i{integer} or @i{false}. @i{pos}---a @i{bounding index} of @i{string}. @subsubheading Description:: @b{parse-integer} parses an @i{integer} in the specified @i{radix} from the substring of @i{string} delimited by @i{start} and @i{end}. @b{parse-integer} expects an optional sign (@t{+} or @t{-}) followed by a a non-empty sequence of digits to be interpreted in the specified @i{radix}. Optional leading and trailing @i{whitespace}_1 is ignored. @b{parse-integer} does not recognize the syntactic radix-specifier prefixes @t{#O}, @t{#B}, @t{#X}, and @t{#@i{n}R}, nor does it recognize a trailing decimal point. If @i{junk-allowed} is @i{false}, an error of @i{type} @b{parse-error} is signaled if substring does not consist entirely of the representation of a signed @i{integer}, possibly surrounded on either side by @i{whitespace}_1 @i{characters}. The first @i{value} returned is either the @i{integer} that was parsed, or else @b{nil} if no syntactically correct @i{integer} was seen but @i{junk-allowed} was @i{true}. The second @i{value} is either the index into the @i{string} of the delimiter that terminated the parse, or the upper @i{bounding index} of the substring if the parse terminated at the end of the substring (as is always the case if @i{junk-allowed} is @i{false}). @subsubheading Examples:: @example (parse-integer "123") @result{} 123, 3 (parse-integer "123" :start 1 :radix 5) @result{} 13, 3 (parse-integer "no-integer" :junk-allowed t) @result{} NIL, 0 @end example @subsubheading Exceptional Situations:: If @i{junk-allowed} is @i{false}, an error is signaled if substring does not consist entirely of the representation of an @i{integer}, possibly surrounded on either side by @i{whitespace}_1 characters. @node boole, boole-1, parse-integer, Numbers Dictionary @subsection boole [Function] @code{boole} @i{op integer-1 integer-2} @result{} @i{result-integer} @subsubheading Arguments and Values:: @i{Op}---a @i{bit-wise logical operation specifier}. @i{integer-1}---an @i{integer}. @i{integer-2}---an @i{integer}. @i{result-integer}---an @i{integer}. @subsubheading Description:: @b{boole} performs bit-wise logical operations on @i{integer-1} and @i{integer-2}, which are treated as if they were binary and in two's complement representation. The operation to be performed and the return value are determined by @i{op}. @b{boole} returns the values specified for any @i{op} in Figure 12--16. @format @group @noindent @w{ Op Result } @w{ @b{boole-1} @i{integer-1} } @w{ @b{boole-2} @i{integer-2} } @w{ @b{boole-andc1} and complement of @i{integer-1} with @i{integer-2} } @w{ @b{boole-andc2} and @i{integer-1} with complement of @i{integer-2} } @w{ @b{boole-and} and } @w{ @b{boole-c1} complement of @i{integer-1} } @w{ @b{boole-c2} complement of @i{integer-2} } @w{ @b{boole-clr} always 0 (all zero bits) } @w{ @b{boole-eqv} equivalence (exclusive nor) } @w{ @b{boole-ior} inclusive or } @w{ @b{boole-nand} not-and } @w{ @b{boole-nor} not-or } @w{ @b{boole-orc1} or complement of @i{integer-1} with @i{integer-2} } @w{ @b{boole-orc2} or @i{integer-1} with complement of @i{integer-2} } @w{ @b{boole-set} always -1 (all one bits) } @w{ @b{boole-xor} exclusive or } @noindent @w{ Figure 12--16: Bit-Wise Logical Operations } @end group @end format @subsubheading Examples:: @example (boole boole-ior 1 16) @result{} 17 (boole boole-and -2 5) @result{} 4 (boole boole-eqv 17 15) @result{} -31 ;;; These examples illustrate the result of applying BOOLE and each ;;; of the possible values of OP to each possible combination of bits. (progn (format t "~&Results of (BOOLE #b0011 #b0101) ...~ ~ (dolist (symbol '(boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) (let ((result (boole (symbol-value symbol) #b0011 #b0101))) (format t "~& ~A~13T~3,' D~23T~:*~5,' B~31T ...~4,'0B~ symbol result (logand result #b1111))))) @t{ |> } Results of (BOOLE #b0011 #b0101) ... @t{ |> } ---Op-------Decimal-----Binary----Bits--- @t{ |> } BOOLE-1 3 11 ...0011 @t{ |> } BOOLE-2 5 101 ...0101 @t{ |> } BOOLE-AND 1 1 ...0001 @t{ |> } BOOLE-ANDC1 4 100 ...0100 @t{ |> } BOOLE-ANDC2 2 10 ...0010 @t{ |> } BOOLE-C1 -4 -100 ...1100 @t{ |> } BOOLE-C2 -6 -110 ...1010 @t{ |> } BOOLE-CLR 0 0 ...0000 @t{ |> } BOOLE-EQV -7 -111 ...1001 @t{ |> } BOOLE-IOR 7 111 ...0111 @t{ |> } BOOLE-NAND -2 -10 ...1110 @t{ |> } BOOLE-NOR -8 -1000 ...1000 @t{ |> } BOOLE-ORC1 -3 -11 ...1101 @t{ |> } BOOLE-ORC2 -5 -101 ...1011 @t{ |> } BOOLE-SET -1 -1 ...1111 @t{ |> } BOOLE-XOR 6 110 ...0110 @result{} NIL @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its first argument is not a @i{bit-wise logical operation specifier} or if any subsequent argument is not an @i{integer}. @subsubheading See Also:: @ref{logand} @subsubheading Notes:: In general, @example (boole boole-and x y) @equiv{} (logand x y) @end example @i{Programmers} who would prefer to use numeric indices rather than @i{bit-wise logical operation specifiers} can get an equivalent effect by a technique such as the following: @example ;; The order of the values in this `table' are such that ;; (logand (boole (elt boole-n-vector n) #b0101 #b0011) #b1111) => n (defconstant boole-n-vector (vector boole-clr boole-and boole-andc1 boole-2 boole-andc2 boole-1 boole-xor boole-ior boole-nor boole-eqv boole-c1 boole-orc1 boole-c2 boole-orc2 boole-nand boole-set)) @result{} BOOLE-N-VECTOR (proclaim '(inline boole-n)) @result{} @i{implementation-dependent} (defun boole-n (n integer &rest more-integers) (apply #'boole (elt boole-n-vector n) integer more-integers)) @result{} BOOLE-N (boole-n #b0111 5 3) @result{} 7 (boole-n #b0001 5 3) @result{} 1 (boole-n #b1101 5 3) @result{} -3 (loop for n from #b0000 to #b1111 collect (boole-n n 5 3)) @result{} (0 1 2 3 4 5 6 7 -8 -7 -6 -5 -4 -3 -2 -1) @end example @node boole-1, logand, boole, Numbers Dictionary @subsection boole-1, boole-2, boole-and, boole-andc1, boole-andc2, @subheading boole-c1, boole-c2, boole-clr, boole-eqv, boole-ior, @subheading boole-nand, boole-nor, boole-orc1, boole-orc2, boole-set, @subheading boole-xor @flushright @i{[Constant Variable]} @end flushright @subsubheading Constant Value:: The identity and nature of the @i{values} of each of these @i{variables} is @i{implementation-dependent}, except that it must be @i{distinct} from each of the @i{values} of the others, and it must be a valid first @i{argument} to the @i{function} @b{boole}. @subsubheading Description:: Each of these @i{constants} has a @i{value} which is one of the sixteen possible @i{bit-wise logical operation specifiers}. @subsubheading Examples:: @example (boole boole-ior 1 16) @result{} 17 (boole boole-and -2 5) @result{} 4 (boole boole-eqv 17 15) @result{} -31 @end example @subsubheading See Also:: @ref{boole} @node logand, logbitp, boole-1, Numbers Dictionary @subsection logand, logandc1, logandc2, logeqv, logior, @subheading lognand, lognor, lognot, logorc1, logorc2, @subheading logxor @flushright @i{[Function]} @end flushright @code{logand} @i{@r{&rest} integers} @result{} @i{result-integer} @code{logandc} @i{1} @result{} @i{integer-1 integer-2} @r{result-integer} @code{logandc} @i{2} @result{} @i{integer-1 integer-2} @r{result-integer} @code{logeqv} @i{@r{&rest} integers} @result{} @i{result-integer} @code{logior} @i{@r{&rest} integers} @result{} @i{result-integer} @code{lognand} @i{integer-1 integer-2} @result{} @i{result-integer} @code{lognor} @i{integer-1 integer-2} @result{} @i{result-integer} @code{lognot} @i{integer} @result{} @i{result-integer} @code{logorc} @i{1} @result{} @i{integer-1 integer-2} @r{result-integer} @code{logorc} @i{2} @result{} @i{integer-1 integer-2} @r{result-integer} @code{logxor} @i{@r{&rest} integers} @result{} @i{result-integer} @subsubheading Arguments and Values:: @i{integers}---@i{integers}. @i{integer}---an @i{integer}. @i{integer-1}---an @i{integer}. @i{integer-2}---an @i{integer}. @i{result-integer}---an @i{integer}. @subsubheading Description:: The @i{functions} @b{logandc1}, @b{logandc2}, @b{logand}, @b{logeqv}, @b{logior}, @b{lognand}, @b{lognor}, @b{lognot}, @b{logorc1}, @b{logorc2}, and @b{logxor} perform bit-wise logical operations on their @i{arguments}, that are treated as if they were binary. Figure 12--17 lists the meaning of each of the @i{functions}. Where an `identity' is shown, it indicates the @i{value} @i{yielded} by the @i{function} when no @i{arguments} are supplied. @format @group @noindent @w{ Function Identity Operation performed } @w{ @b{logandc1} --- and complement of @i{integer-1} with @i{integer-2} } @w{ @b{logandc2} --- and @i{integer-1} with complement of @i{integer-2} } @w{ @b{logand} @t{-1} and } @w{ @b{logeqv} @t{-1} equivalence (exclusive nor) } @w{ @b{logior} @t{0} inclusive or } @w{ @b{lognand} --- complement of @i{integer-1} and @i{integer-2} } @w{ @b{lognor} --- complement of @i{integer-1} or @i{integer-2} } @w{ @b{lognot} --- complement } @w{ @b{logorc1} --- or complement of @i{integer-1} with @i{integer-2} } @w{ @b{logorc2} --- or @i{integer-1} with complement of @i{integer-2} } @w{ @b{logxor} @t{0} exclusive or } @noindent @w{ Figure 12--17: Bit-wise Logical Operations on Integers } @end group @end format Negative @i{integers} are treated as if they were in two's-complement notation. @subsubheading Examples:: @example (logior 1 2 4 8) @result{} 15 (logxor 1 3 7 15) @result{} 10 (logeqv) @result{} -1 (logand 16 31) @result{} 16 (lognot 0) @result{} -1 (lognot 1) @result{} -2 (lognot -1) @result{} 0 (lognot (1+ (lognot 1000))) @result{} 999 ;;; In the following example, m is a mask. For each bit in ;;; the mask that is a 1, the corresponding bits in x and y are ;;; exchanged. For each bit in the mask that is a 0, the ;;; corresponding bits of x and y are left unchanged. (flet ((show (m x y) (format t "~ m x y))) (let ((m #o007750) (x #o452576) (y #o317407)) (show m x y) (let ((z (logand (logxor x y) m))) (setq x (logxor z x)) (setq y (logxor z y)) (show m x y)))) @t{ |> } m = #o007750 @t{ |> } x = #o452576 @t{ |> } y = #o317407 @t{ |> } @t{ |> } m = #o007750 @t{ |> } x = #o457426 @t{ |> } y = #o312557 @result{} NIL @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if any argument is not an @i{integer}. @subsubheading See Also:: @ref{boole} @subsubheading Notes:: @t{(logbitp @i{k} -1)} returns @i{true} for all values of @i{k}. Because the following functions are not associative, they take exactly two arguments rather than any number of arguments. @example (lognand @i{n1} @i{n2}) @equiv{} (lognot (logand @i{n1} @i{n2})) (lognor @i{n1} @i{n2}) @equiv{} (lognot (logior @i{n1} @i{n2})) (logandc1 @i{n1} @i{n2}) @equiv{} (logand (lognot @i{n1}) @i{n2}) (logandc2 @i{n1} @i{n2}) @equiv{} (logand @i{n1} (lognot @i{n2})) (logiorc1 @i{n1} @i{n2}) @equiv{} (logior (lognot @i{n1}) @i{n2}) (logiorc2 @i{n1} @i{n2}) @equiv{} (logior @i{n1} (lognot @i{n2})) (logbitp @i{j} (lognot @i{x})) @equiv{} (not (logbitp @i{j} @i{x})) @end example @node logbitp, logcount, logand, Numbers Dictionary @subsection logbitp [Function] @code{logbitp} @i{index integer} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{index}---a non-negative @i{integer}. @i{integer}---an @i{integer}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{logbitp} is used to test the value of a particular bit in @i{integer}, that is treated as if it were binary. The value of @b{logbitp} is @i{true} if the bit in @i{integer} whose index is @i{index} (that is, its weight is 2^@i{index}) is a one-bit; otherwise it is @i{false}. Negative @i{integers} are treated as if they were in two's-complement notation. @subsubheading Examples:: @example (logbitp 1 1) @result{} @i{false} (logbitp 0 1) @result{} @i{true} (logbitp 3 10) @result{} @i{true} (logbitp 1000000 -1) @result{} @i{true} (logbitp 2 6) @result{} @i{true} (logbitp 0 6) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{index} is not a non-negative @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{integer} is not an @i{integer}. @subsubheading Notes:: @example (logbitp @i{k} @i{n}) @equiv{} (ldb-test (byte 1 @i{k}) @i{n}) @end example @node logcount, logtest, logbitp, Numbers Dictionary @subsection logcount [Function] @code{logcount} @i{integer} @result{} @i{number-of-on-bits} @subsubheading Arguments and Values:: @i{integer}---an @i{integer}. @i{number-of-on-bits}---a non-negative @i{integer}. @subsubheading Description:: Computes and returns the number of bits in the two's-complement binary representation of @i{integer} that are `on' or `set'. If @i{integer} is negative, the @t{0} bits are counted; otherwise, the @t{1} bits are counted. @subsubheading Examples:: @example (logcount 0) @result{} 0 (logcount -1) @result{} 0 (logcount 7) @result{} 3 (logcount 13) @result{} 3 ;Two's-complement binary: ...0001101 (logcount -13) @result{} 2 ;Two's-complement binary: ...1110011 (logcount 30) @result{} 4 ;Two's-complement binary: ...0011110 (logcount -30) @result{} 4 ;Two's-complement binary: ...1100010 (logcount (expt 2 100)) @result{} 1 (logcount (- (expt 2 100))) @result{} 100 (logcount (- (1+ (expt 2 100)))) @result{} 1 @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its argument is not an @i{integer}. @subsubheading Notes:: Even if the @i{implementation} does not represent @i{integers} internally in two's complement binary, @b{logcount} behaves as if it did. The following identity always holds: @example (logcount @i{x}) @equiv{} (logcount (- (+ @i{x} 1))) @equiv{} (logcount (lognot @i{x})) @end example @node logtest, byte, logcount, Numbers Dictionary @subsection logtest [Function] @code{logtest} @i{integer-1 integer-2} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{integer-1}---an @i{integer}. @i{integer-2}---an @i{integer}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if any of the bits designated by the 1's in @i{integer-1} is 1 in @i{integer-2}; otherwise it is @i{false}. @i{integer-1} and @i{integer-2} are treated as if they were binary. Negative @i{integer-1} and @i{integer-2} are treated as if they were represented in two's-complement binary. @subsubheading Examples:: @example (logtest 1 7) @result{} @i{true} (logtest 1 2) @result{} @i{false} (logtest -2 -1) @result{} @i{true} (logtest 0 -1) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{integer-1} is not an @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{integer-2} is not an @i{integer}. @subsubheading Notes:: @example (logtest @i{x} @i{y}) @equiv{} (not (zerop (logand @i{x} @i{y}))) @end example @node byte, deposit-field, logtest, Numbers Dictionary @subsection byte, byte-size, byte-position [Function] @code{byte} @i{size position} @result{} @i{bytespec} @code{byte-size} @i{bytespec} @result{} @i{size} @code{byte-position} @i{bytespec} @result{} @i{position} @subsubheading Arguments and Values:: @i{size}, @i{position}---a non-negative @i{integer}. @i{bytespec}---a @i{byte specifier}. @subsubheading Description:: @b{byte} returns a @i{byte specifier} that indicates a @i{byte} of width @i{size} and whose bits have weights 2^@i{@i{position} + @i{size} - 1\/} through 2^@i{position}, and whose representation is @i{implementation-dependent}. @b{byte-size} returns the number of bits specified by @i{bytespec}. @b{byte-position} returns the position specified by @i{bytespec}. @subsubheading Examples:: @example (setq b (byte 100 200)) @result{} # (byte-size b) @result{} 100 (byte-position b) @result{} 200 @end example @subsubheading See Also:: @ref{ldb} , @ref{dpb} @subsubheading Notes:: @example (byte-size (byte @i{j} @i{k})) @equiv{} @i{j} (byte-position (byte @i{j} @i{k})) @equiv{} @i{k} @end example A @i{byte} of @i{size} of @t{0} is permissible; it refers to a @i{byte} of width zero. For example, @example (ldb (byte 0 3) #o7777) @result{} 0 (dpb #o7777 (byte 0 3) 0) @result{} 0 @end example @node deposit-field, dpb, byte, Numbers Dictionary @subsection deposit-field [Function] @code{deposit-field} @i{newbyte bytespec integer} @result{} @i{result-integer} @subsubheading Arguments and Values:: @i{newbyte}---an @i{integer}. @i{bytespec}---a @i{byte specifier}. @i{integer}---an @i{integer}. @i{result-integer}---an @i{integer}. @subsubheading Description:: Replaces a field of bits within @i{integer}; specifically, returns an @i{integer} that contains the bits of @i{newbyte} within the @i{byte} specified by @i{bytespec}, and elsewhere contains the bits of @i{integer}. @subsubheading Examples:: @example (deposit-field 7 (byte 2 1) 0) @result{} 6 (deposit-field -1 (byte 4 0) 0) @result{} 15 (deposit-field 0 (byte 2 1) -3) @result{} -7 @end example @subsubheading See Also:: @ref{byte} , @ref{dpb} @subsubheading Notes:: @example (logbitp @i{j} (deposit-field @i{m} (byte @i{s} @i{p}) @i{n})) @equiv{} (if (and (>= @i{j} @i{p}) (< @i{j} (+ @i{p} @i{s}))) (logbitp @i{j} @i{m}) (logbitp @i{j} @i{n})) @end example @b{deposit-field} is to @b{mask-field} as @b{dpb} is to @b{ldb}. @node dpb, ldb, deposit-field, Numbers Dictionary @subsection dpb [Function] @code{dpb} @i{newbyte bytespec integer} @result{} @i{result-integer} @subsubheading Pronunciation:: pronounced ,de 'pib or pronounced ,de 'pe b or pronounced 'd\=e 'p\=e 'b\=e @subsubheading Arguments and Values:: @i{newbyte}---an @i{integer}. @i{bytespec}---a @i{byte specifier}. @i{integer}---an @i{integer}. @i{result-integer}---an @i{integer}. @subsubheading Description:: @b{dpb} (deposit byte) is used to replace a field of bits within @i{integer}. @b{dpb} returns an @i{integer} that is the same as @i{integer} except in the bits specified by @i{bytespec}. Let @t{s} be the size specified by @i{bytespec}; then the low @t{s} bits of @i{newbyte} appear in the result in the byte specified by @i{bytespec}. @i{Newbyte} is interpreted as being right-justified, as if it were the result of @b{ldb}. @subsubheading Examples:: @example (dpb 1 (byte 1 10) 0) @result{} 1024 (dpb -2 (byte 2 10) 0) @result{} 2048 (dpb 1 (byte 2 10) 2048) @result{} 1024 @end example @subsubheading See Also:: @ref{byte} , @ref{deposit-field} , @ref{ldb} @subsubheading Notes:: @example (logbitp @i{j} (dpb @i{m} (byte @i{s} @i{p}) @i{n})) @equiv{} (if (and (>= @i{j} @i{p}) (< @i{j} (+ @i{p} @i{s}))) (logbitp (- @i{j} @i{p}) @i{m}) (logbitp @i{j} @i{n})) @end example In general, @example (dpb @i{x} (byte 0 @i{y}) @i{z}) @result{} @i{z} @end example for all valid values of @i{x}, @i{y}, and @i{z}. Historically, the name ``dpb'' comes from a DEC PDP-10 assembly language instruction meaning ``deposit byte.'' @node ldb, ldb-test, dpb, Numbers Dictionary @subsection ldb [Accessor] @code{ldb} @i{bytespec integer} @result{} @i{byte} (setf (@code{ ldb} @i{bytespec place}) new-byte)@* @subsubheading Pronunciation:: pronounced 'lid ib or pronounced 'lid e b or pronounced 'el 'd\=e 'b\=e @subsubheading Arguments and Values:: @i{bytespec}---a @i{byte specifier}. @i{integer}---an @i{integer}. @i{byte}, @i{new-byte}---a non-negative @i{integer}. @subsubheading Description:: @b{ldb} extracts and returns the @i{byte} of @i{integer} specified by @i{bytespec}. @b{ldb} returns an @i{integer} in which the bits with weights 2^@i{(@i{s}-1)} through 2^0 are the same as those in @i{integer} with weights 2^@i{(@i{p}+@i{s}-1)} through 2^@i{p}, and all other bits zero; @i{s} is @t{(byte-size @i{bytespec})} and @i{p} is @t{(byte-position @i{bytespec})}. @b{setf} may be used with @b{ldb} to modify a byte within the @i{integer} that is stored in a given @i{place}. The order of evaluation, when an @b{ldb} form is supplied to @b{setf}, is exactly left-to-right. @ITindex order of evaluation @ITindex evaluation order The effect is to perform a @b{dpb} operation and then store the result back into the @i{place}. @subsubheading Examples:: @example (ldb (byte 2 1) 10) @result{} 1 (setq a (list 8)) @result{} (8) (setf (ldb (byte 2 1) (car a)) 1) @result{} 1 a @result{} (10) @end example @subsubheading See Also:: @ref{byte} , @b{byte-position}, @b{byte-size}, @ref{dpb} @subsubheading Notes:: @example (logbitp @i{j} (ldb (byte @i{s} @i{p}) @i{n})) @equiv{} (and (< @i{j} @i{s}) (logbitp (+ @i{j} @i{p}) @i{n})) @end example In general, @example (ldb (byte 0 @i{x}) @i{y}) @result{} 0 @end example for all valid values of @i{x} and @i{y}. Historically, the name ``ldb'' comes from a DEC PDP-10 assembly language instruction meaning ``load byte.'' @node ldb-test, mask-field, ldb, Numbers Dictionary @subsection ldb-test [Function] @code{ldb-test} @i{bytespec integer} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{bytespec}---a @i{byte specifier}. @i{integer}---an @i{integer}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if any of the bits of the byte in @i{integer} specified by @i{bytespec} is non-zero; otherwise returns @i{false}. @subsubheading Examples:: @example (ldb-test (byte 4 1) 16) @result{} @i{true} (ldb-test (byte 3 1) 16) @result{} @i{false} (ldb-test (byte 3 2) 16) @result{} @i{true} @end example @subsubheading See Also:: @ref{byte} , @ref{ldb} , @ref{zerop} @subsubheading Notes:: @example (ldb-test bytespec n) @equiv{} (not (zerop (ldb bytespec n))) @equiv{} (logtest (ldb bytespec -1) n) @end example @node mask-field, most-positive-fixnum, ldb-test, Numbers Dictionary @subsection mask-field [Accessor] @code{mask-field} @i{bytespec integer} @result{} @i{masked-integer} (setf (@code{ mask-field} @i{bytespec place}) new-masked-integer)@* @subsubheading Arguments and Values:: @i{bytespec}---a @i{byte specifier}. @i{integer}---an @i{integer}. @i{masked-integer}, @i{new-masked-integer}---a non-negative @i{integer}. @subsubheading Description:: @b{mask-field} performs a ``mask'' operation on @i{integer}. It returns an @i{integer} that has the same bits as @i{integer} in the @i{byte} specified by @i{bytespec}, but that has zero-bits everywhere else. @b{setf} may be used with @b{mask-field} to modify a byte within the @i{integer} that is stored in a given @i{place}. The effect is to perform a @b{deposit-field} operation and then store the result back into the @i{place}. @subsubheading Examples:: @example (mask-field (byte 1 5) -1) @result{} 32 (setq a 15) @result{} 15 (mask-field (byte 2 0) a) @result{} 3 a @result{} 15 (setf (mask-field (byte 2 0) a) 1) @result{} 1 a @result{} 13 @end example @subsubheading See Also:: @ref{byte} , @ref{ldb} @subsubheading Notes:: @example (ldb @i{bs} (mask-field @i{bs} @i{n})) @equiv{} (ldb @i{bs} @i{n}) (logbitp @i{j} (mask-field (byte @i{s} @i{p}) @i{n})) @equiv{} (and (>= @i{j} @i{p}) (< @i{j} @i{s}) (logbitp @i{j} @i{n})) (mask-field @i{bs} @i{n}) @equiv{} (logand @i{n} (dpb -1 @i{bs} 0)) @end example @node most-positive-fixnum, decode-float, mask-field, Numbers Dictionary @subsection most-positive-fixnum, most-negative-fixnum [Constant Variable] @subsubheading Constant Value:: @i{implementation-dependent}. @subsubheading Description:: @b{most-positive-fixnum} is that @i{fixnum} closest in value to positive infinity provided by the implementation, and greater than or equal to both 2^@r{15} - 1 and @b{array-dimension-limit}. @b{most-negative-fixnum} is that @i{fixnum} closest in value to negative infinity provided by the implementation, and less than or equal to -2^@r{15}. @node decode-float, float, most-positive-fixnum, Numbers Dictionary @subsection decode-float, scale-float, float-radix, float-sign, @subheading float-digits, float-precision, integer-decode-float @flushright @i{[Function]} @end flushright @code{decode-float} @i{float} @result{} @i{significand, exponent, sign} @code{scale-float} @i{float integer} @result{} @i{scaled-float} @code{float-radix} @i{float} @result{} @i{float-radix} @code{float-sign} @i{float-1 @r{&optional} float-2} @result{} @i{signed-float} @code{float-digits} @i{float} @result{} @i{digits1} @code{float-precision} @i{float} @result{} @i{digits2} @code{integer-decode-float} @i{float} @result{} @i{significand, exponent, integer-sign} @subsubheading Arguments and Values:: @i{digits1}---a non-negative @i{integer}. @i{digits2}---a non-negative @i{integer}. @i{exponent}---an @i{integer}. @i{float}---a @i{float}. @i{float-1}---a @i{float}. @i{float-2}---a @i{float}. @i{float-radix}---an @i{integer}. @i{integer}---a non-negative @i{integer}. @i{integer-sign}---the @i{integer} @t{-1}, or the @i{integer} @t{1}. @i{scaled-float}---a @i{float}. @i{sign}---A @i{float} of the same @i{type} as @i{float} but numerically equal to @t{1.0} or @t{-1.0}. @i{signed-float}---a @i{float}. @i{significand}---a @i{float}. @subsubheading Description:: @b{decode-float} computes three values that characterize @i{float}. The first value is of the same @i{type} as @i{float} and represents the significand. The second value represents the exponent to which the radix (notated in this description by @i{b}) must be raised to obtain the value that, when multiplied with the first result, produces the absolute value of @i{float}. If @i{float} is zero, any @i{integer} value may be returned, provided that the identity shown for @b{scale-float} holds. The third value is of the same @i{type} as @i{float} and is 1.0 if @i{float} is greater than or equal to zero or -1.0 otherwise. @b{decode-float} divides @i{float} by an integral power of @i{b} so as to bring its value between 1/@i{b} (inclusive) and~1 (exclusive), and returns the quotient as the first value. If @i{float} is zero, however, the result equals the absolute value of @i{float} (that is, if there is a negative zero, its significand is considered to be a positive zero). @b{scale-float} returns @t{(* @i{float} (expt (float @i{b} @i{float}) @i{integer}))\/}, where @i{b} is the radix of the floating-point representation. @i{float} is not necessarily between 1/@i{b} and~1. @b{float-radix} returns the radix of @i{float}. @b{float-sign} returns a number @t{z} such that @t{z} and @i{float-1} have the same sign and also such that @t{z} and @i{float-2} have the same absolute value. If @i{float-2} is not supplied, its value is @t{(float 1 @i{float-1})}. If an implementation has distinct representations for negative zero and positive zero, then @t{(float-sign -0.0)} @result{} @t{-1.0}. @b{float-digits} returns the number of radix @i{b} digits used in the representation of @i{float} (including any implicit digits, such as a ``hidden bit''). @b{float-precision} returns the number of significant radix @i{b} digits present in @i{float}; if @i{float} is a @i{float} zero, then the result is an @i{integer} zero. For @i{normalized} @i{floats}, the results of @b{float-digits} and @b{float-precision} are the same, but the precision is less than the number of representation digits for a @i{denormalized} or zero number. @b{integer-decode-float} computes three values that characterize @i{float} - the significand scaled so as to be an @i{integer}, and the same last two values that are returned by @b{decode-float}. If @i{float} is zero, @b{integer-decode-float} returns zero as the first value. The second value bears the same relationship to the first value as for @b{decode-float}: @example (multiple-value-bind (signif expon sign) (integer-decode-float f) (scale-float (float signif f) expon)) @equiv{} (abs f) @end example @subsubheading Examples:: @example ;; Note that since the purpose of this functionality is to expose ;; details of the implementation, all of these examples are necessarily ;; very implementation-dependent. Results may vary widely. ;; Values shown here are chosen consistently from one particular implementation. (decode-float .5) @result{} 0.5, 0, 1.0 (decode-float 1.0) @result{} 0.5, 1, 1.0 (scale-float 1.0 1) @result{} 2.0 (scale-float 10.01 -2) @result{} 2.5025 (scale-float 23.0 0) @result{} 23.0 (float-radix 1.0) @result{} 2 (float-sign 5.0) @result{} 1.0 (float-sign -5.0) @result{} -1.0 (float-sign 0.0) @result{} 1.0 (float-sign 1.0 0.0) @result{} 0.0 (float-sign 1.0 -10.0) @result{} 10.0 (float-sign -1.0 10.0) @result{} -10.0 (float-digits 1.0) @result{} 24 (float-precision 1.0) @result{} 24 (float-precision least-positive-single-float) @result{} 1 (integer-decode-float 1.0) @result{} 8388608, -23, 1 @end example @subsubheading Affected By:: The implementation's representation for @i{floats}. @subsubheading Exceptional Situations:: The functions @b{decode-float}, @b{float-radix}, @b{float-digits}, @b{float-precision}, and @b{integer-decode-float} should signal an error if their only argument is not a @i{float}. The @i{function} @b{scale-float} should signal an error if its first argument is not a @i{float} or if its second argument is not an @i{integer}. The @i{function} @b{float-sign} should signal an error if its first argument is not a @i{float} or if its second argument is supplied but is not a @i{float}. @subsubheading Notes:: The product of the first result of @b{decode-float} or @b{integer-decode-float}, of the radix raised to the power of the second result, and of the third result is exactly equal to the value of @i{float}. @example (multiple-value-bind (signif expon sign) (decode-float f) (scale-float signif expon)) @equiv{} (abs f) @end example and @example (multiple-value-bind (signif expon sign) (decode-float f) (* (scale-float signif expon) sign)) @equiv{} f @end example @node float, floatp, decode-float, Numbers Dictionary @subsection float [Function] @code{float} @i{number @r{&optional} prototype} @result{} @i{float} @subsubheading Arguments and Values:: @i{number}---a @i{real}. @i{prototype}---a @i{float}. @i{float}---a @i{float}. @subsubheading Description:: @b{float} converts a @i{real} number to a @i{float}. If a @i{prototype} is supplied, a @i{float} is returned that is mathematically equal to @i{number} but has the same format as @i{prototype}. If @i{prototype} is not supplied, then if the @i{number} is already a @i{float}, it is returned; otherwise, a @i{float} is returned that is mathematically equal to @i{number} but is a @i{single float}. @subsubheading Examples:: @example (float 0) @result{} 0.0 (float 1 .5) @result{} 1.0 (float 1.0) @result{} 1.0 (float 1/2) @result{} 0.5 @result{} 1.0d0 @i{OR}@result{} 1.0 (eql (float 1.0 1.0d0) 1.0d0) @result{} @i{true} @end example @subsubheading See Also:: @ref{coerce} @node floatp, most-positive-short-float, float, Numbers Dictionary @subsection floatp [Function] @code{floatp} @i{object} @r{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{float}; otherwise, returns @i{false}. @subsubheading Examples:: @example (floatp 1.2d2) @result{} @i{true} (floatp 1.212) @result{} @i{true} (floatp 1.2s2) @result{} @i{true} (floatp (expt 2 130)) @result{} @i{false} @end example @subsubheading Notes:: @example (floatp @i{object}) @equiv{} (typep @i{object} 'float) @end example @node most-positive-short-float, short-float-epsilon, floatp, Numbers Dictionary @subsection most-positive-short-float, least-positive-short-float, @subheading least-positive-normalized-short-float, @subheading most-positive-double-float, least-positive-double-float, @subheading least-positive-normalized-double-float, @subheading most-positive-long-float, least-positive-long-float, @subheading least-positive-normalized-long-float, @subheading most-positive-single-float, least-positive-single-float, @subheading least-positive-normalized-single-float, @subheading most-negative-short-float, least-negative-short-float, @subheading least-negative-normalized-short-float, @subheading most-negative-single-float, least-negative-single-float, @subheading least-negative-normalized-single-float, @subheading most-negative-double-float, least-negative-double-float, @subheading least-negative-normalized-double-float, @subheading most-negative-long-float, least-negative-long-float, @subheading least-negative-normalized-long-float @flushright @i{[Constant Variable]} @end flushright @subsubheading Constant Value:: @i{implementation-dependent}. @subsubheading Description:: These @i{constant variables} provide a way for programs to examine the @i{implementation-defined} limits for the various float formats. Of these @i{variables}, each which has ``@t{-normalized}'' in its @i{name} must have a @i{value} which is a @i{normalized} @i{float}, and each which does not have ``@t{-normalized}'' in its name may have a @i{value} which is either a @i{normalized} @i{float} or a @i{denormalized} @i{float}, as appropriate. Of these @i{variables}, each which has ``@t{short-float}'' in its name must have a @i{value} which is a @i{short float}, each which has ``@t{single-float}'' in its name must have a @i{value} which is a @i{single float}, each which has ``@t{double-float}'' in its name must have a @i{value} which is a @i{double float}, and each which has ``@t{long-float}'' in its name must have a @i{value} which is a @i{long float}. @table @asis @item @t{*} @b{most-positive-short-float}, @b{most-positive-single-float}, @b{most-positive-double-float}, @b{most-positive-long-float} Each of these @i{constant variables} has as its @i{value} the positive @i{float} of the largest magnitude (closest in value to, but not equal to, positive infinity) for the float format implied by its name. @item @t{*} @b{least-positive-short-float}, @b{least-positive-normalized-short-float}, @b{least-positive-single-float}, @b{least-positive-normalized-single-float}, @b{least-positive-double-float}, @b{least-positive-normalized-double-float}, @b{least-positive-long-float}, @b{least-positive-normalized-long-float} Each of these @i{constant variables} has as its @i{value} the smallest positive (nonzero) @i{float} for the float format implied by its name. @item @t{*} @b{least-negative-short-float}, @b{least-negative-normalized-short-float}, @b{least-negative-single-float}, @b{least-negative-normalized-single-float}, @b{least-negative-double-float}, @b{least-negative-normalized-double-float}, @b{least-negative-long-float}, @b{least-negative-normalized-long-float} Each of these @i{constant variables} has as its @i{value} the negative (nonzero) @i{float} of the smallest magnitude for the float format implied by its name. (If an implementation supports minus zero as a @i{different} @i{object} from positive zero, this value must not be minus zero.) @item @t{*} @b{most-negative-short-float}, @b{most-negative-single-float}, @b{most-negative-double-float}, @b{most-negative-long-float} Each of these @i{constant variables} has as its @i{value} the negative @i{float} of the largest magnitude (closest in value to, but not equal to, negative infinity) for the float format implied by its name. @end table @subsubheading Notes:: @node short-float-epsilon, arithmetic-error, most-positive-short-float, Numbers Dictionary @subsection short-float-epsilon, short-float-negative-epsilon, @subheading single-float-epsilon, single-float-negative-epsilon, @subheading double-float-epsilon, double-float-negative-epsilon, @subheading long-float-epsilon, long-float-negative-epsilon @flushright @i{[Constant Variable]} @end flushright @subsubheading Constant Value:: @i{implementation-dependent}. @subsubheading Description:: The value of each of the constants @b{short-float-epsilon}, @b{single-float-epsilon}, @b{double-float-epsilon}, and @b{long-float-epsilon} is the smallest positive @i{float} \epsilon of the given format, such that the following expression is @i{true} when evaluated: @t{(not (= (float 1 \epsilon) (+ (float 1 \epsilon) \epsilon)))\/} The value of each of the constants @b{short-float-negative-epsilon}, @b{single-float-negative-epsilon}, @b{double-float-negative-epsilon}, and @b{long-float-negative-epsilon} is the smallest positive @i{float} \epsilon of the given format, such that the following expression is @i{true} when evaluated: @t{(not (= (float 1 \epsilon) (- (float 1 \epsilon) \epsilon)))\/} @node arithmetic-error, arithmetic-error-operands, short-float-epsilon, Numbers Dictionary @subsection arithmetic-error [Condition Type] @subsubheading Class Precedence List:: @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{arithmetic-error} consists of error conditions that occur during arithmetic operations. The operation and operands are initialized with the initialization arguments named @t{:operation} and @t{:operands} to @b{make-condition}, and are @i{accessed} by the functions @b{arithmetic-error-operation} and @b{arithmetic-error-operands}. @subsubheading See Also:: @b{arithmetic-error-operation}, @ref{arithmetic-error-operands} @node arithmetic-error-operands, division-by-zero, arithmetic-error, Numbers Dictionary @subsection arithmetic-error-operands, arithmetic-error-operation [Function] @code{arithmetic-error-operands} @i{condition} @result{} @i{operands} @code{arithmetic-error-operation} @i{condition} @result{} @i{operation} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{arithmetic-error}. @i{operands}---a @i{list}. @i{operation}---a @i{function designator}. @subsubheading Description:: @b{arithmetic-error-operands} returns a @i{list} of the operands which were used in the offending call to the operation that signaled the @i{condition}. @b{arithmetic-error-operation} returns a @i{list} of the offending operation in the offending call that signaled the @i{condition}. @subsubheading See Also:: @b{arithmetic-error}, @ref{Conditions} @subsubheading Notes:: @node division-by-zero, floating-point-invalid-operation, arithmetic-error-operands, Numbers Dictionary @subsection division-by-zero [Condition Type] @subsubheading Class Precedence List:: @b{division-by-zero}, @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{division-by-zero} consists of error conditions that occur because of division by zero. @node floating-point-invalid-operation, floating-point-inexact, division-by-zero, Numbers Dictionary @subsection floating-point-invalid-operation [Condition Type] @subsubheading Class Precedence List:: @b{floating-point-invalid-operation}, @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{floating-point-invalid-operation} consists of error conditions that occur because of certain floating point traps. It is @i{implementation-dependent} whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being @i{signaled}. @node floating-point-inexact, floating-point-overflow, floating-point-invalid-operation, Numbers Dictionary @subsection floating-point-inexact [Condition Type] @subsubheading Class Precedence List:: @b{floating-point-inexact}, @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{floating-point-inexact} consists of error conditions that occur because of certain floating point traps. It is @i{implementation-dependent} whether floating point traps occur, and whether or how they may be enabled or disabled. Therefore, conforming code may establish handlers for this condition, but must not depend on its being @i{signaled}. @node floating-point-overflow, floating-point-underflow, floating-point-inexact, Numbers Dictionary @subsection floating-point-overflow [Condition Type] @subsubheading Class Precedence List:: @b{floating-point-overflow}, @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{floating-point-overflow} consists of error conditions that occur because of floating-point overflow. @node floating-point-underflow, , floating-point-overflow, Numbers Dictionary @subsection floating-point-underflow [Condition Type] @subsubheading Class Precedence List:: @b{floating-point-underflow}, @b{arithmetic-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{floating-point-underflow} consists of error conditions that occur because of floating-point underflow. @c end of including dict-numbers @c %**end of chapter gcl-2.6.14/info/gcl.texi.diff0000644000175000017500000150004514360276512014302 0ustar cammcammdiff -uNr gcl-texi-orig/chap-10.texi gcl-texi/chap-10.texi --- gcl-texi-orig/chap-10.texi 1994-07-16 18:03:13 +0400 +++ gcl-texi/chap-10.texi 2002-10-17 20:53:05 +0400 @@ -16,6 +16,7 @@ Figure 10--1 lists some @i{defined names} that are applicable to the @i{property lists} of @i{symbols}. +@format @group @noindent @w{ get remprop symbol-plist } @@ -24,10 +25,12 @@ @w{ Figure 10--1: Property list defined names} @end group +@end format Figure 10--2 lists some @i{defined names} that are applicable to the creation of and inquiry about @i{symbols}. +@format @group @noindent @w{ copy-symbol keywordp symbol-package } @@ -38,6 +41,7 @@ @w{ Figure 10--2: Symbol creation and inquiry defined names} @end group +@end format @c end of including concept-symbols @@ -364,7 +368,7 @@ @node copy-symbol, gensym, make-symbol, Symbols Dictionary @subsection copy-symbol [Function] -@code{copy-symbol} @i{symbol {&optional} copy-properties} @result{} @i{new-symbol} +@code{copy-symbol} @i{symbol @r{&optional} copy-properties} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @@ -440,7 +444,7 @@ @node gensym, *gensym-counter*, copy-symbol, Symbols Dictionary @subsection gensym [Function] -@code{gensym} @i{{&optional} x} @result{} @i{new-symbol} +@code{gensym} @i{@r{&optional} x} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @@ -549,7 +553,7 @@ @node gentemp, symbol-function, *gensym-counter*, Symbols Dictionary @subsection gentemp [Function] -@code{gentemp} @i{{&optional} prefix package} @result{} @i{new-symbol} +@code{gentemp} @i{@r{&optional} prefix package} @result{} @i{new-symbol} @subsubheading Arguments and Values:: @@ -958,9 +962,9 @@ @node get, remprop, symbol-value, Symbols Dictionary @subsection get [Accessor] -@code{get} @i{symbol indicator {&optional} default} @result{} @i{value} +@code{get} @i{symbol indicator @r{&optional} default} @result{} @i{value} -(setf (@code{ get} @i{symbol indicator {&optional} default}) new-value)@* +(setf (@code{ get} @i{symbol indicator @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-11.texi gcl-texi/chap-11.texi --- gcl-texi-orig/chap-11.texi 1994-07-16 18:03:12 +0400 +++ gcl-texi/chap-11.texi 2002-10-17 20:53:05 +0400 @@ -43,6 +43,7 @@ a @i{package}. If a @i{symbol} is supplied, its name will be used as the @i{package} name. +@format @group @noindent @w{ *modules* import provide } @@ -60,6 +61,7 @@ @w{ Figure 11--1: Some Defined Names related to Packages } @end group +@end format @menu * Package Names and Nicknames:: @@ -304,6 +306,7 @@ @i{names} and @i{nicknames} of those @i{standardized} @i{packages} is given in Figure 11--2. +@format @group @noindent @w{ Name Nicknames } @@ -315,6 +318,7 @@ @w{ Figure 11--2: Standardized Package Names} @end group +@end format @menu * The COMMON-LISP Package:: @@ -665,7 +669,7 @@ @node export, find-symbol, package, Packages Dictionary @subsection export [Function] -@code{export} @i{symbols {&optional} package} @result{} @i{@b{t}} +@code{export} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -770,7 +774,7 @@ @node find-symbol, find-package, export, Packages Dictionary @subsection find-symbol [Function] -@code{find-symbol} @i{string {&optional} package} @result{} @i{symbol, status} +@code{find-symbol} @i{string @r{&optional} package} @result{} @i{symbol, status} @subsubheading Arguments and Values:: @@ -947,7 +951,7 @@ @node import, list-all-packages, find-all-symbols, Packages Dictionary @subsection import [Function] -@code{import} @i{symbols {&optional} package} @result{} @i{@b{t}} +@code{import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1064,7 +1068,7 @@ @node rename-package, shadow, list-all-packages, Packages Dictionary @subsection rename-package [Function] -@code{rename-package} @i{package new-name {&optional} new-nicknames} @result{} @i{package-object} +@code{rename-package} @i{package new-name @r{&optional} new-nicknames} @result{} @i{package-object} @subsubheading Arguments and Values:: @@ -1105,7 +1109,7 @@ @node shadow, shadowing-import, rename-package, Packages Dictionary @subsection shadow [Function] -@code{shadow} @i{symbol-names {&optional} package} @result{} @i{@b{t}} +@code{shadow} @i{symbol-names @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1183,7 +1187,7 @@ @node shadowing-import, delete-package, shadow, Packages Dictionary @subsection shadowing-import [Function] -@code{shadowing-import} @i{symbols {&optional} package} @result{} @i{@b{t}} +@code{shadowing-import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1391,7 +1395,7 @@ @node make-package, with-package-iterator, delete-package, Packages Dictionary @subsection make-package [Function] -@code{make-package} @i{package-name {&key} nicknames use} @result{} @i{package} +@code{make-package} @i{package-name @r{&key} nicknames use} @result{} @i{package} @subsubheading Arguments and Values:: @@ -1460,9 +1464,9 @@ @node with-package-iterator, unexport, make-package, Packages Dictionary @subsection with-package-iterator [Macro] -@code{with-package-iterator} @i{@r{(}name package-list-form {&rest} {symbol-types}@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{with-package-iterator} @i{@r{(}name package-list-form @r{&rest} @r{symbol-types}@r{)} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -1634,7 +1638,7 @@ @node unexport, unintern, with-package-iterator, Packages Dictionary @subsection unexport [Function] -@code{unexport} @i{symbols {&optional} package} @result{} @i{@b{t}} +@code{unexport} @i{symbols @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1693,7 +1697,7 @@ @node unintern, in-package, unexport, Packages Dictionary @subsection unintern [Function] -@code{unintern} @i{symbol {&optional} package} @result{} @i{generalized-boolean} +@code{unintern} @i{symbol @r{&optional} package} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1795,7 +1799,7 @@ @node unuse-package, use-package, in-package, Packages Dictionary @subsection unuse-package [Function] -@code{unuse-package} @i{packages-to-unuse {&optional} package} @result{} @i{@b{t}} +@code{unuse-package} @i{packages-to-unuse @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1846,7 +1850,7 @@ @node use-package, defpackage, unuse-package, Packages Dictionary @subsection use-package [Function] -@code{use-package} @i{packages-to-use {&optional} package} @result{} @i{@b{t}} +@code{use-package} @i{packages-to-use @r{&optional} package} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1918,14 +1922,14 @@ @code{defpackage} @i{defined-package-name [[!@i{option}]]} @result{} @i{package} -@w{@i{option} ::=@{{(}@t{:nicknames} @{@i{nickname}@}{*}@r{)}@}{*} | } +@w{@i{option} ::=@{@r{(}@t{:nicknames} @{@i{nickname}@}*@r{)}@}* | } @w{ @r{(}@t{:documentation} @i{string}@r{)} | } -@w{ @{{(}@t{:use} @{@i{package-name}@}{*}@r{)}@}{*} | } -@w{ @{{(}@t{:shadow} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } -@w{ @{{(}@t{:shadowing-import-from} @i{package-name} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } -@w{ @{{(}@t{:import-from} @i{package-name} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } -@w{ @{{(}@t{:export} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } -@w{ @{{(}@t{:intern} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } +@w{ @{@r{(}@t{:use} @{@i{package-name}@}*@r{)}@}* | } +@w{ @{@r{(}@t{:shadow} @{!@i{symbol-name}@}*@r{)}@}* | } +@w{ @{@r{(}@t{:shadowing-import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } +@w{ @{@r{(}@t{:import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } +@w{ @{@r{(}@t{:export} @{!@i{symbol-name}@}*@r{)}@}* | } +@w{ @{@r{(}@t{:intern} @{!@i{symbol-name}@}*@r{)}@}* | } @w{ @r{(}@t{:size} @i{integer}@r{)}} @w{@i{symbol-name} ::=(@i{symbol} | @i{string})} @@ -2058,7 +2062,7 @@ particular, @i{shadowing symbols} and @i{imported} @i{symbols} can be made external. -If a {defpackage} @i{form} appears as a @i{top level form}, +If a @i{defpackage} @i{form} appears as a @i{top level form}, all of the actions normally performed by this @i{macro} at load time must also be performed at compile time. @@ -2122,7 +2126,7 @@ @subsubheading See Also:: -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Package Concepts}, @ref{Compilation} @@ -2176,19 +2180,19 @@ @subsection do-symbols, do-external-symbols, do-all-symbols [Macro] @code{do-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} - @{@i{declaration}@}{*} - @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @code{do-external-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} - @{@i{declaration}@}{*} - @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @code{do-all-symbols} @i{@r{(}var @r{[}result-form@r{]}@r{)} - @{@i{declaration}@}{*} - @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2296,7 +2300,7 @@ @node intern, package-name, do-symbols, Packages Dictionary @subsection intern [Function] -@code{intern} @i{string {&optional} package} @result{} @i{symbol, status} +@code{intern} @i{string @r{&optional} package} @result{} @i{symbol, status} @subsubheading Arguments and Values:: @@ -2370,7 +2374,7 @@ @ref{find-symbol} , -@ref{read; read-preserving-whitespace} +@ref{read} , @b{symbol}, @ref{unintern} diff -uNr gcl-texi-orig/chap-12.texi gcl-texi/chap-12.texi --- gcl-texi-orig/chap-12.texi 1994-07-16 18:03:12 +0400 +++ gcl-texi/chap-12.texi 2002-10-17 20:53:05 +0400 @@ -33,6 +33,7 @@ Figure 12--1 shows @i{operators} relating to arithmetic operations. +@format @group @noindent @w{ * 1+ gcd } @@ -44,10 +45,12 @@ @w{ Figure 12--1: Operators relating to Arithmetic.} @end group +@end format Figure 12--2 shows @i{defined names} relating to exponential, logarithmic, and trigonometric operations. +@format @group @noindent @w{ abs cos signum } @@ -63,10 +66,12 @@ @w{ Figure 12--2: Defined names relating to Exponentials, Logarithms, and Trigonometry.} @end group +@end format Figure 12--3 shows @i{operators} relating to numeric comparison and predication. +@format @group @noindent @w{ /= >= oddp } @@ -79,10 +84,12 @@ @w{ Figure 12--3: Operators for numeric comparison and predication.} @end group +@end format Figure 12--4 shows @i{defined names} relating to numeric type manipulation and coercion. +@format @group @noindent @w{ ceiling float-radix rational } @@ -99,6 +106,7 @@ @w{ Figure 12--4: Defined names relating to numeric type manipulation and coercion.} @end group +@end format @menu * Associativity and Commutativity in Numeric Operations:: @@ -187,6 +195,7 @@ Figure 12--5 shows @i{defined names} relating to logical operations on numbers. +@format @group @noindent @w{ ash boole-ior logbitp } @@ -205,6 +214,7 @@ @w{ Figure 12--5: Defined names relating to logical operations on numbers.} @end group +@end format @node Byte Operations on Integers, , Logical Operations on Integers, Numeric Operations @subsubsection Byte Operations on Integers @@ -220,6 +230,7 @@ Figure 12--6 shows @i{defined names} relating to manipulating @i{bytes} of @i{numbers}. +@format @group @noindent @w{ byte deposit-field ldb-test } @@ -230,6 +241,7 @@ @w{ Figure 12--6: Defined names relating to byte manipulation.} @end group +@end format @node Implementation-Dependent Numeric Constants, Rational Computations, Numeric Operations, Number Concepts @subsection Implementation-Dependent Numeric Constants @@ -237,6 +249,7 @@ Figure 12--7 shows @i{defined names} relating to @i{implementation-dependent} details about @i{numbers}. +@format @group @noindent @w{ double-float-epsilon most-negative-fixnum } @@ -257,6 +270,7 @@ @w{ Figure 12--7: Defined names relating to implementation-dependent details about numbers.} @end group +@end format @node Rational Computations, Floating-point Computations, Implementation-Dependent Numeric Constants, Number Concepts @subsection Rational Computations @@ -331,6 +345,7 @@ (permissible only if the imaginary part of the true mathematical result is zero) or @t{(complex single-float)}. +@format @group @noindent @w{ Function Sample Results } @@ -361,6 +376,7 @@ @w{ Figure 12--8: Functions Affected by Rule of Float Substitutability} @end group +@end format @node Floating-point Computations, Complex Computations, Rational Computations, Number Concepts @subsection Floating-point Computations @@ -525,7 +541,7 @@ called branch cuts must be defined, which in turn define the discontinuities in the range. @r{Common Lisp} defines the branch cuts, @i{principal} @i{values}, and boundary -conditions for the complex functions following ``{Principal Values and Branch Cuts in Complex APL}.'' The branch +conditions for the complex functions following ``Principal Values and Branch Cuts in Complex APL.'' The branch cut rules that apply to each function are located with the description of that function. @@ -534,6 +550,7 @@ throughout the applicable portion of the complex domain, even on the branch cuts: +@format @group @noindent @w{ sin i z = i sinh z sinh i z = i sin z arctan i z = i arctanh z } @@ -544,6 +561,7 @@ @w{ Figure 12--9: Trigonometric Identities for Complex Domain } @end group +@end format The quadrant numbers referred to in the discussions of branch cuts are as illustrated in Figure 12--10. @@ -623,6 +641,7 @@ Figure 12--10 lists some @i{defined names} that are applicable to @i{random states}. +@format @group @noindent @w{ *random-state* random } @@ -632,6 +651,7 @@ @w{ Figure 12--10: Random-state defined names} @end group +@end format @c end of including concept-numbers @@ -646,13 +666,13 @@ * real:: * float (System Class):: * short-float:: -* rational:: +* rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: -* mod:: -* bit:: +* mod (System Class):: +* bit (System Class):: * fixnum:: * bignum:: * =:: @@ -676,7 +696,7 @@ * incf:: * lcm:: * log:: -* mod:: +* mod (Function):: * signum:: * sqrt:: * random-state:: @@ -694,7 +714,7 @@ * upgraded-complex-part-type:: * realp:: * numerator:: -* rational:: +* rational (Function):: * rationalp:: * ash:: * integer-length:: @@ -882,14 +902,14 @@ A @i{float} is a mathematical rational (but @i{not} a @r{Common Lisp} @i{rational}) of the form -s\cdot f\cdot b^{e-p}, +s\cdot f\cdot b^@r{e-p}, where s is +1 or -1, the @i{sign}; b is an @i{integer} greater than~1, the @i{base} or @i{radix} of the representation; p is a positive @i{integer}, the @i{precision} (in base-b digits) of the @i{float}; f is a positive @i{integer} -between b^{p-1} and +between b^@r{p-1} and b^p-1 (inclusive), the significand; and e is an @i{integer}, the exponent. The value of p and the range of~e @@ -937,7 +957,7 @@ @subsubheading See Also:: -{@i{Figure~2--9}}, +@i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Floats} @@ -950,7 +970,7 @@ the @i{float} @t{1.0}, or the @i{complex} @t{#C(1.0 0.0)}. -@node short-float, rational, float (System Class), Numbers Dictionary +@node short-float, rational (System Class), float (System Class), Numbers Dictionary @subsection short-float, single-float, double-float, long-float [Type] @subsubheading Supertypes:: @@ -1005,6 +1025,7 @@ as the values in Figure 12--11. Each of the defined @i{subtypes} of @i{type} @b{float} might or might not have a minus zero. +@format @group @noindent @w{ @b{Format} @b{Minimum Precision} @b{Minimum Exponent Size} } @@ -1018,6 +1039,7 @@ @w{ Figure 12--11: Recommended Minimum Floating-Point Precision and Exponent Size} @end group +@end format There can be fewer than four internal representations for @i{floats}. @@ -1099,7 +1121,7 @@ Each of these denotes the set of @i{floats} of the indicated @i{type} that are on the interval specified by the @i{interval designators}. -@node rational, ratio, short-float, Numbers Dictionary +@node rational (System Class), ratio, short-float, Numbers Dictionary @subsection rational [System Class] @subsubheading Class Precedence List:: @@ -1138,7 +1160,7 @@ This denotes the @i{rationals} on the interval described by @i{lower-limit} and @i{upper-limit}. -@node ratio, integer, rational, Numbers Dictionary +@node ratio, integer, rational (System Class), Numbers Dictionary @subsection ratio [System Class] @subsubheading Class Precedence List:: @@ -1160,7 +1182,7 @@ @subsubheading See Also:: -{@i{Figure~2--9}}, +@i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Ratios} @@ -1205,7 +1227,7 @@ @subsubheading See Also:: -{@i{Figure~2--9}}, +@i{Figure~2--9}, @ref{Constructing Numbers from Tokens}, @ref{Printing Integers} @@ -1255,11 +1277,11 @@ This denotes the set of @i{integers} that can be represented in two's-complement form in a @i{byte} of @i{s} bits. This is -equivalent to @t{(integer -2^{s-1} 2^{s-1}-1)}. The type +equivalent to @t{(integer -2^@r{s-1} 2^@r{s-1}-1)}. The type @b{signed-byte} or the type @t{(signed-byte *)} is the same as the @i{type} @b{integer}. -@node unsigned-byte, mod, signed-byte, Numbers Dictionary +@node unsigned-byte, mod (System Class), signed-byte, Numbers Dictionary @subsection unsigned-byte [Type] @subsubheading Supertypes:: @@ -1306,7 +1328,7 @@ The @i{type} @t{(unsigned-byte 1)} is also called @b{bit}. -@node mod, bit, unsigned-byte, Numbers Dictionary +@node mod (System Class), bit (System Class), unsigned-byte, Numbers Dictionary @subsection mod [Type Specifier] @subsubheading Compound Type Specifier Kind:: @@ -1334,7 +1356,7 @@ The symbol @b{mod} is not valid as a @i{type specifier}. -@node bit, fixnum, mod, Numbers Dictionary +@node bit (System Class), fixnum, mod (System Class), Numbers Dictionary @subsection bit [Type] @subsubheading Supertypes:: @@ -1355,7 +1377,7 @@ The @i{type} @b{bit} is equivalent to the @i{type} @t{(integer 0 1)} and @t{(unsigned-byte 1)}. -@node fixnum, bignum, bit, Numbers Dictionary +@node fixnum, bignum, bit (System Class), Numbers Dictionary @subsection fixnum [Type] @subsubheading Supertypes:: @@ -1400,17 +1422,17 @@ @node =, max, bignum, Numbers Dictionary @subsection =, /=, <, >, <=, >= [Function] -@code{=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} -@code{/=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{/=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} -@code{<} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{<} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} -@code{>} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{>} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} -@code{<=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{<=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} -@code{>=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} +@code{>=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1462,6 +1484,7 @@ The uses of these functions are illustrated in Figure 12--12. +@format @group @noindent @w{ @t{(= 3 3)} is @i{true}. @t{(/= 3 3)} is @i{false}. } @@ -1493,6 +1516,7 @@ @w{ Figure 12--12: Uses of /=, =, <, >, <=, and >= } @end group +@end format @subsubheading Exceptional Situations:: @@ -1509,9 +1533,9 @@ @node max, minusp, =, Numbers Dictionary @subsection max, min [Function] -@code{max} @i{{&rest} reals^+} @result{} @i{max-real} +@code{max} @i{@r{&rest} reals^+} @result{} @i{max-real} -@code{min} @i{{&rest} reals^+} @result{} @i{min-real} +@code{min} @i{@r{&rest} reals^+} @result{} @i{min-real} @subsubheading Arguments and Values:: @@ -1628,7 +1652,7 @@ @subsubheading Pronunciation:: -pronounced 'z\=e (, )r\=o{}(, )p\=e +pronounced 'z\=e (, )r\=o@r{}(, )p\=e @subsubheading Arguments and Values:: @@ -1673,21 +1697,21 @@ @i{[Function]} @end flushright -@code{floor} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{floor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{ffloor} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{ffloor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{ceiling} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{ceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{fceiling} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{fceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{truncate} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{truncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{ftruncate} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{ftruncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{round} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{round} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} -@code{fround} @i{number {&optional} divisor} @result{} @i{quotient, remainder} +@code{fround} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} @subsubheading Arguments and Values:: @@ -1708,7 +1732,7 @@ These functions divide @i{number} by @i{divisor}, returning a @i{quotient} and @i{remainder}, such that - @i{quotient}{\cdot} @i{divisor}+@i{remainder}=@i{number} + @i{quotient}@r{\cdot} @i{divisor}+@i{remainder}=@i{number} The @i{quotient} always represents a mathematical integer. When more than one mathematical integer might be possible @@ -1853,7 +1877,7 @@ @subsubheading See Also:: -@ref{asin; acos; atan} +@ref{asin} , @b{acos}, @b{atan}, @@ -1866,7 +1890,7 @@ @code{acos} @i{number} @result{} @i{radians} -@code{atan} @i{number1 {&optional} number2} @result{} @i{radians} +@code{atan} @i{number1 @r{&optional} number2} @result{} @i{radians} @subsubheading Arguments and Values:: @@ -1888,17 +1912,19 @@ functions can be defined mathematically for @i{number} or @i{number1} specified as @i{x} as in Figure 12--13. +@format @group @noindent @w{ Function Definition } -@w{ Arc sine -i @t{log} (ix+ \sqrt{1-x^2} ) } +@w{ Arc sine -i @t{log} (ix+ \sqrt@r{1-x^2} ) } @w{ Arc cosine (\pi/2) - @t{arcsin} x } -@w{ Arc tangent -i @t{log} ((1+ix) \sqrt{1/(1+x^2)} ) } +@w{ Arc tangent -i @t{log} ((1+ix) \sqrt@r{1/(1+x^2)} ) } @noindent @w{ Figure 12--13: Mathematical definition of arc sine, arc cosine, and arc tangent} @end group +@end format These formulae are mathematically correct, assuming completely accurate computation. They are not necessarily @@ -1936,7 +1962,7 @@ The following definition for arc sine determines the range and branch cuts: -@center @t{arcsin} z = -i @t{log} (iz+\sqrt{1-z^2}\Bigr) +@center @t{arcsin} z = -i @t{log} (iz+\sqrt@r{1-z^2}\Bigr) The branch cut for the arc sine function is in two pieces: one along the negative real axis to the left of~-1 @@ -1951,13 +1977,13 @@ The following definition for arc cosine determines the range and branch cuts: -@center @t{arccos} z = {\pi\over2}- @t{arcsin} z +@center @t{arccos} z = \pi\over2 - @t{arcsin} z or, which are equivalent, -@center @t{arccos} z = -i @t{log} (z+i \sqrt{1-z^2}\Bigr) +@center @t{arccos} z = -i @t{log} (z+i \sqrt@r{1-z^2}\Bigr) -@center @t{arccos} z = {{2 @t{log} (\sqrt{(1+z)/2} + i \sqrt{(1-z)/2})}\over{i}} +@center @t{arccos} z = @t{2 @t{log} (\sqrt@r{(1+z)/2} + i \sqrt@r{(1-z)/2})}\over@r{i} The branch cut for the arc cosine function is in two pieces: one along the negative real axis to the left of~-1 @@ -1973,7 +1999,7 @@ The following definition for (one-argument) arc tangent determines the range and branch cuts: -@center @t{arctan} z = {{@t{log} (1+iz) - @t{log} (1-iz)}\over{2i}} +@center @t{arctan} z = @i{@i{@t{log} (1+iz) - @t{log} (1-iz)}\over@i{2i}} Beware of simplifying this formula; ``obvious'' simplifications are likely to alter the branch cuts or the values on the branch cuts incorrectly. @@ -1998,31 +2024,33 @@ The asterisk (*) indicates that the entry in the figure applies to implementations that support minus zero. +@format @group @noindent -@w{ to 1pc{}@i{y} Condition @i{x} Condition Cartesian locus Range of result } -@w{ to 1pc{} y = 0 x > 0 Positive x-axis 0 } -@w{ to 1pc{*} y = +0 x > 0 Positive x-axis +0 } -@w{ to 1pc{*} y = -0 x > 0 Positive x-axis -0 } -@w{ to 1pc{} y > 0 x > 0 Quadrant I 0 < result < \pi/2 } -@w{ to 1pc{} y > 0 x = 0 Positive y-axis \pi/2 } -@w{ to 1pc{} y > 0 x < 0 Quadrant II \pi/2 < result < \pi } -@w{ to 1pc{} y = 0 x < 0 Negative x-axis \pi } -@w{ to 1pc{*} y = +0 x < 0 Negative x-axis +\pi } -@w{ to 1pc{*} y = -0 x < 0 Negative x-axis -\pi } -@w{ to 1pc{} y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 } -@w{ to 1pc{} y < 0 x = 0 Negative y-axis -\pi/2 } -@w{ to 1pc{} y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 } -@w{ to 1pc{} y = 0 x = 0 Origin undefined consequences } -@w{ to 1pc{*} y = +0 x = +0 Origin +0 } -@w{ to 1pc{*} y = -0 x = +0 Origin -0 } -@w{ to 1pc{*} y = +0 x = -0 Origin +\pi } -@w{ to 1pc{*} y = -0 x = -0 Origin -\pi } +@w{ to 1pc@r{}@i{y} Condition @i{x} Condition Cartesian locus Range of result } +@w{ to 1pc@r{} y = 0 x > 0 Positive x-axis 0 } +@w{ to 1pc* y = +0 x > 0 Positive x-axis +0 } +@w{ to 1pc* y = -0 x > 0 Positive x-axis -0 } +@w{ to 1pc@r{} y > 0 x > 0 Quadrant I 0 < result < \pi/2 } +@w{ to 1pc@r{} y > 0 x = 0 Positive y-axis \pi/2 } +@w{ to 1pc@r{} y > 0 x < 0 Quadrant II \pi/2 < result < \pi } +@w{ to 1pc@r{} y = 0 x < 0 Negative x-axis \pi } +@w{ to 1pc* y = +0 x < 0 Negative x-axis +\pi } +@w{ to 1pc* y = -0 x < 0 Negative x-axis -\pi } +@w{ to 1pc@r{} y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 } +@w{ to 1pc@r{} y < 0 x = 0 Negative y-axis -\pi/2 } +@w{ to 1pc@r{} y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 } +@w{ to 1pc@r{} y = 0 x = 0 Origin undefined consequences } +@w{ to 1pc* y = +0 x = +0 Origin +0 } +@w{ to 1pc* y = -0 x = +0 Origin -0 } +@w{ to 1pc* y = +0 x = -0 Origin +\pi } +@w{ to 1pc* y = -0 x = -0 Origin -\pi } @noindent @w{ Figure 12--14: Quadrant information for arc tangent } @end group +@end format @subsubheading Examples:: @@ -2047,7 +2075,7 @@ @ref{log} , -@ref{sqrt; isqrt} +@ref{sqrt} , @ref{Rule of Float Substitutability} @@ -2119,25 +2147,27 @@ which are mathematically defined for an argument @i{x} as given in Figure 12--15. +@format @group @noindent @w{ Function Definition } -@w{ Hyperbolic sine (e^x-e^{-x})/2 } -@w{ Hyperbolic cosine (e^x+e^{-x})/2 } -@w{ Hyperbolic tangent (e^x-e^{-x})/(e^x+e^{-x}) } -@w{ Hyperbolic arc sine @t{log} (x+\sqrt{1+x^2}) } -@w{ Hyperbolic arc cosine 2 @t{log} (\sqrt{(x+1)/2} + \sqrt{(x-1)/2}) } +@w{ Hyperbolic sine (e^x-e^@i{-x})/2 } +@w{ Hyperbolic cosine (e^x+e^@i{-x})/2 } +@w{ Hyperbolic tangent (e^x-e^@i{-x})/(e^x+e^@i{-x}) } +@w{ Hyperbolic arc sine @t{log} (x+\sqrt@i{1+x^2}) } +@w{ Hyperbolic arc cosine 2 @t{log} (\sqrt@i{(x+1)/2} + \sqrt@i{(x-1)/2}) } @w{ Hyperbolic arc tangent (@t{log} (1+x) - @t{log} (1-x))/2 } @noindent @w{ Figure 12--15: Mathematical definitions for hyperbolic functions } @end group +@end format The following definition for the inverse hyperbolic cosine determines the range and branch cuts: -@center @t{arccosh} z = 2 @t{log} (\sqrt{(z+1)/2} + \sqrt{(z-1)/2}\Bigr). +@center @t{arccosh} z = 2 @t{log} (\sqrt@i{(z+1)/2} + \sqrt@i{(z-1)/2}\Bigr). The branch cut for the inverse hyperbolic cosine function lies along the real axis to the left of~1 (inclusive), extending @@ -2152,7 +2182,7 @@ The following definition for the inverse hyperbolic sine determines the range and branch cuts: -@center @t{arcsinh} z = @t{log} (z+\sqrt{1+z^2}\Bigr). +@center @t{arcsinh} z = @t{log} (z+\sqrt@i{1+z^2}\Bigr). The branch cut for the inverse hyperbolic sine function is in two pieces: one along the positive imaginary axis above i @@ -2167,7 +2197,7 @@ The following definition for the inverse hyperbolic tangent determines the range and branch cuts: -@center @t{arctanh} z = {{@t{log} (1+z) - @t{log} (1-z)}\over{2}}. +@center @t{arctanh} z = @i{@i{@t{log} (1+z) - @t{log} (1-z)}\over@r{2}}. Note that: @@ -2206,7 +2236,7 @@ @ref{log} , -@ref{sqrt; isqrt} +@ref{sqrt} , @ref{Rule of Float Substitutability} @@ -2228,7 +2258,7 @@ @node *, +, sinh, Numbers Dictionary @subsection * [Function] -@code{*} @i{{&rest} numbers} @result{} @i{product} +@code{*} @i{@r{&rest} numbers} @result{} @i{product} @subsubheading Arguments and Values:: @@ -2265,7 +2295,7 @@ @node +, -, *, Numbers Dictionary @subsection + [Function] -@code{+} @i{{&rest} numbers} @result{} @i{sum} +@code{+} @i{@r{&rest} numbers} @result{} @i{sum} @subsubheading Arguments and Values:: @@ -2304,7 +2334,7 @@ @code{-} @i{number} @result{} @i{negation} -@code{-} @i{minuend {&rest} subtrahends^+} @result{} @i{difference} +@code{-} @i{minuend @r{&rest} subtrahends^+} @result{} @i{difference} @subsubheading Arguments and Values:: @@ -2353,7 +2383,7 @@ @code{/} @i{number} @result{} @i{reciprocal} -@code{/} @i{numerator {&rest} denominators^+} @result{} @i{quotient} +@code{/} @i{numerator @r{&rest} denominators^+} @result{} @i{quotient} @subsubheading Arguments and Values:: @@ -2406,16 +2436,16 @@ @subsubheading See Also:: -@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} +@ref{floor} , @b{ceiling}, @b{truncate}, @b{round} @node 1+, abs, /, Numbers Dictionary @subsection 1+, 1- [Function] @code{1} @i{+} @result{} @i{number} - {successor} + @r{successor} @code{1} @i{-} @result{} @i{number} - {predecessor} + @r{predecessor} @subsubheading Arguments and Values:: @@ -2444,7 +2474,7 @@ @subsubheading See Also:: -@ref{incf; decf} +@ref{incf} , @b{decf} @subsubheading Notes:: @@ -2611,7 +2641,7 @@ approximately equal to @t{#C(1.0 1.73205)}, not @t{-2}. @b{expt} is defined -as @i{b^x = e^{x log b\/}}. +as @i{b^x = e^@i{x log b\/}}. This defines the @i{principal} @i{values} precisely. The range of @b{expt} is the entire complex plane. Regarded as a function of @i{x}, with @i{b} fixed, there is no branch cut. @@ -2678,7 +2708,7 @@ @node gcd, incf, exp, Numbers Dictionary @subsection gcd [Function] -@code{gcd} @i{{&rest} integers} @result{} @i{greatest-common-denominator} +@code{gcd} @i{@r{&rest} integers} @result{} @i{greatest-common-denominator} @subsubheading Arguments and Values:: @@ -2778,12 +2808,12 @@ @b{+}, @ref{-} , @b{1+}, @b{1-}, -@ref{setf; psetf} +@ref{setf} @node lcm, log, incf, Numbers Dictionary @subsection lcm [Function] -@code{lcm} @i{{&rest} integers} @result{} @i{least-common-multiple} +@code{lcm} @i{@r{&rest} integers} @result{} @i{least-common-multiple} @subsubheading Arguments and Values:: @@ -2836,10 +2866,10 @@ @ref{gcd} -@node log, mod, lcm, Numbers Dictionary +@node log, mod (Function), lcm, Numbers Dictionary @subsection log [Function] -@code{log} @i{number {&optional} base} @result{} @i{logarithm} +@code{log} @i{number @r{&optional} base} @result{} @i{logarithm} @subsubheading Arguments and Values:: @@ -2924,12 +2954,12 @@ @subsubheading See Also:: -@ref{exp; expt} +@ref{exp} , @b{expt}, @ref{Rule of Float Substitutability} -@node mod, signum, log, Numbers Dictionary +@node mod (Function), signum, log, Numbers Dictionary @subsection mod, rem [Function] @code{mod} @i{number divisor} @result{} @i{modulus} @@ -2981,7 +3011,7 @@ @subsubheading See Also:: -@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} +@ref{floor} , @b{truncate} @subsubheading Notes:: @@ -2992,7 +3022,7 @@ with the same sign as @i{divisor}. -@node signum, sqrt, mod, Numbers Dictionary +@node signum, sqrt, mod (Function), Numbers Dictionary @subsection signum [Function] @code{signum} @i{number} @result{} @i{signed-prototype} @@ -3122,7 +3152,7 @@ @subsubheading See Also:: -@ref{exp; expt} +@ref{exp} , @ref{log} , @@ -3166,7 +3196,7 @@ @node make-random-state, random, random-state, Numbers Dictionary @subsection make-random-state [Function] -@code{make-random-state} @i{{&optional} state} @result{} @i{new-state} +@code{make-random-state} @i{@r{&optional} state} @result{} @i{new-state} @subsubheading Arguments and Values:: @@ -3230,7 +3260,7 @@ @node random, random-state-p, make-random-state, Numbers Dictionary @subsection random [Function] -@code{random} @i{limit {&optional} random-state} @result{} @i{random-number} +@code{random} @i{limit @r{&optional} random-state} @result{} @i{random-number} @subsubheading Arguments and Values:: @@ -3420,7 +3450,7 @@ @subsubheading Description:: -@b{cis} returns the value of~@i{e}^{i\cdot @i{radians}}, +@b{cis} returns the value of~@i{e}^@i{i\cdot @i{radians}}, which is a @i{complex} in which the real part is equal to the cosine of @i{radians}, and the imaginary part is equal to the sine of @i{radians}. @@ -3437,7 +3467,7 @@ @node complex, complexp, cis, Numbers Dictionary @subsection complex [Function] -@code{complex} @i{realpart {&optional} imagpart} @result{} @i{complex} +@code{complex} @i{realpart @r{&optional} imagpart} @result{} @i{complex} @subsubheading Arguments and Values:: @@ -3490,7 +3520,7 @@ @subsubheading See Also:: -@ref{realpart; imagpart} +@ref{realpart} , @b{imagpart} @subsubheading Notes:: @@ -3687,7 +3717,7 @@ @node upgraded-complex-part-type, realp, realpart, Numbers Dictionary @subsection upgraded-complex-part-type [Function] -@code{upgraded-complex-part-type} @i{typespec {&optional} environment} @result{} @i{upgraded-typespec} +@code{upgraded-complex-part-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} @subsubheading Arguments and Values:: @@ -3749,7 +3779,7 @@ (realp @i{object}) @equiv{} (typep @i{object} 'real) @end example -@node numerator, rational, realp, Numbers Dictionary +@node numerator, rational (Function), realp, Numbers Dictionary @subsection numerator, denominator [Function] @code{numerator} @i{rational} @result{} @i{numerator} @@ -3795,7 +3825,7 @@ (gcd (numerator x) (denominator x)) @result{} 1 @end example -@node rational, rationalp, numerator, Numbers Dictionary +@node rational (Function), rationalp, numerator, Numbers Dictionary @subsection rational, rationalize [Function] @code{rational} @i{number} @result{} @i{rational} @@ -3868,7 +3898,7 @@ to a @i{float} of the same format produces the original @i{number}. -@node rationalp, ash, rational, Numbers Dictionary +@node rationalp, ash, rational (Function), Numbers Dictionary @subsection rationalp [Function] @code{rationalp} @i{object} @result{} @i{generalized-boolean} @@ -3894,7 +3924,7 @@ @subsubheading See Also:: -@ref{rational} +@ref{rational (Function)} @subsubheading Notes:: @example @@ -3926,7 +3956,7 @@ as @i{integer} is returned. Mathematically speaking, @b{ash} performs the computation -@t{floor}(@i{integer}{\cdot} 2^@i{count}). +@t{floor}(@i{integer}\cdot 2^@i{count}). Logically, @b{ash} moves all of the bits in @i{integer} to the left, adding zero-bits at the right, or moves them to the right, @@ -4050,7 +4080,7 @@ @node parse-integer, boole, integerp, Numbers Dictionary @subsection parse-integer [Function] -@code{parse-integer} @i{string {&key} start end radix junk-allowed} @result{} @i{integer, pos} +@code{parse-integer} @i{string @r{&key} start end radix junk-allowed} @result{} @i{integer, pos} @subsubheading Arguments and Values:: @@ -4140,8 +4170,9 @@ @b{boole} returns the values specified for any @i{op} in Figure 12--16. -{ + +@format @group @noindent @w{ Op Result } @@ -4166,8 +4197,9 @@ @w{ Figure 12--16: Bit-Wise Logical Operations } @end group +@end format + -} @subsubheading Examples:: @@ -4217,7 +4249,7 @@ @subsubheading See Also:: -@ref{logand; logandc1; logandc2; logeqv; logior; lognand; lognor; lognot; logorc1; logorc2; logxor} +@ref{logand} @subsubheading Notes:: @@ -4292,15 +4324,15 @@ @i{[Function]} @end flushright -@code{logand} @i{{&rest} integers} @result{} @i{result-integer} +@code{logand} @i{@r{&rest} integers} @result{} @i{result-integer} @code{logandc} @i{1} @result{} @i{integer-1 integer-2} - {result-integer} + @r{result-integer} @code{logandc} @i{2} @result{} @i{integer-1 integer-2} - {result-integer} -@code{logeqv} @i{{&rest} integers} @result{} @i{result-integer} + @r{result-integer} +@code{logeqv} @i{@r{&rest} integers} @result{} @i{result-integer} -@code{logior} @i{{&rest} integers} @result{} @i{result-integer} +@code{logior} @i{@r{&rest} integers} @result{} @i{result-integer} @code{lognand} @i{integer-1 integer-2} @result{} @i{result-integer} @@ -4309,10 +4341,10 @@ @code{lognot} @i{integer} @result{} @i{result-integer} @code{logorc} @i{1} @result{} @i{integer-1 integer-2} - {result-integer} + @r{result-integer} @code{logorc} @i{2} @result{} @i{integer-1 integer-2} - {result-integer} -@code{logxor} @i{{&rest} integers} @result{} @i{result-integer} + @r{result-integer} +@code{logxor} @i{@r{&rest} integers} @result{} @i{result-integer} @subsubheading Arguments and Values:: @@ -4347,6 +4379,7 @@ Where an `identity' is shown, it indicates the @i{value} @i{yielded} by the @i{function} when no @i{arguments} are supplied. +@format @group @noindent @w{ Function Identity Operation performed } @@ -4366,6 +4399,7 @@ @w{ Figure 12--17: Bit-wise Logical Operations on Integers } @end group +@end format Negative @i{integers} are treated as if they were in two's-complement notation. @@ -4594,7 +4628,7 @@ @b{byte} returns a @i{byte specifier} that indicates a @i{byte} of width @i{size} and whose bits have weights -2^{@i{position} + @i{size} - 1\/} through 2^@i{position}, +2^@i{@i{position} + @i{size} - 1\/} through 2^@i{position}, and whose representation is @i{implementation-dependent}. @@ -4663,7 +4697,7 @@ @subsubheading See Also:: -@ref{byte; byte-size; byte-position} +@ref{byte} , @ref{dpb} @@ -4723,7 +4757,7 @@ @subsubheading See Also:: -@ref{byte; byte-size; byte-position} +@ref{byte} , @ref{deposit-field} , @@ -4776,8 +4810,8 @@ specified by @i{bytespec}. @b{ldb} returns an @i{integer} in which the bits with weights -2^{(@i{s}-1)} through 2^{0} are the same as those in -@i{integer} with weights 2^{(@i{p}+@i{s}-1)} +2^@i{(@i{s}-1)} through 2^0 are the same as those in +@i{integer} with weights 2^@i{(@i{p}+@i{s}-1)} through 2^@i{p}, and all other bits zero; @i{s} is @t{(byte-size @i{bytespec})} and @i{p} is @t{(byte-position @i{bytespec})}. @@ -4807,7 +4841,7 @@ @subsubheading See Also:: -@ref{byte; byte-size; byte-position} +@ref{byte} , @b{byte-position}, @b{byte-size}, @@ -4859,7 +4893,7 @@ @subsubheading See Also:: -@ref{byte; byte-size; byte-position} +@ref{byte} , @ref{ldb} , @@ -4912,7 +4946,7 @@ @subsubheading See Also:: -@ref{byte; byte-size; byte-position} +@ref{byte} , @ref{ldb} @@ -4937,13 +4971,13 @@ @b{most-positive-fixnum} is that @i{fixnum} closest in value to positive infinity provided by the implementation, -and greater than or equal to both 2^{15} - 1 and +and greater than or equal to both 2^@r{15} - 1 and @b{array-dimension-limit}. @b{most-negative-fixnum} is that @i{fixnum} closest in value to negative infinity provided by the implementation, -and less than or equal to -2^{15}. +and less than or equal to -2^@r{15}. @node decode-float, float, most-positive-fixnum, Numbers Dictionary @subsection decode-float, scale-float, float-radix, float-sign, @@ -4958,7 +4992,7 @@ @code{float-radix} @i{float} @result{} @i{float-radix} -@code{float-sign} @i{float-1 {&optional} float-2} @result{} @i{signed-float} +@code{float-sign} @i{float-1 @r{&optional} float-2} @result{} @i{signed-float} @code{float-digits} @i{float} @result{} @i{digits1} @@ -5137,7 +5171,7 @@ @node float, floatp, decode-float, Numbers Dictionary @subsection float [Function] -@code{float} @i{number {&optional} prototype} @result{} @i{float} +@code{float} @i{number @r{&optional} prototype} @result{} @i{float} @subsubheading Arguments and Values:: @@ -5184,7 +5218,7 @@ @subsection floatp [Function] @code{floatp} @i{object} - {generalized-boolean} + @r{generalized-boolean} @subsubheading Arguments and Values:: @@ -5372,7 +5406,7 @@ @subsubheading See Also:: @b{arithmetic-error-operation}, -@ref{arithmetic-error-operands; arithmetic-error-operation} +@ref{arithmetic-error-operands} @node arithmetic-error-operands, division-by-zero, arithmetic-error, Numbers Dictionary @subsection arithmetic-error-operands, arithmetic-error-operation [Function] @@ -5401,7 +5435,7 @@ @subsubheading See Also:: @b{arithmetic-error}, -{@ref{Conditions}} +@ref{Conditions} @subsubheading Notes:: diff -uNr gcl-texi-orig/chap-13.texi gcl-texi/chap-13.texi --- gcl-texi-orig/chap-13.texi 1994-07-16 18:03:11 +0400 +++ gcl-texi/chap-13.texi 2002-10-17 20:53:05 +0400 @@ -46,6 +46,7 @@ Figure 13--1 lists some @i{defined names} relating to @i{character} @i{attributes} and @i{character} @i{predicates}. +@format @group @noindent @w{ alpha-char-p char-not-equal char> } @@ -60,9 +61,11 @@ @w{ Figure 13--1: Character defined names -- 1 } @end group +@end format Figure 13--2 lists some @i{character} construction and conversion @i{defined names}. +@format @group @noindent @w{ char-code char-name code-char } @@ -73,6 +76,7 @@ @w{ Figure 13--2: Character defined names -- 2} @end group +@end format @node Introduction to Scripts and Repertoires, Character Attributes, Introduction to Characters, Character Concepts @subsection Introduction to Scripts and Repertoires @@ -671,29 +675,29 @@ @i{[Function]} @end flushright -@code{{char=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{{char/=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char/=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{{char<}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char<}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{{char>}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char>}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{{char<=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char<=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{{char>=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{@r{char>=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-equal} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-not-equal} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-not-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-lessp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-greaterp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-not-greaterp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-not-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} -@code{char-not-lessp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} +@code{char-not-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1048,7 +1052,7 @@ @node digit-char, digit-char-p, alphanumericp, Characters Dictionary @subsection digit-char [Function] -@code{digit-char} @i{weight {&optional} radix} @result{} @i{char} +@code{digit-char} @i{weight @r{&optional} radix} @result{} @i{char} @subsubheading Arguments and Values:: @@ -1096,7 +1100,7 @@ @node digit-char-p, graphic-char-p, digit-char, Characters Dictionary @subsection digit-char-p [Function] -@code{digit-char-p} @i{char {&optional} radix} @result{} @i{weight} +@code{digit-char-p} @i{char @r{&optional} radix} @result{} @i{weight} @subsubheading Arguments and Values:: @@ -1182,7 +1186,7 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} , @ref{Character Syntax}, @ref{Documentation of Implementation-Defined Scripts} @@ -1275,7 +1279,7 @@ @subsubheading See Also:: -@ref{upper-case-p; lower-case-p; both-case-p} +@ref{upper-case-p} , @ref{alpha-char-p} , @@ -1340,7 +1344,7 @@ @subsubheading See Also:: -@ref{char-upcase; char-downcase} +@ref{char-upcase} , @b{char-downcase}, @ref{Characters With Case}, diff -uNr gcl-texi-orig/chap-14.texi gcl-texi/chap-14.texi --- gcl-texi-orig/chap-14.texi 1994-07-16 18:03:10 +0400 +++ gcl-texi/chap-14.texi 2002-10-17 20:53:05 +0400 @@ -18,6 +18,7 @@ is a compound data @i{object} having two components called the @i{car} and the @i{cdr}. +@format @group @noindent @w{ car cons rplacd } @@ -27,6 +28,7 @@ @w{ Figure 14--1: Some defined names relating to conses.} @end group +@end format Depending on context, a group of connected @i{conses} can be viewed in a variety of different ways. A variety of operations is provided to @@ -52,6 +54,7 @@ Typically, the @i{leaves} represent data while the branches establish some relationship among that data. +@format @group @noindent @w{ caaaar caddar cdar nsubst } @@ -69,6 +72,7 @@ @w{ Figure 14--2: Some defined names relating to trees.} @end group +@end format @menu * General Restrictions on Parameters that must be Trees:: @@ -114,6 +118,7 @@ is a chain of @i{conses} that has no termination because some @i{cons} in the chain is the @i{cdr} of a later @i{cons}. +@format @group @noindent @w{ append last nbutlast rest } @@ -130,6 +135,7 @@ @w{ Figure 14--3: Some defined names relating to lists.} @end group +@end format @menu * Lists as Association Lists:: @@ -147,6 +153,7 @@ where the @i{car} of each @i{cons} is the @i{key} and the @i{cdr} is the @i{value} associated with that @i{key}. +@format @group @noindent @w{ acons assoc-if pairlis rassoc-if } @@ -156,6 +163,7 @@ @w{ Figure 14--4: Some defined names related to assocation lists.} @end group +@end format @node Lists as Sets, General Restrictions on Parameters that must be Lists, Lists as Association Lists, Conses as Lists @subsubsection Lists as Sets @@ -163,6 +171,7 @@ @i{Lists} are sometimes viewed as sets by considering their elements unordered and by assuming there is no duplication of elements. +@format @group @noindent @w{ adjoin nset-difference set-difference union } @@ -173,6 +182,7 @@ @w{ Figure 14--5: Some defined names related to sets. } @end group +@end format @node General Restrictions on Parameters that must be Lists, , Lists as Sets, Conses as Lists @subsubsection General Restrictions on Parameters that must be Lists @@ -196,7 +206,7 @@ @c including dict-conses @menu -* list:: +* list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: @@ -210,7 +220,7 @@ * subst:: * tree-equal:: * copy-list:: -* list:: +* list (Function):: * list-length:: * listp:: * make-list:: @@ -228,7 +238,7 @@ * ldiff:: * nthcdr:: * rest:: -* member:: +* member (Function):: * mapc:: * acons:: * assoc:: @@ -247,7 +257,7 @@ * union:: @end menu -@node list, null (System Class), Conses Dictionary, Conses Dictionary +@node list (System Class), null (System Class), Conses Dictionary, Conses Dictionary @subsection list [System Class] @subsubheading Class Precedence List:: @@ -296,7 +306,7 @@ @ref{Left-Parenthesis}, @ref{Printing Lists and Conses} -@node null (System Class), cons (System Class), list, Conses Dictionary +@node null (System Class), cons (System Class), list (System Class), Conses Dictionary @subsection null [System Class] @subsubheading Class Precedence List:: @@ -408,7 +418,7 @@ @subsubheading See Also:: -@ref{list} +@ref{list (Function)} @subsubheading Notes:: If @i{object-2} is a @i{list}, @b{cons} can be thought of as @@ -677,6 +687,7 @@ order in which the corresponding operations are performed. Figure 14--6 defines the relationships precisely. +@format @group @noindent @w{ This @i{place} ... Is equivalent to this @i{place} ... } @@ -713,6 +724,7 @@ @w{ Figure 14--6: CAR and CDR variants } @end group +@end format @b{setf} can also be used with any of these functions to change an existing component of @i{x}, but @b{setf} will not make new @@ -749,9 +761,9 @@ @subsubheading See Also:: -@ref{rplaca; rplacd} +@ref{rplaca} , -@ref{first; second; third; fourth; fifth; sixth; seventh; eighth; ninth; tenth} +@ref{first} , @ref{rest} @@ -821,9 +833,9 @@ @node sublis, subst, copy-tree, Conses Dictionary @subsection sublis, nsublis [Function] -@code{sublis} @i{alist tree {&key} key test test-not} @result{} @i{new-tree} +@code{sublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} -@code{nsublis} @i{alist tree {&key} key test test-not} @result{} @i{new-tree} +@code{nsublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} @subsubheading Arguments and Values:: @@ -906,7 +918,7 @@ @subsubheading See Also:: -@ref{subst; subst-if; subst-if-not; nsubst; nsubst-if; nsubst-if-not} +@ref{subst} , @ref{Compiler Terminology}, @@ -939,17 +951,17 @@ @i{[Function]} @end flushright -@code{subst} @i{new old tree {&key} key test test-not} @result{} @i{new-tree} +@code{subst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} -@code{subst-if} @i{new predicate tree {&key} key} @result{} @i{new-tree} +@code{subst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} -@code{subst-if-not} @i{new predicate tree {&key} key} @result{} @i{new-tree} +@code{subst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} -@code{nsubst} @i{new old tree {&key} key test test-not} @result{} @i{new-tree} +@code{nsubst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} -@code{nsubst-if} @i{new predicate tree {&key} key} @result{} @i{new-tree} +@code{nsubst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} -@code{nsubst-if-not} @i{new predicate tree {&key} key} @result{} @i{new-tree} +@code{nsubst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} @subsubheading Arguments and Values:: @@ -1048,7 +1060,7 @@ @subsubheading See Also:: -@ref{substitute; substitute-if; substitute-if-not; nsubstitute; nsubstitute-if; nsubstitute-if-not} +@ref{substitute} , @b{nsubstitute}, @@ -1081,7 +1093,7 @@ @node tree-equal, copy-list, subst, Conses Dictionary @subsection tree-equal [Function] -@code{tree-equal} @i{tree-1 tree-2 {&key} test test-not} @result{} @i{generalized-boolean} +@code{tree-equal} @i{tree-1 tree-2 @r{&key} test test-not} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1148,7 +1160,7 @@ The @t{:test-not} parameter is deprecated. -@node copy-list, list, tree-equal, Conses Dictionary +@node copy-list, list (Function), tree-equal, Conses Dictionary @subsection copy-list [Function] @code{copy-list} @i{list} @result{} @i{copy} @@ -1203,12 +1215,12 @@ The copy created is @b{equal} to @i{list}, but not @b{eq}. -@node list, list-length, copy-list, Conses Dictionary +@node list (Function), list-length, copy-list, Conses Dictionary @subsection list, list* [Function] -@code{list} @i{{&rest} objects} @result{} @i{list} +@code{list} @i{@r{&rest} objects} @result{} @i{list} -@code{list*} @i{{&rest} objects^+} @result{} @i{result} +@code{list*} @i{@r{&rest} objects^+} @result{} @i{result} @subsubheading Arguments and Values:: @@ -1266,7 +1278,7 @@ (list* @i{x}) @equiv{} @i{x} @end example -@node list-length, listp, list, Conses Dictionary +@node list-length, listp, list (Function), Conses Dictionary @subsection list-length [Function] @code{list-length} @i{list} @result{} @i{length} @@ -1370,7 +1382,7 @@ @node make-list, push, listp, Conses Dictionary @subsection make-list [Function] -@code{make-list} @i{size {&key} initial-element} @result{} @i{list} +@code{make-list} @i{size @r{&key} initial-element} @result{} @i{list} @subsubheading Arguments and Values:: @@ -1404,7 +1416,7 @@ @ref{cons} , -@ref{list} +@ref{list (Function)} @node push, pop, make-list, Conses Dictionary @subsection push [Macro] @@ -1619,7 +1631,7 @@ @subsubheading See Also:: -@ref{car; cdr; caar; cadr; cdar; cddr; caaar; caadr; cadar; caddr; cdaar; cdadr; cddar; cdddr; caaaar; caaadr; caadar; caaddr; cadaar; cadadr; caddar; cadddr; cdaaar; cdaadr; cdadar; cdaddr; cddaar; cddadr; cdddar; cddddr} +@ref{car} , @ref{nth} @@ -1690,7 +1702,7 @@ @ref{elt} , -@ref{first; second; third; fourth; fifth; sixth; seventh; eighth; ninth; tenth} +@ref{first} , @ref{nthcdr} @@ -1787,7 +1799,7 @@ @node nconc, append, null, Conses Dictionary @subsection nconc [Function] -@code{nconc} @i{{&rest} lists} @result{} @i{concatenated-list} +@code{nconc} @i{@r{&rest} lists} @result{} @i{concatenated-list} @subsubheading Arguments and Values:: @@ -1863,7 +1875,7 @@ @node append, revappend, nconc, Conses Dictionary @subsection append [Function] -@code{append} @i{{&rest} lists} @result{} @i{result} +@code{append} @i{@r{&rest} lists} @result{} @i{result} @subsubheading Arguments and Values:: @@ -1975,7 +1987,7 @@ @subsubheading See Also:: -@ref{reverse; nreverse} +@ref{reverse} , @b{nreverse}, @ref{nconc} @@ -1994,9 +2006,9 @@ @node butlast, last, revappend, Conses Dictionary @subsection butlast, nbutlast [Function] -@code{butlast} @i{list {&optional} n} @result{} @i{result-list} +@code{butlast} @i{list @r{&optional} n} @result{} @i{result-list} -@code{nbutlast} @i{list {&optional} n} @result{} @i{result-list} +@code{nbutlast} @i{list @r{&optional} n} @result{} @i{result-list} @subsubheading Arguments and Values:: @@ -2069,7 +2081,7 @@ @node last, ldiff, butlast, Conses Dictionary @subsection last [Function] -@code{last} @i{list {&optional} n} @result{} @i{tail} +@code{last} @i{list @r{&optional} n} @result{} @i{tail} @subsubheading Arguments and Values:: @@ -2126,7 +2138,7 @@ @subsubheading See Also:: -@ref{butlast; nbutlast} +@ref{butlast} , @ref{nth} @@ -2221,7 +2233,7 @@ @subsubheading See Also:: -@ref{set-difference; nset-difference} +@ref{set-difference} @subsubheading Notes:: @@ -2307,7 +2319,7 @@ , @ref{rest} -@node rest, member, nthcdr, Conses Dictionary +@node rest, member (Function), nthcdr, Conses Dictionary @subsection rest [Accessor] @code{rest} @i{list} @result{} @i{tail} @@ -2355,14 +2367,14 @@ when the argument is to being subjectively viewed as a @i{list} rather than as a @i{cons}. -@node member, mapc, rest, Conses Dictionary +@node member (Function), mapc, rest, Conses Dictionary @subsection member, member-if, member-if-not [Function] -@code{member} @i{item list {&key} key test test-not} @result{} @i{tail} +@code{member} @i{item list @r{&key} key test test-not} @result{} @i{tail} -@code{member-if} @i{predicate list {&key} key} @result{} @i{tail} +@code{member-if} @i{predicate list @r{&key} key} @result{} @i{tail} -@code{member-if-not} @i{predicate list {&key} key} @result{} @i{tail} +@code{member-if-not} @i{predicate list @r{&key} key} @result{} @i{tail} @subsubheading Arguments and Values:: @@ -2422,9 +2434,9 @@ @subsubheading See Also:: -@ref{find; find-if; find-if-not} +@ref{find} , -@ref{position; position-if; position-if-not} +@ref{position} , @ref{Traversal Rules and Side Effects} @@ -2447,20 +2459,20 @@ where @t{a} was found (assuming a check has been made that @b{member} did not return @b{nil}). -@node mapc, acons, member, Conses Dictionary +@node mapc, acons, member (Function), Conses Dictionary @subsection mapc, mapcar, mapcan, mapl, maplist, mapcon [Function] -@code{mapc} @i{function {&rest} lists^+} @result{} @i{list-1} +@code{mapc} @i{function @r{&rest} lists^+} @result{} @i{list-1} -@code{mapcar} @i{function {&rest} lists^+} @result{} @i{result-list} +@code{mapcar} @i{function @r{&rest} lists^+} @result{} @i{result-list} -@code{mapcan} @i{function {&rest} lists^+} @result{} @i{concatenated-results} +@code{mapcan} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} -@code{mapl} @i{function {&rest} lists^+} @result{} @i{list-1} +@code{mapl} @i{function @r{&rest} lists^+} @result{} @i{list-1} -@code{maplist} @i{function {&rest} lists^+} @result{} @i{result-list} +@code{maplist} @i{function @r{&rest} lists^+} @result{} @i{result-list} -@code{mapcon} @i{function {&rest} lists^+} @result{} @i{concatenated-results} +@code{mapcon} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} @subsubheading Arguments and Values:: @@ -2627,7 +2639,7 @@ @subsubheading See Also:: -@ref{assoc; assoc-if; assoc-if-not} +@ref{assoc} , @ref{pairlis} @@ -2640,11 +2652,11 @@ @node assoc, copy-alist, acons, Conses Dictionary @subsection assoc, assoc-if, assoc-if-not [Function] -@code{assoc} @i{item alist {&key} key test test-not} @result{} @i{entry} +@code{assoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} -@code{assoc-if} @i{predicate alist {&key} key} @result{} @i{entry} +@code{assoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} -@code{assoc-if-not} @i{predicate alist {&key} key} @result{} @i{entry} +@code{assoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} @subsubheading Arguments and Values:: @@ -2711,13 +2723,13 @@ @subsubheading See Also:: -@ref{rassoc; rassoc-if; rassoc-if-not} +@ref{rassoc} , -@ref{find; find-if; find-if-not} +@ref{find} , -@ref{member; member-if; member-if-not} +@ref{member (Function)} , -@ref{position; position-if; position-if-not} +@ref{position} , @ref{Traversal Rules and Side Effects} @@ -2798,7 +2810,7 @@ @node pairlis, rassoc, copy-alist, Conses Dictionary @subsection pairlis [Function] -@code{pairlis} @i{keys data {&optional} alist} @result{} @i{new-alist} +@code{pairlis} @i{keys data @r{&optional} alist} @result{} @i{new-alist} @subsubheading Arguments and Values:: @@ -2864,11 +2876,11 @@ @node rassoc, get-properties, pairlis, Conses Dictionary @subsection rassoc, rassoc-if, rassoc-if-not [Function] -@code{rassoc} @i{item alist {&key} key test test-not} @result{} @i{entry} +@code{rassoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} -@code{rassoc-if} @i{predicate alist {&key} key} @result{} @i{entry} +@code{rassoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} -@code{rassoc-if-not} @i{predicate alist {&key} key} @result{} @i{entry} +@code{rassoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} @subsubheading Arguments and Values:: @@ -2919,7 +2931,7 @@ @subsubheading See Also:: -@ref{assoc; assoc-if; assoc-if-not} +@ref{assoc} , @ref{Traversal Rules and Side Effects} @@ -3001,9 +3013,9 @@ @node getf, remf, get-properties, Conses Dictionary @subsection getf [Accessor] -@code{getf} @i{plist indicator {&optional} default} @result{} @i{value} +@code{getf} @i{plist indicator @r{&optional} default} @result{} @i{value} -(setf (@code{ getf} @i{place indicator {&optional} default}) new-value)@* +(setf (@code{ getf} @i{place indicator @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: @@ -3081,7 +3093,7 @@ , @ref{get-properties} , -@ref{setf; psetf} +@ref{setf} , @ref{Function Call Forms as Places} @@ -3163,9 +3175,9 @@ @node intersection, adjoin, remf, Conses Dictionary @subsection intersection, nintersection [Function] -@code{intersection} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{intersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} -@code{nintersection} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{nintersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @@ -3266,7 +3278,7 @@ @subsubheading See Also:: -@ref{union; nunion} +@ref{union} , @ref{Compiler Terminology}, @@ -3284,7 +3296,7 @@ @node adjoin, pushnew, intersection, Conses Dictionary @subsection adjoin [Function] -@code{adjoin} @i{item list {&key} key test test-not} @result{} @i{new-list} +@code{adjoin} @i{item list @r{&key} key test test-not} @result{} @i{new-list} @subsubheading Arguments and Values:: @@ -3355,7 +3367,7 @@ @node pushnew, set-difference, adjoin, Conses Dictionary @subsection pushnew [Macro] -@code{pushnew} @i{item place {&key} key test test-not}@* +@code{pushnew} @i{item place @r{&key} key test test-not}@* @result{} @i{new-place-value} @subsubheading Arguments and Values:: @@ -3455,9 +3467,9 @@ @node set-difference, set-exclusive-or, pushnew, Conses Dictionary @subsection set-difference, nset-difference [Function] -@code{set-difference} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{set-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} -@code{nset-difference} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{nset-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @@ -3564,9 +3576,9 @@ @node set-exclusive-or, subsetp, set-difference, Conses Dictionary @subsection set-exclusive-or, nset-exclusive-or [Function] -@code{set-exclusive-or} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{set-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} -@code{nset-exclusive-or} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{nset-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @@ -3660,7 +3672,7 @@ @node subsetp, union, set-exclusive-or, Conses Dictionary @subsection subsetp [Function] -@code{subsetp} @i{list-1 list-2 {&key} key test test-not} @result{} @i{generalized-boolean} +@code{subsetp} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -3732,9 +3744,9 @@ @node union, , subsetp, Conses Dictionary @subsection union, nunion [Function] -@code{union} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{union} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} -@code{nunion} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} +@code{nunion} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} @subsubheading Arguments and Values:: @@ -3827,7 +3839,7 @@ @subsubheading See Also:: -@ref{intersection; nintersection} +@ref{intersection} , @ref{Compiler Terminology}, diff -uNr gcl-texi-orig/chap-15.texi gcl-texi/chap-15.texi --- gcl-texi-orig/chap-15.texi 1994-07-16 18:03:09 +0400 +++ gcl-texi/chap-15.texi 2002-10-17 20:53:05 +0400 @@ -148,6 +148,7 @@ Figure 15--1 lists some @i{defined names} that are applicable to @i{array} creation, @i{access}, and information operations. +@format @group @noindent @w{ adjust-array array-in-bounds-p svref } @@ -163,6 +164,7 @@ @w{ Figure 15--1: General Purpose Array-Related Defined Names } @end group +@end format @menu * Array Upgrading:: @@ -227,6 +229,7 @@ most information about @i{strings} does not appear in this chapter; see instead @ref{Strings}. +@format @group @noindent @w{ char string-equal string-upcase } @@ -243,6 +246,7 @@ @w{ Figure 15--2: Operators that Manipulate Strings } @end group +@end format @i{Vectors} whose @i{elements} are restricted to @i{type} @b{bit} are called @i{bit vectors} @@ -251,6 +255,7 @@ @i{Bit vectors} are of @i{type} @b{bit-vector}. Figure 15--3 lists some @i{defined names} for operations on @i{bit arrays}. +@format @group @noindent @w{ bit bit-ior bit-orc2 } @@ -263,6 +268,7 @@ @w{ Figure 15--3: Operators that Manipulate Bit Arrays} @end group +@end format @c end of including concept-arrays @@ -304,7 +310,7 @@ * vector-pop:: * vector-push:: * vectorp:: -* bit:: +* bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p:: @@ -347,7 +353,7 @@ (@code{array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) -@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}{*}@r{)}} +@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} @subsubheading Compound Type Specifier Arguments:: @@ -451,7 +457,7 @@ (@code{simple-array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) -@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}{*}@r{)}} +@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} @subsubheading Compound Type Specifier Arguments:: @@ -506,7 +512,7 @@ @subsubheading Compound Type Specifier Syntax:: -(@code{vector}@{@i{@t{[}@{element-type | @b{*}@} @r{[}@{size | @b{*}@}{]}@t{]}}@}) +(@code{vector}@{@i{@t{[}@{element-type | @b{*}@} @r{[}@{size | @b{*}@}@r{]}@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @@ -684,7 +690,7 @@ @node make-array, adjust-array, simple-bit-vector, Arrays Dictionary @subsection make-array [Function] -@code{make-array} @i{dimensions {&key} element-type +@code{make-array} @i{dimensions @r{&key} element-type initial-element initial-contents adjustable @@ -946,7 +952,7 @@ @node adjust-array, adjustable-array-p, make-array, Arrays Dictionary @subsection adjust-array [Function] -@code{adjust-array} @i{array new-dimensions {&key} element-type +@code{adjust-array} @i{array new-dimensions @r{&key} element-type initial-element initial-contents fill-pointer @@ -1240,9 +1246,9 @@ @node aref, array-dimension, adjustable-array-p, Arrays Dictionary @subsection aref [Accessor] -@code{aref} @i{array {&rest} subscripts} @result{} @i{element} +@code{aref} @i{array @r{&rest} subscripts} @result{} @i{element} -(setf (@code{ aref} @i{array {&rest} subscripts}) new-element)@* +(setf (@code{ aref} @i{array @r{&rest} subscripts}) new-element)@* @subsubheading Arguments and Values:: @@ -1288,9 +1294,9 @@ @subsubheading See Also:: -@ref{bit} +@ref{bit (Array)} , -@ref{char; schar} +@ref{char} , @ref{elt} , @@ -1529,7 +1535,7 @@ @node array-in-bounds-p, array-rank, array-displacement, Arrays Dictionary @subsection array-in-bounds-p [Function] -@code{array-in-bounds-p} @i{array {&rest} subscripts} @result{} @i{generalized-boolean} +@code{array-in-bounds-p} @i{array @r{&rest} subscripts} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1605,7 +1611,7 @@ @node array-row-major-index, array-total-size, array-rank, Arrays Dictionary @subsection array-row-major-index [Function] -@code{array-row-major-index} @i{array {&rest} subscripts} @result{} @i{index} +@code{array-row-major-index} @i{array @r{&rest} subscripts} @result{} @i{index} @subsubheading Arguments and Values:: @@ -1832,7 +1838,7 @@ @node upgraded-array-element-type, array-dimension-limit, row-major-aref, Arrays Dictionary @subsection upgraded-array-element-type [Function] -@code{upgraded-array-element-type} @i{typespec {&optional} environment} @result{} @i{upgraded-typespec} +@code{upgraded-array-element-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} @subsubheading Arguments and Values:: @@ -2042,7 +2048,7 @@ @node vector, vector-pop, svref, Arrays Dictionary @subsection vector [Function] -@code{vector} @i{{&rest} objects} @result{} @i{vector} +@code{vector} @i{@r{&rest} objects} @result{} @i{vector} @subsubheading Arguments and Values:: @@ -2075,10 +2081,10 @@ @b{vector} is analogous to @b{list}. @example - (vector a{{}_1} a{{}_2} ... a{{}_n}) + (vector a_1 a_2 ... a_n) @equiv{} (make-array (list @i{n}) :element-type t :initial-contents - (list a{{}_1} a{{}_2} ... a{{}_n})) + (list a_1 a_2 ... a_n)) @end example @node vector-pop, vector-push, vector, Arrays Dictionary @@ -2127,7 +2133,7 @@ @subsubheading See Also:: -@ref{vector-push; vector-push-extend} +@ref{vector-push} , @b{vector-push-extend}, @ref{fill-pointer} @@ -2136,7 +2142,7 @@ @code{vector-push} @i{new-element vector} @result{} @i{new-index-p} -@code{vector-push-extend} @i{new-element vector {&optional} extension} @result{} @i{new-index} +@code{vector-push-extend} @i{new-element vector @r{&optional} extension} @result{} @i{new-index} @subsubheading Arguments and Values:: @@ -2221,7 +2227,7 @@ , @ref{vector-pop} -@node vectorp, bit, vector-push, Arrays Dictionary +@node vectorp, bit (Array), vector-push, Arrays Dictionary @subsection vectorp [Function] @code{vectorp} @i{object} @result{} @i{generalized-boolean} @@ -2252,14 +2258,14 @@ (vectorp @i{object}) @equiv{} (typep @i{object} 'vector) @end example -@node bit, bit-and, vectorp, Arrays Dictionary +@node bit (Array), bit-and, vectorp, Arrays Dictionary @subsection bit, sbit [Accessor] -@code{bit} @i{bit-array {&rest} subscripts} @result{} @i{bit} +@code{bit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} -@code{sbit} @i{bit-array {&rest} subscripts} @result{} @i{bit} +@code{sbit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} -(setf (@code{bit} @i{bit-array {&rest} subscripts}) new-bit)@*(setf (@code{sbit} @i{bit-array {&rest} subscripts}) new-bit)@* +(setf (@code{bit} @i{bit-array @r{&rest} subscripts}) new-bit)@*(setf (@code{sbit} @i{bit-array @r{&rest} subscripts}) new-bit)@* @subsubheading Arguments and Values:: @@ -2308,34 +2314,34 @@ @b{bit} and @b{sbit}, unlike @b{char} and @b{schar}, allow the first argument to be an @i{array} of any @i{rank}. -@node bit-and, bit-vector-p, bit, Arrays Dictionary +@node bit-and, bit-vector-p, bit (Array), Arrays Dictionary @subsection bit-and, bit-andc1, bit-andc2, bit-eqv, @subheading bit-ior, bit-nand, bit-nor, bit-not, bit-orc1, bit-orc2, bit-xor @flushright @i{[Function]} @end flushright -@code{bit-and} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-and} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-andc1} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-andc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-andc2} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-andc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-eqv} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-eqv} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-ior} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-ior} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-nand} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-nand} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-nor} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-nor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-orc1} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-orc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-orc2} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-orc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-xor} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-xor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} -@code{bit-not} @i{bit-array {&optional} opt-arg} @result{} @i{resulting-bit-array} +@code{bit-not} @i{bit-array @r{&optional} opt-arg} @result{} @i{resulting-bit-array} @subsubheading Arguments and Values:: @@ -2374,6 +2380,7 @@ performed by each of the @i{functions}. 2 +@format @group @noindent @w{@b{Function} @b{Operation} } @@ -2393,6 +2400,7 @@ @w{@w{ Figure 15--3: Bit-wise Logical Operations on Bit Arrays} } @end group +@end format @subsubheading Examples:: @example @@ -2413,7 +2421,7 @@ @subsubheading See Also:: @b{lognot}, -@ref{logand; logandc1; logandc2; logeqv; logior; lognand; lognor; lognot; logorc1; logorc2; logxor} +@ref{logand} @node bit-vector-p, simple-bit-vector-p, bit-and, Arrays Dictionary @subsection bit-vector-p [Function] diff -uNr gcl-texi-orig/chap-16.texi gcl-texi/chap-16.texi --- gcl-texi-orig/chap-16.texi 1994-07-16 18:03:08 +0400 +++ gcl-texi/chap-16.texi 2002-10-17 20:53:05 +0400 @@ -378,17 +378,17 @@ @i{[Function]} @end flushright -@code{string-upcase} @i{string {&key} start end} @result{} @i{cased-string} +@code{string-upcase} @i{string @r{&key} start end} @result{} @i{cased-string} -@code{string-downcase} @i{string {&key} start end} @result{} @i{cased-string} +@code{string-downcase} @i{string @r{&key} start end} @result{} @i{cased-string} -@code{string-capitalize} @i{string {&key} start end} @result{} @i{cased-string} +@code{string-capitalize} @i{string @r{&key} start end} @result{} @i{cased-string} -@code{nstring-upcase} @i{string {&key} start end} @result{} @i{string} +@code{nstring-upcase} @i{string @r{&key} start end} @result{} @i{string} -@code{nstring-downcase} @i{string {&key} start end} @result{} @i{string} +@code{nstring-downcase} @i{string @r{&key} start end} @result{} @i{string} -@code{nstring-capitalize} @i{string {&key} start end} @result{} @i{string} +@code{nstring-capitalize} @i{string @r{&key} start end} @result{} @i{string} @subsubheading Arguments and Values:: @@ -480,7 +480,7 @@ @subsubheading See Also:: -@ref{char-upcase; char-downcase} +@ref{char-upcase} , @b{char-downcase} @subsubheading Notes:: @@ -545,29 +545,29 @@ @i{[Function]} @end flushright -@code{string=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} +@code{string=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} -@code{string/=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string/=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string<} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string<} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string>} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string>} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string<=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string<=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string>=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string>=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string-equal} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} +@code{string-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} -@code{string-not-equal} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string-not-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string-lessp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string-greaterp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string-not-greaterp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string-not-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} -@code{string-not-lessp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} +@code{string-not-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @subsubheading Arguments and Values:: @@ -684,7 +684,7 @@ @subsubheading See Also:: -@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} +@ref{char=} @subsubheading Notes:: @@ -728,7 +728,7 @@ @node make-string, , stringp, Strings Dictionary @subsection make-string [Function] -@code{make-string} @i{size {&key} initial-element element-type} @result{} @i{string} +@code{make-string} @i{size @r{&key} initial-element element-type} @result{} @i{string} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-17.texi gcl-texi/chap-17.texi --- gcl-texi-orig/chap-17.texi 1994-07-16 18:03:08 +0400 +++ gcl-texi/chap-17.texi 2002-10-17 20:53:05 +0400 @@ -34,6 +34,7 @@ a new @i{vector}, it always returns a @i{simple vector}. Similarly, any @i{strings} constructed will be @i{simple strings}. +@format @group @noindent @w{ concatenate length remove } @@ -56,6 +57,7 @@ @w{ Figure 17--1: Standardized Sequence Functions } @end group +@end format @menu * General Restrictions on Parameters that must be Sequences:: @@ -91,6 +93,7 @@ This control is offered on the basis of a @i{function} designated with either a @t{:test} or @t{:test-not} @i{argument}. +@format @group @noindent @w{ adjoin nset-exclusive-or search } @@ -108,6 +111,7 @@ @w{ Figure 17--2: Operators that have Two-Argument Tests to be Satisfied} @end group +@end format The object O might not be compared directly to E_i. If a @t{:key} @i{argument} is provided, @@ -193,6 +197,7 @@ as with the @i{functions} described in @ref{Satisfying a Two-Argument Test}, but rather on the basis of a one @i{argument} @i{predicate}. +@format @group @noindent @w{ assoc-if member-if rassoc-if } @@ -208,6 +213,7 @@ @w{ Figure 17--3: Operators that have One-Argument Tests to be Satisfied} @end group +@end format The element E_i might not be considered directly. If a @t{:key} @i{argument} is provided, @@ -409,7 +415,7 @@ @node fill, make-sequence, elt, Sequences Dictionary @subsection fill [Function] -@code{fill} @i{sequence item {&key} start end} @result{} @i{sequence} +@code{fill} @i{sequence item @r{&key} start end} @result{} @i{sequence} @subsubheading Arguments and Values:: @@ -464,7 +470,7 @@ @node make-sequence, subseq, fill, Sequences Dictionary @subsection make-sequence [Function] -@code{make-sequence} @i{result-type size {&key} initial-element} @result{} @i{sequence} +@code{make-sequence} @i{result-type size @r{&key} initial-element} @result{} @i{sequence} @subsubheading Arguments and Values:: @@ -540,9 +546,9 @@ @node subseq, map, make-sequence, Sequences Dictionary @subsection subseq [Accessor] -@code{subseq} @i{sequence start {&optional} end} @result{} @i{subsequence} +@code{subseq} @i{sequence start @r{&optional} end} @result{} @i{subsequence} -(setf (@code{ subseq} @i{sequence start {&optional} end}) new-subsequence)@* +(setf (@code{ subseq} @i{sequence start @r{&optional} end}) new-subsequence)@* @subsubheading Arguments and Values:: @@ -610,7 +616,7 @@ @node map, map-into, subseq, Sequences Dictionary @subsection map [Function] -@code{map} @i{result-type function {&rest} sequences^+} @result{} @i{result} +@code{map} @i{result-type function @r{&rest} sequences^+} @result{} @i{result} @subsubheading Arguments and Values:: @@ -698,7 +704,7 @@ @node map-into, reduce, map, Sequences Dictionary @subsection map-into [Function] -@code{map-into} @i{result-sequence function {&rest} sequences} @result{} @i{result-sequence} +@code{map-into} @i{result-sequence function @r{&rest} sequences} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @@ -778,7 +784,7 @@ @node reduce, count, map-into, Sequences Dictionary @subsection reduce [Function] -@code{reduce} @i{function sequence {&key} key from-end start end initial-value} @result{} @i{result} +@code{reduce} @i{function sequence @r{&key} key from-end start end initial-value} @result{} @i{result} @subsubheading Arguments and Values:: @@ -871,11 +877,11 @@ @node count, length, reduce, Sequences Dictionary @subsection count, count-if, count-if-not [Function] -@code{count} @i{item sequence {&key} from-end start end key test test-not} @result{} @i{n} +@code{count} @i{item sequence @r{&key} from-end start end key test test-not} @result{} @i{n} -@code{count-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{n} +@code{count-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} -@code{count-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{n} +@code{count-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} @subsubheading Arguments and Values:: @@ -1058,9 +1064,9 @@ @node sort, find, reverse, Sequences Dictionary @subsection sort, stable-sort [Function] -@code{sort} @i{sequence predicate {&key} key} @result{} @i{sorted-sequence} +@code{sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} -@code{stable-sort} @i{sequence predicate {&key} key} @result{} @i{sorted-sequence} +@code{stable-sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} @subsubheading Arguments and Values:: @@ -1198,11 +1204,11 @@ @node find, position, sort, Sequences Dictionary @subsection find, find-if, find-if-not [Function] -@code{find} @i{item sequence {&key} from-end test test-not start end key} @result{} @i{element} +@code{find} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{element} -@code{find-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{element} +@code{find-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} -@code{find-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{element} +@code{find-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} @subsubheading Arguments and Values:: @@ -1267,7 +1273,7 @@ @subsubheading See Also:: -@ref{position; position-if; position-if-not} +@ref{position} , @ref{Rules about Test Functions}, @@ -1282,11 +1288,11 @@ @node position, search, find, Sequences Dictionary @subsection position, position-if, position-if-not [Function] -@code{position} @i{item sequence {&key} from-end test test-not start end key} @result{} @i{position} +@code{position} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{position} -@code{position-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{position} +@code{position-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} -@code{position-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{position} +@code{position-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} @subsubheading Arguments and Values:: @@ -1344,7 +1350,7 @@ @subsubheading See Also:: -@ref{find; find-if; find-if-not} +@ref{find} , @ref{Traversal Rules and Side Effects} @@ -1359,7 +1365,7 @@ @subsection search [Function] @code{search} @i{sequence-1 sequence-2 - {&key} from-end test test-not + @r{&key} from-end test test-not key start1 start2 end1 end2}@* @result{} @i{position} @@ -1430,7 +1436,7 @@ @subsection mismatch [Function] @code{mismatch} @i{sequence-1 sequence-2 - {&key} from-end test test-not key start1 start2 end1 end2}@* + @r{&key} from-end test test-not key start1 start2 end1 end2}@* @result{} @i{position} @subsubheading Arguments and Values:: @@ -1506,7 +1512,7 @@ @node replace, substitute, mismatch, Sequences Dictionary @subsection replace [Function] -@code{replace} @i{sequence-1 sequence-2 {&key} start1 end1 start2 end2} @result{} @i{sequence-1} +@code{replace} @i{sequence-1 sequence-2 @r{&key} start1 end1 start2 end2} @result{} @i{sequence-1} @subsubheading Arguments and Values:: @@ -1582,25 +1588,25 @@ @end flushright @code{substitute} @i{newitem olditem sequence - {&key} from-end test + @r{&key} from-end test test-not start end count key}@* @result{} @i{result-sequence} -@code{substitute-if} @i{newitem predicate sequence {&key} from-end start end count key}@* +@code{substitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{result-sequence} -@code{substitute-if-not} @i{newitem predicate sequence {&key} from-end start end count key}@* +@code{substitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{result-sequence} @code{nsubstitute} @i{newitem olditem sequence - {&key} from-end test test-not start end count key}@* + @r{&key} from-end test test-not start end count key}@* @result{} @i{sequence} -@code{nsubstitute-if} @i{newitem predicate sequence {&key} from-end start end count key}@* +@code{nsubstitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{sequence} -@code{nsubstitute-if-not} @i{newitem predicate sequence {&key} from-end start end count key}@* +@code{nsubstitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* @result{} @i{sequence} @subsubheading Arguments and Values:: @@ -1734,7 +1740,7 @@ @subsubheading See Also:: -@ref{subst; subst-if; subst-if-not; nsubst; nsubst-if; nsubst-if-not} +@ref{subst} , @b{nsubst}, @@ -1770,7 +1776,7 @@ @node concatenate, merge, substitute, Sequences Dictionary @subsection concatenate [Function] -@code{concatenate} @i{result-type {&rest} sequences} @result{} @i{result-sequence} +@code{concatenate} @i{result-type @r{&rest} sequences} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @@ -1841,7 +1847,7 @@ @node merge, remove, concatenate, Sequences Dictionary @subsection merge [Function] -@code{merge} @i{result-type sequence-1 sequence-2 predicate {&key} key} @result{} @i{result-sequence} +@code{merge} @i{result-type sequence-1 sequence-2 predicate @r{&key} key} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @@ -1949,7 +1955,7 @@ @subsubheading See Also:: -@ref{sort; stable-sort} +@ref{sort} , @b{stable-sort}, @@ -1964,17 +1970,17 @@ @i{[Function]} @end flushright -@code{remove} @i{item sequence {&key} from-end test test-not start end count key} @result{} @i{result-sequence} +@code{remove} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} -@code{remove-if} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} +@code{remove-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} -@code{remove-if-not} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} +@code{remove-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} -@code{delete} @i{item sequence {&key} from-end test test-not start end count key} @result{} @i{result-sequence} +@code{delete} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} -@code{delete-if} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} +@code{delete-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} -@code{delete-if-not} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} +@code{delete-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} @subsubheading Arguments and Values:: @@ -2153,12 +2159,12 @@ @node remove-duplicates, , remove, Sequences Dictionary @subsection remove-duplicates, delete-duplicates [Function] -@code{remove-duplicates} @i{sequence {&key} +@code{remove-duplicates} @i{sequence @r{&key} from-end test test-not start end key}@* @result{} @i{result-sequence} -@code{delete-duplicates} @i{sequence {&key} +@code{delete-duplicates} @i{sequence @r{&key} from-end test test-not start end key}@* @result{} @i{result-sequence} diff -uNr gcl-texi-orig/chap-18.texi gcl-texi/chap-18.texi --- gcl-texi-orig/chap-18.texi 1994-07-16 18:03:08 +0400 +++ gcl-texi/chap-18.texi 2002-10-17 20:53:05 +0400 @@ -72,6 +72,7 @@ from the @i{secondary value} returned by @b{gethash}. @end table +@format @group @noindent @w{ clrhash hash-table-p remhash } @@ -82,6 +83,7 @@ @w{ Figure 18--1: Hash-table defined names } @end group +@end format @node Modifying Hash Table Keys, , Hash-Table Operations, Hash Table Concepts @subsection Modifying Hash Table Keys @@ -241,14 +243,14 @@ @subsubheading Notes:: The intent is that this mapping be implemented by a hashing mechanism, -such as that described in Section 6.4 ``Hashing'' of {The Art of Computer Programming, Volume 3} +such as that described in Section 6.4 ``Hashing'' of @b{The Art of Computer Programming, Volume 3} (pp506-549). In spite of this intent, no @i{conforming implementation} is required to use any particular technique to implement the mapping. @node make-hash-table, hash-table-p, hash-table, Hash Tables Dictionary @subsection make-hash-table [Function] -@code{make-hash-table} @i{{&key} test size rehash-size rehash-threshold} @result{} @i{hash-table} +@code{make-hash-table} @i{@r{&key} test size rehash-size rehash-threshold} @result{} @i{hash-table} @subsubheading Arguments and Values:: @@ -571,9 +573,9 @@ @node gethash, remhash, hash-table-test, Hash Tables Dictionary @subsection gethash [Accessor] -@code{gethash} @i{key hash-table {&optional} default} @result{} @i{value, present-p} +@code{gethash} @i{key hash-table @r{&optional} default} @result{} @i{value, present-p} -(setf (@code{ gethash} @i{key hash-table {&optional} default}) new-value)@* +(setf (@code{ gethash} @i{key hash-table @r{&optional} default}) new-value)@* @subsubheading Arguments and Values:: @@ -737,7 +739,7 @@ @subsection with-hash-table-iterator [Macro] @code{with-hash-table-iterator} @i{@r{(}name hash-table@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-19.texi gcl-texi/chap-19.texi --- gcl-texi-orig/chap-19.texi 1994-07-16 18:06:18 +0400 +++ gcl-texi/chap-19.texi 2002-10-17 20:59:17 +0400 @@ -124,6 +124,7 @@ Figure 19--1 lists some @i{defined names} that are applicable to @i{pathnames}. +@format @group @noindent @w{ *default-pathname-defaults* namestring pathname-name } @@ -139,6 +140,7 @@ @w{ Figure 19--1: Pathname Operations } @end group +@end format @node Parsing Namestrings Into Pathnames, , Pathnames as Filenames, Overview of Filenames @subsection Parsing Namestrings Into Pathnames @@ -281,9 +283,9 @@ For example, @example - ;; In a TOPS-20 implementation, which uses {@t{^}}V to quote + ;; In a TOPS-20 implementation, which uses @t{^}V to quote (NAMESTRING (MAKE-PATHNAME :HOST "OZ" :NAME "")) -@result{} #P"OZ:PS:{@t{^}}V" +@result{} #P"OZ:PS:@t{^}V" @i{NOT}@result{} #P"OZ:PS:" @end example @@ -298,6 +300,7 @@ Figure 19--2 lists the functions relating to @i{pathnames} that permit a @t{:case} argument: +@format @group @noindent @w{ make-pathname pathname-directory pathname-name } @@ -307,13 +310,14 @@ @w{ Figure 19--2: Pathname functions using a :CASE argument} @end group +@end format @node Local Case in Pathname Components, Common Case in Pathname Components, Case in Pathname Components, Interpreting Pathname Component Values @subsubsection Local Case in Pathname Components For the functions in @i{Figure~19--2}, a value of @t{:local} -@IKindex{local} +@c @IKindex{local} for the @t{:case} argument (the default for these functions) indicates that the functions should receive and yield @i{strings} in component values @@ -330,7 +334,7 @@ For the functions in @i{Figure~19--2}, a value of @t{:common} -@IKindex{common} +@c @IKindex{common} for the @t{:case} argument that these @i{functions} should receive and yield @i{strings} in component values according to the following conventions: @@ -368,7 +372,7 @@ @subsubsection :WILD as a Component Value If @t{:wild} -@IKindex{wild} +@c @IKindex{wild} is the value of a @i{pathname} component, that component is considered to be a wildcard, which matches anything. @@ -387,13 +391,13 @@ @t{(:absolute :wild-inferiors)}, or the same as @t{(:absolute :wild)} in a @i{file system} that does not support @t{:wild-inferiors}. -@IKindex{wild-inferiors} +@c @IKindex{wild-inferiors} @node ->UNSPECIFIC as a Component Value, Relation between component values NIL and ->UNSPECIFIC, ->WILD as a Component Value, Interpreting Pathname Component Values @subsubsection :UNSPECIFIC as a Component Value If @t{:unspecific} -@IKindex{unspecific} +@c @IKindex{unspecific} is the value of a @i{pathname} component, the component is considered to be ``absent'' or to ``have no meaning'' @@ -507,10 +511,10 @@ The directory can be a @i{list} of @i{strings} and @i{symbols}. The @i{car} of the @i{list} is one of the symbols @t{:absolute} -@IKindex{absolute} +@c @IKindex{absolute} or @t{:relative} -@IKindex{relative} +@c @IKindex{relative} , meaning: @table @asis @@ -550,14 +554,15 @@ signals an error of @i{type} @b{file-error}. For example, Unix does not support @t{:wild-inferiors} in most implementations. -@IKindex{wild} +@c @IKindex{wild} -@IKindex{wild-inferiors} +@c @IKindex{wild-inferiors} -@IKindex{up} +@c @IKindex{up} -@IKindex{back} +@c @IKindex{back} +@format @group @noindent @w{ Symbol Meaning } @@ -570,6 +575,7 @@ @w{ Figure 19--3: Special Markers In Directory Component } @end group +@end format The following notes apply to the previous figure: @@ -782,7 +788,7 @@ not a structural description of @i{objects}.) @w{@i{logical-pathname} ::=@r{[}!@i{host} @i{host-marker}@r{]} } -@w{ @r{[}!@i{@i{relative-directory-marker}}@r{]} @{!@i{directory} @i{directory-marker}@}{*} } +@w{ @r{[}!@i{@i{relative-directory-marker}}@r{]} @{!@i{directory} @i{directory-marker}@}* } @w{ @r{[}!@i{name}@r{]} @r{[}@i{type-marker} !@i{type} @r{[}@i{version-marker} !@i{version}@r{]}@r{]}} @w{@i{host} ::=!@i{word}} @@ -1061,7 +1067,7 @@ @node make-pathname, pathnamep, pathname, Filenames Dictionary @subsection make-pathname [Function] -@code{make-pathname} @i{{&key} host device directory name type version defaults case}@* +@code{make-pathname} @i{@r{&key} host device directory name type version defaults case}@* @result{} @i{pathname} @subsubheading Arguments and Values:: @@ -1238,15 +1244,15 @@ @i{[Function]} @end flushright -@code{pathname-host} @i{pathname {&key} case} @result{} @i{host} +@code{pathname-host} @i{pathname @r{&key} case} @result{} @i{host} -@code{pathname-device} @i{pathname {&key} case} @result{} @i{device} +@code{pathname-device} @i{pathname @r{&key} case} @result{} @i{device} -@code{pathname-directory} @i{pathname {&key} case} @result{} @i{directory} +@code{pathname-directory} @i{pathname @r{&key} case} @result{} @i{directory} -@code{pathname-name} @i{pathname {&key} case} @result{} @i{name} +@code{pathname-name} @i{pathname @r{&key} case} @result{} @i{name} -@code{pathname-type} @i{pathname {&key} case} @result{} @i{type} +@code{pathname-type} @i{pathname @r{&key} case} @result{} @i{type} @code{pathname-version} @i{pathname} @result{} @i{version} @@ -1704,7 +1710,7 @@ @code{host-namestring} @i{pathname} @result{} @i{namestring} -@code{enough-namestring} @i{pathname {&optional} defaults} @result{} @i{namestring} +@code{enough-namestring} @i{pathname @r{&optional} defaults} @result{} @i{namestring} @subsubheading Arguments and Values:: @@ -1809,7 +1815,7 @@ @node parse-namestring, wild-pathname-p, namestring, Filenames Dictionary @subsection parse-namestring [Function] -@code{parse-namestring} @i{thing {&optional} host default-pathname {&key} start end junk-allowed}@* +@code{parse-namestring} @i{thing @r{&optional} host default-pathname @r{&key} start end junk-allowed}@* @result{} @i{pathname, position} @subsubheading Arguments and Values:: @@ -1963,7 +1969,7 @@ @node wild-pathname-p, pathname-match-p, parse-namestring, Filenames Dictionary @subsection wild-pathname-p [Function] -@code{wild-pathname-p} @i{pathname {&optional} field-key} @result{} @i{generalized-boolean} +@code{wild-pathname-p} @i{pathname @r{&optional} field-key} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -2069,7 +2075,7 @@ @node translate-logical-pathname, translate-pathname, pathname-match-p, Filenames Dictionary @subsection translate-logical-pathname [Function] -@code{translate-logical-pathname} @i{pathname {&key}} @result{} @i{physical-pathname} +@code{translate-logical-pathname} @i{pathname @r{&key}} @result{} @i{physical-pathname} @subsubheading Arguments and Values:: @@ -2150,7 +2156,7 @@ @node translate-pathname, merge-pathnames, translate-logical-pathname, Filenames Dictionary @subsection translate-pathname [Function] -@code{translate-pathname} @i{source from-wildcard to-wildcard {&key}}@* +@code{translate-pathname} @i{source from-wildcard to-wildcard @r{&key}}@* @result{} @i{translated-pathname} @subsubheading Arguments and Values:: @@ -2273,9 +2279,9 @@ @subsubheading See Also:: -@ref{namestring; file-namestring; directory-namestring; host-namestring; enough-namestring} +@ref{namestring} , -@ref{pathname-host; pathname-device; pathname-directory; pathname-name; pathname-type; pathname-version} +@ref{pathname-host} , @b{pathname}, @@ -2318,7 +2324,7 @@ @node merge-pathnames, , translate-pathname, Filenames Dictionary @subsection merge-pathnames [Function] -@code{merge-pathnames} @i{pathname {&optional} default-pathname default-version}@* +@code{merge-pathnames} @i{pathname @r{&optional} default-pathname default-version}@* @result{} @i{merged-pathname} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-1.texi gcl-texi/chap-1.texi --- gcl-texi-orig/chap-1.texi 1994-07-16 18:02:58 +0400 +++ gcl-texi/chap-1.texi 2002-10-17 21:52:14 +0400 @@ -49,7 +49,7 @@ predominant dialects of Lisp, both arising from these early efforts: MacLisp and Interlisp. For further information about very early Lisp dialects, -see {The Anatomy of Lisp} or {Lisp 1.5 Programmer's Manual}. +see @b{The Anatomy of Lisp} or @b{Lisp 1.5 Programmer's Manual}. MacLisp improved on the Lisp~1.5 notion of special variables and error handling. MacLisp also introduced the concept of functions that could take @@ -58,14 +58,14 @@ on execution speed. By the end of the 1970's, MacLisp was in use at over 50 sites. For further information about Maclisp, -see {Maclisp Reference Manual, Revision~0} or {The Revised Maclisp Manual}. +see @b{Maclisp Reference Manual, Revision~0} or @b{The Revised Maclisp Manual}. Interlisp introduced many ideas into Lisp programming environments and methodology. One of the Interlisp ideas that influenced @r{Common Lisp} was an iteration construct implemented by Warren Teitelman that inspired the @b{loop} macro used both on the Lisp Machines and in MacLisp, and now in @r{Common Lisp}. For further information about Interlisp, -see {Interlisp Reference Manual}. +see @b{Interlisp Reference Manual}. Although the first implementations of Lisp were on the IBM~704 and the IBM~7090, later work focussed on the DEC @@ -83,14 +83,14 @@ that enabled fast function calling. But the limitations of the PDP-10 were evident by 1973: it supported a small number of researchers using Lisp, and the small, 18-bit address -space (2^{18} = 262,144 words) limited the size of a single +space (2^18 = 262,144 words) limited the size of a single program. One response to the address space problem was the Lisp Machine, a special-purpose computer designed to run Lisp programs. The other response was to use general-purpose computers with address spaces larger than 18~bits, such as the DEC VAX and the S-1~Mark~IIA. -For further information about S-1 Common Lisp, see ``{S-1 Common Lisp Implementation}.'' +For further information about S-1 Common Lisp, see @b{S-1 Common Lisp Implementation}. The Lisp machine concept was developed in the late 1960's. In the early 1970's, Peter Deutsch, working with @@ -107,7 +107,7 @@ Machine Lisp became available on the early MIT Lisp Machines. Commercial Lisp machines from Xerox, Lisp Machines (LMI), and Symbolics were on the market by 1981. -For further information about Lisp Machine Lisp, see {Lisp Machine Manual}. +For further information about Lisp Machine Lisp, see @b{Lisp Machine Manual}. During the late 1970's, Lisp Machine Lisp began to expand towards a much fuller language. Sophisticated lambda lists, @@ -132,7 +132,7 @@ to Lisp implementation. Eventually the S-1 and NIL groups collaborated. For further information about the NIL project, -see ``{NIL---A Perspective}.'' +see @b{NIL---A Perspective}. The first effort towards Lisp standardization was made in 1969, when Anthony Hearn and Martin Griss at the University of Utah @@ -142,7 +142,7 @@ optimizing compiler for Standard Lisp, and then an extended implementation known as Portable Standard Lisp (PSL). By the mid 1980's, PSL ran on about a dozen kinds of computers. -For further information about Standard Lisp, see ``{Standard LISP Report}.'' +For further information about Standard Lisp, see @b{Standard LISP Report}. PSL and Franz Lisp---a MacLisp-like dialect for Unix machines---were the first examples of widely available Lisp dialects on multiple @@ -159,7 +159,8 @@ closures, first-class continuations, and simplified syntax (no separation of value cells and function cells). Some of these contributions made a large impact on the design of @r{Common Lisp}. -For further information about Scheme, see {IEEE Standard for the Scheme Programming Language} or ``{Revised^3 Report on the Algorithmic Language Scheme}.'' +For further information about Scheme, see @b{IEEE Standard for the Scheme Programming Language} +or @b{Revised^3 Report on the Algorithmic Language Scheme}. In the late 1970's object-oriented programming concepts started to make a strong impact on Lisp. @@ -170,12 +171,13 @@ At Xerox, the experience with Smalltalk and Knowledge Representation Language (KRL) led to the development of Lisp Object Oriented Programming System (LOOPS) and later Common LOOPS. -For further information on Smalltalk, see {Smalltalk-80: The Language and its Implementation}. -For further information on Flavors, see {Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}. +For further information on Smalltalk, see @b{Smalltalk-80: The Language and its Implementation}. +For further information on Flavors, see @b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}. These systems influenced the design of the Common Lisp Object System (CLOS). CLOS was developed specifically for this standardization effort, -and was separately written up in ``Common Lisp Object System Specification.'' However, minor details +and was separately written up in @b{Common Lisp Object System Specification}. +However, minor details of its design have changed slightly since that publication, and that paper should not be taken as an authoritative reference to the semantics of the object system as described in this document. @@ -254,7 +256,7 @@ For information about data types, see @ref{Types and Classes}. Not all @i{types} and @i{classes} are defined in this chapter; many are defined in chapter corresponding to their topic--for example, -the numeric types are defined in @ref{Numbers}. +the numeric types are defined in @ref{Numbers (Numbers)}. For a complete list of @i{standardized} @i{types}, see @i{Figure~4--2}. @@ -271,32 +273,32 @@ @table @asis @item @t{*} -{The Anatomy of Lisp}, +@b{The Anatomy of Lisp}, John Allen, McGraw-Hill, Inc., 1978. @item @t{*} -{The Art of Computer Programming, Volume 3}, +@b{The Art of Computer Programming, Volume 3}, Donald E. Knuth, Addison-Wesley Company (Reading, MA), 1973. @item @t{*} -{The Art of the Metaobject Protocol}, +@b{The Art of the Metaobject Protocol}, Kiczales et al., MIT Press (Cambridge, MA), 1991. @item @t{*} -``Common Lisp Object System Specification,'' +@b{Common Lisp Object System Specification}, D. Bobrow, L. DiMichiel, R.P. Gabriel, S. Keene, G. Kiczales, D. Moon, @i{SIGPLAN Notices} V23, September, 1988. @item @t{*} -{Common Lisp: The Language}, +@b{Common Lisp: The Language}, Guy L. Steele Jr., Digital Press (Burlington, MA), 1984. @item @t{*} -{Common Lisp: The Language, Second Edition}, +@b{Common Lisp: The Language, Second Edition}, Guy L. Steele Jr., Digital Press (Bedford, MA), 1990. @item @t{*} -{Exceptional Situations in Lisp}, +@b{Exceptional Situations in Lisp}, Kent M. Pitman, @i{Proceedings of the First European Conference on the Practical Application of LISP\/} @@ -305,21 +307,21 @@ March 27-29, 1990. @item @t{*} -{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}, +@b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}, Howard I. Cannon, 1982. @item @t{*} -{IEEE Standard for Binary Floating-Point Arithmetic}, +@b{IEEE Standard for Binary Floating-Point Arithmetic}, ANSI/IEEE Std 754-1985, Institute of Electrical and Electronics Engineers, Inc. (New York), 1985. @item @t{*} -{IEEE Standard for the Scheme Programming Language}, +@b{IEEE Standard for the Scheme Programming Language}, IEEE Std 1178-1990, Institute of Electrical and Electronic Engineers, Inc. (New York), 1991. @item @t{*} -{Interlisp Reference Manual}, Third Revision, +@b{Interlisp Reference Manual}, Third Revision, Teitelman, Warren, et al, Xerox Palo Alto Research Center (Palo Alto, CA), 1978. @@ -331,66 +333,66 @@ ISO, 1983. @item @t{*} -{Lisp 1.5 Programmer's Manual}, +@b{Lisp 1.5 Programmer's Manual}, John McCarthy, MIT Press (Cambridge, MA), August, 1962. @item @t{*} -{Lisp Machine Manual}, +@b{Lisp Machine Manual}, D.L. Weinreb and D.A. Moon, Artificial Intelligence Laboratory, MIT (Cambridge, MA), July, 1981. @item @t{*} -{Maclisp Reference Manual, Revision~0}, +@b{Maclisp Reference Manual, Revision~0}, David A. Moon, Project MAC (Laboratory for Computer Science), MIT (Cambridge, MA), March, 1974. @item @t{*} -``{NIL---A Perspective},'' +@b{NIL---A Perspective}, JonL White, @i{Macsyma User's Conference}, 1979. @item @t{*} -{Performance and Evaluation of Lisp Programs}, +@b{Performance and Evaluation of Lisp Programs}, Richard P. Gabriel, MIT Press (Cambridge, MA), 1985. @item @t{*} -``{Principal Values and Branch Cuts in Complex APL},'' +@b{Principal Values and Branch Cuts in Complex APL}, Paul Penfield Jr., @i{APL 81 Conference Proceedings}, ACM SIGAPL (San Francisco, September 1981), 248-256. Proceedings published as @i{APL Quote Quad 12}, 1 (September 1981). @item @t{*} -{The Revised Maclisp Manual}, +@b{The Revised Maclisp Manual}, Kent M. Pitman, Technical Report 295, Laboratory for Computer Science, MIT (Cambridge, MA), May 1983. @item @t{*} -``{Revised^3 Report on the Algorithmic Language Scheme},'' +@b{Revised^3 Report on the Algorithmic Language Scheme}, Jonathan Rees and William Clinger (editors), @i{SIGPLAN Notices} V21, #12, December, 1986. @item @t{*} -``S-1 Common Lisp Implementation,'' +@b{S-1 Common Lisp Implementation}, R.A. Brooks, R.P. Gabriel, and G.L. Steele, @i{Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, 108-113, 1982. @item @t{*} -@i{Smalltalk-80: The Language and its Implementation}, +@b{Smalltalk-80: The Language and its Implementation}, A. Goldberg and D. Robson, Addison-Wesley, 1983. @item @t{*} -``{Standard LISP Report},'' +@b{Standard LISP Report}, J.B. Marti, A.C. Hearn, M.L. Griss, and C. Griss, @i{SIGPLAN Notices} V14, #10, October, 1979. @item @t{*} -{Webster's Third New International Dictionary +@b{Webster's Third New International Dictionary the English Language, Unabridged}, Merriam Webster (Springfield, MA), 1986. @item @t{*} -@i{XP: A Common Lisp Pretty Printing System}, +@b{XP: A Common Lisp Pretty Printing System}, R.C. Waters, Memo 1102a, Artificial Intelligence Laboratory, MIT (Cambridge, MA), September 1989. @@ -638,15 +640,15 @@ within the BNF, but might still be useful elsewhere. For example, consider the following definitions: -@code{case} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} +@code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} -@code{ccase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@code{ecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}{*}@r{)}} +@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} -@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} +@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} @@ -697,7 +699,7 @@ other indicator) before showing return values, while others do not. @item @i{OR}@result{} -The notation ``{@i{OR}@result{}}'' is used to denote one of several possible +The notation ``@i{OR}@result{}'' is used to denote one of several possible alternate results. The example @example @@ -722,7 +724,7 @@ of the ways in which it is permitted for implementations to diverge. @item @i{NOT}@result{} -The notation ``{@i{NOT}@result{}}'' is used to denote a result which is not possible. +The notation ``@i{NOT}@result{}'' is used to denote a result which is not possible. This might be used, for example, in order to emphasize a situation where some anticipated misconception might lead the reader to falsely believe that the result might be possible. For example, @@ -750,7 +752,7 @@ @t{(gcd (gcd x y) z)} for any @t{x}, @t{y}, and @t{z}. -@item {@t{ |> }} +@item @t{ |> } @r{Common Lisp} specifies input and output with respect to a non-interactive stream model. The specific details of how interactive input and output are mapped onto that non-interactive model are @i{implementation-defined}. @@ -765,7 +767,7 @@ a buffer full of input without the command itself being visible on the program's input stream. -In the examples in this document, the notation ``{@t{ |> }}'' precedes +In the examples in this document, the notation ``@t{ |> }'' precedes lines where interactive input and output occurs. Within such a scenario, ``@b{|>>}@t{this notation}@b{<<|}'' notates user input. @@ -791,11 +793,11 @@ Sometimes, the non-interactive stream model calls for a @i{newline}. How that @i{newline} character is interactively entered is an @i{implementation-defined} detail of the user interface, but in that -case, either the notation ``<@i{Newline}>'' or ``{@i{[<--}~]}'' might be used. +case, either the notation ``<@i{Newline}>'' or ``@i{[<--}~]'' might be used. @example (progn (format t "~&Who? ") (read-line)) -@t{ |> } Who? @b{|>>}@t{Fred, Mary, and Sally{@i{[<--}~]}}@b{<<|} +@t{ |> } Who? @b{|>>}@t{Fred, Mary, and Sally @i{[<--}~]}@b{<<|} @result{} "Fred, Mary, and Sally", @i{false} @end example @@ -886,6 +888,7 @@ By convention, the choice of notation offers a hint as to which of its many roles it is playing. +@format @group @noindent @w{ @b{For Evaluation?} @b{Notation} @b{Typically Implied Role} } @@ -900,6 +903,7 @@ @w{ Figure 1--1: Notations for NIL } @end group +@end format Within this document only, @b{nil} is also sometimes notated as @i{false} to emphasize its role as a @i{boolean}. @@ -1263,42 +1267,42 @@ dictionary entry. @menu -* The ``Affected By'' Section of a Dictionary Entry:: -* The ``Arguments'' Section of a Dictionary Entry:: -* The ``Arguments and Values'' Section of a Dictionary Entry:: -* The ``Binding Types Affected'' Section of a Dictionary Entry:: -* The ``Class Precedence List'' Section of a Dictionary Entry:: +* The "Affected By" Section of a Dictionary Entry:: +* The "Arguments" Section of a Dictionary Entry:: +* The "Arguments and Values" Section of a Dictionary Entry:: +* The "Binding Types Affected" Section of a Dictionary Entry:: +* The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: -* The ``Compound Type Specifier Kind'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Description'' Section of a Dictionary Entry:: -* The ``Constant Value'' Section of a Dictionary Entry:: -* The ``Description'' Section of a Dictionary Entry:: -* The ``Examples'' Section of a Dictionary Entry:: -* The ``Exceptional Situations'' Section of a Dictionary Entry:: -* The ``Initial Value'' Section of a Dictionary Entry:: -* The ``Argument Precedence Order'' Section of a Dictionary Entry:: -* The ``Method Signature'' Section of a Dictionary Entry:: -* The ``Name'' Section of a Dictionary Entry:: -* The ``Notes'' Section of a Dictionary Entry:: -* The ``Pronunciation'' Section of a Dictionary Entry:: -* The ``See Also'' Section of a Dictionary Entry:: -* The ``Side Effects'' Section of a Dictionary Entry:: -* The ``Supertypes'' Section of a Dictionary Entry:: -* The ``Syntax'' Section of a Dictionary Entry:: -* Special ``Syntax'' Notations for Overloaded Operators:: +* The "Compound Type Specifier Kind" Section of a Dictionary Entry:: +* The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: +* The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: +* The "Compound Type Specifier Description" Section of a Dictionary Entry:: +* The "Constant Value" Section of a Dictionary Entry:: +* The "Description" Section of a Dictionary Entry:: +* The "Examples" Section of a Dictionary Entry:: +* The "Exceptional Situations" Section of a Dictionary Entry:: +* The "Initial Value" Section of a Dictionary Entry:: +* The "Argument Precedence Order" Section of a Dictionary Entry:: +* The "Method Signature" Section of a Dictionary Entry:: +* The "Name" Section of a Dictionary Entry:: +* The "Notes" Section of a Dictionary Entry:: +* The "Pronunciation" Section of a Dictionary Entry:: +* The "See Also" Section of a Dictionary Entry:: +* The "Side Effects" Section of a Dictionary Entry:: +* The "Supertypes" Section of a Dictionary Entry:: +* The "Syntax" Section of a Dictionary Entry:: +* Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: -* Requiring Non-Null Rest Parameters in the ``Syntax'' Section:: -* Return values in the ``Syntax'' Section:: -* No Arguments or Values in the ``Syntax'' Section:: -* Unconditional Transfer of Control in the ``Syntax'' Section:: -* The ``Valid Context'' Section of a Dictionary Entry:: -* The ``Value Type'' Section of a Dictionary Entry:: +* Requiring Non-Null Rest Parameters in The "Syntax" Section:: +* Return values in The "Syntax" Section:: +* No Arguments or Values in The "Syntax" Section:: +* Unconditional Transfer of Control in The "Syntax" Section:: +* The "Valid Context" Section of a Dictionary Entry:: +* The "Value Type" Section of a Dictionary Entry:: @end menu -@node The ``Affected By'' Section of a Dictionary Entry, The ``Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries, Interpreting Dictionary Entries -@subsubsection The ``Affected By'' Section of a Dictionary Entry +@node The "Affected By" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries, Interpreting Dictionary Entries +@subsubsection The "Affected By" Section of a Dictionary Entry For an @i{operator}, anything that can affect the side effects of or @i{values} returned by the @i{operator}. @@ -1306,15 +1310,15 @@ For a @i{variable}, anything that can affect the @i{value} of the @i{variable} including @i{functions} that bind or assign it. -@node The ``Arguments'' Section of a Dictionary Entry, The ``Arguments and Values'' Section of a Dictionary Entry, The ``Affected By'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Arguments'' Section of a Dictionary Entry +@node The "Arguments" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, The "Affected By" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Arguments" Section of a Dictionary Entry This information describes the syntax information of entries such as those for @i{declarations} and special @i{expressions} which are never @i{evaluated} as @i{forms}, and so do not return @i{values}. -@node The ``Arguments and Values'' Section of a Dictionary Entry, The ``Binding Types Affected'' Section of a Dictionary Entry, The ``Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Arguments and Values'' Section of a Dictionary Entry +@node The "Arguments and Values" Section of a Dictionary Entry, The "Binding Types Affected" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Arguments and Values" Section of a Dictionary Entry An English language description of what @i{arguments} the @i{operator} accepts and what @i{values} it returns, including information about defaults for @i{parameters} @@ -1324,16 +1328,16 @@ their @i{arguments} are not @i{evaluated} unless it is explicitly stated in their descriptions that they are @i{evaluated}. -@node The ``Binding Types Affected'' Section of a Dictionary Entry, The ``Class Precedence List'' Section of a Dictionary Entry, The ``Arguments and Values'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Binding Types Affected'' Section of a Dictionary Entry +@node The "Binding Types Affected" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Binding Types Affected" Section of a Dictionary Entry This information alerts the reader to the kinds of @i{bindings} that might potentially be affected by a declaration. Whether in fact any particular such @i{binding} is actually affected is dependent on additional factors as well. -See the ``Description'' section of the declaration in question for details. +See The "Description" Section of the declaration in question for details. -@node The ``Class Precedence List'' Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, The ``Binding Types Affected'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Class Precedence List'' Section of a Dictionary Entry +@node The "Class Precedence List" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, The "Binding Types Affected" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Class Precedence List" Section of a Dictionary Entry This appears in the dictionary entry for a @i{class}, and contains an ordered list of the @i{classes} defined @@ -1356,7 +1360,7 @@ the @i{classes} listed in this section are also @i{supertypes} of the @i{type} denoted by the @i{class}. -@node Dictionary Entries for Type Specifiers, The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, The ``Class Precedence List'' Section of a Dictionary Entry, Interpreting Dictionary Entries +@node Dictionary Entries for Type Specifiers, The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, Interpreting Dictionary Entries @subsubsection Dictionary Entries for Type Specifiers The @i{atomic type specifiers} are those @i{defined names} @@ -1366,7 +1370,7 @@ A description of how to interpret a @i{symbol} naming one of these @i{types} or @i{classes} as an @i{atomic type specifier} -is found in the ``Description'' section of such dictionary entries. +is found in The "Description" Section of such dictionary entries. The @i{compound type specifiers} are those @i{defined names} listed in @i{Figure~4--3}. @@ -1381,8 +1385,8 @@ and ``Compound Type Specifier Description'' sections of such dictionary entries. -@node The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, Interpreting Dictionary Entries -@subsubsection The ``Compound Type Specifier Kind'' Section of a Dictionary Entry +@node The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, Interpreting Dictionary Entries +@subsubsection The "Compound Type Specifier Kind" Section of a Dictionary Entry An ``abbreviating'' @i{type specifier} is one that describes a @i{subtype} for which it is in principle possible to enumerate the @i{elements}, @@ -1399,8 +1403,8 @@ in a compositional way, using combining operations (such as ``and,'' ``or,'' and ``not'') on other @i{types}. -@node The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry +@node The "Compound Type Specifier Syntax" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Kind" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Compound Type Specifier Syntax" Section of a Dictionary Entry This information about a @i{type} describes the syntax of a @i{compound type specifier} for that @i{type}. @@ -1408,40 +1412,40 @@ Whether or not the @i{type} is acceptable as an @i{atomic type specifier} is not represented here; see @ref{Dictionary Entries for Type Specifiers}. -@node The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, The ``Compound Type Specifier Description'' Section of a Dictionary Entry, The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry +@node The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Compound Type Specifier Arguments" Section of a Dictionary Entry This information describes @i{type} information for the structures defined in -the ``Compound Type Specifier Syntax'' section. +The "Compound Type Specifier Syntax" Section. -@node The ``Compound Type Specifier Description'' Section of a Dictionary Entry, The ``Constant Value'' Section of a Dictionary Entry, The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Compound Type Specifier Description'' Section of a Dictionary Entry +@node The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Compound Type Specifier Description" Section of a Dictionary Entry This information describes the meaning of the structures defined in -the ``Compound Type Specifier Syntax'' section. +The "Compound Type Specifier Syntax" Section. -@node The ``Constant Value'' Section of a Dictionary Entry, The ``Description'' Section of a Dictionary Entry, The ``Compound Type Specifier Description'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Constant Value'' Section of a Dictionary Entry +@node The "Constant Value" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Constant Value" Section of a Dictionary Entry This information describes the unchanging @i{type} and @i{value} of a @i{constant variable}. -@node The ``Description'' Section of a Dictionary Entry, The ``Examples'' Section of a Dictionary Entry, The ``Constant Value'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Description'' Section of a Dictionary Entry +@node The "Description" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Description" Section of a Dictionary Entry A summary of the @i{operator} and all intended aspects of the @i{operator}, but does not necessarily include all the fields referenced below it (``Side Effects,'' ``Exceptional Situations,'' @i{etc.}) -@node The ``Examples'' Section of a Dictionary Entry, The ``Exceptional Situations'' Section of a Dictionary Entry, The ``Description'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Examples'' Section of a Dictionary Entry +@node The "Examples" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Examples" Section of a Dictionary Entry Examples of use of the @i{operator}. These examples are not considered part of the standard; see @ref{Sections Not Formally Part Of This Standard}. -@node The ``Exceptional Situations'' Section of a Dictionary Entry, The ``Initial Value'' Section of a Dictionary Entry, The ``Examples'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Exceptional Situations'' Section of a Dictionary Entry +@node The "Exceptional Situations" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Exceptional Situations" Section of a Dictionary Entry Three kinds of information may appear here: @table @asis @@ -1459,20 +1463,20 @@ as arguments or through dynamic variables, nor by executing subforms of this operator if it is a @i{macro} or @i{special operator}. -@node The ``Initial Value'' Section of a Dictionary Entry, The ``Argument Precedence Order'' Section of a Dictionary Entry, The ``Exceptional Situations'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Initial Value'' Section of a Dictionary Entry +@node The "Initial Value" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Initial Value" Section of a Dictionary Entry This information describes the initial @i{value} of a @i{dynamic variable}. -Since this variable might change, see @i{type} restrictions in the ``Value Type'' section. +Since this variable might change, see @i{type} restrictions in The "Value Type" Section. -@node The ``Argument Precedence Order'' Section of a Dictionary Entry, The ``Method Signature'' Section of a Dictionary Entry, The ``Initial Value'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Argument Precedence Order'' Section of a Dictionary Entry +@node The "Argument Precedence Order" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Argument Precedence Order" Section of a Dictionary Entry This information describes the argument precedence order. If it is omitted, the argument precedence order is the default (left to right). -@node The ``Method Signature'' Section of a Dictionary Entry, The ``Name'' Section of a Dictionary Entry, The ``Argument Precedence Order'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Method Signature'' Section of a Dictionary Entry +@node The "Method Signature" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Method Signature" Section of a Dictionary Entry The description of a @i{generic function} includes descriptions of the @i{methods} that are defined on that @i{generic function} by the standard. @@ -1483,7 +1487,7 @@ @code{F} @i{@r{(}@i{x} @i{class}@r{)} @r{(}@i{y} t@r{)} - {&optional} @i{z} {&key} @i{k}} + @r{&optional} @i{z} @r{&key} @i{k}} @noindent This @i{signature} indicates that this method on the @i{generic function} @@ -1503,8 +1507,8 @@ @i{implementation-defined} or user-defined @i{methods} in situations where the definition of such @i{methods} is permitted). -@node The ``Name'' Section of a Dictionary Entry, The ``Notes'' Section of a Dictionary Entry, The ``Method Signature'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Name'' Section of a Dictionary Entry +@node The "Name" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Name" Section of a Dictionary Entry This section introduces the dictionary entry. It is not explicitly labeled. It appears preceded and followed by a horizontal bar. @@ -1579,8 +1583,8 @@ @end table -@node The ``Notes'' Section of a Dictionary Entry, The ``Pronunciation'' Section of a Dictionary Entry, The ``Name'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Notes'' Section of a Dictionary Entry +@node The "Notes" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Notes" Section of a Dictionary Entry Information not found elsewhere in this description which pertains to this @i{operator}. @@ -1594,32 +1598,32 @@ any @i{conforming implementation} or @i{conforming program} is permitted to ignore the presence of this information. -@node The ``Pronunciation'' Section of a Dictionary Entry, The ``See Also'' Section of a Dictionary Entry, The ``Notes'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Pronunciation'' Section of a Dictionary Entry +@node The "Pronunciation" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Pronunciation" Section of a Dictionary Entry This offers a suggested pronunciation for @i{defined names} so that people not in verbal communication with the original designers can figure out how to pronounce words that are not in normal English usage. This information is advisory only, and is not considered part of the standard. For brevity, it is only provided for entries with names that are specific to -@r{Common Lisp} and would not be found in {Webster's Third New International Dictionary +@r{Common Lisp} and would not be found in @b{Webster's Third New International Dictionary the English Language, Unabridged}. -@node The ``See Also'' Section of a Dictionary Entry, The ``Side Effects'' Section of a Dictionary Entry, The ``Pronunciation'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``See Also'' Section of a Dictionary Entry +@node The "See Also" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "See Also" Section of a Dictionary Entry List of references to other parts of this standard that offer information relevant to this @i{operator}. This list is not part of the standard. -@node The ``Side Effects'' Section of a Dictionary Entry, The ``Supertypes'' Section of a Dictionary Entry, The ``See Also'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Side Effects'' Section of a Dictionary Entry +@node The "Side Effects" Section of a Dictionary Entry, The "Supertypes" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Side Effects" Section of a Dictionary Entry Anything that is changed as a result of the evaluation of the @i{form} containing this @i{operator}. -@node The ``Supertypes'' Section of a Dictionary Entry, The ``Syntax'' Section of a Dictionary Entry, The ``Side Effects'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Supertypes'' Section of a Dictionary Entry +@node The "Supertypes" Section of a Dictionary Entry, The "Syntax" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Supertypes" Section of a Dictionary Entry This appears in the dictionary entry for a @i{type}, and contains a list of the @i{standardized} @i{types} @@ -1629,15 +1633,15 @@ the order of the @i{classes} in the @i{class precedence list} is consistent with the order presented in this section. -@node The ``Syntax'' Section of a Dictionary Entry, Special ``Syntax'' Notations for Overloaded Operators, The ``Supertypes'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Syntax'' Section of a Dictionary Entry +@node The "Syntax" Section of a Dictionary Entry, Special "Syntax" Notations for Overloaded Operators, The "Supertypes" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Syntax" Section of a Dictionary Entry This section describes how to use the @i{defined name} in code. -The ``Syntax'' description for a @i{generic function} +The "Syntax'' description for a @i{generic function} describes the @i{lambda list} of the @i{generic function} itself, -while the ``Method Signatures'' describe the @i{lambda lists} +while The "Method Signatures'' describe the @i{lambda lists} of the defined @i{methods}. -The ``Syntax'' description for +The "Syntax'' description for an @i{ordinary function}, a @i{macro}, or a @i{special operator} @@ -1645,7 +1649,7 @@ For example, an @i{operator} description might say: -@code{F} @i{x y {&optional} z {&key} k} +@code{F} @i{x y @r{&optional} z @r{&key} k} @noindent This description indicates that the function @b{F} @@ -1658,8 +1662,8 @@ In both cases, however, the outermost parentheses are omitted, and default value information is omitted. -@node Special ``Syntax'' Notations for Overloaded Operators, Naming Conventions for Rest Parameters, The ``Syntax'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection Special ``Syntax'' Notations for Overloaded Operators +@node Special "Syntax" Notations for Overloaded Operators, Naming Conventions for Rest Parameters, The "Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection Special "Syntax" Notations for Overloaded Operators If two descriptions exist for the same operation but with different numbers of arguments, then the extra arguments are to be treated as optional. For example, @@ -1672,7 +1676,7 @@ @noindent is operationally equivalent to this line: -@code{file-position} @i{stream {&optional} position-spec} @result{} @i{result} +@code{file-position} @i{stream @r{&optional} position-spec} @result{} @i{result} @noindent and differs only in that it provides on opportunity to introduce different @@ -1682,7 +1686,7 @@ depending on how many @i{arguments} are supplied (@i{e.g.}, for the @i{function} @b{/}) or the return values are different in the two cases (@i{e.g.}, for the @i{function} @b{file-position}). -@node Naming Conventions for Rest Parameters, Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Special ``Syntax'' Notations for Overloaded Operators, Interpreting Dictionary Entries +@node Naming Conventions for Rest Parameters, Requiring Non-Null Rest Parameters in The "Syntax" Section, Special "Syntax" Notations for Overloaded Operators, Interpreting Dictionary Entries @subsubsection Naming Conventions for Rest Parameters Within this specification, @@ -1694,15 +1698,15 @@ For example, given a syntax description such as: -@code{F} @i{{&rest} @i{arguments}} +@code{F} @i{@r{&rest} @i{arguments}} @noindent it is appropriate to refer either to the @i{rest parameter} named @i{arguments} by name, or to one of its elements by speaking of ``an @i{argument},'' ``some @i{argument},'' ``each @i{argument}'' @i{etc.} -@node Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Return values in the ``Syntax'' Section, Naming Conventions for Rest Parameters, Interpreting Dictionary Entries -@subsubsection Requiring Non-Null Rest Parameters in the ``Syntax'' Section +@node Requiring Non-Null Rest Parameters in The "Syntax" Section, Return values in The "Syntax" Section, Naming Conventions for Rest Parameters, Interpreting Dictionary Entries +@subsubsection Requiring Non-Null Rest Parameters in The "Syntax" Section In some cases it is useful to refer to all arguments equally as a single aggregation using a @i{rest parameter} while at the same time @@ -1711,21 +1715,21 @@ restriction, however they generally do not manifest themselves in a @i{lambda list}. For descriptive purposes within this specification, -@code{F} @i{{&rest} arguments^+} +@code{F} @i{@r{&rest} arguments^+} @noindent means the same as -@code{F} @i{{&rest} arguments} +@code{F} @i{@r{&rest} arguments} @noindent but introduces the additional requirement that there be at least one @i{argument}. -@node Return values in the ``Syntax'' Section, No Arguments or Values in the ``Syntax'' Section, Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Interpreting Dictionary Entries -@subsubsection Return values in the ``Syntax'' Section +@node Return values in The "Syntax" Section, No Arguments or Values in The "Syntax" Section, Requiring Non-Null Rest Parameters in The "Syntax" Section, Interpreting Dictionary Entries +@subsubsection Return values in The "Syntax" Section -An evaluation arrow ``{@result{} }'' precedes a list of @i{values} to be returned. +An evaluation arrow ``@result{}'' precedes a list of @i{values} to be returned. For example: @code{F} @i{a b c} @result{} @i{x} @@ -1738,8 +1742,8 @@ @code{F} @i{a b c} @result{} @i{x, y, z} -@node No Arguments or Values in the ``Syntax'' Section, Unconditional Transfer of Control in the ``Syntax'' Section, Return values in the ``Syntax'' Section, Interpreting Dictionary Entries -@subsubsection No Arguments or Values in the ``Syntax'' Section +@node No Arguments or Values in The "Syntax" Section, Unconditional Transfer of Control in The "Syntax" Section, Return values in The "Syntax" Section, Interpreting Dictionary Entries +@subsubsection No Arguments or Values in The "Syntax" Section If no @i{arguments} are permitted, or no @i{values} are returned, a special notation is used to make this more visually apparent. For example, @@ -1749,8 +1753,8 @@ indicates that @t{F} is an operator that accepts no @i{arguments} and returns no @i{values}. -@node Unconditional Transfer of Control in the ``Syntax'' Section, The ``Valid Context'' Section of a Dictionary Entry, No Arguments or Values in the ``Syntax'' Section, Interpreting Dictionary Entries -@subsubsection Unconditional Transfer of Control in the ``Syntax'' Section +@node Unconditional Transfer of Control in The "Syntax" Section, The "Valid Context" Section of a Dictionary Entry, No Arguments or Values in The "Syntax" Section, Interpreting Dictionary Entries +@subsubsection Unconditional Transfer of Control in The "Syntax" Section Some @i{operators} perform an unconditional transfer of control, and so never have any return values. Such @i{operators} are notated using @@ -1759,8 +1763,8 @@ @code{F} @i{a b c} @result{} # -@node The ``Valid Context'' Section of a Dictionary Entry, The ``Value Type'' Section of a Dictionary Entry, Unconditional Transfer of Control in the ``Syntax'' Section, Interpreting Dictionary Entries -@subsubsection The ``Valid Context'' Section of a Dictionary Entry +@node The "Valid Context" Section of a Dictionary Entry, The "Value Type" Section of a Dictionary Entry, Unconditional Transfer of Control in The "Syntax" Section, Interpreting Dictionary Entries +@subsubsection The "Valid Context" Section of a Dictionary Entry This information is used by dictionary entries such as ``Declarations'' in order to restrict the context in which the declaration may appear. @@ -1770,8 +1774,8 @@ a @i{proclamation} (@i{i.e.}, a @b{declaim} or @b{proclaim} @i{form}), or both. -@node The ``Value Type'' Section of a Dictionary Entry, , The ``Valid Context'' Section of a Dictionary Entry, Interpreting Dictionary Entries -@subsubsection The ``Value Type'' Section of a Dictionary Entry +@node The "Value Type" Section of a Dictionary Entry, , The "Valid Context" Section of a Dictionary Entry, Interpreting Dictionary Entries +@subsubsection The "Value Type" Section of a Dictionary Entry This information describes any @i{type} restrictions on a @i{dynamic variable}. @@ -2103,6 +2107,7 @@ @subsection Deprecated Functions The @i{functions} in Figure 1--2 are deprecated. +@format @group @noindent @w{ assoc-if-not nsubst-if-not require } @@ -2116,6 +2121,7 @@ @w{ Figure 1--2: Deprecated Functions } @end group +@end format @node Deprecated Argument Conventions, Deprecated Variables, Deprecated Functions, Deprecated Language Features @subsection Deprecated Argument Conventions @@ -2124,6 +2130,7 @@ The @t{:test-not} @i{argument} to the @i{functions} in Figure 1--3 are deprecated. +@format @group @noindent @w{ adjoin nset-difference search } @@ -2141,6 +2148,7 @@ @w{ Figure 1--3: Functions with Deprecated :TEST-NOT Arguments} @end group +@end format The use of the situation names @b{compile}, @b{load}, and @b{eval} in @b{eval-when} is deprecated. @@ -2171,6 +2179,7 @@ of the 978 @i{external} @i{symbols} in the @t{COMMON-LISP} @i{package}. @IPindex{common-lisp} +@format @group @noindent @w{ &allow-other-keys *print-miser-width* } @@ -2216,9 +2225,11 @@ @w{ Figure 1--4: Symbols in the COMMON-LISP package (part one of twelve).} @end group +@end format @page +@format @group @noindent @w{ adjoin atom boundp } @@ -2264,9 +2275,11 @@ @w{ Figure 1--5: Symbols in the COMMON-LISP package (part two of twelve).} @end group +@end format @page +@format @group @noindent @w{ cddadr clear-input copy-tree } @@ -2312,9 +2325,11 @@ @w{ Figure 1--6: Symbols in the COMMON-LISP package (part three of twelve). } @end group +@end format @page +@format @group @noindent @w{ denominator eq } @@ -2360,9 +2375,11 @@ @w{ Figure 1--7: Symbols in the COMMON-LISP package (part four of twelve).} @end group +@end format @page +@format @group @noindent @w{ find-symbol get-internal-run-time } @@ -2408,9 +2425,11 @@ @w{ Figure 1--8: Symbols in the COMMON-LISP package (part five of twelve).} @end group +@end format @page +@format @group @noindent @w{ intern lisp-implementation-type } @@ -2456,9 +2475,11 @@ @w{ Figure 1--9: Symbols in the COMMON-LISP package (part six of twelve). } @end group +@end format @page +@format @group @noindent @w{ machine-version mask-field } @@ -2504,9 +2525,11 @@ @w{ Figure 1--10: Symbols in the COMMON-LISP package (part seven of twelve).} @end group +@end format @page +@format @group @noindent @w{ nintersection package-error } @@ -2552,9 +2575,11 @@ @w{ Figure 1--11: Symbols in the COMMON-LISP package (part eight of twelve).} @end group +@end format @page +@format @group @noindent @w{ pprint-tab read-char } @@ -2600,9 +2625,11 @@ @w{ Figure 1--12: Symbols in the COMMON-LISP package (part nine of twelve).} @end group +@end format @page +@format @group @noindent @w{ room simple-bit-vector } @@ -2648,9 +2675,11 @@ @w{ Figure 1--13: Symbols in the COMMON-LISP package (part ten of twelve).} @end group +@end format @page +@format @group @noindent @w{ standard-class sublis } @@ -2696,9 +2725,11 @@ @w{ Figure 1--14: Symbols in the COMMON-LISP package (part eleven of twelve).} @end group +@end format @page +@format @group @noindent @w{ truncate values-list } @@ -2739,6 +2770,7 @@ @w{ Figure 1--15: Symbols in the COMMON-LISP package (part twelve of twelve).} @end group +@end format @c end of including concept-cl-symbols diff -uNr gcl-texi-orig/chap-20.texi gcl-texi/chap-20.texi --- gcl-texi-orig/chap-20.texi 1994-07-16 18:03:06 +0400 +++ gcl-texi/chap-20.texi 2002-10-17 20:53:05 +0400 @@ -32,6 +32,7 @@ Figure 20--1 lists some @i{operators} that are applicable to @i{files} and directories. +@format @group @noindent @w{ compile-file file-length open } @@ -43,6 +44,7 @@ @w{ Figure 20--1: File and Directory Operations } @end group +@end format @menu * Coercion of Streams to Pathnames:: @@ -82,6 +84,7 @@ Of these, the @i{functions} in Figure 20--2 treat @i{open} and @i{closed} @i{streams} differently. +@format @group @noindent @w{ delete-file file-author probe-file } @@ -91,6 +94,7 @@ @w{ Figure 20--2: File Functions that Treat Open and Closed Streams Differently} @end group +@end format Since treatment of @i{open} @i{streams} by the @i{file system} may vary considerably between @i{implementations}, however, @@ -103,6 +107,7 @@ In general, any code that is intended to be portable should use such @i{functions} carefully. +@format @group @noindent @w{ directory probe-file truename } @@ -111,6 +116,7 @@ @w{ Figure 20--3: File Functions where Closed Streams Might Work Best} @end group +@end format @node Truenames, , File Operations on Open and Closed Streams, File System Concepts @subsection Truenames @@ -194,7 +200,7 @@ @node directory, probe-file, Files Dictionary, Files Dictionary @subsection directory [Function] -@code{directory} @i{pathspec {&key}} @result{} @i{pathnames} +@code{directory} @i{pathspec @r{&key}} @result{} @i{pathnames} @subsubheading Arguments and Values:: @@ -246,7 +252,7 @@ If the @i{pathspec} is not @i{wild}, the resulting list will contain either zero or one elements. -@r{Common Lisp} specifies ``{&key}'' in the argument list to @b{directory} +@r{Common Lisp} specifies ``@r{&key}'' in the argument list to @b{directory} even though no @i{standardized} keyword arguments to @b{directory} are defined. ``@t{:allow-other-keys t}'' may be used in @i{conforming programs} in order to quietly ignore any @@ -308,7 +314,7 @@ @node ensure-directories-exist, truename, probe-file, Files Dictionary @subsection ensure-directories-exist [Function] -@code{ensure-directories-exist} @i{pathspec {&key} verbose} @result{} @i{pathspec, created} +@code{ensure-directories-exist} @i{pathspec @r{&key} verbose} @result{} @i{pathspec, created} @subsubheading Arguments and Values:: @@ -687,7 +693,7 @@ @subsubheading See Also:: -{file-error-pathname}, +@r{file-error-pathname}, @ref{open} , @ref{probe-file} diff -uNr gcl-texi-orig/chap-21.texi gcl-texi/chap-21.texi --- gcl-texi-orig/chap-21.texi 1994-07-16 18:03:06 +0400 +++ gcl-texi/chap-21.texi 2002-10-17 20:53:05 +0400 @@ -43,6 +43,7 @@ Figure 21--1 provides a list of @i{standardized} operations that are potentially useful with any kind of @i{stream}. +@format @group @noindent @w{ close stream-element-type } @@ -54,6 +55,7 @@ @w{ Figure 21--1: Some General-Purpose Stream Operations} @end group +@end format Other operations are only meaningful on certain @i{stream} @i{types}. For example, @b{read-char} is only defined for @i{character} @i{streams} @@ -92,6 +94,7 @@ Figure 21--2 shows @i{operators} relating to @i{input} @i{streams}. +@format @group @noindent @w{ clear-input read-byte read-from-string } @@ -103,10 +106,12 @@ @w{ Figure 21--2: Operators relating to Input Streams. } @end group +@end format Figure 21--3 shows @i{operators} relating to @i{output} @i{streams}. +@format @group @noindent @w{ clear-output prin1 write } @@ -120,6 +125,7 @@ @w{ Figure 21--3: Operators relating to Output Streams.} @end group +@end format A @i{stream} that is both an @i{input} @i{stream} and an @i{output} @i{stream} is called a @i{bidirectional} @@ -134,6 +140,7 @@ shows a list of @i{operators} that relate specificaly to @i{bidirectional} @i{streams}. +@format @group @noindent @w{ y-or-n-p yes-or-no-p } @@ -142,6 +149,7 @@ @w{ Figure 21--4: Operators relating to Bidirectional Streams.} @end group +@end format @node Open and Closed Streams, Interactive Streams, Input, Introduction to Streams @subsubsection Open and Closed Streams @@ -235,6 +243,7 @@ by this specification. Figure 21--5 shows some information about these subclasses. +@format @group @noindent @w{ Class Related Operators } @@ -260,6 +269,7 @@ @w{ Figure 21--5: Defined Names related to Specialized Streams} @end group +@end format @node Stream Variables, Stream Arguments to Standardized Functions, Introduction to Streams, Stream Concepts @subsection Stream Variables @@ -277,6 +287,7 @@ The consequences are undefined if at any time the @i{value} of any of these @i{variables} is not an @i{open} @i{stream}. +@format @group @noindent @w{ Glossary Term Variable Name } @@ -292,6 +303,7 @@ @w{ Figure 21--6: Standardized Stream Variables} @end group +@end format Note that, by convention, @i{standardized} @i{stream variables} have names ending in ``@t{-input*}'' if they must be @i{input} @i{streams}, @@ -307,6 +319,7 @@ The @i{operators} in Figure 21--7 accept @i{stream} @i{arguments} that might be either @i{open} or @i{closed} @i{streams}. +@format @group @noindent @w{ broadcast-stream-streams file-author pathnamep } @@ -327,10 +340,12 @@ @w{ Figure 21--7: Operators that accept either Open or Closed Streams } @end group +@end format The @i{operators} in Figure 21--8 accept @i{stream} @i{arguments} that must be @i{open} @i{streams}. +@format @group @noindent @w{ clear-input output-stream-p read-char-no-hang } @@ -356,6 +371,7 @@ @w{ Figure 21--8: Operators that accept Open Streams only } @end group +@end format @node Restrictions on Composite Streams, , Stream Arguments to Standardized Functions, Stream Concepts @subsection Restrictions on Composite Streams @@ -453,8 +469,8 @@ @ref{Stream Concepts}, @ref{Printing Other Objects}, -{@ref{Printer}}, -{@ref{Reader}} +@ref{Printer}, +@ref{Reader} @node broadcast-stream, concatenated-stream, stream, Streams Dictionary @subsection broadcast-stream [System Class] @@ -607,7 +623,7 @@ @subsubheading See Also:: -@ref{echo-stream-input-stream; echo-stream-output-stream} +@ref{echo-stream-input-stream} , @b{echo-stream-output-stream}, @ref{make-echo-stream} @@ -710,7 +726,7 @@ @ref{make-two-way-stream} , -@ref{two-way-stream-input-stream; two-way-stream-output-stream} +@ref{two-way-stream-input-stream} , @b{two-way-stream-output-stream} @@ -908,7 +924,7 @@ @node read-byte, write-byte, streamp, Streams Dictionary @subsection read-byte [Function] -@code{read-byte} @i{stream {&optional} eof-error-p eof-value} @result{} @i{byte} +@code{read-byte} @i{stream @r{&optional} eof-error-p eof-value} @result{} @i{byte} @subsubheading Arguments and Values:: @@ -1022,7 +1038,7 @@ @node peek-char, read-char, write-byte, Streams Dictionary @subsection peek-char [Function] -@code{peek-char} @i{{&optional} peek-type input-stream eof-error-p +@code{peek-char} @i{@r{&optional} peek-type input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @@ -1074,9 +1090,9 @@ If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. -{ }{If @i{recursive-p} is @i{true}, +If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} -or a similar @i{function} used by the @i{Lisp reader}.} +or a similar @i{function} used by the @i{Lisp reader}. When @i{input-stream} is an @i{echo stream}, characters that are only peeked at are not echoed. In the @@ -1119,7 +1135,7 @@ @node read-char, read-char-no-hang, peek-char, Streams Dictionary @subsection read-char [Function] -@code{read-char} @i{{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} +@code{read-char} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @@ -1150,9 +1166,9 @@ and hence are assumed to have been echoed already by a previous call to @b{read-char}. -{ }{If @i{recursive-p} is @i{true}, +If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} -or a similar @i{function} used by the @i{Lisp reader}.} +or a similar @i{function} used by the @i{Lisp reader}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. @@ -1188,7 +1204,7 @@ @ref{write-char} , -@ref{read; read-preserving-whitespace} +@ref{read} @subsubheading Notes:: The corresponding output function is @b{write-char}. @@ -1196,7 +1212,7 @@ @node read-char-no-hang, terpri, read-char, Streams Dictionary @subsection read-char-no-hang [Function] -@code{read-char-no-hang} @i{{&optional} input-stream eof-error-p +@code{read-char-no-hang} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @@ -1221,9 +1237,9 @@ from @i{input-stream} if such a character is available. If no character is available, @b{read-char-no-hang} returns @b{nil}. -{ }{If @i{recursive-p} is @i{true}, +If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} -or a similar @i{function} used by the @i{Lisp reader}.} +or a similar @i{function} used by the @i{Lisp reader}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. @@ -1248,7 +1264,7 @@ ;; interactive input on the console, and where that Newline remains ;; on the input stream. (test-it) -@t{ |> } @b{|>>}@t{a{@i{[<--}~]}}@b{<<|} +@t{ |> } @b{|>>}@t{a@r{@i{[<--}~]}}@b{<<|} @result{} (#\a #\Newline NIL) @end example @@ -1276,9 +1292,9 @@ @node terpri, unread-char, read-char-no-hang, Streams Dictionary @subsection terpri, fresh-line [Function] -@code{terpri} @i{{&optional} output-stream} @result{} @i{@b{nil}} +@code{terpri} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} -@code{fresh-line} @i{{&optional} output-stream} @result{} @i{generalized-boolean} +@code{fresh-line} @i{@r{&optional} output-stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -1343,7 +1359,7 @@ @node unread-char, write-char, terpri, Streams Dictionary @subsection unread-char [Function] -@code{unread-char} @i{character {&optional} input-stream} @result{} @i{@b{nil}} +@code{unread-char} @i{character @r{&optional} input-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1416,7 +1432,7 @@ @node write-char, read-line, unread-char, Streams Dictionary @subsection write-char [Function] -@code{write-char} @i{character {&optional} output-stream} @result{} @i{character} +@code{write-char} @i{character @r{&optional} output-stream} @result{} @i{character} @subsubheading Arguments and Values:: @@ -1462,7 +1478,7 @@ @node read-line, write-string, write-char, Streams Dictionary @subsection read-line [Function] -@code{read-line} @i{{&optional} input-stream eof-error-p eof-value recursive-p}@* +@code{read-line} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p}@* @result{} @i{line, missing-newline-p} @subsubheading Arguments and Values:: @@ -1488,9 +1504,9 @@ Reads from @i{input-stream} a line of text that is terminated by a @i{newline} or @i{end of file}. -{ }{If @i{recursive-p} is @i{true}, +If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} -or a similar @i{function} used by the @i{Lisp reader}.} +or a similar @i{function} used by the @i{Lisp reader}. The @i{primary value}, @i{line}, is the line that is read, represented as a @i{string} (without the trailing @i{newline}, if any). @@ -1533,7 +1549,7 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} @subsubheading Notes:: @@ -1542,9 +1558,9 @@ @node write-string, read-sequence, read-line, Streams Dictionary @subsection write-string, write-line [Function] -@code{write-string} @i{string {&optional} output-stream {&key} start end} @result{} @i{string} +@code{write-string} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} -@code{write-line} @i{string {&optional} output-stream {&key} start end} @result{} @i{string} +@code{write-line} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} @subsubheading Arguments and Values:: @@ -1609,7 +1625,7 @@ @node read-sequence, write-sequence, write-string, Streams Dictionary @subsection read-sequence [Function] -@code{read-sequence} @i{sequence stream {&key} start end} @result{} @i{position} +@code{read-sequence} @i{sequence stream @r{&key} start end} @result{} @i{position} @i{sequence}---a @i{sequence}. @@ -1681,7 +1697,7 @@ @node write-sequence, file-length, read-sequence, Streams Dictionary @subsection write-sequence [Function] -@code{write-sequence} @i{sequence stream {&key} start end} @result{} @i{sequence} +@code{write-sequence} @i{sequence stream @r{&key} start end} @result{} @i{sequence} @i{sequence}---a @i{sequence}. @@ -1726,7 +1742,7 @@ @ref{Compiler Terminology}, @ref{read-sequence} , -@ref{write-string; write-line} +@ref{write-string} , @b{write-line} @@ -1922,7 +1938,7 @@ @node open, stream-external-format, file-string-length, Streams Dictionary @subsection open [Function] -@code{open} @i{filespec {&key} direction element-type +@code{open} @i{filespec @r{&key} direction element-type if-exists if-does-not-exist external-format}@* @result{} @i{stream} @@ -2252,9 +2268,9 @@ @subsubheading Syntax:: -@code{with-open-file} @i{@r{(}stream filespec @{@i{options}@}{*}@r{)} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* +@code{with-open-file} @i{@r{(}stream filespec @{@i{options}@}*@r{)} + @{@i{declaration}@}* + @{@i{form}@}*}@* @result{} @i{results} @subsubheading Arguments and Values:: @@ -2367,7 +2383,7 @@ @node close, with-open-stream, with-open-file, Streams Dictionary @subsection close [Function] -@code{close} @i{stream {&key} abort} @result{} @i{result} +@code{close} @i{stream @r{&key} abort} @result{} @i{result} @subsubheading Arguments and Values:: @@ -2440,9 +2456,9 @@ @subsection with-open-stream [Macro] @code{with-open-stream} @i{@r{(}var stream@r{)} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2492,7 +2508,7 @@ @node listen, clear-input, with-open-stream, Streams Dictionary @subsection listen [Function] -@code{listen} @i{{&optional} input-stream} @result{} @i{generalized-boolean} +@code{listen} @i{@r{&optional} input-stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -2536,7 +2552,7 @@ @node clear-input, finish-output, listen, Streams Dictionary @subsection clear-input [Function] -@code{clear-input} @i{{&optional} input-stream} @result{} @i{@b{nil}} +@code{clear-input} @i{@r{&optional} input-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -2606,11 +2622,11 @@ @node finish-output, y-or-n-p, clear-input, Streams Dictionary @subsection finish-output, force-output, clear-output [Function] -@code{finish-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} +@code{finish-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} -@code{force-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} +@code{force-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} -@code{clear-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} +@code{clear-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -2666,9 +2682,9 @@ @node y-or-n-p, make-synonym-stream, finish-output, Streams Dictionary @subsection y-or-n-p, yes-or-no-p [Function] -@code{y-or-n-p} @i{{&optional} control {&rest} arguments} @result{} @i{generalized-boolean} +@code{y-or-n-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} -@code{yes-or-no-p} @i{{&optional} control {&rest} arguments} @result{} @i{generalized-boolean} +@code{yes-or-no-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -2823,7 +2839,7 @@ @node make-broadcast-stream, make-two-way-stream, broadcast-stream-streams, Streams Dictionary @subsection make-broadcast-stream [Function] -@code{make-broadcast-stream} @i{{&rest} streams} @result{} @i{broadcast-stream} +@code{make-broadcast-stream} @i{@r{&rest} streams} @result{} @i{broadcast-stream} @subsubheading Arguments and Values:: @@ -2975,7 +2991,7 @@ @subsubheading See Also:: -@ref{echo-stream-input-stream; echo-stream-output-stream} +@ref{echo-stream-input-stream} , @b{echo-stream-output-stream}, @ref{make-two-way-stream} @@ -3004,7 +3020,7 @@ @node make-concatenated-stream, get-output-stream-string, concatenated-stream-streams, Streams Dictionary @subsection make-concatenated-stream [Function] -@code{make-concatenated-stream} @i{{&rest} input-streams} @result{} @i{concatenated-stream} +@code{make-concatenated-stream} @i{@r{&rest} input-streams} @result{} @i{concatenated-stream} @subsubheading Arguments and Values:: @@ -3083,7 +3099,7 @@ @node make-string-input-stream, make-string-output-stream, get-output-stream-string, Streams Dictionary @subsection make-string-input-stream [Function] -@code{make-string-input-stream} @i{string {&optional} start end} @result{} @i{string-stream} +@code{make-string-input-stream} @i{string @r{&optional} start end} @result{} @i{string-stream} @subsubheading Arguments and Values:: @@ -3121,7 +3137,7 @@ @node make-string-output-stream, with-input-from-string, make-string-input-stream, Streams Dictionary @subsection make-string-output-stream [Function] -@code{make-string-output-stream} @i{{&key} element-type} @result{} @i{string-stream} +@code{make-string-output-stream} @i{@r{&key} element-type} @result{} @i{string-stream} @subsubheading Arguments and Values:: @@ -3163,10 +3179,10 @@ @node with-input-from-string, with-output-to-string, make-string-output-stream, Streams Dictionary @subsection with-input-from-string [Macro] -@code{with-input-from-string} @i{@r{(}var string {&key} index start end@r{)} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{with-input-from-string} @i{@r{(}var string @r{&key} index start end@r{)} + @{@i{declaration}@}* + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3252,10 +3268,10 @@ @node with-output-to-string, *debug-io*, with-input-from-string, Streams Dictionary @subsection with-output-to-string [Macro] -@code{with-output-to-string} @i{@r{(}var {&optional} string-form {&key} element-type@r{)} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{with-output-to-string} @i{@r{(}var @r{&optional} string-form @r{&key} element-type@r{)} + @{@i{declaration}@}* + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3449,11 +3465,11 @@ @b{synonym-stream}, @ref{Time} , -@ref{trace; untrace} +@ref{trace} , -{@ref{Conditions}}, -{@ref{Reader}}, -{@ref{Printer}} +@ref{Conditions}, +@ref{Reader}, +@ref{Printer} @subsubheading Notes:: diff -uNr gcl-texi-orig/chap-22.texi gcl-texi/chap-22.texi --- gcl-texi-orig/chap-22.texi 1994-07-16 18:03:05 +0400 +++ gcl-texi/chap-22.texi 2002-10-17 22:10:07 +0400 @@ -86,6 +86,7 @@ Figure 22--1 shows the @i{standardized} @i{printer control variables}; there might also be @i{implementation-defined} @i{printer control variables}. +@format @group @noindent @w{ *print-array* *print-gensym* *print-pprint-dispatch* } @@ -98,11 +99,13 @@ @w{ Figure 22--1: Standardized Printer Control Variables } @end group +@end format In addition to the @i{printer control variables}, the following additional @i{defined names} relate to or affect the behavior of the @i{Lisp printer}: +@format @group @noindent @w{ *package* *read-eval* readtable-case } @@ -112,6 +115,7 @@ @w{ Figure 22--2: Additional Influences on the Lisp printer. } @end group +@end format @node Printer Escaping, , Multiple Possible Textual Representations, Overview of The Lisp Printer @subsubsection Printer Escaping @@ -222,7 +226,7 @@ @IRindex{float} -If the magnitude of the @i{float} is either zero or between 10^{-3} (inclusive) +If the magnitude of the @i{float} is either zero or between 10^@r{-3} (inclusive) and 10^7 (exclusive), it is printed as the integer part of the number, then a decimal point, followed by the fractional part of the number; @@ -238,7 +242,7 @@ For example, the base of the natural logarithms as a @i{short float} might be printed as @t{2.71828S0}. -For non-zero magnitudes outside of the range 10^{-3} to 10^7, +For non-zero magnitudes outside of the range 10^@r{-3} to 10^7, a @i{float} is printed in computerized scientific notation. The representation of the number is scaled to be between 1 (inclusive) and 10 (exclusive) and then printed, with one digit @@ -815,7 +819,7 @@ the default notation for structures is: @example - #S(@i{structure-name} @{@i{slot-key} @i{slot-value}@}{*}) + #S(@i{structure-name} @{@i{slot-key} @i{slot-value}@}*) @end example where @t{#S} indicates structure syntax, @@ -918,7 +922,7 @@ @menu * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: -* Notes about the Pretty Printer's Background:: +* Notes about the Pretty Printer`s Background:: @end menu @node Pretty Printer Concepts, Examples of using the Pretty Printer, The Lisp Pretty Printer, The Lisp Pretty Printer @@ -1034,6 +1038,7 @@ arrangement of output is provided through the functions and macros of the pretty printer. Figure 22--3 shows the defined names related to @i{pretty printing}. +@format @group @noindent @w{ *print-lines* pprint-dispatch pprint-pop } @@ -1048,11 +1053,13 @@ @w{ Figure 22--3: Defined names related to pretty printing. } @end group +@end format Figure 22--4 identifies a set of @i{format directives} which serve as an alternate interface to the same pretty printing operations in a more textually compact form. +@format @group @noindent @w{ @t{~I} @t{~W} @t{~<...~:>} } @@ -1062,6 +1069,7 @@ @w{ Figure 22--4: Format directives related to Pretty Printing} @end group +@end format @node Compiling Format Strings, Pretty Print Dispatch Tables, Format Directive Interface, Pretty Printer Concepts @subsubsection Compiling Format Strings @@ -1127,7 +1135,7 @@ the left margin is assumed to be zero. The right margin is controlled by @b{*print-right-margin*}. -@node Examples of using the Pretty Printer, Notes about the Pretty Printer's Background, Pretty Printer Concepts, The Lisp Pretty Printer +@node Examples of using the Pretty Printer, Notes about the Pretty Printer`s Background, Pretty Printer Concepts, The Lisp Pretty Printer @subsection Examples of using the Pretty Printer As an example of the interaction of logical blocks, conditional newlines, @@ -1347,7 +1355,7 @@ (format T "~:<~W ~@@_~:I~W ~:_~W~1I ~_~W~:>" list)) (defun pprint-let (*standard-output* list) - (format T "~:<~W~{@t{^}}~:<~@@@{~:<~@@@{~W~{@t{^}}~_~@}~:>~{@t{^}}~:_~@}~:>~1I~@@@{~{@t{^}}~_~W~@}~:>" list)) + (format T "~:<~W~@t{^}~:<~@@@{~:<~@@@{~W~@t{^}~_~@}~:>~@t{^}~:_~@}~:>~1I~@@@{~@t{^}~_~W~@}~:>" list)) @end example In the following example, the first @i{form} restores @@ -1459,8 +1467,8 @@ its @b{print-object} @i{method} is used instead. -@node Notes about the Pretty Printer's Background, , Examples of using the Pretty Printer, The Lisp Pretty Printer -@subsection Notes about the Pretty Printer's Background +@node Notes about the Pretty Printer`s Background, , Examples of using the Pretty Printer, The Lisp Pretty Printer +@subsection Notes about the Pretty Printer`s Background For a background reference to the abstract concepts detailed in this section, see @i{XP: A Common Lisp Pretty Printing System}. The details of that paper are not binding on @@ -1535,6 +1543,7 @@ Examples of @i{format strings}: +@format @group @noindent @w{ @t{"~S"} ;This is an S directive with no parameters or modifiers. } @@ -1547,6 +1556,7 @@ @w{ Figure 22--5: Examples of format control strings } @end group +@end format @b{format} sends the output to @i{destination}. If @i{destination} is @b{nil}, @@ -1647,7 +1657,7 @@ this fact is mentioned. For example, @example - (format nil "~:@@C" #\Control-Partial) @result{} "Control-{\partial} (Top-F)" + (format nil "~:@@C" #\Control-Partial) @result{} "Control-\partial (Top-F)" @end example This is the format used for telling the user about a key he is expected to type, @@ -1902,7 +1912,7 @@ If both @i{w} and @i{d} are omitted, then the effect is to print the value using ordinary free-format output; @b{prin1} uses this format for any number whose magnitude is either zero or between -10^{-3} (inclusive) and 10^7 (exclusive). +10^@r{-3} (inclusive) and 10^7 (exclusive). If @i{w} is omitted, then if the magnitude of @i{arg} is so large (or, if @i{d} is also omitted, so small) that more than 100 digits would have to @@ -2020,7 +2030,7 @@ a similar format for any non-zero number whose magnitude -is less than 10^{-3} or greater than or equal to 10^7. +is less than 10^@r{-3} or greater than or equal to 10^7. The only difference is that the @t{~E} directive always prints a plus or minus sign in front of the @@ -2057,7 +2067,7 @@ The full form is @t{~@i{w},@i{d},@i{e},@i{k},@i{overflowchar},@i{padchar},@i{exponentchar}G}. The format in which to print @i{arg} depends on the magnitude (absolute value) of the @i{arg}. Let @i{n} be an integer such that -10^{{n}-1} \le |@i{arg}| < 10^@i{n}. +10^@r{@r{n}-1} \le |@i{arg}| < 10^@i{n}. Let @i{ee} equal @i{e}+2, or 4 if @i{e} is omitted. Let @i{ww} equal @i{w}- @i{ee}, or @b{nil} if @i{w} is omitted. If @i{d} is omitted, first let @i{q} @@ -2263,7 +2273,7 @@ Elements are extracted from this list using @b{pprint-pop}, thereby providing automatic support for malformed lists, and the detection of circularity, sharing, and length abbreviation. -Within the body segment, @t{~{@t{^}}} acts like @b{pprint-exit-if-list-exhausted}. +Within the body segment, @t{~@t{^}} acts like @b{pprint-exit-if-list-exhausted}. @t{~<...~:>} supports a feature not supported by @b{pprint-logical-block}. If @t{~:@@>} is used to terminate the directive (@i{i.e.}, @t{~<...~:@@>}), @@ -2599,7 +2609,7 @@ @node Tilde Left-Brace-> Iteration, Tilde Right-Brace-> End of Iteration, Tilde Right-Bracket-> End of Conditional Expression, FORMAT Control-Flow Operations @subsubsection Tilde Left-Brace: Iteration -@t{~@{{@i{str}}~@}} +@t{~@{@i{str}~@}} This is an iteration construct. The argument should be a @i{list}, which is used as a set of arguments @@ -2837,7 +2847,7 @@ @node Tilde Circumflex-> Escape Upward, Tilde Newline-> Ignored Newline, Tilde Semicolon-> Clause Separator, FORMAT Miscellaneous Pseudo-Operations @subsubsection Tilde Circumflex: Escape Upward -{@t{~@t{^} }} +@t{~@t{^} } This is an escape construct. If there are no more arguments remaining to be processed, then the immediately @@ -2851,16 +2861,16 @@ construct. @example - (setq donestr "Done.~{@t{^}} ~D warning~:P.~{@t{^}} ~D error~:P.") -@result{} "Done.~{@t{^}} ~D warning~:P.~{@t{^}} ~D error~:P." + (setq donestr "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P.") +@result{} "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P." (format nil donestr) @result{} "Done." (format nil donestr 3) @result{} "Done. 3 warnings." (format nil donestr 1 5) @result{} "Done. 1 warning. 5 errors." @end example If a prefix parameter is given, then termination occurs if the parameter -is zero. (Hence @t{~{@t{^}}} is equivalent to -@t{~#{@t{^}}}.) If two +is zero. (Hence @t{~@t{^}} is equivalent to +@t{~#@t{^}}.) If two parameters are given, termination occurs if they are equal. [Reviewer Note by Barmar: Which equality predicate?] If three @@ -2869,14 +2879,14 @@ Of course, this is useless if all the prefix parameters are constants; at least one of them should be a @t{#} or a @t{V} parameter. -If @t{~{@t{^}}} is used within a @t{~:@{ } +If @t{~@t{^}} is used within a @t{~:@{ } construct, then it terminates the current iteration step because in the standard case it tests for remaining arguments of the current step only; the next iteration step -commences immediately. @t{~:{@t{^}}} is used to terminate +commences immediately. @t{~:@t{^}} is used to terminate the iteration process. -@t{~:{@t{^}}} +@t{~:@t{^}} may be used only if the command it would terminate is @t{~:@{ } or @t{~:@@@{ }. The entire iteration process is terminated if and only if the sublist that is @@ -2884,8 +2894,8 @@ the case of @t{~:@{ }, or the last @b{format} argument in the case of @t{~:@@@{ }. -@t{~:{@t{^}}} is not -equivalent to @t{~#:{@t{^}}}; +@t{~:@t{^}} is not +equivalent to @t{~#:@t{^}}; the latter terminates the entire iteration if and only if no arguments remain for the current iteration step. For example: @@ -2894,7 +2904,7 @@ (format nil "~:@{ ~@@?~:@t{^} ...~@} " '(("a") ("b"))) @result{} "a...b" @end example -If @t{~{@t{^}}} appears within a control string being processed +If @t{~@t{^}} appears within a control string being processed under the control of a @t{~?} directive, but not within any @t{~@{ } or @t{~<} construct within that string, then the string being @@ -2903,9 +2913,9 @@ continues within the string containing the @t{~?} directive at the point following that directive. -If @t{~{@t{^}}} +If @t{~@t{^}} appears within a @t{~[} or @t{~(} construct, -then all the commands up to the @t{~{@t{^}}} are properly selected +then all the commands up to the @t{~@t{^}} are properly selected or case-converted, the @t{~[} or @t{~(} processing is terminated, and the outward search continues @@ -2913,22 +2923,22 @@ to be terminated. For example: @example - (setq tellstr "~@@(~@@[~R~]~{@t{^}} ~A!~)") -@result{} "~@@(~@@[~R~]~{@t{^}} ~A!~)" + (setq tellstr "~@@(~@@[~R~]~@t{^} ~A!~)") +@result{} "~@@(~@@[~R~]~@t{^} ~A!~)" (format nil tellstr 23) @result{} "Twenty-three!" (format nil tellstr nil "losers") @result{} " Losers!" (format nil tellstr 23 "losers") @result{} "Twenty-three losers!" @end example -Following are examples of the use of @t{~{@t{^}}} +Following are examples of the use of @t{~@t{^}} within a @t{~<} construct. @example - (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo) + (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo) @result{} " FOO" - (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo 'bar) + (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar) @result{} "FOO BAR" - (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo 'bar 'baz) + (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar 'baz) @result{} "FOO BAR BAZ" @end example @@ -3149,7 +3159,7 @@ Note that the meaning of @b{nil} and @b{t} as destinations to @b{format} are different than those of @b{nil} and @b{t} as @i{stream designators}. -The @t{~{@t{^}}} should appear only at the beginning of a @t{~<} clause, +The @t{~@t{^}} should appear only at the beginning of a @t{~<} clause, because it aborts the entire clause in which it appears (as well as all following clauses). @@ -3197,7 +3207,7 @@ @node copy-pprint-dispatch, formatter, Printer Dictionary, Printer Dictionary @subsection copy-pprint-dispatch [Function] -@code{copy-pprint-dispatch} @i{{&optional} table} @result{} @i{new-table} +@code{copy-pprint-dispatch} @i{@r{&optional} table} @result{} @i{new-table} @subsubheading Arguments and Values:: @@ -3267,7 +3277,7 @@ @node pprint-dispatch, pprint-exit-if-list-exhausted, formatter, Printer Dictionary @subsection pprint-dispatch [Function] -@code{pprint-dispatch} @i{object {&optional} table} @result{} @i{function, found-p} +@code{pprint-dispatch} @i{object @r{&optional} table} @result{} @i{function, found-p} @subsubheading Arguments and Values:: @@ -3361,11 +3371,11 @@ @node pprint-fill, pprint-indent, pprint-exit-if-list-exhausted, Printer Dictionary @subsection pprint-fill, pprint-linear, pprint-tabular [Function] -@code{pprint-fill} @i{stream object {&optional} colon-p at-sign-p} @result{} @i{@b{nil}} +@code{pprint-fill} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} -@code{pprint-linear} @i{stream object {&optional} colon-p at-sign-p} @result{} @i{@b{nil}} +@code{pprint-linear} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} -@code{pprint-tabular} @i{stream object {&optional} colon-p at-sign-p tabsize} @result{} @i{@b{nil}} +@code{pprint-tabular} @i{stream object @r{&optional} colon-p at-sign-p tabsize} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -3467,7 +3477,7 @@ @node pprint-indent, pprint-logical-block, pprint-fill, Printer Dictionary @subsection pprint-indent [Function] -@code{pprint-indent} @i{relative-to n {&optional} stream} @result{} @i{@b{nil}} +@code{pprint-indent} @i{relative-to n @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -3521,8 +3531,8 @@ @subsection pprint-logical-block [Macro] @code{pprint-logical-block} @i{@r{(}stream-symbol object - {&key} prefix per-line-prefix suffix@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* + @r{&key} prefix per-line-prefix suffix@r{)} + @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -3663,7 +3673,7 @@ @node pprint-newline, pprint-pop, pprint-logical-block, Printer Dictionary @subsection pprint-newline [Function] -@code{pprint-newline} @i{kind {&optional} stream} @result{} @i{@b{nil}} +@code{pprint-newline} @i{kind @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -3888,7 +3898,7 @@ @node pprint-tab, print-object, pprint-pop, Printer Dictionary @subsection pprint-tab [Function] -@code{pprint-tab} @i{kind colnum colinc {&optional} stream} @result{} @i{@b{nil}} +@code{pprint-tab} @i{kind colnum colinc @r{&optional} stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -4064,13 +4074,13 @@ @subsubheading See Also:: -@ref{pprint-fill; pprint-linear; pprint-tabular} +@ref{pprint-fill} , @ref{pprint-logical-block} , @ref{pprint-pop} , -@ref{write; prin1; print; pprint; princ} +@ref{write} , @b{*print-readably*}, @b{*print-escape*}, @@ -4086,7 +4096,7 @@ @node print-unreadable-object, set-pprint-dispatch, print-object, Printer Dictionary @subsection print-unreadable-object [Macro] -@code{print-unreadable-object} @i{@r{(}object stream {&key} type identity@r{)} @{@i{form}@}{*}} @result{} @i{@b{nil}} +@code{print-unreadable-object} @i{@r{(}object stream @r{&key} type identity@r{)} @{@i{form}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -4144,7 +4154,7 @@ @node set-pprint-dispatch, write, print-unreadable-object, Printer Dictionary @subsection set-pprint-dispatch [Function] -@code{set-pprint-dispatch} @i{type-specifier function {&optional} priority table} @result{} @i{@b{nil}} +@code{set-pprint-dispatch} @i{type-specifier function @r{&optional} priority table} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -4208,16 +4218,16 @@ @node write, write-to-string, set-pprint-dispatch, Printer Dictionary @subsection write, prin1, print, pprint, princ [Function] -@code{write} @i{@i{object} {&key} \writekeys{stream}}@* +@code{write} @i{@i{object} @r{&key} \writekeys@r{stream}}@* @result{} @i{object} -@code{prin} @i{1} @result{} @i{object {&optional} output-stream} - {object} -@code{princ} @i{object {&optional} output-stream} @result{} @i{object} +@code{prin} @i{1} @result{} @i{object @r{&optional} output-stream} + @r{object} +@code{princ} @i{object @r{&optional} output-stream} @result{} @i{object} -@code{print} @i{object {&optional} output-stream} @result{} @i{object} +@code{print} @i{object @r{&optional} output-stream} @result{} @i{object} -@code{pprint} @i{object {&optional} output-stream} @result{} @i{<@i{no @i{values}}>} +@code{pprint} @i{object @r{&optional} output-stream} @result{} @i{<@i{no @i{values}}>} @subsubheading Arguments and Values:: @@ -4226,7 +4236,7 @@ @i{output-stream}---an @i{output} @i{stream designator}. The default is @i{standard output}. -\writekeydescriptions{@i{stream}---an @i{output} @i{stream designator}. +\writekeydescriptions@r{@i{stream}---an @i{output} @i{stream designator}. The default is @i{standard output}.} @subsubheading Description:: @@ -4244,6 +4254,7 @@ Once the appropriate @i{bindings} are @i{established}, the @i{object} is output by the @i{Lisp printer}. +@format @group @noindent @w{ Parameter Corresponding Dynamic Variable } @@ -4267,6 +4278,7 @@ @w{ Figure 22--6: Argument correspondences for the WRITE function.} @end group +@end format @b{prin1}, @b{princ}, @b{print}, and @b{pprint} implicitly @i{bind} certain print parameters to particular values. The remaining parameter @@ -4364,11 +4376,11 @@ @node write-to-string, *print-array*, write, Printer Dictionary @subsection write-to-string, prin1-to-string, princ-to-string [Function] -@code{write-to-string} @i{object {&key} \writekeys{}}@* +@code{write-to-string} @i{object @r{&key} \writekeys}@* @result{} @i{string} @code{prin} @i{1} @result{} @i{-to-string} - {object} {string} + @r{object} @r{string} @code{princ-to-string} @i{object} @result{} @i{string} @@ -4376,7 +4388,7 @@ @i{object}---an @i{object}. -\writekeydescriptions{} +\writekeydescriptions @i{string}---a @i{string}. @@ -4433,14 +4445,14 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} @subsubheading Notes:: @example - (write-to-string @i{object} @{@i{key} @i{argument}@}{*}) + (write-to-string @i{object} @{@i{key} @i{argument}@}*) @equiv{} (with-output-to-string (#1=#:string-stream) - (write object :stream #1# @{@i{key} @i{argument}@}{*})) + (write object :stream #1# @{@i{key} @i{argument}@}*)) (princ-to-string @i{object}) @equiv{} (with-output-to-string (string-stream) @@ -4554,9 +4566,9 @@ @ref{format} , -@ref{write; prin1; print; pprint; princ} +@ref{write} , -@ref{write-to-string; prin1-to-string; princ-to-string} +@ref{write-to-string} @node *print-case*, *print-circle*, *print-base*, Printer Dictionary @subsection *print-case* [Variable] @@ -4606,7 +4618,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} @subsubheading Notes:: @@ -4685,7 +4697,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} @subsubheading Notes:: @@ -4733,7 +4745,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} , @ref{readtable-case} @@ -4771,7 +4783,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} , @b{*print-escape*} @node *print-level*, *print-lines*, *print-gensym*, Printer Dictionary @@ -4862,7 +4874,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} @node *print-lines*, *print-miser-width*, *print-level*, Printer Dictionary @subsection *print-lines* [Variable] @@ -5027,7 +5039,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} @node *print-readably*, *print-right-margin*, *print-pretty*, Printer Dictionary @subsection *print-readably* [Variable] @@ -5129,7 +5141,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} , @ref{print-unreadable-object} @@ -5217,7 +5229,7 @@ @node format, , print-not-readable-object, Printer Dictionary @subsection format [Function] -@code{format} @i{destination control-string {&rest} args} @result{} @i{result} +@code{format} @i{destination control-string @r{&rest} args} @result{} @i{result} @subsubheading Arguments and Values:: @@ -5275,7 +5287,7 @@ @subsubheading See Also:: -@ref{write; prin1; print; pprint; princ} +@ref{write} , @ref{Documentation of Implementation-Defined Scripts} diff -uNr gcl-texi-orig/chap-23.texi gcl-texi/chap-23.texi --- gcl-texi-orig/chap-23.texi 1994-07-16 18:03:03 +0400 +++ gcl-texi/chap-23.texi 2002-10-17 20:53:05 +0400 @@ -263,7 +263,7 @@ @node copy-readtable, make-dispatch-macro-character, readtable, Reader Dictionary @subsection copy-readtable [Function] -@code{copy-readtable} @i{{&optional} from-readtable to-readtable} @result{} @i{readtable} +@code{copy-readtable} @i{@r{&optional} from-readtable to-readtable} @result{} @i{readtable} @subsubheading Arguments and Values:: @@ -332,7 +332,7 @@ @node make-dispatch-macro-character, read, copy-readtable, Reader Dictionary @subsection make-dispatch-macro-character [Function] -@code{make-dispatch-macro-character} @i{char {&optional} non-terminating-p readtable} @result{} @i{@b{t}} +@code{make-dispatch-macro-character} @i{char @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -374,14 +374,14 @@ @ref{readtable} , -@ref{set-dispatch-macro-character; get-dispatch-macro-character} +@ref{set-dispatch-macro-character} @node read, read-delimited-list, make-dispatch-macro-character, Reader Dictionary @subsection read, read-preserving-whitespace [Function] -@code{read} @i{{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{object} +@code{read} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{object} -@code{read-preserving-whitespace} @i{{&optional} input-stream eof-error-p +@code{read-preserving-whitespace} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p}@* @result{} @i{object} @@ -543,13 +543,13 @@ , @ref{parse-integer} , -{@ref{Syntax}}, -{@ref{Reader Concepts}} +@ref{Syntax}, +@ref{Reader Concepts} @node read-delimited-list, read-from-string, read, Reader Dictionary @subsection read-delimited-list [Function] -@code{read-delimited-list} @i{char {&optional} input-stream recursive-p} @result{} @i{list} +@code{read-delimited-list} @i{char @r{&optional} input-stream recursive-p} @result{} @i{list} @subsubheading Arguments and Values:: @@ -596,11 +596,11 @@ @subsubheading Examples:: @example - (read-delimited-list #\{]}) 1 2 3 4 5 6 {]} + (read-delimited-list #\@r{]}) 1 2 3 4 5 6 @r{]} @result{} (1 2 3 4 5 6) @end example -Suppose you wanted @t{#@{{@i{a}} @i{b} @i{c} ... @i{z}@}} +Suppose you wanted @t{#@{@i{a} @i{b} @i{c} ... @i{z}@}} to read as a list of all pairs of the elements @i{a}, @i{b}, @i{c}, ..., @i{z}, for example. @@ -659,7 +659,7 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} , @ref{peek-char} , @@ -680,8 +680,8 @@ @node read-from-string, readtable-case, read-delimited-list, Reader Dictionary @subsection read-from-string [Function] -@code{read-from-string} @i{string {&optional} eof-error-p eof-value - {&key} start end preserve-whitespace}@* +@code{read-from-string} @i{string @r{&optional} eof-error-p eof-value + @r{&key} start end preserve-whitespace}@* @result{} @i{object, position} @subsubheading Arguments and Values:: @@ -748,7 +748,7 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} , @b{read-preserving-whitespace} @@ -840,9 +840,9 @@ @i{[Function]} @end flushright -@code{get-dispatch-macro-character} @i{disp-char sub-char {&optional} readtable} @result{} @i{function} +@code{get-dispatch-macro-character} @i{disp-char sub-char @r{&optional} readtable} @result{} @i{function} -@code{set-dispatch-macro-character} @i{disp-char sub-char new-function {&optional} readtable} @result{} @i{@b{t}} +@code{set-dispatch-macro-character} @i{disp-char sub-char new-function @r{&optional} readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -940,9 +940,9 @@ @node set-macro-character, set-syntax-from-char, set-dispatch-macro-character, Reader Dictionary @subsection set-macro-character, get-macro-character [Function] -@code{get-macro-character} @i{char {&optional} readtable} @result{} @i{function, non-terminating-p} +@code{get-macro-character} @i{char @r{&optional} readtable} @result{} @i{function, non-terminating-p} -@code{set-macro-character} @i{char new-function {&optional} non-terminating-p readtable} @result{} @i{@b{t}} +@code{set-macro-character} @i{char new-function @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1022,7 +1022,7 @@ @node set-syntax-from-char, with-standard-io-syntax, set-macro-character, Reader Dictionary @subsection set-syntax-from-char [Function] -@code{set-syntax-from-char} @i{to-char from-char {&optional} to-readtable from-readtable} @result{} @i{@b{t}} +@code{set-syntax-from-char} @i{to-char from-char @r{&optional} to-readtable from-readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @@ -1075,7 +1075,7 @@ @subsubheading See Also:: -@ref{set-macro-character; get-macro-character} +@ref{set-macro-character} , @ref{make-dispatch-macro-character} , @@ -1093,7 +1093,7 @@ @node with-standard-io-syntax, *read-base*, set-syntax-from-char, Reader Dictionary @subsection with-standard-io-syntax [Macro] -@code{with-standard-io-syntax} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{with-standard-io-syntax} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -1111,6 +1111,7 @@ [Reviewer Note by Barrett: *print-pprint-dispatch* should probably be mentioned here, too.] +@format @group @noindent @w{ Variable Value } @@ -1140,6 +1141,7 @@ @w{ Figure 23--1: Values of standard control variables } @end group +@end format @subsubheading Examples:: @@ -1363,9 +1365,9 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} , -{@ref{Syntax}} +@ref{Syntax} @subsubheading Notes:: @@ -1443,7 +1445,7 @@ @subsubheading See Also:: -@ref{read; read-preserving-whitespace} +@ref{read} , @ref{stream-error-stream} , diff -uNr gcl-texi-orig/chap-24.texi gcl-texi/chap-24.texi --- gcl-texi-orig/chap-24.texi 1994-07-16 18:03:03 +0400 +++ gcl-texi/chap-24.texi 2002-10-17 20:53:05 +0400 @@ -97,12 +97,12 @@ if its argument @i{feature-conditional} fails; otherwise, it succeeds. -@item @t{(and @{@i{feature-conditional}@}{*})} +@item @t{(and @{@i{feature-conditional}@}*)} An @b{and} @i{feature expression} succeeds if all of its argument @i{feature-conditionals} succeed; otherwise, it fails. -@item @t{(or @{@i{feature-conditional}@}{*})} +@item @t{(or @{@i{feature-conditional}@}*)} An @b{or} @i{feature expression} succeeds if any of its argument @i{feature-conditionals} succeed; otherwise, it fails. @@ -124,6 +124,7 @@ Figure 24--1 shows some sample @i{expressions}, and how they would be @i{read}_2 in these @i{implementations}. +@format @group @noindent @w{ @t{(cons #+spice "Spice" #-spice "Lispm" x)} } @@ -151,6 +152,7 @@ @w{ Figure 24--1: Features examples } @end group +@end format @c end of including concept-systems @@ -176,7 +178,7 @@ @node compile-file, compile-file-pathname, System Construction Dictionary, System Construction Dictionary @subsection compile-file [Function] -@code{compile-file} @i{input-file {&key} output-file verbose +@code{compile-file} @i{input-file @r{&key} output-file verbose print external-format}@* @result{} @i{output-truename, warnings-p, failure-p} @@ -320,7 +322,7 @@ @node compile-file-pathname, load, compile-file, System Construction Dictionary @subsection compile-file-pathname [Function] -@code{compile-file-pathname} @i{input-file {&key} output-file {&allow-other-keys}} @result{} @i{pathname} +@code{compile-file-pathname} @i{input-file @r{&key} output-file @r{&allow-other-keys}} @result{} @i{pathname} @subsubheading Arguments and Values:: @@ -388,7 +390,7 @@ @node load, with-compilation-unit, compile-file-pathname, System Construction Dictionary @subsection load [Function] -@code{load} @i{filespec {&key} verbose print +@code{load} @i{filespec @r{&key} verbose print if-does-not-exist external-format}@* @result{} @i{generalized-boolean} @@ -567,7 +569,7 @@ @subsection with-compilation-unit [Macro] @code{with-compilation-unit} @i{@r{(}[[!@i{option}]]@r{)} - @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} + @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @w{@i{option} ::=@t{:override} override} @@ -908,7 +910,7 @@ @subsubheading See Also:: -@ref{provide; require} +@ref{provide} , @b{require} @@ -921,7 +923,7 @@ @code{provide} @i{module-name} @result{} @i{@i{implementation-dependent}} -@code{require} @i{module-name {&optional} pathname-list} @result{} @i{@i{implementation-dependent}} +@code{require} @i{module-name @r{&optional} pathname-list} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-25.texi gcl-texi/chap-25.texi --- gcl-texi-orig/chap-25.texi 1994-07-16 18:03:02 +0400 +++ gcl-texi/chap-25.texi 2002-10-17 20:53:05 +0400 @@ -36,6 +36,7 @@ @i{form}. Figure 25--1 lists variables that are maintained by the @i{Lisp read-eval-print loop}. +@format @group @noindent @w{ * + / - } @@ -46,6 +47,7 @@ @w{ Figure 25--1: Variables maintained by the Read-Eval-Print Loop} @end group +@end format @node Debugging Utilities, Environment Inquiry, Top level loop, The External Environment @subsection Debugging Utilities @@ -53,6 +55,7 @@ Figure 25--2 shows @i{defined names} relating to debugging. +@format @group @noindent @w{ *debugger-hook* documentation step } @@ -65,6 +68,7 @@ @w{ Figure 25--2: Defined names relating to debugging} @end group +@end format @node Environment Inquiry, Time, Debugging Utilities, The External Environment @subsection Environment Inquiry @@ -75,6 +79,7 @@ Figure 25--3 shows @i{defined names} relating to environment inquiry. +@format @group @noindent @w{ *features* machine-instance short-site-name } @@ -86,6 +91,7 @@ @w{ Figure 25--3: Defined names relating to environment inquiry. } @end group +@end format @node Time, , Environment Inquiry, The External Environment @subsection Time @@ -110,6 +116,7 @@ Figure 25--4 shows @i{defined names} relating to @i{time}. +@format @group @noindent @w{ decode-universal-time get-internal-run-time } @@ -121,6 +128,7 @@ @w{ Figure 25--4: Defined names involving Time. } @end group +@end format @menu * Decoded Time:: @@ -183,6 +191,7 @@ Figure 25--5 shows @i{defined names} relating to @i{decoded time}. +@format @group @noindent @w{ decode-universal-time get-decoded-time } @@ -191,6 +200,7 @@ @w{ Figure 25--5: Defined names involving time in Decoded Time.} @end group +@end format @node Universal Time, Internal Time, Decoded Time, Time @subsubsection Universal Time @@ -211,6 +221,7 @@ Because @i{universal time} must be a non-negative @i{integer}, times before the base time of midnight, January 1, 1900 GMT cannot be processed by @r{Common Lisp}. +@format @group @noindent @w{ decode-universal-time get-universal-time } @@ -220,6 +231,7 @@ @w{ Figure 25--6: Defined names involving time in Universal Time.} @end group +@end format @node Internal Time, Seconds, Universal Time, Time @subsubsection Internal Time @@ -233,6 +245,7 @@ Figure 25--7 shows @i{defined names} related to @i{internal time}. +@format @group @noindent @w{ get-internal-real-time internal-time-units-per-second } @@ -242,6 +255,7 @@ @w{ Figure 25--7: Defined names involving time in Internal Time.} @end group +@end format @node Seconds, , Internal Time, Time @subsubsection Seconds @@ -253,6 +267,7 @@ @b{sleep} can be any kind of non-negative @i{real}, in order to allow for the possibility of fractional seconds. +@format @group @noindent @w{ sleep } @@ -261,6 +276,7 @@ @w{ Figure 25--8: Defined names involving time in Seconds.} @end group +@end format @c end of including concept-environment @@ -289,10 +305,10 @@ * ed:: * inspect:: * dribble:: -* -:: -* +:: -* *:: -* /:: +* - (Variable):: +* + (Variable):: +* * (Variable):: +* / (Variable):: * lisp-implementation-type:: * short-site-name:: * machine-instance:: @@ -305,7 +321,7 @@ @node decode-universal-time, encode-universal-time, Environment Dictionary, Environment Dictionary @subsection decode-universal-time [Function] -@code{decode-universal-time} @i{universal-time {&optional} time-zone}@* +@code{decode-universal-time} @i{universal-time @r{&optional} time-zone}@* @result{} @i{second, minute, hour, date, month, year, day, daylight-p, zone} @subsubheading Arguments and Values:: @@ -354,7 +370,7 @@ @ref{encode-universal-time} , -@ref{get-universal-time; get-decoded-time} +@ref{get-universal-time} , @ref{Time} @@ -364,7 +380,7 @@ @subsubheading Syntax:: @code{encode-universal-time} @i{second minute hour date month year - {&optional} time-zone}@* + @r{&optional} time-zone}@* @result{} @i{universal-time} @subsubheading Arguments and Values:: @@ -511,9 +527,9 @@ @node apropos, describe, sleep, Environment Dictionary @subsection apropos, apropos-list [Function] -@code{apropos} @i{string {&optional} package} @result{} @i{<@i{no @i{values}}>} +@code{apropos} @i{string @r{&optional} package} @result{} @i{<@i{no @i{values}}>} -@code{apropos-list} @i{string {&optional} package} @result{} @i{symbols} +@code{apropos-list} @i{string @r{&optional} package} @result{} @i{symbols} @subsubheading Arguments and Values:: @@ -560,7 +576,7 @@ @node describe, describe-object, apropos, Environment Dictionary @subsection describe [Function] -@code{describe} @i{object {&optional} stream} @result{} @i{<@i{no @i{values}}>} +@code{describe} @i{object @r{&optional} stream} @result{} @i{<@i{no @i{values}}>} @subsubheading Arguments and Values:: @@ -700,9 +716,9 @@ @node trace, step, describe-object, Environment Dictionary @subsection trace, untrace [Macro] -@code{trace} @i{@{@i{function-name}@}{*}} @result{} @i{trace-result} +@code{trace} @i{@{@i{function-name}@}*} @result{} @i{trace-result} -@code{untrace} @i{@{@i{function-name}@}{*}} @result{} @i{untrace-result} +@code{untrace} @i{@{@i{function-name}@}*} @result{} @i{untrace-result} @subsubheading Arguments and Values:: @@ -795,7 +811,7 @@ @node step, time, trace, Environment Dictionary @subsection step [Macro] -@code{step} @i{form} @result{} @i{@{@i{result}@}{*}} +@code{step} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -830,7 +846,7 @@ @subsubheading See Also:: -@ref{trace; untrace} +@ref{trace} @subsubheading Notes:: @@ -841,7 +857,7 @@ @node time, internal-time-units-per-second, step, Environment Dictionary @subsection time [Macro] -@code{time} @i{form} @result{} @i{@{@i{result}@}{*}} +@code{time} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -895,7 +911,7 @@ purposes. For useful background information on the complicated issues involved in -interpreting timing results, see {Performance and Evaluation of Lisp Programs}. +interpreting timing results, see @i{Performance and Evaluation of Lisp Programs}. @node internal-time-units-per-second, get-internal-real-time, time, Environment Dictionary @subsection internal-time-units-per-second [Constant Variable] @@ -1215,7 +1231,7 @@ @node room, ed, documentation, Environment Dictionary @subsection room [Function] -@code{room} @i{{&optional} x} @result{} @i{@i{implementation-dependent}} +@code{room} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -1249,7 +1265,7 @@ @node ed, inspect, room, Environment Dictionary @subsection ed [Function] -@code{ed} @i{{&optional} x} @result{} @i{@i{implementation-dependent}} +@code{ed} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -1337,10 +1353,10 @@ of @t{?} or a ``help key'' by providing help, including a list of commands. -@node dribble, -, inspect, Environment Dictionary +@node dribble, - (Variable), inspect, Environment Dictionary @subsection dribble [Function] -@code{dribble} @i{{&optional} pathname} @result{} @i{@i{implementation-dependent}} +@code{dribble} @i{@r{&optional} pathname} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -1396,7 +1412,7 @@ @b{dribble} is intended primarily for interactive debugging; its effect cannot be relied upon when used in a program. -@node -, +, dribble, Environment Dictionary +@node - (Variable), + (Variable), dribble, Environment Dictionary @subsection - [Variable] @subsubheading Value Type:: @@ -1432,7 +1448,7 @@ (@i{variable}), @ref{Top level loop} -@node +, *, -, Environment Dictionary +@node + (Variable), * (Variable), - (Variable), Environment Dictionary @subsection +, ++, +++ [Variable] @subsubheading Value Type:: @@ -1479,7 +1495,7 @@ (@i{variable}), @ref{Top level loop} -@node *, /, +, Environment Dictionary +@node * (Variable), / (Variable), + (Variable), Environment Dictionary @subsection *, **, *** [Variable] @subsubheading Value Type:: @@ -1543,7 +1559,7 @@ *** @equiv{} (car ///) @end example -@node /, lisp-implementation-type, *, Environment Dictionary +@node / (Variable), lisp-implementation-type, * (Variable), Environment Dictionary @subsection /, //, /// [Variable] @subsubheading Value Type:: @@ -1588,7 +1604,7 @@ @b{*} (@i{variable}), @ref{Top level loop} -@node lisp-implementation-type, short-site-name, /, Environment Dictionary +@node lisp-implementation-type, short-site-name, / (Variable), Environment Dictionary @subsection lisp-implementation-type, @subheading lisp-implementation-version @flushright @@ -1804,7 +1820,7 @@ @node user-homedir-pathname, , software-type, Environment Dictionary @subsection user-homedir-pathname [Function] -@code{user-homedir-pathname} @i{{&optional} host} @result{} @i{pathname} +@code{user-homedir-pathname} @i{@r{&optional} host} @result{} @i{pathname} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-26.texi gcl-texi/chap-26.texi --- gcl-texi-orig/chap-26.texi 1994-07-16 18:03:01 +0400 +++ gcl-texi/chap-26.texi 2002-10-17 20:53:05 +0400 @@ -25,7 +25,7 @@ pronounced 'a ,list . The pronunciation key follows @i{Webster's Third New International Dictionary the English Language, Unabridged}, - except that ``{e}'' is used to notate the schwa (upside-down ``e'') character. + except that ``e'' is used to notate the schwa (upside-down ``e'') character. @item @t{*} the part or parts of speech, set in italics. If a term @@ -48,7 +48,7 @@ @item -- an optional discipline, set in italics, present if the term -has a standard definition being repeated. For example, ``{Math.}'' +has a standard definition being repeated. For example, ``Math.'' @item -- an optional context, present if this definition is @@ -59,7 +59,7 @@ @item -- an optional example sentence. For example, - {``This is an example of an example.''} + ``This is an example of an example.'' @item -- optional cross references. @@ -70,7 +70,7 @@ In addition, some terms have idiomatic usage in the Common Lisp community which is not shared by other communities, or which is not -technically correct. Definitions labeled ``{Idiom.}'' represent +technically correct. Definitions labeled ``Idiom.'' represent such idiomatic usage; these definitions are sometimes followed by an explanatory note. @@ -272,7 +272,7 @@ @item @b{alphanumeric} @i{adj.} (of a @i{character}) being either an @i{alphabetic}_1 @i{character} - or a @i{numeric} {character}. + or a @i{numeric} @i{character}. @IGindex{ampersand} @item @b{ampersand} @@ -332,8 +332,8 @@ @i{v.t.} (a @i{function} to a @i{list}) to @i{call} the @i{function} with arguments that are the @i{elements} of the @i{list}. - {``Applying the function @b{+} to a list of integers returns - the sum of the elements of that list.''} + ``Applying the function @b{+} to a list of integers returns + the sum of the elements of that list.'' @IGindex{argument} @item @b{argument} @@ -347,7 +347,7 @@ @item @b{argument evaluation order} @i{n.} the order in which @i{arguments} are evaluated in a function call. - {``The argument evaluation order for Common Lisp is left to right.''} + ``The argument evaluation order for Common Lisp is left to right.'' See @ref{Evaluation}. @IGindex{argument precedence order} @@ -418,13 +418,13 @@ @item @b{atom} @i{n.} any @i{object} that is not a @i{cons}. - {``A vector is an atom.''} + ``A vector is an atom.'' @IGindex{atomic} @item @b{atomic} @i{adj.} being an @i{atom}. - {``The number 3, the symbol @t{foo}, and @b{nil} are atomic.''} + ``The number 3, the symbol @t{foo}, and @b{nil} are atomic.'' @IGindex{atomic type specifier} @item @b{atomic type specifier} @@ -441,9 +441,9 @@ is its @i{code}_2, but @i{implementations} are permitted to have additional @i{implementation-defined} @i{attributes}. See @ref{Character Attributes}. - {``An implementation that support fonts + ``An implementation that support fonts might make font information an attribute of a character, - while others might represent font information separately from characters.''} + while others might represent font information separately from characters.'' @IGindex{aux variable} @item @b{aux variable} @@ -530,8 +530,8 @@ @i{n.} an association between a @i{name} and that which the @i{name} denotes. - {``A lexical binding is a lexical association between a - name and its value.''} + ``A lexical binding is a lexical association between a + name and its value.'' @IGindex{bit} @item @b{bit} @@ -624,13 +624,13 @@ @item @b{bound} @i{adj.}, @i{v.t.} 1. @i{adj.} having an associated denotation in a @i{binding}. - {``The variables named by a @b{let} are bound within - its body.''} + ``The variables named by a @b{let} are bound within + its body.'' See @i{unbound}. 2. @i{adj.} having a local @i{binding} which @i{shadows}_2 another. - {``The variable @b{*print-escape*} is bound while in - the @b{princ} function.''} + ``The variable @b{*print-escape*} is bound while in + the @b{princ} function.'' 3. @i{v.t.} the past tense of @i{bind}. @IGindex{bound declaration} @@ -736,8 +736,8 @@ @i{executed} in an @i{environment} where @i{bindings} for the @i{values} of its @i{parameters} have been @i{established} based on the @i{arguments}. - {``Calling the function @b{+} with the arguments - @t{5} and @t{1} yields a value of @t{6}.''} + ``Calling the function @b{+} with the arguments + @t{5} and @t{1} yields a value of @t{6}.'' 2. @i{n.} a @i{situation} in which a @i{function} is called. @IGindex{captured initialization form} @@ -746,9 +746,9 @@ an @i{initialization form} along with the @i{lexical environment} in which the @i{form} that defined the @i{initialization form} was @i{evaluated}. - {``Each newly added shared slot is set to the result of evaluating + ``Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified - in the @b{defclass} form for the new class.''} + in the @b{defclass} form for the new class.'' @IGindex{car} @item @b{car} @@ -757,20 +757,20 @@ the component of a @i{cons} corresponding to the first @i{argument} to @b{cons}; the other component is the @i{cdr}. - {``The function @b{rplaca} modifies the car of a cons.''} + ``The function @b{rplaca} modifies the car of a cons.'' b. (of a @i{list}) the first @i{element} of the @i{list}, or @b{nil} if the @i{list} is the @i{empty list}. 2. the @i{object} that is held in the @i{car}_1. - {``The function @b{car} returns the car of a cons.''} + ``The function @b{car} returns the car of a cons.'' @IGindex{case} @item @b{case} @i{n.} (of a @i{character}) the property of being either @i{uppercase} or @i{lowercase}. Not all @i{characters} have @i{case}. - {``The characters @t{#\A} and @t{#\a} have case, - but the character @t{#\$} has no case.''} + ``The characters @t{#\A} and @t{#\a} have case, + but the character @t{#\$} has no case.'' See @ref{Characters With Case} and the @i{function} @b{both-case-p}. @IGindex{case sensitivity mode} @@ -808,13 +808,13 @@ 1. a. (of a @i{cons}) the component of a @i{cons} corresponding to the second @i{argument} to @b{cons}; the other component is the @i{car}. - {``The function @b{rplacd} modifies the cdr of a cons.''} + ``The function @b{rplacd} modifies the cdr of a cons.'' b. (of a @i{list} L_1) either the @i{list} L_2 that contains the @i{elements} of L_1 that follow after the first, or else @b{nil} if L_1 is the @i{empty list}. 2. the @i{object} that is held in the @i{cdr}_1. - {``The function @b{cdr} returns the cdr of a cons.''} + ``The function @b{cdr} returns the cdr of a cons.'' @IGindex{cell} @item @b{cell} @@ -884,7 +884,7 @@ other @i{objects} called its @i{indirect instances}, and that acts as a @i{type specifier} for a set of objects called its @i{generalized instances}. - {``The class @b{integer} is a subclass of the class @b{number}.''} + ``The class @b{integer} is a subclass of the class @b{number}.'' (Note that the phrase ``the @i{class} @t{foo}'' is often substituted for the more precise phrase ``the @i{class} named @t{foo}''---in both cases, a @i{class} @i{object} (not a @i{symbol}) is denoted.) @@ -892,8 +892,8 @@ the uniquely determined @i{class} of which the @i{object} is a @i{direct instance}. See the @i{function} @b{class-of}. - {``The class of the object returned by @b{gensym} - is @b{symbol}.''} + ``The class of the object returned by @b{gensym} + is @b{symbol}.'' (Note that with this usage a phrase such as ``its @i{class} is @t{foo}'' is often substituted for the more precise phrase ``its @i{class} is the @i{class} named @t{foo}''---in both @@ -929,7 +929,7 @@ @IGindex{closed} @item @b{closed} @i{adj.} (of a @i{stream}) - having been @i{closed} (see @i{@i}{close}). + having been @i{closed} (see @i{close}). Some (but not all) operations that are valid on @i{open} @i{streams} are not valid on @i{closed} @i{streams}. See @ref{File Operations on Open and Closed Streams}. @@ -1149,7 +1149,7 @@ @item @b{composite stream} @i{n.} a @i{stream} that is composed of one or more other @i{streams}. - {``@b{make-synonym-stream} creates a composite stream.''} + ``@b{make-synonym-stream} creates a composite stream.'' @IGindex{compound form} @item @b{compound form} @@ -1165,7 +1165,7 @@ @i{n.} a @i{type specifier} that is a @i{cons}; @i{i.e.}, a @i{type specifier} that is not an @i{atomic type specifier}. - {``@t{(vector single-float)} is a compound type specifier.''} + ``@t{(vector single-float)} is a compound type specifier.'' @IGindex{concatenated stream} @item @b{concatenated stream} @@ -1286,24 +1286,24 @@ that neither affects nor is affected by the state of any @i{object} except those @i{objects} that are @i{otherwise inaccessible parts} of @i{objects} created by the @i{form} itself. - {``A @b{car} form in which the argument is a - @b{quote} form is a constant form.''} + ``A @b{car} form in which the argument is a + @b{quote} form is a constant form.'' @IGindex{constant object} @item @b{constant object} @i{n.} an @i{object} that is constrained (@i{e.g.}, by its context in a @i{program} or by the source from which it was obtained) to be @i{immutable}. - {``A literal object that has been processed by @b{compile-file} - is a constant object.''} + ``A literal object that has been processed by @b{compile-file} + is a constant object.'' @IGindex{constant variable} @item @b{constant variable} @i{n.} a @i{variable}, the @i{value} of which can never change; that is, a @i{keyword}_1 or a @i{named constant}. - {``The symbols @b{t}, @b{nil}, @t{:direction}, and - @b{most-positive-fixnum} are constant variables.''} + ``The symbols @b{t}, @b{nil}, @t{:direction}, and + @b{most-positive-fixnum} are constant variables.'' @IGindex{constituent} @item @b{constituent} @@ -1329,7 +1329,7 @@ a @i{stream} whose source or sink is a Lisp @i{object}. Note that since a @i{stream} is another Lisp @i{object}, @i{composite streams} are considered @i{constructed streams}. - {``A string stream is a constructed stream.''} + ``A string stream is a constructed stream.'' @IGindex{contagion} @item @b{contagion} @@ -1394,8 +1394,8 @@ 1. (by a @i{restart} other than @b{abort} that has been associated with the @i{error}) capable of being corrected by invoking that @i{restart}. - {``The function @b{cerror} signals an error - that is correctable by the @b{continue} @i{restart}.''} + ``The function @b{cerror} signals an error + that is correctable by the @b{continue} @i{restart}.'' (Note that correctability is not a property of an @i{error} @i{object}, but rather a property of the @@ -1407,9 +1407,9 @@ 2. (when no specific @i{restart} is mentioned) @i{correctable}_1 by at least one @i{restart}. - {``@b{import} signals a correctable error of @i{type} @b{package-error} + ``@b{import} signals a correctable error of @i{type} @b{package-error} if any of the imported symbols has the same name as - some distinct symbol already accessible in the package.''} + some distinct symbol already accessible in the package.'' @IGindex{current input base} @item @b{current input base} @@ -1573,7 +1573,7 @@ @item @b{defining form} @i{n.} a @i{form} that has the side-effect of @i{establishing} a definition. - {``@b{defun} and @b{defparameter} are defining forms.''} + ``@b{defun} and @b{defparameter} are defining forms.'' @IGindex{defsetf lambda list} @item @b{defsetf lambda list} @@ -1595,7 +1595,7 @@ @item @b{denormalized} @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) conforming to the description of ``denormalized'' as described by - {IEEE Standard for Binary Floating-Point Arithmetic}. + @i{IEEE Standard for Binary Floating-Point Arithmetic}. For example, in an @i{implementation} where the minimum possible exponent was @t{-7} but where @t{0.001} was a valid mantissa, the number @t{1.0e-10} might be representable as @t{0.001e-7} internally even if the @i{normalized} @@ -1646,8 +1646,8 @@ @item @b{different} @i{adj.} not the @i{same} - {``The strings @t{"FOO"} and @t{"foo"} are different under - @b{equal} but not under @b{equalp}.''} + ``The strings @t{"FOO"} and @t{"foo"} are different under + @b{equal} but not under @b{equalp}.'' @IGindex{digit} @item @b{digit} @@ -1664,18 +1664,18 @@ @i{objects} an @i{array} can hold along one axis. If the @i{array} is a @i{vector} with a @i{fill pointer}, the @i{fill pointer} is ignored. - {``The second dimension of that array is 7.''} + ``The second dimension of that array is 7.'' 2. an axis of an array. - {``This array has six dimensions.''} + ``This array has six dimensions.'' @IGindex{direct instance} @item @b{direct instance} @i{n.} (of a @i{class} C) an @i{object} whose @i{class} is C itself, rather than some @i{subclass} of C. - {``The function @b{make-instance} always returns a + ``The function @b{make-instance} always returns a direct instance of the class which is (or is named by) - its first argument.''} + its first argument.'' @IGindex{direct subclass} @item @b{direct subclass} @@ -1737,8 +1737,8 @@ In some cases, the @i{documentation string} is saved in such a way that it can later be obtained by supplying either an @i{object}, or by supplying a @i{name} and a ``kind'' to the @i{function} @b{documentation}. - {``The body of code in a @b{defmacro} form can be preceded - by a documentation string of kind @b{function}.''} + ``The body of code in a @b{defmacro} form can be preceded + by a documentation string of kind @b{function}.'' @IGindex{dot} @item @b{dot} @@ -1801,7 +1801,7 @@ an @i{extent} whose duration is bounded by points of @i{establishment} and @i{disestablishment} within the execution of a particular @i{form}. See @i{indefinite extent}. - {``Dynamic variable bindings have dynamic extent.''} + ``Dynamic variable bindings have dynamic extent.'' @IGindex{dynamic scope} @item @b{dynamic scope} @@ -1907,7 +1907,7 @@ @i{n.} 1. a set of @i{bindings}. See @ref{Introduction to Environments}. 2. an @i{environment object}. - {``@b{macroexpand} takes an optional environment argument.''} + ``@b{macroexpand} takes an optional environment argument.'' @IGindex{environment object} @item @b{environment object} @@ -1915,7 +1915,7 @@ an @i{object} representing a set of @i{lexical bindings}, used in the processing of a @i{form} to provide meanings for @i{names} within that @i{form}. - {``@b{macroexpand} takes an optional environment argument.''} + ``@b{macroexpand} takes an optional environment argument.'' (The @i{object} @b{nil} when used as an @i{environment object} denotes the @i{null lexical environment}; the @i{values} of @i{environment parameters} @@ -1966,7 +1966,7 @@ a @i{handler}, a @i{restart}, or an @i{environment}. - {``@b{let} establishes lexical bindings.''} + ``@b{let} establishes lexical bindings.'' @IGindex{evaluate} @item @b{evaluate} @@ -2029,7 +2029,7 @@ control and possibly @i{values} can be transferred both actively by using another @i{control form} and passively through the normal control and data flow of @i{evaluation}. - {``@b{catch} and @b{block} establish bindings for + ``@b{catch} and @b{block} establish bindings for exit points to which @b{throw} and @b{return-from}, respectively, can transfer control and values; @b{tagbody} establishes a binding for an exit point @@ -2037,7 +2037,7 @@ and @b{unwind-protect} establishes an exit point through which control might be transferred by operators such as @b{throw}, @b{return-from}, - and @b{go}.''} + and @b{go}.'' @IGindex{explicit return} @item @b{explicit return} @@ -2062,9 +2062,10 @@ The characters defined as @i{exponent markers} in the @i{standard readtable} are shown in Figure 26--1. For more information, see @ref{Character Syntax}. - {``The exponent marker `d' in `3.0d7' indicates - that this number is to be represented as a double float.''} + ``The exponent marker `d' in `3.0d7' indicates + that this number is to be represented as a double float.'' +@format @group @noindent @w{ Marker Meaning } @@ -2078,6 +2079,7 @@ @w{ Figure 26--1: Exponent Markers } @end group +@end format @IGindex{export} @item @b{export} @@ -2135,10 +2137,10 @@ 1. an @i{object}, often used to emphasize the use of the @i{object} to encode or represent information in a specialized format, such as program text. - {``The second expression in a @b{let} form is a list - of bindings.''} + ``The second expression in a @b{let} form is a list + of bindings.'' 2. the textual notation used to notate an @i{object} in a source file. - {``The expression @t{'sample} is equivalent to @t{(quote sample)}.''} + ``The expression @t{'sample} is equivalent to @t{(quote sample)}.'' @IGindex{expressly adjustable} @item @b{expressly adjustable} @@ -2181,7 +2183,7 @@ a list resembling an @i{ordinary lambda list} in form and purpose, but offering additional syntax or functionality not available in an @i{ordinary lambda list}. - {``@b{defmacro} uses extended lambda lists.''} + ``@b{defmacro} uses extended lambda lists.'' @IGindex{extension} @item @b{extension} @@ -2282,7 +2284,7 @@ or of the @i{environment}. 2. a @i{symbol} that names a @i{feature}_1. See @ref{Features}. - {``The @t{:ansi-cl} feature is present in all conforming implementations.''} + ``The @t{:ansi-cl} feature is present in all conforming implementations.'' @IGindex{feature expression} @item @b{feature expression} @@ -2370,8 +2372,8 @@ @item @b{finite} @i{adj.} (of a @i{type}) having a finite number of @i{elements}. - {``The type specifier @t{(integer 0 5)} denotes a finite type, - but the type specifiers @b{integer} and @t{(integer 0)} do not.''} + ``The type specifier @t{(integer 0 5)} denotes a finite type, + but the type specifiers @b{integer} and @t{(integer 0)} do not.'' @IGindex{fixnum} @item @b{fixnum} @@ -2398,7 +2400,7 @@ or a @i{self-evaluating object}. 3. (for an @i{operator}, as in ``<<@i{operator}>> @i{form}'') a @i{compound form} having that @i{operator} as its first element. - {``A @b{quote} form is a constant form.''} + ``A @b{quote} form is a constant form.'' @IGindex{formal argument} @item @b{formal argument} @@ -2439,12 +2441,12 @@ to mean that some special operation should be performed, possibly involving data supplied by the @i{format arguments} that accompanied the @i{format string}. See the @i{function} @b{format}. - {``In @t{"~D base 10 = ~8R"}, the character - sequences `@t{~D}' and `@t{~8R}' are format directives.''} + ``In @t{"~D base 10 = ~8R"}, the character + sequences `@t{~D}' and `@t{~8R}' are format directives.'' 2. the conceptual category of all @i{format directives}_1 which use the same dispatch character. - {``Both @t{"~3d"} and @t{"~3,'0D"} are valid uses of the - `@t{~D}' format directive.''} + ``Both @t{"~3d"} and @t{"~3,'0D"} are valid uses of the + `@t{~D}' format directive.'' @IGindex{format string} @item @b{format string} @@ -2581,8 +2583,8 @@ @i{n.} @i{implementation-dependent} compilation beyond @i{minimal compilation}. Further compilation is permitted to take place at @i{run time}. - {``Block compilation and generation of machine-specific instructions - are examples of further compilation.''} + ``Block compilation and generation of machine-specific instructions + are examples of further compilation.'' @end table @subheading @b{G} @@ -2673,7 +2675,7 @@ @item @b{glyph} @i{n.} a visual representation. - {``Graphic characters have associated glyphs.''} + ``Graphic characters have associated glyphs.'' @IGindex{go} @item @b{go} @@ -2749,6 +2751,7 @@ that is defined by the @i{implementation} to be an @i{I/O customization variable}. +@format @group @noindent @w{ *debug-io* *error-io* query-io* } @@ -2758,6 +2761,7 @@ @w{ Figure 26--2: Standardized I/O Customization Variables} @end group +@end format @IGindex{identical} @item @b{identical} @@ -2780,7 +2784,7 @@ @i{implementations} are not required to detect attempts to modify @i{immutable} @i{objects} or @i{cells}; the consequences of attempting to make such modification are undefined. - {``Numbers are immutable.''} + ``Numbers are immutable.'' @IGindex{implementation} @item @b{implementation} @@ -2861,7 +2865,7 @@ @item @b{indefinite extent} @i{n.} an @i{extent} whose duration is unlimited. - {``Most Common Lisp objects have indefinite extent.''} + ``Most Common Lisp objects have indefinite extent.'' @IGindex{indefinite scope} @item @b{indefinite scope} @@ -2878,7 +2882,7 @@ @i{n.} (of a @i{class} C_1) an @i{object} of @i{class} C_2, where C_2 is a @i{subclass} of C_1. - {``An integer is an indirect instance of the class @b{number}.''} + ``An integer is an indirect instance of the class @b{number}.'' @IGindex{inherit} @item @b{inherit} @@ -2912,8 +2916,8 @@ @i{n.} a @i{form} used to supply the initial @i{value} for a @i{slot} or @i{variable}. - {``The initialization form for a slot in a @b{defclass} form - is introduced by the keyword @t{:initform}.''} + ``The initialization form for a slot in a @b{defclass} form + is introduced by the keyword @t{:initform}.'' @IGindex{input} @item @b{input} @@ -3028,6 +3032,7 @@ or a @i{compound form} that has an @i{implementation-defined} @i{operator} and that is defined by the @i{implementation} to be an @i{iteration form}. +@format @group @noindent @w{ do do-external-symbols dotimes } @@ -3038,6 +3043,7 @@ @w{ Figure 26--3: Standardized Iteration Forms } @end group +@end format @IGindex{iteration variable} @item @b{iteration variable} @@ -3199,7 +3205,7 @@ @i{n.} @i{scope} that is limited to a spatial or textual region within the establishing @i{form}. - {``The names of parameters to a function normally are lexically scoped.''} + ``The names of parameters to a function normally are lexically scoped.'' @IGindex{lexical variable} @item @b{lexical variable} @@ -3303,9 +3309,9 @@ appearing as data in a @b{quote} @i{form}, or, if the @i{object} is a @i{self-evaluating object}, appearing as unquoted data. - {``In the form @t{(cons "one" '("two"))}, + ``In the form @t{(cons "one" '("two"))}, the expressions @t{"one"}, @t{("two")}, and @t{"two"} - are literal objects.''} + are literal objects.'' @IGindex{load} @item @b{load} @@ -3544,7 +3550,7 @@ but which deviates in syntax or functionality from the definition of an @i{ordinary lambda list}. See @i{ordinary lambda list}. - {``@b{deftype} uses a modified lambda list.''} + ``@b{deftype} uses a modified lambda list.'' @IGindex{most recent} @item @b{most recent} @@ -3571,13 +3577,13 @@ @item @b{multiple values} @i{n.} 1. more than one @i{value}. - {``The function @b{truncate} returns multiple values.''} + ``The function @b{truncate} returns multiple values.'' 2. a variable number of @i{values}, possibly including zero or one. - {``The function @b{values} returns multiple values.''} + ``The function @b{values} returns multiple values.'' 3. a fixed number of values other than one. - {``The macro @b{multiple-value-bind} is among the few + ``The macro @b{multiple-value-bind} is among the few operators in @r{Common Lisp} which can detect and manipulate - multiple values.''} + multiple values.'' @end table @subheading @b{N} @@ -3592,8 +3598,8 @@ 2. @i{v.t.} to give a @i{name} to. 3. @i{n.} (of an @i{object} having a name component) the @i{object} which is that component. - {``The string which is a symbol's name is returned - by @b{symbol-name}.''} + ``The string which is a symbol's name is returned + by @b{symbol-name}.'' 4. @i{n.} (of a @i{pathname}) a. the name component, returned by @b{pathname-name}. b. the entire namestring, returned by @b{namestring}. @@ -3612,16 +3618,16 @@ by the @i{implementation}, or by user code (see the @i{macro} @b{defconstant}) to always @i{yield} the same @i{value} when @i{evaluated}. - {``The value of a named constant may not be changed - by assignment or by binding.''} + ``The value of a named constant may not be changed + by assignment or by binding.'' @IGindex{namespace} @item @b{namespace} @i{n.} 1. @i{bindings} whose denotations are restricted to a particular kind. - {``The bindings of names to tags is the tag namespace.''} + ``The bindings of names to tags is the tag namespace.'' 2. any @i{mapping} whose domain is a set of @i{names}. - {``A package defines a namespace.''} + ``A package defines a namespace.'' @IGindex{namestring} @item @b{namestring} @@ -3710,8 +3716,8 @@ @i{n.} a transfer of control (and sometimes @i{values}) to an @i{exit point} for reasons other than a @i{normal return}. - {``The operators @b{go}, @b{throw}, - and @b{return-from} cause a non-local exit.''} + ``The operators @b{go}, @b{throw}, + and @b{return-from} cause a non-local exit.'' @IGindex{non-nil} @item @b{non-nil} @@ -3755,7 +3761,7 @@ @IGindex{normalized} @item @b{normalized} @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) - conforming to the description of ``normalized'' as described by {IEEE Standard for Binary Floating-Point Arithmetic}. + conforming to the description of ``normalized'' as described by @i{IEEE Standard for Binary Floating-Point Arithmetic}. See @i{denormalized}. @IGindex{null} @@ -3803,24 +3809,24 @@ @item @b{object} @i{n.} 1. any Lisp datum. - {``The function @b{cons} creates an object which refers - to two other objects.''} + ``The function @b{cons} creates an object which refers + to two other objects.'' 2. (immediately following the name of a @i{type}) an @i{object} which is of that @i{type}, used to emphasize that the @i{object} is not just a @i{name} for an object of that @i{type} but really an @i{element} of the @i{type} in cases where @i{objects} of that @i{type} (such as @b{function} or @b{class}) are commonly referred to by @i{name}. - {``The function @b{symbol-function} takes a function name - and returns a function object.''} + ``The function @b{symbol-function} takes a function name + and returns a function object.'' @IGindex{object-traversing} @item @b{object-traversing} @i{adj.} operating in succession on components of an @i{object}. - {``The operators @b{mapcar}, @b{maphash}, + ``The operators @b{mapcar}, @b{maphash}, @b{with-package-iterator} and @b{count} - perform object-traversing operations.''} + perform object-traversing operations.'' @IGindex{open} @item @b{open} @@ -3878,7 +3884,7 @@ @i{n.} the kind of @i{lambda list} used by @b{lambda}. See @i{modified lambda list} and @i{extended lambda list}. - {``@b{defun} uses an ordinary lambda list.''} + ``@b{defun} uses an ordinary lambda list.'' @IGindex{otherwise inaccessible part} @item @b{otherwise inaccessible part} @@ -3957,10 +3963,10 @@ @item @b{pairwise} @i{adv.} (of an adjective on a set) applying individually to all possible pairings of elements of the set. - {``The types A, B, and C are pairwise disjoint if + ``The types A, B, and C are pairwise disjoint if A and B are disjoint, B and C are disjoint, and - A and C are disjoint.''} + A and C are disjoint.'' @IGindex{parallel} @item @b{parallel} @@ -3988,8 +3994,8 @@ due to a prefix notation within the @i{format string} at the @i{format directive}'s point of use. See @ref{Formatted Output}. - {``In @t{"~3,'0D"}, the number @t{3} and the character - @t{#\0} are parameters to the @t{~D} format directive.''} + ``In @t{"~3,'0D"}, the number @t{3} and the character + @t{#\0} are parameters to the @t{~D} format directive.'' @IGindex{parameter specializer} @item @b{parameter specializer} @@ -4150,8 +4156,8 @@ @i{n.} (of @i{values} resulting from the @i{evaluation} of a @i{form}) the first @i{value}, if any, or else @b{nil} if there are no @i{values}. - {``The primary value returned by @b{truncate} is an - integer quotient, truncated toward zero.''} + ``The primary value returned by @b{truncate} is an + integer quotient, truncated toward zero.'' @IGindex{principal} @item @b{principal} @@ -4501,8 +4507,8 @@ 2. (of a @i{pathname}) representing a position in a directory hierarchy by motion from a position other than the root, which might therefore vary. - {``The notation @t{#P"../foo.text"} denotes a relative - pathname if the host file system is Unix.''} + ``The notation @t{#P"../foo.text"} denotes a relative + pathname if the host file system is Unix.'' See @i{absolute}. @IGindex{repertoire} @@ -4563,6 +4569,7 @@ as the @i{restart} which it invokes. Figure 26--4 shows a list of the @i{standardized} @i{restart functions}. +@format @group @noindent @w{ abort muffle-warning use-value } @@ -4572,6 +4579,7 @@ @w{ Figure 26--4: Standardized Restart Functions} @end group +@end format @IGindex{return} @item @b{return} @@ -4646,8 +4654,8 @@ @i{adj.} 1. (of @i{objects} under a specified @i{predicate}) indistinguishable by that @i{predicate}. - {``The symbol @t{car}, the string @t{"car"}, and the string @t{"CAR"} - are the @t{same} under @b{string-equal}''}. + ``The symbol @t{car}, the string @t{"car"}, and the string @t{"CAR"} + are the @t{same} under @b{string-equal}''. 2. (of @i{objects} if no predicate is implied by context) indistinguishable by @b{eql}. Note that @b{eq} might be capable of distinguishing some @@ -4656,13 +4664,13 @@ is @i{implementation-dependent}. Since @b{eq} is used only rarely in this specification, @b{eql} is the default predicate when none is mentioned explicitly. - {``The conses returned by two successive calls to @b{cons} - are never the same.''} + ``The conses returned by two successive calls to @b{cons} + are never the same.'' 3. (of @i{types}) having the same set of @i{elements}; that is, each @i{type} is a @i{subtype} of the others. - {``The types specified by @t{(integer 0 1)}, + ``The types specified by @t{(integer 0 1)}, @t{(unsigned-byte 1)}, - and @t{bit} are the same.''} + and @t{bit} are the same.'' @IGindex{satisfy the test} @item @b{satisfy the test} @@ -4711,7 +4719,7 @@ @i{evaluation} of a @i{form}) the second @i{value}, if any, or else @b{nil} if there are fewer than two @i{values}. - {``The secondary value returned by @b{truncate} is a remainder.''} + ``The secondary value returned by @b{truncate} is a remainder.'' @IGindex{section} @item @b{section} @@ -4726,7 +4734,7 @@ @i{cons}. If a @i{self-evaluating object} is @i{evaluated}, it @i{yields} itself as its only @i{value}. - {``Strings are self-evaluating objects.''} + ``Strings are self-evaluating objects.'' @IGindex{semi-standard} @item @b{semi-standard} @@ -4822,13 +4830,13 @@ @item @b{shadow} @i{v.t.} 1. to override the meaning of. - {``That binding of @t{X} shadows an outer one.''} + ``That binding of @t{X} shadows an outer one.'' 2. to hide the presence of. - {``That @b{macrolet} of @t{F} shadows the - outer @b{flet} of @t{F}.''} + ``That @b{macrolet} of @t{F} shadows the + outer @b{flet} of @t{F}.'' 3. to replace. - {``That package shadows the symbol @t{cl:car} with - its own symbol @t{car}.''} + ``That package shadows the symbol @t{cl:car} with + its own symbol @t{car}.'' @IGindex{shadowing symbol} @item @b{shadowing symbol} @@ -4981,7 +4989,7 @@ @item @b{singleton} @i{adj.} (of a @i{sequence}) having only one @i{element}. - {``@t{(list 'hello)} returns a singleton list.''} + ``@t{(list 'hello)} returns a singleton list.'' @IGindex{situation} @item @b{situation} @@ -5067,8 +5075,8 @@ having an @i{actual array element type} that is a @i{proper subtype} of the @i{type} @b{t}; see @ref{Array Elements}. - {``@t{(make-array 5 :element-type 'bit)} makes an array of length - five that is specialized for bits.''} + ``@t{(make-array 5 :element-type 'bit)} makes an array of length + five that is specialized for bits.'' @IGindex{specialized lambda list} @item @b{specialized lambda list} @@ -5086,8 +5094,8 @@ whose last element is a @i{list} L2 of length m (denoting a list L3 of length m+n-1 whose @i{elements} are L1_i for i < n-1 followed by L2_j for j < m). - {``The list (1 2 (3 4 5)) is a spreadable argument list designator for - the list (1 2 3 4 5).''} + ``The list (1 2 (3 4 5)) is a spreadable argument list designator for + the list (1 2 3 4 5).'' @IGindex{stack allocate} @item @b{stack allocate} @@ -5190,8 +5198,8 @@ @item @b{standardized} @i{adj.} (of a @i{name}, @i{object}, or definition) having been defined by @r{Common Lisp}. - {``All standardized variables that are required to - hold bidirectional streams have ``@t{-io*}'' in their name.''} + ``All standardized variables that are required to + hold bidirectional streams have ``@t{-io*}'' in their name.'' @IGindex{startup environment} @item @b{startup environment} @@ -5341,8 +5349,8 @@ an @i{expression} that is a @i{subexpression} of the @i{form}, and which by virtue of its position in that @i{form} is also a @i{form}. - {``@t{(f x)} and @t{x}, but not @t{exit}, are subforms of - @t{(return-from exit (f x))}.''} + ``@t{(f x)} and @t{x}, but not @t{exit}, are subforms of + @t{(return-from exit (f x))}.'' @IGindex{subrepertoire} @item @b{subrepertoire} @@ -5465,15 +5473,15 @@ an @i{object} that is the @i{same} as either some @i{cons} which makes up that @i{list} or the @i{atom} (if any) which terminates the @i{list}. - {``The empty list is a tail of every proper list.''} + ``The empty list is a tail of every proper list.'' @IGindex{target} @item @b{target} @i{n.} 1. (of a @i{constructed stream}) a @i{constituent} of the @i{constructed stream}. - {``The target of a synonym stream is - the value of its synonym stream symbol.''} + ``The target of a synonym stream is + the value of its synonym stream symbol.'' 2. (of a @i{displaced array}) the @i{array} to which the @i{displaced array} is displaced. (In the case of a chain of @i{constructed streams} or @i{displaced arrays}, @@ -5611,7 +5619,7 @@ @i{S_a} is a @i{subtype} of @i{S_b}.) 2. (immediately following the name of a @i{type}) a @i{subtype} of that @i{type}. - {``The type @b{vector} is an array type.''} + ``The type @b{vector} is an array type.'' @IGindex{type declaration} @item @b{type declaration} @@ -5641,9 +5649,9 @@ @item @b{type specifier} @i{n.} an @i{expression} that denotes a @i{type}. - {``The symbol @t{random-state}, the list @t{(integer 3 5)}, + ``The symbol @t{random-state}, the list @t{(integer 3 5)}, the list @t{(and list (not null))}, and the class named - @t{standard-class} are type specifiers.''} + @t{standard-class} are type specifiers.'' @end table @subheading @b{U} @@ -5765,7 +5773,7 @@ the @i{external symbols} of P_1 become @i{internal symbols} of P_2 unless they are explicitly @i{exported}.) - {``The package @t{CL-USER} uses the package @t{CL}.''} + ``The package @t{CL-USER} uses the package @t{CL}.'' @IGindex{use list} @item @b{use list} @@ -5808,9 +5816,9 @@ the phrase ``a @i{list} of @i{valid array indices}'' further implies that the @i{length} of the @i{list} must be the same as the @i{rank} of the @i{array}.) - {``For a @t{2} by~@t{3} array, + ``For a @t{2} by~@t{3} array, valid array indices for the first dimension are @t{0} and~@t{1}, and - valid array indices for the second dimension are @t{0}, @t{1} and~@t{2}.''} + valid array indices for the second dimension are @t{0}, @t{1} and~@t{2}.'' @IGindex{valid array row-major index} @item @b{valid array row-major index} @@ -6018,7 +6026,7 @@ @item @b{yield} @i{v.t.} (@i{values}) to produce the @i{values} as the result of @i{evaluation}. - {``The form @t{(+ 2 3)} yields @t{5}.''} + ``The form @t{(+ 2 3)} yields @t{5}.'' @end table diff -uNr gcl-texi-orig/chap-2.texi gcl-texi/chap-2.texi --- gcl-texi-orig/chap-2.texi 1994-07-16 18:03:22 +0400 +++ gcl-texi/chap-2.texi 2002-10-17 20:53:05 +0400 @@ -48,6 +48,7 @@ Figure 2--1 lists some @i{defined names} that are applicable to @i{readtables}. +@format @group @noindent @w{ *readtable* readtable-case } @@ -60,6 +61,7 @@ @w{ Figure 2--1: Readtable defined names } @end group +@end format @menu * The Current Readtable:: @@ -115,6 +117,7 @@ but also by various @i{dynamic variables}. Figure 2--2 lists the @i{variables} that influence the behavior of the @i{Lisp reader}. +@format @group @noindent @w{ *package* *read-default-float-format* *readtable* } @@ -124,6 +127,7 @@ @w{ Figure 2--2: Variables that influence the Lisp reader. } @end group +@end format @node Standard Characters, Character Syntax Types, Variables that affect the Lisp Reader, Character Syntax @subsection Standard Characters @@ -140,6 +144,7 @@ and the following additional ninety-four @i{graphic} @i{characters} or their equivalents: +@format @group @noindent @w{ Graphic ID Glyph Description Graphic ID Glyph Description } @@ -174,7 +179,9 @@ @w{ Figure 2--3: Standard Character Subrepertoire (Part 1 of 3: Latin Characters)} @end group +@end format +@format @group @noindent @w{ Graphic ID Glyph Description Graphic ID Glyph Description } @@ -188,7 +195,9 @@ @w{ Figure 2--4: Standard Character Subrepertoire (Part 2 of 3: Numeric Characters)} @end group +@end format +@format @group @noindent @w{ Graphic ID Glyph Description } @@ -229,9 +238,10 @@ @w{ Figure 2--5: Standard Character Subrepertoire (Part 3 of 3: Special Characters)} @end group +@end format The graphic IDs are not used within @r{Common Lisp}, -but are provided for cross reference purposes with {@r{ISO 6937/2}}. +but are provided for cross reference purposes with @r{ISO 6937/2}. Note that the first letter of the graphic ID categorizes the character as follows: L---Latin, N---Numeric, S---Special. @@ -256,6 +266,7 @@ Every @i{character} that can appear in the @i{input} @i{stream} is of one of the @i{syntax types} shown in @i{Figure~2--6}. +@format @group @noindent @w{ @i{constituent} @i{macro character} @i{single escape} } @@ -265,6 +276,7 @@ @w{ Figure 2--6: Possible Character Syntax Types } @end group +@end format The @i{syntax type} of a @i{character} in a @i{readtable} determines how that character is interpreted by the @i{Lisp reader} @@ -274,8 +286,9 @@ @i{Figure~2--7} lists the @i{syntax type} of each @i{character} in @i{standard syntax}. -{ + +@format @group @noindent @w{ character syntax type character syntax type } @@ -306,7 +319,8 @@ @w{ Figure 2--7: Character Syntax Types in Standard Syntax } @end group -} +@end format + The characters marked with an asterisk (*) are initially @i{constituents}, but they are not used in any standard @r{Common Lisp} notations. @@ -381,6 +395,7 @@ Any @i{character} quoted by a @i{single escape} is treated as an @i{alphabetic}_2 constituent, regardless of its normal syntax. +@format @group @noindent @w{ constituent traits constituent traits } @@ -421,6 +436,7 @@ @w{ @t{|} @i{alphabetic}_2* Rubout @i{invalid} } @w{ @t{~} @i{alphabetic}_2 } @end group +@end format @w{ Figure 2--8: Constituent Traits of Standard Characters and Semi-Standard Characters} @@ -799,13 +815,14 @@ The @i{token} is interpreted as a @i{number} if it satisfies the syntax for numbers specified in Figure 2--9. +@format @group @noindent @w{ @i{numeric-token} ::= !@i{integer} | !@i{ratio} | !@i{float} } @w{ @i{integer} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @i{decimal-point} | @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } @w{ @i{ratio} ::= @t{[}@i{sign}@t{]} @{@i{digit}@}^+ @i{slash} @{@i{digit}@}^+ } -@w{ @i{float} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}{*} @i{decimal-point} @{@i{decimal-digit}@}^+ @t{[}!@i{exponent}@t{]} } -@w{ | @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @t{[}@i{decimal-point} @{@i{decimal-digit}@}{*}@t{]} !@i{exponent} } +@w{ @i{float} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}* @i{decimal-point} @{@i{decimal-digit}@}^+ @t{[}!@i{exponent}@t{]} } +@w{ | @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @t{[}@i{decimal-point} @{@i{decimal-digit}@}*@t{]} !@i{exponent} } @w{ @i{exponent} ::= @i{exponent-marker} @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } @w{ @i{sign}---a @i{sign}.} @w{ @i{slash}---a @i{slash}} @@ -814,6 +831,7 @@ @w{ @i{decimal-digit}---a @i{digit} in @i{radix} @t{10}.} @w{ @i{digit}---a @i{digit} in the @i{current input radix}.} @end group +@end format @w{ Figure 2--9: Syntax for Numeric Tokens} @@ -863,7 +881,7 @@ The syntax involving a leading @i{package marker} followed by a @i{potential number} is not well-defined. The consequences of the use -of notation such as @t{:1}, @t{:1/2}, and @t{:2{@t{^}}3} in a +of notation such as @t{:1}, @t{:1/2}, and @t{:2^3} in a position where an expression appropriate for @b{read} is expected are unspecified. @@ -916,42 +934,48 @@ a @i{conforming implementation} is permitted, but not required, to define their meaning. +@format @group @noindent @w{ @t{1b5000} @t{777777q} @t{1.7J} @t{-3/4+6.7J} @t{12/25/83} } -@w{ @t{27{@t{^}}19} @t{3{@t{^}}4/5} @t{6//7} @t{3.1.2.6} @t{{@t{^}}-43@t{^}} } +@w{ @t{27^19} @t{3^4/5} @t{6//7} @t{3.1.2.6} @t{@t{^}-43@t{^}} } @w{ @t{3.141_592_653_589_793_238_4} @t{-3.7+2.6i-6.17j+19.6k} } @noindent @w{ Figure 2--10: Examples of reserved tokens } @end group +@end format The @i{tokens} in Figure 2--11 are not @i{potential numbers}; they are always treated as @i{symbols}: +@format @group @noindent @w{ @t{/} @t{/5} @t{+} @t{1+} @t{1-} } -@w{ @t{foo+} @t{ab.cd} @t{_} @t{@t{^}} @t{{@t{^}}/-} } +@w{ @t{foo+} @t{ab.cd} @t{_} @t{@t{^}} @t{@t{^}/-} } @noindent @w{ Figure 2--11: Examples of symbols} @end group +@end format The @i{tokens} in Figure 2--12 are @i{potential numbers} if the @i{current input base} is @t{16}, but they are always treated as @i{symbols} if the @i{current input base} is @t{10}. +@format @group @noindent -@w{ @t{bad-face} @t{25-dec-83} @t{a/b} @t{fad_cafe} @t{f{@t{^}}} } +@w{ @t{bad-face} @t{25-dec-83} @t{a/b} @t{fad_cafe} @t{f@t{^}} } @noindent @w{ Figure 2--12: Examples of symbols or potential numbers} @end group +@end format @node Constructing Numbers from Tokens, The Consing Dot, Numbers as Tokens, Interpretation of Tokens @subsection Constructing Numbers from Tokens @@ -1005,12 +1029,13 @@ entirely of zeros. Examples of @i{ratios} are in Figure 2--13. +@format @group @noindent @w{ @t{2/3} ;This is in canonical form } @w{ @t{4/6} ;A non-canonical form for 2/3 } @w{ @t{-17/23} ;A ratio preceded by a sign } -@w{ @t{-30517578125/32768} ;This is (-5/2)^{15} } +@w{ @t{-30517578125/32768} ;This is (-5/2)^15 } @w{ @t{10/5} ;The canonical form for this is @t{2} } @w{ @t{#o-101/75} ;Octal notation for -65/61 } @w{ @t{#3r120/21} ;Ternary notation for 15/7 } @@ -1021,6 +1046,7 @@ @w{ Figure 2--13: Examples of Ratios } @end group +@end format [Reviewer Note by Barmar: #o, #3r, #X, and #x mentioned above are not in the syntax rules defined just above that.] @@ -1059,6 +1085,7 @@ Figure 2--14 contains examples of notations for @i{floats}: +@format @group @noindent @w{ @t{0.0} ;Floating-point zero in default format } @@ -1084,6 +1111,7 @@ @w{ Figure 2--14: Examples of Floating-point numbers } @end group +@end format For information on how @i{floats} are printed, see @ref{Printing Floats}. @@ -1140,6 +1168,7 @@ these examples assume that the @i{readtable case} of the @i{current readtable} is @t{:upcase}. +@format @group @noindent @w{ @t{FROBBOZ} The @i{symbol} whose @i{name} is @t{FROBBOZ}. } @@ -1163,30 +1192,33 @@ @w{ Figure 2--15: Examples of the printed representation of symbols (Part 1 of 2)} @end group +@end format +@format @group @noindent @w{ @t{APL\\360} The @i{symbol} whose @i{name} is @t{APL\360}. } @w{ @t{apl\\360} Also the @i{symbol} whose @i{name} is @t{APL\360}. } -@w{ @t{\(b{@t{^}}2\)\ -\ 4*a@t{*c}} The @i{name} is @t{(B{@t{^}}2) - 4*A*C}. } +@w{ @t{\(b@t{^}2\)\ -\ 4*a@t{*c}} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } @w{ Parentheses and two spaces in it. } -@w{ @t{\(\b{@t{^}}2\)\ -\4*\a*\c} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } +@w{ @t{\(\b@t{^}2\)\ -\4*\a*\c} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @w{ Letters explicitly lowercase. } @w{ @t{|"|} The same as writing @t{\"}. } -@w{ @t{|(b{@t{^}}2) - 4*a*c|} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } +@w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @w{ @t{|frobboz|} The @i{name} is @t{frobboz}, not @t{FROBBOZ}. } @w{ @t{|APL\360|} The @i{name} is @t{APL360}. } @w{ @t{|APL\\360|} The @i{name} is @t{APL\360}. } @w{ @t{|apl\\360|} The @i{name} is @t{apl\360}. } @w{ @t{|\|\||} Same as @t{\|\|} ---the @i{name} is @t{||}. } -@w{ @t{|(B{@t{^}}2) - 4*A*C|} The @i{name} is @t{(B{@t{^}}2) - 4*A*C}. } +@w{ @t{|(B@t{^}2) - 4*A*C|} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } @w{ Parentheses and two spaces in it. } -@w{ @t{|(b{@t{^}}2) - 4*a*c|} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } +@w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @noindent @w{ Figure 2--16: Examples of the printed representation of symbols (Part 2 of 2)} @end group +@end format In the process of parsing a @i{symbol}, it is @i{implementation-dependent} which @@ -1214,6 +1246,7 @@ The valid patterns for @i{tokens} are summarized in Figure 2--17. +@format @group @noindent @w{ @t{@i{nnnnn}} a @i{number} } @@ -1232,6 +1265,7 @@ @w{ Figure 2--17: Valid patterns for tokens } @end group +@end format Note that @i{nnnnn} has number syntax, neither @i{xxxxx} nor @i{ppppp} has number syntax, @@ -1591,6 +1625,7 @@ Examples of the use of the @i{double-quote} character are in Figure 2--18. +@format @group @noindent @w{ @t{"Foo"} ;A string with three characters in it } @@ -1602,6 +1637,7 @@ @w{ Figure 2--18: Examples of the use of double-quote } @end group +@end format Note that to place a single escape character or a @i{double-quote} into a string, such a character must be preceded by a single escape character. @@ -1670,7 +1706,7 @@ may be interpreted to mean @example - (append {[} x1{]} {[} x2{]} {[} x3{]} ... {[} xn{]} (quote atom)) + (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] (quote atom)) @end example where the brackets are used to indicate @@ -1699,7 +1735,7 @@ @t{`(x1 x2 x3 ... xn . ,form)} may be interpreted to mean @example - (append {[} x1{]} {[} x2{]} {[} x3{]} ... {[} xn{]} form) + (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] form) @end example where the brackets indicate a transformation of an @t{xj} as described above. @@ -1769,7 +1805,7 @@ requirement. Implementors who have no particular reason to make one choice or another -might wish to refer to {IEEE Standard for the Scheme Programming Language}, which identifies a popular choice of +might wish to refer to @b{IEEE Standard for the Scheme Programming Language}, which identifies a popular choice of representation for such expressions that might provide useful to be useful compatibility for some user communities. There is no requirement, however, that any @i{conforming implementation} use this particular representation. @@ -1804,8 +1840,9 @@ The @i{reader macros} associated with the @i{dispatching macro character} @t{#} are described later in this section and summarized in Figure 2--19. -{ + +@format @group @noindent @w{ dispatch char purpose dispatch char purpose } @@ -1837,7 +1874,7 @@ @w{ [ undefined* T, t undefined } @w{ @t{\} character object U, u undefined } @w{ ] undefined* V, v undefined } -@w{ {@t{^}} undefined W, w undefined } +@w{ @t{^} undefined W, w undefined } @w{ @t{_} undefined X, x hexadecimal rational } @w{ ` undefined Y, y undefined } @w{ @t{|} balanced comment Z, z undefined } @@ -1847,7 +1884,8 @@ @w{ Figure 2--19: Standard # Dispatching Macro Character Syntax } @end group -} +@end format + The combinations marked by an asterisk (*) are explicitly reserved to the user. No @i{conforming implementation} defines them. @@ -2075,7 +2113,7 @@ For example, @example - #B1101 @equiv{} 13 ;1101{{}_2} + #B1101 @equiv{} 13 ;1101_2 #b101/11 @equiv{} 5/3 @end example @@ -2091,7 +2129,7 @@ @example #o37/15 @equiv{} 31/13 #o777 @equiv{} 511 - #o105 @equiv{} 69 ;105{{}_8} + #o105 @equiv{} 69 ;105_8 @end example The consequences are undefined if the token immediately following @@ -2106,7 +2144,7 @@ @example #xF00 @equiv{} 3840 - #x105 @equiv{} 261 ;105{{}_@{16@}} + #x105 @equiv{} 261 ;105_@t{16} @end example The consequences are undefined if the token immediately following @@ -2135,6 +2173,7 @@ Figure 2--20 contains examples of the use of @t{#B}, @t{#O}, @t{#X}, and @t{#R}. +@format @group @noindent @w{ @t{#2r11010101} ;Another way of writing @t{213} decimal } @@ -2152,6 +2191,7 @@ @w{ Figure 2--20: Radix Indicator Example } @end group +@end format The consequences are undefined if the token immediately following the @t{#@i{n}R} does not have the syntax of a @i{rational} in radix @i{n}. @@ -2176,6 +2216,7 @@ Figure 2--21 contains examples of the use of @t{#C}. +@format @group @noindent @w{ @t{#C(3.0s1 2.0s-1)} ;A @i{complex} with @i{small float} parts. } @@ -2187,6 +2228,7 @@ @w{ Figure 2--21: Complex Number Example } @end group +@end format For further information, see @ref{Printing Complexes} and @ref{Syntax of a Complex}. diff -uNr gcl-texi-orig/chap-3.texi gcl-texi/chap-3.texi --- gcl-texi-orig/chap-3.texi 1994-07-16 18:03:21 +0400 +++ gcl-texi/chap-3.texi 2002-10-17 20:58:11 +0400 @@ -297,6 +297,7 @@ Figure 3--1 lists some @i{defined names} that are applicable to assigning, binding, and defining @i{variables}. +@format @group @noindent @w{ boundp let progv } @@ -309,6 +310,7 @@ @w{ Figure 3--1: Some Defined Names Applicable to Variables} @end group +@end format The following is a description of each kind of variable. @@ -469,6 +471,7 @@ Figure 3--2 lists all of the @r{Common Lisp} @i{symbols} that have definitions as @i{special operators}. +@format @group @noindent @w{ block let* return-from } @@ -485,6 +488,7 @@ @w{ Figure 3--2: Common Lisp Special Operators } @end group +@end format @node Macro Forms, Function Forms, Special Forms, The Evaluation Model @subsubsection Macro Forms @@ -526,6 +530,7 @@ Figure 3--3 lists some @i{defined names} that are applicable to @i{macros}. +@format @group @noindent @w{ *macroexpand-hook* macro-function macroexpand-1 } @@ -535,6 +540,7 @@ @w{ Figure 3--3: Defined names applicable to macros } @end group +@end format @node Function Forms, Lambda Forms, Macro Forms, The Evaluation Model @subsubsection Function Forms @@ -593,6 +599,7 @@ Figure 3--4 lists some @i{defined names} that are applicable to @i{functions}. +@format @group @noindent @w{ apply fdefinition mapcan } @@ -608,6 +615,7 @@ @w{ Figure 3--4: Some function-related defined names } @end group +@end format @node Lambda Forms, Self-Evaluating Objects, Function Forms, The Evaluation Model @subsubsection Lambda Forms @@ -837,15 +845,15 @@ @example (contorted-example nil nil 2) - (block here{{}_1} ...) - (contorted-example nil #'(lambda () (return-from here{{}_1} 4)) 1) - (block here{{}_2} ...) - (contorted-example #'(lambda () (return-from here{{}_1} 4)) - #'(lambda () (return-from here{{}_2} 4)) + (block here_1 ...) + (contorted-example nil #'(lambda () (return-from here_1 4)) 1) + (block here_2 ...) + (contorted-example #'(lambda () (return-from here_1 4)) + #'(lambda () (return-from here_2 4)) 0) (funcall f) - where f @result{} #'(lambda () (return-from here{{}_1} 4)) - (return-from here{{}_1} 4) + where f @result{} #'(lambda () (return-from here_1 4)) + (return-from here_1 4) @end example At the time the @t{funcall} is executed @@ -854,8 +862,8 @@ The @b{return-from} @i{form} executed as a result of the @t{funcall} operation refers to the outer outstanding @i{exit point} -(here{{}_1}), not the -inner one (here{{}_2}). +(here_1), not the +inner one (here_2). It refers to that @i{exit point} textually visible at the point of execution of @b{function} @@ -867,8 +875,8 @@ @t{(funcall g)}, then the value of the call @t{(contorted-example nil nil 2)} would be @t{9}. The value would change because @b{funcall} would cause the -execution of @t{(return-from here{{}_2} 4)}, thereby causing -a return from the inner @i{exit point} (here{{}_2}). +execution of @t{(return-from here_2 4)}, thereby causing +a return from the inner @i{exit point} (here_2). When that occurs, the value @t{4} is returned from the middle invocation of @t{contorted-example}, @t{5} is added to that to get @t{9}, and that value is returned from the outer block @@ -967,6 +975,7 @@ one or more @i{forms} to @i{evaluate} and where to put the @i{values} returned by those @i{forms}. +@format @group @noindent @w{ multiple-value-bind multiple-value-prog1 return-from } @@ -977,6 +986,7 @@ @w{ Figure 3--5: Some operators applicable to receiving multiple values} @end group +@end format The @i{function} @b{values} can produce @i{multiple values}_2. @t{(values)} returns zero values; @@ -1202,6 +1212,7 @@ or else a form that can, at the discretion of the @i{code} doing the expansion, be used in place of the original @i{form}. +@format @group @noindent @w{ *macroexpand-hook* compiler-macro-function define-compiler-macro } @@ -1210,6 +1221,7 @@ @w{ Figure 3--6: Defined names applicable to compiler macros } @end group +@end format @node Purpose of Compiler Macros, Naming of Compiler Macros, Compiler Macros, Compilation Semantics @subsubsection Purpose of Compiler Macros @@ -1573,6 +1585,7 @@ plus .5 fil \offinterlineskip +@format @group @noindent @w{ @b{CT} @b{LT} @b{E} @b{Mode} @b{Action} @b{New Mode} } @@ -1586,6 +1599,7 @@ @w{ No No Yes NCT Discard --- } @w{ No No No --- Discard --- } @end group +@end format @w{ Figure 3--7: EVAL-WHEN processing} @@ -1689,6 +1703,7 @@ effects happen only when the defining macros appear at top level. +@format @group @noindent @w{ declaim define-modify-macro defsetf } @@ -1701,6 +1716,7 @@ @w{ Figure 3--8: Defining Macros That Affect the Compile-Time Environment} @end group +@end format @node Constraints on Macros and Compiler Macros, , Processing of Defining Macros, File Compilation @subsubsection Constraints on Macros and Compiler Macros @@ -2225,6 +2241,7 @@ defined by this standard. +@format @group @noindent @w{ declaration ignore special } @@ -2236,6 +2253,7 @@ @w{ Figure 3--9: Common Lisp Declaration Identifiers} @end group +@end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. @@ -2254,8 +2272,8 @@ @subsubsection Shorthand notation for Type Declarations A @i{type specifier} can be used as a @i{declaration identifier}. -@t{(@i{type-specifier} @{@i{var}@}{*})} is taken as shorthand for -@t{(type @i{type-specifier} @{@i{var}@}{*})}. +@t{(@i{type-specifier} @{@i{var}@}*)} is taken as shorthand for +@t{(type @i{type-specifier} @{@i{var}@}*)}. @node Declaration Scope, , Declaration Identifiers, Declarations @subsection Declaration Scope @@ -2424,6 +2442,7 @@ There are several kinds of @i{lambda lists}. +@format @group @noindent @w{ Context Kind of Lambda List } @@ -2452,10 +2471,12 @@ @w{ Figure 3--10: What Kind of Lambda Lists to Use } @end group +@end format Figure 3--11 lists some @i{defined names} that are applicable to @i{lambda lists}. +@format @group @noindent @w{ lambda-list-keywords lambda-parameters-limit } @@ -2464,6 +2485,7 @@ @w{ Figure 3--11: Defined names applicable to lambda lists} @end group +@end format @menu * Ordinary Lambda Lists:: @@ -2489,6 +2511,7 @@ The @i{defined names} in Figure 3--12 are those which use @i{ordinary lambda lists}: +@format @group @noindent @w{ define-method-combination handler-case restart-case } @@ -2499,10 +2522,12 @@ @w{ Figure 3--12: Standardized Operators that use Ordinary Lambda Lists} @end group +@end format An @i{ordinary lambda list} can contain the @i{lambda list keywords} shown in Figure 3--13. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @@ -2512,6 +2537,7 @@ @w{ Figure 3--13: Lambda List Keywords used by Ordinary Lambda Lists} @end group +@end format Each @i{element} of a @i{lambda list} is either a parameter specifier or a @i{lambda list keyword}. @@ -2521,15 +2547,15 @@ The syntax for @i{ordinary lambda lists} is as follows: -@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} -@w{ @t{[}{&optional} @{@i{var} | - @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} -@w{ @t{[}{&rest} @i{var}@t{]}} -@w{ @t{[}{&key} @{@i{var} | +@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} +@w{ @t{[}@r{&optional} @{@i{var} | + @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter @r{]}@r{]}@r{)}@}*@t{]}} +@w{ @t{[}@r{&rest} @i{var}@t{]}} +@w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} - @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} -@w{ @t{[}{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}@r{)}} + @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} +@w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} @w{ } A @i{var} or @i{supplied-p-parameter} must be a @i{symbol} @@ -2759,7 +2785,7 @@ These are not really parameters. If the @i{lambda list keyword} @b{&aux} is present, all specifiers after it are auxiliary variable specifiers. After all parameter specifiers have been processed, the -auxiliary variable specifiers (those following {&aux}) are processed +auxiliary variable specifiers (those following @b{&aux}) are processed from left to right. For each one, @i{init-form} is evaluated and @i{var} is bound to that value (or to @b{nil} if no @i{init-form} was specified). @b{&aux} variable processing is analogous to @@ -2876,16 +2902,17 @@ A @i{generic function lambda list} has the following syntax: -@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} -@w{ @t{[}{&optional} @{@i{var} | @r{(}@i{var}@r{)}@}{*}@t{]}} -@w{ @t{[}{&rest} @i{var}@t{]}} -@w{ @t{[}{&key} @{@i{var} | @r{(}@{@i{var} | - @r{(}@i{keyword-name} @i{var}@r{)}@}{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}@r{)}} +@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} +@w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var}@r{)}@}*@t{]}} +@w{ @t{[}@r{&rest} @i{var}@t{]}} +@w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | + @r{(}@i{keyword-name} @i{var}@r{)}@}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}@r{)}} @w{ } A @i{generic function lambda list} can contain the @i{lambda list keywords} shown in Figure 3--14. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&optional} } @@ -2895,6 +2922,7 @@ @w{ Figure 3--14: Lambda List Keywords used by Generic Function Lambda Lists} @end group +@end format A @i{generic function lambda list} differs from an @i{ordinary lambda list} in the following ways: @@ -2923,6 +2951,7 @@ The @i{defined names} in Figure 3--15 use @i{specialized lambda lists} in some way; see the dictionary entry for each for information about how. +@format @group @noindent @w{ defmethod defgeneric } @@ -2931,10 +2960,12 @@ @w{ Figure 3--15: Standardized Operators that use Specialized Lambda Lists} @end group +@end format A @i{specialized lambda list} can contain the @i{lambda list keywords} shown in Figure 3--16. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @@ -2944,20 +2975,21 @@ @w{ Figure 3--16: Lambda List Keywords used by Specialized Lambda Lists} @end group +@end format A @i{specialized lambda list} is syntactically the same as an @i{ordinary lambda list} except that each @i{required parameter} may optionally be associated with a @i{class} or @i{object} for which that @i{parameter} is @i{specialized}. -@w{@i{lambda-list} ::=@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{specializer}@r{]}@r{)}@}{*}} -@w{ @t{[}{&optional} @{@i{var} | - @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} -@w{ @t{[}{&rest} @i{var}@t{]}} -@w{ @t{[}{&key} @{@i{var} | +@w{@i{lambda-list} ::=@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{specializer}@r{]}@r{)}@}*} +@w{ @t{[}@r{&optional} @{@i{var} | + @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} +@w{ @t{[}@r{&rest} @i{var}@t{]}} +@w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} - @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} @r{[}@t{&allow-other-keys}@r{]}@t{]}} -@w{ @t{[}{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}@r{)}} + @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* @r{[}@t{&allow-other-keys}@r{]}@t{]}} +@w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} @w{ } @node Macro Lambda Lists, Destructuring Lambda Lists, Specialized Lambda Lists, Lambda Lists @@ -2968,6 +3000,7 @@ is used in describing @i{macros} defined by the @i{operators} in Figure 3--17. +@format @group @noindent @w{ define-compiler-macro defmacro macrolet } @@ -2977,32 +3010,33 @@ @w{ Figure 3--17: Operators that use Macro Lambda Lists} @end group +@end format With the additional restriction that an @i{environment parameter} may appear only once (at any of the positions indicated), a @i{macro lambda list} has the following syntax: -{ -@w{@i{reqvars} ::=@{@i{var} | !@i{pattern}@}{*}} -@w{@i{optvars} ::=@t{[}{&optional} @{@i{var} | - @r{(}{@{@i{var} | !@i{pattern}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} +@w{@i{reqvars} ::=@{@i{var} | !@i{pattern}@}*} -@w{@i{restvar} ::=@t{[}@{{@t{&rest}} | {&body}@} @i{@{@i{var} | !@i{pattern}@}}@t{]}} +@w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | + @r{(}@r{@{@i{var} | !@i{pattern}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} -@w{@i{keyvars} ::=@r{[}{&key} @{@i{var} | +@w{@i{restvar} ::=@t{[}@{@t{&rest} | @r{&body}@} @i{@{@i{var} | !@i{pattern}@}}@t{]}} + +@w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | - @r{(}@i{keyword-name} {@{@i{var} | !@i{pattern}@}}@r{)}@} - @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}} + @r{(}@i{keyword-name} @{@i{var} | !@i{pattern}@}@r{)}@} + @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} -{ -@w{@i{auxvars} ::=@t{[}{&aux} @{@i{var} | @r{(}{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}} -} -@w{@i{envvar} ::=@t{[}{&environment} @i{var}@t{]}} -@w{@i{wholevar} ::=@t{[}{&whole} @i{var}@t{]}} +@w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@r{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} + +@w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} + +@w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{envvar} !@i{reqvars} !@i{envvar} !@i{optvars} !@i{envvar}} @w{ !@i{restvar} !@i{envvar} !@i{keyvars} !@i{envvar} !@i{auxvars} !@i{envvar}@r{)} |} @@ -3011,11 +3045,12 @@ @w{@i{pattern} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} -} + A @i{macro lambda list} can contain the @i{lambda list keywords} shown in Figure 3--18. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&environment} @b{&rest} } @@ -3026,6 +3061,7 @@ @w{ Figure 3--18: Lambda List Keywords used by Macro Lambda Lists} @end group +@end format @i{Optional parameters} (introduced by @b{&optional}) and @i{keyword parameters} (introduced by @b{&key}) @@ -3287,31 +3323,30 @@ A @i{destructuring lambda list} has the following syntax: -{ -@w{@i{reqvars} ::=@{@i{var} | !@i{lambda-list}@}{*}} -@w{@i{optvars} ::=@t{[}{&optional} @{@i{var} | - @r{(}{@{@i{var} | !@i{lambda-list}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} +@w{@i{reqvars} ::=@{@i{var} | !@i{lambda-list}@}*} -@w{@i{restvar} ::=@t{[}@{{@t{&rest}} | {&body}@} @i{@{@i{var} | !@i{lambda-list}@}}@t{]}} +@w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | + @r{(}@{@i{var} | !@i{lambda-list}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} -@w{@i{keyvars} ::=@r{[}{&key} @{@i{var} | +@w{@i{restvar} ::=@t{[}@{@t{&rest}} | @t{&body}@} @i{@{@i{var} | !@i{lambda-list}@}@t{]}} + +@w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | - @r{(}@i{keyword-name} {@{@i{var} | !@i{lambda-list}@}}@r{)}@} - @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}} + @r{(}@i{keyword-name} @{@i{var} | !@i{lambda-list}@}@r{)}@} + @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} -{ -@w{@i{auxvars} ::=@t{[}{&aux} @{@i{var} | @r{(}{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}} -} -@w{@i{envvar} ::=@t{[}{&environment} @i{var}@t{]}} -@w{@i{wholevar} ::=@t{[}{&whole} @i{var}@t{]}} +@w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} + +@w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} + +@w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} -} @node Boa Lambda Lists, Defsetf Lambda Lists, Destructuring Lambda Lists, Lambda Lists @subsection Boa Lambda Lists @@ -3432,19 +3467,20 @@ A @i{defsetf lambda list} has the following syntax: -@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} -@w{ @t{[}{&optional} @{@i{var} | - @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} -@w{ @t{[}{&rest} @i{var}@t{]}} -@w{ @t{[}{&key} @{@i{var} | +@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} +@w{ @t{[}@r{&optional} @{@i{var} | + @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} +@w{ @t{[}@r{&rest} @i{var}@t{]}} +@w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} - @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} -@w{ @t{[}{&environment} @i{var}@t{]}} + @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} +@w{ @t{[}@r{&environment} @i{var}@t{]}} A @i{defsetf lambda list} can contain the @i{lambda list keywords} shown in Figure 3--19. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @@ -3454,6 +3490,7 @@ @w{ Figure 3--19: Lambda List Keywords used by Defsetf Lambda Lists} @end group +@end format A @i{defsetf lambda list} differs from an @i{ordinary lambda list} only in that it does not permit the use of @b{&aux}, @@ -3486,6 +3523,7 @@ A @i{define-modify-macro lambda list} can contain the @i{lambda list keywords} shown in Figure 3--20. +@format @group @noindent @w{ @b{&optional} @b{&rest} } @@ -3494,6 +3532,7 @@ @w{ Figure 3--20: Lambda List Keywords used by Define-modify-macro Lambda Lists} @end group +@end format @i{Define-modify-macro lambda lists} are similar to @i{ordinary lambda lists}, but do not support keyword arguments. @@ -3513,6 +3552,7 @@ A @i{define-method-combination arguments lambda list} can contain the @i{lambda list keywords} shown in Figure 3--21. +@format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @@ -3522,6 +3562,7 @@ @w{ Figure 3--21: Lambda List Keywords used by Define-method-combination arguments Lambda Lists} @end group +@end format @i{Define-method-combination arguments lambda lists} are similar to @i{ordinary lambda lists}, but also permit the use of @b{&whole}. @@ -3979,7 +4020,7 @@ @subsubheading Syntax:: -@code{lambda} @i{lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} +@code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} @subsubheading Arguments:: @i{lambda-list}---an @i{ordinary lambda list}. @@ -4003,7 +4044,7 @@ @subsubheading See Also:: @b{function}, -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Lambda Expressions}, @ref{Lambda Forms}, @@ -4026,7 +4067,7 @@ @node lambda, compile, lambda (Symbol), Evaluation and Compilation Dictionary @subsection lambda [Macro] -@code{lambda} @i{lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} @result{} @i{@i{function}} +@code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} @result{} @i{@i{function}} @subsubheading Arguments and Values:: @@ -4046,9 +4087,9 @@ involving a @i{lambda expression} such that: @example - (lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}) - @equiv{} (function (lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*})) - @equiv{} #'(lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}) + (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) + @equiv{} (function (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*)) + @equiv{} #'(lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) @end example @subsubheading Examples:: @@ -4074,7 +4115,7 @@ @node compile, eval, lambda, Evaluation and Compilation Dictionary @subsection compile [Function] -@code{compile} @i{name {&optional} definition} @result{} @i{function, warnings-p, failure-p} +@code{compile} @i{name @r{&optional} definition} @result{} @i{function, warnings-p, failure-p} @subsubheading Arguments and Values:: @@ -4174,7 +4215,7 @@ @node eval, eval-when, compile, Evaluation and Compilation Dictionary @subsection eval [Function] -@code{eval} @i{form} @result{} @i{@{@i{result}@}{*}} +@code{eval} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -4242,19 +4283,19 @@ @node eval-when, load-time-value, eval, Evaluation and Compilation Dictionary @subsection eval-when [Special Operator] -@code{eval-when} @i{@r{(}@{@i{situation}@}{*}@r{)} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{eval-when} @i{@r{(}@{@i{situation}@}*@r{)} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{situation}---One of the @i{symbols} @t{:compile-toplevel} -@IKindex{compile-toplevel} +@c @IKindex{compile-toplevel} , @t{:load-toplevel} -@IKindex{load-toplevel} +@c @IKindex{load-toplevel} , @t{:execute} -@IKindex{execute} +@c @IKindex{execute} , @b{compile} @IRindex{compile} @@ -4452,7 +4493,7 @@ @node load-time-value, quote, eval-when, Evaluation and Compilation Dictionary @subsection load-time-value [Special Operator] -@code{load-time-value} @i{form {&optional} read-only-p} @result{} @i{object} +@code{load-time-value} @i{form @r{&optional} read-only-p} @result{} @i{object} @subsubheading Arguments and Values:: @@ -4653,9 +4694,9 @@ @node compiler-macro-function, define-compiler-macro, quote, Evaluation and Compilation Dictionary @subsection compiler-macro-function [Accessor] -@code{compiler-macro-function} @i{name {&optional} environment} @result{} @i{function} +@code{compiler-macro-function} @i{name @r{&optional} environment} @result{} @i{function} -(setf (@code{ compiler-macro-function} @i{name {&optional} environment}) new-function)@* +(setf (@code{ compiler-macro-function} @i{name @r{&optional} environment}) new-function)@* @subsubheading Arguments and Values:: @@ -4685,7 +4726,7 @@ @node define-compiler-macro, defmacro, compiler-macro-function, Evaluation and Compilation Dictionary @subsection define-compiler-macro [Macro] -@code{define-compiler-macro} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* +@code{define-compiler-macro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* @result{} @i{name} @subsubheading Arguments and Values:: @@ -4849,7 +4890,7 @@ , @ref{defmacro} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Syntactic Interaction of Documentation Strings and Declarations} @@ -4867,7 +4908,7 @@ @node defmacro, macro-function, define-compiler-macro, Evaluation and Compilation Dictionary @subsection defmacro [Macro] -@code{defmacro} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* +@code{defmacro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* @result{} @i{name} @subsubheading Arguments and Values:: @@ -5041,9 +5082,9 @@ @ref{destructuring-bind} , -@ref{documentation; (setf documentation)} +@ref{documentation} , -@ref{macroexpand; macroexpand-1} +@ref{macroexpand} , @b{*macroexpand-hook*}, @b{macrolet}, @@ -5056,9 +5097,9 @@ @node macro-function, macroexpand, defmacro, Evaluation and Compilation Dictionary @subsection macro-function [Accessor] -@code{macro-function} @i{symbol {&optional} environment} @result{} @i{function} +@code{macro-function} @i{symbol @r{&optional} environment} @result{} @i{function} -(setf (@code{ macro-function} @i{symbol {&optional} environment}) new-function)@* +(setf (@code{ macro-function} @i{symbol @r{&optional} environment}) new-function)@* @subsubheading Arguments and Values:: @@ -5139,10 +5180,10 @@ @node macroexpand, define-symbol-macro, macro-function, Evaluation and Compilation Dictionary @subsection macroexpand, macroexpand-1 [Function] -@code{macroexpand} @i{form {&optional} env} @result{} @i{expansion, expanded-p} +@code{macroexpand} @i{form @r{&optional} env} @result{} @i{expansion, expanded-p} -@code{macroexpand-} @i{1} @result{} @i{form {&optional} env} - {expansion, expanded-p} +@code{macroexpand-} @i{1} @result{} @i{form @r{&optional} env} + @r{expansion, expanded-p} @subsubheading Arguments and Values:: @@ -5276,7 +5317,7 @@ @b{*macroexpand-hook*}, @ref{defmacro} , -@ref{setf; psetf} +@ref{setf} of @ref{macro-function} , @@ -5372,15 +5413,15 @@ @ref{symbol-macrolet} , -@ref{macroexpand; macroexpand-1} +@ref{macroexpand} @node symbol-macrolet, *macroexpand-hook*, define-symbol-macro, Evaluation and Compilation Dictionary @subsection symbol-macrolet [Special Operator] -@code{symbol-macrolet} @i{@r{(}@{{(}symbol expansion@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{symbol-macrolet} @i{@r{(}@{@r{(}symbol expansion @r{)}@}*@r{)} + @{@i{declaration}@}* + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -5463,7 +5504,7 @@ @ref{with-slots} , -@ref{macroexpand; macroexpand-1} +@ref{macroexpand} @subsubheading Notes:: @@ -5518,7 +5559,7 @@ @subsubheading See Also:: -@ref{macroexpand; macroexpand-1} +@ref{macroexpand} , @b{macroexpand-1}, @ref{funcall} , @ref{Evaluation} @@ -5566,6 +5607,7 @@ Figure 3--22 shows a list of @i{declaration identifiers} that can be used with @b{proclaim}. +@format @group @noindent @w{ declaration inline optimize type } @@ -5575,6 +5617,7 @@ @w{ Figure 3--22: Global Declaration Specifiers} @end group +@end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. @@ -5628,7 +5671,7 @@ @node declaim, declare, proclaim, Evaluation and Compilation Dictionary @subsection declaim [Macro] -@code{declaim} @i{@{@i{declaration-specifier}@}{*}} @result{} @i{@i{implementation-dependent}} +@code{declaim} @i{@{@i{declaration-specifier}@}*} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -5656,7 +5699,7 @@ @subsubheading Syntax:: -@code{declare} @i{@{@i{declaration-specifier}@}{*}} +@code{declare} @i{@{@i{declaration-specifier}@}*} @subsubheading Arguments:: @i{declaration-specifier}---a @i{declaration specifier}; not evaluated. @@ -5671,6 +5714,7 @@ A @b{declare} @i{expression} can occur in a @i{lambda expression} or in any of the @i{forms} listed in Figure 3--23. +@format @group @noindent @w{ defgeneric do-external-symbols prog } @@ -5691,6 +5735,7 @@ @w{ Figure 3--23: Standardized Forms In Which Declarations Can Occur } @end group +@end format A @b{declare} @i{expression} can only occur where specified by the syntax of these @i{forms}. @@ -5708,6 +5753,7 @@ Figure 3--24 shows a list of @i{declaration identifiers} that can be used with @b{declare}. +@format @group @noindent @w{ dynamic-extent ignore optimize } @@ -5718,6 +5764,7 @@ @w{ Figure 3--24: Local Declaration Specifiers} @end group +@end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. @@ -5782,9 +5829,9 @@ @subsubheading Syntax:: -@t{@r{(}ignore @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}{*}@r{)}} +@t{@r{(}ignore @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} -@t{@r{(}ignorable @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}{*}@r{)}} +@t{@r{(}ignorable @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} @subsubheading Arguments:: @@ -5861,7 +5908,7 @@ @subsubheading Syntax:: -@t{(dynamic-extent [[@{@i{var}@}{*} | +@t{(dynamic-extent [[@{@i{var}@}* | @r{(}@b{function} @i{fn}@r{)}@r{*}]])} @subsubheading Arguments:: @@ -6075,9 +6122,9 @@ @subsubheading Syntax:: -@t{(type @i{typespec} @{@i{var}@}{*})} +@t{(type @i{typespec} @{@i{var}@}*)} -@t{(@i{typespec} @{@i{var}@}{*})} +@t{(@i{typespec} @{@i{var}@}*)} @subsubheading Arguments:: @@ -6250,8 +6297,8 @@ @subsubheading Notes:: -@t{(@i{typespec} @{@i{var}@}{*})} -is an abbreviation for @t{(type @i{typespec} @{@i{var}@}{*})}. +@t{(@i{typespec} @{@i{var}@}*)} +is an abbreviation for @t{(type @i{typespec} @{@i{var}@}*)}. A @b{type} declaration for the arguments to a function does not necessarily imply anything about the type of the result. The following @@ -6303,9 +6350,9 @@ @subsubheading Syntax:: -@t{(inline @{@i{function-name}@}{*})} +@t{(inline @{@i{function-name}@}*)} -@t{(notinline @{@i{function-name}@}{*})} +@t{(notinline @{@i{function-name}@}*)} @subsubheading Arguments:: @@ -6422,7 +6469,7 @@ @subsubheading Syntax:: -@t{(ftype @i{type} @{@i{function-name}@}{*})} +@t{(ftype @i{type} @{@i{function-name}@}*)} @subsubheading Arguments:: @@ -6483,7 +6530,7 @@ @subsubheading Syntax:: -@t{(declaration @{@i{name}@}{*})} +@t{(declaration @{@i{name}@}*)} @subsubheading Arguments:: @@ -6522,7 +6569,7 @@ @subsubheading Syntax:: -@t{(optimize @{@i{quality} | (@i{quality} @i{value})@}{*})} +@t{(optimize @{@i{quality} | (@i{quality} @i{value})@}*)} @IRindex{compilation-speed} @@ -6552,6 +6599,7 @@ the names and meanings of the standard @i{optimize qualities} are shown in Figure 3--25. +@format @group @noindent @w{ Name Meaning } @@ -6565,6 +6613,7 @@ @w{ Figure 3--25: Optimize qualities } @end group +@end format There may be other, @i{implementation-defined} @i{optimize qualities}. @@ -6617,7 +6666,7 @@ @subsubheading Syntax:: -@t{(special @{@i{var}@}{*})} +@t{(special @{@i{var}@}*)} @subsubheading Arguments:: @@ -6764,14 +6813,14 @@ @subsubheading See Also:: -@ref{defparameter; defvar} +@ref{defparameter} , @b{defvar} @node locally, the, special, Evaluation and Compilation Dictionary @subsection locally [Special Operator] -@code{locally} @i{@{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{locally} @i{@{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -6838,7 +6887,7 @@ @node the, special-operator-p, locally, Evaluation and Compilation Dictionary @subsection the [Special Operator] -@code{the} @i{value-type form} @result{} @i{@{@i{result}@}{*}} +@code{the} @i{value-type form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -6950,7 +6999,7 @@ @node constantp, , special-operator-p, Evaluation and Compilation Dictionary @subsection constantp [Function] -@code{constantp} @i{form {&optional} environment} @result{} @i{generalized-boolean} +@code{constantp} @i{form @r{&optional} environment} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-4.texi gcl-texi/chap-4.texi --- gcl-texi-orig/chap-4.texi 1994-07-16 18:03:20 +0400 +++ gcl-texi/chap-4.texi 2002-10-17 20:53:05 +0400 @@ -88,6 +88,7 @@ that are particularly relevant to the object system. @i{Figure~9--1} lists the defined @i{condition} @i{types}. +@format @group @noindent @w{ @b{Section} Data Type } @@ -106,6 +107,7 @@ @w{ Figure 4--1: Cross-References to Data Type Information } @end group +@end format @node Type Relationships, Type Specifiers, Data Type Definition, Types @subsection Type Relationships @@ -182,6 +184,7 @@ or @b{deftype}. +@format @group @noindent @w{ arithmetic-error function simple-condition } @@ -222,6 +225,7 @@ @w{ Figure 4--2: Standardized Atomic Type Specifiers } @end group +@end format \indent If a @i{type specifier} is a @i{list}, the @i{car} of the @i{list} @@ -270,6 +274,7 @@ and then to @t{vector}. +@format @group @noindent @w{ and long-float simple-base-string } @@ -288,11 +293,13 @@ @w{ Figure 4--3: Standardized Compound Type Specifier Names} @end group +@end format Figure 4--4 show the @i{defined names} that can be used as @i{compound type specifier} @i{names} but that cannot be used as @i{atomic type specifiers}. +@format @group @noindent @w{ and mod satisfies } @@ -303,6 +310,7 @@ @w{ Figure 4--4: Standardized Compound-Only Type Specifier Names} @end group +@end format New @i{type specifiers} can come into existence in two ways. @table @asis @@ -327,6 +335,7 @@ Figure 4--5 shows some @i{defined names} relating to @i{types} and @i{declarations}. +@format @group @noindent @w{ coerce defstruct subtypep } @@ -339,12 +348,14 @@ @w{ Figure 4--5: Defined names relating to types and declarations.} @end group +@end format Figure 4--6 shows all @i{defined names} that are @i{type specifier} @i{names}, whether for @i{atomic type specifiers} or @i{compound type specifiers}; this list is the union of the lists in @i{Figure~4--2} and @i{Figure~4--3}. +@format @group @noindent @w{ and function simple-array } @@ -387,6 +398,7 @@ @w{ Figure 4--6: Standardized Type Specifier Names } @end group +@end format @c end of including concept-types @@ -400,6 +412,7 @@ @b{symbol}), Figure 4--7 contains a list of @i{classes} that are especially relevant to understanding the object system. +@format @group @noindent @w{ built-in-class method-combination standard-object } @@ -411,6 +424,7 @@ @w{ Figure 4--7: Object System Classes } @end group +@end format @menu * Introduction to Classes:: @@ -744,7 +758,7 @@ Let S_C be the set of C and its @i{superclasses}. Let R be -@center R=\bigcup_@{c\in {S_C}@}R_c +@center R=\bigcup_@{c\in S_C @}R_c . [Reviewer Note by Barmar: ``Consistent'' needs to be defined, or maybe we should say @@ -838,25 +852,25 @@ (defclass food () ()) @end example -The set S_@{pie@}~= @{{pie, apple, cinnamon, fruit, spice, food, -standard-object, t}@}. The set R~= @{{(pie, apple), +The set S_@{pie@}~= @{pie, apple, cinnamon, fruit, spice, food, +standard-object, t @}. The set R~= @{ (pie, apple), (apple, cinnamon), (apple, fruit), (cinnamon, spice), \break (fruit, food), (spice, food), (food, standard-object), (standard-object, -t)}@}. +t) @}. The class @t{pie} is not preceded by anything, so it comes first; the result so far is @t{(pie)}. Remove @t{pie} from S and pairs -mentioning @t{pie} from R to get S~= @{{apple, cinnamon, -fruit, spice, food, standard-object, t}@} and R~=~@{{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, +mentioning @t{pie} from R to get S~= @{apple, cinnamon, +fruit, spice, food, standard-object, t @} and R~=~@{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, food), (spice, food), (food, standard-object), -(standard-object, t)}@}. +(standard-object, t) @}. The class @t{apple} is not preceded by anything, so it is next; the result is @t{(pie apple)}. Removing @t{apple} and the relevant -pairs results in S~= @{{cinnamon, fruit, spice, food, -standard-object, t}@} and R~= @{{(cinnamon, spice), +pairs results in S~= @{ cinnamon, fruit, spice, food, +standard-object, t @} and R~= @{ (cinnamon, spice), (fruit, food), (spice, food), (food, standard-object),\break -(standard-object, t)}@}. +(standard-object, t) @}. The classes @t{cinnamon} and @t{fruit} are not preceded by anything, so the one with a direct @i{subclass} rightmost in the @@ -865,14 +879,14 @@ @i{subclass} of @t{cinnamon}. Because @t{apple} appears to the right of @t{pie} in the @i{class precedence list}, @t{fruit} goes next, and the -result so far is @t{(pie apple fruit)}. S~= @{{cinnamon, -spice, food, standard-object, t}@}; R~= @{{(cinnamon, +result so far is @t{(pie apple fruit)}. S~= @{ cinnamon, +spice, food, standard-object, t @}; R~= @{(cinnamon, spice), (spice, food),\break (food, standard-object), -(standard-object, t)}@}. +(standard-object, t) @}. -The class @t{cinnamon} is next, giving the result so far as @t{(pie apple fruit cinnamon)}. At this point S~= @{{spice, -food, standard-object, t}@}; R~= @{{(spice, food), (food, -standard-object), (standard-object, t)}@}. +The class @t{cinnamon} is next, giving the result so far as @t{(pie apple fruit cinnamon)}. At this point S~= @{ spice, +food, standard-object, t @}; R~= @{ (spice, food), (food, +standard-object), (standard-object, t) @}. The classes @t{spice}, @t{food}, @b{standard-object}, and @b{t} are added in that order, and the @i{class precedence list} @@ -1161,6 +1175,7 @@ @i{Figure~4--8} lists the set of @i{classes} that correspond to predefined @i{type specifiers}. +@format @group @noindent @w{ arithmetic-error generic-function simple-error } @@ -1193,6 +1208,7 @@ @w{ Figure 4--8: Classes that correspond to pre-defined type specifiers } @end group +@end format The @i{class precedence list} information specified in the entries for each of these @i{classes} are those that are required by the object system. @@ -1232,7 +1248,7 @@ * method-combination:: * t (System Class):: * satisfies:: -* member:: +* member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: @@ -1330,10 +1346,10 @@ (@code{function}@{@i{@t{[}arg-typespec @r{[}value-typespec@r{]}@t{]}}@}) -@w{@i{arg-typespec} ::=@r{(}@{@i{typespec}@}{*} } -@w{ @t{[}{&optional} @{@i{typespec}@}{*}@t{]} } -@w{ @t{[}{&rest} @i{typespec}@t{]} } -@w{ @t{[}{&key} @{{(}keyword typespec@r{)}@}{*}@t{]}@r{)}} +@w{@i{arg-typespec} ::=@r{(}@{@i{typespec}@}* } +@w{ @t{[}@r{&optional} @{@i{typespec}@}*@t{]} } +@w{ @t{[}@r{&rest} @i{typespec}@t{]} } +@w{ @t{[}@r{&key} @{@r{(}keyword typespec @r{)}@}*@t{]}@r{)}} @subsubheading Compound Type Specifier Arguments:: @@ -1728,7 +1744,7 @@ The @i{type} @b{t} is a @i{supertype} of every @i{type}, including itself. Every @i{object} is of @i{type} @b{t}. -@node satisfies, member, t (System Class), Types and Classes Dictionary +@node satisfies, member (Type Specifier), t (System Class), Types and Classes Dictionary @subsection satisfies [Type Specifier] @subsubheading Compound Type Specifier Kind:: @@ -1762,7 +1778,7 @@ The symbol @b{satisfies} is not valid as a @i{type specifier}. -@node member, not (Type Specifier), satisfies, Types and Classes Dictionary +@node member (Type Specifier), not (Type Specifier), satisfies, Types and Classes Dictionary @subsection member [Type Specifier] @subsubheading Compound Type Specifier Kind:: @@ -1771,7 +1787,7 @@ @subsubheading Compound Type Specifier Syntax:: -(@code{member}@{@i{@{@i{object}@}{*}}@}) +(@code{member}@{@i{@{@i{object}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @@ -1794,7 +1810,7 @@ the @i{type} @b{eql} -@node not (Type Specifier), and (Type Specifier), member, Types and Classes Dictionary +@node not (Type Specifier), and (Type Specifier), member (Type Specifier), Types and Classes Dictionary @subsection not [Type Specifier] @subsubheading Compound Type Specifier Kind:: @@ -1826,7 +1842,7 @@ @subsubheading Compound Type Specifier Syntax:: -(@code{and}@{@i{@{@i{typespec}@}{*}}@}) +(@code{and}@{@i{@{@i{typespec}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @@ -1852,7 +1868,7 @@ @subsubheading Compound Type Specifier Syntax:: -(@code{or}@{@i{@{@i{typespec}@}{*}}@}) +(@code{or}@{@i{@{@i{typespec}@}*}@}) @subsubheading Compound Type Specifier Arguments:: @@ -1885,7 +1901,7 @@ [Reviewer Note by Barmar: Missing @b{&key}] -@w{@i{value-typespec} ::=@{@i{typespec}@}{*} @t{[}{&optional} {@{@i{typespec}@}{*}}@t{]} @t{[}{&rest} typespec@t{]} @t{[}@b{&allow-other-keys}@t{]}} +@w{@i{value-typespec} ::=@{@i{typespec}@}* @t{[}@r{&optional} @r{@{@i{typespec}@}*}@t{]} @t{[}@r{&rest} typespec @t{]} @t{[}@b{&allow-other-keys}@t{]}} @subsubheading Compound Type Specifier Arguments:: @@ -2075,9 +2091,9 @@ @subsubheading See Also:: -@ref{rational} +@ref{rational (Function)} , -@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} +@ref{floor} , @ref{char-code} , @@ -2096,7 +2112,7 @@ @node deftype, subtypep, coerce, Types and Classes Dictionary @subsection deftype [Macro] -@code{deftype} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} @result{} @i{name} +@code{deftype} @i{name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*} @result{} @i{name} @subsubheading Arguments and Values:: @@ -2185,7 +2201,7 @@ @b{declare}, @ref{defmacro} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Type Specifiers}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @@ -2193,7 +2209,7 @@ @node subtypep, type-of, deftype, Types and Classes Dictionary @subsection subtypep [Function] -@code{subtypep} @i{type-1 type-2 {&optional} environment} @result{} @i{subtype-p, valid-p} +@code{subtypep} @i{type-1 type-2 @r{&optional} environment} @result{} @i{subtype-p, valid-p} @subsubheading Arguments and Values:: @@ -2228,6 +2244,7 @@ Figure 4--9 summarizes the possible combinations of @i{values} that might result. +@format @group @noindent @w{ Value 1 Value 2 Meaning } @@ -2240,6 +2257,7 @@ @w{ Figure 4--9: Result possibilities for subtypep } @end group +@end format @b{subtypep} is permitted to return the @i{values} @i{false} and @i{false} only when at least @@ -2541,7 +2559,7 @@ , @ref{defstruct} , -@ref{typecase; ctypecase; etypecase} +@ref{typecase} , @ref{typep} , @@ -2556,7 +2574,7 @@ @node typep, type-error, type-of, Types and Classes Dictionary @subsection typep [Function] -@code{typep} @i{object type-specifier {&optional} environment} @result{} @i{generalized-boolean} +@code{typep} @i{object type-specifier @r{&optional} environment} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -2625,26 +2643,26 @@ (typep #c(0 0) '(complex (eql 0))) @result{} @i{false} @end example -Let @t{A{{}_x}} and @t{A{{}_y}} be two @i{type specifiers} that +Let @t{A_x} and @t{A_y} be two @i{type specifiers} that denote different @i{types}, but for which @example - (upgraded-array-element-type 'A{{}_x}) + (upgraded-array-element-type 'A_x) @end example and @example - (upgraded-array-element-type 'A{{}_y}) + (upgraded-array-element-type 'A_y) @end example denote the same @i{type}. Notice that @example - (typep (make-array 0 :element-type 'A{{}_x}) '(array A{{}_x})) @result{} @i{true} - (typep (make-array 0 :element-type 'A{{}_y}) '(array A{{}_y})) @result{} @i{true} - (typep (make-array 0 :element-type 'A{{}_x}) '(array A{{}_y})) @result{} @i{true} - (typep (make-array 0 :element-type 'A{{}_y}) '(array A{{}_x})) @result{} @i{true} + (typep (make-array 0 :element-type 'A_x) '(array A_x)) @result{} @i{true} + (typep (make-array 0 :element-type 'A_y) '(array A_y)) @result{} @i{true} + (typep (make-array 0 :element-type 'A_x) '(array A_y)) @result{} @i{true} + (typep (make-array 0 :element-type 'A_y) '(array A_x)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: @@ -2697,7 +2715,7 @@ @subsubheading See Also:: -@ref{type-error-datum; type-error-expected-type} +@ref{type-error-datum} , @b{type-error-expected-type} @node type-error-datum, simple-type-error, type-error, Types and Classes Dictionary @@ -2773,11 +2791,11 @@ @b{simple-condition}, -@ref{simple-condition-format-control; simple-condition-format-arguments} +@ref{simple-condition-format-control} , @b{simple-condition-format-arguments}, -@ref{type-error-datum; type-error-expected-type} +@ref{type-error-datum} , @b{type-error-expected-type} diff -uNr gcl-texi-orig/chap-5.texi gcl-texi/chap-5.texi --- gcl-texi-orig/chap-5.texi 1994-07-16 18:03:19 +0400 +++ gcl-texi/chap-5.texi 2002-10-17 21:17:54 +0400 @@ -50,6 +50,7 @@ that the ultimate result of evaluating @b{setf} is the value or values being stored. +@format @group @noindent @w{ Access function Update Function Update using @b{setf} } @@ -61,10 +62,12 @@ @w{ Figure 5--1: Examples of setf } @end group +@end format Figure 5--2 shows @i{operators} relating to @i{places} and @i{generalized reference}. +@format @group @noindent @w{ assert defsetf push } @@ -78,6 +81,7 @@ @w{ Figure 5--2: Operators relating to places and generalized reference.} @end group +@end format Some of the @i{operators} above manipulate @i{places} and some manipulate @i{setf expanders}. @@ -281,6 +285,7 @@ For a variable @i{x}: +@format @group @noindent @w{ @t{()} ;list of temporary variables } @@ -293,9 +298,11 @@ @w{ Figure 5--3: Sample Setf Expansion of a Variable} @end group +@end format For @t{(car @i{exp})}: +@format @group @noindent @w{ @t{(g0002)} ;list of temporary variables } @@ -308,9 +315,11 @@ @w{ Figure 5--4: Sample Setf Expansion of a CAR Form } @end group +@end format For @t{(subseq @i{seq} @i{s} @i{e})}: +@format @group @noindent @w{ @t{(g0004 g0005 g0006)} ;list of temporary variables } @@ -324,12 +333,14 @@ @w{ Figure 5--5: Sample Setf Expansion of a SUBSEQ Form } @end group +@end format In some cases, if a @i{subform} of a @i{place} is itself a @i{place}, it is necessary to expand the @i{subform} in order to compute some of the values in the expansion of the outer @i{place}. For @t{(ldb @i{bs} (car @i{exp}))}: +@format @group @noindent @w{ @t{(g0001 g0002)} ;list of temporary variables } @@ -343,6 +354,7 @@ @w{ Figure 5--6: Sample Setf Expansion of a LDB Form } @end group +@end format @node Kinds of Places, Treatment of Other Macros Based on SETF, Overview of Places and Generalized Reference, Generalized Reference @subsection Kinds of Places @@ -387,6 +399,7 @@ search for these items and eliminate stray references to them as `accessors', which they are not, but I will do that at some point.] +@format @group @noindent @w{ aref cdadr get } @@ -416,6 +429,7 @@ @w{ Figure 5--7: Functions that setf can be used with---1 } @end group +@end format In the case of @b{subseq}, the replacement value must be a @i{sequence} whose elements might be contained by the sequence argument to @b{subseq}, @@ -440,6 +454,7 @@ in this case the new @i{place} has stored back into it the result of applying the supplied ``update'' function. +@format @group @noindent @w{ Function name Argument that is a @i{place} Update function used } @@ -451,6 +466,7 @@ @w{ Figure 5--8: Functions that setf can be used with---2 } @end group +@end format During the @b{setf} expansion of these @i{forms}, it is necessary to call @@ -652,17 +668,17 @@ @item @t{*} @t{(setf (apply #'aref @i{array} - @{@i{subscript}@}{*} + @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @item @t{*} @t{(setf (apply #'bit @i{array} - @{@i{subscript}@}{*} + @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @item @t{*} @t{(setf (apply #'sbit @i{array} - @{@i{subscript}@}{*} + @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @end table @@ -687,8 +703,8 @@ to preserve proper left-to-right evaluation of argument @i{subforms}: @example - (setf (apply #'@i{name} @{@i{arg}@}{*}) @i{val}) - @equiv{} (apply #'(setf @i{name}) @i{val} @{@i{arg}@}{*}) + (setf (apply #'@i{name} @{@i{arg}@}*) @i{val}) + @equiv{} (apply #'(setf @i{name}) @i{val} @{@i{arg}@}*) @end example @node Setf Expansions and Places, Macro Forms as Places, APPLY Forms as Places, Kinds of Places @@ -772,7 +788,7 @@ @i{form} with the following general syntax: @example - (@i{operator} @{@i{preceding-form}@}{*} @i{place} @{@i{following-form}@}{*}) + (@i{operator} @{@i{preceding-form}@}* @i{place} @{@i{following-form}@}*) @end example The evaluation of each such @i{form} proceeds like this: @@ -795,6 +811,7 @@ Store the new value into @i{place}. @end table +@format @group @noindent @w{ decf pop pushnew } @@ -804,6 +821,7 @@ @w{ Figure 5--9: Read-Modify-Write Macros} @end group +@end format @c end of including concept-places @@ -944,7 +962,7 @@ @node apply, defun, Data and Control Flow Dictionary, Data and Control Flow Dictionary @subsection apply [Function] -@code{apply} @i{function {&rest} args^+} @result{} @i{@{@i{result}@}{*}} +@code{apply} @i{function @r{&rest} args^+} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -1011,7 +1029,7 @@ @node defun, fdefinition, apply, Data and Control Flow Dictionary @subsection defun [Macro] -@code{defun} @i{function-name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* +@code{defun} @i{function-name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{function-name} @subsubheading Arguments and Values:: @@ -1056,8 +1074,8 @@ @example (lambda @i{lambda-list} - {[[@{@i{declaration}@}{*} | @i{documentation}]]} - (block @i{block-name} @{@i{form}@}{*})) + @r{[[@{@i{declaration}@}* | @i{documentation}]]} + (block @i{block-name} @{@i{form}@}*)) @end example processed in the @i{lexical environment} in which @b{defun} was executed. @@ -1106,7 +1124,7 @@ @subsubheading See Also:: -@ref{flet; labels; macrolet} +@ref{flet} , @b{labels}, @ref{block} @@ -1114,7 +1132,7 @@ @ref{return-from} , @b{declare}, -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Evaluation}, @ref{Ordinary Lambda Lists}, @@ -1313,29 +1331,29 @@ @node flet, funcall, fmakunbound, Data and Control Flow Dictionary @subsection flet, labels, macrolet [Special Operator] -@code{flet} @i{@r{(}@{{(}@i{function-name} +@code{flet} @i{@r{(}@{@r{(}@i{function-name} @i{lambda-list} - {[[@{@i{local-declaration}@}{*} + @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} - @{@i{local-form}@}{*}@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{local-form}@}*@r{)}@}*@r{)} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} -@code{labels} @i{@r{(}@{{(}@i{function-name} +@code{labels} @i{@r{(}@{@r{(}@i{function-name} @i{lambda-list} - {[[@{@i{local-declaration}@}{*} + @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} - @{@i{local-form}@}{*}@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{local-form}@}*@r{)}@}*@r{)} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} -@code{macrolet} @i{@r{(}@{{(}@i{name} +@code{macrolet} @i{@r{(}@{@r{(}@i{name} @i{lambda-list} - {[[@{@i{local-declaration}@}{*} + @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} - @{@i{local-form}@}{*}@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{local-form}@}*@r{)}@}*@r{)} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -1556,9 +1574,9 @@ , @ref{defun} , -@ref{documentation; (setf documentation)} +@ref{documentation} , -@ref{let; let*} +@ref{let} , @ref{Evaluation}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @@ -1575,7 +1593,7 @@ @node funcall, function (Special Operator), flet, Data and Control Flow Dictionary @subsection funcall [Function] -@code{funcall} @i{function {&rest} args} @result{} @i{@{@i{result}@}{*}} +@code{funcall} @i{function @r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -1693,7 +1711,7 @@ , @ref{fdefinition} , -@ref{flet; labels; macrolet} +@ref{flet} , @b{labels}, @ref{symbol-function} @@ -1936,7 +1954,7 @@ @ref{defun} , -@ref{flet; labels; macrolet} +@ref{flet} , @ref{defmacro} , @@ -2049,10 +2067,10 @@ @ref{declaim} , -@ref{defparameter; defvar} +@ref{defparameter} , @b{defvar}, -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{proclaim} , @@ -2196,7 +2214,7 @@ , @ref{defconstant} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Compilation} @@ -2242,8 +2260,8 @@ @node destructuring-bind, let, defparameter, Data and Control Flow Dictionary @subsection destructuring-bind [Macro] -@code{destructuring-bind} @i{lambda-list expression @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{destructuring-bind} @i{lambda-list expression @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2287,9 +2305,9 @@ @node let, progv, destructuring-bind, Data and Control Flow Dictionary @subsection let, let* [Special Operator] -@code{let} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{let} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} -@code{let*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{let*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2417,7 +2435,7 @@ @node progv, setq, let, Data and Control Flow Dictionary @subsection progv [Special Operator] -@code{progv} @i{@i{symbols} @i{values} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{progv} @i{@i{symbols} @i{values} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2462,7 +2480,7 @@ @subsubheading See Also:: -@ref{let; let*} +@ref{let} , @ref{Evaluation} @subsubheading Notes:: @@ -2474,7 +2492,7 @@ @node setq, psetq, progv, Data and Control Flow Dictionary @subsection setq [Special Form] -@code{setq} @i{@{!@i{pair}@}{*}} @result{} @i{result} +@code{setq} @i{@{!@i{pair}@}*} @result{} @i{result} @w{@i{pair} ::=var form} @@ -2541,18 +2559,19 @@ , @ref{set} , -@ref{setf; psetf} +@ref{setf} @node psetq, block, setq, Data and Control Flow Dictionary @subsection psetq [Macro] -@code{psetq} @i{@{!@i{pair}@}{*}} @result{} @i{@b{nil}} +@code{psetq} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} @w{@i{pair} ::=var form} @subsubheading Pronunciation:: -@b{psetq}: pronounced {{{\vrule width 1pt height 2pt depth 2pt}\kern -1pt\raise 6pt{\vrule width 1pt height 2pt depth 2pt}}}p\=e'set ,ky\"u +@b{psetq}: pronounced @tex p\=e'set ,ky\"u +@end tex @subsubheading Arguments and Values:: @@ -2621,7 +2640,7 @@ @node block, catch, psetq, Data and Control Flow Dictionary @subsection block [Special Operator] -@code{block} @i{@i{name} @i{form}@r{*}} @result{} @i{@{@i{result}@}{*}} +@code{block} @i{@i{name} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2681,7 +2700,7 @@ @node catch, go, block, Data and Control Flow Dictionary @subsection catch [Special Operator] -@code{catch} @i{@i{tag} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{catch} @i{@i{tag} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2980,7 +2999,7 @@ @node tagbody, throw, return, Data and Control Flow Dictionary @subsection tagbody [Special Operator] -@code{tagbody} @i{@{@i{tag} | @i{statement}@}{*}} @result{} @i{@b{nil}} +@code{tagbody} @i{@{@i{tag} | @i{statement}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -3060,6 +3079,7 @@ The @i{macros} in Figure 5--10 have @i{implicit tagbodies}. +@format @group @noindent @w{ do do-external-symbols dotimes } @@ -3070,6 +3090,7 @@ @w{ Figure 5--10: Macros that have implicit tagbodies.} @end group +@end format @node throw, unwind-protect, tagbody, Data and Control Flow Dictionary @subsection throw [Special Operator] @@ -3175,7 +3196,7 @@ @node unwind-protect, nil, throw, Data and Control Flow Dictionary @subsection unwind-protect [Special Operator] -@code{unwind-protect} @i{@i{protected-form} @{@i{cleanup-form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{unwind-protect} @i{@i{protected-form} @{@i{cleanup-form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3519,7 +3540,7 @@ , @ref{equalp} , -@ref{=; /=; <; >; <=; >=} +@ref{=} , @ref{Compilation} @@ -3544,6 +3565,7 @@ rather than @b{eql} in a way that cannot be overridden by the @i{code} which employs them: +@format @group @noindent @w{ catch getf throw } @@ -3554,6 +3576,7 @@ @w{ Figure 5--11: Operators that always prefer EQ over EQL} @end group +@end format @node eql, equal, eq, Data and Control Flow Dictionary @subsection eql [Function] @@ -3631,9 +3654,9 @@ , @ref{equalp} , -@ref{=; /=; <; >; <=; >=} +@ref{=} , -@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} +@ref{char=} @subsubheading Notes:: @@ -3731,6 +3754,7 @@ with upper entries taking priority over lower ones. +@format @group @noindent @w{ Type Behavior } @@ -3749,6 +3773,7 @@ @w{ Figure 5--12: Summary and priorities of behavior of @b{equal}} @end group +@end format Any two @i{objects} that are @b{eql} are also @b{equal}. @@ -3783,11 +3808,11 @@ , @ref{equalp} , -@ref{=; /=; <; >; <=; >=} +@ref{=} , -@ref{string=; string/=; string<; string>; string<=; string>=; string-equal; string-not-equal; string-lessp; string-greaterp; string-not-greaterp; string-not-lessp} +@ref{string=} , @b{string-equal}, -@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} +@ref{char=} , @b{char-equal}, @ref{tree-equal} @@ -3869,6 +3894,7 @@ with upper entries taking priority over lower ones. +@format @group @noindent @w{ Type Behavior } @@ -3887,6 +3913,7 @@ @w{ Figure 5--13: Summary and priorities of behavior of @b{equalp}} @end group +@end format @subsubheading Examples:: @@ -3928,11 +3955,11 @@ , @ref{equal} , -@ref{=; /=; <; >; <=; >=} +@ref{=} , -@ref{string=; string/=; string<; string>; string<=; string>=; string-equal; string-not-equal; string-lessp; string-greaterp; string-not-greaterp; string-not-lessp} +@ref{string=} , @b{string-equal}, -@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} +@ref{char=} , @b{char-equal} @@ -4089,13 +4116,13 @@ @node every, and, constantly, Data and Control Flow Dictionary @subsection every, some, notevery, notany [Function] -@code{every} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} +@code{every} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} -@code{some} @i{predicate {&rest} sequences^+} @result{} @i{result} +@code{some} @i{predicate @r{&rest} sequences^+} @result{} @i{result} -@code{notevery} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} +@code{notevery} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} -@code{notany} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} +@code{notany} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @@ -4178,14 +4205,14 @@ @subsubheading Notes:: @example - (notany @i{predicate} @{@i{sequence}@}{*}) @equiv{} (not (some @i{predicate} @{@i{sequence}@}{*})) - (notevery @i{predicate} @{@i{sequence}@}{*}) @equiv{} (not (every @i{predicate} @{@i{sequence}@}{*})) + (notany @i{predicate} @{@i{sequence}@}*) @equiv{} (not (some @i{predicate} @{@i{sequence}@}*)) + (notevery @i{predicate} @{@i{sequence}@}*) @equiv{} (not (every @i{predicate} @{@i{sequence}@}*)) @end example @node and, cond, every, Data and Control Flow Dictionary @subsection and [Macro] -@code{and} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{and} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -4236,13 +4263,13 @@ @ref{cond} , -@ref{every; some; notevery; notany} +@ref{every} , @ref{if} , @ref{or} , -@ref{when; unless} +@ref{when} @subsubheading Notes:: @@ -4254,9 +4281,9 @@ @node cond, if, and, Data and Control Flow Dictionary @subsection cond [Macro] -@code{cond} @i{@{!@i{clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{cond} @i{@{!@i{clause}@}*} @result{} @i{@{@i{result}@}*} -@w{@i{clause} ::=@r{(}test-form @{@i{form}@}{*}@r{)}} +@w{@i{clause} ::=@r{(}test-form @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @@ -4312,13 +4339,13 @@ @ref{if} , -@ref{case; ccase; ecase} +@ref{case} . @node if, or, cond, Data and Control Flow Dictionary @subsection if [Special Operator] -@code{if} @i{@i{test-form} @i{then-form} @r{[}@i{else-form}@r{]}} @result{} @i{@{@i{result}@}{*}} +@code{if} @i{@i{test-form} @i{then-form} @r{[}@i{else-form}@r{]}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -4365,7 +4392,7 @@ @ref{cond} , @b{unless}, -@ref{when; unless} +@ref{when} @subsubheading Notes:: @@ -4377,7 +4404,7 @@ @node or, when, if, Data and Control Flow Dictionary @subsection or [Macro] -@code{or} @i{@{@i{form}@}{*}} @result{} @i{@{@i{results}@}{*}} +@code{or} @i{@{@i{form}@}*} @result{} @i{@{@i{results}@}*} @subsubheading Arguments and Values:: @@ -4428,9 +4455,9 @@ @node when, case, or, Data and Control Flow Dictionary @subsection when, unless [Macro] -@code{when} @i{test-form @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{when} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} -@code{unless} @i{test-form @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{unless} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -4520,15 +4547,15 @@ @node case, typecase, when, Data and Control Flow Dictionary @subsection case, ccase, ecase [Macro] -@code{case} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} +@code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} -@code{ccase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@code{ecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}{*}@r{)}} +@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} -@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} +@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} @@ -4668,9 +4695,9 @@ @ref{cond} , -@ref{typecase; ctypecase; etypecase} +@ref{typecase} , -@ref{setf; psetf} +@ref{setf} , @ref{Generalized Reference} @@ -4678,10 +4705,10 @@ @example (case @i{test-key} - @{((@{@i{key}@}{*}) @{@i{form}@}{*})@}{*}) + @{((@{@i{key}@}*) @{@i{form}@}*)@}*) @equiv{} (let ((#1=#:g0001 @i{test-key})) - (cond @{((member #1# '(@{@i{key}@}{*})) @{@i{form}@}{*})@}{*})) + (cond @{((member #1# '(@{@i{key}@}*)) @{@i{form}@}*)@}*)) @end example The specific error message used by @b{ecase} and @b{ccase} can vary @@ -4693,15 +4720,15 @@ @node typecase, multiple-value-bind, case, Data and Control Flow Dictionary @subsection typecase, ctypecase, etypecase [Macro] -@code{typecase} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} +@code{typecase} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} -@code{ctypecase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ctypecase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@code{etypecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{etypecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} -@w{@i{normal-clause} ::=@r{(}type @{@i{form}@}{*}@r{)}} +@w{@i{normal-clause} ::=@r{(}type @{@i{form}@}*@r{)}} -@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} +@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} @@ -4846,11 +4873,11 @@ @subsubheading See Also:: -@ref{case; ccase; ecase} +@ref{case} , @ref{cond} , -@ref{setf; psetf} +@ref{setf} , @ref{Generalized Reference} @@ -4858,10 +4885,10 @@ @example (typecase @i{test-key} - @{(@i{type} @{@i{form}@}{*})@}{*}) + @{(@i{type} @{@i{form}@}*)@}*) @equiv{} (let ((#1=#:g0001 @i{test-key})) - (cond @{((typep #1# '@i{type}) @{@i{form}@}{*})@}{*})) + (cond @{((typep #1# '@i{type}) @{@i{form}@}*)@}*)) @end example The specific error message used by @b{etypecase} and @b{ctypecase} can vary @@ -4873,11 +4900,11 @@ @node multiple-value-bind, multiple-value-call, typecase, Data and Control Flow Dictionary @subsection multiple-value-bind [Macro] -@code{multiple-value-bind} @i{@r{(}@{@i{var}@}{*}@r{)} +@code{multiple-value-bind} @i{@r{(}@{@i{var}@}*@r{)} @i{values-form} - @{@i{declaration}@}{*} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -4924,24 +4951,24 @@ @subsubheading See Also:: -@ref{let; let*} +@ref{let} , @ref{multiple-value-call} @subsubheading Notes:: @example - (multiple-value-bind (@{@i{var}@}{*}) @i{values-form} @{@i{form}@}{*}) - @equiv{} (multiple-value-call #'(lambda (&optional @{@i{var}@}{*} &rest #1=#:ignore) + (multiple-value-bind (@{@i{var}@}*) @i{values-form} @{@i{form}@}*) + @equiv{} (multiple-value-call #'(lambda (&optional @{@i{var}@}* &rest #1=#:ignore) (declare (ignore #1#)) - @{@i{form}@}{*}) + @{@i{form}@}*) @i{values-form}) @end example @node multiple-value-call, multiple-value-list, multiple-value-bind, Data and Control Flow Dictionary @subsection multiple-value-call [Special Operator] -@code{multiple-value-call} @i{@i{function-form} @i{form}@r{*}} @result{} @i{@{@i{result}@}{*}} +@code{multiple-value-call} @i{@i{function-form} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -5021,9 +5048,9 @@ @node multiple-value-prog1, multiple-value-setq, multiple-value-list, Data and Control Flow Dictionary @subsection multiple-value-prog1 [Special Operator] -@code{multiple-value-prog} @i{1} @result{} @i{first-form @{@i{form}@}{*}} +@code{multiple-value-prog} @i{1} @result{} @i{first-form @{@i{form}@}*} - {first-form-results} + @r{first-form-results} @subsubheading Arguments and Values:: @@ -5052,7 +5079,7 @@ @subsubheading See Also:: -@ref{prog1; prog2} +@ref{prog1} @node multiple-value-setq, values, multiple-value-prog1, Data and Control Flow Dictionary @subsection multiple-value-setq [Macro] @@ -5126,9 +5153,9 @@ @node values, values-list, multiple-value-setq, Data and Control Flow Dictionary @subsection values [Accessor] -@code{values} @i{{&rest} object} @result{} @i{@{@i{object}@}{*}} +@code{values} @i{@r{&rest} object} @result{} @i{@{@i{object}@}*} -(setf (@code{ values} @i{{&rest} place}) new-values)@* +(setf (@code{ values} @i{@r{&rest} place}) new-values)@* @subsubheading Arguments and Values:: @@ -5206,7 +5233,7 @@ @node values-list, multiple-values-limit, values, Data and Control Flow Dictionary @subsection values-list [Function] -@code{values-list} @i{list} @result{} @i{@{@i{element}@}{*}} +@code{values-list} @i{list} @result{} @i{@{@i{element}@}*} @subsubheading Arguments and Values:: @@ -5331,16 +5358,16 @@ @subsection prog, prog* [Macro] @code{prog} @i{@r{(}@{@i{var} | - @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} - @{@i{tag} | @i{statement}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} + @{@i{declaration}@}* + @{@i{tag} | @i{statement}@}*}@* + @result{} @i{@{@i{result}@}*} @code{prog*} @i{@r{(}@{@i{var} | - @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} - @{@i{declaration}@}{*} - @{@i{tag} | @i{statement}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} + @{@i{declaration}@}* + @{@i{tag} | @i{statement}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -5369,7 +5396,7 @@ @example (prog (var1 var2 (var3 init-form-3) var4 (var5 init-form-5)) - @{@i{declaration}@}{*} + @{@i{declaration}@}* statement1 tag1 statement2 @@ -5457,7 +5484,7 @@ @ref{block} , -@ref{let; let*} +@ref{let} , @ref{tagbody} , @@ -5479,10 +5506,10 @@ @node prog1, progn, prog, Data and Control Flow Dictionary @subsection prog1, prog2 [Macro] -@code{prog} @i{1} @result{} @i{first-form @{@i{form}@}{*}} - {result-1} -@code{prog} @i{2} @result{} @i{first-form second-form @{@i{form}@}{*}} - {result-2} +@code{prog} @i{1} @result{} @i{first-form @{@i{form}@}*} + @r{result-1} +@code{prog} @i{2} @result{} @i{first-form second-form @{@i{form}@}*} + @r{result-2} @subsubheading Arguments and Values:: @@ -5553,14 +5580,14 @@ must be computed before some or all of the side effects happen. @example - (prog1 @{@i{form}@}{*}) @equiv{} (values (multiple-value-prog1 @{@i{form}@}{*})) - (prog2 @i{form1} @{@i{form}@}{*}) @equiv{} (let () @i{form1} (prog1 @{@i{form}@}{*})) + (prog1 @{@i{form}@}*) @equiv{} (values (multiple-value-prog1 @{@i{form}@}*)) + (prog2 @i{form1} @{@i{form}@}*) @equiv{} (let () @i{form1} (prog1 @{@i{form}@}*)) @end example @node progn, define-modify-macro, prog1, Data and Control Flow Dictionary @subsection progn [Special Operator] -@code{progn} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{progn} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -5593,7 +5620,7 @@ @subsubheading See Also:: -@ref{prog1; prog2} +@ref{prog1} , @b{prog2}, @ref{Evaluation} @subsubheading Notes:: @@ -5690,7 +5717,7 @@ @ref{define-setf-expander} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Syntactic Interaction of Documentation Strings and Declarations} @@ -5704,8 +5731,8 @@ The ``long form'': -@code{defsetf} @i{access-fn lambda-list @r{(}@{@i{store-variable}@}{*}@r{)} - {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* +@code{defsetf} @i{access-fn lambda-list @r{(}@{@i{store-variable}@}*@r{)} + @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{access-fn} @subsubheading Arguments and Values:: @@ -5870,9 +5897,9 @@ @subsubheading See Also:: -@ref{documentation; (setf documentation)} +@ref{documentation} , -@ref{setf; psetf} +@ref{setf} , @ref{define-setf-expander} @@ -5913,7 +5940,7 @@ @subsection define-setf-expander [Macro] @code{define-setf-expander} @i{access-fn lambda-list - {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* + @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{access-fn} @subsubheading Arguments and Values:: @@ -6025,11 +6052,11 @@ @subsubheading See Also:: -@ref{setf; psetf} +@ref{setf} , @ref{defsetf} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{get-setf-expansion} , @@ -6049,7 +6076,7 @@ @node get-setf-expansion, setf, define-setf-expander, Data and Control Flow Dictionary @subsection get-setf-expansion [Function] -@code{get-setf-expansion} @i{place {&optional} environment}@* +@code{get-setf-expansion} @i{place @r{&optional} environment}@* @result{} @i{vars, vals, store-vars, writer-form, reader-form} @subsubheading Arguments and Values:: @@ -6102,7 +6129,7 @@ , @ref{define-setf-expander} , -@ref{setf; psetf} +@ref{setf} @subsubheading Notes:: @@ -6113,9 +6140,9 @@ @node setf, shiftf, get-setf-expansion, Data and Control Flow Dictionary @subsection setf, psetf [Macro] -@code{setf} @i{@{!@i{pair}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{setf} @i{@{!@i{pair}@}*} @result{} @i{@{@i{result}@}*} -@code{psetf} @i{@{!@i{pair}@}{*}} @result{} @i{@b{nil}} +@code{psetf} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} @w{@i{pair} ::=place newvalue} @@ -6276,7 +6303,7 @@ @subsubheading See Also:: -@ref{setf; psetf} +@ref{setf} , @ref{rotatef} , @ref{Generalized Reference} @@ -6315,7 +6342,7 @@ @node rotatef, control-error, shiftf, Data and Control Flow Dictionary @subsection rotatef [Macro] -@code{rotatef} @i{@{@i{place}@}{*}} @result{} @i{@b{nil}} +@code{rotatef} @i{@{@i{place}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -6358,7 +6385,7 @@ , @ref{defsetf} , -@ref{setf; psetf} +@ref{setf} , @ref{shiftf} , diff -uNr gcl-texi-orig/chap-6.texi gcl-texi/chap-6.texi --- gcl-texi-orig/chap-6.texi 1994-07-16 18:03:17 +0400 +++ gcl-texi/chap-6.texi 2002-10-17 20:53:05 +0400 @@ -889,7 +889,7 @@ subsequent iterations. If @i{form2} is omitted, the construct uses @i{form1} on the second and subsequent iterations. -The @i{loop keywords} {=} and @t{then} serve as valid prepositions +The @i{loop keywords} @r{=} and @t{then} serve as valid prepositions in this syntax. This construct does not provide any termination tests. @@ -981,12 +981,12 @@ In effect @t{being} -@{{each} | @t{the}@} -@{{hash-value} | +@{@t{each} | @t{the}@} +@{@t{hash-value} | @t{hash-values} | @t{hash-key} | @t{hash-keys}@} -@{{in} | @t{of}@} +@{@t{in} | @t{of}@} is a compound preposition. @@ -1059,14 +1059,14 @@ In effect @t{being} -@{{each} | @t{the}@} -@{{symbol} | +@{@t{each} | @t{the}@} +@{@t{symbol} | @t{symbols} | @t{present-symbol} | @t{present-symbols} | @t{external-symbol} | @t{external-symbols}@} -@{{in} | @t{of}@} +@{@t{in} | @t{of}@} is a compound preposition. @@ -2099,15 +2099,15 @@ @node do, dotimes, Iteration Dictionary, Iteration Dictionary @subsection do, do* [Macro] -@code{do} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}{*}@r{)} - @r{(}end-test-form @{@i{result-form}@}{*}@r{)} - @{@i{declaration}@}{*} @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} - -@code{do*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}{*}@r{)} - @r{(}end-test-form {@{@i{result-form}@}{*}}@r{)} - @{@i{declaration}@}{*} @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{do} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} + @r{(}end-test-form @{@i{result-form}@}*@r{)} + @{@i{declaration}@}* @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} + +@code{do*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} + @r{(}end-test-form @r{@{@i{result-form}@}*}@r{)} + @{@i{declaration}@}* @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2337,7 +2337,7 @@ @ref{return} , -@ref{let; let*} +@ref{let} , and @ref{setq} ) @@ -2377,9 +2377,9 @@ @subsection dotimes [Macro] @code{dotimes} @i{@r{(}var count-form @r{[}result-form@r{]}@r{)} - @{@i{declaration}@}{*} - @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2481,7 +2481,7 @@ @subsubheading See Also:: -@ref{do; do*} +@ref{do} , @ref{dolist} , @@ -2496,9 +2496,9 @@ @subsection dolist [Macro] @code{dolist} @i{@r{(}var list-form @r{[}result-form@r{]}@r{)} - @{@i{declaration}@}{*} - @{tag | statement@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* + @{tag | statement@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2569,7 +2569,7 @@ @subsubheading See Also:: -@ref{do; do*} +@ref{do} , @ref{dotimes} , @@ -2588,44 +2588,44 @@ The ``simple'' @b{loop} @i{form}: -@code{loop} @i{@{@i{compound-form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{loop} @i{@{@i{compound-form}@}*} @result{} @i{@{@i{result}@}*} The ``extended'' @b{loop} @i{form}: @code{loop} @i{@r{[}!@i{name-clause}@r{]} - @{!@i{variable-clause}@}{*} - @{!@i{main-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} + @{!@i{variable-clause}@}* + @{!@i{main-clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{name-clause} ::=@t{named} @i{name}} @w{@i{variable-clause} ::=!@i{with-clause} | !@i{initial-final} | !@i{for-as-clause}} -@w{@i{with-clause} ::=@t{with} @i{var1} @r{[}@i{type-spec}@r{]} @r{[}= @i{form1}@r{]} @{{and} @i{var2} @r{[}@i{type-spec}@r{]} @r{[}= @i{form2}@r{]}@}{*}} +@w{@i{with-clause} ::=@t{with} @i{var1} @r{[}@i{type-spec}@r{]} @r{[}= @i{form1}@r{]} @{@t{and} @i{var2} @r{[}@i{type-spec}@r{]} @r{[}= @i{form2}@r{]}@}*} @w{@i{main-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional} | !@i{termination-test} | !@i{initial-final}} @w{@i{initial-final} ::=@t{initially} @{@i{compound-form}@}^+ | @t{finally} @{@i{compound-form}@}^+} -@w{@i{unconditional} ::=@{{do} | @t{doing}@} @{@i{compound-form}@}^+ | @t{return} @{@i{form} | @t{it}@}} +@w{@i{unconditional} ::=@{@t{do} | @t{doing}@} @{@i{compound-form}@}^+ | @t{return} @{@i{form} | @t{it}@}} @w{@i{accumulation} ::=!@i{list-accumulation} | !@i{numeric-accumulation}} -@w{@i{list-accumulation} ::=@{{collect} | @t{collecting} | @t{append} | @t{appending} | @t{nconc} | @t{nconcing}@} @{@i{form} | @t{it}@} } +@w{@i{list-accumulation} ::=@{@t{collect} | @t{collecting} | @t{append} | @t{appending} | @t{nconc} | @t{nconcing}@} @{@i{form} | @t{it}@} } @w{ @r{[}@t{into} @i{simple-var}@r{]}} -@w{@i{numeric-accumulation} ::=@{{count} | @t{counting} | @t{sum} | @t{summing} | @} +@w{@i{numeric-accumulation} ::=@{@t{count} | @t{counting} | @t{sum} | @t{summing} | @} @w{ @t{maximize} | @t{maximizing} | @t{minimize} | @t{minimizing}} @{@i{form} | @t{it}@} } @w{ @r{[}@t{into} @i{simple-var}@r{]} @r{[}@i{type-spec}@r{]}} -@w{@i{conditional} ::=@{{if} | @t{when} | @t{unless}@} @i{form} !@i{selectable-clause} @{{and} !@i{selectable-clause}@}{*} } -@w{ @r{[}@t{else} !@i{selectable-clause} @{{and} !@i{selectable-clause}@}{*}@r{]} } +@w{@i{conditional} ::=@{@t{if} | @t{when} | @t{unless}@} @i{form} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}* } +@w{ @r{[}@t{else} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}*@r{]} } @w{ @r{[}@t{end}@r{]}} @w{@i{selectable-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional}} @w{@i{termination-test} ::=@t{while} @i{form} | @t{until} @i{form} | @t{repeat} @i{form} | @t{always} @i{form} | @t{never} @i{form} | @t{thereis} @i{form}} -@w{@i{for-as-clause} ::=@{{for} | @t{as}@} !@i{for-as-subclause} @{{and} !@i{for-as-subclause}@}{*}} +@w{@i{for-as-clause} ::=@{@t{for} | @t{as}@} !@i{for-as-subclause} @{@t{and} !@i{for-as-subclause}@}*} @w{@i{for-as-subclause} ::=!@i{for-as-arithmetic} | !@i{for-as-in-list} | !@i{for-as-on-list} | !@i{for-as-equals-then} |} @w{ !@i{for-as-across} | !@i{for-as-hash} | !@i{for-as-package}} @@ -2634,11 +2634,11 @@ @w{@i{for-as-arithmetic-subclause} ::=!@i{arithmetic-up} | !@i{arithmetic-downto} | !@i{arithmetic-downfrom}} -@w{@i{arithmetic-up} ::=[[@{{from} | @t{upfrom}@} @i{form1} | @{{to} | @t{upto} | @t{below}@} @i{form2} | @t{by} @i{form3}]]^+} +@w{@i{arithmetic-up} ::=[[@{@t{from} | @t{upfrom}@} @i{form1} | @{@t{to} | @t{upto} | @t{below}@} @i{form2} | @t{by} @i{form3}]]^+} -@w{@i{arithmetic-downto} ::=[[@{{from} @i{form1}@}^1 | @{@{{downto} | @t{above}@} @i{form2}@}^1 | @t{by} @i{form3}]]} +@w{@i{arithmetic-downto} ::=[[@{@t{from} @i{form1}@}^1 | @{@{@t{downto} | @t{above}@} @i{form2}@}^1 | @t{by} @i{form3}]]} -@w{@i{arithmetic-downfrom} ::=[[@{{downfrom} @i{form1}@}^1 | @{{to} | @t{downto} | @t{above}@} @i{form2} | @t{by} @i{form3}]]} +@w{@i{arithmetic-downfrom} ::=[[@{@t{downfrom} @i{form1}@}^1 | @{@t{to} | @t{downto} | @t{above}@} @i{form2} | @t{by} @i{form3}]]} @w{@i{for-as-in-list} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{in} @i{form1} @r{[}@t{by} @i{step-fun}@r{]}} @@ -2648,17 +2648,17 @@ @w{@i{for-as-across} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{across} @i{vector}} -@w{@i{for-as-hash} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{{each} | @t{the}@} } -@w{ @{@{{hash-key} | @t{hash-keys}@} @{{in} | @t{of}@} @i{hash-table} } +@w{@i{for-as-hash} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } +@w{ @{@{@t{hash-key} | @t{hash-keys}@} @{@t{in} | @t{of}@} @i{hash-table} } @w{ @r{[}@t{using} @r{(}@t{hash-value} @i{other-var}@r{)}@r{]} | } -@w{ @{{hash-value} | @t{hash-values}@} @{{in} | @t{of}@} @i{hash-table} } +@w{ @{@t{hash-value} | @t{hash-values}@} @{@t{in} | @t{of}@} @i{hash-table} } @w{ @r{[}@t{using} @r{(}@t{hash-key} @i{other-var}@r{)}@r{]}@}} -@w{@i{for-as-package} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{{each} | @t{the}@} } -@w{ @{{symbol} | @t{symbols} |} +@w{@i{for-as-package} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } +@w{ @{@t{symbol} | @t{symbols} |} @w{ @t{present-symbol} | @t{present-symbols} |} @w{ @t{external-symbol} | @t{external-symbols}@} } -@w{ @r{[}@{{in} | @t{of}@} @i{package}@r{]}} +@w{ @r{[}@{@t{in} | @t{of}@} @i{package}@r{]}} @w{@i{type-spec} ::=!@i{simple-type-spec} | !@i{destructured-type-spec}} @@ -2718,11 +2718,11 @@ (format t "~&The square root of ~D is ~D.~ @result{} SQRT-ADVISOR (sqrt-advisor) -@t{ |> } Number: @b{|>>}@t{5{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{5 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square root of 5 is 2.236068. -@t{ |> } Number: @b{|>>}@t{4{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square root of 4 is 2. -@t{ |> } Number: @b{|>>}@t{done{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} @result{} NIL ;; An example of the extended form of LOOP. @@ -2733,11 +2733,11 @@ do (format t "~&The square of ~D is ~D.~ @result{} SQUARE-ADVISOR (square-advisor) -@t{ |> } Number: @b{|>>}@t{4{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square of 4 is 16. -@t{ |> } Number: @b{|>>}@t{23{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{23 @t{@i{[<--}~]}}@b{<<|} @t{ |> } The square of 23 is 529. -@t{ |> } Number: @b{|>>}@t{done{@i{[<--}~]}}@b{<<|} +@t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} @result{} NIL ;; Another example of the extended form of LOOP. @@ -2749,7 +2749,7 @@ @subsubheading See Also:: -@ref{do; do*} +@ref{do} , @ref{dolist} , @@ -2770,7 +2770,7 @@ in the following way: @example - (loop @{@i{compound-form}@}{*}) @equiv{} (loop do @{@i{compound-form}@}{*}) + (loop @{@i{compound-form}@}*) @equiv{} (loop do @{@i{compound-form}@}*) @end example @node loop-finish, , loop, Iteration Dictionary diff -uNr gcl-texi-orig/chap-7.texi gcl-texi/chap-7.texi --- gcl-texi-orig/chap-7.texi 1994-07-16 18:03:16 +0400 +++ gcl-texi/chap-7.texi 2002-10-17 20:53:05 +0400 @@ -187,7 +187,7 @@ @i{lambda list} becomes an initialization argument for all @i{classes} for which the @i{method} is applicable. -The presence of {&allow-other-keys} in the +The presence of @t{&allow-other-keys} in the @i{lambda list} of an applicable method disables validity checking of initialization arguments. @@ -388,9 +388,10 @@ @center @example +@format @group @noindent -@w{ {} Defaulted {} } +@w{ @t{} Defaulted @t{} } @w{ Form Initialization Argument List Contents of Slot X } @w{ _____________________________________________________________________________} @w{ @t{(make-instance 'r)} @t{(a 1 b 2)} @t{1} } @@ -398,6 +399,7 @@ @w{ @t{(make-instance 'r 'b 4)} @t{(b 4 a 1)} @t{4} } @w{ @t{(make-instance 'r 'a 1 'a 2)} @t{(a 1 a 2 b 2)} @t{1} } @end group +@end format @end example @@ -607,10 +609,10 @@ @c including concept-change-class The @i{function} @b{change-class} can be used to change the @i{class} -of an @i{instance} from its current class, C_@{{from}@}, -to a different class, C_@{{to}@}; it changes the +of an @i{instance} from its current class, C_@{@r{from}@}, +to a different class, C_@{@r{to}@}; it changes the structure of the @i{instance} to conform to the definition of the class -C_@{{to}@}. +C_@{@r{to}@}. Note that changing the @i{class} of an @i{instance} may cause @i{slots} to be added or deleted. Changing the @i{class} of an @@ -634,14 +636,14 @@ @node Modifying the Structure of the Instance, Initializing Newly Added Local Slots (Changing the Class of an Instance), Changing the Class of an Instance, Changing the Class of an Instance @subsection Modifying the Structure of the Instance -In order to make the @i{instance} conform to the class C_@{{to}@}, @i{local slots} specified by the class C_@{{to}@} that are not specified by the class C_@{{from}@} are added, and @i{local slots} not specified by -the class C_@{{to}@} that are specified by the -class C_@{{from}@} are discarded. +In order to make the @i{instance} conform to the class C_@{@r{to}@}, @i{local slots} specified by the class C_@{@r{to}@} that are not specified by the class C_@{@r{from}@} are added, and @i{local slots} not specified by +the class C_@{@r{to}@} that are specified by the +class C_@{@r{from}@} are discarded. -The values of @i{local slots} specified by both the class C_@{{to}@} and the class C_@{{from}@} are retained. If such a @i{local slot} was unbound, it remains +The values of @i{local slots} specified by both the class C_@{@r{to}@} and the class C_@{@r{from}@} are retained. If such a @i{local slot} was unbound, it remains unbound. -The values of @i{slots} specified as shared in the class C_@{{from}@} and as local in the class C_@{{to}@} are retained. +The values of @i{slots} specified as shared in the class C_@{@r{from}@} and as local in the class C_@{@r{to}@} are retained. This first step of the update does not affect the values of any @i{shared slots}. @@ -659,10 +661,10 @@ The generic function @b{update-instance-for-different-class} is invoked on arguments computed by @b{change-class}. The first argument passed is a copy of the @i{instance} being updated -and is an @i{instance} of the class C_@{{from}@}; +and is an @i{instance} of the class C_@{@r{from}@}; this copy has @i{dynamic extent} within the generic function @b{change-class}. The second argument is the @i{instance} as updated so far by @b{change-class} -and is an @i{instance} of the class C_@{{to}@}. +and is an @i{instance} of the class C_@{@r{to}@}. The remaining arguments are an @i{initialization argument list}. There is a system-supplied primary @i{method} for @@ -1156,6 +1158,7 @@ their associated @i{forms} are called @i{method-defining forms}. The @i{standardized} @i{method-defining operators} are listed in Figure 7--2. +@format @group @noindent @w{ defgeneric defmethod defclass } @@ -1165,6 +1168,7 @@ @w{ Figure 7--2: Standardized Method-Defining Operators} @end group +@end format Note that of the @i{standardized} @i{method-defining operators} only @b{defgeneric} @@ -1507,14 +1511,14 @@ @table @asis @item 1. -{Select the applicable methods.} +@r{Select the applicable methods.} @item 2. -{Sort the applicable methods by precedence order, putting +@r{Sort the applicable methods by precedence order, putting the most specific method first.} @item 3. -{Apply method combination to the sorted list of +@r{Apply method combination to the sorted list of applicable methods, producing the effective method.} @end table @@ -1773,6 +1777,7 @@ @IRindex{standard} +@format @group @noindent @w{ + append max nconc progn } @@ -1782,6 +1787,7 @@ @w{ Figure 7--3: Built-in Method Combination Types} @end group +@end format The semantics of the @b{standard} built-in method combination type is described in @ref{Standard Method Combination}. The other @@ -1999,7 +2005,7 @@ @node ensure-generic-function, allocate-instance, function-keywords, Objects Dictionary @subsection ensure-generic-function [Function] -@code{ensure-generic-function} @i{function-name {&key} +@code{ensure-generic-function} @i{function-name @r{&key} argument-precedence-order declare documentation environment generic-function-class lambda-list @@ -2106,13 +2112,13 @@ @subsubheading Syntax:: -@code{allocate-instance} @i{class {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{new-instance} +@code{allocate-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{new-instance} @subsubheading Method Signatures:: -@code{allocate-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} {&rest} initargs} +@code{allocate-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} -@code{allocate-instance} @i{@r{(}@i{class} @b{structure-class}@r{)} {&rest} initargs} +@code{allocate-instance} @i{@r{(}@i{class} @b{structure-class}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2159,11 +2165,11 @@ @subsubheading Syntax:: -@code{reinitialize-instance} @i{instance {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} +@code{reinitialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: -@code{reinitialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} {&rest} initargs} +@code{reinitialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2232,11 +2238,11 @@ @subsubheading Syntax:: -@code{shared-initialize} @i{instance slot-names {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} +@code{shared-initialize} @i{instance slot-names @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: -@code{shared-initialize} @i{@r{(}@i{instance} @b{standard-object}@r{)} slot-names {&rest} initargs} +@code{shared-initialize} @i{@r{(}@i{instance} @b{standard-object}@r{)} slot-names @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2356,14 +2362,14 @@ @subsubheading Syntax:: @code{update-instance-for-different-class} @i{previous current - {&rest} initargs - {&key} {&allow-other-keys}} @result{} @i{@i{implementation-dependent}} + @r{&rest} initargs + @r{&key} @r{&allow-other-keys}} @result{} @i{@i{implementation-dependent}} @subsubheading Method Signatures:: @code{update-instance-for-different-class} @i{@r{(}@i{previous} @b{standard-object}@r{)} @r{(}@i{current} @b{standard-object}@r{)} - {&rest} initargs} + @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2462,15 +2468,15 @@ @code{update-instance-for-redefined-class} @i{instance added-slots discarded-slots property-list - {&rest} initargs {&key} {&allow-other-keys}}@* - @result{} @i{@{@i{result}@}{*}} + @r{&rest} initargs @r{&key} @r{&allow-other-keys}}@* + @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{update-instance-for-redefined-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} added-slots discarded-slots property-list - {&rest} initargs} + @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2610,17 +2616,17 @@ @subsubheading Syntax:: -@code{change-class} @i{instance new-class {&key} {&allow-other-keys}} @result{} @i{instance} +@code{change-class} @i{instance new-class @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: @code{change-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{(}@i{new-class} @b{standard-class}@r{)} - {&rest} initargs} + @r{&rest} initargs} @code{change-class} @i{@r{(}@i{instance} @b{t}@r{)} @r{(}@i{new-class} @b{symbol}@r{)} - {&rest} initargs} + @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -2651,7 +2657,7 @@ generic function @b{update-instance-for-different-class} can be used to assign values to slots in the transformed instance. -See @ref{Initializing Newly Added Local Slots}. +See @ref{Initializing Newly Added Local Slots (Changing the Class of an Instance)}. If the second of the above @i{methods} is selected, that @i{method} invokes @b{change-class} @@ -2868,13 +2874,13 @@ @subsubheading Syntax:: -@code{slot-missing} @i{class object slot-name operation {&optional} new-value} @result{} @i{@{@i{result}@}{*}} +@code{slot-missing} @i{class object slot-name operation @r{&optional} new-value} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{slot-missing} @i{@r{(}@i{class} @b{t}@r{)} object slot-name - operation {&optional} new-value} + operation @r{&optional} new-value} @subsubheading Arguments and Values:: @@ -2961,7 +2967,7 @@ @subsubheading Syntax:: -@code{slot-unbound} @i{class instance slot-name} @result{} @i{@{@i{result}@}{*}} +@code{slot-unbound} @i{class instance slot-name} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @@ -3153,12 +3159,12 @@ @subsubheading Syntax:: -@code{no-applicable-method} @i{generic-function {&rest} function-arguments} @result{} @i{@{@i{result}@}{*}} +@code{no-applicable-method} @i{generic-function @r{&rest} function-arguments} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{no-applicable-method} @i{@r{(}@i{generic-function} @b{t}@r{)} - {&rest} function-arguments} + @r{&rest} function-arguments} @subsubheading Arguments and Values:: @@ -3191,13 +3197,13 @@ @subsubheading Syntax:: -@code{no-next-method} @i{generic-function method {&rest} args} @result{} @i{@{@i{result}@}{*}} +@code{no-next-method} @i{generic-function method @r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Method Signatures:: @code{no-next-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} @r{(}@i{method} @b{standard-method}@r{)} - {&rest} args} + @r{&rest} args} @subsubheading Arguments and Values:: @@ -3263,13 +3269,13 @@ @subsubheading Syntax:: -@code{make-instance} @i{class {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} +@code{make-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: -@code{make-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} {&rest} initargs} +@code{make-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} -@code{make-instance} @i{@r{(}@i{class} @b{symbol}@r{)} {&rest} initargs} +@code{make-instance} @i{@r{(}@i{class} @b{symbol}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: @@ -3359,17 +3365,17 @@ @subsubheading Syntax:: -@code{make-load-form} @i{object {&optional} environment} @result{} @i{creation-form@r{[}, initialization-form@r{]}} +@code{make-load-form} @i{object @r{&optional} environment} @result{} @i{creation-form @r{[}, initialization-form @r{]}} @subsubheading Method Signatures:: -@code{make-load-form} @i{@r{(}@i{object} @b{standard-object}@r{)} {&optional} environment} +@code{make-load-form} @i{@r{(}@i{object} @b{standard-object}@r{)} @r{&optional} environment} -@code{make-load-form} @i{@r{(}@i{object} @b{structure-object}@r{)} {&optional} environment} +@code{make-load-form} @i{@r{(}@i{object} @b{structure-object}@r{)} @r{&optional} environment} -@code{make-load-form} @i{@r{(}@i{object} @b{condition}@r{)} {&optional} environment} +@code{make-load-form} @i{@r{(}@i{object} @b{condition}@r{)} @r{&optional} environment} -@code{make-load-form} @i{@r{(}@i{object} @b{class}@r{)} {&optional} environment} +@code{make-load-form} @i{@r{(}@i{object} @b{class}@r{)} @r{&optional} environment} @subsubheading Arguments and Values:: @@ -3643,7 +3649,7 @@ @node make-load-form-saving-slots, with-accessors, make-load-form, Objects Dictionary @subsection make-load-form-saving-slots [Function] -@code{make-load-form-saving-slots} @i{object {&key} slot-names environment}@* +@code{make-load-form-saving-slots} @i{object @r{&key} slot-names environment}@* @result{} @i{creation-form, initialization-form} @subsubheading Arguments and Values:: @@ -3687,7 +3693,7 @@ , @ref{make-instance} , -@ref{setf; psetf} +@ref{setf} , @ref{slot-value} , @@ -3708,12 +3714,12 @@ @node with-accessors, with-slots, make-load-form-saving-slots, Objects Dictionary @subsection with-accessors [Macro] -@code{with-accessors} @i{{@r{(}@{@i{slot-entry}@}{*}@r{)}} +@code{with-accessors} @i{@r{@r{(}@{@i{slot-entry}@}*@r{)}} instance-form - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} -@w{@i{slot-entry} ::=@r{(}variable-name accessor-name@r{)}} +@w{@i{slot-entry} ::=@r{(}variable-name accessor-name @r{)}} @subsubheading Arguments and Values:: @@ -3794,7 +3800,7 @@ @center @example -@w{@t{(with-accessors} ({slot-entry}_1 ...{slot-entry}_n) @i{instance-form} {form}_1 ...{form}_k)}@* +@w{@t{(with-accessors} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* @end example @noindent @@ -3804,26 +3810,26 @@ @example @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* -@w{ @t{(symbol-macrolet (}{Q}_1... {Q}_n@t{)} {form}_1 ...{form}_k@t{))}}@* +@w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* @end example @noindent -where {Q}_i is +where @r{Q}_i is -@center { +@center @example -@t{(}{variable-name}_i () -@t{({accessor-name}_i in))} +@t{(}@r{variable-name}_i () +@t{(@r{accessor-name}_i in))} @end example -} + @node with-slots, defclass, with-accessors, Objects Dictionary @subsection with-slots [Macro] -@code{with-slots} @i{@r{(}@{@i{slot-entry}@}{*}@r{)} +@code{with-slots} @i{@r{(}@{@i{slot-entry}@}*@r{)} instance-form - @{@i{declaration}@}{*} @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} + @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @w{@i{slot-entry} ::=slot-name | @r{(}variable-name slot-name@r{)}} @@ -3916,7 +3922,7 @@ @center @example -@w{@t{(with-slots} ({slot-entry}_1 ...{slot-entry}_n) @i{instance-form} {form}_1 ...{form}_k)}@* +@w{@t{(with-slots} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* @end example @noindent @@ -3926,44 +3932,44 @@ @example @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* -@w{ @t{(symbol-macrolet (}{Q}_1... {Q}_n@t{)} {form}_1 ...{form}_k@t{))}}@* +@w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* @end example @noindent -where {Q}_i is +where @r{Q}_i is @center @example -@t{(}{slot-entry}_i () -@t{(slot-value }in '{slot-entry}_i@t{))} +@t{(}@r{slot-entry}_i () +@t{(slot-value }in '@r{slot-entry}_i@t{))} @end example @noindent -if {slot-entry}_i is a @i{symbol} +if @r{slot-entry}_i is a @i{symbol} and is -@center { +@center @example -@t{(}{variable-name}_i () -@t{(slot-value }in '{slot-name}_i@t{))} +@t{(}@r{variable-name}_i () +@t{(slot-value }in '@r{slot-name}_i@t{))} @end example -} + @noindent -if {slot-entry}_i +if @r{slot-entry}_i is of the form @center @example -@t{(}{variable-name}_i -{slot-name}_i@t{)} +@t{(}@r{variable-name}_i +@r{slot-name}_i@t{)} @end example @node defclass, defgeneric, with-slots, Objects Dictionary @subsection defclass [Macro] -@code{defclass} @i{@i{class-name} @r{(}@{@i{superclass-name}@}{*}@r{)} -@r{(}@{{@i{slot-specifier}}@}{*}@r{)} +@code{defclass} @i{@i{class-name} @r{(}@{@i{superclass-name}@}*@r{)} +@r{(}@{@i{slot-specifier}@}*@r{)} [[!@i{class-option}]]}@* @result{} @i{new-class} @@ -3971,14 +3977,14 @@ @w{ @i{slot-name}::= @i{symbol}}@* -@w{ slot-option::=@{{:reader} @i{reader-function-name}@}{*} |}@* -@w{ @{{:writer} @i{writer-function-name}@}{*} |}@* -@w{ @{{:accessor} @i{reader-function-name}@}{*} |}@* -@w{ @{{:allocation} @i{allocation-type}@} |}@* -@w{ @{{:initarg} @i{initarg-name}@}{*} |}@* -@w{ @{{:initform} @i{form}@} |}@* -@w{ @{{:type} @i{type-specifier}@} |}@* -@w{ @{{:documentation} @i{string}@}}@* +@w{ slot-option::=@{@t{:reader} @i{reader-function-name}@}* |}@* +@w{ @{@t{:writer} @i{writer-function-name}@}* |}@* +@w{ @{@t{:accessor} @i{reader-function-name}@}* |}@* +@w{ @{@t{:allocation} @i{allocation-type}@} |}@* +@w{ @{@t{:initarg} @i{initarg-name}@}* |}@* +@w{ @{@t{:initform} @i{form}@} |}@* +@w{ @{@t{:type} @i{type-specifier}@} |}@* +@w{ @{@t{:documentation} @i{string}@}}@* @w{ @i{function-name}::= @{@i{symbol} | @t{(setf @i{symbol})}@}}@* @@ -4283,7 +4289,7 @@ @subsubheading See Also:: -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Initialize-Instance} , @@ -4301,17 +4307,17 @@ @subsection defgeneric [Macro] @code{defgeneric} @i{function-name gf-lambda-list - [[!@i{option} | @{!@i{method-description}@}{*}]]}@* + [[!@i{option} | @{!@i{method-description}@}*]]}@* @result{} @i{new-generic} @w{@i{option} ::=@r{(}@t{:argument-precedence-order} @{@i{parameter-name}@}^+@r{)} |} @w{ @r{(}@b{declare} @{@i{gf-declaration}@}^+@r{)} |} @w{ @r{(}@t{:documentation} @i{gf-documentation}@r{)} |} -@w{ @r{(}@t{:method-combination} @i{method-combination} @{@i{method-combination-argument}@}{*}@r{)} |} +@w{ @r{(}@t{:method-combination} @i{method-combination} @{@i{method-combination-argument}@}*@r{)} |} @w{ @r{(}@t{:generic-function-class} @i{generic-function-class}@r{)} |} @w{ @r{(}@t{:method-class} @i{method-class}@r{)}} -@w{@i{method-description} ::=@r{(}@t{:method} @{@i{method-qualifier}@}{*} @i{specialized-lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}@r{)}} +@w{@i{method-description} ::=@r{(}@t{:method} @{@i{method-qualifier}@}* @i{specialized-lambda-list} @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @@ -4560,7 +4566,7 @@ @ref{defmethod} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{ensure-generic-function} , @@ -4573,9 +4579,9 @@ @subsection defmethod [Macro] @code{defmethod} @i{@i{function-name} - @{{@i{method-qualifier}}@}{*} + @{@i{method-qualifier}@}* @i{specialized-lambda-list} - {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* + @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{new-method} @i{function-name}::= @{@i{symbol} @@ -4583,12 +4589,12 @@ @i{method-qualifier}::= @i{non-list} -@w{ @i{specialized-lambda-list}::= (@{@i{var} | @r{(}{@i{var} @i{parameter-specializer-name}}@r{)}@}{*}}@* -@w{ @t{[}{&optional} @{@i{var} | @r{(}var @t{[}@i{initform} {@r{[}@i{supplied-p-parameter}@r{]}} @t{]}@r{)}@}{*}@t{]}}@* +@w{ @i{specialized-lambda-list}::= (@{@i{var} | @r{(}@r{@i{var} @i{parameter-specializer-name}}@r{)}@}*}@* +@w{ @t{[}@r{&optional} @{@i{var} | @r{(}var @t{[}@i{initform} @r{@r{[}@i{supplied-p-parameter}@r{]}} @t{]}@r{)}@}*@t{]}}@* @w{ @t{[}@t{&rest} @i{var}@t{]}}@* -@w{ @t{{[}}{{&key}{}}@{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword}@i{var}@r{)}@} @t{[}@i{initform} @r{[}@i{supplied-p-parameter}@r{]} @t{]}@r{)}@}{*}}@* -@w{ @r{[}@b{&allow-other-keys}@r{]} @t{{]}}}@* -@w{ @t{[}@t{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{initform}@r{]} @r{)}@}{*}@t{]} @r{)}}@* +@w{ @t{[}@r{@r{&key}}@{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword}@i{var}@r{)}@} @t{[}@i{initform} @r{[}@i{supplied-p-parameter}@r{]} @t{]}@r{)}@}*}@* +@w{ @r{[}@b{&allow-other-keys}@r{]} @t{]}}@* +@w{ @t{[}@t{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{initform}@r{]} @r{)}@}*@t{]} @r{)}}@* @w{ @i{parameter-specializer-name}::= @i{symbol} | @r{(}@t{eql} @i{eql-specializer-form}@r{)}}@* @@ -4747,7 +4753,7 @@ @ref{defgeneric} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{Introduction to Methods}, @ref{Congruent Lambda-lists for all Methods of a Generic Function}, @@ -4757,9 +4763,9 @@ @node find-class, next-method-p, defmethod, Objects Dictionary @subsection find-class [Accessor] -@code{find-class} @i{symbol {&optional} errorp environment} @result{} @i{class} +@code{find-class} @i{symbol @r{&optional} errorp environment} @result{} @i{class} -(setf (@code{ find-class} @i{symbol {&optional} errorp environment}) new-class)@* +(setf (@code{ find-class} @i{symbol @r{&optional} errorp environment}) new-class)@* @subsubheading Arguments and Values:: @@ -4857,14 +4863,14 @@ , @ref{defmethod} , -@ref{call-method; make-method} +@ref{call-method} @node call-method, call-next-method, next-method-p, Objects Dictionary @subsection call-method, make-method [Local Macro] @subsubheading Syntax:: -@code{call-method} @i{method {&optional} next-method-list} @result{} @i{@{@i{result}@}{*}} +@code{call-method} @i{method @r{&optional} next-method-list} @result{} @i{@{@i{result}@}*} @code{make-method} @i{form} @result{} @i{method-object} @@ -4935,7 +4941,7 @@ @b{call-next-method} function available to @i{method} signals an error of @i{type} @b{control-error} and the @b{next-method-p} function -available to @i{method} returns {@b{nil}}. +available to @i{method} returns @b{nil}. @subsubheading Examples:: @@ -4952,7 +4958,7 @@ @subsubheading Syntax:: -@code{call-next-method} @i{{&rest} args} @result{} @i{@{@i{result}@}{*}} +@code{call-next-method} @i{@r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -5034,7 +5040,7 @@ , @ref{no-next-method} , -@ref{call-method; make-method} +@ref{call-method} , @ref{Method Selection and Combination}, @ref{Standard Method Combination}, @@ -5083,12 +5089,12 @@ @result{} @i{name} @code{define-method-combination} @i{name lambda-list - @r{(}@{@i{method-group-specifier}@}{*}@r{)} + @r{(}@{@i{method-group-specifier}@}*@r{)} @r{[}@r{(}@t{:arguments} . args-lambda-list@r{)}@r{]} @r{[}@r{(}@t{:generic-function} generic-function-symbol@r{)}@r{]} - [[@{@i{declaration}@}{*} | @i{documentation}]] - @{@i{form}@}{*}}@* + [[@{@i{declaration}@}* | @i{documentation}]] + @{@i{form}@}*}@* @result{} @i{name} @w{@i{short-form-option} ::=@t{:documentation} @i{documentation} | } @@ -5159,7 +5165,7 @@ when the second @i{subform} is a @i{non-nil} symbol or is not present. When the short form is used, @i{name} is defined as a type of method combination that produces a Lisp form -@t{({@i{operator} @i{method-call} @i{method-call} ...})}. +@t{(@r{@i{operator} @i{method-call} @i{method-call} ...})}. The @i{operator} is a @i{symbol} that can be the @i{name} of a @i{function}, @i{macro}, or @i{special operator}. The @i{operator} can be supplied by a keyword option; @@ -5620,11 +5626,11 @@ @subsubheading See Also:: -@ref{call-method; make-method} +@ref{call-method} , @ref{call-next-method} , -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{method-qualifiers} , @@ -5651,13 +5657,13 @@ @subsubheading Syntax:: -@code{find-method} @i{generic-function method-qualifiers specializers {&optional} errorp}@* +@code{find-method} @i{generic-function method-qualifiers specializers @r{&optional} errorp}@* @result{} @i{method} @subsubheading Method Signatures:: @code{find-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} - method-qualifiers specializers {&optional} errorp} + method-qualifiers specializers @r{&optional} errorp} @subsubheading Arguments and Values:: @@ -5783,11 +5789,11 @@ @subsubheading Syntax:: -@code{initialize-instance} @i{instance {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} +@code{initialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} @subsubheading Method Signatures:: -@code{initialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} {&rest} initargs} +@code{initialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/chap-8.texi gcl-texi/chap-8.texi --- gcl-texi-orig/chap-8.texi 1994-07-16 18:03:14 +0400 +++ gcl-texi/chap-8.texi 2002-10-17 20:53:05 +0400 @@ -20,13 +20,13 @@ @node defstruct, copy-structure, Structures Dictionary, Structures Dictionary @subsection defstruct [Macro] -@code{defstruct} @i{name-and-options @r{[}documentation@r{]} @{!@i{slot-description}@}{*}}@* +@code{defstruct} @i{name-and-options @r{[}documentation@r{]} @{!@i{slot-description}@}*}@* @result{} @i{structure-name} @w{@i{name-and-options} ::=structure-name | @r{(}structure-name [[!@i{options}]]@r{)}} @w{@i{options} ::=!@i{conc-name-option} |} -@w{ @{!@i{constructor-option}@}{*} |} +@w{ @{!@i{constructor-option}@}* |} @w{ !@i{copier-option} |} @w{ !@i{include-option} |} @w{ !@i{initial-offset-option} |} @@ -46,7 +46,7 @@ @w{@i{predicate-option} ::=@t{:predicate} | @r{(}@t{:predicate}@r{)} | @r{(}@t{:predicate} @i{predicate-name}@r{)}} -@w{@i{include-option} ::=@r{(}@t{:include} @i{included-structure-name} @{!@i{slot-description}@}{*}@r{)}} +@w{@i{include-option} ::=@r{(}@t{:include} @i{included-structure-name} @{!@i{slot-description}@}*@r{)}} @w{@i{printer-option} ::=!@i{print-object-option} | !@i{print-function-option}} @@ -461,7 +461,7 @@ structure specifies, by giving the @t{:include} option as: @example - (:include @i{included-structure-name} @{@i{slot-description}@}{*}) + (:include @i{included-structure-name} @{@i{slot-description}@}*) @end example Each @i{slot-description} must have a @i{slot-name} @@ -1106,11 +1106,11 @@ @subsubheading See Also:: -@ref{documentation; (setf documentation)} +@ref{documentation} , @ref{print-object} , -@ref{setf; psetf} +@ref{setf} , @ref{subtypep} , diff -uNr gcl-texi-orig/chap-9.texi gcl-texi/chap-9.texi --- gcl-texi-orig/chap-9.texi 1994-07-16 18:03:14 +0400 +++ gcl-texi/chap-9.texi 2002-10-17 22:06:25 +0400 @@ -98,7 +98,7 @@ * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: -* Notes about the Condition System's Background:: +* Notes about the Condition System`s Background:: @end menu @node Condition Types, Creating Conditions, Condition System Concepts, Condition System Concepts @@ -107,6 +107,7 @@ Figure 9--1 lists the @i{standardized} @i{condition} @i{types}. Additional @i{condition} @i{types} can be defined by using @b{define-condition}. +@format @group @noindent @w{ arithmetic-error floating-point-overflow simple-type-error } @@ -124,6 +125,7 @@ @w{ Figure 9--1: Standardized Condition Types } @end group +@end format All @i{condition} types are @i{subtypes} of @i{type} @b{condition}. That is, @@ -147,6 +149,7 @@ Figure 9--2 shows @i{operators} that define @i{condition} @i{types} and creating @i{conditions}. +@format @group @noindent @w{ define-condition make-condition } @@ -155,10 +158,12 @@ @w{ Figure 9--2: Operators that define and create conditions.} @end group +@end format Figure 9--3 shows @i{operators} that @i{read} the @i{value} of @i{condition} @i{slots}. +@format @group @noindent @w{ arithmetic-error-operands simple-condition-format-arguments } @@ -172,6 +177,7 @@ @w{ Figure 9--3: Operators that read condition slots. } @end group +@end format @menu * Serious Conditions:: @@ -210,7 +216,7 @@ . By convention, those arguments are notated as - @i{datum} {&rest} @i{arguments} + @i{datum} @r{&rest} @i{arguments} Taken together, the @i{datum} and the @i{arguments} are ``@i{designators} for a @i{condition} of default type @i{default-type}.'' @@ -218,7 +224,7 @@ @table @asis -@item {@t{*}} If the @i{datum} is a @i{symbol} +@item @t{*} If the @i{datum} is a @i{symbol} naming a @i{condition} @i{type} ... The denoted @i{condition} is the result of @@ -226,7 +232,7 @@ (apply #'make-condition @i{datum} @i{arguments}) @end example -@item {@t{*}} If the @i{datum} is a @i{format control} ... +@item @t{*} If the @i{datum} is a @i{format control} ... The denoted @i{condition} is the result of @@ -238,7 +244,7 @@ where the @i{defaulted-type} is a @i{subtype} of @i{default-type}. -@item {@t{*}} If the @i{datum} is a @i{condition} ... +@item @t{*} If the @i{datum} is a @i{condition} ... The denoted @i{condition} is the @i{datum} itself. In this case, unless otherwise specified by the description of the @i{operator} in question, the @i{arguments} must be @i{null}; @@ -456,6 +462,7 @@ Figure 9--4 shows @i{operators} relating to the @i{handling} of @i{conditions}. +@format @group @noindent @w{ handler-bind handler-case ignore-errors } @@ -464,6 +471,7 @@ @w{ Figure 9--4: Operators relating to handling conditions.} @end group +@end format @menu * Signaling:: @@ -502,6 +510,7 @@ Figure 9--5 shows @i{defined names} relating to the @i{signaling} of @i{conditions}. +@format @group @noindent @w{ *break-on-signals* error warn } @@ -511,6 +520,7 @@ @w{ Figure 9--5: Defined names relating to signaling conditions.} @end group +@end format @node Resignaling a Condition, Restarts, Signaling, Signaling and Handling Conditions @subsubsection Resignaling a Condition @@ -642,6 +652,7 @@ Figure 9--6 shows @i{defined names} relating to @i{restarts}. +@format @group @noindent @w{ abort invoke-restart-interactively store-value } @@ -654,6 +665,7 @@ @w{ Figure 9--6: Defined names relating to restarts. } @end group +@end format @node Restart Tests, Associating a Restart with a Condition, Interfaces to Restarts, Signaling and Handling Conditions @subsubsection Restart Tests @@ -683,7 +695,7 @@ @i{condition} by calling such a function without a @i{condition} @i{argument}, or by supplying a value of @b{nil} for such an @i{argument}. -@node Assertions, Notes about the Condition System's Background, Signaling and Handling Conditions, Condition System Concepts +@node Assertions, Notes about the Condition System`s Background, Signaling and Handling Conditions, Condition System Concepts @subsection Assertions Conditional signaling of @i{conditions} @@ -691,6 +703,7 @@ and @i{type} are handled by assertion @i{operators}. Figure 9--7 shows @i{operators} relating to assertions. +@format @group @noindent @w{ assert check-type ecase } @@ -700,9 +713,10 @@ @w{ Figure 9--7: Operators relating to assertions.} @end group +@end format -@node Notes about the Condition System's Background, , Assertions, Condition System Concepts -@subsection Notes about the Condition System's Background +@node Notes about the Condition System`s Background, , Assertions, Condition System Concepts +@subsection Notes about the Condition System`s Background For a background reference to the abstract concepts detailed in this section, see @i{Exceptional Situations in Lisp}. The details of that paper are not binding on @@ -757,12 +771,12 @@ * restart-name:: * with-condition-restarts:: * with-simple-restart:: -* abort:: +* abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: -* abort:: +* abort (Function):: @end menu @node condition, warning, Conditions Dictionary, Conditions Dictionary @@ -1038,9 +1052,9 @@ @node assert, error, storage-condition, Conditions Dictionary @subsection assert [Macro] -@code{assert} @i{test-form @r{[}@r{(}@{@i{place}@}{*}@r{)} +@code{assert} @i{test-form @r{[}@r{(}@{@i{place}@}*@r{)} @r{[}datum-form - @{@i{argument-form}@}{*}@r{]}@r{]}}@* + @{@i{argument-form}@}*@r{]}@r{]}}@* @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1158,7 +1172,7 @@ @node error, cerror, assert, Conditions Dictionary @subsection error [Function] -@code{error} @i{datum {&rest} arguments} +@code{error} @i{datum @r{&rest} arguments} @result{} # @subsubheading Arguments and Values:: @@ -1276,7 +1290,7 @@ @node cerror, check-type, error, Conditions Dictionary @subsection cerror [Function] -@code{cerror} @i{continue-format-control datum {&rest} arguments} @result{} @i{@b{nil}} +@code{cerror} @i{continue-format-control datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1441,7 +1455,7 @@ @node check-type, simple-error, cerror, Conditions Dictionary @subsection check-type [Macro] -@code{check-type} @i{place typespec {@r{[}@i{string}@r{]}}} @result{} @i{@b{nil}} +@code{check-type} @i{place typespec @r{@r{[}@i{string}@r{]}}} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1596,7 +1610,7 @@ @node invalid-method-error, method-combination-error, simple-error, Conditions Dictionary @subsection invalid-method-error [Function] -@code{invalid-method-error} @i{method format-control {&rest} args} @result{} @i{@i{implementation-dependent}} +@code{invalid-method-error} @i{method format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -1642,7 +1656,7 @@ @node method-combination-error, signal, invalid-method-error, Conditions Dictionary @subsection method-combination-error [Function] -@code{method-combination-error} @i{format-control {&rest} args} @result{} @i{@i{implementation-dependent}} +@code{method-combination-error} @i{format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @@ -1679,7 +1693,7 @@ @node signal, simple-condition, method-combination-error, Conditions Dictionary @subsection signal [Function] -@code{signal} @i{datum {&rest} arguments} @result{} @i{@b{nil}} +@code{signal} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1779,7 +1793,7 @@ @subsubheading See Also:: -@ref{simple-condition-format-control; simple-condition-format-arguments} +@ref{simple-condition-format-control} , @b{simple-condition-format-arguments} @@ -1831,7 +1845,7 @@ @node warn, simple-warning, simple-condition-format-control, Conditions Dictionary @subsection warn [Function] -@code{warn} @i{datum {&rest} arguments} @result{} @i{@b{nil}} +@code{warn} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -1999,7 +2013,7 @@ @node break, *debugger-hook*, invoke-debugger, Conditions Dictionary @subsection break [Function] -@code{break} @i{{&optional} format-control {&rest} format-arguments} @result{} @i{@b{nil}} +@code{break} @i{@r{&optional} format-control @r{&rest} format-arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @@ -2241,8 +2255,8 @@ @node handler-bind, handler-case, *break-on-signals*, Conditions Dictionary @subsection handler-bind [Macro] -@code{handler-bind} @i{@r{(}@{!@i{binding}@}{*}@r{)} - @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{handler-bind} @i{@r{(}@{!@i{binding}@}*@r{)} + @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @w{@i{binding} ::=@r{(}type handler@r{)}} @@ -2325,13 +2339,13 @@ @subsection handler-case [Macro] @code{handler-case} @i{@i{expression} - [[@{!@i{error-clause}@}{*} | !@i{no-error-clause}]]} @result{} @i{@{@i{result}@}{*}} + [[@{!@i{error-clause}@}* | !@i{no-error-clause}]]} @result{} @i{@{@i{result}@}*} @w{@i{clause} ::=!@i{error-clause} | !@i{no-error-clause}} -@w{@i{error-clause} ::=@r{(}typespec @r{(}@t{[}var@t{]}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} +@w{@i{error-clause} ::=@r{(}typespec @r{(}@t{[}var@t{]}@r{)} @{@i{declaration}@}* @{@i{form}@}*@r{)}} -@w{@i{no-error-clause} ::=@r{(}@t{:no-error} @i{lambda-list} @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} +@w{@i{no-error-clause} ::=@r{(}@t{:no-error} @i{lambda-list} @{@i{declaration}@}* @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @@ -2406,7 +2420,7 @@ @i{expression} returns normally and a @i{no-error-clause} does exist, the values returned are used as arguments to the function described by constructing - @t{(lambda @i{lambda-list} @{@i{form}@}{*})} + @t{(lambda @i{lambda-list} @{@i{form}@}*)} from the @i{no-error-clause}, and the @i{values} of that function call are returned by @b{handler-case}. The handlers which were established around the @i{expression} are no longer active at the time of this call. @@ -2490,7 +2504,7 @@ @node ignore-errors, define-condition, handler-case, Conditions Dictionary @subsection ignore-errors [Macro] -@code{ignore-errors} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} +@code{ignore-errors} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -2561,20 +2575,20 @@ [Editorial Note by KMP: This syntax stuff is still very confused and needs lots of work.] -@code{define-condition} @i{name @r{(}@{@i{parent-type}@}{*}@r{)} - @r{(}@{!@i{slot-spec}@}{*}@r{)} - @{@i{option}@}{*}}@* +@code{define-condition} @i{name @r{(}@{@i{parent-type}@}*@r{)} + @r{(}@{!@i{slot-spec}@}*@r{)} + @{@i{option}@}*}@* @result{} @i{name} @w{@i{slot-spec} ::=slot-name | @r{(}slot-name !@i{slot-option}@r{)}} -@w{@i{slot-option} ::=[[ @{{:reader} @i{symbol}@}{*} | } -@w{ @{{:writer} !@i{function-name}@}{*} | } -@w{ @{{:accessor} @i{symbol}@}{*} | } -@w{ @{{:allocation} !@i{allocation-type}@} | } -@w{ @{{:initarg} @i{symbol}@}{*} | } -@w{ @{{:initform} @i{form}@} | } -@w{ @{{:type} @i{type-specifier}@} ]]} +@w{@i{slot-option} ::=[[ @{@t{:reader} @i{symbol}@}* | } +@w{ @{@t{:writer} !@i{function-name}@}* | } +@w{ @{@t{:accessor} @i{symbol}@}* | } +@w{ @{@t{:allocation} !@i{allocation-type}@} | } +@w{ @{@t{:initarg} @i{symbol}@}* | } +@w{ @{@t{:initform} @i{form}@} | } +@w{ @{@t{:type} @i{type-specifier}@} ]]} @w{@i{option} ::=[[ @r{(}@t{:default-initargs} @t{.} @i{initarg-list}@r{)} | } @w{ @r{(}@t{:documentation} @i{string}@r{)} | } @@ -2897,7 +2911,7 @@ @node make-condition, restart, define-condition, Conditions Dictionary @subsection make-condition [Function] -@code{make-condition} @i{type {&rest} slot-initializations} @result{} @i{condition} +@code{make-condition} @i{type @r{&rest} slot-initializations} @result{} @i{condition} @subsubheading Arguments and Values:: @@ -2963,7 +2977,7 @@ @node compute-restarts, find-restart, restart, Conditions Dictionary @subsection compute-restarts [Function] -@code{compute-restarts} @i{{&optional} condition} @result{} @i{restarts} +@code{compute-restarts} @i{@r{&optional} condition} @result{} @i{restarts} @subsubheading Arguments and Values:: @@ -3051,8 +3065,8 @@ @node find-restart, invoke-restart, compute-restarts, Conditions Dictionary @subsection find-restart [Function] -@code{find-restart} @i{identifier {&optional} condition} - {restart} +@code{find-restart} @i{identifier @r{&optional} condition} + @r{restart} @subsubheading Arguments and Values:: @@ -3120,7 +3134,7 @@ @node invoke-restart, invoke-restart-interactively, find-restart, Conditions Dictionary @subsection invoke-restart [Function] -@code{invoke-restart} @i{restart {&rest} arguments} @result{} @i{@{@i{result}@}{*}} +@code{invoke-restart} @i{restart @r{&rest} arguments} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3185,7 +3199,7 @@ @node invoke-restart-interactively, restart-bind, invoke-restart, Conditions Dictionary @subsection invoke-restart-interactively [Function] -@code{invoke-restart-interactively} @i{restart} @result{} @i{@{@i{result}@}{*}} +@code{invoke-restart-interactively} @i{restart} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3270,14 +3284,14 @@ @node restart-bind, restart-case, invoke-restart-interactively, Conditions Dictionary @subsection restart-bind [Macro] -@code{restart-bind} @i{@r{(}@{{(}name function - @{!@i{key-val-pair}@}{*}@r{)}@}{)} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} - -@w{@i{key-val-pair} ::=@t{:interactive-function} {interactive-function} | } -@w{ @t{:report-function} {report-function} | } -@w{ @t{:test-function} {test-function}} +@code{restart-bind} @i{@r{(}@{@r{(}name function + @{!@i{key-val-pair}@}*@r{)}@}@r{)} + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} + +@w{@i{key-val-pair} ::=@t{:interactive-function} @r{interactive-function} | } +@w{ @t{:report-function} @r{report-function} | } +@w{ @t{:test-function} @r{test-function}} @subsubheading Arguments and Values:: @@ -3386,11 +3400,11 @@ @node restart-case, restart-name, restart-bind, Conditions Dictionary @subsection restart-case [Macro] -@code{restart-case} @i{restartable-form {@{!@i{clause}@}}} @result{} @i{@{@i{result}@}{*}} +@code{restart-case} @i{restartable-form @r{@{!@i{clause}@}}} @result{} @i{@{@i{result}@}*} @w{@i{clause} ::=@r{(} case-name lambda-list } @w{ [[@t{:interactive} interactive-expression | @t{:report} report-expression | @t{:test} test-expression]] } -@w{ @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} +@w{ @{@i{declaration}@}* @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @@ -3700,8 +3714,8 @@ @node with-condition-restarts, with-simple-restart, restart-name, Conditions Dictionary @subsection with-condition-restarts [Macro] -@code{with-condition-restarts} @i{condition-form restarts-form @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{with-condition-restarts} @i{condition-form restarts-form @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3740,12 +3754,12 @@ since @b{restart-case} handles most of the common cases in a way that is syntactically more concise. -@node with-simple-restart, abort, with-condition-restarts, Conditions Dictionary +@node with-simple-restart, abort (Restart), with-condition-restarts, Conditions Dictionary @subsection with-simple-restart [Macro] -@code{with-simple-restart} @i{@r{(}name format-control @{@i{format-argument}@}{*}@r{)} - @{@i{form}@}{*}}@* - @result{} @i{@{@i{result}@}{*}} +@code{with-simple-restart} @i{@r{(}name format-control @{@i{format-argument}@}*@r{)} + @{@i{form}@}*}@* + @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @@ -3800,7 +3814,7 @@ @example (defun compute-fixnum-power-of-2 (x) - (with-simple-restart (nil "Give up on computing 2{@t{^}}~D." x) + (with-simple-restart (nil "Give up on computing 2@t{^}~D." x) (let ((result 1)) (dotimes (i x result) (setq result (* 2 result)) @@ -3815,7 +3829,7 @@ (compute-power-of-2 10000) @t{ |> } Error: Power of 2 is too large. @t{ |> } To continue, type :CONTINUE followed by an option number. -@t{ |> } 1: Give up on computing 2{@t{^}}10000. +@t{ |> } 1: Give up on computing 2@t{^}10000. @t{ |> } 2: Return to Lisp Toplevel @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @result{} SOMETHING-BIG @@ -3848,7 +3862,7 @@ in the normal case to be missing or @b{nil} so that the two situations can be distinguished. -@node abort, continue, with-simple-restart, Conditions Dictionary +@node abort (Restart), continue, with-simple-restart, Conditions Dictionary @subsection abort [Restart] @subsubheading Data Arguments Required:: @@ -3875,10 +3889,10 @@ @ref{Interfaces to Restarts}, @ref{invoke-restart} , -@ref{abort} +@ref{abort (Function)} (@i{function}) -@node continue, muffle-warning, abort, Conditions Dictionary +@node continue, muffle-warning, abort (Restart), Conditions Dictionary @subsection continue [Restart] @subsubheading Data Arguments Required:: @@ -4020,7 +4034,7 @@ @ref{use-value} (@i{function} and @i{restart}) -@node use-value, abort, store-value, Conditions Dictionary +@node use-value, abort (Function), store-value, Conditions Dictionary @subsection use-value [Restart] @subsubheading Data Arguments Required:: @@ -4044,7 +4058,7 @@ @ref{store-value} (@i{function} and @i{restart}) -@node abort, , use-value, Conditions Dictionary +@node abort (Function), , use-value, Conditions Dictionary @subsection abort, continue, muffle-warning, store-value, use-value [Function] @IRindex{abort} @@ -4057,17 +4071,17 @@ @IRindex{use-value} -@code{abort} @i{{&optional} condition} +@code{abort} @i{@r{&optional} condition} @result{} # -@code{continue} @i{{&optional} condition} @result{} @i{@b{nil}} +@code{continue} @i{@r{&optional} condition} @result{} @i{@b{nil}} -@code{muffle-warning} @i{{&optional} condition} +@code{muffle-warning} @i{@r{&optional} condition} @result{} # -@code{store-value} @i{value {&optional} condition} @result{} @i{@b{nil}} +@code{store-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} -@code{use-value} @i{value {&optional} condition} @result{} @i{@b{nil}} +@code{use-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: diff -uNr gcl-texi-orig/gcl.texi gcl-texi/gcl.texi --- gcl-texi-orig/gcl.texi 1994-07-16 18:03:23 +0400 +++ gcl-texi/gcl.texi 2002-10-18 12:47:46 +0400 @@ -5,11 +5,19 @@ @settitle ANSI and GNU Common Lisp Document @c %**end of header @setchapternewpage odd + @ifinfo This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter + +@format +INFO-DIR-SECTION GNU Common Lisp +START-INFO-DIR-ENTRY +* gcl: (gcl.info). GNU Common Lisp Manual +END-INFO-DIR-ENTRY +@end format @end ifinfo @titlepage @@ -32,7 +40,7 @@ @c Example index @defcodeindex IP @c Package index -@defcodeindex IK +@c @defcodeindex IK @c Keyword Index @node Top, Introduction (Introduction), (dir), (dir) @@ -110,38 +118,38 @@ Interpreting Dictionary Entries -* The ``Affected By'' Section of a Dictionary Entry:: -* The ``Arguments'' Section of a Dictionary Entry:: -* The ``Arguments and Values'' Section of a Dictionary Entry:: -* The ``Binding Types Affected'' Section of a Dictionary Entry:: -* The ``Class Precedence List'' Section of a Dictionary Entry:: +* The "Affected By" Section of a Dictionary Entry:: +* The "Arguments" Section of a Dictionary Entry:: +* The "Arguments and Values" Section of a Dictionary Entry:: +* The "Binding Types Affected" Section of a Dictionary Entry:: +* The "Class Precedence List" Section of a Dictionary Entry:: * Dictionary Entries for Type Specifiers:: -* The ``Compound Type Specifier Kind'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry:: -* The ``Compound Type Specifier Description'' Section of a Dictionary Entry:: -* The ``Constant Value'' Section of a Dictionary Entry:: -* The ``Description'' Section of a Dictionary Entry:: -* The ``Examples'' Section of a Dictionary Entry:: -* The ``Exceptional Situations'' Section of a Dictionary Entry:: -* The ``Initial Value'' Section of a Dictionary Entry:: -* The ``Argument Precedence Order'' Section of a Dictionary Entry:: -* The ``Method Signature'' Section of a Dictionary Entry:: -* The ``Name'' Section of a Dictionary Entry:: -* The ``Notes'' Section of a Dictionary Entry:: -* The ``Pronunciation'' Section of a Dictionary Entry:: -* The ``See Also'' Section of a Dictionary Entry:: -* The ``Side Effects'' Section of a Dictionary Entry:: -* The ``Supertypes'' Section of a Dictionary Entry:: -* The ``Syntax'' Section of a Dictionary Entry:: -* Special ``Syntax'' Notations for Overloaded Operators:: +* The "Compound Type Specifier Kind" Section of a Dictionary Entry:: +* The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: +* The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: +* The "Compound Type Specifier Description" Section of a Dictionary Entry:: +* The "Constant Value" Section of a Dictionary Entry:: +* The "Description" Section of a Dictionary Entry:: +* The "Examples" Section of a Dictionary Entry:: +* The "Exceptional Situations" Section of a Dictionary Entry:: +* The "Initial Value" Section of a Dictionary Entry:: +* The "Argument Precedence Order" Section of a Dictionary Entry:: +* The "Method Signature" Section of a Dictionary Entry:: +* The "Name" Section of a Dictionary Entry:: +* The "Notes" Section of a Dictionary Entry:: +* The "Pronunciation" Section of a Dictionary Entry:: +* The "See Also" Section of a Dictionary Entry:: +* The "Side Effects" Section of a Dictionary Entry:: +* The "Supertypes" Section of a Dictionary Entry:: +* The "Syntax" Section of a Dictionary Entry:: +* Special "Syntax" Notations for Overloaded Operators:: * Naming Conventions for Rest Parameters:: -* Requiring Non-Null Rest Parameters in the ``Syntax'' Section:: -* Return values in the ``Syntax'' Section:: -* No Arguments or Values in the ``Syntax'' Section:: -* Unconditional Transfer of Control in the ``Syntax'' Section:: -* The ``Valid Context'' Section of a Dictionary Entry:: -* The ``Value Type'' Section of a Dictionary Entry:: +* Requiring Non-Null Rest Parameters in The "Syntax" Section:: +* Return values in The "Syntax" Section:: +* No Arguments or Values in The "Syntax" Section:: +* Unconditional Transfer of Control in The "Syntax" Section:: +* The "Valid Context" Section of a Dictionary Entry:: +* The "Value Type" Section of a Dictionary Entry:: Conformance @@ -529,7 +537,7 @@ * method-combination:: * t (System Class):: * satisfies:: -* member:: +* member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: @@ -871,7 +879,7 @@ * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: -* Notes about the Condition System's Background:: +* Notes about the Condition System`s Background:: Condition Types @@ -942,12 +950,12 @@ * restart-name:: * with-condition-restarts:: * with-simple-restart:: -* abort:: +* abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: -* abort:: +* abort (Function):: Symbols @@ -1095,13 +1103,13 @@ * real:: * float (System Class):: * short-float:: -* rational:: +* rational (System Class):: * ratio:: * integer:: * signed-byte:: * unsigned-byte:: -* mod:: -* bit:: +* mod (System Class):: +* bit (System Class):: * fixnum:: * bignum:: * =:: @@ -1125,7 +1133,7 @@ * incf:: * lcm:: * log:: -* mod:: +* mod (Function):: * signum:: * sqrt:: * random-state:: @@ -1143,7 +1151,7 @@ * upgraded-complex-part-type:: * realp:: * numerator:: -* rational:: +* rational (Function):: * rationalp:: * ash:: * integer-length:: @@ -1257,7 +1265,7 @@ Conses Dictionary -* list:: +* list (System Class):: * null (System Class):: * cons (System Class):: * atom (Type):: @@ -1271,7 +1279,7 @@ * subst:: * tree-equal:: * copy-list:: -* list:: +* list (Function):: * list-length:: * listp:: * make-list:: @@ -1289,7 +1297,7 @@ * ldiff:: * nthcdr:: * rest:: -* member:: +* member (Function):: * mapc:: * acons:: * assoc:: @@ -1368,7 +1376,7 @@ * vector-pop:: * vector-push:: * vectorp:: -* bit:: +* bit (Array):: * bit-and:: * bit-vector-p:: * simple-bit-vector-p:: @@ -1741,7 +1749,7 @@ * Pretty Printer Concepts:: * Examples of using the Pretty Printer:: -* Notes about the Pretty Printer's Background:: +* Notes about the Pretty Printer`s Background:: Pretty Printer Concepts gcl-2.6.14/info/form.texi0000755000175000017500000006056314360276512013601 0ustar cammcamm@node Special Forms and Functions, Compilation, Streams and Reading, Top @chapter Special Forms and Functions @defvr {Constant} LAMBDA-LIST-KEYWORDS Package:LISP List of all the lambda-list keywords used in GCL. @end defvr @deffn {Special Form} THE Package:LISP Syntax: @example (the value-type form) @end example Declares that the value of FORM must be of VALUE-TYPE. Signals an error if this is not the case. @end deffn @deffn {Special Form} SETF Package:LISP Syntax: @example (setf @{place newvalue@}*) @end example Replaces the value in PLACE with the value of NEWVALUE, from left to right. Returns the value of the last NEWVALUE. Each PLACE may be any one of the following: @itemize @asis{} @item A symbol that names a variable. @item A function call form whose first element is the name of the following functions: @example nth elt subseq rest first ... tenth c?r c??r c???r c????r aref svref char schar bit sbit fill-poiter get getf documentation symbol-value symbol-function symbol-plist macro-function gethash char-bit ldb mask-field apply @end example where '?' stands for either 'a' or 'd'. @item the form (THE type place) with PLACE being a place recognized by SETF. @item a macro call which expands to a place recognized by SETF. @item any form for which a DEFSETF or DEFINE-SETF-METHOD declaration has been made. @end itemize @end deffn @deffn {Special Form} WHEN Package:LISP Syntax: @example (when test @{form@}*) @end example If TEST evaluates to non-NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL. @end deffn @deffn {Macro} CCASE Package:LISP Syntax: @example (ccase keyplace @{(@{key | (@{key@}*)@} @{form@}*)@}*) @end example Evaluates KEYPLACE and tries to find the KEY that is EQL to the value of KEYPLACE. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error. @end deffn @defun MACROEXPAND (form &optional (env nil)) Package:LISP If FORM is a macro form, then expands it repeatedly until it is not a macro any more. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro. @end defun @deffn {Special Form} MULTIPLE-VALUE-CALL Package:LISP Syntax: @example (multiple-value-call function @{form@}*) @end example Calls FUNCTION with all the values of FORMs as arguments. @end deffn @deffn {Macro} DEFSETF Package:LISP Syntax: @example (defsetf access-fun @{update-fun [doc] | lambda-list (store-var) @{decl | doc@}* @{form@}*) @end example Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation 'NAME 'setf). @example (defsetf access-fun update-fun) defines an expansion from (setf (ACCESS-FUN arg1 ... argn) value) to (UPDATE-FUN arg1 ... argn value). (defsetf access-fun lambda-list (store-var) . body) defines a macro which @end example expands @example (setf (ACCESS-FUN arg1 ... argn) value) into the form (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest) @end example where REST is the value of BODY with parameters in LAMBDA-LIST bound to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0. @end deffn @deffn {Special Form} TAGBODY Package:LISP Syntax: @example (tagbody @{tag | statement@}*) @end example Executes STATEMENTs and returns NIL if it falls off the end. @end deffn @deffn {Macro} ETYPECASE Package:LISP Syntax: @example (etypecase keyform @{(type @{form@}*)@}*) @end example Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error. @end deffn @deffn {Special Form} LET* Package:LISP Syntax: @example (let* (@{var | (var [value])@}*) @{decl@}* @{form@}*) @end example Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) from left to right, then evaluates FORMs as a PROGN. @end deffn @deffn {Special Form} PROG1 Package:LISP Syntax: @example (prog1 first @{form@}*) @end example Evaluates FIRST and FORMs in order, and returns the (single) value of FIRST. @end deffn @deffn {Special Form} DEFUN Package:LISP Syntax: @example (defun name lambda-list @{decl | doc@}* @{form@}*) @end example Defines a function as the global function definition of the symbol NAME. The complete syntax of a lambda-list is: (@{var@}* [&optional @{var | (var [initform [svar]])@}*] [&rest var] [&key @{var | (@{var | (keyword var)@} [initform [svar]])@}* [&allow-other-keys]] [&aux @{var | (var [initform])@}*]) The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). @end deffn @deffn {Special Form} MULTIPLE-VALUE-BIND Package:LISP Syntax: @example (multiple-value-bind (@{var@}*) values-form @{decl@}* @{form@}*) @end example Binds the VARiables to the results of VALUES-FORM, in order (defaulting to NIL) and evaluates FORMs in order. @end deffn @deffn {Special Form} DECLARE Package:LISP Syntax: @example (declare @{decl-spec@}*) @end example Gives a declaration. Possible DECL-SPECs are: (SPECIAL @{var@}*) (TYPE type @{var@}*) where 'TYPE' is one of the following symbols @example array fixnum package simple-bit-vector atom float pathname simple-string bignum function random-state simple-vector bit hash-table ratio single-float bit-vector integer rational standard-char character keyword readtable stream common list sequence string compiled-function long-float short-float string-char complex nil signed-byte symbol cons null unsigned-byte t double-float number simple-array vector @end example 'TYPE' may also be a list containing one of the above symbols as its first element and more specific information later in the list. For example @example (vector long-float 80) ; vector of 80 long-floats. (array long-float *) ; array of long-floats (array fixnum) ; array of fixnums (array * 30) ; an array of length 30 but unspecified type @end example A list of 1 element may be replaced by the symbol alone, and a list ending in '*' may drop the the final '*'. @example (OBJECT @{var@}*) (FTYPE type @{function-name@}*) eg: ;; function of two required args and optional args and one value: (ftype (function (t t *) t) sort reduce) ;; function with 1 arg of general type returning 1 fixnum as value. (ftype (function (t) fixnum) length) (FUNCTION function-name (@{arg-type@}*) @{return-type@}*) (INLINE @{function-name@}*) (NOTINLINE @{function-name@}*) (IGNORE @{var@}*) (OPTIMIZE @{(@{SPEED | SPACE | SAFETY | COMPILATION-SPEED@} @{0 | 1 | 2 | 3@})@}*) (DECLARATION @{non-standard-decl-name@}*) (:DYNAMIC-EXTENT @{var@}*) ;GCL-specific. @end example @end deffn @deffn {Special Form} DEFMACRO Package:LISP Syntax: @example (defmacro name defmacro-lambda-list @{decl | doc@}* @{form@}*) @end example Defines a macro as the global macro definition of the symbol NAME. The complete syntax of a defmacro-lambda-list is: ( [&whole var] [&environment var] @{pseudo-var@}* [&optional @{var | (pseudo-var [initform [pseudo-var]])@}*] @{[@{&rest | &body@} pseudo-var] [&key @{var | (@{var | (keyword pseudo-var)@} [initform [pseudo-var]])@}* [&allow-other-keys]] [&aux @{var | (pseudo-var [initform])@}*] | . var@}) where pseudo-var is either a symbol or a list of the following form: ( @{pseudo-var@}* [&optional @{var | (pseudo-var [initform [pseudo-var]])@}*] @{[@{&rest | &body@} pseudo-var] [&key @{var | (@{var | (keyword pseudo-var)@} [initform [pseudo-var]])@}* [ &allow-other-keys ] ] [&aux @{var | (pseudo-var [initform])@}*] | . var@}) As a special case, a non-NIL symbol is accepcted as a defmacro-lambda-list: (DEFMACRO ...) is equivalent to (DEFMACRO (&REST ) ...). The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). See the type doc of LIST for the backquote macro useful for defining macros. Also, see the function doc of PPRINT for the output-formatting. @end deffn @defvar *EVALHOOK* Package:LISP If *EVALHOOK* is not NIL, its value must be a function that can receive two arguments: a form to evaluate and an environment. This function does the evaluation instead of EVAL. @end defvar @defun FUNCTIONP (x) Package:LISP Returns T if X is a function, suitable for use by FUNCALL or APPLY. Returns NIL otherwise. @end defun @defvr {Constant} LAMBDA-PARAMETERS-LIMIT Package:LISP The exclusive upper bound on the number of distinct parameter names that may appear in a single lambda-list. Actually, however, there is no such upper bound in GCL. @end defvr @deffn {Special Form} FLET Package:LISP Syntax: @example (flet (@{(name lambda-list @{decl | doc@}* @{form@}*)@}*) . body) @end example Evaluates BODY as a PROGN, with local function definitions in effect. BODY is the scope of each local function definition. Since the scope does not include the function definitions themselves, the local function can reference externally defined functions of the same name. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored. @end deffn @deffn {Macro} ECASE Package:LISP Syntax: @example (ecase keyform @{(@{key | (@{key@}*)@} @{form@}*)@}*) @end example Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals an error. @end deffn @deffn {Special Form} PROG2 Package:LISP Syntax: @example (prog2 first second @{forms@}*) @end example Evaluates FIRST, SECOND, and FORMs in order, and returns the (single) value of SECOND. @end deffn @deffn {Special Form} PROGV Package:LISP Syntax: @example (progv symbols values @{form@}*) @end example SYMBOLS must evaluate to a list of variables. VALUES must evaluate to a list of initial values. Evaluates FORMs as a PROGN, with each variable bound (as special) to the corresponding value. @end deffn @deffn {Special Form} QUOTE Package:LISP Syntax: @example (quote x) @end example or 'x Simply returns X without evaluating it. @end deffn @deffn {Special Form} DOTIMES Package:LISP Syntax: @example (dotimes (var countform [result]) @{decl@}* @{tag | statement@}*) @end example Executes STATEMENTs, with VAR bound to each number between 0 (inclusive) and the value of COUNTFORM (exclusive). Then returns the value(s) of RESULT (which defaults to NIL). @end deffn @defun SPECIAL-FORM-P (symbol) Package:LISP Returns T if SYMBOL globally names a special form; NIL otherwise. The special forms defined in Steele's manual are: @example block if progv catch labels quote compiler-let let return-from declare let* setq eval-when macrolet tagbody flet multiple-value-call the function multiple-value-prog1 throw go progn unwind-protect @end example In addition, GCL implements the following macros as special forms, though of course macro-expanding functions such as MACROEXPAND work correctly for these macros. @example and incf prog1 case locally prog2 cond loop psetq decf multiple-value-bind push defmacro multiple-value-list return defun multiple-value-set setf do or unless do* pop when dolist prog dotimes prog* @end example @end defun @deffn {Special Form} FUNCTION Package:LISP Syntax: @example (function x) @end example or #'x If X is a lambda expression, creates and returns a lexical closure of X in the current lexical environment. If X is a symbol that names a function, returns that function. @end deffn @defvr {Constant} MULTIPLE-VALUES-LIMIT Package:LISP The exclusive upper bound on the number of values that may be returned from a function. Actually, however, there is no such upper bound in GCL. @end defvr @defun APPLYHOOK (function args evalhookfn applyhookfn &optional (env nil)) Package:LISP Applies FUNCTION to ARGS, with *EVALHOOK* bound to EVALHOOKFN and with *APPLYHOOK* bound to APPLYHOOKFN. Ignores the hook function once, for the top-level application of FUNCTION to ARGS. @end defun @defvar *MACROEXPAND-HOOK* Package:LISP Holds a function that can take two arguments (a macro expansion function and the macro form to be expanded) and returns the expanded form. This function is whenever a macro-expansion takes place. Initially this is set to #'FUNCALL. @end defvar @deffn {Special Form} PROG* Package:LISP Syntax: @example (prog* (@{var | (var [init])@}*) @{decl@}* @{tag | statement@}*) @end example Creates a NIL block, binds VARs sequentially, and then executes STATEMENTs. @end deffn @deffn {Special Form} BLOCK Package:LISP Syntax: @example (block name @{form@}*) @end example The FORMs are evaluated in order, but it is possible to exit the block using (RETURN-FROM name value). The RETURN-FROM must be lexically contained within the block. @end deffn @deffn {Special Form} PROGN Package:LISP Syntax: @example (progn @{form@}*) @end example Evaluates FORMs in order, and returns whatever the last FORM returns. @end deffn @defun APPLY (function arg &rest more-args) Package:LISP Applies FUNCTION. The arguments to the function consist of all ARGs except for the last, and all elements of the last ARG. @end defun @deffn {Special Form} LABELS Package:LISP Syntax: @example (labels (@{(name lambda-list @{decl | doc@}* @{form@}*)@}*) . body) @end example Evaluates BODY as a PROGN, with the local function definitions in effect. The scope of the locally defined functions include the function definitions themselves, so their definitions may include recursive references. See the doc of DEFUN for the complete syntax of a lambda-list. Doc-strings for local functions are simply ignored. @end deffn @deffn {Special Form} RETURN Package:LISP Syntax: @example (return [result]) @end example Returns from the lexically surrounding NIL block. The value of RESULT, which defaults to NIL, is returned as the value of the block. @end deffn @deffn {Macro} TYPECASE Package:LISP Syntax: @example (typecase keyform @{(type @{form@}*)@}*) @end example Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value of the last FORM. If not, simply returns NIL. @end deffn @deffn {Special Form} AND Package:LISP Syntax: @example (and @{form@}*) @end example Evaluates FORMs in order from left to right. If any FORM evaluates to NIL, returns immediately with the value NIL. Else, returns the value(s) of the last FORM. @end deffn @deffn {Special Form} LET Package:LISP Syntax: @example (let (@{var | (var [value])@}*) @{decl@}* @{form@}*) @end example Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) all at once, then evaluates FORMs as a PROGN. @end deffn @deffn {Special Form} COND Package:LISP Syntax: @example (cond @{(test @{form@}*)@}*) @end example Evaluates each TEST in order until one evaluates to a non-NIL value. Then evaluates the associated FORMs in order and returns the value(s) of the last FORM. If no forms follow the TEST, then returns the value of the TEST. Returns NIL, if all TESTs evaluate to NIL. @end deffn @defun GET-SETF-METHOD-MULTIPLE-VALUE (form) Package:LISP Returns the five values (or five 'gangs') constituting the SETF method for FORM. See the doc of DEFINE-SETF-METHOD for the meanings of the gangs. The third value (i.e., the list of store variables) may consist of any number of elements. See the doc of GET-SETF-METHOD for comparison. @end defun @deffn {Special Form} CATCH Package:LISP Syntax: @example (catch tag @{form@}*) @end example Sets up a catcher with that value TAG. Then evaluates FORMs as a PROGN, but may possibly abort the evaluation by a THROW form that specifies the value EQ to the catcher tag. @end deffn @deffn {Macro} DEFINE-MODIFY-MACRO Package:LISP Syntax: @example (define-modify-macro name lambda-list fun [doc]) @end example Defines a read-modify-write macro, like PUSH and INCF. The defined macro will expand a form (NAME place val1 ... valn) into a form that in effect SETFs the value of the call (FUN PLACE arg1 ... argm) into PLACE, where arg1 ... argm are parameters in LAMBDA-LIST which are bound to the forms VAL1 ... VALn. The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function). @end deffn @defun MACROEXPAND-1 (form &optional (env nil)) Package:LISP If FORM is a macro form, then expands it once. Returns two values: the expanded form and a T-or-NIL flag indicating whether the original form was a macro. @end defun @defun FUNCALL (function &rest arguments) Package:LISP Applies FUNCTION to the ARGUMENTs @end defun @defvr {Constant} CALL-ARGUMENTS-LIMIT Package:LISP The upper exclusive bound on the number of arguments that may be passed to a function. Actually, however, there is no such upper bound in GCL. @end defvr @deffn {Special Form} CASE Package:LISP Syntax: @example (case keyform @{(@{key | (@{key@}*)@} @{form@}*)@}*) @end example Evaluates KEYFORM and tries to find the KEY that is EQL to the value of KEYFORM. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, simply returns NIL. @end deffn @deffn {Macro} DEFINE-SETF-METHOD Package:LISP Syntax: @example (define-setf-method access-fun defmacro-lambda-list @{decl | doc@}* @{form@}*) @end example Defines how to SETF a generalized-variable reference of the form (ACCESS-FUN ...). When a form (setf (ACCESS-FUN arg1 ... argn) value) is being evaluated, the FORMs are first evaluated as a PROGN with the parameters in DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. Assuming that the last FORM returns five values (temp-var-1 ... temp-var-k) (value-from-1 ... value-form-k) (store-var) storing-form access-form in order, the whole SETF is then expanded into (let* ((temp-var-1 value-from-1) ... (temp-k value-form-k) (store-var VALUE)) storing-from) Incidentally, the five values are called the five gangs of a SETF method. The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved by (documentation 'NAME 'setf). @end deffn @deffn {Special Form} COMPILER-LET Package:LISP Syntax: @example (compiler-let (@{var | (var [value])@}*) @{form@}*) @end example When interpreted, this form works just like a LET form with all VARs declared special. When compiled, FORMs are processed with the VARs bound at compile time, but no bindings occur when the compiled code is executed. @end deffn @defun VALUES (&rest args) Package:LISP Returns ARGs in order, as values. @end defun @deffn {Special Form} MULTIPLE-VALUE-LIST Package:LISP Syntax: @example (multiple-value-list form) @end example Evaluates FORM, and returns a list of multiple values it returned. @end deffn @deffn {Special Form} MULTIPLE-VALUE-PROG1 Package:LISP Syntax: @example (multiple-value-prog1 form @{form@}*) @end example Evaluates the first FORM, saves all the values produced, then evaluates the other FORMs. Returns the saved values. @end deffn @deffn {Special Form} MACROLET Package:LISP Syntax: @example (macrolet (@{(name defmacro-lambda-list @{decl | doc@}* . body)@}*) @{form@}*) @end example Evaluates FORMs as a PROGN, with the local macro definitions in effect. See the doc of DEFMACRO for the complete syntax of a defmacro-lambda-list. Doc-strings for local macros are simply ignored. @end deffn @deffn {Special Form} GO Package:LISP Syntax: @example (go tag) @end example Jumps to the specified TAG established by a lexically surrounding TAGBODY. @end deffn @deffn {Special Form} PROG Package:LISP Syntax: @example (prog (@{var | (var [init])@}*) @{decl@}* @{tag | statement@}*) @end example Creates a NIL block, binds VARs in parallel, and then executes STATEMENTs. @end deffn @defvar *APPLYHOOK* Package:LISP Used to substitute another function for the implicit APPLY normally done within EVAL. If *APPLYHOOK* is not NIL, its value must be a function which takes three arguments: a function to be applied, a list of arguments, and an environment. This function does the application instead of APPLY. @end defvar @deffn {Special Form} RETURN-FROM Package:LISP Syntax: @example (return-from name [result]) @end example Returns from the lexically surrounding block whose name is NAME. The value of RESULT, which defaults to NIL, is returned as the value of the block. @end deffn @deffn {Special Form} UNLESS Package:LISP Syntax: @example (unless test @{form@}*) @end example If TEST evaluates to NIL, then evaluates FORMs as a PROGN. If not, simply returns NIL. @end deffn @deffn {Special Form} MULTIPLE-VALUE-SETQ Package:LISP Syntax: @example (multiple-value-setq variables form) @end example Sets each variable in the list VARIABLES to the corresponding value of FORM. Returns the value assigned to the first variable. @end deffn @deffn {Special Form} LOCALLY Package:LISP Syntax: @example (locally @{decl@}* @{form@}*) @end example Gives local pervasive declarations. @end deffn @defun IDENTITY (x) Package:LISP Simply returns X. @end defun @defun NOT (x) Package:LISP Returns T if X is NIL; NIL otherwise. @end defun @deffn {Macro} DEFCONSTANT Package:LISP Syntax: @example (defconstant name initial-value [doc]) @end example Declares that the variable NAME is a constant whose value is the value of INITIAL-VALUE. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable). @end deffn @defun VALUES-LIST (list) Package:LISP Returns all of the elements of LIST in order, as values. @end defun @defun ERROR (control-string &rest args) Package:LISP Signals a fatal error. @end defun @deffn {Special Form} IF Package:LISP Syntax: @example (if test then [else]) @end example If TEST evaluates to non-NIL, then evaluates THEN and returns the result. If not, evaluates ELSE (which defaults to NIL) and returns the result. @end deffn @deffn {Special Form} UNWIND-PROTECT Package:LISP Syntax: @example (unwind-protect protected-form @{cleanup-form@}*) @end example Evaluates PROTECTED-FORM and returns whatever it returned. Guarantees that CLEANUP-FORMs be always evaluated before exiting from the UNWIND-PROTECT form. @end deffn @defun EVALHOOK (form evalhookfn applyhookfn &optional (env nil)) Package:LISP Evaluates FORM with *EVALHOOK* bound to EVALHOOKFN and *APPLYHOOK* bound to APPLYHOOKFN. Ignores these hooks once, for the top-level evaluation of FORM. @end defun @deffn {Special Form} OR Package:LISP Syntax: @example (or @{form@}*) @end example Evaluates FORMs in order from left to right. If any FORM evaluates to non-NIL, quits and returns that (single) value. If the last FORM is reached, returns whatever values it returns. @end deffn @deffn {Macro} CTYPECASE Package:LISP Syntax: @example (ctypecase keyplace @{(type @{form@}*)@}*) @end example Evaluates KEYPLACE and tries to find the TYPE in which the value of KEYPLACE belongs. If one is found, then evaluates FORMs that follow the KEY and returns the value(s) of the last FORM. If not, signals a correctable error. @end deffn @defun EVAL (exp) Package:LISP Evaluates EXP and returns the result(s). @end defun @deffn {Macro} PSETF Package:LISP Syntax: @example (psetf @{place newvalue@}*) @end example Similar to SETF, but evaluates all NEWVALUEs first, and then replaces the value in each PLACE with the value of the corresponding NEWVALUE. Returns NIL always. @end deffn @deffn {Special Form} THROW Package:LISP Syntax: @example (throw tag result) @end example Evaluates TAG and aborts the execution of the most recent CATCH form that sets up a catcher with the same tag value. The CATCH form returns whatever RESULT returned. @end deffn @deffn {Macro} DEFPARAMETER Package:LISP Syntax: @example (defparameter name initial-value [doc]) @end example Declares the variable NAME as a special variable and initializes the value. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable). @end deffn @deffn {Macro} DEFVAR Package:LISP Syntax: @example (defvar name [initial-value [doc]]) @end example Declares the variable NAME as a special variable and, optionally, initializes it. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable). @end deffn gcl-2.6.14/info/number.texi0000755000175000017500000005311314360276512014117 0ustar cammcamm@node Numbers, Sequences and Arrays and Hash Tables, Top, Top @chapter Numbers @defun SIGNUM (number) Package:LISP If NUMBER is zero, returns NUMBER; else returns (/ NUMBER (ABS NUMBER)). @end defun @defun LOGNOT (integer) Package:LISP Returns the bit-wise logical NOT of INTEGER. @end defun @defvr {Constant} MOST-POSITIVE-SHORT-FLOAT Package:LISP The short-float closest in value to positive infinity. @end defvr @defun INTEGER-DECODE-FLOAT (float) Package:LISP Returns, as three values, the integer interpretation of significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) F is a non-negative integer, E is an integer, and S is either 1 or -1. @end defun @defun MINUSP (number) Package:LISP Returns T if NUMBER < 0; NIL otherwise. @end defun @defun LOGORC1 (integer1 integer2) Package:LISP Returns the logical OR of (LOGNOT INTEGER1) and INTEGER2. @end defun @defvr {Constant} MOST-NEGATIVE-SINGLE-FLOAT Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT. @end defvr @defvr {Constant} BOOLE-C1 Package:LISP Makes BOOLE return the complement of INTEGER1. @end defvr @defvr {Constant} LEAST-POSITIVE-SHORT-FLOAT Package:LISP The positive short-float closest in value to zero. @end defvr @defun BIT-NAND (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NAND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun INT-CHAR (integer) Package:LISP Performs the inverse of CHAR-INT. Equivalent to CODE-CHAR in GCL. @end defun @defun CHAR-INT (char) Package:LISP Returns the font, bits, and code attributes as a single non-negative integer. Equivalent to CHAR-CODE in GCL. @end defun @defvr {Constant} LEAST-NEGATIVE-SINGLE-FLOAT Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT. @end defvr @defun /= (number &rest more-numbers) Package:LISP Returns T if no two of its arguments are numerically equal; NIL otherwise. @end defun @defun LDB-TEST (bytespec integer) Package:LISP Returns T if at least one of the bits in the specified bytes of INTEGER is 1; NIL otherwise. @end defun @defvr {Constant} CHAR-CODE-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-CODE. @end defvr @defun RATIONAL (number) Package:LISP Converts NUMBER into rational accurately and returns it. @end defun @defvr {Constant} PI Package:LISP The floating-point number that is appropriately equal to the ratio of the circumference of the circle to the diameter. @end defvr @defun SIN (radians) Package:LISP Returns the sine of RADIANS. @end defun @defvr {Constant} BOOLE-ORC2 Package:LISP Makes BOOLE return LOGORC2 of INTEGER1 and INTEGER2. @end defvr @defun NUMERATOR (rational) Package:LISP Returns as an integer the numerator of the given rational number. @end defun @defun MASK-FIELD (bytespec integer) Package:LISP Extracts the specified byte from INTEGER. @end defun @deffn {Special Form} INCF Package:LISP Syntax: @example (incf place [delta]) @end example Adds the number produced by DELTA (which defaults to 1) to the number in PLACE. @end deffn @defun SINH (number) Package:LISP Returns the hyperbolic sine of NUMBER. @end defun @defun PHASE (number) Package:LISP Returns the angle part of the polar representation of a complex number. For non-complex numbers, this is 0. @end defun @defun BOOLE (op integer1 integer2) Package:LISP Returns an integer produced by performing the logical operation specified by OP on the two integers. OP must be the value of one of the following constants: BOOLE-CLR BOOLE-C1 BOOLE-XOR BOOLE-ANDC1 BOOLE-SET BOOLE-C2 BOOLE-EQV BOOLE-ANDC2 BOOLE-1 BOOLE-AND BOOLE-NAND BOOLE-ORC1 BOOLE-2 BOOLE-IOR BOOLE-NOR BOOLE-ORC2 See the variable docs of these constants for their operations. @end defun @defvr {Constant} SHORT-FLOAT-EPSILON Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))). @end defvr @defun LOGORC2 (integer1 integer2) Package:LISP Returns the logical OR of INTEGER1 and (LOGNOT INTEGER2). @end defun @defvr {Constant} BOOLE-C2 Package:LISP Makes BOOLE return the complement of INTEGER2. @end defvr @defun REALPART (number) Package:LISP Extracts the real part of NUMBER. @end defun @defvr {Constant} BOOLE-CLR Package:LISP Makes BOOLE return 0. @end defvr @defvr {Constant} BOOLE-IOR Package:LISP Makes BOOLE return LOGIOR of INTEGER1 and INTEGER2. @end defvr @defun FTRUNCATE (number &optional (divisor 1)) Package:LISP Values: (quotient remainder) Same as TRUNCATE, but returns first value as a float. @end defun @defun EQL (x y) Package:LISP Returns T if X and Y are EQ, or if they are numbers of the same type with the same value, or if they are character objects that represent the same character. Returns NIL otherwise. @end defun @defun LOG (number &optional base) Package:LISP Returns the logarithm of NUMBER in the base BASE. BASE defaults to the base of natural logarithms. @end defun @defvr {Constant} DOUBLE-FLOAT-NEGATIVE-EPSILON Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON. @end defvr @defun LOGIOR (&rest integers) Package:LISP Returns the bit-wise INCLUSIVE OR of its arguments. @end defun @defvr {Constant} MOST-NEGATIVE-DOUBLE-FLOAT Package:LISP Same as MOST-NEGATIVE-LONG-FLOAT. @end defvr @defun / (number &rest more-numbers) Package:LISP Divides the first NUMBER by each of the subsequent NUMBERS. With one arg, returns the reciprocal of the number. @end defun @defvar *RANDOM-STATE* Package:LISP The default random-state object used by RAMDOM. @end defvar @defun 1+ (number) Package:LISP Returns NUMBER + 1. @end defun @defvr {Constant} LEAST-NEGATIVE-DOUBLE-FLOAT Package:LISP Same as LEAST-NEGATIVE-LONG-FLOAT. @end defvr @defun FCEILING (number &optional (divisor 1)) Package:LISP Same as CEILING, but returns a float as the first value. @end defun @defvr {Constant} MOST-POSITIVE-FIXNUM Package:LISP The fixnum closest in value to positive infinity. @end defvr @defun BIT-ANDC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ANDC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun TAN (radians) Package:LISP Returns the tangent of RADIANS. @end defun @defvr {Constant} BOOLE-NAND Package:LISP Makes BOOLE return LOGNAND of INTEGER1 and INTEGER2. @end defvr @defun TANH (number) Package:LISP Returns the hyperbolic tangent of NUMBER. @end defun @defun ASIN (number) Package:LISP Returns the arc sine of NUMBER. @end defun @defun BYTE (size position) Package:LISP Returns a byte specifier. In GCL, a byte specifier is represented by a dotted pair ( . ). @end defun @defun ASINH (number) Package:LISP Returns the hyperbolic arc sine of NUMBER. @end defun @defvr {Constant} MOST-POSITIVE-LONG-FLOAT Package:LISP The long-float closest in value to positive infinity. @end defvr @deffn {Macro} SHIFTF Package:LISP Syntax: @example (shiftf @{place@}+ newvalue) @end example Evaluates all PLACEs and NEWVALUE in turn, then assigns the value of each form to the PLACE on its left. Returns the original value of the leftmost form. @end deffn @defvr {Constant} LEAST-POSITIVE-LONG-FLOAT Package:LISP The positive long-float closest in value to zero. @end defvr @defun DEPOSIT-FIELD (newbyte bytespec integer) Package:LISP Returns an integer computed by replacing the specified byte of INTEGER with the specified byte of NEWBYTE. @end defun @defun BIT-AND (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical AND on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun LOGNAND (integer1 integer2) Package:LISP Returns the complement of the logical AND of INTEGER1 and INTEGER2. @end defun @defun BYTE-POSITION (bytespec) Package:LISP Returns the position part (in GCL, the cdr part) of the byte specifier. @end defun @deffn {Macro} ROTATEF Package:LISP Syntax: @example (rotatef @{place@}*) @end example Evaluates PLACEs in turn, then assigns to each PLACE the value of the form to its right. The rightmost PLACE gets the value of the leftmost PLACE. Returns NIL always. @end deffn @defun BIT-ANDC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical ANDC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun TRUNCATE (number &optional (divisor 1)) Package:LISP Values: (quotient remainder) Returns NUMBER/DIVISOR as an integer, rounded toward 0. The second returned value is the remainder. @end defun @defvr {Constant} BOOLE-EQV Package:LISP Makes BOOLE return LOGEQV of INTEGER1 and INTEGER2. @end defvr @defvr {Constant} BOOLE-SET Package:LISP Makes BOOLE return -1. @end defvr @defun LDB (bytespec integer) Package:LISP Extracts and right-justifies the specified byte of INTEGER, and returns the result. @end defun @defun BYTE-SIZE (bytespec) Package:LISP Returns the size part (in GCL, the car part) of the byte specifier. @end defun @defvr {Constant} SHORT-FLOAT-NEGATIVE-EPSILON Package:LISP The smallest positive short-float that satisfies (not (= (float 1 e) (- (float 1 e) e))). @end defvr @defun REM (number divisor) Package:LISP Returns the second value of (TRUNCATE NUMBER DIVISOR). @end defun @defun MIN (number &rest more-numbers) Package:LISP Returns the least of its arguments. @end defun @defun EXP (number) Package:LISP Calculates e raised to the power NUMBER, where e is the base of natural logarithms. @end defun @defun DECODE-FLOAT (float) Package:LISP Returns, as three values, the significand F, the exponent E, and the sign S of the given float, so that E FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) S and F are floating-point numbers of the same float format as FLOAT, and E is an integer. @end defun @defvr {Constant} LONG-FLOAT-EPSILON Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (+ (float 1 e) e))). @end defvr @defun FROUND (number &optional (divisor 1)) Package:LISP Same as ROUND, but returns first value as a float. @end defun @defun LOGEQV (&rest integers) Package:LISP Returns the bit-wise EQUIVALENCE of its arguments. @end defun @defvr {Constant} MOST-NEGATIVE-SHORT-FLOAT Package:LISP The short-float closest in value to negative infinity. @end defvr @defun BIT-NOR (bit-array1 bit-array2 &optional (result-bit-array nil)) Package:LISP Performs a bit-wise logical NOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. @end defun @defun CEILING (number &optional (divisor 1)) Package:LISP Returns the smallest integer not less than or NUMBER/DIVISOR. Returns the remainder as the second value. @end defun @defvr {Constant} LEAST-NEGATIVE-SHORT-FLOAT Package:LISP The negative short-float closest in value to zero. @end defvr @defun 1- (number) Package:LISP Returns NUMBER - 1. @end defun @defun <= (number &rest more-numbers) Package:LISP Returns T if arguments are in strictly non-decreasing order; NIL otherwise. @end defun @defun IMAGPART (number) Package:LISP Extracts the imaginary part of NUMBER. @end defun @defun INTEGERP (x) Package:LISP Returns T if X is an integer (fixnum or bignum); NIL otherwise. @end defun @defun ASH (integer count) Package:LISP Shifts INTEGER left by COUNT places. Shifts right if COUNT is negative. @end defun @defun LCM (integer &rest more-integers) Package:LISP Returns the least common multiple of the arguments. @end defun @defun COS (radians) Package:LISP Returns the cosine of RADIANS. @end defun @deffn {Special Form} DECF Package:LISP Syntax: @example (decf place [delta]) @end example Subtracts the number produced by DELTA (which defaults to 1) from the number in PLACE. @end deffn @defun ATAN (x &optional (y 1)) Package:LISP Returns the arc tangent of X/Y. @end defun @defvr {Constant} BOOLE-ANDC1 Package:LISP Makes BOOLE return LOGANDC1 of INTEGER1 and INTEGER2. @end defvr @defun COSH (number) Package:LISP Returns the hyperbolic cosine of NUMBER. @end defun @defun FLOAT-RADIX (float) Package:LISP Returns the representation radix (or base) of the floating-point number. @end defun @defun ATANH (number) Package:LISP Returns the hyperbolic arc tangent of NUMBER. @end defun @defun EVENP (integer) Package:LISP Returns T if INTEGER is even. Returns NIL if INTEGER is odd. @end defun @defun ZEROP (number) Package:LISP Returns T if NUMBER = 0; NIL otherwise. @end defun @defun FLOATP (x) Package:LISP Returns T if X is a floating-point number; NIL otherwise. @end defun @defun SXHASH (object) Package:LISP Computes a hash code for OBJECT and returns it as an integer. @end defun @defvr {Constant} BOOLE-1 Package:LISP Makes BOOLE return INTEGER1. @end defvr @defvr {Constant} MOST-POSITIVE-SINGLE-FLOAT Package:LISP Same as MOST-POSITIVE-LONG-FLOAT. @end defvr @defun LOGANDC1 (integer1 integer2) Package:LISP Returns the logical AND of (LOGNOT INTEGER1) and INTEGER2. @end defun @defvr {Constant} LEAST-POSITIVE-SINGLE-FLOAT Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT. @end defvr @defun COMPLEXP (x) Package:LISP Returns T if X is a complex number; NIL otherwise. @end defun @defvr {Constant} BOOLE-AND Package:LISP Makes BOOLE return LOGAND of INTEGER1 and INTEGER2. @end defvr @defun MAX (number &rest more-numbers) Package:LISP Returns the greatest of its arguments. @end defun @defun FLOAT-SIGN (float1 &optional (float2 (float 1 float1))) Package:LISP Returns a floating-point number with the same sign as FLOAT1 and with the same absolute value as FLOAT2. @end defun @defvr {Constant} BOOLE-ANDC2 Package:LISP Makes BOOLE return LOGANDC2 of INTEGER1 and INTEGER2. @end defvr @defun DENOMINATOR (rational) Package:LISP Returns the denominator of RATIONAL as an integer. @end defun @defun FLOAT (number &optional other) Package:LISP Converts a non-complex number to a floating-point number. If NUMBER is already a float, FLOAT simply returns NUMBER. Otherwise, the format of the returned float depends on OTHER; If OTHER is not provided, FLOAT returns a SINGLE-FLOAT. If OTHER is provided, the result is in the same float format as OTHER's. @end defun @defun ROUND (number &optional (divisor 1)) Package:LISP Rounds NUMBER/DIVISOR to nearest integer. The second returned value is the remainder. @end defun @defun LOGAND (&rest integers) Package:LISP Returns the bit-wise AND of its arguments. @end defun @defvr {Constant} BOOLE-2 Package:LISP Makes BOOLE return INTEGER2. @end defvr @defun * (&rest numbers) Package:LISP Returns the product of its arguments. With no args, returns 1. @end defun @defun < (number &rest more-numbers) Package:LISP Returns T if its arguments are in strictly increasing order; NIL otherwise. @end defun @defun COMPLEX (realpart &optional (imagpart 0)) Package:LISP Returns a complex number with the given real and imaginary parts. @end defun @defvr {Constant} SINGLE-FLOAT-EPSILON Package:LISP Same as LONG-FLOAT-EPSILON. @end defvr @defun LOGANDC2 (integer1 integer2) Package:LISP Returns the logical AND of INTEGER1 and (LOGNOT INTEGER2). @end defun @defun INTEGER-LENGTH (integer) Package:LISP Returns the number of significant bits in the absolute value of INTEGER. @end defun @defvr {Constant} MOST-NEGATIVE-FIXNUM Package:LISP The fixnum closest in value to negative infinity. @end defvr @defvr {Constant} LONG-FLOAT-NEGATIVE-EPSILON Package:LISP The smallest positive long-float that satisfies (not (= (float 1 e) (- (float 1 e) e))). @end defvr @defun >= (number &rest more-numbers) Package:LISP Returns T if arguments are in strictly non-increasing order; NIL otherwise. @end defun @defvr {Constant} BOOLE-NOR Package:LISP Makes BOOLE return LOGNOR of INTEGER1 and INTEGER2. @end defvr @defun ACOS (number) Package:LISP Returns the arc cosine of NUMBER. @end defun @defun MAKE-RANDOM-STATE (&optional (state *random-state*)) Package:LISP Creates and returns a copy of the specified random state. If STATE is NIL, then the value of *RANDOM-STATE* is used. If STATE is T, then returns a random state object generated from the universal time. @end defun @defun EXPT (base-number power-number) Package:LISP Returns BASE-NUMBER raised to the power POWER-NUMBER. @end defun @defun SQRT (number) Package:LISP Returns the principal square root of NUMBER. @end defun @defun SCALE-FLOAT (float integer) Package:LISP Returns (* FLOAT (expt (float-radix FLOAT) INTEGER)). @end defun @defun ACOSH (number) Package:LISP Returns the hyperbolic arc cosine of NUMBER. @end defun @defvr {Constant} MOST-NEGATIVE-LONG-FLOAT Package:LISP The long-float closest in value to negative infinity. @end defvr @defvr {Constant} LEAST-NEGATIVE-LONG-FLOAT Package:LISP The negative long-float closest in value to zero. @end defvr @defun FFLOOR (number &optional (divisor 1)) Package:LISP Same as FLOOR, but returns a float as the first value. @end defun @defun LOGNOR (integer1 integer2) Package:LISP Returns the complement of the logical OR of INTEGER1 and INTEGER2. @end defun @defun PARSE-INTEGER (string &key (start 0) (end (length string)) (radix 10) (junk-allowed nil)) Package:LISP Parses STRING for an integer and returns it. @end defun @defun + (&rest numbers) Package:LISP Returns the sum of its arguments. With no args, returns 0. @end defun @defun = (number &rest more-numbers) Package:LISP Returns T if all of its arguments are numerically equal; NIL otherwise. @end defun @defun NUMBERP (x) Package:LISP Returns T if X is any kind of number; NIL otherwise. @end defun @defvr {Constant} MOST-POSITIVE-DOUBLE-FLOAT Package:LISP Same as MOST-POSITIVE-LONG-FLOAT. @end defvr @defun LOGTEST (integer1 integer2) Package:LISP Returns T if LOGAND of INTEGER1 and INTEGER2 is not zero; NIL otherwise. @end defun @defun RANDOM-STATE-P (x) Package:LISP Returns T if X is a random-state object; NIL otherwise. @end defun @defvr {Constant} LEAST-POSITIVE-DOUBLE-FLOAT Package:LISP Same as LEAST-POSITIVE-LONG-FLOAT. @end defvr @defun FLOAT-PRECISION (float) Package:LISP Returns the number of significant radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). @end defun @defvr {Constant} BOOLE-XOR Package:LISP Makes BOOLE return LOGXOR of INTEGER1 and INTEGER2. @end defvr @defun DPB (newbyte bytespec integer) Package:LISP Returns an integer computed by replacing the specified byte of INTEGER with NEWBYTE. @end defun @defun ABS (number) Package:LISP Returns the absolute value of NUMBER. @end defun @defun CONJUGATE (number) Package:LISP Returns the complex conjugate of NUMBER. @end defun @defun CIS (radians) Package:LISP Returns e raised to i*RADIANS. @end defun @defun ODDP (integer) Package:LISP Returns T if INTEGER is odd; NIL otherwise. @end defun @defun RATIONALIZE (number) Package:LISP Converts NUMBER into rational approximately and returns it. @end defun @defun ISQRT (integer) Package:LISP Returns the greatest integer less than or equal to the square root of the given non-negative integer. @end defun @defun LOGXOR (&rest integers) Package:LISP Returns the bit-wise EXCLUSIVE OR of its arguments. @end defun @defun > (number &rest more-numbers) Package:LISP Returns T if its arguments are in strictly decreasing order; NIL otherwise. @end defun @defun LOGBITP (index integer) Package:LISP Returns T if the INDEX-th bit of INTEGER is 1. @end defun @defvr {Constant} DOUBLE-FLOAT-EPSILON Package:LISP Same as LONG-FLOAT-EPSILON. @end defvr @defun LOGCOUNT (integer) Package:LISP If INTEGER is negative, returns the number of 0 bits. Otherwise, returns the number of 1 bits. @end defun @defun GCD (&rest integers) Package:LISP Returns the greatest common divisor of INTEGERs. @end defun @defun RATIONALP (x) Package:LISP Returns T if X is an integer or a ratio; NIL otherwise. @end defun @defun MOD (number divisor) Package:LISP Returns the second result of (FLOOR NUMBER DIVISOR). @end defun @defun MODF (number) Package:SYSTEM Returns the integer and fractional part of a floating point number mod 1.0. @end defun @defvr {Constant} BOOLE-ORC1 Package:LISP Makes BOOLE return LOGORC1 of INTEGER1 and INTEGER2. @end defvr @defvr {Constant} SINGLE-FLOAT-NEGATIVE-EPSILON Package:LISP Same as LONG-FLOAT-NEGATIVE-EPSILON. @end defvr @defun FLOOR (number &optional (divisor 1)) Package:LISP Returns the largest integer not larger than the NUMBER divided by DIVISOR. The second returned value is (- NUMBER (* first-value DIVISOR)). @end defun @defun PLUSP (number) Package:LISP Returns T if NUMBER > 0; NIL otherwise. @end defun @defun FLOAT-DIGITS (float) Package:LISP Returns the number of radix-B digits used to represent the significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). @end defun @defun RANDOM (number &optional (state *random-state*)) Package:LISP Generates a uniformly distributed pseudo-random number between zero (inclusive) and NUMBER (exclusive), by using the random state object STATE. @end defun gcl-2.6.14/info/gcl.info-90000644000175000017500000054235614360276512013535 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: room, Next: ed, Prev: documentation, Up: Environment Dictionary 25.2.16 room [Function] ----------------------- 'room' &optional x => implementation-dependent Arguments and Values:: ...................... x--one of t, nil, or :default. Description:: ............. room prints, to standard output, information about the state of internal storage and its management. This might include descriptions of the amount of memory in use and the degree of memory compaction, possibly broken down by internal data type if that is appropriate. The nature and format of the printed information is implementation-dependent. The intent is to provide information that a programmer might use to tune a program for a particular implementation. (room nil) prints out a minimal amount of information. (room t) prints out a maximal amount of information. (room) or (room :default) prints out an intermediate amount of information that is likely to be useful. Side Effects:: .............. Output to standard output. Affected By:: ............. *standard-output*.  File: gcl.info, Node: ed, Next: inspect, Prev: room, Up: Environment Dictionary 25.2.17 ed [Function] --------------------- 'ed' &optional x => implementation-dependent Arguments and Values:: ...................... x--nil, a pathname, a string, or a function name. The default is nil. Description:: ............. ed invokes the editor if the implementation provides a resident editor. If x is nil, the editor is entered. If the editor had been previously entered, its prior state is resumed, if possible. If x is a pathname or string, it is taken as the pathname designator for a file to be edited. If x is a function name, the text of its definition is edited. The means by which the function text is obtained is implementation-defined. Exceptional Situations:: ........................ The consequences are undefined if the implementation does not provide a resident editor. Might signal type-error if its argument is supplied but is not a symbol, a pathname, or nil. If a failure occurs when performing some operation on the file system while attempting to edit a file, an error of type file-error is signaled. An error of type file-error might be signaled if x is a designator for a wild pathname. Implementation-dependent additional conditions might be signaled as well. See Also:: .......... pathname, logical-pathname, *note compile-file:: , *note load:: , *note Pathnames as Filenames::  File: gcl.info, Node: inspect, Next: dribble, Prev: ed, Up: Environment Dictionary 25.2.18 inspect [Function] -------------------------- 'inspect' object => implementation-dependent Arguments and Values:: ...................... object--an object. Description:: ............. inspect is an interactive version of describe. The nature of the interaction is implementation-dependent, but the purpose of inspect is to make it easy to wander through a data structure, examining and modifying parts of it. Side Effects:: .............. implementation-dependent. Affected By:: ............. implementation-dependent. Exceptional Situations:: ........................ implementation-dependent. See Also:: .......... *note describe:: Notes:: ....... Implementations are encouraged to respond to the typing of ? or a "help key" by providing help, including a list of commands.  File: gcl.info, Node: dribble, Next: - (Variable), Prev: inspect, Up: Environment Dictionary 25.2.19 dribble [Function] -------------------------- 'dribble' &optional pathname => implementation-dependent Arguments and Values:: ...................... pathname--a pathname designator. Description:: ............. Either binds *standard-input* and *standard-output* or takes other appropriate action, so as to send a record of the input/output interaction to a file named by pathname. dribble is intended to create a readable record of an interactive session. If pathname is a logical pathname, it is translated into a physical pathname as if by calling translate-logical-pathname. (dribble) terminates the recording of input and output and closes the dribble file. If dribble is called while a stream to a "dribble file" is still open from a previous call to dribble, the effect is implementation-defined. For example, the already-open stream might be closed, or dribbling might occur both to the old stream and to a new one, or the old stream might stay open but not receive any further output, or the new request might be ignored, or some other action might be taken. Affected By:: ............. The implementation. Exceptional Situations:: ........................ If a failure occurs when performing some operation on the file system while creating the dribble file, an error of type file-error is signaled. An error of type file-error might be signaled if pathname is a designator for a wild pathname. See Also:: .......... *note Pathnames as Filenames:: Notes:: ....... dribble can return before subsequent forms are executed. It also can enter a recursive interaction loop, returning only when (dribble) is done. dribble is intended primarily for interactive debugging; its effect cannot be relied upon when used in a program.  File: gcl.info, Node: - (Variable), Next: + (Variable), Prev: dribble, Up: Environment Dictionary 25.2.20 - [Variable] -------------------- Value Type:: ............ a form. Initial Value:: ............... implementation-dependent. Description:: ............. The value of - is the form that is currently being evaluated by the Lisp read-eval-print loop. Examples:: .......... (format t "~&Evaluating ~S~ |> Evaluating (FORMAT T "~&Evaluating ~S~ => NIL Affected By:: ............. Lisp read-eval-print loop. See Also:: .......... + (variable), * (variable), *note /:: (variable), *note Top level loop::  File: gcl.info, Node: + (Variable), Next: * (Variable), Prev: - (Variable), Up: Environment Dictionary 25.2.21 +, ++, +++ [Variable] ----------------------------- Value Type:: ............ an object. Initial Value:: ............... implementation-dependent. Description:: ............. The variables +, ++, and +++ are maintained by the Lisp read-eval-print loop to save forms that were recently evaluated. The value of + is the last form that was evaluated, the value of ++ is the previous value of +, and the value of +++ is the previous value of ++. Examples:: .......... (+ 0 1) => 1 (- 4 2) => 2 (/ 9 3) => 3 (list + ++ +++) => ((/ 9 3) (- 4 2) (+ 0 1)) (setq a 1 b 2 c 3 d (list a b c)) => (1 2 3) (setq a 4 b 5 c 6 d (list a b c)) => (4 5 6) (list a b c) => (4 5 6) (eval +++) => (1 2 3) #.`(,@++ d) => (1 2 3 (1 2 3)) Affected By:: ............. Lisp read-eval-print loop. See Also:: .......... *note -:: (variable), * (variable), *note /:: (variable), *note Top level loop::  File: gcl.info, Node: * (Variable), Next: / (Variable), Prev: + (Variable), Up: Environment Dictionary 25.2.22 *, **, *** [Variable] ----------------------------- Value Type:: ............ an object. Initial Value:: ............... implementation-dependent. Description:: ............. The variables *, **, and *** are maintained by the Lisp read-eval-print loop to save the values of results that are printed each time through the loop. The value of * is the most recent primary value that was printed, the value of ** is the previous value of *, and the value of *** is the previous value of **. If several values are produced, * contains the first value only; * contains nil if zero values are produced. The values of *, **, and *** are updated immediately prior to printing the return value of a top-level form by the Lisp read-eval-print loop. If the evaluation of such a form is aborted prior to its normal return, the values of *, **, and *** are not updated. Examples:: .......... (values 'a1 'a2) => A1, A2 'b => B (values 'c1 'c2 'c3) => C1, C2, C3 (list * ** ***) => (C1 B A1) (defun cube-root (x) (expt x 1/3)) => CUBE-ROOT (compile *) => CUBE-ROOT (setq a (cube-root 27.0)) => 3.0 (* * 9.0) => 27.0 Affected By:: ............. Lisp read-eval-print loop. See Also:: .......... *note -:: (variable), + (variable), *note /:: (variable), *note Top level loop:: Notes:: ....... * == (car /) ** == (car //) *** == (car ///)  File: gcl.info, Node: / (Variable), Next: lisp-implementation-type, Prev: * (Variable), Up: Environment Dictionary 25.2.23 /, //, /// [Variable] ----------------------------- Value Type:: ............ a proper list. Initial Value:: ............... implementation-dependent. Description:: ............. The variables /, //, and /// are maintained by the Lisp read-eval-print loop to save the values of results that were printed at the end of the loop. The value of / is a list of the most recent values that were printed, the value of // is the previous value of /, and the value of /// is the previous value of //. The values of /, //, and /// are updated immediately prior to printing the return value of a top-level form by the Lisp read-eval-print loop. If the evaluation of such a form is aborted prior to its normal return, the values of /, //, and /// are not updated. Examples:: .......... (floor 22 7) => 3, 1 (+ (* (car /) 7) (cadr /)) => 22 Affected By:: ............. Lisp read-eval-print loop. See Also:: .......... *note -:: (variable), + (variable), * (variable), *note Top level loop::  File: gcl.info, Node: lisp-implementation-type, Next: short-site-name, Prev: / (Variable), Up: Environment Dictionary 25.2.24 lisp-implementation-type, --------------------------------- lisp-implementation-version --------------------------- [Function] 'lisp-implementation-type' => description 'lisp-implementation-version' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. lisp-implementation-type and lisp-implementation-version identify the current implementation of Common Lisp. lisp-implementation-type returns a string that identifies the generic name of the particular Common Lisp implementation. lisp-implementation-version returns a string that identifies the version of the particular Common Lisp implementation. If no appropriate and relevant result can be produced, nil is returned instead of a string. Examples:: .......... (lisp-implementation-type) => "ACME Lisp" OR=> "Joe's Common Lisp" (lisp-implementation-version) => "1.3a" => "V2" OR=> "Release 17.3, ECO #6"  File: gcl.info, Node: short-site-name, Next: machine-instance, Prev: lisp-implementation-type, Up: Environment Dictionary 25.2.25 short-site-name, long-site-name [Function] -------------------------------------------------- 'short-site-name' => description 'long-site-name' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. short-site-name and long-site-name return a string that identifies the physical location of the computer hardware, or nil if no appropriate description can be produced. Examples:: .......... (short-site-name) => "MIT AI Lab" OR=> "CMU-CSD" (long-site-name) => "MIT Artificial Intelligence Laboratory" OR=> "CMU Computer Science Department" Affected By:: ............. The implementation, the location of the computer hardware, and the installation/configuration process.  File: gcl.info, Node: machine-instance, Next: machine-type, Prev: short-site-name, Up: Environment Dictionary 25.2.26 machine-instance [Function] ----------------------------------- 'machine-instance' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. Returns a string that identifies the particular instance of the computer hardware on which Common Lisp is running, or nil if no such string can be computed. Examples:: .......... (machine-instance) => "ACME.COM" OR=> "S/N 123231" OR=> "18.26.0.179" OR=> "AA-00-04-00-A7-A4" Affected By:: ............. The machine instance, and the implementation. See Also:: .......... *note machine-type:: , *note machine-version::  File: gcl.info, Node: machine-type, Next: machine-version, Prev: machine-instance, Up: Environment Dictionary 25.2.27 machine-type [Function] ------------------------------- 'machine-type' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. Returns a string that identifies the generic name of the computer hardware on which Common Lisp is running. Examples:: .......... (machine-type) => "DEC PDP-10" OR=> "Symbolics LM-2" Affected By:: ............. The machine type. The implementation. See Also:: .......... *note machine-version::  File: gcl.info, Node: machine-version, Next: software-type, Prev: machine-type, Up: Environment Dictionary 25.2.28 machine-version [Function] ---------------------------------- 'machine-version' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. Returns a string that identifies the version of the computer hardware on which Common Lisp is running, or nil if no such value can be computed. Examples:: .......... (machine-version) => "KL-10, microcode 9" Affected By:: ............. The machine version, and the implementation. See Also:: .......... *note machine-type:: , *note machine-instance::  File: gcl.info, Node: software-type, Next: user-homedir-pathname, Prev: machine-version, Up: Environment Dictionary 25.2.29 software-type, software-version [Function] -------------------------------------------------- 'software-type' => description 'software-version' => description Arguments and Values:: ...................... description--a string or nil. Description:: ............. software-type returns a string that identifies the generic name of any relevant supporting software, or nil if no appropriate or relevant result can be produced. software-version returns a string that identifies the version of any relevant supporting software, or nil if no appropriate or relevant result can be produced. Examples:: .......... (software-type) => "Multics" (software-version) => "1.3x" Affected By:: ............. Operating system environment. Notes:: ....... This information should be of use to maintainers of the implementation.  File: gcl.info, Node: user-homedir-pathname, Prev: software-type, Up: Environment Dictionary 25.2.30 user-homedir-pathname [Function] ---------------------------------------- 'user-homedir-pathname' &optional host => pathname Arguments and Values:: ...................... host--a string, a list of strings, or :unspecific. pathname--a pathname, or nil. Description:: ............. user-homedir-pathname determines the pathname that corresponds to the user's home directory on host. If host is not supplied, its value is implementation-dependent. For a description of :unspecific, see *note Pathname Components::. The definition of home directory is implementation-dependent, but defined in Common Lisp to mean the directory where the user keeps personal files such as initialization files and mail. user-homedir-pathname returns a pathname without any name, type, or version component (those components are all nil) for the user's home directory on host. If it is impossible to determine the user's home directory on host, then nil is returned. user-homedir-pathname never returns nil if host is not supplied. Examples:: .......... (pathnamep (user-homedir-pathname)) => true Affected By:: ............. The host computer's file system, and the implementation.  File: gcl.info, Node: Glossary (Glossary), Next: Appendix, Prev: Environment, Up: Top 26 Glossary *********** * Menu: * Glossary::  File: gcl.info, Node: Glossary, Prev: Glossary (Glossary), Up: Glossary (Glossary) 26.1 Glossary ============= Each entry in this glossary has the following parts: * the term being defined, set in boldface. * optional pronunciation, enclosed in square brackets and set in boldface, as in the following example: pronounced 'a ,list . The pronunciation key follows Webster's Third New International Dictionary the English Language, Unabridged, except that "e" is used to notate the schwa (upside-down "e") character. * the part or parts of speech, set in italics. If a term can be used as several parts of speech, there is a separate definition for each part of speech. * one or more definitions, organized as follows: - an optional number, present if there are several definitions. Lowercase letters might also be used in cases where subdefinitions of a numbered definition are necessary. - an optional part of speech, set in italics, present if the term is one of several parts of speech. - an optional discipline, set in italics, present if the term has a standard definition being repeated. For example, "Math." - an optional context, present if this definition is meaningful only in that context. For example, "(of a symbol)". - the definition. - an optional example sentence. For example, "This is an example of an example." - optional cross references. In addition, some terms have idiomatic usage in the Common Lisp community which is not shared by other communities, or which is not technically correct. Definitions labeled "Idiom." represent such idiomatic usage; these definitions are sometimes followed by an explanatory note. Words in this font are words with entries in the glossary. Words in example sentences do not follow this convention. When an ambiguity arises, the longest matching substring has precedence. For example, "complex float" refers to a single glossary entry for "complex float" rather than the combined meaning of the glossary terms "complex" and "float." Subscript notation, as in "something_n" means that the nth definition of "something" is intended. This notation is used only in situations where the context might be insufficient to disambiguate. The following are abbreviations used in the glossary: Abbreviation Meaning adj. adjective adv. adverb ANSI compatible with one or more ANSI standards Comp. computers Idiom. idiomatic IEEE compatible with one or more IEEE standards ISO compatible with one or more ISO standards Math. mathematics Trad. traditional n. noun v. verb v.t. transitive verb Non-alphabetic -------------- () pronounced 'nil , n. an alternative notation for writing the symbol~nil, used to emphasize the use of nil as an empty list. A - absolute adj. 1. (of a time) representing a specific point in time. 2. (of a pathname) representing a specific position in a directory hierarchy. See relative. access n., v.t. 1. v.t. (a place, or array) to read_1 or write_1 the value of the place or an element of the array. 2. n. (of a place) an attempt to access_1 the value of the place. accessibility n. the state of being accessible. accessible adj. 1. (of an object) capable of being referenced. 2. (of shared slots or local slots in an instance of a class) having been defined by the class of the instance or inherited from a superclass of that class. 3. (of a symbol in a package) capable of being referenced without a package prefix when that package is current, regardless of whether the symbol is present in that package or is inherited. accessor n. an operator that performs an access. See reader and writer. active adj. 1. (of a handler, a restart, or a catch tag) having been established but not yet disestablished. 2. (of an element of an array) having an index that is greater than or equal to zero, but less than the fill pointer (if any). For an array that has no fill pointer, all elements are considered active. actual adjustability n. (of an array) a generalized boolean that is associated with the array, representing whether the array is actually adjustable. See also expressed adjustability and adjustable-array-p. actual argument n. Trad. an argument. actual array element type n. (of an array) the type for which the array is actually specialized, which is the upgraded array element type of the expressed array element type of the array. See the function array-element-type. actual complex part type n. (of a complex) the type in which the real and imaginary parts of the complex are actually represented, which is the upgraded complex part type of the expressed complex part type of the complex. actual parameter n. Trad. an argument. actually adjustable adj. (of an array) such that adjust-array can adjust its characteristics by direct modification. A conforming program may depend on an array being actually adjustable only if either that array is known to have been expressly adjustable or if that array has been explicitly tested by adjustable-array-p. adjustability n. (of an array) 1. expressed adjustability. 2. actual adjustability. adjustable adj. (of an array) 1. expressly adjustable. 2. actually adjustable. after method n. a method having the qualifier :after. alist pronounced '\=a ,list , n. an association list. alphabetic n., adj. 1. adj. (of a character) being one of the standard characters A through Z or a through z, or being any implementation-defined character that has case, or being some other graphic character defined by the implementation to be alphabetic_1. 2. a. n. one of several possible constituent traits of a character. For details, see *note Constituent Characters:: and *note Reader Algorithm::. b. adj. (of a character) being a character that has syntax type constituent in the current readtable and that has the constituent trait alphabetic_{2a}. See Figure~2-8. alphanumeric adj. (of a character) being either an alphabetic_1 character or a numeric character. ampersand n. the standard character that is called "ampersand" (&). See Figure~2-5. anonymous adj. 1. (of a class or function) having no name 2. (of a restart) having a name of nil. apparently uninterned adj. having a home package of nil. (An apparently uninterned symbol might or might not be an uninterned symbol. Uninterned symbols have a home package of nil, but symbols which have been uninterned from their home package also have a home package of nil, even though they might still be interned in some other package.) applicable adj. 1. (of a handler) being an applicable handler. 2. (of a method) being an applicable method. 3. (of a restart) being an applicable restart. applicable handler n. (for a condition being signaled) an active handler for which the associated type contains the condition. applicable method n. (of a generic function called with arguments) a method of the generic function for which the arguments satisfy the parameter specializers of that method. See *note Selecting the Applicable Methods::. applicable restart n. 1. (for a condition) an active handler for which the associated test returns true when given the condition as an argument. 2. (for no particular condition) an active handler for which the associated test returns true when given nil as an argument. apply v.t. (a function to a list) to call the function with arguments that are the elements of the list. "Applying the function + to a list of integers returns the sum of the elements of that list." argument n. 1. (of a function) an object which is offered as data to the function when it is called. 2. (of a format control) a format argument. argument evaluation order n. the order in which arguments are evaluated in a function call. "The argument evaluation order for Common Lisp is left to right." See *note Evaluation::. argument precedence order n. the order in which the arguments to a generic function are considered when sorting the applicable methods into precedence order. around method n. a method having the qualifier :around. array n. an object of type array, which serves as a container for other objects arranged in a Cartesian coordinate system. array element type n. (of an array) 1. a type associated with the array, and of which all elements of the array are constrained to be members. 2. the actual array element type of the array. 3. the expressed array element type of the array. array total size n. the total number of elements in an array, computed by taking the product of the dimensions of the array. (The size of a zero-dimensional array is therefore one.) assign v.t. (a variable) to change the value of the variable in a binding that has already been established. See the special operator setq. association list n. a list of conses representing an association of keys with values, where the car of each cons is the key and the cdr is the value associated with that key. asterisk n. the standard character that is variously called "asterisk" or "star" (*). See Figure~2-5. at-sign n. the standard character that is variously called "commercial at" or "at sign" (@). See Figure~2-5. atom n. any object that is not a cons. "A vector is an atom." atomic adj. being an atom. "The number 3, the symbol foo, and nil are atomic." atomic type specifier n. a type specifier that is atomic. For every atomic type specifier, x, there is an equivalent compound type specifier with no arguments supplied, (x). attribute n. (of a character) a program-visible aspect of the character. The only standardized attribute of a character is its code_2, but implementations are permitted to have additional implementation-defined attributes. See *note Character Attributes::. "An implementation that support fonts might make font information an attribute of a character, while others might represent font information separately from characters." aux variable n. a variable that occurs in the part of a lambda list that was introduced by &aux. Unlike all other variables introduced by a lambda-list, aux variables are not parameters. auxiliary method n. a member of one of two sets of methods (the set of primary methods is the other) that form an exhaustive partition of the set of methods on the method's generic function. How these sets are determined is dependent on the method combination type; see *note Introduction to Methods::. B - backquote n. the standard character that is variously called "grave accent" or "backquote" (`). See Figure~2-5. backslash n. the standard character that is variously called "reverse solidus" or "backslash" (\). See Figure~2-5. base character n. a character of type base-char. base string n. a string of type base-string. before method n. a method having the qualifier :before. bidirectional adj. (of a stream) being both an input stream and an output stream. binary adj. 1. (of a stream) being a stream that has an element type that is a subtype of type integer. The most fundamental operation on a binary input stream is read-byte and on a binary output stream is write-byte. See character. 2. (of a file) having been created by opening a binary stream. (It is implementation-dependent whether this is an detectable aspect of the file, or whether any given character file can be treated as a binary file.) bind v.t. (a variable) to establish a binding for the variable. binding n. an association between a name and that which the name denotes. "A lexical binding is a lexical association between a name and its value." bit n. an object of type bit; that is, the integer 0 or the integer 1. bit array n. a specialized array that is of type (array bit), and whose elements are of type bit. bit vector n. a specialized vector that is of type bit-vector, and whose elements are of type bit. bit-wise logical operation specifier n. an object which names one of the sixteen possible bit-wise logical operations that can be performed by the boole function, and which is the value of exactly one of the constant variables boole-clr, boole-set, boole-1, boole-2, boole-c1, boole-c2, boole-and, boole-ior, boole-xor, boole-eqv, boole-nand, boole-nor, boole-andc1, boole-andc2, boole-orc1, or boole-orc2. block n. a named lexical exit point, established explicitly by block or implicitly by operators such as loop, do and prog, to which control and values may be transfered by using a return-from form with the name of the block. block tag n. the symbol that, within the lexical scope of a block form, names the block established by that block form. See return or return-from. boa lambda list n. a lambda list that is syntactically like an ordinary lambda list, but that is processed in "by order of argument" style. See *note Boa Lambda Lists::. body parameter n. a parameter available in certain lambda lists which from the point of view of conforming programs is like a rest parameter in every way except that it is introduced by &body instead of &rest. (Implementations are permitted to provide extensions which distinguish body parameters and rest parameters--e.g., the forms for operators which were defined using a body parameter might be pretty printed slightly differently than forms for operators which were defined using rest parameters.) boolean n. an object of type boolean; that is, one of the following objects: the symbol~t (representing true), or the symbol~nil (representing false). See generalized boolean. boolean equivalent n. (of an object O_1) any object O_2 that has the same truth value as O_1 when both O_1 and O_2 are viewed as generalized booleans. bound adj., v.t. 1. adj. having an associated denotation in a binding. "The variables named by a let are bound within its body." See unbound. 2. adj. having a local binding which shadows_2 another. "The variable *print-escape* is bound while in the princ function." 3. v.t. the past tense of bind. bound declaration n. a declaration that refers to or is associated with a variable or function and that appears within the special form that establishes the variable or function, but before the body of that special form (specifically, at the head of that form's body). (If a bound declaration refers to a function binding or a lexical variable binding, the scope of the declaration is exactly the scope of that binding. If the declaration refers to a dynamic variable binding, the scope of the declaration is what the scope of the binding would have been if it were lexical rather than dynamic.) bounded adj. (of a sequence S, by an ordered pair of bounding indices i_{start} and i_{end}) restricted to a subrange of the elements of S that includes each element beginning with (and including) the one indexed by i_{start} and continuing up to (but not including) the one indexed by i_{end}. bounding index n. (of a sequence with length n) either of a conceptual pair of integers, i_{start} and i_{end}, respectively called the "lower bounding index" and "upper bounding index", such that 0 <= i_{start} <= i_{end} <= n, and which therefore delimit a subrange of the sequence bounded by i_{start} and i_{end}. bounding index designator (for a sequence) one of two objects that, taken together as an ordered pair, behave as a designator for bounding indices of the sequence; that is, they denote bounding indices of the sequence, and are either: an integer (denoting itself) and nil (denoting the length of the sequence), or two integers (each denoting themselves). break loop n. A variant of the normal Lisp read-eval-print loop that is recursively entered, usually because the ongoing evaluation of some other form has been suspended for the purpose of debugging. Often, a break loop provides the ability to exit in such a way as to continue the suspended computation. See the function break. broadcast stream n. an output stream of type broadcast-stream. built-in class n. a class that is a generalized instance of class built-in-class. built-in type n. one of the types in Figure~4-2. byte n. 1. adjacent bits within an integer. (The specific number of bits can vary from point to point in the program; see the function byte.) 2. an integer in a specified range. (The specific range can vary from point to point in the program; see the functions open and write-byte.) byte specifier n. An object of implementation-dependent nature that is returned by the function byte and that specifies the range of bits in an integer to be used as a byte by functions such as ldb. C - cadr pronounced 'ka ,de r , n. (of an object) the car of the cdr of that object. call v.t., n. 1. v.t. (a function with arguments) to cause the code represented by that function to be executed in an environment where bindings for the values of its parameters have been established based on the arguments. "Calling the function + with the arguments 5 and 1 yields a value of 6." 2. n. a situation in which a function is called. captured initialization form n. an initialization form along with the lexical environment in which the form that defined the initialization form was evaluated. "Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified in the defclass form for the new class." car n. 1. a. (of a cons) the component of a cons corresponding to the first argument to cons; the other component is the cdr. "The function rplaca modifies the car of a cons." b. (of a list) the first element of the list, or nil if the list is the empty list. 2. the object that is held in the car_1. "The function car returns the car of a cons." case n. (of a character) the property of being either uppercase or lowercase. Not all characters have case. "The characters #\A and #\a have case, but the character #\$ has no case." See *note Characters With Case:: and the function both-case-p. case sensitivity mode n. one of the symbols :upcase, :downcase, :preserve, or :invert. catch n. an exit point which is established by a catch form within the dynamic scope of its body, which is named by a catch tag, and to which control and values may be thrown. catch tag n. an object which names an active catch. (If more than one catch is active with the same catch tag, it is only possible to throw to the innermost such catch because the outer one is shadowed_2.) cddr pronounced 'kud e ,de r or pronounced 'ke ,dude r , n. (of an object) the cdr of the cdr of that object. cdr pronounced 'ku ,de r , n. 1. a. (of a cons) the component of a cons corresponding to the second argument to cons; the other component is the car. "The function rplacd modifies the cdr of a cons." b. (of a list L_1) either the list L_2 that contains the elements of L_1 that follow after the first, or else nil if L_1 is the empty list. 2. the object that is held in the cdr_1. "The function cdr returns the cdr of a cons." cell n. Trad. (of an object) a conceptual slot of that object. The dynamic variable and global function bindings of a symbol are sometimes referred to as its value cell and function cell, respectively. character n., adj. 1. n. an object of type character; that is, an object that represents a unitary token in an aggregate quantity of text; see *note Character Concepts::. 2. adj. a. (of a stream) having an element type that is a subtype of type character. The most fundamental operation on a character input stream is read-char and on a character output stream is write-char. See binary. b. (of a file) having been created by opening a character stream. (It is implementation-dependent whether this is an inspectable aspect of the file, or whether any given binary file can be treated as a character file.) character code n. 1. one of possibly several attributes of a character. 2. a non-negative integer less than the value of char-code-limit that is suitable for use as a character code_1. character designator n. a designator for a character; that is, an object that denotes a character and that is one of: a designator for a string of length one (denoting the character that is its only element), or a character (denoting itself). circular adj. 1. (of a list) a circular list. 2. (of an arbitrary object) having a component, element, constituent_2, or subexpression (as appropriate to the context) that is the object itself. circular list n. a chain of conses that has no termination because some cons in the chain is the cdr of a later cons. class n. 1. an object that uniquely determines the structure and behavior of a set of other objects called its direct instances, that contributes structure and behavior to a set of other objects called its indirect instances, and that acts as a type specifier for a set of objects called its generalized instances. "The class integer is a subclass of the class number." (Note that the phrase "the class foo" is often substituted for the more precise phrase "the class named foo"--in both cases, a class object (not a symbol) is denoted.) 2. (of an object) the uniquely determined class of which the object is a direct instance. See the function class-of. "The class of the object returned by gensym is symbol." (Note that with this usage a phrase such as "its class is foo" is often substituted for the more precise phrase "its class is the class named foo"--in both cases, a class object (not a symbol) is denoted.) class designator n. a designator for a class; that is, an object that denotes a class and that is one of: a symbol (denoting the class named by that symbol; see the function find-class) or a class (denoting itself). class precedence list n. a unique total ordering on a class and its superclasses that is consistent with the local precedence orders for the class and its superclasses. For detailed information, see *note Determining the Class Precedence List::. close v.t. (a stream) to terminate usage of the stream as a source or sink of data, permitting the implementation to reclaim its internal data structures, and to free any external resources which might have been locked by the stream when it was opened. closed adj. (of a stream) having been closed (see close). Some (but not all) operations that are valid on open streams are not valid on closed streams. See *note File Operations on Open and Closed Streams::. closure n. a lexical closure. coalesce v.t. (literal objects that are similar) to consolidate the identity of those objects, such that they become the same object. See *note Compiler Terminology::. code n. 1. Trad. any representation of actions to be performed, whether conceptual or as an actual object, such as forms, lambda expressions, objects of type function, text in a source file, or instruction sequences in a compiled file. This is a generic term; the specific nature of the representation depends on its context. 2. (of a character) a character code. coerce v.t. (an object to a type) to produce an object from the given object, without modifying that object, by following some set of coercion rules that must be specifically stated for any context in which this term is used. The resulting object is necessarily of the indicated type, except when that type is a subtype of type complex; in that case, if a complex rational with an imaginary part of zero would result, the result is a rational rather than a complex--see *note Rule of Canonical Representation for Complex Rationals::. colon n. the standard character that is called "colon" (:). See Figure~2-5. comma n. the standard character that is called "comma" (,). See Figure~2-5. compilation n. the process of compiling code by the compiler. compilation environment n. 1. An environment that represents information known by the compiler about a form that is being compiled. See *note Compiler Terminology::. 2. An object that represents the compilation environment_1 and that is used as a second argument to a macro function (which supplies a value for any &environment parameter in the macro function's definition). compilation unit n. an interval during which a single unit of compilation is occurring. See the macro with-compilation-unit. compile v.t. 1. (code) to perform semantic preprocessing of the code, usually optimizing one or more qualities of the code, such as run-time speed of execution or run-time storage usage. The minimum semantic requirements of compilation are that it must remove all macro calls and arrange for all load time values to be resolved prior to run time. 2. (a function) to produce a new object of type compiled-function which represents the result of compiling the code represented by the function. See the function compile. 3. (a source file) to produce a compiled file from a source file. See the function compile-file. compile time n. the duration of time that the compiler is processing source code. compile-time definition n. a definition in the compilation environment. compiled code n. 1. compiled functions. 2. code that represents compiled functions, such as the contents of a compiled file. compiled file n. a file which represents the results of compiling the forms which appeared in a corresponding source file, and which can be loaded. See the function compile-file. compiled function n. an object of type compiled-function, which is a function that has been compiled, which contains no references to macros that must be expanded at run time, and which contains no unresolved references to load time values. compiler n. a facility that is part of Lisp and that translates code into an implementation-dependent form that might be represented or executed efficiently. The functions compile and compile-file permit programs to invoke the compiler. compiler macro n. an auxiliary macro definition for a globally defined function or macro which might or might not be called by any given conforming implementation and which must preserve the semantics of the globally defined function or macro but which might perform some additional optimizations. (Unlike a macro, a compiler macro does not extend the syntax of Common Lisp; rather, it provides an alternate implementation strategy for some existing syntax or functionality.) compiler macro expansion n. 1. the process of translating a form into another form by a compiler macro. 2. the form resulting from this process. compiler macro form n. a function form or macro form whose operator has a definition as a compiler macro, or a funcall form whose first argument is a function form whose argument is the name of a function that has a definition as a compiler macro. compiler macro function n. a function of two arguments, a form and an environment, that implements compiler macro expansion by producing either a form to be used in place of the original argument form or else nil, indicating that the original form should not be replaced. See *note Compiler Macros::. complex n. an object of type complex. complex float n. an object of type complex which has a complex part type that is a subtype of float. A complex float is a complex, but it is not a float. complex part type n. (of a complex) 1. the type which is used to represent both the real part and the imaginary part of the complex. 2. the actual complex part type of the complex. 3. the expressed complex part type of the complex. complex rational n. an object of type complex which has a complex part type that is a subtype of rational. A complex rational is a complex, but it is not a rational. No complex rational has an imaginary part of zero because such a number is always represented by Common Lisp as an object of type rational; see *note Rule of Canonical Representation for Complex Rationals::. complex single float n. an object of type complex which has a complex part type that is a subtype of single-float. A complex single float is a complex, but it is not a single float. composite stream n. a stream that is composed of one or more other streams. "make-synonym-stream creates a composite stream." compound form n. a non-empty list which is a form: a special form, a lambda form, a macro form, or a function form. compound type specifier n. a type specifier that is a cons; i.e., a type specifier that is not an atomic type specifier. "(vector single-float) is a compound type specifier." concatenated stream n. an input stream of type concatenated-stream. condition n. 1. an object which represents a situation--usually, but not necessarily, during signaling. 2. an object of type condition. condition designator n. one or more objects that, taken together, denote either an existing condition object or a condition object to be implicitly created. For details, see *note Condition Designators::. condition handler n. a function that might be invoked by the act of signaling, that receives the condition being signaled as its only argument, and that is permitted to handle the condition or to decline. See *note Signaling::. condition reporter n. a function that describes how a condition is to be printed when the Lisp printer is invoked while *print-escape* is false. See *note Printing Conditions::. conditional newline n. a point in output where a newline might be inserted at the discretion of the pretty printer. There are four kinds of conditional newlines, called "linear-style," "fill-style," "miser-style," and "mandatory-style." See the function pprint-newline and *note Dynamic Control of the Arrangement of Output::. conformance n. a state achieved by proper and complete adherence to the requirements of this specification. See *note Conformance::. conforming code n. code that is all of part of a conforming program. conforming implementation n. an implementation, used to emphasize complete and correct adherance to all conformance criteria. A conforming implementation is capable of accepting a conforming program as input, preparing that program for execution, and executing the prepared program in accordance with this specification. An implementation which has been extended may still be a conforming implementation provided that no extension interferes with the correct function of any conforming program. conforming processor n. ANSI a conforming implementation. conforming program n. a program, used to emphasize the fact that the program depends for its correctness only upon documented aspects of Common Lisp, and can therefore be expected to run correctly in any conforming implementation. congruent n. conforming to the rules of lambda list congruency, as detailed in *note Congruent Lambda-lists for all Methods of a Generic Function::. cons n.v. 1. n. a compound data object having two components called the car and the cdr. 2. v. to create such an object. 3. v. Idiom. to create any object, or to allocate storage. constant n. 1. a constant form. 2. a constant variable. 3. a constant object. 4. a self-evaluating object. constant form n. any form for which evaluation always yields the same value, that neither affects nor is affected by the environment in which it is evaluated (except that it is permitted to refer to the names of constant variables defined in the environment), and that neither affects nor is affected by the state of any object except those objects that are otherwise inaccessible parts of objects created by the form itself. "A car form in which the argument is a quote form is a constant form." constant object n. an object that is constrained (e.g., by its context in a program or by the source from which it was obtained) to be immutable. "A literal object that has been processed by compile-file is a constant object." constant variable n. a variable, the value of which can never change; that is, a keyword_1 or a named constant. "The symbols t, nil, :direction, and most-positive-fixnum are constant variables." constituent n., adj. 1. a. n. the syntax type of a character that is part of a token. For details, see *note Constituent Characters::. b. adj. (of a character) having the constituent_{1a} syntax type_2. c. n. a constituent_{1b} character. 2. n. (of a composite stream) one of possibly several objects that collectively comprise the source or sink of that stream. constituent trait n. (of a character) one of several classifications of a constituent character in a readtable. See *note Constituent Characters::. constructed stream n. a stream whose source or sink is a Lisp object. Note that since a stream is another Lisp object, composite streams are considered constructed streams. "A string stream is a constructed stream." contagion n. a process whereby operations on objects of differing types (e.g., arithmetic on mixed types of numbers) produce a result whose type is controlled by the dominance of one argument's type over the types of the other arguments. See *note Contagion in Numeric Operations::. continuable n. (of an error) an error that is correctable by the continue restart. control form n. 1. a form that establishes one or more places to which control can be transferred. 2. a form that transfers control. copy n. 1. (of a cons C) a fresh cons with the same car and cdr as C. 2. (of a list L) a fresh list with the same elements as L. (Only the list structure is fresh; the elements are the same.) See the function copy-list. 3. (of an association list A with elements A_i) a fresh list B with elements B_i, each of which is nil if A_i is nil, or else a copy of the cons A_i. See the function copy-alist. 4. (of a tree T) a fresh tree with the same leaves as T. See the function copy-tree. 5. (of a random state R) a fresh random state that, if used as an argument to to the function random would produce the same series of "random" values as R would produce. 6. (of a structure S) a fresh structure that has the same type as S, and that has slot values, each of which is the same as the corresponding slot value of S. (Note that since the difference between a cons, a list, and a tree is a matter of "view" or "intention," there can be no general-purpose function which, based solely on the type of an object, can determine which of these distinct meanings is intended. The distinction rests solely on the basis of the text description within this document. For example, phrases like "a copy of the given list" or "copy of the list x" imply the second definition.) correctable adj. (of an error) 1. (by a restart other than abort that has been associated with the error) capable of being corrected by invoking that restart. "The function cerror signals an error that is correctable by the continue restart." (Note that correctability is not a property of an error object, but rather a property of the dynamic environment that is in effect when the error is signaled. Specifically, the restart is "associated with" the error condition object. See *note Associating a Restart with a Condition::.) 2. (when no specific restart is mentioned) correctable_1 by at least one restart. "import signals a correctable error of type package-error if any of the imported symbols has the same name as some distinct symbol already accessible in the package." current input base n. (in a dynamic environment) the radix that is the value of *read-base* in that environment, and that is the default radix employed by the Lisp reader and its related functions. current logical block n. the context of the innermost lexically enclosing use of pprint-logical-block. current output base n. (in a dynamic environment) the radix that is the value of *print-base* in that environment, and that is the default radix employed by the Lisp printer and its related functions. current package n. (in a dynamic environment) the package that is the value of *package* in that environment, and that is the default package employed by the Lisp reader and Lisp printer, and their related functions. current pprint dispatch table n. (in a dynamic environment) the pprint dispatch table that is the value of *print-pprint-dispatch* in that environment, and that is the default pprint dispatch table employed by the pretty printer. current random state n. (in a dynamic environment) the random state that is the value of *random-state* in that environment, and that is the default random state employed by random. current readtable n. (in a dynamic environment) the readtable that is the value of *readtable* in that environment, and that affects the way in which expressions_2 are parsed into objects by the Lisp reader. D - data type n. Trad. a type. debug I/O n. the bidirectional stream that is the value of the variable *debug-io*. debugger n. a facility that allows the user to handle a condition interactively. For example, the debugger might permit interactive selection of a restart from among the active restarts, and it might perform additional implementation-defined services for the purposes of debugging. declaration n. a global declaration or local declaration. declaration identifier n. one of the symbols declaration, dynamic-extent, ftype, function, ignore, inline, notinline, optimize, special, or type; or a symbol which is the name of a type; or a symbol which has been declared to be a declaration identifier by using a declaration declaration. declaration specifier n. an expression that can appear at top level of a declare expression or a declaim form, or as the argument to proclaim, and which has a car which is a declaration identifier, and which has a cdr that is data interpreted according to rules specific to the declaration identifier. declare v. to establish a declaration. See declare, declaim, or proclaim. decline v. (of a handler) to return normally without having handled the condition being signaled, permitting the signaling process to continue as if the handler had not been present. decoded time n. absolute time, represented as an ordered series of nine objects which, taken together, form a description of a point in calendar time, accurate to the nearest second (except that leap seconds are ignored). See *note Decoded Time::. default method n. a method having no parameter specializers other than the class t. Such a method is always an applicable method but might be shadowed_2 by a more specific method. defaulted initialization argument list n. a list of alternating initialization argument names and values in which unsupplied initialization arguments are defaulted, used in the protocol for initializing and reinitializing instances of classes. define-method-combination arguments lambda list n. a lambda list used by the :arguments option to define-method-combination. See *note Define-method-combination Arguments Lambda Lists::. define-modify-macro lambda list n. a lambda list used by define-modify-macro. See *note Define-modify-macro Lambda Lists::. defined name n. a symbol the meaning of which is defined by Common Lisp. defining form n. a form that has the side-effect of establishing a definition. "defun and defparameter are defining forms." defsetf lambda list n. a lambda list that is like an ordinary lambda list except that it does not permit &aux and that it permits use of &environment. See *note Defsetf Lambda Lists::. deftype lambda list n. a lambda list that is like a macro lambda list except that the default value for unsupplied optional parameters and keyword parameters is the symbol * (rather than nil). See *note Deftype Lambda Lists::. denormalized adj., ANSI, IEEE (of a float) conforming to the description of "denormalized" as described by IEEE Standard for Binary Floating-Point Arithmetic. For example, in an implementation where the minimum possible exponent was -7 but where 0.001 was a valid mantissa, the number 1.0e-10 might be representable as 0.001e-7 internally even if the normalized representation would call for it to be represented instead as 1.0e-10 or 0.1e-9. By their nature, denormalized floats generally have less precision than normalized floats. derived type n. a type specifier which is defined in terms of an expansion into another type specifier. deftype defines derived types, and there may be other implementation-defined operators which do so as well. derived type specifier n. a type specifier for a derived type. designator n. an object that denotes another object. In the dictionary entry for an operator if a parameter is described as a designator for a type, the description of the operator is written in a way that assumes that appropriate coercion to that type has already occurred; that is, that the parameter is already of the denoted type. For more detailed information, see *note Designators::. destructive adj. (of an operator) capable of modifying some program-visible aspect of one or more objects that are either explicit arguments to the operator or that can be obtained directly or indirectly from the global environment by the operator. destructuring lambda list n. an extended lambda list used in destructuring-bind and nested within macro lambda lists. See *note Destructuring Lambda Lists::. different adj. not the same "The strings "FOO" and "foo" are different under equal but not under equalp." digit n. (in a radix) a character that is among the possible digits (0 to 9, A to Z, and a to z) and that is defined to have an associated numeric weight as a digit in that radix. See *note Digits in a Radix::. dimension n. 1. a non-negative integer indicating the number of objects an array can hold along one axis. If the array is a vector with a fill pointer, the fill pointer is ignored. "The second dimension of that array is 7." 2. an axis of an array. "This array has six dimensions." direct instance n. (of a class C) an object whose class is C itself, rather than some subclass of C. "The function make-instance always returns a direct instance of the class which is (or is named by) its first argument." direct subclass n. (of a class C_1) a class C_2, such that C_1 is a direct superclass of C_2. direct superclass n. (of a class C_1) a class C_2 which was explicitly designated as a superclass of C_1 in the definition of C_1. disestablish v.t. to withdraw the establishment of an object, a binding, an exit point, a tag, a handler, a restart, or an environment. disjoint n. (of types) having no elements in common. dispatching macro character n. a macro character that has an associated table that specifies the function to be called for each character that is seen following the dispatching macro character. See the function make-dispatch-macro-character. displaced array n. an array which has no storage of its own, but which is instead indirected to the storage of another array, called its target, at a specified offset, in such a way that any attempt to access the displaced array implicitly references the target array. distinct adj. not identical. documentation string n. (in a defining form) A literal string which because of the context in which it appears (rather than because of some intrinsically observable aspect of the string) is taken as documentation. In some cases, the documentation string is saved in such a way that it can later be obtained by supplying either an object, or by supplying a name and a "kind" to the function documentation. "The body of code in a defmacro form can be preceded by a documentation string of kind function." dot n. the standard character that is variously called "full stop," "period," or "dot" (.). See Figure~2-5. dotted list n. a list which has a terminating atom that is not nil. (An atom by itself is not a dotted list, however.) dotted pair n. 1. a cons whose cdr is a non-list. 2. any cons, used to emphasize the use of the cons as a symmetric data pair. double float n. an object of type double-float. double-quote n. the standard character that is variously called "quotation mark" or "double quote" ("). See Figure~2-5. dynamic binding n. a binding in a dynamic environment. dynamic environment n. that part of an environment that contains bindings with dynamic extent. A dynamic environment contains, among other things: exit points established by unwind-protect, and bindings of dynamic variables, exit points established by catch, condition handlers, and restarts. dynamic extent n. an extent whose duration is bounded by points of establishment and disestablishment within the execution of a particular form. See indefinite extent. "Dynamic variable bindings have dynamic extent." dynamic scope n. indefinite scope along with dynamic extent. dynamic variable n. a variable the binding for which is in the dynamic environment. See special. E - echo stream n. a stream of type echo-stream. effective method n. the combination of applicable methods that are executed when a generic function is invoked with a particular sequence of arguments. element n. 1. (of a list) an object that is the car of one of the conses that comprise the list. 2. (of an array) an object that is stored in the array. 3. (of a sequence) an object that is an element of the list or array that is the sequence. 4. (of a type) an object that is a member of the set of objects designated by the type. 5. (of an input stream) a character or number (as appropriate to the element type of the stream) that is among the ordered series of objects that can be read from the stream (using read-char or read-byte, as appropriate to the stream). 6. (of an output stream) a character or number (as appropriate to the element type of the stream) that is among the ordered series of objects that has been or will be written to the stream (using write-char or write-byte, as appropriate to the stream). 7. (of a class) a generalized instance of the class. element type n. 1. (of an array) the array element type of the array. 2. (of a stream) the stream element type of the stream. em n. Trad. a context-dependent unit of measure commonly used in typesetting, equal to the displayed width of of a letter "M" in the current font. (The letter "M" is traditionally chosen because it is typically represented by the widest glyph in the font, and other characters' widths are typically fractions of an em. In implementations providing non-Roman characters with wider characters than "M," it is permissible for another character to be the implementation-defined reference character for this measure, and for "M" to be only a fraction of an em wide.) In a fixed width font, a line with n characters is n ems wide; in a variable width font, n ems is the expected upper bound on the width of such a line. empty list n. the list containing no elements. See (). empty type n. the type that contains no elements, and that is a subtype of all types (including itself). See nil. end of file n. 1. the point in an input stream beyond which there is no further data. Whether or not there is such a point on an interactive stream is implementation-defined. 2. a situation that occurs upon an attempt to obtain data from an input stream that is at the end of file_1. environment n. 1. a set of bindings. See *note Introduction to Environments::. 2. an environment object. "macroexpand takes an optional environment argument." environment object n. an object representing a set of lexical bindings, used in the processing of a form to provide meanings for names within that form. "macroexpand takes an optional environment argument." (The object nil when used as an environment object denotes the null lexical environment; the values of environment parameters to macro functions are objects of implementation-dependent nature which represent the environment_1 in which the corresponding macro form is to be expanded.) See *note Environment Objects::. environment parameter n. A parameter in a defining form f for which there is no corresponding argument; instead, this parameter receives as its value an environment object which corresponds to the lexical environment in which the defining form f appeared. error n. 1. (only in the phrase "is an error") a situation in which the semantics of a program are not specified, and in which the consequences are undefined. 2. a condition which represents an error situation. See *note Error Terminology::. 3. an object of type error. error output n. the output stream which is the value of the dynamic variable *error-output*. escape n., adj. 1. n. a single escape or a multiple escape. 2. adj. single escape or multiple escape. establish v.t. to build or bring into being a binding, a declaration, an exit point, a tag, a handler, a restart, or an environment. "let establishes lexical bindings." evaluate v.t. (a form or an implicit progn) to execute the code represented by the form (or the series of forms making up the implicit progn) by applying the rules of evaluation, returning zero or more values. evaluation n. a model whereby forms are executed, returning zero or more values. Such execution might be implemented directly in one step by an interpreter or in two steps by first compiling the form and then executing the compiled code; this choice is dependent both on context and the nature of the implementation, but in any case is not in general detectable by any program. The evaluation model is designed in such a way that a conforming implementation might legitimately have only a compiler and no interpreter, or vice versa. See *note The Evaluation Model::. evaluation environment n. a run-time environment in which macro expanders and code specified by eval-when to be evaluated are evaluated. All evaluations initiated by the compiler take place in the evaluation environment. execute v.t. Trad. (code) to perform the imperative actions represented by the code. execution time n. the duration of time that compiled code is being executed. exhaustive partition n. (of a type) a set of pairwise disjoint types that form an exhaustive union. exhaustive union n. (of a type) a set of subtypes of the type, whose union contains all elements of that type. exit point n. a point in a control form from which (e.g., block), through which (e.g., unwind-protect), or to which (e.g., tagbody) control and possibly values can be transferred both actively by using another control form and passively through the normal control and data flow of evaluation. "catch and block establish bindings for exit points to which throw and return-from, respectively, can transfer control and values; tagbody establishes a binding for an exit point with lexical extent to which go can transfer control; and unwind-protect establishes an exit point through which control might be transferred by operators such as throw, return-from, and go." explicit return n. the act of transferring control (and possibly values) to a block by using return-from (or return). explicit use n. (of a variable V in a form F) a reference to V that is directly apparent in the normal semantics of F; i.e., that does not expose any undocumented details of the macro expansion of the form itself. References to V exposed by expanding subforms of F are, however, considered to be explicit uses of V. exponent marker n. a character that is used in the textual notation for a float to separate the mantissa from the exponent. The characters defined as exponent markers in the standard readtable are shown in Figure 26-1. For more information, see *note Character Syntax::. "The exponent marker 'd' in '3.0d7' indicates that this number is to be represented as a double float." Marker Meaning D or d double-float E or e float (see *read-default-float-format*) F or f single-float L or l long-float S or s short-float Figure 26-1: Exponent Markers export v.t. (a symbol in a package) to add the symbol to the list of external symbols of the package. exported adj. (of a symbol in a package) being an external symbol of the package. expressed adjustability n. (of an array) a generalized boolean that is conceptually (but not necessarily actually) associated with the array, representing whether the array is expressly adjustable. See also actual adjustability. expressed array element type n. (of an array) the type which is the array element type implied by a type declaration for the array, or which is the requested array element type at its time of creation, prior to any selection of an upgraded array element type. (Common Lisp does not provide a way of detecting this type directly at run time, but an implementation is permitted to make assumptions about the array's contents and the operations which may be performed on the array when this type is noted during code analysis, even if those assumptions would not be valid in general for the upgraded array element type of the expressed array element type.) expressed complex part type n. (of a complex) the type which is implied as the complex part type by a type declaration for the complex, or which is the requested complex part type at its time of creation, prior to any selection of an upgraded complex part type. (Common Lisp does not provide a way of detecting this type directly at run time, but an implementation is permitted to make assumptions about the operations which may be performed on the complex when this type is noted during code analysis, even if those assumptions would not be valid in general for the upgraded complex part type of the expressed complex part type.) expression n. 1. an object, often used to emphasize the use of the object to encode or represent information in a specialized format, such as program text. "The second expression in a let form is a list of bindings." 2. the textual notation used to notate an object in a source file. "The expression 'sample is equivalent to (quote sample)." expressly adjustable adj. (of an array) being actually adjustable by virtue of an explicit request for this characteristic having been made at the time of its creation. All arrays that are expressly adjustable are actually adjustable, but not necessarily vice versa. extended character n. a character of type extended-char: a character that is not a base character. extended function designator n. a designator for a function; that is, an object that denotes a function and that is one of: a function name (denoting the function it names in the global environment), or a function (denoting itself). The consequences are undefined if a function name is used as an extended function designator but it does not have a global definition as a function, or if it is a symbol that has a global definition as a macro or a special form. See also function designator. extended lambda list n. a list resembling an ordinary lambda list in form and purpose, but offering additional syntax or functionality not available in an ordinary lambda list. "defmacro uses extended lambda lists." extension n. a facility in an implementation of Common Lisp that is not specified by this standard. extent n. the interval of time during which a reference to an object, a binding, an exit point, a tag, a handler, a restart, or an environment is defined. external file format n. an object of implementation-dependent nature which determines one of possibly several implementation-dependent ways in which characters are encoded externally in a character file. external file format designator n. a designator for an external file format; that is, an object that denotes an external file format and that is one of: the symbol :default (denoting an implementation-dependent default external file format that can accomodate at least the base characters), some other object defined by the implementation to be an external file format designator (denoting an implementation-defined external file format), or some other object defined by the implementation to be an external file format (denoting itself). external symbol n. (of a package) a symbol that is part of the 'external interface' to the package and that are inherited_3 by any other package that uses the package. When using the Lisp reader, if a package prefix is used, the name of an external symbol is separated from the package name by a single package marker while the name of an internal symbol is separated from the package name by a double package marker; see *note Symbols as Tokens::. externalizable object n. an object that can be used as a literal object in code to be processed by the file compiler. F - false n. the symbol nil, used to represent the failure of a predicate test. fbound pronounced 'ef ,baund adj. (of a function name) bound in the function namespace. (The names of macros and special operators are fbound, but the nature and type of the object which is their value is implementation-dependent. Further, defining a setf expander F does not cause the setf function (setf F) to become defined; as such, if there is a such a definition of a setf expander F, the function (setf F) can be fbound if and only if, by design or coincidence, a function binding for (setf F) has been independently established.) See the functions fboundp and symbol-function. feature n. 1. an aspect or attribute of Common Lisp, of the implementation, or of the environment. 2. a symbol that names a feature_1. See *note Features::. "The :ansi-cl feature is present in all conforming implementations." feature expression n. A boolean combination of features used by the #+ and #- reader macros in order to direct conditional reading of expressions by the Lisp reader. See *note Feature Expressions::. features list n. the list that is the value of *features*. file n. a named entry in a file system, having an implementation-defined nature. file compiler n. any compiler which compiles source code contained in a file, producing a compiled file as output. The compile-file function is the only interface to such a compiler provided by Common Lisp, but there might be other, implementation-defined mechanisms for invoking the file compiler. file position n. (in a stream) a non-negative integer that represents a position in the stream. Not all streams are able to represent the notion of file position; in the description of any operator which manipulates file positions, the behavior for streams that don't have this notion must be explicitly stated. For binary streams, the file position represents the number of preceding bytes in the stream. For character streams, the constraint is more relaxed: file positions must increase monotonically, the amount of the increase between file positions corresponding to any two successive characters in the stream is implementation-dependent. file position designator n. (in a stream) a designator for a file position in that stream; that is, the symbol :start (denoting 0, the first file position in that stream), the symbol :end (denoting the last file position in that stream; i.e., the position following the last element of the stream), or a file position (denoting itself). file stream n. an object of type file-stream. file system n. a facility which permits aggregations of data to be stored in named files on some medium that is external to the Lisp image and that therefore persists from session to session. filename n. a handle, not necessarily ever directly represented as an object, that can be used to refer to a file in a file system. Pathnames and namestrings are two kinds of objects that substitute for filenames in Common Lisp. fill pointer n. (of a vector) an integer associated with a vector that represents the index above which no elements are active. (A fill pointer is a non-negative integer no larger than the total number of elements in the vector. Not all vectors have fill pointers.) finite adj. (of a type) having a finite number of elements. "The type specifier (integer 0 5) denotes a finite type, but the type specifiers integer and (integer 0) do not." fixnum n. an integer of type fixnum. float n. an object of type float. for-value adj. (of a reference to a binding) being a reference that reads_1 the value of the binding. form n. 1. any object meant to be evaluated. 2. a symbol, a compound form, or a self-evaluating object. 3. (for an operator, as in "<> form") a compound form having that operator as its first element. "A quote form is a constant form." formal argument n. Trad. a parameter. formal parameter n. Trad. a parameter. format v.t. (a format control and format arguments) to perform output as if by format, using the format string and format arguments. format argument n. an object which is used as data by functions such as format which interpret format controls. format control n. a format string, or a function that obeys the argument conventions for a function returned by the formatter macro. See *note Compiling Format Strings::. format directive n. 1. a sequence of characters in a format string which is introduced by a tilde, and which is specially interpreted by code which processes format strings to mean that some special operation should be performed, possibly involving data supplied by the format arguments that accompanied the format string. See the function format. "In "~D base 10 = ~8R", the character sequences '~D' and '~8R' are format directives." 2. the conceptual category of all format directives_1 which use the same dispatch character. "Both "~3d" and "~3,'0D" are valid uses of the '~D' format directive." format string n. a string which can contain both ordinary text and format directives, and which is used in conjunction with format arguments to describe how text output should be formatted by certain functions, such as format. free declaration n. a declaration that is not a bound declaration. See declare. fresh adj. 1. (of an object yielded by a function) having been newly-allocated by that function. (The caller of a function that returns a fresh object may freely modify the object without fear that such modification will compromise the future correct behavior of that function.) 2. (of a binding for a name) newly-allocated; not shared with other bindings for that name. freshline n. a conceptual operation on a stream, implemented by the function fresh-line and by the format directive ~&, which advances the display position to the beginning of the next line (as if a newline had been typed, or the function terpri had been called) unless the stream is already known to be positioned at the beginning of a line. Unlike newline, freshline is not a character. funbound pronounced 'ef unbaund n. (of a function name) not fbound. function n. 1. an object representing code, which can be called with zero or more arguments, and which produces zero or more values. 2. an object of type function. function block name n. (of a function name) The symbol that would be used as the name of an implicit block which surrounds the body of a function having that function name. If the function name is a symbol, its function block name is the function name itself. If the function name is a list whose car is setf and whose cadr is a symbol, its function block name is the symbol that is the cadr of the function name. An implementation which supports additional kinds of function names must specify for each how the corresponding function block name is computed. function cell n. Trad. (of a symbol) The place which holds the definition of the global function binding, if any, named by that symbol, and which is accessed by symbol-function. See cell. function designator n. a designator for a function; that is, an object that denotes a function and that is one of: a symbol (denoting the function named by that symbol in the global environment), or a function (denoting itself). The consequences are undefined if a symbol is used as a function designator but it does not have a global definition as a function, or it has a global definition as a macro or a special form. See also extended function designator. function form n. a form that is a list and that has a first element which is the name of a function to be called on arguments which are the result of evaluating subsequent elements of the function form. function name n. (in an environment) A symbol or a list (setf symbol) that is the name of a function in that environment. functional evaluation n. the process of extracting a functional value from a function name or a lambda expression. The evaluator performs functional evaluation implicitly when it encounters a function name or a lambda expression in the car of a compound form, or explicitly when it encounters a function special form. Neither a use of a symbol as a function designator nor a use of the function symbol-function to extract the functional value of a symbol is considered a functional evaluation. functional value n. 1. (of a function name N in an environment E) The value of the binding named N in the function namespace for environment E; that is, the contents of the function cell named N in environment E. 2. (of an fbound symbol S) the contents of the symbol's function cell; that is, the value of the binding named S in the function namespace of the global environment. (A name that is a macro name in the global environment or is a special operator might or might not be fbound. But if S is such a name and is fbound, the specific nature of its functional value is implementation-dependent; in particular, it might or might not be a function.) further compilation n. implementation-dependent compilation beyond minimal compilation. Further compilation is permitted to take place at run time. "Block compilation and generation of machine-specific instructions are examples of further compilation." G - general adj. (of an array) having element type t, and consequently able to have any object as an element. generalized boolean n. an object used as a truth value, where the symbol~nil represents false and all other objects represent true. See boolean. generalized instance n. (of a class) an object the class of which is either that class itself, or some subclass of that class. (Because of the correspondence between types and classes, the term "generalized instance of X" implies "object of type X" and in cases where X is a class (or class name) the reverse is also true. The former terminology emphasizes the view of X as a class while the latter emphasizes the view of X as a type specifier.) generalized reference n. a reference to a location storing an object as if to a variable. (Such a reference can be either to read or write the location.) See *note Generalized Reference::. See also place. generalized synonym stream n. (with a synonym stream symbol) 1. (to a stream) a synonym stream to the stream, or a composite stream which has as a target a generalized synonym stream to the stream. 2. (to a symbol) a synonym stream to the symbol, or a composite stream which has as a target a generalized synonym stream to the symbol. generic function n. a function whose behavior depends on the classes or identities of the arguments supplied to it and whose parts include, among other things, a set of methods, a lambda list, and a method combination type. generic function lambda list n. A lambda list that is used to describe data flow into a generic function. See *note Generic Function Lambda Lists::. gensym n. Trad. an uninterned symbol. See the function gensym. global declaration n. a form that makes certain kinds of information about code globally available; that is, a proclaim form or a declaim form. global environment n. that part of an environment that contains bindings with indefinite scope and indefinite extent. global variable n. a dynamic variable or a constant variable. glyph n. a visual representation. "Graphic characters have associated glyphs." go v. to transfer control to a go point. See the special operator go. go point one of possibly several exit points that are established by tagbody (or other abstractions, such as prog, which are built from tagbody). go tag n. the symbol or integer that, within the lexical scope of a tagbody form, names an exit point established by that tagbody form. graphic adj. (of a character) being a "printing" or "displayable" character that has a standard visual representation as a single glyph, such as A or * or =. Space is defined to be graphic. Of the standard characters, all but newline are graphic. See non-graphic. H - handle v. (of a condition being signaled) to perform a non-local transfer of control, terminating the ongoing signaling of the condition. handler n. a condition handler. hash table n. an object of type hash-table, which provides a mapping from keys to values. home package n. (of a symbol) the package, if any, which is contents of the package cell of the symbol, and which dictates how the Lisp printer prints the symbol when it is not accessible in the current package. (Symbols which have nil in their package cell are said to have no home package, and also to be apparently uninterned.) I - I/O customization variable n. one of the stream variables in Figure 26-2, or some other (implementation-defined) stream variable that is defined by the implementation to be an I/O customization variable. *debug-io* *error-io* query-io* *standard-input* *standard-output* *trace-output* Figure 26-2: Standardized I/O Customization Variables identical adj. the same under eq. identifier n. 1. a symbol used to identify or to distinguish names. 2. a string used the same way. immutable adj. not subject to change, either because no operator is provided which is capable of effecting such change or because some constraint exists which prohibits the use of an operator that might otherwise be capable of effecting such a change. Except as explicitly indicated otherwise, implementations are not required to detect attempts to modify immutable objects or cells; the consequences of attempting to make such modification are undefined. "Numbers are immutable." implementation n. a system, mechanism, or body of code that implements the semantics of Common Lisp. implementation limit n. a restriction imposed by an implementation. implementation-defined adj. implementation-dependent, but required by this specification to be defined by each conforming implementation and to be documented by the corresponding implementor. implementation-dependent adj. describing a behavior or aspect of Common Lisp which has been deliberately left unspecified, that might be defined in some conforming implementations but not in others, and whose details may differ between implementations. A conforming implementation is encouraged (but not required) to document its treatment of each item in this specification which is marked implementation-dependent, although in some cases such documentation might simply identify the item as "undefined." implementation-independent adj. used to identify or emphasize a behavior or aspect of Common Lisp which does not vary between conforming implementations. implicit block n. a block introduced by a macro form rather than by an explicit block form. implicit compilation n. compilation performed during evaluation. implicit progn n. an ordered set of adjacent forms appearing in another form, and defined by their context in that form to be executed as if within a progn. implicit tagbody n. an ordered set of adjacent forms and/or tags appearing in another form, and defined by their context in that form to be executed as if within a tagbody. import v.t. (a symbol into a package) to make the symbol be present in the package. improper list n. a list which is not a proper list: a circular list or a dotted list. inaccessible adj. not accessible. indefinite extent n. an extent whose duration is unlimited. "Most Common Lisp objects have indefinite extent." indefinite scope n. scope that is unlimited. indicator n. a property indicator. indirect instance n. (of a class C_1) an object of class C_2, where C_2 is a subclass of C_1. "An integer is an indirect instance of the class number." inherit v.t. 1. to receive or acquire a quality, trait, or characteristic; to gain access to a feature defined elsewhere. 2. (a class) to acquire the structure and behavior defined by a superclass. 3. (a package) to make symbols exported by another package accessible by using use-package. initial pprint dispatch table n. the value of *print-pprint-dispatch* at the time the Lisp image is started. initial readtable n. the value of *readtable* at the time the Lisp image is started. initialization argument list n. a property list of initialization argument names and values used in the protocol for initializing and reinitializing instances of classes. See *note Object Creation and Initialization::. initialization form n. a form used to supply the initial value for a slot or variable. "The initialization form for a slot in a defclass form is introduced by the keyword :initform." input adj. (of a stream) supporting input operations (i.e., being a "data source"). An input stream might also be an output stream, in which case it is sometimes called a bidirectional stream. See the function input-stream-p. instance n. 1. a direct instance. 2. a generalized instance. 3. an indirect instance. integer n. an object of type integer, which represents a mathematical integer. interactive stream n. a stream on which it makes sense to perform interactive querying. See *note Interactive Streams::. intern v.t. 1. (a string in a package) to look up the string in the package, returning either a symbol with that name which was already accessible in the package or a newly created internal symbol of the package with that name. 2. Idiom. generally, to observe a protocol whereby objects which are equivalent or have equivalent names under some predicate defined by the protocol are mapped to a single canonical object. internal symbol n. (of a package) a symbol which is accessible in the package, but which is not an external symbol of the package. internal time n. time, represented as an integer number of internal time units. Absolute internal time is measured as an offset from an arbitrarily chosen, implementation-dependent base. See *note Internal Time::. internal time unit n. a unit of time equal to 1/n of a second, for some implementation-defined integer value of n. See the variable internal-time-units-per-second. interned adj. Trad. 1. (of a symbol) accessible_3 in any package. 2. (of a symbol in a specific package) present in that package. interpreted function n. a function that is not a compiled function. (It is possible for there to be a conforming implementation which has no interpreted functions, but a conforming program must not assume that all functions are compiled functions.) interpreted implementation n. an implementation that uses an execution strategy for interpreted functions that does not involve a one-time semantic analysis pre-pass, and instead uses "lazy" (and sometimes repetitious) semantic analysis of forms as they are encountered during execution. interval designator n. (of type T) an ordered pair of objects that describe a subtype of T by delimiting an interval on the real number line. See *note Interval Designators::. invalid n., adj. 1. n. a possible constituent trait of a character which if present signifies that the character cannot ever appear in a token except under the control of a single escape character. For details, see *note Constituent Characters::. 2. adj. (of a character) being a character that has syntax type constituent in the current readtable and that has the constituent trait invalid_1. See Figure~2-8. iteration form n. a compound form whose operator is named in Figure 26-3, or a compound form that has an implementation-defined operator and that is defined by the implementation to be an iteration form. do do-external-symbols dotimes do* do-symbols loop do-all-symbols dolist Figure 26-3: Standardized Iteration Forms iteration variable n. a variable V, the binding for which was created by an explicit use of V in an iteration form. K - key n. an object used for selection during retrieval. See association list, property list, and hash table. Also, see *note Sequence Concepts::. keyword n. 1. a symbol the home package of which is the KEYWORD package. 2. any symbol, usually but not necessarily in the KEYWORD package, that is used as an identifying marker in keyword-style argument passing. See lambda. 3. Idiom. a lambda list keyword. keyword parameter n. A parameter for which a corresponding keyword argument is optional. (There is no such thing as a required keyword argument.) If the argument is not supplied, a default value is used. See also supplied-p parameter. keyword/value pair n. two successive elements (a keyword and a value, respectively) of a property list. L - lambda combination n. Trad. a lambda form. lambda expression n. a list which can be used in place of a function name in certain contexts to denote a function by directly describing its behavior rather than indirectly by referring to the name of an established function; its name derives from the fact that its first element is the symbol lambda. See lambda. lambda form n. a form that is a list and that has a first element which is a lambda expression representing a function to be called on arguments which are the result of evaluating subsequent elements of the lambda form. lambda list n. a list that specifies a set of parameters (sometimes called lambda variables) and a protocol for receiving values for those parameters; that is, an ordinary lambda list, an extended lambda list, or a modified lambda list. lambda list keyword n. a symbol whose name begins with ampersand and that is specially recognized in a lambda list. Note that no standardized lambda list keyword is in the KEYWORD package. lambda variable n. a formal parameter, used to emphasize the variable's relation to the lambda list that established it. leaf n. 1. an atom in a tree_1. 2. a terminal node of a tree_2. leap seconds n. additional one-second intervals of time that are occasionally inserted into the true calendar by official timekeepers as a correction similar to "leap years." All Common Lisp time representations ignore leap seconds; every day is assumed to be exactly 86400 seconds long. left-parenthesis n. the standard character "(", that is variously called "left parenthesis" or "open parenthesis" See Figure~2-5. length n. (of a sequence) the number of elements in the sequence. (Note that if the sequence is a vector with a fill pointer, its length is the same as the fill pointer even though the total allocated size of the vector might be larger.) lexical binding n. a binding in a lexical environment. lexical closure n. a function that, when invoked on arguments, executes the body of a lambda expression in the lexical environment that was captured at the time of the creation of the lexical closure, augmented by bindings of the function's parameters to the corresponding arguments. lexical environment n. that part of the environment that contains bindings whose names have lexical scope. A lexical environment contains, among other things: ordinary bindings of variable names to values, lexically established bindings of function names to functions, macros, symbol macros, blocks, tags, and local declarations (see declare). lexical scope n. scope that is limited to a spatial or textual region within the establishing form. "The names of parameters to a function normally are lexically scoped." lexical variable n. a variable the binding for which is in the lexical environment. Lisp image n. a running instantiation of a Common Lisp implementation. A Lisp image is characterized by a single address space in which any object can directly refer to any another in conformance with this specification, and by a single, common, global environment. (External operating systems sometimes call this a "core image," "fork," "incarnation," "job," or "process." Note however, that the issue of a "process" in such an operating system is technically orthogonal to the issue of a Lisp image being defined here. Depending on the operating system, a single "process" might have multiple Lisp images, and multiple "processes" might reside in a single Lisp image. Hence, it is the idea of a fully shared address space for direct reference among all objects which is the defining characteristic. Note, too, that two "processes" which have a communication area that permits the sharing of some but not all objects are considered to be distinct Lisp images.) Lisp printer n. Trad. the procedure that prints the character representation of an object onto a stream. (This procedure is implemented by the function write.) Lisp read-eval-print loop n. Trad. an endless loop that reads_2 a form, evaluates it, and prints (i.e., writes_2) the results. In many implementations, the default mode of interaction with Common Lisp during program development is through such a loop. Lisp reader n. Trad. the procedure that parses character representations of objects from a stream, producing objects. (This procedure is implemented by the function read.) list n. 1. a chain of conses in which the car of each cons is an element of the list, and the cdr of each cons is either the next link in the chain or a terminating atom. See also proper list, dotted list, or circular list. 2. the type that is the union of null and cons. list designator n. a designator for a list of objects; that is, an object that denotes a list and that is one of: a non-nil atom (denoting a singleton list whose element is that non-nil atom) or a proper list (denoting itself). list structure n. (of a list) the set of conses that make up the list. Note that while the car_{1b} component of each such cons is part of the list structure, the objects that are elements of the list (i.e., the objects that are the cars_2 of each cons in the list) are not themselves part of its list structure, even if they are conses, except in the (circular_2) case where the list actually contains one of its tails as an element. (The list structure of a list is sometimes redundantly referred to as its "top-level list structure" in order to emphasize that any conses that are elements of the list are not involved.) literal adj. (of an object) referenced directly in a program rather than being computed by the program; that is, appearing as data in a quote form, or, if the object is a self-evaluating object, appearing as unquoted data. "In the form (cons "one" '("two")), the expressions "one", ("two"), and "two" are literal objects." load v.t. (a file) to cause the code contained in the file to be executed. See the function load. load time n. the duration of time that the loader is loading compiled code. load time value n. an object referred to in code by a load-time-value form. The value of such a form is some specific object which can only be computed in the run-time environment. In the case of file compilation, the value is computed once as part of the process of loading the compiled file, and not again. See the special operator load-time-value. loader n. a facility that is part of Lisp and that loads a file. See the function load. local declaration n. an expression which may appear only in specially designated positions of certain forms, and which provides information about the code contained within the containing form; that is, a declare expression. local precedence order n. (of a class) a list consisting of the class followed by its direct superclasses in the order mentioned in the defining form for the class. local slot n. (of a class) a slot accessible in only one instance, namely the instance in which the slot is allocated. logical block n. a conceptual grouping of related output used by the pretty printer. See the macro pprint-logical-block and *note Dynamic Control of the Arrangement of Output::. logical host n. an object of implementation-dependent nature that is used as the representation of a "host" in a logical pathname, and that has an associated set of translation rules for converting logical pathnames belonging to that host into physical pathnames. See *note Logical Pathnames::. logical host designator n. a designator for a logical host; that is, an object that denotes a logical host and that is one of: a string (denoting the logical host that it names), or a logical host (denoting itself). (Note that because the representation of a logical host is implementation-dependent, it is possible that an implementation might represent a logical host as the string that names it.) logical pathname n. an object of type logical-pathname. long float n. an object of type long-float. loop keyword n. Trad. a symbol that is a specially recognized part of the syntax of an extended loop form. Such symbols are recognized by their name (using string=), not by their identity; as such, they may be in any package. A loop keyword is not a keyword. lowercase adj. (of a character) being among standard characters corresponding to the small letters a through z, or being some other implementation-defined character that is defined by the implementation to be lowercase. See *note Characters With Case::. M - macro n. 1. a macro form 2. a macro function. 3. a macro name. macro character n. a character which, when encountered by the Lisp reader in its main dispatch loop, introduces a reader macro_1. (Macro characters have nothing to do with macros.) macro expansion n. 1. the process of translating a macro form into another form. 2. the form resulting from this process. macro form n. a form that stands for another form (e.g., for the purposes of abstraction, information hiding, or syntactic convenience); that is, either a compound form whose first element is a macro name, or a form that is a symbol that names a symbol macro. macro function n. a function of two arguments, a form and an environment, that implements macro expansion by producing a form to be evaluated in place of the original argument form. macro lambda list n. an extended lambda list used in forms that establish macro definitions, such as defmacro and macrolet. See *note Macro Lambda Lists::. macro name n. a name for which macro-function returns true and which when used as the first element of a compound form identifies that form as a macro form. macroexpand hook n. the function that is the value of *macroexpand-hook*. mapping n. 1. a type of iteration in which a function is successively applied to objects taken from corresponding entries in collections such as sequences or hash tables. 2. Math. a relation between two sets in which each element of the first set (the "domain") is assigned one element of the second set (the "range"). metaclass n. 1. a class whose instances are classes. 2. (of an object) the class of the class of the object. Metaobject Protocol n. one of many possible descriptions of how a conforming implementation might implement various aspects of the object system. This description is beyond the scope of this document, and no conforming implementation is required to adhere to it except as noted explicitly in this specification. Nevertheless, its existence helps to establish normative practice, and implementors with no reason to diverge from it are encouraged to consider making their implementation adhere to it where possible. It is described in detail in The Art of the Metaobject Protocol. method n. an object that is part of a generic function and which provides information about how that generic function should behave when its arguments are objects of certain classes or with certain identities. method combination n. 1. generally, the composition of a set of methods to produce an effective method for a generic function. 2. an object of type method-combination, which represents the details of how the method combination_1 for one or more specific generic functions is to be performed. method-defining form n. a form that defines a method for a generic function, whether explicitly or implicitly. See *note Introduction to Generic Functions::. method-defining operator n. an operator corresponding to a method-defining form. See Figure~7-1. minimal compilation n. actions the compiler must take at compile time. See *note Compilation Semantics::. modified lambda list n. a list resembling an ordinary lambda list in form and purpose, but which deviates in syntax or functionality from the definition of an ordinary lambda list. See ordinary lambda list. "deftype uses a modified lambda list." most recent adj. innermost; that is, having been established (and not yet disestablished) more recently than any other of its kind. multiple escape n., adj. 1. n. the syntax type of a character that is used in pairs to indicate that the enclosed characters are to be treated as alphabetic_2 characters with their case preserved. For details, see *note Multiple Escape Characters::. 2. adj. (of a character) having the multiple escape syntax type. 3. n. a multiple escape_2 character. (In the standard readtable, vertical-bar is a multiple escape character.) multiple values n. 1. more than one value. "The function truncate returns multiple values." 2. a variable number of values, possibly including zero or one. "The function values returns multiple values." 3. a fixed number of values other than one. "The macro multiple-value-bind is among the few operators in Common Lisp which can detect and manipulate multiple values." N - name n., v.t. 1. n. an identifier by which an object, a binding, or an exit point is referred to by association using a binding. 2. v.t. to give a name to. 3. n. (of an object having a name component) the object which is that component. "The string which is a symbol's name is returned by symbol-name." 4. n. (of a pathname) a. the name component, returned by pathname-name. b. the entire namestring, returned by namestring. 5. n. (of a character) a string that names the character and that has length greater than one. (All non-graphic characters are required to have names unless they have some implementation-defined attribute which is not null. Whether or not other characters have names is implementation-dependent.) named constant n. a variable that is defined by Common Lisp, by the implementation, or by user code (see the macro defconstant) to always yield the same value when evaluated. "The value of a named constant may not be changed by assignment or by binding." namespace n. 1. bindings whose denotations are restricted to a particular kind. "The bindings of names to tags is the tag namespace." 2. any mapping whose domain is a set of names. "A package defines a namespace." namestring n. a string that represents a filename using either the standardized notation for naming logical pathnames described in *note Syntax of Logical Pathname Namestrings::, or some implementation-defined notation for naming a physical pathname. newline n. the standard character , notated for the Lisp reader as #\Newline. next method n. the next method to be invoked with respect to a given method for a particular set of arguments or argument classes. See *note Applying method combination to the sorted list of applicable methods::. nickname n. (of a package) one of possibly several names that can be used to refer to the package but that is not the primary name of the package. nil n. the object that is at once the symbol named "NIL" in the COMMON-LISP package, the empty list, the boolean (or generalized boolean) representing false, and the name of the empty type. non-atomic adj. being other than an atom; i.e., being a cons. non-constant variable n. a variable that is not a constant variable. non-correctable adj. (of an error) not intentionally correctable. (Because of the dynamic nature of restarts, it is neither possible nor generally useful to completely prohibit an error from being correctable. This term is used in order to express an intent that no special effort should be made by code signaling an error to make that error correctable; however, there is no actual requirement on conforming programs or conforming implementations imposed by this term.) non-empty adj. having at least one element. non-generic function n. a function that is not a generic function. non-graphic adj. (of a character) not graphic. See *note Graphic Characters::. non-list n., adj. other than a list; i.e., a non-nil atom. non-local exit n. a transfer of control (and sometimes values) to an exit point for reasons other than a normal return. "The operators go, throw, and return-from cause a non-local exit." non-nil n., adj. not nil. Technically, any object which is not nil can be referred to as true, but that would tend to imply a unique view of the object as a generalized boolean. Referring to such an object as non-nil avoids this implication. non-null lexical environment n. a lexical environment that has additional information not present in the global environment, such as one or more bindings. non-simple adj. not simple. non-terminating adj. (of a macro character) being such that it is treated as a constituent character when it appears in the middle of an extended token. See *note Reader Algorithm::. non-top-level form n. a form that, by virtue of its position as a subform of another form, is not a top level form. See *note Processing of Top Level Forms::. normal return n. the natural transfer of control and values which occurs after the complete execution of a form. normalized adj., ANSI, IEEE (of a float) conforming to the description of "normalized" as described by IEEE Standard for Binary Floating-Point Arithmetic. See denormalized. null adj., n. 1. adj. a. (of a list) having no elements: empty. See empty list. b. (of a string) having a length of zero. (It is common, both within this document and in observed spoken behavior, to refer to an empty string by an apparent definite reference, as in "the null string" even though no attempt is made to intern_2 null strings. The phrase "a null string" is technically more correct, but is generally considered awkward by most Lisp programmers. As such, the phrase "the null string" should be treated as an indefinite reference in all cases except for anaphoric references.) c. (of an implementation-defined attribute of a character) An object to which the value of that attribute defaults if no specific value was requested. 2. n. an object of type null (the only such object being nil). null lexical environment n. the lexical environment which has no bindings. number n. an object of type number. numeric adj. (of a character) being one of the standard characters 0 through 9, or being some other graphic character defined by the implementation to be numeric. O - object n. 1. any Lisp datum. "The function cons creates an object which refers to two other objects." 2. (immediately following the name of a type) an object which is of that type, used to emphasize that the object is not just a name for an object of that type but really an element of the type in cases where objects of that type (such as function or class) are commonly referred to by name. "The function symbol-function takes a function name and returns a function object." object-traversing adj. operating in succession on components of an object. "The operators mapcar, maphash, with-package-iterator and count perform object-traversing operations." open adj., v.t. (a file) 1. v.t. to create and return a stream to the file. 2. adj. (of a stream) having been opened_1, but not yet closed. operator n. 1. a function, macro, or special operator. 2. a symbol that names such a function, macro, or special operator. 3. (in a function special form) the cadr of the function special form, which might be either an operator_2 or a lambda expression. 4. (of a compound form) the car of the compound form, which might be either an operator_2 or a lambda expression, and which is never (setf symbol). optimize quality n. one of several aspects of a program that might be optimizable by certain compilers. Since optimizing one such quality might conflict with optimizing another, relative priorities for qualities can be established in an optimize declaration. The standardized optimize qualities are compilation-speed (speed of the compilation process), debug (ease of debugging), safety (run-time error checking), space (both code size and run-time space), and speed (of the object code). Implementations may define additional optimize qualities. optional parameter n. A parameter for which a corresponding positional argument is optional. If the argument is not supplied, a default value is used. See also supplied-p parameter. ordinary function n. a function that is not a generic function. ordinary lambda list n. the kind of lambda list used by lambda. See modified lambda list and extended lambda list. "defun uses an ordinary lambda list." otherwise inaccessible part n. (of an object, O_1) an object, O_2, which would be made inaccessible if O_1 were made inaccessible. (Every object is an otherwise inaccessible part of itself.) output adj. (of a stream) supporting output operations (i.e., being a "data sink"). An output stream might also be an input stream, in which case it is sometimes called a bidirectional stream. See the function output-stream-p. P - package n. an object of type package. package cell n. Trad. (of a symbol) The place in a symbol that holds one of possibly several packages in which the symbol is interned, called the home package, or which holds nil if no such package exists or is known. See the function symbol-package. package designator n. a designator for a package; that is, an object that denotes a package and that is one of: a string designator (denoting the package that has the string that it designates as its name or as one of its nicknames), or a package (denoting itself). package marker n. a character which is used in the textual notation for a symbol to separate the package name from the symbol name, and which is colon in the standard readtable. See *note Character Syntax::. package prefix n. a notation preceding the name of a symbol in text that is processed by the Lisp reader, which uses a package name followed by one or more package markers, and which indicates that the symbol is looked up in the indicated package. package registry n. A mapping of names to package objects. It is possible for there to be a package object which is not in this mapping; such a package is called an unregistered package. Operators such as find-package consult this mapping in order to find a package from its name. Operators such as do-all-symbols, find-all-symbols, and list-all-packages operate only on packages that exist in the package registry. pairwise adv. (of an adjective on a set) applying individually to all possible pairings of elements of the set. "The types A, B, and C are pairwise disjoint if A and B are disjoint, B and C are disjoint, and A and C are disjoint." parallel adj. Trad. (of binding or assignment) done in the style of psetq, let, or do; that is, first evaluating all of the forms that produce values, and only then assigning or binding the variables (or places). Note that this does not imply traditional computational "parallelism" since the forms that produce values are evaluated sequentially. See sequential. parameter n. 1. (of a function) a variable in the definition of a function which takes on the value of a corresponding argument (or of a list of corresponding arguments) to that function when it is called, or which in some cases is given a default value because there is no corresponding argument. 2. (of a format directive) an object received as data flow by a format directive due to a prefix notation within the format string at the format directive's point of use. See *note Formatted Output::. "In "~3,'0D", the number 3 and the character #\0 are parameters to the ~D format directive." parameter specializer n. 1. (of a method) an expression which constrains the method to be applicable only to argument sequences in which the corresponding argument matches the parameter specializer. 2. a class, or a list (eql object). parameter specializer name n. 1. (of a method definition) an expression used in code to name a parameter specializer. See *note Introduction to Methods::. 2. a class, a symbol naming a class, or a list (eql form). pathname n. an object of type pathname, which is a structured representation of the name of a file. A pathname has six components: a "host," a "device," a "directory," a "name," a "type," and a "version." pathname designator n. a designator for a pathname; that is, an object that denotes a pathname and that is one of: a pathname namestring (denoting the corresponding pathname), a stream associated with a file (denoting the pathname used to open the file; this may be, but is not required to be, the actual name of the file), or a pathname (denoting itself). See *note File Operations on Open and Closed Streams::. physical pathname n. a pathname that is not a logical pathname. [Editorial Note by KMP: Still need to reconcile some confusion in the uses of "generalized reference" and "place." I think one was supposed to refer to the abstract concept, and the other to an object (a form), but the usages have become blurred.] place n. 1. a form which is suitable for use as a generalized reference. 2. the conceptual location referred to by such a place_1. plist pronounced 'p\=e ,list n. a property list. portable adj. (of code) required to produce equivalent results and observable side effects in all conforming implementations. potential copy n. (of an object O_1 subject to constriants) an object O_2 that if the specified constraints are satisfied by O_1 without any modification might or might not be identical to O_1, or else that must be a fresh object that resembles a copy of O_1 except that it has been modified as necessary to satisfy the constraints. potential number n. A textual notation that might be parsed by the Lisp reader in some conforming implementation as a number but is not required to be parsed as a number. No object is a potential number--either an object is a number or it is not. See *note Potential Numbers as Tokens::. pprint dispatch table n. an object that can be the value of *print-pprint-dispatch* and hence can control how objects are printed when *print-pretty* is true. See *note Pretty Print Dispatch Tables::. predicate n. a function that returns a generalized boolean as its first value. present n. 1. (of a feature in a Lisp image) a state of being that is in effect if and only if the symbol naming the feature is an element of the features list. 2. (of a symbol in a package) being accessible in that package directly, rather than being inherited from another package. pretty print v.t. (an object) to invoke the pretty printer on the object. pretty printer n. the procedure that prints the character representation of an object onto a stream when the value of *print-pretty* is true, and that uses layout techniques (e.g., indentation) that tend to highlight the structure of the object in a way that makes it easier for human readers to parse visually. See the variable *print-pprint-dispatch* and *note The Lisp Pretty Printer::. pretty printing stream n. a stream that does pretty printing. Such streams are created by the function pprint-logical-block as a link between the output stream and the logical block. primary method n. a member of one of two sets of methods (the set of auxiliary methods is the other) that form an exhaustive partition of the set of methods on the method's generic function. How these sets are determined is dependent on the method combination type; see *note Introduction to Methods::. primary value n. (of values resulting from the evaluation of a form) the first value, if any, or else nil if there are no values. "The primary value returned by truncate is an integer quotient, truncated toward zero." principal adj. (of a value returned by a Common Lisp function that implements a mathematically irrational or transcendental function defined in the complex domain) of possibly many (sometimes an infinite number of) correct values for the mathematical function, being the particular value which the corresponding Common Lisp function has been defined to return. print name n. Trad. (usually of a symbol) a name_3. printer control variable n. a variable whose specific purpose is to control some action of the Lisp printer; that is, one of the variables in Figure~22-1, or else some implementation-defined variable which is defined by the implementation to be a printer control variable. printer escaping n. The combined state of the printer control variables *print-escape* and *print-readably*. If the value of either *print-readably* or *print-escape* is true, then printer escaping is "enabled"; otherwise (if the values of both *print-readably* and *print-escape* are false), then printer escaping is "disabled". printing adj. (of a character) being a graphic character other than space. process v.t. (a form by the compiler) to perform minimal compilation, determining the time of evaluation for a form, and possibly evaluating that form (if required). processor n., ANSI an implementation. proclaim v.t. (a proclamation) to establish that proclamation. proclamation n. a global declaration. prog tag n. Trad. a go tag. program n. Trad. Common Lisp code. programmer n. an active entity, typically a human, that writes a program, and that might or might not also be a user of the program. programmer code n. code that is supplied by the programmer; that is, code that is not system code. proper list n. A list terminated by the empty list. (The empty list is a proper list.) See improper list. proper name n. (of a class) a symbol that names the class whose name is that symbol. See the functions class-name and find-class. proper sequence n. a sequence which is not an improper list; that is, a vector or a proper list. proper subtype n. (of a type) a subtype of the type which is not the same type as the type (i.e., its elements are a "proper subset" of the type). property n. (of a property list) 1. a conceptual pairing of a property indicator and its associated property value on a property list. 2. a property value. property indicator n. (of a property list) the name part of a property, used as a key when looking up a property value on a property list. property list n. 1. a list containing an even number of elements that are alternating names (sometimes called indicators or keys) and values (sometimes called properties). When there is more than one name and value pair with the identical name in a property list, the first such pair determines the property. 2. (of a symbol) the component of the symbol containing a property list. property value n. (of a property indicator on a property list) the object associated with the property indicator on the property list. purports to conform v. makes a good-faith claim of conformance. This term expresses intention to conform, regardless of whether the goal of that intention is realized in practice. For example, language implementations have been known to have bugs, and while an implementation of this specification with bugs might not be a conforming implementation, it can still purport to conform. This is an important distinction in certain specific cases; e.g., see the variable *features*. Q - qualified method n. a method that has one or more qualifiers. qualifier n. (of a method for a generic function) one of possibly several objects used to annotate the method in a way that identifies its role in the method combination. The method combination type determines how many qualifiers are permitted for each method, which qualifiers are permitted, and the semantics of those qualifiers. query I/O n. the bidirectional stream that is the value of the variable *query-io*. quoted object n. an object which is the second element of a quote form. R - radix n. an integer between 2 and 36, inclusive, which can be used to designate a base with respect to which certain kinds of numeric input or output are performed. (There are n valid digit characters for any given radix n, and those digits are the first n digits in the sequence 0, 1, ..., 9, A, B, ..., Z, which have the weights 0, 1, ..., 9, 10, 11, ..., 35, respectively. Case is not significant in parsing numbers of radix greater than 10, so "9b8a" and "9B8A" denote the same radix 16 number.) random state n. an object of type random-state. rank n. a non-negative integer indicating the number of dimensions of an array. ratio n. an object of type ratio. ratio marker n. a character which is used in the textual notation for a ratio to separate the numerator from the denominator, and which is slash in the standard readtable. See *note Character Syntax::. rational n. an object of type rational. read v.t. 1. (a binding or slot or component) to obtain the value of the binding or slot. 2. (an object from a stream) to parse an object from its representation on the stream. readably adv. (of a manner of printing an object O_1) in such a way as to permit the Lisp Reader to later parse the printed output into an object O_2 that is similar to O_1. reader n. 1. a function that reads_1 a variable or slot. 2. the Lisp reader. reader macro n. 1. a textual notation introduced by dispatch on one or two characters that defines special-purpose syntax for use by the Lisp reader, and that is implemented by a reader macro function. See *note Reader Algorithm::. 2. the character or characters that introduce a reader macro_1; that is, a macro character or the conceptual pairing of a dispatching macro character and the character that follows it. (A reader macro is not a kind of macro.) reader macro function n. a function designator that denotes a function that implements a reader macro_2. See the functions set-macro-character and set-dispatch-macro-character. readtable n. an object of type readtable. readtable case n. an attribute of a readtable whose value is a case sensitivity mode, and that selects the manner in which characters in a symbol's name are to be treated by the Lisp reader and the Lisp printer. See *note Effect of Readtable Case on the Lisp Reader:: and *note Effect of Readtable Case on the Lisp Printer::. readtable designator n. a designator for a readtable; that is, an object that denotes a readtable and that is one of: nil (denoting the standard readtable), or a readtable (denoting itself). recognizable subtype n. (of a type) a subtype of the type which can be reliably detected to be such by the implementation. See the function subtypep. reference n., v.t. 1. n. an act or occurrence of referring to an object, a binding, an exit point, a tag, or an environment. 2. v.t. to refer to an object, a binding, an exit point, a tag, or an environment, usually by name. registered package n. a package object that is installed in the package registry. (Every registered package has a name that is a string, as well as zero or more string nicknames. All packages that are initially specified by Common Lisp or created by make-package or defpackage are registered packages. Registered packages can be turned into unregistered packages by delete-package.) relative adj. 1. (of a time) representing an offset from an absolute time in the units appropriate to that time. For example, a relative internal time is the difference between two absolute internal times, and is measured in internal time units. 2. (of a pathname) representing a position in a directory hierarchy by motion from a position other than the root, which might therefore vary. "The notation #P"../foo.text" denotes a relative pathname if the host file system is Unix." See absolute. repertoire n., ISO a subtype of character. See *note Character Repertoires::. report n. (of a condition) to call the function print-object on the condition in an environment where the value of *print-escape* is false. report message n. the text that is output by a condition reporter. required parameter n. A parameter for which a corresponding positional argument must be supplied when calling the function. rest list n. (of a function having a rest parameter) The list to which the rest parameter is bound on some particular call to the function. rest parameter n. A parameter which was introduced by &rest. restart n. an object of type restart. restart designator n. a designator for a restart; that is, an object that denotes a restart and that is one of: a non-nil symbol (denoting the most recently established active restart whose name is that symbol), or a restart (denoting itself). restart function n. a function that invokes a restart, as if by invoke-restart. The primary purpose of a restart function is to provide an alternate interface. By convention, a restart function usually has the same name as the restart which it invokes. Figure 26-4 shows a list of the standardized restart functions. abort muffle-warning use-value continue store-value Figure 26-4: Standardized Restart Functions return v.t. (of values) 1. (from a block) to transfer control and values from the block; that is, to cause the block to yield the values immediately without doing any further evaluation of the forms in its body. 2. (from a form) to yield the values. return value n. Trad. a value_1 right-parenthesis n. the standard character ")", that is variously called "right parenthesis" or "close parenthesis" See Figure~2-5. run time n. 1. load time 2. execution time run-time compiler n. refers to the compile function or to implicit compilation, for which the compilation and run-time environments are maintained in the same Lisp image. run-time definition n. a definition in the run-time environment. run-time environment n. the environment in which a program is executed. S - safe adj. 1. (of code) processed in a lexical environment where the the highest safety level (3) was in effect. See optimize. 2. (of a call) a safe call. safe call n. a call in which the call, the function being called, and the point of functional evaluation are all safe_1 code. For more detailed information, see *note Safe and Unsafe Calls::. same adj. 1. (of objects under a specified predicate) indistinguishable by that predicate. "The symbol car, the string "car", and the string "CAR" are the same under string-equal". 2. (of objects if no predicate is implied by context) indistinguishable by eql. Note that eq might be capable of distinguishing some numbers and characters which eql cannot distinguish, but the nature of such, if any, is implementation-dependent. Since eq is used only rarely in this specification, eql is the default predicate when none is mentioned explicitly. "The conses returned by two successive calls to cons are never the same." 3. (of types) having the same set of elements; that is, each type is a subtype of the others. "The types specified by (integer 0 1), (unsigned-byte 1), and bit are the same." satisfy the test v. (of an object being considered by a sequence function) 1. (for a one argument test) to be in a state such that the function which is the predicate argument to the sequence function returns true when given a single argument that is the result of calling the sequence function's key argument on the object being considered. See *note Satisfying a One-Argument Test::. 2. (for a two argument test) to be in a state such that the two-place predicate which is the sequence function's test argument returns true when given a first argument that is the object being considered, and when given a second argument that is the result of calling the sequence function's key argument on an element of the sequence function's sequence argument which is being tested for equality; or to be in a state such that the test-not function returns false given the same arguments. See *note Satisfying a Two-Argument Test::. scope n. the structural or textual region of code in which references to an object, a binding, an exit point, a tag, or an environment (usually by name) can occur. script n. ISO one of possibly several sets that form an exhaustive partition of the type character. See *note Character Scripts::. secondary value n. (of values resulting from the evaluation of a form) the second value, if any, or else nil if there are fewer than two values. "The secondary value returned by truncate is a remainder." section n. a partitioning of output by a conditional newline on a pretty printing stream. See *note Dynamic Control of the Arrangement of Output::. self-evaluating object n. an object that is neither a symbol nor a cons. If a self-evaluating object is evaluated, it yields itself as its only value. "Strings are self-evaluating objects." semi-standard adj. (of a language feature) not required to be implemented by any conforming implementation, but nevertheless recommended as the canonical approach in situations where an implementation does plan to support such a feature. The presence of semi-standard aspects in the language is intended to lessen portability problems and reduce the risk of gratuitous divergence among implementations that might stand in the way of future standardization. semicolon n. the standard character that is called "semicolon" (;). See Figure~2-5. sequence n. 1. an ordered collection of elements 2. a vector or a list. sequence function n. one of the functions in Figure~17-1, or an implementation-defined function that operates on one or more sequences. and that is defined by the implementation to be a sequence function. sequential adj. Trad. (of binding or assignment) done in the style of setq, let*, or do*; that is, interleaving the evaluation of the forms that produce values with the assignments or bindings of the variables (or places). See parallel. sequentially adv. in a sequential way. serious condition n. a condition of type serious-condition, which represents a situation that is generally sufficiently severe that entry into the debugger should be expected if the condition is signaled but not handled. session n. the conceptual aggregation of events in a Lisp image from the time it is started to the time it is terminated. set v.t. Trad. (any variable or a symbol that is the name of a dynamic variable) to assign the variable. setf expander n. a function used by setf to compute the setf expansion of a place. setf expansion n. a set of five expressions_1 that, taken together, describe how to store into a place and which subforms of the macro call associated with the place are evaluated. See *note Setf Expansions::. setf function n. a function whose name is (setf symbol). setf function name n. (of a symbol S) the list (setf S). shadow v.t. 1. to override the meaning of. "That binding of X shadows an outer one." 2. to hide the presence of. "That macrolet of F shadows the outer flet of F." 3. to replace. "That package shadows the symbol cl:car with its own symbol car." shadowing symbol n. (in a package) an element of the package's shadowing symbols list. shadowing symbols list n. (of a package) a list, associated with the package, of symbols that are to be exempted from 'symbol conflict errors' detected when packages are used. See the function package-shadowing-symbols. shared slot n. (of a class) a slot accessible in more than one instance of a class; specifically, such a slot is accessible in all direct instances of the class and in those indirect instances whose class does not shadow_1 the slot. sharpsign n. the standard character that is variously called "number sign," "sharp," or "sharp sign" (#). See Figure~2-5. short float n. an object of type short-float. sign n. one of the standard characters "+" or "-". signal v. to announce, using a standard protocol, that a particular situation, represented by a condition, has been detected. See *note Condition System Concepts::. signature n. (of a method) a description of the parameters and parameter specializers for the method which determines the method's applicability for a given set of required arguments, and which also describes the argument conventions for its other, non-required arguments. similar adj. (of two objects) defined to be equivalent under the similarity relationship. similarity n. a two-place conceptual equivalence predicate, which is independent of the Lisp image so that two objects in different Lisp images can be understood to be equivalent under this predicate. See *note Literal Objects in Compiled Files::. simple adj. 1. (of an array) being of type simple-array. 2. (of a character) having no implementation-defined attributes, or else having implementation-defined attributes each of which has the null value for that attribute. simple array n. an array of type simple-array. simple bit array n. a bit array that is a simple array; that is, an object of type (simple-array bit). simple bit vector n. a bit vector of type simple-bit-vector. simple condition n. a condition of type simple-condition. simple general vector n. a simple vector. simple string n. a string of type simple-string. simple vector n. a vector of type simple-vector, sometimes called a "simple general vector." Not all vectors that are simple are simple vectors--only those that have element type t. single escape n., adj. 1. n. the syntax type of a character that indicates that the next character is to be treated as an alphabetic_2 character with its case preserved. For details, see *note Single Escape Character::. 2. adj. (of a character) having the single escape syntax type. 3. n. a single escape_2 character. (In the standard readtable, slash is the only single escape.) single float n. an object of type single-float. single-quote n. the standard character that is variously called "apostrophe," "acute accent," "quote," or "single quote" ('). See Figure~2-5. singleton adj. (of a sequence) having only one element. "(list 'hello) returns a singleton list." situation n. the evaluation of a form in a specific environment. slash n. the standard character that is variously called "solidus" or "slash" (/). See Figure~2-5. slot n. a component of an object that can store a value. slot specifier n. a representation of a slot that includes the name of the slot and zero or more slot options. A slot option pertains only to a single slot. source code n. code representing objects suitable for evaluation (e.g., objects created by read, by macro expansion, or by compiler macro expansion). source file n. a file which contains a textual representation of source code, that can be edited, loaded, or compiled. space n. the standard character , notated for the Lisp reader as #\Space. special form n. a list, other than a macro form, which is a form with special syntax or special evaluation rules or both, possibly manipulating the evaluation environment or control flow or both. The first element of a special form is a special operator. special operator n. one of a fixed set of symbols, enumerated in Figure~3-2, that may appear in the car of a form in order to identify the form as a special form. special variable n. Trad. a dynamic variable. specialize v.t. (a generic function) to define a method for the generic function, or in other words, to refine the behavior of the generic function by giving it a specific meaning for a particular set of classes or arguments. specialized adj. 1. (of a generic function) having methods which specialize the generic function. 2. (of an array) having an actual array element type that is a proper subtype of the type t; see *note Array Elements::. "(make-array 5 :element-type 'bit) makes an array of length five that is specialized for bits." specialized lambda list n. an extended lambda list used in forms that establish method definitions, such as defmethod. See *note Specialized Lambda Lists::. spreadable argument list designator n. a designator for a list of objects; that is, an object that denotes a list and that is a non-null list L1 of length n, whose last element is a list L2 of length m (denoting a list L3 of length m+n-1 whose elements are L1_i for i < n-1 followed by L2_j for j < m). "The list (1 2 (3 4 5)) is a spreadable argument list designator for the list (1 2 3 4 5)." stack allocate v.t. Trad. to allocate in a non-permanent way, such as on a stack. Stack-allocation is an optimization technique used in some implementations for allocating certain kinds of objects that have dynamic extent. Such objects are allocated on the stack rather than in the heap so that their storage can be freed as part of unwinding the stack rather than taking up space in the heap until the next garbage collection. What types (if any) can have dynamic extent can vary from implementation to implementation. No implementation is ever required to perform stack-allocation. stack-allocated adj. Trad. having been stack allocated. standard character n. a character of type standard-char, which is one of a fixed set of 96 such characters required to be present in all conforming implementations. See *note Standard Characters::. standard class n. a class that is a generalized instance of class standard-class. standard generic function a function of type standard-generic-function. standard input n. the input stream which is the value of the dynamic variable *standard-input*. standard method combination n. the method combination named standard. standard object n. an object that is a generalized instance of class standard-object. standard output n. the output stream which is the value of the dynamic variable *standard-output*. standard pprint dispatch table n. A pprint dispatch table that is different from the initial pprint dispatch table, that implements pretty printing as described in this specification, and that, unlike other pprint dispatch tables, must never be modified by any program. (Although the definite reference "the standard pprint dispatch table" is generally used within this document, it is actually implementation-dependent whether a single object fills the role of the standard pprint dispatch table, or whether there might be multiple such objects, any one of which could be used on any given occasion where "the standard pprint dispatch table" is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.) standard readtable n. A readtable that is different from the initial readtable, that implements the expression syntax defined in this specification, and that, unlike other readtables, must never be modified by any program. (Although the definite reference "the standard readtable" is generally used within this document, it is actually implementation-dependent whether a single object fills the role of the standard readtable, or whether there might be multiple such objects, any one of which could be used on any given occasion where "the standard readtable" is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.) standard syntax n. the syntax represented by the standard readtable and used as a reference syntax throughout this document. See *note Character Syntax::. standardized adj. (of a name, object, or definition) having been defined by Common Lisp. "All standardized variables that are required to hold bidirectional streams have "-io*" in their name." startup environment n. the global environment of the running Lisp image from which the compiler was invoked. step v.t., n. 1. v.t. (an iteration variable) to assign the variable a new value at the end of an iteration, in preparation for a new iteration. 2. n. the code that identifies how the next value in an iteration is to be computed. 3. v.t. (code) to specially execute the code, pausing at intervals to allow user confirmation or intervention, usually for debugging. stream n. an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation. stream associated with a file n. a file stream, or a synonym stream the target of which is a stream associated with a file. Such a stream cannot be created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, or make-string-output-stream. stream designator n. a designator for a stream; that is, an object that denotes a stream and that is one of: t (denoting the value of *terminal-io*), nil (denoting the value of *standard-input* for input stream designators or denoting the value of *standard-output* for output stream designators), or a stream (denoting itself). stream element type n. (of a stream) the type of data for which the stream is specialized. stream variable n. a variable whose value must be a stream. stream variable designator n. a designator for a stream variable; that is, a symbol that denotes a stream variable and that is one of: t (denoting *terminal-io*), nil (denoting *standard-input* for input stream variable designators or denoting *standard-output* for output stream variable designators), or some other symbol (denoting itself). string n. a specialized vector that is of type string, and whose elements are of type character or a subtype of type character. string designator n. a designator for a string; that is, an object that denotes a string and that is one of: a character (denoting a singleton string that has the character as its only element), a symbol (denoting the string that is its name), or a string (denoting itself). The intent is that this term be consistent with the behavior of string; implementations that extend string must extend the meaning of this term in a compatible way. string equal adj. the same under string-equal. string stream n. a stream of type string-stream. structure n. an object of type structure-object. structure class n. a class that is a generalized instance of class structure-class. structure name n. a name defined with defstruct. Usually, such a type is also a structure class, but there may be implementation-dependent situations in which this is not so, if the :type option to defstruct is used. style warning n. a condition of type style-warning. subclass n. a class that inherits from another class, called a superclass. (No class is a subclass of itself.) subexpression n. (of an expression) an expression that is contained within the expression. (In fact, the state of being a subexpression is not an attribute of the subexpression, but really an attribute of the containing expression since the same object can at once be a subexpression in one context, and not in another.) subform n. (of a form) an expression that is a subexpression of the form, and which by virtue of its position in that form is also a form. "(f x) and x, but not exit, are subforms of (return-from exit (f x))." subrepertoire n. a subset of a repertoire. subtype n. a type whose membership is the same as or a proper subset of the membership of another type, called a supertype. (Every type is a subtype of itself.) superclass n. a class from which another class (called a subclass) inherits. (No class is a superclass of itself.) See subclass. supertype n. a type whose membership is the same as or a proper superset of the membership of another type, called a subtype. (Every type is a supertype of itself.) See subtype. supplied-p parameter n. a parameter which recieves its generalized boolean value implicitly due to the presence or absence of an argument corresponding to another parameter (such as an optional parameter or a rest parameter). See *note Ordinary Lambda Lists::. symbol n. an object of type symbol. symbol macro n. a symbol that stands for another form. See the macro symbol-macrolet. synonym stream n. 1. a stream of type synonym-stream, which is consequently a stream that is an alias for another stream, which is the value of a dynamic variable whose name is the synonym stream symbol of the synonym stream. See the function make-synonym-stream. 2. (to a stream) a synonym stream which has the stream as the value of its synonym stream symbol. 3. (to a symbol) a synonym stream which has the symbol as its synonym stream symbol. synonym stream symbol n. (of a synonym stream) the symbol which names the dynamic variable which has as its value another stream for which the synonym stream is an alias. syntax type n. (of a character) one of several classifications, enumerated in Figure~2-6, that are used for dispatch during parsing by the Lisp reader. See *note Character Syntax Types::. system class n. a class that may be of type built-in-class in a conforming implementation and hence cannot be inherited by classes defined by conforming programs. system code n. code supplied by the implementation to implement this specification (e.g., the definition of mapcar) or generated automatically in support of this specification (e.g., during method combination); that is, code that is not programmer code. T - t n. 1. a. the boolean representing true. b. the canonical generalized boolean representing true. (Although any object other than nil is considered true as a generalized boolean, t is generally used when there is no special reason to prefer one such object over another.) 2. the name of the type to which all objects belong--the supertype of all types (including itself). 3. the name of the superclass of all classes except itself. tag n. 1. a catch tag. 2. a go tag. tail n. (of a list) an object that is the same as either some cons which makes up that list or the atom (if any) which terminates the list. "The empty list is a tail of every proper list." target n. 1. (of a constructed stream) a constituent of the constructed stream. "The target of a synonym stream is the value of its synonym stream symbol." 2. (of a displaced array) the array to which the displaced array is displaced. (In the case of a chain of constructed streams or displaced arrays, the unqualified term "target" always refers to the immediate target of the first item in the chain, not the immediate target of the last item.) terminal I/O n. the bidirectional stream that is the value of the variable *terminal-io*. terminating n. (of a macro character) being such that, if it appears while parsing a token, it terminates that token. See *note Reader Algorithm::. tertiary value n. (of values resulting from the evaluation of a form) the third value, if any, or else nil if there are fewer than three values. throw v. to transfer control and values to a catch. See the special operator throw. tilde n. the standard character that is called "tilde" (~). See Figure~2-5. time a representation of a point (absolute time) or an interval (relative time) on a time line. See decoded time, internal time, and universal time. time zone n. a rational multiple of 1/3600 between -24 (inclusive) and 24 (inclusive) that represents a time zone as a number of hours offset from Greenwich Mean Time. Time zone values increase with motion to the west, so Massachusetts, U.S.A. is in time zone 5, California, U.S.A. is time zone 8, and Moscow, Russia is time zone -3. (When "daylight savings time" is separately represented as an argument or return value, the time zone that accompanies it does not depend on whether daylight savings time is in effect.) token n. a textual representation for a number or a symbol. See *note Interpretation of Tokens::. top level form n. a form which is processed specially by compile-file for the purposes of enabling compile time evaluation of that form. Top level forms include those forms which are not subforms of any other form, and certain other cases. See *note Processing of Top Level Forms::. trace output n. the output stream which is the value of the dynamic variable *trace-output*. tree n. 1. a binary recursive data structure made up of conses and atoms: the conses are themselves also trees (sometimes called "subtrees" or "branches"), and the atoms are terminal nodes (sometimes called leaves). Typically, the leaves represent data while the branches establish some relationship among that data. 2. in general, any recursive data structure that has some notion of "branches" and leaves. tree structure n. (of a tree_1) the set of conses that make up the tree. Note that while the car_{1b} component of each such cons is part of the tree structure, the objects that are the cars_2 of each cons in the tree are not themselves part of its tree structure unless they are also conses. true n. any object that is not false and that is used to represent the success of a predicate test. See t_1. truename n. 1. the canonical filename of a file in the file system. See *note Truenames::. 2. a pathname representing a truename_1. two-way stream n. a stream of type two-way-stream, which is a bidirectional composite stream that receives its input from an associated input stream and sends its output to an associated output stream. type n. 1. a set of objects, usually with common structure, behavior, or purpose. (Note that the expression "X is of type S_a" naturally implies that "X is of type S_b" if S_a is a subtype of S_b.) 2. (immediately following the name of a type) a subtype of that type. "The type vector is an array type." type declaration n. a declaration that asserts that every reference to a specified binding within the scope of the declaration results in some object of the specified type. type equivalent adj. (of two types X and Y) having the same elements; that is, X is a subtype of Y and Y is a subtype of X. type expand n. to fully expand a type specifier, removing any references to derived types. (Common Lisp provides no program interface to cause this to occur, but the semantics of Common Lisp are such that every implementation must be able to do this internally, and some situations involving type specifiers are most easily described in terms of a fully expanded type specifier.) type specifier n. an expression that denotes a type. "The symbol random-state, the list (integer 3 5), the list (and list (not null)), and the class named standard-class are type specifiers." U - unbound adj. not having an associated denotation in a binding. See bound. unbound variable n. a name that is syntactically plausible as the name of a variable but which is not bound in the variable namespace. undefined function n. a name that is syntactically plausible as the name of a function but which is not bound in the function namespace. unintern v.t. (a symbol in a package) to make the symbol not be present in that package. (The symbol might continue to be accessible by inheritance.) uninterned adj. (of a symbol) not accessible in any package; i.e., not interned_1. universal time n. time, represented as a non-negative integer number of seconds. Absolute universal time is measured as an offset from the beginning of the year 1900 (ignoring leap seconds). See *note Universal Time::. unqualified method n. a method with no qualifiers. unregistered package n. a package object that is not present in the package registry. An unregistered package has no name; i.e., its name is nil. See the function delete-package. unsafe adj. (of code) not safe. (Note that, unless explicitly specified otherwise, if a particular kind of error checking is guaranteed only in a safe context, the same checking might or might not occur in that context if it were unsafe; describing a context as unsafe means that certain kinds of error checking are not reliably enabled but does not guarantee that error checking is definitely disabled.) unsafe call n. a call that is not a safe call. For more detailed information, see *note Safe and Unsafe Calls::. upgrade v.t. (a declared type to an actual type) 1. (when creating an array) to substitute an actual array element type for an expressed array element type when choosing an appropriately specialized array representation. See the function upgraded-array-element-type. 2. (when creating a complex) to substitute an actual complex part type for an expressed complex part type when choosing an appropriately specialized complex representation. See the function upgraded-complex-part-type. upgraded array element type n. (of a type) a type that is a supertype of the type and that is used instead of the type whenever the type is used as an array element type for object creation or type discrimination. See *note Array Upgrading::. upgraded complex part type n. (of a type) a type that is a supertype of the type and that is used instead of the type whenever the type is used as a complex part type for object creation or type discrimination. See the function upgraded-complex-part-type. uppercase adj. (of a character) being among standard characters corresponding to the capital letters A through Z, or being some other implementation-defined character that is defined by the implementation to be uppercase. See *note Characters With Case::. use v.t. (a package P_1) to inherit the external symbols of P_1. (If a package P_2 uses P_1, the external symbols of P_1 become internal symbols of P_2 unless they are explicitly exported.) "The package CL-USER uses the package CL." use list n. (of a package) a (possibly empty) list associated with each package which determines what other packages are currently being used by that package. user n. an active entity, typically a human, that invokes or interacts with a program at run time, but that is not necessarily a programmer. V - valid array dimension n. a fixnum suitable for use as an array dimension. Such a fixnum must be greater than or equal to zero, and less than the value of array-dimension-limit. When multiple array dimensions are to be used together to specify a multi-dimensional array, there is also an implied constraint that the product of all of the dimensions be less than the value of array-total-size-limit. valid array index n. (of an array) a fixnum suitable for use as one of possibly several indices needed to name an element of the array according to a multi-dimensional Cartesian coordinate system. Such a fixnum must be greater than or equal to zero, and must be less than the corresponding dimension_1 of the array. (Unless otherwise explicitly specified, the phrase "a list of valid array indices" further implies that the length of the list must be the same as the rank of the array.) "For a 2 by~3 array, valid array indices for the first dimension are 0 and~1, and valid array indices for the second dimension are 0, 1 and~2." valid array row-major index n. (of an array, which might have any number of dimensions_2) a single fixnum suitable for use in naming any element of the array, by viewing the array's storage as a linear series of elements in row-major order. Such a fixnum must be greater than or equal to zero, and less than the array total size of the array. valid fill pointer n. (of an array) a fixnum suitable for use as a fill pointer for the array. Such a fixnum must be greater than or equal to zero, and less than or equal to the array total size of the array. [Editorial Note by KMP: The "valid pathname xxx" definitions were taken from text found in make-pathname, but look wrong to me. I'll fix them later.] valid logical pathname host n. a string that has been defined as the name of a logical host. See the function load-logical-pathname-translations. valid pathname device n. a string, nil, :unspecific, or some other object defined by the implementation to be a valid pathname device. valid pathname directory n. a string, a list of strings, nil, :wild, :unspecific, or some other object defined by the implementation to be a valid directory component. valid pathname host n. a valid physical pathname host or a valid logical pathname host. valid pathname name n. a string, nil, :wild, :unspecific, or some other object defined by the implementation to be a valid pathname name. valid pathname type n. a string, nil, :wild, :unspecific. valid pathname version n. a non-negative integer, or one of :wild, :newest, :unspecific, or nil. The symbols :oldest, :previous, and :installed are semi-standard special version symbols. valid physical pathname host n. any of a string, a list of strings, or the symbol :unspecific, that is recognized by the implementation as the name of a host. valid sequence index n. (of a sequence) an integer suitable for use to name an element of the sequence. Such an integer must be greater than or equal to zero, and must be less than the length of the sequence. (If the sequence is an array, the valid sequence index is further constrained to be a fixnum.) value n. 1. a. one of possibly several objects that are the result of an evaluation. b. (in a situation where exactly one value is expected from the evaluation of a form) the primary value returned by the form. c. (of forms in an implicit progn) one of possibly several objects that result from the evaluation of the last form, or nil if there are no forms. 2. an object associated with a name in a binding. 3. (of a symbol) the value of the dynamic variable named by that symbol. 4. an object associated with a key in an association list, a property list, or a hash table. value cell n. Trad. (of a symbol) The place which holds the value, if any, of the dynamic variable named by that symbol, and which is accessed by symbol-value. See cell. variable n. a binding in which a symbol is the name used to refer to an object. vector n. a one-dimensional array. vertical-bar n. the standard character that is called "vertical bar" (|). See Figure~2-5. W - whitespace n. 1. one or more characters that are either the graphic character #\Space or else non-graphic characters such as #\Newline that only move the print position. 2. a. n. the syntax type of a character that is a token separator. For details, see *note Whitespace Characters::. b. adj. (of a character) having the whitespace_{2a} syntax type_2. c. n. a whitespace_{2b} character. wild adj. 1. (of a namestring) using an implementation-defined syntax for naming files, which might "match" any of possibly several possible filenames, and which can therefore be used to refer to the aggregate of the files named by those filenames. 2. (of a pathname) a structured representation of a name which might "match" any of possibly several pathnames, and which can therefore be used to refer to the aggregate of the files named by those pathnames. The set of wild pathnames includes, but is not restricted to, pathnames which have a component which is :wild, or which have a directory component which contains :wild or :wild-inferors. See the function wild-pathname-p. write v.t. 1. (a binding or slot or component) to change the value of the binding or slot. 2. (an object to a stream) to output a representation of the object to the stream. writer n. a function that writes_1 a variable or slot. Y - yield v.t. (values) to produce the values as the result of evaluation. "The form (+ 2 3) yields 5."  File: gcl.info, Node: Appendix, Prev: Glossary (Glossary), Up: Top 27 Appendix *********** * Menu: * Removed Language Features::  File: gcl.info, Node: Removed Language Features, Prev: Appendix, Up: Appendix 27.1 Removed Language Features ============================== * Menu: * Requirements for removed and deprecated features:: * Removed Types:: * Removed Operators:: * Removed Argument Conventions:: * Removed Variables:: * Removed Reader Syntax:: * Packages No Longer Required::  File: gcl.info, Node: Requirements for removed and deprecated features, Next: Removed Types, Prev: Removed Language Features, Up: Removed Language Features 27.1.1 Requirements for removed and deprecated features ------------------------------------------------------- For this standard, some features from the language described in Common Lisp: The Language have been removed, and others have been deprecated (and will most likely not appear in future Common Lisp standards). Which features were removed and which were deprecated was decided on a case-by-case basis by the X3J13 committee. Conforming implementations that wish to retain any removed features for compatibility must assure that such compatibility does not interfere with the correct function of conforming programs. For example, symbols corresponding to the names of removed functions may not appear in the the COMMON-LISP package. (Note, however, that this specification has been devised in such a way that there can be a package named LISP which can contain such symbols.) Conforming implementations must implement all deprecated features. For a list of deprecated features, see *note Deprecated Language Features::.  File: gcl.info, Node: Removed Types, Next: Removed Operators, Prev: Requirements for removed and deprecated features, Up: Removed Language Features 27.1.2 Removed Types -------------------- The type string-char was removed.  File: gcl.info, Node: Removed Operators, Next: Removed Argument Conventions, Prev: Removed Types, Up: Removed Language Features 27.1.3 Removed Operators ------------------------ The functions int-char , char-bits , char-font , make-char , char-bit , set-char-bit , string-char-p , and commonp were removed. The special operator compiler-let was removed.  File: gcl.info, Node: Removed Argument Conventions, Next: Removed Variables, Prev: Removed Operators, Up: Removed Language Features 27.1.4 Removed Argument Conventions ----------------------------------- The font argument to digit-char was removed. The bits and font arguments to code-char were removed.  File: gcl.info, Node: Removed Variables, Next: Removed Reader Syntax, Prev: Removed Argument Conventions, Up: Removed Language Features 27.1.5 Removed Variables ------------------------ The variables char-font-limit , char-bits-limit , char-control-bit , char-meta-bit , char-super-bit , char-hyper-bit , and *break-on-warnings* were removed.  File: gcl.info, Node: Removed Reader Syntax, Next: Packages No Longer Required, Prev: Removed Variables, Up: Removed Language Features 27.1.6 Removed Reader Syntax ---------------------------- The "#," reader macro in standard syntax was removed.  File: gcl.info, Node: Packages No Longer Required, Prev: Removed Reader Syntax, Up: Removed Language Features 27.1.7 Packages No Longer Required ---------------------------------- The packages LISP , USER , and SYSTEM are no longer required. It is valid for packages with one or more of these names to be provided by a conforming implementation as extensions. gcl-2.6.14/info/chap-24.texi0000644000175000017500000010470014360276512013761 0ustar cammcamm @node System Construction, Environment, Reader, Top @chapter System Construction @menu * System Construction Concepts:: * System Construction Dictionary:: @end menu @node System Construction Concepts, System Construction Dictionary, System Construction, System Construction @section System Construction Concepts @c including concept-systems @menu * Loading:: * Features:: @end menu @node Loading, Features, System Construction Concepts, System Construction Concepts @subsection Loading To @b{load} a @i{file} is to treat its contents as @i{code} and @i{execute} that @i{code}. The @i{file} may contain @i{source code} @IGindex source code or @i{compiled code} @IGindex compiled code . A @i{file} containing @i{source code} is called a @i{source file} @IGindex source file . @i{Loading} a @i{source file} is accomplished essentially by sequentially @i{reading}_2 the @i{forms} in the file, @i{evaluating} each immediately after it is @i{read}. A @i{file} containing @i{compiled code} is called a @i{compiled file} @IGindex compiled file . @i{Loading} a @i{compiled file} is similar to @i{loading} a @i{source file}, except that the @i{file} does not contain text but rather an @i{implementation-dependent} representation of pre-digested @i{expressions} created by the @i{compiler}. Often, a @i{compiled file} can be @i{loaded} more quickly than a @i{source file}. See @ref{Compilation}. The way in which a @i{source file} is distinguished from a @i{compiled file} is @i{implementation-dependent}. @node Features, , Loading, System Construction Concepts @subsection Features A @i{feature} @IGindex feature is an aspect or attribute of @r{Common Lisp}, of the @i{implementation}, or of the @i{environment}. A @i{feature} is identified by a @i{symbol}. A @i{feature} is said to be @i{present} @IGindex present in a @i{Lisp image} if and only if the @i{symbol} naming it is an @i{element} of the @i{list} held by the @i{variable} @b{*features*}, which is called the @i{features list} @IGindex features list . @menu * Feature Expressions:: * Examples of Feature Expressions:: @end menu @node Feature Expressions, Examples of Feature Expressions, Features, Features @subsubsection Feature Expressions Boolean combinations of @i{features}, called @i{feature expressions} @IGindex feature expression , are used by the @t{#+} and @t{#-} @i{reader macros} in order to direct conditional @i{reading} of @i{expressions} by the @i{Lisp reader}. The rules for interpreting a @i{feature expression} are as follows: @table @asis @item @i{feature} If a @i{symbol} naming a @i{feature} is used as a @i{feature expression}, the @i{feature expression} succeeds if that @i{feature} is @i{present}; otherwise it fails. @item @t{(not @i{feature-conditional})} A @b{not} @i{feature expression} succeeds if its argument @i{feature-conditional} fails; otherwise, it succeeds. @item @t{(and @{@i{feature-conditional}@}*)} An @b{and} @i{feature expression} succeeds if all of its argument @i{feature-conditionals} succeed; otherwise, it fails. @item @t{(or @{@i{feature-conditional}@}*)} An @b{or} @i{feature expression} succeeds if any of its argument @i{feature-conditionals} succeed; otherwise, it fails. @end table @node Examples of Feature Expressions, , Feature Expressions, Features @subsubsection Examples of Feature Expressions For example, suppose that in @i{implementation} A, the @i{features} @t{spice} and @t{perq} are @i{present}, but the @i{feature} @t{lispm} is not @i{present}; in @i{implementation} B, the feature @t{lispm} is @i{present}, but the @i{features} @t{spice} and @t{perq} are not @i{present}; and in @i{implementation} C, none of the features @t{spice}, @i{lispm}, or @t{perq} are @i{present}. Figure 24--1 shows some sample @i{expressions}, and how they would be @i{read}_2 in these @i{implementations}. @format @group @noindent @w{ @t{(cons #+spice "Spice" #-spice "Lispm" x)} } @w{ in @i{implementation} A ... @t{(CONS "Spice" X)} } @w{ in @i{implementation} B ... @t{(CONS "Lispm" X)} } @w{ in @i{implementation} C ... @t{(CONS "Lispm" X)} } @w{ @t{(cons #+spice "Spice" #+LispM "Lispm" x)} } @w{ in @i{implementation} A ... @t{(CONS "Spice" X)} } @w{ in @i{implementation} B ... @t{(CONS "Lispm" X)} } @w{ in @i{implementation} C ... @t{(CONS X)} } @w{ @t{(setq a '(1 2 #+perq 43 #+(not perq) 27))} } @w{ in @i{implementation} A ... @t{(SETQ A '(1 2 43))} } @w{ in @i{implementation} B ... @t{(SETQ A '(1 2 27))} } @w{ in @i{implementation} C ... @t{(SETQ A '(1 2 27))} } @w{ @t{(let ((a 3) #+(or spice lispm) (b 3)) (foo a))} } @w{ in @i{implementation} A ... @t{(LET ((A 3) (B 3)) (FOO A))} } @w{ in @i{implementation} B ... @t{(LET ((A 3) (B 3)) (FOO A))} } @w{ in @i{implementation} C ... @t{(LET ((A 3)) (FOO A))} } @w{ @t{(cons #+Lispm "#+Spice" #+Spice "foo" #-(or Lispm Spice) 7 x)} } @w{ in @i{implementation} A ... @t{(CONS "foo" X)} } @w{ in @i{implementation} B ... @t{(CONS "#+Spice" X)} } @w{ in @i{implementation} C ... @t{(CONS 7 X)} } @noindent @w{ Figure 24--1: Features examples } @end group @end format @c end of including concept-systems @node System Construction Dictionary, , System Construction Concepts, System Construction @section System Construction Dictionary @c including dict-system-construction @menu * compile-file:: * compile-file-pathname:: * load:: * with-compilation-unit:: * *features*:: * *compile-file-pathname*:: * *load-pathname*:: * *compile-print*:: * *load-print*:: * *modules*:: * provide:: @end menu @node compile-file, compile-file-pathname, System Construction Dictionary, System Construction Dictionary @subsection compile-file [Function] @code{compile-file} @i{input-file @r{&key} output-file verbose print external-format}@* @result{} @i{output-truename, warnings-p, failure-p} @subsubheading Arguments and Values:: @i{input-file}---a @i{pathname designator}. (Default fillers for unspecified components are taken from @b{*default-pathname-defaults*}.) @i{output-file}---a @i{pathname designator}. The default is @i{implementation-defined}. @i{verbose}---a @i{generalized boolean}. The default is the @i{value} of @b{*compile-verbose*}. @i{print}---a @i{generalized boolean}. The default is the @i{value} of @b{*compile-print*}. @i{external-format}---an @i{external file format designator}. The default is @t{:default}. @i{output-truename}---a @i{pathname} (the @b{truename} of the output @i{file}), or @b{nil}. @i{warnings-p}---a @i{generalized boolean}. @i{failure-p}---a @i{generalized boolean}. @subsubheading Description:: @b{compile-file} transforms the contents of the file specified by @i{input-file} into @i{implementation-dependent} binary data which are placed in the file specified by @i{output-file}. The @i{file} to which @i{input-file} refers should be a @i{source file}. @i{output-file} can be used to specify an output @i{pathname}; the actual @i{pathname} of the @i{compiled file} to which @i{compiled code} will be output is computed as if by calling @b{compile-file-pathname}. If @i{input-file} or @i{output-file} is a @i{logical pathname}, it is translated into a @i{physical pathname} as if by calling @b{translate-logical-pathname}. If @i{verbose} is @i{true}, @b{compile-file} prints a message in the form of a comment (@i{i.e.}, with a leading @i{semicolon}) to @i{standard output} indicating what @i{file} is being @i{compiled} and other useful information. If @i{verbose} is @i{false}, @b{compile-file} does not print this information. If @i{print} is @i{true}, information about @i{top level forms} in the file being compiled is printed to @i{standard output}. Exactly what is printed is @i{implementation-dependent}, but nevertheless some information is printed. If @i{print} is @b{nil}, no information is printed. The @i{external-format} specifies the @i{external file format} to be used when opening the @i{file}; see the @i{function} @b{open}. @b{compile-file} and @b{load} must cooperate in such a way that the resulting @i{compiled file} can be @i{loaded} without specifying an @i{external file format} anew; see the @i{function} @b{load}. @b{compile-file} binds @b{*readtable*} and @b{*package*} to the values they held before processing the file. @b{*compile-file-truename*} is bound by @b{compile-file} to hold the @i{truename} of the @i{pathname} of the file being compiled. @b{*compile-file-pathname*} is bound by @b{compile-file} to hold a @i{pathname} denoted by the first argument to @b{compile-file}, merged against the defaults; that is, @t{(pathname (merge-pathnames @i{input-file}))}. The compiled @i{functions} contained in the @i{compiled file} become available for use when the @i{compiled file} is @i{loaded} into Lisp. Any function definition that is processed by the compiler, including @t{#'(lambda ...)} forms and local function definitions made by @b{flet}, @b{labels} and @b{defun} forms, result in an @i{object} of @i{type} @b{compiled-function}. The @i{primary value} returned by @b{compile-file}, @i{output-truename}, is the @b{truename} of the output file, or @b{nil} if the file could not be created. The @i{secondary value}, @i{warnings-p}, is @i{false} if no @i{conditions} of @i{type} @b{error} or @b{warning} were detected by the compiler, and @i{true} otherwise. The @i{tertiary value}, @i{failure-p}, is @i{false} if no @i{conditions} of @i{type} @b{error} or @b{warning} (other than @b{style-warning}) were detected by the compiler, and @i{true} otherwise. For general information about how @i{files} are processed by the @i{file compiler}, see @ref{File Compilation}. @i{Programs} to be compiled by the @i{file compiler} must only contain @i{externalizable objects}; for details on such @i{objects}, see @ref{Literal Objects in Compiled Files}. For information on how to extend the set of @i{externalizable objects}, see the @i{function} @b{make-load-form} and @ref{Additional Constraints on Externalizable Objects}. @subsubheading Affected By:: @b{*error-output*}, @b{*standard-output*}, @b{*compile-verbose*}, @b{*compile-print*} The computer's file system. @subsubheading Exceptional Situations:: For information about errors detected during the compilation process, see @ref{Exceptional Situations in the Compiler}. An error of @i{type} @b{file-error} might be signaled if @t{(wild-pathname-p @i{input-file})\/} returns true. If either the attempt to open the @i{source file} for input or the attempt to open the @i{compiled file} for output fails, an error of @i{type} @b{file-error} is signaled. @subsubheading See Also:: @ref{compile} , @b{declare}, @ref{eval-when} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node compile-file-pathname, load, compile-file, System Construction Dictionary @subsection compile-file-pathname [Function] @code{compile-file-pathname} @i{input-file @r{&key} output-file @r{&allow-other-keys}} @result{} @i{pathname} @subsubheading Arguments and Values:: @i{input-file}---a @i{pathname designator}. (Default fillers for unspecified components are taken from @b{*default-pathname-defaults*}.) @i{output-file}---a @i{pathname designator}. The default is @i{implementation-defined}. @i{pathname}---a @i{pathname}. @subsubheading Description:: Returns the @i{pathname} that @b{compile-file} would write into, if given the same arguments. The defaults for the @i{output-file} are taken from the @i{pathname} that results from merging the @i{input-file} with the @i{value} of @b{*default-pathname-defaults*}, except that the type component should default to the appropriate @i{implementation-defined} default type for @i{compiled files}. If @i{input-file} is a @i{logical pathname} and @i{output-file} is unsupplied, the result is a @i{logical pathname}. If @i{input-file} is a @i{logical pathname}, it is translated into a physical pathname as if by calling @b{translate-logical-pathname}. If @i{input-file} is a @i{stream}, the @i{stream} can be either open or closed. @b{compile-file-pathname} returns the same @i{pathname} after a file is closed as it did when the file was open. It is an error if @i{input-file} is a @i{stream} that is created with @b{make-two-way-stream}, @b{make-echo-stream}, @b{make-broadcast-stream}, @b{make-concatenated-stream}, @b{make-string-input-stream}, @b{make-string-output-stream}. If an implementation supports additional keyword arguments to @b{compile-file}, @b{compile-file-pathname} must accept the same arguments. @subsubheading Examples:: See @b{logical-pathname-translations}. @subsubheading Exceptional Situations:: An error of @i{type} @b{file-error} might be signaled if either @i{input-file} or @i{output-file} is @i{wild}. @subsubheading See Also:: @ref{compile-file} , @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node load, with-compilation-unit, compile-file-pathname, System Construction Dictionary @subsection load [Function] @code{load} @i{filespec @r{&key} verbose print if-does-not-exist external-format}@* @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{filespec}---a @i{stream}, or a @i{pathname designator}. The default is taken from @b{*default-pathname-defaults*}. @i{verbose}---a @i{generalized boolean}. The default is the @i{value} of @b{*load-verbose*}. @i{print}---a @i{generalized boolean}. The default is the @i{value} of @b{*load-print*}. @i{if-does-not-exist}---a @i{generalized boolean}. The default is @i{true}. @i{external-format}---an @i{external file format designator}. The default is @t{:default}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{load} @i{loads} the @i{file} named by @i{filespec} into the @r{Lisp} environment. The manner in which a @i{source file} is distinguished from a @i{compiled file} is @i{implementation-dependent}. If the file specification is not complete and both a @i{source file} and a @i{compiled file} exist which might match, then which of those files @b{load} selects is @i{implementation-dependent}. If @i{filespec} is a @i{stream}, @b{load} determines what kind of @i{stream} it is and loads directly from the @i{stream}. If @i{filespec} is a @i{logical pathname}, it is translated into a @i{physical pathname} as if by calling @b{translate-logical-pathname}. @b{load} sequentially executes each @i{form} it encounters in the @i{file} named by @i{filespec}. If the @i{file} is a @i{source file} and the @i{implementation} chooses to perform @i{implicit compilation}, @b{load} must recognize @i{top level forms} as described in @ref{Processing of Top Level Forms} and arrange for each @i{top level form} to be executed before beginning @i{implicit compilation} of the next. (Note, however, that processing of @b{eval-when} @i{forms} by @b{load} is controlled by the @t{:execute} situation.) If @i{verbose} is @i{true}, @b{load} prints a message in the form of a comment (@i{i.e.}, with a leading @i{semicolon}) to @i{standard output} indicating what @i{file} is being @i{loaded} and other useful information. If @i{verbose} is @i{false}, @b{load} does not print this information. If @i{print} is @i{true}, @b{load} incrementally prints information to @i{standard output} showing the progress of the @i{loading} process. For a @i{source file}, this information might mean printing the @i{values} @i{yielded} by each @i{form} in the @i{file} as soon as those @i{values} are returned. For a @i{compiled file}, what is printed might not reflect precisely the contents of the @i{source file}, but some information is generally printed. If @i{print} is @i{false}, @b{load} does not print this information. If the file named by @i{filespec} is successfully loaded, @b{load} returns @i{true}. [Reviewer Note by Loosemore: What happens if the file cannot be loaded for some reason other than that it doesn't exist?] [Editorial Note by KMP: i.e., can it return NIL? must it?] If the file does not exist, the specific action taken depends on @i{if-does-not-exist}: if it is @b{nil}, @b{load} returns @b{nil}; otherwise, @b{load} signals an error. The @i{external-format} specifies the @i{external file format} to be used when opening the @i{file} (see the @i{function} @b{open}), except that when the @i{file} named by @i{filespec} is a @i{compiled file}, the @i{external-format} is ignored. @b{compile-file} and @b{load} cooperate in an @i{implementation-dependent} way to assure the preservation of the @i{similarity} of @i{characters} referred to in the @i{source file} at the time the @i{source file} was processed by the @i{file compiler} under a given @i{external file format}, regardless of the value of @i{external-format} at the time the @i{compiled file} is @i{loaded}. @b{load} binds @b{*readtable*} and @b{*package*} to the values they held before @i{loading} the file. @b{*load-truename*} is @i{bound} by @b{load} to hold the @i{truename} of the @i{pathname} of the file being @i{loaded}. @b{*load-pathname*} is @i{bound} by @b{load} to hold a @i{pathname} that represents @i{filespec} merged against the defaults. That is, @t{(pathname (merge-pathnames @i{filespec}))}. @subsubheading Examples:: @example ;Establish a data file... (with-open-file (str "data.in" :direction :output :if-exists :error) (print 1 str) (print '(setq a 888) str) t) @result{} T (load "data.in") @result{} @i{true} a @result{} 888 (load (setq p (merge-pathnames "data.in")) :verbose t) ; Loading contents of file /fred/data.in ; Finished loading /fred/data.in @result{} @i{true} (load p :print t) ; Loading contents of file /fred/data.in ; 1 ; 888 ; Finished loading /fred/data.in @result{} @i{true} @end example @example ;----[Begin file SETUP]---- (in-package "MY-STUFF") (defmacro compile-truename () `',*compile-file-truename*) (defvar *my-compile-truename* (compile-truename) "Just for debugging.") (defvar *my-load-pathname* *load-pathname*) (defun load-my-system () (dolist (module-name '("FOO" "BAR" "BAZ")) (load (merge-pathnames module-name *my-load-pathname*)))) ;----[End of file SETUP]---- (load "SETUP") (load-my-system) @end example @subsubheading Affected By:: The implementation, and the host computer's file system. @subsubheading Exceptional Situations:: If @t{:if-does-not-exist} is supplied and is @i{true}, or is not supplied, @b{load} signals an error of @i{type} @b{file-error} if the file named by @i{filespec} does not exist, or if the @i{file system} cannot perform the requested operation. An error of @i{type} @b{file-error} might be signaled if @t{(wild-pathname-p @i{filespec})} returns @i{true}. @subsubheading See Also:: @ref{error} , @ref{merge-pathnames} , @b{*load-verbose*}, @b{*default-pathname-defaults*}, @b{pathname}, @b{logical-pathname}, @ref{File System Concepts}, @ref{Pathnames as Filenames} @node with-compilation-unit, *features*, load, System Construction Dictionary @subsection with-compilation-unit [Macro] @code{with-compilation-unit} @i{@r{(}[[!@i{option}]]@r{)} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @w{@i{option} ::=@t{:override} override} @subsubheading Arguments and Values:: @i{override}---a @i{generalized boolean}; evaluated. The default is @b{nil}. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Executes @i{forms} from left to right. Within the @i{dynamic environment} of @b{with-compilation-unit}, actions deferred by the compiler until the end of compilation will be deferred until the end of the outermost call to @b{with-compilation-unit}. The set of @i{options} permitted may be extended by the implementation, but the only @i{standardized} keyword is @t{:override}. If nested dynamically only the outer call to @b{with-compilation-unit} has any effect unless the value associated with @t{:override} is @i{true}, in which case warnings are deferred only to the end of the innermost call for which @i{override} is @i{true}. The function @b{compile-file} provides the effect of @example (with-compilation-unit (:override nil) ...) @end example around its @i{code}. Any @i{implementation-dependent} extensions can only be provided as the result of an explicit programmer request by use of an @i{implementation-dependent} keyword. @i{Implementations} are forbidden from attaching additional meaning to a use of this macro which involves either no keywords or just the keyword @t{:override}. @subsubheading Examples:: If an @i{implementation} would normally defer certain kinds of warnings, such as warnings about undefined functions, to the end of a compilation unit (such as a @i{file}), the following example shows how to cause those warnings to be deferred to the end of the compilation of several files. @example (defun compile-files (&rest files) (with-compilation-unit () (mapcar #'(lambda (file) (compile-file file)) files))) (compile-files "A" "B" "C") @end example Note however that if the implementation does not normally defer any warnings, use of @i{with-compilation-unit} might not have any effect. @subsubheading See Also:: @ref{compile} , @ref{compile-file} @node *features*, *compile-file-pathname*, with-compilation-unit, System Construction Dictionary @subsection *features* [Variable] @subsubheading Value Type:: a @i{proper list}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{value} of @b{*features*} is called the @i{features list}. It is a @i{list} of @i{symbols}, called @i{features}, that correspond to some aspect of the @i{implementation} or @i{environment}. Most @i{features} have @i{implementation-dependent} meanings; The following meanings have been assigned to feature names: @table @asis @item @t{:cltl1} If present, indicates that the @t{LISP} @i{package} @i{purports to conform} to the 1984 specification @i{Common Lisp: The Language}. It is possible, but not required, for a @i{conforming implementation} to have this feature because this specification specifies that its @i{symbols} are to be in the @t{COMMON-LISP} @i{package}, not the @t{LISP} package. @item @t{:cltl2} If present, indicates that the implementation @i{purports to conform} to @i{Common Lisp: The Language, Second Edition}. This feature must not be present in any @i{conforming implementation}, since conformance to that document is not compatible with conformance to this specification. The name, however, is reserved by this specification in order to help programs distinguish implementations which conform to that document from implementations which conform to this specification. @item @t{:ieee-floating-point} If present, indicates that the implementation @i{purports to conform} to the requirements of @i{IEEE Standard for Binary Floating-Point Arithmetic}. @item @t{:x3j13} If present, indicates that the implementation conforms to some particular working draft of this specification, or to some subset of features that approximates a belief about what this specification might turn out to contain. A @i{conforming implementation} might or might not contain such a feature. (This feature is intended primarily as a stopgap in order to provide implementors something to use prior to the availability of a draft standard, in order to discourage them from introducing the @t{:draft-ansi-cl} and @t{:ansi-cl} @i{features} prematurely.) @item @t{:draft-ansi-cl} If present, indicates that the @i{implementation} @i{purports to conform} to the first full draft of this specification, which went to public review in 1992. A @i{conforming implementation} which has the @t{:draft-ansi-cl-2} or @t{:ansi-cl} @i{feature} is not permitted to retain the @t{:draft-ansi-cl} @i{feature} since incompatible changes were made subsequent to the first draft. @item @t{:draft-ansi-cl-2} If present, indicates that a second full draft of this specification has gone to public review, and that the @i{implementation} @i{purports to conform} to that specification. (If additional public review drafts are produced, this keyword will continue to refer to the second draft, and additional keywords will be added to identify conformance with such later drafts. As such, the meaning of this keyword can be relied upon not to change over time.) A @i{conforming implementation} which has the @t{:ansi-cl} @i{feature} is only permitted to retain the @t{:draft-ansi-cl} @i{feature} if the finally approved standard is not incompatible with the draft standard. @item @t{:ansi-cl} If present, indicates that this specification has been adopted by ANSI as an official standard, and that the @i{implementation} @i{purports to conform}. @item @t{:common-lisp} This feature must appear in @b{*features*} for any implementation that has one or more of the features @t{:x3j13}, @t{:draft-ansi-cl}, or @t{:ansi-cl}. It is intended that it should also appear in implementations which have the features @t{:cltl1} or @t{:cltl2}, but this specification cannot force such behavior. The intent is that this feature should identify the language family named ``Common Lisp,'' rather than some specific dialect within that family. @end table @subsubheading See Also:: @ref{Use of Read-Time Conditionals}, @ref{Standard Macro Characters} @subsubheading Notes:: The @i{value} of @b{*features*} is used by the @t{#+} and @t{#-} reader syntax. @i{Symbols} in the @i{features list} may be in any @i{package}, but in practice they are generally in the @t{KEYWORD} @i{package}. This is because @t{KEYWORD} is the @i{package} used by default when @i{reading}_2 @i{feature expressions} in the @t{#+} and @t{#-} @i{reader macros}. @i{Code} that needs to name a @i{feature}_2 in a @i{package} P (other than @t{KEYWORD}) can do so by making explicit use of a @i{package prefix} for P, but note that such @i{code} must also assure that the @i{package} P exists in order for the @i{feature expression} to be @i{read}_2---even in cases where the @i{feature expression} is expected to fail. It is generally considered wise for an @i{implementation} to include one or more @i{features} identifying the specific @i{implementation}, so that conditional expressions can be written which distinguish idiosyncrasies of one @i{implementation} from those of another. Since features are normally @i{symbols} in the @t{KEYWORD} @i{package} where name collisions might easily result, and since no uniquely defined mechanism is designated for deciding who has the right to use which @i{symbol} for what reason, a conservative strategy is to prefer names derived from one's own company or product name, since those names are often trademarked and are hence less likely to be used unwittingly by another @i{implementation}. @node *compile-file-pathname*, *load-pathname*, *features*, System Construction Dictionary @subsection *compile-file-pathname*, *compile-file-truename* [Variable] @subsubheading Value Type:: The @i{value} of @b{*compile-file-pathname*} must always be a @i{pathname} or @b{nil}. The @i{value} of @b{*compile-file-truename*} must always be a @i{physical pathname} or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: During a call to @b{compile-file}, @b{*compile-file-pathname*} is @i{bound} to the @i{pathname} denoted by the first argument to @b{compile-file}, merged against the defaults; that is, it is @i{bound} to @t{(pathname (merge-pathnames @i{input-file}))}. During the same time interval, @b{*compile-file-truename*} is @i{bound} to the @i{truename} of the @i{file} being @i{compiled}. At other times, the @i{value} of these @i{variables} is @b{nil}. If a @i{break loop} is entered while @b{compile-file} is ongoing, it is @i{implementation-dependent} whether these @i{variables} retain the @i{values} they had just prior to entering the @i{break loop} or whether they are @i{bound} to @b{nil}. The consequences are unspecified if an attempt is made to @i{assign} or @i{bind} either of these @i{variables}. @subsubheading Affected By:: The @i{file system}. @subsubheading See Also:: @ref{compile-file} @node *load-pathname*, *compile-print*, *compile-file-pathname*, System Construction Dictionary @subsection *load-pathname*, *load-truename* [Variable] @subsubheading Value Type:: The @i{value} of @b{*load-pathname*} must always be a @i{pathname} or @b{nil}. The @i{value} of @b{*load-truename*} must always be a @i{physical pathname} or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: During a call to @b{load}, @b{*load-pathname*} is @i{bound} to the @i{pathname} denoted by the the first argument to @b{load}, merged against the defaults; that is, it is @i{bound} to @t{(pathname (merge-pathnames @i{filespec}))}. During the same time interval, @b{*load-truename*} is @i{bound} to the @i{truename} of the @i{file} being loaded. At other times, the @i{value} of these @i{variables} is @b{nil}. If a @i{break loop} is entered while @b{load} is ongoing, it is @i{implementation-dependent} whether these @i{variables} retain the @i{values} they had just prior to entering the @i{break loop} or whether they are @i{bound} to @b{nil}. The consequences are unspecified if an attempt is made to @i{assign} or @i{bind} either of these @i{variables}. @subsubheading Affected By:: The @i{file system}. @subsubheading See Also:: @ref{load} @node *compile-print*, *load-print*, *load-pathname*, System Construction Dictionary @subsection *compile-print*, *compile-verbose* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{value} of @b{*compile-print*} is the default value of the @t{:print} @i{argument} to @b{compile-file}. The @i{value} of @b{*compile-verbose*} is the default value of the @t{:verbose} @i{argument} to @b{compile-file}. @subsubheading See Also:: @ref{compile-file} @node *load-print*, *modules*, *compile-print*, System Construction Dictionary @subsection *load-print*, *load-verbose* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: The initial @i{value} of @b{*load-print*} is @i{false}. The initial @i{value} of @b{*load-verbose*} is @i{implementation-dependent}. @subsubheading Description:: The @i{value} of @b{*load-print*} is the default value of the @t{:print} @i{argument} to @b{load}. The @i{value} of @b{*load-verbose*} is the default value of the @t{:verbose} @i{argument} to @b{load}. @subsubheading See Also:: @ref{load} @node *modules*, provide, *load-print*, System Construction Dictionary @subsection *modules* [Variable] @subsubheading Value Type:: a @i{list} of @i{strings}. @subsubheading Initial Value:: @i{implementation-dependent}. @subsubheading Description:: The @i{value} of @b{*modules*} is a list of names of the modules that have been loaded into the current @i{Lisp image}. @subsubheading Affected By:: @b{provide} @subsubheading See Also:: @ref{provide} , @b{require} @subsubheading Notes:: The variable @b{*modules*} is deprecated. @node provide, , *modules*, System Construction Dictionary @subsection provide, require [Function] @code{provide} @i{module-name} @result{} @i{@i{implementation-dependent}} @code{require} @i{module-name @r{&optional} pathname-list} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{module-name}---a @i{string designator}. @i{pathname-list}---@b{nil}, or a @i{designator} for a @i{non-empty} @i{list} of @i{pathname designators}. The default is @b{nil}. @subsubheading Description:: @b{provide} adds the @i{module-name} to the @i{list} held by @b{*modules*}, if such a name is not already present. @b{require} tests for the presence of the @i{module-name} in the @i{list} held by @b{*modules*}. If it is present, @b{require} immediately returns. Otherwise, an attempt is made to load an appropriate set of @i{files} as follows: The @i{pathname-list} argument, if @i{non-nil}, specifies a list of @i{pathnames} to be loaded in order, from left to right. If the @i{pathname-list} is @b{nil}, an @i{implementation-dependent} mechanism will be invoked in an attempt to load the module named @i{module-name}; if no such module can be loaded, an error of @i{type} @b{error} is signaled. Both functions use @b{string=} to test for the presence of a @i{module-name}. @subsubheading Examples:: @example ;;; This illustrates a nonportable use of REQUIRE, because it ;;; depends on the implementation-dependent file-loading mechanism. (require "CALCULUS") ;;; This use of REQUIRE is nonportable because of the literal ;;; physical pathname. (require "CALCULUS" "/usr/lib/lisp/calculus") ;;; One form of portable usage involves supplying a logical pathname, ;;; with appropriate translations defined elsewhere. (require "CALCULUS" "lib:calculus") ;;; Another form of portable usage involves using a variable or ;;; table lookup function to determine the pathname, which again ;;; must be initialized elsewhere. (require "CALCULUS" *calculus-module-pathname*) @end example @subsubheading Side Effects:: @b{provide} modifies @b{*modules*}. @subsubheading Affected By:: The specific action taken by @b{require} is affected by calls to @b{provide} (or, in general, any changes to the @i{value} of @b{*modules*}). @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{module-name} is not a @i{string designator}. If @b{require} fails to perform the requested operation due to a problem while interacting with the @i{file system}, an error of @i{type} @b{file-error} is signaled. An error of @i{type} @b{file-error} might be signaled if any @i{pathname} in @i{pathname-list} is a @i{designator} for a @i{wild} @i{pathname}. @subsubheading See Also:: @b{*modules*}, @ref{Pathnames as Filenames} @subsubheading Notes:: The functions @b{provide} and @b{require} are deprecated. If a module consists of a single @i{package}, it is customary for the package and module names to be the same. @c end of including dict-system-construction @c %**end of chapter gcl-2.6.14/info/chap-3.texi0000644000175000017500000076454614360276512013722 0ustar cammcamm @node Evaluation and Compilation, Types and Classes, Syntax, Top @chapter Evaluation and Compilation @menu * Evaluation:: * Compilation:: * Declarations:: * Lambda Lists:: * Error Checking in Function Calls:: * Traversal Rules and Side Effects:: * Destructive Operations:: * Evaluation and Compilation Dictionary:: @end menu @node Evaluation, Compilation, Evaluation and Compilation, Evaluation and Compilation @section Evaluation @c including concept-eval @i{Execution} of @i{code} can be accomplished by a variety of means ranging from direct interpretation of a @i{form} representing a @i{program} to invocation of @i{compiled code} produced by a @i{compiler}. @i{Evaluation} @IGindex evaluation is the process by which a @i{program} is @i{executed} in @r{Common Lisp}. The mechanism of @i{evaluation} is manifested both implicitly through the effect of the @i{Lisp read-eval-print loop}, and explicitly through the presence of the @i{functions} @b{eval}, @b{compile}, @b{compile-file}, and @b{load}. Any of these facilities might share the same execution strategy, or each might use a different one. The behavior of a @i{conforming program} processed by @b{eval} and by @b{compile-file} might differ; see @ref{Semantic Constraints}. @i{Evaluation} can be understood in terms of a model in which an interpreter recursively traverses a @i{form} performing each step of the computation as it goes. This model, which describes the semantics of @r{Common Lisp} @i{programs}, is described in @ref{The Evaluation Model}. @menu * Introduction to Environments:: * The Evaluation Model:: * Lambda Expressions:: * Closures and Lexical Binding:: * Shadowing:: * Extent:: * Return Values:: @end menu @node Introduction to Environments, The Evaluation Model, Evaluation, Evaluation @subsection Introduction to Environments A @i{binding} @IGindex binding is an association between a @i{name} and that which the name denotes. @i{Bindings} are @i{established} in a @i{lexical environment} or a @i{dynamic environment} by particular @i{special operators}. An @i{environment} @IGindex environment is a set of @i{bindings} and other information used during evaluation (@i{e.g.}, to associate meanings with names). @i{Bindings} in an @i{environment} are partitioned into @i{namespaces} @IGindex namespace . A single @i{name} can simultaneously have more than one associated @i{binding} per @i{environment}, but can have only one associated @i{binding} per @i{namespace}. @menu * The Global Environment:: * Dynamic Environments:: * Lexical Environments:: * The Null Lexical Environment:: * Environment Objects:: @end menu @node The Global Environment, Dynamic Environments, Introduction to Environments, Introduction to Environments @subsubsection The Global Environment The @i{global environment} @IGindex global environment is that part of an @i{environment} that contains @i{bindings} with both @i{indefinite scope} and @i{indefinite extent}. The @i{global environment} contains, among other things, the following: @table @asis @item @t{*} @i{bindings} of @i{dynamic variables} and @i{constant variables}. @item @t{*} @i{bindings} of @i{functions}, @i{macros}, and @i{special operators}. @item @t{*} @i{bindings} of @i{compiler macros}. @item @t{*} @i{bindings} of @i{type} and @i{class} @i{names} @item @t{*} information about @i{proclamations}. @end table @node Dynamic Environments, Lexical Environments, The Global Environment, Introduction to Environments @subsubsection Dynamic Environments A @i{dynamic environment} @IGindex dynamic environment for @i{evaluation} is that part of an @i{environment} that contains @i{bindings} whose duration is bounded by points of @i{establishment} and @i{disestablishment} within the execution of the @i{form} that established the @i{binding}. A @i{dynamic environment} contains, among other things, the following: @table @asis @item @t{*} @i{bindings} for @i{dynamic variables}. @item @t{*} information about @i{active} @i{catch tags}. @item @t{*} information about @i{exit points} established by @b{unwind-protect}. @item @t{*} information about @i{active} @i{handlers} and @i{restarts}. @end table The @i{dynamic environment} that is active at any given point in the @i{execution} of a @i{program} is referred to by definite reference as ``the current @i{dynamic environment},'' or sometimes as just ``the @i{dynamic environment}.'' Within a given @i{namespace}, a @i{name} is said to be @i{bound} in a @i{dynamic environment} if there is a @i{binding} associated with its @i{name} in the @i{dynamic environment} or, if not, there is a @i{binding} associated with its name in the @i{global environment}. @node Lexical Environments, The Null Lexical Environment, Dynamic Environments, Introduction to Environments @subsubsection Lexical Environments A @i{lexical environment} @IGindex lexical environment for @i{evaluation} at some position in a @i{program} is that part of the @i{environment} that contains information having @i{lexical scope} within the @i{forms} containing that position. A @i{lexical environment} contains, among other things, the following: @table @asis @item @t{*} @i{bindings} of @i{lexical variables} and @i{symbol macros}. @item @t{*} @i{bindings} of @i{functions} and @i{macros}. (Implicit in this is information about those @i{compiler macros} that are locally disabled.) @item @t{*} @i{bindings} of @i{block tags}. @item @t{*} @i{bindings} of @i{go tags}. @item @t{*} information about @i{declarations}. @end table The @i{lexical environment} that is active at any given position in a @i{program} being semantically processed is referred to by definite reference as ``the current @i{lexical environment},'' or sometimes as just ``the @i{lexical environment}.'' Within a given @i{namespace}, a @i{name} is said to be @i{bound} in a @i{lexical environment} if there is a @i{binding} associated with its @i{name} in the @i{lexical environment} or, if not, there is a @i{binding} associated with its name in the @i{global environment}. @node The Null Lexical Environment, Environment Objects, Lexical Environments, Introduction to Environments @subsubsection The Null Lexical Environment The @i{null lexical environment} @IGindex null lexical environment is equivalent to the @i{global environment}. Although in general the representation of an @i{environment} @i{object} is @i{implementation-dependent}, @b{nil} can be used in any situation where an @i{environment} @i{object} is called for in order to denote the @i{null lexical environment}. @node Environment Objects, , The Null Lexical Environment, Introduction to Environments @subsubsection Environment Objects Some @i{operators} make use of an @i{object}, called an @i{environment object} @IGindex environment object , that represents the set of @i{lexical bindings} needed to perform semantic analysis on a @i{form} in a given @i{lexical environment}. The set of @i{bindings} in an @i{environment object} may be a subset of the @i{bindings} that would be needed to actually perform an @i{evaluation}; for example, @i{values} associated with @i{variable} @i{names} and @i{function names} in the corresponding @i{lexical environment} might not be available in an @i{environment object}. The @i{type} and nature of an @i{environment object} is @i{implementation-dependent}. The @i{values} of @i{environment parameters} to @i{macro functions} are examples of @i{environment objects}. The @i{object} @b{nil} when used as an @i{environment object} denotes the @i{null lexical environment}; see @ref{The Null Lexical Environment}. @node The Evaluation Model, Lambda Expressions, Introduction to Environments, Evaluation @subsection The Evaluation Model A @r{Common Lisp} system evaluates @i{forms} with respect to lexical, dynamic, and global @i{environments}. The following sections describe the components of the @r{Common Lisp} evaluation model. @menu * Form Evaluation:: * Symbols as Forms:: * Lexical Variables:: * Dynamic Variables:: * Constant Variables:: * Symbols Naming Both Lexical and Dynamic Variables:: * Conses as Forms:: * Special Forms:: * Macro Forms:: * Function Forms:: * Lambda Forms:: * Self-Evaluating Objects:: * Examples of Self-Evaluating Objects:: @end menu @node Form Evaluation, Symbols as Forms, The Evaluation Model, The Evaluation Model @subsubsection Form Evaluation @i{Forms} fall into three categories: @i{symbols}, @i{conses}, and @i{self-evaluating objects}. The following sections explain these categories. @node Symbols as Forms, Lexical Variables, Form Evaluation, The Evaluation Model @subsubsection Symbols as Forms If a @i{form} is a @i{symbol}, then it is either a @i{symbol macro} or a @i{variable}. The @i{symbol} names a @i{symbol macro} if there is a @i{binding} of the @i{symbol} as a @i{symbol macro} in the current @i{lexical environment} (see @b{define-symbol-macro} and @b{symbol-macrolet}). If the @i{symbol} is a @i{symbol macro}, its expansion function is obtained. The expansion function is a function of two arguments, and is invoked by calling the @i{macroexpand hook} with the expansion function as its first argument, the @i{symbol} as its second argument, and an @i{environment object} (corresponding to the current @i{lexical environment}) as its third argument. The @i{macroexpand hook}, in turn, calls the expansion function with the @i{form} as its first argument and the @i{environment} as its second argument. The @i{value} of the expansion function, which is passed through by the @i{macroexpand hook}, is a @i{form}. This resulting @i{form} is processed in place of the original @i{symbol}. If a @i{form} is a @i{symbol} that is not a @i{symbol macro}, then it is the @i{name} of a @i{variable}, and the @i{value} of that @i{variable} is returned. There are three kinds of variables: @i{lexical variables}, @i{dynamic variables}, and @i{constant variables}. A @i{variable} can store one @i{object}. The main operations on a @i{variable} are to @i{read}_1 and to @i{write}_1 its @i{value}. An error of @i{type} @b{unbound-variable} should be signaled if an @i{unbound variable} is referenced. @i{Non-constant variables} can be @i{assigned} by using @b{setq} or @i{bound}_3 by using @b{let}. Figure 3--1 lists some @i{defined names} that are applicable to assigning, binding, and defining @i{variables}. @format @group @noindent @w{ boundp let progv } @w{ defconstant let* psetq } @w{ defparameter makunbound set } @w{ defvar multiple-value-bind setq } @w{ lambda multiple-value-setq symbol-value } @noindent @w{ Figure 3--1: Some Defined Names Applicable to Variables} @end group @end format The following is a description of each kind of variable. @node Lexical Variables, Dynamic Variables, Symbols as Forms, The Evaluation Model @subsubsection Lexical Variables A @i{lexical variable} is a @i{variable} that can be referenced only within the @i{lexical scope} of the @i{form} that establishes that @i{variable}; @i{lexical variables} have @i{lexical scope}. Each time a @i{form} creates a @i{lexical binding} of a @i{variable}, a @i{fresh} @i{binding} is @i{established}. Within the @i{scope} of a @i{binding} for a @i{lexical variable} @i{name}, uses of that @i{name} as a @i{variable} are considered to be references to that @i{binding} except where the @i{variable} is @i{shadowed}_2 by a @i{form} that @i{establishes} a @i{fresh} @i{binding} for that @i{variable} @i{name}, or by a @i{form} that locally @i{declares} the @i{name} @b{special}. A @i{lexical variable} always has a @i{value}. There is no @i{operator} that introduces a @i{binding} for a @i{lexical variable} without giving it an initial @i{value}, nor is there any @i{operator} that can make a @i{lexical variable} be @i{unbound}. @i{Bindings} of @i{lexical variables} are found in the @i{lexical environment}. @node Dynamic Variables, Constant Variables, Lexical Variables, The Evaluation Model @subsubsection Dynamic Variables A @i{variable} is a @i{dynamic variable} if one of the following conditions hold: @table @asis @item @t{*} It is locally declared or globally proclaimed @b{special}. @item @t{*} It occurs textually within a @i{form} that creates a @i{dynamic binding} for a @i{variable} of the @i{same} @i{name}, and the @i{binding} is not @i{shadowed}_2 by a @i{form} that creates a @i{lexical binding} of the same @i{variable} @i{name}. @end table A @i{dynamic variable} can be referenced at any time in any @i{program}; there is no textual limitation on references to @i{dynamic variables}. At any given time, all @i{dynamic variables} with a given name refer to exactly one @i{binding}, either in the @i{dynamic environment} or in the @i{global environment}. The @i{value} part of the @i{binding} for a @i{dynamic variable} might be empty; in this case, the @i{dynamic variable} is said to have no @i{value}, or to be @i{unbound}. A @i{dynamic variable} can be made @i{unbound} by using @b{makunbound}. The effect of @i{binding} a @i{dynamic variable} is to create a new @i{binding} to which all references to that @i{dynamic variable} in any @i{program} refer for the duration of the @i{evaluation} of the @i{form} that creates the @i{dynamic binding}. A @i{dynamic variable} can be referenced outside the @i{dynamic extent} of a @i{form} that @i{binds} it. Such a @i{variable} is sometimes called a ``global variable'' but is still in all respects just a @i{dynamic variable} whose @i{binding} happens to exist in the @i{global environment} rather than in some @i{dynamic environment}. A @i{dynamic variable} is @i{unbound} unless and until explicitly assigned a value, except for those variables whose initial value is defined in this specification or by an @i{implementation}. @node Constant Variables, Symbols Naming Both Lexical and Dynamic Variables, Dynamic Variables, The Evaluation Model @subsubsection Constant Variables Certain variables, called @i{constant variables}, are reserved as ``named constants.'' The consequences are undefined if an attempt is made to assign a value to, or create a @i{binding} for a @i{constant variable}, except that a `compatible' redefinition of a @i{constant variable} using @b{defconstant} is permitted; see the @i{macro} @b{defconstant}. @i{Keywords}, @i{symbols} defined by @r{Common Lisp} or the @i{implementation} as constant (such as @b{nil}, @b{t}, and @b{pi}), and @i{symbols} declared as constant using @b{defconstant} are @i{constant variables}. @node Symbols Naming Both Lexical and Dynamic Variables, Conses as Forms, Constant Variables, The Evaluation Model @subsubsection Symbols Naming Both Lexical and Dynamic Variables The same @i{symbol} can name both a @i{lexical variable} and a @i{dynamic variable}, but never in the same @i{lexical environment}. In the following example, the @i{symbol} @t{x} is used, at different times, as the @i{name} of a @i{lexical variable} and as the @i{name} of a @i{dynamic variable}. @example (let ((x 1)) ;Binds a special variable X (declare (special x)) (let ((x 2)) ;Binds a lexical variable X (+ x ;Reads a lexical variable X (locally (declare (special x)) x)))) ;Reads a special variable X @result{} 3 @end example @node Conses as Forms, Special Forms, Symbols Naming Both Lexical and Dynamic Variables, The Evaluation Model @subsubsection Conses as Forms A @i{cons} that is used as a @i{form} is called a @i{compound form}. If the @i{car} of that @i{compound form} is a @i{symbol}, that @i{symbol} is the @i{name} of an @i{operator}, and the @i{form} is either a @i{special form}, a @i{macro form}, or a @i{function form}, depending on the @i{function} @i{binding} of the @i{operator} in the current @i{lexical environment}. If the @i{operator} is neither a @i{special operator} nor a @i{macro name}, it is assumed to be a @i{function name} (even if there is no definition for such a @i{function}). If the @i{car} of the @i{compound form} is not a @i{symbol}, then that @i{car} must be a @i{lambda expression}, in which case the @i{compound form} is a @i{lambda form}. How a @i{compound form} is processed depends on whether it is classified as a @i{special form}, a @i{macro form}, a @i{function form}, or a @i{lambda form}. @node Special Forms, Macro Forms, Conses as Forms, The Evaluation Model @subsubsection Special Forms A @i{special form} is a @i{form} with special syntax, special evaluation rules, or both, possibly manipulating the evaluation environment, control flow, or both. A @i{special operator} has access to the current @i{lexical environment} and the current @i{dynamic environment}. Each @i{special operator} defines the manner in which its @i{subexpressions} are treated---which are @i{forms}, which are special syntax, @i{etc.} Some @i{special operators} create new lexical or dynamic @i{environments} for use during the @i{evaluation} of @i{subforms} of the @i{special form}. For example, @b{block} creates a new @i{lexical environment} that is the same as the one in force at the point of evaluation of the @b{block} @i{form} with the addition of a @i{binding} of the @b{block} name to an @i{exit point} from the @b{block}. The set of @i{special operator} @i{names} is fixed in @r{Common Lisp}; no way is provided for the user to define a @i{special operator}. Figure 3--2 lists all of the @r{Common Lisp} @i{symbols} that have definitions as @i{special operators}. @format @group @noindent @w{ block let* return-from } @w{ catch load-time-value setq } @w{ eval-when locally symbol-macrolet } @w{ flet macrolet tagbody } @w{ function multiple-value-call the } @w{ go multiple-value-prog1 throw } @w{ if progn unwind-protect } @w{ labels progv } @w{ let quote } @noindent @w{ Figure 3--2: Common Lisp Special Operators } @end group @end format @node Macro Forms, Function Forms, Special Forms, The Evaluation Model @subsubsection Macro Forms If the @i{operator} names a @i{macro}, its associated @i{macro function} is applied to the entire @i{form} and the result of that application is used in place of the original @i{form}. Specifically, a @i{symbol} names a @i{macro} in a given @i{lexical environment} if @b{macro-function} is @i{true} of the @i{symbol} and that @i{environment}. The @i{function} returned by @b{macro-function} is a @i{function} of two arguments, called the expansion function. The expansion function is invoked by calling the @i{macroexpand hook} with the expansion function as its first argument, the entire @i{macro form} as its second argument, and an @i{environment object} (corresponding to the current @i{lexical environment}) as its third argument. The @i{macroexpand hook}, in turn, calls the expansion function with the @i{form} as its first argument and the @i{environment} as its second argument. The @i{value} of the expansion function, which is passed through by the @i{macroexpand hook}, is a @i{form}. The returned @i{form} is @i{evaluated} in place of the original @i{form}. The consequences are undefined if a @i{macro function} destructively modifies any part of its @i{form} argument. A @i{macro name} is not a @i{function designator}, and cannot be used as the @i{function} argument to @i{functions} such as @b{apply}, @b{funcall}, or @b{map}. An @i{implementation} is free to implement a @r{Common Lisp} @i{special operator} as a @i{macro}. An @i{implementation} is free to implement any @i{macro} @i{operator} as a @i{special operator}, but only if an equivalent definition of the @i{macro} is also provided. Figure 3--3 lists some @i{defined names} that are applicable to @i{macros}. @format @group @noindent @w{ *macroexpand-hook* macro-function macroexpand-1 } @w{ defmacro macroexpand macrolet } @noindent @w{ Figure 3--3: Defined names applicable to macros } @end group @end format @node Function Forms, Lambda Forms, Macro Forms, The Evaluation Model @subsubsection Function Forms If the @i{operator} is a @i{symbol} naming a @i{function}, the @i{form} represents a @i{function form}, and the @i{cdr} of the list contains the @i{forms} which when evaluated will supply the arguments passed to the @i{function}. When a @i{function name} is not defined, an error of @i{type} @b{undefined-function} should be signaled at run time; see @ref{Semantic Constraints}. A @i{function form} is evaluated as follows: The @i{subforms} in the @i{cdr} of the original @i{form} are evaluated in left-to-right order in the current lexical and dynamic @i{environments}. The @i{primary value} of each such @i{evaluation} becomes an @i{argument} to the named @i{function}; any additional @i{values} returned by the @i{subforms} are discarded. The @i{functional value} of the @i{operator} is retrieved from the @i{lexical environment}, and that @i{function} is invoked with the indicated arguments. Although the order of @i{evaluation} of the @i{argument} @i{subforms} themselves is strictly left-to-right, it is not specified whether the definition of the @i{operator} in a @i{function form} is looked up before the @i{evaluation} of the @i{argument} @i{subforms}, after the @i{evaluation} of the @i{argument} @i{subforms}, or between the @i{evaluation} of any two @i{argument} @i{subforms} if there is more than one such @i{argument} @i{subform}. For example, the following might return 23 or~24. @example (defun foo (x) (+ x 3)) (defun bar () (setf (symbol-function 'foo) #'(lambda (x) (+ x 4)))) (foo (progn (bar) 20)) @end example A @i{binding} for a @i{function name} can be @i{established} in one of several ways. A @i{binding} for a @i{function name} in the @i{global environment} can be @i{established} by @b{defun}, @b{setf} of @b{fdefinition}, @b{setf} of @b{symbol-function}, @b{ensure-generic-function}, @b{defmethod} (implicitly, due to @b{ensure-generic-function}), or @b{defgeneric}. A @i{binding} for a @i{function name} in the @i{lexical environment} can be @i{established} by @b{flet} or @b{labels}. Figure 3--4 lists some @i{defined names} that are applicable to @i{functions}. @format @group @noindent @w{ apply fdefinition mapcan } @w{ call-arguments-limit flet mapcar } @w{ complement fmakunbound mapcon } @w{ constantly funcall mapl } @w{ defgeneric function maplist } @w{ defmethod functionp multiple-value-call } @w{ defun labels reduce } @w{ fboundp map symbol-function } @noindent @w{ Figure 3--4: Some function-related defined names } @end group @end format @node Lambda Forms, Self-Evaluating Objects, Function Forms, The Evaluation Model @subsubsection Lambda Forms A @i{lambda form} is similar to a @i{function form}, except that the @i{function name} is replaced by a @i{lambda expression}. A @i{lambda form} is equivalent to using @i{funcall} of a @i{lexical closure} of the @i{lambda expression} on the given @i{arguments}. (In practice, some compilers are more likely to produce inline code for a @i{lambda form} than for an arbitrary named function that has been declared @b{inline}; however, such a difference is not semantic.) For further information, see @ref{Lambda Expressions}. @node Self-Evaluating Objects, Examples of Self-Evaluating Objects, Lambda Forms, The Evaluation Model @subsubsection Self-Evaluating Objects A @i{form} that is neither a @i{symbol} nor a @i{cons} is defined to be a @i{self-evaluating object}. @i{Evaluating} such an @i{object} @i{yields} the @i{same} @i{object} as a result. Certain specific @i{symbols} and @i{conses} might also happen to be ``self-evaluating'' but only as a special case of a more general set of rules for the @i{evaluation} of @i{symbols} and @i{conses}; such @i{objects} are not considered to be @i{self-evaluating objects}. The consequences are undefined if @i{literal objects} (including @i{self-evaluating objects}) are destructively modified. @node Examples of Self-Evaluating Objects, , Self-Evaluating Objects, The Evaluation Model @subsubsection Examples of Self-Evaluating Objects @i{Numbers}, @i{pathnames}, and @i{arrays} are examples of @i{self-evaluating objects}. @example 3 @result{} 3 #c(2/3 5/8) @result{} #C(2/3 5/8) #p"S:[BILL]OTHELLO.TXT" @result{} #P"S:[BILL]OTHELLO.TXT" #(a b c) @result{} #(A B C) "fred smith" @result{} "fred smith" @end example @node Lambda Expressions, Closures and Lexical Binding, The Evaluation Model, Evaluation @subsection Lambda Expressions In a @i{lambda expression}, the body is evaluated in a lexical @i{environment} that is formed by adding the @i{binding} of each @i{parameter} in the @i{lambda list} with the corresponding @i{value} from the @i{arguments} to the current lexical @i{environment}. For further discussion of how @i{bindings} are @i{established} based on the @i{lambda list}, see @ref{Lambda Lists}. The body of a @i{lambda expression} is an @i{implicit progn}; the @i{values} it returns are returned by the @i{lambda expression}. @node Closures and Lexical Binding, Shadowing, Lambda Expressions, Evaluation @subsection Closures and Lexical Binding A @i{lexical closure} is a @i{function} that can refer to and alter the values of @i{lexical bindings} @i{established} by @i{binding} @i{forms} that textually include the function definition. Consider this code, where @t{x} is not declared @b{special}: @example (defun two-funs (x) (list (function (lambda () x)) (function (lambda (y) (setq x y))))) (setq funs (two-funs 6)) (funcall (car funs)) @result{} 6 (funcall (cadr funs) 43) @result{} 43 (funcall (car funs)) @result{} 43 @end example The @b{function} @i{special form} coerces a @i{lambda expression} into a @i{closure} in which the @i{lexical environment} in effect when the @i{special form} is evaluated is captured along with the @i{lambda expression}. The function @t{two-funs} returns a @i{list} of two @i{functions}, each of which refers to the @i{binding} of the variable @t{x} created on entry to the function @t{two-funs} when it was called. This variable has the value @t{6} initially, but @b{setq} can alter this @i{binding}. The @i{lexical closure} created for the first @i{lambda expression} does not ``snapshot'' the @i{value} @t{6} for @t{x} when the @i{closure} is created; rather it captures the @i{binding} of @t{x}. The second @i{function} can be used to alter the @i{value} in the same (captured) @i{binding} (to @t{43}, in the example), and this altered variable binding then affects the value returned by the first @i{function}. In situations where a @i{closure} of a @i{lambda expression} over the same set of @i{bindings} may be produced more than once, the various resulting @i{closures} may or may not be @i{identical}, at the discretion of the @i{implementation}. That is, two @i{functions} that are behaviorally indistinguishable might or might not be @i{identical}. Two @i{functions} that are behaviorally distinguishable are @i{distinct}. For example: @example (let ((x 5) (funs '())) (dotimes (j 10) (push #'(lambda (z) (if (null z) (setq x 0) (+ x z))) funs)) funs) @end example The result of the above @i{form} is a @i{list} of ten @i{closures}. Each requires only the @i{binding} of @t{x}. It is the same @i{binding} in each case, but the ten @i{closure} @i{objects} might or might not be @i{identical}. On the other hand, the result of the @i{form} @example (let ((funs '())) (dotimes (j 10) (let ((x 5)) (push (function (lambda (z) (if (null z) (setq x 0) (+ x z)))) funs))) funs) @end example is also a @i{list} of ten @i{closures}. However, in this case no two of the @i{closure} @i{objects} can be @i{identical} because each @i{closure} is closed over a distinct @i{binding} of @t{x}, and these @i{bindings} can be behaviorally distinguished because of the use of @b{setq}. The result of the @i{form} @example (let ((funs '())) (dotimes (j 10) (let ((x 5)) (push (function (lambda (z) (+ x z))) funs))) funs) @end example is a @i{list} of ten @i{closure} @i{objects} that might or might not be @i{identical}. A different @i{binding} of @t{x} is involved for each @i{closure}, but the @i{bindings} cannot be distinguished because their values are the @i{same} and immutable (there being no occurrence of @b{setq} on @t{x}). A compiler could internally transform the @i{form} to @example (let ((funs '())) (dotimes (j 10) (push (function (lambda (z) (+ 5 z))) funs)) funs) @end example where the @i{closures} may be @i{identical}. It is possible that a @i{closure} does not close over any variable bindings. In the code fragment @example (mapcar (function (lambda (x) (+ x 2))) y) @end example the function @t{(lambda (x) (+ x 2))} contains no references to any outside object. In this case, the same @i{closure} might be returned for all evaluations of the @b{function} @i{form}. @node Shadowing, Extent, Closures and Lexical Binding, Evaluation @subsection Shadowing If two @i{forms} that @i{establish} @i{lexical bindings} with the same @i{name} N are textually nested, then references to N within the inner @i{form} refer to the @i{binding} established by the inner @i{form}; the inner @i{binding} for N @i{shadows} @IGindex shadow the outer @i{binding} for N. Outside the inner @i{form} but inside the outer one, references to N refer to the @i{binding} established by the outer @i{form}. For example: @example (defun test (x z) (let ((z (* x 2))) (print z)) z) @end example The @i{binding} of the variable @t{z} by @b{let} shadows the @i{parameter} binding for the function @t{test}. The reference to the variable @t{z} in the @b{print} @i{form} refers to the @b{let} binding. The reference to @t{z} at the end of the function @t{test} refers to the @i{parameter} named @t{z}. Constructs that are lexically scoped act as if new names were generated for each @i{object} on each execution. Therefore, dynamic shadowing cannot occur. For example: @example (defun contorted-example (f g x) (if (= x 0) (funcall f) (block here (+ 5 (contorted-example g #'(lambda () (return-from here 4)) (- x 1)))))) @end example Consider the call @t{(contorted-example nil nil 2)}. This produces @t{4}. During the course of execution, there are three calls to @t{contorted-example}, interleaved with two blocks: @example (contorted-example nil nil 2) (block here_1 ...) (contorted-example nil #'(lambda () (return-from here_1 4)) 1) (block here_2 ...) (contorted-example #'(lambda () (return-from here_1 4)) #'(lambda () (return-from here_2 4)) 0) (funcall f) where f @result{} #'(lambda () (return-from here_1 4)) (return-from here_1 4) @end example At the time the @t{funcall} is executed there are two @b{block} @i{exit points} outstanding, each apparently named @t{here}. The @b{return-from} @i{form} executed as a result of the @t{funcall} operation refers to the outer outstanding @i{exit point} (here_1), not the inner one (here_2). It refers to that @i{exit point} textually visible at the point of execution of @b{function} (here abbreviated by the @t{#'} syntax) that resulted in creation of the @i{function} @i{object} actually invoked by @b{funcall}. If, in this example, one were to change the @t{(funcall f)} to @t{(funcall g)}, then the value of the call @t{(contorted-example nil nil 2)} would be @t{9}. The value would change because @b{funcall} would cause the execution of @t{(return-from here_2 4)}, thereby causing a return from the inner @i{exit point} (here_2). When that occurs, the value @t{4} is returned from the middle invocation of @t{contorted-example}, @t{5} is added to that to get @t{9}, and that value is returned from the outer block and the outermost call to @t{contorted-example}. The point is that the choice of @i{exit point} returned from has nothing to do with its being innermost or outermost; rather, it depends on the lexical environment that is packaged up with a @i{lambda expression} when @b{function} is executed. @node Extent, Return Values, Shadowing, Evaluation @subsection Extent @t{Contorted-example} works only because the @i{function} named by @t{f} is invoked during the @i{extent} of the @i{exit point}. Once the flow of execution has left the block, the @i{exit point} is @i{disestablished}. For example: @example (defun invalid-example () (let ((y (block here #'(lambda (z) (return-from here z))))) (if (numberp y) y (funcall y 5)))) @end example One might expect the call @t{(invalid-example)} to produce @t{5} by the following incorrect reasoning: @b{let} binds @t{y} to the value of @b{block}; this value is a @i{function} resulting from the @i{lambda expression}. Because @t{y} is not a number, it is invoked on the value @t{5}. The @b{return-from} should then return this value from the @i{exit point} named @t{here}, thereby exiting from the block again and giving @t{y} the value @t{5} which, being a number, is then returned as the value of the call to @t{invalid-example}. The argument fails only because @i{exit points} have @i{dynamic extent}. The argument is correct up to the execution of @b{return-from}. The execution of @b{return-from} should signal an error of @i{type} @b{control-error}, however, not because it cannot refer to the @i{exit point}, but because it does correctly refer to an @i{exit point} and that @i{exit point} has been @i{disestablished}. A reference by name to a dynamic @i{exit point} binding such as a @i{catch tag} refers to the most recently @i{established} @i{binding} of that name that has not been @i{disestablished}. For example: @example (defun fun1 (x) (catch 'trap (+ 3 (fun2 x)))) (defun fun2 (y) (catch 'trap (* 5 (fun3 y)))) (defun fun3 (z) (throw 'trap z)) @end example Consider the call @t{(fun1 7)}. The result is @t{10}. At the time the @b{throw} is executed, there are two outstanding catchers with the name @t{trap}: one established within procedure @t{fun1}, and the other within procedure @t{fun2}. The latter is the more recent, and so the value @t{7} is returned from @b{catch} in @t{fun2}. Viewed from within @t{fun3}, the @b{catch} in @t{fun2} shadows the one in @t{fun1}. Had @t{fun2} been defined as @example (defun fun2 (y) (catch 'snare (* 5 (fun3 y)))) @end example then the two @i{exit points} would have different @i{names}, and therefore the one in @t{fun1} would not be shadowed. The result would then have been @t{7}. @node Return Values, , Extent, Evaluation @subsection Return Values Ordinarily the result of calling a @i{function} is a single @i{object}. Sometimes, however, it is convenient for a function to compute several @i{objects} and return them. In order to receive other than exactly one value from a @i{form}, one of several @i{special forms} or @i{macros} must be used to request those values. If a @i{form} produces @i{multiple values} which were not requested in this way, then the first value is given to the caller and all others are discarded; if the @i{form} produces zero values, then the caller receives @b{nil} as a value. Figure 3--5 lists some @i{operators} for receiving @i{multiple values}_2. These @i{operators} can be used to specify one or more @i{forms} to @i{evaluate} and where to put the @i{values} returned by those @i{forms}. @format @group @noindent @w{ multiple-value-bind multiple-value-prog1 return-from } @w{ multiple-value-call multiple-value-setq throw } @w{ multiple-value-list return } @noindent @w{ Figure 3--5: Some operators applicable to receiving multiple values} @end group @end format The @i{function} @b{values} can produce @i{multiple values}_2. @t{(values)} returns zero values; @t{(values @i{form})} returns the @i{primary value} returned by @i{form}; @t{(values @i{form1} @i{form2})} returns two values, the @i{primary value} of @i{form1} and the @i{primary value} of @i{form2}; and so on. See @b{multiple-values-limit} and @b{values-list}. @c end of including concept-eval @node Compilation, Declarations, Evaluation, Evaluation and Compilation @section Compilation @c including concept-compile @menu * Compiler Terminology:: * Compilation Semantics:: * File Compilation:: * Literal Objects in Compiled Files:: * Exceptional Situations in the Compiler:: @end menu @node Compiler Terminology, Compilation Semantics, Compilation, Compilation @subsection Compiler Terminology The following terminology is used in this section. The @i{compiler} @IGindex compiler is a utility that translates code into an @i{implementation-dependent} form that might be represented or executed efficiently. The term @i{compiler} @IGindex compiler refers to both of the @i{functions} @b{compile} and @b{compile-file}. The term @i{compiled code} @IGindex compiled code refers to @i{objects} representing compiled programs, such as @i{objects} constructed by @b{compile} or by @b{load} when @i{loading} a @i{compiled file}. The term @i{implicit compilation} @IGindex implicit compilation refers to @i{compilation} performed during @i{evaluation}. The term @i{literal object} @IGindex literal object refers to a quoted @i{object} or a @i{self-evaluating object} or an @i{object} that is a substructure of such an @i{object}. A @i{constant variable} is not itself a @i{literal object}. The term @i{coalesce} @IGindex coalesce is defined as follows. Suppose @t{A} and @t{B} are two @i{literal constants} in the @i{source code}, and that @t{A'} and @t{B'} are the corresponding @i{objects} in the @i{compiled code}. If @t{A'} and @t{B'} are @b{eql} but @t{A} and @t{B} are not @b{eql}, then it is said that @t{A} and @t{B} have been coalesced by the compiler. The term @i{minimal compilation} @IGindex minimal compilation refers to actions the compiler must take at @i{compile time}. These actions are specified in @ref{Compilation Semantics}. The verb @i{process} @IGindex process refers to performing @i{minimal compilation}, determining the time of evaluation for a @i{form}, and possibly @i{evaluating} that @i{form} (if required). The term @i{further compilation} @IGindex further compilation refers to @i{implementation-dependent} compilation beyond @i{minimal compilation}. That is, @i{processing} does not imply complete compilation. Block compilation and generation of machine-specific instructions are examples of further compilation. Further compilation is permitted to take place at @i{run time}. Four different @i{environments} relevant to compilation are distinguished: the @i{startup environment}, the @i{compilation environment}, the @i{evaluation environment}, and the @i{run-time environment}. The @i{startup environment} @IGindex startup environment is the @i{environment} of the @i{Lisp image} from which the @i{compiler} was invoked. The @i{compilation environment} @IGindex compilation environment is maintained by the compiler and is used to hold definitions and declarations to be used internally by the compiler. Only those parts of a definition needed for correct compilation are saved. The @i{compilation environment} is used as the @i{environment} @i{argument} to macro expanders called by the compiler. It is unspecified whether a definition available in the @i{compilation environment} can be used in an @i{evaluation} initiated in the @i{startup environment} or @i{evaluation environment}. The @i{evaluation environment} @IGindex evaluation environment is a @i{run-time environment} in which macro expanders and code specified by @b{eval-when} to be evaluated are evaluated. All evaluations initiated by the @i{compiler} take place in the @i{evaluation environment}. The @i{run-time environment} @IGindex run-time environment is the @i{environment} in which the program being compiled will be executed. The @i{compilation environment} inherits from the @i{evaluation environment}, and the @i{compilation environment} and @i{evaluation environment} might be @i{identical}. The @i{evaluation environment} inherits from the @i{startup environment}, and the @i{startup environment} and @i{evaluation environment} might be @i{identical}. The term @i{compile time} @IGindex compile time refers to the duration of time that the compiler is processing @i{source code}. At @i{compile time}, only the @i{compilation environment} and the @i{evaluation environment} are available. The term @i{compile-time definition} @IGindex compile-time definition refers to a definition in the @i{compilation environment}. For example, when compiling a file, the definition of a function might be retained in the @i{compilation environment} if it is declared @b{inline}. This definition might not be available in the @i{evaluation environment}. The term @i{run time} @IGindex run time refers to the duration of time that the loader is loading compiled code or compiled code is being executed. At run time, only the @i{run-time environment} is available. The term @i{run-time definition} @IGindex run-time definition refers to a definition in the @i{run-time environment}. The term @i{run-time compiler} @IGindex run-time compiler refers to the @i{function} @b{compile} or @i{implicit compilation}, for which the compilation and run-time @i{environments} are maintained in the same @i{Lisp image}. Note that when the @i{run-time compiler} is used, the @i{run-time environment} and @i{startup environment} are the same. @node Compilation Semantics, File Compilation, Compiler Terminology, Compilation @subsection Compilation Semantics Conceptually, compilation is a process that traverses code, performs certain kinds of syntactic and semantic analyses using information (such as proclamations and @i{macro} definitions) present in the @i{compilation environment}, and produces equivalent, possibly more efficient code. @menu * Compiler Macros:: * Purpose of Compiler Macros:: * Naming of Compiler Macros:: * When Compiler Macros Are Used:: * Notes about the Implementation of Compiler Macros:: * Minimal Compilation:: * Semantic Constraints:: @end menu @node Compiler Macros, Purpose of Compiler Macros, Compilation Semantics, Compilation Semantics @subsubsection Compiler Macros A @i{compiler macro} can be defined for a @i{name} that also names a @i{function} or @i{macro}. That is, it is possible for a @i{function name} to name both a @i{function} and a @i{compiler macro}. A @i{function name} names a @i{compiler macro} if @b{compiler-macro-function} is @i{true} of the @i{function name} in the @i{lexical environment} in which it appears. Creating a @i{lexical binding} for the @i{function name} not only creates a new local @i{function} or @i{macro} definition, but also @i{shadows}_2 the @i{compiler macro}. The @i{function} returned by @b{compiler-macro-function} is a @i{function} of two arguments, called the expansion function. To expand a @i{compiler macro}, the expansion function is invoked by calling the @i{macroexpand hook} with the expansion function as its first argument, the entire compiler macro @i{form} as its second argument, and the current compilation @i{environment} (or with the current lexical @i{environment}, if the @i{form} is being processed by something other than @b{compile-file}) as its third argument. The @i{macroexpand hook}, in turn, calls the expansion function with the @i{form} as its first argument and the @i{environment} as its second argument. The return value from the expansion function, which is passed through by the @i{macroexpand hook}, might either be the @i{same} @i{form}, or else a form that can, at the discretion of the @i{code} doing the expansion, be used in place of the original @i{form}. @format @group @noindent @w{ *macroexpand-hook* compiler-macro-function define-compiler-macro } @noindent @w{ Figure 3--6: Defined names applicable to compiler macros } @end group @end format @node Purpose of Compiler Macros, Naming of Compiler Macros, Compiler Macros, Compilation Semantics @subsubsection Purpose of Compiler Macros The purpose of the @i{compiler macro} facility is to permit selective source code transformations as optimization advice to the @i{compiler}. When a @i{compound form} is being processed (as by the compiler), if the @i{operator} names a @i{compiler macro} then the @i{compiler macro function} may be invoked on the form, and the resulting expansion recursively processed in preference to performing the usual processing on the original @i{form} according to its normal interpretation as a @i{function form} or @i{macro form}. A @i{compiler macro function}, like a @i{macro function}, is a @i{function} of two @i{arguments}: the entire call @i{form} and the @i{environment}. Unlike an ordinary @i{macro function}, a @i{compiler macro function} can decline to provide an expansion merely by returning a value that is the @i{same} as the original @i{form}. The consequences are undefined if a @i{compiler macro function} destructively modifies any part of its @i{form} argument. The @i{form} passed to the compiler macro function can either be a @i{list} whose @i{car} is the function name, or a @i{list} whose @i{car} is @b{funcall} and whose @i{cadr} is a list @t{(function @i{name})}; note that this affects destructuring of the form argument by the @i{compiler macro function}. @b{define-compiler-macro} arranges for destructuring of arguments to be performed correctly for both possible formats. When @b{compile-file} chooses to expand a @i{top level form} that is a @i{compiler macro} @i{form}, the expansion is also treated as a @i{top level form} for the purposes of @b{eval-when} processing; see @ref{Processing of Top Level Forms}. @node Naming of Compiler Macros, When Compiler Macros Are Used, Purpose of Compiler Macros, Compilation Semantics @subsubsection Naming of Compiler Macros @i{Compiler macros} may be defined for @i{function names} that name @i{macros} as well as @i{functions}. @i{Compiler macro} definitions are strictly global. There is no provision for defining local @i{compiler macros} in the way that @b{macrolet} defines local @i{macros}. Lexical bindings of a function name shadow any compiler macro definition associated with the name as well as its global @i{function} or @i{macro} definition. Note that the presence of a compiler macro definition does not affect the values returned by functions that access @i{function} definitions (@i{e.g.}, @b{fboundp}) or @i{macro} definitions (@i{e.g.}, @b{macroexpand}). Compiler macros are global, and the function @b{compiler-macro-function} is sufficient to resolve their interaction with other lexical and global definitions. @node When Compiler Macros Are Used, Notes about the Implementation of Compiler Macros, Naming of Compiler Macros, Compilation Semantics @subsubsection When Compiler Macros Are Used The presence of a @i{compiler macro} definition for a @i{function} or @i{macro} indicates that it is desirable for the @i{compiler} to use the expansion of the @i{compiler macro} instead of the original @i{function form} or @i{macro form}. However, no language processor (compiler, evaluator, or other code walker) is ever required to actually invoke @i{compiler macro functions}, or to make use of the resulting expansion if it does invoke a @i{compiler macro function}. When the @i{compiler} encounters a @i{form} during processing that represents a call to a @i{compiler macro} @i{name} (that is not declared @b{notinline}), the @i{compiler} might expand the @i{compiler macro}, and might use the expansion in place of the original @i{form}. When @b{eval} encounters a @i{form} during processing that represents a call to a @i{compiler macro} @i{name} (that is not declared @b{notinline}), @b{eval} might expand the @i{compiler macro}, and might use the expansion in place of the original @i{form}. There are two situations in which a @i{compiler macro} definition must not be applied by any language processor: @table @asis @item @t{*} The global function name binding associated with the compiler macro is shadowed by a lexical binding of the function name. @item @t{*} The function name has been declared or proclaimed @b{notinline} and the call form appears within the scope of the declaration. @end table It is unspecified whether @i{compiler macros} are expanded or used in any other situations. @node Notes about the Implementation of Compiler Macros, Minimal Compilation, When Compiler Macros Are Used, Compilation Semantics @subsubsection Notes about the Implementation of Compiler Macros Although it is technically permissible, as described above, for @b{eval} to treat @i{compiler macros} in the same situations as @i{compiler} might, this is not necessarily a good idea in @i{interpreted implementations}. @i{Compiler macros} exist for the purpose of trading compile-time speed for run-time speed. Programmers who write @i{compiler macros} tend to assume that the @i{compiler macros} can take more time than normal @i{functions} and @i{macros} in order to produce code which is especially optimal for use at run time. Since @b{eval} in an @i{interpreted implementation} might perform semantic analysis of the same form multiple times, it might be inefficient in general for the @i{implementation} to choose to call @i{compiler macros} on every such @i{evaluation}. Nevertheless, the decision about what to do in these situations is left to each @i{implementation}. @node Minimal Compilation, Semantic Constraints, Notes about the Implementation of Compiler Macros, Compilation Semantics @subsubsection Minimal Compilation @i{Minimal compilation} is defined as follows: @table @asis @item @t{*} All @i{compiler macro} @IGindex compiler macro calls appearing in the @i{source code} being compiled are expanded, if at all, at compile time; they will not be expanded at run time. @item @t{*} All @i{macro} @IGindex macro and @i{symbol macro} @IGindex symbol macro calls appearing in the source code being compiled are expanded at compile time in such a way that they will not be expanded again at run time. @b{macrolet} @IRindex macrolet and @b{symbol-macrolet} @IRindex symbol-macrolet are effectively replaced by @i{forms} corresponding to their bodies in which calls to @i{macros} are replaced by their expansions. @item @t{*} The first @i{argument} in a @b{load-time-value} @IRindex load-time-value @i{form} in @i{source code} processed by @b{compile} @IRindex compile is @i{evaluated} at @i{compile time}; in @i{source code} processed by @b{compile-file} @IRindex compile-file , the compiler arranges for it to be @i{evaluated} at @i{load time}. In either case, the result of the @i{evaluation} is remembered and used later as the value of the @b{load-time-value} @i{form} at @i{execution time}. @end table @node Semantic Constraints, , Minimal Compilation, Compilation Semantics @subsubsection Semantic Constraints All @i{conforming programs} must obey the following constraints, which are designed to minimize the observable differences between compiled and interpreted programs: @table @asis @item @t{*} Definitions of any referenced @i{macros} must be present in the @i{compilation environment}. Any @i{form} that is a @i{list} beginning with a @i{symbol} that does not name a @i{special operator} or a @i{macro} defined in the @i{compilation environment} is treated by the compiler as a function call. @item @t{*} @b{Special} proclamations for @i{dynamic variables} must be made in the @i{compilation environment}. Any @i{binding} for which there is no @b{special} declaration or proclamation in the @i{compilation environment} is treated by the compiler as a @i{lexical binding}. @item @t{*} The definition of a function that is defined and declared @b{inline} in the @i{compilation environment} must be the same at run time. @item @t{*} Within a @i{function} named F, the compiler may (but is not required to) assume that an apparent recursive call to a @i{function} named F refers to the same definition of F, unless that function has been declared @b{notinline}. The consequences of redefining such a recursively defined @i{function} F while it is executing are undefined. @item @t{*} A call within a file to a named function that is defined in the same file refers to that function, unless that function has been declared @b{notinline}. The consequences are unspecified if functions are redefined individually at run time or multiply defined in the same file. @item @t{*} The argument syntax and number of return values for all functions whose @b{ftype} is declared at compile time must remain the same at run time. @item @t{*} @i{Constant variables} defined in the @i{compilation environment} must have a @i{similar} value at run time. A reference to a @i{constant variable} in @i{source code} is equivalent to a reference to a @i{literal} @i{object} that is the @i{value} of the @i{constant variable}. @item @t{*} Type definitions made with @b{deftype} or @b{defstruct} in the @i{compilation environment} must retain the same definition at run time. Classes defined by @b{defclass} in the @i{compilation environment} must be defined at run time to have the same @i{superclasses} and same @i{metaclass}. This implies that @i{subtype}/@i{supertype} relationships of @i{type specifiers} must not change between @i{compile time} and @i{run time}. @item @t{*} Type declarations present in the compilation @i{environment} must accurately describe the corresponding values at run time; otherwise, the consequences are undefined. It is permissible for an unknown @i{type} to appear in a declaration at compile time, though a warning might be signaled in such a case. @item @t{*} Except in the situations explicitly listed above, a @i{function} defined in the @i{evaluation environment} is permitted to have a different definition or a different @i{signature} at run time, and the run-time definition prevails. @end table @i{Conforming programs} should not be written using any additional assumptions about consistency between the run-time @i{environment} and the startup, evaluation, and compilation @i{environments}. Except where noted, when a compile-time and a run-time definition are different, one of the following occurs at run time: @table @asis @item @t{*} an error of @i{type} @b{error} is signaled @item @t{*} the compile-time definition prevails @item @t{*} the run-time definition prevails @end table If the @i{compiler} processes a @i{function form} whose @i{operator} is not defined at compile time, no error is signaled at compile time. @node File Compilation, Literal Objects in Compiled Files, Compilation Semantics, Compilation @subsection File Compilation The @i{function} @b{compile-file} performs compilation of @i{forms} in a file following the rules specified in @ref{Compilation Semantics}, and produces an output file that can be loaded by using @b{load}. Normally, the @i{top level forms} appearing in a file compiled with @b{compile-file} are evaluated only when the resulting compiled file is loaded, and not when the file is compiled. However, it is typically the case that some forms in the file need to be evaluated at compile time so the remainder of the file can be read and compiled correctly. The @b{eval-when} @i{special form} can be used to control whether a @i{top level form} is evaluated at compile time, load time, or both. It is possible to specify any of three situations with @b{eval-when}, denoted by the symbols @t{:compile-toplevel}, @t{:load-toplevel}, and @t{:execute}. For top level @b{eval-when} forms, @t{:compile-toplevel} specifies that the compiler must evaluate the body at compile time, and @t{:load-toplevel} specifies that the compiler must arrange to evaluate the body at load time. For non-top level @b{eval-when} forms, @t{:execute} specifies that the body must be executed in the run-time @i{environment}. The behavior of this @i{form} can be more precisely understood in terms of a model of how @b{compile-file} processes forms in a file to be compiled. There are two processing modes, called ``not-compile-time'' and ``compile-time-too''. Successive forms are read from the file by @b{compile-file} and processed in not-compile-time mode; in this mode, @b{compile-file} arranges for forms to be evaluated only at load time and not at compile time. When @b{compile-file} is in compile-time-too mode, forms are evaluated both at compile time and load time. @menu * Processing of Top Level Forms:: * Processing of Defining Macros:: * Constraints on Macros and Compiler Macros:: @end menu @node Processing of Top Level Forms, Processing of Defining Macros, File Compilation, File Compilation @subsubsection Processing of Top Level Forms Processing of @i{top level forms} in the file compiler is defined as follows: @table @asis @item 1. If the @i{form} is a @i{compiler macro form} (not disabled by a @b{notinline} @i{declaration}), the @i{implementation} might or might not choose to compute the @i{compiler macro expansion} of the @i{form} and, having performed the expansion, might or might not choose to process the result as a @i{top level form} in the same processing mode (compile-time-too or not-compile-time). If it declines to obtain or use the expansion, it must process the original @i{form}. @item 2. If the form is a @i{macro form}, its @i{macro expansion} is computed and processed as a @i{top level form} in the same processing mode (compile-time-too or not-compile-time). @item 3. If the form is a @b{progn} form, each of its body @i{forms} is sequentially processed as a @i{top level form} in the same processing mode. @item 4. If the form is a @b{locally}, @b{macrolet}, or @b{symbol-macrolet}, @b{compile-file} establishes the appropriate bindings and processes the body forms as @i{top level forms} with those bindings in effect in the same processing mode. (Note that this implies that the lexical @i{environment} in which @i{top level forms} are processed is not necessarily the @i{null lexical environment}.) @item 5. If the form is an @b{eval-when} @IRindex eval-when form, it is handled according to Figure 3--7. plus .5 fil \offinterlineskip @format @group @noindent @w{ @b{CT} @b{LT} @b{E} @b{Mode} @b{Action} @b{New Mode} } @w{ _________________________________________________} @w{ Yes Yes --- --- Process compile-time-too } @w{ No Yes Yes CTT Process compile-time-too } @w{ No Yes Yes NCT Process not-compile-time } @w{ No Yes No --- Process not-compile-time } @w{ Yes No --- --- Evaluate --- } @w{ No No Yes CTT Evaluate --- } @w{ No No Yes NCT Discard --- } @w{ No No No --- Discard --- } @end group @end format @w{ Figure 3--7: EVAL-WHEN processing} Column @b{CT} indicates whether @t{:compile-toplevel} is specified. Column @b{LT} indicates whether @t{:load-toplevel} is specified. Column @b{E} indicates whether @t{:execute} is specified. Column @b{Mode} indicates the processing mode; a dash (---) indicates that the processing mode is not relevant. The @b{Action} column specifies one of three actions: @table @asis @item @t{} @b{Process:} process the body as @i{top level forms} in the specified mode. @item @t{} @b{Evaluate:} evaluate the body in the dynamic execution context of the compiler, using the @i{evaluation environment} as the global environment and the @i{lexical environment} in which the @b{eval-when} appears. @item @t{} @b{Discard:} ignore the @i{form}. @end table The @b{New Mode} column indicates the new processing mode. A dash (---) indicates the compiler remains in its current mode. @item 6. Otherwise, the form is a @i{top level form} that is not one of the special cases. In compile-time-too mode, the compiler first evaluates the form in the evaluation @i{environment} and then minimally compiles it. In not-compile-time mode, the @i{form} is simply minimally compiled. All @i{subforms} are treated as @i{non-top-level forms}. Note that @i{top level forms} are processed in the order in which they textually appear in the file and that each @i{top level form} read by the compiler is processed before the next is read. However, the order of processing (including macro expansion) of @i{subforms} that are not @i{top level forms} and the order of further compilation is unspecified as long as Common Lisp semantics are preserved. @end table @b{eval-when} forms cause compile-time evaluation only at top level. Both @t{:compile-toplevel} and @t{:load-toplevel} situation specifications are ignored for @i{non-top-level forms}. For @i{non-top-level forms}, an @b{eval-when} specifying the @t{:execute} situation is treated as an @i{implicit progn} including the @i{forms} in the body of the @b{eval-when} @i{form}; otherwise, the @i{forms} in the body are ignored. @node Processing of Defining Macros, Constraints on Macros and Compiler Macros, Processing of Top Level Forms, File Compilation @subsubsection Processing of Defining Macros Defining @i{macros} (such as @b{defmacro} or @b{defvar}) appearing within a file being processed by @b{compile-file} normally have compile-time side effects which affect how subsequent @i{forms} in the same @i{file} are compiled. A convenient model for explaining how these side effects happen is that the defining macro expands into one or more @b{eval-when} @i{forms}, and that the calls which cause the compile-time side effects to happen appear in the body of an @t{(eval-when (:compile-toplevel) ...)} @i{form}. The compile-time side effects may cause information about the definition to be stored differently than if the defining macro had been processed in the `normal' way (either interpretively or by loading the compiled file). In particular, the information stored by the defining @i{macros} at compile time might or might not be available to the interpreter (either during or after compilation), or during subsequent calls to the @i{compiler}. For example, the following code is nonportable because it assumes that the @i{compiler} stores the macro definition of @t{foo} where it is available to the interpreter: @example (defmacro foo (x) `(car ,x)) (eval-when (:execute :compile-toplevel :load-toplevel) (print (foo '(a b c)))) @end example A portable way to do the same thing would be to include the macro definition inside the @b{eval-when} @i{form}, as in: @example (eval-when (:execute :compile-toplevel :load-toplevel) (defmacro foo (x) `(car ,x)) (print (foo '(a b c)))) @end example Figure 3--8 lists macros that make definitions available both in the compilation and run-time @i{environments}. It is not specified whether definitions made available in the @i{compilation environment} are available in the evaluation @i{environment}, nor is it specified whether they are available in subsequent compilation units or subsequent invocations of the compiler. As with @b{eval-when}, these compile-time side effects happen only when the defining macros appear at top level. @format @group @noindent @w{ declaim define-modify-macro defsetf } @w{ defclass define-setf-expander defstruct } @w{ defconstant defmacro deftype } @w{ define-compiler-macro defpackage defvar } @w{ define-condition defparameter } @noindent @w{ Figure 3--8: Defining Macros That Affect the Compile-Time Environment} @end group @end format @node Constraints on Macros and Compiler Macros, , Processing of Defining Macros, File Compilation @subsubsection Constraints on Macros and Compiler Macros Except where explicitly stated otherwise, no @i{macro} defined in the @r{Common Lisp} standard produces an expansion that could cause any of the @i{subforms} of the @i{macro form} to be treated as @i{top level forms}. If an @i{implementation} also provides a @i{special operator} definition of a @r{Common Lisp} @i{macro}, the @i{special operator} definition must be semantically equivalent in this respect. @i{Compiler macro} expansions must also have the same top level evaluation semantics as the @i{form} which they replace. This is of concern both to @i{conforming implementations} and to @i{conforming programs}. @node Literal Objects in Compiled Files, Exceptional Situations in the Compiler, File Compilation, Compilation @subsection Literal Objects in Compiled Files The functions @b{eval} and @b{compile} are required to ensure that @i{literal objects} referenced within the resulting interpreted or compiled code objects are the @i{same} as the corresponding @i{objects} in the @i{source code}. @b{compile-file}, on the other hand, must produce a @i{compiled file} that, when loaded with @b{load}, constructs the @i{objects} defined by the @i{source code} and produces references to them. In the case of @b{compile-file}, @i{objects} constructed by @b{load} of the @i{compiled file} cannot be spoken of as being the @i{same} as the @i{objects} constructed at compile time, because the @i{compiled file} may be loaded into a different @i{Lisp image} than the one in which it was compiled. This section defines the concept of @i{similarity} which relates @i{objects} in the @i{evaluation environment} to the corresponding @i{objects} in the @i{run-time environment}. The constraints on @i{literal objects} described in this section apply only to @b{compile-file}; @b{eval} and @b{compile} do not copy or coalesce constants. @menu * Externalizable Objects:: * Similarity of Literal Objects:: * Similarity of Aggregate Objects:: * Definition of Similarity:: * Extensions to Similarity Rules:: * Additional Constraints on Externalizable Objects:: @end menu @node Externalizable Objects, Similarity of Literal Objects, Literal Objects in Compiled Files, Literal Objects in Compiled Files @subsubsection Externalizable Objects The fact that the @i{file compiler} represents @i{literal} @i{objects} externally in a @i{compiled file} and must later reconstruct suitable equivalents of those @i{objects} when that @i{file} is loaded imposes a need for constraints on the nature of the @i{objects} that can be used as @i{literal} @i{objects} in @i{code} to be processed by the @i{file compiler}. An @i{object} that can be used as a @i{literal} @i{object} in @i{code} to be processed by the @i{file compiler} is called an @i{externalizable object} @IGindex externalizable object . We define that two @i{objects} are @i{similar} @IGindex similar if they satisfy a two-place conceptual equivalence predicate (defined below), which is independent of the @i{Lisp image} so that the two @i{objects} in different @i{Lisp images} can be understood to be equivalent under this predicate. Further, by inspecting the definition of this conceptual predicate, the programmer can anticipate what aspects of an @i{object} are reliably preserved by @i{file compilation}. The @i{file compiler} must cooperate with the @i{loader} in order to assure that in each case where an @i{externalizable object} is processed as a @i{literal object}, the @i{loader} will construct a @i{similar} @i{object}. The set of @i{objects} that are @i{externalizable objects} @IGindex externalizable object are those for which the new conceptual term ``@i{similar}'' is defined, such that when a @i{compiled file} is @i{loaded}, an @i{object} can be constructed which can be shown to be @i{similar} to the original @i{object} which existed at the time the @i{file compiler} was operating. @node Similarity of Literal Objects, Similarity of Aggregate Objects, Externalizable Objects, Literal Objects in Compiled Files @subsubsection Similarity of Literal Objects @node Similarity of Aggregate Objects, Definition of Similarity, Similarity of Literal Objects, Literal Objects in Compiled Files @subsubsection Similarity of Aggregate Objects Of the @i{types} over which @i{similarity} is defined, some are treated as aggregate objects. For these types, @i{similarity} is defined recursively. We say that an @i{object} of these types has certain ``basic qualities'' and to satisfy the @i{similarity} relationship, the values of the corresponding qualities of the two @i{objects} must also be similar. @node Definition of Similarity, Extensions to Similarity Rules, Similarity of Aggregate Objects, Literal Objects in Compiled Files @subsubsection Definition of Similarity Two @i{objects} S (in @i{source code}) and C (in @i{compiled code}) are defined to be @i{similar} if and only if they are both of one of the @i{types} listed here (or defined by the @i{implementation}) and they both satisfy all additional requirements of @i{similarity} indicated for that @i{type}. @table @asis @item @b{number} Two @i{numbers} S and C are @i{similar} if they are of the same @i{type} and represent the same mathematical value. @item @b{character} Two @i{simple} @i{characters} S and C are @i{similar} if they have @i{similar} @i{code} @i{attributes}. @i{Implementations} providing additional, @i{implementation-defined} @i{attributes} must define whether and how @i{non-simple} @i{characters} can be regarded as @i{similar}. @item @b{symbol} Two @i{apparently uninterned} @i{symbols} S and C are @i{similar} if their @i{names} are @i{similar}. Two @i{interned} symbols S and C are @i{similar} if their @i{names} are @i{similar}, and if either S is accessible in the @i{current package} at compile time and C is accessible in the @i{current package} at load time, or C is accessible in the @i{package} that is @i{similar} to the @i{home package} of S. (Note that @i{similarity} of @i{symbols} is dependent on neither the @i{current readtable} nor how the @i{function} @b{read} would parse the @i{characters} in the @i{name} of the @i{symbol}.) @item @b{package} Two @i{packages} S and C are @i{similar} if their @i{names} are @i{similar}. Note that although a @i{package} @i{object} is an @i{externalizable object}, the programmer is responsible for ensuring that the corresponding @i{package} is already in existence when code referencing it as a @i{literal} @i{object} is @i{loaded}. The @i{loader} finds the corresponding @i{package} @i{object} as if by calling @b{find-package} with that @i{name} as an @i{argument}. An error is signaled by the @i{loader} if no @i{package} exists at load time. @item @b{random-state} Two @i{random states} S and C are @i{similar} if S would always produce the same sequence of pseudo-random numbers as a @i{copy}_5 of C when given as the @i{random-state} @i{argument} to the @i{function} @b{random}, assuming equivalent @i{limit} @i{arguments} in each case. (Note that since C has been processed by the @i{file compiler}, it cannot be used directly as an @i{argument} to @b{random} because @b{random} would perform a side effect.) @item @b{cons} Two @i{conses}, S and C, are @i{similar} if the @i{car}_2 of S is @i{similar} to the @i{car}_2 of C, and the @i{cdr}_2 of S is @i{similar} to the @i{cdr}_2 of C. @item @b{array} Two one-dimensional @i{arrays}, S and C, are @i{similar} if the @i{length} of S is @i{similar} to the @i{length} of C, the @i{actual array element type} of S is @i{similar} to the @i{actual array element type} of C, and each @i{active} @i{element} of S is @i{similar} to the corresponding @i{element} of C. Two @i{arrays} of @i{rank} other than one, S and C, are @i{similar} if the @i{rank} of S is @i{similar} to the @i{rank} of C, each @i{dimension}_1 of S is @i{similar} to the corresponding @i{dimension}_1 of C, the @i{actual array element type} of S is @i{similar} to the @i{actual array element type} of C, and each @i{element} of S is @i{similar} to the corresponding @i{element} of C. In addition, if S is a @i{simple array}, then C must also be a @i{simple array}. If S is a @i{displaced array}, has a @i{fill pointer}, or is @i{actually adjustable}, C is permitted to lack any or all of these qualities. @item @b{hash-table} Two @i{hash tables} S and C are @i{similar} if they meet the following three requirements: @table @asis @item 1. They both have the same test (@i{e.g.}, they are both @b{eql} @i{hash tables}). @item 2. There is a unique one-to-one correspondence between the keys of the two @i{hash tables}, such that the corresponding keys are @i{similar}. @item 3. For all keys, the values associated with two corresponding keys are @i{similar}. @end table If there is more than one possible one-to-one correspondence between the keys of S and C, the consequences are unspecified. A @i{conforming program} cannot use a table such as S as an @i{externalizable constant}. @item @b{pathname} Two @i{pathnames} S and C are @i{similar} if all corresponding @i{pathname components} are @i{similar}. @item @b{function} @i{Functions} are not @i{externalizable objects}. @item @b{structure-object} and @b{standard-object} A general-purpose concept of @i{similarity} does not exist for @i{structures} and @i{standard objects}. However, a @i{conforming program} is permitted to define a @b{make-load-form} @i{method} for any @i{class} K defined by that @i{program} that is a @i{subclass} of either @b{structure-object} or @b{standard-object}. The effect of such a @i{method} is to define that an @i{object} S of @i{type} K in @i{source code} is @i{similar} to an @i{object} C of @i{type} K in @i{compiled code} if C was constructed from @i{code} produced by calling @b{make-load-form} on S. @end table @node Extensions to Similarity Rules, Additional Constraints on Externalizable Objects, Definition of Similarity, Literal Objects in Compiled Files @subsubsection Extensions to Similarity Rules Some @i{objects}, such as @i{streams}, @b{readtables}, and @b{methods} are not @i{externalizable objects} under the definition of similarity given above. That is, such @i{objects} may not portably appear as @i{literal} @i{objects} in @i{code} to be processed by the @i{file compiler}. An @i{implementation} is permitted to extend the rules of similarity, so that other kinds of @i{objects} are @i{externalizable objects} for that @i{implementation}. If for some kind of @i{object}, @i{similarity} is neither defined by this specification nor by the @i{implementation}, then the @i{file compiler} must signal an error upon encountering such an @i{object} as a @i{literal constant}. @node Additional Constraints on Externalizable Objects, , Extensions to Similarity Rules, Literal Objects in Compiled Files @subsubsection Additional Constraints on Externalizable Objects If two @i{literal objects} appearing in the source code for a single file processed with the @i{file compiler} are the @i{identical}, the corresponding @i{objects} in the @i{compiled code} must also be the @i{identical}. With the exception of @i{symbols} and @i{packages}, any two @i{literal objects} in @i{code} being processed by the @i{file compiler} may be @i{coalesced} if and only if they are @i{similar}; if they are either both @i{symbols} or both @i{packages}, they may only be @i{coalesced} if and only if they are @i{identical}. @i{Objects} containing circular references can be @i{externalizable objects}. The @i{file compiler} is required to preserve @b{eql}ness of substructures within a @i{file}. Preserving @b{eql}ness means that subobjects that are the @i{same} in the @i{source code} must be the @i{same} in the corresponding @i{compiled code}. In addition, the following are constraints on the handling of @i{literal objects} by the @i{file compiler}: @table @asis @item @t{} @b{array:} If an @i{array} in the source code is a @i{simple array}, then the corresponding @i{array} in the compiled code will also be a @i{simple array}. If an @i{array} in the source code is displaced, has a @i{fill pointer}, or is @i{actually adjustable}, the corresponding @i{array} in the compiled code might lack any or all of these qualities. If an @i{array} in the source code has a fill pointer, then the corresponding @i{array} in the compiled code might be only the size implied by the fill pointer. @item @t{} @b{packages:} The loader is required to find the corresponding @i{package} @i{object} as if by calling @b{find-package} with the package name as an argument. An error of @i{type} @b{package-error} is signaled if no @i{package} of that name exists at load time. @item @t{} @b{random-state:} A constant @i{random state} object cannot be used as the state argument to the @i{function} @b{random} because @b{random} modifies this data structure. @item @t{} @b{structure, standard-object:} @i{Objects} of @i{type} @b{structure-object} and @b{standard-object} may appear in compiled constants if there is an appropriate @b{make-load-form} method defined for that @i{type}. The @i{file compiler} calls @b{make-load-form} on any @i{object} that is referenced as a @i{literal object} if the @i{object} is a @i{generalized instance} of @b{standard-object}, @b{structure-object}, @b{condition}, or any of a (possibly empty) @i{implementation-dependent} set of other @i{classes}. The @i{file compiler} only calls @b{make-load-form} once for any given @i{object} within a single @i{file}. @item @t{} @b{symbol:} In order to guarantee that @i{compiled files} can be @i{loaded} correctly, users must ensure that the @i{packages} referenced in those @i{files} are defined consistently at compile time and load time. @i{Conforming programs} must satisfy the following requirements: @table @asis @item 1. The @i{current package} when a @i{top level form} in the @i{file} is processed by @b{compile-file} must be the same as the @i{current package} when the @i{code} corresponding to that @i{top level form} in the @i{compiled file} is executed by @b{load}. In particular: @table @asis @item a. Any @i{top level form} in a @i{file} that alters the @i{current package} must change it to a @i{package} of the same @i{name} both at compile time and at load time. @item b. If the first @i{non-atomic} @i{top level form} in the @i{file} is not an @b{in-package} @i{form}, then the @i{current package} at the time @b{load} is called must be a @i{package} with the same @i{name} as the package that was the @i{current package} at the time @b{compile-file} was called. @end table @item 2. For all @i{symbols} appearing lexically within a @i{top level form} that were @i{accessible} in the @i{package} that was the @i{current package} during processing of that @i{top level form} at compile time, but whose @i{home package} was another @i{package}, at load time there must be a @i{symbol} with the same @i{name} that is @i{accessible} in both the load-time @i{current package} and in the @i{package} with the same @i{name} as the compile-time @i{home package}. @item 3. For all @i{symbols} represented in the @i{compiled file} that were @i{external symbols} in their @i{home package} at compile time, there must be a @i{symbol} with the same @i{name} that is an @i{external symbol} in the @i{package} with the same @i{name} at load time. @end table If any of these conditions do not hold, the @i{package} in which the @i{loader} looks for the affected @i{symbols} is unspecified. @i{Implementations} are permitted to signal an error or to define this behavior. @end table @node Exceptional Situations in the Compiler, , Literal Objects in Compiled Files, Compilation @subsection Exceptional Situations in the Compiler @b{compile} and @b{compile-file} are permitted to signal errors and warnings, including errors due to compile-time processing of @t{(eval-when (:compile-toplevel) ...)} forms, macro expansion, and conditions signaled by the compiler itself. @i{Conditions} of @i{type} @b{error} might be signaled by the compiler in situations where the compilation cannot proceed without intervention. In addition to situations for which the standard specifies that @i{conditions} of @i{type} @b{warning} must or might be signaled, warnings might be signaled in situations where the compiler can determine that the consequences are undefined or that a run-time error will be signaled. Examples of this situation are as follows: violating type declarations, altering or assigning the value of a constant defined with @b{defconstant}, calling built-in Lisp functions with a wrong number of arguments or malformed keyword argument lists, and using unrecognized declaration specifiers. The compiler is permitted to issue warnings about matters of programming style as conditions of @i{type} @b{style-warning}. Examples of this situation are as follows: redefining a function using a different argument list, calling a function with a wrong number of arguments, not declaring @b{ignore} of a local variable that is not referenced, and referencing a variable declared @b{ignore}. Both @b{compile} and @b{compile-file} are permitted (but not required) to @i{establish} a @i{handler} for @i{conditions} of @i{type} @b{error}. For example, they might signal a warning, and restart compilation from some @i{implementation-dependent} point in order to let the compilation proceed without manual intervention. Both @b{compile} and @b{compile-file} return three values, the second two indicating whether the source code being compiled contained errors and whether style warnings were issued. Some warnings might be deferred until the end of compilation. See @b{with-compilation-unit}. @c end of including concept-compile @node Declarations, Lambda Lists, Compilation, Evaluation and Compilation @section Declarations @c including concept-decls @i{Declarations} @IGindex declaration provide a way of specifying information for use by program processors, such as the evaluator or the compiler. @i{Local declarations} @IGindex local declaration can be embedded in executable code using @b{declare}. @i{Global declarations} @IGindex global declaration , or @i{proclamations} @IGindex proclamation , are established by @b{proclaim} or @b{declaim}. The @b{the} @i{special form} provides a shorthand notation for making a @i{local declaration} about the @i{type} of the @i{value} of a given @i{form}. The consequences are undefined if a program violates a @i{declaration} or a @i{proclamation}. @menu * Minimal Declaration Processing Requirements:: * Declaration Specifiers:: * Declaration Identifiers:: * Declaration Scope:: @end menu @node Minimal Declaration Processing Requirements, Declaration Specifiers, Declarations, Declarations @subsection Minimal Declaration Processing Requirements In general, an @i{implementation} is free to ignore @i{declaration specifiers} except for the @b{declaration} @IRindex declaration , @b{notinline} @IRindex notinline , @b{safety} @IRindex safety , and @b{special} @IRindex special @i{declaration specifiers}. A @b{declaration} @i{declaration} must suppress warnings about unrecognized @i{declarations} of the kind that it declares. If an @i{implementation} does not produce warnings about unrecognized declarations, it may safely ignore this @i{declaration}. A @b{notinline} @i{declaration} must be recognized by any @i{implementation} that supports inline functions or @i{compiler macros} in order to disable those facilities. An @i{implementation} that does not use inline functions or @i{compiler macros} may safely ignore this @i{declaration}. A @b{safety} @i{declaration} that increases the current safety level must always be recognized. An @i{implementation} that always processes code as if safety were high may safely ignore this @i{declaration}. A @b{special} @i{declaration} must be processed by all @i{implementations}. @node Declaration Specifiers, Declaration Identifiers, Minimal Declaration Processing Requirements, Declarations @subsection Declaration Specifiers A @i{declaration specifier} @IGindex declaration specifier is an @i{expression} that can appear at top level of a @b{declare} expression or a @b{declaim} form, or as the argument to @b{proclaim}. It is a @i{list} whose @i{car} is a @i{declaration identifier}, and whose @i{cdr} is data interpreted according to rules specific to the @i{declaration identifier}. @node Declaration Identifiers, Declaration Scope, Declaration Specifiers, Declarations @subsection Declaration Identifiers Figure 3--9 shows a list of all @i{declaration identifiers} @IGindex declaration identifier defined by this standard. @format @group @noindent @w{ declaration ignore special } @w{ dynamic-extent inline type } @w{ ftype notinline } @w{ ignorable optimize } @noindent @w{ Figure 3--9: Common Lisp Declaration Identifiers} @end group @end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. A warning might be issued if a @i{declaration identifier} is not among those defined above, is not defined by the @i{implementation}, is not a @i{type} @i{name}, and has not been declared in a @b{declaration} @i{proclamation}. @menu * Shorthand notation for Type Declarations:: @end menu @node Shorthand notation for Type Declarations, , Declaration Identifiers, Declaration Identifiers @subsubsection Shorthand notation for Type Declarations A @i{type specifier} can be used as a @i{declaration identifier}. @t{(@i{type-specifier} @{@i{var}@}*)} is taken as shorthand for @t{(type @i{type-specifier} @{@i{var}@}*)}. @node Declaration Scope, , Declaration Identifiers, Declarations @subsection Declaration Scope @i{Declarations} can be divided into two kinds: those that apply to the @i{bindings} of @i{variables} or @i{functions}; and those that do not apply to @i{bindings}. A @i{declaration} that appears at the head of a binding @i{form} and applies to a @i{variable} or @i{function} @i{binding} made by that @i{form} is called a @i{bound declaration} @IGindex bound declaration ; such a @i{declaration} affects both the @i{binding} and any references within the @i{scope} of the @i{declaration}. @i{Declarations} that are not @i{bound declarations} are called @i{free declarations} @IGindex free declaration . A @i{free declaration} in a @i{form} F1 that applies to a @i{binding} for a @i{name} N @i{established} by some @i{form} F2 of which F1 is a @i{subform} affects only references to N within F1; it does not to apply to other references to N outside of F1, nor does it affect the manner in which the @i{binding} of N by F2 is @i{established}. @i{Declarations} that do not apply to @i{bindings} can only appear as @i{free declarations}. The @i{scope} of a @i{bound declaration} is the same as the @i{lexical scope} of the @i{binding} to which it applies; for @i{special variables}, this means the @i{scope} that the @i{binding} would have had had it been a @i{lexical binding}. Unless explicitly stated otherwise, the @i{scope} of a @i{free declaration} includes only the body @i{subforms} of the @i{form} at whose head it appears, and no other @i{subforms}. The @i{scope} of @i{free declarations} specifically does not include @i{initialization forms} for @i{bindings} established by the @i{form} containing the @i{declarations}. Some @i{iteration forms} include step, end-test, or result @i{subforms} that are also included in the @i{scope} of @i{declarations} that appear in the @i{iteration form}. Specifically, the @i{iteration forms} and @i{subforms} involved are: @table @asis @item @t{*} @b{do}, @b{do*}: @i{step-forms}, @i{end-test-form}, and @i{result-forms}. @item @t{*} @b{dolist}, @b{dotimes}: @i{result-form} @item @t{*} @b{do-all-symbols}, @b{do-external-symbols}, @b{do-symbols}: @i{result-form} @end table @menu * Examples of Declaration Scope:: @end menu @node Examples of Declaration Scope, , Declaration Scope, Declaration Scope @subsubsection Examples of Declaration Scope Here is an example illustrating the @i{scope} of @i{bound declarations}. @example (let ((x 1)) ;[1] 1st occurrence of x (declare (special x)) ;[2] 2nd occurrence of x (let ((x 2)) ;[3] 3rd occurrence of x (let ((old-x x) ;[4] 4th occurrence of x (x 3)) ;[5] 5th occurrence of x (declare (special x)) ;[6] 6th occurrence of x (list old-x x)))) ;[7] 7th occurrence of x @result{} (2 3) @end example The first occurrence of @t{x} @i{establishes} a @i{dynamic binding} of @t{x} because of the @b{special} @i{declaration} for @t{x} in the second line. The third occurrence of @t{x} @i{establishes} a @i{lexical binding} of @t{x} (because there is no @b{special} @i{declaration} in the corresponding @b{let} @i{form}). The fourth occurrence of @t{x} @i{x} is a reference to the @i{lexical binding} of @t{x} established in the third line. The fifth occurrence of @t{x} @i{establishes} a @i{dynamic binding} of @i{x} for the body of the @b{let} @i{form} that begins on that line because of the @b{special} @i{declaration} for @t{x} in the sixth line. The reference to @t{x} in the fourth line is not affected by the @b{special} @i{declaration} in the sixth line because that reference is not within the ``would-be @i{lexical scope}'' of the @i{variable} @t{x} in the fifth line. The reference to @t{x} in the seventh line is a reference to the @i{dynamic binding} of @i{x} @i{established} in the fifth line. Here is another example, to illustrate the @i{scope} of a @i{free declaration}. In the following: @example (lambda (&optional (x (foo 1))) ;[1] (declare (notinline foo)) ;[2] (foo x)) ;[3] @end example the @i{call} to @t{foo} in the first line might be compiled inline even though the @i{call} to @t{foo} in the third line must not be. This is because the @b{notinline} @i{declaration} for @t{foo} in the second line applies only to the body on the third line. In order to suppress inlining for both @i{calls}, one might write: @example (locally (declare (notinline foo)) ;[1] (lambda (&optional (x (foo 1))) ;[2] (foo x))) ;[3] @end example or, alternatively: @example (lambda (&optional ;[1] (x (locally (declare (notinline foo)) ;[2] (foo 1)))) ;[3] (declare (notinline foo)) ;[4] (foo x)) ;[5] @end example Finally, here is an example that shows the @i{scope} of @i{declarations} in an @i{iteration form}. @example (let ((x 1)) ;[1] (declare (special x)) ;[2] (let ((x 2)) ;[3] (dotimes (i x x) ;[4] (declare (special x))))) ;[5] @result{} 1 @end example In this example, the first reference to @t{x} on the fourth line is to the @i{lexical binding} of @t{x} established on the third line. However, the second occurrence of @t{x} on the fourth line lies within the @i{scope} of the @i{free declaration} on the fifth line (because this is the @i{result-form} of the @b{dotimes}) and therefore refers to the @i{dynamic binding} of @t{x}. @c end of including concept-decls @node Lambda Lists, Error Checking in Function Calls, Declarations, Evaluation and Compilation @section Lambda Lists @c including concept-bvl A @i{lambda list} @IGindex lambda list is a @i{list} that specifies a set of @i{parameters} (sometimes called @i{lambda variables}) and a protocol for receiving @i{values} for those @i{parameters}. There are several kinds of @i{lambda lists}. @format @group @noindent @w{ Context Kind of Lambda List } @w{ @b{defun} @i{form} @i{ordinary lambda list} } @w{ @b{defmacro} @i{form} @i{macro lambda list} } @w{ @i{lambda expression} @i{ordinary lambda list} } @w{ @b{flet} local @i{function} definition @i{ordinary lambda list} } @w{ @b{labels} local @i{function} definition @i{ordinary lambda list} } @w{ @b{handler-case} @i{clause} specification @i{ordinary lambda list} } @w{ @b{restart-case} @i{clause} specification @i{ordinary lambda list} } @w{ @b{macrolet} local @i{macro} definition @i{macro lambda list} } @w{ @b{define-method-combination} @i{ordinary lambda list} } @w{ @b{define-method-combination} @t{:arguments} option @i{define-method-combination arguments lambda list} } @w{ @b{defstruct} @t{:constructor} option @i{boa lambda list} } @w{ @b{defgeneric} @i{form} @i{generic function lambda list} } @w{ @b{defgeneric} @i{method} clause @i{specialized lambda list} } @w{ @b{defmethod} @i{form} @i{specialized lambda list} } @w{ @b{defsetf} @i{form} @i{defsetf lambda list} } @w{ @b{define-setf-expander} @i{form} @i{macro lambda list} } @w{ @b{deftype} @i{form} @i{deftype lambda list} } @w{ @b{destructuring-bind} @i{form} @i{destructuring lambda list} } @w{ @b{define-compiler-macro} @i{form} @i{macro lambda list} } @w{ @b{define-modify-macro} @i{form} @i{define-modify-macro lambda list} } @noindent @w{ Figure 3--10: What Kind of Lambda Lists to Use } @end group @end format Figure 3--11 lists some @i{defined names} that are applicable to @i{lambda lists}. @format @group @noindent @w{ lambda-list-keywords lambda-parameters-limit } @noindent @w{ Figure 3--11: Defined names applicable to lambda lists} @end group @end format @menu * Ordinary Lambda Lists:: * Generic Function Lambda Lists:: * Specialized Lambda Lists:: * Macro Lambda Lists:: * Destructuring Lambda Lists:: * Boa Lambda Lists:: * Defsetf Lambda Lists:: * Deftype Lambda Lists:: * Define-modify-macro Lambda Lists:: * Define-method-combination Arguments Lambda Lists:: * Syntactic Interaction of Documentation Strings and Declarations:: @end menu @node Ordinary Lambda Lists, Generic Function Lambda Lists, Lambda Lists, Lambda Lists @subsection Ordinary Lambda Lists An @i{ordinary lambda list} @IGindex ordinary lambda list is used to describe how a set of @i{arguments} is received by an @i{ordinary} @i{function}. The @i{defined names} in Figure 3--12 are those which use @i{ordinary lambda lists}: @format @group @noindent @w{ define-method-combination handler-case restart-case } @w{ defun labels } @w{ flet lambda } @noindent @w{ Figure 3--12: Standardized Operators that use Ordinary Lambda Lists} @end group @end format An @i{ordinary lambda list} can contain the @i{lambda list keywords} shown in Figure 3--13. @format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @w{ @b{&aux} @b{&optional} } @noindent @w{ Figure 3--13: Lambda List Keywords used by Ordinary Lambda Lists} @end group @end format Each @i{element} of a @i{lambda list} is either a parameter specifier or a @i{lambda list keyword}. Implementations are free to provide additional @i{lambda list keywords}. For a list of all @i{lambda list keywords} used by the implementation, see @b{lambda-list-keywords}. The syntax for @i{ordinary lambda lists} is as follows: @w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} @w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter @r{]}@r{]}@r{)}@}*@t{]}} @w{ @t{[}@r{&rest} @i{var}@t{]}} @w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} @w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} @w{ } A @i{var} or @i{supplied-p-parameter} must be a @i{symbol} that is not the name of a @i{constant variable}. An @i{init-form} can be any @i{form}. Whenever any @i{init-form} is evaluated for any parameter specifier, that @i{form} may refer to any parameter variable to the left of the specifier in which the @i{init-form} appears, including any @i{supplied-p-parameter} variables, and may rely on the fact that no other parameter variable has yet been bound (including its own parameter variable). A @i{keyword-name} can be any @i{symbol}, but by convention is normally a @i{keyword}_1; all @i{standardized} @i{functions} follow that convention. An @i{ordinary lambda list} has five parts, any or all of which may be empty. For information about the treatment of argument mismatches, see @ref{Error Checking in Function Calls}. @menu * Specifiers for the required parameters:: * Specifiers for optional parameters:: * A specifier for a rest parameter:: * Specifiers for keyword parameters:: * Suppressing Keyword Argument Checking:: * Examples of Suppressing Keyword Argument Checking:: * Specifiers for @b{&aux} variables:: * Examples of Ordinary Lambda Lists:: @end menu @node Specifiers for the required parameters, Specifiers for optional parameters, Ordinary Lambda Lists, Ordinary Lambda Lists @subsubsection Specifiers for the required parameters These are all the parameter specifiers up to the first @i{lambda list keyword}; if there are no @i{lambda list keywords}, then all the specifiers are for required parameters. Each required parameter is specified by a parameter variable @i{var}. @i{var} is bound as a lexical variable unless it is declared @b{special}. If there are @t{n} required parameters (@t{n} may be zero), there must be at least @t{n} passed arguments, and the required parameters are bound to the first @t{n} passed arguments; see @ref{Error Checking in Function Calls}. The other parameters are then processed using any remaining arguments. @node Specifiers for optional parameters, A specifier for a rest parameter, Specifiers for the required parameters, Ordinary Lambda Lists @subsubsection Specifiers for optional parameters @IRindex &optional If @b{&optional} is present, the optional parameter specifiers are those following @b{&optional} up to the next @i{lambda list keyword} or the end of the list. If optional parameters are specified, then each one is processed as follows. If any unprocessed arguments remain, then the parameter variable @i{var} is bound to the next remaining argument, just as for a required parameter. If no arguments remain, however, then @i{init-form} is evaluated, and the parameter variable is bound to the resulting value (or to @b{nil} if no @i{init-form} appears in the parameter specifier). If another variable name @i{supplied-p-parameter} appears in the specifier, it is bound to @i{true} if an argument had been available, and to @i{false} if no argument remained (and therefore @i{init-form} had to be evaluated). @i{Supplied-p-parameter} is bound not to an argument but to a value indicating whether or not an argument had been supplied for the corresponding @i{var}. @node A specifier for a rest parameter, Specifiers for keyword parameters, Specifiers for optional parameters, Ordinary Lambda Lists @subsubsection A specifier for a rest parameter @IRindex &rest @b{&rest}, if present, must be followed by a single @i{rest parameter} specifier, which in turn must be followed by another @i{lambda list keyword} or the end of the @i{lambda list}. After all optional parameter specifiers have been processed, then there may or may not be a @i{rest parameter}. If there is a @i{rest parameter}, it is bound to a @i{list} of all as-yet-unprocessed arguments. If no unprocessed arguments remain, the @i{rest parameter} is bound to the @i{empty list}. If there is no @i{rest parameter} and there are no @i{keyword parameters}, then an error should be signaled if any unprocessed arguments remain; see @ref{Error Checking in Function Calls}. The value of a @i{rest parameter} is permitted, but not required, to share structure with the last argument to @b{apply}. @IRindex &key @IRindex &allow-other-keys @node Specifiers for keyword parameters, Suppressing Keyword Argument Checking, A specifier for a rest parameter, Ordinary Lambda Lists @subsubsection Specifiers for keyword parameters If @b{&key} is present, all specifiers up to the next @i{lambda list keyword} or the end of the @i{list} are keyword parameter specifiers. When keyword parameters are processed, the same arguments are processed that would be made into a @i{list} for a @i{rest parameter}. It is permitted to specify both @b{&rest} and @b{&key}. In this case the remaining arguments are used for both purposes; that is, all remaining arguments are made into a @i{list} for the @i{rest parameter}, and are also processed for the @b{&key} parameters. If @b{&key} is specified, there must remain an even number of arguments; see @ref{Odd Number of Keyword Arguments}. These arguments are considered as pairs, the first argument in each pair being interpreted as a name and the second as the corresponding value. The first @i{object} of each pair must be a @i{symbol}; see @ref{Invalid Keyword Arguments}. The keyword parameter specifiers may optionally be followed by the @i{lambda list keyword} @b{&allow-other-keys}. In each keyword parameter specifier must be a name @i{var} for the parameter variable. If the @i{var} appears alone or in a @t{(@i{var} @i{init-form})} combination, the keyword name used when matching @i{arguments} to @i{parameters} is a @i{symbol} in the @t{KEYWORD} @i{package} whose @i{name} is the @i{same} (under @b{string=}) as @i{var}'s. If the notation @t{((@i{keyword-name} @i{var}) @i{init-form})} is used, then the keyword name used to match @i{arguments} to @i{parameters} is @i{keyword-name}, which may be a @i{symbol} in any @i{package}. (Of course, if it is not a @i{symbol} in the @t{KEYWORD} @i{package}, it does not necessarily self-evaluate, so care must be taken when calling the function to make sure that normal evaluation still yields the keyword name.) Thus @example (defun foo (&key radix (type 'integer)) ...) @end example means exactly the same as @example (defun foo (&key ((:radix radix)) ((:type type) 'integer)) ...) @end example The keyword parameter specifiers are, like all parameter specifiers, effectively processed from left to right. For each keyword parameter specifier, if there is an argument pair whose name matches that specifier's name (that is, the names are @b{eq}), then the parameter variable for that specifier is bound to the second item (the value) of that argument pair. If more than one such argument pair matches, the leftmost argument pair is used. If no such argument pair exists, then the @i{init-form} for that specifier is evaluated and the parameter variable is bound to that value (or to @b{nil} if no @i{init-form} was specified). @i{supplied-p-parameter} is treated as for @b{&optional} parameters: it is bound to @i{true} if there was a matching argument pair, and to @i{false} otherwise. Unless keyword argument checking is suppressed, an argument pair must a name matched by a parameter specifier; see @ref{Unrecognized Keyword Arguments}. If keyword argument checking is suppressed, then it is permitted for an argument pair to match no parameter specifier, and the argument pair is ignored, but such an argument pair is accessible through the @i{rest parameter} if one was supplied. The purpose of these mechanisms is to allow sharing of argument lists among several @i{lambda expressions} and to allow either the caller or the called @i{lambda expression} to specify that such sharing may be taking place. Note that if @b{&key} is present, a keyword argument of @t{:allow-other-keys} is always permitted---regardless of whether the associated value is @i{true} or @i{false}. However, if the value is @i{false}, other non-matching keywords are not tolerated (unless @b{&allow-other-keys} was used). Furthermore, if the receiving argument list specifies a regular argument which would be flagged by @t{:allow-other-keys}, then @t{:allow-other-keys} has both its special-cased meaning (identifying whether additional keywords are permitted) and its normal meaning (data flow into the function in question). @node Suppressing Keyword Argument Checking, Examples of Suppressing Keyword Argument Checking, Specifiers for keyword parameters, Ordinary Lambda Lists @subsubsection Suppressing Keyword Argument Checking If @b{&allow-other-keys} was specified in the @i{lambda list} of a @i{function}, @i{keyword}_2 @i{argument} checking is suppressed in calls to that @i{function}. If the @t{:allow-other-keys} @i{argument} is @i{true} in a call to a @i{function}, @i{keyword}_2 @i{argument} checking is suppressed in that call. The @t{:allow-other-keys} @i{argument} is permissible in all situations involving @i{keyword}_2 @i{arguments}, even when its associated @i{value} is @i{false}. @node Examples of Suppressing Keyword Argument Checking, Specifiers for @b{&aux} variables, Suppressing Keyword Argument Checking, Ordinary Lambda Lists @subsubsection Examples of Suppressing Keyword Argument Checking @example ;;; The caller can supply :ALLOW-OTHER-KEYS T to suppress checking. ((lambda (&key x) x) :x 1 :y 2 :allow-other-keys t) @result{} 1 ;;; The callee can use &ALLOW-OTHER-KEYS to suppress checking. ((lambda (&key x &allow-other-keys) x) :x 1 :y 2) @result{} 1 ;;; :ALLOW-OTHER-KEYS NIL is always permitted. ((lambda (&key) t) :allow-other-keys nil) @result{} T ;;; As with other keyword arguments, only the left-most pair ;;; named :ALLOW-OTHER-KEYS has any effect. ((lambda (&key x) x) :x 1 :y 2 :allow-other-keys t :allow-other-keys nil) @result{} 1 ;;; Only the left-most pair named :ALLOW-OTHER-KEYS has any effect, ;;; so in safe code this signals a PROGRAM-ERROR (and might enter the ;;; debugger). In unsafe code, the consequences are undefined. ((lambda (&key x) x) ;This call is not valid :x 1 :y 2 :allow-other-keys nil :allow-other-keys t) @end example @node Specifiers for @b{&aux} variables, Examples of Ordinary Lambda Lists, Examples of Suppressing Keyword Argument Checking, Ordinary Lambda Lists @subsubsection Specifiers for @b{&aux} variables @IRindex &aux These are not really parameters. If the @i{lambda list keyword} @b{&aux} is present, all specifiers after it are auxiliary variable specifiers. After all parameter specifiers have been processed, the auxiliary variable specifiers (those following @b{&aux}) are processed from left to right. For each one, @i{init-form} is evaluated and @i{var} is bound to that value (or to @b{nil} if no @i{init-form} was specified). @b{&aux} variable processing is analogous to @b{let*} processing. @example (lambda (x y &aux (a (car x)) (b 2) c) (list x y a b c)) @equiv{} (lambda (x y) (let* ((a (car x)) (b 2) c) (list x y a b c))) @end example @node Examples of Ordinary Lambda Lists, , Specifiers for @b{&aux} variables, Ordinary Lambda Lists @subsubsection Examples of Ordinary Lambda Lists Here are some examples involving @i{optional parameters} and @i{rest parameters}: @example ((lambda (a b) (+ a (* b 3))) 4 5) @result{} 19 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5) @result{} 19 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4) @result{} 10 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x))) @result{} (2 NIL 3 NIL NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6) @result{} (6 T 3 NIL NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3) @result{} (6 T 3 T NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8) @result{} (6 T 3 T (8)) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8 9 10 11) @result{} (6 t 3 t (8 9 10 11)) @end example Here are some examples involving @i{keyword parameters}: @example ((lambda (a b &key c d) (list a b c d)) 1 2) @result{} (1 2 NIL NIL) ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6) @result{} (1 2 6 NIL) ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8) @result{} (1 2 NIL 8) ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8) @result{} (1 2 6 8) ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6) @result{} (1 2 6 8) ((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6) @result{} (:a 1 6 8) ((lambda (a b &key c d) (list a b c d)) :a :b :c :d) @result{} (:a :b :d NIL) ((lambda (a b &key ((:sea c)) d) (list a b c d)) 1 2 :sea 6) @result{} (1 2 6 NIL) ((lambda (a b &key ((c c)) d) (list a b c d)) 1 2 'c 6) @result{} (1 2 6 NIL) @end example Here are some examples involving @i{optional parameters}, @i{rest parameters}, and @i{keyword parameters} together: @example ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1) @result{} (1 3 NIL 1 ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 2) @result{} (1 2 NIL 1 ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) :c 7) @result{} (:c 7 NIL :c ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :c 7) @result{} (1 6 7 1 (:c 7)) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8) @result{} (1 6 NIL 8 (:d 8)) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8 :c 9 :d 10) @result{} (1 6 9 8 (:d 8 :c 9 :d 10)) @end example As an example of the use of @b{&allow-other-keys} and @t{:allow-other-keys}, consider a @i{function} that takes two named arguments of its own and also accepts additional named arguments to be passed to @b{make-array}: @example (defun array-of-strings (str dims &rest named-pairs &key (start 0) end &allow-other-keys) (apply #'make-array dims :initial-element (subseq str start end) :allow-other-keys t named-pairs)) @end example This @i{function} takes a @i{string} and dimensioning information and returns an @i{array} of the specified dimensions, each of whose elements is the specified @i{string}. However, @t{:start} and @t{:end} named arguments may be used to specify that a substring of the given @i{string} should be used. In addition, the presence of @b{&allow-other-keys} in the @i{lambda list} indicates that the caller may supply additional named arguments; the @i{rest parameter} provides access to them. These additional named arguments are passed to @b{make-array}. The @i{function} @b{make-array} normally does not allow the named arguments @t{:start} and @t{:end} to be used, and an error should be signaled if such named arguments are supplied to @b{make-array}. However, the presence in the call to @b{make-array} of the named argument @t{:allow-other-keys} with a @i{true} value causes any extraneous named arguments, including @t{:start} and @t{:end}, to be acceptable and ignored. @node Generic Function Lambda Lists, Specialized Lambda Lists, Ordinary Lambda Lists, Lambda Lists @subsection Generic Function Lambda Lists A @i{generic function lambda list} @IGindex generic function lambda list is used to describe the overall shape of the argument list to be accepted by a @i{generic function}. Individual @i{method} @i{signatures} might contribute additional @i{keyword parameters} to the @i{lambda list} of the @i{effective method}. A @i{generic function lambda list} is used by @b{defgeneric}. A @i{generic function lambda list} has the following syntax: @w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} @w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var}@r{)}@}*@t{]}} @w{ @t{[}@r{&rest} @i{var}@t{]}} @w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}@r{)}} @w{ } A @i{generic function lambda list} can contain the @i{lambda list keywords} shown in Figure 3--14. @format @group @noindent @w{ @b{&allow-other-keys} @b{&optional} } @w{ @b{&key} @b{&rest} } @noindent @w{ Figure 3--14: Lambda List Keywords used by Generic Function Lambda Lists} @end group @end format A @i{generic function lambda list} differs from an @i{ordinary lambda list} in the following ways: @table @asis @item Required arguments Zero or more @i{required parameters} must be specified. @item Optional and keyword arguments @i{Optional parameters} and @i{keyword parameters} may not have default initial value forms nor use supplied-p parameters. @item Use of @b{&aux} The use of @b{&aux} is not allowed. @end table @node Specialized Lambda Lists, Macro Lambda Lists, Generic Function Lambda Lists, Lambda Lists @subsection Specialized Lambda Lists A @i{specialized lambda list} @IGindex specialized lambda list is used to @i{specialize} a @i{method} for a particular @i{signature} and to describe how @i{arguments} matching that @i{signature} are received by the @i{method}. The @i{defined names} in Figure 3--15 use @i{specialized lambda lists} in some way; see the dictionary entry for each for information about how. @format @group @noindent @w{ defmethod defgeneric } @noindent @w{ Figure 3--15: Standardized Operators that use Specialized Lambda Lists} @end group @end format A @i{specialized lambda list} can contain the @i{lambda list keywords} shown in Figure 3--16. @format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @w{ @b{&aux} @b{&optional} } @noindent @w{ Figure 3--16: Lambda List Keywords used by Specialized Lambda Lists} @end group @end format A @i{specialized lambda list} is syntactically the same as an @i{ordinary lambda list} except that each @i{required parameter} may optionally be associated with a @i{class} or @i{object} for which that @i{parameter} is @i{specialized}. @w{@i{lambda-list} ::=@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{specializer}@r{]}@r{)}@}*} @w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} @w{ @t{[}@r{&rest} @i{var}@t{]}} @w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* @r{[}@t{&allow-other-keys}@r{]}@t{]}} @w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} @w{ } @node Macro Lambda Lists, Destructuring Lambda Lists, Specialized Lambda Lists, Lambda Lists @subsection Macro Lambda Lists A @i{macro lambda list} @IGindex macro lambda list is used in describing @i{macros} defined by the @i{operators} in Figure 3--17. @format @group @noindent @w{ define-compiler-macro defmacro macrolet } @w{ define-setf-expander } @noindent @w{ Figure 3--17: Operators that use Macro Lambda Lists} @end group @end format With the additional restriction that an @i{environment parameter} may appear only once (at any of the positions indicated), a @i{macro lambda list} has the following syntax: @w{@i{reqvars} ::=@{@i{var} | !@i{pattern}@}*} @w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | @r{(}@r{@{@i{var} | !@i{pattern}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} @w{@i{restvar} ::=@t{[}@{@t{&rest} | @r{&body}@} @i{@{@i{var} | !@i{pattern}@}}@t{]}} @w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @{@i{var} | !@i{pattern}@}@r{)}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} @w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@r{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} @w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} @w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{envvar} !@i{reqvars} !@i{envvar} !@i{optvars} !@i{envvar}} @w{ !@i{restvar} !@i{envvar} !@i{keyvars} !@i{envvar} !@i{auxvars} !@i{envvar}@r{)} |} @w{ @r{(}!@i{wholevar} !@i{envvar} !@i{reqvars} !@i{envvar} !@i{optvars} !@i{envvar} @t{.} @i{var}@r{)}} @w{@i{pattern} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} A @i{macro lambda list} can contain the @i{lambda list keywords} shown in Figure 3--18. @format @group @noindent @w{ @b{&allow-other-keys} @b{&environment} @b{&rest} } @w{ @b{&aux} @b{&key} @b{&whole} } @w{ @b{&body} @b{&optional} } @noindent @w{ Figure 3--18: Lambda List Keywords used by Macro Lambda Lists} @end group @end format @i{Optional parameters} (introduced by @b{&optional}) and @i{keyword parameters} (introduced by @b{&key}) can be supplied in a @i{macro lambda list}, just as in an @i{ordinary lambda list}. Both may contain default initialization forms and @i{supplied-p parameters}. @b{&body} @IRindex &body is identical in function to @b{&rest}, but it can be used to inform certain output-formatting and editing functions that the remainder of the @i{form} is treated as a body, and should be indented accordingly. Only one of @b{&body} or @b{&rest} can be used at any particular level; see @ref{Destructuring by Lambda Lists}. @b{&body} can appear at any level of a @i{macro lambda list}; for details, see @ref{Destructuring by Lambda Lists}. @b{&whole} @IRindex &whole is followed by a single variable that is bound to the entire macro-call form; this is the value that the @i{macro function} receives as its first argument. If @b{&whole} and a following variable appear, they must appear first in @i{lambda-list}, before any other parameter or @i{lambda list keyword}. @b{&whole} can appear at any level of a @i{macro lambda list}. At inner levels, the @b{&whole} variable is bound to the corresponding part of the argument, as with @b{&rest}, but unlike @b{&rest}, other arguments are also allowed. The use of @b{&whole} does not affect the pattern of arguments specified. @b{&environment} @IRindex &environment is followed by a single variable that is bound to an @i{environment} representing the @i{lexical environment} in which the macro call is to be interpreted. This @i{environment} should be used with @b{macro-function}, @b{get-setf-expansion}, @b{compiler-macro-function}, and @b{macroexpand} (for example) in computing the expansion of the macro, to ensure that any @i{lexical bindings} or definitions established in the @i{compilation environment} are taken into account. @b{&environment} can only appear at the top level of a @i{macro lambda list}, and can only appear once, but can appear anywhere in that list; the @b{&environment} @i{parameter} is @i{bound} along with @b{&whole} before any other @i{variables} in the @i{lambda list}, regardless of where @b{&environment} appears in the @i{lambda list}. The @i{object} that is bound to the @i{environment parameter} has @i{dynamic extent}. Destructuring allows a @i{macro lambda list} to express the structure of a macro call syntax. If no @i{lambda list keywords} appear, then the @i{macro lambda list} is a @i{tree} containing parameter names at the leaves. The pattern and the @i{macro form} must have compatible @i{tree structure}; that is, their @i{tree structure} must be equivalent, or it must differ only in that some @i{leaves} of the pattern match @i{non-atomic} @i{objects} of the @i{macro form}. For information about error detection in this @i{situation}, see @ref{Destructuring Mismatch}. A destructuring @i{lambda list} (whether at top level or embedded) can be dotted, ending in a parameter name. This situation is treated exactly as if the parameter name that ends the @i{list} had appeared preceded by @b{&rest}. It is permissible for a @i{macro} @i{form} (or a @i{subexpression} of a @i{macro} @i{form}) to be a @i{dotted list} only when @t{(... &rest var)} or @t{(... . var)} is used to match it. It is the responsibility of the @i{macro} to recognize and deal with such situations. [Editorial Note by KMP: Apparently the dotted-macro-forms cleanup doesn't allow for the macro to `manually' notice dotted forms and fix them as well. It shouldn't be required that this be done only by &REST or a dotted pattern; it should only matter that ultimately the non-macro result of a full-macro expansion not contain dots. Anyway, I plan to address this editorially unless someone raises an objection.] @menu * Destructuring by Lambda Lists:: * Data-directed Destructuring by Lambda Lists:: * Examples of Data-directed Destructuring by Lambda Lists:: * Lambda-list-directed Destructuring by Lambda Lists:: @end menu @node Destructuring by Lambda Lists, Data-directed Destructuring by Lambda Lists, Macro Lambda Lists, Macro Lambda Lists @subsubsection Destructuring by Lambda Lists Anywhere in a @i{macro lambda list} where a parameter name can appear, and where @i{ordinary lambda list} syntax (as described in @ref{Ordinary Lambda Lists}) does not otherwise allow a @i{list}, a @i{destructuring lambda list} can appear in place of the parameter name. When this is done, then the argument that would match the parameter is treated as a (possibly dotted) @i{list}, to be used as an argument list for satisfying the parameters in the embedded @i{lambda list}. This is known as destructuring. Destructuring is the process of decomposing a compound @i{object} into its component parts, using an abbreviated, declarative syntax, rather than writing it out by hand using the primitive component-accessing functions. Each component part is bound to a variable. A destructuring operation requires an @i{object} to be decomposed, a pattern that specifies what components are to be extracted, and the names of the variables whose values are to be the components. @node Data-directed Destructuring by Lambda Lists, Examples of Data-directed Destructuring by Lambda Lists, Destructuring by Lambda Lists, Macro Lambda Lists @subsubsection Data-directed Destructuring by Lambda Lists In data-directed destructuring, the pattern is a sample @i{object} of the @i{type} to be decomposed. Wherever a component is to be extracted, a @i{symbol} appears in the pattern; this @i{symbol} is the name of the variable whose value will be that component. @node Examples of Data-directed Destructuring by Lambda Lists, Lambda-list-directed Destructuring by Lambda Lists, Data-directed Destructuring by Lambda Lists, Macro Lambda Lists @subsubsection Examples of Data-directed Destructuring by Lambda Lists An example pattern is @t{(a b c)} which destructures a list of three elements. The variable @t{a} is assigned to the first element, @t{b} to the second, etc. A more complex example is @t{((first . rest) . more)} The important features of data-directed destructuring are its syntactic simplicity and the ability to extend it to lambda-list-directed destructuring. @node Lambda-list-directed Destructuring by Lambda Lists, , Examples of Data-directed Destructuring by Lambda Lists, Macro Lambda Lists @subsubsection Lambda-list-directed Destructuring by Lambda Lists An extension of data-directed destructuring of @i{trees} is lambda-list-directed destructuring. This derives from the analogy between the three-element destructuring pattern @t{(first second third)} and the three-argument @i{lambda list} @t{(first second third)} Lambda-list-directed destructuring is identical to data-directed destructuring if no @i{lambda list keywords} appear in the pattern. Any list in the pattern (whether a sub-list or the whole pattern itself) that contains a @i{lambda list keyword} is interpreted specially. Elements of the list to the left of the first @i{lambda list keyword} are treated as destructuring patterns, as usual, but the remaining elements of the list are treated like a function's @i{lambda list} except that where a variable would normally be required, an arbitrary destructuring pattern is allowed. Note that in case of ambiguity, @i{lambda list} syntax is preferred over destructuring syntax. Thus, after @b{&optional} a list of elements is a list of a destructuring pattern and a default value form. The detailed behavior of each @i{lambda list keyword} in a lambda-list-directed destructuring pattern is as follows: @table @asis @item @b{&optional} Each following element is a variable or a list of a destructuring pattern, a default value form, and a supplied-p variable. The default value and the supplied-p variable can be omitted. If the list being destructured ends early, so that it does not have an element to match against this destructuring (sub)-pattern, the default form is evaluated and destructured instead. The supplied-p variable receives the value @b{nil} if the default form is used, @b{t} otherwise. @item @b{&rest}, @b{&body} The next element is a destructuring pattern that matches the rest of the list. @b{&body} is identical to @b{&rest} but declares that what is being matched is a list of forms that constitutes the body of @i{form}. This next element must be the last unless a @i{lambda list keyword} follows it. @item @b{&aux} The remaining elements are not destructuring patterns at all, but are auxiliary variable bindings. @item @b{&whole} The next element is a destructuring pattern that matches the entire form in a macro, or the entire @i{subexpression} at inner levels. @item @b{&key} Each following element is one of @table @asis @item @t{} a @i{variable}, @item or a list of a variable, an optional initialization form, and an optional supplied-p variable. @item or a list of a list of a keyword and a destructuring pattern, an optional initialization form, and an optional supplied-p variable. @end table The rest of the list being destructured is taken to be alternating keywords and values and is taken apart appropriately. @item @b{&allow-other-keys} Stands by itself. @end table @node Destructuring Lambda Lists, Boa Lambda Lists, Macro Lambda Lists, Lambda Lists @subsection Destructuring Lambda Lists A @i{destructuring lambda list} @IGindex destructuring lambda list is used by @b{destructuring-bind}. @i{Destructuring lambda lists} are closely related to @i{macro lambda lists}; see @ref{Macro Lambda Lists}. A @i{destructuring lambda list} can contain all of the @i{lambda list keywords} listed for @i{macro lambda lists} except for @b{&environment}, and supports destructuring in the same way. Inner @i{lambda lists} nested within a @i{macro lambda list} have the syntax of @i{destructuring lambda lists}. A @i{destructuring lambda list} has the following syntax: @w{@i{reqvars} ::=@{@i{var} | !@i{lambda-list}@}*} @w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | @r{(}@{@i{var} | !@i{lambda-list}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} @w{@i{restvar} ::=@t{[}@{@t{&rest}} | @t{&body}@} @i{@{@i{var} | !@i{lambda-list}@}@t{]}} @w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @{@i{var} | !@i{lambda-list}@}@r{)}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} @w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} @w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} @w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} @node Boa Lambda Lists, Defsetf Lambda Lists, Destructuring Lambda Lists, Lambda Lists @subsection Boa Lambda Lists A @i{boa lambda list} @IGindex boa lambda list is a @i{lambda list} that is syntactically like an @i{ordinary lambda list}, but that is processed in ``@b{b}y @b{o}rder of @b{a}rgument'' style. A @i{boa lambda list} is used only in a @b{defstruct} @i{form}, when explicitly specifying the @i{lambda list} of a constructor @i{function} (sometimes called a ``boa constructor''). The @b{&optional}, @b{&rest}, @b{&aux}, @b{&key}, and @b{&allow-other-keys} @i{lambda list keywords} are recognized in a @i{boa lambda list}. The way these @i{lambda list keywords} differ from their use in an @i{ordinary lambda list} follows. Consider this example, which describes how @b{destruct} processes its @t{:constructor} option. @example (:constructor create-foo (a &optional b (c 'sea) &rest d &aux e (f 'eff))) @end example This defines @t{create-foo} to be a constructor of one or more arguments. The first argument is used to initialize the @t{a} slot. The second argument is used to initialize the @t{b} slot. If there isn't any second argument, then the default value given in the body of the @b{defstruct} (if given) is used instead. The third argument is used to initialize the @t{c} slot. If there isn't any third argument, then the symbol @t{sea} is used instead. Any arguments following the third argument are collected into a @i{list} and used to initialize the @t{d} slot. If there are three or fewer arguments, then @b{nil} is placed in the @t{d} slot. The @t{e} slot is not initialized; its initial value is @i{implementation-defined}. Finally, the @t{f} slot is initialized to contain the symbol @t{eff}. @b{&key} and @b{&allow-other-keys} arguments default in a manner similar to that of @b{&optional} arguments: if no default is supplied in the @i{lambda list} then the default value given in the body of the @b{defstruct} (if given) is used instead. For example: @example (defstruct (foo (:constructor CREATE-FOO (a &optional b (c 'sea) &key (d 2) &aux e (f 'eff)))) (a 1) (b 2) (c 3) (d 4) (e 5) (f 6)) (create-foo 10) @result{} #S(FOO A 10 B 2 C SEA D 2 E @i{implemention-dependent} F EFF) (create-foo 10 'bee 'see :d 'dee) @result{} #S(FOO A 10 B BEE C SEE D DEE E @i{implemention-dependent} F EFF) @end example If keyword arguments of the form @t{((@i{key} @i{var}) @r{[}@i{default} @r{[}@i{svar}@r{]}@r{]})} are specified, the @i{slot} @i{name} is matched with @i{var} (not @i{key}). The actions taken in the @t{b} and @t{e} cases were carefully chosen to allow the user to specify all possible behaviors. The @b{&aux} variables can be used to completely override the default initializations given in the body. If no default value is supplied for an @i{aux variable} variable, the consequences are undefined if an attempt is later made to read the corresponding @i{slot}'s value before a value is explicitly assigned. If such a @i{slot} has a @t{:type} option specified, this suppressed initialization does not imply a type mismatch situation; the declared type is only required to apply when the @i{slot} is finally assigned. With this definition, the following can be written: @example (create-foo 1 2) @end example instead of @example (make-foo :a 1 :b 2) @end example and @t{create-foo} provides defaulting different from that of @t{make-foo}. Additional arguments that do not correspond to slot names but are merely present to supply values used in subsequent initialization computations are allowed. For example, in the definition @example (defstruct (frob (:constructor create-frob (a &key (b 3 have-b) (c-token 'c) (c (list c-token (if have-b 7 2)))))) a b c) @end example the @t{c-token} argument is used merely to supply a value used in the initialization of the @t{c} slot. The @i{supplied-p parameters} associated with @i{optional parameters} and @i{keyword parameters} might also be used this way. @node Defsetf Lambda Lists, Deftype Lambda Lists, Boa Lambda Lists, Lambda Lists @subsection Defsetf Lambda Lists A @i{defsetf lambda list} @IGindex defsetf lambda list is used by @b{defsetf}. A @i{defsetf lambda list} has the following syntax: @w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} @w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} @w{ @t{[}@r{&rest} @i{var}@t{]}} @w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword-name} @i{var}@r{)}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} @w{ @t{[}@r{&environment} @i{var}@t{]}} A @i{defsetf lambda list} can contain the @i{lambda list keywords} shown in Figure 3--19. @format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @w{ @b{&environment} @b{&optional} } @noindent @w{ Figure 3--19: Lambda List Keywords used by Defsetf Lambda Lists} @end group @end format A @i{defsetf lambda list} differs from an @i{ordinary lambda list} only in that it does not permit the use of @b{&aux}, and that it permits use of @b{&environment}, which introduces an @i{environment parameter}. @node Deftype Lambda Lists, Define-modify-macro Lambda Lists, Defsetf Lambda Lists, Lambda Lists @subsection Deftype Lambda Lists A @i{deftype lambda list} @IGindex deftype lambda list is used by @b{deftype}. A @i{deftype lambda list} has the same syntax as a @i{macro lambda list}, and can therefore contain the @i{lambda list keywords} as a @i{macro lambda list}. A @i{deftype lambda list} differs from a @i{macro lambda list} only in that if no @i{init-form} is supplied for an @i{optional parameter} or @i{keyword parameter} in the @i{lambda-list}, the default @i{value} for that @i{parameter} is the @i{symbol} @b{*} (rather than @b{nil}). @node Define-modify-macro Lambda Lists, Define-method-combination Arguments Lambda Lists, Deftype Lambda Lists, Lambda Lists @subsection Define-modify-macro Lambda Lists A @i{define-modify-macro lambda list} @IGindex define-modify-macro lambda list is used by @b{define-modify-macro}. A @i{define-modify-macro lambda list} can contain the @i{lambda list keywords} shown in Figure 3--20. @format @group @noindent @w{ @b{&optional} @b{&rest} } @noindent @w{ Figure 3--20: Lambda List Keywords used by Define-modify-macro Lambda Lists} @end group @end format @i{Define-modify-macro lambda lists} are similar to @i{ordinary lambda lists}, but do not support keyword arguments. @b{define-modify-macro} has no need match keyword arguments, and a @i{rest parameter} is sufficient. @i{Aux variables} are also not supported, since @b{define-modify-macro} has no body @i{forms} which could refer to such @i{bindings}. See the @i{macro} @b{define-modify-macro}. @node Define-method-combination Arguments Lambda Lists, Syntactic Interaction of Documentation Strings and Declarations, Define-modify-macro Lambda Lists, Lambda Lists @subsection Define-method-combination Arguments Lambda Lists A @i{define-method-combination arguments lambda list} @IGindex define-method-combination arguments lambda list is used by the @t{:arguments} option to @b{define-method-combination}. A @i{define-method-combination arguments lambda list} can contain the @i{lambda list keywords} shown in Figure 3--21. @format @group @noindent @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } @w{ @b{&aux} @b{&optional} @b{&whole} } @noindent @w{ Figure 3--21: Lambda List Keywords used by Define-method-combination arguments Lambda Lists} @end group @end format @i{Define-method-combination arguments lambda lists} are similar to @i{ordinary lambda lists}, but also permit the use of @b{&whole}. @node Syntactic Interaction of Documentation Strings and Declarations, , Define-method-combination Arguments Lambda Lists, Lambda Lists @subsection Syntactic Interaction of Documentation Strings and Declarations In a number of situations, a @i{documentation string} can appear amidst a series of @b{declare} @i{expressions} prior to a series of @i{forms}. In that case, if a @i{string} S appears where a @i{documentation string} is permissible and is not followed by either a @b{declare} @i{expression} or a @i{form} then S is taken to be a @i{form}; otherwise, S is taken as a @i{documentation string}. The consequences are unspecified if more than one such @i{documentation string} is present. @c end of including concept-bvl @node Error Checking in Function Calls, Traversal Rules and Side Effects, Lambda Lists, Evaluation and Compilation @section Error Checking in Function Calls @c including concept-args @menu * Argument Mismatch Detection:: @end menu @node Argument Mismatch Detection, , Error Checking in Function Calls, Error Checking in Function Calls @subsection Argument Mismatch Detection @menu * Safe and Unsafe Calls:: * Error Detection Time in Safe Calls:: * Too Few Arguments:: * Too Many Arguments:: * Unrecognized Keyword Arguments:: * Invalid Keyword Arguments:: * Odd Number of Keyword Arguments:: * Destructuring Mismatch:: * Errors When Calling a Next Method:: @end menu @node Safe and Unsafe Calls, Error Detection Time in Safe Calls, Argument Mismatch Detection, Argument Mismatch Detection @subsubsection Safe and Unsafe Calls A @i{call} is a @i{safe call} @IGindex safe call if each of the following is either @i{safe} @i{code} or @i{system code} (other than @i{system code} that results from @i{macro expansion} of @i{programmer code}): @table @asis @item @t{*} the @i{call}. @item @t{*} the definition of the @i{function} being @i{called}. @item @t{*} the point of @i{functional evaluation} @end table The following special cases require some elaboration: @table @asis @item @t{*} If the @i{function} being called is a @i{generic function}, it is considered @i{safe} if all of the following are @i{safe code} or @i{system code}: @table @asis @item -- its definition (if it was defined explicitly). @item -- the @i{method} definitions for all @i{applicable} @i{methods}. @item -- the definition of its @i{method combination}. @end table @item @t{*} For the form @t{(coerce @i{x} 'function)}, where @i{x} is a @i{lambda expression}, the value of the @i{optimize quality} @b{safety} in the global environment at the time the @b{coerce} is @i{executed} applies to the resulting @i{function}. @item @t{*} For a call to the @i{function} @b{ensure-generic-function}, the value of the @i{optimize quality} @b{safety} in the @i{environment} @i{object} passed as the @t{:environment} @i{argument} applies to the resulting @i{generic function}. @item @t{*} For a call to @b{compile} with a @i{lambda expression} as the @i{argument}, the value of the @i{optimize quality} @b{safety} in the @i{global environment} at the time @b{compile} is @i{called} applies to the resulting @i{compiled function}. @item @t{*} For a call to @b{compile} with only one argument, if the original definition of the @i{function} was @i{safe}, then the resulting @i{compiled function} must also be @i{safe}. @item @t{*} A @i{call} to a @i{method} by @b{call-next-method} must be considered @i{safe} if each of the following is @i{safe code} or @i{system code}: @table @asis @item -- the definition of the @i{generic function} (if it was defined explicitly). @item -- the @i{method} definitions for all @i{applicable} @i{methods}. @item -- the definition of the @i{method combination}. @item -- the point of entry into the body of the @i{method defining form}, where the @i{binding} of @b{call-next-method} is established. @item -- the point of @i{functional evaluation} of the name @b{call-next-method}. @end table @end table An @i{unsafe call} @IGindex unsafe call is a @i{call} that is not a @i{safe call}. The informal intent is that the @i{programmer} can rely on a @i{call} to be @i{safe}, even when @i{system code} is involved, if all reasonable steps have been taken to ensure that the @i{call} is @i{safe}. For example, if a @i{programmer} calls @b{mapcar} from @i{safe} @i{code} and supplies a @i{function} that was @i{compiled} as @i{safe}, the @i{implementation} is required to ensure that @b{mapcar} makes a @i{safe call} as well. @node Error Detection Time in Safe Calls, Too Few Arguments, Safe and Unsafe Calls, Argument Mismatch Detection @subsubsection Error Detection Time in Safe Calls If an error is signaled in a @i{safe call}, the exact point of the @i{signal} is @i{implementation-dependent}. In particular, it might be signaled at compile time or at run time, and if signaled at run time, it might be prior to, during, or after @i{executing} the @i{call}. However, it is always prior to the execution of the body of the @i{function} being @i{called}. @node Too Few Arguments, Too Many Arguments, Error Detection Time in Safe Calls, Argument Mismatch Detection @subsubsection Too Few Arguments It is not permitted to supply too few @i{arguments} to a @i{function}. Too few arguments means fewer @i{arguments} than the number of @i{required parameters} for the @i{function}. If this @i{situation} occurs in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Too Many Arguments, Unrecognized Keyword Arguments, Too Few Arguments, Argument Mismatch Detection @subsubsection Too Many Arguments It is not permitted to supply too many @i{arguments} to a @i{function}. Too many arguments means more @i{arguments} than the number of @i{required parameters} plus the number of @i{optional parameters}; however, if the @i{function} uses @b{&rest} or @b{&key}, it is not possible for it to receive too many arguments. If this @i{situation} occurs in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Unrecognized Keyword Arguments, Invalid Keyword Arguments, Too Many Arguments, Argument Mismatch Detection @subsubsection Unrecognized Keyword Arguments It is not permitted to supply a keyword argument to a @i{function} using a name that is not recognized by that @i{function} unless keyword argument checking is suppressed as described in @ref{Suppressing Keyword Argument Checking}. If this @i{situation} occurs in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Invalid Keyword Arguments, Odd Number of Keyword Arguments, Unrecognized Keyword Arguments, Argument Mismatch Detection @subsubsection Invalid Keyword Arguments It is not permitted to supply a keyword argument to a @i{function} using a name that is not a @i{symbol}. If this @i{situation} occurs in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled unless keyword argument checking is suppressed as described in @ref{Suppressing Keyword Argument Checking}; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Odd Number of Keyword Arguments, Destructuring Mismatch, Invalid Keyword Arguments, Argument Mismatch Detection @subsubsection Odd Number of Keyword Arguments An odd number of @i{arguments} must not be supplied for the @i{keyword parameters}. If this @i{situation} occurs in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled unless keyword argument checking is suppressed as described in @ref{Suppressing Keyword Argument Checking}; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Destructuring Mismatch, Errors When Calling a Next Method, Odd Number of Keyword Arguments, Argument Mismatch Detection @subsubsection Destructuring Mismatch When matching a @i{destructuring lambda list} against a @i{form}, the pattern and the @i{form} must have compatible @i{tree structure}, as described in @ref{Macro Lambda Lists}. Otherwise, in a @i{safe call}, an error of @i{type} @b{program-error} must be signaled; and in an @i{unsafe call} the @i{situation} has undefined consequences. @node Errors When Calling a Next Method, , Destructuring Mismatch, Argument Mismatch Detection @subsubsection Errors When Calling a Next Method If @b{call-next-method} is called with @i{arguments}, the ordered set of @i{applicable} @i{methods} for the changed set of @i{arguments} for @b{call-next-method} must be the same as the ordered set of @i{applicable} @i{methods} for the original @i{arguments} to the @i{generic function}, or else an error should be signaled. The comparison between the set of methods applicable to the new arguments and the set applicable to the original arguments is insensitive to order differences among methods with the same specializers. If @b{call-next-method} is called with @i{arguments} that specify a different ordered set of @i{applicable} methods and there is no @i{next method} available, the test for different methods and the associated error signaling (when present) takes precedence over calling @b{no-next-method}. @c end of including concept-args @node Traversal Rules and Side Effects, Destructive Operations, Error Checking in Function Calls, Evaluation and Compilation @section Traversal Rules and Side Effects @c including concept-traversal The consequences are undefined when @i{code} executed during an @i{object-traversing} operation destructively modifies the @i{object} in a way that might affect the ongoing traversal operation. In particular, the following rules apply. @table @asis @item @b{List traversal} For @i{list} traversal operations, the @i{cdr} chain of the @i{list} is not allowed to be destructively modified. @item @b{Array traversal} For @i{array} traversal operations, the @i{array} is not allowed to be adjusted and its @i{fill pointer}, if any, is not allowed to be changed. @item @b{Hash-table traversal} For @i{hash table} traversal operations, new elements may not be added or deleted except that the element corresponding to the current hash key may be changed or removed. @item @b{Package traversal} For @i{package} traversal operations (@i{e.g.}, @b{do-symbols}), new @i{symbols} may not be @i{interned} in or @i{uninterned} from the @i{package} being traversed or any @i{package} that it uses except that the current @i{symbol} may be @i{uninterned} from the @i{package} being traversed. @end table @c end of including concept-traversal @node Destructive Operations, Evaluation and Compilation Dictionary, Traversal Rules and Side Effects, Evaluation and Compilation @section Destructive Operations @c including concept-destruction @menu * Modification of Literal Objects:: * Transfer of Control during a Destructive Operation:: @end menu @node Modification of Literal Objects, Transfer of Control during a Destructive Operation, Destructive Operations, Destructive Operations @subsection Modification of Literal Objects The consequences are undefined if @i{literal} @i{objects} are destructively modified. For this purpose, the following operations are considered @i{destructive}: @table @asis @item @b{random-state} Using it as an @i{argument} to the @i{function} @b{random}. @item @b{cons} Changing the @i{car}_1 or @i{cdr}_1 of the @i{cons}, or performing a @i{destructive} operation on an @i{object} which is either the @i{car}_2 or the @i{cdr}_2 of the @i{cons}. @item @b{array} Storing a new value into some element of the @i{array}, or performing a @i{destructive} operation on an @i{object} that is already such an @i{element}. Changing the @i{fill pointer}, @i{dimensions}, or displacement of the @i{array} (regardless of whether the @i{array} is @i{actually adjustable}). Performing a @i{destructive} operation on another @i{array} that is displaced to the @i{array} or that otherwise shares its contents with the @i{array}. @item @b{hash-table} Performing a @i{destructive} operation on any @i{key}. Storing a new @i{value}_4 for any @i{key}, or performing a @i{destructive} operation on any @i{object} that is such a @i{value}. Adding or removing entries from the @i{hash table}. @item @b{structure-object} Storing a new value into any slot, or performing a @i{destructive} operation on an @i{object} that is the value of some slot. @item @b{standard-object} Storing a new value into any slot, or performing a @i{destructive} operation on an @i{object} that is the value of some slot. Changing the class of the @i{object} (@i{e.g.}, using the @i{function} @b{change-class}). @item @b{readtable} Altering the @i{readtable case}. Altering the syntax type of any character in this readtable. Altering the @i{reader macro function} associated with any @i{character} in the @i{readtable}, or altering the @i{reader macro functions} associated with @i{characters} defined as @i{dispatching macro characters} in the @i{readtable}. @item @b{stream} Performing I/O operations on the @i{stream}, or @i{closing} the @i{stream}. @item All other standardized types [This category includes, for example, @b{character}, @b{condition}, @b{function}, @b{method-combination}, @b{method}, @b{number}, @b{package}, @b{pathname}, @b{restart}, and @b{symbol}.] There are no @i{standardized} @i{destructive} operations defined on @i{objects} of these @i{types}. @end table @node Transfer of Control during a Destructive Operation, , Modification of Literal Objects, Destructive Operations @subsection Transfer of Control during a Destructive Operation Should a transfer of control out of a @i{destructive} operation occur (@i{e.g.}, due to an error) the state of the @i{object} being modified is @i{implementation-dependent}. @menu * Examples of Transfer of Control during a Destructive Operation:: @end menu @node Examples of Transfer of Control during a Destructive Operation, , Transfer of Control during a Destructive Operation, Transfer of Control during a Destructive Operation @subsubsection Examples of Transfer of Control during a Destructive Operation The following examples illustrate some of the many ways in which the @i{implementation-dependent} nature of the modification can manifest itself. @example (let ((a (list 2 1 4 3 7 6 'five))) (ignore-errors (sort a #'<)) a) @result{} (1 2 3 4 6 7 FIVE) @i{OR}@result{} (2 1 4 3 7 6 FIVE) @i{OR}@result{} (2) (prog foo ((a (list 1 2 3 4 5 6 7 8 9 10))) (sort a #'(lambda (x y) (if (zerop (random 5)) (return-from foo a) (> x y))))) @result{} (1 2 3 4 5 6 7 8 9 10) @i{OR}@result{} (3 4 5 6 2 7 8 9 10 1) @i{OR}@result{} (1 2 4 3) @end example @c end of including concept-destruction @node Evaluation and Compilation Dictionary, , Destructive Operations, Evaluation and Compilation @section Evaluation and Compilation Dictionary @c including dict-eval-compile @menu * lambda (Symbol):: * lambda:: * compile:: * eval:: * eval-when:: * load-time-value:: * quote:: * compiler-macro-function:: * define-compiler-macro:: * defmacro:: * macro-function:: * macroexpand:: * define-symbol-macro:: * symbol-macrolet:: * *macroexpand-hook*:: * proclaim:: * declaim:: * declare:: * ignore:: * dynamic-extent:: * type:: * inline:: * ftype:: * declaration:: * optimize:: * special:: * locally:: * the:: * special-operator-p:: * constantp:: @end menu @node lambda (Symbol), lambda, Evaluation and Compilation Dictionary, Evaluation and Compilation Dictionary @subsection lambda [Symbol] @subsubheading Syntax:: @code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} @subsubheading Arguments:: @i{lambda-list}---an @i{ordinary lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @subsubheading Description:: A @i{lambda expression} is a @i{list} that can be used in place of a @i{function name} in certain contexts to denote a @i{function} by directly describing its behavior rather than indirectly by referring to the name of an @i{established} @i{function}. @i{Documentation} is attached to the denoted @i{function} (if any is actually created) as a @i{documentation string}. @subsubheading See Also:: @b{function}, @ref{documentation} , @ref{Lambda Expressions}, @ref{Lambda Forms}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: The @i{lambda form} @example ((lambda @i{lambda-list} . @i{body}) . @i{arguments}) @end example is semantically equivalent to the @i{function form} @example (funcall #'(lambda @i{lambda-list} . @i{body}) . @i{arguments}) @end example @node lambda, compile, lambda (Symbol), Evaluation and Compilation Dictionary @subsection lambda [Macro] @code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} @result{} @i{@i{function}} @subsubheading Arguments and Values:: @i{lambda-list}---an @i{ordinary lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @i{function}---a @i{function}. @subsubheading Description:: Provides a shorthand notation for a @b{function} @i{special form} involving a @i{lambda expression} such that: @example (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) @equiv{} (function (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*)) @equiv{} #'(lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) @end example @subsubheading Examples:: @example (funcall (lambda (x) (+ x 3)) 4) @result{} 7 @end example @subsubheading See Also:: @b{lambda} (symbol) @subsubheading Notes:: This macro could be implemented by: @example (defmacro lambda (&whole form &rest bvl-decls-and-body) (declare (ignore bvl-decls-and-body)) `#',form) @end example @node compile, eval, lambda, Evaluation and Compilation Dictionary @subsection compile [Function] @code{compile} @i{name @r{&optional} definition} @result{} @i{function, warnings-p, failure-p} @subsubheading Arguments and Values:: @i{name}---a @i{function name}, or @b{nil}. @i{definition}---a @i{lambda expression} or a @i{function}. The default is the function definition of @i{name} if it names a @i{function}, or the @i{macro function} of @i{name} if it names a @i{macro}. The consequences are undefined if no @i{definition} is supplied when the @i{name} is @b{nil}. @i{function}---the @i{function-name}, or a @i{compiled function}. @i{warnings-p}---a @i{generalized boolean}. @i{failure-p}---a @i{generalized boolean}. @subsubheading Description:: Compiles an @i{interpreted function}. @b{compile} produces a @i{compiled function} from @i{definition}. If the @i{definition} is a @i{lambda expression}, it is coerced to a @i{function}. If the @i{definition} is already a @i{compiled function}, @b{compile} either produces that function itself (@i{i.e.}, is an identity operation) or an equivalent function. [Editorial Note by KMP: There are a number of ambiguities here that still need resolution.] If the @i{name} is @b{nil}, the resulting @i{compiled function} is returned directly as the @i{primary value}. If a @i{non-nil} @i{name} is given, then the resulting @i{compiled function} replaces the existing @i{function} definition of @i{name} and the @i{name} is returned as the @i{primary value}; if @i{name} is a @i{symbol} that names a @i{macro}, its @i{macro function} is updated and the @i{name} is returned as the @i{primary value}. @i{Literal objects} appearing in code processed by the @b{compile} function are neither copied nor @i{coalesced}. The code resulting from the execution of @b{compile} references @i{objects} that are @b{eql} to the corresponding @i{objects} in the source code. @b{compile} is permitted, but not required, to @i{establish} a @i{handler} for @i{conditions} of @i{type} @b{error}. For example, the @i{handler} might issue a warning and restart compilation from some @i{implementation-dependent} point in order to let the compilation proceed without manual intervention. The @i{secondary value}, @i{warnings-p}, is @i{false} if no @i{conditions} of @i{type} @b{error} or @b{warning} were detected by the compiler, and @i{true} otherwise. The @i{tertiary value}, @i{failure-p}, is @i{false} if no @i{conditions} of @i{type} @b{error} or @b{warning} (other than @b{style-warning}) were detected by the compiler, and @i{true} otherwise. @subsubheading Examples:: @example (defun foo () "bar") @result{} FOO (compiled-function-p #'foo) @result{} @i{implementation-dependent} (compile 'foo) @result{} FOO (compiled-function-p #'foo) @result{} @i{true} (setf (symbol-function 'foo) (compile nil '(lambda () "replaced"))) @result{} # (foo) @result{} "replaced" @end example @subsubheading Affected By:: @b{*error-output*}, @b{*macroexpand-hook*}. The presence of macro definitions and proclamations. @subsubheading Exceptional Situations:: The consequences are undefined if the @i{lexical environment} surrounding the @i{function} to be compiled contains any @i{bindings} other than those for @i{macros}, @i{symbol macros}, or @i{declarations}. For information about errors detected during the compilation process, see @ref{Exceptional Situations in the Compiler}. @subsubheading See Also:: @ref{compile-file} @node eval, eval-when, compile, Evaluation and Compilation Dictionary @subsection eval [Function] @code{eval} @i{form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{form}---a @i{form}. @i{results}---the @i{values} @i{yielded} by the @i{evaluation} of @i{form}. @subsubheading Description:: Evaluates @i{form} in the current @i{dynamic environment} and the @i{null lexical environment}. @b{eval} is a user interface to the evaluator. The evaluator expands macro calls as if through the use of @b{macroexpand-1}. Constants appearing in code processed by @b{eval} are not copied nor coalesced. The code resulting from the execution of @b{eval} references @i{objects} that are @b{eql} to the corresponding @i{objects} in the source code. @subsubheading Examples:: @example (setq form '(1+ a) a 999) @result{} 999 (eval form) @result{} 1000 (eval 'form) @result{} (1+ A) (let ((a '(this would break if eval used local value))) (eval form)) @result{} 1000 @end example @subsubheading See Also:: @b{macroexpand-1}, @ref{The Evaluation Model} @subsubheading Notes:: To obtain the current dynamic value of a @i{symbol}, use of @b{symbol-value} is equivalent (and usually preferable) to use of @b{eval}. Note that an @b{eval} @i{form} involves two levels of @i{evaluation} for its @i{argument}. First, @i{form} is @i{evaluated} by the normal argument evaluation mechanism as would occur with any @i{call}. The @i{object} that results from this normal @i{argument} @i{evaluation} becomes the @i{value} of the @i{form} @i{parameter}, and is then @i{evaluated} as part of the @b{eval} @i{form}. For example: @example (eval (list 'cdr (car '((quote (a . b)) c)))) @result{} b @end example The @i{argument} @i{form} @t{(list 'cdr (car '((quote (a . b)) c)))} is evaluated in the usual way to produce the @i{argument} @t{(cdr (quote (a . b)))}; @b{eval} then evaluates its @i{argument}, @t{(cdr (quote (a . b)))}, to produce @t{b}. Since a single @i{evaluation} already occurs for any @i{argument} @i{form} in any @i{function form}, @b{eval} is sometimes said to perform ``an extra level of evaluation.'' @node eval-when, load-time-value, eval, Evaluation and Compilation Dictionary @subsection eval-when [Special Operator] @code{eval-when} @i{@r{(}@{@i{situation}@}*@r{)} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{situation}---One of the @i{symbols} @t{:compile-toplevel} @c @IKindex{compile-toplevel} , @t{:load-toplevel} @c @IKindex{load-toplevel} , @t{:execute} @c @IKindex{execute} , @b{compile} @IRindex compile , @b{load} @IRindex load , or @b{eval} @IRindex eval . The use of @b{eval}, @b{compile}, and @b{load} is deprecated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms} if they are executed, or @b{nil} if they are not. @subsubheading Description:: The body of an @b{eval-when} form is processed as an @i{implicit progn}, but only in the @i{situations} listed. The use of the @i{situations} @t{:compile-toplevel} (or @t{compile}) and @t{:load-toplevel} (or @t{load}) controls whether and when @i{evaluation} occurs when @b{eval-when} appears as a @i{top level form} in code processed by @b{compile-file}. See @ref{File Compilation}. The use of the @i{situation} @t{:execute} (or @t{eval}) controls whether evaluation occurs for other @b{eval-when} @i{forms}; that is, those that are not @i{top level forms}, or those in code processed by @b{eval} or @b{compile}. If the @t{:execute} situation is specified in such a @i{form}, then the body @i{forms} are processed as an @i{implicit progn}; otherwise, the @b{eval-when} @i{form} returns @b{nil}. @b{eval-when} normally appears as a @i{top level form}, but it is meaningful for it to appear as a @i{non-top-level form}. However, the compile-time side effects described in @ref{Compilation} only take place when @b{eval-when} appears as a @i{top level form}. @subsubheading Examples:: One example of the use of @b{eval-when} is that for the compiler to be able to read a file properly when it uses user-defined @i{reader macros}, it is necessary to write @example (eval-when (:compile-toplevel :load-toplevel :execute) (set-macro-character #\$ #'(lambda (stream char) (declare (ignore char)) (list 'dollar (read stream))))) @result{} T @end example This causes the call to @b{set-macro-character} to be executed in the compiler's execution environment, thereby modifying its reader syntax table. @example ;;; The EVAL-WHEN in this case is not at toplevel, so only the :EXECUTE ;;; keyword is considered. At compile time, this has no effect. ;;; At load time (if the LET is at toplevel), or at execution time ;;; (if the LET is embedded in some other form which does not execute ;;; until later) this sets (SYMBOL-FUNCTION 'FOO1) to a function which ;;; returns 1. (let ((x 1)) (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo1) #'(lambda () x)))) ;;; If this expression occurs at the toplevel of a file to be compiled, ;;; it has BOTH a compile time AND a load-time effect of setting ;;; (SYMBOL-FUNCTION 'FOO2) to a function which returns 2. (eval-when (:execute :load-toplevel :compile-toplevel) (let ((x 2)) (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo2) #'(lambda () x))))) ;;; If this expression occurs at the toplevel of a file to be compiled, ;;; it has BOTH a compile time AND a load-time effect of setting the ;;; function cell of FOO3 to a function which returns 3. (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo3) #'(lambda () 3))) ;;; #4: This always does nothing. It simply returns NIL. (eval-when (:compile-toplevel) (eval-when (:compile-toplevel) (print 'foo4))) ;;; If this form occurs at toplevel of a file to be compiled, FOO5 is ;;; printed at compile time. If this form occurs in a non-top-level ;;; position, nothing is printed at compile time. Regardless of context, ;;; nothing is ever printed at load time or execution time. (eval-when (:compile-toplevel) (eval-when (:execute) (print 'foo5))) ;;; If this form occurs at toplevel of a file to be compiled, FOO6 is ;;; printed at compile time. If this form occurs in a non-top-level ;;; position, nothing is printed at compile time. Regardless of context, ;;; nothing is ever printed at load time or execution time. (eval-when (:execute :load-toplevel) (eval-when (:compile-toplevel) (print 'foo6))) @end example @subsubheading See Also:: @ref{compile-file} , @ref{Compilation} @subsubheading Notes:: The following effects are logical consequences of the definition of @b{eval-when}: @table @asis @item @t{*} Execution of a single @b{eval-when} expression executes the body code at most once. @item @t{*} @i{Macros} intended for use in @i{top level forms} should be written so that side-effects are done by the @i{forms} in the macro expansion. The macro-expander itself should not do the side-effects. For example: Wrong: @example (defmacro foo () (really-foo) `(really-foo)) @end example Right: @example (defmacro foo () `(eval-when (:compile-toplevel :execute :load-toplevel) (really-foo))) @end example Adherence to this convention means that such @i{macros} behave intuitively when appearing as @i{non-top-level forms}. @item @t{*} Placing a variable binding around an @b{eval-when} reliably captures the binding because the compile-time-too mode cannot occur (@i{i.e.}, introducing a variable binding means that the @b{eval-when} is not a @i{top level form}). For example, @example (let ((x 3)) (eval-when (:execute :load-toplevel :compile-toplevel) (print x))) @end example prints @t{3} at execution (@i{i.e.}, load) time, and does not print anything at compile time. This is important so that expansions of @b{defun} and @b{defmacro} can be done in terms of @b{eval-when} and can correctly capture the @i{lexical environment}. @example (defun bar (x) (defun foo () (+ x 3))) @end example might expand into @example (defun bar (x) (progn (eval-when (:compile-toplevel) (compiler::notice-function-definition 'foo '(x))) (eval-when (:execute :load-toplevel) (setf (symbol-function 'foo) #'(lambda () (+ x 3)))))) @end example which would be treated by the above rules the same as @example (defun bar (x) (setf (symbol-function 'foo) #'(lambda () (+ x 3)))) @end example when the definition of @t{bar} is not a @i{top level form}. @end table @node load-time-value, quote, eval-when, Evaluation and Compilation Dictionary @subsection load-time-value [Special Operator] @code{load-time-value} @i{form @r{&optional} read-only-p} @result{} @i{object} @subsubheading Arguments and Values:: @i{form}---a @i{form}; evaluated as described below. @i{read-only-p}---a @i{boolean}; not evaluated. @i{object}---the @i{primary value} resulting from evaluating @i{form}. @subsubheading Description:: @b{load-time-value} provides a mechanism for delaying evaluation of @i{form} until the expression is in the run-time environment; see @ref{Compilation}. @i{Read-only-p} designates whether the result can be considered a @i{constant object}. If @b{t}, the result is a read-only quantity that can, if appropriate to the @i{implementation}, be copied into read-only space and/or @i{coalesced} with @i{similar} @i{constant objects} from other @i{programs}. If @b{nil} (the default), the result must be neither copied nor coalesced; it must be considered to be potentially modifiable data. If a @b{load-time-value} expression is processed by @b{compile-file}, the compiler performs its normal semantic processing (such as macro expansion and translation into machine code) on @i{form}, but arranges for the execution of @i{form} to occur at load time in a @i{null lexical environment}, with the result of this @i{evaluation} then being treated as a @i{literal object} at run time. It is guaranteed that the evaluation of @i{form} will take place only once when the @i{file} is @i{loaded}, but the order of evaluation with respect to the evaluation of @i{top level forms} in the file is @i{implementation-dependent}. @ITindex order of evaluation @ITindex evaluation order If a @b{load-time-value} expression appears within a function compiled with @b{compile}, the @i{form} is evaluated at compile time in a @i{null lexical environment}. The result of this compile-time evaluation is treated as a @i{literal object} in the compiled code. If a @b{load-time-value} expression is processed by @b{eval}, @i{form} is evaluated in a @i{null lexical environment}, and one value is returned. Implementations that implicitly compile (or partially compile) expressions processed by @b{eval} might evaluate @i{form} only once, at the time this compilation is performed. If the @i{same} @i{list} @t{(load-time-value @i{form})} is evaluated or compiled more than once, it is @i{implementation-dependent} whether @i{form} is evaluated only once or is evaluated more than once. This can happen both when an expression being evaluated or compiled shares substructure, and when the @i{same} @i{form} is processed by @b{eval} or @b{compile} multiple times. Since a @b{load-time-value} expression can be referenced in more than one place and can be evaluated multiple times by @b{eval}, it is @i{implementation-dependent} whether each execution returns a fresh @i{object} or returns the same @i{object} as some other execution. Users must use caution when destructively modifying the resulting @i{object}. If two lists @t{(load-time-value @i{form})} that are the @i{same} under @b{equal} but are not @i{identical} are evaluated or compiled, their values always come from distinct evaluations of @i{form}. Their @i{values} may not be coalesced unless @i{read-only-p} is @b{t}. @subsubheading Examples:: @example ;;; The function INCR1 always returns the same value, even in different images. ;;; The function INCR2 always returns the same value in a given image, ;;; but the value it returns might vary from image to image. (defun incr1 (x) (+ x #.(random 17))) (defun incr2 (x) (+ x (load-time-value (random 17)))) ;;; The function FOO1-REF references the nth element of the first of ;;; the *FOO-ARRAYS* that is available at load time. It is permissible for ;;; that array to be modified (e.g., by SET-FOO1-REF); FOO1-REF will see the ;;; updated values. (defvar *foo-arrays* (list (make-array 7) (make-array 8))) (defun foo1-ref (n) (aref (load-time-value (first *my-arrays*) nil) n)) (defun set-foo1-ref (n val) (setf (aref (load-time-value (first *my-arrays*) nil) n) val)) ;;; The function BAR1-REF references the nth element of the first of ;;; the *BAR-ARRAYS* that is available at load time. The programmer has ;;; promised that the array will be treated as read-only, so the system ;;; can copy or coalesce the array. (defvar *bar-arrays* (list (make-array 7) (make-array 8))) (defun bar1-ref (n) (aref (load-time-value (first *my-arrays*) t) n)) ;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced ;;; even though NIL was specified, because the object was already read-only ;;; when it was written as a literal vector rather than created by a constructor. ;;; User programs must treat the vector v as read-only. (defun baz-ref (n) (let ((v (load-time-value #(A B C) nil))) (values (svref v n) v))) ;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced ;;; even though NIL was specified in the outer situation because T was specified ;;; in the inner situation. User programs must treat the vector v as read-only. (defun baz-ref (n) (let ((v (load-time-value (load-time-value (vector 1 2 3) t) nil))) (values (svref v n) v))) @end example @subsubheading See Also:: @ref{compile-file} , @ref{compile} , @ref{eval} , @ref{Minimal Compilation}, @ref{Compilation} @subsubheading Notes:: @b{load-time-value} must appear outside of quoted structure in a ``for @i{evaluation}'' position. In situations which would appear to call for use of @b{load-time-value} within a quoted structure, the @i{backquote} @i{reader macro} is probably called for; see @ref{Backquote}. Specifying @b{nil} for @i{read-only-p} is not a way to force an object to become modifiable if it has already been made read-only. It is only a way to say that, for an object that is modifiable, this operation is not intended to make that object read-only. @node quote, compiler-macro-function, load-time-value, Evaluation and Compilation Dictionary @subsection quote [Special Operator] @code{quote} @i{object} @result{} @i{object} @subsubheading Arguments and Values:: @i{object}---an @i{object}; not evaluated. @subsubheading Description:: The @b{quote} @i{special operator} just returns @i{object}. The consequences are undefined if @i{literal objects} (including @i{quoted objects}) are destructively modified. @subsubheading Examples:: @example (setq a 1) @result{} 1 (quote (setq a 3)) @result{} (SETQ A 3) a @result{} 1 'a @result{} A ''a @result{} (QUOTE A) '''a @result{} (QUOTE (QUOTE A)) (setq a 43) @result{} 43 (list a (cons a 3)) @result{} (43 (43 . 3)) (list (quote a) (quote (cons a 3))) @result{} (A (CONS A 3)) 1 @result{} 1 '1 @result{} 1 "foo" @result{} "foo" '"foo" @result{} "foo" (car '(a b)) @result{} A '(car '(a b)) @result{} (CAR (QUOTE (A B))) #(car '(a b)) @result{} #(CAR (QUOTE (A B))) '#(car '(a b)) @result{} #(CAR (QUOTE (A B))) @end example @subsubheading See Also:: @ref{Evaluation}, @ref{Single-Quote}, @ref{Compiler Terminology} @subsubheading Notes:: The textual notation @t{'@i{object}} is equivalent to @t{(quote @i{object})}; see @ref{Compiler Terminology}. Some @i{objects}, called @i{self-evaluating objects}, do not require quotation by @b{quote}. However, @i{symbols} and @i{lists} are used to represent parts of programs, and so would not be useable as constant data in a program without @b{quote}. Since @b{quote} suppresses the @i{evaluation} of these @i{objects}, they become data rather than program. @node compiler-macro-function, define-compiler-macro, quote, Evaluation and Compilation Dictionary @subsection compiler-macro-function [Accessor] @code{compiler-macro-function} @i{name @r{&optional} environment} @result{} @i{function} (setf (@code{ compiler-macro-function} @i{name @r{&optional} environment}) new-function)@* @subsubheading Arguments and Values:: @i{name}---a @i{function name}. @i{environment}---an @i{environment} @i{object}. @i{function}, @i{new-function}---a @i{compiler macro function}, or @b{nil}. @subsubheading Description:: @i{Accesses} the @i{compiler macro function} named @i{name}, if any, in the @i{environment}. A value of @b{nil} denotes the absence of a @i{compiler macro function} named @i{name}. @subsubheading Exceptional Situations:: The consequences are undefined if @i{environment} is @i{non-nil} in a use of @b{setf} of @b{compiler-macro-function}. @subsubheading See Also:: @ref{define-compiler-macro} , @ref{Compiler Macros} @node define-compiler-macro, defmacro, compiler-macro-function, Evaluation and Compilation Dictionary @subsection define-compiler-macro [Macro] @code{define-compiler-macro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{function name}. @i{lambda-list}---a @i{macro lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @subsubheading Description:: [Editorial Note by KMP: This definition probably needs to be fully expanded to not refer through the definition of defmacro, but should suffice for now.] This is the normal mechanism for defining a @i{compiler macro function}. Its manner of definition is the same as for @b{defmacro}; the only differences are: @table @asis @item @t{*} The @i{name} can be a @i{function name} naming any @i{function} or @i{macro}. @item @t{*} The expander function is installed as a @i{compiler macro function} for the @i{name}, rather than as a @i{macro function}. @item @t{*} The @b{&whole} argument is bound to the form argument that is passed to the @i{compiler macro function}. The remaining lambda-list parameters are specified as if this form contained the function name in the @i{car} and the actual arguments in the @i{cdr}, but if the @i{car} of the actual form is the symbol @b{funcall}, then the destructuring of the arguments is actually performed using its @i{cddr} instead. @item @t{*} @i{Documentation} is attached as a @i{documentation string} to @i{name} (as kind @b{compiler-macro}) and to the @i{compiler macro function}. @item @t{*} Unlike an ordinary @i{macro}, a @i{compiler macro} can decline to provide an expansion merely by returning a form that is the @i{same} as the original (which can be obtained by using @b{&whole}). @end table @subsubheading Examples:: @example (defun square (x) (expt x 2)) @result{} SQUARE (define-compiler-macro square (&whole form arg) (if (atom arg) `(expt ,arg 2) (case (car arg) (square (if (= (length arg) 2) `(expt ,(nth 1 arg) 4) form)) (expt (if (= (length arg) 3) (if (numberp (nth 2 arg)) `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg))) `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg)))) form)) (otherwise `(expt ,arg 2))))) @result{} SQUARE (square (square 3)) @result{} 81 (macroexpand '(square x)) @result{} (SQUARE X), @i{false} (funcall (compiler-macro-function 'square) '(square x) nil) @result{} (EXPT X 2) (funcall (compiler-macro-function 'square) '(square (square x)) nil) @result{} (EXPT X 4) (funcall (compiler-macro-function 'square) '(funcall #'square x) nil) @result{} (EXPT X 2) (defun distance-positional (x1 y1 x2 y2) (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))) @result{} DISTANCE-POSITIONAL (defun distance (&key (x1 0) (y1 0) (x2 x1) (y2 y1)) (distance-positional x1 y1 x2 y2)) @result{} DISTANCE (define-compiler-macro distance (&whole form &rest key-value-pairs &key (x1 0 x1-p) (y1 0 y1-p) (x2 x1 x2-p) (y2 y1 y2-p) &allow-other-keys &environment env) (flet ((key (n) (nth (* n 2) key-value-pairs)) (arg (n) (nth (1+ (* n 2)) key-value-pairs)) (simplep (x) (let ((expanded-x (macroexpand x env))) (or (constantp expanded-x env) (symbolp expanded-x))))) (let ((n (/ (length key-value-pairs) 2))) (multiple-value-bind (x1s y1s x2s y2s others) (loop for (key) on key-value-pairs by #'cddr count (eq key ':x1) into x1s count (eq key ':y1) into y1s count (eq key ':x2) into x2s count (eq key ':y1) into y2s count (not (member key '(:x1 :x2 :y1 :y2))) into others finally (return (values x1s y1s x2s y2s others))) (cond ((and (= n 4) (eq (key 0) :x1) (eq (key 1) :y1) (eq (key 2) :x2) (eq (key 3) :y2)) `(distance-positional ,x1 ,y1 ,x2 ,y2)) ((and (if x1-p (and (= x1s 1) (simplep x1)) t) (if y1-p (and (= y1s 1) (simplep y1)) t) (if x2-p (and (= x2s 1) (simplep x2)) t) (if y2-p (and (= y2s 1) (simplep y2)) t) (zerop others)) `(distance-positional ,x1 ,y1 ,x2 ,y2)) ((and (< x1s 2) (< y1s 2) (< x2s 2) (< y2s 2) (zerop others)) (let ((temps (loop repeat n collect (gensym)))) `(let ,(loop for i below n collect (list (nth i temps) (arg i))) (distance ,@@(loop for i below n append (list (key i) (nth i temps))))))) (t form)))))) @result{} DISTANCE (dolist (form '((distance :x1 (setq x 7) :x2 (decf x) :y1 (decf x) :y2 (decf x)) (distance :x1 (setq x 7) :y1 (decf x) :x2 (decf x) :y2 (decf x)) (distance :x1 (setq x 7) :y1 (incf x)) (distance :x1 (setq x 7) :y1 (incf x) :x1 (incf x)) (distance :x1 a1 :y1 b1 :x2 a2 :y2 b2) (distance :x1 a1 :x2 a2 :y1 b1 :y2 b2) (distance :x1 a1 :y1 b1 :z1 c1 :x2 a2 :y2 b2 :z2 c2))) (print (funcall (compiler-macro-function 'distance) form nil))) @t{ |> } (LET ((#:G6558 (SETQ X 7)) @t{ |> } (#:G6559 (DECF X)) @t{ |> } (#:G6560 (DECF X)) @t{ |> } (#:G6561 (DECF X))) @t{ |> } (DISTANCE :X1 #:G6558 :X2 #:G6559 :Y1 #:G6560 :Y2 #:G6561)) @t{ |> } (DISTANCE-POSITIONAL (SETQ X 7) (DECF X) (DECF X) (DECF X)) @t{ |> } (LET ((#:G6567 (SETQ X 7)) @t{ |> } (#:G6568 (INCF X))) @t{ |> } (DISTANCE :X1 #:G6567 :Y1 #:G6568)) @t{ |> } (DISTANCE :X1 (SETQ X 7) :Y1 (INCF X) :X1 (INCF X)) @t{ |> } (DISTANCE-POSITIONAL A1 B1 A2 B2) @t{ |> } (DISTANCE-POSITIONAL A1 B1 A2 B2) @t{ |> } (DISTANCE :X1 A1 :Y1 B1 :Z1 C1 :X2 A2 :Y2 B2 :Z2 C2) @result{} NIL @end example @subsubheading See Also:: @ref{compiler-macro-function} , @ref{defmacro} , @ref{documentation} , @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: The consequences of writing a @i{compiler macro} definition for a function in the @t{COMMON-LISP} @i{package} are undefined; it is quite possible that in some @i{implementations} such an attempt would override an equivalent or equally important definition. In general, it is recommended that a programmer only write @i{compiler macro} definitions for @i{functions} he or she personally maintains--writing a @i{compiler macro} definition for a function maintained elsewhere is normally considered a violation of traditional rules of modularity and data abstraction. @node defmacro, macro-function, define-compiler-macro, Evaluation and Compilation Dictionary @subsection defmacro [Macro] @code{defmacro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{lambda-list}---a @i{macro lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @subsubheading Description:: Defines @i{name} as a @i{macro} by associating a @i{macro function} with that @i{name} in the global environment. The @i{macro function} is defined in the same @i{lexical environment} in which the @b{defmacro} @i{form} appears. The parameter variables in @i{lambda-list} are bound to destructured portions of the macro call. The expansion function accepts two arguments, a @i{form} and an @i{environment}. The expansion function returns a @i{form}. The body of the expansion function is specified by @i{forms}. @i{Forms} are executed in order. The value of the last @i{form} executed is returned as the expansion of the @i{macro}. The body @i{forms} of the expansion function (but not the @i{lambda-list}) are implicitly enclosed in a @i{block} whose name is @i{name}. The @i{lambda-list} conforms to the requirements described in @ref{Macro Lambda Lists}. @i{Documentation} is attached as a @i{documentation string} to @i{name} (as kind @b{function}) and to the @i{macro function}. @b{defmacro} can be used to redefine a @i{macro} or to replace a @i{function} definition with a @i{macro} definition. Recursive expansion of the @i{form} returned must terminate, including the expansion of other @i{macros} which are @i{subforms} of other @i{forms} returned. The consequences are undefined if the result of fully macroexpanding a @i{form} contains any @i{circular} @i{list structure} except in @i{literal objects}. If a @b{defmacro} @i{form} appears as a @i{top level form}, the @i{compiler} must store the @i{macro} definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Users must ensure that the body of the @i{macro} can be evaluated at compile time if it is referenced within the @i{file} being @i{compiled}. @subsubheading Examples:: @example (defmacro mac1 (a b) "Mac1 multiplies and adds" `(+ ,a (* ,b 3))) @result{} MAC1 (mac1 4 5) @result{} 19 (documentation 'mac1 'function) @result{} "Mac1 multiplies and adds" (defmacro mac2 (&optional (a 2 b) (c 3 d) &rest x) `'(,a ,b ,c ,d ,x)) @result{} MAC2 (mac2 6) @result{} (6 T 3 NIL NIL) (mac2 6 3 8) @result{} (6 T 3 T (8)) (defmacro mac3 (&whole r a &optional (b 3) &rest x &key c (d a)) `'(,r ,a ,b ,c ,d ,x)) @result{} MAC3 (mac3 1 6 :d 8 :c 9 :d 10) @result{} ((MAC3 1 6 :D 8 :C 9 :D 10) 1 6 9 8 (:D 8 :C 9 :D 10)) @end example The stipulation that an embedded @i{destructuring lambda list} is permitted only where @i{ordinary lambda list} syntax would permit a parameter name but not a @i{list} is made to prevent ambiguity. For example, the following is not valid: @example (defmacro loser (x &optional (a b &rest c) &rest z) ...) @end example because @i{ordinary lambda list} syntax does permit a @i{list} following @t{&optional}; the list @t{(a b &rest c)} would be interpreted as describing an optional parameter named @t{a} whose default value is that of the form @t{b}, with a supplied-p parameter named @b{&rest} (not valid), and an extraneous symbol @t{c} in the list (also not valid). An almost correct way to express this is @example (defmacro loser (x &optional ((a b &rest c)) &rest z) ...) @end example The extra set of parentheses removes the ambiguity. However, the definition is now incorrect because a macro call such as @t{(loser (car pool))} would not provide any argument form for the lambda list @t{(a b &rest c)}, and so the default value against which to match the @i{lambda list} would be @b{nil} because no explicit default value was specified. The consequences of this are unspecified since the empty list, @b{nil}, does not have @i{forms} to satisfy the parameters @t{a} and @t{b}. The fully correct definition would be either @example (defmacro loser (x &optional ((a b &rest c) '(nil nil)) &rest z) ...) @end example or @example (defmacro loser (x &optional ((&optional a b &rest c)) &rest z) ...) @end example These differ slightly: the first requires that if the macro call specifies @t{a} explicitly then it must also specify @t{b} explicitly, whereas the second does not have this requirement. For example, @example (loser (car pool) ((+ x 1))) @end example would be a valid call for the second definition but not for the first. @example (defmacro dm1a (&whole x) `',x) (macroexpand '(dm1a)) @result{} (QUOTE (DM1A)) (macroexpand '(dm1a a)) is an error. (defmacro dm1b (&whole x a &optional b) `'(,x ,a ,b)) (macroexpand '(dm1b)) is an error. (macroexpand '(dm1b q)) @result{} (QUOTE ((DM1B Q) Q NIL)) (macroexpand '(dm1b q r)) @result{} (QUOTE ((DM1B Q R) Q R)) (macroexpand '(dm1b q r s)) is an error. @end example @example (defmacro dm2a (&whole form a b) `'(form ,form a ,a b ,b)) (macroexpand '(dm2a x y)) @result{} (QUOTE (FORM (DM2A X Y) A X B Y)) (dm2a x y) @result{} (FORM (DM2A X Y) A X B Y) (defmacro dm2b (&whole form a (&whole b (c . d) &optional (e 5)) &body f &environment env) ``(,',form ,,a ,',b ,',(macroexpand c env) ,',d ,',e ,',f)) ;Note that because backquote is involved, implementations may differ ;slightly in the nature (though not the functionality) of the expansion. (macroexpand '(dm2b x1 (((incf x2) x3 x4)) x5 x6)) @result{} (LIST* '(DM2B X1 (((INCF X2) X3 X4)) X5 X6) X1 '((((INCF X2) X3 X4)) (SETQ X2 (+ X2 1)) (X3 X4) 5 (X5 X6))), T (let ((x1 5)) (macrolet ((segundo (x) `(cadr ,x))) (dm2b x1 (((segundo x2) x3 x4)) x5 x6))) @result{} ((DM2B X1 (((SEGUNDO X2) X3 X4)) X5 X6) 5 (((SEGUNDO X2) X3 X4)) (CADR X2) (X3 X4) 5 (X5 X6)) @end example @subsubheading See Also:: @ref{define-compiler-macro} , @ref{destructuring-bind} , @ref{documentation} , @ref{macroexpand} , @b{*macroexpand-hook*}, @b{macrolet}, @ref{macro-function} , @ref{Evaluation}, @ref{Compilation}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @node macro-function, macroexpand, defmacro, Evaluation and Compilation Dictionary @subsection macro-function [Accessor] @code{macro-function} @i{symbol @r{&optional} environment} @result{} @i{function} (setf (@code{ macro-function} @i{symbol @r{&optional} environment}) new-function)@* @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{environment}---an @i{environment} @i{object}. @i{function}---a @i{macro function} or @b{nil}. @i{new-function}---a @i{macro function}. @subsubheading Description:: Determines whether @i{symbol} has a function definition as a macro in the specified @i{environment}. If so, the macro expansion function, a function of two arguments, is returned. If @i{symbol} has no function definition in the lexical environment @i{environment}, or its definition is not a @i{macro}, @b{macro-function} returns @b{nil}. It is possible for both @b{macro-function} and @b{special-operator-p} to return @i{true} of @i{symbol}. The @i{macro} definition must be available for use by programs that understand only the standard @r{Common Lisp} @i{special forms}. @subsubheading Examples:: @example (defmacro macfun (x) '(macro-function 'macfun)) @result{} MACFUN (not (macro-function 'macfun)) @result{} @i{false} @end example @example (macrolet ((foo (&environment env) (if (macro-function 'bar env) ''yes ''no))) (list (foo) (macrolet ((bar () :beep)) (foo)))) @result{} (NO YES) @end example @subsubheading Affected By:: @t{(setf macro-function)}, @b{defmacro}, and @b{macrolet}. @subsubheading Exceptional Situations:: The consequences are undefined if @i{environment} is @i{non-nil} in a use of @b{setf} of @b{macro-function}. @subsubheading See Also:: @ref{defmacro} , @ref{Evaluation} @subsubheading Notes:: @b{setf} can be used with @b{macro-function} to install a @i{macro} as a symbol's global function definition: @example (setf (macro-function symbol) fn) @end example The value installed must be a @i{function} that accepts two arguments, the entire macro call and an @i{environment}, and computes the expansion for that call. Performing this operation causes @i{symbol} to have only that macro definition as its global function definition; any previous definition, whether as a @i{macro} or as a @i{function}, is lost. @node macroexpand, define-symbol-macro, macro-function, Evaluation and Compilation Dictionary @subsection macroexpand, macroexpand-1 [Function] @code{macroexpand} @i{form @r{&optional} env} @result{} @i{expansion, expanded-p} @code{macroexpand-} @i{1} @result{} @i{form @r{&optional} env} @r{expansion, expanded-p} @subsubheading Arguments and Values:: @i{form}---a @i{form}. @i{env}---an @i{environment} @i{object}. The default is @b{nil}. @i{expansion}---a @i{form}. @i{expanded-p}---a @i{generalized boolean}. @subsubheading Description:: @b{macroexpand} and @b{macroexpand-1} expand @i{macros}. If @i{form} is a @i{macro form}, then @b{macroexpand-1} expands the @i{macro form} call once. @b{macroexpand} repeatedly expands @i{form} until it is no longer a @i{macro form}. In effect, @b{macroexpand} calls @b{macroexpand-1} repeatedly until the @i{secondary value} it returns is @b{nil}. If @i{form} is a @i{macro form}, then the @i{expansion} is a @i{macro expansion} and @i{expanded-p} is @i{true}. Otherwise, the @i{expansion} is the given @i{form} and @i{expanded-p} is @i{false}. Macro expansion is carried out as follows. Once @b{macroexpand-1} has determined that the @i{form} is a @i{macro form}, it obtains an appropriate expansion @i{function} for the @i{macro} or @i{symbol macro}. The value of @b{*macroexpand-hook*} is coerced to a @i{function} and then called as a @i{function} of three arguments: the expansion @i{function}, the @i{form}, and the @i{env}. The @i{value} returned from this call is taken to be the expansion of the @i{form}. In addition to @i{macro} definitions in the global environment, any local macro definitions established within @i{env} by @b{macrolet} or @b{symbol-macrolet} are considered. If only @i{form} is supplied as an argument, then the environment is effectively null, and only global macro definitions as established by @b{defmacro} are considered. @i{Macro} definitions are shadowed by local @i{function} definitions. @subsubheading Examples:: @example (defmacro alpha (x y) `(beta ,x ,y)) @result{} ALPHA (defmacro beta (x y) `(gamma ,x ,y)) @result{} BETA (defmacro delta (x y) `(gamma ,x ,y)) @result{} EPSILON (defmacro expand (form &environment env) (multiple-value-bind (expansion expanded-p) (macroexpand form env) `(values ',expansion ',expanded-p))) @result{} EXPAND (defmacro expand-1 (form &environment env) (multiple-value-bind (expansion expanded-p) (macroexpand-1 form env) `(values ',expansion ',expanded-p))) @result{} EXPAND-1 ;; Simple examples involving just the global environment (macroexpand-1 '(alpha a b)) @result{} (BETA A B), @i{true} (expand-1 (alpha a b)) @result{} (BETA A B), @i{true} (macroexpand '(alpha a b)) @result{} (GAMMA A B), @i{true} (expand (alpha a b)) @result{} (GAMMA A B), @i{true} (macroexpand-1 'not-a-macro) @result{} NOT-A-MACRO, @i{false} (expand-1 not-a-macro) @result{} NOT-A-MACRO, @i{false} (macroexpand '(not-a-macro a b)) @result{} (NOT-A-MACRO A B), @i{false} (expand (not-a-macro a b)) @result{} (NOT-A-MACRO A B), @i{false} ;; Examples involving lexical environments (macrolet ((alpha (x y) `(delta ,x ,y))) (macroexpand-1 '(alpha a b))) @result{} (BETA A B), @i{true} (macrolet ((alpha (x y) `(delta ,x ,y))) (expand-1 (alpha a b))) @result{} (DELTA A B), @i{true} (macrolet ((alpha (x y) `(delta ,x ,y))) (macroexpand '(alpha a b))) @result{} (GAMMA A B), @i{true} (macrolet ((alpha (x y) `(delta ,x ,y))) (expand (alpha a b))) @result{} (GAMMA A B), @i{true} (macrolet ((beta (x y) `(epsilon ,x ,y))) (expand (alpha a b))) @result{} (EPSILON A B), @i{true} (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (expand a))) @result{} (FIRST X), @i{true} (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (macroexpand 'a))) @result{} A, @i{false} (symbol-macrolet ((b (alpha x y))) (expand-1 b)) @result{} (ALPHA X Y), @i{true} (symbol-macrolet ((b (alpha x y))) (expand b)) @result{} (GAMMA X Y), @i{true} (symbol-macrolet ((b (alpha x y)) (a b)) (expand-1 a)) @result{} B, @i{true} (symbol-macrolet ((b (alpha x y)) (a b)) (expand a)) @result{} (GAMMA X Y), @i{true} ;; Examples of shadowing behavior (flet ((beta (x y) (+ x y))) (expand (alpha a b))) @result{} (BETA A B), @i{true} (macrolet ((alpha (x y) `(delta ,x ,y))) (flet ((alpha (x y) (+ x y))) (expand (alpha a b)))) @result{} (ALPHA A B), @i{false} (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (let ((a x)) (expand a)))) @result{} A, @i{false} @end example @subsubheading Affected By:: @b{defmacro}, @b{setf} of @b{macro-function}, @b{macrolet}, @b{symbol-macrolet} @subsubheading See Also:: @b{*macroexpand-hook*}, @ref{defmacro} , @ref{setf} of @ref{macro-function} , @b{macrolet}, @ref{symbol-macrolet} , @ref{Evaluation} @subsubheading Notes:: Neither @b{macroexpand} nor @b{macroexpand-1} makes any explicit attempt to expand @i{macro forms} that are either @i{subforms} of the @i{form} or @i{subforms} of the @i{expansion}. Such expansion might occur implicitly, however, due to the semantics or implementation of the @i{macro function}. @node define-symbol-macro, symbol-macrolet, macroexpand, Evaluation and Compilation Dictionary @subsection define-symbol-macro [Macro] @code{define-symbol-macro} @i{symbol expansion}@* @result{} @i{symbol} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{expansion}---a @i{form}. @subsubheading Description:: Provides a mechanism for globally affecting the @i{macro expansion} of the indicated @i{symbol}. Globally establishes an expansion function for the @i{symbol macro} named by @i{symbol}. The only guaranteed property of an expansion @i{function} for a @i{symbol macro} is that when it is applied to the @i{form} and the @i{environment} it returns the correct expansion. (In particular, it is @i{implementation-dependent} whether the expansion is conceptually stored in the expansion function, the @i{environment}, or both.) Each global reference to @i{symbol} (@i{i.e.}, not @i{shadowed}_2 by a @i{binding} for a @i{variable} or @i{symbol macro} named by the same @i{symbol}) is expanded by the normal macro expansion process; see @ref{Symbols as Forms}. The expansion of a @i{symbol macro} is subject to further @i{macro expansion} in the same @i{lexical environment} as the @i{symbol macro} reference, exactly analogous to normal @i{macros}. The consequences are unspecified if a @b{special} declaration is made for @i{symbol} while in the scope of this definition (@i{i.e.}, when it is not @i{shadowed}_2 by a @i{binding} for a @i{variable} or @i{symbol macro} named by the same @i{symbol}). Any use of @b{setq} to set the value of the @i{symbol} while in the scope of this definition is treated as if it were a @b{setf}. @b{psetq} of @i{symbol} is treated as if it were a @b{psetf}, and @b{multiple-value-setq} is treated as if it were a @b{setf} of @b{values}. A @i{binding} for a @i{symbol macro} can be @i{shadowed}_2 by @b{let} or @b{symbol-macrolet}. @subsubheading Examples:: @example (defvar *things* (list 'alpha 'beta 'gamma)) @result{} *THINGS* (define-symbol-macro thing1 (first *things*)) @result{} THING1 (define-symbol-macro thing2 (second *things*)) @result{} THING2 (define-symbol-macro thing3 (third *things*)) @result{} THING3 thing1 @result{} ALPHA (setq thing1 'ONE) @result{} ONE *things* @result{} (ONE BETA GAMMA) (multiple-value-setq (thing2 thing3) (values 'two 'three)) @result{} TWO thing3 @result{} THREE *things* @result{} (ONE TWO THREE) (list thing2 (let ((thing2 2)) thing2)) @result{} (TWO 2) @end example @subsubheading Exceptional Situations:: If @i{symbol} is already defined as a @i{global variable}, an error of @i{type} @b{program-error} is signaled. @subsubheading See Also:: @ref{symbol-macrolet} , @ref{macroexpand} @node symbol-macrolet, *macroexpand-hook*, define-symbol-macro, Evaluation and Compilation Dictionary @subsection symbol-macrolet [Special Operator] @code{symbol-macrolet} @i{@r{(}@{@r{(}symbol expansion @r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{expansion}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{symbol-macrolet} provides a mechanism for affecting the @i{macro expansion} environment for @i{symbols}. @b{symbol-macrolet} lexically establishes expansion functions for each of the @i{symbol macros} named by @i{symbols}. The only guaranteed property of an expansion @i{function} for a @i{symbol macro} is that when it is applied to the @i{form} and the @i{environment} it returns the correct expansion. (In particular, it is @i{implementation-dependent} whether the expansion is conceptually stored in the expansion function, the @i{environment}, or both.) Each reference to @i{symbol} as a variable within the lexical @i{scope} of @b{symbol-macrolet} is expanded by the normal macro expansion process; see @ref{Symbols as Forms}. The expansion of a symbol macro is subject to further macro expansion in the same lexical environment as the symbol macro invocation, exactly analogous to normal @i{macros}. Exactly the same @i{declarations} are allowed as for @b{let} with one exception: @b{symbol-macrolet} signals an error if a @b{special} declaration names one of the @i{symbols} being defined by @b{symbol-macrolet}. When the @i{forms} of the @b{symbol-macrolet} form are expanded, any use of @b{setq} to set the value of one of the specified variables is treated as if it were a @b{setf}. @b{psetq} of a @i{symbol} defined as a symbol macro is treated as if it were a @b{psetf}, and @b{multiple-value-setq} is treated as if it were a @b{setf} of @b{values}. The use of @b{symbol-macrolet} can be shadowed by @b{let}. In other words, @b{symbol-macrolet} only substitutes for occurrences of @i{symbol} that would be in the @i{scope} of a lexical binding of @i{symbol} surrounding the @i{forms}. @subsubheading Examples:: @example ;;; The following is equivalent to ;;; (list 'foo (let ((x 'bar)) x)), ;;; not ;;; (list 'foo (let (('foo 'bar)) 'foo)) (symbol-macrolet ((x 'foo)) (list x (let ((x 'bar)) x))) @result{} (foo bar) @i{NOT}@result{} (foo foo) (symbol-macrolet ((x '(foo x))) (list x)) @result{} ((FOO X)) @end example @subsubheading Exceptional Situations:: If an attempt is made to bind a @i{symbol} that is defined as a @i{global variable}, an error of @i{type} @b{program-error} is signaled. If @i{declaration} contains a @b{special} declaration that names one of the @i{symbols} being bound by @b{symbol-macrolet}, an error of @i{type} @b{program-error} is signaled. @subsubheading See Also:: @ref{with-slots} , @ref{macroexpand} @subsubheading Notes:: The special form @b{symbol-macrolet} is the basic mechanism that is used to implement @b{with-slots}. If a @b{symbol-macrolet} @i{form} is a @i{top level form}, the @i{forms} are also processed as @i{top level forms}. See @ref{File Compilation}. @node *macroexpand-hook*, proclaim, symbol-macrolet, Evaluation and Compilation Dictionary @subsection *macroexpand-hook* [Variable] @subsubheading Value Type:: a @i{designator} for a @i{function} of three @i{arguments}: a @i{macro function}, a @i{macro form}, and an @i{environment} @i{object}. @subsubheading Initial Value:: a @i{designator} for a function that is equivalent to the @i{function} @b{funcall}, but that might have additional @i{implementation-dependent} side-effects. @subsubheading Description:: Used as the expansion interface hook by @b{macroexpand-1} to control the @i{macro expansion} process. When a @i{macro form} is to be expanded, this @i{function} is called with three arguments: the @i{macro function}, the @i{macro form}, and the @i{environment} in which the @i{macro form} is to be expanded. The @i{environment} @i{object} has @i{dynamic extent}; the consequences are undefined if the @i{environment} @i{object} is referred to outside the @i{dynamic extent} of the macro expansion function. @subsubheading Examples:: @example (defun hook (expander form env) (format t "Now expanding: ~S~ (funcall expander form env)) @result{} HOOK (defmacro machook (x y) `(/ (+ ,x ,y) 2)) @result{} MACHOOK (macroexpand '(machook 1 2)) @result{} (/ (+ 1 2) 2), @i{true} (let ((*macroexpand-hook* #'hook)) (macroexpand '(machook 1 2))) @t{ |> } Now expanding (MACHOOK 1 2) @result{} (/ (+ 1 2) 2), @i{true} @end example @subsubheading See Also:: @ref{macroexpand} , @b{macroexpand-1}, @ref{funcall} , @ref{Evaluation} @subsubheading Notes:: The net effect of the chosen initial value is to just invoke the @i{macro function}, giving it the @i{macro form} and @i{environment} as its two arguments. Users or user programs can @i{assign} this @i{variable} to customize or trace the @i{macro expansion} mechanism. Note, however, that this @i{variable} is a global resource, potentially shared by multiple @i{programs}; as such, if any two @i{programs} depend for their correctness on the setting of this @i{variable}, those @i{programs} may not be able to run in the same @i{Lisp image}. For this reason, it is frequently best to confine its uses to debugging situations. Users who put their own function into @b{*macroexpand-hook*} should consider saving the previous value of the hook, and calling that value from their own. @node proclaim, declaim, *macroexpand-hook*, Evaluation and Compilation Dictionary @subsection proclaim [Function] @code{proclaim} @i{declaration-specifier} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{declaration-specifier}---a @i{declaration specifier}. @subsubheading Description:: @i{Establishes} the @i{declaration} specified by @i{declaration-specifier} in the @i{global environment}. Such a @i{declaration}, sometimes called a @i{global declaration} or a @i{proclamation}, is always in force unless locally @i{shadowed}. @i{Names} of @i{variables} and @i{functions} within @i{declaration-specifier} refer to @i{dynamic variables} and global @i{function} definitions, respectively. Figure 3--22 shows a list of @i{declaration identifiers} that can be used with @b{proclaim}. @format @group @noindent @w{ declaration inline optimize type } @w{ ftype notinline special } @noindent @w{ Figure 3--22: Global Declaration Specifiers} @end group @end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. @subsubheading Examples:: @example (defun declare-variable-types-globally (type vars) (proclaim `(type ,type ,@@vars)) type) ;; Once this form is executed, the dynamic variable *TOLERANCE* ;; must always contain a float. (declare-variable-types-globally 'float '(*tolerance*)) @result{} FLOAT @end example @subsubheading See Also:: @ref{declaim} , @b{declare}, @ref{Compilation} @subsubheading Notes:: Although the @i{execution} of a @b{proclaim} @i{form} has effects that might affect compilation, the compiler does not make any attempt to recognize and specially process @b{proclaim} @i{forms}. A @i{proclamation} such as the following, even if a @i{top level form}, does not have any effect until it is executed: @example (proclaim '(special *x*)) @end example If compile time side effects are desired, @b{eval-when} may be useful. For example: @example (eval-when (:execute :compile-toplevel :load-toplevel) (proclaim '(special *x*))) @end example In most such cases, however, it is preferrable to use @b{declaim} for this purpose. Since @b{proclaim} @i{forms} are ordinary @i{function forms}, @i{macro forms} can expand into them. @node declaim, declare, proclaim, Evaluation and Compilation Dictionary @subsection declaim [Macro] @code{declaim} @i{@{@i{declaration-specifier}@}*} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{declaration-specifier}---a @i{declaration specifier}; not evaluated. @subsubheading Description:: Establishes the @i{declarations} specified by the @i{declaration-specifiers}. If a use of this macro appears as a @i{top level form} in a @i{file} being processed by the @i{file compiler}, the proclamations are also made at compile-time. As with other defining macros, it is unspecified whether or not the compile-time side-effects of a @b{declaim} persist after the @i{file} has been @i{compiled}. @subsubheading Examples:: @subsubheading See Also:: @b{declare}, @ref{proclaim} @node declare, ignore, declaim, Evaluation and Compilation Dictionary @subsection declare [Symbol] @subsubheading Syntax:: @code{declare} @i{@{@i{declaration-specifier}@}*} @subsubheading Arguments:: @i{declaration-specifier}---a @i{declaration specifier}; not evaluated. @subsubheading Description:: A @b{declare} @i{expression}, sometimes called a @i{declaration}, can occur only at the beginning of the bodies of certain @i{forms}; that is, it may be preceded only by other @b{declare} @i{expressions}, or by a @i{documentation string} if the context permits. A @b{declare} @i{expression} can occur in a @i{lambda expression} or in any of the @i{forms} listed in Figure 3--23. @format @group @noindent @w{ defgeneric do-external-symbols prog } @w{ define-compiler-macro do-symbols prog* } @w{ define-method-combination dolist restart-case } @w{ define-setf-expander dotimes symbol-macrolet } @w{ defmacro flet with-accessors } @w{ defmethod handler-case with-hash-table-iterator } @w{ defsetf labels with-input-from-string } @w{ deftype let with-open-file } @w{ defun let* with-open-stream } @w{ destructuring-bind locally with-output-to-string } @w{ do macrolet with-package-iterator } @w{ do* multiple-value-bind with-slots } @w{ do-all-symbols pprint-logical-block } @noindent @w{ Figure 3--23: Standardized Forms In Which Declarations Can Occur } @end group @end format A @b{declare} @i{expression} can only occur where specified by the syntax of these @i{forms}. The consequences of attempting to evaluate a @b{declare} @i{expression} are undefined. In situations where such @i{expressions} can appear, explicit checks are made for their presence and they are never actually evaluated; it is for this reason that they are called ``@b{declare} @i{expressions}'' rather than ``@b{declare} @i{forms}.'' @i{Macro forms} cannot expand into declarations; @b{declare} @i{expressions} must appear as actual @i{subexpressions} of the @i{form} to which they refer. Figure 3--24 shows a list of @i{declaration identifiers} that can be used with @b{declare}. @format @group @noindent @w{ dynamic-extent ignore optimize } @w{ ftype inline special } @w{ ignorable notinline type } @noindent @w{ Figure 3--24: Local Declaration Specifiers} @end group @end format An implementation is free to support other (@i{implementation-defined}) @i{declaration identifiers} as well. @subsubheading Examples:: @example (defun nonsense (k x z) (foo z x) ;First call to foo (let ((j (foo k x)) ;Second call to foo (x (* k k))) (declare (inline foo) (special x z)) (foo x j z))) ;Third call to foo @end example In this example, the @b{inline} declaration applies only to the third call to @t{foo}, but not to the first or second ones. The @b{special} declaration of @t{x} causes @b{let} to make a dynamic @i{binding} for @t{x}, and causes the reference to @t{x} in the body of @b{let} to be a dynamic reference. The reference to @t{x} in the second call to @t{foo} is a local reference to the second parameter of @t{nonsense}. The reference to @t{x} in the first call to @t{foo} is a local reference, not a @b{special} one. The @b{special} declaration of @t{z} causes the reference to @t{z} in the third call to @t{foo} to be a dynamic reference; it does not refer to the parameter to @t{nonsense} named @t{z}, because that parameter @i{binding} has not been declared to be @b{special}. (The @b{special} declaration of @t{z} does not appear in the body of @b{defun}, but in an inner @i{form}, and therefore does not affect the @i{binding} of the @i{parameter}.) @subsubheading Exceptional Situations:: The consequences of trying to use a @b{declare} @i{expression} as a @i{form} to be @i{evaluated} are undefined. [Editorial Note by KMP: Probably we need to say something here about ill-formed declare expressions.] @subsubheading See Also:: @ref{proclaim} , @ref{Type Specifiers}, @b{declaration}, @b{dynamic-extent}, @b{ftype}, @b{ignorable}, @b{ignore}, @b{inline}, @b{notinline}, @b{optimize}, @b{type} @node ignore, dynamic-extent, declare, Evaluation and Compilation Dictionary @subsection ignore, ignorable [Declaration] @subsubheading Syntax:: @t{@r{(}ignore @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} @t{@r{(}ignorable @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} @subsubheading Arguments:: @i{var}---a @i{variable} @i{name}. @i{fn}---a @i{function} @i{name}. @subsubheading Valid Context:: @i{declaration} @subsubheading Binding Types Affected:: @i{variable}, @i{function} @subsubheading Description:: The @b{ignore} and @b{ignorable} declarations refer to @i{for-value} @i{references} to @i{variable} @i{bindings} for the @i{vars} and to @i{function} @i{bindings} for the @i{fns}. An @b{ignore} @i{declaration} specifies that @i{for-value} @i{references} to the indicated @i{bindings} will not occur within the scope of the @i{declaration}. Within the @i{scope} of such a @i{declaration}, it is desirable for a compiler to issue a warning about the presence of either a @i{for-value} @i{reference} to any @i{var} or @i{fn}, or a @b{special} @i{declaration} for any @i{var}. An @b{ignorable} @i{declaration} specifies that @i{for-value} @i{references} to the indicated @i{bindings} might or might not occur within the scope of the @i{declaration}. Within the @i{scope} of such a @i{declaration}, it is not desirable for a compiler to issue a warning about the presence or absence of either a @i{for-value} @i{reference} to any @i{var} or @i{fn}, or a @b{special} @i{declaration} for any @i{var}. When not within the @i{scope} of a @b{ignore} or @b{ignorable} @i{declaration}, it is desirable for a compiler to issue a warning about any @i{var} for which there is neither a @i{for-value} @i{reference} nor a @b{special} @i{declaration}, or about any @i{fn} for which there is no @i{for-value} @i{reference}. Any warning about a ``used'' or ``unused'' @i{binding} must be of @i{type} @b{style-warning}, and may not affect program semantics. The @i{stream variables} established by @b{with-open-file}, @b{with-open-stream}, @b{with-input-from-string}, and @b{with-output-to-string}, and all @i{iteration variables} are, by definition, always ``used''. Using @t{(declare (ignore @i{v}))}, for such a @i{variable} @i{v} has unspecified consequences. @subsubheading See Also:: @b{declare} @node dynamic-extent, type, ignore, Evaluation and Compilation Dictionary @subsection dynamic-extent [Declaration] @subsubheading Syntax:: @t{(dynamic-extent [[@{@i{var}@}* | @r{(}@b{function} @i{fn}@r{)}@r{*}]])} @subsubheading Arguments:: @i{var}---a @i{variable} @i{name}. @i{fn}---a @i{function} @i{name}. @subsubheading Valid Context:: @i{declaration} @subsubheading Binding Types Affected:: @i{variable}, @i{function} @subsubheading Description:: In some containing @i{form}, @i{F}, this declaration asserts for each @i{var_i} (which need not be bound by @i{F}), and for each @i{value} @i{v_@{ij@}} that @i{var_i} takes on, and for each @i{object} @i{x_@{ijk@}} that is an @i{otherwise inaccessible part} of @i{v_@{ij@}} at any time when @i{v_@{ij@}} becomes the value of @i{var_i}, that just after the execution of @i{F} terminates, @i{x_@{ijk@}} is either @i{inaccessible} (if @i{F} established a @i{binding} for @i{var_i}) or still an @i{otherwise inaccessible part} of the current value of @i{var_i} (if @i{F} did not establish a @i{binding} for @i{var_i}). The same relation holds for each @i{fn_i}, except that the @i{bindings} are in the @i{function} @i{namespace}. The compiler is permitted to use this information in any way that is appropriate to the @i{implementation} and that does not conflict with the semantics of @r{Common Lisp}. @b{dynamic-extent} declarations can be @i{free declarations} or @i{bound declarations}. The @i{vars} and @i{fns} named in a @b{dynamic-extent} declaration must not refer to @i{symbol macro} or @i{macro} bindings. @subsubheading Examples:: Since stack allocation of the initial value entails knowing at the @i{object}'s creation time that the @i{object} can be @i{stack-allocated}, it is not generally useful to make a @b{dynamic-extent} @i{declaration} for @i{variables} which have no lexically apparent initial value. For example, it is probably useful to write: @example (defun f () (let ((x (list 1 2 3))) (declare (dynamic-extent x)) ...)) @end example This would permit those compilers that wish to do so to @i{stack allocate} the list held by the local variable @t{x}. It is permissible, but in practice probably not as useful, to write: @example (defun g (x) (declare (dynamic-extent x)) ...) (defun f () (g (list 1 2 3))) @end example Most compilers would probably not @i{stack allocate} the @i{argument} to @t{g} in @t{f} because it would be a modularity violation for the compiler to assume facts about @t{g} from within @t{f}. Only an implementation that was willing to be responsible for recompiling @t{f} if the definition of @t{g} changed incompatibly could legitimately @i{stack allocate} the @i{list} argument to @t{g} in @t{f}. Here is another example: @example (declaim (inline g)) (defun g (x) (declare (dynamic-extent x)) ...) (defun f () (g (list 1 2 3))) (defun f () (flet ((g (x) (declare (dynamic-extent x)) ...)) (g (list 1 2 3)))) @end example In the previous example, some compilers might determine that optimization was possible and others might not. A variant of this is the so-called ``stack allocated rest list'' that can be achieved (in implementations supporting the optimization) by: @example (defun f (&rest x) (declare (dynamic-extent x)) ...) @end example Note that although the initial value of @t{x} is not explicit, the @t{f} function is responsible for assembling the list @t{x} from the passed arguments, so the @t{f} function can be optimized by the compiler to construct a @i{stack-allocated} list instead of a heap-allocated list in implementations that support such. In the following example, @example (let ((x (list 'a1 'b1 'c1)) (y (cons 'a2 (cons 'b2 (cons 'c2 nil))))) (declare (dynamic-extent x y)) ...) @end example The @i{otherwise inaccessible parts} of @t{x} are three @i{conses}, and the @i{otherwise inaccessible parts} of @t{y} are three other @i{conses}. None of the symbols @t{a1}, @t{b1}, @t{c1}, @t{a2}, @t{b2}, @t{c2}, or @b{nil} is an @i{otherwise inaccessible part} of @t{x} or @t{y} because each is @i{interned} and hence @i{accessible} by the @i{package} (or @i{packages}) in which it is @i{interned}. However, if a freshly allocated @i{uninterned} @i{symbol} had been used, it would have been an @i{otherwise inaccessible part} of the @i{list} which contained it. @example ;; In this example, the implementation is permitted to @i{stack allocate} ;; the list that is bound to X. (let ((x (list 1 2 3))) (declare (dynamic-extent x)) (print x) :done) @t{ |> } (1 2 3) @result{} :DONE ;; In this example, the list to be bound to L can be @i{stack-allocated}. (defun zap (x y z) (do ((l (list x y z) (cdr l))) ((null l)) (declare (dynamic-extent l)) (prin1 (car l)))) @result{} ZAP (zap 1 2 3) @t{ |> } 123 @result{} NIL ;; Some implementations might open-code LIST-ALL-PACKAGES in a way ;; that permits using @i{stack allocation} of the list to be bound to L. (do ((l (list-all-packages) (cdr l))) ((null l)) (declare (dynamic-extent l)) (let ((name (package-name (car l)))) (when (string-search "COMMON-LISP" name) (print name)))) @t{ |> } "COMMON-LISP" @t{ |> } "COMMON-LISP-USER" @result{} NIL ;; Some implementations might have the ability to @i{stack allocate} ;; rest lists. A declaration such as the following should be a cue ;; to such implementations that stack-allocation of the rest list ;; would be desirable. (defun add (&rest x) (declare (dynamic-extent x)) (apply #'+ x)) @result{} ADD (add 1 2 3) @result{} 6 (defun zap (n m) ;; Computes (RANDOM (+ M 1)) at relative speed of roughly O(N). ;; It may be slow, but with a good compiler at least it ;; doesn't waste much heap storage. :-@} (let ((a (make-array n))) (declare (dynamic-extent a)) (dotimes (i n) (declare (dynamic-extent i)) (setf (aref a i) (random (+ i 1)))) (aref a m))) @result{} ZAP (< (zap 5 3) 3) @result{} @i{true} @end example The following are in error, since the value of @t{x} is used outside of its @i{extent}: @example (length (list (let ((x (list 1 2 3))) ; Invalid (declare (dynamic-extent x)) x))) (progn (let ((x (list 1 2 3))) ; Invalid (declare (dynamic-extent x)) x) nil) @end example @subsubheading See Also:: @b{declare} @subsubheading Notes:: The most common optimization is to @i{stack allocate} the initial value of the @i{objects} named by the @i{vars}. It is permissible for an implementation to simply ignore this declaration. @node type, inline, dynamic-extent, Evaluation and Compilation Dictionary @subsection type [Declaration] @subsubheading Syntax:: @t{(type @i{typespec} @{@i{var}@}*)} @t{(@i{typespec} @{@i{var}@}*)} @subsubheading Arguments:: @i{typespec}---a @i{type specifier}. @i{var}---a @i{variable} @i{name}. @subsubheading Valid Context:: @i{declaration} or @i{proclamation} @subsubheading Binding Types Affected:: @i{variable} @subsubheading Description:: Affects only variable @i{bindings} and specifies that the @i{vars} take on values only of the specified @i{typespec}. In particular, values assigned to the variables by @b{setq}, as well as the initial values of the @i{vars} must be of the specified @i{typespec}. @b{type} declarations never apply to function @i{bindings} (see @b{ftype}). A type declaration of a @i{symbol} defined by @b{symbol-macrolet} is equivalent to wrapping a @b{the} expression around the expansion of that @i{symbol}, although the @i{symbol}'s @i{macro expansion} is not actually affected. The meaning of a type declaration is equivalent to changing each reference to a variable (@i{var}) within the scope of the declaration to @t{(the @i{typespec} @i{var})}, changing each expression assigned to the variable (@i{new-value}) within the scope of the declaration to @t{(the @i{typespec} @i{new-value})}, and executing @t{(the @i{typespec} @i{var})} at the moment the scope of the declaration is entered. A @i{type} declaration is valid in all declarations. The interpretation of a type declaration is as follows: @table @asis @item 1. During the execution of any reference to the declared variable within the scope of the declaration, the consequences are undefined if the value of the declared variable is not of the declared @i{type}. @item 2. During the execution of any @b{setq} of the declared variable within the scope of the declaration, the consequences are undefined if the newly assigned value of the declared variable is not of the declared @i{type}. @item 3. At the moment the scope of the declaration is entered, the consequences are undefined if the value of the declared variable is not of the declared @i{type}. @end table A @i{type} declaration affects only variable references within its scope. If nested @i{type} declarations refer to the same variable, then the value of the variable must be a member of the intersection of the declared @i{types}. If there is a local @t{type} declaration for a dynamic variable, and there is also a global @t{type} proclamation for that same variable, then the value of the variable within the scope of the local declaration must be a member of the intersection of the two declared @i{types}. @b{type} declarations can be @i{free declarations} or @i{bound declarations}. A @i{symbol} cannot be both the name of a @i{type} and the name of a declaration. Defining a @i{symbol} as the @i{name} of a @i{class}, @i{structure}, @i{condition}, or @i{type}, when the @i{symbol} has been @i{declared} as a declaration name, or vice versa, signals an error. Within the @i{lexical scope} of an @b{array} type declaration, all references to @i{array} @i{elements} are assumed to satisfy the @i{expressed array element type} (as opposed to the @i{upgraded array element type}). A compiler can treat the code within the scope of the @b{array} type declaration as if each @i{access} of an @i{array} @i{element} were surrounded by an appropriate @b{the} form. @subsubheading Examples:: @example (defun f (x y) (declare (type fixnum x y)) (let ((z (+ x y))) (declare (type fixnum z)) z)) @result{} F (f 1 2) @result{} 3 ;; The previous definition of F is equivalent to (defun f (x y) ;; This declaration is a shorthand form of the TYPE declaration (declare (fixnum x y)) ;; To declare the type of a return value, it's not necessary to ;; create a named variable. A THE special form can be used instead. (the fixnum (+ x y))) @result{} F (f 1 2) @result{} 3 @end example @example (defvar *one-array* (make-array 10 :element-type '(signed-byte 5))) (defvar *another-array* (make-array 10 :element-type '(signed-byte 8))) (defun frob (an-array) (declare (type (array (signed-byte 5) 1) an-array)) (setf (aref an-array 1) 31) (setf (aref an-array 2) 127) (setf (aref an-array 3) (* 2 (aref an-array 3))) (let ((foo 0)) (declare (type (signed-byte 5) foo)) (setf foo (aref an-array 0)))) (frob *one-array*) (frob *another-array*) @end example The above definition of @t{frob} is equivalent to: @example (defun frob (an-array) (setf (the (signed-byte 5) (aref an-array 1)) 31) (setf (the (signed-byte 5) (aref an-array 2)) 127) (setf (the (signed-byte 5) (aref an-array 3)) (* 2 (the (signed-byte 5) (aref an-array 3)))) (let ((foo 0)) (declare (type (signed-byte 5) foo)) (setf foo (the (signed-byte 5) (aref an-array 0))))) @end example Given an implementation in which @i{fixnums} are 29 bits but @b{fixnum} @i{arrays} are upgraded to signed 32-bit @i{arrays}, the following could be compiled with all @i{fixnum} arithmetic: @example (defun bump-counters (counters) (declare (type (array fixnum *) bump-counters)) (dotimes (i (length counters)) (incf (aref counters i)))) @end example @subsubheading See Also:: @b{declare}, @ref{declaim} , @ref{proclaim} @subsubheading Notes:: @t{(@i{typespec} @{@i{var}@}*)} is an abbreviation for @t{(type @i{typespec} @{@i{var}@}*)}. A @b{type} declaration for the arguments to a function does not necessarily imply anything about the type of the result. The following function is not permitted to be compiled using @i{implementation-dependent} @i{fixnum}-only arithmetic: @example (defun f (x y) (declare (fixnum x y)) (+ x y)) @end example To see why, consider @t{(f most-positive-fixnum 1)}. Common Lisp defines that @t{F} must return a @i{bignum} here, rather than signal an error or produce a mathematically incorrect result. If you have special knowledge such ``@i{fixnum} overflow'' cases will not come up, you can declare the result value to be in the @i{fixnum} range, enabling some compilers to use more efficient arithmetic: @example (defun f (x y) (declare (fixnum x y)) (the fixnum (+ x y))) @end example Note, however, that in the three-argument case, because of the possibility of an implicit intermediate value growing too large, the following will not cause @i{implementation-dependent} @i{fixnum}-only arithmetic to be used: @example (defun f (x y) (declare (fixnum x y z)) (the fixnum (+ x y z))) @end example To see why, consider @t{(f most-positive-fixnum 1 -1).} Although the arguments and the result are all @i{fixnums}, an intermediate value is not a @i{fixnum}. If it is important that @i{implementation-dependent} @i{fixnum}-only arithmetic be selected in @i{implementations} that provide it, consider writing something like this instead: @example (defun f (x y) (declare (fixnum x y z)) (the fixnum (+ (the fixnum (+ x y)) z))) @end example @node inline, ftype, type, Evaluation and Compilation Dictionary @subsection inline, notinline [Declaration] @subsubheading Syntax:: @t{(inline @{@i{function-name}@}*)} @t{(notinline @{@i{function-name}@}*)} @subsubheading Arguments:: @i{function-name}---a @i{function name}. @subsubheading Valid Context:: @i{declaration} or @i{proclamation} @subsubheading Binding Types Affected:: @i{function} @subsubheading Description:: @b{inline} specifies that it is desirable for the compiler to produce inline calls to the @i{functions} named by @i{function-names}; that is, the code for a specified @i{function-name} should be integrated into the calling routine, appearing ``in line'' in place of a procedure call. A compiler is free to ignore this declaration. @b{inline} declarations never apply to variable @i{bindings}. If one of the @i{functions} mentioned has a lexically apparent local definition (as made by @b{flet} or @b{labels}), then the declaration applies to that local definition and not to the global function definition. While no @i{conforming implementation} is required to perform inline expansion of user-defined functions, those @i{implementations} that do attempt to recognize the following paradigm: To define a @i{function} @t{f} that is not @b{inline} by default but for which @t{(declare (inline f))} will make @i{f} be locally inlined, the proper definition sequence is: @example (declaim (inline f)) (defun f ...) (declaim (notinline f)) @end example The @b{inline} proclamation preceding the @b{defun} @i{form} ensures that the @i{compiler} has the opportunity save the information necessary for inline expansion, and the @b{notinline} proclamation following the @b{defun} @i{form} prevents @t{f} from being expanded inline everywhere. @b{notinline} specifies that it is undesirable to compile the @i{functions} named by @i{function-names} in-line. A compiler is not free to ignore this declaration; calls to the specified functions must be implemented as out-of-line subroutine calls. If one of the @i{functions} mentioned has a lexically apparent local definition (as made by @b{flet} or @b{labels}), then the declaration applies to that local definition and not to the global function definition. In the presence of a @i{compiler macro} definition for @i{function-name}, a @b{notinline} declaration prevents that @i{compiler macro} from being used. An @b{inline} declaration may be used to encourage use of @i{compiler macro} definitions. @b{inline} and @b{notinline} declarations otherwise have no effect when the lexically visible definition of @i{function-name} is a @i{macro} definition. @b{inline} and @b{notinline} declarations can be @i{free declarations} or @i{bound declarations}. @b{inline} and @b{notinline} declarations of functions that appear before the body of a @b{flet} or @b{labels} @i{form} that defines that function are @i{bound declarations}. Such declarations in other contexts are @i{free declarations}. @subsubheading Examples:: @example ;; The globally defined function DISPATCH should be open-coded, ;; if the implementation supports inlining, unless a NOTINLINE ;; declaration overrides this effect. (declaim (inline dispatch)) (defun dispatch (x) (funcall (get (car x) 'dispatch) x)) ;; Here is an example where inlining would be encouraged. (defun top-level-1 () (dispatch (read-command))) ;; Here is an example where inlining would be prohibited. (defun top-level-2 () (declare (notinline dispatch)) (dispatch (read-command))) ;; Here is an example where inlining would be prohibited. (declaim (notinline dispatch)) (defun top-level-3 () (dispatch (read-command))) ;; Here is an example where inlining would be encouraged. (defun top-level-4 () (declare (inline dispatch)) (dispatch (read-command))) @end example @subsubheading See Also:: @b{declare}, @ref{declaim} , @ref{proclaim} @node ftype, declaration, inline, Evaluation and Compilation Dictionary @subsection ftype [Declaration] @subsubheading Syntax:: @t{(ftype @i{type} @{@i{function-name}@}*)} @subsubheading Arguments:: @i{function-name}---a @i{function name}. @i{type}---a @i{type specifier}. @subsubheading Valid Context:: @i{declaration} or @i{proclamation} @subsubheading Binding Types Affected:: @i{function} @subsubheading Description:: Specifies that the @i{functions} named by @i{function-names} are of the functional type @i{type}. For example: @example (declare (ftype (function (integer list) t) ith) (ftype (function (number) float) sine cosine)) @end example If one of the @i{functions} mentioned has a lexically apparent local definition (as made by @b{flet} or @b{labels}), then the declaration applies to that local definition and not to the global function definition. @b{ftype} declarations never apply to variable @i{bindings} (see @t{type}). The lexically apparent bindings of @i{function-names} must not be @i{macro} definitions. (This is because @b{ftype} declares the functional definition of each @i{function name} to be of a particular subtype of @b{function}, and @i{macros} do not denote @i{functions}.) @b{ftype} declarations can be @i{free declarations} or @i{bound declarations}. @b{ftype} declarations of functions that appear before the body of a @b{flet} or @b{labels} @i{form} that defines that function are @i{bound declarations}. Such declarations in other contexts are @i{free declarations}. @subsubheading See Also:: @b{declare}, @ref{declaim} , @ref{proclaim} @node declaration, optimize, ftype, Evaluation and Compilation Dictionary @subsection declaration [Declaration] @subsubheading Syntax:: @t{(declaration @{@i{name}@}*)} @subsubheading Arguments:: @i{name}---a @i{symbol}. @subsubheading Valid Context:: @i{proclamation} only @subsubheading Description:: Advises the compiler that each @i{name} is a valid but potentially non-standard declaration name. The purpose of this is to tell one compiler not to issue warnings for declarations meant for another compiler or other program processor. @subsubheading Examples:: @example (declaim (declaration author target-language target-machine)) (declaim (target-language ada)) (declaim (target-machine IBM-650)) (defun strangep (x) (declare (author "Harry Tweeker")) (member x '(strange weird odd peculiar))) @end example @subsubheading See Also:: @ref{declaim} , @ref{proclaim} @node optimize, special, declaration, Evaluation and Compilation Dictionary @subsection optimize [Declaration] @subsubheading Syntax:: @t{(optimize @{@i{quality} | (@i{quality} @i{value})@}*)} @IRindex compilation-speed @IRindex debug @IRindex safety @IRindex space @IRindex speed @subsubheading Arguments:: @i{quality}---an @i{optimize quality}. @i{value}---one of the @i{integers} @t{0}, @t{1}, @t{2}, or @t{3}. @subsubheading Valid Context:: @i{declaration} or @i{proclamation} @subsubheading Description:: Advises the compiler that each @i{quality} should be given attention according to the specified corresponding @i{value}. Each @i{quality} must be a @i{symbol} naming an @i{optimize quality}; the names and meanings of the standard @i{optimize qualities} are shown in Figure 3--25. @format @group @noindent @w{ Name Meaning } @w{ @b{compilation-speed} speed of the compilation process } @w{ @b{debug} ease of debugging } @w{ @b{safety} run-time error checking } @w{ @b{space} both code size and run-time space } @w{ @b{speed} speed of the object code } @noindent @w{ Figure 3--25: Optimize qualities } @end group @end format There may be other, @i{implementation-defined} @i{optimize qualities}. A @i{value} @t{0} means that the corresponding @i{quality} is totally unimportant, and @t{3} that the @i{quality} is extremely important; @t{1} and @t{2} are intermediate values, with @t{1} the neutral value. @t{(@i{quality} 3)} can be abbreviated to @i{quality}. Note that @i{code} which has the optimization @t{(safety 3)}, or just @b{safety}, is called @i{safe} @i{code}. The consequences are unspecified if a @i{quality} appears more than once with @i{different} @i{values}. @subsubheading Examples:: @example (defun often-used-subroutine (x y) (declare (optimize (safety 2))) (error-check x y) (hairy-setup x) (do ((i 0 (+ i 1)) (z x (cdr z))) ((null z)) ;; This inner loop really needs to burn. (declare (optimize speed)) (declare (fixnum i)) )) @end example @subsubheading See Also:: @b{declare}, @ref{declaim} , @ref{proclaim} , @ref{Declaration Scope} @subsubheading Notes:: An @b{optimize} declaration never applies to either a @i{variable} or a @i{function} @i{binding}. An @b{optimize} declaration can only be a @i{free declaration}. For more information, see @ref{Declaration Scope}. @node special, locally, optimize, Evaluation and Compilation Dictionary @subsection special [Declaration] @subsubheading Syntax:: @t{(special @{@i{var}@}*)} @subsubheading Arguments:: @i{var}---a @i{symbol}. @subsubheading Valid Context:: @i{declaration} or @i{proclamation} @subsubheading Binding Types Affected:: @i{variable} @subsubheading Description:: Specifies that all of the @i{vars} named are dynamic. This specifier affects variable @i{bindings} and affects references. All variable @i{bindings} affected are made to be dynamic @i{bindings}, and affected variable references refer to the current dynamic @i{binding}. For example: @example (defun hack (thing *mod*) ;The binding of the parameter (declare (special *mod*)) ; *mod* is visible to hack1, (hack1 (car thing))) ; but not that of thing. (defun hack1 (arg) (declare (special *mod*)) ;Declare references to *mod* ;within hack1 to be special. (if (atom arg) *mod* (cons (hack1 (car arg)) (hack1 (cdr arg))))) @end example A @b{special} declaration does not affect inner @i{bindings} of a @i{var}; the inner @i{bindings} implicitly shadow a @b{special} declaration and must be explicitly re-declared to be @b{special}. @b{special} declarations never apply to function @i{bindings}. @b{special} declarations can be either @i{bound declarations}, affecting both a binding and references, or @i{free declarations}, affecting only references, depending on whether the declaration is attached to a variable binding. When used in a @i{proclamation}, a @b{special} @i{declaration specifier} applies to all @i{bindings} as well as to all references of the mentioned variables. For example, after @example (declaim (special x)) @end example then in a function definition such as @example (defun example (x) ...) @end example the parameter @t{x} is bound as a dynamic variable rather than as a lexical variable. @subsubheading Examples:: @example (defun declare-eg (y) ;this y is special (declare (special y)) (let ((y t)) ;this y is lexical (list y (locally (declare (special y)) y)))) ;this y refers to the ;special binding of y @result{} DECLARE-EG (declare-eg nil) @result{} (T NIL) @end example @example (setf (symbol-value 'x) 6) (defun foo (x) ;a lexical binding of x (print x) (let ((x (1+ x))) ;a special binding of x (declare (special x)) ;and a lexical reference (bar)) (1+ x)) (defun bar () (print (locally (declare (special x)) x))) (foo 10) @t{ |> } 10 @t{ |> } 11 @result{} 11 @end example @example (setf (symbol-value 'x) 6) (defun bar (x y) ;[1] 1st occurrence of x (let ((old-x x) ;[2] 2nd occurrence of x -- same as 1st occurrence (x y)) ;[3] 3rd occurrence of x (declare (special x)) (list old-x x))) (bar 'first 'second) @result{} (FIRST SECOND) @end example @example (defun few (x &optional (y *foo*)) (declare (special *foo*)) ...) @end example The reference to @t{*foo*} in the first line of this example is not @b{special} even though there is a @b{special} declaration in the second line. @example (declaim (special prosp)) @result{} @i{implementation-dependent} (setq prosp 1 reg 1) @result{} 1 (let ((prosp 2) (reg 2)) ;the binding of prosp is special (set 'prosp 3) (set 'reg 3) ;due to the preceding proclamation, (list prosp reg)) ;whereas the variable reg is lexical @result{} (3 2) (list prosp reg) @result{} (1 3) (declaim (special x)) ;x is always special. (defun example (x y) (declare (special y)) (let ((y 3) (x (* x 2))) (print (+ y (locally (declare (special y)) y))) (let ((y 4)) (declare (special y)) (foo x)))) @result{} EXAMPLE @end example In the contorted code above, the outermost and innermost @i{bindings} of @t{y} are dynamic, but the middle binding is lexical. The two arguments to @t{+} are different, one being the value, which is @t{3}, of the lexical variable @t{y}, and the other being the value of the dynamic variable named @t{y} (a @i{binding} of which happens, coincidentally, to lexically surround it at an outer level). All the @i{bindings} of @t{x} and references to @t{x} are dynamic, however, because of the proclamation that @t{x} is always @b{special}. @subsubheading See Also:: @ref{defparameter} , @b{defvar} @node locally, the, special, Evaluation and Compilation Dictionary @subsection locally [Special Operator] @code{locally} @i{@{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{Declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms}. @subsubheading Description:: Sequentially evaluates a body of @i{forms} in a @i{lexical environment} where the given @i{declarations} have effect. @subsubheading Examples:: @example (defun sample-function (y) ;this y is regarded as special (declare (special y)) (let ((y t)) ;this y is regarded as lexical (list y (locally (declare (special y)) ;; this next y is regarded as special y)))) @result{} SAMPLE-FUNCTION (sample-function nil) @result{} (T NIL) (setq x '(1 2 3) y '(4 . 5)) @result{} (4 . 5) ;;; The following declarations are not notably useful in specific. ;;; They just offer a sample of valid declaration syntax using LOCALLY. (locally (declare (inline floor) (notinline car cdr)) (declare (optimize space)) (floor (car x) (cdr y))) @result{} 0, 1 @end example @example ;;; This example shows a definition of a function that has a particular set ;;; of OPTIMIZE settings made locally to that definition. (locally (declare (optimize (safety 3) (space 3) (speed 0))) (defun frob (w x y &optional (z (foo x y))) (mumble x y z w))) @result{} FROB ;;; This is like the previous example, except that the optimize settings ;;; remain in effect for subsequent definitions in the same compilation unit. (declaim (optimize (safety 3) (space 3) (speed 0))) (defun frob (w x y &optional (z (foo x y))) (mumble x y z w)) @result{} FROB @end example @subsubheading See Also:: @b{declare} @subsubheading Notes:: The @b{special} declaration may be used with @b{locally} to affect references to, rather than @i{bindings} of, @i{variables}. If a @b{locally} @i{form} is a @i{top level form}, the body @i{forms} are also processed as @i{top level forms}. See @ref{File Compilation}. @node the, special-operator-p, locally, Evaluation and Compilation Dictionary @subsection the [Special Operator] @code{the} @i{value-type form} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{value-type}---a @i{type specifier}; not evaluated. @i{form}---a @i{form}; evaluated. @i{results}---the @i{values} resulting from the @i{evaluation} of @i{form}. These @i{values} must conform to the @i{type} supplied by @i{value-type}; see below. @subsubheading Description:: @b{the} specifies that the @i{values}_@{1a@} returned by @i{form} are of the @i{types} specified by @i{value-type}. The consequences are undefined if any @i{result} is not of the declared type. It is permissible for @i{form} to @i{yield} a different number of @i{values} than are specified by @i{value-type}, provided that the values for which @i{types} are declared are indeed of those @i{types}. Missing values are treated as @b{nil} for the purposes of checking their @i{types}. Regardless of number of @i{values} declared by @i{value-type}, the number of @i{values} returned by the @b{the} @i{special form} is the same as the number of @i{values} returned by @i{form}. @subsubheading Examples:: @example (the symbol (car (list (gensym)))) @result{} #:G9876 (the fixnum (+ 5 7)) @result{} 12 (the (values) (truncate 3.2 2)) @result{} 1, 1.2 (the integer (truncate 3.2 2)) @result{} 1, 1.2 (the (values integer) (truncate 3.2 2)) @result{} 1, 1.2 (the (values integer float) (truncate 3.2 2)) @result{} 1, 1.2 (the (values integer float symbol) (truncate 3.2 2)) @result{} 1, 1.2 (the (values integer float symbol t null list) (truncate 3.2 2)) @result{} 1, 1.2 (let ((i 100)) (declare (fixnum i)) (the fixnum (1+ i))) @result{} 101 (let* ((x (list 'a 'b 'c)) (y 5)) (setf (the fixnum (car x)) y) x) @result{} (5 B C) @end example @subsubheading Exceptional Situations:: The consequences are undefined if the @i{values} @i{yielded} by the @i{form} are not of the @i{type} specified by @i{value-type}. @subsubheading See Also:: @b{values} @subsubheading Notes:: The @b{values} @i{type specifier} can be used to indicate the types of @i{multiple values}: @example (the (values integer integer) (floor x y)) (the (values string t) (gethash the-key the-string-table)) @end example @b{setf} can be used with @b{the} type declarations. In this case the declaration is transferred to the form that specifies the new value. The resulting @b{setf} @i{form} is then analyzed. @node special-operator-p, constantp, the, Evaluation and Compilation Dictionary @subsection special-operator-p [Function] @code{special-operator-p} @i{symbol} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{symbol} is a @i{special operator}; otherwise, returns @i{false}. @subsubheading Examples:: @example (special-operator-p 'if) @result{} @i{true} (special-operator-p 'car) @result{} @i{false} (special-operator-p 'one) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its argument is not a @i{symbol}. @subsubheading Notes:: Historically, this function was called @t{special-form-p}. The name was finally declared a misnomer and changed, since it returned true for @i{special operators}, not @i{special forms}. @node constantp, , special-operator-p, Evaluation and Compilation Dictionary @subsection constantp [Function] @code{constantp} @i{form @r{&optional} environment} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{form}---a @i{form}. @i{environment}---an @i{environment} @i{object}. The default is @b{nil}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{form} can be determined by the @i{implementation} to be a @i{constant form} in the indicated @i{environment}; otherwise, it returns @i{false} indicating either that the @i{form} is not a @i{constant form} or that it cannot be determined whether or not @i{form} is a @i{constant form}. The following kinds of @i{forms} are considered @i{constant forms}: @table @asis @item @t{*} @i{Self-evaluating objects} (such as @i{numbers}, @i{characters}, and the various kinds of @i{arrays}) are always considered @i{constant forms} and must be recognized as such by @b{constantp}. @item @t{*} @i{Constant variables}, such as @i{keywords}, symbols defined by @r{Common Lisp} as constant (such as @b{nil}, @b{t}, and @b{pi}), and symbols declared as constant by the user in the indicated @i{environment} using @b{defconstant} are always considered @i{constant forms} and must be recognized as such by @b{constantp}. @item @t{*} @b{quote} @i{forms} are always considered @i{constant forms} and must be recognized as such by @b{constantp}. @item @t{*} An @i{implementation} is permitted, but not required, to detect additional @i{constant forms}. If it does, it is also permitted, but not required, to make use of information in the @i{environment}. Examples of @i{constant forms} for which @b{constantp} might or might not return @i{true} are: @t{(sqrt pi)}, @t{(+ 3 2)}, @t{(length '(a b c))}, and @t{(let ((x 7)) (zerop x))}. @end table If an @i{implementation} chooses to make use of the @i{environment} information, such actions as expanding @i{macros} or performing function inlining are permitted to be used, but not required; however, expanding @i{compiler macros} is not permitted. @subsubheading Examples:: @example (constantp 1) @result{} @i{true} (constantp 'temp) @result{} @i{false} (constantp ''temp)) @result{} @i{true} (defconstant this-is-a-constant 'never-changing) @result{} THIS-IS-A-CONSTANT (constantp 'this-is-a-constant) @result{} @i{true} (constantp "temp") @result{} @i{true} (setq a 6) @result{} 6 (constantp a) @result{} @i{true} (constantp '(sin pi)) @result{} @i{implementation-dependent} (constantp '(car '(x))) @result{} @i{implementation-dependent} (constantp '(eql x x)) @result{} @i{implementation-dependent} (constantp '(typep x 'nil)) @result{} @i{implementation-dependent} (constantp '(typep x 't)) @result{} @i{implementation-dependent} (constantp '(values this-is-a-constant)) @result{} @i{implementation-dependent} (constantp '(values 'x 'y)) @result{} @i{implementation-dependent} (constantp '(let ((a '(a b c))) (+ (length a) 6))) @result{} @i{implementation-dependent} @end example @subsubheading Affected By:: The state of the global environment (@i{e.g.}, which @i{symbols} have been declared to be the @i{names} of @i{constant variables}). @subsubheading See Also:: @ref{defconstant} @c end of including dict-eval-compile @c %**end of chapter gcl-2.6.14/info/chap-2.texi0000644000175000017500000030610714360276512013702 0ustar cammcamm @node Syntax, Evaluation and Compilation, Introduction (Introduction), Top @chapter Syntax @menu * Character Syntax:: * Reader Algorithm:: * Interpretation of Tokens:: * Standard Macro Characters:: @end menu @node Character Syntax, Reader Algorithm, Syntax, Syntax @section Character Syntax @c including concept-syntax The @i{Lisp reader} takes @i{characters} from a @i{stream}, interprets them as a printed representation of an @i{object}, constructs that @i{object}, and returns it. The syntax described by this chapter is called the @i{standard syntax} @IGindex standard syntax . Operations are provided by @r{Common Lisp} so that various aspects of the syntax information represented by a @i{readtable} can be modified under program control; see @ref{Reader}. Except as explicitly stated otherwise, the syntax used throughout this document is @i{standard syntax}. @menu * Readtables:: * Variables that affect the Lisp Reader:: * Standard Characters:: * Character Syntax Types:: @end menu @node Readtables, Variables that affect the Lisp Reader, Character Syntax, Character Syntax @subsection Readtables Syntax information for use by the @i{Lisp reader} is embodied in an @i{object} called a @i{readtable} @IGindex readtable . Among other things, the @i{readtable} contains the association between @i{characters} and @i{syntax types}. Figure 2--1 lists some @i{defined names} that are applicable to @i{readtables}. @format @group @noindent @w{ *readtable* readtable-case } @w{ copy-readtable readtablep } @w{ get-dispatch-macro-character set-dispatch-macro-character } @w{ get-macro-character set-macro-character } @w{ make-dispatch-macro-character set-syntax-from-char } @noindent @w{ Figure 2--1: Readtable defined names } @end group @end format @menu * The Current Readtable:: * The Standard Readtable:: * The Initial Readtable:: @end menu @node The Current Readtable, The Standard Readtable, Readtables, Readtables @subsubsection The Current Readtable Several @i{readtables} describing different syntaxes can exist, but at any given time only one, called the @i{current readtable} @IGindex current readtable , affects the way in which @i{expressions}_2 are parsed into @i{objects} by the @i{Lisp reader}. The @i{current readtable} in a given @i{dynamic environment} is the @i{value} of @b{*readtable*} in that @i{environment}. To make a different @i{readtable} become the @i{current readtable}, @b{*readtable*} can be @i{assigned} or @i{bound}. @node The Standard Readtable, The Initial Readtable, The Current Readtable, Readtables @subsubsection The Standard Readtable The @i{standard readtable} @IGindex standard readtable conforms to @i{standard syntax}. The consequences are undefined if an attempt is made to modify the @i{standard readtable}. To achieve the effect of altering or extending @i{standard syntax}, a copy of the @i{standard readtable} can be created; see the @i{function} @b{copy-readtable}. The @i{readtable case} of the @i{standard readtable} is @t{:upcase}. @node The Initial Readtable, , The Standard Readtable, Readtables @subsubsection The Initial Readtable The @i{initial readtable} @IGindex initial readtable is the @i{readtable} that is the @i{current readtable} at the time when the @i{Lisp image} starts. At that time, it conforms to @i{standard syntax}. The @i{initial readtable} is @i{distinct} from the @i{standard readtable}. It is permissible for a @i{conforming program} to modify the @i{initial readtable}. @node Variables that affect the Lisp Reader, Standard Characters, Readtables, Character Syntax @subsection Variables that affect the Lisp Reader The @i{Lisp reader} is influenced not only by the @i{current readtable}, but also by various @i{dynamic variables}. Figure 2--2 lists the @i{variables} that influence the behavior of the @i{Lisp reader}. @format @group @noindent @w{ *package* *read-default-float-format* *readtable* } @w{ *read-base* *read-suppress* } @noindent @w{ Figure 2--2: Variables that influence the Lisp reader. } @end group @end format @node Standard Characters, Character Syntax Types, Variables that affect the Lisp Reader, Character Syntax @subsection Standard Characters All @i{implementations} must support a @i{character} @i{repertoire} called @b{standard-char}; @i{characters} that are members of that @i{repertoire} are called @i{standard characters} @IGindex standard character . The @b{standard-char} @i{repertoire} consists of the @i{non-graphic} @i{character} @i{newline}, the @i{graphic} @i{character} @i{space}, and the following additional ninety-four @i{graphic} @i{characters} or their equivalents: @format @group @noindent @w{ Graphic ID Glyph Description Graphic ID Glyph Description } @w{ LA01 @t{a} small a LN01 @t{n} small n } @w{ LA02 @t{A} capital A LN02 @t{N} capital N } @w{ LB01 @t{b} small b LO01 @t{o} small o } @w{ LB02 @t{B} capital B LO02 @t{O} capital O } @w{ LC01 @t{c} small c LP01 @t{p} small p } @w{ LC02 @t{C} capital C LP02 @t{P} capital P } @w{ LD01 @t{d} small d LQ01 @t{q} small q } @w{ LD02 @t{D} capital D LQ02 @t{Q} capital Q } @w{ LE01 @t{e} small e LR01 @t{r} small r } @w{ LE02 @t{E} capital E LR02 @t{R} capital R } @w{ LF01 @t{f} small f LS01 @t{s} small s } @w{ LF02 @t{F} capital F LS02 @t{S} capital S } @w{ LG01 @t{g} small g LT01 @t{t} small t } @w{ LG02 @t{G} capital G LT02 @t{T} capital T } @w{ LH01 @t{h} small h LU01 @t{u} small u } @w{ LH02 @t{H} capital H LU02 @t{U} capital U } @w{ LI01 @t{i} small i LV01 @t{v} small v } @w{ LI02 @t{I} capital I LV02 @t{V} capital V } @w{ LJ01 @t{j} small j LW01 @t{w} small w } @w{ LJ02 @t{J} capital J LW02 @t{W} capital W } @w{ LK01 @t{k} small k LX01 @t{x} small x } @w{ LK02 @t{K} capital K LX02 @t{X} capital X } @w{ LL01 @t{l} small l LY01 @t{y} small y } @w{ LL02 @t{L} capital L LY02 @t{Y} capital Y } @w{ LM01 @t{m} small m LZ01 @t{z} small z } @w{ LM02 @t{M} capital M LZ02 @t{Z} capital Z } @noindent @w{ Figure 2--3: Standard Character Subrepertoire (Part 1 of 3: Latin Characters)} @end group @end format @format @group @noindent @w{ Graphic ID Glyph Description Graphic ID Glyph Description } @w{ ND01 @t{1} digit 1 ND06 @t{6} digit 6 } @w{ ND02 @t{2} digit 2 ND07 @t{7} digit 7 } @w{ ND03 @t{3} digit 3 ND08 @t{8} digit 8 } @w{ ND04 @t{4} digit 4 ND09 @t{9} digit 9 } @w{ ND05 @t{5} digit 5 ND10 @t{0} digit 0 } @noindent @w{ Figure 2--4: Standard Character Subrepertoire (Part 2 of 3: Numeric Characters)} @end group @end format @format @group @noindent @w{ Graphic ID Glyph Description } @w{ SP02 @t{!} exclamation mark } @w{ SC03 @t{$} dollar sign } @w{ SP04 @t{"} quotation mark, or double quote } @w{ SP05 @t{'} apostrophe, or @r{[}single@r{]} quote } @w{ SP06 @t{(} left parenthesis, or open parenthesis } @w{ SP07 @t{)} right parenthesis, or close parenthesis } @w{ SP08 @t{,} comma } @w{ SP09 @t{_} low line, or underscore } @w{ SP10 @t{-} hyphen, or minus @r{[}sign@r{]} } @w{ SP11 @t{.} full stop, period, or dot } @w{ SP12 @t{/} solidus, or slash } @w{ SP13 @t{:} colon } @w{ SP14 @t{;} semicolon } @w{ SP15 @t{?} question mark } @w{ SA01 @t{+} plus @r{[}sign@r{]} } @w{ SA03 @t{<} less-than @r{[}sign@r{]} } @w{ SA04 @t{=} equals @r{[}sign@r{]} } @w{ SA05 @t{>} greater-than @r{[}sign@r{]} } @w{ SM01 @t{#} number sign, or sharp@r{[}sign@r{]} } @w{ SM02 @t{%} percent @r{[}sign@r{]} } @w{ SM03 @t{&} ampersand } @w{ SM04 @t{*} asterisk, or star } @w{ SM05 @t{@@} commercial at, or at-sign } @w{ SM06 @t{[} left @r{[}square@r{]} bracket } @w{ SM07 @t{\} reverse solidus, or backslash } @w{ SM08 @t{]} right @r{[}square@r{]} bracket } @w{ SM11 @t{@{} left curly bracket, or left brace } @w{ SM13 @t{|} vertical bar } @w{ SM14 @t{@}} right curly bracket, or right brace } @w{ SD13 @t{`} grave accent, or backquote } @w{ SD15 @t{@t{^}} circumflex accent } @w{ SD19 @t{~} tilde } @noindent @w{ Figure 2--5: Standard Character Subrepertoire (Part 3 of 3: Special Characters)} @end group @end format The graphic IDs are not used within @r{Common Lisp}, but are provided for cross reference purposes with @r{ISO 6937/2}. Note that the first letter of the graphic ID categorizes the character as follows: L---Latin, N---Numeric, S---Special. @node Character Syntax Types, , Standard Characters, Character Syntax @subsection Character Syntax Types The @i{Lisp reader} constructs an @i{object} from the input text by interpreting each @i{character} according to its @i{syntax type}. The @i{Lisp reader} cannot accept as input everything that the @i{Lisp printer} produces, and the @i{Lisp reader} has features that are not used by the @i{Lisp printer}. The @i{Lisp reader} can be used as a lexical analyzer for a more general user-written parser. When the @i{Lisp reader} is invoked, it reads a single character from the @i{input} @i{stream} and dispatches according to the @i{syntax type} @IGindex syntax type of that @i{character}. Every @i{character} that can appear in the @i{input} @i{stream} is of one of the @i{syntax types} shown in @i{Figure~2--6}. @format @group @noindent @w{ @i{constituent} @i{macro character} @i{single escape} } @w{ @i{invalid} @i{multiple escape} @i{whitespace}_2 } @noindent @w{ Figure 2--6: Possible Character Syntax Types } @end group @end format The @i{syntax type} of a @i{character} in a @i{readtable} determines how that character is interpreted by the @i{Lisp reader} while that @i{readtable} is the @i{current readtable}. At any given time, every character has exactly one @i{syntax type}. @i{Figure~2--7} lists the @i{syntax type} of each @i{character} in @i{standard syntax}. @format @group @noindent @w{ character syntax type character syntax type } @w{ Backspace @i{constituent} 0--9 @i{constituent} } @w{ Tab @i{whitespace}_2 : @i{constituent} } @w{ Newline @i{whitespace}_2 ; @i{terminating} @i{macro char} } @w{ Linefeed @i{whitespace}_2 @t{<} @i{constituent} } @w{ Page @i{whitespace}_2 = @i{constituent} } @w{ Return @i{whitespace}_2 @t{>} @i{constituent} } @w{ Space @i{whitespace}_2 ? @i{constituent}* } @w{ ! @i{constituent}* @t{@@} @i{constituent} } @w{ @t{"} @i{terminating} @i{macro char} A--Z @i{constituent} } @w{ # @i{non-terminating} @i{macro char} @t{[} @i{constituent}* } @w{ $ @i{constituent} @t{\} @i{single escape} } @w{ % @i{constituent} @t{]} @i{constituent}* } @w{ & @i{constituent} @t{^} @i{constituent} } @w{ ' @i{terminating} @i{macro char} @t{_} @i{constituent} } @w{ ( @i{terminating} @i{macro char} ` @i{terminating} @i{macro char} } @w{ ) @i{terminating} @i{macro char} a--z @i{constituent} } @w{ @t{*} @i{constituent} @t{@{} @i{constituent}* } @w{ + @i{constituent} @t{|} @i{multiple escape} } @w{ , @i{terminating} @i{macro char} @t{@}} @i{constituent}* } @w{ - @i{constituent} @t{~} @i{constituent} } @w{ . @i{constituent} Rubout @i{constituent} } @w{ / @i{constituent} } @noindent @w{ Figure 2--7: Character Syntax Types in Standard Syntax } @end group @end format The characters marked with an asterisk (*) are initially @i{constituents}, but they are not used in any standard @r{Common Lisp} notations. These characters are explicitly reserved to the @i{programmer}. @t{~} is not used in @r{Common Lisp}, and reserved to implementors. @t{$} and @t{%} are @i{alphabetic}_2 @i{characters}, but are not used in the names of any standard @r{Common Lisp} @i{defined names}. @i{Whitespace}_2 characters serve as separators but are otherwise ignored. @i{Constituent} and @i{escape} @i{characters} are accumulated to make a @i{token}, which is then interpreted as a @i{number} or @i{symbol}. @i{Macro characters} trigger the invocation of @i{functions} (possibly user-supplied) that can perform arbitrary parsing actions. @i{Macro characters} are divided into two kinds, @i{terminating} and @i{non-terminating}, depending on whether or not they terminate a @i{token}. The following are descriptions of each kind of @i{syntax type}. @menu * Constituent Characters:: * Constituent Traits:: * Invalid Characters:: * Macro Characters:: * Multiple Escape Characters:: * Examples of Multiple Escape Characters:: * Single Escape Character:: * Examples of Single Escape Characters:: * Whitespace Characters:: * Examples of Whitespace Characters:: @end menu @node Constituent Characters, Constituent Traits, Character Syntax Types, Character Syntax Types @subsubsection Constituent Characters @i{Constituent} @i{characters} are used in @i{tokens}. A @i{token} @IGindex token is a representation of a @i{number} or a @i{symbol}. Examples of @i{constituent} @i{characters} are letters and digits. Letters in symbol names are sometimes converted to letters in the opposite @i{case} when the name is read; see @ref{Effect of Readtable Case on the Lisp Reader}. @i{Case} conversion can be suppressed by the use of @i{single escape} or @i{multiple escape} characters. @node Constituent Traits, Invalid Characters, Constituent Characters, Character Syntax Types @subsubsection Constituent Traits Every @i{character} has one or more @i{constituent traits} that define how the @i{character} is to be interpreted by the @i{Lisp reader} when the @i{character} is a @i{constituent} @i{character}. These @i{constituent traits} are @i{alphabetic}_2, digit, @i{package marker}, plus sign, minus sign, dot, decimal point, @i{ratio marker}, @i{exponent marker}, and @i{invalid}. @i{Figure~2--8} shows the @i{constituent traits} of the @i{standard characters} and of certain @i{semi-standard} @i{characters}; no mechanism is provided for changing the @i{constituent trait} of a @i{character}. Any @i{character} with the alphadigit @i{constituent trait} in that figure is a digit if the @i{current input base} is greater than that character's digit value, otherwise the @i{character} is @i{alphabetic}_2. Any @i{character} quoted by a @i{single escape} is treated as an @i{alphabetic}_2 constituent, regardless of its normal syntax. @format @group @noindent @w{ constituent traits constituent traits } @w{ character character } @w{ ________________________________________________________________________________} @w{ Backspace @i{invalid} @t{@{} @i{alphabetic}_2 } @w{ Tab @i{invalid}* @t{@}} @i{alphabetic}_2 } @w{ Newline @i{invalid}* + @i{alphabetic}_2, plus sign } @w{ Linefeed @i{invalid}* - @i{alphabetic}_2, minus sign } @w{ Page @i{invalid}* . @i{alphabetic}_2, dot, decimal point } @w{ Return @i{invalid}* / @i{alphabetic}_2, @i{ratio marker} } @w{ Space @i{invalid}* A, a alphadigit } @w{ ! @i{alphabetic}_2 B, b alphadigit } @w{ @t{"} @i{alphabetic}_2* C, c alphadigit } @w{ # @i{alphabetic}_2* D, d alphadigit, double-float @i{exponent marker} } @w{ $ @i{alphabetic}_2 E, e alphadigit, float @i{exponent marker} } @w{ % @i{alphabetic}_2 F, f alphadigit, single-float @i{exponent marker} } @w{ & @i{alphabetic}_2 G, g alphadigit } @w{ ' @i{alphabetic}_2* H, h alphadigit } @w{ ( @i{alphabetic}_2* I, i alphadigit } @w{ ) @i{alphabetic}_2* J, j alphadigit } @w{ @t{*} @i{alphabetic}_2 K, k alphadigit } @w{ , @i{alphabetic}_2* L, l alphadigit, long-float @i{exponent marker} } @w{ 0-9 alphadigit M, m alphadigit } @w{ : @i{package marker} N, n alphadigit } @w{ ; @i{alphabetic}_2* O, o alphadigit } @w{ @t{<} @i{alphabetic}_2 P, p alphadigit } @w{ = @i{alphabetic}_2 Q, q alphadigit } @w{ @t{>} @i{alphabetic}_2 R, r alphadigit } @w{ ? @i{alphabetic}_2 S, s alphadigit, short-float @i{exponent marker} } @w{ @t{@@} @i{alphabetic}_2 T, t alphadigit } @w{ @t{[} @i{alphabetic}_2 U, u alphadigit } @w{ @t{\} @i{alphabetic}_2* V, v alphadigit } @w{ @t{]} @i{alphabetic}_2 W, w alphadigit } @w{ @t{^} @i{alphabetic}_2 X, x alphadigit } @w{ @t{_} @i{alphabetic}_2 Y, y alphadigit } @w{ ` @i{alphabetic}_2* Z, z alphadigit } @w{ @t{|} @i{alphabetic}_2* Rubout @i{invalid} } @w{ @t{~} @i{alphabetic}_2 } @end group @end format @w{ Figure 2--8: Constituent Traits of Standard Characters and Semi-Standard Characters} The interpretations in this table apply only to @i{characters} whose @i{syntax type} is @i{constituent}. Entries marked with an asterisk (*) are normally @i{shadowed}_2 because the indicated @i{characters} are of @i{syntax type} @i{whitespace}_2, @i{macro character}, @i{single escape}, or @i{multiple escape}; these @i{constituent traits} apply to them only if their @i{syntax types} are changed to @i{constituent}. @node Invalid Characters, Macro Characters, Constituent Traits, Character Syntax Types @subsubsection Invalid Characters @i{Characters} with the @i{constituent trait} @i{invalid} cannot ever appear in a @i{token} except under the control of a @i{single escape} @i{character}. If an @i{invalid} @i{character} is encountered while an @i{object} is being read, an error of @i{type} @b{reader-error} is signaled. If an @i{invalid} @i{character} is preceded by a @i{single escape} @i{character}, it is treated as an @i{alphabetic}_2 @i{constituent} instead. @node Macro Characters, Multiple Escape Characters, Invalid Characters, Character Syntax Types @subsubsection Macro Characters When the @i{Lisp reader} encounters a @i{macro character} on an @i{input} @i{stream}, special parsing of subsequent @i{characters} on the @i{input} @i{stream} is performed. A @i{macro character} has an associated @i{function} called a @i{reader macro function} @IGindex reader macro function that implements its specialized parsing behavior. An association of this kind can be established or modified under control of a @i{conforming program} by using the @i{functions} @b{set-macro-character} and @b{set-dispatch-macro-character}. Upon encountering a @i{macro character}, the @i{Lisp reader} calls its @i{reader macro function}, which parses one specially formatted object from the @i{input} @i{stream}. The @i{function} either returns the parsed @i{object}, or else it returns no @i{values} to indicate that the characters scanned by the @i{function} are being ignored (@i{e.g.}, in the case of a comment). Examples of @i{macro characters} are @i{backquote}, @i{single-quote}, @i{left-parenthesis}, and @i{right-parenthesis}. A @i{macro character} is either @i{terminating} or @i{non-terminating}. The difference between @i{terminating} and @i{non-terminating} @i{macro characters} lies in what happens when such characters occur in the middle of a @i{token}. If a @i{non-terminating} @IGindex non-terminating @i{macro character} occurs in the middle of a @i{token}, the @i{function} associated with the @i{non-terminating} @i{macro character} is not called, and the @i{non-terminating} @i{macro character} does not terminate the @i{token}'s name; it becomes part of the name as if the @i{macro character} were really a constituent character. A @i{terminating} @IGindex terminating @i{macro character} terminates any @i{token}, and its associated @i{reader macro function} is called no matter where the @i{character} appears. The only @i{non-terminating} @i{macro character} in @i{standard syntax} is @i{sharpsign}. If a @i{character} is a @i{dispatching macro character} C_1, its @i{reader macro function} is a @i{function} supplied by the @i{implementation}. This @i{function} reads decimal @i{digit} @i{characters} until a non-@i{digit} C_2 is read. If any @i{digits} were read, they are converted into a corresponding @i{integer} infix parameter P; otherwise, the infix parameter P is @b{nil}. The terminating non-@i{digit} C_2 is a @i{character} (sometimes called a ``sub-character'' to emphasize its subordinate role in the dispatching) that is looked up in the dispatch table associated with the @i{dispatching macro character} C_1. The @i{reader macro function} associated with the sub-character C_2 is invoked with three arguments: the @i{stream}, the sub-character C_2, and the infix parameter P. For more information about dispatch characters, see the @i{function} @b{set-dispatch-macro-character}. For information about the @i{macro characters} that are available in @i{standard syntax}, see @ref{Standard Macro Characters}. @node Multiple Escape Characters, Examples of Multiple Escape Characters, Macro Characters, Character Syntax Types @subsubsection Multiple Escape Characters A pair of @i{multiple escape} @IGindex multiple escape @i{characters} is used to indicate that an enclosed sequence of characters, including possible @i{macro characters} and @i{whitespace}_2 @i{characters}, are to be treated as @i{alphabetic}_2 @i{characters} with @i{case} preserved. Any @i{single escape} and @i{multiple escape} @i{characters} that are to appear in the sequence must be preceded by a @i{single escape} @i{character}. @i{Vertical-bar} is a @i{multiple escape} @i{character} in @i{standard syntax}. @node Examples of Multiple Escape Characters, Single Escape Character, Multiple Escape Characters, Character Syntax Types @subsubsection Examples of Multiple Escape Characters @example ;; The following examples assume the readtable case of *readtable* ;; and *print-case* are both :upcase. (eq 'abc 'ABC) @result{} @i{true} (eq 'abc '|ABC|) @result{} @i{true} (eq 'abc 'a|B|c) @result{} @i{true} (eq 'abc '|abc|) @result{} @i{false} @end example @node Single Escape Character, Examples of Single Escape Characters, Examples of Multiple Escape Characters, Character Syntax Types @subsubsection Single Escape Character A @i{single escape} @IGindex single escape is used to indicate that the next @i{character} is to be treated as an @i{alphabetic}_2 @i{character} with its @i{case} preserved, no matter what the @i{character} is or which @i{constituent traits} it has. @i{Slash} is a @i{single escape} @i{character} in @i{standard syntax}. @node Examples of Single Escape Characters, Whitespace Characters, Single Escape Character, Character Syntax Types @subsubsection Examples of Single Escape Characters @example ;; The following examples assume the readtable case of *readtable* ;; and *print-case* are both :upcase. (eq 'abc '\A\B\C) @result{} @i{true} (eq 'abc 'a\Bc) @result{} @i{true} (eq 'abc '\ABC) @result{} @i{true} (eq 'abc '\abc) @result{} @i{false} @end example @node Whitespace Characters, Examples of Whitespace Characters, Examples of Single Escape Characters, Character Syntax Types @subsubsection Whitespace Characters @i{Whitespace}_2 @i{characters} are used to separate @i{tokens}. @i{Space} and @i{newline} are @i{whitespace}_2 @i{characters} in @i{standard syntax}. @node Examples of Whitespace Characters, , Whitespace Characters, Character Syntax Types @subsubsection Examples of Whitespace Characters @example (length '(this-that)) @result{} 1 (length '(this - that)) @result{} 3 (length '(a b)) @result{} 2 (+ 34) @result{} 34 (+ 3 4) @result{} 7 @end example @c end of including concept-syntax @node Reader Algorithm, Interpretation of Tokens, Character Syntax, Syntax @section Reader Algorithm @c including concept-reader-algorithm This section describes the algorithm used by the @i{Lisp reader} to parse @i{objects} from an @i{input} @i{character} @i{stream}, including how the @i{Lisp reader} processes @i{macro characters}. When dealing with @i{tokens}, the reader's basic function is to distinguish representations of @i{symbols} from those of @i{numbers}. When a @i{token} is accumulated, it is assumed to represent a @i{number} if it satisfies the syntax for numbers listed in @i{Figure~2--9}. If it does not represent a @i{number}, it is then assumed to be a @i{potential number} if it satisfies the rules governing the syntax for a @i{potential number}. If a valid @i{token} is neither a representation of a @i{number} nor a @i{potential number}, it represents a @i{symbol}. The algorithm performed by the @i{Lisp reader} is as follows: @table @asis @item 1. If at end of file, end-of-file processing is performed as specified in @b{read}. Otherwise, one @i{character}, @i{x}, is read from the @i{input} @i{stream}, and dispatched according to the @i{syntax type} of @i{x} to one of steps 2 to 7. @item 2. If @i{x} is an @i{invalid} @i{character}, an error of @i{type} @b{reader-error} is signaled. @item 3. If @i{x} is a @i{whitespace}_2 @i{character}, then it is discarded and step 1 is re-entered. @item 4. If @i{x} is a @i{terminating} or @i{non-terminating} @i{macro character} then its associated @i{reader macro function} is called with two @i{arguments}, the @i{input} @i{stream} and @i{x}. The @i{reader macro function} may read @i{characters} from the @i{input} @i{stream}; if it does, it will see those @i{characters} following the @i{macro character}. The @i{Lisp reader} may be invoked recursively from the @i{reader macro function}. The @i{reader macro function} must not have any side effects other than on the @i{input} @i{stream}; because of backtracking and restarting of the @b{read} operation, front ends to the @i{Lisp reader} (@i{e.g.}, ``editors'' and ``rubout handlers'') may cause the @i{reader macro function} to be called repeatedly during the reading of a single @i{expression} in which @i{x} only appears once. The @i{reader macro function} may return zero values or one value. If one value is returned, then that value is returned as the result of the read operation; the algorithm is done. If zero values are returned, then step 1 is re-entered. @item 5. If @i{x} is a @i{single escape} @i{character} then the next @i{character}, @i{y}, is read, or an error of @i{type} @b{end-of-file} is signaled if at the end of file. @i{y} is treated as if it is a @i{constituent} whose only @i{constituent trait} is @i{alphabetic}_2. @i{y} is used to begin a @i{token}, and step 8 is entered. @item 6. If @i{x} is a @i{multiple escape} @i{character} then a @i{token} (initially containing no @i{characters}) is begun and step 9 is entered. @item 7. If @i{x} is a @i{constituent} @i{character}, then it begins a @i{token}. After the @i{token} is read in, it will be interpreted either as a @r{Lisp} @i{object} or as being of invalid syntax. If the @i{token} represents an @i{object}, that @i{object} is returned as the result of the read operation. If the @i{token} is of invalid syntax, an error is signaled. If @i{x} is a @i{character} with @i{case}, it might be replaced with the corresponding @i{character} of the opposite @i{case}, depending on the @i{readtable case} of the @i{current readtable}, as outlined in @ref{Effect of Readtable Case on the Lisp Reader}. @i{X} is used to begin a @i{token}, and step 8 is entered. @item 8. At this point a @i{token} is being accumulated, and an even number of @i{multiple escape} @i{characters} have been encountered. If at end of file, step 10 is entered. Otherwise, a @i{character}, @i{y}, is read, and one of the following actions is performed according to its @i{syntax type}: @table @asis @item @t{*} If @i{y} is a @i{constituent} or @i{non-terminating} @i{macro character}: @table @asis @item -- If @i{y} is a @i{character} with @i{case}, it might be replaced with the corresponding @i{character} of the opposite @i{case}, depending on the @i{readtable case} of the @i{current readtable}, as outlined in @ref{Effect of Readtable Case on the Lisp Reader}. @item -- @i{Y} is appended to the @i{token} being built. @item -- Step 8 is repeated. @end table @item @t{*} If @i{y} is a @i{single escape} @i{character}, then the next @i{character}, @i{z}, is read, or an error of @i{type} @b{end-of-file} is signaled if at end of file. @i{Z} is treated as if it is a @i{constituent} whose only @i{constituent trait} is @i{alphabetic}_2. @i{Z} is appended to the @i{token} being built, and step 8 is repeated. @item @t{*} If @i{y} is a @i{multiple escape} @i{character}, then step 9 is entered. @item @t{*} If @i{y} is an @i{invalid} @i{character}, an error of @i{type} @b{reader-error} is signaled. @item @t{*} If @i{y} is a @i{terminating} @i{macro character}, then it terminates the @i{token}. First the @i{character} @i{y} is unread (see @b{unread-char}), and then step 10 is entered. @item @t{*} If @i{y} is a @i{whitespace}_2 @i{character}, then it terminates the @i{token}. First the @i{character} @i{y} is unread if appropriate (see @b{read-preserving-whitespace}), and then step 10 is entered. @end table @item 9. At this point a @i{token} is being accumulated, and an odd number of @i{multiple escape} @i{characters} have been encountered. If at end of file, an error of @i{type} @b{end-of-file} is signaled. Otherwise, a @i{character}, @i{y}, is read, and one of the following actions is performed according to its @i{syntax type}: @table @asis @item @t{*} If @i{y} is a @i{constituent}, macro, or @i{whitespace}_2 @i{character}, @i{y} is treated as a @i{constituent} whose only @i{constituent trait} is @i{alphabetic}_2. @i{Y} is appended to the @i{token} being built, and step 9 is repeated. @item @t{*} If @i{y} is a @i{single escape} @i{character}, then the next @i{character}, @i{z}, is read, or an error of @i{type} @b{end-of-file} is signaled if at end of file. @i{Z} is treated as a @i{constituent} whose only @i{constituent trait} is @i{alphabetic}_2. @i{Z} is appended to the @i{token} being built, and step 9 is repeated. @item @t{*} If @i{y} is a @i{multiple escape} @i{character}, then step 8 is entered. @item @t{*} If @i{y} is an @i{invalid} @i{character}, an error of @i{type} @b{reader-error} is signaled. @end table @item 10. An entire @i{token} has been accumulated. The @i{object} represented by the @i{token} is returned as the result of the read operation, or an error of @i{type} @b{reader-error} is signaled if the @i{token} is not of valid syntax. @end table @c end of including concept-reader-algorithm @node Interpretation of Tokens, Standard Macro Characters, Reader Algorithm, Syntax @section Interpretation of Tokens @c including concept-tokens @menu * Numbers as Tokens:: * Constructing Numbers from Tokens:: * The Consing Dot:: * Symbols as Tokens:: * Valid Patterns for Tokens:: * Package System Consistency Rules:: @end menu @node Numbers as Tokens, Constructing Numbers from Tokens, Interpretation of Tokens, Interpretation of Tokens @subsection Numbers as Tokens When a @i{token} is read, it is interpreted as a @i{number} or @i{symbol}. The @i{token} is interpreted as a @i{number} if it satisfies the syntax for numbers specified in Figure 2--9. @format @group @noindent @w{ @i{numeric-token} ::= !@i{integer} | !@i{ratio} | !@i{float} } @w{ @i{integer} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @i{decimal-point} | @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } @w{ @i{ratio} ::= @t{[}@i{sign}@t{]} @{@i{digit}@}^+ @i{slash} @{@i{digit}@}^+ } @w{ @i{float} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}* @i{decimal-point} @{@i{decimal-digit}@}^+ @t{[}!@i{exponent}@t{]} } @w{ | @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @t{[}@i{decimal-point} @{@i{decimal-digit}@}*@t{]} !@i{exponent} } @w{ @i{exponent} ::= @i{exponent-marker} @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } @w{ @i{sign}---a @i{sign}.} @w{ @i{slash}---a @i{slash}} @w{ @i{decimal-point}---a @i{dot}.} @w{ @i{exponent-marker}---an @i{exponent marker}.} @w{ @i{decimal-digit}---a @i{digit} in @i{radix} @t{10}.} @w{ @i{digit}---a @i{digit} in the @i{current input radix}.} @end group @end format @w{ Figure 2--9: Syntax for Numeric Tokens} @menu * Potential Numbers as Tokens:: * Escape Characters and Potential Numbers:: * Examples of Potential Numbers:: @end menu @node Potential Numbers as Tokens, Escape Characters and Potential Numbers, Numbers as Tokens, Numbers as Tokens @subsubsection Potential Numbers as Tokens To allow implementors and future @r{Common Lisp} standards to extend the syntax of numbers, a syntax for @i{potential numbers} is defined that is more general than the syntax for numbers. A @i{token} is a @i{potential number} if it satisfies all of the following requirements: @table @asis @item 1. The @i{token} consists entirely of @i{digits}, @i{signs}, @i{ratio markers}, decimal points (@t{.}), extension characters (@t{^} or @t{_}), and number markers. A number marker is a letter. Whether a letter may be treated as a number marker depends on context, but no letter that is adjacent to another letter may ever be treated as a number marker. @i{Exponent markers} are number markers. @item 2. The @i{token} contains at least one digit. Letters may be considered to be digits, depending on the @i{current input base}, but only in @i{tokens} containing no decimal points. @item 3. The @i{token} begins with a @i{digit}, @i{sign}, decimal point, or extension character, [Reviewer Note by Barmar: This section is unnecessary because the first bullet already omits discussion of a colon (@i{package marker}).] but not a @i{package marker}. The syntax involving a leading @i{package marker} followed by a @i{potential number} is not well-defined. The consequences of the use of notation such as @t{:1}, @t{:1/2}, and @t{:2^3} in a position where an expression appropriate for @b{read} is expected are unspecified. @item 4. The @i{token} does not end with a sign. @end table If a @i{potential number} has number syntax, a @i{number} of the appropriate type is constructed and returned, if the @i{number} is representable in an implementation. A @i{number} will not be representable in an implementation if it is outside the boundaries set by the @i{implementation-dependent} constants for @i{numbers}. For example, specifying too large or too small an exponent for a @i{float} may make the @i{number} impossible to represent in the implementation. A @i{ratio} with denominator zero (such as @t{-35/000}) is not represented in any implementation. When a @i{token} with the syntax of a number cannot be converted to an internal @i{number}, an error of @i{type} @b{reader-error} is signaled. An error must not be signaled for specifying too many significant digits for a @i{float}; a truncated or rounded value should be produced. If there is an ambiguity as to whether a letter should be treated as a digit or as a number marker, the letter is treated as a digit. @node Escape Characters and Potential Numbers, Examples of Potential Numbers, Potential Numbers as Tokens, Numbers as Tokens @subsubsection Escape Characters and Potential Numbers A @i{potential number} cannot contain any @i{escape} @i{characters}. An @i{escape} @i{character} robs the following @i{character} of all syntactic qualities, forcing it to be strictly @i{alphabetic}_2 and therefore unsuitable for use in a @i{potential number}. For example, all of the following representations are interpreted as @i{symbols}, not @i{numbers}: @example \256 25\64 1.0\E6 |100| 3\.14159 |3/4| 3\/4 5|| @end example In each case, removing the @i{escape} @i{character} (or @i{characters}) would cause the token to be a @i{potential number}. @node Examples of Potential Numbers, , Escape Characters and Potential Numbers, Numbers as Tokens @subsubsection Examples of Potential Numbers As examples, the @i{tokens} in Figure 2--10 are @i{potential numbers}, but they are not actually numbers, and so are reserved @i{tokens}; a @i{conforming implementation} is permitted, but not required, to define their meaning. @format @group @noindent @w{ @t{1b5000} @t{777777q} @t{1.7J} @t{-3/4+6.7J} @t{12/25/83} } @w{ @t{27^19} @t{3^4/5} @t{6//7} @t{3.1.2.6} @t{@t{^}-43@t{^}} } @w{ @t{3.141_592_653_589_793_238_4} @t{-3.7+2.6i-6.17j+19.6k} } @noindent @w{ Figure 2--10: Examples of reserved tokens } @end group @end format The @i{tokens} in Figure 2--11 are not @i{potential numbers}; they are always treated as @i{symbols}: @format @group @noindent @w{ @t{/} @t{/5} @t{+} @t{1+} @t{1-} } @w{ @t{foo+} @t{ab.cd} @t{_} @t{@t{^}} @t{@t{^}/-} } @noindent @w{ Figure 2--11: Examples of symbols} @end group @end format The @i{tokens} in Figure 2--12 are @i{potential numbers} if the @i{current input base} is @t{16}, but they are always treated as @i{symbols} if the @i{current input base} is @t{10}. @format @group @noindent @w{ @t{bad-face} @t{25-dec-83} @t{a/b} @t{fad_cafe} @t{f@t{^}} } @noindent @w{ Figure 2--12: Examples of symbols or potential numbers} @end group @end format @node Constructing Numbers from Tokens, The Consing Dot, Numbers as Tokens, Interpretation of Tokens @subsection Constructing Numbers from Tokens A @i{real} is constructed directly from a corresponding numeric @i{token}; see @i{Figure~2--9}. A @i{complex} is notated as a @t{#C} (or @t{#c}) followed by a @i{list} of two @i{reals}; see @ref{Sharpsign C}. The @i{reader macros} @t{#B}, @t{#O}, @t{#X}, and @t{#R} may also be useful in controlling the input @i{radix} in which @i{rationals} are parsed; see @ref{Sharpsign B}, @ref{Sharpsign O}, @ref{Sharpsign X}, and @ref{Sharpsign R}. This section summarizes the full syntax for @i{numbers}. @menu * Syntax of a Rational:: * Syntax of an Integer:: * Syntax of a Ratio:: * Syntax of a Float:: * Syntax of a Complex:: @end menu @node Syntax of a Rational, Syntax of an Integer, Constructing Numbers from Tokens, Constructing Numbers from Tokens @subsubsection Syntax of a Rational @node Syntax of an Integer, Syntax of a Ratio, Syntax of a Rational, Constructing Numbers from Tokens @subsubsection Syntax of an Integer @i{Integers} can be written as a sequence of @i{digits}, optionally preceded by a @i{sign} and optionally followed by a decimal point; see @i{Figure~2--9}. When a decimal point is used, the @i{digits} are taken to be in @i{radix} @t{10}; when no decimal point is used, the @i{digits} are taken to be in radix given by the @i{current input base}. For information on how @i{integers} are printed, see @ref{Printing Integers}. @node Syntax of a Ratio, Syntax of a Float, Syntax of an Integer, Constructing Numbers from Tokens @subsubsection Syntax of a Ratio @i{Ratios} can be written as an optional @i{sign} followed by two non-empty sequences of @i{digits} separated by a @i{slash}; see @i{Figure~2--9}. The second sequence may not consist entirely of zeros. Examples of @i{ratios} are in Figure 2--13. @format @group @noindent @w{ @t{2/3} ;This is in canonical form } @w{ @t{4/6} ;A non-canonical form for 2/3 } @w{ @t{-17/23} ;A ratio preceded by a sign } @w{ @t{-30517578125/32768} ;This is (-5/2)^15 } @w{ @t{10/5} ;The canonical form for this is @t{2} } @w{ @t{#o-101/75} ;Octal notation for -65/61 } @w{ @t{#3r120/21} ;Ternary notation for 15/7 } @w{ @t{#Xbc/ad} ;Hexadecimal notation for 188/173 } @w{ @t{#xFADED/FACADE} ;Hexadecimal notation for 1027565/16435934 } @noindent @w{ Figure 2--13: Examples of Ratios } @end group @end format [Reviewer Note by Barmar: #o, #3r, #X, and #x mentioned above are not in the syntax rules defined just above that.] For information on how @i{ratios} are printed, see @ref{Printing Ratios}. @node Syntax of a Float, Syntax of a Complex, Syntax of a Ratio, Constructing Numbers from Tokens @subsubsection Syntax of a Float @i{Floats} can be written in either decimal fraction or computerized scientific notation: an optional sign, then a non-empty sequence of digits with an embedded decimal point, then an optional decimal exponent specification. If there is no exponent specifier, then the decimal point is required, and there must be digits after it. The exponent specifier consists of an @i{exponent marker}, an optional sign, and a non-empty sequence of digits. If no exponent specifier is present, or if the @i{exponent marker} @t{e} (or @t{E}) is used, then the format specified by @b{*read-default-float-format*} is used. See @i{Figure~2--9}. An implementation may provide one or more kinds of @i{float} that collectively make up the @i{type} @b{float}. The letters @t{s}, @t{f}, @t{d}, and @t{l} (or their respective uppercase equivalents) explicitly specify the use of the @i{types} @b{short-float}, @b{single-float}, @b{double-float}, and @b{long-float}, respectively. The internal format used for an external representation depends only on the @i{exponent marker}, and not on the number of decimal digits in the external representation. Figure 2--14 contains examples of notations for @i{floats}: @format @group @noindent @w{ @t{0.0} ;Floating-point zero in default format } @w{ @t{0E0} ;As input, this is also floating-point zero in default format. } @w{ ;As output, this would appear as @t{0.0}. } @w{ @t{0e0} ;As input, this is also floating-point zero in default format. } @w{ ;As output, this would appear as @t{0.0}. } @w{ @t{-.0} ;As input, this might be a zero or a minus zero, } @w{ ; depending on whether the implementation supports } @w{ ; a distinct minus zero. } @w{ ;As output, @t{0.0} is zero and @t{-0.0} is minus zero. } @w{ @t{0.} ;On input, the integer zero---@i{not} a floating-point number! } @w{ ;Whether this appears as @t{0} or @t{0.} on output depends } @w{ ;on the @i{value} of @b{*print-radix*}. } @w{ @t{0.0s0} ;A floating-point zero in short format } @w{ @t{0s0} ;As input, this is a floating-point zero in short format. } @w{ ;As output, such a zero would appear as @t{0.0s0} } @w{ ; (or as @t{0.0} if @b{short-float} was the default format). } @w{ @t{6.02E+23} ;Avogadro's number, in default format } @w{ @t{602E+21} ;Also Avogadro's number, in default format } @noindent @w{ Figure 2--14: Examples of Floating-point numbers } @end group @end format For information on how @i{floats} are printed, see @ref{Printing Floats}. @node Syntax of a Complex, , Syntax of a Float, Constructing Numbers from Tokens @subsubsection Syntax of a Complex A @i{complex} has a Cartesian structure, with a real part and an imaginary part each of which is a @i{real}. The parts of a @i{complex} are not necessarily @i{floats} but both parts must be of the same @i{type}: [Editorial Note by KMP: This is not the same as saying they must be the same type. Maybe we mean they are of the same `precision' or `format'? GLS had suggestions which are not yet merged.] either both are @i{rationals}, or both are of the same @i{float} @i{subtype}. When constructing a @i{complex}, if the specified parts are not the same @i{type}, the parts are converted to be the same @i{type} internally (@i{i.e.}, the @i{rational} part is converted to a @i{float}). An @i{object} of type @t{(complex rational)} is converted internally and represented thereafter as a @i{rational} if its imaginary part is an @i{integer} whose value is 0. For further information, see @ref{Sharpsign C} and @ref{Printing Complexes}. @node The Consing Dot, Symbols as Tokens, Constructing Numbers from Tokens, Interpretation of Tokens @subsection The Consing Dot If a @i{token} consists solely of dots (with no escape characters), then an error of @i{type} @b{reader-error} is signaled, except in one circumstance: if the @i{token} is a single @i{dot} and appears in a situation where @i{dotted pair} notation permits a @i{dot}, then it is accepted as part of such syntax and no error is signaled. See @ref{Left-Parenthesis}. @node Symbols as Tokens, Valid Patterns for Tokens, The Consing Dot, Interpretation of Tokens @subsection Symbols as Tokens Any @i{token} that is not a @i{potential number}, does not contain a @i{package marker}, and does not consist entirely of dots will always be interpreted as a @i{symbol}. Any @i{token} that is a @i{potential number} but does not fit the number syntax is a reserved @i{token} and has an @i{implementation-dependent} interpretation. In all other cases, the @i{token} is construed to be the name of a @i{symbol}. Examples of the printed representation of @i{symbols} are in Figure 2--15. For presentational simplicity, these examples assume that the @i{readtable case} of the @i{current readtable} is @t{:upcase}. @format @group @noindent @w{ @t{FROBBOZ} The @i{symbol} whose @i{name} is @t{FROBBOZ}. } @w{ @t{frobboz} Another way to notate the same @i{symbol}. } @w{ @t{fRObBoz} Yet another way to notate it. } @w{ @t{unwind-protect} A @i{symbol} with a hyphen in its @i{name}. } @w{ @t{+$} The @i{symbol} named @t{+$}. } @w{ @t{1+} The @i{symbol} named @t{1+}. } @w{ @t{+1} This is the @i{integer} @t{1}, not a @i{symbol}. } @w{ @t{pascal_style} This @i{symbol} has an underscore in its @i{name}. } @w{ @t{file.rel.43} This @i{symbol} has periods in its @i{name}. } @w{ @t{\(} The @i{symbol} whose @i{name} is @t{(}. } @w{ @t{\+1} The @i{symbol} whose @i{name} is @t{+1}. } @w{ @t{+\1} Also the @i{symbol} whose @i{name} is @t{+1}. } @w{ @t{\frobboz} The @i{symbol} whose @i{name} is @t{fROBBOZ}. } @w{ @t{3.14159265\s0} The @i{symbol} whose @i{name} is @t{3.14159265s0}. } @w{ @t{3.14159265\S0} A different @i{symbol}, whose @i{name} is @t{3.14159265S0}. } @w{ @t{3.14159265s0} A possible @i{short float} approximation to \pi. } @noindent @w{ Figure 2--15: Examples of the printed representation of symbols (Part 1 of 2)} @end group @end format @format @group @noindent @w{ @t{APL\\360} The @i{symbol} whose @i{name} is @t{APL\360}. } @w{ @t{apl\\360} Also the @i{symbol} whose @i{name} is @t{APL\360}. } @w{ @t{\(b@t{^}2\)\ -\ 4*a@t{*c}} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } @w{ Parentheses and two spaces in it. } @w{ @t{\(\b@t{^}2\)\ -\4*\a*\c} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @w{ Letters explicitly lowercase. } @w{ @t{|"|} The same as writing @t{\"}. } @w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @w{ @t{|frobboz|} The @i{name} is @t{frobboz}, not @t{FROBBOZ}. } @w{ @t{|APL\360|} The @i{name} is @t{APL360}. } @w{ @t{|APL\\360|} The @i{name} is @t{APL\360}. } @w{ @t{|apl\\360|} The @i{name} is @t{apl\360}. } @w{ @t{|\|\||} Same as @t{\|\|} ---the @i{name} is @t{||}. } @w{ @t{|(B@t{^}2) - 4*A*C|} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } @w{ Parentheses and two spaces in it. } @w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } @noindent @w{ Figure 2--16: Examples of the printed representation of symbols (Part 2 of 2)} @end group @end format In the process of parsing a @i{symbol}, it is @i{implementation-dependent} which @i{implementation-defined} @i{attributes} are removed from the @i{characters} forming a @i{token} that represents a @i{symbol}. When parsing the syntax for a @i{symbol}, the @i{Lisp reader} looks up the @i{name} of that @i{symbol} in the @i{current package}. This lookup may involve looking in other @i{packages} whose @i{external symbols} are inherited by the @i{current package}. If the name is found, the corresponding @i{symbol} is returned. If the name is not found (that is, there is no @i{symbol} of that name @i{accessible} in the @i{current package}), a new @i{symbol} is created and is placed in the @i{current package} as an @i{internal symbol}. The @i{current package} becomes the owner (@i{home package}) of the @i{symbol}, and the @i{symbol} becomes interned in the @i{current package}. If the name is later read again while this same @i{package} is current, the same @i{symbol} will be found and returned. @node Valid Patterns for Tokens, Package System Consistency Rules, Symbols as Tokens, Interpretation of Tokens @subsection Valid Patterns for Tokens The valid patterns for @i{tokens} are summarized in Figure 2--17. @format @group @noindent @w{ @t{@i{nnnnn}} a @i{number} } @w{ @t{@i{xxxxx}} a @i{symbol} in the @i{current package} } @w{ @t{:@i{xxxxx}} a @i{symbol} in the the @t{KEYWORD} @i{package} } @w{ @t{@i{ppppp}:@i{xxxxx}} an @i{external symbol} in the @i{ppppp} @i{package} } @w{ @t{@i{ppppp}::@i{xxxxx}} a (possibly internal) @i{symbol} in the @i{ppppp} @i{package} } @w{ @t{:@i{nnnnn}} undefined } @w{ @t{@i{ppppp}:@i{nnnnn}} undefined } @w{ @t{@i{ppppp}::@i{nnnnn}} undefined } @w{ @t{::@i{aaaaa}} undefined } @w{ @t{@i{aaaaa}:} undefined } @w{ @t{@i{aaaaa}:@i{aaaaa}:@i{aaaaa}} undefined } @noindent @w{ Figure 2--17: Valid patterns for tokens } @end group @end format Note that @i{nnnnn} has number syntax, neither @i{xxxxx} nor @i{ppppp} has number syntax, and @i{aaaaa} has any syntax. A summary of rules concerning @i{package markers} follows. In each case, examples are offered to illustrate the case; for presentational simplicity, the examples assume that the @i{readtable case} of the @i{current readtable} is @t{:upcase}. @table @asis @item 1. If there is a single @i{package marker}, and it occurs at the beginning of the @i{token}, then the @i{token} is interpreted as a @i{symbol} in the @t{KEYWORD} @i{package}. It also sets the @b{symbol-value} of the newly-created @i{symbol} to that same @i{symbol} so that the @i{symbol} will self-evaluate. For example, @t{:bar}, when read, interns @t{BAR} as an @i{external symbol} in the @t{KEYWORD} @i{package}. @item 2. If there is a single @i{package marker} not at the beginning or end of the @i{token}, then it divides the @i{token} into two parts. The first part specifies a @i{package}; the second part is the name of an @i{external symbol} available in that package. For example, @t{foo:bar}, when read, looks up @t{BAR} among the @i{external symbols} of the @i{package} named @t{FOO}. @item 3. If there are two adjacent @i{package markers} not at the beginning or end of the @i{token}, then they divide the @i{token} into two parts. The first part specifies a @i{package}; the second part is the name of a @i{symbol} within that @i{package} (possibly an @i{internal symbol}). For example, @t{foo::bar}, when read, interns @t{BAR} in the @i{package} named @t{FOO}. @item 4. If the @i{token} contains no @i{package markers}, and does not have @i{potential number} syntax, then the entire @i{token} is the name of the @i{symbol}. The @i{symbol} is looked up in the @i{current package}. For example, @t{bar}, when read, interns @t{BAR} in the @i{current package}. @item 5. The consequences are unspecified if any other pattern of @i{package markers} in a @i{token} is used. All other uses of @i{package markers} within names of @i{symbols} are not defined by this standard but are reserved for @i{implementation-dependent} use. @end table For example, assuming the @i{readtable case} of the @i{current readtable} is @t{:upcase}, @t{editor:buffer} refers to the @i{external symbol} named @t{BUFFER} present in the @i{package} named @t{editor}, regardless of whether there is a @i{symbol} named @t{BUFFER} in the @i{current package}. If there is no @i{package} named @t{editor}, or if no @i{symbol} named @t{BUFFER} is present in @t{editor}, or if @t{BUFFER} is not exported by @t{editor}, the reader signals a correctable error. If @t{editor::buffer} is seen, the effect is exactly the same as reading @t{buffer} with the @t{EDITOR} @i{package} being the @i{current package}. @node Package System Consistency Rules, , Valid Patterns for Tokens, Interpretation of Tokens @subsection Package System Consistency Rules The following rules apply to the package system as long as the @i{value} of @b{*package*} is not changed: @table @asis @item @b{Read-read consistency} Reading the same @i{symbol} @i{name} always results in the @i{same} @i{symbol}. @item @b{Print-read consistency} An @i{interned symbol} always prints as a sequence of characters that, when read back in, yields the @i{same} @i{symbol}. For information about how the @i{Lisp printer} treats @i{symbols}, see @ref{Printing Symbols}. @item @b{Print-print consistency} If two interned @i{symbols} are not the @i{same}, then their printed representations will be different sequences of characters. @end table These rules are true regardless of any implicit interning. As long as the @i{current package} is not changed, results are reproducible regardless of the order of @i{loading} files or the exact history of what @i{symbols} were typed in when. If the @i{value} of @b{*package*} is changed and then changed back to the previous value, consistency is maintained. The rules can be violated by changing the @i{value} of @b{*package*}, forcing a change to @i{symbols} or to @i{packages} or to both by continuing from an error, or calling one of the following @i{functions}: @b{unintern}, @b{unexport}, @b{shadow}, @b{shadowing-import}, or @b{unuse-package}. An inconsistency only applies if one of the restrictions is violated between two of the named @i{symbols}. @b{shadow}, @b{unexport}, @b{unintern}, and @b{shadowing-import} can only affect the consistency of @i{symbols} with the same @i{names} (under @b{string=}) as the ones supplied as arguments. @c end of including concept-tokens @node Standard Macro Characters, , Interpretation of Tokens, Syntax @section Standard Macro Characters @c including concept-macro-chars If the reader encounters a @i{macro character}, then its associated @i{reader macro function} is invoked and may produce an @i{object} to be returned. This @i{function} may read the @i{characters} following the @i{macro character} in the @i{stream} in any syntax and return the @i{object} represented by that syntax. Any @i{character} can be made to be a @i{macro character}. The @i{macro characters} defined initially in a @i{conforming implementation} include the following: @menu * Left-Parenthesis:: * Right-Parenthesis:: * Single-Quote:: * Semicolon:: * Double-Quote:: * Backquote:: * Comma:: * Sharpsign:: * Re-Reading Abbreviated Expressions:: @end menu @node Left-Parenthesis, Right-Parenthesis, Standard Macro Characters, Standard Macro Characters @subsection Left-Parenthesis The @i{left-parenthesis} initiates reading of a @i{list}. @b{read} is called recursively to read successive @i{objects} until a right parenthesis is found in the input @i{stream}. A @i{list} of the @i{objects} read is returned. Thus @example (a b c) @end example is read as a @i{list} of three @i{objects} (the @i{symbols} @t{a}, @t{b}, and @t{c}). The right parenthesis need not immediately follow the printed representation of the last @i{object}; @i{whitespace}_2 characters and comments may precede it. If no @i{objects} precede the right parenthesis, it reads as a @i{list} of zero @i{objects} (the @i{empty list}). If a @i{token} that is just a dot not immediately preceded by an escape character is read after some @i{object} then exactly one more @i{object} must follow the dot, possibly preceded or followed by @i{whitespace}_2 or a comment, followed by the right parenthesis: @example (a b c . d) @end example This means that the @i{cdr} of the last @i{cons} in the @i{list} is not @b{nil}, but rather the @i{object} whose representation followed the dot. The above example might have been the result of evaluating @example (cons 'a (cons 'b (cons 'c 'd))) @end example Similarly, @example (cons 'this-one 'that-one) @result{} (this-one . that-one) @end example It is permissible for the @i{object} following the dot to be a @i{list}: @example (a b c d . (e f . (g))) @equiv{} (a b c d e f g) @end example For information on how the @i{Lisp printer} prints @i{lists} and @i{conses}, see @ref{Printing Lists and Conses}. @node Right-Parenthesis, Single-Quote, Left-Parenthesis, Standard Macro Characters @subsection Right-Parenthesis The @i{right-parenthesis} is invalid except when used in conjunction with the left parenthesis character. For more information, see @ref{Reader Algorithm}. @node Single-Quote, Semicolon, Right-Parenthesis, Standard Macro Characters @subsection Single-Quote @b{Syntax:} @t{'<<@i{exp}>>} A @i{single-quote} introduces an @i{expression} to be ``quoted.'' @i{Single-quote} followed by an @i{expression} @i{exp} is treated by the @i{Lisp reader} as an abbreviation for and is parsed identically to the @i{expression} @t{(quote @i{exp})}. See the @i{special operator} @b{quote}. @menu * Examples of Single-Quote:: @end menu @node Examples of Single-Quote, , Single-Quote, Single-Quote @subsubsection Examples of Single-Quote @example 'foo @result{} FOO ''foo @result{} (QUOTE FOO) (car ''foo) @result{} QUOTE @end example @node Semicolon, Double-Quote, Single-Quote, Standard Macro Characters @subsection Semicolon @b{Syntax:} @t{;<<@i{text}>>} A @i{semicolon} introduces @i{characters} that are to be ignored, such as comments. The @i{semicolon} and all @i{characters} up to and including the next @i{newline} or end of file are ignored. @menu * Examples of Semicolon:: * Notes about Style for Semicolon:: * Use of Single Semicolon:: * Use of Double Semicolon:: * Use of Triple Semicolon:: * Use of Quadruple Semicolon:: * Examples of Style for Semicolon:: @end menu @node Examples of Semicolon, Notes about Style for Semicolon, Semicolon, Semicolon @subsubsection Examples of Semicolon @example (+ 3 ; three 4) @result{} 7 @end example @node Notes about Style for Semicolon, Use of Single Semicolon, Examples of Semicolon, Semicolon @subsubsection Notes about Style for Semicolon Some text editors make assumptions about desired indentation based on the number of @i{semicolons} that begin a comment. The following style conventions are common, although not by any means universal. @node Use of Single Semicolon, Use of Double Semicolon, Notes about Style for Semicolon, Semicolon @subsubsection Use of Single Semicolon Comments that begin with a single @i{semicolon} are all aligned to the same column at the right (sometimes called the ``comment column''). The text of such a comment generally applies only to the line on which it appears. Occasionally two or three contain a single sentence together; this is sometimes indicated by indenting all but the first with an additional space (after the @i{semicolon}). @node Use of Double Semicolon, Use of Triple Semicolon, Use of Single Semicolon, Semicolon @subsubsection Use of Double Semicolon Comments that begin with a double @i{semicolon} are all aligned to the same level of indentation as a @i{form} would be at that same position in the @i{code}. The text of such a comment usually describes the state of the @i{program} at the point where the comment occurs, the @i{code} which follows the comment, or both. @node Use of Triple Semicolon, Use of Quadruple Semicolon, Use of Double Semicolon, Semicolon @subsubsection Use of Triple Semicolon Comments that begin with a triple @i{semicolon} are all aligned to the left margin. Usually they are used prior to a definition or set of definitions, rather than within a definition. @node Use of Quadruple Semicolon, Examples of Style for Semicolon, Use of Triple Semicolon, Semicolon @subsubsection Use of Quadruple Semicolon Comments that begin with a quadruple @i{semicolon} are all aligned to the left margin, and generally contain only a short piece of text that serve as a title for the code which follows, and might be used in the header or footer of a program that prepares code for presentation as a hardcopy document. @node Examples of Style for Semicolon, , Use of Quadruple Semicolon, Semicolon @subsubsection Examples of Style for Semicolon @example ;;;; Math Utilities ;;; FIB computes the the Fibonacci function in the traditional ;;; recursive way. (defun fib (n) (check-type n integer) ;; At this point we're sure we have an integer argument. ;; Now we can get down to some serious computation. (cond ((< n 0) ;; Hey, this is just supposed to be a simple example. ;; Did you really expect me to handle the general case? (error "FIB got ~D as an argument." n)) ((< n 2) n) ;fib[0]=0 and fib[1]=1 ;; The cheap cases didn't work. ;; Nothing more to do but recurse. (t (+ (fib (- n 1)) ;The traditional formula (fib (- n 2)))))) ; is fib[n-1]+fib[n-2]. @end example @node Double-Quote, Backquote, Semicolon, Standard Macro Characters @subsection Double-Quote @b{Syntax:} @t{"<<@i{text}>>"} The @i{double-quote} is used to begin and end a @i{string}. When a @i{double-quote} is encountered, @i{characters} are read from the @i{input} @i{stream} and accumulated until another @i{double-quote} is encountered. If a @i{single escape} @i{character} is seen, the @i{single escape} @i{character} is discarded, the next @i{character} is accumulated, and accumulation continues. The accumulated @i{characters} up to but not including the matching @i{double-quote} are made into a @i{simple string} and returned. It is @i{implementation-dependent} which @i{attributes} of the accumulated characters are removed in this process. Examples of the use of the @i{double-quote} character are in Figure 2--18. @format @group @noindent @w{ @t{"Foo"} ;A string with three characters in it } @w{ @t{""} ;An empty string } @w{ @t{"\"APL\\360?\" he cried."} ;A string with twenty characters } @w{ @t{"|x| = |-x|"} ;A ten-character string } @noindent @w{ Figure 2--18: Examples of the use of double-quote } @end group @end format Note that to place a single escape character or a @i{double-quote} into a string, such a character must be preceded by a single escape character. Note, too, that a multiple escape character need not be quoted by a single escape character within a string. For information on how the @i{Lisp printer} prints @i{strings}, see @ref{Printing Strings}. @node Backquote, Comma, Double-Quote, Standard Macro Characters @subsection Backquote The @i{backquote} introduces a template of a data structure to be built. For example, writing @example `(cond ((numberp ,x) ,@@y) (t (print ,x) ,@@y)) @end example is roughly equivalent to writing @example (list 'cond (cons (list 'numberp x) y) (list* 't (list 'print x) y)) @end example Where a comma occurs in the template, the @i{expression} following the comma is to be evaluated to produce an @i{object} to be inserted at that point. Assume @t{b} has the value 3, for example, then evaluating the @i{form} denoted by @t{`(a b ,b ,(+ b 1) b)} produces the result @t{(a b 3 4 b)}. If a comma is immediately followed by an @i{at-sign}, then the @i{form} following the @i{at-sign} is evaluated to produce a @i{list} of @i{objects}. These @i{objects} are then ``spliced'' into place in the template. For example, if @t{x} has the value @t{(a b c)}, then @example `(x ,x ,@@x foo ,(cadr x) bar ,(cdr x) baz ,@@(cdr x)) @result{} (x (a b c) a b c foo b bar (b c) baz b c) @end example The backquote syntax can be summarized formally as follows. @table @asis @item @t{*} @t{`@i{basic}} is the same as @t{'@i{basic}}, that is, @t{(quote @i{basic})}, for any @i{expression} @i{basic} that is not a @i{list} or a general @i{vector}. @item @t{*} @t{`,@i{form}} is the same as @i{form}, for any @i{form}, provided that the representation of @i{form} does not begin with @i{at-sign} or @i{dot}. (A similar caveat holds for all occurrences of a form after a @i{comma}.) @item @t{*} @t{`,@@@i{form}} has undefined consequences. @item @t{*} @t{`(x1 x2 x3 ... xn . atom)} may be interpreted to mean @example (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] (quote atom)) @end example where the brackets are used to indicate a transformation of an @i{xj} as follows: @table @asis @item -- @t{[@i{form}]} is interpreted as @t{(list `@i{form})}, which contains a backquoted form that must then be further interpreted. @item -- @t{[,@i{form}]} is interpreted as @t{(list @i{form})}. @item -- @t{[,@@@i{form}]} is interpreted as @i{form}. @end table @item @t{*} @t{`(x1 x2 x3 ... xn)} may be interpreted to mean the same as the backquoted form @t{`(x1 x2 x3 ... xn . @b{nil})}, thereby reducing it to the previous case. @item @t{*} @t{`(x1 x2 x3 ... xn . ,form)} may be interpreted to mean @example (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] form) @end example where the brackets indicate a transformation of an @t{xj} as described above. @item @t{*} @t{`(x1 x2 x3 ... xn . ,@@form)} has undefined consequences. @item @t{*} @t{`#(x1 x2 x3 ... xn)} may be interpreted to mean @t{(apply #'vector `(x1 x2 x3 ... xn))}. @end table Anywhere ``@t{,@@}'' may be used, the syntax ``@t{,.}'' may be used instead to indicate that it is permissible to operate @i{destructively} on the @i{list structure} produced by the form following the ``@t{,.}'' (in effect, to use @b{nconc} instead of @b{append}). If the backquote syntax is nested, the innermost backquoted form should be expanded first. This means that if several commas occur in a row, the leftmost one belongs to the innermost @i{backquote}. An @i{implementation} is free to interpret a backquoted @i{form} F_1 as any @i{form} F_2 that, when evaluated, will produce a result that is the @i{same} under @b{equal} as the result implied by the above definition, provided that the side-effect behavior of the substitute @i{form} F_2 is also consistent with the description given above. The constructed copy of the template might or might not share @i{list} structure with the template itself. As an example, the above definition implies that @example `((,a b) ,c ,@@d) @end example will be interpreted as if it were @example (append (list (append (list a) (list 'b) '@b{nil})) (list c) d '@b{nil}) @end example but it could also be legitimately interpreted to mean any of the following: @example (append (list (append (list a) (list 'b))) (list c) d) (append (list (append (list a) '(b))) (list c) d) (list* (cons a '(b)) c d) (list* (cons a (list 'b)) c d) (append (list (cons a '(b))) (list c) d) (list* (cons a '(b)) c (copy-list d)) @end example @menu * Notes about Backquote:: @end menu @node Notes about Backquote, , Backquote, Backquote @subsubsection Notes about Backquote Since the exact manner in which the @i{Lisp reader} will parse an @i{expression} involving the @i{backquote} @i{reader macro} is not specified, an @i{implementation} is free to choose any representation that preserves the semantics described. Often an @i{implementation} will choose a representation that facilitates pretty printing of the expression, so that @t{(pprint `(a ,b))} will display @t{`(a ,b)} and not, for example, @t{(list 'a b)}. However, this is not a requirement. Implementors who have no particular reason to make one choice or another might wish to refer to @b{IEEE Standard for the Scheme Programming Language}, which identifies a popular choice of representation for such expressions that might provide useful to be useful compatibility for some user communities. There is no requirement, however, that any @i{conforming implementation} use this particular representation. This information is provided merely for cross-reference purposes. @node Comma, Sharpsign, Backquote, Standard Macro Characters @subsection Comma The @i{comma} is part of the backquote syntax; see @ref{Backquote}. @i{Comma} is invalid if used other than inside the body of a backquote @i{expression} as described above. @node Sharpsign, Re-Reading Abbreviated Expressions, Comma, Standard Macro Characters @subsection Sharpsign @i{Sharpsign} is a @i{non-terminating} @i{dispatching macro character}. It reads an optional sequence of digits and then one more character, and uses that character to select a @i{function} to run as a @i{reader macro function}. The @i{standard syntax} includes constructs introduced by the @t{#} character. The syntax of these constructs is as follows: a character that identifies the type of construct is followed by arguments in some form. If the character is a letter, its @i{case} is not important; @t{#O} and @t{#o} are considered to be equivalent, for example. Certain @t{#} constructs allow an unsigned decimal number to appear between the @t{#} and the character. The @i{reader macros} associated with the @i{dispatching macro character} @t{#} are described later in this section and summarized in Figure 2--19. @format @group @noindent @w{ dispatch char purpose dispatch char purpose } @w{ Backspace signals error @t{@{} undefined* } @w{ Tab signals error @t{@}} undefined* } @w{ Newline signals error + read-time conditional } @w{ Linefeed signals error - read-time conditional } @w{ Page signals error . read-time evaluation } @w{ Return signals error / undefined } @w{ Space signals error A, a array } @w{ ! undefined* B, b binary rational } @w{ @t{"} undefined C, c complex number } @w{ # reference to = label D, d undefined } @w{ $ undefined E, e undefined } @w{ % undefined F, f undefined } @w{ & undefined G, g undefined } @w{ ' function abbreviation H, h undefined } @w{ ( simple vector I, i undefined } @w{ ) signals error J, j undefined } @w{ @t{*} bit vector K, k undefined } @w{ , undefined L, l undefined } @w{ : uninterned symbol M, m undefined } @w{ ; undefined N, n undefined } @w{ @t{<} signals error O, o octal rational } @w{ @t{=} labels following object P, p pathname } @w{ @t{>} undefined Q, q undefined } @w{ ? undefined* R, r radix-n rational } @w{ @@ undefined S, s structure } @w{ [ undefined* T, t undefined } @w{ @t{\} character object U, u undefined } @w{ ] undefined* V, v undefined } @w{ @t{^} undefined W, w undefined } @w{ @t{_} undefined X, x hexadecimal rational } @w{ ` undefined Y, y undefined } @w{ @t{|} balanced comment Z, z undefined } @w{ @t{~} undefined Rubout undefined } @noindent @w{ Figure 2--19: Standard # Dispatching Macro Character Syntax } @end group @end format The combinations marked by an asterisk (*) are explicitly reserved to the user. No @i{conforming implementation} defines them. Note also that @i{digits} do not appear in the preceding table. This is because the notations @t{#0}, @t{#1}, ..., @t{#9} are reserved for another purpose which occupies the same syntactic space. When a @i{digit} follows a @i{sharpsign}, it is not treated as a dispatch character. Instead, an unsigned integer argument is accumulated and passed as an @i{argument} to the @i{reader macro} for the @i{character} that follows the digits. For example, @t{#2A((1 2) (3 4))} is a use of @t{#A} with an argument of @t{2}. @menu * Sharpsign Backslash:: * Sharpsign Single-Quote:: * Sharpsign Left-Parenthesis:: * Sharpsign Asterisk:: * Examples of Sharpsign Asterisk:: * Sharpsign Colon:: * Sharpsign Dot:: * Sharpsign B:: * Sharpsign O:: * Sharpsign X:: * Sharpsign R:: * Sharpsign C:: * Sharpsign A:: * Sharpsign S:: * Sharpsign P:: * Sharpsign Equal-Sign:: * Sharpsign Sharpsign:: * Sharpsign Plus:: * Sharpsign Minus:: * Sharpsign Vertical-Bar:: * Examples of Sharpsign Vertical-Bar:: * Notes about Style for Sharpsign Vertical-Bar:: * Sharpsign Less-Than-Sign:: * Sharpsign Whitespace:: * Sharpsign Right-Parenthesis:: @end menu @node Sharpsign Backslash, Sharpsign Single-Quote, Sharpsign, Sharpsign @subsubsection Sharpsign Backslash @b{Syntax:} @t{#\<<@i{x}>>} When the @i{token} @i{x} is a single @i{character} long, this parses as the literal @i{character} @i{char}. @i{Uppercase} and @i{lowercase} letters are distinguished after @t{#\}; @t{#\A} and @t{#\a} denote different @i{character} @i{objects}. Any single @i{character} works after @t{#\}, even those that are normally special to @b{read}, such as @i{left-parenthesis} and @i{right-parenthesis}. In the single @i{character} case, the @i{x} must be followed by a non-constituent @i{character}. After @t{#\} is read, the reader backs up over the @i{slash} and then reads a @i{token}, treating the initial @i{slash} as a @i{single escape} @i{character} (whether it really is or not in the @i{current readtable}). When the @i{token} @i{x} is more than one @i{character} long, the @i{x} must have the syntax of a @i{symbol} with no embedded @i{package markers}. In this case, the @i{sharpsign} @i{backslash} notation parses as the @i{character} whose @i{name} is @t{(string-upcase @i{x})}; see @ref{Character Names}. For information about how the @i{Lisp printer} prints @i{character} @i{objects}, see @ref{Printing Characters}. @node Sharpsign Single-Quote, Sharpsign Left-Parenthesis, Sharpsign Backslash, Sharpsign @subsubsection Sharpsign Single-Quote Any @i{expression} preceded by @t{#'} (@i{sharpsign} followed by @i{single-quote}), as in @t{#'@i{expression}}, is treated by the @i{Lisp reader} as an abbreviation for and parsed identically to the @i{expression} @t{(function @i{expression})}. See @b{function}. For example, @example (apply #'+ l) @equiv{} (apply (function +) l) @end example @node Sharpsign Left-Parenthesis, Sharpsign Asterisk, Sharpsign Single-Quote, Sharpsign @subsubsection Sharpsign Left-Parenthesis @t{#(} and @t{)} are used to notate a @i{simple vector}. If an unsigned decimal integer appears between the @t{#} and @t{(}, it specifies explicitly the length of the @i{vector}. The consequences are undefined if the number of @i{objects} specified before the closing @t{)} exceeds the unsigned decimal integer. If the number of @i{objects} supplied before the closing @t{)} is less than the unsigned decimal integer but greater than zero, the last @i{object} is used to fill all remaining elements of the @i{vector}. [Editorial Note by Barmar: This should say "signals...".] The consequences are undefined if the unsigned decimal integer is non-zero and number of @i{objects} supplied before the closing @t{)} is zero. For example, @example #(a b c c c c) #6(a b c c c c) #6(a b c) #6(a b c c) @end example all mean the same thing: a @i{vector} of length @t{6} with @i{elements} @t{a}, @t{b}, and four occurrences of @t{c}. Other examples follow: @example #(a b c) ;A vector of length 3 #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) ;A vector containing the primes below 50 #() ;An empty vector @end example The notation @t{#()} denotes an empty @i{vector}, as does @t{#0()}. For information on how the @i{Lisp printer} prints @i{vectors}, see @ref{Printing Strings}, @ref{Printing Bit Vectors}, or @ref{Printing Other Vectors}. @node Sharpsign Asterisk, Examples of Sharpsign Asterisk, Sharpsign Left-Parenthesis, Sharpsign @subsubsection Sharpsign Asterisk @b{Syntax:} @t{#*<<@i{bits}>>} A @i{simple bit vector} is constructed containing the indicated @i{bits} (@t{0}'s and @t{1}'s), where the leftmost @i{bit} has index zero and the subsequent @i{bits} have increasing indices. @b{Syntax:} @t{#<<@i{n}>>*<<@i{bits}>>} With an argument @i{n}, the @i{vector} to be created is of @i{length} @i{n}. If the number of @i{bits} is less than @i{n} but greater than zero, the last bit is used to fill all remaining bits of the @i{bit vector}. The notations @t{#*} and @t{#0*} each denote an empty @i{bit vector}. Regardless of whether the optional numeric argument @i{n} is provided, the @i{token} that follows the @i{asterisk} is delimited by a normal @i{token} delimiter. However, (unless the @i{value} of @b{*read-suppress*} is @i{true}) an error of @i{type} @b{reader-error} is signaled if that @i{token} is not composed entirely of @t{0}'s and @t{1}'s, or if @i{n} was supplied and the @i{token} is composed of more than @i{n} @i{bits}, or if @i{n} is greater than one, but no @i{bits} were specified. Neither a @i{single escape} nor a @i{multiple escape} is permitted in this @i{token}. For information on how the @i{Lisp printer} prints @i{bit vectors}, see @ref{Printing Bit Vectors}. @node Examples of Sharpsign Asterisk, Sharpsign Colon, Sharpsign Asterisk, Sharpsign @subsubsection Examples of Sharpsign Asterisk For example, @example #*101111 #6*101111 #6*101 #6*1011 @end example all mean the same thing: a @i{vector} of length @t{6} with @i{elements} @t{1}, @t{0}, @t{1}, @t{1}, @t{1}, and @t{1}. For example: @example #* ;An empty bit-vector @end example @node Sharpsign Colon, Sharpsign Dot, Examples of Sharpsign Asterisk, Sharpsign @subsubsection Sharpsign Colon @b{Syntax:} @t{#:<<@i{symbol-name}>>} @t{#:} introduces an @i{uninterned} @i{symbol} whose @i{name} is @i{symbol-name}. Every time this syntax is encountered, a @i{distinct} @i{uninterned} @i{symbol} is created. The @i{symbol-name} must have the syntax of a @i{symbol} with no @i{package prefix}. For information on how the @i{Lisp reader} prints @i{uninterned} @i{symbols}, see @ref{Printing Symbols}. @node Sharpsign Dot, Sharpsign B, Sharpsign Colon, Sharpsign @subsubsection Sharpsign Dot @t{#.@i{foo}} is read as the @i{object} resulting from the evaluation of the @i{object} represented by @i{foo}. The evaluation is done during the @b{read} process, when the @t{#.} notation is encountered. The @t{#.} syntax therefore performs a read-time evaluation of @i{foo}. The normal effect of @t{#.} is inhibited when the @i{value} of @b{*read-eval*} is @i{false}. In that situation, an error of @i{type} @b{reader-error} is signaled. For an @i{object} that does not have a convenient printed representation, a @i{form} that computes the @i{object} can be given using the @t{#.} notation. @node Sharpsign B, Sharpsign O, Sharpsign Dot, Sharpsign @subsubsection Sharpsign B @t{#B}@i{rational} reads @i{rational} in binary (radix 2). For example, @example #B1101 @equiv{} 13 ;1101_2 #b101/11 @equiv{} 5/3 @end example The consequences are undefined if the token immediately following the @t{#B} does not have the syntax of a binary (@i{i.e.}, radix 2) @i{rational}. @node Sharpsign O, Sharpsign X, Sharpsign B, Sharpsign @subsubsection Sharpsign O @t{#O}@i{rational} reads @i{rational} in octal (radix 8). For example, @example #o37/15 @equiv{} 31/13 #o777 @equiv{} 511 #o105 @equiv{} 69 ;105_8 @end example The consequences are undefined if the token immediately following the @t{#O} does not have the syntax of an octal (@i{i.e.}, radix 8) @i{rational}. @node Sharpsign X, Sharpsign R, Sharpsign O, Sharpsign @subsubsection Sharpsign X @t{#X}@i{rational} reads @i{rational} in hexadecimal (radix 16). The digits above @t{9} are the letters @t{A} through @t{F} (the lowercase letters @t{a} through @t{f} are also acceptable). For example, @example #xF00 @equiv{} 3840 #x105 @equiv{} 261 ;105_@t{16} @end example The consequences are undefined if the token immediately following the @t{#X} does not have the syntax of a hexadecimal (@i{i.e.}, radix 16) @i{rational}. @node Sharpsign R, Sharpsign C, Sharpsign X, Sharpsign @subsubsection Sharpsign R @t{#@i{n}R} @t{#@i{radix}R@i{rational}} reads @i{rational} in radix @i{radix}. @i{radix} must consist of only digits that are interpreted as an @i{integer} in decimal radix; its value must be between 2 and 36 (inclusive). Only valid digits for the specified radix may be used. For example, @t{#3r102} is another way of writing @t{11} (decimal), and @t{#11R32} is another way of writing @t{35} (decimal). For radices larger than 10, letters of the alphabet are used in order for the digits after @t{9}. No alternate @t{#} notation exists for the decimal radix since a decimal point suffices. Figure 2--20 contains examples of the use of @t{#B}, @t{#O}, @t{#X}, and @t{#R}. @format @group @noindent @w{ @t{#2r11010101} ;Another way of writing @t{213} decimal } @w{ @t{#b11010101} ;Ditto } @w{ @t{#b+11010101} ;Ditto } @w{ @t{#o325} ;Ditto, in octal radix } @w{ @t{#xD5} ;Ditto, in hexadecimal radix } @w{ @t{#16r+D5} ;Ditto } @w{ @t{#o-300} ;Decimal @t{-192}, written in base 8 } @w{ @t{#3r-21010} ;Same thing in base 3 } @w{ @t{#25R-7H} ;Same thing in base 25 } @w{ @t{#xACCEDED} ;@t{181202413}, in hexadecimal radix } @noindent @w{ Figure 2--20: Radix Indicator Example } @end group @end format The consequences are undefined if the token immediately following the @t{#@i{n}R} does not have the syntax of a @i{rational} in radix @i{n}. @node Sharpsign C, Sharpsign A, Sharpsign R, Sharpsign @subsubsection Sharpsign C @t{#C} reads a following @i{object}, which must be a @i{list} of length two whose @i{elements} are both @i{reals}. These @i{reals} denote, respectively, the real and imaginary parts of a @i{complex} number. If the two parts as notated are not of the same data type, then they are converted according to the rules of floating-point @i{contagion} described in @ref{Contagion in Numeric Operations}. @t{#C(@i{real} @i{imag})} is equivalent to @t{#.(complex (quote @i{real}) (quote @i{imag}))}, except that @t{#C} is not affected by @b{*read-eval*}. See the @i{function} @b{complex}. Figure 2--21 contains examples of the use of @t{#C}. @format @group @noindent @w{ @t{#C(3.0s1 2.0s-1)} ;A @i{complex} with @i{small float} parts. } @w{ @t{#C(5 -3) } ;A ``Gaussian integer'' } @w{ @t{#C(5/3 7.0) } ;Will be converted internally to @t{#C(1.66666 7.0)} } @w{ @t{#C(0 1)} ;The imaginary unit; that is, i. } @noindent @w{ Figure 2--21: Complex Number Example } @end group @end format For further information, see @ref{Printing Complexes} and @ref{Syntax of a Complex}. @node Sharpsign A, Sharpsign S, Sharpsign C, Sharpsign @subsubsection Sharpsign A @t{#@i{n}A} @t{#@i{n}@t{A}@i{object}} constructs an @i{n}-dimensional @i{array}, using @i{object} as the value of the @t{:initial-contents} argument to @b{make-array}. For example, @t{#2A((0 1 5) (foo 2 (hot dog)))} represents a 2-by-3 matrix: @example 0 1 5 foo 2 (hot dog) @end example In contrast, @t{#1A((0 1 5) (foo 2 (hot dog)))} represents a @i{vector} of @i{length} @t{2} whose @i{elements} are @i{lists}: @example (0 1 5) (foo 2 (hot dog)) @end example @t{#0A((0 1 5) (foo 2 (hot dog)))} represents a zero-dimensional @i{array} whose sole element is a @i{list}: @example ((0 1 5) (foo 2 (hot dog))) @end example @t{#0A foo} represents a zero-dimensional @i{array} whose sole element is the @i{symbol} @t{foo}. The notation @t{#1A foo} is not valid because @t{foo} is not a @i{sequence}. If some @i{dimension} of the @i{array} whose representation is being parsed is found to be @t{0}, all @i{dimensions} to the right (@i{i.e.}, the higher numbered @i{dimensions}) are also considered to be @t{0}. For information on how the @i{Lisp printer} prints @i{arrays}, see @ref{Printing Strings}, @ref{Printing Bit Vectors}, @ref{Printing Other Vectors}, or @ref{Printing Other Arrays}. @node Sharpsign S, Sharpsign P, Sharpsign A, Sharpsign @subsubsection Sharpsign S @t{#s(name slot1 value1 slot2 value2 ...)} denotes a @i{structure}. This is valid only if @i{name} is the name of a @i{structure} @i{type} already defined by @b{defstruct} and if the @i{structure} @i{type} has a standard constructor function. Let @i{cm} stand for the name of this constructor function; then this syntax is equivalent to @example #.(cm keyword1 'value1 keyword2 'value2 ...) @end example where each @i{keywordj} is the result of computing @example (intern (string slotj) (find-package 'keyword)) @end example The net effect is that the constructor function is called with the specified slots having the specified values. (This coercion feature is deprecated; in the future, keyword names will be taken in the package they are read in, so @i{symbols} that are actually in the @t{KEYWORD} @i{package} should be used if that is what is desired.) Whatever @i{object} the constructor function returns is returned by the @t{#S} syntax. For information on how the @i{Lisp printer} prints @i{structures}, see @ref{Printing Structures}. @node Sharpsign P, Sharpsign Equal-Sign, Sharpsign S, Sharpsign @subsubsection Sharpsign P @t{#P} reads a following @i{object}, which must be a @i{string}. @t{#P<<@i{expression}>>} is equivalent to @t{#.(parse-namestring '<<@i{expression}>>)}, except that @t{#P} is not affected by @b{*read-eval*}. For information on how the @i{Lisp printer} prints @i{pathnames}, see @ref{Printing Pathnames}. @node Sharpsign Equal-Sign, Sharpsign Sharpsign, Sharpsign P, Sharpsign @subsubsection Sharpsign Equal-Sign @t{#@i{n}=} @t{#@i{n}=@i{object}} reads as whatever @i{object} has @i{object} as its printed representation. However, that @i{object} is labeled by @i{n}, a required unsigned decimal integer, for possible reference by the syntax @t{#@i{n}#}. The scope of the label is the @i{expression} being read by the outermost call to @b{read}; within this @i{expression}, the same label may not appear twice. @node Sharpsign Sharpsign, Sharpsign Plus, Sharpsign Equal-Sign, Sharpsign @subsubsection Sharpsign Sharpsign @t{#@i{n}#} @t{#@i{n}#}, where @i{n} is a required unsigned decimal @i{integer}, provides a reference to some @i{object} labeled by @t{#@i{n}=}; that is, @t{#@i{n}#} represents a pointer to the same (@b{eq}) @i{object} labeled by @t{#@i{n}=}. For example, a structure created in the variable @t{y} by this code: @example (setq x (list 'p 'q)) (setq y (list (list 'a 'b) x 'foo x)) (rplacd (last y) (cdr y)) @end example could be represented in this way: @example ((a b) . #1=(#2=(p q) foo #2# . #1#)) @end example Without this notation, but with @b{*print-length*} set to @t{10} and @b{*print-circle*} set to @b{nil}, the structure would print in this way: @example ((a b) (p q) foo (p q) (p q) foo (p q) (p q) foo (p q) ...) @end example A reference @t{#@i{n}#} may only occur after a label @t{#@i{n}=}; forward references are not permitted. The reference may not appear as the labeled object itself (that is, @t{#@i{n}=#@i{n}#}) may not be written because the @i{object} labeled by @t{#@i{n}=} is not well defined in this case. @node Sharpsign Plus, Sharpsign Minus, Sharpsign Sharpsign, Sharpsign @subsubsection Sharpsign Plus @t{#+} provides a read-time conditionalization facility; the syntax is @t{#+@i{test} @i{expression}}. If the @i{feature expression} @i{test} succeeds, then this textual notation represents an @i{object} whose printed representation is @i{expression}. If the @i{feature expression} @i{test} fails, then this textual notation is treated as @i{whitespace}_2; that is, it is as if the ``@t{#+} @i{test} @i{expression}'' did not appear and only a @i{space} appeared in its place. For a detailed description of success and failure in @i{feature expressions}, see @ref{Feature Expressions}. @t{#+} operates by first reading the @i{feature expression} and then skipping over the @i{form} if the @i{feature expression} fails. While reading the @i{test}, the @i{current package} is the @t{KEYWORD} @i{package}. Skipping over the @i{form} is accomplished by @i{binding} @b{*read-suppress*} to @i{true} and then calling @b{read}. For examples, see @ref{Examples of Feature Expressions}. @node Sharpsign Minus, Sharpsign Vertical-Bar, Sharpsign Plus, Sharpsign @subsubsection Sharpsign Minus @t{#-} is like @t{#+} except that it skips the @i{expression} if the @i{test} succeeds; that is, @example #-@i{test} @i{expression} @equiv{} #+(not @i{test}) @i{expression} @end example For examples, see @ref{Examples of Feature Expressions}. @node Sharpsign Vertical-Bar, Examples of Sharpsign Vertical-Bar, Sharpsign Minus, Sharpsign @subsubsection Sharpsign Vertical-Bar @t{#|...|#} is treated as a comment by the reader. It must be balanced with respect to other occurrences of @t{#|} and @t{|#}, but otherwise may contain any characters whatsoever. @node Examples of Sharpsign Vertical-Bar, Notes about Style for Sharpsign Vertical-Bar, Sharpsign Vertical-Bar, Sharpsign @subsubsection Examples of Sharpsign Vertical-Bar The following are some examples that exploit the @t{#|...|#} notation: @example ;;; In this example, some debugging code is commented out with #|...|# ;;; Note that this kind of comment can occur in the middle of a line ;;; (because a delimiter marks where the end of the comment occurs) ;;; where a semicolon comment can only occur at the end of a line ;;; (because it comments out the rest of the line). (defun add3 (n) #|(format t "~&Adding 3 to ~D." n)|# (+ n 3)) ;;; The examples that follow show issues related to #| ... |# nesting. ;;; In this first example, #| and |# always occur properly paired, ;;; so nesting works naturally. (defun mention-fun-fact-1a () (format t "CL uses ; and #|...|# in comments.")) @result{} MENTION-FUN-FACT-1A (mention-fun-fact-1a) @t{ |> } CL uses ; and #|...|# in comments. @result{} NIL #| (defun mention-fun-fact-1b () (format t "CL uses ; and #|...|# in comments.")) |# (fboundp 'mention-fun-fact-1b) @result{} NIL ;;; In this example, vertical-bar followed by sharpsign needed to appear ;;; in a string without any matching sharpsign followed by vertical-bar ;;; having preceded this. To compensate, the programmer has included a ;;; slash separating the two characters. In case 2a, the slash is ;;; unnecessary but harmless, but in case 2b, the slash is critical to ;;; allowing the outer #| ... |# pair match. If the slash were not present, ;;; the outer comment would terminate prematurely. (defun mention-fun-fact-2a () (format t "Don't use |\# unmatched or you'll get in trouble!")) @result{} MENTION-FUN-FACT-2A (mention-fun-fact-2a) @t{ |> } Don't use |# unmatched or you'll get in trouble! @result{} NIL #| (defun mention-fun-fact-2b () (format t "Don't use |\# unmatched or you'll get in trouble!") |# (fboundp 'mention-fun-fact-2b) @result{} NIL ;;; In this example, the programmer attacks the mismatch problem in a ;;; different way. The sharpsign vertical bar in the comment is not needed ;;; for the correct parsing of the program normally (as in case 3a), but ;;; becomes important to avoid premature termination of a comment when such ;;; a program is commented out (as in case 3b). (defun mention-fun-fact-3a () ; #| (format t "Don't use |# unmatched or you'll get in trouble!")) @result{} MENTION-FUN-FACT-3A (mention-fun-fact-3a) @t{ |> } Don't use |# unmatched or you'll get in trouble! @result{} NIL #| (defun mention-fun-fact-3b () ; #| (format t "Don't use |# unmatched or you'll get in trouble!")) |# (fboundp 'mention-fun-fact-3b) @result{} NIL @end example @node Notes about Style for Sharpsign Vertical-Bar, Sharpsign Less-Than-Sign, Examples of Sharpsign Vertical-Bar, Sharpsign @subsubsection Notes about Style for Sharpsign Vertical-Bar Some text editors that purport to understand Lisp syntax treat any @t{|...|} as balanced pairs that cannot nest (as if they were just balanced pairs of the multiple escapes used in notating certain symbols). To compensate for this deficiency, some programmers use the notation @t{#||...#||...||#...||#} instead of @t{#|...#|...|#...|#}. Note that this alternate usage is not a different @i{reader macro}; it merely exploits the fact that the additional vertical-bars occur within the comment in a way that tricks certain text editor into better supporting nested comments. As such, one might sometimes see code like: @example #|| (+ #|| 3 ||# 4 5) ||# @end example Such code is equivalent to: @example #| (+ #| 3 |# 4 5) |# @end example @node Sharpsign Less-Than-Sign, Sharpsign Whitespace, Notes about Style for Sharpsign Vertical-Bar, Sharpsign @subsubsection Sharpsign Less-Than-Sign @t{#<} is not valid reader syntax. The @i{Lisp reader} will signal an error of @i{type} @b{reader-error} on encountering @t{#<}. This syntax is typically used in the printed representation of @i{objects} that cannot be read back in. @node Sharpsign Whitespace, Sharpsign Right-Parenthesis, Sharpsign Less-Than-Sign, Sharpsign @subsubsection Sharpsign Whitespace @t{#} followed immediately by @i{whitespace}_1 is not valid reader syntax. The @i{Lisp reader} will signal an error of @i{type} @b{reader-error} if it encounters the reader macro notation @t{#<@i{Newline}>} or @t{#<@i{Space}>}. @node Sharpsign Right-Parenthesis, , Sharpsign Whitespace, Sharpsign @subsubsection Sharpsign Right-Parenthesis This is not valid reader syntax. The @i{Lisp reader} will signal an error of @i{type} @b{reader-error} upon encountering @t{#)}. @node Re-Reading Abbreviated Expressions, , Sharpsign, Standard Macro Characters @subsection Re-Reading Abbreviated Expressions Note that the @i{Lisp reader} will generally signal an error of @i{type} @b{reader-error} when reading an @i{expression}_2 that has been abbreviated because of length or level limits (see @b{*print-level*}, @b{*print-length*}, and @b{*print-lines*}) due to restrictions on ``@t{..}'', ``@t{...}'', ``@t{#}'' followed by @i{whitespace}_1, and ``@t{#)}''. @c end of including concept-macro-chars @c %**end of chapter gcl-2.6.14/info/bind.texi0000755000175000017500000004140614360276512013545 0ustar cammcamm@setfilename foo.info @node bind @subsection bind @cartouche bind \- Arrange for X events to invoke Tcl commands @unnumberedsubsec Synopsis @w{@b{bind}@i{ windowSpec}} @w{@b{bind}@i{ windowSpec sequence}} @w{@b{bind}@i{ windowSpec sequence command}} @b{bind}@i{ windowSpec sequence @b{+}}\fIcommand @end cartouche @unnumberedsubsec Description If all three arguments are specified, @b{bind} will arrange for @i{command} (a Tcl command) to be executed whenever the sequence of events given by @i{sequence} occurs in the window(s) identified by @i{windowSpec}. If @i{command} is prefixed with a ``+'', then it is appended to any existing binding for @i{sequence}; otherwise @i{command} replaces the existing binding, if any. If @i{command} is an empty string then the current binding for @i{sequence} is destroyed, leaving @i{sequence} unbound. In all of the cases where a @i{command} argument is provided, @b{bind} returns an empty string. If @i{sequence} is specified without a @i{command}, then the command currently bound to @i{sequence} is returned, or an empty string if there is no binding for @i{sequence}. If neither @i{sequence} nor @i{command} is specified, then the return value is a list whose elements are all the sequences for which there exist bindings for @i{windowSpec}. The @i{windowSpec} argument selects which window(s) the binding applies to. It may have one of three forms. If @i{windowSpec} is the path name for a window, then the binding applies to that particular window. If @i{windowSpec} is the name of a class of widgets, then the binding applies to all widgets in that class. Lastly, @i{windowSpec} may have the value @b{all}, in which case the binding applies to all windows in the application. The @i{sequence} argument specifies a sequence of one or more event patterns, with optional white space between the patterns. Each event pattern may take either of two forms. In the simplest case it is a single printing ASCII character, such as @b{a} or @b{[}. The character may not be a space character or the character @b{<}. This form of pattern matches a @b{KeyPress} event for the particular character. The second form of pattern is longer but more general. It has the following syntax: @example @b{<}@i{modifier-modifier-type-detail@b{>}} @end example The entire event pattern is surrounded by angle brackets. Inside the angle brackets are zero or more modifiers, an event type, and an extra piece of information (@i{detail}) identifying a particular button or keysym. Any of the fields may be omitted, as long as at least one of @i{type} and @i{detail} is present. The fields must be separated by white space or dashes. Modifiers may consist of any of the values in the following list: @example Control Any Shift Double Lock Triple Button1, B1 Mod1, M1, Meta, M Button2, B2 Mod2, M2, Alt Button3, B3 Mod3, M3 Button4, B4 Mod4, M4 Button5, B5 Mod5, M5 @end example Where more than one value is listed, separated by commas, the values are equivalent. All of the modifiers except @b{Any}, @b{Double}, and @b{Triple} have the obvious X meanings. For example, @b{Button1} requires that button 1 be depressed when the event occurs. Under normal conditions the button and modifier state at the time of the event must match exactly those specified in the @b{bind} command. If no modifiers are specified, then events will match only if no modifiers are present. If the @b{Any} modifier is specified, then additional modifiers may be present besides those specified explicitly. For example, if button 1 is pressed while the shift and control keys are down, the specifier @b{} will match the event, but the specifier @b{} will not. The @b{Double} and @b{Triple} modifiers are a convenience for specifying double mouse clicks and other repeated events. They cause a particular event pattern to be repeated 2 or 3 times, and also place a time and space requirement on the sequence: for a sequence of events to match a @b{Double} or @b{Triple} pattern, all of the events must occur close together in time and without substantial mouse motion in between. For example, @b{} is equivalent to @b{} with the extra time and space requirement. The @i{type} field may be any of the standard X event types, with a few extra abbreviations. Below is a list of all the valid types; where two name appear together, they are synonyms. @example ButtonPress, Button Expose Leave ButtonRelease FocusIn Map Circulate FocusOut Property CirculateRequest Gravity Reparent Colormap Keymap ResizeRequest Configure KeyPress, Key Unmap ConfigureRequest KeyRelease Visibility Destroy MapRequest Enter Motion @end example The last part of a long event specification is @i{detail}. In the case of a @b{ButtonPress} or @b{ButtonRelease} event, it is the number of a button (1-5). If a button number is given, then only an event on that particular button will match; if no button number is given, then an event on any button will match. Note: giving a specific button number is different than specifying a button modifier; in the first case, it refers to a button being pressed or released, while in the second it refers to some other button that is already depressed when the matching event occurs. If a button number is given then @i{type} may be omitted: if will default to @b{ButtonPress}. For example, the specifier @b{<1>} is equivalent to @b{}. If the event type is @b{KeyPress} or @b{KeyRelease}, then @i{detail} may be specified in the form of an X keysym. Keysyms are textual specifications for particular keys on the keyboard; they include all the alphanumeric ASCII characters (e.g. ``a'' is the keysym for the ASCII character ``a''), plus descriptions for non-alphanumeric characters (``comma'' is the keysym for the comma character), plus descriptions for all the non-ASCII keys on the keyboard (``Shift_L'' is the keysm for the left shift key, and ``F1'' is the keysym for the F1 function key, if it exists). The complete list of keysyms is not presented here; it should be available in other X documentation. If necessary, you can use the @b{%K} notation described below to print out the keysym name for an arbitrary key. If a keysym @i{detail} is given, then the @i{type} field may be omitted; it will default to @b{KeyPress}. For example, @b{} is equivalent to @b{}. If a keysym @i{detail} is specified then the @b{Shift} modifier need not be specified and will be ignored if specified: each keysym already implies a particular state for the shift key. The @i{command} argument to @b{bind} is a Tcl command string, which will be executed whenever the given event sequence occurs. @i{Command} will be executed in the same interpreter that the @b{bind} command was executed in. If @i{command} contains any @b{%} characters, then the command string will not be executed directly. Instead, a new command string will be generated by replacing each @b{%}, and the character following it, with information from the current event. The replacement depends on the character following the @b{%}, as defined in the list below. Unless otherwise indicated, the replacement string is the decimal value of the given field from the current event. Some of the substitutions are only valid for certain types of events; if they are used for other types of events the value substituted is undefined. @table @asis @item @b{%%} Replaced with a single percent. @item @b{%#} The number of the last client request processed by the server (the @i{serial} field from the event). Valid for all event types. @item @b{%a} The @i{above} field from the event. Valid only for @b{ConfigureNotify} events. @item @b{%b} The number of the button that was pressed or released. Valid only for @b{ButtonPress} and @b{ButtonRelease} events. @item @b{%c} The @i{count} field from the event. Valid only for @b{Expose}, @b{GraphicsExpose}, and @b{MappingNotify} events. @item @b{%d} The @i{detail} field from the event. The @b{%d} is replaced by a string identifying the detail. For @b{EnterNotify}, @b{LeaveNotify}, @b{FocusIn}, and @b{FocusOut} events, the string will be one of the following: @example NotifyAncestor NotifyNonlinearVirtual NotifyDetailNone NotifyPointer NotifyInferior NotifyPointerRoot NotifyNonlinear NotifyVirtual @end example For @b{ConfigureRequest} events, the substituted string will be one of the following: @example Above Opposite Below TopIf BottomIf @end example For events other than these, the substituted string is undefined. @item @b{%f} The @i{focus} field from the event (@b{0} or @b{1}). Valid only for @b{EnterNotify} and @b{LeaveNotify} events. @item @b{%h} The @i{height} field from the event. Valid only for @b{Configure}, @b{ConfigureNotify}, @b{Expose}, @b{GraphicsExpose}, and @b{ResizeRequest} events. @item @b{%k} The @i{keycode} field from the event. Valid only for @b{KeyPress} and @b{KeyRelease} events. @item @b{%m} The @i{mode} field from the event. The substituted string is one of @b{NotifyNormal}, @b{NotifyGrab}, @b{NotifyUngrab}, or @b{NotifyWhileGrabbed}. Valid only for @b{EnterWindow}, @b{FocusIn}, @b{FocusOut}, and @b{LeaveWindow} events. @item @b{%o} The @i{override_redirect} field from the event. Valid only for @b{CreateNotify}, @b{MapNotify}, @b{ReparentNotify}, and @b{ConfigureNotify} events. @item @b{%p} The @i{place} field from the event, substituted as one of the strings @b{PlaceOnTop} or @b{PlaceOnBottom}. Valid only for @b{CirculateNotify} and @b{CirculateRequest} events. @item @b{%s} The @i{state} field from the event. For @b{ButtonPress}, @b{ButtonRelease}, @b{EnterNotify}, @b{KeyPress}, @b{KeyRelease}, @b{LeaveNotify}, and @b{MotionNotify} events, a decimal string is substituted. For @b{VisibilityNotify}, one of the strings @b{VisibilityUnobscured}, @b{VisibilityPartiallyObscured}, and @b{VisibilityFullyObscured} is substituted. @item @b{%t} The @i{time} field from the event. Valid only for events that contain a @i{time} field. @item @b{%v} The @i{value_mask} field from the event. Valid only for @b{ConfigureRequest} events. @item @b{%w} The @i{width} field from the event. Valid only for @b{Configure}, @b{ConfigureRequest}, @b{Expose}, @b{GraphicsExpose}, and @b{ResizeRequest} events. @item @b{%x} The @i{x} field from the event. Valid only for events containing an @i{x} field. @item @b{%y} The @i{y} field from the event. Valid only for events containing a @i{y} field. @item @b{%A} Substitutes the ASCII character corresponding to the event, or the empty string if the event doesn't correspond to an ASCII character (e.g. the shift key was pressed). @b{XLookupString} does all the work of translating from the event to an ASCII character. Valid only for @b{KeyPress} and @b{KeyRelease} events. @item @b{%B} The @i{border_width} field from the event. Valid only for @b{ConfigureNotify} and @b{CreateWindow} events. @item @b{%D} The @i{display} field from the event. Valid for all event types. @item @b{%E} The @i{send_event} field from the event. Valid for all event types. @item @b{%K} The keysym corresponding to the event, substituted as a textual string. Valid only for @b{KeyPress} and @b{KeyRelease} events. @item @b{%N} The keysym corresponding to the event, substituted as a decimal number. Valid only for @b{KeyPress} and @b{KeyRelease} events. @item @b{%R} The @i{root} window identifier from the event. Valid only for events containing a @i{root} field. @item @b{%S} The @i{subwindow} window identifier from the event. Valid only for events containing a @i{subwindow} field. @item @b{%T} The @i{type} field from the event. Valid for all event types. @item @b{%W} The path name of the window to which the event was reported (the @i{window} field from the event). Valid for all event types. @item @b{%X} The @i{x_root} field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding x-coordinate in the virtual root. Valid only for @b{ButtonPress}, @b{ButtonRelease}, @b{KeyPress}, @b{KeyRelease}, and @b{MotionNotify} events. @item @b{%Y} The @i{y_root} field from the event. If a virtual-root window manager is being used then the substituted value is the corresponding y-coordinate in the virtual root. Valid only for @b{ButtonPress}, @b{ButtonRelease}, @b{KeyPress}, @b{KeyRelease}, and @b{MotionNotify} events. @end table If the replacement string for a %-replacement contains characters that are interpreted specially by the Tcl parser (such as backslashes or square brackets or spaces) additional backslashes are added during replacement so that the result after parsing is the original replacement string. For example, if @i{command} is @example @b{insert\0%A} @end example and the character typed is an open square bracket, then the command actually executed will be @example @b{insert\0\e[} @end example This will cause the @b{insert} to receive the original replacement string (open square bracket) as its first argument. If the extra backslash hadn't been added, Tcl would not have been able to parse the command correctly. At most one binding will trigger for any given X event. If several bindings match the recent events, the most specific binding is chosen and its command will be executed. The following tests are applied, in order, to determine which of several matching sequences is more specific: (a) a binding whose @i{windowSpec} names a particular window is more specific than a binding for a class, which is more specific than a binding whose @i{windowSpec} is @b{all}; (b) a longer sequence (in terms of number of events matched) is more specific than a shorter sequence; (c) an event pattern that specifies a specific button or key is more specific than one that doesn't; (e) an event pattern that requires a particular modifier is more specific than one that doesn't require the modifier; (e) an event pattern specifying the @b{Any} modifier is less specific than one that doesn't. If the matching sequences contain more than one event, then tests (c)-(e) are applied in order from the most recent event to the least recent event in the sequences. If these tests fail to determine a winner, then the most recently registered sequence is the winner. If an X event does not match any of the existing bindings, then the event is ignored (an unbound event is not considered to be an error). When a @i{sequence} specified in a @b{bind} command contains more than one event pattern, then its command is executed whenever the recent events (leading up to and including the current event) match the given sequence. This means, for example, that if button 1 is clicked repeatedly the sequence @b{} will match each button press but the first. If extraneous events that would prevent a match occur in the middle of an event sequence then the extraneous events are ignored unless they are @b{KeyPress} or @b{ButtonPress} events. For example, @b{} will match a sequence of presses of button 1, even though there will be @b{ButtonRelease} events (and possibly @b{MotionNotify} events) between the @b{ButtonPress} events. Furthermore, a @b{KeyPress} event may be preceded by any number of other @b{KeyPress} events for modifier keys without the modifier keys preventing a match. For example, the event sequence @b{aB} will match a press of the @b{a} key, a release of the @b{a} key, a press of the @b{Shift} key, and a press of the @b{b} key: the press of @b{Shift} is ignored because it is a modifier key. Finally, if several @b{MotionNotify} events occur in a row, only the last one is used for purposes of matching binding sequences. If an error occurs in executing the command for a binding then the @b{tkerror} mechanism is used to report the error. The command will be executed at global level (outside the context of any Tcl procedure). @unnumberedsubsec "See Also" tkerror @unnumberedsubsec Keywords form, manual gcl-2.6.14/info/chap-23.texi0000644000175000017500000013647014360276512013771 0ustar cammcamm @node Reader, System Construction, Printer, Top @chapter Reader @menu * Reader Concepts:: * Reader Dictionary:: @end menu @node Reader Concepts, Reader Dictionary, Reader, Reader @section Reader Concepts @c including concept-reader @menu * Dynamic Control of the Lisp Reader:: * Effect of Readtable Case on the Lisp Reader:: * Argument Conventions of Some Reader Functions:: @end menu @node Dynamic Control of the Lisp Reader, Effect of Readtable Case on the Lisp Reader, Reader Concepts, Reader Concepts @subsection Dynamic Control of the Lisp Reader Various aspects of the @i{Lisp reader} can be controlled dynamically. See @ref{Readtables} and @ref{Variables that affect the Lisp Reader}. @node Effect of Readtable Case on the Lisp Reader, Argument Conventions of Some Reader Functions, Dynamic Control of the Lisp Reader, Reader Concepts @subsection Effect of Readtable Case on the Lisp Reader The @i{readtable case} of the @i{current readtable} affects the @i{Lisp reader} in the following ways: @table @asis @item @t{:upcase} When the @i{readtable case} is @t{:upcase}, unescaped constituent @i{characters} are converted to @i{uppercase}, as specified in @ref{Reader Algorithm}. @item @t{:downcase} When the @i{readtable case} is @t{:downcase}, unescaped constituent @i{characters} are converted to @i{lowercase}. @item @t{:preserve} When the @i{readtable case} is @t{:preserve}, the case of all @i{characters} remains unchanged. @item @t{:invert} When the @i{readtable case} is @t{:invert}, then if all of the unescaped letters in the extended token are of the same @i{case}, those (unescaped) letters are converted to the opposite @i{case}. @end table @menu * Examples of Effect of Readtable Case on the Lisp Reader:: @end menu @node Examples of Effect of Readtable Case on the Lisp Reader, , Effect of Readtable Case on the Lisp Reader, Effect of Readtable Case on the Lisp Reader @subsubsection Examples of Effect of Readtable Case on the Lisp Reader @example (defun test-readtable-case-reading () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE Input Symbol-name~ ~ ~ (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (input '("ZEBRA" "Zebra" "zebra")) (format t "~&:~A~16T~A~24T~A" (string-upcase readtable-case) input (symbol-name (read-from-string input))))))) @end example The output from @t{(test-readtable-case-reading)} should be as follows: @example READTABLE-CASE Input Symbol-name ------------------------------------- :UPCASE ZEBRA ZEBRA :UPCASE Zebra ZEBRA :UPCASE zebra ZEBRA :DOWNCASE ZEBRA zebra :DOWNCASE Zebra zebra :DOWNCASE zebra zebra :PRESERVE ZEBRA ZEBRA :PRESERVE Zebra Zebra :PRESERVE zebra zebra :INVERT ZEBRA zebra :INVERT Zebra Zebra :INVERT zebra ZEBRA @end example @node Argument Conventions of Some Reader Functions, , Effect of Readtable Case on the Lisp Reader, Reader Concepts @subsection Argument Conventions of Some Reader Functions @menu * The EOF-ERROR-P argument:: * The RECURSIVE-P argument:: @end menu @node The EOF-ERROR-P argument, The RECURSIVE-P argument, Argument Conventions of Some Reader Functions, Argument Conventions of Some Reader Functions @subsubsection The EOF-ERROR-P argument @i{Eof-error-p} in input function calls controls what happens if input is from a file (or any other input source that has a definite end) and the end of the file is reached. If @i{eof-error-p} is @i{true} (the default), an error of @i{type} @b{end-of-file} is signaled at end of file. If it is @i{false}, then no error is signaled, and instead the function returns @i{eof-value}. Functions such as @b{read} that read the representation of an @i{object} rather than a single character always signals an error, regardless of @i{eof-error-p}, if the file ends in the middle of an object representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, @b{read} signals an error. If a file ends in a @i{symbol} or a @i{number} immediately followed by end-of-file, @b{read} reads the @i{symbol} or @i{number} successfully and when called again will act according to @i{eof-error-p}. Similarly, the @i{function} @b{read-line} successfully reads the last line of a file even if that line is terminated by end-of-file rather than the newline character. Ignorable text, such as lines containing only @i{whitespace}_2 or comments, are not considered to begin an @i{object}; if @b{read} begins to read an @i{expression} but sees only such ignorable text, it does not consider the file to end in the middle of an @i{object}. Thus an @i{eof-error-p} argument controls what happens when the file ends between @i{objects}. @node The RECURSIVE-P argument, , The EOF-ERROR-P argument, Argument Conventions of Some Reader Functions @subsubsection The RECURSIVE-P argument If @i{recursive-p} is supplied and not @b{nil}, it specifies that this function call is not an outermost call to @b{read} but an embedded call, typically from a @i{reader macro function}. It is important to distinguish such recursive calls for three reasons. @table @asis @item 1. An outermost call establishes the context within which the @t{#@i{n}=} and @t{#@i{n}#} syntax is scoped. Consider, for example, the expression @example (cons '#3=(p q r) '(x y . #3#)) @end example If the @i{single-quote} @i{reader macro} were defined in this way: @example (set-macro-character #\' ;incorrect #'(lambda (stream char) (declare (ignore char)) (list 'quote (read stream)))) @end example then each call to the @i{single-quote} @i{reader macro function} would establish independent contexts for the scope of @b{read} information, including the scope of identifications between markers like ``@t{#3=}'' and ``@t{#3#}''. However, for this expression, the scope was clearly intended to be determined by the outer set of parentheses, so such a definition would be incorrect. The correct way to define the @i{single-quote} @i{reader macro} uses @i{recursive-p}: @example (set-macro-character #\' ;correct #'(lambda (stream char) (declare (ignore char)) (list 'quote (read stream t nil t)))) @end example @item 2. A recursive call does not alter whether the reading process is to preserve @i{whitespace}_2 or not (as determined by whether the outermost call was to @b{read} or @b{read-preserving-whitespace}). Suppose again that @i{single-quote} were to be defined as shown above in the incorrect definition. Then a call to @b{read-preserving-whitespace} that read the expression @t{'foo<@i{Space}>} would fail to preserve the space character following the symbol @t{foo} because the @i{single-quote} @i{reader macro function} calls @b{read}, not @b{read-preserving-whitespace}, to read the following expression (in this case @t{foo}). The correct definition, which passes the value @i{true} for @i{recursive-p} to @b{read}, allows the outermost call to determine whether @i{whitespace}_2 is preserved. @item 3. When end-of-file is encountered and the @i{eof-error-p} argument is not @b{nil}, the kind of error that is signaled may depend on the value of @i{recursive-p}. If @i{recursive-p} is @i{true}, then the end-of-file is deemed to have occurred within the middle of a printed representation; if @i{recursive-p} is @i{false}, then the end-of-file may be deemed to have occurred between @i{objects} rather than within the middle of one. @end table @c end of including concept-reader @node Reader Dictionary, , Reader Concepts, Reader @section Reader Dictionary @c including dict-reader @menu * readtable:: * copy-readtable:: * make-dispatch-macro-character:: * read:: * read-delimited-list:: * read-from-string:: * readtable-case:: * readtablep:: * set-dispatch-macro-character:: * set-macro-character:: * set-syntax-from-char:: * with-standard-io-syntax:: * *read-base*:: * *read-default-float-format*:: * *read-eval*:: * *read-suppress*:: * *readtable*:: * reader-error:: @end menu @node readtable, copy-readtable, Reader Dictionary, Reader Dictionary @subsection readtable [System Class] @subsubheading Class Precedence List:: @b{readtable}, @b{t} @subsubheading Description:: A @i{readtable} maps @i{characters} into @i{syntax types} for the @i{Lisp reader}; see @ref{Syntax}. A @i{readtable} also contains associations between @i{macro characters} and their @i{reader macro functions}, and records information about the case conversion rules to be used by the @i{Lisp reader} when parsing @i{symbols}. Each @i{simple} @i{character} must be representable in the @i{readtable}. It is @i{implementation-defined} whether @i{non-simple} @i{characters} can have syntax descriptions in the @i{readtable}. @subsubheading See Also:: @ref{Readtables}, @ref{Printing Other Objects} @node copy-readtable, make-dispatch-macro-character, readtable, Reader Dictionary @subsection copy-readtable [Function] @code{copy-readtable} @i{@r{&optional} from-readtable to-readtable} @result{} @i{readtable} @subsubheading Arguments and Values:: @i{from-readtable}---a @i{readtable designator}. The default is the @i{current readtable}. @i{to-readtable}---a @i{readtable} or @b{nil}. The default is @b{nil}. @i{readtable}---the @i{to-readtable} if it is @i{non-nil}, or else a @i{fresh} @i{readtable}. @subsubheading Description:: @b{copy-readtable} copies @i{from-readtable}. If @i{to-readtable} is @b{nil}, a new @i{readtable} is created and returned. Otherwise the @i{readtable} specified by @i{to-readtable} is modified and returned. @b{copy-readtable} copies the setting of @b{readtable-case}. @subsubheading Examples:: @example (setq zvar 123) @result{} 123 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) @result{} T zvar @result{} 123 (copy-readtable table2 *readtable*) @result{} # zvar @result{} VAR (setq *readtable* (copy-readtable)) @result{} # zvar @result{} VAR (setq *readtable* (copy-readtable nil)) @result{} # zvar @result{} 123 @end example @subsubheading See Also:: @b{readtable}, @ref{readtable} @subsubheading Notes:: @example (setq *readtable* (copy-readtable nil)) @end example restores the input syntax to standard @r{Common Lisp} syntax, even if the @i{initial readtable} has been clobbered (assuming it is not so badly clobbered that you cannot type in the above expression). On the other hand, @example (setq *readtable* (copy-readtable)) @end example replaces the current @i{readtable} with a copy of itself. This is useful if you want to save a copy of a readtable for later use, protected from alteration in the meantime. It is also useful if you want to locally bind the readtable to a copy of itself, as in: @example (let ((*readtable* (copy-readtable))) ...) @end example @node make-dispatch-macro-character, read, copy-readtable, Reader Dictionary @subsection make-dispatch-macro-character [Function] @code{make-dispatch-macro-character} @i{char @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{char}---a @i{character}. @i{non-terminating-p}---a @i{generalized boolean}. The default is @i{false}. @i{readtable}---a @i{readtable}. The default is the @i{current readtable}. @subsubheading Description:: @b{make-dispatch-macro-character} makes @i{char} be a @i{dispatching macro character} in @i{readtable}. Initially, every @i{character} in the dispatch table associated with the @i{char} has an associated function that signals an error of @i{type} @b{reader-error}. If @i{non-terminating-p} is @i{true}, the @i{dispatching macro character} is made a @i{non-terminating} @i{macro character}; if @i{non-terminating-p} is @i{false}, the @i{dispatching macro character} is made a @i{terminating} @i{macro character}. @subsubheading Examples:: @example (get-macro-character #\@{) @result{} NIL, @i{false} (make-dispatch-macro-character #\@{) @result{} T (not (get-macro-character #\@{)) @result{} @i{false} @end example The @i{readtable} is altered. @subsubheading See Also:: @ref{readtable} , @ref{set-dispatch-macro-character} @node read, read-delimited-list, make-dispatch-macro-character, Reader Dictionary @subsection read, read-preserving-whitespace [Function] @code{read} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{object} @code{read-preserving-whitespace} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p}@* @result{} @i{object} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream designator}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{object}---an @i{object} (parsed by the @i{Lisp reader}) or the @i{eof-value}. @subsubheading Description:: @b{read} parses the printed representation of an @i{object} from @i{input-stream} and builds such an @i{object}. @b{read-preserving-whitespace} is like @b{read} but preserves any @i{whitespace}_2 @i{character} that delimits the printed representation of the @i{object}. @b{read-preserving-whitespace} is exactly like @b{read} when the @i{recursive-p} @i{argument} to @b{read-preserving-whitespace} is @i{true}. When @b{*read-suppress*} is @i{false}, @b{read} throws away the delimiting @i{character} required by certain printed representations if it is a @i{whitespace}_2 @i{character}; but @b{read} preserves the character (using @b{unread-char}) if it is syntactically meaningful, because it could be the start of the next expression. If a file ends in a @i{symbol} or a @i{number} immediately followed by an @i{end of file}_1, @b{read} reads the @i{symbol} or @i{number} successfully; when called again, it sees the @i{end of file}_1 and only then acts according to @i{eof-error-p}. If a file contains ignorable text at the end, such as blank lines and comments, @b{read} does not consider it to end in the middle of an @i{object}. If @i{recursive-p} is @i{true}, the call to @b{read} is expected to be made from within some function that itself has been called from @b{read} or from a similar input function, rather than from the top level. Both functions return the @i{object} read from @i{input-stream}. @i{Eof-value} is returned if @i{eof-error-p} is @i{false} and end of file is reached before the beginning of an @i{object}. @subsubheading Examples:: @example (read) @t{ |> } @b{|>>}@t{'a}@b{<<|} @result{} (QUOTE A) (with-input-from-string (is " ") (read is nil 'the-end)) @result{} THE-END (defun skip-then-read-char (s c n) (if (char= c #\@{) (read s t nil t) (read-preserving-whitespace s)) (read-char-no-hang s)) @result{} SKIP-THEN-READ-CHAR (let ((*readtable* (copy-readtable nil))) (set-dispatch-macro-character #\# #\@{ #'skip-then-read-char) (set-dispatch-macro-character #\# #\@} #'skip-then-read-char) (with-input-from-string (is "#@{123 x #@}123 y") (format t "~S ~S" (read is) (read is)))) @result{} #\x, #\Space, NIL @end example As an example, consider this @i{reader macro} definition: @example (defun slash-reader (stream char) (declare (ignore char)) `(path . ,(loop for dir = (read-preserving-whitespace stream t nil t) then (progn (read-char stream t nil t) (read-preserving-whitespace stream t nil t)) collect dir while (eql (peek-char nil stream nil nil t) #\/)))) (set-macro-character #\/ #'slash-reader) @end example Consider now calling @b{read} on this expression: @example (zyedh /usr/games/zork /usr/games/boggle) @end example The @t{/} macro reads objects separated by more @t{/} characters; thus @t{/usr/games/zork} is intended to read as @t{(path usr games zork)}. The entire example expression should therefore be read as @example (zyedh (path usr games zork) (path usr games boggle)) @end example However, if @b{read} had been used instead of @b{read-preserving-whitespace}, then after the reading of the symbol @t{zork}, the following space would be discarded; the next call to @b{peek-char} would see the following @t{/}, and the loop would continue, producing this interpretation: @example (zyedh (path usr games zork usr games boggle)) @end example There are times when @i{whitespace}_2 should be discarded. If a command interpreter takes single-character commands, but occasionally reads an @i{object} then if the @i{whitespace}_2 after a @i{symbol} is not discarded it might be interpreted as a command some time later after the @i{symbol} had been read. @subsubheading Affected By:: @b{*standard-input*}, @b{*terminal-io*}, @b{*readtable*}, @b{*read-default-float-format*}, @b{*read-base*}, @b{*read-suppress*}, @b{*package*}, @b{*read-eval*}. @subsubheading Exceptional Situations:: @b{read} signals an error of @i{type} @b{end-of-file}, regardless of @i{eof-error-p}, if the file ends in the middle of an @i{object} representation. For example, if a file does not contain enough right parentheses to balance the left parentheses in it, @b{read} signals an error. This is detected when @b{read} or @b{read-preserving-whitespace} is called with @i{recursive-p} and @i{eof-error-p} @i{non-nil}, and end-of-file is reached before the beginning of an @i{object}. If @i{eof-error-p} is @i{true}, an error of @i{type} @b{end-of-file} is signaled at the end of file. @subsubheading See Also:: @ref{peek-char} , @ref{read-char} , @ref{unread-char} , @ref{read-from-string} , @ref{read-delimited-list} , @ref{parse-integer} , @ref{Syntax}, @ref{Reader Concepts} @node read-delimited-list, read-from-string, read, Reader Dictionary @subsection read-delimited-list [Function] @code{read-delimited-list} @i{char @r{&optional} input-stream recursive-p} @result{} @i{list} @subsubheading Arguments and Values:: @i{char}---a @i{character}. @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{list}---a @i{list} of the @i{objects} read. @subsubheading Description:: @b{read-delimited-list} reads @i{objects} from @i{input-stream} until the next character after an @i{object}'s representation (ignoring @i{whitespace}_2 characters and comments) is @i{char}. @b{read-delimited-list} looks ahead at each step for the next non-@i{whitespace}_2 @i{character} and peeks at it as if with @b{peek-char}. If it is @i{char}, then the @i{character} is consumed and the @i{list} of @i{objects} is returned. If it is a @i{constituent} or @i{escape} @i{character}, then @b{read} is used to read an @i{object}, which is added to the end of the @i{list}. If it is a @i{macro character}, its @i{reader macro function} is called; if the function returns a @i{value}, that @i{value} is added to the @i{list}. The peek-ahead process is then repeated. If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} or a similar function. It is an error to reach end-of-file during the operation of @b{read-delimited-list}. The consequences are undefined if @i{char} has a @i{syntax type} of @i{whitespace}_2 in the @i{current readtable}. @subsubheading Examples:: @example (read-delimited-list #\@r{]}) 1 2 3 4 5 6 @r{]} @result{} (1 2 3 4 5 6) @end example Suppose you wanted @t{#@{@i{a} @i{b} @i{c} ... @i{z}@}} to read as a list of all pairs of the elements @i{a}, @i{b}, @i{c}, ..., @i{z}, for example. @example #@{p q z a@} reads as ((p q) (p z) (p a) (q z) (q a) (z a)) @end example This can be done by specifying a macro-character definition for @t{#@{} that does two things: reads in all the items up to the @t{@}}, and constructs the pairs. @b{read-delimited-list} performs the first task. @example (defun |#@{-reader| (stream char arg) (declare (ignore char arg)) (mapcon #'(lambda (x) (mapcar #'(lambda (y) (list (car x) y)) (cdr x))) (read-delimited-list #\@} stream t))) @result{} |#@{-reader| (set-dispatch-macro-character #\# #\@{ #'|#@{-reader|) @result{} T (set-macro-character #\@} (get-macro-character #\) @b{nil})) @end example Note that @i{true} is supplied for the @i{recursive-p} argument. It is necessary here to give a definition to the character @t{@}} as well to prevent it from being a constituent. If the line @example (set-macro-character #\@} (get-macro-character #\) @b{nil})) @end example shown above were not included, then the @t{@}} in @example #@{ p q z a@} @end example would be considered a constituent character, part of the symbol named @t{a@}}. This could be corrected by putting a space before the @t{@}}, but it is better to call @b{set-macro-character}. Giving @t{@}} the same definition as the standard definition of the character @t{)} has the twin benefit of making it terminate tokens for use with @b{read-delimited-list} and also making it invalid for use in any other context. Attempting to read a stray @t{@}} will signal an error. @subsubheading Affected By:: @b{*standard-input*}, @b{*readtable*}, @b{*terminal-io*}. @subsubheading See Also:: @ref{read} , @ref{peek-char} , @ref{read-char} , @ref{unread-char} . @subsubheading Notes:: @b{read-delimited-list} is intended for use in implementing @i{reader macros}. Usually it is desirable for @i{char} to be a @i{terminating} @i{macro character} so that it can be used to delimit tokens; however, @b{read-delimited-list} makes no attempt to alter the syntax specified for @i{char} by the current readtable. The caller must make any necessary changes to the readtable syntax explicitly. @node read-from-string, readtable-case, read-delimited-list, Reader Dictionary @subsection read-from-string [Function] @code{read-from-string} @i{string @r{&optional} eof-error-p eof-value @r{&key} start end preserve-whitespace}@* @result{} @i{object, position} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{preserve-whitespace}---a @i{generalized boolean}. The default is @i{false}. @i{object}---an @i{object} (parsed by the @i{Lisp reader}) or the @i{eof-value}. @i{position}---an @i{integer} greater than or equal to zero, and less than or equal to one more than the @i{length} of the @i{string}. @subsubheading Description:: Parses the printed representation of an @i{object} from the subsequence of @i{string} @i{bounded} by @i{start} and @i{end}, as if @b{read} had been called on an @i{input} @i{stream} containing those same @i{characters}. If @i{preserve-whitespace} is @i{true}, the operation will preserve @i{whitespace}_2 as @b{read-preserving-whitespace} would do. If an @i{object} is successfully parsed, the @i{primary value}, @i{object}, is the @i{object} that was parsed. If @i{eof-error-p} is @i{false} and if the end of the @i{substring} is reached, @i{eof-value} is returned. The @i{secondary value}, @i{position}, is the index of the first @i{character} in the @i{bounded} @i{string} that was not read. The @i{position} may depend upon the value of @i{preserve-whitespace}. If the entire @i{string} was read, the @i{position} returned is either the @i{length} of the @i{string} or one greater than the @i{length} of the @i{string}. @subsubheading Examples:: @example (read-from-string " 1 3 5" t nil :start 2) @result{} 3, 5 (read-from-string "(a b c)") @result{} (A B C), 7 @end example @subsubheading Exceptional Situations:: If the end of the supplied substring occurs before an @i{object} can be read, an error is signaled if @i{eof-error-p} is @i{true}. An error is signaled if the end of the @i{substring} occurs in the middle of an incomplete @i{object}. @subsubheading See Also:: @ref{read} , @b{read-preserving-whitespace} @subsubheading Notes:: The reason that @i{position} is allowed to be beyond the @i{length} of the @i{string} is to permit (but not require) the @i{implementation} to work by simulating the effect of a trailing delimiter at the end of the @i{bounded} @i{string}. When @i{preserve-whitespace} is @i{true}, the @i{position} might count the simulated delimiter. @node readtable-case, readtablep, read-from-string, Reader Dictionary @subsection readtable-case [Accessor] @code{readtable-case} @i{readtable} @result{} @i{mode} (setf (@code{ readtable-case} @i{readtable}) mode)@* @subsubheading Arguments and Values:: @i{readtable}---a @i{readtable}. @i{mode}---a @i{case sensitivity mode}. @subsubheading Description:: @i{Accesses} the @i{readtable case} of @i{readtable}, which affects the way in which the @i{Lisp Reader} reads @i{symbols} and the way in which the @i{Lisp Printer} writes @i{symbols}. @subsubheading Examples:: See @ref{Examples of Effect of Readtable Case on the Lisp Reader} and @ref{Examples of Effect of Readtable Case on the Lisp Printer}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{readtable} is not a @i{readtable}. Should signal an error of @i{type} @b{type-error} if @i{mode} is not a @i{case sensitivity mode}. @subsubheading See Also:: @ref{readtable} , @b{*print-escape*}, @ref{Reader Algorithm}, @ref{Effect of Readtable Case on the Lisp Reader}, @ref{Effect of Readtable Case on the Lisp Printer} @subsubheading Notes:: @b{copy-readtable} copies the @i{readtable case} of the @i{readtable}. @node readtablep, set-dispatch-macro-character, readtable-case, Reader Dictionary @subsection readtablep [Function] @code{readtablep} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{readtable}; otherwise, returns @i{false}. @subsubheading Examples:: @example (readtablep *readtable*) @result{} @i{true} (readtablep (copy-readtable)) @result{} @i{true} (readtablep '*readtable*) @result{} @i{false} @end example @subsubheading Notes:: @example (readtablep @i{object}) @equiv{} (typep @i{object} 'readtable) @end example @node set-dispatch-macro-character, set-macro-character, readtablep, Reader Dictionary @subsection set-dispatch-macro-character, get-dispatch-macro-character @flushright @i{[Function]} @end flushright @code{get-dispatch-macro-character} @i{disp-char sub-char @r{&optional} readtable} @result{} @i{function} @code{set-dispatch-macro-character} @i{disp-char sub-char new-function @r{&optional} readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{disp-char}---a @i{character}. @i{sub-char}---a @i{character}. @i{readtable}---a @i{readtable designator}. The default is the @i{current readtable}. @i{function}---a @i{function designator} or @b{nil}. @i{new-function}---a @i{function designator}. @subsubheading Description:: @b{set-dispatch-macro-character} causes @i{new-function} to be called when @i{disp-char} followed by @i{sub-char} is read. If @i{sub-char} is a lowercase letter, it is converted to its uppercase equivalent. It is an error if @i{sub-char} is one of the ten decimal digits. @b{set-dispatch-macro-character} installs a @i{new-function} to be called when a particular @i{dispatching macro character} pair is read. @i{New-function} is installed as the dispatch function to be called when @i{readtable} is in use and when @i{disp-char} is followed by @i{sub-char}. For more information about how the @i{new-function} is invoked, see @ref{Macro Characters}. @b{get-dispatch-macro-character} retrieves the dispatch function associated with @i{disp-char} and @i{sub-char} in @i{readtable}. @b{get-dispatch-macro-character} returns the macro-character function for @i{sub-char} under @i{disp-char}, or @b{nil} if there is no function associated with @i{sub-char}. If @i{sub-char} is a decimal digit, @b{get-dispatch-macro-character} returns @b{nil}. @subsubheading Examples:: @example (get-dispatch-macro-character #\# #\@{) @result{} NIL (set-dispatch-macro-character #\# #\@{ ;dispatch on #@{ #'(lambda(s c n) (let ((list (read s nil (values) t))) ;list is object after #n@{ (when (consp list) ;return nth element of list (unless (and n (< 0 n (length list))) (setq n 0)) (setq list (nth n list))) list))) @result{} T #@{(1 2 3 4) @result{} 1 #3@{(0 1 2 3) @result{} 3 #@{123 @result{} 123 @end example If it is desired that @t{#$@i{foo}} : as if it were @t{(dollars @i{foo})}. @example (defun |#$-reader| (stream subchar arg) (declare (ignore subchar arg)) (list 'dollars (read stream t nil t))) @result{} |#$-reader| (set-dispatch-macro-character #\# #\$ #'|#$-reader|) @result{} T @end example @subsubheading See Also:: @ref{Macro Characters} @subsubheading Side Effects:: The @i{readtable} is modified. @subsubheading Affected By:: @b{*readtable*}. @subsubheading Exceptional Situations:: For either function, an error is signaled if @i{disp-char} is not a @i{dispatching macro character} in @i{readtable}. @subsubheading See Also:: @ref{readtable} @subsubheading Notes:: It is necessary to use @b{make-dispatch-macro-character} to set up the dispatch character before specifying its sub-characters. @node set-macro-character, set-syntax-from-char, set-dispatch-macro-character, Reader Dictionary @subsection set-macro-character, get-macro-character [Function] @code{get-macro-character} @i{char @r{&optional} readtable} @result{} @i{function, non-terminating-p} @code{set-macro-character} @i{char new-function @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{char}---a @i{character}. @i{non-terminating-p}---a @i{generalized boolean}. The default is @i{false}. @i{readtable}---a @i{readtable designator}. The default is the @i{current readtable}. @i{function}---@b{nil}, or a @i{designator} for a @i{function} of two @i{arguments}. @i{new-function}---a @i{function designator}. @subsubheading Description:: @b{get-macro-character} returns as its @i{primary value}, @i{function}, the @i{reader macro function} associated with @i{char} in @i{readtable} (if any), or else @b{nil} if @i{char} is not a @i{macro character} in @i{readtable}. The @i{secondary value}, @i{non-terminating-p}, is @i{true} if @i{char} is a @i{non-terminating} @i{macro character}; otherwise, it is @i{false}. @b{set-macro-character} causes @i{char} to be a @i{macro character} associated with the @i{reader macro function} @i{new-function} (or the @i{designator} for @i{new-function}) in @i{readtable}. If @i{non-terminating-p} is @i{true}, @i{char} becomes a @i{non-terminating} @i{macro character}; otherwise it becomes a @i{terminating} @i{macro character}. @subsubheading Examples:: @example (get-macro-character #\@{) @result{} NIL, @i{false} (not (get-macro-character #\;)) @result{} @i{false} @end example The following is a possible definition for the @i{single-quote} @i{reader macro} in @i{standard syntax}: @example (defun single-quote-reader (stream char) (declare (ignore char)) (list 'quote (read stream t nil t))) @result{} SINGLE-QUOTE-READER (set-macro-character #\' #'single-quote-reader) @result{} T @end example Here @t{single-quote-reader} reads an @i{object} following the @i{single-quote} and returns a @i{list} of @b{quote} and that @i{object}. The @i{char} argument is ignored. The following is a possible definition for the @i{semicolon} @i{reader macro} in @i{standard syntax}: @example (defun semicolon-reader (stream char) (declare (ignore char)) ;; First swallow the rest of the current input line. ;; End-of-file is acceptable for terminating the comment. (do () ((char= (read-char stream nil #\Newline t) #\Newline))) ;; Return zero values. (values)) @result{} SEMICOLON-READER (set-macro-character #\; #'semicolon-reader) @result{} T @end example @subsubheading Side Effects:: The @i{readtable} is modified. @subsubheading See Also:: @ref{readtable} @node set-syntax-from-char, with-standard-io-syntax, set-macro-character, Reader Dictionary @subsection set-syntax-from-char [Function] @code{set-syntax-from-char} @i{to-char from-char @r{&optional} to-readtable from-readtable} @result{} @i{@b{t}} @subsubheading Arguments and Values:: @i{to-char}---a @i{character}. @i{from-char}---a @i{character}. @i{to-readtable}---a @i{readtable}. The default is the @i{current readtable}. @i{from-readtable}---a @i{readtable designator}. The default is the @i{standard readtable}. @subsubheading Description:: @b{set-syntax-from-char} makes the syntax of @i{to-char} in @i{to-readtable} be the same as the syntax of @i{from-char} in @i{from-readtable}. @b{set-syntax-from-char} copies the @i{syntax types} of @i{from-char}. If @i{from-char} is a @i{macro character}, its @i{reader macro function} is copied also. If the character is a @i{dispatching macro character}, its entire dispatch table of @i{reader macro functions} is copied. The @i{constituent traits} of @i{from-char} are not copied. A macro definition from a character such as @t{"} can be copied to another character; the standard definition for @t{"} looks for another character that is the same as the character that invoked it. The definition of @t{(} can not be meaningfully copied to @t{@{}, on the other hand. The result is that @i{lists} are of the form @t{@{a b c)}, not @t{@{a b c@}}, because the definition always looks for a closing parenthesis, not a closing brace. @subsubheading Examples:: @example (set-syntax-from-char #\7 #\;) @result{} T 123579 @result{} 1235 @end example @subsubheading Side Effects:: The @i{to-readtable} is modified. @subsubheading Affected By:: The existing values in the @i{from-readtable}. @subsubheading See Also:: @ref{set-macro-character} , @ref{make-dispatch-macro-character} , @ref{Character Syntax Types} @subsubheading Notes:: The @i{constituent traits} of a @i{character} are ``hard wired'' into the parser for extended @i{tokens}. For example, if the definition of @t{S} is copied to @t{*}, then @t{*} will become a @i{constituent} that is @i{alphabetic}_2 but that cannot be used as a @i{short float} @i{exponent marker}. For further information, see @ref{Constituent Traits}. @node with-standard-io-syntax, *read-base*, set-syntax-from-char, Reader Dictionary @subsection with-standard-io-syntax [Macro] @code{with-standard-io-syntax} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Within the dynamic extent of the body of @i{forms}, all reader/printer control variables, including any @i{implementation-defined} ones not specified by this standard, are bound to values that produce standard read/print behavior. The values for the variables specified by this standard are listed in Figure 23--1. [Reviewer Note by Barrett: *print-pprint-dispatch* should probably be mentioned here, too.] @format @group @noindent @w{ Variable Value } @w{ @b{*package*} The @t{CL-USER} @i{package} } @w{ @b{*print-array*} @b{t} } @w{ @b{*print-base*} @t{10} } @w{ @b{*print-case*} @t{:upcase} } @w{ @b{*print-circle*} @b{nil} } @w{ @b{*print-escape*} @b{t} } @w{ @b{*print-gensym*} @b{t} } @w{ @b{*print-length*} @b{nil} } @w{ @b{*print-level*} @b{nil} } @w{ @b{*print-lines*} @b{nil} } @w{ @b{*print-miser-width*} @b{nil} } @w{ @b{*print-pprint-dispatch*} The @i{standard pprint dispatch table} } @w{ @b{*print-pretty*} @b{nil} } @w{ @b{*print-radix*} @b{nil} } @w{ @b{*print-readably*} @b{t} } @w{ @b{*print-right-margin*} @b{nil} } @w{ @b{*read-base*} @t{10} } @w{ @b{*read-default-float-format*} @b{single-float} } @w{ @b{*read-eval*} @b{t} } @w{ @b{*read-suppress*} @b{nil} } @w{ @b{*readtable*} The @i{standard readtable} } @noindent @w{ Figure 23--1: Values of standard control variables } @end group @end format @subsubheading Examples:: @example (with-open-file (file pathname :direction :output) (with-standard-io-syntax (print data file))) ;;; ... Later, in another Lisp: (with-open-file (file pathname :direction :input) (with-standard-io-syntax (setq data (read file)))) @end example @node *read-base*, *read-default-float-format*, with-standard-io-syntax, Reader Dictionary @subsection *read-base* [Variable] @subsubheading Value Type:: a @i{radix}. @subsubheading Initial Value:: @t{10}. @subsubheading Description:: Controls the interpretation of tokens by @b{read} as being @i{integers} or @i{ratios}. The @i{value} of @b{*read-base*}, called the @i{current input base} @IGindex current input base , is the radix in which @i{integers} and @i{ratios} are to be read by the @i{Lisp reader}. The parsing of other numeric @i{types} (@i{e.g.}, @i{floats}) is not affected by this option. The effect of @b{*read-base*} on the reading of any particular @i{rational} number can be locally overridden by explicit use of the @t{#O}, @t{#X}, @t{#B}, or @t{#@i{n}R} syntax or by a trailing decimal point. @subsubheading Examples:: @example (dotimes (i 6) (let ((*read-base* (+ 10. i))) (let ((object (read-from-string "(\\DAD DAD |BEE| BEE 123. 123)"))) (print (list *read-base* object))))) @t{ |> } (10 (DAD DAD BEE BEE 123 123)) @t{ |> } (11 (DAD DAD BEE BEE 123 146)) @t{ |> } (12 (DAD DAD BEE BEE 123 171)) @t{ |> } (13 (DAD DAD BEE BEE 123 198)) @t{ |> } (14 (DAD 2701 BEE BEE 123 227)) @t{ |> } (15 (DAD 3088 BEE 2699 123 258)) @result{} NIL @end example @subsubheading Notes:: Altering the input radix can be useful when reading data files in special formats. @node *read-default-float-format*, *read-eval*, *read-base*, Reader Dictionary @subsection *read-default-float-format* [Variable] @subsubheading Value Type:: one of the @i{atomic type specifiers} @b{short-float}, @b{single-float}, @b{double-float}, or @b{long-float}, or else some other @i{type specifier} defined by the @i{implementation} to be acceptable. @subsubheading Initial Value:: The @i{symbol} @b{single-float}. @subsubheading Description:: Controls the floating-point format that is to be used when reading a floating-point number that has no @i{exponent marker} or that has @t{e} or @t{E} for an @i{exponent marker}. Other @i{exponent markers} explicitly prescribe the floating-point format to be used. The printer uses @b{*read-default-float-format*} to guide the choice of @i{exponent markers} when printing floating-point numbers. @subsubheading Examples:: @example (let ((*read-default-float-format* 'double-float)) (read-from-string "(1.0 1.0e0 1.0s0 1.0f0 1.0d0 1.0L0)")) @result{} (1.0 1.0 1.0 1.0 1.0 1.0) ;Implementation has float format F. @result{} (1.0 1.0 1.0s0 1.0 1.0 1.0) ;Implementation has float formats S and F. @result{} (1.0d0 1.0d0 1.0 1.0 1.0d0 1.0d0) ;Implementation has float formats F and D. @result{} (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0d0) ;Implementation has float formats S, F, D. @result{} (1.0d0 1.0d0 1.0 1.0 1.0d0 1.0L0) ;Implementation has float formats F, D, L. @result{} (1.0d0 1.0d0 1.0s0 1.0 1.0d0 1.0L0) ;Implementation has formats S, F, D, L. @end example @node *read-eval*, *read-suppress*, *read-default-float-format*, Reader Dictionary @subsection *read-eval* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{true}. @subsubheading Description:: If it is @i{true}, the @t{#.} @i{reader macro} has its normal effect. Otherwise, that @i{reader macro} signals an error of @i{type} @b{reader-error}. @subsubheading See Also:: @b{*print-readably*} @subsubheading Notes:: If @b{*read-eval*} is @i{false} and @b{*print-readably*} is @i{true}, any @i{method} for @b{print-object} that would output a reference to the @t{#.} @i{reader macro} either outputs something different or signals an error of @i{type} @b{print-not-readable}. @node *read-suppress*, *readtable*, *read-eval*, Reader Dictionary @subsection *read-suppress* [Variable] @subsubheading Value Type:: a @i{generalized boolean}. @subsubheading Initial Value:: @i{false}. @subsubheading Description:: This variable is intended primarily to support the operation of the read-time conditional notations @t{#+} and @t{#-}. It is important for the @i{reader macros} which implement these notations to be able to skip over the printed representation of an @i{expression} despite the possibility that the syntax of the skipped @i{expression} may not be entirely valid for the current implementation, since @t{#+} and @t{#-} exist in order to allow the same program to be shared among several @r{Lisp} implementations (including dialects other than @r{Common Lisp}) despite small incompatibilities of syntax. If it is @i{false}, the @i{Lisp reader} operates normally. If the @i{value} of @b{*read-suppress*} is @i{true}, @b{read}, @b{read-preserving-whitespace}, @b{read-delimited-list}, and @b{read-from-string} all return a @i{primary value} of @b{nil} when they complete successfully; however, they continue to parse the representation of an @i{object} in the normal way, in order to skip over the @i{object}, and continue to indicate @i{end of file} in the normal way. Except as noted below, any @i{standardized} @i{reader macro}_2 that is defined to @i{read}_2 a following @i{object} or @i{token} will do so, but not signal an error if the @i{object} read is not of an appropriate type or syntax. The @i{standard syntax} and its associated @i{reader macros} will not construct any new @i{objects} (@i{e.g.}, when reading the representation of a @i{symbol}, no @i{symbol} will be constructed or interned). @table @asis @item Extended tokens All extended tokens are completely uninterpreted. Errors such as those that might otherwise be signaled due to detection of invalid @i{potential numbers}, invalid patterns of @i{package markers}, and invalid uses of the @i{dot} character are suppressed. @item Dispatching macro characters (including @i{sharpsign}) @i{Dispatching macro characters} continue to parse an infix numerical argument, and invoke the dispatch function. The @i{standardized} @i{sharpsign} @i{reader macros} do not enforce any constraints on either the presence of or the value of the numerical argument. @item #= The @t{#=} notation is totally ignored. It does not read a following @i{object}. It produces no @i{object}, but is treated as @i{whitespace}_2. @item ## The @t{##} notation always produces @b{nil}. @end table No matter what the @i{value} of @b{*read-suppress*}, parentheses still continue to delimit and construct @i{lists}; the @t{#(} notation continues to delimit @i{vectors}; and comments, @i{strings}, and the @i{single-quote} and @i{backquote} notations continue to be interpreted properly. Such situations as @t{')}, @t{#<}, @t{#)}, and @t{#<@i{Space}>} continue to signal errors. @subsubheading Examples:: @example (let ((*read-suppress* t)) (mapcar #'read-from-string '("#(foo bar baz)" "#P(:type :lisp)" "#c1.2" "#.(PRINT 'FOO)" "#3AHELLO" "#S(INTEGER)" "#*ABC" "#\GARBAGE" "#RALPHA" "#3R444"))) @result{} (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) @end example @subsubheading See Also:: @ref{read} , @ref{Syntax} @subsubheading Notes:: @i{Programmers} and @i{implementations} that define additional @i{macro characters} are strongly encouraged to make them respect @b{*read-suppress*} just as @i{standardized} @i{macro characters} do. That is, when the @i{value} of @b{*read-suppress*} is @i{true}, they should ignore type errors when reading a following @i{object} and the @i{functions} that implement @i{dispatching macro characters} should tolerate @b{nil} as their infix @i{parameter} value even if a numeric value would ordinarily be required. @node *readtable*, reader-error, *read-suppress*, Reader Dictionary @subsection *readtable* [Variable] @subsubheading Value Type:: a @i{readtable}. @subsubheading Initial Value:: A @i{readtable} that conforms to the description of @r{Common Lisp} syntax in @ref{Syntax}. @subsubheading Description:: The @i{value} of @b{*readtable*} is called the @i{current readtable}. It controls the parsing behavior of the @i{Lisp reader}, and can also influence the @i{Lisp printer} (@i{e.g.}, see the @i{function} @b{readtable-case}). @subsubheading Examples:: @example (readtablep *readtable*) @result{} @i{true} (setq zvar 123) @result{} 123 (set-syntax-from-char #\z #\' (setq table2 (copy-readtable))) @result{} T zvar @result{} 123 (setq *readtable* table2) @result{} # zvar @result{} VAR (setq *readtable* (copy-readtable nil)) @result{} # zvar @result{} 123 @end example @subsubheading Affected By:: @b{compile-file}, @b{load} @subsubheading See Also:: @ref{compile-file} , @ref{load} , @ref{readtable} , @ref{The Current Readtable} @node reader-error, , *readtable*, Reader Dictionary @subsection reader-error [Condition Type] @subsubheading Class Precedence List:: @b{reader-error}, @b{parse-error}, @b{stream-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{reader-error} consists of error conditions that are related to tokenization and parsing done by the @i{Lisp reader}. @subsubheading See Also:: @ref{read} , @ref{stream-error-stream} , @ref{Reader Concepts} @c end of including dict-reader @c %**end of chapter gcl-2.6.14/info/si-defs.texi0000755000175000017500000010364314360276512014165 0ustar cammcamm @node System Definitions, Debugging, C Interface, Top @chapter System Definitions @defun ALLOCATE-CONTIGUOUS-PAGES (number &optional (really-allocate nil)) Package:SI GCL specific: Sets the maximum number of pages for contiguous blocks to NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified number of pages will be allocated immediately. @end defun @defun FREEZE-DEFSTRUCT (name) Package:SI The inline defstruct type checker will be made more efficient, in that it will only check for types which currently include NAME. After calling this the defstruct should not be altered. @end defun @defun MAXIMUM-ALLOCATABLE-PAGES (type) Package:SI GCL specific: Returns the current maximum number of pages for the type class of the GCL implementation type TYPE. @end defun @defun ALLOCATED-RELOCATABLE-PAGES () Package:SI GCL specific: Returns the number of pages currently allocated for relocatable blocks. @end defun @defun PUTPROP (symbol value indicator) Package:SI Give SYMBOL the VALUE on INDICATOR property. @end defun @defun ALLOCATED-PAGES (type) Package:SI GCL specific: Returns the number of pages currently allocated for the type class of the GCL implementation type TYPE. @end defun @defun ALLOCATE-RELOCATABLE-PAGES (number) Package:SI GCL specific: Sets the maximum number of pages for relocatable blocks to NUMBER. @end defun @defun ALLOCATED-CONTIGUOUS-PAGES () Package:SI GCL specific: Returns the number of pages currently allocated for contiguous blocks. @end defun @defun MAXIMUM-CONTIGUOUS-PAGES () Package:SI GCL specific: Returns the current maximum number of pages for contiguous blocks. @end defun @defun GET-HOLE-SIZE () Package:SI GCL specific: Returns as a fixnum the size of the memory hole (in pages). @end defun @defun SPECIALP (symbol) Package:SI GCL specific: Returns T if the SYMBOL is a globally special variable; NIL otherwise. @end defun @defun OUTPUT-STREAM-STRING (string-output-stream) Package:SI GCL specific: Returns the string corresponding to the STRING-OUTPUT-STREAM. @end defun @defun GET-STRING-INPUT-STREAM-INDEX (string-input-stream) Package:SI GCL specific: Returns the current index of the STRING-INPUT-STREAM. @end defun @defun STRING-CONCATENATE (&rest strings) Package:SI GCL specific: Returns the result of concatenating the given STRINGS. @end defun @defun BDS-VAR (i) Package:SI GCL specific: Returns the symbol of the i-th entity in the bind stack. @end defun @defun ERROR-SET (form) Package:SI GCL specific: Evaluates the FORM in the null environment. If the evaluation of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first value and the result of the evaluation as the rest of the values. If, in the course of the evaluation, a non-local jump from the FORM is atempted, SI:ERROR-SET traps the jump and returns the corresponding jump tag as its value. @end defun @defun COMPILED-FUNCTION-NAME (compiled-function-object) Package:SI GCL specific: Returns the name of the COMPILED-FUNCTION-OBJECT. @end defun @defun STRUCTUREP (object) Package:SI GCL specific: Returns T if the OBJECT is a structure; NIL otherwise. @end defun @defun IHS-VS (i) Package:SI GCL specific: Returns the value stack index of the i-th entity in the invocation history stack. @end defun @defun UNIVERSAL-ERROR-HANDLER (error-name correctable function-name continue-format-string error-format-string &rest args) Package:SI GCL specific: Starts the error handler of GCL. When an error is detected, GCL calls SI:UNIVERSAL-ERROR-HANDLER with the specified arguments. ERROR-NAME is the name of the error. CORRECTABLE is T for a correctable error and NIL for a fatal error. FUNCTION-NAME is the name of the function that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the format strings of the error message. ARGS are the arguments to the format strings. To change the error handler of GCL, redefine SI:UNIVERSAL-ERROR- HANDLER. @end defun @defvar *INTERRUPT-ENABLE* Package:SI GCL specific: If the value of SI:*INTERRUPT-ENABLE* is non-NIL, GCL signals an error on the terminal interrupt (this is the default case). If it is NIL, GCL ignores the interrupt and assigns T to SI:*INTERRUPT-ENABLE*. @end defvar @defun CHDIR (pathname) Package:SI GCL/UNIX specific: Changes the current working directory to the specified pathname. @end defun @defun COPY-STREAM (in-stream out-stream) Package:SI GCL specific: Copies IN-STREAM to OUT-STREAM until the end-of-file on IN- STREAM. @end defun @defun INIT-SYSTEM () Package:SI GCL specific: Initializes the library and the compiler of GCL. Since they have already been initialized in the standard image of GCL, calling SI:INIT- SYSTEM will cause an error. @end defun @defvar *INDENT-FORMATTED-OUTPUT* Package:SI GCL specific: The FORMAT directive ~% indents the next line if the value of this variable is non-NIL. If NIL, ~% simply does Newline. @end defvar @defun SET-HOLE-SIZE (fixnum) Package:SI GCL specific: Sets the size of the memory hole (in pages). @end defun @defun FRS-BDS (i) Package:SI GCL specific: Returns the bind stack index of the i-th entity in the frame stack. @end defun @defun IHS-FUN (i) Package:SI GCL specific: Returns the function value of the i-th entity in the invocation history stack. @end defun @defun *MAKE-CONSTANT (symbol value) Package:SI GCL specific: Makes the SYMBOL a constant with the specified VALUE. @end defun @defun FIXNUMP (object) Package:SI GCL specific: Returns T if the OBJECT is a fixnum; NIL otherwise. @end defun @defun BDS-VAL (i) Package:SI GCL specific: Returns the value of the i-th entity in the bind stack. @end defun @defun STRING-TO-OBJECT (string) Package:SI GCL specific: (SI:STRING-TO-OBJECT STRING) is equivalent to (READ-FROM-STRING STRING), but much faster. @end defun @defvar *SYSTEM-DIRECTORY* Package:SI GCL specific: Holds the name of the system directory of GCL. @end defvar @defun FRS-IHS (i) Package:SI GCL specific: Returns the invocation history stack index of the i-th entity in the frame stack. @end defun @defun RESET-GBC-COUNT () Package:SI GCL specific: Resets the counter of the garbage collector that records how many times the garbage collector has been called for each implementation type. @end defun @defun CATCH-BAD-SIGNALS () Package:SI GCL/BSD specific: Installs a signal catcher for bad signals: SIGILL, SIGIOT, SIGEMT, SIGBUS, SIGSEGV, SIGSYS. The signal catcher, upon catching the signal, signals an error (and enter the break-level). Since the internal memory of GCL may be broken, the user should check the signal and exit from GCL if necessary. When the signal is caught during garbage collection, GCL terminates immediately. @end defun @defun RESET-STACK-LIMITS () Package:SI GCL specific: Resets the stack limits to the normal state. When a stack has overflowed, GCL extends the limit for the stack in order to execute the error handler. After processing the error, GCL resets the stack limit by calling SI:RESET-STACK-LIMITS. @end defun @defvar *GBC-MESSAGE* Package:SI GCL specific: If the value of SI:*GBC-MESSAGE* is non-NIL, the garbage collector prints some information on the terminal. Usually SI:*GBC-MESSAGE* should be set NIL. @end defvar @defvar *GBC-NOTIFY* Package:SI GCL specific: If the value is non-NIL, the garbage collector prints a very brief one line message about the area causing the collection, and the time spent in internal time units. @end defvar @defvar *AFTER-GBC-HOOK* Package:SI Defaults to nil, but may be set to a function of one argument TYPE which is a lisp variable indicating the TYPE which caused the current collection. @end defvar @deffn {Funcition} ALLOCATED (type) Package:SI Returns 6 values: @table @asis @item nfree number free @item npages number of pages @item maxpage number of pages to grow to @item nppage number per page @item gbccount number of gc's due to running out of items of this size @item nused number of items used @end table Note that all items of the same size are stored on similar pages. Thus for example on a 486 under linux the following basic types are all the same size and so will share the same allocated information: CONS BIGNUM RATIO COMPLEX STRUCTURE. @end deffn @defun *MAKE-SPECIAL (symbol) Package:SI GCL specific: Makes the SYMBOL globally special. @end defun @defun MAKE-STRING-OUTPUT-STREAM-FROM-STRING (string) Package:SI GCL specific: Creates a string-output-stream corresponding to the STRING and returns it. The STRING should have a fill-pointer. @end defun @defvar *IGNORE-EOF-ON-TERMINAL-IO* Package:SI GCL specific: If the value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is non-NIL, GCL ignores the eof-character (usually ^D) on the terminal and the terminal never becomes end-of-file. The default value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is NIL. @end defvar @defun ADDRESS (object) Package:SI GCL specific: Returns the address of the OBJECT as a fixnum. The address of an object depends on the version of GCL. E.g. (SI:ADDRESS NIL) returns 1879062044 on GCL/AOSVS dated March 14, 1986. @end defun @defvar *LISP-MAXPAGES* Package:SI GCL specific: Holds the maximum number of pages (1 page = 2048 bytes) for the GCL process. The result of changing the value of SI:*LISP-MAXPAGES* is unpredictable. @end defvar @defun ARGC () Package:SI GCL specific: Returns the number of arguments on the command line that invoked the GCL process. @end defun @defun NANI (fixnum) Package:SI GCL specific: Returns the object in the address FIXNUM. This function is the inverse of SI:ADDRESS. Although SI:ADDRESS is a harmless operation, SI:NANI is quite dangerous and should be used with care. @end defun @defvar *NOTIFY-GBC* Package:SI GCL specific: If the value of this variable is non-NIL, then the garbage collector notifies that it begins to run whenever it is invoked. Otherwise, garbage collection begins silently. @end defvar @defun SAVE-SYSTEM (pathname) Package:SI GCL specific: Saves the current GCL core imange into a program file specified by PATHNAME. This function differs from SAVE in that the contiguous and relocatable areas are made permanent in the saved image. Usually the standard image of GCL interpreter/compiler is saved by SI:SAVE-SYSTEM. This function causes an exit from lisp. Various changes are made to the memory of the running system, such as closing files and resetting io streams. It would not be possible to continue normally. @end defun @defun UNCATCH-BAD-SIGNALS () Package:SI GCL/BSD specific: Undoes the effect of SI:CATCH-BAD-SIGNALS. @end defun @defun VS (i) Package:SI GCL specific: Returns the i-th entity in the value stack. @end defun @defun DISPLACED-ARRAY-P (array) Package:SI GCL specific: Returns T if the ARRAY is a displaced array; NIL otherwise. @end defun @defun ARGV (fixnum) Package:SI GCL specific: Returns the FIXNUM-th argument on the command line that invoked the GCL process. @end defun @defvar *DEFAULT-TIME-ZONE* Package:SI GCL specific: Holds the default time zone. The initial value of SI:*DEFAULT- TIME-ZONE* is 6 (the time zone of Austin, Texas). @end defvar @defun GETENV (string) Package:SI GCL/UNIX specific: Returns the environment with the name STRING as a string; if the environment specified by STRING is not found, returns NIL. @end defun @defun FASLINK (file string) Package:SI GCL/BSD specific: Loads the FASL file FILE while linking the object files and libraries specified by STRING. For example, (faslink "foo.o" "bar.o boo.o -lpixrect") loads foo.o while linking two object files (bar.o and boo.o) and the library pixrect. Usually, foo.o consists of the C language interface for the functions defined in the object files or the libraries. A more portable way of making references to C code, is to build it in at the time of the original make. If foo.c references things in -lpixrect, and foo.o is its compilation in the gcl/unixport directory (cd gcl/unixport ; make "EXTRAS= foo.o -lpixrect ") should add them. If EXTRAS was already joe.o in the unixport/makefile you should of course add joe.o to the above "EXTRAS= joe.o foo.o.." Faslink does not work on most UNIX systems which are derived from SYS V or AIX. @end defun @defun TOP-LEVEL () Package:SI GCL specific: Starts the standard top-level listner of GCL. When the GCL process is invoked, it calls SI:TOP-LEVEL by (FUNCALL 'SI:TOP-LEVEL). To change the top-level of GCL, redefine SI:TOP-LEVEL and save the core imange in a file. When the saved imange is invoked, it will start the redefined top-level. @end defun @defun FRS-VS (i) Package:SI GCL specific: Returns the value stack index of the i-th entity in the frame stack. @end defun @defun WRITE-DEBUG-SYMBOLS (start file &key (main-file "/usr/local/schelter/xgcl/unixport/raw_gcl") (output-file "debug-symbols.o" )) Package:SI Write out a file of debug-symbols using address START as the place where FILE will be loaded into the running executable MAIN-FILE. The last is a keyword argument. @end defun @defun PROF (x y) Package:SI These functions in the SI package are GCL specific, and allow monitoring the run time of functions loaded into GCL, as well as the basic functions. Sample Usage: (si::set-up-profile 1000000) (si::prof 0 90) run program (si::prof 0 0) ;; turn off profile (si::display-prof) (si::clear-profile) (si::prof 0 90) ;; start profile again run program .. Profile can be stopped with (si::prof 0 0) and restarted with (si::prof 0 90) The START-ADDRESS will correspond to the beginning of the profile array, and the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the profile array. Thus if the profile array is 1,000,000 bytes long and the code segment is 5 megabytes long you can profile the whole thing using a scale of 50 Note that long runs may result in overflow, and so an understating of the time in a function. You must run intensively however since, with a scale of 128 it takes 6,000,000 times through a loop to overflow the sampling in one part of the code. @end defun @defun CATCH-FATAL (i) Package:SI Sets the value of the C variable catch_fatal to I which should be an integer. If catch_fatal is 1, then most unrecoverable fatal errors will be caught. Upon catching such an error catch_fatal becomes -1, to avoid recursive errors. The top level loop automatically sets catch_fatal to 1, if the value is less than zero. Catching can be turned off by making catch_fatal = 0. @end defun @defvar *MULTIPLY-STACKS* Package:SI If this variable is set to a positive fixnum, then the next time through the TOP-LEVEL loop, the loop will be exited. The size of the stacks will be multiplied by the value of *multiply-stacks*, and the TOP-LEVEL will be called again. Thus to double the size of the stacks: >(setq si::*multiply-stacks* 2) [exits top level and reinvokes it, with the new stacks in place] > We must exit TOP-LEVEL, because it and any other lisp functions maintain many pointers into the stacks, which would be incorrect when the stacks have been moved. Interrupting the process of growing the stacks, can leave you in an inconsistent state. @end defvar @defun GBC-TIME (&optional x) Package:SI Sets the internal C variable gc_time to X if X is supplied and then returns gc_time. If gc_time is greater or equal to 0, then gc_time is incremented by the garbage collector, according to the number of internal time units spent there. The initial value of gc_time is -1. @end defun @defun FWRITE (string start count stream) Package:SI Write from STRING starting at char START (or 0 if it is nil) COUNT characters (or to end if COUNT is nil) to STREAM. STREAM must be a stream such as returned by FP-OUTPUT-STREAM. Returns nil if it fails. @end defun @defun FREAD (string start count stream) Package:SI Read characters into STRING starting at char START (or 0 if it is nil) COUNT characters (or from start to length of STRING if COUNT is nil). Characters are read from STREAM. STREAM must be a stream such as returned by FP-INPUT-STREAM. Returns nil if it fails. Return number of characters read if it succeeds. @end defun @defun SGC-ON (&optional ON) Package:SI If ON is not nil then SGC (stratified garbage collection) is turned on. If ON is supplied and is nil, then SGC is turned off. If ON is not supplied, then it returns T if SGC is on, and NIL if SGC is off. The purpose of SGC is to prevent paging activity during garbage collection. It is efficient if the actual number of pages being written to form a small percentage of the total image size. The image should be built as compactly as possible. This can be accomplished by using a settings such as (si::allocate-growth 'cons 1 10 50 20) to limit the growth in the cons maxpage to 10 pages per time. Then just before calling si::save-system to save your image you can do something like: (si::set-hole-size 500)(gbc nil) (si::sgc-on t) (si::save-system ..) This makes the saved image come up with SGC on. We have set a reasonably large hole size. This is so that allocation of pages either because they fill up, or through specific calls to si::allocate, will not need to move all the relocatable data. Moving relocatable data requires turning SGC off, performing a full gc, and then turning it back on. New relocatable data is collected by SGC, but moving the old requires going through all pages of memory to change pointers into it. Using si::*notify-gbc* gives information about the number of pages used by SGC. Note that SGC is only available on operating systems which provide the mprotect system call, to write protect pages. Otherwise we cannot tell which pages have been written too. @end defun @defun ALLOCATE-SGC (type min-pages max-pages percent-free) Package:SI If MIN-PAGES is 0, then this type will not be swept by SGC. Otherwise this is the minimum number of pages to make available to SGC. MAX-PAGES is the upper limit of such pages. Only pages with PERCENT-FREE objects on them, will be assigned to SGC. A list of the previous values for min, max and percent are returned. @end defun @defun ALLOCATE-GROWTH (type min max percent percent-free) Package:SI The next time after a garbage collection for TYPE, if PERCENT-FREE of the objects of this TYPE are not actually free, and if the maximum number of pages for this type has already been allocated, then the maximum number will be increased by PERCENT of the old maximum, subject to the condition that this increment be at least MIN pages and at most MAX pages. A list of the previous values for min, max, percent, and percent-free for the type TYPE is returned. A value of 0 means use the system default, and if an argument is out of range then the current values are returned with no change made. Examples: (si::allocate-growth 'cons 1 10 50 10) would insist that after a garbage collection for cons, there be at least 10% cons's free. If not the number of cons pages would be grown by 50% or 10 pages which ever was smaller. This might be reasonable if you were trying to build an image which was `full', ie had few free objects of this type. (si::allocate-growth 'fixnum 0 10000 30 40) would grow space till there were normally 40% free fixnums, usually growing by 30% per time. (si::allocate-growth 'cons 0 0 0 40) would require 40% free conses after garbage collection for conses, and would use system defaults for the the rate to grow towards this goal. (si::allocate-growth 'cons -1 0 0 0) would return the current values, but not make any changes. @end defun @defun OPEN-FASD (stream direction eof-value table) Package:SI Given file STREAM open for input or output in DIRECTION, set it up to start writing or reading in fasd format. When reading from this stream the EOF-VALUE will be returned when the end a fasd end of dump marker is encountered. TABLE should be an eq hashtable on output, a vector on input, or nil. In this last case a default one will be constructed. We shall refer to the result as a `fasd stream'. It is suitable as the arg to CLOSE-FASD, READ-FASD-TOP, and as the second second arg to WRITE-FASD. As a lisp object it is actually a vector, whose body coincides with: struct fasd @{ object stream; /* lisp object of type stream */ object table; /* hash table used in dumping or vector on input*/ object eof; /* lisp object to be returned on coming to eof mark */ object direction; /* holds Cnil or Kinput or Koutput */ object package; /* the package symbols are in by default */ object index; /* integer. The current_dump index on write */ object filepos; /* nil or the position of the start */ object table_length; /* On read it is set to the size dump array needed or 0 */ object macro ; @} We did not use a defstruct for this, because we want the compiler to use this and it makes bootstrapping more difficult. It is in "cmpnew/fasdmacros.lsp" @end defun @defun WRITE-FASD-TOP (X FASD-STREAM) Package:SI Write X to FASD-STREAM. @end defun @defun READ-FASD-TOP (FASD-STREAM) Package:SI Read the next object from FASD-STREAM. Return the eof-value of FASD-STREAM if we encounter an eof marker put out by CLOSE-FASD. Encountering end of actual file stream causes an error. @end defun @defun CLOSE-FASD (FASD-STREAM) Package:SI On output write an eof marker to the associated file stream, and then make FASD-STREAM invalid for further output. It also attempts to write information to the stream on the size of the index table needed to read from the stream from the last open. This is useful in growing the array. It does not alter the file stream, other than for writing this information to it. The file stream may be reopened for further use. It is an error to OPEN-FASD the same file or file stream again with out first calling CLOSE-FASD. @end defun @defun FIND-SHARING-TOP (x table) Package:SI X is any lisp object and TABLE is an eq hash table. This walks through X making entries to indicate the frequency of symbols,lists, and arrays. Initially items get -1 when they are first met, and this is decremented by 1 each time the object occurs. Call this function on all the objects in a fasd file, which you wish to share structure. @end defun @defvar *LOAD-PATHNAME* Package:SI Load binds this to the pathname of the file being loaded. @end defvar @deffn {Macro} DEFINE-INLINE-FUNCTION (fname vars &body body) Package:SI This is equivalent to defun except that VARS may not contain &optional, &rest, &key or &aux. Also a compiler property is added, which essentially saves the body and turns this into a let of the VARS and then execution of the body. This last is done using si::DEFINE-COMPILER-MACRO Example: (si::define-inline-function myplus (a b c) (+ a b c)) @end deffn @deffn {Macro} DEFINE-COMPILER-MACRO (fname vars &body body) Package:SI FNAME may be the name of a function, but at compile time the macro expansion given by this is used. (si::define-compiler-macro mycar (a) `(car ,a)) @end deffn @defun DBL () Package:SI Invoke a top level loop, in which debug commands may be entered. These commands may also be entered at breaks, or in the error handler. See SOURCE-LEVEL-DEBUG @end defun @defun NLOAD (file) Package:SI Load a file with the readtable bound to a special readtable, which permits tracking of source line information as the file is loaded. see SOURCE-LEVEL-DEBUG @end defun @defun BREAK-FUNCTION (function &optional line absolute) Package:SI Set a breakpoint for a FUNCTION at LINE if the function has source information loaded. If ABSOLUTE is not nil, then the line is understood to be relative to the beginning of the buffer. See also dbl-break-function, the emacs command. @end defun @defun XDR-OPEN (stream) Package:SI Returns an object suitable for passing to XDR-READ if the stream is an input stream, and XDR-WRITE if it was an output stream. Note the stream must be a unix stream, on which si::fp-input-stream or si::fp-output-stream would act as the identity. @end defun @defun FP-INPUT-STREAM (stream) Package:SI Return a unix stream for input associated to STREAM if possible, otherwise return nil. @end defun @defun FP-OUTPUT-STREAM (stream) Package:SI Return a unix stream for output associated to STREAM if possible, otherwise return nil. @end defun @defun XDR-READ (stream element) Package:SI Read one item from STREAM of type the type of ELEMENT. The representation of the elements is machine independent. The xdr routines are what is used by the basic unix rpc calls. @end defun @defun XDR-WRITE (stream element) Package:SI Write to STREAM the given ELEMENT. @end defun @defvar *TOP-LEVEL-HOOK* Package:SI If this variable is has a function as its value at start up time, then it is run immediately after the init.lsp file is loaded. This is useful for starting up an alternate top level loop. @end defvar @defun RUN-PROCESS (string arglist) Package:SI Execute the command STRING in a subshell passing the strings in the list ARGLIST as arguments to the command. Return a two way stream associated to this. Use si::fp-output-stream to get an associated output stream or si::fp-input-stream. Bugs: It does not properly deallocate everything, so that it will fail if you call it too many times. @end defun @defvar *CASE-FOLD-SEARCH* Package: SI Non nil means that a string-match should ignore case @end defvar @defun STRING-MATCH (pattern string &optional start end) Package: SI Match regexp PATTERN in STRING starting in string starting at START and ending at END. Return -1 if match not found, otherwise return the start index of the first matchs. The variable *MATCH-DATA* will be set to a fixnum array of sufficient size to hold the matches, to be obtained with match-beginning and match-end. If it already contains such an array, then the contents of it will be over written. The form of a regexp pattern is discussed in @xref{Regular Expressions}. @end defun @defun MATCH-BEGINNING (index) Returns the beginning of the I'th match from the previous STRING-MATCH, where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* vector is not a fixnum array. @end defun @defun MATCH-END (index) Returns the end of the I'th match from the previous STRING-MATCH @end defun @defun SOCKET (port &key host server async myaddr myport daemon) Establishes a socket connection to the specified PORT under a variety of circumstances. If HOST is specified, then it is a string designating the IP address of the server to which we are the client. ASYNC specifies that the connection should be made asynchronously, and the call return immediately. MYADDR and MYPORT can specify the IP address and port respectively of a client connection, for example when the running machine has several network interfaces. If SERVER is specified, then it is a function which will handle incoming connections to this PORT. DAEMON specifies that the running process should be forked to handle incoming connections in the background. If DAEMON is set to the keyword PERSISTENT, then the backgrounded process will survive when the parent process exits, and the SOCKET call returns NIL. Any other non-NIL setting of DAEMON causes the socket call to return the process id of the backgrounded process. DAEMON currently only works on BSD and Linux based systems. If DAEMON is not set or nil, or if the socket is not a SERVER socket, then the SOCKET call returns a two way stream. In this case, the running process is responsible for all I/O operations on the stream. Specifically, if a SERVER socket is created as a non-DAEMON, then the running process must LISTEN for connections, ACCEPT them when present, and call the SERVER function on the stream returned by ACCEPT. @end defun @defun ACCEPT (stream) Creates a new two-way stream to handle an individual incoming connection to STREAM, which must have been created with the SOCKET function with the SERVER keyword set. ACCEPT should only be invoked when LISTEN on STREAM returns T. If the STREAM was created with the DAEMON keyword set in the call to SOCKET, ACCEPT is unnecessary and will be called automatically as needed. @end defun @menu * Regular Expressions:: @end menu @node Regular Expressions, , System Definitions, System Definitions @section Regular Expressions The function @code{string-match} (*Index string-match::) is used to match a regular expression against a string. If the variable @code{*case-fold-search*} is not nil, case is ignored in the match. To determine the extent of the match use *Index match-beginning:: and *Index match-end::. Regular expressions are implemented using Henry Spencer's package (thank you Henry!), and much of the description of regular expressions below is copied verbatim from his manual entry. Code for delimited searches, case insensitive searches, and speedups to allow fast searching of long files was contributed by W. Schelter. The speedups use an adaptation by Schelter of the Boyer and Moore string search algorithm to the case of branched regular expressions. These allow such expressions as 'not_there|really_not' to be searched for 30 times faster than in GNU emacs (1995), and 200 times faster than in the original Spencer method. Expressions such as [a-u]bcdex get a speedup of 60 and 194 times respectively. This is based on searching a string of 50000 characters (such as the file tk.lisp). @itemize @bullet @item A regular expression is a string containing zero or more @i{branches} which are separated by @code{|}. A match of the regular expression against a string is simply a match of the string with one of the branches. @item Each branch consists of zero or more @i{pieces}, concatenated. A matching string must contain an initial substring matching the first piece, immediately followed by a second substring matching the second piece and so on. @item Each piece is an @i{atom} optionally followed by @code{+}, @code{*}, or @code{?}. @item An atom followed by @code{+} matches a sequence of 1 or more matches of the atom. @item An atom followed by @code{*} matches a sequence of 0 or more matches of the atom. @item An atom followed by @code{?} matches a match of the atom, or the null string. @item An atom is @itemize @minus @item a regular expression in parentheses matching a match for the regular expression @item a @i{range} see below @item a @code{.} matching any single character @item a @code{^} matching the null string at the beginning of the input string @item a @code{$} matching the null string at the end of the input string @item a @code{\} followed by a single character matching that character @item a single character with no other significance (matching that character). @end itemize @item A @i{range} is a sequence of characters enclosed in @code{[]}. It normally matches any single character from the sequence. @itemize @minus @item If the sequence begins with @code{^}, it matches any single character @i{not} from the rest of the sequence. @item If two characters in the sequence are separated by @code{-}, this is shorthand for the full list of ASCII characters between them (e.g. @code{[0-9]} matches any decimal digit). @item To include a literal @code{]} in the sequence, make it the first character (following a possible @code{^}). @item To include a literal @code{-}, make it the first or last character. @end itemize @end itemize @unnumberedsubsec Ordering Multiple Matches In general there may be more than one way to match a regular expression to an input string. For example, consider the command @example (string-match "(a*)b*" "aabaaabb") @end example Considering only the rules given so far, the value of (list-matches 0 1) might be @code{("aabb" "aa")} or @code{("aaab" "aaa")} or @code{("ab" "a")} or any of several other combinations. To resolve this potential ambiguity @b{string-match} chooses among alternatives using the rule @i{first then longest}. In other words, it considers the possible matches in order working from left to right across the input string and the pattern, and it attempts to match longer pieces of the input string before shorter ones. More specifically, the following rules apply in decreasing order of priority: @itemize @asis{} @item [1] If a regular expression could match two different parts of an input string then it will match the one that begins earliest. @item [2] If a regular expression contains @b{|} operators then the leftmost matching sub-expression is chosen. @item [3] In @b{*}@r{, }@b{+}@r{, and }@b{?} constructs, longer matches are chosen in preference to shorter ones. @item [4] In sequences of expression components the components are considered from left to right. @end itemize In the example from above, @b{(a*)b*}@r{ matches }@b{aab}@r{: the }@b{(a*)} portion of the pattern is matched first and it consumes the leading @b{aa}@r{; then the }@b{b*} portion of the pattern consumes the next @b{b}. Or, consider the following example: @example (string-match "(ab|a)(b*)c" "xabc") ==> 1 (list-matches 0 1 2 3) ==> ("abc" "ab" "" NIL) (match-beginning 0) ==> 1 (match-end 0) ==> 4 (match-beginning 1) ==> 1 (match-end 1) ==> 3 (match-beginning 2) ==> 3 (match-end 2) ==> 3 (match-beginning 3) ==> -1 (match-end 3) ==> -1 @end example In the above example the return value of @code{1} (which is @code{> -1}) indicates that a match was found. The entire match runs from 1 to 4. Rule 4 specifies that @b{(ab|a)} gets first shot at the input string and Rule 2 specifies that the @b{ab} sub-expression is checked before the @b{a} sub-expression. Thus the @b{b}@r{ has already been claimed before the }@b{(b*)} component is checked and @b{(b*)} must match an empty string. The special characters in the string @code{"\()[]+.*|^$?"}, must be quoted, if a simple string search is desired. The function re-quote-string is provided for this purpose. @example (re-quote-string "*standard*") ==> "\\*standard\\*" (string-match (re-quote-string "*standard*") "X *standard* ") ==> 2 (string-match "*standard*" "X *standard* ") Error: Regexp Error: ?+* follows nothing @end example Note there is actually just one @code{\} before the @code{*} but the printer makes two so that the string can be read, since @code{\} is also the lisp quote character. In the last example an error is signalled since the special character @code{*} must follow an atom if it is interpreted as a regular expression. gcl-2.6.14/info/internal.texi0000755000175000017500000002434514360276512014450 0ustar cammcamm@node GCL Specific, C Interface, Type, Top @chapter GCL Specific @defun SYSTEM (string) Package:LISP GCL specific: Executes a Shell command as if STRING is an input to the Shell. Not all versions of GCL support this function. At least on POSIX systems, this call should return two integers represeting the exit status and any possible terminating signal respectively. @end defun @defvar *TMP-DIR* Package:COMPILER GCL specific: Directory in which temporary ``gazonk'' files used by the compiler are to be created. @end defvar @defvar *IGNORE-MAXIMUM-PAGES* Package:SI GCL specific: Tells the GCL memory manager whether (non-NIL) or not (NIL) it should expand memory whenever the maximum allocatable pages have been used up. @end defvar @defvar *OPTIMIZE-MAXIMUM-PAGES* Package:SI GCL specific: Tells the GCL memory manager whether to attempt to adjust the maximum allowable pages for each type to approximately optimize the garbage collection load in the current process. Defaults to T. Set to NIL if you care more about memory usage than runtime. @end defvar @defun MACHINE-VERSION () Package:LISP Returns a string that identifies the machine version of the machine on which GCL is currently running. @end defun @defun BY () Package:LISP GCL specific: Exits from GCL. @end defun @deffn {Macro} DEFCFUN Package:LISP Syntax: @example (defcfun header n @{element@}*) @end example GCL specific: Defines a C-language function which calls Lisp functions and/or handles Lisp objects. HEADER gives the header of the C function as a string. Non-negative-integer is the number of the main stack entries used by the C function, primarily for protecting Lisp objects from being garbage-collected. Each ELEMENT may give a C code fragment as a string, or it may be a list ((symbol @{arg@}*) @{place@}*) which, when executed, calls the Lisp function named by SYMBOL with the specified arguments and saves the value(s) to the specified places. The DEFCFUN form has the above meanings only after compiled; The GCL interpreter simply ignores this form. An example which defines a C function list2 of two arguments, but which calls the 'lisp' function CONS by name, and refers to the constant 'NIL. Note to be loaded by @code{load} the function should be static. (defCfun "static object list2(x,y) object x,y;" 0 "object z;" ('NIL z) ((CONS y z) z) ((CONS x z) z) "return(z);" ) In lisp the operations in the body would be (setq z 'nil) (setq z (cons y z)) (setq z (cons x z)) Syntax: @example (defCfun header non-negative-integer @{ string | ( function-symbol @{ value @}* ) | (( function-symbol @{ value @}* ) @{ place @}* ) @}) value: place: @{ C-expr | ( C-type C-expr ) @} C-function-name: C-expr: @{ string | symbol @} C-type: @{ object | int | char | float | double @} @end example @end deffn @deffn {Macro} CLINES Package:LISP Syntax: @example (clines @{string@}*) @end example GCL specific: The GCL compiler embeds STRINGs into the intermediate C language code. The interpreter ignores this form. @end deffn @defun ALLOCATE (type number &optional (really-allocate nil)) Package:LISP GCL specific: Sets the maximum number of pages for the type class of the GCL implementation type TYPE to NUMBER. If REALLY-ALLOCATE is given a non-NIL value, then the specified number of pages will be allocated immediately. @end defun @defun GBC (x) Package:LISP GCL specific: Invokes the garbage collector (GC) with the collection level specified by X. NIL as the argument causes GC to collect cells only. T as the argument causes GC to collect everything. @end defun @defun SAVE (pathname) Package:LISP GCL specific: Saves the current GCL core image into a program file specified by PATHNAME. This function depends on the version of GCL. The function si::save-system is to be preferred in almost all circumstances. Unlike save, it makes the relocatable section permanent, and causes no future gc of currently loaded .o files. @end defun @defun HELP* (string &optional (package 'lisp)) Package:LISP GCL specific: Prints the documentation associated with those symbols in the specified package whose print names contain STRING as substring. STRING may be a symbol, in which case the print-name of that symbol is used. If PACKAGE is NIL, then all packages are searched. @end defun @deffn {Macro} DEFLA Package:LISP Syntax: @example (defla name lambda-list @{decl | doc@}* @{form@}*) @end example GCL specific: Used to DEFine Lisp Alternative. For the interpreter, DEFLA is equivalent to DEFUN, but the compiler ignores this form. @end deffn @defun PROCLAMATION (decl-spec) Package:LISP GCL specific: Returns T if the specified declaration is globally in effect; NIL otherwise. See the doc of DECLARE for possible DECL-SPECs. @end defun @deffn {Macro} DEFENTRY Package:LISP Syntax: @example (defentry name arg-types c-function) @end example GCL specific: The compiler defines a Lisp function whose body consists of a calling sequence to the C language function specified by C-FUNCTION. The interpreter ignores this form. The ARG-TYPES specifies the C types of the arguments which C-FUNCTION requires. The list of allowed types is (object char int float double string). Code will be produced to coerce from a lisp object to the appropriate type before passing the argument to the C-FUNCTION. The c-function should be of the form (c-result-type c-fname) where c-result-type is a member of (void object char int float double string). c-fname may be a symbol (in which case it will be downcased) or a string. If c-function is not a list, then (object c-function) is assumed. In order for C code to be loaded in by @code{load} you should declare any variables and functions to be static. If you will link them in at build time, of course you are allowed to define new externals. @example Sample usage: --File begin----- ;; JOE takes X a lisp string and Y a fixnum and returns a character. (clines "#include \"foo.ch\"") (defentry joe (string int) (char "our_c_fun")) ---File end------ ---File foo.ch--- /* C function for extracting the i'th element of a string */ static char our_c_fun(p,i) char *p; int i; @{ return p[i]; @} -----File end--- @end example One must be careful of storage allocation issues when passing a string. If the C code invokes storage allocation (either by calling @code{malloc} or @code{make_cons} etc), then there is a possibility of a garbage collection, so that if the string passed was not constructed with @code{:static t} when its array was constructed, then it could move. If the C function may allocate storage, then you should pass a copy: @example (defun safe-c-string (x) (let* ((n (length x)) (a (make-array (+ n 1) :element-type 'string-char :static t :fill-pointer n))) (si::copy-array-portion x y 0 0 n) (setf (aref a n) (code-char 0))) a) @end example @end deffn @defun COPY-ARRAY-PORTION (x,y,i1,i2,n1) Package:SI Copy elements from X to Y starting at X[i1] to Y[i2] and doing N1 elements if N1 is supplied otherwise, doing the length of X - I1 elements. If the types of the arrays are not the same, this has implementation dependent results. @end defun @defun BYE ( &optional (exit-status 0)) Package:LISP GCL specific: Exits from GCL with exit-status. @end defun @defun USE-FAST-LINKS (turn-on) Package:LISP GCL specific: If TURN-ON is not nil, the fast link mechanism is enabled, so that ordinary function calls will not appear in the invocation stack, and calls will be much faster. This is the default. If you anticipate needing to see a stack trace in the debugger, then you should turn this off. @end defun @menu * Bignums:: @end menu @node Bignums, , GCL Specific, GCL Specific @section Bignums A directory mp was added to hold the new multi precision arithmetic code. The layout and a fair amount of code in the mp directory is an enhanced version of gpari version 34. The gpari c code was rewritten to be more efficient, and gcc assembler macros were added to allow inlining of operations not possible to do in C. On a 68K machine, this allows the C version to be as efficient as the very carefully written assembler in the gpari distribution. For the main machines, an assembler file (produced by gcc) based on this new method, is included. This is for sites which do not have gcc, or do not wish to compile the whole system with gcc. Bignum arithmetic is much faster now. Many changes were made to cmpnew also, to add 'integer' as a new type. It differs from variables of other types, in that storage is associated to each such variable, and assignments mean copying the storage. This allows a function which does a good deal of bignum arithmetic, to do very little consing in the heap. An example is the computation of PI-INV in scratchpad, which calculates the inverse of pi to a prescribed number of bits accuracy. That function is now about 20 times faster, and no longer causes garbage collection. In versions of GCL where HAVE_ALLOCA is defined, the temporary storage growth is on the C stack, although this often not so critical (for example it makes virtually no difference in the PI-INV example, since in spite of the many operations, only one storage allocation takes place. Below is the actual code for PI-INV On a sun3/280 (cli.com) Here is the comparison of lucid and gcl before and after on that pi-inv. Times are in seconds with multiples of the gcl/akcl time in parentheses. On a sun3/280 (cli.com) @example pi-inv akcl-566 franz lucid old kcl/akcl ---------------------------------------- 10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) 20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) (defun pi-inv (bits &aux (m 0)) (declare (integer bits m)) (let* ((n (+ bits (integer-length bits) 11)) (tt (truncate (ash 1 n) 882)) (d (* 4 882 882)) (s 0)) (declare (integer s d tt n)) (do ((i 2 (+ i 2)) (j 1123 (+ j 21460))) ((zerop tt) (cons s (- (+ n 2)))) (declare (integer i j)) (setq s (+ s (* j tt)) m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) @end example gcl-2.6.14/info/user-interface.texi0000755000175000017500000002010014360276512015531 0ustar cammcamm@node User Interface, Doc, Iteration and Tests, Top @chapter User Interface @defvr {Special Variable} - Package:LISP Holds the top-level form that GCL is currently evaluating. @end defvr @defun - (number &rest more-numbers) Package:LISP Subtracts the second and all subsequent NUMBERs from the first NUMBER. With one arg, negates it. @end defun @deffn {Macro} UNTRACE Package:LISP Syntax: @example (untrace @{function-name@}*) @end example Removes tracing from the specified functions. With no FUNCTION-NAMEs, untraces all functions. @end deffn @defvar *** Package:LISP Gets the previous value of ** when GCL evaluates a top-level form. @end defvar @defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) Package:LISP Returns an input stream which will supply the characters of String between Start and End in order. @end defun @deffn {Macro} STEP Package:LISP Syntax: @example (step form) @end example Evaluates FORM in the single-step mode and returns the value. @end deffn @defvar *BREAK-ENABLE* Package:LISP GCL specific: When an error occurrs, control enters to the break loop only if the value of this variable is non-NIL. @end defvar @defvr {Special Variable} / Package:LISP Holds a list of the values of the last top-level form. @end defvr @defun DESCRIBE (x) Package:LISP Prints a description of the object X. @end defun @defun ED (&optional x) Package:LISP Invokes the editor. The action depends on the version of GCL. @end defun @defvar *DEBUG-IO* Package:LISP Holds the I/O stream used by the GCL debugger. @end defvar @defvar *BREAK-ON-WARNINGS* Package:LISP When the function WARN is called, control enters to the break loop only if the value of this varialbe is non-NIL. @end defvar @defun CERROR (continue-format-string error-format-string &rest args) Package:LISP Signals a correctable error. @end defun @defvar ** Package:LISP Gets the previous value of * when GCL evaluates a top-level form. @end defvar @defvr {Special Variable} +++ Package:LISP Gets the previous value of ++ when GCL evaluates a top-level form. @end defvr @defun INSPECT (x) Package:LISP Shows the information about the object X in an interactive manner @end defun @defvr {Special Variable} // Package:LISP Gets the previous value of / when GCL evaluates a top-level form. @end defvr @defvar *TRACE-OUTPUT* Package:LISP The trace output stream. @end defvar @defvr {Special Variable} ++ Package:LISP Gets the previous value of + when GCL evaluates a top-level form. @end defvr @defvar *ERROR-OUTPUT* Package:LISP Holds the output stream for error messages. @end defvar @defun DRIBBLE (&optional pathname) Package:LISP If PATHNAME is given, begins to record the interaction to the specified file. If PATHNAME is not given, ends the recording. @end defun @defvar * Package:LISP Holds the value of the last top-level form. @end defvar @defvr {Special Variable} /// Package:LISP Gets the previous value of // when GCL evaluates a top-level form. @end defvr @defun WARN (format-string &rest args) Package:LISP Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. @end defun @defun BREAK (&optional (format-string nil) &rest args) Package:LISP Enters a break loop. If FORMAT-STRING is non-NIL, formats FORMAT-STRING and ARGS to *ERROR-OUTPUT* before entering a break loop. Typing :HELP at the break loop will list the break-loop commands. @end defun @defvr {Special Variable} + Package:LISP Holds the last top-level form. @end defvr @deffn {Macro} TRACE Package:LISP Syntax: @example (trace @{function-name@}*) @end example Traces the specified functions. With no FUNCTION-NAMEs, returns a list of functions currently being traced. Additional Keywords are allowed in GCL with the syntax (trace @{fn | (fn @{:kw form@}*)@}*) For each FN naming a function, traces that function. Each :KW should be one of the ones listed below, and FORM should have the corresponding form. No :KW may be given more than once for the same FN. Returns a list of all FNs now traced which weren't already traced. EXAMPLE (Try this with your favorite factorial function FACT): @example ;; print entry args and exit values (trace FACT) ;; Break coming out of FACT if the value is bigger than 1000. (trace (fact :exit (progn (if (> (car values) 1000)(break "big result")) (car values)))) ;; Hairy example: ;;make arglist available without the si:: prefix (import 'si::arglist) (trace (fact :DECLARATIONS ((in-string "Here comes input: ") (out-string "Here comes output: ") all-values (silly (+ 3 4))) :COND (equal (rem (car arglist) 2) 0) :ENTRY (progn (cond ((equal (car arglist) 8) (princ "Entering FACT on input 8!! ") (setq out-string "Here comes output from inside (FACT 8): ")) (t (princ in-string))) (car arglist)) :EXIT (progn (setq all-values (cons (car values) all-values)) (princ out-string) (when (equal (car arglist) 8) ;; reset out-string (setq out-string "Here comes output: ")) (cons 'fact values)) :ENTRYCOND (not (= (car arglist) 6)) :EXITCOND (not (= (car values) (* 6 (car arglist)))) :DEPTH 5)) @end example Syntax is @code{:keyword} @i{form1} @code{:keyword} @i{form2} ... @table @code @item :declarations @example DEFAULT: NIL @end example FORM is ((var1 form1 )(var2 form2 )...), where the var_i are symbols distinct from each other and from all symbols which are similarly declared for currently traced functions. Each form is evaluated immediately. Upon any invocation of a traced function when not already inside a traced function call, each var is bound to that value of form . @item :COND @example DEFAULT: T @end example Here, FORM is any Lisp form to be evaluated (by EVAL) upon entering a call of FN, in the environment where si::ARGLIST is bound to the current list of arguments of FN. Note that even if the evaluation of FORM changes the value of SI::ARGLIST (e.g. by evaluation of (SETQ si::ARGLIST ...)), the list of arguments passed to FN is unchanged. Users may alter args passed by destructively modifying the list structure of SI::ARGLIST however. The call is traced (thus invoking the :ENTRYCOND and :EXITCOND forms, at least) if and only if FORM does not evaluate to NIL. @item :ENTRYCOND @example DEFAULT: T @end example This is evaluated (by EVAL) if the :COND form evaluates to non-NIL, both in an environment where SI::ARGLIST is bound to the current list of arguments of FN. If non-NIL, the :ENTRY form is then evaluated and printed with the trace "prompt". @item :ENTRY @example DEFAULT: (CONS (QUOTE x) SI::ARGLIST), @end example where x is the symbol we call FN If the :COND and :ENTRYCOND forms evaluate to non-NIL, then the trace "prompt" is printed and then this FORM is evaluated (by EVAL) in an environment where SI::ARGLIST is bound to the current list of arguments of FN. The result is then printed. @item :EXITCOND @example DEFAULT: T @end example This is evaluated (by EVAL) in the environment described below for the :EXIT form. The :EXIT form is then evaluated and printed with the "prompt" if and only if the result here is non-NIL. @item :EXIT @example DEFAULT: (CONS (QUOTE x) VALUES), @end example where x is the symbol we call FN Upon exit from tracing a given call, this FORM is evaluated (after the appropriate trace "prompt" is printed), using EVAL in an environment where SI::ARGLIST is bound to the current list of arguments of FN and VALUES is bound to the list of values returned by FN (recalling that Common Lisp functions may return multiple values). @item :DEPTH @example DEFAULT: No depth limit @end example FORM is simply a positive integer specifying the maximum nesting of traced calls of FN, i.e. of calls of FN in which the :COND form evaluated to non-NIL. For calls of FN in which this limit is exceeded, even the :COND form is not evaluated, and the call is not traced. @end table @end deffn gcl-2.6.14/info/gcl-si.texi0000755000175000017500000000426514360276512014011 0ustar cammcamm\input texinfo @c -*-texinfo-*- @c IMPORTANT.... @c some versions of texinfo.tex cause an error message 'unmatched paren @c for: @c @defun foo (a &optional (b 3)) @c ! unbalanced parens in @def arguments. @c ignore these by using 's' to scroll error messages in tex. @c @smallbook @setfilename gcl-si.info @synindex vr fn @c to update the menus do: @c (texinfo-multiple-files-update "gcl-si.texi" t t) @setchapternewpage odd @dircategory GNU Common Lisp @direntry * gcl-si: (gcl-si.info). GNU Common Lisp System Internals @end direntry @ifinfo This is a Texinfo GCL SYSTEM INTERNALS Manual Copyright 1994 William F. Schelter @end ifinfo @titlepage @sp 10 @comment The title is printed in a large font. @comment @center @titlefont{GCL SI Manual} @title GCL SI Manual @end titlepage @node Top, Numbers, (dir), (dir) @top @menu * Numbers:: * Sequences and Arrays and Hash Tables:: * Characters:: * Lists:: * Streams and Reading:: * Special Forms and Functions:: * Compilation:: * Symbols:: * Operating System:: * Structures:: * Iteration and Tests:: * User Interface:: * Doc:: * Type:: * GCL Specific:: * C Interface:: * System Definitions:: * Debugging:: * Miscellaneous:: * Compiler Definitions:: * Function and Variable Index:: --- The Detailed Node Listing --- Operating System * Command Line:: * Operating System Definitions:: GCL Specific * Bignums:: C Interface * Available Symbols:: System Definitions * Regular Expressions:: Debugging * Source Level Debugging in Emacs:: * Low Level Debug Functions:: Miscellaneous * Environment:: * Inititialization:: * Low Level X Interface:: @end menu @include number.texi @include sequence.texi @include character.texi @include list.texi @include io.texi @include form.texi @include compile.texi @include symbol.texi @include system.texi @include structure.texi @include iteration.texi @include user-interface.texi @include doc.texi @include type.texi @include internal.texi @include c-interface.texi @include si-defs.texi @include debug.texi @include misc.texi @include compiler-defs.texi @include gcl-si-index.texi @summarycontents @contents @bye gcl-2.6.14/info/symbol.texi0000755000175000017500000002212714360276512014135 0ustar cammcamm@node Symbols, Operating System, Compilation, Top @chapter Symbols @defun GENSYM (&optional (x nil)) Package:LISP Creates and returns a new uninterned symbol whose name is a prefix string (defaults to "G"), followed by a decimal number. The number is incremented by each call to GENSYM. X, if an integer, resets the counter. If X is a string, it becomes the new prefix. @end defun @defun KEYWORDP (x) Package:LISP Returns T if X is a symbol and it belongs to the KEYWORD package; NIL otherwise. @end defun @defun REMPROP (symbol indicator) Package:LISP Look on property list of SYMBOL for property with specified INDICATOR. If found, splice this indicator and its value out of the plist, and return T. If not found, returns NIL with no side effects. @end defun @defun SYMBOL-PACKAGE (symbol) Package:LISP Returns the contents of the package cell of the symbol SYMBOL. @end defun @defvar *PACKAGE* Package:LISP The current package. @end defvar @defun SHADOWING-IMPORT (symbols &optional (package *package*)) Package:LISP Imports SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol of the same name is already present, then it is uninterned. SYMBOLS must be a list of symbols or a symbol. @end defun @deffn {Macro} REMF Package:LISP Syntax: @example (remf place indicator) @end example PLACE may be any place expression acceptable to SETF, and is expected to hold a property list or NIL. This list is destructively altered to remove the property specified by INDICATOR. Returns T if such a property was present; NIL otherwise. @end deffn @defun MAKUNBOUND (symbol) Package:LISP Makes empty the value slot of SYMBOL. Returns SYMBOL. @end defun @defun USE-PACKAGE (packages-to-use &optional (package *package*)) Package:LISP Adds all packages in PACKAGE-TO-USE list to the use list for PACKAGE so that the external symbols of the used packages are available as internal symbols in PACKAGE. @end defun @defun MAKE-SYMBOL (string) Package:LISP Creates and returns a new uninterned symbol whose print name is STRING. @end defun @deffn {Special Form} PSETQ Package:LISP Syntax: @example (psetq @{var form@}*) @end example Similar to SETQ, but evaluates all FORMs first, and then assigns each value to the corresponding VAR. Returns NIL always. @end deffn @defun PACKAGE-USED-BY-LIST (package) Package:LISP Returns the list of packages that use PACKAGE. @end defun @defun SYMBOLP (x) Package:LISP Returns T if X is a symbol; NIL otherwise. @end defun @defvr {Constant} NIL Package:LISP Holds NIL. @end defvr @defun SET (symbol value) Package:LISP Assigns the value of VALUE to the dynamic variable named by SYMBOL, and returns the value assigned. @end defun @deffn {Special Form} SETQ Package:LISP Syntax: @example (setq @{var form@}*) @end example VARs are not evaluated and must be symbols. Assigns the value of the first FORM to the first VAR, then assigns the value of the second FORM to the second VAR, and so on. Returns the last value assigned. @end deffn @defun UNUSE-PACKAGE (packages-to-unuse &optional (package *package*)) Package:LISP Removes PACKAGES-TO-UNUSE from the use list for PACKAGE. @end defun @defvr {Constant} T Package:LISP Holds T. @end defvr @defun PACKAGE-USE-LIST (package) Package:LISP Returns the list of packages used by PACKAGE. @end defun @defun LIST-ALL-PACKAGES () Package:LISP Returns a list of all existing packages. @end defun @defun COPY-SYMBOL (symbol &optional (copy-props nil)) Package:LISP Returns a new uninterned symbol with the same print name as SYMBOL. If COPY-PROPS is NIL, the function, the variable, and the property slots of the new symbol have no value. Otherwise, these slots are given the values of the corresponding slots of SYMBOL. @end defun @defun SYMBOL-PLIST (symbol) Package:LISP Returns the property list of SYMBOL. @end defun @defun SYMBOL-NAME (symbol) Package:LISP Returns the print name of the symbol SYMBOL. @end defun @defun FIND-SYMBOL (name &optional (package *package*)) Package:LISP Returns the symbol named NAME in PACKAGE. If such a symbol is found, then the second value is :INTERN, :EXTERNAL, or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL. @end defun @defun SHADOW (symbols &optional (package *package*)) Package:LISP Creates an internal symbol in PACKAGE with the same name as each of the specified SYMBOLS. SYMBOLS must be a list of symbols or a symbol. @end defun @defun FBOUNDP (symbol) Package:LISP Returns T if SYMBOL has a global function definition or if SYMBOL names a special form or a macro; NIL otherwise. @end defun @defun MACRO-FUNCTION (symbol) Package:LISP If SYMBOL globally names a macro, then returns the expansion function. Returns NIL otherwise. @end defun @defun IN-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) Package:LISP Sets *PACKAGE* to the package with PACKAGE-NAME, creating the package if it does not exist. If the package already exists then it is modified to agree with USE and NICKNAMES arguments. Any new nicknames are added without removing any old ones not specified. If any package in the USE list is not currently used, then it is added to the use list. @end defun @defun MAKE-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) Package:LISP Makes a new package having the specified PACKAGE-NAME and NICKNAMES. The package will inherit all external symbols from each package in the USE list. @end defun @defun PACKAGE-SHADOWING-SYMBOLS (package) Package:LISP Returns the list of symbols that have been declared as shadowing symbols in PACKAGE. @end defun @defun INTERN (name &optional (package *package*)) Package:LISP Returns a symbol having the specified name, creating it if necessary. Returns as the second value one of the symbols :INTERNAL, :EXTERNAL, :INHERITED, and NIL. @end defun @defun EXPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS external symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol. @end defun @defun PACKAGEP (x) Package:LISP Returns T if X is a package; NIL otherwise. @end defun @defun SYMBOL-FUNCTION (symbol) Package:LISP Returns the current global function definition named by SYMBOL. @end defun @defun SYMBOL-VALUE (symbol) Package:LISP Returns the current value of the dynamic (special) variable named by SYMBOL. @end defun @defun BOUNDP (symbol) Package:LISP Returns T if the global variable named by SYMBOL has a value; NIL otherwise. @end defun @defun DOCUMENTATION (symbol doc-type) Package:LISP Returns the doc-string of DOC-TYPE for SYMBOL; NIL if none exists. Possible doc-types are: FUNCTION (special forms, macros, and functions) VARIABLE (dynamic variables, including constants) TYPE (types defined by DEFTYPE) STRUCTURE (structures defined by DEFSTRUCT) SETF (SETF methods defined by DEFSETF, DEFINE-SETF-METHOD, and DEFINE-MODIFY-MACRO) All built-in special forms, macros, functions, and variables have their doc-strings. @end defun @defun GENTEMP (&optional (prefix "t") (package *package*)) Package:LISP Creates a new symbol interned in the package PACKAGE with the given PREFIX. @end defun @defun RENAME-PACKAGE (package new-name &optional (new-nicknames nil)) Package:LISP Replaces the old name and nicknames of PACKAGE with NEW-NAME and NEW-NICKNAMES. @end defun @defun UNINTERN (symbol &optional (package *package*)) Package:LISP Makes SYMBOL no longer present in PACKAGE. Returns T if SYMBOL was present; NIL otherwise. If PACKAGE is the home package of SYMBOL, then makes SYMBOL uninterned. @end defun @defun UNEXPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS no longer accessible as external symbols in PACKAGE. SYMBOLS must be a list of symbols or a symbol. @end defun @defun PACKAGE-NICKNAMES (package) Package:LISP Returns as a list the nickname strings for the specified PACKAGE. @end defun @defun IMPORT (symbols &optional (package *package*)) Package:LISP Makes SYMBOLS internal symbols of PACKAGE. SYMBOLS must be a list of symbols or a symbol. @end defun @defun GET (symbol indicator &optional (default nil)) Package:LISP Looks on the property list of SYMBOL for the specified INDICATOR. If this is found, returns the associated value. Otherwise, returns DEFAULT. @end defun @defun FIND-ALL-SYMBOLS (string-or-symbol) Package:LISP Returns a list of all symbols that have the specified name. @end defun @defun FMAKUNBOUND (symbol) Package:LISP Discards the global function definition named by SYMBOL. Returns SYMBOL. @end defun @defun PACKAGE-NAME (package) Package:LISP Returns the string that names the specified PACKAGE. @end defun @defun FIND-PACKAGE (name) Package:LISP Returns the specified package if it already exists; NIL otherwise. NAME may be a string that is the name or nickname of the package. NAME may also be a symbol, in which case the symbol's print name is used. @end defun @defun APROPOS-LIST (string &optional (package nil)) Package:LISP Returns, as a list, all symbols whose print-names contain STRING as substring. If PACKAGE is non-NIL, then only the specified package is searched. @end defun gcl-2.6.14/info/list.texi0000755000175000017500000003142014360276512013577 0ustar cammcamm@node Lists, Streams and Reading, Characters, Top @chapter Lists @defun NINTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the intersection of LIST1 and LIST2. LIST1 may be destroyed. @end defun @defun RASSOC-IF (predicate alist) Package:LISP Returns the first cons in ALIST whose cdr satisfies PREDICATE. @end defun @defun MAKE-LIST (size &key (initial-element nil)) Package:LISP Creates and returns a list containing SIZE elements, each of which is initialized to INITIAL-ELEMENT. @end defun @defun NTH (n list) Package:LISP Returns the N-th element of LIST, where the car of LIST is the zeroth element. @end defun @defun CAAR (x) Package:LISP Equivalent to (CAR (CAR X)). @end defun @defun NULL (x) Package:LISP Returns T if X is NIL; NIL otherwise. @end defun @defun FIFTH (x) Package:LISP Equivalent to (CAR (CDDDDR X)). @end defun @defun NCONC (&rest lists) Package:LISP Concatenates LISTs by destructively modifying them. @end defun @defun TAILP (sublist list) Package:LISP Returns T if SUBLIST is one of the conses in LIST; NIL otherwise. @end defun @defun CONSP (x) Package:LISP Returns T if X is a cons; NIL otherwise. @end defun @defun TENTH (x) Package:LISP Equivalent to (CADR (CDDDDR (CDDDDR X))). @end defun @defun LISTP (x) Package:LISP Returns T if X is either a cons or NIL; NIL otherwise. @end defun @defun MAPCAN (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs, NCONCs the results, and returns it. @end defun @defun EIGHTH (x) Package:LISP Equivalent to (CADDDR (CDDDDR X)). @end defun @defun LENGTH (sequence) Package:LISP Returns the length of SEQUENCE. @end defun @defun RASSOC (item alist &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the first cons in ALIST whose cdr is equal to ITEM. @end defun @defun NSUBST-IF-NOT (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that do not satisfy TEST. @end defun @defun NBUTLAST (list &optional (n 1)) Package:LISP Changes the cdr of the N+1 th cons from the end of the list LIST to NIL. Returns the whole list. @end defun @defun CDR (list) Package:LISP Returns the cdr of LIST. Returns NIL if LIST is NIL. @end defun @defun MAPC (fun list &rest more-lists) Package:LISP Applies FUN to successive cars of LISTs. Returns the first LIST. @end defun @defun MAPL (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs. Returns the first LIST. @end defun @defun CONS (x y) Package:LISP Returns a new cons whose car and cdr are X and Y, respectively. @end defun @defun LIST (&rest args) Package:LISP Returns a list of its arguments @end defun @defun THIRD (x) Package:LISP Equivalent to (CADDR X). @end defun @defun CDDAAR (x) Package:LISP Equivalent to (CDR (CDR (CAR (CAR X)))). @end defun @defun CDADAR (x) Package:LISP Equivalent to (CDR (CAR (CDR (CAR X)))). @end defun @defun CDAADR (x) Package:LISP Equivalent to (CDR (CAR (CAR (CDR X)))). @end defun @defun CADDAR (x) Package:LISP Equivalent to (CAR (CDR (CDR (CAR X)))). @end defun @defun CADADR (x) Package:LISP Equivalent to (CAR (CDR (CAR (CDR X)))). @end defun @defun CAADDR (x) Package:LISP Equivalent to (CAR (CAR (CDR (CDR X)))). @end defun @defun NTHCDR (n list) Package:LISP Returns the result of performing the CDR operation N times on LIST. @end defun @defun PAIRLIS (keys data &optional (alist nil)) Package:LISP Constructs an association list from KEYS and DATA adding to ALIST. @end defun @defun SEVENTH (x) Package:LISP Equivalent to (CADDR (CDDDDR X)). @end defun @defun SUBSETP (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns T if every element of LIST1 appears in LIST2; NIL otherwise. @end defun @defun NSUBST-IF (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that satisfy TEST. @end defun @defun COPY-LIST (list) Package:LISP Returns a new copy of LIST. @end defun @defun LAST (list) Package:LISP Returns the last cons in LIST @end defun @defun CAAAR (x) Package:LISP Equivalent to (CAR (CAR (CAR X))). @end defun @defun LIST-LENGTH (list) Package:LISP Returns the length of LIST, or NIL if LIST is circular. @end defun @defun CDDDR (x) Package:LISP Equivalent to (CDR (CDR (CDR X))). @end defun @defun INTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the intersection of List1 and List2. @end defun @defun NSUBST (new old tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes NEW for subtrees in TREE that match OLD. @end defun @defun REVAPPEND (x y) Package:LISP Equivalent to (APPEND (REVERSE X) Y) @end defun @defun CDAR (x) Package:LISP Equivalent to (CDR (CAR X)). @end defun @defun CADR (x) Package:LISP Equivalent to (CAR (CDR X)). @end defun @defun REST (x) Package:LISP Equivalent to (CDR X). @end defun @defun NSET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list with elements which appear but once in LIST1 and LIST2. @end defun @defun ACONS (key datum alist) Package:LISP Constructs a new alist by adding the pair (KEY . DATUM) to ALIST. @end defun @defun SUBST-IF-NOT (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that do not satisfy TEST. @end defun @defun RPLACA (x y) Package:LISP Replaces the car of X with Y, and returns the modified X. @end defun @defun SECOND (x) Package:LISP Equivalent to (CADR X). @end defun @defun NUNION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the union of LIST1 and LIST2. LIST1 and/or LIST2 may be destroyed. @end defun @defun BUTLAST (list &optional (n 1)) Package:LISP Creates and returns a list with the same elements as LIST but without the last N elements. @end defun @defun COPY-ALIST (alist) Package:LISP Returns a new copy of ALIST. @end defun @defun SIXTH (x) Package:LISP Equivalent to (CADR (CDDDDR X)). @end defun @defun CAAAAR (x) Package:LISP Equivalent to (CAR (CAR (CAR (CAR X)))). @end defun @defun CDDDAR (x) Package:LISP Equivalent to (CDR (CDR (CDR (CAR X)))). @end defun @defun CDDADR (x) Package:LISP Equivalent to (CDR (CDR (CAR (CDR X)))). @end defun @defun CDADDR (x) Package:LISP Equivalent to (CDR (CAR (CDR (CDR X)))). @end defun @defun CADDDR (x) Package:LISP Equivalent to (CAR (CDR (CDR (CDR X)))). @end defun @defun FOURTH (x) Package:LISP Equivalent to (CADDDR X). @end defun @defun NSUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes from ALIST for subtrees of TREE. @end defun @defun SUBST-IF (new test tree &key (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that satisfy TEST. @end defun @defun NSET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements of LIST1 that do not appear in LIST2. LIST1 may be destroyed. @end defun @deffn {Special Form} POP Package:LISP Syntax: @example (pop place) @end example Pops one item off the front of the list in PLACE and returns it. @end deffn @deffn {Special Form} PUSH Package:LISP Syntax: @example (push item place) @end example Conses ITEM onto the list in PLACE, and returns the new list. @end deffn @defun CDAAR (x) Package:LISP Equivalent to (CDR (CAR (CAR X))). @end defun @defun CADAR (x) Package:LISP Equivalent to (CAR (CDR (CAR X))). @end defun @defun CAADR (x) Package:LISP Equivalent to (CAR (CAR (CDR X))). @end defun @defun FIRST (x) Package:LISP Equivalent to (CAR X). @end defun @defun SUBST (new old tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes NEW for subtrees of TREE that match OLD. @end defun @defun ADJOIN (item list &key (test #'eql) test-not (key #'identity)) Package:LISP Adds ITEM to LIST unless ITEM is already a member of LIST. @end defun @defun MAPCON (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs, NCONCs the results, and returns it. @end defun @deffn {Macro} PUSHNEW Package:LISP Syntax: @example (pushnew item place @{keyword value@}*) @end example If ITEM is already in the list stored in PLACE, does nothing. Else, conses ITEM onto the list. Returns NIL. If no KEYWORDs are supplied, each element in the list is compared with ITEM by EQL, but the comparison can be controlled by supplying keywords :TEST, :TEST-NOT, and/or :KEY. @end deffn @defun SET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements appearing exactly once in LIST1 and LIST2. @end defun @defun TREE-EQUAL (x y &key (test #'eql) test-not) Package:LISP Returns T if X and Y are isomorphic trees with identical leaves. @end defun @defun CDDR (x) Package:LISP Equivalent to (CDR (CDR X)). @end defun @defun GETF (place indicator &optional (default nil)) Package:LISP Searches the property list stored in Place for an indicator EQ to Indicator. If one is found, the corresponding value is returned, else the Default is returned. @end defun @defun LDIFF (list sublist) Package:LISP Returns a new list, whose elements are those of LIST that appear before SUBLIST. If SUBLIST is not a tail of LIST, a copy of LIST is returned. @end defun @defun UNION (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the union of LIST1 and LIST2. @end defun @defun ASSOC-IF-NOT (test alist) Package:LISP Returns the first pair in ALIST whose car does not satisfy TEST. @end defun @defun RPLACD (x y) Package:LISP Replaces the cdr of X with Y, and returns the modified X. @end defun @defun MEMBER-IF-NOT (test list &key (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first element not satisfying TEST. @end defun @defun CAR (list) Package:LISP Returns the car of LIST. Returns NIL if LIST is NIL. @end defun @defun ENDP (x) Package:LISP Returns T if X is NIL. Returns NIL if X is a cons. Otherwise, signals an error. @end defun @defun LIST* (arg &rest others) Package:LISP Returns a list of its arguments with the last cons being a dotted pair of the next to the last argument and the last argument. @end defun @defun NINTH (x) Package:LISP Equivalent to (CAR (CDDDDR (CDDDDR X))). @end defun @defun CDAAAR (x) Package:LISP Equivalent to (CDR (CAR (CAR (CAR X)))). @end defun @defun CADAAR (x) Package:LISP Equivalent to (CAR (CDR (CAR (CAR X)))). @end defun @defun CAADAR (x) Package:LISP Equivalent to (CAR (CAR (CDR (CAR X)))). @end defun @defun CAAADR (x) Package:LISP Equivalent to (CAR (CAR (CAR (CDR X)))). @end defun @defun CDDDDR (x) Package:LISP Equivalent to (CDR (CDR (CDR (CDR X)))). @end defun @defun SUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) Package:LISP Substitutes from ALIST for subtrees of TREE nondestructively. @end defun @defun RASSOC-IF-NOT (predicate alist) Package:LISP Returns the first cons in ALIST whose cdr does not satisfy PREDICATE. @end defun @defun NRECONC (x y) Package:LISP Equivalent to (NCONC (NREVERSE X) Y). @end defun @defun MAPLIST (fun list &rest more-lists) Package:LISP Applies FUN to successive cdrs of LISTs and returns the results as a list. @end defun @defun SET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) Package:LISP Returns a list of elements of LIST1 that do not appear in LIST2. @end defun @defun ASSOC-IF (test alist) Package:LISP Returns the first pair in ALIST whose car satisfies TEST. @end defun @defun GET-PROPERTIES (place indicator-list) Package:LISP Looks for the elements of INDICATOR-LIST in the property list stored in PLACE. If found, returns the indicator, the value, and T as multiple-values. If not, returns NILs as its three values. @end defun @defun MEMBER-IF (test list &key (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first element satisfying TEST. @end defun @defun COPY-TREE (object) Package:LISP Recursively copies conses in OBJECT and returns the result. @end defun @defun ATOM (x) Package:LISP Returns T if X is not a cons; NIL otherwise. @end defun @defun CDDAR (x) Package:LISP Equivalent to (CDR (CDR (CAR X))). @end defun @defun CDADR (x) Package:LISP Equivalent to (CDR (CAR (CDR X))). @end defun @defun CADDR (x) Package:LISP Equivalent to (CAR (CDR (CDR X))). @end defun @defun ASSOC (item alist &key (test #'eql) test-not) Package:LISP Returns the first pair in ALIST whose car is equal (in the sense of TEST) to ITEM. @end defun @defun APPEND (&rest lists) Package:LISP Constructs a new list by concatenating its arguments. @end defun @defun MEMBER (item list &key (test #'eql) test-not (key #'identity)) Package:LISP Returns the tail of LIST beginning with the first ITEM. @end defun gcl-2.6.14/info/misc.texi0000755000175000017500000000333614360276512013564 0ustar cammcamm @node Miscellaneous, Compiler Definitions, Debugging, Top @chapter Miscellaneous @menu * Environment:: * Inititialization:: * Low Level X Interface:: @end menu @node Environment, Inititialization, Miscellaneous, Miscellaneous @section Environment The environment in GCL which is passed to macroexpand and other functions requesting an environment, should be a list of 3 lists. The first list looks like ((v1 val1) (v2 val2) ..) where vi are variables and vali are their values. The second is a list of ((fname1 . fbody1) (fname2 . fbody2) ...) where fbody1 is either (macro lambda-list lambda-body) or (lambda-list lambda-body) depending on whether this is a macro or a function. The third list contains tags and blocks. @node Inititialization, Low Level X Interface, Environment, Miscellaneous @section Initialization If the file init.lsp exists in the current directory, it is loaded at startup. The first argument passed to the executable image should be the system directory. Normally this would be gcl/unixport. This directory is stored in the si::*system-directory* variable. If the file sys-init.lsp exists in the system directory, it is loaded before init.lsp. See also si::*TOP-LEVEL-HOOK*. @node Low Level X Interface, , Inititialization, Miscellaneous @section Low Level X Interface A sample program for drawing things on X windows from lisp is included in the file gcl/lsp/littleXlsp.lsp That routine invokes the corresponding C routines in XLIB. So in order to use it you must `faslink' in the X routines. Directions are given at the beginning of the lisp file, for either building them into the image or using faslink. This program is also a good tutorial on invoking C from lisp. See also defentry and faslink. gcl-2.6.14/info/structure.texi0000755000175000017500000000252114360276512014664 0ustar cammcamm@node Structures, Iteration and Tests, Operating System, Top @chapter Structures @deffn {Macro} DEFSTRUCT Package:LISP Syntax: @example (defstruct @{name | (name @{:conc-name | (:conc-name prefix-string) | :constructor | (:constructor symbol [lambda-list]) | :copier | (:copier symbol) | :predicate | (:predicate symbol) | (:include symbol) | (:print-function function) | (:type @{vector | (vector type) | list@}) | :named | (:static @{ nil | t@}) (:initial-offset number)@}*)@} [doc] @{slot-name | (slot-name [default-value-form] @{:type type | :read-only flag@}*) @}* ) @end example Defines a structure. The doc-string DOC, if supplied, is saved as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure). STATIC is gcl specific and makes the body non relocatable. See the files misc/rusage.lsp misc/cstruct.lsp, for examples of making a lisp structure correspond to a C structure. @end deffn @defun HELP (&optional symbol) Package:LISP GCL specific: Prints the documentation associated with SYMBOL. With no argument, this function prints the greeting message to GCL beginners. @end defun gcl-2.6.14/info/compile.texi0000755000175000017500000002735414360276512014267 0ustar cammcamm@node Compilation, Symbols, Special Forms and Functions, Top @chapter Compilation @defun COMPILE (name &optional (definition nil)) Package:LISP If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. In this case, COMPILE compiles the function, installs the compiled function as the global function definition of NAME, and returns NAME. If DEFINITION is non-NIL, it must be a lambda expression and NAME must be a symbol. COMPILE compiles the lambda expression, installs the compiled function as the function definition of NAME, and returns NAME. There is only one exception for this: If NAME is NIL, then the compiled function is not installed but is simply returned as the value of COMPILE. In any case, COMPILE creates temporary files whose filenames are "gazonk***". By default, i.e. if :LEAVE-GAZONK is not supplied or is NIL, these files are automatically deleted after compilation. @end defun @defun LINK (files image &optional post extra-libs (run-user-init t) &aux raw init) Package:LISP On systems where dlopen is used for relocations, one cannot make custom images containing loaded binary object files simply by loading the files and executing save-system. This function is provided for such cases. After compiling source files into objects, LINK can be called with a list of binary and source FILES which would otherwise normally be loaded in sequence before saving the image to IMAGE. LINK will use the system C linker to link the binary files thus supplied with GCL's objects, using EXTRA-LIBS as well if provided, and producing a raw_IMAGE executable. This executable is then run to initialize first GCL's objects, followed by the supplied files, in order, if RUN-USER-INIT is set. In such a case, source files are loaded at their position in the sequence. Any optional code which should be run after file initialization can be supplied in the POST variable. The image is then saved using save-system to IMAGE. This method of creating lisp images may also have the advantage that all new object files are kept out of the lisp core and placed instead in the final image's .text section. This should in principle reduce the core size, speed up garbage collection, and forego any performance penalty induced by data cache flushing on some machines. In both the RAW and SAVED image, any calls to LOAD binary object files which have been specified in this list will bypass the normal load procedure, and simply initialize the already linked in module. One can rely on this feature by disabling RUN-USER-INIT, and instead passing the normal build commands in POST. In the course of executing this code, binary modules previously linked into the .text section of the executable will be initialized at the same point at which they would have normally been loaded into the lisp core, in the executable's .data section. In this way, the user can choose to take advantage of the aforementioned possible benefits of this linking method in a relatively transparent way. All binary objects specified in FILES must have been compiled with :SYSTEM-P set to T. @end defun @deffn {Special Form} EVAL-WHEN Package:LISP Syntax: @example (eval-when (@{situation@}*) @{form@}*) @end example A situation must be either COMPILE, LOAD, or EVAL. The interpreter evaluates only when EVAL is specified. If COMPILE is specified, FORMs are evaluated at compile time. If LOAD is specified, the compiler arranges so that FORMs be evaluated when the compiled code is loaded. @end deffn @defun COMPILE-FILE (input-pathname &key output-file (load nil) (message-file nil) ;GCL specific keywords: system-p c-debug c-file h-file data-file) Package:LISP Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then ".lsp" is used as the default file type for the source file. :LOAD specifies whether to load the generated fasl file after compilation. :MESSAGE-FILE specifies the log file for the compiler messages. It defaults to the value of the variable COMPILER:*DEFAULT-MESSAGE-FILE*. A non-NIL value of COMPILER::*COMPILE-PRINT* forces the compiler to indicate the form currently being compiled. More keyword parameters are accepted, depending on the version. Most versions of GCL can receive :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters, with which you can control the intermediate files generated by the GCL compiler. Also :C-DEBUG will pass the -g flag to the C compiler. By top level forms in a file, we mean the value of *top-level-forms* after doing (TF form) for each form read from a file. We define TF as follows: (defun TF (x) (when (consp x) (setq x (macroexpand x)) (when (consp x) (cond ((member (car x) '(progn eval-when)) (mapcar 'tf (cdr x))) (t (push x *top-level-forms*)))))) Among the common lisp special forms only DEFUN and DEFMACRO will cause actual native machine code to be generated. The rest will be specially treated in an init section of the .data file. This is done so that things like putprop,setq, and many other forms would use up space which could not be usefully freed, if we were to compile to native machine code. If you have other `ordinary' top level forms which you need to have compiled fully to machine code you may either set compiler::*COMPILE-ORDINARIES* to t, or put them inside a (PROGN 'COMPILE ...forms-which-need-to-be-compiled) The compiler will take each of them and make a temporary function which will be compiled and invoked once. It is permissible to wrap a (PROGN 'COMPILE ..) around the whole file. Currently this construction binds the compiler::*COMPILE-ORDINARIES* flag to t. Setting this flag globally to a non nil value to cause all top level forms to generate machine code. This might be useful in a system such as PCL, where a number of top level lambda expressions are given. Note that most common lisps will simply ignore the top level atom 'compile, since it has no side effects. Defentry, clines, and defcfun also result in machine code being generated. @end defun @unnumbered subsection Evaluation at Compile time In GCL the eval-when behaviour was changed in order to allow more efficient init code, and also to bring it into line with the resolution passed by the X3j13 committee. Evaluation at compile time is controlled by placing eval-when special forms in the code, or by the value of the variable compiler::*eval-when-defaults* [default value :defaults]. If that variable has value :defaults, then the following hold: @w{Eval at Compile Type of Top Level Form}@* @table @asis @item Partial: defstructs, defvar, defparameter @item Full: defmacro, defconstant, defsetf, define-setf-method, deftype, package ops, proclaim @item None: defun, others @end table By `partial' we mean (see the X3J13 Common Lisp document (doc/compile-file-handling-of-top-level-forms) for more detail), that functions will not be defined, values will not be set, but other miscellaneous compiler properties will be set: eg properties to inline expand defstruct accessors and testers, defstruct properties allowing subsequent defstructs to include this one, any type hierarch information, special variable information will be set up. Example: @example (defun foo () 3) (defstruct jo a b) @end example As a side effect of compiling these two forms, foo would not have its function cell changed. Neither would jo-a, although it would gain a property which allows it to expand inline to a structure access. Thus if it had a previous definition (as commonly happens from previously loading the file), this previous definition would not be touched, and could well be inconsistent with the compiler properties. Unfortunately this is what the CL standard says to do, and I am just trying to follow it. If you prefer a more intuitive scheme, of evaling all forms in the file, so that there are no inconsistencies, (previous behaviour of AKCL) you may set compiler::*eval-when-defaults* to '(compile eval load). The variable compiler::*FASD-DATA* [default t] controls whether an ascii output is used for the data section of the object file. The data section will be in ascii if *fasd-data* is nil or if the system-p keyword is supplied to compile-file and *fasd-data* is not eq to :system-p. The old GCL variable *compile-time-too* has disappeared. See OPTIMIZE on how to enable warnings of slow constructs. @defun PROCLAIM (decl-spec) Package:LISP Puts the declaration given by DECL-SPEC into effect globally. See the doc of DECLARE for possible DECL-SPECs. @end defun @defun PROVIDE (module-name) Package:LISP Adds the specified module to the list of modules maintained in *MODULES*. @end defun @defun COMPILED-FUNCTION-P (x) Package:LISP Returns T if X is a compiled function; NIL otherwise. @end defun @defun GPROF-START () Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with --enable-gprof. This function starts the profiling timers and counters. @end defun @defun GPROF-QUIT () Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with --enable-gprof. This function reports the profiling results in the form of a call graph to standard output, and clears the profiling arrays. Please note that lisp functions are not (yet) displayed with their lisp names. Please see also the PROFILE function. @end defun @defun GPROF-SET (begin end) Package:SYSTEM GCL now has preliminary support for profiling with gprof, an externally supplied profiling tool at the C level which typically accompanies gcc. Support must be enabled at compile time with --enable-gprof. This function sets the address range used by GPROF-START in specifying the section of the running program which is to be profiled. All subsequent calls to GPROF-START will use this new address range. By default, the range is set to begin at the starting address of the .text section, and to end at the current end of the running core. These default values can be restored by calling GPROF-SET with both argments set to 0. @end defun @defvar *DEFAULT-SYSTEM-P* Pakcage:COMPILER Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-C-FILE* Pakcage:COMPILER Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-H-FILE* Pakcage:COMPILER Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL. @end defvar @defvar *DEFAULT-DATA-FILE* Pakcage:COMPILER Specifies the default setting of :DATA-FILE used by COMPILE. Defaults to NIL. @end defvar @defvar *FEATURES* Package:LISP List of symbols that name features of the current version of GCL. These features are used to decide the read-time conditionalization facility provided by '#+' and '#-' read macros. When the GCL reader encounters @example #+ feature-description form @end example it reads FORM in the usual manner if FEATURE-DESCRIPTION is true. Otherwise, the reader just skips FORM. @example #- feature-description form @end example is equivalent to @example #- (not feature-description) form @end example A feature-description may be a symbol, which is true only when it is an element of *FEATURES*. Or else, it must be one of the following: @example (and feature-desciption-1 ... feature-desciption-n) (or feature-desciption-1 ... feature-desciption-n) (not feature-desciption) @end example The AND description is true only when all of its sub-descriptions are true. The OR description is true only when at least one of its sub-descriptions is true. The NOT description is true only when its sub-description is false. @end defvar gcl-2.6.14/info/chap-26.texi0000644000175000017500000061733014360276512013773 0ustar cammcamm @node Glossary (Glossary), Appendix, Environment, Top @chapter Glossary @menu * Glossary:: @end menu @node Glossary, , Glossary (Glossary), Glossary (Glossary) @section Glossary @c including concept-glossary Each entry in this glossary has the following parts: @table @asis @item @t{*} the term being defined, set in boldface. @item @t{*} optional pronunciation, enclosed in square brackets and set in boldface, as in the following example: pronounced 'a ,list . The pronunciation key follows @i{Webster's Third New International Dictionary the English Language, Unabridged}, except that ``e'' is used to notate the schwa (upside-down ``e'') character. @item @t{*} the part or parts of speech, set in italics. If a term can be used as several parts of speech, there is a separate definition for each part of speech. @item @t{*} one or more definitions, organized as follows: @table @asis @item -- an optional number, present if there are several definitions. Lowercase letters might also be used in cases where subdefinitions of a numbered definition are necessary. @item -- an optional part of speech, set in italics, present if the term is one of several parts of speech. @item -- an optional discipline, set in italics, present if the term has a standard definition being repeated. For example, ``Math.'' @item -- an optional context, present if this definition is meaningful only in that context. For example, ``(of a @i{symbol})''. @item -- the definition. @item -- an optional example sentence. For example, ``This is an example of an example.'' @item -- optional cross references. @end table @end table In addition, some terms have idiomatic usage in the Common Lisp community which is not shared by other communities, or which is not technically correct. Definitions labeled ``Idiom.'' represent such idiomatic usage; these definitions are sometimes followed by an explanatory note. Words in @i{this font} are words with entries in the glossary. Words in example sentences do not follow this convention. When an ambiguity arises, the longest matching substring has precedence. For example, ``@i{complex float}'' refers to a single glossary entry for ``@i{complex float}'' rather than the combined meaning of the glossary terms ``@i{complex}'' and ``@i{float}.'' Subscript notation, as in ``@i{something}_n'' means that the @i{n}th definition of ``@i{something}'' is intended. This notation is used only in situations where the context might be insufficient to disambiguate. The following are abbreviations used in the glossary: Abbreviation Meaning @table @asis @item @i{adj.} adjective @item @i{adv.} adverb @item @i{ANSI} compatible with one or more ANSI standards @item @i{Comp.} computers @item @i{Idiom.} idiomatic @item @i{IEEE} compatible with one or more IEEE standards @item @i{ISO} compatible with one or more ISO standards @item @i{Math.} mathematics @item @i{Trad.} traditional @item @i{n.} noun @item @i{v.} verb @item @i{v.t.} transitive verb @end table @c @table @asis @subheading @b{Non-alphabetic} @table @asis @IGindex () @item @b{()} pronounced 'nil , @i{n.} an alternative notation for writing the symbol~@b{nil}, used to emphasize the use of @i{nil} as an @i{empty list}. @end table @subheading @b{A} @table @asis @IGindex absolute @item @b{absolute} @i{adj.} 1. (of a @i{time}) representing a specific point in time. 2. (of a @i{pathname}) representing a specific position in a directory hierarchy. See @i{relative}. @IGindex access @item @b{access} @i{n.}, @i{v.t.} 1. @i{v.t.} (a @i{place}, or @i{array}) to @i{read}_1 or @i{write}_1 the @i{value} of the @i{place} or an @i{element} of the @i{array}. 2. @i{n.} (of a @i{place}) an attempt to @i{access}_1 the @i{value} of the @i{place}. @IGindex accessibility @item @b{accessibility} @i{n.} the state of being @i{accessible}. @IGindex accessible @item @b{accessible} @i{adj.} 1. (of an @i{object}) capable of being @i{referenced}. 2. (of @i{shared slots} or @i{local slots} in an @i{instance} of a @i{class}) having been defined by the @i{class} of the @i{instance} or @i{inherited} from a @i{superclass} of that @i{class}. 3. (of a @i{symbol} in a @i{package}) capable of being @i{referenced} without a @i{package prefix} when that @i{package} is current, regardless of whether the @i{symbol} is @i{present} in that @i{package} or is @i{inherited}. @IGindex accessor @item @b{accessor} @i{n.} an @i{operator} that performs an @i{access}. See @i{reader} and @i{writer}. @IGindex active @item @b{active} @i{adj.} 1. (of a @i{handler}, a @i{restart}, or a @i{catch tag}) having been @i{established} but not yet @i{disestablished}. 2. (of an @i{element} of an @i{array}) having an index that is greater than or equal to zero, but less than the @i{fill pointer} (if any). For an @i{array} that has no @i{fill pointer}, all @i{elements} are considered @i{active}. @IGindex actual adjustability @item @b{actual adjustability} @i{n.} (of an @i{array}) a @i{generalized boolean} that is associated with the @i{array}, representing whether the @i{array} is @i{actually adjustable}. See also @i{expressed adjustability} and @b{adjustable-array-p}. @IGindex actual argument @item @b{actual argument} @i{n.} @i{Trad.} an @i{argument}. @IGindex actual array element type @item @b{actual array element type} @i{n.} (of an @i{array}) the @i{type} for which the @i{array} is actually specialized, which is the @i{upgraded array element type} of the @i{expressed array element type} of the @i{array}. See the @i{function} @b{array-element-type}. @IGindex actual complex part type @item @b{actual complex part type} @i{n.} (of a @i{complex}) the @i{type} in which the real and imaginary parts of the @i{complex} are actually represented, which is the @i{upgraded complex part type} of the @i{expressed complex part type} of the @i{complex}. @IGindex actual parameter @item @b{actual parameter} @i{n.} @i{Trad.} an @i{argument}. @IGindex actually adjustable @item @b{actually adjustable} @i{adj.} (of an @i{array}) such that @b{adjust-array} can adjust its characteristics by direct modification. A @i{conforming program} may depend on an @i{array} being @i{actually adjustable} only if either that @i{array} is known to have been @i{expressly adjustable} or if that @i{array} has been explicitly tested by @b{adjustable-array-p}. @IGindex adjustability @item @b{adjustability} @i{n.} (of an @i{array}) 1. @i{expressed adjustability}. 2. @i{actual adjustability}. @IGindex adjustable @item @b{adjustable} @i{adj.} (of an @i{array}) 1. @i{expressly adjustable}. 2. @i{actually adjustable}. @IGindex after method @item @b{after method} @i{n.} a @i{method} having the @i{qualifier} @t{:after}. @IGindex alist @item @b{alist} pronounced '\=a ,list , @i{n.} an @i{association list}. @IGindex alphabetic @item @b{alphabetic} @i{n.}, @i{adj.} 1. @i{adj.} (of a @i{character}) being one of the @i{standard characters} @t{A} through @t{Z} or @t{a} through @t{z}, or being any @i{implementation-defined} character that has @i{case}, or being some other @i{graphic} @i{character} defined by the @i{implementation} to be @i{alphabetic}_1. 2. a. @i{n.} one of several possible @i{constituent traits} of a @i{character}. For details, see @ref{Constituent Characters} and @ref{Reader Algorithm}. b. @i{adj.} (of a @i{character}) being a @i{character} that has @i{syntax type} @i{constituent} in the @i{current readtable} and that has the @i{constituent trait} @i{alphabetic}_@{2a@}. See @i{Figure~2--8}. @IGindex alphanumeric @item @b{alphanumeric} @i{adj.} (of a @i{character}) being either an @i{alphabetic}_1 @i{character} or a @i{numeric} @i{character}. @IGindex ampersand @item @b{ampersand} @i{n.} the @i{standard character} that is called ``ampersand'' (@t{&}). See @i{Figure~2--5}. @IGindex anonymous @item @b{anonymous} @i{adj.} 1. (of a @i{class} or @i{function}) having no @i{name} 2. (of a @i{restart}) having a @i{name} of @b{nil}. @IGindex apparently uninterned @item @b{apparently uninterned} @i{adj.} having a @i{home package} of @b{nil}. (An @i{apparently uninterned} @i{symbol} might or might not be an @i{uninterned} @i{symbol}. @i{Uninterned symbols} have a @i{home package} of @b{nil}, but @i{symbols} which have been @i{uninterned} from their @i{home package} also have a @i{home package} of @b{nil}, even though they might still be @i{interned} in some other @i{package}.) @IGindex applicable @item @b{applicable} @i{adj.} 1. (of a @i{handler}) being an @i{applicable handler}. 2. (of a @i{method}) being an @i{applicable method}. 3. (of a @i{restart}) being an @i{applicable restart}. @IGindex applicable handler @item @b{applicable handler} @i{n.} (for a @i{condition} being @i{signaled}) an @i{active} @i{handler} for which the associated type contains the @i{condition}. @IGindex applicable method @item @b{applicable method} @i{n.} (of a @i{generic function} called with @i{arguments}) a @i{method} of the @i{generic function} for which the @i{arguments} satisfy the @i{parameter specializers} of that @i{method}. See @ref{Selecting the Applicable Methods}. @IGindex applicable restart @item @b{applicable restart} @i{n.} 1. (for a @i{condition}) an @i{active} @i{handler} for which the associated test returns @i{true} when given the @i{condition} as an argument. 2. (for no particular @i{condition}) an @i{active} @i{handler} for which the associated test returns @i{true} when given @b{nil} as an argument. @IGindex apply @item @b{apply} @i{v.t.} (a @i{function} to a @i{list}) to @i{call} the @i{function} with arguments that are the @i{elements} of the @i{list}. ``Applying the function @b{+} to a list of integers returns the sum of the elements of that list.'' @IGindex argument @item @b{argument} @i{n.} 1. (of a @i{function}) an @i{object} which is offered as data to the @i{function} when it is @i{called}. 2. (of a @i{format control}) a @i{format argument}. @IGindex argument evaluation order @item @b{argument evaluation order} @i{n.} the order in which @i{arguments} are evaluated in a function call. ``The argument evaluation order for Common Lisp is left to right.'' See @ref{Evaluation}. @IGindex argument precedence order @item @b{argument precedence order} @i{n.} the order in which the @i{arguments} to a @i{generic function} are considered when sorting the @i{applicable methods} into precedence order. @IGindex around method @item @b{around method} @i{n.} a @i{method} having the @i{qualifier} @t{:around}. @IGindex array @item @b{array} @i{n.} an @i{object} of @i{type} @b{array}, which serves as a container for other @i{objects} arranged in a Cartesian coordinate system. @IGindex array element type @item @b{array element type} @i{n.} (of an @i{array}) 1. a @i{type} associated with the @i{array}, and of which all @i{elements} of the @i{array} are constrained to be members. 2. the @i{actual array element type} of the @i{array}. 3. the @i{expressed array element type} of the @i{array}. @IGindex array total size @item @b{array total size} @i{n.} the total number of @i{elements} in an @i{array}, computed by taking the product of the @i{dimensions} of the @i{array}. (The size of a zero-dimensional @i{array} is therefore one.) @IGindex assign @item @b{assign} @i{v.t.} (a @i{variable}) to change the @i{value} of the @i{variable} in a @i{binding} that has already been @i{established}. See the @i{special operator} @b{setq}. @IGindex association list @item @b{association list} @i{n.} a @i{list} of @i{conses} representing an association of @i{keys} with @i{values}, where the @i{car} of each @i{cons} is the @i{key} and the @i{cdr} is the @i{value} associated with that @i{key}. @IGindex asterisk @item @b{asterisk} @i{n.} the @i{standard character} that is variously called ``asterisk'' or ``star'' (@t{*}). See @i{Figure~2--5}. @IGindex at-sign @item @b{at-sign} @i{n.} the @i{standard character} that is variously called ``commercial at'' or ``at sign'' (@t{@@}). See @i{Figure~2--5}. @IGindex atom @item @b{atom} @i{n.} any @i{object} that is not a @i{cons}. ``A vector is an atom.'' @IGindex atomic @item @b{atomic} @i{adj.} being an @i{atom}. ``The number 3, the symbol @t{foo}, and @b{nil} are atomic.'' @IGindex atomic type specifier @item @b{atomic type specifier} @i{n.} a @i{type specifier} that is @i{atomic}. For every @i{atomic type specifier}, @i{x}, there is an equivalent @i{compound type specifier} with no arguments supplied, @t{(@i{x})}. @IGindex attribute @item @b{attribute} @i{n.} (of a @i{character}) a program-visible aspect of the @i{character}. The only @i{standardized} @i{attribute} of a @i{character} is its @i{code}_2, but @i{implementations} are permitted to have additional @i{implementation-defined} @i{attributes}. See @ref{Character Attributes}. ``An implementation that support fonts might make font information an attribute of a character, while others might represent font information separately from characters.'' @IGindex aux variable @item @b{aux variable} @i{n.} a @i{variable} that occurs in the part of a @i{lambda list} that was introduced by @b{&aux}. Unlike all other @i{variables} introduced by a @i{lambda-list}, @i{aux variables} are not @i{parameters}. @IGindex auxiliary method @item @b{auxiliary method} @i{n.} a member of one of two sets of @i{methods} (the set of @i{primary methods} is the other) that form an exhaustive partition of the set of @i{methods} on the @i{method}'s @i{generic function}. How these sets are determined is dependent on the @i{method combination} type; see @ref{Introduction to Methods}. @end table @subheading @b{B} @table @asis @IGindex backquote @item @b{backquote} @i{n.} the @i{standard character} that is variously called ``grave accent'' or ``backquote'' (@t{`}). See @i{Figure~2--5}. @IGindex backslash @item @b{backslash} @i{n.} the @i{standard character} that is variously called ``reverse solidus'' or ``backslash'' (@t{\}). See @i{Figure~2--5}. @IGindex base character @item @b{base character} @i{n.} a @i{character} of @i{type} @b{base-char}. @IGindex base string @item @b{base string} @i{n.} a @i{string} of @i{type} @b{base-string}. @IGindex before method @item @b{before method} @i{n.} a @i{method} having the @i{qualifier} @t{:before}. @IGindex bidirectional @item @b{bidirectional} @i{adj.} (of a @i{stream}) being both an @i{input} @i{stream} and an @i{output} @i{stream}. @IGindex binary @item @b{binary} @i{adj.} 1. (of a @i{stream}) being a @i{stream} that has an @i{element type} that is a @i{subtype} of @i{type} @b{integer}. The most fundamental operation on a @i{binary} @i{input} @i{stream} is @b{read-byte} and on a @i{binary} @i{output} @i{stream} is @b{write-byte}. See @i{character}. 2. (of a @i{file}) having been created by opening a @i{binary} @i{stream}. (It is @i{implementation-dependent} whether this is an detectable aspect of the @i{file}, or whether any given @i{character} @i{file} can be treated as a @i{binary} @i{file}.) @IGindex bind @item @b{bind} @i{v.t.} (a @i{variable}) to establish a @i{binding} for the @i{variable}. @IGindex binding @item @b{binding} @i{n.} an association between a @i{name} and that which the @i{name} denotes. ``A lexical binding is a lexical association between a name and its value.'' @IGindex bit @item @b{bit} @i{n.} an @i{object} of @i{type} @b{bit}; that is, the @i{integer} @t{0} or the @i{integer} @t{1}. @IGindex bit array @item @b{bit array} @i{n.} a specialized @i{array} that is of @i{type} @t{(array bit)}, and whose elements are of @i{type} @b{bit}. @IGindex bit vector @item @b{bit vector} @i{n.} a specialized @i{vector} that is of @i{type} @b{bit-vector}, and whose elements are of @i{type} @b{bit}. @IGindex bit-wise logical operation specifier @item @b{bit-wise logical operation specifier} @i{n.} an @i{object} which names one of the sixteen possible bit-wise logical operations that can be performed by the @b{boole} function, and which is the @i{value} of exactly one of the @i{constant variables} @b{boole-clr}, @b{boole-set}, @b{boole-1}, @b{boole-2}, @b{boole-c1}, @b{boole-c2}, @b{boole-and}, @b{boole-ior}, @b{boole-xor}, @b{boole-eqv}, @b{boole-nand}, @b{boole-nor}, @b{boole-andc1}, @b{boole-andc2}, @b{boole-orc1}, or @b{boole-orc2}. @IGindex block @item @b{block} @i{n.} a named lexical @i{exit point}, @i{established} explicitly by @b{block} or implicitly by @i{operators} such as @b{loop}, @b{do} and @b{prog}, to which control and values may be transfered by using a @b{return-from} @i{form} with the name of the @i{block}. @IGindex block tag @item @b{block tag} @i{n.} the @i{symbol} that, within the @i{lexical scope} of a @b{block} @i{form}, names the @i{block} @i{established} by that @b{block} @i{form}. See @b{return} or @b{return-from}. @IGindex boa lambda list @item @b{boa lambda list} @i{n.} a @i{lambda list} that is syntactically like an @i{ordinary lambda list}, but that is processed in ``@b{b}y @b{o}rder of @b{a}rgument'' style. See @ref{Boa Lambda Lists}. @IGindex body parameter @item @b{body parameter} @i{n.} a @i{parameter} available in certain @i{lambda lists} which from the point of view of @i{conforming programs} is like a @i{rest parameter} in every way except that it is introduced by @b{&body} instead of @b{&rest}. (@i{Implementations} are permitted to provide extensions which distinguish @i{body parameters} and @i{rest parameters}---@i{e.g.}, the @i{forms} for @i{operators} which were defined using a @i{body parameter} might be pretty printed slightly differently than @i{forms} for @i{operators} which were defined using @i{rest parameters}.) @IGindex boolean @item @b{boolean} @i{n.} an @i{object} of @i{type} @b{boolean}; that is, one of the following @i{objects}: the symbol~@b{t} (representing @i{true}), or the symbol~@b{nil} (representing @i{false}). See @i{generalized boolean}. @IGindex boolean equivalent @item @b{boolean equivalent} @i{n.} (of an @i{object} O_1) any @i{object} O_2 that has the same truth value as O_1 when both O_1 and O_2 are viewed as @i{generalized booleans}. @IGindex bound @item @b{bound} @i{adj.}, @i{v.t.} 1. @i{adj.} having an associated denotation in a @i{binding}. ``The variables named by a @b{let} are bound within its body.'' See @i{unbound}. 2. @i{adj.} having a local @i{binding} which @i{shadows}_2 another. ``The variable @b{*print-escape*} is bound while in the @b{princ} function.'' 3. @i{v.t.} the past tense of @i{bind}. @IGindex bound declaration @item @b{bound declaration} @i{n.} a @i{declaration} that refers to or is associated with a @i{variable} or @i{function} and that appears within the @i{special form} that @i{establishes} the @i{variable} or @i{function}, but before the body of that @i{special form} (specifically, at the head of that @i{form}'s body). (If a @i{bound declaration} refers to a @i{function} @i{binding} or a @i{lexical variable} @i{binding}, the @i{scope} of the @i{declaration} is exactly the @i{scope} of that @i{binding}. If the @i{declaration} refers to a @i{dynamic variable} @i{binding}, the @i{scope} of the @i{declaration} is what the @i{scope} of the @i{binding} would have been if it were lexical rather than dynamic.) @IGindex bounded @item @b{bounded} @i{adj.} (of a @i{sequence} S, by an ordered pair of @i{bounding indices} i_@{start@} and i_@{end@}) restricted to a subrange of the @i{elements} of S that includes each @i{element} beginning with (and including) the one indexed by i_@{start@} and continuing up to (but not including) the one indexed by i_@{end@}. @IGindex bounding index @item @b{bounding index} @i{n.} (of a @i{sequence} with @i{length} n) either of a conceptual pair of @i{integers}, i_@{start@} and i_@{end@}, respectively called the ``lower bounding index'' and ``upper bounding index'', such that 0 <= i_@{start@} <= i_@{end@} <= n, and which therefore delimit a subrange of the @i{sequence} @i{bounded} by i_@{start@} and i_@{end@}. @IGindex bounding index designator @item @b{bounding index designator} (for a @i{sequence}) one of two @i{objects} that, taken together as an ordered pair, behave as a @i{designator} for @i{bounding indices} of the @i{sequence}; that is, they denote @i{bounding indices} of the @i{sequence}, and are either: an @i{integer} (denoting itself) and @b{nil} (denoting the @i{length} of the @i{sequence}), or two @i{integers} (each denoting themselves). @IGindex break loop @item @b{break loop} @i{n.} A variant of the normal @i{Lisp read-eval-print loop} that is recursively entered, usually because the ongoing @i{evaluation} of some other @i{form} has been suspended for the purpose of debugging. Often, a @i{break loop} provides the ability to exit in such a way as to continue the suspended computation. See the @i{function} @b{break}. @IGindex broadcast stream @item @b{broadcast stream} @i{n.} an @i{output} @i{stream} of @i{type} @b{broadcast-stream}. @IGindex built-in class @item @b{built-in class} @i{n.} a @i{class} that is a @i{generalized instance} of @i{class} @b{built-in-class}. @IGindex built-in type @item @b{built-in type} @i{n.} one of the @i{types} in @i{Figure~4--2}. @IGindex byte @item @b{byte} @i{n.} 1. adjacent bits within an @i{integer}. (The specific number of bits can vary from point to point in the program; see the @i{function} @b{byte}.) 2. an integer in a specified range. (The specific range can vary from point to point in the program; see the @i{functions} @b{open} and @b{write-byte}.) @IGindex byte specifier @item @b{byte specifier} @i{n.} An @i{object} of @i{implementation-dependent} nature that is returned by the @i{function} @b{byte} and that specifies the range of bits in an @i{integer} to be used as a @i{byte} by @i{functions} such as @b{ldb}. @end table @subheading @b{C} @table @asis @IGindex cadr @item @b{cadr} pronounced 'ka ,de r , @i{n.} (of an @i{object}) the @i{car} of the @i{cdr} of that @i{object}. @IGindex call @item @b{call} @i{v.t.}, @i{n.} 1. @i{v.t.} (a @i{function} with @i{arguments}) to cause the @i{code} represented by that @i{function} to be @i{executed} in an @i{environment} where @i{bindings} for the @i{values} of its @i{parameters} have been @i{established} based on the @i{arguments}. ``Calling the function @b{+} with the arguments @t{5} and @t{1} yields a value of @t{6}.'' 2. @i{n.} a @i{situation} in which a @i{function} is called. @IGindex captured initialization form @item @b{captured initialization form} @i{n.} an @i{initialization form} along with the @i{lexical environment} in which the @i{form} that defined the @i{initialization form} was @i{evaluated}. ``Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified in the @b{defclass} form for the new class.'' @IGindex car @item @b{car} @i{n.} 1. a. (of a @i{cons}) the component of a @i{cons} corresponding to the first @i{argument} to @b{cons}; the other component is the @i{cdr}. ``The function @b{rplaca} modifies the car of a cons.'' b. (of a @i{list}) the first @i{element} of the @i{list}, or @b{nil} if the @i{list} is the @i{empty list}. 2. the @i{object} that is held in the @i{car}_1. ``The function @b{car} returns the car of a cons.'' @IGindex case @item @b{case} @i{n.} (of a @i{character}) the property of being either @i{uppercase} or @i{lowercase}. Not all @i{characters} have @i{case}. ``The characters @t{#\A} and @t{#\a} have case, but the character @t{#\$} has no case.'' See @ref{Characters With Case} and the @i{function} @b{both-case-p}. @IGindex case sensitivity mode @item @b{case sensitivity mode} @i{n.} one of the @i{symbols} @t{:upcase}, @t{:downcase}, @t{:preserve}, or @t{:invert}. @IGindex catch @item @b{catch} @i{n.} an @i{exit point} which is @i{established} by a @b{catch} @i{form} within the @i{dynamic scope} of its body, which is named by a @i{catch tag}, and to which control and @i{values} may be @i{thrown}. @IGindex catch tag @item @b{catch tag} @i{n.} an @i{object} which names an @i{active} @i{catch}. (If more than one @i{catch} is active with the same @i{catch tag}, it is only possible to @i{throw} to the innermost such @i{catch} because the outer one is @i{shadowed}_2.) @IGindex cddr @item @b{cddr} pronounced 'kud e ,de r or pronounced 'ke ,dude r , @i{n.} (of an @i{object}) the @i{cdr} of the @i{cdr} of that @i{object}. @IGindex cdr @item @b{cdr} pronounced 'ku ,de r , @i{n.} 1. a. (of a @i{cons}) the component of a @i{cons} corresponding to the second @i{argument} to @b{cons}; the other component is the @i{car}. ``The function @b{rplacd} modifies the cdr of a cons.'' b. (of a @i{list} L_1) either the @i{list} L_2 that contains the @i{elements} of L_1 that follow after the first, or else @b{nil} if L_1 is the @i{empty list}. 2. the @i{object} that is held in the @i{cdr}_1. ``The function @b{cdr} returns the cdr of a cons.'' @IGindex cell @item @b{cell} @i{n.} @i{Trad.} (of an @i{object}) a conceptual @i{slot} of that @i{object}. The @i{dynamic variable} and global @i{function} @i{bindings} of a @i{symbol} are sometimes referred to as its @i{value cell} and @i{function cell}, respectively. @IGindex character @item @b{character} @i{n.}, @i{adj.} 1. @i{n.} an @i{object} of @i{type} @b{character}; that is, an @i{object} that represents a unitary token in an aggregate quantity of text; see @ref{Character Concepts}. 2. @i{adj.} a. (of a @i{stream}) having an @i{element type} that is a @i{subtype} of @i{type} @b{character}. The most fundamental operation on a @i{character} @i{input} @i{stream} is @b{read-char} and on a @i{character} @i{output} @i{stream} is @b{write-char}. See @i{binary}. b. (of a @i{file}) having been created by opening a @i{character} @i{stream}. (It is @i{implementation-dependent} whether this is an inspectable aspect of the @i{file}, or whether any given @i{binary} @i{file} can be treated as a @i{character} @i{file}.) @IGindex character code @item @b{character code} @i{n.} 1. one of possibly several @i{attributes} of a @i{character}. 2. a non-negative @i{integer} less than the @i{value} of @b{char-code-limit} that is suitable for use as a @i{character code}_1. @IGindex character designator @item @b{character designator} @i{n.} a @i{designator} for a @i{character}; that is, an @i{object} that denotes a @i{character} and that is one of: a @i{designator} for a @i{string} of @i{length} one (denoting the @i{character} that is its only @i{element}), or a @i{character} (denoting itself). @IGindex circular @item @b{circular} @i{adj.} 1. (of a @i{list}) a @i{circular list}. 2. (of an arbitrary @i{object}) having a @i{component}, @i{element}, @i{constituent}_2, or @i{subexpression} (as appropriate to the context) that is the @i{object} itself. @IGindex circular list @item @b{circular list} @i{n.} a chain of @i{conses} that has no termination because some @i{cons} in the chain is the @i{cdr} of a later @i{cons}. @IGindex class @item @b{class} @i{n.} 1. an @i{object} that uniquely determines the structure and behavior of a set of other @i{objects} called its @i{direct instances}, that contributes structure and behavior to a set of other @i{objects} called its @i{indirect instances}, and that acts as a @i{type specifier} for a set of objects called its @i{generalized instances}. ``The class @b{integer} is a subclass of the class @b{number}.'' (Note that the phrase ``the @i{class} @t{foo}'' is often substituted for the more precise phrase ``the @i{class} named @t{foo}''---in both cases, a @i{class} @i{object} (not a @i{symbol}) is denoted.) 2. (of an @i{object}) the uniquely determined @i{class} of which the @i{object} is a @i{direct instance}. See the @i{function} @b{class-of}. ``The class of the object returned by @b{gensym} is @b{symbol}.'' (Note that with this usage a phrase such as ``its @i{class} is @t{foo}'' is often substituted for the more precise phrase ``its @i{class} is the @i{class} named @t{foo}''---in both cases, a @i{class} @i{object} (not a @i{symbol}) is denoted.) @IGindex class designator @item @b{class designator} @i{n.} a @i{designator} for a @i{class}; that is, an @i{object} that denotes a @i{class} and that is one of: a @i{symbol} (denoting the @i{class} named by that @i{symbol}; see the @i{function} @b{find-class}) or a @i{class} (denoting itself). @IGindex class precedence list @item @b{class precedence list} @i{n.} a unique total ordering on a @i{class} and its @i{superclasses} that is consistent with the @i{local precedence orders} for the @i{class} and its @i{superclasses}. For detailed information, see @ref{Determining the Class Precedence List}. @IGindex close @item @b{close} @i{v.t.} (a @i{stream}) to terminate usage of the @i{stream} as a source or sink of data, permitting the @i{implementation} to reclaim its internal data structures, and to free any external resources which might have been locked by the @i{stream} when it was opened. @IGindex closed @item @b{closed} @i{adj.} (of a @i{stream}) having been @i{closed} (see @i{close}). Some (but not all) operations that are valid on @i{open} @i{streams} are not valid on @i{closed} @i{streams}. See @ref{File Operations on Open and Closed Streams}. @IGindex closure @item @b{closure} @i{n.} a @i{lexical closure}. @IGindex coalesce @item @b{coalesce} @i{v.t.} (@i{literal objects} that are @i{similar}) to consolidate the identity of those @i{objects}, such that they become the @i{same} @i{object}. See @ref{Compiler Terminology}. @IGindex code @item @b{code} @i{n.} 1. @i{Trad.} any representation of actions to be performed, whether conceptual or as an actual @i{object}, such as @i{forms}, @i{lambda expressions}, @i{objects} of @i{type} @i{function}, text in a @i{source file}, or instruction sequences in a @i{compiled file}. This is a generic term; the specific nature of the representation depends on its context. 2. (of a @i{character}) a @i{character code}. @IGindex coerce @item @b{coerce} @i{v.t.} (an @i{object} to a @i{type}) to produce an @i{object} from the given @i{object}, without modifying that @i{object}, by following some set of coercion rules that must be specifically stated for any context in which this term is used. The resulting @i{object} is necessarily of the indicated @i{type}, except when that type is a @i{subtype} of @i{type} @b{complex}; in that case, if a @i{complex rational} with an imaginary part of zero would result, the result is a @i{rational} rather than a @i{complex}---see @ref{Rule of Canonical Representation for Complex Rationals}. @IGindex colon @item @b{colon} @i{n.} the @i{standard character} that is called ``colon'' (@t{:}). See @i{Figure~2--5}. @IGindex comma @item @b{comma} @i{n.} the @i{standard character} that is called ``comma'' (@t{,}). See @i{Figure~2--5}. @IGindex compilation @item @b{compilation} @i{n.} the process of @i{compiling} @i{code} by the @i{compiler}. @IGindex compilation environment @item @b{compilation environment} @i{n.} 1. An @i{environment} that represents information known by the @i{compiler} about a @i{form} that is being @i{compiled}. See @ref{Compiler Terminology}. 2. An @i{object} that represents the @i{compilation environment}_1 and that is used as a second argument to a @i{macro function} (which supplies a @i{value} for any @b{&environment} @i{parameter} in the @i{macro function}'s definition). @IGindex compilation unit @item @b{compilation unit} @i{n.} an interval during which a single unit of compilation is occurring. See the @i{macro} @b{with-compilation-unit}. @IGindex compile @item @b{compile} @i{v.t.} 1. (@i{code}) to perform semantic preprocessing of the @i{code}, usually optimizing one or more qualities of the code, such as run-time speed of @i{execution} or run-time storage usage. The minimum semantic requirements of compilation are that it must remove all macro calls and arrange for all @i{load time values} to be resolved prior to run time. 2. (a @i{function}) to produce a new @i{object} of @i{type} @b{compiled-function} which represents the result of @i{compiling} the @i{code} represented by the @i{function}. See the @i{function} @b{compile}. 3. (a @i{source file}) to produce a @i{compiled file} from a @i{source file}. See the @i{function} @b{compile-file}. @IGindex compile time @item @b{compile time} @i{n.} the duration of time that the @i{compiler} is processing @i{source code}. @IGindex compile-time definition @item @b{compile-time definition} @i{n.} a definition in the @i{compilation environment}. @IGindex compiled code @item @b{compiled code} @i{n.} 1. @i{compiled functions}. 2. @i{code} that represents @i{compiled functions}, such as the contents of a @i{compiled file}. @IGindex compiled file @item @b{compiled file} @i{n.} a @i{file} which represents the results of @i{compiling} the @i{forms} which appeared in a corresponding @i{source file}, and which can be @i{loaded}. See the @i{function} @b{compile-file}. @IGindex compiled function @item @b{compiled function} @i{n.} an @i{object} of @i{type} @b{compiled-function}, which is a @i{function} that has been @i{compiled}, which contains no references to @i{macros} that must be expanded at run time, and which contains no unresolved references to @i{load time values}. @IGindex compiler @item @b{compiler} @i{n.} a facility that is part of Lisp and that translates @i{code} into an @i{implementation-dependent} form that might be represented or @i{executed} efficiently. The functions @b{compile} and @b{compile-file} permit programs to invoke the @i{compiler}. @IGindex compiler macro @item @b{compiler macro} @i{n.} an auxiliary macro definition for a globally defined @i{function} or @i{macro} which might or might not be called by any given @i{conforming implementation} and which must preserve the semantics of the globally defined @i{function} or @i{macro} but which might perform some additional optimizations. (Unlike a @i{macro}, a @i{compiler macro} does not extend the syntax of @r{Common Lisp}; rather, it provides an alternate implementation strategy for some existing syntax or functionality.) @IGindex compiler macro expansion @item @b{compiler macro expansion} @i{n.} 1. the process of translating a @i{form} into another @i{form} by a @i{compiler macro}. 2. the @i{form} resulting from this process. @IGindex compiler macro form @item @b{compiler macro form} @i{n.} a @i{function form} or @i{macro form} whose @i{operator} has a definition as a @i{compiler macro}, or a @b{funcall} @i{form} whose first @i{argument} is a @b{function} @i{form} whose @i{argument} is the @i{name} of a @i{function} that has a definition as a @i{compiler macro}. @IGindex compiler macro function @item @b{compiler macro function} @i{n.} a @i{function} of two arguments, a @i{form} and an @i{environment}, that implements @i{compiler macro expansion} by producing either a @i{form} to be used in place of the original argument @i{form} or else @b{nil}, indicating that the original @i{form} should not be replaced. See @ref{Compiler Macros}. @IGindex complex @item @b{complex} @i{n.} an @i{object} of @i{type} @b{complex}. @IGindex complex float @item @b{complex float} @i{n.} an @i{object} of @i{type} @b{complex} which has a @i{complex part type} that is a @i{subtype} of @b{float}. A @i{complex float} is a @i{complex}, but it is not a @i{float}. @IGindex complex part type @item @b{complex part type} @i{n.} (of a @i{complex}) 1. the @i{type} which is used to represent both the real part and the imaginary part of the @i{complex}. 2. the @i{actual complex part type} of the @i{complex}. 3. the @i{expressed complex part type} of the @i{complex}. @IGindex complex rational @item @b{complex rational} @i{n.} an @i{object} of @i{type} @b{complex} which has a @i{complex part type} that is a @i{subtype} of @b{rational}. A @i{complex rational} is a @i{complex}, but it is not a @i{rational}. No @i{complex rational} has an imaginary part of zero because such a number is always represented by @r{Common Lisp} as an @i{object} of @i{type} @b{rational}; see @ref{Rule of Canonical Representation for Complex Rationals}. @IGindex complex single float @item @b{complex single float} @i{n.} an @i{object} of @i{type} @b{complex} which has a @i{complex part type} that is a @i{subtype} of @b{single-float}. A @i{complex single float} is a @i{complex}, but it is not a @i{single float}. @IGindex composite stream @item @b{composite stream} @i{n.} a @i{stream} that is composed of one or more other @i{streams}. ``@b{make-synonym-stream} creates a composite stream.'' @IGindex compound form @item @b{compound form} @i{n.} a @i{non-empty} @i{list} which is a @i{form}: a @i{special form}, a @i{lambda form}, a @i{macro form}, or a @i{function form}. @IGindex compound type specifier @item @b{compound type specifier} @i{n.} a @i{type specifier} that is a @i{cons}; @i{i.e.}, a @i{type specifier} that is not an @i{atomic type specifier}. ``@t{(vector single-float)} is a compound type specifier.'' @IGindex concatenated stream @item @b{concatenated stream} @i{n.} an @i{input} @i{stream} of @i{type} @b{concatenated-stream}. @IGindex condition @item @b{condition} @i{n.} 1. an @i{object} which represents a @i{situation}---usually, but not necessarily, during @i{signaling}. 2. an @i{object} of @i{type} @b{condition}. @IGindex condition designator @item @b{condition designator} @i{n.} one or more @i{objects} that, taken together, denote either an existing @i{condition} @i{object} or a @i{condition} @i{object} to be implicitly created. For details, see @ref{Condition Designators}. @IGindex condition handler @item @b{condition handler} @i{n.} a @i{function} that might be invoked by the act of @i{signaling}, that receives the @i{condition} being signaled as its only argument, and that is permitted to @i{handle} the @i{condition} or to @i{decline}. See @ref{Signaling}. @IGindex condition reporter @item @b{condition reporter} @i{n.} a @i{function} that describes how a @i{condition} is to be printed when the @i{Lisp printer} is invoked while @b{*print-escape*} is @i{false}. See @ref{Printing Conditions}. @IGindex conditional newline @item @b{conditional newline} @i{n.} a point in output where a @i{newline} might be inserted at the discretion of the @i{pretty printer}. There are four kinds of @i{conditional newlines}, called ``linear-style,'' ``fill-style,'' ``miser-style,'' and ``mandatory-style.'' See the @i{function} @b{pprint-newline} and @ref{Dynamic Control of the Arrangement of Output}. @IGindex conformance @item @b{conformance} @i{n.} a state achieved by proper and complete adherence to the requirements of this specification. See @ref{Conformance}. @IGindex conforming code @item @b{conforming code} @i{n.} @i{code} that is all of part of a @i{conforming program}. @IGindex conforming implementation @item @b{conforming implementation} @i{n.} an @i{implementation}, used to emphasize complete and correct adherance to all conformance criteria. A @i{conforming implementation} is capable of accepting a @i{conforming program} as input, preparing that @i{program} for @i{execution}, and executing the prepared @i{program} in accordance with this specification. An @i{implementation} which has been extended may still be a @i{conforming implementation} provided that no extension interferes with the correct function of any @i{conforming program}. @IGindex conforming processor @item @b{conforming processor} @i{n.} @i{ANSI} a @i{conforming implementation}. @IGindex conforming program @item @b{conforming program} @i{n.} a @i{program}, used to emphasize the fact that the @i{program} depends for its correctness only upon documented aspects of @r{Common Lisp}, and can therefore be expected to run correctly in any @i{conforming implementation}. @IGindex congruent @item @b{congruent} @i{n.} conforming to the rules of @i{lambda list} congruency, as detailed in @ref{Congruent Lambda-lists for all Methods of a Generic Function}. @IGindex cons @item @b{cons} @i{n.}@i{v.} 1. @i{n.} a compound data @i{object} having two components called the @i{car} and the @i{cdr}. 2. @i{v.} to create such an @i{object}. 3. @i{v.} @i{Idiom.} to create any @i{object}, or to allocate storage. @IGindex constant @item @b{constant} @i{n.} 1. a @i{constant form}. 2. a @i{constant variable}. 3. a @i{constant object}. 4. a @i{self-evaluating object}. @IGindex constant form @item @b{constant form} @i{n.} any @i{form} for which @i{evaluation} always @i{yields} the same @i{value}, that neither affects nor is affected by the @i{environment} in which it is @i{evaluated} (except that it is permitted to refer to the names of @i{constant variables} defined in the @i{environment}), and that neither affects nor is affected by the state of any @i{object} except those @i{objects} that are @i{otherwise inaccessible parts} of @i{objects} created by the @i{form} itself. ``A @b{car} form in which the argument is a @b{quote} form is a constant form.'' @IGindex constant object @item @b{constant object} @i{n.} an @i{object} that is constrained (@i{e.g.}, by its context in a @i{program} or by the source from which it was obtained) to be @i{immutable}. ``A literal object that has been processed by @b{compile-file} is a constant object.'' @IGindex constant variable @item @b{constant variable} @i{n.} a @i{variable}, the @i{value} of which can never change; that is, a @i{keyword}_1 or a @i{named constant}. ``The symbols @b{t}, @b{nil}, @t{:direction}, and @b{most-positive-fixnum} are constant variables.'' @IGindex constituent @item @b{constituent} @i{n.}, @i{adj.} 1. a. @i{n.} the @i{syntax type} of a @i{character} that is part of a @i{token}. For details, see @ref{Constituent Characters}. b. @i{adj.} (of a @i{character}) having the @i{constituent}_@{1a@} @i{syntax type}_2. c. @i{n.} a @i{constituent}_@{1b@} @i{character}. 2. @i{n.} (of a @i{composite stream}) one of possibly several @i{objects} that collectively comprise the source or sink of that @i{stream}. @IGindex constituent trait @item @b{constituent trait} @i{n.} (of a @i{character}) one of several classifications of a @i{constituent} @i{character} in a @i{readtable}. See @ref{Constituent Characters}. @IGindex constructed stream @item @b{constructed stream} @i{n.} a @i{stream} whose source or sink is a Lisp @i{object}. Note that since a @i{stream} is another Lisp @i{object}, @i{composite streams} are considered @i{constructed streams}. ``A string stream is a constructed stream.'' @IGindex contagion @item @b{contagion} @i{n.} a process whereby operations on @i{objects} of differing @i{types} (@i{e.g.}, arithmetic on mixed @i{types} of @i{numbers}) produce a result whose @i{type} is controlled by the dominance of one @i{argument}'s @i{type} over the @i{types} of the other @i{arguments}. See @ref{Contagion in Numeric Operations}. @IGindex continuable @item @b{continuable} @i{n.} (of an @i{error}) an @i{error} that is @i{correctable} by the @t{continue} restart. @IGindex control form @item @b{control form} @i{n.} 1. a @i{form} that establishes one or more places to which control can be transferred. 2. a @i{form} that transfers control. @IGindex copy @item @b{copy} @i{n.} 1. (of a @i{cons} C) a @i{fresh} @i{cons} with the @i{same} @i{car} and @i{cdr} as C. 2. (of a @i{list} L) a @i{fresh} @i{list} with the @i{same} @i{elements} as L. (Only the @i{list structure} is @i{fresh}; the @i{elements} are the @i{same}.) See the @i{function} @b{copy-list}. 3. (of an @i{association list} A with @i{elements} A_i) a @i{fresh} @i{list} B with @i{elements} B_i, each of which is @b{nil} if A_i is @b{nil}, or else a @i{copy} of the @i{cons} A_i. See the @i{function} @b{copy-alist}. 4. (of a @i{tree} T) a @i{fresh} @i{tree} with the @i{same} @i{leaves} as T. See the @i{function} @b{copy-tree}. 5. (of a @i{random state} R) a @i{fresh} @i{random state} that, if used as an argument to to the @i{function} @b{random} would produce the same series of ``random'' values as R would produce. 6. (of a @i{structure} S) a @i{fresh} @i{structure} that has the same @i{type} as S, and that has slot values, each of which is the @i{same} as the corresponding slot value of S. (Note that since the difference between a @i{cons}, a @i{list}, and a @i{tree} is a matter of ``view'' or ``intention,'' there can be no general-purpose @i{function} which, based solely on the @i{type} of an @i{object}, can determine which of these distinct meanings is intended. The distinction rests solely on the basis of the text description within this document. For example, phrases like ``a @i{copy} of the given @i{list}'' or ``copy of the @i{list} @i{x}'' imply the second definition.) @IGindex correctable @item @b{correctable} @i{adj.} (of an @i{error}) 1. (by a @i{restart} other than @b{abort} that has been associated with the @i{error}) capable of being corrected by invoking that @i{restart}. ``The function @b{cerror} signals an error that is correctable by the @b{continue} @i{restart}.'' (Note that correctability is not a property of an @i{error} @i{object}, but rather a property of the @i{dynamic environment} that is in effect when the @i{error} is @i{signaled}. Specifically, the @i{restart} is ``associated with'' the @i{error} @i{condition} @i{object}. See @ref{Associating a Restart with a Condition}.) 2. (when no specific @i{restart} is mentioned) @i{correctable}_1 by at least one @i{restart}. ``@b{import} signals a correctable error of @i{type} @b{package-error} if any of the imported symbols has the same name as some distinct symbol already accessible in the package.'' @IGindex current input base @item @b{current input base} @i{n.} (in a @i{dynamic environment}) the @i{radix} that is the @i{value} of @b{*read-base*} in that @i{environment}, and that is the default @i{radix} employed by the @i{Lisp reader} and its related @i{functions}. @IGindex current logical block @item @b{current logical block} @i{n.} the context of the innermost lexically enclosing use of @b{pprint-logical-block}. @IGindex current output base @item @b{current output base} @i{n.} (in a @i{dynamic environment}) the @i{radix} that is the @i{value} of @b{*print-base*} in that @i{environment}, and that is the default @i{radix} employed by the @i{Lisp printer} and its related @i{functions}. @IGindex current package @item @b{current package} @i{n.} (in a @i{dynamic environment}) the @i{package} that is the @i{value} of @b{*package*} in that @i{environment}, and that is the default @i{package} employed by the @i{Lisp reader} and @i{Lisp printer}, and their related @i{functions}. @IGindex current pprint dispatch table @item @b{current pprint dispatch table} @i{n.} (in a @i{dynamic environment}) the @i{pprint dispatch table} that is the @i{value} of @b{*print-pprint-dispatch*} in that @i{environment}, and that is the default @i{pprint dispatch table} employed by the @i{pretty printer}. @IGindex current random state @item @b{current random state} @i{n.} (in a @i{dynamic environment}) the @i{random state} that is the @i{value} of @b{*random-state*} in that @i{environment}, and that is the default @i{random state} employed by @b{random}. @IGindex current readtable @item @b{current readtable} @i{n.} (in a @i{dynamic environment}) the @i{readtable} that is the @i{value} of @b{*readtable*} in that @i{environment}, and that affects the way in which @i{expressions}_2 are parsed into @i{objects} by the @i{Lisp reader}. @end table @subheading @b{D} @table @asis @IGindex data type @item @b{data type} @i{n.} @i{Trad.} a @i{type}. @IGindex debug I/O @item @b{debug I/O} @i{n.} the @i{bidirectional} @i{stream} that is the @i{value} of the @i{variable} @b{*debug-io*}. @IGindex debugger @item @b{debugger} @i{n.} a facility that allows the @i{user} to handle a @i{condition} interactively. For example, the @i{debugger} might permit interactive selection of a @i{restart} from among the @i{active} @i{restarts}, and it might perform additional @i{implementation-defined} services for the purposes of debugging. @IGindex declaration @item @b{declaration} @i{n.} a @i{global declaration} or @i{local declaration}. @IGindex declaration identifier @item @b{declaration identifier} @i{n.} one of the @i{symbols} @b{declaration}, @b{dynamic-extent}, @b{ftype}, @b{function}, @b{ignore}, @b{inline}, @b{notinline}, @b{optimize}, @b{special}, or @b{type}; or a @i{symbol} which is the @i{name} of a @i{type}; or a @i{symbol} which has been @i{declared} to be a @i{declaration identifier} by using a @b{declaration} @i{declaration}. @IGindex declaration specifier @item @b{declaration specifier} @i{n.} an @i{expression} that can appear at top level of a @b{declare} expression or a @b{declaim} form, or as the argument to @b{proclaim}, and which has a @i{car} which is a @i{declaration identifier}, and which has a @i{cdr} that is data interpreted according to rules specific to the @i{declaration identifier}. @IGindex declare @item @b{declare} @i{v.} to @i{establish} a @i{declaration}. See @b{declare}, @b{declaim}, or @b{proclaim}. @IGindex decline @item @b{decline} @i{v.} (of a @i{handler}) to return normally without having @i{handled} the @i{condition} being @i{signaled}, permitting the signaling process to continue as if the @i{handler} had not been present. @IGindex decoded time @item @b{decoded time} @i{n.} @i{absolute} @i{time}, represented as an ordered series of nine @i{objects} which, taken together, form a description of a point in calendar time, accurate to the nearest second (except that @i{leap seconds} are ignored). See @ref{Decoded Time}. @IGindex default method @item @b{default method} @i{n.} a @i{method} having no @i{parameter specializers} other than the @i{class} @b{t}. Such a @i{method} is always an @i{applicable method} but might be @i{shadowed}_2 by a more specific @i{method}. @IGindex defaulted initialization argument list @item @b{defaulted initialization argument list} @i{n.} a @i{list} of alternating initialization argument @i{names} and @i{values} in which unsupplied initialization arguments are defaulted, used in the protocol for initializing and reinitializing @i{instances} of @i{classes}. @IGindex define-method-combination arguments lambda list @item @b{define-method-combination arguments lambda list} @i{n.} a @i{lambda list} used by the @t{:arguments} option to @b{define-method-combination}. See @ref{Define-method-combination Arguments Lambda Lists}. @IGindex define-modify-macro lambda list @item @b{define-modify-macro lambda list} @i{n.} a @i{lambda list} used by @b{define-modify-macro}. See @ref{Define-modify-macro Lambda Lists}. @IGindex defined name @item @b{defined name} @i{n.} a @i{symbol} the meaning of which is defined by @r{Common Lisp}. @IGindex defining form @item @b{defining form} @i{n.} a @i{form} that has the side-effect of @i{establishing} a definition. ``@b{defun} and @b{defparameter} are defining forms.'' @IGindex defsetf lambda list @item @b{defsetf lambda list} @i{n.} a @i{lambda list} that is like an @i{ordinary lambda list} except that it does not permit @b{&aux} and that it permits use of @b{&environment}. See @ref{Defsetf Lambda Lists}. @IGindex deftype lambda list @item @b{deftype lambda list} @i{n.} a @i{lambda list} that is like a @i{macro lambda list} except that the default @i{value} for unsupplied @i{optional parameters} and @i{keyword parameters} is the @i{symbol} @b{*} (rather than @b{nil}). See @ref{Deftype Lambda Lists}. @IGindex denormalized @item @b{denormalized} @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) conforming to the description of ``denormalized'' as described by @i{IEEE Standard for Binary Floating-Point Arithmetic}. For example, in an @i{implementation} where the minimum possible exponent was @t{-7} but where @t{0.001} was a valid mantissa, the number @t{1.0e-10} might be representable as @t{0.001e-7} internally even if the @i{normalized} representation would call for it to be represented instead as @t{1.0e-10} or @t{0.1e-9}. By their nature, @i{denormalized} @i{floats} generally have less precision than @i{normalized} @i{floats}. @IGindex derived type @item @b{derived type} @i{n.} a @i{type specifier} which is defined in terms of an expansion into another @i{type specifier}. @b{deftype} defines @i{derived types}, and there may be other @i{implementation-defined} @i{operators} which do so as well. @IGindex derived type specifier @item @b{derived type specifier} @i{n.} a @i{type specifier} for a @i{derived type}. @IGindex designator @item @b{designator} @i{n.} an @i{object} that denotes another @i{object}. In the dictionary entry for an @i{operator} if a @i{parameter} is described as a @i{designator} for a @i{type}, the description of the @i{operator} is written in a way that assumes that appropriate coercion to that @i{type} has already occurred; that is, that the @i{parameter} is already of the denoted @i{type}. For more detailed information, see @ref{Designators}. @IGindex destructive @item @b{destructive} @i{adj.} (of an @i{operator}) capable of modifying some program-visible aspect of one or more @i{objects} that are either explicit @i{arguments} to the @i{operator} or that can be obtained directly or indirectly from the @i{global environment} by the @i{operator}. @IGindex destructuring lambda list @item @b{destructuring lambda list} @i{n.} an @i{extended lambda list} used in @b{destructuring-bind} and nested within @i{macro lambda lists}. See @ref{Destructuring Lambda Lists}. @IGindex different @item @b{different} @i{adj.} not the @i{same} ``The strings @t{"FOO"} and @t{"foo"} are different under @b{equal} but not under @b{equalp}.'' @IGindex digit @item @b{digit} @i{n.} (in a @i{radix}) a @i{character} that is among the possible digits (@t{0} to @t{9}, @t{A} to @t{Z}, and @t{a} to @t{z}) and that is defined to have an associated numeric weight as a digit in that @i{radix}. See @ref{Digits in a Radix}. @IGindex dimension @item @b{dimension} @i{n.} 1. a non-negative @i{integer} indicating the number of @i{objects} an @i{array} can hold along one axis. If the @i{array} is a @i{vector} with a @i{fill pointer}, the @i{fill pointer} is ignored. ``The second dimension of that array is 7.'' 2. an axis of an array. ``This array has six dimensions.'' @IGindex direct instance @item @b{direct instance} @i{n.} (of a @i{class} C) an @i{object} whose @i{class} is C itself, rather than some @i{subclass} of C. ``The function @b{make-instance} always returns a direct instance of the class which is (or is named by) its first argument.'' @IGindex direct subclass @item @b{direct subclass} @i{n.} (of a @i{class} C_1) a @i{class} C_2, such that C_1 is a @i{direct superclass} of C_2. @IGindex direct superclass @item @b{direct superclass} @i{n.} (of a @i{class} C_1) a @i{class} C_2 which was explicitly designated as a @i{superclass} of C_1 in the definition of C_1. @IGindex disestablish @item @b{disestablish} @i{v.t.} to withdraw the @i{establishment} of an @i{object}, a @i{binding}, an @i{exit point}, a @i{tag}, a @i{handler}, a @i{restart}, or an @i{environment}. @IGindex disjoint @item @b{disjoint} @i{n.} (of @i{types}) having no @i{elements} in common. @IGindex dispatching macro character @item @b{dispatching macro character} @i{n.} a @i{macro character} that has an associated table that specifies the @i{function} to be called for each @i{character} that is seen following the @i{dispatching macro character}. See the @i{function} @b{make-dispatch-macro-character}. @IGindex displaced array @item @b{displaced array} @i{n.} an @i{array} which has no storage of its own, but which is instead indirected to the storage of another @i{array}, called its @i{target}, at a specified offset, in such a way that any attempt to @i{access} the @i{displaced array} implicitly references the @i{target} @i{array}. @IGindex distinct @item @b{distinct} @i{adj.} not @i{identical}. @IGindex documentation string @item @b{documentation string} @i{n.} (in a defining @i{form}) A @i{literal} @i{string} which because of the context in which it appears (rather than because of some intrinsically observable aspect of the @i{string}) is taken as documentation. In some cases, the @i{documentation string} is saved in such a way that it can later be obtained by supplying either an @i{object}, or by supplying a @i{name} and a ``kind'' to the @i{function} @b{documentation}. ``The body of code in a @b{defmacro} form can be preceded by a documentation string of kind @b{function}.'' @IGindex dot @item @b{dot} @i{n.} the @i{standard character} that is variously called ``full stop,'' ``period,'' or ``dot'' (@t{.}). See @i{Figure~2--5}. @IGindex dotted list @item @b{dotted list} @i{n.} a @i{list} which has a terminating @i{atom} that is not @b{nil}. (An @i{atom} by itself is not a @i{dotted list}, however.) @IGindex dotted pair @item @b{dotted pair} @i{n.} 1. a @i{cons} whose @i{cdr} is a @i{non-list}. 2. any @i{cons}, used to emphasize the use of the @i{cons} as a symmetric data pair. @IGindex double float @item @b{double float} @i{n.} an @i{object} of @i{type} @b{double-float}. @IGindex double-quote @item @b{double-quote} @i{n.} the @i{standard character} that is variously called ``quotation mark'' or ``double quote'' (@t{"}). See @i{Figure~2--5}. @IGindex dynamic binding @item @b{dynamic binding} @i{n.} a @i{binding} in a @i{dynamic environment}. @IGindex dynamic environment @item @b{dynamic environment} @i{n.} that part of an @i{environment} that contains @i{bindings} with @i{dynamic extent}. A @i{dynamic environment} contains, among other things: @i{exit points} established by @b{unwind-protect}, and @i{bindings} of @i{dynamic variables}, @i{exit points} established by @b{catch}, @i{condition handlers}, and @i{restarts}. @IGindex dynamic extent @item @b{dynamic extent} @i{n.} an @i{extent} whose duration is bounded by points of @i{establishment} and @i{disestablishment} within the execution of a particular @i{form}. See @i{indefinite extent}. ``Dynamic variable bindings have dynamic extent.'' @IGindex dynamic scope @item @b{dynamic scope} @i{n.} @i{indefinite scope} along with @i{dynamic extent}. @IGindex dynamic variable @item @b{dynamic variable} @i{n.} a @i{variable} the @i{binding} for which is in the @i{dynamic environment}. See @b{special}. @end table @subheading @b{E} @table @asis @IGindex echo stream @item @b{echo stream} @i{n.} a @i{stream} of @i{type} @b{echo-stream}. @IGindex effective method @item @b{effective method} @i{n.} the combination of @i{applicable methods} that are executed when a @i{generic function} is invoked with a particular sequence of @i{arguments}. @IGindex element @item @b{element} @i{n.} 1. (of a @i{list}) an @i{object} that is the @i{car} of one of the @i{conses} that comprise the @i{list}. 2. (of an @i{array}) an @i{object} that is stored in the @i{array}. 3. (of a @i{sequence}) an @i{object} that is an @i{element} of the @i{list} or @i{array} that is the @i{sequence}. 4. (of a @i{type}) an @i{object} that is a member of the set of @i{objects} designated by the @i{type}. 5. (of an @i{input} @i{stream}) a @i{character} or @i{number} (as appropriate to the @i{element type} of the @i{stream}) that is among the ordered series of @i{objects} that can be read from the @i{stream} (using @b{read-char} or @b{read-byte}, as appropriate to the @i{stream}). 6. (of an @i{output} @i{stream}) a @i{character} or @i{number} (as appropriate to the @i{element type} of the @i{stream}) that is among the ordered series of @i{objects} that has been or will be written to the @i{stream} (using @b{write-char} or @b{write-byte}, as appropriate to the @i{stream}). 7. (of a @i{class}) a @i{generalized instance} of the @i{class}. @IGindex element type @item @b{element type} @i{n.} 1. (of an @i{array}) the @i{array element type} of the @i{array}. 2. (of a @i{stream}) the @i{stream element type} of the @i{stream}. @IGindex em @item @b{em} @i{n.} @i{Trad.} a context-dependent unit of measure commonly used in typesetting, equal to the displayed width of of a letter ``M'' in the current font. (The letter ``M'' is traditionally chosen because it is typically represented by the widest @i{glyph} in the font, and other characters' widths are typically fractions of an @i{em}. In implementations providing non-Roman characters with wider characters than ``M,'' it is permissible for another character to be the @i{implementation-defined} reference character for this measure, and for ``M'' to be only a fraction of an @i{em} wide.) In a fixed width font, a line with @i{n} characters is @i{n} @i{ems} wide; in a variable width font, @i{n} @i{ems} is the expected upper bound on the width of such a line. @IGindex empty list @item @b{empty list} @i{n.} the @i{list} containing no @i{elements}. See @i{()}. @IGindex empty type @item @b{empty type} @i{n.} the @i{type} that contains no @i{elements}, and that is a @i{subtype} of all @i{types} (including itself). See @i{nil}. @IGindex end of file @item @b{end of file} @i{n.} 1. the point in an @i{input} @i{stream} beyond which there is no further data. Whether or not there is such a point on an @i{interactive stream} is @i{implementation-defined}. 2. a @i{situation} that occurs upon an attempt to obtain data from an @i{input stream} that is at the @i{end of file}_1. @IGindex environment @item @b{environment} @i{n.} 1. a set of @i{bindings}. See @ref{Introduction to Environments}. 2. an @i{environment object}. ``@b{macroexpand} takes an optional environment argument.'' @IGindex environment object @item @b{environment object} @i{n.} an @i{object} representing a set of @i{lexical bindings}, used in the processing of a @i{form} to provide meanings for @i{names} within that @i{form}. ``@b{macroexpand} takes an optional environment argument.'' (The @i{object} @b{nil} when used as an @i{environment object} denotes the @i{null lexical environment}; the @i{values} of @i{environment parameters} to @i{macro functions} are @i{objects} of @i{implementation-dependent} nature which represent the @i{environment}_1 in which the corresponding @i{macro form} is to be expanded.) See @ref{Environment Objects}. @IGindex environment parameter @item @b{environment parameter} @i{n.} A @i{parameter} in a @i{defining form} f for which there is no corresponding @i{argument}; instead, this @i{parameter} receives as its value an @i{environment} @i{object} which corresponds to the @i{lexical environment} in which the @i{defining form} f appeared. @IGindex error @item @b{error} @i{n.} 1. (only in the phrase ``is an error'') a @i{situation} in which the semantics of a program are not specified, and in which the consequences are undefined. 2. a @i{condition} which represents an @i{error} @i{situation}. See @ref{Error Terminology}. 3. an @i{object} of @i{type} @b{error}. @IGindex error output @item @b{error output} @i{n.} the @i{output} @i{stream} which is the @i{value} of the @i{dynamic variable} @b{*error-output*}. @IGindex escape @item @b{escape} @i{n.}, @i{adj.} 1. @i{n.} a @i{single escape} or a @i{multiple escape}. 2. @i{adj.} @i{single escape} or @i{multiple escape}. @IGindex establish @item @b{establish} @i{v.t.} to build or bring into being a @i{binding}, a @i{declaration}, an @i{exit point}, a @i{tag}, a @i{handler}, a @i{restart}, or an @i{environment}. ``@b{let} establishes lexical bindings.'' @IGindex evaluate @item @b{evaluate} @i{v.t.} (a @i{form} or an @i{implicit progn}) to @i{execute} the @i{code} represented by the @i{form} (or the series of @i{forms} making up the @i{implicit progn}) by applying the rules of @i{evaluation}, returning zero or more values. @IGindex evaluation @item @b{evaluation} @i{n.} a model whereby @i{forms} are @i{executed}, returning zero or more values. Such execution might be implemented directly in one step by an interpreter or in two steps by first @i{compiling} the @i{form} and then @i{executing} the @i{compiled} @i{code}; this choice is dependent both on context and the nature of the @i{implementation}, but in any case is not in general detectable by any program. The evaluation model is designed in such a way that a @i{conforming implementation} might legitimately have only a compiler and no interpreter, or vice versa. See @ref{The Evaluation Model}. @IGindex evaluation environment @item @b{evaluation environment} @i{n.} a @i{run-time environment} in which macro expanders and code specified by @b{eval-when} to be evaluated are evaluated. All evaluations initiated by the @i{compiler} take place in the @i{evaluation environment}. @IGindex execute @item @b{execute} @i{v.t.} @i{Trad.} (@i{code}) to perform the imperative actions represented by the @i{code}. @IGindex execution time @item @b{execution time} @i{n.} the duration of time that @i{compiled code} is being @i{executed}. @IGindex exhaustive partition @item @b{exhaustive partition} @i{n.} (of a @i{type}) a set of @i{pairwise} @i{disjoint} @i{types} that form an @i{exhaustive union}. @IGindex exhaustive union @item @b{exhaustive union} @i{n.} (of a @i{type}) a set of @i{subtypes} of the @i{type}, whose union contains all @i{elements} of that @i{type}. @IGindex exit point @item @b{exit point} @i{n.} a point in a @i{control form} from which (@i{e.g.}, @b{block}), through which (@i{e.g.}, @b{unwind-protect}), or to which (@i{e.g.}, @b{tagbody}) control and possibly @i{values} can be transferred both actively by using another @i{control form} and passively through the normal control and data flow of @i{evaluation}. ``@b{catch} and @b{block} establish bindings for exit points to which @b{throw} and @b{return-from}, respectively, can transfer control and values; @b{tagbody} establishes a binding for an exit point with lexical extent to which @b{go} can transfer control; and @b{unwind-protect} establishes an exit point through which control might be transferred by operators such as @b{throw}, @b{return-from}, and @b{go}.'' @IGindex explicit return @item @b{explicit return} @i{n.} the act of transferring control (and possibly @i{values}) to a @i{block} by using @b{return-from} (or @b{return}). @IGindex explicit use @item @b{explicit use} @i{n.} (of a @i{variable} V in a @i{form} F) a reference to V that is directly apparent in the normal semantics of F; @i{i.e.}, that does not expose any undocumented details of the @i{macro expansion} of the @i{form} itself. References to V exposed by expanding @i{subforms} of F are, however, considered to be @i{explicit uses} of V. @IGindex exponent marker @item @b{exponent marker} @i{n.} a character that is used in the textual notation for a @i{float} to separate the mantissa from the exponent. The characters defined as @i{exponent markers} in the @i{standard readtable} are shown in Figure 26--1. For more information, see @ref{Character Syntax}. ``The exponent marker `d' in `3.0d7' indicates that this number is to be represented as a double float.'' @format @group @noindent @w{ Marker Meaning } @w{ @t{D} or @t{d} @b{double-float} } @w{ @t{E} or @t{e} @b{float} (see @b{*read-default-float-format*}) } @w{ @t{F} or @t{f} @b{single-float} } @w{ @t{L} or @t{l} @b{long-float} } @w{ @t{S} or @t{s} @b{short-float} } @noindent @w{ Figure 26--1: Exponent Markers } @end group @end format @IGindex export @item @b{export} @i{v.t.} (a @i{symbol} in a @i{package}) to add the @i{symbol} to the list of @i{external symbols} of the @i{package}. @IGindex exported @item @b{exported} @i{adj.} (of a @i{symbol} in a @i{package}) being an @i{external symbol} of the @i{package}. @IGindex expressed adjustability @item @b{expressed adjustability} @i{n.} (of an @i{array}) a @i{generalized boolean} that is conceptually (but not necessarily actually) associated with the @i{array}, representing whether the @i{array} is @i{expressly adjustable}. See also @i{actual adjustability}. @IGindex expressed array element type @item @b{expressed array element type} @i{n.} (of an @i{array}) the @i{type} which is the @i{array element type} implied by a @i{type declaration} for the @i{array}, or which is the requested @i{array element type} at its time of creation, prior to any selection of an @i{upgraded array element type}. (@r{Common Lisp} does not provide a way of detecting this @i{type} directly at run time, but an @i{implementation} is permitted to make assumptions about the @i{array}'s contents and the operations which may be performed on the @i{array} when this @i{type} is noted during code analysis, even if those assumptions would not be valid in general for the @i{upgraded array element type} of the @i{expressed array element type}.) @IGindex expressed complex part type @item @b{expressed complex part type} @i{n.} (of a @i{complex}) the @i{type} which is implied as the @i{complex part type} by a @i{type declaration} for the @i{complex}, or which is the requested @i{complex part type} at its time of creation, prior to any selection of an @i{upgraded complex part type}. (@r{Common Lisp} does not provide a way of detecting this @i{type} directly at run time, but an @i{implementation} is permitted to make assumptions about the operations which may be performed on the @i{complex} when this @i{type} is noted during code analysis, even if those assumptions would not be valid in general for the @i{upgraded complex part type} of the @i{expressed complex part type}.) @IGindex expression @item @b{expression} @i{n.} 1. an @i{object}, often used to emphasize the use of the @i{object} to encode or represent information in a specialized format, such as program text. ``The second expression in a @b{let} form is a list of bindings.'' 2. the textual notation used to notate an @i{object} in a source file. ``The expression @t{'sample} is equivalent to @t{(quote sample)}.'' @IGindex expressly adjustable @item @b{expressly adjustable} @i{adj.} (of an @i{array}) being @i{actually adjustable} by virtue of an explicit request for this characteristic having been made at the time of its creation. All @i{arrays} that are @i{expressly adjustable} are @i{actually adjustable}, but not necessarily vice versa. @IGindex extended character @item @b{extended character} @i{n.} a @i{character} of @i{type} @b{extended-char}: a @i{character} that is not a @i{base character}. @IGindex extended function designator @item @b{extended function designator} @i{n.} a @i{designator} for a @i{function}; that is, an @i{object} that denotes a @i{function} and that is one of: a @i{function name} (denoting the @i{function} it names in the @i{global environment}), or a @i{function} (denoting itself). The consequences are undefined if a @i{function name} is used as an @i{extended function designator} but it does not have a global definition as a @i{function}, or if it is a @i{symbol} that has a global definition as a @i{macro} or a @i{special form}. See also @i{function designator}. @IGindex extended lambda list @item @b{extended lambda list} @i{n.} a list resembling an @i{ordinary lambda list} in form and purpose, but offering additional syntax or functionality not available in an @i{ordinary lambda list}. ``@b{defmacro} uses extended lambda lists.'' @IGindex extension @item @b{extension} @i{n.} a facility in an @i{implementation} of @r{Common Lisp} that is not specified by this standard. @IGindex extent @item @b{extent} @i{n.} the interval of time during which a @i{reference} to an @i{object}, a @i{binding}, an @i{exit point}, a @i{tag}, a @i{handler}, a @i{restart}, or an @i{environment} is defined. @IGindex external file format @item @b{external file format} @i{n.} an @i{object} of @i{implementation-dependent} nature which determines one of possibly several @i{implementation-dependent} ways in which @i{characters} are encoded externally in a @i{character} @i{file}. @IGindex external file format designator @item @b{external file format designator} @i{n.} a @i{designator} for an @i{external file format}; that is, an @i{object} that denotes an @i{external file format} and that is one of: the @i{symbol} @t{:default} (denoting an @i{implementation-dependent} default @i{external file format} that can accomodate at least the @i{base characters}), some other @i{object} defined by the @i{implementation} to be an @i{external file format designator} (denoting an @i{implementation-defined} @i{external file format}), or some other @i{object} defined by the @i{implementation} to be an @i{external file format} (denoting itself). @IGindex external symbol @item @b{external symbol} @i{n.} (of a @i{package}) a @i{symbol} that is part of the `external interface' to the @i{package} and that are @i{inherited}_3 by any other @i{package} that @i{uses} the @i{package}. When using the @i{Lisp reader}, if a @i{package prefix} is used, the @i{name} of an @i{external symbol} is separated from the @i{package} @i{name} by a single @i{package marker} while the @i{name} of an @i{internal symbol} is separated from the @i{package} @i{name} by a double @i{package marker}; see @ref{Symbols as Tokens}. @IGindex externalizable object @item @b{externalizable object} @i{n.} an @i{object} that can be used as a @i{literal} @i{object} in @i{code} to be processed by the @i{file compiler}. @end table @subheading @b{F} @table @asis @IGindex false @item @b{false} @i{n.} the @i{symbol} @b{nil}, used to represent the failure of a @i{predicate} test. @IGindex fbound @item @b{fbound} pronounced 'ef ,baund @i{adj.} (of a @i{function name}) @i{bound} in the @i{function} @i{namespace}. (The @i{names} of @i{macros} and @i{special operators} are @i{fbound}, but the nature and @i{type} of the @i{object} which is their @i{value} is @i{implementation-dependent}. Further, defining a @i{setf expander} @i{F} does not cause the @i{setf function} @t{(setf @i{F})} to become defined; as such, if there is a such a definition of a @i{setf expander} @i{F}, the @i{function} @t{(setf @i{F})} can be @i{fbound} if and only if, by design or coincidence, a function binding for @t{(setf @i{F})} has been independently established.) See the @i{functions} @b{fboundp} and @b{symbol-function}. @IGindex feature @item @b{feature} @i{n.} 1. an aspect or attribute of @r{Common Lisp}, of the @i{implementation}, or of the @i{environment}. 2. a @i{symbol} that names a @i{feature}_1. See @ref{Features}. ``The @t{:ansi-cl} feature is present in all conforming implementations.'' @IGindex feature expression @item @b{feature expression} @i{n.} A boolean combination of @i{features} used by the @t{#+} and @t{#-} @i{reader macros} in order to direct conditional @i{reading} of @i{expressions} by the @i{Lisp reader}. See @ref{Feature Expressions}. @IGindex features list @item @b{features list} @i{n.} the @i{list} that is the @i{value} of @b{*features*}. @IGindex file @item @b{file} @i{n.} a named entry in a @i{file system}, having an @i{implementation-defined} nature. @IGindex file compiler @item @b{file compiler} @i{n.} any @i{compiler} which @i{compiles} @i{source code} contained in a @i{file}, producing a @i{compiled file} as output. The @b{compile-file} function is the only interface to such a @i{compiler} provided by @r{Common Lisp}, but there might be other, @i{implementation-defined} mechanisms for invoking the @i{file compiler}. @IGindex file position @item @b{file position} @i{n.} (in a @i{stream}) a non-negative @i{integer} that represents a position in the @i{stream}. Not all @i{streams} are able to represent the notion of @i{file position}; in the description of any @i{operator} which manipulates @i{file positions}, the behavior for @i{streams} that don't have this notion must be explicitly stated. For @i{binary} @i{streams}, the @i{file position} represents the number of preceding @i{bytes} in the @i{stream}. For @i{character} @i{streams}, the constraint is more relaxed: @i{file positions} must increase monotonically, the amount of the increase between @i{file positions} corresponding to any two successive characters in the @i{stream} is @i{implementation-dependent}. @IGindex file position designator @item @b{file position designator} @i{n.} (in a @i{stream}) a @i{designator} for a @i{file position} in that @i{stream}; that is, the symbol @t{:start} (denoting @t{0}, the first @i{file position} in that @i{stream}), the symbol @t{:end} (denoting the last @i{file position} in that @i{stream}; @i{i.e.}, the position following the last @i{element} of the @i{stream}), or a @i{file position} (denoting itself). @IGindex file stream @item @b{file stream} @i{n.} an @i{object} of @i{type} @b{file-stream}. @IGindex file system @item @b{file system} @i{n.} a facility which permits aggregations of data to be stored in named @i{files} on some medium that is external to the @i{Lisp image} and that therefore persists from @i{session} to @i{session}. @IGindex filename @item @b{filename} @i{n.} a handle, not necessarily ever directly represented as an @i{object}, that can be used to refer to a @i{file} in a @i{file system}. @i{Pathnames} and @i{namestrings} are two kinds of @i{objects} that substitute for @i{filenames} in @r{Common Lisp}. @IGindex fill pointer @item @b{fill pointer} @i{n.} (of a @i{vector}) an @i{integer} associated with a @i{vector} that represents the index above which no @i{elements} are @i{active}. (A @i{fill pointer} is a non-negative @i{integer} no larger than the total number of @i{elements} in the @i{vector}. Not all @i{vectors} have @i{fill pointers}.) @IGindex finite @item @b{finite} @i{adj.} (of a @i{type}) having a finite number of @i{elements}. ``The type specifier @t{(integer 0 5)} denotes a finite type, but the type specifiers @b{integer} and @t{(integer 0)} do not.'' @IGindex fixnum @item @b{fixnum} @i{n.} an @i{integer} of @i{type} @b{fixnum}. @IGindex float @item @b{float} @i{n.} an @i{object} of @i{type} @b{float}. @IGindex for-value @item @b{for-value} @i{adj.} (of a @i{reference} to a @i{binding}) being a @i{reference} that @i{reads}_1 the @i{value} of the @i{binding}. @IGindex form @item @b{form} @i{n.} 1. any @i{object} meant to be @i{evaluated}. 2. a @i{symbol}, a @i{compound form}, or a @i{self-evaluating object}. 3. (for an @i{operator}, as in ``<<@i{operator}>> @i{form}'') a @i{compound form} having that @i{operator} as its first element. ``A @b{quote} form is a constant form.'' @IGindex formal argument @item @b{formal argument} @i{n.} @i{Trad.} a @i{parameter}. @IGindex formal parameter @item @b{formal parameter} @i{n.} @i{Trad.} a @i{parameter}. @IGindex format @item @b{format} @i{v.t.} (a @i{format control} and @i{format arguments}) to perform output as if by @b{format}, using the @i{format string} and @i{format arguments}. @IGindex format argument @item @b{format argument} @i{n.} an @i{object} which is used as data by functions such as @b{format} which interpret @i{format controls}. @IGindex format control @item @b{format control} @i{n.} a @i{format string}, or a @i{function} that obeys the @i{argument} conventions for a @i{function} returned by the @b{formatter} @i{macro}. See @ref{Compiling Format Strings}. @IGindex format directive @item @b{format directive} @i{n.} 1. a sequence of @i{characters} in a @i{format string} which is introduced by a @i{tilde}, and which is specially interpreted by @i{code} which processes @i{format strings} to mean that some special operation should be performed, possibly involving data supplied by the @i{format arguments} that accompanied the @i{format string}. See the @i{function} @b{format}. ``In @t{"~D base 10 = ~8R"}, the character sequences `@t{~D}' and `@t{~8R}' are format directives.'' 2. the conceptual category of all @i{format directives}_1 which use the same dispatch character. ``Both @t{"~3d"} and @t{"~3,'0D"} are valid uses of the `@t{~D}' format directive.'' @IGindex format string @item @b{format string} @i{n.} a @i{string} which can contain both ordinary text and @i{format directives}, and which is used in conjunction with @i{format arguments} to describe how text output should be formatted by certain functions, such as @b{format}. @IGindex free declaration @item @b{free declaration} @i{n.} a declaration that is not a @i{bound declaration}. See @b{declare}. @IGindex fresh @item @b{fresh} @i{adj.} 1. (of an @i{object} @i{yielded} by a @i{function}) having been newly-allocated by that @i{function}. (The caller of a @i{function} that returns a @i{fresh} @i{object} may freely modify the @i{object} without fear that such modification will compromise the future correct behavior of that @i{function}.) 2. (of a @i{binding} for a @i{name}) newly-allocated; not shared with other @i{bindings} for that @i{name}. @IGindex freshline @item @b{freshline} @i{n.} a conceptual operation on a @i{stream}, implemented by the @i{function} @b{fresh-line} and by the @i{format directive} @t{~&}, which advances the display position to the beginning of the next line (as if a @i{newline} had been typed, or the @i{function} @b{terpri} had been called) unless the @i{stream} is already known to be positioned at the beginning of a line. Unlike @i{newline}, @i{freshline} is not a @i{character}. @IGindex funbound @item @b{funbound} pronounced 'ef unbaund @i{n.} (of a @i{function name}) not @i{fbound}. @IGindex function @item @b{function} @i{n.} 1. an @i{object} representing code, which can be @i{called} with zero or more @i{arguments}, and which produces zero or more @i{values}. 2. an @i{object} of @i{type} @b{function}. @IGindex function block name @item @b{function block name} @i{n.} (of a @i{function name}) The @i{symbol} that would be used as the name of an @i{implicit block} which surrounds the body of a @i{function} having that @i{function name}. If the @i{function name} is a @i{symbol}, its @i{function block name} is the @i{function name} itself. If the @i{function name} is a @i{list} whose @i{car} is @b{setf} and whose @i{cadr} is a @i{symbol}, its @i{function block name} is the @i{symbol} that is the @i{cadr} of the @i{function name}. An @i{implementation} which supports additional kinds of @i{function names} must specify for each how the corresponding @i{function block name} is computed. @IGindex function cell @item @b{function cell} @i{n.} @i{Trad.} (of a @i{symbol}) The @i{place} which holds the @i{definition} of the global @i{function} @i{binding}, if any, named by that @i{symbol}, and which is @i{accessed} by @b{symbol-function}. See @i{cell}. @IGindex function designator @item @b{function designator} @i{n.} a @i{designator} for a @i{function}; that is, an @i{object} that denotes a @i{function} and that is one of: a @i{symbol} (denoting the @i{function} named by that @i{symbol} in the @i{global environment}), or a @i{function} (denoting itself). The consequences are undefined if a @i{symbol} is used as a @i{function designator} but it does not have a global definition as a @i{function}, or it has a global definition as a @i{macro} or a @i{special form}. See also @i{extended function designator}. @IGindex function form @item @b{function form} @i{n.} a @i{form} that is a @i{list} and that has a first element which is the @i{name} of a @i{function} to be called on @i{arguments} which are the result of @i{evaluating} subsequent elements of the @i{function form}. @IGindex function name @item @b{function name} @i{n.} (in an @i{environment}) A @i{symbol} or a @i{list} @t{(setf @i{symbol})} that is the @i{name} of a @i{function} in that @i{environment}. @IGindex functional evaluation @item @b{functional evaluation} @i{n.} the process of extracting a @i{functional value} from a @i{function name} or a @i{lambda expression}. The evaluator performs @i{functional evaluation} implicitly when it encounters a @i{function name} or a @i{lambda expression} in the @i{car} of a @i{compound form}, or explicitly when it encounters a @b{function} @i{special form}. Neither a use of a @i{symbol} as a @i{function designator} nor a use of the @i{function} @b{symbol-function} to extract the @i{functional value} of a @i{symbol} is considered a @i{functional evaluation}. @IGindex functional value @item @b{functional value} @i{n.} 1. (of a @i{function name} N in an @i{environment} E) The @i{value} of the @i{binding} named N in the @i{function} @i{namespace} for @i{environment} E; that is, the contents of the @i{function cell} named N in @i{environment} E. 2. (of an @i{fbound} @i{symbol} S) the contents of the @i{symbol}'s @i{function cell}; that is, the @i{value} of the @i{binding} named S in the @i{function} @i{namespace} of the @i{global environment}. (A @i{name} that is a @i{macro name} in the @i{global environment} or is a @i{special operator} might or might not be @i{fbound}. But if S is such a @i{name} and is @i{fbound}, the specific nature of its @i{functional value} is @i{implementation-dependent}; in particular, it might or might not be a @i{function}.) @IGindex further compilation @item @b{further compilation} @i{n.} @i{implementation-dependent} compilation beyond @i{minimal compilation}. Further compilation is permitted to take place at @i{run time}. ``Block compilation and generation of machine-specific instructions are examples of further compilation.'' @end table @subheading @b{G} @table @asis @IGindex general @item @b{general} @i{adj.} (of an @i{array}) having @i{element type} @b{t}, and consequently able to have any @i{object} as an @i{element}. @IGindex generalized boolean @item @b{generalized boolean} @i{n.} an @i{object} used as a truth value, where the symbol~@b{nil} represents @i{false} and all other @i{objects} represent @i{true}. See @i{boolean}. @IGindex generalized instance @item @b{generalized instance} @i{n.} (of a @i{class}) an @i{object} the @i{class} of which is either that @i{class} itself, or some subclass of that @i{class}. (Because of the correspondence between types and classes, the term ``generalized instance of X'' implies ``object of type X'' and in cases where X is a @i{class} (or @i{class name}) the reverse is also true. The former terminology emphasizes the view of X as a @i{class} while the latter emphasizes the view of X as a @i{type specifier}.) @IGindex generalized reference @item @b{generalized reference} @i{n.} a reference to a location storing an @i{object} as if to a @i{variable}. (Such a reference can be either to @i{read} or @i{write} the location.) See @ref{Generalized Reference}. See also @i{place}. @IGindex generalized synonym stream @item @b{generalized synonym stream} @i{n.} (with a @i{synonym stream symbol}) 1. (to a @i{stream}) a @i{synonym stream} to the @i{stream}, or a @i{composite stream} which has as a target a @i{generalized synonym stream} to the @i{stream}. 2. (to a @i{symbol}) a @i{synonym stream} to the @i{symbol}, or a @i{composite stream} which has as a target a @i{generalized synonym stream} to the @i{symbol}. @IGindex generic function @item @b{generic function} @i{n.} a @i{function} whose behavior depends on the @i{classes} or identities of the arguments supplied to it and whose parts include, among other things, a set of @i{methods}, a @i{lambda list}, and a @i{method combination} type. @IGindex generic function lambda list @item @b{generic function lambda list} @i{n.} A @i{lambda list} that is used to describe data flow into a @i{generic function}. See @ref{Generic Function Lambda Lists}. @IGindex gensym @item @b{gensym} @i{n.} @i{Trad.} an @i{uninterned} @i{symbol}. See the @i{function} @b{gensym}. @IGindex global declaration @item @b{global declaration} @i{n.} a @i{form} that makes certain kinds of information about code globally available; that is, a @b{proclaim} @i{form} or a @b{declaim} @i{form}. @IGindex global environment @item @b{global environment} @i{n.} that part of an @i{environment} that contains @i{bindings} with @i{indefinite scope} and @i{indefinite extent}. @IGindex global variable @item @b{global variable} @i{n.} a @i{dynamic variable} or a @i{constant variable}. @IGindex glyph @item @b{glyph} @i{n.} a visual representation. ``Graphic characters have associated glyphs.'' @IGindex go @item @b{go} @i{v.} to transfer control to a @i{go point}. See the @i{special operator} @b{go}. @IGindex go point @item @b{go point} one of possibly several @i{exit points} that are @i{established} by @b{tagbody} (or other abstractions, such as @b{prog}, which are built from @b{tagbody}). @IGindex go tag @item @b{go tag} @i{n.} the @i{symbol} or @i{integer} that, within the @i{lexical scope} of a @b{tagbody} @i{form}, names an @i{exit point} @i{established} by that @b{tagbody} @i{form}. @IGindex graphic @item @b{graphic} @i{adj.} (of a @i{character}) being a ``printing'' or ``displayable'' @i{character} that has a standard visual representation as a single @i{glyph}, such as @t{A} or @t{*} or @t{=}. @i{Space} is defined to be @i{graphic}. Of the @i{standard characters}, all but @i{newline} are @i{graphic}. See @i{non-graphic}. @end table @subheading @b{H} @table @asis @IGindex handle @item @b{handle} @i{v.} (of a @i{condition} being @i{signaled}) to perform a non-local transfer of control, terminating the ongoing @i{signaling} of the @i{condition}. @IGindex handler @item @b{handler} @i{n.} a @i{condition handler}. @IGindex hash table @item @b{hash table} @i{n.} an @i{object} of @i{type} @b{hash-table}, which provides a mapping from @i{keys} to @i{values}. @IGindex home package @item @b{home package} @i{n.} (of a @i{symbol}) the @i{package}, if any, which is contents of the @i{package cell} of the @i{symbol}, and which dictates how the @i{Lisp printer} prints the @i{symbol} when it is not @i{accessible} in the @i{current package}. (@i{Symbols} which have @b{nil} in their @i{package cell} are said to have no @i{home package}, and also to be @i{apparently uninterned}.) @end table @subheading @b{I} @table @asis @IGindex I/O customization variable @item @b{I/O customization variable} @i{n.} one of the @i{stream variables} in Figure 26--2, or some other (@i{implementation-defined}) @i{stream variable} that is defined by the @i{implementation} to be an @i{I/O customization variable}. @format @group @noindent @w{ *debug-io* *error-io* query-io* } @w{ *standard-input* *standard-output* *trace-output* } @noindent @w{ Figure 26--2: Standardized I/O Customization Variables} @end group @end format @IGindex identical @item @b{identical} @i{adj.} the @i{same} under @b{eq}. @IGindex identifier @item @b{identifier} @i{n.} 1. a @i{symbol} used to identify or to distinguish @i{names}. 2. a @i{string} used the same way. @IGindex immutable @item @b{immutable} @i{adj.} not subject to change, either because no @i{operator} is provided which is capable of effecting such change or because some constraint exists which prohibits the use of an @i{operator} that might otherwise be capable of effecting such a change. Except as explicitly indicated otherwise, @i{implementations} are not required to detect attempts to modify @i{immutable} @i{objects} or @i{cells}; the consequences of attempting to make such modification are undefined. ``Numbers are immutable.'' @IGindex implementation @item @b{implementation} @i{n.} a system, mechanism, or body of @i{code} that implements the semantics of @r{Common Lisp}. @IGindex implementation limit @item @b{implementation limit} @i{n.} a restriction imposed by an @i{implementation}. @IGindex implementation-defined @item @b{implementation-defined} @i{adj.} @i{implementation-dependent}, but required by this specification to be defined by each @i{conforming implementation} and to be documented by the corresponding implementor. @IGindex implementation-dependent @item @b{implementation-dependent} @i{adj.} describing a behavior or aspect of @r{Common Lisp} which has been deliberately left unspecified, that might be defined in some @i{conforming implementations} but not in others, and whose details may differ between @i{implementations}. A @i{conforming implementation} is encouraged (but not required) to document its treatment of each item in this specification which is marked @i{implementation-dependent}, although in some cases such documentation might simply identify the item as ``undefined.'' @IGindex implementation-independent @item @b{implementation-independent} @i{adj.} used to identify or emphasize a behavior or aspect of @r{Common Lisp} which does not vary between @i{conforming implementations}. @IGindex implicit block @item @b{implicit block} @i{n.} a @i{block} introduced by a @i{macro form} rather than by an explicit @b{block} @i{form}. @IGindex implicit compilation @item @b{implicit compilation} @i{n.} @i{compilation} performed during @i{evaluation}. @IGindex implicit progn @item @b{implicit progn} @i{n.} an ordered set of adjacent @i{forms} appearing in another @i{form}, and defined by their context in that @i{form} to be executed as if within a @b{progn}. @IGindex implicit tagbody @item @b{implicit tagbody} @i{n.} an ordered set of adjacent @i{forms} and/or @i{tags} appearing in another @i{form}, and defined by their context in that @i{form} to be executed as if within a @b{tagbody}. @IGindex import @item @b{import} @i{v.t.} (a @i{symbol} into a @i{package}) to make the @i{symbol} be @i{present} in the @i{package}. @IGindex improper list @item @b{improper list} @i{n.} a @i{list} which is not a @i{proper list}: a @i{circular list} or a @i{dotted list}. @IGindex inaccessible @item @b{inaccessible} @i{adj.} not @i{accessible}. @IGindex indefinite extent @item @b{indefinite extent} @i{n.} an @i{extent} whose duration is unlimited. ``Most Common Lisp objects have indefinite extent.'' @IGindex indefinite scope @item @b{indefinite scope} @i{n.} @i{scope} that is unlimited. @IGindex indicator @item @b{indicator} @i{n.} a @i{property indicator}. @IGindex indirect instance @item @b{indirect instance} @i{n.} (of a @i{class} C_1) an @i{object} of @i{class} C_2, where C_2 is a @i{subclass} of C_1. ``An integer is an indirect instance of the class @b{number}.'' @IGindex inherit @item @b{inherit} @i{v.t.} 1. to receive or acquire a quality, trait, or characteristic; to gain access to a feature defined elsewhere. 2. (a @i{class}) to acquire the structure and behavior defined by a @i{superclass}. 3. (a @i{package}) to make @i{symbols} @i{exported} by another @i{package} @i{accessible} by using @b{use-package}. @IGindex initial pprint dispatch table @item @b{initial pprint dispatch table} @i{n.} the @i{value} of @b{*print-pprint-dispatch*} at the time the @i{Lisp image} is started. @IGindex initial readtable @item @b{initial readtable} @i{n.} the @i{value} of @b{*readtable*} at the time the @i{Lisp image} is started. @IGindex initialization argument list @item @b{initialization argument list} @i{n.} a @i{property list} of initialization argument @i{names} and @i{values} used in the protocol for initializing and reinitializing @i{instances} of @i{classes}. See @ref{Object Creation and Initialization}. @IGindex initialization form @item @b{initialization form} @i{n.} a @i{form} used to supply the initial @i{value} for a @i{slot} or @i{variable}. ``The initialization form for a slot in a @b{defclass} form is introduced by the keyword @t{:initform}.'' @IGindex input @item @b{input} @i{adj.} (of a @i{stream}) supporting input operations (@i{i.e.}, being a ``data source''). An @i{input} @i{stream} might also be an @i{output} @i{stream}, in which case it is sometimes called a @i{bidirectional} @i{stream}. See the @i{function} @b{input-stream-p}. @IGindex instance @item @b{instance} @i{n.} 1. a @i{direct instance}. 2. a @i{generalized instance}. 3. an @i{indirect instance}. @IGindex integer @item @b{integer} @i{n.} an @i{object} of @i{type} @b{integer}, which represents a mathematical integer. @IGindex interactive stream @item @b{interactive stream} @i{n.} a @i{stream} on which it makes sense to perform interactive querying. See @ref{Interactive Streams}. @IGindex intern @item @b{intern} @i{v.t.} 1. (a @i{string} in a @i{package}) to look up the @i{string} in the @i{package}, returning either a @i{symbol} with that @i{name} which was already @i{accessible} in the @i{package} or a newly created @i{internal symbol} of the @i{package} with that @i{name}. 2. @i{Idiom.} generally, to observe a protocol whereby objects which are equivalent or have equivalent names under some predicate defined by the protocol are mapped to a single canonical object. @IGindex internal symbol @item @b{internal symbol} @i{n.} (of a @i{package}) a symbol which is @i{accessible} in the @i{package}, but which is not an @i{external symbol} of the @i{package}. @IGindex internal time @item @b{internal time} @i{n.} @i{time}, represented as an @i{integer} number of @i{internal time units}. @i{Absolute} @i{internal time} is measured as an offset from an arbitrarily chosen, @i{implementation-dependent} base. See @ref{Internal Time}. @IGindex internal time unit @item @b{internal time unit} @i{n.} a unit of time equal to 1/n of a second, for some @i{implementation-defined} @i{integer} value of n. See the @i{variable} @b{internal-time-units-per-second}. @IGindex interned @item @b{interned} @i{adj.} @i{Trad.} 1. (of a @i{symbol}) @i{accessible}_3 in any @i{package}. 2. (of a @i{symbol} in a specific @i{package}) @i{present} in that @i{package}. @IGindex interpreted function @item @b{interpreted function} @i{n.} a @i{function} that is not a @i{compiled function}. (It is possible for there to be a @i{conforming implementation} which has no @i{interpreted functions}, but a @i{conforming program} must not assume that all @i{functions} are @i{compiled functions}.) @IGindex interpreted implementation @item @b{interpreted implementation} @i{n.} an @i{implementation} that uses an execution strategy for @i{interpreted functions} that does not involve a one-time semantic analysis pre-pass, and instead uses ``lazy'' (and sometimes repetitious) semantic analysis of @i{forms} as they are encountered during execution. @IGindex interval designator @item @b{interval designator} @i{n.} (of @i{type} T) an ordered pair of @i{objects} that describe a @i{subtype} of T by delimiting an interval on the real number line. See @ref{Interval Designators}. @IGindex invalid @item @b{invalid} @i{n.}, @i{adj.} 1. @i{n.} a possible @i{constituent trait} of a @i{character} which if present signifies that the @i{character} cannot ever appear in a @i{token} except under the control of a @i{single escape} @i{character}. For details, see @ref{Constituent Characters}. 2. @i{adj.} (of a @i{character}) being a @i{character} that has @i{syntax type} @i{constituent} in the @i{current readtable} and that has the @i{constituent trait} @i{invalid}_1. See @i{Figure~2--8}. @IGindex iteration form @item @b{iteration form} @i{n.} a @i{compound form} whose @i{operator} is named in Figure 26--3, or a @i{compound form} that has an @i{implementation-defined} @i{operator} and that is defined by the @i{implementation} to be an @i{iteration form}. @format @group @noindent @w{ do do-external-symbols dotimes } @w{ do* do-symbols loop } @w{ do-all-symbols dolist } @noindent @w{ Figure 26--3: Standardized Iteration Forms } @end group @end format @IGindex iteration variable @item @b{iteration variable} @i{n.} a @i{variable} V, the @i{binding} for which was created by an @i{explicit use} of V in an @i{iteration form}. @end table @subheading @b{K} @table @asis @IGindex key @item @b{key} @i{n.} an @i{object} used for selection during retrieval. See @i{association list}, @i{property list}, and @i{hash table}. Also, see @ref{Sequence Concepts}. @IGindex keyword @item @b{keyword} @i{n.} 1. a @i{symbol} the @i{home package} of which is the @t{KEYWORD} @i{package}. 2. any @i{symbol}, usually but not necessarily in the @t{KEYWORD} @i{package}, that is used as an identifying marker in keyword-style argument passing. See @b{lambda}. 3. @i{Idiom.} a @i{lambda list keyword}. @IGindex keyword parameter @item @b{keyword parameter} @i{n.} A @i{parameter} for which a corresponding keyword @i{argument} is optional. (There is no such thing as a required keyword @i{argument}.) If the @i{argument} is not supplied, a default value is used. See also @i{supplied-p parameter}. @IGindex keyword/value pair @item @b{keyword/value pair} @i{n.} two successive @i{elements} (a @i{keyword} and a @i{value}, respectively) of a @i{property list}. @end table @subheading @b{L} @table @asis @IGindex lambda combination @item @b{lambda combination} @i{n.} @i{Trad.} a @i{lambda form}. @IGindex lambda expression @item @b{lambda expression} @i{n.} a @i{list} which can be used in place of a @i{function name} in certain contexts to denote a @i{function} by directly describing its behavior rather than indirectly by referring to the name of an @i{established} @i{function}; its name derives from the fact that its first element is the @i{symbol} @t{lambda}. See @b{lambda}. @IGindex lambda form @item @b{lambda form} @i{n.} a @i{form} that is a @i{list} and that has a first element which is a @i{lambda expression} representing a @i{function} to be called on @i{arguments} which are the result of @i{evaluating} subsequent elements of the @i{lambda form}. @IGindex lambda list @item @b{lambda list} @i{n.} a @i{list} that specifies a set of @i{parameters} (sometimes called @i{lambda variables}) and a protocol for receiving @i{values} for those @i{parameters}; that is, an @i{ordinary lambda list}, an @i{extended lambda list}, or a @i{modified lambda list}. @IGindex lambda list keyword @item @b{lambda list keyword} @i{n.} a @i{symbol} whose @i{name} begins with @i{ampersand} and that is specially recognized in a @i{lambda list}. Note that no @i{standardized} @i{lambda list keyword} is in the @t{KEYWORD} @i{package}. @IGindex lambda variable @item @b{lambda variable} @i{n.} a @i{formal parameter}, used to emphasize the @i{variable}'s relation to the @i{lambda list} that @i{established} it. @IGindex leaf @item @b{leaf} @i{n.} 1. an @i{atom} in a @i{tree}_1. 2. a terminal node of a @i{tree}_2. @IGindex leap seconds @item @b{leap seconds} @i{n.} additional one-second intervals of time that are occasionally inserted into the true calendar by official timekeepers as a correction similar to ``leap years.'' All @r{Common Lisp} @i{time} representations ignore @i{leap seconds}; every day is assumed to be exactly 86400 seconds long. @IGindex left-parenthesis @item @b{left-parenthesis} @i{n.} the @i{standard character} ``@t{(}'', that is variously called ``left parenthesis'' or ``open parenthesis'' See @i{Figure~2--5}. @IGindex length @item @b{length} @i{n.} (of a @i{sequence}) the number of @i{elements} in the @i{sequence}. (Note that if the @i{sequence} is a @i{vector} with a @i{fill pointer}, its @i{length} is the same as the @i{fill pointer} even though the total allocated size of the @i{vector} might be larger.) @IGindex lexical binding @item @b{lexical binding} @i{n.} a @i{binding} in a @i{lexical environment}. @IGindex lexical closure @item @b{lexical closure} @i{n.} a @i{function} that, when invoked on @i{arguments}, executes the body of a @i{lambda expression} in the @i{lexical environment} that was captured at the time of the creation of the @i{lexical closure}, augmented by @i{bindings} of the @i{function}'s @i{parameters} to the corresponding @i{arguments}. @IGindex lexical environment @item @b{lexical environment} @i{n.} that part of the @i{environment} that contains @i{bindings} whose names have @i{lexical scope}. A @i{lexical environment} contains, among other things: ordinary @i{bindings} of @i{variable} @i{names} to @i{values}, lexically @i{established} @i{bindings} of @i{function names} to @i{functions}, @i{macros}, @i{symbol macros}, @i{blocks}, @i{tags}, and @i{local declarations} (see @b{declare}). @IGindex lexical scope @item @b{lexical scope} @i{n.} @i{scope} that is limited to a spatial or textual region within the establishing @i{form}. ``The names of parameters to a function normally are lexically scoped.'' @IGindex lexical variable @item @b{lexical variable} @i{n.} a @i{variable} the @i{binding} for which is in the @i{lexical environment}. @IGindex Lisp image @item @b{Lisp image} @i{n.} a running instantiation of a @r{Common Lisp} @i{implementation}. A @i{Lisp image} is characterized by a single address space in which any @i{object} can directly refer to any another in conformance with this specification, and by a single, common, @i{global environment}. (External operating systems sometimes call this a ``core image,'' ``fork,'' ``incarnation,'' ``job,'' or ``process.'' Note however, that the issue of a ``process'' in such an operating system is technically orthogonal to the issue of a @i{Lisp image} being defined here. Depending on the operating system, a single ``process'' might have multiple @i{Lisp images}, and multiple ``processes'' might reside in a single @i{Lisp image}. Hence, it is the idea of a fully shared address space for direct reference among all @i{objects} which is the defining characteristic. Note, too, that two ``processes'' which have a communication area that permits the sharing of some but not all @i{objects} are considered to be distinct @i{Lisp images}.) @IGindex Lisp printer @item @b{Lisp printer} @i{n.} @i{Trad.} the procedure that prints the character representation of an @i{object} onto a @i{stream}. (This procedure is implemented by the @i{function} @b{write}.) @IGindex Lisp read-eval-print loop @item @b{Lisp read-eval-print loop} @i{n.} @i{Trad.} an endless loop that @i{reads}_2 a @i{form}, @i{evaluates} it, and prints (@i{i.e.}, @i{writes}_2) the results. In many @i{implementations}, the default mode of interaction with @r{Common Lisp} during program development is through such a loop. @IGindex Lisp reader @item @b{Lisp reader} @i{n.} @i{Trad.} the procedure that parses character representations of @i{objects} from a @i{stream}, producing @i{objects}. (This procedure is implemented by the @i{function} @b{read}.) @IGindex list @item @b{list} @i{n.} 1. a chain of @i{conses} in which the @i{car} of each @i{cons} is an @i{element} of the @i{list}, and the @i{cdr} of each @i{cons} is either the next link in the chain or a terminating @i{atom}. See also @i{proper list}, @i{dotted list}, or @i{circular list}. 2. the @i{type} that is the union of @b{null} and @b{cons}. @IGindex list designator @item @b{list designator} @i{n.} a @i{designator} for a @i{list} of @i{objects}; that is, an @i{object} that denotes a @i{list} and that is one of: a @i{non-nil} @i{atom} (denoting a @i{singleton} @i{list} whose @i{element} is that @i{non-nil} @i{atom}) or a @i{proper list} (denoting itself). @IGindex list structure @item @b{list structure} @i{n.} (of a @i{list}) the set of @i{conses} that make up the @i{list}. Note that while the @i{car}_@{1b@} component of each such @i{cons} is part of the @i{list structure}, the @i{objects} that are @i{elements} of the @i{list} (@i{i.e.}, the @i{objects} that are the @i{cars}_2 of each @i{cons} in the @i{list}) are not themselves part of its @i{list structure}, even if they are @i{conses}, except in the (@i{circular}_2) case where the @i{list} actually contains one of its @i{tails} as an @i{element}. (The @i{list structure} of a @i{list} is sometimes redundantly referred to as its ``top-level list structure'' in order to emphasize that any @i{conses} that are @i{elements} of the @i{list} are not involved.) @IGindex literal @item @b{literal} @i{adj.} (of an @i{object}) referenced directly in a program rather than being computed by the program; that is, appearing as data in a @b{quote} @i{form}, or, if the @i{object} is a @i{self-evaluating object}, appearing as unquoted data. ``In the form @t{(cons "one" '("two"))}, the expressions @t{"one"}, @t{("two")}, and @t{"two"} are literal objects.'' @IGindex load @item @b{load} @i{v.t.} (a @i{file}) to cause the @i{code} contained in the @i{file} to be @i{executed}. See the @i{function} @b{load}. @IGindex load time @item @b{load time} @i{n.} the duration of time that the loader is @i{loading} @i{compiled code}. @IGindex load time value @item @b{load time value} @i{n.} an @i{object} referred to in @i{code} by a @b{load-time-value} @i{form}. The @i{value} of such a @i{form} is some specific @i{object} which can only be computed in the run-time @i{environment}. In the case of @i{file} @i{compilation}, the @i{value} is computed once as part of the process of @i{loading} the @i{compiled file}, and not again. See the @i{special operator} @b{load-time-value}. @IGindex loader @item @b{loader} @i{n.} a facility that is part of Lisp and that @i{loads} a @i{file}. See the @i{function} @b{load}. @IGindex local declaration @item @b{local declaration} @i{n.} an @i{expression} which may appear only in specially designated positions of certain @i{forms}, and which provides information about the code contained within the containing @i{form}; that is, a @b{declare} @i{expression}. @IGindex local precedence order @item @b{local precedence order} @i{n.} (of a @i{class}) a @i{list} consisting of the @i{class} followed by its @i{direct superclasses} in the order mentioned in the defining @i{form} for the @i{class}. @IGindex local slot @item @b{local slot} @i{n.} (of a @i{class}) a @i{slot} @i{accessible} in only one @i{instance}, namely the @i{instance} in which the @i{slot} is allocated. @IGindex logical block @item @b{logical block} @i{n.} a conceptual grouping of related output used by the @i{pretty printer}. See the @i{macro} @b{pprint-logical-block} and @ref{Dynamic Control of the Arrangement of Output}. @IGindex logical host @item @b{logical host} @i{n.} an @i{object} of @i{implementation-dependent} nature that is used as the representation of a ``host'' in a @i{logical pathname}, and that has an associated set of translation rules for converting @i{logical pathnames} belonging to that host into @i{physical pathnames}. See @ref{Logical Pathnames}. @IGindex logical host designator @item @b{logical host designator} @i{n.} a @i{designator} for a @i{logical host}; that is, an @i{object} that denotes a @i{logical host} and that is one of: a @i{string} (denoting the @i{logical host} that it names), or a @i{logical host} (denoting itself). (Note that because the representation of a @i{logical host} is @i{implementation-dependent}, it is possible that an @i{implementation} might represent a @i{logical host} as the @i{string} that names it.) @IGindex logical pathname @item @b{logical pathname} @i{n.} an @i{object} of @i{type} @b{logical-pathname}. @IGindex long float @item @b{long float} @i{n.} an @i{object} of @i{type} @b{long-float}. @IGindex loop keyword @item @b{loop keyword} @i{n.} @i{Trad.} a symbol that is a specially recognized part of the syntax of an extended @b{loop} @i{form}. Such symbols are recognized by their @i{name} (using @b{string=}), not by their identity; as such, they may be in any package. A @i{loop keyword} is not a @i{keyword}. @IGindex lowercase @item @b{lowercase} @i{adj.} (of a @i{character}) being among @i{standard characters} corresponding to the small letters @t{a} through @t{z}, or being some other @i{implementation-defined} @i{character} that is defined by the @i{implementation} to be @i{lowercase}. See @ref{Characters With Case}. @end table @subheading @b{M} @table @asis @IGindex macro @item @b{macro} @i{n.} 1. a @i{macro form} 2. a @i{macro function}. 3. a @i{macro name}. @IGindex macro character @item @b{macro character} @i{n.} a @i{character} which, when encountered by the @i{Lisp reader} in its main dispatch loop, introduces a @i{reader macro}_1. (@i{Macro characters} have nothing to do with @i{macros}.) @IGindex macro expansion @item @b{macro expansion} @i{n.} 1. the process of translating a @i{macro form} into another @i{form}. 2. the @i{form} resulting from this process. @IGindex macro form @item @b{macro form} @i{n.} a @i{form} that stands for another @i{form} (@i{e.g.}, for the purposes of abstraction, information hiding, or syntactic convenience); that is, either a @i{compound form} whose first element is a @i{macro name}, or a @i{form} that is a @i{symbol} that names a @i{symbol macro}. @IGindex macro function @item @b{macro function} @i{n.} a @i{function} of two arguments, a @i{form} and an @i{environment}, that implements @i{macro expansion} by producing a @i{form} to be evaluated in place of the original argument @i{form}. @IGindex macro lambda list @item @b{macro lambda list} @i{n.} an @i{extended lambda list} used in @i{forms} that @i{establish} @i{macro} definitions, such as @b{defmacro} and @b{macrolet}. See @ref{Macro Lambda Lists}. @IGindex macro name @item @b{macro name} @i{n.} a @i{name} for which @b{macro-function} returns @i{true} and which when used as the first element of a @i{compound form} identifies that @i{form} as a @i{macro form}. @IGindex macroexpand hook @item @b{macroexpand hook} @i{n.} the @i{function} that is the @i{value} of @b{*macroexpand-hook*}. @IGindex mapping @item @b{mapping} @i{n.} 1. a type of iteration in which a @i{function} is successively applied to @i{objects} taken from corresponding entries in collections such as @i{sequences} or @i{hash tables}. 2. @i{Math.} a relation between two sets in which each element of the first set (the ``domain'') is assigned one element of the second set (the ``range''). @IGindex metaclass @item @b{metaclass} @i{n.} 1. a @i{class} whose instances are @i{classes}. 2. (of an @i{object}) the @i{class} of the @i{class} of the @i{object}. @IGindex Metaobject Protocol @item @b{Metaobject Protocol} @i{n.} one of many possible descriptions of how a @i{conforming implementation} might implement various aspects of the object system. This description is beyond the scope of this document, and no @i{conforming implementation} is required to adhere to it except as noted explicitly in this specification. Nevertheless, its existence helps to establish normative practice, and implementors with no reason to diverge from it are encouraged to consider making their @i{implementation} adhere to it where possible. It is described in detail in @i{The Art of the Metaobject Protocol}. @IGindex method @item @b{method} @i{n.} an @i{object} that is part of a @i{generic function} and which provides information about how that @i{generic function} should behave when its @i{arguments} are @i{objects} of certain @i{classes} or with certain identities. @IGindex method combination @item @b{method combination} @i{n.} 1. generally, the composition of a set of @i{methods} to produce an @i{effective method} for a @i{generic function}. 2. an object of @i{type} @b{method-combination}, which represents the details of how the @i{method combination}_1 for one or more specific @i{generic functions} is to be performed. @IGindex method-defining form @item @b{method-defining form} @i{n.} a @i{form} that defines a @i{method} for a @i{generic function}, whether explicitly or implicitly. See @ref{Introduction to Generic Functions}. @IGindex method-defining operator @item @b{method-defining operator} @i{n.} an @i{operator} corresponding to a @i{method-defining} @i{form}. See @i{Figure~7--1}. @IGindex minimal compilation @item @b{minimal compilation} @i{n.} actions the @i{compiler} must take at compile time. See @ref{Compilation Semantics}. @IGindex modified lambda list @item @b{modified lambda list} @i{n.} a list resembling an @i{ordinary lambda list} in form and purpose, but which deviates in syntax or functionality from the definition of an @i{ordinary lambda list}. See @i{ordinary lambda list}. ``@b{deftype} uses a modified lambda list.'' @IGindex most recent @item @b{most recent} @i{adj.} innermost; that is, having been @i{established} (and not yet @i{disestablished}) more recently than any other of its kind. @IGindex multiple escape @item @b{multiple escape} @i{n.}, @i{adj.} 1. @i{n.} the @i{syntax type} of a @i{character} that is used in pairs to indicate that the enclosed @i{characters} are to be treated as @i{alphabetic}_2 @i{characters} with their @i{case} preserved. For details, see @ref{Multiple Escape Characters}. 2. @i{adj.} (of a @i{character}) having the @i{multiple escape} @i{syntax type}. 3. @i{n.} a @i{multiple escape}_2 @i{character}. (In the @i{standard readtable}, @i{vertical-bar} is a @i{multiple escape} @i{character}.) @IGindex multiple values @item @b{multiple values} @i{n.} 1. more than one @i{value}. ``The function @b{truncate} returns multiple values.'' 2. a variable number of @i{values}, possibly including zero or one. ``The function @b{values} returns multiple values.'' 3. a fixed number of values other than one. ``The macro @b{multiple-value-bind} is among the few operators in @r{Common Lisp} which can detect and manipulate multiple values.'' @end table @subheading @b{N} @table @asis @IGindex name @item @b{name} @i{n.}, @i{v.t.} 1. @i{n.} an @i{identifier} by which an @i{object}, a @i{binding}, or an @i{exit point} is referred to by association using a @i{binding}. 2. @i{v.t.} to give a @i{name} to. 3. @i{n.} (of an @i{object} having a name component) the @i{object} which is that component. ``The string which is a symbol's name is returned by @b{symbol-name}.'' 4. @i{n.} (of a @i{pathname}) a. the name component, returned by @b{pathname-name}. b. the entire namestring, returned by @b{namestring}. 5. @i{n.} (of a @i{character}) a @i{string} that names the @i{character} and that has @i{length} greater than one. (All @i{non-graphic} @i{characters} are required to have @i{names} unless they have some @i{implementation-defined} @i{attribute} which is not @i{null}. Whether or not other @i{characters} have @i{names} is @i{implementation-dependent}.) @IGindex named constant @item @b{named constant} @i{n.} a @i{variable} that is defined by @r{Common Lisp}, by the @i{implementation}, or by user code (see the @i{macro} @b{defconstant}) to always @i{yield} the same @i{value} when @i{evaluated}. ``The value of a named constant may not be changed by assignment or by binding.'' @IGindex namespace @item @b{namespace} @i{n.} 1. @i{bindings} whose denotations are restricted to a particular kind. ``The bindings of names to tags is the tag namespace.'' 2. any @i{mapping} whose domain is a set of @i{names}. ``A package defines a namespace.'' @IGindex namestring @item @b{namestring} @i{n.} a @i{string} that represents a @i{filename} using either the @i{standardized} notation for naming @i{logical pathnames} described in @ref{Syntax of Logical Pathname Namestrings}, or some @i{implementation-defined} notation for naming a @i{physical pathname}. @IGindex newline @item @b{newline} @i{n.} the @i{standard character} <@i{Newline}>, notated for the @i{Lisp reader} as @t{#\Newline}. @IGindex next method @item @b{next method} @i{n.} the next @i{method} to be invoked with respect to a given @i{method} for a particular set of arguments or argument @i{classes}. See @ref{Applying method combination to the sorted list of applicable methods}. @IGindex nickname @item @b{nickname} @i{n.} (of a @i{package}) one of possibly several @i{names} that can be used to refer to the @i{package} but that is not the primary @i{name} of the @i{package}. @IGindex nil @item @b{nil} @i{n.} the @i{object} that is at once the @i{symbol} named @t{"NIL"} in the @t{COMMON-LISP} @i{package}, the @i{empty list}, the @i{boolean} (or @i{generalized boolean}) representing @i{false}, and the @i{name} of the @i{empty type}. @IGindex non-atomic @item @b{non-atomic} @i{adj.} being other than an @i{atom}; @i{i.e.}, being a @i{cons}. @IGindex non-constant variable @item @b{non-constant variable} @i{n.} a @i{variable} that is not a @i{constant variable}. @IGindex non-correctable @item @b{non-correctable} @i{adj.} (of an @i{error}) not intentionally @i{correctable}. (Because of the dynamic nature of @i{restarts}, it is neither possible nor generally useful to completely prohibit an @i{error} from being @i{correctable}. This term is used in order to express an intent that no special effort should be made by @i{code} signaling an @i{error} to make that @i{error} @i{correctable}; however, there is no actual requirement on @i{conforming programs} or @i{conforming implementations} imposed by this term.) @IGindex non-empty @item @b{non-empty} @i{adj.} having at least one @i{element}. @IGindex non-generic function @item @b{non-generic function} @i{n.} a @i{function} that is not a @i{generic function}. @IGindex non-graphic @item @b{non-graphic} @i{adj.} (of a @i{character}) not @i{graphic}. See @ref{Graphic Characters}. @IGindex non-list @item @b{non-list} @i{n.}, @i{adj.} other than a @i{list}; @i{i.e.}, a @i{non-nil} @i{atom}. @IGindex non-local exit @item @b{non-local exit} @i{n.} a transfer of control (and sometimes @i{values}) to an @i{exit point} for reasons other than a @i{normal return}. ``The operators @b{go}, @b{throw}, and @b{return-from} cause a non-local exit.'' @IGindex non-nil @item @b{non-nil} @i{n.}, @i{adj.} not @b{nil}. Technically, any @i{object} which is not @b{nil} can be referred to as @i{true}, but that would tend to imply a unique view of the @i{object} as a @i{generalized boolean}. Referring to such an @i{object} as @i{non-nil} avoids this implication. @IGindex non-null lexical environment @item @b{non-null lexical environment} @i{n.} a @i{lexical environment} that has additional information not present in the @i{global environment}, such as one or more @i{bindings}. @IGindex non-simple @item @b{non-simple} @i{adj.} not @i{simple}. @IGindex non-terminating @item @b{non-terminating} @i{adj.} (of a @i{macro character}) being such that it is treated as a constituent @i{character} when it appears in the middle of an extended token. See @ref{Reader Algorithm}. @IGindex non-top-level form @item @b{non-top-level form} @i{n.} a @i{form} that, by virtue of its position as a @i{subform} of another @i{form}, is not a @i{top level form}. See @ref{Processing of Top Level Forms}. @IGindex normal return @item @b{normal return} @i{n.} the natural transfer of control and @i{values} which occurs after the complete @i{execution} of a @i{form}. @IGindex normalized @item @b{normalized} @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) conforming to the description of ``normalized'' as described by @i{IEEE Standard for Binary Floating-Point Arithmetic}. See @i{denormalized}. @IGindex null @item @b{null} @i{adj.}, @i{n.} 1. @i{adj.} a. (of a @i{list}) having no @i{elements}: empty. See @i{empty list}. b. (of a @i{string}) having a @i{length} of zero. (It is common, both within this document and in observed spoken behavior, to refer to an empty string by an apparent definite reference, as in ``the @i{null} @i{string}'' even though no attempt is made to @i{intern}_2 null strings. The phrase ``a @i{null} @i{string}'' is technically more correct, but is generally considered awkward by most Lisp programmers. As such, the phrase ``the @i{null} @i{string}'' should be treated as an indefinite reference in all cases except for anaphoric references.) c. (of an @i{implementation-defined} @i{attribute} of a @i{character}) An @i{object} to which the value of that @i{attribute} defaults if no specific value was requested. 2. @i{n.} an @i{object} of @i{type} @b{null} (the only such @i{object} being @b{nil}). @IGindex null lexical environment @item @b{null lexical environment} @i{n.} the @i{lexical environment} which has no @i{bindings}. @IGindex number @item @b{number} @i{n.} an @i{object} of @i{type} @b{number}. @IGindex numeric @item @b{numeric} @i{adj.} (of a @i{character}) being one of the @i{standard characters} @t{0} through @i{9}, or being some other @i{graphic} @i{character} defined by the @i{implementation} to be @i{numeric}. @end table @subheading @b{O} @table @asis @IGindex object @item @b{object} @i{n.} 1. any Lisp datum. ``The function @b{cons} creates an object which refers to two other objects.'' 2. (immediately following the name of a @i{type}) an @i{object} which is of that @i{type}, used to emphasize that the @i{object} is not just a @i{name} for an object of that @i{type} but really an @i{element} of the @i{type} in cases where @i{objects} of that @i{type} (such as @b{function} or @b{class}) are commonly referred to by @i{name}. ``The function @b{symbol-function} takes a function name and returns a function object.'' @IGindex object-traversing @item @b{object-traversing} @i{adj.} operating in succession on components of an @i{object}. ``The operators @b{mapcar}, @b{maphash}, @b{with-package-iterator} and @b{count} perform object-traversing operations.'' @IGindex open @item @b{open} @i{adj.}, @i{v.t.} (a @i{file}) 1. @i{v.t.} to create and return a @i{stream} to the @i{file}. 2. @i{adj.} (of a @i{stream}) having been @i{opened}_1, but not yet @i{closed}. @IGindex operator @item @b{operator} @i{n.} 1. a @i{function}, @i{macro}, or @i{special operator}. 2. a @i{symbol} that names such a @i{function}, @i{macro}, or @i{special operator}. 3. (in a @b{function} @i{special form}) the @i{cadr} of the @b{function} @i{special form}, which might be either an @i{operator}_2 or a @i{lambda expression}. 4. (of a @i{compound form}) the @i{car} of the @i{compound form}, which might be either an @i{operator}_2 or a @i{lambda expression}, and which is never @t{(setf @i{symbol})}. @IGindex optimize quality @item @b{optimize quality} @i{n.} one of several aspects of a program that might be optimizable by certain compilers. Since optimizing one such quality might conflict with optimizing another, relative priorities for qualities can be established in an @b{optimize} @i{declaration}. The @i{standardized} @i{optimize qualities} are @t{compilation-speed} (speed of the compilation process), @t{debug} (ease of debugging), @t{safety} (run-time error checking), @t{space} (both code size and run-time space), and @t{speed} (of the object code). @i{Implementations} may define additional @i{optimize qualities}. @IGindex optional parameter @item @b{optional parameter} @i{n.} A @i{parameter} for which a corresponding positional @i{argument} is optional. If the @i{argument} is not supplied, a default value is used. See also @i{supplied-p parameter}. @IGindex ordinary function @item @b{ordinary function} @i{n.} a @i{function} that is not a @i{generic function}. @IGindex ordinary lambda list @item @b{ordinary lambda list} @i{n.} the kind of @i{lambda list} used by @b{lambda}. See @i{modified lambda list} and @i{extended lambda list}. ``@b{defun} uses an ordinary lambda list.'' @IGindex otherwise inaccessible part @item @b{otherwise inaccessible part} @i{n.} (of an @i{object}, O_1) an @i{object}, O_2, which would be made @i{inaccessible} if O_1 were made @i{inaccessible}. (Every @i{object} is an @i{otherwise inaccessible part} of itself.) @IGindex output @item @b{output} @i{adj.} (of a @i{stream}) supporting output operations (@i{i.e.}, being a ``data sink''). An @i{output} @i{stream} might also be an @i{input} @i{stream}, in which case it is sometimes called a @i{bidirectional} @i{stream}. See the @i{function} @b{output-stream-p}. @end table @subheading @b{P} @table @asis @IGindex package @item @b{package} @i{n.} an @i{object} of @i{type} @b{package}. @IGindex package cell @item @b{package cell} @i{n.} @i{Trad.} (of a @i{symbol}) The @i{place} in a @i{symbol} that holds one of possibly several @i{packages} in which the @i{symbol} is @i{interned}, called the @i{home package}, or which holds @b{nil} if no such @i{package} exists or is known. See the @i{function} @b{symbol-package}. @IGindex package designator @item @b{package designator} @i{n.} a @i{designator} for a @i{package}; that is, an @i{object} that denotes a @i{package} and that is one of: a @i{string designator} (denoting the @i{package} that has the @i{string} that it designates as its @i{name} or as one of its @i{nicknames}), or a @i{package} (denoting itself). @IGindex package marker @item @b{package marker} @i{n.} a character which is used in the textual notation for a symbol to separate the package name from the symbol name, and which is @i{colon} in the @i{standard readtable}. See @ref{Character Syntax}. @IGindex package prefix @item @b{package prefix} @i{n.} a notation preceding the @i{name} of a @i{symbol} in text that is processed by the @i{Lisp reader}, which uses a @i{package} @i{name} followed by one or more @i{package markers}, and which indicates that the symbol is looked up in the indicated @i{package}. @IGindex package registry @item @b{package registry} @i{n.} A mapping of @i{names} to @i{package} @i{objects}. It is possible for there to be a @i{package} @i{object} which is not in this mapping; such a @i{package} is called an @i{unregistered package}. @i{Operators} such as @b{find-package} consult this mapping in order to find a @i{package} from its @i{name}. @i{Operators} such as @b{do-all-symbols}, @b{find-all-symbols}, and @b{list-all-packages} operate only on @i{packages} that exist in the @i{package registry}. @IGindex pairwise @item @b{pairwise} @i{adv.} (of an adjective on a set) applying individually to all possible pairings of elements of the set. ``The types A, B, and C are pairwise disjoint if A and B are disjoint, B and C are disjoint, and A and C are disjoint.'' @IGindex parallel @item @b{parallel} @i{adj.} @i{Trad.} (of @i{binding} or @i{assignment}) done in the style of @b{psetq}, @b{let}, or @b{do}; that is, first evaluating all of the @i{forms} that produce @i{values}, and only then @i{assigning} or @i{binding} the @i{variables} (or @i{places}). Note that this does not imply traditional computational ``parallelism'' since the @i{forms} that produce @i{values} are evaluated @i{sequentially}. See @i{sequential}. @IGindex parameter @item @b{parameter} @i{n.} 1. (of a @i{function}) a @i{variable} in the definition of a @i{function} which takes on the @i{value} of a corresponding @i{argument} (or of a @i{list} of corresponding arguments) to that @i{function} when it is called, or which in some cases is given a default value because there is no corresponding @i{argument}. 2. (of a @i{format directive}) an @i{object} received as data flow by a @i{format directive} due to a prefix notation within the @i{format string} at the @i{format directive}'s point of use. See @ref{Formatted Output}. ``In @t{"~3,'0D"}, the number @t{3} and the character @t{#\0} are parameters to the @t{~D} format directive.'' @IGindex parameter specializer @item @b{parameter specializer} @i{n.} 1. (of a @i{method}) an @i{expression} which constrains the @i{method} to be applicable only to @i{argument} sequences in which the corresponding @i{argument} matches the @i{parameter specializer}. 2. a @i{class}, or a @i{list} @t{(eql @i{object})}. @IGindex parameter specializer name @item @b{parameter specializer name} @i{n.} 1. (of a @i{method} definition) an expression used in code to name a @i{parameter specializer}. See @ref{Introduction to Methods}. 2. a @i{class}, a @i{symbol} naming a @i{class}, or a @i{list} @t{(eql @i{form})}. @IGindex pathname @item @b{pathname} @i{n.} an @i{object} of @i{type} @b{pathname}, which is a structured representation of the name of a @i{file}. A @i{pathname} has six components: a ``host,'' a ``device,'' a ``directory,'' a ``name,'' a ``type,'' and a ``version.'' @IGindex pathname designator @item @b{pathname designator} @i{n.} a @i{designator} for a @i{pathname}; that is, an @i{object} that denotes a @i{pathname} and that is one of: a @i{pathname} @i{namestring} (denoting the corresponding @i{pathname}), a @i{stream associated with a file} (denoting the @i{pathname} used to open the @i{file}; this may be, but is not required to be, the actual name of the @i{file}), or a @i{pathname} (denoting itself). See @ref{File Operations on Open and Closed Streams}. @IGindex physical pathname @item @b{physical pathname} @i{n.} a @i{pathname} that is not a @i{logical pathname}. [Editorial Note by KMP: Still need to reconcile some confusion in the uses of ``generalized reference'' and ``place.'' I think one was supposed to refer to the abstract concept, and the other to an object (a form), but the usages have become blurred.] @IGindex place @item @b{place} @i{n.} 1. a @i{form} which is suitable for use as a @i{generalized reference}. 2. the conceptual location referred to by such a @i{place}_1. @IGindex plist @item @b{plist} pronounced 'p\=e ,list @i{n.} a @i{property list}. @IGindex portable @item @b{portable} @i{adj.} (of @i{code}) required to produce equivalent results and observable side effects in all @i{conforming implementations}. @IGindex potential copy @item @b{potential copy} @i{n.} (of an @i{object} O_1 subject to constriants) an @i{object} O_2 that if the specified constraints are satisfied by O_1 without any modification might or might not be @i{identical} to O_1, or else that must be a @i{fresh} @i{object} that resembles a @i{copy} of O_1 except that it has been modified as necessary to satisfy the constraints. @IGindex potential number @item @b{potential number} @i{n.} A textual notation that might be parsed by the @i{Lisp reader} in some @i{conforming implementation} as a @i{number} but is not required to be parsed as a @i{number}. No @i{object} is a @i{potential number}---either an @i{object} is a @i{number} or it is not. See @ref{Potential Numbers as Tokens}. @IGindex pprint dispatch table @item @b{pprint dispatch table} @i{n.} an @i{object} that can be the @i{value} of @b{*print-pprint-dispatch*} and hence can control how @i{objects} are printed when @b{*print-pretty*} is @i{true}. See @ref{Pretty Print Dispatch Tables}. @IGindex predicate @item @b{predicate} @i{n.} a @i{function} that returns a @i{generalized boolean} as its first value. @IGindex present @item @b{present} @i{n.} 1. (of a @i{feature} in a @i{Lisp image}) a state of being that is in effect if and only if the @i{symbol} naming the @i{feature} is an @i{element} of the @i{features list}. 2. (of a @i{symbol} in a @i{package}) being accessible in that @i{package} directly, rather than being inherited from another @i{package}. @IGindex pretty print @item @b{pretty print} @i{v.t.} (an @i{object}) to invoke the @i{pretty printer} on the @i{object}. @IGindex pretty printer @item @b{pretty printer} @i{n.} the procedure that prints the character representation of an @i{object} onto a @i{stream} when the @i{value} of @b{*print-pretty*} is @i{true}, and that uses layout techniques (@i{e.g.}, indentation) that tend to highlight the structure of the @i{object} in a way that makes it easier for human readers to parse visually. See the @i{variable} @b{*print-pprint-dispatch*} and @ref{The Lisp Pretty Printer}. @IGindex pretty printing stream @item @b{pretty printing stream} @i{n.} a @i{stream} that does pretty printing. Such streams are created by the @i{function} @b{pprint-logical-block} as a link between the output stream and the logical block. @IGindex primary method @item @b{primary method} @i{n.} a member of one of two sets of @i{methods} (the set of @i{auxiliary methods} is the other) that form an exhaustive partition of the set of @i{methods} on the @i{method}'s @i{generic function}. How these sets are determined is dependent on the @i{method combination} type; see @ref{Introduction to Methods}. @IGindex primary value @item @b{primary value} @i{n.} (of @i{values} resulting from the @i{evaluation} of a @i{form}) the first @i{value}, if any, or else @b{nil} if there are no @i{values}. ``The primary value returned by @b{truncate} is an integer quotient, truncated toward zero.'' @IGindex principal @item @b{principal} @i{adj.} (of a value returned by a @r{Common Lisp} @i{function} that implements a mathematically irrational or transcendental function defined in the complex domain) of possibly many (sometimes an infinite number of) correct values for the mathematical function, being the particular @i{value} which the corresponding @r{Common Lisp} @i{function} has been defined to return. @IGindex print name @item @b{print name} @i{n.} @i{Trad.} (usually of a @i{symbol}) a @i{name}_3. @IGindex printer control variable @item @b{printer control variable} @i{n.} a @i{variable} whose specific purpose is to control some action of the @i{Lisp printer}; that is, one of the @i{variables} in @i{Figure~22--1}, or else some @i{implementation-defined} @i{variable} which is defined by the @i{implementation} to be a @i{printer control variable}. @IGindex printer escaping @item @b{printer escaping} @i{n.} The combined state of the @i{printer control variables} @b{*print-escape*} and @b{*print-readably*}. If the value of either @b{*print-readably*} or @b{*print-escape*} is @i{true}, then @i{printer escaping} @IGindex printer escaping is ``enabled''; otherwise (if the values of both @b{*print-readably*} and @b{*print-escape*} are @i{false}), then @i{printer escaping} is ``disabled''. @IGindex printing @item @b{printing} @i{adj.} (of a @i{character}) being a @i{graphic} @i{character} other than @i{space}. @IGindex process @item @b{process} @i{v.t.} (a @i{form} by the @i{compiler}) to perform @i{minimal compilation}, determining the time of evaluation for a @i{form}, and possibly @i{evaluating} that @i{form} (if required). @IGindex processor @item @b{processor} @i{n.}, @i{ANSI} an @i{implementation}. @IGindex proclaim @item @b{proclaim} @i{v.t.} (a @i{proclamation}) to @i{establish} that @i{proclamation}. @IGindex proclamation @item @b{proclamation} @i{n.} a @i{global declaration}. @IGindex prog tag @item @b{prog tag} @i{n.} @i{Trad.} a @i{go tag}. @IGindex program @item @b{program} @i{n.} @i{Trad.} @r{Common Lisp} @i{code}. @IGindex programmer @item @b{programmer} @i{n.} an active entity, typically a human, that writes a @i{program}, and that might or might not also be a @i{user} of the @i{program}. @IGindex programmer code @item @b{programmer code} @i{n.} @i{code} that is supplied by the programmer; that is, @i{code} that is not @i{system code}. @IGindex proper list @item @b{proper list} @i{n.} A @i{list} terminated by the @i{empty list}. (The @i{empty list} is a @i{proper list}.) See @i{improper list}. @IGindex proper name @item @b{proper name} @i{n.} (of a @i{class}) a @i{symbol} that @i{names} the @i{class} whose @i{name} is that @i{symbol}. See the @i{functions} @b{class-name} and @b{find-class}. @IGindex proper sequence @item @b{proper sequence} @i{n.} a @i{sequence} which is not an @i{improper list}; that is, a @i{vector} or a @i{proper list}. @IGindex proper subtype @item @b{proper subtype} @i{n.} (of a @i{type}) a @i{subtype} of the @i{type} which is not the @i{same} @i{type} as the @i{type} (@i{i.e.}, its @i{elements} are a ``proper subset'' of the @i{type}). @IGindex property @item @b{property} @i{n.} (of a @i{property list}) 1. a conceptual pairing of a @i{property indicator} and its associated @i{property value} on a @i{property list}. 2. a @i{property value}. @IGindex property indicator @item @b{property indicator} @i{n.} (of a @i{property list}) the @i{name} part of a @i{property}, used as a @i{key} when looking up a @i{property value} on a @i{property list}. @IGindex property list @item @b{property list} @i{n.} 1. a @i{list} containing an even number of @i{elements} that are alternating @i{names} (sometimes called @i{indicators} or @i{keys}) and @i{values} (sometimes called @i{properties}). When there is more than one @i{name} and @i{value} pair with the @i{identical} @i{name} in a @i{property list}, the first such pair determines the @i{property}. 2. (of a @i{symbol}) the component of the @i{symbol} containing a @i{property list}. @IGindex property value @item @b{property value} @i{n.} (of a @i{property indicator} on a @i{property list}) the @i{object} associated with the @i{property indicator} on the @i{property list}. @IGindex purports to conform @item @b{purports to conform} @i{v.} makes a good-faith claim of conformance. This term expresses intention to conform, regardless of whether the goal of that intention is realized in practice. For example, language implementations have been known to have bugs, and while an @i{implementation} of this specification with bugs might not be a @i{conforming implementation}, it can still @i{purport to conform}. This is an important distinction in certain specific cases; @i{e.g.}, see the @i{variable} @b{*features*}. @end table @subheading @b{Q} @table @asis @IGindex qualified method @item @b{qualified method} @i{n.} a @i{method} that has one or more @i{qualifiers}. @IGindex qualifier @item @b{qualifier} @i{n.} (of a @i{method} for a @i{generic function}) one of possibly several @i{objects} used to annotate the @i{method} in a way that identifies its role in the @i{method combination}. The @i{method combination} @i{type} determines how many @i{qualifiers} are permitted for each @i{method}, which @i{qualifiers} are permitted, and the semantics of those @i{qualifiers}. @IGindex query I/O @item @b{query I/O} @i{n.} the @i{bidirectional} @i{stream} that is the @i{value} of the @i{variable} @b{*query-io*}. @IGindex quoted object @item @b{quoted object} @i{n.} an @i{object} which is the second element of a @b{quote} @i{form}. @end table @subheading @b{R} @table @asis @IGindex radix @item @b{radix} @i{n.} an @i{integer} between 2 and 36, inclusive, which can be used to designate a base with respect to which certain kinds of numeric input or output are performed. (There are n valid digit characters for any given @i{radix} n, and those digits are the first n digits in the sequence @t{0}, @t{1}, ..., @t{9}, @t{A}, @t{B}, ..., @t{Z}, which have the weights @t{0}, @t{1}, ..., @t{9}, @t{10}, @t{11}, ..., @t{35}, respectively. Case is not significant in parsing numbers of radix greater than @t{10}, so ``9b8a'' and ``9B8A'' denote the same @i{radix} @t{16} number.) @IGindex random state @item @b{random state} @i{n.} an @i{object} of @i{type} @b{random-state}. @IGindex rank @item @b{rank} @i{n.} a non-negative @i{integer} indicating the number of @i{dimensions} of an @i{array}. @IGindex ratio @item @b{ratio} @i{n.} an @i{object} of @i{type} @b{ratio}. @IGindex ratio marker @item @b{ratio marker} @i{n.} a character which is used in the textual notation for a @i{ratio} to separate the numerator from the denominator, and which is @i{slash} in the @i{standard readtable}. See @ref{Character Syntax}. @IGindex rational @item @b{rational} @i{n.} an @i{object} of @i{type} @b{rational}. @IGindex read @item @b{read} @i{v.t.} 1. (a @i{binding} or @i{slot} or component) to obtain the @i{value} of the @i{binding} or @i{slot}. 2. (an @i{object} from a @i{stream}) to parse an @i{object} from its representation on the @i{stream}. @IGindex readably @item @b{readably} @i{adv.} (of a manner of printing an @i{object} O_1) in such a way as to permit the @i{Lisp Reader} to later @i{parse} the printed output into an @i{object} O_2 that is @i{similar} to O_1. @IGindex reader @item @b{reader} @i{n.} 1. a @i{function} that @i{reads}_1 a @i{variable} or @i{slot}. 2. the @i{Lisp reader}. @IGindex reader macro @item @b{reader macro} @i{n.} 1. a textual notation introduced by dispatch on one or two @i{characters} that defines special-purpose syntax for use by the @i{Lisp reader}, and that is implemented by a @i{reader macro function}. See @ref{Reader Algorithm}. 2. the @i{character} or @i{characters} that introduce a @i{reader macro}_1; that is, a @i{macro character} or the conceptual pairing of a @i{dispatching macro character} and the @i{character} that follows it. (A @i{reader macro} is not a kind of @i{macro}.) @IGindex reader macro function @item @b{reader macro function} @i{n.} a @i{function} @i{designator} that denotes a @i{function} that implements a @i{reader macro}_2. See the @i{functions} @b{set-macro-character} and @b{set-dispatch-macro-character}. @IGindex readtable @item @b{readtable} @i{n.} an @i{object} of @i{type} @b{readtable}. @IGindex readtable case @item @b{readtable case} @i{n.} an attribute of a @i{readtable} whose value is a @i{case sensitivity mode}, and that selects the manner in which @i{characters} in a @i{symbol}'s @i{name} are to be treated by the @i{Lisp reader} and the @i{Lisp printer}. See @ref{Effect of Readtable Case on the Lisp Reader} and @ref{Effect of Readtable Case on the Lisp Printer}. @IGindex readtable designator @item @b{readtable designator} @i{n.} a @i{designator} for a @i{readtable}; that is, an @i{object} that denotes a @i{readtable} and that is one of: @b{nil} (denoting the @i{standard readtable}), or a @i{readtable} (denoting itself). @IGindex recognizable subtype @item @b{recognizable subtype} @i{n.} (of a @i{type}) a @i{subtype} of the @i{type} which can be reliably detected to be such by the @i{implementation}. See the @i{function} @b{subtypep}. @IGindex reference @item @b{reference} @i{n.}, @i{v.t.} 1. @i{n.} an act or occurrence of referring to an @i{object}, a @i{binding}, an @i{exit point}, a @i{tag}, or an @i{environment}. 2. @i{v.t.} to refer to an @i{object}, a @i{binding}, an @i{exit point}, a @i{tag}, or an @i{environment}, usually by @i{name}. @IGindex registered package @item @b{registered package} @i{n.} a @i{package} @i{object} that is installed in the @i{package registry}. (Every @i{registered package} has a @i{name} that is a @i{string}, as well as zero or more @i{string} nicknames. All @i{packages} that are initially specified by @r{Common Lisp} or created by @b{make-package} or @b{defpackage} are @i{registered packages}. @i{Registered packages} can be turned into @i{unregistered packages} by @b{delete-package}.) @IGindex relative @item @b{relative} @i{adj.} 1. (of a @i{time}) representing an offset from an @i{absolute} @i{time} in the units appropriate to that time. For example, a @i{relative} @i{internal time} is the difference between two @i{absolute} @i{internal times}, and is measured in @i{internal time units}. 2. (of a @i{pathname}) representing a position in a directory hierarchy by motion from a position other than the root, which might therefore vary. ``The notation @t{#P"../foo.text"} denotes a relative pathname if the host file system is Unix.'' See @i{absolute}. @IGindex repertoire @item @b{repertoire} @i{n.}, @i{ISO} a @i{subtype} of @b{character}. See @ref{Character Repertoires}. @IGindex report @item @b{report} @i{n.} (of a @i{condition}) to @i{call} the @i{function} @b{print-object} on the @i{condition} in an @i{environment} where the @i{value} of @b{*print-escape*} is @i{false}. @IGindex report message @item @b{report message} @i{n.} the text that is output by a @i{condition reporter}. @IGindex required parameter @item @b{required parameter} @i{n.} A @i{parameter} for which a corresponding positional @i{argument} must be supplied when @i{calling} the @i{function}. @IGindex rest list @item @b{rest list} @i{n.} (of a @i{function} having a @i{rest parameter}) The @i{list} to which the @i{rest parameter} is @i{bound} on some particular @i{call} to the @i{function}. @IGindex rest parameter @item @b{rest parameter} @i{n.} A @i{parameter} which was introduced by @b{&rest}. @IGindex restart @item @b{restart} @i{n.} an @i{object} of @i{type} @b{restart}. @IGindex restart designator @item @b{restart designator} @i{n.} a @i{designator} for a @i{restart}; that is, an @i{object} that denotes a @i{restart} and that is one of: a @i{non-nil} @i{symbol} (denoting the most recently established @i{active} @i{restart} whose @i{name} is that @i{symbol}), or a @i{restart} (denoting itself). @IGindex restart function @item @b{restart function} @i{n.} a @i{function} that invokes a @i{restart}, as if by @b{invoke-restart}. The primary purpose of a @i{restart function} is to provide an alternate interface. By convention, a @i{restart function} usually has the same name as the @i{restart} which it invokes. Figure 26--4 shows a list of the @i{standardized} @i{restart functions}. @format @group @noindent @w{ abort muffle-warning use-value } @w{ continue store-value } @noindent @w{ Figure 26--4: Standardized Restart Functions} @end group @end format @IGindex return @item @b{return} @i{v.t.} (of @i{values}) 1. (from a @i{block}) to transfer control and @i{values} from the @i{block}; that is, to cause the @i{block} to @i{yield} the @i{values} immediately without doing any further evaluation of the @i{forms} in its body. 2. (from a @i{form}) to @i{yield} the @i{values}. @IGindex return value @item @b{return value} @i{n.} @i{Trad.} a @i{value}_1 @IGindex right-parenthesis @item @b{right-parenthesis} @i{n.} the @i{standard character} ``@t{)}'', that is variously called ``right parenthesis'' or ``close parenthesis'' See @i{Figure~2--5}. @IGindex run time @item @b{run time} @i{n.} 1. @i{load time} 2. @i{execution time} @IGindex run-time compiler @item @b{run-time compiler} @i{n.} refers to the @b{compile} function or to @i{implicit compilation}, for which the compilation and run-time @i{environments} are maintained in the same @i{Lisp image}. @IGindex run-time definition @item @b{run-time definition} @i{n.} a definition in the @i{run-time environment}. @IGindex run-time environment @item @b{run-time environment} @i{n.} the @i{environment} in which a program is @i{executed}. @end table @subheading @b{S} @table @asis @IGindex safe @item @b{safe} @i{adj.} 1. (of @i{code}) processed in a @i{lexical environment} where the the highest @b{safety} level (@t{3}) was in effect. See @b{optimize}. 2. (of a @i{call}) a @i{safe call}. @IGindex safe call @item @b{safe call} @i{n.} a @i{call} in which the @i{call}, the @i{function} being @i{called}, and the point of @i{functional evaluation} are all @i{safe}_1 @i{code}. For more detailed information, see @ref{Safe and Unsafe Calls}. @IGindex same @item @b{same} @i{adj.} 1. (of @i{objects} under a specified @i{predicate}) indistinguishable by that @i{predicate}. ``The symbol @t{car}, the string @t{"car"}, and the string @t{"CAR"} are the @t{same} under @b{string-equal}''. 2. (of @i{objects} if no predicate is implied by context) indistinguishable by @b{eql}. Note that @b{eq} might be capable of distinguishing some @i{numbers} and @i{characters} which @b{eql} cannot distinguish, but the nature of such, if any, is @i{implementation-dependent}. Since @b{eq} is used only rarely in this specification, @b{eql} is the default predicate when none is mentioned explicitly. ``The conses returned by two successive calls to @b{cons} are never the same.'' 3. (of @i{types}) having the same set of @i{elements}; that is, each @i{type} is a @i{subtype} of the others. ``The types specified by @t{(integer 0 1)}, @t{(unsigned-byte 1)}, and @t{bit} are the same.'' @IGindex satisfy the test @item @b{satisfy the test} @i{v.} (of an @i{object} being considered by a @i{sequence function}) 1. (for a one @i{argument} test) to be in a state such that the @i{function} which is the @i{predicate} @i{argument} to the @i{sequence function} returns @i{true} when given a single @i{argument} that is the result of calling the @i{sequence function}'s @i{key} @i{argument} on the @i{object} being considered. See @ref{Satisfying a One-Argument Test}. 2. (for a two @i{argument} test) to be in a state such that the two-place @i{predicate} which is the @i{sequence function}'s @i{test} @i{argument} returns @i{true} when given a first @i{argument} that is the @i{object} being considered, and when given a second @i{argument} that is the result of calling the @i{sequence function}'s @i{key} @i{argument} on an @i{element} of the @i{sequence function}'s @i{sequence} @i{argument} which is being tested for equality; or to be in a state such that the @i{test-not} @i{function} returns @i{false} given the same @i{arguments}. See @ref{Satisfying a Two-Argument Test}. @IGindex scope @item @b{scope} @i{n.} the structural or textual region of code in which @i{references} to an @i{object}, a @i{binding}, an @i{exit point}, a @i{tag}, or an @i{environment} (usually by @i{name}) can occur. @IGindex script @item @b{script} @i{n.} @i{ISO} one of possibly several sets that form an @i{exhaustive partition} of the type @b{character}. See @ref{Character Scripts}. @IGindex secondary value @item @b{secondary value} @i{n.} (of @i{values} resulting from the @i{evaluation} of a @i{form}) the second @i{value}, if any, or else @b{nil} if there are fewer than two @i{values}. ``The secondary value returned by @b{truncate} is a remainder.'' @IGindex section @item @b{section} @i{n.} a partitioning of output by a @i{conditional newline} on a @i{pretty printing stream}. See @ref{Dynamic Control of the Arrangement of Output}. @IGindex self-evaluating object @item @b{self-evaluating object} @i{n.} an @i{object} that is neither a @i{symbol} nor a @i{cons}. If a @i{self-evaluating object} is @i{evaluated}, it @i{yields} itself as its only @i{value}. ``Strings are self-evaluating objects.'' @IGindex semi-standard @item @b{semi-standard} @i{adj.} (of a language feature) not required to be implemented by any @i{conforming implementation}, but nevertheless recommended as the canonical approach in situations where an @i{implementation} does plan to support such a feature. The presence of @i{semi-standard} aspects in the language is intended to lessen portability problems and reduce the risk of gratuitous divergence among @i{implementations} that might stand in the way of future standardization. @IGindex semicolon @item @b{semicolon} @i{n.} the @i{standard character} that is called ``semicolon'' (@t{;}). See @i{Figure~2--5}. @IGindex sequence @item @b{sequence} @i{n.} 1. an ordered collection of elements 2. a @i{vector} or a @i{list}. @IGindex sequence function @item @b{sequence function} @i{n.} one of the @i{functions} in @i{Figure~17--1}, or an @i{implementation-defined} @i{function} that operates on one or more @i{sequences}. and that is defined by the @i{implementation} to be a @i{sequence function}. @IGindex sequential @item @b{sequential} @i{adj.} @i{Trad.} (of @i{binding} or @i{assignment}) done in the style of @b{setq}, @b{let*}, or @b{do*}; that is, interleaving the evaluation of the @i{forms} that produce @i{values} with the @i{assignments} or @i{bindings} of the @i{variables} (or @i{places}). See @i{parallel}. @IGindex sequentially @item @b{sequentially} @i{adv.} in a @i{sequential} way. @IGindex serious condition @item @b{serious condition} @i{n.} a @i{condition} of @i{type} @b{serious-condition}, which represents a @i{situation} that is generally sufficiently severe that entry into the @i{debugger} should be expected if the @i{condition} is @i{signaled} but not @i{handled}. @IGindex session @item @b{session} @i{n.} the conceptual aggregation of events in a @i{Lisp image} from the time it is started to the time it is terminated. @IGindex set @item @b{set} @i{v.t.} @i{Trad.} (any @i{variable} or a @i{symbol} that is the @i{name} of a @i{dynamic variable}) to @i{assign} the @i{variable}. @IGindex setf expander @item @b{setf expander} @i{n.} a function used by @b{setf} to compute the @i{setf expansion} of a @i{place}. @IGindex setf expansion @item @b{setf expansion} @i{n.} a set of five @i{expressions}_1 that, taken together, describe how to store into a @i{place} and which @i{subforms} of the macro call associated with the @i{place} are evaluated. See @ref{Setf Expansions}. @IGindex setf function @item @b{setf function} @i{n.} a @i{function} whose @i{name} is @t{(setf @i{symbol})}. @IGindex setf function name @item @b{setf function name} @i{n.} (of a @i{symbol} @i{S}) the @i{list} @t{(setf @i{S})}. @IGindex shadow @item @b{shadow} @i{v.t.} 1. to override the meaning of. ``That binding of @t{X} shadows an outer one.'' 2. to hide the presence of. ``That @b{macrolet} of @t{F} shadows the outer @b{flet} of @t{F}.'' 3. to replace. ``That package shadows the symbol @t{cl:car} with its own symbol @t{car}.'' @IGindex shadowing symbol @item @b{shadowing symbol} @i{n.} (in a @i{package}) an @i{element} of the @i{package}'s @i{shadowing symbols list}. @IGindex shadowing symbols list @item @b{shadowing symbols list} @i{n.} (of a @i{package}) a @i{list}, associated with the @i{package}, of @i{symbols} that are to be exempted from `symbol conflict errors' detected when packages are @i{used}. See the @i{function} @b{package-shadowing-symbols}. @IGindex shared slot @item @b{shared slot} @i{n.} (of a @i{class}) a @i{slot} @i{accessible} in more than one @i{instance} of a @i{class}; specifically, such a @i{slot} is @i{accessible} in all @i{direct instances} of the @i{class} and in those @i{indirect instances} whose @i{class} does not @i{shadow}_1 the @i{slot}. @IGindex sharpsign @item @b{sharpsign} @i{n.} the @i{standard character} that is variously called ``number sign,'' ``sharp,'' or ``sharp sign'' (@t{#}). See @i{Figure~2--5}. @IGindex short float @item @b{short float} @i{n.} an @i{object} of @i{type} @b{short-float}. @IGindex sign @item @b{sign} @i{n.} one of the @i{standard characters} ``@t{+}'' or ``@t{-}''. @IGindex signal @item @b{signal} @i{v.} to announce, using a standard protocol, that a particular situation, represented by a @i{condition}, has been detected. See @ref{Condition System Concepts}. @IGindex signature @item @b{signature} @i{n.} (of a @i{method}) a description of the @i{parameters} and @i{parameter specializers} for the @i{method} which determines the @i{method}'s applicability for a given set of required @i{arguments}, and which also describes the @i{argument} conventions for its other, non-required @i{arguments}. @IGindex similar @item @b{similar} @i{adj.} (of two @i{objects}) defined to be equivalent under the @i{similarity} relationship. @IGindex similarity @item @b{similarity} @i{n.} a two-place conceptual equivalence predicate, which is independent of the @i{Lisp image} so that two @i{objects} in different @i{Lisp images} can be understood to be equivalent under this predicate. See @ref{Literal Objects in Compiled Files}. @IGindex simple @item @b{simple} @i{adj.} 1. (of an @i{array}) being of @i{type} @b{simple-array}. 2. (of a @i{character}) having no @i{implementation-defined} @i{attributes}, or else having @i{implementation-defined} @i{attributes} each of which has the @i{null} value for that @i{attribute}. @IGindex simple array @item @b{simple array} @i{n.} an @i{array} of @i{type} @b{simple-array}. @IGindex simple bit array @item @b{simple bit array} @i{n.} a @i{bit array} that is a @i{simple array}; that is, an @i{object} of @i{type} @t{(simple-array bit)}. @IGindex simple bit vector @item @b{simple bit vector} @i{n.} a @i{bit vector} of @i{type} @b{simple-bit-vector}. @IGindex simple condition @item @b{simple condition} @i{n.} a @i{condition} of @i{type} @b{simple-condition}. @IGindex simple general vector @item @b{simple general vector} @i{n.} a @i{simple vector}. @IGindex simple string @item @b{simple string} @i{n.} a @i{string} of @i{type} @b{simple-string}. @IGindex simple vector @item @b{simple vector} @i{n.} a @i{vector} of @i{type} @b{simple-vector}, sometimes called a ``@i{simple general vector}.'' Not all @i{vectors} that are @i{simple} are @i{simple vectors}---only those that have @i{element type} @b{t}. @IGindex single escape @item @b{single escape} @i{n.}, @i{adj.} 1. @i{n.} the @i{syntax type} of a @i{character} that indicates that the next @i{character} is to be treated as an @i{alphabetic}_2 @i{character} with its @i{case} preserved. For details, see @ref{Single Escape Character}. 2. @i{adj.} (of a @i{character}) having the @i{single escape} @i{syntax type}. 3. @i{n.} a @i{single escape}_2 @i{character}. (In the @i{standard readtable}, @i{slash} is the only @i{single escape}.) @IGindex single float @item @b{single float} @i{n.} an @i{object} of @i{type} @b{single-float}. @IGindex single-quote @item @b{single-quote} @i{n.} the @i{standard character} that is variously called ``apostrophe,'' ``acute accent,'' ``quote,'' or ``single quote'' (@t{'}). See @i{Figure~2--5}. @IGindex singleton @item @b{singleton} @i{adj.} (of a @i{sequence}) having only one @i{element}. ``@t{(list 'hello)} returns a singleton list.'' @IGindex situation @item @b{situation} @i{n.} the @i{evaluation} of a @i{form} in a specific @i{environment}. @IGindex slash @item @b{slash} @i{n.} the @i{standard character} that is variously called ``solidus'' or ``slash'' (@t{/}). See @i{Figure~2--5}. @IGindex slot @item @b{slot} @i{n.} a component of an @i{object} that can store a @i{value}. @IGindex slot specifier @item @b{slot specifier} @i{n.} a representation of a @i{slot} that includes the @i{name} of the @i{slot} and zero or more @i{slot} options. A @i{slot} option pertains only to a single @i{slot}. @IGindex source code @item @b{source code} @i{n.} @i{code} representing @i{objects} suitable for @i{evaluation} (@i{e.g.}, @i{objects} created by @b{read}, by @i{macro expansion}, or by @i{compiler macro expansion}). @IGindex source file @item @b{source file} @i{n.} a @i{file} which contains a textual representation of @i{source code}, that can be edited, @i{loaded}, or @i{compiled}. @IGindex space @item @b{space} @i{n.} the @i{standard character} <@i{Space}>, notated for the @i{Lisp reader} as @t{#\Space}. @IGindex special form @item @b{special form} @i{n.} a @i{list}, other than a @i{macro form}, which is a @i{form} with special syntax or special @i{evaluation} rules or both, possibly manipulating the @i{evaluation} @i{environment} or control flow or both. The first element of a @i{special form} is a @i{special operator}. @IGindex special operator @item @b{special operator} @i{n.} one of a fixed set of @i{symbols}, enumerated in @i{Figure~3--2}, that may appear in the @i{car} of a @i{form} in order to identify the @i{form} as a @i{special form}. @IGindex special variable @item @b{special variable} @i{n.} @i{Trad.} a @i{dynamic variable}. @IGindex specialize @item @b{specialize} @i{v.t.} (a @i{generic function}) to define a @i{method} for the @i{generic function}, or in other words, to refine the behavior of the @i{generic function} by giving it a specific meaning for a particular set of @i{classes} or @i{arguments}. @IGindex specialized @item @b{specialized} @i{adj.} 1. (of a @i{generic function}) having @i{methods} which @i{specialize} the @i{generic function}. 2. (of an @i{array}) having an @i{actual array element type} that is a @i{proper subtype} of the @i{type} @b{t}; see @ref{Array Elements}. ``@t{(make-array 5 :element-type 'bit)} makes an array of length five that is specialized for bits.'' @IGindex specialized lambda list @item @b{specialized lambda list} @i{n.} an @i{extended lambda list} used in @i{forms} that @i{establish} @i{method} definitions, such as @b{defmethod}. See @ref{Specialized Lambda Lists}. @IGindex spreadable argument list designator @item @b{spreadable argument list designator} @i{n.} a @i{designator} for a @i{list} of @i{objects}; that is, an @i{object} that denotes a @i{list} and that is a @i{non-null} @i{list} L1 of length n, whose last element is a @i{list} L2 of length m (denoting a list L3 of length m+n-1 whose @i{elements} are L1_i for i < n-1 followed by L2_j for j < m). ``The list (1 2 (3 4 5)) is a spreadable argument list designator for the list (1 2 3 4 5).'' @IGindex stack allocate @item @b{stack allocate} @i{v.t.} @i{Trad.} to allocate in a non-permanent way, such as on a stack. Stack-allocation is an optimization technique used in some @i{implementations} for allocating certain kinds of @i{objects} that have @i{dynamic extent}. Such @i{objects} are allocated on the stack rather than in the heap so that their storage can be freed as part of unwinding the stack rather than taking up space in the heap until the next garbage collection. What @i{types} (if any) can have @i{dynamic extent} can vary from @i{implementation} to @i{implementation}. No @i{implementation} is ever required to perform stack-allocation. @IGindex stack-allocated @item @b{stack-allocated} @i{adj.} @i{Trad.} having been @i{stack allocated}. @IGindex standard character @item @b{standard character} @i{n.} a @i{character} of @i{type} @b{standard-char}, which is one of a fixed set of 96 such @i{characters} required to be present in all @i{conforming implementations}. See @ref{Standard Characters}. @IGindex standard class @item @b{standard class} @i{n.} a @i{class} that is a @i{generalized instance} of @i{class} @b{standard-class}. @IGindex standard generic function @item @b{standard generic function} a @i{function} of @i{type} @b{standard-generic-function}. @IGindex standard input @item @b{standard input} @i{n.} the @i{input} @i{stream} which is the @i{value} of the @i{dynamic variable} @b{*standard-input*}. @IGindex standard method combination @item @b{standard method combination} @i{n.} the @i{method combination} named @b{standard}. @IGindex standard object @item @b{standard object} @i{n.} an @i{object} that is a @i{generalized instance} of @i{class} @b{standard-object}. @IGindex standard output @item @b{standard output} @i{n.} the @i{output} @i{stream} which is the @i{value} of the @i{dynamic variable} @b{*standard-output*}. @IGindex standard pprint dispatch table @item @b{standard pprint dispatch table} @i{n.} A @i{pprint dispatch table} that is @i{different} from the @i{initial pprint dispatch table}, that implements @i{pretty printing} as described in this specification, and that, unlike other @i{pprint dispatch tables}, must never be modified by any program. (Although the definite reference ``the @i{standard pprint dispatch table}'' is generally used within this document, it is actually @i{implementation-dependent} whether a single @i{object} fills the role of the @i{standard pprint dispatch table}, or whether there might be multiple such objects, any one of which could be used on any given occasion where ``the @i{standard pprint dispatch table}'' is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.) @IGindex standard readtable @item @b{standard readtable} @i{n.} A @i{readtable} that is @i{different} from the @i{initial readtable}, that implements the @i{expression} syntax defined in this specification, and that, unlike other @i{readtables}, must never be modified by any program. (Although the definite reference ``the @i{standard readtable}'' is generally used within this document, it is actually @i{implementation-dependent} whether a single @i{object} fills the role of the @i{standard readtable}, or whether there might be multiple such objects, any one of which could be used on any given occasion where ``the @i{standard readtable}'' is called for. As such, this phrase should be seen as an indefinite reference in all cases except for anaphoric references.) @IGindex standard syntax @item @b{standard syntax} @i{n.} the syntax represented by the @i{standard readtable} and used as a reference syntax throughout this document. See @ref{Character Syntax}. @IGindex standardized @item @b{standardized} @i{adj.} (of a @i{name}, @i{object}, or definition) having been defined by @r{Common Lisp}. ``All standardized variables that are required to hold bidirectional streams have ``@t{-io*}'' in their name.'' @IGindex startup environment @item @b{startup environment} @i{n.} the @i{global environment} of the running @i{Lisp image} from which the @i{compiler} was invoked. @IGindex step @item @b{step} @i{v.t.}, @i{n.} 1. @i{v.t.} (an iteration @i{variable}) to @i{assign} the @i{variable} a new @i{value} at the end of an iteration, in preparation for a new iteration. 2. @i{n.} the @i{code} that identifies how the next value in an iteration is to be computed. 3. @i{v.t.} (@i{code}) to specially execute the @i{code}, pausing at intervals to allow user confirmation or intervention, usually for debugging. @IGindex stream @item @b{stream} @i{n.} an @i{object} that can be used with an input or output function to identify an appropriate source or sink of @i{characters} or @i{bytes} for that operation. @IGindex stream associated with a file @item @b{stream associated with a file} @i{n.} a @i{file stream}, or a @i{synonym stream} the @i{target} of which is a @i{stream associated with a file}. Such a @i{stream} cannot be created with @b{make-two-way-stream}, @b{make-echo-stream}, @b{make-broadcast-stream}, @b{make-concatenated-stream}, @b{make-string-input-stream}, or @b{make-string-output-stream}. @IGindex stream designator @item @b{stream designator} @i{n.} a @i{designator} for a @i{stream}; that is, an @i{object} that denotes a @i{stream} and that is one of: @b{t} (denoting the @i{value} of @b{*terminal-io*}), @b{nil} (denoting the @i{value} of @b{*standard-input*} for @i{input} @i{stream designators} or denoting the @i{value} of @b{*standard-output*} for @i{output} @i{stream designators}), or a @i{stream} (denoting itself). @IGindex stream element type @item @b{stream element type} @i{n.} (of a @i{stream}) the @i{type} of data for which the @i{stream} is specialized. @IGindex stream variable @item @b{stream variable} @i{n.} a @i{variable} whose @i{value} must be a @i{stream}. @IGindex stream variable designator @item @b{stream variable designator} @i{n.} a @i{designator} for a @i{stream variable}; that is, a @i{symbol} that denotes a @i{stream variable} and that is one of: @b{t} (denoting @b{*terminal-io*}), @b{nil} (denoting @b{*standard-input*} for @i{input} @i{stream variable designators} or denoting @b{*standard-output*} for @i{output} @i{stream variable designators}), or some other @i{symbol} (denoting itself). @IGindex string @item @b{string} @i{n.} a specialized @i{vector} that is of @i{type} @b{string}, and whose elements are of @i{type} @b{character} or a @i{subtype} of @i{type} @b{character}. @IGindex string designator @item @b{string designator} @i{n.} a @i{designator} for a @i{string}; that is, an @i{object} that denotes a @i{string} and that is one of: a @i{character} (denoting a @i{singleton} @i{string} that has the @i{character} as its only @i{element}), a @i{symbol} (denoting the @i{string} that is its @i{name}), or a @i{string} (denoting itself). The intent is that this term be consistent with the behavior of @b{string}; @i{implementations} that extend @b{string} must extend the meaning of this term in a compatible way. @IGindex string equal @item @b{string equal} @i{adj.} the @i{same} under @b{string-equal}. @IGindex string stream @item @b{string stream} @i{n.} a @i{stream} of @i{type} @b{string-stream}. @IGindex structure @item @b{structure} @i{n.} an @i{object} of @i{type} @b{structure-object}. @IGindex structure class @item @b{structure class} @i{n.} a @i{class} that is a @i{generalized instance} of @i{class} @b{structure-class}. @IGindex structure name @item @b{structure name} @i{n.} a @i{name} defined with @b{defstruct}. Usually, such a @i{type} is also a @i{structure class}, but there may be @i{implementation-dependent} situations in which this is not so, if the @t{:type} option to @b{defstruct} is used. @IGindex style warning @item @b{style warning} @i{n.} a @i{condition} of @i{type} @b{style-warning}. @IGindex subclass @item @b{subclass} @i{n.} a @i{class} that @i{inherits} from another @i{class}, called a @i{superclass}. (No @i{class} is a @i{subclass} of itself.) @IGindex subexpression @item @b{subexpression} @i{n.} (of an @i{expression}) an @i{expression} that is contained within the @i{expression}. (In fact, the state of being a @i{subexpression} is not an attribute of the @i{subexpression}, but really an attribute of the containing @i{expression} since the @i{same} @i{object} can at once be a @i{subexpression} in one context, and not in another.) @IGindex subform @item @b{subform} @i{n.} (of a @i{form}) an @i{expression} that is a @i{subexpression} of the @i{form}, and which by virtue of its position in that @i{form} is also a @i{form}. ``@t{(f x)} and @t{x}, but not @t{exit}, are subforms of @t{(return-from exit (f x))}.'' @IGindex subrepertoire @item @b{subrepertoire} @i{n.} a subset of a @i{repertoire}. @IGindex subtype @item @b{subtype} @i{n.} a @i{type} whose membership is the same as or a proper subset of the membership of another @i{type}, called a @i{supertype}. (Every @i{type} is a @i{subtype} of itself.) @IGindex superclass @item @b{superclass} @i{n.} a @i{class} from which another @i{class} (called a @i{subclass}) @i{inherits}. (No @i{class} is a @i{superclass} of itself.) See @i{subclass}. @IGindex supertype @item @b{supertype} @i{n.} a @i{type} whose membership is the same as or a proper superset of the membership of another @i{type}, called a @i{subtype}. (Every @i{type} is a @i{supertype} of itself.) See @i{subtype}. @IGindex supplied-p parameter @item @b{supplied-p parameter} @i{n.} a @i{parameter} which recieves its @i{generalized boolean} value implicitly due to the presence or absence of an @i{argument} corresponding to another @i{parameter} (such as an @i{optional parameter} or a @i{rest parameter}). See @ref{Ordinary Lambda Lists}. @IGindex symbol @item @b{symbol} @i{n.} an @i{object} of @i{type} @b{symbol}. @IGindex symbol macro @item @b{symbol macro} @i{n.} a @i{symbol} that stands for another @i{form}. See the @i{macro} @b{symbol-macrolet}. @IGindex synonym stream @item @b{synonym stream} @i{n.} 1. a @i{stream} of @i{type} @b{synonym-stream}, which is consequently a @i{stream} that is an alias for another @i{stream}, which is the @i{value} of a @i{dynamic variable} whose @i{name} is the @i{synonym stream symbol} of the @i{synonym stream}. See the @i{function} @b{make-synonym-stream}. 2. (to a @i{stream}) a @i{synonym stream} which has the @i{stream} as the @i{value} of its @i{synonym stream symbol}. 3. (to a @i{symbol}) a @i{synonym stream} which has the @i{symbol} as its @i{synonym stream symbol}. @IGindex synonym stream symbol @item @b{synonym stream symbol} @i{n.} (of a @i{synonym stream}) the @i{symbol} which names the @i{dynamic variable} which has as its @i{value} another @i{stream} for which the @i{synonym stream} is an alias. @IGindex syntax type @item @b{syntax type} @i{n.} (of a @i{character}) one of several classifications, enumerated in @i{Figure~2--6}, that are used for dispatch during parsing by the @i{Lisp reader}. See @ref{Character Syntax Types}. @IGindex system class @item @b{system class} @i{n.} a @i{class} that may be of @i{type} @b{built-in-class} in a @i{conforming implementation} and hence cannot be inherited by @i{classes} defined by @i{conforming programs}. @IGindex system code @item @b{system code} @i{n.} @i{code} supplied by the @i{implementation} to implement this specification (@i{e.g.}, the definition of @b{mapcar}) or generated automatically in support of this specification (@i{e.g.}, during method combination); that is, @i{code} that is not @i{programmer code}. @end table @subheading @b{T} @table @asis @IGindex t @item @b{t} @i{n.} 1. a. the @i{boolean} representing true. b. the canonical @i{generalized boolean} representing true. (Although any @i{object} other than @b{nil} is considered @i{true} as a @i{generalized boolean}, @t{t} is generally used when there is no special reason to prefer one such @i{object} over another.) 2. the @i{name} of the @i{type} to which all @i{objects} belong---the @i{supertype} of all @i{types} (including itself). 3. the @i{name} of the @i{superclass} of all @i{classes} except itself. @IGindex tag @item @b{tag} @i{n.} 1. a @i{catch tag}. 2. a @i{go tag}. @IGindex tail @item @b{tail} @i{n.} (of a @i{list}) an @i{object} that is the @i{same} as either some @i{cons} which makes up that @i{list} or the @i{atom} (if any) which terminates the @i{list}. ``The empty list is a tail of every proper list.'' @IGindex target @item @b{target} @i{n.} 1. (of a @i{constructed stream}) a @i{constituent} of the @i{constructed stream}. ``The target of a synonym stream is the value of its synonym stream symbol.'' 2. (of a @i{displaced array}) the @i{array} to which the @i{displaced array} is displaced. (In the case of a chain of @i{constructed streams} or @i{displaced arrays}, the unqualified term ``@i{target}'' always refers to the immediate @i{target} of the first item in the chain, not the immediate target of the last item.) @IGindex terminal I/O @item @b{terminal I/O} @i{n.} the @i{bidirectional} @i{stream} that is the @i{value} of the @i{variable} @b{*terminal-io*}. @IGindex terminating @item @b{terminating} @i{n.} (of a @i{macro character}) being such that, if it appears while parsing a token, it terminates that token. See @ref{Reader Algorithm}. @IGindex tertiary value @item @b{tertiary value} @i{n.} (of @i{values} resulting from the @i{evaluation} of a @i{form}) the third @i{value}, if any, or else @b{nil} if there are fewer than three @i{values}. @IGindex throw @item @b{throw} @i{v.} to transfer control and @i{values} to a @i{catch}. See the @i{special operator} @b{throw}. @IGindex tilde @item @b{tilde} @i{n.} the @i{standard character} that is called ``tilde'' (@t{~}). See @i{Figure~2--5}. @IGindex time @item @b{time} a representation of a point (@i{absolute} @i{time}) or an interval (@i{relative} @i{time}) on a time line. See @i{decoded time}, @i{internal time}, and @i{universal time}. @IGindex time zone @item @b{time zone} @i{n.} a @i{rational} multiple of @t{1/3600} between @t{-24} (inclusive) and @t{24} (inclusive) that represents a time zone as a number of hours offset from Greenwich Mean Time. Time zone values increase with motion to the west, so Massachusetts, U.S.A. is in time zone @t{5}, California, U.S.A. is time zone @t{8}, and Moscow, Russia is time zone @i{-3}. (When ``daylight savings time'' is separately represented as an @i{argument} or @i{return value}, the @i{time zone} that accompanies it does not depend on whether daylight savings time is in effect.) @IGindex token @item @b{token} @i{n.} a textual representation for a @i{number} or a @i{symbol}. See @ref{Interpretation of Tokens}. @IGindex top level form @item @b{top level form} @i{n.} a @i{form} which is processed specially by @b{compile-file} for the purposes of enabling @i{compile time} @i{evaluation} of that @i{form}. @i{Top level forms} include those @i{forms} which are not @i{subforms} of any other @i{form}, and certain other cases. See @ref{Processing of Top Level Forms}. @IGindex trace output @item @b{trace output} @i{n.} the @i{output} @i{stream} which is the @i{value} of the @i{dynamic variable} @b{*trace-output*}. @IGindex tree @item @b{tree} @i{n.} 1. a binary recursive data structure made up of @i{conses} and @i{atoms}: the @i{conses} are themselves also @i{trees} (sometimes called ``subtrees'' or ``branches''), and the @i{atoms} are terminal nodes (sometimes called @i{leaves}). Typically, the @i{leaves} represent data while the branches establish some relationship among that data. 2. in general, any recursive data structure that has some notion of ``branches'' and @i{leaves}. @IGindex tree structure @item @b{tree structure} @i{n.} (of a @i{tree}_1) the set of @i{conses} that make up the @i{tree}. Note that while the @i{car}_@{1b@} component of each such @i{cons} is part of the @i{tree structure}, the @i{objects} that are the @i{cars}_2 of each @i{cons} in the @i{tree} are not themselves part of its @i{tree structure} unless they are also @i{conses}. @IGindex true @item @b{true} @i{n.} any @i{object} that is not @i{false} and that is used to represent the success of a @i{predicate} test. See @i{t}_1. @IGindex truename @item @b{truename} @i{n.} 1. the canonical @i{filename} of a @i{file} in the @i{file system}. See @ref{Truenames}. 2. a @i{pathname} representing a @i{truename}_1. @IGindex two-way stream @item @b{two-way stream} @i{n.} a @i{stream} of @i{type} @b{two-way-stream}, which is a @i{bidirectional} @i{composite stream} that receives its input from an associated @i{input} @i{stream} and sends its output to an associated @i{output} @i{stream}. @IGindex type @item @b{type} @i{n.} 1. a set of @i{objects}, usually with common structure, behavior, or purpose. (Note that the expression ``@i{X} is of type @i{S_a}'' naturally implies that ``@i{X} is of type @i{S_b}'' if @i{S_a} is a @i{subtype} of @i{S_b}.) 2. (immediately following the name of a @i{type}) a @i{subtype} of that @i{type}. ``The type @b{vector} is an array type.'' @IGindex type declaration @item @b{type declaration} @i{n.} a @i{declaration} that asserts that every reference to a specified @i{binding} within the scope of the @i{declaration} results in some @i{object} of the specified @i{type}. @IGindex type equivalent @item @b{type equivalent} @i{adj.} (of two @i{types} X and Y) having the same @i{elements}; that is, X is a @i{subtype} of Y and Y is a @i{subtype} of X. @IGindex type expand @item @b{type expand} @i{n.} to fully expand a @i{type specifier}, removing any references to @i{derived types}. (@r{Common Lisp} provides no program interface to cause this to occur, but the semantics of @r{Common Lisp} are such that every @i{implementation} must be able to do this internally, and some situations involving @i{type specifiers} are most easily described in terms of a fully expanded @i{type specifier}.) @IGindex type specifier @item @b{type specifier} @i{n.} an @i{expression} that denotes a @i{type}. ``The symbol @t{random-state}, the list @t{(integer 3 5)}, the list @t{(and list (not null))}, and the class named @t{standard-class} are type specifiers.'' @end table @subheading @b{U} @table @asis @IGindex unbound @item @b{unbound} @i{adj.} not having an associated denotation in a @i{binding}. See @i{bound}. @IGindex unbound variable @item @b{unbound variable} @i{n.} a @i{name} that is syntactically plausible as the name of a @i{variable} but which is not @i{bound} in the @i{variable} @i{namespace}. @IGindex undefined function @item @b{undefined function} @i{n.} a @i{name} that is syntactically plausible as the name of a @i{function} but which is not @i{bound} in the @i{function} @i{namespace}. @IGindex unintern @item @b{unintern} @i{v.t.} (a @i{symbol} in a @i{package}) to make the @i{symbol} not be @i{present} in that @i{package}. (The @i{symbol} might continue to be @i{accessible} by inheritance.) @IGindex uninterned @item @b{uninterned} @i{adj.} (of a @i{symbol}) not @i{accessible} in any @i{package}; @i{i.e.}, not @i{interned}_1. @IGindex universal time @item @b{universal time} @i{n.} @i{time}, represented as a non-negative @i{integer} number of seconds. @i{Absolute} @i{universal time} is measured as an offset from the beginning of the year 1900 (ignoring @i{leap seconds}). See @ref{Universal Time}. @IGindex unqualified method @item @b{unqualified method} @i{n.} a @i{method} with no @i{qualifiers}. @IGindex unregistered package @item @b{unregistered package} @i{n.} a @i{package} @i{object} that is not present in the @i{package registry}. An @i{unregistered package} has no @i{name}; @i{i.e.}, its @i{name} is @b{nil}. See the @i{function} @b{delete-package}. @IGindex unsafe @item @b{unsafe} @i{adj.} (of @i{code}) not @i{safe}. (Note that, unless explicitly specified otherwise, if a particular kind of error checking is guaranteed only in a @i{safe} context, the same checking might or might not occur in that context if it were @i{unsafe}; describing a context as @i{unsafe} means that certain kinds of error checking are not reliably enabled but does not guarantee that error checking is definitely disabled.) @IGindex unsafe call @item @b{unsafe call} @i{n.} a @i{call} that is not a @i{safe call}. For more detailed information, see @ref{Safe and Unsafe Calls}. @IGindex upgrade @item @b{upgrade} @i{v.t.} (a declared @i{type} to an actual @i{type}) 1. (when creating an @i{array}) to substitute an @i{actual array element type} for an @i{expressed array element type} when choosing an appropriately @i{specialized} @i{array} representation. See the @i{function} @b{upgraded-array-element-type}. 2. (when creating a @i{complex}) to substitute an @i{actual complex part type} for an @i{expressed complex part type} when choosing an appropriately @i{specialized} @i{complex} representation. See the @i{function} @b{upgraded-complex-part-type}. @IGindex upgraded array element type @item @b{upgraded array element type} @i{n.} (of a @i{type}) a @i{type} that is a @i{supertype} of the @i{type} and that is used instead of the @i{type} whenever the @i{type} is used as an @i{array element type} for object creation or type discrimination. See @ref{Array Upgrading}. @IGindex upgraded complex part type @item @b{upgraded complex part type} @i{n.} (of a @i{type}) a @i{type} that is a @i{supertype} of the @i{type} and that is used instead of the @i{type} whenever the @i{type} is used as a @i{complex part type} for object creation or type discrimination. See the @i{function} @b{upgraded-complex-part-type}. @IGindex uppercase @item @b{uppercase} @i{adj.} (of a @i{character}) being among @i{standard characters} corresponding to the capital letters @t{A} through @t{Z}, or being some other @i{implementation-defined} @i{character} that is defined by the @i{implementation} to be @i{uppercase}. See @ref{Characters With Case}. @IGindex use @item @b{use} @i{v.t.} (a @i{package} P_1) to @i{inherit} the @i{external symbols} of P_1. (If a package P_2 uses P_1, the @i{external symbols} of P_1 become @i{internal symbols} of P_2 unless they are explicitly @i{exported}.) ``The package @t{CL-USER} uses the package @t{CL}.'' @IGindex use list @item @b{use list} @i{n.} (of a @i{package}) a (possibly empty) @i{list} associated with each @i{package} which determines what other @i{packages} are currently being @i{used} by that @i{package}. @IGindex user @item @b{user} @i{n.} an active entity, typically a human, that invokes or interacts with a @i{program} at run time, but that is not necessarily a @i{programmer}. @end table @subheading @b{V} @table @asis @IGindex valid array dimension @item @b{valid array dimension} @i{n.} a @i{fixnum} suitable for use as an @i{array} @i{dimension}. Such a @i{fixnum} must be greater than or equal to zero, and less than the @i{value} of @b{array-dimension-limit}. When multiple @i{array} @i{dimensions} are to be used together to specify a multi-dimensional @i{array}, there is also an implied constraint that the product of all of the @i{dimensions} be less than the @i{value} of @b{array-total-size-limit}. @IGindex valid array index @item @b{valid array index} @i{n.} (of an @i{array}) a @i{fixnum} suitable for use as one of possibly several indices needed to name an @i{element} of the @i{array} according to a multi-dimensional Cartesian coordinate system. Such a @i{fixnum} must be greater than or equal to zero, and must be less than the corresponding @i{dimension}_1 of the @i{array}. (Unless otherwise explicitly specified, the phrase ``a @i{list} of @i{valid array indices}'' further implies that the @i{length} of the @i{list} must be the same as the @i{rank} of the @i{array}.) ``For a @t{2} by~@t{3} array, valid array indices for the first dimension are @t{0} and~@t{1}, and valid array indices for the second dimension are @t{0}, @t{1} and~@t{2}.'' @IGindex valid array row-major index @item @b{valid array row-major index} @i{n.} (of an @i{array}, which might have any number of @i{dimensions}_2) a single @i{fixnum} suitable for use in naming any @i{element} of the @i{array}, by viewing the array's storage as a linear series of @i{elements} in row-major order. Such a @i{fixnum} must be greater than or equal to zero, and less than the @i{array total size} of the @i{array}. @IGindex valid fill pointer @item @b{valid fill pointer} @i{n.} (of an @i{array}) a @i{fixnum} suitable for use as a @i{fill pointer} for the @i{array}. Such a @i{fixnum} must be greater than or equal to zero, and less than or equal to the @i{array total size} of the @i{array}. [Editorial Note by KMP: The ``valid pathname xxx'' definitions were taken from text found in make-pathname, but look wrong to me. I'll fix them later.] @IGindex valid logical pathname host @item @b{valid logical pathname host} @i{n.} a @i{string} that has been defined as the name of a @i{logical host}. See the @i{function} @b{load-logical-pathname-translations}. @IGindex valid pathname device @item @b{valid pathname device} @i{n.} a @i{string}, @b{nil}, @t{:unspecific}, or some other @i{object} defined by the @i{implementation} to be a @i{valid pathname device}. @IGindex valid pathname directory @item @b{valid pathname directory} @i{n.} a @i{string}, a @i{list} of @i{strings}, @b{nil}, @t{:wild}, @t{:unspecific}, or some other @i{object} defined by the @i{implementation} to be a @i{valid directory component}. @IGindex valid pathname host @item @b{valid pathname host} @i{n.} a @i{valid physical pathname host} or a @i{valid logical pathname host}. @IGindex valid pathname name @item @b{valid pathname name} @i{n.} a @i{string}, @b{nil}, @t{:wild}, @t{:unspecific}, or some other @i{object} defined by the @i{implementation} to be a @i{valid pathname name}. @IGindex valid pathname type @item @b{valid pathname type} @i{n.} a @i{string}, @b{nil}, @t{:wild}, @t{:unspecific}. @IGindex valid pathname version @item @b{valid pathname version} @i{n.} a non-negative @i{integer}, or one of @t{:wild}, @t{:newest}, @t{:unspecific}, or @b{nil}. The symbols @t{:oldest}, @t{:previous}, and @t{:installed} are @i{semi-standard} special version symbols. @IGindex valid physical pathname host @item @b{valid physical pathname host} @i{n.} any of a @i{string}, a @i{list} of @i{strings}, or the symbol @t{:unspecific}, that is recognized by the implementation as the name of a host. @IGindex valid sequence index @item @b{valid sequence index} @i{n.} (of a @i{sequence}) an @i{integer} suitable for use to name an @i{element} of the @i{sequence}. Such an @i{integer} must be greater than or equal to zero, and must be less than the @i{length} of the @i{sequence}. (If the @i{sequence} is an @i{array}, the @i{valid sequence index} is further constrained to be a @i{fixnum}.) @IGindex value @item @b{value} @i{n.} 1. a. one of possibly several @i{objects} that are the result of an @i{evaluation}. b. (in a situation where exactly one value is expected from the @i{evaluation} of a @i{form}) the @i{primary value} returned by the @i{form}. c. (of @i{forms} in an @i{implicit progn}) one of possibly several @i{objects} that result from the @i{evaluation} of the last @i{form}, or @b{nil} if there are no @i{forms}. 2. an @i{object} associated with a @i{name} in a @i{binding}. 3. (of a @i{symbol}) the @i{value} of the @i{dynamic variable} named by that symbol. 4. an @i{object} associated with a @i{key} in an @i{association list}, a @i{property list}, or a @i{hash table}. @IGindex value cell @item @b{value cell} @i{n.} @i{Trad.} (of a @i{symbol}) The @i{place} which holds the @i{value}, if any, of the @i{dynamic variable} named by that @i{symbol}, and which is @i{accessed} by @b{symbol-value}. See @i{cell}. @IGindex variable @item @b{variable} @i{n.} a @i{binding} in which a @i{symbol} is the @i{name} used to refer to an @i{object}. @IGindex vector @item @b{vector} @i{n.} a one-dimensional @i{array}. @IGindex vertical-bar @item @b{vertical-bar} @i{n.} the @i{standard character} that is called ``vertical bar'' (@t{|}). See @i{Figure~2--5}. @end table @subheading @b{W} @table @asis @IGindex whitespace @item @b{whitespace} @i{n.} 1. one or more @i{characters} that are either the @i{graphic} @i{character} @t{#\Space} or else @i{non-graphic} characters such as @t{#\Newline} that only move the print position. 2. a. @i{n.} the @i{syntax type} of a @i{character} that is a @i{token} separator. For details, see @ref{Whitespace Characters}. b. @i{adj.} (of a @i{character}) having the @i{whitespace}_@{2a@} @i{syntax type}_2. c. @i{n.} a @i{whitespace}_@{2b@} @i{character}. @IGindex wild @item @b{wild} @i{adj.} 1. (of a @i{namestring}) using an @i{implementation-defined} syntax for naming files, which might ``match'' any of possibly several possible @i{filenames}, and which can therefore be used to refer to the aggregate of the @i{files} named by those @i{filenames}. 2. (of a @i{pathname}) a structured representation of a name which might ``match'' any of possibly several @i{pathnames}, and which can therefore be used to refer to the aggregate of the @i{files} named by those @i{pathnames}. The set of @i{wild} @i{pathnames} includes, but is not restricted to, @i{pathnames} which have a component which is @t{:wild}, or which have a directory component which contains @t{:wild} or @t{:wild-inferors}. See the @i{function} @b{wild-pathname-p}. @IGindex write @item @b{write} @i{v.t.} 1. (a @i{binding} or @i{slot} or component) to change the @i{value} of the @i{binding} or @i{slot}. 2. (an @i{object} to a @i{stream}) to output a representation of the @i{object} to the @i{stream}. @IGindex writer @item @b{writer} @i{n.} a @i{function} that @i{writes}_1 a @i{variable} or @i{slot}. @end table @subheading @b{Y} @table @asis @IGindex yield @item @b{yield} @i{v.t.} (@i{values}) to produce the @i{values} as the result of @i{evaluation}. ``The form @t{(+ 2 3)} yields @t{5}.'' @end table @c @end table @c end of including concept-glossary @c %**end of chapter gcl-2.6.14/info/chap-21.texi0000644000175000017500000033611214360276512013762 0ustar cammcamm @node Streams, Printer, Files, Top @chapter Streams @menu * Stream Concepts:: * Streams Dictionary:: @end menu @node Stream Concepts, Streams Dictionary, Streams, Streams @section Stream Concepts @c including concept-streams @menu * Introduction to Streams:: * Stream Variables:: * Stream Arguments to Standardized Functions:: * Restrictions on Composite Streams:: @end menu @node Introduction to Streams, Stream Variables, Stream Concepts, Stream Concepts @subsection Introduction to Streams A @i{stream} @IGindex stream is an @i{object} that can be used with an input or output function to identify an appropriate source or sink of @i{characters} or @i{bytes} for that operation. A @i{character} @IGindex character @i{stream} @IGindex stream is a source or sink of @i{characters}. A @i{binary} @IGindex binary @i{stream} @IGindex stream is a source or sink of @i{bytes}. Some operations may be performed on any kind of @i{stream}; Figure 21--1 provides a list of @i{standardized} operations that are potentially useful with any kind of @i{stream}. @format @group @noindent @w{ close stream-element-type } @w{ input-stream-p streamp } @w{ interactive-stream-p with-open-stream } @w{ output-stream-p } @noindent @w{ Figure 21--1: Some General-Purpose Stream Operations} @end group @end format Other operations are only meaningful on certain @i{stream} @i{types}. For example, @b{read-char} is only defined for @i{character} @i{streams} and @b{read-byte} is only defined for @i{binary} @i{streams}. @menu * Abstract Classifications of Streams (Introduction to Streams):: * Input:: * Open and Closed Streams:: * Interactive Streams:: * Abstract Classifications of Streams:: * File Streams:: * Other Subclasses of Stream:: @end menu @node Abstract Classifications of Streams (Introduction to Streams), Input, Introduction to Streams, Introduction to Streams @subsubsection Abstract Classifications of Streams @node Input, Open and Closed Streams, Abstract Classifications of Streams (Introduction to Streams), Introduction to Streams @subsubsection Input, Output, and Bidirectional Streams A @i{stream}, whether a @i{character} @i{stream} or a @i{binary} @i{stream}, can be an @i{input} @IGindex input @i{stream} @IGindex stream (source of data), an @i{output} @IGindex output @i{stream} @IGindex stream (sink for data), both, or (@i{e.g.}, when ``@t{:direction :probe}'' is given to @b{open}) neither. Figure 21--2 shows @i{operators} relating to @i{input} @i{streams}. @format @group @noindent @w{ clear-input read-byte read-from-string } @w{ listen read-char read-line } @w{ peek-char read-char-no-hang read-preserving-whitespace } @w{ read read-delimited-list unread-char } @noindent @w{ Figure 21--2: Operators relating to Input Streams. } @end group @end format Figure 21--3 shows @i{operators} relating to @i{output} @i{streams}. @format @group @noindent @w{ clear-output prin1 write } @w{ finish-output prin1-to-string write-byte } @w{ force-output princ write-char } @w{ format princ-to-string write-line } @w{ fresh-line print write-string } @w{ pprint terpri write-to-string } @noindent @w{ Figure 21--3: Operators relating to Output Streams.} @end group @end format A @i{stream} that is both an @i{input} @i{stream} and an @i{output} @i{stream} is called a @i{bidirectional} @IGindex bidirectional @i{stream} @IGindex stream . See the @i{functions} @b{input-stream-p} and @b{output-stream-p}. Any of the @i{operators} listed in @i{Figure~21--2} or @i{Figure~21--3} can be used with @i{bidirectional} @i{streams}. In addition, Figure 21--4 shows a list of @i{operators} that relate specificaly to @i{bidirectional} @i{streams}. @format @group @noindent @w{ y-or-n-p yes-or-no-p } @noindent @w{ Figure 21--4: Operators relating to Bidirectional Streams.} @end group @end format @node Open and Closed Streams, Interactive Streams, Input, Introduction to Streams @subsubsection Open and Closed Streams @i{Streams} are either @i{open} @IGindex open or @i{closed} @IGindex closed . Except as explicitly specified otherwise, operations that create and return @i{streams} return @i{open} @i{streams}. The action of @i{closing} a @i{stream} marks the end of its use as a source or sink of data, permitting the @i{implementation} to reclaim its internal data structures, and to free any external resources which might have been locked by the @i{stream} when it was opened. Except as explicitly specified otherwise, the consequences are undefined when a @i{closed} @i{stream} is used where a @i{stream} is called for. Coercion of @i{streams} to @i{pathnames} is permissible for @i{closed} @i{streams}; in some situations, such as for a @i{truename} computation, the result might be different for an @i{open} @i{stream} and for that same @i{stream} once it has been @i{closed}. @node Interactive Streams, Abstract Classifications of Streams, Open and Closed Streams, Introduction to Streams @subsubsection Interactive Streams An @i{interactive stream} @IGindex interactive stream is one on which it makes sense to perform interactive querying. The precise meaning of an @i{interactive stream} is @i{implementation-defined}, and may depend on the underlying operating system. Some examples of the things that an @i{implementation} might choose to use as identifying characteristics of an @i{interactive stream} include: @table @asis @item @t{*} The @i{stream} is connected to a person (or equivalent) in such a way that the program can prompt for information and expect to receive different input depending on the prompt. @item @t{*} The program is expected to prompt for input and support ``normal input editing''. @item @t{*} @b{read-char} might wait for the user to type something before returning instead of immediately returning a character or end-of-file. @end table The general intent of having some @i{streams} be classified as @i{interactive streams} is to allow them to be distinguished from streams containing batch (or background or command-file) input. Output to batch streams is typically discarded or saved for later viewing, so interactive queries to such streams might not have the expected effect. @i{Terminal I/O} might or might not be an @i{interactive stream}. @node Abstract Classifications of Streams, File Streams, Interactive Streams, Introduction to Streams @subsubsection Abstract Classifications of Streams @node File Streams, Other Subclasses of Stream, Abstract Classifications of Streams, Introduction to Streams @subsubsection File Streams Some @i{streams}, called @i{file streams} @IGindex file stream , provide access to @i{files}. An @i{object} of @i{class} @b{file-stream} is used to represent a @i{file stream}. The basic operation for opening a @i{file} is @b{open}, which typically returns a @i{file stream} (see its dictionary entry for details). The basic operation for closing a @i{stream} is @b{close}. The macro @b{with-open-file} is useful to express the common idiom of opening a @i{file} for the duration of a given body of @i{code}, and assuring that the resulting @i{stream} is closed upon exit from that body. @node Other Subclasses of Stream, , File Streams, Introduction to Streams @subsubsection Other Subclasses of Stream The @i{class} @b{stream} has a number of @i{subclasses} defined by this specification. Figure 21--5 shows some information about these subclasses. @format @group @noindent @w{ Class Related Operators } @w{ @b{broadcast-stream} @b{make-broadcast-stream} } @w{ @b{broadcast-stream-streams} } @w{ @b{concatenated-stream} @b{make-concatenated-stream} } @w{ @b{concatenated-stream-streams} } @w{ @b{echo-stream} @b{make-echo-stream} } @w{ @b{echo-stream-input-stream} } @w{ @b{echo-stream-output-stream} } @w{ @b{string-stream} @b{make-string-input-stream} } @w{ @b{with-input-from-string} } @w{ @b{make-string-output-stream} } @w{ @b{with-output-to-string} } @w{ @b{get-output-stream-string} } @w{ @b{synonym-stream} @b{make-synonym-stream} } @w{ @b{synonym-stream-symbol} } @w{ @b{two-way-stream} @b{make-two-way-stream} } @w{ @b{two-way-stream-input-stream} } @w{ @b{two-way-stream-output-stream} } @noindent @w{ Figure 21--5: Defined Names related to Specialized Streams} @end group @end format @node Stream Variables, Stream Arguments to Standardized Functions, Introduction to Streams, Stream Concepts @subsection Stream Variables @i{Variables} whose @i{values} must be @i{streams} are sometimes called @i{stream variables} @IGindex stream variable . Certain @i{stream variables} are defined by this specification to be the proper source of input or output in various @i{situations} where no specific @i{stream} has been specified instead. A complete list of such @i{standardized} @i{stream variables} appears in Figure 21--6. The consequences are undefined if at any time the @i{value} of any of these @i{variables} is not an @i{open} @i{stream}. @format @group @noindent @w{ Glossary Term Variable Name } @w{ @i{debug I/O} @b{*debug-io*} } @w{ @i{error output} @b{*error-output*} } @w{ @i{query I/O} @b{*query-io*} } @w{ @i{standard input} @b{*standard-input*} } @w{ @i{standard output} @b{*standard-output*} } @w{ @i{terminal I/O} @b{*terminal-io*} } @w{ @i{trace output} @b{*trace-output*} } @noindent @w{ Figure 21--6: Standardized Stream Variables} @end group @end format Note that, by convention, @i{standardized} @i{stream variables} have names ending in ``@t{-input*}'' if they must be @i{input} @i{streams}, ending in ``@t{-output*}'' if they must be @i{output} @i{streams}, or ending in ``@t{-io*}'' if they must be @i{bidirectional} @i{streams}. User programs may @i{assign} or @i{bind} any @i{standardized} @i{stream variable} except @b{*terminal-io*}. @node Stream Arguments to Standardized Functions, Restrictions on Composite Streams, Stream Variables, Stream Concepts @subsection Stream Arguments to Standardized Functions The @i{operators} in Figure 21--7 accept @i{stream} @i{arguments} that might be either @i{open} or @i{closed} @i{streams}. @format @group @noindent @w{ broadcast-stream-streams file-author pathnamep } @w{ close file-namestring probe-file } @w{ compile-file file-write-date rename-file } @w{ compile-file-pathname host-namestring streamp } @w{ concatenated-stream-streams load synonym-stream-symbol } @w{ delete-file logical-pathname translate-logical-pathname } @w{ directory merge-pathnames translate-pathname } @w{ directory-namestring namestring truename } @w{ dribble open two-way-stream-input-stream } @w{ echo-stream-input-stream open-stream-p two-way-stream-output-stream } @w{ echo-stream-ouput-stream parse-namestring wild-pathname-p } @w{ ed pathname with-open-file } @w{ enough-namestring pathname-match-p } @noindent @w{ Figure 21--7: Operators that accept either Open or Closed Streams } @end group @end format The @i{operators} in Figure 21--8 accept @i{stream} @i{arguments} that must be @i{open} @i{streams}. @format @group @noindent @w{ clear-input output-stream-p read-char-no-hang } @w{ clear-output peek-char read-delimited-list } @w{ file-length pprint read-line } @w{ file-position pprint-fill read-preserving-whitespace } @w{ file-string-length pprint-indent stream-element-type } @w{ finish-output pprint-linear stream-external-format } @w{ force-output pprint-logical-block terpri } @w{ format pprint-newline unread-char } @w{ fresh-line pprint-tab with-open-stream } @w{ get-output-stream-string pprint-tabular write } @w{ input-stream-p prin1 write-byte } @w{ interactive-stream-p princ write-char } @w{ listen print write-line } @w{ make-broadcast-stream print-object write-string } @w{ make-concatenated-stream print-unreadable-object y-or-n-p } @w{ make-echo-stream read yes-or-no-p } @w{ make-synonym-stream read-byte } @w{ make-two-way-stream read-char } @noindent @w{ Figure 21--8: Operators that accept Open Streams only } @end group @end format @node Restrictions on Composite Streams, , Stream Arguments to Standardized Functions, Stream Concepts @subsection Restrictions on Composite Streams The consequences are undefined if any @i{component} of a @i{composite stream} is @i{closed} before the @i{composite stream} is @i{closed}. The consequences are undefined if the @i{synonym stream symbol} is not @i{bound} to an @i{open} @i{stream} from the time of the @i{synonym stream}'s creation until the time it is @i{closed}. @c end of including concept-streams @node Streams Dictionary, , Stream Concepts, Streams @section Streams Dictionary @c including dict-streams @menu * stream:: * broadcast-stream:: * concatenated-stream:: * echo-stream:: * file-stream:: * string-stream:: * synonym-stream:: * two-way-stream:: * input-stream-p:: * interactive-stream-p:: * open-stream-p:: * stream-element-type:: * streamp:: * read-byte:: * write-byte:: * peek-char:: * read-char:: * read-char-no-hang:: * terpri:: * unread-char:: * write-char:: * read-line:: * write-string:: * read-sequence:: * write-sequence:: * file-length:: * file-position:: * file-string-length:: * open:: * stream-external-format:: * with-open-file:: * close:: * with-open-stream:: * listen:: * clear-input:: * finish-output:: * y-or-n-p:: * make-synonym-stream:: * synonym-stream-symbol:: * broadcast-stream-streams:: * make-broadcast-stream:: * make-two-way-stream:: * two-way-stream-input-stream:: * echo-stream-input-stream:: * make-echo-stream:: * concatenated-stream-streams:: * make-concatenated-stream:: * get-output-stream-string:: * make-string-input-stream:: * make-string-output-stream:: * with-input-from-string:: * with-output-to-string:: * *debug-io*:: * *terminal-io*:: * stream-error:: * stream-error-stream:: * end-of-file:: @end menu @node stream, broadcast-stream, Streams Dictionary, Streams Dictionary @subsection stream [System Class] @subsubheading Class Precedence List:: @b{stream}, @b{t} @subsubheading Description:: A @i{stream} is an @i{object} that can be used with an input or output function to identify an appropriate source or sink of @i{characters} or @i{bytes} for that operation. For more complete information, see @ref{Stream Concepts}. @subsubheading See Also:: @ref{Stream Concepts}, @ref{Printing Other Objects}, @ref{Printer}, @ref{Reader} @node broadcast-stream, concatenated-stream, stream, Streams Dictionary @subsection broadcast-stream [System Class] @subsubheading Class Precedence List:: @b{broadcast-stream}, @b{stream}, @b{t} @subsubheading Description:: A @i{broadcast stream} is an @i{output} @i{stream} which has associated with it a set of zero or more @i{output} @i{streams} such that any output sent to the @i{broadcast stream} gets passed on as output to each of the associated @i{output} @i{streams}. (If a @i{broadcast stream} has no @i{component streams}, then all output to the @i{broadcast stream} is discarded.) The set of operations that may be performed on a @i{broadcast stream} is the intersection of those for its associated @i{output} @i{streams}. Some output operations (@i{e.g.}, @b{fresh-line}) return @i{values} based on the state of the @i{stream} at the time of the operation. Since these @i{values} might differ for each of the @i{component streams}, it is necessary to describe their return value specifically: @table @asis @item @t{*} @b{stream-element-type} returns the value from the last component stream, or @b{t} if there are no component streams. @item @t{*} @b{fresh-line} returns the value from the last component stream, or @b{nil} if there are no component streams. @item @t{*} The functions @b{file-length}, @b{file-position}, @b{file-string-length}, and @b{stream-external-format} return the value from the last component stream; if there are no component streams, @b{file-length} and @b{file-position} return @t{0}, @b{file-string-length} returns @t{1}, and @b{stream-external-format} returns @t{:default}. @item @t{*} The functions @b{streamp} and @b{output-stream-p} always return @i{true} for @i{broadcast streams}. @item @t{*} The functions @b{open-stream-p} tests whether the @i{broadcast stream} is @i{open}_2, not whether its component streams are @i{open}. @item @t{*} The functions @b{input-stream-p} and @i{interactive-stream-p} return an @i{implementation-defined}, @i{generalized boolean} value. @item @t{*} For the input operations @b{clear-input} @b{listen}, @b{peek-char}, @b{read-byte}, @b{read-char-no-hang}, @b{read-char}, @b{read-line}, and @b{unread-char}, the consequences are undefined if the indicated operation is performed. However, an @i{implementation} is permitted to define such a behavior as an @i{implementation-dependent} extension. @end table For any output operations not having their return values explicitly specified above or elsewhere in this document, it is defined that the @i{values} returned by such an operation are the @i{values} resulting from performing the operation on the last of its @i{component streams}; the @i{values} resulting from performing the operation on all preceding @i{streams} are discarded. If there are no @i{component streams}, the value is @i{implementation-dependent}. @subsubheading See Also:: @ref{broadcast-stream-streams} , @ref{make-broadcast-stream} @node concatenated-stream, echo-stream, broadcast-stream, Streams Dictionary @subsection concatenated-stream [System Class] @subsubheading Class Precedence List:: @b{concatenated-stream}, @b{stream}, @b{t} @subsubheading Description:: A @i{concatenated stream} is an @i{input} @i{stream} which is a @i{composite stream} of zero or more other @i{input} @i{streams}, such that the sequence of data which can be read from the @i{concatenated stream} is the same as the concatenation of the sequences of data which could be read from each of the constituent @i{streams}. Input from a @i{concatenated stream} is taken from the first of the associated @i{input streams} until it reaches @i{end of file}_1; then that @i{stream} is discarded, and subsequent input is taken from the next @i{input stream}, and so on. An @i{end of file} on the associated @i{input streams} is always managed invisibly by the @i{concatenated stream}---the only time a client of a @i{concatenated stream} sees an @i{end of file} is when an attempt is made to obtain data from the @i{concatenated stream} but it has no remaining @i{input streams} from which to obtain such data. @subsubheading See Also:: @ref{concatenated-stream-streams} , @ref{make-concatenated-stream} @node echo-stream, file-stream, concatenated-stream, Streams Dictionary @subsection echo-stream [System Class] @subsubheading Class Precedence List:: @b{echo-stream}, @b{stream}, @b{t} @subsubheading Description:: An @i{echo stream} is a @i{bidirectional} @i{stream} that gets its input from an associated @i{input} @i{stream} and sends its output to an associated @i{output} @i{stream}. All input taken from the @i{input} @i{stream} is echoed to the @i{output} @i{stream}. Whether the input is echoed immediately after it is encountered, or after it has been read from the @i{input stream} is @i{implementation-dependent}. @subsubheading See Also:: @ref{echo-stream-input-stream} , @b{echo-stream-output-stream}, @ref{make-echo-stream} @node file-stream, string-stream, echo-stream, Streams Dictionary @subsection file-stream [System Class] @subsubheading Class Precedence List:: @b{file-stream}, @b{stream}, @b{t} @subsubheading Description:: An @i{object} of @i{type} @b{file-stream} is a @i{stream} the direct source or sink of which is a @i{file}. Such a @i{stream} is created explicitly by @b{open} and @b{with-open-file}, and implicitly by @i{functions} such as @b{load} that process @i{files}. @subsubheading See Also:: @ref{load} , @ref{open} , @ref{with-open-file} @node string-stream, synonym-stream, file-stream, Streams Dictionary @subsection string-stream [System Class] @subsubheading Class Precedence List:: @b{string-stream}, @b{stream}, @b{t} @subsubheading Description:: A @i{string stream} is a @i{stream} which reads input from or writes output to an associated @i{string}. The @i{stream element type} of a @i{string stream} is always a @i{subtype} of @i{type} @b{character}. @subsubheading See Also:: @ref{make-string-input-stream} , @ref{make-string-output-stream} , @ref{with-input-from-string} , @ref{with-output-to-string} @node synonym-stream, two-way-stream, string-stream, Streams Dictionary @subsection synonym-stream [System Class] @subsubheading Class Precedence List:: @b{synonym-stream}, @b{stream}, @b{t} @subsubheading Description:: A @i{stream} that is an alias for another @i{stream}, which is the @i{value} of a @i{dynamic variable} whose @i{name} is the @i{synonym stream symbol} of the @i{synonym stream}. Any operations on a @i{synonym stream} will be performed on the @i{stream} that is then the @i{value} of the @i{dynamic variable} named by the @i{synonym stream symbol}. If the @i{value} of the @i{variable} should change, or if the @i{variable} should be @i{bound}, then the @i{stream} will operate on the new @i{value} of the @i{variable}. @subsubheading See Also:: @ref{make-synonym-stream} , @ref{synonym-stream-symbol} @node two-way-stream, input-stream-p, synonym-stream, Streams Dictionary @subsection two-way-stream [System Class] @subsubheading Class Precedence List:: @b{two-way-stream}, @b{stream}, @b{t} @subsubheading Description:: A @i{bidirectional} @i{composite stream} that receives its input from an associated @i{input} @i{stream} and sends its output to an associated @i{output} @i{stream}. @subsubheading See Also:: @ref{make-two-way-stream} , @ref{two-way-stream-input-stream} , @b{two-way-stream-output-stream} @node input-stream-p, interactive-stream-p, two-way-stream, Streams Dictionary @subsection input-stream-p, output-stream-p [Function] @code{input-stream-p} @i{stream} @result{} @i{generalized-boolean} @code{output-stream-p} @i{stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{stream}---a @i{stream}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{input-stream-p} returns @i{true} if @i{stream} is an @i{input} @i{stream}; otherwise, returns @i{false}. @b{output-stream-p} returns @i{true} if @i{stream} is an @i{output} @i{stream}; otherwise, returns @i{false}. @subsubheading Examples:: @example (input-stream-p *standard-input*) @result{} @i{true} (input-stream-p *terminal-io*) @result{} @i{true} (input-stream-p (make-string-output-stream)) @result{} @i{false} (output-stream-p *standard-output*) @result{} @i{true} (output-stream-p *terminal-io*) @result{} @i{true} (output-stream-p (make-string-input-stream "jr")) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. @node interactive-stream-p, open-stream-p, input-stream-p, Streams Dictionary @subsection interactive-stream-p [Function] @code{interactive-stream-p} @i{stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{stream}---a @i{stream}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{stream} is an @i{interactive stream}; otherwise, returns @i{false}. @subsubheading Examples:: @example (when (> measured limit) (let ((error (round (* (- measured limit) 100) limit))) (unless (if (interactive-stream-p *query-io*) (yes-or-no-p "The frammis is out of tolerance by ~D Is it safe to proceed? " error) (< error 15)) ;15 (error "The frammis is out of tolerance by ~D @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. @subsubheading See Also:: @ref{Stream Concepts} @node open-stream-p, stream-element-type, interactive-stream-p, Streams Dictionary @subsection open-stream-p [Function] @code{open-stream-p} @i{stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{stream}---a @i{stream}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{stream} is an @i{open} @i{stream}; otherwise, returns @i{false}. @i{Streams} are open until they have been explicitly closed with @b{close}, or until they are implicitly closed due to exit from a @b{with-output-to-string}, @b{with-open-file}, @b{with-input-from-string}, or @b{with-open-stream} @i{form}. @subsubheading Examples:: @example (open-stream-p *standard-input*) @result{} @i{true} @end example @subsubheading Affected By:: @b{close}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. @node stream-element-type, streamp, open-stream-p, Streams Dictionary @subsection stream-element-type [Function] @code{stream-element-type} @i{stream} @result{} @i{typespec} @subsubheading Arguments and Values:: @i{stream}---a @i{stream}. @i{typespec}---a @i{type specifier}. @subsubheading Description:: @b{stream-element-type} returns a @i{type specifier} that indicates the @i{types} of @i{objects} that may be read from or written to @i{stream}. @i{Streams} created by @b{open} have an @i{element type} restricted to @b{integer} or a @i{subtype} of @i{type} @b{character}. @subsubheading Examples:: @example ;; Note that the stream must accomodate at least the specified type, ;; but might accomodate other types. Further note that even if it does ;; accomodate exactly the specified type, the type might be specified in ;; any of several ways. (with-open-file (s "test" :element-type '(integer 0 1) :if-exists :error :direction :output) (stream-element-type s)) @result{} INTEGER @i{OR}@result{} (UNSIGNED-BYTE 16) @i{OR}@result{} (UNSIGNED-BYTE 8) @i{OR}@result{} BIT @i{OR}@result{} (UNSIGNED-BYTE 1) @i{OR}@result{} (INTEGER 0 1) @i{OR}@result{} (INTEGER 0 (2)) @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. @node streamp, read-byte, stream-element-type, Streams Dictionary @subsection streamp [Function] @code{streamp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{stream}; otherwise, returns @i{false}. @b{streamp} is unaffected by whether @i{object}, if it is a @i{stream}, is @i{open} or closed. @subsubheading Examples:: @example (streamp *terminal-io*) @result{} @i{true} (streamp 1) @result{} @i{false} @end example @subsubheading Notes:: @example (streamp @i{object}) @equiv{} (typep @i{object} 'stream) @end example @node read-byte, write-byte, streamp, Streams Dictionary @subsection read-byte [Function] @code{read-byte} @i{stream @r{&optional} eof-error-p eof-value} @result{} @i{byte} @subsubheading Arguments and Values:: @i{stream}---a @i{binary} @i{input} @i{stream}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{byte}---an @i{integer}, or the @i{eof-value}. @subsubheading Description:: @b{read-byte} reads and returns one byte from @i{stream}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, the @i{eof-value} is returned. @subsubheading Examples:: @example (with-open-file (s "temp-bytes" :direction :output :element-type 'unsigned-byte) (write-byte 101 s)) @result{} 101 (with-open-file (s "temp-bytes" :element-type 'unsigned-byte) (format t "~S ~S" (read-byte s) (read-byte s nil 'eof))) @t{ |> } 101 EOF @result{} NIL @end example @subsubheading Side Effects:: Modifies @i{stream}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. Should signal an error of @i{type} @b{error} if @i{stream} is not a @i{binary} @i{input} @i{stream}. If there are no @i{bytes} remaining in the @i{stream} and @i{eof-error-p} is @i{true}, an error of @i{type} @b{end-of-file} is signaled. @subsubheading See Also:: @ref{read-char} , @ref{read-sequence} , @ref{write-byte} @node write-byte, peek-char, read-byte, Streams Dictionary @subsection write-byte [Function] @code{write-byte} @i{byte stream} @result{} @i{byte} @subsubheading Arguments and Values:: @i{byte}---an @i{integer} of the @i{stream element type} of @i{stream}. @i{stream}---a @i{binary} @i{output} @i{stream}. @subsubheading Description:: @b{write-byte} writes one byte, @i{byte}, to @i{stream}. @subsubheading Examples:: @example (with-open-file (s "temp-bytes" :direction :output :element-type 'unsigned-byte) (write-byte 101 s)) @result{} 101 @end example @subsubheading Side Effects:: @i{stream} is modified. @subsubheading Affected By:: The @i{element type} of the @i{stream}. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream}. Should signal an error of @i{type} @b{error} if @i{stream} is not a @i{binary} @i{output} @i{stream}. Might signal an error of @i{type} @b{type-error} if @i{byte} is not an @i{integer} of the @i{stream element type} of @i{stream}. @subsubheading See Also:: @ref{read-byte} , @ref{write-char} , @ref{write-sequence} @node peek-char, read-char, write-byte, Streams Dictionary @subsection peek-char [Function] @code{peek-char} @i{@r{&optional} peek-type input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @i{peek-type}---a @i{character} or @b{t} or @b{nil}. @i{input-stream}---@i{input} @i{stream designator}. The default is @i{standard input}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{char}---a @i{character} or the @i{eof-value}. @subsubheading Description:: @b{peek-char} obtains the next character in @i{input-stream} without actually reading it, thus leaving the character to be read at a later time. It can also be used to skip over and discard intervening characters in the @i{input-stream} until a particular character is found. If @i{peek-type} is not supplied or @b{nil}, @b{peek-char} returns the next character to be read from @i{input-stream}, without actually removing it from @i{input-stream}. The next time input is done from @i{input-stream}, the character will still be there. If @i{peek-type} is @b{t}, then @b{peek-char} skips over @i{whitespace}_2 @i{characters}, but not comments, and then performs the peeking operation on the next character. The last character examined, the one that starts an @i{object}, is not removed from @i{input-stream}. If @i{peek-type} is a @i{character}, then @b{peek-char} skips over input characters until a character that is @b{char=} to that @i{character} is found; that character is left in @i{input-stream}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} or a similar @i{function} used by the @i{Lisp reader}. When @i{input-stream} is an @i{echo stream}, characters that are only peeked at are not echoed. In the case that @i{peek-type} is not @b{nil}, the characters that are passed by @b{peek-char} are treated as if by @b{read-char}, and so are echoed unless they have been marked otherwise by @b{unread-char}. @subsubheading Examples:: @example (with-input-from-string (input-stream " 1 2 3 4 5") (format t "~S ~S ~S" (peek-char t input-stream) (peek-char #\4 input-stream) (peek-char nil input-stream))) @t{ |> } #\1 #\4 #\4 @result{} NIL @end example @subsubheading Affected By:: @b{*readtable*}, @b{*standard-input*}, @b{*terminal-io*}. @subsubheading Exceptional Situations:: If @i{eof-error-p} is @i{true} and an @i{end of file}_2 occurs an error of @i{type} @b{end-of-file} is signaled. If @i{peek-type} is a @i{character}, an @i{end of file}_2 occurs, and @i{eof-error-p} is @i{true}, an error of @i{type} @b{end-of-file} is signaled. If @i{recursive-p} is @i{true} and an @i{end of file}_2 occurs, an error of @i{type} @b{end-of-file} is signaled. @node read-char, read-char-no-hang, peek-char, Streams Dictionary @subsection read-char [Function] @code{read-char} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{char}---a @i{character} or the @i{eof-value}. @subsubheading Description:: @b{read-char} returns the next @i{character} from @i{input-stream}. When @i{input-stream} is an @i{echo stream}, the character is echoed on @i{input-stream} the first time the character is seen. Characters that are not echoed by @b{read-char} are those that were put there by @b{unread-char} and hence are assumed to have been echoed already by a previous call to @b{read-char}. If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} or a similar @i{function} used by the @i{Lisp reader}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. @subsubheading Examples:: @example (with-input-from-string (is "0123") (do ((c (read-char is) (read-char is nil 'the-end))) ((not (characterp c))) (format t "~S " c))) @t{ |> } #\0 #\1 #\2 #\3 @result{} NIL @end example @subsubheading Affected By:: @b{*standard-input*}, @b{*terminal-io*}. @subsubheading Exceptional Situations:: If an @i{end of file}_2 occurs before a character can be read, and @i{eof-error-p} is @i{true}, an error of @i{type} @b{end-of-file} is signaled. @subsubheading See Also:: @ref{read-byte} , @ref{read-sequence} , @ref{write-char} , @ref{read} @subsubheading Notes:: The corresponding output function is @b{write-char}. @node read-char-no-hang, terpri, read-char, Streams Dictionary @subsection read-char-no-hang [Function] @code{read-char-no-hang} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} @subsubheading Arguments and Values:: @i{input-stream} -- an @i{input} @i{stream designator}. The default is @i{standard input}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{char}---a @i{character} or @b{nil} or the @i{eof-value}. @subsubheading Description:: @b{read-char-no-hang} returns a character from @i{input-stream} if such a character is available. If no character is available, @b{read-char-no-hang} returns @b{nil}. If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} or a similar @i{function} used by the @i{Lisp reader}. If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, @i{eof-value} is returned. @subsubheading Examples:: @example ;; This code assumes an implementation in which a newline is not ;; required to terminate input from the console. (defun test-it () (unread-char (read-char)) (list (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) @result{} TEST-IT ;; Implementation A, where a Newline is not required to terminate ;; interactive input on the console. (test-it) @t{ |> } @b{|>>}@t{a}@b{<<|} @result{} (#\a NIL NIL) ;; Implementation B, where a Newline is required to terminate ;; interactive input on the console, and where that Newline remains ;; on the input stream. (test-it) @t{ |> } @b{|>>}@t{a@r{@i{[<--}~]}}@b{<<|} @result{} (#\a #\Newline NIL) @end example @subsubheading Affected By:: @b{*standard-input*}, @b{*terminal-io*}. @subsubheading Exceptional Situations:: If an @i{end of file}_2 occurs when @i{eof-error-p} is @i{true}, an error of @i{type} @b{end-of-file} is signaled . @subsubheading See Also:: @ref{listen} @subsubheading Notes:: @b{read-char-no-hang} is exactly like @b{read-char}, except that if it would be necessary to wait in order to get a character (as from a keyboard), @b{nil} is immediately returned without waiting. @node terpri, unread-char, read-char-no-hang, Streams Dictionary @subsection terpri, fresh-line [Function] @code{terpri} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} @code{fresh-line} @i{@r{&optional} output-stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{output-stream} -- an @i{output} @i{stream designator}. The default is @i{standard output}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{terpri} outputs a @i{newline} to @i{output-stream}. @b{fresh-line} is similar to @b{terpri} but outputs a @i{newline} only if the @i{output-stream} is not already at the start of a line. If for some reason this cannot be determined, then a @i{newline} is output anyway. @b{fresh-line} returns @i{true} if it outputs a @i{newline}; otherwise it returns @i{false}. @subsubheading Examples:: @example (with-output-to-string (s) (write-string "some text" s) (terpri s) (terpri s) (write-string "more text" s)) @result{} "some text more text" (with-output-to-string (s) (write-string "some text" s) (fresh-line s) (fresh-line s) (write-string "more text" s)) @result{} "some text more text" @end example @subsubheading Side Effects:: The @i{output-stream} is modified. @subsubheading Affected By:: @b{*standard-output*}, @b{*terminal-io*}. @subsubheading Exceptional Situations:: None. [Reviewer Note by Barmar: What if stream is closed?] @subsubheading Notes:: @b{terpri} is identical in effect to @example (write-char #\Newline output-stream) @end example @node unread-char, write-char, terpri, Streams Dictionary @subsection unread-char [Function] @code{unread-char} @i{character @r{&optional} input-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{character}---a @i{character}; must be the last @i{character} that was read from @i{input-stream}. @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @subsubheading Description:: @b{unread-char} places @i{character} back onto the front of @i{input-stream} so that it will again be the next character in @i{input-stream}. When @i{input-stream} is an @i{echo stream}, no attempt is made to undo any echoing of the character that might already have been done on @i{input-stream}. However, characters placed on @i{input-stream} by @b{unread-char} are marked in such a way as to inhibit later re-echo by @b{read-char}. It is an error to invoke @b{unread-char} twice consecutively on the same @i{stream} without an intervening call to @b{read-char} (or some other input operation which implicitly reads characters) on that @i{stream}. Invoking @b{peek-char} or @b{read-char} commits all previous characters. The consequences of invoking @b{unread-char} on any character preceding that which is returned by @b{peek-char} (including those passed over by @b{peek-char} that has a @i{non-nil} @i{peek-type}) are unspecified. In particular, the consequences of invoking @b{unread-char} after @b{peek-char} are unspecified. @subsubheading Examples:: @example (with-input-from-string (is "0123") (dotimes (i 6) (let ((c (read-char is))) (if (evenp i) (format t "~&~S ~S~ @t{ |> } 0 #\0 @t{ |> } 2 #\1 @t{ |> } 4 #\2 @result{} NIL @end example @subsubheading Affected By:: @b{*standard-input*}, @b{*terminal-io*}. @subsubheading See Also:: @ref{peek-char} , @ref{read-char} , @ref{Stream Concepts} @subsubheading Notes:: @b{unread-char} is intended to be an efficient mechanism for allowing the @i{Lisp reader} and other parsers to perform one-character lookahead in @i{input-stream}. @node write-char, read-line, unread-char, Streams Dictionary @subsection write-char [Function] @code{write-char} @i{character @r{&optional} output-stream} @result{} @i{character} @subsubheading Arguments and Values:: @i{character}---a @i{character}. @i{output-stream} -- an @i{output} @i{stream designator}. The default is @i{standard output}. @subsubheading Description:: @b{write-char} outputs @i{character} to @i{output-stream}. @subsubheading Examples:: @example (write-char #\a) @t{ |> } a @result{} #\a (with-output-to-string (s) (write-char #\a s) (write-char #\Space s) (write-char #\b s)) @result{} "a b" @end example @subsubheading Side Effects:: The @i{output-stream} is modified. @subsubheading Affected By:: @b{*standard-output*}, @b{*terminal-io*}. @subsubheading See Also:: @ref{read-char} , @ref{write-byte} , @ref{write-sequence} @node read-line, write-string, write-char, Streams Dictionary @subsection read-line [Function] @code{read-line} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p}@* @result{} @i{line, missing-newline-p} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @i{eof-error-p}---a @i{generalized boolean}. The default is @i{true}. @i{eof-value}---an @i{object}. The default is @b{nil}. @i{recursive-p}---a @i{generalized boolean}. The default is @i{false}. @i{line}---a @i{string} or the @i{eof-value}. @i{missing-newline-p}---a @i{generalized boolean}. @subsubheading Description:: Reads from @i{input-stream} a line of text that is terminated by a @i{newline} or @i{end of file}. If @i{recursive-p} is @i{true}, this call is expected to be embedded in a higher-level call to @b{read} or a similar @i{function} used by the @i{Lisp reader}. The @i{primary value}, @i{line}, is the line that is read, represented as a @i{string} (without the trailing @i{newline}, if any). If @i{eof-error-p} is @i{false} and the @i{end of file} for @i{input-stream} is reached before any @i{characters} are read, @i{eof-value} is returned as the @i{line}. The @i{secondary value}, @i{missing-newline-p}, is a @i{generalized boolean} that is @i{false} if the @i{line} was terminated by a @i{newline}, or @i{true} if the @i{line} was terminated by the @i{end of file} for @i{input-stream} (or if the @i{line} is the @i{eof-value}). @subsubheading Examples:: @example (setq a "line 1 line2") @result{} "line 1 line2" (read-line (setq input-stream (make-string-input-stream a))) @result{} "line 1", @i{false} (read-line input-stream) @result{} "line2", @i{true} (read-line input-stream nil nil) @result{} NIL, @i{true} @end example @subsubheading Affected By:: @b{*standard-input*}, @b{*terminal-io*}. @subsubheading Exceptional Situations:: If an @i{end of file}_2 occurs before any characters are read in the line, an error is signaled if @i{eof-error-p} is @i{true}. @subsubheading See Also:: @ref{read} @subsubheading Notes:: The corresponding output function is @b{write-line}. @node write-string, read-sequence, read-line, Streams Dictionary @subsection write-string, write-line [Function] @code{write-string} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} @code{write-line} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{output-stream} -- an @i{output} @i{stream designator}. The default is @i{standard output}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @subsubheading Description:: @b{write-string} writes the @i{characters} of the subsequence of @i{string} @i{bounded} by @i{start} and @i{end} to @i{output-stream}. @b{write-line} does the same thing, but then outputs a newline afterwards. @subsubheading Examples:: @example (prog1 (write-string "books" nil :end 4) (write-string "worms")) @t{ |> } bookworms @result{} "books" (progn (write-char #\*) (write-line "test12" *standard-output* :end 5) (write-line "*test2") (write-char #\*) nil) @t{ |> } *test1 @t{ |> } *test2 @t{ |> } * @result{} NIL @end example @subsubheading Affected By:: @b{*standard-output*}, @b{*terminal-io*}. @subsubheading See Also:: @ref{read-line} , @ref{write-char} @subsubheading Notes:: @b{write-line} and @b{write-string} return @i{string}, not the substring @i{bounded} by @i{start} and @i{end}. @example (write-string string) @equiv{} (dotimes (i (length string) (write-char (char string i))) (write-line string) @equiv{} (prog1 (write-string string) (terpri)) @end example @node read-sequence, write-sequence, write-string, Streams Dictionary @subsection read-sequence [Function] @code{read-sequence} @i{sequence stream @r{&key} start end} @result{} @i{position} @i{sequence}---a @i{sequence}. @i{stream}---an @i{input} @i{stream}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{position}---an @i{integer} greater than or equal to zero, and less than or equal to the @i{length} of the @i{sequence}. @subsubheading Description:: Destructively modifies @i{sequence} by replacing the @i{elements} of @i{sequence} @i{bounded} by @i{start} and @i{end} with @i{elements} read from @i{stream}. @i{Sequence} is destructively modified by copying successive @i{elements} into it from @i{stream}. If the @i{end of file} for @i{stream} is reached before copying all @i{elements} of the subsequence, then the extra @i{elements} near the end of @i{sequence} are not updated. @i{Position} is the index of the first @i{element} of @i{sequence} that was not updated, which might be less than @i{end} because the @i{end of file} was reached. @subsubheading Examples:: @example (defvar *data* (make-array 15 :initial-element nil)) (values (read-sequence *data* (make-string-input-stream "test string")) *data*) @result{} 11, #(#\t #\e #\s #\t #\Space #\s #\t #\r #\i #\n #\g NIL NIL NIL NIL) @end example @subsubheading Side Effects:: Modifies @i{stream} and @i{sequence}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. Should signal an error of @i{type} @b{type-error} if @i{start} is not a non-negative @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{end} is not a non-negative @i{integer} or @b{nil}. Might signal an error of @i{type} @b{type-error} if an @i{element} read from the @i{stream} is not a member of the @i{element type} of the @i{sequence}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{write-sequence} , @ref{read-line} @subsubheading Notes:: @b{read-sequence} is identical in effect to iterating over the indicated subsequence and reading one @i{element} at a time from @i{stream} and storing it into @i{sequence}, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the @i{sequence} is a @i{vector} with the same @i{element type} as the @i{stream}. @node write-sequence, file-length, read-sequence, Streams Dictionary @subsection write-sequence [Function] @code{write-sequence} @i{sequence stream @r{&key} start end} @result{} @i{sequence} @i{sequence}---a @i{sequence}. @i{stream}---an @i{output} @i{stream}. @i{start}, @i{end}---@i{bounding index designators} of @i{sequence}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @subsubheading Description:: @b{write-sequence} writes the @i{elements} of the subsequence of @i{sequence} @i{bounded} by @i{start} and @i{end} to @i{stream}. @subsubheading Examples:: @example (write-sequence "bookworms" *standard-output* :end 4) @t{ |> } book @result{} "bookworms" @end example @subsubheading Side Effects:: Modifies @i{stream}. @subsubheading Exceptional Situations:: Should be prepared to signal an error of @i{type} @b{type-error} if @i{sequence} is not a @i{proper sequence}. Should signal an error of @i{type} @b{type-error} if @i{start} is not a non-negative @i{integer}. Should signal an error of @i{type} @b{type-error} if @i{end} is not a non-negative @i{integer} or @b{nil}. Might signal an error of @i{type} @b{type-error} if an @i{element} of the @i{bounded} @i{sequence} is not a member of the @i{stream element type} of the @i{stream}. @subsubheading See Also:: @ref{Compiler Terminology}, @ref{read-sequence} , @ref{write-string} , @b{write-line} @subsubheading Notes:: @b{write-sequence} is identical in effect to iterating over the indicated subsequence and writing one @i{element} at a time to @i{stream}, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the @i{sequence} is a @i{vector} with the same @i{element type} as the @i{stream}. @node file-length, file-position, write-sequence, Streams Dictionary @subsection file-length [Function] @code{file-length} @i{stream} @result{} @i{length} @subsubheading Arguments and Values:: @i{stream}---a @i{stream associated with a file}. @i{length}---a non-negative @i{integer} or @b{nil}. @subsubheading Description:: @b{file-length} returns the length of @i{stream}, or @b{nil} if the length cannot be determined. For a binary file, the length is measured in units of the @i{element type} of the @i{stream}. @subsubheading Examples:: @example (with-open-file (s "decimal-digits.text" :direction :output :if-exists :error) (princ "0123456789" s) (truename s)) @result{} #P"A:>Joe>decimal-digits.text.1" (with-open-file (s "decimal-digits.text") (file-length s)) @result{} 10 @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{stream} is not a @i{stream associated with a file}. @subsubheading See Also:: @ref{open} @node file-position, file-string-length, file-length, Streams Dictionary @subsection file-position [Function] @code{file-position} @i{stream} @result{} @i{position} @code{file-position} @i{stream position-spec} @result{} @i{success-p} @subsubheading Arguments and Values:: @i{stream}---a @i{stream}. @i{position-spec}---a @i{file position designator}. @i{position}---a @i{file position} or @b{nil}. @i{success-p}---a @i{generalized boolean}. @subsubheading Description:: Returns or changes the current position within a @i{stream}. When @i{position-spec} is not supplied, @b{file-position} returns the current @i{file position} in the @i{stream}, or @b{nil} if this cannot be determined. When @i{position-spec} is supplied, the @i{file position} in @i{stream} is set to that @i{file position} (if possible). @b{file-position} returns @i{true} if the repositioning is performed successfully, or @i{false} if it is not. An @i{integer} returned by @b{file-position} of one argument should be acceptable as @i{position-spec} for use with the same file. For a character file, performing a single @b{read-char} or @b{write-char} operation may cause the file position to be increased by more than 1 because of character-set translations (such as translating between the @r{Common Lisp} @t{#\Newline} character and an external ASCII carriage-return/line-feed sequence) and other aspects of the implementation. For a binary file, every @b{read-byte} or @b{write-byte} operation increases the file position by 1. @subsubheading Examples:: @example (defun tester () (let ((noticed '()) file-written) (flet ((notice (x) (push x noticed) x)) (with-open-file (s "test.bin" :element-type '(unsigned-byte 8) :direction :output :if-exists :error) (notice (file-position s)) ;1 (write-byte 5 s) (write-byte 6 s) (let ((p (file-position s))) (notice p) ;2 (notice (when p (file-position s (1- p))))) ;3 (write-byte 7 s) (notice (file-position s)) ;4 (setq file-written (truename s))) (with-open-file (s file-written :element-type '(unsigned-byte 8) :direction :input) (notice (file-position s)) ;5 (let ((length (file-length s))) (notice length) ;6 (when length (dotimes (i length) (notice (read-byte s)))))) ;7,... (nreverse noticed)))) @result{} tester (tester) @result{} (0 2 T 2 0 2 5 7) @i{OR}@result{} (0 2 NIL 3 0 3 5 6 7) @i{OR}@result{} (NIL NIL NIL NIL NIL NIL) @end example @subsubheading Side Effects:: When the @i{position-spec} argument is supplied, the @i{file position} in the @i{stream} might be moved. @subsubheading Affected By:: The value returned by @b{file-position} increases monotonically as input or output operations are performed. @subsubheading Exceptional Situations:: If @i{position-spec} is supplied, but is too large or otherwise inappropriate, an error is signaled. @subsubheading See Also:: @ref{file-length} , @ref{file-string-length} , @ref{open} @subsubheading Notes:: Implementations that have character files represented as a sequence of records of bounded size might choose to encode the file position as, for example, <<@i{record-number}>>*<<@i{max-record-size}>>+<<@i{character-within-record}>>. This is a valid encoding because it increases monotonically as each character is read or written, though not necessarily by 1 at each step. An @i{integer} might then be considered ``inappropriate'' as @i{position-spec} to @b{file-position} if, when decoded into record number and character number, it turned out that the supplied record was too short for the specified character number. @node file-string-length, open, file-position, Streams Dictionary @subsection file-string-length [Function] @code{file-string-length} @i{stream object} @result{} @i{length} @subsubheading Arguments and Values:: @i{stream}---an @i{output} @i{character} @i{file stream}. @i{object}---a @i{string} or a @i{character}. @i{length}---a non-negative @i{integer}, or @b{nil}. @subsubheading Description:: @b{file-string-length} returns the difference between what @t{(file-position @i{stream})} would be after writing @i{object} and its current value, or @b{nil} if this cannot be determined. The returned value corresponds to the current state of @i{stream} at the time of the call and might not be the same if it is called again when the state of the @i{stream} has changed. @node open, stream-external-format, file-string-length, Streams Dictionary @subsection open [Function] @code{open} @i{filespec @r{&key} direction element-type if-exists if-does-not-exist external-format}@* @result{} @i{stream} @subsubheading Arguments and Values:: @i{filespec}---a @i{pathname designator}. @i{direction}---one of @t{:input}, @t{:output}, @t{:io}, or @t{:probe}. The default is @t{:input}. @i{element-type}---a @i{type specifier} for @i{recognizable subtype} of @b{character}; or a @i{type specifier} for a @i{finite} @i{recognizable subtype} of @i{integer}; or one of the @i{symbols} @b{signed-byte}, @b{unsigned-byte}, or @t{:default}. The default is @b{character}. @i{if-exists}---one of @t{:error}, @t{:new-version}, @t{:rename}, @t{:rename-and-delete}, @t{:overwrite}, @t{:append}, @t{:supersede}, or @b{nil}. The default is @t{:new-version} if the version component of @i{filespec} is @t{:newest}, or @t{:error} otherwise. @i{if-does-not-exist}---one of @t{:error}, @t{:create}, or @b{nil}. The default is @t{:error} if @i{direction} is @t{:input} or @i{if-exists} is @t{:overwrite} or @t{:append}; @t{:create} if @i{direction} is @t{:output} or @t{:io}, and @i{if-exists} is neither @t{:overwrite} nor @t{:append}; or @b{nil} when @i{direction} is @t{:probe}. @i{external-format}---an @i{external file format designator}. The default is @t{:default}. @i{stream}---a @i{file stream} or @b{nil}. @subsubheading Description:: @b{open} creates, opens, and returns a @i{file stream} that is connected to the file specified by @i{filespec}. @i{Filespec} is the name of the file to be opened. If the @i{filespec} @i{designator} is a @i{stream}, that @i{stream} is not closed first or otherwise affected. The keyword arguments to @b{open} specify the characteristics of the @i{file stream} that is returned, and how to handle errors. If @i{direction} is @t{:input} or @t{:probe}, or if @i{if-exists} is not @t{:new-version} and the version component of the @i{filespec} is @t{:newest}, then the file opened is that file already existing in the file system that has a version greater than that of any other file in the file system whose other pathname components are the same as those of @i{filespec}. An implementation is required to recognize all of the @b{open} keyword options and to do something reasonable in the context of the host operating system. For example, if a file system does not support distinct file versions and does not distinguish the notions of deletion and expunging, @t{:new-version} might be treated the same as @t{:rename} or @t{:supersede}, and @t{:rename-and-delete} might be treated the same as @t{:supersede}. @table @asis @item @t{:direction} These are the possible values for @i{direction}, and how they affect the nature of the @i{stream} that is created: @table @asis @item @t{:input} Causes the creation of an @i{input} @i{file stream}. @item @t{:output} Causes the creation of an @i{output} @i{file stream}. @item @t{:io} Causes the creation of a @i{bidirectional} @i{file stream}. @item @t{:probe} Causes the creation of a ``no-directional'' @i{file stream}; in effect, the @i{file stream} is created and then closed prior to being returned by @b{open}. @end table @item @t{:element-type} The @i{element-type} specifies the unit of transaction for the @i{file stream}. If it is @t{:default}, the unit is determined by @i{file system}, possibly based on the @i{file}. @item @t{:if-exists} @i{if-exists} specifies the action to be taken if @i{direction} is @t{:output} or @t{:io} and a file of the name @i{filespec} already exists. If @i{direction} is @t{:input}, not supplied, or @t{:probe}, @i{if-exists} is ignored. These are the results of @b{open} as modified by @i{if-exists}: @table @asis @item @t{:error} An error of @i{type} @b{file-error} is signaled. @item @t{:new-version} A new file is created with a larger version number. @item @t{:rename} The existing file is renamed to some other name and then a new file is created. @item @t{:rename-and-delete} The existing file is renamed to some other name, then it is deleted but not expunged, and then a new file is created. @item @t{:overwrite} Output operations on the @i{stream} destructively modify the existing file. If @i{direction} is @t{:io} the file is opened in a bidirectional mode that allows both reading and writing. The file pointer is initially positioned at the beginning of the file; however, the file is not truncated back to length zero when it is opened. @item @t{:append} Output operations on the @i{stream} destructively modify the existing file. The file pointer is initially positioned at the end of the file. If @i{direction} is @t{:io}, the file is opened in a bidirectional mode that allows both reading and writing. @item @t{:supersede} The existing file is superseded; that is, a new file with the same name as the old one is created. If possible, the implementation should not destroy the old file until the new @i{stream} is closed. @item @b{nil} No file or @i{stream} is created; instead, @b{nil} is returned to indicate failure. @end table @item @t{:if-does-not-exist} @i{if-does-not-exist} specifies the action to be taken if a file of name @i{filespec} does not already exist. These are the results of @b{open} as modified by @i{if-does-not-exist}: @table @asis @item @t{:error} An error of @i{type} @b{file-error} is signaled. @item @t{:create} An empty file is created. Processing continues as if the file had already existed but no processing as directed by @i{if-exists} is performed. @item @b{nil} No file or @i{stream} is created; instead, @b{nil} is returned to indicate failure. @end table @item @t{:external-format} This option selects an @i{external file format} for the @i{file}: The only @i{standardized} value for this option is @t{:default}, although @i{implementations} are permitted to define additional @i{external file formats} and @i{implementation-dependent} values returned by @b{stream-external-format} can also be used by @i{conforming programs}. The @i{external-format} is meaningful for any kind of @i{file stream} whose @i{element type} is a @i{subtype} of @i{character}. This option is ignored for @i{streams} for which it is not meaningful; however, @i{implementations} may define other @i{element types} for which it is meaningful. The consequences are unspecified if a @i{character} is written that cannot be represented by the given @i{external file format}. @end table When a file is opened, a @i{file stream} is constructed to serve as the file system's ambassador to the @r{Lisp} environment; operations on the @i{file stream} are reflected by operations on the file in the file system. A file can be deleted, renamed, or destructively modified by @b{open}. For information about opening relative pathnames, see @ref{Merging Pathnames}. @subsubheading Examples:: @example (open @i{filespec} :direction :probe) @result{} # (setq q (merge-pathnames (user-homedir-pathname) "test")) @result{} # (open @i{filespec} :if-does-not-exist :create) @result{} # (setq s (open @i{filespec} :direction :probe)) @result{} # (truename s) @result{} # (open s :direction :output :if-exists nil) @result{} NIL @end example @subsubheading Affected By:: The nature and state of the host computer's @i{file system}. @subsubheading Exceptional Situations:: If @i{if-exists} is @t{:error}, (subject to the constraints on the meaning of @i{if-exists} listed above), an error of @i{type} @b{file-error} is signaled. If @i{if-does-not-exist} is @t{:error} (subject to the constraints on the meaning of @i{if-does-not-exist} listed above), an error of @i{type} @b{file-error} is signaled. If it is impossible for an implementation to handle some option in a manner close to what is specified here, an error of @i{type} @b{error} might be signaled. An error of @i{type} @b{file-error} is signaled if @t{(wild-pathname-p @i{filespec})} returns true. An error of @i{type} @b{error} is signaled if the @i{external-format} is not understood by the @i{implementation}. The various @i{file systems} in existence today have widely differing capabilities, and some aspects of the @i{file system} are beyond the scope of this specification to define. A given @i{implementation} might not be able to support all of these options in exactly the manner stated. An @i{implementation} is required to recognize all of these option keywords and to try to do something ``reasonable'' in the context of the host @i{file system}. Where necessary to accomodate the @i{file system}, an @i{implementation} deviate slightly from the semantics specified here without being disqualified for consideration as a @i{conforming implementation}. If it is utterly impossible for an @i{implementation} to handle some option in a manner similar to what is specified here, it may simply signal an error. With regard to the @t{:element-type} option, if a @i{type} is requested that is not supported by the @i{file system}, a substitution of types such as that which goes on in @i{upgrading} is permissible. As a minimum requirement, it should be the case that opening an @i{output} @i{stream} to a @i{file} in a given @i{element type} and later opening an @i{input} @i{stream} to the same @i{file} in the same @i{element type} should work compatibly. @subsubheading See Also:: @ref{with-open-file} , @ref{close} , @b{pathname}, @b{logical-pathname}, @ref{Merging Pathnames}, @ref{Pathnames as Filenames} @subsubheading Notes:: @b{open} does not automatically close the file when an abnormal exit occurs. When @i{element-type} is a @i{subtype} of @b{character}, @b{read-char} and/or @b{write-char} can be used on the resulting @i{file stream}. When @i{element-type} is a @i{subtype} of @i{integer}, @b{read-byte} and/or @b{write-byte} can be used on the resulting @i{file stream}. When @i{element-type} is @t{:default}, the @i{type} can be determined by using @b{stream-element-type}. @node stream-external-format, with-open-file, open, Streams Dictionary @subsection stream-external-format [Function] @code{stream-external-format} @i{stream} @result{} @i{format} @subsubheading Arguments and Values:: @i{stream}---a @i{file stream}. @i{format}---an @i{external file format}. @subsubheading Description:: Returns an @i{external file format designator} for the @i{stream}. @subsubheading Examples:: @example (with-open-file (stream "test" :direction :output) (stream-external-format stream)) @result{} :DEFAULT @i{OR}@result{} :ISO8859/1-1987 @i{OR}@result{} (:ASCII :SAIL) @i{OR}@result{} ACME::PROPRIETARY-FILE-FORMAT-17 @i{OR}@result{} # @end example @subsubheading See Also:: the @t{:external-format} @i{argument} to the @i{function} @ref{open} and the @ref{with-open-file} @i{macro}. @subsubheading Notes:: The @i{format} returned is not necessarily meaningful to other @i{implementations}. @node with-open-file, close, stream-external-format, Streams Dictionary @subsection with-open-file [macro] @subsubheading Syntax:: @code{with-open-file} @i{@r{(}stream filespec @{@i{options}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{results} @subsubheading Arguments and Values:: @i{stream} -- a variable. @i{filespec}---a @i{pathname designator}. @i{options} -- @i{forms}; evaluated. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{with-open-file} uses @b{open} to create a @i{file stream} to @i{file} named by @i{filespec}. @i{Filespec} is the name of the file to be opened. @i{Options} are used as keyword arguments to @b{open}. The @i{stream} @i{object} to which the @i{stream} @i{variable} is @i{bound} has @i{dynamic extent}; its @i{extent} ends when the @i{form} is exited. @b{with-open-file} evaluates the @i{forms} as an @i{implicit progn} with @i{stream} bound to the value returned by @b{open}. When control leaves the body, either normally or abnormally (such as by use of @b{throw}), the file is automatically closed. If a new output file is being written, and control leaves abnormally, the file is aborted and the file system is left, so far as possible, as if the file had never been opened. It is possible by the use of @t{:if-exists nil} or @t{:if-does-not-exist nil} for @i{stream} to be bound to @b{nil}. Users of @t{:if-does-not-exist nil} should check for a valid @i{stream}. The consequences are undefined if an attempt is made to @i{assign} the @i{stream} @i{variable}. The compiler may choose to issue a warning if such an attempt is detected. @subsubheading Examples:: @example (setq p (merge-pathnames "test")) @result{} # (with-open-file (s p :direction :output :if-exists :supersede) (format s "Here are a couple~ (with-open-file (s p) (do ((l (read-line s) (read-line s nil 'eof))) ((eq l 'eof) "Reached end of file.") (format t "~&*** ~A~ @t{ |> } *** Here are a couple @t{ |> } *** of test data lines @result{} "Reached end of file." @end example @example ;; Normally one would not do this intentionally because it is ;; not perspicuous, but beware when using :IF-DOES-NOT-EXIST NIL ;; that this doesn't happen to you accidentally... (with-open-file (foo "no-such-file" :if-does-not-exist nil) (read foo)) @t{ |> } @b{|>>}@t{hello?}@b{<<|} @result{} HELLO? ;This value was read from the terminal, not a file! ;; Here's another bug to avoid... (with-open-file (foo "no-such-file" :direction :output :if-does-not-exist nil) (format foo "Hello")) @result{} "Hello" ;FORMAT got an argument of NIL! @end example @subsubheading Side Effects:: Creates a @i{stream} to the @i{file} named by @i{filename} (upon entry), and closes the @i{stream} (upon exit). In some @i{implementations}, the @i{file} might be locked in some way while it is open. If the @i{stream} is an @i{output} @i{stream}, a @i{file} might be created. @subsubheading Affected By:: The host computer's file system. @subsubheading Exceptional Situations:: See the @i{function} @b{open}. @subsubheading See Also:: @ref{open} , @ref{close} , @b{pathname}, @b{logical-pathname}, @ref{Pathnames as Filenames} @node close, with-open-stream, with-open-file, Streams Dictionary @subsection close [Function] @code{close} @i{stream @r{&key} abort} @result{} @i{result} @subsubheading Arguments and Values:: @i{stream}---a @i{stream} (either @i{open} or @i{closed}). @i{abort}---a @i{generalized boolean}. The default is @i{false}. @i{result}---@b{t} if the @i{stream} was @i{open} at the time it was received as an @i{argument}, or @i{implementation-dependent} otherwise. @subsubheading Description:: @b{close} closes @i{stream}. Closing a @i{stream} means that it may no longer be used in input or output operations. The act of @i{closing} a @i{file stream} ends the association between the @i{stream} and its associated @i{file}; the transaction with the @i{file system} is terminated, and input/output may no longer be performed on the @i{stream}. If @i{abort} is @i{true}, an attempt is made to clean up any side effects of having created @i{stream}. If @i{stream} performs output to a file that was created when the @i{stream} was created, the file is deleted and any previously existing file is not superseded. It is permissible to close an already closed @i{stream}, but in that case the @i{result} is @i{implementation-dependent}. After @i{stream} is closed, it is still possible to perform the following query operations upon it: @b{streamp}, @b{pathname}, @b{truename}, @b{merge-pathnames}, @b{pathname-host}, @b{pathname-device}, @b{pathname-directory},@b{pathname-name}, @b{pathname-type}, @b{pathname-version}, @b{namestring}, @b{file-namestring}, @b{directory-namestring}, @b{host-namestring}, @b{enough-namestring}, @b{open}, @b{probe-file}, and @b{directory}. The effect of @b{close} on a @i{constructed stream} is to close the argument @i{stream} only. There is no effect on the @i{constituents} of @i{composite streams}. For a @i{stream} created with @b{make-string-output-stream}, the result of @b{get-output-stream-string} is unspecified after @b{close}. @subsubheading Examples:: @example (setq s (make-broadcast-stream)) @result{} # (close s) @result{} T (output-stream-p s) @result{} @i{true} @end example @subsubheading Side Effects:: The @i{stream} is @i{closed} (if necessary). If @i{abort} is @i{true} and the @i{stream} is an @i{output} @i{file stream}, its associated @i{file} might be deleted. @subsubheading See Also:: @ref{open} @node with-open-stream, listen, close, Streams Dictionary @subsection with-open-stream [Macro] @code{with-open-stream} @i{@r{(}var stream@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{variable} @i{name}. @i{stream}---a @i{form}; evaluated to produce a @i{stream}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{with-open-stream} performs a series of operations on @i{stream}, returns a value, and then closes the @i{stream}. @i{Var} is bound to the value of @i{stream}, and then @i{forms} are executed as an @i{implicit progn}. @i{stream} is automatically closed on exit from @b{with-open-stream}, no matter whether the exit is normal or abnormal. The @i{stream} has @i{dynamic extent}; its @i{extent} ends when the @i{form} is exited. The consequences are undefined if an attempt is made to @i{assign} the the @i{variable} @i{var} with the @i{forms}. @subsubheading Examples:: @example (with-open-stream (s (make-string-input-stream "1 2 3 4")) (+ (read s) (read s) (read s))) @result{} 6 @end example @subsubheading Side Effects:: The @i{stream} is closed (upon exit). @subsubheading See Also:: @ref{close} @node listen, clear-input, with-open-stream, Streams Dictionary @subsection listen [Function] @code{listen} @i{@r{&optional} input-stream} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if there is a character immediately available from @i{input-stream}; otherwise, returns @i{false}. On a non-interactive @i{input-stream}, @b{listen} returns @i{true} except when at @i{end of file}_1. If an @i{end of file} is encountered, @b{listen} returns @i{false}. @b{listen} is intended to be used when @i{input-stream} obtains characters from an interactive device such as a keyboard. @subsubheading Examples:: @example (progn (unread-char (read-char)) (list (listen) (read-char))) @t{ |> } @b{|>>}@t{1}@b{<<|} @result{} (T #\1) (progn (clear-input) (listen)) @result{} NIL ;Unless you're a very fast typist! @end example @subsubheading Affected By:: @b{*standard-input*} @subsubheading See Also:: @ref{interactive-stream-p} , @ref{read-char-no-hang} @node clear-input, finish-output, listen, Streams Dictionary @subsection clear-input [Function] @code{clear-input} @i{@r{&optional} input-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream designator}. The default is @i{standard input}. @subsubheading Description:: Clears any available input from @i{input-stream}. If @b{clear-input} does not make sense for @i{input-stream}, then @b{clear-input} does nothing. @subsubheading Examples:: @example ;; The exact I/O behavior of this example might vary from implementation ;; to implementation depending on the kind of interactive buffering that ;; occurs. (The call to SLEEP here is intended to help even out the ;; differences in implementations which do not do line-at-a-time buffering.) (defun read-sleepily (&optional (clear-p nil) (zzz 0)) (list (progn (print '>) (read)) ;; Note that input typed within the first ZZZ seconds ;; will be discarded. (progn (print '>) (if zzz (sleep zzz)) (print '>>) (if clear-p (clear-input)) (read)))) (read-sleepily) @t{ |> } > @b{|>>}@t{10}@b{<<|} @t{ |> } > @t{ |> } >> @b{|>>}@t{20}@b{<<|} @result{} (10 20) (read-sleepily t) @t{ |> } > @b{|>>}@t{10}@b{<<|} @t{ |> } > @t{ |> } >> @b{|>>}@t{20}@b{<<|} @result{} (10 20) (read-sleepily t 10) @t{ |> } > @b{|>>}@t{10}@b{<<|} @t{ |> } > @b{|>>}@t{20}@b{<<|} ; Some implementations won't echo typeahead here. @t{ |> } >> @b{|>>}@t{30}@b{<<|} @result{} (10 30) @end example @subsubheading Side Effects:: The @i{input-stream} is modified. @subsubheading Affected By:: @b{*standard-input*} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{input-stream} is not a @i{stream designator}. @subsubheading See Also:: @b{clear-output} @node finish-output, y-or-n-p, clear-input, Streams Dictionary @subsection finish-output, force-output, clear-output [Function] @code{finish-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} @code{force-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} @code{clear-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{output-stream}---an @i{output} @i{stream designator}. The default is @i{standard output}. @subsubheading Description:: @b{finish-output}, @b{force-output}, and @b{clear-output} exercise control over the internal handling of buffered stream output. @b{finish-output} attempts to ensure that any buffered output sent to @i{output-stream} has reached its destination, and then returns. @b{force-output} initiates the emptying of any internal buffers but does not wait for completion or acknowledgment to return. @b{clear-output} attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the destination. If any of these operations does not make sense for @i{output-stream}, then it does nothing. The precise actions of these @i{functions} are @i{implementation-dependent}. @subsubheading Examples:: @example ;; Implementation A (progn (princ "am i seen?") (clear-output)) @result{} NIL ;; Implementation B (progn (princ "am i seen?") (clear-output)) @t{ |> } am i seen? @result{} NIL @end example @subsubheading Affected By:: @b{*standard-output*} @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{output-stream} is not a @i{stream designator}. @subsubheading See Also:: @ref{clear-input} @node y-or-n-p, make-synonym-stream, finish-output, Streams Dictionary @subsection y-or-n-p, yes-or-no-p [Function] @code{y-or-n-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} @code{yes-or-no-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{control}---a @i{format control}. @i{arguments}---@i{format arguments} for @i{control}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: These functions ask a question and parse a response from the user. They return @i{true} if the answer is affirmative, or @i{false} if the answer is negative. @b{y-or-n-p} is for asking the user a question whose answer is either ``yes'' or ``no.'' It is intended that the reply require the user to answer a yes-or-no question with a single character. @b{yes-or-no-p} is also for asking the user a question whose answer is either ``Yes'' or ``No.'' It is intended that the reply require the user to take more action than just a single keystroke, such as typing the full word @t{yes} or @t{no} followed by a newline. @b{y-or-n-p} types out a message (if supplied), reads an answer in some @i{implementation-dependent} manner (intended to be short and simple, such as reading a single character such as @t{Y} or @t{N}). @b{yes-or-no-p} types out a message (if supplied), attracts the user's attention (for example, by ringing the terminal's bell), and reads an answer in some @i{implementation-dependent} manner (intended to be multiple characters, such as @t{YES} or @t{NO}). If @i{format-control} is supplied and not @b{nil}, then a @b{fresh-line} operation is performed; then a message is printed as if @i{format-control} and @i{arguments} were given to @b{format}. In any case, @b{yes-or-no-p} and @b{y-or-n-p} will provide a prompt such as ``@t{(Y or N)}'' or ``@t{(Yes or No)}'' if appropriate. All input and output are performed using @i{query I/O}. @subsubheading Examples:: @example (y-or-n-p "(t or nil) given by") @t{ |> } (t or nil) given by (Y or N) @b{|>>}@t{Y}@b{<<|} @result{} @i{true} (yes-or-no-p "a ~S message" 'frightening) @t{ |> } a FRIGHTENING message (Yes or No) @b{|>>}@t{no}@b{<<|} @result{} @i{false} (y-or-n-p "Produce listing file?") @t{ |> } Produce listing file? @t{ |> } Please respond with Y or N. @b{|>>}@t{n}@b{<<|} @result{} @i{false} @end example @subsubheading Side Effects:: Output to and input from @i{query I/O} will occur. @subsubheading Affected By:: @b{*query-io*}. @subsubheading See Also:: @ref{format} @subsubheading Notes:: @b{yes-or-no-p} and @b{yes-or-no-p} do not add question marks to the end of the prompt string, so any desired question mark or other punctuation should be explicitly included in the text query. @node make-synonym-stream, synonym-stream-symbol, y-or-n-p, Streams Dictionary @subsection make-synonym-stream [Function] @code{make-synonym-stream} @i{symbol} @result{} @i{synonym-stream} @subsubheading Arguments and Values:: @i{symbol}---a @i{symbol} that names a @i{dynamic variable}. @i{synonym-stream}---a @i{synonym stream}. @subsubheading Description:: Returns a @i{synonym stream} whose @i{synonym stream symbol} is @i{symbol}. @subsubheading Examples:: @example (setq a-stream (make-string-input-stream "a-stream") b-stream (make-string-input-stream "b-stream")) @result{} # (setq s-stream (make-synonym-stream 'c-stream)) @result{} # (setq c-stream a-stream) @result{} # (read s-stream) @result{} A-STREAM (setq c-stream b-stream) @result{} # (read s-stream) @result{} B-STREAM @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its argument is not a @i{symbol}. @subsubheading See Also:: @ref{Stream Concepts} @node synonym-stream-symbol, broadcast-stream-streams, make-synonym-stream, Streams Dictionary @subsection synonym-stream-symbol [Function] @code{synonym-stream-symbol} @i{synonym-stream} @result{} @i{symbol} @subsubheading Arguments and Values:: @i{synonym-stream}---a @i{synonym stream}. @i{symbol}---a @i{symbol}. @subsubheading Description:: Returns the @i{symbol} whose @b{symbol-value} the @i{synonym-stream} is using. @subsubheading See Also:: @ref{make-synonym-stream} @node broadcast-stream-streams, make-broadcast-stream, synonym-stream-symbol, Streams Dictionary @subsection broadcast-stream-streams [Function] @code{broadcast-stream-streams} @i{broadcast-stream} @result{} @i{streams} @subsubheading Arguments and Values:: @i{broadcast-stream}---a @i{broadcast stream}. @i{streams}---a @i{list} of @i{streams}. @subsubheading Description:: Returns a @i{list} of output @i{streams} that constitute all the @i{streams} to which the @i{broadcast-stream} is broadcasting. @node make-broadcast-stream, make-two-way-stream, broadcast-stream-streams, Streams Dictionary @subsection make-broadcast-stream [Function] @code{make-broadcast-stream} @i{@r{&rest} streams} @result{} @i{broadcast-stream} @subsubheading Arguments and Values:: @i{stream}---an @i{output} @i{stream}. @i{broadcast-stream}---a @i{broadcast stream}. @subsubheading Description:: Returns a @i{broadcast stream}. @subsubheading Examples:: @example (setq a-stream (make-string-output-stream) b-stream (make-string-output-stream)) @result{} # (format (make-broadcast-stream a-stream b-stream) "this will go to both streams") @result{} NIL (get-output-stream-string a-stream) @result{} "this will go to both streams" (get-output-stream-string b-stream) @result{} "this will go to both streams" @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if any @i{stream} is not an @i{output} @i{stream}. @subsubheading See Also:: @ref{broadcast-stream-streams} @node make-two-way-stream, two-way-stream-input-stream, make-broadcast-stream, Streams Dictionary @subsection make-two-way-stream [Function] @code{make-two-way-stream} @i{input-stream output-stream} @result{} @i{two-way-stream} @subsubheading Arguments and Values:: @i{input-stream}---a @i{stream}. @i{output-stream}---a @i{stream}. @i{two-way-stream}---a @i{two-way stream}. @subsubheading Description:: Returns a @i{two-way stream} that gets its input from @i{input-stream} and sends its output to @i{output-stream}. @subsubheading Examples:: @example (with-output-to-string (out) (with-input-from-string (in "input...") (let ((two (make-two-way-stream in out))) (format two "output...") (setq what-is-read (read two))))) @result{} "output..." what-is-read @result{} INPUT... @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{input-stream} is not an @i{input} @i{stream}. Should signal an error of @i{type} @b{type-error} if @i{output-stream} is not an @i{output} @i{stream}. @node two-way-stream-input-stream, echo-stream-input-stream, make-two-way-stream, Streams Dictionary @subsection two-way-stream-input-stream, two-way-stream-output-stream @flushright @i{[Function]} @end flushright @code{two-way-stream-input-stream} @i{two-way-stream} @result{} @i{input-stream} @code{two-way-stream-output-stream} @i{two-way-stream} @result{} @i{output-stream} @subsubheading Arguments and Values:: @i{two-way-stream}---a @i{two-way stream}. @i{input-stream}---an @i{input} @i{stream}. @i{output-stream}---an @i{output} @i{stream}. @subsubheading Description:: @b{two-way-stream-input-stream} returns the @i{stream} from which @i{two-way-stream} receives input. @b{two-way-stream-output-stream} returns the @i{stream} to which @i{two-way-stream} sends output. @node echo-stream-input-stream, make-echo-stream, two-way-stream-input-stream, Streams Dictionary @subsection echo-stream-input-stream, echo-stream-output-stream [Function] @code{echo-stream-input-stream} @i{echo-stream} @result{} @i{input-stream} @code{echo-stream-output-stream} @i{echo-stream} @result{} @i{output-stream} @subsubheading Arguments and Values:: @i{echo-stream}---an @i{echo stream}. @i{input-stream}---an @i{input} @i{stream}. @b{output-stream}---an @i{output} @i{stream}. @subsubheading Description:: @b{echo-stream-input-stream} returns the @i{input} @i{stream} from which @i{echo-stream} receives input. @b{echo-stream-output-stream} returns the @i{output} @i{stream} to which @i{echo-stream} sends output. @node make-echo-stream, concatenated-stream-streams, echo-stream-input-stream, Streams Dictionary @subsection make-echo-stream [Function] @code{make-echo-stream} @i{input-stream output-stream} @result{} @i{echo-stream} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream}. @i{output-stream}---an @i{output} @i{stream}. @i{echo-stream}---an @i{echo stream}. @subsubheading Description:: Creates and returns an @i{echo stream} that takes input from @i{input-stream} and sends output to @i{output-stream}. @subsubheading Examples:: @example (let ((out (make-string-output-stream))) (with-open-stream (s (make-echo-stream (make-string-input-stream "this-is-read-and-echoed") out)) (read s) (format s " * this-is-direct-output") (get-output-stream-string out))) @result{} "this-is-read-and-echoed * this-is-direct-output" @end example @subsubheading See Also:: @ref{echo-stream-input-stream} , @b{echo-stream-output-stream}, @ref{make-two-way-stream} @node concatenated-stream-streams, make-concatenated-stream, make-echo-stream, Streams Dictionary @subsection concatenated-stream-streams [Function] @code{concatenated-stream-streams} @i{concatenated-stream} @result{} @i{streams} @subsubheading Arguments and Values:: @i{concatenated-stream} -- a @i{concatenated stream}. @i{streams}---a @i{list} of @i{input} @i{streams}. @subsubheading Description:: Returns a @i{list} of @i{input} @i{streams} that constitute the ordered set of @i{streams} the @i{concatenated-stream} still has to read from, starting with the current one it is reading from. The list may be @i{empty} if no more @i{streams} remain to be read. The consequences are undefined if the @i{list structure} of the @i{streams} is ever modified. @node make-concatenated-stream, get-output-stream-string, concatenated-stream-streams, Streams Dictionary @subsection make-concatenated-stream [Function] @code{make-concatenated-stream} @i{@r{&rest} input-streams} @result{} @i{concatenated-stream} @subsubheading Arguments and Values:: @i{input-stream}---an @i{input} @i{stream}. @i{concatenated-stream}---a @i{concatenated stream}. @subsubheading Description:: Returns a @i{concatenated stream} that has the indicated @i{input-streams} initially associated with it. @subsubheading Examples:: @example (read (make-concatenated-stream (make-string-input-stream "1") (make-string-input-stream "2"))) @result{} 12 @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if any argument is not an @i{input} @i{stream}. @subsubheading See Also:: @ref{concatenated-stream-streams} @node get-output-stream-string, make-string-input-stream, make-concatenated-stream, Streams Dictionary @subsection get-output-stream-string [Function] @code{get-output-stream-string} @i{string-output-stream} @result{} @i{string} @subsubheading Arguments and Values:: @i{string-output-stream}---a @i{stream}. @i{string}---a @i{string}. @subsubheading Description:: Returns a @i{string} containing, in order, all the @i{characters} that have been output to @i{string-output-stream}. This operation clears any @i{characters} on @i{string-output-stream}, so the @i{string} contains only those @i{characters} which have been output since the last call to @b{get-output-stream-string} or since the creation of the @i{string-output-stream}, whichever occurred most recently. @subsubheading Examples:: @example (setq a-stream (make-string-output-stream) a-string "abcdefghijklm") @result{} "abcdefghijklm" (write-string a-string a-stream) @result{} "abcdefghijklm" (get-output-stream-string a-stream) @result{} "abcdefghijklm" (get-output-stream-string a-stream) @result{} "" @end example @subsubheading Side Effects:: The @i{string-output-stream} is cleared. @subsubheading Exceptional Situations:: The consequences are undefined if @i{stream-output-string} is @i{closed}. The consequences are undefined if @i{string-output-stream} is a @i{stream} that was not produced by @b{make-string-output-stream}. The consequences are undefined if @i{string-output-stream} was created implicitly by @b{with-output-to-string} or @b{format}. @subsubheading See Also:: @ref{make-string-output-stream} @node make-string-input-stream, make-string-output-stream, get-output-stream-string, Streams Dictionary @subsection make-string-input-stream [Function] @code{make-string-input-stream} @i{string @r{&optional} start end} @result{} @i{string-stream} @subsubheading Arguments and Values:: @i{string}---a @i{string}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{string-stream}---an @i{input} @i{string stream}. @subsubheading Description:: Returns an @i{input} @i{string stream}. This @i{stream} will supply, in order, the @i{characters} in the substring of @i{string} @i{bounded} by @i{start} and @i{end}. After the last @i{character} has been supplied, the @i{string stream} will then be at @i{end of file}. @subsubheading Examples:: @example (let ((string-stream (make-string-input-stream "1 one "))) (list (read string-stream nil nil) (read string-stream nil nil) (read string-stream nil nil))) @result{} (1 ONE NIL) (read (make-string-input-stream "prefixtargetsuffix" 6 12)) @result{} TARGET @end example @subsubheading See Also:: @ref{with-input-from-string} @node make-string-output-stream, with-input-from-string, make-string-input-stream, Streams Dictionary @subsection make-string-output-stream [Function] @code{make-string-output-stream} @i{@r{&key} element-type} @result{} @i{string-stream} @subsubheading Arguments and Values:: @i{element-type}---a @i{type specifier}. The default is @b{character}. @i{string-stream}---an @i{output} @i{string stream}. @subsubheading Description:: Returns an @i{output} @i{string stream} that accepts @i{characters} and makes available (via @b{get-output-stream-string}) a @i{string} that contains the @i{characters} that were actually output. The @i{element-type} names the @i{type} of the @i{elements} of the @i{string}; a @i{string} is constructed of the most specialized @i{type} that can accommodate @i{elements} of that @i{element-type}. @subsubheading Examples:: @example (let ((s (make-string-output-stream))) (write-string "testing... " s) (prin1 1234 s) (get-output-stream-string s)) @result{} "testing... 1234" @end example None.. @subsubheading See Also:: @ref{get-output-stream-string} , @ref{with-output-to-string} @node with-input-from-string, with-output-to-string, make-string-output-stream, Streams Dictionary @subsection with-input-from-string [Macro] @code{with-input-from-string} @i{@r{(}var string @r{&key} index start end@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{variable} @i{name}. @i{string}---a @i{form}; evaluated to produce a @i{string}. @i{index}---a @i{place}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{result}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Creates an @i{input} @i{string stream}, provides an opportunity to perform operations on the @i{stream} (returning zero or more @i{values}), and then closes the @i{string stream}. @i{String} is evaluated first, and @i{var} is bound to a character @i{input} @i{string stream} that supplies @i{characters} from the subsequence of the resulting @i{string} @i{bounded} by @i{start} and @i{end}. The body is executed as an @i{implicit progn}. The @i{input} @i{string stream} is automatically closed on exit from @b{with-input-from-string}, no matter whether the exit is normal or abnormal. The @i{input} @i{string stream} to which the @i{variable} @i{var} is @i{bound} has @i{dynamic extent}; its @i{extent} ends when the @i{form} is exited. The @i{index} is a pointer within the @i{string} to be advanced. If @b{with-input-from-string} is exited normally, then @i{index} will have as its @i{value} the index into the @i{string} indicating the first character not read which is @t{(length @i{string})} if all characters were used. The place specified by @i{index} is not updated as reading progresses, but only at the end of the operation. @i{start} and @i{index} may both specify the same variable, which is a pointer within the @i{string} to be advanced, perhaps repeatedly by some containing loop. The consequences are undefined if an attempt is made to @i{assign} the @i{variable} @i{var}. @subsubheading Examples:: @example (with-input-from-string (s "XXX1 2 3 4xxx" :index ind :start 3 :end 10) (+ (read s) (read s) (read s))) @result{} 6 ind @result{} 9 (with-input-from-string (s "Animal Crackers" :index j :start 6) (read s)) @result{} CRACKERS @end example The variable @t{j} is set to @t{15}. @subsubheading Side Effects:: The @i{value} of the @i{place} named by @i{index}, if any, is modified. @subsubheading See Also:: @ref{make-string-input-stream} , @ref{Traversal Rules and Side Effects} @node with-output-to-string, *debug-io*, with-input-from-string, Streams Dictionary @subsection with-output-to-string [Macro] @code{with-output-to-string} @i{@r{(}var @r{&optional} string-form @r{&key} element-type@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{variable} @i{name}. @i{string-form}---a @i{form} or @b{nil}; if @i{non-nil}, evaluated to produce @i{string}. @i{string}---a @i{string} that has a @i{fill pointer}. @i{element-type}---a @i{type specifier}; evaluated. The default is @b{character}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---If a @i{string-form} is not supplied or @b{nil}, a @i{string}; otherwise, the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{with-output-to-string} creates a character @i{output} @i{stream}, performs a series of operations that may send results to this @i{stream}, and then closes the @i{stream}. The @i{element-type} names the @i{type} of the elements of the @i{stream}; a @i{stream} is constructed of the most specialized @i{type} that can accommodate elements of the given @i{type}. The body is executed as an @i{implicit progn} with @i{var} bound to an @i{output} @i{string stream}. All output to that @i{string stream} is saved in a @i{string}. If @i{string} is supplied, @i{element-type} is ignored, and the output is incrementally appended to @i{string} as if by use of @b{vector-push-extend}. The @i{output} @i{stream} is automatically closed on exit from @b{with-output-from-string}, no matter whether the exit is normal or abnormal. The @i{output} @i{string stream} to which the @i{variable} @i{var} is @i{bound} has @i{dynamic extent}; its @i{extent} ends when the @i{form} is exited. If no @i{string} is provided, then @b{with-output-from-string} produces a @i{stream} that accepts characters and returns a @i{string} of the indicated @i{element-type}. If @i{string} is provided, @b{with-output-to-string} returns the results of evaluating the last @i{form}. The consequences are undefined if an attempt is made to @i{assign} the @i{variable} @i{var}. @subsubheading Examples:: @example (setq fstr (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)) @result{} "" (with-output-to-string (s fstr) (format s "here's some output") (input-stream-p s)) @result{} @i{false} fstr @result{} "here's some output" @end example @subsubheading Side Effects:: The @i{string} is modified. @subsubheading Exceptional Situations:: The consequences are undefined if destructive modifications are performed directly on the @i{string} during the @i{dynamic extent} of the call. @subsubheading See Also:: @ref{make-string-output-stream} , @b{vector-push-extend}, @ref{Traversal Rules and Side Effects} @node *debug-io*, *terminal-io*, with-output-to-string, Streams Dictionary @subsection *debug-io*, *error-output*, *query-io*, @subheading *standard-input*, *standard-output*, @subheading *trace-output* @flushright @i{[Variable]} @end flushright @subsubheading Value Type:: For @b{*standard-input*}: an @i{input} @i{stream} For @b{*error-output*}, @b{*standard-output*}, and @b{*trace-output*}: an @i{output} @i{stream}. For @b{*debug-io*}, @b{*query-io*}: a @i{bidirectional} @i{stream}. @subsubheading Initial Value:: @i{implementation-dependent}, but it must be an @i{open} @i{stream} that is not a @i{generalized synonym stream} to an @i{I/O customization variables} but that might be a @i{generalized synonym stream} to the value of some @i{I/O customization variable}. The initial value might also be a @i{generalized synonym stream} to either the @i{symbol} @b{*terminal-io*} or to the @i{stream} that is its @i{value}. @subsubheading Description:: These @i{variables} are collectively called the @i{standardized} @i{I/O customization variables}. They can be @i{bound} or @i{assigned} in order to change the default destinations for input and/or output used by various @i{standardized} @i{operators} and facilities. The @i{value} of @b{*debug-io*}, called @i{debug I/O}, is a @i{stream} to be used for interactive debugging purposes. The @i{value} of @b{*error-output*}, called @i{error output}, is a @i{stream} to which warnings and non-interactive error messages should be sent. The @i{value} of @b{*query-io*}, called @i{query I/O}, is a @i{bidirectional} @i{stream} to be used when asking questions of the user. The question should be output to this @i{stream}, and the answer read from it. The @i{value} of @b{*standard-input*}, called @i{standard input}, is a @i{stream} that is used by many @i{operators} as a default source of input when no specific @i{input} @i{stream} is explicitly supplied. The @i{value} of @b{*standard-output*}, called @i{standard output}, is a @i{stream} that is used by many @i{operators} as a default destination for output when no specific @i{output} @i{stream} is explicitly supplied. The @i{value} of @b{*trace-output*}, called @i{trace output}, is the @i{stream} on which traced functions (see @b{trace}) and the @b{time} @i{macro} print their output. @subsubheading Examples:: @example (with-output-to-string (*error-output*) (warn "this string is sent to *error-output*")) @result{} "Warning: this string is sent to *error-output* " ;The exact format of this string is @i{implementation-dependent}. (with-input-from-string (*standard-input* "1001") (+ 990 (read))) @result{} 1991 (progn (setq out (with-output-to-string (*standard-output*) (print "print and format t send things to") (format t "*standard-output* now going to a string"))) :done) @result{} :DONE out @result{} " \"print and format t send things to\" *standard-output* now going to a string" (defun fact (n) (if (< n 2) 1 (* n (fact (- n 1))))) @result{} FACT (trace fact) @result{} (FACT) ;; Of course, the format of traced output is implementation-dependent. (with-output-to-string (*trace-output*) (fact 3)) @result{} " 1 Enter FACT 3 | 2 Enter FACT 2 | 3 Enter FACT 1 | 3 Exit FACT 1 | 2 Exit FACT 2 1 Exit FACT 6" @end example @subsubheading See Also:: @b{*terminal-io*}, @b{synonym-stream}, @ref{Time} , @ref{trace} , @ref{Conditions}, @ref{Reader}, @ref{Printer} @subsubheading Notes:: The intent of the constraints on the initial @i{value} of the @i{I/O customization variables} is to ensure that it is always safe to @i{bind} or @i{assign} such a @i{variable} to the @i{value} of another @i{I/O customization variable}, without unduly restricting @i{implementation} flexibility. It is common for an @i{implementation} to make the initial @i{values} of @b{*debug-io*} and @b{*query-io*} be the @i{same} @i{stream}, and to make the initial @i{values} of @b{*error-output*} and @b{*standard-output*} be the @i{same} @i{stream}. The functions @b{y-or-n-p} and @b{yes-or-no-p} use @i{query I/O} for their input and output. In the normal @i{Lisp read-eval-print loop}, input is read from @i{standard input}. Many input functions, including @b{read} and @b{read-char}, take a @i{stream} argument that defaults to @i{standard input}. In the normal @i{Lisp read-eval-print loop}, output is sent to @i{standard output}. Many output functions, including @b{print} and @b{write-char}, take a @i{stream} argument that defaults to @i{standard output}. A program that wants, for example, to divert output to a file should do so by @i{binding} @b{*standard-output*}; that way error messages sent to @b{*error-output*} can still get to the user by going through @b{*terminal-io*} (if @b{*error-output*} is bound to @b{*terminal-io*}), which is usually what is desired. @node *terminal-io*, stream-error, *debug-io*, Streams Dictionary @subsection *terminal-io* [Variable] @subsubheading Value Type:: a @i{bidirectional} @i{stream}. @subsubheading Initial Value:: @i{implementation-dependent}, but it must be an @i{open} @i{stream} that is not a @i{generalized synonym stream} to an @i{I/O customization variables} but that might be a @i{generalized synonym stream} to the @i{value} of some @i{I/O customization variable}. @subsubheading Description:: The @i{value} of @b{*terminal-io*}, called @i{terminal I/O}, is ordinarily a @i{bidirectional} @i{stream} that connects to the user's console. Typically, writing to this @i{stream} would cause the output to appear on a display screen, for example, and reading from the @i{stream} would accept input from a keyboard. It is intended that standard input functions such as @b{read} and @b{read-char}, when used with this @i{stream}, cause echoing of the input into the output side of the @i{stream}. The means by which this is accomplished are @i{implementation-dependent}. The effect of changing the @i{value} of @b{*terminal-io*}, either by @i{binding} or @i{assignment}, is @i{implementation-defined}. @subsubheading Examples:: @example (progn (prin1 'foo) (prin1 'bar *terminal-io*)) @t{ |> } FOOBAR @result{} BAR (with-output-to-string (*standard-output*) (prin1 'foo) (prin1 'bar *terminal-io*)) @t{ |> } BAR @result{} "FOO" @end example @subsubheading See Also:: @b{*debug-io*}, @b{*error-output*}, @b{*query-io*}, @b{*standard-input*}, @b{*standard-output*}, @b{*trace-output*} @node stream-error, stream-error-stream, *terminal-io*, Streams Dictionary @subsection stream-error [Condition Type] @subsubheading Class Precedence List:: @b{stream-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{stream-error} consists of error conditions that are related to receiving input from or sending output to a @i{stream}. The ``offending stream'' is initialized by the @t{:stream} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{stream-error-stream}. @subsubheading See Also:: @ref{stream-error-stream} @node stream-error-stream, end-of-file, stream-error, Streams Dictionary @subsection stream-error-stream [Function] @code{stream-error-stream} @i{condition} @result{} @i{stream} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{stream-error}. @i{stream}---a @i{stream}. @subsubheading Description:: Returns the offending @i{stream} of a @i{condition} of @i{type} @b{stream-error}. @subsubheading Examples:: @example (with-input-from-string (s "(FOO") (handler-case (read s) (end-of-file (c) (format nil "~&End of file on ~S." (stream-error-stream c))))) "End of file on #." @end example @subsubheading See Also:: @b{stream-error}, @ref{Conditions} @node end-of-file, , stream-error-stream, Streams Dictionary @subsection end-of-file [Condition Type] @subsubheading Class Precedence List:: @b{end-of-file}, @b{stream-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{end-of-file} consists of error conditions related to read operations that are done on @i{streams} that have no more data. @subsubheading See Also:: @ref{stream-error-stream} @c end of including dict-streams @c %**end of chapter gcl-2.6.14/info/chap-9.texi0000644000175000017500000043234214360276512013712 0ustar cammcamm @node Conditions, Symbols, Structures, Top @chapter Conditions @menu * Condition System Concepts:: * Conditions Dictionary:: @end menu @node Condition System Concepts, Conditions Dictionary, Conditions, Conditions @section Condition System Concepts @c including concept-conditions Common Lisp constructs are described not only in terms of their behavior in situations during which they are intended to be used (see the ``Description'' part of each @i{operator} specification), but in all other situations (see the ``Exceptional Situations'' part of each @i{operator} specification). A situation is the evaluation of an expression in a specific context. A @i{condition} is an @i{object} that represents a specific situation that has been detected. @i{Conditions} are @i{generalized instances} of the @i{class} @b{condition}. A hierarchy of @i{condition} classes is defined in @r{Common Lisp}. A @i{condition} has @i{slots} that contain data relevant to the situation that the @i{condition} represents. An error is a situation in which normal program execution cannot continue correctly without some form of intervention (either interactively by the user or under program control). Not all errors are detected. When an error goes undetected, the effects can be @i{implementation-dependent}, @i{implementation-defined}, unspecified, or undefined. See @ref{Definitions}. All detected errors can be represented by @i{conditions}, but not all @i{conditions} represent errors. Signaling is the process by which a @i{condition} can alter the flow of control in a program by raising the @i{condition} which can then be @i{handled}. The functions @b{error}, @b{cerror}, @b{signal}, and @b{warn} are used to signal @i{conditions}. The process of signaling involves the selection and invocation of a @i{handler} from a set of @i{active} @i{handlers}. A @i{handler} is a @i{function} of one argument (the @i{condition}) that is invoked to handle a @i{condition}. Each @i{handler} is associated with a @i{condition} @i{type}, and a @i{handler} will be invoked only on a @i{condition} of the @i{handler}'s associated @i{type}. @i{Active} @i{handlers} are @i{established} dynamically (see @b{handler-bind} or @b{handler-case}). @i{Handlers} are invoked in a @i{dynamic environment} equivalent to that of the signaler, except that the set of @i{active} @i{handlers} is bound in such a way as to include only those that were @i{active} at the time the @i{handler} being invoked was @i{established}. Signaling a @i{condition} has no side-effect on the @i{condition}, and there is no dynamic state contained in a @i{condition}. If a @i{handler} is invoked, it can address the @i{situation} in one of three ways: @table @asis @item @b{Decline} It can decline to @i{handle} the @i{condition}. It does this by simply returning rather than transferring control. When this happens, any values returned by the handler are ignored and the next most recently established handler is invoked. If there is no such handler and the signaling function is @b{error} or @b{cerror}, the debugger is entered in the @i{dynamic environment} of the signaler. If there is no such handler and the signaling function is either @b{signal} or @b{warn}, the signaling function simply returns~@b{nil}. @item @b{Handle} It can @i{handle} the @i{condition} by performing a non-local transfer of control. This can be done either primitively by using @b{go}, @b{return}, @b{throw} or more abstractly by using a function such as @b{abort} or @b{invoke-restart}. @item @b{Defer} It can put off a decision about whether to @i{handle} or @i{decline}, by any of a number of actions, but most commonly by signaling another condition, resignaling the same condition, or forcing entry into the debugger. @end table @menu * Condition Types:: * Creating Conditions:: * Printing Conditions:: * Signaling and Handling Conditions:: * Assertions:: * Notes about the Condition System`s Background:: @end menu @node Condition Types, Creating Conditions, Condition System Concepts, Condition System Concepts @subsection Condition Types Figure 9--1 lists the @i{standardized} @i{condition} @i{types}. Additional @i{condition} @i{types} can be defined by using @b{define-condition}. @format @group @noindent @w{ arithmetic-error floating-point-overflow simple-type-error } @w{ cell-error floating-point-underflow simple-warning } @w{ condition package-error storage-condition } @w{ control-error parse-error stream-error } @w{ division-by-zero print-not-readable style-warning } @w{ end-of-file program-error type-error } @w{ error reader-error unbound-slot } @w{ file-error serious-condition unbound-variable } @w{ floating-point-inexact simple-condition undefined-function } @w{ floating-point-invalid-operation simple-error warning } @noindent @w{ Figure 9--1: Standardized Condition Types } @end group @end format All @i{condition} types are @i{subtypes} of @i{type} @b{condition}. That is, @example (typep @i{c} 'condition) @result{} @i{true} @end example if and only if @i{c} is a @i{condition}. @i{Implementations} must define all specified @i{subtype} relationships. Except where noted, all @i{subtype} relationships indicated in this document are not mutually exclusive. A @i{condition} inherits the structure of its @i{supertypes}. The metaclass of the @i{class} @b{condition} is not specified. @i{Names} of @i{condition} @i{types} may be used to specify @i{supertype} relationships in @b{define-condition}, but the consequences are not specified if an attempt is made to use a @i{condition} @i{type} as a @i{superclass} in a @b{defclass} @i{form}. Figure 9--2 shows @i{operators} that define @i{condition} @i{types} and creating @i{conditions}. @format @group @noindent @w{ define-condition make-condition } @noindent @w{ Figure 9--2: Operators that define and create conditions.} @end group @end format Figure 9--3 shows @i{operators} that @i{read} the @i{value} of @i{condition} @i{slots}. @format @group @noindent @w{ arithmetic-error-operands simple-condition-format-arguments } @w{ arithmetic-error-operation simple-condition-format-control } @w{ cell-error-name stream-error-stream } @w{ file-error-pathname type-error-datum } @w{ package-error-package type-error-expected-type } @w{ print-not-readable-object unbound-slot-instance } @noindent @w{ Figure 9--3: Operators that read condition slots. } @end group @end format @menu * Serious Conditions:: @end menu @node Serious Conditions, , Condition Types, Condition Types @subsubsection Serious Conditions A @i{serious condition} is a @i{condition} serious enough to require interactive intervention if not handled. @i{Serious conditions} are typically signaled with @b{error} or @b{cerror}; non-serious @i{conditions} are typically signaled with @b{signal} or @b{warn}. @node Creating Conditions, Printing Conditions, Condition Types, Condition System Concepts @subsection Creating Conditions The function @b{make-condition} can be used to construct a @i{condition} @i{object} explicitly. Functions such as @b{error}, @b{cerror}, @b{signal}, and @b{warn} operate on @i{conditions} and might create @i{condition} @i{objects} implicitly. Macros such as @b{ccase}, @b{ctypecase}, @b{ecase}, @b{etypecase}, @b{check-type}, and @b{assert} might also implicitly create (and @i{signal}) @i{conditions}. @menu * Condition Designators:: @end menu @node Condition Designators, , Creating Conditions, Creating Conditions @subsubsection Condition Designators A number of the functions in the condition system take arguments which are identified as @i{condition designators} @IGindex condition designator . By convention, those arguments are notated as @i{datum} @r{&rest} @i{arguments} Taken together, the @i{datum} and the @i{arguments} are ``@i{designators} for a @i{condition} of default type @i{default-type}.'' How the denoted @i{condition} is computed depends on the type of the @i{datum}: @table @asis @item @t{*} If the @i{datum} is a @i{symbol} naming a @i{condition} @i{type} ... The denoted @i{condition} is the result of @example (apply #'make-condition @i{datum} @i{arguments}) @end example @item @t{*} If the @i{datum} is a @i{format control} ... The denoted @i{condition} is the result of @example (make-condition @i{defaulted-type} :format-control @i{datum} :format-arguments @i{arguments}) @end example where the @i{defaulted-type} is a @i{subtype} of @i{default-type}. @item @t{*} If the @i{datum} is a @i{condition} ... The denoted @i{condition} is the @i{datum} itself. In this case, unless otherwise specified by the description of the @i{operator} in question, the @i{arguments} must be @i{null}; that is, the consequences are undefined if any @i{arguments} were supplied. @end table Note that the @i{default-type} gets used only in the case where the @i{datum} @i{string} is supplied. In the other situations, the resulting condition is not necessarily of @i{type} @i{default-type}. Here are some illustrations of how different @i{condition designators} can denote equivalent @i{condition} @i{objects}: @example (let ((c (make-condition 'arithmetic-error :operator '/ :operands '(7 0)))) (error c)) @equiv{} (error 'arithmetic-error :operator '/ :operands '(7 0)) (error "Bad luck.") @equiv{} (error 'simple-error :format-control "Bad luck." :format-arguments '()) @end example @node Printing Conditions, Signaling and Handling Conditions, Creating Conditions, Condition System Concepts @subsection Printing Conditions If the @t{:report} argument to @b{define-condition} is used, a print function is defined that is called whenever the defined @i{condition} is printed while the @i{value} of @b{*print-escape*} is @i{false}. This function is called the @i{condition reporter} @IGindex condition reporter ; the text which it outputs is called a @i{report message} @IGindex report message . When a @i{condition} is printed and @b{*print-escape*} is @i{false}, the @i{condition reporter} for the @i{condition} is invoked. @i{Conditions} are printed automatically by functions such as @b{invoke-debugger}, @b{break}, and @b{warn}. When @b{*print-escape*} is @i{true}, the @i{object} should print in an abbreviated fashion according to the style of the implementation (@i{e.g.}, by @b{print-unreadable-object}). It is not required that a @i{condition} can be recreated by reading its printed representation. No @i{function} is provided for directly @i{accessing} or invoking @i{condition reporters}. @menu * Recommended Style in Condition Reporting:: * Capitalization and Punctuation in Condition Reports:: * Leading and Trailing Newlines in Condition Reports:: * Embedded Newlines in Condition Reports:: * Note about Tabs in Condition Reports:: * Mentioning Containing Function in Condition Reports:: @end menu @node Recommended Style in Condition Reporting, Capitalization and Punctuation in Condition Reports, Printing Conditions, Printing Conditions @subsubsection Recommended Style in Condition Reporting In order to ensure a properly aesthetic result when presenting @i{report messages} to the user, certain stylistic conventions are recommended. There are stylistic recommendations for the content of the messages output by @i{condition reporters}, but there are no formal requirements on those @i{programs}. If a @i{program} violates the recommendations for some message, the display of that message might be less aesthetic than if the guideline had been observed, but the @i{program} is still considered a @i{conforming program}. The requirements on a @i{program} or @i{implementation} which invokes a @i{condition reporter} are somewhat stronger. A @i{conforming program} must be permitted to assume that if these style guidelines are followed, proper aesthetics will be maintained. Where appropriate, any specific requirements on such routines are explicitly mentioned below. @node Capitalization and Punctuation in Condition Reports, Leading and Trailing Newlines in Condition Reports, Recommended Style in Condition Reporting, Printing Conditions @subsubsection Capitalization and Punctuation in Condition Reports It is recommended that a @i{report message} be a complete sentences, in the proper case and correctly punctuated. In English, for example, this means the first letter should be uppercase, and there should be a trailing period. @example (error "This is a message") ; Not recommended (error "this is a message.") ; Not recommended (error "This is a message.") ; Recommended instead @end example @node Leading and Trailing Newlines in Condition Reports, Embedded Newlines in Condition Reports, Capitalization and Punctuation in Condition Reports, Printing Conditions @subsubsection Leading and Trailing Newlines in Condition Reports It is recommended that a @i{report message} not begin with any introductory text, such as ``@t{Error: }'' or ``@t{Warning: }'' or even just @i{freshline} or @i{newline}. Such text is added, if appropriate to the context, by the routine invoking the @i{condition reporter}. It is recommended that a @i{report message} not be followed by a trailing @i{freshline} or @i{newline}. Such text is added, if appropriate to the context, by the routine invoking the @i{condition reporter}. @example (error "This is a message.~ (error "~&This is a message.") ; Not recommended (error "~&This is a message.~ (error "This is a message.") ; Recommended instead @end example @node Embedded Newlines in Condition Reports, Note about Tabs in Condition Reports, Leading and Trailing Newlines in Condition Reports, Printing Conditions @subsubsection Embedded Newlines in Condition Reports Especially if it is long, it is permissible and appropriate for a @i{report message} to contain one or more embedded @i{newlines}. If the calling routine conventionally inserts some additional prefix (such as ``@t{Error: }'' or ``@t{;; Error: }'') on the first line of the message, it must also assure that an appropriate prefix will be added to each subsequent line of the output, so that the left edge of the message output by the @i{condition reporter} will still be properly aligned. @example (defun test () (error "This is an error message.~%It has two lines.")) ;; Implementation A (test) This is an error message. It has two lines. ;; Implementation B (test) ;; Error: This is an error message. ;; It has two lines. ;; Implementation C (test) >> Error: This is an error message. It has two lines. @end example @node Note about Tabs in Condition Reports, Mentioning Containing Function in Condition Reports, Embedded Newlines in Condition Reports, Printing Conditions @subsubsection Note about Tabs in Condition Reports Because the indentation of a @i{report message} might be shifted to the right or left by an arbitrary amount, special care should be taken with the semi-standard @i{character} <@i{Tab}> (in those @i{implementations} that support such a @i{character}). Unless the @i{implementation} specifically defines its behavior in this context, its use should be avoided. @node Mentioning Containing Function in Condition Reports, , Note about Tabs in Condition Reports, Printing Conditions @subsubsection Mentioning Containing Function in Condition Reports The name of the containing function should generally not be mentioned in @i{report messages}. It is assumed that the @i{debugger} will make this information accessible in situations where it is necessary and appropriate. @node Signaling and Handling Conditions, Assertions, Printing Conditions, Condition System Concepts @subsection Signaling and Handling Conditions The operation of the condition system depends on the ordering of active @i{applicable handlers} from most recent to least recent. Each @i{handler} is associated with a @i{type specifier} that must designate a @i{subtype} of @i{type} @b{condition}. A @i{handler} is said to be @i{applicable} to a @i{condition} if that @i{condition} is of the @i{type} designated by the associated @i{type specifier}. @i{Active} @i{handlers} are @i{established} by using @b{handler-bind} (or an abstraction based on @b{handler-bind}, such as @b{handler-case} or @b{ignore-errors}). @i{Active} @i{handlers} can be @i{established} within the dynamic scope of other @i{active} @i{handlers}. At any point during program execution, there is a set of @i{active} @i{handlers}. When a @i{condition} is signaled, the @i{most recent} active @i{applicable handler} for that @i{condition} is selected from this set. Given a @i{condition}, the order of recentness of active @i{applicable handlers} is defined by the following two rules: @table @asis @item 1. Each handler in a set of active handlers H_1 is more recent than every handler in a set H_2 if the handlers in H_2 were active when the handlers in H_1 were established. @item 2. Let h_1 and h_2 be two applicable active handlers established by the same @i{form}. Then h_1 is more recent than h_2 if h_1 was defined to the left of h_2 in the @i{form} that established them. @end table Once a handler in a handler binding @i{form} (such as @b{handler-bind} or @b{handler-case}) has been selected, all handlers in that @i{form} become inactive for the remainder of the signaling process. While the selected @i{handler} runs, no other @i{handler} established by that @i{form} is active. That is, if the @i{handler} declines, no other handler established by that @i{form} will be considered for possible invocation. Figure 9--4 shows @i{operators} relating to the @i{handling} of @i{conditions}. @format @group @noindent @w{ handler-bind handler-case ignore-errors } @noindent @w{ Figure 9--4: Operators relating to handling conditions.} @end group @end format @menu * Signaling:: * Resignaling a Condition:: * Restarts:: * Interactive Use of Restarts:: * Interfaces to Restarts:: * Restart Tests:: * Associating a Restart with a Condition:: @end menu @node Signaling, Resignaling a Condition, Signaling and Handling Conditions, Signaling and Handling Conditions @subsubsection Signaling When a @i{condition} is signaled, the most recent applicable @i{active} @i{handler} is invoked. Sometimes a handler will decline by simply returning without a transfer of control. In such cases, the next most recent applicable active handler is invoked. If there are no applicable handlers for a @i{condition} that has been signaled, or if all applicable handlers decline, the @i{condition} is unhandled. The functions @b{cerror} and @b{error} invoke the interactive @i{condition} handler (the debugger) rather than return if the @i{condition} being signaled, regardless of its @i{type}, is unhandled. In contrast, @b{signal} returns @b{nil} if the @i{condition} being signaled, regardless of its @i{type}, is unhandled. The @i{variable} @b{*break-on-signals*} can be used to cause the debugger to be entered before the signaling process begins. Figure 9--5 shows @i{defined names} relating to the @i{signaling} of @i{conditions}. @format @group @noindent @w{ *break-on-signals* error warn } @w{ cerror signal } @noindent @w{ Figure 9--5: Defined names relating to signaling conditions.} @end group @end format @node Resignaling a Condition, Restarts, Signaling, Signaling and Handling Conditions @subsubsection Resignaling a Condition During the @i{dynamic extent} of the @i{signaling} process for a particular @i{condition} @i{object}, @b{signaling} the same @i{condition} @i{object} again is permitted if and only if the @i{situation} represented in both cases are the same. For example, a @i{handler} might legitimately @i{signal} the @i{condition} @i{object} that is its @i{argument} in order to allow outer @i{handlers} first opportunity to @i{handle} the condition. (Such a @i{handlers} is sometimes called a ``default handler.'') This action is permitted because the @i{situation} which the second @i{signaling} process is addressing is really the same @i{situation}. On the other hand, in an @i{implementation} that implemented asynchronous keyboard events by interrupting the user process with a call to @b{signal}, it would not be permissible for two distinct asynchronous keyboard events to @i{signal} @i{identical} @i{condition} @i{objects} at the same time for different situations. @node Restarts, Interactive Use of Restarts, Resignaling a Condition, Signaling and Handling Conditions @subsubsection Restarts The interactive condition handler returns only through non-local transfer of control to specially defined @i{restarts} that can be set up either by the system or by user code. Transferring control to a restart is called ``invoking'' the restart. Like handlers, active @i{restarts} are @i{established} dynamically, and only active @i{restarts} can be invoked. An active @i{restart} can be invoked by the user from the debugger or by a program by using @b{invoke-restart}. A @i{restart} contains a @i{function} to be @i{called} when the @i{restart} is invoked, an optional name that can be used to find or invoke the @i{restart}, and an optional set of interaction information for the debugger to use to enable the user to manually invoke a @i{restart}. The name of a @i{restart} is used by @b{invoke-restart}. @i{Restarts} that can be invoked only within the debugger do not need names. @i{Restarts} can be established by using @b{restart-bind}, @b{restart-case}, and @b{with-simple-restart}. A @i{restart} function can itself invoke any other @i{restart} that was active at the time of establishment of the @i{restart} of which the @i{function} is part. The @i{restarts} @i{established} by a @b{restart-bind} @i{form}, a @b{restart-case} @i{form}, or a @b{with-simple-restart} @i{form} have @i{dynamic extent} which extends for the duration of that @i{form}'s execution. @i{Restarts} of the same name can be ordered from least recent to most recent according to the following two rules: @table @asis @item 1. Each @i{restart} in a set of active restarts R_1 is more recent than every @i{restart} in a set R_2 if the @i{restarts} in R_2 were active when the @i{restarts} in R_1 were established. @item 2. Let r_1 and r_2 be two active @i{restarts} with the same name established by the same @i{form}. Then r_1 is more recent than r_2 if r_1 was defined to the left of r_2 in the @i{form} that established them. @end table If a @i{restart} is invoked but does not transfer control, the values resulting from the @i{restart} function are returned by the function that invoked the restart, either @b{invoke-restart} or @b{invoke-restart-interactively}. @node Interactive Use of Restarts, Interfaces to Restarts, Restarts, Signaling and Handling Conditions @subsubsection Interactive Use of Restarts For interactive handling, two pieces of information are needed from a @i{restart}: a report function and an interactive function. The report function is used by a program such as the debugger to present a description of the action the @i{restart} will take. The report function is specified and established by the @t{:report-function} keyword to @b{restart-bind} or the @t{:report} keyword to @b{restart-case}. The interactive function, which can be specified using the @t{:interactive-function} keyword to @b{restart-bind} or @t{:interactive} keyword to @b{restart-case}, is used when the @i{restart} is invoked interactively, such as from the debugger, to produce a suitable list of arguments. @b{invoke-restart} invokes the most recently @i{established} @i{restart} whose name is the same as the first argument to @b{invoke-restart}. If a @i{restart} is invoked interactively by the debugger and does not transfer control but rather returns values, the precise action of the debugger on those values is @i{implementation-defined}. @node Interfaces to Restarts, Restart Tests, Interactive Use of Restarts, Signaling and Handling Conditions @subsubsection Interfaces to Restarts Some @i{restarts} have functional interfaces, such as @b{abort}, @b{continue}, @b{muffle-warning}, @b{store-value}, and @b{use-value}. They are ordinary functions that use @b{find-restart} and @b{invoke-restart} internally, that have the same name as the @i{restarts} they manipulate, and that are provided simply for notational convenience. Figure 9--6 shows @i{defined names} relating to @i{restarts}. @format @group @noindent @w{ abort invoke-restart-interactively store-value } @w{ compute-restarts muffle-warning use-value } @w{ continue restart-bind with-simple-restart } @w{ find-restart restart-case } @w{ invoke-restart restart-name } @noindent @w{ Figure 9--6: Defined names relating to restarts. } @end group @end format @node Restart Tests, Associating a Restart with a Condition, Interfaces to Restarts, Signaling and Handling Conditions @subsubsection Restart Tests Each @i{restart} has an associated test, which is a function of one argument (a @i{condition} or @b{nil}) which returns @i{true} if the @i{restart} should be visible in the current @i{situation}. This test is created by the @t{:test-function} option to @b{restart-bind} or the @t{:test} option to @b{restart-case}. @node Associating a Restart with a Condition, , Restart Tests, Signaling and Handling Conditions @subsubsection Associating a Restart with a Condition A @i{restart} can be ``associated with'' a @i{condition} explicitly by @b{with-condition-restarts}, or implicitly by @b{restart-case}. Such an assocation has @i{dynamic extent}. A single @i{restart} may be associated with several @i{conditions} at the same time. A single @i{condition} may have several associated @i{restarts} at the same time. Active restarts associated with a particular @i{condition} can be detected by @i{calling} a @i{function} such as @b{find-restart}, supplying that @i{condition} as the @i{condition} @i{argument}. Active restarts can also be detected without regard to any associated @i{condition} by calling such a function without a @i{condition} @i{argument}, or by supplying a value of @b{nil} for such an @i{argument}. @node Assertions, Notes about the Condition System`s Background, Signaling and Handling Conditions, Condition System Concepts @subsection Assertions Conditional signaling of @i{conditions} based on such things as key match, form evaluation, and @i{type} are handled by assertion @i{operators}. Figure 9--7 shows @i{operators} relating to assertions. @format @group @noindent @w{ assert check-type ecase } @w{ ccase ctypecase etypecase } @noindent @w{ Figure 9--7: Operators relating to assertions.} @end group @end format @node Notes about the Condition System`s Background, , Assertions, Condition System Concepts @subsection Notes about the Condition System`s Background For a background reference to the abstract concepts detailed in this section, see @i{Exceptional Situations in Lisp}. The details of that paper are not binding on this document, but may be helpful in establishing a conceptual basis for understanding this material. @c end of including concept-conditions @node Conditions Dictionary, , Condition System Concepts, Conditions @section Conditions Dictionary @c including dict-conditions @menu * condition:: * warning:: * style-warning:: * serious-condition:: * error (Condition Type):: * cell-error:: * cell-error-name:: * parse-error:: * storage-condition:: * assert:: * error:: * cerror:: * check-type:: * simple-error:: * invalid-method-error:: * method-combination-error:: * signal:: * simple-condition:: * simple-condition-format-control:: * warn:: * simple-warning:: * invoke-debugger:: * break:: * *debugger-hook*:: * *break-on-signals*:: * handler-bind:: * handler-case:: * ignore-errors:: * define-condition:: * make-condition:: * restart:: * compute-restarts:: * find-restart:: * invoke-restart:: * invoke-restart-interactively:: * restart-bind:: * restart-case:: * restart-name:: * with-condition-restarts:: * with-simple-restart:: * abort (Restart):: * continue:: * muffle-warning:: * store-value:: * use-value:: * abort (Function):: @end menu @node condition, warning, Conditions Dictionary, Conditions Dictionary @subsection condition [Condition Type] [Reviewer Note by Barrett: I think CONDITION-RESTARTS is not fully integrated.] @subsubheading Class Precedence List:: @b{condition}, @b{t} @subsubheading Description:: All types of @i{conditions}, whether error or non-error, must inherit from this @i{type}. No additional @i{subtype} relationships among the specified @i{subtypes} of @i{type} @b{condition} are allowed, except when explicitly mentioned in the text; however implementations are permitted to introduce additional @i{types} and one of these @i{types} can be a @i{subtype} of any number of the @i{subtypes} of @i{type} @b{condition}. Whether a user-defined @i{condition} @i{type} has @i{slots} that are accessible by @i{with-slots} is @i{implementation-dependent}. Furthermore, even in an @i{implementation} in which user-defined @i{condition} @i{types} would have @i{slots}, it is @i{implementation-dependent} whether any @i{condition} @i{types} defined in this document have such @i{slots} or, if they do, what their @i{names} might be; only the reader functions documented by this specification may be relied upon by portable code. @i{Conforming code} must observe the following restrictions related to @i{conditions}: @table @asis @item @t{*} @b{define-condition}, not @b{defclass}, must be used to define new @i{condition} @i{types}. @item @t{*} @b{make-condition}, not @b{make-instance}, must be used to create @i{condition} @i{objects} explicitly. @item @t{*} The @t{:report} option of @b{define-condition}, not @b{defmethod} for @b{print-object}, must be used to define a condition reporter. @item @t{*} @b{slot-value}, @b{slot-boundp}, @b{slot-makunbound}, and @b{with-slots} must not be used on @i{condition} @i{objects}. Instead, the appropriate accessor functions (defined by @b{define-condition}) should be used. @end table @node warning, style-warning, condition, Conditions Dictionary @subsection warning [Condition Type] @subsubheading Class Precedence List:: @b{warning}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{warning} consists of all types of warnings. @subsubheading See Also:: @b{style-warning} @node style-warning, serious-condition, warning, Conditions Dictionary @subsection style-warning [Condition Type] @subsubheading Class Precedence List:: @b{style-warning}, @b{warning}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{style-warning} includes those @i{conditions} that represent @i{situations} involving @i{code} that is @i{conforming code} but that is nevertheless considered to be faulty or substandard. @subsubheading See Also:: @ref{muffle-warning} @subsubheading Notes:: An @i{implementation} might signal such a @i{condition} if it encounters @i{code} that uses deprecated features or that appears unaesthetic or inefficient. An `unused variable' warning must be of @i{type} @b{style-warning}. In general, the question of whether @i{code} is faulty or substandard is a subjective decision to be made by the facility processing that @i{code}. The intent is that whenever such a facility wishes to complain about @i{code} on such subjective grounds, it should use this @i{condition} @i{type} so that any clients who wish to redirect or muffle superfluous warnings can do so without risking that they will be redirecting or muffling other, more serious warnings. @node serious-condition, error (Condition Type), style-warning, Conditions Dictionary @subsection serious-condition [Condition Type] @subsubheading Class Precedence List:: @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: All @i{conditions} serious enough to require interactive intervention if not handled should inherit from the @i{type} @b{serious-condition}. This condition type is provided primarily so that it may be included as a @i{superclass} of other @i{condition} @i{types}; it is not intended to be signaled directly. @subsubheading Notes:: Signaling a @i{serious condition} does not itself force entry into the debugger. However, except in the unusual situation where the programmer can assure that no harm will come from failing to @i{handle} a @i{serious condition}, such a @i{condition} is usually signaled with @b{error} rather than @b{signal} in order to assure that the program does not continue without @i{handling} the @i{condition}. (And conversely, it is conventional to use @b{signal} rather than @b{error} to signal conditions which are not @i{serious conditions}, since normally the failure to handle a non-serious condition is not reason enough for the debugger to be entered.) @node error (Condition Type), cell-error, serious-condition, Conditions Dictionary @subsection error [Condition Type] @subsubheading Class Precedence List:: @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{error} consists of all @i{conditions} that represent @i{errors}. @node cell-error, cell-error-name, error (Condition Type), Conditions Dictionary @subsection cell-error [Condition Type] @subsubheading Class Precedence List:: @b{cell-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{cell-error} consists of error conditions that occur during a location @i{access}. The name of the offending cell is initialized by the @t{:name} initialization argument to @b{make-condition}, and is @i{accessed} by the @i{function} @b{cell-error-name}. @subsubheading See Also:: @ref{cell-error-name} @node cell-error-name, parse-error, cell-error, Conditions Dictionary @subsection cell-error-name [Function] @code{cell-error-name} @i{condition} @result{} @i{name} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{cell-error}. @i{name}---an @i{object}. @subsubheading Description:: Returns the @i{name} of the offending cell involved in the @i{situation} represented by @i{condition}. The nature of the result depends on the specific @i{type} of @i{condition}. For example, if the @i{condition} is of @i{type} @b{unbound-variable}, the result is the @i{name} of the @i{unbound variable} which was being @i{accessed}, if the @i{condition} is of @i{type} @b{undefined-function}, this is the @i{name} of the @i{undefined function} which was being @i{accessed}, and if the @i{condition} is of @i{type} @b{unbound-slot}, this is the @i{name} of the @i{slot} which was being @i{accessed}. @subsubheading See Also:: @b{cell-error}, @b{unbound-slot}, @b{unbound-variable}, @b{undefined-function}, @ref{Condition System Concepts} @node parse-error, storage-condition, cell-error-name, Conditions Dictionary @subsection parse-error [Condition Type] @subsubheading Class Precedence List:: @b{parse-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{parse-error} consists of error conditions that are related to parsing. @subsubheading See Also:: @ref{parse-namestring} , @ref{reader-error} @node storage-condition, assert, parse-error, Conditions Dictionary @subsection storage-condition [Condition Type] @subsubheading Class Precedence List:: @b{storage-condition}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{storage-condition} consists of serious conditions that relate to problems with memory management that are potentially due to @i{implementation-dependent} limits rather than semantic errors in @i{conforming programs}, and that typically warrant entry to the debugger if not handled. Depending on the details of the @i{implementation}, these might include such problems as stack overflow, memory region overflow, and storage exhausted. @subsubheading Notes:: While some @r{Common Lisp} operations might signal @i{storage-condition} because they are defined to create @i{objects}, it is unspecified whether operations that are not defined to create @i{objects} create them anyway and so might also signal @b{storage-condition}. Likewise, the evaluator itself might create @i{objects} and so might signal @b{storage-condition}. (The natural assumption might be that such @i{object} creation is naturally inefficient, but even that is @i{implementation-dependent}.) In general, the entire question of how storage allocation is done is @i{implementation-dependent}, and so any operation might signal @b{storage-condition} at any time. Because such a @i{condition} is indicative of a limitation of the @i{implementation} or of the @i{image} rather than an error in a @i{program}, @i{objects} of @i{type} @b{storage-condition} are not of @i{type} @b{error}. @node assert, error, storage-condition, Conditions Dictionary @subsection assert [Macro] @code{assert} @i{test-form @r{[}@r{(}@{@i{place}@}*@r{)} @r{[}datum-form @{@i{argument-form}@}*@r{]}@r{]}}@* @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{test-form}---a @i{form}; always evaluated. @i{place}---a @i{place}; evaluated if an error is signaled. @i{datum-form}---a @i{form} that evaluates to a @i{datum}. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled. @i{argument-form}---a @i{form} that evaluates to an @i{argument}. Evaluated each time an error is to be signaled, or not at all if no error is to be signaled. @i{datum}, @i{arguments}---@i{designators} for a @i{condition} of default type @b{error}. (These @i{designators} are the result of evaluating @i{datum-form} and each of the @i{argument-forms}.) @subsubheading Description:: @b{assert} assures that @i{test-form} evaluates to @i{true}. If @i{test-form} evaluates to @i{false}, @b{assert} signals a @i{correctable} @i{error} (denoted by @i{datum} and @i{arguments}). Continuing from this error using the @b{continue} @i{restart} makes it possible for the user to alter the values of the @i{places} before @b{assert} evaluates @i{test-form} again. If the value of @i{test-form} is @i{non-nil}, @b{assert} returns @b{nil}. The @i{places} are @i{generalized references} to data upon which @i{test-form} depends, whose values can be changed by the user in attempting to correct the error. @i{Subforms} of each @i{place} are only evaluated if an error is signaled, and might be re-evaluated if the error is re-signaled (after continuing without actually fixing the problem). The order of evaluation of the @i{places} is not specified; see @ref{Evaluation of Subforms to Places}. @ITindex order of evaluation @ITindex evaluation order If a @i{place} @i{form} is supplied that produces more values than there are store variables, the extra values are ignored. If the supplied @i{form} produces fewer values than there are store variables, the missing values are set to @b{nil}. @subsubheading Examples:: @example (setq x (make-array '(3 5) :initial-element 3)) @result{} #2A((3 3 3 3 3) (3 3 3 3 3) (3 3 3 3 3)) (setq y (make-array '(3 5) :initial-element 7)) @result{} #2A((7 7 7 7 7) (7 7 7 7 7) (7 7 7 7 7)) (defun matrix-multiply (a b) (let ((*print-array* nil)) (assert (and (= (array-rank a) (array-rank b) 2) (= (array-dimension a 1) (array-dimension b 0))) (a b) "Cannot multiply ~S by ~S." a b) (really-matrix-multiply a b))) @result{} MATRIX-MULTIPLY (matrix-multiply x y) @t{ |> } Correctable error in MATRIX-MULTIPLY: @t{ |> } Cannot multiply # by #. @t{ |> } Restart options: @t{ |> } 1: You will be prompted for one or more new values. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Value for A: @b{|>>}@t{x}@b{<<|} @t{ |> } Value for B: @b{|>>}@t{(make-array '(5 3) :initial-element 6)}@b{<<|} @result{} #2A((54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54) (54 54 54 54 54)) @end example @example (defun double-safely (x) (assert (numberp x) (x)) (+ x x)) (double-safely 4) @result{} 8 (double-safely t) @t{ |> } Correctable error in DOUBLE-SAFELY: The value of (NUMBERP X) must be non-NIL. @t{ |> } Restart options: @t{ |> } 1: You will be prompted for one or more new values. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Value for X: @b{|>>}@t{7}@b{<<|} @result{} 14 @end example @subsubheading Affected By:: @b{*break-on-signals*} The set of active @i{condition handlers}. @subsubheading See Also:: @ref{check-type} , @ref{error} , @ref{Generalized Reference} @subsubheading Notes:: The debugger need not include the @i{test-form} in the error message, and the @i{places} should not be included in the message, but they should be made available for the user's perusal. If the user gives the ``continue'' command, the values of any of the references can be altered. The details of this depend on the implementation's style of user interface. @node error, cerror, assert, Conditions Dictionary @subsection error [Function] @code{error} @i{datum @r{&rest} arguments} @result{} # @subsubheading Arguments and Values:: @i{datum}, @i{arguments}---@i{designators} for a @i{condition} of default type @b{simple-error}. @subsubheading Description:: @b{error} effectively invokes @b{signal} on the denoted @i{condition}. If the @i{condition} is not handled, @t{(invoke-debugger @i{condition})} is done. As a consequence of calling @b{invoke-debugger}, @b{error} cannot directly return; the only exit from @b{error} can come by non-local transfer of control in a handler or by use of an interactive debugging command. @subsubheading Examples:: @example (defun factorial (x) (cond ((or (not (typep x 'integer)) (minusp x)) (error "~S is not a valid argument to FACTORIAL." x)) ((zerop x) 1) (t (* x (factorial (- x 1)))))) @result{} FACTORIAL (factorial 20) @result{} 2432902008176640000 (factorial -1) @t{ |> } Error: -1 is not a valid argument to FACTORIAL. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return to Lisp Toplevel. @t{ |> } Debug> @end example @example (setq a 'fred) @result{} FRED (if (numberp a) (1+ a) (error "~S is not a number." A)) @t{ |> } Error: FRED is not a number. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:Continue 1}@b{<<|} @t{ |> } Return to Lisp Toplevel. (define-condition not-a-number (error) ((argument :reader not-a-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a number." (not-a-number-argument condition))))) @result{} NOT-A-NUMBER (if (numberp a) (1+ a) (error 'not-a-number :argument a)) @t{ |> } Error: FRED is not a number. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:Continue 1}@b{<<|} @t{ |> } Return to Lisp Toplevel. @end example @subsubheading Side Effects:: @i{Handlers} for the specified condition, if any, are invoked and might have side effects. Program execution might stop, and the debugger might be entered. @subsubheading Affected By:: Existing handler bindings. @b{*break-on-signals*} Signals an error of @i{type} @b{type-error} if @i{datum} and @i{arguments} are not @i{designators} for a @i{condition}. @subsubheading See Also:: @ref{cerror} , @ref{signal} , @ref{format} , @ref{ignore-errors} , @b{*break-on-signals*}, @ref{handler-bind} , @ref{Condition System Concepts} @subsubheading Notes:: Some implementations may provide debugger commands for interactively returning from individual stack frames. However, it should be possible for the programmer to feel confident about writing code like: @example (defun wargames:no-win-scenario () (if (error "pushing the button would be stupid.")) (push-the-button)) @end example In this scenario, there should be no chance that @b{error} will return and the button will get pushed. While the meaning of this program is clear and it might be proven `safe' by a formal theorem prover, such a proof is no guarantee that the program is safe to execute. Compilers have been known to have bugs, computers to have signal glitches, and human beings to manually intervene in ways that are not always possible to predict. Those kinds of errors, while beyond the scope of the condition system to formally model, are not beyond the scope of things that should seriously be considered when writing code that could have the kinds of sweeping effects hinted at by this example. @node cerror, check-type, error, Conditions Dictionary @subsection cerror [Function] @code{cerror} @i{continue-format-control datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{Continue-format-control}---a @i{format control}. [Reviewer Note by Barmar: What is continue-format-control used for??] @i{datum}, @i{arguments}---@i{designators} for a @i{condition} of default type @b{simple-error}. @subsubheading Description:: @b{cerror} effectively invokes @b{error} on the @i{condition} named by @i{datum}. As with any function that implicitly calls @b{error}, if the @i{condition} is not handled, @t{(invoke-debugger @i{condition})} is executed. While signaling is going on, and while in the debugger if it is reached, it is possible to continue code execution (@i{i.e.}, to return from @b{cerror}) using the @b{continue} @i{restart}. If @i{datum} is a @i{condition}, @i{arguments} can be supplied, but are used only in conjunction with the @i{continue-format-control}. @subsubheading Examples:: @example (defun real-sqrt (n) (when (minusp n) (setq n (- n)) (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n)) (sqrt n)) (real-sqrt 4) @result{} 2.0 (real-sqrt -9) @t{ |> } Correctable error in REAL-SQRT: Tried to take sqrt(-9). @t{ |> } Restart options: @t{ |> } 1: Return sqrt(9) instead. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @result{} 3.0 (define-condition not-a-number (error) ((argument :reader not-a-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a number." (not-a-number-argument condition))))) (defun assure-number (n) (loop (when (numberp n) (return n)) (cerror "Enter a number." 'not-a-number :argument n) (format t "~&Type a number: ") (setq n (read)) (fresh-line))) (assure-number 'a) @t{ |> } Correctable error in ASSURE-NUMBER: A is not a number. @t{ |> } Restart options: @t{ |> } 1: Enter a number. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Type a number: @b{|>>}@t{1/2}@b{<<|} @result{} 1/2 (defun assure-large-number (n) (loop (when (and (numberp n) (> n 73)) (return n)) (cerror "Enter a number~:[~; a bit larger than ~D~]." "~*~A is not a large number." (numberp n) n) (format t "~&Type a large number: ") (setq n (read)) (fresh-line))) (assure-large-number 10000) @result{} 10000 (assure-large-number 'a) @t{ |> } Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. @t{ |> } Restart options: @t{ |> } 1: Enter a number. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Type a large number: @b{|>>}@t{88}@b{<<|} @result{} 88 (assure-large-number 37) @t{ |> } Correctable error in ASSURE-LARGE-NUMBER: 37 is not a large number. @t{ |> } Restart options: @t{ |> } 1: Enter a number a bit larger than 37. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Type a large number: @b{|>>}@t{259}@b{<<|} @result{} 259 (define-condition not-a-large-number (error) ((argument :reader not-a-large-number-argument :initarg :argument)) (:report (lambda (condition stream) (format stream "~S is not a large number." (not-a-large-number-argument condition))))) (defun assure-large-number (n) (loop (when (and (numberp n) (> n 73)) (return n)) (cerror "Enter a number~3*~:[~; a bit larger than ~*~D~]." 'not-a-large-number :argument n :ignore (numberp n) :ignore n :allow-other-keys t) (format t "~&Type a large number: ") (setq n (read)) (fresh-line))) (assure-large-number 'a) @t{ |> } Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. @t{ |> } Restart options: @t{ |> } 1: Enter a number. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Type a large number: @b{|>>}@t{88}@b{<<|} @result{} 88 (assure-large-number 37) @t{ |> } Correctable error in ASSURE-LARGE-NUMBER: A is not a large number. @t{ |> } Restart options: @t{ |> } 1: Enter a number a bit larger than 37. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Type a large number: @b{|>>}@t{259}@b{<<|} @result{} 259 @end example @subsubheading Affected By:: @b{*break-on-signals*}. Existing handler bindings. @subsubheading See Also:: @ref{error} , @ref{format} , @ref{handler-bind} , @b{*break-on-signals*}, @b{simple-type-error} @subsubheading Notes:: If @i{datum} is a @i{condition} @i{type} rather than a @i{string}, the @b{format} directive @t{~*} may be especially useful in the @i{continue-format-control} in order to ignore the @i{keywords} in the @i{initialization argument list}. For example: @example (cerror "enter a new value to replace ~*~s" 'not-a-number :argument a) @end example @node check-type, simple-error, cerror, Conditions Dictionary @subsection check-type [Macro] @code{check-type} @i{place typespec @r{@r{[}@i{string}@r{]}}} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{typespec}---a @i{type specifier}. @i{string}---a @i{string}; evaluated. @subsubheading Description:: @b{check-type} signals a @i{correctable} @i{error} of @i{type} @b{type-error} if the contents of @i{place} are not of the type @i{typespec}. @b{check-type} can return only if the @b{store-value} @i{restart} is invoked, either explicitly from a handler or implicitly as one of the options offered by the debugger. If the @b{store-value} @i{restart} is invoked, @b{check-type} stores the new value that is the argument to the @i{restart} invocation (or that is prompted for interactively by the debugger) in @i{place} and starts over, checking the type of the new value and signaling another error if it is still not of the desired @i{type}. The first time @i{place} is @i{evaluated}, it is @i{evaluated} by normal evaluation rules. It is later @i{evaluated} as a @i{place} if the type check fails and the @b{store-value} @i{restart} is used; see @ref{Evaluation of Subforms to Places}. @i{string} should be an English description of the type, starting with an indefinite article (``a'' or ``an''). If @i{string} is not supplied, it is computed automatically from @i{typespec}. The automatically generated message mentions @i{place}, its contents, and the desired type. An implementation may choose to generate a somewhat differently worded error message if it recognizes that @i{place} is of a particular form, such as one of the arguments to the function that called @b{check-type}. @i{string} is allowed because some applications of @b{check-type} may require a more specific description of what is wanted than can be generated automatically from @i{typespec}. @subsubheading Examples:: @example (setq aardvarks '(sam harry fred)) @result{} (SAM HARRY FRED) (check-type aardvarks (array * (3))) @t{ |> } Error: The value of AARDVARKS, (SAM HARRY FRED), @t{ |> } is not a 3-long array. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Use Value: @b{|>>}@t{#(SAM FRED HARRY)}@b{<<|} @result{} NIL aardvarks @result{} # (map 'list #'identity aardvarks) @result{} (SAM FRED HARRY) (setq aardvark-count 'foo) @result{} FOO (check-type aardvark-count (integer 0 *) "A positive integer") @t{ |> } Error: The value of AARDVARK-COUNT, FOO, is not a positive integer. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 2}@b{<<|} @end example @example (defmacro define-adder (name amount) (check-type name (and symbol (not null)) "a name for an adder function") (check-type amount integer) `(defun ,name (x) (+ x ,amount))) (macroexpand '(define-adder add3 3)) @result{} (defun add3 (x) (+ x 3)) (macroexpand '(define-adder 7 7)) @t{ |> } Error: The value of NAME, 7, is not a name for an adder function. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:Continue 1}@b{<<|} @t{ |> } Specify a value to use instead. @t{ |> } Type a form to be evaluated and used instead: @b{|>>}@t{'ADD7}@b{<<|} @result{} (defun add7 (x) (+ x 7)) (macroexpand '(define-adder add5 something)) @t{ |> } Error: The value of AMOUNT, SOMETHING, is not an integer. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:Continue 1}@b{<<|} @t{ |> } Type a form to be evaluated and used instead: @b{|>>}@t{5}@b{<<|} @result{} (defun add5 (x) (+ x 5)) @end example Control is transferred to a handler. @subsubheading Side Effects:: The debugger might be entered. @subsubheading Affected By:: @b{*break-on-signals*} The implementation. @subsubheading See Also:: @ref{Condition System Concepts} @subsubheading Notes:: @example (check-type @i{place} @i{typespec}) @equiv{} (assert (typep @i{place} '@i{typespec}) (@i{place}) 'type-error :datum @i{place} :expected-type '@i{typespec}) @end example @node simple-error, invalid-method-error, check-type, Conditions Dictionary @subsection simple-error [Condition Type] @subsubheading Class Precedence List:: @b{simple-error}, @b{simple-condition}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{simple-error} consists of @i{conditions} that are signaled by @b{error} or @b{cerror} when a @i{format control} is supplied as the function's first argument. @node invalid-method-error, method-combination-error, simple-error, Conditions Dictionary @subsection invalid-method-error [Function] @code{invalid-method-error} @i{method format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{method}---a @i{method}. @i{format-control}---a @i{format control}. @i{args}---@i{format arguments} for the @i{format-control}. @subsubheading Description:: The @i{function} @b{invalid-method-error} is used to signal an error of @i{type} @b{error} when there is an applicable @i{method} whose @i{qualifiers} are not valid for the method combination type. The error message is constructed by using the @i{format-control} suitable for @b{format} and any @i{args} to it. Because an implementation may need to add additional contextual information to the error message, @b{invalid-method-error} should be called only within the dynamic extent of a method combination function. The @i{function} @b{invalid-method-error} is called automatically when a @i{method} fails to satisfy every @i{qualifier} pattern and predicate in a @b{define-method-combination} @i{form}. A method combination function that imposes additional restrictions should call @b{invalid-method-error} explicitly if it encounters a @i{method} it cannot accept. Whether @b{invalid-method-error} returns to its caller or exits via @b{throw} is @i{implementation-dependent}. @subsubheading Side Effects:: The debugger might be entered. @subsubheading Affected By:: @b{*break-on-signals*} @subsubheading See Also:: @ref{define-method-combination} @node method-combination-error, signal, invalid-method-error, Conditions Dictionary @subsection method-combination-error [Function] @code{method-combination-error} @i{format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} @subsubheading Arguments and Values:: @i{format-control}---a @i{format control}. @i{args}---@i{format arguments} for @i{format-control}. @subsubheading Description:: The @i{function} @b{method-combination-error} is used to signal an error in method combination. The error message is constructed by using a @i{format-control} suitable for @b{format} and any @i{args} to it. Because an implementation may need to add additional contextual information to the error message, @b{method-combination-error} should be called only within the dynamic extent of a method combination function. Whether @b{method-combination-error} returns to its caller or exits via @b{throw} is @i{implementation-dependent}. @subsubheading Side Effects:: The debugger might be entered. @subsubheading Affected By:: @b{*break-on-signals*} @subsubheading See Also:: @ref{define-method-combination} @node signal, simple-condition, method-combination-error, Conditions Dictionary @subsection signal [Function] @code{signal} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{datum}, @i{arguments}---@i{designators} for a @i{condition} of default type @b{simple-condition}. @subsubheading Description:: @i{Signals} the @i{condition} denoted by the given @i{datum} and @i{arguments}. If the @i{condition} is not handled, @b{signal} returns @b{nil}. @subsubheading Examples:: @example (defun handle-division-conditions (condition) (format t "Considering condition for division condition handling~ (when (and (typep condition 'arithmetic-error) (eq '/ (arithmetic-error-operation condition))) (invoke-debugger condition))) HANDLE-DIVISION-CONDITIONS (defun handle-other-arithmetic-errors (condition) (format t "Considering condition for arithmetic condition handling~ (when (typep condition 'arithmetic-error) (abort))) HANDLE-OTHER-ARITHMETIC-ERRORS (define-condition a-condition-with-no-handler (condition) ()) A-CONDITION-WITH-NO-HANDLER (signal 'a-condition-with-no-handler) NIL (handler-bind ((condition #'handle-division-conditions) (condition #'handle-other-arithmetic-errors)) (signal 'a-condition-with-no-handler)) Considering condition for division condition handling Considering condition for arithmetic condition handling NIL (handler-bind ((arithmetic-error #'handle-division-conditions) (arithmetic-error #'handle-other-arithmetic-errors)) (signal 'arithmetic-error :operation '* :operands '(1.2 b))) Considering condition for division condition handling Considering condition for arithmetic condition handling Back to Lisp Toplevel @end example @subsubheading Side Effects:: The debugger might be entered due to @b{*break-on-signals*}. Handlers for the condition being signaled might transfer control. @subsubheading Affected By:: Existing handler bindings. @b{*break-on-signals*} @subsubheading See Also:: @b{*break-on-signals*}, @ref{error} , @b{simple-condition}, @ref{Signaling and Handling Conditions} @subsubheading Notes:: If @t{(typep @i{datum} *break-on-signals*)} @i{yields} @i{true}, the debugger is entered prior to beginning the signaling process. The @b{continue} @i{restart} can be used to continue with the signaling process. This is also true for all other @i{functions} and @i{macros} that should, might, or must @i{signal} @i{conditions}. @node simple-condition, simple-condition-format-control, signal, Conditions Dictionary @subsection simple-condition [Condition Type] @subsubheading Class Precedence List:: @b{simple-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{simple-condition} represents @i{conditions} that are signaled by @b{signal} whenever a @i{format-control} is supplied as the function's first argument. The @i{format control} and @i{format arguments} are initialized with the initialization arguments named @t{:format-control} and @t{:format-arguments} to @b{make-condition}, and are @i{accessed} by the @i{functions} @b{simple-condition-format-control} and @b{simple-condition-format-arguments}. If format arguments are not supplied to @b{make-condition}, @b{nil} is used as a default. @subsubheading See Also:: @ref{simple-condition-format-control} , @b{simple-condition-format-arguments} @node simple-condition-format-control, warn, simple-condition, Conditions Dictionary @subsection simple-condition-format-control, simple-condition-format-arguments @flushright @i{[Function]} @end flushright @code{simple-condition-format-control} @i{condition} @result{} @i{format-control} @code{simple-condition-format-arguments} @i{condition} @result{} @i{format-arguments} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} of @i{type} @b{simple-condition}. @i{format-control}---a @i{format control}. @i{format-arguments}---a @i{list}. @subsubheading Description:: @b{simple-condition-format-control} returns the @i{format control} needed to process the @i{condition}'s @i{format arguments}. @b{simple-condition-format-arguments} returns a @i{list} of @i{format arguments} needed to process the @i{condition}'s @i{format control}. @subsubheading Examples:: @example (setq foo (make-condition 'simple-condition :format-control "Hi ~S" :format-arguments '(ho))) @result{} # (apply #'format nil (simple-condition-format-control foo) (simple-condition-format-arguments foo)) @result{} "Hi HO" @end example @subsubheading See Also:: @ref{simple-condition} , @ref{Condition System Concepts} @node warn, simple-warning, simple-condition-format-control, Conditions Dictionary @subsection warn [Function] @code{warn} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{datum}, @i{arguments}---@i{designators} for a @i{condition} of default type @b{simple-warning}. @subsubheading Description:: @i{Signals} a @i{condition} of @i{type} @b{warning}. If the @i{condition} is not @i{handled}, reports the @i{condition} to @i{error output}. The precise mechanism for warning is as follows: @table @asis @item @b{The warning condition is signaled} While the @b{warning} @i{condition} is being signaled, the @b{muffle-warning} @i{restart} is established for use by a @i{handler}. If invoked, this @i{restart} bypasses further action by @b{warn}, which in turn causes @b{warn} to immediately return @b{nil}. @item @b{If no handler for the warning condition is found} If no handlers for the warning condition are found, or if all such handlers decline, then the @i{condition} is reported to @i{error output} by @b{warn} in an @i{implementation-dependent} format. @item @b{@b{nil} is returned} The value returned by @b{warn} if it returns is @b{nil}. @end table @subsubheading Examples:: @example (defun foo (x) (let ((result (* x 2))) (if (not (typep result 'fixnum)) (warn "You're using very big numbers.")) result)) @result{} FOO (foo 3) @result{} 6 (foo most-positive-fixnum) @t{ |> } Warning: You're using very big numbers. @result{} 4294967294 (setq *break-on-signals* t) @result{} T (foo most-positive-fixnum) @t{ |> } Break: Caveat emptor. @t{ |> } To continue, type :CONTINUE followed by an option number. @t{ |> } 1: Return from Break. @t{ |> } 2: Abort to Lisp Toplevel. @t{ |> } Debug> :continue 1 @t{ |> } Warning: You're using very big numbers. @result{} 4294967294 @end example @subsubheading Side Effects:: A warning is issued. The debugger might be entered. @subsubheading Affected By:: Existing handler bindings. @b{*break-on-signals*}, @b{*error-output*}. @subsubheading Exceptional Situations:: If @i{datum} is a @i{condition} and if the @i{condition} is not of @i{type} @b{warning}, or @i{arguments} is @i{non-nil}, an error of @i{type} @b{type-error} is signaled. If @i{datum} is a condition type, the result of @t{(apply #'make-condition datum arguments)} must be of @i{type} @b{warning} or an error of @i{type} @b{type-error} is signaled. @subsubheading See Also:: @b{*break-on-signals*}, @ref{muffle-warning} , @ref{signal} @node simple-warning, invoke-debugger, warn, Conditions Dictionary @subsection simple-warning [Condition Type] @subsubheading Class Precedence List:: @b{simple-warning}, @b{simple-condition}, @b{warning}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{simple-warning} represents @i{conditions} that are signaled by @b{warn} whenever a @i{format control} is supplied as the function's first argument. @node invoke-debugger, break, simple-warning, Conditions Dictionary @subsection invoke-debugger [Function] @code{invoke-debugger} @i{condition} @result{} # @subsubheading Arguments and Values:: @i{condition}---a @i{condition} @i{object}. @subsubheading Description:: @b{invoke-debugger} attempts to enter the debugger with @i{condition}. If @b{*debugger-hook*} is not @b{nil}, it should be a @i{function} (or the name of a @i{function}) to be called prior to entry to the standard debugger. The @i{function} is called with @b{*debugger-hook*} bound to @b{nil}, and the @i{function} must accept two arguments: the @i{condition} and the @i{value} of @b{*debugger-hook*} prior to binding it to @b{nil}. If the @i{function} returns normally, the standard debugger is entered. The standard debugger never directly returns. Return can occur only by a non-local transfer of control, such as the use of a restart function. @subsubheading Examples:: @example (ignore-errors ;Normally, this would suppress debugger entry (handler-bind ((error #'invoke-debugger)) ;But this forces debugger entry (error "Foo."))) Debug: Foo. To continue, type :CONTINUE followed by an option number: 1: Return to Lisp Toplevel. Debug> @end example @subsubheading Side Effects:: @b{*debugger-hook*} is bound to @b{nil}, program execution is discontinued, and the debugger is entered. @subsubheading Affected By:: @b{*debug-io*} and @b{*debugger-hook*}. @subsubheading See Also:: @ref{error} , @ref{break} @node break, *debugger-hook*, invoke-debugger, Conditions Dictionary @subsection break [Function] @code{break} @i{@r{&optional} format-control @r{&rest} format-arguments} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{format-control}---a @i{format control}. The default is @i{implementation-dependent}. @i{format-arguments}---@i{format arguments} for the @i{format-control}. @subsubheading Description:: @b{break} @i{formats} @i{format-control} and @i{format-arguments} and then goes directly into the debugger without allowing any possibility of interception by programmed error-handling facilities. If the @b{continue} @i{restart} is used while in the debugger, @b{break} immediately returns @b{nil} without taking any unusual recovery action. @b{break} binds @b{*debugger-hook*} to @b{nil} before attempting to enter the debugger. @subsubheading Examples:: @example (break "You got here with arguments: ~:S." '(FOO 37 A)) @t{ |> } BREAK: You got here with these arguments: FOO, 37, A. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return from BREAK. @t{ |> } 2: Top level. @t{ |> } Debug> :CONTINUE 1 @t{ |> } Return from BREAK. @result{} NIL @end example @subsubheading Side Effects:: The debugger is entered. @subsubheading Affected By:: @b{*debug-io*}. @subsubheading See Also:: @ref{error} , @ref{invoke-debugger} . @subsubheading Notes:: @b{break} is used as a way of inserting temporary debugging ``breakpoints'' in a program, not as a way of signaling errors. For this reason, @b{break} does not take the @i{continue-format-control} @i{argument} that @b{cerror} takes. This and the lack of any possibility of interception by @i{condition} @i{handling} are the only program-visible differences between @b{break} and @b{cerror}. The user interface aspects of @b{break} and @b{cerror} are permitted to vary more widely, in order to accomodate the interface needs of the @i{implementation}. For example, it is permissible for a @i{Lisp read-eval-print loop} to be entered by @b{break} rather than the conventional debugger. @b{break} could be defined by: @example (defun break (&optional (format-control "Break") &rest format-arguments) (with-simple-restart (continue "Return from BREAK.") (let ((*debugger-hook* nil)) (invoke-debugger (make-condition 'simple-condition :format-control format-control :format-arguments format-arguments)))) nil) @end example @node *debugger-hook*, *break-on-signals*, break, Conditions Dictionary @subsection *debugger-hook* [Variable] @subsubheading Value Type:: a @i{designator} for a @i{function} of two @i{arguments} (a @i{condition} and the @i{value} of @b{*debugger-hook*} at the time the debugger was entered), or @b{nil}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: When the @i{value} of @b{*debugger-hook*} is @i{non-nil}, it is called prior to normal entry into the debugger, either due to a call to @b{invoke-debugger} or due to automatic entry into the debugger from a call to @b{error} or @b{cerror} with a condition that is not handled. The @i{function} may either handle the @i{condition} (transfer control) or return normally (allowing the standard debugger to run). To minimize recursive errors while debugging, @b{*debugger-hook*} is bound to @b{nil} by @b{invoke-debugger} prior to calling the @i{function}. @subsubheading Examples:: @example (defun one-of (choices &optional (prompt "Choice")) (let ((n (length choices)) (i)) (do ((c choices (cdr c)) (i 1 (+ i 1))) ((null c)) (format t "~&[~D] ~A~ (do () ((typep i `(integer 1 ,n))) (format t "~&~A: " prompt) (setq i (read)) (fresh-line)) (nth (- i 1) choices))) (defun my-debugger (condition me-or-my-encapsulation) (format t "~&Fooey: ~A" condition) (let ((restart (one-of (compute-restarts)))) (if (not restart) (error "My debugger got an error.")) (let ((*debugger-hook* me-or-my-encapsulation)) (invoke-restart-interactively restart)))) (let ((*debugger-hook* #'my-debugger)) (+ 3 'a)) @t{ |> } Fooey: The argument to +, A, is not a number. @t{ |> } [1] Supply a replacement for A. @t{ |> } [2] Return to Cloe Toplevel. @t{ |> } Choice: 1 @t{ |> } Form to evaluate and use: (+ 5 'b) @t{ |> } Fooey: The argument to +, B, is not a number. @t{ |> } [1] Supply a replacement for B. @t{ |> } [2] Supply a replacement for A. @t{ |> } [3] Return to Cloe Toplevel. @t{ |> } Choice: 1 @t{ |> } Form to evaluate and use: 1 @result{} 9 @end example @subsubheading Affected By:: @b{invoke-debugger} @subsubheading Notes:: When evaluating code typed in by the user interactively, it is sometimes useful to have the hook function bind @b{*debugger-hook*} to the @i{function} that was its second argument so that recursive errors can be handled using the same interactive facility. @node *break-on-signals*, handler-bind, *debugger-hook*, Conditions Dictionary @subsection *break-on-signals* [Variable] @subsubheading Value Type:: a @i{type specifier}. @subsubheading Initial Value:: @b{nil}. @subsubheading Description:: When @t{(typep @i{condition} *break-on-signals*)} returns @i{true}, calls to @b{signal}, and to other @i{operators} such as @b{error} that implicitly call @b{signal}, enter the debugger prior to @i{signaling} the @i{condition}. The @b{continue} @i{restart} can be used to continue with the normal @i{signaling} process when a break occurs process due to @b{*break-on-signals*}. @subsubheading Examples:: @example *break-on-signals* @result{} NIL (ignore-errors (error 'simple-error :format-control "Fooey!")) @result{} NIL, # (let ((*break-on-signals* 'error)) (ignore-errors (error 'simple-error :format-control "Fooey!"))) @t{ |> } Break: Fooey! @t{ |> } BREAK entered because of *BREAK-ON-SIGNALS*. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Continue to signal. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Continue to signal. @result{} NIL, # (let ((*break-on-signals* 'error)) (error 'simple-error :format-control "Fooey!")) @t{ |> } Break: Fooey! @t{ |> } BREAK entered because of *BREAK-ON-SIGNALS*. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Continue to signal. @t{ |> } 2: Top level. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Continue to signal. @t{ |> } Error: Fooey! @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Top level. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Top level. @end example @subsubheading See Also:: @ref{break} , @ref{signal} , @ref{warn} , @ref{error} , @ref{typep} , @ref{Condition System Concepts} @subsubheading Notes:: @b{*break-on-signals*} is intended primarily for use in debugging code that does signaling. When setting @b{*break-on-signals*}, the user is encouraged to choose the most restrictive specification that suffices. Setting @b{*break-on-signals*} effectively violates the modular handling of @i{condition} signaling. In practice, the complete effect of setting @b{*break-on-signals*} might be unpredictable in some cases since the user might not be aware of the variety or number of calls to @b{signal} that are used in code called only incidentally. @b{*break-on-signals*} enables an early entry to the debugger but such an entry does not preclude an additional entry to the debugger in the case of operations such as @b{error} and @b{cerror}. @node handler-bind, handler-case, *break-on-signals*, Conditions Dictionary @subsection handler-bind [Macro] @code{handler-bind} @i{@r{(}@{!@i{binding}@}*@r{)} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @w{@i{binding} ::=@r{(}type handler@r{)}} @subsubheading Arguments and Values:: @i{type}---a @i{type specifier}. @i{handler}---a @i{form}; evaluated to produce a @i{handler-function}. @i{handler-function}---a @i{designator} for a @i{function} of one @i{argument}. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Executes @i{forms} in a @i{dynamic environment} where the indicated @i{handler} @i{bindings} are in effect. Each @i{handler} should evaluate to a @i{handler-function}, which is used to handle @i{conditions} of the given @i{type} during execution of the @i{forms}. This @i{function} should take a single argument, the @i{condition} being signaled. If more than one @i{handler} @i{binding} is supplied, the @i{handler} @i{bindings} are searched sequentially from top to bottom in search of a match (by visual analogy with @b{typecase}). If an appropriate @i{type} is found, the associated handler is run in a @i{dynamic environment} where none of these @i{handler} bindings are visible (to avoid recursive errors). If the @i{handler} @i{declines}, the search continues for another @i{handler}. If no appropriate @i{handler} is found, other @i{handlers} are sought from dynamically enclosing contours. If no @i{handler} is found outside, then @b{signal} returns or @b{error} enters the debugger. @subsubheading Examples:: In the following code, if an unbound variable error is signaled in the body (and not handled by an intervening handler), the first function is called. @example (handler-bind ((unbound-variable #'(lambda ...)) (error #'(lambda ...))) ...) @end example If any other kind of error is signaled, the second function is called. In either case, neither handler is active while executing the code in the associated function. @example (defun trap-error-handler (condition) (format *error-output* "~&~A~&" condition) (throw 'trap-errors nil)) (defmacro trap-errors (&rest forms) `(catch 'trap-errors (handler-bind ((error #'trap-error-handler)) ,@@forms))) (list (trap-errors (signal "Foo.") 1) (trap-errors (error "Bar.") 2) (+ 1 2)) @t{ |> } Bar. @result{} (1 NIL 3) @end example Note that ``Foo.'' is not printed because the condition made by @b{signal} is a @i{simple condition}, which is not of @i{type} @b{error}, so it doesn't trigger the handler for @b{error} set up by @t{trap-errors}. @subsubheading See Also:: @ref{handler-case} @node handler-case, ignore-errors, handler-bind, Conditions Dictionary @subsection handler-case [Macro] @code{handler-case} @i{@i{expression} [[@{!@i{error-clause}@}* | !@i{no-error-clause}]]} @result{} @i{@{@i{result}@}*} @w{@i{clause} ::=!@i{error-clause} | !@i{no-error-clause}} @w{@i{error-clause} ::=@r{(}typespec @r{(}@t{[}var@t{]}@r{)} @{@i{declaration}@}* @{@i{form}@}*@r{)}} @w{@i{no-error-clause} ::=@r{(}@t{:no-error} @i{lambda-list} @{@i{declaration}@}* @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @i{expression}---a @i{form}. @i{typespec}---a @i{type specifier}. @i{var}---a @i{variable} @i{name}. @i{lambda-list}---an @i{ordinary lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{form}---a @i{form}. @i{results}---In the normal situation, the values returned are those that result from the evaluation of @i{expression}; in the exceptional situation when control is transferred to a @i{clause}, the value of the last @i{form} in that @i{clause} is returned. @subsubheading Description:: @b{handler-case} executes @i{expression} in a @i{dynamic environment} where various handlers are active. Each @i{error-clause} specifies how to handle a @i{condition} matching the indicated @i{typespec}. A @i{no-error-clause} allows the specification of a particular action if control returns normally. If a @i{condition} is signaled for which there is an appropriate @i{error-clause} during the execution of @i{expression} (@i{i.e.}, one for which @t{(typep @i{condition} '@i{typespec})} returns @i{true}) and if there is no intervening handler for a @i{condition} of that @i{type}, then control is transferred to the body of the relevant @i{error-clause}. In this case, the dynamic state is unwound appropriately (so that the handlers established around the @i{expression} are no longer active), and @i{var} is bound to the @i{condition} that had been signaled. If more than one case is provided, those cases are made accessible in parallel. That is, in @example (handler-case @i{form} (@i{typespec1} (@i{var1}) @i{form1}) (@i{typespec2} (@i{var2}) @i{form2})) @end example if the first @i{clause} (containing @i{form1}) has been selected, the handler for the second is no longer visible (or vice versa). The @i{clauses} are searched sequentially from top to bottom. If there is @i{type} overlap between @i{typespecs}, the earlier of the @i{clauses} is selected. If @i{var} is not needed, it can be omitted. That is, a @i{clause} such as: @example (@i{typespec} (@i{var}) (declare (ignore @i{var})) @i{form}) @end example can be written @t{(@i{typespec} () @i{form})}. If there are no @i{forms} in a selected @i{clause}, the case, and therefore @b{handler-case}, returns @b{nil}. If execution of @i{expression} returns normally and no @i{no-error-clause} exists, the values returned by @i{expression} are returned by @b{handler-case}. If execution of @i{expression} returns normally and a @i{no-error-clause} does exist, the values returned are used as arguments to the function described by constructing @t{(lambda @i{lambda-list} @{@i{form}@}*)} from the @i{no-error-clause}, and the @i{values} of that function call are returned by @b{handler-case}. The handlers which were established around the @i{expression} are no longer active at the time of this call. @subsubheading Examples:: @example (defun assess-condition (condition) (handler-case (signal condition) (warning () "Lots of smoke, but no fire.") ((or arithmetic-error control-error cell-error stream-error) (condition) (format nil "~S looks especially bad." condition)) (serious-condition (condition) (format nil "~S looks serious." condition)) (condition () "Hardly worth mentioning."))) @result{} ASSESS-CONDITION (assess-condition (make-condition 'stream-error :stream *terminal-io*)) @result{} "# looks especially bad." (define-condition random-condition (condition) () (:report (lambda (condition stream) (declare (ignore condition)) (princ "Yow" stream)))) @result{} RANDOM-CONDITION (assess-condition (make-condition 'random-condition)) @result{} "Hardly worth mentioning." @end example @subsubheading See Also:: @ref{handler-bind} , @ref{ignore-errors} , @ref{Condition System Concepts} @subsubheading Notes:: @example (handler-case form (@i{type1} (@i{var1}) . @i{body1}) (@i{type2} (@i{var2}) . @i{body2}) ...) @end example is approximately equivalent to: @example (block #1=#:g0001 (let ((#2=#:g0002 nil)) (tagbody (handler-bind ((@i{type1} #'(lambda (temp) (setq #1# temp) (go #3=#:g0003))) (@i{type2} #'(lambda (temp) (setq #2# temp) (go #4=#:g0004))) ...) (return-from #1# form)) #3# (return-from #1# (let ((@i{var1} #2#)) . @i{body1})) #4# (return-from #1# (let ((@i{var2} #2#)) . @i{body2})) ...))) @end example @example (handler-case form (@i{type1} @i{(var1)} . @i{body1}) ... (:no-error (@i{varN-1} @i{varN-2} ...) . @i{bodyN})) @end example is approximately equivalent to: @example (block #1=#:error-return (multiple-value-call #'(lambda (@i{varN-1} @i{varN-2} ...) . @i{bodyN}) (block #2=#:normal-return (return-from #1# (handler-case (return-from #2# form) (@i{type1} (@i{var1}) . @i{body1}) ...))))) @end example @node ignore-errors, define-condition, handler-case, Conditions Dictionary @subsection ignore-errors [Macro] @code{ignore-errors} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{forms}---an @i{implicit progn}. @i{results}---In the normal situation, the @i{values} of the @i{forms} are returned; in the exceptional situation, two values are returned: @b{nil} and the @i{condition}. @subsubheading Description:: @b{ignore-errors} is used to prevent @i{conditions} of @i{type} @b{error} from causing entry into the debugger. Specifically, @b{ignore-errors} @i{executes} @i{forms} in a @i{dynamic environment} where a @i{handler} for @i{conditions} of @i{type} @b{error} has been established; if invoked, it @i{handles} such @i{conditions} by returning two @i{values}, @b{nil} and the @i{condition} that was @i{signaled}, from the @b{ignore-errors} @i{form}. If a @i{normal return} from the @i{forms} occurs, any @i{values} returned are returned by @b{ignore-errors}. @subsubheading Examples:: @example (defun load-init-file (program) (let ((win nil)) (ignore-errors ;if this fails, don't enter debugger (load (merge-pathnames (make-pathname :name program :type :lisp) (user-homedir-pathname))) (setq win t)) (unless win (format t "~&Init file failed to load.~ win)) (load-init-file "no-such-program") @t{ |> } Init file failed to load. NIL @end example @subsubheading See Also:: @ref{handler-case} , @ref{Condition System Concepts} @subsubheading Notes:: @example (ignore-errors . @i{forms}) @end example is equivalent to: @example (handler-case (progn . @i{forms}) (error (condition) (values nil condition))) @end example Because the second return value is a @i{condition} in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or @b{nil} so that the two situations can be distinguished. @node define-condition, make-condition, ignore-errors, Conditions Dictionary @subsection define-condition [Macro] [Editorial Note by KMP: This syntax stuff is still very confused and needs lots of work.] @code{define-condition} @i{name @r{(}@{@i{parent-type}@}*@r{)} @r{(}@{!@i{slot-spec}@}*@r{)} @{@i{option}@}*}@* @result{} @i{name} @w{@i{slot-spec} ::=slot-name | @r{(}slot-name !@i{slot-option}@r{)}} @w{@i{slot-option} ::=[[ @{@t{:reader} @i{symbol}@}* | } @w{ @{@t{:writer} !@i{function-name}@}* | } @w{ @{@t{:accessor} @i{symbol}@}* | } @w{ @{@t{:allocation} !@i{allocation-type}@} | } @w{ @{@t{:initarg} @i{symbol}@}* | } @w{ @{@t{:initform} @i{form}@} | } @w{ @{@t{:type} @i{type-specifier}@} ]]} @w{@i{option} ::=[[ @r{(}@t{:default-initargs} @t{.} @i{initarg-list}@r{)} | } @w{ @r{(}@t{:documentation} @i{string}@r{)} | } @w{ @r{(}@t{:report} @i{report-name}@r{)} ]]} @w{@i{function-name} ::=@{@i{symbol} | @t{(setf @i{symbol})}@}} @w{@i{allocation-type} ::=@t{:instance} | @t{:class}} @w{@i{report-name} ::=@i{string} | @i{symbol} | @i{lambda expression}} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{parent-type}---a @i{symbol} naming a @i{condition} @i{type}. If no @i{parent-types} are supplied, the @i{parent-types} default to @t{(condition)}. @i{default-initargs}---a @i{list} of @i{keyword/value pairs}. [Editorial Note by KMP: This is all mixed up as to which is a slot option and which is a main option. I'll sort that out. Also, some of this is implied by the bnf and needn't be stated explicitly.] @i{Slot-spec} -- the @i{name} of a @i{slot} or a @i{list} consisting of the @i{slot-name} followed by zero or more @i{slot-options}. @i{Slot-name} -- a slot name (a @i{symbol}), the @i{list} of a slot name, or the @i{list} of slot name/slot form pairs. @i{Option} -- Any of the following: @table @asis @item @t{:reader} @t{:reader} can be supplied more than once for a given @i{slot} and cannot be @b{nil}. @item @t{:writer} @t{:writer} can be supplied more than once for a given @i{slot} and must name a @i{generic function}. @item @t{:accessor} @t{:accessor} can be supplied more than once for a given @i{slot} and cannot be @b{nil}. @item @t{:allocation} @t{:allocation} can be supplied once at most for a given @i{slot}. The default if @t{:allocation} is not supplied is @t{:instance}. @item @t{:initarg} @t{:initarg} can be supplied more than once for a given @i{slot}. @item @t{:initform} @t{:initform} can be supplied once at most for a given @i{slot}. @item @t{:type} @t{:type} can be supplied once at most for a given @i{slot}. @item @t{:documentation} @t{:documentation} can be supplied once at most for a given @i{slot}. @item @t{:report} @t{:report} can be supplied once at most. @end table @subsubheading Description:: @b{define-condition} defines a new condition type called @i{name}, which is a @i{subtype} of the @i{type} or @i{types} named by @i{parent-type}. Each @i{parent-type} argument specifies a direct @i{supertype} of the new @i{condition}. The new @i{condition} inherits @i{slots} and @i{methods} from each of its direct @i{supertypes}, and so on. If a slot name/slot form pair is supplied, the slot form is a @i{form} that can be evaluated by @b{make-condition} to produce a default value when an explicit value is not provided. If no slot form is supplied, the contents of the @i{slot} is initialized in an @i{implementation-dependent} way. If the @i{type} being defined and some other @i{type} from which it inherits have a slot by the same name, only one slot is allocated in the @i{condition}, but the supplied slot form overrides any slot form that might otherwise have been inherited from a @i{parent-type}. If no slot form is supplied, the inherited slot form (if any) is still visible. Accessors are created according to the same rules as used by @b{defclass}. A description of @i{slot-options} follows: @table @asis @item @t{:reader} The @t{:reader} slot option specifies that an @i{unqualified method} is to be defined on the @i{generic function} named by the argument to @t{:reader} to read the value of the given @i{slot}. @item @t{*} The @t{:initform} slot option is used to provide a default initial value form to be used in the initialization of the @i{slot}. This @i{form} is evaluated every time it is used to initialize the @i{slot}. The @i{lexical environment} in which this @i{form} is evaluated is the lexical @i{environment} in which the @b{define-condition} form was evaluated. Note that the @i{lexical environment} refers both to variables and to @i{functions}. For @i{local slots}, the @i{dynamic environment} is the dynamic @i{environment} in which @b{make-condition} was called; for @i{shared slots}, the @i{dynamic environment} is the @i{dynamic environment} in which the @b{define-condition} form was evaluated. [Reviewer Note by Barmar: Issue CLOS-CONDITIONS doesn't say this.] No implementation is permitted to extend the syntax of @b{define-condition} to allow @t{(@i{slot-name} @i{form})} as an abbreviation for @t{(@i{slot-name} :initform @i{form})}. @item @t{:initarg} The @t{:initarg} slot option declares an initialization argument named by its @i{symbol} argument and specifies that this initialization argument initializes the given @i{slot}. If the initialization argument has a value in the call to @b{initialize-instance}, the value is stored into the given @i{slot}, and the slot's @t{:initform} slot option, if any, is not evaluated. If none of the initialization arguments specified for a given @i{slot} has a value, the @i{slot} is initialized according to the @t{:initform} slot option, if specified. @item @t{:type} The @t{:type} slot option specifies that the contents of the @i{slot} is always of the specified @i{type}. It effectively declares the result type of the reader generic function when applied to an @i{object} of this @i{condition} type. The consequences of attempting to store in a @i{slot} a value that does not satisfy the type of the @i{slot} is undefined. @item @t{:default-initargs} [Editorial Note by KMP: This is an option, not a slot option.] This option is treated the same as it would be @b{defclass}. @item @t{:documentation} [Editorial Note by KMP: This is both an option and a slot option.] The @t{:documentation} slot option provides a @i{documentation string} for the @i{slot}. @item @t{:report} [Editorial Note by KMP: This is an option, not a slot option.] @i{Condition} reporting is mediated through the @b{print-object} method for the @i{condition} type in question, with @b{*print-escape*} always being @b{nil}. Specifying @t{(:report @i{report-name})} in the definition of a condition type @t{C} is equivalent to: @example (defmethod print-object ((x c) stream) (if *print-escape* (call-next-method) (@i{report-name} x stream))) @end example If the value supplied by the argument to @t{:report} (@i{report-name}) is a @i{symbol} or a @i{lambda expression}, it must be acceptable to @b{function}. @t{(function @i{report-name})} is evaluated in the current @i{lexical environment}. It should return a @i{function} of two arguments, a @i{condition} and a @i{stream}, that prints on the @i{stream} a description of the @i{condition}. This @i{function} is called whenever the @i{condition} is printed while @b{*print-escape*} is @b{nil}. If @i{report-name} is a @i{string}, it is a shorthand for @example (lambda (condition stream) (declare (ignore condition)) (write-string @i{report-name} stream)) @end example This option is processed after the new @i{condition} type has been defined, so use of the @i{slot} accessors within the @t{:report} function is permitted. If this option is not supplied, information about how to report this type of @i{condition} is inherited from the @i{parent-type}. @end table The consequences are unspecifed if an attempt is made to @i{read} a @i{slot} that has not been explicitly initialized and that has not been given a default value. The consequences are unspecified if an attempt is made to assign the @i{slots} by using @b{setf}. If a @b{define-condition} @i{form} appears as a @i{top level form}, the @i{compiler} must make @i{name} recognizable as a valid @i{type} name, and it must be possible to reference the @i{condition} @i{type} as the @i{parent-type} of another @i{condition} @i{type} in a subsequent @b{define-condition} @i{form} in the @i{file} being compiled. @subsubheading Examples:: The following form defines a condition of @i{type} @t{peg/hole-mismatch} which inherits from a condition type called @t{blocks-world-error}: @example (define-condition peg/hole-mismatch (blocks-world-error) ((peg-shape :initarg :peg-shape :reader peg/hole-mismatch-peg-shape) (hole-shape :initarg :hole-shape :reader peg/hole-mismatch-hole-shape)) (:report (lambda (condition stream) (format stream "A ~A peg cannot go in a ~A hole." (peg/hole-mismatch-peg-shape condition) (peg/hole-mismatch-hole-shape condition))))) @end example The new type has slots @t{peg-shape} and @t{hole-shape}, so @b{make-condition} accepts @t{:peg-shape} and @t{:hole-shape} keywords. The @i{readers} @t{peg/hole-mismatch-peg-shape} and @t{peg/hole-mismatch-hole-shape} apply to objects of this type, as illustrated in the @t{:report} information. The following form defines a @i{condition} @i{type} named @t{machine-error} which inherits from @b{error}: @example (define-condition machine-error (error) ((machine-name :initarg :machine-name :reader machine-error-machine-name)) (:report (lambda (condition stream) (format stream "There is a problem with ~A." (machine-error-machine-name condition))))) @end example Building on this definition, a new error condition can be defined which is a subtype of @t{machine-error} for use when machines are not available: @example (define-condition machine-not-available-error (machine-error) () (:report (lambda (condition stream) (format stream "The machine ~A is not available." (machine-error-machine-name condition))))) @end example This defines a still more specific condition, built upon @t{machine-not-available-error}, which provides a slot initialization form for @t{machine-name} but which does not provide any new slots or report information. It just gives the @t{machine-name} slot a default initialization: @example (define-condition my-favorite-machine-not-available-error (machine-not-available-error) ((machine-name :initform "mc.lcs.mit.edu"))) @end example Note that since no @t{:report} clause was given, the information inherited from @t{machine-not-available-error} is used to report this type of condition. @example (define-condition ate-too-much (error) ((person :initarg :person :reader ate-too-much-person) (weight :initarg :weight :reader ate-too-much-weight) (kind-of-food :initarg :kind-of-food :reader :ate-too-much-kind-of-food))) @result{} ATE-TOO-MUCH (define-condition ate-too-much-ice-cream (ate-too-much) ((kind-of-food :initform 'ice-cream) (flavor :initarg :flavor :reader ate-too-much-ice-cream-flavor :initform 'vanilla )) (:report (lambda (condition stream) (format stream "~A ate too much ~A ice-cream" (ate-too-much-person condition) (ate-too-much-ice-cream-flavor condition))))) @result{} ATE-TOO-MUCH-ICE-CREAM (make-condition 'ate-too-much-ice-cream :person 'fred :weight 300 :flavor 'chocolate) @result{} # (format t "~A" *) @t{ |> } FRED ate too much CHOCOLATE ice-cream @result{} NIL @end example @subsubheading See Also:: @ref{make-condition} , @ref{defclass} , @ref{Condition System Concepts} @node make-condition, restart, define-condition, Conditions Dictionary @subsection make-condition [Function] @code{make-condition} @i{type @r{&rest} slot-initializations} @result{} @i{condition} @subsubheading Arguments and Values:: @i{type}---a @i{type specifier} (for a @i{subtype} of @b{condition}). @i{slot-initializations}---an @i{initialization argument list}. @i{condition}---a @i{condition}. @subsubheading Description:: Constructs and returns a @i{condition} of type @i{type} using @i{slot-initializations} for the initial values of the slots. The newly created @i{condition} is returned. @subsubheading Examples:: @example (defvar *oops-count* 0) (setq a (make-condition 'simple-error :format-control "This is your ~:R error." :format-arguments (list (incf *oops-count*)))) @result{} # (format t "~&~A~ @t{ |> } This is your first error. @result{} NIL (error a) @t{ |> } Error: This is your first error. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return to Lisp Toplevel. @t{ |> } Debug> @end example @subsubheading Affected By:: The set of defined @i{condition} @i{types}. @subsubheading See Also:: @ref{define-condition} , @ref{Condition System Concepts} @node restart, compute-restarts, make-condition, Conditions Dictionary @subsection restart [System Class] @subsubheading Class Precedence List:: @b{restart}, @b{t} @subsubheading Description:: An @i{object} of @i{type} @b{restart} represents a @i{function} that can be called to perform some form of recovery action, usually a transfer of control to an outer point in the running program. An @i{implementation} is free to implement a @i{restart} in whatever manner is most convenient; a @i{restart} has only @i{dynamic extent} relative to the scope of the binding @i{form} which @i{establishes} it. @node compute-restarts, find-restart, restart, Conditions Dictionary @subsection compute-restarts [Function] @code{compute-restarts} @i{@r{&optional} condition} @result{} @i{restarts} @subsubheading Arguments and Values:: @i{condition}---a @i{condition} @i{object}, or @b{nil}. @i{restarts}---a @i{list} of @i{restarts}. @subsubheading Description:: @b{compute-restarts} uses the dynamic state of the program to compute a @i{list} of the @i{restarts} which are currently active. The resulting @i{list} is ordered so that the innermost (more-recently established) restarts are nearer the head of the @i{list}. When @i{condition} is @i{non-nil}, only those @i{restarts} are considered that are either explicitly associated with that @i{condition}, or not associated with any @i{condition}; that is, the excluded @i{restarts} are those that are associated with a non-empty set of @i{conditions} of which the given @i{condition} is not an @i{element}. If @i{condition} is @b{nil}, all @i{restarts} are considered. @b{compute-restarts} returns all @i{applicable restarts}, including anonymous ones, even if some of them have the same name as others and would therefore not be found by @b{find-restart} when given a @i{symbol} argument. Implementations are permitted, but not required, to return @i{distinct} @i{lists} from repeated calls to @b{compute-restarts} while in the same dynamic environment. The consequences are undefined if the @i{list} returned by @b{compute-restarts} is every modified. @subsubheading Examples:: @example ;; One possible way in which an interactive debugger might present ;; restarts to the user. (defun invoke-a-restart () (let ((restarts (compute-restarts))) (do ((i 0 (+ i 1)) (r restarts (cdr r))) ((null r)) (format t "~&~D: ~A~ (let ((n nil) (k (length restarts))) (loop (when (and (typep n 'integer) (>= n 0) (< n k)) (return t)) (format t "~&Option: ") (setq n (read)) (fresh-line)) (invoke-restart-interactively (nth n restarts))))) (restart-case (invoke-a-restart) (one () 1) (two () 2) (nil () :report "Who knows?" 'anonymous) (one () 'I) (two () 'II)) @t{ |> } 0: ONE @t{ |> } 1: TWO @t{ |> } 2: Who knows? @t{ |> } 3: ONE @t{ |> } 4: TWO @t{ |> } 5: Return to Lisp Toplevel. @t{ |> } Option: @b{|>>}@t{4}@b{<<|} @result{} II ;; Note that in addition to user-defined restart points, COMPUTE-RESTARTS ;; also returns information about any system-supplied restarts, such as ;; the "Return to Lisp Toplevel" restart offered above. @end example @subsubheading Affected By:: Existing restarts. @subsubheading See Also:: @ref{find-restart} , @ref{invoke-restart} , @ref{restart-bind} @node find-restart, invoke-restart, compute-restarts, Conditions Dictionary @subsection find-restart [Function] @code{find-restart} @i{identifier @r{&optional} condition} @r{restart} @subsubheading Arguments and Values:: @i{identifier}---a @i{non-nil} @i{symbol}, or a @i{restart}. @i{condition}---a @i{condition} @i{object}, or @b{nil}. @i{restart}---a @i{restart} or @b{nil}. @subsubheading Description:: @b{find-restart} searches for a particular @i{restart} in the current @i{dynamic environment}. When @i{condition} is @i{non-nil}, only those @i{restarts} are considered that are either explicitly associated with that @i{condition}, or not associated with any @i{condition}; that is, the excluded @i{restarts} are those that are associated with a non-empty set of @i{conditions} of which the given @i{condition} is not an @i{element}. If @i{condition} is @b{nil}, all @i{restarts} are considered. If @i{identifier} is a @i{symbol}, then the innermost (most recently established) @i{applicable restart} with that @i{name} is returned. @b{nil} is returned if no such restart is found. If @i{identifier} is a currently active restart, then it is returned. Otherwise, @b{nil} is returned. @subsubheading Examples:: @example (restart-case (let ((r (find-restart 'my-restart))) (format t "~S is named ~S" r (restart-name r))) (my-restart () nil)) @t{ |> } # is named MY-RESTART @result{} NIL (find-restart 'my-restart) @result{} NIL @end example @subsubheading Affected By:: Existing restarts. @b{restart-case}, @b{restart-bind}, @b{with-condition-restarts}. @subsubheading See Also:: @ref{compute-restarts} @subsubheading Notes:: @example (find-restart @i{identifier}) @equiv{} (find @i{identifier} (compute-restarts) :key :restart-name) @end example Although anonymous restarts have a name of @b{nil}, the consequences are unspecified if @b{nil} is given as an @i{identifier}. Occasionally, programmers lament that @b{nil} is not permissible as an @i{identifier} argument. In most such cases, @b{compute-restarts} can probably be used to simulate the desired effect. @node invoke-restart, invoke-restart-interactively, find-restart, Conditions Dictionary @subsection invoke-restart [Function] @code{invoke-restart} @i{restart @r{&rest} arguments} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{restart}---a @i{restart designator}. @i{argument}---an @i{object}. @i{results}---the @i{values} returned by the @i{function} associated with @i{restart}, if that @i{function} returns. @subsubheading Description:: Calls the @i{function} associated with @i{restart}, passing @i{arguments} to it. @i{Restart} must be valid in the current @i{dynamic environment}. @subsubheading Examples:: @example (defun add3 (x) (check-type x number) (+ x 3)) (foo 'seven) @t{ |> } Error: The value SEVEN was not of type NUMBER. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a different value to use. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{(invoke-restart 'store-value 7)}@b{<<|} @result{} 10 @end example @subsubheading Side Effects:: A non-local transfer of control might be done by the restart. @subsubheading Affected By:: Existing restarts. @subsubheading Exceptional Situations:: If @i{restart} is not valid, an error of @i{type} @b{control-error} is signaled. @subsubheading See Also:: @ref{find-restart} , @ref{restart-bind} , @ref{restart-case} , @ref{invoke-restart-interactively} @subsubheading Notes:: The most common use for @b{invoke-restart} is in a @i{handler}. It might be used explicitly, or implicitly through @b{invoke-restart-interactively} or a @i{restart function}. @i{Restart functions} call @b{invoke-restart}, not vice versa. That is, @i{invoke-restart} provides primitive functionality, and @i{restart functions} are non-essential ``syntactic sugar.'' @node invoke-restart-interactively, restart-bind, invoke-restart, Conditions Dictionary @subsection invoke-restart-interactively [Function] @code{invoke-restart-interactively} @i{restart} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{restart}---a @i{restart designator}. @i{results}---the @i{values} returned by the @i{function} associated with @i{restart}, if that @i{function} returns. @subsubheading Description:: @b{invoke-restart-interactively} calls the @i{function} associated with @i{restart}, prompting for any necessary arguments. If @i{restart} is a name, it must be valid in the current @i{dynamic environment}. @b{invoke-restart-interactively} prompts for arguments by executing the code provided in the @t{:interactive} keyword to @b{restart-case} or @t{:interactive-function} keyword to @b{restart-bind}. If no such options have been supplied in the corresponding @b{restart-bind} or @b{restart-case}, then the consequences are undefined if the @i{restart} takes required arguments. If the arguments are optional, an argument list of @b{nil} is used. Once the arguments have been determined, @b{invoke-restart-interactively} executes the following: @example (apply #'invoke-restart @i{restart} @i{arguments}) @end example @subsubheading Examples:: @example (defun add3 (x) (check-type x number) (+ x 3)) (add3 'seven) @t{ |> } Error: The value SEVEN was not of type NUMBER. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a different value to use. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{(invoke-restart-interactively 'store-value)}@b{<<|} @t{ |> } Type a form to evaluate and use: @b{|>>}@t{7}@b{<<|} @result{} 10 @end example @subsubheading Side Effects:: If prompting for arguments is necesary, some typeout may occur (on @i{query I/O}). A non-local transfer of control might be done by the restart. @subsubheading Affected By:: @b{*query-io*}, active @i{restarts} @subsubheading Exceptional Situations:: If @i{restart} is not valid, an error of @i{type} @b{control-error} is signaled. @subsubheading See Also:: @ref{find-restart} , @ref{invoke-restart} , @ref{restart-case} , @ref{restart-bind} @subsubheading Notes:: @b{invoke-restart-interactively} is used internally by the debugger and may also be useful in implementing other portable, interactive debugging tools. @node restart-bind, restart-case, invoke-restart-interactively, Conditions Dictionary @subsection restart-bind [Macro] @code{restart-bind} @i{@r{(}@{@r{(}name function @{!@i{key-val-pair}@}*@r{)}@}@r{)} @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @w{@i{key-val-pair} ::=@t{:interactive-function} @r{interactive-function} | } @w{ @t{:report-function} @r{report-function} | } @w{ @t{:test-function} @r{test-function}} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}; not evaluated. @i{function}---a @i{form}; evaluated. @i{forms}---an @i{implicit progn}. @i{interactive-function}---a @i{form}; evaluated. @i{report-function}---a @i{form}; evaluated. @i{test-function}---a @i{form}; evaluated. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{restart-bind} executes the body of @i{forms} in a @i{dynamic environment} where @i{restarts} with the given @i{names} are in effect. If a @i{name} is @b{nil}, it indicates an anonymous restart; if a @i{name} is a @i{non-nil} @i{symbol}, it indicates a named restart. The @i{function}, @i{interactive-function}, and @i{report-function} are unconditionally evaluated in the current lexical and dynamic environment prior to evaluation of the body. Each of these @i{forms} must evaluate to a @i{function}. If @b{invoke-restart} is done on that restart, the @i{function} which resulted from evaluating @i{function} is called, in the @i{dynamic environment} of the @b{invoke-restart}, with the @i{arguments} given to @b{invoke-restart}. The @i{function} may either perform a non-local transfer of control or may return normally. If the restart is invoked interactively from the debugger (using @b{invoke-restart-interactively}), the arguments are defaulted by calling the @i{function} which resulted from evaluating @i{interactive-function}. That @i{function} may optionally prompt interactively on @i{query I/O}, and should return a @i{list} of arguments to be used by @b{invoke-restart-interactively} when invoking the restart. If a restart is invoked interactively but no @i{interactive-function} is used, then an argument list of @b{nil} is used. In that case, the @i{function} must be compatible with an empty argument list. If the restart is presented interactively (@i{e.g.}, by the debugger), the presentation is done by calling the @i{function} which resulted from evaluating @i{report-function}. This @i{function} must be a @i{function} of one argument, a @i{stream}. It is expected to print a description of the action that the restart takes to that @i{stream}. This @i{function} is called any time the restart is printed while @b{*print-escape*} is @b{nil}. In the case of interactive invocation, the result is dependent on the value of @t{:interactive-function} as follows. @table @asis @item @t{:interactive-function} @i{Value} is evaluated in the current lexical environment and should return a @i{function} of no arguments which constructs a @i{list} of arguments to be used by @b{invoke-restart-interactively} when invoking this restart. The @i{function} may prompt interactively using @i{query I/O} if necessary. @item @t{:report-function} @i{Value} is evaluated in the current lexical environment and should return a @i{function} of one argument, a @i{stream}, which prints on the @i{stream} a summary of the action that this restart takes. This @i{function} is called whenever the restart is reported (printed while @b{*print-escape*} is @b{nil}). If no @t{:report-function} option is provided, the manner in which the @i{restart} is reported is @i{implementation-dependent}. @item @t{:test-function} @i{Value} is evaluated in the current lexical environment and should return a @i{function} of one argument, a @i{condition}, which returns @i{true} if the restart is to be considered visible. @end table @subsubheading Affected By:: @b{*query-io*}. @subsubheading See Also:: @ref{restart-case} , @ref{with-simple-restart} @subsubheading Notes:: @b{restart-bind} is primarily intended to be used to implement @b{restart-case} and might be useful in implementing other macros. Programmers who are uncertain about whether to use @b{restart-case} or @b{restart-bind} should prefer @b{restart-case} for the cases where it is powerful enough, using @b{restart-bind} only in cases where its full generality is really needed. @node restart-case, restart-name, restart-bind, Conditions Dictionary @subsection restart-case [Macro] @code{restart-case} @i{restartable-form @r{@{!@i{clause}@}}} @result{} @i{@{@i{result}@}*} @w{@i{clause} ::=@r{(} case-name lambda-list } @w{ [[@t{:interactive} interactive-expression | @t{:report} report-expression | @t{:test} test-expression]] } @w{ @{@i{declaration}@}* @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @i{restartable-form}---a @i{form}. @i{case-name}---a @i{symbol} or @b{nil}. @i{lambda-list}---an @i{ordinary lambda list}. @i{interactive-expression}---a @i{symbol} or a @i{lambda expression}. @i{report-expression}---a @i{string}, a @i{symbol}, or a @i{lambda expression}. @i{test-expression}---a @i{symbol} or a @i{lambda expression}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{form}---a @i{form}. @i{results}---the @i{values} resulting from the @i{evaluation} of @i{restartable-form}, or the @i{values} returned by the last @i{form} executed in a chosen @i{clause}, or @b{nil}. @subsubheading Description:: @b{restart-case} evaluates @i{restartable-form} in a @i{dynamic environment} where the clauses have special meanings as points to which control may be transferred. If @i{restartable-form} finishes executing and returns any values, all values returned are returned by @b{restart-case} and processing has completed. While @i{restartable-form} is executing, any code may transfer control to one of the clauses (see @b{invoke-restart}). If a transfer occurs, the forms in the body of that clause is evaluated and any values returned by the last such form are returned by @b{restart-case}. In this case, the dynamic state is unwound appropriately (so that the restarts established around the @i{restartable-form} are no longer active) prior to execution of the clause. If there are no @i{forms} in a selected clause, @b{restart-case} returns @b{nil}. If @i{case-name} is a @i{symbol}, it names this restart. It is possible to have more than one clause use the same @i{case-name}. In this case, the first clause with that name is found by @b{find-restart}. The other clauses are accessible using @b{compute-restarts}. Each @i{arglist} is an @i{ordinary lambda list} to be bound during the execution of its corresponding @i{forms}. These parameters are used by the @b{restart-case} clause to receive any necessary data from a call to @b{invoke-restart}. By default, @b{invoke-restart-interactively} passes no arguments and all arguments must be optional in order to accomodate interactive restarting. However, the arguments need not be optional if the @t{:interactive} keyword has been used to inform @b{invoke-restart-interactively} about how to compute a proper argument list. @i{Keyword} options have the following meaning. @table @asis @item @t{:interactive} The @i{value} supplied by @t{:interactive @i{value}} must be a suitable argument to @b{function}. @t{(function @i{value})} is evaluated in the current lexical environment. It should return a @i{function} of no arguments which returns arguments to be used by @b{invoke-restart-interactively} when it is invoked. @b{invoke-restart-interactively} is called in the dynamic environment available prior to any restart attempt, and uses @i{query I/O} for user interaction. If a restart is invoked interactively but no @t{:interactive} option was supplied, the argument list used in the invocation is the empty list. @item @t{:report} If the @i{value} supplied by @t{:report @i{value}} is a @i{lambda expression} or a @i{symbol}, it must be acceptable to @b{function}. @t{(function @i{value})} is evaluated in the current lexical environment. It should return a @i{function} of one argument, a @i{stream}, which prints on the @i{stream} a description of the restart. This @i{function} is called whenever the restart is printed while @b{*print-escape*} is @b{nil}. If @i{value} is a @i{string}, it is a shorthand for @example (lambda (stream) (write-string value stream)) @end example If a named restart is asked to report but no report information has been supplied, the name of the restart is used in generating default report text. When @b{*print-escape*} is @b{nil}, the printer uses the report information for a restart. For example, a debugger might announce the action of typing a ``continue'' command by: @example (format t "~&~S -- ~A~ @end example which might then display as something like: @example :CONTINUE -- Return to command level @end example The consequences are unspecified if an unnamed restart is specified but no @t{:report} option is provided. @item @t{:test} The @i{value} supplied by @t{:test @i{value}} must be a suitable argument to @b{function}. @t{(function @i{value})} is evaluated in the current lexical environment. It should return a @i{function} of one @i{argument}, the @i{condition}, that returns @i{true} if the restart is to be considered visible. The default for this option is equivalent to @t{(lambda (c) (declare (ignore c)) t)}. @end table If the @i{restartable-form} is a @i{list} whose @i{car} is any of the @i{symbols} @b{signal}, @b{error}, @b{cerror}, or @b{warn} (or is a @i{macro form} which macroexpands into such a @i{list}), then @b{with-condition-restarts} is used implicitly to associate the indicated @i{restarts} with the @i{condition} to be signaled. @subsubheading Examples:: @example (restart-case (handler-bind ((error #'(lambda (c) (declare (ignore condition)) (invoke-restart 'my-restart 7)))) (error "Foo.")) (my-restart (&optional v) v)) @result{} 7 (define-condition food-error (error) ()) @result{} FOOD-ERROR (define-condition bad-tasting-sundae (food-error) ((ice-cream :initarg :ice-cream :reader bad-tasting-sundae-ice-cream) (sauce :initarg :sauce :reader bad-tasting-sundae-sauce) (topping :initarg :topping :reader bad-tasting-sundae-topping)) (:report (lambda (condition stream) (format stream "Bad tasting sundae with ~S, ~S, and ~S" (bad-tasting-sundae-ice-cream condition) (bad-tasting-sundae-sauce condition) (bad-tasting-sundae-topping condition))))) @result{} BAD-TASTING-SUNDAE (defun all-start-with-same-letter (symbol1 symbol2 symbol3) (let ((first-letter (char (symbol-name symbol1) 0))) (and (eql first-letter (char (symbol-name symbol2) 0)) (eql first-letter (char (symbol-name symbol3) 0))))) @result{} ALL-START-WITH-SAME-LETTER (defun read-new-value () (format t "Enter a new value: ") (multiple-value-list (eval (read)))) @result{} READ-NEW-VALUE @page (defun verify-or-fix-perfect-sundae (ice-cream sauce topping) (do () ((all-start-with-same-letter ice-cream sauce topping)) (restart-case (error 'bad-tasting-sundae :ice-cream ice-cream :sauce sauce :topping topping) (use-new-ice-cream (new-ice-cream) :report "Use a new ice cream." :interactive read-new-value (setq ice-cream new-ice-cream)) (use-new-sauce (new-sauce) :report "Use a new sauce." :interactive read-new-value (setq sauce new-sauce)) (use-new-topping (new-topping) :report "Use a new topping." :interactive read-new-value (setq topping new-topping)))) (values ice-cream sauce topping)) @result{} VERIFY-OR-FIX-PERFECT-SUNDAE (verify-or-fix-perfect-sundae 'vanilla 'caramel 'cherry) @t{ |> } Error: Bad tasting sundae with VANILLA, CARAMEL, and CHERRY. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Use a new ice cream. @t{ |> } 2: Use a new sauce. @t{ |> } 3: Use a new topping. @t{ |> } 4: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @t{ |> } Use a new ice cream. @t{ |> } Enter a new ice cream: @b{|>>}@t{'chocolate}@b{<<|} @result{} CHOCOLATE, CARAMEL, CHERRY @end example @subsubheading See Also:: @ref{restart-bind} , @ref{with-simple-restart} . @subsubheading Notes:: @example (restart-case @i{expression} (@i{name1} @i{arglist1} ...@i{options1}... . @i{body1}) (@i{name2} @i{arglist2} ...@i{options2}... . @i{body2})) @end example is essentially equivalent to @example (block #1=#:g0001 (let ((#2=#:g0002 nil)) (tagbody (restart-bind ((name1 #'(lambda (&rest temp) (setq #2# temp) (go #3=#:g0003)) ...@i{slightly-transformed-options1}...) (name2 #'(lambda (&rest temp) (setq #2# temp) (go #4=#:g0004)) ...@i{slightly-transformed-options2}...)) (return-from #1# @i{expression})) #3# (return-from #1# (apply #'(lambda @i{arglist1} . @i{body1}) #2#)) #4# (return-from #1# (apply #'(lambda @i{arglist2} . @i{body2}) #2#))))) @end example Unnamed restarts are generally only useful interactively and an interactive option which has no description is of little value. Implementations are encouraged to warn if an unnamed restart is used and no report information is provided at compilation time. At runtime, this error might be noticed when entering the debugger. Since signaling an error would probably cause recursive entry into the debugger (causing yet another recursive error, etc.) it is suggested that the debugger print some indication of such problems when they occur but not actually signal errors. @example (restart-case (signal fred) (a ...) (b ...)) @equiv{} (restart-case (with-condition-restarts fred (list (find-restart 'a) (find-restart 'b)) (signal fred)) (a ...) (b ...)) @end example @node restart-name, with-condition-restarts, restart-case, Conditions Dictionary @subsection restart-name [Function] @code{restart-name} @i{restart} @result{} @i{name} @subsubheading Arguments and Values:: @i{restart}---a @i{restart}. @i{name}---a @i{symbol}. @subsubheading Description:: Returns the name of the @i{restart}, or @b{nil} if the @i{restart} is not named. @subsubheading Examples:: @example (restart-case (loop for restart in (compute-restarts) collect (restart-name restart)) (case1 () :report "Return 1." 1) (nil () :report "Return 2." 2) (case3 () :report "Return 3." 3) (case1 () :report "Return 4." 4)) @result{} (CASE1 NIL CASE3 CASE1 ABORT) ;; In the example above the restart named ABORT was not created ;; explicitly, but was implicitly supplied by the system. @end example @subsubheading See Also:: @ref{compute-restarts} @ref{find-restart} @node with-condition-restarts, with-simple-restart, restart-name, Conditions Dictionary @subsection with-condition-restarts [Macro] @code{with-condition-restarts} @i{condition-form restarts-form @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{condition-form}---a @i{form}; @i{evaluated} to produce a @i{condition}. @i{condition}---a @i{condition} @i{object} resulting from the @i{evaluation} of @i{condition-form}. @i{restart-form}---a @i{form}; @i{evaluated} to produce a @i{restart-list}. @i{restart-list}---a @i{list} of @i{restart} @i{objects} resulting from the @i{evaluation} of @i{restart-form}. @i{forms}---an @i{implicit progn}; evaluated. @i{results}---the @i{values} returned by @i{forms}. @subsubheading Description:: First, the @i{condition-form} and @i{restarts-form} are @i{evaluated} in normal left-to-right order; the @i{primary values} yielded by these @i{evaluations} are respectively called the @i{condition} and the @i{restart-list}. Next, the @i{forms} are @i{evaluated} in a @i{dynamic environment} in which each @i{restart} in @i{restart-list} is associated with the @i{condition}. See @ref{Associating a Restart with a Condition}. @subsubheading See Also:: @ref{restart-case} @subsubheading Notes:: Usually this @i{macro} is not used explicitly in code, since @b{restart-case} handles most of the common cases in a way that is syntactically more concise. @node with-simple-restart, abort (Restart), with-condition-restarts, Conditions Dictionary @subsection with-simple-restart [Macro] @code{with-simple-restart} @i{@r{(}name format-control @{@i{format-argument}@}*@r{)} @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{format-control}---a @i{format control}. @i{format-argument}---an @i{object} (@i{i.e.}, a @i{format argument}). @i{forms}---an @i{implicit progn}. @i{results}---in the normal situation, the @i{values} returned by the @i{forms}; in the exceptional situation where the @i{restart} named @i{name} is invoked, two values---@b{nil} and @b{t}. @subsubheading Description:: @b{with-simple-restart} establishes a restart. If the restart designated by @i{name} is not invoked while executing @i{forms}, all values returned by the last of @i{forms} are returned. If the restart designated by @i{name} is invoked, control is transferred to @b{with-simple-restart}, which returns two values, @b{nil} and @b{t}. If @i{name} is @b{nil}, an anonymous restart is established. The @i{format-control} and @i{format-arguments} are used report the @i{restart}. @subsubheading Examples:: @example (defun read-eval-print-loop (level) (with-simple-restart (abort "Exit command level ~D." level) (loop (with-simple-restart (abort "Return to command level ~D." level) (let ((form (prog2 (fresh-line) (read) (fresh-line)))) (prin1 (eval form))))))) @result{} READ-EVAL-PRINT-LOOP (read-eval-print-loop 1) (+ 'a 3) @t{ |> } Error: The argument, A, to the function + was of the wrong type. @t{ |> } The function expected a number. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use this time. @t{ |> } 2: Return to command level 1. @t{ |> } 3: Exit command level 1. @t{ |> } 4: Return to Lisp Toplevel. @end example @example (defun compute-fixnum-power-of-2 (x) (with-simple-restart (nil "Give up on computing 2@t{^}~D." x) (let ((result 1)) (dotimes (i x result) (setq result (* 2 result)) (unless (fixnump result) (error "Power of 2 is too large.")))))) COMPUTE-FIXNUM-POWER-OF-2 (defun compute-power-of-2 (x) (or (compute-fixnum-power-of-2 x) 'something big)) COMPUTE-POWER-OF-2 (compute-power-of-2 10) 1024 (compute-power-of-2 10000) @t{ |> } Error: Power of 2 is too large. @t{ |> } To continue, type :CONTINUE followed by an option number. @t{ |> } 1: Give up on computing 2@t{^}10000. @t{ |> } 2: Return to Lisp Toplevel @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} @result{} SOMETHING-BIG @end example @subsubheading See Also:: @ref{restart-case} @subsubheading Notes:: @b{with-simple-restart} is shorthand for one of the most common uses of @b{restart-case}. @b{with-simple-restart} could be defined by: @example (defmacro with-simple-restart ((restart-name format-control &rest format-arguments) &body forms) `(restart-case (progn ,@@forms) (,restart-name () :report (lambda (stream) (format stream ,format-control ,@@format-arguments)) (values nil t)))) @end example Because the second return value is @b{t} in the exceptional case, it is common (but not required) to arrange for the second return value in the normal case to be missing or @b{nil} so that the two situations can be distinguished. @node abort (Restart), continue, with-simple-restart, Conditions Dictionary @subsection abort [Restart] @subsubheading Data Arguments Required:: None. @subsubheading Description:: The intent of the @b{abort} restart is to allow return to the innermost ``command level.'' Implementors are encouraged to make sure that there is always a restart named @b{abort} around any user code so that user code can call @b{abort} at any time and expect something reasonable to happen; exactly what the reasonable thing is may vary somewhat. Typically, in an interactive listener, the invocation of @b{abort} returns to the @i{Lisp reader} phase of the @i{Lisp read-eval-print loop}, though in some batch or multi-processing situations there may be situations in which having it kill the running process is more appropriate. @subsubheading See Also:: @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{invoke-restart} , @ref{abort (Function)} (@i{function}) @node continue, muffle-warning, abort (Restart), Conditions Dictionary @subsection continue [Restart] @subsubheading Data Arguments Required:: None. @subsubheading Description:: The @b{continue} @i{restart} is generally part of protocols where there is a single ``obvious'' way to continue, such as in @b{break} and @b{cerror}. Some user-defined protocols may also wish to incorporate it for similar reasons. In general, however, it is more reliable to design a special purpose restart with a name that more directly suits the particular application. @subsubheading Examples:: @example (let ((x 3)) (handler-bind ((error #'(lambda (c) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (cond ((not (floatp x)) (cerror "Try floating it." "~D is not a float." x) (float x)) (t x)))) @result{} 3.0 @end example @subsubheading See Also:: @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{invoke-restart} , @ref{continue} (@i{function}), @ref{assert} , @ref{cerror} @node muffle-warning, store-value, continue, Conditions Dictionary @subsection muffle-warning [Restart] @subsubheading Data Arguments Required:: None. @subsubheading Description:: This @i{restart} is established by @b{warn} so that @i{handlers} of @b{warning} @i{conditions} have a way to tell @b{warn} that a warning has already been dealt with and that no further action is warranted. @subsubheading Examples:: @example (defvar *all-quiet* nil) @result{} *ALL-QUIET* (defvar *saved-warnings* '()) @result{} *SAVED-WARNINGS* (defun quiet-warning-handler (c) (when *all-quiet* (let ((r (find-restart 'muffle-warning c))) (when r (push c *saved-warnings*) (invoke-restart r))))) @result{} CUSTOM-WARNING-HANDLER (defmacro with-quiet-warnings (&body forms) `(let ((*all-quiet* t) (*saved-warnings* '())) (handler-bind ((warning #'quiet-warning-handler)) ,@@forms *saved-warnings*))) @result{} WITH-QUIET-WARNINGS (setq saved (with-quiet-warnings (warn "Situation #1.") (let ((*all-quiet* nil)) (warn "Situation #2.")) (warn "Situation #3."))) @t{ |> } Warning: Situation #2. @result{} (# #) (dolist (s saved) (format t "~&~A~ @t{ |> } Situation #3. @t{ |> } Situation #1. @result{} NIL @end example @subsubheading See Also:: @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{invoke-restart} , @ref{muffle-warning} (@i{function}), @ref{warn} @node store-value, use-value, muffle-warning, Conditions Dictionary @subsection store-value [Restart] @subsubheading Data Arguments Required:: a value to use instead (on an ongoing basis). @subsubheading Description:: The @b{store-value} @i{restart} is generally used by @i{handlers} trying to recover from errors of @i{types} such as @b{cell-error} or @b{type-error}, which may wish to supply a replacement datum to be stored permanently. @subsubheading Examples:: @example (defun type-error-auto-coerce (c) (when (typep c 'type-error) (let ((r (find-restart 'store-value c))) (handler-case (let ((v (coerce (type-error-datum c) (type-error-expected-type c)))) (invoke-restart r v)) (error ()))))) @result{} TYPE-ERROR-AUTO-COERCE (let ((x 3)) (handler-bind ((type-error #'type-error-auto-coerce)) (check-type x float) x)) @result{} 3.0 @end example @subsubheading See Also:: @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{invoke-restart} , @ref{store-value} (@i{function}), @b{ccase}, @ref{check-type} , @b{ctypecase}, @ref{use-value} (@i{function} and @i{restart}) @node use-value, abort (Function), store-value, Conditions Dictionary @subsection use-value [Restart] @subsubheading Data Arguments Required:: a value to use instead (once). @subsubheading Description:: The @b{use-value} @i{restart} is generally used by @i{handlers} trying to recover from errors of @i{types} such as @b{cell-error}, where the handler may wish to supply a replacement datum for one-time use. @subsubheading See Also:: @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{invoke-restart} , @ref{use-value} (@i{function}), @ref{store-value} (@i{function} and @i{restart}) @node abort (Function), , use-value, Conditions Dictionary @subsection abort, continue, muffle-warning, store-value, use-value [Function] @IRindex abort @IRindex continue @IRindex muffle-warning @IRindex store-value @IRindex use-value @code{abort} @i{@r{&optional} condition} @result{} # @code{continue} @i{@r{&optional} condition} @result{} @i{@b{nil}} @code{muffle-warning} @i{@r{&optional} condition} @result{} # @code{store-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} @code{use-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{value}---an @i{object}. @i{condition}---a @i{condition} @i{object}, or @b{nil}. @subsubheading Description:: Transfers control to the most recently established @i{applicable restart} having the same name as the function. That is, the @i{function} @b{abort} searches for an @i{applicable} @b{abort} @i{restart}, the @i{function} @b{continue} searches for an @i{applicable} @b{continue} @i{restart}, and so on. If no such @i{restart} exists, the functions @b{continue}, @b{store-value}, and @b{use-value} return @b{nil}, and the functions @b{abort} and @b{muffle-warning} signal an error of @i{type} @b{control-error}. When @i{condition} is @i{non-nil}, only those @i{restarts} are considered that are either explicitly associated with that @i{condition}, or not associated with any @i{condition}; that is, the excluded @i{restarts} are those that are associated with a non-empty set of @i{conditions} of which the given @i{condition} is not an @i{element}. If @i{condition} is @b{nil}, all @i{restarts} are considered. @subsubheading Examples:: @example ;;; Example of the ABORT retart (defmacro abort-on-error (&body forms) `(handler-bind ((error #'abort)) ,@@forms)) @result{} ABORT-ON-ERROR (abort-on-error (+ 3 5)) @result{} 8 (abort-on-error (error "You lose.")) @t{ |> } Returned to Lisp Top Level. ;;; Example of the CONTINUE restart (defun real-sqrt (n) (when (minusp n) (setq n (- n)) (cerror "Return sqrt(~D) instead." "Tried to take sqrt(-~D)." n)) (sqrt n)) (real-sqrt 4) @result{} 2 (real-sqrt -9) @t{ |> } Error: Tried to take sqrt(-9). @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Return sqrt(9) instead. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{(continue)}@b{<<|} @t{ |> } Return sqrt(9) instead. @result{} 3 (handler-bind ((error #'(lambda (c) (continue)))) (real-sqrt -9)) @result{} 3 ;;; Example of the MUFFLE-WARNING restart (defun count-down (x) (do ((counter x (1- counter))) ((= counter 0) 'done) (when (= counter 1) (warn "Almost done")) (format t "~&~D~ @result{} COUNT-DOWN (count-down 3) @t{ |> } 3 @t{ |> } 2 @t{ |> } Warning: Almost done @t{ |> } 1 @result{} DONE (defun ignore-warnings-while-counting (x) (handler-bind ((warning #'ignore-warning)) (count-down x))) @result{} IGNORE-WARNINGS-WHILE-COUNTING (defun ignore-warning (condition) (declare (ignore condition)) (muffle-warning)) @result{} IGNORE-WARNING (ignore-warnings-while-counting 3) @t{ |> } 3 @t{ |> } 2 @t{ |> } 1 @result{} DONE ;;; Example of the STORE-VALUE and USE-VALUE restarts (defun careful-symbol-value (symbol) (check-type symbol symbol) (restart-case (if (boundp symbol) (return-from careful-symbol-value (symbol-value symbol)) (error 'unbound-variable :name symbol)) (use-value (value) :report "Specify a value to use this time." value) (store-value (value) :report "Specify a value to store and use in the future." (setf (symbol-value symbol) value)))) (setq a 1234) @result{} 1234 (careful-symbol-value 'a) @result{} 1234 (makunbound 'a) @result{} A (careful-symbol-value 'a) @t{ |> } Error: A is not bound. @t{ |> } To continue, type :CONTINUE followed by an option number. @t{ |> } 1: Specify a value to use this time. @t{ |> } 2: Specify a value to store and use in the future. @t{ |> } 3: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{(use-value 12)}@b{<<|} @result{} 12 (careful-symbol-value 'a) @t{ |> } Error: A is not bound. @t{ |> } To continue, type :CONTINUE followed by an option number. @t{ |> } 1: Specify a value to use this time. @t{ |> } 2: Specify a value to store and use in the future. @t{ |> } 3: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{(store-value 24)}@b{<<|} @result{} 24 (careful-symbol-value 'a) @result{} 24 ;;; Example of the USE-VALUE restart (defun add-symbols-with-default (default &rest symbols) (handler-bind ((sys:unbound-symbol #'(lambda (c) (declare (ignore c)) (use-value default)))) (apply #'+ (mapcar #'careful-symbol-value symbols)))) @result{} ADD-SYMBOLS-WITH-DEFAULT (setq x 1 y 2) @result{} 2 (add-symbols-with-default 3 'x 'y 'z) @result{} 6 @end example @subsubheading Side Effects:: A transfer of control may occur if an appropriate @i{restart} is available, or (in the case of the @i{function} @b{abort} or the @i{function} @b{muffle-warning}) execution may be stopped. @subsubheading Affected By:: Each of these functions can be affected by the presence of a @i{restart} having the same name. @subsubheading Exceptional Situations:: If an appropriate @b{abort} @i{restart} is not available for the @i{function} @b{abort}, or an appropriate @b{muffle-warning} @i{restart} is not available for the @i{function} @b{muffle-warning}, an error of @i{type} @b{control-error} is signaled. @subsubheading See Also:: @ref{invoke-restart} , @ref{Restarts}, @ref{Interfaces to Restarts}, @ref{assert} , @b{ccase}, @ref{cerror} , @ref{check-type} , @b{ctypecase}, @ref{use-value} , @ref{warn} @subsubheading Notes:: @example (abort condition) @equiv{} (invoke-restart 'abort) (muffle-warning) @equiv{} (invoke-restart 'muffle-warning) (continue) @equiv{} (let ((r (find-restart 'continue))) (if r (invoke-restart r))) (use-value @i{x}) @equiv{} (let ((r (find-restart 'use-value))) (if r (invoke-restart r @i{x}))) (store-value x) @equiv{} (let ((r (find-restart 'store-value))) (if r (invoke-restart r @i{x}))) @end example No functions defined in this specification are required to provide a @b{use-value} @i{restart}. @c end of including dict-conditions @c %**end of chapter gcl-2.6.14/info/gcl.info-70000644000175000017500000110523114360276512013517 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: reduce, Next: count, Prev: map-into, Up: Sequences Dictionary 17.3.9 reduce [Function] ------------------------ 'reduce' function sequence &key key from-end start end initial-value => result Arguments and Values:: ...................... function--a designator for a function that might be called with either zero or two arguments. sequence--a proper sequence. key--a designator for a function of one argument, or nil. from-end--a generalized boolean. The default is false. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. initial-value--an object. result--an object. Description:: ............. reduce uses a binary operation, function, to combine the elements of sequence bounded by start and end. The function must accept as arguments two elements of sequence or the results from combining those elements. The function must also be able to accept no arguments. If key is supplied, it is used is used to extract the values to reduce. The key function is applied exactly once to each element of sequence in the order implied by the reduction order but not to the value of initial-value, if supplied. The key function typically returns part of the element of sequence. If key is not supplied or is nil, the sequence element itself is used. The reduction is left-associative, unless from-end is true in which case it is right-associative. If initial-value is supplied, it is logically placed before the subsequence (or after it if from-end is true) and included in the reduction operation. In the normal case, the result of reduce is the combined result of function's being applied to successive pairs of elements of sequence. If the subsequence contains exactly one element and no initial-value is given, then that element is returned and function is not called. If the subsequence is empty and an initial-value is given, then the initial-value is returned and function is not called. If the subsequence is empty and no initial-value is given, then the function is called with zero arguments, and reduce returns whatever function does. This is the only case where the function is called with other than two arguments. Examples:: .......... (reduce #'* '(1 2 3 4 5)) => 120 (reduce #'append '((1) (2)) :initial-value '(i n i t)) => (I N I T 1 2) (reduce #'append '((1) (2)) :from-end t :initial-value '(i n i t)) => (1 2 I N I T) (reduce #'- '(1 2 3 4)) == (- (- (- 1 2) 3) 4) => -8 (reduce #'- '(1 2 3 4) :from-end t) ;Alternating sum. == (- 1 (- 2 (- 3 4))) => -2 (reduce #'+ '()) => 0 (reduce #'+ '(3)) => 3 (reduce #'+ '(foo)) => FOO (reduce #'list '(1 2 3 4)) => (((1 2) 3) 4) (reduce #'list '(1 2 3 4) :from-end t) => (1 (2 (3 4))) (reduce #'list '(1 2 3 4) :initial-value 'foo) => ((((foo 1) 2) 3) 4) (reduce #'list '(1 2 3 4) :from-end t :initial-value 'foo) => (1 (2 (3 (4 foo)))) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note Traversal Rules and Side Effects::  File: gcl.info, Node: count, Next: length, Prev: reduce, Up: Sequences Dictionary 17.3.10 count, count-if, count-if-not [Function] ------------------------------------------------ 'count' item sequence &key from-end start end key test test-not => n 'count-if' predicate sequence &key from-end start end key => n 'count-if-not' predicate sequence &key from-end start end key => n Arguments and Values:: ...................... item--an object. sequence--a proper sequence. predicate--a designator for a function of one argument that returns a generalized boolean. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. key--a designator for a function of one argument, or nil. n--a non-negative integer less than or equal to the length of sequence. Description:: ............. count, count-if, and count-if-not count and return the number of elements in the sequence bounded by start and end that satisfy the test. The from-end has no direct effect on the result. However, if from-end is true, the elements of sequence will be supplied as arguments to the test, test-not, and key in reverse order, which may change the side-effects, if any, of those functions. Examples:: .......... (count #\a "how many A's are there in here?") => 2 (count-if-not #'oddp '((1) (2) (3) (4)) :key #'car) => 2 (count-if #'upper-case-p "The Crying of Lot 49" :start 4) => 2 Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note Rules about Test Functions::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. The function count-if-not is deprecated.  File: gcl.info, Node: length, Next: reverse, Prev: count, Up: Sequences Dictionary 17.3.11 length [Function] ------------------------- 'length' sequence => n Arguments and Values:: ...................... sequence--a proper sequence. n--a non-negative integer. Description:: ............. Returns the number of elements in sequence. If sequence is a vector with a fill pointer, the active length as specified by the fill pointer is returned. Examples:: .......... (length "abc") => 3 (setq str (make-array '(3) :element-type 'character :initial-contents "abc" :fill-pointer t)) => "abc" (length str) => 3 (setf (fill-pointer str) 2) => 2 (length str) => 2 Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note list-length:: , sequence  File: gcl.info, Node: reverse, Next: sort, Prev: length, Up: Sequences Dictionary 17.3.12 reverse, nreverse [Function] ------------------------------------ 'reverse' sequence => reversed-sequence 'nreverse' sequence => reversed-sequence Arguments and Values:: ...................... sequence--a proper sequence. reversed-sequence--a sequence. Description:: ............. reverse and nreverse return a new sequence of the same kind as sequence, containing the same elements, but in reverse order. reverse and nreverse differ in that reverse always creates and returns a new sequence, whereas nreverse might modify and return the given sequence. reverse never modifies the given sequence. For reverse, if sequence is a vector, the result is a fresh simple array of rank one that has the same actual array element type as sequence. If sequence is a list, the result is a fresh list. For nreverse, if sequence is a vector, the result is a vector that has the same actual array element type as sequence. If sequence is a list, the result is a list. For nreverse, sequence might be destroyed and re-used to produce the result. The result might or might not be identical to sequence. Specifically, when sequence is a list, nreverse is permitted to setf any part, car or cdr, of any cons that is part of the list structure of sequence. When sequence is a vector, nreverse is permitted to re-order the elements of sequence in order to produce the resulting vector. Examples:: .......... (setq str "abc") => "abc" (reverse str) => "cba" str => "abc" (setq str (copy-seq str)) => "abc" (nreverse str) => "cba" str => implementation-dependent (setq l (list 1 2 3)) => (1 2 3) (nreverse l) => (3 2 1) l => implementation-dependent Side Effects:: .............. nreverse might either create a new sequence, modify the argument sequence, or both. (reverse does not modify sequence.) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence.  File: gcl.info, Node: sort, Next: find, Prev: reverse, Up: Sequences Dictionary 17.3.13 sort, stable-sort [Function] ------------------------------------ 'sort' sequence predicate &key key => sorted-sequence 'stable-sort' sequence predicate &key key => sorted-sequence Arguments and Values:: ...................... sequence--a proper sequence. predicate--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. sorted-sequence--a sequence. Description:: ............. sort and stable-sort destructively sort sequences according to the order determined by the predicate function. If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list. sort determines the relationship between two elements by giving keys extracted from the elements to the predicate. The first argument to the predicate function is the part of one element of sequence extracted by the key function (if supplied); the second argument is the part of another element of sequence extracted by the key function (if supplied). Predicate should return true if and only if the first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then the predicate should return false. The argument to the key function is the sequence element. The return value of the key function becomes an argument to predicate. If key is not supplied or nil, the sequence element itself is used. There is no guarantee on the number of times the key will be called. If the key and predicate always return, then the sorting operation will always terminate, producing a sequence containing the same elements as sequence (that is, the result is a permutation of sequence). This is guaranteed even if the predicate does not really consistently represent a total order (in which case the elements will be scrambled in some unpredictable way, but no element will be lost). If the key consistently returns meaningful keys, and the predicate does reflect some total ordering criterion on those keys, then the elements of the sorted-sequence will be properly sorted according to that ordering. The sorting operation performed by sort is not guaranteed stable. Elements considered equal by the predicate might or might not stay in their original order. The predicate is assumed to consider two elements x and y to be equal if (funcall predicate x y) and (funcall predicate y x) are both false. stable-sort guarantees stability. The sorting operation can be destructive in all cases. In the case of a vector argument, this is accomplished by permuting the elements in place. In the case of a list, the list is destructively reordered in the same manner as for nreverse. Examples:: .......... (setq tester (copy-seq "lkjashd")) => "lkjashd" (sort tester #'char-lessp) => "adhjkls" (setq tester (list '(1 2 3) '(4 5 6) '(7 8 9))) => ((1 2 3) (4 5 6) (7 8 9)) (sort tester #'> :key #'car) => ((7 8 9) (4 5 6) (1 2 3)) (setq tester (list 1 2 3 4 5 6 7 8 9 0)) => (1 2 3 4 5 6 7 8 9 0) (stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y)))) => (1 3 5 7 9 2 4 6 8 0) (sort (setq committee-data (vector (list (list "JonL" "White") "Iteration") (list (list "Dick" "Waters") "Iteration") (list (list "Dick" "Gabriel") "Objects") (list (list "Kent" "Pitman") "Conditions") (list (list "Gregor" "Kiczales") "Objects") (list (list "David" "Moon") "Objects") (list (list "Kathy" "Chapman") "Editorial") (list (list "Larry" "Masinter") "Cleanup") (list (list "Sandra" "Loosemore") "Compiler"))) #'string-lessp :key #'cadar) => #((("Kathy" "Chapman") "Editorial") (("Dick" "Gabriel") "Objects") (("Gregor" "Kiczales") "Objects") (("Sandra" "Loosemore") "Compiler") (("Larry" "Masinter") "Cleanup") (("David" "Moon") "Objects") (("Kent" "Pitman") "Conditions") (("Dick" "Waters") "Iteration") (("JonL" "White") "Iteration")) ;; Note that individual alphabetical order within `committees' ;; is preserved. (setq committee-data (stable-sort committee-data #'string-lessp :key #'cadr)) => #((("Larry" "Masinter") "Cleanup") (("Sandra" "Loosemore") "Compiler") (("Kent" "Pitman") "Conditions") (("Kathy" "Chapman") "Editorial") (("Dick" "Waters") "Iteration") (("JonL" "White") "Iteration") (("Dick" "Gabriel") "Objects") (("Gregor" "Kiczales") "Objects") (("David" "Moon") "Objects")) Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note merge:: , *note Compiler Terminology::, *note Traversal Rules and Side Effects::, *note Destructive Operations::  File: gcl.info, Node: find, Next: position, Prev: sort, Up: Sequences Dictionary 17.3.14 find, find-if, find-if-not [Function] --------------------------------------------- 'find' item sequence &key from-end test test-not start end key => element 'find-if' predicate sequence &key from-end start end key => element 'find-if-not' predicate sequence &key from-end start end key => element Arguments and Values:: ...................... item--an object. sequence--a proper sequence. predicate--a designator for a function of one argument that returns a generalized boolean. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. key--a designator for a function of one argument, or nil. element--an element of the sequence, or nil. Description:: ............. find, find-if, and find-if-not each search for an element of the sequence bounded by start and end that satisfies the predicate predicate or that satisfies the test test or test-not, as appropriate. If from-end is true, then the result is the rightmost element that satisfies the test. If the sequence contains an element that satisfies the test, then the leftmost or rightmost sequence element, depending on from-end, is returned; otherwise nil is returned. Examples:: .......... (find #\d "here are some letters that can be looked at" :test #'char>) => #\Space (find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t) => 3 (find-if-not #'complexp '#(3.5 2 #C(1.0 0.0) #C(0.0 1.0)) :start 2) => NIL Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note position:: , *note Rules about Test Functions::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. The function find-if-not is deprecated.  File: gcl.info, Node: position, Next: search, Prev: find, Up: Sequences Dictionary 17.3.15 position, position-if, position-if-not [Function] --------------------------------------------------------- 'position' item sequence &key from-end test test-not start end key => position 'position-if' predicate sequence &key from-end start end key => position 'position-if-not' predicate sequence &key from-end start end key => position Arguments and Values:: ...................... item--an object. sequence--a proper sequence. predicate--a designator for a function of one argument that returns a generalized boolean. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. key--a designator for a function of one argument, or nil. position--a bounding index of sequence, or nil. Description:: ............. position, position-if, and position-if-not each search sequence for an element that satisfies the test. The position returned is the index within sequence of the leftmost (if from-end is true) or of the rightmost (if from-end is false) element that satisfies the test; otherwise nil is returned. The index returned is relative to the left-hand end of the entire sequence, regardless of the value of start, end, or from-end. Examples:: .......... (position #\a "baobab" :from-end t) => 4 (position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car) => 2 (position 595 '()) => NIL (position-if-not #'integerp '(1 2 3 4 5.0)) => 4 Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note find:: , *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. The function position-if-not is deprecated.  File: gcl.info, Node: search, Next: mismatch, Prev: position, Up: Sequences Dictionary 17.3.16 search [Function] ------------------------- 'search' sequence-1 sequence-2 &key from-end test test-not key start1 start2 end1 end2 => position Arguments and Values:: ...................... Sequence-1--a sequence. Sequence-2--a sequence. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. start1, end1--bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively. start2, end2--bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively. position--a bounding index of sequence-2, or nil. Description:: ............. Searches sequence-2 for a subsequence that matches sequence-1. The implementation may choose to search sequence-2 in any order; there is no guarantee on the number of times the test is made. For example, when start-end is true, the sequence might actually be searched from left to right instead of from right to left (but in either case would return the rightmost matching subsequence). If the search succeeds, search returns the offset into sequence-2 of the first element of the leftmost or rightmost matching subsequence, depending on from-end; otherwise search returns nil. If from-end is true, the index of the leftmost element of the rightmost matching subsequence is returned. Examples:: .......... (search "dog" "it's a dog's life") => 7 (search '(0 1) '(2 4 6 1 3 5) :key #'oddp) => 2 See Also:: .......... *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated.  File: gcl.info, Node: mismatch, Next: replace, Prev: search, Up: Sequences Dictionary 17.3.17 mismatch [Function] --------------------------- 'mismatch' sequence-1 sequence-2 &key from-end test test-not key start1 start2 end1 end2 => position Arguments and Values:: ...................... Sequence-1--a sequence. Sequence-2--a sequence. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start1, end1--bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively. start2, end2--bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively. key--a designator for a function of one argument, or nil. position--a bounding index of sequence-1, or nil. Description:: ............. The specified subsequences of sequence-1 and sequence-2 are compared element-wise. The key argument is used for both the sequence-1 and the sequence-2. If sequence-1 and sequence-2 are of equal length and match in every element, the result is false. Otherwise, the result is a non-negative integer, the index within sequence-1 of the leftmost or rightmost position, depending on from-end, at which the two subsequences fail to match. If one subsequence is shorter than and a matching prefix of the other, the result is the index relative to sequence-1 beyond the last position tested. If from-end is true, then one plus the index of the rightmost position in which the sequences differ is returned. In effect, the subsequences are aligned at their right-hand ends; then, the last elements are compared, the penultimate elements, and so on. The index returned is an index relative to sequence-1. Examples:: .......... (mismatch "abcd" "ABCDE" :test #'char-equal) => 4 (mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t) => 3 (mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp) => NIL (mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4) => NIL See Also:: .......... *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated.  File: gcl.info, Node: replace, Next: substitute, Prev: mismatch, Up: Sequences Dictionary 17.3.18 replace [Function] -------------------------- 'replace' sequence-1 sequence-2 &key start1 end1 start2 end2 => sequence-1 Arguments and Values:: ...................... sequence-1--a sequence. sequence-2--a sequence. start1, end1--bounding index designators of sequence-1. The defaults for start1 and end1 are 0 and nil, respectively. start2, end2--bounding index designators of sequence-2. The defaults for start2 and end2 are 0 and nil, respectively. Description:: ............. Destructively modifies sequence-1 by replacing the elements of subsequence-1 bounded by start1 and end1 with the elements of subsequence-2 bounded by start2 and end2. Sequence-1 is destructively modified by copying successive elements into it from sequence-2. Elements of the subsequence of sequence-2 bounded by start2 and end2 are copied into the subsequence of sequence-1 bounded by start1 and end1. If these subsequences are not of the same length, then the shorter length determines how many elements are copied; the extra elements near the end of the longer subsequence are not involved in the operation. The number of elements copied can be expressed as: (min (- end1 start1) (- end2 start2)) If sequence-1 and sequence-2 are the same object and the region being modified overlaps the region being copied from, then it is as if the entire source region were copied to another place and only then copied back into the target region. However, if sequence-1 and sequence-2 are not the same, but the region being modified overlaps the region being copied from (perhaps because of shared list structure or displaced arrays), then after the replace operation the subsequence of sequence-1 being modified will have unpredictable contents. It is an error if the elements of sequence-2 are not of a type that can be stored into sequence-1. Examples:: .......... (replace "abcdefghij" "0123456789" :start1 4 :end1 7 :start2 4) => "abcd456hij" (setq lst "012345678") => "012345678" (replace lst lst :start1 2 :start2 0) => "010123456" lst => "010123456" Side Effects:: .............. The sequence-1 is modified. See Also:: .......... *note fill::  File: gcl.info, Node: substitute, Next: concatenate, Prev: replace, Up: Sequences Dictionary 17.3.19 substitute, substitute-if, substitute-if-not, ----------------------------------------------------- nsubstitute, nsubstitute-if, nsubstitute-if-not ----------------------------------------------- [Function] 'substitute' newitem olditem sequence &key from-end test test-not start end count key => result-sequence 'substitute-if' newitem predicate sequence &key from-end start end count key => result-sequence 'substitute-if-not' newitem predicate sequence &key from-end start end count key => result-sequence 'nsubstitute' newitem olditem sequence &key from-end test test-not start end count key => sequence 'nsubstitute-if' newitem predicate sequence &key from-end start end count key => sequence 'nsubstitute-if-not' newitem predicate sequence &key from-end start end count key => sequence Arguments and Values:: ...................... newitem--an object. olditem--an object. sequence--a proper sequence. predicate--a designator for a function of one argument that returns a generalized boolean. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. count--an integer or nil. The default is nil. key--a designator for a function of one argument, or nil. result-sequence--a sequence. Description:: ............. substitute, substitute-if, and substitute-if-not return a copy of sequence in which each element that satisfies the test has been replaced with newitem. nsubstitute, nsubstitute-if, and nsubstitute-if-not are like substitute, substitute-if, and substitute-if-not respectively, but they may modify sequence. If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list. Count, if supplied, limits the number of elements altered; if more than count elements satisfy the test, then of these elements only the leftmost or rightmost, depending on from-end, are replaced, as many as specified by count. If count is supplied and negative, the behavior is as if zero had been supplied instead. If count is nil, all matching items are affected. Supplying a from-end of true matters only when the count is provided (and non-nil); in that case, only the rightmost count elements satisfying the test are removed (instead of the leftmost). predicate, test, and test-not might be called more than once for each sequence element, and their side effects can happen in any order. The result of all these functions is a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been replaced by newitem. substitute, substitute-if, and substitute-if-not return a sequence which can share with sequence or may be identical to the input sequence if no elements need to be changed. nsubstitute and nsubstitute-if are required to setf any car (if sequence is a list) or aref (if sequence is a vector) of sequence that is required to be replaced with newitem. If sequence is a list, none of the cdrs of the top-level list can be modified. Examples:: .......... (substitute #\. #\SPACE "0 2 4 6") => "0.2.4.6" (substitute 9 4 '(1 2 4 1 3 4 5)) => (1 2 9 1 3 9 5) (substitute 9 4 '(1 2 4 1 3 4 5) :count 1) => (1 2 9 1 3 4 5) (substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) => (1 2 4 1 3 9 5) (substitute 9 3 '(1 2 4 1 3 4 5) :test #'>) => (9 9 4 9 3 4 5) (substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car) => ((1) (2) (3) 0) (substitute-if 9 #'oddp '(1 2 4 1 3 4 5)) => (9 2 4 9 9 4 9) (substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) => (1 2 4 1 3 9 5) (setq some-things (list 'a 'car 'b 'cdr 'c)) => (A CAR B CDR C) (nsubstitute-if "function was here" #'fboundp some-things :count 1 :from-end t) => (A CAR B "function was here" C) some-things => (A CAR B "function was here" C) (setq alpha-tester (copy-seq "ab ")) => "ab " (nsubstitute-if-not #\z #'alpha-char-p alpha-tester) => "abz" alpha-tester => "abz" Side Effects:: .............. nsubstitute, nsubstitute-if, and nsubstitute-if-not modify sequence. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note subst:: , nsubst, *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. The functions substitute-if-not and nsubstitute-if-not are deprecated. nsubstitute and nsubstitute-if can be used in for-effect-only positions in code. Because the side-effecting variants (e.g., nsubstitute) potentially change the path that is being traversed, their effects in the presence of shared or circular structure may vary in surprising ways when compared to their non-side-effecting alternatives. To see this, consider the following side-effect behavior, which might be exhibited by some implementations: (defun test-it (fn) (let ((x (cons 'b nil))) (rplacd x x) (funcall fn 'a 'b x :count 1))) (test-it #'substitute) => (A . #1=(B . #1#)) (test-it #'nsubstitute) => (A . #1#)  File: gcl.info, Node: concatenate, Next: merge, Prev: substitute, Up: Sequences Dictionary 17.3.20 concatenate [Function] ------------------------------ 'concatenate' result-type &rest sequences => result-sequence Arguments and Values:: ...................... result-type--a sequence type specifier. sequences--a sequence. result-sequence--a proper sequence of type result-type. Description:: ............. concatenate returns a sequence that contains all the individual elements of all the sequences in the order that they are supplied. The sequence is of type result-type, which must be a subtype of type sequence. All of the sequences are copied from; the result does not share any structure with any of the sequences. Therefore, if only one sequence is provided and it is of type result-type, concatenate is required to copy sequence rather than simply returning it. It is an error if any element of the sequences cannot be an element of the sequence result. [Reviewer Note by Barmar: Should signal?] If the result-type is a subtype of list, the result will be a list. If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled. Examples:: .......... (concatenate 'string "all" " " "together" " " "now") => "all together now" (concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011) => (#\A #\B #\C D E F 1 2 3 1 0 1 1) (concatenate 'list) => NIL (concatenate '(vector * 2) "a" "bc") should signal an error Exceptional Situations:: ........................ An error is signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector. An error of type type-error should be signaled if result-type specifies the number of elements and the sum of sequences is different from that number. See Also:: .......... *note append::  File: gcl.info, Node: merge, Next: remove, Prev: concatenate, Up: Sequences Dictionary 17.3.21 merge [Function] ------------------------ 'merge' result-type sequence-1 sequence-2 predicate &key key => result-sequence Arguments and Values:: ...................... result-type--a sequence type specifier. sequence-1--a sequence. sequence-2--a sequence. predicate--a designator for a function of two arguments that returns a generalized boolean. key--a designator for a function of one argument, or nil. result-sequence--a proper sequence of type result-type. Description:: ............. Destructively merges sequence-1 with sequence-2 according to an order determined by the predicate. merge determines the relationship between two elements by giving keys extracted from the sequence elements to the predicate. The first argument to the predicate function is an element of sequence-1 as returned by the key (if supplied); the second argument is an element of sequence-2 as returned by the key (if supplied). Predicate should return true if and only if its first argument is strictly less than the second (in some appropriate sense). If the first argument is greater than or equal to the second (in the appropriate sense), then predicate should return false. merge considers two elements x and y to be equal if (funcall predicate x y) and (funcall predicate y x) both yield false. The argument to the key is the sequence element. Typically, the return value of the key becomes the argument to predicate. If key is not supplied or nil, the sequence element itself is used. The key may be executed more than once for each sequence element, and its side effects may occur in any order. If key and predicate return, then the merging operation will terminate. The result of merging two sequences x and y is a new sequence of type result-type z, such that the length of z is the sum of the lengths of x and y, and z contains all the elements of x and y. If x1 and x2 are two elements of x, and x1 precedes x2 in x, then x1 precedes x2 in z, and similarly for elements of y. In short, z is an interleaving of x and y. If x and y were correctly sorted according to the predicate, then z will also be correctly sorted. If x or y is not so sorted, then z will not be sorted, but will nevertheless be an interleaving of x and y. The merging operation is guaranteed stable; if two or more elements are considered equal by the predicate, then the elements from sequence-1 will precede those from sequence-2 in the result. sequence-1 and/or sequence-2 may be destroyed. If the result-type is a subtype of list, the result will be a list. If the result-type is a subtype of vector, then if the implementation can determine the element type specified for the result-type, the element type of the resulting array is the result of upgrading that element type; or, if the implementation can determine that the element type is unspecified (or *), the element type of the resulting array is t; otherwise, an error is signaled. Examples:: .......... (setq test1 (list 1 3 4 6 7)) (setq test2 (list 2 5 8)) (merge 'list test1 test2 #'<) => (1 2 3 4 5 6 7 8) (setq test1 (copy-seq "BOY")) (setq test2 (copy-seq :nosy")) (merge 'string test1 test2 #'char-lessp) => "BnOosYy" (setq test1 (vector ((red . 1) (blue . 4)))) (setq test2 (vector ((yellow . 2) (green . 7)))) (merge 'vector test1 test2 #'< :key #'cdr) => #((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7)) (merge '(vector * 4) '(1 5) '(2 4 6) #'<) should signal an error Exceptional Situations:: ........................ An error must be signaled if the result-type is neither a recognizable subtype of list, nor a recognizable subtype of vector. An error of type type-error should be signaled if result-type specifies the number of elements and the sum of the lengths of sequence-1 and sequence-2 is different from that number. See Also:: .......... *note sort:: , stable-sort, *note Compiler Terminology::, *note Traversal Rules and Side Effects::  File: gcl.info, Node: remove, Next: remove-duplicates, Prev: merge, Up: Sequences Dictionary 17.3.22 remove, remove-if, remove-if-not, ----------------------------------------- delete, delete-if, delete-if-not -------------------------------- [Function] 'remove' item sequence &key from-end test test-not start end count key => result-sequence 'remove-if' test sequence &key from-end start end count key => result-sequence 'remove-if-not' test sequence &key from-end start end count key => result-sequence 'delete' item sequence &key from-end test test-not start end count key => result-sequence 'delete-if' test sequence &key from-end start end count key => result-sequence 'delete-if-not' test sequence &key from-end start end count key => result-sequence Arguments and Values:: ...................... item--an object. sequence--a proper sequence. test--a designator for a function of one argument that returns a generalized boolean. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. count--an integer or nil. The default is nil. key--a designator for a function of one argument, or nil. result-sequence--a sequence. Description:: ............. remove, remove-if, and remove-if-not return a sequence from which the elements that satisfy the test have been removed. delete, delete-if, and delete-if-not are like remove, remove-if, and remove-if-not respectively, but they may modify sequence. If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list. Supplying a from-end of true matters only when the count is provided; in that case only the rightmost count elements satisfying the test are deleted. Count, if supplied, limits the number of elements removed or deleted; if more than count elements satisfy the test, then of these elements only the leftmost or rightmost, depending on from-end, are deleted or removed, as many as specified by count. If count is supplied and negative, the behavior is as if zero had been supplied instead. If count is nil, all matching items are affected. For all these functions, elements not removed or deleted occur in the same order in the result as they did in sequence. remove, remove-if, remove-if-not return a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been removed. This is a non-destructive operation. If any elements need to be removed, the result will be a copy. The result of remove may share with sequence; the result may be identical to the input sequence if no elements need to be removed. delete, delete-if, and delete-if-not return a sequence of the same type as sequence that has the same elements except that those in the subsequence bounded by start and end and satisfying the test have been deleted. Sequence may be destroyed and used to construct the result; however, the result might or might not be identical to sequence. delete, when sequence is a list, is permitted to setf any part, car or cdr, of the top-level list structure in that sequence. When sequence is a vector, delete is permitted to change the dimensions of the vector and to slide its elements into new positions without permuting them to produce the resulting vector. delete-if is constrained to behave exactly as follows: (delete nil sequence :test #'(lambda (ignore item) (funcall test item)) ...) Examples:: .......... (remove 4 '(1 3 4 5 9)) => (1 3 5 9) (remove 4 '(1 2 4 1 3 4 5)) => (1 2 1 3 5) (remove 4 '(1 2 4 1 3 4 5) :count 1) => (1 2 1 3 4 5) (remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t) => (1 2 4 1 3 5) (remove 3 '(1 2 4 1 3 4 5) :test #'>) => (4 3 4 5) (setq lst '(list of four elements)) => (LIST OF FOUR ELEMENTS) (setq lst2 (copy-seq lst)) => (LIST OF FOUR ELEMENTS) (setq lst3 (delete 'four lst)) => (LIST OF ELEMENTS) (equal lst lst2) => false (remove-if #'oddp '(1 2 4 1 3 4 5)) => (2 4 4) (remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t) => (1 2 4 1 3 5) (remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t) => (1 2 3 4 5 6 8) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete 4 tester) => (1 2 1 3 5) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete 4 tester :count 1) => (1 2 1 3 4 5) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete 4 tester :count 1 :from-end t) => (1 2 4 1 3 5) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete 3 tester :test #'>) => (4 3 4 5) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete-if #'oddp tester) => (2 4 4) (setq tester (list 1 2 4 1 3 4 5)) => (1 2 4 1 3 4 5) (delete-if #'evenp tester :count 1 :from-end t) => (1 2 4 1 3 5) (setq tester (list 1 2 3 4 5 6)) => (1 2 3 4 5 6) (delete-if #'evenp tester) => (1 3 5) tester => implementation-dependent (setq foo (list 'a 'b 'c)) => (A B C) (setq bar (cdr foo)) => (B C) (setq foo (delete 'b foo)) => (A C) bar => ((C)) or ... (eq (cdr foo) (car bar)) => T or ... Side Effects:: .............. For delete, delete-if, and delete-if-not, sequence may be destroyed and used to construct the result. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. The functions delete-if-not and remove-if-not are deprecated.  File: gcl.info, Node: remove-duplicates, Prev: remove, Up: Sequences Dictionary 17.3.23 remove-duplicates, delete-duplicates [Function] ------------------------------------------------------- 'remove-duplicates' sequence &key from-end test test-not start end key => result-sequence 'delete-duplicates' sequence &key from-end test test-not start end key => result-sequence Arguments and Values:: ...................... sequence--a proper sequence. from-end--a generalized boolean. The default is false. test--a designator for a function of two arguments that returns a generalized boolean. test-not--a designator for a function of two arguments that returns a generalized boolean. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. key--a designator for a function of one argument, or nil. result-sequence--a sequence. Description:: ............. remove-duplicates returns a modified copy of sequence from which any element that matches another element occurring in sequence has been removed. If sequence is a vector, the result is a vector that has the same actual array element type as sequence. The result might or might not be simple, and might or might not be identical to sequence. If sequence is a list, the result is a list. delete-duplicates is like remove-duplicates, but delete-duplicates may modify sequence. The elements of sequence are compared pairwise, and if any two match, then the one occurring earlier in sequence is discarded, unless from-end is true, in which case the one later in sequence is discarded. remove-duplicates and delete-duplicates return a sequence of the same type as sequence with enough elements removed so that no two of the remaining elements match. The order of the elements remaining in the result is the same as the order in which they appear in sequence. remove-duplicates returns a sequence that may share with sequence or may be identical to sequence if no elements need to be removed. delete-duplicates, when sequence is a list, is permitted to setf any part, car or cdr, of the top-level list structure in that sequence. When sequence is a vector, delete-duplicates is permitted to change the dimensions of the vector and to slide its elements into new positions without permuting them to produce the resulting vector. Examples:: .......... (remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t) => "aBcD" (remove-duplicates '(a b c b d d e)) => (A C B D E) (remove-duplicates '(a b c b d d e) :from-end t) => (A B C D E) (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr) => ((BAR #\%) (BAZ #\A)) (remove-duplicates '((foo #\a) (bar #\%) (baz #\A)) :test #'char-equal :key #'cadr :from-end t) => ((FOO #\a) (BAR #\%)) (setq tester (list 0 1 2 3 4 5 6)) (delete-duplicates tester :key #'oddp :start 1 :end 6) => (0 4 5 6) Side Effects:: .............. delete-duplicates might destructively modify sequence. Exceptional Situations:: ........................ Should signal an error of type type-error if sequence is not a proper sequence. See Also:: .......... *note Compiler Terminology::, *note Traversal Rules and Side Effects:: Notes:: ....... The :test-not argument is deprecated. These functions are useful for converting sequence into a canonical form suitable for representing a set.  File: gcl.info, Node: Hash Tables, Next: Filenames, Prev: Sequences, Up: Top 18 Hash Tables ************** * Menu: * Hash Table Concepts:: * Hash Tables Dictionary::  File: gcl.info, Node: Hash Table Concepts, Next: Hash Tables Dictionary, Prev: Hash Tables, Up: Hash Tables 18.1 Hash Table Concepts ======================== * Menu: * Hash-Table Operations:: * Modifying Hash Table Keys::  File: gcl.info, Node: Hash-Table Operations, Next: Modifying Hash Table Keys, Prev: Hash Table Concepts, Up: Hash Table Concepts 18.1.1 Hash-Table Operations ---------------------------- Figure 18-1 lists some defined names that are applicable to hash tables. The following rules apply to hash tables. - A hash table can only associate one value with a given key. If an attempt is made to add a second value for a given key, the second value will replace the first. Thus, adding a value to a hash table is a destructive operation; the hash table is modified. - There are four kinds of hash tables: those whose keys are compared with eq, those whose keys are compared with eql, those whose keys are compared with equal, and those whose keys are compared with equalp. - Hash tables are created by make-hash-table. gethash is used to look up a key and find the associated value. New entries are added to hash tables using setf with gethash. remhash is used to remove an entry. For example: (setq a (make-hash-table)) => # (setf (gethash 'color a) 'brown) => BROWN (setf (gethash 'name a) 'fred) => FRED (gethash 'color a) => BROWN, true (gethash 'name a) => FRED, true (gethash 'pointy a) => NIL, false In this example, the symbols color and name are being used as keys, and the symbols brown and fred are being used as the associated values. The hash table has two items in it, one of which associates from color to brown, and the other of which associates from name to fred. - A key or a value may be any object. - The existence of an entry in the hash table can be determined from the secondary value returned by gethash. clrhash hash-table-p remhash gethash make-hash-table sxhash hash-table-count maphash Figure 18-1: Hash-table defined names  File: gcl.info, Node: Modifying Hash Table Keys, Prev: Hash-Table Operations, Up: Hash Table Concepts 18.1.2 Modifying Hash Table Keys -------------------------------- The function supplied as the :test argument to make-hash-table specifies the 'equivalence test' for the hash table it creates. An object is 'visibly modified' with regard to an equivalence test if there exists some set of objects (or potential objects) which are equivalent to the object before the modification but are no longer equivalent afterwards. If an object O_1 is used as a key in a hash table H and is then visibly modified with regard to the equivalence test of H, then the consequences are unspecified if O_1, or any object O_2 equivalent to O_1 under the equivalence test (either before or after the modification), is used as a key in further operations on H. The consequences of using O_1 as a key are unspecified even if O_1 is visibly modified and then later modified again in such a way as to undo the visible modification. Following are specifications of the modifications which are visible to the equivalence tests which must be supported by hash tables. The modifications are described in terms of modification of components, and are defined recursively. Visible modifications of components of the object are visible modifications of the object. * Menu: * Visible Modification of Objects with respect to EQ and EQL:: * Visible Modification of Objects with respect to EQUAL:: * Visible Modification of Conses with respect to EQUAL:: * Visible Modification of Bit Vectors and Strings with respect to EQUAL:: * Visible Modification of Objects with respect to EQUALP:: * Visible Modification of Structures with respect to EQUALP:: * Visible Modification of Arrays with respect to EQUALP:: * Visible Modification of Hash Tables with respect to EQUALP:: * Visible Modifications by Language Extensions::  File: gcl.info, Node: Visible Modification of Objects with respect to EQ and EQL, Next: Visible Modification of Objects with respect to EQUAL, Prev: Modifying Hash Table Keys, Up: Modifying Hash Table Keys 18.1.2.1 Visible Modification of Objects with respect to EQ and EQL ................................................................... No standardized function is provided that is capable of visibly modifying an object with regard to eq or eql.  File: gcl.info, Node: Visible Modification of Objects with respect to EQUAL, Next: Visible Modification of Conses with respect to EQUAL, Prev: Visible Modification of Objects with respect to EQ and EQL, Up: Modifying Hash Table Keys 18.1.2.2 Visible Modification of Objects with respect to EQUAL .............................................................. As a consequence of the behavior for equal, the rules for visible modification of objects not explicitly mentioned in this section are inherited from those in *note Visible Modification of Objects with respect to EQ and EQL::.  File: gcl.info, Node: Visible Modification of Conses with respect to EQUAL, Next: Visible Modification of Bit Vectors and Strings with respect to EQUAL, Prev: Visible Modification of Objects with respect to EQUAL, Up: Modifying Hash Table Keys 18.1.2.3 Visible Modification of Conses with respect to EQUAL ............................................................. Any visible change to the car or the cdr of a cons is considered a visible modification with regard to equal.  File: gcl.info, Node: Visible Modification of Bit Vectors and Strings with respect to EQUAL, Next: Visible Modification of Objects with respect to EQUALP, Prev: Visible Modification of Conses with respect to EQUAL, Up: Modifying Hash Table Keys 18.1.2.4 Visible Modification of Bit Vectors and Strings with respect to EQUAL .............................................................................. For a vector of type bit-vector or of type string, any visible change to an active element of the vector, or to the length of the vector (if it is actually adjustable or has a fill pointer) is considered a visible modification with regard to equal.  File: gcl.info, Node: Visible Modification of Objects with respect to EQUALP, Next: Visible Modification of Structures with respect to EQUALP, Prev: Visible Modification of Bit Vectors and Strings with respect to EQUAL, Up: Modifying Hash Table Keys 18.1.2.5 Visible Modification of Objects with respect to EQUALP ............................................................... As a consequence of the behavior for equalp, the rules for visible modification of objects not explicitly mentioned in this section are inherited from those in *note Visible Modification of Objects with respect to EQUAL::.  File: gcl.info, Node: Visible Modification of Structures with respect to EQUALP, Next: Visible Modification of Arrays with respect to EQUALP, Prev: Visible Modification of Objects with respect to EQUALP, Up: Modifying Hash Table Keys 18.1.2.6 Visible Modification of Structures with respect to EQUALP .................................................................. Any visible change to a slot of a structure is considered a visible modification with regard to equalp.  File: gcl.info, Node: Visible Modification of Arrays with respect to EQUALP, Next: Visible Modification of Hash Tables with respect to EQUALP, Prev: Visible Modification of Structures with respect to EQUALP, Up: Modifying Hash Table Keys 18.1.2.7 Visible Modification of Arrays with respect to EQUALP .............................................................. In an array, any visible change to an active element, to the fill pointer (if the array can and does have one), or to the dimensions (if the array is actually adjustable) is considered a visible modification with regard to equalp.  File: gcl.info, Node: Visible Modification of Hash Tables with respect to EQUALP, Next: Visible Modifications by Language Extensions, Prev: Visible Modification of Arrays with respect to EQUALP, Up: Modifying Hash Table Keys 18.1.2.8 Visible Modification of Hash Tables with respect to EQUALP ................................................................... In a hash table, any visible change to the count of entries in the hash table, to the keys, or to the values associated with the keys is considered a visible modification with regard to equalp. Note that the visibility of modifications to the keys depends on the equivalence test of the hash table, not on the specification of equalp.  File: gcl.info, Node: Visible Modifications by Language Extensions, Prev: Visible Modification of Hash Tables with respect to EQUALP, Up: Modifying Hash Table Keys 18.1.2.9 Visible Modifications by Language Extensions ..................................................... Implementations that extend the language by providing additional mutator functions (or additional behavior for existing mutator functions) must document how the use of these extensions interacts with equivalence tests and hash table searches. Implementations that extend the language by defining additional acceptable equivalence tests for hash tables (allowing additional values for the :test argument to make-hash-table) must document the visible components of these tests.  File: gcl.info, Node: Hash Tables Dictionary, Prev: Hash Table Concepts, Up: Hash Tables 18.2 Hash Tables Dictionary =========================== * Menu: * hash-table:: * make-hash-table:: * hash-table-p:: * hash-table-count:: * hash-table-rehash-size:: * hash-table-rehash-threshold:: * hash-table-size:: * hash-table-test:: * gethash:: * remhash:: * maphash:: * with-hash-table-iterator:: * clrhash:: * sxhash::  File: gcl.info, Node: hash-table, Next: make-hash-table, Prev: Hash Tables Dictionary, Up: Hash Tables Dictionary 18.2.1 hash-table [System Class] -------------------------------- Class Precedence List:: ....................... hash-table, t Description:: ............. Hash tables provide a way of mapping any object (a key) to an associated object (a value). See Also:: .......... *note Hash Table Concepts::, *note Printing Other Objects:: Notes:: ....... The intent is that this mapping be implemented by a hashing mechanism, such as that described in Section 6.4 "Hashing" of The Art of Computer Programming, Volume 3 (pp506-549). In spite of this intent, no conforming implementation is required to use any particular technique to implement the mapping.  File: gcl.info, Node: make-hash-table, Next: hash-table-p, Prev: hash-table, Up: Hash Tables Dictionary 18.2.2 make-hash-table [Function] --------------------------------- 'make-hash-table' &key test size rehash-size rehash-threshold => hash-table Arguments and Values:: ...................... test--a designator for one of the functions eq, eql, equal, or equalp. The default is eql. size--a non-negative integer. The default is implementation-dependent. rehash-size--a real of type (or (integer 1 *) (float (1.0) *)). The default is implementation-dependent. rehash-threshold--a real of type (real 0 1). The default is implementation-dependent. hash-table--a hash table. Description:: ............. Creates and returns a new hash table. test determines how keys are compared. An object is said to be present in the hash-table if that object is the same under the test as the key for some entry in the hash-table. size is a hint to the implementation about how much initial space to allocate in the hash-table. This information, taken together with the rehash-threshold, controls the approximate number of entries which it should be possible to insert before the table has to grow. The actual size might be rounded up from size to the next 'good' size; for example, some implementations might round to the next prime number. rehash-size specifies a minimum amount to increase the size of the hash-table when it becomes full enough to require rehashing; see rehash-theshold below. If rehash-size is an integer, the expected growth rate for the table is additive and the integer is the number of entries to add; if it is a float, the expected growth rate for the table is multiplicative and the float is the ratio of the new size to the old size. As with size, the actual size of the increase might be rounded up. rehash-threshold specifies how full the hash-table can get before it must grow. It specifies the maximum desired hash-table occupancy level. The values of rehash-size and rehash-threshold do not constrain the implementation to use any particular method for computing when and by how much the size of hash-table should be enlarged. Such decisions are implementation-dependent, and these values only hints from the programmer to the implementation, and the implementation is permitted to ignore them. Examples:: .......... (setq table (make-hash-table)) => # (setf (gethash "one" table) 1) => 1 (gethash "one" table) => NIL, false (setq table (make-hash-table :test 'equal)) => # (setf (gethash "one" table) 1) => 1 (gethash "one" table) => 1, T (make-hash-table :rehash-size 1.5 :rehash-threshold 0.7) => # See Also:: .......... *note gethash:: , hash-table  File: gcl.info, Node: hash-table-p, Next: hash-table-count, Prev: make-hash-table, Up: Hash Tables Dictionary 18.2.3 hash-table-p [Function] ------------------------------ 'hash-table-p' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type hash-table; otherwise, returns false. Examples:: .......... (setq table (make-hash-table)) => # (hash-table-p table) => true (hash-table-p 37) => false (hash-table-p '((a . 1) (b . 2))) => false Notes:: ....... (hash-table-p object) == (typep object 'hash-table)  File: gcl.info, Node: hash-table-count, Next: hash-table-rehash-size, Prev: hash-table-p, Up: Hash Tables Dictionary 18.2.4 hash-table-count [Function] ---------------------------------- 'hash-table-count' hash-table => count Arguments and Values:: ...................... hash-table--a hash table. count--a non-negative integer. Description:: ............. Returns the number of entries in the hash-table. If hash-table has just been created or newly cleared (see clrhash) the entry count is 0. Examples:: .......... (setq table (make-hash-table)) => # (hash-table-count table) => 0 (setf (gethash 57 table) "fifty-seven") => "fifty-seven" (hash-table-count table) => 1 (dotimes (i 100) (setf (gethash i table) i)) => NIL (hash-table-count table) => 100 Affected By:: ............. clrhash, remhash, setf of gethash See Also:: .......... *note hash-table-size:: Notes:: ....... The following relationships are functionally correct, although in practice using hash-table-count is probably much faster: (hash-table-count table) == (loop for value being the hash-values of table count t) == (let ((total 0)) (maphash #'(lambda (key value) (declare (ignore key value)) (incf total)) table) total)  File: gcl.info, Node: hash-table-rehash-size, Next: hash-table-rehash-threshold, Prev: hash-table-count, Up: Hash Tables Dictionary 18.2.5 hash-table-rehash-size [Function] ---------------------------------------- 'hash-table-rehash-size' hash-table => rehash-size Arguments and Values:: ...................... hash-table--a hash table. rehash-size--a real of type (or (integer 1 *) (float (1.0) *)). Description:: ............. Returns the current rehash size of hash-table, suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table. Examples:: .......... (setq table (make-hash-table :size 100 :rehash-size 1.4)) => # (hash-table-rehash-size table) => 1.4 Exceptional Situations:: ........................ Should signal an error of type type-error if hash-table is not a hash table. See Also:: .......... *note make-hash-table:: , *note hash-table-rehash-threshold:: Notes:: ....... If the hash table was created with an integer rehash size, the result is an integer, indicating that the rate of growth of the hash-table when rehashed is intended to be additive; otherwise, the result is a float, indicating that the rate of growth of the hash-table when rehashed is intended to be multiplicative. However, this value is only advice to the implementation; the actual amount by which the hash-table will grow upon rehash is implementation-dependent.  File: gcl.info, Node: hash-table-rehash-threshold, Next: hash-table-size, Prev: hash-table-rehash-size, Up: Hash Tables Dictionary 18.2.6 hash-table-rehash-threshold [Function] --------------------------------------------- 'hash-table-rehash-threshold' hash-table => rehash-threshold Arguments and Values:: ...................... hash-table--a hash table. rehash-threshold--a real of type (real 0 1). Description:: ............. Returns the current rehash threshold of hash-table, which is suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table. Examples:: .......... (setq table (make-hash-table :size 100 :rehash-threshold 0.5)) => # (hash-table-rehash-threshold table) => 0.5 Exceptional Situations:: ........................ Should signal an error of type type-error if hash-table is not a hash table. See Also:: .......... *note make-hash-table:: , *note hash-table-rehash-size::  File: gcl.info, Node: hash-table-size, Next: hash-table-test, Prev: hash-table-rehash-threshold, Up: Hash Tables Dictionary 18.2.7 hash-table-size [Function] --------------------------------- 'hash-table-size' hash-table => size Arguments and Values:: ...................... hash-table--a hash table. size--a non-negative integer. Description:: ............. Returns the current size of hash-table, which is suitable for use in a call to make-hash-table in order to produce a hash table with state corresponding to the current state of the hash-table. Exceptional Situations:: ........................ Should signal an error of type type-error if hash-table is not a hash table. See Also:: .......... *note hash-table-count:: , *note make-hash-table::  File: gcl.info, Node: hash-table-test, Next: gethash, Prev: hash-table-size, Up: Hash Tables Dictionary 18.2.8 hash-table-test [Function] --------------------------------- 'hash-table-test' hash-table => test Arguments and Values:: ...................... hash-table--a hash table. test--a function designator. For the four standardized hash table test functions (see make-hash-table), the test value returned is always a symbol. If an implementation permits additional tests, it is implementation-dependent whether such tests are returned as function objects or function names. Description:: ............. Returns the test used for comparing keys in hash-table. Exceptional Situations:: ........................ Should signal an error of type type-error if hash-table is not a hash table. See Also:: .......... *note make-hash-table::  File: gcl.info, Node: gethash, Next: remhash, Prev: hash-table-test, Up: Hash Tables Dictionary 18.2.9 gethash [Accessor] ------------------------- 'gethash' key hash-table &optional default => value, present-p (setf (' gethash' key hash-table &optional default) new-value) Arguments and Values:: ...................... key--an object. hash-table--a hash table. default--an object. The default is nil. value--an object. present-p--a generalized boolean. Description:: ............. Value is the object in hash-table whose key is the same as key under the hash-table's equivalence test. If there is no such entry, value is the default. Present-p is true if an entry is found; otherwise, it is false. setf may be used with gethash to modify the value associated with a given key, or to add a new entry. When a gethash form is used as a setf place, any default which is supplied is evaluated according to normal left-to-right evaluation rules, but its value is ignored. Examples:: .......... (setq table (make-hash-table)) => # (gethash 1 table) => NIL, false (gethash 1 table 2) => 2, false (setf (gethash 1 table) "one") => "one" (setf (gethash 2 table "two") "two") => "two" (gethash 1 table) => "one", true (gethash 2 table) => "two", true (gethash nil table) => NIL, false (setf (gethash nil table) nil) => NIL (gethash nil table) => NIL, true (defvar *counters* (make-hash-table)) => *COUNTERS* (gethash 'foo *counters*) => NIL, false (gethash 'foo *counters* 0) => 0, false (defmacro how-many (obj) `(values (gethash ,obj *counters* 0))) => HOW-MANY (defun count-it (obj) (incf (how-many obj))) => COUNT-IT (dolist (x '(bar foo foo bar bar baz)) (count-it x)) (how-many 'foo) => 2 (how-many 'bar) => 3 (how-many 'quux) => 0 See Also:: .......... *note remhash:: Notes:: ....... The secondary value, present-p, can be used to distinguish the absence of an entry from the presence of an entry that has a value of default.  File: gcl.info, Node: remhash, Next: maphash, Prev: gethash, Up: Hash Tables Dictionary 18.2.10 remhash [Function] -------------------------- 'remhash' key hash-table => generalized-boolean Arguments and Values:: ...................... key--an object. hash-table--a hash table. generalized-boolean--a generalized boolean. Description:: ............. Removes the entry for key in hash-table, if any. Returns true if there was such an entry, or false otherwise. Examples:: .......... (setq table (make-hash-table)) => # (setf (gethash 100 table) "C") => "C" (gethash 100 table) => "C", true (remhash 100 table) => true (gethash 100 table) => NIL, false (remhash 100 table) => false Side Effects:: .............. The hash-table is modified.  File: gcl.info, Node: maphash, Next: with-hash-table-iterator, Prev: remhash, Up: Hash Tables Dictionary 18.2.11 maphash [Function] -------------------------- 'maphash' function hash-table => nil Arguments and Values:: ...................... function--a designator for a function of two arguments, the key and the value. hash-table--a hash table. Description:: ............. Iterates over all entries in the hash-table. For each entry, the function is called with two arguments-the key and the value of that entry. The consequences are unspecified if any attempt is made to add or remove an entry from the hash-table while a maphash is in progress, with two exceptions: the function can use can use setf of gethash to change the value part of the entry currently being processed, or it can use remhash to remove that entry. Examples:: .......... (setq table (make-hash-table)) => # (dotimes (i 10) (setf (gethash i table) i)) => NIL (let ((sum-of-squares 0)) (maphash #'(lambda (key val) (let ((square (* val val))) (incf sum-of-squares square) (setf (gethash key table) square))) table) sum-of-squares) => 285 (hash-table-count table) => 10 (maphash #'(lambda (key val) (when (oddp val) (remhash key table))) table) => NIL (hash-table-count table) => 5 (maphash #'(lambda (k v) (print (list k v))) table) (0 0) (8 64) (2 4) (6 36) (4 16) => NIL Side Effects:: .............. None, other than any which might be done by the function. See Also:: .......... *note loop:: , *note with-hash-table-iterator:: , *note Traversal Rules and Side Effects::  File: gcl.info, Node: with-hash-table-iterator, Next: clrhash, Prev: maphash, Up: Hash Tables Dictionary 18.2.12 with-hash-table-iterator [Macro] ---------------------------------------- 'with-hash-table-iterator' (name hash-table) {declaration}* {form}* => {result}* Arguments and Values:: ...................... name--a name suitable for the first argument to macrolet. hash-table--a form, evaluated once, that should produce a hash table. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by forms. Description:: ............. Within the lexical scope of the body, name is defined via macrolet such that successive invocations of (name) return the items, one by one, from the hash table that is obtained by evaluating hash-table only once. An invocation (name) returns three values as follows: 1. A generalized boolean that is true if an entry is returned. 2. The key from the hash-table entry. 3. The value from the hash-table entry. After all entries have been returned by successive invocations of (name), then only one value is returned, namely nil. It is unspecified what happens if any of the implicit interior state of an iteration is returned outside the dynamic extent of the with-hash-table-iterator form such as by returning some closure over the invocation form. Any number of invocations of with-hash-table-iterator can be nested, and the body of the innermost one can invoke all of the locally established macros, provided all of those macros have distinct names. Examples:: .......... The following function should return t on any hash table, and signal an error if the usage of with-hash-table-iterator does not agree with the corresponding usage of maphash. (defun test-hash-table-iterator (hash-table) (let ((all-entries '()) (generated-entries '()) (unique (list nil))) (maphash #'(lambda (key value) (push (list key value) all-entries)) hash-table) (with-hash-table-iterator (generator-fn hash-table) (loop (multiple-value-bind (more? key value) (generator-fn) (unless more? (return)) (unless (eql value (gethash key hash-table unique)) (error "Key ~S not found for value ~S" key value)) (push (list key value) generated-entries)))) (unless (= (length all-entries) (length generated-entries) (length (union all-entries generated-entries :key #'car :test (hash-table-test hash-table)))) (error "Generated entries and Maphash entries don't correspond")) t)) The following could be an acceptable definition of maphash, implemented by with-hash-table-iterator. (defun maphash (function hash-table) (with-hash-table-iterator (next-entry hash-table) (loop (multiple-value-bind (more key value) (next-entry) (unless more (return nil)) (funcall function key value))))) Exceptional Situations:: ........................ The consequences are undefined if the local function named name established by with-hash-table-iterator is called after it has returned false as its primary value. See Also:: .......... *note Traversal Rules and Side Effects::  File: gcl.info, Node: clrhash, Next: sxhash, Prev: with-hash-table-iterator, Up: Hash Tables Dictionary 18.2.13 clrhash [Function] -------------------------- 'clrhash' hash-table => hash-table Arguments and Values:: ...................... hash-table--a hash table. Description:: ............. Removes all entries from hash-table, and then returns that empty hash table. Examples:: .......... (setq table (make-hash-table)) => # (dotimes (i 100) (setf (gethash i table) (format nil "~R" i))) => NIL (hash-table-count table) => 100 (gethash 57 table) => "fifty-seven", true (clrhash table) => # (hash-table-count table) => 0 (gethash 57 table) => NIL, false Side Effects:: .............. The hash-table is modified.  File: gcl.info, Node: sxhash, Prev: clrhash, Up: Hash Tables Dictionary 18.2.14 sxhash [Function] ------------------------- 'sxhash' object => hash-code Arguments and Values:: ...................... object--an object. hash-code--a non-negative fixnum. Description:: ............. sxhash returns a hash code for object. The manner in which the hash code is computed is implementation-dependent, but subject to certain constraints: 1. (equal x y) implies (= (sxhash x) (sxhash y)). 2. For any two objects, x and y, both of which are bit vectors, characters, conses, numbers, pathnames, strings, or symbols, and which are similar, (sxhash x) and (sxhash y) yield the same mathematical value even if x and y exist in different Lisp images of the same implementation. See *note Literal Objects in Compiled Files::. 3. The hash-code for an object is always the same within a single session provided that the object is not visibly modified with regard to the equivalence test equal. See *note Modifying Hash Table Keys::. 4. The hash-code is intended for hashing. This places no verifiable constraint on a conforming implementation, but the intent is that an implementation should make a good-faith effort to produce hash-codes that are well distributed within the range of non-negative fixnums. 5. Computation of the hash-code must terminate, even if the object contains circularities. Examples:: .......... (= (sxhash (list 'list "ab")) (sxhash (list 'list "ab"))) => true (= (sxhash "a") (sxhash (make-string 1 :initial-element #\a))) => true (let ((r (make-random-state))) (= (sxhash r) (sxhash (make-random-state r)))) => implementation-dependent Affected By:: ............. The implementation. Notes:: ....... Many common hashing needs are satisfied by make-hash-table and the related functions on hash tables. sxhash is intended for use where the pre-defined abstractions are insufficient. Its main intent is to allow the user a convenient means of implementing more complicated hashing paradigms than are provided through hash tables. The hash codes returned by sxhash are not necessarily related to any hashing strategy used by any other function in Common Lisp. For objects of types that equal compares with eq, item 3 requires that the hash-code be based on some immutable quality of the identity of the object. Another legitimate implementation technique would be to have sxhash assign (and cache) a random hash code for these objects, since there is no requirement that similar but non-eq objects have the same hash code. Although similarity is defined for symbols in terms of both the symbol's name and the packages in which the symbol is accessible, item 3 disallows using package information to compute the hash code, since changes to the package status of a symbol are not visible to equal.  File: gcl.info, Node: Filenames, Next: Files, Prev: Hash Tables, Up: Top 19 Filenames ************ * Menu: * Overview of Filenames:: * Pathnames:: * Logical Pathnames:: * Filenames Dictionary::  File: gcl.info, Node: Overview of Filenames, Next: Pathnames, Prev: Filenames, Up: Filenames 19.1 Overview of Filenames ========================== There are many kinds of file systems, varying widely both in their superficial syntactic details, and in their underlying power and structure. The facilities provided by Common Lisp for referring to and manipulating files has been chosen to be compatible with many kinds of file systems, while at the same time minimizing the program-visible differences between kinds of file systems. Since file systems vary in their conventions for naming files, there are two distinct ways to represent filenames: as namestrings and as pathnames. * Menu: * Namestrings as Filenames:: * Pathnames as Filenames:: * Parsing Namestrings Into Pathnames::  File: gcl.info, Node: Namestrings as Filenames, Next: Pathnames as Filenames, Prev: Overview of Filenames, Up: Overview of Filenames 19.1.1 Namestrings as Filenames ------------------------------- A namestring is a string that represents a filename. In general, the syntax of namestrings involves the use of implementation-defined conventions, usually those customary for the file system in which the named file resides. The only exception is the syntax of a logical pathname namestring, which is defined in this specification; see *note Syntax of Logical Pathname Namestrings::. A conforming program must never unconditionally use a literal namestring other than a logical pathname namestring because Common Lisp does not define any namestring syntax other than that for logical pathnames that would be guaranteed to be portable. However, a conforming program can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable namestrings. A namestring can be coerced to a pathname by the functions pathname or parse-namestring.  File: gcl.info, Node: Pathnames as Filenames, Next: Parsing Namestrings Into Pathnames, Prev: Namestrings as Filenames, Up: Overview of Filenames 19.1.2 Pathnames as Filenames ----------------------------- Pathnames are structured objects that can represent, in an implementation-independent way, the filenames that are used natively by an underlying file system. In addition, pathnames can also represent certain partially composed filenames for which an underlying file system might not have a specific namestring representation. A pathname need not correspond to any file that actually exists, and more than one pathname can refer to the same file. For example, the pathname with a version of :newest might refer to the same file as a pathname with the same components except a certain number as the version. Indeed, a pathname with version :newest might refer to different files as time passes, because the meaning of such a pathname depends on the state of the file system. Some file systems naturally use a structural model for their filenames, while others do not. Within the Common Lisp pathname model, all filenames are seen as having a particular structure, even if that structure is not reflected in the underlying file system. The nature of the mapping between structure imposed by pathnames and the structure, if any, that is used by the underlying file system is implementation-defined. Every pathname has six components: a host, a device, a directory, a name, a type, and a version. By naming files with pathnames, Common Lisp programs can work in essentially the same way even in file systems that seem superficially quite different. For a detailed description of these components, see *note Pathname Components::. The mapping of the pathname components into the concepts peculiar to each file system is implementation-defined. There exist conceivable pathnames for which there is no mapping to a syntactically valid filename in a particular implementation. An implementation may use various strategies in an attempt to find a mapping; for example, an implementation may quietly truncate filenames that exceed length limitations imposed by the underlying file system, or ignore certain pathname components for which the file system provides no support. If such a mapping cannot be found, an error of type file-error is signaled. The time at which this mapping and associated error signaling occurs is implementation-dependent. Specifically, it may occur at the time the pathname is constructed, when coercing a pathname to a namestring, or when an attempt is made to open or otherwise access the file designated by the pathname. Figure 19-1 lists some defined names that are applicable to pathnames. *default-pathname-defaults* namestring pathname-name directory-namestring open pathname-type enough-namestring parse-namestring pathname-version file-namestring pathname pathnamep file-string-length pathname-device translate-pathname host-namestring pathname-directory truename make-pathname pathname-host user-homedir-pathname merge-pathnames pathname-match-p wild-pathname-p Figure 19-1: Pathname Operations  File: gcl.info, Node: Parsing Namestrings Into Pathnames, Prev: Pathnames as Filenames, Up: Overview of Filenames 19.1.3 Parsing Namestrings Into Pathnames ----------------------------------------- Parsing is the operation used to convert a namestring into a pathname. Except in the case of parsing logical pathname namestrings, this operation is implementation-dependent, because the format of namestrings is implementation-dependent. A conforming implementation is free to accommodate other file system features in its pathname representation and provides a parser that can process such specifications in namestrings. Conforming programs must not depend on any such features, since those features will not be portable.  File: gcl.info, Node: Pathnames, Next: Logical Pathnames, Prev: Overview of Filenames, Up: Filenames 19.2 Pathnames ============== * Menu: * Pathname Components:: * Interpreting Pathname Component Values:: * Merging Pathnames::  File: gcl.info, Node: Pathname Components, Next: Interpreting Pathname Component Values, Prev: Pathnames, Up: Pathnames 19.2.1 Pathname Components -------------------------- A pathname has six components: a host, a device, a directory, a name, a type, and a version. * Menu: * The Pathname Host Component:: * The Pathname Device Component:: * The Pathname Directory Component:: * The Pathname Name Component:: * The Pathname Type Component:: * The Pathname Version Component::  File: gcl.info, Node: The Pathname Host Component, Next: The Pathname Device Component, Prev: Pathname Components, Up: Pathname Components 19.2.1.1 The Pathname Host Component .................................... The name of the file system on which the file resides, or the name of a logical host.  File: gcl.info, Node: The Pathname Device Component, Next: The Pathname Directory Component, Prev: The Pathname Host Component, Up: Pathname Components 19.2.1.2 The Pathname Device Component ...................................... Corresponds to the "device" or "file structure" concept in many host file systems: the name of a logical or physical device containing files.  File: gcl.info, Node: The Pathname Directory Component, Next: The Pathname Name Component, Prev: The Pathname Device Component, Up: Pathname Components 19.2.1.3 The Pathname Directory Component ......................................... Corresponds to the "directory" concept in many host file systems: the name of a group of related files.  File: gcl.info, Node: The Pathname Name Component, Next: The Pathname Type Component, Prev: The Pathname Directory Component, Up: Pathname Components 19.2.1.4 The Pathname Name Component .................................... The "name" part of a group of files that can be thought of as conceptually related.  File: gcl.info, Node: The Pathname Type Component, Next: The Pathname Version Component, Prev: The Pathname Name Component, Up: Pathname Components 19.2.1.5 The Pathname Type Component .................................... Corresponds to the "filetype" or "extension" concept in many host file systems. This says what kind of file this is. This component is always a string, nil, :wild, or :unspecific.  File: gcl.info, Node: The Pathname Version Component, Prev: The Pathname Type Component, Up: Pathname Components 19.2.1.6 The Pathname Version Component ....................................... Corresponds to the "version number" concept in many host file systems. The version is either a positive integer or a symbol from the following list: nil, :wild, :unspecific, or :newest (refers to the largest version number that already exists in the file system when reading a file, or to a version number greater than any already existing in the file system when writing a new file). Implementations can define other special version symbols.  File: gcl.info, Node: Interpreting Pathname Component Values, Next: Merging Pathnames, Prev: Pathname Components, Up: Pathnames 19.2.2 Interpreting Pathname Component Values --------------------------------------------- * Menu: * Strings in Component Values:: * Special Characters in Pathname Components:: * Case in Pathname Components:: * Local Case in Pathname Components:: * Common Case in Pathname Components:: * Special Pathname Component Values:: * NIL as a Component Value:: * ->WILD as a Component Value:: * ->UNSPECIFIC as a Component Value:: * Relation between component values NIL and ->UNSPECIFIC:: * Restrictions on Wildcard Pathnames:: * Restrictions on Examining Pathname Components:: * Restrictions on Examining a Pathname Host Component:: * Restrictions on Examining a Pathname Device Component:: * Restrictions on Examining a Pathname Directory Component:: * Directory Components in Non-Hierarchical File Systems:: * Restrictions on Examining a Pathname Name Component:: * Restrictions on Examining a Pathname Type Component:: * Restrictions on Examining a Pathname Version Component:: * Notes about the Pathname Version Component:: * Restrictions on Constructing Pathnames::  File: gcl.info, Node: Strings in Component Values, Next: Special Characters in Pathname Components, Prev: Interpreting Pathname Component Values, Up: Interpreting Pathname Component Values 19.2.2.1 Strings in Component Values ....................................  File: gcl.info, Node: Special Characters in Pathname Components, Next: Case in Pathname Components, Prev: Strings in Component Values, Up: Interpreting Pathname Component Values 19.2.2.2 Special Characters in Pathname Components .................................................. Strings in pathname component values never contain special characters that represent separation between pathname fields, such as slash in Unix filenames. Whether separator characters are permitted as part of a string in a pathname component is implementation-defined; however, if the implementation does permit it, it must arrange to properly "quote" the character for the file system when constructing a namestring. For example, ;; In a TOPS-20 implementation, which uses ^V to quote (NAMESTRING (MAKE-PATHNAME :HOST "OZ" :NAME "")) => #P"OZ:PS:^V" NOT=> #P"OZ:PS:"  File: gcl.info, Node: Case in Pathname Components, Next: Local Case in Pathname Components, Prev: Special Characters in Pathname Components, Up: Interpreting Pathname Component Values 19.2.2.3 Case in Pathname Components .................................... Namestrings always use local file system case conventions, but Common Lisp functions that manipulate pathname components allow the caller to select either of two conventions for representing case in component values by supplying a value for the :case keyword argument. Figure 19-2 lists the functions relating to pathnames that permit a :case argument: make-pathname pathname-directory pathname-name pathname-device pathname-host pathname-type Figure 19-2: Pathname functions using a :CASE argument  File: gcl.info, Node: Local Case in Pathname Components, Next: Common Case in Pathname Components, Prev: Case in Pathname Components, Up: Interpreting Pathname Component Values 19.2.2.4 Local Case in Pathname Components .......................................... For the functions in Figure~19-2, a value of :local for the :case argument (the default for these functions) indicates that the functions should receive and yield strings in component values as if they were already represented according to the host file system's convention for case. If the file system supports both cases, strings given or received as pathname component values under this protocol are to be used exactly as written. If the file system only supports one case, the strings will be translated to that case.  File: gcl.info, Node: Common Case in Pathname Components, Next: Special Pathname Component Values, Prev: Local Case in Pathname Components, Up: Interpreting Pathname Component Values 19.2.2.5 Common Case in Pathname Components ........................................... For the functions in Figure~19-2, a value of :common for the :case argument that these functions should receive and yield strings in component values according to the following conventions: * All uppercase means to use a file system's customary case. * All lowercase means to use the opposite of the customary case. * Mixed case represents itself. Note that these conventions have been chosen in such a way that translation from :local to :common and back to :local is information-preserving.  File: gcl.info, Node: Special Pathname Component Values, Next: NIL as a Component Value, Prev: Common Case in Pathname Components, Up: Interpreting Pathname Component Values 19.2.2.6 Special Pathname Component Values ..........................................  File: gcl.info, Node: NIL as a Component Value, Next: ->WILD as a Component Value, Prev: Special Pathname Component Values, Up: Interpreting Pathname Component Values 19.2.2.7 NIL as a Component Value ................................. As a pathname component value, nil represents that the component is "unfilled"; see *note Merging Pathnames::. The value of any pathname component can be nil. When constructing a pathname, nil in the host component might mean a default host rather than an actual nil in some implementations.  File: gcl.info, Node: ->WILD as a Component Value, Next: ->UNSPECIFIC as a Component Value, Prev: NIL as a Component Value, Up: Interpreting Pathname Component Values 19.2.2.8 :WILD as a Component Value ................................... If :wild is the value of a pathname component, that component is considered to be a wildcard, which matches anything. A conforming program must be prepared to encounter a value of :wild as the value of any pathname component, or as an element of a list that is the value of the directory component. When constructing a pathname, a conforming program may use :wild as the value of any or all of the directory, name, type, or version component, but must not use :wild as the value of the host, or device component. If :wild is used as the value of the directory component in the construction of a pathname, the effect is equivalent to specifying the list (:absolute :wild-inferiors), or the same as (:absolute :wild) in a file system that does not support :wild-inferiors.  File: gcl.info, Node: ->UNSPECIFIC as a Component Value, Next: Relation between component values NIL and ->UNSPECIFIC, Prev: ->WILD as a Component Value, Up: Interpreting Pathname Component Values 19.2.2.9 :UNSPECIFIC as a Component Value ......................................... If :unspecific is the value of a pathname component, the component is considered to be "absent" or to "have no meaning" in the filename being represented by the pathname. Whether a value of :unspecific is permitted for any component on any given file system accessible to the implementation is implementation-defined. A conforming program must never unconditionally use a :unspecific as the value of a pathname component because such a value is not guaranteed to be permissible in all implementations. However, a conforming program can, if it is careful, successfully manipulate user-supplied data which contains or refers to non-portable pathname components. And certainly a conforming program should be prepared for the possibility that any components of a pathname could be :unspecific. When reading_1 the value of any pathname component, conforming programs should be prepared for the value to be :unspecific. When writing_1 the value of any pathname component, the consequences are undefined if :unspecific is given for a pathname in a file system for which it does not make sense.  File: gcl.info, Node: Relation between component values NIL and ->UNSPECIFIC, Next: Restrictions on Wildcard Pathnames, Prev: ->UNSPECIFIC as a Component Value, Up: Interpreting Pathname Component Values 19.2.2.10 Relation between component values NIL and :UNSPECIFIC ............................................................... If a pathname is converted to a namestring, the symbols nil and :unspecific cause the field to be treated as if it were empty. That is, both nil and :unspecific cause the component not to appear in the namestring. However, when merging a pathname with a set of defaults, only a nil value for a component will be replaced with the default for that component, while a value of :unspecific will be left alone as if the field were "filled"; see the function merge-pathnames and *note Merging Pathnames::.  File: gcl.info, Node: Restrictions on Wildcard Pathnames, Next: Restrictions on Examining Pathname Components, Prev: Relation between component values NIL and ->UNSPECIFIC, Up: Interpreting Pathname Component Values 19.2.2.11 Restrictions on Wildcard Pathnames ............................................ Wildcard pathnames can be used with directory but not with open, and return true from wild-pathname-p. When examining wildcard components of a wildcard pathname, conforming programs must be prepared to encounter any of the following additional values in any component or any element of a list that is the directory component: * The symbol :wild, which matches anything. * A string containing implementation-dependent special wildcard characters. * Any object, representing an implementation-dependent wildcard pattern.  File: gcl.info, Node: Restrictions on Examining Pathname Components, Next: Restrictions on Examining a Pathname Host Component, Prev: Restrictions on Wildcard Pathnames, Up: Interpreting Pathname Component Values 19.2.2.12 Restrictions on Examining Pathname Components ....................................................... The space of possible objects that a conforming program must be prepared to read_1 as the value of a pathname component is substantially larger than the space of possible objects that a conforming program is permitted to write_1 into such a component. While the values discussed in the subsections of this section, in *note Special Pathname Component Values::, and in *note Restrictions on Wildcard Pathnames:: apply to values that might be seen when reading the component values, substantially more restrictive rules apply to constructing pathnames; see *note Restrictions on Constructing Pathnames::. When examining pathname components, conforming programs should be aware of the following restrictions.  File: gcl.info, Node: Restrictions on Examining a Pathname Host Component, Next: Restrictions on Examining a Pathname Device Component, Prev: Restrictions on Examining Pathname Components, Up: Interpreting Pathname Component Values 19.2.2.13 Restrictions on Examining a Pathname Host Component ............................................................. It is implementation-dependent what object is used to represent the host.  File: gcl.info, Node: Restrictions on Examining a Pathname Device Component, Next: Restrictions on Examining a Pathname Directory Component, Prev: Restrictions on Examining a Pathname Host Component, Up: Interpreting Pathname Component Values 19.2.2.14 Restrictions on Examining a Pathname Device Component ............................................................... The device might be a string, :wild, :unspecific, or nil. Note that :wild might result from an attempt to read_1 the pathname component, even though portable programs are restricted from writing_1 such a component value; see *note Restrictions on Wildcard Pathnames:: and *note Restrictions on Constructing Pathnames::.  File: gcl.info, Node: Restrictions on Examining a Pathname Directory Component, Next: Directory Components in Non-Hierarchical File Systems, Prev: Restrictions on Examining a Pathname Device Component, Up: Interpreting Pathname Component Values 19.2.2.15 Restrictions on Examining a Pathname Directory Component .................................................................. The directory might be a string, :wild, :unspecific, or nil. The directory can be a list of strings and symbols. The car of the list is one of the symbols :absolute or :relative , meaning: :absolute A list whose car is the symbol :absolute represents a directory path starting from the root directory. The list (:absolute) represents the root directory. The list (:absolute "foo" "bar" "baz") represents the directory called "/foo/bar/baz" in Unix (except possibly for case). :relative A list whose car is the symbol :relative represents a directory path starting from a default directory. The list (:relative) has the same meaning as nil and hence is not used. The list (:relative "foo" "bar") represents the directory named "bar" in the directory named "foo" in the default directory. Each remaining element of the list is a string or a symbol. Each string names a single level of directory structure. The strings should contain only the directory names themselves--no punctuation characters. In place of a string, at any point in the list, symbols can occur to indicate special file notations. Figure 19-3 lists the symbols that have standard meanings. Implementations are permitted to add additional objects of any type that is disjoint from string if necessary to represent features of their file systems that cannot be represented with the standard strings and symbols. Supplying any non-string, including any of the symbols listed below, to a file system for which it does not make sense signals an error of type file-error. For example, Unix does not support :wild-inferiors in most implementations. Symbol Meaning :wild Wildcard match of one level of directory structure :wild-inferiors Wildcard match of any number of directory levels :up Go upward in directory structure (semantic) :back Go upward in directory structure (syntactic) Figure 19-3: Special Markers In Directory Component The following notes apply to the previous figure: Invalid Combinations Using :absolute or :wild-inferiors immediately followed by :up or :back signals an error of type file-error. Syntactic vs Semantic "Syntactic" means that the action of :back depends only on the pathname and not on the contents of the file system. "Semantic" means that the action of :up depends on the contents of the file system; to resolve a pathname containing :up to a pathname whose directory component contains only :absolute and strings requires probing the file system. :up differs from :back only in file systems that support multiple names for directories, perhaps via symbolic links. For example, suppose that there is a directory (:absolute "X" "Y" "Z") linked to (:absolute "A" "B" "C") and there also exist directories (:absolute "A" "B" "Q") and (:absolute "X" "Y" "Q"). Then (:absolute "X" "Y" "Z" :up "Q") designates (:absolute "A" "B" "Q") while (:absolute "X" "Y" "Z" :back "Q") designates (:absolute "X" "Y" "Q")  File: gcl.info, Node: Directory Components in Non-Hierarchical File Systems, Next: Restrictions on Examining a Pathname Name Component, Prev: Restrictions on Examining a Pathname Directory Component, Up: Interpreting Pathname Component Values 19.2.2.16 Directory Components in Non-Hierarchical File Systems ............................................................... In non-hierarchical file systems, the only valid list values for the directory component of a pathname are (:absolute string) and (:absolute :wild). :relative directories and the keywords :wild-inferiors, :up, and :back are not used in non-hierarchical file systems.  File: gcl.info, Node: Restrictions on Examining a Pathname Name Component, Next: Restrictions on Examining a Pathname Type Component, Prev: Directory Components in Non-Hierarchical File Systems, Up: Interpreting Pathname Component Values 19.2.2.17 Restrictions on Examining a Pathname Name Component ............................................................. The name might be a string, :wild, :unspecific, or nil.  File: gcl.info, Node: Restrictions on Examining a Pathname Type Component, Next: Restrictions on Examining a Pathname Version Component, Prev: Restrictions on Examining a Pathname Name Component, Up: Interpreting Pathname Component Values 19.2.2.18 Restrictions on Examining a Pathname Type Component ............................................................. The type might be a string, :wild, :unspecific, or nil.  File: gcl.info, Node: Restrictions on Examining a Pathname Version Component, Next: Notes about the Pathname Version Component, Prev: Restrictions on Examining a Pathname Type Component, Up: Interpreting Pathname Component Values 19.2.2.19 Restrictions on Examining a Pathname Version Component ................................................................ The version can be any symbol or any integer. The symbol :newest refers to the largest version number that already exists in the file system when reading, overwriting, appending, superseding, or directory listing an existing file. The symbol :newest refers to the smallest version number greater than any existing version number when creating a new file. The symbols nil, :unspecific, and :wild have special meanings and restrictions; see *note Special Pathname Component Values:: and *note Restrictions on Constructing Pathnames::. Other symbols and integers have implementation-defined meaning.  File: gcl.info, Node: Notes about the Pathname Version Component, Next: Restrictions on Constructing Pathnames, Prev: Restrictions on Examining a Pathname Version Component, Up: Interpreting Pathname Component Values 19.2.2.20 Notes about the Pathname Version Component .................................................... It is suggested, but not required, that implementations do the following: * Use positive integers starting at 1 as version numbers. * Recognize the symbol :oldest to designate the smallest existing version number. * Use keywords for other special versions.  File: gcl.info, Node: Restrictions on Constructing Pathnames, Prev: Notes about the Pathname Version Component, Up: Interpreting Pathname Component Values 19.2.2.21 Restrictions on Constructing Pathnames ................................................ When constructing a pathname from components, conforming programs must follow these rules: * Any component can be nil. nil in the host might mean a default host rather than an actual nil in some implementations. * The host, device, directory, name, and type can be strings. There are implementation-dependent limits on the number and type of characters in these strings. * The directory can be a list of strings and symbols. There are implementation-dependent limits on the list's length and contents. * The version can be :newest. * Any component can be taken from the corresponding component of another pathname. When the two pathnames are for different file systems (in implementations that support multiple file systems), an appropriate translation occurs. If no meaningful translation is possible, an error is signaled. The definitions of "appropriate" and "meaningful" are implementation-dependent. * An implementation might support other values for some components, but a portable program cannot use those values. A conforming program can use implementation-dependent values but this can make it non-portable; for example, it might work only with Unix file systems.  File: gcl.info, Node: Merging Pathnames, Prev: Interpreting Pathname Component Values, Up: Pathnames 19.2.3 Merging Pathnames ------------------------ Merging takes a pathname with unfilled components and supplies values for those components from a source of defaults. If a component's value is nil, that component is considered to be unfilled. If a component's value is any non-nil object, including :unspecific, that component is considered to be filled. Except as explicitly specified otherwise, for functions that manipulate or inquire about files in the file system, the pathname argument to such a function is merged with *default-pathname-defaults* before accessing the file system (as if by merge-pathnames). * Menu: * Examples of Merging Pathnames::  File: gcl.info, Node: Examples of Merging Pathnames, Prev: Merging Pathnames, Up: Merging Pathnames 19.2.3.1 Examples of Merging Pathnames ...................................... Although the following examples are possible to execute only in implementations which permit :unspecific in the indicated position andwhich permit four-letter type components, they serve to illustrate the basic concept of pathname merging. (pathname-type (merge-pathnames (make-pathname :type "LISP") (make-pathname :type "TEXT"))) => "LISP" (pathname-type (merge-pathnames (make-pathname :type nil) (make-pathname :type "LISP"))) => "LISP" (pathname-type (merge-pathnames (make-pathname :type :unspecific) (make-pathname :type "LISP"))) => :UNSPECIFIC  File: gcl.info, Node: Logical Pathnames, Next: Filenames Dictionary, Prev: Pathnames, Up: Filenames 19.3 Logical Pathnames ====================== * Menu: * Syntax of Logical Pathname Namestrings:: * Logical Pathname Components::  File: gcl.info, Node: Syntax of Logical Pathname Namestrings, Next: Logical Pathname Components, Prev: Logical Pathnames, Up: Logical Pathnames 19.3.1 Syntax of Logical Pathname Namestrings --------------------------------------------- The syntax of a logical pathname namestring is as follows. (Note that unlike many notational descriptions in this document, this is a syntactic description of character sequences, not a structural description of objects.) logical-pathname ::=[!host host-marker] [!relative-directory-marker] {!directory directory-marker}* [!name] [type-marker !type [version-marker !version]] host ::=!word directory ::=!word | !wildcard-word | !wild-inferiors-word name ::=!word | !wildcard-word type ::=!word | !wildcard-word version ::=!pos-int | newest-word | wildcard-version host-marker--a colon. relative-directory-marker--a semicolon. directory-marker--a semicolon. type-marker--a dot. version-marker--a dot. wild-inferiors-word--The two character sequence "**" (two asterisks). newest-word--The six character sequence "newest" or the six character sequence "NEWEST". wildcard-version--an asterisk. wildcard-word--one or more asterisks, uppercase letters, digits, and hyphens, including at least one asterisk, with no two asterisks adjacent. word--one or more uppercase letters, digits, and hyphens. pos-int--a positive integer. * Menu: * Additional Information about Parsing Logical Pathname Namestrings:: * The Host part of a Logical Pathname Namestring:: * The Device part of a Logical Pathname Namestring:: * The Directory part of a Logical Pathname Namestring:: * The Type part of a Logical Pathname Namestring:: * The Version part of a Logical Pathname Namestring:: * Wildcard Words in a Logical Pathname Namestring:: * Lowercase Letters in a Logical Pathname Namestring:: * Other Syntax in a Logical Pathname Namestring::  File: gcl.info, Node: Additional Information about Parsing Logical Pathname Namestrings, Next: The Host part of a Logical Pathname Namestring, Prev: Syntax of Logical Pathname Namestrings, Up: Syntax of Logical Pathname Namestrings 19.3.1.1 Additional Information about Parsing Logical Pathname Namestrings ..........................................................................  File: gcl.info, Node: The Host part of a Logical Pathname Namestring, Next: The Device part of a Logical Pathname Namestring, Prev: Additional Information about Parsing Logical Pathname Namestrings, Up: Syntax of Logical Pathname Namestrings 19.3.1.2 The Host part of a Logical Pathname Namestring ....................................................... The host must have been defined as a logical pathname host; this can be done by using setf of logical-pathname-translations. The logical pathname host name "SYS" is reserved for the implementation. The existence and meaning of SYS: logical pathnames is implementation-defined.  File: gcl.info, Node: The Device part of a Logical Pathname Namestring, Next: The Directory part of a Logical Pathname Namestring, Prev: The Host part of a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.3 The Device part of a Logical Pathname Namestring ......................................................... There is no syntax for a logical pathname device since the device component of a logical pathname is always :unspecific; see *note Unspecific Components of a Logical Pathname::.  File: gcl.info, Node: The Directory part of a Logical Pathname Namestring, Next: The Type part of a Logical Pathname Namestring, Prev: The Device part of a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.4 The Directory part of a Logical Pathname Namestring ............................................................ If a relative-directory-marker precedes the directories, the directory component parsed is as relative; otherwise, the directory component is parsed as absolute. If a wild-inferiors-marker is specified, it parses into :wild-inferiors.  File: gcl.info, Node: The Type part of a Logical Pathname Namestring, Next: The Version part of a Logical Pathname Namestring, Prev: The Directory part of a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.5 The Type part of a Logical Pathname Namestring ....................................................... The type of a logical pathname for a source file is "LISP". This should be translated into whatever type is appropriate in a physical pathname.  File: gcl.info, Node: The Version part of a Logical Pathname Namestring, Next: Wildcard Words in a Logical Pathname Namestring, Prev: The Type part of a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.6 The Version part of a Logical Pathname Namestring .......................................................... Some file systems do not have versions. Logical pathname translation to such a file system ignores the version. This implies that a program cannot rely on being able to store more than one version of a file named by a logical pathname. If a wildcard-version is specified, it parses into :wild.  File: gcl.info, Node: Wildcard Words in a Logical Pathname Namestring, Next: Lowercase Letters in a Logical Pathname Namestring, Prev: The Version part of a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.7 Wildcard Words in a Logical Pathname Namestring ........................................................ Each asterisk in a wildcard-word matches a sequence of zero or more characters. The wildcard-word "*" parses into :wild; other wildcard-words parse into strings.  File: gcl.info, Node: Lowercase Letters in a Logical Pathname Namestring, Next: Other Syntax in a Logical Pathname Namestring, Prev: Wildcard Words in a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.8 Lowercase Letters in a Logical Pathname Namestring ........................................................... When parsing words and wildcard-words, lowercase letters are translated to uppercase.  File: gcl.info, Node: Other Syntax in a Logical Pathname Namestring, Prev: Lowercase Letters in a Logical Pathname Namestring, Up: Syntax of Logical Pathname Namestrings 19.3.1.9 Other Syntax in a Logical Pathname Namestring ...................................................... The consequences of using characters other than those specified here in a logical pathname namestring are unspecified. The consequences of using any value not specified here as a logical pathname component are unspecified.  File: gcl.info, Node: Logical Pathname Components, Prev: Syntax of Logical Pathname Namestrings, Up: Logical Pathnames 19.3.2 Logical Pathname Components ---------------------------------- * Menu: * Unspecific Components of a Logical Pathname:: * Null Strings as Components of a Logical Pathname::  File: gcl.info, Node: Unspecific Components of a Logical Pathname, Next: Null Strings as Components of a Logical Pathname, Prev: Logical Pathname Components, Up: Logical Pathname Components 19.3.2.1 Unspecific Components of a Logical Pathname .................................................... The device component of a logical pathname is always :unspecific; no other component of a logical pathname can be :unspecific.  File: gcl.info, Node: Null Strings as Components of a Logical Pathname, Prev: Unspecific Components of a Logical Pathname, Up: Logical Pathname Components 19.3.2.2 Null Strings as Components of a Logical Pathname ......................................................... The null string, "", is not a valid value for any component of a logical pathname.  File: gcl.info, Node: Filenames Dictionary, Prev: Logical Pathnames, Up: Filenames 19.4 Filenames Dictionary ========================= * Menu: * pathname (System Class):: * logical-pathname (System Class):: * pathname:: * make-pathname:: * pathnamep:: * pathname-host:: * load-logical-pathname-translations:: * logical-pathname-translations:: * logical-pathname:: * *default-pathname-defaults*:: * namestring:: * parse-namestring:: * wild-pathname-p:: * pathname-match-p:: * translate-logical-pathname:: * translate-pathname:: * merge-pathnames::  File: gcl.info, Node: pathname (System Class), Next: logical-pathname (System Class), Prev: Filenames Dictionary, Up: Filenames Dictionary 19.4.1 pathname [System Class] ------------------------------ Class Precedence List:: ....................... pathname, t Description:: ............. A pathname is a structured object which represents a filename. There are two kinds of pathnames--physical pathnames and logical pathnames.  File: gcl.info, Node: logical-pathname (System Class), Next: pathname, Prev: pathname (System Class), Up: Filenames Dictionary 19.4.2 logical-pathname [System Class] -------------------------------------- Class Precedence List:: ....................... logical-pathname, pathname, t Description:: ............. A pathname that uses a namestring syntax that is implementation-independent, and that has component values that are implementation-independent. Logical pathnames do not refer directly to filenames See Also:: .......... *note File System Concepts::, *note Sharpsign P::, *note Printing Pathnames::  File: gcl.info, Node: pathname, Next: make-pathname, Prev: logical-pathname (System Class), Up: Filenames Dictionary 19.4.3 pathname [Function] -------------------------- 'pathname' pathspec => pathname Arguments and Values:: ...................... pathspec--a pathname designator. pathname--a pathname. Description:: ............. Returns the pathname denoted by pathspec. If the pathspec designator is a stream, the stream can be either open or closed; in both cases, the pathname returned corresponds to the filename used to open the file. pathname returns the same pathname for a file stream after it is closed as it did when it was open. If the pathspec designator is a file stream created by opening a logical pathname, a logical pathname is returned. Examples:: .......... ;; There is a great degree of variability permitted here. The next ;; several examples are intended to illustrate just a few of the many ;; possibilities. Whether the name is canonicalized to a particular ;; case (either upper or lower) depends on both the file system and the ;; implementation since two different implementations using the same ;; file system might differ on many issues. How information is stored ;; internally (and possibly presented in #S notation) might vary, ;; possibly requiring `accessors' such as PATHNAME-NAME to perform case ;; conversion upon access. The format of a namestring is dependent both ;; on the file system and the implementation since, for example, one ;; implementation might include the host name in a namestring, and ;; another might not. #S notation would generally only be used in a ;; situation where no appropriate namestring could be constructed for use ;; with #P. (setq p1 (pathname "test")) => #P"CHOCOLATE:TEST" ; with case canonicalization (e.g., VMS) OR=> #P"VANILLA:test" ; without case canonicalization (e.g., Unix) OR=> #P"test" OR=> #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST") OR=> #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test") (setq p2 (pathname "test")) => #P"CHOCOLATE:TEST" OR=> #P"VANILLA:test" OR=> #P"test" OR=> #S(PATHNAME :HOST "STRAWBERRY" :NAME "TEST") OR=> #S(PATHNAME :HOST "BELGIAN-CHOCOLATE" :NAME "test") (pathnamep p1) => true (eq p1 (pathname p1)) => true (eq p1 p2) => true OR=> false (with-open-file (stream "test" :direction :output) (pathname stream)) => #P"ORANGE-CHOCOLATE:>Gus>test.lisp.newest" See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: make-pathname, Next: pathnamep, Prev: pathname, Up: Filenames Dictionary 19.4.4 make-pathname [Function] ------------------------------- 'make-pathname' &key host device directory name type version defaults case => pathname Arguments and Values:: ...................... host--a valid physical pathname host. Complicated defaulting behavior; see below. device--a valid pathname device. Complicated defaulting behavior; see below. directory--a valid pathname directory. Complicated defaulting behavior; see below. name--a valid pathname name. Complicated defaulting behavior; see below. type--a valid pathname type. Complicated defaulting behavior; see below. version--a valid pathname version. Complicated defaulting behavior; see below. defaults--a pathname designator. The default is a pathname whose host component is the same as the host component of the value of *default-pathname-defaults*, and whose other components are all nil. case--one of :common or :local. The default is :local. pathname--a pathname. Description:: ............. Constructs and returns a pathname from the supplied keyword arguments. After the components supplied explicitly by host, device, directory, name, type, and version are filled in, the merging rules used by merge-pathnames are used to fill in any unsupplied components from the defaults supplied by defaults. Whenever a pathname is constructed the components may be canonicalized if appropriate. For the explanation of the arguments that can be supplied for each component, see *note Pathname Components::. If case is supplied, it is treated as described in *note Case in Pathname Components::. The resulting pathname is a logical pathname if and only its host component is a logical host or a string that names a defined logical host. If the directory is a string, it should be the name of a top level directory, and should not contain any punctuation characters; that is, specifying a string, str, is equivalent to specifying the list (:absolute str). Specifying the symbol :wild is equivalent to specifying the list (:absolute :wild-inferiors), or (:absolute :wild) in a file system that does not support :wild-inferiors. Examples:: .......... ;; Implementation A -- an implementation with access to a single ;; Unix file system. This implementation happens to never display ;; the `host' information in a namestring, since there is only one host. (make-pathname :directory '(:absolute "public" "games") :name "chess" :type "db") => #P"/public/games/chess.db" ;; Implementation B -- an implementation with access to one or more ;; VMS file systems. This implementation displays `host' information ;; in the namestring only when the host is not the local host. ;; It uses a double colon to separate a host name from the host's local ;; file name. (make-pathname :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB") => #P"SYS$DISK:[PUBLIC.GAMES]CHESS.DB" (make-pathname :host "BOBBY" :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB") => #P"BOBBY::SYS$DISK:[PUBLIC.GAMES]CHESS.DB" ;; Implementation C -- an implementation with simultaneous access to ;; multiple file systems from the same Lisp image. In this ;; implementation, there is a convention that any text preceding the ;; first colon in a pathname namestring is a host name. (dolist (case '(:common :local)) (dolist (host '("MY-LISPM" "MY-VAX" "MY-UNIX")) (print (make-pathname :host host :case case :directory '(:absolute "PUBLIC" "GAMES") :name "CHESS" :type "DB")))) |> #P"MY-LISPM:>public>games>chess.db" |> #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB" |> #P"MY-UNIX:/public/games/chess.db" |> #P"MY-LISPM:>public>games>chess.db" |> #P"MY-VAX:SYS$DISK:[PUBLIC.GAMES]CHESS.DB" |> #P"MY-UNIX:/PUBLIC/GAMES/CHESS.DB" => NIL Affected By:: ............. The file system. See Also:: .......... *note merge-pathnames:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames:: Notes:: ....... Portable programs should not supply :unspecific for any component. See *note ->UNSPECIFIC as a Component Value::.  File: gcl.info, Node: pathnamep, Next: pathname-host, Prev: make-pathname, Up: Filenames Dictionary 19.4.5 pathnamep [Function] --------------------------- 'pathnamep' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type pathname; otherwise, returns false. Examples:: .......... (setq q "test") => "test" (pathnamep q) => false (setq q (pathname "test")) => #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL) (pathnamep q) => true (setq q (logical-pathname "SYS:SITE;FOO.SYSTEM")) => #P"SYS:SITE;FOO.SYSTEM" (pathnamep q) => true Notes:: ....... (pathnamep object) == (typep object 'pathname)  File: gcl.info, Node: pathname-host, Next: load-logical-pathname-translations, Prev: pathnamep, Up: Filenames Dictionary 19.4.6 pathname-host, pathname-device, pathname-directory, ---------------------------------------------------------- pathname-name, pathname-type, pathname-version ---------------------------------------------- [Function] 'pathname-host' pathname &key case => host 'pathname-device' pathname &key case => device 'pathname-directory' pathname &key case => directory 'pathname-name' pathname &key case => name 'pathname-type' pathname &key case => type 'pathname-version' pathname => version Arguments and Values:: ...................... pathname--a pathname designator. case--one of :local or :common. The default is :local. host--a valid pathname host. device--a valid pathname device. directory--a valid pathname directory. name--a valid pathname name. type--a valid pathname type. version--a valid pathname version. Description:: ............. These functions return the components of pathname. If the pathname designator is a pathname, it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. If case is supplied, it is treated as described in *note Case in Pathname Components::. Examples:: .......... (setq q (make-pathname :host "KATHY" :directory "CHAPMAN" :name "LOGIN" :type "COM")) => #P"KATHY::[CHAPMAN]LOGIN.COM" (pathname-host q) => "KATHY" (pathname-name q) => "LOGIN" (pathname-type q) => "COM" ;; Because namestrings are used, the results shown in the remaining ;; examples are not necessarily the only possible results. Mappings ;; from namestring representation to pathname representation are ;; dependent both on the file system involved and on the implementation ;; (since there may be several implementations which can manipulate the ;; the same file system, and those implementations are not constrained ;; to agree on all details). Consult the documentation for each ;; implementation for specific information on how namestrings are treated ;; that implementation. ;; VMS (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP")) => (:ABSOLUTE "FOO" "BAR") (pathname-directory (parse-namestring "[FOO.*.BAR]BAZ.LSP") :case :common) => (:ABSOLUTE "FOO" "BAR") ;; Unix (pathname-directory "foo.l") => NIL (pathname-device "foo.l") => :UNSPECIFIC (pathname-name "foo.l") => "foo" (pathname-name "foo.l" :case :local) => "foo" (pathname-name "foo.l" :case :common) => "FOO" (pathname-type "foo.l") => "l" (pathname-type "foo.l" :case :local) => "l" (pathname-type "foo.l" :case :common) => "L" (pathname-type "foo") => :UNSPECIFIC (pathname-type "foo" :case :common) => :UNSPECIFIC (pathname-type "foo.") => "" (pathname-type "foo." :case :common) => "" (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local) => (:ABSOLUTE "foo" "bar") (pathname-directory (parse-namestring "/foo/bar/baz.lisp") :case :local) => (:ABSOLUTE "FOO" "BAR") (pathname-directory (parse-namestring "../baz.lisp")) => (:RELATIVE :UP) (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz")) => (:ABSOLUTE "foo" "BAR" :UP "Mum") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/BAR/../Mum/baz") :case :common) => (:ABSOLUTE "FOO" "bar" :UP "Mum") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l")) => (:ABSOLUTE "foo" :WILD "bar") (PATHNAME-DIRECTORY (PARSE-NAMESTRING "/foo/*/bar/baz.l") :case :common) => (:ABSOLUTE "FOO" :WILD "BAR") ;; Symbolics LMFS (pathname-directory (parse-namestring ">foo>**>bar>baz.lisp")) => (:ABSOLUTE "foo" :WILD-INFERIORS "bar") (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp")) => (:ABSOLUTE "foo" :WILD "bar") (pathname-directory (parse-namestring ">foo>*>bar>baz.lisp") :case :common) => (:ABSOLUTE "FOO" :WILD "BAR") (pathname-device (parse-namestring ">foo>baz.lisp")) => :UNSPECIFIC Affected By:: ............. The implementation and the host file system. Exceptional Situations:: ........................ Should signal an error of type type-error if its first argument is not a pathname. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: load-logical-pathname-translations, Next: logical-pathname-translations, Prev: pathname-host, Up: Filenames Dictionary 19.4.7 load-logical-pathname-translations [Function] ---------------------------------------------------- 'load-logical-pathname-translations' host => just-loaded Arguments and Values:: ...................... host--a string. just-loaded--a generalized boolean. Description:: ............. Searches for and loads the definition of a logical host named host, if it is not already defined. The specific nature of the search is implementation-defined. If the host is already defined, no attempt to find or load a definition is attempted, and false is returned. If the host is not already defined, but a definition is successfully found and loaded, true is returned. Otherwise, an error is signaled. Examples:: .......... (translate-logical-pathname "hacks:weather;barometer.lisp.newest") |> Error: The logical host HACKS is not defined. (load-logical-pathname-translations "HACKS") |> ;; Loading SYS:SITE;HACKS.TRANSLATIONS |> ;; Loading done. => true (translate-logical-pathname "hacks:weather;barometer.lisp.newest") => #P"HELIUM:[SHARED.HACKS.WEATHER]BAROMETER.LSP;0" (load-logical-pathname-translations "HACKS") => false Exceptional Situations:: ........................ If no definition is found, an error of type error is signaled. See Also:: .......... logical-pathname Notes:: ....... Logical pathname definitions will be created not just by implementors but also by programmers. As such, it is important that the search strategy be documented. For example, an implementation might define that the definition of a host is to be found in a file called "host.translations" in some specifically named directory.  File: gcl.info, Node: logical-pathname-translations, Next: logical-pathname, Prev: load-logical-pathname-translations, Up: Filenames Dictionary 19.4.8 logical-pathname-translations [Accessor] ----------------------------------------------- 'logical-pathname-translations' host => translations (setf (' logical-pathname-translations' host) new-translations) Arguments and Values:: ...................... host-a logical host designator. translations, new-translations--a list. Description:: ............. Returns the host's list of translations. Each translation is a list of at least two elements: from-wildcard and to-wildcard. Any additional elements are implementation-defined. From-wildcard is a logical pathname whose host is host. To-wildcard is a pathname. [Reviewer Note by Laddaga: Can this be a logical pathname?] (setf (logical-pathname-translations host) translations) sets a logical pathname host's list of translations. If host is a string that has not been previously used as a logical pathname host, a new logical pathname host is defined; otherwise an existing host's translations are replaced. logical pathname host names are compared with string-equal. When setting the translations list, each from-wildcard can be a logical pathname whose host is host or a logical pathname namestring parseable by (parse-namestring string host), where host represents the appropriate object as defined by parse-namestring. Each to-wildcard can be anything coercible to a pathname by (pathname to-wildcard). If to-wildcard coerces to a logical pathname, translate-logical-pathname will perform repeated translation steps when it uses it. host is either the host component of a logical pathname or a string that has been defined as a logical pathname host name by setf of logical-pathname-translations. Examples:: .......... [Reviewer Note by Laddaga: Shouldn't there be some *.*'s in the list of translations for PROG below?] ;;;A very simple example of setting up a logical pathname host. No ;;;translations are necessary to get around file system restrictions, so ;;;all that is necessary is to specify the root of the physical directory ;;;tree that contains the logical file system. ;;;The namestring syntax on the right-hand side is implementation-dependent. (setf (logical-pathname-translations "foo") '(("**;*.*.*" "MY-LISPM:>library>foo>**>"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "foo:bar;baz;mum.quux.3") => #P"MY-LISPM:>library>foo>bar>baz>mum.quux.3" ;;;A more complex example, dividing the files among two file servers ;;;and several different directories. This Unix doesn't support ;;;:WILD-INFERIORS in the directory, so each directory level must ;;;be translated individually. No file name or type translations ;;;are required except for .MAIL to .MBX. ;;;The namestring syntax on the right-hand side is implementation-dependent. (setf (logical-pathname-translations "prog") '(("RELEASED;*.*.*" "MY-UNIX:/sys/bin/my-prog/") ("RELEASED;*;*.*.*" "MY-UNIX:/sys/bin/my-prog/*/") ("EXPERIMENTAL;*.*.*" "MY-UNIX:/usr/Joe/development/prog/") ("EXPERIMENTAL;DOCUMENTATION;*.*.*" "MY-VAX:SYS$DISK:[JOE.DOC]") ("EXPERIMENTAL;*;*.*.*" "MY-UNIX:/usr/Joe/development/prog/*/") ("MAIL;**;*.MAIL" "MY-VAX:SYS$DISK:[JOE.MAIL.PROG...]*.MBX"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:mail;save;ideas.mail.3") => #P"MY-VAX:SYS$DISK:[JOE.MAIL.PROG.SAVE]IDEAS.MBX.3" ;;;Example translations for a program that uses three files main.lisp, ;;;auxiliary.lisp, and documentation.lisp. These translations might be ;;;supplied by a software supplier as examples. ;;;For Unix with long file names (setf (logical-pathname-translations "prog") '(("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") => #P"/lib/prog/documentation.lisp" ;;;For Unix with 14-character file names, using .lisp as the type (setf (logical-pathname-translations "prog") '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") ("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") => #P"/lib/prog/docum.lisp" ;;;For Unix with 14-character file names, using .l as the type ;;;The second translation shortens the compiled file type to .b (setf (logical-pathname-translations "prog") `(("**;*.LISP.*" ,(logical-pathname "PROG:**;*.L.*")) (,(compile-file-pathname (logical-pathname "PROG:**;*.LISP.*")) ,(logical-pathname "PROG:**;*.B.*")) ("CODE;DOCUMENTATION.*.*" "/lib/prog/documentatio.*") ("CODE;*.*.*" "/lib/prog/"))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") => #P"/lib/prog/documentatio.l" ;;;For a Cray with 6 character names and no directories, types, or versions. (setf (logical-pathname-translations "prog") (let ((l '(("MAIN" "PGMN") ("AUXILIARY" "PGAUX") ("DOCUMENTATION" "PGDOC"))) (logpath (logical-pathname "prog:code;")) (phypath (pathname "XXX"))) (append ;; Translations for source files (mapcar #'(lambda (x) (let ((log (first x)) (phy (second x))) (list (make-pathname :name log :type "LISP" :version :wild :defaults logpath) (make-pathname :name phy :defaults phypath)))) l) ;; Translations for compiled files (mapcar #'(lambda (x) (let* ((log (first x)) (phy (second x)) (com (compile-file-pathname (make-pathname :name log :type "LISP" :version :wild :defaults logpath)))) (setq phy (concatenate 'string phy "B")) (list com (make-pathname :name phy :defaults phypath)))) l)))) ;;;Sample use of that logical pathname. The return value ;;;is implementation-dependent. (translate-logical-pathname "prog:code;documentation.lisp") => #P"PGDOC" Exceptional Situations:: ........................ If host is incorrectly supplied, an error of type type-error is signaled. See Also:: .......... logical-pathname, *note Pathnames as Filenames:: Notes:: ....... Implementations can define additional functions that operate on logical pathname hosts, for example to specify additional translation rules or options.  File: gcl.info, Node: logical-pathname, Next: *default-pathname-defaults*, Prev: logical-pathname-translations, Up: Filenames Dictionary 19.4.9 logical-pathname [Function] ---------------------------------- 'logical-pathname' pathspec => logical-pathname Arguments and Values:: ...................... pathspec--a logical pathname, a logical pathname namestring, or a stream. logical-pathname--a logical pathname. Description:: ............. logical-pathname converts pathspec to a logical pathname and returns the new logical pathname. If pathspec is a logical pathname namestring, it should contain a host component and its following colon. If pathspec is a stream, it should be one for which pathname returns a logical pathname. If pathspec is a stream, the stream can be either open or closed. logical-pathname returns the same logical pathname after a file is closed as it did when the file was open. It is an error if pathspec is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, or make-string-output-stream. Exceptional Situations:: ........................ Signals an error of type type-error if pathspec isn't supplied correctly. See Also:: .......... logical-pathname, *note translate-logical-pathname:: , *note Logical Pathnames::  File: gcl.info, Node: *default-pathname-defaults*, Next: namestring, Prev: logical-pathname, Up: Filenames Dictionary 19.4.10 *default-pathname-defaults* [Variable] ---------------------------------------------- Value Type:: ............ a pathname object. Initial Value:: ............... An implementation-dependent pathname, typically in the working directory that was current when Common Lisp was started up. Description:: ............. a pathname, used as the default whenever a function needs a default pathname and one is not supplied. Examples:: .......... ;; This example illustrates a possible usage for a hypothetical Lisp running on a ;; DEC TOPS-20 file system. Since pathname conventions vary between Lisp ;; implementations and host file system types, it is not possible to provide a ;; general-purpose, conforming example. *default-pathname-defaults* => #P"PS:" (merge-pathnames (make-pathname :name "CALENDAR")) => #P"PS:CALENDAR" (let ((*default-pathname-defaults* (pathname ""))) (merge-pathnames (make-pathname :name "CALENDAR"))) => #P"CALENDAR" Affected By:: ............. The implementation.  File: gcl.info, Node: namestring, Next: parse-namestring, Prev: *default-pathname-defaults*, Up: Filenames Dictionary 19.4.11 namestring, file-namestring, directory-namestring, ---------------------------------------------------------- host-namestring, enough-namestring ---------------------------------- [Function] 'namestring' pathname => namestring 'file-namestring' pathname => namestring 'directory-namestring' pathname => namestring 'host-namestring' pathname => namestring 'enough-namestring' pathname &optional defaults => namestring Arguments and Values:: ...................... pathname--a pathname designator. defaults--a pathname designator. The default is the value of *default-pathname-defaults*. namestring--a string or nil. [Editorial Note by KMP: Under what circumstances can NIL be returned??] Description:: ............. These functions convert pathname into a namestring. The name represented by pathname is returned as a namestring in an implementation-dependent canonical form. namestring returns the full form of pathname. file-namestring returns just the name, type, and version components of pathname. directory-namestring returns the directory name portion. host-namestring returns the host name. enough-namestring returns an abbreviated namestring that is just sufficient to identify the file named by pathname when considered relative to the defaults. It is required that (merge-pathnames (enough-namestring pathname defaults) defaults) == (merge-pathnames (parse-namestring pathname nil defaults) defaults) in all cases, and the result of enough-namestring is the shortest reasonable string that will satisfy this criterion. It is not necessarily possible to construct a valid namestring by concatenating some of the three shorter namestrings in some order. Examples:: .......... (namestring "getty") => "getty" (setq q (make-pathname :host "kathy" :directory (pathname-directory *default-pathname-defaults*) :name "getty")) => #S(PATHNAME :HOST "kathy" :DEVICE NIL :DIRECTORY directory-name :NAME "getty" :TYPE NIL :VERSION NIL) (file-namestring q) => "getty" (directory-namestring q) => directory-name (host-namestring q) => "kathy" ;;;Using Unix syntax and the wildcard conventions used by the ;;;particular version of Unix on which this example was created: (namestring (translate-pathname "/usr/dmr/hacks/frob.l" "/usr/d*/hacks/*.l" "/usr/d*/backup/hacks/backup-*.*")) => "/usr/dmr/backup/hacks/backup-frob.l" (namestring (translate-pathname "/usr/dmr/hacks/frob.l" "/usr/d*/hacks/fr*.l" "/usr/d*/backup/hacks/backup-*.*")) => "/usr/dmr/backup/hacks/backup-ob.l" ;;;This is similar to the above example but uses two different hosts, ;;;U: which is a Unix and V: which is a VMS. Note the translation ;;;of file type and alphabetic case conventions. (namestring (translate-pathname "U:/usr/dmr/hacks/frob.l" "U:/usr/d*/hacks/*.l" "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*")) => "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-FROB.LSP" (namestring (translate-pathname "U:/usr/dmr/hacks/frob.l" "U:/usr/d*/hacks/fr*.l" "V:SYS$DISK:[D*.BACKUP.HACKS]BACKUP-*.*")) => "V:SYS$DISK:[DMR.BACKUP.HACKS]BACKUP-OB.LSP" See Also:: .......... *note truename:: , *note merge-pathnames:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: parse-namestring, Next: wild-pathname-p, Prev: namestring, Up: Filenames Dictionary 19.4.12 parse-namestring [Function] ----------------------------------- 'parse-namestring' thing &optional host default-pathname &key start end junk-allowed => pathname, position Arguments and Values:: ...................... thing--a string, a pathname, or a stream associated with a file. host--a valid pathname host, a logical host, or nil. default-pathname--a pathname designator. The default is the value of *default-pathname-defaults*. start, end--bounding index designators of thing. The defaults for start and end are 0 and nil, respectively. junk-allowed--a generalized boolean. The default is false. pathname--a pathname, or nil. position--a bounding index designator for thing. Description:: ............. Converts thing into a pathname. The host supplies a host name with respect to which the parsing occurs. If thing is a stream associated with a file, processing proceeds as if the pathname used to open that file had been supplied instead. If thing is a pathname, the host and the host component of thing are compared. If they match, two values are immediately returned: thing and start; otherwise (if they do not match), an error is signaled. Otherwise (if thing is a string), parse-namestring parses the name of a file within the substring of thing bounded by start and end. If thing is a string then the substring of thing bounded by start and end is parsed into a pathname as follows: * If host is a logical host then thing is parsed as a logical pathname namestring on the host. * If host is nil and thing is a syntactically valid logical pathname namestring containing an explicit host, then it is parsed as a logical pathname namestring. * If host is nil, default-pathname is a logical pathname, and thing is a syntactically valid logical pathname namestring without an explicit host, then it is parsed as a logical pathname namestring on the host that is the host component of default-pathname. * Otherwise, the parsing of thing is implementation-defined. In the first of these cases, the host portion of the logical pathname namestring and its following colon are optional. If the host portion of the namestring and host are both present and do not match, an error is signaled. If junk-allowed is true, then the primary value is the pathname parsed or, if no syntactically correct pathname was seen, nil. If junk-allowed is false, then the entire substring is scanned, and the primary value is the pathname parsed. In either case, the secondary value is the index into thing of the delimiter that terminated the parse, or the index beyond the substring if the parse terminated at the end of the substring (as will always be the case if junk-allowed is false). Parsing a null string always succeeds, producing a pathname with all components (except the host) equal to nil. If thing contains an explicit host name and no explicit device name, then it is implementation-defined whether parse-namestring will supply the standard default device for that host as the device component of the resulting pathname. Examples:: .......... (setq q (parse-namestring "test")) => #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL) (pathnamep q) => true (parse-namestring "test") => #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test" :TYPE NIL :VERSION NIL), 4 (setq s (open xxx)) => # (parse-namestring s) => #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME xxx :TYPE NIL :VERSION NIL), 0 (parse-namestring "test" nil nil :start 2 :end 4 ) => #S(PATHNAME ...), 15 (parse-namestring "foo.lisp") => #P"foo.lisp" Exceptional Situations:: ........................ If junk-allowed is false, an error of type parse-error is signaled if thing does not consist entirely of the representation of a pathname, possibly surrounded on either side by whitespace_1 characters if that is appropriate to the cultural conventions of the implementation. If host is supplied and not nil, and thing contains a manifest host name, an error of type error is signaled if the hosts do not match. If thing is a logical pathname namestring and if the host portion of the namestring and host are both present and do not match, an error of type error is signaled. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note ->UNSPECIFIC as a Component Value::, *note Pathnames as Filenames::  File: gcl.info, Node: wild-pathname-p, Next: pathname-match-p, Prev: parse-namestring, Up: Filenames Dictionary 19.4.13 wild-pathname-p [Function] ---------------------------------- 'wild-pathname-p' pathname &optional field-key => generalized-boolean Arguments and Values:: ...................... pathname--a pathname designator. Field-key--one of :host, :device :directory, :name, :type, :version, or nil. generalized-boolean--a generalized boolean. Description:: ............. wild-pathname-p tests pathname for the presence of wildcard components. If pathname is a pathname (as returned by pathname) it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. If field-key is not supplied or nil, wild-pathname-p returns true if pathname has any wildcard components, nil if pathname has none. If field-key is non-nil, wild-pathname-p returns true if the indicated component of pathname is a wildcard, nil if the component is not a wildcard. Examples:: .......... ;;;The following examples are not portable. They are written to run ;;;with particular file systems and particular wildcard conventions. ;;;Other implementations will behave differently. These examples are ;;;intended to be illustrative, not to be prescriptive. (wild-pathname-p (make-pathname :name :wild)) => true (wild-pathname-p (make-pathname :name :wild) :name) => true (wild-pathname-p (make-pathname :name :wild) :type) => false (wild-pathname-p (pathname "s:>foo>**>")) => true ;Lispm (wild-pathname-p (pathname :name "F*O")) => true ;Most places Exceptional Situations:: ........................ If pathname is not a pathname, a string, or a stream associated with a file an error of type type-error is signaled. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames:: Notes:: ....... Not all implementations support wildcards in all fields. See *note ->WILD as a Component Value:: and *note Restrictions on Wildcard Pathnames::.  File: gcl.info, Node: pathname-match-p, Next: translate-logical-pathname, Prev: wild-pathname-p, Up: Filenames Dictionary 19.4.14 pathname-match-p [Function] ----------------------------------- 'pathname-match-p' pathname wildcard => generalized-boolean Arguments and Values:: ...................... pathname--a pathname designator. wildcard--a designator for a wild pathname. generalized-boolean--a generalized boolean. Description:: ............. pathname-match-p returns true if pathname matches wildcard, otherwise nil. The matching rules are implementation-defined but should be consistent with directory. Missing components of wildcard default to :wild. It is valid for pathname to be a wild pathname; a wildcard field in pathname only matches a wildcard field in wildcard (i.e., pathname-match-p is not commutative). It is valid for wildcard to be a non-wild pathname. Exceptional Situations:: ........................ If pathname or wildcard is not a pathname, string, or stream associated with a file an error of type type-error is signaled. See Also:: .......... *note directory:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: translate-logical-pathname, Next: translate-pathname, Prev: pathname-match-p, Up: Filenames Dictionary 19.4.15 translate-logical-pathname [Function] --------------------------------------------- 'translate-logical-pathname' pathname &key => physical-pathname Arguments and Values:: ...................... pathname--a pathname designator, or a logical pathname namestring. physical-pathname--a physical pathname. Description:: ............. Translates pathname to a physical pathname, which it returns. If pathname is a stream, the stream can be either open or closed. translate-logical-pathname returns the same physical pathname after a file is closed as it did when the file was open. It is an error if pathname is a stream that is created with make-two-way-stream, make-echo-stream, make-broadcast-stream, make-concatenated-stream, make-string-input-stream, make-string-output-stream. If pathname is a logical pathname namestring, the host portion of the logical pathname namestring and its following colon are required. Pathname is first coerced to a pathname. If the coerced pathname is a physical pathname, it is returned. If the coerced pathname is a logical pathname, the first matching translation (according to pathname-match-p) of the logical pathname host is applied, as if by calling translate-pathname. If the result is a logical pathname, this process is repeated. When the result is finally a physical pathname, it is returned. If no translation matches, an error is signaled. translate-logical-pathname might perform additional translations, typically to provide translation of file types to local naming conventions, to accomodate physical file systems with limited length names, or to deal with special character requirements such as translating hyphens to underscores or uppercase letters to lowercase. Any such additional translations are implementation-defined. Some implementations do no additional translations. There are no specified keyword arguments for translate-logical-pathname, but implementations are permitted to extend it by adding keyword arguments. Examples:: .......... See logical-pathname-translations. Exceptional Situations:: ........................ If pathname is incorrectly supplied, an error of type type-error is signaled. If no translation matches, an error of type file-error is signaled. [Editorial Note by KMP: Is file-error really right, or should it be pathname-error?] See Also:: .......... *note logical-pathname:: , *note logical-pathname-translations:: , logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: translate-pathname, Next: merge-pathnames, Prev: translate-logical-pathname, Up: Filenames Dictionary 19.4.16 translate-pathname [Function] ------------------------------------- 'translate-pathname' source from-wildcard to-wildcard &key => translated-pathname Arguments and Values:: ...................... source--a pathname designator. from-wildcard--a pathname designator. to-wildcard--a pathname designator. translated-pathname--a pathname. Description:: ............. translate-pathname translates source (that matches from-wildcard) into a corresponding pathname that matches to-wildcard, and returns the corresponding pathname. The resulting pathname is to-wildcard with each wildcard or missing field replaced by a portion of source. A "wildcard field" is a pathname component with a value of :wild, a :wild element of a list-valued directory component, or an implementation-defined portion of a component, such as the "*" in the complex wildcard string "foo*bar" that some implementations support. An implementation that adds other wildcard features, such as regular expressions, must define how translate-pathname extends to those features. A "missing field" is a pathname component with a value of nil. The portion of source that is copied into the resulting pathname is implementation-defined. Typically it is determined by the user interface conventions of the file systems involved. Usually it is the portion of source that matches a wildcard field of from-wildcard that is in the same position as the wildcard or missing field of to-wildcard. If there is no wildcard field in from-wildcard at that position, then usually it is the entire corresponding pathname component of source, or in the case of a list-valued directory component, the entire corresponding list element. During the copying of a portion of source into the resulting pathname, additional implementation-defined translations of case or file naming conventions might occur, especially when from-wildcard and to-wildcard are for different hosts. It is valid for source to be a wild pathname; in general this will produce a wild result. It is valid for from-wildcard and/or to-wildcard to be non-wild pathnames. There are no specified keyword arguments for translate-pathname, but implementations are permitted to extend it by adding keyword arguments. translate-pathname maps customary case in source into customary case in the output pathname. Examples:: .......... ;; The results of the following five forms are all implementation-dependent. ;; The second item in particular is shown with multiple results just to ;; emphasize one of many particular variations which commonly occurs. (pathname-name (translate-pathname "foobar" "foo*" "*baz")) => "barbaz" (pathname-name (translate-pathname "foobar" "foo*" "*")) => "foobar" OR=> "bar" (pathname-name (translate-pathname "foobar" "*" "foo*")) => "foofoobar" (pathname-name (translate-pathname "bar" "*" "foo*")) => "foobar" (pathname-name (translate-pathname "foobar" "foo*" "baz*")) => "bazbar" (defun translate-logical-pathname-1 (pathname rules) (let ((rule (assoc pathname rules :test #'pathname-match-p))) (unless rule (error "No translation rule for ~A" pathname)) (translate-pathname pathname (first rule) (second rule)))) (translate-logical-pathname-1 "FOO:CODE;BASIC.LISP" '(("FOO:DOCUMENTATION;" "MY-UNIX:/doc/foo/") ("FOO:CODE;" "MY-UNIX:/lib/foo/") ("FOO:PATCHES;*;" "MY-UNIX:/lib/foo/patch/*/"))) => #P"MY-UNIX:/lib/foo/basic.l" ;;;This example assumes one particular set of wildcard conventions ;;;Not all file systems will run this example exactly as written (defun rename-files (from to) (dolist (file (directory from)) (rename-file file (translate-pathname file from to)))) (rename-files "/usr/me/*.lisp" "/dev/her/*.l") ;Renames /usr/me/init.lisp to /dev/her/init.l (rename-files "/usr/me/pcl*/*" "/sys/pcl/*/") ;Renames /usr/me/pcl-5-may/low.lisp to /sys/pcl/pcl-5-may/low.lisp ;In some file systems the result might be /sys/pcl/5-may/low.lisp (rename-files "/usr/me/pcl*/*" "/sys/library/*/") ;Renames /usr/me/pcl-5-may/low.lisp to /sys/library/pcl-5-may/low.lisp ;In some file systems the result might be /sys/library/5-may/low.lisp (rename-files "/usr/me/foo.bar" "/usr/me2/") ;Renames /usr/me/foo.bar to /usr/me2/foo.bar (rename-files "/usr/joe/*-recipes.text" "/usr/jim/cookbook/joe's-*-rec.text") ;Renames /usr/joe/lamb-recipes.text to /usr/jim/cookbook/joe's-lamb-rec.text ;Renames /usr/joe/pork-recipes.text to /usr/jim/cookbook/joe's-pork-rec.text ;Renames /usr/joe/veg-recipes.text to /usr/jim/cookbook/joe's-veg-rec.text Exceptional Situations:: ........................ If any of source, from-wildcard, or to-wildcard is not a pathname, a string, or a stream associated with a file an error of type type-error is signaled. (pathname-match-p source from-wildcard) must be true or an error of type error is signaled. See Also:: .......... *note namestring:: , *note pathname-host:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames:: Notes:: ....... The exact behavior of translate-pathname cannot be dictated by the Common Lisp language and must be allowed to vary, depending on the user interface conventions of the file systems involved. The following is an implementation guideline. One file system performs this operation by examining each piece of the three pathnames in turn, where a piece is a pathname component or a list element of a structured component such as a hierarchical directory. Hierarchical directory elements in from-wildcard and to-wildcard are matched by whether they are wildcards, not by depth in the directory hierarchy. If the piece in to-wildcard is present and not wild, it is copied into the result. If the piece in to-wildcard is :wild or nil, the piece in source is copied into the result. Otherwise, the piece in to-wildcard might be a complex wildcard such as "foo*bar" and the piece in from-wildcard should be wild; the portion of the piece in source that matches the wildcard portion of the piece in from-wildcard replaces the wildcard portion of the piece in to-wildcard and the value produced is used in the result.  File: gcl.info, Node: merge-pathnames, Prev: translate-pathname, Up: Filenames Dictionary 19.4.17 merge-pathnames [Function] ---------------------------------- 'merge-pathnames' pathname &optional default-pathname default-version => merged-pathname Arguments and Values:: ...................... pathname--a pathname designator. default-pathname--a pathname designator. The default is the value of *default-pathname-defaults*. default-version--a valid pathname version. The default is :newest. merged-pathname--a pathname. Description:: ............. Constructs a pathname from pathname by filling in any unsupplied components with the corresponding values from default-pathname and default-version. Defaulting of pathname components is done by filling in components taken from another pathname. This is especially useful for cases such as a program that has an input file and an output file. Unspecified components of the output pathname will come from the input pathname, except that the type should not default to the type of the input pathname but rather to the appropriate default type for output from the program; for example, see the function compile-file-pathname. If no version is supplied, default-version is used. If default-version is nil, the version component will remain unchanged. If pathname explicitly specifies a host and not a device, and if the host component of default-pathname matches the host component of pathname, then the device is taken from the default-pathname; otherwise the device will be the default file device for that host. If pathname does not specify a host, device, directory, name, or type, each such component is copied from default-pathname. If pathname does not specify a name, then the version, if not provided, will come from default-pathname, just like the other components. If pathname does specify a name, then the version is not affected by default-pathname. If this process leaves the version missing, the default-version is used. If the host's file name syntax provides a way to input a version without a name or type, the user can let the name and type default but supply a version different from the one in default-pathname. If pathname is a stream, pathname effectively becomes (pathname pathname). merge-pathnames can be used on either an open or a closed stream. If pathname is a pathname it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. merge-pathnames recognizes a logical pathname namestring when default-pathname is a logical pathname, or when the namestring begins with the name of a defined logical host followed by a colon. In the first of these two cases, the host portion of the logical pathname namestring and its following colon are optional. merge-pathnames returns a logical pathname if and only if its first argument is a logical pathname, or its first argument is a logical pathname namestring with an explicit host, or its first argument does not specify a host and the default-pathname is a logical pathname. Pathname merging treats a relative directory specially. If (pathname-directory pathname) is a list whose car is :relative, and (pathname-directory default-pathname) is a list, then the merged directory is the value of (append (pathname-directory default-pathname) (cdr ;remove :relative from the front (pathname-directory pathname))) except that if the resulting list contains a string or :wild immediately followed by :back, both of them are removed. This removal of redundant :back keywords is repeated as many times as possible. If (pathname-directory default-pathname) is not a list or (pathname-directory pathname) is not a list whose car is :relative, the merged directory is (or (pathname-directory pathname) (pathname-directory default-pathname)) merge-pathnames maps customary case in pathname into customary case in the output pathname. Examples:: .......... (merge-pathnames "CMUC::FORMAT" "CMUC::PS:.FASL") => #P"CMUC::PS:FORMAT.FASL.0" See Also:: .......... *default-pathname-defaults*, pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames:: Notes:: ....... The net effect is that if just a name is supplied, the host, device, directory, and type will come from default-pathname, but the version will come from default-version. If nothing or just a directory is supplied, the name, type, and version will come from default-pathname together.  File: gcl.info, Node: Files, Next: Streams, Prev: Filenames, Up: Top 20 Files ******** * Menu: * File System Concepts:: * Files Dictionary::  File: gcl.info, Node: File System Concepts, Next: Files Dictionary, Prev: Files, Up: Files 20.1 File System Concepts ========================= This section describes the Common Lisp interface to file systems. The model used by this interface assumes that files are named by filenames , that a filename can be represented by a pathname object, and that given a pathname a stream can be constructed that connects to a file whose filename it represents. For information about opening and closing files, and manipulating their contents, see *note Streams::. Figure 20-1 lists some operators that are applicable to files and directories. compile-file file-length open delete-file file-position probe-file directory file-write-date rename-file file-author load with-open-file Figure 20-1: File and Directory Operations * Menu: * Coercion of Streams to Pathnames:: * File Operations on Open and Closed Streams:: * Truenames::  File: gcl.info, Node: Coercion of Streams to Pathnames, Next: File Operations on Open and Closed Streams, Prev: File System Concepts, Up: File System Concepts 20.1.1 Coercion of Streams to Pathnames --------------------------------------- A stream associated with a file is either a file stream or a synonym stream whose target is a stream associated with a file . Such streams can be used as pathname designators. Normally, when a stream associated with a file is used as a pathname designator, it denotes the pathname used to open the file; this may be, but is not required to be, the actual name of the file. Some functions, such as truename and delete-file, coerce streams to pathnames in a different way that involves referring to the actual file that is open, which might or might not be the file whose name was opened originally. Such special situations are always notated specifically and are not the default.  File: gcl.info, Node: File Operations on Open and Closed Streams, Next: Truenames, Prev: Coercion of Streams to Pathnames, Up: File System Concepts 20.1.2 File Operations on Open and Closed Streams ------------------------------------------------- Many functions that perform file operations accept either open or closed streams as arguments; see *note Stream Arguments to Standardized Functions::. Of these, the functions in Figure 20-2 treat open and closed streams differently. delete-file file-author probe-file directory file-write-date truename Figure 20-2: File Functions that Treat Open and Closed Streams Differently Since treatment of open streams by the file system may vary considerably between implementations, however, a closed stream might be the most reliable kind of argument for some of these functions--in particular, those in Figure 20-3. For example, in some file systems, open files are written under temporary names and not renamed until closed and/or are held invisible until closed. In general, any code that is intended to be portable should use such functions carefully. directory probe-file truename Figure 20-3: File Functions where Closed Streams Might Work Best  File: gcl.info, Node: Truenames, Prev: File Operations on Open and Closed Streams, Up: File System Concepts 20.1.3 Truenames ---------------- Many file systems permit more than one filename to designate a particular file. Even where multiple names are possible, most file systems have a convention for generating a canonical filename in such situations. Such a canonical filename (or the pathname representing such a filename) is called a truename . The truename of a file may differ from other filenames for the file because of symbolic links, version numbers, logical device translations in the file system, logical pathname translations within Common Lisp, or other artifacts of the file system. The truename for a file is often, but not necessarily, unique for each file. For instance, a Unix file with multiple hard links could have several truenames. * Menu: * Examples of Truenames::  File: gcl.info, Node: Examples of Truenames, Prev: Truenames, Up: Truenames 20.1.3.1 Examples of Truenames .............................. For example, a DEC TOPS-20 system with files PS:FOO.TXT.1 and PS:FOO.TXT.2 might permit the second file to be referred to as PS:FOO.TXT.0, since the ".0" notation denotes "newest" version of several files. In the same file system, a "logical device" "JOE:" might be taken to refer to PS:" and so the names JOE:FOO.TXT.2 or JOE:FOO.TXT.0 might refer to PS:FOO.TXT.2. In all of these cases, the truename of the file would probably be PS:FOO.TXT.2. If a file is a symbolic link to another file (in a file system permitting such a thing), it is conventional for the truename to be the canonical name of the file after any symbolic links have been followed; that is, it is the canonical name of the file whose contents would become available if an input stream to that file were opened. In the case of a file still being created (that is, of an output stream open to such a file), the exact truename of the file might not be known until the stream is closed. In this case, the function truename might return different values for such a stream before and after it was closed. In fact, before it is closed, the name returned might not even be a valid name in the file system--for example, while a file is being written, it might have version :newest and might only take on a specific numeric value later when the file is closed even in a file system where all files have numeric versions.  File: gcl.info, Node: Files Dictionary, Prev: File System Concepts, Up: Files 20.2 Files Dictionary ===================== * Menu: * directory:: * probe-file:: * ensure-directories-exist:: * truename:: * file-author:: * file-write-date:: * rename-file:: * delete-file:: * file-error:: * file-error-pathname::  File: gcl.info, Node: directory, Next: probe-file, Prev: Files Dictionary, Up: Files Dictionary 20.2.1 directory [Function] --------------------------- 'directory' pathspec &key => pathnames Arguments and Values:: ...................... pathspec--a pathname designator, which may contain wild components. pathnames--a list of physical pathnames. Description:: ............. Determines which, if any, files that are present in the file system have names matching pathspec, and returns a fresh list of pathnames corresponding to the truenames of those files. An implementation may be extended to accept implementation-defined keyword arguments to directory. Affected By:: ............. The host computer's file system. Exceptional Situations:: ........................ If the attempt to obtain a directory listing is not successful, an error of type file-error is signaled. See Also:: .......... pathname, logical-pathname, *note ensure-directories-exist:: , *note File System Concepts::, *note File Operations on Open and Closed Streams::, *note Pathnames as Filenames:: Notes:: ....... If the pathspec is not wild, the resulting list will contain either zero or one elements. Common Lisp specifies "&key" in the argument list to directory even though no standardized keyword arguments to directory are defined. ":allow-other-keys t" may be used in conforming programs in order to quietly ignore any additional keywords which are passed by the program but not supported by the implementation.  File: gcl.info, Node: probe-file, Next: ensure-directories-exist, Prev: directory, Up: Files Dictionary 20.2.2 probe-file [Function] ---------------------------- 'probe-file' pathspec => truename Arguments and Values:: ...................... pathspec--a pathname designator. truename--a physical pathname or nil. Description:: ............. probe-file tests whether a file exists. probe-file returns false if there is no file named pathspec, and otherwise returns the truename of pathspec. If the pathspec designator is an open stream, then probe-file produces the truename of its associated file. If pathspec is a stream, whether open or closed, it is coerced to a pathname as if by the function pathname. Affected By:: ............. The host computer's file system. Exceptional Situations:: ........................ An error of type file-error is signaled if pathspec is wild. An error of type file-error is signaled if the file system cannot perform the requested operation. See Also:: .......... *note truename:: , *note open:: , *note ensure-directories-exist:: , pathname, logical-pathname, *note File System Concepts::, *note File Operations on Open and Closed Streams::, *note Pathnames as Filenames::  File: gcl.info, Node: ensure-directories-exist, Next: truename, Prev: probe-file, Up: Files Dictionary 20.2.3 ensure-directories-exist [Function] ------------------------------------------ 'ensure-directories-exist' pathspec &key verbose => pathspec, created Arguments and Values:: ...................... pathspec--a pathname designator. verbose--a generalized boolean. created--a generalized boolean. Description:: ............. Tests whether the directories containing the specified file actually exist, and attempts to create them if they do not. If the containing directories do not exist and if verbose is true, then the implementation is permitted (but not required) to perform output to standard output saying what directories were created. If the containing directories exist, or if verbose is false, this function performs no output. The primary value is the given pathspec so that this operation can be straightforwardly composed with other file manipulation expressions. The secondary value, created, is true if any directories were created. Affected By:: ............. The host computer's file system. Exceptional Situations:: ........................ An error of type file-error is signaled if the host, device, or directory part of pathspec is wild. If the directory creation attempt is not successful, an error of type file-error is signaled; if this occurs, it might be the case that none, some, or all of the requested creations have actually occurred within the file system. See Also:: .......... *note probe-file:: , *note open:: , *note Pathnames as Filenames::  File: gcl.info, Node: truename, Next: file-author, Prev: ensure-directories-exist, Up: Files Dictionary 20.2.4 truename [Function] -------------------------- 'truename' filespec => truename Arguments and Values:: ...................... filespec--a pathname designator. truename--a physical pathname. Description:: ............. truename tries to find the file indicated by filespec and returns its truename. If the filespec designator is an open stream, its associated file is used. If filespec is a stream, truename can be used whether the stream is open or closed. It is permissible for truename to return more specific information after the stream is closed than when the stream was open. If filespec is a pathname it represents the name used to open the file. This may be, but is not required to be, the actual name of the file. Examples:: .......... ;; An example involving version numbers. Note that the precise nature of ;; the truename is implementation-dependent while the file is still open. (with-open-file (stream ">vistor>test.text.newest") (values (pathname stream) (truename stream))) => #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1" OR=> #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.newest" OR=> #P"S:>vistor>test.text.newest", #P"S:>vistor>_temp_._temp_.1" ;; In this case, the file is closed when the truename is tried, so the ;; truename information is reliable. (with-open-file (stream ">vistor>test.text.newest") (close stream) (values (pathname stream) (truename stream))) => #P"S:>vistor>test.text.newest", #P"S:>vistor>test.text.1" ;; An example involving TOP-20's implementation-dependent concept ;; of logical devices -- in this case, "DOC:" is shorthand for ;; "PS:" ... (with-open-file (stream "CMUC::DOC:DUMPER.HLP") (values (pathname stream) (truename stream))) => #P"CMUC::DOC:DUMPER.HLP", #P"CMUC::PS:DUMPER.HLP.13" Exceptional Situations:: ........................ An error of type file-error is signaled if an appropriate file cannot be located within the file system for the given filespec, or if the file system cannot perform the requested operation. An error of type file-error is signaled if pathname is wild. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames:: Notes:: ....... truename may be used to account for any filename translations performed by the file system.  File: gcl.info, Node: file-author, Next: file-write-date, Prev: truename, Up: Files Dictionary 20.2.5 file-author [Function] ----------------------------- 'file-author' pathspec => author Arguments and Values:: ...................... pathspec--a pathname designator. author--a string or nil. Description:: ............. Returns a string naming the author of the file specified by pathspec, or nil if the author's name cannot be determined. Examples:: .......... (with-open-file (stream ">relativity>general.text") (file-author s)) => "albert" Affected By:: ............. The host computer's file system. Other users of the file named by pathspec. Exceptional Situations:: ........................ An error of type file-error is signaled if pathspec is wild. An error of type file-error is signaled if the file system cannot perform the requested operation. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: file-write-date, Next: rename-file, Prev: file-author, Up: Files Dictionary 20.2.6 file-write-date [Function] --------------------------------- 'file-write-date' pathspec => date Arguments and Values:: ...................... pathspec--a pathname designator. date--a universal time or nil. Description:: ............. Returns a universal time representing the time at which the file specified by pathspec was last written (or created), or returns nil if such a time cannot be determined. Examples:: .......... (with-open-file (s "noel.text" :direction :output :if-exists :error) (format s "~&Dear Santa,~2 Please leave lots of toys.~2 ~2 (truename s)) => #P"CUPID:/susan/noel.text" (with-open-file (s "noel.text") (file-write-date s)) => 2902600800 Affected By:: ............. The host computer's file system. Exceptional Situations:: ........................ An error of type file-error is signaled if pathspec is wild. An error of type file-error is signaled if the file system cannot perform the requested operation. See Also:: .......... *note Universal Time::, *note Pathnames as Filenames::  File: gcl.info, Node: rename-file, Next: delete-file, Prev: file-write-date, Up: Files Dictionary 20.2.7 rename-file [Function] ----------------------------- 'rename-file' filespec new-name => defaulted-new-name, old-truename, new-truename Arguments and Values:: ...................... filespec--a pathname designator. new-name--a pathname designator other than a stream. defaulted-new-name--a pathname old-truename--a physical pathname. new-truename--a physical pathname. Description:: ............. rename-file modifies the file system in such a way that the file indicated by filespec is renamed to defaulted-new-name. It is an error to specify a filename containing a wild component, for filespec to contain a nil component where the file system does not permit a nil component, or for the result of defaulting missing components of new-name from filespec to contain a nil component where the file system does not permit a nil component. If new-name is a logical pathname, rename-file returns a logical pathname as its primary value. rename-file returns three values if successful. The primary value, defaulted-new-name, is the resulting name which is composed of new-name with any missing components filled in by performing a merge-pathnames operation using filespec as the defaults. The secondary value, old-truename, is the truename of the file before it was renamed. The tertiary value, new-truename, is the truename of the file after it was renamed. If the filespec designator is an open stream, then the stream itself and the file associated with it are affected (if the file system permits). Examples:: .......... ;; An example involving logical pathnames. (with-open-file (stream "sys:chemistry;lead.text" :direction :output :if-exists :error) (princ "eureka" stream) (values (pathname stream) (truename stream))) => #P"SYS:CHEMISTRY;LEAD.TEXT.NEWEST", #P"Q:>sys>chem>lead.text.1" (rename-file "sys:chemistry;lead.text" "gold.text") => #P"SYS:CHEMISTRY;GOLD.TEXT.NEWEST", #P"Q:>sys>chem>lead.text.1", #P"Q:>sys>chem>gold.text.1" Exceptional Situations:: ........................ If the renaming operation is not successful, an error of type file-error is signaled. An error of type file-error might be signaled if filespec is wild. See Also:: .......... *note truename:: , pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: delete-file, Next: file-error, Prev: rename-file, Up: Files Dictionary 20.2.8 delete-file [Function] ----------------------------- 'delete-file' filespec => t Arguments and Values:: ...................... filespec--a pathname designator. Description:: ............. Deletes the file specified by filespec. If the filespec designator is an open stream, then filespec and the file associated with it are affected (if the file system permits), in which case filespec might be closed immediately, and the deletion might be immediate or delayed until filespec is explicitly closed, depending on the requirements of the file system. It is implementation-dependent whether an attempt to delete a nonexistent file is considered to be successful. delete-file returns true if it succeeds, or signals an error of type file-error if it does not. The consequences are undefined if filespec has a wild component, or if filespec has a nil component and the file system does not permit a nil component. Examples:: .......... (with-open-file (s "delete-me.text" :direction :output :if-exists :error)) => NIL (setq p (probe-file "delete-me.text")) => #P"R:>fred>delete-me.text.1" (delete-file p) => T (probe-file "delete-me.text") => false (with-open-file (s "delete-me.text" :direction :output :if-exists :error) (delete-file s)) => T (probe-file "delete-me.text") => false Exceptional Situations:: ........................ If the deletion operation is not successful, an error of type file-error is signaled. An error of type file-error might be signaled if filespec is wild. See Also:: .......... pathname, logical-pathname, *note File System Concepts::, *note Pathnames as Filenames::  File: gcl.info, Node: file-error, Next: file-error-pathname, Prev: delete-file, Up: Files Dictionary 20.2.9 file-error [Condition Type] ---------------------------------- Class Precedence List:: ....................... file-error, error, serious-condition, condition, t Description:: ............. The type file-error consists of error conditions that occur during an attempt to open or close a file, or during some low-level transactions with a file system. The "offending pathname" is initialized by the :pathname initialization argument to make-condition, and is accessed by the function file-error-pathname. See Also:: .......... file-error-pathname, *note open:: , *note probe-file:: , *note directory:: , *note ensure-directories-exist::  File: gcl.info, Node: file-error-pathname, Prev: file-error, Up: Files Dictionary 20.2.10 file-error-pathname [Function] -------------------------------------- 'file-error-pathname' condition => pathspec Arguments and Values:: ...................... condition--a condition of type file-error. pathspec--a pathname designator. Description:: ............. Returns the "offending pathname" of a condition of type file-error. Exceptional Situations:: ........................ See Also:: .......... file-error, *note Conditions::  File: gcl.info, Node: Streams, Next: Printer, Prev: Files, Up: Top 21 Streams ********** * Menu: * Stream Concepts:: * Streams Dictionary::  File: gcl.info, Node: Stream Concepts, Next: Streams Dictionary, Prev: Streams, Up: Streams 21.1 Stream Concepts ==================== * Menu: * Introduction to Streams:: * Stream Variables:: * Stream Arguments to Standardized Functions:: * Restrictions on Composite Streams::  File: gcl.info, Node: Introduction to Streams, Next: Stream Variables, Prev: Stream Concepts, Up: Stream Concepts 21.1.1 Introduction to Streams ------------------------------ A stream is an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation. A character stream is a source or sink of characters. A binary stream is a source or sink of bytes. Some operations may be performed on any kind of stream; Figure 21-1 provides a list of standardized operations that are potentially useful with any kind of stream. close stream-element-type input-stream-p streamp interactive-stream-p with-open-stream output-stream-p Figure 21-1: Some General-Purpose Stream Operations Other operations are only meaningful on certain stream types. For example, read-char is only defined for character streams and read-byte is only defined for binary streams. * Menu: * Abstract Classifications of Streams (Introduction to Streams):: * Input:: * Open and Closed Streams:: * Interactive Streams:: * Abstract Classifications of Streams:: * File Streams:: * Other Subclasses of Stream::  File: gcl.info, Node: Abstract Classifications of Streams (Introduction to Streams), Next: Input, Prev: Introduction to Streams, Up: Introduction to Streams 21.1.1.1 Abstract Classifications of Streams ............................................  File: gcl.info, Node: Input, Next: Open and Closed Streams, Prev: Abstract Classifications of Streams (Introduction to Streams), Up: Introduction to Streams 21.1.1.2 Input, Output, and Bidirectional Streams ................................................. A stream, whether a character stream or a binary stream, can be an input stream (source of data), an output stream (sink for data), both, or (e.g., when ":direction :probe" is given to open) neither. Figure 21-2 shows operators relating to input streams. clear-input read-byte read-from-string listen read-char read-line peek-char read-char-no-hang read-preserving-whitespace read read-delimited-list unread-char Figure 21-2: Operators relating to Input Streams. Figure 21-3 shows operators relating to output streams. clear-output prin1 write finish-output prin1-to-string write-byte force-output princ write-char format princ-to-string write-line fresh-line print write-string pprint terpri write-to-string Figure 21-3: Operators relating to Output Streams. A stream that is both an input stream and an output stream is called a bidirectional stream . See the functions input-stream-p and output-stream-p. Any of the operators listed in Figure~21-2 or Figure~21-3 can be used with bidirectional streams. In addition, Figure 21-4 shows a list of operators that relate specificaly to bidirectional streams. y-or-n-p yes-or-no-p Figure 21-4: Operators relating to Bidirectional Streams.  File: gcl.info, Node: Open and Closed Streams, Next: Interactive Streams, Prev: Input, Up: Introduction to Streams 21.1.1.3 Open and Closed Streams ................................ Streams are either open or closed . Except as explicitly specified otherwise, operations that create and return streams return open streams. The action of closing a stream marks the end of its use as a source or sink of data, permitting the implementation to reclaim its internal data structures, and to free any external resources which might have been locked by the stream when it was opened. Except as explicitly specified otherwise, the consequences are undefined when a closed stream is used where a stream is called for. Coercion of streams to pathnames is permissible for closed streams; in some situations, such as for a truename computation, the result might be different for an open stream and for that same stream once it has been closed.  File: gcl.info, Node: Interactive Streams, Next: Abstract Classifications of Streams, Prev: Open and Closed Streams, Up: Introduction to Streams 21.1.1.4 Interactive Streams ............................ An interactive stream is one on which it makes sense to perform interactive querying. The precise meaning of an interactive stream is implementation-defined, and may depend on the underlying operating system. Some examples of the things that an implementation might choose to use as identifying characteristics of an interactive stream include: * The stream is connected to a person (or equivalent) in such a way that the program can prompt for information and expect to receive different input depending on the prompt. * The program is expected to prompt for input and support "normal input editing". * read-char might wait for the user to type something before returning instead of immediately returning a character or end-of-file. The general intent of having some streams be classified as interactive streams is to allow them to be distinguished from streams containing batch (or background or command-file) input. Output to batch streams is typically discarded or saved for later viewing, so interactive queries to such streams might not have the expected effect. Terminal I/O might or might not be an interactive stream.  File: gcl.info, Node: Abstract Classifications of Streams, Next: File Streams, Prev: Interactive Streams, Up: Introduction to Streams 21.1.1.5 Abstract Classifications of Streams ............................................  File: gcl.info, Node: File Streams, Next: Other Subclasses of Stream, Prev: Abstract Classifications of Streams, Up: Introduction to Streams 21.1.1.6 File Streams ..................... Some streams, called file streams , provide access to files. An object of class file-stream is used to represent a file stream. The basic operation for opening a file is open, which typically returns a file stream (see its dictionary entry for details). The basic operation for closing a stream is close. The macro with-open-file is useful to express the common idiom of opening a file for the duration of a given body of code, and assuring that the resulting stream is closed upon exit from that body.  File: gcl.info, Node: Other Subclasses of Stream, Prev: File Streams, Up: Introduction to Streams 21.1.1.7 Other Subclasses of Stream ................................... The class stream has a number of subclasses defined by this specification. Figure 21-5 shows some information about these subclasses. Class Related Operators broadcast-stream make-broadcast-stream broadcast-stream-streams concatenated-stream make-concatenated-stream concatenated-stream-streams echo-stream make-echo-stream echo-stream-input-stream echo-stream-output-stream string-stream make-string-input-stream with-input-from-string make-string-output-stream with-output-to-string get-output-stream-string synonym-stream make-synonym-stream synonym-stream-symbol two-way-stream make-two-way-stream two-way-stream-input-stream two-way-stream-output-stream Figure 21-5: Defined Names related to Specialized Streams  File: gcl.info, Node: Stream Variables, Next: Stream Arguments to Standardized Functions, Prev: Introduction to Streams, Up: Stream Concepts 21.1.2 Stream Variables ----------------------- Variables whose values must be streams are sometimes called stream variables . Certain stream variables are defined by this specification to be the proper source of input or output in various situations where no specific stream has been specified instead. A complete list of such standardized stream variables appears in Figure 21-6. The consequences are undefined if at any time the value of any of these variables is not an open stream. Glossary Term Variable Name debug I/O *debug-io* error output *error-output* query I/O *query-io* standard input *standard-input* standard output *standard-output* terminal I/O *terminal-io* trace output *trace-output* Figure 21-6: Standardized Stream Variables Note that, by convention, standardized stream variables have names ending in "-input*" if they must be input streams, ending in "-output*" if they must be output streams, or ending in "-io*" if they must be bidirectional streams. User programs may assign or bind any standardized stream variable except *terminal-io*.  File: gcl.info, Node: Stream Arguments to Standardized Functions, Next: Restrictions on Composite Streams, Prev: Stream Variables, Up: Stream Concepts 21.1.3 Stream Arguments to Standardized Functions ------------------------------------------------- The operators in Figure 21-7 accept stream arguments that might be either open or closed streams. broadcast-stream-streams file-author pathnamep close file-namestring probe-file compile-file file-write-date rename-file compile-file-pathname host-namestring streamp concatenated-stream-streams load synonym-stream-symbol delete-file logical-pathname translate-logical-pathname directory merge-pathnames translate-pathname directory-namestring namestring truename dribble open two-way-stream-input-stream echo-stream-input-stream open-stream-p two-way-stream-output-stream echo-stream-ouput-stream parse-namestring wild-pathname-p ed pathname with-open-file enough-namestring pathname-match-p Figure 21-7: Operators that accept either Open or Closed Streams The operators in Figure 21-8 accept stream arguments that must be open streams. clear-input output-stream-p read-char-no-hang clear-output peek-char read-delimited-list file-length pprint read-line file-position pprint-fill read-preserving-whitespace file-string-length pprint-indent stream-element-type finish-output pprint-linear stream-external-format force-output pprint-logical-block terpri format pprint-newline unread-char fresh-line pprint-tab with-open-stream get-output-stream-string pprint-tabular write input-stream-p prin1 write-byte interactive-stream-p princ write-char listen print write-line make-broadcast-stream print-object write-string make-concatenated-stream print-unreadable-object y-or-n-p make-echo-stream read yes-or-no-p make-synonym-stream read-byte make-two-way-stream read-char Figure 21-8: Operators that accept Open Streams only  File: gcl.info, Node: Restrictions on Composite Streams, Prev: Stream Arguments to Standardized Functions, Up: Stream Concepts 21.1.4 Restrictions on Composite Streams ---------------------------------------- The consequences are undefined if any component of a composite stream is closed before the composite stream is closed. The consequences are undefined if the synonym stream symbol is not bound to an open stream from the time of the synonym stream's creation until the time it is closed.  File: gcl.info, Node: Streams Dictionary, Prev: Stream Concepts, Up: Streams 21.2 Streams Dictionary ======================= * Menu: * stream:: * broadcast-stream:: * concatenated-stream:: * echo-stream:: * file-stream:: * string-stream:: * synonym-stream:: * two-way-stream:: * input-stream-p:: * interactive-stream-p:: * open-stream-p:: * stream-element-type:: * streamp:: * read-byte:: * write-byte:: * peek-char:: * read-char:: * read-char-no-hang:: * terpri:: * unread-char:: * write-char:: * read-line:: * write-string:: * read-sequence:: * write-sequence:: * file-length:: * file-position:: * file-string-length:: * open:: * stream-external-format:: * with-open-file:: * close:: * with-open-stream:: * listen:: * clear-input:: * finish-output:: * y-or-n-p:: * make-synonym-stream:: * synonym-stream-symbol:: * broadcast-stream-streams:: * make-broadcast-stream:: * make-two-way-stream:: * two-way-stream-input-stream:: * echo-stream-input-stream:: * make-echo-stream:: * concatenated-stream-streams:: * make-concatenated-stream:: * get-output-stream-string:: * make-string-input-stream:: * make-string-output-stream:: * with-input-from-string:: * with-output-to-string:: * *debug-io*:: * *terminal-io*:: * stream-error:: * stream-error-stream:: * end-of-file::  File: gcl.info, Node: stream, Next: broadcast-stream, Prev: Streams Dictionary, Up: Streams Dictionary 21.2.1 stream [System Class] ---------------------------- Class Precedence List:: ....................... stream, t Description:: ............. A stream is an object that can be used with an input or output function to identify an appropriate source or sink of characters or bytes for that operation. For more complete information, see *note Stream Concepts::. See Also:: .......... *note Stream Concepts::, *note Printing Other Objects::, *note Printer::, *note Reader::  File: gcl.info, Node: broadcast-stream, Next: concatenated-stream, Prev: stream, Up: Streams Dictionary 21.2.2 broadcast-stream [System Class] -------------------------------------- Class Precedence List:: ....................... broadcast-stream, stream, t Description:: ............. A broadcast stream is an output stream which has associated with it a set of zero or more output streams such that any output sent to the broadcast stream gets passed on as output to each of the associated output streams. (If a broadcast stream has no component streams, then all output to the broadcast stream is discarded.) The set of operations that may be performed on a broadcast stream is the intersection of those for its associated output streams. Some output operations (e.g., fresh-line) return values based on the state of the stream at the time of the operation. Since these values might differ for each of the component streams, it is necessary to describe their return value specifically: * stream-element-type returns the value from the last component stream, or t if there are no component streams. * fresh-line returns the value from the last component stream, or nil if there are no component streams. * The functions file-length, file-position, file-string-length, and stream-external-format return the value from the last component stream; if there are no component streams, file-length and file-position return 0, file-string-length returns 1, and stream-external-format returns :default. * The functions streamp and output-stream-p always return true for broadcast streams. * The functions open-stream-p tests whether the broadcast stream is open_2, not whether its component streams are open. * The functions input-stream-p and interactive-stream-p return an implementation-defined, generalized boolean value. * For the input operations clear-input listen, peek-char, read-byte, read-char-no-hang, read-char, read-line, and unread-char, the consequences are undefined if the indicated operation is performed. However, an implementation is permitted to define such a behavior as an implementation-dependent extension. For any output operations not having their return values explicitly specified above or elsewhere in this document, it is defined that the values returned by such an operation are the values resulting from performing the operation on the last of its component streams; the values resulting from performing the operation on all preceding streams are discarded. If there are no component streams, the value is implementation-dependent. See Also:: .......... *note broadcast-stream-streams:: , *note make-broadcast-stream::  File: gcl.info, Node: concatenated-stream, Next: echo-stream, Prev: broadcast-stream, Up: Streams Dictionary 21.2.3 concatenated-stream [System Class] ----------------------------------------- Class Precedence List:: ....................... concatenated-stream, stream, t Description:: ............. A concatenated stream is an input stream which is a composite stream of zero or more other input streams, such that the sequence of data which can be read from the concatenated stream is the same as the concatenation of the sequences of data which could be read from each of the constituent streams. Input from a concatenated stream is taken from the first of the associated input streams until it reaches end of file_1; then that stream is discarded, and subsequent input is taken from the next input stream, and so on. An end of file on the associated input streams is always managed invisibly by the concatenated stream--the only time a client of a concatenated stream sees an end of file is when an attempt is made to obtain data from the concatenated stream but it has no remaining input streams from which to obtain such data. See Also:: .......... *note concatenated-stream-streams:: , *note make-concatenated-stream::  File: gcl.info, Node: echo-stream, Next: file-stream, Prev: concatenated-stream, Up: Streams Dictionary 21.2.4 echo-stream [System Class] --------------------------------- Class Precedence List:: ....................... echo-stream, stream, t Description:: ............. An echo stream is a bidirectional stream that gets its input from an associated input stream and sends its output to an associated output stream. All input taken from the input stream is echoed to the output stream. Whether the input is echoed immediately after it is encountered, or after it has been read from the input stream is implementation-dependent. See Also:: .......... *note echo-stream-input-stream:: , echo-stream-output-stream, *note make-echo-stream::  File: gcl.info, Node: file-stream, Next: string-stream, Prev: echo-stream, Up: Streams Dictionary 21.2.5 file-stream [System Class] --------------------------------- Class Precedence List:: ....................... file-stream, stream, t Description:: ............. An object of type file-stream is a stream the direct source or sink of which is a file. Such a stream is created explicitly by open and with-open-file, and implicitly by functions such as load that process files. See Also:: .......... *note load:: , *note open:: , *note with-open-file::  File: gcl.info, Node: string-stream, Next: synonym-stream, Prev: file-stream, Up: Streams Dictionary 21.2.6 string-stream [System Class] ----------------------------------- Class Precedence List:: ....................... string-stream, stream, t Description:: ............. A string stream is a stream which reads input from or writes output to an associated string. The stream element type of a string stream is always a subtype of type character. See Also:: .......... *note make-string-input-stream:: , *note make-string-output-stream:: , *note with-input-from-string:: , *note with-output-to-string::  File: gcl.info, Node: synonym-stream, Next: two-way-stream, Prev: string-stream, Up: Streams Dictionary 21.2.7 synonym-stream [System Class] ------------------------------------ Class Precedence List:: ....................... synonym-stream, stream, t Description:: ............. A stream that is an alias for another stream, which is the value of a dynamic variable whose name is the synonym stream symbol of the synonym stream. Any operations on a synonym stream will be performed on the stream that is then the value of the dynamic variable named by the synonym stream symbol. If the value of the variable should change, or if the variable should be bound, then the stream will operate on the new value of the variable. See Also:: .......... *note make-synonym-stream:: , *note synonym-stream-symbol::  File: gcl.info, Node: two-way-stream, Next: input-stream-p, Prev: synonym-stream, Up: Streams Dictionary 21.2.8 two-way-stream [System Class] ------------------------------------ Class Precedence List:: ....................... two-way-stream, stream, t Description:: ............. A bidirectional composite stream that receives its input from an associated input stream and sends its output to an associated output stream. See Also:: .......... *note make-two-way-stream:: , *note two-way-stream-input-stream:: , two-way-stream-output-stream  File: gcl.info, Node: input-stream-p, Next: interactive-stream-p, Prev: two-way-stream, Up: Streams Dictionary 21.2.9 input-stream-p, output-stream-p [Function] ------------------------------------------------- 'input-stream-p' stream => generalized-boolean 'output-stream-p' stream => generalized-boolean Arguments and Values:: ...................... stream--a stream. generalized-boolean--a generalized boolean. Description:: ............. input-stream-p returns true if stream is an input stream; otherwise, returns false. output-stream-p returns true if stream is an output stream; otherwise, returns false. Examples:: .......... (input-stream-p *standard-input*) => true (input-stream-p *terminal-io*) => true (input-stream-p (make-string-output-stream)) => false (output-stream-p *standard-output*) => true (output-stream-p *terminal-io*) => true (output-stream-p (make-string-input-stream "jr")) => false Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream.  File: gcl.info, Node: interactive-stream-p, Next: open-stream-p, Prev: input-stream-p, Up: Streams Dictionary 21.2.10 interactive-stream-p [Function] --------------------------------------- 'interactive-stream-p' stream => generalized-boolean Arguments and Values:: ...................... stream--a stream. generalized-boolean--a generalized boolean. Description:: ............. Returns true if stream is an interactive stream; otherwise, returns false. Examples:: .......... (when (> measured limit) (let ((error (round (* (- measured limit) 100) limit))) (unless (if (interactive-stream-p *query-io*) (yes-or-no-p "The frammis is out of tolerance by ~D Is it safe to proceed? " error) (< error 15)) ;15 (error "The frammis is out of tolerance by ~D Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream. See Also:: .......... *note Stream Concepts::  File: gcl.info, Node: open-stream-p, Next: stream-element-type, Prev: interactive-stream-p, Up: Streams Dictionary 21.2.11 open-stream-p [Function] -------------------------------- 'open-stream-p' stream => generalized-boolean Arguments and Values:: ...................... stream--a stream. generalized-boolean--a generalized boolean. Description:: ............. Returns true if stream is an open stream; otherwise, returns false. Streams are open until they have been explicitly closed with close, or until they are implicitly closed due to exit from a with-output-to-string, with-open-file, with-input-from-string, or with-open-stream form. Examples:: .......... (open-stream-p *standard-input*) => true Affected By:: ............. close. Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream.  File: gcl.info, Node: stream-element-type, Next: streamp, Prev: open-stream-p, Up: Streams Dictionary 21.2.12 stream-element-type [Function] -------------------------------------- 'stream-element-type' stream => typespec Arguments and Values:: ...................... stream--a stream. typespec--a type specifier. Description:: ............. stream-element-type returns a type specifier that indicates the types of objects that may be read from or written to stream. Streams created by open have an element type restricted to integer or a subtype of type character. Examples:: .......... ;; Note that the stream must accomodate at least the specified type, ;; but might accomodate other types. Further note that even if it does ;; accomodate exactly the specified type, the type might be specified in ;; any of several ways. (with-open-file (s "test" :element-type '(integer 0 1) :if-exists :error :direction :output) (stream-element-type s)) => INTEGER OR=> (UNSIGNED-BYTE 16) OR=> (UNSIGNED-BYTE 8) OR=> BIT OR=> (UNSIGNED-BYTE 1) OR=> (INTEGER 0 1) OR=> (INTEGER 0 (2)) Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream.  File: gcl.info, Node: streamp, Next: read-byte, Prev: stream-element-type, Up: Streams Dictionary 21.2.13 streamp [Function] -------------------------- 'streamp' object => generalized-boolean Arguments and Values:: ...................... object--an object. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of type stream; otherwise, returns false. streamp is unaffected by whether object, if it is a stream, is open or closed. Examples:: .......... (streamp *terminal-io*) => true (streamp 1) => false Notes:: ....... (streamp object) == (typep object 'stream)  File: gcl.info, Node: read-byte, Next: write-byte, Prev: streamp, Up: Streams Dictionary 21.2.14 read-byte [Function] ---------------------------- 'read-byte' stream &optional eof-error-p eof-value => byte Arguments and Values:: ...................... stream--a binary input stream. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. byte--an integer, or the eof-value. Description:: ............. read-byte reads and returns one byte from stream. If an end of file_2 occurs and eof-error-p is false, the eof-value is returned. Examples:: .......... (with-open-file (s "temp-bytes" :direction :output :element-type 'unsigned-byte) (write-byte 101 s)) => 101 (with-open-file (s "temp-bytes" :element-type 'unsigned-byte) (format t "~S ~S" (read-byte s) (read-byte s nil 'eof))) |> 101 EOF => NIL Side Effects:: .............. Modifies stream. Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream. Should signal an error of type error if stream is not a binary input stream. If there are no bytes remaining in the stream and eof-error-p is true, an error of type end-of-file is signaled. See Also:: .......... *note read-char:: , *note read-sequence:: , *note write-byte::  File: gcl.info, Node: write-byte, Next: peek-char, Prev: read-byte, Up: Streams Dictionary 21.2.15 write-byte [Function] ----------------------------- 'write-byte' byte stream => byte Arguments and Values:: ...................... byte--an integer of the stream element type of stream. stream--a binary output stream. Description:: ............. write-byte writes one byte, byte, to stream. Examples:: .......... (with-open-file (s "temp-bytes" :direction :output :element-type 'unsigned-byte) (write-byte 101 s)) => 101 Side Effects:: .............. stream is modified. Affected By:: ............. The element type of the stream. Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream. Should signal an error of type error if stream is not a binary output stream. Might signal an error of type type-error if byte is not an integer of the stream element type of stream. See Also:: .......... *note read-byte:: , *note write-char:: , *note write-sequence::  File: gcl.info, Node: peek-char, Next: read-char, Prev: write-byte, Up: Streams Dictionary 21.2.16 peek-char [Function] ---------------------------- 'peek-char' &optional peek-type input-stream eof-error-p eof-value recursive-p => char Arguments and Values:: ...................... peek-type--a character or t or nil. input-stream--input stream designator. The default is standard input. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. recursive-p--a generalized boolean. The default is false. char--a character or the eof-value. Description:: ............. peek-char obtains the next character in input-stream without actually reading it, thus leaving the character to be read at a later time. It can also be used to skip over and discard intervening characters in the input-stream until a particular character is found. If peek-type is not supplied or nil, peek-char returns the next character to be read from input-stream, without actually removing it from input-stream. The next time input is done from input-stream, the character will still be there. If peek-type is t, then peek-char skips over whitespace_2 characters, but not comments, and then performs the peeking operation on the next character. The last character examined, the one that starts an object, is not removed from input-stream. If peek-type is a character, then peek-char skips over input characters until a character that is char= to that character is found; that character is left in input-stream. If an end of file_2 occurs and eof-error-p is false, eof-value is returned. If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader. When input-stream is an echo stream, characters that are only peeked at are not echoed. In the case that peek-type is not nil, the characters that are passed by peek-char are treated as if by read-char, and so are echoed unless they have been marked otherwise by unread-char. Examples:: .......... (with-input-from-string (input-stream " 1 2 3 4 5") (format t "~S ~S ~S" (peek-char t input-stream) (peek-char #\4 input-stream) (peek-char nil input-stream))) |> #\1 #\4 #\4 => NIL Affected By:: ............. *readtable*, *standard-input*, *terminal-io*. Exceptional Situations:: ........................ If eof-error-p is true and an end of file_2 occurs an error of type end-of-file is signaled. If peek-type is a character, an end of file_2 occurs, and eof-error-p is true, an error of type end-of-file is signaled. If recursive-p is true and an end of file_2 occurs, an error of type end-of-file is signaled.  File: gcl.info, Node: read-char, Next: read-char-no-hang, Prev: peek-char, Up: Streams Dictionary 21.2.17 read-char [Function] ---------------------------- 'read-char' &optional input-stream eof-error-p eof-value recursive-p => char Arguments and Values:: ...................... input-stream--an input stream designator. The default is standard input. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. recursive-p--a generalized boolean. The default is false. char--a character or the eof-value. Description:: ............. read-char returns the next character from input-stream. When input-stream is an echo stream, the character is echoed on input-stream the first time the character is seen. Characters that are not echoed by read-char are those that were put there by unread-char and hence are assumed to have been echoed already by a previous call to read-char. If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader. If an end of file_2 occurs and eof-error-p is false, eof-value is returned. Examples:: .......... (with-input-from-string (is "0123") (do ((c (read-char is) (read-char is nil 'the-end))) ((not (characterp c))) (format t "~S " c))) |> #\0 #\1 #\2 #\3 => NIL Affected By:: ............. *standard-input*, *terminal-io*. Exceptional Situations:: ........................ If an end of file_2 occurs before a character can be read, and eof-error-p is true, an error of type end-of-file is signaled. See Also:: .......... *note read-byte:: , *note read-sequence:: , *note write-char:: , *note read:: Notes:: ....... The corresponding output function is write-char.  File: gcl.info, Node: read-char-no-hang, Next: terpri, Prev: read-char, Up: Streams Dictionary 21.2.18 read-char-no-hang [Function] ------------------------------------ 'read-char-no-hang' &optional input-stream eof-error-p eof-value recursive-p => char Arguments and Values:: ...................... input-stream - an input stream designator. The default is standard input. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. recursive-p--a generalized boolean. The default is false. char--a character or nil or the eof-value. Description:: ............. read-char-no-hang returns a character from input-stream if such a character is available. If no character is available, read-char-no-hang returns nil. If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader. If an end of file_2 occurs and eof-error-p is false, eof-value is returned. Examples:: .......... ;; This code assumes an implementation in which a newline is not ;; required to terminate input from the console. (defun test-it () (unread-char (read-char)) (list (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) => TEST-IT ;; Implementation A, where a Newline is not required to terminate ;; interactive input on the console. (test-it) |> |>>a<<| => (#\a NIL NIL) ;; Implementation B, where a Newline is required to terminate ;; interactive input on the console, and where that Newline remains ;; on the input stream. (test-it) |> |>>a[<-~]<<| => (#\a #\Newline NIL) Affected By:: ............. *standard-input*, *terminal-io*. Exceptional Situations:: ........................ If an end of file_2 occurs when eof-error-p is true, an error of type end-of-file is signaled . See Also:: .......... *note listen:: Notes:: ....... read-char-no-hang is exactly like read-char, except that if it would be necessary to wait in order to get a character (as from a keyboard), nil is immediately returned without waiting.  File: gcl.info, Node: terpri, Next: unread-char, Prev: read-char-no-hang, Up: Streams Dictionary 21.2.19 terpri, fresh-line [Function] ------------------------------------- 'terpri' &optional output-stream => nil 'fresh-line' &optional output-stream => generalized-boolean Arguments and Values:: ...................... output-stream - an output stream designator. The default is standard output. generalized-boolean--a generalized boolean. Description:: ............. terpri outputs a newline to output-stream. fresh-line is similar to terpri but outputs a newline only if the output-stream is not already at the start of a line. If for some reason this cannot be determined, then a newline is output anyway. fresh-line returns true if it outputs a newline; otherwise it returns false. Examples:: .......... (with-output-to-string (s) (write-string "some text" s) (terpri s) (terpri s) (write-string "more text" s)) => "some text more text" (with-output-to-string (s) (write-string "some text" s) (fresh-line s) (fresh-line s) (write-string "more text" s)) => "some text more text" Side Effects:: .............. The output-stream is modified. Affected By:: ............. *standard-output*, *terminal-io*. Exceptional Situations:: ........................ None. [Reviewer Note by Barmar: What if stream is closed?] Notes:: ....... terpri is identical in effect to (write-char #\Newline output-stream)  File: gcl.info, Node: unread-char, Next: write-char, Prev: terpri, Up: Streams Dictionary 21.2.20 unread-char [Function] ------------------------------ 'unread-char' character &optional input-stream => nil Arguments and Values:: ...................... character--a character; must be the last character that was read from input-stream. input-stream--an input stream designator. The default is standard input. Description:: ............. unread-char places character back onto the front of input-stream so that it will again be the next character in input-stream. When input-stream is an echo stream, no attempt is made to undo any echoing of the character that might already have been done on input-stream. However, characters placed on input-stream by unread-char are marked in such a way as to inhibit later re-echo by read-char. It is an error to invoke unread-char twice consecutively on the same stream without an intervening call to read-char (or some other input operation which implicitly reads characters) on that stream. Invoking peek-char or read-char commits all previous characters. The consequences of invoking unread-char on any character preceding that which is returned by peek-char (including those passed over by peek-char that has a non-nil peek-type) are unspecified. In particular, the consequences of invoking unread-char after peek-char are unspecified. Examples:: .......... (with-input-from-string (is "0123") (dotimes (i 6) (let ((c (read-char is))) (if (evenp i) (format t "~&~S ~S~ |> 0 #\0 |> 2 #\1 |> 4 #\2 => NIL Affected By:: ............. *standard-input*, *terminal-io*. See Also:: .......... *note peek-char:: , *note read-char:: , *note Stream Concepts:: Notes:: ....... unread-char is intended to be an efficient mechanism for allowing the Lisp reader and other parsers to perform one-character lookahead in input-stream.  File: gcl.info, Node: write-char, Next: read-line, Prev: unread-char, Up: Streams Dictionary 21.2.21 write-char [Function] ----------------------------- 'write-char' character &optional output-stream => character Arguments and Values:: ...................... character--a character. output-stream - an output stream designator. The default is standard output. Description:: ............. write-char outputs character to output-stream. Examples:: .......... (write-char #\a) |> a => #\a (with-output-to-string (s) (write-char #\a s) (write-char #\Space s) (write-char #\b s)) => "a b" Side Effects:: .............. The output-stream is modified. Affected By:: ............. *standard-output*, *terminal-io*. See Also:: .......... *note read-char:: , *note write-byte:: , *note write-sequence::  File: gcl.info, Node: read-line, Next: write-string, Prev: write-char, Up: Streams Dictionary 21.2.22 read-line [Function] ---------------------------- 'read-line' &optional input-stream eof-error-p eof-value recursive-p => line, missing-newline-p Arguments and Values:: ...................... input-stream--an input stream designator. The default is standard input. eof-error-p--a generalized boolean. The default is true. eof-value--an object. The default is nil. recursive-p--a generalized boolean. The default is false. line--a string or the eof-value. missing-newline-p--a generalized boolean. Description:: ............. Reads from input-stream a line of text that is terminated by a newline or end of file. If recursive-p is true, this call is expected to be embedded in a higher-level call to read or a similar function used by the Lisp reader. The primary value, line, is the line that is read, represented as a string (without the trailing newline, if any). If eof-error-p is false and the end of file for input-stream is reached before any characters are read, eof-value is returned as the line. The secondary value, missing-newline-p, is a generalized boolean that is false if the line was terminated by a newline, or true if the line was terminated by the end of file for input-stream (or if the line is the eof-value). Examples:: .......... (setq a "line 1 line2") => "line 1 line2" (read-line (setq input-stream (make-string-input-stream a))) => "line 1", false (read-line input-stream) => "line2", true (read-line input-stream nil nil) => NIL, true Affected By:: ............. *standard-input*, *terminal-io*. Exceptional Situations:: ........................ If an end of file_2 occurs before any characters are read in the line, an error is signaled if eof-error-p is true. See Also:: .......... *note read:: Notes:: ....... The corresponding output function is write-line.  File: gcl.info, Node: write-string, Next: read-sequence, Prev: read-line, Up: Streams Dictionary 21.2.23 write-string, write-line [Function] ------------------------------------------- 'write-string' string &optional output-stream &key start end => string 'write-line' string &optional output-stream &key start end => string Arguments and Values:: ...................... string--a string. output-stream - an output stream designator. The default is standard output. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. Description:: ............. write-string writes the characters of the subsequence of string bounded by start and end to output-stream. write-line does the same thing, but then outputs a newline afterwards. Examples:: .......... (prog1 (write-string "books" nil :end 4) (write-string "worms")) |> bookworms => "books" (progn (write-char #\*) (write-line "test12" *standard-output* :end 5) (write-line "*test2") (write-char #\*) nil) |> *test1 |> *test2 |> * => NIL Affected By:: ............. *standard-output*, *terminal-io*. See Also:: .......... *note read-line:: , *note write-char:: Notes:: ....... write-line and write-string return string, not the substring bounded by start and end. (write-string string) == (dotimes (i (length string) (write-char (char string i))) (write-line string) == (prog1 (write-string string) (terpri))  File: gcl.info, Node: read-sequence, Next: write-sequence, Prev: write-string, Up: Streams Dictionary 21.2.24 read-sequence [Function] -------------------------------- 'read-sequence' sequence stream &key start end => position sequence--a sequence. stream--an input stream. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. position--an integer greater than or equal to zero, and less than or equal to the length of the sequence. Description:: ............. Destructively modifies sequence by replacing the elements of sequence bounded by start and end with elements read from stream. Sequence is destructively modified by copying successive elements into it from stream. If the end of file for stream is reached before copying all elements of the subsequence, then the extra elements near the end of sequence are not updated. Position is the index of the first element of sequence that was not updated, which might be less than end because the end of file was reached. Examples:: .......... (defvar *data* (make-array 15 :initial-element nil)) (values (read-sequence *data* (make-string-input-stream "test string")) *data*) => 11, #(#\t #\e #\s #\t #\Space #\s #\t #\r #\i #\n #\g NIL NIL NIL NIL) Side Effects:: .............. Modifies stream and sequence. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil. Might signal an error of type type-error if an element read from the stream is not a member of the element type of the sequence. See Also:: .......... *note Compiler Terminology::, *note write-sequence:: , *note read-line:: Notes:: ....... read-sequence is identical in effect to iterating over the indicated subsequence and reading one element at a time from stream and storing it into sequence, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the sequence is a vector with the same element type as the stream.  File: gcl.info, Node: write-sequence, Next: file-length, Prev: read-sequence, Up: Streams Dictionary 21.2.25 write-sequence [Function] --------------------------------- 'write-sequence' sequence stream &key start end => sequence sequence--a sequence. stream--an output stream. start, end--bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively. Description:: ............. write-sequence writes the elements of the subsequence of sequence bounded by start and end to stream. Examples:: .......... (write-sequence "bookworms" *standard-output* :end 4) |> book => "bookworms" Side Effects:: .............. Modifies stream. Exceptional Situations:: ........................ Should be prepared to signal an error of type type-error if sequence is not a proper sequence. Should signal an error of type type-error if start is not a non-negative integer. Should signal an error of type type-error if end is not a non-negative integer or nil. Might signal an error of type type-error if an element of the bounded sequence is not a member of the stream element type of the stream. See Also:: .......... *note Compiler Terminology::, *note read-sequence:: , *note write-string:: , write-line Notes:: ....... write-sequence is identical in effect to iterating over the indicated subsequence and writing one element at a time to stream, but may be more efficient than the equivalent loop. An efficient implementation is more likely to exist for the case where the sequence is a vector with the same element type as the stream.  File: gcl.info, Node: file-length, Next: file-position, Prev: write-sequence, Up: Streams Dictionary 21.2.26 file-length [Function] ------------------------------ 'file-length' stream => length Arguments and Values:: ...................... stream--a stream associated with a file. length--a non-negative integer or nil. Description:: ............. file-length returns the length of stream, or nil if the length cannot be determined. For a binary file, the length is measured in units of the element type of the stream. Examples:: .......... (with-open-file (s "decimal-digits.text" :direction :output :if-exists :error) (princ "0123456789" s) (truename s)) => #P"A:>Joe>decimal-digits.text.1" (with-open-file (s "decimal-digits.text") (file-length s)) => 10 Exceptional Situations:: ........................ Should signal an error of type type-error if stream is not a stream associated with a file. See Also:: .......... *note open::  File: gcl.info, Node: file-position, Next: file-string-length, Prev: file-length, Up: Streams Dictionary 21.2.27 file-position [Function] -------------------------------- 'file-position' stream => position 'file-position' stream position-spec => success-p Arguments and Values:: ...................... stream--a stream. position-spec--a file position designator. position--a file position or nil. success-p--a generalized boolean. Description:: ............. Returns or changes the current position within a stream. When position-spec is not supplied, file-position returns the current file position in the stream, or nil if this cannot be determined. When position-spec is supplied, the file position in stream is set to that file position (if possible). file-position returns true if the repositioning is performed successfully, or false if it is not. An integer returned by file-position of one argument should be acceptable as position-spec for use with the same file. For a character file, performing a single read-char or write-char operation may cause the file position to be increased by more than 1 because of character-set translations (such as translating between the Common Lisp #\Newline character and an external ASCII carriage-return/line-feed sequence) and other aspects of the implementation. For a binary file, every read-byte or write-byte operation increases the file position by 1. Examples:: .......... (defun tester () (let ((noticed '()) file-written) (flet ((notice (x) (push x noticed) x)) (with-open-file (s "test.bin" :element-type '(unsigned-byte 8) :direction :output :if-exists :error) (notice (file-position s)) ;1 (write-byte 5 s) (write-byte 6 s) (let ((p (file-position s))) (notice p) ;2 (notice (when p (file-position s (1- p))))) ;3 (write-byte 7 s) (notice (file-position s)) ;4 (setq file-written (truename s))) (with-open-file (s file-written :element-type '(unsigned-byte 8) :direction :input) (notice (file-position s)) ;5 (let ((length (file-length s))) (notice length) ;6 (when length (dotimes (i length) (notice (read-byte s)))))) ;7,... (nreverse noticed)))) => tester (tester) => (0 2 T 2 0 2 5 7) OR=> (0 2 NIL 3 0 3 5 6 7) OR=> (NIL NIL NIL NIL NIL NIL) Side Effects:: .............. When the position-spec argument is supplied, the file position in the stream might be moved. Affected By:: ............. The value returned by file-position increases monotonically as input or output operations are performed. Exceptional Situations:: ........................ If position-spec is supplied, but is too large or otherwise inappropriate, an error is signaled. See Also:: .......... *note file-length:: , *note file-string-length:: , *note open:: Notes:: ....... Implementations that have character files represented as a sequence of records of bounded size might choose to encode the file position as, for example, <>*<>+<>. This is a valid encoding because it increases monotonically as each character is read or written, though not necessarily by 1 at each step. An integer might then be considered "inappropriate" as position-spec to file-position if, when decoded into record number and character number, it turned out that the supplied record was too short for the specified character number.  File: gcl.info, Node: file-string-length, Next: open, Prev: file-position, Up: Streams Dictionary 21.2.28 file-string-length [Function] ------------------------------------- 'file-string-length' stream object => length Arguments and Values:: ...................... stream--an output character file stream. object--a string or a character. length--a non-negative integer, or nil. Description:: ............. file-string-length returns the difference between what (file-position stream) would be after writing object and its current value, or nil if this cannot be determined. The returned value corresponds to the current state of stream at the time of the call and might not be the same if it is called again when the state of the stream has changed.  File: gcl.info, Node: open, Next: stream-external-format, Prev: file-string-length, Up: Streams Dictionary 21.2.29 open [Function] ----------------------- 'open' filespec &key direction element-type if-exists if-does-not-exist external-format => stream Arguments and Values:: ...................... filespec--a pathname designator. direction--one of :input, :output, :io, or :probe. The default is :input. element-type--a type specifier for recognizable subtype of character; or a type specifier for a finite recognizable subtype of integer; or one of the symbols signed-byte, unsigned-byte, or :default. The default is character. if-exists--one of :error, :new-version, :rename, :rename-and-delete, :overwrite, :append, :supersede, or nil. The default is :new-version if the version component of filespec is :newest, or :error otherwise. if-does-not-exist--one of :error, :create, or nil. The default is :error if direction is :input or if-exists is :overwrite or :append; :create if direction is :output or :io, and if-exists is neither :overwrite nor :append; or nil when direction is :probe. external-format--an external file format designator. The default is :default. stream--a file stream or nil. Description:: ............. open creates, opens, and returns a file stream that is connected to the file specified by filespec. Filespec is the name of the file to be opened. If the filespec designator is a stream, that stream is not closed first or otherwise affected. The keyword arguments to open specify the characteristics of the file stream that is returned, and how to handle errors. If direction is :input or :probe, or if if-exists is not :new-version and the version component of the filespec is :newest, then the file opened is that file already existing in the file system that has a version greater than that of any other file in the file system whose other pathname components are the same as those of filespec. An implementation is required to recognize all of the open keyword options and to do something reasonable in the context of the host operating system. For example, if a file system does not support distinct file versions and does not distinguish the notions of deletion and expunging, :new-version might be treated the same as :rename or :supersede, and :rename-and-delete might be treated the same as :supersede. :direction These are the possible values for direction, and how they affect the nature of the stream that is created: :input Causes the creation of an input file stream. :output Causes the creation of an output file stream. :io Causes the creation of a bidirectional file stream. :probe Causes the creation of a "no-directional" file stream; in effect, the file stream is created and then closed prior to being returned by open. :element-type The element-type specifies the unit of transaction for the file stream. If it is :default, the unit is determined by file system, possibly based on the file. :if-exists if-exists specifies the action to be taken if direction is :output or :io and a file of the name filespec already exists. If direction is :input, not supplied, or :probe, if-exists is ignored. These are the results of open as modified by if-exists: :error An error of type file-error is signaled. :new-version A new file is created with a larger version number. :rename The existing file is renamed to some other name and then a new file is created. :rename-and-delete The existing file is renamed to some other name, then it is deleted but not expunged, and then a new file is created. :overwrite Output operations on the stream destructively modify the existing file. If direction is :io the file is opened in a bidirectional mode that allows both reading and writing. The file pointer is initially positioned at the beginning of the file; however, the file is not truncated back to length zero when it is opened. :append Output operations on the stream destructively modify the existing file. The file pointer is initially positioned at the end of the file. If direction is :io, the file is opened in a bidirectional mode that allows both reading and writing. :supersede The existing file is superseded; that is, a new file with the same name as the old one is created. If possible, the implementation should not destroy the old file until the new stream is closed. nil No file or stream is created; instead, nil is returned to indicate failure. :if-does-not-exist if-does-not-exist specifies the action to be taken if a file of name filespec does not already exist. These are the results of open as modified by if-does-not-exist: :error An error of type file-error is signaled. :create An empty file is created. Processing continues as if the file had already existed but no processing as directed by if-exists is performed. nil No file or stream is created; instead, nil is returned to indicate failure. :external-format This option selects an external file format for the file: The only standardized value for this option is :default, although implementations are permitted to define additional external file formats and implementation-dependent values returned by stream-external-format can also be used by conforming programs. The external-format is meaningful for any kind of file stream whose element type is a subtype of character. This option is ignored for streams for which it is not meaningful; however, implementations may define other element types for which it is meaningful. The consequences are unspecified if a character is written that cannot be represented by the given external file format. When a file is opened, a file stream is constructed to serve as the file system's ambassador to the Lisp environment; operations on the file stream are reflected by operations on the file in the file system. A file can be deleted, renamed, or destructively modified by open. For information about opening relative pathnames, see *note Merging Pathnames::. Examples:: .......... (open filespec :direction :probe) => # (setq q (merge-pathnames (user-homedir-pathname) "test")) => # (open filespec :if-does-not-exist :create) => # (setq s (open filespec :direction :probe)) => # (truename s) => # (open s :direction :output :if-exists nil) => NIL Affected By:: ............. The nature and state of the host computer's file system. Exceptional Situations:: ........................ If if-exists is :error, (subject to the constraints on the meaning of if-exists listed above), an error of type file-error is signaled. If if-does-not-exist is :error (subject to the constraints on the meaning of if-does-not-exist listed above), an error of type file-error is signaled. If it is impossible for an implementation to handle some option in a manner close to what is specified here, an error of type error might be signaled. An error of type file-error is signaled if (wild-pathname-p filespec) returns true. An error of type error is signaled if the external-format is not understood by the implementation. The various file systems in existence today have widely differing capabilities, and some aspects of the file system are beyond the scope of this specification to define. A given implementation might not be able to support all of these options in exactly the manner stated. An implementation is required to recognize all of these option keywords and to try to do something "reasonable" in the context of the host file system. Where necessary to accomodate the file system, an implementation deviate slightly from the semantics specified here without being disqualified for consideration as a conforming implementation. If it is utterly impossible for an implementation to handle some option in a manner similar to what is specified here, it may simply signal an error. With regard to the :element-type option, if a type is requested that is not supported by the file system, a substitution of types such as that which goes on in upgrading is permissible. As a minimum requirement, it should be the case that opening an output stream to a file in a given element type and later opening an input stream to the same file in the same element type should work compatibly. See Also:: .......... *note with-open-file:: , *note close:: , pathname, logical-pathname, *note Merging Pathnames::, *note Pathnames as Filenames:: Notes:: ....... open does not automatically close the file when an abnormal exit occurs. When element-type is a subtype of character, read-char and/or write-char can be used on the resulting file stream. When element-type is a subtype of integer, read-byte and/or write-byte can be used on the resulting file stream. When element-type is :default, the type can be determined by using stream-element-type.  File: gcl.info, Node: stream-external-format, Next: with-open-file, Prev: open, Up: Streams Dictionary 21.2.30 stream-external-format [Function] ----------------------------------------- 'stream-external-format' stream => format Arguments and Values:: ...................... stream--a file stream. format--an external file format. Description:: ............. Returns an external file format designator for the stream. Examples:: .......... (with-open-file (stream "test" :direction :output) (stream-external-format stream)) => :DEFAULT OR=> :ISO8859/1-1987 OR=> (:ASCII :SAIL) OR=> ACME::PROPRIETARY-FILE-FORMAT-17 OR=> # See Also:: .......... the :external-format argument to the function *note open:: and the *note with-open-file:: macro. Notes:: ....... The format returned is not necessarily meaningful to other implementations.  File: gcl.info, Node: with-open-file, Next: close, Prev: stream-external-format, Up: Streams Dictionary 21.2.31 with-open-file [macro] ------------------------------ Syntax:: ........ 'with-open-file' (stream filespec {options}*) {declaration}* {form}* => results Arguments and Values:: ...................... stream - a variable. filespec--a pathname designator. options - forms; evaluated. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. with-open-file uses open to create a file stream to file named by filespec. Filespec is the name of the file to be opened. Options are used as keyword arguments to open. The stream object to which the stream variable is bound has dynamic extent; its extent ends when the form is exited. with-open-file evaluates the forms as an implicit progn with stream bound to the value returned by open. When control leaves the body, either normally or abnormally (such as by use of throw), the file is automatically closed. If a new output file is being written, and control leaves abnormally, the file is aborted and the file system is left, so far as possible, as if the file had never been opened. It is possible by the use of :if-exists nil or :if-does-not-exist nil for stream to be bound to nil. Users of :if-does-not-exist nil should check for a valid stream. The consequences are undefined if an attempt is made to assign the stream variable. The compiler may choose to issue a warning if such an attempt is detected. Examples:: .......... (setq p (merge-pathnames "test")) => # (with-open-file (s p :direction :output :if-exists :supersede) (format s "Here are a couple~ (with-open-file (s p) (do ((l (read-line s) (read-line s nil 'eof))) ((eq l 'eof) "Reached end of file.") (format t "~&*** ~A~ |> *** Here are a couple |> *** of test data lines => "Reached end of file." ;; Normally one would not do this intentionally because it is ;; not perspicuous, but beware when using :IF-DOES-NOT-EXIST NIL ;; that this doesn't happen to you accidentally... (with-open-file (foo "no-such-file" :if-does-not-exist nil) (read foo)) |> |>>hello?<<| => HELLO? ;This value was read from the terminal, not a file! ;; Here's another bug to avoid... (with-open-file (foo "no-such-file" :direction :output :if-does-not-exist nil) (format foo "Hello")) => "Hello" ;FORMAT got an argument of NIL! Side Effects:: .............. Creates a stream to the file named by filename (upon entry), and closes the stream (upon exit). In some implementations, the file might be locked in some way while it is open. If the stream is an output stream, a file might be created. Affected By:: ............. The host computer's file system. Exceptional Situations:: ........................ See the function open. See Also:: .......... *note open:: , *note close:: , pathname, logical-pathname, *note Pathnames as Filenames::  File: gcl.info, Node: close, Next: with-open-stream, Prev: with-open-file, Up: Streams Dictionary 21.2.32 close [Function] ------------------------ 'close' stream &key abort => result Arguments and Values:: ...................... stream--a stream (either open or closed). abort--a generalized boolean. The default is false. result--t if the stream was open at the time it was received as an argument, or implementation-dependent otherwise. Description:: ............. close closes stream. Closing a stream means that it may no longer be used in input or output operations. The act of closing a file stream ends the association between the stream and its associated file; the transaction with the file system is terminated, and input/output may no longer be performed on the stream. If abort is true, an attempt is made to clean up any side effects of having created stream. If stream performs output to a file that was created when the stream was created, the file is deleted and any previously existing file is not superseded. It is permissible to close an already closed stream, but in that case the result is implementation-dependent. After stream is closed, it is still possible to perform the following query operations upon it: streamp, pathname, truename, merge-pathnames, pathname-host, pathname-device, pathname-directory,pathname-name, pathname-type, pathname-version, namestring, file-namestring, directory-namestring, host-namestring, enough-namestring, open, probe-file, and directory. The effect of close on a constructed stream is to close the argument stream only. There is no effect on the constituents of composite streams. For a stream created with make-string-output-stream, the result of get-output-stream-string is unspecified after close. Examples:: .......... (setq s (make-broadcast-stream)) => # (close s) => T (output-stream-p s) => true Side Effects:: .............. The stream is closed (if necessary). If abort is true and the stream is an output file stream, its associated file might be deleted. See Also:: .......... *note open::  File: gcl.info, Node: with-open-stream, Next: listen, Prev: close, Up: Streams Dictionary 21.2.33 with-open-stream [Macro] -------------------------------- 'with-open-stream' (var stream) {declaration}* {form}* => {result}* Arguments and Values:: ...................... var--a variable name. stream--a form; evaluated to produce a stream. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. with-open-stream performs a series of operations on stream, returns a value, and then closes the stream. Var is bound to the value of stream, and then forms are executed as an implicit progn. stream is automatically closed on exit from with-open-stream, no matter whether the exit is normal or abnormal. The stream has dynamic extent; its extent ends when the form is exited. The consequences are undefined if an attempt is made to assign the the variable var with the forms. Examples:: .......... (with-open-stream (s (make-string-input-stream "1 2 3 4")) (+ (read s) (read s) (read s))) => 6 Side Effects:: .............. The stream is closed (upon exit). See Also:: .......... *note close::  File: gcl.info, Node: listen, Next: clear-input, Prev: with-open-stream, Up: Streams Dictionary 21.2.34 listen [Function] ------------------------- 'listen' &optional input-stream => generalized-boolean Arguments and Values:: ...................... input-stream--an input stream designator. The default is standard input. generalized-boolean--a generalized boolean. Description:: ............. Returns true if there is a character immediately available from input-stream; otherwise, returns false. On a non-interactive input-stream, listen returns true except when at end of file_1. If an end of file is encountered, listen returns false. listen is intended to be used when input-stream obtains characters from an interactive device such as a keyboard. Examples:: .......... (progn (unread-char (read-char)) (list (listen) (read-char))) |> |>>1<<| => (T #\1) (progn (clear-input) (listen)) => NIL ;Unless you're a very fast typist! Affected By:: ............. *standard-input* See Also:: .......... *note interactive-stream-p:: , *note read-char-no-hang::  File: gcl.info, Node: clear-input, Next: finish-output, Prev: listen, Up: Streams Dictionary 21.2.35 clear-input [Function] ------------------------------ 'clear-input' &optional input-stream => nil Arguments and Values:: ...................... input-stream--an input stream designator. The default is standard input. Description:: ............. Clears any available input from input-stream. If clear-input does not make sense for input-stream, then clear-input does nothing. Examples:: .......... ;; The exact I/O behavior of this example might vary from implementation ;; to implementation depending on the kind of interactive buffering that ;; occurs. (The call to SLEEP here is intended to help even out the ;; differences in implementations which do not do line-at-a-time buffering.) (defun read-sleepily (&optional (clear-p nil) (zzz 0)) (list (progn (print '>) (read)) ;; Note that input typed within the first ZZZ seconds ;; will be discarded. (progn (print '>) (if zzz (sleep zzz)) (print '>>) (if clear-p (clear-input)) (read)))) (read-sleepily) |> > |>>10<<| |> > |> >> |>>20<<| => (10 20) (read-sleepily t) |> > |>>10<<| |> > |> >> |>>20<<| => (10 20) (read-sleepily t 10) |> > |>>10<<| |> > |>>20<<| ; Some implementations won't echo typeahead here. |> >> |>>30<<| => (10 30) Side Effects:: .............. The input-stream is modified. Affected By:: ............. *standard-input* Exceptional Situations:: ........................ Should signal an error of type type-error if input-stream is not a stream designator. See Also:: .......... clear-output  File: gcl.info, Node: finish-output, Next: y-or-n-p, Prev: clear-input, Up: Streams Dictionary 21.2.36 finish-output, force-output, clear-output [Function] ------------------------------------------------------------ 'finish-output' &optional output-stream => nil 'force-output' &optional output-stream => nil 'clear-output' &optional output-stream => nil Arguments and Values:: ...................... output-stream--an output stream designator. The default is standard output. Description:: ............. finish-output, force-output, and clear-output exercise control over the internal handling of buffered stream output. finish-output attempts to ensure that any buffered output sent to output-stream has reached its destination, and then returns. force-output initiates the emptying of any internal buffers but does not wait for completion or acknowledgment to return. clear-output attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the destination. If any of these operations does not make sense for output-stream, then it does nothing. The precise actions of these functions are implementation-dependent. Examples:: .......... ;; Implementation A (progn (princ "am i seen?") (clear-output)) => NIL ;; Implementation B (progn (princ "am i seen?") (clear-output)) |> am i seen? => NIL Affected By:: ............. *standard-output* Exceptional Situations:: ........................ Should signal an error of type type-error if output-stream is not a stream designator. See Also:: .......... *note clear-input::  File: gcl.info, Node: y-or-n-p, Next: make-synonym-stream, Prev: finish-output, Up: Streams Dictionary 21.2.37 y-or-n-p, yes-or-no-p [Function] ---------------------------------------- 'y-or-n-p' &optional control &rest arguments => generalized-boolean 'yes-or-no-p' &optional control &rest arguments => generalized-boolean Arguments and Values:: ...................... control--a format control. arguments--format arguments for control. generalized-boolean--a generalized boolean. Description:: ............. These functions ask a question and parse a response from the user. They return true if the answer is affirmative, or false if the answer is negative. y-or-n-p is for asking the user a question whose answer is either "yes" or "no." It is intended that the reply require the user to answer a yes-or-no question with a single character. yes-or-no-p is also for asking the user a question whose answer is either "Yes" or "No." It is intended that the reply require the user to take more action than just a single keystroke, such as typing the full word yes or no followed by a newline. y-or-n-p types out a message (if supplied), reads an answer in some implementation-dependent manner (intended to be short and simple, such as reading a single character such as Y or N). yes-or-no-p types out a message (if supplied), attracts the user's attention (for example, by ringing the terminal's bell), and reads an answer in some implementation-dependent manner (intended to be multiple characters, such as YES or NO). If format-control is supplied and not nil, then a fresh-line operation is performed; then a message is printed as if format-control and arguments were given to format. In any case, yes-or-no-p and y-or-n-p will provide a prompt such as "(Y or N)" or "(Yes or No)" if appropriate. All input and output are performed using query I/O. Examples:: .......... (y-or-n-p "(t or nil) given by") |> (t or nil) given by (Y or N) |>>Y<<| => true (yes-or-no-p "a ~S message" 'frightening) |> a FRIGHTENING message (Yes or No) |>>no<<| => false (y-or-n-p "Produce listing file?") |> Produce listing file? |> Please respond with Y or N. |>>n<<| => false Side Effects:: .............. Output to and input from query I/O will occur. Affected By:: ............. *query-io*. See Also:: .......... *note format:: Notes:: ....... yes-or-no-p and yes-or-no-p do not add question marks to the end of the prompt string, so any desired question mark or other punctuation should be explicitly included in the text query.  File: gcl.info, Node: make-synonym-stream, Next: synonym-stream-symbol, Prev: y-or-n-p, Up: Streams Dictionary 21.2.38 make-synonym-stream [Function] -------------------------------------- 'make-synonym-stream' symbol => synonym-stream Arguments and Values:: ...................... symbol--a symbol that names a dynamic variable. synonym-stream--a synonym stream. Description:: ............. Returns a synonym stream whose synonym stream symbol is symbol. Examples:: .......... (setq a-stream (make-string-input-stream "a-stream") b-stream (make-string-input-stream "b-stream")) => # (setq s-stream (make-synonym-stream 'c-stream)) => # (setq c-stream a-stream) => # (read s-stream) => A-STREAM (setq c-stream b-stream) => # (read s-stream) => B-STREAM Exceptional Situations:: ........................ Should signal type-error if its argument is not a symbol. See Also:: .......... *note Stream Concepts::  File: gcl.info, Node: synonym-stream-symbol, Next: broadcast-stream-streams, Prev: make-synonym-stream, Up: Streams Dictionary 21.2.39 synonym-stream-symbol [Function] ---------------------------------------- 'synonym-stream-symbol' synonym-stream => symbol Arguments and Values:: ...................... synonym-stream--a synonym stream. symbol--a symbol. Description:: ............. Returns the symbol whose symbol-value the synonym-stream is using. See Also:: .......... *note make-synonym-stream::  File: gcl.info, Node: broadcast-stream-streams, Next: make-broadcast-stream, Prev: synonym-stream-symbol, Up: Streams Dictionary 21.2.40 broadcast-stream-streams [Function] ------------------------------------------- 'broadcast-stream-streams' broadcast-stream => streams Arguments and Values:: ...................... broadcast-stream--a broadcast stream. streams--a list of streams. Description:: ............. Returns a list of output streams that constitute all the streams to which the broadcast-stream is broadcasting.  File: gcl.info, Node: make-broadcast-stream, Next: make-two-way-stream, Prev: broadcast-stream-streams, Up: Streams Dictionary 21.2.41 make-broadcast-stream [Function] ---------------------------------------- 'make-broadcast-stream' &rest streams => broadcast-stream Arguments and Values:: ...................... stream--an output stream. broadcast-stream--a broadcast stream. Description:: ............. Returns a broadcast stream. Examples:: .......... (setq a-stream (make-string-output-stream) b-stream (make-string-output-stream)) => # (format (make-broadcast-stream a-stream b-stream) "this will go to both streams") => NIL (get-output-stream-string a-stream) => "this will go to both streams" (get-output-stream-string b-stream) => "this will go to both streams" Exceptional Situations:: ........................ Should signal an error of type type-error if any stream is not an output stream. See Also:: .......... *note broadcast-stream-streams::  File: gcl.info, Node: make-two-way-stream, Next: two-way-stream-input-stream, Prev: make-broadcast-stream, Up: Streams Dictionary 21.2.42 make-two-way-stream [Function] -------------------------------------- 'make-two-way-stream' input-stream output-stream => two-way-stream Arguments and Values:: ...................... input-stream--a stream. output-stream--a stream. two-way-stream--a two-way stream. Description:: ............. Returns a two-way stream that gets its input from input-stream and sends its output to output-stream. Examples:: .......... (with-output-to-string (out) (with-input-from-string (in "input...") (let ((two (make-two-way-stream in out))) (format two "output...") (setq what-is-read (read two))))) => "output..." what-is-read => INPUT... Exceptional Situations:: ........................ Should signal an error of type type-error if input-stream is not an input stream. Should signal an error of type type-error if output-stream is not an output stream.  File: gcl.info, Node: two-way-stream-input-stream, Next: echo-stream-input-stream, Prev: make-two-way-stream, Up: Streams Dictionary 21.2.43 two-way-stream-input-stream, two-way-stream-output-stream ----------------------------------------------------------------- [Function] 'two-way-stream-input-stream' two-way-stream => input-stream 'two-way-stream-output-stream' two-way-stream => output-stream Arguments and Values:: ...................... two-way-stream--a two-way stream. input-stream--an input stream. output-stream--an output stream. Description:: ............. two-way-stream-input-stream returns the stream from which two-way-stream receives input. two-way-stream-output-stream returns the stream to which two-way-stream sends output.  File: gcl.info, Node: echo-stream-input-stream, Next: make-echo-stream, Prev: two-way-stream-input-stream, Up: Streams Dictionary 21.2.44 echo-stream-input-stream, echo-stream-output-stream [Function] ---------------------------------------------------------------------- 'echo-stream-input-stream' echo-stream => input-stream 'echo-stream-output-stream' echo-stream => output-stream Arguments and Values:: ...................... echo-stream--an echo stream. input-stream--an input stream. output-stream--an output stream. Description:: ............. echo-stream-input-stream returns the input stream from which echo-stream receives input. echo-stream-output-stream returns the output stream to which echo-stream sends output.  File: gcl.info, Node: make-echo-stream, Next: concatenated-stream-streams, Prev: echo-stream-input-stream, Up: Streams Dictionary 21.2.45 make-echo-stream [Function] ----------------------------------- 'make-echo-stream' input-stream output-stream => echo-stream Arguments and Values:: ...................... input-stream--an input stream. output-stream--an output stream. echo-stream--an echo stream. Description:: ............. Creates and returns an echo stream that takes input from input-stream and sends output to output-stream. Examples:: .......... (let ((out (make-string-output-stream))) (with-open-stream (s (make-echo-stream (make-string-input-stream "this-is-read-and-echoed") out)) (read s) (format s " * this-is-direct-output") (get-output-stream-string out))) => "this-is-read-and-echoed * this-is-direct-output" See Also:: .......... *note echo-stream-input-stream:: , echo-stream-output-stream, *note make-two-way-stream::  File: gcl.info, Node: concatenated-stream-streams, Next: make-concatenated-stream, Prev: make-echo-stream, Up: Streams Dictionary 21.2.46 concatenated-stream-streams [Function] ---------------------------------------------- 'concatenated-stream-streams' concatenated-stream => streams Arguments and Values:: ...................... concatenated-stream - a concatenated stream. streams--a list of input streams. Description:: ............. Returns a list of input streams that constitute the ordered set of streams the concatenated-stream still has to read from, starting with the current one it is reading from. The list may be empty if no more streams remain to be read. The consequences are undefined if the list structure of the streams is ever modified.  File: gcl.info, Node: make-concatenated-stream, Next: get-output-stream-string, Prev: concatenated-stream-streams, Up: Streams Dictionary 21.2.47 make-concatenated-stream [Function] ------------------------------------------- 'make-concatenated-stream' &rest input-streams => concatenated-stream Arguments and Values:: ...................... input-stream--an input stream. concatenated-stream--a concatenated stream. Description:: ............. Returns a concatenated stream that has the indicated input-streams initially associated with it. Examples:: .......... (read (make-concatenated-stream (make-string-input-stream "1") (make-string-input-stream "2"))) => 12 Exceptional Situations:: ........................ Should signal type-error if any argument is not an input stream. See Also:: .......... *note concatenated-stream-streams::  File: gcl.info, Node: get-output-stream-string, Next: make-string-input-stream, Prev: make-concatenated-stream, Up: Streams Dictionary 21.2.48 get-output-stream-string [Function] ------------------------------------------- 'get-output-stream-string' string-output-stream => string Arguments and Values:: ...................... string-output-stream--a stream. string--a string. Description:: ............. Returns a string containing, in order, all the characters that have been output to string-output-stream. This operation clears any characters on string-output-stream, so the string contains only those characters which have been output since the last call to get-output-stream-string or since the creation of the string-output-stream, whichever occurred most recently. Examples:: .......... (setq a-stream (make-string-output-stream) a-string "abcdefghijklm") => "abcdefghijklm" (write-string a-string a-stream) => "abcdefghijklm" (get-output-stream-string a-stream) => "abcdefghijklm" (get-output-stream-string a-stream) => "" Side Effects:: .............. The string-output-stream is cleared. Exceptional Situations:: ........................ The consequences are undefined if stream-output-string is closed. The consequences are undefined if string-output-stream is a stream that was not produced by make-string-output-stream. The consequences are undefined if string-output-stream was created implicitly by with-output-to-string or format. See Also:: .......... *note make-string-output-stream::  File: gcl.info, Node: make-string-input-stream, Next: make-string-output-stream, Prev: get-output-stream-string, Up: Streams Dictionary 21.2.49 make-string-input-stream [Function] ------------------------------------------- 'make-string-input-stream' string &optional start end => string-stream Arguments and Values:: ...................... string--a string. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. string-stream--an input string stream. Description:: ............. Returns an input string stream. This stream will supply, in order, the characters in the substring of string bounded by start and end. After the last character has been supplied, the string stream will then be at end of file. Examples:: .......... (let ((string-stream (make-string-input-stream "1 one "))) (list (read string-stream nil nil) (read string-stream nil nil) (read string-stream nil nil))) => (1 ONE NIL) (read (make-string-input-stream "prefixtargetsuffix" 6 12)) => TARGET See Also:: .......... *note with-input-from-string::  File: gcl.info, Node: make-string-output-stream, Next: with-input-from-string, Prev: make-string-input-stream, Up: Streams Dictionary 21.2.50 make-string-output-stream [Function] -------------------------------------------- 'make-string-output-stream' &key element-type => string-stream Arguments and Values:: ...................... element-type--a type specifier. The default is character. string-stream--an output string stream. Description:: ............. Returns an output string stream that accepts characters and makes available (via get-output-stream-string) a string that contains the characters that were actually output. The element-type names the type of the elements of the string; a string is constructed of the most specialized type that can accommodate elements of that element-type. Examples:: .......... (let ((s (make-string-output-stream))) (write-string "testing... " s) (prin1 1234 s) (get-output-stream-string s)) => "testing... 1234" None.. See Also:: .......... *note get-output-stream-string:: , *note with-output-to-string::  File: gcl.info, Node: with-input-from-string, Next: with-output-to-string, Prev: make-string-output-stream, Up: Streams Dictionary 21.2.51 with-input-from-string [Macro] -------------------------------------- 'with-input-from-string' (var string &key index start end) {declaration}* {form}* => {result}* Arguments and Values:: ...................... var--a variable name. string--a form; evaluated to produce a string. index--a place. start, end--bounding index designators of string. The defaults for start and end are 0 and nil, respectively. declaration--a declare expression; not evaluated. forms--an implicit progn. result--the values returned by the forms. Description:: ............. Creates an input string stream, provides an opportunity to perform operations on the stream (returning zero or more values), and then closes the string stream. String is evaluated first, and var is bound to a character input string stream that supplies characters from the subsequence of the resulting string bounded by start and end. The body is executed as an implicit progn. The input string stream is automatically closed on exit from with-input-from-string, no matter whether the exit is normal or abnormal. The input string stream to which the variable var is bound has dynamic extent; its extent ends when the form is exited. The index is a pointer within the string to be advanced. If with-input-from-string is exited normally, then index will have as its value the index into the string indicating the first character not read which is (length string) if all characters were used. The place specified by index is not updated as reading progresses, but only at the end of the operation. start and index may both specify the same variable, which is a pointer within the string to be advanced, perhaps repeatedly by some containing loop. The consequences are undefined if an attempt is made to assign the variable var. Examples:: .......... (with-input-from-string (s "XXX1 2 3 4xxx" :index ind :start 3 :end 10) (+ (read s) (read s) (read s))) => 6 ind => 9 (with-input-from-string (s "Animal Crackers" :index j :start 6) (read s)) => CRACKERS The variable j is set to 15. Side Effects:: .............. The value of the place named by index, if any, is modified. See Also:: .......... *note make-string-input-stream:: , *note Traversal Rules and Side Effects::  File: gcl.info, Node: with-output-to-string, Next: *debug-io*, Prev: with-input-from-string, Up: Streams Dictionary 21.2.52 with-output-to-string [Macro] ------------------------------------- 'with-output-to-string' (var &optional string-form &key element-type) {declaration}* {form}* => {result}* Arguments and Values:: ...................... var--a variable name. string-form--a form or nil; if non-nil, evaluated to produce string. string--a string that has a fill pointer. element-type--a type specifier; evaluated. The default is character. declaration--a declare expression; not evaluated. forms--an implicit progn. results--If a string-form is not supplied or nil, a string; otherwise, the values returned by the forms. Description:: ............. with-output-to-string creates a character output stream, performs a series of operations that may send results to this stream, and then closes the stream. The element-type names the type of the elements of the stream; a stream is constructed of the most specialized type that can accommodate elements of the given type. The body is executed as an implicit progn with var bound to an output string stream. All output to that string stream is saved in a string. If string is supplied, element-type is ignored, and the output is incrementally appended to string as if by use of vector-push-extend. The output stream is automatically closed on exit from with-output-from-string, no matter whether the exit is normal or abnormal. The output string stream to which the variable var is bound has dynamic extent; its extent ends when the form is exited. If no string is provided, then with-output-from-string produces a stream that accepts characters and returns a string of the indicated element-type. If string is provided, with-output-to-string returns the results of evaluating the last form. The consequences are undefined if an attempt is made to assign the variable var. Examples:: .......... (setq fstr (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)) => "" (with-output-to-string (s fstr) (format s "here's some output") (input-stream-p s)) => false fstr => "here's some output" Side Effects:: .............. The string is modified. Exceptional Situations:: ........................ The consequences are undefined if destructive modifications are performed directly on the string during the dynamic extent of the call. See Also:: .......... *note make-string-output-stream:: , vector-push-extend, *note Traversal Rules and Side Effects::  File: gcl.info, Node: *debug-io*, Next: *terminal-io*, Prev: with-output-to-string, Up: Streams Dictionary 21.2.53 *debug-io*, *error-output*, *query-io*, ----------------------------------------------- *standard-input*, *standard-output*, ------------------------------------ *trace-output* -------------- [Variable] Value Type:: ............ For *standard-input*: an input stream For *error-output*, *standard-output*, and *trace-output*: an output stream. For *debug-io*, *query-io*: a bidirectional stream. Initial Value:: ............... implementation-dependent, but it must be an open stream that is not a generalized synonym stream to an I/O customization variables but that might be a generalized synonym stream to the value of some I/O customization variable. The initial value might also be a generalized synonym stream to either the symbol *terminal-io* or to the stream that is its value. Description:: ............. These variables are collectively called the standardized I/O customization variables. They can be bound or assigned in order to change the default destinations for input and/or output used by various standardized operators and facilities. The value of *debug-io*, called debug I/O, is a stream to be used for interactive debugging purposes. The value of *error-output*, called error output, is a stream to which warnings and non-interactive error messages should be sent. The value of *query-io*, called query I/O, is a bidirectional stream to be used when asking questions of the user. The question should be output to this stream, and the answer read from it. The value of *standard-input*, called standard input, is a stream that is used by many operators as a default source of input when no specific input stream is explicitly supplied. The value of *standard-output*, called standard output, is a stream that is used by many operators as a default destination for output when no specific output stream is explicitly supplied. The value of *trace-output*, called trace output, is the stream on which traced functions (see trace) and the time macro print their output. Examples:: .......... (with-output-to-string (*error-output*) (warn "this string is sent to *error-output*")) => "Warning: this string is sent to *error-output* " ;The exact format of this string is implementation-dependent. (with-input-from-string (*standard-input* "1001") (+ 990 (read))) => 1991 (progn (setq out (with-output-to-string (*standard-output*) (print "print and format t send things to") (format t "*standard-output* now going to a string"))) :done) => :DONE out => " \"print and format t send things to\" *standard-output* now going to a string" (defun fact (n) (if (< n 2) 1 (* n (fact (- n 1))))) => FACT (trace fact) => (FACT) ;; Of course, the format of traced output is implementation-dependent. (with-output-to-string (*trace-output*) (fact 3)) => " 1 Enter FACT 3 | 2 Enter FACT 2 | 3 Enter FACT 1 | 3 Exit FACT 1 | 2 Exit FACT 2 1 Exit FACT 6" See Also:: .......... *terminal-io*, synonym-stream, *note Time:: , *note trace:: , *note Conditions::, *note Reader::, *note Printer:: Notes:: ....... The intent of the constraints on the initial value of the I/O customization variables is to ensure that it is always safe to bind or assign such a variable to the value of another I/O customization variable, without unduly restricting implementation flexibility. It is common for an implementation to make the initial values of *debug-io* and *query-io* be the same stream, and to make the initial values of *error-output* and *standard-output* be the same stream. The functions y-or-n-p and yes-or-no-p use query I/O for their input and output. In the normal Lisp read-eval-print loop, input is read from standard input. Many input functions, including read and read-char, take a stream argument that defaults to standard input. In the normal Lisp read-eval-print loop, output is sent to standard output. Many output functions, including print and write-char, take a stream argument that defaults to standard output. A program that wants, for example, to divert output to a file should do so by binding *standard-output*; that way error messages sent to *error-output* can still get to the user by going through *terminal-io* (if *error-output* is bound to *terminal-io*), which is usually what is desired.  File: gcl.info, Node: *terminal-io*, Next: stream-error, Prev: *debug-io*, Up: Streams Dictionary 21.2.54 *terminal-io* [Variable] -------------------------------- Value Type:: ............ a bidirectional stream. Initial Value:: ............... implementation-dependent, but it must be an open stream that is not a generalized synonym stream to an I/O customization variables but that might be a generalized synonym stream to the value of some I/O customization variable. Description:: ............. The value of *terminal-io*, called terminal I/O, is ordinarily a bidirectional stream that connects to the user's console. Typically, writing to this stream would cause the output to appear on a display screen, for example, and reading from the stream would accept input from a keyboard. It is intended that standard input functions such as read and read-char, when used with this stream, cause echoing of the input into the output side of the stream. The means by which this is accomplished are implementation-dependent. The effect of changing the value of *terminal-io*, either by binding or assignment, is implementation-defined. Examples:: .......... (progn (prin1 'foo) (prin1 'bar *terminal-io*)) |> FOOBAR => BAR (with-output-to-string (*standard-output*) (prin1 'foo) (prin1 'bar *terminal-io*)) |> BAR => "FOO" See Also:: .......... *debug-io*, *error-output*, *query-io*, *standard-input*, *standard-output*, *trace-output*  File: gcl.info, Node: stream-error, Next: stream-error-stream, Prev: *terminal-io*, Up: Streams Dictionary 21.2.55 stream-error [Condition Type] ------------------------------------- Class Precedence List:: ....................... stream-error, error, serious-condition, condition, t Description:: ............. The type stream-error consists of error conditions that are related to receiving input from or sending output to a stream. The "offending stream" is initialized by the :stream initialization argument to make-condition, and is accessed by the function stream-error-stream. See Also:: .......... *note stream-error-stream::  File: gcl.info, Node: stream-error-stream, Next: end-of-file, Prev: stream-error, Up: Streams Dictionary 21.2.56 stream-error-stream [Function] -------------------------------------- 'stream-error-stream' condition => stream Arguments and Values:: ...................... condition--a condition of type stream-error. stream--a stream. Description:: ............. Returns the offending stream of a condition of type stream-error. Examples:: .......... (with-input-from-string (s "(FOO") (handler-case (read s) (end-of-file (c) (format nil "~&End of file on ~S." (stream-error-stream c))))) "End of file on #." See Also:: .......... stream-error, *note Conditions::  File: gcl.info, Node: end-of-file, Prev: stream-error-stream, Up: Streams Dictionary 21.2.57 end-of-file [Condition Type] ------------------------------------ Class Precedence List:: ....................... end-of-file, stream-error, error, serious-condition, condition, t Description:: ............. The type end-of-file consists of error conditions related to read operations that are done on streams that have no more data. See Also:: .......... *note stream-error-stream:: gcl-2.6.14/info/gcl.info-20000644000175000017500000113022714360276512013515 0ustar cammcammThis is gcl.info, produced by makeinfo version 6.7 from gcl.texi. This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard for Common Lisp. Copyright 1994 William F. Schelter INFO-DIR-SECTION GNU Common Lisp START-INFO-DIR-ENTRY * gcl: (gcl.info). GNU Common Lisp Manual END-INFO-DIR-ENTRY  File: gcl.info, Node: Notes about the Implementation of Compiler Macros, Next: Minimal Compilation, Prev: When Compiler Macros Are Used, Up: Compilation Semantics 3.2.2.5 Notes about the Implementation of Compiler Macros ......................................................... Although it is technically permissible, as described above, for eval to treat compiler macros in the same situations as compiler might, this is not necessarily a good idea in interpreted implementations. Compiler macros exist for the purpose of trading compile-time speed for run-time speed. Programmers who write compiler macros tend to assume that the compiler macros can take more time than normal functions and macros in order to produce code which is especially optimal for use at run time. Since eval in an interpreted implementation might perform semantic analysis of the same form multiple times, it might be inefficient in general for the implementation to choose to call compiler macros on every such evaluation. Nevertheless, the decision about what to do in these situations is left to each implementation.  File: gcl.info, Node: Minimal Compilation, Next: Semantic Constraints, Prev: Notes about the Implementation of Compiler Macros, Up: Compilation Semantics 3.2.2.6 Minimal Compilation ........................... Minimal compilation is defined as follows: * All compiler macro calls appearing in the source code being compiled are expanded, if at all, at compile time; they will not be expanded at run time. * All macro and symbol macro calls appearing in the source code being compiled are expanded at compile time in such a way that they will not be expanded again at run time. macrolet and symbol-macrolet are effectively replaced by forms corresponding to their bodies in which calls to macros are replaced by their expansions. * The first argument in a load-time-value form in source code processed by compile is evaluated at compile time; in source code processed by compile-file , the compiler arranges for it to be evaluated at load time. In either case, the result of the evaluation is remembered and used later as the value of the load-time-value form at execution time.  File: gcl.info, Node: Semantic Constraints, Prev: Minimal Compilation, Up: Compilation Semantics 3.2.2.7 Semantic Constraints ............................ All conforming programs must obey the following constraints, which are designed to minimize the observable differences between compiled and interpreted programs: * Definitions of any referenced macros must be present in the compilation environment. Any form that is a list beginning with a symbol that does not name a special operator or a macro defined in the compilation environment is treated by the compiler as a function call. * Special proclamations for dynamic variables must be made in the compilation environment. Any binding for which there is no special declaration or proclamation in the compilation environment is treated by the compiler as a lexical binding. * The definition of a function that is defined and declared inline in the compilation environment must be the same at run time. * Within a function named F, the compiler may (but is not required to) assume that an apparent recursive call to a function named F refers to the same definition of F, unless that function has been declared notinline. The consequences of redefining such a recursively defined function F while it is executing are undefined. * A call within a file to a named function that is defined in the same file refers to that function, unless that function has been declared notinline. The consequences are unspecified if functions are redefined individually at run time or multiply defined in the same file. * The argument syntax and number of return values for all functions whose ftype is declared at compile time must remain the same at run time. * Constant variables defined in the compilation environment must have a similar value at run time. A reference to a constant variable in source code is equivalent to a reference to a literal object that is the value of the constant variable. * Type definitions made with deftype or defstruct in the compilation environment must retain the same definition at run time. Classes defined by defclass in the compilation environment must be defined at run time to have the same superclasses and same metaclass. This implies that subtype/supertype relationships of type specifiers must not change between compile time and run time. * Type declarations present in the compilation environment must accurately describe the corresponding values at run time; otherwise, the consequences are undefined. It is permissible for an unknown type to appear in a declaration at compile time, though a warning might be signaled in such a case. * Except in the situations explicitly listed above, a function defined in the evaluation environment is permitted to have a different definition or a different signature at run time, and the run-time definition prevails. Conforming programs should not be written using any additional assumptions about consistency between the run-time environment and the startup, evaluation, and compilation environments. Except where noted, when a compile-time and a run-time definition are different, one of the following occurs at run time: * an error of type error is signaled * the compile-time definition prevails * the run-time definition prevails If the compiler processes a function form whose operator is not defined at compile time, no error is signaled at compile time.  File: gcl.info, Node: File Compilation, Next: Literal Objects in Compiled Files, Prev: Compilation Semantics, Up: Compilation 3.2.3 File Compilation ---------------------- The function compile-file performs compilation of forms in a file following the rules specified in *note Compilation Semantics::, and produces an output file that can be loaded by using load. Normally, the top level forms appearing in a file compiled with compile-file are evaluated only when the resulting compiled file is loaded, and not when the file is compiled. However, it is typically the case that some forms in the file need to be evaluated at compile time so the remainder of the file can be read and compiled correctly. The eval-when special form can be used to control whether a top level form is evaluated at compile time, load time, or both. It is possible to specify any of three situations with eval-when, denoted by the symbols :compile-toplevel, :load-toplevel, and :execute. For top level eval-when forms, :compile-toplevel specifies that the compiler must evaluate the body at compile time, and :load-toplevel specifies that the compiler must arrange to evaluate the body at load time. For non-top level eval-when forms, :execute specifies that the body must be executed in the run-time environment. The behavior of this form can be more precisely understood in terms of a model of how compile-file processes forms in a file to be compiled. There are two processing modes, called "not-compile-time" and "compile-time-too". Successive forms are read from the file by compile-file and processed in not-compile-time mode; in this mode, compile-file arranges for forms to be evaluated only at load time and not at compile time. When compile-file is in compile-time-too mode, forms are evaluated both at compile time and load time. * Menu: * Processing of Top Level Forms:: * Processing of Defining Macros:: * Constraints on Macros and Compiler Macros::  File: gcl.info, Node: Processing of Top Level Forms, Next: Processing of Defining Macros, Prev: File Compilation, Up: File Compilation 3.2.3.1 Processing of Top Level Forms ..................................... Processing of top level forms in the file compiler is defined as follows: 1. If the form is a compiler macro form (not disabled by a notinline declaration), the implementation might or might not choose to compute the compiler macro expansion of the form and, having performed the expansion, might or might not choose to process the result as a top level form in the same processing mode (compile-time-too or not-compile-time). If it declines to obtain or use the expansion, it must process the original form. 2. If the form is a macro form, its macro expansion is computed and processed as a top level form in the same processing mode (compile-time-too or not-compile-time). 3. If the form is a progn form, each of its body forms is sequentially processed as a top level form in the same processing mode. 4. If the form is a locally, macrolet, or symbol-macrolet, compile-file establishes the appropriate bindings and processes the body forms as top level forms with those bindings in effect in the same processing mode. (Note that this implies that the lexical environment in which top level forms are processed is not necessarily the null lexical environment.) 5. If the form is an eval-when form, it is handled according to Figure 3-7. plus .5 fil \offinterlineskip CT LT E Mode Action New Mode _________________________________________________ Yes Yes -- -- Process compile-time-too No Yes Yes CTT Process compile-time-too No Yes Yes NCT Process not-compile-time No Yes No -- Process not-compile-time Yes No -- -- Evaluate -- No No Yes CTT Evaluate -- No No Yes NCT Discard -- No No No -- Discard -- Figure 3-7: EVAL-WHEN processing Column CT indicates whether :compile-toplevel is specified. Column LT indicates whether :load-toplevel is specified. Column E indicates whether :execute is specified. Column Mode indicates the processing mode; a dash (--) indicates that the processing mode is not relevant. The Action column specifies one of three actions: Process: process the body as top level forms in the specified mode. Evaluate: evaluate the body in the dynamic execution context of the compiler, using the evaluation environment as the global environment and the lexical environment in which the eval-when appears. Discard: ignore the form. The New Mode column indicates the new processing mode. A dash (--) indicates the compiler remains in its current mode. 6. Otherwise, the form is a top level form that is not one of the special cases. In compile-time-too mode, the compiler first evaluates the form in the evaluation environment and then minimally compiles it. In not-compile-time mode, the form is simply minimally compiled. All subforms are treated as non-top-level forms. Note that top level forms are processed in the order in which they textually appear in the file and that each top level form read by the compiler is processed before the next is read. However, the order of processing (including macro expansion) of subforms that are not top level forms and the order of further compilation is unspecified as long as Common Lisp semantics are preserved. eval-when forms cause compile-time evaluation only at top level. Both :compile-toplevel and :load-toplevel situation specifications are ignored for non-top-level forms. For non-top-level forms, an eval-when specifying the :execute situation is treated as an implicit progn including the forms in the body of the eval-when form; otherwise, the forms in the body are ignored.  File: gcl.info, Node: Processing of Defining Macros, Next: Constraints on Macros and Compiler Macros, Prev: Processing of Top Level Forms, Up: File Compilation 3.2.3.2 Processing of Defining Macros ..................................... Defining macros (such as defmacro or defvar) appearing within a file being processed by compile-file normally have compile-time side effects which affect how subsequent forms in the same file are compiled. A convenient model for explaining how these side effects happen is that the defining macro expands into one or more eval-when forms, and that the calls which cause the compile-time side effects to happen appear in the body of an (eval-when (:compile-toplevel) ...) form. The compile-time side effects may cause information about the definition to be stored differently than if the defining macro had been processed in the 'normal' way (either interpretively or by loading the compiled file). In particular, the information stored by the defining macros at compile time might or might not be available to the interpreter (either during or after compilation), or during subsequent calls to the compiler. For example, the following code is nonportable because it assumes that the compiler stores the macro definition of foo where it is available to the interpreter: (defmacro foo (x) `(car ,x)) (eval-when (:execute :compile-toplevel :load-toplevel) (print (foo '(a b c)))) A portable way to do the same thing would be to include the macro definition inside the eval-when form, as in: (eval-when (:execute :compile-toplevel :load-toplevel) (defmacro foo (x) `(car ,x)) (print (foo '(a b c)))) Figure 3-8 lists macros that make definitions available both in the compilation and run-time environments. It is not specified whether definitions made available in the compilation environment are available in the evaluation environment, nor is it specified whether they are available in subsequent compilation units or subsequent invocations of the compiler. As with eval-when, these compile-time side effects happen only when the defining macros appear at top level. declaim define-modify-macro defsetf defclass define-setf-expander defstruct defconstant defmacro deftype define-compiler-macro defpackage defvar define-condition defparameter Figure 3-8: Defining Macros That Affect the Compile-Time Environment  File: gcl.info, Node: Constraints on Macros and Compiler Macros, Prev: Processing of Defining Macros, Up: File Compilation 3.2.3.3 Constraints on Macros and Compiler Macros ................................................. Except where explicitly stated otherwise, no macro defined in the Common Lisp standard produces an expansion that could cause any of the subforms of the macro form to be treated as top level forms. If an implementation also provides a special operator definition of a Common Lisp macro, the special operator definition must be semantically equivalent in this respect. Compiler macro expansions must also have the same top level evaluation semantics as the form which they replace. This is of concern both to conforming implementations and to conforming programs.  File: gcl.info, Node: Literal Objects in Compiled Files, Next: Exceptional Situations in the Compiler, Prev: File Compilation, Up: Compilation 3.2.4 Literal Objects in Compiled Files --------------------------------------- The functions eval and compile are required to ensure that literal objects referenced within the resulting interpreted or compiled code objects are the same as the corresponding objects in the source code. compile-file, on the other hand, must produce a compiled file that, when loaded with load, constructs the objects defined by the source code and produces references to them. In the case of compile-file, objects constructed by load of the compiled file cannot be spoken of as being the same as the objects constructed at compile time, because the compiled file may be loaded into a different Lisp image than the one in which it was compiled. This section defines the concept of similarity which relates objects in the evaluation environment to the corresponding objects in the run-time environment. The constraints on literal objects described in this section apply only to compile-file; eval and compile do not copy or coalesce constants. * Menu: * Externalizable Objects:: * Similarity of Literal Objects:: * Similarity of Aggregate Objects:: * Definition of Similarity:: * Extensions to Similarity Rules:: * Additional Constraints on Externalizable Objects::  File: gcl.info, Node: Externalizable Objects, Next: Similarity of Literal Objects, Prev: Literal Objects in Compiled Files, Up: Literal Objects in Compiled Files 3.2.4.1 Externalizable Objects .............................. The fact that the file compiler represents literal objects externally in a compiled file and must later reconstruct suitable equivalents of those objects when that file is loaded imposes a need for constraints on the nature of the objects that can be used as literal objects in code to be processed by the file compiler. An object that can be used as a literal object in code to be processed by the file compiler is called an externalizable object . We define that two objects are similar if they satisfy a two-place conceptual equivalence predicate (defined below), which is independent of the Lisp image so that the two objects in different Lisp images can be understood to be equivalent under this predicate. Further, by inspecting the definition of this conceptual predicate, the programmer can anticipate what aspects of an object are reliably preserved by file compilation. The file compiler must cooperate with the loader in order to assure that in each case where an externalizable object is processed as a literal object, the loader will construct a similar object. The set of objects that are externalizable objects are those for which the new conceptual term "similar" is defined, such that when a compiled file is loaded, an object can be constructed which can be shown to be similar to the original object which existed at the time the file compiler was operating.  File: gcl.info, Node: Similarity of Literal Objects, Next: Similarity of Aggregate Objects, Prev: Externalizable Objects, Up: Literal Objects in Compiled Files 3.2.4.2 Similarity of Literal Objects .....................................  File: gcl.info, Node: Similarity of Aggregate Objects, Next: Definition of Similarity, Prev: Similarity of Literal Objects, Up: Literal Objects in Compiled Files 3.2.4.3 Similarity of Aggregate Objects ....................................... Of the types over which similarity is defined, some are treated as aggregate objects. For these types, similarity is defined recursively. We say that an object of these types has certain "basic qualities" and to satisfy the similarity relationship, the values of the corresponding qualities of the two objects must also be similar.  File: gcl.info, Node: Definition of Similarity, Next: Extensions to Similarity Rules, Prev: Similarity of Aggregate Objects, Up: Literal Objects in Compiled Files 3.2.4.4 Definition of Similarity ................................ Two objects S (in source code) and C (in compiled code) are defined to be similar if and only if they are both of one of the types listed here (or defined by the implementation) and they both satisfy all additional requirements of similarity indicated for that type. number Two numbers S and C are similar if they are of the same type and represent the same mathematical value. character Two simple characters S and C are similar if they have similar code attributes. Implementations providing additional, implementation-defined attributes must define whether and how non-simple characters can be regarded as similar. symbol Two apparently uninterned symbols S and C are similar if their names are similar. Two interned symbols S and C are similar if their names are similar, and if either S is accessible in the current package at compile time and C is accessible in the current package at load time, or C is accessible in the package that is similar to the home package of S. (Note that similarity of symbols is dependent on neither the current readtable nor how the function read would parse the characters in the name of the symbol.) package Two packages S and C are similar if their names are similar. Note that although a package object is an externalizable object, the programmer is responsible for ensuring that the corresponding package is already in existence when code referencing it as a literal object is loaded. The loader finds the corresponding package object as if by calling find-package with that name as an argument. An error is signaled by the loader if no package exists at load time. random-state Two random states S and C are similar if S would always produce the same sequence of pseudo-random numbers as a copy_5 of C when given as the random-state argument to the function random, assuming equivalent limit arguments in each case. (Note that since C has been processed by the file compiler, it cannot be used directly as an argument to random because random would perform a side effect.) cons Two conses, S and C, are similar if the car_2 of S is similar to the car_2 of C, and the cdr_2 of S is similar to the cdr_2 of C. array Two one-dimensional arrays, S and C, are similar if the length of S is similar to the length of C, the actual array element type of S is similar to the actual array element type of C, and each active element of S is similar to the corresponding element of C. Two arrays of rank other than one, S and C, are similar if the rank of S is similar to the rank of C, each dimension_1 of S is similar to the corresponding dimension_1 of C, the actual array element type of S is similar to the actual array element type of C, and each element of S is similar to the corresponding element of C. In addition, if S is a simple array, then C must also be a simple array. If S is a displaced array, has a fill pointer, or is actually adjustable, C is permitted to lack any or all of these qualities. hash-table Two hash tables S and C are similar if they meet the following three requirements: 1. They both have the same test (e.g., they are both eql hash tables). 2. There is a unique one-to-one correspondence between the keys of the two hash tables, such that the corresponding keys are similar. 3. For all keys, the values associated with two corresponding keys are similar. If there is more than one possible one-to-one correspondence between the keys of S and C, the consequences are unspecified. A conforming program cannot use a table such as S as an externalizable constant. pathname Two pathnames S and C are similar if all corresponding pathname components are similar. function Functions are not externalizable objects. structure-object and standard-object A general-purpose concept of similarity does not exist for structures and standard objects. However, a conforming program is permitted to define a make-load-form method for any class K defined by that program that is a subclass of either structure-object or standard-object. The effect of such a method is to define that an object S of type K in source code is similar to an object C of type K in compiled code if C was constructed from code produced by calling make-load-form on S.  File: gcl.info, Node: Extensions to Similarity Rules, Next: Additional Constraints on Externalizable Objects, Prev: Definition of Similarity, Up: Literal Objects in Compiled Files 3.2.4.5 Extensions to Similarity Rules ...................................... Some objects, such as streams, readtables, and methods are not externalizable objects under the definition of similarity given above. That is, such objects may not portably appear as literal objects in code to be processed by the file compiler. An implementation is permitted to extend the rules of similarity, so that other kinds of objects are externalizable objects for that implementation. If for some kind of object, similarity is neither defined by this specification nor by the implementation, then the file compiler must signal an error upon encountering such an object as a literal constant.  File: gcl.info, Node: Additional Constraints on Externalizable Objects, Prev: Extensions to Similarity Rules, Up: Literal Objects in Compiled Files 3.2.4.6 Additional Constraints on Externalizable Objects ........................................................ If two literal objects appearing in the source code for a single file processed with the file compiler are the identical, the corresponding objects in the compiled code must also be the identical. With the exception of symbols and packages, any two literal objects in code being processed by the file compiler may be coalesced if and only if they are similar; if they are either both symbols or both packages, they may only be coalesced if and only if they are identical. Objects containing circular references can be externalizable objects. The file compiler is required to preserve eqlness of substructures within a file. Preserving eqlness means that subobjects that are the same in the source code must be the same in the corresponding compiled code. In addition, the following are constraints on the handling of literal objects by the file compiler: array: If an array in the source code is a simple array, then the corresponding array in the compiled code will also be a simple array. If an array in the source code is displaced, has a fill pointer, or is actually adjustable, the corresponding array in the compiled code might lack any or all of these qualities. If an array in the source code has a fill pointer, then the corresponding array in the compiled code might be only the size implied by the fill pointer. packages: The loader is required to find the corresponding package object as if by calling find-package with the package name as an argument. An error of type package-error is signaled if no package of that name exists at load time. random-state: A constant random state object cannot be used as the state argument to the function random because random modifies this data structure. structure, standard-object: Objects of type structure-object and standard-object may appear in compiled constants if there is an appropriate make-load-form method defined for that type. The file compiler calls make-load-form on any object that is referenced as a literal object if the object is a generalized instance of standard-object, structure-object, condition, or any of a (possibly empty) implementation-dependent set of other classes. The file compiler only calls make-load-form once for any given object within a single file. symbol: In order to guarantee that compiled files can be loaded correctly, users must ensure that the packages referenced in those files are defined consistently at compile time and load time. Conforming programs must satisfy the following requirements: 1. The current package when a top level form in the file is processed by compile-file must be the same as the current package when the code corresponding to that top level form in the compiled file is executed by load. In particular: a. Any top level form in a file that alters the current package must change it to a package of the same name both at compile time and at load time. b. If the first non-atomic top level form in the file is not an in-package form, then the current package at the time load is called must be a package with the same name as the package that was the current package at the time compile-file was called. 2. For all symbols appearing lexically within a top level form that were accessible in the package that was the current package during processing of that top level form at compile time, but whose home package was another package, at load time there must be a symbol with the same name that is accessible in both the load-time current package and in the package with the same name as the compile-time home package. 3. For all symbols represented in the compiled file that were external symbols in their home package at compile time, there must be a symbol with the same name that is an external symbol in the package with the same name at load time. If any of these conditions do not hold, the package in which the loader looks for the affected symbols is unspecified. Implementations are permitted to signal an error or to define this behavior.  File: gcl.info, Node: Exceptional Situations in the Compiler, Prev: Literal Objects in Compiled Files, Up: Compilation 3.2.5 Exceptional Situations in the Compiler -------------------------------------------- compile and compile-file are permitted to signal errors and warnings, including errors due to compile-time processing of (eval-when (:compile-toplevel) ...) forms, macro expansion, and conditions signaled by the compiler itself. Conditions of type error might be signaled by the compiler in situations where the compilation cannot proceed without intervention. In addition to situations for which the standard specifies that conditions of type warning must or might be signaled, warnings might be signaled in situations where the compiler can determine that the consequences are undefined or that a run-time error will be signaled. Examples of this situation are as follows: violating type declarations, altering or assigning the value of a constant defined with defconstant, calling built-in Lisp functions with a wrong number of arguments or malformed keyword argument lists, and using unrecognized declaration specifiers. The compiler is permitted to issue warnings about matters of programming style as conditions of type style-warning. Examples of this situation are as follows: redefining a function using a different argument list, calling a function with a wrong number of arguments, not declaring ignore of a local variable that is not referenced, and referencing a variable declared ignore. Both compile and compile-file are permitted (but not required) to establish a handler for conditions of type error. For example, they might signal a warning, and restart compilation from some implementation-dependent point in order to let the compilation proceed without manual intervention. Both compile and compile-file return three values, the second two indicating whether the source code being compiled contained errors and whether style warnings were issued. Some warnings might be deferred until the end of compilation. See with-compilation-unit.  File: gcl.info, Node: Declarations, Next: Lambda Lists, Prev: Compilation, Up: Evaluation and Compilation 3.3 Declarations ================ Declarations provide a way of specifying information for use by program processors, such as the evaluator or the compiler. Local declarations can be embedded in executable code using declare. Global declarations , or proclamations , are established by proclaim or declaim. The the special form provides a shorthand notation for making a local declaration about the type of the value of a given form. The consequences are undefined if a program violates a declaration or a proclamation. * Menu: * Minimal Declaration Processing Requirements:: * Declaration Specifiers:: * Declaration Identifiers:: * Declaration Scope::  File: gcl.info, Node: Minimal Declaration Processing Requirements, Next: Declaration Specifiers, Prev: Declarations, Up: Declarations 3.3.1 Minimal Declaration Processing Requirements ------------------------------------------------- In general, an implementation is free to ignore declaration specifiers except for the declaration , notinline , safety , and special declaration specifiers. A declaration declaration must suppress warnings about unrecognized declarations of the kind that it declares. If an implementation does not produce warnings about unrecognized declarations, it may safely ignore this declaration. A notinline declaration must be recognized by any implementation that supports inline functions or compiler macros in order to disable those facilities. An implementation that does not use inline functions or compiler macros may safely ignore this declaration. A safety declaration that increases the current safety level must always be recognized. An implementation that always processes code as if safety were high may safely ignore this declaration. A special declaration must be processed by all implementations.  File: gcl.info, Node: Declaration Specifiers, Next: Declaration Identifiers, Prev: Minimal Declaration Processing Requirements, Up: Declarations 3.3.2 Declaration Specifiers ---------------------------- A declaration specifier is an expression that can appear at top level of a declare expression or a declaim form, or as the argument to proclaim. It is a list whose car is a declaration identifier, and whose cdr is data interpreted according to rules specific to the declaration identifier.  File: gcl.info, Node: Declaration Identifiers, Next: Declaration Scope, Prev: Declaration Specifiers, Up: Declarations 3.3.3 Declaration Identifiers ----------------------------- Figure 3-9 shows a list of all declaration identifiers defined by this standard. declaration ignore special dynamic-extent inline type ftype notinline ignorable optimize Figure 3-9: Common Lisp Declaration Identifiers An implementation is free to support other (implementation-defined) declaration identifiers as well. A warning might be issued if a declaration identifier is not among those defined above, is not defined by the implementation, is not a type name, and has not been declared in a declaration proclamation. * Menu: * Shorthand notation for Type Declarations::  File: gcl.info, Node: Shorthand notation for Type Declarations, Prev: Declaration Identifiers, Up: Declaration Identifiers 3.3.3.1 Shorthand notation for Type Declarations ................................................ A type specifier can be used as a declaration identifier. (type-specifier {var}*) is taken as shorthand for (type type-specifier {var}*).  File: gcl.info, Node: Declaration Scope, Prev: Declaration Identifiers, Up: Declarations 3.3.4 Declaration Scope ----------------------- Declarations can be divided into two kinds: those that apply to the bindings of variables or functions; and those that do not apply to bindings. A declaration that appears at the head of a binding form and applies to a variable or function binding made by that form is called a bound declaration ; such a declaration affects both the binding and any references within the scope of the declaration. Declarations that are not bound declarations are called free declarations . A free declaration in a form F1 that applies to a binding for a name N established by some form F2 of which F1 is a subform affects only references to N within F1; it does not to apply to other references to N outside of F1, nor does it affect the manner in which the binding of N by F2 is established. Declarations that do not apply to bindings can only appear as free declarations. The scope of a bound declaration is the same as the lexical scope of the binding to which it applies; for special variables, this means the scope that the binding would have had had it been a lexical binding. Unless explicitly stated otherwise, the scope of a free declaration includes only the body subforms of the form at whose head it appears, and no other subforms. The scope of free declarations specifically does not include initialization forms for bindings established by the form containing the declarations. Some iteration forms include step, end-test, or result subforms that are also included in the scope of declarations that appear in the iteration form. Specifically, the iteration forms and subforms involved are: * do, do*: step-forms, end-test-form, and result-forms. * dolist, dotimes: result-form * do-all-symbols, do-external-symbols, do-symbols: result-form * Menu: * Examples of Declaration Scope::  File: gcl.info, Node: Examples of Declaration Scope, Prev: Declaration Scope, Up: Declaration Scope 3.3.4.1 Examples of Declaration Scope ..................................... Here is an example illustrating the scope of bound declarations. (let ((x 1)) ;[1] 1st occurrence of x (declare (special x)) ;[2] 2nd occurrence of x (let ((x 2)) ;[3] 3rd occurrence of x (let ((old-x x) ;[4] 4th occurrence of x (x 3)) ;[5] 5th occurrence of x (declare (special x)) ;[6] 6th occurrence of x (list old-x x)))) ;[7] 7th occurrence of x => (2 3) The first occurrence of x establishes a dynamic binding of x because of the special declaration for x in the second line. The third occurrence of x establishes a lexical binding of x (because there is no special declaration in the corresponding let form). The fourth occurrence of x x is a reference to the lexical binding of x established in the third line. The fifth occurrence of x establishes a dynamic binding of x for the body of the let form that begins on that line because of the special declaration for x in the sixth line. The reference to x in the fourth line is not affected by the special declaration in the sixth line because that reference is not within the "would-be lexical scope" of the variable x in the fifth line. The reference to x in the seventh line is a reference to the dynamic binding of x established in the fifth line. Here is another example, to illustrate the scope of a free declaration. In the following: (lambda (&optional (x (foo 1))) ;[1] (declare (notinline foo)) ;[2] (foo x)) ;[3] the call to foo in the first line might be compiled inline even though the call to foo in the third line must not be. This is because the notinline declaration for foo in the second line applies only to the body on the third line. In order to suppress inlining for both calls, one might write: (locally (declare (notinline foo)) ;[1] (lambda (&optional (x (foo 1))) ;[2] (foo x))) ;[3] or, alternatively: (lambda (&optional ;[1] (x (locally (declare (notinline foo)) ;[2] (foo 1)))) ;[3] (declare (notinline foo)) ;[4] (foo x)) ;[5] Finally, here is an example that shows the scope of declarations in an iteration form. (let ((x 1)) ;[1] (declare (special x)) ;[2] (let ((x 2)) ;[3] (dotimes (i x x) ;[4] (declare (special x))))) ;[5] => 1 In this example, the first reference to x on the fourth line is to the lexical binding of x established on the third line. However, the second occurrence of x on the fourth line lies within the scope of the free declaration on the fifth line (because this is the result-form of the dotimes) and therefore refers to the dynamic binding of x.  File: gcl.info, Node: Lambda Lists, Next: Error Checking in Function Calls, Prev: Declarations, Up: Evaluation and Compilation 3.4 Lambda Lists ================ A lambda list is a list that specifies a set of parameters (sometimes called lambda variables) and a protocol for receiving values for those parameters. There are several kinds of lambda lists. Context Kind of Lambda List defun form ordinary lambda list defmacro form macro lambda list lambda expression ordinary lambda list flet local function definition ordinary lambda list labels local function definition ordinary lambda list handler-case clause specification ordinary lambda list restart-case clause specification ordinary lambda list macrolet local macro definition macro lambda list define-method-combination ordinary lambda list define-method-combination :arguments option define-method-combination arguments lambda list defstruct :constructor option boa lambda list defgeneric form generic function lambda list defgeneric method clause specialized lambda list defmethod form specialized lambda list defsetf form defsetf lambda list define-setf-expander form macro lambda list deftype form deftype lambda list destructuring-bind form destructuring lambda list define-compiler-macro form macro lambda list define-modify-macro form define-modify-macro lambda list Figure 3-10: What Kind of Lambda Lists to Use Figure 3-11 lists some defined names that are applicable to lambda lists. lambda-list-keywords lambda-parameters-limit Figure 3-11: Defined names applicable to lambda lists * Menu: * Ordinary Lambda Lists:: * Generic Function Lambda Lists:: * Specialized Lambda Lists:: * Macro Lambda Lists:: * Destructuring Lambda Lists:: * Boa Lambda Lists:: * Defsetf Lambda Lists:: * Deftype Lambda Lists:: * Define-modify-macro Lambda Lists:: * Define-method-combination Arguments Lambda Lists:: * Syntactic Interaction of Documentation Strings and Declarations::  File: gcl.info, Node: Ordinary Lambda Lists, Next: Generic Function Lambda Lists, Prev: Lambda Lists, Up: Lambda Lists 3.4.1 Ordinary Lambda Lists --------------------------- An ordinary lambda list is used to describe how a set of arguments is received by an ordinary function. The defined names in Figure 3-12 are those which use ordinary lambda lists: define-method-combination handler-case restart-case defun labels flet lambda Figure 3-12: Standardized Operators that use Ordinary Lambda Lists An ordinary lambda list can contain the lambda list keywords shown in Figure 3-13. &allow-other-keys &key &rest &aux &optional Figure 3-13: Lambda List Keywords used by Ordinary Lambda Lists Each element of a lambda list is either a parameter specifier or a lambda list keyword. Implementations are free to provide additional lambda list keywords. For a list of all lambda list keywords used by the implementation, see lambda-list-keywords. The syntax for ordinary lambda lists is as follows: lambda-list ::=({var}* [&optional {var | (var [init-form [supplied-p-parameter ]])}*] [&rest var] [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* pt [&allow-other-keys]] [&aux {var | (var [init-form])}*]) A var or supplied-p-parameter must be a symbol that is not the name of a constant variable. An init-form can be any form. Whenever any init-form is evaluated for any parameter specifier, that form may refer to any parameter variable to the left of the specifier in which the init-form appears, including any supplied-p-parameter variables, and may rely on the fact that no other parameter variable has yet been bound (including its own parameter variable). A keyword-name can be any symbol, but by convention is normally a keyword_1; all standardized functions follow that convention. An ordinary lambda list has five parts, any or all of which may be empty. For information about the treatment of argument mismatches, see *note Error Checking in Function Calls::. * Menu: * Specifiers for the required parameters:: * Specifiers for optional parameters:: * A specifier for a rest parameter:: * Specifiers for keyword parameters:: * Suppressing Keyword Argument Checking:: * Examples of Suppressing Keyword Argument Checking:: * Specifiers for &aux variables:: * Examples of Ordinary Lambda Lists::  File: gcl.info, Node: Specifiers for the required parameters, Next: Specifiers for optional parameters, Prev: Ordinary Lambda Lists, Up: Ordinary Lambda Lists 3.4.1.1 Specifiers for the required parameters .............................................. These are all the parameter specifiers up to the first lambda list keyword; if there are no lambda list keywords, then all the specifiers are for required parameters. Each required parameter is specified by a parameter variable var. var is bound as a lexical variable unless it is declared special. If there are n required parameters (n may be zero), there must be at least n passed arguments, and the required parameters are bound to the first n passed arguments; see *note Error Checking in Function Calls::. The other parameters are then processed using any remaining arguments.  File: gcl.info, Node: Specifiers for optional parameters, Next: A specifier for a rest parameter, Prev: Specifiers for the required parameters, Up: Ordinary Lambda Lists 3.4.1.2 Specifiers for optional parameters .......................................... If &optional is present, the optional parameter specifiers are those following &optional up to the next lambda list keyword or the end of the list. If optional parameters are specified, then each one is processed as follows. If any unprocessed arguments remain, then the parameter variable var is bound to the next remaining argument, just as for a required parameter. If no arguments remain, however, then init-form is evaluated, and the parameter variable is bound to the resulting value (or to nil if no init-form appears in the parameter specifier). If another variable name supplied-p-parameter appears in the specifier, it is bound to true if an argument had been available, and to false if no argument remained (and therefore init-form had to be evaluated). Supplied-p-parameter is bound not to an argument but to a value indicating whether or not an argument had been supplied for the corresponding var.  File: gcl.info, Node: A specifier for a rest parameter, Next: Specifiers for keyword parameters, Prev: Specifiers for optional parameters, Up: Ordinary Lambda Lists 3.4.1.3 A specifier for a rest parameter ........................................ &rest, if present, must be followed by a single rest parameter specifier, which in turn must be followed by another lambda list keyword or the end of the lambda list. After all optional parameter specifiers have been processed, then there may or may not be a rest parameter. If there is a rest parameter, it is bound to a list of all as-yet-unprocessed arguments. If no unprocessed arguments remain, the rest parameter is bound to the empty list. If there is no rest parameter and there are no keyword parameters, then an error should be signaled if any unprocessed arguments remain; see *note Error Checking in Function Calls::. The value of a rest parameter is permitted, but not required, to share structure with the last argument to apply.  File: gcl.info, Node: Specifiers for keyword parameters, Next: Suppressing Keyword Argument Checking, Prev: A specifier for a rest parameter, Up: Ordinary Lambda Lists 3.4.1.4 Specifiers for keyword parameters ......................................... If &key is present, all specifiers up to the next lambda list keyword or the end of the list are keyword parameter specifiers. When keyword parameters are processed, the same arguments are processed that would be made into a list for a rest parameter. It is permitted to specify both &rest and &key. In this case the remaining arguments are used for both purposes; that is, all remaining arguments are made into a list for the rest parameter, and are also processed for the &key parameters. If &key is specified, there must remain an even number of arguments; see *note Odd Number of Keyword Arguments::. These arguments are considered as pairs, the first argument in each pair being interpreted as a name and the second as the corresponding value. The first object of each pair must be a symbol; see *note Invalid Keyword Arguments::. The keyword parameter specifiers may optionally be followed by the lambda list keyword &allow-other-keys. In each keyword parameter specifier must be a name var for the parameter variable. If the var appears alone or in a (var init-form) combination, the keyword name used when matching arguments to parameters is a symbol in the KEYWORD package whose name is the same (under string=) as var's. If the notation ((keyword-name var) init-form) is used, then the keyword name used to match arguments to parameters is keyword-name, which may be a symbol in any package. (Of course, if it is not a symbol in the KEYWORD package, it does not necessarily self-evaluate, so care must be taken when calling the function to make sure that normal evaluation still yields the keyword name.) Thus (defun foo (&key radix (type 'integer)) ...) means exactly the same as (defun foo (&key ((:radix radix)) ((:type type) 'integer)) ...) The keyword parameter specifiers are, like all parameter specifiers, effectively processed from left to right. For each keyword parameter specifier, if there is an argument pair whose name matches that specifier's name (that is, the names are eq), then the parameter variable for that specifier is bound to the second item (the value) of that argument pair. If more than one such argument pair matches, the leftmost argument pair is used. If no such argument pair exists, then the init-form for that specifier is evaluated and the parameter variable is bound to that value (or to nil if no init-form was specified). supplied-p-parameter is treated as for &optional parameters: it is bound to true if there was a matching argument pair, and to false otherwise. Unless keyword argument checking is suppressed, an argument pair must a name matched by a parameter specifier; see *note Unrecognized Keyword Arguments::. If keyword argument checking is suppressed, then it is permitted for an argument pair to match no parameter specifier, and the argument pair is ignored, but such an argument pair is accessible through the rest parameter if one was supplied. The purpose of these mechanisms is to allow sharing of argument lists among several lambda expressions and to allow either the caller or the called lambda expression to specify that such sharing may be taking place. Note that if &key is present, a keyword argument of :allow-other-keys is always permitted--regardless of whether the associated value is true or false. However, if the value is false, other non-matching keywords are not tolerated (unless &allow-other-keys was used). Furthermore, if the receiving argument list specifies a regular argument which would be flagged by :allow-other-keys, then :allow-other-keys has both its special-cased meaning (identifying whether additional keywords are permitted) and its normal meaning (data flow into the function in question).  File: gcl.info, Node: Suppressing Keyword Argument Checking, Next: Examples of Suppressing Keyword Argument Checking, Prev: Specifiers for keyword parameters, Up: Ordinary Lambda Lists 3.4.1.5 Suppressing Keyword Argument Checking ............................................. If &allow-other-keys was specified in the lambda list of a function, keyword_2 argument checking is suppressed in calls to that function. If the :allow-other-keys argument is true in a call to a function, keyword_2 argument checking is suppressed in that call. The :allow-other-keys argument is permissible in all situations involving keyword_2 arguments, even when its associated value is false.  File: gcl.info, Node: Examples of Suppressing Keyword Argument Checking, Next: Specifiers for &aux variables, Prev: Suppressing Keyword Argument Checking, Up: Ordinary Lambda Lists 3.4.1.6 Examples of Suppressing Keyword Argument Checking ......................................................... ;;; The caller can supply :ALLOW-OTHER-KEYS T to suppress checking. ((lambda (&key x) x) :x 1 :y 2 :allow-other-keys t) => 1 ;;; The callee can use &ALLOW-OTHER-KEYS to suppress checking. ((lambda (&key x &allow-other-keys) x) :x 1 :y 2) => 1 ;;; :ALLOW-OTHER-KEYS NIL is always permitted. ((lambda (&key) t) :allow-other-keys nil) => T ;;; As with other keyword arguments, only the left-most pair ;;; named :ALLOW-OTHER-KEYS has any effect. ((lambda (&key x) x) :x 1 :y 2 :allow-other-keys t :allow-other-keys nil) => 1 ;;; Only the left-most pair named :ALLOW-OTHER-KEYS has any effect, ;;; so in safe code this signals a PROGRAM-ERROR (and might enter the ;;; debugger). In unsafe code, the consequences are undefined. ((lambda (&key x) x) ;This call is not valid :x 1 :y 2 :allow-other-keys nil :allow-other-keys t)  File: gcl.info, Node: Specifiers for &aux variables, Next: Examples of Ordinary Lambda Lists, Prev: Examples of Suppressing Keyword Argument Checking, Up: Ordinary Lambda Lists 3.4.1.7 Specifiers for &aux variables ..................................... These are not really parameters. If the lambda list keyword &aux is present, all specifiers after it are auxiliary variable specifiers. After all parameter specifiers have been processed, the auxiliary variable specifiers (those following &aux) are processed from left to right. For each one, init-form is evaluated and var is bound to that value (or to nil if no init-form was specified). &aux variable processing is analogous to let* processing. (lambda (x y &aux (a (car x)) (b 2) c) (list x y a b c)) == (lambda (x y) (let* ((a (car x)) (b 2) c) (list x y a b c)))  File: gcl.info, Node: Examples of Ordinary Lambda Lists, Prev: Specifiers for &aux variables, Up: Ordinary Lambda Lists 3.4.1.8 Examples of Ordinary Lambda Lists ......................................... Here are some examples involving optional parameters and rest parameters: ((lambda (a b) (+ a (* b 3))) 4 5) => 19 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5) => 19 ((lambda (a &optional (b 2)) (+ a (* b 3))) 4) => 10 ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x))) => (2 NIL 3 NIL NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6) => (6 T 3 NIL NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3) => (6 T 3 T NIL) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8) => (6 T 3 T (8)) ((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3 8 9 10 11) => (6 t 3 t (8 9 10 11)) Here are some examples involving keyword parameters: ((lambda (a b &key c d) (list a b c d)) 1 2) => (1 2 NIL NIL) ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6) => (1 2 6 NIL) ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8) => (1 2 NIL 8) ((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8) => (1 2 6 8) ((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6) => (1 2 6 8) ((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6) => (:a 1 6 8) ((lambda (a b &key c d) (list a b c d)) :a :b :c :d) => (:a :b :d NIL) ((lambda (a b &key ((:sea c)) d) (list a b c d)) 1 2 :sea 6) => (1 2 6 NIL) ((lambda (a b &key ((c c)) d) (list a b c d)) 1 2 'c 6) => (1 2 6 NIL) Here are some examples involving optional parameters, rest parameters, and keyword parameters together: ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1) => (1 3 NIL 1 ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 2) => (1 2 NIL 1 ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) :c 7) => (:c 7 NIL :c ()) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :c 7) => (1 6 7 1 (:c 7)) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8) => (1 6 NIL 8 (:d 8)) ((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x)) 1 6 :d 8 :c 9 :d 10) => (1 6 9 8 (:d 8 :c 9 :d 10)) As an example of the use of &allow-other-keys and :allow-other-keys, consider a function that takes two named arguments of its own and also accepts additional named arguments to be passed to make-array: (defun array-of-strings (str dims &rest named-pairs &key (start 0) end &allow-other-keys) (apply #'make-array dims :initial-element (subseq str start end) :allow-other-keys t named-pairs)) This function takes a string and dimensioning information and returns an array of the specified dimensions, each of whose elements is the specified string. However, :start and :end named arguments may be used to specify that a substring of the given string should be used. In addition, the presence of &allow-other-keys in the lambda list indicates that the caller may supply additional named arguments; the rest parameter provides access to them. These additional named arguments are passed to make-array. The function make-array normally does not allow the named arguments :start and :end to be used, and an error should be signaled if such named arguments are supplied to make-array. However, the presence in the call to make-array of the named argument :allow-other-keys with a true value causes any extraneous named arguments, including :start and :end, to be acceptable and ignored.  File: gcl.info, Node: Generic Function Lambda Lists, Next: Specialized Lambda Lists, Prev: Ordinary Lambda Lists, Up: Lambda Lists 3.4.2 Generic Function Lambda Lists ----------------------------------- A generic function lambda list is used to describe the overall shape of the argument list to be accepted by a generic function. Individual method signatures might contribute additional keyword parameters to the lambda list of the effective method. A generic function lambda list is used by defgeneric. A generic function lambda list has the following syntax: lambda-list ::=({var}* [&optional {var | (var)}*] [&rest var] [&key {var | ({var | (keyword-name var)})}* pt [&allow-other-keys]]) A generic function lambda list can contain the lambda list keywords shown in Figure 3-14. &allow-other-keys &optional &key &rest Figure 3-14: Lambda List Keywords used by Generic Function Lambda Lists A generic function lambda list differs from an ordinary lambda list in the following ways: Required arguments Zero or more required parameters must be specified. Optional and keyword arguments Optional parameters and keyword parameters may not have default initial value forms nor use supplied-p parameters. Use of &aux The use of &aux is not allowed.  File: gcl.info, Node: Specialized Lambda Lists, Next: Macro Lambda Lists, Prev: Generic Function Lambda Lists, Up: Lambda Lists 3.4.3 Specialized Lambda Lists ------------------------------ A specialized lambda list is used to specialize a method for a particular signature and to describe how arguments matching that signature are received by the method. The defined names in Figure 3-15 use specialized lambda lists in some way; see the dictionary entry for each for information about how. defmethod defgeneric Figure 3-15: Standardized Operators that use Specialized Lambda Lists A specialized lambda list can contain the lambda list keywords shown in Figure 3-16. &allow-other-keys &key &rest &aux &optional Figure 3-16: Lambda List Keywords used by Specialized Lambda Lists A specialized lambda list is syntactically the same as an ordinary lambda list except that each required parameter may optionally be associated with a class or object for which that parameter is specialized. lambda-list ::=({var | (var [specializer])}* [&optional {var | (var [init-form [supplied-p-parameter]])}*] [&rest var] [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] [&aux {var | (var [init-form])}*])  File: gcl.info, Node: Macro Lambda Lists, Next: Destructuring Lambda Lists, Prev: Specialized Lambda Lists, Up: Lambda Lists 3.4.4 Macro Lambda Lists ------------------------ A macro lambda list is used in describing macros defined by the operators in Figure 3-17. define-compiler-macro defmacro macrolet define-setf-expander Figure 3-17: Operators that use Macro Lambda Lists With the additional restriction that an environment parameter may appear only once (at any of the positions indicated), a macro lambda list has the following syntax: reqvars ::={var | !pattern}* optvars ::=[&optional {var | ({var | !pattern} [init-form [supplied-p-parameter]])}*] restvar ::=[{&rest | &body} {var | !pattern}] keyvars ::=[&key {var | ({var | (keyword-name {var | !pattern})} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] auxvars ::=[&aux {var | (var [init-form])}*] envvar ::=[&environment var] wholevar ::=[&whole var] lambda-list ::=(!wholevar !envvar !reqvars !envvar !optvars !envvar !restvar !envvar !keyvars !envvar !auxvars !envvar) | (!wholevar !envvar !reqvars !envvar !optvars !envvar . var) pattern ::=(!wholevar !reqvars !optvars !restvar !keyvars !auxvars) | (!wholevar !reqvars !optvars . var) A macro lambda list can contain the lambda list keywords shown in Figure 3-18. &allow-other-keys &environment &rest &aux &key &whole &body &optional Figure 3-18: Lambda List Keywords used by Macro Lambda Lists Optional parameters (introduced by &optional) and keyword parameters (introduced by &key) can be supplied in a macro lambda list, just as in an ordinary lambda list. Both may contain default initialization forms and supplied-p parameters. &body is identical in function to &rest, but it can be used to inform certain output-formatting and editing functions that the remainder of the form is treated as a body, and should be indented accordingly. Only one of &body or &rest can be used at any particular level; see *note Destructuring by Lambda Lists::. &body can appear at any level of a macro lambda list; for details, see *note Destructuring by Lambda Lists::. &whole is followed by a single variable that is bound to the entire macro-call form; this is the value that the macro function receives as its first argument. If &whole and a following variable appear, they must appear first in lambda-list, before any other parameter or lambda list keyword. &whole can appear at any level of a macro lambda list. At inner levels, the &whole variable is bound to the corresponding part of the argument, as with &rest, but unlike &rest, other arguments are also allowed. The use of &whole does not affect the pattern of arguments specified. &environment is followed by a single variable that is bound to an environment representing the lexical environment in which the macro call is to be interpreted. This environment should be used with macro-function, get-setf-expansion, compiler-macro-function, and macroexpand (for example) in computing the expansion of the macro, to ensure that any lexical bindings or definitions established in the compilation environment are taken into account. &environment can only appear at the top level of a macro lambda list, and can only appear once, but can appear anywhere in that list; the &environment parameter is bound along with &whole before any other variables in the lambda list, regardless of where &environment appears in the lambda list. The object that is bound to the environment parameter has dynamic extent. Destructuring allows a macro lambda list to express the structure of a macro call syntax. If no lambda list keywords appear, then the macro lambda list is a tree containing parameter names at the leaves. The pattern and the macro form must have compatible tree structure; that is, their tree structure must be equivalent, or it must differ only in that some leaves of the pattern match non-atomic objects of the macro form. For information about error detection in this situation, see *note Destructuring Mismatch::. A destructuring lambda list (whether at top level or embedded) can be dotted, ending in a parameter name. This situation is treated exactly as if the parameter name that ends the list had appeared preceded by &rest. It is permissible for a macro form (or a subexpression of a macro form) to be a dotted list only when (... &rest var) or (... . var) is used to match it. It is the responsibility of the macro to recognize and deal with such situations. [Editorial Note by KMP: Apparently the dotted-macro-forms cleanup doesn't allow for the macro to 'manually' notice dotted forms and fix them as well. It shouldn't be required that this be done only by &REST or a dotted pattern; it should only matter that ultimately the non-macro result of a full-macro expansion not contain dots. Anyway, I plan to address this editorially unless someone raises an objection.] * Menu: * Destructuring by Lambda Lists:: * Data-directed Destructuring by Lambda Lists:: * Examples of Data-directed Destructuring by Lambda Lists:: * Lambda-list-directed Destructuring by Lambda Lists::  File: gcl.info, Node: Destructuring by Lambda Lists, Next: Data-directed Destructuring by Lambda Lists, Prev: Macro Lambda Lists, Up: Macro Lambda Lists 3.4.4.1 Destructuring by Lambda Lists ..................................... Anywhere in a macro lambda list where a parameter name can appear, and where ordinary lambda list syntax (as described in *note Ordinary Lambda Lists::) does not otherwise allow a list, a destructuring lambda list can appear in place of the parameter name. When this is done, then the argument that would match the parameter is treated as a (possibly dotted) list, to be used as an argument list for satisfying the parameters in the embedded lambda list. This is known as destructuring. Destructuring is the process of decomposing a compound object into its component parts, using an abbreviated, declarative syntax, rather than writing it out by hand using the primitive component-accessing functions. Each component part is bound to a variable. A destructuring operation requires an object to be decomposed, a pattern that specifies what components are to be extracted, and the names of the variables whose values are to be the components.  File: gcl.info, Node: Data-directed Destructuring by Lambda Lists, Next: Examples of Data-directed Destructuring by Lambda Lists, Prev: Destructuring by Lambda Lists, Up: Macro Lambda Lists 3.4.4.2 Data-directed Destructuring by Lambda Lists ................................................... In data-directed destructuring, the pattern is a sample object of the type to be decomposed. Wherever a component is to be extracted, a symbol appears in the pattern; this symbol is the name of the variable whose value will be that component.  File: gcl.info, Node: Examples of Data-directed Destructuring by Lambda Lists, Next: Lambda-list-directed Destructuring by Lambda Lists, Prev: Data-directed Destructuring by Lambda Lists, Up: Macro Lambda Lists 3.4.4.3 Examples of Data-directed Destructuring by Lambda Lists ............................................................... An example pattern is (a b c) which destructures a list of three elements. The variable a is assigned to the first element, b to the second, etc. A more complex example is ((first . rest) . more) The important features of data-directed destructuring are its syntactic simplicity and the ability to extend it to lambda-list-directed destructuring.  File: gcl.info, Node: Lambda-list-directed Destructuring by Lambda Lists, Prev: Examples of Data-directed Destructuring by Lambda Lists, Up: Macro Lambda Lists 3.4.4.4 Lambda-list-directed Destructuring by Lambda Lists .......................................................... An extension of data-directed destructuring of trees is lambda-list-directed destructuring. This derives from the analogy between the three-element destructuring pattern (first second third) and the three-argument lambda list (first second third) Lambda-list-directed destructuring is identical to data-directed destructuring if no lambda list keywords appear in the pattern. Any list in the pattern (whether a sub-list or the whole pattern itself) that contains a lambda list keyword is interpreted specially. Elements of the list to the left of the first lambda list keyword are treated as destructuring patterns, as usual, but the remaining elements of the list are treated like a function's lambda list except that where a variable would normally be required, an arbitrary destructuring pattern is allowed. Note that in case of ambiguity, lambda list syntax is preferred over destructuring syntax. Thus, after &optional a list of elements is a list of a destructuring pattern and a default value form. The detailed behavior of each lambda list keyword in a lambda-list-directed destructuring pattern is as follows: &optional Each following element is a variable or a list of a destructuring pattern, a default value form, and a supplied-p variable. The default value and the supplied-p variable can be omitted. If the list being destructured ends early, so that it does not have an element to match against this destructuring (sub)-pattern, the default form is evaluated and destructured instead. The supplied-p variable receives the value nil if the default form is used, t otherwise. &rest, &body The next element is a destructuring pattern that matches the rest of the list. &body is identical to &rest but declares that what is being matched is a list of forms that constitutes the body of form. This next element must be the last unless a lambda list keyword follows it. &aux The remaining elements are not destructuring patterns at all, but are auxiliary variable bindings. &whole The next element is a destructuring pattern that matches the entire form in a macro, or the entire subexpression at inner levels. &key Each following element is one of a variable, or a list of a variable, an optional initialization form, and an optional supplied-p variable. or a list of a list of a keyword and a destructuring pattern, an optional initialization form, and an optional supplied-p variable. The rest of the list being destructured is taken to be alternating keywords and values and is taken apart appropriately. &allow-other-keys Stands by itself.  File: gcl.info, Node: Destructuring Lambda Lists, Next: Boa Lambda Lists, Prev: Macro Lambda Lists, Up: Lambda Lists 3.4.5 Destructuring Lambda Lists -------------------------------- A destructuring lambda list is used by destructuring-bind. Destructuring lambda lists are closely related to macro lambda lists; see *note Macro Lambda Lists::. A destructuring lambda list can contain all of the lambda list keywords listed for macro lambda lists except for &environment, and supports destructuring in the same way. Inner lambda lists nested within a macro lambda list have the syntax of destructuring lambda lists. A destructuring lambda list has the following syntax: reqvars ::={var | !lambda-list}* optvars ::=[&optional {var | ({var | !lambda-list} [init-form [supplied-p-parameter]])}*] restvar ::=[{&rest | &body} {var | !lambda-list}] keyvars ::=[&key {var | ({var | (keyword-name {var | !lambda-list})} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] auxvars ::=[&aux {var | (var [init-form])}*] envvar ::=[&environment var] wholevar ::=[&whole var] lambda-list ::=(!wholevar !reqvars !optvars !restvar !keyvars !auxvars) | (!wholevar !reqvars !optvars . var)  File: gcl.info, Node: Boa Lambda Lists, Next: Defsetf Lambda Lists, Prev: Destructuring Lambda Lists, Up: Lambda Lists 3.4.6 Boa Lambda Lists ---------------------- A boa lambda list is a lambda list that is syntactically like an ordinary lambda list, but that is processed in "by order of argument" style. A boa lambda list is used only in a defstruct form, when explicitly specifying the lambda list of a constructor function (sometimes called a "boa constructor"). The &optional, &rest, &aux, &key, and &allow-other-keys lambda list keywords are recognized in a boa lambda list. The way these lambda list keywords differ from their use in an ordinary lambda list follows. Consider this example, which describes how destruct processes its :constructor option. (:constructor create-foo (a &optional b (c 'sea) &rest d &aux e (f 'eff))) This defines create-foo to be a constructor of one or more arguments. The first argument is used to initialize the a slot. The second argument is used to initialize the b slot. If there isn't any second argument, then the default value given in the body of the defstruct (if given) is used instead. The third argument is used to initialize the c slot. If there isn't any third argument, then the symbol sea is used instead. Any arguments following the third argument are collected into a list and used to initialize the d slot. If there are three or fewer arguments, then nil is placed in the d slot. The e slot is not initialized; its initial value is implementation-defined. Finally, the f slot is initialized to contain the symbol eff. &key and &allow-other-keys arguments default in a manner similar to that of &optional arguments: if no default is supplied in the lambda list then the default value given in the body of the defstruct (if given) is used instead. For example: (defstruct (foo (:constructor CREATE-FOO (a &optional b (c 'sea) &key (d 2) &aux e (f 'eff)))) (a 1) (b 2) (c 3) (d 4) (e 5) (f 6)) (create-foo 10) => #S(FOO A 10 B 2 C SEA D 2 E implemention-dependent F EFF) (create-foo 10 'bee 'see :d 'dee) => #S(FOO A 10 B BEE C SEE D DEE E implemention-dependent F EFF) If keyword arguments of the form ((key var) [default [svar]]) are specified, the slot name is matched with var (not key). The actions taken in the b and e cases were carefully chosen to allow the user to specify all possible behaviors. The &aux variables can be used to completely override the default initializations given in the body. If no default value is supplied for an aux variable variable, the consequences are undefined if an attempt is later made to read the corresponding slot's value before a value is explicitly assigned. If such a slot has a :type option specified, this suppressed initialization does not imply a type mismatch situation; the declared type is only required to apply when the slot is finally assigned. With this definition, the following can be written: (create-foo 1 2) instead of (make-foo :a 1 :b 2) and create-foo provides defaulting different from that of make-foo. Additional arguments that do not correspond to slot names but are merely present to supply values used in subsequent initialization computations are allowed. For example, in the definition (defstruct (frob (:constructor create-frob (a &key (b 3 have-b) (c-token 'c) (c (list c-token (if have-b 7 2)))))) a b c) the c-token argument is used merely to supply a value used in the initialization of the c slot. The supplied-p parameters associated with optional parameters and keyword parameters might also be used this way.  File: gcl.info, Node: Defsetf Lambda Lists, Next: Deftype Lambda Lists, Prev: Boa Lambda Lists, Up: Lambda Lists 3.4.7 Defsetf Lambda Lists -------------------------- A defsetf lambda list is used by defsetf. A defsetf lambda list has the following syntax: lambda-list ::=({var}* [&optional {var | (var [init-form [supplied-p-parameter]])}*] [&rest var] [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* pt [&allow-other-keys]] [&environment var] A defsetf lambda list can contain the lambda list keywords shown in Figure 3-19. &allow-other-keys &key &rest &environment &optional Figure 3-19: Lambda List Keywords used by Defsetf Lambda Lists A defsetf lambda list differs from an ordinary lambda list only in that it does not permit the use of &aux, and that it permits use of &environment, which introduces an environment parameter.  File: gcl.info, Node: Deftype Lambda Lists, Next: Define-modify-macro Lambda Lists, Prev: Defsetf Lambda Lists, Up: Lambda Lists 3.4.8 Deftype Lambda Lists -------------------------- A deftype lambda list is used by deftype. A deftype lambda list has the same syntax as a macro lambda list, and can therefore contain the lambda list keywords as a macro lambda list. A deftype lambda list differs from a macro lambda list only in that if no init-form is supplied for an optional parameter or keyword parameter in the lambda-list, the default value for that parameter is the symbol * (rather than nil).  File: gcl.info, Node: Define-modify-macro Lambda Lists, Next: Define-method-combination Arguments Lambda Lists, Prev: Deftype Lambda Lists, Up: Lambda Lists 3.4.9 Define-modify-macro Lambda Lists -------------------------------------- A define-modify-macro lambda list is used by define-modify-macro. A define-modify-macro lambda list can contain the lambda list keywords shown in Figure 3-20. &optional &rest Figure 3-20: Lambda List Keywords used by Define-modify-macro Lambda Lists Define-modify-macro lambda lists are similar to ordinary lambda lists, but do not support keyword arguments. define-modify-macro has no need match keyword arguments, and a rest parameter is sufficient. Aux variables are also not supported, since define-modify-macro has no body forms which could refer to such bindings. See the macro define-modify-macro.  File: gcl.info, Node: Define-method-combination Arguments Lambda Lists, Next: Syntactic Interaction of Documentation Strings and Declarations, Prev: Define-modify-macro Lambda Lists, Up: Lambda Lists 3.4.10 Define-method-combination Arguments Lambda Lists ------------------------------------------------------- A define-method-combination arguments lambda list is used by the :arguments option to define-method-combination. A define-method-combination arguments lambda list can contain the lambda list keywords shown in Figure 3-21. &allow-other-keys &key &rest &aux &optional &whole Figure 3-21: Lambda List Keywords used by Define-method-combination arguments Lambda Lists Define-method-combination arguments lambda lists are similar to ordinary lambda lists, but also permit the use of &whole.  File: gcl.info, Node: Syntactic Interaction of Documentation Strings and Declarations, Prev: Define-method-combination Arguments Lambda Lists, Up: Lambda Lists 3.4.11 Syntactic Interaction of Documentation Strings and Declarations ---------------------------------------------------------------------- In a number of situations, a documentation string can appear amidst a series of declare expressions prior to a series of forms. In that case, if a string S appears where a documentation string is permissible and is not followed by either a declare expression or a form then S is taken to be a form; otherwise, S is taken as a documentation string. The consequences are unspecified if more than one such documentation string is present.  File: gcl.info, Node: Error Checking in Function Calls, Next: Traversal Rules and Side Effects, Prev: Lambda Lists, Up: Evaluation and Compilation 3.5 Error Checking in Function Calls ==================================== * Menu: * Argument Mismatch Detection::  File: gcl.info, Node: Argument Mismatch Detection, Prev: Error Checking in Function Calls, Up: Error Checking in Function Calls 3.5.1 Argument Mismatch Detection --------------------------------- * Menu: * Safe and Unsafe Calls:: * Error Detection Time in Safe Calls:: * Too Few Arguments:: * Too Many Arguments:: * Unrecognized Keyword Arguments:: * Invalid Keyword Arguments:: * Odd Number of Keyword Arguments:: * Destructuring Mismatch:: * Errors When Calling a Next Method::  File: gcl.info, Node: Safe and Unsafe Calls, Next: Error Detection Time in Safe Calls, Prev: Argument Mismatch Detection, Up: Argument Mismatch Detection 3.5.1.1 Safe and Unsafe Calls ............................. A call is a safe call if each of the following is either safe code or system code (other than system code that results from macro expansion of programmer code): * the call. * the definition of the function being called. * the point of functional evaluation The following special cases require some elaboration: * If the function being called is a generic function, it is considered safe if all of the following are safe code or system code: - its definition (if it was defined explicitly). - the method definitions for all applicable methods. - the definition of its method combination. * For the form (coerce x 'function), where x is a lambda expression, the value of the optimize quality safety in the global environment at the time the coerce is executed applies to the resulting function. * For a call to the function ensure-generic-function, the value of the optimize quality safety in the environment object passed as the :environment argument applies to the resulting generic function. * For a call to compile with a lambda expression as the argument, the value of the optimize quality safety in the global environment at the time compile is called applies to the resulting compiled function. * For a call to compile with only one argument, if the original definition of the function was safe, then the resulting compiled function must also be safe. * A call to a method by call-next-method must be considered safe if each of the following is safe code or system code: - the definition of the generic function (if it was defined explicitly). - the method definitions for all applicable methods. - the definition of the method combination. - the point of entry into the body of the method defining form, where the binding of call-next-method is established. - the point of functional evaluation of the name call-next-method. An unsafe call is a call that is not a safe call. The informal intent is that the programmer can rely on a call to be safe, even when system code is involved, if all reasonable steps have been taken to ensure that the call is safe. For example, if a programmer calls mapcar from safe code and supplies a function that was compiled as safe, the implementation is required to ensure that mapcar makes a safe call as well.  File: gcl.info, Node: Error Detection Time in Safe Calls, Next: Too Few Arguments, Prev: Safe and Unsafe Calls, Up: Argument Mismatch Detection 3.5.1.2 Error Detection Time in Safe Calls .......................................... If an error is signaled in a safe call, the exact point of the signal is implementation-dependent. In particular, it might be signaled at compile time or at run time, and if signaled at run time, it might be prior to, during, or after executing the call. However, it is always prior to the execution of the body of the function being called.  File: gcl.info, Node: Too Few Arguments, Next: Too Many Arguments, Prev: Error Detection Time in Safe Calls, Up: Argument Mismatch Detection 3.5.1.3 Too Few Arguments ......................... It is not permitted to supply too few arguments to a function. Too few arguments means fewer arguments than the number of required parameters for the function. If this situation occurs in a safe call, an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Too Many Arguments, Next: Unrecognized Keyword Arguments, Prev: Too Few Arguments, Up: Argument Mismatch Detection 3.5.1.4 Too Many Arguments .......................... It is not permitted to supply too many arguments to a function. Too many arguments means more arguments than the number of required parameters plus the number of optional parameters; however, if the function uses &rest or &key, it is not possible for it to receive too many arguments. If this situation occurs in a safe call, an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Unrecognized Keyword Arguments, Next: Invalid Keyword Arguments, Prev: Too Many Arguments, Up: Argument Mismatch Detection 3.5.1.5 Unrecognized Keyword Arguments ...................................... It is not permitted to supply a keyword argument to a function using a name that is not recognized by that function unless keyword argument checking is suppressed as described in *note Suppressing Keyword Argument Checking::. If this situation occurs in a safe call, an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Invalid Keyword Arguments, Next: Odd Number of Keyword Arguments, Prev: Unrecognized Keyword Arguments, Up: Argument Mismatch Detection 3.5.1.6 Invalid Keyword Arguments ................................. It is not permitted to supply a keyword argument to a function using a name that is not a symbol. If this situation occurs in a safe call, an error of type program-error must be signaled unless keyword argument checking is suppressed as described in *note Suppressing Keyword Argument Checking::; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Odd Number of Keyword Arguments, Next: Destructuring Mismatch, Prev: Invalid Keyword Arguments, Up: Argument Mismatch Detection 3.5.1.7 Odd Number of Keyword Arguments ....................................... An odd number of arguments must not be supplied for the keyword parameters. If this situation occurs in a safe call, an error of type program-error must be signaled unless keyword argument checking is suppressed as described in *note Suppressing Keyword Argument Checking::; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Destructuring Mismatch, Next: Errors When Calling a Next Method, Prev: Odd Number of Keyword Arguments, Up: Argument Mismatch Detection 3.5.1.8 Destructuring Mismatch .............................. When matching a destructuring lambda list against a form, the pattern and the form must have compatible tree structure, as described in *note Macro Lambda Lists::. Otherwise, in a safe call, an error of type program-error must be signaled; and in an unsafe call the situation has undefined consequences.  File: gcl.info, Node: Errors When Calling a Next Method, Prev: Destructuring Mismatch, Up: Argument Mismatch Detection 3.5.1.9 Errors When Calling a Next Method ......................................... If call-next-method is called with arguments, the ordered set of applicable methods for the changed set of arguments for call-next-method must be the same as the ordered set of applicable methods for the original arguments to the generic function, or else an error should be signaled. The comparison between the set of methods applicable to the new arguments and the set applicable to the original arguments is insensitive to order differences among methods with the same specializers. If call-next-method is called with arguments that specify a different ordered set of applicable methods and there is no next method available, the test for different methods and the associated error signaling (when present) takes precedence over calling no-next-method.  File: gcl.info, Node: Traversal Rules and Side Effects, Next: Destructive Operations, Prev: Error Checking in Function Calls, Up: Evaluation and Compilation 3.6 Traversal Rules and Side Effects ==================================== The consequences are undefined when code executed during an object-traversing operation destructively modifies the object in a way that might affect the ongoing traversal operation. In particular, the following rules apply. List traversal For list traversal operations, the cdr chain of the list is not allowed to be destructively modified. Array traversal For array traversal operations, the array is not allowed to be adjusted and its fill pointer, if any, is not allowed to be changed. Hash-table traversal For hash table traversal operations, new elements may not be added or deleted except that the element corresponding to the current hash key may be changed or removed. Package traversal For package traversal operations (e.g., do-symbols), new symbols may not be interned in or uninterned from the package being traversed or any package that it uses except that the current symbol may be uninterned from the package being traversed.  File: gcl.info, Node: Destructive Operations, Next: Evaluation and Compilation Dictionary, Prev: Traversal Rules and Side Effects, Up: Evaluation and Compilation 3.7 Destructive Operations ========================== * Menu: * Modification of Literal Objects:: * Transfer of Control during a Destructive Operation::  File: gcl.info, Node: Modification of Literal Objects, Next: Transfer of Control during a Destructive Operation, Prev: Destructive Operations, Up: Destructive Operations 3.7.1 Modification of Literal Objects ------------------------------------- The consequences are undefined if literal objects are destructively modified. For this purpose, the following operations are considered destructive: random-state Using it as an argument to the function random. cons Changing the car_1 or cdr_1 of the cons, or performing a destructive operation on an object which is either the car_2 or the cdr_2 of the cons. array Storing a new value into some element of the array, or performing a destructive operation on an object that is already such an element. Changing the fill pointer, dimensions, or displacement of the array (regardless of whether the array is actually adjustable). Performing a destructive operation on another array that is displaced to the array or that otherwise shares its contents with the array. hash-table Performing a destructive operation on any key. Storing a new value_4 for any key, or performing a destructive operation on any object that is such a value. Adding or removing entries from the hash table. structure-object Storing a new value into any slot, or performing a destructive operation on an object that is the value of some slot. standard-object Storing a new value into any slot, or performing a destructive operation on an object that is the value of some slot. Changing the class of the object (e.g., using the function change-class). readtable Altering the readtable case. Altering the syntax type of any character in this readtable. Altering the reader macro function associated with any character in the readtable, or altering the reader macro functions associated with characters defined as dispatching macro characters in the readtable. stream Performing I/O operations on the stream, or closing the stream. All other standardized types [This category includes, for example, character, condition, function, method-combination, method, number, package, pathname, restart, and symbol.] There are no standardized destructive operations defined on objects of these types.  File: gcl.info, Node: Transfer of Control during a Destructive Operation, Prev: Modification of Literal Objects, Up: Destructive Operations 3.7.2 Transfer of Control during a Destructive Operation -------------------------------------------------------- Should a transfer of control out of a destructive operation occur (e.g., due to an error) the state of the object being modified is implementation-dependent. * Menu: * Examples of Transfer of Control during a Destructive Operation::  File: gcl.info, Node: Examples of Transfer of Control during a Destructive Operation, Prev: Transfer of Control during a Destructive Operation, Up: Transfer of Control during a Destructive Operation 3.7.2.1 Examples of Transfer of Control during a Destructive Operation ...................................................................... The following examples illustrate some of the many ways in which the implementation-dependent nature of the modification can manifest itself. (let ((a (list 2 1 4 3 7 6 'five))) (ignore-errors (sort a #'<)) a) => (1 2 3 4 6 7 FIVE) OR=> (2 1 4 3 7 6 FIVE) OR=> (2) (prog foo ((a (list 1 2 3 4 5 6 7 8 9 10))) (sort a #'(lambda (x y) (if (zerop (random 5)) (return-from foo a) (> x y))))) => (1 2 3 4 5 6 7 8 9 10) OR=> (3 4 5 6 2 7 8 9 10 1) OR=> (1 2 4 3)  File: gcl.info, Node: Evaluation and Compilation Dictionary, Prev: Destructive Operations, Up: Evaluation and Compilation 3.8 Evaluation and Compilation Dictionary ========================================= * Menu: * lambda (Symbol):: * lambda:: * compile:: * eval:: * eval-when:: * load-time-value:: * quote:: * compiler-macro-function:: * define-compiler-macro:: * defmacro:: * macro-function:: * macroexpand:: * define-symbol-macro:: * symbol-macrolet:: * *macroexpand-hook*:: * proclaim:: * declaim:: * declare:: * ignore:: * dynamic-extent:: * type:: * inline:: * ftype:: * declaration:: * optimize:: * special:: * locally:: * the:: * special-operator-p:: * constantp::  File: gcl.info, Node: lambda (Symbol), Next: lambda, Prev: Evaluation and Compilation Dictionary, Up: Evaluation and Compilation Dictionary 3.8.1 lambda [Symbol] --------------------- Syntax:: ........ 'lambda' lambda-list [[{declaration}* | documentation]] {form}* Arguments:: ........... lambda-list--an ordinary lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. Description:: ............. A lambda expression is a list that can be used in place of a function name in certain contexts to denote a function by directly describing its behavior rather than indirectly by referring to the name of an established function. Documentation is attached to the denoted function (if any is actually created) as a documentation string. See Also:: .......... function, *note documentation:: , *note Lambda Expressions::, *note Lambda Forms::, *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... The lambda form ((lambda lambda-list . body) . arguments) is semantically equivalent to the function form (funcall #'(lambda lambda-list . body) . arguments)  File: gcl.info, Node: lambda, Next: compile, Prev: lambda (Symbol), Up: Evaluation and Compilation Dictionary 3.8.2 lambda [Macro] -------------------- 'lambda' lambda-list [[{declaration}* | documentation]] {form}* => function Arguments and Values:: ...................... lambda-list--an ordinary lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. function--a function. Description:: ............. Provides a shorthand notation for a function special form involving a lambda expression such that: (lambda lambda-list [[{declaration}* | documentation]] {form}*) == (function (lambda lambda-list [[{declaration}* | documentation]] {form}*)) == #'(lambda lambda-list [[{declaration}* | documentation]] {form}*) Examples:: .......... (funcall (lambda (x) (+ x 3)) 4) => 7 See Also:: .......... lambda (symbol) Notes:: ....... This macro could be implemented by: (defmacro lambda (&whole form &rest bvl-decls-and-body) (declare (ignore bvl-decls-and-body)) `#',form)  File: gcl.info, Node: compile, Next: eval, Prev: lambda, Up: Evaluation and Compilation Dictionary 3.8.3 compile [Function] ------------------------ 'compile' name &optional definition => function, warnings-p, failure-p Arguments and Values:: ...................... name--a function name, or nil. definition--a lambda expression or a function. The default is the function definition of name if it names a function, or the macro function of name if it names a macro. The consequences are undefined if no definition is supplied when the name is nil. function--the function-name, or a compiled function. warnings-p--a generalized boolean. failure-p--a generalized boolean. Description:: ............. Compiles an interpreted function. compile produces a compiled function from definition. If the definition is a lambda expression, it is coerced to a function. If the definition is already a compiled function, compile either produces that function itself (i.e., is an identity operation) or an equivalent function. [Editorial Note by KMP: There are a number of ambiguities here that still need resolution.] If the name is nil, the resulting compiled function is returned directly as the primary value. If a non-nil name is given, then the resulting compiled function replaces the existing function definition of name and the name is returned as the primary value; if name is a symbol that names a macro, its macro function is updated and the name is returned as the primary value. Literal objects appearing in code processed by the compile function are neither copied nor coalesced. The code resulting from the execution of compile references objects that are eql to the corresponding objects in the source code. compile is permitted, but not required, to establish a handler for conditions of type error. For example, the handler might issue a warning and restart compilation from some implementation-dependent point in order to let the compilation proceed without manual intervention. The secondary value, warnings-p, is false if no conditions of type error or warning were detected by the compiler, and true otherwise. The tertiary value, failure-p, is false if no conditions of type error or warning (other than style-warning) were detected by the compiler, and true otherwise. Examples:: .......... (defun foo () "bar") => FOO (compiled-function-p #'foo) => implementation-dependent (compile 'foo) => FOO (compiled-function-p #'foo) => true (setf (symbol-function 'foo) (compile nil '(lambda () "replaced"))) => # (foo) => "replaced" Affected By:: ............. *error-output*, *macroexpand-hook*. The presence of macro definitions and proclamations. Exceptional Situations:: ........................ The consequences are undefined if the lexical environment surrounding the function to be compiled contains any bindings other than those for macros, symbol macros, or declarations. For information about errors detected during the compilation process, see *note Exceptional Situations in the Compiler::. See Also:: .......... *note compile-file::  File: gcl.info, Node: eval, Next: eval-when, Prev: compile, Up: Evaluation and Compilation Dictionary 3.8.4 eval [Function] --------------------- 'eval' form => {result}* Arguments and Values:: ...................... form--a form. results--the values yielded by the evaluation of form. Description:: ............. Evaluates form in the current dynamic environment and the null lexical environment. eval is a user interface to the evaluator. The evaluator expands macro calls as if through the use of macroexpand-1. Constants appearing in code processed by eval are not copied nor coalesced. The code resulting from the execution of eval references objects that are eql to the corresponding objects in the source code. Examples:: .......... (setq form '(1+ a) a 999) => 999 (eval form) => 1000 (eval 'form) => (1+ A) (let ((a '(this would break if eval used local value))) (eval form)) => 1000 See Also:: .......... macroexpand-1, *note The Evaluation Model:: Notes:: ....... To obtain the current dynamic value of a symbol, use of symbol-value is equivalent (and usually preferable) to use of eval. Note that an eval form involves two levels of evaluation for its argument. First, form is evaluated by the normal argument evaluation mechanism as would occur with any call. The object that results from this normal argument evaluation becomes the value of the form parameter, and is then evaluated as part of the eval form. For example: (eval (list 'cdr (car '((quote (a . b)) c)))) => b The argument form (list 'cdr (car '((quote (a . b)) c))) is evaluated in the usual way to produce the argument (cdr (quote (a . b))); eval then evaluates its argument, (cdr (quote (a . b))), to produce b. Since a single evaluation already occurs for any argument form in any function form, eval is sometimes said to perform "an extra level of evaluation."  File: gcl.info, Node: eval-when, Next: load-time-value, Prev: eval, Up: Evaluation and Compilation Dictionary 3.8.5 eval-when [Special Operator] ---------------------------------- 'eval-when' ({situation}*) {form}* => {result}* Arguments and Values:: ...................... situation--One of the symbols :compile-toplevel , :load-toplevel , :execute , compile , load , or eval . The use of eval, compile, and load is deprecated. forms--an implicit progn. results--the values of the forms if they are executed, or nil if they are not. Description:: ............. The body of an eval-when form is processed as an implicit progn, but only in the situations listed. The use of the situations :compile-toplevel (or compile) and :load-toplevel (or load) controls whether and when evaluation occurs when eval-when appears as a top level form in code processed by compile-file. See *note File Compilation::. The use of the situation :execute (or eval) controls whether evaluation occurs for other eval-when forms; that is, those that are not top level forms, or those in code processed by eval or compile. If the :execute situation is specified in such a form, then the body forms are processed as an implicit progn; otherwise, the eval-when form returns nil. eval-when normally appears as a top level form, but it is meaningful for it to appear as a non-top-level form. However, the compile-time side effects described in *note Compilation:: only take place when eval-when appears as a top level form. Examples:: .......... One example of the use of eval-when is that for the compiler to be able to read a file properly when it uses user-defined reader macros, it is necessary to write (eval-when (:compile-toplevel :load-toplevel :execute) (set-macro-character #\$ #'(lambda (stream char) (declare (ignore char)) (list 'dollar (read stream))))) => T This causes the call to set-macro-character to be executed in the compiler's execution environment, thereby modifying its reader syntax table. ;;; The EVAL-WHEN in this case is not at toplevel, so only the :EXECUTE ;;; keyword is considered. At compile time, this has no effect. ;;; At load time (if the LET is at toplevel), or at execution time ;;; (if the LET is embedded in some other form which does not execute ;;; until later) this sets (SYMBOL-FUNCTION 'FOO1) to a function which ;;; returns 1. (let ((x 1)) (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo1) #'(lambda () x)))) ;;; If this expression occurs at the toplevel of a file to be compiled, ;;; it has BOTH a compile time AND a load-time effect of setting ;;; (SYMBOL-FUNCTION 'FOO2) to a function which returns 2. (eval-when (:execute :load-toplevel :compile-toplevel) (let ((x 2)) (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo2) #'(lambda () x))))) ;;; If this expression occurs at the toplevel of a file to be compiled, ;;; it has BOTH a compile time AND a load-time effect of setting the ;;; function cell of FOO3 to a function which returns 3. (eval-when (:execute :load-toplevel :compile-toplevel) (setf (symbol-function 'foo3) #'(lambda () 3))) ;;; #4: This always does nothing. It simply returns NIL. (eval-when (:compile-toplevel) (eval-when (:compile-toplevel) (print 'foo4))) ;;; If this form occurs at toplevel of a file to be compiled, FOO5 is ;;; printed at compile time. If this form occurs in a non-top-level ;;; position, nothing is printed at compile time. Regardless of context, ;;; nothing is ever printed at load time or execution time. (eval-when (:compile-toplevel) (eval-when (:execute) (print 'foo5))) ;;; If this form occurs at toplevel of a file to be compiled, FOO6 is ;;; printed at compile time. If this form occurs in a non-top-level ;;; position, nothing is printed at compile time. Regardless of context, ;;; nothing is ever printed at load time or execution time. (eval-when (:execute :load-toplevel) (eval-when (:compile-toplevel) (print 'foo6))) See Also:: .......... *note compile-file:: , *note Compilation:: Notes:: ....... The following effects are logical consequences of the definition of eval-when: * Execution of a single eval-when expression executes the body code at most once. * Macros intended for use in top level forms should be written so that side-effects are done by the forms in the macro expansion. The macro-expander itself should not do the side-effects. For example: Wrong: (defmacro foo () (really-foo) `(really-foo)) Right: (defmacro foo () `(eval-when (:compile-toplevel :execute :load-toplevel) (really-foo))) Adherence to this convention means that such macros behave intuitively when appearing as non-top-level forms. * Placing a variable binding around an eval-when reliably captures the binding because the compile-time-too mode cannot occur (i.e., introducing a variable binding means that the eval-when is not a top level form). For example, (let ((x 3)) (eval-when (:execute :load-toplevel :compile-toplevel) (print x))) prints 3 at execution (i.e., load) time, and does not print anything at compile time. This is important so that expansions of defun and defmacro can be done in terms of eval-when and can correctly capture the lexical environment. (defun bar (x) (defun foo () (+ x 3))) might expand into (defun bar (x) (progn (eval-when (:compile-toplevel) (compiler::notice-function-definition 'foo '(x))) (eval-when (:execute :load-toplevel) (setf (symbol-function 'foo) #'(lambda () (+ x 3)))))) which would be treated by the above rules the same as (defun bar (x) (setf (symbol-function 'foo) #'(lambda () (+ x 3)))) when the definition of bar is not a top level form.  File: gcl.info, Node: load-time-value, Next: quote, Prev: eval-when, Up: Evaluation and Compilation Dictionary 3.8.6 load-time-value [Special Operator] ---------------------------------------- 'load-time-value' form &optional read-only-p => object Arguments and Values:: ...................... form--a form; evaluated as described below. read-only-p--a boolean; not evaluated. object--the primary value resulting from evaluating form. Description:: ............. load-time-value provides a mechanism for delaying evaluation of form until the expression is in the run-time environment; see *note Compilation::. Read-only-p designates whether the result can be considered a constant object. If t, the result is a read-only quantity that can, if appropriate to the implementation, be copied into read-only space and/or coalesced with similar constant objects from other programs. If nil (the default), the result must be neither copied nor coalesced; it must be considered to be potentially modifiable data. If a load-time-value expression is processed by compile-file, the compiler performs its normal semantic processing (such as macro expansion and translation into machine code) on form, but arranges for the execution of form to occur at load time in a null lexical environment, with the result of this evaluation then being treated as a literal object at run time. It is guaranteed that the evaluation of form will take place only once when the file is loaded, but the order of evaluation with respect to the evaluation of top level forms in the file is implementation-dependent. If a load-time-value expression appears within a function compiled with compile, the form is evaluated at compile time in a null lexical environment. The result of this compile-time evaluation is treated as a literal object in the compiled code. If a load-time-value expression is processed by eval, form is evaluated in a null lexical environment, and one value is returned. Implementations that implicitly compile (or partially compile) expressions processed by eval might evaluate form only once, at the time this compilation is performed. If the same list (load-time-value form) is evaluated or compiled more than once, it is implementation-dependent whether form is evaluated only once or is evaluated more than once. This can happen both when an expression being evaluated or compiled shares substructure, and when the same form is processed by eval or compile multiple times. Since a load-time-value expression can be referenced in more than one place and can be evaluated multiple times by eval, it is implementation-dependent whether each execution returns a fresh object or returns the same object as some other execution. Users must use caution when destructively modifying the resulting object. If two lists (load-time-value form) that are the same under equal but are not identical are evaluated or compiled, their values always come from distinct evaluations of form. Their values may not be coalesced unless read-only-p is t. Examples:: .......... ;;; The function INCR1 always returns the same value, even in different images. ;;; The function INCR2 always returns the same value in a given image, ;;; but the value it returns might vary from image to image. (defun incr1 (x) (+ x #.(random 17))) (defun incr2 (x) (+ x (load-time-value (random 17)))) ;;; The function FOO1-REF references the nth element of the first of ;;; the *FOO-ARRAYS* that is available at load time. It is permissible for ;;; that array to be modified (e.g., by SET-FOO1-REF); FOO1-REF will see the ;;; updated values. (defvar *foo-arrays* (list (make-array 7) (make-array 8))) (defun foo1-ref (n) (aref (load-time-value (first *my-arrays*) nil) n)) (defun set-foo1-ref (n val) (setf (aref (load-time-value (first *my-arrays*) nil) n) val)) ;;; The function BAR1-REF references the nth element of the first of ;;; the *BAR-ARRAYS* that is available at load time. The programmer has ;;; promised that the array will be treated as read-only, so the system ;;; can copy or coalesce the array. (defvar *bar-arrays* (list (make-array 7) (make-array 8))) (defun bar1-ref (n) (aref (load-time-value (first *my-arrays*) t) n)) ;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced ;;; even though NIL was specified, because the object was already read-only ;;; when it was written as a literal vector rather than created by a constructor. ;;; User programs must treat the vector v as read-only. (defun baz-ref (n) (let ((v (load-time-value #(A B C) nil))) (values (svref v n) v))) ;;; This use of LOAD-TIME-VALUE permits the indicated vector to be coalesced ;;; even though NIL was specified in the outer situation because T was specified ;;; in the inner situation. User programs must treat the vector v as read-only. (defun baz-ref (n) (let ((v (load-time-value (load-time-value (vector 1 2 3) t) nil))) (values (svref v n) v))) See Also:: .......... *note compile-file:: , *note compile:: , *note eval:: , *note Minimal Compilation::, *note Compilation:: Notes:: ....... load-time-value must appear outside of quoted structure in a "for evaluation" position. In situations which would appear to call for use of load-time-value within a quoted structure, the backquote reader macro is probably called for; see *note Backquote::. Specifying nil for read-only-p is not a way to force an object to become modifiable if it has already been made read-only. It is only a way to say that, for an object that is modifiable, this operation is not intended to make that object read-only.  File: gcl.info, Node: quote, Next: compiler-macro-function, Prev: load-time-value, Up: Evaluation and Compilation Dictionary 3.8.7 quote [Special Operator] ------------------------------ 'quote' object => object Arguments and Values:: ...................... object--an object; not evaluated. Description:: ............. The quote special operator just returns object. The consequences are undefined if literal objects (including quoted objects) are destructively modified. Examples:: .......... (setq a 1) => 1 (quote (setq a 3)) => (SETQ A 3) a => 1 'a => A ''a => (QUOTE A) '''a => (QUOTE (QUOTE A)) (setq a 43) => 43 (list a (cons a 3)) => (43 (43 . 3)) (list (quote a) (quote (cons a 3))) => (A (CONS A 3)) 1 => 1 '1 => 1 "foo" => "foo" '"foo" => "foo" (car '(a b)) => A '(car '(a b)) => (CAR (QUOTE (A B))) #(car '(a b)) => #(CAR (QUOTE (A B))) '#(car '(a b)) => #(CAR (QUOTE (A B))) See Also:: .......... *note Evaluation::, *note Single-Quote::, *note Compiler Terminology:: Notes:: ....... The textual notation 'object is equivalent to (quote object); see *note Compiler Terminology::. Some objects, called self-evaluating objects, do not require quotation by quote. However, symbols and lists are used to represent parts of programs, and so would not be useable as constant data in a program without quote. Since quote suppresses the evaluation of these objects, they become data rather than program.  File: gcl.info, Node: compiler-macro-function, Next: define-compiler-macro, Prev: quote, Up: Evaluation and Compilation Dictionary 3.8.8 compiler-macro-function [Accessor] ---------------------------------------- 'compiler-macro-function' name &optional environment => function (setf (' compiler-macro-function' name &optional environment) new-function) Arguments and Values:: ...................... name--a function name. environment--an environment object. function, new-function--a compiler macro function, or nil. Description:: ............. Accesses the compiler macro function named name, if any, in the environment. A value of nil denotes the absence of a compiler macro function named name. Exceptional Situations:: ........................ The consequences are undefined if environment is non-nil in a use of setf of compiler-macro-function. See Also:: .......... *note define-compiler-macro:: , *note Compiler Macros::  File: gcl.info, Node: define-compiler-macro, Next: defmacro, Prev: compiler-macro-function, Up: Evaluation and Compilation Dictionary 3.8.9 define-compiler-macro [Macro] ----------------------------------- 'define-compiler-macro' name lambda-list [[{declaration}* | documentation]] {form}* => name Arguments and Values:: ...................... name--a function name. lambda-list--a macro lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. Description:: ............. [Editorial Note by KMP: This definition probably needs to be fully expanded to not refer through the definition of defmacro, but should suffice for now.] This is the normal mechanism for defining a compiler macro function. Its manner of definition is the same as for defmacro; the only differences are: * The name can be a function name naming any function or macro. * The expander function is installed as a compiler macro function for the name, rather than as a macro function. * The &whole argument is bound to the form argument that is passed to the compiler macro function. The remaining lambda-list parameters are specified as if this form contained the function name in the car and the actual arguments in the cdr, but if the car of the actual form is the symbol funcall, then the destructuring of the arguments is actually performed using its cddr instead. * Documentation is attached as a documentation string to name (as kind compiler-macro) and to the compiler macro function. * Unlike an ordinary macro, a compiler macro can decline to provide an expansion merely by returning a form that is the same as the original (which can be obtained by using &whole). Examples:: .......... (defun square (x) (expt x 2)) => SQUARE (define-compiler-macro square (&whole form arg) (if (atom arg) `(expt ,arg 2) (case (car arg) (square (if (= (length arg) 2) `(expt ,(nth 1 arg) 4) form)) (expt (if (= (length arg) 3) (if (numberp (nth 2 arg)) `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg))) `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg)))) form)) (otherwise `(expt ,arg 2))))) => SQUARE (square (square 3)) => 81 (macroexpand '(square x)) => (SQUARE X), false (funcall (compiler-macro-function 'square) '(square x) nil) => (EXPT X 2) (funcall (compiler-macro-function 'square) '(square (square x)) nil) => (EXPT X 4) (funcall (compiler-macro-function 'square) '(funcall #'square x) nil) => (EXPT X 2) (defun distance-positional (x1 y1 x2 y2) (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))) => DISTANCE-POSITIONAL (defun distance (&key (x1 0) (y1 0) (x2 x1) (y2 y1)) (distance-positional x1 y1 x2 y2)) => DISTANCE (define-compiler-macro distance (&whole form &rest key-value-pairs &key (x1 0 x1-p) (y1 0 y1-p) (x2 x1 x2-p) (y2 y1 y2-p) &allow-other-keys &environment env) (flet ((key (n) (nth (* n 2) key-value-pairs)) (arg (n) (nth (1+ (* n 2)) key-value-pairs)) (simplep (x) (let ((expanded-x (macroexpand x env))) (or (constantp expanded-x env) (symbolp expanded-x))))) (let ((n (/ (length key-value-pairs) 2))) (multiple-value-bind (x1s y1s x2s y2s others) (loop for (key) on key-value-pairs by #'cddr count (eq key ':x1) into x1s count (eq key ':y1) into y1s count (eq key ':x2) into x2s count (eq key ':y1) into y2s count (not (member key '(:x1 :x2 :y1 :y2))) into others finally (return (values x1s y1s x2s y2s others))) (cond ((and (= n 4) (eq (key 0) :x1) (eq (key 1) :y1) (eq (key 2) :x2) (eq (key 3) :y2)) `(distance-positional ,x1 ,y1 ,x2 ,y2)) ((and (if x1-p (and (= x1s 1) (simplep x1)) t) (if y1-p (and (= y1s 1) (simplep y1)) t) (if x2-p (and (= x2s 1) (simplep x2)) t) (if y2-p (and (= y2s 1) (simplep y2)) t) (zerop others)) `(distance-positional ,x1 ,y1 ,x2 ,y2)) ((and (< x1s 2) (< y1s 2) (< x2s 2) (< y2s 2) (zerop others)) (let ((temps (loop repeat n collect (gensym)))) `(let ,(loop for i below n collect (list (nth i temps) (arg i))) (distance ,@(loop for i below n append (list (key i) (nth i temps))))))) (t form)))))) => DISTANCE (dolist (form '((distance :x1 (setq x 7) :x2 (decf x) :y1 (decf x) :y2 (decf x)) (distance :x1 (setq x 7) :y1 (decf x) :x2 (decf x) :y2 (decf x)) (distance :x1 (setq x 7) :y1 (incf x)) (distance :x1 (setq x 7) :y1 (incf x) :x1 (incf x)) (distance :x1 a1 :y1 b1 :x2 a2 :y2 b2) (distance :x1 a1 :x2 a2 :y1 b1 :y2 b2) (distance :x1 a1 :y1 b1 :z1 c1 :x2 a2 :y2 b2 :z2 c2))) (print (funcall (compiler-macro-function 'distance) form nil))) |> (LET ((#:G6558 (SETQ X 7)) |> (#:G6559 (DECF X)) |> (#:G6560 (DECF X)) |> (#:G6561 (DECF X))) |> (DISTANCE :X1 #:G6558 :X2 #:G6559 :Y1 #:G6560 :Y2 #:G6561)) |> (DISTANCE-POSITIONAL (SETQ X 7) (DECF X) (DECF X) (DECF X)) |> (LET ((#:G6567 (SETQ X 7)) |> (#:G6568 (INCF X))) |> (DISTANCE :X1 #:G6567 :Y1 #:G6568)) |> (DISTANCE :X1 (SETQ X 7) :Y1 (INCF X) :X1 (INCF X)) |> (DISTANCE-POSITIONAL A1 B1 A2 B2) |> (DISTANCE-POSITIONAL A1 B1 A2 B2) |> (DISTANCE :X1 A1 :Y1 B1 :Z1 C1 :X2 A2 :Y2 B2 :Z2 C2) => NIL See Also:: .......... *note compiler-macro-function:: , *note defmacro:: , *note documentation:: , *note Syntactic Interaction of Documentation Strings and Declarations:: Notes:: ....... The consequences of writing a compiler macro definition for a function in the COMMON-LISP package are undefined; it is quite possible that in some implementations such an attempt would override an equivalent or equally important definition. In general, it is recommended that a programmer only write compiler macro definitions for functions he or she personally maintains-writing a compiler macro definition for a function maintained elsewhere is normally considered a violation of traditional rules of modularity and data abstraction.  File: gcl.info, Node: defmacro, Next: macro-function, Prev: define-compiler-macro, Up: Evaluation and Compilation Dictionary 3.8.10 defmacro [Macro] ----------------------- 'defmacro' name lambda-list [[{declaration}* | documentation]] {form}* => name Arguments and Values:: ...................... name--a symbol. lambda-list--a macro lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. Description:: ............. Defines name as a macro by associating a macro function with that name in the global environment. The macro function is defined in the same lexical environment in which the defmacro form appears. The parameter variables in lambda-list are bound to destructured portions of the macro call. The expansion function accepts two arguments, a form and an environment. The expansion function returns a form. The body of the expansion function is specified by forms. Forms are executed in order. The value of the last form executed is returned as the expansion of the macro. The body forms of the expansion function (but not the lambda-list) are implicitly enclosed in a block whose name is name. The lambda-list conforms to the requirements described in *note Macro Lambda Lists::. Documentation is attached as a documentation string to name (as kind function) and to the macro function. defmacro can be used to redefine a macro or to replace a function definition with a macro definition. Recursive expansion of the form returned must terminate, including the expansion of other macros which are subforms of other forms returned. The consequences are undefined if the result of fully macroexpanding a form contains any circular list structure except in literal objects. If a defmacro form appears as a top level form, the compiler must store the macro definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Users must ensure that the body of the macro can be evaluated at compile time if it is referenced within the file being compiled. Examples:: .......... (defmacro mac1 (a b) "Mac1 multiplies and adds" `(+ ,a (* ,b 3))) => MAC1 (mac1 4 5) => 19 (documentation 'mac1 'function) => "Mac1 multiplies and adds" (defmacro mac2 (&optional (a 2 b) (c 3 d) &rest x) `'(,a ,b ,c ,d ,x)) => MAC2 (mac2 6) => (6 T 3 NIL NIL) (mac2 6 3 8) => (6 T 3 T (8)) (defmacro mac3 (&whole r a &optional (b 3) &rest x &key c (d a)) `'(,r ,a ,b ,c ,d ,x)) => MAC3 (mac3 1 6 :d 8 :c 9 :d 10) => ((MAC3 1 6 :D 8 :C 9 :D 10) 1 6 9 8 (:D 8 :C 9 :D 10)) The stipulation that an embedded destructuring lambda list is permitted only where ordinary lambda list syntax would permit a parameter name but not a list is made to prevent ambiguity. For example, the following is not valid: (defmacro loser (x &optional (a b &rest c) &rest z) ...) because ordinary lambda list syntax does permit a list following &optional; the list (a b &rest c) would be interpreted as describing an optional parameter named a whose default value is that of the form b, with a supplied-p parameter named &rest (not valid), and an extraneous symbol c in the list (also not valid). An almost correct way to express this is (defmacro loser (x &optional ((a b &rest c)) &rest z) ...) The extra set of parentheses removes the ambiguity. However, the definition is now incorrect because a macro call such as (loser (car pool)) would not provide any argument form for the lambda list (a b &rest c), and so the default value against which to match the lambda list would be nil because no explicit default value was specified. The consequences of this are unspecified since the empty list, nil, does not have forms to satisfy the parameters a and b. The fully correct definition would be either (defmacro loser (x &optional ((a b &rest c) '(nil nil)) &rest z) ...) or (defmacro loser (x &optional ((&optional a b &rest c)) &rest z) ...) These differ slightly: the first requires that if the macro call specifies a explicitly then it must also specify b explicitly, whereas the second does not have this requirement. For example, (loser (car pool) ((+ x 1))) would be a valid call for the second definition but not for the first. (defmacro dm1a (&whole x) `',x) (macroexpand '(dm1a)) => (QUOTE (DM1A)) (macroexpand '(dm1a a)) is an error. (defmacro dm1b (&whole x a &optional b) `'(,x ,a ,b)) (macroexpand '(dm1b)) is an error. (macroexpand '(dm1b q)) => (QUOTE ((DM1B Q) Q NIL)) (macroexpand '(dm1b q r)) => (QUOTE ((DM1B Q R) Q R)) (macroexpand '(dm1b q r s)) is an error. (defmacro dm2a (&whole form a b) `'(form ,form a ,a b ,b)) (macroexpand '(dm2a x y)) => (QUOTE (FORM (DM2A X Y) A X B Y)) (dm2a x y) => (FORM (DM2A X Y) A X B Y) (defmacro dm2b (&whole form a (&whole b (c . d) &optional (e 5)) &body f &environment env) ``(,',form ,,a ,',b ,',(macroexpand c env) ,',d ,',e ,',f)) ;Note that because backquote is involved, implementations may differ ;slightly in the nature (though not the functionality) of the expansion. (macroexpand '(dm2b x1 (((incf x2) x3 x4)) x5 x6)) => (LIST* '(DM2B X1 (((INCF X2) X3 X4)) X5 X6) X1 '((((INCF X2) X3 X4)) (SETQ X2 (+ X2 1)) (X3 X4) 5 (X5 X6))), T (let ((x1 5)) (macrolet ((segundo (x) `(cadr ,x))) (dm2b x1 (((segundo x2) x3 x4)) x5 x6))) => ((DM2B X1 (((SEGUNDO X2) X3 X4)) X5 X6) 5 (((SEGUNDO X2) X3 X4)) (CADR X2) (X3 X4) 5 (X5 X6)) See Also:: .......... *note define-compiler-macro:: , *note destructuring-bind:: , *note documentation:: , *note macroexpand:: , *macroexpand-hook*, macrolet, *note macro-function:: , *note Evaluation::, *note Compilation::, *note Syntactic Interaction of Documentation Strings and Declarations::  File: gcl.info, Node: macro-function, Next: macroexpand, Prev: defmacro, Up: Evaluation and Compilation Dictionary 3.8.11 macro-function [Accessor] -------------------------------- 'macro-function' symbol &optional environment => function (setf (' macro-function' symbol &optional environment) new-function) Arguments and Values:: ...................... symbol--a symbol. environment--an environment object. function--a macro function or nil. new-function--a macro function. Description:: ............. Determines whether symbol has a function definition as a macro in the specified environment. If so, the macro expansion function, a function of two arguments, is returned. If symbol has no function definition in the lexical environment environment, or its definition is not a macro, macro-function returns nil. It is possible for both macro-function and special-operator-p to return true of symbol. The macro definition must be available for use by programs that understand only the standard Common Lisp special forms. Examples:: .......... (defmacro macfun (x) '(macro-function 'macfun)) => MACFUN (not (macro-function 'macfun)) => false (macrolet ((foo (&environment env) (if (macro-function 'bar env) ''yes ''no))) (list (foo) (macrolet ((bar () :beep)) (foo)))) => (NO YES) Affected By:: ............. (setf macro-function), defmacro, and macrolet. Exceptional Situations:: ........................ The consequences are undefined if environment is non-nil in a use of setf of macro-function. See Also:: .......... *note defmacro:: , *note Evaluation:: Notes:: ....... setf can be used with macro-function to install a macro as a symbol's global function definition: (setf (macro-function symbol) fn) The value installed must be a function that accepts two arguments, the entire macro call and an environment, and computes the expansion for that call. Performing this operation causes symbol to have only that macro definition as its global function definition; any previous definition, whether as a macro or as a function, is lost.  File: gcl.info, Node: macroexpand, Next: define-symbol-macro, Prev: macro-function, Up: Evaluation and Compilation Dictionary 3.8.12 macroexpand, macroexpand-1 [Function] -------------------------------------------- 'macroexpand' form &optional env => expansion, expanded-p 'macroexpand-' 1 => form &optional env expansion, expanded-p Arguments and Values:: ...................... form--a form. env--an environment object. The default is nil. expansion--a form. expanded-p--a generalized boolean. Description:: ............. macroexpand and macroexpand-1 expand macros. If form is a macro form, then macroexpand-1 expands the macro form call once. macroexpand repeatedly expands form until it is no longer a macro form. In effect, macroexpand calls macroexpand-1 repeatedly until the secondary value it returns is nil. If form is a macro form, then the expansion is a macro expansion and expanded-p is true. Otherwise, the expansion is the given form and expanded-p is false. Macro expansion is carried out as follows. Once macroexpand-1 has determined that the form is a macro form, it obtains an appropriate expansion function for the macro or symbol macro. The value of *macroexpand-hook* is coerced to a function and then called as a function of three arguments: the expansion function, the form, and the env. The value returned from this call is taken to be the expansion of the form. In addition to macro definitions in the global environment, any local macro definitions established within env by macrolet or symbol-macrolet are considered. If only form is supplied as an argument, then the environment is effectively null, and only global macro definitions as established by defmacro are considered. Macro definitions are shadowed by local function definitions. Examples:: .......... (defmacro alpha (x y) `(beta ,x ,y)) => ALPHA (defmacro beta (x y) `(gamma ,x ,y)) => BETA (defmacro delta (x y) `(gamma ,x ,y)) => EPSILON (defmacro expand (form &environment env) (multiple-value-bind (expansion expanded-p) (macroexpand form env) `(values ',expansion ',expanded-p))) => EXPAND (defmacro expand-1 (form &environment env) (multiple-value-bind (expansion expanded-p) (macroexpand-1 form env) `(values ',expansion ',expanded-p))) => EXPAND-1 ;; Simple examples involving just the global environment (macroexpand-1 '(alpha a b)) => (BETA A B), true (expand-1 (alpha a b)) => (BETA A B), true (macroexpand '(alpha a b)) => (GAMMA A B), true (expand (alpha a b)) => (GAMMA A B), true (macroexpand-1 'not-a-macro) => NOT-A-MACRO, false (expand-1 not-a-macro) => NOT-A-MACRO, false (macroexpand '(not-a-macro a b)) => (NOT-A-MACRO A B), false (expand (not-a-macro a b)) => (NOT-A-MACRO A B), false ;; Examples involving lexical environments (macrolet ((alpha (x y) `(delta ,x ,y))) (macroexpand-1 '(alpha a b))) => (BETA A B), true (macrolet ((alpha (x y) `(delta ,x ,y))) (expand-1 (alpha a b))) => (DELTA A B), true (macrolet ((alpha (x y) `(delta ,x ,y))) (macroexpand '(alpha a b))) => (GAMMA A B), true (macrolet ((alpha (x y) `(delta ,x ,y))) (expand (alpha a b))) => (GAMMA A B), true (macrolet ((beta (x y) `(epsilon ,x ,y))) (expand (alpha a b))) => (EPSILON A B), true (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (expand a))) => (FIRST X), true (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (macroexpand 'a))) => A, false (symbol-macrolet ((b (alpha x y))) (expand-1 b)) => (ALPHA X Y), true (symbol-macrolet ((b (alpha x y))) (expand b)) => (GAMMA X Y), true (symbol-macrolet ((b (alpha x y)) (a b)) (expand-1 a)) => B, true (symbol-macrolet ((b (alpha x y)) (a b)) (expand a)) => (GAMMA X Y), true ;; Examples of shadowing behavior (flet ((beta (x y) (+ x y))) (expand (alpha a b))) => (BETA A B), true (macrolet ((alpha (x y) `(delta ,x ,y))) (flet ((alpha (x y) (+ x y))) (expand (alpha a b)))) => (ALPHA A B), false (let ((x (list 1 2 3))) (symbol-macrolet ((a (first x))) (let ((a x)) (expand a)))) => A, false Affected By:: ............. defmacro, setf of macro-function, macrolet, symbol-macrolet See Also:: .......... *macroexpand-hook*, *note defmacro:: , *note setf:: of *note macro-function:: , macrolet, *note symbol-macrolet:: , *note Evaluation:: Notes:: ....... Neither macroexpand nor macroexpand-1 makes any explicit attempt to expand macro forms that are either subforms of the form or subforms of the expansion. Such expansion might occur implicitly, however, due to the semantics or implementation of the macro function.  File: gcl.info, Node: define-symbol-macro, Next: symbol-macrolet, Prev: macroexpand, Up: Evaluation and Compilation Dictionary 3.8.13 define-symbol-macro [Macro] ---------------------------------- 'define-symbol-macro' symbol expansion => symbol Arguments and Values:: ...................... symbol--a symbol. expansion--a form. Description:: ............. Provides a mechanism for globally affecting the macro expansion of the indicated symbol. Globally establishes an expansion function for the symbol macro named by symbol. The only guaranteed property of an expansion function for a symbol macro is that when it is applied to the form and the environment it returns the correct expansion. (In particular, it is implementation-dependent whether the expansion is conceptually stored in the expansion function, the environment, or both.) Each global reference to symbol (i.e., not shadowed_2 by a binding for a variable or symbol macro named by the same symbol) is expanded by the normal macro expansion process; see *note Symbols as Forms::. The expansion of a symbol macro is subject to further macro expansion in the same lexical environment as the symbol macro reference, exactly analogous to normal macros. The consequences are unspecified if a special declaration is made for symbol while in the scope of this definition (i.e., when it is not shadowed_2 by a binding for a variable or symbol macro named by the same symbol). Any use of setq to set the value of the symbol while in the scope of this definition is treated as if it were a setf. psetq of symbol is treated as if it were a psetf, and multiple-value-setq is treated as if it were a setf of values. A binding for a symbol macro can be shadowed_2 by let or symbol-macrolet. Examples:: .......... (defvar *things* (list 'alpha 'beta 'gamma)) => *THINGS* (define-symbol-macro thing1 (first *things*)) => THING1 (define-symbol-macro thing2 (second *things*)) => THING2 (define-symbol-macro thing3 (third *things*)) => THING3 thing1 => ALPHA (setq thing1 'ONE) => ONE *things* => (ONE BETA GAMMA) (multiple-value-setq (thing2 thing3) (values 'two 'three)) => TWO thing3 => THREE *things* => (ONE TWO THREE) (list thing2 (let ((thing2 2)) thing2)) => (TWO 2) Exceptional Situations:: ........................ If symbol is already defined as a global variable, an error of type program-error is signaled. See Also:: .......... *note symbol-macrolet:: , *note macroexpand::  File: gcl.info, Node: symbol-macrolet, Next: *macroexpand-hook*, Prev: define-symbol-macro, Up: Evaluation and Compilation Dictionary 3.8.14 symbol-macrolet [Special Operator] ----------------------------------------- 'symbol-macrolet' ({(symbol expansion )}*) {declaration}* {form}* => {result}* Arguments and Values:: ...................... symbol--a symbol. expansion--a form. declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values returned by the forms. Description:: ............. symbol-macrolet provides a mechanism for affecting the macro expansion environment for symbols. symbol-macrolet lexically establishes expansion functions for each of the symbol macros named by symbols. The only guaranteed property of an expansion function for a symbol macro is that when it is applied to the form and the environment it returns the correct expansion. (In particular, it is implementation-dependent whether the expansion is conceptually stored in the expansion function, the environment, or both.) Each reference to symbol as a variable within the lexical scope of symbol-macrolet is expanded by the normal macro expansion process; see *note Symbols as Forms::. The expansion of a symbol macro is subject to further macro expansion in the same lexical environment as the symbol macro invocation, exactly analogous to normal macros. Exactly the same declarations are allowed as for let with one exception: symbol-macrolet signals an error if a special declaration names one of the symbols being defined by symbol-macrolet. When the forms of the symbol-macrolet form are expanded, any use of setq to set the value of one of the specified variables is treated as if it were a setf. psetq of a symbol defined as a symbol macro is treated as if it were a psetf, and multiple-value-setq is treated as if it were a setf of values. The use of symbol-macrolet can be shadowed by let. In other words, symbol-macrolet only substitutes for occurrences of symbol that would be in the scope of a lexical binding of symbol surrounding the forms. Examples:: .......... ;;; The following is equivalent to ;;; (list 'foo (let ((x 'bar)) x)), ;;; not ;;; (list 'foo (let (('foo 'bar)) 'foo)) (symbol-macrolet ((x 'foo)) (list x (let ((x 'bar)) x))) => (foo bar) NOT=> (foo foo) (symbol-macrolet ((x '(foo x))) (list x)) => ((FOO X)) Exceptional Situations:: ........................ If an attempt is made to bind a symbol that is defined as a global variable, an error of type program-error is signaled. If declaration contains a special declaration that names one of the symbols being bound by symbol-macrolet, an error of type program-error is signaled. See Also:: .......... *note with-slots:: , *note macroexpand:: Notes:: ....... The special form symbol-macrolet is the basic mechanism that is used to implement with-slots. If a symbol-macrolet form is a top level form, the forms are also processed as top level forms. See *note File Compilation::.  File: gcl.info, Node: *macroexpand-hook*, Next: proclaim, Prev: symbol-macrolet, Up: Evaluation and Compilation Dictionary 3.8.15 *macroexpand-hook* [Variable] ------------------------------------ Value Type:: ............ a designator for a function of three arguments: a macro function, a macro form, and an environment object. Initial Value:: ............... a designator for a function that is equivalent to the function funcall, but that might have additional implementation-dependent side-effects. Description:: ............. Used as the expansion interface hook by macroexpand-1 to control the macro expansion process. When a macro form is to be expanded, this function is called with three arguments: the macro function, the macro form, and the environment in which the macro form is to be expanded. The environment object has dynamic extent; the consequences are undefined if the environment object is referred to outside the dynamic extent of the macro expansion function. Examples:: .......... (defun hook (expander form env) (format t "Now expanding: ~S~ (funcall expander form env)) => HOOK (defmacro machook (x y) `(/ (+ ,x ,y) 2)) => MACHOOK (macroexpand '(machook 1 2)) => (/ (+ 1 2) 2), true (let ((*macroexpand-hook* #'hook)) (macroexpand '(machook 1 2))) |> Now expanding (MACHOOK 1 2) => (/ (+ 1 2) 2), true See Also:: .......... *note macroexpand:: , macroexpand-1, *note funcall:: , *note Evaluation:: Notes:: ....... The net effect of the chosen initial value is to just invoke the macro function, giving it the macro form and environment as its two arguments. Users or user programs can assign this variable to customize or trace the macro expansion mechanism. Note, however, that this variable is a global resource, potentially shared by multiple programs; as such, if any two programs depend for their correctness on the setting of this variable, those programs may not be able to run in the same Lisp image. For this reason, it is frequently best to confine its uses to debugging situations. Users who put their own function into *macroexpand-hook* should consider saving the previous value of the hook, and calling that value from their own.  File: gcl.info, Node: proclaim, Next: declaim, Prev: *macroexpand-hook*, Up: Evaluation and Compilation Dictionary 3.8.16 proclaim [Function] -------------------------- 'proclaim' declaration-specifier => implementation-dependent Arguments and Values:: ...................... declaration-specifier--a declaration specifier. Description:: ............. Establishes the declaration specified by declaration-specifier in the global environment. Such a declaration, sometimes called a global declaration or a proclamation, is always in force unless locally shadowed. Names of variables and functions within declaration-specifier refer to dynamic variables and global function definitions, respectively. Figure 3-22 shows a list of declaration identifiers that can be used with proclaim. declaration inline optimize type ftype notinline special Figure 3-22: Global Declaration Specifiers An implementation is free to support other (implementation-defined) declaration identifiers as well. Examples:: .......... (defun declare-variable-types-globally (type vars) (proclaim `(type ,type ,@vars)) type) ;; Once this form is executed, the dynamic variable *TOLERANCE* ;; must always contain a float. (declare-variable-types-globally 'float '(*tolerance*)) => FLOAT See Also:: .......... *note declaim:: , declare, *note Compilation:: Notes:: ....... Although the execution of a proclaim form has effects that might affect compilation, the compiler does not make any attempt to recognize and specially process proclaim forms. A proclamation such as the following, even if a top level form, does not have any effect until it is executed: (proclaim '(special *x*)) If compile time side effects are desired, eval-when may be useful. For example: (eval-when (:execute :compile-toplevel :load-toplevel) (proclaim '(special *x*))) In most such cases, however, it is preferrable to use declaim for this purpose. Since proclaim forms are ordinary function forms, macro forms can expand into them.  File: gcl.info, Node: declaim, Next: declare, Prev: proclaim, Up: Evaluation and Compilation Dictionary 3.8.17 declaim [Macro] ---------------------- 'declaim' {declaration-specifier}* => implementation-dependent Arguments and Values:: ...................... declaration-specifier--a declaration specifier; not evaluated. Description:: ............. Establishes the declarations specified by the declaration-specifiers. If a use of this macro appears as a top level form in a file being processed by the file compiler, the proclamations are also made at compile-time. As with other defining macros, it is unspecified whether or not the compile-time side-effects of a declaim persist after the file has been compiled. Examples:: .......... See Also:: .......... declare, *note proclaim::  File: gcl.info, Node: declare, Next: ignore, Prev: declaim, Up: Evaluation and Compilation Dictionary 3.8.18 declare [Symbol] ----------------------- Syntax:: ........ 'declare' {declaration-specifier}* Arguments:: ........... declaration-specifier--a declaration specifier; not evaluated. Description:: ............. A declare expression, sometimes called a declaration, can occur only at the beginning of the bodies of certain forms; that is, it may be preceded only by other declare expressions, or by a documentation string if the context permits. A declare expression can occur in a lambda expression or in any of the forms listed in Figure 3-23. defgeneric do-external-symbols prog define-compiler-macro do-symbols prog* define-method-combination dolist restart-case define-setf-expander dotimes symbol-macrolet defmacro flet with-accessors defmethod handler-case with-hash-table-iterator defsetf labels with-input-from-string deftype let with-open-file defun let* with-open-stream destructuring-bind locally with-output-to-string do macrolet with-package-iterator do* multiple-value-bind with-slots do-all-symbols pprint-logical-block Figure 3-23: Standardized Forms In Which Declarations Can Occur A declare expression can only occur where specified by the syntax of these forms. The consequences of attempting to evaluate a declare expression are undefined. In situations where such expressions can appear, explicit checks are made for their presence and they are never actually evaluated; it is for this reason that they are called "declare expressions" rather than "declare forms." Macro forms cannot expand into declarations; declare expressions must appear as actual subexpressions of the form to which they refer. Figure 3-24 shows a list of declaration identifiers that can be used with declare. dynamic-extent ignore optimize ftype inline special ignorable notinline type Figure 3-24: Local Declaration Specifiers An implementation is free to support other (implementation-defined) declaration identifiers as well. Examples:: .......... (defun nonsense (k x z) (foo z x) ;First call to foo (let ((j (foo k x)) ;Second call to foo (x (* k k))) (declare (inline foo) (special x z)) (foo x j z))) ;Third call to foo In this example, the inline declaration applies only to the third call to foo, but not to the first or second ones. The special declaration of x causes let to make a dynamic binding for x, and causes the reference to x in the body of let to be a dynamic reference. The reference to x in the second call to foo is a local reference to the second parameter of nonsense. The reference to x in the first call to foo is a local reference, not a special one. The special declaration of z causes the reference to z in the third call to foo to be a dynamic reference; it does not refer to the parameter to nonsense named z, because that parameter binding has not been declared to be special. (The special declaration of z does not appear in the body of defun, but in an inner form, and therefore does not affect the binding of the parameter.) Exceptional Situations:: ........................ The consequences of trying to use a declare expression as a form to be evaluated are undefined. [Editorial Note by KMP: Probably we need to say something here about ill-formed declare expressions.] See Also:: .......... *note proclaim:: , *note Type Specifiers::, declaration, dynamic-extent, ftype, ignorable, ignore, inline, notinline, optimize, type  File: gcl.info, Node: ignore, Next: dynamic-extent, Prev: declare, Up: Evaluation and Compilation Dictionary 3.8.19 ignore, ignorable [Declaration] -------------------------------------- Syntax:: ........ (ignore {var | (function fn)}*) (ignorable {var | (function fn)}*) Arguments:: ........... var--a variable name. fn--a function name. Valid Context:: ............... declaration Binding Types Affected:: ........................ variable, function Description:: ............. The ignore and ignorable declarations refer to for-value references to variable bindings for the vars and to function bindings for the fns. An ignore declaration specifies that for-value references to the indicated bindings will not occur within the scope of the declaration. Within the scope of such a declaration, it is desirable for a compiler to issue a warning about the presence of either a for-value reference to any var or fn, or a special declaration for any var. An ignorable declaration specifies that for-value references to the indicated bindings might or might not occur within the scope of the declaration. Within the scope of such a declaration, it is not desirable for a compiler to issue a warning about the presence or absence of either a for-value reference to any var or fn, or a special declaration for any var. When not within the scope of a ignore or ignorable declaration, it is desirable for a compiler to issue a warning about any var for which there is neither a for-value reference nor a special declaration, or about any fn for which there is no for-value reference. Any warning about a "used" or "unused" binding must be of type style-warning, and may not affect program semantics. The stream variables established by with-open-file, with-open-stream, with-input-from-string, and with-output-to-string, and all iteration variables are, by definition, always "used". Using (declare (ignore v)), for such a variable v has unspecified consequences. See Also:: .......... declare  File: gcl.info, Node: dynamic-extent, Next: type, Prev: ignore, Up: Evaluation and Compilation Dictionary 3.8.20 dynamic-extent [Declaration] ----------------------------------- Syntax:: ........ (dynamic-extent [[{var}* | (function fn)*]]) Arguments:: ........... var--a variable name. fn--a function name. Valid Context:: ............... declaration Binding Types Affected:: ........................ variable, function Description:: ............. In some containing form, F, this declaration asserts for each var_i (which need not be bound by F), and for each value v_{ij} that var_i takes on, and for each object x_{ijk} that is an otherwise inaccessible part of v_{ij} at any time when v_{ij} becomes the value of var_i, that just after the execution of F terminates, x_{ijk} is either inaccessible (if F established a binding for var_i) or still an otherwise inaccessible part of the current value of var_i (if F did not establish a binding for var_i). The same relation holds for each fn_i, except that the bindings are in the function namespace. The compiler is permitted to use this information in any way that is appropriate to the implementation and that does not conflict with the semantics of Common Lisp. dynamic-extent declarations can be free declarations or bound declarations. The vars and fns named in a dynamic-extent declaration must not refer to symbol macro or macro bindings. Examples:: .......... Since stack allocation of the initial value entails knowing at the object's creation time that the object can be stack-allocated, it is not generally useful to make a dynamic-extent declaration for variables which have no lexically apparent initial value. For example, it is probably useful to write: (defun f () (let ((x (list 1 2 3))) (declare (dynamic-extent x)) ...)) This would permit those compilers that wish to do so to stack allocate the list held by the local variable x. It is permissible, but in practice probably not as useful, to write: (defun g (x) (declare (dynamic-extent x)) ...) (defun f () (g (list 1 2 3))) Most compilers would probably not stack allocate the argument to g in f because it would be a modularity violation for the compiler to assume facts about g from within f. Only an implementation that was willing to be responsible for recompiling f if the definition of g changed incompatibly could legitimately stack allocate the list argument to g in f. Here is another example: (declaim (inline g)) (defun g (x) (declare (dynamic-extent x)) ...) (defun f () (g (list 1 2 3))) (defun f () (flet ((g (x) (declare (dynamic-extent x)) ...)) (g (list 1 2 3)))) In the previous example, some compilers might determine that optimization was possible and others might not. A variant of this is the so-called "stack allocated rest list" that can be achieved (in implementations supporting the optimization) by: (defun f (&rest x) (declare (dynamic-extent x)) ...) Note that although the initial value of x is not explicit, the f function is responsible for assembling the list x from the passed arguments, so the f function can be optimized by the compiler to construct a stack-allocated list instead of a heap-allocated list in implementations that support such. In the following example, (let ((x (list 'a1 'b1 'c1)) (y (cons 'a2 (cons 'b2 (cons 'c2 nil))))) (declare (dynamic-extent x y)) ...) The otherwise inaccessible parts of x are three conses, and the otherwise inaccessible parts of y are three other conses. None of the symbols a1, b1, c1, a2, b2, c2, or nil is an otherwise inaccessible part of x or y because each is interned and hence accessible by the package (or packages) in which it is interned. However, if a freshly allocated uninterned symbol had been used, it would have been an otherwise inaccessible part of the list which contained it. ;; In this example, the implementation is permitted to stack allocate ;; the list that is bound to X. (let ((x (list 1 2 3))) (declare (dynamic-extent x)) (print x) :done) |> (1 2 3) => :DONE ;; In this example, the list to be bound to L can be stack-allocated. (defun zap (x y z) (do ((l (list x y z) (cdr l))) ((null l)) (declare (dynamic-extent l)) (prin1 (car l)))) => ZAP (zap 1 2 3) |> 123 => NIL ;; Some implementations might open-code LIST-ALL-PACKAGES in a way ;; that permits using stack allocation of the list to be bound to L. (do ((l (list-all-packages) (cdr l))) ((null l)) (declare (dynamic-extent l)) (let ((name (package-name (car l)))) (when (string-search "COMMON-LISP" name) (print name)))) |> "COMMON-LISP" |> "COMMON-LISP-USER" => NIL ;; Some implementations might have the ability to stack allocate ;; rest lists. A declaration such as the following should be a cue ;; to such implementations that stack-allocation of the rest list ;; would be desirable. (defun add (&rest x) (declare (dynamic-extent x)) (apply #'+ x)) => ADD (add 1 2 3) => 6 (defun zap (n m) ;; Computes (RANDOM (+ M 1)) at relative speed of roughly O(N). ;; It may be slow, but with a good compiler at least it ;; doesn't waste much heap storage. :-} (let ((a (make-array n))) (declare (dynamic-extent a)) (dotimes (i n) (declare (dynamic-extent i)) (setf (aref a i) (random (+ i 1)))) (aref a m))) => ZAP (< (zap 5 3) 3) => true The following are in error, since the value of x is used outside of its extent: (length (list (let ((x (list 1 2 3))) ; Invalid (declare (dynamic-extent x)) x))) (progn (let ((x (list 1 2 3))) ; Invalid (declare (dynamic-extent x)) x) nil) See Also:: .......... declare Notes:: ....... The most common optimization is to stack allocate the initial value of the objects named by the vars. It is permissible for an implementation to simply ignore this declaration.  File: gcl.info, Node: type, Next: inline, Prev: dynamic-extent, Up: Evaluation and Compilation Dictionary 3.8.21 type [Declaration] ------------------------- Syntax:: ........ (type typespec {var}*) (typespec {var}*) Arguments:: ........... typespec--a type specifier. var--a variable name. Valid Context:: ............... declaration or proclamation Binding Types Affected:: ........................ variable Description:: ............. Affects only variable bindings and specifies that the vars take on values only of the specified typespec. In particular, values assigned to the variables by setq, as well as the initial values of the vars must be of the specified typespec. type declarations never apply to function bindings (see ftype). A type declaration of a symbol defined by symbol-macrolet is equivalent to wrapping a the expression around the expansion of that symbol, although the symbol's macro expansion is not actually affected. The meaning of a type declaration is equivalent to changing each reference to a variable (var) within the scope of the declaration to (the typespec var), changing each expression assigned to the variable (new-value) within the scope of the declaration to (the typespec new-value), and executing (the typespec var) at the moment the scope of the declaration is entered. A type declaration is valid in all declarations. The interpretation of a type declaration is as follows: 1. During the execution of any reference to the declared variable within the scope of the declaration, the consequences are undefined if the value of the declared variable is not of the declared type. 2. During the execution of any setq of the declared variable within the scope of the declaration, the consequences are undefined if the newly assigned value of the declared variable is not of the declared type. 3. At the moment the scope of the declaration is entered, the consequences are undefined if the value of the declared variable is not of the declared type. A type declaration affects only variable references within its scope. If nested type declarations refer to the same variable, then the value of the variable must be a member of the intersection of the declared types. If there is a local type declaration for a dynamic variable, and there is also a global type proclamation for that same variable, then the value of the variable within the scope of the local declaration must be a member of the intersection of the two declared types. type declarations can be free declarations or bound declarations. A symbol cannot be both the name of a type and the name of a declaration. Defining a symbol as the name of a class, structure, condition, or type, when the symbol has been declared as a declaration name, or vice versa, signals an error. Within the lexical scope of an array type declaration, all references to array elements are assumed to satisfy the expressed array element type (as opposed to the upgraded array element type). A compiler can treat the code within the scope of the array type declaration as if each access of an array element were surrounded by an appropriate the form. Examples:: .......... (defun f (x y) (declare (type fixnum x y)) (let ((z (+ x y))) (declare (type fixnum z)) z)) => F (f 1 2) => 3 ;; The previous definition of F is equivalent to (defun f (x y) ;; This declaration is a shorthand form of the TYPE declaration (declare (fixnum x y)) ;; To declare the type of a return value, it's not necessary to ;; create a named variable. A THE special form can be used instead. (the fixnum (+ x y))) => F (f 1 2) => 3 (defvar *one-array* (make-array 10 :element-type '(signed-byte 5))) (defvar *another-array* (make-array 10 :element-type '(signed-byte 8))) (defun frob (an-array) (declare (type (array (signed-byte 5) 1) an-array)) (setf (aref an-array 1) 31) (setf (aref an-array 2) 127) (setf (aref an-array 3) (* 2 (aref an-array 3))) (let ((foo 0)) (declare (type (signed-byte 5) foo)) (setf foo (aref an-array 0)))) (frob *one-array*) (frob *another-array*) The above definition of frob is equivalent to: (defun frob (an-array) (setf (the (signed-byte 5) (aref an-array 1)) 31) (setf (the (signed-byte 5) (aref an-array 2)) 127) (setf (the (signed-byte 5) (aref an-array 3)) (* 2 (the (signed-byte 5) (aref an-array 3)))) (let ((foo 0)) (declare (type (signed-byte 5) foo)) (setf foo (the (signed-byte 5) (aref an-array 0))))) Given an implementation in which fixnums are 29 bits but fixnum arrays are upgraded to signed 32-bit arrays, the following could be compiled with all fixnum arithmetic: (defun bump-counters (counters) (declare (type (array fixnum *) bump-counters)) (dotimes (i (length counters)) (incf (aref counters i)))) See Also:: .......... declare, *note declaim:: , *note proclaim:: Notes:: ....... (typespec {var}*) is an abbreviation for (type typespec {var}*). A type declaration for the arguments to a function does not necessarily imply anything about the type of the result. The following function is not permitted to be compiled using implementation-dependent fixnum-only arithmetic: (defun f (x y) (declare (fixnum x y)) (+ x y)) To see why, consider (f most-positive-fixnum 1). Common Lisp defines that F must return a bignum here, rather than signal an error or produce a mathematically incorrect result. If you have special knowledge such "fixnum overflow" cases will not come up, you can declare the result value to be in the fixnum range, enabling some compilers to use more efficient arithmetic: (defun f (x y) (declare (fixnum x y)) (the fixnum (+ x y))) Note, however, that in the three-argument case, because of the possibility of an implicit intermediate value growing too large, the following will not cause implementation-dependent fixnum-only arithmetic to be used: (defun f (x y) (declare (fixnum x y z)) (the fixnum (+ x y z))) To see why, consider (f most-positive-fixnum 1 -1). Although the arguments and the result are all fixnums, an intermediate value is not a fixnum. If it is important that implementation-dependent fixnum-only arithmetic be selected in implementations that provide it, consider writing something like this instead: (defun f (x y) (declare (fixnum x y z)) (the fixnum (+ (the fixnum (+ x y)) z)))  File: gcl.info, Node: inline, Next: ftype, Prev: type, Up: Evaluation and Compilation Dictionary 3.8.22 inline, notinline [Declaration] -------------------------------------- Syntax:: ........ (inline {function-name}*) (notinline {function-name}*) Arguments:: ........... function-name--a function name. Valid Context:: ............... declaration or proclamation Binding Types Affected:: ........................ function Description:: ............. inline specifies that it is desirable for the compiler to produce inline calls to the functions named by function-names; that is, the code for a specified function-name should be integrated into the calling routine, appearing "in line" in place of a procedure call. A compiler is free to ignore this declaration. inline declarations never apply to variable bindings. If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition. While no conforming implementation is required to perform inline expansion of user-defined functions, those implementations that do attempt to recognize the following paradigm: To define a function f that is not inline by default but for which (declare (inline f)) will make f be locally inlined, the proper definition sequence is: (declaim (inline f)) (defun f ...) (declaim (notinline f)) The inline proclamation preceding the defun form ensures that the compiler has the opportunity save the information necessary for inline expansion, and the notinline proclamation following the defun form prevents f from being expanded inline everywhere. notinline specifies that it is undesirable to compile the functions named by function-names in-line. A compiler is not free to ignore this declaration; calls to the specified functions must be implemented as out-of-line subroutine calls. If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition. In the presence of a compiler macro definition for function-name, a notinline declaration prevents that compiler macro from being used. An inline declaration may be used to encourage use of compiler macro definitions. inline and notinline declarations otherwise have no effect when the lexically visible definition of function-name is a macro definition. inline and notinline declarations can be free declarations or bound declarations. inline and notinline declarations of functions that appear before the body of a flet or labels form that defines that function are bound declarations. Such declarations in other contexts are free declarations. Examples:: .......... ;; The globally defined function DISPATCH should be open-coded, ;; if the implementation supports inlining, unless a NOTINLINE ;; declaration overrides this effect. (declaim (inline dispatch)) (defun dispatch (x) (funcall (get (car x) 'dispatch) x)) ;; Here is an example where inlining would be encouraged. (defun top-level-1 () (dispatch (read-command))) ;; Here is an example where inlining would be prohibited. (defun top-level-2 () (declare (notinline dispatch)) (dispatch (read-command))) ;; Here is an example where inlining would be prohibited. (declaim (notinline dispatch)) (defun top-level-3 () (dispatch (read-command))) ;; Here is an example where inlining would be encouraged. (defun top-level-4 () (declare (inline dispatch)) (dispatch (read-command))) See Also:: .......... declare, *note declaim:: , *note proclaim::  File: gcl.info, Node: ftype, Next: declaration, Prev: inline, Up: Evaluation and Compilation Dictionary 3.8.23 ftype [Declaration] -------------------------- Syntax:: ........ (ftype type {function-name}*) Arguments:: ........... function-name--a function name. type--a type specifier. Valid Context:: ............... declaration or proclamation Binding Types Affected:: ........................ function Description:: ............. Specifies that the functions named by function-names are of the functional type type. For example: (declare (ftype (function (integer list) t) ith) (ftype (function (number) float) sine cosine)) If one of the functions mentioned has a lexically apparent local definition (as made by flet or labels), then the declaration applies to that local definition and not to the global function definition. ftype declarations never apply to variable bindings (see type). The lexically apparent bindings of function-names must not be macro definitions. (This is because ftype declares the functional definition of each function name to be of a particular subtype of function, and macros do not denote functions.) ftype declarations can be free declarations or bound declarations. ftype declarations of functions that appear before the body of a flet or labels form that defines that function are bound declarations. Such declarations in other contexts are free declarations. See Also:: .......... declare, *note declaim:: , *note proclaim::  File: gcl.info, Node: declaration, Next: optimize, Prev: ftype, Up: Evaluation and Compilation Dictionary 3.8.24 declaration [Declaration] -------------------------------- Syntax:: ........ (declaration {name}*) Arguments:: ........... name--a symbol. Valid Context:: ............... proclamation only Description:: ............. Advises the compiler that each name is a valid but potentially non-standard declaration name. The purpose of this is to tell one compiler not to issue warnings for declarations meant for another compiler or other program processor. Examples:: .......... (declaim (declaration author target-language target-machine)) (declaim (target-language ada)) (declaim (target-machine IBM-650)) (defun strangep (x) (declare (author "Harry Tweeker")) (member x '(strange weird odd peculiar))) See Also:: .......... *note declaim:: , *note proclaim::  File: gcl.info, Node: optimize, Next: special, Prev: declaration, Up: Evaluation and Compilation Dictionary 3.8.25 optimize [Declaration] ----------------------------- Syntax:: ........ (optimize {quality | (quality value)}*) Arguments:: ........... quality--an optimize quality. value--one of the integers 0, 1, 2, or 3. Valid Context:: ............... declaration or proclamation Description:: ............. Advises the compiler that each quality should be given attention according to the specified corresponding value. Each quality must be a symbol naming an optimize quality; the names and meanings of the standard optimize qualities are shown in Figure 3-25. Name Meaning compilation-speed speed of the compilation process debug ease of debugging safety run-time error checking space both code size and run-time space speed speed of the object code Figure 3-25: Optimize qualities There may be other, implementation-defined optimize qualities. A value 0 means that the corresponding quality is totally unimportant, and 3 that the quality is extremely important; 1 and 2 are intermediate values, with 1 the neutral value. (quality 3) can be abbreviated to quality. Note that code which has the optimization (safety 3), or just safety, is called safe code. The consequences are unspecified if a quality appears more than once with different values. Examples:: .......... (defun often-used-subroutine (x y) (declare (optimize (safety 2))) (error-check x y) (hairy-setup x) (do ((i 0 (+ i 1)) (z x (cdr z))) ((null z)) ;; This inner loop really needs to burn. (declare (optimize speed)) (declare (fixnum i)) )) See Also:: .......... declare, *note declaim:: , *note proclaim:: , *note Declaration Scope:: Notes:: ....... An optimize declaration never applies to either a variable or a function binding. An optimize declaration can only be a free declaration. For more information, see *note Declaration Scope::.  File: gcl.info, Node: special, Next: locally, Prev: optimize, Up: Evaluation and Compilation Dictionary 3.8.26 special [Declaration] ---------------------------- Syntax:: ........ (special {var}*) Arguments:: ........... var--a symbol. Valid Context:: ............... declaration or proclamation Binding Types Affected:: ........................ variable Description:: ............. Specifies that all of the vars named are dynamic. This specifier affects variable bindings and affects references. All variable bindings affected are made to be dynamic bindings, and affected variable references refer to the current dynamic binding. For example: (defun hack (thing *mod*) ;The binding of the parameter (declare (special *mod*)) ; *mod* is visible to hack1, (hack1 (car thing))) ; but not that of thing. (defun hack1 (arg) (declare (special *mod*)) ;Declare references to *mod* ;within hack1 to be special. (if (atom arg) *mod* (cons (hack1 (car arg)) (hack1 (cdr arg))))) A special declaration does not affect inner bindings of a var; the inner bindings implicitly shadow a special declaration and must be explicitly re-declared to be special. special declarations never apply to function bindings. special declarations can be either bound declarations, affecting both a binding and references, or free declarations, affecting only references, depending on whether the declaration is attached to a variable binding. When used in a proclamation, a special declaration specifier applies to all bindings as well as to all references of the mentioned variables. For example, after (declaim (special x)) then in a function definition such as (defun example (x) ...) the parameter x is bound as a dynamic variable rather than as a lexical variable. Examples:: .......... (defun declare-eg (y) ;this y is special (declare (special y)) (let ((y t)) ;this y is lexical (list y (locally (declare (special y)) y)))) ;this y refers to the ;special binding of y => DECLARE-EG (declare-eg nil) => (T NIL) (setf (symbol-value 'x) 6) (defun foo (x) ;a lexical binding of x (print x) (let ((x (1+ x))) ;a special binding of x (declare (special x)) ;and a lexical reference (bar)) (1+ x)) (defun bar () (print (locally (declare (special x)) x))) (foo 10) |> 10 |> 11 => 11 (setf (symbol-value 'x) 6) (defun bar (x y) ;[1] 1st occurrence of x (let ((old-x x) ;[2] 2nd occurrence of x -- same as 1st occurrence (x y)) ;[3] 3rd occurrence of x (declare (special x)) (list old-x x))) (bar 'first 'second) => (FIRST SECOND) (defun few (x &optional (y *foo*)) (declare (special *foo*)) ...) The reference to *foo* in the first line of this example is not special even though there is a special declaration in the second line. (declaim (special prosp)) => implementation-dependent (setq prosp 1 reg 1) => 1 (let ((prosp 2) (reg 2)) ;the binding of prosp is special (set 'prosp 3) (set 'reg 3) ;due to the preceding proclamation, (list prosp reg)) ;whereas the variable reg is lexical => (3 2) (list prosp reg) => (1 3) (declaim (special x)) ;x is always special. (defun example (x y) (declare (special y)) (let ((y 3) (x (* x 2))) (print (+ y (locally (declare (special y)) y))) (let ((y 4)) (declare (special y)) (foo x)))) => EXAMPLE In the contorted code above, the outermost and innermost bindings of y are dynamic, but the middle binding is lexical. The two arguments to + are different, one being the value, which is 3, of the lexical variable y, and the other being the value of the dynamic variable named y (a binding of which happens, coincidentally, to lexically surround it at an outer level). All the bindings of x and references to x are dynamic, however, because of the proclamation that x is always special. See Also:: .......... *note defparameter:: , defvar  File: gcl.info, Node: locally, Next: the, Prev: special, Up: Evaluation and Compilation Dictionary 3.8.27 locally [Special Operator] --------------------------------- 'locally' {declaration}* {form}* => {result}* Arguments and Values:: ...................... Declaration--a declare expression; not evaluated. forms--an implicit progn. results--the values of the forms. Description:: ............. Sequentially evaluates a body of forms in a lexical environment where the given declarations have effect. Examples:: .......... (defun sample-function (y) ;this y is regarded as special (declare (special y)) (let ((y t)) ;this y is regarded as lexical (list y (locally (declare (special y)) ;; this next y is regarded as special y)))) => SAMPLE-FUNCTION (sample-function nil) => (T NIL) (setq x '(1 2 3) y '(4 . 5)) => (4 . 5) ;;; The following declarations are not notably useful in specific. ;;; They just offer a sample of valid declaration syntax using LOCALLY. (locally (declare (inline floor) (notinline car cdr)) (declare (optimize space)) (floor (car x) (cdr y))) => 0, 1 ;;; This example shows a definition of a function that has a particular set ;;; of OPTIMIZE settings made locally to that definition. (locally (declare (optimize (safety 3) (space 3) (speed 0))) (defun frob (w x y &optional (z (foo x y))) (mumble x y z w))) => FROB ;;; This is like the previous example, except that the optimize settings ;;; remain in effect for subsequent definitions in the same compilation unit. (declaim (optimize (safety 3) (space 3) (speed 0))) (defun frob (w x y &optional (z (foo x y))) (mumble x y z w)) => FROB See Also:: .......... declare Notes:: ....... The special declaration may be used with locally to affect references to, rather than bindings of, variables. If a locally form is a top level form, the body forms are also processed as top level forms. See *note File Compilation::.  File: gcl.info, Node: the, Next: special-operator-p, Prev: locally, Up: Evaluation and Compilation Dictionary 3.8.28 the [Special Operator] ----------------------------- 'the' value-type form => {result}* Arguments and Values:: ...................... value-type--a type specifier; not evaluated. form--a form; evaluated. results--the values resulting from the evaluation of form. These values must conform to the type supplied by value-type; see below. Description:: ............. the specifies that the values_{1a} returned by form are of the types specified by value-type. The consequences are undefined if any result is not of the declared type. It is permissible for form to yield a different number of values than are specified by value-type, provided that the values for which types are declared are indeed of those types. Missing values are treated as nil for the purposes of checking their types. Regardless of number of values declared by value-type, the number of values returned by the the special form is the same as the number of values returned by form. Examples:: .......... (the symbol (car (list (gensym)))) => #:G9876 (the fixnum (+ 5 7)) => 12 (the (values) (truncate 3.2 2)) => 1, 1.2 (the integer (truncate 3.2 2)) => 1, 1.2 (the (values integer) (truncate 3.2 2)) => 1, 1.2 (the (values integer float) (truncate 3.2 2)) => 1, 1.2 (the (values integer float symbol) (truncate 3.2 2)) => 1, 1.2 (the (values integer float symbol t null list) (truncate 3.2 2)) => 1, 1.2 (let ((i 100)) (declare (fixnum i)) (the fixnum (1+ i))) => 101 (let* ((x (list 'a 'b 'c)) (y 5)) (setf (the fixnum (car x)) y) x) => (5 B C) Exceptional Situations:: ........................ The consequences are undefined if the values yielded by the form are not of the type specified by value-type. See Also:: .......... values Notes:: ....... The values type specifier can be used to indicate the types of multiple values: (the (values integer integer) (floor x y)) (the (values string t) (gethash the-key the-string-table)) setf can be used with the type declarations. In this case the declaration is transferred to the form that specifies the new value. The resulting setf form is then analyzed.  File: gcl.info, Node: special-operator-p, Next: constantp, Prev: the, Up: Evaluation and Compilation Dictionary 3.8.29 special-operator-p [Function] ------------------------------------ 'special-operator-p' symbol => generalized-boolean Arguments and Values:: ...................... symbol--a symbol. generalized-boolean--a generalized boolean. Description:: ............. Returns true if symbol is a special operator; otherwise, returns false. Examples:: .......... (special-operator-p 'if) => true (special-operator-p 'car) => false (special-operator-p 'one) => false Exceptional Situations:: ........................ Should signal type-error if its argument is not a symbol. Notes:: ....... Historically, this function was called special-form-p. The name was finally declared a misnomer and changed, since it returned true for special operators, not special forms.  File: gcl.info, Node: constantp, Prev: special-operator-p, Up: Evaluation and Compilation Dictionary 3.8.30 constantp [Function] --------------------------- 'constantp' form &optional environment => generalized-boolean Arguments and Values:: ...................... form--a form. environment--an environment object. The default is nil. generalized-boolean--a generalized boolean. Description:: ............. Returns true if form can be determined by the implementation to be a constant form in the indicated environment; otherwise, it returns false indicating either that the form is not a constant form or that it cannot be determined whether or not form is a constant form. The following kinds of forms are considered constant forms: * Self-evaluating objects (such as numbers, characters, and the various kinds of arrays) are always considered constant forms and must be recognized as such by constantp. * Constant variables, such as keywords, symbols defined by Common Lisp as constant (such as nil, t, and pi), and symbols declared as constant by the user in the indicated environment using defconstant are always considered constant forms and must be recognized as such by constantp. * quote forms are always considered constant forms and must be recognized as such by constantp. * An implementation is permitted, but not required, to detect additional constant forms. If it does, it is also permitted, but not required, to make use of information in the environment. Examples of constant forms for which constantp might or might not return true are: (sqrt pi), (+ 3 2), (length '(a b c)), and (let ((x 7)) (zerop x)). If an implementation chooses to make use of the environment information, such actions as expanding macros or performing function inlining are permitted to be used, but not required; however, expanding compiler macros is not permitted. Examples:: .......... (constantp 1) => true (constantp 'temp) => false (constantp ''temp)) => true (defconstant this-is-a-constant 'never-changing) => THIS-IS-A-CONSTANT (constantp 'this-is-a-constant) => true (constantp "temp") => true (setq a 6) => 6 (constantp a) => true (constantp '(sin pi)) => implementation-dependent (constantp '(car '(x))) => implementation-dependent (constantp '(eql x x)) => implementation-dependent (constantp '(typep x 'nil)) => implementation-dependent (constantp '(typep x 't)) => implementation-dependent (constantp '(values this-is-a-constant)) => implementation-dependent (constantp '(values 'x 'y)) => implementation-dependent (constantp '(let ((a '(a b c))) (+ (length a) 6))) => implementation-dependent Affected By:: ............. The state of the global environment (e.g., which symbols have been declared to be the names of constant variables). See Also:: .......... *note defconstant::  File: gcl.info, Node: Types and Classes, Next: Data and Control Flow, Prev: Evaluation and Compilation, Up: Top 4 Types and Classes ******************* * Menu: * Introduction (Types and Classes):: * Types:: * Classes:: * Types and Classes Dictionary::  File: gcl.info, Node: Introduction (Types and Classes), Next: Types, Prev: Types and Classes, Up: Types and Classes 4.1 Introduction ================ A type is a (possibly infinite) set of objects. An object can belong to more than one type. Types are never explicitly represented as objects by Common Lisp. Instead, they are referred to indirectly by the use of type specifiers, which are objects that denote types. New types can be defined using deftype, defstruct, defclass, and define-condition. The function typep, a set membership test, is used to determine whether a given object is of a given type. The function subtypep, a subset test, is used to determine whether a given type is a subtype of another given type. The function type-of returns a particular type to which a given object belongs, even though that object must belong to one or more other types as well. (For example, every object is of type t, but type-of always returns a type specifier for a type more specific than t.) Objects, not variables, have types. Normally, any variable can have any object as its value. It is possible to declare that a variable takes on only values of a given type by making an explicit type declaration. Types are arranged in a directed acyclic graph, except for the presence of equivalences. Declarations can be made about types using declare, proclaim, declaim, or the. For more information about declarations, see *note Declarations::. Among the fundamental objects of the object system are classes. A class determines the structure and behavior of a set of other objects, which are called its instances. Every object is a direct instance of a class. The class of an object determines the set of operations that can be performed on the object. For more information, see *note Classes::. It is possible to write functions that have behavior specialized to the class of the objects which are their arguments. For more information, see *note Generic Functions and Methods::. The class of the class of an object is called its metaclass . For more information about metaclasses, see *note Meta-Objects::.  File: gcl.info, Node: Types, Next: Classes, Prev: Introduction (Types and Classes), Up: Types and Classes 4.2 Types ========= * Menu: * Data Type Definition:: * Type Relationships:: * Type Specifiers::  File: gcl.info, Node: Data Type Definition, Next: Type Relationships, Prev: Types, Up: Types 4.2.1 Data Type Definition -------------------------- Information about type usage is located in the sections specified in Figure~4-1. Figure~4-7 lists some classes that are particularly relevant to the object system. Figure~9-1 lists the defined condition types. Section Data Type _________________________________________________________________________ *note Classes:: Object System types *note Slots:: Object System types *note Objects:: Object System types *note Generic Functions and Methods:: Object System types *note Condition System Concepts:: Condition System types *note Types and Classes:: Miscellaneous types *note Syntax:: All types--read and print syntax *note The Lisp Printer:: All types--print syntax *note Compilation:: All types--compilation issues Figure 4-1: Cross-References to Data Type Information  File: gcl.info, Node: Type Relationships, Next: Type Specifiers, Prev: Data Type Definition, Up: Types 4.2.2 Type Relationships ------------------------ * The types cons, symbol, array, number, character, hash-table, function, readtable, package, pathname, stream, random-state, condition, restart, and any single other type created by defstruct, define-condition, or defclass are pairwise disjoint, except for type relations explicitly established by specifying superclasses in defclass or define-condition or the :include option of destruct. * Any two types created by defstruct are disjoint unless one is a supertype of the other by virtue of the defstruct :include option. [Editorial Note by KMP: The comments in the source say gray suggested some change from "common superclass" to "common subclass" in the following, but the result looks suspicious to me.] * Any two distinct classes created by defclass or define-condition are disjoint unless they have a common subclass or one class is a subclass of the other. * An implementation may be extended to add other subtype relationships between the specified types, as long as they do not violate the type relationships and disjointness requirements specified here. An implementation may define additional types that are subtypes or supertypes of any specified types, as long as each additional type is a subtype of type t and a supertype of type nil and the disjointness requirements are not violated. At the discretion of the implementation, either standard-object or structure-object might appear in any class precedence list for a system class that does not already specify either standard-object or structure-object. If it does, it must precede the class t and follow all other standardized classes.  File: gcl.info, Node: Type Specifiers, Prev: Type Relationships, Up: Types 4.2.3 Type Specifiers --------------------- Type specifiers can be symbols, classes, or lists. Figure~4-2 lists symbols that are standardized atomic type specifiers, and Figure~4-3 lists standardized compound type specifier names. For syntax information, see the dictionary entry for the corresponding type specifier. It is possible to define new type specifiers using defclass, define-condition, defstruct, or deftype. arithmetic-error function simple-condition array generic-function simple-error atom hash-table simple-string base-char integer simple-type-error base-string keyword simple-vector bignum list simple-warning bit logical-pathname single-float bit-vector long-float standard-char broadcast-stream method standard-class built-in-class method-combination standard-generic-function cell-error nil standard-method character null standard-object class number storage-condition compiled-function package stream complex package-error stream-error concatenated-stream parse-error string condition pathname string-stream cons print-not-readable structure-class control-error program-error structure-object division-by-zero random-state style-warning double-float ratio symbol echo-stream rational synonym-stream end-of-file reader-error t error readtable two-way-stream extended-char real type-error file-error restart unbound-slot file-stream sequence unbound-variable fixnum serious-condition undefined-function float short-float unsigned-byte floating-point-inexact signed-byte vector floating-point-invalid-operation simple-array warning floating-point-overflow simple-base-string floating-point-underflow simple-bit-vector Figure 4-2: Standardized Atomic Type Specifiers \indent If a type specifier is a list, the car of the list is a symbol, and the rest of the list is subsidiary type information. Such a type specifier is called a compound type specifier . Except as explicitly stated otherwise, the subsidiary items can be unspecified. The unspecified subsidiary items are indicated by writing *. For example, to completely specify a vector, the type of the elements and the length of the vector must be present. (vector double-float 100) The following leaves the length unspecified: (vector double-float *) The following leaves the element type unspecified: (vector * 100) Suppose that two type specifiers are the same except that the first has a * where the second has a more explicit specification. Then the second denotes a subtype of the type denoted by the first. If a list has one or more unspecified items at the end, those items can be dropped. If dropping all occurrences of * results in a singleton list, then the parentheses can be dropped as well (the list can be replaced by the symbol in its car). For example, (vector double-float *) can be abbreviated to (vector double-float), and (vector * *) can be abbreviated to (vector) and then to vector. and long-float simple-base-string array member simple-bit-vector base-string mod simple-string bit-vector not simple-vector complex or single-float cons rational string double-float real unsigned-byte eql satisfies values float short-float vector function signed-byte integer simple-array Figure 4-3: Standardized Compound Type Specifier Names Figure 4-4 show the defined names that can be used as compound type specifier names but that cannot be used as atomic type specifiers. and mod satisfies eql not values member or Figure 4-4: Standardized Compound-Only Type Specifier Names New type specifiers can come into existence in two ways. * Defining a structure by using defstruct without using the :type specifier or defining a class by using defclass or define-condition automatically causes the name of the structure or class to be a new type specifier symbol. * deftype can be used to define derived type specifiers , which act as 'abbreviations' for other type specifiers. A class object can be used as a type specifier. When used this way, it denotes the set of all members of that class. Figure 4-5 shows some defined names relating to types and declarations. coerce defstruct subtypep declaim deftype the declare ftype type defclass locally type-of define-condition proclaim typep Figure 4-5: Defined names relating to types and declarations. Figure 4-6 shows all defined names that are type specifier names, whether for atomic type specifiers or compound type specifiers; this list is the union of the lists in Figure~4-2 and Figure~4-3. and function simple-array arithmetic-error generic-function simple-base-string array hash-table simple-bit-vector atom integer simple-condition base-char keyword simple-error base-string list simple-string bignum logical-pathname simple-type-error bit long-float simple-vector bit-vector member simple-warning broadcast-stream method single-float built-in-class method-combination standard-char cell-error mod standard-class character nil standard-generic-function class not standard-method compiled-function null standard-object complex number storage-condition concatenated-stream or stream condition package stream-error cons package-error string control-error parse-error string-stream division-by-zero pathname structure-class double-float print-not-readable structure-object echo-stream program-error style-warning end-of-file random-state symbol eql ratio synonym-stream error rational t extended-char reader-error two-way-stream file-error readtable type-error file-stream real unbound-slot fixnum restart unbound-variable float satisfies undefined-function floating-point-inexact sequence unsigned-byte floating-point-invalid-operation serious-condition values floating-point-overflow short-float vector floating-point-underflow signed-byte warning Figure 4-6: Standardized Type Specifier Names  File: gcl.info, Node: Classes, Next: Types and Classes Dictionary, Prev: Types, Up: Types and Classes 4.3 Classes =========== While the object system is general enough to describe all standardized classes (including, for example, number, hash-table, and symbol), Figure 4-7 contains a list of classes that are especially relevant to understanding the object system. built-in-class method-combination standard-object class standard-class structure-class generic-function standard-generic-function structure-object method standard-method Figure 4-7: Object System Classes * Menu: * Introduction to Classes:: * Defining Classes:: * Creating Instances of Classes:: * Inheritance:: * Determining the Class Precedence List:: * Redefining Classes:: * Integrating Types and Classes::  File: gcl.info, Node: Introduction to Classes, Next: Defining Classes, Prev: Classes, Up: Classes 4.3.1 Introduction to Classes ----------------------------- A class is an object that determines the structure and behavior of a set of other objects, which are called its instances . A class can inherit structure and behavior from other classes. A class whose definition refers to other classes for the purpose of inheriting from them is said to be a subclass of each of those classes. The classes that are designated for purposes of inheritance are said to be superclasses of the inheriting class. A class can have a name. The function class-name takes a class object and returns its name. The name of an anonymous class is nil. A symbol can name a class. The function find-class takes a symbol and returns the class that the symbol names. A class has a proper name if the name is a symbol and if the name of the class names that class. That is, a class~C has the proper name~S if S= (class-name C) and C= (find-class S). Notice that it is possible for (find-class S_1) = (find-class S_2) and S_1!= S_2. If C= (find-class S), we say that C is the class named S. A class C_1 is a direct superclass of a class C_2 if C_2 explicitly designates C_1 as a superclass in its definition. In this case C_2 is a direct subclass of C_1. A class C_n is a superclass of a class C_1 if there exists a series of classes C_2,...,C_{n-1} such that C_{i+1} is a direct superclass of C_i for 1 <= i= 2, be the classes from S_C with no predecessors. Let (C_1... C_n), n>= 1, be the class precedence list constructed so far. C_1 is the most specific class, and C_n is the least specific. Let 1<= j<= n be the largest number such that there exists an i where 1<= i<= m and N_i is a direct superclass of C_j; N_i is placed next. The effect of this rule for selecting from a set of classes with no predecessors is that the classes in a simple superclass chain are adjacent in the class precedence list and that classes in each relatively separated subgraph are adjacent in the class precedence list. For example, let T_1 and T_2 be subgraphs whose only element in common is the class J. Suppose that no superclass of J appears in either T_1 or T_2, and that J is in the superclass chain of every class in both T_1 and T_2. Let C_1 be the bottom of T_1; and let C_2 be the bottom of T_2. Suppose C is a class whose direct superclasses are C_1 and C_2 in that order, then the class precedence list for C starts with C and is followed by all classes in T_1 except J. All the classes of T_2 are next. The class J and its superclasses appear last.  File: gcl.info, Node: Examples of Class Precedence List Determination, Prev: Topological Sorting, Up: Determining the Class Precedence List 4.3.5.2 Examples of Class Precedence List Determination ....................................................... This example determines a class precedence list for the class pie. The following classes are defined: (defclass pie (apple cinnamon) ()) (defclass apple (fruit) ()) (defclass cinnamon (spice) ()) (defclass fruit (food) ()) (defclass spice (food) ()) (defclass food () ()) The set S_{pie}~= {pie, apple, cinnamon, fruit, spice, food, standard-object, t }. The set R~= { (pie, apple), (apple, cinnamon), (apple, fruit), (cinnamon, spice), \break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) }. The class pie is not preceded by anything, so it comes first; the result so far is (pie). Remove pie from S and pairs mentioning pie from R to get S~= {apple, cinnamon, fruit, spice, food, standard-object, t } and R~=~{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, food), (spice, food), (food, standard-object), (standard-object, t) }. The class apple is not preceded by anything, so it is next; the result is (pie apple). Removing apple and the relevant pairs results in S~= { cinnamon, fruit, spice, food, standard-object, t } and R~= { (cinnamon, spice), (fruit, food), (spice, food), (food, standard-object),\break (standard-object, t) }. The classes cinnamon and fruit are not preceded by anything, so the one with a direct subclass rightmost in the class precedence list computed so far goes next. The class apple is a direct subclass of fruit, and the class pie is a direct subclass of cinnamon. Because apple appears to the right of pie in the class precedence list, fruit goes next, and the result so far is (pie apple fruit). S~= { cinnamon, spice, food, standard-object, t }; R~= {(cinnamon, spice), (spice, food),\break (food, standard-object), (standard-object, t) }. The class cinnamon is next, giving the result so far as (pie apple fruit cinnamon). At this point S~= { spice, food, standard-object, t }; R~= { (spice, food), (food, standard-object), (standard-object, t) }. The classes spice, food, standard-object, and t are added in that order, and the class precedence list is (pie apple fruit cinnamon spice food standard-object t). It is possible to write a set of class definitions that cannot be ordered. For example: (defclass new-class (fruit apple) ()) (defclass apple (fruit) ()) The class fruit must precede apple because the local ordering of superclasses must be preserved. The class apple must precede fruit because a class always precedes its own superclasses. When this situation occurs, an error is signaled, as happens here when the system tries to compute the class precedence list of new-class. The following might appear to be a conflicting set of definitions: (defclass pie (apple cinnamon) ()) (defclass pastry (cinnamon apple) ()) (defclass apple () ()) (defclass cinnamon () ()) The class precedence list for pie is (pie apple cinnamon standard-object t). The class precedence list for pastry is (pastry cinnamon apple standard-object t). It is not a problem for apple to precede cinnamon in the ordering of the superclasses of pie but not in the ordering for pastry. However, it is not possible to build a new class that has both pie and pastry as superclasses.  File: gcl.info, Node: Redefining Classes, Next: Integrating Types and Classes, Prev: Determining the Class Precedence List, Up: Classes 4.3.6 Redefining Classes ------------------------ A class that is a direct instance of standard-class can be redefined if the new class is also a direct instance of standard-class. Redefining a class modifies the existing class object to reflect the new class definition; it does not create a new class object for the class. Any method object created by a :reader, :writer, or :accessor option specified by the old defclass form is removed from the corresponding generic function. Methods specified by the new defclass form are added. When the class C is redefined, changes are propagated to its instances and to instances of any of its subclasses. Updating such an instance occurs at an implementation-dependent time, but no later than the next time a slot of that instance is read or written. Updating an instance does not change its identity as defined by the function eq. The updating process may change the slots of that particular instance, but it does not create a new instance. Whether updating an instance consumes storage is implementation-dependent. Note that redefining a class may cause slots to be added or deleted. If a class is redefined in a way that changes the set of local slots accessible in instances, the instances are updated. It is implementation-dependent whether instances are updated if a class is redefined in a way that does not change the set of local slots accessible in instances. The value of a slot that is specified as shared both in the old class and in the new class is retained. If such a shared slot was unbound in the old class, it is unbound in the new class. Slots that were local in the old class and that are shared in the new class are initialized. Newly added shared slots are initialized. Each newly added shared slot is set to the result of evaluating the captured initialization form for the slot that was specified in the defclass form for the new class. If there was no initialization form, the slot is unbound. If a class is redefined in such a way that the set of local slots accessible in an instance of the class is changed, a two-step process of updating the instances of the class takes place. The process may be explicitly started by invoking the generic function make-instances-obsolete. This two-step process can happen in other circumstances in some implementations. For example, in some implementations this two-step process is triggered if the order of slots in storage is changed. The first step modifies the structure of the instance by adding new local slots and discarding local slots that are not defined in the new version of the class. The second step initializes the newly-added local slots and performs any other user-defined actions. These two steps are further specified in the next two sections. * Menu: * Modifying the Structure of Instances:: * Initializing Newly Added Local Slots (Redefining Classes):: * Customizing Class Redefinition::  File: gcl.info, Node: Modifying the Structure of Instances, Next: Initializing Newly Added Local Slots (Redefining Classes), Prev: Redefining Classes, Up: Redefining Classes 4.3.6.1 Modifying the Structure of Instances ............................................ [Reviewer Note by Barmar: What about shared slots that are deleted?] The first step modifies the structure of instances of the redefined class to conform to its new class definition. Local slots specified by the new class definition that are not specified as either local or shared by the old class are added, and slots not specified as either local or shared by the new class definition that are specified as local by the old class are discarded. The names of these added and discarded slots are passed as arguments to update-instance-for-redefined-class as described in the next section. The values of local slots specified by both the new and old classes are retained. If such a local slot was unbound, it remains unbound. The value of a slot that is specified as shared in the old class and as local in the new class is retained. If such a shared slot was unbound, the local slot is unbound.  File: gcl.info, Node: Initializing Newly Added Local Slots (Redefining Classes), Next: Customizing Class Redefinition, Prev: Modifying the Structure of Instances, Up: Redefining Classes 4.3.6.2 Initializing Newly Added Local Slots ............................................ The second step initializes the newly added local slots and performs any other user-defined actions. This step is implemented by the generic function update-instance-for-redefined-class, which is called after completion of the first step of modifying the structure of the instance. The generic function update-instance-for-redefined-class takes four required arguments: the instance being updated after it has undergone the first step, a list of the names of local slots that were added, a list of the names of local slots that were discarded, and a property list containing the slot names and values of slots that were discarded and had values. Included among the discarded slots are slots that were local in the old class and that are shared in the new class. The generic function update-instance-for-redefined-class also takes any number of initialization arguments. When it is called by the system to update an instance whose class has been redefined, no initialization arguments are provided. There is a system-supplied primary method for update-instance-for-redefined-class whose parameter specializer for its instance argument is the class standard-object. First this method checks the validity of initialization arguments and signals an error if an initialization argument is supplied that is not declared as valid. (For more information, see *note Declaring the Validity of Initialization Arguments::.) Then it calls the generic function shared-initialize with the following arguments: the instance, the list of names of the newly added slots, and the initialization arguments it received.  File: gcl.info, Node: Customizing Class Redefinition, Prev: Initializing Newly Added Local Slots (Redefining Classes), Up: Redefining Classes 4.3.6.3 Customizing Class Redefinition ...................................... [Reviewer Note by Barmar: This description is hard to follow.] Methods for update-instance-for-redefined-class may be defined to specify actions to be taken when an instance is updated. If only after methods for update-instance-for-redefined-class are defined, they will be run after the system-supplied primary method for initialization and therefore will not interfere with the default behavior of update-instance-for-redefined-class. Because no initialization arguments are passed to update-instance-for-redefined-class when it is called by the system, the initialization forms for slots that are filled by before methods for update-instance-for-redefined-class will not be evaluated by shared-initialize. Methods for shared-initialize may be defined to customize class redefinition. For more information, see *note Shared-Initialize::.  File: gcl.info, Node: Integrating Types and Classes, Prev: Redefining Classes, Up: Classes 4.3.7 Integrating Types and Classes ----------------------------------- The object system maps the space of classes into the space of types. Every class that has a proper name has a corresponding type with the same name. The proper name of every class is a valid type specifier. In addition, every class object is a valid type specifier. Thus the expression (typep object class) evaluates to true if the class of object is class itself or a subclass of class. The evaluation of the expression (subtypep class1 class2) returns the values true and true if class1 is a subclass of class2 or if they are the same class; otherwise it returns the values false and true. If I is an instance of some class C named S and C is an instance of standard-class, the evaluation of the expression (type-of I\/) returns S if S is the proper name of C; otherwise, it returns C. Because the names of classes and class objects are type specifiers, they may be used in the special form the and in type declarations. Many but not all of the predefined type specifiers have a corresponding class with the same proper name as the type. These type specifiers are listed in Figure~4-8. For example, the type array has a corresponding class named array. No type specifier that is a list, such as (vector double-float 100), has a corresponding class. The operator deftype does not create any classes. Each class that corresponds to a predefined type specifier can be implemented in one of three ways, at the discretion of each implementation. It can be a standard class, a structure class, or a system class. A built-in class is one whose generalized instances have restricted capabilities or special representations. Attempting to use defclass to define subclasses of a built-in-class signals an error. Calling make-instance to create a generalized instance of a built-in class signals an error. Calling slot-value on a generalized instance of a built-in class signals an error. Redefining a built-in class or using change-class to change the class of an object to or from a built-in class signals an error. However, built-in classes can be used as parameter specializers in methods. It is possible to determine whether a class is a built-in class by checking the metaclass. A standard class is an instance of the class standard-class, a built-in class is an instance of the class built-in-class, and a structure class is an instance of the class structure-class. Each structure type created by defstruct without using the :type option has a corresponding class. This class is a generalized instance of the class structure-class. The :include option of defstruct creates a direct subclass of the class that corresponds to the included structure type. It is implementation-dependent whether slots are involved in the operation of functions defined in this specification on instances of classes defined in this specification, except when slots are explicitly defined by this specification. If in a particular implementation a class defined in this specification has slots that are not defined by this specfication, the names of these slots must not be external symbols of packages defined in this specification nor otherwise accessible in the CL-USER package. The purpose of specifying that many of the standard type specifiers have a corresponding class is to enable users to write methods that discriminate on these types. Method selection requires that a class precedence list can be determined for each class. The hierarchical relationships among the type specifiers are mirrored by relationships among the classes corresponding to those types. Figure~4-8 lists the set of classes that correspond to predefined type specifiers. arithmetic-error generic-function simple-error array hash-table simple-type-error bit-vector integer simple-warning broadcast-stream list standard-class built-in-class logical-pathname standard-generic-function cell-error method standard-method character method-combination standard-object class null storage-condition complex number stream concatenated-stream package stream-error condition package-error string cons parse-error string-stream control-error pathname structure-class division-by-zero print-not-readable structure-object echo-stream program-error style-warning end-of-file random-state symbol error ratio synonym-stream file-error rational t file-stream reader-error two-way-stream float readtable type-error floating-point-inexact real unbound-slot floating-point-invalid-operation restart unbound-variable floating-point-overflow sequence undefined-function floating-point-underflow serious-condition vector function simple-condition warning Figure 4-8: Classes that correspond to pre-defined type specifiers The class precedence list information specified in the entries for each of these classes are those that are required by the object system. Individual implementations may be extended to define other type specifiers to have a corresponding class. Individual implementations may be extended to add other subclass relationships and to add other elements to the class precedence lists as long as they do not violate the type relationships and disjointness requirements specified by this standard. A standard class defined with no direct superclasses is guaranteed to be disjoint from all of the classes in the table, except for the class named t.  File: gcl.info, Node: Types and Classes Dictionary, Prev: Classes, Up: Types and Classes 4.4 Types and Classes Dictionary ================================ * Menu: * nil (Type):: * boolean:: * function (System Class):: * compiled-function:: * generic-function:: * standard-generic-function:: * class:: * built-in-class:: * structure-class:: * standard-class:: * method:: * standard-method:: * structure-object:: * standard-object:: * method-combination:: * t (System Class):: * satisfies:: * member (Type Specifier):: * not (Type Specifier):: * and (Type Specifier):: * or (Type Specifier):: * values (Type Specifier):: * eql (Type Specifier):: * coerce:: * deftype:: * subtypep:: * type-of:: * typep:: * type-error:: * type-error-datum:: * simple-type-error::  File: gcl.info, Node: nil (Type), Next: boolean, Prev: Types and Classes Dictionary, Up: Types and Classes Dictionary 4.4.1 nil [Type] ---------------- Supertypes:: ............ all types Description:: ............. The type nil contains no objects and so is also called the empty type. The type nil is a subtype of every type. No object is of type nil. Notes:: ....... The type containing the object nil is the type null, not the type nil.  File: gcl.info, Node: boolean, Next: function (System Class), Prev: nil (Type), Up: Types and Classes Dictionary 4.4.2 boolean [Type] -------------------- Supertypes:: ............ boolean, symbol, t Description:: ............. The type boolean contains the symbols t and nil, which represent true and false, respectively. See Also:: .......... t (constant variable), nil (constant variable), *note if:: , *note not:: , *note complement:: Notes:: ....... Conditional operations, such as if, permit the use of generalized booleans, not just booleans; any non-nil value, not just t, counts as true for a generalized boolean. However, as a matter of convention, the symbol t is considered the canonical value to use even for a generalized boolean when no better choice presents itself.  File: gcl.info, Node: function (System Class), Next: compiled-function, Prev: boolean, Up: Types and Classes Dictionary 4.4.3 function [System Class] ----------------------------- Class Precedence List:: ....................... function, t Description:: ............. A function is an object that represents code to be executed when an appropriate number of arguments is supplied. A function is produced by the function special form, the function coerce, or the function compile. A function can be directly invoked by using it as the first argument to funcall, apply, or multiple-value-call. Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('function'{[arg-typespec [value-typespec]]}) arg-typespec ::=({typespec}* [&optional {typespec}*] [&rest typespec] [&key {(keyword typespec )}*]) Compound Type Specifier Arguments:: ................................... typespec--a type specifier. value-typespec--a type specifier. Compound Type Specifier Description:: ..................................... [Editorial Note by KMP: Isn't there some context info about ftype declarations to be merged here?] [Editorial Note by KMP: This could still use some cleaning up.] [Editorial Note by Sandra: Still need clarification about what happens if the number of arguments doesn't match the FUNCTION type declaration.] The list form of the function type-specifier can be used only for declaration and not for discrimination. Every element of this type is a function that accepts arguments of the types specified by the argj-types and returns values that are members of the types specified by value-type. The &optional, &rest, &key, and &allow-other-keys markers can appear in the list of argument types. The type specifier provided with &rest is the type of each actual argument, not the type of the corresponding variable. The &key parameters should be supplied as lists of the form (keyword type). The keyword must be a valid keyword-name symbol as must be supplied in the actual arguments of a call. This is usually a symbol in the KEYWORD package but can be any symbol. When &key is given in a function type specifier lambda list, the keyword parameters given are exhaustive unless &allow-other-keys is also present. &allow-other-keys is an indication that other keyword arguments might actually be supplied and, if supplied, can be used. For example, the type of the function make-list could be declared as follows: (function ((integer 0) &key (:initial-element t)) list) The value-type can be a values type specifier in order to indicate the types of multiple values. Consider a declaration of the following form: (ftype (function (arg0-type arg1-type ...) val-type) f)) Any form (f arg0 arg1 ...) within the scope of that declaration is equivalent to the following: (the val-type (f (the arg0-type arg0) (the arg1-type arg1) ...)) That is, the consequences are undefined if any of the arguments are not of the specified types or the result is not of the specified type. In particular, if any argument is not of the correct type, the result is not guaranteed to be of the specified type. Thus, an ftype declaration for a function describes calls to the function, not the actual definition of the function. Consider a declaration of the following form: (type (function (arg0-type arg1-type ...) val-type) fn-valued-variable) This declaration has the interpretation that, within the scope of the declaration, the consequences are unspecified if the value of fn-valued-variable is called with arguments not of the specified types; the value resulting from a valid call will be of type val-type. As with variable type declarations, nested declarations imply intersections of types, as follows: * Consider the following two declarations of ftype: (ftype (function (arg0-type1 arg1-type1 ...) val-type1) f)) and (ftype (function (arg0-type2 arg1-type2 ...) val-type2) f)) If both these declarations are in effect, then within the shared scope of the declarations, calls to f can be treated as if f were declared as follows: (ftype (function ((and arg0-type1 arg0-type2) (and arg1-type1 arg1-type2 ...) ...) (and val-type1 val-type2)) f)) It is permitted to ignore one or all of the ftype declarations in force. * If two (or more) type declarations are in effect for a variable, and they are both function declarations, the declarations combine similarly.  File: gcl.info, Node: compiled-function, Next: generic-function, Prev: function (System Class), Up: Types and Classes Dictionary 4.4.4 compiled-function [Type] ------------------------------ Supertypes:: ............ compiled-function, function, t Description:: ............. Any function may be considered by an implementation to be a a compiled function if it contains no references to macros that must be expanded at run time, and it contains no unresolved references to load time values. See *note Compilation Semantics::. Functions whose definitions appear lexically within a file that has been compiled with compile-file and then loaded with load are of type compiled-function. Functions produced by the compile function are of type compiled-function. Other functions might also be of type compiled-function.  File: gcl.info, Node: generic-function, Next: standard-generic-function, Prev: compiled-function, Up: Types and Classes Dictionary 4.4.5 generic-function [System Class] ------------------------------------- Class Precedence List:: ....................... generic-function, function, t Description:: ............. A generic function is a function whose behavior depends on the classes or identities of the arguments supplied to it. A generic function object contains a set of methods, a lambda list, a method combination type, and other information. The methods define the class-specific behavior and operations of the generic function; a method is said to specialize a generic function. When invoked, a generic function executes a subset of its methods based on the classes or identities of its arguments. A generic function can be used in the same ways that an ordinary function can be used; specifically, a generic function can be used as an argument to funcall and apply, and can be given a global or a local name.  File: gcl.info, Node: standard-generic-function, Next: class, Prev: generic-function, Up: Types and Classes Dictionary 4.4.6 standard-generic-function [System Class] ---------------------------------------------- Class Precedence List:: ....................... standard-generic-function, generic-function, function, t Description:: ............. The class standard-generic-function is the default class of generic functions established by defmethod, ensure-generic-function, defgeneric, and defclass forms.  File: gcl.info, Node: class, Next: built-in-class, Prev: standard-generic-function, Up: Types and Classes Dictionary 4.4.7 class [System Class] -------------------------- Class Precedence List:: ....................... class, standard-object, t Description:: ............. The type class represents objects that determine the structure and behavior of their instances. Associated with an object of type class is information describing its place in the directed acyclic graph of classes, its slots, and its options.  File: gcl.info, Node: built-in-class, Next: structure-class, Prev: class, Up: Types and Classes Dictionary 4.4.8 built-in-class [System Class] ----------------------------------- Class Precedence List:: ....................... built-in-class, class, standard-object, t Description:: ............. A built-in class is a class whose instances have restricted capabilities or special representations. Attempting to use defclass to define subclasses of a built-in class signals an error of type error. Calling make-instance to create an instance of a built-in class signals an error of type error. Calling slot-value on an instance of a built-in class signals an error of type error. Redefining a built-in class or using change-class to change the class of an instance to or from a built-in class signals an error of type error. However, built-in classes can be used as parameter specializers in methods.  File: gcl.info, Node: structure-class, Next: standard-class, Prev: built-in-class, Up: Types and Classes Dictionary 4.4.9 structure-class [System Class] ------------------------------------ Class Precedence List:: ....................... structure-class, class, standard-object, t Description:: ............. All classes defined by means of defstruct are instances of the class structure-class.  File: gcl.info, Node: standard-class, Next: method, Prev: structure-class, Up: Types and Classes Dictionary 4.4.10 standard-class [System Class] ------------------------------------ Class Precedence List:: ....................... standard-class, class, standard-object, t Description:: ............. The class standard-class is the default class of classes defined by defclass.  File: gcl.info, Node: method, Next: standard-method, Prev: standard-class, Up: Types and Classes Dictionary 4.4.11 method [System Class] ---------------------------- Class Precedence List:: ....................... method, t Description:: ............. A method is an object that represents a modular part of the behavior of a generic function. A method contains code to implement the method's behavior, a sequence of parameter specializers that specify when the given method is applicable, and a sequence of qualifiers that is used by the method combination facility to distinguish among methods. Each required parameter of each method has an associated parameter specializer, and the method will be invoked only on arguments that satisfy its parameter specializers. The method combination facility controls the selection of methods, the order in which they are run, and the values that are returned by the generic function. The object system offers a default method combination type and provides a facility for declaring new types of method combination. See Also:: .......... *note Generic Functions and Methods::  File: gcl.info, Node: standard-method, Next: structure-object, Prev: method, Up: Types and Classes Dictionary 4.4.12 standard-method [System Class] ------------------------------------- Class Precedence List:: ....................... standard-method, method, standard-object, t Description:: ............. The class standard-method is the default class of methods defined by the defmethod and defgeneric forms.  File: gcl.info, Node: structure-object, Next: standard-object, Prev: standard-method, Up: Types and Classes Dictionary 4.4.13 structure-object [Class] ------------------------------- Class Precedence List:: ....................... structure-object, t Description:: ............. The class structure-object is an instance of structure-class and is a superclass of every class that is an instance of structure-class except itself, and is a superclass of every class that is defined by defstruct. See Also:: .......... *note defstruct:: , *note Sharpsign S::, *note Printing Structures::  File: gcl.info, Node: standard-object, Next: method-combination, Prev: structure-object, Up: Types and Classes Dictionary 4.4.14 standard-object [Class] ------------------------------ Class Precedence List:: ....................... standard-object, t Description:: ............. The class standard-object is an instance of standard-class and is a superclass of every class that is an instance of standard-class except itself.  File: gcl.info, Node: method-combination, Next: t (System Class), Prev: standard-object, Up: Types and Classes Dictionary 4.4.15 method-combination [System Class] ---------------------------------------- Class Precedence List:: ....................... method-combination, t Description:: ............. Every method combination object is an indirect instance of the class method-combination. A method combination object represents the information about the method combination being used by a generic function. A method combination object contains information about both the type of method combination and the arguments being used with that type.  File: gcl.info, Node: t (System Class), Next: satisfies, Prev: method-combination, Up: Types and Classes Dictionary 4.4.16 t [System Class] ----------------------- Class Precedence List:: ....................... t Description:: ............. The set of all objects. The type t is a supertype of every type, including itself. Every object is of type t.  File: gcl.info, Node: satisfies, Next: member (Type Specifier), Prev: t (System Class), Up: Types and Classes Dictionary 4.4.17 satisfies [Type Specifier] --------------------------------- Compound Type Specifier Kind:: .............................. Predicating. Compound Type Specifier Syntax:: ................................ ('satisfies'{predicate-name}) Compound Type Specifier Arguments:: ................................... predicate-name--a symbol. Compound Type Specifier Description:: ..................................... This denotes the set of all objects that satisfy the predicate predicate-name, which must be a symbol whose global function definition is a one-argument predicate. A name is required for predicate-name; lambda expressions are not allowed. For example, the type specifier (and integer (satisfies evenp)) denotes the set of all even integers. The form (typep x '(satisfies p)) is equivalent to (if (p x) t nil). The argument is required. The symbol * can be the argument, but it denotes itself (the symbol *), and does not represent an unspecified value. The symbol satisfies is not valid as a type specifier.  File: gcl.info, Node: member (Type Specifier), Next: not (Type Specifier), Prev: satisfies, Up: Types and Classes Dictionary 4.4.18 member [Type Specifier] ------------------------------ Compound Type Specifier Kind:: .............................. Combining. Compound Type Specifier Syntax:: ................................ ('member'{{object}*}) Compound Type Specifier Arguments:: ................................... object--an object. Compound Type Specifier Description:: ..................................... This denotes the set containing the named objects. An object is of this type if and only if it is eql to one of the specified objects. The type specifiers (member) and nil are equivalent. * can be among the objects, but if so it denotes itself (the symbol *) and does not represent an unspecified value. The symbol member is not valid as a type specifier; and, specifically, it is not an abbreviation for either (member) or (member *). See Also:: .......... the type eql  File: gcl.info, Node: not (Type Specifier), Next: and (Type Specifier), Prev: member (Type Specifier), Up: Types and Classes Dictionary 4.4.19 not [Type Specifier] --------------------------- Compound Type Specifier Kind:: .............................. Combining. Compound Type Specifier Syntax:: ................................ ('not'{typespec}) Compound Type Specifier Arguments:: ................................... typespec--a type specifier. Compound Type Specifier Description:: ..................................... This denotes the set of all objects that are not of the type typespec. The argument is required, and cannot be *. The symbol not is not valid as a type specifier.  File: gcl.info, Node: and (Type Specifier), Next: or (Type Specifier), Prev: not (Type Specifier), Up: Types and Classes Dictionary 4.4.20 and [Type Specifier] --------------------------- Compound Type Specifier Kind:: .............................. Combining. Compound Type Specifier Syntax:: ................................ ('and'{{typespec}*}) Compound Type Specifier Arguments:: ................................... typespec--a type specifier. Compound Type Specifier Description:: ..................................... This denotes the set of all objects of the type determined by the intersection of the typespecs. * is not permitted as an argument. The type specifiers (and) and t are equivalent. The symbol and is not valid as a type specifier, and, specifically, it is not an abbreviation for (and).  File: gcl.info, Node: or (Type Specifier), Next: values (Type Specifier), Prev: and (Type Specifier), Up: Types and Classes Dictionary 4.4.21 or [Type Specifier] -------------------------- Compound Type Specifier Kind:: .............................. Combining. Compound Type Specifier Syntax:: ................................ ('or'{{typespec}*}) Compound Type Specifier Arguments:: ................................... typespec--a type specifier. Compound Type Specifier Description:: ..................................... This denotes the set of all objects of the type determined by the union of the typespecs. For example, the type list by definition is the same as (or null cons). Also, the value returned by position is an object of type (or null (integer 0 *)); i.e., either nil or a non-negative integer. * is not permitted as an argument. The type specifiers (or) and nil are equivalent. The symbol or is not valid as a type specifier; and, specifically, it is not an abbreviation for (or).  File: gcl.info, Node: values (Type Specifier), Next: eql (Type Specifier), Prev: or (Type Specifier), Up: Types and Classes Dictionary 4.4.22 values [Type Specifier] ------------------------------ Compound Type Specifier Kind:: .............................. Specializing. Compound Type Specifier Syntax:: ................................ ('values'{!value-typespec}) [Reviewer Note by Barmar: Missing &key] value-typespec ::={typespec}* [&optional {typespec}*] [&rest typespec ] [&allow-other-keys] Compound Type Specifier Arguments:: ................................... typespec--a type specifier. Compound Type Specifier Description:: ..................................... This type specifier can be used only as the value-type in a function type specifier or a the special form. It is used to specify individual types when multiple values are involved. The &optional and &rest markers can appear in the value-type list; they indicate the parameter list of a function that, when given to multiple-value-call along with the values, would correctly receive those values. The symbol * may not be among the value-types. The symbol values is not valid as a type specifier; and, specifically, it is not an abbreviation for (values).  File: gcl.info, Node: eql (Type Specifier), Next: coerce, Prev: values (Type Specifier), Up: Types and Classes Dictionary 4.4.23 eql [Type Specifier] --------------------------- Compound Type Specifier Kind:: .............................. Combining. Compound Type Specifier Syntax:: ................................ ('eql'{object}) Compound Type Specifier Arguments:: ................................... object--an object. Compound Type Specifier Description:: ..................................... Represents the type whose only element is object. The argument object is required. The object can be *, but if so it denotes itself (the symbol *) and does not represent an unspecified value. The symbol eql is not valid as an atomic type specifier.  File: gcl.info, Node: coerce, Next: deftype, Prev: eql (Type Specifier), Up: Types and Classes Dictionary 4.4.24 coerce [Function] ------------------------ 'coerce' object result-type => result Arguments and Values:: ...................... object--an object. result-type--a type specifier. result--an object, of type result-type except in situations described in *note Rule of Canonical Representation for Complex Rationals::. Description:: ............. Coerces the object to type result-type. If object is already of type result-type, the object itself is returned, regardless of whether it would have been possible in general to coerce an object of some other type to result-type. Otherwise, the object is coerced to type result-type according to the following rules: sequence If the result-type is a recognizable subtype of list, and the object is a sequence, then the result is a list that has the same elements as object. If the result-type is a recognizable subtype of vector, and the object is a sequence, then the result is a vector that has the same elements as object. If result-type is a specialized type, the result has an actual array element type that is the result of upgrading the element type part of that specialized type. If no element type is specified, the element type defaults to t. If the implementation cannot determine the element type, an error is signaled. character If the result-type is character and the object is a character designator, the result is the character it denotes. complex If the result-type is complex and the object is a number, then the result is obtained by constructing a complex whose real part is the object and whose imaginary part is the result of coercing an integer zero to the type of the object (using coerce). (If the real part is a rational, however, then the result must be represented as a rational rather than a complex; see *note Rule of Canonical Representation for Complex Rationals::. So, for example, (coerce 3 'complex) is permissible, but will return 3, which is not a complex.) float If the result-type is any of float, short-float, single-float, double-float, long-float, and the object is a real, then the result is a float of type result-type which is equal in sign and magnitude to the object to whatever degree of representational precision is permitted by that float representation. (If the result-type is float and object is not already a float, then the result is a single float.) function If the result-type is function, and object is any function name that is fbound but that is globally defined neither as a macro name nor as a special operator, then the result is the functional value of object. If the result-type is function, and object is a lambda expression, then the result is a closure of object in the null lexical environment. t Any object can be coerced to an object of type t. In this case, the object is simply returned. Examples:: .......... (coerce '(a b c) 'vector) => #(A B C) (coerce 'a 'character) => #\A (coerce 4.56 'complex) => #C(4.56 0.0) (coerce 4.5s0 'complex) => #C(4.5s0 0.0s0) (coerce 7/2 'complex) => 7/2 (coerce 0 'short-float) => 0.0s0 (coerce 3.5L0 'float) => 3.5L0 (coerce 7/2 'float) => 3.5 (coerce (cons 1 2) t) => (1 . 2) All the following forms should signal an error: (coerce '(a b c) '(vector * 4)) (coerce #(a b c) '(vector * 4)) (coerce '(a b c) '(vector * 2)) (coerce #(a b c) '(vector * 2)) (coerce "foo" '(string 2)) (coerce #(#\a #\b #\c) '(string 2)) (coerce '(0 1) '(simple-bit-vector 3)) Exceptional Situations:: ........................ If a coercion is not possible, an error of type type-error is signaled. (coerce x 'nil) always signals an error of type type-error. An error of type error is signaled if the result-type is function but object is a symbol that is not fbound or if the symbol names a macro or a special operator. An error of type type-error should be signaled if result-type specifies the number of elements and object is of a different length. See Also:: .......... *note rational (Function):: , *note floor:: , *note char-code:: , *note char-int:: Notes:: ....... Coercions from floats to rationals and from ratios to integers are not provided because of rounding problems. (coerce x 't) == (identity x) == x  File: gcl.info, Node: deftype, Next: subtypep, Prev: coerce, Up: Types and Classes Dictionary 4.4.25 deftype [Macro] ---------------------- 'deftype' name lambda-list [[{declaration}* | documentation]] {form}* => name Arguments and Values:: ...................... name--a symbol. lambda-list--a deftype lambda list. declaration--a declare expression; not evaluated. documentation--a string; not evaluated. form--a form. Description:: ............. deftype defines a derived type specifier named name. The meaning of the new type specifier is given in terms of a function which expands the type specifier into another type specifier, which itself will be expanded if it contains references to another derived type specifier. The newly defined type specifier may be referenced as a list of the form (name arg_1 arg_2 ...)\/. The number of arguments must be appropriate to the lambda-list. If the new type specifier takes no arguments, or if all of its arguments are optional, the type specifier may be used as an atomic type specifier. The argument expressions to the type specifier, arg_1 ... arg_n, are not evaluated. Instead, these literal objects become the objects to which corresponding parameters become bound. The body of the deftype form (but not the lambda-list) is implicitly enclosed in a block named name, and is evaluated as an implicit progn, returning a new type specifier. The lexical environment of the body is the one which was current at the time the deftype form was evaluated, augmented by the variables in the lambda-list. Recursive expansion of the type specifier returned as the expansion must terminate, including the expansion of type specifiers which are nested within the expansion. The consequences are undefined if the result of fully expanding a type specifier contains any circular structure, except within the objects referred to by member and eql type specifiers. Documentation is attached to name as a documentation string of kind type. If a deftype form appears as a top level form, the compiler must ensure that the name is recognized in subsequent type declarations. The programmer must ensure that the body of a deftype form can be evaluated at compile time if the name is referenced in subsequent type declarations. If the expansion of a type specifier is not defined fully at compile time (perhaps because it expands into an unknown type specifier or a satisfies of a named function that isn't defined in the compile-time environment), an implementation may ignore any references to this type in declarations and/or signal a warning. Examples:: .......... (defun equidimensional (a) (or (< (array-rank a) 2) (apply #'= (array-dimensions a)))) => EQUIDIMENSIONAL (deftype square-matrix (&optional type size) `(and (array ,type (,size ,size)) (satisfies equidimensional))) => SQUARE-MATRIX See Also:: .......... declare, *note defmacro:: , *note documentation:: , *note Type Specifiers::, *note Syntactic Interaction of Documentation Strings and Declarations::  File: gcl.info, Node: subtypep, Next: type-of, Prev: deftype, Up: Types and Classes Dictionary 4.4.26 subtypep [Function] -------------------------- 'subtypep' type-1 type-2 &optional environment => subtype-p, valid-p Arguments and Values:: ...................... type-1--a type specifier. type-2--a type specifier. environment--an environment object. The default is nil, denoting the null lexical environment and the current global environment. subtype-p--a generalized boolean. valid-p--a generalized boolean. Description:: ............. If type-1 is a recognizable subtype of type-2, the first value is true. Otherwise, the first value is false, indicating that either type-1 is not a subtype of type-2, or else type-1 is a subtype of type-2 but is not a recognizable subtype. A second value is also returned indicating the 'certainty' of the first value. If this value is true, then the first value is an accurate indication of the subtype relationship. (The second value is always true when the first value is true.) Figure 4-9 summarizes the possible combinations of values that might result. Value 1 Value 2 Meaning true true type-1 is definitely a subtype of type-2. false true type-1 is definitely not a subtype of type-2. false false subtypep could not determine the relationship, so type-1 might or might not be a subtype of type-2. Figure 4-9: Result possibilities for subtypep subtypep is permitted to return the values false and false only when at least one argument involves one of these type specifiers: and, eql, the list form of function, member, not, or, satisfies, or values. (A type specifier 'involves' such a symbol if, after being type expanded, it contains that symbol in a position that would call for its meaning as a type specifier to be used.) One consequence of this is that if neither type-1 nor type-2 involves any of these type specifiers, then subtypep is obliged to determine the relationship accurately. In particular, subtypep returns the values true and true if the arguments are equal and do not involve any of these type specifiers. subtypep never returns a second value of nil when both type-1 and type-2 involve only the names in Figure~4-2, or names of types defined by defstruct, define-condition, or defclass, or derived types that expand into only those names. While type specifiers listed in Figure~4-2 and names of defclass and defstruct can in some cases be implemented as derived types, subtypep regards them as primitive. The relationships between types reflected by subtypep are those specific to the particular implementation. For example, if an implementation supports only a single type of floating-point numbers, in that implementation (subtypep 'float 'long-float) returns the values true and true (since the two types are identical). For all T1 and T2 other than *, (array T1) and (array T2) are two different type specifiers that always refer to the same sets of things if and only if they refer to arrays of exactly the same specialized representation, i.e., if (upgraded-array-element-type 'T1) and (upgraded-array-element-type 'T2) return two different type specifiers that always refer to the same sets of objects. This is another way of saying that `(array type-specifier) and `(array ,(upgraded-array-element-type 'type-specifier)) refer to the same set of specialized array representations. For all T1 and T2 other than *, the intersection of (array T1) and (array T2) is the empty set if and only if they refer to arrays of different, distinct specialized representations. Therefore, (subtypep '(array T1) '(array T2)) => true if and only if (upgraded-array-element-type 'T1) and (upgraded-array-element-type 'T2) return two different type specifiers that always refer to the same sets of objects. For all type-specifiers T1 and T2 other than *, (subtypep '(complex T1) '(complex T2)) => true, true if: 1. T1 is a subtype of T2, or 2. (upgraded-complex-part-type 'T1) and (upgraded-complex-part-type 'T2) return two different type specifiers that always refer to the same sets of objects; in this case, (complex T1) and (complex T2) both refer to the same specialized representation. The values are false and true otherwise. The form (subtypep '(complex single-float) '(complex float)) must return true in all implementations, but (subtypep '(array single-float) '(array float)) returns true only in implementations that do not have a specialized array representation for single floats distinct from that for other floats. Examples:: .......... (subtypep 'compiled-function 'function) => true, true (subtypep 'null 'list) => true, true (subtypep 'null 'symbol) => true, true (subtypep 'integer 'string) => false, true (subtypep '(satisfies dummy) nil) => false, implementation-dependent (subtypep '(integer 1 3) '(integer 1 4)) => true, true (subtypep '(integer (0) (0)) 'nil) => true, true (subtypep 'nil '(integer (0) (0))) => true, true (subtypep '(integer (0) (0)) '(member)) => true, true ;or false, false (subtypep '(member) 'nil) => true, true ;or false, false (subtypep 'nil '(member)) => true, true ;or false, false Let and be two distinct type specifiers that do not always refer to the same sets of objects in a given implementation, but for which make-array, will return an object of the same array type. Thus, in each case, (subtypep (array-element-type (make-array 0 :element-type ')) (array-element-type (make-array 0 :element-type '))) => true, true (subtypep (array-element-type (make-array 0 :element-type ')) (array-element-type (make-array 0 :element-type '))) => true, true If (array ) and (array ) are different names for exactly the same set of objects, these names should always refer to the same sets of objects. That implies that the following set of tests are also true: (subtypep '(array ) '(array )) => true, true (subtypep '(array ) '(array )) => true, true See Also:: .......... *note Types:: Notes:: ....... The small differences between the subtypep specification for the array and complex types are necessary because there is no creation function for complexes which allows the specification of the resultant part type independently of the actual types of the parts. Thus in the case of the type complex, the actual type of the parts is referred to, although a number can be a member of more than one type. For example, 17 is of type (mod 18) as well as type (mod 256) and type integer; and 2.3f5 is of type single-float as well as type float.  File: gcl.info, Node: type-of, Next: typep, Prev: subtypep, Up: Types and Classes Dictionary 4.4.27 type-of [Function] ------------------------- 'type-of' object => typespec Arguments and Values:: ...................... object--an object. typespec--a type specifier. Description:: ............. Returns a type specifier, typespec, for a type that has the object as an element. The typespec satisfies the following: 1. For any object that is an element of some built-in type: a. the type returned is a recognizable subtype of that built-in type. b. the type returned does not involve and, eql, member, not, or, satisfies, or values. 2. For all objects, (typep object (type-of object)) returns true. Implicit in this is that type specifiers which are not valid for use with typep, such as the list form of the function type specifier, are never returned by type-of. 3. The type returned by type-of is always a recognizable subtype of the class returned by class-of. That is, (subtypep (type-of object) (class-of object)) => true, true 4. For objects of metaclass structure-class or standard-class, and for conditions, type-of returns the proper name of the class returned by class-of if it has a proper name, and otherwise returns the class itself. In particular, for objects created by the constructor function of a structure defined with defstruct without a :type option, type-of returns the structure name; and for objects created by make-condition, the typespec is the name of the condition type. 5. For each of the types short-float, single-float, double-float, or long-float of which the object is an element, the typespec is a recognizable subtype of that type. Examples:: .......... (type-of 'a) => SYMBOL (type-of '(1 . 2)) => CONS OR=> (CONS FIXNUM FIXNUM) (type-of #c(0 1)) => COMPLEX OR=> (COMPLEX INTEGER) (defstruct temp-struct x y z) => TEMP-STRUCT (type-of (make-temp-struct)) => TEMP-STRUCT (type-of "abc") => STRING OR=> (STRING 3) (subtypep (type-of "abc") 'string) => true, true (type-of (expt 2 40)) => BIGNUM OR=> INTEGER OR=> (INTEGER 1099511627776 1099511627776) OR=> SYSTEM::TWO-WORD-BIGNUM OR=> FIXNUM (subtypep (type-of 112312) 'integer) => true, true (defvar *foo* (make-array 5 :element-type t)) => *FOO* (class-name (class-of *foo*)) => VECTOR (type-of *foo*) => VECTOR OR=> (VECTOR T 5) See Also:: .......... *note array-element-type:: , *note class-of:: , *note defstruct:: , *note typecase:: , *note typep:: , *note Types:: Notes:: ....... Implementors are encouraged to arrange for type-of to return a portable value.  File: gcl.info, Node: typep, Next: type-error, Prev: type-of, Up: Types and Classes Dictionary 4.4.28 typep [Function] ----------------------- 'typep' object type-specifier &optional environment => generalized-boolean Arguments and Values:: ...................... object--an object. type-specifier--any type specifier except values, or a type specifier list whose first element is either function or values. environment--an environment object. The default is nil, denoting the null lexical environment and the and current global environment. generalized-boolean--a generalized boolean. Description:: ............. Returns true if object is of the type specified by type-specifier; otherwise, returns false. A type-specifier of the form (satisfies fn) is handled by applying the function fn to object. (typep object '(array type-specifier)), where type-specifier is not *, returns true if and only if object is an array that could be the result of supplying type-specifier as the :element-type argument to make-array. (array *) refers to all arrays regardless of element type, while (array type-specifier) refers only to those arrays that can result from giving type-specifier as the :element-type argument to make-array. A similar interpretation applies to (simple-array type-specifier) and (vector type-specifier). See *note Array Upgrading::. (typep object '(complex type-specifier)) returns true for all complex numbers that can result from giving numbers of type type-specifier to the function complex, plus all other complex numbers of the same specialized representation. Both the real and the imaginary parts of any such complex number must satisfy: (typep realpart 'type-specifier) (typep imagpart 'type-specifier) See the function upgraded-complex-part-type. Examples:: .......... (typep 12 'integer) => true (typep (1+ most-positive-fixnum) 'fixnum) => false (typep nil t) => true (typep nil nil) => false (typep 1 '(mod 2)) => true (typep #c(1 1) '(complex (eql 1))) => true ;; To understand this next example, you might need to refer to ;; *note Rule of Canonical Representation for Complex Rationals::. (typep #c(0 0) '(complex (eql 0))) => false Let A_x and A_y be two type specifiers that denote different types, but for which (upgraded-array-element-type 'A_x) and (upgraded-array-element-type 'A_y) denote the same type. Notice that (typep (make-array 0 :element-type 'A_x) '(array A_x)) => true (typep (make-array 0 :element-type 'A_y) '(array A_y)) => true (typep (make-array 0 :element-type 'A_x) '(array A_y)) => true (typep (make-array 0 :element-type 'A_y) '(array A_x)) => true Exceptional Situations:: ........................ An error of type error is signaled if type-specifier is values, or a type specifier list whose first element is either function or values. The consequences are undefined if the type-specifier is not a type specifier. See Also:: .......... *note type-of:: , *note upgraded-array-element-type:: , *note upgraded-complex-part-type:: , *note Type Specifiers:: Notes:: ....... Implementations are encouraged to recognize and optimize the case of (typep x (the class y)), since it does not involve any need for expansion of deftype information at runtime.  File: gcl.info, Node: type-error, Next: type-error-datum, Prev: typep, Up: Types and Classes Dictionary 4.4.29 type-error [Condition Type] ---------------------------------- Class Precedence List:: ....................... type-error, error, serious-condition, condition, t Description:: ............. The type type-error represents a situation in which an object is not of the expected type. The "offending datum" and "expected type" are initialized by the initialization arguments named :datum and :expected-type to make-condition, and are accessed by the functions type-error-datum and type-error-expected-type. See Also:: .......... *note type-error-datum:: , type-error-expected-type  File: gcl.info, Node: type-error-datum, Next: simple-type-error, Prev: type-error, Up: Types and Classes Dictionary 4.4.30 type-error-datum, type-error-expected-type [Function] ------------------------------------------------------------ 'type-error-datum' condition => datum 'type-error-expected-type' condition => expected-type Arguments and Values:: ...................... condition--a condition of type type-error. datum--an object. expected-type--a type specifier. Description:: ............. type-error-datum returns the offending datum in the situation represented by the condition. type-error-expected-type returns the expected type of the offending datum in the situation represented by the condition. Examples:: .......... (defun fix-digits (condition) (check-type condition type-error) (let* ((digits '(zero one two three four five six seven eight nine)) (val (position (type-error-datum condition) digits))) (if (and val (subtypep 'fixnum (type-error-expected-type condition))) (store-value 7)))) (defun foo (x) (handler-bind ((type-error #'fix-digits)) (check-type x number) (+ x 3))) (foo 'seven) => 10 See Also:: .......... type-error, *note Conditions::  File: gcl.info, Node: simple-type-error, Prev: type-error-datum, Up: Types and Classes Dictionary 4.4.31 simple-type-error [Condition Type] ----------------------------------------- Class Precedence List:: ....................... simple-type-error, simple-condition, type-error, error, serious-condition, condition, t Description:: ............. Conditions of type simple-type-error are like conditions of type type-error, except that they provide an alternate mechanism for specifying how the condition is to be reported; see the type simple-condition. See Also:: .......... simple-condition, *note simple-condition-format-control:: , simple-condition-format-arguments, *note type-error-datum:: , type-error-expected-type  File: gcl.info, Node: Data and Control Flow, Next: Iteration, Prev: Types and Classes, Up: Top 5 Data and Control Flow *********************** * Menu: * Generalized Reference:: * Transfer of Control to an Exit Point:: * Data and Control Flow Dictionary::  File: gcl.info, Node: Generalized Reference, Next: Transfer of Control to an Exit Point, Prev: Data and Control Flow, Up: Data and Control Flow 5.1 Generalized Reference ========================= * Menu: * Overview of Places and Generalized Reference:: * Kinds of Places:: * Treatment of Other Macros Based on SETF::  File: gcl.info, Node: Overview of Places and Generalized Reference, Next: Kinds of Places, Prev: Generalized Reference, Up: Generalized Reference 5.1.1 Overview of Places and Generalized Reference -------------------------------------------------- A generalized reference is the use of a form, sometimes called a place , as if it were a variable that could be read and written. The value of a place is the object to which the place form evaluates. The value of a place can be changed by using setf. The concept of binding a place is not defined in Common Lisp, but an implementation is permitted to extend the language by defining this concept. Figure 5-1 contains examples of the use of setf. Note that the values returned by evaluating the forms in column two are not necessarily the same as those obtained by evaluating the forms in column three. In general, the exact macro expansion of a setf form is not guaranteed and can even be implementation-dependent; all that is guaranteed is that the expansion is an update form that works for that particular implementation, that the left-to-right evaluation of subforms is preserved, and that the ultimate result of evaluating setf is the value or values being stored. Access function Update Function Update using setf x (setq x datum) (setf x datum) (car x) (rplaca x datum) (setf (car x) datum) (symbol-value x) (set x datum) (setf (symbol-value x) datum) Figure 5-1: Examples of setf Figure 5-2 shows operators relating to places and generalized reference. assert defsetf push ccase get-setf-expansion remf ctypecase getf rotatef decf incf setf define-modify-macro pop shiftf define-setf-expander psetf Figure 5-2: Operators relating to places and generalized reference. Some of the operators above manipulate places and some manipulate setf expanders. A setf expansion can be derived from any place. New setf expanders can be defined by using defsetf and define-setf-expander. * Menu: * Evaluation of Subforms to Places:: * Examples of Evaluation of Subforms to Places:: * Setf Expansions:: * Examples of Setf Expansions::  File: gcl.info, Node: Evaluation of Subforms to Places, Next: Examples of Evaluation of Subforms to Places, Prev: Overview of Places and Generalized Reference, Up: Overview of Places and Generalized Reference 5.1.1.1 Evaluation of Subforms to Places ........................................ The following rules apply to the evaluation of subforms in a place: 1. The evaluation ordering of subforms within a place is determined by the order specified by the second value returned by get-setf-expansion. For all places defined by this specification (e.g., getf, ldb, ...), this order of evaluation is left-to-right. When a place is derived from a macro expansion, this rule is applied after the macro is expanded to find the appropriate place. Places defined by using defmacro or define-setf-expander use the evaluation order defined by those definitions. For example, consider the following: (defmacro wrong-order (x y) `(getf ,y ,x)) This following form evaluates place2 first and then place1 because that is the order they are evaluated in the macro expansion: (push value (wrong-order place1 place2)) 2. For the macros that manipulate places (push, pushnew, remf, incf, decf, shiftf, rotatef, psetf, setf, pop, and those defined by define-modify-macro) the subforms of the macro call are evaluated exactly once in left-to-right order, with the subforms of the places evaluated in the order specified in (1). push, pushnew, remf, incf, decf, shiftf, rotatef, psetf, pop evaluate all subforms before modifying any of the place locations. setf (in the case when setf has more than two arguments) performs its operation on each pair in sequence. For example, in (setf place1 value1 place2 value2 ...) the subforms of place1 and value1 are evaluated, the location specified by place1 is modified to contain the value returned by value1, and then the rest of the setf form is processed in a like manner. 3. For check-type, ctypecase, and ccase, subforms of the place are evaluated once as in (1), but might be evaluated again if the type check fails in the case of check-type or none of the cases hold in ctypecase and ccase. 4. For assert, the order of evaluation of the generalized references is not specified. Rules 2, 3 and 4 cover all standardized macros that manipulate places.  File: gcl.info, Node: Examples of Evaluation of Subforms to Places, Next: Setf Expansions, Prev: Evaluation of Subforms to Places, Up: Overview of Places and Generalized Reference 5.1.1.2 Examples of Evaluation of Subforms to Places .................................................... (let ((ref2 (list '()))) (push (progn (princ "1") 'ref-1) (car (progn (princ "2") ref2)))) |> 12 => (REF1) (let (x) (push (setq x (list 'a)) (car (setq x (list 'b)))) x) => (((A) . B)) push first evaluates (setq x (list 'a)) => (a), then evaluates (setq x (list 'b)) => (b), then modifies the car of this latest value to be ((a) . b).  File: gcl.info, Node: Setf Expansions, Next: Examples of Setf Expansions, Prev: Examples of Evaluation of Subforms to Places, Up: Overview of Places and Generalized Reference 5.1.1.3 Setf Expansions ....................... Sometimes it is possible to avoid evaluating subforms of a place multiple times or in the wrong order. A setf expansion for a given access form can be expressed as an ordered collection of five objects: List of temporary variables a list of symbols naming temporary variables to be bound sequentially, as if by let*, to values resulting from value forms. List of value forms a list of forms (typically, subforms of the place) which when evaluated yield the values to which the corresponding temporary variables should be bound. List of store variables a list of symbols naming temporary store variables which are to hold the new values that will be assigned to the place. Storing form a form which can reference both the temporary and the store variables, and which changes the value of the place and guarantees to return as its values the values of the store variables, which are the correct values for setf to return. Accessing form a form which can reference the temporary variables, and which returns the value of the place. The value returned by the accessing form is affected by execution of the storing form, but either of these forms might be evaluated any number of times. It is possible to do more than one setf in parallel via psetf, shiftf, and rotatef. Because of this, the setf expander must produce new temporary and store variable names every time. For examples of how to do this, see gensym. For each standardized accessor function F, unless it is explicitly documented otherwise, it is implementation-dependent whether the ability to use an F form as a setf place is implemented by a setf expander or a setf function. Also, it follows from this that it is implementation-dependent whether the name (setf F) is fbound.  File: gcl.info, Node: Examples of Setf Expansions, Prev: Setf Expansions, Up: Overview of Places and Generalized Reference 5.1.1.4 Examples of Setf Expansions ................................... Examples of the contents of the constituents of setf expansions follow. For a variable x: () ;list of temporary variables () ;list of value forms (g0001) ;list of store variables (setq x g0001) ;storing form x ;accessing form Figure 5-3: Sample Setf Expansion of a Variable For (car exp): (g0002) ;list of temporary variables (exp) ;list of value forms (g0003) ;list of store variables (progn (rplaca g0002 g0003) g0003) ;storing form (car g0002) ;accessing form Figure 5-4: Sample Setf Expansion of a CAR Form For (subseq seq s e): (g0004 g0005 g0006) ;list of temporary variables (seq s e) ;list of value forms (g0007) ;list of store variables (progn (replace g0004 g0007 :start1 g0005 :end1 g0006) g0007) ;storing form (subseq g0004 g0005 g0006) ; accessing form Figure 5-5: Sample Setf Expansion of a SUBSEQ Form In some cases, if a subform of a place is itself a place, it is necessary to expand the subform in order to compute some of the values in the expansion of the outer place. For (ldb bs (car exp)): (g0001 g0002) ;list of temporary variables (bs exp) ;list of value forms (g0003) ;list of store variables (progn (rplaca g0002 (dpb g0003 g0001 (car g0002))) g0003) ;storing form (ldb g0001 (car g0002)) ; accessing form Figure 5-6: Sample Setf Expansion of a LDB Form  File: gcl.info, Node: Kinds of Places, Next: Treatment of Other Macros Based on SETF, Prev: Overview of Places and Generalized Reference, Up: Generalized Reference 5.1.2 Kinds of Places --------------------- Several kinds of places are defined by Common Lisp; this section enumerates them. This set can be extended by implementations and by programmer code. * Menu: * Variable Names as Places:: * Function Call Forms as Places:: * VALUES Forms as Places:: * THE Forms as Places:: * APPLY Forms as Places:: * Setf Expansions and Places:: * Macro Forms as Places:: * Symbol Macros as Places:: * Other Compound Forms as Places::  File: gcl.info, Node: Variable Names as Places, Next: Function Call Forms as Places, Prev: Kinds of Places, Up: Kinds of Places 5.1.2.1 Variable Names as Places ................................ The name of a lexical variable or dynamic variable can be used as a place.  File: gcl.info, Node: Function Call Forms as Places, Next: VALUES Forms as Places, Prev: Variable Names as Places, Up: Kinds of Places 5.1.2.2 Function Call Forms as Places ..................................... A function form can be used as a place if it falls into one of the following categories: * A function call form whose first element is the name of any one of the functions in Figure 5-7. [Editorial Note by KMP: Note that what are in some places still called 'condition accessors' are deliberately omitted from this table, and are not labeled as accessors in their entries. I have not yet had time to do a full search for these items and eliminate stray references to them as 'accessors', which they are not, but I will do that at some point.] aref cdadr get bit cdar gethash caaaar cddaar logical-pathname-translations caaadr cddadr macro-function caaar cddar ninth caadar cdddar nth caaddr cddddr readtable-case caadr cdddr rest caar cddr row-major-aref cadaar cdr sbit cadadr char schar cadar class-name second caddar compiler-macro-function seventh cadddr documentation sixth caddr eighth slot-value cadr elt subseq car fdefinition svref cdaaar fifth symbol-function cdaadr fill-pointer symbol-plist cdaar find-class symbol-value cdadar first tenth cdaddr fourth third Figure 5-7: Functions that setf can be used with--1 In the case of subseq, the replacement value must be a sequence whose elements might be contained by the sequence argument to subseq, but does not have to be a sequence of the same type as the sequence of which the subsequence is specified. If the length of the replacement value does not equal the length of the subsequence to be replaced, then the shorter length determines the number of elements to be stored, as for replace. * A function call form whose first element is the name of a selector function constructed by defstruct. The function name must refer to the global function definition, rather than a locally defined function. * A function call form whose first element is the name of any one of the functions in Figure 5-8, provided that the supplied argument to that function is in turn a place form; in this case the new place has stored back into it the result of applying the supplied "update" function. Function name Argument that is a place Update function used ldb second dpb mask-field second deposit-field getf first implementation-dependent Figure 5-8: Functions that setf can be used with--2 During the setf expansion of these forms, it is necessary to call get-setf-expansion in order to figure out how the inner, nested generalized variable must be treated. The information from get-setf-expansion is used as follows. ldb In a form such as: (setf (ldb byte-spec place-form) value-form) the place referred to by the place-form must always be both read and written; note that the update is to the generalized variable specified by place-form, not to any object of type integer. Thus this setf should generate code to do the following: 1. Evaluate byte-spec (and bind it into a temporary variable). 2. Bind the temporary variables for place-form. 3. Evaluate value-form (and bind its value or values into the store variable). 4. Do the read from place-form. 5. Do the write into place-form with the given bits of the integer fetched in step 4 replaced with the value from step 3. If the evaluation of value-form in step 3 alters what is found in place-form, such as setting different bits of integer, then the change of the bits denoted by byte-spec is to that altered integer, because step 4 is done after the value-form evaluation. Nevertheless, the evaluations required for binding the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen. For example: (setq integer #x69) => #x69 (rotatef (ldb (byte 4 4) integer) (ldb (byte 4 0) integer)) integer => #x96 ;;; This example is trying to swap two independent bit fields ;;; in an integer. Note that the generalized variable of ;;; interest here is just the (possibly local) program variable ;;; integer. mask-field This case is the same as ldb in all essential aspects. getf In a form such as: (setf (getf place-form ind-form) value-form) the place referred to by place-form must always be both read and written; note that the update is to the generalized variable specified by place-form, not necessarily to the particular list that is the property list in question. Thus this setf should generate code to do the following: 1. Bind the temporary variables for place-form. 2. Evaluate ind-form (and bind it into a temporary variable). 3. Evaluate value-form (and bind its value or values into the store variable). 4. Do the read from place-form. 5. Do the write into place-form with a possibly-new property list obtained by combining the values from steps 2, 3, and 4. (Note that the phrase "possibly-new property list" can mean that the former property list is somehow destructively re-used, or it can mean partial or full copying of it. Since either copying or destructive re-use can occur, the treatment of the resultant value for the possibly-new property list must proceed as if it were a different copy needing to be stored back into the generalized variable.) If the evaluation of value-form in step 3 alters what is found in place-form, such as setting a different named property in the list, then the change of the property denoted by ind-form is to that altered list, because step 4 is done after the value-form evaluation. Nevertheless, the evaluations required for binding the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen. For example: (setq s (setq r (list (list 'a 1 'b 2 'c 3)))) => ((a 1 b 2 c 3)) (setf (getf (car r) 'b) (progn (setq r nil) 6)) => 6 r => NIL s => ((A 1 B 6 C 3)) ;;; Note that the (setq r nil) does not affect the actions of ;;; the SETF because the value of R had already been saved in ;;; a temporary variable as part of the step 1. Only the CAR ;;; of this value will be retrieved, and subsequently modified ;;; after the value computation. gcl-2.6.14/info/character.texi0000755000175000017500000001561514360276512014570 0ustar cammcamm@node Characters, Lists, Sequences and Arrays and Hash Tables, Top @chapter Characters @defun NAME-CHAR (name) Package:LISP Given an argument acceptable to string, Returns a character object whose name is NAME if one exists. Returns NIL otherwise. NAME must be an object that can be coerced to a string. @end defun @defun CHAR-NAME (char) Package:LISP Returns the name for CHAR as a string; NIL if CHAR has no name. Only #\Backspace, #\Tab, #\Newline (or #\Linefeed), #\Page, #\Return, and #\Rubout have names. @end defun @defun BOTH-CASE-P (char) Package:LISP Returns T if CHAR is an alphabetic character; NIL otherwise. Equivalent to ALPHA-CHAR-P. @end defun @defun SCHAR (simple-string index) Package:LISP Returns the character object representing the INDEX-th character in STRING. This is faster than CHAR. @end defun @defvr {Constant} CHAR-SUPER-BIT Package:LISP The bit that indicates a super character. @end defvr @defvr {Constant} CHAR-FONT-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-FONT. @end defvr @defun CHAR-DOWNCASE (char) Package:LISP Returns the lower-case equivalent of CHAR, if any. If not, simply returns CHAR. @end defun @defun STRING-CHAR-P (char) Package:LISP Returns T if CHAR can be stored in a string. In GCL, this function always returns T since any character in GCL can be stored in a string. @end defun @defun CHAR-NOT-LESSP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. @end defun @defun DISASSEMBLE (thing) Package:LISP Compiles the form specified by THING and prints the intermediate C language code for that form. But does NOT install the result of compilation. If THING is a symbol that names a not-yet-compiled function, the function definition is disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form. @end defun @defun LOWER-CASE-P (char) Package:LISP Returns T if CHAR is a lower-case character; NIL otherwise. @end defun @defun CHAR<= (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise. @end defun @defvr {Constant} CHAR-HYPER-BIT Package:LISP The bit that indicates a hyper character. @end defvr @defun CODE-CHAR (code &optional (bits 0) (font 0)) Package:LISP Returns a character object with the specified code, if any. If not, returns NIL. @end defun @defun CHAR-CODE (char) Package:LISP Returns the code attribute of CHAR. @end defun @defvr {Constant} CHAR-CONTROL-BIT Package:LISP The bit that indicates a control character. @end defvr @defun CHAR-LESSP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. @end defun @defun CHAR-FONT (char) Package:LISP Returns the font attribute of CHAR. @end defun @defun CHAR< (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. @end defun @defun CHAR>= (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-increasing order; NIL otherwise. @end defun @defvr {Constant} CHAR-META-BIT Package:LISP The bit that indicates a meta character. @end defvr @defun GRAPHIC-CHAR-P (char) Package:LISP Returns T if CHAR is a printing character, i.e., #\Space through #\~; NIL otherwise. @end defun @defun CHAR-NOT-EQUAL (char &rest more-chars) Package:LISP Returns T if no two of CHARs are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same. @end defun @defvr {Constant} CHAR-BITS-LIMIT Package:LISP The upper exclusive bound on values produced by CHAR-BITS. @end defvr @defun CHARACTERP (x) Package:LISP Returns T if X is a character; NIL otherwise. @end defun @defun CHAR= (char &rest more-chars) Package:LISP Returns T if all CHARs are the same character; NIL otherwise. @end defun @defun ALPHA-CHAR-P (char) Package:LISP Returns T if CHAR is an alphabetic character, A-Z or a-z; NIL otherwise. @end defun @defun UPPER-CASE-P (char) Package:LISP Returns T if CHAR is an upper-case character; NIL otherwise. @end defun @defun CHAR-BIT (char name) Package:LISP Returns T if the named bit is on in the character CHAR; NIL otherwise. In GCL, this function always returns NIL. @end defun @defun MAKE-CHAR (char &optional (bits 0) (font 0)) Package:LISP Returns a character object with the same code attribute as CHAR and with the specified BITS and FONT attributes. @end defun @defun CHARACTER (x) Package:LISP Coerces X into a character object if possible. @end defun @defun CHAR-EQUAL (char &rest more-chars) Package:LISP Returns T if all of its arguments are the same character; NIL otherwise. Upper case character and its lower case equivalent are regarded the same. @end defun @defun CHAR-NOT-GREATERP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly non-decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. @end defun @defun CHAR> (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise. @end defun @defun STANDARD-CHAR-P (char) Package:LISP Returns T if CHAR is a standard character, i.e., one of the 95 ASCII printing characters #\Space to #\~ and #Newline; NIL otherwise. @end defun @defun CHAR-UPCASE (char) Package:LISP Returns the upper-case equivalent of CHAR, if any. If not, simply returns CHAR. @end defun @defun DIGIT-CHAR-P (char &optional (radix 10)) Package:LISP If CHAR represents a digit in RADIX, then returns the weight as an integer. Otherwise, returns nil. @end defun @defun CHAR/= (char &rest more-chars) Package:LISP Returns T if no two of CHARs are the same character; NIL otherwise. @end defun @defun CHAR-GREATERP (char &rest more-chars) Package:LISP Returns T if the codes of CHARs are in strictly decreasing order; NIL otherwise. For a lower-case character, the code of its upper-case equivalent is used. @end defun @defun ALPHANUMERICP (char) Package:LISP Returns T if CHAR is either numeric or alphabetic; NIL otherwise. @end defun @defun CHAR-BITS (char) Package:LISP Returns the bits attribute (which is always 0 in GCL) of CHAR. @end defun @defun DIGIT-CHAR (digit &optional (radix 10) (font 0)) Package:LISP Returns a character object that represents the DIGIT in the specified RADIX. Returns NIL if no such character exists. @end defun @defun SET-CHAR-BIT (char name newvalue) Package:LISP Returns a character just like CHAR except that the named bit is set or cleared, according to whether NEWVALUE is non-NIL or NIL. This function is useless in GCL. @end defun gcl-2.6.14/info/chap-5.texi0000644000175000017500000060274214360276512013711 0ustar cammcamm @node Data and Control Flow, Iteration, Types and Classes, Top @chapter Data and Control Flow @menu * Generalized Reference:: * Transfer of Control to an Exit Point:: * Data and Control Flow Dictionary:: @end menu @node Generalized Reference, Transfer of Control to an Exit Point, Data and Control Flow, Data and Control Flow @section Generalized Reference @c including concept-places @menu * Overview of Places and Generalized Reference:: * Kinds of Places:: * Treatment of Other Macros Based on SETF:: @end menu @node Overview of Places and Generalized Reference, Kinds of Places, Generalized Reference, Generalized Reference @subsection Overview of Places and Generalized Reference A @i{generalized reference} @IGindex generalized reference is the use of a @i{form}, sometimes called a @i{place} @IGindex place , as if it were a @i{variable} that could be read and written. The @i{value} of a @i{place} is the @i{object} to which the @i{place} @i{form} evaluates. The @i{value} of a @i{place} can be changed by using @b{setf}. The concept of binding a @i{place} is not defined in @r{Common Lisp}, but an @i{implementation} is permitted to extend the language by defining this concept. Figure 5--1 contains examples of the use of @b{setf}. Note that the values returned by evaluating the @i{forms} in column two are not necessarily the same as those obtained by evaluating the @i{forms} in column three. In general, the exact @i{macro expansion} of a @b{setf} @i{form} is not guaranteed and can even be @i{implementation-dependent}; all that is guaranteed is that the expansion is an update form that works for that particular @i{implementation}, that the left-to-right evaluation of @i{subforms} is preserved, and that the ultimate result of evaluating @b{setf} is the value or values being stored. @format @group @noindent @w{ Access function Update Function Update using @b{setf} } @w{ @t{x} @t{(setq x datum)} @t{(setf x datum)} } @w{ @t{(car x)} @t{(rplaca x datum)} @t{(setf (car x) datum)} } @w{ @t{(symbol-value x)} @t{(set x datum)} @t{(setf (symbol-value x) datum)} } @noindent @w{ Figure 5--1: Examples of setf } @end group @end format Figure 5--2 shows @i{operators} relating to @i{places} and @i{generalized reference}. @format @group @noindent @w{ assert defsetf push } @w{ ccase get-setf-expansion remf } @w{ ctypecase getf rotatef } @w{ decf incf setf } @w{ define-modify-macro pop shiftf } @w{ define-setf-expander psetf } @noindent @w{ Figure 5--2: Operators relating to places and generalized reference.} @end group @end format Some of the @i{operators} above manipulate @i{places} and some manipulate @i{setf expanders}. A @i{setf expansion} can be derived from any @i{place}. New @i{setf expanders} can be defined by using @b{defsetf} and @b{define-setf-expander}. @menu * Evaluation of Subforms to Places:: * Examples of Evaluation of Subforms to Places:: * Setf Expansions:: * Examples of Setf Expansions:: @end menu @node Evaluation of Subforms to Places, Examples of Evaluation of Subforms to Places, Overview of Places and Generalized Reference, Overview of Places and Generalized Reference @subsubsection Evaluation of Subforms to Places The following rules apply to the @i{evaluation} of @i{subforms} in a @i{place}: @table @asis @item 1. The evaluation ordering of @i{subforms} within a @i{place} is determined by the order specified by the second value returned by @b{get-setf-expansion}. For all @i{places} defined by this specification (@i{e.g.}, @b{getf}, @b{ldb}, ...), this order of evaluation is left-to-right. @ITindex order of evaluation @ITindex evaluation order When a @i{place} is derived from a macro expansion, this rule is applied after the macro is expanded to find the appropriate @i{place}. @i{Places} defined by using @b{defmacro} or @b{define-setf-expander} use the evaluation order defined by those definitions. For example, consider the following: @example (defmacro wrong-order (x y) `(getf ,y ,x)) @end example This following @i{form} evaluates @t{place2} first and then @t{place1} because that is the order they are evaluated in the macro expansion: @example (push value (wrong-order place1 place2)) @end example @item 2. For the @i{macros} that manipulate @i{places} (@b{push}, @b{pushnew}, @b{remf}, @b{incf}, @b{decf}, @b{shiftf}, @b{rotatef}, @b{psetf}, @b{setf}, @b{pop}, and those defined by @b{define-modify-macro}) the @i{subforms} of the macro call are evaluated exactly once in left-to-right order, with the @i{subforms} of the @i{places} evaluated in the order specified in (1). @b{push}, @b{pushnew}, @b{remf}, @b{incf}, @b{decf}, @b{shiftf}, @b{rotatef}, @b{psetf}, @b{pop} evaluate all @i{subforms} before modifying any of the @i{place} locations. @b{setf} (in the case when @b{setf} has more than two arguments) performs its operation on each pair in sequence. For example, in @example (setf place1 value1 place2 value2 ...) @end example the @i{subforms} of @t{place1} and @t{value1} are evaluated, the location specified by @t{place1} is modified to contain the value returned by @t{value1}, and then the rest of the @b{setf} form is processed in a like manner. @item 3. For @b{check-type}, @b{ctypecase}, and @b{ccase}, @i{subforms} of the @i{place} are evaluated once as in (1), but might be evaluated again if the type check fails in the case of @b{check-type} or none of the cases hold in @b{ctypecase} and @b{ccase}. @item 4. For @b{assert}, the order of evaluation of the generalized references is not specified. @ITindex order of evaluation @ITindex evaluation order @end table Rules 2, 3 and 4 cover all @i{standardized} @i{macros} that manipulate @i{places}. @node Examples of Evaluation of Subforms to Places, Setf Expansions, Evaluation of Subforms to Places, Overview of Places and Generalized Reference @subsubsection Examples of Evaluation of Subforms to Places @example (let ((ref2 (list '()))) (push (progn (princ "1") 'ref-1) (car (progn (princ "2") ref2)))) @t{ |> } 12 @result{} (REF1) (let (x) (push (setq x (list 'a)) (car (setq x (list 'b)))) x) @result{} (((A) . B)) @end example @b{push} first evaluates @t{(setq x (list 'a)) @result{} (a)}, then evaluates @t{(setq x (list 'b)) @result{} (b)}, then modifies the @i{car} of this latest value to be @t{((a) . b)}. @node Setf Expansions, Examples of Setf Expansions, Examples of Evaluation of Subforms to Places, Overview of Places and Generalized Reference @subsubsection Setf Expansions Sometimes it is possible to avoid evaluating @i{subforms} of a @i{place} multiple times or in the wrong order. A @i{setf expansion} for a given access form can be expressed as an ordered collection of five @i{objects}: @table @asis @item @b{List of temporary variables} a list of symbols naming temporary variables to be bound sequentially, as if by @b{let*}, to @i{values} resulting from value forms. @item @b{List of value forms} a list of forms (typically, @i{subforms} of the @i{place}) which when evaluated yield the values to which the corresponding temporary variables should be bound. @item @b{List of store variables} a list of symbols naming temporary store variables which are to hold the new values that will be assigned to the @i{place}. @item @b{Storing form} a form which can reference both the temporary and the store variables, and which changes the @i{value} of the @i{place} and guarantees to return as its values the values of the store variables, which are the correct values for @b{setf} to return. @item @b{Accessing form} a @i{form} which can reference the temporary variables, and which returns the @i{value} of the @i{place}. @end table The value returned by the accessing form is affected by execution of the storing form, but either of these forms might be evaluated any number of times. It is possible to do more than one @b{setf} in parallel via @b{psetf}, @b{shiftf}, and @b{rotatef}. Because of this, the @i{setf expander} must produce new temporary and store variable names every time. For examples of how to do this, see @b{gensym}. For each @i{standardized} accessor function @i{F}, unless it is explicitly documented otherwise, it is @i{implementation-dependent} whether the ability to use an @i{F} @i{form} as a @b{setf} @i{place} is implemented by a @i{setf expander} or a @i{setf function}. Also, it follows from this that it is @i{implementation-dependent} whether the name @t{(setf @i{F})} is @i{fbound}. @node Examples of Setf Expansions, , Setf Expansions, Overview of Places and Generalized Reference @subsubsection Examples of Setf Expansions Examples of the contents of the constituents of @i{setf expansions} follow. For a variable @i{x}: @format @group @noindent @w{ @t{()} ;list of temporary variables } @w{ @t{()} ;list of value forms } @w{ @t{(g0001)} ;list of store variables } @w{ @t{(setq @i{x} g0001)} ;storing form } @w{ @i{x} ;accessing form } @noindent @w{ Figure 5--3: Sample Setf Expansion of a Variable} @end group @end format For @t{(car @i{exp})}: @format @group @noindent @w{ @t{(g0002)} ;list of temporary variables } @w{ @t{(@i{exp})} ;list of value forms } @w{ @t{(g0003)} ;list of store variables } @w{ @t{(progn (rplaca g0002 g0003) g0003)} ;storing form } @w{ @t{(car g0002)} ;accessing form } @noindent @w{ Figure 5--4: Sample Setf Expansion of a CAR Form } @end group @end format For @t{(subseq @i{seq} @i{s} @i{e})}: @format @group @noindent @w{ @t{(g0004 g0005 g0006)} ;list of temporary variables } @w{ @t{(@i{seq} @i{s} @i{e})} ;list of value forms } @w{ @t{(g0007)} ;list of store variables } @w{ @t{(progn (replace g0004 g0007 :start1 g0005 :end1 g0006) g0007)} } @w{ ;storing form } @w{ @t{(subseq g0004 g0005 g0006)} ; accessing form } @noindent @w{ Figure 5--5: Sample Setf Expansion of a SUBSEQ Form } @end group @end format In some cases, if a @i{subform} of a @i{place} is itself a @i{place}, it is necessary to expand the @i{subform} in order to compute some of the values in the expansion of the outer @i{place}. For @t{(ldb @i{bs} (car @i{exp}))}: @format @group @noindent @w{ @t{(g0001 g0002)} ;list of temporary variables } @w{ @t{(@i{bs} @i{exp})} ;list of value forms } @w{ @t{(g0003)} ;list of store variables } @w{ @t{(progn (rplaca g0002 (dpb g0003 g0001 (car g0002))) g0003)} } @w{ ;storing form } @w{ @t{(ldb g0001 (car g0002))} ; accessing form } @noindent @w{ Figure 5--6: Sample Setf Expansion of a LDB Form } @end group @end format @node Kinds of Places, Treatment of Other Macros Based on SETF, Overview of Places and Generalized Reference, Generalized Reference @subsection Kinds of Places Several kinds of @i{places} are defined by @r{Common Lisp}; this section enumerates them. This set can be extended by @i{implementations} and by @i{programmer code}. @menu * Variable Names as Places:: * Function Call Forms as Places:: * VALUES Forms as Places:: * THE Forms as Places:: * APPLY Forms as Places:: * Setf Expansions and Places:: * Macro Forms as Places:: * Symbol Macros as Places:: * Other Compound Forms as Places:: @end menu @node Variable Names as Places, Function Call Forms as Places, Kinds of Places, Kinds of Places @subsubsection Variable Names as Places The name of a @i{lexical variable} or @i{dynamic variable} can be used as a @i{place}. @node Function Call Forms as Places, VALUES Forms as Places, Variable Names as Places, Kinds of Places @subsubsection Function Call Forms as Places A @i{function form} can be used as a @i{place} if it falls into one of the following categories: @table @asis @item @t{*} A function call form whose first element is the name of any one of the functions in Figure 5--7. [Editorial Note by KMP: Note that what are in some places still called `condition accessors' are deliberately omitted from this table, and are not labeled as accessors in their entries. I have not yet had time to do a full search for these items and eliminate stray references to them as `accessors', which they are not, but I will do that at some point.] @format @group @noindent @w{ aref cdadr get } @w{ bit cdar gethash } @w{ caaaar cddaar logical-pathname-translations } @w{ caaadr cddadr macro-function } @w{ caaar cddar ninth } @w{ caadar cdddar nth } @w{ caaddr cddddr readtable-case } @w{ caadr cdddr rest } @w{ caar cddr row-major-aref } @w{ cadaar cdr sbit } @w{ cadadr char schar } @w{ cadar class-name second } @w{ caddar compiler-macro-function seventh } @w{ cadddr documentation sixth } @w{ caddr eighth slot-value } @w{ cadr elt subseq } @w{ car fdefinition svref } @w{ cdaaar fifth symbol-function } @w{ cdaadr fill-pointer symbol-plist } @w{ cdaar find-class symbol-value } @w{ cdadar first tenth } @w{ cdaddr fourth third } @noindent @w{ Figure 5--7: Functions that setf can be used with---1 } @end group @end format In the case of @b{subseq}, the replacement value must be a @i{sequence} whose elements might be contained by the sequence argument to @b{subseq}, but does not have to be a @i{sequence} of the same @i{type} as the @i{sequence} of which the subsequence is specified. If the length of the replacement value does not equal the length of the subsequence to be replaced, then the shorter length determines the number of elements to be stored, as for @b{replace}. @item @t{*} A function call form whose first element is the name of a selector function constructed by @b{defstruct}. The function name must refer to the global function definition, rather than a locally defined @i{function}. @item @t{*} A function call form whose first element is the name of any one of the functions in Figure 5--8, provided that the supplied argument to that function is in turn a @i{place} form; in this case the new @i{place} has stored back into it the result of applying the supplied ``update'' function. @format @group @noindent @w{ Function name Argument that is a @i{place} Update function used } @w{ @b{ldb} second @b{dpb} } @w{ @b{mask-field} second @b{deposit-field} } @w{ @b{getf} first @i{implementation-dependent} } @noindent @w{ Figure 5--8: Functions that setf can be used with---2 } @end group @end format During the @b{setf} expansion of these @i{forms}, it is necessary to call @b{get-setf-expansion} in order to figure out how the inner, nested generalized variable must be treated. The information from @b{get-setf-expansion} is used as follows. @table @asis @item @b{ldb} In a form such as: @t{(setf (ldb @i{byte-spec} @i{place-form}) @i{value-form})} the place referred to by the @i{place-form} must always be both @i{read} and @i{written}; note that the update is to the generalized variable specified by @i{place-form}, not to any object of @i{type} @b{integer}. Thus this @b{setf} should generate code to do the following: @table @asis @item 1. Evaluate @i{byte-spec} (and bind it into a temporary variable). @item 2. Bind the temporary variables for @i{place-form}. @item 3. Evaluate @i{value-form} (and bind its value or values into the store variable). @item 4. Do the @i{read} from @i{place-form}. @item 5. Do the @i{write} into @i{place-form} with the given bits of the @i{integer} fetched in step 4 replaced with the value from step 3. @end table If the evaluation of @i{value-form} in step 3 alters what is found in @i{place-form}, such as setting different bits of @i{integer}, then the change of the bits denoted by @i{byte-spec} is to that altered @i{integer}, because step 4 is done after the @i{value-form} evaluation. Nevertheless, the evaluations required for @i{binding} the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen. For example: @example (setq integer #x69) @result{} #x69 (rotatef (ldb (byte 4 4) integer) (ldb (byte 4 0) integer)) integer @result{} #x96 ;;; This example is trying to swap two independent bit fields ;;; in an integer. Note that the generalized variable of ;;; interest here is just the (possibly local) program variable ;;; integer. @end example @item @b{mask-field} This case is the same as @b{ldb} in all essential aspects. @item @b{getf} In a form such as: @t{(setf (getf @i{place-form} @i{ind-form}) @i{value-form})} the place referred to by @i{place-form} must always be both @i{read} and @i{written}; note that the update is to the generalized variable specified by @i{place-form}, not necessarily to the particular @i{list} that is the property list in question. Thus this @b{setf} should generate code to do the following: @table @asis @item 1. Bind the temporary variables for @i{place-form}. @item 2. Evaluate @i{ind-form} (and bind it into a temporary variable). @item 3. Evaluate @i{value-form} (and bind its value or values into the store variable). @item 4. Do the @i{read} from @i{place-form}. @item 5. Do the @i{write} into @i{place-form} with a possibly-new property list obtained by combining the values from steps 2, 3, and 4. (Note that the phrase ``possibly-new property list'' can mean that the former property list is somehow destructively re-used, or it can mean partial or full copying of it. Since either copying or destructive re-use can occur, the treatment of the resultant value for the possibly-new property list must proceed as if it were a different copy needing to be stored back into the generalized variable.) @end table If the evaluation of @i{value-form} in step 3 alters what is found in @i{place-form}, such as setting a different named property in the list, then the change of the property denoted by @i{ind-form} is to that altered list, because step 4 is done after the @i{value-form} evaluation. Nevertheless, the evaluations required for @i{binding} the temporary variables are done in steps 1 and 2, and thus the expected left-to-right evaluation order is seen. For example: @example (setq s (setq r (list (list 'a 1 'b 2 'c 3)))) @result{} ((a 1 b 2 c 3)) (setf (getf (car r) 'b) (progn (setq r nil) 6)) @result{} 6 r @result{} NIL s @result{} ((A 1 B 6 C 3)) ;;; Note that the (setq r nil) does not affect the actions of ;;; the SETF because the value of R had already been saved in ;;; a temporary variable as part of the step 1. Only the CAR ;;; of this value will be retrieved, and subsequently modified ;;; after the value computation. @end example @end table @end table @node VALUES Forms as Places, THE Forms as Places, Function Call Forms as Places, Kinds of Places @subsubsection VALUES Forms as Places A @b{values} @i{form} can be used as a @i{place}, provided that each of its @i{subforms} is also a @i{place} form. A form such as @t{(setf (values @i{place-1} \dots @i{place-n}) @i{values-form})} does the following: @table @asis @item 1. The @i{subforms} of each nested @i{place} are evaluated in left-to-right order. @item 2. The @i{values-form} is evaluated, and the first store variable from each @i{place} is bound to its return values as if by @b{multiple-value-bind}. @item 3. If the @i{setf expansion} for any @i{place} involves more than one store variable, then the additional store variables are bound to @b{nil}. @item 4. The storing forms for each @i{place} are evaluated in left-to-right order. @end table The storing form in the @i{setf expansion} of @b{values} returns as @i{multiple values}_2 the values of the store variables in step 2. That is, the number of values returned is the same as the number of @i{place} forms. This may be more or fewer values than are produced by the @i{values-form}. @node THE Forms as Places, APPLY Forms as Places, VALUES Forms as Places, Kinds of Places @subsubsection THE Forms as Places A @b{the} @i{form} can be used as a @i{place}, in which case the declaration is transferred to the @i{newvalue} form, and the resulting @b{setf} is analyzed. For example, @example (setf (the integer (cadr x)) (+ y 3)) @end example is processed as if it were @example (setf (cadr x) (the integer (+ y 3))) @end example @node APPLY Forms as Places, Setf Expansions and Places, THE Forms as Places, Kinds of Places @subsubsection APPLY Forms as Places The following situations involving @b{setf} of @b{apply} must be supported: @table @asis @item @t{*} @t{(setf (apply #'aref @i{array} @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @item @t{*} @t{(setf (apply #'bit @i{array} @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @item @t{*} @t{(setf (apply #'sbit @i{array} @{@i{subscript}@}* @i{more-subscripts}) @i{new-element})} @end table In all three cases, the @i{element} of @i{array} designated by the concatenation of @i{subscripts} and @i{more-subscripts} (@i{i.e.}, the same @i{element} which would be @i{read} by the call to @i{apply} if it were not part of a @b{setf} @i{form}) is changed to have the @i{value} given by @i{new-element}. For these usages, the function name (@b{aref}, @b{bit}, or @b{sbit}) must refer to the global function definition, rather than a locally defined @i{function}. No other @i{standardized} @i{function} is required to be supported, but an @i{implementation} may define such support. An @i{implementation} may also define support for @i{implementation-defined} @i{operators}. If a user-defined @i{function} is used in this context, the following equivalence is true, except that care is taken to preserve proper left-to-right evaluation of argument @i{subforms}: @example (setf (apply #'@i{name} @{@i{arg}@}*) @i{val}) @equiv{} (apply #'(setf @i{name}) @i{val} @{@i{arg}@}*) @end example @node Setf Expansions and Places, Macro Forms as Places, APPLY Forms as Places, Kinds of Places @subsubsection Setf Expansions and Places Any @i{compound form} for which the @i{operator} has a @i{setf expander} defined can be used as a @i{place}. The @i{operator} must refer to the global function definition, rather than a locally defined @i{function} or @i{macro}. @node Macro Forms as Places, Symbol Macros as Places, Setf Expansions and Places, Kinds of Places @subsubsection Macro Forms as Places A @i{macro form} can be used as a @i{place}, in which case @r{Common Lisp} expands the @i{macro form} as if by @b{macroexpand-1} and then uses the @i{macro expansion} in place of the original @i{place}. Such @i{macro expansion} is attempted only after exhausting all other possibilities other than expanding into a call to a function named @t{(setf @i{reader})}. @node Symbol Macros as Places, Other Compound Forms as Places, Macro Forms as Places, Kinds of Places @subsubsection Symbol Macros as Places A reference to a @i{symbol} that has been @i{established} as a @i{symbol macro} can be used as a @i{place}. In this case, @b{setf} expands the reference and then analyzes the resulting @i{form}. @node Other Compound Forms as Places, , Symbol Macros as Places, Kinds of Places @subsubsection Other Compound Forms as Places For any other @i{compound form} for which the @i{operator} is a @i{symbol} @i{f}, the @b{setf} @i{form} expands into a call to the @i{function} named @t{(setf @i{f})}. The first @i{argument} in the newly constructed @i{function form} is @i{newvalue} and the remaining @i{arguments} are the remaining @i{elements} of @i{place}. This expansion occurs regardless of whether @i{f} or @t{(setf @i{f})} is defined as a @i{function} locally, globally, or not at all. For example, @t{(setf (@i{f} @i{arg1} @i{arg2} ...) @i{new-value})} expands into a form with the same effect and value as @example (let ((#:temp-1 arg1) ;force correct order of evaluation (#:temp-2 arg2) ... (#:temp-0 @i{new-value})) (funcall (function (setf @i{f})) #:temp-0 #:temp-1 #:temp-2...)) @end example A @i{function} named @t{(setf @i{f})} must return its first argument as its only value in order to preserve the semantics of @b{setf}. @node Treatment of Other Macros Based on SETF, , Kinds of Places, Generalized Reference @subsection Treatment of Other Macros Based on SETF For each of the ``read-modify-write'' @i{operators} in Figure 5--9, and for any additional @i{macros} defined by the @i{programmer} using @b{define-modify-macro}, an exception is made to the normal rule of left-to-right evaluation of arguments. Evaluation of @i{argument} @i{forms} occurs in left-to-right order, with the exception that for the @i{place} @i{argument}, the actual @i{read} of the ``old value'' from that @i{place} happens after all of the @i{argument} @i{form} @i{evaluations}, and just before a ``new value'' is computed and @i{written} back into the @i{place}. Specifically, each of these @i{operators} can be viewed as involving a @i{form} with the following general syntax: @example (@i{operator} @{@i{preceding-form}@}* @i{place} @{@i{following-form}@}*) @end example The evaluation of each such @i{form} proceeds like this: @table @asis @item 1. @i{Evaluate} each of the @i{preceding-forms}, in left-to-right order. @item 2. @i{Evaluate} the @i{subforms} of the @i{place}, in the order specified by the second value of the @i{setf expansion} for that @i{place}. @item 3. @i{Evaluate} each of the @i{following-forms}, in left-to-right order. @item 4. @i{Read} the old value from @i{place}. @item 5. Compute the new value. @item 6. Store the new value into @i{place}. @end table @format @group @noindent @w{ decf pop pushnew } @w{ incf push remf } @noindent @w{ Figure 5--9: Read-Modify-Write Macros} @end group @end format @c end of including concept-places @node Transfer of Control to an Exit Point, Data and Control Flow Dictionary, Generalized Reference, Data and Control Flow @section Transfer of Control to an Exit Point @c including concept-exits When a transfer of control is initiated by @b{go}, @b{return-from}, or @b{throw} the following events occur in order to accomplish the transfer of control. Note that for @b{go}, the @i{exit point} is the @i{form} within the @b{tagbody} that is being executed at the time the @b{go} is performed; for @b{return-from}, the @i{exit point} is the corresponding @b{block} @i{form}; and for @b{throw}, the @i{exit point} is the corresponding @b{catch} @i{form}. @table @asis @item 1. Intervening @i{exit points} are ``abandoned'' (@i{i.e.}, their @i{extent} ends and it is no longer valid to attempt to transfer control through them). @item 2. The cleanup clauses of any intervening @b{unwind-protect} clauses are evaluated. @item 3. Intervening dynamic @i{bindings} of @b{special} variables, @i{catch tags}, @i{condition handlers}, and @i{restarts} are undone. @item 4. The @i{extent} of the @i{exit point} being invoked ends, and control is passed to the target. @end table The extent of an exit being ``abandoned'' because it is being passed over ends as soon as the transfer of control is initiated. That is, event 1 occurs at the beginning of the initiation of the transfer of control. The consequences are undefined if an attempt is made to transfer control to an @i{exit point} whose @i{dynamic extent} has ended. Events 2 and 3 are actually performed interleaved, in the order corresponding to the reverse order in which they were established. The effect of this is that the cleanup clauses of an @b{unwind-protect} see the same dynamic @i{bindings} of variables and @i{catch tags} as were visible when the @b{unwind-protect} was entered. Event 4 occurs at the end of the transfer of control. @c end of including concept-exits @node Data and Control Flow Dictionary, , Transfer of Control to an Exit Point, Data and Control Flow @section Data and Control Flow Dictionary @c including dict-flow @menu * apply:: * defun:: * fdefinition:: * fboundp:: * fmakunbound:: * flet:: * funcall:: * function (Special Operator):: * function-lambda-expression:: * functionp:: * compiled-function-p:: * call-arguments-limit:: * lambda-list-keywords:: * lambda-parameters-limit:: * defconstant:: * defparameter:: * destructuring-bind:: * let:: * progv:: * setq:: * psetq:: * block:: * catch:: * go:: * return-from:: * return:: * tagbody:: * throw:: * unwind-protect:: * nil:: * not:: * t:: * eq:: * eql:: * equal:: * equalp:: * identity:: * complement:: * constantly:: * every:: * and:: * cond:: * if:: * or:: * when:: * case:: * typecase:: * multiple-value-bind:: * multiple-value-call:: * multiple-value-list:: * multiple-value-prog1:: * multiple-value-setq:: * values:: * values-list:: * multiple-values-limit:: * nth-value:: * prog:: * prog1:: * progn:: * define-modify-macro:: * defsetf:: * define-setf-expander:: * get-setf-expansion:: * setf:: * shiftf:: * rotatef:: * control-error:: * program-error:: * undefined-function:: @end menu @node apply, defun, Data and Control Flow Dictionary, Data and Control Flow Dictionary @subsection apply [Function] @code{apply} @i{function @r{&rest} args^+} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{function}---a @i{function designator}. @i{args}---a @i{spreadable argument list designator}. @i{results}---the @i{values} returned by @i{function}. @subsubheading Description:: @i{Applies} the @i{function} to the @i{args}. When the @i{function} receives its arguments via @b{&rest}, it is permissible (but not required) for the @i{implementation} to @i{bind} the @i{rest parameter} to an @i{object} that shares structure with the last argument to @b{apply}. Because a @i{function} can neither detect whether it was called via @b{apply} nor whether (if so) the last argument to @b{apply} was a @i{constant}, @i{conforming programs} must neither rely on the @i{list} structure of a @i{rest list} to be freshly consed, nor modify that @i{list} structure. @b{setf} can be used with @b{apply} in certain circumstances; see @ref{APPLY Forms as Places}. @subsubheading Examples:: @example (setq f '+) @result{} + (apply f '(1 2)) @result{} 3 (setq f #'-) @result{} # (apply f '(1 2)) @result{} -1 (apply #'max 3 5 '(2 7 3)) @result{} 7 (apply 'cons '((+ 2 3) 4)) @result{} ((+ 2 3) . 4) (apply #'+ '()) @result{} 0 (defparameter *some-list* '(a b c)) (defun strange-test (&rest x) (eq x *some-list*)) (apply #'strange-test *some-list*) @result{} @i{implementation-dependent} (defun bad-boy (&rest x) (rplacd x 'y)) (bad-boy 'a 'b 'c) has undefined consequences. (apply #'bad-boy *some-list*) has undefined consequences. @end example @example (defun foo (size &rest keys &key double &allow-other-keys) (let ((v (apply #'make-array size :allow-other-keys t keys))) (if double (concatenate (type-of v) v v) v))) (foo 4 :initial-contents '(a b c d) :double t) @result{} #(A B C D A B C D) @end example @subsubheading See Also:: @ref{funcall} , @ref{fdefinition} , @b{function}, @ref{Evaluation}, @ref{APPLY Forms as Places} @node defun, fdefinition, apply, Data and Control Flow Dictionary @subsection defun [Macro] @code{defun} @i{function-name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{function-name} @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. @i{lambda-list}---an @i{ordinary lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{forms}---an @i{implicit progn}. @i{block-name}---the @i{function block name} of the @i{function-name}. @subsubheading Description:: Defines a new @i{function} named @i{function-name} in the @i{global environment}. The body of the @i{function} defined by @b{defun} consists of @i{forms}; they are executed as an @i{implicit progn} when the @i{function} is called. @b{defun} can be used to define a new @i{function}, to install a corrected version of an incorrect definition, to redefine an already-defined @i{function}, or to redefine a @i{macro} as a @i{function}. @b{defun} implicitly puts a @b{block} named @i{block-name} around the body @i{forms} (but not the @i{forms} in the @i{lambda-list}) of the @i{function} defined. @i{Documentation} is attached as a @i{documentation string} to @i{name} (as kind @b{function}) and to the @i{function} @i{object}. Evaluating @b{defun} causes @i{function-name} to be a global name for the @i{function} specified by the @i{lambda expression} @example (lambda @i{lambda-list} @r{[[@{@i{declaration}@}* | @i{documentation}]]} (block @i{block-name} @{@i{form}@}*)) @end example processed in the @i{lexical environment} in which @b{defun} was executed. (None of the arguments are evaluated at macro expansion time.) @b{defun} is not required to perform any compile-time side effects. In particular, @b{defun} does not make the @i{function} definition available at compile time. An @i{implementation} may choose to store information about the @i{function} for the purposes of compile-time error-checking (such as checking the number of arguments on calls), or to enable the @i{function} to be expanded inline. @subsubheading Examples:: @example (defun recur (x) (when (> x 0) (recur (1- x)))) @result{} RECUR (defun ex (a b &optional c (d 66) &rest keys &key test (start 0)) (list a b c d keys test start)) @result{} EX (ex 1 2) @result{} (1 2 NIL 66 NIL NIL 0) (ex 1 2 3 4 :test 'equal :start 50) @result{} (1 2 3 4 (:TEST EQUAL :START 50) EQUAL 50) (ex :test 1 :start 2) @result{} (:TEST 1 :START 2 NIL NIL 0) ;; This function assumes its callers have checked the types of the ;; arguments, and authorizes the compiler to build in that assumption. (defun discriminant (a b c) (declare (number a b c)) "Compute the discriminant for a quadratic equation." (- (* b b) (* 4 a c))) @result{} DISCRIMINANT (discriminant 1 2/3 -2) @result{} 76/9 ;; This function assumes its callers have not checked the types of the ;; arguments, and performs explicit type checks before making any assumptions. (defun careful-discriminant (a b c) "Compute the discriminant for a quadratic equation." (check-type a number) (check-type b number) (check-type c number) (locally (declare (number a b c)) (- (* b b) (* 4 a c)))) @result{} CAREFUL-DISCRIMINANT (careful-discriminant 1 2/3 -2) @result{} 76/9 @end example @subsubheading See Also:: @ref{flet} , @b{labels}, @ref{block} , @ref{return-from} , @b{declare}, @ref{documentation} , @ref{Evaluation}, @ref{Ordinary Lambda Lists}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: @b{return-from} can be used to return prematurely from a @i{function} defined by @b{defun}. Additional side effects might take place when additional information (typically debugging information) about the function definition is recorded. @node fdefinition, fboundp, defun, Data and Control Flow Dictionary @subsection fdefinition [Accessor] @code{fdefinition} @i{function-name} @result{} @i{definition} (setf (@code{ fdefinition} @i{function-name}) new-definition)@* @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. In the non-@b{setf} case, the @i{name} must be @i{fbound} in the @i{global environment}. @i{definition}---Current global function definition named by @i{function-name}. @i{new-definition}---a @i{function}. @subsubheading Description:: @b{fdefinition} @i{accesses} the current global function definition named by @i{function-name}. The definition may be a @i{function} or may be an @i{object} representing a @i{special form} or @i{macro}. The value returned by @b{fdefinition} when @b{fboundp} returns true but the @i{function-name} denotes a @i{macro} or @i{special form} is not well-defined, but @b{fdefinition} does not signal an error. @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{function-name} is not a @i{function name}. An error of @i{type} @b{undefined-function} is signaled in the non-@b{setf} case if @i{function-name} is not @i{fbound}. @subsubheading See Also:: @ref{fboundp} , @ref{fmakunbound} , @ref{macro-function} , @ref{special-operator-p} , @ref{symbol-function} @subsubheading Notes:: @b{fdefinition} cannot @i{access} the value of a lexical function name produced by @b{flet} or @b{labels}; it can @i{access} only the global function value. @b{setf} can be used with @b{fdefinition} to replace a global function definition when the @i{function-name}'s function definition does not represent a @i{special form}. @b{setf} of @b{fdefinition} requires a @i{function} as the new value. It is an error to set the @b{fdefinition} of a @i{function-name} to a @i{symbol}, a @i{list}, or the value returned by @b{fdefinition} on the name of a @i{macro} or @i{special form}. @node fboundp, fmakunbound, fdefinition, Data and Control Flow Dictionary @subsection fboundp [Function] @code{fboundp} @i{name} @result{} @i{generalized-boolean} @subsubheading Pronunciation:: pronounced ,ef 'baund p\=e @subsubheading Arguments and Values:: @i{name}---a @i{function name}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{name} is @i{fbound}; otherwise, returns @i{false}. @subsubheading Examples:: @example (fboundp 'car) @result{} @i{true} (fboundp 'nth-value) @result{} @i{false} (fboundp 'with-open-file) @result{} @i{true} (fboundp 'unwind-protect) @result{} @i{true} (defun my-function (x) x) @result{} MY-FUNCTION (fboundp 'my-function) @result{} @i{true} (let ((saved-definition (symbol-function 'my-function))) (unwind-protect (progn (fmakunbound 'my-function) (fboundp 'my-function)) (setf (symbol-function 'my-function) saved-definition))) @result{} @i{false} (fboundp 'my-function) @result{} @i{true} (defmacro my-macro (x) `',x) @result{} MY-MACRO (fboundp 'my-macro) @result{} @i{true} (fmakunbound 'my-function) @result{} MY-FUNCTION (fboundp 'my-function) @result{} @i{false} (flet ((my-function (x) x)) (fboundp 'my-function)) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{name} is not a @i{function name}. @subsubheading See Also:: @ref{symbol-function} , @ref{fmakunbound} , @ref{fdefinition} @subsubheading Notes:: It is permissible to call @b{symbol-function} on any @i{symbol} that is @i{fbound}. @b{fboundp} is sometimes used to ``guard'' an access to the @i{function cell}, as in: @example (if (fboundp x) (symbol-function x)) @end example Defining a @i{setf expander} @i{F} does not cause the @i{setf function} @t{(setf @i{F})} to become defined. @node fmakunbound, flet, fboundp, Data and Control Flow Dictionary @subsection fmakunbound [Function] @code{fmakunbound} @i{name} @result{} @i{name} @subsubheading Pronunciation:: pronounced ,ef 'mak e n,baund or pronounced ,ef 'm\=a k e n,baund @subsubheading Arguments and Values:: @i{name}---a @i{function name}. @subsubheading Description:: Removes the @i{function} or @i{macro} definition, if any, of @i{name} in the @i{global environment}. @subsubheading Examples:: @example (defun add-some (x) (+ x 19)) @result{} ADD-SOME (fboundp 'add-some) @result{} @i{true} (flet ((add-some (x) (+ x 37))) (fmakunbound 'add-some) (add-some 1)) @result{} 38 (fboundp 'add-some) @result{} @i{false} @end example @subsubheading Exceptional Situations:: Should signal an error of @i{type} @b{type-error} if @i{name} is not a @i{function name}. The consequences are undefined if @i{name} is a @i{special operator}. @subsubheading See Also:: @ref{fboundp} , @ref{makunbound} @node flet, funcall, fmakunbound, Data and Control Flow Dictionary @subsection flet, labels, macrolet [Special Operator] @code{flet} @i{@r{(}@{@r{(}@i{function-name} @i{lambda-list} @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} @{@i{local-form}@}*@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @code{labels} @i{@r{(}@{@r{(}@i{function-name} @i{lambda-list} @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} @{@i{local-form}@}*@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @code{macrolet} @i{@r{(}@{@r{(}@i{name} @i{lambda-list} @r{[[@{@i{local-declaration}@}* | @i{local-documentation}]]} @{@i{local-form}@}*@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{function-name}---a @i{function name}. @i{name}---a @i{symbol}. @i{lambda-list}---a @i{lambda list}; for @b{flet} and @b{labels}, it is an @i{ordinary lambda list}; for @b{macrolet}, it is a @i{macro lambda list}. @i{local-declaration}---a @b{declare} @i{expression}; not evaluated. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{local-documentation}---a @i{string}; not evaluated. @i{local-forms}, @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms}. @subsubheading Description:: @b{flet}, @b{labels}, and @b{macrolet} define local @i{functions} and @i{macros}, and execute @i{forms} using the local definitions. @i{Forms} are executed in order of occurrence. The body forms (but not the @i{lambda list}) of each @i{function} created by @b{flet} and @b{labels} and each @i{macro} created by @b{macrolet} are enclosed in an @i{implicit block} whose name is the @i{function block name} of the @i{function-name} or @i{name}, as appropriate. The scope of the @i{declarations} between the list of local function/macro definitions and the body @i{forms} in @b{flet} and @b{labels} does not include the bodies of the locally defined @i{functions}, except that for @b{labels}, any @b{inline}, @b{notinline}, or @b{ftype} declarations that refer to the locally defined functions do apply to the local function bodies. That is, their @i{scope} is the same as the function name that they affect. The scope of these @i{declarations} does not include the bodies of the macro expander functions defined by @b{macrolet}. @table @asis @item flet @b{flet} defines locally named @i{functions} and executes a series of @i{forms} with these definition @i{bindings}. Any number of such local @i{functions} can be defined. The @i{scope} of the name @i{binding} encompasses only the body. Within the body of @b{flet}, @i{function-names} matching those defined by @b{flet} refer to the locally defined @i{functions} rather than to the global function definitions of the same name. Also, within the scope of @b{flet}, global @i{setf expander} definitions of the @i{function-name} defined by @b{flet} do not apply. Note that this applies to @t{(defsetf @i{f} ...)}, not @t{(defmethod (setf @i{f}) ...)}. The names of @i{functions} defined by @b{flet} are in the @i{lexical environment}; they retain their local definitions only within the body of @b{flet}. The function definition bindings are visible only in the body of @b{flet}, not the definitions themselves. Within the function definitions, local function names that match those being defined refer to @i{functions} or @i{macros} defined outside the @b{flet}. @b{flet} can locally @i{shadow} a global function name, and the new definition can refer to the global definition. Any @i{local-documentation} is attached to the corresponding local @i{function} (if one is actually created) as a @i{documentation string}. @item labels @b{labels} is equivalent to @b{flet} except that the scope of the defined function names for @b{labels} encompasses the function definitions themselves as well as the body. @item macrolet @b{macrolet} establishes local @i{macro} definitions, using the same format used by @b{defmacro}. Within the body of @b{macrolet}, global @i{setf expander} definitions of the @i{names} defined by the @b{macrolet} do not apply; rather, @b{setf} expands the @i{macro form} and recursively process the resulting @i{form}. The macro-expansion functions defined by @b{macrolet} are defined in the @i{lexical environment} in which the @b{macrolet} form appears. Declarations and @b{macrolet} and @b{symbol-macrolet} definitions affect the local macro definitions in a @b{macrolet}, but the consequences are undefined if the local macro definitions reference any local @i{variable} or @i{function} @i{bindings} that are visible in that @i{lexical environment}. Any @i{local-documentation} is attached to the corresponding local @i{macro function} as a @i{documentation string}. @end table @subsubheading Examples:: @example (defun foo (x flag) (macrolet ((fudge (z) ;The parameters x and flag are not accessible ; at this point; a reference to flag would be to ; the global variable of that name. ` (if flag (* ,z ,z) ,z))) ;The parameters x and flag are accessible here. (+ x (fudge x) (fudge (+ x 1))))) @equiv{} (defun foo (x flag) (+ x (if flag (* x x) x) (if flag (* (+ x 1) (+ x 1)) (+ x 1)))) @end example after macro expansion. The occurrences of @t{x} and @t{flag} legitimately refer to the parameters of the function @t{foo} because those parameters are visible at the site of the macro call which produced the expansion. @example (flet ((flet1 (n) (+ n n))) (flet ((flet1 (n) (+ 2 (flet1 n)))) (flet1 2))) @result{} 6 (defun dummy-function () 'top-level) @result{} DUMMY-FUNCTION (funcall #'dummy-function) @result{} TOP-LEVEL (flet ((dummy-function () 'shadow)) (funcall #'dummy-function)) @result{} SHADOW (eq (funcall #'dummy-function) (funcall 'dummy-function)) @result{} @i{true} (flet ((dummy-function () 'shadow)) (eq (funcall #'dummy-function) (funcall 'dummy-function))) @result{} @i{false} (defun recursive-times (k n) (labels ((temp (n) (if (zerop n) 0 (+ k (temp (1- n)))))) (temp n))) @result{} RECURSIVE-TIMES (recursive-times 2 3) @result{} 6 (defmacro mlets (x &environment env) (let ((form `(babbit ,x))) (macroexpand form env))) @result{} MLETS (macrolet ((babbit (z) `(+ ,z ,z))) (mlets 5)) @result{} 10 @end example @example (flet ((safesqrt (x) (sqrt (abs x)))) ;; The safesqrt function is used in two places. (safesqrt (apply #'+ (map 'list #'safesqrt '(1 2 3 4 5 6))))) @result{} 3.291173 @end example @example (defun integer-power (n k) (declare (integer n)) (declare (type (integer 0 *) k)) (labels ((expt0 (x k a) (declare (integer x a) (type (integer 0 *) k)) (cond ((zerop k) a) ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a))))) (expt1 (x k a) (declare (integer x a) (type (integer 0 *) k)) (cond ((evenp k) (expt1 (* x x) (floor k 2) a)) (t (expt0 (* x x) (floor k 2) (* x a)))))) (expt0 n k 1))) @result{} INTEGER-POWER @end example @example (defun example (y l) (flet ((attach (x) (setq l (append l (list x))))) (declare (inline attach)) (dolist (x y) (unless (null (cdr x)) (attach x))) l)) (example '((a apple apricot) (b banana) (c cherry) (d) (e)) '((1) (2) (3) (4 2) (5) (6 3 2))) @result{} ((1) (2) (3) (4 2) (5) (6 3 2) (A APPLE APRICOT) (B BANANA) (C CHERRY)) @end example @subsubheading See Also:: @b{declare}, @ref{defmacro} , @ref{defun} , @ref{documentation} , @ref{let} , @ref{Evaluation}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: It is not possible to define recursive @i{functions} with @b{flet}. @b{labels} can be used to define mutually recursive @i{functions}. If a @b{macrolet} @i{form} is a @i{top level form}, the body @i{forms} are also processed as @i{top level forms}. See @ref{File Compilation}. @node funcall, function (Special Operator), flet, Data and Control Flow Dictionary @subsection funcall [Function] @code{funcall} @i{function @r{&rest} args} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{function}---a @i{function designator}. @i{args}---@i{arguments} to the @i{function}. @i{results}---the @i{values} returned by the @i{function}. @subsubheading Description:: @b{funcall} applies @i{function} to @i{args}. If @i{function} is a @i{symbol}, it is coerced to a @i{function} as if by finding its @i{functional value} in the @i{global environment}. @subsubheading Examples:: @example (funcall #'+ 1 2 3) @result{} 6 (funcall 'car '(1 2 3)) @result{} 1 (funcall 'position 1 '(1 2 3 2 1) :start 1) @result{} 4 (cons 1 2) @result{} (1 . 2) (flet ((cons (x y) `(kons ,x ,y))) (let ((cons (symbol-function '+))) (funcall #'cons (funcall 'cons 1 2) (funcall cons 1 2)))) @result{} (KONS (1 . 2) 3) @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{undefined-function} should be signaled if @i{function} is a @i{symbol} that does not have a global definition as a @i{function} or that has a global definition as a @i{macro} or a @i{special operator}. @subsubheading See Also:: @ref{apply} , @b{function}, @ref{Evaluation} @subsubheading Notes:: @example (funcall @i{function} @i{arg1} @i{arg2} ...) @equiv{} (apply @i{function} @i{arg1} @i{arg2} ... nil) @equiv{} (apply @i{function} (list @i{arg1} @i{arg2} ...)) @end example The difference between @b{funcall} and an ordinary function call is that in the former case the @i{function} is obtained by ordinary @i{evaluation} of a @i{form}, and in the latter case it is obtained by the special interpretation of the function position that normally occurs. @node function (Special Operator), function-lambda-expression, funcall, Data and Control Flow Dictionary @subsection function [Special Operator] @code{function} @i{name} @result{} @i{function} @subsubheading Arguments and Values:: @i{name}---a @i{function name} or @i{lambda expression}. @i{function}---a @i{function} @i{object}. @subsubheading Description:: The @i{value} of @b{function} is the @i{functional value} of @i{name} in the current @i{lexical environment}. If @i{name} is a @i{function name}, the functional definition of that name is that established by the innermost lexically enclosing @b{flet}, @b{labels}, or @b{macrolet} @i{form}, if there is one. Otherwise the global functional definition of the @i{function name} is returned. If @i{name} is a @i{lambda expression}, then a @i{lexical closure} is returned. In situations where a @i{closure} over the same set of @i{bindings} might be produced more than once, the various resulting @i{closures} might or might not be @b{eq}. It is an error to use @b{function} on a @i{function name} that does not denote a @i{function} in the lexical environment in which the @b{function} form appears. Specifically, it is an error to use @b{function} on a @i{symbol} that denotes a @i{macro} or @i{special form}. An implementation may choose not to signal this error for performance reasons, but implementations are forbidden from defining the failure to signal an error as a useful behavior. @subsubheading Examples:: @example (defun adder (x) (function (lambda (y) (+ x y)))) @end example The result of @t{(adder 3)} is a function that adds @t{3} to its argument: @example (setq add3 (adder 3)) (funcall add3 5) @result{} 8 @end example This works because @b{function} creates a @i{closure} of the @i{lambda expression} that is able to refer to the @i{value} @t{3} of the variable @t{x} even after control has returned from the function @t{adder}. @subsubheading See Also:: @ref{defun} , @ref{fdefinition} , @ref{flet} , @b{labels}, @ref{symbol-function} , @ref{Symbols as Forms}, @ref{Sharpsign Single-Quote}, @ref{Printing Other Objects} @subsubheading Notes:: The notation @t{#'@i{name}} may be used as an abbreviation for @t{(function @i{name})}. @node function-lambda-expression, functionp, function (Special Operator), Data and Control Flow Dictionary @subsection function-lambda-expression [Function] @code{function-lambda-expression} @i{function}@* @result{} @i{lambda-expression, closure-p, name} @subsubheading Arguments and Values:: @i{function}---a @i{function}. @i{lambda-expression}---a @i{lambda expression} or @b{nil}. @i{closure-p}---a @i{generalized boolean}. @i{name}---an @i{object}. @subsubheading Description:: Returns information about @i{function} as follows: The @i{primary value}, @i{lambda-expression}, is @i{function}'s defining @i{lambda expression}, or @b{nil} if the information is not available. The @i{lambda expression} may have been pre-processed in some ways, but it should remain a suitable argument to @b{compile} or @b{function}. Any @i{implementation} may legitimately return @b{nil} as the @i{lambda-expression} of any @i{function}. The @i{secondary value}, @i{closure-p}, is @b{nil} if @i{function}'s definition was enclosed in the @i{null lexical environment} or something @i{non-nil} if @i{function}'s definition might have been enclosed in some @i{non-null lexical environment}. Any @i{implementation} may legitimately return @i{true} as the @i{closure-p} of any @i{function}. The @i{tertiary value}, @i{name}, is the ``name'' of @i{function}. The name is intended for debugging only and is not necessarily one that would be valid for use as a name in @b{defun} or @b{function}, for example. By convention, @b{nil} is used to mean that @i{function} has no name. Any @i{implementation} may legitimately return @b{nil} as the @i{name} of any @i{function}. @subsubheading Examples:: The following examples illustrate some possible return values, but are not intended to be exhaustive: @example (function-lambda-expression #'(lambda (x) x)) @result{} NIL, @i{false}, NIL @i{OR}@result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA (X) X), @i{true}, NIL @i{OR}@result{} (LAMBDA (X) X), @i{false}, NIL (function-lambda-expression (funcall #'(lambda () #'(lambda (x) x)))) @result{} NIL, @i{false}, NIL @i{OR}@result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA (X) X), @i{true}, NIL @i{OR}@result{} (LAMBDA (X) X), @i{false}, NIL (function-lambda-expression (funcall #'(lambda (x) #'(lambda () x)) nil)) @result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA () X), @i{true}, NIL @i{NOT}@result{} NIL, @i{false}, NIL @i{NOT}@result{} (LAMBDA () X), @i{false}, NIL (flet ((foo (x) x)) (setf (symbol-function 'bar) #'foo) (function-lambda-expression #'bar)) @result{} NIL, @i{false}, NIL @i{OR}@result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA (X) (BLOCK FOO X)), @i{true}, NIL @i{OR}@result{} (LAMBDA (X) (BLOCK FOO X)), @i{false}, FOO @i{OR}@result{} (SI::BLOCK-LAMBDA FOO (X) X), @i{false}, FOO (defun foo () (flet ((bar (x) x)) #'bar)) (function-lambda-expression (foo)) @result{} NIL, @i{false}, NIL @i{OR}@result{} NIL, @i{true}, NIL @i{OR}@result{} (LAMBDA (X) (BLOCK BAR X)), @i{true}, NIL @i{OR}@result{} (LAMBDA (X) (BLOCK BAR X)), @i{true}, (:INTERNAL FOO 0 BAR) @i{OR}@result{} (LAMBDA (X) (BLOCK BAR X)), @i{false}, "BAR in FOO" @end example @subsubheading Notes:: Although @i{implementations} are free to return ``@b{nil}, @i{true}, @b{nil}'' in all cases, they are encouraged to return a @i{lambda expression} as the @i{primary value} in the case where the argument was created by a call to @b{compile} or @b{eval} (as opposed to being created by @i{loading} a @i{compiled file}). @node functionp, compiled-function-p, function-lambda-expression, Data and Control Flow Dictionary @subsection functionp [Function] @code{functionp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{function}; otherwise, returns @i{false}. @subsubheading Examples:: @example (functionp 'append) @result{} @i{false} (functionp #'append) @result{} @i{true} (functionp (symbol-function 'append)) @result{} @i{true} (flet ((f () 1)) (functionp #'f)) @result{} @i{true} (functionp (compile nil '(lambda () 259))) @result{} @i{true} (functionp nil) @result{} @i{false} (functionp 12) @result{} @i{false} (functionp '(lambda (x) (* x x))) @result{} @i{false} (functionp #'(lambda (x) (* x x))) @result{} @i{true} @end example @subsubheading Notes:: @example (functionp @i{object}) @equiv{} (typep @i{object} 'function) @end example @node compiled-function-p, call-arguments-limit, functionp, Data and Control Flow Dictionary @subsection compiled-function-p [Function] @code{compiled-function-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{compiled-function}; otherwise, returns @i{false}. @subsubheading Examples:: @example (defun f (x) x) @result{} F (compiled-function-p #'f) @result{} @i{false} @i{OR}@result{} @i{true} (compiled-function-p 'f) @result{} @i{false} (compile 'f) @result{} F (compiled-function-p #'f) @result{} @i{true} (compiled-function-p 'f) @result{} @i{false} (compiled-function-p (compile nil '(lambda (x) x))) @result{} @i{true} (compiled-function-p #'(lambda (x) x)) @result{} @i{false} @i{OR}@result{} @i{true} (compiled-function-p '(lambda (x) x)) @result{} @i{false} @end example @subsubheading See Also:: @ref{compile} , @ref{compile-file} , @ref{compiled-function} @subsubheading Notes:: @example (compiled-function-p @i{object}) @equiv{} (typep @i{object} 'compiled-function) @end example @node call-arguments-limit, lambda-list-keywords, compiled-function-p, Data and Control Flow Dictionary @subsection call-arguments-limit [Constant Variable] @subsubheading Constant Value:: An integer not smaller than @t{50} and at least as great as the @i{value} of @b{lambda-parameters-limit}, the exact magnitude of which is @i{implementation-dependent}. @subsubheading Description:: The upper exclusive bound on the number of @i{arguments} that may be passed to a @i{function}. @subsubheading See Also:: @ref{lambda-parameters-limit} , @ref{multiple-values-limit} @node lambda-list-keywords, lambda-parameters-limit, call-arguments-limit, Data and Control Flow Dictionary @subsection lambda-list-keywords [Constant Variable] @subsubheading Constant Value:: a @i{list}, the @i{elements} of which are @i{implementation-dependent}, but which must contain at least the @i{symbols} @b{&allow-other-keys}, @b{&aux}, @b{&body}, @b{&environment}, @b{&key}, @b{&optional}, @b{&rest}, and @b{&whole}. @subsubheading Description:: A @i{list} of all the @i{lambda list keywords} used in the @i{implementation}, including the additional ones used only by @i{macro} definition @i{forms}. @subsubheading See Also:: @ref{defun} , @ref{flet} , @ref{defmacro} , @b{macrolet}, @ref{The Evaluation Model} @node lambda-parameters-limit, defconstant, lambda-list-keywords, Data and Control Flow Dictionary @subsection lambda-parameters-limit [Constant Variable] @subsubheading Constant Value:: @i{implementation-dependent}, but not smaller than @t{50}. @subsubheading Description:: A positive @i{integer} that is the upper exclusive bound on the number of @i{parameter} @i{names} that can appear in a single @i{lambda list}. @subsubheading See Also:: @ref{call-arguments-limit} @subsubheading Notes:: Implementors are encouraged to make the @i{value} of @b{lambda-parameters-limit} as large as possible. @node defconstant, defparameter, lambda-parameters-limit, Data and Control Flow Dictionary @subsection defconstant [Macro] @code{defconstant} @i{name initial-value @r{[}documentation@r{]}} @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}; not evaluated. @i{initial-value}---a @i{form}; evaluated. @i{documentation}---a @i{string}; not evaluated. @subsubheading Description:: @b{defconstant} causes the global variable named by @i{name} to be given a value that is the result of evaluating @i{initial-value}. A constant defined by @b{defconstant} can be redefined with @b{defconstant}. However, the consequences are undefined if an attempt is made to assign a @i{value} to the @i{symbol} using another operator, or to assign it to a @i{different} @i{value} using a subsequent @b{defconstant}. If @i{documentation} is supplied, it is attached to @i{name} as a @i{documentation string} of kind @b{variable}. @b{defconstant} normally appears as a @i{top level form}, but it is meaningful for it to appear as a @i{non-top-level form}. However, the compile-time side effects described below only take place when @b{defconstant} appears as a @i{top level form}. The consequences are undefined if there are any @i{bindings} of the variable named by @i{name} at the time @b{defconstant} is executed or if the value is not @b{eql} to the value of @i{initial-value}. The consequences are undefined when constant @i{symbols} are rebound as either lexical or dynamic variables. In other words, a reference to a @i{symbol} declared with @b{defconstant} always refers to its global value. The side effects of the execution of @b{defconstant} must be equivalent to at least the side effects of the execution of the following code: @example (setf (symbol-value '@i{name}) @i{initial-value}) (setf (documentation '@i{name} 'variable) '@i{documentation}) @end example If a @b{defconstant} @i{form} appears as a @i{top level form}, the @i{compiler} must recognize that @i{name} names a @i{constant variable}. An implementation may choose to evaluate the value-form at compile time, load time, or both. Therefore, users must ensure that the @i{initial-value} can be @i{evaluated} at compile time (regardless of whether or not references to @i{name} appear in the file) and that it always @i{evaluates} to the same value. [Editorial Note by KMP: Does ``same value'' here mean eql or similar?] [Reviewer Note by Moon: Probably depends on whether load time is compared to compile time, or two compiles.] @subsubheading Examples:: @example (defconstant this-is-a-constant 'never-changing "for a test") @result{} THIS-IS-A-CONSTANT this-is-a-constant @result{} NEVER-CHANGING (documentation 'this-is-a-constant 'variable) @result{} "for a test" (constantp 'this-is-a-constant) @result{} @i{true} @end example @subsubheading See Also:: @ref{declaim} , @ref{defparameter} , @b{defvar}, @ref{documentation} , @ref{proclaim} , @ref{Constant Variables}, @ref{Compilation} @node defparameter, destructuring-bind, defconstant, Data and Control Flow Dictionary @subsection defparameter, defvar [Macro] @code{defparameter} @i{name initial-value @r{[}documentation@r{]} } @result{} @i{name} @code{defvar} @i{name @t{[}initial-value @r{[}documentation@r{]}@t{]}} @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}; not evaluated. @i{initial-value}---a @i{form}; for @b{defparameter}, it is always @i{evaluated}, but for @b{defvar} it is @i{evaluated} only if @i{name} is not already @i{bound}. @i{documentation}---a @i{string}; not evaluated. @subsubheading Description:: @b{defparameter} and @b{defvar} @i{establish} @i{name} as a @i{dynamic variable}. @b{defparameter} unconditionally @i{assigns} the @i{initial-value} to the @i{dynamic variable} named @i{name}. @b{defvar}, by contrast, @i{assigns} @i{initial-value} (if supplied) to the @i{dynamic variable} named @i{name} only if @i{name} is not already @i{bound}. If no @i{initial-value} is supplied, @b{defvar} leaves the @i{value cell} of the @i{dynamic variable} named @i{name} undisturbed; if @i{name} was previously @i{bound}, its old @i{value} persists, and if it was previously @i{unbound}, it remains @i{unbound}. If @i{documentation} is supplied, it is attached to @i{name} as a @i{documentation string} of kind @b{variable}. @b{defparameter} and @b{defvar} normally appear as a @i{top level form}, but it is meaningful for them to appear as @i{non-top-level forms}. However, the compile-time side effects described below only take place when they appear as @i{top level forms}. @subsubheading Examples:: @example (defparameter *p* 1) @result{} *P* *p* @result{} 1 (constantp '*p*) @result{} @i{false} (setq *p* 2) @result{} 2 (defparameter *p* 3) @result{} *P* *p* @result{} 3 (defvar *v* 1) @result{} *V* *v* @result{} 1 (constantp '*v*) @result{} @i{false} (setq *v* 2) @result{} 2 (defvar *v* 3) @result{} *V* *v* @result{} 2 (defun foo () (let ((*p* 'p) (*v* 'v)) (bar))) @result{} FOO (defun bar () (list *p* *v*)) @result{} BAR (foo) @result{} (P V) @end example The principal operational distinction between @b{defparameter} and @b{defvar} is that @b{defparameter} makes an unconditional assignment to @i{name}, while @b{defvar} makes a conditional one. In practice, this means that @b{defparameter} is useful in situations where loading or reloading the definition would want to pick up a new value of the variable, while @b{defvar} is used in situations where the old value would want to be retained if the file were loaded or reloaded. For example, one might create a file which contained: @example (defvar *the-interesting-numbers* '()) (defmacro define-interesting-number (name n) `(progn (defvar ,name ,n) (pushnew ,name *the-interesting-numbers*) ',name)) (define-interesting-number *my-height* 168) ;cm (define-interesting-number *my-weight* 13) ;stones @end example Here the initial value, @t{()}, for the variable @t{*the-interesting-numbers*} is just a seed that we are never likely to want to reset to something else once something has been grown from it. As such, we have used @b{defvar} to avoid having the @t{*interesting-numbers*} information reset if the file is loaded a second time. It is true that the two calls to @b{define-interesting-number} here would be reprocessed, but if there were additional calls in another file, they would not be and that information would be lost. On the other hand, consider the following code: @example (defparameter *default-beep-count* 3) (defun beep (&optional (n *default-beep-count*)) (dotimes (i n) (si: @end example Here we could easily imagine editing the code to change the initial value of @t{*default-beep-count*}, and then reloading the file to pick up the new value. In order to make value updating easy, we have used @b{defparameter}. On the other hand, there is potential value to using @b{defvar} in this situation. For example, suppose that someone had predefined an alternate value for @t{*default-beep-count*}, or had loaded the file and then manually changed the value. In both cases, if we had used @b{defvar} instead of @b{defparameter}, those user preferences would not be overridden by (re)loading the file. The choice of whether to use @b{defparameter} or @b{defvar} has visible consequences to programs, but is nevertheless often made for subjective reasons. @subsubheading Side Effects:: If a @b{defvar} or @b{defparameter} @i{form} appears as a @i{top level form}, the @i{compiler} must recognize that the @i{name} has been proclaimed @b{special}. However, it must neither @i{evaluate} the @i{initial-value} @i{form} nor @i{assign} the @i{dynamic variable} named @i{name} at compile time. There may be additional (@i{implementation-defined}) compile-time or run-time side effects, as long as such effects do not interfere with the correct operation of @i{conforming programs}. @subsubheading Affected By:: @b{defvar} is affected by whether @i{name} is already @i{bound}. @subsubheading See Also:: @ref{declaim} , @ref{defconstant} , @ref{documentation} , @ref{Compilation} @subsubheading Notes:: It is customary to name @i{dynamic variables} with an @i{asterisk} at the beginning and end of the name. e.g., @t{*foo*} is a good name for a @i{dynamic variable}, but not for a @i{lexical variable}; @t{foo} is a good name for a @i{lexical variable}, but not for a @i{dynamic variable}. This naming convention is observed for all @i{defined names} in @r{Common Lisp}; however, neither @i{conforming programs} nor @i{conforming implementations} are obliged to adhere to this convention. The intent of the permission for additional side effects is to allow @i{implementations} to do normal ``bookkeeping'' that accompanies definitions. For example, the @i{macro expansion} of a @b{defvar} or @b{defparameter} @i{form} might include code that arranges to record the name of the source file in which the definition occurs. @b{defparameter} and @b{defvar} might be defined as follows: @example (defmacro defparameter (name initial-value &optional (documentation nil documentation-p)) `(progn (declaim (special ,name)) (setf (symbol-value ',name) ,initial-value) ,(when documentation-p `(setf (documentation ',name 'variable) ',documentation)) ',name)) (defmacro defvar (name &optional (initial-value nil initial-value-p) (documentation nil documentation-p)) `(progn (declaim (special ,name)) ,(when initial-value-p `(unless (boundp ',name) (setf (symbol-value ',name) ,initial-value))) ,(when documentation-p `(setf (documentation ',name 'variable) ',documentation)) ',name)) @end example @node destructuring-bind, let, defparameter, Data and Control Flow Dictionary @subsection destructuring-bind [Macro] @code{destructuring-bind} @i{lambda-list expression @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{lambda-list}---a @i{destructuring lambda list}. @i{expression}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{destructuring-bind} binds the variables specified in @i{lambda-list} to the corresponding values in the tree structure resulting from the evaluation of @i{expression}; then @b{destructuring-bind} evaluates @i{forms}. The @i{lambda-list} supports destructuring as described in @ref{Destructuring Lambda Lists}. @subsubheading Examples:: @example (defun iota (n) (loop for i from 1 to n collect i)) ;helper (destructuring-bind ((a &optional (b 'bee)) one two three) `((alpha) ,@@(iota 3)) (list a b three two one)) @result{} (ALPHA BEE 3 2 1) @end example @subsubheading Exceptional Situations:: If the result of evaluating the @i{expression} does not match the destructuring pattern, an error of @i{type} @b{error} should be signaled. @subsubheading See Also:: @b{macrolet}, @ref{defmacro} @node let, progv, destructuring-bind, Data and Control Flow Dictionary @subsection let, let* [Special Operator] @code{let} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @code{let*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{symbol}. @i{init-form}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{form}---a @i{form}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{let} and @b{let*} create new variable @i{bindings} and execute a series of @i{forms} that use these @i{bindings}. @b{let} performs the @i{bindings} in parallel and @b{let*} does them sequentially. The form @example (let ((@i{var1} @i{init-form-1}) (@i{var2} @i{init-form-2}) ... (@i{varm} @i{init-form-m})) @i{declaration1} @i{declaration2} ... @i{declarationp} @i{form1} @i{form2} ... @i{formn}) @end example first evaluates the expressions @i{init-form-1}, @i{init-form-2}, and so on, in that order, saving the resulting values. Then all of the variables @i{varj} are bound to the corresponding values; each @i{binding} is lexical unless there is a @b{special} declaration to the contrary. The expressions @i{formk} are then evaluated in order; the values of all but the last are discarded (that is, the body of a @b{let} is an @i{implicit progn}). @b{let*} is similar to @b{let}, but the @i{bindings} of variables are performed sequentially rather than in parallel. The expression for the @i{init-form} of a @i{var} can refer to @i{vars} previously bound in the @b{let*}. The form @example (let* ((@i{var1} @i{init-form-1}) (@i{var2} @i{init-form-2}) ... (@i{varm} @i{init-form-m})) @i{declaration1} @i{declaration2} ... @i{declarationp} @i{form1} @i{form2} ... @i{formn}) @end example first evaluates the expression @i{init-form-1}, then binds the variable @i{var1} to that value; then it evaluates @i{init-form-2} and binds @i{var2}, and so on. The expressions @i{formj} are then evaluated in order; the values of all but the last are discarded (that is, the body of @b{let*} is an implicit @b{progn}). For both @b{let} and @b{let*}, if there is not an @i{init-form} associated with a @i{var}, @i{var} is initialized to @b{nil}. The special form @b{let} has the property that the @i{scope} of the name binding does not include any initial value form. For @b{let*}, a variable's @i{scope} also includes the remaining initial value forms for subsequent variable bindings. @subsubheading Examples:: @example (setq a 'top) @result{} TOP (defun dummy-function () a) @result{} DUMMY-FUNCTION (let ((a 'inside) (b a)) (format nil "~S ~S ~S" a b (dummy-function))) @result{} "INSIDE TOP TOP" (let* ((a 'inside) (b a)) (format nil "~S ~S ~S" a b (dummy-function))) @result{} "INSIDE INSIDE TOP" (let ((a 'inside) (b a)) (declare (special a)) (format nil "~S ~S ~S" a b (dummy-function))) @result{} "INSIDE TOP INSIDE" @end example The code @example (let (x) (declare (integer x)) (setq x (gcd y z)) ...) @end example is incorrect; although @t{x} is indeed set before it is used, and is set to a value of the declared type @i{integer}, nevertheless @t{x} initially takes on the value @b{nil} in violation of the type declaration. @subsubheading See Also:: @ref{progv} @node progv, setq, let, Data and Control Flow Dictionary @subsection progv [Special Operator] @code{progv} @i{@i{symbols} @i{values} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{symbols}---a @i{list} of @i{symbols}; evaluated. @i{values}---a @i{list} of @i{objects}; evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: @b{progv} creates new dynamic variable @i{bindings} and executes each @i{form} using those @i{bindings}. Each @i{form} is evaluated in order. @b{progv} allows @i{binding} one or more dynamic variables whose names may be determined at run time. Each @i{form} is evaluated in order with the dynamic variables whose names are in @i{symbols} bound to corresponding @i{values}. If too few @i{values} are supplied, the remaining @i{symbols} are bound and then made to have no value. If too many @i{values} are supplied, the excess values are ignored. The @i{bindings} of the dynamic variables are undone on exit from @b{progv}. @subsubheading Examples:: @example (setq *x* 1) @result{} 1 (progv '(*x*) '(2) *x*) @result{} 2 *x* @result{} 1 Assuming *x* is not globally special, (let ((*x* 3)) (progv '(*x*) '(4) (list *x* (symbol-value '*x*)))) @result{} (3 4) @end example @subsubheading See Also:: @ref{let} , @ref{Evaluation} @subsubheading Notes:: Among other things, @b{progv} is useful when writing interpreters for languages embedded in @r{Lisp}; it provides a handle on the mechanism for @i{binding} @i{dynamic variables}. @node setq, psetq, progv, Data and Control Flow Dictionary @subsection setq [Special Form] @code{setq} @i{@{!@i{pair}@}*} @result{} @i{result} @w{@i{pair} ::=var form} @subsubheading Pronunciation:: pronounced 'set ,ky\"u @subsubheading Arguments and Values:: @i{var}---a @i{symbol} naming a @i{variable} other than a @i{constant variable}. @i{form}---a @i{form}. @i{result}---the @i{primary value} of the last @i{form}, or @b{nil} if no @i{pairs} were supplied. @subsubheading Description:: Assigns values to @i{variables}. @t{(setq @i{var1} @i{form1} @i{var2} @i{form2} ...)} is the simple variable assignment statement of @r{Lisp}. First @i{form1} is evaluated and the result is stored in the variable @i{var1}, then @i{form2} is evaluated and the result stored in @i{var2}, and so forth. @b{setq} may be used for assignment of both lexical and dynamic variables. If any @i{var} refers to a @i{binding} made by @b{symbol-macrolet}, then that @i{var} is treated as if @b{setf} (not @b{setq}) had been used. @subsubheading Examples:: @example ;; A simple use of SETQ to establish values for variables. (setq a 1 b 2 c 3) @result{} 3 a @result{} 1 b @result{} 2 c @result{} 3 ;; Use of SETQ to update values by sequential assignment. (setq a (1+ b) b (1+ a) c (+ a b)) @result{} 7 a @result{} 3 b @result{} 4 c @result{} 7 ;; This illustrates the use of SETQ on a symbol macro. (let ((x (list 10 20 30))) (symbol-macrolet ((y (car x)) (z (cadr x))) (setq y (1+ z) z (1+ y)) (list x y z))) @result{} ((21 22 30) 21 22) @end example @subsubheading Side Effects:: The @i{primary value} of each @i{form} is assigned to the corresponding @i{var}. @subsubheading See Also:: @ref{psetq} , @ref{set} , @ref{setf} @node psetq, block, setq, Data and Control Flow Dictionary @subsection psetq [Macro] @code{psetq} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} @w{@i{pair} ::=var form} @subsubheading Pronunciation:: @b{psetq}: pronounced @tex p\=e'set ,ky\"u @end tex @subsubheading Arguments and Values:: @i{var}---a @i{symbol} naming a @i{variable} other than a @i{constant variable}. @i{form}---a @i{form}. @subsubheading Description:: Assigns values to @i{variables}. This is just like @b{setq}, except that the assignments happen ``in parallel.'' That is, first all of the forms are evaluated, and only then are the variables set to the resulting values. In this way, the assignment to one variable does not affect the value computation of another in the way that would occur with @b{setq}'s sequential assignment. If any @i{var} refers to a @i{binding} made by @b{symbol-macrolet}, then that @i{var} is treated as if @b{psetf} (not @b{psetq}) had been used. @subsubheading Examples:: @example ;; A simple use of PSETQ to establish values for variables. ;; As a matter of style, many programmers would prefer SETQ ;; in a simple situation like this where parallel assignment ;; is not needed, but the two have equivalent effect. (psetq a 1 b 2 c 3) @result{} NIL a @result{} 1 b @result{} 2 c @result{} 3 ;; Use of PSETQ to update values by parallel assignment. ;; The effect here is very different than if SETQ had been used. (psetq a (1+ b) b (1+ a) c (+ a b)) @result{} NIL a @result{} 3 b @result{} 2 c @result{} 3 ;; Use of PSETQ on a symbol macro. (let ((x (list 10 20 30))) (symbol-macrolet ((y (car x)) (z (cadr x))) (psetq y (1+ z) z (1+ y)) (list x y z))) @result{} ((21 11 30) 21 11) ;; Use of parallel assignment to swap values of A and B. (let ((a 1) (b 2)) (psetq a b b a) (values a b)) @result{} 2, 1 @end example @subsubheading Side Effects:: The values of @i{forms} are assigned to @i{vars}. @subsubheading See Also:: @b{psetf}, @ref{setq} @node block, catch, psetq, Data and Control Flow Dictionary @subsection block [Special Operator] @code{block} @i{@i{name} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{form}---a @i{form}. @i{results}---the @i{values} of the @i{forms} if a @i{normal return} occurs, or else, if an @i{explicit return} occurs, the @i{values} that were transferred. @subsubheading Description:: @b{block} @i{establishes} a @i{block} named @i{name} and then evaluates @i{forms} as an @i{implicit progn}. The @i{special operators} @b{block} and @b{return-from} work together to provide a structured, lexical, non-local exit facility. At any point lexically contained within @i{forms}, @b{return-from} can be used with the given @i{name} to return control and values from the @b{block} @i{form}, except when an intervening @i{block} with the same name has been @i{established}, in which case the outer @i{block} is shadowed by the inner one. The @i{block} named @i{name} has @i{lexical scope} and @i{dynamic extent}. Once established, a @i{block} may only be exited once, whether by @i{normal return} or @i{explicit return}. @subsubheading Examples:: @example (block empty) @result{} NIL (block whocares (values 1 2) (values 3 4)) @result{} 3, 4 (let ((x 1)) (block stop (setq x 2) (return-from stop) (setq x 3)) x) @result{} 2 (block early (return-from early (values 1 2)) (values 3 4)) @result{} 1, 2 (block outer (block inner (return-from outer 1)) 2) @result{} 1 (block twin (block twin (return-from twin 1)) 2) @result{} 2 ;; Contrast behavior of this example with corresponding example of CATCH. (block b (flet ((b1 () (return-from b 1))) (block b (b1) (print 'unreachable)) 2)) @result{} 1 @end example @subsubheading See Also:: @ref{return} , @ref{return-from} , @ref{Evaluation} @subsubheading Notes:: @node catch, go, block, Data and Control Flow Dictionary @subsection catch [Special Operator] @code{catch} @i{@i{tag} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{tag}---a @i{catch tag}; evaluated. @i{forms}---an @i{implicit progn}. @i{results}---if the @i{forms} exit normally, the @i{values} returned by the @i{forms}; if a throw occurs to the @i{tag}, the @i{values} that are thrown. @subsubheading Description:: @b{catch} is used as the destination of a non-local control transfer by @b{throw}. @i{Tags} are used to find the @b{catch} to which a @b{throw} is transferring control. @t{(catch 'foo @i{form})} catches a @t{(throw 'foo @i{form})} but not a @t{(throw 'bar @i{form})}. The order of execution of @b{catch} follows: @ITindex order of evaluation @ITindex evaluation order @table @asis @item 1. @i{Tag} is evaluated. It serves as the name of the @b{catch}. @item 2. @i{Forms} are then evaluated as an implicit @b{progn}, and the results of the last @i{form} are returned unless a @b{throw} occurs. @item 3. If a @b{throw} occurs during the execution of one of the @i{forms}, control is transferred to the @b{catch} @i{form} whose @i{tag} is @b{eq} to the tag argument of the @b{throw} and which is the most recently established @b{catch} with that @i{tag}. No further evaluation of @i{forms} occurs. @item 4. The @i{tag} @i{established} by @b{catch} is @i{disestablished} just before the results are returned. @end table If during the execution of one of the @i{forms}, a @b{throw} is executed whose tag is @b{eq} to the @b{catch} tag, then the values specified by the @b{throw} are returned as the result of the dynamically most recently established @b{catch} form with that tag. The mechanism for @b{catch} and @b{throw} works even if @b{throw} is not within the lexical scope of @b{catch}. @b{throw} must occur within the @i{dynamic extent} of the @i{evaluation} of the body of a @b{catch} with a corresponding @i{tag}. @subsubheading Examples:: @example (catch 'dummy-tag 1 2 (throw 'dummy-tag 3) 4) @result{} 3 (catch 'dummy-tag 1 2 3 4) @result{} 4 (defun throw-back (tag) (throw tag t)) @result{} THROW-BACK (catch 'dummy-tag (throw-back 'dummy-tag) 2) @result{} T ;; Contrast behavior of this example with corresponding example of BLOCK. (catch 'c (flet ((c1 () (throw 'c 1))) (catch 'c (c1) (print 'unreachable)) 2)) @result{} 2 @end example @subsubheading Exceptional Situations:: An error of @i{type} @b{control-error} is signaled if @b{throw} is done when there is no suitable @b{catch} @i{tag}. @subsubheading See Also:: @ref{throw} , @ref{Evaluation} @subsubheading Notes:: It is customary for @i{symbols} to be used as @i{tags}, but any @i{object} is permitted. However, numbers should not be used because the comparison is done using @b{eq}. @b{catch} differs from @b{block} in that @b{catch} tags have dynamic @i{scope} while @b{block} names have @i{lexical scope}. @node go, return-from, catch, Data and Control Flow Dictionary @subsection go [Special Operator] @code{go} @i{tag} @result{} # @subsubheading Arguments and Values:: @i{tag}---a @i{go tag}. @subsubheading Description:: @b{go} transfers control to the point in the body of an enclosing @b{tagbody} form labeled by a tag @b{eql} to @i{tag}. If there is no such @i{tag} in the body, the bodies of lexically containing @b{tagbody} @i{forms} (if any) are examined as well. If several tags are @b{eql} to @i{tag}, control is transferred to whichever matching @i{tag} is contained in the innermost @b{tagbody} form that contains the @b{go}. The consequences are undefined if there is no matching @i{tag} lexically visible to the point of the @b{go}. The transfer of control initiated by @b{go} is performed as described in @ref{Transfer of Control to an Exit Point}. @subsubheading Examples:: @example (tagbody (setq val 2) (go lp) (incf val 3) lp (incf val 4)) @result{} NIL val @result{} 6 @end example The following is in error because there is a normal exit of the @b{tagbody} before the @b{go} is executed. @example (let ((a nil)) (tagbody t (setq a #'(lambda () (go t)))) (funcall a)) @end example The following is in error because the @b{tagbody} is passed over before the @b{go} @i{form} is executed. @example (funcall (block nil (tagbody a (return #'(lambda () (go a)))))) @end example @subsubheading See Also:: @ref{tagbody} @node return-from, return, go, Data and Control Flow Dictionary @subsection return-from [Special Operator] @code{return-from} @i{@i{name} @r{[}@i{result}@r{]}} @result{} # @subsubheading Arguments and Values:: @i{name}---a @i{block tag}; not evaluated. @i{result}---a @i{form}; evaluated. The default is @b{nil}. @subsubheading Description:: Returns control and @i{multiple values}_2 from a lexically enclosing @i{block}. A @b{block} @i{form} named @i{name} must lexically enclose the occurrence of @b{return-from}; any @i{values} @i{yielded} by the @i{evaluation} of @i{result} are immediately returned from the innermost such lexically enclosing @i{block}. The transfer of control initiated by @b{return-from} is performed as described in @ref{Transfer of Control to an Exit Point}. @subsubheading Examples:: @example (block alpha (return-from alpha) 1) @result{} NIL (block alpha (return-from alpha 1) 2) @result{} 1 (block alpha (return-from alpha (values 1 2)) 3) @result{} 1, 2 (let ((a 0)) (dotimes (i 10) (incf a) (when (oddp i) (return))) a) @result{} 2 (defun temp (x) (if x (return-from temp 'dummy)) 44) @result{} TEMP (temp nil) @result{} 44 (temp t) @result{} DUMMY (block out (flet ((exit (n) (return-from out n))) (block out (exit 1))) 2) @result{} 1 (block nil (unwind-protect (return-from nil 1) (return-from nil 2))) @result{} 2 (dolist (flag '(nil t)) (block nil (let ((x 5)) (declare (special x)) (unwind-protect (return-from nil) (print x)))) (print 'here)) @t{ |> } 5 @t{ |> } HERE @t{ |> } 5 @t{ |> } HERE @result{} NIL (dolist (flag '(nil t)) (block nil (let ((x 5)) (declare (special x)) (unwind-protect (if flag (return-from nil)) (print x)))) (print 'here)) @t{ |> } 5 @t{ |> } HERE @t{ |> } 5 @t{ |> } HERE @result{} NIL @end example The following has undefined consequences because the @b{block} @i{form} exits normally before the @b{return-from} @i{form} is attempted. @example (funcall (block nil #'(lambda () (return-from nil)))) is an error. @end example @subsubheading See Also:: @ref{block} , @ref{return} , @ref{Evaluation} @node return, tagbody, return-from, Data and Control Flow Dictionary @subsection return [Macro] @code{return} @i{@r{[}@i{result}@r{]}} @result{} # @subsubheading Arguments and Values:: @i{result}---a @i{form}; evaluated. The default is @b{nil}. @subsubheading Description:: Returns, as if by @b{return-from}, from the @i{block} named @b{nil}. @subsubheading Examples:: @example (block nil (return) 1) @result{} NIL (block nil (return 1) 2) @result{} 1 (block nil (return (values 1 2)) 3) @result{} 1, 2 (block nil (block alpha (return 1) 2)) @result{} 1 (block alpha (block nil (return 1)) 2) @result{} 2 (block nil (block nil (return 1) 2)) @result{} 1 @end example @subsubheading See Also:: @ref{block} , @ref{return-from} , @ref{Evaluation} @subsubheading Notes:: @example (return) @equiv{} (return-from nil) (return @i{form}) @equiv{} (return-from nil @i{form}) @end example The @i{implicit blocks} @i{established} by @i{macros} such as @b{do} are often named @b{nil}, so that @b{return} can be used to exit from such @i{forms}. @node tagbody, throw, return, Data and Control Flow Dictionary @subsection tagbody [Special Operator] @code{tagbody} @i{@{@i{tag} | @i{statement}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @subsubheading Description:: Executes zero or more @i{statements} in a @i{lexical environment} that provides for control transfers to labels indicated by the @i{tags}. The @i{statements} in a @b{tagbody} are @i{evaluated} in order from left to right, and their @i{values} are discarded. If at any time there are no remaining @i{statements}, @b{tagbody} returns @b{nil}. However, if @t{(go @i{tag})} is @i{evaluated}, control jumps to the part of the body labeled with the @i{tag}. (Tags are compared with @b{eql}.) A @i{tag} established by @b{tagbody} has @i{lexical scope} and has @i{dynamic extent}. Once @b{tagbody} has been exited, it is no longer valid to @b{go} to a @i{tag} in its body. It is permissible for @b{go} to jump to a @b{tagbody} that is not the innermost @b{tagbody} containing that @b{go}; the @i{tags} established by a @b{tagbody} only shadow other @i{tags} of like name. The determination of which elements of the body are @i{tags} and which are @i{statements} is made prior to any @i{macro expansion} of that element. If a @i{statement} is a @i{macro form} and its @i{macro expansion} is an @i{atom}, that @i{atom} is treated as a @i{statement}, not a @i{tag}. @subsubheading Examples:: @example (let (val) (tagbody (setq val 1) (go point-a) (incf val 16) point-c (incf val 04) (go point-b) (incf val 32) point-a (incf val 02) (go point-c) (incf val 64) point-b (incf val 08)) val) @result{} 15 (defun f1 (flag) (let ((n 1)) (tagbody (setq n (f2 flag #'(lambda () (go out)))) out (prin1 n)))) @result{} F1 (defun f2 (flag escape) (if flag (funcall escape) 2)) @result{} F2 (f1 nil) @t{ |> } 2 @result{} NIL (f1 t) @t{ |> } 1 @result{} NIL @end example @subsubheading See Also:: @ref{go} @subsubheading Notes:: The @i{macros} in Figure 5--10 have @i{implicit tagbodies}. @format @group @noindent @w{ do do-external-symbols dotimes } @w{ do* do-symbols prog } @w{ do-all-symbols dolist prog* } @noindent @w{ Figure 5--10: Macros that have implicit tagbodies.} @end group @end format @node throw, unwind-protect, tagbody, Data and Control Flow Dictionary @subsection throw [Special Operator] @code{throw} @i{tag result-form} @result{} # @subsubheading Arguments and Values:: @i{tag}---a @i{catch tag}; evaluated. @i{result-form}---a @i{form}; evaluated as described below. @subsubheading Description:: @b{throw} causes a non-local control transfer to a @b{catch} whose tag is @b{eq} to @i{tag}. @i{Tag} is evaluated first to produce an @i{object} called the throw tag; then @i{result-form} is evaluated, and its results are saved. If the @i{result-form} produces multiple values, then all the values are saved. The most recent outstanding @b{catch} whose @i{tag} is @b{eq} to the throw tag is exited; the saved results are returned as the value or values of @b{catch}. The transfer of control initiated by @b{throw} is performed as described in @ref{Transfer of Control to an Exit Point}. @subsubheading Examples:: @example (catch 'result (setq i 0 j 0) (loop (incf j 3) (incf i) (if (= i 3) (throw 'result (values i j))))) @result{} 3, 9 @end example @example (catch nil (unwind-protect (throw nil 1) (throw nil 2))) @result{} 2 @end example The consequences of the following are undefined because the @b{catch} of @t{b} is passed over by the first @b{throw}, hence portable programs must assume that its @i{dynamic extent} is terminated. The @i{binding} of the @i{catch tag} is not yet @i{disestablished} and therefore it is the target of the second @b{throw}. @example (catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))) @end example The following prints ``@t{The inner catch returns :SECOND-THROW}'' and then returns @t{:outer-catch}. @example (catch 'foo (format t "The inner catch returns ~s.~ (catch 'foo (unwind-protect (throw 'foo :first-throw) (throw 'foo :second-throw)))) :outer-catch) @t{ |> } The inner catch returns :SECOND-THROW @result{} :OUTER-CATCH @end example @subsubheading Exceptional Situations:: If there is no outstanding @i{catch tag} that matches the throw tag, no unwinding of the stack is performed, and an error of @i{type} @b{control-error} is signaled. When the error is signaled, the @i{dynamic environment} is that which was in force at the point of the @b{throw}. @subsubheading See Also:: @ref{block} , @ref{catch} , @ref{return-from} , @ref{unwind-protect} , @ref{Evaluation} @subsubheading Notes:: @b{catch} and @b{throw} are normally used when the @i{exit point} must have @i{dynamic scope} (@i{e.g.}, the @b{throw} is not lexically enclosed by the @b{catch}), while @b{block} and @b{return} are used when @i{lexical scope} is sufficient. @node unwind-protect, nil, throw, Data and Control Flow Dictionary @subsection unwind-protect [Special Operator] @code{unwind-protect} @i{@i{protected-form} @{@i{cleanup-form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{protected-form}---a @i{form}. @i{cleanup-form}---a @i{form}. @i{results}---the @i{values} of the @i{protected-form}. @subsubheading Description:: @b{unwind-protect} evaluates @i{protected-form} and guarantees that @i{cleanup-forms} are executed before @b{unwind-protect} exits, whether it terminates normally or is aborted by a control transfer of some kind. @b{unwind-protect} is intended to be used to make sure that certain side effects take place after the evaluation of @i{protected-form}. If a @i{non-local exit} occurs during execution of @i{cleanup-forms}, no special action is taken. The @i{cleanup-forms} of @b{unwind-protect} are not protected by that @b{unwind-protect}. @b{unwind-protect} protects against all attempts to exit from @i{protected-form}, including @b{go}, @b{handler-case}, @b{ignore-errors}, @b{restart-case}, @b{return-from}, @b{throw}, and @b{with-simple-restart}. Undoing of @i{handler} and @i{restart} @i{bindings} during an exit happens in parallel with the undoing of the bindings of @i{dynamic variables} and @b{catch} tags, in the reverse order in which they were established. The effect of this is that @i{cleanup-form} sees the same @i{handler} and @i{restart} @i{bindings}, as well as @i{dynamic variable} @i{bindings} and @b{catch} tags, as were visible when the @b{unwind-protect} was entered. @subsubheading Examples:: @example (tagbody (let ((x 3)) (unwind-protect (if (numberp x) (go out)) (print x))) out ...) @end example When @b{go} is executed, the call to @b{print} is executed first, and then the transfer of control to the tag @t{out} is completed. @example (defun dummy-function (x) (setq state 'running) (unless (numberp x) (throw 'abort 'not-a-number)) (setq state (1+ x))) @result{} DUMMY-FUNCTION (catch 'abort (dummy-function 1)) @result{} 2 state @result{} 2 (catch 'abort (dummy-function 'trash)) @result{} NOT-A-NUMBER state @result{} RUNNING (catch 'abort (unwind-protect (dummy-function 'trash) (setq state 'aborted))) @result{} NOT-A-NUMBER state @result{} ABORTED @end example The following code is not correct: @example (unwind-protect (progn (incf *access-count*) (perform-access)) (decf *access-count*)) @end example If an exit occurs before completion of @b{incf}, the @b{decf} @i{form} is executed anyway, resulting in an incorrect value for @t{*access-count*}. The correct way to code this is as follows: @example (let ((old-count *access-count*)) (unwind-protect (progn (incf *access-count*) (perform-access)) (setq *access-count* old-count))) @end example @example ;;; The following returns 2. (block nil (unwind-protect (return 1) (return 2))) ;;; The following has undefined consequences. (block a (block b (unwind-protect (return-from a 1) (return-from b 2)))) ;;; The following returns 2. (catch nil (unwind-protect (throw nil 1) (throw nil 2))) ;;; The following has undefined consequences because the catch of B is ;;; passed over by the first THROW, hence portable programs must assume ;;; its dynamic extent is terminated. The binding of the catch tag is not ;;; yet disestablished and therefore it is the target of the second throw. (catch 'a (catch 'b (unwind-protect (throw 'a 1) (throw 'b 2)))) ;;; The following prints "The inner catch returns :SECOND-THROW" ;;; and then returns :OUTER-CATCH. (catch 'foo (format t "The inner catch returns ~s.~ (catch 'foo (unwind-protect (throw 'foo :first-throw) (throw 'foo :second-throw)))) :outer-catch) ;;; The following returns 10. The inner CATCH of A is passed over, but ;;; because that CATCH is disestablished before the THROW to A is executed, ;;; it isn't seen. (catch 'a (catch 'b (unwind-protect (1+ (catch 'a (throw 'b 1))) (throw 'a 10)))) ;;; The following has undefined consequences because the extent of ;;; the (CATCH 'BAR ...) exit ends when the (THROW 'FOO ...) ;;; commences. (catch 'foo (catch 'bar (unwind-protect (throw 'foo 3) (throw 'bar 4) (print 'xxx)))) ;;; The following returns 4; XXX is not printed. ;;; The (THROW 'FOO ...) has no effect on the scope of the BAR ;;; catch tag or the extent of the (CATCH 'BAR ...) exit. (catch 'bar (catch 'foo (unwind-protect (throw 'foo 3) (throw 'bar 4) (print 'xxx)))) ;;; The following prints 5. (block nil (let ((x 5)) (declare (special x)) (unwind-protect (return) (print x)))) @end example @subsubheading See Also:: @ref{catch} , @ref{go} , @ref{handler-case} , @ref{restart-case} , @ref{return} , @ref{return-from} , @ref{throw} , @ref{Evaluation} @node nil, not, unwind-protect, Data and Control Flow Dictionary @subsection nil [Constant Variable] @subsubheading Constant Value:: @b{nil}. @subsubheading Description:: @b{nil} represents both @i{boolean} (and @i{generalized boolean}) @i{false} and the @i{empty list}. @subsubheading Examples:: @example nil @result{} NIL @end example @subsubheading See Also:: @ref{t} @node not, t, nil, Data and Control Flow Dictionary @subsection not [Function] @code{not} @i{x} @result{} @i{boolean} @subsubheading Arguments and Values:: @i{x}---a @i{generalized boolean} (@i{i.e.}, any @i{object}). @i{boolean}---a @i{boolean}. @subsubheading Description:: Returns @b{t} if @i{x} is @i{false}; otherwise, returns @b{nil}. @subsubheading Examples:: @example (not nil) @result{} T (not '()) @result{} T (not (integerp 'sss)) @result{} T (not (integerp 1)) @result{} NIL (not 3.7) @result{} NIL (not 'apple) @result{} NIL @end example @subsubheading See Also:: @ref{null} @subsubheading Notes:: @b{not} is intended to be used to invert the `truth value' of a @i{boolean} (or @i{generalized boolean}) whereas @b{null} is intended to be used to test for the @i{empty list}. Operationally, @b{not} and @b{null} compute the same result; which to use is a matter of style. @node t, eq, not, Data and Control Flow Dictionary @subsection t [Constant Variable] @subsubheading Constant Value:: @b{t}. @subsubheading Description:: The @i{boolean} representing true, and the canonical @i{generalized boolean} representing true. Although any @i{object} other than @b{nil} is considered @i{true}, @b{t} is generally used when there is no special reason to prefer one such @i{object} over another. The @i{symbol} @b{t} is also sometimes used for other purposes as well. For example, as the @i{name} of a @i{class}, as a @i{designator} (@i{e.g.}, a @i{stream designator}) or as a special symbol for some syntactic reason (@i{e.g.}, in @b{case} and @b{typecase} to label the @i{otherwise-clause}). @subsubheading Examples:: @example t @result{} T (eq t 't) @result{} @i{true} (find-class 't) @result{} # (case 'a (a 1) (t 2)) @result{} 1 (case 'b (a 1) (t 2)) @result{} 2 (prin1 'hello t) @t{ |> } HELLO @result{} HELLO @end example @subsubheading See Also:: @ref{NIL} @node eq, eql, t, Data and Control Flow Dictionary @subsection eq [Function] @code{eq} @i{x y} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{x}---an @i{object}. @i{y}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if its @i{arguments} are the same, identical @i{object}; otherwise, returns @i{false}. @subsubheading Examples:: @example (eq 'a 'b) @result{} @i{false} (eq 'a 'a) @result{} @i{true} (eq 3 3) @result{} @i{true} @i{OR}@result{} @i{false} (eq 3 3.0) @result{} @i{false} (eq 3.0 3.0) @result{} @i{true} @i{OR}@result{} @i{false} (eq #c(3 -4) #c(3 -4)) @result{} @i{true} @i{OR}@result{} @i{false} (eq #c(3 -4.0) #c(3 -4)) @result{} @i{false} (eq (cons 'a 'b) (cons 'a 'c)) @result{} @i{false} (eq (cons 'a 'b) (cons 'a 'b)) @result{} @i{false} (eq '(a . b) '(a . b)) @result{} @i{true} @i{OR}@result{} @i{false} (progn (setq x (cons 'a 'b)) (eq x x)) @result{} @i{true} (progn (setq x '(a . b)) (eq x x)) @result{} @i{true} (eq #\A #\A) @result{} @i{true} @i{OR}@result{} @i{false} (let ((x "Foo")) (eq x x)) @result{} @i{true} (eq "Foo" "Foo") @result{} @i{true} @i{OR}@result{} @i{false} (eq "Foo" (copy-seq "Foo")) @result{} @i{false} (eq "FOO" "foo") @result{} @i{false} (eq "string-seq" (copy-seq "string-seq")) @result{} @i{false} (let ((x 5)) (eq x x)) @result{} @i{true} @i{OR}@result{} @i{false} @end example @subsubheading See Also:: @ref{eql} , @ref{equal} , @ref{equalp} , @ref{=} , @ref{Compilation} @subsubheading Notes:: @i{Objects} that appear the same when printed are not necessarily @b{eq} to each other. @i{Symbols} that print the same usually are @b{eq} to each other because of the use of the @b{intern} function. However, @i{numbers} with the same value need not be @b{eq}, and two similar @i{lists} are usually not @i{identical}. An implementation is permitted to make ``copies'' of @i{characters} and @i{numbers} at any time. The effect is that @r{Common Lisp} makes no guarantee that @b{eq} is true even when both its arguments are ``the same thing'' if that thing is a @i{character} or @i{number}. Most @r{Common Lisp} @i{operators} use @b{eql} rather than @b{eq} to compare objects, or else they default to @b{eql} and only use @b{eq} if specifically requested to do so. However, the following @i{operators} are defined to use @b{eq} rather than @b{eql} in a way that cannot be overridden by the @i{code} which employs them: @format @group @noindent @w{ catch getf throw } @w{ get remf } @w{ get-properties remprop } @noindent @w{ Figure 5--11: Operators that always prefer EQ over EQL} @end group @end format @node eql, equal, eq, Data and Control Flow Dictionary @subsection eql [Function] @code{eql} @i{x y} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{x}---an @i{object}. @i{y}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: The value of @b{eql} is @i{true} of two objects, @i{x} and @i{y}, in the folowing cases: @table @asis @item 1. If @i{x} and @i{y} are @b{eq}. @item 2. If @i{x} and @i{y} are both @i{numbers} of the same @i{type} and the same value. @item 3. If they are both @i{characters} that represent the same character. @end table Otherwise the value of @b{eql} is @i{false}. If an implementation supports positive and negative zeros as @i{distinct} values, then @t{(eql 0.0 -0.0)} returns @i{false}. Otherwise, when the syntax @t{-0.0} is read it is interpreted as the value @t{0.0}, and so @t{(eql 0.0 -0.0)} returns @i{true}. @subsubheading Examples:: @example (eql 'a 'b) @result{} @i{false} (eql 'a 'a) @result{} @i{true} (eql 3 3) @result{} @i{true} (eql 3 3.0) @result{} @i{false} (eql 3.0 3.0) @result{} @i{true} (eql #c(3 -4) #c(3 -4)) @result{} @i{true} (eql #c(3 -4.0) #c(3 -4)) @result{} @i{false} (eql (cons 'a 'b) (cons 'a 'c)) @result{} @i{false} (eql (cons 'a 'b) (cons 'a 'b)) @result{} @i{false} (eql '(a . b) '(a . b)) @result{} @i{true} @i{OR}@result{} @i{false} (progn (setq x (cons 'a 'b)) (eql x x)) @result{} @i{true} (progn (setq x '(a . b)) (eql x x)) @result{} @i{true} (eql #\A #\A) @result{} @i{true} (eql "Foo" "Foo") @result{} @i{true} @i{OR}@result{} @i{false} (eql "Foo" (copy-seq "Foo")) @result{} @i{false} (eql "FOO" "foo") @result{} @i{false} @end example Normally @t{(eql 1.0s0 1.0d0)} is false, under the assumption that @t{1.0s0} and @t{1.0d0} are of distinct data types. However, implementations that do not provide four distinct floating-point formats are permitted to ``collapse'' the four formats into some smaller number of them; in such an implementation @t{(eql 1.0s0 1.0d0)} might be true. @subsubheading See Also:: @ref{eq} , @ref{equal} , @ref{equalp} , @ref{=} , @ref{char=} @subsubheading Notes:: @b{eql} is the same as @b{eq}, except that if the arguments are @i{characters} or @i{numbers} of the same type then their values are compared. Thus @b{eql} tells whether two @i{objects} are conceptually the same, whereas @b{eq} tells whether two @i{objects} are implementationally identical. It is for this reason that @b{eql}, not @b{eq}, is the default comparison predicate for @i{operators} that take @i{sequences} as arguments. @b{eql} may not be true of two @i{floats} even when they represent the same value. @b{=} is used to compare mathematical values. Two @i{complex} numbers are considered to be @b{eql} if their real parts are @b{eql} and their imaginary parts are @b{eql}. For example, @t{(eql #C(4 5) #C(4 5))} is @i{true} and @t{(eql #C(4 5) #C(4.0 5.0))} is @i{false}. Note that while @t{(eql #C(5.0 0.0) 5.0)} is @i{false}, @t{(eql #C(5 0) 5)} is @i{true}. In the case of @t{(eql #C(5.0 0.0) 5.0)} the two arguments are of different types, and so cannot satisfy @b{eql}. In the case of @t{(eql #C(5 0) 5)}, @t{#C(5 0)} is not a @i{complex} number, but is automatically reduced to the @i{integer} @t{5}. @node equal, equalp, eql, Data and Control Flow Dictionary @subsection equal [Function] @code{equal} @i{x y} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{x}---an @i{object}. @i{y}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{x} and @i{y} are structurally similar (isomorphic) @i{objects}. @i{Objects} are treated as follows by @b{equal}. @table @asis @item @i{Symbols}, @i{Numbers}, and @i{Characters} @b{equal} is @i{true} of two @i{objects} if they are @i{symbols} that are @b{eq}, if they are @i{numbers} that are @b{eql}, or if they are @i{characters} that are @b{eql}. @item @i{Conses} For @i{conses}, @b{equal} is defined recursively as the two @i{cars} being @b{equal} and the two @i{cdrs} being @b{equal}. @item @i{Arrays} Two @i{arrays} are @b{equal} only if they are @b{eq}, with one exception: @i{strings} and @i{bit vectors} are compared element-by-element (using @b{eql}). If either @i{x} or @i{y} has a @i{fill pointer}, the @i{fill pointer} limits the number of elements examined by @b{equal}. Uppercase and lowercase letters in @i{strings} are considered by @b{equal} to be different. @item @i{Pathnames} Two @i{pathnames} are @b{equal} if and only if all the corresponding components (host, device, and so on) are equivalent. Whether or not uppercase and lowercase letters are considered equivalent in @i{strings} appearing in components is @i{implementation-dependent}. @i{pathnames} that are @b{equal} should be functionally equivalent. @item Other (Structures, hash-tables, instances, ...) Two other @i{objects} are @b{equal} only if they are @b{eq}. @end table @b{equal} does not descend any @i{objects} other than the ones explicitly specified above. Figure 5--12 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of @b{equal}, with upper entries taking priority over lower ones. @format @group @noindent @w{ Type Behavior } @w{ @i{number} uses @b{eql} } @w{ @i{character} uses @b{eql} } @w{ @i{cons} descends } @w{ @i{bit vector} descends } @w{ @i{string} descends } @w{ @i{pathname} ``functionally equivalent'' } @w{ @i{structure} uses @b{eq} } @w{ Other @i{array} uses @b{eq} } @w{ @i{hash table} uses @b{eq} } @w{ Other @i{object} uses @b{eq} } @noindent @w{ Figure 5--12: Summary and priorities of behavior of @b{equal}} @end group @end format Any two @i{objects} that are @b{eql} are also @b{equal}. @b{equal} may fail to terminate if @i{x} or @i{y} is circular. @subsubheading Examples:: @example (equal 'a 'b) @result{} @i{false} (equal 'a 'a) @result{} @i{true} (equal 3 3) @result{} @i{true} (equal 3 3.0) @result{} @i{false} (equal 3.0 3.0) @result{} @i{true} (equal #c(3 -4) #c(3 -4)) @result{} @i{true} (equal #c(3 -4.0) #c(3 -4)) @result{} @i{false} (equal (cons 'a 'b) (cons 'a 'c)) @result{} @i{false} (equal (cons 'a 'b) (cons 'a 'b)) @result{} @i{true} (equal #\A #\A) @result{} @i{true} (equal #\A #\a) @result{} @i{false} (equal "Foo" "Foo") @result{} @i{true} (equal "Foo" (copy-seq "Foo")) @result{} @i{true} (equal "FOO" "foo") @result{} @i{false} (equal "This-string" "This-string") @result{} @i{true} (equal "This-string" "this-string") @result{} @i{false} @end example @subsubheading See Also:: @ref{eq} , @ref{eql} , @ref{equalp} , @ref{=} , @ref{string=} , @b{string-equal}, @ref{char=} , @b{char-equal}, @ref{tree-equal} @subsubheading Notes:: @i{Object} equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, @b{equal} and @b{equalp} are not appropriate for every application. A rough rule of thumb is that two @i{objects} are @b{equal} if and only if their printed representations are the same. @node equalp, identity, equal, Data and Control Flow Dictionary @subsection equalp [Function] @code{equalp} @i{x y} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{x}---an @i{object}. @i{y}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{x} and @i{y} are @b{equal}, or if they have components that are of the same @i{type} as each other and if those components are @b{equalp}; specifically, @b{equalp} returns @i{true} in the following cases: @table @asis @item @i{Characters} If two @i{characters} are @b{char-equal}. @item @i{Numbers} If two @i{numbers} are the @i{same} under @b{=}. @item @i{Conses} If the two @i{cars} in the @i{conses} are @b{equalp} and the two @i{cdrs} in the @i{conses} are @b{equalp}. @item @i{Arrays} If two @i{arrays} have the same number of dimensions, the dimensions match, and the corresponding @i{active elements} are @b{equalp}. The @i{types} for which the @i{arrays} are @i{specialized} need not match; for example, a @i{string} and a general @i{array} that happens to contain the same @i{characters} are @b{equalp}. Because @b{equalp} performs @i{element}-by-@i{element} comparisons of @i{strings} and ignores the @i{case} of @i{characters}, @i{case} distinctions are ignored when @b{equalp} compares @i{strings}. @item @i{Structures} If two @i{structures} S_1 and S_2 have the same @i{class} and the value of each @i{slot} in S_1 is the @i{same} under @b{equalp} as the value of the corresponding @i{slot} in S_2. @item @i{Hash Tables} @b{equalp} descends @i{hash-tables} by first comparing the count of entries and the @t{:test} function; if those are the same, it compares the keys of the tables using the @t{:test} function and then the values of the matching keys using @b{equalp} recursively. @end table @b{equalp} does not descend any @i{objects} other than the ones explicitly specified above. Figure 5--13 summarizes the information given in the previous list. In addition, the figure specifies the priority of the behavior of @b{equalp}, with upper entries taking priority over lower ones. @format @group @noindent @w{ Type Behavior } @w{ @i{number} uses @b{=} } @w{ @i{character} uses @b{char-equal} } @w{ @i{cons} descends } @w{ @i{bit vector} descends } @w{ @i{string} descends } @w{ @i{pathname} same as @b{equal} } @w{ @i{structure} descends, as described above } @w{ Other @i{array} descends } @w{ @i{hash table} descends, as described above } @w{ Other @i{object} uses @b{eq} } @noindent @w{ Figure 5--13: Summary and priorities of behavior of @b{equalp}} @end group @end format @subsubheading Examples:: @example (equalp 'a 'b) @result{} @i{false} (equalp 'a 'a) @result{} @i{true} (equalp 3 3) @result{} @i{true} (equalp 3 3.0) @result{} @i{true} (equalp 3.0 3.0) @result{} @i{true} (equalp #c(3 -4) #c(3 -4)) @result{} @i{true} (equalp #c(3 -4.0) #c(3 -4)) @result{} @i{true} (equalp (cons 'a 'b) (cons 'a 'c)) @result{} @i{false} (equalp (cons 'a 'b) (cons 'a 'b)) @result{} @i{true} (equalp #\A #\A) @result{} @i{true} (equalp #\A #\a) @result{} @i{true} (equalp "Foo" "Foo") @result{} @i{true} (equalp "Foo" (copy-seq "Foo")) @result{} @i{true} (equalp "FOO" "foo") @result{} @i{true} @end example @example (setq array1 (make-array 6 :element-type 'integer :initial-contents '(1 1 1 3 5 7))) @result{} #(1 1 1 3 5 7) (setq array2 (make-array 8 :element-type 'integer :initial-contents '(1 1 1 3 5 7 2 6) :fill-pointer 6)) @result{} #(1 1 1 3 5 7) (equalp array1 array2) @result{} @i{true} (setq vector1 (vector 1 1 1 3 5 7)) @result{} #(1 1 1 3 5 7) (equalp array1 vector1) @result{} @i{true} @end example @subsubheading See Also:: @ref{eq} , @ref{eql} , @ref{equal} , @ref{=} , @ref{string=} , @b{string-equal}, @ref{char=} , @b{char-equal} @subsubheading Notes:: @i{Object} equality is not a concept for which there is a uniquely determined correct algorithm. The appropriateness of an equality predicate can be judged only in the context of the needs of some particular program. Although these functions take any type of argument and their names sound very generic, @b{equal} and @b{equalp} are not appropriate for every application. @node identity, complement, equalp, Data and Control Flow Dictionary @subsection identity [Function] @code{identity} @i{object} @result{} @i{object} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @subsubheading Description:: Returns its argument @i{object}. @subsubheading Examples:: @example (identity 101) @result{} 101 (mapcan #'identity (list (list 1 2 3) '(4 5 6))) @result{} (1 2 3 4 5 6) @end example @subsubheading Notes:: @b{identity} is intended for use with functions that require a @i{function} as an argument. @t{(eql x (identity x))} returns @i{true} for all possible values of @i{x}, but @t{(eq x (identity x))} might return @i{false} when @i{x} is a @i{number} or @i{character}. @b{identity} could be defined by @example (defun identity (x) x) @end example @node complement, constantly, identity, Data and Control Flow Dictionary @subsection complement [Function] @code{complement} @i{function} @result{} @i{complement-function} @subsubheading Arguments and Values:: @i{function}---a @i{function}. @i{complement-function}---a @i{function}. @subsubheading Description:: Returns a @i{function} that takes the same @i{arguments} as @i{function}, and has the same side-effect behavior as @i{function}, but returns only a single value: a @i{generalized boolean} with the opposite truth value of that which would be returned as the @i{primary value} of @i{function}. That is, when the @i{function} would have returned @i{true} as its @i{primary value} the @i{complement-function} returns @i{false}, and when the @i{function} would have returned @i{false} as its @i{primary value} the @i{complement-function} returns @i{true}. @subsubheading Examples:: @example (funcall (complement #'zerop) 1) @result{} @i{true} (funcall (complement #'characterp) #\A) @result{} @i{false} (funcall (complement #'member) 'a '(a b c)) @result{} @i{false} (funcall (complement #'member) 'd '(a b c)) @result{} @i{true} @end example @subsubheading See Also:: @ref{not} @subsubheading Notes:: @example (complement @i{x}) @equiv{} #'(lambda (&rest arguments) (not (apply @i{x} arguments))) @end example In @r{Common Lisp}, functions with names like ``@t{@i{xxx}-if-not}'' are related to functions with names like ``@t{@i{xxx}-if}'' in that @example (@i{xxx}-if-not @i{f} . @i{arguments}) @equiv{} (@i{xxx}-if (complement @i{f}) . @i{arguments}) @end example For example, @example (find-if-not #'zerop '(0 0 3)) @equiv{} (find-if (complement #'zerop) '(0 0 3)) @result{} 3 @end example Note that since the ``@t{@i{xxx}-if-not}'' @i{functions} and the @t{:test-not} arguments have been deprecated, uses of ``@t{@i{xxx}-if}'' @i{functions} or @t{:test} arguments with @b{complement} are preferred. @node constantly, every, complement, Data and Control Flow Dictionary @subsection constantly [Function] @code{constantly} @i{value} @result{} @i{function} @subsubheading Arguments and Values:: @i{value}---an @i{object}. @i{function}---a @i{function}. @subsubheading Description:: @b{constantly} returns a @i{function} that accepts any number of arguments, that has no side-effects, and that always returns @i{value}. @subsubheading Examples:: @example (mapcar (constantly 3) '(a b c d)) @result{} (3 3 3 3) (defmacro with-vars (vars &body forms) `((lambda ,vars ,@@forms) ,@@(mapcar (constantly nil) vars))) @result{} WITH-VARS (macroexpand '(with-vars (a b) (setq a 3 b (* a a)) (list a b))) @result{} ((LAMBDA (A B) (SETQ A 3 B (* A A)) (LIST A B)) NIL NIL), @i{true} @end example @subsubheading See Also:: @ref{not} @subsubheading Notes:: @b{constantly} could be defined by: @example (defun constantly (object) #'(lambda (&rest arguments) object)) @end example @node every, and, constantly, Data and Control Flow Dictionary @subsection every, some, notevery, notany [Function] @code{every} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} @code{some} @i{predicate @r{&rest} sequences^+} @result{} @i{result} @code{notevery} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} @code{notany} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{predicate}---a @i{designator} for a @i{function} of as many @i{arguments} as there are @i{sequences}. @i{sequence}---a @i{sequence}. @i{result}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: @b{every}, @b{some}, @b{notevery}, and @b{notany} test @i{elements} of @i{sequences} for satisfaction of a given @i{predicate}. The first argument to @i{predicate} is an @i{element} of the first @i{sequence}; each succeeding argument is an @i{element} of a succeeding @i{sequence}. @i{Predicate} is first applied to the elements with index @t{0} in each of the @i{sequences}, and possibly then to the elements with index @t{1}, and so on, until a termination criterion is met or the end of the shortest of the @i{sequences} is reached. @b{every} returns @i{false} as soon as any invocation of @i{predicate} returns @i{false}. If the end of a @i{sequence} is reached, @b{every} returns @i{true}. Thus, @b{every} returns @i{true} if and only if every invocation of @i{predicate} returns @i{true}. @b{some} returns the first @i{non-nil} value which is returned by an invocation of @i{predicate}. If the end of a @i{sequence} is reached without any invocation of the @i{predicate} returning @i{true}, @b{some} returns @i{false}. Thus, @b{some} returns @i{true} if and only if some invocation of @i{predicate} returns @i{true}. @b{notany} returns @i{false} as soon as any invocation of @i{predicate} returns @i{true}. If the end of a @i{sequence} is reached, @b{notany} returns @i{true}. Thus, @b{notany} returns @i{true} if and only if it is not the case that any invocation of @i{predicate} returns @i{true}. @b{notevery} returns @i{true} as soon as any invocation of @i{predicate} returns @i{false}. If the end of a @i{sequence} is reached, @b{notevery} returns @i{false}. Thus, @b{notevery} returns @i{true} if and only if it is not the case that every invocation of @i{predicate} returns @i{true}. @subsubheading Examples:: @example (every #'characterp "abc") @result{} @i{true} (some #'= '(1 2 3 4 5) '(5 4 3 2 1)) @result{} @i{true} (notevery #'< '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) @result{} @i{false} (notany #'> '(1 2 3 4) '(5 6 7 8) '(9 10 11 12)) @result{} @i{true} @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its first argument is neither a @i{symbol} nor a @i{function} or if any subsequent argument is not a @i{proper sequence}. Other exceptional situations are possible, depending on the nature of the @i{predicate}. @subsubheading See Also:: @ref{and} , @ref{or} , @ref{Traversal Rules and Side Effects} @subsubheading Notes:: @example (notany @i{predicate} @{@i{sequence}@}*) @equiv{} (not (some @i{predicate} @{@i{sequence}@}*)) (notevery @i{predicate} @{@i{sequence}@}*) @equiv{} (not (every @i{predicate} @{@i{sequence}@}*)) @end example @node and, cond, every, Data and Control Flow Dictionary @subsection and [Macro] @code{and} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{form}---a @i{form}. @i{results}---the @i{values} resulting from the evaluation of the last @i{form}, or the symbols @b{nil} or @b{t}. @subsubheading Description:: The macro @b{and} evaluates each @i{form} one at a time from left to right. As soon as any @i{form} evaluates to @b{nil}, @b{and} returns @b{nil} without evaluating the remaining @i{forms}. If all @i{forms} but the last evaluate to @i{true} values, @b{and} returns the results produced by evaluating the last @i{form}. If no @i{forms} are supplied, @t{(and)} returns @b{t}. @b{and} passes back multiple values from the last @i{subform} but not from subforms other than the last. @subsubheading Examples:: @example (if (and (>= n 0) (< n (length a-simple-vector)) (eq (elt a-simple-vector n) 'foo)) (princ "Foo!")) @end example The above expression prints @t{Foo!} if element @t{n} of @t{a-simple-vector} is the symbol @t{foo}, provided also that @t{n} is indeed a valid index for @t{a-simple-vector}. Because @b{and} guarantees left-to-right testing of its parts, @b{elt} is not called if @t{n} is out of range. @example (setq temp1 1 temp2 1 temp3 1) @result{} 1 (and (incf temp1) (incf temp2) (incf temp3)) @result{} 2 (and (eql 2 temp1) (eql 2 temp2) (eql 2 temp3)) @result{} @i{true} (decf temp3) @result{} 1 (and (decf temp1) (decf temp2) (eq temp3 'nil) (decf temp3)) @result{} NIL (and (eql temp1 temp2) (eql temp2 temp3)) @result{} @i{true} (and) @result{} T @end example @subsubheading See Also:: @ref{cond} , @ref{every} , @ref{if} , @ref{or} , @ref{when} @subsubheading Notes:: @example (and @i{form}) @equiv{} (let () @i{form}) (and @i{form1} @i{form2} ...) @equiv{} (when @i{form1} (and @i{form2} ...)) @end example @node cond, if, and, Data and Control Flow Dictionary @subsection cond [Macro] @code{cond} @i{@{!@i{clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{clause} ::=@r{(}test-form @{@i{form}@}*@r{)}} @subsubheading Arguments and Values:: @i{test-form}---a @i{form}. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms} in the first @i{clause} whose @i{test-form} @i{yields} @i{true}, or the @i{primary value} of the @i{test-form} if there are no @i{forms} in that @i{clause}, or else @b{nil} if no @i{test-form} @i{yields} @i{true}. @subsubheading Description:: @b{cond} allows the execution of @i{forms} to be dependent on @i{test-form}. @i{Test-forms} are evaluated one at a time in the order in which they are given in the argument list until a @i{test-form} is found that evaluates to @i{true}. If there are no @i{forms} in that clause, the @i{primary value} of the @i{test-form} is returned by the @b{cond} @i{form}. Otherwise, the @i{forms} associated with this @i{test-form} are evaluated in order, left to right, as an @i{implicit progn}, and the @i{values} returned by the last @i{form} are returned by the @b{cond} @i{form}. Once one @i{test-form} has @i{yielded} @i{true}, no additional @i{test-forms} are @i{evaluated}. If no @i{test-form} @i{yields} @i{true}, @b{nil} is returned. @subsubheading Examples:: @example (defun select-options () (cond ((= a 1) (setq a 2)) ((= a 2) (setq a 3)) ((and (= a 3) (floor a 2))) (t (floor a 3)))) @result{} SELECT-OPTIONS (setq a 1) @result{} 1 (select-options) @result{} 2 a @result{} 2 (select-options) @result{} 3 a @result{} 3 (select-options) @result{} 1 (setq a 5) @result{} 5 (select-options) @result{} 1, 2 @end example @subsubheading See Also:: @ref{if} , @ref{case} . @node if, or, cond, Data and Control Flow Dictionary @subsection if [Special Operator] @code{if} @i{@i{test-form} @i{then-form} @r{[}@i{else-form}@r{]}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{Test-form}---a @i{form}. @i{Then-form}---a @i{form}. @i{Else-form}---a @i{form}. The default is @b{nil}. @i{results}---if the @i{test-form} @i{yielded} @i{true}, the @i{values} returned by the @i{then-form}; otherwise, the @i{values} returned by the @i{else-form}. @subsubheading Description:: @b{if} allows the execution of a @i{form} to be dependent on a single @i{test-form}. First @i{test-form} is evaluated. If the result is @i{true}, then @i{then-form} is selected; otherwise @i{else-form} is selected. Whichever form is selected is then evaluated. @subsubheading Examples:: @example (if t 1) @result{} 1 (if nil 1 2) @result{} 2 (defun test () (dolist (truth-value '(t nil 1 (a b c))) (if truth-value (print 'true) (print 'false)) (prin1 truth-value))) @result{} TEST (test) @t{ |> } TRUE T @t{ |> } FALSE NIL @t{ |> } TRUE 1 @t{ |> } TRUE (A B C) @result{} NIL @end example @subsubheading See Also:: @ref{cond} , @b{unless}, @ref{when} @subsubheading Notes:: @example (if @i{test-form} @i{then-form} @i{else-form}) @equiv{} (cond (@i{test-form} @i{then-form}) (t @i{else-form})) @end example @node or, when, if, Data and Control Flow Dictionary @subsection or [Macro] @code{or} @i{@{@i{form}@}*} @result{} @i{@{@i{results}@}*} @subsubheading Arguments and Values:: @i{form}---a @i{form}. @i{results}---the @i{values} or @i{primary value} (see below) resulting from the evaluation of the last @i{form} executed or @b{nil}. @subsubheading Description:: @b{or} evaluates each @i{form}, one at a time, from left to right. The evaluation of all @i{forms} terminates when a @i{form} evaluates to @i{true} (@i{i.e.}, something other than @b{nil}). If the @i{evaluation} of any @i{form} other than the last returns a @i{primary value} that is @i{true}, @b{or} immediately returns that @i{value} (but no additional @i{values}) without evaluating the remaining @i{forms}. If every @i{form} but the last returns @i{false} as its @i{primary value}, @b{or} returns all @i{values} returned by the last @i{form}. If no @i{forms} are supplied, @b{or} returns @b{nil}. @subsubheading Examples:: @example (or) @result{} NIL (setq temp0 nil temp1 10 temp2 20 temp3 30) @result{} 30 (or temp0 temp1 (setq temp2 37)) @result{} 10 temp2 @result{} 20 (or (incf temp1) (incf temp2) (incf temp3)) @result{} 11 temp1 @result{} 11 temp2 @result{} 20 temp3 @result{} 30 (or (values) temp1) @result{} 11 (or (values temp1 temp2) temp3) @result{} 11 (or temp0 (values temp1 temp2)) @result{} 11, 20 (or (values temp0 temp1) (values temp2 temp3)) @result{} 20, 30 @end example @subsubheading See Also:: @ref{and} , @b{some}, @b{unless} @node when, case, or, Data and Control Flow Dictionary @subsection when, unless [Macro] @code{when} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @code{unless} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{test-form}---a @i{form}. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms} in a @b{when} @i{form} if the @i{test-form} @i{yields} @i{true} or in an @b{unless} @i{form} if the @i{test-form} @i{yields} @i{false}; otherwise @b{nil}. @subsubheading Description:: @b{when} and @b{unless} allow the execution of @i{forms} to be dependent on a single @i{test-form}. In a @b{when} @i{form}, if the @i{test-form} @i{yields} @i{true}, the @i{forms} are @i{evaluated} in order from left to right and the @i{values} returned by the @i{forms} are returned from the @b{when} @i{form}. Otherwise, if the @i{test-form} @i{yields} @i{false}, the @i{forms} are not @i{evaluated}, and the @b{when} @i{form} returns @b{nil}. In an @b{unless} @i{form}, if the @i{test-form} @i{yields} @i{false}, the @i{forms} are @i{evaluated} in order from left to right and the @i{values} returned by the @i{forms} are returned from the @b{unless} @i{form}. Otherwise, if the @i{test-form} @i{yields} @i{false}, the @i{forms} are not @i{evaluated}, and the @b{unless} @i{form} returns @b{nil}. @subsubheading Examples:: @example (when t 'hello) @result{} HELLO (unless t 'hello) @result{} NIL (when nil 'hello) @result{} NIL (unless nil 'hello) @result{} HELLO (when t) @result{} NIL (unless nil) @result{} NIL (when t (prin1 1) (prin1 2) (prin1 3)) @t{ |> } 123 @result{} 3 (unless t (prin1 1) (prin1 2) (prin1 3)) @result{} NIL (when nil (prin1 1) (prin1 2) (prin1 3)) @result{} NIL (unless nil (prin1 1) (prin1 2) (prin1 3)) @t{ |> } 123 @result{} 3 (let ((x 3)) (list (when (oddp x) (incf x) (list x)) (when (oddp x) (incf x) (list x)) (unless (oddp x) (incf x) (list x)) (unless (oddp x) (incf x) (list x)) (if (oddp x) (incf x) (list x)) (if (oddp x) (incf x) (list x)) (if (not (oddp x)) (incf x) (list x)) (if (not (oddp x)) (incf x) (list x)))) @result{} ((4) NIL (5) NIL 6 (6) 7 (7)) @end example @subsubheading See Also:: @ref{and} , @ref{cond} , @ref{if} , @ref{or} @subsubheading Notes:: @example (when @i{test} @{@i{form}@}^+) @equiv{} (and @i{test} (progn @{@i{form}@}^+)) (when @i{test} @{@i{form}@}^+) @equiv{} (cond (@i{test} @{@i{form}@}^+)) (when @i{test} @{@i{form}@}^+) @equiv{} (if @i{test} (progn @{@i{form}@}^+) nil) (when @i{test} @{@i{form}@}^+) @equiv{} (unless (not @i{test}) @{@i{form}@}^+) (unless @i{test} @{@i{form}@}^+) @equiv{} (cond ((not @i{test}) @{@i{form}@}^+)) (unless @i{test} @{@i{form}@}^+) @equiv{} (if @i{test} nil (progn @{@i{form}@}^+)) (unless @i{test} @{@i{form}@}^+) @equiv{} (when (not @i{test}) @{@i{form}@}^+) @end example @node case, typecase, when, Data and Control Flow Dictionary @subsection case, ccase, ecase [Macro] @code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} @code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} @w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} @IRindex otherwise @IRindex t @subsubheading Arguments and Values:: @i{keyform}---a @i{form}; evaluated to produce a @i{test-key}. @i{keyplace}---a @i{form}; evaluated initially to produce a @i{test-key}. Possibly also used later as a @i{place} if no @i{keys} match. @i{test-key}---an object produced by evaluating @i{keyform} or @i{keyplace}. @i{keys}---a @i{designator} for a @i{list} of @i{objects}. In the case of @b{case}, the @i{symbols} @b{t} and @b{otherwise} may not be used as the @i{keys} @i{designator}. To refer to these @i{symbols} by themselves as @i{keys}, the designators @t{(t)} and @t{(otherwise)}, respectively, must be used instead. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms} in the matching @i{clause}. @subsubheading Description:: These @i{macros} allow the conditional execution of a body of @i{forms} in a @i{clause} that is selected by matching the @i{test-key} on the basis of its identity. The @i{keyform} or @i{keyplace} is @i{evaluated} to produce the @i{test-key}. Each of the @i{normal-clauses} is then considered in turn. If the @i{test-key} is the @i{same} as any @i{key} for that @i{clause}, the @i{forms} in that @i{clause} are @i{evaluated} as an @i{implicit progn}, and the @i{values} it returns are returned as the value of the @b{case}, @b{ccase}, or @b{ecase} @i{form}. These @i{macros} differ only in their @i{behavior} when no @i{normal-clause} matches; specifically: @table @asis @item @b{case} If no @i{normal-clause} matches, and there is an @i{otherwise-clause}, then that @i{otherwise-clause} automatically matches; the @i{forms} in that @i{clause} are @i{evaluated} as an @i{implicit progn}, and the @i{values} it returns are returned as the value of the @b{case}. If there is no @i{otherwise-clause}, @b{case} returns @b{nil}. @item @b{ccase} If no @i{normal-clause} matches, a @i{correctable} @i{error} of @i{type} @b{type-error} is signaled. The offending datum is the @i{test-key} and the expected type is @i{type equivalent} to @t{(member @i{key1} @i{key2} ...)}. The @b{store-value} @i{restart} can be used to correct the error. If the @b{store-value} @i{restart} is invoked, its @i{argument} becomes the new @i{test-key}, and is stored in @i{keyplace} as if by @t{(setf @i{keyplace} @i{test-key})}. Then @b{ccase} starts over, considering each @i{clause} anew. [Reviewer Note by Barmar: Will it prompt for multiple values if keyplace is a VALUES general ref?] The subforms of @i{keyplace} might be evaluated again if none of the cases holds. @item @b{ecase} If no @i{normal-clause} matches, a @i{non-correctable} @i{error} of @i{type} @b{type-error} is signaled. The offending datum is the @i{test-key} and the expected type is @i{type equivalent} to @t{(member @i{key1} @i{key2} ...)}. Note that in contrast with @b{ccase}, the caller of @b{ecase} may rely on the fact that @b{ecase} does not return if a @i{normal-clause} does not match. @end table @subsubheading Examples:: @example (dolist (k '(1 2 3 :four #\v () t 'other)) (format t "~S " (case k ((1 2) 'clause1) (3 'clause2) (nil 'no-keys-so-never-seen) ((nil) 'nilslot) ((:four #\v) 'clause4) ((t) 'tslot) (otherwise 'others)))) @t{ |> } CLAUSE1 CLAUSE1 CLAUSE2 CLAUSE4 CLAUSE4 NILSLOT TSLOT OTHERS @result{} NIL (defun add-em (x) (apply #'+ (mapcar #'decode x))) @result{} ADD-EM (defun decode (x) (ccase x ((i uno) 1) ((ii dos) 2) ((iii tres) 3) ((iv cuatro) 4))) @result{} DECODE (add-em '(uno iii)) @result{} 4 (add-em '(uno iiii)) @t{ |> } Error: The value of X, IIII, is not I, UNO, II, DOS, III, @t{ |> } TRES, IV, or CUATRO. @t{ |> } 1: Supply a value to use instead. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Value to evaluate and use for X: @b{|>>}@t{'IV}@b{<<|} @result{} 5 @end example @subsubheading Side Effects:: The debugger might be entered. If the @b{store-value} @i{restart} is invoked, the @i{value} of @i{keyplace} might be changed. @subsubheading Affected By:: @b{ccase} and @b{ecase}, since they might signal an error, are potentially affected by existing @i{handlers} and @b{*debug-io*}. @subsubheading Exceptional Situations:: @b{ccase} and @b{ecase} signal an error of @i{type} @b{type-error} if no @i{normal-clause} matches. @subsubheading See Also:: @ref{cond} , @ref{typecase} , @ref{setf} , @ref{Generalized Reference} @subsubheading Notes:: @example (case @i{test-key} @{((@{@i{key}@}*) @{@i{form}@}*)@}*) @equiv{} (let ((#1=#:g0001 @i{test-key})) (cond @{((member #1# '(@{@i{key}@}*)) @{@i{form}@}*)@}*)) @end example The specific error message used by @b{ecase} and @b{ccase} can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use @b{case} with an @i{otherwise-clause} that explicitly signals an error with an appropriate message. @node typecase, multiple-value-bind, case, Data and Control Flow Dictionary @subsection typecase, ctypecase, etypecase [Macro] @code{typecase} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} @code{ctypecase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @code{etypecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} @w{@i{normal-clause} ::=@r{(}type @{@i{form}@}*@r{)}} @w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} @w{@i{clause} ::=normal-clause | otherwise-clause} @IRindex otherwise @IRindex t @subsubheading Arguments and Values:: @i{keyform}---a @i{form}; evaluated to produce a @i{test-key}. @i{keyplace}---a @i{form}; evaluated initially to produce a @i{test-key}. Possibly also used later as a @i{place} if no @i{types} match. @i{test-key}---an object produced by evaluating @i{keyform} or @i{keyplace}. @i{type}---a @i{type specifier}. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms} in the matching @i{clause}. @subsubheading Description:: These @i{macros} allow the conditional execution of a body of @i{forms} in a @i{clause} that is selected by matching the @i{test-key} on the basis of its @i{type}. The @i{keyform} or @i{keyplace} is @i{evaluated} to produce the @i{test-key}. Each of the @i{normal-clauses} is then considered in turn. If the @i{test-key} is of the @i{type} given by the @i{clauses}'s @i{type}, the @i{forms} in that @i{clause} are @i{evaluated} as an @i{implicit progn}, and the @i{values} it returns are returned as the value of the @b{typecase}, @b{ctypecase}, or @b{etypecase} @i{form}. These @i{macros} differ only in their @i{behavior} when no @i{normal-clause} matches; specifically: @table @asis @item @b{typecase} If no @i{normal-clause} matches, and there is an @i{otherwise-clause}, then that @i{otherwise-clause} automatically matches; the @i{forms} in that @i{clause} are @i{evaluated} as an @i{implicit progn}, and the @i{values} it returns are returned as the value of the @b{typecase}. If there is no @i{otherwise-clause}, @b{typecase} returns @b{nil}. @item @b{ctypecase} If no @i{normal-clause} matches, a @i{correctable} @i{error} of @i{type} @b{type-error} is signaled. The offending datum is the @i{test-key} and the expected type is @i{type equivalent} to @t{(or @i{type1} @i{type2} ...)}. The @b{store-value} @i{restart} can be used to correct the error. If the @b{store-value} @i{restart} is invoked, its @i{argument} becomes the new @i{test-key}, and is stored in @i{keyplace} as if by @t{(setf @i{keyplace} @i{test-key})}. Then @b{ctypecase} starts over, considering each @i{clause} anew. If the @b{store-value} @i{restart} is invoked interactively, the user is prompted for a new @i{test-key} to use. The subforms of @i{keyplace} might be evaluated again if none of the cases holds. @item @b{etypecase} If no @i{normal-clause} matches, a @i{non-correctable} @i{error} of @i{type} @b{type-error} is signaled. The offending datum is the @i{test-key} and the expected type is @i{type equivalent} to @t{(or @i{type1} @i{type2} ...)}. Note that in contrast with @b{ctypecase}, the caller of @b{etypecase} may rely on the fact that @b{etypecase} does not return if a @i{normal-clause} does not match. @end table In all three cases, is permissible for more than one @i{clause} to specify a matching @i{type}, particularly if one is a @i{subtype} of another; the earliest applicable @i{clause} is chosen. @subsubheading Examples:: @example ;;; (Note that the parts of this example which use TYPE-OF ;;; are implementation-dependent.) (defun what-is-it (x) (format t "~&~S is ~A.~ x (typecase x (float "a float") (null "a symbol, boolean false, or the empty list") (list "a list") (t (format nil "a(n) ~(~A~)" (type-of x)))))) @result{} WHAT-IS-IT (map 'nil #'what-is-it '(nil (a b) 7.0 7 box)) @t{ |> } NIL is a symbol, boolean false, or the empty list. @t{ |> } (A B) is a list. @t{ |> } 7.0 is a float. @t{ |> } 7 is a(n) integer. @t{ |> } BOX is a(n) symbol. @result{} NIL (setq x 1/3) @result{} 1/3 (ctypecase x (integer (* x 4)) (symbol (symbol-value x))) @t{ |> } Error: The value of X, 1/3, is neither an integer nor a symbol. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Use value: @b{|>>}@t{3.7}@b{<<|} @t{ |> } Error: The value of X, 3.7, is neither an integer nor a symbol. @t{ |> } To continue, type :CONTINUE followed by an option number: @t{ |> } 1: Specify a value to use instead. @t{ |> } 2: Return to Lisp Toplevel. @t{ |> } Debug> @b{|>>}@t{:CONTINUE 1}@b{<<|} @t{ |> } Use value: @b{|>>}@t{12}@b{<<|} @result{} 48 x @result{} 12 @end example @subsubheading Affected By:: @b{ctypecase} and @b{etypecase}, since they might signal an error, are potentially affected by existing @i{handlers} and @b{*debug-io*}. @subsubheading Exceptional Situations:: @b{ctypecase} and @b{etypecase} signal an error of @i{type} @b{type-error} if no @i{normal-clause} matches. The @i{compiler} may choose to issue a warning of @i{type} @b{style-warning} if a @i{clause} will never be selected because it is completely shadowed by earlier clauses. @subsubheading See Also:: @ref{case} , @ref{cond} , @ref{setf} , @ref{Generalized Reference} @subsubheading Notes:: @example (typecase @i{test-key} @{(@i{type} @{@i{form}@}*)@}*) @equiv{} (let ((#1=#:g0001 @i{test-key})) (cond @{((typep #1# '@i{type}) @{@i{form}@}*)@}*)) @end example The specific error message used by @b{etypecase} and @b{ctypecase} can vary between implementations. In situations where control of the specific wording of the error message is important, it is better to use @b{typecase} with an @i{otherwise-clause} that explicitly signals an error with an appropriate message. @node multiple-value-bind, multiple-value-call, typecase, Data and Control Flow Dictionary @subsection multiple-value-bind [Macro] @code{multiple-value-bind} @i{@r{(}@{@i{var}@}*@r{)} @i{values-form} @{@i{declaration}@}* @{@i{form}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---a @i{symbol} naming a variable; not evaluated. @i{values-form}---a @i{form}; evaluated. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} returned by the @i{forms}. @subsubheading Description:: Creates new variable @i{bindings} for the @i{vars} and executes a series of @i{forms} that use these @i{bindings}. The variable @i{bindings} created are lexical unless @b{special} declarations are specified. @i{Values-form} is evaluated, and each of the @i{vars} is bound to the respective value returned by that @i{form}. If there are more @i{vars} than values returned, extra values of @b{nil} are given to the remaining @i{vars}. If there are more values than @i{vars}, the excess values are discarded. The @i{vars} are bound to the values over the execution of the @i{forms}, which make up an implicit @b{progn}. The consequences are unspecified if a type @i{declaration} is specified for a @i{var}, but the value to which that @i{var} is bound is not consistent with the type @i{declaration}. The @i{scopes} of the name binding and @i{declarations} do not include the @i{values-form}. @subsubheading Examples:: @example (multiple-value-bind (f r) (floor 130 11) (list f r)) @result{} (11 9) @end example @subsubheading See Also:: @ref{let} , @ref{multiple-value-call} @subsubheading Notes:: @example (multiple-value-bind (@{@i{var}@}*) @i{values-form} @{@i{form}@}*) @equiv{} (multiple-value-call #'(lambda (&optional @{@i{var}@}* &rest #1=#:ignore) (declare (ignore #1#)) @{@i{form}@}*) @i{values-form}) @end example @node multiple-value-call, multiple-value-list, multiple-value-bind, Data and Control Flow Dictionary @subsection multiple-value-call [Special Operator] @code{multiple-value-call} @i{@i{function-form} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{function-form}---a @i{form}; evaluated to produce @i{function}. @i{function}---a @i{function designator} resulting from the evaluation of @i{function-form}. @i{form}---a @i{form}. @i{results}---the @i{values} returned by the @i{function}. @subsubheading Description:: Applies @i{function} to a @i{list} of the @i{objects} collected from groups of @i{multiple values}_2. @b{multiple-value-call} first evaluates the @i{function-form} to obtain @i{function}, and then evaluates each @i{form}. All the values of each @i{form} are gathered together (not just one value from each) and given as arguments to the @i{function}. @subsubheading Examples:: @example (multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5)) @result{} (1 / 2 3 / / 2 0.5) (+ (floor 5 3) (floor 19 4)) @equiv{} (+ 1 4) @result{} 5 (multiple-value-call #'+ (floor 5 3) (floor 19 4)) @equiv{} (+ 1 2 4 3) @result{} 10 @end example @subsubheading See Also:: @ref{multiple-value-list} , @ref{multiple-value-bind} @node multiple-value-list, multiple-value-prog1, multiple-value-call, Data and Control Flow Dictionary @subsection multiple-value-list [Macro] @code{multiple-value-list} @i{form} @result{} @i{list} @subsubheading Arguments and Values:: @i{form}---a @i{form}; evaluated as described below. @i{list}---a @i{list} of the @i{values} returned by @i{form}. @subsubheading Description:: @b{multiple-value-list} evaluates @i{form} and creates a @i{list} of the @i{multiple values}_2 it returns. @subsubheading Examples:: @example (multiple-value-list (floor -3 4)) @result{} (-1 1) @end example @subsubheading See Also:: @ref{values-list} , @ref{multiple-value-call} @subsubheading Notes:: @b{multiple-value-list} and @b{values-list} are inverses of each other. @example (multiple-value-list form) @equiv{} (multiple-value-call #'list form) @end example @node multiple-value-prog1, multiple-value-setq, multiple-value-list, Data and Control Flow Dictionary @subsection multiple-value-prog1 [Special Operator] @code{multiple-value-prog} @i{1} @result{} @i{first-form @{@i{form}@}*} @r{first-form-results} @subsubheading Arguments and Values:: @i{first-form}---a @i{form}; evaluated as described below. @i{form}---a @i{form}; evaluated as described below. @i{first-form-results}---the @i{values} resulting from the @i{evaluation} of @i{first-form}. @subsubheading Description:: @b{multiple-value-prog1} evaluates @i{first-form} and saves all the values produced by that @i{form}. It then evaluates each @i{form} from left to right, discarding their values. @subsubheading Examples:: @example (setq temp '(1 2 3)) @result{} (1 2 3) (multiple-value-prog1 (values-list temp) (setq temp nil) (values-list temp)) @result{} 1, 2, 3 @end example @subsubheading See Also:: @ref{prog1} @node multiple-value-setq, values, multiple-value-prog1, Data and Control Flow Dictionary @subsection multiple-value-setq [Macro] @code{multiple-value-setq} @i{vars form} @result{} @i{result} @subsubheading Arguments and Values:: @i{vars}---a @i{list} of @i{symbols} that are either @i{variable} @i{names} or @i{names} of @i{symbol macros}. @i{form}---a @i{form}. @i{result}---The @i{primary value} returned by the @i{form}. @subsubheading Description:: @b{multiple-value-setq} assigns values to @i{vars}. The @i{form} is evaluated, and each @i{var} is @i{assigned} to the corresponding @i{value} returned by that @i{form}. If there are more @i{vars} than @i{values} returned, @b{nil} is @i{assigned} to the extra @i{vars}. If there are more @i{values} than @i{vars}, the extra @i{values} are discarded. If any @i{var} is the @i{name} of a @i{symbol macro}, then it is @i{assigned} as if by @b{setf}. Specifically, @example (multiple-value-setq (@i{symbol}_1 ... @i{symbol}_n) @i{value-producing-form}) @end example is defined to always behave in the same way as @example (values (setf (values @i{symbol}_1 ... @i{symbol}_n) @i{value-producing-form})) @end example in order that the rules for order of evaluation and side-effects be consistent with those used by @b{setf}. @ITindex order of evaluation @ITindex evaluation order See @ref{VALUES Forms as Places}. @subsubheading Examples:: @example (multiple-value-setq (quotient remainder) (truncate 3.2 2)) @result{} 1 quotient @result{} 1 remainder @result{} 1.2 (multiple-value-setq (a b c) (values 1 2)) @result{} 1 a @result{} 1 b @result{} 2 c @result{} NIL (multiple-value-setq (a b) (values 4 5 6)) @result{} 4 a @result{} 4 b @result{} 5 @end example @subsubheading See Also:: @ref{setq} , @ref{symbol-macrolet} @node values, values-list, multiple-value-setq, Data and Control Flow Dictionary @subsection values [Accessor] @code{values} @i{@r{&rest} object} @result{} @i{@{@i{object}@}*} (setf (@code{ values} @i{@r{&rest} place}) new-values)@* @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{place}---a @i{place}. @i{new-value}---an @i{object}. @subsubheading Description:: @b{values} returns the @i{objects} as @i{multiple values}_2. @b{setf} of @b{values} is used to store the @i{multiple values}_2 @i{new-values} into the @i{places}. See @ref{VALUES Forms as Places}. @subsubheading Examples:: @example (values) @result{} <@i{no @i{values}}> (values 1) @result{} 1 (values 1 2) @result{} 1, 2 (values 1 2 3) @result{} 1, 2, 3 (values (values 1 2 3) 4 5) @result{} 1, 4, 5 (defun polar (x y) (values (sqrt (+ (* x x) (* y y))) (atan y x))) @result{} POLAR (multiple-value-bind (r theta) (polar 3.0 4.0) (vector r theta)) @result{} #(5.0 0.927295) @end example Sometimes it is desirable to indicate explicitly that a function returns exactly one value. For example, the function @example (defun foo (x y) (floor (+ x y) y)) @result{} FOO @end example returns two values because @b{floor} returns two values. It may be that the second value makes no sense, or that for efficiency reasons it is desired not to compute the second value. @b{values} is the standard idiom for indicating that only one value is to be returned: @example (defun foo (x y) (values (floor (+ x y) y))) @result{} FOO @end example This works because @b{values} returns exactly one value for each of @i{args}; as for any function call, if any of @i{args} produces more than one value, all but the first are discarded. @subsubheading See Also:: @ref{values-list} , @ref{multiple-value-bind} , @ref{multiple-values-limit} , @ref{Evaluation} @subsubheading Notes:: Since @b{values} is a @i{function}, not a @i{macro} or @i{special form}, it receives as @i{arguments} only the @i{primary values} of its @i{argument} @i{forms}. @node values-list, multiple-values-limit, values, Data and Control Flow Dictionary @subsection values-list [Function] @code{values-list} @i{list} @result{} @i{@{@i{element}@}*} @subsubheading Arguments and Values:: @i{list}---a @i{list}. @i{elements}---the @i{elements} of the @i{list}. @subsubheading Description:: Returns the @i{elements} of the @i{list} as @i{multiple values}_2. @subsubheading Examples:: @example (values-list nil) @result{} <@i{no @i{values}}> (values-list '(1)) @result{} 1 (values-list '(1 2)) @result{} 1, 2 (values-list '(1 2 3)) @result{} 1, 2, 3 @end example @subsubheading Exceptional Situations:: Should signal @b{type-error} if its argument is not a @i{proper list}. @subsubheading See Also:: @ref{multiple-value-bind} , @ref{multiple-value-list} , @ref{multiple-values-limit} , @ref{values} @subsubheading Notes:: @example (values-list @i{list}) @equiv{} (apply #'values @i{list}) @end example @t{(equal @i{x} (multiple-value-list (values-list @i{x})))} returns @i{true} for all @i{lists} @i{x}. @node multiple-values-limit, nth-value, values-list, Data and Control Flow Dictionary @subsection multiple-values-limit [Constant Variable] @subsubheading Constant Value:: An @i{integer} not smaller than @t{20}, the exact magnitude of which is @i{implementation-dependent}. @subsubheading Description:: The upper exclusive bound on the number of @i{values} that may be returned from a @i{function}, bound or assigned by @b{multiple-value-bind} or @b{multiple-value-setq}, or passed as a first argument to @b{nth-value}. (If these individual limits might differ, the minimum value is used.) @subsubheading See Also:: @ref{lambda-parameters-limit} , @ref{call-arguments-limit} @subsubheading Notes:: Implementors are encouraged to make this limit as large as possible. @node nth-value, prog, multiple-values-limit, Data and Control Flow Dictionary @subsection nth-value [Macro] @code{nth-value} @i{n form} @result{} @i{object} @subsubheading Arguments and Values:: @i{n}---a non-negative @i{integer}; evaluated. @i{form}---a @i{form}; evaluated as described below. @i{object}---an @i{object}. @subsubheading Description:: Evaluates @i{n} and then @i{form}, returning as its only value the @i{n}th value @i{yielded} by @i{form}, or @b{nil} if @i{n} is greater than or equal to the number of @i{values} returned by @i{form}. (The first returned value is numbered @t{0}.) @subsubheading Examples:: @example (nth-value 0 (values 'a 'b)) @result{} A (nth-value 1 (values 'a 'b)) @result{} B (nth-value 2 (values 'a 'b)) @result{} NIL (let* ((x 83927472397238947423879243432432432) (y 32423489732) (a (nth-value 1 (floor x y))) (b (mod x y))) (values a b (= a b))) @result{} 3332987528, 3332987528, @i{true} @end example @subsubheading See Also:: @ref{multiple-value-list} , @ref{nth} @subsubheading Notes:: Operationally, the following relationship is true, although @b{nth-value} might be more efficient in some @i{implementations} because, for example, some @i{consing} might be avoided. @example (nth-value @i{n} @i{form}) @equiv{} (nth @i{n} (multiple-value-list @i{form})) @end example @node prog, prog1, nth-value, Data and Control Flow Dictionary @subsection prog, prog* [Macro] @code{prog} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{tag} | @i{statement}@}*}@* @result{} @i{@{@i{result}@}*} @code{prog*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{tag} | @i{statement}@}*}@* @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{var}---variable name. @i{init-form}---a @i{form}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{tag}---a @i{go tag}; not evaluated. @i{statement}---a @i{compound form}; evaluated as described below. @i{results}---@b{nil} if a @i{normal return} occurs, or else, if an @i{explicit return} occurs, the @i{values} that were transferred. @subsubheading Description:: Three distinct operations are performed by @b{prog} and @b{prog*}: they bind local variables, they permit use of the @b{return} statement, and they permit use of the @b{go} statement. A typical @b{prog} looks like this: @example (prog (var1 var2 (var3 init-form-3) var4 (var5 init-form-5)) @{@i{declaration}@}* statement1 tag1 statement2 statement3 statement4 tag2 statement5 ... ) @end example For @b{prog}, @i{init-forms} are evaluated first, in the order in which they are supplied. The @i{vars} are then bound to the corresponding values in parallel. If no @i{init-form} is supplied for a given @i{var}, that @i{var} is bound to @b{nil}. The body of @b{prog} is executed as if it were a @b{tagbody} @i{form}; the @b{go} statement can be used to transfer control to a @i{tag}. @i{Tags} label @i{statements}. @b{prog} implicitly establishes a @b{block} named @b{nil} around the entire @b{prog} @i{form}, so that @b{return} can be used at any time to exit from the @b{prog} @i{form}. The difference between @b{prog*} and @b{prog} is that in @b{prog*} the @i{binding} and initialization of the @i{vars} is done @i{sequentially}, so that the @i{init-form} for each one can use the values of previous ones. @subsubheading Examples:: @example (prog* ((y z) (x (car y))) (return x)) @end example returns the @i{car} of the value of @t{z}. @example (setq a 1) @result{} 1 (prog ((a 2) (b a)) (return (if (= a b) '= '/=))) @result{} /= (prog* ((a 2) (b a)) (return (if (= a b) '= '/=))) @result{} = (prog () 'no-return-value) @result{} NIL @end example @example (defun king-of-confusion (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (prog (x y z) ;Initialize x, y, z to NIL (setq y (car w) z (cdr w)) loop (cond ((null y) (return x)) ((null z) (go err))) rejoin (setq x (cons (cons (car y) (car z)) x)) (setq y (cdr y) z (cdr z)) (go loop) err (cerror "Will self-pair extraneous items" "Mismatch - gleep! ~S" y) (setq z y) (go rejoin))) @result{} KING-OF-CONFUSION @end example This can be accomplished more perspicuously as follows: @example (defun prince-of-clarity (w) "Take a cons of two lists and make a list of conses. Think of this function as being like a zipper." (do ((y (car w) (cdr y)) (z (cdr w) (cdr z)) (x '@t{()} (cons (cons (car y) (car z)) x))) ((null y) x) (when (null z) (cerror "Will self-pair extraneous items" "Mismatch - gleep! ~S" y) (setq z y)))) @result{} PRINCE-OF-CLARITY @end example @subsubheading See Also:: @ref{block} , @ref{let} , @ref{tagbody} , @ref{go} , @ref{return} , @ref{Evaluation} @subsubheading Notes:: @b{prog} can be explained in terms of @b{block}, @b{let}, and @b{tagbody} as follows: @example (prog @i{variable-list} @i{declaration} . @i{body}) @equiv{} (block nil (let @i{variable-list} @i{declaration} (tagbody . @i{body}))) @end example @node prog1, progn, prog, Data and Control Flow Dictionary @subsection prog1, prog2 [Macro] @code{prog} @i{1} @result{} @i{first-form @{@i{form}@}*} @r{result-1} @code{prog} @i{2} @result{} @i{first-form second-form @{@i{form}@}*} @r{result-2} @subsubheading Arguments and Values:: @i{first-form}---a @i{form}; evaluated as described below. @i{second-form}---a @i{form}; evaluated as described below. @i{forms}---an @i{implicit progn}; evaluated as described below. @i{result-1}---the @i{primary value} resulting from the @i{evaluation} of @i{first-form}. @i{result-2}---the @i{primary value} resulting from the @i{evaluation} of @i{second-form}. @subsubheading Description:: @b{prog1} @i{evaluates} @i{first-form} and then @i{forms}, @i{yielding} as its only @i{value} the @i{primary value} @i{yielded} by @i{first-form}. @b{prog2} @i{evaluates} @i{first-form}, then @i{second-form}, and then @i{forms}, @i{yielding} as its only @i{value} the @i{primary value} @i{yielded} by @i{first-form}. @subsubheading Examples:: @example (setq temp 1) @result{} 1 (prog1 temp (print temp) (incf temp) (print temp)) @t{ |> } 1 @t{ |> } 2 @result{} 1 (prog1 temp (setq temp nil)) @result{} 2 temp @result{} NIL (prog1 (values 1 2 3) 4) @result{} 1 (setq temp (list 'a 'b 'c)) (prog1 (car temp) (setf (car temp) 'alpha)) @result{} A temp @result{} (ALPHA B C) (flet ((swap-symbol-values (x y) (setf (symbol-value x) (prog1 (symbol-value y) (setf (symbol-value y) (symbol-value x)))))) (let ((*foo* 1) (*bar* 2)) (declare (special *foo* *bar*)) (swap-symbol-values '*foo* '*bar*) (values *foo* *bar*))) @result{} 2, 1 (setq temp 1) @result{} 1 (prog2 (incf temp) (incf temp) (incf temp)) @result{} 3 temp @result{} 4 (prog2 1 (values 2 3 4) 5) @result{} 2 @end example @subsubheading See Also:: @ref{multiple-value-prog1} , @ref{progn} @subsubheading Notes:: @b{prog1} and @b{prog2} are typically used to @i{evaluate} one or more @i{forms} with side effects and return a @i{value} that must be computed before some or all of the side effects happen. @example (prog1 @{@i{form}@}*) @equiv{} (values (multiple-value-prog1 @{@i{form}@}*)) (prog2 @i{form1} @{@i{form}@}*) @equiv{} (let () @i{form1} (prog1 @{@i{form}@}*)) @end example @node progn, define-modify-macro, prog1, Data and Control Flow Dictionary @subsection progn [Special Operator] @code{progn} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} @subsubheading Arguments and Values:: @i{forms}---an @i{implicit progn}. @i{results}---the @i{values} of the @i{forms}. @subsubheading Description:: @b{progn} evaluates @i{forms}, in the order in which they are given. The values of each @i{form} but the last are discarded. If @b{progn} appears as a @i{top level form}, then all @i{forms} within that @b{progn} are considered by the compiler to be @i{top level forms}. @subsubheading Examples:: @example (progn) @result{} NIL (progn 1 2 3) @result{} 3 (progn (values 1 2 3)) @result{} 1, 2, 3 (setq a 1) @result{} 1 (if a (progn (setq a nil) 'here) (progn (setq a t) 'there)) @result{} HERE a @result{} NIL @end example @subsubheading See Also:: @ref{prog1} , @b{prog2}, @ref{Evaluation} @subsubheading Notes:: Many places in @r{Common Lisp} involve syntax that uses @i{implicit progns}. That is, part of their syntax allows many @i{forms} to be written that are to be evaluated sequentially, discarding the results of all @i{forms} but the last and returning the results of the last @i{form}. Such places include, but are not limited to, the following: the body of a @i{lambda expression}; the bodies of various control and conditional @i{forms} (@i{e.g.}, @b{case}, @b{catch}, @b{progn}, and @b{when}). @node define-modify-macro, defsetf, progn, Data and Control Flow Dictionary @subsection define-modify-macro [Macro] @code{define-modify-macro} @i{name lambda-list function @r{[}documentation@r{]}} @result{} @i{name} @subsubheading Arguments and Values:: @i{name}---a @i{symbol}. @i{lambda-list}---a @i{define-modify-macro lambda list} @i{function}---a @i{symbol}. @i{documentation}---a @i{string}; not evaluated. @subsubheading Description:: @b{define-modify-macro} defines a @i{macro} named @i{name} to @i{read} and @i{write} a @i{place}. The arguments to the new @i{macro} are a @i{place}, followed by the arguments that are supplied in @i{lambda-list}. @i{Macros} defined with @b{define-modify-macro} correctly pass the @i{environment parameter} to @b{get-setf-expansion}. When the @i{macro} is invoked, @i{function} is applied to the old contents of the @i{place} and the @i{lambda-list} arguments to obtain the new value, and the @i{place} is updated to contain the result. Except for the issue of avoiding multiple evaluation (see below), the expansion of a @b{define-modify-macro} is equivalent to the following: @example (defmacro @i{name} (reference . @i{lambda-list}) @i{documentation} `(setf ,reference (@i{function} ,reference ,@i{arg1} ,@i{arg2} ...))) @end example where @i{arg1}, @i{arg2}, ..., are the parameters appearing in @i{lambda-list}; appropriate provision is made for a @i{rest parameter}. The @i{subforms} of the macro calls defined by @b{define-modify-macro} are evaluated as specified in @ref{Evaluation of Subforms to Places}. @i{Documentation} is attached as a @i{documentation string} to @i{name} (as kind @b{function}) and to the @i{macro function}. If a @b{define-modify-macro} @i{form} appears as a @i{top level form}, the @i{compiler} must store the @i{macro} definition at compile time, so that occurrences of the macro later on in the file can be expanded correctly. @subsubheading Examples:: @example (define-modify-macro appendf (&rest args) append "Append onto list") @result{} APPENDF (setq x '(a b c) y x) @result{} (A B C) (appendf x '(d e f) '(1 2 3)) @result{} (A B C D E F 1 2 3) x @result{} (A B C D E F 1 2 3) y @result{} (A B C) (define-modify-macro new-incf (&optional (delta 1)) +) (define-modify-macro unionf (other-set &rest keywords) union) @end example @subsubheading Side Effects:: A macro definition is assigned to @i{name}. @subsubheading See Also:: @ref{defsetf} , @ref{define-setf-expander} , @ref{documentation} , @ref{Syntactic Interaction of Documentation Strings and Declarations} @node defsetf, define-setf-expander, define-modify-macro, Data and Control Flow Dictionary @subsection defsetf [Macro] The ``short form'': @code{defsetf} @i{access-fn update-fn @r{[}documentation@r{]}}@* @result{} @i{access-fn} The ``long form'': @code{defsetf} @i{access-fn lambda-list @r{(}@{@i{store-variable}@}*@r{)} @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{access-fn} @subsubheading Arguments and Values:: @i{access-fn}---a @i{symbol} which names a @i{function} or a @i{macro}. @i{update-fn}---a @i{symbol} naming a @i{function} or @i{macro}. @i{lambda-list}---a @i{defsetf lambda list}. @i{store-variable}---a @i{symbol} (a @i{variable} @i{name}). @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{form}---a @i{form}. @subsubheading Description:: @b{defsetf} defines how to @b{setf} a @i{place} of the form @t{(@i{access-fn} ...)} for relatively simple cases. (See @b{define-setf-expander} for more general access to this facility.) It must be the case that the @i{function} or @i{macro} named by @i{access-fn} evaluates all of its arguments. @b{defsetf} may take one of two forms, called the ``short form'' and the ``long form,'' which are distinguished by the @i{type} of the second @i{argument}. When the short form is used, @i{update-fn} must name a @i{function} (or @i{macro}) that takes one more argument than @i{access-fn} takes. When @b{setf} is given a @i{place} that is a call on @i{access-fn}, it expands into a call on @i{update-fn} that is given all the arguments to @i{access-fn} and also, as its last argument, the new value (which must be returned by @i{update-fn} as its value). The long form @b{defsetf} resembles @b{defmacro}. The @i{lambda-list} describes the arguments of @i{access-fn}. The @i{store-variables} describe the value or values to be stored into the @i{place}. The @i{body} must compute the expansion of a @b{setf} of a call on @i{access-fn}. The expansion function is defined in the same @i{lexical environment} in which the @b{defsetf} @i{form} appears. During the evaluation of the @i{forms}, the variables in the @i{lambda-list} and the @i{store-variables} are bound to names of temporary variables, generated as if by @b{gensym} or @b{gentemp}, that will be bound by the expansion of @b{setf} to the values of those @i{subforms}. This binding permits the @i{forms} to be written without regard for order-of-evaluation issues. @b{defsetf} arranges for the temporary variables to be optimized out of the final result in cases where that is possible. The body code in @b{defsetf} is implicitly enclosed in a @i{block} whose name is @i{access-fn} @b{defsetf} ensures that @i{subforms} of the @i{place} are evaluated exactly once. @i{Documentation} is attached to @i{access-fn} as a @i{documentation string} of kind @b{setf}. If a @b{defsetf} @i{form} appears as a @i{top level form}, the @i{compiler} must make the @i{setf expander} available so that it may be used to expand calls to @b{setf} later on in the @i{file}. Users must ensure that the @i{forms}, if any, can be evaluated at compile time if the @i{access-fn} is used in a @i{place} later in the same @i{file}. The @i{compiler} must make these @i{setf expanders} available to compile-time calls to @b{get-setf-expansion} when its @i{environment} argument is a value received as the @i{environment parameter} of a @i{macro}. @subsubheading Examples:: The effect of @example (defsetf symbol-value set) @end example is built into the @r{Common Lisp} system. This causes the form @t{(setf (symbol-value foo) fu)} to expand into @t{(set foo fu)}. Note that @example (defsetf car rplaca) @end example would be incorrect because @b{rplaca} does not return its last argument. @example (defun middleguy (x) (nth (truncate (1- (list-length x)) 2) x)) @result{} MIDDLEGUY (defun set-middleguy (x v) (unless (null x) (rplaca (nthcdr (truncate (1- (list-length x)) 2) x) v)) v) @result{} SET-MIDDLEGUY (defsetf middleguy set-middleguy) @result{} MIDDLEGUY (setq a (list 'a 'b 'c 'd) b (list 'x) c (list 1 2 3 (list 4 5 6) 7 8 9)) @result{} (1 2 3 (4 5 6) 7 8 9) (setf (middleguy a) 3) @result{} 3 (setf (middleguy b) 7) @result{} 7 (setf (middleguy (middleguy c)) 'middleguy-symbol) @result{} MIDDLEGUY-SYMBOL a @result{} (A 3 C D) b @result{} (7) c @result{} (1 2 3 (4 MIDDLEGUY-SYMBOL 6) 7 8 9) @end example An example of the use of the long form of @b{defsetf}: @example (defsetf subseq (sequence start &optional end) (new-sequence) `(progn (replace ,sequence ,new-sequence :start1 ,start :end1 ,end) ,new-sequence)) @result{} SUBSEQ @end example @example (defvar *xy* (make-array '(10 10))) (defun xy (&key ((x x) 0) ((y y) 0)) (aref *xy* x y)) @result{} XY (defun set-xy (new-value &key ((x x) 0) ((y y) 0)) (setf (aref *xy* x y) new-value)) @result{} SET-XY (defsetf xy (&key ((x x) 0) ((y y) 0)) (store) `(set-xy ,store 'x ,x 'y ,y)) @result{} XY (get-setf-expansion '(xy a b)) @result{} (#:t0 #:t1), (a b), (#:store), ((lambda (&key ((x #:x)) ((y #:y))) (set-xy #:store 'x #:x 'y #:y)) #:t0 #:t1), (xy #:t0 #:t1) (xy 'x 1) @result{} NIL (setf (xy 'x 1) 1) @result{} 1 (xy 'x 1) @result{} 1 (let ((a 'x) (b 'y)) (setf (xy a 1 b 2) 3) (setf (xy b 5 a 9) 14)) @result{} 14 (xy 'y 0 'x 1) @result{} 1 (xy 'x 1 'y 2) @result{} 3 @end example @subsubheading See Also:: @ref{documentation} , @ref{setf} , @ref{define-setf-expander} , @ref{get-setf-expansion} , @ref{Generalized Reference}, @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: @i{forms} must include provision for returning the correct value (the value or values of @i{store-variable}). This is handled by @i{forms} rather than by @b{defsetf} because in many cases this value can be returned at no extra cost, by calling a function that simultaneously stores into the @i{place} and returns the correct value. A @b{setf} of a call on @i{access-fn} also evaluates all of @i{access-fn}'s arguments; it cannot treat any of them specially. This means that @b{defsetf} cannot be used to describe how to store into a @i{generalized reference} to a byte, such as @t{(ldb field reference)}. @b{define-setf-expander} is used to handle situations that do not fit the restrictions imposed by @b{defsetf} and gives the user additional control. @node define-setf-expander, get-setf-expansion, defsetf, Data and Control Flow Dictionary @subsection define-setf-expander [Macro] @code{define-setf-expander} @i{access-fn lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* @result{} @i{access-fn} @subsubheading Arguments and Values:: @i{access-fn}---a @i{symbol} that @i{names} a @i{function} or @i{macro}. @i{lambda-list} -- @i{macro lambda list}. @i{declaration}---a @b{declare} @i{expression}; not evaluated. @i{documentation}---a @i{string}; not evaluated. @i{forms}---an @i{implicit progn}. @subsubheading Description:: @b{define-setf-expander} specifies the means by which @b{setf} updates a @i{place} that is referenced by @i{access-fn}. When @b{setf} is given a @i{place} that is specified in terms of @i{access-fn} and a new value for the @i{place}, it is expanded into a form that performs the appropriate update. The @i{lambda-list} supports destructuring. See @ref{Macro Lambda Lists}. @i{Documentation} is attached to @i{access-fn} as a @i{documentation string} of kind @b{setf}. @i{Forms} constitute the body of the @i{setf expander} definition and must compute the @i{setf expansion} for a call on @b{setf} that references the @i{place} by means of the given @i{access-fn}. The @i{setf expander} function is defined in the same @i{lexical environment} in which the @b{define-setf-expander} @i{form} appears. While @i{forms} are being executed, the variables in @i{lambda-list} are bound to parts of the @i{place} @i{form}. The body @i{forms} (but not the @i{lambda-list}) in a @b{define-setf-expander} @i{form} are implicitly enclosed in a @i{block} whose name is @i{access-fn}. The evaluation of @i{forms} must result in the five values described in @ref{Setf Expansions}. If a @b{define-setf-expander} @i{form} appears as a @i{top level form}, the @i{compiler} must make the @i{setf expander} available so that it may be used to expand calls to @b{setf} later on in the @i{file}. @i{Programmers} must ensure that the @i{forms} can be evaluated at compile time if the @i{access-fn} is used in a @i{place} later in the same @i{file}. The @i{compiler} must make these @i{setf expanders} available to compile-time calls to @b{get-setf-expansion} when its @i{environment} argument is a value received as the @i{environment parameter} of a @i{macro}. @subsubheading Examples:: @example (defun lastguy (x) (car (last x))) @result{} LASTGUY (define-setf-expander lastguy (x &environment env) "Set the last element in a list to the given value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion x env) (let ((store (gensym))) (values dummies vals `(,store) `(progn (rplaca (last ,getter) ,store) ,store) `(lastguy ,getter))))) @result{} LASTGUY (setq a (list 'a 'b 'c 'd) b (list 'x) c (list 1 2 3 (list 4 5 6))) @result{} (1 2 3 (4 5 6)) (setf (lastguy a) 3) @result{} 3 (setf (lastguy b) 7) @result{} 7 (setf (lastguy (lastguy c)) 'lastguy-symbol) @result{} LASTGUY-SYMBOL a @result{} (A B C 3) b @result{} (7) c @result{} (1 2 3 (4 5 LASTGUY-SYMBOL)) @end example @example ;;; Setf expander for the form (LDB bytespec int). ;;; Recall that the int form must itself be suitable for SETF. (define-setf-expander ldb (bytespec int &environment env) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env);Get setf expansion for int. (let ((btemp (gensym)) ;Temp var for byte specifier. (store (gensym)) ;Temp var for byte to store. (stemp (first stores))) ;Temp var for int to store. (if (cdr stores) (error "Can't expand this.")) ;;; Return the setf expansion for LDB as five values. (values (cons btemp temps) ;Temporary variables. (cons bytespec vals) ;Value forms. (list store) ;Store variables. `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) ;Storing form. `(ldb ,btemp ,access-form) ;Accessing form. )))) @end example @subsubheading See Also:: @ref{setf} , @ref{defsetf} , @ref{documentation} , @ref{get-setf-expansion} , @ref{Syntactic Interaction of Documentation Strings and Declarations} @subsubheading Notes:: @b{define-setf-expander} differs from the long form of @b{defsetf} in that while the body is being executed the @i{variables} in @i{lambda-list} are bound to parts of the @i{place} @i{form}, not to temporary variables that will be bound to the values of such parts. In addition, @b{define-setf-expander} does not have @b{defsetf}'s restriction that @i{access-fn} must be a @i{function} or a function-like @i{macro}; an arbitrary @b{defmacro} destructuring pattern is permitted in @i{lambda-list}. @node get-setf-expansion, setf, define-setf-expander, Data and Control Flow Dictionary @subsection get-setf-expansion [Function] @code{get-setf-expansion} @i{place @r{&optional} environment}@* @result{} @i{vars, vals, store-vars, writer-form, reader-form} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{environment}---an @i{environment} @i{object}. @i{vars, vals, store-vars, writer-form, reader-form}---a @i{setf expansion}. @subsubheading Description:: Determines five values constituting the @i{setf expansion} for @i{place} in @i{environment}; see @ref{Setf Expansions}. If @i{environment} is not supplied or @b{nil}, the environment is the @i{null lexical environment}. @subsubheading Examples:: @example (get-setf-expansion 'x) @result{} NIL, NIL, (#:G0001), (SETQ X #:G0001), X @end example @example ;;; This macro is like POP (defmacro xpop (place &environment env) (multiple-value-bind (dummies vals new setter getter) (get-setf-expansion place env) `(let* (,@@(mapcar #'list dummies vals) (,(car new) ,getter)) (if (cdr new) (error "Can't expand this.")) (prog1 (car ,(car new)) (setq ,(car new) (cdr ,(car new))) ,setter)))) (defsetf frob (x) (value) `(setf (car ,x) ,value)) @result{} FROB ;;; The following is an error; an error might be signaled at macro expansion time (flet ((frob (x) (cdr x))) ;Invalid (xpop (frob z))) @end example @subsubheading See Also:: @ref{defsetf} , @ref{define-setf-expander} , @ref{setf} @subsubheading Notes:: Any @i{compound form} is a valid @i{place}, since any @i{compound form} whose @i{operator} @i{f} has no @i{setf expander} are expanded into a call to @t{(setf @i{f})}. @node setf, shiftf, get-setf-expansion, Data and Control Flow Dictionary @subsection setf, psetf [Macro] @code{setf} @i{@{!@i{pair}@}*} @result{} @i{@{@i{result}@}*} @code{psetf} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} @w{@i{pair} ::=place newvalue} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{newvalue}---a @i{form}. @i{results}---the @i{multiple values}_2 returned by the storing form for the last @i{place}, or @b{nil} if there are no @i{pairs}. @subsubheading Description:: @b{setf} changes the @i{value} of @i{place} to be @i{newvalue}. @t{(setf place newvalue)} expands into an update form that stores the result of evaluating @i{newvalue} into the location referred to by @i{place}. Some @i{place} forms involve uses of accessors that take optional arguments. Whether those optional arguments are permitted by @b{setf}, or what their use is, is up to the @b{setf} expander function and is not under the control of @b{setf}. The documentation for any @i{function} that accepts @b{&optional}, @b{&rest}, or @t{&key} arguments and that claims to be usable with @b{setf} must specify how those arguments are treated. If more than one @i{pair} is supplied, the @i{pairs} are processed sequentially; that is, @example (setf place-1 newvalue-1 place-2 newvalue-2 ... place-N newvalue-N) @end example is precisely equivalent to @example (progn (setf place-1 newvalue-1) (setf place-2 newvalue-2) ... (setf place-N newvalue-N)) @end example For @b{psetf}, if more than one @i{pair} is supplied then the assignments of new values to places are done in parallel. More precisely, all @i{subforms} (in both the @i{place} and @i{newvalue} @i{forms}) that are to be evaluated are evaluated from left to right; after all evaluations have been performed, all of the assignments are performed in an unpredictable order. For detailed treatment of the expansion of @b{setf} and @b{psetf}, see @ref{Kinds of Places}. @subsubheading Examples:: @example (setq x (cons 'a 'b) y (list 1 2 3)) @result{} (1 2 3) (setf (car x) 'x (cadr y) (car x) (cdr x) y) @result{} (1 X 3) x @result{} (X 1 X 3) y @result{} (1 X 3) (setq x (cons 'a 'b) y (list 1 2 3)) @result{} (1 2 3) (psetf (car x) 'x (cadr y) (car x) (cdr x) y) @result{} NIL x @result{} (X 1 A 3) y @result{} (1 A 3) @end example @subsubheading Affected By:: @b{define-setf-expander}, @b{defsetf}, @b{*macroexpand-hook*} @subsubheading See Also:: @ref{define-setf-expander} , @ref{defsetf} , @b{macroexpand-1}, @ref{rotatef} , @ref{shiftf} , @ref{Generalized Reference} @node shiftf, rotatef, setf, Data and Control Flow Dictionary @subsection shiftf [Macro] @code{shiftf} @i{@{@i{place}@}^+ newvalue} @result{} @i{old-value-1} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @i{newvalue}---a @i{form}; evaluated. @i{old-value-1}---an @i{object} (the old @i{value} of the first @i{place}). @subsubheading Description:: @b{shiftf} modifies the values of each @i{place} by storing @i{newvalue} into the last @i{place}, and shifting the values of the second through the last @i{place} into the remaining @i{places}. If @i{newvalue} produces more values than there are store variables, the extra values are ignored. If @i{newvalue} produces fewer values than there are store variables, the missing values are set to @b{nil}. In the form @t{(shiftf @i{place1} @i{place2} ... @i{placen} @i{newvalue})}, the values in @i{place1} through @i{placen} are @i{read} and saved, and @i{newvalue} is evaluated, for a total of @t{n}+1 values in all. Values 2 through @t{n}+1 are then stored into @i{place1} through @i{placen}, respectively. It is as if all the @i{places} form a shift register; the @i{newvalue} is shifted in from the right, all values shift over to the left one place, and the value shifted out of @i{place1} is returned. For information about the @i{evaluation} of @i{subforms} of @i{places}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (setq x (list 1 2 3) y 'trash) @result{} TRASH (shiftf y x (cdr x) '(hi there)) @result{} TRASH x @result{} (2 3) y @result{} (1 HI THERE) (setq x (list 'a 'b 'c)) @result{} (A B C) (shiftf (cadr x) 'z) @result{} B x @result{} (A Z C) (shiftf (cadr x) (cddr x) 'q) @result{} Z x @result{} (A (C) . Q) (setq n 0) @result{} 0 (setq x (list 'a 'b 'c 'd)) @result{} (A B C D) (shiftf (nth (setq n (+ n 1)) x) 'z) @result{} B x @result{} (A Z C D) @end example @subsubheading Affected By:: @b{define-setf-expander}, @b{defsetf}, @b{*macroexpand-hook*} @subsubheading See Also:: @ref{setf} , @ref{rotatef} , @ref{Generalized Reference} @subsubheading Notes:: The effect of @t{(shiftf @i{place1} @i{place2} ... @i{placen} @i{newvalue})} is roughly equivalent to @example (let ((var1 @i{place1}) (var2 @i{place2}) ... (varn @i{placen}) (var0 @i{newvalue})) (setf @i{place1} var2) (setf @i{place2} var3) ... (setf @i{placen} var0) var1) @end example except that the latter would evaluate any @i{subforms} of each @t{place} twice, whereas @b{shiftf} evaluates them once. For example, @example (setq n 0) @result{} 0 (setq x (list 'a 'b 'c 'd)) @result{} (A B C D) (prog1 (nth (setq n (+ n 1)) x) (setf (nth (setq n (+ n 1)) x) 'z)) @result{} B x @result{} (A B Z D) @end example @node rotatef, control-error, shiftf, Data and Control Flow Dictionary @subsection rotatef [Macro] @code{rotatef} @i{@{@i{place}@}*} @result{} @i{@b{nil}} @subsubheading Arguments and Values:: @i{place}---a @i{place}. @subsubheading Description:: @b{rotatef} modifies the values of each @i{place} by rotating values from one @i{place} into another. If a @i{place} produces more values than there are store variables, the extra values are ignored. If a @i{place} produces fewer values than there are store variables, the missing values are set to @b{nil}. In the form @t{(rotatef @i{place1} @i{place2} ... @i{placen})}, the values in @i{place1} through @i{placen} are @i{read} and @i{written}. Values 2 through @i{n} and value 1 are then stored into @i{place1} through @i{placen}. It is as if all the places form an end-around shift register that is rotated one place to the left, with the value of @i{place1} being shifted around the end to @i{placen}. For information about the @i{evaluation} of @i{subforms} of @i{places}, see @ref{Evaluation of Subforms to Places}. @subsubheading Examples:: @example (let ((n 0) (x (list 'a 'b 'c 'd 'e 'f 'g))) (rotatef (nth (incf n) x) (nth (incf n) x) (nth (incf n) x)) x) @result{} (A C D B E F G) @end example @subsubheading See Also:: @ref{define-setf-expander} , @ref{defsetf} , @ref{setf} , @ref{shiftf} , @b{*macroexpand-hook*}, @ref{Generalized Reference} @subsubheading Notes:: The effect of @t{(rotatef @i{place1} @i{place2} ... @i{placen})} is roughly equivalent to @example (psetf @i{place1} @i{place2} @i{place2} @i{place3} ... @i{placen} @i{place1}) @end example except that the latter would evaluate any @i{subforms} of each @t{place} twice, whereas @b{rotatef} evaluates them once. @node control-error, program-error, rotatef, Data and Control Flow Dictionary @subsection control-error [Condition Type] @subsubheading Class Precedence List:: @b{control-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{control-error} consists of error conditions that result from invalid dynamic transfers of control in a program. The errors that result from giving @b{throw} a tag that is not active or from giving @b{go} or @b{return-from} a tag that is no longer dynamically available are of @i{type} @b{control-error}. @node program-error, undefined-function, control-error, Data and Control Flow Dictionary @subsection program-error [Condition Type] @subsubheading Class Precedence List:: @b{program-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{program-error} consists of error conditions related to incorrect program syntax. The errors that result from naming a @i{go tag} or a @i{block tag} that is not lexically apparent are of @i{type} @b{program-error}. @node undefined-function, , program-error, Data and Control Flow Dictionary @subsection undefined-function [Condition Type] @subsubheading Class Precedence List:: @b{undefined-function}, @b{cell-error}, @b{error}, @b{serious-condition}, @b{condition}, @b{t} @subsubheading Description:: The @i{type} @b{undefined-function} consists of @i{error} @i{conditions} that represent attempts to @i{read} the definition of an @i{undefined function}. The name of the cell (see @b{cell-error}) is the @i{function name} which was @i{funbound}. @subsubheading See Also:: @ref{cell-error-name} @c end of including dict-flow @c %**end of chapter gcl-2.6.14/info/chap-16.texi0000644000175000017500000005615014360276512013767 0ustar cammcamm @node Strings, Sequences, Arrays, Top @chapter Strings @menu * String Concepts:: * Strings Dictionary:: @end menu @node String Concepts, Strings Dictionary, Strings, Strings @section String Concepts @c including concept-strings @menu * Implications of Strings Being Arrays:: * Subtypes of STRING:: @end menu @node Implications of Strings Being Arrays, Subtypes of STRING, String Concepts, String Concepts @subsection Implications of Strings Being Arrays Since all @i{strings} are @i{arrays}, all rules which apply generally to @i{arrays} also apply to @i{strings}. See @ref{Array Concepts}. For example, @i{strings} can have @i{fill pointers}, and @i{strings} are also subject to the rules of @i{element type} @i{upgrading} that apply to @i{arrays}. @node Subtypes of STRING, , Implications of Strings Being Arrays, String Concepts @subsection Subtypes of STRING All functions that operate on @i{strings} will operate on @i{subtypes} of @i{string} as well. However, the consequences are undefined if a @i{character} is inserted into a @i{string} for which the @i{element type} of the @i{string} does not include that @i{character}. @c end of including concept-strings @node Strings Dictionary, , String Concepts, Strings @section Strings Dictionary @c including dict-strings @menu * string (System Class):: * base-string:: * simple-string:: * simple-base-string:: * simple-string-p:: * char:: * string:: * string-upcase:: * string-trim:: * string=:: * stringp:: * make-string:: @end menu @node string (System Class), base-string, Strings Dictionary, Strings Dictionary @subsection string [System Class] @subsubheading Class Precedence List:: @b{string}, @b{vector}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: A @i{string} is a @i{specialized} @i{vector} whose @i{elements} are of @i{type} @b{character} or a @i{subtype} of @i{type} @b{character}. When used as a @i{type specifier} for object creation, @b{string} means @t{(vector character)}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{string}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the union of all @i{types} @t{(array @i{c} (@i{size}))} for all @i{subtypes} @i{c} of @b{character}; that is, the set of @i{strings} of size @i{size}. @subsubheading See Also:: @ref{String Concepts}, @ref{Double-Quote}, @ref{Printing Strings} @node base-string, simple-string, string (System Class), Strings Dictionary @subsection base-string [Type] @subsubheading Supertypes:: @b{base-string}, @b{string}, @b{vector}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: The @i{type} @b{base-string} is equivalent to @t{(vector base-char)}. The @i{base string} representation is the most efficient @i{string} representation that can hold an arbitrary sequence of @i{standard characters}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{base-string}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This is equivalent to the type @t{(vector base-char @i{size})}; that is, the set of @i{base strings} of size @i{size}. @node simple-string, simple-base-string, base-string, Strings Dictionary @subsection simple-string [Type] @subsubheading Supertypes:: @b{simple-string}, @b{string}, @b{vector}, @b{simple-array}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: A @i{simple string} is a specialized one-dimensional @i{simple array} whose @i{elements} are of @i{type} @b{character} or a @i{subtype} of @i{type} @b{character}. When used as a @i{type specifier} for object creation, @b{simple-string} means @t{(simple-array character (@i{size}))}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{simple-string}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This denotes the union of all @i{types} @t{(simple-array @i{c} (@i{size}))} for all @i{subtypes} @i{c} of @b{character}; that is, the set of @i{simple strings} of size @i{size}. @node simple-base-string, simple-string-p, simple-string, Strings Dictionary @subsection simple-base-string [Type] @subsubheading Supertypes:: @b{simple-base-string}, @b{base-string}, @b{simple-string}, @b{string}, @b{vector}, @b{simple-array}, @b{array}, @b{sequence}, @b{t} @subsubheading Description:: The @i{type} @b{simple-base-string} is equivalent to @t{(simple-array base-char (*))}. @subsubheading Compound Type Specifier Kind:: Abbreviating. @subsubheading Compound Type Specifier Syntax:: (@code{simple-base-string}@{@i{@t{[}size@t{]}}@}) @subsubheading Compound Type Specifier Arguments:: @i{size}---a non-negative @i{fixnum}, or the @i{symbol} @b{*}. @subsubheading Compound Type Specifier Description:: This is equivalent to the type @t{(simple-array base-char (@i{size}))}; that is, the set of @i{simple base strings} of size @i{size}. @node simple-string-p, char, simple-base-string, Strings Dictionary @subsection simple-string-p [Function] @code{simple-string-p} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{simple-string}; otherwise, returns @i{false}. @subsubheading Examples:: @example (simple-string-p "aaaaaa") @result{} @i{true} (simple-string-p (make-array 6 :element-type 'character :fill-pointer t)) @result{} @i{false} @end example @subsubheading Notes:: @example (simple-string-p @i{object}) @equiv{} (typep @i{object} 'simple-string) @end example @node char, string, simple-string-p, Strings Dictionary @subsection char, schar [Accessor] @code{char} @i{string index} @result{} @i{character} @code{schar} @i{string index} @result{} @i{character} (setf (@code{char} @i{string index}) new-character)@*(setf (@code{schar} @i{string index}) new-character)@* @subsubheading Arguments and Values:: @i{string}---for @b{char}, a @i{string}; for @b{schar}, a @i{simple string}. @i{index}---a @i{valid array index} for the @i{string}. @i{character}, @i{new-character}---a @i{character}. @subsubheading Description:: @b{char} and @b{schar} @i{access} the @i{element} of @i{string} specified by @i{index}. @b{char} ignores @i{fill pointers} when @i{accessing} @i{elements}. @subsubheading Examples:: @example (setq my-simple-string (make-string 6 :initial-element #\A)) @result{} "AAAAAA" (schar my-simple-string 4) @result{} #\A (setf (schar my-simple-string 4) #\B) @result{} #\B my-simple-string @result{} "AAAABA" (setq my-filled-string (make-array 6 :element-type 'character :fill-pointer 5 :initial-contents my-simple-string)) @result{} "AAAAB" (char my-filled-string 4) @result{} #\B (char my-filled-string 5) @result{} #\A (setf (char my-filled-string 3) #\C) @result{} #\C (setf (char my-filled-string 5) #\D) @result{} #\D (setf (fill-pointer my-filled-string) 6) @result{} 6 my-filled-string @result{} "AAACBD" @end example @subsubheading See Also:: @ref{aref} , @ref{elt} , @ref{Compiler Terminology} @subsubheading Notes:: @example (char s j) @equiv{} (aref (the string s) j) @end example @node string, string-upcase, char, Strings Dictionary @subsection string [Function] @code{string} @i{x} @result{} @i{string} @subsubheading Arguments and Values:: @i{x}---a @i{string}, a @i{symbol}, or a @i{character}. @i{string}---a @i{string}. @subsubheading Description:: Returns a @i{string} described by @i{x}; specifically: @table @asis @item @t{*} If @i{x} is a @i{string}, it is returned. @item @t{*} If @i{x} is a @i{symbol}, its @i{name} is returned. @item @t{*} If @i{x} is a @i{character}, then a @i{string} containing that one @i{character} is returned. @item @t{*} @b{string} might perform additional, @i{implementation-defined} conversions. @end table @subsubheading Examples:: @example (string "already a string") @result{} "already a string" (string 'elm) @result{} "ELM" (string #\c) @result{} "c" @end example @subsubheading Exceptional Situations:: In the case where a conversion is defined neither by this specification nor by the @i{implementation}, an error of @i{type} @b{type-error} is signaled. @subsubheading See Also:: @ref{coerce} , @b{string} (@i{type}). @subsubheading Notes:: @b{coerce} can be used to convert a @i{sequence} of @i{characters} to a @i{string}. @b{prin1-to-string}, @b{princ-to-string}, @b{write-to-string}, or @b{format} (with a first argument of @b{nil}) can be used to get a @i{string} representation of a @i{number} or any other @i{object}. @node string-upcase, string-trim, string, Strings Dictionary @subsection string-upcase, string-downcase, string-capitalize, @subheading nstring-upcase, nstring-downcase, nstring-capitalize @flushright @i{[Function]} @end flushright @code{string-upcase} @i{string @r{&key} start end} @result{} @i{cased-string} @code{string-downcase} @i{string @r{&key} start end} @result{} @i{cased-string} @code{string-capitalize} @i{string @r{&key} start end} @result{} @i{cased-string} @code{nstring-upcase} @i{string @r{&key} start end} @result{} @i{string} @code{nstring-downcase} @i{string @r{&key} start end} @result{} @i{string} @code{nstring-capitalize} @i{string @r{&key} start end} @result{} @i{string} @subsubheading Arguments and Values:: @i{string}---a @i{string designator}. For @b{nstring-upcase}, @b{nstring-downcase}, and @b{nstring-capitalize}, the @i{string} @i{designator} must be a @i{string}. @i{start}, @i{end}---@i{bounding index designators} of @i{string}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{cased-string}---a @i{string}. @subsubheading Description:: @b{string-upcase}, @b{string-downcase}, @b{string-capitalize}, @b{nstring-upcase}, @b{nstring-downcase}, @b{nstring-capitalize} change the case of the subsequence of @i{string} @i{bounded} by @i{start} and @i{end} as follows: @table @asis @item string-upcase @b{string-upcase} returns a @i{string} just like @i{string} with all lowercase characters replaced by the corresponding uppercase characters. More precisely, each character of the result @i{string} is produced by applying the @i{function} @b{char-upcase} to the corresponding character of @i{string}. @item string-downcase @b{string-downcase} is like @b{string-upcase} except that all uppercase characters are replaced by the corresponding lowercase characters (using @b{char-downcase}). @item string-capitalize @b{string-capitalize} produces a copy of @i{string} such that, for every word in the copy, the first @i{character} of the ``word,'' if it has @i{case}, is @i{uppercase} and any other @i{characters} with @i{case} in the word are @i{lowercase}. For the purposes of @b{string-capitalize}, a ``word'' is defined to be a consecutive subsequence consisting of @i{alphanumeric} @i{characters}, delimited at each end either by a non-@i{alphanumeric} @i{character} or by an end of the @i{string}. @item nstring-upcase, nstring-downcase, nstring-capitalize @b{nstring-upcase}, @b{nstring-downcase}, and @b{nstring-capitalize} are identical to @b{string-upcase}, @b{string-downcase}, and @b{string-capitalize} respectively except that they modify @i{string}. @end table For @b{string-upcase}, @b{string-downcase}, and @b{string-capitalize}, @i{string} is not modified. However, if no characters in @i{string} require conversion, the result may be either @i{string} or a copy of it, at the implementation's discretion. @subsubheading Examples:: @example (string-upcase "abcde") @result{} "ABCDE" (string-upcase "Dr. Livingston, I presume?") @result{} "DR. LIVINGSTON, I PRESUME?" (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10) @result{} "Dr. LiVINGston, I presume?" (string-downcase "Dr. Livingston, I presume?") @result{} "dr. livingston, i presume?" (string-capitalize "elm 13c arthur;fig don't") @result{} "Elm 13c Arthur;Fig Don'T" (string-capitalize " hello ") @result{} " Hello " (string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION") @result{} "Occluded Casements Forestall Inadvertent Defenestration" (string-capitalize 'kludgy-hash-search) @result{} "Kludgy-Hash-Search" (string-capitalize "DON'T!") @result{} "Don'T!" ;not "Don't!" (string-capitalize "pipe 13a, foo16c") @result{} "Pipe 13a, Foo16c" (setq str (copy-seq "0123ABCD890a")) @result{} "0123ABCD890a" (nstring-downcase str :start 5 :end 7) @result{} "0123AbcD890a" str @result{} "0123AbcD890a" @end example @subsubheading Side Effects:: @b{nstring-upcase}, @b{nstring-downcase}, and @b{nstring-capitalize} modify @i{string} as appropriate rather than constructing a new @i{string}. @subsubheading See Also:: @ref{char-upcase} , @b{char-downcase} @subsubheading Notes:: The result is always of the same length as @i{string}. @node string-trim, string=, string-upcase, Strings Dictionary @subsection string-trim, string-left-trim, string-right-trim [Function] @code{string-trim} @i{character-bag string} @result{} @i{trimmed-string} @code{string-left-trim} @i{character-bag string} @result{} @i{trimmed-string} @code{string-right-trim} @i{character-bag string} @result{} @i{trimmed-string} @subsubheading Arguments and Values:: @i{character-bag}---a @i{sequence} containing @i{characters}. @i{string}---a @i{string designator}. @i{trimmed-string}---a @i{string}. @subsubheading Description:: @b{string-trim} returns a substring of @i{string}, with all characters in @i{character-bag} stripped off the beginning and end. @b{string-left-trim} is similar but strips characters off only the beginning; @b{string-right-trim} strips off only the end. If no @i{characters} need to be trimmed from the @i{string}, then either @i{string} itself or a copy of it may be returned, at the discretion of the implementation. All of these @i{functions} observe the @i{fill pointer}. @subsubheading Examples:: @example (string-trim "abc" "abcaakaaakabcaaa") @result{} "kaaak" (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans ") @result{} "garbanzo beans" (string-trim " (*)" " ( *three (silly) words* ) ") @result{} "three (silly) words" (string-left-trim "abc" "labcabcabc") @result{} "labcabcabc" (string-left-trim " (*)" " ( *three (silly) words* ) ") @result{} "three (silly) words* ) " (string-right-trim " (*)" " ( *three (silly) words* ) ") @result{} " ( *three (silly) words" @end example @subsubheading Affected By:: The @i{implementation}. @node string=, stringp, string-trim, Strings Dictionary @subsection string=, string/=, string<, string>, string<=, string>=, @subheading string-equal, string-not-equal, string-lessp, @subheading string-greaterp, string-not-greaterp, string-not-lessp @flushright @i{[Function]} @end flushright @code{string=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} @code{string/=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string<} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string>} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string<=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string>=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} @code{string-not-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string-not-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @code{string-not-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} @subsubheading Arguments and Values:: @i{string1}---a @i{string designator}. @i{string2}---a @i{string designator}. @i{start1}, @i{end1}---@i{bounding index designators} of @i{string1}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{start2}, @i{end2}---@i{bounding index designators} of @i{string2}. The defaults for @i{start} and @i{end} are @t{0} and @b{nil}, respectively. @i{generalized-boolean}---a @i{generalized boolean}. @i{mismatch-index}---a @i{bounding index} of @i{string1}, or @b{nil}. @subsubheading Description:: These functions perform lexicographic comparisons on @i{string1} and @i{string2}. @b{string=} and @b{string-equal} are called equality functions; the others are called inequality functions. The comparison operations these @i{functions} perform are restricted to the subsequence of @i{string1} @i{bounded} by @i{start1} and @i{end1} and to the subsequence of @i{string2} @i{bounded} by @i{start2} and @i{end2}. A string @i{a} is equal to a string @i{b} if it contains the same number of characters, and the corresponding characters are the @i{same} under @b{char=} or @b{char-equal}, as appropriate. A string @i{a} is less than a string @i{b} if in the first position in which they differ the character of @i{a} is less than the corresponding character of @i{b} according to @b{char<} or @b{char-lessp} as appropriate, or if string @i{a} is a proper prefix of string @i{b} (of shorter length and matching in all the characters of @i{a}). The equality functions return a @i{generalized boolean} that is @i{true} if the strings are equal, or @i{false} otherwise. The inequality functions return a @i{mismatch-index} that is @i{true} if the strings are not equal, or @i{false} otherwise. When the @i{mismatch-index} is @i{true}, it is an @i{integer} representing the first character position at which the two substrings differ, as an offset from the beginning of @i{string1}. The comparison has one of the following results: @table @asis @item @b{string=} @b{string=} is @i{true} if the supplied substrings are of the same length and contain the @i{same} characters in corresponding positions; otherwise it is @i{false}. @item @b{string/=} @b{string/=} is @i{true} if the supplied substrings are different; otherwise it is @i{false}. @item @b{string-equal} @b{string-equal} is just like @b{string=} except that differences in case are ignored; two characters are considered to be the same if @b{char-equal} is @i{true} of them. @item @b{string<} @b{string<} is @i{true} if substring1 is less than substring2; otherwise it is @i{false}. @item @b{string>} @b{string>} is @i{true} if substring1 is greater than substring2; otherwise it is @i{false}. @item @b{string-lessp}, @b{string-greaterp} @b{string-lessp} and @b{string-greaterp} are exactly like @b{string<} and @b{string>}, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if @b{char-lessp} were used instead of @b{char<} for comparing characters. @item @b{string<=} @b{string<=} is @i{true} if substring1 is less than or equal to substring2; otherwise it is @i{false}. @item @b{string>=} @b{string>=} is @i{true} if substring1 is greater than or equal to substring2; otherwise it is @i{false}. @item @b{string-not-greaterp}, @b{string-not-lessp} @b{string-not-greaterp} and @b{string-not-lessp} are exactly like @b{string<=} and @b{string>=}, respectively, except that distinctions between uppercase and lowercase letters are ignored. It is as if @b{char-lessp} were used instead of @b{char<} for comparing characters. @end table @subsubheading Examples:: @example (string= "foo" "foo") @result{} @i{true} (string= "foo" "Foo") @result{} @i{false} (string= "foo" "bar") @result{} @i{false} (string= "together" "frog" :start1 1 :end1 3 :start2 2) @result{} @i{true} (string-equal "foo" "Foo") @result{} @i{true} (string= "abcd" "01234abcd9012" :start2 5 :end2 9) @result{} @i{true} (string< "aaaa" "aaab") @result{} 3 (string>= "aaaaa" "aaaa") @result{} 4 (string-not-greaterp "Abcde" "abcdE") @result{} 5 (string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7 :start2 2 :end2 6) @result{} 6 (string-not-equal "AAAA" "aaaA") @result{} @i{false} @end example @subsubheading See Also:: @ref{char=} @subsubheading Notes:: @b{equal} calls @b{string=} if applied to two @i{strings}. @node stringp, make-string, string=, Strings Dictionary @subsection stringp [Function] @code{stringp} @i{object} @result{} @i{generalized-boolean} @subsubheading Arguments and Values:: @i{object}---an @i{object}. @i{generalized-boolean}---a @i{generalized boolean}. @subsubheading Description:: Returns @i{true} if @i{object} is of @i{type} @b{string}; otherwise, returns @i{false}. @subsubheading Examples:: @example (stringp "aaaaaa") @result{} @i{true} (stringp #\a) @result{} @i{false} @end example @subsubheading See Also:: @ref{typep} , @b{string} (@i{type}) @subsubheading Notes:: @example (stringp @i{object}) @equiv{} (typep @i{object} 'string) @end example @node make-string, , stringp, Strings Dictionary @subsection make-string [Function] @code{make-string} @i{size @r{&key} initial-element element-type} @result{} @i{string} @subsubheading Arguments and Values:: @i{size}---a @i{valid array dimension}. @i{initial-element}---a @i{character}. The default is @i{implementation-dependent}. @i{element-type}---a @i{type specifier}. The default is @b{character}. @i{string}---a @i{simple string}. @subsubheading Description:: @b{make-string} returns a @i{simple string} of length @i{size} whose elements have been initialized to @i{initial-element}. The @i{element-type} names the @i{type} of the @i{elements} of the @i{string}; a @i{string} is constructed of the most @i{specialized} @i{type} that can accommodate @i{elements} of the given @i{type}. @subsubheading Examples:: @example (make-string 10 :initial-element #\5) @result{} "5555555555" (length (make-string 10)) @result{} 10 @end example @subsubheading Affected By:: The @i{implementation}. @c end of including dict-strings @c %**end of chapter gcl-2.6.14/info/.gitignore0000644000175000017500000000016614360276512013721 0ustar cammcamm*.aux *.cp *.dvi *.fn *.ky *.pg *.toc *.tp *.vr *.info* *.IC *.IE *.IG *.IP *.IR *.IT *.fu *.log gcl/ gcl-tk/ gcl-si/ gcl-2.6.14/install.sh0000644000175000017500000001256214360276512013003 0ustar cammcamm#! /bin/sh # # install - install a program, script, or datafile # This comes from X11R5 (mit/util/scripts/install.sh). # # Copyright 1991 by the Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. # # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" mkdirprog="${MKDIRPROG-mkdir}" transformbasename="" transform_arg="" instcmd="$mvprog" chmodcmd="$chmodprog 0755" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" dir_arg="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -d) dir_arg=true shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; -t=*) transformarg=`echo $1 | sed 's/-t=//'` shift continue;; -b=*) transformbasename=`echo $1 | sed 's/-b=//'` shift continue;; *) if [ x"$src" = x ] then src=$1 else # this colon is to work around a 386BSD /bin/sh bug : dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 else true fi if [ x"$dir_arg" != x ]; then dst=$src src="" if [ -d $dst ]; then instcmd=: else instcmd=mkdir fi else # Waiting for this to be detected by the "$instcmd $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if [ -f $src -o -d $src ] then true else echo "install: $src does not exist" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 else true fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` else true fi fi ## this sed command emulates the dirname command dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` # Make sure that the destination directory exists. # this part is taken from Noah Friedman's mkinstalldirs script # Skip lots of stat calls in the usual case. if [ ! -d "$dstdir" ]; then defaultIFS=' ' IFS="${IFS-${defaultIFS}}" oIFS="${IFS}" # Some sh's can't handle IFS=/ for some reason. IFS='%' set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` IFS="${oIFS}" pathcomp='' while [ $# -ne 0 ] ; do pathcomp="${pathcomp}${1}" shift if [ ! -d "${pathcomp}" ] ; then $mkdirprog "${pathcomp}" else true fi pathcomp="${pathcomp}/" done fi if [ x"$dir_arg" != x ] then $doit $instcmd $dst && if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi else # If we're going to rename the final executable, determine the name now. if [ x"$transformarg" = x ] then dstfile=`basename $dst` else dstfile=`basename $dst $transformbasename | sed $transformarg`$transformbasename fi # don't allow the sed command to completely eliminate the filename if [ x"$dstfile" = x ] then dstfile=`basename $dst` else true fi # Make a temp file name in the proper directory. dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp && trap "rm -f ${dsttmp}" 0 && # and set any options; do chmod last to preserve setuid bits # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $instcmd $src $dsttmp" command. if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && # Now rename the file to the real destination. $doit $rmcmd -f $dstdir/$dstfile && $doit $mvcmd $dsttmp $dstdir/$dstfile fi && exit 0 gcl-2.6.14/README.macosx0000644000175000017500000000044014360276512013142 0ustar cammcammOn some recent mac boxes (e.g. 10.6) running 64bit capable processors, the default configure scripts detect the cpu as 32bit only. To get a 64bit build, do: ./configure --build=x86_64-apple-darwin10.4.0 .... where the key item is the x86_64, and some darwin string in the last place. gcl-2.6.14/gcl2.jpg0000644000175000017500000001315114360276512012325 0ustar cammcammJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222|," }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( (]sOrB2#ʟz}>%׆h?5]6DFwQƽ[O֭ﭢPHzZ56< vY_y{5 -S?zQE! fIvx- ^ "v5Z_jdqOֹbiM_ b+ܫ-vx]ʑxEMZOƾp{/q41drusk؇ O>O6լ jWpλ90+J 浐=BFHX|/{>xJ=iо#j|ۡfXk5{x-Y"eXwUQh|;-f7\VUZxLSZOmh绗$`^OO}?Wuk)S-wOEVOl&J>Fx輌|Iǭgc%wU}OPٮv-lW,"PrN2kV .՞)٧ ((O6k &..bd<{TTǙX<%L]UJ2I?馴n-d KWi^I%kȫVU/-5W]$MZȑoJ7h\N2<եo*Z+e)?SJYeyWJZ)UY 2}+E)(U? 6}uyR1/?TT@>zZifztFTWOfK+g>T2z0*[I Wq8<t4\„k[jatvQyn|I^k:E r{7?5PrwgG_Rϩ}6RKy4h؎k:o sq].ÂY7:'mcB=fܪ I%k8å<%ZӘ0t"r-qc6 B%]Kԧ2^kk4m*#_ǩ=kӬB}Qs&r~.,yWS0JwZkH?Ȃ(0UK0Q6^֫ۯcjdaz8ZJ1{Uj<ֶM!V完X4/v2Yj|c!߆P8i~VG]-&GEPቮ'0Qױoo x_&҈K15hw>31E}uo'@6]cq^a]oYX`Tsb˚=얂w@8̂y߈iJdz<s/inq]j>^+J3m:.*+8PAƭmi+ri"1v*sWjaUZS#hϳtkKIz2Ҍ/VVV-z+Bi?)UG [=8+wF]سܞMzŝW5aq~Uc'y>߆ܘwU'/7 ( +Wed=2X6Cxjyb~g֕WvoW`\(68E(+09:Θ-ٿ6WWao?J+$DG|R=&yQ^I+sN\:ӯ-X.g ƥ%wzn\v&cԲO^IA$]٭"~#yn_8KVhӕ;mHWxD:A#i1J־#_,?N~U##I#1'޸52lE E=ϤmE]H "]mWN$zslg5o=?S~7C؋k/ʹby,v>'^^ڿv%\u .M7[H܀~-`z m;iS7*[_V MHaB9v~:WqqּKX#`]3k?`noX=axCg؇F!1oDjkf+P-kwiYf>I^<'&~R(앂ҙJS)qӖXujN?ӢC/j6jXz[|g[5 1^ \{Ir}s]wAZS2u{Sϕ=pb6}fEӍ5mOCr##꓾(E*1‚~b;Bys Rrbq|2Y[˯AM+aGϥiA' +^MgazTh*z>/2ͪc* i̼T16E?4ｇ+#Kұė*pibNȰ#J?ϽJ(hr.}M ]9(E[#Lqb+ @G5r9ejtPm{p,TQ&VUew;Y (åfة+MGg03KEP:+4*+keS8ZmtBq= |æ*㊿j,+vhLq[tV0;Tb#8Q"+c皶|J.k! Q`Wq+gpUIGc_CUhR@SҝEQEgcl-2.6.14/machines0000755000175000017500000000325114360276512012511 0ustar cammcamm names for various supported machines. * 386-linux: 386 or 486 running linux (a.out or elf) * 386-bsd: 386 or 486 running bsd * alpha-osf1: Dec alpha DEC OSF/1 V3.2 Worksystem Software (Rev. 214) * dec3100: Decstation 3100,5000, OS=Ultrix V3.1C-0 (Rev. 42) [akcl 505] ULTRIX V4.2 (Rev. 96)[akcl 602] (VOL= ) * hp300-bsd: Hp 350, 370 [motorola 68K] under 4.3 BSD (mt xinu) * hp300: Hp 350, 370 under HPUX. * hp800: Hp 720,730 under HPUX (version 8). Possibly hp 800 also * mac2: Macintosh under AUX (unix) * mingw: Windows built with MSYS hosted Mingw32 gcc * mp386: intel 386 under System V 3 (eg microport,interactive) * NeXT30-m68k: NeXT (M68K) under NeXTSTEP 3.0 * NeXT32-m68k: NeXT (M68K) under NeXTSTEP 3.2, 3.3 (gcc-2.6.3 is required) * NeXT32-i386: NeXT (I386) under NeXTSTEP 3.2, 3.3 (gcc-2.6.3 is required) * ncr: intel 386 under System V 4 (loader sfasl not done). * ps2_aix: ibm ps2 under aix * rios: Ibm risc 6000 under aix3. * rios: Ibm risc 6000 under aix4.3 but load does not yet work. * rt_aix: ibm rt under aix release 2. * sgi4d: 4d silicon graphics (IRIX System V Release 3.3.1)[akcl 600] * sgi: silicon graphics 3d versions * irix5: silicon graphics (IRIX Rel 5.2) /*cant save dynamically loaded*/ * sun3-os4: sun3 under os 4.03, 4.1, 4.1.1 * sun3: Sun 3 (motorola 68K) Sun OS 3.5 * sun4: Sun 4,(sparc) sparctations, sun os 4.03, 4.1.x * solaris: Sun 4,(sparc) sparctations, sun os 5 (solaris 2.5,2.6) use gcc * solaris-i386: Intel x86 processors running sun os 5 (solaris 2.5) * sparc-linux: sparc processor running linux * symmetry: sequent symmetry (386 chips) DYNIX-3.0.12+ * u370: IBM 370 (3090's) under AIX * vax: Vax under 4.3 bsd., also ultrix gcl-2.6.14/bin/0000755000175000017500000000000014360276512011543 5ustar cammcammgcl-2.6.14/bin/tkinfo0000755000175000017500000000045114360276512012763 0ustar cammcamm#!/home/wfs/bin/gcl -f (in-package "SI") (setq *load-verbose* nil) (tkconnect) (tk::wm :iconify ".") (offer-choices (sloop::sloop for v in (cdr si::*command-args*) appending (info-aux v *default-info-files*)) *default-info-files*) (tk::bind '.info "" '(bye)) (read) gcl-2.6.14/bin/info0000755000175000017500000000031314360276512012421 0ustar cammcamm#!/bin/sh gcl -batch -eval '(si::error-set (quote (progn (tk::tkconnect :args "-geometry 20x20-2+2")(tk::wm :iconify ".")(si::info '\"$1\"')(tk::bind (quote .info) "" (quote (bye)))(read))))' gcl-2.6.14/bin/file-sub.c0000644000175000017500000000261014360276512013414 0ustar cammcamm/* # Substitute the region between BEGIN and END in FILE1 into FILE2 */ #include #include #include void scanCopyToLine(FILE *fp, char *line,FILE *outstream); int main(int argc,char *argv[]) { if (argc < 5) { ERROR: fprintf(stderr,"Usage: file-sub subFile FileToSubInto BEGIN END [outfile -]"); exit(1); } { FILE *file1; FILE *file2; FILE *outstream = stdout; char *begin=argv[3]; char *end=argv[4]; file2= fopen(argv[2],"rb"); file1= fopen(argv[1],"rb"); if (argc>=6 && strcmp(argv[5],"-")!=0) { outstream= fopen(argv[5],"wb"); } if (file1==0 || file2==0) goto ERROR; { scanCopyToLine(file2,begin,outstream); scanCopyToLine(file1,begin,0); scanCopyToLine(file1,end,outstream); scanCopyToLine(file2,end,0); scanCopyToLine(file2,0,outstream); } if (outstream != stdout) fclose(outstream); } return 0; } /* copy from fp to outstream all lines up to and including one beginning with LINE */ void scanCopyToLine(FILE *fp, char *line,FILE *outstream) { int length=0; int finish=0; char buf[5000]; if (line) length = strlen(line); while (!finish && !feof(fp)) { char *s = fgets(buf,sizeof(buf),fp); if (line && s && strncmp(line,s,length)==0) { finish=1; } if (s && outstream) fputs(s,outstream); } } gcl-2.6.14/bin/dpp.c0000755000175000017500000003131214360276512012475 0ustar cammcamm/* dpp.c defun preprocessor */ /* Usage: dpp file The file named file.d is preprocessed and the output will be written to the file whose name is file.c. ;changes: remove \n from beginning of main output so debuggers can find the right foo.d source file name.--wfs ;add \" to the line output for ansi C --wfs The function definition: @(defun name ({var}* [&optional {var | (var [initform [svar]])}*] [&rest] [&key {var | ({var | (keyword var)} [initform [svar]])}* [&allow_other_keys]] [&aux {var | (var [initform])}*]) C-declaration @ C-body @) &optional may be abbreviated as &o. &rest may be abbreviated as &r. &key may be abbreviated as &k. &allow_other_keys may be abbreviated as &aok. &aux may be abbreviated as &a. Each variable becomes a macro name defined to be an expression of the form vs_base[...]. Each supplied-p parameter becomes a boolean C variable. Initforms are C expressions. It an expression contain non-alphanumeric characters, it should be surrounded by backquotes (`). Function return: @(return {form}*) It becomes a C block. */ #include #include #include #include "gclincl.h" #include "config.h" #ifdef UNIX #include #define isalphanum(c) isalnum(c) #endif #define POOLSIZE 2048 #define MAXREQ 16 #define MAXOPT 16 #define MAXKEY 16 #define MAXAUX 16 #define MAXRES 16 #define TRUE 1 #define FALSE 0 typedef int bool; FILE *in, *out; char filename[BUFSIZ]; int line; int tab; int tab_save; char pool[POOLSIZE]; char *poolp; char *function; int fstatic; char *required[MAXREQ]; int nreq; struct optional { char *o_var; char *o_init; char *o_svar; } optional[MAXOPT]; int nopt; bool rest_flag; bool key_flag; struct keyword { char *k_key; char *k_var; char *k_init; char *k_svar; } keyword[MAXKEY]; int nkey; bool allow_other_keys_flag; struct aux { char *a_var; char *a_init; } aux[MAXAUX]; int naux; char *result[MAXRES]; int nres; void error(s) char *s; { printf("Error in line %d: %s.\n", line, s); exit(0); } int readc() { int c; c = getc(in); if (feof(in)) { if (function != NULL) error("unexpected end of file"); exit(0); } if (c == '\n') { line++; tab = 0; } else if (c == '\t') tab++; return(c); } int nextc() { int c; while (isspace(c = readc())) ; return(c); } void unreadc(c) int c; { if (c == '\n') --line; else if (c == '\t') --tab; ungetc(c, in); } void put_tabs(n) int n; { int i; for (i = 0; i < n; i++) putc('\t', out); } void pushc(c) int c; { if (poolp >= &pool[POOLSIZE]) error("buffer bool overflow"); *poolp++ = c; } char * read_token() { int c; char *p; p = poolp; if ((c = nextc()) == '`') { while ((c = readc()) != '`') pushc(c); pushc('\0'); return(p); } do pushc(c); while (isalphanum(c = readc()) || c == '_'); pushc('\0'); unreadc(c); return(p); } void reset() { int i; poolp = pool; function = NULL; nreq = 0; for (i = 0; i < MAXREQ; i++) required[i] = NULL; nopt = 0; for (i = 0; i < MAXOPT; i++) optional[i].o_var = optional[i].o_init = optional[i].o_svar = NULL; rest_flag = FALSE; key_flag = FALSE; nkey = 0; for (i = 0; i < MAXKEY; i++) keyword[i].k_key = keyword[i].k_var = keyword[i].k_init = keyword[i].k_svar = NULL; allow_other_keys_flag = FALSE; naux = 0; for (i = 0; i < MAXAUX; i++) aux[i].a_var = aux[i].a_init = NULL; } void get_function() { function = read_token(); } void get_lambda_list() { int c; char *p; if ((c = nextc()) != '(') error("( expected"); for (;;) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); goto OPTIONAL; } unreadc(c); p = read_token(); if (nreq >= MAXREQ) error("too many required variables"); required[nreq++] = p; } OPTIONAL: if (strcmp(p, "optional") != 0 && strcmp(p, "o") != 0) goto REST; for (;; nopt++) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); goto REST; } if (nopt >= MAXOPT) error("too many optional argument"); if (c == '(') { optional[nopt].o_var = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); optional[nopt].o_init = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); optional[nopt].o_svar = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); optional[nopt].o_var = read_token(); } } REST: if (strcmp(p, "rest") != 0 && strcmp(p, "r") != 0) goto KEYWORD; rest_flag = TRUE; if ((c = nextc()) == ')') return; if (c != '&') error("& expected"); p = read_token(); goto KEYWORD; KEYWORD: if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) goto AUX_L; key_flag = TRUE; for (;; nkey++) { if ((c = nextc()) == ')') return; if (c == '&') { p = read_token(); if (strcmp(p, "allow_other_keys") == 0 || strcmp(p, "aok") == 0) { allow_other_keys_flag = TRUE; if ((c = nextc()) == ')') return; if (c != '&') error("& expected"); p = read_token(); } goto AUX_L; } if (nkey >= MAXKEY) error("too many optional argument"); if (c == '(') { if ((c = nextc()) == '(') { p = read_token(); if (p[0] != ':' || p[1] == '\0') error("keyword expected"); keyword[nkey].k_key = p + 1; keyword[nkey].k_var = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); keyword[nkey].k_key = keyword[nkey].k_var = read_token(); } if ((c = nextc()) == ')') continue; unreadc(c); keyword[nkey].k_init = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); keyword[nkey].k_svar = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); keyword[nkey].k_key = keyword[nkey].k_var = read_token(); } } AUX_L: if (strcmp(p, "aux") != 0 && strcmp(p, "a") != 0) error("illegal lambda-list keyword"); for (;;) { if ((c = nextc()) == ')') return; if (c == '&') error("illegal lambda-list keyword"); if (naux >= MAXAUX) error("too many auxiliary variable"); if (c == '(') { aux[naux].a_var = read_token(); if ((c = nextc()) == ')') continue; unreadc(c); aux[naux].a_init = read_token(); if (nextc() != ')') error(") expected"); } else { unreadc(c); aux[naux].a_var = read_token(); } naux++; } } void get_return() { int c; nres = 0; for (;;) { if ((c = nextc()) == ')') return; unreadc(c); result[nres++] = read_token(); } } void put_fhead() { #ifdef STATIC_FUNCTION_POINTERS fprintf(out, "static void L%s_static ();\n",function); if (!fstatic) fprintf(out,"void\nL%s()\n{ L%s_static();}\n\n",function,function); fprintf(out,"static void\nL%s_static()\n{",function); #else fprintf(out, "%svoid\nL%s()\n{", fstatic ? "static " : "",function); #endif } void put_declaration() { int i; if (nopt || rest_flag || key_flag) fprintf(out, "\tint narg;\n"); fprintf(out, "\tregister object *DPPbase=vs_base;\n"); for (i = 0; i < nopt; i++) if (optional[i].o_svar != NULL) fprintf(out, "\tbool %s;\n", optional[i].o_svar); for (i = 0; i < nreq; i++) fprintf(out, "#define\t%s\tDPPbase[%d]\n", required[i], i); for (i = 0; i < nopt; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d]\n", optional[i].o_var, nreq, i); for (i = 0; i < nkey; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d+%d]\n", keyword[i].k_var, nreq, nopt, i); for (i = 0; i < nkey; i++) if (keyword[i].k_svar != NULL) fprintf(out, "\tbool %s;\n", keyword[i].k_svar); for (i = 0; i < naux; i++) fprintf(out, "#define\t%s\tDPPbase[%d+%d+2*%d+%d]\n", aux[i].a_var, nreq, nopt, nkey, i); fprintf(out, "\n"); if (nopt == 0 && !rest_flag && !key_flag) fprintf(out, "\tcheck_arg(%d);\n", nreq); else { fprintf(out, "\tnarg = vs_top - vs_base;\n"); fprintf(out, "\tif (narg < %d)\n", nreq); fprintf(out, "\t\ttoo_few_arguments();\n"); } for (i = 0; i < nopt; i++) if (optional[i].o_svar != NULL) { fprintf(out, "\tif (narg > %d + %d)\n", nreq, i); fprintf(out, "\t\t%s = TRUE;\n", optional[i].o_svar); fprintf(out, "\telse {\n"); fprintf(out, "\t\t%s = FALSE;\n", optional[i].o_svar); fprintf(out, "\t\tvs_push(%s);\n", optional[i].o_init); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } else if (optional[i].o_init != NULL) { fprintf(out, "\tif (narg <= %d + %d) {\n", nreq, i); fprintf(out, "\t\tvs_push(%s);\n", optional[i].o_init); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } else { fprintf(out, "\tif (narg <= %d + %d) {\n", nreq, i); fprintf(out, "\t\tvs_push(Cnil);\n"); fprintf(out, "\t\tnarg++;\n"); fprintf(out, "\t}\n"); } if (nopt > 0 && !key_flag && !rest_flag) { fprintf(out, "\tif (narg > %d + %d)\n", nreq, nopt); fprintf(out, "\t\ttoo_many_arguments();\n"); } if (key_flag) { fprintf(out, "\tparse_key(vs_base+%d+%d,FALSE, %s, %d,\n", nreq, nopt, allow_other_keys_flag ? "TRUE" : "FALSE", nkey); if (nkey > 0) { i = 0; for (;;) { fprintf(out, "\t\tsK%s", keyword[i].k_key); if (++i == nkey) { fprintf(out, ");\n"); break; } else fprintf(out, ",\n"); } } else fprintf(out, "\t\tCnil);"); fprintf(out, "\tvs_top = vs_base + %d+%d+2*%d;\n", nreq, nopt, nkey); for (i = 0; i < nkey; i++) { if (keyword[i].k_init == NULL) continue; fprintf(out, "\tif (vs_base[%d+%d+%d+%d]==Cnil)\n", nreq, nopt, nkey, i); fprintf(out, "\t\t%s = %s;\n", keyword[i].k_var, keyword[i].k_init); } for (i = 0; i < nkey; i++) if (keyword[i].k_svar != NULL) fprintf(out, "\t%s = vs_base[%d+%d+%d+%d] != Cnil;\n", keyword[i].k_svar, nreq, nopt, nkey, i); } for (i = 0; i < naux; i++) if (aux[i].a_init != NULL) fprintf(out, "\tvs_push(%s);\n", aux[i].a_init); else fprintf(out, "\tvs_push(Cnil);\n"); } void put_ftail() { int i; for (i = 0; i < nreq; i++) fprintf(out, "#undef %s\n", required[i]); for (i = 0; i < nopt; i++) fprintf(out, "#undef %s\n", optional[i].o_var); for (i = 0; i < nkey; i++) fprintf(out, "#undef %s\n", keyword[i].k_var); for (i = 0; i < naux; i++) fprintf(out, "#undef %s\n", aux[i].a_var); fprintf(out, "}"); } void put_return() { int i, t; t = tab_save + 1; if (nres == 0) { fprintf(out, "{\n"); put_tabs(t); fprintf(out, "vs_top = vs_base;\n"); put_tabs(t); fprintf(out, "vs_base[0] = Cnil;\n"); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } else if (nres == 1) { fprintf(out, "{\n"); put_tabs(t); fprintf(out, "vs_base[0] = %s;\n", result[0]); put_tabs(t); fprintf(out, "vs_top = vs_base + 1;\n"); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } else { fprintf(out, "{\n"); for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "object R%d;\n", i); } for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "R%d = %s;\n", i, result[i]); } for (i = 0; i < nres; i++) { put_tabs(t); fprintf(out, "vs_base[%d] = R%d;\n", i, i); } put_tabs(t); fprintf(out, "vs_top = vs_base + %d;\n", nres); put_tabs(t); fprintf(out, "return;\n"); put_tabs(tab_save); fprintf(out, "}"); } } void main_loop() { int c; char *p; line = 1; fprintf(out, "# line %d \"%s\"\n", line, filename); LOOP: reset(); fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); if (readc() != '(') error("@( expected"); p = read_token(); fstatic=0; if (strcmp(p, "static") == 0) { fstatic=1; p = read_token(); } if (strcmp(p, "defun") == 0) { get_function(); get_lambda_list(); put_fhead(); fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); put_declaration(); BODY: fprintf(out, "\n# line %d \"%s\"\n", line, filename); while ((c = readc()) != '@') putc(c, out); if ((c = readc()) == ')') { put_ftail(); goto LOOP; } else if (c != '(') error("@( expected"); p = read_token(); if (strcmp(p, "return") == 0) { tab_save = tab; get_return(); put_return(); goto BODY; } else error("illegal symbol"); } else error("illegal symbol"); } int main(argc, argv) int argc; char **argv; { char *p, *q; if (argc != 2) error("arg count"); for (p = argv[1], q = filename; *p != '\0'; p++, q++) if (q >= &filename[BUFSIZ-3]) error("too long file name"); else *q = *p; q[0] = '.'; q[1] = 'd'; q[2] = '\0'; in = fopen(filename, "r"); if (in == NULL) error("can't open input file"); q[1] = 'c'; out = fopen(filename, "w"); if (out == NULL) error("can't open output file"); q[1] = 'd'; printf("dpp: %s -> ", filename); q[1] = 'c'; printf("%s\n", filename); q[1] = 'd'; main_loop(); return 0; } gcl-2.6.14/bin/makefile0000644000175000017500000000061414360276512013244 0ustar cammcammDEFS = -I../h CC = cc APPEND = ../bin/append -include ../makedefs all: dpp${EXE} ${APPEND}${EXE} file-sub${EXE} dpp${EXE}: dpp.c ${CC} ${DEFS} -o dpp${EXE} dpp.c file-sub${EXE}: file-sub.c ${CC} ${DEFS} -o file-sub${EXE} file-sub.c ${APPEND}${EXE}: append.c ${CC} ${DEFS} -o append${EXE} append.c clean: rm -f dpp${EXE} append${EXE} file-sub${EXE} core a.out *.o gcl gclm.bat gcl-2.6.14/bin/info10000755000175000017500000000040414360276512012503 0ustar cammcamm#!/usr/local/bin/gcl.exe -f (si::error-set '(progn (tk::tkconnect :args "-geometry 20x20-2+2") (tk::wm :iconify ".") (si::info (nth 1 SYSTEM::*COMMAND-ARGS*)) (tk::bind (quote .info) "" (quote (bye))) (read))) gcl-2.6.14/bin/.gitignore0000644000175000017500000000003014360276512013524 0ustar cammcammappend dpp file-sub gcl gcl-2.6.14/bin/append.c0000755000175000017500000000124114360276512013157 0ustar cammcamm#include /* usage: append a b c equivalent to cat a b >> c if only cat were binary... but by some wonderful dos like deicision, it is not under cygnus.. */ int main(int argc,char *argv[]) { int i; FILE *out ; if (argc < 2) return 0; out = fopen(argv[argc-1],"a+b"); if (out == 0) { perror("cant open"); return 1; } for (i=1; i < argc-1 ; i++) { FILE *fp = fopen(argv[i],"rb"); int ch; if (fp == 0) { perror("cant open"); return 1; } while (1) { ch =getc(fp); if (ch == EOF && feof(fp)) { fclose(fp); break; } else putc(ch,out); } } fclose(out); return 0; } gcl-2.6.14/dos/0000755000175000017500000000000014360276512011560 5ustar cammcammgcl-2.6.14/dos/read.s0000755000175000017500000000202014360276512012654 0ustar cammcamm/* This is file READ.S */ /* ** Copyright (C) 1991 DJ Delorie, 24 Kirsten Ave, Rochester NH 03867-2954 ** ** This file is distributed under the terms listed in the document ** "copying.dj", available from DJ Delorie at the address above. ** A copy of "copying.dj" should accompany this file; if not, a copy ** should be available from where this file was obtained. This file ** may not be distributed without a verbatim copy of "copying.dj". ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ .text .globl _read _read: pushl %eax movl $0,%eax cmp 8(%esp),%eax /* Is it stdin */ jne NotStdin cmp _interrupt_flag,%eax /* Any SIGINT Interrupt pending ? */ je NoInterrupt call _sigalrm NoInterrupt: NotStdin: popl %eax pushl %ebx pushl %esi pushl %edi movl 16(%esp),%ebx movl 20(%esp),%edx movl 24(%esp),%ecx movb $0x3f,%ah int $0x21 popl %edi popl %esi popl %ebx jb syscall_error ret gcl-2.6.14/dos/dostimes.c0000755000175000017500000000044514360276512013561 0ustar cammcamm#include #include #ifdef __ZTC__ #define HZ 100 #endif times(x) struct tms *x; { int hz; struct rusage ru; getrusage(RUSAGE_SELF,&ru); hz = ru.ru_utime.tv_sec * HZ + (ru.ru_utime.tv_usec *HZ)/1000000; x->tms_utime = hz; x->tms_stime = hz; return 0; } gcl-2.6.14/dos/sigman.s0000755000175000017500000000241714360276512013231 0ustar cammcamm .globl _SignalManager _SignalManager: pushl %ebp movl %esp,%ebp /*------------------------------------------------------------------- ** Save all registers **-----------------------------------------------------------------*/ pushl %eax pushl %ebx pushl %ecx pushl %edx pushl %esi pushl %edi pushf pushl %es pushl %ds /* pushl %ss*/ pushl %fs pushl %gs /*-----------------------------------------------------------------*/ movl 4(%ebp), %eax shl $2, %eax movl _SignalTable(%eax), %ebx call %ebx /*------------------------------------------------------------------- ** Restore registers **-----------------------------------------------------------------*/ popl %gs popl %fs /* popl %ss*/ popl %ds popl %es popf popl %edi popl %esi popl %edx popl %ecx popl %ebx popl %eax /*------------------------------------------------------------------*/ popl %ebp add $4, %esp ret /* resume program */ gcl-2.6.14/dos/makefile0000644000175000017500000000040714360276512013261 0ustar cammcamm.SUFFIXES: .o .c HDIR = ../h OFLAG = -O ODIR = . -include ../makedefs DOS_ODIR=. CFLAGS = -I. -I$(HDIR) $(ODIR_DEBUG) .s.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c .c.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c OBJS = $(EXX_DOS) all: $(OBJS) clean: rm -f $(OBJS) gcl-2.6.14/dos/signal.h0000755000175000017500000001137614360276512013221 0ustar cammcamm/* This is file signal.h */ /* This file may have been modified by DJ Delorie (Jan 1991). If so, ** these modifications are Coyright (C) 1991 DJ Delorie, 24 Kirsten Ave, ** Rochester NH, 03867-2954, USA. */ /* This may look like C code, but it is really -*- C++ -*- */ /* Copyright (C) 1989 Free Software Foundation written by Doug Lea (dl@rocky.oswego.edu) This file is part of GNU CC. GNU CC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the GNU CC General Public License for full details. Everyone is granted permission to copy, modify and redistribute GNU CC, but only under the conditions described in the GNU CC General Public License. A copy of this license is supposed to have been given to you along with GNU CC so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. */ #ifndef _signal_h #pragma once #ifdef __cplusplus extern "C" { #endif /* This #define KERNEL hack gets around bad function prototypes on most */ /* systems. If not, you need to do some real work... */ /******************* * #define KERNEL * #include * #undef KERNEL ********************/ #ifndef _signal_h #define _signal_h 1 #endif /* The Interviews folks call this SignalHandler. Might as well conform. */ /* Beware: some systems think that SignalHandler returns int. */ typedef void (*SignalHandler) (); extern SignalHandler signal(int sig, SignalHandler action); extern SignalHandler sigset(int sig, SignalHandler action); extern SignalHandler ssignal(int sig, SignalHandler action); extern int gsignal (int sig); extern int kill (int pid, int sig); #ifndef hpux /* Interviews folks claim that hpux doesn't like these */ struct sigvec; extern int sigsetmask(int mask); extern int sigblock(int mask); extern int sigpause(int mask); extern int sigvec(int sig, struct sigvec* v, struct sigvec* prev); #endif /* The Interviews version also has these ... */ #define SignalBad ((SignalHandler)-1) #define SignalDefault ((SignalHandler)0) #define SignalIgnore ((SignalHandler)1) #ifdef __cplusplus } #endif #define _SIGNAL_H /** #include **/ #ifdef _SIGNAL_H /* This file defines the fake signal functions and signal number constants for 4.2 or 4.3 BSD-derived Unix system. */ #define SIG_DFL 0 #if 0 /*#ifndef SIG_DFL*/ /* Fake signal functions. These lines MUST be split! m4 will not change them otherwise. */ #define SIG_ERR /* Error return. */ \ ((void EXFUN((*), (int sig))) -1) #define SIG_DFL /* Default action. */ \ ((void EXFUN((*), (int sig))) 0) #define SIG_IGN /* Ignore signal. */ \ ((void EXFUN((*), (int sig))) 1) #endif /* Signals. */ #define SIGHUP 1 /* Hangup (POSIX). */ #define SIGINT 2 /* Interrupt (ANSI). */ #define SIGQUIT 3 /* Quit (POSIX). */ #define SIGILL 4 /* Illegal instruction (ANSI). */ #define SIGABRT SIGIOT /* Abort (ANSI). */ #define SIGTRAP 5 /* Trace trap (POSIX). */ #define SIGIOT 6 /* IOT trap (4.2 BSD). */ #define SIGEMT 7 /* EMT trap (4.2 BSD). */ #define SIGFPE 8 /* Floating-point exception (ANSI). */ #define SIGKILL 9 /* Kill, unblockable (POSIX). */ #define SIGBUS 10 /* Bus error (4.2 BSD). */ #define SIGSEGV 11 /* Segmentation violation (ANSI). */ #define SIGSYS 12 /* Bad argument to system call (4.2 BSD)*/ #define SIGPIPE 13 /* Broken pipe (POSIX). */ #define SIGALRM 14 /* Alarm clock (POSIX). */ #define SIGTERM 15 /* Termination (ANSI). */ #define SIGURG 16 /* Urgent condition on socket (4.2 BSD).*/ #define SIGSTOP 17 /* Stop, unblockable (POSIX). */ #define SIGTSTP 18 /* Keyboard stop (POSIX). */ #define SIGCONT 19 /* Continue (POSIX). */ #define SIGCHLD 20 /* Child status has changed (POSIX). */ #define SIGCLD SIGCHLD /* Same as SIGCHLD (System V). */ #define SIGTTIN 21 /* Background read from tty (POSIX). */ #define SIGTTOU 22 /* Background write to tty (POSIX). */ #define SIGIO 23 /* I/O now possible (4.2 BSD). */ #define SIGPOLL SIGIO /* Same as SIGIO? (SVID). */ #define SIGXCPU 24 /* CPU limit exceeded (4.2 BSD). */ #define SIGXFSZ 25 /* File size limit exceeded (4.2 BSD). */ #define SIGVTALRM 26 /* Virtual alarm clock (4.2 BSD). */ #define SIGPROF 27 /* Profiling alarm clock (4.2 BSD). */ #define SIGWINCH 28 /* Window size change (4.3 BSD, Sun). */ #define SIGUSR1 30 /* User-defined signal 1 (POSIX). */ #define SIGUSR2 31 /* User-defined signal 2 (POSIX). */ #endif /* included. */ #define _NSIG 32 /* Biggest signal number + 1. */ #endif gcl-2.6.14/dos/dum_dos.c0000755000175000017500000000026514360276512013364 0ustar cammcamm#define DUM(a) int a(int n) { printf("dummy " #a " call %d\n",n); return 0;} DUM(profil) /* DUM(alarm) */ DUM(getpid) DUM(getuid) DUM(popen) DUM(pclose) DUM(getpwuid) DUM(getpwnam) gcl-2.6.14/dos/signal.c0000755000175000017500000000607014360276512013207 0ustar cammcamm/* This is file signal.c ** ** Copyright (C) 1992 Rami EL CHARIF and William SCHELTER ** rcharif@ma.utexas.edu wfs@cs.utexas.edu ** ** Signal package for djgpp versions 1.05, 1.06 ** version 0.0 alpha 03/30/1992 ** ** Send your comments or bugs report to ** rcharif@ma.utexas.edu or wfs@cs.utexas.edu ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ #include #include #include unsigned long SignalTable[_NSIG + 1] = { (unsigned long)SIG_DFL, /* SIGHUP */ (unsigned long)SIG_DFL, /* SIGINT +*/ (unsigned long)SIG_DFL, /* SIGQUIT */ (unsigned long)SIG_DFL, /* SIGILL */ (unsigned long)SIG_DFL, /* SIGABRT */ (unsigned long)SIG_DFL, /* SIGTRAP */ (unsigned long)SIG_DFL, /* SIGIOT */ (unsigned long)SIG_DFL, /* SIGEMT */ (unsigned long)SIG_DFL, /* SIGFPE */ (unsigned long)SIG_DFL, /* SIGKILL */ (unsigned long)SIG_DFL, /* SIGBUS */ (unsigned long)SIG_DFL, /* SIGSEGV +*/ (unsigned long)SIG_DFL, /* SIGSYS */ (unsigned long)SIG_DFL, /* SIGPIPE */ (unsigned long)SIG_DFL, /* SIGALRM */ (unsigned long)SIG_DFL, /* SIGTERM */ (unsigned long)SIG_DFL, /* SIGURG */ (unsigned long)SIG_DFL, /* SIGSTOP */ (unsigned long)SIG_DFL, /* SIGTSTP */ (unsigned long)SIG_DFL, /* SIGCONT */ (unsigned long)SIG_DFL, /* SIGCHLD */ (unsigned long)SIG_DFL, /* SIGCLD */ (unsigned long)SIG_DFL, /* SIGTTIN */ (unsigned long)SIG_DFL, /* SIGTTOU */ (unsigned long)SIG_DFL, /* SIGIO */ (unsigned long)SIG_DFL, /* SIGPOLL */ (unsigned long)SIG_DFL, /* SIGXCPU */ (unsigned long)SIG_DFL, /* SIGXFSZ */ (unsigned long)SIG_DFL, /* SIGVTALRM */ (unsigned long)SIG_DFL, /* SIGPROF */ (unsigned long)SIG_DFL, /* SIGWINCH */ (unsigned long)SIG_DFL, /* SIGUSR1 */ (unsigned long)SIG_DFL /* SIGUSR2 */ }; SignalHandler signal(int sig, SignalHandler action) { extern void SignalManager(); union REGS in, out; SignalHandler hsigOld; in.h.ah = 1; in.h.al = sig; SignalTable[sig] = in.x.dx = (long)action; in.x.cx = (long)SignalManager; int86(0xfa, &in, &out); hsigOld = (SignalHandler)out.x.dx; return hsigOld; } void SigInst() { union REGS in, out; extern void SignalManager(); in.h.ah = 0; in.h.al = 0; in.x.dx = (long)SignalManager; #ifdef DEBUG_SIG printf("\nSignal Manager = %ld, %lx", in.x.dx, in.x.dx); #endif int86(0xfa, &in, &out); } #ifndef NO_SIG_ALARM unsigned int alarm(int culSeconds) { union REGS in, out; if (!culSeconds) { in.h.ah = 3; /* Reset alarm */ int86(0xfa, &in, &out); } else { in.h.ah = 2; in.x.dx = culSeconds; int86(0xfa, &in, &out); } return in.x.cx; } #else unsigned int alarm(int n) { return 0; } #endif gcl-2.6.14/dos/readme0000755000175000017500000000033614360276512012745 0ustar cammcamm This is the remnants of the port of akcl to dos under djgpp (version 1.06) Unfortunately djgpp has changed and so it is not so straightforward to make gcl work .. I would be happy if someone else does it! Bill Schelter gcl-2.6.14/readme.mingw0000755000175000017500000000660014360276512013300 0ustar cammcamm=============================================== BUILDING NATIVE WIN32 GNU COMMON LISP FROM CVS =============================================== The preferred build host system for the Mingw32 compiler is MSYS. I use gcc version 3.3.1 and binutils 2.14.90, but earlier versions of gcc back to 2.95 are OK provided that you remove the "-fno-zero-initialized-in-bss" flag in "h/mingw.defs" before running "configure". Note that gcc 3.3.3 and gcc 3.4.0 do NOT work; likewise binutils 2.13.90 and 2.15.90. The working binutils version can be found at: ftp://ftp.sf.net/m/mi/mingw/binutils-2.14.90-20030807-1.tar.gz =============================================== BUILDING GCL USING MSYS AS THE HOST =============================================== BUILD TOOLS - Mingw32 Version 2 Windows native gcc: http://www.mingw.org/ - MSYS Mingw build environment, including the MSYS DTK http://www.mingw.org/ - Source code for GCL. http://savannah.gnu.org/projects/gcl/ Subject to the above warnings, it is usually a good idea to keep up to date with Mingw32 and MSYS. Updates for various parts of these packages are available on the web site. SHORT SETUP NOTES - Install Mingw32 and MSYS using the instructions at those sites. DETAILED SETUP NOTES - Start by installing the latest version of MinGW2.exe. - By looking at the dates and version numbers appended to the other packages on the download page, get any versions of gcc 3.2, binutils, mingw-runtime, and w32api that are later than the Mingw2 package. - Go to the top level Mingw32 installation directory - the one in which you can see "bin", "lib" etc - Extract those other packages in that directory eg: tar xzf rumpty-dumpty.tar.gz - Remove the Mingw version of "make" from the bin directory - it has serious bugs and will not work properly for most tasks including building GCL and Maxima. We will be using the MSYS version. - Get MSYS and install it - follow the instructions - subscribe to the mailing list and read the archives. - In the MSYS directory install the "msysDTK-1.0.0-alpha-1.tar.gz" package which gives you cvs, ssh, rlogin, etc. BUILDING - Change to your GCL source directory eg: cd /c/cvs/gcl - You are now ready to configure GCL: ./configure --prefix="c:/gcl" > configure.log 2>&1 Change the prefix directory as required for your final installation path. I find it helpful to redirect output from "configure" and "make" into log files for debugging and checking. - Check the log. - Type: make >& make.log - The "saved_gcl.exe" should turn up eventually in the unixport directory. You can try it out directly by typing: ./unixport/saved_gcl.exe at the command prompt. - To install: make install >& install.log It is necessary to install GCL before building Maxima. - The batch file "gclm.bat" can be used to make a Windows desktop shortcut. - BFD fasloading, Stratified Garbage Collection (SGC) readline and GCL-TK don't work under Windows. The configuration options above provide a "traditional" GCL executable which will build the current CVS version of Maxima. The BFD option will depend on someone with knowledge of BFD and PE-COFF linking fixing some problems with the BFD library - I am slowly absorbing the info needed, but we really need input from an expert. My inclination is to stick with custom relocation as BFD is less efficient. Mike Thomas 15 June 2004 gcl-2.6.14/gcl-tk/0000755000175000017500000000000014360276512012154 5ustar cammcammgcl-2.6.14/gcl-tk/ngcltksrv0000755000175000017500000000036514360276512014123 0ustar cammcamm#!/bin/sh #comment \ export DISPLAY=$4 ; host=$1;port=$2 ;pid=$3 ; exec wish "$0" "$@" set host [lindex $argv 0] set port [lindex $argv 1] set pid [lindex $argv 2] source /home/wfs/gcl-2.3/gcl-tk/decode.tcl GclAnswerSocket $host $port $pid gcl-2.6.14/gcl-tk/makefile.prev0000644000175000017500000000602114360276512014626 0ustar cammcamm .SUFFIXES: .SUFFIXES: .o .lsp .lisp .c CC=cc LD_ORDINARY_CC=${CC} # Need libX11.a and libtcl.a, machine.defs may say where.. CC = gcc HDIR = ../h ODIR = ../o GCLIB = ../o/gcllib.a # begin makedefs # use=386-linux LIBS= -lm GCLDIR=/d2/wfs/gcl-2.3 SHELL=/bin/sh MACHINE=386-linux TK_CONFIG_PREFIX="/usr/lib" TCL_CONFIG_PREFIX="/usr/lib" #could not find dir so using: INFO_DIR="unknown" TK_INCLUDE="-I/usr/include" TK_VERSION=4.1 TCL_VERSION=7.5 TK_LIB_SPEC=-L/usr/lib -ltk TK_LIBRARY=/usr/lib/tk4.1 TCL_LIBRARY=/usr/lib/tcl7.5 TK_BUILD_LIB_SPEC=-L/usr/src/tk4.1/unix -ltk TK_XLIBSW=-L/usr/X11R6/lib -lX11 TK_XLIB_DIR=/usr/X11R6/lib TK_XINCLUDES=# no special path needed TCL_LIB_SPEC=-L/usr/lib -ltcl TCL_DL_LIBS=-ldl TCL_LIBS=-ldl -lieee -lm HAVE_X11=-DHAVE_X11 # Machine dependent makefile definitions for intel 386,486 running linux LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm ODIR_DEBUG= -O4 # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # (the -pipe is just since our file system is slow..) CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char LDCC=${CC} # note for linuxaout on an elf machine add -b i486-linuxaout # CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd # end makedefs CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TK_XINCLUDES} all: gcltkaux tkl.o tinfo.o gcltksrv demos/gc-monitor.o .lisp.o: echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/saved_gcl .lsp.o: echo "(compile-file \"$*.lsp\" :c-file t :c-debug t)" | ../unixport/saved_gcl GUIOS = guis.o tkAppInit.o tkMain.o clean:: rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o .c.o: $(CC) -c $(CFLAGS1) ${ODIR_DEBUG} $*.c gcltkaux: $(GUIOS) $(LD_ORDINARY_CC) $(GUIOS) -o gcltkaux ${TK_LIB_SPEC} ${TK_BUILD_LIB_SPEC} ${TK_XLIBSW} ${TK_XINCLUDES} ${TCL_LIB_SPEC} ${TCL_DL_LIBS} ${TCL_LIBS} ${LIBS} ${GCLIB} gcltksrv: makefile cat gcltksrv.in | sed -e "s:TK_LIBRARY=.*:TK_LIBRARY=${TK_LIBRARY}:g" \ -e "s:TK_XLIB_DIR=.*:TK_XLIB_DIR=${TK_XLIB_DIR}:g" \ -e "s:GCL_TK_DIR=.*:GCL_TK_DIR=${GCLDIR}/gcl-tk:g" > gcltksrv chmod a+x gcltksrv INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h tar: tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz tags: etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c tkAppInit.o : tkAppInit.c tkMain.o : tkMain.c tkXAppInit.o : tkXAppInit.c tkXshell.o : tkXshell.c guis.o : guis.c guis.h comm.c sheader.h sockets.c: our_io.c sheader.h socketsl.o: socketsl.lisp sockets.c gcl-2.6.14/gcl-tk/index.lsp0000755000175000017500000000346214360276512014013 0ustar cammcamm (in-package "TK") (AUTOLOAD 'FILE-TO-STRING '|info|) (AUTOLOAD 'ATOI '|info|) (AUTOLOAD 'INFO-GET-TAGS '|info|) (AUTOLOAD 'RE-QUOTE-STRING '|info|) (AUTOLOAD 'GET-MATCH '|info|) (AUTOLOAD 'GET-NODES '|info|) (AUTOLOAD 'GET-INDEX-NODE '|info|) (AUTOLOAD 'NODES-FROM-INDEX '|info|) (AUTOLOAD 'GET-NODE-INDEX '|info|) (AUTOLOAD 'ALL-MATCHES '|info|) (AUTOLOAD 'NODE-OFFSET '|info|) (AUTOLOAD 'SETUP-INFO '|info|) (AUTOLOAD 'GET-INFO-CHOICES '|info|) (AUTOLOAD 'ADD-FILE '|info|) (AUTOLOAD 'INFO-ERROR '|info|) (AUTOLOAD 'INFO-GET-FILE '|info|) (AUTOLOAD 'WAITING '|info|) (AUTOLOAD 'END-WAITING '|info|) (AUTOLOAD 'INFO-SUBFILE '|info|) (AUTOLOAD 'INFO-NODE-FROM-POSITION '|info|) (AUTOLOAD 'SHOW-INFO '|info|) (AUTOLOAD 'INFO-AUX '|info|) (AUTOLOAD 'INFO-SEARCH '|info|) (AUTOLOAD 'IDESCRIBE '|info|) (AUTOLOAD 'INFO '|info|) (AUTOLOAD 'DEFAULT-INFO-HOTLIST '|info|) (AUTOLOAD 'ADD-TO-HOTLIST '|info|) (AUTOLOAD 'LIST-MATCHES '|info|) (AUTOLOAD 'SIMPLE-LISTBOX '|tinfo|) (AUTOLOAD 'INSERT-STANDARD-LISTBOX '|tinfo|) (AUTOLOAD 'LISTBOX-MOVE '|tinfo|) (AUTOLOAD 'NEW-WINDOW '|tinfo|) (AUTOLOAD 'INSERT-INFO-CHOICES '|tinfo|) (AUTOLOAD 'OFFER-CHOICES '|tinfo|) (AUTOLOAD 'GET-INFO-APROPOS '|tinfo|) (AUTOLOAD 'SHOW-INFO-KEY '|tinfo|) (AUTOLOAD 'MKINFO '|tinfo|) (AUTOLOAD 'INFO-TEXT-SEARCH '|tinfo|) (AUTOLOAD 'PRINT-NODE '|tinfo|) (AUTOLOAD 'INFO-SHOW-HISTORY '|tinfo|) (AUTOLOAD 'SHOW-THIS-NODE '|tinfo|) (AUTOLOAD 'SCROLL-SET-FIX-XREF-CLOSURE '|tinfo|) (AUTOLOAD 'FIX-XREF '|tinfo|) (AUTOLOAD 'INSERT-FONTIFIED '|tinfo|) (AUTOLOAD 'SECTION-HEADER '|tinfo|) (AUTOLOAD 'INSERT-STRING '|tinfo|) (AUTOLOAD 'INSERT-STRING-WITH-REGEXP '|tinfo|) (AUTOLOAD 'COUNT-CHAR '|tinfo|) (AUTOLOAD 'START-OF-ITH-LINE '|tinfo|) (AUTOLOAD 'INDEX-TO-POSITION '|tinfo|) (SETQ SYSTEM::*LOAD-PATH* (APPEND '("/usr/local/gcl-2.2/gcl-tk/") SYSTEM::*LOAD-PATH*))gcl-2.6.14/gcl-tk/gcltksrv.prev0000755000175000017500000000064414360276512014720 0ustar cammcamm#!/bin/sh # where to find bitmaps, # and the class bindings in /usr/local/lib/tk/tk.tcl TK_LIBRARY=/var/X11/lib/X11/tk DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk TK_LIBRARY=/public/lib/tk DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk #put correct dir if [ -f ${TK_LIBRARY}/tk.tcl ] ; then true; else TK_LIBRARY=/usr/local/lib/tk export TK_LIBRARY fi if [ $# -ge 4 ] ;then DISPLAY=$4 ; export DISPLAY; fi exec ${DIR}/gcltkaux $1 $2 $3 gcl-2.6.14/gcl-tk/intrs.h0000755000175000017500000000000014360276512013455 0ustar cammcammgcl-2.6.14/gcl-tk/helpers.lisp0000755000175000017500000000127114360276512014513 0ustar cammcamm (in-package "TK") (setq controls '( after exit lower place send tkvars winfo focus option raise tk tkwait wm destroy grab pack selection tkerror update tk_listboxSingleSelect)) (setq widgets '( button listbox scale canvas menu scrollbar checkbutton menubutton text entry message frame label radiobutton toplevel )) (defun get-options (com) (let ((tem (funcall com "jo" :return 'string)) (cond ((equal (subseq tem 0 (length s)) s) (setq tem (subseq tem (length s))) (setq tem (substitute #\space #\, tem)) (setq tem (list-string tem)) (setq tem (delete "or" tem :test 'equal)) (mapcar #'(lambda (x) (intern (string-upcase x) :keyword)) tem) )))) gcl-2.6.14/gcl-tk/gcltksrv.bat0000755000175000017500000000022714360276512014507 0ustar cammcammset GCL_TK_DIR=c:/cvs/gcl/gcl-tk set TCL_LIBRARY=c:/lang/tcl/lib/tcl8.3 set TK_LIBRARY=c:/lang/tcl/lib/tcl8.3 start %GCL_TK_DIR%/gcltkaux %1 %2 %3 gcl-2.6.14/gcl-tk/guis.h0000755000175000017500000000336514360276512013306 0ustar cammcamm#ifndef _GUIS_H_ #define _GUIS_H_ #include #define NO_PRELINK_UNEXEC_DIVERSION #define IMMNUM_H #define GMP_WRAPPERS_H #define ERROR_H #undef INLINE #include "include.h" #ifdef NeXT typedef int pid_t; #endif #ifndef _ANSI_ARGS_ #ifdef __STDC__ #define _ANSI_ARGS_(x) x #else #define _ANSI_ARGS_(x) () #endif #endif #define STRING_HEADER_FORMAT "%4.4d" #define CB_STRING_HEADER (5) /* #define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ sscanf(__buf, STRING_HEADER_FORMAT, __plgth); */ /* sscanf is braindead on SunOS */ #define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ {\ __buf[CB_STRING_HEADER - 1] = 0;\ *__plgth = atoi(__buf);\ __buf[4] = '';\ } /* need to have opportunity to collapse message to reduce trafic */ #define MSG_STRAIGHT_TCL_CMD 0 #define MSG_CREATE_COMMAND 1 /* #define MSG_ */ typedef struct _guiMsg { pid_t pidSender; int vMajor; int vMinor; int idx; int fSignal; int fAck; int IdMsg; char *szData; char *szMsg; } guiMsg; #define MSG_IDX(__p) (__p->idx) #define MSG_COMMAND(__p) (__p->IdMsg) #define MSG_NEED_ACK(__p) (__p->fAck) #define MSG_NEED_SIGNAL_PARENT(__p) (__p->fSignal) #define MSG_TCL_STR(__p) (__p->szData) #define MSG_DATA_STR(__p) (__p->szData) /* #define MSG_(__p) (__p->) */ #include "sheader.h" struct message_header * guiParseMsg1(); extern pid_t parent; struct connection_state * sock_connect_to_name(); void sock_close_connection( ); int sock_read_str(); guiMsg *guiParseMsg(); void guiFreeMsg(); void guiCreateThenBindCallback(); int guiBindCallback(); #endif int sock_write_str2(struct connection_state *,enum mtype, char *, int,const char *,int); object fSclear_connection(fixnum); object fScheck_fd_for_input(fixnum,fixnum); #define SI_makefun(a_,b_,c_) gcl-2.6.14/gcl-tk/socks.h0000755000175000017500000000155214360276512013455 0ustar cammcamm#ifndef _H_SOCKS #define _H_SOCKS #include "obj.h" obj sock_open_named_socket( obj name, bool async ); void sock_close_named_socket( obj named_socket ); obj sock_connect_to_name( obj host_id, obj name, bool async ); obj sock_accept_connection( obj named_socket, bool async ); obj sock_hostname_to_hostid( obj hostname, obj *aliases ); obj sock_hostid_to_hostname( obj hostid, obj *aliases ); bool sock_hostid_eq( obj hostid1, obj hostid2 ); /* items is a list of objects returned from sock_open_named_socket, sock_connect_to_name, or sock_accept_connection with async = YES */ obj sock_collect_data( obj items ); void sock_write( obj connection, const char *text, UINT_32 length ); /* sock_read should return 0 on EOF */ UINT_32 sock_read( obj connection, char *buffer, UINT_32 max_len ); void sock_close_connection( obj connection ); #endif /* _H_SOCKS */ gcl-2.6.14/gcl-tk/gcl-1.tcl0000755000175000017500000000257514360276512013577 0ustar cammcamm set LongestMatchPossible 3000 proc MarkRegexps { w regexp tag tags {start 0.0} {end end}} { upvar #0 LongestMatchPossible longest $w mark set MaRe $start set found 0 while {[$w compare MaRe < $end]} { set began MaRe set text [$w get MaRe "MaRe + [expr 10 * $longest] chars"] set limit [expr 9 * $longest] set begin 0 set last "-1 -1" while {[regexp -indices $regexp $text all j1 j2 j3 j4 j5 j6 j7 j8 \ j9 ]} { incr found set i 1 set endmatch [lindex $all 1] $w tag add $tag "MaRe + [expr $begin + [lindex $all 0]] chars" \ "MaRe + [expr $begin + [lindex $all 1]] chars" foreach ta $tags { set all [set j$i] incr i if { $all != "-1 -1" } { # puts stdout "ta=$ta taa=[set $ta]" # puts stdout "found $endmatch: `[string range $text [lindex $all 0] [lindex $all 1]]'" $w tag add $ta "MaRe + [expr $begin + [lindex $all 0]] chars" \ "MaRe + [expr $begin + [lindex $all 1]] chars" } } # puts stdout "found $endmatch: `[string range $text [expr $endmatch - 10] \ [expr $endmatch + 4]]'" set text [string range $text $endmatch end] incr begin $endmatch if {[expr $begin >= $limit]} { set limit $begin ;break} } $w mark set MaRe "MaRe + $limit chars" } # puts stdout "found $found matches" } gcl-2.6.14/gcl-tk/demos/0000755000175000017500000000000014360276512013263 5ustar cammcammgcl-2.6.14/gcl-tk/demos/mkStyles.lisp0000755000175000017500000001215714360276512016000 0ustar cammcamm;;# mkStyles w ;; ;; Create a top-level window with a text widget that demonstrates the ;; various display styles that are available in texts. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkStyles (&optional (w '.styles) &aux (textwin (conc w '.t)) ) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Display Styles") (wm :iconname w "Text Styles") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true" :width 70 :height 28) (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles (funcall textwin :tag :configure 'bold :font :Adobe-Courier-Bold-O-Normal-*-120-*) (funcall textwin :tag :configure 'big :font :Adobe-Courier-Bold-R-Normal-*-140-*) (funcall textwin :tag :configure 'verybig :font :Adobe-Helvetica-Bold-R-Normal-*-240-*) (if (> (read-from-string (winfo :depth w)) 1) (progn (funcall textwin :tag :configure 'color1 :background "#eed5b7") (funcall textwin :tag :configure 'color2 :foreground "red") (funcall textwin :tag :configure 'raised :background "#eed5b7" :relief "raised" :borderwidth 1) (funcall textwin :tag :configure 'sunken :background "#eed5b7" :relief "sunken" :borderwidth 1) ) ;;else (progn (funcall textwin :tag :configure 'color1 :background "black" :foreground "white") (funcall textwin :tag :configure 'color2 :background "black" :foreground "white") (funcall textwin :tag :configure 'raised :background "white" :relief "raised" :borderwidth 1) (funcall textwin :tag :configure 'sunken :background "white" :relief "sunken" :borderwidth 1) )) (funcall textwin :tag :configure 'bgstipple :background "black" :borderwidth 0 :bgstipple "gray25") (funcall textwin :tag :configure 'fgstipple :fgstipple "gray50") (funcall textwin :tag :configure 'underline :underline "on") (funcall textwin :insert 0.0 " Text widgets like this one allow you to display information in a variety of styles. Display styles are controlled using a mechanism called " ) (insertWithTags textwin "tags" 'bold) (insertWithTags textwin ". Tags are just textual names that you can apply to one or more ranges of characters within a text widget. You can configure tags with various display styles. (if :you do this, then the tagged characters will be displayed with the styles you chose. The available display styles are: " ) (insertWithTags textwin " 1. Font." 'big) (insertWithTags textwin " You can choose any X font, ") (insertWithTags textwin "large" "verybig") (insertWithTags textwin " or ") (insertWithTags textwin "small. ") (insertWithTags textwin " 2. Color." 'big) (insertWithTags textwin " You can change either the ") (insertWithTags textwin "background" "color1") (insertWithTags textwin " or ") (insertWithTags textwin "foreground" "color2") (insertWithTags textwin " color, or ") (insertWithTags textwin "both" "color1" "color2") (insertWithTags textwin ". ") (insertWithTags textwin " 3. Stippling." 'big) (insertWithTags textwin " You can cause either the ") (insertWithTags textwin "background" 'bgstipple) (insertWithTags textwin " or ") (insertWithTags textwin "foreground" 'fgstipple) (insertWithTags textwin " information to be drawn with a stipple fill instead of a solid fill. ") (insertWithTags textwin " 4. Underlining." 'big) (insertWithTags textwin " You can ") (insertWithTags textwin "underline" "underline") (insertWithTags textwin " ranges of text. ") (insertWithTags textwin " 5. 3-D effects." 'big) (insertWithTags textwin " You can arrange for the background to be drawn with a border that makes characters appear either ") (insertWithTags textwin "raised" "raised") (insertWithTags textwin " or ") (insertWithTags textwin "sunken" "sunken") (insertWithTags textwin ". ") (insertWithTags textwin " 6. Yet to come." 'big) (insertWithTags textwin " More display effects will be coming soon, such as the ability to change line justification and perhaps line spacing.") (funcall textwin :mark :set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) ;; The procedure below inserts text into a given text widget and ;; applies one or more tags to that text. The arguments are: ;; ;; w Window in which to insert ;; text Text to insert (it's :inserted at the "insert" mark) ;; args One or more tags to apply to text. (if :this is empty ;; then all tags are removed from the text. (defun insertWithTags (w text &rest args) (let (( start (funcall w :index 'insert :return 'string))) (funcall w :insert 'insert text) (dolist (v (funcall w :tag :names start :return 'list-strings)) (funcall w :tag :remove v start 'insert)) (dolist (i args) (funcall w :tag :add i start 'insert)))) gcl-2.6.14/gcl-tk/demos/mkRuler.tcl0000755000175000017500000000747614360276512015431 0ustar cammcamm# mkRuler w # # Create a canvas demonstration consisting of a ruler. # # Arguments: # w - Name to use for new top-level window. # This file implements a canvas widget that displays a ruler with tab stops # that can be set individually. The only procedure that should be invoked # from outside the file is the first one, which creates the canvas. proc mkRuler {{w .ruler}} { global tk_library upvar #0 demo_rulerInfo v catch {destroy $w} toplevel $w dpos $w wm title $w "Ruler Demonstration" wm iconname $w "Ruler" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 13c \ -relief raised -bd 2 -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." canvas $c -width 14.8c -height 2.5c -relief raised button $w.ok -text "OK" -command "destroy $w" pack $w.msg $w.c -side top -fill x pack $w.ok -side bottom -pady 5 set v(grid) .25c set v(left) [winfo fpixels $c 1c] set v(right) [winfo fpixels $c 13c] set v(top) [winfo fpixels $c 1c] set v(bottom) [winfo fpixels $c 1.5c] set v(size) [winfo fpixels $c .2c] set v(normalStyle) "-fill black" if {[winfo depth $c] > 1} { set v(activeStyle) "-fill red -stipple {}" set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ -fill red" } else { set v(activeStyle) "-fill black -stipple {}" set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ -fill black" } $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 for {set i 0} {$i < 12} {incr i} { set x [expr $i+1] $c create line ${x}c 1c ${x}c 0.6c -width 1 $c create line $x.25c 1c $x.25c 0.8c -width 1 $c create line $x.5c 1c $x.5c 0.7c -width 1 $c create line $x.75c 1c $x.75c 0.8c -width 1 $c create text $x.15c .75c -text $i -anchor sw } $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ -outline black -fill [lindex [$c config -bg] 4]] $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ [winfo pixels $c .65c]] $c bind well <1> "rulerNewTab $c %x %y" $c bind tab <1> "demo_selectTab $c %x %y" bind $c "rulerMoveTab $c %x %y" bind $c "rulerReleaseTab $c" } proc rulerMkTab {c x y} { upvar #0 demo_rulerInfo v $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ [expr $x-$v(size)] [expr $y+$v(size)] } proc rulerNewTab {c x y} { upvar #0 demo_rulerInfo v $c addtag active withtag [rulerMkTab $c $x $y] $c addtag tab withtag active set v(x) $x set v(y) $y rulerMoveTab $c $x $y } proc rulerMoveTab {c x y} { upvar #0 demo_rulerInfo v if {[$c find withtag active] == ""} { return } set cx [$c canvasx $x $v(grid)] set cy [$c canvasy $y] if {$cx < $v(left)} { set cx $v(left) } if {$cx > $v(right)} { set cx $v(right) } if {($cy >= $v(top)) && ($cy <= $v(bottom))} { set cy [expr $v(top)+2] eval "$c itemconf active $v(activeStyle)" } else { set cy [expr $cy-$v(size)-2] eval "$c itemconf active $v(deleteStyle)" } $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] set v(x) $cx set v(y) $cy } proc demo_selectTab {c x y} { upvar #0 demo_rulerInfo v set v(x) [$c canvasx $x $v(grid)] set v(y) [expr $v(top)+2] $c addtag active withtag current eval "$c itemconf active $v(activeStyle)" $c raise active } proc rulerReleaseTab c { upvar #0 demo_rulerInfo v if {[$c find withtag active] == {}} { return } if {$v(y) != [expr $v(top)+2]} { $c delete active } else { eval "$c itemconf active $v(normalStyle)" $c dtag active } } gcl-2.6.14/gcl-tk/demos/mkLabel.lisp0000755000175000017500000000312414360276512015526 0ustar cammcamm;;# mkLabel w ;; ;; Create a top-level window that displays a bunch of labels. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkLabel (&optional (w '.l1)) ; (global :tk_library) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Label Demonstration") (wm :iconname w "Labels") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough.") (frame (conc w '.left)) (frame (conc w '.right)) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (pack (conc w '.msg) :side "top") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.left) (conc w '.right) :side "left" :expand "yes" :padx 10 :pady 10 :fill "both") (label (conc w '.left.l1) :text "First label") (label (conc w '.left.l2) :text "Second label, raised just for fun" :relief "raised") (label (conc w '.left.l3) :text "Third label, sunken" :relief "sunken") (pack (conc w '.left.l1) (conc w '.left.l2) (conc w '.left.l3) :side "top" :expand "yes" :pady 2 :anchor "w") (label (conc w '.right.bitmap) :bitmap "@": *tk-library* : "/demos/images/face" :borderwidth 2 :relief "sunken") (label (conc w '.right.caption) :text "Tcl/Tk Proprietor") (pack (conc w '.right.bitmap) (conc w '.right.caption) :side "top") ) gcl-2.6.14/gcl-tk/demos/mkCanvText.tcl0000755000175000017500000001054714360276512016065 0ustar cammcamm# mkCanvText w # # Create a top-level window containing a canvas displaying a text # string and allowing the string to be edited and re-anchored. # # Arguments: # w - Name to use for new top-level window. proc mkCanvText {{w .ctext}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Canvas Text Demonstration" wm iconname $w "Text" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 420 \ -relief raised -bd 2 -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification." canvas $c -relief raised -width 500 -height 400 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill both pack $w.c -side top -expand yes -fill both pack $w.ok -side bottom -pady 5 -anchor center set font -Adobe-helvetica-medium-r-*-240-* $c create rectangle 245 195 255 205 -outline black -fill red # First, create the text item and give it bindings so it can be edited. $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left] $c bind text <1> "textB1Press $c %x %y" $c bind text "textB1Move $c %x %y" $c bind text "$c select adjust current @%x,%y" $c bind text "textB1Move $c %x %y" $c bind text "$c insert text insert %A" $c bind text "$c insert text insert %A" $c bind text "$c insert text insert \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "$c dchars text sel.first sel.last" $c bind text "$c insert text insert \[selection get\]" # Next, create some items that allow the text's anchor position # to be edited. set x 50 set y 50 set color LightSkyBlue1 mkTextConfig $c $x $y -anchor se $color mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ -outline black -fill red] $c bind $item <1> "$c itemconf text -anchor center" $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ -font -Adobe-times-medium-r-normal--*-240-* -fill brown # Lastly, create some items that allow the text's justification to be # changed. set x 350 set y 50 set color SeaGreen2 mkTextConfig $c $x $y -justify left $color mkTextConfig $c [expr $x+30] [expr $y] -justify center $color mkTextConfig $c [expr $x+60] [expr $y] -justify right $color $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ -font -Adobe-times-medium-r-normal--*-240-* -fill brown $c bind config "textEnter $c" $c bind config "$c itemconf current -fill \$textConfigFill" } proc mkTextConfig {w x y option value color} { set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ -outline black -fill $color -width 1] $w bind $item <1> "$w itemconf text $option $value" $w addtag config withtag $item } set textConfigFill {} proc textEnter {w} { global textConfigFill set textConfigFill [lindex [$w itemconfig current -fill] 4] $w itemconfig current -fill black } proc textB1Press {w x y} { $w icursor current @$x,$y $w focus current focus $w $w select from current @$x,$y } proc textB1Move {w x y} { $w select to current @$x,$y } proc textBs {w} { set char [expr {[$w index text insert] - 1}] if {$char >= 0} {$w dchar text $char} } gcl-2.6.14/gcl-tk/demos/mkdialog.lisp0000755000175000017500000000475114360276512015755 0ustar cammcamm;;# mkDialog w msgArgs list list '... (in-package "TK") ;; ;; Create a dialog box with a message and any number of buttons at ;; the bottom. ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; msgArgs - List of arguments to use when creating the message of the ;; dialog box (e.g. :text, justifcation, etc.) ;; list - A two-element list that describes one of the buttons that ;; will appear at the bottom of the dialog. The first element ;; gives the text to be displayed in the button and the second ;; gives the command to be invoked when the button is invoked. (defun mkDialog (w msgArgs &rest args) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w :class "Dialog") (wm :title w "Dialog box") (wm :iconname w "Dialog") ;; Create two frames in the main window. The top frame will hold the ;; message and the bottom one will hold the buttons. Arrange them ;; one above the other, with any extra vertical space split between ;; them. (frame (conc w '.top) :relief "raised" :border 1) (frame (conc w '.bot) :relief "raised" :border 1) (pack (conc w '.top) (conc w '.bot) :side "top" :fill "both" :expand "yes") ;; Create the message widget and arrange for it to be centered in the ;; top frame. (apply 'message (conc w '.top.msg) :justify "center" :font :Adobe-times-medium-r-normal--*-180* msgArgs) (pack (conc w '.top.msg) :side "top" :expand "yes" :padx 3 :pady 3) ;; Create as many buttons as needed and arrange them from left to right ;; in the bottom frame. Embed the left button in an additional sunken ;; frame to indicate that it is the default button, and arrange for that ;; button to be invoked as the default action for clicks and returns in ;; the dialog. (if (> (length args) 0) (let ((i 1) arg) (setq arg (nth 0 args)) (frame (conc w '.bot.0) :relief "sunken" :border 1) (pack (conc w '.bot.0) :side "left" :expand "yes" :padx 10 :pady 10) (button (conc w '.bot.0.button) :text (nth 0 arg) :command `(progn ,(nth 1 arg)(destroy ',w))) (pack (conc w '.bot.0.button) :expand "yes" :padx 6 :pady 6) (bind w "" `(progn ,(nth 1 arg)(destroy ',w))) (focus w) (dolist (arg (cdr args)) (setq i (+ i 1)) (button (conc w '.bot. i) :text (nth 0 arg) :command `(progn ,(nth 1 arg)(destroy ',w))) (pack (conc w '.bot. i) :side "left" :expand "yes" :padx 10) ) )) (bind w "" `(focus ',w)) (focus w) ) gcl-2.6.14/gcl-tk/demos/mkDialog.tcl0000755000175000017500000000434014360276512015522 0ustar cammcamm# mkDialog w msgArgs list list ... # # Create a dialog box with a message and any number of buttons at # the bottom. # # Arguments: # w - Name to use for new top-level window. # msgArgs - List of arguments to use when creating the message of the # dialog box (e.g. text, justifcation, etc.) # list - A two-element list that describes one of the buttons that # will appear at the bottom of the dialog. The first element # gives the text to be displayed in the button and the second # gives the command to be invoked when the button is invoked. proc mkDialog {w msgArgs args} { catch {destroy $w} toplevel $w -class Dialog wm title $w "Dialog box" wm iconname $w "Dialog" # Create two frames in the main window. The top frame will hold the # message and the bottom one will hold the buttons. Arrange them # one above the other, with any extra vertical space split between # them. frame $w.top -relief raised -border 1 frame $w.bot -relief raised -border 1 pack $w.top $w.bot -side top -fill both -expand yes # Create the message widget and arrange for it to be centered in the # top frame. eval message $w.top.msg -justify center \ -font -Adobe-times-medium-r-normal--*-180* $msgArgs pack $w.top.msg -side top -expand yes -padx 3 -pady 3 # Create as many buttons as needed and arrange them from left to right # in the bottom frame. Embed the left button in an additional sunken # frame to indicate that it is the default button, and arrange for that # button to be invoked as the default action for clicks and returns in # the dialog. if {[llength $args] > 0} { set arg [lindex $args 0] frame $w.bot.0 -relief sunken -border 1 pack $w.bot.0 -side left -expand yes -padx 10 -pady 10 button $w.bot.0.button -text [lindex $arg 0] \ -command "[lindex $arg 1]; destroy $w" pack $w.bot.0.button -expand yes -padx 6 -pady 6 bind $w "[lindex $arg 1]; destroy $w" focus $w set i 1 foreach arg [lrange $args 1 end] { button $w.bot.$i -text [lindex $arg 0] \ -command "[lindex $arg 1]; destroy $w" pack $w.bot.$i -side left -expand yes -padx 10 set i [expr $i+1] } } bind $w [list focus $w] focus $w } gcl-2.6.14/gcl-tk/demos/mkLabel.tcl0000755000175000017500000000246714360276512015352 0ustar cammcamm# mkLabel w # # Create a top-level window that displays a bunch of labels. # # Arguments: # w - Name to use for new top-level window. proc mkLabel {{w .l1}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Label Demonstration" wm iconname $w "Labels" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough." frame $w.left frame $w.right button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both label $w.left.l1 -text "First label" label $w.left.l2 -text "Second label, raised just for fun" -relief raised label $w.left.l3 -text "Third label, sunken" -relief sunken pack $w.left.l1 $w.left.l2 $w.left.l3 \ -side top -expand yes -pady 2 -anchor w label $w.right.bitmap -bitmap @$tk_library/demos/images/face.bmp \ -borderwidth 2 -relief sunken label $w.right.caption -text "Tcl/Tk Proprietor" pack $w.right.bitmap $w.right.caption -side top } gcl-2.6.14/gcl-tk/demos/mkEntry.tcl0000755000175000017500000000274514360276512015433 0ustar cammcamm# mkEntry w # # Create a top-level window that displays a bunch of entries. # # Arguments: # w - Name to use for new top-level window. proc mkEntry {{w .e1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Entry Demonstration" wm iconname $w "Entries" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill both entry $w.frame.e1 -relief sunken entry $w.frame.e2 -relief sunken entry $w.frame.e3 -relief sunken pack $w.frame.e1 $w.frame.e2 $w.frame.e3 -side top -pady 5 -fill x $w.frame.e1 insert 0 "Initial value" $w.frame.e2 insert end "This entry contains a long value, much too long " $w.frame.e2 insert end "to fit in the window at one time, so long in fact " $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." } gcl-2.6.14/gcl-tk/demos/mkItems.tcl0000755000175000017500000002342314360276512015407 0ustar cammcamm# mkItems w # # Create a top-level window containing a canvas that displays the # various item types and allows them to be selected and moved. This # demo can be used to test out the point-hit and rectangle-hit code # for items. # # Arguments: # w - Name to use for new top-level window. proc mkItems {{w .citems}} { global c tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Canvas Item Demonstration" wm iconname $w "Items" wm minsize $w 100 100 set c $w.frame2.c message $w.msg -font -Adobe-Times-Medium-R-Normal--*-180-* -width 13c \ -bd 2 -relief raised -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." frame $w.frame2 -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill x pack $w.frame2 -side top -fill both -expand yes pack $w.ok -side bottom -pady 5 -anchor center canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ -xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set" scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" pack $w.frame2.hscroll -side bottom -fill x pack $w.frame2.vscroll -side right -fill y pack $c -in $w.frame2 -expand yes -fill both # Display a 3x3 rectangular grid. $c create rect 0c 0c 30c 24c -width 2 $c create line 0c 8c 30c 8c -width 2 $c create line 0c 16c 30c 16c -width 2 $c create line 10c 0c 10c 24c -width 2 $c create line 20c 0c 20c 24c -width 2 set font1 -Adobe-Helvetica-Medium-R-Normal--*-120-* set font2 -Adobe-Helvetica-Bold-R-Normal--*-240-* if {[winfo depth $c] > 1} { set blue DeepSkyBlue3 set red red set bisque bisque3 set green SeaGreen3 } else { set blue black set red black set bisque black set green black } # Set up demos within each of the areas of the grid. $c create text 5c .2c -text Lines -anchor n $c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ -cap butt -join miter -tags item $c create line 4.67c 1c 4.67c 4c -arrow last -tags item $c create line 6.33c 1c 6.33c 4c -arrow both -tags item $c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ -width 3 -fill $red -tags item $c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ -stipple @$tk_library/demos/bitmaps/grey.25 \ -arrow both -arrowshape {15 15 7} -tags item $c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ -cap round -join round -tags item $c create text 15c .2c -text "Curves (smoothed lines)" -anchor n $c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ -fill $blue -tags item $c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ -arrow both -width 3 -tags item $c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $red -tags item $c create text 25c .2c -text Polygons -anchor n $c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green -tags item $c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item $c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ -stipple @$tk_library/demos/bitmaps/grey.25 -tags item $c create text 5c 8.2c -text Rectangles -anchor n $c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item $c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item $c create rectangle 6c 10c 9c 15c -outline {} \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item $c create text 15c 8.2c -text Ovals -anchor n $c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item $c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item $c create oval 16c 10c 19c 15c -outline {} \ -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item $c create text 25c 8.2c -text Text -anchor n $c create rectangle 22.4c 8.9c 22.6c 9.1c $c create text 22.5c 9c -anchor n -font $font1 -width 4c \ -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item $c create rectangle 25.4c 10.9c 25.6c 11.1c $c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ -justify center -tags item $c create rectangle 24.9c 13.9c 25.1c 14.1c $c create text 25c 14c -font $font2 -anchor c -fill $red \ -stipple @$tk_library/demos/bitmaps/grey.5 \ -text "Stippled characters" -tags item $c create text 5c 16.2c -text Arcs -anchor n $c create arc 0.5c 17c 7c 20c -fill $green -outline black \ -start 45 -extent 270 -style pieslice -tags item $c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ -fill $blue -start -135 -extent 270 \ -stipple @$tk_library/demos/bitmaps/grey.25 -tags item $c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ -fill {} -outline $red -start 225 -extent -90 -tags item $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ -fill $blue -outline {} -start 45 -extent 270 -tags item $c create text 15c 16.2c -text Bitmaps -anchor n $c create bitmap 13c 20c -bitmap @$tk_library/demos/bitmaps/face -tags item $c create bitmap 17c 18.5c \ -bitmap @$tk_library/demos/bitmaps/noletters -tags item $c create bitmap 17c 21.5c \ -bitmap @$tk_library/demos/bitmaps/letters -tags item $c create text 25c 16.2c -text Windows -anchor n button $c.button -text "Press Me" -command "butPress $c $red" $c create window 21c 18c -window $c.button -anchor nw -tags item entry $c.entry -width 20 -relief sunken $c.entry insert end "Edit this text" $c create window 21c 21c -window $c.entry -anchor nw -tags item scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ -width .5c -tickinterval 0 $c create window 28.5c 17.5c -window $c.scale -anchor n -tags item $c create text 21c 17.9c -text Button: -anchor sw $c create text 21c 20.9c -text Entry: -anchor sw $c create text 28.5c 17.4c -text Scale: -anchor s # Set up event bindings for canvas: $c bind item "itemEnter $c" $c bind item "itemLeave $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c <3> "itemMark $c %x %y" bind $c "itemStroke $c %x %y" bind $c "itemsUnderArea $c" bind $c <1> "itemStartDrag $c %x %y" bind $c "itemDrag $c %x %y" bind $w "focus $c" } # Utility procedures for highlighting the item under the pointer: proc itemEnter {c} { global restoreCmd if {[winfo depth $c] <= 1} { set restoreCmd {} return } set type [$c type current] if {$type == "window"} { set restoreCmd {} return } if {$type == "bitmap"} { set bg [lindex [$c itemconf current -background] 4] set restoreCmd [list $c itemconfig current -background $bg] $c itemconfig current -background SteelBlue2 return } set fill [lindex [$c itemconfig current -fill] 4] if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) && ($fill == "")} { set outline [lindex [$c itemconfig current -outline] 4] set restoreCmd "$c itemconfig current -outline $outline" $c itemconfig current -outline SteelBlue2 } else { set restoreCmd "$c itemconfig current -fill $fill" $c itemconfig current -fill SteelBlue2 } } proc itemLeave {c} { global restoreCmd eval $restoreCmd } # Utility procedures for stroking out a rectangle and printing what's # underneath the rectangle's area. proc itemMark {c x y} { global areaX1 areaY1 set areaX1 [$c canvasx $x] set areaY1 [$c canvasy $y] $c delete area } proc itemStroke {c x y} { global areaX1 areaY1 areaX2 areaY2 set x [$c canvasx $x] set y [$c canvasy $y] if {($areaX1 != $x) && ($areaY1 != $y)} { $c delete area $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ -outline black] set areaX2 $x set areaY2 $y } } proc itemsUnderArea {c} { global areaX1 areaY1 areaX2 areaY2 set area [$c find withtag area] set items "" foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { if {[lsearch [$c gettags $i] item] != -1} { lappend items $i } } puts stdout "Items enclosed by area: $items" set items "" foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { if {[lsearch [$c gettags $i] item] != -1} { lappend items $i } } puts stdout "Items overlapping area: $items" } set areaX1 0 set areaY1 0 set areaX2 0 set areaY2 0 # Utility procedures to support dragging of items. proc itemStartDrag {c x y} { global lastX lastY set lastX [$c canvasx $x] set lastY [$c canvasy $y] } proc itemDrag {c x y} { global lastX lastY set x [$c canvasx $x] set y [$c canvasy $y] $c move current [expr $x-$lastX] [expr $y-$lastY] set lastX $x set lastY $y } # Procedure that's invoked when the button embedded in the canvas # is invoked. proc butPress {w color} { set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] after 500 "$w delete $i" } gcl-2.6.14/gcl-tk/demos/mkRadio.tcl0000755000175000017500000000502014360276512015355 0ustar cammcamm# mkRadio w # # Create a top-level window that displays a bunch of radio buttons. # # Arguments: # w - Name to use for new top-level window. proc mkRadio {{w .r1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Radiobutton Demonstration" wm iconname $w "Radiobuttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 frame $w.frame2 pack $w.msg -side top pack $w.msg -side top pack $w.frame -side top -fill x -pady 10 pack $w.frame2 -side bottom -fill x frame $w.frame.left frame $w.frame.right pack $w.frame.left $w.frame.right -side left -expand yes radiobutton $w.frame.left.b1 -text "Point Size 10" -variable size \ -relief flat -value 10 radiobutton $w.frame.left.b2 -text "Point Size 12" -variable size \ -relief flat -value 12 radiobutton $w.frame.left.b3 -text "Point Size 18" -variable size \ -relief flat -value 18 radiobutton $w.frame.left.b4 -text "Point Size 24" -variable size \ -relief flat -value 24 pack $w.frame.left.b1 $w.frame.left.b2 $w.frame.left.b3 $w.frame.left.b4 \ -side top -pady 2 -anchor w radiobutton $w.frame.right.b1 -text "Red" -variable color \ -relief flat -value red radiobutton $w.frame.right.b2 -text "Green" -variable color \ -relief flat -value green radiobutton $w.frame.right.b3 -text "Blue" -variable color \ -relief flat -value blue radiobutton $w.frame.right.b4 -text "Yellow" -variable color \ -relief flat -value yellow radiobutton $w.frame.right.b5 -text "Orange" -variable color \ -relief flat -value orange radiobutton $w.frame.right.b6 -text "Purple" -variable color \ -relief flat -value purple pack $w.frame.right.b1 $w.frame.right.b2 $w.frame.right.b3 \ $w.frame.right.b4 $w.frame.right.b5 $w.frame.right.b6 \ -side top -pady 2 -anchor w button $w.frame2.ok -text OK -command "destroy $w" -width 12 button $w.frame2.vars -text "See Variables" -width 12\ -command "showVars $w.dialog size color" pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill x } gcl-2.6.14/gcl-tk/demos/mkBasic.tcl0000755000175000017500000000471114360276512015346 0ustar cammcamm# mkBasic w # # Create a top-level window that displays a basic text widget. # # Arguments: # w - Name to use for new top-level window. proc mkBasic {{w .basic}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Basic Facilities" wm iconname $w "Text Basics" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both $w.t insert 0.0 {\ This window is a text widget. It displays one or more lines of text and allows you to edit the text. Here is a summary of the things you can do to a text widget: 1. Scrolling. Use the scrollbar to adjust the view in the text window. 2. Scanning. Press mouse button 2 in the text window and drag up or down. This will drag the text at high speed to allow you to scan its contents. 3. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. You can backspace over what you've typed using either the backspace key, the delete key, or Control+h. 4. Select. Press mouse button 1 and drag to select a range of characters. Once you've released the button, you can adjust the selection by pressing button 1 with the shift key down. This will reset the end of the selection nearest the mouse cursor and you can drag that end of the selection by dragging the mouse before releasing the mouse button. You can double-click to select whole words, or triple-click to select whole lines. 5. Delete. To delete text, select the characters you'd like to delete and type Control+d. 6. Copy the selection. To copy the selection either from this window or from any other window or application, select what you want, click button 1 to set the insertion cursor, then type Control+v to copy the selection to the point of the insertion cursor. 7. Resize the window. This widget has been configured with the "setGrid" option on, so that if you resize the window it will always resize to an even number of characters high and wide. Also, if you make the window narrow you can see that long lines automatically wrap around onto additional lines so that all the information is always visible. When you're finished with this demonstration, press the "OK" button below.} $w.t mark set insert 0.0 bind $w "focus $w.t" } gcl-2.6.14/gcl-tk/demos/tclIndex0000755000175000017500000001266614360276512014776 0ustar cammcamm# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(mkCheck) [list source [file join $dir mkCheck.tcl]] set auto_index(mkListbox2) [list source [file join $dir mkListbox2.tcl]] set auto_index(mkLabel) [list source [file join $dir mkLabel.tcl]] set auto_index(mkListbox3) [list source [file join $dir mkListbox3.tcl]] set auto_index(mkPuzzle) [list source [file join $dir mkPuzzle.tcl]] set auto_index(puzzle.switch) [list source [file join $dir mkPuzzle.tcl]] set auto_index(mkArrow) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowSetup) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove1) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove2) [list source [file join $dir mkArrow.tcl]] set auto_index(arrowMove3) [list source [file join $dir mkArrow.tcl]] set auto_index(mkBasic) [list source [file join $dir mkBasic.tcl]] set auto_index(mkBitmaps) [list source [file join $dir mkBitmaps.tcl]] set auto_index(bitmapRow) [list source [file join $dir mkBitmaps.tcl]] set auto_index(mkButton) [list source [file join $dir mkButton.tcl]] set auto_index(mkCanvText) [list source [file join $dir mkCanvText.tcl]] set auto_index(mkTextConfig) [list source [file join $dir mkCanvText.tcl]] set auto_index(textEnter) [list source [file join $dir mkCanvText.tcl]] set auto_index(textB1Press) [list source [file join $dir mkCanvText.tcl]] set auto_index(textB1Move) [list source [file join $dir mkCanvText.tcl]] set auto_index(textBs) [list source [file join $dir mkCanvText.tcl]] set auto_index(mkDialog) [list source [file join $dir mkDialog.tcl]] set auto_index(mkEntry) [list source [file join $dir mkEntry.tcl]] set auto_index(mkEntry2) [list source [file join $dir mkEntry2.tcl]] set auto_index(mkFloor) [list source [file join $dir mkFloor.tcl]] set auto_index(floorDisplay) [list source [file join $dir mkFloor.tcl]] set auto_index(roomChanged) [list source [file join $dir mkFloor.tcl]] set auto_index(bg1) [list source [file join $dir mkFloor.tcl]] set auto_index(bg2) [list source [file join $dir mkFloor.tcl]] set auto_index(bg3) [list source [file join $dir mkFloor.tcl]] set auto_index(fg1) [list source [file join $dir mkFloor.tcl]] set auto_index(fg2) [list source [file join $dir mkFloor.tcl]] set auto_index(fg3) [list source [file join $dir mkFloor.tcl]] set auto_index(mkForm) [list source [file join $dir mkForm.tcl]] set auto_index(Tab) [list source [file join $dir mkForm.tcl]] set auto_index(mkHScale) [list source [file join $dir mkHScale.tcl]] set auto_index(setWidth) [list source [file join $dir mkHScale.tcl]] set auto_index(mkIcon) [list source [file join $dir mkIcon.tcl]] set auto_index(iconCmd) [list source [file join $dir mkIcon.tcl]] set auto_index(mkItems) [list source [file join $dir mkItems.tcl]] set auto_index(itemEnter) [list source [file join $dir mkItems.tcl]] set auto_index(itemLeave) [list source [file join $dir mkItems.tcl]] set auto_index(itemMark) [list source [file join $dir mkItems.tcl]] set auto_index(itemStroke) [list source [file join $dir mkItems.tcl]] set auto_index(itemsUnderArea) [list source [file join $dir mkItems.tcl]] set auto_index(itemStartDrag) [list source [file join $dir mkItems.tcl]] set auto_index(itemDrag) [list source [file join $dir mkItems.tcl]] set auto_index(butPress) [list source [file join $dir mkItems.tcl]] set auto_index(mkListbox) [list source [file join $dir mkListbox.tcl]] set auto_index(mkPlot) [list source [file join $dir mkPlot.tcl]] set auto_index(plotDown) [list source [file join $dir mkPlot.tcl]] set auto_index(plotMove) [list source [file join $dir mkPlot.tcl]] set auto_index(mkRadio) [list source [file join $dir mkRadio.tcl]] set auto_index(mkRuler) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerMkTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerNewTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerMoveTab) [list source [file join $dir mkRuler.tcl]] set auto_index(demo_selectTab) [list source [file join $dir mkRuler.tcl]] set auto_index(rulerReleaseTab) [list source [file join $dir mkRuler.tcl]] set auto_index(mkScroll) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollEnter) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollLeave) [list source [file join $dir mkScroll.tcl]] set auto_index(scrollButton) [list source [file join $dir mkScroll.tcl]] set auto_index(mkTextSearch) [list source [file join $dir mkSearch.tcl]] set auto_index(TextLoadFile) [list source [file join $dir mkSearch.tcl]] set auto_index(TextSearch) [list source [file join $dir mkSearch.tcl]] set auto_index(TextToggle) [list source [file join $dir mkSearch.tcl]] set auto_index(mkStyles) [list source [file join $dir mkStyles.tcl]] set auto_index(insertWithTags) [list source [file join $dir mkStyles.tcl]] set auto_index(mkTear) [list source [file join $dir mkTear.tcl]] set auto_index(mkTextBind) [list source [file join $dir mkTextBind.tcl]] set auto_index(insertWithTags) [list source [file join $dir mkTextBind.tcl]] set auto_index(mkVScale) [list source [file join $dir mkVScale.tcl]] set auto_index(setHeight) [list source [file join $dir mkVScale.tcl]] set auto_index(showVars) [list source [file join $dir showVars.tcl]] gcl-2.6.14/gcl-tk/demos/mkButton.tcl0000755000175000017500000000232314360276512015575 0ustar cammcamm# mkButton w # # Create a top-level window that displays a bunch of buttons. # # Arguments: # w - Name to use for new top-level window. proc mkButton {{w .b1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Button Demonstration" wm iconname $w "Buttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Four buttons are displayed below. If you click on a button, it will change the background of the button area to the color indicated in the button. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top -fill both pack $w.frame -side top -expand yes -fill both pack $w.ok -side bottom -fill both button $w.frame.b1 -text "Peach Puff" \ -command "$w.frame config -bg PeachPuff1" button $w.frame.b2 -text "Light Blue" \ -command "$w.frame config -bg LightBlue1" button $w.frame.b3 -text "Sea Green" \ -command "$w.frame config -bg SeaGreen2" button $w.frame.b4 -text "Yellow" \ -command "$w.frame config -bg Yellow1" pack $w.frame.b1 $w.frame.b2 $w.frame.b3 $w.frame.b4 -side top \ -expand yes -pady 2 } gcl-2.6.14/gcl-tk/demos/mkForm.lisp0000755000175000017500000000363314360276512015417 0ustar cammcamm;;# mkForm w ;; ;; Create a top-level window that displays a bunch of entries with ;; tabs set up to move between them. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *tablist*) (defun mkForm (&optional (w '.form)) (setq *tablist* nil) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Form Demonstration") (wm :iconname w "Form") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :width "4i" :text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done.") (dolist (i '(f1 f2 f3 f4 f5)) (frame (conc w '|.| i) :bd "1m") (entry (conc w '|.| i '.entry) :relief "sunken" :width 40) (bind (conc w '|.| i '.entry) "" '(Tab *tabList*)) (bind (conc w '|.| i '.entry) "" `(destroy ',w)) (label (conc w '|.| i '.label)) (pack (conc w '|.| i '.entry) :side "right") (pack (conc w '|.| i '.label) :side "left") (push (conc i '.entry) *tablist*)) (setq *tablist* (nreverse *tablist*)) (funcall (conc w '.f1.label) :config :text "Name: ") (funcall (conc w '.f2.label) :config :text "Address: ") (funcall (conc w '.f5.label) :config :text "Phone: ") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.f1) (conc w '.f2) (conc w '.f3) (conc w '.f4) (conc w '.f5) (conc w '.ok) :side "top" :fill "x") ) ;; The procedure below is invoked in response to tabs in the entry ;; windows. It moves the focus to the next window in the tab list. ;; Arguments: ;; ;; list - Ordered list of windows to receive focus (defun Tab (list) (setq i (position (focus :return t) list)) (cond ((null i) (setq i 0)) (t (incf i) (if (>= i (length list) ) (setq i 0)))) (focus (nth i list )) ) gcl-2.6.14/gcl-tk/demos/mkHScale.lisp0000755000175000017500000000300414360276512015643 0ustar cammcamm;;# mkHScale w ;; ;; Create a top-level window that displays a horizontal scale. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkHScale (&optional (w '.scale2)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Horizontal Scale Demonstration") (wm :iconname w "Scale") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A bar and a horizontal scale are displayed below. (if :you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "x") (frame (conc w '.frame.top) :borderwidth 15) (scale (conc w '.frame.scale) :orient "horizontal" :length 280 :from 0 :to 250 :command (tk-conc "setWidth " w ".frame.top.inner") :tickinterval 50 :bg "Bisque1") (frame (conc w '.frame.top.inner) :width 20 :height 40 :relief "raised" :borderwidth 2 :bg "SteelBlue1") (pack (conc w '.frame.top) :side "top" :expand "yes" :anchor "sw") (pack (conc w '.frame.scale) :side "bottom" :expand "yes" :anchor "nw") (pack (conc w '.frame.top.inner) :expand "yes" :anchor "sw") (funcall (conc w '.frame.scale) :set 20) ) (defun setWidth (w width) (funcall w :config :width ${width} :height 40) ) gcl-2.6.14/gcl-tk/demos/showVars.tcl0000755000175000017500000000144014360276512015605 0ustar cammcamm# showVars w var var var ... # # Create a top-level window that displays a bunch of global variable values # and keeps the display up-to-date even when the variables change value # # Arguments: # w - Name to use for new top-level window. # var - Name of variable to monitor. proc showVars {w args} { catch {destroy $w} toplevel $w wm title $w "Variable values" label $w.title -text "Variable values:" -width 20 -anchor center \ -font -Adobe-helvetica-medium-r-normal--*-180* pack $w.title -side top -fill x foreach i $args { frame $w.$i label $w.$i.name -text "$i: " label $w.$i.value -textvar $i pack $w.$i.name $w.$i.value -side left pack $w.$i -side top -anchor w } button $w.ok -text OK -command "destroy $w" pack $w.ok -side bottom -pady 2 } gcl-2.6.14/gcl-tk/demos/mkTextBind.tcl0000755000175000017500000000644314360276512016052 0ustar cammcamm# mkTextBind w # # Create a top-level window that illustrates how you can bind # Tcl commands to regions of text in a text widget. # # Arguments: # w - Name to use for new top-level window. proc mkTextBind {{w .bindings}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Tag Bindings" wm iconname $w "Text Bindings" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ -width 60 -height 28 \ -font "-Adobe-Helvetica-Bold-R-Normal-*-120-*" scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles if {[winfo depth $w] > 1} { set bold "-foreground red" set normal "-foreground {}" } else { set bold "-foreground white -background black" set normal "-foreground {} -background {}" } $w.t insert 0.0 {\ The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 3 over a description then that particular demonstration is invoked. This demo package contains a number of demonstrations of Tk's canvas widgets. Here are brief descriptions of some of the demonstrations that are available: } insertWithTags $w.t \ {1. Samples of all the different types of items that can be created in canvas widgets.} d1 insertWithTags $w.t \n\n insertWithTags $w.t \ {2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 insertWithTags $w.t \n\n insertWithTags $w.t \ {3. Anchoring and justification modes for text items.} d3 insertWithTags $w.t \n\n insertWithTags $w.t \ {4. An editor for arrow-head shapes for line items.} d4 insertWithTags $w.t \n\n insertWithTags $w.t \ {5. A ruler with facilities for editing tab stops.} d5 insertWithTags $w.t \n\n insertWithTags $w.t \ {6. A grid that demonstrates how canvases can be scrolled.} d6 foreach tag {d1 d2 d3 d4 d5 d6} { $w.t tag bind $tag "$w.t tag configure $tag $bold" $w.t tag bind $tag "$w.t tag configure $tag $normal" } $w.t tag bind d1 <3> mkItems $w.t tag bind d2 <3> mkPlot $w.t tag bind d3 <3> mkCanvText $w.t tag bind d4 <3> mkArrow $w.t tag bind d5 <3> mkRuler $w.t tag bind d6 <3> mkScroll $w.t mark set insert 0.0 bind $w "focus $w.t" } # The procedure below inserts text into a given text widget and # applies one or more tags to that text. The arguments are: # # w Window in which to insert # text Text to insert (it's inserted at the "insert" mark) # args One or more tags to apply to text. If this is empty # then all tags are removed from the text. proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } gcl-2.6.14/gcl-tk/demos/mkEntry.lisp0000755000175000017500000000331014360276512015605 0ustar cammcamm;;# mkEntry w ;; ;; Create a top-level window that displays a bunch of entries. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkEntry (&optional (w '.e1)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Entry Demonstration") (wm :iconname w "Entries") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 :text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The usual emacs control characters control editing. Thus control-b back a char, control-f forward a char, control-a begin line, control-k kill rest of line, control-y yank. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") (entry (conc w '.frame.e1) :relief "sunken") (entry (conc w '.frame.e2) :relief "sunken") (entry (conc w '.frame.e3) :relief "sunken") (pack (conc w '.frame.e1) (conc w '.frame.e2) (conc w '.frame.e3) :side "top" :pady 5 :fill "x") (funcall (conc w '.frame.e1) :insert 0 "Initial value") (funcall (conc w '.frame.e2) :insert "end" "This entry contains a long value, much too long ") (funcall (conc w '.frame.e2) :insert "end" "to fit in the window at one time, so long in fact ") (funcall (conc w '.frame.e2) :insert "end" "that you'll have to scan or scroll to see the end.") ) gcl-2.6.14/gcl-tk/demos/mkEntry2.lisp0000755000175000017500000000477514360276512015707 0ustar cammcamm;;# mkEntry2 - ;; ;; Create a top-level window that displays a bunch of entries with ;; scrollbars. ;; ;; Arguments: ;; w - Name to use for new top-level window. (IN-package "TK") (defun mkEntry2 (&optional (w '.e2)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Entry Demonstration") (wm :iconname w "Entries") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 :text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") (entry (conc w '.frame.e1) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s1 set")) (scrollbar (conc w '.frame.s1) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e1 xview")) (frame (conc w '.frame.f1) :width 20 :height 10) (entry (conc w '.frame.e2) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s2 set")) (scrollbar (conc w '.frame.s2) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e2 xview")) (frame (conc w '.frame.f2) :width 20 :height 10) (entry (conc w '.frame.e3) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s3 set")) (scrollbar (conc w '.frame.s3) :relief "sunken" :orient "horiz" :command (tk-conc w ".frame.e3 xview")) (pack (conc w '.frame.e1) (conc w '.frame.s1) (conc w '.frame.f1) (conc w '.frame.e2) (conc w '.frame.s2) (conc w '.frame.f2) (conc w '.frame.e3) (conc w '.frame.s3) :side "top" :fill "x") (funcall (conc w '.frame.e1) :insert 0 "Initial value") (funcall (conc w '.frame.e2) :insert 'end "This entry contains a long value, much too long ") (funcall (conc w '.frame.e2) :insert 'end "to fit in the window at one time, so long in fact ") (funcall (conc w '.frame.e2) :insert 'end "that you'll have to scan or scroll to see the end.") ) gcl-2.6.14/gcl-tk/demos/mkCheck.tcl0000755000175000017500000000265014360276512015342 0ustar cammcamm# mkCheck w # # Create a top-level window that displays a bunch of check buttons. # # Arguments: # w - Name to use for new top-level window. proc mkCheck {{w .c1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Checkbutton demonstration" wm iconname $w "Checkbuttons" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 frame $w.frame2 pack $w.msg -side top -fill both pack $w.frame -side top -expand yes -fill both pack $w.frame2 -side bottom -fill both checkbutton $w.frame.b1 -text "Wipers OK" -variable wipers -relief flat checkbutton $w.frame.b2 -text "Brakes OK" -variable brakes -relief flat checkbutton $w.frame.b3 -text "Driver Sober" -variable sober -relief flat pack $w.frame.b1 $w.frame.b2 $w.frame.b3 -side top -pady 2 -expand yes \ -anchor w button $w.frame2.ok -text OK -command "destroy $w" button $w.frame2.vars -text "See Variables" \ -command "showVars $w.dialog wipers brakes sober" pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill both } gcl-2.6.14/gcl-tk/demos/mkSearch.tcl0000755000175000017500000001120414360276512015525 0ustar cammcamm# mkTextSearch w # # Create a top-level window containing a text widget that allows you # to load a file and highlight all instances of a given string. # # Arguments: # w - Name to use for new top-level window. proc mkTextSearch {{w .search}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Search and Highlight" wm iconname $w "Text Search" frame $w.file label $w.file.label -text "File name:" -width 13 -anchor w entry $w.file.entry -width 40 -relief sunken -bd 2 -textvariable fileName button $w.file.button -text "Load File" \ -command "TextLoadFile $w.t \$fileName" pack $w.file.label $w.file.entry -side left pack $w.file.button -side left -pady 5 -padx 10 bind $w.file.entry " TextLoadFile $w.t \$fileName focus $w.string.entry " frame $w.string label $w.string.label -text "Search string:" -width 13 -anchor w entry $w.string.entry -width 40 -relief sunken -bd 2 \ -textvariable searchString button $w.string.button -text "Highlight" \ -command "TextSearch $w.t \$searchString search" pack $w.string.label $w.string.entry -side left pack $w.string.button -side left -pady 5 -padx 10 bind $w.string.entry "TextSearch $w.t \$searchString search" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true scrollbar $w.s -relief flat -command "$w.t yview" pack $w.file $w.string -side top -fill x pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles for text highlighting. if {[winfo depth $w] > 1} { TextToggle "$w.t tag configure search -background \ SeaGreen4 -foreground white" 800 "$w.t tag configure \ search -background {} -foreground {}" 200 } else { TextToggle "$w.t tag configure search -background \ black -foreground white" 800 "$w.t tag configure \ search -background {} -foreground {}" 200 } $w.t insert 0.0 {\ This window demonstrates how to use the tagging facilities in text widgets to implement a searching mechanism. First, type a file name in the top entry, then type or click on "Load File". Then type a string in the lower entry and type or click on "Load File". This will cause all of the instances of the string to be tagged with the tag "search", and it will arrange for the tag's display attributes to change to make all of the strings blink. } $w.t mark set insert 0.0 bind $w "focus $w.file.entry" } set fileName "" set searchString "" # The utility procedure below loads a file into a text widget, # discarding the previous contents of the widget. Tags for the # old widget are not affected, however. # Arguments: # # w - The window into which to load the file. Must be a # text widget. # file - The name of the file to load. Must be readable. proc TextLoadFile {w file} { set f [open $file] $w delete 1.0 end while {![eof $f]} { $w insert end [read $f 10000] } close $f } # The utility procedure below searches for all instances of a # given string in a text widget and applies a given tag to each # instance found. # Arguments: # # w - The window in which to search. Must be a text widget. # string - The string to search for. The search is done using # exact matching only; no special characters. # tag - Tag to apply to each instance of a matching string. proc TextSearch {w string tag} { $w tag remove search 0.0 end scan [$w index end] %d numLines set l [string length $string] for {set i 1} {$i <= $numLines} {incr i} { if {[string first $string [$w get $i.0 $i.1000]] == -1} { continue } set line [$w get $i.0 $i.1000] set offset 0 while 1 { set index [string first $string $line] if {$index < 0} { break } incr offset $index $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l] incr offset $l set line [string range $line [expr $index+$l] 1000] } } } # The procedure below is invoked repeatedly to invoke two commands # at periodic intervals. It normally reschedules itself after each # execution but if an error occurs (e.g. because the window was # deleted) then it doesn't reschedule itself. # Arguments: # # cmd1 - Command to execute when procedure is called. # sleep1 - Ms to sleep after executing cmd1 before executing cmd2. # cmd2 - Command to execute in the *next* invocation of this # procedure. # sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. proc TextToggle {cmd1 sleep1 cmd2 sleep2} { catch { eval $cmd1 after $sleep1 [list TextToggle $cmd2 $sleep2 $cmd1 $sleep1] } } gcl-2.6.14/gcl-tk/demos/mkListbox.lisp0000755000175000017500000000336714360276512016144 0ustar cammcamm(in-package "TK") (defun mklistbox (&optional (w '.listbox)) (toplevel w ) (dpos w) (wm :title w "Listbox Demonstration (50 states)") (wm :iconname w "Listbox") (wm :minsize w 1 1) (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") (pack (conc w '.ok) :side "bottom" :fill "x") (scrollbar (conc w '.frame '.scroll) :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack (conc w '.frame.scroll) :side "right" :fill "y") (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") (funcall (conc w '.frame.list) :insert 0 "Alabama" "Alaska" "Arizona" "Arkansas" "California" "Colorado" "Connecticut" "Delaware" "Florida" "Georgia" "Hawaii" "Idaho" "Illinois" "Indiana" "Iowa" "Kansas" "Kentucky" "Louisiana" "Maine" "Maryland" "Massachusetts" "Michigan" "Minnesota" "Mississippi" "Missouri" "Montana" "Nebraska" "Nevada" "New Hampshire" "New Jersey" "New Mexico" "New York" "North Carolina" "North Dakota" "Ohio" "Oklahoma" "Oregon" "Pennsylvania" "Rhode Island" "South Carolina" "South Dakota" "Tennessee" "Texas" "Utah" "Vermont" "Virginia" "Washington" "West Virginia" "Wisconsin" "Wyoming") w) gcl-2.6.14/gcl-tk/demos/mkSearch.lisp0000755000175000017500000001161314360276512015716 0ustar cammcamm;;# mkTextSearch w (in-package "TK") ;; ;; Create a top-level window containing a text widget that allows you ;; to load a file and highlight all instances of a given string. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkTextSearch (&optional (w '.search) &aux (textwin (conc w '.t))) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Search and Highlight") (wm :iconname w "Text Search") (frame (conc w '.file)) (label (conc w '.file.label) :text "File name:" :width 13 :anchor "w") (entry (conc w '.file.entry) :width 40 :relief "sunken" :bd 2 :textvariable 'fileName) (button (conc w '.file.button) :text "Load File" :command `(TextLoadFile ',textwin fileName)) (pack (conc w '.file.label) (conc w '.file.entry) :side "left") (pack (conc w '.file.button) :side "left" :pady 5 :padx 10) (bind (conc w '.file.entry) "" `(progn (TextLoadFile ',textwin fileName) (focus (conc ',w '.string.entry)))) (frame (conc w '.string)) (label (conc w '.string.label) :text "Search string:" :width 13 :anchor "w") (entry (conc w '.string.entry) :width 40 :relief "sunken" :bd 2 :textvariable 'searchString) (button (conc w '.string.button) :text "Highlight" :command `(TextSearch ',textwin searchString "search")) (pack (conc w '.string.label) (conc w '.string.entry) :side "left") (pack (conc w '.string.button) :side "left" :pady 5 :padx 10) (bind (conc w '.string.entry) "" `(TextSearch ',textwin searchString "search")) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true") (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (pack (conc w '.file) (conc w '.string) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles for text highlighting. (let* (com (bg (if (> (read-from-string (winfo :depth w)) 1) "SeaGreen4" "black")) on (fun #'(lambda () (when (myerrorset (progn (funcall textwin :tag :configure "search" :background (if on bg "") :foreground (if on "white" "")) t)) (setq on (not on)) (myerrorset (after 500 com)) )))) (setq com (tcl-create-command fun nil nil)) (setq bil fun) (funcall fun )) (funcall textwin :insert 0.0 " This window demonstrates how to use the tagging facilities in text widgets to implement a searching mechanism. First, type a file name in the top entry, then type or click on \"Load File\". Then type a string in the lower entry and type or click on \"Load File\". This will cause all of the instances of the string to be tagged with the tag \"search\", and it will arrange for the tag's display attributes to change to make all of the strings blink. " ) (funcall textwin :mark :set 'insert 0.0) (bind w "" (tk-conc "focus " w ".file.entry")) ) (setq fileName "") (setq searchString "") ;; The utility procedure below loads a file into a text widget, ;; discarding the previous contents of the widget. Tags for the ;; old widget are not affected, however. ;; Arguments: ;; ;; w - The window into which to load the file. Must be a ;; text widget. ;; file - The name of the file to load. Must be readable. (defun TextLoadFile (w file) (with-open-file (st file) (let ((ar (make-array 3000 :element-type 'string-char :fill-pointer 0)) (n (file-length st)) m) (funcall w :delete "1.0" 'end) (while (> n 0) (setq m (min (array-total-size ar) n)) (setq n (- n m)) (si::fread ar 0 m st) (setf (fill-pointer ar) m) (funcall w :insert 'end ar))))) ;; The utility procedure below searches for all instances of a ;; given string in a text widget and applies a given tag to each ;; instance found. ;; Arguments: ;; ;; w - The window in which to search. Must be a text widget. ;; string - The string to search for. The search is done using ;; exact matching only; no special characters. ;; tag - Tag to apply to each instance of a matching string. (defun TextSearch (w string tag) (funcall w :tag :remove 'search 0.0 'end) (let ((mark "mine") (m (length string))) (funcall w :mark :set "mine" "0.0") (while (funcall w :compare mark '< 'end :return 'boolean) (let ((s (funcall w :get mark mark : " + 3000 chars" :return 'string)) (n 0) tem) (while (setq tem (search string s :start2 n)) (funcall w :tag :add 'search mark : " + " : tem : " chars" mark : " + " : (setq n (+ tem m)) : " chars")) (funcall w :mark :set mark mark : " + " : (- 3000 m) : " chars"))))) gcl-2.6.14/gcl-tk/demos/mkListbox2.tcl0000755000175000017500000001142614360276512016034 0ustar cammcamm# mkListbox2 w # # Create a top-level window containing a listbox showing a bunch of # colors from the X color database. # # Arguments: # w - Name to use for new top-level window. proc mkListbox2 {{w .l2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (colors)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A listbox containing several color values is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the background for the window will be changed to that color. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.frame -side top -expand yes -fill y scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ -setgrid 1 pack $w.frame.list $w.frame.scroll -side left -fill y $w.frame.list insert 0 snow1 snow2 snow3 snow4 seashell1 seashell2 \ seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ green3 green4 chartreuse1 chartreuse2 chartreuse3 \ chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ thistle4 bind $w.frame.list \ "$w config -bg \[lindex \[selection get\] 0\] $w.frame config -bg \[lindex \[selection get\] 0\] $w.msg config -bg \[lindex \[selection get\] 0\]" } gcl-2.6.14/gcl-tk/demos/mkVScale.lisp0000755000175000017500000000300114360276512015656 0ustar cammcamm(in-package "TK") ;;# mkVScale w ;; ;; Create a top-level window that displays a vertical scale. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkVScale (&optional (w '.vscale )) ; (catch {destroy w}) (toplevel w) (dpos w) (wm :title w "Vertical Scale Demonstration") (wm :iconname w "Scale") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the OK button when you're finished.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.frame) (conc w '.ok)) (scale (conc w '.frame.scale) :orient "vertical" :length 280 :from 0 :to 250 :command #'(lambda (height) ; (print height) (setHeight (conc w '.frame.right.inner) height)) :tickinterval 50 :bg "Bisque1") (frame (conc w '.frame.right) :borderwidth 15) (frame (conc w '.frame.right.inner) :width 40 :height 20 :relief "raised" :borderwidth 2 :bg "SteelBlue1") (pack (conc w '.frame.scale) :side "left" :anchor "ne") (pack (conc w '.frame.right) :side "left" :anchor "nw") (funcall (conc w '.frame.scale) :set 20) (pack (conc w '.frame.right.inner) :expand "yes" :anchor "nw") ) (defun setHeight (w height) (funcall w :config :width 40 :height height) ) gcl-2.6.14/gcl-tk/demos/mkFloor.tcl0000755000175000017500000022604014360276512015407 0ustar cammcamm# mkFloor w # # Create a top-level window containing a canvas that displays the # floorplan for DEC's Western Research Laboratory. # # Arguments: # w - Name to use for new top-level window. proc mkFloor {{w .cfloor}} { global c tk_library currentRoom colors catch {destroy $w} toplevel $w # dpos $w wm title $w "Floorplan Canvas Demonstration" wm iconname $w "Floorplan" wm minsize $w 100 100 set c $w.frame2.c message $w.msg -font *-Times-Medium-R-Normal-*-180-* -width 800 \ -relief raised -bd 2 -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." frame $w.frame2 -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill both pack $w.frame2 -side top -fill both -expand yes pack $w.ok -side bottom -pady 5 scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" canvas $c -width 900 -height 500 -xscrollcommand "$w.frame2.hscroll set" \ -yscrollcommand "$w.frame2.vscroll set" pack $w.frame2.hscroll -side bottom -fill x pack $w.frame2.vscroll -side right -fill y pack $c -in $w.frame2 -expand yes -fill both # Create an entry for displaying and typing in current room. entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom # Choose colors, then fill in the floorplan. if {[winfo depth $c] > 1} { set colors(bg1) #c0a3db55dc28 set colors(outline1) #70207f868000 set colors(bg2) #aeb8c6eec7ad set colors(outline2) #59b466056666 set colors(bg3) #9cfab288b333 set colors(outline3) #43474c834ccd set colors(offices) Black set colors(active) #dae0f278f332 } else { set colors(bg1) white set colors(outline1) black set colors(bg2) white set colors(outline2) black set colors(bg3) white set colors(outline3) black set colors(offices) Black set colors(active) black } floorDisplay $c 3 # Set up event bindings for canvas: $c bind floor1 <1> "floorDisplay $c 1" $c bind floor2 <1> "floorDisplay $c 2" $c bind floor3 <1> "floorDisplay $c 3" $c bind room \ "set currentRoom \$floorLabels(\[$c find withtag current\]) update idletasks" $c bind room {set currentRoom ""} bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c "unset currentRoom" bind $c "focus $c.entry" set currentRoom "" trace variable currentRoom w "roomChanged $c" } set activeFloor "" # The following procedure recreates the floorplan display in the canvas # given by "w". The floor given by "active" (1, 2, or 3) is displayed # on top, with office structure visible. proc floorDisplay {w active} { global floorLabels floorItems colors activeFloor if {$activeFloor == $active} { return } $w delete all set activeFloor $active # First go through the three floors, displaying the backgrounds for # each floor. bg1 $w $colors(bg1) $colors(outline1) bg2 $w $colors(bg2) $colors(outline2) bg3 $w $colors(bg3) $colors(outline3) # Raise the background for the active floor so that it's on top. $w raise floor$active # Create a dummy item just to mark this point in the display list, # so we can insert highlights here. $w create rect 0 100 1 101 -fill {} -outline {} -tags marker # Add the walls and labels for the active floor, along with # transparent polygons that define the rooms on the floor. # Make sure that the room polygons are on top. catch {unset floorLabels} catch {unset floorItems} fg$active $w $colors(offices) $w raise room # Offset the floors diagonally from each other. $w move floor1 2c 2c $w move floor2 1c 1c # Create items for the room entry and its label. $w create window 600 100 -anchor w -window $w.entry $w create text 600 100 -anchor e -text "Room: " $w config -scrollregion [$w bbox all] } # This procedure is invoked whenever the currentRoom variable changes. # It highlights the current room and unhighlights any previous room. proc roomChanged {w args} { global currentRoom floorItems colors $w delete highlight if [catch {set item $floorItems($currentRoom)}] { return } set new [eval \ "$w create polygon [$w coords $item] -fill $colors(active) \ -tags highlight"] $w raise $new marker } # The following procedures are invoked to instantiate various portions # of the building floorplan. The bodies of these procedures were # generated automatically from database files describing the building. proc bg1 {w fill outline} { $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ 344 76 347 80 \ -tags {floor1 bg} -fill $fill $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} } proc bg2 {w fill outline} { $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ 367 802 367 802 129 725 129 725 133 559 133 559 129 \ -tags {floor2 bg} -fill $fill $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} } proc bg3 {w fill outline} { $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ -tags {floor3 bg} -fill $fill $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ -tags {floor3 bg} -fill $fill $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} $w create line 107 300 159 300 159 248 107 248 107 300 \ -fill $outline -tags {floor3 bg} } proc fg1 {w color} { global floorLabels floorItems set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] set floorLabels($i) 101 set {floorItems(101)} $i $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] set floorLabels($i) {Pub Lift1} set {floorItems(Pub Lift1)} $i $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] set floorLabels($i) {Priv Lift1} set {floorItems(Priv Lift1)} $i $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] set floorLabels($i) 110 set {floorItems(110)} $i $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] set floorLabels($i) 109 set {floorItems(109)} $i $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] set floorLabels($i) 111 set {floorItems(111)} $i $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] set floorLabels($i) 117B set {floorItems(117B)} $i $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] set floorLabels($i) 112 set {floorItems(112)} $i $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] set floorLabels($i) 113 set {floorItems(113)} $i $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] set floorLabels($i) 117A set {floorItems(117A)} $i $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] set floorLabels($i) 117 set {floorItems(117)} $i $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] set floorLabels($i) 114 set {floorItems(114)} $i $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] set floorLabels($i) 115 set {floorItems(115)} $i $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] set floorLabels($i) 116 set {floorItems(116)} $i $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] set floorLabels($i) 118 set {floorItems(118)} $i $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] set floorLabels($i) 120 set {floorItems(120)} $i $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] set floorLabels($i) 122 set {floorItems(122)} $i $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] set floorLabels($i) 121 set {floorItems(121)} $i $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] set floorLabels($i) 106A set {floorItems(106A)} $i $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] set floorLabels($i) 105 set {floorItems(105)} $i $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] set floorLabels($i) 106B set {floorItems(106B)} $i $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] set floorLabels($i) 104 set {floorItems(104)} $i $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] set floorLabels($i) 108 set {floorItems(108)} $i $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] set floorLabels($i) 107 set {floorItems(107)} $i $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] set floorLabels($i) Smoking set {floorItems(Smoking)} $i $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] set floorLabels($i) 123 set {floorItems(123)} $i $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] set floorLabels($i) 103 set {floorItems(103)} $i $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] set floorLabels($i) 124 set {floorItems(124)} $i $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] set floorLabels($i) 125 set {floorItems(125)} $i $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] set floorLabels($i) 126 set {floorItems(126)} $i $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] set floorLabels($i) 127 set {floorItems(127)} $i $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] set floorLabels($i) MShower set {floorItems(MShower)} $i $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] set floorLabels($i) Closet set {floorItems(Closet)} $i $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] set floorLabels($i) WShower set {floorItems(WShower)} $i $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] set floorLabels($i) 130 set {floorItems(130)} $i $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] set floorLabels($i) 102 set {floorItems(102)} $i $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] set floorLabels($i) 128 set {floorItems(128)} $i $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] set floorLabels($i) 129 set {floorItems(129)} $i $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] set floorLabels($i) 133 set {floorItems(133)} $i $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] set floorLabels($i) 132 set {floorItems(132)} $i $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] set floorLabels($i) 134 set {floorItems(134)} $i $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] set floorLabels($i) 135 set {floorItems(135)} $i $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] set floorLabels($i) {Ramona Stair} set {floorItems(Ramona Stair)} $i $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] set floorLabels($i) {University Stair} set {floorItems(University Stair)} $i $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] set floorLabels($i) {Plaza Stair} set {floorItems(Plaza Stair)} $i $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] set floorLabels($i) {Plaza Deck} set {floorItems(Plaza Deck)} $i $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] set floorLabels($i) 106 set {floorItems(106)} $i $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] set floorLabels($i) 119 set {floorItems(119)} $i $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} $w create line 155 191 155 189 -fill $color -tags {floor1 wall} $w create line 155 177 155 169 -fill $color -tags {floor1 wall} $w create line 96 129 96 169 -fill $color -tags {floor1 wall} $w create line 78 169 176 169 -fill $color -tags {floor1 wall} $w create line 176 247 176 129 -fill $color -tags {floor1 wall} $w create line 340 206 307 206 -fill $color -tags {floor1 wall} $w create line 340 187 340 170 -fill $color -tags {floor1 wall} $w create line 340 210 340 201 -fill $color -tags {floor1 wall} $w create line 340 247 340 224 -fill $color -tags {floor1 wall} $w create line 340 241 307 241 -fill $color -tags {floor1 wall} $w create line 376 246 376 170 -fill $color -tags {floor1 wall} $w create line 307 247 307 170 -fill $color -tags {floor1 wall} $w create line 376 170 307 170 -fill $color -tags {floor1 wall} $w create line 315 129 315 170 -fill $color -tags {floor1 wall} $w create line 147 129 176 129 -fill $color -tags {floor1 wall} $w create line 202 133 176 133 -fill $color -tags {floor1 wall} $w create line 398 129 315 129 -fill $color -tags {floor1 wall} $w create line 258 352 258 387 -fill $color -tags {floor1 wall} $w create line 60 387 60 391 -fill $color -tags {floor1 wall} $w create line 0 337 0 391 -fill $color -tags {floor1 wall} $w create line 60 391 0 391 -fill $color -tags {floor1 wall} $w create line 3 114 3 337 -fill $color -tags {floor1 wall} $w create line 258 387 60 387 -fill $color -tags {floor1 wall} $w create line 52 237 52 273 -fill $color -tags {floor1 wall} $w create line 52 189 52 225 -fill $color -tags {floor1 wall} $w create line 52 140 52 177 -fill $color -tags {floor1 wall} $w create line 395 306 395 311 -fill $color -tags {floor1 wall} $w create line 531 254 398 254 -fill $color -tags {floor1 wall} $w create line 475 178 475 238 -fill $color -tags {floor1 wall} $w create line 502 162 398 162 -fill $color -tags {floor1 wall} $w create line 398 129 398 188 -fill $color -tags {floor1 wall} $w create line 383 188 376 188 -fill $color -tags {floor1 wall} $w create line 408 188 408 194 -fill $color -tags {floor1 wall} $w create line 398 227 398 254 -fill $color -tags {floor1 wall} $w create line 408 227 398 227 -fill $color -tags {floor1 wall} $w create line 408 222 408 227 -fill $color -tags {floor1 wall} $w create line 408 206 408 210 -fill $color -tags {floor1 wall} $w create line 408 208 475 208 -fill $color -tags {floor1 wall} $w create line 484 278 484 311 -fill $color -tags {floor1 wall} $w create line 484 311 508 311 -fill $color -tags {floor1 wall} $w create line 508 327 508 311 -fill $color -tags {floor1 wall} $w create line 559 327 508 327 -fill $color -tags {floor1 wall} $w create line 644 391 559 391 -fill $color -tags {floor1 wall} $w create line 644 389 644 391 -fill $color -tags {floor1 wall} $w create line 514 205 475 205 -fill $color -tags {floor1 wall} $w create line 496 189 496 187 -fill $color -tags {floor1 wall} $w create line 559 129 484 129 -fill $color -tags {floor1 wall} $w create line 484 162 484 129 -fill $color -tags {floor1 wall} $w create line 725 133 559 133 -fill $color -tags {floor1 wall} $w create line 559 129 559 133 -fill $color -tags {floor1 wall} $w create line 725 149 725 167 -fill $color -tags {floor1 wall} $w create line 725 129 802 129 -fill $color -tags {floor1 wall} $w create line 802 389 802 129 -fill $color -tags {floor1 wall} $w create line 739 167 802 167 -fill $color -tags {floor1 wall} $w create line 396 188 408 188 -fill $color -tags {floor1 wall} $w create line 0 337 9 337 -fill $color -tags {floor1 wall} $w create line 58 337 21 337 -fill $color -tags {floor1 wall} $w create line 43 391 43 337 -fill $color -tags {floor1 wall} $w create line 105 337 75 337 -fill $color -tags {floor1 wall} $w create line 91 387 91 337 -fill $color -tags {floor1 wall} $w create line 154 337 117 337 -fill $color -tags {floor1 wall} $w create line 139 387 139 337 -fill $color -tags {floor1 wall} $w create line 227 337 166 337 -fill $color -tags {floor1 wall} $w create line 258 337 251 337 -fill $color -tags {floor1 wall} $w create line 258 328 302 328 -fill $color -tags {floor1 wall} $w create line 302 355 302 311 -fill $color -tags {floor1 wall} $w create line 395 311 302 311 -fill $color -tags {floor1 wall} $w create line 484 278 395 278 -fill $color -tags {floor1 wall} $w create line 395 294 395 278 -fill $color -tags {floor1 wall} $w create line 473 278 473 275 -fill $color -tags {floor1 wall} $w create line 473 256 473 254 -fill $color -tags {floor1 wall} $w create line 533 257 531 254 -fill $color -tags {floor1 wall} $w create line 553 276 551 274 -fill $color -tags {floor1 wall} $w create line 698 276 553 276 -fill $color -tags {floor1 wall} $w create line 559 391 559 327 -fill $color -tags {floor1 wall} $w create line 802 389 644 389 -fill $color -tags {floor1 wall} $w create line 741 314 741 389 -fill $color -tags {floor1 wall} $w create line 698 280 698 167 -fill $color -tags {floor1 wall} $w create line 707 280 698 280 -fill $color -tags {floor1 wall} $w create line 802 280 731 280 -fill $color -tags {floor1 wall} $w create line 741 280 741 302 -fill $color -tags {floor1 wall} $w create line 698 167 727 167 -fill $color -tags {floor1 wall} $w create line 725 137 725 129 -fill $color -tags {floor1 wall} $w create line 514 254 514 175 -fill $color -tags {floor1 wall} $w create line 496 175 514 175 -fill $color -tags {floor1 wall} $w create line 502 175 502 162 -fill $color -tags {floor1 wall} $w create line 475 166 475 162 -fill $color -tags {floor1 wall} $w create line 496 176 496 175 -fill $color -tags {floor1 wall} $w create line 491 189 496 189 -fill $color -tags {floor1 wall} $w create line 491 205 491 189 -fill $color -tags {floor1 wall} $w create line 487 238 475 238 -fill $color -tags {floor1 wall} $w create line 487 240 487 238 -fill $color -tags {floor1 wall} $w create line 487 252 487 254 -fill $color -tags {floor1 wall} $w create line 315 133 304 133 -fill $color -tags {floor1 wall} $w create line 256 133 280 133 -fill $color -tags {floor1 wall} $w create line 78 247 270 247 -fill $color -tags {floor1 wall} $w create line 307 247 294 247 -fill $color -tags {floor1 wall} $w create line 214 133 232 133 -fill $color -tags {floor1 wall} $w create line 217 247 217 266 -fill $color -tags {floor1 wall} $w create line 217 309 217 291 -fill $color -tags {floor1 wall} $w create line 217 309 172 309 -fill $color -tags {floor1 wall} $w create line 154 309 148 309 -fill $color -tags {floor1 wall} $w create line 175 300 175 309 -fill $color -tags {floor1 wall} $w create line 151 300 175 300 -fill $color -tags {floor1 wall} $w create line 151 247 151 309 -fill $color -tags {floor1 wall} $w create line 78 237 78 265 -fill $color -tags {floor1 wall} $w create line 78 286 78 309 -fill $color -tags {floor1 wall} $w create line 106 309 78 309 -fill $color -tags {floor1 wall} $w create line 130 309 125 309 -fill $color -tags {floor1 wall} $w create line 99 309 99 247 -fill $color -tags {floor1 wall} $w create line 127 299 99 299 -fill $color -tags {floor1 wall} $w create line 127 309 127 299 -fill $color -tags {floor1 wall} $w create line 155 191 137 191 -fill $color -tags {floor1 wall} $w create line 137 169 137 191 -fill $color -tags {floor1 wall} $w create line 78 171 78 169 -fill $color -tags {floor1 wall} $w create line 78 190 78 218 -fill $color -tags {floor1 wall} $w create line 86 192 86 169 -fill $color -tags {floor1 wall} $w create line 86 192 78 192 -fill $color -tags {floor1 wall} $w create line 52 301 3 301 -fill $color -tags {floor1 wall} $w create line 52 286 52 301 -fill $color -tags {floor1 wall} $w create line 52 252 3 252 -fill $color -tags {floor1 wall} $w create line 52 203 3 203 -fill $color -tags {floor1 wall} $w create line 3 156 52 156 -fill $color -tags {floor1 wall} $w create line 8 25 8 114 -fill $color -tags {floor1 wall} $w create line 63 114 3 114 -fill $color -tags {floor1 wall} $w create line 75 114 97 114 -fill $color -tags {floor1 wall} $w create line 108 114 129 114 -fill $color -tags {floor1 wall} $w create line 129 114 129 89 -fill $color -tags {floor1 wall} $w create line 52 114 52 128 -fill $color -tags {floor1 wall} $w create line 132 89 88 89 -fill $color -tags {floor1 wall} $w create line 88 25 88 89 -fill $color -tags {floor1 wall} $w create line 88 114 88 89 -fill $color -tags {floor1 wall} $w create line 218 89 144 89 -fill $color -tags {floor1 wall} $w create line 147 111 147 129 -fill $color -tags {floor1 wall} $w create line 162 111 147 111 -fill $color -tags {floor1 wall} $w create line 162 109 162 111 -fill $color -tags {floor1 wall} $w create line 162 96 162 89 -fill $color -tags {floor1 wall} $w create line 218 89 218 94 -fill $color -tags {floor1 wall} $w create line 218 89 218 119 -fill $color -tags {floor1 wall} $w create line 8 25 88 25 -fill $color -tags {floor1 wall} $w create line 258 337 258 328 -fill $color -tags {floor1 wall} $w create line 113 129 96 129 -fill $color -tags {floor1 wall} $w create line 302 355 258 355 -fill $color -tags {floor1 wall} $w create line 386 104 386 129 -fill $color -tags {floor1 wall} $w create line 377 100 386 104 -fill $color -tags {floor1 wall} $w create line 365 94 377 100 -fill $color -tags {floor1 wall} $w create line 350 83 365 94 -fill $color -tags {floor1 wall} $w create line 337 70 350 83 -fill $color -tags {floor1 wall} $w create line 337 70 323 56 -fill $color -tags {floor1 wall} $w create line 312 49 323 56 -fill $color -tags {floor1 wall} $w create line 295 40 312 49 -fill $color -tags {floor1 wall} $w create line 282 37 295 40 -fill $color -tags {floor1 wall} $w create line 260 34 282 37 -fill $color -tags {floor1 wall} $w create line 253 34 260 34 -fill $color -tags {floor1 wall} $w create line 386 128 386 104 -fill $color -tags {floor1 wall} $w create line 113 152 156 152 -fill $color -tags {floor1 wall} $w create line 113 152 156 152 -fill $color -tags {floor1 wall} $w create line 113 152 113 129 -fill $color -tags {floor1 wall} } proc fg2 {w color} { global floorLabels floorItems set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] set floorLabels($i) 238 set {floorItems(238)} $i $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] set floorLabels($i) 237 set {floorItems(237)} $i $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] set floorLabels($i) 246 set {floorItems(246)} $i $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] set floorLabels($i) 247 set {floorItems(247)} $i $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] set floorLabels($i) 202 set {floorItems(202)} $i $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] set floorLabels($i) 206 set {floorItems(206)} $i $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] set floorLabels($i) 212 set {floorItems(212)} $i $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] set floorLabels($i) 245 set {floorItems(245)} $i $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] set floorLabels($i) 244 set {floorItems(244)} $i $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] set floorLabels($i) 243 set {floorItems(243)} $i $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] set floorLabels($i) 242 set {floorItems(242)} $i $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] set floorLabels($i) {Barbecue Deck} set {floorItems(Barbecue Deck)} $i $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] set floorLabels($i) 240 set {floorItems(240)} $i $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] set floorLabels($i) 241 set {floorItems(241)} $i $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] set floorLabels($i) 239 set {floorItems(239)} $i $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] set floorLabels($i) 248 set {floorItems(248)} $i $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] set floorLabels($i) 236 set {floorItems(236)} $i $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] set floorLabels($i) 235 set {floorItems(235)} $i $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] set floorLabels($i) 234 set {floorItems(234)} $i $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] set floorLabels($i) 233 set {floorItems(233)} $i $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] set floorLabels($i) 230 set {floorItems(230)} $i $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] set floorLabels($i) 232 set {floorItems(232)} $i $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] set floorLabels($i) 229 set {floorItems(229)} $i $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] set floorLabels($i) 227 set {floorItems(227)} $i $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] set floorLabels($i) 228 set {floorItems(228)} $i $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] set floorLabels($i) 226 set {floorItems(226)} $i $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] set floorLabels($i) 225 set {floorItems(225)} $i $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] set floorLabels($i) 224 set {floorItems(224)} $i $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] set floorLabels($i) 223 set {floorItems(223)} $i $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] set floorLabels($i) 222 set {floorItems(222)} $i $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] set floorLabels($i) 221 set {floorItems(221)} $i $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] set floorLabels($i) 204 set {floorItems(204)} $i $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] set floorLabels($i) 205 set {floorItems(205)} $i $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] set floorLabels($i) 207 set {floorItems(207)} $i $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] set floorLabels($i) 208 set {floorItems(208)} $i $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] set floorLabels($i) 209 set {floorItems(209)} $i $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] set floorLabels($i) 217 set {floorItems(217)} $i $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] set floorLabels($i) 217A set {floorItems(217A)} $i $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] set floorLabels($i) 216 set {floorItems(216)} $i $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] set floorLabels($i) 215 set {floorItems(215)} $i $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] set floorLabels($i) 214 set {floorItems(214)} $i $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] set floorLabels($i) 213 set {floorItems(213)} $i $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] set floorLabels($i) 210 set {floorItems(210)} $i $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] set floorLabels($i) 211 set {floorItems(211)} $i $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] set floorLabels($i) 203 set {floorItems(203)} $i $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] set floorLabels($i) 220 set {floorItems(220)} $i $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] set floorLabels($i) {Priv Lift2} set {floorItems(Priv Lift2)} $i $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] set floorLabels($i) {Pub Lift 2} set {floorItems(Pub Lift 2)} $i $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] set floorLabels($i) 218 set {floorItems(218)} $i $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] set floorLabels($i) 219 set {floorItems(219)} $i $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] set floorLabels($i) 201 set {floorItems(201)} $i $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} $w create line 641 186 678 186 -fill $color -tags {floor2 wall} $w create line 757 350 757 367 -fill $color -tags {floor2 wall} $w create line 634 133 634 144 -fill $color -tags {floor2 wall} $w create line 634 144 627 144 -fill $color -tags {floor2 wall} $w create line 572 133 572 144 -fill $color -tags {floor2 wall} $w create line 572 144 579 144 -fill $color -tags {floor2 wall} $w create line 398 129 398 162 -fill $color -tags {floor2 wall} $w create line 174 197 175 197 -fill $color -tags {floor2 wall} $w create line 175 197 175 227 -fill $color -tags {floor2 wall} $w create line 757 206 757 221 -fill $color -tags {floor2 wall} $w create line 396 188 408 188 -fill $color -tags {floor2 wall} $w create line 727 189 725 189 -fill $color -tags {floor2 wall} $w create line 747 167 802 167 -fill $color -tags {floor2 wall} $w create line 747 167 747 189 -fill $color -tags {floor2 wall} $w create line 755 189 739 189 -fill $color -tags {floor2 wall} $w create line 769 224 757 224 -fill $color -tags {floor2 wall} $w create line 802 224 802 129 -fill $color -tags {floor2 wall} $w create line 802 129 725 129 -fill $color -tags {floor2 wall} $w create line 725 189 725 129 -fill $color -tags {floor2 wall} $w create line 725 186 690 186 -fill $color -tags {floor2 wall} $w create line 676 133 676 186 -fill $color -tags {floor2 wall} $w create line 627 144 627 186 -fill $color -tags {floor2 wall} $w create line 629 186 593 186 -fill $color -tags {floor2 wall} $w create line 579 144 579 186 -fill $color -tags {floor2 wall} $w create line 559 129 559 133 -fill $color -tags {floor2 wall} $w create line 725 133 559 133 -fill $color -tags {floor2 wall} $w create line 484 162 484 129 -fill $color -tags {floor2 wall} $w create line 559 129 484 129 -fill $color -tags {floor2 wall} $w create line 526 129 526 186 -fill $color -tags {floor2 wall} $w create line 540 186 581 186 -fill $color -tags {floor2 wall} $w create line 528 186 523 186 -fill $color -tags {floor2 wall} $w create line 511 186 475 186 -fill $color -tags {floor2 wall} $w create line 496 190 496 186 -fill $color -tags {floor2 wall} $w create line 496 205 496 202 -fill $color -tags {floor2 wall} $w create line 475 205 527 205 -fill $color -tags {floor2 wall} $w create line 558 205 539 205 -fill $color -tags {floor2 wall} $w create line 558 205 558 249 -fill $color -tags {floor2 wall} $w create line 558 249 475 249 -fill $color -tags {floor2 wall} $w create line 662 206 642 206 -fill $color -tags {floor2 wall} $w create line 695 206 675 206 -fill $color -tags {floor2 wall} $w create line 695 278 642 278 -fill $color -tags {floor2 wall} $w create line 642 291 642 206 -fill $color -tags {floor2 wall} $w create line 695 291 695 206 -fill $color -tags {floor2 wall} $w create line 716 208 716 206 -fill $color -tags {floor2 wall} $w create line 757 206 716 206 -fill $color -tags {floor2 wall} $w create line 757 221 757 224 -fill $color -tags {floor2 wall} $w create line 793 224 802 224 -fill $color -tags {floor2 wall} $w create line 757 262 716 262 -fill $color -tags {floor2 wall} $w create line 716 220 716 264 -fill $color -tags {floor2 wall} $w create line 716 315 716 276 -fill $color -tags {floor2 wall} $w create line 757 315 703 315 -fill $color -tags {floor2 wall} $w create line 757 325 757 224 -fill $color -tags {floor2 wall} $w create line 757 367 644 367 -fill $color -tags {floor2 wall} $w create line 689 367 689 315 -fill $color -tags {floor2 wall} $w create line 647 315 644 315 -fill $color -tags {floor2 wall} $w create line 659 315 691 315 -fill $color -tags {floor2 wall} $w create line 600 325 600 391 -fill $color -tags {floor2 wall} $w create line 627 325 644 325 -fill $color -tags {floor2 wall} $w create line 644 391 644 315 -fill $color -tags {floor2 wall} $w create line 615 325 575 325 -fill $color -tags {floor2 wall} $w create line 644 391 558 391 -fill $color -tags {floor2 wall} $w create line 563 325 558 325 -fill $color -tags {floor2 wall} $w create line 558 391 558 314 -fill $color -tags {floor2 wall} $w create line 558 327 508 327 -fill $color -tags {floor2 wall} $w create line 558 275 484 275 -fill $color -tags {floor2 wall} $w create line 558 302 558 275 -fill $color -tags {floor2 wall} $w create line 508 327 508 311 -fill $color -tags {floor2 wall} $w create line 484 311 508 311 -fill $color -tags {floor2 wall} $w create line 484 275 484 311 -fill $color -tags {floor2 wall} $w create line 475 208 408 208 -fill $color -tags {floor2 wall} $w create line 408 206 408 210 -fill $color -tags {floor2 wall} $w create line 408 222 408 227 -fill $color -tags {floor2 wall} $w create line 408 227 398 227 -fill $color -tags {floor2 wall} $w create line 398 227 398 254 -fill $color -tags {floor2 wall} $w create line 408 188 408 194 -fill $color -tags {floor2 wall} $w create line 383 188 376 188 -fill $color -tags {floor2 wall} $w create line 398 188 398 162 -fill $color -tags {floor2 wall} $w create line 398 162 484 162 -fill $color -tags {floor2 wall} $w create line 475 162 475 254 -fill $color -tags {floor2 wall} $w create line 398 254 475 254 -fill $color -tags {floor2 wall} $w create line 484 280 395 280 -fill $color -tags {floor2 wall} $w create line 395 311 395 275 -fill $color -tags {floor2 wall} $w create line 307 197 293 197 -fill $color -tags {floor2 wall} $w create line 278 197 233 197 -fill $color -tags {floor2 wall} $w create line 233 197 233 249 -fill $color -tags {floor2 wall} $w create line 307 179 284 179 -fill $color -tags {floor2 wall} $w create line 233 249 278 249 -fill $color -tags {floor2 wall} $w create line 269 179 269 133 -fill $color -tags {floor2 wall} $w create line 220 179 220 133 -fill $color -tags {floor2 wall} $w create line 155 191 110 191 -fill $color -tags {floor2 wall} $w create line 90 190 98 190 -fill $color -tags {floor2 wall} $w create line 98 169 98 190 -fill $color -tags {floor2 wall} $w create line 52 133 52 165 -fill $color -tags {floor2 wall} $w create line 52 214 52 177 -fill $color -tags {floor2 wall} $w create line 52 226 52 262 -fill $color -tags {floor2 wall} $w create line 52 274 52 276 -fill $color -tags {floor2 wall} $w create line 234 275 234 339 -fill $color -tags {floor2 wall} $w create line 226 339 258 339 -fill $color -tags {floor2 wall} $w create line 211 387 211 339 -fill $color -tags {floor2 wall} $w create line 214 339 177 339 -fill $color -tags {floor2 wall} $w create line 258 387 60 387 -fill $color -tags {floor2 wall} $w create line 3 133 3 339 -fill $color -tags {floor2 wall} $w create line 165 339 129 339 -fill $color -tags {floor2 wall} $w create line 117 339 80 339 -fill $color -tags {floor2 wall} $w create line 68 339 59 339 -fill $color -tags {floor2 wall} $w create line 0 339 46 339 -fill $color -tags {floor2 wall} $w create line 60 391 0 391 -fill $color -tags {floor2 wall} $w create line 0 339 0 391 -fill $color -tags {floor2 wall} $w create line 60 387 60 391 -fill $color -tags {floor2 wall} $w create line 258 329 258 387 -fill $color -tags {floor2 wall} $w create line 350 329 258 329 -fill $color -tags {floor2 wall} $w create line 395 311 350 311 -fill $color -tags {floor2 wall} $w create line 398 129 315 129 -fill $color -tags {floor2 wall} $w create line 176 133 315 133 -fill $color -tags {floor2 wall} $w create line 176 129 96 129 -fill $color -tags {floor2 wall} $w create line 3 133 96 133 -fill $color -tags {floor2 wall} $w create line 66 387 66 339 -fill $color -tags {floor2 wall} $w create line 115 387 115 339 -fill $color -tags {floor2 wall} $w create line 163 387 163 339 -fill $color -tags {floor2 wall} $w create line 234 275 276 275 -fill $color -tags {floor2 wall} $w create line 288 275 309 275 -fill $color -tags {floor2 wall} $w create line 298 275 298 329 -fill $color -tags {floor2 wall} $w create line 341 283 350 283 -fill $color -tags {floor2 wall} $w create line 321 275 341 275 -fill $color -tags {floor2 wall} $w create line 375 275 395 275 -fill $color -tags {floor2 wall} $w create line 315 129 315 170 -fill $color -tags {floor2 wall} $w create line 376 170 307 170 -fill $color -tags {floor2 wall} $w create line 307 250 307 170 -fill $color -tags {floor2 wall} $w create line 376 245 376 170 -fill $color -tags {floor2 wall} $w create line 340 241 307 241 -fill $color -tags {floor2 wall} $w create line 340 245 340 224 -fill $color -tags {floor2 wall} $w create line 340 210 340 201 -fill $color -tags {floor2 wall} $w create line 340 187 340 170 -fill $color -tags {floor2 wall} $w create line 340 206 307 206 -fill $color -tags {floor2 wall} $w create line 293 250 307 250 -fill $color -tags {floor2 wall} $w create line 271 179 238 179 -fill $color -tags {floor2 wall} $w create line 226 179 195 179 -fill $color -tags {floor2 wall} $w create line 176 129 176 179 -fill $color -tags {floor2 wall} $w create line 182 179 176 179 -fill $color -tags {floor2 wall} $w create line 174 169 176 169 -fill $color -tags {floor2 wall} $w create line 162 169 90 169 -fill $color -tags {floor2 wall} $w create line 96 169 96 129 -fill $color -tags {floor2 wall} $w create line 175 227 90 227 -fill $color -tags {floor2 wall} $w create line 90 190 90 227 -fill $color -tags {floor2 wall} $w create line 52 179 3 179 -fill $color -tags {floor2 wall} $w create line 52 228 3 228 -fill $color -tags {floor2 wall} $w create line 52 276 3 276 -fill $color -tags {floor2 wall} $w create line 155 177 155 169 -fill $color -tags {floor2 wall} $w create line 110 191 110 169 -fill $color -tags {floor2 wall} $w create line 155 189 155 197 -fill $color -tags {floor2 wall} $w create line 350 283 350 329 -fill $color -tags {floor2 wall} $w create line 162 197 155 197 -fill $color -tags {floor2 wall} $w create line 341 275 341 283 -fill $color -tags {floor2 wall} } proc fg3 {w color} { global floorLabels floorItems set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] set floorLabels($i) 316 set {floorItems(316)} $i $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] set floorLabels($i) 309 set {floorItems(309)} $i $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] set floorLabels($i) 308 set {floorItems(308)} $i $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] set floorLabels($i) 307 set {floorItems(307)} $i $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] set floorLabels($i) 305 set {floorItems(305)} $i $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] set floorLabels($i) 324B set {floorItems(324B)} $i $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] set floorLabels($i) 324A set {floorItems(324A)} $i $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] set floorLabels($i) 320 set {floorItems(320)} $i $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] set floorLabels($i) 310 set {floorItems(310)} $i $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] set floorLabels($i) 312 set {floorItems(312)} $i $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] set floorLabels($i) 313 set {floorItems(313)} $i $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] set floorLabels($i) 314 set {floorItems(314)} $i $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] set floorLabels($i) 315 set {floorItems(315)} $i $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] set floorLabels($i) 316B set {floorItems(316B)} $i $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] set floorLabels($i) 316A set {floorItems(316A)} $i $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] set floorLabels($i) 319 set {floorItems(319)} $i $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] set floorLabels($i) 311 set {floorItems(311)} $i $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] set floorLabels($i) 318 set {floorItems(318)} $i $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] set floorLabels($i) 317 set {floorItems(317)} $i $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] set floorLabels($i) 323 set {floorItems(323)} $i $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] set floorLabels($i) 325 set {floorItems(325)} $i $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] set floorLabels($i) 321 set {floorItems(321)} $i $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] set floorLabels($i) 322 set {floorItems(322)} $i $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] set floorLabels($i) {Pub Lift3} set {floorItems(Pub Lift3)} $i $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] set floorLabels($i) {Priv Lift3} set {floorItems(Priv Lift3)} $i $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] set floorLabels($i) 303 set {floorItems(303)} $i $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] set floorLabels($i) 324 set {floorItems(324)} $i $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] set floorLabels($i) 304 set {floorItems(304)} $i $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] set floorLabels($i) 301 set {floorItems(301)} $i $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] set floorLabels($i) 327 set {floorItems(327)} $i $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] set floorLabels($i) 326 set {floorItems(326)} $i $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] set floorLabels($i) 302 set {floorItems(302)} $i $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] set floorLabels($i) 306 set {floorItems(306)} $i $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} $w create line 341 275 341 283 -fill $color -tags {floor3 wall} $w create line 162 197 155 197 -fill $color -tags {floor3 wall} $w create line 396 247 399 247 -fill $color -tags {floor3 wall} $w create line 399 129 399 311 -fill $color -tags {floor3 wall} $w create line 258 202 243 202 -fill $color -tags {floor3 wall} $w create line 350 283 350 329 -fill $color -tags {floor3 wall} $w create line 251 231 243 231 -fill $color -tags {floor3 wall} $w create line 243 220 251 220 -fill $color -tags {floor3 wall} $w create line 243 250 243 202 -fill $color -tags {floor3 wall} $w create line 155 197 155 190 -fill $color -tags {floor3 wall} $w create line 110 192 110 169 -fill $color -tags {floor3 wall} $w create line 155 192 110 192 -fill $color -tags {floor3 wall} $w create line 155 177 155 169 -fill $color -tags {floor3 wall} $w create line 176 197 176 227 -fill $color -tags {floor3 wall} $w create line 69 280 69 274 -fill $color -tags {floor3 wall} $w create line 21 276 69 276 -fill $color -tags {floor3 wall} $w create line 69 262 69 226 -fill $color -tags {floor3 wall} $w create line 21 228 69 228 -fill $color -tags {floor3 wall} $w create line 21 179 75 179 -fill $color -tags {floor3 wall} $w create line 69 179 69 214 -fill $color -tags {floor3 wall} $w create line 90 220 90 227 -fill $color -tags {floor3 wall} $w create line 90 204 90 202 -fill $color -tags {floor3 wall} $w create line 90 203 100 203 -fill $color -tags {floor3 wall} $w create line 90 187 90 179 -fill $color -tags {floor3 wall} $w create line 90 227 176 227 -fill $color -tags {floor3 wall} $w create line 100 179 100 227 -fill $color -tags {floor3 wall} $w create line 100 179 87 179 -fill $color -tags {floor3 wall} $w create line 96 179 96 129 -fill $color -tags {floor3 wall} $w create line 162 169 96 169 -fill $color -tags {floor3 wall} $w create line 173 169 176 169 -fill $color -tags {floor3 wall} $w create line 182 179 176 179 -fill $color -tags {floor3 wall} $w create line 176 129 176 179 -fill $color -tags {floor3 wall} $w create line 195 179 226 179 -fill $color -tags {floor3 wall} $w create line 224 133 224 179 -fill $color -tags {floor3 wall} $w create line 264 179 264 133 -fill $color -tags {floor3 wall} $w create line 238 179 264 179 -fill $color -tags {floor3 wall} $w create line 273 207 273 193 -fill $color -tags {floor3 wall} $w create line 273 235 273 250 -fill $color -tags {floor3 wall} $w create line 273 224 273 219 -fill $color -tags {floor3 wall} $w create line 273 193 307 193 -fill $color -tags {floor3 wall} $w create line 273 222 307 222 -fill $color -tags {floor3 wall} $w create line 273 250 307 250 -fill $color -tags {floor3 wall} $w create line 384 247 376 247 -fill $color -tags {floor3 wall} $w create line 340 206 307 206 -fill $color -tags {floor3 wall} $w create line 340 187 340 170 -fill $color -tags {floor3 wall} $w create line 340 210 340 201 -fill $color -tags {floor3 wall} $w create line 340 247 340 224 -fill $color -tags {floor3 wall} $w create line 340 241 307 241 -fill $color -tags {floor3 wall} $w create line 376 247 376 170 -fill $color -tags {floor3 wall} $w create line 307 250 307 170 -fill $color -tags {floor3 wall} $w create line 376 170 307 170 -fill $color -tags {floor3 wall} $w create line 315 129 315 170 -fill $color -tags {floor3 wall} $w create line 376 283 366 283 -fill $color -tags {floor3 wall} $w create line 376 283 376 275 -fill $color -tags {floor3 wall} $w create line 399 275 376 275 -fill $color -tags {floor3 wall} $w create line 341 275 320 275 -fill $color -tags {floor3 wall} $w create line 341 283 350 283 -fill $color -tags {floor3 wall} $w create line 298 275 298 329 -fill $color -tags {floor3 wall} $w create line 308 275 298 275 -fill $color -tags {floor3 wall} $w create line 243 322 243 275 -fill $color -tags {floor3 wall} $w create line 243 275 284 275 -fill $color -tags {floor3 wall} $w create line 258 322 226 322 -fill $color -tags {floor3 wall} $w create line 212 370 212 322 -fill $color -tags {floor3 wall} $w create line 214 322 177 322 -fill $color -tags {floor3 wall} $w create line 163 370 163 322 -fill $color -tags {floor3 wall} $w create line 165 322 129 322 -fill $color -tags {floor3 wall} $w create line 84 322 117 322 -fill $color -tags {floor3 wall} $w create line 71 322 64 322 -fill $color -tags {floor3 wall} $w create line 115 322 115 370 -fill $color -tags {floor3 wall} $w create line 66 322 66 370 -fill $color -tags {floor3 wall} $w create line 52 322 21 322 -fill $color -tags {floor3 wall} $w create line 21 331 0 331 -fill $color -tags {floor3 wall} $w create line 21 331 21 133 -fill $color -tags {floor3 wall} $w create line 96 133 21 133 -fill $color -tags {floor3 wall} $w create line 176 129 96 129 -fill $color -tags {floor3 wall} $w create line 315 133 176 133 -fill $color -tags {floor3 wall} $w create line 315 129 399 129 -fill $color -tags {floor3 wall} $w create line 399 311 350 311 -fill $color -tags {floor3 wall} $w create line 350 329 258 329 -fill $color -tags {floor3 wall} $w create line 258 322 258 370 -fill $color -tags {floor3 wall} $w create line 60 370 258 370 -fill $color -tags {floor3 wall} $w create line 60 370 60 391 -fill $color -tags {floor3 wall} $w create line 0 391 0 331 -fill $color -tags {floor3 wall} $w create line 60 391 0 391 -fill $color -tags {floor3 wall} $w create line 307 250 307 242 -fill $color -tags {floor3 wall} $w create line 273 250 307 250 -fill $color -tags {floor3 wall} $w create line 258 250 243 250 -fill $color -tags {floor3 wall} } gcl-2.6.14/gcl-tk/demos/mkRadio.lisp0000755000175000017500000000577314360276512015561 0ustar cammcamm(in-package "TK") ;;# mkRadio w ;; ;; Create a top-level window that displays a bunch of radio buttons. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkRadio (&optional (w '.r1)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Radiobutton Demonstration") (wm :iconname w "Radiobuttons") (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (frame (conc w '.frame2)) (pack (conc w '.msg) :side "top") (pack (conc w '.msg) :side "top") (pack (conc w '.frame) :side "top" :fill "x" :pady 10) (pack (conc w '.frame2) :side "bottom" :fill "x") (frame (conc w '.frame.left)) (frame (conc w '.frame.right)) (pack (conc w '.frame.left) (conc w '.frame.right) :side "left" :expand "yes") (radiobutton (conc w '.frame.left.b1) :text "Point Size 10" :variable 'size :relief "flat" :value 10) (radiobutton (conc w '.frame.left.b2) :text "Point Size 12" :variable 'size :relief "flat" :value 12) (radiobutton (conc w '.frame.left.b3) :text "Point Size 18" :variable 'size :relief "flat" :value 18) (radiobutton (conc w '.frame.left.b4) :text "Point Size 24" :variable 'size :relief "flat" :value 24) (pack (conc w '.frame.left.b1) (conc w '.frame.left.b2) (conc w '.frame.left.b3) (conc w '.frame.left.b4) :side "top" :pady 2 :anchor "w") (radiobutton (conc w '.frame.right.b1) :text "Red" :variable 'color :relief "flat" :value "red") (radiobutton (conc w '.frame.right.b2) :text "Green" :variable 'color :relief "flat" :value "green") (radiobutton (conc w '.frame.right.b3) :text "Blue" :variable 'color :relief "flat" :value "blue") (radiobutton (conc w '.frame.right.b4) :text "Yellow" :variable 'color :relief "flat" :value "yellow") (radiobutton (conc w '.frame.right.b5) :text "Orange" :variable 'color :relief "flat" :value "orange") (radiobutton (conc w '.frame.right.b6) :text "Purple" :variable 'color :relief "flat" :value "purple") (pack (conc w '.frame.right.b1) (conc w '.frame.right.b2) (conc w '.frame.right.b3) (conc w '.frame.right.b4) (conc w '.frame.right.b5) (conc w '.frame.right.b6) :side "top" :pady 2 :anchor "w") (button (conc w '.frame2.ok) :text "OK" :command (tk-conc "destroy " w) :width 12) (button (conc w '.frame2.vars) :text "See Variables" :width 12 :command `(showvars (conc ',w '.dialog) '(size color))) (pack (conc w '.frame2.ok) (conc w '.frame2.vars) :side "left" :expand "yes" :fill "x") ) gcl-2.6.14/gcl-tk/demos/widget.lisp0000755000175000017500000002440414360276512015446 0ustar cammcamm (in-package "TK") ;; ;; This "script" demonstrates the various widgets provided by Tk, ;; along with many of the features of the Tk toolkit. This file ;; only contains code to generate the main window for the ;; application, which invokes individual demonstrations. The ;; code for the actual demonstrations is contained in separate ;; ".tcl" files is this directory, which are auto-loaded by Tcl ;; when they are needed. To find the code for a particular ;; demo, look below for the procedure that's invoked by its menu ;; entry, then grep for the file that contains the procedure ;; definition. (tk-do (concatenate 'string "set auto_path \"" *tk-library* "/demos " "$auto_path\"")) ;; add teh current path to the auto_path so that we find the ;; .tcl demos for older demos not in new releases.. (tk-do (concatenate 'string "lappend auto_path [file dirname " (namestring (truename si::*load-pathname*)) "]")) ;(setq si::*load-path* (cons (tk-conc si::*lib-directory* "gcl-tk/demos/") si::*load-path*)) (load (merge-pathnames "index.lsp" si::*load-pathname*)) (wm :title '|.| "Widget Demonstration") ;;------------------------------------------------------- ;; The code below create the main window, consisting of a ;; menu bar and a message explaining the basic operation ;; of the program. ;;------------------------------------------------------- (frame '.menu :relief "raised" :borderwidth 1) (message '.msg :font :Adobe-times-medium-r-normal--*-180* :relief "raised" :width 500 :borderwidth 1 :text "This application demonstrates the widgets provided by the GCL Tk toolkit. The menus above are organized by widget type: each menu contains one or more demonstrations of a particular type of widget. To invoke a demonstration, press mouse button 1 over one of the menu buttons above, drag the mouse to the desired entry in the menu, then release the mouse button.) (To exit this demonstration, invoke the \"Quit\" entry in the \"Misc\" menu.") (pack '.menu :side "top" :fill "x") (pack '.msg :side "bottom" :expand "yes" :fill "both") ;;------------------------------------------------------- ;; The code below creates all the menus, which invoke procedures ;; to create particular demonstrations of various widgets. ;;------------------------------------------------------- (menubutton '.menu.button :text "Labels/Buttons" :menu '.menu.button.m :underline 7) (menu '.menu.button.m) (.menu.button.m :add 'command :label "Labels" :command "mkLabel" :underline 0) (.menu.button.m :add 'command :label "Buttons" :command "mkButton" :underline 0) (.menu.button.m :add 'command :label "Checkbuttons" :command "mkCheck" :underline 0) (.menu.button.m :add 'command :label "Radiobuttons" :command 'mkRadio :underline 0) (.menu.button.m :add 'command :label "15-puzzle" :command "mkPuzzle" :underline 0) (.menu.button.m :add 'command :label "Iconic buttons" :command "mkIcon" :underline 0) (menubutton '.menu.listbox :text "Listboxes" :menu '.menu.listbox.m :underline 0) (menu '.menu.listbox.m) (.menu.listbox.m :add 'command :label "States" :command 'mkListbox :underline 0) (.menu.listbox.m :add 'command :label "Colors" :command "mkListbox2" :underline 0) (.menu.listbox.m :add 'command :label "Well-known sayings" :command "mkListbox3" :underline 0) (menubutton '.menu.entry :text "Entries" :menu '.menu.entry.m :underline 0) (menu '.menu.entry.m) (.menu.entry.m :add 'command :label "Without scrollbars" :command 'mkentry :underline 4) (.menu.entry.m :add 'command :label "With scrollbars" :command 'mkEntry2 :underline 0) (.menu.entry.m :add 'command :label "Simple form" :command 'mkForm :underline 0) (menubutton '.menu.text :text "Text" :menu '.menu.text.m :underline 0) (menu '.menu.text.m) (.menu.text.m :add 'command :label "Basic text" :command 'mkBasic :underline 0) (.menu.text.m :add 'command :label "Display styles" :command 'mkStyles :underline 0) (.menu.text.m :add 'command :label "Command bindings" :command 'mkTextBind :underline 0) (.menu.text.m :add 'command :label "Search" :command "mkTextSearch" :underline 0) (menubutton '.menu.scroll :text "Scrollbars" :menu '.menu.scroll.m :underline 0) (menu '.menu.scroll.m) (.menu.scroll.m :add 'command :label "Vertical" :command "mkListbox2" :underline 0) (.menu.scroll.m :add 'command :label "Horizontal" :command "mkEntry2" :underline 0) (menubutton '.menu.scale :text "Scales" :menu '.menu.scale.m :underline 2) (menu '.menu.scale.m) (.menu.scale.m :add 'command :label "Vertical" :command 'mkVScale :underline 0) (.menu.scale.m :add 'command :label "Horizontal" :command 'mkHScale :underline 0) (menubutton '.menu.canvas :text "Canvases" :menu '.menu.canvas.m :underline 0) (menu '.menu.canvas.m) (.menu.canvas.m :add 'command :label "Item types" :command 'mkItems :underline 0) (.menu.canvas.m :add 'command :label "2-D plot" :command 'mkPlot :underline 0) (.menu.canvas.m :add 'command :label "Text" :command "mkCanvText" :underline 0) (.menu.canvas.m :add 'command :label "Arrow shapes" :command "mkArrow" :underline 0) (.menu.canvas.m :add 'command :label "Ruler" :command 'mkRuler :underline 0) (.menu.canvas.m :add 'command :label "Scrollable canvas" :command "mkScroll" :underline 0) (.menu.canvas.m :add 'command :label "Floor plan" :command "mkFloor" :underline 0) (menubutton '.menu.menu :text "Menus" :menu '.menu.menu.m :underline 0) (menu '.menu.menu.m) (.menu.menu.m :add 'command :label "Print hello" :command '(print "Hello") :accelerator "Control+a" :underline 6) (bind '|.| "" '(print "Hello")) (.menu.menu.m :add 'command :label "Print goodbye" :command '(print "Goodbye") :accelerator "Control+b" :underline 6) (bind '|.| "" '(format t "Goodbye")) (.menu.menu.m :add 'command :label "Light blue background" :command '(.msg :configure :bg "LightBlue1") :underline 0) (.menu.menu.m :add 'command :label "Info on tear-off menus" :command "mkTear" :underline 0) (.menu.menu.m :add 'cascade :label "Check buttons" :menu '.menu.menu.m.check :underline 0) (.menu.menu.m :add 'cascade :label "Radio buttons" :menu '.menu.menu.m.radio :underline 0) (.menu.menu.m :add 'command :bitmap "@": *tk-library* :"/demos/bitmaps/pattern" :command ' (mkDialog '.pattern '(:text "The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry." :aspect 250 ))) (menu '.menu.menu.m.check) (.menu.menu.m.check :add 'check :label "Oil checked" :variable 'oil) (.menu.menu.m.check :add 'check :label "Transmission checked" :variable 'trans) (.menu.menu.m.check :add 'check :label "Brakes checked" :variable 'brakes) (.menu.menu.m.check :add 'check :label "Lights checked" :variable 'lights) (.menu.menu.m.check :add 'separator) (.menu.menu.m.check :add 'command :label "Show current values" :command '(showVars '.menu.menu.dialog '(oil trans brakes lights))) (.menu.menu.m.check :invoke 1) (.menu.menu.m.check :invoke 3) (menu '.menu.menu.m.radio) (.menu.menu.m.radio :add 'radio :label "10 point" :variable 'pointSize :value 10) (.menu.menu.m.radio :add 'radio :label "14 point" :variable 'pointSize :value 14) (.menu.menu.m.radio :add 'radio :label "18 point" :variable 'pointSize :value 18) (.menu.menu.m.radio :add 'radio :label "24 point" :variable 'pointSize :value 24) (.menu.menu.m.radio :add 'radio :label "32 point" :variable 'pointSize :value 32) (.menu.menu.m.radio :add 'sep) (.menu.menu.m.radio :add 'radio :label "Roman" :variable 'style :value "roman") (.menu.menu.m.radio :add 'radio :label "Bold" :variable 'style :value "bold") (.menu.menu.m.radio :add 'radio :label "Italic" :variable 'style :value "italic") (.menu.menu.m.radio :add 'sep) (.menu.menu.m.radio :add 'command :label "Show current values" :command '(showVars '.menu.menu.dialog '(pointSize style))) (.menu.menu.m.radio :invoke 1) (.menu.menu.m.radio :invoke 7) (menubutton '.menu.misc :text "Misc" :menu '.menu.misc.m :underline 1) (menu '.menu.misc.m) (.menu.misc.m :add 'command :label "Modal dialog (local grab)" :command ' (progn (mkDialog '.modal '(:text "This dialog box is a modal one. It uses Tk's \"grab\" command to create a \"local grab\" on the dialog box. The grab prevents any pointer related events from getting to any other windows in the application. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi"))) (wm :geometry '.modal "+10+10") (tk-wait-til-exists '.modal) ; (tkwait :visibility '.modal) (grab '.modal) (tkwait :window '.modal) ) :underline 0) (.menu.misc.m :add 'command :label "Modal dialog (global grab)" :command '(progn (mkDialog '.modal '(:text "This is another modal dialog box. However, in this case a \"global grab\" is used, which locks up the display so you can't talk to any windows in any applications anywhere, except for the dialog. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi1"))) (wm :geometry '.modal "+10+10") (tk-wait-til-exists '.modal) ;(tkwait :visibility '.modal) (grab :set :global '.modal) (tkwait :window '.modal) ) :underline 0) (.menu.misc.m :add 'command :label "Built-in bitmaps" :command "mkBitmaps" :underline 0) (.menu.misc.m :add 'command :label "GC monitor" :command 'mkgcmonitor :underline 0) (.menu.misc.m :add 'command :label "Quit" :command "destroy ." :underline 0) (pack '.menu.button '.menu.listbox '.menu.entry '.menu.text '.menu.scroll '.menu.scale '.menu.canvas '.menu.menu '.menu.misc :side "left") ;; Set up for keyboard-based menu traversal (bind '|.| "" '(progn (if (and (equal |%d| "NotifyVirtual") (equal |%m| "NotifyNormal")) (focus '.menu) ))) ;; make the meta key do traversal bindings (bind '.menu "" "tk_traverseToMenu %W %A") (tk-menu-bar '.menu '.menu.button '.menu.listbox '.menu.entry '.menu.text '.menu.scroll '.menu.scale '.menu.canvas '.menu.menu '.menu.misc) ;; Position a dialog box at a reasonable place on the screen. (defun dpos (w) (wm :geometry w "+60+25") ) ;; some of the widgets are tcl and need this. (tk-do "proc dpos w { wm geometry $w +300+300 }") gcl-2.6.14/gcl-tk/demos/mkBasic.lisp0000755000175000017500000000535314360276512015536 0ustar cammcamm;;# mkBasic w ;; ;; Create a top-level window that displays a basic text widget. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *basic-message* " This window is a text widget. It displays one or more lines of text and allows you to edit the text. Here is a summary of the things you can do to a text widget: 1. Scrolling. Use the scrollbar to adjust the view in the text window. 2. Scanning. Press mouse button 2 in the text window and drag up or down. This will drag the text at high speed to allow you to scan its contents. 3. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. You can backspace over what you've typed using either the backspace key, the delete key, or Control+h. 4. Select. Press mouse button 1 and drag to select a range of characters. Once you've released the button, you can adjust the selection by pressing button 1 with the shift key down. This will reset the end of the selection nearest the mouse cursor and you can drag that end of the selection by dragging the mouse before releasing the mouse button. You can double-click to select whole words, or triple-click to select whole lines. 5. Delete. To delete text, select the characters you'd like to delete and type Control+d. 6. Copy the selection. To copy the selection either from this window or from any other window or application, select what you want, click button 1 to set the insertion cursor, then type Control+v to copy the selection to the point of the insertion cursor. 7. Resize the window. This widget has been configured with the \"setGrid\" option on, so that if you resize the window it will always resize to an even number of characters high and wide. Also, if you make the window narrow you can see that long lines automatically wrap around onto additional lines so that all the information is always visible. When you're finished with this demonstration, press the \"OK\" button below.") (defun mkBasic (&optional (w '.basic)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Basic Facilities") (wm :iconname w "Text Basics") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text (conc w '.t) :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true") (pack (conc w '.ok) :side 'bottom :fill "x") (pack (conc w '.s) :side 'right :fill "y") (pack (conc w '.t) :expand 'yes :fill 'both) (funcall (conc w '.t) :insert 0.0 *basic-message*) (funcall (conc w '.t) :mark 'set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) gcl-2.6.14/gcl-tk/demos/mkTextBind.lisp0000755000175000017500000001005014360276512016224 0ustar cammcamm;;# mkTextBind w ;; ;; Create a top-level window that illustrates how you can bind ;; Tcl commands to regions of text in a text widget. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkTextBind (&optional (w '.bindings) &aux bold normal (textwin (conc w '.t ) )) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Text Demonstration - Tag Bindings") (wm :iconname w "Text Bindings") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true" :width 60 :height 28 :font "-Adobe-Helvetica-Bold-R-Normal-*-120-*") (pack (conc w '.ok) :side "bottom" :fill "x") (pack (conc w '.s) :side "right" :fill "y") (pack textwin :expand "yes" :fill "both") ;; Set up display styles (if (> (read-from-string (winfo :depth w)) 1) (progn (setq bold '(:foreground "red")) (setq normal '(:foreground "")) );;else (progn (setq bold '(:foreground "white" :background "black")) (setq normal '(:foreground "" :background "")) )) (funcall textwin :insert 0.0 "The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 3 over a description then that particular demonstration is invoked. This demo package contains a number of demonstrations of Tk's canvas widgets. Here are brief descriptions of some of the demonstrations that are available: " ) (let ((blank-lines (format nil "~2%"))) (insertWithTags textwin "1. Samples of all the different types of items that can be created in canvas widgets." "d1") (insertWithTags textwin blank-lines) (insertWithTags textwin "2. A simple two-dimensional plot that allows you to adjust the :positions of the data points." "d2") (insertWithTags textwin blank-lines) (insertWithTags textwin "3. Anchoring and justification modes for text items." "d3") (insertWithTags textwin blank-lines) (insertWithTags textwin "4. An editor for arrow-head shapes for line items." "d4") (insertWithTags textwin blank-lines) (insertWithTags textwin "5. A ruler with facilities for editing tab stops." "d5") (insertWithTags textwin blank-lines) (insertWithTags textwin "6. A grid that demonstrates how canvases can be scrolled." "d6")) (dolist (tag '("d1" "d2" "d3" "d4" "d5" "d6")) (funcall textwin :tag :bind tag "" `(,textwin :tag :configure ,tag ,@bold)) (funcall textwin :tag :bind tag "" `(,textwin :tag :configure ,tag ,@normal)) ) (funcall textwin :tag :bind "d1" "<3>" 'mkItems) (funcall textwin :tag :bind "d2" "<3>" 'mkPlot) (funcall textwin :tag :bind "d3" "<3>" "mkCanvText") (funcall textwin :tag :bind "d4" "<3>" "mkArrow") (funcall textwin :tag :bind "d5" "<3>" 'mkRuler) (funcall textwin :tag :bind "d6" "<3>" "mkScroll") (funcall textwin :mark 'set 'insert 0.0) (bind w "" (tk-conc "focus " w ".t")) ) ;; The procedure below inserts text into a given text widget and ;; applies one or more tags to that text. The arguments are: ;; ;; w Window in which to insert ;; text Text to insert (it's :inserted at the "insert" mark) ;; args One or more tags to apply to text. (if :this is empty ;; then all tags are removed from the text. (defun insertWithTags (w text &rest args) (let (( start (funcall w :index 'insert :return 'string))) (funcall w :insert 'insert text) (dolist (v (funcall w :tag "names" start :return 'list-strings)) (funcall w :tag 'remove v start "insert")) (dolist (i args) (funcall w :tag 'add i start 'insert)))) gcl-2.6.14/gcl-tk/demos/mkIcon.tcl0000755000175000017500000000374114360276512015217 0ustar cammcamm# mkIcon w # # Create a top-level window that displays a bunch of iconic # buttons. # # Arguments: # w - Name to use for new top-level window. proc mkIcon {{w .icon}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Iconic Button Demonstration" wm iconname $w "Icons" label $w.msg -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." pack $w.msg -side top frame $w.buttons pack $w.buttons -side bottom -fill x -pady 2m button $w.buttons.dismiss -text Dismiss -command "destroy $w" pack $w.buttons.dismiss -side left -expand 1 image create bitmap flagup \ -file [file join $tk_library demos images flagup.bmp] \ -maskfile [file join $tk_library demos images flagup.bmp] image create bitmap flagdown \ -file [file join $tk_library demos images flagdown.bmp] \ -maskfile [file join $tk_library demos images flagdown.bmp] frame $w.frame -borderwidth 10 pack $w.frame -side top checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ -indicatoron 0 $w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] checkbutton $w.frame.b2 \ -bitmap @[file join $tk_library demos images letters.bmp] \ -indicatoron 0 -selectcolor SeaGreen1 frame $w.frame.left pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m radiobutton $w.frame.left.b3 \ -bitmap @[file join $tk_library demos images letters.bmp] \ -variable letters -value full radiobutton $w.frame.left.b4 \ -bitmap @[file join $tk_library demos images noletter.bmp] \ -variable letters -value empty pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes } gcl-2.6.14/gcl-tk/demos/mkItems.lisp0000755000175000017500000003532214360276512015575 0ustar cammcamm;;# mkItems w ;; ;; Create a top-level window containing a canvas that displays the ;; various item types and allows them to be selected and moved. This ;; demo can be used to test out the point-hit and rectangle-hit code ;; for items. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defvar *color-display* nil) (defun mkItems (&optional (w '.citems)) (declare (special c tk_library)) (if (winfo :exists w :return 'boolean) (destroy w)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Canvas Item Demonstration") (wm :iconname w "Items") (wm :minsize w 100 100) (setq c (conc w '.frame2.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal--*-180-* :width "13c" :bd 2 :relief "raised" :text #u"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") (frame (conc w '.frame2) :relief "raised" :bd 2) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) :side "top" :fill "x") (pack (conc w '.frame2) :side "top" :fill "both" :expand "yes") (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") (scrollbar (conc w '.frame2.vscroll) :relief "sunken" :command (tk-conc c " yview")) (scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview")) (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" :relief "sunken" :borderwidth 2 :xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set")) (pack (conc w '.frame2.hscroll) :side "bottom" :fill "x") (pack (conc w '.frame2.vscroll) :side "right" :fill "y") (pack c :in (conc w '.frame2) :expand "yes" :fill "both") ;; Display a 3x3 rectangular grid. (funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) (funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) (funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) (funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) (funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) (setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*) (setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*) (if (> (winfo :depth c :return 'number) 1) (progn (setq *color-display* t) (setq blue "DeepSkyBlue3") (setq red "red") (setq bisque "bisque3") (setq green "SeaGreen3")) (progn (setq blue "black") (setq red "black") (setq bisque "black") (setq green "black"))) ;; Set up demos within each of the areas of the grid. (funcall c :create "text" "5c" ".2c" :text "Lines" :anchor "n") (funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue :cap "butt" :join "miter" :tags "item") (funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") (funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") (funcall c :create "line" "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :fill "red" :width 3 :tags "item") (funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" :width ".5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :arrow "both" :arrowshape "15 15 7" :tags "item") (funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" "5.8c" "4c" "7c" :width ".5c" :cap "round" :join "round" :tags "item") (funcall c :create "text" "15c" ".2c" :text "Curves (smoothed :lines)" :anchor "n") (funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" "4c" :smooth "on" :fill blue :tags "item") (funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" "19.5c" "4c" :smooth "on" :arrow "both" :width 3 :tags "item") (funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") (funcall c :create "text" '25c ".2c" :text "Polygons" :anchor "n") (funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" "23.25c" "2.5c" "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" :fill green :tags "item") (funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") (funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") (funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") (funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") (funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") (funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") (funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") (funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") (funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") (funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue :text #u"Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." :justify "center" :tags "item") (funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") (funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :text "Stippled characters" :tags "item") (funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") (funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" :start 45 :extent 270 :style "pieslice" :tags "item") (funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" :fill blue :start -135 :extent 270 :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" :fill "" :outline red :start 225 :extent -90 :tags "item") (funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" :fill blue :outline "" :start 45 :extent 270 :tags "item") (funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") (funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") (funcall c :create "bitmap" "17c" "18.5c" :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") (funcall c :create "bitmap" "17c" "21.5c" :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") (funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") (button (conc c '.button) :text "Press Me" :command `(butPress ',c ',red)) (funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") (bind "Entry" "" '(emacs-move %W %A )) (bind "Entry" "" "") (entry (conc c '.entry) :width 20 :relief "sunken") (funcall (conc c '.entry) :insert "end" "Edit this text") (funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") (scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c :width ".5c" :tickinterval 0) (funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") (funcall c :create "text" "21c" "17.9c" :text "Button" :anchor "sw") (funcall c :create "text" "21c" "20.9c" :text "Entry" :anchor "sw") (funcall c :create "text" "28.5c" "17.4c" :text "Scale" :anchor "s") ;; Set up event bindings for canvas: (funcall c :bind "item" "" `(itemEnter ',c)) (funcall c :bind "item" "" `(itemLeave ',c)) (bind c "<2>" (tk-conc c " scan mark %x %y")) (bind c "" (tk-conc c " scan dragto %x %y")) (bind c "<3>" `(itemMark ',c |%x| |%y|)) (bind c "" `(itemStroke ',c |%x| |%y|)) (bind c "" `(itemsUnderArea ',c)) (bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) (bind c "" `(itemDrag ',c |%x| |%y|)) (bind w "" `(focus ',c)) ) ;; Utility procedures for highlighting the item under the pointer: (defvar *restorecmd* nil) (defun itemEnter (c &aux type bg) ; (global :*restorecmd*) (let ((current (funcall c :find "withtag" "current" :return 'string))) (if (equal current "") (return-from itementer nil)) (itemleave nil) (if (not *color-display*) (progn (itemLeave nil) (return-from itementer nil))) (setq type (funcall c :type current :return 'string)) (if (equal type "window") (progn (itemLeave nil) (return-from itemEnter nil))) (if (equal type "bitmap") (progn (setq bg (nth 4 (funcall c :itemconf current :background :return 'list-strings))) (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) (funcall c :itemconfig current :background "SteelBlue2") (return-from itemEnter nil))) (setq fill (nth 4 (funcall c :itemconfig current :fill :return 'list-strings))) (if (or (member type '("rectangle" "oval" "arg") :test 'equal) (equal fill "")) (progn (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) (funcall c :itemconfig current :outline "SteelBlue2")) (progn (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) (funcall c :itemconfig current :fill "SteelBlue2"))) ) ) (defun itemLeave (c) ; (global :*restorecmd*) (let ((tem *restorecmd*)) (setq *restorecmd* nil) (dolist (v tem) (eval v)))) ;; Utility procedures for stroking out a rectangle and printing what's ;; underneath the rectangle's area. (defun itemMark (c x y) ; (global :areaX1 areaY1) (setq areaX1 (funcall c :canvasx x :return 'string)) (setq areaY1 (funcall c :canvasy y :return 'string)) (funcall c :delete "area") ) (defun itemStroke (c x y ) (declare (special areaX1 areaY1 areaX2 areaY2)) (or *recursive* (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'string)) (setq y (funcall c :canvasy y :return 'string)) (progn (setq areaX2 x) (setq areaY2 y) ;; this next return 'stringis simply for TIMING!!! ;; to make it wait for the result before going into subsequent!! (funcall c :delete "area" :return 'string) (funcall c :addtag "area" "withtag" (funcall c :create "rect" areaX1 areaY1 x y :outline "black" :return 'string)) )))) (defun itemsUnderArea (c) ; (global :areaX1 areaY1 areaX2 areaY2) (setq area (funcall c :find "withtag" "area" :return 'string)) (setq me c) (setq items "") (dolist (i (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items enclosed by area: " items)) (setq items "") (dolist (i (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items overlapping area: " items)) (terpri) (force-output) ) (setq areaX1 0) (setq areaY1 0) (setq areaX2 0) (setq areaY2 0) ;; Utility procedures to support dragging of items. (defvar *lastX* 0) (defvar *lastY* 0) (defun itemStartDrag (c x y) ; (global :*lastX* *lastY*) (setq *lastX* (funcall c :canvasx x :return 'number)) (setq *lastY* (funcall c :canvasy y :return 'number)) ) (defun itemDrag (c x y) ; (global :*lastX* *lastY*) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x *lastX*) (- y *lastY*)) (setq *lastX* x) (setq *lastY* y) ) (defvar *recursive* nil) (defun itemDrag (c x y) ; (global :*lastX* *lastY*) (cond (*recursive* ) (t (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x *lastX*) (- y *lastY*)) (setq *lastX* x) (setq *lastY* y))))) ;; Procedure that's invoked when the button embedded in the "canvas" ;; is invoked. (defun butPress (w color) (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" :fill color :anchor "n" :return 'string)) (after 500 (tk-conc w " delete " i)) ) (defvar *last-kill* "") ;(bind ".citems.frame2.c.entry" "" '(emacs-move %W %A )) (defun emacs-move (a key) (let* ((win a) ;; if this window is from tcl it is not yet a lisp function. ;; steal it... build it into coerce-result... (foo (or (fboundp win) (setf (symbol-function win) (make-widget-instance win nil)))) (pos (funcall win :index "insert" :return 'number)) char new) (setq new (case (setq char (aref key 0)) (#\^B (max 0 (- pos 1))) (#\^F (max 0 (+ pos 1))) (#\^A 0) (#\^E "end"))) ; (print (list a char key)) (cond (new (funcall win :icursor new)) ((eql char #\^D) (funcall win :delete pos )) ((or (eql char #\^K) (eql char #\v)) (setq *last-kill* (subseq (funcall win :get :return 'string) pos)) (funcall win :delete pos "end" )) ((eql char #\^Y) (funcall win :insert pos *last-kill*)) (t (funcall win :insert pos key))))) gcl-2.6.14/gcl-tk/demos/showVars.lisp0000755000175000017500000000210514360276512015771 0ustar cammcamm(in-package "TK") ;;# showVars w var var var '... ;; ;; Create a top-level window that displays a bunch of global variable values ;; and keeps the display up-to-date even when the variables change value ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; var - Name of variable to monitor. (defun showVars (w args) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (wm :title w "Variable values") (label (conc w '.title) :text "Variable values:" :width 20 :anchor "center" :font :Adobe-helvetica-medium-r-normal--*-180*) (pack (conc w '.title) :side "top" :fill "x") (dolist (i args) (frame (conc w '|.| i)) (label (conc w '|.| i '.name) :text (tk-conc i ": ")) (label (conc w '|.| i '.value) :textvariable (list (or (get i 'text-variable-type) t) i)) (pack (conc w '|.| i '.name) (conc w '|.| i '.value) :side "left") (pack (conc w '|.| i) :side "top" :anchor "w") ) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.ok) :side "bottom" :pady 2) ) gcl-2.6.14/gcl-tk/demos/mkHScale.tcl0000755000175000017500000000231714360276512015464 0ustar cammcamm# mkHScale w # # Create a top-level window that displays a horizontal scale. # # Arguments: # w - Name to use for new top-level window. proc mkHScale {{w .scale2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Horizontal Scale Demonstration" wm iconname $w "Scale" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A bar and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill x frame $w.frame.top -borderwidth 15 scale $w.frame.scale -orient horizontal -length 280 -from 0 -to 250 \ -command "setWidth $w.frame.top.inner" -tickinterval 50 \ -bg Bisque1 pack $w.frame.top -side top -expand yes -anchor sw pack $w.frame.scale -side bottom -expand yes -anchor nw frame $w.frame.top.inner -relief raised -borderwidth 2 \ -bg SteelBlue1 pack $w.frame.top.inner -expand yes -anchor sw $w.frame.scale set 20 } proc setWidth {w width} { $w config -width $width } gcl-2.6.14/gcl-tk/demos/mkListbox3.tcl0000755000175000017500000000407014360276512016032 0ustar cammcamm# mkListbox3 w # # Create a top-level window containing a listbox with a bunch of well-known # sayings. The listbox can be scrolled or scanned in two dimensions. # # Arguments: # w - Name to use for new top-level window. proc mkListbox3 {{w .l3}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (well-known sayings)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you're done." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.ok -side bottom -fill x pack $w.frame -side top -expand yes -fill y scrollbar $w.frame.yscroll -relief sunken -command "$w.frame.list yview" scrollbar $w.frame.xscroll -relief sunken -orient horizontal \ -command "$w.frame.list xview" listbox $w.frame.list -width 20 -height 10 -yscroll "$w.frame.yscroll set" \ -xscroll "$w.frame.xscroll set" -relief sunken -setgrid 1 pack $w.frame.yscroll -side right -fill y pack $w.frame.xscroll -side bottom -fill x pack $w.frame.list -expand yes -fill y $w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" } gcl-2.6.14/gcl-tk/demos/mkPlot.tcl0000755000175000017500000000445514360276512015250 0ustar cammcamm# mkPlot w # # Create a top-level window containing a canvas displaying a simple # graph with data points that can be moved interactively. # # Arguments: # w - Name to use for new top-level window. proc mkPlot {{w .plot}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Plot Demonstration" wm iconname $w "Plot" set c $w.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 400 \ -bd 2 -relief raised -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." canvas $c -relief raised -width 450 -height 300 button $w.ok -text "OK" -command "destroy $w" pack $w.msg $w.c -side top -fill x pack $w.ok -side bottom -pady 5 set font -Adobe-helvetica-medium-r-*-180-* $c create line 100 250 400 250 -width 2 $c create line 100 250 100 50 -width 2 $c create text 225 20 -text "A Simple Plot" -font $font -fill brown for {set i 0} {$i <= 10} {incr i} { set x [expr {100 + ($i*30)}] $c create line $x 250 $x 245 -width 2 $c create text $x 254 -text [expr 10*$i] -anchor n -font $font } for {set i 0} {$i <= 5} {incr i} { set y [expr {250 - ($i*40)}] $c create line 100 $y 105 $y -width 2 $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font } foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223}} { set x [expr {100 + (3*[lindex $point 0])}] set y [expr {250 - (4*[lindex $point 1])/5}] set item [$c create oval [expr $x-6] [expr $y-6] \ [expr $x+6] [expr $y+6] -width 1 -outline black \ -fill SkyBlue2] $c addtag point withtag $item } $c bind point "$c itemconfig current -fill red" $c bind point "$c itemconfig current -fill SkyBlue2" $c bind point <1> "plotDown $c %x %y" $c bind point "$c dtag selected" bind $c "plotMove $c %x %y" } set plot(lastX) 0 set plot(lastY) 0 proc plotDown {w x y} { global plot $w dtag selected $w addtag selected withtag current $w raise current set plot(lastX) $x set plot(lastY) $y } proc plotMove {w x y} { global plot $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] set plot(lastX) $x set plot(lastY) $y } gcl-2.6.14/gcl-tk/demos/nqthm-stack.lisp0000755000175000017500000000446014360276512016415 0ustar cammcamm(in-package "TK") ;; turn on history; ;(MAINTAIN-REWRITE-PATH t) (defun nqthm-stack (&optional (w '.nqthm)) (toplevel w) (dpos w) (wm :title w "Nqthm Stack Frames") (wm :iconname w "Nqthm Stack") (wm :minsize w 1 1) (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") (frame (conc w '.frame) :borderwidth 10) (button (conc w '.ok) :text "OK" :command `(destroy ',w)) (button (conc w '.redo) :text "Show Frames" :command `(show-frames)) (checkbutton (conc w '.rew) :text "Maintain Frames" :variable '(boolean user::do-frames) :command '(user::MAINTAIN-REWRITE-PATH user::do-frames)) (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") (pack (conc w '.rew)(conc w '.redo) (conc w '.ok) :side "bottom" :fill "x") (scrollbar (conc w '.frame '.scroll) :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack (conc w '.frame.scroll) :side "right" :fill "y") (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") (setq *list-box* (conc w '.frame.list))) (in-package "USER") (defun tk::show-frames() (funcall tk::*list-box* :delete 0 "end") (apply tk::*list-box* :insert 0 (sloop::sloop for i below user::REWRITE-PATH-STK-PTR do (setq tem (aref user::REWRITE-PATH-STK i)) (setq tem (display-rewrite-path-token (nth 0 tem) (nth 3 tem))) (cond ((consp tem) (setq tem (format nil "~a" tem)))) collect tem))) (defun display-rewrite-path-token (prog term) (case prog (ADD-EQUATIONS-TO-POT-LST (access linear-lemma name term)) (REWRITE-WITH-LEMMAS (access rewrite-rule name term)) ((REWRITE REWRITE-WITH-LINEAR) (ffn-symb term)) ((SET-SIMPLIFY-CLAUSE-POT-LST SIMPLIFY-CLAUSE) "clause") (t (er hard (prog term) |Unexpected| |prog| |in| |call| |of| display-rewrite-path-token |on| (!ppr prog nil) |and| (!ppr term (quote |.|))))))gcl-2.6.14/gcl-tk/demos/mkBitmaps.tcl0000755000175000017500000000267514360276512015733 0ustar cammcamm# mkBitmaps w # # Create a top-level window that displays all of Tk's built-in bitmaps. # # Arguments: # w - Name to use for new top-level window. proc mkBitmaps {{w .bitmaps}} { global tk_library catch {destroy $w} toplevel $w dpos $w wm title $w "Bitmap Demonstration" wm iconname $w "Bitmaps" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts. Click the \"OK\" button when you've seen enough." frame $w.frame bitmapRow $w.frame.0 error gray25 gray50 hourglass bitmapRow $w.frame.1 info question questhead warning button $w.ok -text OK -command "destroy $w" pack $w.msg -side top -anchor center pack $w.frame -side top -expand yes -fill both pack $w.ok -side bottom -fill both } # The procedure below creates a new row of bitmaps in a window. Its # arguments are: # # w - The window that is to contain the row. # args - The names of one or more bitmaps, which will be displayed # in a new row across the bottom of w along with their # names. proc bitmapRow {w args} { frame $w pack $w -side top -fill both set i 0 foreach bitmap $args { frame $w.$i pack $w.$i -side left -fill both -pady .25c -padx .25c label $w.$i.bitmap -bitmap $bitmap label $w.$i.label -text $bitmap -width 9 pack $w.$i.label $w.$i.bitmap -side bottom incr i } } gcl-2.6.14/gcl-tk/demos/gc-monitor.lisp0000755000175000017500000001204114360276512016233 0ustar cammcamm ;; bug in aix c compiler on optimize?? #+aix3 (eval-when (compile) (proclaim '(optimize (speed 0)))) (in-package "TK") (defvar *gc-monitor-types* '(cons fixnum string si::relocatable-blocks stream)) (defvar *special-type-background* "red") (defun make-one-graph (top type) (let* ((f (conc top '.type type))) (setf (get type 'frame) f) (setf (get type 'canvas) (conc top '.canvas type)) (frame f ) (canvas (get type 'canvas) :relief "sunken" :width "8c" :height ".4c") (label (conc f '.data)) (button (conc f '.label) :text (string-capitalize (symbol-name type)) :background "gray90" :command `(draw-status ',type t)) (pack (conc f '.label) (conc f '.data) :side "left" :anchor "w" :padx "4m") (pack f :side "top" :anchor "w" :padx "1c") (pack (get type 'canvas) :side "top" :expand 1 :pady "2m") )) (defvar *prev-special-type* nil) (defvar *time-to-stay-on-type* 0) (defvar *values-array* (make-array 20 :fill-pointer 0)) (defun push-multiple-values (&rest l) (declare (:dynamic-extent l)) (dolist (v l) (vector-push-extend v *values-array*))) (defun draw-status (special-type &optional clicked) (setf (fill-pointer *values-array*) 0) (let ((max-size 0) (ar *values-array*) (i 0) (width 7.0s0) (ht ".15c")) (declare (fixnum max-size) (short-float width)(type (array (t)) ar)) (dolist (v *gc-monitor-types*) (let ((fp (fill-pointer *values-array*)) ) (multiple-value-call 'push-multiple-values (si::allocated v)) (setq max-size (max max-size (aref ar (the fixnum (+ fp 1))))))) ; (nfree npages maxpage nppage gccount nused) (dolist (v *gc-monitor-types*) (let* ((nfree (aref ar i)) (npages (aref ar (setq i(+ i 1)))) (nppage (aref ar (setq i(+ i 2)))) (gccount (aref ar (setq i (+ i 1)))) (nused (aref ar (setq i (+ i 1)))) (wid (/ (the short-float(* npages width)) max-size)) (f (get v 'frame)) (tot (* npages nppage)) (width-used (the short-float (/ (the short-float (* wid (the fixnum (- tot (the fixnum nfree))))) tot)))) (declare (fixnum nppage npages tot) (short-float wid)) (setq i (+ i 1)) (funcall (get v 'canvas) :delete "graph") (funcall (get v 'canvas) :create "line" 0 ht width-used : "c" ht :width "3m" :tag "graph" :fill "red") (funcall (get v 'canvas) :create "line" width-used : "c" ht wid : "c" ht :width "3m" :tag "graph" :fill "aquamarine4" ) (funcall (conc f '.data) :configure :text gccount : " gc's for ": npages : " pages (used=" : nused : ")") (cond ((eql special-type v) (cond (clicked (let ((n (* max-size 2))) (.gc.amount :configure :length "8c" :label "Allocate: " : (or special-type "") :tickinterval (truncate n 4) :to n) (.gc.amount :set npages) ))))))) (set-label-background *prev-special-type* "pink") (setq *prev-special-type* special-type) (set-label-background special-type *special-type-background*) ) ) (defun do-allocation () (when *prev-special-type* (allocate *prev-special-type* (.gc.amount :get :return 'number) t) (draw-status *prev-special-type*))) (defun set-label-background (type colour) (and (get type 'frame) (let ((label (conc (get type 'frame) '.label))) (funcall label :configure :background colour)))) (defun mkgcmonitor() (let (si::*after-gbc-hook*) (toplevel '.gc) (wm :title '.gc "GC Monitor") (wm :title '.gc "GC") (or (> (read-from-string (winfo :depth '.gc)) 1) (setq *special-type-background* "white")) (message '.gc.msg :font :Adobe-times-medium-r-normal--*-180* :aspect 400 :text "GC monitor displays after each garbage collection the amount of space used (red) and free (green) of the types in the list *gc-monitor-types*. Clicking on a type makes its size appear on the scale at the bottom, and double clicking on the scale causes actual allocation!") (pack '.gc.msg :side "top") (dolist (v *gc-monitor-types*) (make-one-graph '.gc v) ) (.gc :configure :borderwidth 4 :relief "ridge") ;; it is important to create the frame first, so that ;; it is earlier... and the others will show. (frame '.gc.ff) (button '.gc.ok :text "QUIT" :command `(progn (setq si::*after-gbc-hook* nil) (destroy '.gc))) (scale '.gc.amount :label "Amount :" :width ".3c" :orient "horizontal" :to 100) (pack '.gc.amount) (button '.gc.reset :text "RESET Number Used" :command '(progn (dolist (v *gc-monitor-types*) (set-label-background v "gray90")) (si::reset-number-used) (draw-status *prev-special-type*))) (button '.gc.update :text "Update" :command '(draw-status *prev-special-type*)) (pack '.gc.ok '.gc.reset '.gc.update :expand 1 :fill "x" :in '.gc.ff :padx 3 :pady 2 :side 'left) (pack '.gc.ff :expand 1 :fill "x") (bind '.gc.amount "" 'do-allocation) (draw-status nil)) (setq si::*after-gbc-hook* 'draw-status) ) gcl-2.6.14/gcl-tk/demos/mkEntry2.tcl0000755000175000017500000000402314360276512015504 0ustar cammcamm# mkEntry2 - # # Create a top-level window that displays a bunch of entries with # scrollbars. # # Arguments: # w - Name to use for new top-level window. proc mkEntry2 {{w .e2}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Entry Demonstration" wm iconname $w "Entries" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok -side top -fill both entry $w.frame.e1 -relief sunken -xscrollcommand "$w.frame.s1 set" scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ "$w.frame.e1 xview" frame $w.frame.f1 entry $w.frame.e2 -relief sunken -xscrollcommand "$w.frame.s2 set" scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ "$w.frame.e2 xview" frame $w.frame.f2 entry $w.frame.e3 -relief sunken -xscrollcommand "$w.frame.s3 set" scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ "$w.frame.e3 xview" pack $w.frame.e1 $w.frame.s1 $w.frame.f1 $w.frame.e2 $w.frame.s2 \ $w.frame.f2 $w.frame.e3 $w.frame.s3 -side top -fill x $w.frame.e1 insert 0 "Initial value" $w.frame.e2 insert end "This entry contains a long value, much too long " $w.frame.e2 insert end "to fit in the window at one time, so long in fact " $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." } gcl-2.6.14/gcl-tk/demos/mkArrow.tcl0000755000175000017500000001620614360276512015421 0ustar cammcamm# mkArrow w # # Create a top-level window containing a canvas demonstration that # allows the user to experiment with arrow shapes. # # Arguments: # w - Name to use for new top-level window. # This file implements a canvas widget that displays a large line with # an arrowhead and allows the shape of the arrowhead to be edited # interactively. The only procedure that should be invoked from outside # the file is the first one, which creates the canvas. proc mkArrow {{w .arrow}} { global tk_library upvar #0 demo_arrowInfo v catch {destroy $w} toplevel $w dpos $w wm title $w "Arrowhead Editor Demonstration" wm iconname $w "Arrow" set c $w.c frame $w.frame1 -relief raised -bd 2 canvas $c -width 500 -height 350 -relief raised button $w.ok -text "OK" -command "destroy $w" pack $w.frame1 -side top -fill both pack $w.ok -side bottom -pady 5 pack $c -expand yes -fill both message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a line." pack $w.frame1.m set v(a) 8 set v(b) 10 set v(c) 3 set v(width) 2 set v(motionProc) arrowMoveNull set v(x1) 40 set v(x2) 350 set v(y) 150 set v(smallTips) {5 5 2} set v(count) 0 if {[winfo depth $c] > 1} { set v(bigLineStyle) "-fill SkyBlue1" set v(boxStyle) "-fill {} -outline black -width 1" set v(activeStyle) "-fill red -outline black -width 1" } else { set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25" set v(boxStyle) "-fill {} -outline black -width 1" set v(activeStyle) "-fill black -outline black -width 1" } arrowSetup $c $c bind box "$c itemconfigure current $v(activeStyle)" $c bind box "$c itemconfigure current $v(boxStyle)" $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} $c bind box "\$demo_arrowInfo(motionProc) $c %x %y" bind $c "arrowSetup $c" } # The procedure below completely regenerates all the text and graphics # in the canvas window. It's called when the canvas is initially created, # and also whenever any of the parameters of the arrow head are changed # interactively. The argument is the name of the canvas widget to be # regenerated, and also the name of a global variable containing the # parameters for the display. proc arrowSetup c { upvar #0 demo_arrowInfo v $c delete all # Create the arrow and outline. eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ -arrow last $v(bigLineStyle)" set xtip [expr $v(x2)-10*$v(b)] set deltaY [expr 10*$v(c)+5*$v(width)] $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ $v(x2) $v(y) -width 2 -capstyle round -joinstyle round # Create the boxes for reshaping the line and arrowhead. eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ -tags {box1 box}" eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ -tags {box2 box}" eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ -tags {box3 box}" # Create three arrows in actual size with the same parameters $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ -width 2 set tmp [expr $v(x2)+100] $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ [expr $v(y)+125] -width $v(width) \ -arrow both -arrowshape "$v(a) $v(b) $v(c)" # Create a bunch of other arrows and text items showing the # current dimensions. set tmp [expr $v(x2)+10] $c create line $tmp [expr $v(y)-5*$v(width)] \ $tmp [expr $v(y)-$deltaY] \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ -text $v(c) -anchor w set tmp [expr $v(x1)-10] $c create line $tmp [expr $v(y)-5*$v(width)] \ $tmp [expr $v(y)+5*$v(width)] \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ -text $v(a) -anchor n set tmp [expr $tmp+25] $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ -arrow both -arrowshape $v(smallTips) $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ -text $v(b) -anchor n $c create text $v(x1) 310 -text "-width $v(width)" \ -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* incr v(count) } # The procedures below are called in response to mouse motion for one # of the three items used to change the line width and arrowhead shape. # Each procedure updates one or more of the controlling parameters # for the line and arrowhead, and recreates the display if that is # needed. The arguments are the name of the canvas widget, and the # x and y positions of the mouse within the widget. proc arrowMove1 {c x y} { upvar #0 demo_arrowInfo v set newA [expr ($v(x2)+5-[$c canvasx $x])/10] if {$newA < 1} { set newA 1 } if {$newA > 25} { set newA 25 } if {$newA != $v(a)} { $c move box1 [expr 10*($v(a)-$newA)] 0 set v(a) $newA } } proc arrowMove2 {c x y} { upvar #0 demo_arrowInfo v set newB [expr ($v(x2)+5-[$c canvasx $x])/10] if {$newB < 1} { set newB 1 } if {$newB > 25} { set newB 25 } set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10] if {$newC < 1} { set newC 1 } if {$newC > 20} { set newC 20 } if {($newB != $v(b)) || ($newC != $v(c))} { $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] set v(b) $newB set v(c) $newC } } proc arrowMove3 {c x y} { upvar #0 demo_arrowInfo v set newWidth [expr ($v(y)+5-[$c canvasy $y])/5] if {$newWidth < 1} { set newWidth 1 } if {$newWidth > 20} { set newWidth 20 } if {$newWidth != $v(width)} { $c move box3 0 [expr 5*($v(width)-$newWidth)] set v(width) $newWidth } } gcl-2.6.14/gcl-tk/demos/mkStyles.tcl0000755000175000017500000001040314360276512015603 0ustar cammcamm# mkStyles w # # Create a top-level window with a text widget that demonstrates the # various display styles that are available in texts. # # Arguments: # w - Name to use for new top-level window. proc mkStyles {{w .styles}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Text Demonstration - Display Styles" wm iconname $w "Text Styles" button $w.ok -text OK -command "destroy $w" text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ -width 70 -height 28 scrollbar $w.s -relief flat -command "$w.t yview" pack $w.ok -side bottom -fill x pack $w.s -side right -fill y pack $w.t -expand yes -fill both # Set up display styles $w.t tag configure bold -font -Adobe-Courier-Bold-O-Normal-*-120-* $w.t tag configure big -font -Adobe-Courier-Bold-R-Normal-*-140-* $w.t tag configure verybig -font -Adobe-Helvetica-Bold-R-Normal-*-240-* if {[winfo depth $w] > 1} { $w.t tag configure color1 -background #eed5b7 $w.t tag configure color2 -foreground red $w.t tag configure raised -background #eed5b7 -relief raised \ -borderwidth 1 $w.t tag configure sunken -background #eed5b7 -relief sunken \ -borderwidth 1 } else { $w.t tag configure color1 -background black -foreground white $w.t tag configure color2 -background black -foreground white $w.t tag configure raised -background white -relief raised \ -borderwidth 1 $w.t tag configure sunken -background white -relief sunken \ -borderwidth 1 } $w.t tag configure bgstipple -background black -borderwidth 0 \ -bgstipple gray25 $w.t tag configure fgstipple -fgstipple gray50 $w.t tag configure underline -underline on $w.t insert 0.0 {\ Text widgets like this one allow you to display information in a variety of styles. Display styles are controlled using a mechanism called } insertWithTags $w.t tags bold insertWithTags $w.t {. Tags are just textual names that you can apply to one or more ranges of characters within a text widget. You can configure tags with various display styles. If you do this, then the tagged characters will be displayed with the styles you chose. The available display styles are: } insertWithTags $w.t { 1. Font.} big insertWithTags $w.t { You can choose any X font, } insertWithTags $w.t large verybig insertWithTags $w.t { or } insertWithTags $w.t {small. } insertWithTags $w.t { 2. Color.} big insertWithTags $w.t { You can change either the } insertWithTags $w.t background color1 insertWithTags $w.t { or } insertWithTags $w.t foreground color2 insertWithTags $w.t { color, or } insertWithTags $w.t both color1 color2 insertWithTags $w.t {. } insertWithTags $w.t { 3. Stippling.} big insertWithTags $w.t { You can cause either the } insertWithTags $w.t background bgstipple insertWithTags $w.t { or } insertWithTags $w.t foreground fgstipple insertWithTags $w.t { information to be drawn with a stipple fill instead of a solid fill. } insertWithTags $w.t { 4. Underlining.} big insertWithTags $w.t { You can } insertWithTags $w.t underline underline insertWithTags $w.t { ranges of text. } insertWithTags $w.t { 5. 3-D effects.} big insertWithTags $w.t { You can arrange for the background to be drawn with a border that makes characters appear either } insertWithTags $w.t raised raised insertWithTags $w.t { or } insertWithTags $w.t sunken sunken insertWithTags $w.t {. } insertWithTags $w.t { 6. Yet to come.} big insertWithTags $w.t { More display effects will be coming soon, such as the ability to change line justification and perhaps line spacing.} $w.t mark set insert 0.0 bind $w "focus $w.t" } # The procedure below inserts text into a given text widget and # applies one or more tags to that text. The arguments are: # # w Window in which to insert # text Text to insert (it's inserted at the "insert" mark) # args One or more tags to apply to text. If this is empty # then all tags are removed from the text. proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } gcl-2.6.14/gcl-tk/demos/mkPlot.lisp0000755000175000017500000000555114360276512015433 0ustar cammcamm(in-package "TK") ;;# mkPlot w ;; ;; Create a top-level window containing a canvas displaying a simple ;; graph with data points that can be moved interactively. ;; ;; Arguments: ;; w - Name to use for new top-level window. (defun mkPlot ( &optional (w '.plot ) &aux c font x y item) (toplevel w ) (dpos w) (wm :title w "Plot Demonstration " : w) (wm :iconname w "Plot") (setq c (conc w '.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width 400 :bd 2 :relief "raised" :text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.") (canvas c :relief "raised" :width 450 :height 300) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :pady 5) (setq font :Adobe-helvetica-medium-r-*-180-*) (funcall c :create "line" 100 250 400 250 :width 2) (funcall c :create "line" 100 250 100 50 :width 2) (funcall c :create "text" 225 20 :text "A Simple Plot" :font font :fill "brown") (sloop for i to 10 do (setq x (+ 100 (* i 30))) (funcall c :create "line" x 250 x 245 :width 2) (funcall c :create "text" x 254 :text (* 10 i) :anchor "n" :font font)) (sloop for i to 5 do (setq y (- 250 (* i 40))) (funcall c :create "line" 100 y 105 y :width 2) (funcall c :create "text" 96 y :text (* i 50) : ".0" :anchor "e" :font font)) (sloop for point in '((12 56) (20 94) (33 98) (32 120) (61 180) (75 160) (98 223)) do (setq x (+ 100 (* 3 (nth 0 point)))) (setq y (- 250 (truncate (* 4 (nth 1 point)) 5))) (setq item (funcall c :create "oval" (- x 6) (- y 6) (+ x 6) (+ y 6) :width 1 :outline "black" :fill "SkyBlue2" :return 'string )) (funcall c :addtag "point" "withtag" item) ) (funcall c :bind "point" "" c : " itemconfig current -fill red") (funcall c :bind "point" "" c : " itemconfig current -fill SkyBlue2") (funcall c :bind "point" "<1>" `(plotdown ',c |%x| |%y|)) (funcall c :bind "point" "" c : " dtag selected") (bind c "" `(plotmove ',c |%x| |%y|)) ) (defvar plotlastX 0) (defvar plotlastY 0) (defun plotDown (w x y) (funcall w :dtag "selected") (funcall w :addtag "selected" "withtag" "current") (funcall w :raise "current") (setq plotlastY y) (setq plotlastX x) ) (defun plotMove (w x y &aux ) (let ((oldx plotlastX) (oldy plotlastY)) ;; Note plotmove may be called recursively... since ;; the funcall may call something which calls this. ;; so we must set the global plotlastx before the funcall.. (setq plotlastx x) (setq plotlastY y) (funcall w :move "selected" (- x oldx) (- y oldy)) ) ) gcl-2.6.14/gcl-tk/demos/mkPuzzle.tcl0000755000175000017500000000403414360276512015614 0ustar cammcamm# mkPuzzle w # # Create a top-level window containing a 15-puzzle game. # # Arguments: # w - Name to use for new top-level window. proc mkPuzzle {{w .p1}} { global xpos ypos catch {destroy $w} toplevel $w dpos $w wm title $w "15-Puzzle Demonstration" wm iconname $w "15-Puzzle" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right. Click the \"OK\" button when you've finished playing." frame $w.frame -width 120 -height 120 -borderwidth 2 -relief sunken \ -bg Bisque3 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.frame -side top -padx 5 -pady 5 pack $w.ok -side bottom -fill x set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} for {set i 0} {$i < 15} {set i [expr $i+1]} { set num [lindex $order $i] set xpos($num) [expr ($i%4)*.25] set ypos($num) [expr ($i/4)*.25] button $w.frame.$num -relief raised -text $num \ -command "puzzle.switch $w $num" place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ -relwidth .25 -relheight .25 } set xpos(space) .75 set ypos(space) .75 } # Procedure invoked by buttons in the puzzle to resize the puzzle entries: proc puzzle.switch {w num} { global xpos ypos if {(($ypos($num) >= ($ypos(space) - .01)) && ($ypos($num) <= ($ypos(space) + .01)) && ($xpos($num) >= ($xpos(space) - .26)) && ($xpos($num) <= ($xpos(space) + .26))) || (($xpos($num) >= ($xpos(space) - .01)) && ($xpos($num) <= ($xpos(space) + .01)) && ($ypos($num) >= ($ypos(space) - .26)) && ($ypos($num) <= ($ypos(space) + .26)))} { set tmp $xpos(space) set xpos(space) $xpos($num) set xpos($num) $tmp set tmp $ypos(space) set ypos(space) $ypos($num) set ypos($num) $tmp place $w.frame.$num -relx $xpos($num) -rely $ypos($num) } } gcl-2.6.14/gcl-tk/demos/mkListbox.tcl0000755000175000017500000000330114360276512015743 0ustar cammcamm# mkListbox w # # Create a top-level window that displays a listbox with the names of the # 50 states. # # Arguments: # w - Name to use for new top-level window. proc mkListbox {{w .l1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Listbox Demonstration (50 states)" wm iconname $w "Listbox" wm minsize $w 1 1 message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you've seen enough." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg -side top pack $w.frame -side top -expand yes -fill y pack $w.ok -side bottom -fill x scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ -setgrid 1 pack $w.frame.scroll -side right -fill y pack $w.frame.list -side left -expand yes -fill both $w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ Massachusetts Michigan Minnesota Mississippi Missouri \ Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ "New York" "North Carolina" "North Dakota" \ Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ "South Carolina" "South Dakota" \ Tennessee Texas Utah Vermont Virginia Washington \ "West Virginia" Wisconsin Wyoming } gcl-2.6.14/gcl-tk/demos/mkScroll.tcl0000755000175000017500000000543514360276512015567 0ustar cammcamm# mkScroll w # # Create a top-level window containing a simple canvas that can # be scrolled in two dimensions. # # Arguments: # w - Name to use for new top-level window. proc mkScroll {{w .cscroll}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Scrollable Canvas Demonstration" wm iconname $w "Canvas" wm minsize $w 100 100 set c $w.frame.c message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ -relief raised -bd 2 -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." frame $w.frame -relief raised -bd 2 button $w.ok -text "OK" -command "destroy $w" pack $w.msg -side top -fill x pack $w.ok -side bottom -pady 5 pack $w.frame -side top -expand yes -fill both canvas $c -scrollregion {-10c -10c 50c 20c} \ -xscrollcommand "$w.frame.hscroll set" -yscrollcommand "$w.frame.vscroll set" scrollbar $w.frame.vscroll -relief sunken -command "$c yview" scrollbar $w.frame.hscroll -orient horiz -relief sunken -command "$c xview" pack $w.frame.vscroll -side right -fill y pack $w.frame.hscroll -side bottom -fill x pack $c -expand yes -fill both set bg [lindex [$c config -bg] 4] for {set i 0} {$i < 20} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ -outline black -fill $bg -tags rect $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ -anchor center -tags text } } $c bind all "scrollEnter $c" $c bind all "scrollLeave $c" $c bind all <1> "scrollButton $c" bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" } proc scrollEnter canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] >= 0} { set id [expr $id-1] } set oldFill [lindex [$canvas itemconfig $id -fill] 4] if {[winfo depth $canvas] > 1} { $canvas itemconfigure $id -fill SeaGreen1 } else { $canvas itemconfigure $id -fill black $canvas itemconfigure [expr $id+1] -fill white } } proc scrollLeave canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] >= 0} { set id [expr $id-1] } $canvas itemconfigure $id -fill $oldFill $canvas itemconfigure [expr $id+1] -fill black } proc scrollButton canvas { global oldFill set id [$canvas find withtag current] if {[lsearch [$canvas gettags current] text] < 0} { set id [expr $id+1] } puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" } gcl-2.6.14/gcl-tk/demos/mkVScale.tcl0000755000175000017500000000230014360276512015472 0ustar cammcamm# mkVScale w # # Create a top-level window that displays a vertical scale. # # Arguments: # w - Name to use for new top-level window. proc mkVScale {{w .scale1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Vertical Scale Demonstration" wm iconname $w "Scale" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ -text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the \"OK\" button when you're finished." frame $w.frame -borderwidth 10 button $w.ok -text OK -command "destroy $w" pack $w.msg $w.frame $w.ok scale $w.frame.scale -orient vertical -length 280 -from 0 -to 250 \ -command "setHeight $w.frame.right.inner" -tickinterval 50 \ -bg Bisque1 frame $w.frame.right -borderwidth 15 pack $w.frame.scale -side left -anchor ne pack $w.frame.right -side left -anchor nw $w.frame.scale set 20 frame $w.frame.right.inner -width 40 -height 20 -relief raised \ -borderwidth 2 -bg SteelBlue1 pack $w.frame.right.inner -expand yes -anchor nw } proc setHeight {w height} { $w config -height $height } gcl-2.6.14/gcl-tk/demos/mkForm.tcl0000755000175000017500000000303214360276512015223 0ustar cammcamm# mkForm w # # Create a top-level window that displays a bunch of entries with # tabs set up to move between them. # # Arguments: # w - Name to use for new top-level window. proc mkForm {{w .form}} { global tabList catch {destroy $w} toplevel $w dpos $w wm title $w "Form Demonstration" wm iconname $w "Form" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done." foreach i {f1 f2 f3 f4 f5} { frame $w.$i -bd 1m entry $w.$i.entry -relief sunken -width 40 bind $w.$i.entry "Tab \$tabList" bind $w.$i.entry "destroy $w" label $w.$i.label pack $w.$i.entry -side right pack $w.$i.label -side left } $w.f1.label config -text Name: $w.f2.label config -text Address: $w.f5.label config -text Phone: button $w.ok -text OK -command "destroy $w" pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 $w.ok -side top -fill x set tabList "$w.f1.entry $w.f2.entry $w.f3.entry $w.f4.entry $w.f5.entry" } # The procedure below is invoked in response to tabs in the entry # windows. It moves the focus to the next window in the tab list. # Arguments: # # list - Ordered list of windows to receive focus proc Tab {list} { set i [lsearch $list [focus]] if {$i < 0} { set i 0 } else { incr i if {$i >= [llength $list]} { set i 0 } } focus [lindex $list $i] } gcl-2.6.14/gcl-tk/demos/mkCanvText.lisp0000755000175000017500000001162514360276512016250 0ustar cammcamm;;# mkCanvText w ;; ;; Create a top-level window containing a canvas displaying a text ;; string and allowing the string to be edited and re-anchored. ;; ;; Arguments: ;; w - Name to use for new top-level window. (in-package "TK") (defun mkCanvText ({w .ctext}) (catch {destroy w}) (toplevel w) (dpos w) (wm :title w "Canvas Text Demonstration") (wm :iconname w "Text") (setq c (conc w '.c)) (message (conc w '.msg) :font -Adobe-Times-Medium-R-Normal-*-180-* :width 420 :relief "raised" :bd 2 :text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification.") (canvas c :relief "raised" :width 500 :height 400) (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) :side "top" :fill "both") (pack (conc w '.c) :side "top" :expand "yes" :fill "both") (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") (setq font :Adobe-helvetica-medium-r-*-240-*) (funcall c :create rectangle 245 195 255 205 :outline "black" :fill "red") ;; First, create the text item and give it bindings so it can be edited. (funcall c :addtag text withtag (funcall c create text 250 200 :text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." :width 440 :anchor "n" :font font :justify "left")) (funcall c :bind text "<1>" (textB1Press c |%x| |%y|)) (funcall c :bind text "" (textB1Move c %x %y)) (funcall c :bind text "" (tk-conc c " select adjust current @%x,%y")) (funcall c :bind text "" (funcall 'textB1Move c |%x| |%y|)) (funcall c :bind text "" (tk-conc c " insert text insert %A")) (funcall c :bind text "" (tk-conc c " insert text insert %A")) (funcall c :bind text "" (tk-conc c " insert text insert \\n")) (funcall c :bind text "" (funcall 'textBs c)) (funcall c :bind text "" (funcall 'textBs c)) (funcall c :bind text "" (tk-conc c " dchars text sel.first sel.last")) (funcall c :bind text "" (tk-conc c " insert text insert \[selection get\]")) ;; Next, create some items that allow the text's anchor position ;; to be edited. (setq x 50) (setq y 50) (setq color LightSkyBlue1) (mkTextConfig c x y :anchor "se" color) (mkTextConfig c (+ x 30) y :anchor "s" color) (mkTextConfig c (+ x 60) y :anchor "sw" color) (mkTextConfig c x (+ y 30) :anchor "e" color) (mkTextConfig c (+ x 30) (+ y 30) :anchor "center" color) (mkTextConfig c (+ x 60) (+ y 30) :anchor "w" color) (mkTextConfig c x (+ y 60) :anchor "ne" color) (mkTextConfig c (+ x 30) (+ y 60) :anchor "n" color) (mkTextConfig c (+ x 60) (+ y 60) :anchor "nw" color) (setq item (funcall c create rect (+ x 40) (+ y 40) (+ x 50) (+ y 50) :outline "black" :fill "red")) (funcall c :bind item "<1>" (tk-conc c " itemconf text :anchor ")center"") (funcall c :create text (+ x 45) (- y 5) :text "{Text Position}" :anchor "s" :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") ;; Lastly, create some items that allow the text's justification to be ;; changed. (setq x 350) (setq y 50) (setq color SeaGreen2) (mkTextConfig c x y :justify "left" color) (mkTextConfig c (+ x 30) y :justify "center" color) (mkTextConfig c (+ x 60) y :justify "right" color) (funcall c :create text (+ x 45) (- y 5) :text "Justification" :anchor "s" :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") (funcall c :bind config "" (tk-conc "textEnter " c)) (funcall c :bind config "" (tk-conc c " itemconf current :fill \$textConfigFill")) ) (defun mkTextConfig (w x y option value color) (setq item (funcall w create rect x y (+ x 30) (+ y 30) :outline "black" :fill color :width 1)) (funcall w :bind item "<1>" (tk-conc w " itemconf text " option " " value)) (funcall w :addtag "config" "withtag" item) ) (setq textConfigFill "") (defun textEnter (w) (global :textConfigFill) (setq textConfigFill [lindex (funcall w :itemconfig "current" :fill) 4]) (funcall w :itemconfig "current" :fill "black") ) (defun textB1Press (w x y) (funcall w :icursor "current" (aT x y)) (funcall w :focus "current") (focus w) (funcall w :select "from" "current" (aT x y)) ) (defun textB1Move (w x y) (funcall w :select "to current" (aT x y)) ) (defun textBs (w &aux char) (setq char (atoi (funcall w :index "text" "insert")) - 1) (if (>= char 0) (funcall w :dchar "text" char)) ) gcl-2.6.14/gcl-tk/demos/mkRuler.lisp0000755000175000017500000001214614360276512015604 0ustar cammcamm;;# mkRuler w ;; ;; Create a canvas demonstration consisting of a ruler. ;; ;; Arguments: ;; w - Name to use for new top-level window. ;; This file implements a canvas widget that displays a ruler with tab stops ;; that can be set individually. The only procedure that should be invoked ;; from outside the file is the first one, which creates the canvas. (in-package "TK") (defun mkRuler (&optional (w '.ruler)) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (dpos w) (wm :title w "Ruler Demonstration") (wm :iconname w "Ruler") (setq c (conc w '.c)) (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width "13c" :relief "raised" :bd 2 :text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. (if :you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.") (canvas c :width "14.8c" :height "2.5c" :relief "raised") (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") (pack (conc w '.ok) :side "bottom" :pady 5) (setf *v* (gensym)) (setf (get *v* 'grid) '.25c) (setf (get *v* 'left) (winfo :fpixels c "1c" :return t)) (setf (get *v* 'right) (winfo :fpixels c "13c" :return t)) (setf (get *v* 'top) (winfo :fpixels c "1c" :return t)) (setf (get *v* 'bottom) (winfo :fpixels c "1.5c" :return t)) (setf (get *v* 'size) (winfo :fpixels c '.2c :return t)) (setf (get *v* 'normalStyle) '(:fill "black")) (if (> (read-from-string (winfo :depth c)) 1) (progn (setf (get *v* 'activeStyle) '(:fill "red" :stipple "")) (setf (get *v* 'deleteStyle) `(:stipple "@" : ,*tk-library* :"/demos/bitmaps/grey.25" :fill "red")) );;else (progn (setf (get *v* 'activeStyle) '(:fill "black" :stipple "" )) (setf (get *v* 'deleteStyle) `(:stipple "@" : ,*tk-library* : "/demos/bitmaps/grey.25" :fill "black")) )) (funcall c :create "line" "1c" "0.5c" "1c" "1c" "13c" "1c" "13c" "0.5c" :width 1) (dotimes (i 12) (let (( x (+ i 1))) (funcall c :create "line" x :"c" "1c" x :"c" "0.6c" :width 1) (funcall c :create "line" x :".25c" "1c" x :".25c" "0.8c" :width 1) (funcall c :create "line" x :".5c" "1c" x :".5c" "0.7c" :width 1) (funcall c :create "line" x :".75c" "1c" x :".75c" "0.8c" :width 1) (funcall c :create "text" x :".15c" '.75c :text i :anchor "sw") )) (funcall c :addtag "well" "withtag" (funcall c :create "rect" "13.2c" "1c" "13.8c" "0.5c" :outline "black" :fill (nth 4 (funcall c :config :background :return 'list-strings)))) (funcall c :addtag "well" "withtag" (rulerMkTab c (winfo :pixels c "13.5c" :return t) (winfo :pixels c '.65c :return t))) (funcall c :bind "well" "<1>" `(rulerNewTab ',c |%x| |%y|)) (funcall c :bind "tab" "<1>" `(demo_selectTab ',c |%x| |%y|)) (bind c "" `(rulerMoveTab ',c |%x| |%y|)) (bind c "" `(rulerReleaseTab ',c)) ) (defun rulerMkTab (c x y) (funcall c :create "polygon" x y (+ x (get *v* 'size)) (+ y (get *v* 'size)) (- x (get *v* 'size)) (+ y (get *v* 'size)) :return 'string ) ) (defun rulerNewTab (c x y) (funcall c :addtag "active" "withtag" (rulerMkTab c x y)) (funcall c :addtag "tab" "withtag" "active") (setf (get *v* 'x) x) (setf (get *v* 'y) y) (rulerMoveTab c x y) ) (defvar *recursive* nil) ;; prevent recursive calls (defun rulerMoveTab (c x y &aux cx cy (*recursive* *recursive*) ) (cond (*recursive* (return-from rulerMoveTab)) (t (setq *recursive* t))) (if (equal (funcall c :find "withtag" "active" :return 'string) "") (return-from rulerMoveTab nil)) (setq cx (funcall c :canvasx x (get *v* 'grid) :return t)) (setq cy (funcall c :canvasy y :return t)) (if (< cx (get *v* 'left))(setq cx (get *v* 'left))) (if (> cx (get *v* 'right))(setq cx (get *v* 'right))) (if (and (>= cy (get *v* 'top)) (<= cy (get *v* 'bottom))) (progn (setq cy (+ 2 (get *v* 'top))) (apply c :itemconf "active" (get *v* 'activestyle))) (progn (setq cy (- cy (get *v* 'size) 2)) (apply c :itemconf "active"(get *v* 'deletestyle))) ) (funcall c :move "active" (- cx (get *v* 'x)) (- cy (get *v* 'y)) ) (setf (get *v* 'x) cx) (setf (get *v* 'y) cy) ) (defun demo_selectTab (c x y) (setf (get *v* 'x) (funcall c :canvasx x (get *v* 'grid) :return t)) (setf (get *v* 'y) (+ 2 (get *v* 'top))) (funcall c :addtag "active" "withtag" "current") (apply c :itemconf "active" (get *v* 'activeStyle)) (funcall c :raise "active") ) (defun rulerReleaseTab (c ) (if (equal (funcall c :find "withtag" "active" :return 'string) "") (return-from rulerReleaseTab nil)) (if (not (eql (get *v* 'y) (+ 2 (get *v* 'top)))) (funcall c :delete "active") (progn (apply c :itemconf "active" (get *v* 'normalStyle)) (funcall c :dtag "active") ) )) gcl-2.6.14/gcl-tk/demos/mkTear.tcl0000755000175000017500000000145014360276512015215 0ustar cammcamm# mkTear w # # Create a top-level window that displays a help message on tear-off # menus. # # Arguments: # w - Name to use for new top-level window. proc mkTear {{w .t1}} { catch {destroy $w} toplevel $w dpos $w wm title $w "Information On Tear-Off Menus" wm iconname $w "Info" message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 250 \ -text "To tear off a menu, press mouse button 2 over the menubutton for the menu, then drag the menu with button 2 held down. You can reposition a torn-off menu by pressing button 2 on it and dragging again. To unpost the menu, click mouse button 1 over the menu's menubutton. Click the \"OK\" button when you're finished with this window." button $w.ok -text OK -command "destroy $w" pack $w.msg $w.ok -pady 5 } gcl-2.6.14/gcl-tk/tktst.c0000755000175000017500000001262214360276512013477 0ustar cammcamm/*-*-c++-*-*/ #include #include #include #include Tcl_Interp *tcliMain; /* Main and only tcl interpreter instance */ static Tk_Window mainWindow; /* The main window for the application. If * NULL then the application no longer * exists. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static int synchronize = 1; static char *szname = "TCL/TK-Scheme"; static char *szdisplay = NULL; /* "unix:0.0"; */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int gotPartial = 0; /* Partial command in buffer. */ static char exitCmd[] = "exit"; static char errorExitCmd[] = "destroy ."; extern int isatty _ANSI_ARGS_((int fd)); /* int __TclX_AppInit(Tcl_Interp *interp) { return TCL_OK; } */ /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ static void StdinProc(ClientData clientData, int mask) { #define BUFFER_SIZE 4000 char input[BUFFER_SIZE+1]; char *cmd; int code, count; count = read(fileno(stdin), input, BUFFER_SIZE); if (count <= 0) { if (!gotPartial) { if (tty) { Tcl_VarEval(tcliMain, "exit", (char *) NULL); exit(1); } else { Tk_DeleteFileHandler(0); } return; } else { count = 0; } } cmd = Tcl_DStringAppend(&command, input, count); if (count != 0) { if ((input[count-1] != '\n') && (input[count-1] != ';')) { gotPartial = 1; goto exitPoint; } if (!Tcl_CommandComplete(cmd)) { gotPartial = 1; goto exitPoint; } } gotPartial = 0; /* * Disable the stdin file handler; otherwise if the command * re-enters the event loop we might process commands from * stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0); code = Tcl_RecordAndEval(tcliMain, cmd, 0); Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_PrintResult (tcliMain, code, cmd); Tcl_DStringFree(&command); exitPoint: if (tty) { TclX_OutputPrompt (tcliMain, !gotPartial); } } /* *---------------------------------------------------------------------- * * SignalProc -- * * Function called on a signal generating an error to clear the stdin * buffer. *---------------------------------------------------------------------- */ static void SignalProc (int signalNum) { tclGotErrorSignal = 0; Tcl_DStringFree (&command); gotPartial = 0; if (tty) { fputc ('\n', stdout); TclX_OutputPrompt (tcliMain, !gotPartial); } } char *TclTkInit() { tcliMain = Tcl_CreateInterp(); mainWindow = Tk_CreateMainWindow(tcliMain, szdisplay, szname, "Tk"); if (mainWindow == NULL) fprintf(stderr, "Unable to create mainWindow : %s\n", tcliMain->result); Tk_SetClass(mainWindow, "Tk"); if (synchronize) XSynchronize(Tk_Display(mainWindow), True); Tk_GeometryRequest(mainWindow, 200, 200); /* if (__TclX_AppInit(tcliMain) != TCL_OK) TclX_ErrorExit (tcliMain, 255); */ Tcl_AppInit(tcliMain); return "."; } void TclTkMainLoop() { /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(tcliMain, "tcl_interactive", tty ? "1" : "0", TCL_GLOBAL_ONLY); /* TclX_EvalRCFile (tcliMain); */ /* * Commands will come from standard input. Set up a handler * to receive those characters and print a prompt if the input * device is a terminal. */ tclErrorSignalProc = SignalProc; Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_OutputPrompt (tcliMain, 1); Tk_MainLoop(); Tcl_GlobalEval(tcliMain, exitCmd); } main() { TclTkInit(); TclTkMainLoop(); } int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window main; main = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (TclX_Init(interp) == TCL_ERROR) return TCL_ERROR; if (TkX_Init(interp) == TCL_ERROR) return TCL_ERROR; /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ tcl_RcFileName = "~/.wishrc"; return TCL_OK; } gcl-2.6.14/gcl-tk/tinfo.lsp0000755000175000017500000004502114360276512014020 0ustar cammcamm;; Copyright (C) 1994 W. Schelter ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; (in-package "TK") (eval-when (compile eval) (defmacro f (op x y) `(the ,(if (get op 'compiler::predicate) 't 'fixnum) (,op (the fixnum ,x) (the fixnum ,y)))) (defmacro while (test &body body) `(sloop while ,test do ,@ body)) (or (boundp '*info-window*) (si::aload "info")) ) (defun simple-listbox (w) (let ((listbox (conc w '.frame.list)) (scrollbar(conc w '.frame.scroll))) (frame (conc w '.frame)) (scrollbar scrollbar :relief "sunken" :command (tk-conc w ".frame.list yview")) (listbox listbox :yscroll (tk-conc w ".frame.scroll set") :relief "sunken" :setgrid 1) (pack scrollbar :side "right" :fill "y") (pack listbox :side "left" :expand "yes" :fill "both")) (conc w '.frame)) (defun insert-standard-listbox (w lis &aux print-entry) (funcall w :delete 0 'end) (setf (get w 'list) lis) (setq print-entry (get w 'print-entry)) (dolist (v lis) (funcall w :insert 'end (if print-entry (funcall print-entry v) v)))) (defun listbox-move (win key |%y|) |%y| (let ((amt (cdr (assoc key '(("Up" . -1) ("Down" . 1) ("Next" . 10) ("Prior" . -10)) :test 'equal)))) (cond (amt (funcall win :yview (+ (funcall win :nearest 0 :return 'number) amt)))))) (defun new-window (name &aux tem) (cond ((not (fboundp name)) name) ((winfo :exists name :return 'boolean) (let ((i 2)) (while (winfo :exists (setq tem (conc name i )) :return 'boolean) (setq i (+ i 1))) tem)) (t name))) (defun insert-info-choices (listbox list &aux file position-pattern prev) (funcall listbox :delete 0 'end) (sloop for i from 0 for name in list do (setq file nil position-pattern nil) (progn ;decode name (cond ((and (consp name) (consp (cdr name))) (setq file (cadr name) name (car name)))) (cond ((consp name) (setq position-pattern (car name) name (cdr name))))) (funcall listbox :insert 'end (format nil "~@[~a :~]~@[(~a)~]~a." position-pattern (if (eq file prev) nil (setq prev file)) name))) (setf (get listbox 'list)list)) (defun offer-choices (list info-dirs &optional (w (new-window '.info)) &aux listbox) (toplevel w) (simple-listbox w) (setq listbox (conc w '.frame.list)) (insert-info-choices listbox list) (bind listbox "" #'(lambda () (show-info (nth (atoi (funcall listbox :curselection :return 'string) 0) (get listbox 'list))))) (button (conc w '.ok) :text "Quit " :command `(destroy ',w)) (frame (conc w '.apro)) (label(conc w '.apro.label) :text "Apropos: ") (entry (conc w '.apro.entry) :relief "sunken") (pack (conc w '.apro.label) (conc w '.apro.entry) :side "left" :expand "yes") (pack (conc w '.frame) (conc w '.ok) (conc w '.apro) :side "top" :fill "both") (bind (conc w '.apro.entry) "" #'(lambda() (insert-info-choices listbox (info-aux (funcall (conc w '.apro.entry) :get :return 'string) info-dirs) ))) (bind w "" `(focus ',(conc w '.apro.entry))) w ) (defun get-info-apropos (win file type) (cond ((and win (winfo :exists win :return 'boolean)) (let ((old (get win 'info-data))) (unless (eq old *current-info-data*) (setf (get win 'info-data) *current-info-data*) (funcall (conc win '.frame.list) :delete 0 'end)) (raise win) (focus win) win)) (t (offer-choices file type nil)))) (defun show-info-key (win key) (let ((node (get win 'node)) name) (or node (info-error "No Node?")) (setq name (if (f >= (string-match (si::string-concatenate key #u":[ \t]+([^\n\t,]+)[\n\t,]") (node string node) (node header node) (node begin node)) 0) (get-match (node string node) 1))) (if name (show-info name nil)))) (defun mkinfo (&optional (w '.info_text) &aux textwin menu ) (if (winfo :exists w :return 'boolean) (destroy w)) (toplevel w) (wm :title w "Info Text Window") (wm :iconname w "Info") (frame (setq menu (conc w '.menu )):relief "raised" :borderwidth 1) (setq textwin (conc w '.t)) (pack menu :side "top" :fill "x") (button (conc menu '.quit) :text "Quit" :command `(destroy ',w)) (menubutton (conc menu '.file) :text "File" :relief 'raised :menu (conc menu '.File '.m) :underline 0) (menu (conc menu '.file '.m)) (funcall (conc menu '.file '.m) :add 'command :label "Hotlist" :command '(show-info (tk-conc "("(default-info-hotlist) ")") nil)) (funcall (conc menu '.file '.m) :add 'command :label "Add to Hotlist" :command `(add-to-hotlist ',textwin)) (funcall (conc menu '.file '.m) :add 'command :label "Top Dir" :command `(show-info "(dir)" nil)) (button (conc menu '.next) :text "Next" :relief 'raised :command `(show-info-key ',textwin "Next")) (button (conc menu '.prev) :text "Previous" :relief 'raised :command `(show-info-key ',textwin "Prev")) (button (conc menu '.up) :text "Up" :relief 'raised :command `(show-info-key ',textwin "Up")) (button (conc menu '.info) :text "Info" :relief 'raised :command `(if (winfo :exists ".info") (raise '.info) (offer-choices nil si::*default-info-files*) )) (button (conc menu '.last) :text "Last" :relief 'raised :command `(info-show-history ',textwin 'last)) (button (conc menu '.history) :text "History" :relief 'raised :command `(info-show-history ',textwin 'history)) (pack (conc menu '.file) (conc menu '.quit) (conc menu '.next) (conc menu '.prev) (conc menu '.up) (conc menu '.prev) (conc menu '.last) (conc menu '.history) (conc menu '.info) :side "left") ; (entry (conc menu '.entry) :relief "sunken") ; (pack (conc menu '.entry) :expand "yes" :fill "x") ; (pack (conc menu '.next) ; :side "left") (bind w "" `(focus ',menu)) ; (tk-menu-bar menu (conc menu '.next) ) ; (bind menu "" "tk_traverseToMenu %W %A") (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) (text textwin :relief "raised" :bd 2 :setgrid "true" :state 'disabled) (funcall textwin :configure :yscrollcommand (scroll-set-fix-xref-closure textwin (conc w '.s)) ) (bind menu "" `(show-info-key ',textwin "Next")) (bind menu "" `(show-info-key ',textwin "Up")) (bind menu "" `(show-info-key ',textwin "Prev")) (bind menu "" (nth 4(funcall (conc menu '.last) :configure :command :return 'list-strings))) ;; SEARCHING: this needs to be speeded up and fixed. ; (bind (conc menu '.entry) "" ; `(info-text-search ',textwin ',menu %W %A %K)) ; (bind (conc menu '.entry) "" ; `(info-text-search ',textwin ',menu %W %A %K)) ; (bind menu "" #'(lambda () (focus (menu '.entry)))) (pack (conc w '.s) :side 'right :fill "y") (pack textwin :expand 'yes :fill 'both) (funcall textwin :mark 'set 'insert 0.0) (funcall textwin :tag :configure 'bold :font :Adobe-Courier-Bold-O-Normal-*-120-*) (funcall textwin :tag :configure 'big :font :Adobe-Courier-Bold-R-Normal-*-140-*) (funcall textwin :tag :configure 'verybig :font :Adobe-Helvetica-Bold-R-Normal-*-240-*) (funcall textwin :tag :configure 'xref :font :Adobe-Courier-Bold-O-Normal-*-120-* ) (funcall textwin :tag :configure 'current_xref :underline 1 ) (funcall textwin :tag :bind 'xref "" "eval [concat %W { tag add current_xref } [get_tag_range %W xref @%x,%y]]") (funcall textwin :tag :bind 'xref "" "%W tag remove current_xref 0.0 end") (funcall textwin :tag :bind 'xref "<3>" `(show-this-node ',textwin |%x| |%y|)) (focus menu) ;; (bind w "" (tk-conc "focus " w ".t")) ) (defun info-text-search (textwin menu entry a k &aux again (node (get textwin 'node))) (or node (tk-error "cant find node index")) ; (print (list entry a k )) (cond ((equal k "Delete") (let ((n (funcall entry :index 'insert :return 'number))) (funcall entry :delete (- n 1)))) ((>= (string-match "Control" k) 0)) ((equal a "") (setq again 1)) ((>= (string-match "[^-]" a) 0) (funcall entry :insert 'insert a) (setq again 0)) (t (focus menu) )) (or again (return-from info-text-search nil)) (print (list 'begin-search entry a k )) (let* ( (ind (funcall textwin :index 'current :return 'string)) (pos (index-to-position ind (node string node) (node begin node) (node end node) )) (where (info-search (funcall entry :get :return 'string) (+ again (node-offset node) pos)))) ;; to do mark region in reverse video... (cond ((>= where 0) (let ((node (info-node-from-position where))) (print-node node (- where (node-offset node))))) (t (funcall entry :flash ))))) (defvar *last-history* nil) (defun print-node (node initial-offset &aux last) ; "print text from node possibly positioning window at initial-offset ;from beginning of node" (setq last (list node initial-offset)) (let ((text '.info_text) textwin tem) (or (winfo :exists text :return 'boolean) (mkinfo text)) (setq textwin (conc text '.t)) (funcall textwin :configure :state 'normal) (cond ((get textwin 'no-record-history) (remprop textwin 'no-record-history)) ((setq tem (get textwin 'node)) (setq *last-history* nil) (push (format nil #u"* ~a:\t(~a)~a.\tat:~a" (node name tem) (node file tem) (node name tem) (funcall textwin :index "@0,0" :return 'string) ) (get textwin 'history)))) (setf (get textwin 'node) node) (funcall textwin :delete 0.0 'end) (funcall textwin :mark :set 'insert "1.0") (cond ((> initial-offset 0) ;; insert something to separate the beginning of what ;; we want to show and what goes before. (funcall textwin :insert "0.0" #u"\n") (funcall textwin :mark :set 'display_at 'end) (funcall textwin :mark :set 'insert 'end) (funcall textwin :yview 'display_at) (insert-fontified textwin (node string node) (+ (node begin node) initial-offset) (node end node)) (funcall textwin :mark :set 'insert "0.0") (insert-fontified textwin (node string node) (node begin node) (+ (node begin node) initial-offset)) ) (t (insert-fontified textwin (node string node) (node begin node) (node end node)))) (funcall textwin :configure :state 'disabled) (raise text) textwin )) (defun info-show-history (win type) (let ((his (get win 'history))) (cond ((stringp type) (if (f >= (string-match #u":\t([^\t]+)[.]\tat:([0-9.]+)" type) 0) (let ((pos (get-match type 2)) (w (show-info (get-match type 1) nil))) (setf (get win 'no-record-history) t) (or (equal "1.0" pos) (funcall w :yview pos))))) ((eq type 'last) (info-show-history win (if *last-history* (pop *last-history*) (progn (setq *last-history* (get win 'history)) (pop *last-history*))))) ((eq type 'history) (let* ((w '.info_history) (listbox (conc w '.frame.list))) (cond ((winfo :exists w :return 'boolean)) (t (toplevel w) (simple-listbox w) (button (conc w '.quit) :text "Quit" :command `(destroy ',w)) (pack (conc w '.frame) (conc w '.quit) :expand "yes" :fill 'both) )) (insert-standard-listbox listbox his) (raise w) (bind listbox "" `(info-show-history ',listbox (car (selection :get :return 'list-strings))))))))) (defun show-this-node (textwin x y) (let ((inds (get_tag_range textwin 'xref "@": x :",": y :return 'list-strings))) (cond ((and inds (listp inds) (eql (length inds) 2)) (show-info (nsubstitute #\space #\newline (apply textwin :get :return 'string inds)) nil)) (t (print inds))))) (defun scroll-set-fix-xref-closure (wint wins &aux prev) #'(lambda (&rest l) (or (equal l prev) (progn (setq prev l) (fix-xref wint) (apply wins :set l))))) (defvar *recursive* nil) ;(defun fix-xref-faster (win &aux (all'(" ")) tem) ; (unless ; *recursive* ; (let* ((*recursive* t) s ; (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") ; (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) ; (end (funcall win :index "@0,1000 lineend" :return 'string))) ; (cond ((or (f >= (string-match "possible_xref" ; (funcall win :tag :names beg :return 'string)) 0) ; (not (equal "" ; (setq tem (funcall win :tag :nextrange "possible_xref" beg end ; :return 'string))))) ; (if tem (setq beg (car (list-string tem)))) ; (let ((s (funcall win :get beg end :return 'string)) ; (j 0) i) ; (with-tk-command ; (pp "MultipleTagAdd" no_quote) ; (pp win normal) ; (pp "xref" normal) ; (pp beg normal) ; (pp "{" no_quote) ; (while (f >= (string-match pat s j) 0) ; (setq i (if (f >= (match-beginning 1) 0) 1 2)) ; (pp (match-beginning i) no_quote) ; (pp (match-end i) no_quote) ; (setq j (match-end 0)) ; ) ; (pp "}" no_quote) ; (send-tcl-cmd *tk-connection* tk-command nil))) ; (funcall win :tag :remove "possible_xref" beg end) ; ))))) (defun fix-xref (win &aux tem) (unless *recursive* (let* ((*recursive* t) (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) (end (funcall win :index "@0,1000 lineend" :return 'string))) (cond ((or (f >= (string-match "possible_xref" (funcall win :tag :names beg :return 'string)) 0) (not (equal "" (setq tem (funcall win :tag :nextrange "possible_xref" beg end :return 'string))))) (if tem (setq beg (car (list-string tem)))) (let ((s (funcall win :get beg end :return 'string)) (j 0) i) (while (f >= (string-match pat s j) 0) (setq i (if (f >= (match-beginning 1) 0) 1 (if (f >= (match-beginning 2) 0) 2 3))) (funcall win :tag :add "xref" beg : "+" : (match-beginning i) : " chars" beg : "+" : (match-end i) : " chars") (setq j (match-end 0)))) (funcall win :tag :remove "possible_xref" beg end) ))))) (defun insert-fontified (window string beg end) "set fonts in WINDOW for string with " ; (waiting window) ; (print (list beg end)) (insert-string-with-regexp window string beg end #u"\n([^\n]+)\n[.=_*-][.=*_-]+\n|\\*Note ([^:]+)::" '((1 section-header) (2 "xref") )) (funcall window :tag :add "possible_xref" "0.0" "end") (fix-xref window) (end-waiting window) ) (defun section-header (win string lis &aux (i (car lis))) (let ((mark 'insert)) (insert-string win string (match-beginning 0) (match-end i)) (funcall win :insert mark #u"\n") (funcall win :tag :add (cdr (assoc (aref string (f + (match-end i) 2)) '((#\= . "verybig") (#\_ . "big") (#\- . "big") (#\. . "bold") (#\* . "bold") ))) "insert - " : (f - (match-end i) (f + (match-beginning i ) -1 )) : " chars" "insert -1 chars") ;;make index count be same.. (let ((n (f - (f - (match-end 0) (match-end i)) 1))) (declare (fixnum n)) (if (>= n 0) (funcall win :insert mark (make-string n ))) ))) (defun insert-string (win string beg end) (and (> end beg) (let ((ar (make-array (- end beg) :element-type 'string-char :displaced-to string :displaced-index-offset beg))) (funcall win :insert 'insert ar)))) (defun insert-string-with-regexp (win string beg end regexp reg-actions &aux (i 0) temi (*window* win) *match-data*) (declare (special *window* *match-data*)) (declare (fixnum beg end i)) (while (f >= (string-match regexp string beg end) 0) (setq i 1) (setq temi nil) (loop (or (< i 10) (return nil)) (cond ((f >= (match-beginning i) 0) (setq temi (assoc i reg-actions)) (return nil))) (setq i (+ i 1))) (cond ;(t nil) ((functionp (second temi)) (insert-string win string beg (match-beginning 0)) (funcall (second temi) win string temi)) ((stringp (second temi)) (insert-string win string beg (match-end 0)) (dolist (v (cdr temi)) (funcall win :tag :add v "insert -" : (f - (match-end 0) (match-beginning i)) : " chars" "insert -" :(f - (match-end 0) (match-end i)): " chars" ) )) (t (info-error "bad regexp prop"))) (setq beg (match-end 0)) (or (<= beg end) (error "hi")) ) (insert-string win string beg end)) (defun count-char (ch string beg end &aux (count 0)) ; "Count the occurrences of CH in STRING from BEG to END" (declare (character ch)) (declare (string string)) (declare (fixnum beg end count)) (while (< beg end) (if (eql (aref string beg) ch) (incf count)) (incf beg)) count) (defun start-of-ith-line (count string beg &optional (end -1)) (declare (string string)) (declare (fixnum beg end count)) (if (< end 0) (setq end (length string))) (cond ((eql count 1) beg) (t (decf count) (while (< beg end) (if (eql (aref string beg) #\newline) (progn (decf count) (incf beg) (if (<= count 0) (return-from start-of-ith-line beg))) (incf beg))) beg))) (defun index-to-position (index string beg &optional (end -1) &aux (count 0)) ; "Find INDEX of form \"line.char\" in STRING with 0.0 at BEG and ; up to END. Result is a fixnum string index" (declare (string string index)) (declare (fixnum beg end count)) (if (< end 0) (setq end (length string))) (let* ((line (atoi index 0)) (charpos (atoi index (+ 1 (position #\. index))))) (declare (fixnum line charpos)) (setq count (start-of-ith-line line string beg end)) (print (list count charpos)) (+ count charpos))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** gcl-2.6.14/gcl-tk/gcl_guisl.h0000755000175000017500000000017714360276512014305 0ustar cammcamm static L1(); static L2(); static char * VVi[2]={ #define Cdata VV[1] (char *)(L1), (char *)(L2) }; #define VV ((object *)VVi) gcl-2.6.14/gcl-tk/tk-package.lsp0000755000175000017500000000153614360276512014713 0ustar cammcamm(in-package "TK" :use '("LISP" "SLOOP")) (in-package "SI") (import '( string begin end header name info-subfile file tags end-waiting si::match-beginning si::idescribe si::setup-info si::autoload si::idescribe si::*default-info-files* si::*info-paths* si::*info-window* si::info si::get-match si::print-node si::offer-choices si::match-end si::string-match si::*case-fold-search* si::*current-info-data* si::info-data si::node si::info-aux si::info-error si::*tk-library* si::*tk-connection* si::show-info si::tkconnect si::*match-data*) "TK") gcl-2.6.14/gcl-tk/tkl.lisp0000755000175000017500000014000214360276512013637 0ustar cammcamm;; Copyright (C) 1994 W. Schelter ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; (eval-when (load eval compile) (in-package "TK") ) (eval-when (compile) (proclaim '(ftype (function (t fixnum fixnum) fixnum) set-message-header get-number-string)) (proclaim '(ftype (function (t t fixnum) t) store-circle)) (proclaim '(ftype (function (t fixnum) t) get-circle)) (proclaim '(ftype (function (t fixnum fixnum fixnum) fixnum) push-number-string)) ) (defvar *tk-package* (find-package "TK")) (eval-when (compile eval load) (defconstant *header* '(magic1 magic2 type flag body-length nil nil msg-index nil nil)) ;;enum print_arglist_codes {..}; (defvar *print-arglist-codes* '( normal no_leading_space join_follows end_join begin_join begin_join_no_leading_space no_quote no_quote_no_leading_space no_quote_downcase no_quotes_and_no_leading_space )) (defconstant *mtypes* '( m_not_used m_create_command m_reply m_call m_tcl_command m_tcl_command_wait_response m_tcl_clear_connection m_tcl_link_text_variable m_set_lisp_loc m_tcl_set_text_variable m_tcl_unlink_text_variable m_lisp_eval m_lisp_eval_wait_response )) (defconstant *magic1* #\) (defconstant *magic2* #\A) (defvar *some-fixnums* (make-array 3 :element-type 'fixnum)) (defmacro msg-index () `(the fixnum (aref (the (array fixnum) *some-fixnums*) 0))) ;;; (defmacro safe-car (x) ;;; (cond ((symbolp x) `(if (consp ,x) (car ,x) (if (null ,x) nil ;;; (not-a-cons ,x)))) ;;; (t (let ((sym (gensym))) ;;; `(let ((,sym ,x)) ;;; (safe-car ,sym)))))) ;;; (defmacro safe-cdr (x) ;;; (cond ((symbolp x) `(if (consp ,x) (cdr ,x) (if (null ,x) nil ;;; (not-a-cons ,x)))) ;;; (t (let ((sym (gensym))) ;;; `(let ((,sym ,x)) ;;; (safe-cdr ,sym)))))) (defun desetq-consp-check (val) (or (consp val) (error "~a is not a cons" val))) (defun desetq1 (form val) (cond ((symbolp form) (cond (form ;(push form *desetq-binds*) `(setf ,form ,val)))) ((consp form) `(progn (desetq-consp-check ,val) ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) (defmacro while (test &body body) `(sloop while ,test do ,@ body)) ) (defmacro nth-value (n form) `(multiple-value-bind ,(make-list (+ n 1) :initial-element 'a) ,form a)) (defvar *tk-command* nil) (defvar *debugging* nil) (defvar *break-on-errors* nil) (defvar *tk-connection* nil ) ;; array of functions to be invoked from lisp. (defvar *call-backs* (make-array 20 :fill-pointer 0 :adjustable t )) ;;array of message half read. Ie read header but not body. (defvar *pending* nil) ;;circular array for replies,requests esp for debugging ;; replies is used for getting replies. (defvar *replies* (make-array (expt 2 7)) "circle of replies to requests in *requests*") ;; these are strings (defvar *requests* (make-array (expt 2 7))) ;; these are lisp forms (defvar *request-forms* (make-array 40)) (defvar *read-buffer* (make-array 400 :element-type 'standard-char :fill-pointer 0 :static t)) (defvar *text-variable-locations* (make-array 10 :fill-pointer 0 :adjustable t)) (defmacro pos (flag lis) (or (member flag (symbol-value lis)) (error "~a is not in ~a" flag lis)) (position flag (symbol-value lis))) ;;; (defun p1 (a &aux tem) ;;; ;;Used for putting A into a string for sending a command to TK ;;; (cond ;;; ((and (symbolp a) (setq tem (get a 'tk-print))) ;;; (format *tk-command* tem)) ;;; ((keywordp a) ;;; (format *tk-command* "-~(~a~)" a)) ;;; ((numberp a) ;;; (format *tk-command* "~a" a)) ;;; ((stringp a) ;;; (format *tk-command* "\"~a\"" a)) ;;; ((and (consp a)(eq (car a) 'a)) ;;; (format *tk-command* "~a" (cdr a))) ;;; ((and (consp a)(eq (car a) 'd)) ;;; (format *tk-command* "~(~a~)" (cdr a))) ;;; ((and (symbolp a) ;;; (eql (aref (symbol-name a) 0) ;;; #\.)) ;;; (format *tk-command* "~(~a~)" a)) ;;; (t (error "unrecognized term ~s" a)))) (defvar *command-strings* (sloop for i below 2 collect (make-array 200 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream ""))) (defmacro with-tk-command (&body body) `(let (tk-command (*command-strings* *command-strings*)) (declare (type string tk-command)) (setq tk-command (grab-tk-command)) ,@ body)) (defun grab-tk-command( &aux x) ;; keep a list of available *command-strings* and grab one (cond ((cdr *command-strings*)) (t (setq x (list (make-array 70 :element-type 'standard-char :fill-pointer 0 :adjustable t)) ) (or *command-strings* (error "how??")) (setq *command-strings* (nconc *command-strings* x)))) (let ((x (car *command-strings*))) (setq *command-strings* (cdr *command-strings*)) (setf (fill-pointer x ) #.(length *header*)) x )) (defun print-to-string (str x code) (cond ((consp x) (cond ((eq (car x) 'a) (setq x (cdr x) code (pos no_quote *print-arglist-codes*))) ((eq (car x) 'd) (setq x (cdr x) code (pos no_quote_downcase *print-arglist-codes*))) (t (error "bad arg ~a" x))))) (while (null (si::print-to-string1 str x code)) (cond ((typep x 'bignum) (setq x (format nil "~a" x))) (t (setq str (adjust-array str (the fixnum (+ (the fixnum (array-total-size str)) (the fixnum (+ (if (stringp x) (length (the string x)) 0) 70)))) :fill-pointer (fill-pointer str) :element-type 'string-char))))) str) (defmacro pp (x code) (let ((u `(pos ,code *print-arglist-codes*))) `(print-to-string tk-command ,x ,u))) (defun print-arglist (to-string l &aux v in-join x) ;; (sloop for v in l do (p :| | v)) (while l (setq v (cdr l)) (setq x (car l)) (cond ((eql (car v) ': ) (print-to-string to-string x (if in-join (pos join_follows *print-arglist-codes*) (pos begin_join *print-arglist-codes*))) (setq in-join t) (setq v (cdr v))) (in-join (print-to-string to-string x (pos end_join *print-arglist-codes*)) (setq in-join nil)) (t;; code == (pos normal *print-arglist-codes*) (print-to-string to-string x (pos normal *print-arglist-codes*)))) (setq l v) )) (defmacro p (&rest l) `(progn ,@ (sloop for v in l collect `(p1 ,v)))) (defvar *send-and-wait* nil "If not nil, then wait for answer and check result") (defun tk-call (fun &rest l &aux result-type) (with-tk-command (pp fun no_leading_space) (setq result-type (prescan-arglist l nil nil)) (print-arglist tk-command l) (cond (result-type (call-with-result-type tk-command result-type)) (t (send-tcl-cmd *tk-connection* tk-command nil) (values))))) (defun tk-do (str &rest l &aux ) (with-tk-command (pp str no_quotes_and_no_leading_space) ;; leading keyword printed without '-' at beginning. (while l (pp (car l) no_quotes_and_no_leading_space) (setq l (cdr l))) (call-with-result-type tk-command 'string))) (defun tk-do-no-wait (str &aux (n (length str))) (with-tk-command (si::copy-array-portion str tk-command 0 #.(length *header*) n) (setf (fill-pointer tk-command) (the fixnum (+ n #.(length *header*)))) (let () (send-tcl-cmd *tk-connection* tk-command nil)))) (defun fsubseq (s &optional (b 0) (e (length s))) (make-array (- e b) :element-type (array-element-type s) :displaced-to s :displaced-index-offset b :fill-pointer (- e b))) (defun send-tcl-cmd (c str send-and-wait ) ;(notice-text-variables) (or send-and-wait (setq send-and-wait *send-and-wait*)) ; (setq send-and-wait t) (vector-push-extend (code-char 0) str) (let ((msg-id (set-message-header str (if send-and-wait (pos m_tcl_command_wait_response *mtypes*) (pos m_tcl_command *mtypes*)) (the fixnum (- (length str) #.(length *header*)))))) (cond (send-and-wait (if *debugging* (store-circle *requests* (fsubseq str #.(length *header*)) msg-id)) (store-circle *replies* nil msg-id) (execute-tcl-cmd c str)) (t (store-circle *requests* nil msg-id) (write-to-connection c str))))) (defun send-tcl-create-command (c str) (vector-push-extend (code-char 0) str) (set-message-header str (pos m_create_command *mtypes*) (- (length str) #.(length *header*))) (write-to-connection c str)) (defun write-to-connection (con string &aux tem) (let* ((*sigusr1* t) ;; dont let us get interrupted while writing!! (n (length string)) (fd (caar con)) (m 0)) (declare (Fixnum n m)) (or con (error "Trying to write to non open connection ")) (if *debugging* (describe-message string)) (or (typep fd 'string) (error "~a is not a connection" con)) (setq m (si::our-write fd string n)) (or (eql m n) (error "Failed to write ~a bytes to file descriptor ~a" n fd)) (setq tem *sigusr1*) ;; a signal at this instruction would not be noticed...since it ;; would set *sigusr1* to :received but that would be too late for tem ;; since the old value will be popped off the binding stack at the next 'paren' ) (cond ((eq tem :received) (read-and-act nil))) t) (defun coerce-string (a) (cond ((stringp a) a) ((fixnump a) (format nil "~a" a)) ((numberp a) (format nil "~,2f" (float a))) ((keywordp a) (format nil "-~(~a~)" a)) ((symbolp a) (format nil "~(~a~)" a)) (t (error "bad type")))) ;;2 decimals (defun my-conc (a b) (setq a (coerce-string a)) (setq b (coerce-string b)) (concatenate 'string a b )) ;; In an arglist 'a : b' <==> (tk-conc a b) ;; eg: 1 : "b" <==> "1b" ; "c" : "b" <==> "cb" ; 'a : "b" <==> "ab" ; '.a : '.b <==> ".a.b" ; ':ab : "b" <==> "abb" ;;Convenience for concatenating symbols, strings, numbers ;; (tk-conc '.joe.bill ".frame.list yview " 3) ==> ".joe.bill.frame.list yview 3" (defun tk-conc (&rest l) (declare (:dynamic-extent l)) (let ((tk-command (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (cond ((null l)) (t (pp (car l) no_quote_no_leading_space))) (setq l (cdr l)) (while (cdr l) (pp (car l) join_follows) (setq l (cdr l))) (and l (pp (car l) no_quote_no_leading_space)) tk-command )) ;;; (defun verify-list (l) ;;; (loop ;;; (cond ((null l)(return t)) ;;; ((consp l) (setq l (cdr l))) ;;; (t (error "not a true list ~s"l))))) ;;; (defun prescan-arglist (l pathname name-caller &aux result-type) ;;; (let ((v l) tem prev a b c) ;;; (verify-list l) ;;; (sloop while v ;;; do ;;; (cond ;;; ((keywordp (car v)) ;;; (setq a (car v)) ;;; (setq c (cdr v)) ;;; (setq b (car c) c (cadr c)) ;;; (cond ((eq a :bind) ;;; (cond ((setq tem (cdddr v)) ;;; (or (eq (cadr tem) ': ) ;;; (setf (car tem) ;;; (tcl-create-command (car tem) ;;; nil ;;; t)))))) ;;; ((eq c ': )) ;;; ((member a'(:yscroll :command ;;; :xscroll ;;; :yscrollcommand ;;; :xscrollcommand ;;; :scrollcommand ;;; )) ;;; (cond ((setq tem (cdr v)) ;;; (setf (car tem) ;;; (tcl-create-command (car tem) ;;; (or (get a 'command-arg) ;;; (get name-caller ;;; 'command-arg)) ;;; nil))))) ;;; ((eq (car v) :return) ;;; (setf result-type (cadr v)) ;;; (cond (prev ;;; (setf (cdr prev) (cddr v))) ;;; (t (setf (car v) '(a . "")) ;;; (setf (cdr v) (cddr v))))) ;;; ((eq (car v) :textvariable) ;;; (setf (second v) (link-variable b 'string))) ;;; ((member (car v) '(:value :onvalue :offvalue)) ;;; (let* ((va (get pathname 'variable)) ;;; (type (get va 'linked-variable-type)) ;;; (fun (cdr (get type ;;; 'coercion-functions)))) ;;; (or va ;;; (error ;;; "Must specify :variable before :value so that we know the type")) ;;; (or fun (error "No coercion-functions for type ~s" type)) ;;; (setf (cadr v) (funcall fun b)))) ;;; ((eq (car v) :variable) ;;; (let ((va (second v)) ;;; (type (cond ((eql name-caller 'checkbutton) 'boolean) ;;; (t 'string)))) ;;; (cond ((consp va) ;;; (desetq (type va) va) ;;; (or (symbolp va) ;;; (error "should be :variable (type symbol)")))) ;;; (setf (get pathname 'variable) va) ;;; (setf (second v) ;;; (link-variable va type)))) ;;; ))) ;;; (setq prev v) ;;; (setq v (cdr v)) ;;; )) ;;; result-type ;;; ) (defun prescan-arglist (l pathname name-caller &aux result-type) (let ((v l) tem prev a ) ; (verify-list l) ; unnecessary all are from &rest args. ; If pathname supplied, then this should be an alternating list ;; of keywords and values..... (sloop while v do (setq a (car v)) (cond ((keywordp a) (cond ((eq (car v) :return) (setf result-type (cadr v)) (cond (prev (setf (cdr prev) (cddr v))) (t (setf (car v) '(a . "")) (setf (cdr v) (cddr v))))) ((setq tem (get a 'prescan-function)) (funcall tem a v pathname name-caller))))) (setq prev v) (setq v (cdr v))) result-type)) (eval-when (compile eval load) (defun set-prescan-function (fun &rest l) (dolist (v l) (setf (get v 'prescan-function) fun))) ) (set-prescan-function 'prescan-bind :bind) (defun prescan-bind (x v pathname name-caller &aux tem) name-caller pathname x (cond ((setq tem (cdddr v)) (or (keywordp (car tem)) (eq (cadr tem) ': ) (setf (car tem) (tcl-create-command (car tem) nil t)))))) (set-prescan-function 'prescan-command :yscroll :command :postcommand :xscroll :yscrollcommand :xscrollcommand :scrollcommand) (defun prescan-command (x v pathname name-caller &aux tem arg) x pathname (setq arg (cond (( member v '(:xscroll :yscrollcommand :xscrollcommand :scrollcommand)) 'aaaa) ((get name-caller 'command-arg)))) (cond ((setq tem (cdr v)) (cond ((eq (car tem) :return ) :return) (t (setf (car tem) (tcl-create-command (car tem) arg nil))))))) (defun prescan-value (a v pathname name-caller) a name-caller (let* ((va (get pathname ':variable)) (type (get va 'linked-variable-type)) (fun (cdr (get type 'coercion-functions)))) (or va (error "Must specify :variable before :value so that we know the type")) (or fun (error "No coercion-functions for type ~s" type)) (setq v (cdr v)) (if v (setf (car v) (funcall fun (car v)))))) (set-prescan-function 'prescan-value :value :onvalue :offvalue) (set-prescan-function #'(lambda (a v pathname name-caller) a (let ((va (second v)) (type (cond ((eql name-caller 'checkbutton) 'boolean) (t 'string)))) (cond ((consp va) (desetq (type va) va) (or (symbolp va) (error "should be :variable (type symbol)")))) (cond (va (setf (get pathname a) va) (setf (second v) (link-variable va type)))))) :variable :textvariable) (defun make-widget-instance (pathname widget) ;; ??make these not wait for response unless user is doing debugging.. (or (symbolp pathname) (error "must give a symbol")) #'(lambda ( &rest l &aux result-type (option (car l))) (declare (:dynamic-extent l)) (setq result-type (prescan-arglist l pathname widget)) (if (and *break-on-errors* (not result-type)) (store-circle *request-forms* (cons pathname (copy-list l)) (msg-index))) (with-tk-command (pp pathname no_leading_space) ;; the leading keyword gets printed with no leading - (or (keywordp option) (error "First arg to ~s must be an option keyword not ~s" pathname option )) (pp option no_quote) (setq l (cdr l)) ;(print (car l)) (cond ((and (keywordp (car l)) (not (eq option :configure)) (not (eq option :config)) (not (eq option :itemconfig)) (not (eq option :cget)) (not (eq option :postscript)) ) (pp (car l) no_quote) (setq l (cdr l)))) (print-arglist tk-command l) (cond (result-type (call-with-result-type tk-command result-type)) (t (send-tcl-cmd *tk-connection* tk-command nil) (values)))))) (defmacro def-widget (widget &key (command-arg 'sssss)) `(eval-when (compile eval load) (setf (get ',widget 'command-arg) ',command-arg) (defun ,widget (pathname &rest l)(declare (:dynamic-extent l)) (widget-function ',widget pathname l)))) ;; comand-arg "asaa" means pass second arg back as string, and others not quoted ;; ??make these always wait for response ;; since creating a window failure is likely to cause many failures. (defun widget-function (widget pathname l ) (or (symbolp pathname) (error "First arg to ~s must be a symbol not ~s" widget pathname)) (if *break-on-errors* (store-circle *request-forms* (cons pathname (copy-list l)) (msg-index))) (prescan-arglist l pathname widget) (with-tk-command (pp widget no_leading_space) (pp pathname normal) (print-arglist tk-command l ) (multiple-value-bind (res success) (send-tcl-cmd *tk-connection* tk-command t) (if success (setf (symbol-function pathname) (make-widget-instance pathname widget)) (error "Cant define ~(~a~) pathnamed ~(~a~): ~a" widget pathname res))) pathname)) (def-widget button) (def-widget listbox) (def-widget scale :command-arg a) (def-widget canvas) (def-widget menu) (def-widget scrollbar) (def-widget checkbutton) (def-widget menubutton) (def-widget text) (def-widget entry) (def-widget message) (def-widget frame) (def-widget label) (def-widget |image create photo|) (def-widget |image create bitmap|) (def-widget radiobutton) (def-widget toplevel) (defmacro def-control (name &key print-name before) (cond ((null print-name )(setq print-name name)) (t (setq print-name (cons 'a print-name)))) `(defun ,name (&rest l) ,@ (if before `((,before ',print-name l))) (control-function ',print-name l))) (defun call-with-result-type (tk-command result-type) (multiple-value-bind (res suc) (send-tcl-cmd *tk-connection* tk-command t) (values (if result-type (coerce-result res result-type) res) suc))) (defun control-function (name l &aux result-type) ;(store-circle *request-forms* (cons name l) (msg-index)) (setq result-type (prescan-arglist l nil name)) (with-tk-command (pp name normal) ;; leading keyword printed without '-' at beginning. (cond ((keywordp (car l)) (pp (car l) no_quote) (setq l (cdr l)))) (print-arglist tk-command l) (call-with-result-type tk-command result-type))) (dolist (v '( |%%| |%#| |%a| |%b| |%c| |%d| |%f| |%h| |%k| |%m| |%o| |%p| |%s| |%t| |%v| |%w| |%x| |%y| |%A| |%B| |%D| |%E| |%K| |%N| |%R| |%S| |%T| |%W| |%X| |%Y|)) (progn (setf (get v 'event-symbol) (symbol-name v)) (or (member v '(|%d| |%m| |%p| |%K| ;|%W| |%A|)) (setf (get v 'event-symbol) (cons (get v 'event-symbol) 'fixnum ))))) (defvar *percent-symbols-used* nil) (defun get-per-cent-symbols (expr) (cond ((atom expr) (and (symbolp expr) (get expr 'event-symbol) (pushnew expr *percent-symbols-used*))) (t (get-per-cent-symbols (car expr)) (setq expr (cdr expr)) (get-per-cent-symbols expr)))) (defun reserve-call-back ( &aux ind) (setq ind (fill-pointer *call-backs*)) (vector-push-extend nil *call-backs* ) ind) ;; The command arg: ;; For bind windowSpec SEQUENCE COMMAND ;; COMMAND is called when the event SEQUENCE occurs to windowSpec. ;; If COMMAND is a symbol or satisfies (functionp COMMAND), then ;; it will be funcalled. The number of args supplied in this ;; case is determined by the widget... for example a COMMAND for the ;; scale widget will be supplied exactly 1 argument. ;; If COMMAND is a string then this will be passed to the graphics ;; interpreter with no change, ;; This allows invoking of builtin functionality, without bothering the lisp process. ;; If COMMAND is a lisp expression to eval, and it may reference ;; details of the event via the % constructs eg: %K refers to the keysym ;; of the key pressed (case of BIND only). A function whose body is the ;; form, will actually be constructed which takes as args all the % variables ;; actually appearing in the form. The body of the function will be the form. ;; Thus (print (list |%w| %W) would turn into #'(lambda(|%w| %W) (print (list |%w| %W))) ;; and when invoked it would be supplied with the correct args. (defvar *arglist* nil) (defun tcl-create-command (command arg-data allow-percent-data) (with-tk-command (cond ((or (null command) (equal command "")) (return-from tcl-create-command "")) ((stringp command) (return-from tcl-create-command command))) (let (*percent-symbols-used* tem ans name ind) (setq ind (reserve-call-back)) (setq name (format nil "callback_~d" ind)) ;; install in tk the knowledge that callback_ind will call back to here. ;; and tell it arg types expected. ;; the percent commands are handled differently (push-number-string tk-command ind #.(length *header*) 3) (setf (fill-pointer tk-command) #.(+ (length *header*) 3)) (if arg-data (pp arg-data no_leading_space)) (send-tcl-create-command *tk-connection* tk-command) (if (and arg-data allow-percent-data) (error "arg data and percent data not allowed")) (cond ((or (symbolp command) (functionp command))) (allow-percent-data (get-per-cent-symbols command) (and *percent-symbols-used* (setq ans "")) (sloop for v in *percent-symbols-used* do (setq tem (get v 'event-symbol)) (cond ((stringp tem) (setq ans (format nil "~a \"~a\"" ans tem))) ((eql (cdr tem) 'fixnum) (setq ans (format nil "~a ~a" ans (car tem)))) (t (error "bad arg")))) (if ans (setq ans (concatenate 'string "{(" ans ")}"))) (setq command `(lambda ,*percent-symbols-used* ,command)) (if ans (setq name (concatenate 'string "{"name " " ans"}")))) (t (setq command `(lambda (&rest *arglist*) ,command)))) (setf (aref *call-backs* ind) command) ;; the command must NOT appear as "{[...]}" or it will be eval'd. (cons 'a name) ))) (defun bind (window-spec &optional sequence command type) "command may be a function name, or an expression which may involve occurrences of elements of *percent-symbols* The expression will be evaluated in an enviroment in which each of the % symbols is bound to the value of the corresponding event value obtained from TK." (cond ((equal sequence :return) (setq sequence nil) (setq command nil))) (cond ((equal command :return) (or (eq type 'string) (tkerror "bind only returns type string")) (setq command nil)) (command (setq command (tcl-create-command command nil t)))) (with-tk-command (pp 'bind no_leading_space) (pp window-spec normal) (and sequence (pp sequence normal)) (and command (pp command normal)) (send-tcl-cmd *tk-connection* tk-command (or (null sequence)(null command))))) (defmacro tk-connection-fd (x) `(caar ,x)) (def-control after) (def-control exit) (def-control lower) (def-control place) (def-control send) (def-control tkvars) (def-control winfo) (def-control focus) (def-control option) (def-control raise) (def-control tk) ;; problem on waiting. Waiting for dialog to kill self ;; wont work because the wait blocks even messages which go ;; to say to kill... ;; must use ;; (grab :set :global .fo) ;; and sometimes the gcltkaux gets blocked and cant accept input when ;; in grabbed state... (def-control tkwait) (def-control wm) (def-control destroy :before destroy-aux) (def-control grab) (def-control pack) (def-control selection) (def-control tkerror) (def-control update) (def-control tk-listbox-single-select :print-name "tk_listboxSingleSelect") (def-control tk-menu-bar :print-name "tk_menuBar") (def-control tk-dialog :print-name "tk_dialog") (def-control get_tag_range) (def-control lsearch) (def-control lindex) (defun tk-wait-til-exists (win) (tk-do (tk-conc "if ([winfo exists " win " ]) { } else {tkwait visibility " win "}"))) (defun destroy-aux (name l) name (dolist (v l) (cond ((stringp v)) ((symbolp v) (dolist (prop '(:variable :textvariable)) (remprop v prop)) (fmakunbound v) ) (t (error "not a pathname : ~s" v)))) ) (defvar *default-timeout* (* 100 internal-time-units-per-second)) (defun execute-tcl-cmd (connection cmd) (let (id tem (time *default-timeout*)) (declare (fixnum time)) (setq id (get-number-string cmd (pos msg-index *header*) 3)) (store-circle *replies* nil id) (write-to-connection connection cmd) (loop (cond ((setq tem (get-circle *replies* id)) (cond ((or (car tem) (null *break-on-errors*)) (return-from execute-tcl-cmd (values (cdr tem) (car tem)))) (t (cerror "Type :r to continue" "Cmd failed: ~a : ~a " (subseq cmd (length *header*) (- (length cmd) 1) ) (cdr tem)) (return (cdr tem)) )))) (cond ((> (si::check-state-input (tk-connection-fd connection) 10) 0) (read-and-act id) )) (setq time (- time 10)) (cond ((< time 0) (cerror ":r resumes waiting for *default-timeout*" "Did not get a reply for cmd ~a" cmd) (setq time *default-timeout*) ))))) (defun push-number-string (string number ind bytes ) (declare (fixnum ind number bytes)) ;; a number #xabcdef is stored "" where is (code-char #xef) (declare (string string)) (declare (fixnum number bytes )) (sloop while (>= bytes 1) do (setf (aref string ind) (the character (code-char (the fixnum(logand number 255))))) (setq ind (+ ind 1)) (setq bytes (- bytes 1)) ; (setq number (* number 256)) (setq number (ash number -8)) nil)) (defun get-number-string (string start bytes &aux (number 0)) ;; a number #xabcdef is stored "" where is (code-char #xef) (declare (string string)) (declare (fixnum number bytes start)) (setq start (+ start (the fixnum (- bytes 1)))) (sloop while (>= bytes 1) do (setq number (+ number (char-code (aref string start)))) (setq start (- start 1) bytes (- bytes 1)) (cond ((> bytes 0) (setq number (ash number 8))) (t (return number))))) (defun quit () (tkdisconnect) (bye)) (defun debugging (x) (setq *debugging* x)) (defmacro dformat (&rest l) `(if *debugging* (dformat1 ,@l))) (defun dformat1 (&rest l) (declare (:dynamic-extent l)) (format *debug-io* "~%Lisp:") (apply 'format *debug-io* l)) (defvar *sigusr1* nil) ;;??NOTE NOTE we need to make it so that if doing code inside an interrupt, ;;then we do NOT do a gc for relocatable. This will kill US. ;;One hack would be that if relocatable is low or cant be grown.. then ;;we just set a flag which says run our sigusr1 code at the next cons... ;;and dont do anything here. Actually we can always grow relocatable via sbrk, ;;so i think it is ok.....??...... (defun system::sigusr1-interrupt (x) x (cond (*sigusr1* (setq *sigusr1* :received)) (*tk-connection* (let ((*sigusr1* t)) (dformat "Received SIGUSR1. ~a" (if (> (si::check-state-input (tk-connection-fd *tk-connection*) 0) 0) "" "No Data left there.")) ;; we put 4 here to wait for a bit just in case ;; data comes (si::check-state-input (tk-connection-fd *tk-connection*) 4 ) (read-and-act nil))))) (setf (symbol-function 'si::SIGIO-INTERRUPT) (symbol-function 'si::sigusr1-interrupt)) (defun store-circle (ar reply id) (declare (type (array t) ar) (fixnum id)) (setf (aref ar (the fixnum (mod id (length ar)))) reply)) (defun get-circle (ar id) (declare (type (array t) ar) (fixnum id)) (aref ar (the fixnum (mod id (length ar))))) (defun decode-response (str &aux reply-from ) (setq reply-from (get-number-string str #.(+ 1 (length *header*)) 3)) (values (fsubseq str #.(+ 4 (length *header*))) (eql (aref str #.(+ 1 (length *header*))) #\0) reply-from (get-circle *requests* reply-from))) (defun describe-message (vec) (let ((body-length (get-number-string vec (pos body-length *header*) 3)) (msg-index (get-number-string vec (pos msg-index *header*) 3)) (mtype (nth (char-code (aref vec (pos type *header*))) *mtypes*)) success from-id requ ) (format t "~%Msg-id=~a, type=~a, leng=~a, " msg-index mtype body-length) (case mtype (m_reply (setq from-id (get-number-string vec #.(+ 1 (length *header*)) 3)) (setq success (eql (aref vec #.(+ 0 (length *header*))) #\0)) (setq requ (get-circle *requests* from-id)) (format t "result-code=~a[bod:~s](form msg ~a)[hdr:~s]" success (subseq vec #.(+ 4 (length *header*))) from-id (subseq vec 0 (length *header*)) ) ) ((m_create_command m_call m_lisp_eval m_lisp_eval_wait_response) (let ((islot (get-number-string vec #.(+ 0 (length *header*)) 3))) (format t "islot=~a(callback_~a), arglist=~s" islot islot (subseq vec #.(+ 3 (length *header*)))))) ((m_tcl_command m_tcl_command_wait_response M_TCL_CLEAR_CONNECTION ) (format t "body=[~a]" (subseq vec (length *header*)) )) ((m_tcl_set_text_variable) (let* ((bod (subseq vec (length *header*))) (end (position (code-char 0) bod)) (var (subseq bod 0 end))) (format t "name=~s,val=[~a],body=" var (subseq bod (+ 1 end) (- (length bod) 1)) bod))) ((m_tcl_link_text_variable m_tcl_unlink_text_variable m_set_lisp_loc) (let (var (islot (get-number-string vec #.(+ 0 (length *header*)) 3))) (format t "array_slot=~a,name=~s,type=~s body=[~a]" islot (setq var (aref *text-variable-locations* islot)) (get var 'linked-variable-type) (subseq vec #.(+ 3 (length *header*)))))) (otherwise (error "unknown message type ~a [~s]" mtype vec ))))) (defun clear-tk-connection () ;; flush both sides of connection and discard any partial command. (cond (*tk-connection* (si::clear-connection-state (car (car *tk-connection*))) (setq *pending* nil) (with-tk-command (set-message-header tk-command (pos m_tcl_clear_connection *mtypes*) 0) (write-to-connection *tk-connection* tk-command)) ))) (defun read-tk-message (ar connection timeout &aux (n-read 0)) (declare (fixnum timeout n-read) (string ar)) (cond (*pending* (read-message-body *pending* connection timeout))) (setq n-read(si::our-read-with-offset (tk-connection-fd connection) ar 0 #.(length *header*) timeout)) (setq *pending* ar) (cond ((not (eql n-read #.(length *header*))) (cond ((< n-read 0) (tkdisconnect) (cerror ":r to resume " "Read got an error, have closed connection")) (t (error "Bad tk message")))) (t (or (and (eql (aref ar (pos magic1 *header*)) *magic1*) (eql (aref ar (pos magic2 *header*)) *magic2*)) (error "Bad magic")) (read-message-body ar connection timeout)))) (defun read-message-body (ar connection timeout &aux (m 0) (n-read 0)) (declare (fixnum m n-read)) (setq m (get-number-string ar (pos body-length *header*) 3)) (or (>= (array-total-size ar) (the fixnum (+ m #.(length *header*)))) (setq ar (adjust-array ar (the fixnum (+ m 40))))) (cond (*pending* (setq n-read (si::our-read-with-offset (tk-connection-fd connection) ar #.(length *header*) m timeout)) (setq *pending* nil) (or (eql n-read m) (error "Failed to read ~a bytes" m)) (setf (fill-pointer ar) (the fixnum (+ m #.(length *header*)))))) (if *debugging* (describe-message ar)) ar) (defun tkdisconnect () (cond (*tk-connection* (si::close-sd (caar *tk-connection*)) (si::close-fd (cadr *tk-connection*)))) (setq *sigusr1* t);; disable it... (setq *pending* nil) (setf *tk-connection* nil) ) (defun read-and-act (id) id (when *tk-connection* (let* ((*sigusr1* t) tem fun string) (with-tk-command (tagbody TOP (or (> (si::check-state-input (tk-connection-fd *tk-connection*) 0) 0) (return-from read-and-act)) (setq string (read-tk-message tk-command *tk-connection* *default-timeout*)) (let ((type (char-code (aref string (pos type *header*)))) from-id success) (case type (#.(pos m_reply *mtypes*) (setq from-id (get-number-string tk-command #.(+ 1 (length *header*)) 3)) (setq success (eql (aref tk-command #.(+ 0 (length *header*))) #\0)) (cond ((and (not success) *break-on-errors* (not (get-circle *requests* from-id))) (cerror ":r to resume ignoring" "request ~s failed: ~s" (or (get-circle *request-forms* from-id) "") (subseq tk-command #.(+ 4 (length *header*)))))) (store-circle *replies* (cons success (if (eql (length tk-command) #.(+ 4 (length *header*))) "" (fsubseq tk-command #.(+ 4 (length *header*))))) from-id)) (#.(pos m_call *mtypes*) ;; Can play a game of if read-and-act called with request-id: ;; When we send a request which waits for an m_reply, we note ;; at SEND time, the last message id received from tk. We ;; dont process any funcall's with lower id than this id, ;; until after we get the m_reply back from tk. (let ((islot (get-number-string tk-command #.(+ 0 (length *header*))3)) (n (length tk-command))) (declare (fixnum islot n)) (setq tem (our-read-from-string tk-command #.(+ 0 (length *header*)3))) (or (< islot (length *call-backs*)) (error "out of bounds call back??")) (setq fun (aref (the (array t) *call-backs*) islot)) (cond ((equal n #.(+ 3 (length *header*))) (funcall fun)) (t (setq tem (our-read-from-string tk-command #.(+ 3(length *header*)))) (cond ((null tem) (funcall fun)) ((consp tem) (apply fun tem)) (t (error "bad m_call message "))))))) (#.(pos m_set_lisp_loc *mtypes*) (let* ((lisp-var-id (get-number-string tk-command #.(+ 0 (length *header*)) 3)) (var (aref *text-variable-locations* lisp-var-id)) (type (get var 'linked-variable-type)) val) (setq val (coerce-result (fsubseq tk-command #.(+ 3 (length *header*))) type)) (setf (aref *text-variable-locations* (the fixnum ( + lisp-var-id 1))) val) (set var val))) (otherwise (format t "Unknown response back ~a" tk-command))) (if (eql *sigusr1* :received) (dformat "<>")) (go TOP) )))))) (defun our-read-from-string (string start) (let* ((s (car *string-streams*)) (*string-streams* (cdr *string-streams*))) (or s (setq s (make-string-input-stream ""))) (assert (array-has-fill-pointer-p string)) (setf (fill-pointer string) start) (si::c-set-stream-object0 s string) (read s nil nil))) (defun atoi (string) (if (numberp string) string (our-read-from-string string 0))) (defun conc (a b &rest l &aux tem) (declare (:dynamic-extent l)) (sloop do (or (symbolp a) (error "not a symbol ~s" a)) ; (or (symbolp b) (error "not a symbol ~s" b)) (cond ((setq tem (get a b))) (t (setf (get a b) (setq tem (intern (format nil "~a~a" a b) *tk-package* ))))) while l do (setq a tem b (car l) l (cdr l))) tem) (defun dpos (x) (wm :geometry x "+60+25")) (defun string-list (x) (let ((tk-command (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t))) (string-list1 tk-command x) tk-command)) (defun string-list1 (tk-command l &aux x) ;; turn a list into a tk list (desetq (x . l) l) (pp x no_leading_space) (while l (desetq (x . l) l) (cond ((atom x) (pp x normal)) ((consp x) (pp "{" no_quote) (string-list1 tk-command x) (pp '} no_leading_space))))) (defun list-string (x &aux (brace-level 0) skipping (ch #\space) (n (length x)) ) (declare (Fixnum brace-level n) (string x) (character ch)) (if (eql n 0) (return-from list-string nil)) (sloop for i below n with beg = 0 and ans do (setq ch (aref x i)) (cond ((eql ch #\space) (cond (skipping nil) ((eql brace-level 0) (if (> i beg) (setq ans (cons (fsubseq x beg i) ans))) (setq beg (+ i 1)) ))) (t (cond (skipping (setq skipping nil) (setq beg i))) (case ch (#\{ (cond ((eql brace-level 0) (setq beg (+ i 1)))) (incf brace-level)) (#\} (cond ((eql brace-level 1) (setq ans (cons (fsubseq x beg i) ans)) (setq skipping t))) (incf brace-level -1))))) finally (unless skipping (setq ans (cons (fsubseq x beg i) ans))) (return (nreverse ans)) )) ;; unless keyword :integer-value, :string-value, :list-strings, :list-forms ;; (foo :return 'list) "ab 2 3" --> (ab 2 3) ;; (foo :return 'list-strings) "ab 2 3" --> ("ab" "2" "3") ;;ie ;; (foo :return 'string) "ab 2 3" --> "ab 2 3" ;; (foo :return 't) "ab 2 3" --> AB ;; (foo :return 'boolean) "1" --> t (defun coerce-result (string key) (case key (list (our-read-from-string (tk-conc "("string ")") 0)) (string string) (number (our-read-from-string string 0)) ((t) (our-read-from-string string 0)) (t (let ((funs (get key 'coercion-functions))) (cond ((null funs) (error "Undefined coercion for type ~s" key))) (funcall (car funs) string))))) ;;convert "2c" into screen units or points or something... )) ;; If loc is suitable for handing to setf, then ;; (setf loc (coerce-result val type) ;; (radio-button (defvar *unbound-var* "") (defun link-variable (var type) (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) tem ) (declare (fixnum i n) (type (array (t)) ar)) (cond ((stringp var) (return-from link-variable var)) ((symbolp var)) ((and (consp var) (consp (cdr var))) (setq type (car var)) (setq var (cadr var)))) (or (and (symbolp type) (get type 'coercion-functions)) (error "Need coercion functions for type ~s" type)) (or (symbolp var) (error "illegal text variable ~s" var)) (setq tem (get var 'linked-variable-type)) (unless (if (and tem (not (eq tem type))) (format t "~%;;Warning: ~s had type ~s, is being changed to type ~s" var tem type ))) (setf (get var 'linked-variable-type) type) (while (< i n) (cond ((eq (aref ar i) var) (return-from link-variable var)) ((null (aref ar i)) (return nil)) (t (setq i (+ i 2))))) ;; i is positioned at the write place (cond ((= i n) (vector-push-extend nil ar) (vector-push-extend nil ar))) (setf (aref ar i) var) (setf (aref ar (the fixnum (+ i 1))) (if (boundp var) (symbol-value var) *unbound-var*)) (with-tk-command (push-number-string tk-command i #.(length *header*) 3) (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quotes_and_no_leading_space) (vector-push-extend (code-char 0) tk-command) (set-message-header tk-command (pos m_tcl_link_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command))) (notice-text-variables) var) (defun unlink-variable (var ) (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) ) (declare (fixnum i n) (type (array (t)) ar)) (while (< i n) (cond ((eq (aref ar i) var) (setf (aref ar i) nil) (setf (aref ar (+ i 1)) nil) (return nil) ) (t (setq i (+ i 2))))) (cond ((< i n) (with-tk-command (push-number-string tk-command i #.(length *header*) 3) (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quotes_and_no_leading_space) (vector-push-extend (code-char 0) tk-command) (set-message-header tk-command (pos m_tcl_unlink_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command)) var)))) (defun notice-text-variables () (let* ((i 0) (ar *text-variable-locations*) (n (length ar)) tem var type ) (declare (fixnum i n) (type (array (t)) ar)) (tagbody (while (< i n) (unless (or (not (boundp (setq var (aref ar i)))) (eq (setq tem (symbol-value var)) (aref ar (the fixnum (+ i 1))))) (setf (aref ar (the fixnum (+ i 1))) tem) (setq type (get var 'linked-variable-type)) (with-tk-command ;(push-number-string tk-command i #.(length *header*) 3) ;(setf (fill-pointer tk-command) #. (+ 3 (length *header*))) (pp var no_quote_no_leading_space) (vector-push (code-char 0) tk-command ) (case type (string (or (stringp tem) (go error))) (number (or (numberp tem) (go error))) ((t) (setq tem (format nil "~s" tem ))) (t (let ((funs (get type 'coercion-functions))) (or funs (error "no writer for type ~a" type)) (setq tem (funcall (cdr funs) tem))))) (pp tem no_quotes_and_no_leading_space) (vector-push (code-char 0) tk-command ) (set-message-header tk-command (pos m_tcl_set_text_variable *mtypes*) (- (length tk-command) #.(length *header*))) (write-to-connection *tk-connection* tk-command))) (setq i (+ i 2))) (return-from notice-text-variables) error (error "~s has value ~s which is not of type ~s" (aref ar i) tem type) ))) (defmacro setk (&rest l) `(prog1 (setf ,@ l) (notice-text-variables))) (setf (get 'boolean 'coercion-functions) (cons #'(lambda (x &aux (ch (aref x 0))) (cond ((eql ch #\0) nil) ((eql ch #\1) t) (t (error "non boolean value ~s" x)))) #'(lambda (x) (if x "1" "0")))) (setf (get 't 'coercion-functions) (cons #'(lambda (x) (our-read-from-string x 0)) #'(lambda (x) (format nil "~s" x)))) (setf (get 'string 'coercion-functions) (cons #'(lambda (x) (cond ((stringp x) x) (t (format nil "~s" x)))) 'identity)) (setf (get 'list-strings 'coercion-functions) (cons 'list-string 'list-to-string)) (defun list-to-string (l &aux (x l) v (start t)) (with-tk-command (while x (cond ((consp x) (setq v (car x))) (t (error "Not a true list ~s" l))) (cond (start (pp v no_leading_space) (setq start nil)) (t (pp v normal))) (setf x (cdr x))) (fsubseq tk-command #.(length *header*)))) (defvar *tk-library* nil) (defun tkconnect (&key host can-rsh gcltksrv (display (si::getenv "DISPLAY")) (args "") &aux hostid (loopback "127.0.0.1")) (if *tk-connection* (tkdisconnect)) (or display (error "DISPLAY not set")) (or *tk-library* (setq *tk-library* (si::getenv "TK_LIBRARY"))) (or gcltksrv (setq gcltksrv (cond (host "gcltksrv") ((si::getenv "GCL_TK_SERVER")) ((probe-file (tk-conc si::*lib-directory* "gcl-tk/gcltksrv"))) (t (error "Must setenv GCL_TK_SERVER "))))) (let ((pid (if host -1 (si::getpid))) (tk-socket (si::open-named-socket 0)) ) (cond ((not host) (setq hostid loopback)) (host (setq hostid (si::hostname-to-hostid (si::gethostname))))) (or hostid (error "Can't find my address")) (setq tk-socket (si::open-named-socket 0)) (if (pathnamep gcltksrv) (setq gcltksrv (namestring gcltksrv))) (let ((command (tk-conc gcltksrv " " hostid " " (cdr tk-socket) " " pid " " display " " args ))) (print command) (cond ((not host) (si::system command)) (can-rsh (si::system (tk-conc "rsh " host " " command " < /dev/null &"))) (t (format t "Waiting for you to invoke GCL_TK_SERVER, on ~a as in: ~s~%" host command ))) (let ((ar *text-variable-locations*)) (declare (type (array (t)) ar)) (sloop for i below (length ar) by 2 do (remprop (aref ar i) 'linked-variable-type))) (setf (fill-pointer *text-variable-locations*) 0) (setf (fill-pointer *call-backs*) 0) (setq *tk-connection* (si::accept-socket-connection tk-socket )) (if (eql pid -1) (si::SET-SIGIO-FOR-FD (car (car *tk-connection*)))) (setf *sigusr1* nil) (tk-do (tk-conc "source " si::*lib-directory* "gcl-tk/gcl.tcl")) ))) (defun children (win) (let ((ans (list-string (winfo :children win)))) (cond ((null ans) win) (t (cons win (mapcar 'children ans)))))) ;; read nth item from a string in (defun nth-a (n string &optional (separator #\space) &aux (j 0) (i 0) (lim (length string)) ans) (declare (fixnum j n i lim)) (while (< i lim) (cond ((eql j n) (setq ans (our-read-from-string string i)) (setq i lim)) ((eql (aref string i) separator) (setq j (+ j 1)))) (setq i (+ i 1))) ans) (defun set-message-header(vec mtype body-length &aux (m (msg-index)) ) (declare (fixnum mtype body-length m) (string vec) ) (setf (aref vec (pos magic1 *header*)) *magic1*) (setf (aref vec (pos magic2 *header*)) *magic2*) ; (setf (aref vec (pos flag *header*)) (code-char (make-flag flags))) (setf (aref vec (pos type *header*)) (code-char mtype)) (push-number-string vec body-length (pos body-length *header*) 3) (push-number-string vec m (pos msg-index *header*) 3) (setf (msg-index) (the fixnum (+ m 1))) m) (defun get-autoloads (&optional (lis (directory "*.lisp")) ( out "index.lsp") &aux *paths* ) (declare (special *paths*)) (with-open-file (st out :direction :output) (format st "~%(in-package ~s)" (package-name *package*)) (dolist (v lis) (get-file-autoloads v st)) (format st "~%(in-package ~s)" (package-name *package*)) (format st "~2%~s" `(setq si::*load-path* (append ',*paths* si::*load-path*))) )) (defun get-file-autoloads (file &optional (out t) &aux (eof '(nil)) (*package* *package*) saw-package name ) (declare (special *paths*)) (setq name (pathname-name (pathname file))) (with-open-file (st file) (if (boundp '*paths*) (pushnew (namestring (make-pathname :directory (pathname-directory (truename st)))) *paths* :test 'equal)) (sloop for tem = (read st nil eof) while (not (eq tem eof)) do (cond ((and (consp tem) (eq (car tem) 'defun)) (or saw-package (format t "~%;;Warning:(in ~a) a defun not preceded by package declaration" file)) (format out "~%(~s '~s '|~a|)" 'si::autoload (second tem) name)) ((and (consp tem) (eq (car tem) 'in-package)) (setq saw-package t) (or (equal (find-package (second tem)) *package*) (format out "~%~s" tem)) (eval tem)) )))) ;; execute form return values as usual unless error ;; occurs in which case if symbol set-var is supplied, set it ;; to the tag, returning the tag. (defmacro myerrorset (form &optional set-var) `(let ((*break-enable* nil)(*debug-io* si::*null-io*) (*error-output* si::*null-io*)) (multiple-value-call 'error-set-help ',set-var (si::error-set ,form)))) (defun error-set-help (var tag &rest l) (cond (tag (if var (set var tag))) ;; got an error (t (apply 'values l)))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** gcl-2.6.14/gcl-tk/tkXshell.c0000755000175000017500000002740214360276512014126 0ustar cammcamm/* * tkXshell.c * * Version of Tk main that is modified to build a wish shell with the Extended * Tcl command set and libraries. This makes it easier to use a different * main. *----------------------------------------------------------------------------- * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id$ *----------------------------------------------------------------------------- */ /* * main.c -- * * This file contains the main program for "wish", a windowing * shell based on Tk and Tcl. It also provides a template that * can be used as the basis for main programs for other Tk * applications. * * Copyright (c) 1990-1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ #ifdef __cplusplus # include "tcl++.h" # include #else # include "tclExtend.h" #endif #include "tk.h" /*-------------------------------------------------------------------*/ #include #include #include int sock_write( int connection, const char *text, int length ); int sock_read( int connection, char *buffer, int max_len ); extern int hdl; extern pid_t parent; /*-------------------------------------------------------------------*/ /* * Declarations for various library procedures and variables (don't want * to include tkInt.h or tkConfig.h here, because people might copy this * file out of the Tk source directory to make their own modified versions). */ extern void exit _ANSI_ARGS_((int status)); extern int isatty _ANSI_ARGS_((int fd)); /* extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); */ extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); /* * Global variables used by the main program: */ static Tk_Window mainWindow; /* The main window for the application. If * NULL then the application no longer * exists. */ static Tcl_Interp *interp; /* Interpreter for this application. */ char *tcl_RcFileName ; /* Name of a user-specific startup script * to source if the application is being run * interactively (e.g. "~/.wishrc"). Set * by Tcl_AppInit. NULL means don't source * anything ever. */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int gotPartial = 0; /* Partial command in buffer. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static char exitCmd[] = "exit"; static char errorExitCmd[] = "exit 1"; /* * Command-line options: */ static int synchronize = 0; static char *fileName = NULL; static char *name = NULL; static char *display = NULL; static char *geometry = NULL; static Tk_ArgvInfo argTable[] = { {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, "File from which to read commands"}, {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, "Initial geometry for window"}, {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, "Display to use"}, {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, "Name to use for application"}, {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, "Use synchronous mode for display server"}, {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, (char *) NULL} }; /* * Forward declarations for procedures defined later in this file: */ static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); static void SignalProc _ANSI_ARGS_((int signalNum)); /* *---------------------------------------------------------------------- * * TkX_Wish -- * * Main program for Wish. * * Results: * None. This procedure never returns (it exits the process when * it's done * * Side effects: * This procedure initializes the wish world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * *---------------------------------------------------------------------- */ void TkX_Wish (argc, argv) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ { char *args, *p, *msg; char buf[20]; int code; interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); #endif /* * Parse command-line arguments. */ if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0) != TCL_OK) { fprintf(stderr, "%s\n", interp->result); exit(1); } if (name == NULL) { if (fileName != NULL) { p = fileName; } else { p = argv[0]; } name = strrchr(p, '/'); if (name != NULL) { name++; } else { name = p; } } /* * If a display was specified, put it into the DISPLAY * environment variable so that it will be available for * any sub-processes created by us. */ if (display != NULL) { Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); } /* * Set the "tcl_interactive" variable. */ tty = isatty(hdl); Tcl_SetVar(interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); tty = isatty(hdl); /* * Initialize the Tk application. */ mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk"); if (mainWindow == NULL) { fprintf(stderr, "%s\n", interp->result); exit(1); } Tk_SetClass(mainWindow, "Tk"); if (synchronize) { XSynchronize(Tk_Display(mainWindow), True); } Tk_GeometryRequest(mainWindow, 200, 200); /* * Make command-line arguments available in the Tcl variables "argc" * and "argv". Also set the "geometry" variable from the geometry * specified on the command line. */ args = Tcl_Merge(argc-1, argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buf, "%d", argc-1); Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], TCL_GLOBAL_ONLY); if (geometry != NULL) { Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); } /* * Invoke application-specific initialization. */ if (Tcl_AppInit(interp) != TCL_OK) { TclX_ErrorExit (interp, 255); } /* * Set the geometry of the main window, if requested. */ if (geometry != NULL) { code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); } } /* * Invoke the script specified on the command line, if any. */ if (fileName != NULL) { code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); if (code != TCL_OK) { goto error; } tty = 0; } else { TclX_EvalRCFile (interp); /* * Commands will come from standard input. Set up a handler * to receive those characters and print a prompt if the input * device is a terminal. */ tclErrorSignalProc = SignalProc; Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); if (tty) { TclX_OutputPrompt (interp, 1); } } tclSignalBackgroundError = Tk_BackgroundError; fflush(stdout); Tcl_DStringInit(&command); /* * Loop infinitely, waiting for commands to execute. When there * are no windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); /* * Don't exit directly, but rather invoke the Tcl "exit" command. * This gives the application the opportunity to redefine "exit" * to do additional cleanup. */ Tcl_GlobalEval(interp, exitCmd); exit(1); error: msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (msg == NULL) { msg = interp->result; } fprintf(stderr, "%s\n", msg); Tcl_GlobalEval(interp, errorExitCmd); exit (1); } /* *---------------------------------------------------------------------- * * SignalProc -- * * Function called on a signal generating an error to clear the stdin * buffer. *---------------------------------------------------------------------- */ static void SignalProc (signalNum) int signalNum; { tclGotErrorSignal = 0; Tcl_DStringFree (&command); gotPartial = 0; if (tty) { fputc ('\n', stdout); TclX_OutputPrompt (interp, !gotPartial); } } /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ #define BUFFER_SIZE 4000 static void StdinProc(clientData, mask) ClientData clientData; /* Not used. */ int mask; /* Not used. */ { char input[BUFFER_SIZE+1]; char *cmd; int code, count; count = read(hdl, input, BUFFER_SIZE); if (count <= 0) { if (!gotPartial) { if (tty) { Tcl_VarEval(interp, "exit", (char *) NULL); exit(1); } else { Tk_DeleteFileHandler(hdl); } return; } else { count = 0; } } cmd = Tcl_DStringAppend(&command, input, count); fprintf(stderr, "TK command : %s\n", cmd); fflush(stderr); if (count != 0) { if ((input[count-1] != '\n') && (input[count-1] != ';')) { gotPartial = 1; goto exitPoint; } if (!Tcl_CommandComplete(cmd)) { fprintf(stderr, "Partial command\n", cmd); fflush(stderr); gotPartial = 1; goto exitPoint; } } gotPartial = 0; /* * Disable the stdin file handler; otherwise if the command * re-enters the event loop we might process commands from * stdin before the current command is finished. Among other * things, this will trash the text of the command being evaluated. */ Tk_CreateFileHandler(hdl, 0, StdinProc, (ClientData) 0); code = Tcl_RecordAndEval(interp, cmd, 0); Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); if (tty) TclX_PrintResult (interp, code, cmd); else { char buf[1024]; sprintf(buf, "%d %s", code, interp->result); sock_write(hdl, buf, strlen(buf)); kill(parent, SIGUSR1); } Tcl_DStringFree(&command); exitPoint: if (tty) { TclX_OutputPrompt (interp, !gotPartial); } } gcl-2.6.14/gcl-tk/sheader.h0000755000175000017500000000600314360276512013742 0ustar cammcamm #define MAGIC1 '' #define MAGIC2 'A' /* SIZE in BYTES 10+N magic1 1 magic2 1 type (id) 1 the TYPE of message. callback, command, etc...[an enum!] flag 1 things like, do acknowledge, etc. size of actual_body 3 N Use PUSH_LONG to store, POP_LONG to read msg_index 3 counter inc'd on each message sent, PUSH_SHORT to write.. actual_body N data */ enum mtype { m_not_used, m_create_command, m_reply, m_call, m_tcl_command, m_tcl_command_wait_response, m_tcl_clear_connection, /* clear tk connection and command buff */ m_tcl_link_text_variable, m_set_lisp_loc, m_tcl_set_text_variable, m_tcl_unlink_text_variable }; struct message_header { char magic1; char magic2; char type; unsigned char flag; unsigned char size[3]; unsigned char msg_id[3]; char body[1]; }; #ifndef SIGNAL_PARENT_WAITING_RESPONSE #define SIGNAL_PARENT_WAITING_RESPONSE 1 #endif #define BYTE_S 8 #define BYTE_MASK (~(~0UL << BYTE_S)) #define GET_3BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ ans = BYTE_MASK&(*__p++); \ ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ ans += (BYTE_MASK&((*__p++)))<<2*BYTE_S;} while(0) #define GET_2BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ ans = BYTE_MASK&(*__p++); \ ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ } while(0) /* store an unsigned int n into the character pointer so that low order byte occurs first */ #define STORE_2BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ *__p++ = (n & BYTE_MASK);\ *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ }\ while (0) #define STORE_3BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ *__p++ = (n & BYTE_MASK);\ *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ *__p++ = ((n >> (2*BYTE_S)) & BYTE_MASK);}\ while (0) #define MESSAGE_HEADER_SIZE 10 #define HDR_SIZE 5 struct our_header { unsigned char magic; unsigned char length[2]; /* length of packet including HDR_SIZE */ unsigned char received[2]; /* tell other side about how many bytes received. incrementally */ }; struct connection_state { int fd; int total_bytes_sent; int total_bytes_received; int bytes_sent_not_received; int bytes_received_not_confirmed; int next_packet_offset; /* offset from valid_data for start of next packet*/ char *read_buffer; int read_buffer_size; char *valid_data; int valid_data_size; int max_allowed_in_pipe; int write_timeout; }; #define MAX_ALLOWED_IN_PIPE PAGESIZE #define READ_BUFF_SIZE (PAGESIZE<<1) extern struct connection_state *dsfd; #define fScheck_dsfd_for_input(sf,timeout) \ (sf->valid_data_size > 0 ? make_fixnum1(1) : fScheck_fd_for_input(sf->fd,timeout)) #define OBJ_TO_CONNECTION_STATE(x) \ ((struct connection_state *)(void *)((x)->ust.ust_self)) struct connection_state * setup_connection_state(); gcl-2.6.14/gcl-tk/tkAppInit.c0000755000175000017500000000703514360276512014233 0ustar cammcamm/* * tkAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for * use in wish and similar Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ /* #ifndef lint */ /* static char rcsid[] = "/usr/home/gah/repository/blt/tkAppInit.c,v 1.3 1994/04/02 04:37:26 gah Exp SPRITE (Berkeley) $Revision"; */ /* #endif */ #include "tk.h" /* * The following variable is a special hack that allows applications * to be linked using the procedure "main" from the Tk library. The * variable generates a reference to "main", which causes main to * be brought in from the library (and all of Tk and Tcl with it). */ extern int main(); int *tclDummyMainPtr = (int *) main; /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window mmain; /* extern int Blt_Init _ANSI_ARGS_((Tcl_Interp *interp)); */ mmain = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* if (Blt_Init(interp) == TCL_ERROR) { return TCL_ERROR; } */ if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ /* for version tk 3.5: tcl_RcFileName = "~/.wishrc"; */ Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY); return TCL_OK; } gcl-2.6.14/gcl-tk/our_io.c0000755000175000017500000000372314360276512013624 0ustar cammcamm #include #ifndef NO_DEFUN #ifndef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname #endif #endif #ifndef HZ #define HZ 60 #endif #ifndef SET_TIMEVAL #define SET_TIMEVAL(t,timeout) \ t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) #endif DEFUN("CHECK-FD-FOR-INPUT",int,fScheck_fd_for_input, SI,0,0,NONE,II,IO,OO,OO, "Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ for data to become available. Here there are \ INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ available on FD, 0 if timeout reached and -1 if failed.") (fd,timeout) int fd; int timeout; { fd_set inp; int n; struct timeval t; SET_TIMEVAL(t,timeout); FD_ZERO(&inp); FD_SET(fd, &inp); n = select(fd + 1, &inp, NULL, NULL, &t); if (n < 0) return -1; else if (FD_ISSET(fd, &inp)) return 1; else return 0; } /* read from FD into BUF, M bytes allowing TIMEOUT if necessary. return number of bytes read. */ our_read(fd,buf,m,timeout) int fd,m,timeout; char *buf; { int r,tot=0; char *p = buf; while(tot < m && (fScheck_fd_for_input(fd,timeout)>0)) { r = read(fd,p,m); if (r == 0) return tot; if (r == -1) { if (errno != EAGAIN) return -1;} else { tot += r; p += r; }} return tot; } /* write to FD file descriptor from BUF sending NBYTES. */ our_write(fd,buf,nbytes) char *buf; int fd,nbytes; { int result = 0; int m; int n = nbytes; char *p=buf; while (n>0) { m=write(fd,p,n); if (m< 0) { perror("write failed:"); return -1;} if (m==0) { fprintf(stderr, "write failed? 0 bytes written nbytes %d [%s] lost:", n,p ); return result; } p+= m; n-= m; result+= m; } if (n>0) { perror("Could not write all data:"); return result; } /* should not happen */ if (result!= nbytes) abort(); return result; } gcl-2.6.14/gcl-tk/gcl.tcl0000755000175000017500000000257614360276512013442 0ustar cammcamm # some extensions for gcl # of course these could be in lisp, but keeping them on the # tk side of the pipe can cut down overhead. for large things # like getting a file proc TextLoadFile {w file} { set f [open $file] $w delete 1.0 end while {![eof $f]} { $w insert end [read $f 10000] } close $f } proc insertWithTags {w text args} { set start [$w index insert] $w insert insert $text foreach tag [$w tag names $start] { $w tag remove $tag $start insert } foreach i $args { $w tag add $i $start insert } } # in WINDOW if TAG is set at INDEX then return the range # of indices for which tag is set including index. proc get_tag_range {w tag index} { set i 1 set index [$w index $index] set range "" set ok 0 # puts stdout $index foreach v [$w tag names $index] { if {$v == $tag} {set ok 1}} while $ok { set range [$w tag nextrange $tag "$index -$i chars" "$index +1 char"] if {[llength $range ] >= 2} { break;} if {[$w compare "$index - $i chars" <= "0.0 + 1 chars" ]} { break;} set i [expr $i + 1] } return $range } proc MultipleTagAdd {win tag start l} { set prev -1 foreach v $l { puts stdout $v if { "$prev" == "-1" } { set prev $v } else { $win tag add $tag "$start + $prev chars" "$start + $v chars" set prev -1 }}} gcl-2.6.14/gcl-tk/dir.sed0000755000175000017500000000005614360276512013433 0ustar cammcamm/DIR=/a\ DIR=/home/wfs/gcl-2.0/gcl-tk /DIR=/d gcl-2.6.14/gcl-tk/decode.tcl0000644000175000017500000002064214360276512014107 0ustar cammcamm# this file contains the protocol for receiving connections from GCL and # other lisps [or other languages] # The communication is via a socket, and the data is packaged up into # packets, which we track letting the other side know how much is actually # received. This protocol is to prevent problems with flooding a # communications channel. The sender knows how many bytes are in the pipe. # the outer wrapper is # { char magic; # unsigned short length; /* including the header */ # unsigned short received; /* incremental number of bytes received at the # other end of the channel */ # # (MAGIC1 MAGIC2 TYPE FLAG BODY-LENGTH NIL NIL MSG-INDEX NIL NIL) set GclMTypes { m_not_used m_create_command m_reply m_call m_tcl_command m_tcl_command_wait_response m_tcl_clear_connection m_tcl_link_text_variable m_set_lisp_loc m_tcl_set_text_variable m_tcl_unlink_text_variable} proc GclDecodeMsg { msg } { # char magic1; \06 # char magic2; 'A' # char type; m_* # unsigned char flag; # unsigned char size[3]; /* of body */ # unsigned char msg_id[3]; # char body[1]; global GclMTypes if { [string match "\06A*" $msg] } { binary scan [string range $msg 2 end] ccsc type flag bodyLo bodyHi set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] set index [msgIndex $msg] set ans "xMsg-id=$index, type= [lindex $GclMTypes $type], length=$bodyLength, body=[string range $msg 10 [expr 10 + $bodyLength-1]]" } else {set ans "invalidmsg:<$msg>" } } #proc GclmsgIndex { msg } { # binary scan [string range $msg 7 9] sc indLo indHi # set index [expr ($indLo & 0xffff)+ ($indHi >> 16)] # return $index #} proc Gclget3Bytes { s } { binary scan $s "sc" lo hi return [expr { ($lo & 0xffff) + ($hi << 16) }] } proc GclMake3Bytes { n } { return [ string range [binary format i $n] 0 2] } proc debugSend { msg } { puts stderr $msg flush stderr } proc GclAnswerSocket { host port pid } { global GclSock GclPdata GclPacket set sock [socket $host $port] setupPacket $sock fconfigure $sock -blocking 0 -translation {binary binary} # debugSend fconfigure:$sock:[fconfigure $sock] set GclSock $sock catch { unset GclPdata(data,$sock) } fileevent $sock readable "GclReadAndAct1 $sock" set GclPdata(pid,$sock) $pid return $sock } proc setupPacket { sock } { global GclPacket # data including 5 byte headers set GclPacket(indata,$sock) "" set GclPacket(received,$sock) 0 set GclPacket(sent_not_received,$sock) 0 # the data after stripping headers set GclPacket(outdata,$sock) "" } proc GclRead1 { sock } { global GclPacket upvar #0 GclPacket(indata,$sock) indata set recd 0 append indata [read $sock] set ll 0 while { [set l [string length $indata]] >= 5 } { binary scan $indata "css" magic length received # debugSend "magic=$magic,length=$length,received:=$received,indata=$indata" # -122 = signedchar(0206) if { $magic != -122 } { error "bad magic" } # debugSend "test: $l >= $length + 5" if { $l >= $length } { append GclPacket(outdata,$sock) [string range $indata 5 [expr $length -1]] set indata [string range $indata $length end] incr recd $received incr ll $length } else { break } } incr GclPacket(received,$sock) $ll if { $recd } { incr GclPacket(sent_not_received,$sock) -$recd } if { $GclPacket(received,$sock) > 1500 } { sendReceiveConfirmation $sock } set res $GclPacket(outdata,$sock) set GclPacket(outdata,$sock) "" # debugSend "GclRead1--><$res>" return $res } proc sendReceiveConfirmation { sock } { GclWrite1 $sock "" } proc GclWrite1 { sock data } { global GclPacket # debugSend "entering GclWrite1" set length [expr 5 + [string length $data]] set hdr \206[binary format ss $length $GclPacket(received,$sock)] # debugSend "hdr=$hdr, [array get GclPacket *]" set GclPacket(received,$sock) 0 incr GclPacket(sent_not_received,$sock) $length #debugSend "GclWrite1:<$hdr$data>" puts -nonewline $sock $hdr$data flush $sock } proc GclReadAndAct1 { sock } { global GclPdata GclMTypes upvar #0 GclPdata(data,$sock) msg set read [GclRead1 $sock] if { [string length $read] == 0 } { if { [eof $sock] } { # debugSend "exitting since $sock is closed" exit 1 } return "" } append msg $read while { [set l [string length $msg]] >= 10 } { #debugSend "msg=<$msg>" #debugSend [GclDecodeMsg $msg] binary scan $msg sccsc magic type flag bodyLo bodyHi if { $magic != 16646 } { error "bad magic:[string range $msg 0 1]" } set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] if { $l >= 10+$bodyLength } { set toeval [list [lindex $GclMTypes $type] $msg [string range $msg 10 [expr 10 + $bodyLength-1]]] set msg [string range $msg [expr 10 + $bodyLength] end] #debugSend toeval=$toeval if { [catch { eval $toeval } err] } { puts stderr "error in [lindex $toeval 0] [string range [lindex $toeval 1 ] 0 13]... [lindex $toeval 2]: $err" flush stderr } } } } proc GclGetCString {s } { return [string range $s 0 [expr [string first \0 $s] -1]] } set GclSockMsgId 0 proc sock_write_str {typeflag text } { global GclSock GclSockMsgId set msg "\06A$typeflag[GclMake3Bytes [string length $text]][GclMake3Bytes [incr GclSockMsgId]]$text" #debugSend sending:[GclDecodeMsg $msg] GclWrite1 $GclSock $msg } proc GclGenericCommand { n arg } { global GclSock # 2 == [lsearch $GclMTypes m_reply] sock_write_str "\3\0" "[GclMake3Bytes $n]$arg" signalParent $GclSock } proc GclGenericCommandStringify { n arglist lis } { global GclSock set i 0 set ans "[GclMake3Bytes $n](" foreach v $lis { if { "s" == "[string range $arglist $i $i]" } { append ans " \"" $v "\"" } else { append ans " " $v } } append ans ")" sock_write_str "\3\0" $ans signalParent $GclSock } proc m_create_command { msg body } { #debugSend "in m_create_command" set n [Gclget3Bytes $body] set arglist [GclGetCString [string range $body 3 end]] # "debugSend callback_$n:args=\$args ; GclGenericCommandStringify $n $arglist \$args" \ if { "$arglist" == "" } { proc callback_$n { { arg1 "" } } "GclGenericCommand $n \$arg1" } else { proc callback_$n { args } "GclGenericCommandStringify $n $arglist \$args" } } proc m_tcl_command { msg body } { set body [string trimright $body "\0"] # set body [GclGetCString $body] # set fail [catch { eval $body } res] # set fail [catch { eval $body } res] eval $body # set com "update idletasks" #after cancel $com #after 5 $com # update idletasks # puts stderr "doing $body" ; flush stderr # debugSend "in eval of <$body>: fail=$fail,res=<$res>" } proc m_tcl_command_wait_response { msg body } { global GclSock set body [string trimright $body "\0"] # set body [GclGetCString $body] set fail [catch { eval $body } res] # 2 == [lsearch $GclMTypes m_reply] sock_write_str "\2\0" "$fail[string range $msg 7 9]$res" # debugSend " signalParent $GclSock" # no need to signal other side is waiting. # signalParent $GclSock } proc m_tcl_clear_connection { msg body } { global GclSock flush $GclSock set GclPdata($GclSock,data) "" } proc m_tcl_set_text_variable { msg body } { set n [string first \0 $body] set [string range $body 0 [expr $n -1]] [string range $body [expr $n+1] end] } proc m_tcl_link_text_variable { msg body } { global GclPdata set i [Gclget3Bytes $body] set name [string range $body 3 end] uplevel #0 trace variable wu $name "GclTellLispVarChanged $i" } proc signalParent1 {sock } { global GclPdata GclPacket if { $GclPacket(sent_not_received,$sock) } { exec kill -s SIGUSR1 $GclPdata(pid,$sock) & } } proc signalParent {sock } { global delay set com "signalParent1 $sock" after cancel $com after 5 $com } proc GclTellLispVarChanged { i name1 name2 op } { global GclPdata upvar #0 $name1 val # 8 == [lsearch $GclMTypes m_set_lisp_loc] sock_write_str \8\0 "[GclMake3Bytes $i]$val" signalParent $GclSock } proc m_tcl_unlink_text_variable { msg body } { set i [Gclget3Bytes $body] set name [string range $body 3 end] trace vdelete $name wu "GclTellLispVarChanged $i" } gcl-2.6.14/gcl-tk/makefile0000644000175000017500000000410114360276512013650 0ustar cammcamm .SUFFIXES: .SUFFIXES: .o .lsp .lisp .c CC=cc LD_ORDINARY_CC=${CC} GCLTKCC=${CC} # Need libX11.a and libtcl.a, machine.defs may say where.. CC = gcc HDIR = ../h ODIR = ../o GCLIB = ../o/gcllib.a -include ../makedefs CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TCL_INCLUDE} ${TK_XINCLUDES} all: gcltksrv tkl.o tinfo.o demos/gc-monitor.o gcltkaux (cd demos ; \ echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' | ../../unixport/$(FLISP)) .lisp.o: echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) .lsp.o: echo "(compile-file \"$*.lsp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) GUIOS = guis.o tkAppInit.o tkMain.o clean:: rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o demos/index.lsp *.fn demos/*.fn .c.o: $(GCLTKCC) -c $(filter-out -pg,$(CFLAGS1)) -fPIE ${ODIR_DEBUG} $*.c # for some reason -lieee is on various linux systems in the list of requireds.. gcltkaux: $(GUIOS) $(LD_ORDINARY_CC) $(GUIOS) $(filter-out %gcl.script,$(LDFLAGS)) -pie -o gcltkaux ${TK_LIB_SPEC} ${TCL_LIB_SPEC} gcltksrv: makefile cat gcltksrv.in | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv chmod a+x gcltksrv gcltksrv.interp: makefile cat gcltksrv.in.interp | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv.interp chmod a+x gcltksrv.interp INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h tar: tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz tags: etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c tkAppInit.o : tkAppInit.c tkMain.o : tkMain.c tkXAppInit.o : tkXAppInit.c tkXshell.o : tkXshell.c guis.o : guis.c guis.h comm.c sheader.h sockets.c: our_io.c sheader.h socketsl.o: socketsl.lisp sockets.c gcl-2.6.14/gcl-tk/gcltksrv.in0000755000175000017500000000134614360276512014352 0ustar cammcamm#!/bin/sh # where to find bitmaps, # and the class bindings in /usr/local/lib/tk/tk.tcl GCL_TK_DIR=/home/wfs/gcl-2.0/gcl-tk TK_XLIB_DIR=/usr/local/X11R6/lib if [ -d "${TK_XLIB_DIR}" ] ; then export LD_LIBRARY_PATH LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${TK_XLIB_DIR} fi #check to see if TK_LIBRARY set in users environment ok.. if [ -f ${TK_LIBRARY}/tk.tcl ] ;then true; else TK_LIBRARY=/var/X11/lib/X11/tk if [ -f ${TK_LIBRARY}/tk.tcl ] ;then export TK_LIBRARY ; fi export TK_LIBRARY fi if [ -f ${TCL_LIBRARY}/init.tcl ] ;then true; else TCL_LIBRARY=/usr/local/lib/tcl if [ -f ${TCL_LIBRARY}/init.tcl ] ; then export TCL_LIBRARY ; fi fi if [ $# -ge 4 ] ;then DISPLAY=$4 ; export DISPLAY; fi exec ${GCL_TK_DIR}/gcltkaux $1 $2 $3 gcl-2.6.14/gcl-tk/tkMain.c0000755000175000017500000004406214360276512013554 0ustar cammcamm/* * main.c -- * * This file contains the main program for "wish", a windowing * shell based on Tk and Tcl. It also provides a template that * can be used as the basis for main programs for other Tk * applications. * * Copyright (c) 1990-1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ /* #ifndef lint */ /* static char rcsid[] = "$Header$ SPRITE (Berkeley)"; */ /* #endif */ #include #include #include #include #include #if (TK_MINOR_VERSION==0 && TK_MAJOR_VERSION==4) #define TkCreateMainWindow Tk_CreateMainWindow #endif #if TCL_MAJOR_VERSION >= 8 #define INTERP_RESULT(interp) Tcl_GetStringResult(interp) #else #define INTERP_RESULT(interp) (interp)->result #endif /*-------------------------------------------------------------------*/ #include #include #include #include int writable_malloc=0; /*FIXME, don't wrap fopen here, exclude notcomp.h or equivalent */ #include "guis.h" struct connection_state *dsfd; /*-------------------------------------------------------------------*/ /* * Declarations for various library procedures and variables (don't want * to include tkInt.h or tkConfig.h here, because people might copy this * file out of the Tk source directory to make their own modified versions). */ /* extern void exit _ANSI_ARGS_((int status)); */ extern int isatty _ANSI_ARGS_((int fd)); /* extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); */ extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); /* * Global variables used by the main program: */ /* static Tk_Window mainWindow; The main window for the application. If * NULL then the application no longer * exists. */ static Tcl_Interp *interp; /* Interpreter for this application. */ char *tcl_RcFileName; /* Name of a user-specific startup script * to source if the application is being run * interactively (e.g. "~/.wishrc"). Set * by Tcl_AppInit. NULL means don't source * anything ever. */ static Tcl_DString command; /* Used to assemble lines of terminal input * into Tcl commands. */ static int tty; /* Non-zero means standard input is a * terminal-like device. Zero means it's * a file. */ static char errorExitCmd[] = "exit 1"; /* * Command-line options: */ static int synchronize = 0; static char *fileName = NULL; static char *name = NULL; static char *display = NULL; static char *geometry = NULL; int debug = 0; static void guiCreateCommand _ANSI_ARGS_((int idLispObject, int iSlot , char *arglist)); void dfprintf(FILE *fp,char *s,...) { va_list args; if (debug) { va_start(args,s); fprintf(fp,"\nguis:"); vfprintf(fp,s,args); fflush(fp); va_end(args); } } #define CMD_SIZE 4000 #define SIGNAL_ERROR TCL_signal_error static void TCL_signal_error(x) char *x; {char buf[300] ; sprintf(buf,"error %s",x); Tcl_Eval(interp,buf); dfprintf(stderr,x); } static Tk_ArgvInfo argTable[] = { {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, "File from which to read commands"}, {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, "Initial geometry for window"}, {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, "Display to use"}, {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, "Name to use for application"}, {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, "Use synchronous mode for display server"}, {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, (char *) NULL} }; /* * Declaration for Tcl command procedure to create demo widget. This * procedure is only invoked if SQUARE_DEMO is defined. */ extern int SquareCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])); /* * Forward declarations for procedures defined later in this file: */ static void StdinProc _ANSI_ARGS_((ClientData clientData, int mask)); /* *---------------------------------------------------------------------- * * main -- * * Main program for Wish. * * Results: * None. This procedure never returns (it exits the process when * it's done * * Side effects: * This procedure initializes the wish world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * *---------------------------------------------------------------------- */ /* int main(argc, argv) */ /* FIXME, should come in from tk header or not be called */ EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp * interp, char * screenName, char * baseName)); void TkX_Wish (argc, argv) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ { char *args, *p; const char *msg; char buf[20]; int code; interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); #endif /* * Parse command-line arguments. */ if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, (const char **)argv, argTable, 0) != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); exit(1); } if (name == NULL) { if (fileName != NULL) { p = fileName; } else { p = argv[0]; } name = strrchr(p, '/'); if (name != NULL) { name++; } else { name = p; } } /* * If a display was specified, put it into the DISPLAY * environment variable so that it will be available for * any sub-processes created by us. */ if (display != NULL) { Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); } /* * Initialize the Tk application. */ /* mainWindow = TkCreateMainWindow(interp, display, name/\* , "Tk" *\/); */ /* if (mainWindow == NULL) { */ /* fprintf(stderr, "%s\n", INTERP_RESULT(interp)); */ /* exit(1); */ /* } */ /* #ifndef __MINGW32__ */ /* if (synchronize) { */ /* XSynchronize(Tk_Display(mainWindow), True); */ /* } */ /* #endif */ /* Tk_GeometryRequest(mainWindow, 200, 200); */ /* Tk_UnmapWindow(mainWindow); */ /* * Make command-line arguments available in the Tcl variables "argc" * and "argv". Also set the "geometry" variable from the geometry * specified on the command line. */ args = Tcl_Merge(argc-1, (const char **)argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buf, "%d", argc-1); Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], TCL_GLOBAL_ONLY); if (geometry != NULL) { Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); } /* * Set the "tcl_interactive" variable. */ tty = isatty(dsfd->fd); Tcl_SetVar(interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Add a few application-specific commands to the application's * interpreter. */ /* #ifdef SQUARE_DEMO */ /* Tcl_CreateCommand(interp, "square", SquareCmd, (ClientData) mainWindow, */ /* (void (*)()) NULL); */ /* #endif */ /* * Invoke application-specific initialization. */ if (Tcl_AppInit(interp) != TCL_OK) { fprintf(stderr, "Tcl_AppInit failed: %s\n", INTERP_RESULT(interp)); } /* * Set the geometry of the main window, if requested. */ if (geometry != NULL) { code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); if (code != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } } /* * Invoke the script specified on the command line, if any. */ if (fileName != NULL) { code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); if (code != TCL_OK) { goto error; } tty = 0; } else { /* * Commands will come from standard input, so set up an event * handler for standard input. If the input device is aEvaluate the * .rc file, if one has been specified, set up an event handler * for standard input, and print a prompt if the input * device is a terminal. */ if (tcl_RcFileName != NULL) { Tcl_DString buffer; char *fullName; FILE *f; fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); if (fullName == NULL) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } else { f = fopen(fullName, "r"); if (f != NULL) { code = Tcl_EvalFile(interp, fullName); if (code != TCL_OK) { fprintf(stderr, "%s\n", INTERP_RESULT(interp)); } fclose(f); } } Tcl_DStringFree(&buffer); } dfprintf(stderr, "guis : Creating file handler for %d\n", dsfd->fd); #ifndef __MINGW32__ Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); #endif } fflush(stdout); Tcl_DStringInit(&command); /* * Loop infinitely, waiting for commands to execute. When there * are no windows left, Tk_MainLoop returns and we exit. */ Tk_MainLoop(); /* * Don't exit directly, but rather invoke the Tcl "exit" command. * This gives the application the opportunity to redefine "exit" * to do additional cleanup. */ Tcl_Eval(interp, "exit"); exit(1); error: msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (msg == NULL) { msg = INTERP_RESULT(interp); } dfprintf(stderr, "%s\n", msg); Tcl_Eval(interp, errorExitCmd); return; /* Needed only to prevent compiler warnings. */ } static char *being_set_by_lisp; static char * tell_lisp_var_changed( clientData, interp, name1, name2, flags) ClientData clientData; Tcl_Interp *interp; char *name1; char *name2; int flags; { if (being_set_by_lisp == 0) { const char *val = Tcl_GetVar2(interp,name1,name2, TCL_GLOBAL_ONLY); char buf[3]; STORE_3BYTES(buf,(long) clientData); if(sock_write_str2(dsfd, m_set_lisp_loc, buf, 3 , val, strlen(val)) < 0) { /* what do we want to do if the write failed */} #ifndef __MINGW32__ if (parent > 0) kill(parent, SIGUSR1); #endif } else /* avoid going back to lisp if it is lisp that is doing the setting! */ if (strcmp(being_set_by_lisp,name1)) { fprintf(stderr,"recursive setting of vars %s??",name1);} /* normal */ return 0; } /* *---------------------------------------------------------------------- * * StdinProc -- * * This procedure is invoked by the event dispatcher whenever * standard input becomes readable. It grabs the next line of * input characters, adds them to a command being assembled, and * executes the command if it's complete. * * Results: * None. * * Side effects: * Could be almost arbitrary, depending on the command that's * typed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void StdinProc(clientData, mask) ClientData clientData; /* Not used. */ int mask; /* Not used. */ { int fNotDone; char *cmd; int code, count; struct message_header *msg; char buf[0x4000]; msg = (struct message_header *) buf; /* * Disable the stdin file handler while evaluating the command; * otherwise if the command re-enters the event loop we might * process commands from stdin before the current command is * finished. Among other things, this will trash the text of the * command being evaluated. */ dfprintf(stderr, "\nguis : Disabling file handler for %d\n", dsfd->fd); /* Tk_CreateFileHandler(dsfd->fd, 0, StdinProc, (ClientData) 0); */ do { msg = guiParseMsg1(dsfd,buf,sizeof(buf)); if (msg == NULL) { /*dfprintf(stderr, "Yoo !!! Empty command\n"); */ if (debug)perror("zero message"); #ifndef __MINGW32__ Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); #endif return; } /* Need to switch to table lookup */ switch (msg->type){ case m_create_command: { int iSlot; GET_3BYTES(msg->body,iSlot); guiCreateCommand(0, iSlot, &(msg->body[3])); } break; case m_tcl_command : case m_tcl_command_wait_response: count = strlen(msg->body); cmd = Tcl_DStringAppend(&command, msg->body, count); code = Tcl_RecordAndEval(interp, cmd, 0); if (msg->type == m_tcl_command_wait_response || code) { char buf[4]; char *p = buf, *string; /*header */ *p++ = (code ? '1' : '0'); bcopy(msg->msg_id,p,3); /* end header */ string = (char *)INTERP_RESULT(interp); if(sock_write_str2(dsfd, m_reply, buf, 4, string, strlen(string)) < 0) { /* what do we want to do if the write failed */} if (msg->type == m_tcl_command_wait_response) { /* parent is waiting so dong signal */ ;} #ifndef __MINGW32__ else if (parent> 0)kill(parent, SIGUSR1); #endif } Tcl_DStringFree(&command); break; case m_tcl_clear_connection: /* we are stuck... */ { Tcl_DStringInit(&command); Tcl_DStringFree(&command); fSclear_connection(dsfd->fd); } break; case m_tcl_set_text_variable: { int n = strlen(msg->body); if(being_set_by_lisp) fprintf(stderr,"recursive set?"); /* avoid a trace on this set!! */ being_set_by_lisp = msg->body; Tcl_SetVar2(interp,msg->body,0,msg->body+n+1, TCL_GLOBAL_ONLY); being_set_by_lisp = 0; } break; case m_tcl_link_text_variable: {long i; GET_3BYTES(msg->body,i); Tcl_TraceVar2(interp,msg->body+3 ,0, TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_GLOBAL_ONLY , tell_lisp_var_changed, (ClientData) i); } break; case m_tcl_unlink_text_variable: {long i; GET_3BYTES(msg->body,i); Tcl_UntraceVar2(interp,msg->body+3 ,0, TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_GLOBAL_ONLY , tell_lisp_var_changed, (ClientData) i); } break; default : dfprintf(stderr, "Error !!! Unknown command %d\n" , msg->type); } fNotDone = fix(fScheck_dsfd_for_input(dsfd,0)); if (fNotDone > 0) { dfprintf(stderr, "\nguis : in StdinProc, not done, executed %s" , msg->body); } } while (fNotDone > 0); /* Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); */ if ((void *)msg != (void *) buf) free ((void *) msg); } /* ----------------------------------------------------------------- */ typedef struct _ClientDataLispObject { int id; int iSlot; char *arglist; } ClientDataLispObject; static int TclGenericCommandProcedure( clientData, pinterp, argc, argv) ClientData clientData; Tcl_Interp *pinterp; int argc; char *argv[]; { char szCmd[CMD_SIZE]; ClientDataLispObject *pcdlo = (ClientDataLispObject *)clientData; int cb=0; char *q = szCmd; char *p = pcdlo->arglist; STORE_3BYTES(q,(pcdlo->iSlot)); q += 3; if (p == 0) { char *arg = (argc > 1 ? argv[1] : ""); int m = strlen(arg); if (m > CMD_SIZE -50) SIGNAL_ERROR("too big command"); bcopy(arg,q,m); q += m ;} else { int i,n; *q++ = '('; n = strlen(p); for (i=1; i< argc; i++) { if (i < n && p[i]=='s') { *q++ = '"';} strcpy(q,argv[i]); q+= strlen(argv[i]); if (i < n && p[i]=='s') { *q++ = '"';} } *q++ = ')'; } *q = 0; dfprintf(stderr, "TclGenericCommandProcedure : %s\n" , szCmd ); if (sock_write_str2(dsfd,m_call, "",0, szCmd, q-szCmd) == -1) { dfprintf(stderr, "Error\t(TclGenericCommandProcedure) !!!\n\tFailed to write [%s] to socket %d (%d) cb=%d\n" , szCmd, dsfd->fd, errno, cb); } #ifndef __MINGW32__ if (parent > 0)kill(parent, SIGUSR1); #endif return TCL_OK; } static void guiCreateCommand( idLispObject, iSlot , arglist) int idLispObject; int iSlot ; char *arglist; { char szNameCmdProc[2000],*c; ClientDataLispObject *pcdlo; sprintf(szNameCmdProc, "callback_%d",iSlot); pcdlo = (ClientDataLispObject *)malloc(sizeof(ClientDataLispObject)); pcdlo->id = idLispObject; pcdlo->iSlot = iSlot; if (arglist[0] == 0) { pcdlo->arglist = 0;} else {c= malloc(strlen(arglist)+1); strcpy(c,arglist); pcdlo->arglist = c;} Tcl_CreateCommand(interp , szNameCmdProc, TclGenericCommandProcedure , (ClientData *)pcdlo, free); dfprintf(stderr, "TCL creating callback : %s\n", szNameCmdProc); /* guiBindCallback(szNameCmdProc, szTclObject, szModifier,arglist); */ } /* int guiBindCallback(char *szNameCmdProc, char *szTclObject, char *szModifier,char* arglist) { int code; char szCmd[2000]; sprintf(szCmd, "bind %s %s {%s %s}" , szTclObject , szModifier , szNameCmdProc , (arglist ? arglist : "") ); dfprintf(stderr, "TCL BIND : %s\n", szCmd); code = Tcl_Eval(interp, szCmd); if (code != TCL_OK) { dfprintf(stderr, "TCL Error int bind : %s\n", INTERP_RESULT(interp)); } return code; } */ /* static void */ /* guiDeleteCallback(szCallback) */ /* char *szCallback; */ /* { */ /* dfprintf(stderr, "Tcl Deleting command : %s\n", szCallback); */ /* Tcl_DeleteCommand(interp, szCallback); */ /* } */ /* */ gcl-2.6.14/gcl-tk/demos-4.2/0000755000175000017500000000000014360276512013564 5ustar cammcammgcl-2.6.14/gcl-tk/demos-4.2/widget0000755000175000017500000003210314360276512014774 0ustar cammcamm#!/bin/sh # the next line restarts using wish \ exec wish4.2 "$0" "$@" # widget -- # This script demonstrates the various widgets provided by Tk, # along with many of the features of the Tk toolkit. This file # only contains code to generate the main window for the # application, which invokes individual demonstrations. The # code for the actual demonstrations is contained in separate # ".tcl" files is this directory, which are sourced by this script # as needed. # # SCCS: @(#) widget 1.21 96/10/04 17:09:34 eval destroy [winfo child .] wm title . "Widget Demonstration" #---------------------------------------------------------------- # The code below create the main window, consisting of a menu bar # and a text widget that explains how to use the program, plus lists # all of the demos as hypertext items. #---------------------------------------------------------------- set font -*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-* frame .menuBar pack .menuBar -side top -fill x menubutton .menuBar.file -text File -menu .menuBar.file.m -underline 0 menu .menuBar.file.m .menuBar.file.m add command -label "About ... " -command "aboutBox" \ -underline 0 -accelerator "" .menuBar.file.m add sep .menuBar.file.m add command -label "Quit" -command "exit" -underline 0 pack .menuBar.file -side left bind . aboutBox frame .textFrame scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ -takefocus 1 pack .s -in .textFrame -side right -fill y -padx 1 text .t -yscrollcommand {.s set} -wrap word -width 60 -height 30 -font $font \ -setgrid 1 -highlightthickness 0 -padx 4 -pady 2 -takefocus 0 pack .t -in .textFrame -expand y -fill both -padx 1 pack .textFrame -expand yes -fill both -padx 1 -pady 2 frame .statusBar label .statusBar.lab -text " " -relief sunken -bd 1 \ -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w label .statusBar.foo -width 8 -relief sunken -bd 1 \ -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w pack .statusBar.lab -side left -padx 2 -expand yes -fill both pack .statusBar.foo -side left -padx 2 pack .statusBar -side top -fill x -pady 2 # Create a bunch of tags to use in the text widget, such as those for # section titles and demo descriptions. Also define the bindings for # tags. .t tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-* # We put some "space" characters to the left and right of each demo description # so that the descriptions are highlighted only when the mouse cursor # is right over them (but not when the cursor is to their left or right) # .t tag configure demospace -lmargin1 1c -lmargin2 1c if {[winfo depth .] == 1} { .t tag configure demo -lmargin1 1c -lmargin2 1c \ -underline 1 .t tag configure visited -lmargin1 1c -lmargin2 1c \ -underline 1 .t tag configure hot -background black -foreground white } else { .t tag configure demo -lmargin1 1c -lmargin2 1c \ -foreground blue -underline 1 .t tag configure visited -lmargin1 1c -lmargin2 1c \ -foreground #303080 -underline 1 .t tag configure hot -foreground red -underline 1 } .t tag bind demo { invoke [.t index {@%x,%y}] } set lastLine "" .t tag bind demo { set lastLine [.t index {@%x,%y linestart}] .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" .t config -cursor hand2 showStatus [.t index {@%x,%y}] } .t tag bind demo { .t tag remove hot 1.0 end .t config -cursor xterm .statusBar.lab config -text "" } .t tag bind demo { set newLine [.t index {@%x,%y linestart}] if {[string compare $newLine $lastLine] != 0} { .t tag remove hot 1.0 end set lastLine $newLine set tags [.t tag names {@%x,%y}] set i [lsearch -glob $tags demo-*] if {$i >= 0} { .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" } } showStatus [.t index {@%x,%y}] } # Create the text for the text widget. .t insert end "Tk Widget Demonstrations\n" title .t insert end { This application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code. } .t insert end "Labels, buttons, checkbuttons, and radiobuttons" title .t insert end " \n " {demospace} .t insert end "1. Labels (text and bitmaps)." {demo demo-label} .t insert end " \n " {demospace} .t insert end "2. Buttons." {demo demo-button} .t insert end " \n " {demospace} .t insert end "3. Checkbuttons (select any of a group)." {demo demo-check} .t insert end " \n " {demospace} .t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio} .t insert end " \n " {demospace} .t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle} .t insert end " \n " {demospace} .t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon} .t insert end " \n " {demospace} .t insert end "7. Two labels displaying images." {demo demo-image1} .t insert end " \n " {demospace} .t insert end "8. A simple user interface for viewing images." \ {demo demo-image2} .t insert end " \n " {demospace} .t insert end \n {} "Listboxes" title .t insert end " \n " {demospace} .t insert end "1. 50 states." {demo demo-states} .t insert end " \n " {demospace} .t insert end "2. Colors: change the color scheme for the application." \ {demo demo-colors} .t insert end " \n " {demospace} .t insert end "3. A collection of famous sayings." {demo demo-sayings} .t insert end " \n " {demospace} .t insert end \n {} "Entries" title .t insert end " \n " {demospace} .t insert end "1. Without scrollbars." {demo demo-entry1} .t insert end " \n " {demospace} .t insert end "2. With scrollbars." {demo demo-entry2} .t insert end " \n " {demospace} .t insert end "3. Simple Rolodex-like form." {demo demo-form} .t insert end " \n " {demospace} .t insert end \n {} "Text" title .t insert end " \n " {demospace} .t insert end "1. Basic editable text." {demo demo-text} .t insert end " \n " {demospace} .t insert end "2. Text display styles." {demo demo-style} .t insert end " \n " {demospace} .t insert end "3. Hypertext (tag bindings)." {demo demo-bind} .t insert end " \n " {demospace} .t insert end "4. A text widget with embedded windows." {demo demo-twind} .t insert end " \n " {demospace} .t insert end "5. A search tool built with a text widget." {demo demo-search} .t insert end " \n " {demospace} .t insert end \n {} "Canvases" title .t insert end " \n " {demospace} .t insert end "1. The canvas item types." {demo demo-items} .t insert end " \n " {demospace} .t insert end "2. A simple 2-D plot." {demo demo-plot} .t insert end " \n " {demospace} .t insert end "3. Text items in canvases." {demo demo-ctext} .t insert end " \n " {demospace} .t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow} .t insert end " \n " {demospace} .t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler} .t insert end " \n " {demospace} .t insert end "6. A building floor plan." {demo demo-floor} .t insert end " \n " {demospace} .t insert end "7. A simple scrollable canvas." {demo demo-cscroll} .t insert end " \n " {demospace} .t insert end \n {} "Scales" title .t insert end " \n " {demospace} .t insert end "1. Vertical scale." {demo demo-vscale} .t insert end " \n " {demospace} .t insert end "2. Horizontal scale." {demo demo-hscale} .t insert end " \n " {demospace} .t insert end \n {} "Menus" title .t insert end " \n " {demospace} .t insert end "1. A window containing several menus and cascades." \ {demo demo-menu} .t insert end " \n " {demospace} .t insert end \n {} "Common Dialogs" title .t insert end " \n " {demospace} .t insert end "1. Message boxes." {demo demo-msgbox} .t insert end " \n " {demospace} .t insert end "2. File selection dialog." {demo demo-filebox} .t insert end " \n " {demospace} .t insert end "3. Color picker." {demo demo-clrpick} .t insert end " \n " {demospace} .t insert end \n {} "Miscellaneous" title .t insert end " \n " {demospace} .t insert end "1. The built-in bitmaps." {demo demo-bitmap} .t insert end " \n " {demospace} .t insert end "2. A dialog box with a local grab." {demo demo-dialog1} .t insert end " \n " {demospace} .t insert end "3. A dialog box with a global grab." {demo demo-dialog2} .t insert end " \n " {demospace} .t configure -state disabled focus .s # positionWindow -- # This procedure is invoked by most of the demos to position a # new demo window. # # Arguments: # w - The name of the window to position. proc positionWindow w { wm geometry $w +300+300 } # showVars -- # Displays the values of one or more variables in a window, and # updates the display whenever any of the variables changes. # # Arguments: # w - Name of new window to create for display. # args - Any number of names of variables. proc showVars {w args} { catch {destroy $w} toplevel $w wm title $w "Variable values" label $w.title -text "Variable values:" -width 20 -anchor center \ -font -Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-* pack $w.title -side top -fill x set len 1 foreach i $args { if {[string length $i] > $len} { set len [string length $i] } } foreach i $args { frame $w.$i label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w label $w.$i.value -textvar $i -anchor w pack $w.$i.name -side left pack $w.$i.value -side left -expand 1 -fill x pack $w.$i -side top -anchor w -fill x } button $w.ok -text OK -command "destroy $w" pack $w.ok -side bottom -pady 2 } # invoke -- # This procedure is called when the user clicks on a demo description. # It is responsible for invoking the demonstration. # # Arguments: # index - The index of the character that the user clicked on. proc invoke index { global tk_library set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] if {$i < 0} { return } set cursor [.t cget -cursor] .t configure -cursor watch update set demo [string range [lindex $tags $i] 5 end] uplevel [list source [file join $tk_library demos $demo.tcl]] update .t configure -cursor $cursor .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" } # showStatus -- # # Show the name of the demo program in the status bar. This procedure # is called when the user moves the cursor over a demo description. # proc showStatus index { global tk_library set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] set cursor [.t cget -cursor] if {$i < 0} { .statusBar.lab config -text " " set newcursor xterm } else { set demo [string range [lindex $tags $i] 5 end] .statusBar.lab config -text "Run the \"$demo\" sample program" set newcursor hand2 } if [string compare $cursor $newcursor] { .t config -cursor $newcursor } } # showCode -- # This procedure creates a toplevel window that displays the code for # a demonstration and allows it to be edited and reinvoked. # # Arguments: # w - The name of the demonstration's window, which can be # used to derive the name of the file containing its code. proc showCode w { global tk_library set file [string range $w 1 end].tcl if ![winfo exists .code] { toplevel .code frame .code.buttons pack .code.buttons -side bottom -fill x button .code.buttons.dismiss -text Dismiss -command "destroy .code" button .code.buttons.rerun -text "Rerun Demo" -command { eval [.code.text get 1.0 end] } pack .code.buttons.dismiss .code.buttons.rerun -side left \ -expand 1 -pady 2 frame .code.frame pack .code.frame -expand yes -fill both -padx 1 -pady 1 text .code.text -height 40 -wrap word\ -xscrollcommand ".code.xscroll set" \ -yscrollcommand ".code.yscroll set" \ -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 scrollbar .code.xscroll -command ".code.text xview" \ -highlightthickness 0 -orient horizontal scrollbar .code.yscroll -command ".code.text yview" \ -highlightthickness 0 -orient vertical grid .code.text -in .code.frame -padx 1 -pady 1 \ -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news # grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ # -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news grid rowconfig .code.frame 0 -weight 1 -minsize 0 grid columnconfig .code.frame 0 -weight 1 -minsize 0 } else { wm deiconify .code raise .code } wm title .code "Demo code: [file join $tk_library demos $file]" wm iconname .code $file set id [open [file join $tk_library demos $file]] .code.text delete 1.0 end .code.text insert 1.0 [read $id] .code.text mark set insert 1.0 close $id } # aboutBox -- # # Pops up a message box with an "about" message # proc aboutBox {} { tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ "Tk widget demonstration\n\n\ Copyright (c) 1996 Sun Microsystems, Inc." } gcl-2.6.14/gcl-tk/demos-4.2/widget.lisp0000755000175000017500000003557614360276512015763 0ustar cammcamm;;#!/bin/sh ;; the next line restarts using wish ;(exec :wish4.2 (tk-conc 0) "$@") (in-package "TK") ;; widget -- ;; This script demonstrates the various widgets provided by Tk, ;; along with many of the features of the Tk toolkit. This file ;; only contains code to generate the main window for the ;; application, which invokes individual demonstrations. The ;; code for the actual demonstrations is contained in separate ;; ".tcl" files is this directory, which are sourced by this script ;; as needed. ;; ;; SCCS: @(#) :widget 1.21 96/10/04 17:09:34 (apply 'destroy (winfo :child '|.| :return 'list)) (wm :title '|.| "Widget Demonstration") ;;---------------------------------------------------------------- ;; The code below create the main window, consisting of a menu bar ;; and a text widget that explains how to use the program, plus lists ;; all of the demos as hypertext items. ;;---------------------------------------------------------------- (setq font '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*) (frame '.menuBar) (pack '.menuBar :side "top" :fill "x") (menubutton '.menuBar.file :text "File" :menu '.menuBar.file.m :underline 0) (menu '.menuBar.file.m) (.menuBar.file.m :add :command :label "About '... " :command "aboutBox" :underline 0 :accelerator "") (.menuBar.file.m :add :sep) (.menuBar.file.m :add :command :label "Quit" :command "exit" :underline 0) (pack '.menuBar.file :side "left") (bind '|.| "" 'aboutBox) (frame '.textFrame) (scrollbar '.s :orient "vertical" :command '(.t :yview) :highlightthickness 0 :takefocus 1) (pack '.s :in '.textFrame :side "right" :fill "y" :padx 1) (text '.t :yscrollcommand '(.s :set) :wrap "word" :width 60 :height 30 :font font :setgrid 1 :highlightthickness 0 :padx 4 :pady 2 :takefocus 0) (pack '.t :in '.textFrame :expand "y" :fill "both" :padx 1) (pack '.textFrame :expand "yes" :fill "both" :padx 1 :pady 2) (frame '.statusBar) (label '.statusBar.lab :text " " :relief "sunken" :bd 1 :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") (label '.statusBar.foo :width 8 :relief "sunken" :bd 1 :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") (pack '.statusBar.lab :side "left" :padx 2 :expand "yes" :fill "both") (pack '.statusBar.foo :side "left" :padx 2) (pack '.statusBar :side "top" :fill "x" :pady 2) ;; Create a bunch of tags to use in the text widget, such as those for ;; section titles and demo descriptions. Also define the bindings for ;; tags. (.t :tag :configure "title" :font :*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*) ;; We put some "space" characters to the left and right of each demo description ;; so that the descriptions are highlighted only when the mouse cursor ;; is right over them (but :not when the cursor is to their left or right) ;; (.t :tag :configure "demospace" :lmargin1 "1c" :lmargin2 "1c") (if (equal (winfo :depth '|.| :return 'number) 1) (progn (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" :underline 1) (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" :underline 1) (.t :tag :configure "hot" :background "black" :foreground "white") ) ;;else (progn (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" :foreground "blue" :underline 1) (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" :foreground "#303080" :underline 1) (.t :tag :configure "hot" :foreground "red" :underline 1) )) (.t :tag :bind "demo" "" '(invoke (.t index "@%x,%y")) ) (setq lastLine "") (.t :tag :bind "demo" "" '(progn (setq lastLine (.t :index "@" : |%x| :"," : |%y| "linestart" :return 'number)) (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) (.t :config :cursor "hand2") (showStatus (.t :index "@" : |%x| :"," : |%y| :return 'number)) )) (.t :tag :bind "demo" "" '(progn (.t :tag :remove "hot" 1.0 end) (.t :config :cursor "xterm") (.statusBar.lab :config :text "") ) (.t :tag :bind "demo" "" '(progn (setq newLine [.t index {@%x,%y linestart}]) (if ([string :compare newLine $lastLine] != 0) (progn (.t :tag :remove "hot" 1.0 end) (setq lastLine newLine) (setq tags [.t tag names {@%x,%y}]) (setq i [lsearch :glob tags "demo-*"]) (if (funcall i >= 0) {) (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) ) ) (showStatus (.t :index "@%x,%y" :return 'number)) )) ;; Create the text for the text widget. (.t :insert end "Tk Widget Demonstrations\n" title) (.t :insert end {) (This :application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. (if :you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code.) } (setq *newline* " ") (.t :insert :end "Labels, buttons, checkbuttons, and radiobuttons" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Labels (text :and bitmaps)." "demo demo-label") (.t :insert :end " \n " "demospace") (.t :insert :end "2. Buttons." "demo demo-label") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Checkbuttons (select :any of a group)." "demo demo-check") (.t :insert :end *newline* "demospace") (.t :insert :end "4. Radiobuttons (select :one of a group).""demo demo-radio") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A 15-puzzle game made out of buttons.""demo demo-puzzle") (.t :insert :end *newline* "demospace") (.t :insert :end "6. Iconic buttons that use bitmaps." "demo demo-icon") (.t :insert :end *newline* "demospace") (.t :insert :end "7. Two labels displaying images." "demo demo-image1") (.t :insert :end *newline* "demospace") (.t :insert :end "8. A simple user interface for viewing images." "demo demo-image2") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Listboxes" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. 50 states." "demo demo-states") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Colors: change the color scheme for the application." "demo demo-colors") (.t :insert :end *newline* "demospace") (.t :insert :end "3. A collection of famous sayings." "demo demo-sayings") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Entries" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Without scrollbars." "demo demo-entry1") (.t :insert :end *newline* "demospace") (.t :insert :end "2. With scrollbars." "demo demo-entry2") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Simple Rolodex-like form." "demo demo-form") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Text" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Basic editable text." "demo demo-text") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Text display styles." "demo demo-style") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Hypertext (tag :bindings)." "demo demo-bind") (.t :insert :end *newline* "demospace") (.t :insert :end "4. A text widget with embedded windows." "demo demo-twind") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A search tool built with a text widget." "demo demo-search") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Canvases" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. The canvas item types." "demo demo-items") (.t :insert :end *newline* "demospace") (.t :insert :end "2. A simple 2-D plot." "demo demo-plot") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Text items in canvases." "demo demo-ctext") (.t :insert :end *newline* "demospace") (.t :insert :end "4. An editor for arrowheads on canvas lines." "demo demo-arrow") (.t :insert :end *newline* "demospace") (.t :insert :end "5. A ruler with adjustable tab stops." "demo demo-ruler") (.t :insert :end *newline* "demospace") (.t :insert :end "6. A building floor plan." "demo demo-floor") (.t :insert :end *newline* "demospace") (.t :insert :end "7. A simple scrollable canvas." "demo demo-cscroll") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Scales" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Vertical scale." "demo demo-vscale") (.t :insert :end *newline* "demospace") (.t :insert :end "2. Horizontal scale." "demo demo-hscale") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Menus" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. A window containing several menus and cascades." (demo demo-menu)) (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Common Dialogs" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. Message boxes." "demo demo-msgbox") (.t :insert :end *newline* "demospace") (.t :insert :end "2. File selection dialog." "demo demo-filebox") (.t :insert :end *newline* "demospace") (.t :insert :end "3. Color picker." "demo demo-clrpick") (.t :insert :end *newline* "demospace") (.t :insert :end *newline* : "Miscellaneous" "title") (.t :insert :end *newline* "demospace") (.t :insert :end "1. The built-in bitmaps." "demo demo-bitmap") (.t :insert :end *newline* "demospace") (.t :insert :end "2. A dialog box with a local grab." "demo demo-dialog1") (.t :insert :end *newline* "demospace") (.t :insert :end "3. A dialog box with a global grab." "demo demo-dialog2") (.t :insert :end *newline* "demospace") (.t :configure :state "disabled") (focus '.s) ;; positionWindow -- ;; This procedure is invoked by most of the demos to position a ;; new demo window. ;; ;; Arguments: ;; w - The name of the window to position. (defun positionWindow w (wm :geometry w +300+300) ) ;; showVars -- ;; Displays the values of one or more variables in a window, and ;; updates the display whenever any of the variables changes. ;; ;; Arguments: ;; w - Name of new window to create for display. ;; args - Any number of names of variables. (defun showVars (w args) (if (winfo :exists w) (destroy :w)) (toplevel w) (wm :title w "Variable values") (label (conc w '."title") :text "Variable values:" :width 20 :anchor "center" :font :Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-*) (pack (conc w '."title") :side "top" :fill "x") (setq len 1) foreach i args { ( (if ([string :length $i] > len) (progn ) (setq len [string length $i]) ( )) } foreach i args { (frame (conc w '|.| i)) (label (conc w '|.| i '.name) :text (tk-conc i ": ") :width ( + len 2) :anchor "w") (label (conc w '|.| i '.value) :textvar i :anchor "w") (pack (conc w '|.| i '.name) :side "left") (pack (conc w '|.| i '.value) :side "left" :expand 1 :fill "x") (pack (conc w '|.| i) :side "top" :anchor "w" :fill "x") } (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) (pack (conc w '.ok) :side "bottom" :pady 2) ) ;; invoke -- ;; This procedure is called when the user clicks on a demo description. ;; It is responsible for invoking the demonstration. ;; ;; Arguments: ;; index - The index of the character that the user clicked on. (defun invoke index (global :tk_library) (setq tags [.t tag names $index]) (setq i [lsearch :glob tags demo-*]) (if (funcall i < 0) (progn (return) ) (setq cursor [.t cget :cursor]) (.t :configure :cursor "watch") (update) (setq demo [string range [lindex tags $i] 5 end]) (uplevel [list source [file join $tk_library demos (conc demo '.tcl)]]) (update) (.t :configure :cursor cursor) (.t :tag :add visited (tk-conc index " linestart +1 chars") (tk-conc index " lineend -1 chars")) ) ;; showStatus -- ;; ;; Show the name of the demo program in the status bar. This procedure ;; is called when the user moves the cursor over a demo description. ;; (defun showStatus (index ) ;(global :tk_library) ; (setq index (round index)) (setq tags (.t :tag "names" index :return 'string)) (setq i (lsearch "-glob" tags "demo-*" :return 'number)) (setq cursor (.t :cget :cursor :return 'string)) (if (< i 0) (progn (.statusBar.lab :config :text " ") (setq newcursor "xterm") ) ;;else (progn (setq demo (string :range (lindex tags i :return 'string) 5 "end" :return 'string)) (.statusBar.lab :config :text (tk-conc "Run the \"" demo "\" sample program")) (setq newcursor "hand2") )) (if (string :compare cursor newcursor :return 'boolean) (.t :config :cursor newcursor) ) ) ;; showCode -- ;; This procedure creates a toplevel window that displays the code for ;; a demonstration and allows it to be edited and reinvoked. ;; ;; Arguments: ;; w - The name of the demonstration's window, which can be ;; used to derive the name of the file containing its code. (defun showCode w (global :tk_library) (setq file [string range w 1 end].tcl) (if ![winfo exists '.code] { (toplevel '.code) (frame '.code.buttons) (pack '.code.buttons :side "bottom" :fill "x") (button '.code.buttons.dismiss :text "Dismiss" :command "destroy '.code") (button '.code.buttons.rerun :text "Rerun Demo" :command {) (eval [.code.text get 1.0 end]) } (pack '.code.buttons.dismiss '.code.buttons.rerun :side "left" :expand 1 :pady 2) (frame '.code.frame) (pack '.code.frame :expand "yes" :fill "both" :padx 1 :pady 1) (text '.code.text :height 40 :wrap "word " :xscrollcommand ".code.xscroll set" :yscrollcommand ".code.yscroll set" :setgrid 1 :highlightthickness 0 :pady 2 :padx 3) (scrollbar '.code.xscroll :command ".code.text xview" :highlightthickness 0 :orient "horizontal") (scrollbar '.code.yscroll :command ".code.text yview" :highlightthickness 0 :orient "vertical") (grid '.code.text :in '.code.frame :padx 1 :pady 1 :row 0 :column 0 :rowspan 1 :columnspan 1 :sticky "news") (grid '.code.yscroll :in '.code.frame :padx 1 :pady 1 :row 0 :column 1 :rowspan 1 :columnspan 1 :sticky "news") ;; grid '.code.xscroll :in '.code.frame :padx 1 :pady 1 ;; :row 1 :column 0 :rowspan 1 :columnspan 1 :sticky "news" (grid :rowconfig '.code.frame 0 :weight 1 :minsize 0) (grid :columnconfig '.code.frame 0 :weight 1 :minsize 0) } else { (wm :deiconify '.code) (raise '.code) } (wm :title '.code (tk-conc "Demo code: [file join " tk "_library demos " file "]")) (wm :iconname '.code file) (setq id [open [file join $tk_library demos $file]]) (.code.text :delete 1.0 end) (.code.text :insert 1.0 [read $id]) (.code.text :mark set insert 1.0) (close id) ) ;; aboutBox -- ;; ;; Pops up a message box with an "about" message ;; (defun aboutBox () (tk_messageBox :icon "info" :type "ok" :title "About Widget Demo" :message "Tk widget demonstration\\n\\n Copyright (c) 1996 Sun Microsystems, Inc.") ) gcl-2.6.14/gcl-tk/convert.el0000755000175000017500000001465214360276512014171 0ustar cammcamm (defun try () (interactive) (goto-char (point-min)) (if (looking-at "#") (insert ";;")) (grab-variables) (goto-char (point-min)) (do-replacements '(("\n\\([ \t]*\\)#" "\n\\1;;") ("catch {destroy $w}" "(if (winfo :exists w) (destroy w))") ("\\[tk colormodel [$]w\\] == \"color\"" "equal (tk :colormodel w) \"color\"") )) (goto-char (point-min)) (replace-proc) (goto-char (point-min)) (replace-if) (goto-char (point-min)) (separate-lines) (goto-char (point-min)) (replace-keywords) (do-replacements '(("@[$]tk_library\\([^ \t\n]+\\)" "\"@\" : *tk-library* : \"\\1\""))) (goto-char (point-min)) (replace-$-in-string) (goto-char (point-min)) (do-replacements *replacements*) (goto-char (point-min)) (do-replacements '(( "[$]\\([a-z0-9A-Z]+\\)\\([)} \n]\\)" "\\1\\2"))) (do-replacements '(( " \\([0-9][0-9.]*[cmpi]\\)" " \"\\1\"") ("\\(:create\\|:tag\\|:add\\|:scan\\:select\\:mark\\) \\([a-z]\\)" "\\1 :\\2") ; (":add \\([a-z]\\)" ":add '\\1") )) (do-replacements '(("\\([ \t]\\)[.]\\([a-z0-9A-Z.]*\\)" "\\1'.\\2") ("'[.] " "'|.| ") ("((conc " "(funcall (conc ")) t) ) (defun grab-variables () (let (tem) (setq the-variables nil) (while (re-search-forward "[$]\\([a-zA-Z0-9]+\\)" nil t) (setq tem (buffer-substring (match-beginning 1) (match-end 1))) (or (member tem the-variables) (setq the-variables (cons tem the-variables)))))) (defun separate-lines () (interactive) (while (re-search-forward "\n[ \t]*[^;#() \n]" nil t) (forward-char -1) (cond ((or (looking-at "}") (looking-at "for"))) (t ; (forward-sexp -1) (insert "(") (re-search-forward "[^\\]\n" nil t) (forward-char -1)(insert ")") )))) (defun replace-keywords () (interactive) (while (re-search-forward "\\([ \t]\\)-\\([a-zA-Z]\\)" nil t) (replace-match "\\1:\\2") (forward-sexp 1) (skip-chars-forward " ") (cond ((looking-at "[a-z]") (insert "\"")(forward-sexp 1) (insert "\"")))) (goto-char (point-min)) (while (re-search-forward "(\\([^ ]+\\)" nil t) (let ((tem (buffer-substring (match-beginning 1)(match-end 0)))) ; (message (princ tem)) (sit-for 1) (cond ((equal tem "defun")(forward-line 1)(beginning-of-line)) ((member tem '("defun" "set"))) (t (skip-chars-forward " ") (cond ((looking-at "[a-z]") (insert ":")))))))) (defvar the-variables nil) (defun replace-$-in-string () (interactive) (let (tem beg (end (make-marker ))) (while (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" nil t) (forward-char -1) (cond ((in-a-string) (goto-char this-string-began ) (setq beg (point)) (insert "(tk-conc ") (setq beg (point)) (forward-sexp 1) (set-marker end (point)) (insert ")") (goto-char beg) (while (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" end t) (replace-match "\\1\" \\2 \"")) (goto-char (- beg 2)) (while (re-search-forward " \"\"" end t) (replace-match "")) (set-marker end nil) )) ))) (defun change-{-to-paren () (interactive) (let (end) (cond ((search-forward "{" nil t) (forward-char -1) (let ((p (point))) (forward-sexp 1) (delete-region (- (point) 1)(point)) (insert ")") (setq end (point)) (goto-char p) (delete-region p (+ p 1)) (insert "(")) (goto-char end) t)))) (defun in-a-string () (interactive) (save-excursion (save-match-data (let ((p (point)) (c 0)) (beginning-of-line) (while (re-search-forward "[^\\]\"" p t) (setq this-string-began (+ 1 (match-beginning 0))) (setq c (+ c 1))) (eql 1 (mod c 2)))))) (defun replace-proc () (interactive) (while (re-search-forward "[ \t\n]\\(proc\\) " nil t) (goto-char (match-beginning 1)) (delete-region (match-beginning 1) (match-end 0)) (insert "(defun ") (forward-sexp 1) (skip-chars-forward " \n\t") (cond ((looking-at "{{") (change-{-to-paren) (forward-sexp -1) (forward-char 1) (insert "&optional ") (change-{-to-paren)) ((looking-at "{") (change-{-to-paren))) (change-{-to-paren) (forward-sexp -1) (delete-char 1))) (defun replace-if () (interactive) (while (re-search-forward "[ \t\n]\\(if\\) " nil t) (goto-char (match-beginning 1)) (delete-region (match-beginning 1) (match-end 0)) (insert "(if ") (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren))) (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren) (save-excursion (forward-sexp -1) (forward-char 1) (insert "progn ")))) (skip-chars-forward " \n\t") (cond ((looking-at "else") (replace-match ";;else \n") (skip-chars-forward " \n\t") (cond ((looking-at "{") (change-{-to-paren) (save-excursion (forward-sexp -1) (forward-char 1) (insert "progn ")))) (insert ")") )))) (setq *replacements* '( ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.]+\\)" "(conc \\1 '|.| \\2 '.\\3)") ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9)]+\\)" "(conc \\1 '|.| \\2)") ("[$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.)]+\\)" "(conc \\1 '.\\2\)") ("\\(<[a-z0-9A-Z---]+>\\)" "\"\\1\"") ("[[]expr \\([a-z$A-Z0-9]+\\)\\([ ]*[+---*][ ]*\\)\\([a-z$A-Z0-9]+\\)\\]" "(\\2 \\1 \\3)") ("[[]expr \\([a-z$A-Z0-9]+\\)\\]" "\\1") ("($\\([a-z0-9A-Z]+\\)[.]\\([a-z0-9A-Z.]+\\)" "(funcall (conc \\1 '.\\2)") ("($\\([a-z0-9A-Z]+\\)" "(funcall \\1") ("[[]$\\([a-z0-9A-Z]+\\)\\([^]]+\\)\\]" "(funcall \\1\\2)") ("[{]$\\([a-z0-9A-Z]+\\)\\([^}]+\\)\\}" "(funcall \\1\\2)") ("[\\]\n" "\n") ("\n\\([ \t]*\\)#" "\n\\1;") ("(set " "(setq ") ("tk_menuBar" "tk-menu-bar") ("@\\([$a-zA-Z0-9]+\\),\\([$a-zA-Z0-9]+\\)" "(aT \\1 \\2)") ("\\(:variable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") ("\\(:textvariable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") (":font -" ":font :") (":create \\([a-z]+\\)" ":create \"\\1\"") )) (defun do-replacements (lis &optional not-in-string) (let (x) (while lis (setq x (car lis)) (setq lis (cdr lis)) (goto-char (point-min)) (while (re-search-forward (nth 0 x) nil t) (and not-in-string (progn (forward-char -1) (not (in-a-string)))) (replace-match (nth 1 x) t))))) gcl-2.6.14/gcl-tk/sysdep-sunos.h0000755000175000017500000000023114360276512015000 0ustar cammcamm#ifndef _SYSDEP_SUNOS_H_ #define _SYSDEP_SUNOS_H_ #include #define memmove(d,s,c) bcopy(s,d,c) #define strerror(err) (perror(err),0) #endif gcl-2.6.14/gcl-tk/gcl_cmpinit.lsp0000755000175000017500000000002714360276512015166 0ustar cammcamm(load "tk-package.lsp")gcl-2.6.14/gcl-tk/socketsl.lisp0000755000175000017500000000203614360276512014700 0ustar cammcamm(in-package "SI") ; (clines "#define our_read_with_offset(fd,buffer,offset,nbytes,timeout) our_read(fd,&((buffer)->ust.ust_self[offset]),nbytes,timeout)") ;;(defun our-read-with-offset (fd buffer offset bytes-to-read timeout) ;; (return bytes read) ;(defentry our-read-with-offset (int object int int int) (int "our_read_with_offset")) (clines "#define our_write_object(fd,buffer,nbytes) our_write(fd,buffer->ust.ust_self,nbytes)") ;; (defun our-write (fd buffer nbytes) (return bytes-written)) (defentry our-write (int object int ) (int "our_write_object")) (defentry print-to-string1 (object object object) (object print_to_string1)) ;(clines "#define symbol_value_any(x) ((x)->s.s_dbind)") ;(defentry symbol-value-any (object) (object symbol_value_any)) ;(clines "#define get_signals_allowed() signals_allowed") ;(defentry signals-allowed () (int "get_signals_allowed")) ;(defentry install_default_signals ()(int "install_default_signals")) ;(defentry unblock-signal (int) (int "unblock_signal")) (defentry getpid () (int "getpid")) gcl-2.6.14/gcl-tk/gcltksrv.in.interp0000755000175000017500000000044214360276512015646 0ustar cammcamm#!/bin/sh # comment \ export GCL_TK_DIR ; \ GCL_TK_DIR=/d2/wfs/gcl-2.3/gcl-tk #comment \ export DISPLAY; DISPLAY=$4 ; exec wish "$0" "$@" set host [lindex $argv 0] set port [lindex $argv 1] set pid [lindex $argv 2] source $env(GCL_TK_DIR)/decode.tcl GclAnswerSocket $host $port $pid gcl-2.6.14/gcl-tk/tkXAppInit.c0000755000175000017500000001063014360276512014356 0ustar cammcamm/* * tkXAppInit.c -- * * Provides a default version of the Tcl_AppInit procedure for use with * applications built with Extended Tcl and Tk. This is based on the * the UCB Tk file tkAppInit.c * *----------------------------------------------------------------------------- * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id$ *----------------------------------------------------------------------------- * Copyright (c) 1993 The Regents of the University of California. * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, modify, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. * * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ #ifndef lint static char rcsid[] = "$Header$ SPRITE (Berkeley)"; #endif /* not lint */ #include "tclExtend.h" #include "tk.h" #include /* * The following variable is a special hack that allows applications * to be linked using the procedure "main" from the Tk library. The * variable generates a reference to "main", which causes main to * be brought in from the library (and all of Tk and Tcl with it). */ EXTERN int main _ANSI_ARGS_((int argc, char **argv)); int *tclDummyMainPtr = (int *) main; /* * The following variable is a special hack that insures the tcl * version of matherr() is used when linking against shared libraries * Only define if matherr is used on this system. */ #if defined(DOMAIN) && defined(SING) EXTERN int matherr _ANSI_ARGS_((struct exception *)); int *tclDummyMathPtr = (int *) matherr; #endif /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tk_Window main; main = Tk_MainWindow(interp); /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ if (TclX_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (TkX_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ tcl_RcFileName = "~/.tclrc"; return TCL_OK; } gcl-2.6.14/gcl-tk/demos-4.1/0000755000175000017500000000000014360276512013563 5ustar cammcammgcl-2.6.14/gcl-tk/demos-4.1/items.lisp0000755000175000017500000003163614360276512015611 0ustar cammcamm;;# items.lisp -- This demo has been converted for tk4.1 from the ;; corresponding tcl demo program. ;; ;; This demonstration script creates a canvas that displays the ;; canvas item types. ;; ;; @(#) :items.tcl 1.5 95/10/04 15:00:39 (defun positionwindow (w) (wm :geometry w "+60+25") ) (setq w '.items) (if (winfo :exists w) (destroy w)) (toplevel w) (wm :title w "Canvas Item Demonstration") (wm :iconname w "Items") (positionWindow w) (setq c (conc w '.frame.c)) (setq font :Adobe-times-medium-r-normal--*-180* ) (label (conc w '.msg) :font font :wraplength "5i" :justify "left" :text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") (pack (conc w '.msg) :side "top") (frame (conc w '.buttons)) (pack (conc w '.buttons) :side "bottom" :expand "y" :fill "x" :pady "2m") (button (conc w '.buttons.dismiss) :text "Dismiss" :command (tk-conc "destroy " w)) (button (conc w '.buttons.code) :text "See Code" :command (tk-conc "showCode " w)) (pack (conc w '.buttons.dismiss) (conc w '.buttons.code) :side "left" :expand 1) (frame (conc w '.frame)) (pack (conc w '.frame) :side "top" :fill "both" :expand "yes") (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" :relief "sunken" :borderwidth 2 :xscrollcommand (tk-conc w ".frame.hscroll set") :yscrollcommand (tk-conc w ".frame.vscroll set")) (scrollbar (conc w '.frame.vscroll) :command (tk-conc c " yview")) (scrollbar (conc w '.frame.hscroll) :orient "horiz" :command (tk-conc c " xview")) (pack (conc w '.frame.hscroll) :side "bottom" :fill "x") (pack (conc w '.frame.vscroll) :side "right" :fill "y") (pack c :in (conc w '.frame) :expand "yes" :fill "both") ;; Display a 3x3 rectangular grid. (funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) (funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) (funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) (funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) (funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) (setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*) (setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*) (if (> (winfo :depth c :return 'number) 1) (progn (setq blue "DeepSkyBlue3") (setq red "red") (setq bisque "bisque3") (setq green "SeaGreen3") ) ;;else (progn (setq blue "black") (setq red "black") (setq bisque "black") (setq green "black") )) ;; Set up demos within each of the areas of the grid. (funcall c :create "text" "5c" '.2c :text "Lines" :anchor "n") (funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue :cap "butt" :join "miter" :tags "item") (funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") (funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") (funcall c :create "line" "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :width 3 :fill red :tags "item") (funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" :width '.5c :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :arrow "both" :arrowshape "15 15 7" :tags "item") (funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" "5.8c" "4c" "7c" :width '.5c :cap "round" :join "round" :tags "item") (funcall c :create "text" "15c" '.2c :text "Curves (smoothed :lines)" :anchor "n") (funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" "4c" :smooth "on" :fill blue :tags "item") (funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" "19.5c" "4c" :smooth "on" :arrow "both" :width 3 :tags "item") (funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") (funcall c :create "text" "25c" '.2c :text "Polygons" :anchor "n") (funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" "23.25c" "2.5c" "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" :fill green :outline "black" :width 4 :tags "item") (funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") (funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :outline "black" :tags "item") (funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") (funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") (funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") (funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") (funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") (funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") (funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") (funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") (funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") (funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") (funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue :text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." :justify "center" :tags "item") (funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") (funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red :stipple "gray50" :text "Stippled characters" :tags "item") (funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") (funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" :start 45 :extent 270 :style "pieslice" :tags "item") (funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" :outline blue :start -135 :extent 270 :outlinestipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") (funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" :fill "" :outline red :start 225 :extent -90 :tags "item") (funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" :fill blue :outline "" :start 45 :extent 270 :tags "item") (funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") (funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") (funcall c :create "bitmap" "17c" "18.5c" :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") (funcall c :create "bitmap" "17c" "21.5c" :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") (funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") (button (conc c '.button) :text "Press Me" :command `(butpress ',c "red")) (funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") (entry (conc c '.entry) :width 20 :relief "sunken") (funcall (conc c '.entry) :insert "end" "Edit this text") (funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") (scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c :width '.5c :tickinterval 0) (funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") (funcall c :create "text" "21c" "17.9c" :text "Button": :anchor "sw") (funcall c :create "text" "21c" "20.9c" :text "Entry": :anchor "sw") (funcall c :create "text" "28.5c" "17.4c" :text "Scale": :anchor "s") ;; Set up event bindings for canvas: (funcall c :bind "item" "" `(itemEnter ',c)) (funcall c :bind "item" "" `(itemLeave ',c)) (bind c "<2>" (tk-conc c " scan mark %x %y")) (bind c "" (tk-conc c " scan dragto %x %y")) (bind c "<3>" `(itemMark ',c |%x| |%y|)) (bind c "" `(itemStroke ',c |%x| |%y|)) (bind c "" `(itemsUnderArea ',c)) (bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) (bind c "" `(itemDrag ',c |%x| |%y|)) (focus c) ;; Utility procedures for highlighting the item under the pointer: (defvar *restorecmd* nil) (defun itemEnter (c &aux type bg) ; (global :*restorecmd*) (let ((current (funcall c :find "withtag" "current" :return 'string))) (if (equal current "") (return-from itementer nil)) (itemleave nil) (setq type (funcall c :type current :return 'string)) (if (equal type "window") (progn (itemLeave nil) (return-from itemEnter nil))) (if (equal type "bitmap") (progn (setq bg (nth 4 (funcall c :itemconf current :background :return 'list-strings))) (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) (funcall c :itemconfig current :background "SteelBlue2") (return-from itemEnter nil))) (setq fill (nth 4 (funcall c :itemconfig current :fill :return 'list-strings))) (if (or (member type '("rectangle" "oval" "arg") :test 'equal) (equal fill "")) (progn (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) (funcall c :itemconfig current :outline "SteelBlue2")) (progn (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) (funcall c :itemconfig current :fill "SteelBlue2"))) ) ) (defun itemLeave (c) ; (global :*restorecmd*) (let ((tem *restorecmd*)) (setq *restorecmd* nil) (dolist (v tem) (eval v)))) ;; Utility procedures for stroking out a rectangle and printing what's ;; underneath the rectangle's area. (defun itemMark (c x y) ; (global :areaX1 areaY1) (setq areaX1 (funcall c :canvasx x :return 'string)) (setq areaY1 (funcall c :canvasy y :return 'string)) (funcall c :delete "area") ) (defun itemStroke (c x y ) (declare (special areaX1 areaY1 areaX2 areaY2)) (or *recursive* (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'string)) (setq y (funcall c :canvasy y :return 'string)) (progn (setq areaX2 x) (setq areaY2 y) ;; this next return 'stringis simply for TIMING!!! ;; to make it wait for the result before going into subsequent!! (funcall c :delete "area" :return 'string) (funcall c :addtag "area" "withtag" (funcall c :create "rect" areaX1 areaY1 x y :outline "black" :return 'string)) )))) (defun itemsUnderArea (c) ; (global :areaX1 areaY1 areaX2 areaY2) (setq area (funcall c :find "withtag" "area" :return 'string)) (setq me c) (setq items "") (dolist (i (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items enclosed by area: " items)) (setq items "") (dolist (i (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 :return 'list-strings)) (if (search "item" (funcall c :gettags i :return 'string)) (setq items (tk-conc items " " i)))) (print (tk-conc "Items overlapping area: " items)) (terpri) (force-output) ) (setq areaX1 0) (setq areaY1 0) (setq areaX2 0) (setq areaY2 0) ;; Utility procedures to support dragging of items. (defun itemStartDrag (c x y) ; (global :lastX lastY) (setq lastX (funcall c :canvasx x :return 'number)) (setq lastY (funcall c :canvasy y :return 'number)) ) (defun itemDrag (c x y) ; (global :lastX lastY) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x lastX) (- y lastY)) (setq lastX x) (setq lastY y) ) (defvar *recursive* nil) (defun itemDrag (c x y) ; (global :lastX lastY) (cond (*recursive* ) (t (let ((*recursive* t)) (setq x (funcall c :canvasx x :return 'number)) (setq y (funcall c :canvasy y :return 'number)) (funcall c :move "current" (- x lastX) (- y lastY)) (setq lastX x) (setq lastY y))))) ;; Procedure that's invoked when the button embedded in the canvas ;; is invoked. (defun butPress (w color) (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" :fill color :anchor "n" :return 'string)) (after 500 (tk-conc w " delete " i)) ) gcl-2.6.14/gcl-tk/guis.c0000755000175000017500000002650114360276512013276 0ustar cammcamm/* Copyright (C) 1994 Rami el Charif, W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define IN_GUIS #include #include #include #ifdef __cplusplus extern "C" { #endif #include #ifndef _WIN32 # include # ifdef PLATFORM_NEXT # include # include # else # include # include # endif #endif /* #include */ #include #ifndef _WIN32 #include #endif #include #include #include #ifdef __cplusplus #ifdef PLATFORM_NEXT extern unsigned long inet_addr( char *cp ); extern char *inet_ntoa ( struct in_addr in ); #endif } #endif #ifdef PLATFORM_LINUX #include #endif #include #ifdef __svr4__ #include #endif #ifdef PLATFORM_NEXT /* somehow, this is getting lost... */ #undef bzero #define bzero(b,len) memset(b,0,len) #endif #include "guis.h" #ifndef TRUE #define TRUE (1) #define FALSE (0) #endif FILE *pstreamDebug; int fDebugSockets; /* #ifdef PLATFORM_SUNOS */ /* static void notice_input( ); */ /* #else */ /* static void notice_input(); */ /* #endif */ int hdl = -1; void TkX_Wish (); pid_t parent; int debug; #ifdef _WIN32 #include #include /* Keep track of socket initialisations */ int w32_socket_initialisations = 0; WSADATA WSAData; /* Use threads instead of fork() */ /* Struct to hold args for thread. */ typedef struct _TAS { char **argv; int argc; int rv; int delay; } TAS; #endif #include "comm.c" #ifdef _WIN32 #define SET_SESSION_ID() 0 UINT WINAPI tf1 ( void *tain ) { TAS *ta = (TAS *) tain; UINT rv = 0; if (SET_SESSION_ID() == -1) { fprintf ( stderr, "tf: Error - set session id failed : %d\n", errno ); } if ( w32_socket_init() >= 0 ) { dsfd = sock_connect_to_name ( ta->argv[1], atoi ( ta->argv[2] ), 0); if ( dsfd ) { fprintf ( stderr, "connected to %s %s\n", ta->argv[1], ta->argv[2] ); TkX_Wish ( ta->argc, ta->argv ); fprintf ( stderr, "Wish shell done\n" ); sock_close_connection ( dsfd ); ta->rv = 0; } else { fprintf ( stderr, "Error: Can't connect to socket host=%s, port=%s, errno=%d\n", ta->argv[1], ta->argv[2], errno ); fflush ( stderr ); ta->rv = -1; } w32_socket_exit(); } else { fprintf ( stderr, "tf: Can't initialise sockets - w32_socket_init failed.\n" ); } _endthreadex ( 0 ); return ( 0 ); } int w32_socket_init(void) { int rv = 0; if (w32_socket_initialisations++) { rv = 0; } else { if (WSAStartup(0x0101, &WSAData)) { w32_socket_initialisations = 0; fprintf ( stderr, "WSAStartup failed\n" ); WSACleanup(); rv = -1; } } return rv; } int w32_socket_exit(void) { int rv = 0; if ( w32_socket_initialisations == 0 || --w32_socket_initialisations > 0 ) { rv = 0; } else { rv = WSACleanup(); } return rv; } #endif /* Start up our Graphical User Interface connecting to NETWORK-ADDRESS on PORT to process PID. If fourth argument WAITING causes debugging flags to be turned on and also causes a wait in a loop for WAITING seconds (giving a human debugger time to attach to the forked process). */ #ifdef SGC int sgc_enabled=0; #endif int delay; int main(argc, argv,envp) int argc; char *argv[]; char *envp[]; { int rv = 0; { int i = argc; pstreamDebug = stderr; while (--i > 3) { if (strcmp(argv[i],"-delay")==0) { delay = atoi(argv[i+1]);} if (strcmp(argv[i],"-debug")==0) {debug = 1; fDebugSockets = -1;} } } if (argc >= 4) { #ifdef _WIN32 UINT dwThreadID; HANDLE hThread; TAS targs; void *pTA = (void *) &targs; targs.argv = argv; targs.argc = argc; targs.rv = 0; targs.delay = delay; hThread = (HANDLE) _beginthreadex ( NULL, 0, tf1, pTA, 0, &dwThreadID ); if ( 0 == hThread ) { dfprintf ( stderr, "Error: Couldn't create thread.\n" ); rv = -1; } if ( WAIT_OBJECT_0 != WaitForSingleObject ( hThread, INFINITE ) ) { dfprintf ( stderr, "Error: Couldn't wait for thread to exit.\n" ); rv = -1; } CloseHandle ( hThread ); #else /* _WIN32 */ pid_t p; parent = atoi(argv[3]); dfprintf(stderr,"guis, parent is : %d\n", parent); #ifdef MUST_USE_VFORK p = vfork(); #else p = fork(); #endif dfprintf(stderr, "guis, vfork returned : %d\n", p); if (p == -1) { dfprintf(stderr, "Error !!! vfork failed %d\n", errno); return -1; } else if (p) { dfprintf(stderr, "guis,vforked child : %d\n", p); _exit(p); /* return p; */ } else { #ifndef SET_SESSION_ID #if defined(__svr4__) || defined(ATT) #define SET_SESSION_ID() setsid() #else #ifdef BSD #define SET_SESSION_ID() (setpgrp() ? -1 : 0) #endif #endif #endif if (SET_SESSION_ID() == -1) { dfprintf(stderr, "Error !!! setsid failed : %d\n", errno); } dsfd = sock_connect_to_name(argv[1], atoi(argv[2]), 0); if (dsfd) { dfprintf(stderr, "connected to %s %s" , argv[1], argv[2]); /* give chance for someone to attach with gdb and to set waiting to 0 */ while (-- delay >=0) sleep(1); { TkX_Wish(argc, argv); } dfprintf(stderr, "Wish shell done\n"); sock_close_connection(dsfd); return 0; } else { dfprintf(stderr, "Error !!! Can't connect to socket host=%s, port=%s, errno=%d\n" , argv[1], argv[2], errno); fflush(stderr); return -1; } } #endif /* _WIN32 */ } else { int i; fprintf ( stderr, "gcltkaux: Error - expecting more arguments, but found:\n" ); fflush(stderr); for ( i = 0; ifd ); free(sfd->read_buffer); free(sfd); } /* #ifdef PLATFORM_SUNOS */ /* static void */ /* notice_input( int sig, int code, struct sigcontext *s, char *a ) */ /* #else */ /* static void */ /* notice_input( sig ) */ /* int sig; */ /* #endif */ /* { */ /* signal( SIGIO, notice_input ); */ /* dfprintf(stderr, "\nNoticed input!\n" ); */ /* } */ static int message_id; int sock_write_str2( sfd, type, hdr, hdrsize,text, length ) struct connection_state *sfd; enum mtype type; char *hdr; int hdrsize; const char *text; int length; { char buf[0x1000]; char *p = buf; int m; int n_written; struct message_header *msg; msg = (struct message_header *) buf; if (length == 0) length = strlen(text); m = length + hdrsize; msg->magic1=MAGIC1; msg->magic2=MAGIC2; msg->type = type; msg->flag = 0; STORE_3BYTES(msg->size,m); STORE_3BYTES(msg->msg_id,message_id); message_id++; p = buf + MESSAGE_HEADER_SIZE; bcopy(hdr,p,hdrsize); p+= hdrsize; if (sizeof(buf) >= (length + hdrsize + MESSAGE_HEADER_SIZE)) { bcopy(text,p,length); n_written = write1(sfd,buf,(length + hdrsize + MESSAGE_HEADER_SIZE)); } else { n_written = write1(sfd,buf, hdrsize + MESSAGE_HEADER_SIZE); n_written += write1(sfd, text, length); } if (n_written != (length + hdrsize + MESSAGE_HEADER_SIZE)) {perror("sock_write_str: Did not write full message"); return -1;} return n_written; } #define READ_BUF_STRING_AVAIL 1 #define READ_BUF_DATA_ON_PORT 2 #define DEFAULT_TIMEOUT_FOR_TK_READ (100 * HZ) struct message_header * guiParseMsg1(sfd,buf,bufleng) char *buf; int bufleng; struct connection_state *sfd; { int m; int body_length; int tot; struct message_header *msg; msg = (struct message_header *) buf; m= read1(sfd,(void *)msg,MESSAGE_HEADER_SIZE,DEFAULT_TIMEOUT_FOR_TK_READ); if (m == MESSAGE_HEADER_SIZE) { if ( msg->magic1!=MAGIC1 || msg->magic2!=MAGIC2) { fprintf(stderr,"bad magic..flushing buffers"); while(read1(sfd,buf,bufleng,0) > 0); return 0;} GET_3BYTES(msg->size,body_length); tot = body_length+MESSAGE_HEADER_SIZE; if (tot >= bufleng) {msg = (void *)malloc(tot+1); bcopy(buf,msg,MESSAGE_HEADER_SIZE);} m = read1(sfd,(void *)&(msg->body), body_length,DEFAULT_TIMEOUT_FOR_TK_READ); if (m == body_length) { return msg;}} if (m < 0) exit(1); { static int bad_read_allowed=4; if (bad_read_allowed-- < 0) exit(1); } dfprintf(stderr,"reading from lisp timed out or not enough read"); return 0; } void error(s) char *s; { fprintf(stderr,"%s",s); abort(); } void write_timeout_error(s) char *s; { fprintf(stderr,"write timeout: %s",s); abort(); } void connection_failure(s) char *s; { fprintf(stderr,"connection_failure:%s",s); abort(); } object make_fixnum1(long i) { static union lispunion lu; lu.FIX.FIXVAL=i; return &lu; } gcl-2.6.14/gcl-tk/comm.c0000755000175000017500000001610014360276512013254 0ustar cammcamm #include #ifndef NO_DEFUN #ifndef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname #endif #endif #ifndef HZ #define HZ 60 #endif #ifndef SET_TIMEVAL #define SET_TIMEVAL(t,timeout) \ t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) #endif DEFUN_NEW("CHECK-FD-FOR-INPUT",object,fScheck_fd_for_input, SI,2,2,NONE,OI,IO,OO,OO,(fixnum fd,fixnum timeout), "Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ for data to become available. Here there are \ INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ available on FD, 0 if timeout reached and -1 if failed.") { fd_set inp; int n; struct timeval t; SET_TIMEVAL(t,timeout); FD_ZERO(&inp); FD_SET(fd, &inp); n = select(fd + 1, &inp, NULL, NULL, &t); if (n < 0) return make_fixnum1(-1); else if (FD_ISSET(fd, &inp)) return make_fixnum1(1); else return make_fixnum1(0); } #ifdef STATIC_FUNCTION_POINTERS object fScheck_fd_for_input(fixnum fd,fixnum timeout) { return FFN(fScheck_fd_for_input)(fd,timeout); } #endif #define MAX_PACKET 1000 #define MUST_CONFIRM 2000 #define OUR_SOCK_MAGIC 0206 /* Each write and read will be of a packet including information about how many we have read and written. Sometimes we must read more messages, in order to check whether the one being sent has info about bytes_received. */ struct connection_state * setup_connection_state(int fd) { struct connection_state * res; res = (void *)malloc(sizeof(struct connection_state)); bzero(res,sizeof(struct connection_state)); res->fd = fd; res->read_buffer_size = READ_BUFF_SIZE; res->read_buffer = (void *)malloc(READ_BUFF_SIZE); res->valid_data = res->read_buffer; res->max_allowed_in_pipe = MAX_ALLOWED_IN_PIPE; res->write_timeout = 30* 100; return res; } /* P is supposed to start with a hdr and run N bytes. */ static void scan_headers(sfd) struct connection_state *sfd; { struct our_header *hdr; char *p = sfd->valid_data + sfd->next_packet_offset; int n = sfd->valid_data_size - sfd->next_packet_offset; int length,received; while (n >= HDR_SIZE) { hdr = (void *)p; if (hdr->magic != OUR_SOCK_MAGIC) abort(); GET_2BYTES(&hdr->received, received); STORE_2BYTES(&hdr->received, 0); sfd->bytes_sent_not_received -= received; GET_2BYTES(&hdr->length, length); p += length; n -= length; } } static int write1(struct connection_state *,const char *,int); static void send_confirmation(struct connection_state *sfd) { write1(sfd,0,0); } /* read from SFD to buffer P M bytes. Allow TIMEOUT delay while waiting for data to arrive. return number of bytes actually read. The data arrives on the pipe packetized, but is unpacketized by this function. It gets info about bytes that have been received by the other process, and updates info in the state. */ static int read1(sfd,p,m,timeout) struct connection_state* sfd; char *p; int timeout; int m; { int nread=0; int wanted = m; int length; struct our_header *hdr; if (wanted == 0) goto READ_SOME; TRY_PACKET: if (sfd->next_packet_offset > 0) { int mm = (sfd->next_packet_offset >= wanted ? wanted : sfd->next_packet_offset); { bcopy(sfd->valid_data,p,mm); p += mm; sfd->valid_data+= mm; sfd->valid_data_size -= mm; sfd->next_packet_offset -= mm; } wanted -= mm; if (0 == wanted) return m; } /* at beginning of a packet */ if (sfd->valid_data_size >= HDR_SIZE) { hdr = (void *) sfd->valid_data; GET_2BYTES(&hdr->length,length); } else goto READ_SOME; if (length > sfd->valid_data_size) goto READ_SOME; /* we have a full packet available */ {int mm = (wanted <= length - HDR_SIZE ? wanted : length - HDR_SIZE); /* mm = amount to copy */ { bcopy(sfd->valid_data+HDR_SIZE,p,mm); p += mm; sfd->valid_data+= (mm +HDR_SIZE); sfd->valid_data_size -= (mm +HDR_SIZE); sfd->next_packet_offset = length - (mm + HDR_SIZE); wanted -= mm; } if (0 == wanted) return m; goto TRY_PACKET; } READ_SOME: if (sfd->read_buffer_size - sfd->valid_data_size < MAX_PACKET) { char *tmp ; tmp = (void *) malloc(2* sfd->read_buffer_size); if (tmp == 0) error("out of free space"); bcopy(sfd->valid_data,tmp,sfd->valid_data_size); free(sfd->read_buffer); sfd->valid_data = sfd->read_buffer = tmp; sfd->read_buffer_size *= 2; } if(sfd->read_buffer_size - (sfd->valid_data - sfd->read_buffer) < MAX_PACKET) { bcopy(sfd->valid_data,sfd->read_buffer,sfd->valid_data_size); sfd->valid_data=sfd->read_buffer;} /* there is at least a packet size of space available */ if ((fix(FFN(fScheck_fd_for_input)(sfd->fd,sfd->write_timeout))>0)) again: {char *start = sfd->valid_data+sfd->valid_data_size; nread = SAFE_READ(sfd->fd,start, sfd->read_buffer_size - (start - sfd->read_buffer)); } if (nread<0) {if (errno == EAGAIN) goto again; return -1;} if (nread == 0) { return 0; } sfd->total_bytes_received += nread; sfd->bytes_received_not_confirmed += nread; sfd->valid_data_size += nread; if(sfd->bytes_received_not_confirmed > MUST_CONFIRM) send_confirmation(sfd); scan_headers(sfd); goto TRY_PACKET; } /* send BYTES chars from buffer P to CONNECTION. They are packaged up with a hdr */ static void write_timeout_error(char *); static void connection_failure(char *); int write1(sfd,p,bytes) struct connection_state *sfd; const char *p; int bytes; { int bs; int to_send = bytes; BEGIN: bs = sfd->bytes_sent_not_received; if (bs > sfd->max_allowed_in_pipe) {read1(sfd,0,0,sfd->write_timeout); if (bs > sfd->bytes_sent_not_received) goto BEGIN; write_timeout_error(""); } {struct our_header *hdr; char buf[MAX_PACKET]; int n_to_send = (bytes > MAX_PACKET -HDR_SIZE ? MAX_PACKET : bytes+HDR_SIZE); hdr = (void *) buf; STORE_2BYTES(&hdr->length, n_to_send); hdr->magic = OUR_SOCK_MAGIC; STORE_2BYTES(&hdr->received, sfd->bytes_received_not_confirmed); sfd->bytes_received_not_confirmed =0; sfd->bytes_sent_not_received += n_to_send; bcopy(p, buf+HDR_SIZE,n_to_send - HDR_SIZE); AGAIN: { int n = write(sfd->fd,buf,n_to_send); if (n == n_to_send); else if (n < 0) { if (errno == EAGAIN) { goto AGAIN; } else connection_failure(""); } else abort(); } p += (n_to_send -HDR_SIZE); bytes -= (n_to_send -HDR_SIZE); if (bytes==0) return to_send; goto BEGIN; } } DEFUN_NEW("CLEAR-CONNECTION",object,fSclear_connection,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd), "Read on FD until nothing left to read. Return number of bytes read") {char buffer[0x1000]; int n=0; while (fix(FFN(fScheck_fd_for_input)(fd,0))) { n+=read(fd,buffer,sizeof(buffer)); } return make_fixnum1(n); } #ifdef STATIC_FUNCTION_POINTERS object fSclear_connection(fixnum fd) { return FFN(fSclear_connection)(fd); } #endif gcl-2.6.14/ChangeLog.old0000755000175000017500000001611414360276512013330 0ustar cammcamm2001-12-29 Camm Maguire * gmp/configure.in update for darwin * #ifdef'ed R_386_NUM in sfaslelf.c for old libc * changes to configure.in and elisp/makefile to handle emacs not being present * fix to gmp/ltconfig to avoid exec'ing '""' * Added DESTDIR to makefiles to support installing under arbitrary subdir * good 'clean' targets * correct building in absence of tcl/tk 2001-12-18 David Billinghurst * h/gnuwin95.h: Cruft removal and update (SA_RESTART): Surround by #if 0/#endif (fopen_binary): Remove (fopen): Remove redefinition to fopen_binary 2001-04-15 Bill Schelter * Added changes to allow the loading .o files compiled on -O4 under linux, and also added this to be the default optimize level if speed = 3. speed = 2 gives -O still 2001-04-13 Bill Schelter * fix the NULL_OR_ON_C_STACK macro for x86 linux in notcomp.h and in 386-linux.h 2001-01-30 Bill Schelter * many changes added for MS windows version.. * add check on CSTACK_ADDRESS to configure for NULL_OR_ON_C_STACK 2000-10-27 Bill Schelter * o/file.d bug in close_stream * add xbin/386-linux-fix to knock the -O4 flag off of gcc if it is version 2.96 because of a C compiler bug * fixes to configure.in to better find the tcl tk stuff. 2000-06-01 Bill Schelter * o/print.d: change printing of pathnames to use the more standard #p"foo.bar" instead of #"foo.bar" * o/read.d: allow pathnames #p"foo.bar" instead of just #"foo.bar" as many implementations do. 2000-05-13 Bill Schelter * fix readme file * update gcl-2.3/mp/mpi-sol-sparc.s for the 'sparc' version. * number of changes to 'configure.in' to handle finding paths correctly. 2000-05-02 Bill Schelter * rsym_elf.c (out;): strip off the @@GLIB* from symbols, in the base image, since this is not added to .o files With advent of GLIB2.0 this addition to the symbol was made. This will allow dynamic linking of the raw_gcl with the C library. * remove the -static default from the 386-linux.defs file, so that links will by default be dynamic for libc .. Fri Mar 28 16:23:18 1997 Bill Schelter * fix o/unexelf.c for section following bss overlapping it. * fix some of the install sections in makefile * add man page. Wed Mar 12 14:11:01 1997 Bill Schelter * makefile (go): change to remove typo o${..} in makefile in the install script * change DIR= to GCL_TK_DIR= in gcl-tk/gcltksrv* and in makefile, gcl-tk/makefile. Plain DIR= was causing the replacement (in sed in makefiles) of other other variables ending in DIR= .. Sun Dec 8 18:31:38 1996 Bill Schelter * release 2.2.1 contains various fixes to unexec and to makefiles, for building on current systems. Mon Dec 2 20:36:28 1996 Bill Schelter * o/gbc.c: make the marking of MVloc go in the right direction. important for problems that use mv_ref methods.. Thu Nov 9 18:09:01 1995 Bill Schelter * fixes for format and structure printing. * fixes to calls to FEerror * arrange so that static arrays stay static on growing via adjust-array or via output with string stream stuff Mon Oct 30 20:42:17 1995 Bill Schelter * o/print.d (BEGIN): fix (defstruct (foo (:print-function print-foo)) junk) (defun print-foo (foo stream depth) (format stream "#" (foo-junk foo))) bug. [with the printStructBufp value being nulled] * add-defs sets TCL_LIBRARY, and gcltksrv sets it.. * fixes to support solaris-i386 [in rsym_elf.c, sfaslelf.c * ./add-defs fix order of tests of paths... Fri Oct 20 01:15:47 1995 Bill Schelter * fix initialization of *link-array* to be a string.. [remove from cmptop.lsp] * misc fixes in gbc.c and sgbc.c * fix to profiling. Wed Oct 18 00:16:59 1995 Bill Schelter * (format nil "~5,,X" 10) made to work. Note the ansi draft neither condones nor prohibits this. Normally the , is a place holder and there is a argument after the last , and then comes the directive. Here the commas dont hold a place. * fix bv.bv_offset problem... the move to 64 bit machines caused it to be impossible to have some structure fields overlap the way they once did. added BV_OFFSET(x) and SET_BV_OFFSET(x,val) macros. * fix add-defs to make clxsocket.o not be compiled in case of no X11 include files found. Tue Oct 17 13:21:38 1995 Bill Schelter * fix the (write 3) bug... in print.d Wed Oct 11 23:00:34 1995 Bill Schelter * merge in billm's elf support for linux, and repair the changes effects on regular a.out linux * switch to unexec from 19.29 for versions using either the regular or elf unexec from emacs Sun Oct 1 19:52:45 1995 Bill Schelter * Many changes to gcl 2.1 to support 64 bit machines (eg Dec alpha). Layout of structures etc changed. * a gcl-2.2 beta was released in the summer. since then there have been several bugs fixed. One in cmpfun.lsp affecting write, and another in init_gcl.lsp to make sure the link array is a string array (changed from fixnum which are no longer sufficient to hold pointers). * changes to fix for PA risc hpux in the hp800.h * changes to unexec-19.27.c to allow MUCH faster saving in NFS environment. * testing with maxima 5.1 * reworking makefiles * (write 2) bug fixed. (in compiler) * (aref #*11111 0) fixed (was different bv_elttype field) Sun Apr 30 18:28:07 1995 Bill Schelter * various fixes to array.c for bitarrays and non 1 dimensional arrays * fix to Ieval * verify that pcl and clx work with these changes. Sun Apr 9 21:24:38 1995 Bill Schelter * (ln): Sat Apr 1 14:01:35 1995 Bill Schelter * There have been an infinite number of changes for gcl-2.0 * GCL now contains a tcl/tk windowing interface. It is based on TCL 7.3 and TK 3.6 available from ftp.cs.berkeley.edu and many mirrors. See the gcl-tk/demos/widget.lisp file for the demos. * support for gzipped files (setq si::*allow-gzipped-file* t) to allow it. (load "foo.o") will look for "foo.o.gz" if it does not find foo.o. Writing gzipped files is not supported. * Command line args: See the documentaion in the info directory under command line. `-eval' `-load' etc. `-f' allows shell scripts to be made such as ================== #!/usr/local/bin/gcl.exe -f (print "hello world") ================== * All documentation converted to texinfo, info format and extended. Ansi common lisp documentation converted to texinfo * interrupts completely changed, to be more robust and to allow communication with tk. * regexp matching introduced see 'string-match' gcl-2.6.14/README.openbsd0000644000175000017500000000227114360276512013306 0ustar cammcammBuilding and using GCL 2.6.2 on OpenBSD PLATFORMS --------- GCL has only been tested on OpenBSD/i386 3.4. Newer versions should work as well. Other hardware platforms are unchartered land. TOOLS ----- You need GNU make to compile GCL. If you have installed the ports tree, you can get it by running the following as root: cd /usr/ports/devel/gmake make install It is then installed as `gmake'. The sed that ships with OpenBSD 3.4 has a bug (PR 3677) which is triggered by the GCL makefiles. You can use either the sed of 3.5 or GNU sed. Make sure the correct sed comes first in your PATH. BUILDING -------- There's nothing special to do for OpenBSD; GCL should build out of the box. The OpenBSD version shares makefiles with FreeBSD, so don't be surprised when you see "FreeBSD" in the output. NOTES ----- The default limits on data segment size are 64MB (soft) and 256MB (hard). GCL will automatically raise the soft limit to the hard limit, but you may find that it runs out of memory anyway. If so, you can change the limits in /etc/login.conf. For the record, the W^X feature of OpenBSD is disabled, since it interfers with the way GCL dumps its executable. Magnus Henoch, 12 June 2004 gcl-2.6.14/gmp.patch0000644000175000017500000000124514360276512012601 0ustar cammcammdiff -ruN ../libgmp3-4.0.1/mpn/generic/mul_n.c gmp/mpn/generic/mul_n.c --- ../libgmp3-4.0.1/mpn/generic/mul_n.c Thu Jun 28 19:04:08 2001 +++ gmp/mpn/generic/mul_n.c Sun Jul 28 14:01:36 2002 @@ -1144,9 +1144,15 @@ * multiplication will take much longer than malloc()/free(). */ mp_limb_t wsLen, *ws; wsLen = MPN_TOOM3_MUL_N_TSIZE (n); +#ifdef BAD_ALLOCA ws = __GMP_ALLOCATE_FUNC_LIMBS ((size_t) wsLen); +#else + ws = TMP_ALLOC ((size_t) wsLen * sizeof(mp_limb_t)); +#endif mpn_toom3_mul_n (p, a, b, n, ws); +#ifdef BAD_ALLOCA __GMP_FREE_FUNC_LIMBS (ws, (size_t) wsLen); +#endif } #if WANT_FFT || TUNE_PROGRAM_BUILD else gcl-2.6.14/cmpnew/0000755000175000017500000000000014360276512012264 5ustar cammcammgcl-2.6.14/cmpnew/gcl_cmploc.lsp0000755000175000017500000002434514360276512015121 0ustar cammcamm;;; CMPLOC Set-loc and Wt-loc. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar *value-to-go*) ;;; Valid locations are: ;;; NIL ;;; T ;;; 'FUN-VAL' ;;; ( 'VS' vs-address ) ;;; ( 'VS*' vs-address ) ;;; ( 'CCB-VS' ccb-vs ) ;;; ( 'VAR' var-object ccb ) ;;; ( 'VV' vv-index ) ;;; ( 'CVAR' cvar ) ;;; ( 'INLINE' side-effect-p fun/string locs ) ;;; ( 'INLINE-COND' side-effect-p fun/string locs ) ;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs ) ;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs ) ;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs ) ;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs ) ;;; ( 'SIMPLE-CALL { SYMLISPCALL-NO-EVENT ;;; | LISPCALL-NO-EVENT ;;; | SYMLISPCALL ;;; | LISPCALL } ;;; vs-index number-of-arguments [ vv-index ] ) ;;; ( 'VS-BASE' offset ) ;;; ( 'CAR' cvar ) ;;; ( 'CADR' cvar ) ;;; ( 'SYMBOL-FUNCTION' vv-index ) ;;; ( 'MAKE-CCLOSURE' cfun cllink ) ;;; ( 'FIXNUM-VALUE' vv-index fixnum-value ) ;;; ( 'FIXNUM-LOC' loc ) ;;; ( 'CHARACTER-VALUE' vv-index character-code ) ;;; ( 'CHARACTER-LOC' loc ) ;;; ( 'LONG-FLOAT-VALUE' vv-index long-float-value ) ;;; ( 'LONG-FLOAT-LOC' loc ) ;;; ( 'SHORT-FLOAT-VALUE' vv-index short-float-value ) ;;; ( 'SHORT-FLOAT-LOC' loc ) ;;; Valid *value-to-go* locations are: ;;; ;;; 'RETURN' The value is returned from the current function. ;;; 'RETURN-FIXNUM' ;;; 'RETURN-CHARACTER' ;;; 'RETURN-LONG-FLOAT' ;;; 'RETURN-SHORT-FLOAT' ;;; 'RETURN-OBJECT ;;; 'TRASH' The value may be thrown away. ;;; 'TOP' The value should be set at the top of vs as if it were ;;; a resulted value of a function call. ;;; ( 'VS' vs-address ) ;;; ( 'VS*' vs-address ) ;;; ( 'CCB-VS' ccb-vs ) ;;; ( 'VAR' var-object ccb ) ;;; ( 'JUMP-TRUE' label ) ;;; ( 'JUMP-FALSE' label ) ;;; ( 'BDS-BIND' vv-index ) ;;; ( 'PUSH-CATCH-FRAME' ) ;;; ( 'DBIND' symbol-name-vv ) (si:putprop 'cvar 'wt-cvar 'wt-loc) (si:putprop 'vv 'wt-vv 'wt-loc) (si:putprop 'car 'wt-car 'wt-loc) (si:putprop 'cdr 'wt-cdr 'wt-loc) (si:putprop 'cadr 'wt-cadr 'wt-loc) (si:putprop 'vs-base 'wt-vs-base 'wt-loc) (si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc) (si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc) (si:putprop 'integer-loc 'wt-integer-loc 'wt-loc) (si:putprop 'character-value 'wt-character-value 'wt-loc) (si:putprop 'character-loc 'wt-character-loc 'wt-loc) (si:putprop 'long-float-value 'wt-long-float-value 'wt-loc) (si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc) (si:putprop 'short-float-value 'wt-short-float-value 'wt-loc) (si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc) (si::putprop 'next-var-arg 'wt-next-var-arg 'wt-loc) (si::putprop 'first-var-arg 'wt-first-var-arg 'wt-loc) (defun wt-first-var-arg () (wt "first")) (defun wt-next-var-arg () (wt "va_arg(ap,object)")) (defun set-loc (loc &aux fd) (cond ((eq *value-to-go* 'return) (set-return loc)) ((eq *value-to-go* 'trash) (cond ((and (consp loc) (member (car loc) '(INLINE INLINE-COND INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)) (cadr loc)) (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc)) (wt ");")) ((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) (wt-nl "(void)" loc ";")))) ((eq *value-to-go* 'top) (unless (eq loc 'fun-val) (set-top loc))) ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc)) ((eq *value-to-go* 'return-character) (set-return-character loc)) ((eq *value-to-go* 'return-long-float) (set-return-long-float loc)) ((eq *value-to-go* 'return-short-float) (set-return-short-float loc)) ((or (not (consp *value-to-go*)) (not (symbolp (car *value-to-go*)))) (baboon)) ((setq fd (get (car *value-to-go*) 'set-loc)) (apply fd loc (cdr *value-to-go*))) ((setq fd (get (car *value-to-go*) 'wt-loc)) (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";")) (t (baboon))) ) (defun wt-loc (loc) (cond ((eq loc nil) (wt "Cnil")) ((eq loc t) (wt "Ct")) ((eq loc 'fun-val) (wt "vs_base[0]")) ((or (not (consp loc)) (not (symbolp (car loc)))) (baboon)) (t (let ((fd (get (car loc) 'wt-loc))) (when (null fd) (baboon)) (apply fd (cdr loc))))) ) (defun set-return (loc) (cond ((eq loc 'fun-val)) ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*)) (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;") (base-used)) ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LEXICAL) (not (var-ref-ccb (cadr loc))) (eql (car (var-ref (cadr loc))) *level*)) (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;") (base-used)) (t (set-top loc))) ) (defun set-top (loc) (let ((*vs* *vs*)) (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";") (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;") (base-used))) (defun wt-vs-base (offset) (wt "vs_base[" offset "]")) (defun wt-car (cvar) (wt "(V" cvar "->c.c_car)")) (defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)")) (defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)")) (defun wt-cvar (cvar &optional type) (if type (wt "/* " (symbol-name type) " */")) (wt "V" cvar)) (defun vv-str (vv) (let ((vv (add-object2 vv))) (si::string-concatenate "((object)VV[" (write-to-string vv) "])"))) (defun wt-vv (vv) (wt (vv-str vv))) (defun wt-fixnum-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'FIXNUM)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM)) (wt "(long)")(wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'fixnum-value)) (wt "(long)")(wt (caddr loc))) ((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT INLINE-LONG-FLOAT))) (wt "((long)(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt "))")) (t (wt "fix(" loc ")")))) (defun wt-integer-loc (loc &optional type &aux (avma t)(first (and (consp loc) (car loc)))) (declare (ignore type)) (case first (inline-fixnum (wt "stoi(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt ")")) (INLINE-INTEGER (setq avma nil) (wt-inline-loc (caddr loc) (cadddr loc))) (fixnum-value (wt "stoi(" (caddr loc) ")")) (var (case (var-kind (cadr loc)) (integer (setq avma nil) (wt "V" (var-loc (cadr loc)))) (fixnum (wt "stoi(V" (var-loc (cadr loc))")")) (otherwise (wt "otoi(" loc ")")))) (otherwise (wt "otoi(" loc ")"))) (and avma (not *restore-avma*)(wfs-error)) ) (defun fixnum-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'FIXNUM)) (eq (car loc) 'INLINE-FIXNUM) (eq (car loc) 'fixnum-value)))) (defun wt-fixnum-value (vv fixnum-value) (if vv (wt (vv-str vv)) (wt "small_fixnum(" fixnum-value ")"))) (defun wt-character-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'CHARACTER)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE)) (wt (caddr loc))) (t (wt "char_code(" loc ")")))) (defun character-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'CHARACTER)) (eq (car loc) 'INLINE-CHARACTER) (eq (car loc) 'character-value)))) (defun wt-character-value (vv character-code) (declare (ignore character-code)) (wt (vv-str vv))) (defun wt-long-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LONG-FLOAT)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'long-float-value)) (wt (caddr loc))) (t (wt "lf(" loc ")")))) (defun long-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'LONG-FLOAT)) (eq (car loc) 'INLINE-LONG-FLOAT) (eq (car loc) 'long-float-value)))) (defun wt-long-float-value (vv long-float-value) (declare (ignore long-float-value)) (wt (vv-str vv))) (defun wt-short-float-loc (loc) (cond ((and (consp loc) (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) (wt "V" (var-loc (cadr loc)))) ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT)) (wt-inline-loc (caddr loc) (cadddr loc))) ((and (consp loc) (eq (car loc) 'short-float-value)) (wt (caddr loc))) (t (wt "sf(" loc ")")))) (defun short-float-loc-p (loc) (and (consp loc) (or (and (eq (car loc) 'var) (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) (eq (car loc) 'INLINE-SHORT-FLOAT) (eq (car loc) 'short-float-value)))) (defun wt-short-float-value (vv short-float-value) (declare (ignore short-float-value)) (wt (vv-str vv))) gcl-2.6.14/cmpnew/gcl_cmptag.lsp0000755000175000017500000003503614360276512015116 0ustar cammcamm;;; CMPTAG Tagbody and Go. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (import 'si::switch) (import 'si::switch-finish) (si:putprop 'tagbody 'c1tagbody 'c1special) (si:putprop 'tagbody 'c2tagbody 'c2) (si:putprop 'go 'c1go 'c1special) (si:putprop 'go 'c2go 'c2) (defstruct tag name ;;; Tag name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; tagbody id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. label ;;; Where to jump. A label. unwind-exit ;;; Where to unwind-no-exit. var ;;; The tag-name holder. A VV index. switch ;;; tag for switch. A fixnum or 'default ) (defvar *tags* nil) ;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed ;;; on *tags* when *level* is incremented. (defun jumps-to-p (clause tag-name &aux tem) ;;Does CLAUSE have a go TAG-NAME in it? (cond ((atom clause)nil) ((and (eq (car clause) 'go) (tag-p (setq tem (cadddr (cdr clause)))) (eq (tag-name tem) tag-name))) ((eq (car clause) 'location) nil) (t (or (jumps-to-p (car clause) tag-name) (jumps-to-p (cdr clause) tag-name))))) (defvar *reg-amount* 60) ;;amount to increase var-register for each variable reference in side a loop (defun add-reg1 (form) ;;increase the var-register in FORM for all vars (cond ((atom form) (cond ((typep form 'var) (setf (var-register form) (the fixnum (+ (the fixnum (var-register form)) (the fixnum *reg-amount*)))) ))) (t (add-reg1 (car form)) (add-reg1 (cdr form))))) (defun add-loop-registers (tagbody) ;;Find a maximal iteration interval in TAGBODY from first to end ;;then increment the var-register slot. (do ((v tagbody (cdr v)) (end nil) (first nil)) ((null v) (do ((ww first (cdr ww))) ((eq ww end)(add-reg1 (car ww))) (add-reg1 (car ww)))) (cond ((typep (car v) 'tag) (or first (setq first v)) (do ((w (cdr v) (cdr w)) (name (tag-name (car v)))) ((null w) ) (cond ((jumps-to-p (car w) name) (setq end w)))))))) (defun c1tagbody (body &aux (*tags* *tags*) (info (make-info))) ;;; Establish tags. (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (push tag *tags*) tag)) (t x))) body)) ;;; Process non-tag forms. (setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info))) body)) ;;; Delete redundant tags. (do ((l body (cdr l)) (body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil)) ((endp l) (if (or ref-ccb ref-clb ref) (progn (setq body1 (nreverse body1)) ;; If ref-ccb is set, we will cons up the environment, hence ;; all tags which had level boundary references must be changed ;; to ccb references. FIXME -- review this logic carefully ;; CM 20040228 (when ref-ccb (dolist (l body1) (when (and (typep l 'tag) (tag-ref-clb l)) (setf (tag-ref-ccb l) t)))) (cond ((or ref-clb ref-ccb) (incf *setjmps*)) (t (add-loop-registers body1 ))) (list 'tagbody info ref-clb ref-ccb body1)) (list 'progn info (nreverse (cons (c1nil) body1))))) (declare (object l ref ref-clb ref-ccb)) (if (typep (car l) 'tag) (cond ((tag-ref-ccb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-ccb t)) ((tag-ref-clb (car l)) (push (car l) body1) (setf (tag-var (car l)) (add-object (tag-name (car l)))) (setq ref-clb t)) ((tag-ref (car l)) (push (car l) body1) (setq ref t))) (push (car l) body1)))) (defun c2tagbody (ref-clb ref-ccb body) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body)))) (defun c2tagbody-local (body &aux (label (next-label))) ;;; Allocate labels. (dolist** (x body) (when (typep x 'tag) (setf (tag-label x) (next-label*)) (setf (tag-unwind-exit x) label))) (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)) ) (defun c2tagbody-body (body) (do ((l body (cdr l)) (written nil)) ((endp (cdr l)) (cond (written (unwind-exit nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l))) (unwind-exit nil)) (t (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (wt-label *exit*)) (unless (member (caar l) '(go return-from)) (unwind-exit nil))))) (declare (object l written)) (cond (written (setq written nil)) ((typep (car l) 'tag) (wt-switch-case (tag-switch (car l))) (wt-label (tag-label (car l)))) (t (let* ((*exit* (if (typep (cadr l) 'tag) (progn (setq written t) (tag-label (cadr l))) (next-label))) (*unwind-exit* (cons *exit* *unwind-exit*)) (*value-to-go* 'trash)) (c2expr (car l)) (and (typep (cadr l) 'tag) (wt-switch-case (tag-switch (cadr l)))) (wt-label *exit*)))))) (defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push))) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (tag-ref-clb tag) (setf (tag-ref-clb tag) ref-clb) (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") (wt-nl " ") (reset-top) (wt-nl " ") (wt-go (tag-label tag)) (wt-nl "}")))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c2tagbody-ccb (body &aux (label (next-label)) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (let ((*unwind-exit* (cons 'frame *unwind-exit*)) (ref-clb (vs-push)) ref-ccb) (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") (wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",") (wt-clink) (wt ");") (clink ref-clb) (setq ref-ccb (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");") (wt-nl "if(nlj_active){") (wt-nl "nlj_active=FALSE;") ;;; Allocate labels. (dolist** (tag body) (when (typep tag 'tag) (setf (tag-label tag) (next-label*)) (setf (tag-unwind-exit tag) label) (when (or (tag-ref-clb tag) (tag-ref-ccb tag)) (setf (tag-ref-clb tag) ref-clb) (when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb)) (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") (wt-nl " ") (reset-top) (wt-nl " ") (wt-go (tag-label tag)) (wt-nl "}")))) (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") (wt-nl "}") (let ((*unwind-exit* (cons label *unwind-exit*))) (c2tagbody-body body)))) (defun c1go (args) (cond ((endp args) (too-few-args 'go 1 0)) ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) ((not (or (symbolp (car args)) (integerp (car args)))) "The tag name ~s is not a symbol nor an integer." (car args))) (do ((tags *tags* (cdr tags)) (name (car args)) (ccb nil) (clb nil)) ((endp tags) (cmperr "The tag ~s is undefined." name)) (declare (object name ccb clb)) (case (car tags) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (tag-name (car tags)) name) (let ((tag (car tags))) (cond (ccb (setf (tag-ref-ccb tag) t)) (clb (setf (tag-ref-clb tag) t)) (t (setf (tag-ref tag) t))) (return (list 'go *info* clb ccb tag)))))))) (defun c2go (clb ccb tag) (cond (ccb (c2go-ccb tag)) (clb (c2go-clb tag)) (t (c2go-local tag)))) (defun c2go-local (tag) (unwind-no-exit (tag-unwind-exit tag)) (wt-nl) (wt-go (tag-label tag))) (defun c2go-clb (tag) (wt-nl "vs_base=vs_top;") (wt-nl "unwind(frs_sch(") (if (tag-ref-ccb tag) (wt-vs* (tag-ref-clb tag)) (wt-vs (tag-ref-clb tag))) (wt ")," (vv-str (tag-var tag)) ");")) (defun c2go-ccb (tag) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");") (wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1," (vv-str (tag-var tag)) ");") (wt-nl "vs_base=vs_top;") (wt-nl "unwind(fr," (vv-str (tag-var tag)) ");}")) (defun wt-switch-case (x) (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) (defun c1switch(form &aux (*tags* *tags*)) (let* ((switch-op (car form)) (body (cdr form)) (switch-op-1 (c1expr switch-op))) (cond ((and (typep (second switch-op-1 ) 'info) (subtypep (info-type (second switch-op-1)) 'fixnum)) ;;optimize into a C switch: ;;If we ever get GCC to do switch's with an enum arg, ;;which don't do bounds checking, then we will ;;need to carry over the restricted range. ;;more generally the compiler should carry along the original type ;;decl, not just the coerced one. This needs another slot in ;;info. (or (member t body) (setq body (append body (list t)))) ;; Remove duplicate tags in C switch statement -- CM 20031112 (setq body (let (tags new-body) (dolist (b body) (cond ((or (symbolp b) (integerp b)) (unless (member b tags) (push b tags) (push b new-body))) (t (push b new-body)))) (nreverse new-body))) (setq body (mapcar #'(lambda (x) (cond ((or (symbolp x) (integerp x)) (let ((tag (make-tag :name x :ref nil :ref-ccb nil :ref-clb nil))) (cond((typep x 'fixnum) (setf (tag-ref tag) t) (setf (tag-switch tag) x)) ((eq t x) (setf (tag-ref tag) t) (setf (tag-switch tag) "default"))) tag)) (t x))) body)) (let ((tem (c1tagbody `(,@ body switch-finish-label)))) (nconc (list 'switch (cadr tem) switch-op-1) (cddr tem)) )) (t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) (defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) (let ((args (inline-args (list op ) '(fixnum )))) (wt-inline-loc "switch(#0){" args) (cond (ref-ccb (c2tagbody-ccb body)) (ref-clb (c2tagbody-clb body)) (t (c2tagbody-local body))) (wt "}") (unwind-exit nil) (close-inline-blocks))) ;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI) ;; TEST must evaluate to something of INTEGER TYPE. If test matches one ;; of the labels (ie integers) in the body of switch, control will jump ;; to that point. It is an error to have two or more constants which are ;; eql in the the same switch. If none of the constants match the value, ;; then control moves to a label T. If there is no label T, control ;; flows as if the last term in the switch were a T. It is an error ;; however if TEST were declared to be in a given integer range, and at ;; runtime a value outside that range were provided. The value of a ;; switch construct is undefined. If you wish to return a value use a ;; block construct outside the switch and a return-from. `GO' may also ;; be used to jump to labels in the SWITCH. ;; Control falls through from case to case, just as if the cases were ;; labels in a tagbody. To jump to the end of the switch, use ;; (switch-finish). ;; The reason for using a new construct rather than building on CASE, is ;; that CASE does not allow the user to use invoke a `GO' if necessary. ;; to switch from one case to another. Also CASE does not allow sharing ;; of parts of code between different cases. They have to be either the ;; same or disjoint. ;; The SWITCH may be implemented very efficiently using a jump table, if ;; the range of cases is not too much larger than the number of cases. ;; If the range is much larger than the number of cases, a binary ;; splitting of cases might be used. ;; Sample usage: ;; (defun goo (x) ;; (switch x ;; 1 (princ "x is one, ") ;; 2 (princ "x is one or two, ") ;; (switch-finish) ;; 3 (princ "x is three, ") ;; (switch-finish) ;; t (princ "none"))) ;; We provide a Common Lisp macro for implementing the above construct: (defmacro switch (test &body body &aux cases) (dolist (v body) (cond ((integerp v) (push `(if (eql ,v ,test) (go ,v) nil) cases)))) `(tagbody ,@ (nreverse cases) (go t) ,@ body ,@ (if (member t body) nil '(t)) switch-finish-label )) (defmacro switch-finish nil '(go switch-finish-label)) (si::putprop 'switch 'c1switch 'c1special) (si::putprop 'switch 'c2switch 'c2) gcl-2.6.14/cmpnew/gcl_collectfn.lsp0000755000175000017500000003043214360276512015607 0ustar cammcamm;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;; ;;; Copyright (c) 1989 by William Schelter,University of Texas ;;;;; ;;; All rights reserved ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; See the doc/DOC file for information on emit-fn and ;; make-all-proclaims. The basic idea is to utilize information gathered ;; by the compiler in a compile of a system of files in order to generate ;; better code on subsequent compiles of the system. To do this a file ;; sys-proclaim.lisp should be produced. ;; Additionally cross reference information about functions in the system is ;; collected. (in-package :compiler) (import 'sloop::sloop) (defstruct fn name ;; name of THIS FUNCTION def ;; defun, defmacro value-type ;; If this function's body contained ;; (cond ((> a 3) 7) ;; ((> a 1) (foo))) ;; then the return type of 7 is known at compile time ;; and value-type would be fixnum. [see return-type] fun-values ;; list of functions whose values are the values of THIS FN ;; (foo) in the previous example. callees ;; list of all functions called by THIS FUNCTION return-type ;; Store a return-type computed from the fun-values ;; and value-type field. This computation is done later. arg-types ;; non optional arg types. no-emit ;; if not nil don't emit declaration. macros ) (defvar *other-form* (make-fn)) (defvar *all-fns* nil) (defvar *call-table* (make-hash-table)) (defvar *current-fn* nil) (defun add-callee (fname) (cond ((consp fname) (or (eq (car fname) 'values) (add-callee (car fname)))) ((eq fname 'single-value)) (fname (pushnew fname (fn-callees (current-fn)))))) (defun add-macro-callee (fname) (or ;; make sure the macro fname is not shadowed in the current environment. (sloop::sloop for v in *funs* when (and (consp v) (eq (car v) fname)) do (return t)) (pushnew fname (fn-macros (current-fn))))) (defun clear-call-table () (setf *current-fn* nil) (setq *all-fns* nil) (setq *other-form* (make-fn :name 'other-form)) (clrhash *call-table*) (setf (gethash 'other-form *call-table*) *other-form*) ) (defun emit-fn (flag) (setq *record-call-info* flag)) (defun type-or (a b) (if (eq b '*) '* (case a ((nil) b) ((t inline) t) ((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum (type-or t b))) (otherwise '*) ))) (defun current-fn () (cond ((and (consp *current-form*) (member (car *current-form*) '(defun defmacro)) (symbolp (second *current-form*)) (symbol-package (second *current-form*));;don't record gensym'd ) (cond ((and *current-fn* (equal (second *current-form*) (fn-name *current-fn*))) *current-fn*) (t (unless (setq *current-fn* (gethash (second *current-form*) *call-table*)) (setq *current-fn* (make-fn :name (second *current-form*) :def (car *current-form*))) (setf (gethash (second *current-form*) *call-table*) *current-fn*) (setq *all-fns* (cons *current-fn* *all-fns*))) *current-fn*))) ;; catch all for other top level forms (t *other-form*))) (defun who-calls (f) (sloop for (ke val) in-table *call-table* when (or (member f (fn-callees val)) (member f (fn-macros val))) collect ke)) (defun add-value-type (x fn &aux (current-fn (current-fn))) (cond (fn (pushnew fn (fn-fun-values current-fn) :test 'equal)) (t (setf (fn-value-type current-fn) (type-or (fn-value-type current-fn) x))))) (defun get-var-types (lis) (sloop::sloop for v in lis collect (var-type v))) (defun record-arg-info( lambda-list &aux (cf (current-fn))) (setf (fn-arg-types cf) (get-var-types (car lambda-list))) (when (sloop::sloop for v in (cdr lambda-list) for w in '(&optional &rest &key nil &allow-other-keys ) when (and v w) do (return '*)) (setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*))) )) (defvar *depth* 0) (defvar *called-from* nil) (defun get-value-type (fname) (cond ((member fname *called-from* :test 'eq) nil) (t (let ((tem (cons fname *called-from*))) (declare (:dynamic-extent tem)) (let ((*called-from* tem)) (get-value-type1 fname)))))) (defun get-value-type1 (fname &aux tem (*depth* (the fixnum (+ 1 (the fixnum *depth* ))))) (cond ((> (the fixnum *depth*) 100) '*) ((setq tem (gethash fname *call-table*)) (or (fn-return-type tem) (sloop::sloop with typ = (fn-value-type tem) for v in (fn-fun-values tem) when (symbolp v) do (setq typ (type-or typ (get-value-type v))) else when (and (consp v) (eq (car v) 'values)) do (setq typ (type-or typ (if (eql (cdr v) 1) t '*))) else do (error "unknown fun value ~a" v) finally ;; if there is no visible return, then we can assume ;; one value. (or typ (fn-value-type tem) (fn-fun-values tem) (setf typ t)) (setf (fn-return-type tem) typ) (return typ) ))) ((get fname 'return-type)) ((get fname 'proclaimed-return-type)) (t '*))) (defun result-type-from-loc (x) (cond ((consp x) (case (car x) ((fixnum-value inline-fixnum) 'fixnum) (var (var-type (second x))) ;; eventually separate out other inlines (t (cond ((and (symbolp (car x)) (get (car x) 'wt-loc)) t) (t (print (list 'type '* x)) '*))))) ((or (eq x t) (null x)) t) (t (print (list 'type '*2 x)) '*))) (defun small-all-t-p (args ret) (and (eq ret t) (< (length args) 10) (sloop::sloop for v in args always (eq v t)))) ;; Don't change return type but pretend all these are optional args. (defun no-make-proclaims-hack () (sloop::sloop for (ke val) in-table *call-table* do (progn ke) (setf (fn-no-emit val) 1))) (defun set-closure () (setf (fn-def (current-fn)) 'closure)) (defun make-proclaims ( &optional (st *standard-output*) &aux (ht (make-hash-table :test 'equal)) *print-length* *print-level* (si::*print-package* t) ) ; (require "VLFUN" ; (concatenate 'string si::*system-directory* ; "../cmpnew/lfun_list.lsp")) (print `(in-package ,(package-name *package*)) st) (sloop::sloop with ret with at for (ke val) in-table *call-table* do (cond ((eq (fn-def val) 'closure) (push ke (gethash 'proclaimed-closure ht))) ((or (eql 1 (fn-no-emit val)) (not (eq (fn-def val) 'defun)))) (t (setq ret (get-value-type ke)) (setq at (fn-arg-types val)) (push ke (gethash (list at ret) ht))))) (sloop::sloop for (at fns) in-table ht do (print (if (symbolp at) `(mapc (lambda (x) (setf (get x 'compiler::proclaimed-closure) t)) '(,@fns)) `(proclaim '(ftype (function ,@ at) ,@ fns))) st))) (defun setup-sys-proclaims() (or (gethash 'si::call-test *call-table*) (get 'si::call-test 'proclaimed-function) (load (concatenate 'string si::*system-directory* "../lsp/sys-proclaim.lisp")) (no-make-proclaims-hack) )) (defun make-all-proclaims (&rest files) (setup-sys-proclaims) (dolist (v files) (mapcar 'load (directory v))) (write-sys-proclaims)) (defun write-sys-proclaims () (with-open-file (st "sys-proclaim.lisp" :direction :output) (make-proclaims st))) (defvar *file-table* (make-hash-table :test 'eq)) (defvar *warn-on-multiple-fn-definitions* t) (defun add-fn-data (lis &aux tem (file *load-truename*)) (dolist (v lis) (cond ((eql (fn-name v) 'other-form) (setf (fn-name v) (intern (concatenate 'string "OTHER-FORM-" (namestring file)))) (setf (get (fn-name v) 'other-form) t))) (setf (gethash (fn-name v) *call-table*) v) (when *warn-on-multiple-fn-definitions* (when (setq tem (gethash (fn-name v) *file-table*)) (unless (equal tem file) (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a." :format-arguments (list (fn-name v) file tem))))) (setf (gethash (fn-name v) *file-table*) file))) (defun dump-fn-data (&optional (file "fn-data.lsp") &aux (*package* (find-package "COMPILER")) (*print-length* nil) (*print-level* nil) ) (with-open-file (st file :direction :output) (format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data) (sloop::sloop for (ke val) in-table *call-table* do (progn ke) (print val st)) (princ "))" st) (truename st))) (defun record-call-info (loc fname) (cond ((and fname (symbolp fname)) (add-callee fname))) (cond ((eq loc 'record-call-info) (return-from record-call-info nil))) (case *value-to-go* (return (if (eq loc 'fun-val) (add-value-type nil (or fname 'unknown-values)) (add-value-type (result-type-from-loc loc) nil))) (return-fixnum (add-value-type 'fixnum nil)) (return-object (add-value-type t nil)) (top (setq *top-data* (cons fname nil)) )) ) (defun list-undefined-functions (&aux undefs) (sloop::sloop for (name fn) in-table *call-table* declare (ignore name) do (sloop for w in (fn-callees fn) when (not (or (fboundp w) (gethash w *call-table*) (get w 'inline-always) (get w 'inline-unsafe) (get w 'other-form) )) do (pushnew w undefs))) undefs) (dolist (v '(throw coerce single-value sort delete remove char-upcase si::fset typep)) (si::putprop v t 'return-type)) (defun init-fn () nil) (defun list-uncalled-functions ( ) (let* ((size (sloop::sloop for (ke v) in-table *call-table* count t do (progn ke v nil))) (called (make-hash-table :test 'eq :size (+ 3 size)))) (sloop::sloop for (ke fn) in-table *call-table* declare (ignore ke) do (sloop::sloop for w in (fn-callees fn) do (setf (gethash w called) t)) (sloop::sloop for w in (fn-macros fn) do (setf (gethash w called) t)) ) (sloop::sloop for (ke fn) in-table *call-table* when(and (not (gethash ke called)) (member (fn-def fn) '(defun defmacro) :test 'eq)) collect ke))) ;; redefine the stub in defstruct.lsp (defun si::record-fn (name def arg-types return-type) (if (null return-type) (setq return-type t)) (and *record-call-info* *compiler-in-use* (let ((fn (make-fn :name name :def def :return-type return-type :arg-types arg-types))) (push fn *all-fns*) (setf (gethash name *call-table*) fn)))) (defun get-packages (&optional (st "sys-package.lisp") pass &aux (si::*print-package* t)) (flet ((pr (x) (format st "~%~s" x))) (cond ((null pass) (with-open-file (st st :direction :output) (get-packages st 'establish) (get-packages st 'export) (get-packages st 'shadow) (format st "~2%") (return-from get-packages nil)))) (dolist (p (list-all-packages)) (unless (member (package-name p) '("SLOOP" "COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER") :test 'equal ) (format st "~2%;;; Definitions for package ~a of type ~a" (package-name p) pass) (ecase pass (establish (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p) :use nil ,@ (if (package-nicknames p) `(:nicknames ',(package-nicknames p))))))) (export (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p) :use '(,@ (mapcar 'package-name (package-use-list p))) ,@(if (package-nicknames p) `(:nicknames ',(package-nicknames p)))))) (let (ext (*package* p) imps) (do-external-symbols (sym p) (push sym ext) (or (eq (symbol-package sym) p) (push sym imps))) (pr `(import ',imps)) (pr `(export ',ext)))) (shadow (let ((SYSTEM::*PRINT-PACKAGE* t)) (pr `(in-package ,(package-name p)))) (let (in out (*package* (find-package "LISP"))) (dolist (v (package-shadowing-symbols p)) (cond ((eq (symbol-package v) p) (push v in)) (t (push v out)))) (pr `(shadow ',in)) (pr `(shadowing-import ',out)) (let (imp) (do-symbols (v p) (cond ((not (eq (symbol-package v) p)) (push v imp)))) (pr `(import ',imp)))))))))) gcl-2.6.14/cmpnew/gcl_cmplam.lsp0000755000175000017500000010321714360276512015111 0ustar cammcamm;;; CMPLAM Lambda expression. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) ;;; During Pass1, a lambda-list ;;; ;;; ( { var }* ;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] ;;; [ &rest var ] ;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* ;;; [&allow-other-keys]] ;;; [ &aux {var | (var [initform])}*] ;;; ) ;;; ;;; is transformed into ;;; ;;; ( ( { var }* ) ; required ;;; ( { (var initform svar) }* ) ; optional ;;; { var | nil } ; rest ;;; key-flag ;;; ( { ( kwd-vv-index var initform svar) }* ) ; key ;;; allow-other-keys-flag ;;; ) ;;; ;;; where ;;; svar: nil ; means svar is not supplied ;;; | var ;;; ;;; &aux parameters will be embedded into LET*. ;;; ;;; c1lambda-expr receives ;;; ( lambda-list { doc | decl }* . body ) ;;; and returns ;;; ( lambda info-object lambda-list' doc body' ) ;;; ;;; Doc is NIL if no doc string is supplied. ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are ;;; supplied) and an implicit block. (defmacro ck-spec (condition) `(unless ,condition (cmperr "The parameter specification ~s is illegal." spec))) (defmacro ck-vl (condition) `(unless ,condition (cmperr "The lambda list ~s is illegal." vl))) ;;;the following code implements downward closures. ;;;These are like closures, except they are guaranteed not ;;;to survive past the exit of the function in which they ;;;are born. (defmacro downward-function (x) `(function ,x)) (setf (get 'downward-function 'c1special) 'c1downward-function) (defun c1downward-function (x) (let* ((tem (c1expr (list 'function (car x)))) (info (cadr tem))) ;; for the moment we only allow downward closures with no args (cond ((and (consp x) (consp (car x)) (eq (caar x) 'lambda) (null (second (car x)))) (do-referred (var info) (cond ((and (eq (var-kind var) 'lexical) (var-ref-ccb var) t) (setf (var-kind var) 'down))) ) (setf (car tem) 'downward-function) tem) (t tem)))) (si::putprop 'downward-function 'c2downward-function 'c2) (si:putprop 'make-dclosure 'wt-make-dclosure 'wt-loc) (defun wt-make-dclosure (cfun clink)clink ;;Dbase=base0 (wt-nl "(DownClose"cfun".t=t_dclosure,DownClose" cfun ".dc_self=LC" cfun"," "DownClose" cfun ".dc_env=base0,(object)&DownClose" cfun ")")) (defun wfs-error () (error "This error is not supposed to occur: Contact Schelter ~ ~%wfs@math.utexas.edu")) (defun wt-downward-closure-macro (cfun) (cond (*downward-closures* (wt-h "#define DCnames" cfun " ") (setq *downward-closures* (delete 'dcnames *downward-closures*)) (cond (*downward-closures* (wt-h1 "struct dclosure ") (do ((v *downward-closures* (cdr v))) ((null v)) (wt-h1 "DownClose") (wt-h1 (car v)) (if (cdr v) (wt-h1 ","))) (wt-h1 ";")))))) (defun c2downward-function (funob) (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) (push (list 'dclosure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* fun funob) *local-funs*) (push fun *closures*) (push (fun-cfun fun) *downward-closures*) (unwind-exit (list 'make-dclosure (fun-cfun fun) *clink*)))) (defun c1lambda-expr (lambda-expr &optional (block-name nil block-it) &aux (requireds nil) (optionals nil) (rest nil) (keywords nil) (key-flag nil) lambda-list (allow-other-keys nil) (aux-vars nil) (aux-inits nil) doc vl spec body ss is ts other-decls vnames (*vars* *vars*) (info (make-info)) (aux-info nil) (setjmps *setjmps*) ) (cmpck (endp lambda-expr) "The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) (multiple-value-setq (body ss ts is other-decls doc) (c1body (cdr lambda-expr) t)) (when block-it (setq body (list (cons 'block (cons block-name body))))) (c1add-globals ss) (setq vl (car lambda-expr)) (block parse (tagbody Lreq (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&optional (go Lopt)) (&rest (go Lrest)) (&key (go Lkey)) (&aux (go Laux))) (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push v *vars*) (push v requireds)) (go Lreq) Lopt (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&rest (go Lrest)) (&key (go Lkey)) (&aux (go Laux))) (cond ((not (consp spec)) (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push (list v (default-init (var-type v)) nil) optionals) (push v *vars*))) ((not (consp (cdr spec))) (ck-spec (null (cdr spec))) (let ((v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (list v (default-init (var-type v)) nil) optionals) (push v *vars*))) ((not (consp (cddr spec))) (ck-spec (null (cddr spec))) (let ((init (c1expr* (cadr spec) info)) (v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (list v (and-form-type (var-type v) init (cadr spec)) nil) optionals) (push v *vars*))) (t (ck-spec (null (cdddr spec))) (let ((init (c1expr* (cadr spec) info)) (v (c1make-var (car spec) ss is ts)) (sv (c1make-var (caddr spec) ss is ts)) ) (push (car spec) vnames) (push (caddr spec) vnames) (push (list v (and-form-type (var-type v) init (cadr spec)) sv) optionals) (push v *vars*) (push sv *vars*)))) (go Lopt) Lrest (ck-vl (consp vl)) (push (car vl) vnames) (setq rest (c1make-var (pop vl) ss is ts)) (push rest *vars*) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&key (go Lkey)) (&aux (go Laux))) (cmperr "Either &key or &aux is missing before ~s." spec) Lkey (setq key-flag t) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&aux (go Laux)) (&allow-other-keys (setq allow-other-keys t) (when (null vl) (return-from parse)) (ck-vl (consp vl)) (case (setq spec (pop vl)) (&aux (go Laux))) (cmperr "&aux is missing before ~s." spec))) (when (not (consp spec)) (setq spec (list spec))) (cond ((consp (car spec)) (ck-spec (and (keywordp (caar spec)) (consp (cdar spec)) (null (cddar spec)))) (setq spec (cons (caar spec) (cons (cadar spec) (cdr spec))))) (t (ck-spec (symbolp (car spec))) (setq spec (cons (intern (string (car spec)) 'keyword) (cons (car spec) (cdr spec)))))) (cond ((not (consp (cddr spec))) (ck-spec (null (cddr spec))) (let ((v (c1make-var (cadr spec) ss is ts))) (push (cadr spec) vnames) (push (list (car spec) v (default-init (var-type v)) (make-var :kind 'DUMMY)) keywords) (push v *vars*))) ((not (consp (cdddr spec))) (ck-spec (null (cdddr spec))) (let ((init (c1expr* (caddr spec) info)) (v (c1make-var (cadr spec) ss is ts))) (push (cadr spec) vnames) (push (list (car spec) v (and-form-type (var-type v) init (caddr spec)) (make-var :kind 'DUMMY)) keywords) (push v *vars*))) (t (ck-spec (null (cddddr spec))) (let ((init (c1expr* (caddr spec) info)) (v (c1make-var (cadr spec) ss is ts)) (sv (c1make-var (cadddr spec) ss is ts))) (push (cadr spec) vnames) (push (cadddr spec) vnames) (push (list (car spec) v (and-form-type (var-type v) init (caddr spec)) sv) keywords) (push v *vars*) (push sv *vars*)))) (go Lkey) Laux (setq aux-info (make-info)) Laux1 (when (null vl) (add-info info aux-info) (return-from parse)) (ck-vl (consp vl)) (setq spec (pop vl)) (cond ((consp spec) (cond ((not (consp (cdr spec))) (ck-spec (null (cdr spec))) (let ((v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (default-init (var-type v)) aux-inits) (push v aux-vars) (push v *vars*))) (t (ck-spec (null (cddr spec))) (let ((init (c1expr* (cadr spec) aux-info)) (v (c1make-var (car spec) ss is ts))) (push (car spec) vnames) (push (and-form-type (var-type v) init (cadr spec)) aux-inits) (push v aux-vars) (push v *vars*))))) (t (let ((v (c1make-var spec ss is ts))) (push spec vnames) (push (default-init (var-type v)) aux-inits) (push v aux-vars) (push v *vars*)))) (go Laux1) ) ) (setq requireds (nreverse requireds) optionals (nreverse optionals) keywords (nreverse keywords) aux-vars (nreverse aux-vars) aux-inits (nreverse aux-inits)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (dolist** (var requireds) (check-vref var)) (dolist** (opt optionals) (check-vref (car opt)) (when (caddr opt) (check-vref (caddr opt)))) (when rest (check-vref rest)) (dolist** (kwd keywords) (check-vref (cadr kwd)) (when (cadddr kwd) (check-vref (cadddr kwd)))) (dolist** (var aux-vars) (check-vref var)) (when aux-vars (add-info aux-info (cadr body)) (setq body (list 'let* aux-info aux-vars aux-inits body)) (or (eql setjmps *setjmps*) (setf (info-volatile aux-info) t))) (setq body (fix-down-args requireds body block-name)) (setq lambda-list (list requireds optionals rest key-flag keywords allow-other-keys)) (and *record-call-info* (record-arg-info lambda-list)) (list 'lambda info lambda-list doc body) ) ;;this makes a let for REQUIREDS which are used in a downward ;;lexical closure (defun fix-down-args(requireds body name &aux auxv auxinit info v) (let ((types (get name 'proclaimed-arg-types)) (fixed (get name 'fixed-args))) (do ((vv requireds (cdr vv)) (typ types (cdr typ))) ((null vv)) (setq v (car vv)) (cond ((not (or fixed (eq (car typ) t))) (return-from fix-down-args body)) ((and (eq (var-kind v) 'DOWN) (eq (var-loc v) 'object)) ;;a downward variable could not have been special ;;and must be type t. We create a new variable ;;for the arg, and bind the old one to it. (let* ((new (c1make-var (var-name v) nil nil nil)) (init (list 'var (or info (setq info (make-info))) (list new nil)))) (push v auxv) (setf (car vv) new) (push-referred new info) (push init auxinit))))) (if auxv (list 'let* info auxv auxinit body) body))) (defun the-parameter (name) (cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) name ) (defvar *rest-on-stack* nil) ;; non nil means put rest arg on C stack. (defun c2lambda-expr (lambda-list body &optional (fname nil s-fname)) (let ((*tail-recursion-info* ;;; Tail recursion possible if (if (and *do-tail-recursion* s-fname ;;; named function, (dolist* (var (car lambda-list) t) (when (var-ref-ccb var) (return nil))) ;;; no required is closed in a closure, (null (cadr lambda-list)) ;;; no optionals, (null (caddr lambda-list)) ;;; no rest parameter, and (not (cadddr lambda-list))) ;;; no keywords. (cons fname (car lambda-list)) nil))) (let ((*rest-on-stack* (cond ((and (caddr lambda-list) (eq (var-type (caddr lambda-list)) :dynamic-extent)) t) (t *rest-on-stack*)))) (if (cadddr lambda-list) ;;; key-flag (c2lambda-expr-with-key lambda-list body) (c2lambda-expr-without-key lambda-list body))) )) (defun decl-body-safety (body) (case (car body) (decl-body (or (cadr (assoc 'safety (caddr body))) 0)) ((let let*) (decl-body-safety (car (last body)))) (otherwise 0))) (defun c2lambda-expr-without-key (lambda-list body &aux (requireds (car lambda-list)) (optionals (cadr lambda-list)) (rest (caddr lambda-list)) (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) (block-p nil) ) (declare (object requireds optionals rest)) ;;; Allocate immediate-type parameters. (flet ((do-decl (var) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (v requireds) (do-decl v)) (dolist** (opt optionals) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when rest (do-decl rest)) ) ;;; check arguments (when (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body)));FIXME (cond ((or rest optionals) (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) ") too_few_arguments();")) (unless rest (wt-nl "if(vs_top-vs_base>" (+ (length requireds) (length optionals)) ") too_many_arguments();"))) (t (when requireds (wt-nl "check_arg(" (length requireds) ");"))))) ;;; Allocate the parameters. (dolist** (var requireds) (setf (var-ref var) (vs-push))) (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (dolist** (opt optionals) (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) ;;; Bind required parameters. (dolist** (var requireds) (c2bind var)) ;;; Bind optional parameters as long as there remain arguments. ;;; The compile-time binding is discarded because they are bound again. (when (and (or optionals rest) (not (null requireds))) (wt-nl "vs_base=vs_base+" (length requireds) ";")) (cond (optionals (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (when rest (wt-nl "{object *q=vs_base+" (length optionals) ",*l;") (wt-nl " for (l=q;qc.c_cdr) *l=MMcons(*q,Cnil);") (wt-nl " *l=Cnil;}")) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (push (next-label) labels) (wt-nl "if(vs_base>=vs_top){") (reset-top) (wt-go (car labels)) (wt "}") (c2bind (caar opts)) (when (caddar opts) (c2bind-loc (caddar opts) t)) (when (cdr opts) (wt-nl "vs_base++;")) ) (when rest (c2bind rest)) ) (wt-nl) (reset-top) (let ((label (next-label))) (wt-nl) (wt-go label) (setq labels (nreverse labels)) ;;; Bind unspecified optional parameters. (dolist** (opt optionals) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) (when rest (c2bind-loc rest nil)) (wt-label label))) (rest (wt-nl "{object *q=vs_base,*l;") (wt-nl " for (l=q;qc.c_cdr) *l=" (if *rest-on-stack* "ON_STACK_CONS" "MMcons") "(*q,Cnil);") (wt-nl " *l=Cnil;}") (c2bind rest) (wt-nl) (reset-top)) (t (wt-nl) (reset-top))) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;")(wt-nl1 "TTL:;")) ;;; Now the parameters are ready! (c2expr body) (when block-p (wt-nl "}")) ) (defun c2lambda-expr-with-key (lambda-list body &aux (requireds (nth 0 lambda-list)) (optionals (nth 1 lambda-list)) (rest (nth 2 lambda-list)) (keywords (nth 4 lambda-list)) (allow-other-keys (nth 5 lambda-list)) (labels nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) (block-p nil) ) (declare (object requireds optionals rest keywords allow-other-keys)) ;;; Allocate immediate-type parameters. (flet ((do-decl (var) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (v requireds) (do-decl v)) (dolist** (opt optionals) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when rest (do-decl rest)) (dolist** (kwd keywords) (do-decl (cadr kwd)) (when (cadddr kwd) (do-decl (cadddr kwd)))) ) ;;; Check arguments. (when (and (or *safe-compile* *compiler-check-args* (plusp (decl-body-safety body))) requireds);FIXME (when requireds (wt-nl "if(vs_top-vs_base<" (length requireds) ") too_few_arguments();"))) ;;; Allocate the parameters. (dolist** (var requireds) (setf (var-ref var) (vs-push))) (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (dolist** (kwd keywords) (setf (var-ref (cadr kwd)) (vs-push))) (dolist** (kwd keywords) (setf (var-ref (cadddr kwd)) (vs-push))) (dolist** (opt optionals) (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) ;;; Assign rest and keyword parameters first. ;;; parse_key does not change vs_base and vs_top. (wt-nl "parse_key(vs_base") (when (or requireds optionals) (wt "+" (+ (length requireds) (length optionals)))) (if rest (wt ",TRUE,") (wt ",FALSE,")) (if allow-other-keys (wt "TRUE,") (wt "FALSE,")) (wt (length keywords)) (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd))))) (wt ");") ;;; Bind required parameters. (dolist** (var requireds) (c2bind var)) ;;; Bind optional parameters as long as there remain arguments. ;;; The compile-time binding is discarded because they are bound again. (when optionals (when requireds (wt-nl "vs_base += " (length requireds) ";")) (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (push (next-label) labels) (wt-nl "if(vs_base>=vs_top){") (reset-top) (wt-go (car labels)) (wt "}") (c2bind (caar opts)) (when (caddar opts) (c2bind-loc (caddar opts) t)) (when (cdr opts) (wt-nl "vs_base++;")))) (setq labels (nreverse labels)) ) (reset-top) (when optionals (let ((label (next-label))) (wt-go label) ;;; Bind unspecified optional parameters. (dolist** (opt optionals) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) (wt-label label) )) (when rest (c2bind rest)) ;;; Bind keywords. (dolist** (kwd keywords) (cond ((and (eq (caaddr kwd) 'LOCATION) (null (caddr (caddr kwd)))) ;;; Cnil has been set if keyword parameter is not supplied. (c2bind (cadr kwd))) (t (wt-nl "if(") (wt-vs (var-ref (cadddr kwd))) (wt "==Cnil){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2bind-init (cadr kwd) (caddr kwd))) (wt-nl "}else{") (c2bind (cadr kwd)) (wt "}"))) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind (cadddr kwd)))) ;;; Now the parameters are ready, after all! (c2expr body) (when block-p (wt-nl "}")) ) (defun need-to-set-vs-pointers (lambda-list) ;;; On entry to in-line lambda expression, ;;; vs_base and vs_top must be set iff, (or *safe-compile* *compiler-check-args* (nth 1 lambda-list) ;;; optional, (nth 2 lambda-list) ;;; rest, or (nth 3 lambda-list) ;;; key-flag. )) ;;; The DEFMACRO compiler. ;;; valid lambda-list to DEFMACRO is: ;;; ;;; ( [ &whole sym ] ;;; [ &environment sym ] ;;; { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) ;;; ;;; where v is short for { defmacro-lambda-list | sym }. ;;; Defamcro-lambda-list is defined as: ;;; ;;; ( { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) (defvar *vnames*) (defvar *dm-info*) (defvar *dm-vars*) (defun c1dm (macro-name vl body &aux (*vs* *vs*) (whole nil) (env nil) (setjmps *setjmps*) (*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) doc ss is ts other-decls ppn) (multiple-value-setq (body ss ts is other-decls doc) (c1body body t)) (setq body (list (list* 'block macro-name body))) (c1add-globals ss) (when (and (listp vl) (eq (car vl) '&whole)) (push (cadr vl) *vnames*) (setq whole (c1make-var (cadr vl) ss is ts)) (push whole *dm-vars*) (push whole *vars*) (setq vl (cddr vl)) ) (let ((env-m (and (listp vl) (do ((tail vl (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail)))))) (when env-m (push (cadr env-m) *vnames*) (setq env (c1make-var (cadr env-m) ss is ts)) (push env *dm-vars*) (push env *vars*) (setq vl (append (ldiff vl env-m) (cddr env-m))))) (multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts)) (check-vdecl *vnames* ts is) (setq body (c1decl-body other-decls body)) (add-info *dm-info* (cadr body)) (cond ((eql setjmps *setjmps*)) (t(setf (info-volatile *dm-info*) t) (setf (get macro-name 'contains-setjmp) t) )) (dolist* (v *dm-vars*) (check-vref v)) (list doc ppn whole env vl body *dm-info*) ) (defun c1dm-vl (vl ss is ts) (do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil) (auxp nil) (requireds nil) (optionals nil) (rest nil) (key-flag nil) (keywords nil) (auxs nil) (allow-other-keys nil) (n 0) (ppn nil) ) ((not (consp vl)) (when vl (when restp (dm-bad-key '&rest)) (setq rest (c1dm-v vl ss is ts))) (values (list (nreverse requireds) (nreverse optionals) rest key-flag (nreverse keywords) allow-other-keys (nreverse auxs)) ppn) ) (let ((v (car vl))) (declare (object v)) (cond ((eq v '&optional) (when optionalp (dm-bad-key '&optional)) (setq optionalp t) (pop vl)) ((or (eq v '&rest) (eq v '&body)) (when restp (dm-bad-key v)) (setq rest (c1dm-v (cadr vl) ss is ts)) (setq restp t optionalp t) (setq vl (cddr vl)) (when (eq v '&body) (setq ppn n))) ((eq v '&key) (when keyp (dm-bad-key '&key)) (setq keyp t restp t optionalp t key-flag t) (pop vl)) ((eq v '&allow-other-keys) (when (or (not keyp) allow-other-keys-p) (dm-bad-key '&allow-other-keys)) (setq allow-other-keys-p t allow-other-keys t) (pop vl)) ((eq v '&aux) (when auxp (dm-bad-key '&aux)) (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) (pop vl)) (auxp (let (x init) (cond ((symbolp v) (setq x v init (c1nil))) (t (setq x (car v)) (if (endp (cdr v)) (setq init (c1nil)) (setq init (c1expr* (cadr v) *dm-info*))))) (push (list (c1dm-v x ss is ts) init) auxs)) (pop vl)) (keyp (let (x k init (sv nil)) (cond ((symbolp v) (setq x v k (intern (string v) 'keyword) init (c1nil))) (t (if (symbolp (car v)) (setq x (car v) k (intern (string (car v)) 'keyword)) (setq x (cadar v) k (caar v))) (cond ((endp (cdr v)) (setq init (c1nil))) (t (setq init (c1expr* (cadr v) *dm-info*)) (unless (endp (cddr v)) (setq sv (caddr v))))))) (push (list k (c1dm-v x ss is ts) init (if sv (c1dm-v sv ss is ts) nil)) keywords) ) (pop vl)) (optionalp (let (x init (sv nil)) (cond ((symbolp v) (setq x v init (c1nil))) (t (setq x (car v)) (cond ((endp (cdr v)) (setq init (c1nil))) (t (setq init (c1expr* (cadr v) *dm-info*)) (unless (endp (cddr v)) (setq sv (caddr v))))))) (push (list (c1dm-v x ss is ts) init (if sv (c1dm-v sv ss is ts) nil)) optionals)) (pop vl) (incf n) ) (t (push (c1dm-v v ss is ts) requireds) (pop vl) (incf n)) ))) ) (defun c1dm-v (v ss is ts) (cond ((symbolp v) (push v *vnames*) (setq v (c1make-var v ss is ts)) (push v *vars*) (push v *dm-vars*) v) (t (c1dm-vl v ss is ts)))) (defun c1dm-bad-key (key) (cmperr "Defmacro-lambda-list contains illegal use of ~s." key)) (defmacro maybe-wt-c2dm-bind-vl (vl cvar form end-form) `(let ((ipos (file-position *compiler-output1*))) ,form (let ((npos (file-position *compiler-output1*))) (c2dm-bind-vl ,vl ,cvar) (if (eql npos (file-position *compiler-output1*)) (file-position *compiler-output1* ipos) ,end-form)))) (defun c2dm (whole env vl body &aux (cvar (next-cvar))) (when (or *safe-compile* *compiler-check-args*) (wt-nl "check_arg(2);")) (cond (whole (setf (var-ref whole) (vs-push))) (t (vs-push))) (cond (env (setf (var-ref env) (vs-push))) (t (vs-push))) (c2dm-reserve-vl vl) (reset-top) (when whole (c2bind whole)) (when env (c2bind env)) (maybe-wt-c2dm-bind-vl vl cvar (wt-nl "{object V" cvar "=base[0]->c.c_cdr;") (wt "}")) (c2expr body) ) (defun c2dm-reserve-vl (vl) (dolist** (var (car vl)) (c2dm-reserve-v var)) (dolist** (opt (cadr vl)) (c2dm-reserve-v (car opt)) (when (caddr opt) (c2dm-reserve-v (caddr opt)))) (when (caddr vl) (c2dm-reserve-v (caddr vl))) (dolist** (kwd (car (cddddr vl))) (c2dm-reserve-v (cadr kwd)) (when (cadddr kwd) (c2dm-reserve-v (cadddr kwd)))) (dolist** (aux (caddr (cddddr vl))) (c2dm-reserve-v (car aux))) ) (defun c2dm-reserve-v (v) (if (consp v) (c2dm-reserve-vl v) (setf (var-ref v) (vs-push)))) (defun c2dm-bind-vl (vl cvar &aux (requireds (car vl)) (optionals (cadr vl)) (rest (caddr vl)) (key-flag (cadddr vl)) (keywords (car (cddddr vl))) (allow-other-keys (cadr (cddddr vl))) (auxs (caddr (cddddr vl))) ) (declare (object requireds optionals rest key-flag keywords allow-other-keys auxs)) (do ((reqs requireds (cdr reqs))) ((endp reqs)) (declare (object reqs)) (when (or *safe-compile* *compiler-check-args*) (wt-nl "if(endp(V" cvar "))invalid_macro_call();")) (c2dm-bind-loc (car reqs) `(car ,cvar)) (when (or (cdr reqs) optionals rest key-flag *safe-compile* *compiler-check-args*) (wt-nl "V" cvar "=V" cvar "->c.c_cdr;"))) (do ((opts optionals (cdr opts))) ((endp opts)) (declare (object opts)) (let ((opt (car opts))) (declare (object opt)) (wt-nl "if(endp(V" cvar ")){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2dm-bind-init (car opt) (cadr opt)) (when (caddr opt) (c2dm-bind-loc (caddr opt) nil)) ) (wt-nl "} else {") (c2dm-bind-loc (car opt) `(car ,cvar)) (when (caddr opt) (c2dm-bind-loc (caddr opt) t))) (when (or (cdr opts) rest key-flag *safe-compile* *compiler-check-args*) (wt-nl "V" cvar "=V" cvar "->c.c_cdr;")) (wt "}")) (when rest (c2dm-bind-loc rest `(cvar ,cvar))) (dolist** (kwd keywords) (let ((cvar1 (next-cvar))) (wt-nl "{object V" cvar1 "=getf(V" cvar "," (vv-str (add-symbol (car kwd))) ",OBJNULL);") (wt-nl "if(V" cvar1 "==OBJNULL){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2dm-bind-init (cadr kwd) (caddr kwd)) (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) nil)) (wt "} else {")) (c2dm-bind-loc (cadr kwd) `(cvar ,cvar1)) (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) t)) (wt-nl "}}"))) (when (and (or *safe-compile* *compiler-check-args*) (null rest) (null key-flag)) (wt-nl "if(!endp(V" cvar "))invalid_macro_call();")) (when (and (or *safe-compile* *compiler-check-args*) key-flag (not allow-other-keys)) (wt-nl "check_other_key(V" cvar "," (length keywords)) (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd))))) (wt ");")) (dolist** (aux auxs) (c2dm-bind-init (car aux) (cadr aux))) ) (defun c2dm-bind-loc (v loc) (if (consp v) (let ((cvar (next-cvar))) (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}"))) (c2bind-loc v loc))) (defun c2dm-bind-init (v init) (if (consp v) (let* ((*vs* *vs*) (*inline-blocks* 0) (cvar (next-cvar)) (loc (car (inline-args (list init) '(t))))) (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}")) (close-inline-blocks)) (c2bind-init v init))) gcl-2.6.14/cmpnew/gcl_nocmpinc.lsp0000755000175000017500000000071014360276512015440 0ustar cammcamm (in-package :compiler) (defvar *cmpinclude-string* nil) (defun write-out-cmpinclude (stream string) (do ((i 0 (setq i (the fixnum (+ i 1)))) (l (length *cmpinclude-string*))) ((>= i l)) (declare (fixnum i l)) (or string (setq string *cmpinclude-string*)) (or string (error "need a string")) (let ((tem (aref (the string string i)))) (declare (character tem)) (write-char tem stream)))) gcl-2.6.14/cmpnew/gcl_cmpblock.lsp0000755000175000017500000001375414360276512015440 0ustar cammcamm;;; CMPBLOCK Block and Return-from. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'block 'c1block 'c1special) (si:putprop 'block 'c2block 'c2) (si:putprop 'return-from 'c1return-from 'c1special) (si:putprop 'return-from 'c2return-from 'c2) (defstruct blk name ;;; Block name. ref ;;; Referenced or not. T or NIL. ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; block id, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-vs for the ;;; block id, or NIL. exit ;;; Where to return. A label. value-to-go ;;; Where the value of the block to go. var ;;; The block name holder. Used only in ;;; the error message. ) (defvar *blocks* nil) ;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB' ;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on ;;; *blocks* when the compiler begins to process a closure. 'LB' will be ;;; pushed on *blocks* when *level* is incremented. (defun c1block (args) (when (endp args) (too-few-args 'block 1 0)) (cmpck (not (symbolp (car args))) "The block name ~s is not a symbol." (car args)) (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil)) (*blocks* (cons blk *blocks*)) (body (c1progn (cdr args)))) (if (or (blk-ref-ccb blk) (blk-ref-clb blk)) (incf *setjmps*)) (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk)) (list 'block (reset-info-type (cadr body)) blk body) body)) ) (defun c2block (blk body) (cond ((blk-ref-ccb blk) (c2block-ccb blk body)) ((blk-ref-clb blk) (c2block-clb blk body)) (t (c2block-local blk body)))) (defun c2block-local (blk body) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (c2expr body) ) (defun c2block-clb (blk body &aux (*vs* *vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (setf (blk-exit blk) *exit*) (setf (blk-value-to-go blk) *value-to-go*) (setf (blk-ref-clb blk) (vs-push)) (setf (blk-var blk) (add-symbol (blk-name blk))) (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");") (clink (blk-ref-clb blk)) (setf (blk-ref-ccb blk) (ccb-vs-push)) (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");") (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt-nl "}") ) (defun c1return-from (args) (cond ((endp args) (too-few-args 'return-from 1 0)) ((and (not (endp (cdr args))) (not (endp (cddr args)))) (too-many-args 'return-from 2 (length args))) ((not (symbolp (car args))) "The block name ~s is not a symbol." (car args))) (do ((blks *blocks* (cdr blks)) (name (car args)) (ccb nil) (clb nil)) ((endp blks) (cmperr "The block ~s is undefined." name)) (declare (object name ccb clb)) (case (car blks) (cb (setq ccb t)) (lb (setq clb t)) (t (when (eq (blk-name (car blks)) name) (let ((val (c1expr (cadr args))) (blk (car blks))) (cond (ccb (setf (blk-ref-ccb blk) t)) (clb (setf (blk-ref-clb blk) t)) (t (setf (blk-ref blk) t))) (return (list 'return-from (reset-info-type (cadr val)) blk clb ccb val))))))) ) (defun c2return-from (blk clb ccb val) (cond (ccb (c2return-ccb blk val)) (clb (c2return-clb blk val)) (t (c2return-local blk val)))) (defun c2return-local (blk val) (let ((*value-to-go* (blk-value-to-go blk)) (*exit* (blk-exit blk))) (c2expr val)) ) (defun c2return-clb (blk val) (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(frs_sch(") (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk))) (wt "),Cnil);") ) (defun c2return-ccb (blk val) (wt-nl "{frame_ptr fr;") (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");") (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1," (vv-str (blk-var blk)) ");") (let ((*value-to-go* 'top)) (c2expr* val)) (wt-nl "unwind(fr,Cnil);}") ) gcl-2.6.14/cmpnew/gcl_cmpvs.lsp0000755000175000017500000000560514360276512014772 0ustar cammcamm;;; CMPVS Value stack manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'vs 'set-vs 'set-loc) (si:putprop 'vs 'wt-vs 'wt-loc) (si:putprop 'vs* 'wt-vs* 'wt-loc) (si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc) (defvar *vs* 0) (defvar *max-vs* 0) (defvar *clink* nil) (defvar *ccb-vs* 0) ;; We need an initial binding for *initial-ccb-vs* for use in defining ;; local functions at the toplevel in c2flet and c2labels. CM ;; 20031130. (defvar *initial-ccb-vs* 0) (defvar *level* 0) (defvar *vcs-used*) ;;; *vs* holds the offset of the current vs-top. ;;; *max-vs* holds the maximum offset so far. ;;; *clink* holds NIL or the vs-address of the last ccb object. ;;; *ccb-vs* holds the top of the level 0 vs. ;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process ;;; a local (possibly closure) function. ;;; *level* holds the current function level. *level* is 0 for a top-level ;;; function. (defun vs-push () (prog1 (cons *level* *vs*) (incf *vs*) (setq *max-vs* (max *vs* *max-vs*)))) (defun set-vs (loc vs) (unless (and (consp loc) (eq (car loc) 'vs) (equal (cadr loc) vs)) (wt-nl) (wt-vs vs) (wt "= " loc ";"))) (defun wt-vs (vs) (cond ((eq (car vs) 'cvar) (wt "V" (second vs))) ((eq (car vs) 'cs) (setq *vcs-used* t) (wt "Vcs[" (cdr vs) "]")) ((eq (car vs) 'fun-env) (wt "fun->cc.cc_turbo[" (cdr vs) "]")) (t (if (= (car vs) *level*) (wt "base[" (cdr vs) "]") (wt "base" (car vs) "[" (cdr vs) "]"))))) (defun wt-vs* (vs) (wt "(" )(wt-vs vs) (wt "->c.c_car)")) (defun wt-ccb-vs (ccb-vs);;FIXME harmonize *closure-p* with *clink* (wt "(" (if *closure-p* "fun->cc.cc_turbo" "base0") "[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)")) (defun clink (vs) (setq *clink* vs)) (defun wt-clink (&optional (clink *clink*)) (if (null clink) (wt "Cnil") (wt-vs clink))) (defun ccb-vs-push () (incf *ccb-vs*)) (defun cvs-push () (prog1 (cons 'cs *cs*) (incf *cs*) )) (defun wt-list (l) (do ((v l (cdr v))) ((null v)) (wt (car v)) (or (null (cdr v)) (wt ",")))) gcl-2.6.14/cmpnew/gcl_cmpflet.lsp0000755000175000017500000003757114360276512015303 0ustar cammcamm;;; CMPFLET Flet, Labels, and Macrolet. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'flet 'c1flet 'c1special) (si:putprop 'flet 'c2flet 'c2) (si:putprop 'labels 'c1labels 'c1special) (si:putprop 'labels 'c2labels 'c2) (si:putprop 'macrolet 'c1macrolet 'c1special) ;;; c2macrolet is not defined, because MACROLET is replaced by PROGN ;;; during Pass 1. (si:putprop 'call-local 'c2call-local 'c2) (defstruct fun name ;;; Function name. ref ;;; Referenced or not. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; function closure, or NIL. ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the vs-address for the ;;; function closure, or NIL. cfun ;;; The cfun for the function. level ;;; The level of the function. info ;;; fun-info; CM, 20031008 ;;; collect info structure when processing ;;; function lambda list in flet and labels ;;; and pass upwards to call-local and call-global ;;; to determine more accurately when ;;; args-info-changed-vars should prevent certain ;;; inlining ;;; examples: (defun foo (a) (flet ((%f8 nil (setq a 0))) ;;; (let ((v9 a)) (- (%f8) v9)))) ;;; (defun foo (a) (flet ((%f8 nil (setq a 2))) ;;; (* a (%f8)))) ) (defvar *funs* nil) ;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions ;;; and the symbol 'CB' (Closure Boundary). 'CB' will be pushed on *funs* ;;; when the compiler begins to process a closure. A local macro definition ;;; is a list ( macro-name expansion-function). (defun c1flet (args &aux body ss ts is other-decl info (defs1 nil) (local-funs nil) (closures nil) (*info* (copy-info *info*))) (when (endp args) (too-few-args 'flet 1 0)) (let ((*funs* *funs*)) (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The function definition ~s is illegal." def) (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) (push fun *funs*) (push (list fun (cdr def)) defs1))) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (setq info (copy-info (cadr body)))) (dolist* (def (setq defs1 (nreverse defs1))) (when (fun-ref-ccb (car def)) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) closures)))) (when (fun-ref (car def)) (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) local-funs)))) (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) (setf (fun-cfun (car def)) (next-cfun)))) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars ;; ;; walk body a second time to incorporate changed variable info from local function ;; lambda lists (let ((*funs* *funs*)) (setq *funs* (nconc (mapcar 'car defs1) *funs*)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) ;; Apparently this is not scricttly necessary, just changes to body (add-info info (cadr body))) (if (or local-funs closures) (list 'flet info (nreverse local-funs) (nreverse closures) body) body)) (defun c2flet (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (dolist** (def local-funs) (setf (fun-level (car def)) *level*) ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing ;; the code for this function. Local functions, unlike closures, get an envinment ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) ;;; Setup closures. (dolist** (def closures) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* (car def) (cadr def)) *local-funs*) (push (car def) *closures*) (let ((fun (car def))) (declare (object fun)) (setf (fun-ref fun) (vs-push)) (wt-nl) (wt-vs (fun-ref fun)) (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun fun) (fun-name fun)) ",Cnil,") (wt-clink) (wt ",Cdata);") (wt-nl) (wt-vs (fun-ref fun)) (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");") (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push)) )) (c2expr body) ) (defun c1labels (args &aux body ss ts is other-decl info (defs1 nil) (local-funs nil) (closures nil) (fnames nil) (processed-flag nil) (*funs* *funs*) (*info* (copy-info *info*))) (when (endp args) (too-few-args 'labels 1 0)) ;;; bind local-functions (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The local function definition ~s is illegal." def) (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) (push (car def) fnames) (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) (push fun *funs*) (push (list fun nil nil (cdr def)) defs1))) (setq defs1 (nreverse defs1)) ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ). (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (setq info (copy-info (cadr body))) (block local-process (loop (setq processed-flag nil) (dolist** (def defs1) (when (and (fun-ref (car def)) ;;; referred locally and (null (cadr def))) ;;; not processed yet (setq processed-flag t) (setf (cadr def) t) (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) local-funs))))) (unless processed-flag (return-from local-process)) )) ;;; end local process (block closure-process (loop (setq processed-flag nil) (dolist** (def defs1) (when (and (fun-ref-ccb (car def)) ; referred across closure (null (caddr def))) ; and not processed (setq processed-flag t) (setf (caddr def) t) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) (add-info info (cadr lam)) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars (add-info (fun-info (car def)) (cadr lam)) (push (list (car def) lam) closures)))) ) (unless processed-flag (return-from closure-process)) )) ;;; end closure process (dolist** (def defs1) (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) (setf (fun-cfun (car def)) (next-cfun)))) ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args ;; via args-info-changed-vars ;; ;; walk body a second time to gather info in labels lambda lists (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) (setq body (c1decl-body other-decl body))) (add-info info (cadr body)) (if (or local-funs closures) (list 'labels info (nreverse local-funs) (nreverse closures) body) body)) (defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) ;;; Prepare for cross-referencing closures. (dolist** (def closures) (let ((fun (car def))) (declare (object fun)) (setf (fun-ref fun) (vs-push)) (wt-nl) (wt-vs (fun-ref fun)) (wt "=MMcons(Cnil,") (wt-clink) (wt ");") (clink (fun-ref fun)) (setf (fun-ref-ccb fun) (ccb-vs-push)) )) (dolist** (def local-funs) (setf (fun-level (car def)) *level*) ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing ;; the code for this function. Local functions, unlike closures, get an envinment ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) ;;; Then make closures. (dolist** (def closures) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* (car def) (cadr def)) *local-funs*) (push (car def) *closures*) (wt-nl) (wt-vs* (fun-ref (car def))) (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun (car def)) (fun-name (car def))) ",Cnil,") (wt-clink) (wt ",Cdata);") ) ;;; now the body of flet (c2expr body) ) (defun c1macrolet (args &aux body ss ts is other-decl (*funs* *funs*) (*vars* *vars*)) (when (endp args) (too-few-args 'macrolet 1 0)) (dolist** (def (car args)) (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) "The macro definition ~s is illegal." def) (push (list (car def) (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) *funs*)) (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) (c1add-globals ss) (check-vdecl nil ts is) (c1decl-body other-decl body) ) (defun c1local-fun (fname &aux (ccb nil)) (declare (object ccb)) (dolist* (fun *funs* nil) (cond ((eq fun 'CB) (setq ccb t)) ((consp fun) (when (eq (car fun) fname) (return (cadr fun)))) ((eq (fun-name fun) fname) (if ccb (setf (fun-ref-ccb fun) t) (setf (fun-ref fun) t)) ;; Add fun-info here at the bottom of the call-local processing tree ;; FIXME -- understand why special variable *info* is used in certain ;; cases and copy-info in othes. ;; This extends local call arg side-effect protection (via args-info-changed-vars) ;; through c1funob to other call methods than previously supported c1symbol-fun, ;; e.g. c1multiple-value-call, etc. CM 20031030 (add-info *info* (fun-info fun)) (return (list 'call-local *info* fun ccb)))))) (defun sch-local-fun (fname) ;;; Returns fun-ob for the local function (not locat macro) named FNAME, ;;; if any. Otherwise, returns FNAME itself. (dolist* (fun *funs* fname) (when (and (not (eq fun 'CB)) (not (consp fun)) (eq (fun-name fun) fname)) (return fun))) ) (defun c1local-closure (fname &aux (ccb nil)) (declare (object ccb)) ;;; Called only from C1FUNCTION. (dolist* (fun *funs* nil) (cond ((eq fun 'CB) (setq ccb t)) ((consp fun) (when (eq (car fun) fname) (return (cadr fun)))) ((eq (fun-name fun) fname) (setf (fun-ref-ccb fun) t) ;; Add fun-info here at the bottom of the call-local processing tree ;; FIXME -- understand why special variable *info* is used in certain ;; cases and copy-info in othes. ;; This extends local call arg side-effect protection (via args-info-changed-vars) ;; through c1funob to other call methods than previously supported c1symbol-fun, ;; e.g. c1multiple-value-call, etc. CM 20031030 (add-info *info* (fun-info fun)) (return (list 'call-local *info* fun ccb)))))) (defun c2call-local (fd args &aux (*vs* *vs*)) ;;; FD is a list ( fun-object ccb ). (cond ((cadr fd) (push-args args) (wt-nl "funcall(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");")) ((and (listp args) *do-tail-recursion* *tail-recursion-info* (eq (car *tail-recursion-info*) (car fd)) (eq *exit* 'RETURN) (tail-recursion-possible) (= (length args) (length (cdr *tail-recursion-info*)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2psetq (mapcar #'(lambda (v) (list v nil)) (cdr *tail-recursion-info*)) args) (wt-label *exit*)) (unwind-no-exit 'tail-recursion-mark) (wt-nl "goto TTL;") (cmpnote "Tail-recursive call of ~s was replaced by iteration." (fun-name (car fd)))) (t (push-args args) (wt-nl (c-function-name "L" (fun-cfun (car fd)) (fun-name (car fd))) "(") (dotimes** (n (fun-level (car fd))) (if (when *closure-p* (zerop n)) (wt "fun->cc.cc_turbo,") (wt "base" n ","))) (wt "base") (unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd)))) (wt ");") (base-used))) (unwind-exit 'fun-val) ) gcl-2.6.14/cmpnew/gcl_lfun_list.lsp0000755000175000017500000005333514360276512015644 0ustar cammcamm ;; Modified data base including return values types ;; and making the arglists correct if they have optional args. ;; (in-package :compiler) (DEFSYSFUN 'GENSYM "Lgensym" '(*) 'T NIL NIL) (DEFSYSFUN 'SUBSEQ "Lsubseq" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MINUSP "Lminusp" '(T) 'T NIL T) (DEFSYSFUN 'INTEGER-DECODE-FLOAT "Linteger_decode_float" '(T) '(VALUES T T T) NIL NIL) (DEFSYSFUN '- "Lminus" '(T *) 'T NIL NIL) (DEFSYSFUN 'INT-CHAR "Lint_char" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-INT "Lchar_int" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN '/= "Lall_different" '(T *) 'T NIL T) (DEFSYSFUN 'COPY-SEQ "Lcopy_seq" '(T) 'T NIL NIL) (DEFSYSFUN 'KEYWORDP "Lkeywordp" '(T) 'T NIL T) (DEFSYSFUN 'NAME-CHAR "Lname_char" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-NAME "Lchar_name" '(T) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF "Lrassoc_if" '(T T) 'T NIL NIL) (DEFSYSFUN 'MAKE-LIST "Lmake_list" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-ECHO-STREAM "Lmake_echo_stream" '(T T) 'T NIL NIL) ;(DEFSYSFUN 'NTH "Lnth" '(T T) 'T NIL NIL) (DEFSYSFUN 'SIN "Lsin" '(T) 'T NIL NIL) (DEFSYSFUN 'NUMERATOR "Lnumerator" '(T) 'T NIL NIL) (DEFSYSFUN 'ARRAY-RANK "Larray_rank" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'CAAR "Lcaar" '(T) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'LOAD "Lload" '(T *) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'OPEN "Lopen" '(T *) 'T NIL NIL) (DEFSYSFUN 'BOTH-CASE-P "Lboth_case_p" '(T) 'T NIL T) (DEFSYSFUN 'NULL "Lnull" '(T) 'T NIL T) (DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'NCONC "Lnconc" '(*) 'T NIL NIL) (DEFSYSFUN 'BOOLE "Lboole" '(T T T) 'T NIL NIL) (DEFSYSFUN 'TAILP "Ltailp" '(T T) 'T NIL T) (DEFSYSFUN 'CONSP "Lconsp" '(T) 'T NIL T) (DEFSYSFUN 'LISTP "Llistp" '(T) 'T NIL T) (DEFSYSFUN 'MAPCAN "Lmapcan" '(T T *) 'T NIL NIL) (DEFSYSFUN 'LENGTH "Llength" '(T) 'FIXNUM T NIL) (DEFSYSFUN 'RASSOC "Lrassoc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'PPRINT "Lpprint" '(T *) 'T NIL NIL) (DEFSYSFUN 'NSUBST-IF-NOT "Lnsubst_if_not" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'STRING< "Lstring_l" '(T T *) 'T NIL NIL) (DEFSYSFUN 'REVERSE "Lreverse" '(T) 'T NIL NIL) (DEFSYSFUN 'STREAMP "Lstreamp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::PUTPROP "siLputprop" '(T T T) 'T NIL NIL) (DEFSYSFUN 'REMPROP "Lremprop" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYMBOL-PACKAGE "Lsymbol_package" '(T) 'T NIL NIL) (DEFSYSFUN 'NSTRING-UPCASE "Lnstring_upcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'STRING>= "Lstring_ge" '(T T *) 'T NIL NIL) (DEFSYSFUN 'REALPART "Lrealpart" '(T) 'T NIL NIL) ;;broken on suns.. (DEFSYSFUN 'NBUTLAST "Lnbutlast" '(T *) 'T NIL NIL) (DEFSYSFUN 'ARRAY-DIMENSION "Larray_dimension" '(T T) 'FIXNUM NIL NIL) (DEFSYSFUN 'CDR "Lcdr" '(T) 'T NIL NIL) ;(DEFSYSFUN 'EQL "Leql" '(T T) 'T NIL T) (DEFSYSFUN 'LOG "Llog" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-EQUAL "Lstring_not_equal" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SHADOWING-IMPORT "Lshadowing_import" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAPC "Lmapc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAPL "Lmapl" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAKUNBOUND "Lmakunbound" '(T) 'T NIL NIL) (DEFSYSFUN 'CONS "Lcons" '(T T) 'T NIL NIL) (DEFSYSFUN 'LIST "Llist" '(*) 'T NIL NIL) (DEFSYSFUN 'USE-PACKAGE "Luse_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-SYMBOL "Lmake_symbol" '(T) 'T NIL NIL) (DEFSYSFUN 'STRING-RIGHT-TRIM "Lstring_right_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'PRINT "Lprint" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDDAAR "Lcddaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADAR "Lcdadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDAADR "Lcdaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDAR "Lcaddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADADR "Lcadadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADDR "Lcaaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'SET-MACRO-CHARACTER "Lset_macro_character" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FORCE-OUTPUT "Lforce_output" '(*) 'T NIL NIL) ;(DEFSYSFUN 'NTHCDR "Lnthcdr" '(T T) 'T NIL NIL) (DEFSYSFUN 'LOGIOR "Llogior" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-DOWNCASE "Lchar_downcase" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'STRING-CHAR-P "Lstring_char_p" '(T) 'T NIL T) (DEFSYSFUN 'STREAM-ELEMENT-TYPE "Lstream_element_type" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-USED-BY-LIST "Lpackage_used_by_list" '(T) 'T NIL NIL) (DEFSYSFUN '/ "Ldivide" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAPHASH "Lmaphash" '(T T) 'T NIL NIL) (DEFSYSFUN 'STRING= "Lstring_eq" '(T T *) 'T NIL T) (DEFSYSFUN 'PAIRLIS "Lpairlis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SYMBOLP "Lsymbolp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-NOT-LESSP "Lchar_not_lessp" '(T *) 'T NIL T) (DEFSYSFUN '1+ "Lone_plus" '(T) 'T NIL NIL) (DEFSYSFUN 'BY "Lby" 'NIL 'T NIL NIL) (DEFSYSFUN 'NSUBST-IF "Lnsubst_if" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'COPY-LIST "Lcopy_list" '(T) 'T NIL NIL) (DEFSYSFUN 'TAN "Ltan" '(T) 'T NIL NIL) (DEFSYSFUN 'SET "Lset" '(T T) 'T NIL NIL) (DEFSYSFUN 'FUNCTIONP "Lfunctionp" '(T) 'T NIL T) (DEFSYSFUN 'WRITE-BYTE "Lwrite_byte" '(T T) 'T NIL NIL) (DEFSYSFUN 'LAST "Llast" '(T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-STRING "Lmake_string" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CAAAR "Lcaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'LIST-LENGTH "Llist_length" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDDR "Lcdddr" '(T) 'T NIL NIL) (DEFSYSFUN 'PRIN1 "Lprin1" '(T *) 'T NIL NIL) (DEFSYSFUN 'PRINC "Lprinc" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOWER-CASE-P "Llower_case_p" '(T) 'T NIL T) (DEFSYSFUN 'CHAR<= "Lchar_le" '(T *) 'T NIL T) (DEFSYSFUN 'STRING-EQUAL "Lstring_equal" '(T T *) 'T NIL T) (DEFSYSFUN 'CLEAR-OUTPUT "Lclear_output" '(*) 'T NIL NIL) #-clcs (DEFSYSFUN 'CERROR "Lcerror" '(T T *) 'T NIL NIL) (DEFSYSFUN 'TERPRI "Lterpri" '(*) 'T NIL NIL) (DEFSYSFUN 'NSUBST "Lnsubst" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'UNUSE-PACKAGE "Lunuse_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-GREATERP "Lstring_not_greaterp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'STRING> "Lstring_g" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FINISH-OUTPUT "Lfinish_output" '(*) 'T NIL NIL) (DEFSYSFUN 'SPECIAL-OPERATOR-P "Lspecial_operator_p" '(T) 'T NIL T) (DEFSYSFUN 'STRINGP "Lstringp" '(T) 'T NIL T) (DEFSYSFUN 'GET-INTERNAL-RUN-TIME "Lget_internal_run_time" 'NIL 'T NIL NIL) (DEFSYSFUN 'TRUNCATE "Ltruncate" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'CODE-CHAR "Lcode_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHAR-CODE "Lchar_code" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'SIMPLE-STRING-P "Lsimple_string_p" '(T) 'T NIL T) (DEFSYSFUN 'REVAPPEND "Lrevappend" '(T T) 'T NIL NIL) (DEFSYSFUN 'HASH-TABLE-COUNT "Lhash_table_count" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-USE-LIST "Lpackage_use_list" '(T) 'T NIL NIL) (DEFSYSFUN 'REM "Lrem" '(T T) 'T NIL NIL) (DEFSYSFUN 'MIN "Lmin" '(T *) 'T NIL NIL) (DEFSYSFUN 'APPLYHOOK "Lapplyhook" '(T T T T *) 'T NIL NIL) (DEFSYSFUN 'EXP "Lexp" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR-LESSP "Lchar_lessp" '(T *) 'T NIL T) (DEFSYSFUN 'CDAR "Lcdar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADR "Lcadr" '(T) 'T NIL NIL) (DEFSYSFUN 'LIST-ALL-PACKAGES "Llist_all_packages" 'NIL 'T NIL NIL) (DEFSYSFUN 'REST "Lcdr" '(T) 'T NIL NIL) (DEFSYSFUN 'COPY-SYMBOL "Lcopy_symbol" '(T *) 'T NIL NIL) (DEFSYSFUN 'ACONS "Lacons" '(T T T) 'T NIL NIL) (DEFSYSFUN 'ADJUSTABLE-ARRAY-P "Ladjustable_array_p" '(T) 'T NIL T) (DEFSYSFUN 'SVREF "Lsvref" '(T T) 'T NIL NIL) (DEFSYSFUN 'APPLY "Lapply" '(T T *) 'T NIL NIL) (DEFSYSFUN 'DECODE-FLOAT "Ldecode_float" '(T) '(VALUES T T T) NIL NIL) ;(DEFSYSFUN 'SUBST-IF-NOT "Lsubst_if_not" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'RPLACA "Lrplaca" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYMBOL-PLIST "Lsymbol_plist" '(T) 'T NIL NIL) (DEFSYSFUN 'WRITE-STRING "Lwrite_string" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOGEQV "Llogeqv" '(*) 'T NIL NIL) (DEFSYSFUN 'STRING "Lstring" '(T) 'STRING NIL NIL) (DEFSYSFUN 'STRING-UPCASE "Lstring_upcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CEILING "Lceiling" '(T *) '(VALUES T T) NIL NIL) ;(DEFSYSFUN 'GETHASH "Lgethash" '(T T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'TYPE-OF "Ltype_of" '(T) 'T NIL NIL) (DEFSYSFUN 'BUTLAST "Lbutlast" '(T *) 'T NIL NIL) (DEFSYSFUN '1- "Lone_minus" '(T) 'T NIL NIL) ;(DEFSYSFUN 'MAKE-HASH-TABLE "Lmake_hash_table" '(*) 'T NIL NIL) (DEFSYSFUN 'STRING/= "Lstring_neq" '(T T *) 'T NIL NIL) (DEFSYSFUN '<= "Lmonotonically_nondecreasing" '(T *) 'T NIL T) (DEFSYSFUN 'MAKE-BROADCAST-STREAM "Lmake_broadcast_stream" '(*) 'T NIL NIL) (DEFSYSFUN 'IMAGPART "Limagpart" '(T) 'T NIL NIL) (DEFSYSFUN 'INTEGERP "Lintegerp" '(T) 'T NIL T) (DEFSYSFUN 'READ-CHAR "Lread_char" '(*) 'T NIL NIL) (DEFSYSFUN 'PEEK-CHAR "Lpeek_char" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-FONT "Lchar_font" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'STRING-GREATERP "Lstring_greaterp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'OUTPUT-STREAM-P "Loutput_stream_p" '(T) 'T NIL T) (DEFSYSFUN 'ASH "Lash" '(T T) 'T NIL NIL) (DEFSYSFUN 'LCM "Llcm" '(T *) 'T NIL NIL) (DEFSYSFUN 'ELT "Lelt" '(T T) 'T NIL NIL) (DEFSYSFUN 'COS "Lcos" '(T) 'T NIL NIL) (DEFSYSFUN 'NSTRING-DOWNCASE "Lnstring_downcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'COPY-ALIST "Lcopy_alist" '(T) 'T NIL NIL) (DEFSYSFUN 'ATAN "Latan" '(T *) 'T NIL NIL) (DEFSYSFUN 'FLOAT-RADIX "Lfloat_radix" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'SYMBOL-NAME "Lsymbol_name" '(T) 'STRING NIL NIL) (DEFSYSFUN 'CLEAR-INPUT "Lclear_input" '(*) 'T NIL NIL) (DEFSYSFUN 'FIND-SYMBOL "Lfind_symbol" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'CHAR< "Lchar_l" '(T *) 'T NIL T) (DEFSYSFUN 'HASH-TABLE-P "Lhash_table_p" '(T) 'T NIL T) (DEFSYSFUN 'EVENP "Levenp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CMOD "siLcmod" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CPLUS "siLcplus" '(T T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CTIMES "siLctimes" '(T T) 'T NIL T) (DEFSYSFUN 'SYSTEM::CDIFFERENCE "siLcdifference" '(T T) 'T NIL T) (DEFSYSFUN 'ZEROP "Lzerop" '(T) 'T NIL T) (DEFSYSFUN 'CAAAAR "Lcaaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR>= "Lchar_ge" '(T *) 'T NIL T) (DEFSYSFUN 'CDDDAR "Lcdddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDADR "Lcddadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADDR "Lcdaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDDR "Lcadddr" '(T) 'T NIL NIL) (DEFSYSFUN 'FILL-POINTER "Lfill_pointer" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'MAPCAR "Lmapcar" '(T T *) 'T NIL NIL) (DEFSYSFUN 'FLOATP "Lfloatp" '(T) 'T NIL T) (DEFSYSFUN 'SHADOW "Lshadow" '(T *) 'T NIL NIL) (DEFSYSFUN 'MACROEXPAND-1 "Lmacroexpand_1" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'SXHASH "Lsxhash" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'LISTEN "Llisten" '(*) 'T NIL NIL) (DEFSYSFUN 'ARRAYP "Larrayp" '(T) 'T NIL T) (DEFSYSFUN 'FUNCALL "Lfuncall" '(T *) 'T NIL NIL) (DEFSYSFUN 'CLRHASH "Lclrhash" '(T) 'T NIL NIL) (DEFSYSFUN 'GRAPHIC-CHAR-P "Lgraphic_char_p" '(T) 'T NIL T) (DEFSYSFUN 'FBOUNDP "Lfboundp" '(T) 'T NIL T) (DEFSYSFUN 'NSUBLIS "Lnsublis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR-NOT-EQUAL "Lchar_not_equal" '(T *) 'T NIL T) (DEFSYSFUN 'MACRO-FUNCTION "Lmacro_function" '(T) 'T NIL NIL) ;(DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) (DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) (DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) (DEFSYSFUN 'IN-PACKAGE "Lin_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'READTABLEP "Lreadtablep" '(T) 'T NIL T) (DEFSYSFUN 'FLOAT-SIGN "Lfloat_sign" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHARACTERP "Lcharacterp" '(T) 'T NIL T) (DEFSYSFUN 'READ "Lread" '(*) 'T NIL NIL) (DEFSYSFUN 'UNREAD-CHAR "Lunread_char" '(T *) 'T NIL NIL) (DEFSYSFUN 'CDAAR "Lcdaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAR "Lcadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADR "Lcaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CHAR= "Lchar_eq" '(T *) 'T NIL T) (DEFSYSFUN 'ALPHA-CHAR-P "Lalpha_char_p" '(T) 'T NIL T) (DEFSYSFUN 'STRING-TRIM "Lstring_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'MAKE-PACKAGE "Lmake_package" '(T *) 'T NIL NIL) (DEFSYSFUN 'CLOSE "Lclose" '(T *) 'T NIL NIL) (DEFSYSFUN 'DENOMINATOR "Ldenominator" '(T) 'T NIL NIL) (DEFSYSFUN 'FLOAT "Lfloat" '(T *) 'T NIL NIL) ;(DEFSYSFUN 'FIRST "Lcar" '(T) 'T NIL NIL) (DEFSYSFUN 'ROUND "Lround" '(T *) '(VALUES T T) NIL NIL) ;(DEFSYSFUN 'SUBST "Lsubst" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'UPPER-CASE-P "Lupper_case_p" '(T) 'T NIL T) (DEFSYSFUN 'ARRAY-ELEMENT-TYPE "Larray_element_type" '(T) 'T NIL NIL) (DEFSYSFUN 'ADJOIN "Ladjoin" '(T T *) 'T NIL NIL) (DEFSYSFUN 'LOGAND "Llogand" '(*) 'T NIL NIL) (DEFSYSFUN 'MAPCON "Lmapcon" '(T T *) 'T NIL NIL) (DEFSYSFUN 'INTERN "Lintern" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'VALUES "Lvalues" '(*) '* NIL NIL) (DEFSYSFUN 'EXPORT "Lexport" '(T *) 'T NIL NIL) (DEFSYSFUN '* "Ltimes" '(*) 'T NIL NIL) (DEFSYSFUN '< "Lmonotonically_increasing" '(T *) 'T NIL T) (DEFSYSFUN 'COMPLEX "Lcomplex" '(T *) 'T NIL NIL) (DEFSYSFUN 'SET-SYNTAX-FROM-CHAR "Lset_syntax_from_char" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR-BIT "Lchar_bit" '(T T) 'FIXNUM NIL NIL) (DEFSYSFUN 'INTEGER-LENGTH "Linteger_length" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'PACKAGEP "Lpackagep" '(T) 'T NIL T) (DEFSYSFUN 'INPUT-STREAM-P "Linput_stream_p" '(T) 'T NIL T) (DEFSYSFUN '>= "Lmonotonically_nonincreasing" '(T *) 'T NIL T) ;(DEFSYSFUN 'EQ "Leq" '(T T) 'T NIL T) (DEFSYSFUN 'MAKE-CHAR "Lmake_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'CHARACTER "Lcharacter" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'SYMBOL-FUNCTION "Lsymbol_function" '(T) 'T NIL NIL) (DEFSYSFUN 'CONSTANTP "Lconstantp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-EQUAL "Lchar_equal" '(T *) 'T NIL T) (DEFSYSFUN 'TREE-EQUAL "Ltree_equal" '(T T *) 'T NIL T) (DEFSYSFUN 'CDDR "Lcddr" '(T) 'T NIL NIL) (DEFSYSFUN 'GETF "Lgetf" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SAVE "Lsave" '(T) 'T NIL NIL) (DEFSYSFUN 'MAKE-RANDOM-STATE "Lmake_random_state" '(*) 'T NIL NIL) (DEFSYSFUN 'CHAR-NOT-GREATERP "Lchar_not_greaterp" '(T *) 'T NIL T) (DEFSYSFUN 'EXPT "Lexpt" '(T T) 'T NIL NIL) (DEFSYSFUN 'SQRT "Lsqrt" '(T) 'T NIL NIL) (DEFSYSFUN 'SCALE-FLOAT "Lscale_float" '(T T) 'T NIL NIL) (DEFSYSFUN 'CHAR> "Lchar_g" '(T *) 'T NIL T) (DEFSYSFUN 'LDIFF "Lldiff" '(T T) 'T NIL NIL) (DEFSYSFUN 'ASSOC-IF-NOT "Lassoc_if_not" '(T T) 'T NIL NIL) (DEFSYSFUN 'BIT-VECTOR-P "Lbit_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'NSTRING-CAPITALIZE "Lnstring_capitalize" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'SYMBOL-VALUE "Lsymbol_value" '(T) 'T NIL NIL) (DEFSYSFUN 'RPLACD "Lrplacd" '(T T) 'T NIL NIL) (DEFSYSFUN 'BOUNDP "Lboundp" '(T) 'T NIL T) ;(DEFSYSFUN 'EQUALP "Lequalp" '(T T) 'T NIL T) (DEFSYSFUN 'SIMPLE-BIT-VECTOR-P "Lsimple_bit_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'MEMBER-IF-NOT "Lmember_if_not" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MAKE-TWO-WAY-STREAM "Lmake_two_way_stream" '(T T) 'T NIL NIL) (DEFSYSFUN 'PARSE-INTEGER "Lparse_integer" '(T *) 'T NIL NIL) (DEFSYSFUN '+ "Lplus" '(*) 'T NIL NIL) (DEFSYSFUN '= "Lall_the_same" '(T *) 'T NIL T) (DEFSYSFUN 'GENTEMP "Lgentemp" '(*) 'T NIL NIL) (DEFSYSFUN 'RENAME-PACKAGE "Lrename_package" '(T T *) 'T NIL NIL) (DEFSYSFUN 'COMMONP "siLcommonp" '(T) 'T NIL T) (DEFSYSFUN 'NUMBERP "Lnumberp" '(T) 'T NIL T) (DEFSYSFUN 'COPY-READTABLE "Lcopy_readtable" '(*) 'T NIL NIL) (DEFSYSFUN 'RANDOM-STATE-P "Lrandom_state_p" '(T) 'T NIL T) (DEFSYSFUN 'STANDARD-CHAR-P "Lstandard_char_p" '(T) 'T NIL T) (DEFSYSFUN 'IDENTITY "Lidentity" '(T) 'T NIL NIL) (DEFSYSFUN 'NREVERSE "Lnreverse" '(T) 'T NIL NIL) (DEFSYSFUN 'UNINTERN "Lunintern" '(T *) 'T NIL NIL) (DEFSYSFUN 'UNEXPORT "Lunexport" '(T *) 'T NIL NIL) (DEFSYSFUN 'FLOAT-PRECISION "Lfloat_precision" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'STRING-DOWNCASE "Lstring_downcase" '(T *) 'STRING NIL NIL) (DEFSYSFUN 'CAR "Lcar" '(T) 'T NIL NIL) (DEFSYSFUN 'CONJUGATE "Lconjugate" '(T) 'T NIL NIL) (DEFSYSFUN 'NOT "Lnull" '(T) 'T NIL T) (DEFSYSFUN 'READ-CHAR-NO-HANG "Lread_char_no_hang" '(*) 'T NIL NIL) (DEFSYSFUN 'FRESH-LINE "Lfresh_line" '(*) 'T NIL NIL) (DEFSYSFUN 'WRITE-CHAR "Lwrite_char" '(T *) 'T NIL NIL) ;(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) (DEFSYSFUN 'STRING-NOT-LESSP "Lstring_not_lessp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'CHAR "Lchar" '(T T) 'CHARACTER NIL NIL) (DEFSYSFUN 'AREF "Laref" '(T *) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-NICKNAMES "Lpackage_nicknames" '(T) 'T NIL NIL) (DEFSYSFUN 'ENDP "Lendp" '(T) 'T NIL T) (DEFSYSFUN 'ODDP "Loddp" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-UPCASE "Lchar_upcase" '(T) 'CHARACTER NIL NIL) (DEFSYSFUN 'LIST* "LlistA" '(T *) 'T NIL NIL) (DEFSYSFUN 'VALUES-LIST "Lvalues_list" '(T) '* NIL NIL) ;(DEFSYSFUN 'EQUAL "Lequal" '(T T) 'T NIL T) (DEFSYSFUN 'DIGIT-CHAR-P "Ldigit_char_p" '(T *) 'T NIL NIL) ;; #-clcs (DEFSYSFUN 'ERROR "Lerror" '(T *) 'T NIL NIL) (DEFSYSFUN 'CHAR/= "Lchar_neq" '(T *) 'T NIL T) (DEFSYSFUN 'CDAAAR "Lcdaaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CADAAR "Lcadaar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAADAR "Lcaadar" '(T) 'T NIL NIL) (DEFSYSFUN 'CAAADR "Lcaaadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CDDDDR "Lcddddr" '(T) 'T NIL NIL) (DEFSYSFUN 'GET-MACRO-CHARACTER "Lget_macro_character" '(T *) 'T NIL NIL) (DEFSYSFUN 'FORMAT "Lformat" '(T T *) 'T NIL NIL) (DEFSYSFUN 'COMPILED-FUNCTION-P "Lcompiled_function_p" '(T) 'T NIL T) (DEFSYSFUN 'SUBLIS "Lsublis" '(T T *) 'T NIL NIL) (DEFSYSFUN 'IMPORT "Limport" '(T *) 'T NIL NIL) (DEFSYSFUN 'LOGXOR "Llogxor" '(*) 'T NIL NIL) (DEFSYSFUN 'RASSOC-IF-NOT "Lrassoc_if_not" '(T T) 'T NIL NIL) (DEFSYSFUN 'CHAR-GREATERP "Lchar_greaterp" '(T *) 'T NIL T) (DEFSYSFUN 'MAKE-SYNONYM-STREAM "Lmake_synonym_stream" '(T) 'T NIL NIL) (DEFSYSFUN 'ALPHANUMERICP "Lalphanumericp" '(T) 'T NIL T) (DEFSYSFUN 'REMHASH "Lremhash" '(T T) 'T NIL NIL) (DEFSYSFUN 'NRECONC "Lreconc" '(T T) 'T NIL NIL) (DEFSYSFUN '> "Lmonotonically_decreasing" '(T *) 'T NIL T) (DEFSYSFUN 'LOGBITP "Llogbitp" '(T T) 'T NIL T) (DEFSYSFUN 'MAPLIST "Lmaplist" '(T T *) 'T NIL NIL) (DEFSYSFUN 'VECTORP "Lvectorp" '(T) 'T NIL T) (DEFSYSFUN 'ASSOC-IF "Lassoc_if" '(T T) 'T NIL NIL) (DEFSYSFUN 'GET-PROPERTIES "Lget_properties" '(T T) '* NIL NIL) (DEFSYSFUN 'STRING<= "Lstring_le" '(T T *) 'T NIL NIL) (DEFSYSFUN 'EVALHOOK "siLevalhook" '(T T T *) 'T NIL NIL) (DEFSYSFUN 'LOGCOUNT "Llogcount" '(T) 'T NIL NIL) (DEFSYSFUN 'MEMBER-IF "Lmember_if" '(T T *) 'T NIL NIL) (DEFSYSFUN 'READ-BYTE "Lread_byte" '(T *) 'T NIL NIL) (DEFSYSFUN 'SIMPLE-VECTOR-P "Lsimple_vector_p" '(T) 'T NIL T) (DEFSYSFUN 'CHAR-BITS "Lchar_bits" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'COPY-TREE "Lcopy_tree" '(T) 'T NIL NIL) (DEFSYSFUN 'GCD "Lgcd" '(*) 'T NIL NIL) (DEFSYSFUN 'BYE "Lby" 'NIL 'T NIL NIL) ;(DEFSYSFUN 'QUIT "Lquit" 'NIL 'T NIL NIL) ;(DEFSYSFUN 'EXIT "Lexit" 'NIL 'T NIL NIL) (DEFSYSFUN 'GET "Lget" '(T T *) 'T NIL NIL) (DEFSYSFUN 'MOD "Lmod" '(T T) 'T NIL NIL) (DEFSYSFUN 'DIGIT-CHAR "Ldigit_char" '(T *) 'CHARACTER NIL NIL) (DEFSYSFUN 'STRING-LEFT-TRIM "Lstring_left_trim" '(T T) 'STRING NIL NIL) (DEFSYSFUN 'WRITE-LINE "Lwrite_line" '(T *) 'T NIL NIL) (DEFSYSFUN 'EVAL "Leval" '(T) 'T NIL NIL) (DEFSYSFUN 'ATOM "Latom" '(T) 'T NIL T) (DEFSYSFUN 'CDDAR "Lcddar" '(T) 'T NIL NIL) (DEFSYSFUN 'CDADR "Lcdadr" '(T) 'T NIL NIL) (DEFSYSFUN 'CADDR "Lcaddr" '(T) 'T NIL NIL) (DEFSYSFUN 'FMAKUNBOUND "Lfmakunbound" '(T) 'T NIL NIL) (DEFSYSFUN 'SLEEP "Lsleep" '(T) 'T NIL NIL) (DEFSYSFUN 'PACKAGE-NAME "Lpackage_name" '(T) 'T NIL NIL) ;(DEFSYSFUN 'FIND-PACKAGE "Lfind_package" '(T) 'T NIL NIL) (DEFSYSFUN 'ASSOC "Lassoc" '(T T *) 'T NIL NIL) (DEFSYSFUN 'SET-CHAR-BIT "Lset_char_bit" '(T T T) 'CHARACTER NIL NIL) (DEFSYSFUN 'FLOOR "Lfloor" '(T *) '(VALUES T T) NIL NIL) (DEFSYSFUN 'WRITE "Lwrite" '(T *) 'T NIL NIL) (DEFSYSFUN 'PLUSP "Lplusp" '(T) 'T NIL T) (DEFSYSFUN 'FLOAT-DIGITS "Lfloat_digits" '(T) 'FIXNUM NIL NIL) (DEFSYSFUN 'READ-DELIMITED-LIST "Lread_delimited_list" '(T *) 'T NIL NIL) (DEFSYSFUN 'APPEND "Lappend" '(*) 'T NIL NIL) (DEFSYSFUN 'MEMBER "Lmember" '(T T *) 'T NIL NIL) (DEFSYSFUN 'STRING-LESSP "Lstring_lessp" '(T T *) 'T NIL NIL) (DEFSYSFUN 'RANDOM "Lrandom" '(T *) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::SPECIALP "siLspecialp" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::OUTPUT-STREAM-STRING "siLoutput_stream_string" '(T) 'T NIL NIL) ;#-clcs (DEFSYSFUN 'SYSTEM::ERROR-SET "siLerror_set" '(T) '* NIL NIL) (DEFSYSFUN 'SYSTEM::STRUCTUREP "siLstructurep" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::COPY-STREAM "siLcopy_stream" '(T T) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::INIT-SYSTEM "siLinit_system" 'NIL 'T NIL NIL) (DEFSYSFUN 'SYSTEM::STRING-TO-OBJECT "siLstring_to_object" '(T) 'T NIL NIL) (DEFSYSFUN 'SYSTEM::RESET-STACK-LIMITS "siLreset_stack_limits" 'NIL 'T NIL NIL) (DEFSYSFUN 'SYSTEM::DISPLACED-ARRAY-P "siLdisplaced_array_p" '(T) 'T NIL T) (DEFSYSFUN 'SYSTEM::RPLACA-NTHCDR "siLrplaca_nthcdr" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::LIST-NTH "siLlist_nth" NIL T NIL NIL) ;(DEFSYSFUN 'SYSTEM::MAKE-PURE-ARRAY "siLmake_pure_array" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::MAKE-VECTOR "siLmake_vector" NIL 'VECTOR NIL NIL) ;(DEFSYSFUN 'SYSTEM::ARRAY-DISPLACEMENT "siLarray_displacement" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::ASET "siLaset" '(ARRAY *) NIL NIL NIL) (DEFSYSFUN 'SYSTEM::SVSET "siLsvset" '(SIMPLE-VECTOR FIXNUM T) T NIL NIL) (DEFSYSFUN 'SYSTEM::FILL-POINTER-SET "siLfill_pointer_set" '(VECTOR FIXNUM) 'FIXNUM NIL NIL) (DEFSYSFUN 'SYSTEM::REPLACE-ARRAY "siLreplace_array" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::FSET "siLfset" '(SYMBOL T) NIL NIL NIL) ;(DEFSYSFUN 'SYSTEM::HASH-SET "siLhash_set" NIL T NIL NIL) (DEFSYSFUN 'BOOLE3 "Lboole" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::PACKAGE-INTERNAL "siLpackage_internal" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::PACKAGE-EXTERNAL "siLpackage_external" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::ELT-SET "siLelt_set" '(SEQUENCE FIXNUM T) T NIL NIL) (DEFSYSFUN 'SYSTEM::CHAR-SET "siLchar_set" '(STRING FIXNUM CHARACTER) 'CHARACTER NIL NIL) (DEFSYSFUN 'SYSTEM::MAKE-STRUCTURE "siLmake_structure" NIL T NIL NIL) (DEFSYSFUN 'SYSTEM::STRUCTURE-NAME "siLstructure_name" '(T) 'SYMBOL NIL NIL) ;; (DEFSYSFUN 'SYSTEM::STRUCTURE-REF "siLstructure_ref" '(T T FIXNUM) T NIL ;; NIL) ;; (DEFSYSFUN 'SYSTEM::STRUCTURE-SET "siLstructure_set" '(T T FIXNUM T) T ;; NIL NIL) (DEFSYSFUN 'SYSTEM::PUT-F "siLput_f" NIL '(T T) NIL NIL) (DEFSYSFUN 'SYSTEM::REM-F "siLrem_f" NIL '(T T) NIL NIL) (DEFSYSFUN 'SYSTEM::SET-SYMBOL-PLIST "siLset_symbol_plist" '(SYMBOL T) T NIL NIL) (DEFSYSFUN 'SI::BIT-ARRAY-OP "siLbit_array_op" NIL T NIL NIL) (dolist (l '(eq eql equal equalp ldb-test logtest)) (setf (get l 'predicate) t)) gcl-2.6.14/cmpnew/gcl_cmptest.lsp0000755000175000017500000002010414360276512015310 0ustar cammcamm;;; CMPTEST Functions for compiler test. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defun self-compile () (with-open-file (log "lsplog" :direction :output) (let ((*standard-output* (make-broadcast-stream *standard-output* log))) ; (self-compile2 "cmpbind") ; (self-compile2 "cmpblock") ; (self-compile2 "cmpcall") ; (self-compile2 "cmpcatch") (self-compile2 "cmpenv") ; (self-compile2 "cmpeval") ; (self-compile2 "cmpflet") ; (self-compile2 "cmpfun") ; (self-compile2 "cmpif") ; (self-compile2 "cmpinline") (self-compile2 "cmplabel") ; (self-compile2 "cmplam") ; (self-compile2 "cmplet") ; (self-compile2 "cmploc") ; (self-compile2 "cmpmap") ; (self-compile2 "cmpmulti") ; (self-compile2 "cmpspecial") ; (self-compile2 "cmptag") ; (self-compile2 "cmptop") ; (self-compile2 "cmptype") (self-compile2 "cmputil") ; (self-compile2 "cmpvar") ; (self-compile2 "cmpvs") ; (self-compile2 "cmpwt") )) t) (defun setup () ; (allocate 'cons 800) ; (allocate 'string 256) ; (allocate 'structure 32) ; (allocate-relocatable-pages 128) ; (load ":udd:common:cmpnew:cmpinline.lsp") (load ":udd:common:cmpnew:cmputil.lsp") ; (load ":udd:common:cmpnew:cmptype.lsp") ; (load ":udd:common:cmpnew:cmpbind.lsp") ; (load ":udd:common:cmpnew:cmpblock.lsp") (load ":udd:common:cmpnew:cmpcall.lsp") ; (load ":udd:common:cmpnew:cmpcatch.lsp") ; (load ":udd:common:cmpnew:cmpenv.lsp") ; (load ":udd:common:cmpnew:cmpeval.lsp") (load ":udd:common:cmpnew:cmpflet.lsp") ; (load ":udd:common:cmpnew:cmpfun.lsp") ; (load ":udd:common:cmpnew:cmpif.lsp") (load ":udd:common:cmpnew:cmplabel.lsp") ; (load ":udd:common:cmpnew:cmplam.lsp") ; (load ":udd:common:cmpnew:cmplet.lsp") (load ":udd:common:cmpnew:cmploc.lsp") ; (load ":udd:common:cmpnew:cmpmain.lsp") ; (load ":udd:common:cmpnew:cmpmap.lsp") ; (load ":udd:common:cmpnew:cmpmulti.lsp") ; (load ":udd:common:cmpnew:cmpspecial.lsp") ; (load ":udd:common:cmpnew:cmptag.lsp") (load ":udd:common:cmpnew:cmptop.lsp") ; (load ":udd:common:cmpnew:cmpvar.lsp") ; (load ":udd:common:cmpnew:cmpvs.lsp") ; (load ":udd:common:cmpnew:cmpwt.lsp") ; (load ":udd:common:cmpnew:lfun_list") ; (load ":udd:common:cmpnew:cmpopt.lsp") ) (defun cli () (process ":cli.pr")) (defun load-fasl () (load "cmpinline") (load "cmputil") (load "cmpbind") (load "cmpblock") (load "cmpcall") (load "cmpcatch") (load "cmpenv") (load "cmpeval") (load "cmpflet") (load "cmpfun") (load "cmpif") (load "cmplabel") (load "cmplam") (load "cmplet") (load "cmploc") (load "cmpmap") (load "cmpmulti") (load "cmpspecial") (load "cmptag") (load "cmptop") (load "cmptype") (load "cmpvar") (load "cmpvs") (load "cmpwt") (load "cmpmain.lsp") (load "lfun_list.lsp") (load "cmpopt.lsp") ) (setq *macroexpand-hook* 'funcall) (defun self-compile1 (file) (prin1 file) (terpri) (compile-file1 file :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)) (defun self-compile2 (file) (prin1 file) (terpri) (compile-file1 file :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t) (prin1 (load file)) (terpri)) (defvar *previous-form* nil) (defun cmp (form) (setq *previous-form* form) (again)) (defun again () (init-env) (print *previous-form*) (terpri) (setq *compiler-output1* *standard-output*) (setq *compiler-output2* *standard-output*) (setq *compiler-output-data* *standard-output*) (let ((prev (get-dispatch-macro-character #\# #\,))) (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler) (unwind-protect (t1expr *previous-form*) (set-dispatch-macro-character #\# #\, prev))) (catch *cmperr-tag* (ctop-write "test")) t) ;(defun make-cmpmain-for-unix () ; (print "unixmain") ; (format t "~&The old value of *FEATURES* is ~s." *features*) ; (let ((*features* '(unix common kcl))) ; (format t "~&The new value of *FEATURES* is ~s." *features*) ; (init-env) ; (compile-file1 "cmpmain.lsp" ; :output-file "unixmain" ; :c-file t ; :h-file t ; :data-file t ; :system-p t ; )) ; (format t "~&The resumed value of *FEATURES* is ~s." *features*) ; ) (defun compiler-make-ufun () (make-ufun '( "cmpbind.lsp" "cmpblock.lsp" "cmpcall.lsp" "cmpcatch.lsp" "cmpenv.lsp" "cmpeval.lsp" "cmpflet.lsp" "cmpfun.lsp" "cmpif.lsp" "cmpinline.lsp" "cmplabel.lsp" "cmplam.lsp" "cmplet.lsp" "cmploc.lsp" "cmpmain.lsp" "cmpmap.lsp" "cmpmulti.lsp" "cmpspecial.lsp" "cmptag.lsp" "cmptop.lsp" "cmptype.lsp" "cmputil.lsp" "cmpvar.lsp" "cmpvs.lsp" "cmpwt.lsp" )) t) (defun remrem () (do-symbols (x (find-package 'lisp)) (remprop x 'inline-always) (remprop x 'inline-safe) (remprop x 'inline-unsafe)) (do-symbols (x (find-package 'system)) (remprop x 'inline-always) (remprop x 'inline-safe) (remprop x 'inline-unsafe))) (defun ckck () (do-symbols (x (find-package 'lisp)) (when (or (get x 'inline-always) (get x 'inline-safe) (get x 'inline-unsafe)) (print x))) (do-symbols (x (find-package 'si)) (when (or (get x 'inline-always) (get x 'inline-safe) (get x 'inline-unsafe)) (print x)))) (defun make-cmpopt (&aux (eof (cons nil nil))) (with-open-file (in "cmpopt.db") (with-open-file (out "cmpopt.lsp" :direction :output) (print '(in-package 'compiler) out) (terpri out) (terpri out) (do ((x (read in nil eof) (read in nil eof))) ((eq x eof)) (apply #'(lambda (property return-type side-effectp new-object-p name arg-types body) (when (stringp body) (do ((i 0 (1+ i)) (l nil) (l1 nil)) ((>= i (length body)) (when l1 (setq body (concatenate 'string "@" (reverse l1) ";" body)))) (when (char= (aref body i) #\#) (incf i) (cond ((member (aref body i) l) (pushnew (aref body i) l1)) (t (push (aref body i) l)))))) (print `(push '(,arg-types ,return-type ,side-effectp ,new-object-p ,body) (get ',name ',property)) out)) (cdr x))) (terpri out)))) gcl-2.6.14/cmpnew/gcl_cmplet.lsp0000755000175000017500000003114514360276512015124 0ustar cammcamm;;; CMPLET Let and Let*. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (eval-when (compile) (or (fboundp 'write-block-open) (load "cmplet.lsp"))) (si:putprop 'let 'c1let 'c1special) (si:putprop 'let 'c2let 'c2) (si:putprop 'let* 'c1let* 'c1special) (si:putprop 'let* 'c2let* 'c2) (defun c1let (args &aux (info (make-info))(setjmps *setjmps*) (forms nil) (vars nil) (vnames nil) ss is ts body other-decls (*vars* *vars*)) (when (endp args) (too-few-args 'let 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (c1add-globals ss) (dolist** (x (car args)) (cond ((symbolp x) (let ((v (c1make-var x ss is ts))) (push x vnames) (push v vars) (push (default-init (var-type v)) forms))) (t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) "The variable binding ~s is illegal." x) (let ((v (c1make-var (car x) ss is ts))) (push (car x) vnames) (push v vars) (push (if (endp (cdr x)) (default-init (var-type v)) (and-form-type (var-type v) (c1expr* (cadr x) info) (cadr x))) forms))))) (setq *vars* (append vars *vars*)) ; (dolist* (v (reverse vars)) (push v *vars*)) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (dolist** (var vars) (check-vref var)) (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) (list 'let info (nreverse vars) (nreverse forms) body) ) (defun c2let (vars forms body &aux (block-p nil) (bindings nil) initials (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (declare (object block-p)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) ((endp vl)) (declare (object vl fl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (declare (object form var)) (cond (kind (setf (var-kind var) kind) (setf (var-loc var) (next-cvar))) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (wfs-error))) (t (setf (var-ref var) (vs-push)))) (case (var-kind var) ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) (push (list 'c2expr* (list 'var var nil) form) initials)) (otherwise (case (car form) (LOCATION (if (can-be-replaced var body) (progn (setf (var-kind var) 'REPLACED) (setf (var-loc var) (caddr form))) (push (list var (caddr form)) bindings))) (VAR (let ((var1 (caaddr form))) (declare (object var1)) (cond ((or (args-info-changed-vars var1 (cdr fl)) (and (member (var-kind var1) '(SPECIAL GLOBAL)) (member (var-name var1) prev-ss))) (push (list 'c2expr* (cond ((eq (var-kind var) 'object) (list 'var var nil)) ((eq (var-kind var) 'down) ;(push (list var) bindings) (list 'down (var-loc var))) (t(push (list var) bindings) (list 'vs (var-ref var)))) form)initials)) ((and (can-be-replaced var body) (member (var-kind var1) '(LEXICAL REPLACED OBJECT)) (null (var-ref-ccb var1)) (not (is-changed var1 (cadr body)))) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (case (var-kind var1) (LEXICAL (list 'vs (var-ref var1))) (REPLACED (var-loc var1)) (OBJECT (list 'cvar (var-loc var1))) (otherwise (baboon))))) (t (push (list var (list 'var var1 (cadr (caddr form)))) bindings))))) (t (push (list 'c2expr* (cond ((eq (var-kind var) 'object) (list 'var var nil)) ((eq (var-kind var) 'down) ;(push (list var) bindings) (list 'down (var-loc var))) (t(push (list var) bindings) (list 'vs (var-ref var)))) form) initials)) ))) (when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) )) (setq block-p (write-block-open vars)) (dolist* (binding (nreverse initials)) (let ((*value-to-go* (second binding))) (c2expr* (third binding)))) (dolist* (binding (nreverse bindings)) (if (cdr binding) (c2bind-loc (car binding) (cadr binding)) (c2bind (car binding)))) (c2expr body) (when block-p (wt "}")) ) (defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) (setjmps *setjmps*) ss is ts body other-decls (info (make-info)) (*vars* *vars*)) (when (endp args) (too-few-args 'let* 1 0)) (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) (c1add-globals ss) (dolist** (x (car args)) (cond ((symbolp x) (let ((v (c1make-var x ss is ts))) (push x vnames) (push (default-init (var-type v)) forms) (push v vars) (push v *vars*))) ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) (cmperr "The variable binding ~s is illegal." x)) (t (let ((v (c1make-var (car x) ss is ts))) (push (car x) vnames) (push (if (endp (cdr x)) (default-init (var-type v)) (and-form-type (var-type v) (c1expr* (cadr x) info) (cadr x))) forms) (push v vars) (push v *vars*))))) (check-vdecl vnames ts is) (setq body (c1decl-body other-decls body)) (add-info info (cadr body)) (setf (info-type info) (info-type (cadr body))) (dolist** (var vars) (check-vref var)) (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) (list 'let* info (nreverse vars) (nreverse forms) body) ) (defun c2let* (vars forms body &aux (block-p nil) (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (declare (object block-p)) (do ((vl vars (cdr vl)) (fl forms (cdr fl))) ((endp vl)) (declare (object vl fl)) (let* ((form (car fl)) (var (car vl)) (kind (c2var-kind var))) (declare (object form var)) (cond (kind (setf (var-kind var) kind) (setf (var-loc var) (next-cvar)))) (if (member (var-kind var) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) nil (case (car form) (LOCATION (cond ((can-be-replaced* var body (cdr fl)) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (caddr form))) ((eq (var-kind var) 'object)) ((eq (var-kind var) 'down) (or (si::fixnump (var-loc var)) (baboon))) (t (setf (var-ref var) (vs-push)) ))) (VAR (let ((var1 (caaddr form))) (declare (object var1)) (cond ((and (can-be-replaced* var body (cdr fl)) (member (var-kind var1) '(LEXICAL REPLACED OBJECT)) (null (var-ref-ccb var1)) (not (args-info-changed-vars var1 (cdr fl))) (not (is-changed var1 (cadr body)))) (setf (var-kind var) 'REPLACED) (setf (var-loc var) (case (var-kind var1) (LEXICAL (list 'vs (var-ref var1))) (REPLACED (var-loc var1)) (OBJECT (list 'cvar (var-loc var1))) (t (baboon))))) ((eq (var-kind var)'object)) (t (setf (var-ref var) (vs-push)) ))) ) ; ((eq (var-kind var) 'object)) (t (unless (eq (var-kind var) 'object) (setf (var-ref var) (vs-push))) ))) )) (setq block-p (write-block-open vars)) (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (var nil) (form nil)) ((null vl)) (setq var (car vl))(setq form (car fl)) ; (print (list (var-kind var) (car form))) (case (var-kind var) ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER) (let ((*value-to-go* (list 'var var nil))) (c2expr* form))) (REPLACED ) (t (case (car form) (LOCATION (c2bind-loc var (caddr form))) (VAR (c2bind-loc var (list 'var (caaddr form) (cadr (caddr form))))) (t (c2bind-init var form)))))) (c2expr body) (when block-p (wt "}")) ) (defun can-be-replaced (var body) (and (or (eq (var-kind var) 'LEXICAL) (and (eq (var-kind var) 'object) (< (the fixnum (var-register var)) (the fixnum *register-min*)))) (null (var-ref-ccb var)) (not (eq (var-loc var) 'clb)) (not (is-changed var (cadr body))))) (defun can-be-replaced* (var body forms) (and (can-be-replaced var body) (dolist** (form forms t) (when (is-changed var (cadr form)) (return nil))) )) (defun write-block-open (vars) (let ( block-p) (dolist** (var vars) (let ((kind (var-kind var))) (declare (object kind)) (when (member kind '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER)) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))) block-p )) ;; ---------- stack-let for consing on stack --------- ;; Usage: (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7) ;; where foo must not keep a copy of `a', since the cons will be formed ;; on the c stack. (setf (get 'stack-let 'c1special) 'c1stack-let) (defmacro stack-let (&rest x) (cons `let x)) (defun c1stack-let (args &aux npairs nums) (let ((pairs (car args)) ) (dolist (v pairs) (push (cond ((atom v) v) ((let ((var (car v)) (val (second v))) (and (consp val) (or (eq (car val) 'cons) (and (eq (car val) 'list) (null (cddr val)) (setq val `(cons ,(second val) nil)))) (progn (push (next-cvar) nums) `(,var (stack-cons ,(car nums) ,@ (cdr val))))))) (t (cmpwarn "Stack let = regular let for ~a ~a" v (cdr args)) v)) npairs)) (let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args)))))) (list 'stack-let (second result) nums result)))) (setf (get 'stack-let 'c2) 'c2stack-let) (defun c2stack-let (nums form) (let ((n (next-cvar))) (wt-nl "{Cons_Macro" n ";") (c2expr form) (wt "}") (wt-h "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums) ))) (push '((fixnum t t) t #.(flags) "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") (get 'stack-cons 'inline-always)) ;; ---------- end stack-let for consing on stack --------- gcl-2.6.14/cmpnew/gcl_make_ufun.lsp0000755000175000017500000000626514360276512015617 0ustar cammcamm;;; MAKE_UFUN Makes Ufun list for user-defined functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar gazonk (make-package 'symbol-table :use nil)) (defvar eof (cons nil nil)) (defvar *Ufun-out*) (defvar *str* (make-array 128 :element-type 'character :fill-pointer 0)) (defun make-Ufun (in-files &key (out-file "Ufun_list.lsp")) (with-open-file (*Ufun-out* out-file :direction :output) (print '(in-package "COMPILER") *Ufun-out*) (dolist (file in-files) (with-open-file (in (merge-pathnames file #".lsp")) (loop (when (eq (setq form (read in nil eof)) eof) (return)) (do-form form)))))) (defun do-form (form) (when (consp form) (case (car form) (defun (let ((*package* (find-package 'compiler))) (print `(si:putprop ',(cadr form) ,(get-cname (cadr form)) 'Ufun) *Ufun-out*)) (eval form)) (progn (mapc #'do-form (cdr form))) (eval-when (if (member 'load (cadr form)) (mapc #'do-form (cddr form)) (if (member 'compile (cadr form)) (mapc #'eval (cddr form))))) (t (if (macro-function (car form)) (do-form (macroexpand-1 form)) (eval form)))))) (defun get-cname (symbol &aux (name (symbol-name symbol))) (setf (fill-pointer *str*) 0) (vector-push #\U *str*) (dotimes (n (length name)) (let ((char (schar name n))) (cond ((alphanumericp char) (vector-push (char-downcase char) *str*)) ((char= char #\-) (vector-push #\_ *str*)) ((char= char #\*) (vector-push #\A *str*)) ))) (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table) (unless flag ;(setq foo (intern (copy-seq *str*) 'symbol-table)) (setq foo (intern *str* 'symbol-table)) ;(set foo nil) (return-from get-cname *str*)) (gensym *str*) (gensym 0) (loop (setq name (symbol-name (gensym))) (multiple-value-bind (foo flag1) (intern name 'symbol-table) (unless flag1 ;(set foo nil) (return-from get-cname name))))) ) gcl-2.6.14/cmpnew/gcl_cmpcatch.lsp0000755000175000017500000001017314360276512015420 0ustar cammcamm;;; CMPCATCH Catch, Unwind-protect, and Throw. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'catch 'c1catch 'c1special) (si:putprop 'catch 'c2catch 'c2) (si:putprop 'unwind-protect 'c1unwind-protect 'c1special) (si:putprop 'unwind-protect 'c2unwind-protect 'c2) (si:putprop 'throw 'c1throw 'c1special) (si:putprop 'throw 'c2throw 'c2) (defun c1catch (args &aux (info (make-info :sp-change t)) tag) (incf *setjmps*) (when (endp args) (too-few-args 'catch 1 0)) (setq tag (c1expr (car args))) (add-info info (cadr tag)) (setq args (c1progn (cdr args))) (add-info info (cadr args)) (list 'catch info tag args)) (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc) (defun c2catch (tag body &aux (*vs* *vs*)) (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag)) (wt-nl "if(nlj_active)") (wt-nl "{nlj_active=FALSE;frs_pop();") (unwind-exit 'fun-val 'jump) (wt "}") (wt-nl "else{") (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) (wt "}") ) (defun set-push-catch-frame (loc) (wt-nl "frs_push(FRS_CATCH," loc ");")) (defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form) (incf *setjmps*) (when (endp args) (too-few-args 'unwind-protect 1 0)) (setq form (let ((*blocks* (cons 'lb *blocks*)) (*tags* (cons 'lb *tags*)) (*vars* (cons 'lb *vars*))) (c1expr (car args)))) (add-info info (cadr form)) (setq args (c1progn (cdr args))) (add-info info (cadr args)) (list 'unwind-protect info form args) ) (defun c2unwind-protect (form body &aux (*vs* *vs*) (loc (list 'vs (vs-push))) top-data) ;;; exchanged following two lines to eliminate setjmp clobbering warning (wt-nl "frs_push(FRS_PROTECT,Cnil);") (wt-nl "{object tag=Cnil;frame_ptr fr=NULL;object p;bool active;") (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}") (wt-nl "else{") (let ((*value-to-go* 'top) *top-data* ) (c2expr* form) (setq top-data *top-data*)) (wt-nl "active=FALSE;}") (wt-nl loc "=Cnil;") (wt-nl "while(vs_base= 'fixnum type) 'FIXNUM) ; ((type>= 'integer type) 'INTEGER) ((type>= 'CHARACTER type) 'CHARACTER) ((type>= 'long-float type) 'LONG-FLOAT) ((type>= 'short-float type) 'SHORT-FLOAT) ((and (boundp '*c-gc*) *c-gc* 'OBJECT)) (t nil)))) nil) ) (defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value)) (defun c2location (loc) (unwind-exit loc nil 'single-value)) (defun check-downward (info &aux no-down ) (dolist (v *local-functions*) (cond ((eq (car v) 'function) (setq no-down t) (dolist (w *local-functions*) (cond ((eq (car w) 'downward-function) (setf (car w) 'function)))) (return nil)))) (setq *local-functions* nil) (cond (no-down (do-referred (var info) (if (eq (var-kind var) 'down) (setf (var-kind var) 'lexical)))))) (defun assign-down-vars (info cfun inside &aux (ind 0) ) (do-referred (var info) (cond ((eq (var-kind var) 'down) ;;don't do twice since this list may have duplicates. (cond ((integerp (var-loc var) ) ;(or (integerp (var-ref var)) (print var)) (setq ind (max ind (1+ (var-loc var)))) (setf (var-ref var) (var-loc var)) ;delete later ) ;((integerp (var-loc var)) (break "bil")) (t (setf (var-ref var) ind) ;delete later (setf (var-loc var) ind) (setf ind (+ ind 1))))))) (cond ((> ind 0) ;;(wt-nl "object Dbase[" ind "];") (cond ((eq inside 't3defun) (wt-nl "object base0[" ind "];"))) ;DCnames gets defined at end whe (push 'dcnames *downward-closures*) (wt-nl "DCnames"cfun ""))) ind) (si::putprop 'down 'wt-down 'wt-loc) (defun wt-down (n) (or (si::fixnump n) (wfs-error)) (wt "base0[" n "]")) (defun wt-var (var ccb) (case (var-kind var) (LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var))) ((var-ref-ccb var) (wt-vs* (var-ref var))) ((and (eq t (var-ref var)) (si:fixnump (var-loc var)) *c-gc* (eq t (var-type var))) (setf (var-kind var) 'object) (wt-var var ccb)) (t (wt-vs (var-ref var))))) (SPECIAL (wt "(" (vv-str (var-loc var)) "->s.s_dbind)")) (REPLACED (wt (var-loc var))) (DOWN (wt-down (var-loc var))) (GLOBAL (if *safe-compile* (wt "symbol_value(" (vv-str (var-loc var)) ")") (wt "(" (vv-str (var-loc var)) "->s.s_dbind)"))) (t (case (var-kind var) (FIXNUM (when (zerop *space*) (wt "CMP")) (wt "make_fixnum")) (INTEGER (wt "make_integer")) (CHARACTER (wt "code_char")) (LONG-FLOAT (wt "make_longfloat")) (SHORT-FLOAT (wt "make_shortfloat")) (OBJECT) (t (baboon))) (wt "(V" (var-loc var) ")")) )) ;; When setting bignums across setjmps, cannot use alloca as longjmp ;; restores the C stack. FIXME -- only need malloc when reading variable ;; outside frame. CM 20031201 (defmacro bignum-expansion-storage () `(if (and (boundp '*unwind-exit*) (member 'frame *unwind-exit*)) "gcl_gmp_alloc" "alloca")) (defun set-var (loc var ccb) (unless (and (consp loc) (eq (car loc) 'var) (eq (cadr loc) var) (eq (caddr loc) ccb)) (case (var-kind var) (LEXICAL (wt-nl) (cond (ccb (wt-ccb-vs (var-ref-ccb var))) ((var-ref-ccb var) (wt-vs* (var-ref var))) (t (wt-vs (var-ref var)))) (wt "= " loc ";")) (SPECIAL (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";")) (GLOBAL (if *safe-compile* (wt-nl "setq(" (vv-str (var-loc var)) "," loc ");") (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";"))) (DOWN (wt-nl "") (wt-down (var-loc var)) (wt "=" loc ";")) (INTEGER (let ((first (and (consp loc) (car loc))) (n (var-loc var))) (case first (inline-fixnum (wt-nl "ISETQ_FIX(V"n",V"n"alloc,") (wt-inline-loc (caddr loc) (cadddr loc))) (fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc))) (var (case (var-kind (cadr loc)) (integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc)) "," (bignum-expansion-storage))) (fixnum (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr loc)))) (otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc "," (bignum-expansion-storage))))) (vs (wt "SETQ_IO(V"n",V"n"alloc,"loc "," (bignum-expansion-storage))) (otherwise (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma '(nil integer)) (wt-nl "SETQ_II(V"n",V" n"alloc,") (wt-integer-loc loc (cons 'set-var var)) (wt "," (bignum-expansion-storage) ");") (close-inline-blocks)) (return-from set-var nil)) ) (wt ");"))) (t (wt-nl "V" (var-loc var) "= ") (case (var-kind var) (FIXNUM (wt-fixnum-loc loc)) (CHARACTER (wt-character-loc loc)) (LONG-FLOAT (wt-long-float-loc loc)) (SHORT-FLOAT (wt-short-float-loc loc)) (OBJECT (wt-loc loc)) (t (baboon))) (wt ";")) ))) (defun sch-global (name) (dolist* (var *undefined-vars* nil) (when (eq (var-name var) name) (return-from sch-global var)))) (defun c1add-globals (globals) (dolist** (name globals) (push (make-var :name name :kind 'GLOBAL :loc (add-symbol name) :type (let ((x (get name 'cmp-type))) (if x x t)) ) *vars*)) ) (defun c1setq (args) (cond ((endp args) (c1nil)) ((endp (cdr args)) (too-few-args 'setq 2 1)) ((endp (cddr args)) (c1setq1 (car args) (cadr args))) (t (do ((pairs args (cddr pairs)) (forms nil)) ((endp pairs) (c1expr (cons 'progn (nreverse forms)))) (declare (object pairs)) (cmpck (endp (cdr pairs)) "No form was given for the value of ~s." (car pairs)) (push (list 'setq (car pairs) (cadr pairs)) forms) ))) ) (defun c1setq1 (name form &aux (info (make-info)) type form1 name1) (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being assigned a value." name) (setq name1 (c1vref name)) (push-changed (car name1) info) (setq form1 (c1expr form)) (add-info info (cadr form1)) (setq type (type-and (var-type (car name1)) (info-type (cadr form1)))) (when (null type) (cmpwarn "Type mismatches between ~s and ~s." name form)) (unless (eq type (info-type (cadr form1))) (let ((info1 (copy-info (cadr form1)))) (setf (info-type info1) type) (setq form1 (list* (car form1) info1 (cddr form1))))) (setf (info-type info) type) (list 'setq info name1 form1) ) (defun c2setq (vref form) (let ((*value-to-go* (cons 'var vref))) (c2expr* form)) (case (car form) (LOCATION (c2location (caddr form))) (otherwise (unwind-exit (cons 'var vref)))) ) (defun c1progv (args &aux symbols values (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'progv 2 (length args))) (setq symbols (c1expr* (car args) info)) (setq values (c1expr* (cadr args) info)) (list 'progv info symbols values (c1progn* (cddr args) info)) ) (defun c2progv (symbols values body &aux (cvar (next-cvar)) (*unwind-exit* *unwind-exit*)) (wt-nl "{object symbols,values;") (wt-nl "bds_ptr V" cvar "=bds_top;") (push cvar *unwind-exit*) (let ((*vs* *vs*)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* symbols) (wt-nl "symbols= " *value-to-go* ";")) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* values) (wt-nl "values= " *value-to-go* ";")) (wt-nl "while(!endp(symbols)){") (when *safe-compile* (wt-nl "if(type_of(MMcar(symbols))!=t_symbol)") (wt-nl "FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));")) (wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);") (wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));") (wt-nl "values=MMcdr(values);}") (wt-nl "symbols=MMcdr(symbols);}") ) (c2expr body) (wt "}") ) (defun c1psetq (args &aux (vrefs nil) (forms nil) (info (make-info :type '(member nil)))) (do ((l args (cddr l))) ((endp l)) (declare (object l)) (cmpck (not (symbolp (car l))) "The variable ~s is not a symbol." (car l)) (cmpck (constantp (car l)) "The constant ~s is being assigned a value." (car l)) (cmpck (endp (cdr l)) "No form was given for the value of ~s." (car l)) (let* ((vref (c1vref (car l))) (form (c1expr (cadr l))) (type (type-and (var-type (car vref)) (info-type (cadr form))))) (unless (equal type (info-type (cadr form))) (let ((info1 (copy-info (cadr form)))) (setf (info-type info1) type) (setq form (list* (car form) info1 (cddr form))))) (push vref vrefs) (push form forms) (push-changed (car vref) info) (add-info info (cadar forms))) ) (list 'psetq info (nreverse vrefs) (nreverse forms)) ) (defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0)) (dolist** (vref vrefs) (if (or (args-info-changed-vars (car vref) (cdr forms)) (args-info-referred-vars (car vref) (cdr forms))) (case (caar forms) (LOCATION (push (cons vref (caddar forms)) saves)) (otherwise (if (member (var-kind (car vref)) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)) (let* ((kind (var-kind (car vref))) (cvar (next-cvar)) (temp (list 'var (make-var :kind kind :loc cvar) nil))) (wt-nl "{" *volatile* (rep-type kind) "V" cvar ";") (incf blocks) (let ((*value-to-go* temp)) (c2expr* (car forms))) (push (cons vref temp) saves)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car forms)) (push (cons vref *value-to-go*) saves))))) (let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms)))) (pop forms)) (dolist** (save saves) (set-var (cdr save) (caar save) (cadar save))) (dotimes (i blocks) (wt "}")) (unwind-exit nil) ) (defun wt-var-decl (var) (cond ((var-p var) (let ((n (var-loc var))) (cond ((eq (var-kind var) 'integer)(wt "IDECL("))) (wt *volatile* (register var) (rep-type (var-kind var)) "V" n ) (if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)")) (wt ";"))) (t (wfs-error)))) gcl-2.6.14/cmpnew/gcl_cmpmap.lsp0000755000175000017500000002361314360276512015116 0ustar cammcamm;;; CMPMAP Map functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'mapcar 'c1mapcar 'c1) (si:putprop 'maplist 'c1maplist 'c1) (si:putprop 'mapcar 'c2mapcar 'c2) (si:putprop 'mapc 'c1mapc 'c1) (si:putprop 'mapl 'c1mapl 'c1) (si:putprop 'mapc 'c2mapc 'c2) (si:putprop 'mapcan 'c1mapcan 'c1) (si:putprop 'mapcon 'c1mapcon 'c1) (si:putprop 'mapcan 'c2mapcan 'c2) (defun c1mapcar (args) (c1map-functions 'mapcar t args)) (defun c1maplist (args) (c1map-functions 'mapcar nil args)) (defun c1mapc (args) (c1map-functions 'mapc t args)) (defun c1mapl (args) (c1map-functions 'mapc nil args)) (defun c1mapcan (args) (c1map-functions 'mapcan t args)) (defun c1mapcon (args) (c1map-functions 'mapcan nil args)) (defun c1map-functions (name car-p args &aux funob info) (when (or (endp args) (endp (cdr args))) (too-few-args 'map-function 2 (length args))) (setq funob (c1funob (car args))) (setq info (copy-info (cadr funob))) (list name info funob car-p (c1args (cdr args) info)) ) (defun c2mapcar (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) (value-loc (list 'VS (vs-push))) (handy (list 'CVAR (next-cvar))) (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (wt-nl "{object " handy ";") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") (wt-label label) (let* ((*value-to-go* (list 'CAR (cadr handy))) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (unwind-exit value-loc 'jump) (wt "}") (wt-nl handy "=MMcdr(" handy ")=MMcons(Cnil,Cnil);") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun c2mapc (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) value-loc (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (setq value-loc (car args)) (wt-nl "{") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-label label) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (unwind-exit value-loc 'jump) (wt "}") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun c2mapcan (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((label (next-label*)) (value-loc (list 'VS (vs-push))) (handy (list 'CVAR (next-cvar))) (handies (mapcar #'(lambda (x) (declare (ignore x)) (list 'CVAR (next-cvar))) args)) save ) (setq save (save-funob funob)) ; (setq args (inline-args args ; (make-list (length args) :initial-element t))) (setq args (push-changed-vars (inline-args args (make-list (length args) :initial-element t)) funob)) (wt-nl "{object " handy ";") (dolist** (loc handies) (wt-nl "object " loc "= " (car args) ";") (pop args)) (cond (*safe-compile* (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "if(" (car handies) "==Cnil") (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) (wt "){"))) (unwind-exit nil 'jump) (wt "}") (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") (wt-label label) (let* ((*value-to-go* (list 'cdr (cadr handy))) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*)) ) (c2funcall funob (if car-p (mapcar #'(lambda (loc) (list 'LOCATION *info* (list 'CAR (cadr loc)))) handies) (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) handies)) save) (wt-label *exit*)) (cond (*safe-compile* (wt-nl "{object cdr_" handy "=MMcdr(" handy ");while(!endp(cdr_" handy ")) {cdr_" handy "=MMcdr(cdr_" handy ");" handy "=MMcdr(" handy ");}}") (wt-nl (car handies) "=MMcdr(" (car handies) ");") (dolist** (loc (cdr handies)) (wt-nl loc "=MMcdr(" loc ");")) (wt-nl "if(endp(" (car handies) ")") (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) (wt "){")) (t (wt-nl "while(MMcdr(" handy ")!=Cnil)" handy "=MMcdr(" handy ");") (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") (dolist** (loc (cdr handies)) (wt "||(" loc "=MMcdr(" loc "))==Cnil")) (wt "){"))) (wt-nl value-loc "=" value-loc "->c.c_cdr;") (unwind-exit value-loc 'jump) (wt "}") (wt-nl) (wt-go label) (wt "}") (close-inline-blocks) ) ) (defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob))) (dolist (loc locs (reverse locs1)) (if (and (consp loc) (eq (car loc) 'VAR) (args-info-changed-vars (cadr loc) forms)) (let ((temp (list 'VS (vs-push)))) (wt-nl temp "= " loc ";") (push temp locs1)) (push loc locs1)))) gcl-2.6.14/cmpnew/gcl_cmpcall.lsp0000755000175000017500000005135114360276512015254 0ustar cammcamm;;; CMPCALL Function call. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar *ifuncall* nil) (eval-when (compile eval) (defmacro link-arg-p (x) `(let ((.u ,x)) (not (member .u '(character boolean long-float short-float) :test 'eq))))) (defun fast-link-proclaimed-type-p (fname &optional args) (and (symbolp fname) (and (< (the fixnum(length args)) 64) (or (and (get fname 'fixed-args) (listp args)) (and (get fname 'proclaimed-function) (link-arg-p (get fname 'proclaimed-return-type)) (dolist (v (get fname 'proclaimed-arg-types) t) (or (eq v '*)(link-arg-p v) (return nil)))))))) (si::putprop 'funcall 'c2funcall-aux 'wholec2) (si:putprop 'call-lambda 'c2call-lambda 'c2) (si:putprop 'call-global 'c2call-global 'c2) ;;Like macro-function except it searches the lexical environment, ;;to determine if the macro is shadowed by a function or a macro. (defun cmp-macro-function (name &aux fd) (cond ((setq fd (c1local-fun name)) (if (eq (car fd) 'call-local) nil fd)) (t (macro-function name)))) (defun c1funob (fun &aux fd) ;;; NARGS is the number of arguments. If the number is unknown, (e.g. ;;; in case of APPLY), then NARGS should be NIL. (cond ((and (consp fun) (symbolp (car fun)) (cmp-macro-function (car fun))) (setq fun (cmp-macroexpand fun)))) (or (and (consp fun) (or (and (eq (car fun) 'quote) (not (endp (cdr fun))) (endp (cddr fun)) (or (and (consp (cadr fun)) (not (endp (cdadr fun))) (eq (caadr fun) 'lambda) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)) (let ((lambda-expr (c1lambda-expr (cdadr fun)))) (list 'call-lambda (cadr lambda-expr) lambda-expr)))) (and (symbolp (cadr fun)) (or (and (setq fd (c1local-fun (cadr fun))) (eq (car fd) 'call-local) fd) (list 'call-global (make-info :sp-change (null (get (cadr fun) 'no-sp-change))) (cadr fun))) ))) (and (eq (car fun) 'function) (not (endp (cdr fun))) (endp (cddr fun)) (or (and (consp (cadr fun)) (eq (caadr fun) 'lambda) (not (endp (cdadr fun))) (let ((lambda-expr (c1lambda-expr (cdadr fun)))) (list 'call-lambda (cadr lambda-expr) lambda-expr)) ) (and (symbolp (cadr fun)) (or (and (setq fd (c1local-fun (cadr fun))) (eq (car fd) 'call-local) fd) (list 'call-global (make-info :sp-change (null (get (cadr fun) 'no-sp-change))) (cadr fun))) ))))) (let ((x (c1expr fun)) (info (make-info :sp-change t))) (add-info info (cadr x)) (list 'ordinary info x)) )) (defun c2funcall-aux(form &aux (info (cadr form)) (funob (caddr form)) (args (cadddr form)) (loc (nth 4 form))) (c2funcall funob args loc info)) (defvar *use-sfuncall* t) (defvar *super-funcall* nil) (defun c2funcall (funob args &optional loc info) ;;; Usually, ARGS holds a list of forms, which are arguments to the ;;; function. If, however, the arguments are already pushed on the stack, ;;; ARGS should be set to the symbol ARGS-PUSHED. (case (car funob) (call-global (c2call-global (caddr funob) args loc t)) (call-local (c2call-local (cddr funob) args)) (call-lambda (c2call-lambda (caddr funob) args)) (ordinary ;;; An ordinary expression. In this case, if ;;; arguments are already pushed on the stack, then ;;; LOC cannot be NIL. Callers of C2FUNCALL must be ;;; responsible for maintaining this condition. (let ((*vs* *vs*) (form (caddr funob))) (declare (object form)) (cond ((and (listp args) (< (length args) 12) ;FIXME fcalln1 limitation *use-sfuncall* ;;Determine if only one value at most is required: (or (member *value-to-go* '(return-object trash)) (and (consp *value-to-go*) (member (car *value-to-go*) '(var cvar jump-false jump-true))) (and info (equal (info-type info) '(values t))) )) (c2funcall-sfun form args info) (return-from c2funcall nil))) (unless loc (unless (listp args) (baboon)) (cond ((eq (car form) 'LOCATION) (setq loc (caddr form))) ((and (eq (car form) 'VAR) (not (args-info-changed-vars (caaddr form) args))) (setq loc (cons 'VAR (caddr form)))) (t (setq loc (list 'vs (vs-push))) (let ((*value-to-go* loc)) (c2expr* (caddr funob)))))) (push-args args) (if *compiler-push-events* (wt-nl "super_funcall(" loc ");") (if *super-funcall* (funcall *super-funcall* loc) (wt-nl "super_funcall_no_event(" loc ");"))) (unwind-exit 'fun-val))) (otherwise (baboon)) )) (defun fcalln-inline (&rest args) (wt-nl "({object _f=" (car args) ";enum type _t=type_of(_f);") (wt-nl "_f = _t==t_symbol && _f->s.s_gfdef!=OBJNULL ? (_t=type_of(_f->s.s_gfdef),_f->s.s_gfdef) : _f;") (wt-nl "_t==t_sfun&&(_f->sfn.sfn_argd&0xff)== " (length (cdr args)) " ? _f->sfn.sfn_self : ") (wt-nl "(fcall.argd= " (length (cdr args)) ",_t==t_vfun&&_f->vfn.vfn_minargs<= " (length (cdr args)) "&&" (length (cdr args)) "<=_f->vfn.vfn_maxargs ? _f->vfn.vfn_self : ") (wt-nl "(fcall.fun=_f,fcalln));})") (wt-nl "(") (when (cdr args) (wt (cadr args)) (dolist (loc (cddr args)) (wt #\, loc))) (wt-nl ")")) (defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr))) (declare (object lambda-list)) (cond ((or (cadr lambda-list) ;;; Has optional? (caddr lambda-list) ;;; Has rest? (cadddr lambda-list) ;;; Has key? (not (listp args)) ;;; Args already pushed? ) (when (listp args) ;;; Args already pushed? (let ((*vs* *vs*) (base *vs*)) (push-args-lispcall args) (when (need-to-set-vs-pointers lambda-list) (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (base-used) ))) (c2lambda-expr lambda-list (caddr (cddr lambda-expr))) ) (t (let ((l-length (length (car lambda-list))) (a-length (length args))) (or (eql a-length l-length) (cmperr "Calling lambda with ~a args not ~a" a-length l-length))) (c2let (car lambda-list) args (caddr (cddr lambda-expr))))) ) (defun check-fname-args (fname args) (let ((a (get fname 'arg-types t))) (and (eq t a) (get fname 'si::structure-access) (setq a '(t))) (cond ((and (listp a) (listp args) (not (member '* a))) (or (eql (length a) (length args)) (cmpwarn "Wrong number of args for ~s: ~a instead of ~a." fname (length args) (length a))))))) (defun save-avma (fd) (when (and (not *restore-avma*) (setq *restore-avma* (or (member 'integer (car fd)) (eq (cadr fd) 'integer) (flag-p (caddr fd) is)))) (wt-nl "{ save_avma;") (inc-inline-blocks) (or (consp *inline-blocks*) (setq *inline-blocks* (cons *inline-blocks* 'restore-avma))))) (defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*)) ;this is now done in get-inline-info ; (and *Fast-link-compiling* (fast-link-proclaimed-type-p fname args) ; (add-fast-link fname t args)) (if (inline-possible fname) (cond ;;; Tail-recursive case. ((and (listp args) *do-tail-recursion* *tail-recursion-info* (eq (car *tail-recursion-info*) fname) (member *exit* '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT)) (tail-recursion-possible) (= (length args) (length (cdr *tail-recursion-info*)))) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2psetq (mapcar #'(lambda (v) (list v nil)) (cdr *tail-recursion-info*)) args) (wt-label *exit*)) (unwind-no-exit 'tail-recursion-mark) (wt-nl "goto TTL;") (cmpnote "Tail-recursive call of ~s was replaced by iteration." fname)) ;;; Open-codable function call. ((and (listp args) (null loc) (setq fd (get-inline-info fname args return-type))) (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma fd) (unwind-exit (get-inline-loc fd args) nil fname) (close-inline-blocks))) ;;; Call to a function whose C language function name is known. ((setq fd (or (get fname 'Lfun) (get fname 'Ufun))) (check-fname-args fname args) (push-args args) (wt-h "void " fd "();") (wt-nl fd "();") (unwind-exit 'fun-val nil fname) ) ( t; *Fast-link-compiling* (cond ((and (listp args) (< (the fixnum (length args)) 10) (or *ifuncall* (get fname 'ifuncall)) (progn (if (eq *value-to-go* 'top) (format t "~%Called with top:~a" fname)) t) (not (eq 'top *value-to-go*)) (null loc) ) (let ((*inline-blocks* 0)) (unwind-exit (get-inline-loc (inline-proc fname args) args) nil fname) (close-inline-blocks))) (t (push-args args) (let ((num (add-fast-link fname nil args))) (wt-nl "(void) (*Lnk" num ")(") (if (get fname 'proclaimed-closure) (wt "Lclptr" num)) (wt ");") (unwind-exit 'fun-val nil fname))))) ;;; Call to a function defined in the same file. ((setq fd (assoc fname *global-funs*)) (push-args args) (wt-nl (c-function-name "L" (cdr fd) fname) "();") (unwind-exit 'fun-val nil fname) ) ((eql fname 'funcall-c) (wt-funcall-c args)) ;;; Otherwise. (t (c2call-unknown-global fname args loc t))) (c2call-unknown-global fname args loc nil)) ) (defun add-fast-link (fname type args) (let (link link-info (n (add-object2 (add-symbol fname))) vararg) (cond (type ;;should do some args checking in that case too. (let* (link-string tem argtypes (leng (and (listp args) (length args)))) (setq argtypes (cond ((get fname 'proclaimed-function) (get fname 'proclaimed-arg-types)) ((setq tem (get fname ' fixed-args)) (cond ((si:fixnump tem) (or (equal leng tem) (cmpwarn "~a: Fixed args not fixed!" fname))) (t (setf (get fname 'fixed-args) leng))) (make-list leng :initial-element t)))) (and leng (or (eql leng (length argtypes)) (MEMBER '* ARGTYPES) (cmpwarn "~a called with ~a args, expected ~a " fname leng (length argtypes)))) (unless (cddr (setq link-info (car (member-if (lambda (x) (and (eq fname (car x)) (stringp (cadr x)))) *function-links*)))) (setq link-string (with-output-to-string (st) (format st "(*(LnkLI~d))(" n) (do ((com) (v argtypes (cdr v)) (i 0 (+ 1 i))) ((null v)) (cond ((eq (car v) '*) (setq vararg t) (princ (if (eq v argtypes) "#?" "#*") st)) (t (if com (princ "," st) (setq com t)) (format st "#~a" i)))) (princ ")" st) ) ) ; (print (list 'link-string link-string)) ; (format t "~{~a~#[~:;,~]~}" '(1 2 3 4)) ; 1,2,3,4 (if vararg (setq link #'(lambda ( &rest l) (wt "(VFUN_NARGS="(length l) ",") (wt-inline-loc link-string l) (wt ")")))) (push (list fname argtypes (or (get fname 'proclaimed-return-type) t) (flags side-effect-p allocates-new-storage) (or link link-string) 'link-call) *inline-functions*) (setq link-info (list fname (format nil "LI~d" n) (or (get fname 'proclaimed-return-type) t) argtypes))))) (t (check-fname-args fname args) (setq link-info (list fname n (if (get fname 'proclaimed-closure) 'proclaimed-closure) )))) (pushnew link-info *function-links* :test 'equal) n)) ;;make a function which will be called hopefully only once, ;;and will establish the link. (defun wt-function-link (x) (let ((name (first x)) (num (second x)) (type (third x)) (args (fourth x))) (cond ((null type) (wt-nl1 "static void LnkT" num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}")) ((eql type 'proclaimed-closure) (wt-nl1 "static void LnkT" num "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}")) (t ;;change later to include above. ;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr"))))) (wt-nl1 "static " (declaration-type (rep-type type)) " LnkT" num ) (cond ((or args (not (eq t type))) (let ((vararg (member '* args))) (wt "(object first,...){" (declaration-type (rep-type type)) "V1;" "va_list ap;va_start(ap,first);V1=call_" (if vararg "v" "") "proc_new(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num) (or vararg (wt "," (proclaimed-argd args type))) (wt ",first,ap);va_end(ap);return V1;}" ))) (t (wt "(){return call_proc0(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num ");}" )))) (t (error "unknown link type ~a" type))) (setq name (symbol-name name)) (if (find #\/ name) (setq name (remove #\/ name))) (wt " /* " name " */") )) ;;For funcalling when the argument is guaranteed to be a compiled-function. ;;For (funcall-c he 3 4), he being a compiled function. (not a symbol)! (defun wt-funcall-c (args) (let ((fun (car args)) (real-args (cdr args)) loc) (cond ((eql (car fun) 'var) (let ((fun-loc (cons (car fun) (third fun)))) (when *safe-compile* (wt-nl "(type_of(") (wt-loc fun-loc) (wt ")==t_cfun)||FEinvalid_function(") (wt-loc fun-loc)(wt ");")) (push-args real-args) (wt-nl "(") (wt-loc fun-loc))) (t (setq loc (list 'cvar (incf *next-cvar*))) (let ((*value-to-go* loc)) (wt-nl "{object V" (second loc) ";") (c2expr* (car args)) (push-args (cdr args)) (wt "(V" (second loc))))) (wt ")->cf.cf_self ();") (and loc (wt "}"))) (unwind-exit 'fun-val)) (defun inline-proc (fname args &aux (n (length args)) res (obj (add-object fname))) (format t "~%Using ifuncall: ~a" fname) (let ((result (case n ;(0 (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj))) (1 (list '(t) t (flags ans set) (format nil "ifuncall1(~a,(#0))" (vv-str obj)) 'ifuncall)) (2 (list '(t t) t (flags ans set) (format nil "ifuncall2(~a,(#0),(#1))" (vv-str obj)) 'ifuncall)) (t (list (make-list n :initial-element t) t (flags ans set) (format nil "ifuncall(~a,~a~{,#~a~})" (vv-str obj) n (dotimes (i n(nreverse res)) (push i res))) 'ifuncall))))) (push (cons fname result ) *inline-functions*) result )) (si:putprop 'simple-call 'wt-simple-call 'wt-loc) (defun wt-simple-call (cfun base n &optional (vv-index nil)) (wt "simple_" cfun "(") (when vv-index (wt (vv-str vv-index) ",")) (wt "base+" base "," n ")") (base-used)) ;;; Functions that use SAVE-FUNOB should reset *vs*. (defun save-funob (funob) (case (car funob) ((call-lambda call-quote-lambda call-local)) (call-global (unless (and (inline-possible (caddr funob)) (or (get (caddr funob) 'Lfun) (get (caddr funob) 'Ufun) (get (caddr funob) 'proclaimed-function) (assoc (caddr funob) *global-funs*))) (let ((temp (list 'vs (vs-push)))) (if *safe-compile* (wt-nl temp "=symbol_function(" (vv-str (add-symbol (caddr funob))) ");") (wt-nl temp "=" (vv-str (add-symbol (caddr funob))) "->s.s_gfdef;")) temp))) (ordinary (let* ((temp (list 'vs (vs-push))) (*value-to-go* temp)) (c2expr* (caddr funob)) temp)) (otherwise (baboon)) )) (defun push-args (args) (cond ((null args) (wt-nl "vs_base=vs_top;")) ((consp args) (let ((*vs* *vs*) (base *vs*)) (dolist** (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg))) (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (base-used))))) (defun push-args-lispcall (args) (dolist** (arg args) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* arg)))) (defun c2call-unknown-global (fname args loc inline-p) (cond (*compiler-push-events* ;;; Want to set up the return catcher. (unless loc (setq loc (list 'vs (vs-push))) (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");")) (push-args args) (wt-nl "funcall_with_catcher(" (vv-str (add-symbol fname)) "," loc ");") (unwind-exit 'fun-val nil fname)) (loc ;;; The function was already pushed. (push-args args) (if inline-p (if *safe-compile* (wt-nl "funcall_no_event(" loc ");") (wt-nl "CMPfuncall(" loc ");")) (wt-nl "funcall(" loc ");")) (unwind-exit 'fun-val)) ((args-cause-side-effect args) ;;; Evaluation of the arguments may cause side-effect. ;;; Arguments are not yet pushed. (let ((base *vs*)) (setq loc (list 'vs (vs-push))) (if *safe-compile* (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");") (wt-nl loc "=(" (vv-str (add-symbol fname)) "->s.s_gfdef);")) (push-args-lispcall args) (cond ((or (eq *value-to-go* 'return) (eq *value-to-go* 'top)) (wt-nl "lispcall") (when inline-p (wt "_no_event")) (wt "(base+" base "," (length args) ");") (base-used) (unwind-exit 'fun-val)) (t (unwind-exit (list 'SIMPLE-CALL (if inline-p "lispcall_no_event" "lispcall") base (length args)))))) ) (t ;;; Evaluation of the arguments causes no side-effect. ;;; Arguments are not yet pushed. (let ((base *vs*)) (push-args-lispcall args) (cond ((or (eq *value-to-go* 'return) (eq *value-to-go* 'top)) (wt-nl "symlispcall") (when inline-p (wt "_no_event")) (wt "(" (vv-str (add-symbol fname)) ",base+" base "," (length args) ");") (base-used) (unwind-exit 'fun-val nil fname)) (t (unwind-exit (list 'SIMPLE-CALL (if inline-p "symlispcall_no_event" "symlispcall") base (length args) (add-symbol fname)) nil fname)))) ))) gcl-2.6.14/cmpnew/gcl_make-fn.lsp0000755000175000017500000000015414360276512015152 0ustar cammcamm(load (concatenate 'string si::*system-directory* "../cmpnew/gcl_collectfn")) (compiler::emit-fn t) gcl-2.6.14/cmpnew/gcl_cmptype.lsp0000755000175000017500000002061614360276512015322 0ustar cammcamm;;; CMPTYPE Type information. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) ;;; CL-TYPE is any valid type specification of Common Lisp. ;;; ;;; TYPE is a representation type used by KCL. TYPE is one of: ;;; ;;; T(BOOLEAN) ;;; ;;; FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT ;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) ;;; (VECTOR SHORT-FLOAT) (VECTOR LONG-FLOAT) ;;; (ARRAY T) (ARRAY STRING-CHAR) (ARRAY BIT) ;;; (ARRAY FIXNUM) ;;; (ARRAY SHORT-FLOAT) (ARRAY LONG-FLOAT) ;;; UNKNOWN ;;; ;;; NIL ;;; ;;; ;;; immediate-type: ;;; FIXNUM int ;;; CHARACTER char ;;; SHORT-FLOAT float ;;; LONG-FLOAT double ;;; Check if THING is an object of the type TYPE. ;;; Depends on the implementation of TYPE-OF. (defun object-type (thing) (let ((type (type-of thing))) (case type ((fixnum short-float long-float) type) ((standard-char character) 'character) ((string bit-vector) type) (vector (list 'vector (array-element-type thing))) (array (list 'array (array-element-type thing))) (t t)))) ; 'unknown ;; I can't see any use of this (defun type-filter (type) (case type ((fixnum character short-float long-float) type) (single-float 'long-float) (boolean 'boolean) (double-float 'long-float) ((simple-string string) 'string) ((simple-bit-vector bit-vector) 'bit-vector) ((nil t) t) (t (let ((type (si::normalize-type type)) element-type) (case (car type) ((simple-array array) (cond ((or (endp (cdr type)) (not (setq element-type (cond ((eq '* (cadr type)) nil) ((si::best-array-element-type (cadr type))) (t t))))) t) ; I don't know. ((and (not (endp (cddr type))) (not (eq (caddr type) '*)) (or (eql (caddr type) 1) (and (consp (caddr type)) (= (length (caddr type)) 1)))) (case element-type (character 'string) (bit 'bit-vector) (t (list 'vector element-type)))) (t (list 'array element-type)))) (integer (if (si::sub-interval-p (cdr type) (list most-negative-fixnum most-positive-fixnum)) 'fixnum 'integer)) ((short-float) 'short-float) ((long-float double-float single-float) 'long-float) ((stream) 'stream) (t (cond ((subtypep type 'fixnum) 'fixnum) ((subtypep type 'integer) 'integer) ((subtypep type 'character) 'character) ((subtypep type 'short-float) 'short-float) ((subtypep type 'long-float) 'long-float) ((subtypep type '(vector t)) '(vector t)) ((subtypep type 'string) 'string) ((subtypep type 'bit-vector) 'bit-vector) ((subtypep type '(vector fixnum)) '(vector fixnum)) ((subtypep type '(vector short-float)) '(vector short-float)) ((subtypep type '(vector long-float)) '(vector long-float)) ((subtypep type '(array t)) '(array t)) ((subtypep type '(array character)) '(array character)) ((subtypep type '(array bit)) '(array bit)) ((subtypep type '(array fixnum)) '(array fixnum)) ((subtypep type '(array short-float)) '(array short-float)) ((subtypep type '(array long-float)) '(array long-float)) ((eq (car type) 'values) (if (null (cddr type)) (list 'values (type-filter (second type))) t)) ((and (eq (car type) 'satisfies) (symbolp (second type)) (get (second type) 'type-filter))) (t t))) ))))) (defun type-and (type1 type2) (cond ((equal type1 type2) type1) ((eq type1 '*) type2) ((eq type2 '*) type1) ((and (consp type2) (eq (car type2) 'values)) (type-and type1 (second type2))) ((and (consp type1) (eq (car type1) 'values)) (type-and (second type1) type2)) ((eq type1 'object) type2) ((eq type1 t) type2) ((eq type2 'object) type1) ((eq type2 t) type1) ((subtypep type2 type1) type2) ((subtypep type1 type2) type1) ((consp type1) (case (car type1) (array (case (cadr type1) (character (if (eq type2 'string) type2 nil)) (bit (if (eq type2 'bit-vector) type2 nil)) (t (if (and (consp type2) (eq (car type2) 'vector) (eq (cadr type1) (cadr type2))) type2 nil)))) (vector (if (and (consp type2) (eq (car type2) 'array) (eq (cadr type1) (cadr type2))) type1 nil)) (t nil))) (t (case type1 (string (if (and (consp type2) (eq (car type2) 'array) (eq (cadr type2) 'character)) type1 nil)) (bit-vector (if (and (consp type2) (eq (car type2) 'array) (eq (cadr type2) 'bit)) type1 nil)) (fixnum-float (if (member type2 '(fixnum float short-float long-float)) type2 nil)) (float (if (member type2 '(short-float long-float)) type2 nil)) ((long-float short-float) (if (member type2 '(fixnum-float float)) type1 nil)) ((signed-char unsigned-char signed-short) (if (eq type2 'fixnum) type1 nil)) ((unsigned-short) (if (subtypep type1 type2) type1 nil)) (integer (case type2 (fixnum type2))) (fixnum (case type2 ((integer fixnum-float) 'fixnum) ((signed-char unsigned-char signed-short bit) type2) ((unsigned-short) (if (subtypep type2 type1) type2 nil)))) )))) (defun type>= (type1 type2) (equal (type-and type1 type2) type2)) (defun reset-info-type (info) (if (info-type info) (let ((info1 (copy-info info))) (setf (info-type info1) t) info1) info)) (defun and-form-type (type form original-form &aux type1) (setq type1 (type-and type (info-type (cadr form)))) (when (null type1) (cmpwarn "The type of the form ~s is not ~s." original-form type)) (if (eq type1 (info-type (cadr form))) form (let ((info (copy-info (cadr form)))) (setf (info-type info) type1) (list* (car form) info (cddr form))))) (defun check-form-type (type form original-form) (when (null (type-and type (info-type (cadr form)))) (cmpwarn "The type of the form ~s is not ~s." original-form type))) (defun default-init (type) (case type (fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) (character (cmpwarn "The default value of NIL is not CHARACTER.")) (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) (short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT.")) (integer (cmpwarn "The default value of NIL is not INTEGER")) ) (c1nil)) gcl-2.6.14/cmpnew/makefile0000644000175000017500000000333314360276512013766 0ustar cammcamm .SUFFIXES: .SUFFIXES: .o .c .lsp .lisp .fn -include ../makedefs PORTDIR = ../unixport CAT=cat APPEND=../xbin/append OBJS = gcl_cmpbind.o gcl_cmpblock.o gcl_cmpcall.o gcl_cmpcatch.o gcl_cmpenv.o gcl_cmpeval.o \ gcl_cmpflet.o gcl_cmpfun.o gcl_cmpif.o gcl_cmpinline.o gcl_cmplabel.o gcl_cmplam.o gcl_cmplet.o \ gcl_cmploc.o gcl_cmpmap.o gcl_cmpmulti.o gcl_cmpspecial.o gcl_cmptag.o gcl_cmptop.o \ gcl_cmptype.o gcl_cmputil.o gcl_cmpvar.o gcl_cmpvs.o gcl_cmpwt.o gcl_cmpmain.o #gcl_cmpopt.o gcl_lfun_list.o FNS:= $(OBJS:.o=.fn) LISP=$(PORTDIR)/saved_pre_gcl$(EXE) COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile %.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp $(COMPILE_FILE) $* all: $(OBJS) .lsp.fn: ../cmpnew/gcl_collectfn.o ../xbin/make-fn $*.lsp $(LISP) fns1: $(FNS) fns: ../cmpnew/gcl_collectfn.o $(MAKE) fns1 -e "FNS=`echo ${OBJS} | sed -e 's:\.o:\.fn:g'`" gcl_collectfn.o: $(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lsp .lisp.o: @ ../xbin/if-exists $(PORTDIR)/saved_pre_gcl$(EXE) \ "$(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lisp " sys-proclaim.lisp: fns echo '(in-package "COMPILER")' \ '(load "../cmpnew/gcl_collectfn")(load "../lsp/sys-proclaim.lisp")'\ '(compiler::make-all-proclaims "*.fn")' | ../xbin/gcl newfn: $(MAKE) `echo $(OBJS) | sed -e 's:\.o:.fn:g'` remake: for v in `"ls" *.lsp.V | sed -e "s:\.lsp\.V::g"` ; \ do rm -f $$v.c $$v.h $$v.data $$v.lsp $$v.o ; \ ln -s $(MAINDIR)/cmpnew/$$v.c . ; ln -s $(MAINDIR)/cmpnew/$$v.h . ; \ ln -s $(MAINDIR)/cmpnew/$$v.data . ; \ done rm -f ../unixport/$(FLISP) (cd .. ; $(MAKE) sources) (cd .. ; $(MAKE)) (cd .. ; $(MAKE)) clean: rm -f *.o core a.out *.fn *.c *.data *.h allclean: rm -f *.h *.data *.c gcl-2.6.14/cmpnew/gcl_cmpopt.lsp0000755000175000017500000013200214360276512015134 0ustar cammcamm(in-package :compiler) ;; The optimizers have been redone to allow more flags ;; The old style optimizations correspond to the first 2 ;; flags. ;; ( arglist result-type flags {string | function}) ;; meaning of the flags slot. ; '((allocates-new-storage ans); might invoke gbc ; (side-effect-p set) ; no effect on arguments ; (constantp) ; always returns same result, ; ;double eval ok. ; (result-type-from-args rfa); if passed args of matching ; ;type result is of result type ; (is))) ;; extends the `integer stack'. ; (cond ((member flag v :test 'eq) ; ;;; valid properties are 'inline-always 'inline-safe 'inline-unsafe ;; Note: The order of the properties is important, since the first ;; one whose arg types and result type can be matched will be chosen. (or (fboundp 'flags) (load "../cmpnew/cmpeval.lsp")) ;;INTEGER-LENGTH (push '((t) t #.(compiler::flags) "immnum_length(#0)") (get 'integer-length 'compiler::inline-always)) ;;LOGCOUNT (push '((t) t #.(compiler::flags) "immnum_count(#0)") (get 'logcount 'compiler::inline-always)) ;;LOGBITP (push '((t t) boolean #.(compiler::flags) "immnum_bitp(#0,#1)") (get 'logbitp 'compiler::inline-always)) ;;ABS (push '((t) t #.(compiler::flags) "immnum_abs(#0)") (get 'abs 'compiler::inline-always)) ;;ASH (push '((t t) t #.(compiler::flags) "immnum_shft(#0,#1)") (get 'ash 'compiler::inline-always)) ;;GCD (push '((t t) t #.(compiler::flags) "immnum_gcd(#0,#1)") (get 'gcd 'compiler::inline-always)) ;;LCM (push '((t t) t #.(compiler::flags) "immnum_lcm(#0,#1)") (get 'lcm 'compiler::inline-always)) ;;BOOLE (push '((t t t) t #.(compiler::flags) "immnum_bool(#0,#1,#2)") (get 'boole 'compiler::inline-always)) (push '((fixnum t t) t #.(compiler::flags) "immnum_boole(#0,#1,#2)") (get 'boole 'compiler::inline-always)) ;;BOOLE3 (push '((fixnum fixnum fixnum) fixnum #.(flags rfa)INLINE-BOOLE3) (get 'boole3 'inline-always)) ;;FP-OKP (push '((t) boolean #.(flags set) "@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )") (get 'fp-okp 'inline-unsafe)) (push '((stream) boolean #.(flags set)"((#0)->sm.sm_fp)!=0") (get 'fp-okp 'inline-unsafe)) ;;LDB1 (push '((fixnum fixnum fixnum) fixnum #.(flags) "((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))") (get 'si::ldb1 'inline-always)) ;;LONG-FLOAT-P (push '((t) boolean #.(flags)"type_of(#0)==t_longfloat") (get 'long-float-p 'inline-always)) ;;COMPLEX-P (push '((t) boolean #.(flags)"type_of(#0)==t_complex") (get 'si::complexp 'inline-always)) ;;SFEOF (push '((object) boolean #.(flags set)"(gcl_feof((#0)->sm.sm_fp))") (get 'sfeof 'inline-unsafe)) ;;SGETC1 (push '((object) fixnum #.(flags set rfa) "gcl_getc((#0)->sm.sm_fp)") (get 'sgetc1 'inline-unsafe)) ;;SPUTC (push '((fixnum object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") (get 'sputc 'inline-unsafe)) (push '((character object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") (get 'sputc 'inline-unsafe)) ;;READ-BYTE1 (push '((t t) t #.(flags ans set)"read_byte1(#0,#1)") (get 'read-byte1 'inline-unsafe)) ;;READ-CHAR1 (push '((t t) t #.(flags ans set)"read_char1(#0,#1)") (get 'read-char1 'inline-unsafe)) ;;SHIFT<< (push '((fixnum fixnum) fixnum #.(flags)"((#0) << (#1))") (get 'shift<< 'inline-always)) ;;SHIFT>> (push '((fixnum fixnum) fixnum #.(flags set rfa)"((#0) >> (- (#1)))") (get 'shift>> 'inline-always)) ;;SHORT-FLOAT-P (push '((t) boolean #.(flags)"type_of(#0)==t_shortfloat") (get 'short-float-p 'inline-always)) ;;SIDE-EFFECTS (push '(nil t #.(flags ans set)"Ct") (get 'side-effects 'inline-always)) ;;STACK-CONS (push '((fixnum t t) t #.(flags) "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") (get 'stack-cons 'inline-always)) ;;SUBLIS1 (push '((t t t) t #.(flags ans set)SUBLIS1-INLINE) (get 'sublis1 'inline-always)) ;;SYMBOL-LENGTH (push '((t) fixnum #.(flags rfa) "@0;(type_of(#0)==t_symbol ? (#0)->s.s_fillp :not_a_variable((#0)))") (get 'symbol-length 'inline-always)) ;;VECTOR-TYPE (push '((t fixnum) boolean #.(flags) "@0;(type_of(#0) == t_vector && (#0)->v.v_elttype == (#1))") (get 'vector-type 'inline-always)) ;;SYSTEM:ASET (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") (get 'system:aset 'inline-always)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:aset 'inline-always)) (push '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)") (get 'system:aset 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:aset 'inline-unsafe)) (push '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array character) fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array bit) fixnum fixnum) fixnum #.(flags rfa) "({object _o=(#0);fixnum _i=(#1)+_o->bv.bv_offset;char _c=1<bv.bv_self+(_i>>3);bool _b=(#2);if (_b) *_d|=_c; else *_d&=~_c;_b;})") (get 'si::aset 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum) fixnum #.(flags set rfa)"(#0)->fixa.fixa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short *)(#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array signed-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array unsigned-short) fixnum fixnum) fixnum #.(flags rfa set) "((unsigned short *)(#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array unsigned-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") (get 'system:aset 'inline-unsafe)) (push '(((array short-float) fixnum short-float) short-float #.(flags rfa set)"(#0)->sfa.sfa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '(((array long-float) fixnum long-float) long-float #.(flags rfa set)"(#0)->lfa.lfa_self[#1]= (#2)") (get 'system:aset 'inline-unsafe)) (push '((t t t t) t #.(flags set) "@0;aset(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2),#3)") (get 'system:aset 'inline-unsafe)) (push '(((array t) fixnum fixnum t) t #.(flags set) "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array character) fixnum fixnum character) character #.(flags rfa set) "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array short-float) fixnum fixnum short-float) short-float #.(flags rfa set) "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) (push '(((array long-float) fixnum fixnum long-float) long-float #.(flags rfa set) "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") (get 'system:aset 'inline-unsafe)) ;;SYSTEM:CHAR-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:char-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:char-set 'inline-always)) (push '((t t t) t #.(flags set) "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") (get 'system:char-set 'inline-unsafe)) (push '((t fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:char-set 'inline-unsafe)) ;;SYSTEM:ELT-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:elt-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:elt-set 'inline-always)) (push '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)") (get 'system:elt-set 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:elt-set 'inline-unsafe)) ;;SYSTEM:FILL-POINTER-SET (push '((t fixnum) fixnum #.(flags rfa set)"((#0)->st.st_fillp)=(#1)") (get 'system:fill-pointer-set 'inline-unsafe)) ;;SYSTEM:FIXNUMP (push '((t) boolean #.(flags)"type_of(#0)==t_fixnum") (get 'system:fixnump 'inline-always)) (push '((fixnum) boolean #.(flags)"1") (get 'system:fixnump 'inline-always)) ;;SYSTEM:HASH-SET (push '((t t t) t #.(flags rfa) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-unsafe)) (push '((t t t) t #.(flags rfa) "@2;(sethash_with_check(#0,#1,#2),#2)") (get 'si::hash-set 'inline-always)) ;;SYSTEM:MV-REF (push '((fixnum) t #.(flags ans set)"(MVloc[(#0)])") (get 'system:mv-ref 'inline-always)) ;;SYSTEM:PUTPROP (push '((t t t) t #.(flags set)"putprop(#0,#1,#2)") (get 'system:putprop 'inline-always)) ;;SYSTEM:SCHAR-SET (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") (get 'system:schar-set 'inline-always)) (push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") (get 'system:schar-set 'inline-always)) (push '((t t t) t #.(flags set) "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") (get 'system:schar-set 'inline-unsafe)) (push '((t fixnum character) character #.(flags set rfa)"(#0)->ust.ust_self[#1]= (#2)") (get 'system:schar-set 'inline-unsafe)) ;;SYSTEM:SET-MV (push '((fixnum t) t #.(flags ans set)"(MVloc[(#0)]=(#1))") (get 'system:set-mv 'inline-always)) ;;SYSTEM:SPUTPROP (push '((t t t) t #.(flags set)"sputprop(#0,#1,#2)") (get 'system:sputprop 'inline-always)) ;;SYSTEM:STRUCTURE-DEF (push '((t) t #.(flags)"(#0)->str.str_def") (get 'system:structure-def 'inline-unsafe)) ;;SYSTEM:STRUCTURE-LENGTH (push '((t) fixnum #.(flags rfa)"S_DATA(#0)->length") (get 'system:structure-length 'inline-unsafe)) ;;SYSTEM:STRUCTURE-REF (push '((t t fixnum) t #.(flags ans)"structure_ref(#0,#1,#2)") (get 'system:structure-ref 'inline-always)) ;;SYSTEM:STRUCTURE-SET (push '((t t fixnum t) t #.(flags set)"structure_set(#0,#1,#2,#3)") (get 'system:structure-set 'inline-always)) ;;SYSTEM:STRUCTUREP (push '((t) boolean #.(flags)"type_of(#0)==t_structure") (get 'system:structurep 'inline-always)) ;;SYSTEM:gethash1 (push '((t t) t #.(flags)"({struct htent *e=gethash(#0,#1);e->hte_key != OBJNULL ? e->hte_value : Cnil;})") (get 'system:gethash1 'inline-always)) ;;SYSTEM:SVSET (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") (get 'system:svset 'inline-always)) (push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") (get 'system:svset 'inline-always)) (push '((t t t) t #.(flags set)"((#0)->v.v_self[fix(#1)]=(#2))") (get 'system:svset 'inline-unsafe)) (push '((t fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") (get 'system:svset 'inline-unsafe)) ;;* (push '((t t) t #.(flags ans) "immnum_times(#0,#1)");"number_times(#0,#1)" (get '* 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)*(double)(#1)") (get '* 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)*(#1)") (get '* 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)*(#1)") (get '* 'inline-always)) ;;+ ;; (push '((t t) t #.(flags ans)"number_plus(#0,#1)") ;; (get '+ 'inline-always)) (push '((t t) t #.(flags ans)"immnum_plus(#0,#1)") (get '+ 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)+(double)(#1)") (get '+ 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)+(#1)") (get '+ 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)+(#1)") (get '+ 'inline-always)) ;;- ;; (push '((t) t #.(flags ans)"number_negate(#0)") ;; (get '- 'inline-always)) (push '((t) t #.(flags ans)"immnum_negate(#0)") (get '- 'inline-always)) (push '((t t) t #.(flags ans)"immnum_minus(#0,#1)") (get '- 'inline-always)) ;; (push '((t t) t #.(flags ans)"number_minus(#0,#1)") ;; (get '- 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((fixnum-float) short-float #.(flags)"-(double)(#0)") (get '- 'inline-always)) (push '((fixnum-float) long-float #.(flags)"-(double)(#0)") (get '- 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)-(double)(#1)") (get '- 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)-(#1)") (get '- 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)"(#0)-(#1)") (get '- 'inline-always)) (push '((fixnum) fixnum #.(flags)"-(#0)") (get '- 'inline-always)) ;;/ (push '((fixnum fixnum) fixnum #.(flags)"(#0)/(#1)") (get '/ 'inline-always)) (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)/(double)(#1)") (get '/ 'inline-always)) (push '((short-float short-float) short-float #.(flags rfa)"(#0)/(#1)") (get '/ 'inline-always)) ;;/= (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") (get '/= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)!=0") ;; (get '/= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)!=(#1)") (get '/= 'inline-always)) ;;1+ ;; (push '((t) t #.(flags ans)"one_plus(#0)") ;; (get '1+ 'inline-always)) (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(1))") (get '1+ 'inline-always)) (push '((fixnum-float) short-float #.(flags)"(double)(#0)+1") (get '1+ 'inline-always)) (push '((fixnum-float) long-float #.(flags)"(double)(#0)+1") (get '1+ 'inline-always)) (push '((fixnum) fixnum #.(flags)"(#0)+1") (get '1+ 'inline-always)) ;;1- ;; (push '((t) t #.(flags ans)"one_minus(#0)") ;; (get '1- 'inline-always)) (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(-1))") (get '1- 'inline-always)) (push '((fixnum) fixnum #.(flags)"(#0)-1") (get '1- 'inline-always)) (push '((fixnum-float) short-float #.(flags)"(double)(#0)-1") (get '1- 'inline-always)) (push '((fixnum-float) long-float #.(flags)"(double)(#0)-1") (get '1- 'inline-always)) ;;< (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<0") ;; (get '< 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<(#1)") (get '< 'inline-always)) ;;compiler::objlt (push '((t t) boolean #.(flags)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always)) ;;<= (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<=0") ;; (get '<= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<=(#1)") (get '<= 'inline-always)) ;;= (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)==0") ;; (get '= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)==(#1)") (get '= 'inline-always)) ;;> (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>0") ;; (get '> 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>(#1)") (get '> 'inline-always)) ;;>= (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>=0") ;; (get '>= 'inline-always)) (push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>=(#1)") (get '>= 'inline-always)) ;;APPEND (push '((t t) t #.(flags ans)"append(#0,#1)") (get 'append 'inline-always)) ;;AREF (push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fixint(#1))") (get 'aref 'inline-always)) (push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") (get 'aref 'inline-always)) (push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fix(#1))") (get 'aref 'inline-unsafe)) (push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") (get 'aref 'inline-unsafe)) (push '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array character) fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array bit) fixnum) fixnum #.(flags rfa)"({object _o=(#0);fixnum _i=(#1)+(_o)->bv.bv_offset;(_o->bv.bv_self[_i>>3]>>BIT_ENDIAN(_i&0x7))&0x1;})") (get 'aref 'inline-unsafe)) (push '(((array fixnum) fixnum) fixnum #.(flags rfa)"(#0)->fixa.fixa_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array unsigned-char) fixnum) fixnum #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array signed-char) fixnum) fixnum #.(flags rfa)"SIGNED_CHAR((#0)->ust.ust_self[#1])") (get 'aref 'inline-unsafe)) (push '(((array unsigned-short) fixnum) fixnum #.(flags rfa) "((unsigned short *)(#0)->ust.ust_self)[#1]") (get 'aref 'inline-unsafe)) (push '(((array signed-short) fixnum) fixnum #.(flags rfa)"((short *)(#0)->ust.ust_self)[#1]") (get 'aref 'inline-unsafe)) (push '(((array short-float) fixnum) short-float #.(flags rfa)"(#0)->sfa.sfa_self[#1]") (get 'aref 'inline-unsafe)) (push '(((array long-float) fixnum) long-float #.(flags rfa)"(#0)->lfa.lfa_self[#1]") (get 'aref 'inline-unsafe)) ;; (push '((t t t) t #.(flags ans) ;; "@0;aref(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2))") ;; (get 'aref 'inline-unsafe)) (push '(((array t) fixnum fixnum) t #.(flags ) "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array character) fixnum fixnum) character #.(flags rfa) "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array fixnum) fixnum fixnum) fixnum #.(flags rfa) "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array short-float) fixnum fixnum) short-float #.(flags rfa) "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) (push '(((array long-float) fixnum fixnum) long-float #.(flags rfa) "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]") (get 'aref 'inline-unsafe)) ;;ARRAY-TOTAL-SIZE (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)") (get 'array-total-size 'inline-unsafe)) ;;ARRAYP ;; (push '((t) boolean #.(flags) ;; "@0;type_of(#0)==t_array|| ;; type_of(#0)==t_vector|| ;; type_of(#0)==t_string|| ;; type_of(#0)==t_bitvector") ;; (get 'arrayp 'inline-always)) ;;ATOM (push '((t) boolean #.(flags)"atom(#0)") (get 'atom 'inline-always)) ;;BIT-VECTOR-P (push '((t) boolean #.(flags)"(type_of(#0)==t_bitvector)") (get 'bit-vector-p 'inline-always)) ;;BIT-VECTOR-P (push '((t) boolean #.(flags)"(type_of(#0)==t_bitvector)") (get 'bit-vector-p 'inline-always)) ;;HASH-TABLE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_hashtable)") (get 'hash-table-p 'inline-always)) ;;RANDOM-STATE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_random)") (get 'random-state-p 'inline-always)) ;;RANDOM-STATE-P (push '((t) boolean #.(flags)"(type_of(#0)==t_random)") (get 'random-state-p 'inline-always)) ;;PACKAGEP (push '((t) boolean #.(flags)"(type_of(#0)==t_package)") (get 'packagep 'inline-always)) ;;STREAMP (push '((t) boolean #.(flags)"(type_of(#0)==t_stream)") (get 'streamp 'inline-always)) ;;READTABLEP (push '((t) boolean #.(flags)"(type_of(#0)==t_readtable)") (get 'readtablep 'inline-always)) ;;COMPOUND PREDICATES (dolist (l '(integerp rationalp floatp realp numberp vectorp arrayp compiled-function-p)) (push `((t) boolean #.(flags) ,(substitute #\_ #\- (concatenate 'string (string-downcase l) "(#0)"))) (get l 'inline-always))) ;;BOUNDP (push '((t) boolean #.(flags)"(#0)->s.s_dbind!=OBJNULL") (get 'boundp 'inline-unsafe)) ;;CAAAAR (push '((t) t #.(flags)"caaaar(#0)") (get 'caaaar 'inline-safe)) (push '((t) t #.(flags)"CMPcaaaar(#0)") (get 'caaaar 'inline-unsafe)) ;;CAAADR (push '((t) t #.(flags)"caaadr(#0)") (get 'caaadr 'inline-safe)) (push '((t) t #.(flags)"CMPcaaadr(#0)") (get 'caaadr 'inline-unsafe)) ;;CAAAR (push '((t) t #.(flags)"caaar(#0)") (get 'caaar 'inline-safe)) (push '((t) t #.(flags)"CMPcaaar(#0)") (get 'caaar 'inline-unsafe)) ;;CAADAR (push '((t) t #.(flags)"caadar(#0)") (get 'caadar 'inline-safe)) (push '((t) t #.(flags)"CMPcaadar(#0)") (get 'caadar 'inline-unsafe)) ;;CAADDR (push '((t) t #.(flags)"caaddr(#0)") (get 'caaddr 'inline-safe)) (push '((t) t #.(flags)"CMPcaaddr(#0)") (get 'caaddr 'inline-unsafe)) ;;CAADR (push '((t) t #.(flags)"caadr(#0)") (get 'caadr 'inline-safe)) (push '((t) t #.(flags)"CMPcaadr(#0)") (get 'caadr 'inline-unsafe)) ;;CAAR (push '((t) t #.(flags)"caar(#0)") (get 'caar 'inline-safe)) (push '((t) t #.(flags)"CMPcaar(#0)") (get 'caar 'inline-unsafe)) ;;CADAAR (push '((t) t #.(flags)"cadaar(#0)") (get 'cadaar 'inline-safe)) (push '((t) t #.(flags)"CMPcadaar(#0)") (get 'cadaar 'inline-unsafe)) ;;CADADR (push '((t) t #.(flags)"cadadr(#0)") (get 'cadadr 'inline-safe)) (push '((t) t #.(flags)"CMPcadadr(#0)") (get 'cadadr 'inline-unsafe)) ;;CADAR (push '((t) t #.(flags)"cadar(#0)") (get 'cadar 'inline-safe)) (push '((t) t #.(flags)"CMPcadar(#0)") (get 'cadar 'inline-unsafe)) ;;CADDAR (push '((t) t #.(flags)"caddar(#0)") (get 'caddar 'inline-safe)) (push '((t) t #.(flags)"CMPcaddar(#0)") (get 'caddar 'inline-unsafe)) ;;CADDDR (push '((t) t #.(flags)"cadddr(#0)") (get 'cadddr 'inline-safe)) (push '((t) t #.(flags)"CMPcadddr(#0)") (get 'cadddr 'inline-unsafe)) ;;CADDR (push '((t) t #.(flags)"caddr(#0)") (get 'caddr 'inline-safe)) (push '((t) t #.(flags)"CMPcaddr(#0)") (get 'caddr 'inline-unsafe)) ;;CADR (push '((t) t #.(flags)"cadr(#0)") (get 'cadr 'inline-safe)) (push '((t) t #.(flags)"CMPcadr(#0)") (get 'cadr 'inline-unsafe)) ;;CAR (push '((t) t #.(flags)"car(#0)") (get 'car 'inline-safe)) (push '((t) t #.(flags)"CMPcar(#0)") (get 'car 'inline-unsafe)) ;;CDAAAR (push '((t) t #.(flags)"cdaaar(#0)") (get 'cdaaar 'inline-safe)) (push '((t) t #.(flags)"CMPcdaaar(#0)") (get 'cdaaar 'inline-unsafe)) ;;CDAADR (push '((t) t #.(flags)"cdaadr(#0)") (get 'cdaadr 'inline-safe)) (push '((t) t #.(flags)"CMPcdaadr(#0)") (get 'cdaadr 'inline-unsafe)) ;;CDAAR (push '((t) t #.(flags)"cdaar(#0)") (get 'cdaar 'inline-safe)) (push '((t) t #.(flags)"CMPcdaar(#0)") (get 'cdaar 'inline-unsafe)) ;;CDADAR (push '((t) t #.(flags)"cdadar(#0)") (get 'cdadar 'inline-safe)) (push '((t) t #.(flags)"CMPcdadar(#0)") (get 'cdadar 'inline-unsafe)) ;;CDADDR (push '((t) t #.(flags)"cdaddr(#0)") (get 'cdaddr 'inline-safe)) (push '((t) t #.(flags)"CMPcdaddr(#0)") (get 'cdaddr 'inline-unsafe)) ;;CDADR (push '((t) t #.(flags)"cdadr(#0)") (get 'cdadr 'inline-safe)) (push '((t) t #.(flags)"CMPcdadr(#0)") (get 'cdadr 'inline-unsafe)) ;;CDAR (push '((t) t #.(flags)"cdar(#0)") (get 'cdar 'inline-safe)) (push '((t) t #.(flags)"CMPcdar(#0)") (get 'cdar 'inline-unsafe)) ;;CDDAAR (push '((t) t #.(flags)"cddaar(#0)") (get 'cddaar 'inline-safe)) (push '((t) t #.(flags)"CMPcddaar(#0)") (get 'cddaar 'inline-unsafe)) ;;CDDADR (push '((t) t #.(flags)"cddadr(#0)") (get 'cddadr 'inline-safe)) (push '((t) t #.(flags)"CMPcddadr(#0)") (get 'cddadr 'inline-unsafe)) ;;CDDAR (push '((t) t #.(flags)"cddar(#0)") (get 'cddar 'inline-safe)) (push '((t) t #.(flags)"CMPcddar(#0)") (get 'cddar 'inline-unsafe)) ;;CDDDAR (push '((t) t #.(flags)"cdddar(#0)") (get 'cdddar 'inline-safe)) (push '((t) t #.(flags)"CMPcdddar(#0)") (get 'cdddar 'inline-unsafe)) ;;CDDDDR (push '((t) t #.(flags)"cddddr(#0)") (get 'cddddr 'inline-safe)) (push '((t) t #.(flags)"CMPcddddr(#0)") (get 'cddddr 'inline-unsafe)) ;;CDDDR (push '((t) t #.(flags)"cdddr(#0)") (get 'cdddr 'inline-safe)) (push '((t) t #.(flags)"CMPcdddr(#0)") (get 'cdddr 'inline-unsafe)) ;;CDDR (push '((t) t #.(flags)"cddr(#0)") (get 'cddr 'inline-safe)) (push '((t) t #.(flags)"CMPcddr(#0)") (get 'cddr 'inline-unsafe)) ;;CDR (push '((t) t #.(flags)"cdr(#0)") (get 'cdr 'inline-safe)) (push '((t) t #.(flags)"CMPcdr(#0)") (get 'cdr 'inline-unsafe)) ;;CHAR (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'char 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'char 'inline-always)) (push '((t t) t #.(flags)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'char 'inline-unsafe)) (push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'char 'inline-unsafe)) ;;CHAR-CODE (push '((character) fixnum #.(flags rfa)"(#0)") (get 'char-code 'inline-always)) ;;CHAR/= (push '((character character) boolean #.(flags)"(#0)!=(#1)") (get 'char/= 'inline-always)) (push '((t t) boolean #.(flags)"!eql(#0,#1)") (get 'char/= 'inline-unsafe)) (push '((t t) boolean #.(flags)"char_code(#0)!=char_code(#1)") (get 'char/= 'inline-unsafe)) ;;CHAR< (push '((character character) boolean #.(flags)"(#0)<(#1)") (get 'char< 'inline-always)) ;;CHAR<= (push '((character character) boolean #.(flags)"(#0)<=(#1)") (get 'char<= 'inline-always)) ;;CHAR= (push '((t t) boolean #.(flags)"eql(#0,#1)") (get 'char= 'inline-unsafe)) (push '((t t) boolean #.(flags)"char_code(#0)==char_code(#1)") (get 'char= 'inline-unsafe)) (push '((character character) boolean #.(flags)"(#0)==(#1)") (get 'char= 'inline-unsafe)) ;;CHAR> (push '((character character) boolean #.(flags)"(#0)>(#1)") (get 'char> 'inline-always)) ;;CHAR>= (push '((character character) boolean #.(flags)"(#0)>=(#1)") (get 'char>= 'inline-always)) ;;CHARACTERP (push '((t) boolean #.(flags)"type_of(#0)==t_character") (get 'characterp 'inline-always)) ;;CODE-CHAR (push '((fixnum) character #.(flags)"(#0)") (get 'code-char 'inline-always)) ;;CONS (push '((t t) t #.(flags ans)"make_cons(#0,#1)") (get 'cons 'inline-always)) (push '((t t) :dynamic-extent #.(flags ans)"ON_STACK_CONS(#0,#1)") (get 'cons 'inline-always)) ;;CONSP (push '((t) boolean #.(flags)"consp(#0)") (get 'consp 'inline-always)) ;;COS (push '((long-float) long-float #.(flags rfa)"cos(#0)") (get 'cos 'inline-always)) ;;DIGIT-CHAR-P (push '((character) boolean #.(flags)"@0; ((#0) <= '9' && (#0) >= '0')") (get 'digit-char-p 'inline-always)) ;;ELT (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'elt 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'elt 'inline-always)) (push '((t t) t #.(flags ans)"elt(#0,fix(#1))") (get 'elt 'inline-unsafe)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'elt 'inline-unsafe)) ;;ENDP ;;Must use endp_prop here as generic lisp code containing (endp ;;can be compiled to take function output as its argument, which ;;cannot be redirected via a macro, e.g. endp(cdr(V20)). CM (push '((t) boolean #.(flags)"endp_prop(#0)") (get 'endp 'inline-safe)) (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'endp 'inline-unsafe)) ;;EQ (push '((t t) boolean #.(flags rfa)"(#0)==(#1)") (get 'eq 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"0") (get 'eq 'inline-always)) ;;EQL (push '((t t) boolean #.(flags rfa)"eql(#0,#1)") (get 'eql 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) (push '((character character) boolean #.(flags rfa)"(#0)==(#1)") (get 'eql 'inline-always)) ;;EQUAL (push '((t t) boolean #.(flags rfa)"equal(#0,#1)") (get 'equal 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equal 'inline-always)) ;;EQUALP (push '((t t) boolean #.(flags rfa)"equalp(#0,#1)") (get 'equalp 'inline-always)) (push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") (get 'equalp 'inline-always)) ;;EXPT (push '((t t) t #.(flags ans)"number_expt(#0,#1)") (get 'expt 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags)(LAMBDA (LOC1 LOC2) (IF (AND (CONSP LOC1) (EQ (CAR LOC1) 'FIXNUM-LOC) (CONSP (CADR LOC1)) (EQ (CAADR LOC1) 'FIXNUM-VALUE) (EQUAL (CADDR (CADR LOC1)) 2)) (WT "(1<<(" LOC2 "))") (WT "fixnum_expt(" LOC1 #\, LOC2 #\))))) (get 'expt 'inline-always)) ;;FILL-POINTER (push '((t) fixnum #.(flags rfa)"((#0)->st.st_fillp)") (get 'fill-pointer 'inline-unsafe)) ;;FIRST (push '((t) t #.(flags)"car(#0)") (get 'first 'inline-safe)) (push '((t) t #.(flags)"CMPcar(#0)") (get 'first 'inline-unsafe)) ;;FLOAT (push '((fixnum-float) long-float #.(flags)"((longfloat)(#0))") (get 'float 'inline-always)) (push '((fixnum-float) short-float #.(flags)"((shortfloat)(#0))") (get 'float 'inline-always)) ;;FLOATP ;; (push '((t) boolean #.(flags) ;; "@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat") ;; (get 'floatp 'inline-always)) ;;CEILING (push '((t t) t #.(compiler::flags) "immnum_ceiling(#0,#1)") (get 'ceiling 'compiler::inline-always)) ;;FLOOR ; (push '((fixnum fixnum) fixnum #.(flags rfa) ; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))") ; (get 'floor 'inline-always)) (push '((t t) t #.(compiler::flags) "immnum_floor(#0,#1)") (get 'floor 'compiler::inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa) "@01;({fixnum _t=(#0)/(#1);((#1)<0 && (#0)<=0) || ((#1)>0 && (#0)>=0) || ((#1)*_t == (#0)) ? _t : _t - 1;})") (get 'floor 'inline-always)) ;;FOURTH (push '((t) t #.(flags)"cadddr(#0)") (get 'fourth 'inline-safe)) (push '((t) t #.(flags)"CMPcadddr(#0)") (get 'fourth 'inline-unsafe)) ;;GET (push '((t t t) t #.(flags)"get(#0,#1,#2)") (get 'get 'inline-always)) (push '((t t) t #.(flags)"get(#0,#1,Cnil)") (get 'get 'inline-always)) ;;INTEGERP ;; (push '((t) boolean #.(flags) ;; "@0;type_of(#0)==t_fixnum||type_of(#0)==t_bignum") ;; (get 'integerp 'inline-always)) (push '((fixnum) boolean #.(flags) "1") (get 'integerp 'inline-always)) ;;KEYWORDP (push '((t) boolean #.(flags) "@0;(type_of(#0)==t_symbol&&(#0)->s.s_hpack==keyword_package)") (get 'keywordp 'inline-always)) ;;ADDRESS (push '((t) fixnum #.(flags rfa)"((fixnum)(#0))") (get 'si::address 'inline-always)) ;;NANI (push '((fixnum) t #.(flags rfa)"((object)(#0))") (get 'si::nani 'inline-always)) ;;LENGTH (push '((t) fixnum #.(flags rfa)"length(#0)") (get 'length 'inline-always)) (push '(((array t)) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) (push '(((array fixnum)) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) (push '((string) fixnum #.(flags rfa)"(#0)->v.v_fillp") (get 'length 'inline-unsafe)) ;;LIST (push '(nil t #.(flags)"Cnil") (get 'list 'inline-always)) (push '((t) t #.(flags ans)"make_cons(#0,Cnil)") (get 'list 'inline-always)) (push '((t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) (push '((t t t t t t t t t t) t #.(flags ans)LIST-INLINE) (get 'list 'inline-always)) ;;LIST* (push '((t) t #.(flags)"(#0)") (get 'list* 'inline-always)) (push '((t t) t #.(flags ans)"make_cons(#0,#1)") (get 'list* 'inline-always)) (push '((t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) (push '((t t t t t t t t t t) t #.(flags ans)LIST*-INLINE) (get 'list* 'inline-always)) ;;LISTP (push '((t) boolean #.(flags)"listp(#0)") (get 'listp 'inline-always)) ;;si::spice-p (push '((t) boolean #.(flags)"@0;type_of(#0)==t_spice") (get 'si::spice-p 'inline-always)) ;;LOGNAND (push '((t t) t #.(compiler::flags) "immnum_nand(#0,#1)") (get 'lognand 'compiler::inline-always)) ;;LOGNOR (push '((t t) t #.(compiler::flags) "immnum_nor(#0,#1)") (get 'lognor 'compiler::inline-always)) ;;LOGEQV (push '((t t) t #.(compiler::flags) "immnum_eqv(#0,#1)") (get 'logeqv 'compiler::inline-always)) ;;LOGANDC1 (push '((t t) t #.(compiler::flags) "immnum_andc1(#0,#1)") (get 'logandc1 'compiler::inline-always)) ;;LOGANDC2 (push '((t t) t #.(compiler::flags) "immnum_andc2(#0,#1)") (get 'logandc2 'compiler::inline-always)) ;;LOGORC1 (push '((t t) t #.(compiler::flags) "immnum_orc1(#0,#1)") (get 'logorc1 'compiler::inline-always)) ;;LOGORC1 (push '((t t) t #.(compiler::flags) "immnum_orc2(#0,#1)") (get 'logorc2 'compiler::inline-always)) ;;LOGAND (push '((t t) t #.(flags)"immnum_and((#0),(#1))") (get 'logand 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & (#1))") (get 'logand 'inline-always)) ;;LOGIOR (push '((t t) t #.(flags)"immnum_ior((#0),(#1))") (get 'logior 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) | (#1))") (get 'logior 'inline-always)) ;;LOGXOR (push '((t t) t #.(flags)"immnum_xor((#0),(#1))") (get 'logxor 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) ^ (#1))") (get 'logxor 'inline-always)) ;;LOGNOT (push '((t) t #.(flags)"immnum_not(#0)") (get 'lognot 'inline-always)) (push '((fixnum) fixnum #.(flags rfa)"(~(#0))") (get 'lognot 'inline-always)) ;;MAKE-LIST (push '((fixnum) :dynamic-extent #.(flags ans) "@0;(ALLOCA_CONS(#0),ON_STACK_MAKE_LIST(#0))") (get 'make-list 'inline-always)) ;;MAX (push '((t t) t #.(flags) "immnum_max(#0,#1)");"@01;(number_compare(#0,#1)>=0?(#0):#1)" (get 'max 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)>=(#1)?(#0):#1)") (get 'max 'inline-always)) ;;MIN (push '((t t) t #.(flags) "immnum_min(#0,#1)");"@01;(number_compare(#0,#1)<=0?(#0):#1)" (get 'min 'inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)<=(#1)?(#0):#1)") (get 'min 'inline-always)) ;;LDB (push '((t t) t #.(compiler::flags) "immnum_ldb(#0,#1)") (get 'ldb 'compiler::inline-always)) ;;LDB-TEST (push '((t t) boolean #.(compiler::flags) "immnum_ldbt(#0,#1)") (get 'ldb-test 'compiler::inline-always)) ;;LOGTEST (push '((t t) boolean #.(compiler::flags) "immnum_logt(#0,#1)") (get 'logtest 'compiler::inline-always)) ;;DPB (push '((t t t) t #.(compiler::flags) "immnum_dpb(#0,#1,#2)") (get 'dpb 'compiler::inline-always)) ;;DEPOSIT-FIELD (push '((t t t) t #.(compiler::flags) "immnum_dpf(#0,#1,#2)") (get 'deposit-field 'compiler::inline-always)) ;;MINUSP (push '((t) boolean #.(flags) "immnum_minusp(#0)");"number_compare(small_fixnum(0),#0)>0" (get 'minusp 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)<0") (get 'minusp 'inline-always)) ;;MOD ; (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;(#0>=0&&(#1)>0?(#0)%(#1):imod(#0,#1))") ; (get 'mod 'inline-always)) (push '((t t) t #.(compiler::flags) "immnum_mod(#0,#1)") (get 'mod 'compiler::inline-always)) (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;({fixnum _t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})") (get 'mod 'inline-always)) ;;NCONC (push '((t t) t #.(flags set)"nconc(#0,#1)") (get 'nconc 'inline-always)) ;;NOT (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'not 'inline-always)) ;;NREVERSE (push '((t) t #.(flags ans set)"nreverse(#0)") (get 'nreverse 'inline-always)) ;;NTH ; (push '((t t) t #.(flags)"nth(fixint(#0),#1)") ; (get 'nth 'inline-always)) ; (push '((fixnum t) t #.(flags)"nth(#0,#1)") ; (get 'nth 'inline-always)) ; (push '((t t) t #.(flags)"nth(fix(#0),#1)") ; (get 'nth 'inline-unsafe)) ;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") ; (get 'nth 'inline-always)) ;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") ; (get 'nth 'inline-always)) (push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") (get 'nth 'inline-unsafe)) ;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") ; (get 'nth 'inline-unsafe)) ;;NTHCDR ; (push '((t t) t #.(flags)"nthcdr(fixint(#0),#1)") ; (get 'nthcdr 'inline-always)) ; (push '((fixnum t) t #.(flags)"nthcdr(#0,#1)") ; (get 'nthcdr 'inline-always)) ; (push '((t t) t #.(flags)"nthcdr(fix(#0),#1)") ; (get 'nthcdr 'inline-unsafe)) ;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") ; (get 'nthcdr 'inline-always)) ;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") ; (get 'nthcdr 'inline-always)) (push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") (get 'nthcdr 'inline-unsafe)) ;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") ; (get 'nthcdr 'inline-unsafe)) ;;NULL (push '((t) boolean #.(flags)"(#0)==Cnil") (get 'null 'inline-always)) ;;NUMBERP ;; (push '((t) boolean #.(flags) ;; "@0;type_of(#0)==t_fixnum|| ;; type_of(#0)==t_bignum|| ;; type_of(#0)==t_ratio|| ;; type_of(#0)==t_shortfloat|| ;; type_of(#0)==t_longfloat|| ;; type_of(#0)==t_complex") ;; (get 'numberp 'inline-always)) ;;PLUSP (push '((t) boolean #.(flags) "immnum_plusp(#0)");"number_compare(small_fixnum(0),#0)<0" (get 'plusp 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)>0") (get 'plusp 'inline-always)) ;;PRIN1 (push '((t t) t #.(flags set)"prin1(#0,#1)") (get 'prin1 'inline-always)) (push '((t) t #.(flags set)"prin1(#0,Cnil)") (get 'prin1 'inline-always)) ;;PRINC (push '((t t) t #.(flags set)"princ(#0,#1)") (get 'princ 'inline-always)) (push '((t) t #.(flags set)"princ(#0,Cnil)") (get 'princ 'inline-always)) ;;PRINT (push '((t t) t #.(flags set)"print(#0,#1)") (get 'print 'inline-always)) (push '((t) t #.(flags set)"print(#0,Cnil)") (get 'print 'inline-always)) ;;PROBE-FILE (push '((t) boolean #.(flags)"(file_exists(#0))") (get 'probe-file 'inline-always)) ;;RATIOP (push '((t) boolean #.(flags) "type_of(#0)==t_ratio") (get 'ratiop 'inline-always)) ;;REM (push '((t t) t #.(compiler::flags) "immnum_rem(#0,#1)") (get 'rem 'compiler::inline-always)) #+TRUNCATE_USE_C (push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)") (get 'rem 'inline-always)) ;;REMPROP (push '((t t) t #.(flags set)"remprop(#0,#1)") (get 'remprop 'inline-always)) ;;REST (push '((t) t #.(flags)"cdr(#0)") (get 'rest 'inline-safe)) (push '((t) t #.(flags)"CMPcdr(#0)") (get 'rest 'inline-unsafe)) ;;REVERSE (push '((t) t #.(flags ans)"reverse(#0)") (get 'reverse 'inline-always)) ;;SCHAR (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") (get 'schar 'inline-always)) (push '((t fixnum) t #.(flags ans)"elt(#0,#1)") (get 'schar 'inline-always)) (push '((t t) t #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])") (get 'schar 'inline-unsafe)) (push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") (get 'schar 'inline-unsafe)) ;;SECOND (push '((t) t #.(flags)"cadr(#0)") (get 'second 'inline-safe)) (push '((t) t #.(flags)"CMPcadr(#0)") (get 'second 'inline-unsafe)) ;;SIN (push '((long-float) long-float #.(flags rfa)"sin(#0)") (get 'sin 'inline-always)) ;;STRING (push '((t) t #.(flags ans)"coerce_to_string(#0)") (get 'string 'inline-always)) ;;PATHNAME-DESIGNATORP (push '((t) boolean #.(flags)"pathname_designatorp(#0)") (get 'si::pathname-designatorp 'inline-always)) ;;PATHNAMEP (push '((t) boolean #.(flags)"type_of(#0)==t_pathname") (get 'pathnamep 'inline-always)) ;;STRINGP (push '((t) boolean #.(flags)"type_of(#0)==t_string") (get 'stringp 'inline-always)) ;;SVREF ;; (push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))") ;; (get 'svref 'inline-always)) ;; (push '((t fixnum) t #.(flags ans)"aref1(#0,#1)") ;; (get 'svref 'inline-always)) (push '((t t) t #.(flags)"(#0)->v.v_self[fix(#1)]") (get 'svref 'inline-unsafe)) (push '((t fixnum) t #.(flags)"(#0)->v.v_self[#1]") (get 'svref 'inline-unsafe)) ;;SYMBOL-NAME (push '((t) t #.(flags ans)"symbol_name(#0)") (get 'symbol-name 'inline-always)) ;;SYMBOL-PLIST (push (list '(t) t #.(flags) "((#0)->s.s_plist)") (get 'symbol-plist 'inline-unsafe)) ;;SYMBOLP (push '((t) boolean #.(flags)"type_of(#0)==t_symbol") (get 'symbolp 'inline-always)) ;;TAN (push '((long-float) long-float #.(flags rfa)"tan(#0)") (get 'tan 'inline-always)) ;;SQRT (push '((long-float) long-float #.(flags rfa)"sqrt((double)#0)") (get 'sqrt 'inline-always)) ;;TERPRI (push '((t) t #.(flags set)"terpri(#0)") (get 'terpri 'inline-always)) (push '(nil t #.(flags set)"terpri(Cnil)") (get 'terpri 'inline-always)) ;;THIRD (push '((t) t #.(flags)"caddr(#0)") (get 'third 'inline-safe)) (push '((t) t #.(flags)"CMPcaddr(#0)") (get 'third 'inline-unsafe)) ;;TRUNCATE (push '((t t) t #.(compiler::flags) "immnum_truncate(#0,#1)") (get 'truncate 'compiler::inline-always)) #+TRUNCATE_USE_C (push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)/(#1)") (get 'truncate 'inline-always)) (push '((fixnum-float) fixnum #.(flags)"(fixnum)(#0)") (get 'truncate 'inline-always)) ;;VECTORP ;; (push '((t) boolean #.(flags) ;; "@0;type_of(#0)==t_vector|| ;; type_of(#0)==t_string|| ;; type_of(#0)==t_bitvector") ;; (get 'vectorp 'inline-always)) ;;WRITE-CHAR (push '((t) t #.(flags set) "@0;(writec_stream(char_code(#0),Vstandard_output->s.s_dbind),(#0))") (get 'write-char 'inline-unsafe)) ;;EVENP (push '((t) boolean #.(compiler::flags) "immnum_evenp(#0)") (get 'evenp 'compiler::inline-always)) ;;ODDP (push '((t) boolean #.(compiler::flags) "immnum_oddp(#0)") (get 'oddp 'compiler::inline-always)) ;;SIGNUM (push '((t) t #.(compiler::flags) "immnum_signum(#0)") (get 'signum 'compiler::inline-always)) ;;ZEROP (push '((t) boolean #.(flags) "immnum_zerop(#0)");"number_compare(small_fixnum(0),#0)==0" (get 'zerop 'inline-always)) (push '((fixnum-float) boolean #.(flags)"(#0)==0") (get 'zerop 'inline-always)) ;;CMOD (push '((t) t #.(flags) "cmod(#0)") (get 'system:cmod 'inline-always)) ;;CTIMES (push '((t t) t #.(flags) "ctimes(#0,#1)") (get 'system:ctimes 'inline-always)) ;;CPLUS (push '((t t) t #.(flags) "cplus(#0,#1)") (get 'system:cplus 'inline-always)) ;;CDIFFERENCE (push '((t t) t #.(flags) "cdifference(#0,#1)") (get 'system:cdifference 'inline-always)) ;;si::static-inverse-cons (push '((t) t #.(compiler::flags) "({object _y=(object)fixint(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) (push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) (push '((t) t #.(compiler::flags) "({object _y=(object)fix(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) (push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) ;;symbol-value (push '((t) t #.(compiler::flags) "(#0)->s.s_dbind") (get 'symbol-value 'compiler::inline-unsafe)) (push '((t) t #.(compiler::flags) "@0;type_of(#0)!=t_symbol ? (not_a_symbol(#0),Cnil) : ((#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind)") (get 'symbol-value 'compiler::inline-always)) (push '((symbol) t #.(compiler::flags) "@0;(#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind") (get 'symbol-value 'compiler::inline-always)) ;;acons (push '((t t t) t #.(compiler::flags) "MMcons(MMcons((#0),(#1)),(#2))") (get 'acons 'compiler::inline-always)) gcl-2.6.14/cmpnew/gcl_cmpfun.lsp0000755000175000017500000007712514360276512015140 0ustar cammcamm;; CMPFUN Library functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'princ 'c1princ 'c1) (si:putprop 'princ 'c2princ 'c2) (si:putprop 'terpri 'c1terpri 'c1) (si:putprop 'apply 'c1apply 'c1) (si:putprop 'apply 'c2apply 'c2) (si:putprop 'apply-optimize 'c2apply-optimize 'c2) (si:putprop 'funcall 'c1funcall 'c1) (si:putprop 'rplaca 'c1rplaca 'c1) (si:putprop 'rplaca 'c2rplaca 'c2) (si:putprop 'rplacd 'c1rplacd 'c1) (si:putprop 'rplacd 'c2rplacd 'c2) (si:putprop 'si::memq 'c1memq 'c1) (si:putprop 'member 'c1member 'c1) (si:putprop 'member!2 'c2member!2 'c2) (si:putprop 'assoc 'c1assoc 'c1) (si:putprop 'assoc!2 'c2assoc!2 'c2) (si:putprop 'get 'c1get 'c1) (si:putprop 'get 'c2get 'c2) (si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional) (si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional) (si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1) (si:putprop 'si:list-nth 'c1list-nth 'c1) (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2) (si:putprop 'gethash 'c1gethash 'c1) (si:putprop 'gethash 'c2gethash 'c2) (defvar *princ-string-limit* 80) (defun c1princ (args &aux stream (info (make-info))) (when (endp args) (too-few-args 'princ 1 0)) (unless (or (endp (cdr args)) (endp (cddr args))) (too-many-args 'princ 2 (length args))) (setq stream (if (endp (cdr args)) (c1nil) (c1expr* (cadr args) info))) (if (and (or (and (stringp (car args)) (<= (length (car args)) *princ-string-limit*)) (characterp (car args))) (or (endp (cdr args)) (and (eq (car stream) 'var) (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))) (list 'princ info (car args) (if (endp (cdr args)) nil (var-loc (caaddr stream))) stream) (list 'call-global info 'princ (list (c1expr* (car args) info) stream)))) (defun c2princ (string vv-index stream) (cond ((eq *value-to-go* 'trash) (cond ((characterp string) (wt-nl "princ_char(" (char-code string)) (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) (wt ");")) ((= (length string) 1) (wt-nl "princ_char(" (char-code (aref string 0))) (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) (wt ");")) (t (wt-nl "princ_str(\"") (dotimes** (n (length string)) (let ((char (schar string n))) (cond ((char= char #\\) (wt "\\\\")) ((char= char #\") (wt "\\\"")) ((char= char #\Newline) (wt "\\n")) ((char= char #\Return) (wt "\\r")) (t (wt char))))) (wt "\",") (if (null vv-index) (wt "Cnil") (wt (vv-str vv-index))) (wt ");"))) (unwind-exit nil)) ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t)) (t (c2call-global 'princ (list (list 'LOCATION (make-info :type (if (characterp string) 'character 'string)) (list 'VV (add-object string))) stream) nil t)))) (defun c1terpri (args &aux stream (info (make-info))) (unless (or (endp args) (endp (cdr args))) (too-many-args 'terpri 1 (length args))) (setq stream (if (endp args) (c1nil) (c1expr* (car args) info))) (if (or (endp args) (and (eq (car stream) 'var) (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))) (list 'princ info #\Newline (if (endp args) nil (var-loc (caaddr stream))) stream) (list 'call-global info 'terpri (list stream)))) (defun c1apply (args &aux info) (when (or (endp args) (endp (cdr args))) (too-few-args 'apply 2 (length args))) (let ((funob (c1funob (car args)))) (setq info (copy-info (cadr funob))) (setq args (c1args (cdr args) info)) (cond ((eq (car funob) 'call-lambda) (let* ((lambda-expr (caddr funob)) (lambda-list (caddr lambda-expr))) (declare (object lambda-expr lambda-list)) (if (and (null (cadr lambda-list)) ; No optional (null (cadddr lambda-list))) ; No keyword (c1apply-optimize info (car lambda-list) (caddr lambda-list) (car (cddddr lambda-expr)) args) (list 'apply info funob args)))) (t (list 'apply info funob args)))) ) (defun c2apply (funob args &aux (*vs* *vs*) loc) (setq loc (save-funob funob)) (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar)))) (do ((l args (cdr l))) ((endp (cdr l)) (wt-nl "{object " last-arg ";") (let ((*value-to-go* last-arg)) (c2expr* (car l)))) (declare (object l)) (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l)))) (wt-nl " vs_top=base+" *vs* ";") (base-used) (cond (*safe-compile* (wt-nl " while(!endp(" last-arg "))") (wt-nl " {vs_push(car(" last-arg "));") (wt last-arg "=cdr(" last-arg ");}")) (t (wt-nl " while(" last-arg "!=Cnil)") (wt-nl " {vs_push((" last-arg ")->c.c_car);") (wt last-arg "=(" last-arg ")->c.c_cdr;}"))) (wt-nl "vs_base=base+" base ";}") (base-used)) (c2funcall funob 'args-pushed loc) ) (defun c1apply-optimize (info requireds rest body args &aux (vl nil) (fl nil)) (do () ((or (endp (cdr args)) (endp requireds))) (push (pop requireds) vl) (push (pop args) fl)) (cond ((cdr args) ;;; REQUIREDS is NIL. (cmpck (null rest) "APPLY passes too many arguments to LAMBDA expression.") (push rest vl) (push (list 'call-global info 'list* args) fl) (list 'let info (reverse vl) (reverse fl) body)) (requireds ;;; ARGS is singleton. (let ((temp (make-var :kind 'LEXICAL :ref t))) (push temp vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) (list 'apply-optimize (cadr body) temp requireds rest body)))) (rest (push rest vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) body)) (t (let ((temp (make-var :kind 'LEXICAL :ref t))) (push temp vl) (push (car args) fl) (list 'let info (reverse vl) (reverse fl) (list 'apply-optimize (cadr body) temp requireds rest body)))) ) ) (defun c2apply-optimize (temp requireds rest body &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) (when (or *safe-compile* *compiler-check-args*) (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly") "(" (length requireds) ",") (wt-var temp nil) (wt ");")) (dolist** (v requireds) (setf (var-ref v) (vs-push))) (when rest (setf (var-ref rest) (vs-push))) (do ((n 0 (1+ n)) (vl requireds (cdr vl))) ((endp vl) (when rest (wt-nl) (wt-vs (var-ref rest)) (wt "= ") (dotimes** (i n) (wt "(")) (wt-var temp nil) (dotimes** (i n) (wt-nl ")->c.c_cdr")) (wt ";"))) (declare (fixnum n) (object vl)) (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(") (dotimes** (i n) (wt "(")) (wt-var temp nil) (dotimes** (i n) (wt-nl ")->c.c_cdr")) (wt ")->c.c_car;")) (dolist** (var requireds) (c2bind var)) (when rest (c2bind rest)) (c2expr body) ) (defun c1funcall (args &aux funob (info (make-info))) (when (endp args) (too-few-args 'funcall 1 0)) (setq funob (c1funob (car args))) (add-info info (cadr funob)) (list 'funcall info funob (c1args (cdr args) info)) ) (defun c1rplaca (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'rplaca 2 (length args))) (unless (endp (cddr args)) (too-many-args 'rplaca 2 (length args))) (setq args (c1args args info)) (list 'rplaca info args)) (defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (safe-compile (wt-nl "if(type_of(" (car args) ")!=t_cons)" "FEwrong_type_argument(Scons," (car args) ");")) (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";") (unwind-exit (car args)) (close-inline-blocks) ) (defun c1rplacd (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'rplacd 2 (length args))) (when (not (endp (cddr args))) (too-many-args 'rplacd 2 (length args))) (setq args (c1args args info)) (list 'rplacd info args)) (defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (safe-compile (wt-nl "if(type_of(" (car args) ")!=t_cons)" "FEwrong_type_argument(Scons," (car args) ");")) (wt-nl "(" (car args) ")->c.c_cdr = SAFE_CDR(" (cadr args) ");") (unwind-exit (car args)) (close-inline-blocks) ) (defun c1memq (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'si::memq 2 (length args))) (unless (endp (cddr args)) (too-many-args 'si::memq 2 (length args))) (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info))) (defun c1member (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'member 2 (length args))) (cond ((endp (cddr args)) (list 'member!2 info 'eql (c1args args info))) ((and (eq (caddr args) :test) (eql (length args) 4) (member (cadddr args) '('eq #'eq 'equal #'equal 'equalp #'equalp 'eql #'eql) :test 'equal)) (list 'member!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) (t (list 'call-global info 'member (c1args args info))))) (defun c2member!2 (fun args &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar))) (setq args (inline-args args '(t t))) (wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";") (if *safe-compile* (wt-nl "while(!endp(V" l "))") (wt-nl "while(V" l "!=Cnil)")) (if (eq fun 'eq) (wt-nl "if(x==(V" l "->c.c_car)){") (wt-nl "if(" (string-downcase (symbol-name fun)) "(x,V" l "->c.c_car)){")) (if (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'JUMP-TRUE) (eq (car *value-to-go*) 'JUMP-FALSE))) (unwind-exit t 'JUMP) (unwind-exit (list 'CVAR l) 'JUMP)) (wt-nl "}else V" l "=V" l "->c.c_cdr;") (unwind-exit nil) (wt "}") (close-inline-blocks) ) (defun c1assoc (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'assoc 2 (length args))) (cond ((endp (cddr args)) (list 'assoc!2 info 'eql (c1args args info))) ((and (eq (caddr args) ':test) (eql (length args) 4) (member (cadddr args) '('eq #'eq 'equal #'equal 'equalp #'equalp 'eql #'eql) :test 'equal)) (list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) (t (list 'call-global info 'assoc (c1args args info))))) (defun c2assoc!2 (fun args &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name) (setq args (inline-args args '(t t))) (setq name (symbol-name fun)) (or (eq fun 'eq) (setq name (string-downcase name))) (wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";") (cond (*safe-compile* (wt-nl "while(!endp(V" al "))") (wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&" name "(x,V" al "->c.c_car->c.c_car)){")) (t (wt-nl "while(V" al "!=Cnil)") (wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&" "V"al"->c.c_car != Cnil){"))) (if (and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (unwind-exit t 'jump) (unwind-exit (list 'CAR al) 'jump)) (wt-nl "}else V" al "=V" al "->c.c_cdr;") (unwind-exit nil) (wt "}") (close-inline-blocks) ) (defun boole3 (a b c) (boole a b c)) ;(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) (defun c1boole-condition (args) (and (not (endp (cddr args))) (endp (cdddr args)) (inline-boole3-string (car args)))) (defun c1boole3 (args) (c1expr (cons 'boole3 args))) (defun inline-boole3 (&rest args) (let ((boole-op-arg (second (car args)))) (or (eq (car boole-op-arg) 'fixnum-value) (error "must be constant")) (let ((string (inline-boole3-string (third boole-op-arg)))) (or string (error "should not get here boole opt")) (wt-inline-loc string (cdr args))))) (defun inline-boole3-string (op-code) (and (constantp op-code) (setq op-code (eval op-code))) (case op-code (#. boole-andc1 "((~(#0))&(#1))") (#. boole-andc2 "(((#0))&(~(#1)))") (#. boole-nor "(~((#0)|(#1)))") (#. boole-orc1 "(~(#0)) | (#1)))") (#. boole-orc2 "((#0) | (~(#1)))") (#. boole-nand "(~((#0) & (#1)))") (#. boole-eqv "(~((#0) ^ (#1)))") (#. boole-and "((#0) & (#1))") (#. boole-xor "((#0) ^ (#1))") (#. boole-ior "((#0) | (#1))"))) (si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) (defun c1ash-condition (args &aux (z '#.(let ((z (integer-length most-positive-fixnum))) `(integer ,(- z) ,z)))) (let ((shamt (second args))) (or (typep shamt z) (and (consp shamt) (eq (car shamt) 'the) (let ((type (cadr shamt))) (subtypep type z)))))) (defun c1ash (args) (let ((shamt (second args))fun) (cond ((constantp shamt) (setq shamt (eval shamt)) (or (si:fixnump shamt) (error "integer shift only")) (cond ((< shamt 0) (setq fun 'shift>> )) ((>= shamt 0) (setq fun 'shift<<)))) (t (let ((type (second shamt))) ;;it had to be a (the type..) (cond ((subtypep type '#.`(integer 0 ,(integer-length most-positive-fixnum))) (setq fun 'shift<< )) ((subtypep type '#.`(integer ,(- (integer-length most-positive-fixnum)) 0)) (setq fun 'shift>> )) (t (error "should not get here"))) ))) (c1expr (cons fun args)))) (defun shift>> (a b) (ash a b)) (defun shift<< (a b) (ash a b)) (si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) (si:putprop 'shift>> "Lash" 'lfun) (si:putprop 'shift<< "Lash" 'lfun) (si::putprop 'ldb 'co1ldb 'co1) (defun co1ldb (f args &aux tem (len (integer-length most-positive-fixnum))) f (let ((specs (cond ((and (consp (setq tem (first args))) (eq 'byte (car tem)) (cons (second tem) (third tem))))))) (cond ((and (integerp (cdr specs)) (integerp (car specs)) (< (+ (car specs)(cdr specs)) len) (subtypep (result-type (second args)) 'fixnum)) (c1expr `(the fixnum (si::ldb1 ,(car specs) ,(cdr specs) ,(second args)))))))) (si:putprop 'length 'c1length 'c1) (defun c1length (args &aux (info (make-info))) (setf (info-type info) 'fixnum) (cond ((and (consp (car args)) (eq (caar args) 'symbol-name) (let ((args1 (cdr (car args)))) (and args1 (not (cddr args1)) (list 'call-global info 'symbol-length (c1args args1 info)))))) (t (setq args (c1args args info)) (list 'call-global info 'length args )))) (defun c1get (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'get 2 (length args))) (when (and (not (endp (cddr args))) (not (endp (cdddr args)))) (too-many-args 'get 3 (length args))) (list 'get info (c1args args info))) (defun c2get (args) (if *safe-compile* (c2call-global 'get args nil t) (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar))) (setq args (inline-args args (if (cddr args) '(t t t) '(t t)))) (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;") (wt-nl " object ind= " (cadr args) ";") (wt-nl "while(V" pl "!=Cnil){") (wt-nl "if(V" pl "->c.c_car==ind){") (unwind-exit (list 'CADR pl) 'jump) (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}") (unwind-exit (if (cddr args) (caddr args) nil)) (wt "}") (close-inline-blocks))) ) (defun co1eql (f args) f (or (and (cdr args) (not *safe-compile*)) (return-from co1eql nil)) (cond ((replace-constant args) (cond ((characterp (second args)) (setq args (reverse args)))) (cond ((characterp (car args)) (let ((c (gensym))) (c1expr `(let ((,c ,(second args))) (declare (type ,(result-type (second args)) ,c)) (and (typep ,c 'character) (= (char-code ,(car args)) (the fixnum (char-code (the character ,c))) )))))))))) (si::putprop 'eql 'co1eql 'co1) (defvar *frozen-defstructs* nil) ;; Return the most particular type we can EASILY obtain ;; from x. (defun result-type (x) (cond ((symbolp x) (let ((tem (c1expr x))) (info-type (second tem)))) ((constantp x) (type-filter (type-of x))) ((and (consp x) (eq (car x) 'the)) (type-filter (second x))) (t t))) (defvar *type-alist* '((fixnum . si::fixnump) (float . floatp) (si::spice . si::spice-p) (short-float . short-float-p) (long-float . long-float-p) (integer . integerp) (character . characterp) (symbol . symbolp) (cons . consp) (null . null) (array . arrayp) (vector . vectorp) (bit-vector . bit-vector-p) (string . stringp) (list . (lambda (y) (or (consp y) (null y)))) (number . numberp) (rational . rationalp) (complex . complexp) (ratio . ratiop) (sequence . (lambda (y) (or (listp y) (vectorp y)))) (function . functionp) )) (defun co1typep (f args &aux tem) f (let* ((x (car args)) new (type (and (consp (second args)) (eq (car (second args)) 'quote) (second (second args))))) (cond ((subtypep (result-type (car args)) type) (setq new t) (return-from co1typep (c1expr new)))) (setq new (cond ((null type) nil) ((setq f (assoc type *type-alist* :test 'equal)) (list (cdr f) x)) ((setq f (when (symbolp type) (get type 'si::type-predicate))) (list f x)) ((and (consp type) (eq (car type) 'or)) `(or ,@(mapcar (lambda (y) `(typep ,x ',y)) (cdr type)))) ((and (consp type) (eq (car type) 'member)) `(or ,@(mapcar (lambda (y) `(eql ,x ',y)) (cdr type)))) ((and (consp type) (eq (car type) 'eql)) `(eql ,x ',(cadr type))) ((and (consp type) (or (and (eq (car type) 'vector) (null (cddr type))) (and (member (car type) '(array vector simple-array)) (equal (third type) '(*))))) (setq tem (si::best-array-element-type (second type))) (cond ((eq tem 'character) `(stringp ,x)) ((eq tem 'bit) `(bit-vector-p ,x)) ((setq tem (position tem *aet-types*)) `(the boolean (vector-type ,x ,tem))))) ((and (consp type) (eq (car type) 'satisfies) (consp (cdr type)) (cadr type) (symbolp (cadr type)) (symbol-package (cadr type)) (null (cddr type)) `(,(cadr type) ,x))) ((subtypep type 'fixnum) (setq tem (si::normalize-type type)) (and (consp tem) (si::fixnump (second tem)) (si::fixnump (third tem)) `(let ((.tem ,x)) (declare (type ,(result-type x) .tem)) (and (typep .tem 'fixnum) (>= (the fixnum .tem) ,(second tem)) (<= (the fixnum .tem) ,(third tem)))))) ((and (symbolp type) (setq tem (get type 'si::s-data))) (cond ((or (si::s-data-frozen tem) *frozen-defstructs*) (struct-type-opt x tem)) (t `(si::structure-subtype-p ,x ',type)))) ((and (symbolp type) (setq tem (get type 'si::deftype-definition))) `(typep ,x ',(funcall tem))) ;; ((and (print (list 'slow 'typep type)) nil)) (t nil))) (and new (c1expr `(the boolean , new))))) ;; this is going the wrong way. want to go up.. (defun struct-type-opt (x sd) (let ((s (gensym)) (included (get-included (si::s-data-name sd)))) `(let ((,s ,x)) (and (si::structurep ,s) ,(cond ((< (length included) 3) `(or ,@ (mapcar #'(lambda (x) `(eq (si::structure-def ,s) ,(name-sd1 x))) included))) (t `(si::structure-subtype-p ,s ,(name-sd1 (si::s-data-name sd))))))))) (defun get-included (name) (let ((sd (get name 'si::s-data))) (cons (si::s-data-name sd) (mapcan 'get-included (si::s-data-included sd))))) (si::putprop 'typep 'co1typep 'co1) (defun co1schar (f args) f (and (listp (car args)) (not *safe-compile*) (cdr args) (eq (caar args) 'symbol-name) (c1expr `(aref (the string ,(second (car args))) ,(second args))))) (si::putprop 'schar 'co1schar 'co1) (si::putprop 'cons 'co1cons 'co1) ;; turn repetitious cons's into a list* (defun cons-to-lista (x) (let ((tem (last x))) (cond ((and (consp tem) (consp (car tem)) (eq (caar tem) 'cons) (eql (length (cdar tem)) 2) (cons-to-lista (append (butlast x) (cdar tem))))) (t x)))) (defun co1cons (f args) f (let ((tem (and (eql (length args) 2) (cons-to-lista args)))) (and (not (eq tem args)) (c1expr (if (equal '(nil) (last tem)) (cons 'list (butlast tem)) (cons 'list* tem)))))) ;; I don't feel it is good to replace the list call, but rather ;; usually better the other way around. We removed c1list ;; because of possible feedback. (defun c1nth-condition (args) (and (not (endp args)) (not (endp (cdr args))) (endp (cddr args)) (numberp (car args)) (<= 0 (car args) 7))) (defun c1nth (args) (c1expr (case (car args) (0 (cons 'car (cdr args))) (1 (cons 'cadr (cdr args))) (2 (cons 'caddr (cdr args))) (3 (cons 'cadddr (cdr args))) (4 (list 'car (cons 'cddddr (cdr args)))) (5 (list 'cadr (cons 'cddddr (cdr args)))) (6 (list 'caddr (cons 'cddddr (cdr args)))) (7 (list 'cadddr (cons 'cddddr (cdr args)))) ))) (defun c1nthcdr-condition (args) (and (not (endp args)) (not (endp (cdr args))) (endp (cddr args)) (numberp (car args)) (<= 0 (car args) 7))) (defun c1nthcdr (args) (c1expr (case (car args) (0 (cadr args)) (1 (cons 'cdr (cdr args))) (2 (cons 'cddr (cdr args))) (3 (cons 'cdddr (cdr args))) (4 (cons 'cddddr (cdr args))) (5 (list 'cdr (cons 'cddddr (cdr args)))) (6 (list 'cddr (cons 'cddddr (cdr args)))) (7 (list 'cdddr (cons 'cddddr (cdr args)))) ))) (defun c1rplaca-nthcdr (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args)) (endp (cddr args))) (too-few-args 'si:rplaca-nthcdr 3 (length args))) (unless (endp (cdddr args)) (too-few-args 'si:rplaca-nthcdr 3 (length args))) (if (and (numberp (cadr args)) (<= 0 (cadr args) 10)) (let ((x (gensym))(y (gensym))) (c1expr `(let ((,x ,(car args)) (,y ,(third args))) (setf ,x (nthcdr ,(cadr args) ,x)) (setf (car ,x) ,y) ,y))) (list 'call-global info 'si:rplaca-nthcdr (c1args args info)))) ;; Facilities for faster reading and writing from file streams. ;; You must declare the stream to be :in-file ;; or :out-file (si::putprop 'read-byte 'co1read-byte 'co1) (si::putprop 'read-char 'co1read-char 'co1) (si::putprop 'write-byte 'co1write-byte 'co1) (si::putprop 'write-char 'co1write-char 'co1) (defun fast-read (args read-fun) (cond ((and (not *safe-compile*) (< *space* 2) (null (second args)) (boundp 'si::*eof*)) (cond ((atom (car args)) (or (car args) (setq args (cons '*standard-input* (cdr args)))) (let ((stream (car args)) (eof (third args))) `(let ((ans 0)) (declare (fixnum ans)) (cond ((fp-okp ,stream) (setq ans (sgetc1 ,stream)) (cond ((and (eql ans ,si::*eof*) (sfeof ,stream)) ,eof) (t ,(if (eq read-fun 'read-char1) '(code-char ans) 'ans)) )) (t (,read-fun ,stream ,eof) ) )))) (t `(let ((.strm. ,(car args))) (declare (type ,(result-type (car args)) .strm.)) ,(fast-read (cons '.strm. (cdr args)) read-fun))))))) (defun co1read-byte (f args &aux tem) f (cond ((setq tem (fast-read args 'read-byte1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun co1read-char (f args &aux tem) f (cond ((setq tem (fast-read args 'read-char1)) (let ((*space* 10)) ;prevent recursion! (c1expr tem))))) (defun cfast-write (args write-fun) (cond ((and (not *safe-compile*) (< *space* 2) (boundp 'si::*eof*)) (let ((stream (second args))) (or stream (setq stream '*standard-output*)) (cond ((atom stream) `(cond ((fp-okp ,stream) (the fixnum (sputc .ch ,stream))) (t (,write-fun .ch ,stream)))) (t `(let ((.str ,stream)) (declare (type ,(result-type stream) .str)) ,(cfast-write (list '.ch '.str) write-fun)))))))) (defun co1write-byte (f args) f (let ((tem (cfast-write args 'write-byte))) (if tem (let ((*space* 10)) (c1expr `(let ((.ch ,(car args))) (declare (fixnum .ch)) ,tem ,(if (atom (car args)) (car args) '.ch))))))) (defun co1write-char (f args) f (let ((tem (cfast-write args 'write-char))) (if tem (let ((*space* 10)) (c1expr `(let ((.ch ,(car args))) (declare (character .ch)) ,tem ,(if (atom (car args)) (car args) '.ch))))))) (defvar *aet-types* #(T CHARACTER SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) (defun aet-c-type (type) (ecase type ((t) "object") ((character signed-char) "char") (fixnum "fixnum") (unsigned-char "unsigned char") (unsigned-short "unsigned short") (signed-short "short") (unsigned-short "unsigned short") (long-float "longfloat") (short-float "shortfloat"))) (si:putprop 'vector-push 'co1vector-push 'co1) (si:putprop 'vector-push-extend 'co1vector-push 'co1) (defun co1vector-push (f args) f (unless (or *safe-compile* (> *space* 3) (null (cdr args)) ) (let ((*space* 10)) (c1expr `(let* ((.val ,(car args)) (.v ,(second args)) (.i (fill-pointer .v)) (.dim (array-total-size .v))) (declare (fixnum .i .dim)) (declare (type ,(result-type (second args)) .v)) (declare (type ,(result-type (car args)) .val)) (cond ((< .i .dim) (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i)))) (si::aset .v .i .val) .i) (t ,(cond ((eq f 'vector-push-extend) `(vector-push-extend .val .v ,@(cddr args))))))))))) (defun constant-fold-p (x) (cond ((constantp x) t) ((atom x) nil) ((eq (car x) 'the) (constant-fold-p (third x))) ((and (symbolp (car x)) (eq (get (car x) 'co1) 'co1constant-fold)) (dolist (w (cdr x)) (or (constant-fold-p w) (return-from constant-fold-p nil))) t) (t nil))) (defun co1constant-fold (f args ) (cond ((and (fboundp f) (dolist (v args t) (or (constant-fold-p v) (return-from co1constant-fold nil)))) (c1expr (cmp-eval (cons f args)))))) (si::putprop 'sublis 'co1sublis 'co1) (defun co1sublis (f args &aux test) f (and (case (length args) (2 (setq test 'eql)) (4 (and (eq (third args) :test) (cond ((member (fourth args) '(equal (function equal))) (setq test 'equal)) ((member (fourth args) '(eql (function eql))) (setq test 'eql)) ((member (fourth args) '(eq (function eq))) (setq test 'eq)) )))) (let ((s (gensym))) (c1expr `(let ((,s ,(car args))) (sublis1 ,s ,(second args) ',test)))))) (defun sublis1-inline (a b c) (let ((tst (ltvp-eval (cadr c)))) (or (member tst '(eq equal eql)) (error "bad test")) (wt "(check_alist(" a "),sublis1("a "," b "," (format nil "&o~(~a~)))" tst)))) ;; end new (defun c1list-nth (args &aux (info (make-info))) (when (or (endp args) (endp (cdr args))) (too-few-args 'si:rplaca-nthcdr 2 (length args))) (unless (endp (cddr args)) (too-few-args 'si:rplaca-nthcdr 2 (length args))) (if (and (numberp (car args)) (<= 0 (car args) 10)) (list 'list-nth-immediate info (car args) (c1args (list (cadr args)) info)) (list 'call-global info 'si:list-nth (c1args args info)))) (defun c2list-nth-immediate (index args &aux (l (next-cvar)) (*vs* *vs*) (*inline-blocks* 0)) (setq args (inline-args args '(t t))) (wt-nl "{object V" l "= ") (if *safe-compile* (progn (dotimes** (i index) (wt "cdr(")) (wt (car args)) (dotimes** (i index) (wt ")")) (wt ";") (wt-nl "if((type_of(V" l ")!=t_cons) && (" (car args) "!= Cnil))") (wt-nl " FEwrong_type_argument(Scons,V" l ");") ) (progn (wt-nl (car args)) (dotimes** (i index) (wt-nl "->c.c_cdr")) (wt ";"))) (unwind-exit (list 'CAR l)) (wt "}") (close-inline-blocks) ) (defun c1gethash (args) (unless (cdr args) (too-few-args 'gethash 2 (length args))) (when (cdddr args) (too-many-args 'gethash 3 (length args))) (let* ((info (make-info)) (nargs (c1args args info))) `(gethash ,info ,nargs))) (defun c2gethash (args) (cond ((member *value-to-go* '(top return)) (let* ((nargs (inline-args args '(t t))) (base *vs*)(*vs* *vs*) (r (cdr (vs-push)))(f (cdr (vs-push)))) (wt-nl "{ struct htent *_z=gethash" (if *safe-compile* "_with_check" "") "(" (car nargs) "," (cadr nargs) ");") (wt-nl "if (_z->hte_key==OBJNULL) {") (wt-nl "base[" r "]=" (caddr nargs) ";") (wt-nl "base[" f "]=Cnil;") (wt-nl "} else {") (wt-nl "base[" r "]=_z->hte_value;") (wt-nl "base[" f "]=Ct;") (wt-nl "}}") (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") (unwind-exit 'fun-val nil (cons 'values 2)))) ((let ((*inline-blocks* 0) (*restore-avma* *restore-avma*) (fd `((t t) t #.(flags rfa) ,(concatenate 'string "({struct htent *_z=gethash" (if *safe-compile* "_with_check" "") "(#0,#1);_z->hte_key==OBJNULL ? (#2) : _z->hte_value;})")))) (save-avma fd) (unwind-exit (get-inline-loc fd args)) (close-inline-blocks))))) gcl-2.6.14/cmpnew/gcl_cmpwt.lsp0000755000175000017500000001500014360276512014762 0ustar cammcamm;;; CMPWT Output routines. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (eval-when (compile eval) (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") (defmacro data-inits () `(first *data*)) ) (defun wt-comment (message &optional (symbol nil)) (princ " /* " *compiler-output1*) (princ message *compiler-output1*) (when symbol (let ((s (symbol-name symbol))) (declare (string s)) (dotimes** (n (length s)) (let ((c (schar s n))) (declare (character c)) (unless (char= c #\/) (princ c *compiler-output1*)))))) (princ " */ " *compiler-output1*) nil ) (defun wt1 (form) (cond ((or (stringp form) (integerp form) (characterp form)) (princ form *compiler-output1*)) ((or (typep form 'long-float) (typep form 'short-float)) (format *compiler-output1* "~10,,,,,,'eG" form)) (t (wt-loc form))) nil) (defun wt-h1 (form) (cond ((consp form) (let ((fun (get (car form) 'wt))) (if fun (apply fun (cdr form)) (cmpiler-error "The location ~s is undefined." form)))) (t (princ form *compiler-output2*))) nil) (defvar *fasd-data*) (defvar *hash-eq* nil) (defvar *run-hash-equal-data-checking* t) (defun memoized-hash-equal (x depth);FIXME implement all this in lisp (declare (fixnum depth)) (when *run-hash-equal-data-checking* (unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq))) (or (gethash x *hash-eq*) (setf (gethash x *hash-eq*) (if (> depth 3) 0 (if (typep x 'cons) (logxor (setq depth (the fixnum (1+ depth)));FIXME? (logxor (memoized-hash-equal (car x) depth) (memoized-hash-equal (cdr x) depth))) (si::hash-equal x depth))))))) (defun push-data-incf (x) (incf *next-vv*)) (defun wt-data1 (expr) (let ((*print-radix* nil) (*print-base* 10) (*print-circle* t) (*print-pretty* nil) (*print-level* nil) (*print-length* nil) (*print-case* :downcase) (*print-gensym* t) (*print-array* t) ;;This forces the printer to add the float type in the .data file. (*READ-DEFAULT-FLOAT-FORMAT* t) (si::*print-package* t) (si::*print-structure* t)) (terpri *compiler-output-data*) (prin1 expr *compiler-output-data*))) (defun add-init (x &optional endp &aux (tem (cons (memoized-hash-equal x -1000) x))) (if endp (nconc (data-inits) (list tem)) (push tem (data-inits))) x) (defun verify-datum (v) (unless (eql (pop v) (memoized-hash-equal v -1000)) (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" v)) v) (defun wt-fasd-element (x) (si::find-sharing-top x (fasd-table (car *fasd-data*))) (si::write-fasd-top x (car *fasd-data*))) (defun wt-data2 (x) (if *fasd-data* (wt-fasd-element x) (wt-data1 x))) (defun wt-data-file nil (when *prof-p* (add-init `(si::mark-memory-as-profiling))) (wt-data2 (1+ *next-vv*)) (dolist (v (nreverse (data-inits))) (wt-data2 (verify-datum v))) (when *fasd-data* (si::close-fasd (car *fasd-data*)))) (defun wt-data-begin ()) (defun wt-data-end ()) (defmacro wt (&rest forms &aux (fl nil)) (dolist** (form forms (cons 'progn (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (defmacro wt-h (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output2*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output2*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output2*) fl) (push `(wt-h1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output2*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output2*) fl) (push `(wt-h1 ,form) fl)))))) (defmacro wt-nl (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output1*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output1*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output1*) (reverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))))) (defmacro wt-nl1 (&rest forms &aux (fl nil)) (cond ((endp forms) '(princ " " *compiler-output1*)) ((stringp (car forms)) (dolist** (form (cdr forms) (list* 'progn `(princ ,(concatenate 'string " " (car forms)) *compiler-output1*) (nreverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))) (t (dolist** (form forms (list* 'progn '(princ " " *compiler-output1*) (nreverse (cons nil fl)))) (if (stringp form) (push `(princ ,form *compiler-output1*) fl) (push `(wt1 ,form) fl)))))) gcl-2.6.14/cmpnew/gcl_cmpinline.lsp0000755000175000017500000006567514360276512015635 0ustar cammcamm;;; CMPINLINE Open coding optimizer. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) ;;; Pass 1 generates the internal form ;;; ( id info-object . rest ) ;;; for each form encountered. ;;; Change changed-vars and referrred-vars slots in info structure to arrays ;;; for dramatic compilation speed improvements when the number of variables ;;; are large, as occurs at present in running the random-int-form tester. ;;; 20040320 CM (defmacro mia (x y) `(si:make-vector t ,x t ,y nil 0 nil nil)) ;(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y)) (defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y))) (defstruct (info (:copier old-copy-info)) (type t) ;;; Type of the form. (sp-change nil) ;;; Whether execution of the form may change ;;; the value of a special variable *VS*. (volatile nil) ;;; whether there is a possible setjmp (changed-array (mia 10 0)) ;;; List of var-objects changed by the form. (referred-array (mia 10 0)) ;;; List of var-objects referred in the form. ) (defun copy-array (array) (declare ((vector t) array)) (let ((new-array (mia (the fixnum (array-total-size array)) (length array)))) (declare ((vector t) new-array)) (do ((i 0 (1+ i))) ((>= i (length array)) new-array) (declare (fixnum i)) (setf (aref new-array i) (aref array i))))) (defun copy-info (info) (let ((new-info (old-copy-info info))) (setf (info-referred-array new-info) (copy-array (info-referred-array info))) (setf (info-changed-array new-info) (copy-array (info-changed-array info))) new-info)) (defun bsearchleq (x a i j le) (declare (object x le) ((vector t) a) (fixnum i j)) (when (eql i j) (return-from bsearchleq (if (or le (and (< i (length a)) (eq x (aref a i)))) i (length a)))) (let* ((k (the fixnum (+ i (the fixnum (ash (the fixnum (- j i) ) -1))))) (y (aref a k))) (declare (fixnum k) (object y)) (cond ((si::objlt x y) (bsearchleq x a i k le)) ((eq x y) k) (t (bsearchleq x a (1+ k) j le))))) (defun push-array (x ar s lin) (declare (object x lin) ((vector t) ar) (fixnum s) (ignore lin)) ; (j (if lin ; (do ((k s (1+ k))) ((or (eql k (length ar)) (si::objlt x (aref ar k)) (eq x (aref ar k))) k) ; (declare (fixnum k))) ; (bsearchleq x ar s (length ar))))) (let ((j (bsearchleq x ar s (length ar) t))) (declare (fixnum j)) (when (and (< j (length ar)) (eq (aref ar j) x)) (return-from push-array -1)) (let ((ar (if (eql (length ar) (the fixnum (array-total-size ar))) (adjust-array ar (the fixnum (* 2 (length ar)))) ar))) (declare ((vector t) ar)) (do ((i (length ar) (1- i))) ((<= i j)) (declare (fixnum i)) (setf (aref ar i) (aref ar (the fixnum (1- i))))) (setf (aref ar j) x) (setf (fill-pointer ar) (the fixnum (1+ (length ar)))) j))) (defmacro do-array ((v oar) &rest body) (let ((count (gensym)) (ar (gensym))) `(let* ((,ar ,oar)) (declare ((vector t) ,ar)) (do ((,count 0 (1+ ,count))) ((eql ,count (length ,ar))) (declare (fixnum ,count)) (let ((,v (aref ,ar ,count))) ,@body))))) (defmacro in-array (v ar) `(< (bsearchleq ,v ,ar 0 (length ,ar) nil) (length ,ar))) (defmacro do-referred ((v info) &rest body) `(do-array (,v (info-referred-array ,info)) ,@body)) (defmacro do-changed ((v info) &rest body) `(do-array (,v (info-changed-array ,info)) ,@body)) (defmacro is-referred (var info) `(in-array ,var (info-referred-array ,info))) (defmacro is-changed (var info) `(in-array ,var (info-changed-array ,info))) (defmacro push-referred (var info) `(push-array ,var (info-referred-array ,info) 0 nil)) (defmacro push-changed (var info) `(push-array ,var (info-changed-array ,info) 0 nil)) (defmacro push-referred-with-start (var info s lin) `(push-array ,var (info-referred-array ,info) ,s ,lin)) (defmacro push-changed-with-start (var info s lin) `(push-array ,var (info-changed-array ,info) ,s ,lin)) (defmacro changed-length (info) `(length (info-changed-array ,info))) (defmacro referred-length (info) `(length (info-referred-array ,info))) (defvar *info* (make-info)) (defun mlin (x y) (declare (fixnum x y)) (when (<= y 3) (return-from mlin nil)) (let ((ly (do ((tl y (ash tl -1)) (k -1 (1+ k))) ((eql tl 0) k) (declare (fixnum k tl))))) (declare (fixnum ly)) (let ((lyr (the fixnum (truncate y (the fixnum (1- ly)))))) (declare (fixnum lyr)) (> x (the fixnum (1+ lyr)))))) (defun add-info (to-info from-info) ;; Allow nil from-info without error CM 20031030 (unless from-info (return-from add-info to-info)) (let* ((s 0) (lin)); (mlin (changed-length from-info) (changed-length to-info)))) (declare (fixnum s) (object lin)) (do-changed (v from-info) (let ((res (push-changed-with-start v to-info s lin))) (declare (fixnum res)) (when (>= res 0) (setq s (the fixnum (1+ res))))))) (let* ((s 0) (lin)); (mlin (referred-length from-info) (referred-length to-info)))) (declare (fixnum s) (object lin)) (do-referred (v from-info) (let ((res (push-referred-with-start v to-info s lin))) (declare (fixnum res)) (when (>= res 0) (setq s (the fixnum (1+ res))))))) (when (info-sp-change from-info) (setf (info-sp-change to-info) t)) ;; Return to-info, CM 20031030 to-info) (defun args-info-changed-vars (var forms) (case (var-kind var) ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) (dolist** (form forms) (when (is-changed var (cadr form)) (return-from args-info-changed-vars t)))) (REPLACED nil) (t (dolist** (form forms nil) (when (or (is-changed var (cadr form)) (info-sp-change (cadr form))) (return-from args-info-changed-vars t))))) ) ;; Variable references in arguments can also be via replaced variables ;; (see gcl_cmplet.lsp) It appears that this is not necessary when ;; checking for changed variables, as matches would appear to require ;; that the variable not be replaced. It might be better to provide a ;; new slot in the var structure to point to the variable by which one ;; is replaced -- one would need to consider chains in such a case. ;; Here we match on the C variable reference, which should be complete. ;; 20040306 CM (defun var-rep-loc (x) (and (eq (var-kind x) 'replaced) (consp (var-loc x)) ;; may not be necessary, but vars can also be replaced to 'locations ;; see gcl_cmplet.lsp (cadr (var-loc x)))) (defun is-rep-referred (var info) (let ((rx (var-rep-loc var))) (do-referred (v info) (let ((ry (var-rep-loc v))) (when (or (eql-not-nil (var-loc var) ry) (eql-not-nil (var-loc v) rx) (eql-not-nil rx ry)) (return-from is-rep-referred t)))))) (defun args-info-referred-vars (var forms) (case (var-kind var) ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) (dolist** (form forms nil) (when (or (is-referred var (cadr form)) (is-rep-referred var (cadr form))) (return-from args-info-referred-vars t)))) (t (dolist** (form forms nil) (when (or (is-referred var (cadr form)) (is-rep-referred var (cadr form)) (info-sp-change (cadr form))) (return-from args-info-referred-vars t)))) )) ;;; Valid property names for open coded functions are: ;;; INLINE ;;; INLINE-SAFE safe-compile only ;;; INLINE-UNSAFE non-safe-compile only ;;; ;;; Each property is a list of 'inline-info's, where each inline-info is: ;;; ( types { type | boolean } side-effect new-object { string | function } ). ;;; ;;; For each open-codable function, open coding will occur only if there exits ;;; an appropriate property with the argument types equal to 'types' and with ;;; the return-type equal to 'type'. The third element ;;; is T if and only if side effects may occur by the call of the function. ;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side ;;; effects must be included in the compiled code. ;;; The forth element is T if and only if the result value is a new Lisp ;;; object, i.e., it must be explicitly protected against GBC. (defvar *inline-functions* nil) (defvar *inline-blocks* 0) ;;; *inline-functions* holds: ;;; (...( function-name . inline-info )...) ;;; ;;; *inline-blocks* holds the number of temporary cvars used to save ;;; intermediate results during evaluation of inlined function calls. ;;; This variable is used to close up blocks introduced to declare static ;;; c variables. (defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer)) (defun inc-inline-blocks() (cond ((consp *inline-blocks*) (incf (car *inline-blocks*))) (t (incf *inline-blocks*)))) (defun inline-args (forms types &optional fun &aux (locs nil) ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) (nreverse locs)) (declare (object forms types)) (let ((form (car forms)) (type (car types))) (declare (object form type)) (case (car form) (LOCATION (push (coerce-loc (caddr form) type) locs)) (VAR (cond ((args-info-changed-vars (caaddr form) (cdr forms)) (cond ((and (member (var-kind (caaddr form)) *special-types*) (eq type (var-kind (caaddr form)))) (let ((cvar (next-cvar))) (wt-nl "{" (rep-type type) "V" cvar "= V" (var-loc (caaddr form)) ";") (push (list 'cvar cvar 'inline-args) locs) (inc-inline-blocks))) (t (let ((temp (wt-c-push))) (wt-nl temp "= ") (wt-var (caaddr form) (cadr (caddr form))) (wt ";") (push (coerce-loc temp type) locs))))) ((and (member (var-kind (caaddr form)) '(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER)) (not (eq type (var-kind (caaddr form))))) (let ((temp (cs-push type))) (wt-nl "V" temp " = " (coerce-loc (cons 'var (caddr form)) type) ";") (push (list 'cvar temp) locs))) (t (push (coerce-loc (cons 'VAR (caddr form)) type) locs)))) (CALL-GLOBAL (if (let ((fname (caddr form))) (and (inline-possible fname) (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)))) (progn (save-avma ii) t))) (let ((loc (get-inline-loc ii (cadddr form)))) (cond ((or (and (flag-p (caddr ii) ans)(not *c-gc*)) ; returns new object (and (member (cadr ii) '(FIXNUM LONG-FLOAT SHORT-FLOAT)) (not (eq type (cadr ii))))) (let ((temp (cs-push type))) (wt-nl "V" temp " = " (coerce-loc loc type) ";") (push (list 'cvar temp) locs)) ) ((or (need-to-protect (cdr forms) (cdr types)) ;;if either new form or side effect, ;;we don't want double evaluation (and (flag-p (caddr ii) allocates-new-storage) (or (null fun) ;; Any fun such as list,list* which ;; does not cause side effects or ;; do double eval (ie not "@..") ;; could go here. (not (si::memq fun '(list-inline list*-inline))))) (flag-p (caddr ii) is) (and (flag-p (caddr ii) set) ; side-effectp (not (null (cdr forms))))) (let (cvar) (cond ((eq type t) (setq cvar (cs-push)) (wt-nl "V" cvar "= ") (wt-loc loc)) (t (setq cvar (next-cvar)) (wt-nl "{" (rep-type type) "V" cvar "= ") (case type (fixnum (wt-fixnum-loc loc)) (integer (wt-integer-loc loc 'inline-args)) (character (wt-character-loc loc)) (long-float (wt-long-float-loc loc)) (short-float (wt-short-float-loc loc)) (otherwise (wt-loc loc))) (inc-inline-blocks))) (wt ";") (push (list 'cvar cvar 'inline-args) locs) )) (t (push (coerce-loc loc type) locs)))) (let ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push))))) (let ((*value-to-go* temp)) (c2expr* form)) (push (coerce-loc temp type) locs)))) (structure-ref (push (coerce-loc-structure-ref (cdr form) type) locs)) (SETQ (let ((vref (caddr form)) (form1 (cadddr form))) (let ((*value-to-go* (cons 'var vref))) (c2expr* form1)) (cond ((eq (car form1) 'LOCATION) (push (coerce-loc (caddr form1) type) locs)) (t (setq forms (list* form (list 'VAR (cadr form) vref) (cdr forms))) ;; want (setq types (list* type type (cdr types))) ;; but type is first of types (setq types (list* type types)))))) (t (let ((temp (cond (*c-gc* (cond ((eq type t) (list 'cvar (cs-push))) (t (push (cons type (next-cvar)) *c-vars*) (list 'var (make-var :type type :kind (if (member type *special-types*) type 'object) :loc (cdar *c-vars*)) nil )))) (t (list 'vs (vs-push)))))) (let ((*value-to-go* temp)) (c2expr* form) (push (coerce-loc temp type) locs)))))))) (defun coerce-loc (loc type) (case type (fixnum (list 'FIXNUM-LOC loc)) (integer (list 'integer-loc loc )) (character (list 'CHARACTER-LOC loc)) (long-float (list 'LONG-FLOAT-LOC loc)) (short-float (list 'SHORT-FLOAT-LOC loc)) (t loc))) (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs) ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*. (setq locs (inline-args args (car ii) fun)) (when (and (stringp fun) (char= (char (the string fun) 0) #\@)) (let ((i 1) (saves nil)) (declare (fixnum i)) (do ((char (char (the string fun) i) (char (the string fun) i))) ((char= char #\;) (incf i)) (declare (character char)) (push (the fixnum (- (char-code char) #.(char-code #\0))) saves) (incf i)) (do ((l locs (cdr l)) (n 0 (1+ n)) (locs1 nil)) ((endp l) (setq locs (nreverse locs1))) (declare (fixnum n) (object l)) (if (member n saves) (let* ((loc1 (car l)) (loc loc1) (coersion nil)) (declare (object loc loc1)) (when (and (consp loc1) (member (car loc1) '(FIXNUM-LOC integer-loc CHARACTER-LOC LONG-FLOAT-LOC SHORT-FLOAT-LOC))) (setq coersion (car loc1)) (setq loc (cadr loc1)) ; remove coersion ) (cond ((and (consp loc) (or (member (car loc) '(INLINE INLINE-COND)) (and (member (car loc) '( INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)) (or (flag-p (cadr loc) allocates-new-storage) (flag-p (cadr loc) side-effect-p)) ))) (wt-nl "{") (inc-inline-blocks) (let ((cvar (next-cvar))) (push (list 'CVAR cvar) locs1) (case coersion ((nil) (wt "object V" cvar "= ") (wt-loc loc1)) (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc)) (integer-loc (wt "MP_INT * V" cvar "= ") (wt-integer-loc loc 'get-inline-locs)) (CHARACTER-LOC (wt "unsigned char V" cvar "= ") (wt-character-loc loc)) (LONG-FLOAT-LOC (wt "double V" cvar "= ") (wt-long-float-loc loc)) (SHORT-FLOAT-LOC (wt "float V" cvar "= ") (wt-short-float-loc loc)) (t (baboon)))) (wt ";") ) (t (push loc1 locs1)))) (push (car l) locs1))))) (list (inline-type (cadr ii)) (caddr ii) fun locs) ) (defvar *inline-types* '((boolean . INLINE-COND) (fixnum . INLINE-FIXNUM) (character . INLINE-CHARACTER) (long-float . INLINE-LONG-FLOAT) (short-float . INLINE-SHORT-FLOAT) (integer . INLINE-INTEGER) (t . INLINE))) (defun inline-type (type) (or (cdr (assoc type *inline-types* :test 'eq)) 'inline)) (defun get-inline-info (fname args return-type &aux x ii) (and (fast-link-proclaimed-type-p fname args) (add-fast-link fname return-type args)) (setq args (mapcar #'(lambda (form) (info-type (cadr form))) args)) (when (if *safe-compile* (setq x (get fname 'inline-safe)) (setq x (get fname 'inline-unsafe))) (dolist** (y x nil) (when (setq ii (inline-type-matches y args return-type)) (return-from get-inline-info ii)))) (when (setq x (get fname 'inline-always)) (dolist** (y x) (when (setq ii (inline-type-matches y args return-type)) (return-from get-inline-info ii)))) (dolist* (x *inline-functions*) (when (and (eq (car x) fname) (setq ii (inline-type-matches (cdr x) args return-type))) (return-from get-inline-info ii))) nil) (defun inline-type-matches (inline-info arg-types return-type &aux (rts nil)) (if (not (typep (third inline-info) 'fixnum)) (fix-opt inline-info)) (if (member 'integer (car inline-info)) (return-from inline-type-matches nil)) (if (and (let ((types (car inline-info))) (declare (object types)) (dolist** (arg-type arg-types (or (equal types '(*)) (endp types))) (when (endp types) (return nil)) (cond ((equal types '(*)) (setq types '(t *)))) (cond ((eq (car types) 'fixnum-float) (cond ((type>= 'fixnum arg-type) (push 'fixnum rts)) ((type>= 'long-float arg-type) (push 'long-float rts)) ((type>= 'short-float arg-type) (push 'short-float rts)) (t (return nil)))) ((type>= (car types) arg-type) (push (car types) rts)) (t (return nil))) (pop types))) (type>= (cadr inline-info) return-type)) (cons (nreverse rts) (cdr inline-info)) nil) ) (defun need-to-protect (forms types &aux ii) (do ((forms forms (cdr forms)) (types types (cdr types))) ((endp forms) nil) (declare (object forms types)) (let ((form (car forms))) (declare (object form)) (case (car form) (LOCATION) (VAR (when (or (args-info-changed-vars (caaddr form) (cdr forms)) (and (member (var-kind (caaddr form)) '(FIXNUM LONG-FLOAT SHORT-FLOAT)) (not (eq (car types) (var-kind (caaddr form)))))) (return t))) (CALL-GLOBAL (let ((fname (caddr form))) (declare (object fname)) (when (or (not (inline-possible fname)) (null (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form))))) (flag-p (caddr ii) allocates-new-storage) (flag-p (caddr ii) set) (flag-p (caddr ii) is) (and (member (cadr ii) '(fixnum long-float short-float)) (not (eq (car types) (cadr ii)))) (need-to-protect (cadddr form) (car ii))) (return t)))) (structure-ref (when (need-to-protect (list (caddr form)) '(t)) (return t))) (t (return t))))) ) (defun wt-c-push () (cond (*c-gc* (inc-inline-blocks) (let ((tem (next-cvar))) (wt "{" *volatile* "object V" tem ";") (list 'cvar tem))) (t (list 'VS (vs-push))))) (defun close-inline-blocks ( &aux (bl *inline-blocks*)) (when (consp bl) (if (eql (cdr bl) 'restore-avma) (wt "restore_avma;")) (setq bl (car bl))) (dotimes** (i bl) (wt "}"))) (si:putprop 'inline 'wt-inline 'wt-loc) (si:putprop 'inline-cond 'wt-inline-cond 'wt-loc) (si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc) (si:putprop 'inline-integer 'wt-inline-integer 'wt-loc) (si:putprop 'inline-character 'wt-inline-character 'wt-loc) (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc) (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc) (defun wt-inline-loc (fun locs &aux (i 0) (max -1)) (declare (fixnum i max)) (cond ((stringp fun) (when (char= (char (the string fun) 0) #\@) (setq i 1) (do () ((char= (char (the string fun) i) #\;) (incf i)) (incf i))) (do ((size (length (the string fun)))) ((>= i size)) (declare (fixnum size )) (let ((char (char (the string fun) i))) (declare (character char)) (cond ((char= char #\#) (let ((ch (char (the string fun) (the fixnum (1+ i)))) (n 0)) (cond ((or (eql ch #\*) (eql ch #\?));#? ensures 'first' vararg is initialized (let* ((f (char= (char fun (1- i)) #\()) (e (char= (char fun (+ 2 i)) #\))) (locs (nthcdr (1+ max) locs)) (locs (or locs (when (eql ch #\?) `((fixnum-value nil 0)))))) (dolist (v locs (unless (or f e) (wt ","))) (unless f (wt ",")) (setq f nil) (wt-loc v)))) ((digit-char-p ch 10) (setq n (- (char-code ch) (char-code #\0))) (when (and (> (length fun) (+ i 2)) (progn (setq ch (char (the string fun) (+ i 2))) (digit-char-p ch))) (setq n (+ (* n 10) (- (char-code ch) (char-code #\0)))) (incf i)) (cond ((>= n max) (setq max n))) (wt-loc (nth n locs))))) (incf i 2)) (t (princ char *compiler-output1*) (incf i))))) ) (t (apply fun locs)))) (defun wt-inline (side-effectp fun locs) (declare (ignore side-effectp)) (wt-inline-loc fun locs)) (defun wt-inline-cond (side-effectp fun locs) (declare (ignore side-effectp)) (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)")) (defun wt-inline-fixnum (side-effectp fun locs) (declare (ignore side-effectp)) (when (zerop *space*) (wt "CMP")) (wt "make_fixnum((long)(") (wt-inline-loc fun locs) (wt "))")) (defun wt-inline-integer (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_integer(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-character (side-effectp fun locs) (declare (ignore side-effectp)) (wt "code_char(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-long-float (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")")) (defun wt-inline-short-float (side-effectp fun locs) (declare (ignore side-effectp)) (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")")) (defun args-cause-side-effect (forms &aux ii) (dolist** (form forms nil) (case (car form) ((LOCATION VAR structure-ref)) (CALL-GLOBAL (let ((fname (caddr form))) (declare (object fname)) (unless (and (inline-possible fname) (setq ii (get-inline-info fname (cadddr form) (info-type (cadr form)))) (progn (fix-opt ii) (not (flag-p (caddr ii) side-effect-p))) ) (return t)))) (otherwise (return t))))) ;;; Borrowed from CMPOPT.LSP (defun list-inline (&rest x &aux tem (n (length x))) (cond ((setq tem (and (consp *value-to-go*) (eq (car *value-to-go*) 'var) (eq (var-type (second *value-to-go*)) :dynamic-extent))) (wt "(ALLOCA_CONS(" n "),ON_STACK_LIST(" n)) (t (wt "list(" (length x)))) (dolist (loc x) (wt #\, loc)) (wt #\)) (if tem (wt #\))) ) (defun list*-inline (&rest x) (case (length x) (1 (wt (car x))) (2 (wt "make_cons(" (car x) "," (cadr x) ")")) (otherwise (wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))))) ;;; Borrowed from LFUN_LIST.LSP (defun defsysfun (fname cname-string arg-types return-type never-change-special-var-p predicate) ;;; The value NIL for each parameter except for fname means "not known". (when cname-string (si:putprop fname cname-string 'Lfun)) (when arg-types (si:putprop fname (mapcar #'(lambda (x) (if (eq x '*) '* (type-filter x))) arg-types) 'arg-types)) (when return-type (let ((rt (function-return-type (if (atom return-type) (list return-type) return-type)))) (or (consp rt) (setq rt (list rt))) (si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt)) 'return-type))) (when never-change-special-var-p (si:putprop fname t 'no-sp-change)) (when predicate (si:putprop fname t 'predicate)) ) gcl-2.6.14/cmpnew/gcl_cmpif.lsp0000755000175000017500000003761314360276512014744 0ustar cammcamm;;; CMPIF Conditionals. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'if 'c1if 'c1special) (si:putprop 'if 'c2if 'c2) (si:putprop 'and 'c1and 'c1) (si:putprop 'and 'c2and 'c2) (si:putprop 'or 'c1or 'c1) (si:putprop 'or 'c2or 'c2) (si:putprop 'jump-true 'set-jump-true 'set-loc) (si:putprop 'jump-false 'set-jump-false 'set-loc) (si:putprop 'case 'c1case 'c1) (si:putprop 'ecase 'c1ecase 'c1) (si:putprop 'case 'c2case 'c2) (defun c1if (args &aux info f) (when (or (endp args) (endp (cdr args))) (too-few-args 'if 2 (length args))) (unless (or (endp (cddr args)) (endp (cdddr args))) (too-many-args 'if 3 (length args))) (setq f (c1fmla-constant (car args))) (case f ((t) (c1expr (cadr args))) ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) (otherwise (setq info (make-info)) (list 'if info (c1fmla f info) (c1expr* (cadr args) info) (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info))))) ) (defun c1fmla-constant (fmla &aux f) (cond ((consp fmla) (case (car fmla) (and (do ((fl (cdr fmla) (cdr fl))) ((endp fl) t) (declare (object fl)) (setq f (c1fmla-constant (car fl))) (case f ((t)) ((nil) (return nil)) (t (if (endp (cdr fl)) (return f) (return (list* 'and f (cdr fl)))))))) (or (do ((fl (cdr fmla) (cdr fl))) ((endp fl) nil) (declare (object fl)) (setq f (c1fmla-constant (car fl))) (case f ((t) (return t)) ((nil)) (t (if (endp (cdr fl)) (return f) (return (list* 'or f (cdr fl)))))))) ((not null) (when (endp (cdr fmla)) (too-few-args 'not 1 0)) (unless (endp (cddr fmla)) (too-many-args 'not 1 (length (cdr fmla)))) (setq f (c1fmla-constant (cadr fmla))) (case f ((t) nil) ((nil) t) (t (list 'not f)))) (t fmla))) ((symbolp fmla) (if (constantp fmla) (if (symbol-value fmla) t nil) fmla)) (t t)) ) (defun c1fmla (fmla info) (if (consp fmla) (case (car fmla) (and (case (length (cdr fmla)) (0 (c1t)) (1 (c1fmla (cadr fmla) info)) (t (cons 'FMLA-AND (mapcar #'(lambda (x) (c1fmla x info)) (cdr fmla)))))) (or (case (length (cdr fmla)) (0 (c1nil)) (1 (c1fmla (cadr fmla) info)) (t (cons 'FMLA-OR (mapcar #'(lambda (x) (c1fmla x info)) (cdr fmla)))))) ((not null) (when (endp (cdr fmla)) (too-few-args 'not 1 0)) (unless (endp (cddr fmla)) (too-many-args 'not 1 (length (cdr fmla)))) (list 'FMLA-NOT (c1fmla (cadr fmla) info))) (t (c1expr* `(the boolean ,fmla) info))) (c1expr* fmla info)) ) (defun c2if (fmla form1 form2 &aux (Tlabel (next-label)) Flabel) (cond ((and (eq (car form2) 'LOCATION) (null (caddr form2)) (eq *value-to-go* 'TRASH) (not (eq *exit* 'RETURN))) (let ((exit *exit*) (*unwind-exit* (cons Tlabel *unwind-exit*)) (*exit* Tlabel)) (CJF fmla Tlabel exit)) (wt-label Tlabel) (c2expr form1)) (t (setq Flabel (next-label)) (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*))) (*exit* Tlabel)) (CJF fmla Tlabel Flabel)) (wt-label Tlabel) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1)) (wt-label Flabel) (c2expr form2))) ) ;;; If fmla is true, jump to Tlabel. If false, do nothing. (defun CJT (fmla Tlabel Flabel) (case (car fmla) (fmla-and (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJT (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJF (car fs) label Flabel) (wt-label label)))) (fmla-or (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJT (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJT (car fs) Tlabel label) (wt-label label)))) (fmla-not (CJF (cadr fmla) Flabel Tlabel)) (LOCATION (case (caddr fmla) ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel)) ((nil)) (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))) (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla)))) ) ;;; If fmla is false, jump to Flabel. If true, do nothing. (defun CJF (fmla Tlabel Flabel) (case (car fmla) (FMLA-AND (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJF (car fs) label Flabel) (wt-label label)))) (FMLA-OR (do ((fs (cdr fmla) (cdr fs))) ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) (declare (object fs)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (CJT (car fs) Tlabel label) (wt-label label)))) (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel)) (LOCATION (case (caddr fmla) ((t)) ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel)) (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))) (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla)))) ) (defun c1and (args) (cond ((endp args) (c1t)) ((endp (cdr args)) (c1expr (car args))) (t (let ((info (make-info))) (list 'AND info (c1args args info)))))) (defun c2and (forms) (do ((forms forms (cdr forms))) ((endp (cdr forms)) (c2expr (car forms))) (declare (object forms)) (cond ((eq (caar forms) 'LOCATION) (case (caddar forms) ((t)) ((nil) (unwind-exit nil 'JUMP)) (t (wt-nl "if(" (caddar forms) "==Cnil){") (unwind-exit nil 'JUMP) (wt "}") ))) ((eq (caar forms) 'VAR) (wt-nl "if(") (wt-var (car (caddar forms)) (cadr (caddar forms))) (wt "==Cnil){") (unwind-exit nil 'jump) (wt "}")) (t (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (let ((*value-to-go* (list 'jump-true label))) (c2expr* (car forms))) (unwind-exit nil 'jump) (wt-label label)))) )) (defun c1or (args) (cond ((endp args) (c1nil)) ((endp (cdr args)) (c1expr (car args))) (t (let ((info (make-info))) (list 'OR info (c1args args info)))))) (defun c2or (forms &aux (*vs* *vs*) temp) (do ((forms forms (cdr forms)) ) ((endp (cdr forms)) (c2expr (car forms))) (declare (object forms)) (cond ((eq (caar forms) 'LOCATION) (case (caddar forms) ((t) (unwind-exit t 'JUMP)) ((nil)) (t (wt-nl "if(" (caddar forms) "!=Cnil){") (unwind-exit (caddar forms) 'JUMP) (wt "}")))) ((eq (caar forms) 'VAR) (wt-nl "if(") (wt-var (car (caddar forms)) (cadr (caddar forms))) (wt "!=Cnil){") (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}")) ((and (eq (caar forms) 'CALL-GLOBAL) (get (caddar forms) 'predicate)) (let* ((label (next-label)) (*unwind-exit* (cons label *unwind-exit*))) (let ((*value-to-go* (list 'jump-false label))) (c2expr* (car forms))) (unwind-exit t 'jump) (wt-label label))) (t (let* ((label (next-label)) (*inline-blocks* 0) (*unwind-exit* (cons label *unwind-exit*))) (setq temp (wt-c-push)) (let ((*value-to-go* temp)) (c2expr* (car forms))) (wt-nl "if(" temp "==Cnil)") (wt-go label) (unwind-exit temp 'jump) (wt-label label) (close-inline-blocks) ))) ) ) (defun set-jump-true (loc label) (unless (null loc) (cond ((eq loc t)) ((and (consp loc) (eq (car loc) 'INLINE-COND)) (wt-nl "if(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt ")")) (t (wt-nl "if((" loc ")!=Cnil)"))) (unless (eq loc t) (wt "{")) (unwind-no-exit label) (wt-nl) (wt-go label) (unless (eq loc t) (wt "}"))) ) (defun set-jump-false (loc label) (unless (eq loc t) (cond ((null loc)) ((and (consp loc) (eq (car loc) 'INLINE-COND)) (wt-nl "if(!(") (wt-inline-loc (caddr loc) (cadddr loc)) (wt "))")) (t (wt-nl "if((" loc ")==Cnil)"))) (unless (null loc) (wt "{")) (unwind-no-exit label) (wt-nl) (wt-go label) (unless (null loc) (wt "}"))) ) (defun c1ecase (args) (c1case args t)) ;;If the key is declared fixnum, then we convert a case statement to a switch, ;;so that we may see the benefit of a table jump. (defun convert-case-to-switch (args default) (let ((sym (gensym)) body keys) (dolist (v (cdr args)) (cond ((si::fixnump (car v)) (push (car v) body)) ((consp (car v))(dolist (w (car v)) (push w body))) ((member (car v) '(t otherwise)) (and default (cmperror "T or otherwise found in an ecase")) (push t body))) (push `(return-from ,sym (progn ,@ (cdr v))) body)) (cond (default (push t body) (dolist (v (cdr args)) (cond ((atom (car v)) (push (car v) keys)) (t (setq keys (append (car v) keys))))) (push `(error "The key ~a for ECASE was not found in cases ~a" ,(car args) ',keys) body))) `(block ,sym (si::switch ,(car args) ,@ (nreverse body))))) (defun c1case (args &optional (default nil)) (when (endp args) (too-few-args 'case 1 0)) (let* ((info (make-info)) (key-form (c1expr* (car args) info)) clauses) (cond ((subtypep (info-type (second key-form)) 'fixnum) (return-from c1case (c1expr (convert-case-to-switch args default ))))) (do ((c (cdr args) (cdr c))) ((not c)) (let* ((clause (car c))) (cmpck (endp clause) "The CASE clause ~S is illegal." clause) (let* ((k (pop clause))(dfp (unless default (member k '(t otherwise)))) (keylist (cond ((listp k) (mapcar (lambda (key) (if (symbolp key) key (add-object key))) k)) ((symbolp k) (when dfp (when (cdr c) (cmperr "default case found in bad place"))) (list k)) ((list (add-object k))))) (body (c1progn clause))) (add-info info (cadr body)) (if dfp (setq default body) (push (cons keylist body) clauses))))) (list 'case info key-form (nreverse clauses) (or default (c1nil))))) ;; (defun c1case (args &optional (default nil)) ;; (when (endp args) (too-few-args 'case 1 0)) ;; (let* ((info (make-info)) ;; (key-form (c1expr* (car args) info)) ;; (clauses nil)) ;; (cond ((subtypep (info-type (second key-form)) 'fixnum) ;; (return-from c1case (c1expr (convert-case-to-switch ;; args default ))))) ;; (dolist (clause (cdr args)) ;; (cmpck (endp clause) "The CASE clause ~S is illegal." clause) ;; (case (car clause) ;; ((nil)) ;; ((t otherwise) ;; (when default ;; (cmperr (if (eq default 't) ;; "ECASE had an OTHERWISE clause." ;; "CASE had more than one OTHERWISE clauses."))) ;; (setq default (c1progn (cdr clause))) ;; (add-info info (cadr default))) ;; (t (let* ((keylist ;; (cond ((consp (car clause)) ;; (mapcar #'(lambda (key) (if (symbolp key) key ;; (add-object key))) ;; (car clause))) ;; ((symbolp (car clause)) (list (car clause))) ;; (t (list (add-object (car clause)))))) ;; (body (c1progn (cdr clause)))) ;; (add-info info (cadr body)) ;; (push (cons keylist body) clauses))))) ;; (list 'case info key-form (reverse clauses) (or default (c1nil))))) (defun c2case (key-form clauses default &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0)) (setq key-form (car (inline-args (list key-form) '(t)))) (wt-nl "{object V" cvar "= " key-form ";") (dolist (clause clauses) (let* ((label (next-label)) (keylist (car clause)) (local-label nil)) (do () ((<= (length keylist) 5)) (when (null local-label) (setq local-label (next-label))) (wt-nl "if(") (dotimes (i 5) (cond ((symbolp (car keylist)) (wt "(V" cvar "== ") (case (car keylist) ((t) (wt "Ct")) ((nil) (wt "Cnil")) (otherwise (wt (vv-str (add-symbol (car keylist)))))) (wt ")")) (t (wt "eql(V" cvar "," (vv-str (car keylist)) ")"))) (when (< i 4) (wt-nl "|| ")) (pop keylist)) (wt ")") (wt-go local-label)) (when keylist (wt-nl "if(") (do () ((endp keylist)) (cond ((symbolp (car keylist)) (wt "(V" cvar "!= ") (case (car keylist) ((t) (wt "Ct")) ((nil) (wt "Cnil")) (otherwise (wt (vv-str (add-symbol (car keylist)))))) (wt ")")) (t (wt "!eql(V" cvar "," (vv-str (car keylist)) ")"))) (unless (endp (cdr keylist)) (wt-nl "&& ")) (pop keylist)) (wt ")") (wt-go label) (when local-label (wt-label local-label)) (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause))) (wt-label label)))) (if (eq default 't) (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");") (c2expr default)) (wt "}") (close-inline-blocks)) gcl-2.6.14/cmpnew/gcl_cmptop.lsp0000755000175000017500000016533514360276512015153 0ustar cammcamm;;; CMPTOP Compiler top-level. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar *objects* (make-hash-table :test 'eq)) ;(defvar *objects* nil) (defvar *constants* nil) (defvar *sharp-commas* nil) (defvar *function-links* nil) (defvar *c-gc* t) ;if we gc the c stack. (defvar *c-vars*) ;list of *c-vars* to put at beginning of function. ;;number of address registers available not counting the ;;frame pointer and the stack pointer ;;If sup and base are used, then their are even 2 less ;;To do: If the regs hold data then there are really more available; (defvar *free-address-registers* 5) (defvar *free-data-registers* 6) ;;Inside t3defun this collects the list of downward closures defined. (defvar *downward-closures* nil) (defvar *volatile*) (defvar *setjmps* 0) ;; Functions may use a block of C stack space. ;; (cs . i) will become Vcs[i]. (defvar *cs* 0) ;; Holds list of local-functions resulting from c1function of ;; a lambda. Is used to eliminate mix of downward and regular closures. (defvar *local-functions* nil) ;;; *objects* holds ( { object vv-index }* ). ;;; *constants* holds ( { symbol vv-index }* ). ;;; *sharp-commas* holds ( vv-index* ), indicating that the value ;;; of each vv should be turned into an object from a string before ;;; defining the current function during loading process, so that ;;; sharp-comma-macros may be evaluated correctly. ;;; *function-links* ( {symbol vv-index} ) for function symbols needing link (defvar *global-funs* nil) ;;; *global-funs* holds ;;; ( { global-fun-name cfun }* ) (defvar *closures* nil) (defvar *local-funs* nil) ;;; *closure* holds fun-objects for closures. (defvar *top-level-forms* nil) ;;; *top-level-forms* holds ( { top-level-form }* ). ;;; ;;; top-level-form: ;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp) ;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp) ;;; | ( 'ORDINARY' cfun expr) ;;; | ( 'DECLARE' var-name-vv ) ;;; | ( 'DEFVAR' var-name-vv expr doc-vv) ;;; | ( 'CLINES' string ) ;;; | ( 'DEFCFUN' header vs-size body) ;;; | ( 'DEFENTRY' fun-name cfun cvspecs type cfun-name ) ;;; | ( 'SHARP-COMMA' vv ) (defvar *reservations* nil) (defvar *reservation-cmacro* nil) ;;; *reservations* holds (... ( cmacro . value ) ...). ;;; *reservation-cmacro* holds the cmacro current used as vs reservation. (defvar *global-entries* nil) ;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). ;;; Package operations. (si:putprop 'in-package t 'eval-at-compile) (si:putprop 'si::in-package-internal t 'eval-at-compile) ;;; Pass 1 top-levels. (si:putprop 'eval-when 't1eval-when 't1) (si:putprop 'progn 't1progn 't1) (si:putprop 'macrolet 't1macrolet 't1) (si:putprop 'defun 't1defun 't1) (si:putprop 'defmacro 't1defmacro 't1) (si:putprop 'clines 't1clines 't1) (si:putprop 'defcfun 't1defcfun 't1) (si:putprop 'defentry 't1defentry 't1) (si:putprop 'defla 't1defla 't1) ;;; Top-level macros. (si:putprop 'defconstant t 'top-level-macro) (si:putprop 'defparameter t 'top-level-macro) (si:putprop 'defstruct t 'top-level-macro) (si:putprop 'deftype t 'top-level-macro) (si:putprop 'defsetf t 'top-level-macro) ;;; Pass 2 initializers. (si:putprop 'defun 't2defun 't2) (si:putprop 'progn 't2progn 't2) (si:putprop 'declare 't2declare 't2) (si:putprop 'defentry 't2defentry 't2) (si:putprop 'si:putprop 't2putprop 't2) ;;; Pass 2 C function generators. (si:putprop 'defun 't3defun 't3) (si:putprop 'progn 't3progn 't3) (si:putprop 'ordinary 't3ordinary 't3) (si:putprop 'sharp-comma 't3sharp-comma 't3) (si:putprop 'clines 't3clines 't3) (si:putprop 'defcfun 't3defcfun 't3) (si:putprop 'defentry 't3defentry 't3) (eval-when (compile eval) (defmacro lambda-list (lambda-expr) `(caddr ,lambda-expr)) (defmacro ll-requireds (lambda-list) `(car ,lambda-list)) (defmacro ll-keywords (lambda-list) `(nth 4 ,lambda-list)) (defmacro ll-optionals (lambda-list) `(nth 1 ,lambda-list)) (defmacro ll-keywords-p (lambda-list) `(nth 3 ,lambda-list)) (defmacro ll-rest (lambda-list) `(nth 2 ,lambda-list)) (defmacro ll-allow-other-keys (lambda-list) `(nth 5 ,lambda-list)) (defmacro vargd (min max) `(+ ,min (ash ,max 8))) (defmacro let-pass3 (binds &body body &aux res) (let ((usual '((*c-vars* nil) (*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil) (*unwind-exit* (list *exit*)) (*value-to-go* *exit*) (*reservation-cmacro* (next-cmacro)) (*sup-used* nil) (*restore-avma* nil) (*base-used* nil) (*cs* 0) ))) (dolist (v binds) (or (assoc (car v) usual) (push v usual))) (do ((v (setq usual (copy-list usual)) (cdr v))) ((null v)) (let ((tem (assoc (caar v) binds))) (if tem (setf (car v) tem)))) `(let* ,usual ,@body))) ) ;; FIXME case does not optimize as well (defun dash-to-underscore-int (str beg end) (declare (string str) (fixnum beg end)) (unless (< beg end) (return-from dash-to-underscore-int str)) (let ((ch (aref str beg))) (declare (character ch)) (setf (aref str beg) (cond ((eql ch #\-) #\_) ((eql ch #\/) #\_) ((eql ch #\.) #\_) ((eql ch #\_) #\_) ((eql ch #\!) #\E) ((eql ch #\*) #\A) (t (if (alphanumericp ch) ch #\$))))) (dash-to-underscore-int str (1+ beg) end)) (defun dash-to-underscore (str) (declare (string str)) (let ((new (copy-seq str))) (dash-to-underscore-int new 0 (length new)))) (defun init-name (p &optional sp) (if sp (let* ((p (truename (merge-pathnames p #p".lsp"))) (pn (pathname-name p)) (g (zerop (si::string-match #v"^gcl_" pn)))) (dash-to-underscore (namestring (make-pathname :host (unless g (pathname-host p)) :device (unless g (pathname-device p)) :directory (unless g (pathname-directory p)) :name pn)))) "code")) ;; FIXME consider making this a macro (defun c-function-name (prefix num fname) #-gprof(declare (ignore fname)) (si::string-concatenate (string prefix) (write-to-string num) #+gprof(let ((fname (string fname))) (si::string-concatenate "__" (dash-to-underscore fname) "__" (if (boundp '*compiler-input*) (subseq (init-name *compiler-input* t) 4) ""))))) (defun t1expr (form &aux (*current-form* form) (*first-error* t)) (catch *cmperr-tag* (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (declare (object fun args)) (cond ((symbolp fun) (cond ((eq fun 'si:|#,|) (cmperr "Sharp-comma-macro is in a bad place.")) ((setq fd (get fun 't1)) (when *compile-print* (print-current-form)) (funcall fd args)) ((get fun 'top-level-macro) (when *compile-print* (print-current-form)) (t1expr (cmp-macroexpand-1 form))) ((get fun 'c1) (t1ordinary form)) ((setq fd (or (macro-function fun) (cadr (assoc fun *funs*)))) (let ((res (cmp-expand-macro fd fun (copy-list (cdr form))) )) (t1expr res))) (t (t1ordinary form)) )) ((consp fun) (t1ordinary form)) (t (cmperr "~s is illegal function." fun))) ))) ) (defun declaration-type (type) (cond ((equal type "") "void") ((equal type "long ") "object ") (t type))) (defvar *vaddress-list*) ;; hold addresses of C functions, and other data (defvar *vind*) ;; index in the VV array where the address is. (defvar *Inits*) (defun t23expr (form prop &aux (def (when (consp form) (get (car form) prop))) *local-funs* (*first-error* t) *vcs-used*) (when def (apply def (cdr form))) (when (eq prop 't3) ;;; Local function and closure function definitions. (block nil (loop (when (endp *local-funs*) (return)) (let (*vcs-used*) (apply 't3local-fun (pop *local-funs*))))))) (defun ctop-write (name &aux (*function-links* nil) *c-vars* (*volatile* " VOL ") *vaddress-list* (*vind* 0) *inits* *current-form* *vcs-used*) (declare (special *current-form* *vcs-used*)) (setq *top-level-forms* (nreverse *top-level-forms*)) ;;; Initialization function. (wt-nl1 "void init_" name "(){" #+sgi3d "Init_Links ();" "do_init((void *)VV);" "}") ;; write all the inits. (dolist (*current-form* *top-level-forms*) (t23expr *current-form* 't2)) ;;; C function definitions. (dolist (*current-form* *top-level-forms*) (let* ((inits (data-inits))) (t23expr *current-form* 't3) (unless (or (eq (data-inits) inits) (eq (cdr (data-inits)) inits)) (let ((di (data-inits))) (setf (data-inits) inits) (add-init (cons 'progn (nreverse (mapcar 'cdr (ldiff di inits))))))))) ;;; Global entries for directly called functions. (dolist* (x *global-entries*) (setq *vcs-used* nil) (apply 'wt-global-entry x)) ;;; Fastlinks (dolist* (x *function-links*) (setq *vcs-used* nil) (wt-function-link x)) #+sgi3d (progn (wt-nl1 "" "static void Init_Links () {") (dolist* (x *function-links*) (let ((num (second x))) (wt-nl "Lnk" num " = LnkT" num ";"))) (wt-nl1 "}")) ;;; Declarations in h-file. (dolist* (fun *closures*) (wt-h "static void " (c-function-name "LC" (fun-cfun fun) (fun-name fun)) "();")) (dolist* (x *reservations*) (wt-h "#define VM" (car x) " " (cdr x))) ;;*next-vv* is the index of the last entry pushed onto the data vector ;;*vind* is the index of the next constant to be pushed. ;;make sure enough room in VV to handle *vind* ;;reserve a spot for the Cdata which will be swapped for the (si::%init..): (push-data-incf nil) ;Ensure there is enough room to write t (dotimes (i (- *vind* *next-vv* +1)) (push-data-incf nil)) ;; now *next-vv* >= *vind* ;; reserve space for the Cdata the cfdata object as the ;; last entry in the VV vector. (wt-h "static void * VVi[" (+ 1 *next-vv*) "]={") (wt-h "#define Cdata VV[" *next-vv* "]") (or *vaddress-list* (wt-h 0)) (do ((v (nreverse *Vaddress-List*) (cdr v))) ((null v) (wt-h "};")) (wt-h "(void *)(" (caar v) (if (cdr v) ")," ")"))) (wt-h "#define VV (VVi)") (wt-data-file) ; (break "f") (dolist (x *function-links* ) (let ((num (second x)) (type (third x)) (args (fourth x)) (newtype nil)) (cond ((eq type 'proclaimed-closure) (wt-h "static object Lclptr"num";") (setq newtype "")) (t (setq newtype (if type (Rep-type type) "")))) (if (and (not (null type)) (not (eq type 'proclaimed-closure)) (or args (not (eq t type)))) (progn (wt-h "static " (declaration-type newtype) " LnkT" num "(object,...);") #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = (" (declaration-type newtype) "(*)()) LnkT" num ";") #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")) (progn (wt-h "static " (declaration-type newtype) " LnkT" num "();") #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = LnkT" num ";") #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")))))) ;; this default will be as close to the the decision of the x3j13 committee ;; as I can make it. Valid values of *eval-when-defaults* are ;; a sublist of '(compile eval load) (defvar *eval-when-defaults* nil);:defaults (defun maybe-eval (def form) (when (or def (intersection '(compile :compile-toplevel) *eval-when-defaults*) (let ((c (car form))) (when (symbolp c) (get c 'eval-at-compile)))) (when form (cmp-eval form)) t)) (defun t1eval-when (args &aux load-flag compile-flag) (when (endp args) (too-few-args 'eval-when 1 0)) (dolist (situation (car args)) (case situation ((load :load-toplevel) (setq load-flag t)) ((compile :compile-toplevel) (setq compile-flag t)) ((eval :execute)) (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." situation)))) (let ((*eval-when-defaults* (or *eval-when-defaults* (car args)))) (cond (load-flag (t1progn (cdr args))) (compile-flag (cmp-eval (cons 'progn (cdr args))))))) (defun t1macrolet(args &aux (*funs* *funs*)) (dolist (def (car args)) (push (list (car def) (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) *funs*)) (dolist (form (cdr args)) (t1expr form))) (defvar *compile-ordinaries* nil) (defun t1progn (args) (cond ((equal (car args) ''compile) (let ((*compile-ordinaries* t)) (t1progn (cdr args)))) (t (let ((f *top-level-forms*)) (dolist (form args) (t1expr form)) (setq *top-level-forms* (cons `(progn ,(nreverse (ldiff *top-level-forms* f))) f)))))) (defun t3progn (args) (dolist (arg args) (t23expr arg 't3))) (defun t2progn (args) (dolist (arg args) (t23expr arg 't2))) ;; (defun foo (x) .. -> (defun foo (g102 &aux (x g102)) ... (defun cmpfix-args (args bind &aux tem (lam (copy-list (second args)))) (dolist (v bind) (setq tem (member (car v) lam)) (and tem (setf (car tem) (second v)))) (cond ((setq tem (member '&aux lam)) (setf (cdr tem) (append bind (cdr tem)))) (t (setf lam (append lam (cons '&aux bind))))) (list* (car args) lam (cddr args))) (defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas* nil)) (when (or (endp args) (endp (cdr args))) (too-few-args 'defun 2 (length args))) (cmpck (not (symbolp (car args))) "The function name ~s is not a symbol." (car args)) (unless (macro-function (car args)) (maybe-eval nil (cons 'defun args))) (tagbody top (setq *local-functions* nil) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr (*special-binding* nil) (cfun (or (get (car args) 'Ufun) (next-cfun))) (doc nil) (fname (car args))) (declare (object fname)) (setq lambda-expr (c1lambda-expr (cdr args) fname)) (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) t)) (check-downward (cadr lambda-expr)) ;;provide a simple way for the user to declare functions to ;;have fixed args without having to count them, and make mistakes. (cond ((get fname 'fixed-args) ;the number of regular args in definition (let ((n (length (car (lambda-list lambda-expr))))) (setf (get fname 'fixed-args) n);;for error checking. (proclaim (list 'function fname (make-list n :initial-element t) t))))) (cond ((and (get fname 'proclaimed-function) ;; check the args: (let ((lambda-list (lambda-list lambda-expr))bind) (declare (object lambda-list)) (and (null (cadr lambda-list)) ;;; no optional (null (caddr lambda-list)) ;;; no rest (null (cadddr lambda-list)) ;;; no keyword (< (length (car lambda-list)) call-arguments-limit) ;;; less than 10 requireds ;;; For all required parameters... (do ((vars (car lambda-list) (cdr vars)) (types (get fname 'proclaimed-arg-types) (cdr types)) (problem)) ((endp vars) (and (endp types) (cond (bind (setq args (cmpfix-args args bind)) (go top)) (t (not problem))))) (declare (object vars types)) (let ((var (car vars))) (declare (object var)) (cond ((equal (car types) '*)(return nil))) (unless (and (or (and (or (eq (var-kind var) 'LEXICAL) (and (eq (var-kind var) 'special) (eq (car types) t))) (not (var-ref-ccb var)) (not (eq (var-loc var) 'clb))) (progn (push (list (var-name var) (gensym)) bind) t)) (type-and (car types) (var-type var)) (or (member (car types) '(fixnum character long-float short-float)) (eq (var-loc var) 'object) *c-gc* (not (is-changed var (cadr lambda-expr))))) (unless bind (cmpwarn "Calls to ~a will be VERY SLOW. Recommend not to proclaim. ~%;;The arg caused the problem. ~a" fname (var-name var))) (setq problem t)))) (numberp cfun)))) ;;whew: it is acceptable. (push (list fname (get fname 'proclaimed-arg-types) (get fname 'proclaimed-return-type) (flags set ans) (make-inline-string cfun (get fname 'proclaimed-arg-types) fname)) *inline-functions*)) ((and ;(get fname 'proclaimed-function) (eq (get fname 'proclaimed-return-type) t)) ; (setq me lambda-list) ; (setq me (lambda-list lambda-expr)) ; (print args) )) ;; variable number of args; (when (cadddr lambda-expr) (setq doc (cadddr lambda-expr))) (add-load-time-sharp-comma) (push (list defun fname cfun lambda-expr doc *special-binding*) *top-level-forms*) (push (cons fname cfun) *global-funs*) ))) (defun make-inline-string (cfun args fname) (if (null args) (format nil "~d()" (c-function-name "LI" cfun fname)) (let ((o (make-array 100 :element-type 'character :fill-pointer 0 :adjustable t ))) (format o "~d(" (c-function-name "LI" cfun fname)) (do ((l args (cdr l)) (n 0 (1+ n))) ((endp (cdr l)) (format o "#~d)" n)) (declare (fixnum n)) (format o "#~d," n)) o))) (defun cs-push (&optional type) (let ((tem (next-cvar))) (push (if type (cons type tem) tem) *c-vars*) tem)) ; For the moment only two types are recognized. (defun f-type (x) (if (var-p x) (setq x (var-type x))) (cond ((and x (subtypep x 'fixnum)) 1) (t 0))) (defun proclaimed-argd (args return) (let ((ans (length args)) (i 8) (type (the fixnum (f-type return))) (begin t)) (declare (fixnum ans i)) (loop (if (not (eql 0 type)) (setq ans (the fixnum (+ ans (the fixnum (ash (the fixnum type) (the (integer 0 30) i))))))) (when begin (setq i 10) (setq begin nil)) (if (null args) (return ans)) (setq i (the fixnum (+ i 2))) (setq type (f-type (pop args)))))) (defun wt-if-proclaimed (fname cfun lambda-expr macro-p) (cond (macro-p (add-init `(si::MM ',fname ,(add-address (c-function-name "LI" cfun fname))))) ((fast-link-proclaimed-type-p fname) (cond ((unless (member '* (get fname 'proclaimed-arg-types)) (assoc fname *inline-functions*)) (add-init `(si::mfsfun ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(proclaimed-argd (get fname 'proclaimed-arg-types) (get fname 'proclaimed-return-type) ) ) ) t) (t (let ((arg-c (length (car (lambda-list lambda-expr)))) (arg-p (length (get fname 'proclaimed-arg-types))) (va (member '* (get fname 'proclaimed-arg-types)))) (cond (va (or (>= arg-c) (- arg-p (length va)) (cmpwarn "~a needs ~a args. ~a supplied." fname (- arg-p (length va)) arg-c))) ((not (eql arg-c arg-p)) (cmpwarn "~%;; ~a Number of proclaimed args was ~a. ~ ~%;;Its definition had ~a." fname arg-p arg-c)) ;((>= arg-c 10.)) ;checked above ;(cmpwarn " t1defun only likes 10 args ~ ; ~%for proclaimed functions") (t (cmpwarn " ~a is proclaimed but not in *inline-functions* ~ ~%T1defun could not assure suitability of args for C call" fname )))) nil))))) (defun volatile (info) (if (info-volatile info) "VOL " "")) (defun register (var) (cond ((and (equal *volatile* "") (>= (the fixnum (var-register var)) (the fixnum *register-min*))) "register ") (t ""))) (defun vararg-p (x) (and (equal (get x 'proclaimed-return-type) t) (do ((v (get x 'proclaimed-arg-types) (cdr v))) ((null v) t) (or (consp v) (return nil)) (or (eq (car v) t) (eq (car v) '*) (return nil))))) (defun maxargs (lambda-list) ; any function can take &allow-other-keys in ANSI lisp (cond ( ; (or (ll-allow-other-keys lambda-list)(ll-rest lambda-list)) (or (ll-keywords-p lambda-list) (ll-rest lambda-list)) 64) (t (+ (length (car lambda-list)) ;reg (length (ll-optionals lambda-list)) (* 2 (length (ll-keywords lambda-list))))))) (defun add-address (a) ;; if need ampersand before function for address ;; (setq a (string-concatenate "&" a)) (push (list a) *vaddress-list*) (prog1 *vind* (incf *vind*))) (defun t2defun (fname cfun lambda-expr doc sp &optional macro-p) (declare (ignore cfun lambda-expr doc sp macro-p)) (cond ((get fname 'no-global-entry)(return-from t2defun nil))) (cond ((< *space* 2) (setf (get fname 'debug-prop) t) ))) (defun si::add-debug (fname x) (si::putprop fname x 'si::debugger)) (defun t3init-fun (fname cfun lambda-expr doc macro-p) (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation))) (cond ((wt-if-proclaimed fname cfun lambda-expr macro-p)) ((vararg-p fname) (let ((keyp (ll-keywords-p (lambda-list lambda-expr)))) ; (wt-h "static object LI" cfun "();") (if keyp (add-init `(si::mfvfun-key ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(vargd (length (car (lambda-list lambda-expr))) (maxargs (lambda-list lambda-expr))) ,(add-address (format nil "&LI~akey" cfun))) ) (add-init `(si::mfvfun ',fname ,(add-address (c-function-name "LI" cfun fname)) ,(vargd (length (car (lambda-list lambda-expr))) (maxargs (lambda-list lambda-expr)))) )))) ((numberp cfun) (wt-h "static void " (c-function-name "L" cfun fname) "();") (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))) (t (wt-h cfun "();") (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname))))))) (defun t3defun (fname cfun lambda-expr doc sp &optional macro-p &aux inline-info (*current-form* (list 'defun fname)) (*volatile* (volatile (second lambda-expr))) *downward-closures*) (cond ((dolist (v *inline-functions*) (or (si::fixnump (nth 3 v)) (error "Old style inline")) (and (eq (car v) fname) (not (nth 5 v)) ; ie.not 'link-call or 'ifuncall (return (setq inline-info v)))) ;;; Add global entry information. (unless (or macro-p (fast-link-proclaimed-type-p fname)) (push (list fname cfun (cadr inline-info) (caddr inline-info)) *global-entries*)) ;;; Local entry (analyze-regs (cadr lambda-expr) 0) (t3defun-aux 't3defun-local-entry (case (caddr inline-info) (fixnum 'return-fixnum) (character 'return-character) (long-float 'return-long-float) (short-float 'return-short-float) (otherwise 'return-object)) fname cfun lambda-expr sp inline-info )) ((vararg-p fname) (analyze-regs (cadr lambda-expr) 0) (t3defun-aux 't3defun-vararg 'return-object fname cfun lambda-expr sp)) (t (analyze-regs (cadr lambda-expr) 2) (t3defun-aux 't3defun-normal 'return fname cfun lambda-expr sp))) (wt-downward-closure-macro cfun) (t3init-fun fname cfun lambda-expr doc macro-p) (add-debug-info fname lambda-expr)) (defun t3defun-aux (f *exit* &rest lis) (let-pass3 () (apply f lis))) (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info &aux specials (requireds (caaddr lambda-expr))) (do ((vl requireds (cdr vl)) (types (cadr inline-info) (cdr types))) ((endp vl)) (declare (object vl types)) (cond ((eq (var-kind (car vl)) 'special) (push (cons (car vl) (var-loc (car vl))) specials)) (t (setf (var-kind (car vl)) (case (car types) (fixnum 'FIXNUM) (character 'CHARACTER) (long-float 'LONG-FLOAT) (short-float 'SHORT-FLOAT) (otherwise 'OBJECT)))) ) (setf (var-loc (car vl)) (next-cvar))) (wt-comment "local entry for function " fname) (wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "();") (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(") (wt-requireds requireds (cadr inline-info)) ;;; Now the body. (let ((cm *reservation-cmacro*) (*tail-recursion-info* (if *do-tail-recursion* (cons fname requireds) nil)) (*unwind-exit* *unwind-exit*)) (wt-nl1 "{ ") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt " VMB" cm " VMS" cm " VMV" cm) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) (dolist (v specials) (wt-nl "bds_bind(" (vv-str (cdr v)) ",V" (var-loc (car v)) ");") (push 'bds-bind *unwind-exit*) (setf (var-kind (car v)) 'SPECIAL) (setf (var-loc (car v)) (cdr v))) (c2expr (caddr (cddr lambda-expr))) ;;; Use base if defined for lint (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) ;;; Make sure to return object if necessary (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) (wt-nl1 "}") (wt-V*-macros cm (caddr inline-info)) )) (defvar *vararg-use-vs* nil) (defun set-up-var-cvs (var) (cond (*vararg-use-vs* (setf (var-ref var) (vs-push))) ; ((numberp (var-loc var))) (t (setf (var-ref var) (cvs-push))))) (defun t3defun-vararg (fname cfun lambda-expr sp &aux reqs *vararg-use-vs* block-p labels (deflt t) key-offset (*inline-blocks* 0) rest-var (ll (lambda-list lambda-expr)) (is-var-arg (or (ll-rest ll) (ll-optionals ll) (ll-keywords-p ll))) (first (unless (car ll) is-var-arg))) (dolist (v (car ll)) (push (list 'cvar (next-cvar)) reqs)) (wt-comment "local entry for function " fname) (let ((tmp "")) (wt-nl1 "static object " (c-function-name "LI" cfun fname) "(") (when reqs (do ((v reqs (cdr v))) ((null v)) (wt "object " (car v)) (setq tmp (concatenate 'string tmp "object")) (or (null (cdr v)) (progn (wt ",") (setq tmp (concatenate 'string tmp ",")))))) (when is-var-arg (when first (wt "object first") (setq tmp (concatenate 'string tmp "object"))) (wt ",...") (setq tmp (concatenate 'string tmp ",..."))) (wt ")") (wt-h "static object " (c-function-name "LI" cfun fname) "(" tmp ");")) ; (when reqs (wt-nl "object ") ; (wt-list reqs) (wt ";")) ; (if is-var-arg (wt-nl "va_dcl ")) ;;; Now the body. (let ((cm *reservation-cmacro*) (*tail-recursion-info* ;; to do: When can we do tail recursion? ;; Should be able to do the optionals case, where the ;; optional defaults are constants. But this ;; is probably not worth it. (and *do-tail-recursion* (not (ll-rest ll)) (dolist* (var (ll-requireds ll) t) (when (var-ref-ccb var) (return nil))) (null (ll-optionals ll)) (null (ll-keywords ll)) (cons fname (car ll)))) (*unwind-exit* *unwind-exit*)) (wt-nl1 "{ ") (when is-var-arg (wt-nl "va_list ap;")) (wt-nl "int narg = VFUN_NARGS;") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt " VMB" cm " VMS" cm " VMV" cm) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (or is-var-arg (wt-nl "if ( narg!= " (length reqs) ") vfun_wrong_number_of_args(small_fixnum(" (length reqs) "));")) (flet ((do-decl (var) (and (eql (var-loc var) 'clb) (setf *vararg-use-vs* t)) (let ((kind (c2var-kind var))) (declare (object kind)) (when kind (let ((cvar (next-cvar))) (setf (var-kind var) kind) (setf (var-loc var) cvar) (wt-nl) (unless block-p (wt "{") (setq block-p t)) (wt-var-decl var) ))))) (dolist** (var (car ll)) (do-decl var)) (dolist** (opt (ll-optionals ll)) (do-decl (car opt)) (when (caddr opt) (do-decl (caddr opt)))) (when (ll-rest ll) (do-decl (ll-rest ll))) (dolist** (kwd (ll-keywords ll)) (do-decl (cadr kwd)) (when (cadddr kwd) (do-decl (cadddr kwd)))) ) ;;; Use Vcs for lint ; (if *vararg-use-vs* t (progn (wt-nl "Vcs[0]=Vcs[0];"))) ;;; start va_list at beginning (when is-var-arg (wt-nl "va_start(ap," (if first "first" (car (last reqs))) ");")) ;;; Check arguments. (when (and (or *safe-compile* *compiler-check-args*) (car ll)) (wt-nl "if(narg <" (length (car ll)) ") too_few_arguments();")) ;;; Allocate the parameters. (dolist** (var (car ll)) (set-up-var-cvs var)) (dolist** (opt (ll-optionals ll)) (set-up-var-cvs (car opt))) (when (ll-rest ll) (set-up-var-cvs (ll-rest ll))) (setf key-offset (if *vararg-use-vs* *vs* *cs*)) (dolist** (kwd (ll-keywords ll)) (set-up-var-cvs (cadr kwd))) (dolist** (kwd (ll-keywords ll)) (set-up-var-cvs (cadddr kwd))) ;;bind the params: (do ((v reqs (cdr v)) (vl (car ll) (cdr vl))) ((null v)) (c2bind-loc (car vl) (car v))) (when (ll-optionals ll) (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (wt-nl "narg = narg - " (length reqs) ";") (dolist** (opt (ll-optionals ll)) (push (next-label) labels) (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") (wt-go (car labels)) (wt-nl "else {" ) (c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg))) (setq first nil) (wt "}") (when (caddr opt) (c2bind-loc (caddr opt) t)))) (setq labels (nreverse labels)) (let ((label (next-label))) (wt-nl "--narg; ") (wt-go label) ;;; Bind unspecified optional parameters. (dolist** (opt (ll-optionals ll)) (wt-label (car labels)) (pop labels) (c2bind-init (car opt) (cadr opt)) (when (caddr opt) (c2bind-loc (caddr opt) nil))) ; (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;")) (wt-label label) )) (if (ll-rest ll) (progn (setq rest-var (cs-push)) (cond ((ll-optionals ll)) (t (wt-nl "narg= narg - " (length (car ll)) ";"))) (wt-nl "V" rest-var " = ") (let ((*rest-on-stack* (or (eq (var-type (ll-rest ll)) :dynamic-extent) *rest-on-stack*))) (if (ll-keywords-p ll) (cond (*rest-on-stack* (wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) (t (wt "make_list(narg);"))) (cond (*rest-on-stack* (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg," (if first "first" "OBJNULL") ",ap));" )) (t (wt "list_vector_new(narg," (if first "first" "OBJNULL") ",ap);")))) (c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) (when (ll-keywords-p ll) (cond ((ll-rest ll)) ((ll-optionals ll)) (t (wt-nl "narg= narg - " (length (car ll)) ";"))) (setq deflt (mapcar 'caddr (ll-keywords ll))) (let ((vkdefaults nil) (n (length (ll-keywords ll)))) (do* ((v deflt (cdr v)) (kwds (ll-keywords ll) (cdr kwds)) (kwd (car kwds) (car kwds))) ((null v)) (unless (and (eq (caar v) 'location) (eq (third (car v)) nil)) (setq vkdefaults t)) (when (or (not (and (eq (caar v) 'location) (let ((tem (third (car v)))) (or (eq tem nil) (and (consp tem) (member (car tem) '(vv fixnum-value)) ))))) ;; the supplied-p variable is not there (not (eq (var-kind (cadddr kwd)) 'DUMMY))) (setf Vkdefaults t) (setf (car v) 0))) (if (> (length deflt) 15) (setq vkdefaults t)) (wt-nl "{") (inc-inline-blocks) (let ((*compiler-output1* *compiler-output2*)) (when vkdefaults (terpri *compiler-output2*) (wt "static object VK" cfun "defaults[" (length deflt) "]={") (do ((v deflt(cdr v))(tem)) ((null v)) (wt "(void *)") (cond ((eql (car v) 0) (wt "-1")) ;; must be location ((and (eq (setq tem (third (car v))) nil)) (wt "-2")) ((and (consp tem) (eq (car tem) 'vv)) (wt (add-object2 (add-object (second tem))) )) ((and (consp tem) (eq (car tem) 'fixnum-value)) ; (print (setq ttem tem)) (break) (wt (add-object2 (add-object (third tem))) )) (t (baboon))) (if (cdr v) (wt ","))) (wt "};")) (terpri *compiler-output2*) (wt "static struct { short n,allow_other_keys;" "object *defaults;") (wt-nl " KEYTYPE keys[" (max n 1) "];") (wt "} " "LI" cfun "key=") (wt "{" (length (ll-keywords ll)) "," (if (ll-allow-other-keys ll) 1 0) ",") (if vkdefaults (wt "VK" cfun "defaults") (wt "Cstd_key_defaults")) (when (ll-keywords ll) (wt ",{") (do ((v (reverse (ll-keywords ll)) (cdr v))) ((null v)) ;; We write this list backwards for convenience ;; in stepping through it in parse_key (wt "(void *)") ; (print (setq ss v))(break "h") (wt (add-object2 (add-symbol (caar v)))) (if (cdr v) (wt ","))) (wt "}")) (wt "};") ) (cond ((ll-rest ll) (wt-nl "parse_key_rest_new(" (list 'cvar rest-var) ",")) (t (wt-nl "parse_key_new_new("))) (if (eql 0 *cs*)(setq *cs* 1)) (wt "narg," (if *vararg-use-vs* "base " (progn (setq *vcs-used* t) "Vcs ")) "+" key-offset",(struct key *)(void *)&LI" cfun "key," (if first "first" "OBJNULL") ",ap);") )) ;; bind keywords (dolist** (kwd (ll-keywords ll)) (cond ((not (eql 0 (pop deflt))) ;; keyword default bound by parse_key.. and no supplied-p (c2bind (cadr kwd))) (t (wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==OBJNULL){") (let ((*clink* *clink*) (*unwind-exit* *unwind-exit*) (*ccb-vs* *ccb-vs*)) (c2bind-init (cadr kwd) (caddr kwd))) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil)) (wt-nl "}else{") (c2bind (cadr kwd)) (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) t)) (wt "}"))) ) (when *tail-recursion-info* (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) (c2expr (caddr (cddr lambda-expr))) ;;; End va_list at function end (when is-var-arg (wt-nl "va_end(ap);")) ;;; Use base if defined for lint (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) ;;; Need to ensure return of type object (wt-nl "return Cnil;") (wt "}") (when block-p (wt-nl "}")) (close-inline-blocks) (wt-V*-macros cm (get fname 'proclaimed-return-type)) )) (defun t3defun-normal (fname cfun lambda-expr sp) (wt-comment "function definition for " fname) (if (numberp cfun) (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") (wt-nl1 cfun "()")) (wt-nl1 "{" "register object *" *volatile*"base=vs_base;") (assign-down-vars (cadr lambda-expr) cfun 't3defun) (wt-nl "register object *" *volatile*"sup=base+VM" *reservation-cmacro* ";") (wt " VC" *reservation-cmacro*) (if *safe-compile* (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") (wt-nl "vs_check;")) (when sp (wt-nl "bds_check;")) (when *compiler-push-events* (wt-nl "ihs_check;")) (c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)) fname) (wt-nl1 "}") (push (cons *reservation-cmacro* *max-vs*) *reservations*) (wt-h "#define VC" *reservation-cmacro*) (wt-cvars) ) ;;Macros for conditionally writing vs_base ..preamble, and for setting ;;up the return. (defun wt-V*-macros (cm return-type) (declare (ignore return-type)) (push (cons cm *max-vs*) *reservations*) (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) ;;note if (proclaim '(function foo () t)) ;;(defun foo () (goo)) ;then *max-vs*=0,*sup-used*=t;--wfs (wt-h "#define VMB" cm) (wt-h "#define VMB" cm " " "register object *" *volatile*"base=vs_top;")) ;;tack following onto the VMB macro.. (wt-cvars) (if *sup-used* (wt-h "#define VMS" cm " " " register object *" *volatile*"sup=vs_top+" *max-vs* ";vs_top=sup;") (if (zerop *max-vs*) (wt-h "#define VMS" cm) (wt-h "#define VMS" cm " vs_top += " *max-vs* ";"))) (if (zerop *max-vs*) (wt-h "#define VMV" cm) (if *safe-compile* (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");") (wt-h "#define VMV" cm " vs_check;"))) (if (zerop *max-vs*) (wt-h "#define VMR" cm "(VMT" cm ") return(VMT" cm ");") (wt-h "#define VMR" cm "(VMT" cm ") vs_top=base ; return(VMT" cm ");")) ) ;;Write the required args as c arguments, and declarations for the arguments. (defun wt-requireds (requireds arg-types) (do ((vl requireds (cdr vl))) ((endp vl)) (declare (object vl)) (let ((cvar (next-cvar))) (setf (var-loc (car vl)) cvar) (wt "V" cvar)) (unless (endp (cdr vl)) (wt ","))) (wt ") ") (when requireds (wt-nl1) (do ((vl requireds (cdr vl)) (types arg-types (cdr types)) (prev-type nil)) ((endp vl) (wt ";")) (declare (object vl)) (if prev-type (wt ";")) (wt *volatile* (register (car vl)) (rep-type (car types))) (setq prev-type (car types)) (wt "V" (var-loc (car vl)))))) (defun add-debug-info (fname lambda-expr &aux locals) (cond ((>= *space* 2)) ((null (get fname 'debug-prop)) (warn "~a has a duplicate definition in this file" fname)) (t (remprop fname 'debug-prop) (let ((leng 0)) (do-referred (va (second lambda-expr)) (when (and (consp (var-ref va)) (si::fixnump (cdr (var-ref va)))) (setq leng (max leng (cdr (var-ref va)))))) (setq locals (make-list (1+ leng))) (do-referred (va (second lambda-expr)) (when (and (consp (var-ref va)) ;always fixnum ? (si::fixnump (cdr (var-ref va)))) (setf (nth (cdr (var-ref va)) locals) (var-name va)))) (setf (get fname 'si::debugger) locals) (let ((locals (get fname 'si::debugger))) (if (and locals (or (cdr locals) (not (null (car locals))))) (add-init `(debug ',fname ',locals) ) )) )))) ;;Checks the register slots of variables, and finds which ;;variables should be in registers, zero'ing the register slot ;;in the remaining. Data and address variables are done separately. (defun analyze-regs (info for-sup-base) (let ((addr-regs (- *free-address-registers* for-sup-base))) (cond ((zerop *free-data-registers*) (analyze-regs1 info addr-regs)) (t (let ((addr (make-info)) (data (make-info))) (do-referred (v info) (cond ((member (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT) :test #'eq) (push-referred v data)) (t (push-referred v addr)))) (analyze-regs1 addr addr-regs) (analyze-regs1 data *free-data-registers*)))))) (defun analyze-regs1 (info want ) (let ((tem 0)(real-min 3)(this-min 100000)(want want)(have 0)) (declare (fixnum tem real-min this-min want have)) (tagbody START (do-referred (v info) (setq tem (var-register v)) (cond ((>= tem real-min) (setq have (the fixnum (+ have 1))) (cond ((< tem this-min ) (setq this-min tem))) (cond ((> have want) (go NEXT))) ))) (cond ((< have want) (setq real-min (- real-min 1)))) (do-referred (v info) (cond ((< (the fixnum (var-register v)) real-min) (setf (var-register v) 0)))) (return-from analyze-regs1 real-min) NEXT (setq have 0) (setq real-min (the fixnum (+ this-min 1))) (setq this-min 1000000) (go START) ))) (defun wt-global-entry (fname cfun arg-types return-type) (cond ((get fname 'no-global-entry)(return-from wt-global-entry nil))) (wt-comment "global entry for the function " fname) (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") (wt-nl1 "{ register object *base=vs_base;") (when (or *safe-compile* *compiler-check-args*) (wt-nl "check_arg(" (length arg-types) ");")) (wt-nl "base[0]=" (case return-type (fixnum (if (zerop *space*) "CMPmake_fixnum" "make_fixnum")) (character "code_char") (long-float "make_longfloat") (short-float "make_shortfloat") (otherwise "")) "(" (c-function-name "LI" cfun fname) "(") (do ((types arg-types (cdr types)) (n 0 (1+ n))) ((endp types)) (declare (object types) (fixnum n)) (wt (case (car types) (fixnum "fix") (character "char_code") (long-float "lf") (short-float "sf") (otherwise "")) "(base[" n "])") (unless (endp (cdr types)) (wt ","))) (wt "));") (wt-nl "vs_top=(vs_base=base)+1;") (wt-nl1 "}") ) (defun rep-type (type) (case type (fixnum "long ") (integer "MP_INT * ") (character "unsigned char ") (short-float "float ") (long-float "double ") (otherwise "object "))) (defun t1defmacro (args &aux (w args)(n (pop args))(l (symbol-plist n)) (macp (when (listp n) (eq 'macro (car n))))(n (if macp (cdr n) n))) (proclaim `(ftype (function (t t) t) ,n)) (maybe-eval (not (macro-function n)) (cons 'defmacro w));FIXME? (t1expr `(defun ,n ,@(if macp args (cddr (caddr (si::defmacro* n (pop args) args)))))) (setf (symbol-plist n) l) (nconc (car *top-level-forms*) '(t))) (defvar *compiling-ordinary* nil) (defun compile-ordinary-p (form) (when (consp form) (or (member (car form) '(lambda defun defmacro flet labels)) (compile-ordinary-p (car form)) (compile-ordinary-p (cdr form))))) (defun t1ordinary (form) (cond ((unless *compiling-ordinary* (or *compile-ordinaries* (compile-ordinary-p form))) (maybe-eval nil form) (let ((gen (gensym))(*compiling-ordinary* t)) (proclaim `(function ,gen nil t)) (t1expr `(progn (defun ,gen nil ,form nil) (,gen))))) (t (maybe-eval nil form) (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) (*sharp-commas* nil)) (push (list 'ordinary form) *top-level-forms*) nil)))) (defun t3ordinary (form) (cond ((atom form)) ((constantp form)) (t (add-init form )))) (defun add-load-time-sharp-comma () (dolist* (vv (reverse *sharp-commas*)) (cond ((atom vv) (wfs-error))) (push (cons 'sharp-comma vv) *top-level-forms*))) (defun t3sharp-comma (vv val) (add-init `(si::setvv ,vv ,val) )) (defun t2declare (vv) vv (wfs-error)) ;; Some top level functions which should be eval'd in the :default case ;; for eval-when (setf (get 'si::*make-special 'eval-at-compile) t) (setf (get 'si::*make-constant 'eval-at-compile) t) (setf (get 'proclaim 'eval-at-compile) t) (setf (get 'si::define-structure 't1) 't1define-structure) (defun t1define-structure (args) (maybe-eval t `(si::define-structure ,@(copy-tree args) ,(not (maybe-eval nil nil))));FIXME (t1ordinary (cons 'si::define-structure args))) (si:putprop 'dbind 'set-dbind 'set-loc) (defun set-dbind (loc vv) (wt-nl (vv-str vv) "->s.s_dbind = " loc ";")) (defun t1clines (args) (dolist** (s args) (cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s)) (push (list 'clines args) *top-level-forms*)) (defun t3clines (ss) (dolist** (s ss) (wt-nl1 s))) (defun t1defcfun (args &aux (body nil)) (when (or (endp args) (endp (cdr args))) (too-few-args 'defcfun 2 (length args))) (cmpck (not (stringp (car args))) "The first argument to defCfun ~s is not a string." (car args)) (cmpck (not (numberp (cadr args))) "The second argument to defCfun ~s is not a number." (cadr args)) (dolist** (s (cddr args)) (cond ((stringp s) (push s body)) ((consp s) (cond ((symbolp (car s)) (cmpck (special-operator-p (car s)) "Special form ~s is not allowed in defCfun." (car s)) (push (list (cons (car s) (parse-cvspecs (cdr s)))) body)) ((and (consp (car s)) (symbolp (caar s)) (not (if (eq (caar s) 'quote) (or (endp (cdar s)) (not (endp (cddar s))) (endp (cdr s)) (not (endp (cddr s)))) (special-operator-p (caar s))))) (push (cons (cons (caar s) (if (eq (caar s) 'quote) (list (add-object (cadar s))) (parse-cvspecs (cdar s)))) (parse-cvspecs (cdr s))) body)) (t (cmperr "The defCfun body ~s is illegal." s)))) (t (cmperr "The defCfun body ~s is illegal." s)))) (push (list 'defcfun (car args) (cadr args) (nreverse body)) *top-level-forms*) ) (defun t3defcfun (header vs-size body &aux fd) (wt-comment "C function defined by " 'defcfun) (wt-nl1 header) (wt-h header ";") (wt-nl1 "{") (wt-nl1 "object *vs=vs_top;") (when (> vs-size 0) (wt-nl1 "object *old_top=vs_top+" vs-size ";")(wt-nl "vs_top=old_top;")) (wt-nl1 "{") (dolist** (s body) (cond ((stringp s) (wt-nl1 s)) ((eq (caar s) 'quote) (wt-nl1 (cadadr s)) (case (caadr s) (object (wt "=" (vv-str (cadar s)) ";")) (otherwise (wt "=object_to_" (string-downcase (symbol-name (caadr s))) "(" (vv-str (cadar s)) ");")))) (t (wt-nl1 "{vs_base=vs_top=old_top;") (dolist** (arg (cdar s)) (wt-nl1 "vs_push(") (case (car arg) (object (wt (cadr arg))) (char (wt "code_char((long)" (cadr arg) ")")) (int (when (zerop *space*) (wt "CMP")) (wt "make_fixnum((long)(" (cadr arg) "))")) (float (wt "make_shortfloat((double)" (cadr arg) ")")) (double (wt "make_longfloat((double)" (cadr arg) ")"))) (wt ");")) (cond ((setq fd (assoc (caar s) *global-funs*)) (cond (*compiler-push-events* (wt-nl1 "ihs_push(" (vv-str (add-symbol (caar s))) ");") (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();") (wt-nl1 "ihs_pop();")) (t (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();")))) (*compiler-push-events* (wt-nl1 "super_funcall(" (vv-str (add-symbol (caar s))) ");")) (*safe-compile* (wt-nl1 "super_funcall_no_event(" (vv-str (add-symbol (caar s))) ");")) (t (wt-nl1 "CMPfuncall(" (vv-str (add-symbol (caar s))) "->s.s_gfdef);")) ) (unless (endp (cdr s)) (wt-nl1 (cadadr s)) (case (caadr s) (object (wt "=vs_base[0];")) (otherwise (wt "=object_to_" (string-downcase (symbol-name (caadr s))) "(vs_base[0]);"))) (dolist** (dest (cddr s)) (wt-nl1 "vs_base++;") (wt-nl1 (cadr dest)) (case (car dest) (object (wt "=(vs_base> ,(* i 8))) ,str)) (provide 'FASDMACROS) gcl-2.6.14/cmpnew/gcl_cmpeval.lsp0000755000175000017500000006100314360276512015263 0ustar cammcamm;;; CMPEVAL The Expression Dispatcher. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (export '(si::define-compiler-macro si::undef-compiler-macro si::define-inline-function) :system) (in-package :compiler) (si:putprop 'progn 'c1progn 'c1special) (si:putprop 'progn 'c2progn 'c2) (si:putprop 'si:structure-ref 'c1structure-ref 'c1) (si:putprop 'structure-ref 'c2structure-ref 'c2) (si:putprop 'structure-ref 'wt-structure-ref 'wt-loc) (si:putprop 'si:structure-set 'c1structure-set 'c1) (si:putprop 'structure-set 'c2structure-set 'c2) (defun c1expr* (form info) (setq form (c1expr form)) (add-info info (cadr form)) form) (defun c1expr (form) (setq form (catch *cmperr-tag* (cond ((symbolp form) (cond ((eq form nil) (c1nil)) ((eq form t) (c1t)) ((keywordp form) (list 'LOCATION (make-info :type (object-type form)) (list 'VV (add-object form)))) ((constantp form) (let ((val (symbol-value form))) (or (c1constant-value val nil) (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-constant form)))))) (t (c1var form)))) ((consp form) (let ((fun (car form))) (cond ((symbolp fun) (c1symbol-fun fun (cdr form))) ((and (consp fun) (eq (car fun) 'lambda)) (c1lambda-fun (cdr fun) (cdr form))) ((and (consp fun) (eq (car fun) 'si:|#,|)) (cmperr "Sharp-comma-macro was found in a bad place.")) (t (cmperr "The function ~s is illegal." fun))))) (t (c1constant-value form t))))) (if (eq form '*cmperr-tag*) (c1nil) form)) (si::putprop 'si:|#,| 'c1sharp-comma 'c1special) (si::putprop 'load-time-value 'c1load-time-value 'c1special) (defun c1sharp-comma (arg) (c1constant-value (cons 'si:|#,| arg) t)) (defun c1load-time-value (arg) (c1constant-value (cons 'si:|#,| (if *compiler-compile* (let ((x (cmp-eval (car arg)))) (if (and (cdr arg) (cadr arg)) x `(si::nani ,(si::address x)))) (car arg))) t)) (si::putprop 'si::define-structure 'c1define-structure 't1) (defun c1define-structure (arg &aux *sharp-commas*) (declare (special *sharp-commas*)) (eval (cons 'si::define-structure arg)) (c1constant-value (cons 'si:|#,| (cons 'si::define-structure arg)) t) (add-load-time-sharp-comma) nil) (defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil)) (defun c1nil () *c1nil*) (defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t)) (defun c1t () *c1t*) (defun flags-pos (flag &aux (i 0)) (declare (fixnum i)) (dolist (v '((allocates-new-storage ans); might invoke gbc (side-effect-p set) ; no effect on arguments (constantp) ; always returns same result, ;double eval ok. (result-type-from-args rfa); if passed args of matching ;type result is of result type (is))) ;; extends the `integer stack'. (cond ((member flag v :test 'eq) (return-from flags-pos i))) (setq i (+ i 1))) (error "unknown opt flag")) (defmacro flag-p (n flag) `(logbitp ,(flags-pos flag) ,n)) ;; old style opts had '(args ret new-storage side-effect string) ;; these new-storage and side-effect have been combined into ;; one integer, along with several other flags. (defun fix-opt (opt) (let ((a (cddr opt))) (unless (typep (car a ) 'fixnum) (if *compiler-in-use* (cmpwarn "Obsolete optimization: use fix-opt ~s" opt)) (setf (cddr opt) (cons (logior (if (car a) 2 0) (if (cadr a) 1 0)) (cddr a)))) opt)) ;; some hacks for revising a list of optimizers. #+revise (progn (defun output-opt (opt sym flag) (fix-opt opt) (format t "(push '(~(~s ~s #.(flags~)" (car opt) (second opt)) (let ((o (third opt))) (if (flag-p o set) (princ " set")) (if (flag-p o ans) (princ " ans")) (if (flag-p o rfa) (princ " rfa")) (if (flag-p o constantp) (princ "constantp "))) (format t ")") (if (and (stringp (nth 3 opt)) (> (length (nth 3 opt)) 40)) (format t "~% ")) (prin1 (nth 3 opt)) (format t ")~% ~((get '~s '~s)~))~%" sym flag)) (defun output-all-opts (&aux lis did) (sloop::sloop for v in ;(list (find-package "LISP")) (list-all-packages) do (setq lis (sloop::sloop for sym in-package (package-name v) when (or (get sym 'inline-always) (get sym 'inline-safe) (get sym 'inline-unsafe)) collect sym)) (setq lis (sort lis #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) do (sloop::sloop for sym in lis do (format t "~%;;~s~% " sym) (sloop::sloop for u in '(inline-always inline-safe inline-unsafe) do (sloop::sloop for w in (nreverse (remove-duplicates (copy-list (get sym u)) :test 'equal)) do (output-opt w sym u)))))) ) (defun result-type-from-args(f args &aux tem) (when (if (setq tem (get f 'return-type)) (and (not (eq tem '*)) (not (consp tem))) t) (dolist (v '(inline-always inline-unsafe)) (dolist (w (get f v)) (fix-opt w) (when (and (flag-p (third w) result-type-from-args) (eql (length args) (length (car w))) (do ((a args (cdr a)) (b (car w) (cdr b))) ((null a) t) (unless (or (eq (car a) (car b)) (type>= (car b)(car a) )) (return nil)))) (return-from result-type-from-args (second w))))))) ;; omitting a flag means it is set to nil. (defmacro flags (&rest lis &aux (i 0)) (dolist (v lis) (setq i (logior i (ash 1 (flags-pos v))))) i) ;; Usage: ; (flagp-p (caddr ii) side-effect-p) ; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)") ; (get '+ 'inline-always)) (defun c1symbol-fun (fname args &aux fd) (cond ((setq fd (get fname 'c1special)) (funcall fd args)) ((and (setq fd (get fname 'co1special)) (funcall fd fname args))) ((setq fd (c1local-fun fname)) (if (eq (car fd) 'call-local) ;; c1local-fun now adds fun-info into (cadr fd), so we need no longer ;; do it explicitly here. CM 20031030 (let* ((info (add-info (make-info :sp-change t) (cadr fd))) (forms (c1args args info))) (let ((return-type (get-local-return-type (caddr fd)))) (when return-type (setf (info-type info) return-type))) (let ((arg-types (get-local-arg-types (caddr fd)))) ;;; Add type information to the arguments. (when arg-types (let ((fl nil)) (dolist** (form forms) (cond ((endp arg-types) (push form fl)) (t (push (and-form-type (car arg-types) form (car args)) fl) (pop arg-types) (pop args)))) (setq forms (nreverse fl))))) (list 'call-local info (cddr fd) forms)) (c1expr (cmp-expand-macro fd fname args)))) ((and (setq fd (get fname 'co1)) (inline-possible fname) (funcall fd fname args))) ((and (setq fd (get fname 'c1)) (inline-possible fname)) (funcall fd args)) ((and (setq fd (get fname 'c1conditional)) (inline-possible fname) (funcall (car fd) args)) (funcall (cdr fd) args)) ;; record the call info if we get to here ((progn (and (eq (symbol-package fname) (symbol-package 'and)) (not (fboundp fname)) (cmpwarn "~A (in lisp package) is called as a function--not yet defined" fname)) (and *record-call-info* (record-call-info 'record-call-info fname)) nil)) ;;continue ((setq fd (macro-function fname)) (c1expr (cmp-expand-macro fd fname args))) ((setq fd (get fname 'compiler-macro)) (c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil)))) ((and (setq fd (get fname 'si::structure-access)) (inline-possible fname) ;;; Structure hack. (consp fd) (si:fixnump (cdr fd)) (not (endp args)) (endp (cdr args))) (case (car fd) (vector (c1expr `(elt ,(car args) ,(cdr fd)))) (list (c1expr `(si:list-nth ,(cdr fd) ,(car args)))) (t (c1structure-ref1 (car args) (car fd) (cdr fd))) ) ) ((eq fname 'si:|#,|) (cmperr "Sharp-comma-macro was found in a bad place.")) (t (let* ((info (make-info :sp-change (null (get fname 'no-sp-change)))) (forms (c1args args info))) ;; info updated by args here (let ((return-type (get-return-type fname))) (when return-type (if (equal return-type '(*)) (setf return-type nil) (setf (info-type info) return-type)))) (let ((arg-types (get-arg-types fname))) ;;; Add type information to the arguments. (when arg-types (do ((fl forms (cdr fl)) (fl1 nil) (al args (cdr al))) ((endp fl) (setq forms (nreverse fl1))) (cond ((endp arg-types) (push (car fl) fl1)) (t (push (and-form-type (car arg-types) (car fl) (car al)) fl1) (pop arg-types)))))) (let ((arg-types (get fname 'arg-types))) ;;; Check argument types. (when arg-types (do ((fl forms (cdr fl)) (al args (cdr al))) ((or (endp arg-types) (endp fl))) (check-form-type (car arg-types) (car fl) (car al)) (pop arg-types)))) (case fname (aref (let ((etype (info-type (cadar forms)))) (when (or (and (eq etype 'string) (setq etype 'character)) (and (consp etype) (or (eq (car etype) 'array) (eq (car etype) 'vector)) (setq etype (cadr etype)))) (setq etype (type-and (info-type info) etype)) (when (null etype) (cmpwarn "Type mismatch was found in ~s." (cons fname args))) (setf (info-type info) etype)))) (si:aset (let ((etype (info-type (cadar forms)))) (when (or (and (eq etype 'string) (setq etype 'character)) (and (consp etype) (or (eq (car etype) 'array) (eq (car etype) 'vector)) (setq etype (cadr etype)))) (setq etype (type-and (info-type info) (type-and (info-type (cadar (last forms))) etype))) (when (null etype) (cmpwarn "Type mismatch was found in ~s." (cons fname args))) (setf (info-type info) etype) (setf (info-type (cadar (last forms))) etype) )))) ;; some functions can have result type deduced from ;; arg types. (let ((tem (result-type-from-args fname (mapcar #'(lambda (x) (info-type (cadr x))) forms)))) (when tem (setq tem (type-and tem (info-type info))) (setf (info-type info) tem))) (list 'call-global info fname forms))) ) ) ;;numbers and character constants may be sometimes used, instead ;;of the variable, eg inside eql (defun replace-constant (lis &aux found tem) (do ((v lis (cdr v))) ((null v) found) (cond ((and (constantp (car v)) (or (numberp (setq tem(eval (car v)))) (characterp tem))) (setq found t) (setf (car v) tem))))) (defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t))) (setq args (c1args args info)) (setq lambda-expr (c1lambda-expr lambda-expr)) (add-info info (cadr lambda-expr)) (list 'call-lambda info lambda-expr args) ) (defun c2expr (form) (if (eq (car form) 'call-global) (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form))) (if (or (eq (car form) 'let) (eq (car form) 'let*)) (let ((*volatile* (volatile (cadr form)))) (declare (special *volatile*)) (apply (get (car form) 'c2) (cddr form))) (let ((tem (get (car form) 'c2))) (cond (tem (apply tem (cddr form))) ((setq tem (get (car form) 'wholec2)) (funcall tem form)) (t (baboon))))))) (defun c2funcall-sfun (fn args info &aux locs (all (cons fn args))) info (let ((*inline-blocks* 0)) (setq locs (get-inline-loc (list (make-list (length all) :initial-element t) t #.(flags ans set) 'fcalln-inline) all)) (unwind-exit locs) (close-inline-blocks))) (defun c2expr* (form) (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr form) (wt-label *exit*)) ) (defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*)) (*reservation-cmacro* (next-cmacro))) (wt-nl "{register object *base" (1- *level*) "=base;") (base-used) (wt-nl "{register object *base=V" top ";") (wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";") ;;; Dummy assignments for lint (wt-nl "base" (1- *level*) "[0]=base" (1- *level*) "[0];") (wt-nl "base[0]=base[0];") (if *safe-compile* (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") (wt-nl "vs_check;")) (wt-nl) (reset-top) (c2expr form) (push (cons *reservation-cmacro* *max-vs*) *reservations*) (wt-nl "}}") ) (defun c2expr-top* (form top) (let* ((*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr-top form top) (wt-label *exit*))) (defun c1progn (forms &aux (fl nil)) (cond ((endp forms) (c1nil)) ((endp (cdr forms)) (c1expr (car forms))) (t (let ((info (make-info))) (dolist (form forms) (setq form (c1expr form)) (push form fl) (add-info info (cadr form))) (setf (info-type info) (info-type (cadar fl))) (list 'progn info (nreverse fl)) ))) ) ;;; Should be deleted. (defun c1progn* (forms info) (setq forms (c1progn forms)) (add-info info (cadr forms)) forms) (defun c2progn (forms) ;;; The length of forms may not be less than 1. (do ((l forms (cdr l))) ((endp (cdr l)) (c2expr (car l))) (declare (object l)) (let* ((*value-to-go* 'trash) (*exit* (next-label)) (*unwind-exit* (cons *exit* *unwind-exit*))) (c2expr (car l)) (wt-label *exit*) )) ) (defun c1args (forms info) (mapcar #'(lambda (form) (c1expr* form info)) forms)) ;;; Structures (defun c1structure-ref (args) (if (and (not *safe-compile*) (not (endp args)) (not (endp (cdr args))) (consp (cadr args)) (eq (caadr args) 'quote) (not (endp (cdadr args))) (symbolp (cadadr args)) (endp (cddadr args)) (not (endp (cddr args))) (si:fixnump (caddr args)) (endp (cdddr args))) (c1structure-ref1 (car args) (cadadr args) (caddr args)) (let ((info (make-info))) (list 'call-global info 'si:structure-ref (c1args args info))))) (defun c1structure-ref1 (form name index &aux (info (make-info))) ;;; Explicitly called from c1expr and c1structure-ref. (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index))) ((let* ((sd (get name 'si::s-data)) (aet-type (aref (si::s-data-raw sd) index)) (sym (find-symbol (si::string-concatenate (or (si::s-data-conc-name sd) "") (car (nth index (si::s-data-slot-descriptions sd)))))) (tp (if sym (get-return-type sym) '*)) (tp (type-filter (type-and tp (aref *aet-types* aet-type))))) (setf (info-type info) (if (and (eq name 'si::s-data) (= index 2));;FIXME -- this belongs somewhere else. CM 20050106 '(vector unsigned-char) tp)) (list 'structure-ref info (c1expr* form info) (add-symbol name) index sd))))) (defun coerce-loc-structure-ref (arg type-wanted &aux (form (cdr arg))) (let* ((sd (fourth form)) (index (caddr form))) (cond (sd (let* ((aet-type (aref (si::s-data-raw sd) index)) (type (aref *aet-types* aet-type))) (cond ((eq (inline-type (type-filter type)) 'inline) (or (eql aet-type 0) (error "bad type ~a" type)))) (setf (info-type (car arg)) (type-filter type)) (coerce-loc (list (inline-type (type-filter type)) (flags) 'my-call (list (car (inline-args (list (car form)) '(t))) 'joe index sd)) (type-filter type-wanted))) ) (t (wfs-error))))) (defun c2structure-ref (form name-vv index sd &aux (*vs* *vs*) (*inline-blocks* 0)) (let ((loc (car (inline-args (list form) '(t)))) (type (aref *aet-types* (aref (si::s-data-raw sd) index)))) (unwind-exit (list (inline-type (type-filter type)) (flags) 'my-call (list loc name-vv index sd)))) (close-inline-blocks) ) (defun my-call (loc name-vv ind sd) name-vv (let* ((raw (si::s-data-raw sd)) (spos (si::s-data-slot-position sd))) (if *safe-compile* (wfs-error) (wt "STREF(" (aet-c-type (aref *aet-types* (aref raw ind)) ) "," loc "," (aref spos ind) ")")))) (defun c1structure-set (args &aux (info (make-info))) (if (and (not (endp args)) (not *safe-compile*) (not (endp (cdr args))) (consp (cadr args)) (eq (caadr args) 'quote) (not (endp (cdadr args))) (symbolp (cadadr args)) (endp (cddadr args)) (not (endp (cddr args))) (si:fixnump (caddr args)) (not (endp (cdddr args))) (endp (cddddr args))) (let ((x (c1expr (car args))) (y (c1expr (cadddr args)))) (add-info info (cadr x)) (add-info info (cadr y)) (setf (info-type info) (info-type (cadr y))) (list 'structure-set info x (add-symbol (cadadr args)) ;;; remove QUOTE. (caddr args) y (get (cadadr args) 'si::s-data))) (list 'call-global info 'si:structure-set (c1args args info)))) ;; The following (side-effects) exists for putting at the end of an ;; argument list to force all previous arguments to be stored in ;; variables, when computing inline-args. (push '(() t #.(flags ans set) "Ct") (get 'side-effects 'inline-always)) (defun c2structure-set (x name-vv ind y sd &aux locs (*vs* *vs*) (*inline-blocks* 0)) name-vv (let* ((raw (si::s-data-raw sd)) (type (aref *aet-types* (aref raw ind))) (spos (si::s-data-slot-position sd)) (tftype (type-filter type)) ix iy) (setq locs (inline-args (list x y (list 'call-global (make-info) 'side-effects nil)) (if (eq type t) '(t t t) `(t ,tftype t)))) (setq ix (car locs)) (setq iy (cadr locs)) (if *safe-compile* (wfs-error)) (wt-nl "STSET(" (aet-c-type type )"," ix "," (aref spos ind) ", " iy ");") (unwind-exit (list (inline-type tftype) (flags) 'wt-loc (list iy))) (close-inline-blocks) )) (defun c1constant-value (val always-p) (cond ((eq val nil) (c1nil)) ((eq val t) (c1t)) ((when (si:fixnump val) (< most-negative-fixnum val)) (list 'LOCATION (make-info :type 'fixnum) (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val)) val))) ((characterp val) (list 'LOCATION (make-info :type 'character) (list 'CHARACTER-VALUE (add-object val) (char-code val)))) ((typep val 'long-float) ;; We can't read in long-floats which are too big: (let* (sc (vv (cond ((> (abs val) (/ most-positive-long-float 2)) (add-object `(si::|#,| * ,(/ val most-positive-long-float) most-positive-long-float))) ((< (abs val) (* least-positive-normalized-long-float 2.0)) (add-object `(si::|#,| * ,(/ val least-positive-normalized-long-float) least-positive-normalized-long-float))) ((setq sc t) (add-object val))))) `(location ,(make-info :type 'long-float) ,(if sc (list 'LONG-FLOAT-VALUE vv val) (list 'vv vv))))) ((typep val 'short-float) (list 'LOCATION (make-info :type 'short-float) (list 'SHORT-FLOAT-VALUE (add-object val) val))) ((and *compiler-compile* (not *keep-gaz*)) (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address val))))))) (always-p (list 'LOCATION (make-info :type (object-type val)) (list 'VV (add-object val)))) (t nil))) (defmacro si::define-compiler-macro (name vl &rest body) `(progn (si:putprop ',name (caddr (si:defmacro* ',name ',vl ',body)) 'compiler-macro) ',name)) (defun si::undef-compiler-macro (name) (remprop name 'compiler-macro)) (defvar *compiler-temps* '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) (defmacro si:define-inline-function (name vars &body body) (let ((temps nil) (*compiler-temps* *compiler-temps*)) (dolist (var vars) (if (and (symbolp var) (not (si:memq var '(&optional &rest &key &aux)))) (push (or (pop *compiler-temps*) (gentemp "TMP" (find-package 'compiler))) temps) (error "The parameter ~s for the inline function ~s is illegal." var name))) (let ((binding (cons 'list (mapcar #'(lambda (var temp) `(list ',var ,temp)) vars temps)))) `(progn (defun ,name ,vars ,@body) (si:define-compiler-macro ,name ,temps (list* 'let ,binding ',body)))))) (defun name-to-sd (x &aux sd) (or (and (symbolp x) (setq sd (get x 'si::s-data))) (error "The structure ~a is undefined." x)) sd) ;; lay down code for a load time eval constant. (defun name-sd1 (x) (or (get x 'name-to-sd) (setf (get x 'name-sd) `(si::|#,| name-to-sd ',x)))) (defun co1structure-predicate (f args &aux tem) (cond ((and (symbolp f) (setq tem (get f 'si::struct-predicate))) (c1expr `(typep ,(car args) ',tem))))) gcl-2.6.14/cmpnew/gcl_cmputil.lsp0000755000175000017500000001571614360276512015323 0ustar cammcamm;;; CMPUTIL Miscellaneous Functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (export '(*suppress-compiler-warnings* *suppress-compiler-notes* *compiler-break-enable*)) (defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms)) (defvar *current-form* '|compiler preprocess|) (defvar *first-error* t) (defvar *error-count* 0) (defconstant *cmperr-tag* (cons nil nil)) (defun cmperr (string &rest args &aux (*print-case* :upcase)) (print-current-form) (format t "~&;;; ") (apply #'format t string args) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defmacro cmpck (condition string &rest args) `(if ,condition (cmperr ,string ,@args))) (defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) (print-current-form) (format t ";;; ~S requires at most ~R argument~:p, ~ but ~R ~:*~[were~;was~:;were~] supplied.~%" name upper-bound n) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defun too-few-args (name lower-bound n &aux (*print-case* :upcase)) (print-current-form) (format t ";;; ~S requires at least ~R argument~:p, ~ but only ~R ~:*~[were~;was~:;were~] supplied.~%" name lower-bound n) (incf *error-count*) (throw *cmperr-tag* '*cmperr-tag*)) (defvar *suppress-compiler-warnings* nil) (defun cmpwarn (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-warnings* (print-current-form) (format t ";; Warning: ") (apply #'format t string args) (terpri)) nil) (defvar *suppress-compiler-notes* nil) (defun cmpnote (string &rest args &aux (*print-case* :upcase)) (unless *suppress-compiler-notes* (terpri) (format t ";; Note: ") (apply #'format t string args)) nil) (defun print-current-form () (when *first-error* (setq *first-error* nil) (fresh-line) (cond ((and (consp *current-form*) (eq (car *current-form*) 'si:|#,|)) (format t "; #,~s is being compiled.~%" (cdr *current-form*))) (t (let ((*print-length* 2) (*print-level* 2)) (format t "; ~s is being compiled.~%" *current-form*))))) nil) (defun undefined-variable (sym &aux (*print-case* :upcase)) (print-current-form) (format t ";; The variable ~s is undefined.~%~ ;; The compiler will assume this variable is a global.~%" sym) nil) (defun baboon (&aux (*print-case* :upcase)) (print-current-form) (format t ";;; A bug was found in the compiler. Contact Taiichi.~%") (incf *error-count*) (break) ; (throw *cmperr-tag* '*cmperr-tag*) ) ;;; Internal Macros with type declarations (defmacro dolist* ((v l &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) ((endp ,temp) ,val) (declare (object ,v)) ,@body))) (defmacro dolist** ((v l &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) ((endp ,temp) ,val) (declare (object ,temp ,v)) ,@body))) (defmacro dotimes* ((v n &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,n) (,v 0 (1+ ,v))) ((>= ,v ,temp) ,val) (declare (fixnum ,v)) ,@body))) (defmacro dotimes** ((v n &optional (val nil)) . body) (let ((temp (gensym))) `(do* ((,temp ,n) (,v 0 (1+ ,v))) ((>= ,v ,temp) ,val) (declare (fixnum ,temp ,v)) ,@body))) (defun cmp-eval (form) (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form))))) (if (car x) (let ((*print-case* :upcase)) (incf *error-count*) (print-current-form) (format t ";;; The form ~s was not evaluated successfully.~%~ ;;; You are recommended to compile again.~%" form) nil) (values-list (cdr x))))) ;(si::putprop 'setf 'c1setf 'c1special) ;;The PLACE may be a local macro, so we must take care to expand it ;;before trying to call the macro form of setf, or an error will ;(defun c1setf (args &aux fd) ; (cond ((and ; (consp (car args)) ; (symbolp (caar args)) ; (setq fd (cmp-macro-function (caar args)))) ; (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args)) ; ,@ (cdr args)))) ; (t ; (c1expr (cmp-expand-macro (macro-function 'setf) ; 'setf ; args))))) (defun macro-def-p (form &aux (fname (when (consp form) (car form)))) (when (symbolp fname) (or (member-if (lambda (x) (when (consp x) (eq (car x) fname))) *funs*) (macro-function fname)))) (defun macro-env (&aux env) (dolist (v *funs* (when env (list nil (nreverse env) nil))) (when (consp v) (push (list (car v) 'macro (cadr v)) env)))) (defun cmp-macroexpand (form) (if (macro-def-p form) (macroexpand form (macro-env)) form)) (defun cmp-macroexpand-1 (form) (if (macro-def-p form) (macroexpand-1 form (macro-env)) form)) (defun cmp-expand-macro (fd fname args &aux (form (cons fname args))) (if (macro-def-p form) (let ((env (macro-env))) (if (eq *macroexpand-hook* 'funcall) (funcall fd form env) (funcall *macroexpand-hook* fd form env))) form)) (defvar *compiler-break-enable* nil) (defun cmp-toplevel-eval (form) (let* ((si::*ihs-base* si::*ihs-top*) (si::*ihs-top* (1- (si::ihs-top))) (si::*break-enable* *compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) (dolist (v '(si::cdefn lfun inline-safe inline-unsafe inline-always c1conditional c2 c1 c1+ co1 si::structure-access co1special top-level-macro t3 t2 t1)) (si::putprop v t 'compiler-prop )) (defun compiler-def-hook (symbol code) symbol code nil) (defun compiler-clear-compiler-properties (symbol code) code (let ((v (symbol-plist symbol)) w) (tagbody top (setq w (car v)) (cond ((and (symbolp w) (get w 'compiler-prop)) (setq v (cddr v)) (remprop symbol w)) (t (setq v (cddr v)))) (or (null v) (go top))) (compiler-def-hook symbol code) )) ;hi gcl-2.6.14/cmpnew/so_locations0000755000175000017500000000017514360276512014711 0ustar cammcammcollectfn.o \ :st = .text 0x000000005ffe0000, 0x0000000000010000:\ :st = .data 0x000000005fff0000, 0x0000000000010000:\ gcl-2.6.14/cmpnew/gcl_cmplabel.lsp0000755000175000017500000002312614360276512015417 0ustar cammcamm;;; CMPLABEL Exit manager. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar *last-label* 0) (defvar *exit*) (defvar *unwind-exit*) (defvar *record-call-info* nil) ;;; *last-label* holds the label# of the last used label. ;;; *exit* holds an 'exit', which is ;;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, ;;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or ;;; RETURN-OBJECT). ;;; *unwind-exit* holds a list consisting of: ;;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, ;;; JUMP, BDS-BIND (each pushed for a single special binding), and ;;; cvar (which holds the bind stack pointer used to unbind). (defmacro next-label () `(cons (incf *last-label*) nil)) (defmacro next-label* () `(cons (incf *last-label*) t)) (defmacro wt-label (label) `(when (cdr ,label) (wt-nl "goto T" (car ,label) ";")(wt-nl1 "T" (car ,label) ":;"))) (defmacro wt-go (label) `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")(wt-nl))) (defvar *restore-avma* nil) (defun unwind-bds (bds-cvar bds-bind) (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");")) (dotimes* (n bds-bind) (wt-nl "bds_unwind1;"))) (defun unwind-exit (loc &optional (jump-p nil) fname &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt) (declare (fixnum bds-bind)) (and *record-call-info* (record-call-info loc fname)) (when (and (eq loc 'fun-val) (not (eq *value-to-go* 'return)) (not (eq *value-to-go* 'top))) (wt-nl) (reset-top)) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true)) (set-jump-true loc (cadr *value-to-go*)) (when (eq loc t) (return-from unwind-exit))) ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false)) (set-jump-false loc (cadr *value-to-go*)) (when (null loc) (return-from unwind-exit)))) (dolist* (ue *unwind-exit* (baboon)) (cond ((consp ue) (cond ((eq ue *exit*) (cond ((and (consp *value-to-go*) (or (eq (car *value-to-go*) 'jump-true) (eq (car *value-to-go*) 'jump-false))) (unwind-bds bds-cvar bds-bind)) (t (if (or bds-cvar (plusp bds-bind)) ;;; Save the value if LOC may possibly refer ;;; to special binding. (if (and (consp loc) (or (and (eq (car loc) 'var) (member (var-kind (cadr loc)) '(SPECIAL GLOBAL))) (member (car loc) '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM INLINE-CHARACTER INLINE-INTEGER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)))) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'vs)) (set-loc loc) (unwind-bds bds-cvar bds-bind)) (t (let ((temp (list 'cvar (cs-push)))) (let ((*value-to-go* temp)) (set-loc loc)) (unwind-bds bds-cvar bds-bind) (set-loc temp)))) (progn (unwind-bds bds-cvar bds-bind) (set-loc loc))) (set-loc loc)))) (when jump-p (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) (wt-nl) (wt-go *exit*)) (return)) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 ((eq (car ue) 'sup) (when (and ;; If we've pushed the sup, we've always reset vs_top, as we're ;; using c2expr-top{*}. Regardless then of whether we are ;; explicitly unwinding a fun-val, we must reset the top, unless ;; unless returning, when we rely on the returning code to leave ;; the stack in the correct state, regardless of loc being a fun-val ;; or otherwise. We might need to reset when returning and loc is not ;; fun-val, but this appears doubtful. 20040306 CM ;; (eq loc 'fun-val) (not (eq *value-to-go* 'return)) (not (eq *value-to-go* 'top))) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) (t (setq jump-p t)))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((eq ue 'return) (when (eq *exit* 'return) ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*. (set-loc loc) (unwind-bds bds-cvar bds-bind) (wt-nl "return;") (return)) ;;; Never reached ) ((eq ue 'frame) (when (and (consp loc) (member (car loc) '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT))) (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'vs)) (set-loc loc) (setq loc *value-to-go*)) (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push))))) (set-loc loc) (setq loc *value-to-go*))))) (wt-nl "frs_pop();")) ((eq ue 'tail-recursion-mark)) ((eq ue 'jump) (setq jump-p t)) ((setq type.wt (assoc ue '((return-fixnum fixnum . wt-fixnum-loc) (return-character character . wt-character-loc) (return-short-float short-float . wt-short-float-loc) (return-long-float long-float . wt-long-float-loc) (return-object t . wt-loc)))) (let ((cvar (next-cvar))) (or (eq *exit* (car type.wt)) (wfs-error)) (setq type.wt (cdr type.wt)) (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ") (funcall (cdr type.wt) loc) (wt ";") (unwind-bds bds-cvar bds-bind) (wt-nl "VMR" *reservation-cmacro* "(" (if (equal (rep-type (car type.wt)) "long ") "(object)" "") "V" cvar")}") (return))) (t (baboon)) ;;; Never reached )) ) (defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0)) (declare (fixnum bds-bind)) (dolist* (ue *unwind-exit* (baboon)) (cond ((consp ue) (when (eq ue exit) (unwind-bds bds-cvar bds-bind) (return)) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 (when (eq (car ue) 'sup) (wt-nl "sup=V" (cdr ue) ";") (wt-nl) (reset-top))) ((numberp ue) (setq bds-cvar ue bds-bind 0)) ((eq ue 'bds-bind) (incf bds-bind)) ((member ue '(return return-object return-fixnum return-character return-long-float return-short-float)) (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind) (return)) (t (baboon))) ;;; Never reached ) ((eq ue 'frame) (wt-nl "frs_pop();")) ((eq ue 'tail-recursion-mark) (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind) (return)) (t (baboon))) ;;; Never reached ) ((eq ue 'jump)) (t (baboon)) ;;; Never reached )) ) ;;; Tail-recursion optimization for a function F is possible only if ;;; 1. the value of *DO-TAIL-RECURSION* is non-nil (this is default), ;;; 2. F receives only required parameters, and ;;; 3. no required parameter of F is enclosed in a closure. ;;; ;;; A recursive call (F e1 ... en) may be replaced by a loop only if ;;; 1. F is not declared as NOTINLINE, ;;; 2. n is equal to the number of required parameters of F, ;;; 3. the form is a normal function call (i.e. the arguments are ;;; pushed on the stack, ;;; 4. (F e1 ... en) is not surrounded by a form that causes dynamic ;;; binding (such as LET, LET*, PROGV), ;;; 5. (F e1 ... en) is not surrounded by a form that that pushes a frame ;;; onto the frame-stack (such as BLOCK and TAGBODY whose tags are ;;; enclosed in a closure, and CATCH), (defun tail-recursion-possible () (dolist* (ue *unwind-exit* (baboon)) (cond ((eq ue 'tail-recursion-mark) (return t)) ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame)) (return nil)) ((or (consp ue) (eq ue 'jump))) (t (baboon))))) gcl-2.6.14/cmpnew/gcl_cmpinit.lsp0000755000175000017500000000063014360276512015276 0ustar cammcamm;(proclaim '(optimize (safety 0) (space 3))) ;(proclaim '(optimize (safety 2) (space 3))) (load "../lsp/sys-proclaim.lisp") (load "sys-proclaim.lisp") (setq compiler::*eval-when-defaults* '(compile eval load)) ;(load "cmptop.lsp") ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval )) (si::nload (format nil "~(~a~).lsp" v))) gcl-2.6.14/cmpnew/gcl_cmpbind.lsp0000755000175000017500000001055214360276512015253 0ustar cammcamm;;; CMPBIND Variable Binding. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'bds-bind 'set-bds-bind 'set-loc) ;;; Those functions that call the following binding functions should ;;; rebind the special variables, ;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*. (defun c2bind (var) (case (var-kind var) (LEXICAL (when (var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(") (wt-vs (var-ref var)) (wt ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push)))) (SPECIAL (wt-nl "bds_bind(" (vv-str (var-loc var)) ",") (wt-vs (var-ref var)) (wt ");") (push 'bds-bind *unwind-exit*)) (DOWN (cond ((integerp (var-loc var)) (wt-nl "base0[" (var-loc var) "]=") (wt-vs (var-ref var)) (wt ";")) (t (wfs-error)))) (INTEGER (wt-nl "SETQ_IO(V" (var-loc var)"," "V" (var-loc var)"alloc,") (wt "(") (wt-vs (var-ref var)) (wt "),") (wt (bignum-expansion-storage) ");")) (t (wt-nl "V" (var-loc var) "=") (case (var-kind var) (OBJECT) (FIXNUM (wt "fix")) (CHARACTER (wt "char_code")) (LONG-FLOAT (wt "lf")) (SHORT-FLOAT (wt "sf")) (t (baboon))) (wt "(") (wt-vs (var-ref var)) (wt ");"))) ) (defun c2bind-loc (var loc) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (wt-nl) (wt-vs (var-ref var)) (wt "=MMcons(" loc ",") (wt-clink) (wt ");") (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) (SPECIAL (wt-nl "bds_bind(" (vv-str (var-loc var)) "," loc ");") (push 'bds-bind *unwind-exit*)) (DOWN (wt-nl "base0[" (var-loc var) "]=" loc ";")) (INTEGER (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) (save-avma '(nil integer)) (wt-nl "V" (var-loc var) "= ") (wt-integer-loc loc var) (wt ";") (close-inline-blocks))) (t (wt-nl "V" (var-loc var) "= ") (case (var-kind var) (OBJECT (wt-loc loc)) (FIXNUM (wt-fixnum-loc loc)) (CHARACTER (wt-character-loc loc)) (LONG-FLOAT (wt-long-float-loc loc)) (SHORT-FLOAT (wt-short-float-loc loc)) (t (baboon))) (wt ";"))) ) (defun c2bind-init (var init) (case (var-kind var) (LEXICAL (cond ((var-ref-ccb var) (let ((loc (list 'vs (var-ref var)))) (let ((*value-to-go* loc)) (c2expr* init)) (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*) (wt ");")) (clink (var-ref var)) (setf (var-ref-ccb var) (ccb-vs-push))) (t (let ((*value-to-go* (list 'vs (var-ref var)))) (c2expr* init))))) (SPECIAL (let ((*value-to-go* (list 'bds-bind (var-loc var)))) (c2expr* init)) (push 'bds-bind *unwind-exit*)) (DOWN (let ((*value-to-go* (list 'down (var-loc var)))) (c2expr* init))) ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) (let ((*value-to-go* (list 'var var nil))) (c2expr* init))) (t (baboon))) ) (defun set-bds-bind (loc vv) (wt-nl "bds_bind(" (vv-str vv) "," loc ");")) gcl-2.6.14/cmpnew/gcl_cmpenv.lsp0000755000175000017500000006172114360276512015133 0ustar cammcamm;;; CMPENV Environments of the Compiler. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (defvar *safe-compile* nil) (defvar *compiler-check-args* nil) (defvar *compiler-push-events* nil) (defvar *speed* 3) (defvar *space* 0) ;;; Only these flags are set by the user. ;;; If *safe-compile* is ON, some kind of run-time checks are not ;;; included in the compiled code. The default value is OFF. (defun init-env () (setq *next-cvar* 0) (setq *next-cmacro* 0) (setq *next-vv* -1) (setq *next-cfun* 0) (setq *last-label* 0) (clrhash *objects*) (setq *hash-eq* nil) (setq *constants* nil) (setq *local-funs* nil) (setq *global-funs* nil) (setq *global-entries* nil) (setq *undefined-vars* nil) (setq *reservations* nil) (setq *closures* nil) (setq *top-level-forms* nil) (setq *function-declarations* nil) (setq *inline-functions* nil) (setq *inline-blocks* 0) (setq *notinline* nil) ) (defvar *next-cvar* 0) (defvar *next-cmacro* 0) (defvar *next-vv* -1) (defvar *next-cfun* 0) ;;; *next-cvar* holds the last cvar number used. ;;; *next-cmacro* holds the last cmacro number used. ;;; *next-vv* holds the last VV index used. ;;; *next-cfun* holds the last cfun used. (defmacro next-cfun () '(incf *next-cfun*)) (defun add-symbol (symbol) (add-object symbol)) (defun add-object2 (object) (let* ((init (if (when (consp object) (eq (car object) '|#,|)) (cdr object) `',object)) (object (if (when (consp init) (eq (car init) 'si::nani)) (si::nani (cadr init)) object))) (cond ((gethash object *objects*)) ((push-data-incf nil) (when init (add-init `(si::setvv ,*next-vv* ,init))) (setf (gethash object *objects*) *next-vv*))))) ;; Write to a string with all the *print-.. levels bound appropriately. (defun wt-to-string (x &aux (*compiler-output-data* (make-string-output-stream)) *fasd-data*) (wt-data1 x) (get-output-stream-string *compiler-output-data*)) (defun ltvp-eval (form) (cond ((atom form) form) ((eq (car form) 'si::|#,|) (ltvp-eval (cdr form))) ((eq (car form) 'si::nani) (si::nani (cadr form))) (form))) (defun ltvp (val) (when (consp val) (eq (car val) 'si::|#,|))) (defun add-object (object) (cond ((ltvp object) object) ((and *compiler-compile* (not *keep-gaz*)) (cons 'si::|#,| `(si::nani ,(si::address object)))) (object))) (defun add-constant (symbol) (add-object (cons 'si::|#,| symbol))) (defmacro next-cvar () '(incf *next-cvar*)) (defmacro next-cmacro () '(incf *next-cmacro*)) ;;; Tail recursion information. (defvar *do-tail-recursion* t) (defvar *tail-recursion-info* nil) ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL. ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. ;;; If possible, *tail-recursion-info* holds ;;; ( fname required-arg .... required-arg ), ;;; where each required-arg is a var-object. (defvar *function-declarations* nil) ;;; *function-declarations* holds : ;;; (... ( { function-name | fun-object } arg-types return-type ) ...) ;;; Function declarations for global functions are ASSOCed by function names, ;;; whereas those for local functions are ASSOCed by function objects. ;;; ;;; The valid argment type declaration is: ;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] ) ;;; though &optional, &rest, and &key return types are simply ignored. (defun function-arg-types (arg-types &aux vararg (types nil) result) (setq result (do ((al arg-types (cdr al)) (i 0 (the fixnum (+ 1 i)))) ((endp al) (nreverse types)) (declare (fixnum i)) (cond ((or (member (car al) '(&optional &rest &key)) (equal (car al) '* )) (setq vararg t) (return (nreverse (cons '* types))))) ;; only the first 9 args may have proclaimed type different from T (push (cond ((< i 9) (let ((tem (type-filter (car al)))) (if (eq 'integer tem) t tem))) (t (if (eq (car al) '*) '* t))) types))) ;;only type t args for var arg so far. (cond (vararg (do ((v result (cdr v))) ((null v)) (setf (car v) (if (eq (car v) '*) '* t))))) result) ;;; The valid return type declaration is: ;;; (( VALUES {type}* )) or ( {type}* ). (defun function-return-type (return-types) (and (eq (car return-types) 'values) (setq return-types (cdr return-types))) (cond ((endp return-types) nil) ((and (consp (car return-types)) (eq (caar return-types) 'values)) (function-return-type (cdr (car return-types)))) (t (do ((v return-types (cdr v)) (result)) ((endp v)(or (null v) (warn "The function return type ~s is illegal." return-types)) (nreverse result)) (let ((tem (if (eq (car v) '*) '* (type-filter (car v))))) (if (eq tem 'integer) (setq tem t)) (push tem result)))))) (defun add-function-proclamation (fname decl list &aux (procl t) arg-types return-types) (cond ((and (symbolp fname) (listp decl) (listp (cdr decl))) (cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*))) (t (setq arg-types (function-arg-types (car decl))) )) (setq return-types (function-return-type (cdr decl))) (cond ((and (consp return-types) ; ie not nil (endp (cdr return-types)) (not (eq (car return-types) '*))) (setq return-types ;; varargs must return type t currently. (if (member '* (and (consp arg-types) arg-types)) t (car return-types)))) (t (setq procl nil))) (cond ((and (listp arg-types) (< (length arg-types) call-arguments-limit))) (t (setq procl nil))) (do ((fname fname (car list))) (()) (or (symbolp fname) (return (add-function-proclamation fname decl nil))) (if (eq arg-types '*) (remprop fname 'proclaimed-arg-types) (si:putprop fname arg-types 'proclaimed-arg-types)) (si:putprop fname return-types 'proclaimed-return-type) ;;; A non-local function may have local entry only if it returns ;;; a single value. (if procl (si:putprop fname t 'proclaimed-function) (remprop fname 'proclaimed-function)) (setq list (cdr list)) (or (consp list) (return 'done)) )) (t (warn "The function procl ~s ~s is not valid." fname decl)))) (defun add-function-declaration (fname arg-types return-types) (cond ((symbolp fname) (push (list (sch-local-fun fname) (function-arg-types arg-types) (function-return-type return-types)) *function-declarations*)) (t (warn "The function name ~s is not a symbol." fname)))) (defun get-arg-types (fname &aux x) (if (setq x (assoc fname *function-declarations*)) (cadr x) (get fname 'proclaimed-arg-types))) (defun get-return-type (fname) (let* ((x (assoc fname *function-declarations*)) (type1 (if x (caddr x) (get fname 'proclaimed-return-type))) (type (if (get fname 'predicate) 'boolean (get fname 'return-type)))) (cond (type1 (cond (type (cond ((setq type (type-and type type1)) type) (t (cmpwarn "The return type of ~s was badly declared." fname)))) (t type1))) (t type)))) (defun get-local-arg-types (fun &aux x) (if (setq x (assoc fun *function-declarations*)) (cadr x) nil)) (defun get-local-return-type (fun &aux x) (if (setq x (assoc fun *function-declarations*)) (caddr x) nil)) (defvar *sup-used* nil) (defvar *base-used* nil) (defun reset-top () (wt "vs_top=sup;") (setq *sup-used* t)) (defmacro base-used () '(setq *base-used* t)) ;;; Proclamation and declaration handling. (defvar *alien-declarations* nil) (defvar *notinline* nil) (defun inline-possible (fname) (not (or *compiler-push-events* (member fname *notinline*) (get fname 'cmp-notinline)))) (defun proclaim (decl) (case (car decl) (special (dolist** (var (cdr decl)) (if (symbolp var) (si:*make-special var) (warn "The variable name ~s is not a symbol." var)))) (optimize (dolist (x (cdr decl)) (when (symbolp x) (setq x (list x 3))) (if (or (not (consp x)) (not (consp (cdr x))) (not (numberp (cadr x))) (not (<= 0 (cadr x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) (safety (setq *compiler-check-args* (>= (cadr x) 1)) (setq *safe-compile* (>= (cadr x) 2)) (setq *compiler-push-events* (>= (cadr x) 3))) (space (setq *space* (cadr x))) (speed (setq *speed* (cadr x))) (compilation-speed (setq *speed* (- 3 (cadr x)))) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (type (if (consp (cdr decl)) (proclaim-var (cadr decl) (cddr decl)) (warn "The type declaration ~s is illegal." decl))) ((fixnum character short-float long-float) (proclaim-var (car decl) (cdr decl))) (ftype (cond ((and (consp (cdr decl)) (consp (cadr decl)) (eq (caadr decl) 'function)) (add-function-proclamation (caddr decl) (cdr (cadr decl)) (cddr decl))) (t (cmpwarn "Bad function proclamation ~a" decl)))) (function (cond ((and (consp (cdr decl))) (add-function-proclamation (cadr decl) (cddr decl) nil)) (t (cmpwarn "Bad function proclamation ~a" decl)))) (inline (dolist** (fun (cdr decl)) (if (symbolp fun) (remprop fun 'cmp-notinline) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl)) (if (symbolp fun) (si:putprop fun t 'cmp-notinline) (warn "The function name ~s is not a symbol." fun)))) ((object ignore ignorable) (dolist** (var (cdr decl)) (unless (symbolp var) (warn "The variable name ~s is not a symbol." var)))) (declaration (dolist** (x (cdr decl)) (if (symbolp x) (unless (member x *alien-declarations*) (push x *alien-declarations*)) (warn "The declaration specifier ~s is not a symbol." x)))) ((array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string dynamic-extent :dynamic-extent symbol t vector signed-byte unsigned-byte) (proclaim-var (car decl) (cdr decl))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl))) (and (functionp (get (car decl) :proclaim)) (dolist** (v (cdr decl)) (funcall (get (car decl) :proclaim) v))) ) ) nil ) (defun proclaim-var (type vl) (setq type (type-filter type)) (dolist** (var vl) (cond ((symbolp var) (let ((type1 (get var 'cmp-type)) (v (sch-global var))) (setq type1 (if type1 (type-and type1 type) type)) (when v (setq type1 (type-and type1 (var-type v)))) (when (null type1) (warn "Inconsistent type declaration was found for the variable ~s." var)) (si:putprop var type1 'cmp-type) (when v (setf (var-type v) type1)))) (t (warn "The variable name ~s is not a symbol." var))))) (defun mexpand-deftype (tp &aux (l (listp tp))(i (when l (cdr tp)))(tp (if l (car tp) tp))) (when (symbolp tp) (let ((fn (get tp 'si::deftype-definition))) (when fn (apply fn i))))) (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil) doc form) (loop (when (endp body) (return)) (setq form (car body)) (cond ((stringp form) (when (or (null doc-p) (endp (cdr body)) doc) (return)) (setq doc form)) ((and (consp form) (eq (car form) 'declare)) (dolist** (decl (cdr form)) ;;; Add support for 'cons' declarations, such as (declare ((vector t) foo)) ;;; 20040320 CM (cmpck (not (consp decl)) "The declaration ~s is illegal." decl) (let* ((dtype (car decl)) (dtype (or (mexpand-deftype dtype) dtype))) (if (consp dtype) (let ((stype (car dtype))) (cmpck (or (not (symbolp stype)) (cdddr dtype)) "The declaration ~s is illegal." decl) (case stype (satisfies (push decl others)) (otherwise (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var dtype) ts))))) (let ((stype dtype)) (cmpck (not (symbolp stype)) "The declaration ~s is illegal." decl) (case stype (special (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The special declaration ~s contains a non-symbol ~s." decl var) (push var ss))) ((ignore ignorable) (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The ignore declaration ~s contains a non-symbol ~s." decl var) (when (eq stype 'ignorable) (push 'ignorable is)) (push var is))) (type (cmpck (endp (cdr decl)) "The type declaration ~s is illegal." decl) (let ((type (type-filter (cadr decl)))) (when type (dolist** (var (cddr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var type) ts))))) (object (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The object declaration ~s contains a non-symbol ~s." decl var) (push (cons var 'object) ts))) (:register (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The register declaration ~s contains a non-symbol ~s." decl var) (push (cons var 'register) ts) )) ((:dynamic-extent dynamic-extent) (dolist (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var :dynamic-extent) ts))) ((fixnum character double-float short-float array atom bignum bit bit-vector common compiled-function complex cons float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence simple-array simple-bit-vector simple-string simple-base-string simple-vector single-float standard-char stream string symbol t vector signed-byte unsigned-byte) (let ((type (type-filter stype))) (when type (dolist** (var (cdr decl)) (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." decl var) (push (cons var type) ts))))) (otherwise (push decl others)))))))) (t (return))) (pop body) ) (values body ss ts is others doc) ) (defun c1decl-body (decls body &aux (dl nil)) (if (null decls) (c1progn body) (let ((*function-declarations* *function-declarations*) (*alien-declarations* *alien-declarations*) (*notinline* *notinline*) (*space* *space*) (*safe-compile* *safe-compile*)) (dolist** (decl decls dl) (case (car decl) (optimize (dolist (x (cdr decl)) (when (symbolp x) (setq x (list x 3))) (if (or (not (consp x)) (not (consp (cdr x))) (not (numberp (cadr x))) (not (<= 0 (cadr x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) (safety (setq *safe-compile* (>= (the fixnum (cadr x)) 2)) (push (list 'safety (cadr x)) dl)) (space (setq *space* (cadr x)) (push (list 'space (cadr x)) dl)) ((speed compilation-speed)) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (warn "The function declaration ~s is illegal." decl) (dolist** (fname (cddr decl)) (add-function-declaration fname (cadadr decl) (cddadr decl))))) (function (if (or (endp (cdr decl)) (endp (cddr decl)) (not (symbolp (cadr decl)))) (warn "The function declaration ~s is illegal." decl) (add-function-declaration (cadr decl) (caddr decl) (cdddr decl)))) (inline (dolist** (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'inline fun) dl) (setq *notinline* (remove fun *notinline*))) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl)) (if (symbolp fun) (progn (push (list 'notinline fun) dl) (push fun *notinline*)) (warn "The function name ~s is not a symbol." fun)))) (declaration (dolist** (x (cdr decl)) (if (symbolp x) (unless (member x *alien-declarations*) (push x *alien-declarations*)) (warn "The declaration specifier ~s is not a symbol." x)))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl)))) )) (setq body (c1progn body)) (list 'decl-body (cadr body) dl body) ) ) ) (si:putprop 'decl-body 'c2decl-body 'c2) (defun c2decl-body (decls body) (let ((*compiler-check-args* *compiler-check-args*) (*safe-compile* *safe-compile*) (*compiler-push-events* *compiler-push-events*) (*notinline* *notinline*) (*space* *space*) ) (dolist** (decl decls) (case (car decl) (safety (let ((level (cadr decl))) (declare (fixnum level)) (setq *compiler-check-args* (>= level 1) *safe-compile* (>= level 2) *compiler-push-events* (>= level 3)))) (space (setq *space* (cadr decl))) (notinline (push (cadr decl) *notinline*)) (inline (setq *notinline* (remove (cadr decl) *notinline*))) (otherwise (baboon)))) (c2expr body)) ) (defun check-vdecl (vnames ts is) (dolist** (x ts) (unless (member (car x) vnames) (cmpwarn "Type declaration was found for not bound variable ~s." (car x)))) (dolist** (x is) (unless (or (eq x 'ignorable) (member x vnames)) (cmpwarn "Ignore/ignorable declaration was found for not bound variable ~s." x))) ) (defun proclamation (decl) (case (car decl) (special (dolist** (var (cdr decl) t) (if (symbolp var) (unless (si:specialp var) (return nil)) (warn "The variable name ~s is not a symbol." var)))) (optimize (dolist (x (cdr decl) t) (when (symbolp x) (setq x (list x 3))) (if (or (not (consp x)) (not (consp (cdr x))) (not (numberp (cadr x))) (not (<= 0 (cadr x) 3))) (warn "The OPTIMIZE proclamation ~s is illegal." x) (case (car x) (safety (unless (= (cadr x) (cond ((null *compiler-check-args*) 0) ((null *safe-compile*) 1) ((null *compiler-push-events*) 2) (t 3))) (return nil))) (space (unless (= (cadr x) *space*) (return nil))) (speed (unless (= (cadr x) *speed*) (return nil))) (compilation-speed (unless (= (- 3 (cadr x)) *speed*) (return nil))) (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) (type (if (consp (cdr decl)) (let ((type (type-filter (cadr decl))) x) (dolist** (var (cddr decl) t) (if (symbolp var) (unless (and (setq x (get var 'cmp-type)) (equal x type)) (return nil)) (warn "The variable name ~s is not a symbol." var)))) (warn "The type declaration ~s is illegal." decl))) ((fixnum character short-float long-float) (let ((type (type-filter (car decl))) x) (dolist** (var (cdr decl) t) (if (symbolp var) (unless (and (setq x (get var 'cmp-type)) (equal x type)) (return nil)) (warn "The variable name ~s is not a symbol." var))))) (ftype (if (or (endp (cdr decl)) (not (consp (cadr decl))) (not (eq (caadr decl) 'function)) (endp (cdadr decl))) (warn "The function declaration ~s is illegal." decl) (dolist** (fname (cddr decl) t) (unless (and (get fname 'proclaimed-function) (equal (function-arg-types (cadadr decl)) (get fname 'proclaimed-arg-types)) (equal (function-return-type (cddadr decl)) (get fname 'proclaimed-return-type))) (return nil))))) (function (if (or (endp (cdr decl)) (endp (cddr decl))) (warn "The function declaration ~s is illegal." decl) (and (get (cadr decl) 'proclaimed-function) (equal (function-arg-types (caddr decl)) (get (cadr decl) 'proclaimed-arg-types)) (equal (function-return-type (cdddr decl)) (get (cadr decl) 'proclaimed-return-type))))) (inline (dolist** (fun (cdr decl) t) (if (symbolp fun) (when (get fun 'cmp-notinline) (return nil)) (warn "The function name ~s is not a symbol." fun)))) (notinline (dolist** (fun (cdr decl) t) (if (symbolp fun) (unless (get fun 'cmp-notinline) (return nil)) (warn "The function name ~s is not a symbol." fun)))) ((object ignore ignorable) (dolist** (var (cdr decl) t) (unless (symbolp var) (warn "The variable name ~s is not a symbol." var)))) (declaration (dolist** (x (cdr decl) t) (if (symbolp x) (unless (member x *alien-declarations*) (return nil)) (warn "The declaration specifier ~s is not a symbol." x)))) ((array atom bignum bit bit-vector character common compiled-function complex cons double-float fixnum float hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string dynamic-extent :dynamic-extent symbol t vector signed-byte unsigned-byte) (let ((type (type-filter (car decl)))) (dolist** (var (cdr decl) t) (if (symbolp var) (unless (equal (get var 'cmp-type) type) (return nil)) (warn "The variable name ~s is not a symbol." var))))) (otherwise (unless (member (car decl) *alien-declarations*) (warn "The declaration specifier ~s is unknown." (car decl)))) ) ) gcl-2.6.14/cmpnew/gcl_init.lsp0000755000175000017500000000022114360276512014572 0ustar cammcamm(defun lcs1 (file) (compile-file file :c-file t :h-file t :data-file t :ob-file t :system-p t)) gcl-2.6.14/cmpnew/sys-proclaim.lisp0000644000175000017500000005047714360276512015614 0ustar cammcamm (COMMON-LISP::IN-PACKAGE "COMPILER") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*) COMPILER::WT-CHARACTER-LOC COMPILER::T1EXPR COMPILER::C2PROGN COMPILER::WT-TO-STRING COMPILER::CMP-EVAL COMPILER::WT-FIXNUM-LOC COMPILER::T1EVAL-WHEN COMPILER::MEXPAND-DEFTYPE COMPILER::SET-LOC COMPILER::C2OR COMPILER::C2AND COMPILER::WT-LOC COMPILER::CMP-TOPLEVEL-EVAL COMPILER::WT-LONG-FLOAT-LOC COMPILER::WT-SHORT-FLOAT-LOC COMPILER::C2EXPR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T) COMPILER::MAKE-VAR COMPILER::C2FSET COMPILER::CS-PUSH COMPILER::MAKE-FUN COMPILER::LIST-INLINE COMPILER::WT-CLINK COMPILER::FCALLN-INLINE COMPILER::MAKE-INFO COMPILER::MAKE-TAG COMPILER::LIST*-INLINE COMPILER::MAKE-BLK COMPILER::COMPILER-COMMAND)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T (COMMON-LISP::ARRAY COMMON-LISP::T (COMMON-LISP::*)) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) COMMON-LISP::T) COMMON-LISP::FIXNUM) COMPILER::PUSH-ARRAY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T (COMMON-LISP::ARRAY COMMON-LISP::T (COMMON-LISP::*)) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) COMMON-LISP::T) COMMON-LISP::FIXNUM) COMPILER::BSEARCHLEQ)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) COMPILER::WT-FIRST-VAR-ARG COMPILER::CLOSE-INLINE-BLOCKS COMPILER::WT-DATA-END COMPILER::CCB-VS-PUSH COMPILER::INC-INLINE-BLOCKS COMPILER::CVS-PUSH COMPILER::C1NIL COMPILER::MACRO-ENV COMPILER::WT-C-PUSH COMPILER::TAIL-RECURSION-POSSIBLE COMPILER::VS-PUSH COMPILER::WT-CVARS COMPILER::RESET-TOP COMPILER::WT-DATA-BEGIN COMPILER::WFS-ERROR COMPILER::PRINT-CURRENT-FORM COMPILER::INIT-ENV COMPILER::BABOON COMPILER::WT-NEXT-VAR-ARG COMPILER::GAZONK-NAME COMPILER::ADD-LOAD-TIME-SHARP-COMMA COMPILER::WT-DATA-FILE COMPILER::PRINT-COMPILER-INFO COMPILER::C1T)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMPILER::GET-INLINE-LOC SYSTEM::ADD-DEBUG COMPILER::FAST-READ COMPILER::WT-GO COMPILER::MAKE-USER-INIT COMPILER::C2THROW COMPILER::C2MULTIPLE-VALUE-PROG1 COMPILER::NEXT-CFUN COMPILER::TYPE>= COMPILER::C2DM-BIND-INIT COMPILER::NCONC-FILES COMPILER::DO-CHANGED COMPILER::BASE-USED COMPILER::COERCE-LOC COMPILER::NEXT-LABEL* COMPILER::PUSH-CHANGED COMPILER::C2DM-BIND-VL COMPILER::WT-FIXNUM-VALUE COMPILER::TYPE-AND COMPILER::CAN-BE-REPLACED SYSTEM::DEFINE-INLINE-FUNCTION COMPILER::CONVERT-CASE-TO-SWITCH COMPILER::SET-BDS-BIND COMPILER::NEED-TO-PROTECT COMPILER::COMPILER-BUILD COMPILER::SAFE-COMPILE COMPILER::C2EXPR-TOP* COMPILER::IS-REFERRED COMPILER::C1FMLA COMPILER::CK-SPEC COMPILER::CO1WRITE-BYTE COMPILER::CO1CONSTANT-FOLD COMPILER::WT-SHORT-FLOAT-VALUE COMPILER::CO1TYPEP COMPILER::BIGNUM-EXPANSION-STORAGE COMPILER::C1CONSTANT-VALUE COMPILER::CHANGED-LENGTH COMPILER::UNWIND-BDS COMPILER::DOTIMES** COMPILER::CO1CONS COMPILER::CO1STRUCTURE-PREDICATE COMPILER::DO-REFERRED COMPILER::C2ASSOC!2 COMPILER::NEXT-LABEL COMPILER::C2CALL-LAMBDA COMPILER::C1PROGN* COMPILER::FLAG-P COMPILER::CFAST-WRITE COMPILER::T23EXPR COMPILER::C2MULTIPLE-VALUE-SETQ COMPILER::CO1VECTOR-PUSH COMPILER::WT-LABEL COMPILER::C2CATCH COMPILER::CHECK-FNAME-ARGS COMPILER::SET-DBIND COMPILER::C2LAMBDA-EXPR-WITHOUT-KEY COMPILER::SET-VS COMPILER::C1DECL-BODY COMPILER::C1ARGS COMPILER::C2LIST-NTH-IMMEDIATE COMPILER::C2RETURN-CCB COMPILER::IN-ARRAY COMMON-LISP::DEFINE-COMPILER-MACRO COMPILER::C2APPLY COMPILER::CO1WRITE-CHAR COMPILER::C2DM-BIND-LOC COMPILER::WT-NL COMPILER::WT-LONG-FLOAT-VALUE COMPILER::CO1READ-BYTE COMPILER::REMOVE-FLAG COMPILER::CO1LDB COMPILER::WT-VAR COMPILER::COERCE-LOC-STRUCTURE-REF COMPILER::PUSH-CHANGED-VARS COMPILER::C2PSETQ COMPILER::SHIFT>> COMPILER::PROCLAIM-VAR COMPILER::IS-CHANGED COMPILER::ADD-DEBUG-INFO COMPILER::CO1SUBLIS COMPILER::WT-CHARACTER-VALUE COMPILER::C2EXPR-TOP COMPILER::WT-REQUIREDS COMPILER::DOTIMES* COMPILER::PRIN1-CMP COMPILER::PUSH-CHANGED-WITH-START COMPILER::DOLIST* COMPILER::C2BLOCK-CLB COMPILER::CMPCK COMPILER::PUSH-REFERRED-WITH-START COMPILER::INLINE-PROC COMPILER::CK-VL COMPILER::C1EXPR* COMPILER::WT-H COMPILER::STRUCT-TYPE-OPT COMPILER::C2UNWIND-PROTECT COMPILER::ARGS-INFO-CHANGED-VARS COMPILER::C2LAMBDA-EXPR-WITH-KEY COMPILER::SET-JUMP-TRUE COMPILER::WT-MAKE-DCLOSURE COMPILER::WT-NL1 COMPILER::CO1SCHAR COMPILER::JUMPS-TO-P COMPILER::DOLIST** COMPILER::COMPILER-DEF-HOOK COMPILER::NEXT-CMACRO COMPILER::C2MEMBER!2 COMPILER::RESULT-TYPE-FROM-ARGS COMPILER::CO1EQL COMPILER::C2CALL-LOCAL COMPILER::SET-JUMP-FALSE COMPILER::C2MULTIPLE-VALUE-CALL COMPILER::C2BIND-LOC COMPILER::C1SETQ1 COMPILER::CO1READ-CHAR COMPILER::REFERRED-LENGTH COMPILER::C2STACK-LET COMPILER::WT COMPILER::CMPFIX-ARGS COMPILER::NEXT-CVAR COMPILER::ARGS-INFO-REFERRED-VARS COMPILER::COMPILER-CLEAR-COMPILER-PROPERTIES SYSTEM::SWITCH COMPILER::COMPILER-CC COMPILER::FLAGS COMPILER::T3SHARP-COMMA COMPILER::C2SETQ COMPILER::C2RETURN-CLB COMPILER::C1LAMBDA-FUN COMPILER::C2BLOCK-CCB COMPILER::IS-REP-REFERRED COMPILER::MAYBE-WT-C2DM-BIND-VL COMPILER::WT-V*-MACROS SYSTEM::SWITCH-FINISH COMPILER::STACK-LET COMPILER::SHIFT<< COMPILER::DO-ARRAY COMPILER::MULTIPLE-VALUE-CHECK COMPILER::DOWNWARD-FUNCTION COMPILER::EQL-NOT-NIL COMPILER::ADD-INFO COMPILER::MAYBE-EVAL COMPILER::MIA COMPILER::PUSH-REFERRED COMPILER::C2BIND-INIT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) COMPILER::COMPILE-FILE1 COMMON-LISP::COMPILE-FILE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::ARRAY COMMON-LISP::T (COMMON-LISP::*))) COMMON-LISP::T) COMPILER::COPY-ARRAY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::FIXNUM) COMPILER::PROCLAIMED-ARGD COMPILER::ANALYZE-REGS COMPILER::ANALYZE-REGS1)) (COMMON-LISP::MAPC (COMMON-LISP::LAMBDA (COMPILER::X) (COMMON-LISP::SETF (COMMON-LISP::GET COMPILER::X 'COMPILER::PROCLAIMED-CLOSURE) COMMON-LISP::T)) '(COMMON-LISP::DISASSEMBLE COMMON-LISP::COMPILE COMPILER::CMP-ANON COMPILER::CMP-TMP-MACRO)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) COMPILER::C1DM-VL COMPILER::C2RETURN-FROM COMPILER::C2DM COMPILER::C1DM-V COMPILER::C2APPLY-OPTIMIZE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) COMPILER::T3DEFUN-AUX)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) COMPILER::C2IF COMPILER::WT-INLINE COMPILER::C2FLET COMPILER::C2LABELS COMPILER::C2COMPILER-LET)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER COMMON-LISP::*)) COMMON-LISP::T) COMPILER::TS COMPILER::DASH-TO-UNDERSCORE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) COMPILER::C2BLOCK-LOCAL COMPILER::C1SYMBOL-FUN COMPILER::WT-INLINE-LOC COMPILER::C2RETURN-LOCAL COMPILER::C2BLOCK COMPILER::C2DECL-BODY COMPILER::C1BODY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMPILER::WT-COMMENT COMPILER::INIT-NAME COMPILER::ADD-INIT COMPILER::CMPWARN COMPILER::FAST-LINK-PROCLAIMED-TYPE-P COMPILER::UNWIND-EXIT COMPILER::CMPNOTE COMPILER::C1CASE COMPILER::WT-INTEGER-LOC COMPILER::C1LAMBDA-EXPR COMPILER::WT-CVAR COMPILER::CMPERR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER COMMON-LISP::*) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) COMPILER::DASH-TO-UNDERSCORE-INT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMPILER::WT-GLOBAL-ENTRY COMPILER::MY-CALL COMPILER::C2CALL-GLOBAL COMPILER::C1MAKE-VAR COMPILER::T3DEFUN-VARARG COMPILER::C2SWITCH COMPILER::C2CALL-UNKNOWN-GLOBAL COMPILER::C2STRUCTURE-REF COMPILER::T3DEFUN-NORMAL COMPILER::WT-IF-PROCLAIMED)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMPILER::T3LOCAL-FUN COMPILER::T2DEFUN COMPILER::T3LOCAL-DCFUN COMPILER::T3DEFUN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMPILER::MYSUB COMPILER::WT-INLINE-INTEGER COMPILER::C2MAPC COMPILER::WT-INLINE-LONG-FLOAT COMPILER::C2PROGV COMPILER::CHECK-VDECL COMPILER::AND-FORM-TYPE COMPILER::WT-INLINE-CHARACTER COMPILER::C2MAPCAR COMPILER::MAKE-INLINE-STRING COMPILER::C-FUNCTION-NAME COMPILER::WT-INLINE-COND COMPILER::ADD-FUNCTION-DECLARATION COMPILER::T3DEFCFUN COMPILER::C2MAPCAN COMPILER::C1DM COMPILER::ASSIGN-DOWN-VARS COMPILER::CJT COMPILER::SET-VAR COMPILER::COMPILER-PASS2 COMPILER::TOO-FEW-ARGS COMPILER::C2MULTIPLE-VALUE-BIND COMPILER::C2GO COMPILER::C2FUNCALL-SFUN COMPILER::C2PRINC COMPILER::WT-INLINE-SHORT-FLOAT COMPILER::C1STRUCTURE-REF1 COMPILER::GET-INLINE-INFO COMPILER::CAN-BE-REPLACED* COMPILER::CJF COMPILER::ADD-FUNCTION-PROCLAMATION COMPILER::C2LET* COMPILER::C2TAGBODY COMPILER::CMP-EXPAND-MACRO COMPILER::CHECK-FORM-TYPE COMPILER::C2LET COMPILER::C2CASE COMPILER::WT-MAKE-CCLOSURE COMPILER::TOO-MANY-ARGS COMPILER::BOOLE3 COMPILER::SUBLIS1-INLINE COMPILER::WT-INLINE-FIXNUM COMPILER::FIX-DOWN-ARGS COMPILER::C1MAP-FUNCTIONS COMPILER::INLINE-TYPE-MATCHES COMPILER::ADD-FAST-LINK)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMPILER::C2LAMBDA-EXPR COMPILER::INLINE-ARGS COMPILER::C2FUNCALL COMPILER::LINK)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMPILER::C2STRUCTURE-SET COMPILER::T3INIT-FUN COMPILER::C1APPLY-OPTIMIZE COMPILER::T3DEFUN-LOCAL-ENTRY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMPILER::T2DEFENTRY COMPILER::DEFSYSFUN COMPILER::T3DEFENTRY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMPILER::GET-OUTPUT-PATHNAME COMPILER::WT-SIMPLE-CALL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) COMPILER::MLIN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) COMPILER::MEMOIZED-HASH-EQUAL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) COMPILER::C1PSETQ COMPILER::ADD-LOOP-REGISTERS COMPILER::FSET-FN-NAME COMPILER::CMP-MACRO-FUNCTION COMPILER::C1PROGN COMPILER::C1SHARP-COMMA COMPILER::C1PRINC COMPILER::C1EXPR COMPILER::CONS-TO-LISTA COMPILER::RESET-INFO-TYPE COMPILER::WT-VS* COMPILER::FUNCTION-RETURN-TYPE COMPILER::C2DM-RESERVE-VL COMPILER::C1APPLY COMPILER::GET-INCLUDED COMPILER::BLK-REF-CCB COMPILER::C1MACROLET COMPILER::ADD-OBJECT COMPILER::C1ASH-CONDITION COMPILER::FUN-REF COMPILER::T1DEFLA COMPILER::C1NTHCDR COMPILER::C1FUNCTION COMPILER::PROCLAMATION COMPILER::C2FUNCALL-AUX COMPILER::MAXARGS COMPILER::INFO-VOLATILE COMPILER::C1ASSOC COMPILER::C1MAPLIST COMPILER::CLINK COMPILER::C1BOOLE-CONDITION COMPILER::C1VAR COMPILER::VERIFY-DATUM COMPILER::C1OR COMPILER::FUNCTION-ARG-TYPES COMPILER::C2FUNCTION COMPILER::INLINE-POSSIBLE COMPILER::C2GO-LOCAL COMPILER::C1COMPILER-LET COMPILER::NAME-SD1 COMPILER::C1LET COMPILER::C1MULTIPLE-VALUE-BIND COMPILER::C1LOCAL-FUN COMPILER::CHARACTER-LOC-P COMPILER::VARARG-P COMPILER::FIXNUM-LOC-P COMPILER::SAVE-FUNOB COMPILER::BLK-VAR COMPILER::C1STACK-LET COMPILER::C1FUNCALL COMPILER::INFO-SP-CHANGE COMPILER::T1DEFINE-STRUCTURE COMPILER::C1THROW COMPILER::T2PROGN COMPILER::GET-ARG-TYPES COMMON-LISP::PROCLAIM COMPILER::C2LOCATION COMPILER::C1IF COMPILER::CHECK-DOWNWARD COMPILER::TAG-REF-CCB COMPILER::C1MEMBER COMPILER::VAR-REP-LOC COMPILER::VV-STR COMPILER::C1RETURN-FROM COMPILER::SET-PUSH-CATCH-FRAME COMPILER::C2TAGBODY-LOCAL COMPILER::C1MAPC COMPILER::C1LET* COMPILER::WT1 COMPILER::C1PROGV COMPILER::C2TAGBODY-BODY COMPILER::C1TERPRI COMPILER::FUN-INFO COMPILER::C1EVAL-WHEN COMPILER::WT-CDR COMPILER::WT-VAR-DECL COMPILER::C1RPLACA COMPILER::REPLACE-CONSTANT COMPILER::SET-TOP COMPILER::OBJECT-TYPE COMPILER::C1TAGBODY COMPILER::T1ORDINARY COMPILER::WT-VS-BASE COMPILER::CONSTANT-FOLD-P COMPILER::C1RPLACD COMPILER::C1DOWNWARD-FUNCTION COMPILER::TYPE-FILTER COMPILER::T3PROGN COMPILER::C1LOCAL-CLOSURE COMPILER::C2RPLACD COMPILER::TAG-UNWIND-EXIT COMPILER::PUSH-DATA-INCF COMPILER::VAR-REF-CCB COMPILER::INFO-P COMPILER::WT-SYMBOL-FUNCTION COMPILER::TAG-VAR COMPILER::T1DEFMACRO COMPILER::CTOP-WRITE COMPILER::C1MAPCON COMPILER::C1FUNOB COMPILER::C2BIND COMPILER::ADD-SYMBOL COMPILER::SET-RETURN COMPILER::WT-CAR COMPILER::NAME-TO-SD COMPILER::ADD-ADDRESS COMPILER::C2GETHASH COMPILER::C1FLET COMPILER::C2TAGBODY-CLB COMPILER::C2VAR COMPILER::ADD-OBJECT2 COMPILER::BLK-REF COMPILER::INLINE-TYPE COMPILER::C2RPLACA COMPILER::C2GO-CCB COMPILER::WT-FUNCTION-LINK COMPILER::T1DEFENTRY COMPILER::C1NTH COMPILER::COPY-INFO COMPILER::WT-FASD-ELEMENT COMPILER::C1STRUCTURE-REF COMPILER::LTVP-EVAL COMPILER::VAR-NAME COMPILER::C1BOOLE3 COMPILER::C1STRUCTURE-SET COMPILER::WT-VS COMPILER::INFO-CHANGED-ARRAY COMPILER::MACRO-DEF-P COMPILER::TAG-P COMPILER::VAR-TYPE COMPILER::SHORT-FLOAT-LOC-P COMPILER::AET-C-TYPE COMPILER::BLK-VALUE-TO-GO COMPILER::C1GET COMPILER::C1AND COMPILER::C1SETQ COMPILER::C1LOAD-TIME-VALUE COMPILER::C1ECASE COMPILER::C1MAPCAN COMPILER::T1DEFUN COMPILER::C1DEFINE-STRUCTURE COMPILER::C1ASH COMPILER::C1NTHCDR-CONDITION COMPILER::BLK-EXIT COMPILER::FUN-P COMPILER::C1LABELS COMPILER::LONG-FLOAT-LOC-P COMPILER::C1SWITCH COMPILER::T1CLINES COMPILER::GET-RETURN-TYPE COMPILER::C1DM-BAD-KEY COMPILER::T1PROGN COMPILER::C1QUOTE COMPILER::WT-SWITCH-CASE COMPILER::FUN-LEVEL COMPILER::DECLARATION-TYPE COMPILER::PARSE-CVSPECS COMPILER::WT-DATA1 COMPILER::REGISTER COMPILER::C1FMLA-CONSTANT COMPILER::C1DECLARE COMPILER::VAR-P COMPILER::ADD-REG1 COMPILER::C1UNWIND-PROTECT COMPILER::C2VAR-KIND COMPILER::BLK-P COMPILER::INFO-TYPE COMPILER::THE-PARAMETER COMPILER::C2VALUES COMPILER::WRITE-BLOCK-OPEN COMPILER::C1NTH-CONDITION COMPILER::C1MAPCAR COMPILER::VAR-LOC COMPILER::SCH-GLOBAL COMPILER::WT-H1 COMPILER::SAVE-AVMA COMPILER::C1BLOCK SYSTEM::UNDEF-COMPILER-MACRO COMPILER::C1MULTIPLE-VALUE-PROG1 COMPILER::SAFE-SYSTEM COMPILER::DEFAULT-INIT COMPILER::T3ORDINARY COMPILER::CMP-MACROEXPAND-1 COMPILER::FUN-REF-CCB COMPILER::TAG-REF-CLB COMPILER::C2DOWNWARD-FUNCTION COMPILER::C1THE COMPILER::CHECK-VREF COMPILER::ARGS-CAUSE-SIDE-EFFECT COMPILER::C1ADD-GLOBALS COMPILER::WT-LIST COMPILER::SET-UP-VAR-CVS COMPILER::T1DEFCFUN COMPILER::INLINE-BOOLE3-STRING COMPILER::FIX-OPT COMPILER::VAR-REGISTER COMPILER::TAG-REF COMPILER::T2DECLARE COMPILER::DECL-BODY-SAFETY COMPILER::C1VREF COMPILER::C2DM-RESERVE-V COMPILER::BLK-NAME COMPILER::C1RPLACA-NTHCDR COMPILER::VOLATILE COMPILER::PUSH-ARGS COMPILER::C1FSET COMPILER::FLAGS-POS COMPILER::TAG-LABEL COMPILER::C1MEMQ COMPILER::C1CATCH COMPILER::GET-LOCAL-RETURN-TYPE COMPILER::WT-DATA2 COMPILER::PUSH-ARGS-LISPCALL COMPILER::FUN-NAME COMPILER::C2TAGBODY-CCB COMPILER::C2GET COMPILER::INFO-REFERRED-ARRAY COMPILER::WT-DOWNWARD-CLOSURE-MACRO COMPILER::T1MACROLET COMPILER::T3CLINES COMPILER::SCH-LOCAL-FUN COMPILER::C1LENGTH COMPILER::WT-DOWN COMPILER::WT-FUNCALL-C COMPILER::RESULT-TYPE COMPILER::MDELETE-FILE COMPILER::ADD-CONSTANT COMPILER::C1VALUES COMPILER::C1GETHASH COMPILER::CMP-MACROEXPAND COMPILER::FUN-CFUN COMPILER::C1MAPL COMPILER::UNWIND-NO-EXIT COMPILER::BLK-REF-CLB COMPILER::WT-VV COMPILER::VAR-KIND COMPILER::TAG-SWITCH COMPILER::WT-CCB-VS COMPILER::REP-TYPE COMPILER::UNDEFINED-VARIABLE COMPILER::C1MULTIPLE-VALUE-SETQ COMPILER::C2GO-CLB COMPILER::NEED-TO-SET-VS-POINTERS COMPILER::LTVP COMPILER::GET-LOCAL-ARG-TYPES COMPILER::COMPILE-ORDINARY-P COMPILER::C1LIST-NTH COMPILER::C1GO COMPILER::C1MULTIPLE-VALUE-CALL COMPILER::C2EXPR* COMPILER::VAR-REF COMPILER::WT-CADR COMPILER::TAG-NAME)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) COMPILER::INLINE-BOOLE3)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM) COMPILER::F-TYPE)) gcl-2.6.14/cmpnew/gcl_cmpmain.lsp0000755000175000017500000006637114360276512015275 0ustar cammcamm;;; CMPMAIN Compiler main program. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; **** Caution **** ;;; This file is machine/OS dependant. ;;; ***************** (in-package :compiler) (export '(*compile-print* *compile-verbose*)) (import 'si::(*tmp-dir* *cc* *ld* *objdump*)) (import 'si::*error-p* 'compiler) ;;; This had been true with Linux 1.2.13 a.out or even older ;;; #+linux (push :ld-not-accept-data *features*) ;;; its now a bug preventing the :linux feature. (defvar *compiler-in-use* nil) (defvar *compiler-compile* nil) (defvar *compiler-input*) (defvar *compiler-output1*) (defvar *compiler-output2*) (defvar *compiler-output-data*) (defvar *compiler-output-i*) (defvar *compile-print* nil) (defvar *compile-verbose* t) (defvar *cmpinclude* "\"cmpinclude.h\"") ;;If the following is a string, then it is inserted instead of ;; the include file cmpinclude.h, EXCEPT for system-p calls. (defvar *cmpinclude-string* (si::file-to-string (namestring (make-pathname :directory (append (pathname-directory si::*system-directory*) (list :back "h")) :name "cmpinclude" :type "h")))) ;; Let the user write dump c-file etc to /dev/null. (defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)) (device (pathname-device *default-pathname-defaults*))) (cond ((equal file "/dev/null") (pathname file)) #+aix3 ((and (equal name "float") (equal ext "h")) (get-output-pathname file ext "Float" )) ((let ((lf (and file (not (eq file t))))) (let ((device (if lf (pathname-device file) device)) (dir (if lf (pathname-directory file) dir)) (name (if lf (pathname-name file) name))) (make-pathname :device device :directory dir :name name :type ext)))))) (defun safe-system (string) (multiple-value-bind (code result) (system (mysub (ts string) "$" "\\$")) (unless (and (zerop code) (zerop result)) (cerror "Continues anyway." "(SYSTEM ~S) returned a non-zero value ~D ~D." string code result) (setq *error-p* t)) (values result))) ;; If this is t we use fasd-data on all but system-p files. If it ;; is :system-p we use it on all files. If nil use it on none. (defvar *fasd-data* t) (defvar *data* nil) (defvar *default-system-p* nil) (defvar *default-c-file* nil) (defvar *default-h-file* nil) (defvar *default-data-file* nil) (defvar *default-prof-p* nil) #+large-memory-model(defvar *default-large-memory-model-p* nil) (defvar *keep-gaz* nil) (defvar *prof-p* nil) #+large-memory-model(defvar *large-memory-model-p* nil) ;; (list section-length split-file-names next-section-start-file-position) ;; Many c compilers cannot handle the large C files resulting from large lisp files. ;; If *split-files* is a number then, separate compilations for sections ;; *split-files* long, with the ;; will be performed for separate chunks of the lisp files. (defvar *split-files* nil) ;; if (defvar *compile-file-truename*) (defun compile-file (filename &rest args &aux (*print-pretty* nil) (*package* *package*) (*split-files* *split-files*) (*PRINT-CIRCLE* NIL) (*PRINT-RADIX* NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-PRETTY* T) (*PRINT-LENGTH* NIL) (*PRINT-GENSYM* T) (*PRINT-CASE* :UPCASE) (*PRINT-BASE* 10) (*PRINT-ESCAPE* T) (section-length *split-files*) tem warnings failures (filename (pathname filename)) (*compile-file-pathname* (merge-pathnames filename #p".lsp")) (*compile-file-truename* (truename *compile-file-pathname*))) (loop (compiler::init-env) (setq tem (apply 'compile-file1 filename args)) (cond ((atom *split-files*) (return (values (when tem (truename tem)) warnings failures))) ((null (third *split-files*)) (let ((gaz (gazonk-name))(*readtable* (si::standard-readtable))) (with-open-file (st gaz :direction :output) (print `(eval-when (load eval) (dolist (v ',(nreverse (second *split-files*))) (load (merge-pathnames v si::*load-pathname*)))) st)) (setq *split-files* nil) (return (let ((tem (apply 'compile-file gaz (append args (unless (member :output-file args) (list :output-file (get-output-pathname filename "o" nil nil nil))))))) (unless *keep-gaz* (mdelete-file gaz)) (values (when tem (truename tem)) warnings failures))))) ((setf (car *split-files*) (+ (third *split-files*) section-length)))))) (defun compile-file1 (input-pathname &key (output-file (merge-pathnames ".o" (truename input-pathname))) (o-file t) (c-file *default-c-file*) (h-file *default-h-file*) (data-file *default-data-file*) (c-debug nil) (system-p *default-system-p*) (prof-p *default-prof-p*) #+large-memory-model(large-memory-model-p *default-large-memory-model-p*) (print nil) (load nil) &aux (*standard-output* *standard-output*) (*prof-p* prof-p) #+large-memory-model(*large-memory-model-p* large-memory-model-p) (output-file (pathname output-file)) (*error-output* *error-output*) (*compiler-in-use* *compiler-in-use*) (*c-debug* c-debug) (*compile-print* (or print *compile-print*)) (*DEFAULT-PATHNAME-DEFAULTS* #p"") (*data* (list nil)) *init-name* (*fasd-data* *fasd-data*) (*error-count* 0)) (declare (special *c-debug* *init-name* system-p)) (cond (*compiler-in-use* (format t "~&The compiler was called recursively.~%~ Cannot compile ~a.~%" (namestring (merge-pathnames input-pathname #p".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (t (setq *error-p* nil) (setq *compiler-in-use* t))) (unless (probe-file (merge-pathnames input-pathname #p".lsp")) (format t "~&The source file ~a is not found.~%" (namestring (merge-pathnames input-pathname #p".lsp"))) (setq *error-p* t) (return-from compile-file1 (values))) (when *compile-verbose* (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #p".lsp")))) (and *record-call-info* (clear-call-table)) (with-open-file (*compiler-input* (merge-pathnames input-pathname #p".lsp")) (when (numberp *split-files*) (setq *split-files* (unless (< (file-length *compiler-input*) *split-files*) (list *split-files* nil 0 nil)))) (when (consp *split-files*) (file-position *compiler-input* (third *split-files*)) (setq output-file (make-pathname :directory (pathname-directory output-file) :name (format nil "~a~a" (pathname-name output-file) (length (second *split-files*))) :type "o"))) (let* ((eof (cons nil nil)) (dir (pathname-directory (or output-file input-pathname))) (name (pathname-name (or output-file input-pathname))) (device (pathname-device (or output-file input-pathname))) (typ (pathname-type (or output-file #p".o"))) (o-pathname (get-output-pathname o-file typ name dir device)) (c-pathname (get-output-pathname c-file "c" name dir device)) (h-pathname (get-output-pathname h-file "h" name dir device)) (data-pathname (get-output-pathname data-file "data" name dir device))) (declare (special dir name)) (init-env) (and (boundp 'si::*gcl-version*) (not system-p) (add-init `(si::warn-version ,si::*gcl-major-version* ,si::*gcl-minor-version* ,si::*gcl-extra-version*))) (when (probe-file "./gcl_cmpinit.lsp") (load "./gcl_cmpinit.lsp" :verbose *compile-verbose*)) (with-open-file (*compiler-output-data* data-pathname :direction :output) (when *fasd-data* (setq *fasd-data* (list (si::open-fasd *compiler-output-data* :output nil nil)))) (wt-data-begin) (if *compiler-compile* (t1expr *compiler-compile*) (let* ((rtb *readtable*) (prev (and (eq (get-macro-character #\# rtb) (get-macro-character #\# (si:standard-readtable))) (get-dispatch-macro-character #\# #\, rtb)))) (if (and prev (eq prev (get-dispatch-macro-character #\# #\, (si:standard-readtable)))) (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler rtb) (setq prev nil)) ;; t1expr the package ops again.. (when (consp *split-files*) (dolist (v (fourth *split-files*)) (t1expr v))) (unwind-protect (do ((form (read *compiler-input* nil eof)(read *compiler-input* nil eof)) (load-flag (if *eval-when-defaults* (or (member 'load *eval-when-defaults*) (member :load-toplevel *eval-when-defaults*)) t))) (nil) (unless (eq form eof) (if load-flag (t1expr form) (maybe-eval nil form))) (when (or (eq form eof) (when *split-files* (> (file-position *compiler-input*) (car *split-files*)))) (when *split-files* (push (pathname-name output-file) (second *split-files*)) (setf (third *split-files*) (unless (eq form eof) (file-position *compiler-input*))) (setf (fourth *split-files*) nil));(reverse (third *data*)) ;FIXME check this (return nil))) (when prev (set-dispatch-macro-character #\# #\, prev rtb))))) (setq *init-name* (init-name input-pathname system-p)) (when (zerop *error-count*) (when *compile-verbose* (format t "~&End of Pass 1. ~%")) (compiler-pass2 c-pathname h-pathname system-p )) (wt-data-end)) ;;; *compiler-output-data* closed. (init-env) (if (zerop *error-count*) (progn (when *compile-verbose* (format t "~&End of Pass 2. ~%")) (cond (*record-call-info* (dump-fn-data (get-output-pathname output-file "fn" name dir device)))) (cond (o-file (compiler-cc c-pathname o-pathname ) (cond ((probe-file o-pathname) (compiler-build o-pathname data-pathname) (when load (load o-pathname)) (when *compile-verbose* (print-compiler-info) (format t "~&Finished compiling ~a.~%" (namestring output-file) ))) (t (format t "~&Your C compiler failed to compile the intermediate file.~%") (setq *error-p* t)))) (*compile-verbose* (print-compiler-info) (format t "~&Finished compiling ~a.~%" (namestring output-file) ))) (unless c-file (mdelete-file c-pathname)) (unless h-file (mdelete-file h-pathname)) (unless (or data-file #+ld-not-accept-data t system-p) (mdelete-file data-pathname)) (when o-file o-pathname)) (progn (when (probe-file c-pathname) (mdelete-file c-pathname)) (when (probe-file h-pathname) (mdelete-file h-pathname)) (when (probe-file data-pathname) (mdelete-file data-pathname)) (format t "~&No FASL generated.~%") (setq *error-p* t) (values)))))) (defun gazonk-name () (dotimes (i 1000) (let ((tem (merge-pathnames (format nil "~agazonk_~d_~d.lsp" (if (boundp '*tmp-dir*) *tmp-dir* "") (abs (si::getpid)) i)))) (unless (probe-file tem) (return-from gazonk-name (pathname tem))))) (error "1000 gazonk names used already!")) (defun prin1-cmp (form strm) (let ((*compiler-output-data* strm) (*fasd-data* nil)) (wt-data1 form) ;; this binds all the print stuff )) (defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #p".")) (cond ((not(symbolp name)) (error "Must be a name")) ((and (consp def) (member (car def) '(lambda ))) (or name (setf name 'cmp-anon)) (setf (symbol-function name) def) (compile name)) (def (error "def not a lambda expression")) ((setq tem (macro-function name)) (setf (symbol-function 'cmp-anon) tem) (compile 'cmp-anon) (setf (macro-function name) (macro-function name)) ;; FIXME -- support warnings-p and failures-p. CM 20041119 (values name nil nil)) ((and (setq tem (symbol-function name)) (consp tem)) (let ((na (if (symbol-package name) name 'cmp-anon))) (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon))) (with-open-file (st (setq gaz (gazonk-name)) :direction :output)) (let* ((*compiler-compile* `(defun ,na ,@(ecase (car tem) (lambda (cdr tem)) (lambda-block (cddr tem))))) (fi (compile-file gaz))) (when (pathnamep fi) (load fi) (mdelete-file fi))) (unless *keep-gaz* (mdelete-file gaz))) (or (eq na name) (setf (symbol-function name) (symbol-function na))) ;; FIXME -- support warnings-p and failures-p. CM 20041119 (values (symbol-function name) nil nil) )) (t (error "can't compile ~a" name)))) (defun disassemble (name &aux tem) (cond ((and (consp name) (eq (car name) 'lambda)) (eval `(defun cmp-anon ,@ (cdr name))) (disassemble 'cmp-anon)) ((not(symbolp name)) (error "Not a lambda or a name")) ((setq tem(macro-function name)) (setf (symbol-function 'cmp-tmp-macro) tem) (disassemble 'cmp-tmp-macro) (setf (macro-function name) (macro-function name)) name) ((and (setq tem (symbol-function name)) (consp tem) (eq (car tem) 'lambda-block)) (let ((gaz (gazonk-name))) (with-open-file (st gaz :direction :output) (prin1-cmp `(defun ,name ,@ (cddr tem)) st)) (let (*fasd-data*) (compile-file gaz :h-file t :c-file t :data-file t :o-file t)) (let ((cn (get-output-pathname gaz "c" gaz )) (dn (get-output-pathname gaz "data" gaz )) (hn (get-output-pathname gaz "h" gaz )) (on (get-output-pathname gaz "o" gaz ))) (with-open-file (st cn) (do () ((let ((a (read-line st))) (when (>= (si::string-match "gazonk_[0-9]*_[0-9]*.h" a) 0) (format t "~%~d~%" a) a)))) (si::copy-stream st *standard-output*)) (with-open-file (st dn) (si::copy-stream st *standard-output*)) (with-open-file (st hn) (si::copy-stream st *standard-output*)) (when *objdump* (safe-system (si::string-concatenate *objdump* (namestring on)))) (mdelete-file cn) (mdelete-file dn) (mdelete-file hn) (mdelete-file on) (unless *keep-gaz* (mdelete-file gaz))))) (t (error "can't disassemble ~a" name)))) (defun compiler-pass2 (c-pathname h-pathname system-p &aux (ci *cmpinclude*) (ci (when (stringp ci) (subseq ci 1 (1- (length ci))))) (ci (concatenate 'string si::*system-directory* "../h/" ci)) (system-p (when (probe-file ci) system-p))) (declare (special *init-name*)) (with-open-file (st c-pathname :direction :output) (let ((*compiler-output1* st)) (declare (special *compiler-output1*)) (with-open-file (*compiler-output2* h-pathname :direction :output) (cond ((and (stringp *cmpinclude-string*) (not system-p) (si::fwrite *cmpinclude-string* 0 (length *cmpinclude-string*) *compiler-output1*))) (t (wt-nl1 "#include " *cmpinclude*))) (wt-nl1 "#include \"" (namestring (make-pathname :name (pathname-name h-pathname) :type (pathname-type h-pathname))) "\"") (catch *cmperr-tag* (ctop-write *init-name*)) (terpri *compiler-output1*) ;; write ctl-z at end to make sure preprocessor stops! #+dos (write-char (code-char 26) *compiler-output1*) (terpri *compiler-output2*))))) (defvar *ld-libs* "ld-libs") (defvar *opt-three* "") (defvar *opt-two* "") (defvar *init-lsp* "init-lsp") (defvar *use-buggy* nil) (defun remove-flag (flag flags) (let ((i (search flag flags))) (if i (concatenate 'string (subseq flags 0 i) (remove-flag flag (subseq flags (+ i (length flag))))) flags))) (defun compiler-command (&rest args &aux na ) (declare (special *c-debug*)) (let ((dirlist (pathname-directory (first args))) (name (pathname-name (first args))) dir) (cond (dirlist (setq dir (namestring (make-pathname :directory dirlist)))) (t (setq dir "."))) (setq na (namestring (make-pathname :name name :type (pathname-type(first args))))) (format nil "~a ~a -I~a ~a ~a -c ~a -o ~a ~a" (concatenate 'string (if *prof-p* (remove-flag "-fomit-frame-pointer" *cc*) *cc*) #+large-memory-model(if *large-memory-model-p* " -mcmodel=large " "") #-large-memory-model "") (if *prof-p* " -pg " "") (concatenate 'string si::*system-directory* "../h") (if (and (boundp '*c-debug*) *c-debug*) " -g " "") (case *speed* (3 *opt-three* ) (2 *opt-two*) (t "")) (namestring (first args)) (namestring (second args)) (prog1 #+aix3 (format nil " -w ;ar x /lib/libc.a fsavres.o ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv ~a XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o" *init-name* (setq na (namestring (get-output-pathname na "o" nil))) na na na na na) #+(or dlopen irix5) (if (not system-p) (format nil " -w ; mv ~a XX~a ; ld ~a -shared XX~a -o ~a -lc ; rm -f XX~a" (setq na (namestring (get-output-pathname na "o" nil))) na #+ignore-unresolved "-ignore_unresolved" #+expect-unresolved "-expect_unresolved '*'" na na na)) #+(or winnt bsd) ""; "-w" #-(or aix3 bsd winnt irix3) "");" 2> /dev/null " ) ) ) #+(or cygwin winnt) (defun prep-win-path-acc ( s acc) (let ((pos (search "\~" s))) (if pos (let ((start (subseq s 0 (1+ pos))) (finish (subseq s (1+ pos)))) (prep-win-path-acc finish (concatenate 'string acc start "~"))) (concatenate 'string acc s)))) (defun compiler-cc (c-pathname o-pathname) (safe-system (format nil #+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A" #+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null" #+(or cygwin winnt) (prep-win-path-acc (compiler-command c-pathname o-pathname) "") #-(or vax system-v e15 dgux sgi) (compiler-command c-pathname o-pathname) *cc* (if (or (= *speed* 2) (= *speed* 3)) t nil) (namestring c-pathname) (namestring o-pathname) )) #+large-memory-model(when *large-memory-model-p* (mark-as-large-memory-model o-pathname)) #+dont_need (let ((cname (pathname-name c-pathname)) (odir (pathname-directory o-pathname)) (oname (pathname-name o-pathname))) (unless (and (equalp (truename "./") (truename (make-pathname :directory odir))) (equal cname oname)) (rename-file (make-pathname :name cname :type "o") o-pathname) ))) (defun compiler-build (o-pathname data-pathname) #+(and system-v (not e15)) (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A" (namestring o-pathname))) #+(or hp-ux sun sgi) (with-open-file (o-file (namestring o-pathname) :direction :output :if-exists :append) ; we could do a safe-system, but forking is slow on the Iris #+(or hp-ux (and sgi (not irix5))) (dotimes (i 12) (write-char #\^@ o-file)) #+sun ; we could do a safe-system, but forking is slow on the Iris (dolist (v '(0 0 4 16 0 0 0 0)) (write-byte v o-file)) ) #-ld-not-accept-data (when (probe-file o-pathname) (nconc-files o-pathname data-pathname) #+never (safe-system (format nil "cat ~a >> ~A" (namestring data-pathname) (namestring o-pathname))))) (defun print-compiler-info () (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%" (cond ((null *compiler-check-args*) 0) ((null *safe-compile*) 1) ((null *compiler-push-events*) 2) (t 3)) *safe-compile* *space* *speed*)) (defun nconc-files (a b) (let* ((n 256) (tem (make-string n)) (m 0)) (with-open-file (st-a a :direction :output :if-exists :append) (with-open-file (st-b b ) (sloop::sloop do (setq m (si::fread tem 0 n st-b)) while (and m (> m 0)) do (si::fwrite tem 0 m st-a)))))) #+dos (progn (defun directory (x &aux ans) (let* ((pa (pathname x)) (temp "XXDIR") tem (name (pathname-name pa))) (setq pa (make-pathname :directory (pathname-directory pa) :name (or (pathname-name pa) :wild) :type (pathname-type pa))) (setq name (namestring pa)) (safe-system (format nil "ls -d ~a > ~a" name temp)) (with-open-file (st temp) (loop (setq tem (read-line st nil nil)) (if (and tem (setq tem (probe-file tem))) (push tem ans) (return)))) ans)) (defvar *old-compile-file* #'compile-file) (defun compile-file (f &rest l) (let* ((p (pathname f)) dir pwd) (setq dir (pathname-directory p)) (when dir (setq dir (namestring (make-pathname :directory dir :name "."))) (setq pwd (namestring (truename "."))) ) (unwind-protect (progn (if dir (si::chdir dir)) (apply *old-compile-file* f l)) (if pwd (si::chdir pwd))))) (defun user-homedir-pathname () (or (si::getenv "HOME") "/")) ) ; ; These functions are added to build custom images requiring ; the loading of binary objects on systems relocating with dlopen. ; (defun make-user-init (files outn) (let* ((c (pathname outn)) (c (merge-pathnames c (make-pathname :directory '(:relative)))) (o (merge-pathnames (make-pathname :type "o") c)) (c (merge-pathnames (make-pathname :type "c") c))) (with-open-file (st c :direction :output) (format st "#include ~a~%~%" *cmpinclude*) (format st "#define load2(a) do {") (format st "printf(\"Loading %s...\\n\",(a));") (format st "load(a);") (format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") (let ((p nil)) (dolist (tem files) (when (equal (pathname-type tem) "o") (let ((tem (namestring tem))) (push (list (si::find-init-name tem) tem) p)))) (setq p (nreverse p)) (dolist (tem p) (format st "extern void ~a(void);~%" (car tem))) (format st "~%") (format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") (format st "#define NF ~a~%" (length p)) (format st "static Fnlst my_fnlst[NF]={") (dolist (tem p) (when (not (eq tem (car p))) (format st ",~%")) (format st "{~a,\"~a\"}" (car tem) (cadr tem))) (format st "};~%~%") (format st "static int user_init_run;~%") (format st "#define my_load(a_,b_) {if (!user_init_run && (a_) && (b_)) gcl_init_or_load1((a_),(b_));(a_)=0;(b_)=0;}~%~%") (format st "object user_init(void) {~%") (format st "user_init_run=1;~%") (dolist (tem files) (let ((tem (namestring tem))) (cond ((equal (cadr (car p)) tem) (format st "gcl_init_or_load1(~a,\"~a\");~%" (car (car p)) tem) (setq p (cdr p))) (t (format st "load2(\"~a\");~%" tem))))) (format st "return Cnil;}~%~%") (format st "static int my_strncmp(const char *s1,const char *s2,unsigned long n) {") (format st " for (;n--;) if (*s1++!=*s2++) return 1; return 0;}") (format st "int user_match(const char *s,int n) {~%") (format st " Fnlst *f;~%") (format st " for (f=my_fnlst;fs && !my_strncmp(s,f->s,n)) {~%") (format st " my_load(f->fn,f->s);~%") (format st " return 1;~%") (format st " }~%") (format st " }~%") (format st " return 0;~%") (format st "}~%~%"))) (compiler-cc c o) (mdelete-file c) o)) (defun mysub (str it new) (let ((x (search it str))) (unless x (return-from mysub str)) (let ((y (+ (length it) (the fixnum x)))) (declare (fixnum y)) (concatenate (type-of str) (subseq str 0 x) new (mysub (subseq str y) it new))))) (eval-when (compile eval) (defmacro fcr (x) `(load-time-value (si::compile-regexp ,x))) (defmacro sml (x y &optional z) (let ((q (gensym))) `(let ((,q (si::string-match ,x ,y ,@(when z (list z))))) (if (= ,q -1) (length ,y) ,q))))) (defun ts (s) (declare (string s)) s) (defun mdelete-file (x) (delete-file (ts (namestring x)))) (defun link (files image &optional post extra-libs (run-user-init t)) (let* ((ui (make-user-init files "user-init")) (raw (pathname image)) (init (merge-pathnames (make-pathname :name (concatenate 'string "init_" (pathname-name raw)) :type "lsp") raw)) (raw (merge-pathnames raw (truename "./"))) (raw (merge-pathnames (make-pathname :name (concatenate 'string "raw_" (pathname-name raw))) raw)) (map (merge-pathnames (make-pathname :name (concatenate 'string (pathname-name raw) "_map")) raw)) #+winnt (raw (merge-pathnames (make-pathname :type "exe") raw))) (with-open-file (st (namestring map) :direction :output)) (safe-system (let* ((par (namestring (make-pathname :directory '(:relative :back)))) (i (concatenate 'string " " par)) (j (concatenate 'string " " si::*system-directory* par))) (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" (mysub *ld* i j) (namestring raw) (namestring ui) (let ((sfiles "")) (dolist (tem files) (if (equal (pathname-type tem) "o") (setq sfiles (concatenate 'string sfiles " " (namestring tem))))) sfiles) si::*system-directory* #+gnu-ld (format nil "-Wl,-Map ~a" (namestring map)) #-gnu-ld "" (if (stringp extra-libs) extra-libs "") (mysub *ld-libs* i j)))) (mdelete-file ui) (with-open-file (st init :direction :output) (unless run-user-init (format st "(fmakunbound 'si::user-init)~%")) (format st "(setq si::*no-init* '(") (dolist (tem files) (format st " \"~a\"" (pathname-name tem))) (format st "))~%") (with-open-file (st1 (format nil "~a~a" si::*system-directory* *init-lsp*)) (si::copy-stream st1 st)) (if (stringp post) (format st "~a~%" post)) (format st "(si::save-system \"~a\")~%" (ts (namestring image)))) (safe-system (format nil "~a ~a < ~a" (namestring raw) si::*system-directory* (namestring init))) (mdelete-file raw) (mdelete-file init)) image) gcl-2.6.14/cmpnew/gcl_cmpmulti.lsp0000755000175000017500000002253014360276512015470 0ustar cammcamm;;; CMPMULT Multiple-value-call and Multiple-value-prog1. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package :compiler) (si:putprop 'multiple-value-call 'c1multiple-value-call 'c1special) (si:putprop 'multiple-value-call 'c2multiple-value-call 'c2) (si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special) (si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2) (si:putprop 'values 'c1values 'c1) (si:putprop 'values 'c2values 'c2) (si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1) (si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2) (si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1) (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2) (defun c1multiple-value-call (args &aux info funob) (when (endp args) (too-few-args 'multiple-value-call 1 0)) (cond ((endp (cdr args)) (c1funcall args)) (t (setq funob (c1funob (car args))) (setq info (copy-info (cadr funob))) (setq args (c1args (cdr args) info)) (list 'multiple-value-call info funob args))) ) (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top sup) (cond ((endp (cdr forms)) (setq loc (save-funob funob)) (let ((*value-to-go* 'top)) (c2expr* (car forms))) (c2funcall funob 'args-pushed loc)) (t (setq top (next-cvar)) (setq sup (next-cvar)) (setq loc (save-funob funob)) (base-used) ;; Add (sup .var) handling in unwind-exit -- in ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently ;; alone, c2expr-top is used to evaluate arguments, presumably to ;; preserve certain states of the value stack for the purposes of ;; retrieving the final results. c2exprt-top rebinds sup, and ;; vs_top in turn to the new sup, causing non-local exits to lose ;; the true top of the stack vital for subsequent function ;; evaluations. We unwind this stack supremum variable change here ;; when necessary. CM 20040301 (wt-nl "{object *V" top "=base+" *vs* ",*V" sup "=sup;") (dolist** (form forms) (let ((*value-to-go* 'top) (*unwind-exit* (cons (cons 'sup sup) *unwind-exit*))) (c2expr-top* form top)) (wt-nl "while(vs_basevs_top) vs_top=vs_base;") (wt-nl "*vs_top=Cnil;") (do ((vs vrefs (cdr vs))) ((endp vs)) (let ((vref (car vs))) (set-var 'fun-val (car vref) (cadr vref)) (unless (endp (cdr vs)) (wt-nl "if(vs_basevs_top) vs_top=vs_base;") (wt-nl "*vs_top=Cnil;") (do ((vs vars (cdr vs))) ((endp vs)) (c2bind-loc (car vs) '(vs-base 0)) (unless (endp (cdr vs)) (wt-nl "if (vs_base= 'boolean (type-filter (car args))) (type>= (type-filter (car args)) 'boolean)) (return-from c1the (c1the (list 'boolean `(unless (eq nil ,(cadr args)) t))))) (cmpwarn "Type mismatch was found in ~s." (cons 'the args))) (setf (info-type info) type) (list* (car form) info (cddr form)) ) (defun c1compiler-let (args &aux (symbols nil) (values nil)) (when (endp args) (too-few-args 'compiler-let 1 0)) (dolist** (spec (car args)) (cond ((consp spec) (cmpck (not (and (symbolp (car spec)) (or (endp (cdr spec)) (endp (cddr spec))))) "The variable binding ~s is illegal." spec) (push (car spec) symbols) (push (if (endp (cdr spec)) nil (eval (cadr spec))) values)) ((symbolp spec) (push spec symbols) (push nil values)) (t (cmperr "The variable binding ~s is illegal." spec)))) (setq symbols (reverse symbols)) (setq values (reverse values)) (setq args (progv symbols values (c1progn (cdr args)))) (list 'compiler-let (cadr args) symbols values args) ) (defun c2compiler-let (symbols values body) (progv symbols values (c2expr body))) (defun c1function (args &aux fd) (when (endp args) (too-few-args 'function 1 0)) (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) (let ((fun (car args))) (cond ((symbolp fun) (cond ((and (setq fd (c1local-closure fun)) (eq (car fd) 'call-local)) (list 'function *info* fd)) (t (let ((info (make-info :sp-change (null (get fun 'no-sp-change))))) (list 'function info (list 'call-global info fun)) )))) ((and (consp fun) (eq (car fun) 'lambda)) (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) (let ((*vars* (cons 'cb *vars*)) (*funs* (cons 'cb *funs*)) (*blocks* (cons 'cb *blocks*)) (*tags* (cons 'cb *tags*))) (setq fun (c1lambda-expr (cdr fun))) (list 'function (cadr fun) fun))) (t (cmperr "The function ~s is illegal." fun)))) ) (defun c2function (funob) (case (car funob) (call-global (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) (call-local (if (cadddr funob) (unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob)))) (unwind-exit (list 'vs* (fun-ref (caddr funob)))))) (t ;;; Lambda closure. (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) *ccb-vs* fun funob) *local-funs*) (push fun *closures*) (cond (*clink* (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink* (fun-name fun)))) (t (unwind-exit (list 'vv (cons 'si::|#,| `(si::mc nil ,(add-address (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))))))))) )) ) (si:putprop 'symbol-function 'wt-symbol-function 'wt-loc) (si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc) (defun wt-symbol-function (vv) (if *safe-compile* (wt "symbol_function(" (vv-str vv) ")") (wt "(" (vv-str vv) "->s.s_gfdef)"))) (defun wt-make-cclosure (cfun clink fname) (wt-nl "make_cclosure_new(" (c-function-name "LC" cfun fname) ",Cnil,") (wt-clink clink) (wt ",Cdata)")) gcl-2.6.14/cmpnew/.gitignore0000644000175000017500000000001014360276512014243 0ustar cammcamm*.c *.h gcl-2.6.14/eval.tcl0000755000175000017500000000363114360276512012434 0ustar cammcamm# A frame, scrollbar, and text frame .eval set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}] scrollbar .eval.s -command {.eval.t yview} pack .eval.s -side left -fill y pack .eval.t -side right -fill both -expand true pack .eval -fill both -expand true # Insert the prompt and initialize the limit mark .eval.t insert insert "Tcl eval log\n" set prompt "tcl> " .eval.t insert insert $prompt .eval.t mark set limit insert .eval.t mark gravity limit left focus .eval.t # Keybindings that limit input and eval things bind .eval.t { _Eval .eval.t ; break } bind .eval.t { if [%W compare insert < limit] { %W mark set insert end } } bind .eval.t { if {[%W tag nextrange sel 1.0 end] != ""} { %W delete sel.first sel.last } elseif [%W compare insert > limit] { %W delete insert-1c %W see insert } break } bindtags .eval.t {.eval.t Text all} proc _Eval { t } { global prompt set command [$t get limit end] if [info complete $command] { $t insert insert \n $t mark set limit insert set err [catch {uplevel #0 $command} result] if {[string length $result] > 0} { $t insert insert $result\n } $t insert insert $prompt $t see insert $t mark set limit insert return } else { $t insert insert \n } } rename puts putsSystem proc puts args { if {[llength $args] > 3} { error "invalid arguments" } set newline "\n" if {[string match "-nonewline" [lindex $args 0]]} { set newline "" set args [lreplace $args 0 0] } if {[llength $args] == 1} { set chan stdout set string [lindex $args 0]$newline } else { set chan [lindex $args 0] set string [lindex $args 1]$newline } if [regexp (stdout|stderr) $chan] { .eval.t mark gravity limit right .eval.t insert limit $string .eval.t see limit .eval.t mark gravity limit left } else { putsSystem -nonewline $chan $string } } gcl-2.6.14/japitest.lsp0000644000175000017500000003025114360276512013337 0ustar cammcamm;;; ;;; Japi is a cross-platform, easy to use (rough and ready) Java based GUI library ;;; Download a library and headers for your platform, and get the C examples ;;; and documentation from: ;;; ;;; http://www.japi.de/ ;;; ;;; This file shows how to use some of the available functions. You may assume ;;; that the only functions tested so far in the binding are those which appear ;;; below, as this file doubles as the test program. The binding is so simple ;;; however that so far no binding (APART FROM J_PRINT) has gone wrong of those ;;; tested so far! ;;; ;;; ;;; HOW TO USE THIS FILE ;;; ;;; (compile-file "c:/cvs/gcl/japitest.lsp") (load "c:/cvs/gcl/japitest.o") ;;; ;;; Requires either "java" or "jre" in the path to work. ;;; (in-package :japi-primitives) ;; Start up the Japi server (needs to find either "java" or "jre" in your path (defmacro with-server ((app-name debug-level) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(if (= 0 (jpr::j_start)) (format t (format nil "~S can't connect to the Japi GUI server." ,app-name)) (progn (j_setdebug ,debug-level) ,@ds (unwind-protect (progn ,@b) (j_quit)))))) ;; Use a frame and clean up afterwards even if trouble ensues (defmacro with-frame ((frame-var-name title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,frame-var-name (j_frame ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,frame-var-name))))) ;; Use a canvas and clean up afterwards even if trouble ensues (defmacro with-canvas ((canvas-var-name frame-obj x-size y-size) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,canvas-var-name (j_canvas ,frame-obj ,x-size ,y-size))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,canvas-var-name))))) ;; Use a text area and clean up afterwards even if trouble ensues (defmacro with-text-area ((text-area-var-name panel-obj x-size y-size) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,text-area-var-name (j_textarea ,panel-obj ,x-size ,y-size))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,text-area-var-name))))) ;; Use a pulldown menu bar and clean up afterwards even if trouble ensues (defmacro with-menu-bar ((bar-var-name frame-obj) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,bar-var-name (j_menubar ,frame-obj))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,bar-var-name))))) ;; Add a pulldown menu and clean up afterwards even if trouble ensues (defmacro with-menu ((menu-var-name bar-obj title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,menu-var-name (j_menu ,bar-obj ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,menu-var-name))))) ;; Add a pulldown menu item and clean up afterwards even if trouble ensues (defmacro with-menu-item ((item-var-name menu-obj title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,item-var-name (j_menuitem ,menu-obj ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,item-var-name))))) ;; Add a mouse listener and clean up afterwards even if trouble ensues (defmacro with-mouse-listener ((var-name obj type) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,var-name (j_mouselistener ,obj ,type))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,var-name))))) ;; Use a panel and clean up afterwards even if trouble ensues (defmacro with-panel ((panel-var-name frame-obj) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,panel-var-name (j_panel ,frame-obj))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,panel-var-name))))) ;; Run a five second frame in a Japi server (with-server ("GCL Japi library test GUI 1" 0) (with-frame (frame "Five Second Blank Test Frame") (j_show frame) (j_sleep 5000))) ;; Get a pointer to an array of ints (defCfun "static void* inta_ptr(object s)" 0 " return(s->fixa.fixa_self);") (defentry inta-ptr (object) (int "inta_ptr")) ;; Draw function (defun drawgraphics (drawable xmin ymin xmax ymax) (let* ((fntsize 10) (tmpstrx (format nil "XMax = ~D" xmax)) (tmpstry (format nil "YMax = ~D" ymax)) (tmpstrwidx (j_getstringwidth drawable tmpstrx))) (j_setfontsize drawable fntsize) (j_setnamedcolor drawable J_RED) (j_drawline drawable xmin ymin (- xmax 1) (- ymax 1)) (j_drawline drawable xmin (- ymax 1) (- xmax 1) ymin) (j_drawrect drawable xmin ymin (- xmax xmin 1) (- ymax xmin 1)) (j_setnamedcolor drawable J_BLACK) (j_drawline drawable xmin (- ymax 30) (- xmax 1) (- ymax 30)) (j_drawstring drawable (- (/ xmax 2) (/ tmpstrwidx 2)) (- ymax 40) tmpstrx) (j_drawline drawable (+ xmin 30) ymin (+ xmin 30) (- ymax 1)) (j_drawstring drawable (+ xmin 50) 40 tmpstry) (j_setnamedcolor drawable J_MAGENTA) (loop for i from 1 to 10 do (j_drawoval drawable (+ xmin (/ (- xmax xmin) 2)) (+ ymin (/ (- ymax ymin) 2)) (* (/ (- xmax xmin) 20) i) (* (/ (- ymax ymin) 20) i))) (j_setnamedcolor drawable J_BLUE) (let ((y ymin) (teststr "JAPI Test Text")) (loop for i from 5 to 21 do (j_setfontsize drawable i) (let ((x (- xmax (j_getstringwidth drawable teststr)))) (setf y (+ y (j_getfontheight drawable))) (j_drawstring drawable x y teststr)))))) ;; Run some more extensive tests (with-server ("GCL Japi library test GUI 2" 0) (with-frame (frame "Draw") (j_show frame) (let ((alert (j_messagebox frame "Two second alert box" "label"))) (j_sleep 2000) (j_dispose alert)) (let ((result1 (j_alertbox frame "label1" "label2" "OK")) (result2 (j_choicebox2 frame "label1" "label2" "Yes" "No")) (result3 (j_choicebox3 frame "label1" "label2" "Yes" "No" "Cancel"))) (format t "Requestor results were: ~D, ~D, ~D~%" result1 result2 result3)) (j_setborderlayout frame) (with-menu-bar (menubar frame) (with-menu (file menubar "File") (with-menu-item (print file "Print") (with-menu-item (save file "Save BMP") (with-menu-item (quit file "Quit") (with-canvas (canvas frame 400 600) (j_pack frame) (drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas)) (j_show frame) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit)) t) (when (= obj canvas) (j_setnamedcolorbg canvas J_WHITE) (drawgraphics canvas 10 10 (- (j_getwidth canvas) 10) (- (j_getheight canvas) 10))) (when (= obj print) (let ((printer (j_printer frame))) (when (> 0 printer) (drawgraphics printer 40 40 (- (j_getwidth printer) 80) (- (j_getheight printer) 80)) (j_print printer)))) (when (= obj save) (let ((image (j_image 600 800))) (drawgraphics image 0 0 600 800) (when (= 0 (j_saveimage image "test.bmp" J_BMP)) (j_alertbox frame "Problems" "Can't save the image" "OK"))))))))))))) ;; Try some mouse handling (with-server ("GCL Japi library test GUI 3" 0) (with-frame (frame "Move and drag the mouse") (j_setsize frame 430 240) (j_setnamedcolorbg frame J_LIGHT_GRAY) (with-canvas (canvas1 frame 200 200) (with-canvas (canvas2 frame 200 200) (j_setpos canvas1 10 30) (j_setpos canvas2 220 30) (with-mouse-listener (pressed canvas1 J_PRESSED) (with-mouse-listener (dragged canvas1 J_DRAGGED) (with-mouse-listener (released canvas1 J_RELEASED) (with-mouse-listener (entered canvas2 J_ENTERERD) (with-mouse-listener (moved canvas2 J_MOVED) (with-mouse-listener (exited canvas2 J_EXITED) (j_show frame) ;; Allocate immovable storage for passing data back from C land. ;; Uses the GCL only make-array keyword :static (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (pxa (inta-ptr xa)) (pya (inta-ptr ya)) (x 0) (y 0) (get-mouse-xy (lambda (obj) (progn (j_getmousepos obj pxa pya) (setf x (aref xa 0)) (setf y (aref ya 0))))) (startx 0) (starty 0)) (do ((obj (j_nextaction) (j_nextaction))) ((= obj frame) t) (when (= obj pressed) (funcall get-mouse-xy pressed) (setf startx x) (setf starty y)) (when (= obj dragged) (funcall get-mouse-xy dragged) (j_drawrect canvas1 startx starty (- x startx) (- y starty))) (when (= obj released) (funcall get-mouse-xy released) (j_drawrect canvas1 startx starty (- x startx) (- y starty))) (when (= obj entered) (funcall get-mouse-xy entered) (setf startx x) (setf starty y)) (when (= obj moved) (funcall get-mouse-xy moved) (j_drawline canvas2 startx starty x y)) (setf startx x) (setf starty y) (when (= obj exited) (funcall get-mouse-xy exited) (j_drawline canvas2 startx starty x y)))))))))))))) ;; Text editor demo (with-server ("GCL Japi library test text editor" 0) (with-frame (frame "A simple editor") (j_setgridlayout frame 1 1) (with-panel (panel frame) (j_setgridlayout panel 1 1) (with-menu-bar (menubar frame) (with-menu (file-mi menubar "File") (with-menu-item (new-mi file-mi "New") (with-menu-item (save-mi file-mi "Save") (j_seperator file-mi) (with-menu-item (quit-mi file-mi "Quit") (with-menu (edit-mi menubar "Edit") (with-menu-item (select-all-mi edit-mi "Select All") (j_seperator edit-mi) (with-menu-item (cut-mi edit-mi "Cut") (with-menu-item (copy-mi edit-mi "Copy") (with-menu-item (paste-mi edit-mi "Paste") (with-text-area (text panel 15 4) (j_setfont text J_DIALOGIN J_BOLD 18) (let ((new-text (format nil "JAPI (Java Application~%Programming Interface)~%a platform and language~%independent API"))) (j_settext text new-text) (j_show frame) (j_pack frame) (j_setrows text 4) (j_setcolumns text 15) (j_pack frame) ;; Allocate immovable storage for passing data back from C land. ;; Uses the GCL only make-array keyword :static (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (pxa (inta-ptr xa)) (pya (inta-ptr ya)) (x 0) (y 0) (get-mouse-xy (lambda (obj) (progn (j_getmousepos obj pxa pya) (setf x (aref xa 0)) (setf y (aref ya 0))))) (startx 0) (starty 0) (selstart 0) (selend 0) (text-buffer (make-array 64000 :initial-element 0 :element-type 'character :static t)) ; (text-buffer (make-string 64000 :initial-element #\0)) (p-text-buffer (inta-ptr text-buffer))) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit-mi))t) (when (= obj panel) (format t "Size changed to ~D rows ~D columns~%" (j_getrows text) (j_getcolumns text)) (format t "Size changed to ~D x ~D pixels~%" (j_getwidth text) (j_getheight text))) (when (= obj text) (format t "Text changed (len=~D)~%" (j_getlength text) )) (when (= obj new-mi) (j_settext new-text)) (when (= obj save-mi) (j_gettext text text-buffer)) (when (= obj select-all-mi) (j_selectall text)) (when (or (= obj cut-mi) (= obj copy-mi) (= obj paste-mi)) (setf selstart (1- (j_getselstart text))) (setf selend (1- (j_getselend text)))) (when (= obj cut-mi) (j_getseltext text p-text-buffer) (j_delete text (1- (j_getselstart text)) (1- (j_getselend text))) (setf selend selstart)) (when (= obj copy-mi) (j_getseltext text p-text-buffer)) (when (= obj paste-mi) (if (= selstart selend) (j_inserttext text p-text-buffer (1- (j_getcurpos text))) (j_replacetext text p-text-buffer (1- (j_getselstart text)) (1- (j_getselend text)))) )))))))))))))))))) gcl-2.6.14/ChangeLog0000755000175000017500000035515214360276512012563 0ustar cammcamm2006-10-26 Gabriel Dos Reis * configure.in: Don't be overly eager about setting INFO_DIR. Fix quotations, as new Autoconf are pickier. * configure: Regenerate. 2002-01-25 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/ChangeLog.orig: *** empty log message *** 2002-01-24 Camm Maguire * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/sfaslelf.c: Get bfd initialization to bypass malloc * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/lsp/defpackage.c, /cvsroot/gcl/gcl/lsp/defpackage.data, /cvsroot/gcl/gcl/lsp/defpackage.h, /cvsroot/gcl/gcl/lsp/defpackage.lsp, /cvsroot/gcl/gcl/lsp/make_defpackage.c, /cvsroot/gcl/gcl/lsp/make_defpackage.data, /cvsroot/gcl/gcl/lsp/make_defpackage.h, /cvsroot/gcl/gcl/lsp/make_defpackage.lsp, /cvsroot/gcl/gcl/lsp/makefile: Defpackage support 2002-01-23 Camm Maguire * /cvsroot/gcl/gcl/o/mingfile.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/minglacks.h, /cvsroot/gcl/gcl/h/mingw.h: Mingw support fixes 2002-01-20 Camm Maguire * /cvsroot/gcl/gcl/gcl.png: gif -> png for logo 2002-01-18 Camm Maguire * /cvsroot/gcl/gcl/lsp/destructuring_bind.c, /cvsroot/gcl/gcl/lsp/destructuring_bind.data, /cvsroot/gcl/gcl/lsp/destructuring_bind.h, /cvsroot/gcl/gcl/lsp/destructuring_bind.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c: Add support for destructuring-bind 2002-01-15 Camm Maguire * /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/o/unexnt.c: Changes to get a preliminary NT build 2002-01-13 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Emacs site list dir fix 2002-01-11 Camm Maguire * /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/new_init.c: Added (quit) and (exit) as synonyms to (bye) * /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/urandom.h: Changes submitted by Robert Byer for VMS (thanks\!) 2002-01-10 Camm Maguire * /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/h/object.h: Fix function definitions to be more portable, enables build on m68k 2002-01-09 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Need 'return 0' at end of tests for DBEGIN and CSTACK_ADDRESS for sparc * /cvsroot/gcl/gcl/info/makefile: Removed info files from tree, created now at build time from texi files 2002-01-08 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Better arm config support * /cvsroot/gcl/gcl/h/arm-linux.defs, /cvsroot/gcl/gcl/h/arm-linux.h, /cvsroot/gcl/gcl/h/m68k-linux.defs, /cvsroot/gcl/gcl/h/m68k-linux.h: New arm and m68k machine files * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Added configuration support for linux architectures 2002-01-07 Camm Maguire * /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/acconfig.h: BFD library support for relocations * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Changes to better detect tcl/tk locations * /cvsroot/gcl/gcl/h/386-linux.defs: Optimization flags by default in 386-linux.defs * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/makefile: Removed some build-generated files 2002-01-06 Camm Maguire * /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c: Refinement to max stack size handling, better fix to unexelf section numbering bug, revert sigsetjmp change in rsym_elf.c * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: configure changes to detect newer as well as older tcl/tk libraries * /cvsroot/gcl/gcl/o/unexelf.c: Protect against sh_info=0, causing occasional segfaults, in unexelf.c 2002-01-04 Camm Maguire * /cvsroot/gcl/gcl/unixport/rsym_elf.c: _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c * /cvsroot/gcl/gcl/o/main.c: Protect against unlimited stack resource environments * /cvsroot/gcl/gcl/unixport/rsym_elf.c: _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c 2001-12-29 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** * /cvsroot/gcl/gcl/unixport/makefile: Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absence of tcl/tk * /cvsroot/gcl/gcl/gcl-tk/makefile: Add gcl-tk/demos/index.lsp to clean target * /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absence of tcl/tk * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/makefile: changes to configure.in and elisp/makefile to handle emacs not being present * /cvsroot/gcl/gcl/gmp/ltconfig: fix to gmp/ltconfig to avoid exec'ing empty string * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: gmp/configure.in update for darwin * /cvsroot/gcl/gcl/gmp/ltconfig: fix to gmp/ltconfig to avoid exec'ing empty string * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: gmp/configure.in update for darwin 2001-12-21 Camm Maguire * /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/emacsen-startup, /cvsroot/gcl/gcl/debian/gcl-doc.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.si, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.tk, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/emacsen-install, /cvsroot/gcl/gcl/debian/emacsen-remove, /cvsroot/gcl/gcl/debian/gcl.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base, /cvsroot/gcl/gcl/debian/gcl-doc.docs, /cvsroot/gcl/gcl/debian/gcl-doc.files, /cvsroot/gcl/gcl/debian/gcl.files, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/makefile: Many changes to get Debian package to build cleanly 2001-12-20 Camm Maguire * /cvsroot/gcl/gcl/ChangeLog: remove more build-generated files * /cvsroot/gcl/gcl/h/gnuwin95.h: Apply fopen patch * /cvsroot/gcl/gcl/debian/all-files, /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/clean, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/control.withtk, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/dirs, /cvsroot/gcl/gcl/debian/docs, /cvsroot/gcl/gcl/debian/gcl-doc.info, /cvsroot/gcl/gcl/debian/gcl.substvars, /cvsroot/gcl/gcl/debian/manpages, /cvsroot/gcl/gcl/debian/postinst, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/debian/texi.awk: Initial upload of debian package building subdir * /cvsroot/gcl/gcl/tests/alltest.tst, /cvsroot/gcl/gcl/tests/array.tst, /cvsroot/gcl/gcl/tests/backquot.tst, /cvsroot/gcl/gcl/tests/characters.tst, /cvsroot/gcl/gcl/tests/eval20.tst, /cvsroot/gcl/gcl/tests/format.tst, /cvsroot/gcl/gcl/tests/GNU-GPL, /cvsroot/gcl/gcl/tests/hashlong.tst, /cvsroot/gcl/gcl/tests/hash.tst, /cvsroot/gcl/gcl/tests/iofkts.tst, /cvsroot/gcl/gcl/tests/lambda.tst, /cvsroot/gcl/gcl/tests/lists151.tst, /cvsroot/gcl/gcl/tests/lists152.tst, /cvsroot/gcl/gcl/tests/lists153.tst, /cvsroot/gcl/gcl/tests/lists154.tst, /cvsroot/gcl/gcl/tests/lists155.tst, /cvsroot/gcl/gcl/tests/lists156.tst, /cvsroot/gcl/gcl/tests/macro8.tst, /cvsroot/gcl/gcl/tests/Makefile, /cvsroot/gcl/gcl/tests/map.tst, /cvsroot/gcl/gcl/tests/number.tst, /cvsroot/gcl/gcl/tests/pack11.tst, /cvsroot/gcl/gcl/tests/path.tst, /cvsroot/gcl/gcl/tests/README, /cvsroot/gcl/gcl/tests/readtable.tst, /cvsroot/gcl/gcl/tests/setf.tst, /cvsroot/gcl/gcl/tests/steele7.tst, /cvsroot/gcl/gcl/tests/streamslong.tst, /cvsroot/gcl/gcl/tests/streams.tst, /cvsroot/gcl/gcl/tests/strings.tst, /cvsroot/gcl/gcl/tests/symbol10.tst, /cvsroot/gcl/gcl/tests/symbols.tst, /cvsroot/gcl/gcl/tests/tests.lsp, /cvsroot/gcl/gcl/tests/tprint.tst, /cvsroot/gcl/gcl/tests/tread.tst, /cvsroot/gcl/gcl/tests/type.tst: Initial upload of cltl1 tests used by clisp -- needs #+ and #- for gcl * /cvsroot/gcl/gcl/makefile: Make distclean on gmp non-fatal * /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/number.texi, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi: Clean target for docs, build all docs, fix texinfo errors * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/makefile: Got clean targets working so as not to leave any non-CVS files in tree after build (and clean) * /cvsroot/gcl/gcl/makefile: Fixed makefile to build without tcl/tk if not found in configure * /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/readline.c, /cvsroot/gcl/gcl/lsp/readline.data, /cvsroot/gcl/gcl/lsp/readline.h, /cvsroot/gcl/gcl/lsp/readline.lsp, /cvsroot/gcl/gcl/lsp/serror.c, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/readline.d, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/acconfig.h, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers: Integrated dynamic readline support, activated at runtime with (si::init-readline) 2001-12-19 Camm Maguire * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: Merge bugfixes from current 2001-12-18 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: FCNTL check opens bad file 'jim', now opens configure.in read-only * /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: Merge current bugfixes into 2.5.0 * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: s/cygwin32/ cygwin\*/ in configure * /cvsroot/gcl/gcl/h/gnuwin95.defs: Tidy up h/gnuwin95.defs * /cvsroot/gcl/gcl/h/cyglacks.h: Remove cruft from h/cyglacks.h * /cvsroot/gcl/gcl/h/gnuwin95.h: Tidy up h/gnuwin95.defs * /cvsroot/gcl/gcl/h/coff/i386.h: Remove cruft from h/coff/i386.h * /cvsroot/gcl/gcl/o/print.d: Prototype definition for coerce_stream * /cvsroot/gcl/gcl/o/fat_string.c: Compiler warning cleanup, strings end with char 0, not NULL * /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi: Minor changes to .texi files to compile cleanly on standard texinfo installations * /cvsroot/gcl/gcl/h/num_include.h: Clear up a compiler warning with MOST_NEGATIVE_FIX * /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv: Remove version dependence on wish in shell scripts -- if need a dependency, will put in configure later * /cvsroot/gcl/gcl/elisp/smart-complete.el: Rename split-string to split-string-gcl to avoid name conflicts with other elisp packages * /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/unixfsys.c: Added missing headers for str... and exit standard functions * /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: Removed CR from all compilable files; removed one useless file 2001-12-17 Camm Maguire * /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub: New versions of config.sub and config.guess 2001-12-16 Camm Maguire * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Allow setting compiler in CC env variable * /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/file.d: Commented labels at end of #endifs * /cvsroot/gcl/gcl/h/ptable.h: removed carriage returns 2001-12-15 Camm Maguire * /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/supersparc/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/com_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/logops_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/p3mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpbsd/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/umul.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/udiv.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/umul.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/cross.pl, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/README, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpq/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tests/rand/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/trace.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.h, /cvsroot/gcl/gcl/gmp/mpn/tests/tst-addsub.c, /cvsroot/gcl/gcl/gmp/mpn/tests/x86call.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/x86check.c, /cvsroot/gcl/gcl/gmp/mpn/thumb/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/thumb/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/x86/addsub_n.S, /cvsroot/gcl/gcl/gmp/mpn/x86/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/README, /cvsroot/gcl/gcl/gmp/mpn/x86/README.family, /cvsroot/gcl/gcl/gmp/mpn/x86/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/x86-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/z8000/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/z8000/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/sub_n.s, /cvsroot/gcl/gcl/gmp/mpq/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tune/Makefile.in, /cvsroot/gcl/gcl/gmp/demos/Makefile.in, /cvsroot/gcl/gcl/gmp/macos/Makefile.in, /cvsroot/gcl/gcl/gmp/mpbsd/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/a29k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/udiv.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/umul.s, /cvsroot/gcl/gcl/gmp/mpn/alpha/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/cntlz.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/default.m4, /cvsroot/gcl/gcl/gmp/mpn/alpha/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/alpha/invert_limb.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/README, /cvsroot/gcl/gcl/gmp/mpn/alpha/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/alpha/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/unicos.m4, /cvsroot/gcl/gcl/gmp/mpn/arm/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/arm/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/arm/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/clipper/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/cray/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/cray/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/cray/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.f, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.s, /cvsroot/gcl/gcl/gmp/mpn/cray/README, /cvsroot/gcl/gcl/gmp/mpn/cray/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/hppa/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/README, /cvsroot/gcl/gcl/gmp/mpn/hppa/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/udiv_qrnnd.s, /cvsroot/gcl/gcl/gmp/mpn/i960/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/i960/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/README, /cvsroot/gcl/gcl/gmp/mpn/i960/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/lisp/gmpasm-mode.el, /cvsroot/gcl/gcl/gmp/mpn/m68k/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/lshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/rshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/syntax.h, /cvsroot/gcl/gcl/gmp/mpn/m88k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/umul.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/mips3/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/README, /cvsroot/gcl/gcl/gmp/mpn/mips3/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/README, /cvsroot/gcl/gcl/gmp/mpn/pa64/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64w/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/README, /cvsroot/gcl/gcl/gmp/mpn/pa64w/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64w/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/power/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/regmap.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addsub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/README, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/power/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/sdiv.s, /cvsroot/gcl/gcl/gmp/mpn/power/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/umul.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_fp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_nfp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/README, /cvsroot/gcl/gcl/gmp/mpn/sparc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/README, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.c, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.h, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/spinner.c, /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/mpn/asm-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/generic/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/addsub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bdivmod.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bz_divrem_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/cmp.c, /cvsroot/gcl/gcl/gmp/mpn/generic/diveby3.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/dump.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/get_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/generic/hamdist.c, /cvsroot/gcl/gcl/gmp/mpn/generic/inlines.c, /cvsroot/gcl/gcl/gmp/mpn/generic/jacbase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1_rs.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_fft.c, /cvsroot/gcl/gcl/gmp/mpn/generic/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/popcount.c, /cvsroot/gcl/gcl/gmp/mpn/generic/pre_mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random.c, /cvsroot/gcl/gcl/gmp/mpn/generic/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sb_divrem_mn.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan0.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/set_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqr_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/udiv_w_sdiv.c, /cvsroot/gcl/gcl/gmp/mpn/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/mp_bases.c, /cvsroot/gcl/gcl/gmp/mpn/README, /cvsroot/gcl/gcl/gmp/mpz/abs.c, /cvsroot/gcl/gcl/gmp/mpz/add.c, /cvsroot/gcl/gcl/gmp/mpz/addmul_ui.c, /cvsroot/gcl/gcl/gmp/mpz/add_ui.c, /cvsroot/gcl/gcl/gmp/mpz/and.c, /cvsroot/gcl/gcl/gmp/mpz/array_init.c, /cvsroot/gcl/gcl/gmp/mpz/bin_ui.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/clear.c, /cvsroot/gcl/gcl/gmp/mpz/clrbit.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cmp.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_si.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_ui.c, /cvsroot/gcl/gcl/gmp/mpz/com.c, /cvsroot/gcl/gcl/gmp/mpz/divexact.c, /cvsroot/gcl/gcl/gmp/mpz/dump.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fib_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_slong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sshort_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_uint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ulong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ushort_p.c, /cvsroot/gcl/gcl/gmp/mpz/gcdext.c, /cvsroot/gcl/gcl/gmp/mpz/gcd_ui.c, /cvsroot/gcl/gcl/gmp/mpz/get_d.c, /cvsroot/gcl/gcl/gmp/mpz/getlimbn.c, /cvsroot/gcl/gcl/gmp/mpz/get_si.c, /cvsroot/gcl/gcl/gmp/mpz/get_str.c, /cvsroot/gcl/gcl/gmp/mpz/get_ui.c, /cvsroot/gcl/gcl/gmp/mpz/hamdist.c, /cvsroot/gcl/gcl/gmp/mpz/init.c, /cvsroot/gcl/gcl/gmp/mpz/inp_raw.c, /cvsroot/gcl/gcl/gmp/mpz/inp_str.c, /cvsroot/gcl/gcl/gmp/mpz/invert.c, /cvsroot/gcl/gcl/gmp/mpz/ior.c, /cvsroot/gcl/gcl/gmp/mpz/iset.c, /cvsroot/gcl/gcl/gmp/mpz/iset_d.c, /cvsroot/gcl/gcl/gmp/mpz/iset_si.c, /cvsroot/gcl/gcl/gmp/mpz/iset_str.c, /cvsroot/gcl/gcl/gmp/mpz/iset_ui.c, /cvsroot/gcl/gcl/gmp/mpz/jacobi.c, /cvsroot/gcl/gcl/gmp/mpz/kronsz.c, /cvsroot/gcl/gcl/gmp/mpz/kronuz.c, /cvsroot/gcl/gcl/gmp/mpz/kronzs.c, /cvsroot/gcl/gcl/gmp/mpz/kronzu.c, /cvsroot/gcl/gcl/gmp/mpz/lcm.c, /cvsroot/gcl/gcl/gmp/mpz/legendre.c, /cvsroot/gcl/gcl/gmp/mpz/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/mod.c, /cvsroot/gcl/gcl/gmp/mpz/mul_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/mul_siui.c, /cvsroot/gcl/gcl/gmp/mpz/neg.c, /cvsroot/gcl/gcl/gmp/mpz/nextprime.c, /cvsroot/gcl/gcl/gmp/mpz/out_raw.c, /cvsroot/gcl/gcl/gmp/mpz/out_str.c, /cvsroot/gcl/gcl/gmp/mpz/perfpow.c, /cvsroot/gcl/gcl/gmp/mpz/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpz/popcount.c, /cvsroot/gcl/gcl/gmp/mpz/powm.c, /cvsroot/gcl/gcl/gmp/mpz/powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/random2.c, /cvsroot/gcl/gcl/gmp/mpz/random.c, /cvsroot/gcl/gcl/gmp/mpz/README, /cvsroot/gcl/gcl/gmp/mpz/realloc.c, /cvsroot/gcl/gcl/gmp/mpz/remove.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/rrandomb.c, /cvsroot/gcl/gcl/gmp/mpz/scan0.c, /cvsroot/gcl/gcl/gmp/mpz/scan1.c, /cvsroot/gcl/gcl/gmp/mpz/setbit.c, /cvsroot/gcl/gcl/gmp/mpz/set.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/set_f.c, /cvsroot/gcl/gcl/gmp/mpz/set_q.c, /cvsroot/gcl/gcl/gmp/mpz/set_si.c, /cvsroot/gcl/gcl/gmp/mpz/set_str.c, /cvsroot/gcl/gcl/gmp/mpz/set_ui.c, /cvsroot/gcl/gcl/gmp/mpz/size.c, /cvsroot/gcl/gcl/gmp/mpz/sizeinbase.c, /cvsroot/gcl/gcl/gmp/mpz/sqrt.c, /cvsroot/gcl/gcl/gmp/mpz/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/sub.c, /cvsroot/gcl/gcl/gmp/mpz/sub_ui.c, /cvsroot/gcl/gcl/gmp/mpz/swap.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tstbit.c, /cvsroot/gcl/gcl/gmp/mpz/ui_pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/urandomb.c, /cvsroot/gcl/gcl/gmp/mpz/urandomm.c, /cvsroot/gcl/gcl/gmp/mpz/xor.c: Complete file additions for gmp configure and build * /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/compat.c, /cvsroot/gcl/gcl/gmp/config.guess, /cvsroot/gcl/gcl/gmp/config.in, /cvsroot/gcl/gcl/gmp/config.sub, /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/COPYING, /cvsroot/gcl/gcl/gmp/errno.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp.h, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/insert-dbl.c, /cvsroot/gcl/gcl/gmp/install-sh, /cvsroot/gcl/gcl/gmp/longlong.h, /cvsroot/gcl/gcl/gmp/ltconfig, /cvsroot/gcl/gcl/gmp/ltmain.sh, /cvsroot/gcl/gcl/gmp/Makefile.in, /cvsroot/gcl/gcl/gmp/memory.c, /cvsroot/gcl/gcl/gmp/missing, /cvsroot/gcl/gcl/gmp/mp_bpl.c, /cvsroot/gcl/gcl/gmp/mp_clz_tab.c, /cvsroot/gcl/gcl/gmp/mp.h, /cvsroot/gcl/gcl/gmp/mp_minv_tab.c, /cvsroot/gcl/gcl/gmp/mp_set_fns.c, /cvsroot/gcl/gcl/gmp/rand.c, /cvsroot/gcl/gcl/gmp/randclr.c, /cvsroot/gcl/gcl/gmp/randlc2x.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/randsd.c, /cvsroot/gcl/gcl/gmp/randsdui.c, /cvsroot/gcl/gcl/gmp/README, /cvsroot/gcl/gcl/gmp/stack-alloc.c, /cvsroot/gcl/gcl/gmp/stack-alloc.h, /cvsroot/gcl/gcl/gmp/urandom.h, /cvsroot/gcl/gcl/gmp/version.c: gmp configure and build restoration * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: Run emacs with --no-site-file to avoid errors; default ix86 gmp target is i486 * /cvsroot/gcl/gcl/h/gmp.h: Link needed to get gmp bignums working with new gmp_big.c file * /cvsroot/gcl/gcl/h/386-linux.h: Patch submitted via email months ago by Dr. Schelter to enable reliable dynamic linking on i386 Linux 2001-07-03 wfs * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/gclincl.h: fix to configure 2001-06-06 wfs * /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.lsp: fix info to handle defunx 2001-05-18 wfs * /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/o/gmp_big.c, /cvsroot/gcl/gcl/o/gmp.c, /cvsroot/gcl/gcl/o/gmp_num_log.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/pari_big.c, /cvsroot/gcl/gcl/o/pari_num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/h/mp.h: changes for bignum code, now relocatable bignums ok, worked around bug in gmp code which does not detect 0 as fitting in an int 2001-05-16 wfs * /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/makefile: changes for gmp 2001-05-15 wfs * /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makefile: fix to ash, and for buggy redhat/cygnus compiler 2001-05-11 wfs * /cvsroot/gcl/gcl/readme.gmp, /cvsroot/gcl/gcl/readme.mingw, /cvsroot/gcl/gcl/unixport/init_gcl.lsp: fix the error code on compile from command line 2001-05-06 wfs * /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c: changes to gmp from 3.1.1 for gcl * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/xbin/new-files: many changes adding gmp bignums 2001-04-17 wfs * /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data, /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/new_init.c: minor change to break-call * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/debug.lsp: removed the o/*.ini files since these are generated automatically. fixed things in h/mingw.{h,defs}, made o/sfaslelf.c so it can load things compiled under -O4 (since init_ is searched for), repaired rsym_nt.c for mingw port 2001-04-13 wfs * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/notcomp.h: changes for clisp, and to sysdef 2001-03-22 wfs * /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/unexelf.c: Fix the unexelf to make the data section executable 2001-02-24 wfs * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/OpenBSD.defs, /cvsroot/gcl/gcl/h/OpenBSD.h, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/xbin/new-files: fix for debian, for stdout corruption after save 2000-12-09 wfs * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/winkill.c, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/mingwin.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/tclwinkill.c, /cvsroot/gcl/gcl/o/unexnt.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/xbin/386-linux-fix: many changes for xmaxima and for windows 2000-10-28 wfs * /cvsroot/gcl/gcl/xbin/386-linux-fix: changes for redhat 7.0 2000-10-27 wfs * /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/configure.in: changes for close_stream, and to configure for redhat 7.0 * /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/makefile: abort() is void so fixed BV_OFFSET macro 2000-06-27 wfs * /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/o/file.d: allow open of a file '| command' to open a pipe 2000-06-26 wfs * /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/read.d: change parse_number to do bignums much faster 2000-06-15 wfs * /cvsroot/gcl/gcl/configure.in: fixes to configure 2000-06-13 wfs * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/unixport/init_maxima.lsp: fix info compilation in makefile 2000-06-04 wfs * /cvsroot/gcl/gcl/o/pathname.d: fix so make-pathname when given an :type nil makes the type nil independent of the default * /cvsroot/gcl/gcl/lsp/sloop.c, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini, /cvsroot/gcl/gcl/o/typespec.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/usig.ini, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmplam.c, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile: change the # syntax for pathnames to be #p 2000-05-25 wfs * /cvsroot/gcl/gcl/minvers: fix version to 3.6 * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/configure: update configure from configure.in 2000-05-16 wfs * /cvsroot/gcl/gcl/h/386-linux.defs: remove the -static declaration for the link 2000-05-15 wfs * /cvsroot/gcl/gcl/readme, /cvsroot/gcl/gcl/makefile: fix some cosmetic and documentation items 2000-05-15 mzou * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** 2000-05-13 wfs * /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/new-files: fix xbin/distribute * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: bring cvs tree up to date with my development tree * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: some cosmetic and readme changes 1999-12-06 wfs * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: initial checkin * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: New file. * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: initial checkin * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: New file. * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: initial checkin * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: New file. * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: initial checkin * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: New file. * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: initial checkin * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: New file. * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: initial checkin * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: New file. * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: initial checkin * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: New file. * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: initial checkin * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: New file. * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: initial checkin * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: New file. * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: initial checkin * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: New file. * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: initial checkin * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: New file. * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: initial checkin * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: New file. * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: initial checkin * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: New file. * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: initial checkin * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: New file. * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: initial checkin * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: New file. * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: initial checkin * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: New file. * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: initial checkin * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: New file. * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: initial checkin * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: New file. * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: New file. * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: New file. * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: initial checkin * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: New file. * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: initial checkin * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: New file. * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: initial checkin * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: New file. gcl-2.6.14/AC_FD_MSG0000644000175000017500000000000614360276512012254 0ustar cammcammgot 0 gcl-2.6.14/go/0000755000175000017500000000000014360276512011400 5ustar cammcammgcl-2.6.14/go/makefile0000644000175000017500000001056614360276512013110 0ustar cammcamm# make .d more important by clearing suffixes. .SUFFIXES: .SUFFIXES: .d .o .c .ini HDIR = ../h/ CDIR = ./ MPDIR = ../mp OFLAG = -O ODIR = . GCLIB = gcllib.a RANLIB=ranlib AR = ar qc LIBFILES= bcmp.o bcopy.o bzero.o # compile main.c with -g, since signalling may not be ok on -O MAIN_DEBUG= DPP = ../bin/dpp AUX_INFO=-aux-info $*.X .c.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c $(AUX_INFO) .d.o: $(DPP) $* $(CC) -c $(OFLAG) $(CFLAGS) $*.c $(AUX_INFO) rm $*.c .c.ini: $(CC) -DNO_DEFUN $(CFLAGS) -E $*.c | grab_defs > $*.ini .d.ini: $(DPP) $* grab_defs < $*.c > $*.ini rm $*.c -include ../makedefs CFLAGS = -I../gcl-tk -I$(HDIR) $(ODIR_DEBUG) MP = $(HDIR)/mp.h CMPINCLUDE_FILES=${HDIR}compbas.h ${HDIR}enum.h ${HDIR}object.h ${HDIR}vs.h \ ${HDIR}bds.h ${HDIR}frame.h \ ${HDIR}lex.h ${HDIR}eval.h ${HDIR}funlink.h \ ${HDIR}att_ext.h ${HDIR}compbas2.h ${HDIR}/compat.h ${HDIR}/cmponly.h OTHERS=${HDIR}notcomp.h ${HDIR}rgbc.h ${HDIR}stacks.h HFILES = $(HDIR)include.h $(CMPINCLUDE_FILES) $(OTHERS) # these are made elsewhere... MPFILES= OBJS = $(OD)main.o $(OD)alloc.o $(OD)gbc.o \ $(OD)bitop.o $(OD)typespec.o $(OD)eval.o \ $(OD)macros.o $(OD)lex.o $(OD)bds.o \ $(OD)frame.o $(OD)predicate.o $(OD)reference.o \ $(OD)assignment.o $(OD)bind.o $(OD)let.o \ $(OD)conditional.o $(OD)block.o $(OD)iteration.o \ $(OD)mapfun.o $(OD)prog.o $(OD)multival.o \ $(OD)catch.o $(OD)symbol.o $(OD)cfun.o \ $(OD)cmpaux.o $(OD)package.o $(OD)big.o \ $(OD)number.o $(OD)num_pred.o $(OD)num_comp.o \ $(OD)num_arith.o $(OD)num_sfun.o $(OD)num_co.o \ $(OD)num_log.o $(OD)num_rand.o $(OD)earith.o \ $(OD)character.o $(OD)sequence.o \ $(OD)list.o $(OD)hash.o $(OD)array.o \ $(OD)string.o $(OD)structure.o $(OD)toplevel.o \ $(OD)file.o $(OD)read.o $(OD)backq.o \ $(OD)print.o $(OD)format.o $(OD)pathname.o \ $(OD)unixfsys.o $(OD)unixfasl.o $(OD)error.o \ $(OD)unixtime.o $(OD)unixsys.o $(OD)unixsave.o \ $(OD)funlink.o \ $(OD)fat_string.o ${ODIR}/run_process.o \ $(OD)nfunlink.o $(OD)usig.o $(OD)usig2.o $(OD)utils.o \ $(OD)makefun.o $(OD)sockets.o \ $(OD)init_pari.o $(NEW_INIT) $(MPFILES) $(SFASL) $(EXTRAS) \ $(addprefix $(OD),$(RL_OBJS)) all: $(OBJS) new-init $(LIBFILES) new_init.o $(GCLIB) go: $(MAKE) "CFLAGS=${CFLAGS} -pg" new-init: grab_defs $(MAKE) new_init.c "INI_FILES=`echo ${OBJS} | sed -e 's:\.o:.ini:g' -e 's:new_init.o::g' `" new_init.c: ${INI_FILES} echo '#include "make-init.h"' > new_init.c echo 'NewInit(){' >> new_init.c cat ${INI_FILES} >> new_init.c echo '}' >> new_init.c grab_defs: grab_defs.c ${CC} $(OFLAGS) -o grab_defs grab_defs.c ALIB=${LIBFILES} user_init.o $(GCLIB): ${ALIB} rm -f gcllib.a $(AR) gcllib.a ${ALIB} ${RANLIB} gcllib.a clean: rm -f $(OBJS) *.a IBMAIX3_NEAR_LIB = fsavres.o $(ODIR)/ibmaix3.a: /lib/libc.a mkdir tmpx (cd tmpx ; ar xv /lib/libc.a ${IBMAIX3_NEAR_LIB} ; ar qc ../ibmaix3.a ${IBMAIX3_NEAR_LIB}) rm -rf tmpx character.o: $(HFILES) file.o: $(HFILES) hash.o: $(HFILES) ${MP} list.o: $(HFILES) package.o: $(HFILES) pathname.o: $(HFILES) print.o: $(HFILES) ${MP} read.o: $(HFILES) ${MP} sequence.o: $(HFILES) string.o: $(HFILES) symbol.o: $(HFILES) alloc.o: $(HFILES) array.o: $(HFILES) assignment.o: $(HFILES) backq.o: $(HFILES) bds.o: $(HFILES) big.o: $(HFILES) ${MP} bind.o: $(HFILES) bitop.o: $(HFILES) block.o: $(HFILES) catch.o: $(HFILES) cfun.o: $(HFILES) cmpaux.o: $(HFILES) ${MP} conditional.o: $(HFILES) earith.o: $(HFILES) error.o: $(HFILES) eval.o: $(HFILES) format.o: $(HFILES) frame.o: $(HFILES) gbc.o: $(HFILES) ${MP} interrupt.o: $(HFILES) iteration.o: $(HFILES) let.o: $(HFILES) lex.o: $(HFILES) macros.o: $(HFILES) main.o: $(HFILES) mapfun.o: $(HFILES) multival.o: $(HFILES) mpi.o: $(MP) num_arith.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_co.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_comp.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_log.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_pred.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_rand.o: $(HFILES) $(HDIR)/num_include.h ${MP} num_sfun.o: $(HFILES) $(HDIR)/num_include.h ${MP} number.o: $(HFILES) $(HDIR)/num_include.h ${MP} predicate.o: $(HFILES) prog.o: $(HFILES) reference.o: $(HFILES) structure.o: $(HFILES) toplevel.o: $(HFILES) typespec.o: $(HFILES) ${MP} unixfasl.o: $(HFILES) unixfsys.o: $(HFILES) unixint.o: $(HFILES) unixsave.o: $(HFILES) unixsys.o: $(HFILES) unixtime.o: $(HFILES) funlink.o: $(HFILES) fat_string.o: $(HFILES) fasdump.o: $(HFILES) bitblit2.o: $(HFILES) gcl-2.6.14/release0000644000175000017500000000004014360276512012330 0ustar cammcammFri Jan 13 10:47:56 AM EST 2023 gcl-2.6.14/gcl.jpg0000755000175000017500000006010014360276512012242 0ustar cammcammJFIFHH Photoshop 3.08BIMHH8BIM8BIM 8BIM' 8BIMH/fflff/ff2Z5-8BIMp8BIM@@8BIM 4N cJFIFHH'File written by Adobe Photoshop 4.0Adobed            4"?   3!1AQa"q2B#$Rb34rC%Scs5&DTdE£t6UeuF'Vfv7GWgw5!1AQaq"2B#R3$brCScs4%&5DTdEU6teuFVfv'7GWgw ?T^덬XYvC 8'Y"SNg(9HJ@ .]:Eƨ?1X:ݻ1D|qigaaB{.{hqpsugml` op{ܹor`G72~)K=-t4>/x ^[l8}44>c>n/;=K(-n ϵk۵KF~>Gjl$Lj{Z]K>\9q"\&n_DS,kĂ~.8)kV\TYϬl-6Ooqui񕑅r0[ >sKvZzë6YklseL sPo:q%:w=r辫Wc{t7k?oW9KBF0rqw?TJ7qle#-}fh97rW?]Tt~csM:cx/q/KKq?zoӱi!fVk.n/1<.xyyd,:V/Svw:=י'#FY]3gbSc}x-{ǩ}'>W]7kGsV}NSs}4}*wNvcvbGWuWN-Ɲ^ߠ. N亯T[[cpmW~)-)CcDBH߹Ե#}Mo2_QZX4 `xocɵNsĽ@ v[~ݣws(<1ޟy?ƟzRzPߤc~;k޸\R+E8pa\ƽݶ;};{ss\GF0)i/܏e!'-q k*aGDzm?WEWVWY1\-ck{wTƿYp\z?44OivKrRC1kXzo_:uq\ߤ߉.ƴ{XGh;-{[X. {EwMrkS|o$ Ry?a[P͕S:e6rcwv{Z 1#pG+>t?۝&[n3;E՛,RxYͩ 0~-?F~!fu>Fk6Ƽvkpy˕ac'POU>-NNF;ﲇMOs'L[v̫qu;{פ[3:YEcr%_UWb0#R8*B|b~ǵyn؈򅯉r. c@ {/2AEFaQ)s';ko72ѫk{먺?!SE5A5y XZ{\w+^^1$Z 1q8-8/9 lxѥ/pn+]"{Mu~wg5Iѱ@Gu\%c㓔Lpڽ8u''J,j]sP8LI/yW4+`Mh CQc0q+2?pv|tܢ[A0@^4_M>?g[xWG?=nXk4}=٧^^/}9aXmo4V;,{v?Gg3EdZ>sGjE؇1Zѽ#*duї#6ʹ?楻 |R%#nvV7-~IfD=>.Uʟ9@^?8GSÿזRnP?F?68=-Dݸ{Wi3//#ɿM5_(y^"z,7#ogPs}So]Ip0!4=>%z;}oRx]$K7>sKM<62ۿofOD/}?䗾gR6"5 9g9?hQL:?- }cQuN5QyWOl}Վd7$=?< O!4!giQ_x>$}h?SPy sWrc}/SK}m(Λٍ|_/>o۟&͉ 3un_J$]9%eC6 4 IQ :>,,i3ZjH|U\⯍?:3|3竟!_QaimqO I +$=I>GY=&_ Ē,vk#8)$Nұyz~[m3cad':( &+[)XH<Z' &+[)Xɯ(_o1D~ak+Y>wɱyB6r$2[0)$5W _Wn^뎎YcB @[֨^YIW!z`kv*Uv*UثWb^Zykzљ;R!ui$rG90R4Rߦe,13Ir:k\蟓ZbkhLryTOsmmT_f,3{Ip =>sf7jÏ3:[>8淟?40?3ywa9x-瓍h_QWPo$\yog?z<1:=G7)|I`9]v*UثWb~q/}ʚƍ['+Sj2'njuNtc$C'njЋ^Zo4鑓g'r:J;_iY ?H~D،ꀉ3&yU P=9y$g:Ņ2X' =Z~*y֖ԵBflڍ*?sn4v*Xf_K}é~{9h^ &;ދ?_uM/חOnmVT{) 4!Pӛg!6]#|>o~w;< lc<j^OjsF?9,ܜFFɲ@CDb9rwe.s{M(]ϣ}*a[sCF߼z :Hy~2a9흊V [h2,PDY܅U2p&D̵Pj1n?.$G<IЬ!a$rJŒo=CI`c?h;R]r)2GcYJygv$,n`{BhSv*Uثv*UثWv}7A^/]v`PvSZ8\Cwg~kB?^C˺#s7~"~s@~a~w4+iKSfKQV*Mey+,\?֞/_1۾v*UثWb]v*U[ȾpuyZ8#AI-e Jw:lNGyǰ#}JEθ;WĞ&4 =,FyJkUS%' 0E=3MC[vYlt*ȫu Or<9xS~> r/ay`{T*O/0^f{W5E̗,{Lvl 8eFS6O{ދCE8tQ?O3&ܧb]v*UثWb?2n{'ą΋iǗ?L{o|g ^GY~2~Q2~y{Bs~^!`C,/DbsK'+^<4~_<+vh7ОŇ4ݻtr{w.}?(=~v*Uث*Κ] 6=/HT=?<˗c;&tCyri{ &ִ~' 6Bʧ IlPv*Uv*UثH#G 򿗋?nV'عWu}qCg'{a=.xyF?O3`QgiwT~WWh*" TA}b2z_|yLoS?$Cg䫾ˉ,ULw~mjOْףA~U+l'?~ 1njwXǯv~Ug UثWb]v*UثTU}p'6 ?bqHsN.G f& $LOBod*f0D"YbAE|? !Fzp@=ǩe;վ[a$DW#jx cGe?QO-ٙ5Lvf 39v*%M> ]PJssO<~m ݳǣDG^j;zDt=dORN ٻv* $@Rp{JBFYvgؠ;1X g̀}z{φ]`69Nc# H ΣPoi5Ye_;p 6F.u$O[I|gd*ТN4]P7}W^j;3UIdG'`bzFq>33CWbWRio!PO1O$z cR{'V(v#|N̈́d(ku9pN `$_IXOl%'^PbTdƿ,#%ޗ|nMMvU2fiXxWA۝xxp>} =?1.Q_$MIܓ+kWbW:$sEE''HF"qz:LR͚BI*H3@?nGߝV=Y~o{MIȜ] =8 Kx8ŠsG@|==|j2NED|i2r"2 D><.( 56kxŽ*Oi݉qB`J'㢎V;v*Ui Ƅ].-63?{gad@Lג5f>$Sh]j,ty.'n(])D |Ō\D@$7ᯝyo7Ϙ獍}5B>Q3ul"Kcvl;7EKXn~'sbKv*U@F&D̵ 0IA$gePEg鰌8SmvK[U>y&e>UEc R}sKR*$^ͧGW @lPv*Uv*;[KH{X$q,hP $H&x$ 4Iúm<ɖ UCԺe4C*yjfh{;R|C 3r5otUثVgfw:cS;27̿KG$9V&!VC0tqqL%yu9о:˴+ָXO'ޕy_~%/> 4'7yѮOt$? Y7/?M4f0Ǘ$EcuW*rD=-iaE?̼~}s'+:_gDCw?Vd R9x:Xs>E< =r#όw^(v= L">uvVY9WPkLt( tR:(t~"4_Ik~t,yWAӗ aVcQbItO@<ݷǣgs؍#3C~:y:ϝ|ǫFW֮SWeD*i4Lf~ٚ\z\njP$w',{*v]78ԳNO9dE5xg4aL7OGqU;2Hw?y}oP@&xD;>Fé'63 \ټ#5Mp%Z_@0%[y8/xyq|{XcRYdځ7d&#=GEkѓ41)C?oj|1g? C!Bh|xu۱WbQvQOda]H'w_kSŜ"}yφ=yyn޿%~L<_Ⱥe_H5I7-8Fxdm# Fءv*UثWv*>RUvu|U/uYZ r_iײߞ˴rǀ|&b_ÿR;v*U7-Dz nx|IL~W}=L2s?>F_H80Zg?,3Gi> ^*=2c텁/<+ᅬiP@X݅,yV0ݏ[ԼVM^tjN7 bϋ6{~'ɼYOabKea&c37.FUq &G"xM p"`Y<{B {8:O,H%`8Om݊=<"~ėWNXr|R 9ZBD]ޅNP{89@}1ߕ=ZLwˏ|.]NȾ};rr?`NiI}N9n:Nj/#ih !EG) R/4[`ݰi ,QxWb]C\Ck72! * , NB1Nyo̫ͯ5io tڠSN$ }ǾyhjQ:z~iFz7l;z]ڙ7'PG̖sgO3\򏗽CᅬyI\+Ss$z/+]9D Y/p:$Kݴ.*|Y:2( k^\W@{Z򀐷`f |{`em1q33! ƐdοFX{J5EM{=6Hm2HB8'1@[vOUq#dh}0]y̺ov{#BzX PBa]1͒SdHgaRÛǷq:_]yK4vR/$^էCl, P Pv*Uث|9C6:]<Ў\.5٧Z}Y$Z,3OۚK*/Oϟo?wa<~v*Uت*?R**?GO61Q9}_Jbjyw_odu@~@{O4Q|0%H "s k'tSꑯCqsXVHԑK,/~bzl K?Վ#"}ثWb]~~L7Z(SQr}Yӗvfx@>~&gQCq|_@iznVf{+soϦ-S6sRMfm]{_<Ffǜښq/ǓOS_10!Kyx7qN]L#G_Η?Ie?({Gl:<:ˊ_Շ }7c:mL.s~o/|~4_IJ"<<0\?$K,lv:H1U)m*i%~Vؕ怒V02C6SEV^)4ɋ"Aȴ}lqR1_4j<-13_g|_Qc~Cѧ&e?'Ծ\Aj/L,S%v*UثWbzb/ǜG4VTjvơ)OCp?L7=XF& ?ggǜ]N4Qg]wo_|z>3Dz>kHwΝ_:W&5׾PcREF *$ <ܗ?w[^_3Aj5jm"Vk"n哼>e vGf`uϪg"X&bb]v*ɼa]" 5sJEA589ٚQ>y?n;c+p?|_ZoKH~)w_iJ|~XK[1f h)(!=.]_vW;V[?5/;v*UR$s?ٝb`>_e?#C?=۹@7@c/fOR呑۸ͻe7~ -Dv"|2M$"텁f0Xv*1T#8 #vV}QlUUlD e*]/姓%~_X- Tah>Op|M@~b~O%j%B|7]O4~TC x 9mߗ?Xb}8#_Υ/< iH3|.S5Ⱦ^"|2AEFm4 YfPv*UثWs*}.57M?(贻t-V|]sq98s=ƾBi_g(e8f݊v*4qOߝaÇI;?i~E8"OKؼiHͻe4$^iQ/%iZǙ5OѶ6cDE<"fix ?齉1'aɗ+w*[H7ySg?ueNR]q h a$O_O3嗟tw vp:`=e=)I v*Uث4{R[ΎCM3oOe>ٳy^I}{vS>m,{* DYK,#D;?8ٵ=BR5.%ֵy\o9&g##̛~i 0a9]ɚQ6PݞC5GWɜ9K1'6\-/<> "!R=2M%E /4yDW5y4AQoَ1Z(Ɗ7f W,q@Fs;;lɐyd69mwX2>(CYĐrfW<'lNid˘qG^Ňgu9H#_!dC"F#6bMgALֳm4m?Qag'rj r!4@6E*&<ťKԦMHohݳ}}6t{ߏݳ9tpŏ}Qֈ{j8 X A6OE#F w T\u1j4 P&6C:*LL /贙5y䐈Kg/1yTnZJTW*^T<6SrI?7nciqi8tE}XTv*ڂ(ƃrɦVl3͐a"|,Ox g1B0_˩d8|9=ʖ?.uב4~ j}wK)݆IiE?P Pv*UثWHv_ԗ_%n,k@^b@&o]7~1tc^uثWbCؐ~Őd=6>z[xfv R}a@(; QfW H<1b_4̒mָ_z)Cw:iؓ5KOmj<4eS"BKϧߞYخ]eR$|=#Co;lc[n&UG/b,G%xе m# ֞tO]dz8^@|c8<3_v*dhը9Ds Br>ya&@E?x0~Ea&d˰?^ $Q")gv4 $ab&s'rY?3syBmGQMZ"@u*~("?c7ӆpڿ#_ ==ڸdy9p9sϰv*"oh[{o'yQȫ[Vimf -P}7K`5G|c}~Չ H8ѡi35y_,M)mG֖ p͹ERﺂ4$(Ѵ'z~0Ƴ(qxDC܌G^C0*l?ZY@뗺.n~d7?&e5/?Ǧ YCI{){I/hu>s3/{?=CCTRyv$qj/J2W1WzoWTb_N}'SOeeyXXliA092?ch:0Gv*Uتw_%f E><;3Q^_!y{[uXf(s9(HA=h>s( J큷؇ؾD@ h.̾{5i#+bGky(j*rs}(wWm>V{=߳:ةCnjODk}R6$y078[*Q>=HH'^iU$wi ?[`fr #r9dOS;v*m2/jl;/O#g?Wcgǂ?֟/:,|W'y?O|>XW$^@K۝R==6Y,|O]yd<N%u`UثWb7o+H܇j{o 9?[}v~&O->BdkGy !BEP}>D_eyU H4z/W>d,–J+ BHȤ98G$Dz]ڹ|-&)dX$gFkyߑHx_j(Ian&lJgڝ-@8za׼~x{Qɨ Jcܣ;ԟ < Wb^'xh|ݪ Z{E8֡쟳V?`vwy}?V^ޑ0g_~vO9q74-M? haƇ3Sj8( ?Vs%Q!Hb>|RR|֝v*YC8PQ⑹D|*є: '=,nz48O<9AObRi^6LC?&n?={NU^xil?I~L=n?2H;?"Po?Տ"w?{AW?Տ"wɛӏԩod$Q]K+4$ffc@ RI=Ҟ_Lq?]E+6XU9|Fx (E+W_'ύgSH;9kGGYs?'?!Ac'ՂR_~2{!fb]d:7ץcSQH@jgOQ mws23agpƸ䟜UUNtRYu&4f>8[fd3f9"0閺BM:RyCOr3S.B#Ir4LF,<o濟c>yeE jFF*sYF}2Gw!o?e-6"8|Rzgb]N9sozzz>Y0h"~rKn0?yl_/h !Eו4hrFxPA k1 a,\/>f"M Qn$sH=2=yvXBCav{SAWY!{𕏃Wb] ;~dB?ZU* 3qUyo].3#1dI]R)Cںs~}6.A?|LSRPyndido$)FlN ><B !2-]NM'yPߡoW͖vv@lo7 *ZN^C#!";K 0FQg}Q&$呔I$$/dơ+q}7_Au-vhs^d`=]9r p3<~E[ǧd~Ku[^_Կo'~I<.CfrM߻,z->=>1Pn[Wb]v*UثWblx^e]F$9L8Y;RcNn~ =YS<8CjG#sџi\PC5ĆA 銿⯇?5(n?1.[cqo!4ְ Xȣ됨"ȣUG:?OL{ ư*$/v'v]v*UثWb]v*U4n:#?sv&}FǼͽfvE||`} J{x$H 9it?2vmnM^zl9 ּIfK%gc$_WygM|=_p~SYj:_涕l^PH5_#mgz ;:rhGc?FWx +)D=]xz?>3}ثWb]v*UثTLea,O'v_~@v3dԑzBK'p#Kzh@"eA0 O{GQ:j533drl2H\_@GH , _9,XǢn/F&OfGk7?O?{cC|>>hEC^Z(LP6X%lRYu=OϿq.ݮ5)ڡ2[w{DwhUOvN;;r:ǻ~C?P yl_A^۸d.1??T&MbӤsd Hp%TrvO=1$KNOU<]#>_<ئjmi'FFPTЩ.(偄~>Q F 䁸ȍ#̟Hy3 J^'uԪ{Khb֓<!}G)t'v*UثWbIGm#EQSc<$8vEN89׸s,@T+- VNh=%FN'tG6S 'E(:DP>,dD$$$,K^W_5,]> Y/޿kﴝ{W,$TmYltD>d^Z-Ԥ!j/U+m4baQQR)^wi?Z $RM:N!-&)$o$$r+5Zw"?O{{5n01㟉@T}>GיI$:fm۩[;ҼVuėh>J5C~'yo"?O}=Md@ЄA> a`Kll*텂.ڨE1WZޟCXݡ5)#'Ti9tLR0MDA#pTܓ^Jo.J\ ťz0t(g;sM~; 8AK m*a29lhd.9xW$LF!+.DYόIOF]K9|{]>^~@Cdb~SU>`GUƿ $?|#)ͷTn$i?A}w"|ߏV(119|"*#mtŅx["^Fzc+@vm{S',;GB>^ꭚi^YF_ݝA/`)X , }'/Z{h`̨LQ1Oza,cD4:Wƻj{odm8HȘ7?Qh0ca q]~o؂zُw==SԿ0t_YI\ԇ???ؿy;/AsRX';Nj_ʟGcu?NSKc?;#O'bweJ? O~v'v_)O?#1Cb'rN j~GObweJ?⑖>['TnG$n;x^scoc˧{Qf}>drGqDR[znc)uO\럞 ܼI*NDiҙ 'Ӿ^+m*( bCȕcE;bk^^_2KֽS`%__E^Kp[_,bW>Om,))݊!FV-d$Į ?0S.$O /)1W[&B~ƑȬ?saq2$_(%iQD ,mXm{be: ( 5@(PGZm!iQ'0;b+i ojZYy~ŕUbo~) %s`\LfB?4Isy i?0I_6t .Zn:b-5lRum?g˞0^s}#1 YZC''? O ix^'Ɨ!1w ix^'ƗQ<ƗVѱyb1OݏZkcR?v>Vӈ4TZ|C"„+5^ت5!(WT^1VWbk7lU)qJCsF+6yr6M2Z3v+hS868Cm~}آh<cm;#Z|bNQpXi*Xx2GQJ.mlRi 0&y|ϖ}_+n 1[wn?ۿq Vb}<}ح)bNmJQi}ohaBkS"*Uv*Uث\Wb}4=QO1VOX߫۞G?*խ?1W}VYwխ?1VoLUw?F*ߧb_v*[]v*UثT\TQbzq*Єk#b}VYwm/1VoLUBF*ӌtG1Vnov*bx^gk UF/Uތ?I1Wz0ba}']Oч#w?F*FUތ?I1V8DQ Uw>UUثWv*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb_gcl-2.6.14/xgcl-2/0000755000175000017500000000000014360276512012067 5ustar cammcammgcl-2.6.14/xgcl-2/gcl_general.lsp0000644000175000017500000000601714360276512015055 0ustar cammcamm(in-package :XLIB) ; general.lsp Hiep Huu Nguyen ; 24 Jun 06 ; 15 Sep 05; 24 Jan 06 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ; 27 Aug 92 ; 15 Sep 05: Edited by G. Novak to change C function headers to new form ; 24 Jan 06: Edited by G. Novak to remove vertex-array entries. ; 22 Jun 06: Edited by G. Novak to fix entry types ;(defentry free (string) (void free)) ;(defentry calloc(fixnum fixnum) (string calloc)) (defentry char-array (int) (fixnum char_array)) (defentry char-pos (fixnum int) (char char_pos)) (defentry set-char-array (fixnum int char) (void set_char_array)) (defentry int-array (int) (fixnum int_array)) (defentry int-pos (fixnum int) (int int_pos)) (defentry set-int-array (fixnum int int) (void set_int_array)) (defentry fixnum-array (int) (fixnum fixnum_array)) (defentry fixnum-pos (fixnum int) (fixnum fixnum_pos)) (defentry set-fixnum-array (fixnum int fixnum) (void set_fixnum_array)) ;;from mark ring's function ;; General routines. (defCfun "object get_c_string(object s)" 0 " return((object)s->st.st_self);" ) (defCfun "object get_c_string1(object s)" 0 " return((object)object_to_string(s));" ) (defCfun "fixnum get_c_string2(object s)" 0 " return((fixnum)get_c_string(s));" ) (defentry get_c_string_2 (object) (object get_c_string)) ;; make sure string is null terminated (defentry get-c-string (object) (object get_c_string1));"(object)object_to_string")) ;; General routines. (defCfun "object lisp_string(object a_string, fixnum c_string) " 0 "extern unsigned long strlen(const char *);" "fixnum len = strlen((void *)c_string);" "a_string->st.st_dim = len;" "a_string->st.st_fillp = len;" "a_string->st.st_self = (void *)c_string;" "return(a_string);" ) (defentry lisp-string-2 (object fixnum ) (object lisp_string)) (defun lisp-string (a-string ) (lisp-string-2 "" a-string )) ;;modified from mark ring's function ;; General routines. (defCfun "fixnum get_st_point(object s)" 0 " return((fixnum) s->st.st_self);" ) (defentry get-st-point2 (object) (fixnum get_c_string2));"(fixnum)get_c_string")) ;; make sure string is null terminated (defun get-st-point (string) ( get-st-point2 (concatenate 'string string ""))) gcl-2.6.14/xgcl-2/gcl_Xlib.lsp0000644000175000017500000014110714360276512014336 0ustar cammcamm(in-package :XLIB) ; Xlib.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;typedef unsigned long XID) ; ;;typedef XID Window) ; ;;typedef XID Drawable) ; ;;typedef XID Font) ; ;;typedef XID Pixmap) ; ;;typedef XID Cursor) ; ;;typedef XID Colormap) ; ;;typedef XID GContext) ; ;;typedef XID KeySym) ; ;;typedef unsigned long Mask) ; ;;typedef unsigned long Atom) ; ;;typedef unsigned long VisualID) ; ;;typedef unsigned long Time) ; ;;typedef unsigned char KeyCode) ; (defconstant True 1) (defconstant False 0) (defconstant QueuedAlready 0) (defconstant QueuedAfterReading 1) (defconstant QueuedAfterFlush 2) (defentry XLoadQueryFont( fixnum ;; display object ;; name )( fixnum "XLoadQueryFont")) (defentry XQueryFont( fixnum ;; display fixnum ;; font_ID )( fixnum "XQueryFont")) (defentry XGetMotionEvents( fixnum ;; display fixnum ;; w fixnum ;; start fixnum ;; stop fixnum ;; nevents_return )( fixnum "XGetMotionEvents")) (defentry XDeleteModifiermapEntry( fixnum ;; modmap fixnum ;; keycode_entry fixnum ;; modifier )( fixnum "XDeleteModifiermapEntry")) (defentry XGetModifierMapping( fixnum ;; display )( fixnum "XGetModifierMapping")) (defentry XInsertModifiermapEntry( fixnum ;; modmap fixnum ;; keycode_entry fixnum ;; modifier )( fixnum "XInsertModifiermapEntry")) (defentry XNewModifiermap( fixnum ;; max_keys_per_mod )( fixnum "XNewModifiermap")) (defentry XCreateImage( fixnum ;; display fixnum ;; visual fixnum ;; depth fixnum ;; format fixnum ;; offset object ;; data fixnum ;; width fixnum ;; height fixnum ;; bitmap_pad fixnum ;; bytes_per_line )( fixnum "XCreateImage")) (defentry XGetImage( fixnum ;; display fixnum ;; d fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; plane_mask fixnum ;; format )( fixnum "XGetImage")) (defentry XGetSubImage( fixnum ;; display fixnum ;; d fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; plane_mask fixnum ;; format fixnum ;; dest_image fixnum ;; dest_x fixnum ;; dest_y )( fixnum "XGetSubImage")) ;;Window X function declarations. (defentry XOpenDisplay( object ;; display_name )( fixnum "XOpenDisplay")) (defentry XrmInitialize( ;; void )( void "XrmInitialize")) (defentry XFetchBytes( fixnum ;; display fixnum ;; nbytes_return )( fixnum "XFetchBytes")) (defentry XFetchBuffer( fixnum ;; display fixnum ;; nbytes_return fixnum ;; buffer )( fixnum "XFetchBuffer")) (defentry XGetAtomName( fixnum ;; display fixnum ;; atom )( fixnum "XGetAtomName")) (defentry XGetDefault( fixnum ;; display object ;; program object ;; option )( fixnum "XGetDefault")) (defentry XDisplayName( object ;; string )( fixnum "XDisplayName")) (defentry XKeysymToString( fixnum ;; keysym )( fixnum "XKeysymToString")) (defentry XInternAtom( fixnum ;; display object ;; atom_name fixnum ;; only_if_exists )( fixnum "XInternAtom")) (defentry XCopyColormapAndFree( fixnum ;; display fixnum ;; colormap )( fixnum "XCopyColormapAndFree")) (defentry XCreateColormap( fixnum ;; display fixnum ;; w fixnum ;; visual fixnum ;; alloc )( fixnum "XCreateColormap")) (defentry XCreatePixmapCursor( fixnum ;; display fixnum ;; source fixnum ;; mask fixnum ;; foreground_color fixnum ;; background_color fixnum ;; x fixnum ;; y )( fixnum "XCreatePixmapCursor")) (defentry XCreateGlyphCursor( fixnum ;; display fixnum ;; source_font fixnum ;; mask_font fixnum ;; source_char fixnum ;; mask_char fixnum ;; foreground_color fixnum ;; background_color )( fixnum "XCreateGlyphCursor")) (defentry XCreateFontCursor( fixnum ;; display fixnum ;; shape )( fixnum "XCreateFontCursor")) (defentry XLoadFont( fixnum ;; display object ;; name )( fixnum "XLoadFont")) (defentry XCreateGC( fixnum ;; display fixnum ;; d fixnum ;; valuemask fixnum ;; values )( fixnum "XCreateGC")) (defentry XGContextFromGC( fixnum ;; gc )( fixnum "XGContextFromGC")) (defentry XCreatePixmap( fixnum ;; display fixnum ;; d fixnum ;; width fixnum ;; height fixnum ;; depth )( fixnum "XCreatePixmap")) (defentry XCreateBitmapFromData( fixnum ;; display fixnum ;; d object ;; data fixnum ;; width fixnum ;; height )( fixnum "XCreateBitmapFromData")) (defentry XCreatePixmapFromBitmapData( fixnum ;; display fixnum ;; d object ;; data fixnum ;; width fixnum ;; height fixnum ;; fg fixnum ;; bg fixnum ;; depth )( fixnum "XCreatePixmapFromBitmapData")) (defentry XCreateSimpleWindow( fixnum ;; display fixnum ;; parent fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; border_width fixnum ;; border fixnum ;; background )( fixnum "XCreateSimpleWindow")) (defentry XGetSelectionOwner( fixnum ;; display fixnum ;; selection )( fixnum "XGetSelectionOwner")) (defentry XCreateWindow( fixnum ;; display fixnum ;; parent fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; border_width fixnum ;; depth fixnum ;; class fixnum ;; visual fixnum ;; valuemask fixnum ;; attributes )( fixnum "XCreateWindow")) (defentry XListInstalledColormaps( fixnum ;; display fixnum ;; w fixnum ;; num_return )( fixnum "XListInstalledColormaps")) (defentry XListFonts( fixnum ;; display object ;; pattern fixnum ;; maxnames fixnum ;; actual_count_return )( fixnum "XListFonts")) (defentry XListFontsWithInfo( fixnum ;; display object ;; pattern fixnum ;; maxnames fixnum ;; count_return fixnum ;; info_return )( fixnum "XListFontsWithInfo")) (defentry XGetFontPath( fixnum ;; display fixnum ;; npaths_return )( fixnum "XGetFontPath")) (defentry XListExtensions( fixnum ;; display fixnum ;; nextensions_return )( fixnum "XListExtensions")) (defentry XListProperties( fixnum ;; display fixnum ;; w fixnum ;; num_prop_return )( fixnum "XListProperties")) (defentry XListHosts( fixnum ;; display fixnum ;; nhosts_return fixnum ;; state_return )( fixnum "XListHosts")) (defentry XKeycodeToKeysym( fixnum ;; display fixnum ;; fixnum fixnum ;; index )( fixnum "XKeycodeToKeysym")) (defentry XLookupKeysym( fixnum ;; key_event fixnum ;; index )( fixnum "XLookupKeysym")) (defentry XGetKeyboardMapping( fixnum ;; display fixnum ;; first_keycode fixnum ;; keycode_count fixnum ;; keysyms_per_keycode_return )( fixnum "XGetKeyboardMapping")) (defentry XStringToKeysym( object ;; string )( fixnum "XStringToKeysym")) (defentry XMaxRequestSize( fixnum ;; display )( fixnum "XMaxRequestSize")) (defentry XResourceManagerString( fixnum ;; display )( fixnum "XResourceManagerString")) (defentry XDisplayMotionBufferSize( fixnum ;; display )( fixnum "XDisplayMotionBufferSize")) (defentry XVisualIDFromVisual( fixnum ;; visual )( fixnum "XVisualIDFromVisual")) ;; routines for dealing with extensions (defentry XInitExtension( fixnum ;; display object ;; name )( fixnum "XInitExtension")) (defentry XAddExtension( fixnum ;; display )( fixnum "XAddExtension")) (defentry XFindOnExtensionList( fixnum ;; structure fixnum ;; number )( fixnum "XFindOnExtensionList")) ;;;fix ;(defentry XEHeadOfExtensionList( ; fixnum ;;object ;)( fixnum "XEHeadOfExtensionList")) ;; these are routines for which there are also macros (defentry XRootWindow( fixnum ;; display fixnum ;; screen_number )( fixnum "XRootWindow")) (defentry XDefaultRootWindow( fixnum ;; display )( fixnum "XDefaultRootWindow")) (defentry XRootWindowOfScreen( fixnum ;; screen )( fixnum "XRootWindowOfScreen")) (defentry XDefaultVisual( fixnum ;; display fixnum ;; screen_number )( fixnum "XDefaultVisual")) (defentry XDefaultVisualOfScreen( fixnum ;; screen )( fixnum "XDefaultVisualOfScreen")) (defentry XDefaultGC( fixnum ;; display fixnum ;; screen_number )( fixnum "XDefaultGC")) (defentry XDefaultGCOfScreen( fixnum ;; screen )( fixnum "XDefaultGCOfScreen")) (defentry XBlackPixel( fixnum ;; display fixnum ;; screen_number )( fixnum "XBlackPixel")) (defentry XWhitePixel( fixnum ;; display fixnum ;; screen_number )( fixnum "XWhitePixel")) (defentry XAllPlanes( ;; void )( fixnum "XAllPlanes")) (defentry XBlackPixelOfScreen( fixnum ;; screen )( fixnum "XBlackPixelOfScreen")) (defentry XWhitePixelOfScreen( fixnum ;; screen )( fixnum "XWhitePixelOfScreen")) (defentry XNextRequest( fixnum ;; display )( fixnum "XNextRequest")) (defentry XLastKnownRequestProcessed( fixnum ;; display )( fixnum "XLastKnownRequestProcessed")) (defentry XServerVendor( fixnum ;; display )( fixnum "XServerVendor")) (defentry XDisplayString( fixnum ;; display )( fixnum "XDisplayString")) (defentry XDefaultColormap( fixnum ;; display fixnum ;; screen_number )( fixnum "XDefaultColormap")) (defentry XDefaultColormapOfScreen( fixnum ;; screen )( fixnum "XDefaultColormapOfScreen")) (defentry XDisplayOfScreen( fixnum ;; screen )( fixnum "XDisplayOfScreen")) (defentry XScreenOfDisplay( fixnum ;; display fixnum ;; screen_number )( fixnum "XScreenOfDisplay")) (defentry XDefaultScreenOfDisplay( fixnum ;; display )( fixnum "XDefaultScreenOfDisplay")) (defentry XEventMaskOfScreen( fixnum ;; screen )( fixnum "XEventMaskOfScreen")) (defentry XScreenNumberOfScreen( fixnum ;; screen )( fixnum "XScreenNumberOfScreen")) (defentry XSetErrorHandler ( fixnum ;; handler )( fixnum "XSetErrorHandler" )) ;;fix (defentry XSetIOErrorHandler ( fixnum ;; handler )( fixnum "XSetIOErrorHandler" )) (defentry XListPixmapFormats( fixnum ;; display fixnum ;; count_return )( fixnum "XListPixmapFormats")) (defentry XListDepths( fixnum ;; display fixnum ;; screen_number fixnum ;; count_return )( fixnum "XListDepths")) ;; ICCCM routines for things that don't require special include files; ;; other declarations are given in Xutil.h (defentry XReconfigureWMWindow( fixnum ;; display fixnum ;; w fixnum ;; screen_number fixnum ;; mask fixnum ;; changes )( fixnum "XReconfigureWMWindow")) (defentry XGetWMProtocols( fixnum ;; display fixnum ;; w fixnum ;; protocols_return fixnum ;; count_return )( fixnum "XGetWMProtocols")) (defentry XSetWMProtocols( fixnum ;; display fixnum ;; w fixnum ;; protocols fixnum ;; count )( fixnum "XSetWMProtocols")) (defentry XIconifyWindow( fixnum ;; display fixnum ;; w fixnum ;; screen_number )( fixnum "XIconifyWindow")) (defentry XWithdrawWindow( fixnum ;; display fixnum ;; w fixnum ;; screen_number )( fixnum "XWithdrawWindow")) ;;;fix (defentry XGetCommand( fixnum ;; display fixnum ;; w fixnum ;; argv_return fixnum ;; argc_return )( fixnum "XGetCommand")) (defentry XGetWMColormapWindows( fixnum ;; display fixnum ;; w fixnum ;; windows_return fixnum ;; count_return )( fixnum "XGetWMColormapWindows")) (defentry XSetWMColormapWindows( fixnum ;; display fixnum ;; w fixnum ;; colormap_windows fixnum ;; count )( fixnum "XSetWMColormapWindows")) (defentry XFreeStringList( fixnum ;; list )( void "XFreeStringList")) (defentry XSetTransientForHint( fixnum ;; display fixnum ;; w fixnum ;; prop_window )( void "XSetTransientForHint")) ;; The following are given in alphabetical order (defentry XActivateScreenSaver( fixnum ;; display )( void "XActivateScreenSaver")) (defentry XAddHost( fixnum ;; display fixnum ;; host )( void "XAddHost")) (defentry XAddHosts( fixnum ;; display fixnum ;; hosts fixnum ;; num_hosts )( void "XAddHosts")) (defentry XAddToExtensionList( fixnum ;; structure fixnum ;; ext_data )( void "XAddToExtensionList")) (defentry XAddToSaveSet( fixnum ;; display fixnum ;; w )( void "XAddToSaveSet")) (defentry XAllocColor( fixnum ;; display fixnum ;; colormap fixnum ;; screen_in_out )( fixnum "XAllocColor")) ;;;fix (defentry XAllocColorCells( fixnum ;; display fixnum ;; colormap fixnum ;; contig fixnum ;; plane_masks_return fixnum ;; nplanes fixnum ;; pixels_return fixnum ;; npixels )( fixnum "XAllocColorCells")) (defentry XAllocColorPlanes( fixnum ;; display fixnum ;; colormap fixnum ;; contig fixnum ;; pixels_return fixnum ;; ncolors fixnum ;; nreds fixnum ;; ngreens fixnum ;; nblues fixnum ;; rmask_return fixnum ;; gmask_return fixnum ;; bmask_return )( fixnum "XAllocColorPlanes")) (defentry XAllocNamedColor( fixnum ;; display fixnum ;; colormap object ;; color_name fixnum ;; screen_def_return fixnum ;; exact_def_return )( fixnum "XAllocNamedColor")) (defentry XAllowEvents( fixnum ;; display fixnum ;; event_mode fixnum ;; time )( void "XAllowEvents")) (defentry XAutoRepeatOff( fixnum ;; display )( void "XAutoRepeatOff")) (defentry XAutoRepeatOn( fixnum ;; display )( void "XAutoRepeatOn")) (defentry XBell( fixnum ;; display fixnum ;; percent )( void "XBell")) (defentry XBitmapBitOrder( fixnum ;; display )( fixnum "XBitmapBitOrder")) (defentry XBitmapPad( fixnum ;; display )( fixnum "XBitmapPad")) (defentry XBitmapUnit( fixnum ;; display )( fixnum "XBitmapUnit")) (defentry XCellsOfScreen( fixnum ;; screen )( fixnum "XCellsOfScreen")) (defentry XChangeActivePointerGrab( fixnum ;; display fixnum ;; event_mask fixnum ;; cursor fixnum ;; time )( void "XChangeActivePointerGrab")) (defentry XChangeGC( fixnum ;; display fixnum ;; gc fixnum ;; valuemask fixnum ;; values )( void "XChangeGC")) (defentry XChangeKeyboardControl( fixnum ;; display fixnum ;; value_mask fixnum ;; values )( void "XChangeKeyboardControl")) (defentry XChangeKeyboardMapping( fixnum ;; display fixnum ;; first_keycode fixnum ;; keysyms_per_keycode fixnum ;; keysyms fixnum ;; num_codes )( void "XChangeKeyboardMapping")) (defentry XChangePointerControl( fixnum ;; display fixnum ;; do_accel fixnum ;; do_threshold fixnum ;; accel_numerator fixnum ;; accel_denominator fixnum ;; threshold )( void "XChangePointerControl")) (defentry XChangeProperty( fixnum ;; display fixnum ;; w fixnum ;; property fixnum ;; type fixnum ;; format fixnum ;; mode fixnum ;; data fixnum ;; nelements )( void "XChangeProperty")) (defentry XChangeSaveSet( fixnum ;; display fixnum ;; w fixnum ;; change_mode )( void "XChangeSaveSet")) (defentry XChangeWindowAttributes( fixnum ;; display fixnum ;; w fixnum ;; valuemask fixnum ;; attributes )( void "XChangeWindowAttributes")) (defentry XCheckMaskEvent( fixnum ;; display fixnum ;; event_mask fixnum ;; event_return )( fixnum "XCheckMaskEvent")) (defentry XCheckTypedEvent( fixnum ;; display fixnum ;; event_type fixnum ;; event_return )( fixnum "XCheckTypedEvent")) (defentry XCheckTypedWindowEvent( fixnum ;; display fixnum ;; w fixnum ;; event_type fixnum ;; event_return )( fixnum "XCheckTypedWindowEvent")) (defentry XCheckWindowEvent( fixnum ;; display fixnum ;; w fixnum ;; event_mask fixnum ;; event_return )( fixnum "XCheckWindowEvent")) (defentry XCirculateSubwindows( fixnum ;; display fixnum ;; w fixnum ;; direction )( void "XCirculateSubwindows")) (defentry XCirculateSubwindowsDown( fixnum ;; display fixnum ;; w )( void "XCirculateSubwindowsDown")) (defentry XCirculateSubwindowsUp( fixnum ;; display fixnum ;; w )( void "XCirculateSubwindowsUp")) (defentry XClearArea( fixnum ;; display fixnum ;; w fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; exposures )( void "XClearArea")) (defentry XClearWindow( fixnum ;; display fixnum ;; w )( void "XClearWindow")) (defentry XCloseDisplay( fixnum ;; display )( void "XCloseDisplay")) (defentry XConfigureWindow( fixnum ;; display fixnum ;; w fixnum ;; value_mask fixnum ;; values )( void "XConfigureWindow")) (defentry XConnectionNumber( fixnum ;; display )( fixnum "XConnectionNumber")) (defentry XConvertSelection( fixnum ;; display fixnum ;; selection fixnum ;; target fixnum ;; property fixnum ;; requestor fixnum ;; time )( void "XConvertSelection")) (defentry XCopyArea( fixnum ;; display fixnum ;; src fixnum ;; dest fixnum ;; gc fixnum ;; src_x fixnum ;; src_y fixnum ;; width fixnum ;; height fixnum ;; dest_x fixnum ;; dest_y )( void "XCopyArea")) (defentry XCopyGC( fixnum ;; display fixnum ;; src fixnum ;; valuemask fixnum ;; dest )( void "XCopyGC")) (defentry XCopyPlane( fixnum ;; display fixnum ;; src fixnum ;; dest fixnum ;; gc fixnum ;; src_x fixnum ;; src_y fixnum ;; width fixnum ;; height fixnum ;; dest_x fixnum ;; dest_y fixnum ;; plane )( void "XCopyPlane")) (defentry XDefaultDepth( fixnum ;; display fixnum ;; screen_number )( fixnum "XDefaultDepth")) (defentry XDefaultDepthOfScreen( fixnum ;; screen )( fixnum "XDefaultDepthOfScreen")) (defentry XDefaultScreen( fixnum ;; display )( fixnum "XDefaultScreen")) (defentry XDefineCursor( fixnum ;; display fixnum ;; w fixnum ;; cursor )( void "XDefineCursor")) (defentry XDeleteProperty( fixnum ;; display fixnum ;; w fixnum ;; property )( void "XDeleteProperty")) (defentry XDestroyWindow( fixnum ;; display fixnum ;; w )( void "XDestroyWindow")) (defentry XDestroySubwindows( fixnum ;; display fixnum ;; w )( void "XDestroySubwindows")) (defentry XDoesBackingStore( fixnum ;; screen )( fixnum "XDoesBackingStore")) (defentry XDoesSaveUnders( fixnum ;; screen )( fixnum "XDoesSaveUnders")) (defentry XDisableAccessControl( fixnum ;; display )( void "XDisableAccessControl")) (defentry XDisplayCells( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayCells")) (defentry XDisplayHeight( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayHeight")) (defentry XDisplayHeightMM( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayHeightMM")) (defentry XDisplayKeycodes( fixnum ;; display fixnum ;; min_keycodes_return fixnum ;; max_keycodes_return )( void "XDisplayKeycodes")) (defentry XDisplayPlanes( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayPlanes")) (defentry XDisplayWidth( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayWidth")) (defentry XDisplayWidthMM( fixnum ;; display fixnum ;; screen_number )( fixnum "XDisplayWidthMM")) (defentry XDrawArc( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; angle1 fixnum ;; angle2 )( void "XDrawArc")) (defentry XDrawArcs( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; arcs fixnum ;; narcs )( void "XDrawArcs")) (defentry XDrawImageString( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y object ;; string fixnum ;; length )( void "XDrawImageString")) (defentry XDrawImageString16( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; string fixnum ;; length )( void "XDrawImageString16")) (defentry XDrawLine( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x1 fixnum ;; x2 fixnum ;; y1 fixnum ;; y2 )( void "XDrawLine")) (defentry XDrawLines( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; points fixnum ;; npoints fixnum ;; mode )( void "XDrawLines")) (defentry XDrawPoint( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y )( void "XDrawPoint")) (defentry XDrawPoints( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; points fixnum ;; npoints fixnum ;; mode )( void "XDrawPoints")) (defentry XDrawRectangle( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height )( void "XDrawRectangle")) (defentry XDrawRectangles( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; rectangles fixnum ;; nrectangles )( void "XDrawRectangles")) (defentry XDrawSegments( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; segments fixnum ;; nsegments )( void "XDrawSegments")) (defentry XDrawString( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y object ;; string fixnum ;; length )( void "XDrawString")) (defentry XDrawString16( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; string fixnum ;; length )( void "XDrawString16")) (defentry XDrawText( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; items fixnum ;; nitems )( void "XDrawText")) (defentry XDrawText16( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; items fixnum ;; nitems )( void "XDrawText16")) (defentry XEnableAccessControl( fixnum ;; display )( void "XEnableAccessControl")) (defentry XEventsQueued( fixnum ;; display fixnum ;; mode )( fixnum "XEventsQueued")) (defentry XFetchName( fixnum ;; display fixnum ;; w fixnum ;; window_name_return )( fixnum "XFetchName")) (defentry XFillArc( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height fixnum ;; angle1 fixnum ;; angle2 )( void "XFillArc")) (defentry XFillArcs( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; arcs fixnum ;; narcs )( void "XFillArcs")) (defentry XFillPolygon( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; points fixnum ;; npoints fixnum ;; shape fixnum ;; mode )( void "XFillPolygon")) (defentry XFillRectangle( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height )( void "XFillRectangle")) (defentry XFillRectangles( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; rectangles fixnum ;; nrectangles )( void "XFillRectangles")) (defentry XFlush( fixnum ;; display )( void "XFlush")) (defentry XForceScreenSaver( fixnum ;; display fixnum ;; mode )( void "XForceScreenSaver")) (defentry XFree( object ;; data )( void "XFree")) (defentry XFreeColormap( fixnum ;; display fixnum ;; colormap )( void "XFreeColormap")) (defentry XFreeColors( fixnum ;; display fixnum ;; colormap fixnum ;; pixels fixnum ;; npixels fixnum ;; planes )( void "XFreeColors")) (defentry XFreeCursor( fixnum ;; display fixnum ;; cursor )( void "XFreeCursor")) (defentry XFreeExtensionList( fixnum ;; list )( void "XFreeExtensionList")) (defentry XFreeFont( fixnum ;; display fixnum ;; font_struct )( void "XFreeFont")) (defentry XFreeFontInfo( fixnum ;; names fixnum ;; free_info fixnum ;; actual_count )( void "XFreeFontInfo")) (defentry XFreeFontNames( fixnum ;; list )( void "XFreeFontNames")) (defentry XFreeFontPath( fixnum ;; list )( void "XFreeFontPath")) (defentry XFreeGC( fixnum ;; display fixnum ;; gc )( void "XFreeGC")) (defentry XFreeModifiermap( fixnum ;; modmap )( void "XFreeModifiermap")) (defentry XFreePixmap( fixnum ;; display fixnum ;; fixnum )( void "XFreePixmap")) (defentry XGeometry( fixnum ;; display fixnum ;; screen object ;; position object ;; default_position fixnum ;; bwidth fixnum ;; fwidth fixnum ;; fheight fixnum ;; xadder fixnum ;; yadder fixnum ;; x_return fixnum ;; y_return fixnum ;; width_return fixnum ;; height_return )( fixnum "XGeometry")) (defentry XGetErrorDatabaseText( fixnum ;; display object ;; name object ;; message object ;; default_string object ;; buffer_return fixnum ;; length )( void "XGetErrorDatabaseText")) (defentry XGetErrorText( fixnum ;; display fixnum ;; code object ;; buffer_return fixnum ;; length )( void "XGetErrorText")) (defentry XGetFontProperty( fixnum ;; font_struct fixnum ;; atom fixnum ;; value_return )( fixnum "XGetFontProperty")) (defentry XGetGCValues( fixnum ;; display fixnum ;; gc fixnum ;; valuemask fixnum ;; values_return )( fixnum "XGetGCValues")) (defentry XGetGeometry( fixnum ;; display fixnum ;; d fixnum ;; root_return fixnum ;; x_return fixnum ;; y_return fixnum ;; width_return fixnum ;; height_return fixnum ;; border_width_return fixnum ;; depth_return )( fixnum "XGetGeometry")) (defentry XGetIconName( fixnum ;; display fixnum ;; w fixnum ;; icon_name_return )( fixnum "XGetIconName")) (defentry XGetInputFocus( fixnum ;; display fixnum ;; focus_return fixnum ;; revert_to_return )( void "XGetInputFocus")) (defentry XGetKeyboardControl( fixnum ;; display fixnum ;; values_return )( void "XGetKeyboardControl")) (defentry XGetPointerControl( fixnum ;; display fixnum ;; accel_numerator_return fixnum ;; accel_denominator_return fixnum ;; threshold_return )( void "XGetPointerControl")) (defentry XGetPointerMapping( fixnum ;; display object ;; map_return fixnum ;; nmap )( fixnum "XGetPointerMapping")) (defentry XGetScreenSaver( fixnum ;; display fixnum ;; intout_return fixnum ;; interval_return fixnum ;; prefer_blanking_return fixnum ;; allow_exposures_return )( void "XGetScreenSaver")) (defentry XGetTransientForHint( fixnum ;; display fixnum ;; w fixnum ;; prop_window_return )( fixnum "XGetTransientForHint")) (defentry XGetWindowProperty( fixnum ;; display fixnum ;; w fixnum ;; property fixnum ;; int_offset fixnum ;; int_length fixnum ;; delete fixnum ;; req_type fixnum ;; actual_type_return fixnum ;; actual_format_return fixnum ;; nitems_return fixnum ;; bytes_after_return fixnum ;; prop_return )( fixnum "XGetWindowProperty")) (defentry XGetWindowAttributes( fixnum ;; display fixnum ;; w fixnum ;; Window_attributes_return )( fixnum "XGetWindowAttributes")) (defentry XGrabButton( fixnum ;; display fixnum ;; button fixnum ;; modifiers fixnum ;; grab_window fixnum ;; owner_events fixnum ;; event_mask fixnum ;; pointer_mode fixnum ;; keyboard_mode fixnum ;; confine_to fixnum ;; cursor )( void "XGrabButton")) (defentry XGrabKey( fixnum ;; display fixnum ;; keycode fixnum ;; modifiers fixnum ;; grab_window fixnum ;; owner_events fixnum ;; pointer_mode fixnum ;; keyboard_mode )( void "XGrabKey")) (defentry XGrabKeyboard( fixnum ;; display fixnum ;; grab_window fixnum ;; owner_events fixnum ;; pointer_mode fixnum ;; keyboard_mode fixnum ;; fixnum )( fixnum "XGrabKeyboard")) (defentry XGrabPointer( fixnum ;; display fixnum ;; grab_window fixnum ;; owner_events fixnum ;; event_mask fixnum ;; pointer_mode fixnum ;; keyboard_mode fixnum ;; confine_to fixnum ;; cursor fixnum ;; fixnum )( fixnum "XGrabPointer")) (defentry XGrabServer( fixnum ;; display )( void "XGrabServer")) (defentry XHeightMMOfScreen( fixnum ;; screen )( fixnum "XHeightMMOfScreen")) (defentry XHeightOfScreen( fixnum ;; screen )( fixnum "XHeightOfScreen")) (defentry XImageByteOrder( fixnum ;; display )( fixnum "XImageByteOrder")) (defentry XInstallColormap( fixnum ;; display fixnum ;; colormap )( void "XInstallColormap")) (defentry XKeysymToKeycode( fixnum ;; display fixnum ;; keysym )( fixnum "XKeysymToKeycode")) (defentry XKillClient( fixnum ;; display fixnum ;; resource )( void "XKillClient")) (defentry XLookupColor( fixnum ;; display fixnum ;; colormap object ;; color_name fixnum ;; exact_def_return fixnum ;; screen_def_return )( fixnum "XLookupColor")) (defentry XLowerWindow( fixnum ;; display fixnum ;; w )( void "XLowerWindow")) (defentry XMapRaised( fixnum ;; display fixnum ;; w )( void "XMapRaised")) (defentry XMapSubwindows( fixnum ;; display fixnum ;; w )( void "XMapSubwindows")) (defentry XMapWindow( fixnum ;; display fixnum ;; w )( void "XMapWindow")) (defentry XMaskEvent( fixnum ;; display fixnum ;; event_mask fixnum ;; event_return )( void "XMaskEvent")) (defentry XMaxCmapsOfScreen( fixnum ;; screen )( fixnum "XMaxCmapsOfScreen")) (defentry XMinCmapsOfScreen( fixnum ;; screen )( fixnum "XMinCmapsOfScreen")) (defentry XMoveResizeWindow( fixnum ;; display fixnum ;; w fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height )( void "XMoveResizeWindow")) (defentry XMoveWindow( fixnum ;; display fixnum ;; w fixnum ;; x fixnum ;; y )( void "XMoveWindow")) (defentry XNextEvent( fixnum ;; display fixnum ;; event_return )( void "XNextEvent")) (defentry XNoOp( fixnum ;; display )( void "XNoOp")) (defentry XParseColor( fixnum ;; display fixnum ;; colormap object ;; spec fixnum ;; exact_def_return )( fixnum "XParseColor")) (defentry XParseGeometry( object ;; parsestring fixnum ;; x_return fixnum ;; y_return fixnum ;; width_return fixnum ;; height_return )( fixnum "XParseGeometry")) (defentry XPeekEvent( fixnum ;; display fixnum ;; event_return )( void "XPeekEvent")) (defentry XPending( fixnum ;; display )( fixnum "XPending")) (defentry XPlanesOfScreen( fixnum ;; screen )( fixnum "XPlanesOfScreen")) (defentry XProtocolRevision( fixnum ;; display )( fixnum "XProtocolRevision")) (defentry XProtocolVersion( fixnum ;; display )( fixnum "XProtocolVersion")) (defentry XPutBackEvent( fixnum ;; display fixnum ;; event )( void "XPutBackEvent")) (defentry XPutImage( fixnum ;; display fixnum ;; d fixnum ;; gc fixnum ;; image fixnum ;; src_x fixnum ;; src_y fixnum ;; dest_x fixnum ;; dest_y fixnum ;; width fixnum ;; height )( void "XPutImage")) (defentry XQLength( fixnum ;; display )( fixnum "XQLength")) (defentry XQueryBestCursor( fixnum ;; display fixnum ;; d fixnum ;; width fixnum ;; height fixnum ;; width_return fixnum ;; height_return )( fixnum "XQueryBestCursor")) (defentry XQueryBestSize( fixnum ;; display fixnum ;; class fixnum ;; which_screen fixnum ;; width fixnum ;; height fixnum ;; width_return fixnum ;; height_return )( fixnum "XQueryBestSize")) (defentry XQueryBestStipple( fixnum ;; display fixnum ;; which_screen fixnum ;; width fixnum ;; height fixnum ;; width_return fixnum ;; height_return )( fixnum "XQueryBestStipple")) (defentry XQueryBestTile( fixnum ;; display fixnum ;; which_screen fixnum ;; width fixnum ;; height fixnum ;; width_return fixnum ;; height_return )( fixnum "XQueryBestTile")) (defentry XQueryColor( fixnum ;; display fixnum ;; colormap fixnum ;; def_in_out )( void "XQueryColor")) (defentry XQueryColors( fixnum ;; display fixnum ;; colormap fixnum ;; defs_in_out fixnum ;; ncolors )( void "XQueryColors")) (defentry XQueryExtension( fixnum ;; display object ;; name fixnum ;; major_opcode_return fixnum ;; first_event_return fixnum ;; first_error_return )( fixnum "XQueryExtension")) ;;fix (defentry XQueryKeymap( fixnum ;; display fixnum ;; keys_return )( void "XQueryKeymap")) (defentry XQueryPointer( fixnum ;; display fixnum ;; w fixnum ;; root_return fixnum ;; child_return fixnum ;; root_x_return fixnum ;; root_y_return fixnum ;; win_x_return fixnum ;; win_y_return fixnum ;; mask_return )( fixnum "XQueryPointer")) (defentry XQueryTextExtents( fixnum ;; display fixnum ;; font_ID object ;; string fixnum ;; nchars fixnum ;; direction_return fixnum ;; font_ascent_return fixnum ;; font_descent_return fixnum ;; overall_return )( void "XQueryTextExtents")) (defentry XQueryTextExtents16( fixnum ;; display fixnum ;; font_ID fixnum ;; string fixnum ;; nchars fixnum ;; direction_return fixnum ;; font_ascent_return fixnum ;; font_descent_return fixnum ;; overall_return )( void "XQueryTextExtents16")) (defentry XQueryTree( fixnum ;; display fixnum ;; w fixnum ;; root_return fixnum ;; parent_return fixnum ;; children_return fixnum ;; nchildren_return )( fixnum "XQueryTree")) (defentry XRaiseWindow( fixnum ;; display fixnum ;; w )( void "XRaiseWindow")) (defentry XReadBitmapFile( fixnum ;; display fixnum ;; d object ;; filename fixnum ;; width_return fixnum ;; height_return fixnum ;; bitmap_return fixnum ;; x_hot_return fixnum ;; y_hot_return )( fixnum "XReadBitmapFile")) (defentry XRebindKeysym( fixnum ;; display fixnum ;; keysym fixnum ;; list fixnum ;; mod_count object ;; string fixnum ;; bytes_string )( void "XRebindKeysym")) (defentry XRecolorCursor( fixnum ;; display fixnum ;; cursor fixnum ;; foreground_color fixnum ;; background_color )( void "XRecolorCursor")) (defentry XRefreshKeyboardMapping( fixnum ;; event_map )( void "XRefreshKeyboardMapping")) (defentry XRemoveFromSaveSet( fixnum ;; display fixnum ;; w )( void "XRemoveFromSaveSet")) (defentry XRemoveHost( fixnum ;; display fixnum ;; host )( void "XRemoveHost")) (defentry XRemoveHosts( fixnum ;; display fixnum ;; hosts fixnum ;; num_hosts )( void "XRemoveHosts")) (defentry XReparentWindow( fixnum ;; display fixnum ;; w fixnum ;; parent fixnum ;; x fixnum ;; y )( void "XReparentWindow")) (defentry XResetScreenSaver( fixnum ;; display )( void "XResetScreenSaver")) (defentry XResizeWindow( fixnum ;; display fixnum ;; w fixnum ;; width fixnum ;; height )( void "XResizeWindow")) (defentry XRestackWindows( fixnum ;; display fixnum ;; windows fixnum ;; nwindows )( void "XRestackWindows")) (defentry XRotateBuffers( fixnum ;; display fixnum ;; rotate )( void "XRotateBuffers")) (defentry XRotateWindowProperties( fixnum ;; display fixnum ;; w fixnum ;; properties fixnum ;; num_prop fixnum ;; npositions )( void "XRotateWindowProperties")) (defentry XScreenCount( fixnum ;; display )( fixnum "XScreenCount")) (defentry XSelectInput( fixnum ;; display fixnum ;; w fixnum ;; event_mask )( void "XSelectInput")) (defentry XSendEvent( fixnum ;; display fixnum ;; w fixnum ;; propagate fixnum ;; event_mask fixnum ;; event_send )( fixnum "XSendEvent")) (defentry XSetAccessControl( fixnum ;; display fixnum ;; mode )( void "XSetAccessControl")) (defentry XSetArcMode( fixnum ;; display fixnum ;; gc fixnum ;; arc_mode )( void "XSetArcMode")) (defentry XSetBackground( fixnum ;; display fixnum ;; gc fixnum ;; background )( void "XSetBackground")) (defentry XSetClipMask( fixnum ;; display fixnum ;; gc fixnum ;; fixnum )( void "XSetClipMask")) (defentry XSetClipOrigin( fixnum ;; display fixnum ;; gc fixnum ;; clip_x_origin fixnum ;; clip_y_origin )( void "XSetClipOrigin")) (defentry XSetClipRectangles( fixnum ;; display fixnum ;; gc fixnum ;; clip_x_origin fixnum ;; clip_y_origin fixnum ;; rectangles fixnum ;; n fixnum ;; ordering )( void "XSetClipRectangles")) (defentry XSetCloseDownMode( fixnum ;; display fixnum ;; close_mode )( void "XSetCloseDownMode")) (defentry XSetCommand( fixnum ;; display fixnum ;; w fixnum ;; argv fixnum ;; argc )( void "XSetCommand")) (defentry XSetDashes( fixnum ;; display fixnum ;; gc fixnum ;; dash_offset object ;; dash_list fixnum ;; n )( void "XSetDashes")) (defentry XSetFillRule( fixnum ;; display fixnum ;; gc fixnum ;; fill_rule )( void "XSetFillRule")) (defentry XSetFillStyle( fixnum ;; display fixnum ;; gc fixnum ;; fill_style )( void "XSetFillStyle")) (defentry XSetFont( fixnum ;; display fixnum ;; gc fixnum ;; font )( void "XSetFont")) (defentry XSetFontPath( fixnum ;; display fixnum ;; directories fixnum ;; ndirs )( void "XSetFontPath")) (defentry XSetForeground( fixnum ;; display fixnum ;; gc fixnum ;; foreground )( void "XSetForeground")) (defentry XSetFunction( fixnum ;; display fixnum ;; gc fixnum ;; function )( void "XSetFunction")) (defentry XSetGraphicsExposures( fixnum ;; display fixnum ;; gc fixnum ;; graphics_exposures )( void "XSetGraphicsExposures")) (defentry XSetIconName( fixnum ;; display fixnum ;; w object ;; icon_name )( void "XSetIconName")) (defentry XSetInputFocus( fixnum ;; display fixnum ;; focus fixnum ;; revert_to fixnum ;; fixnum )( void "XSetInputFocus")) (defentry XSetLineAttributes( fixnum ;; display fixnum ;; gc fixnum ;; line_width fixnum ;; line_style fixnum ;; cap_style fixnum ;; join_style )( void "XSetLineAttributes")) (defentry XSetModifierMapping( fixnum ;; display fixnum ;; modmap )( fixnum "XSetModifierMapping")) (defentry XSetPlaneMask( fixnum ;; display fixnum ;; gc fixnum ;; plane_mask )( void "XSetPlaneMask")) (defentry XSetPointerMapping( fixnum ;; display object ;; map fixnum ;; nmap )( fixnum "XSetPointerMapping")) (defentry XSetScreenSaver( fixnum ;; display fixnum ;; intout fixnum ;; interval fixnum ;; prefer_blanking fixnum ;; allow_exposures )( void "XSetScreenSaver")) (defentry XSetSelectionOwner( fixnum ;; display fixnum ;; selection fixnum ;; owner fixnum ;; fixnum )( void "XSetSelectionOwner")) (defentry XSetState( fixnum ;; display fixnum ;; gc fixnum ;; foreground fixnum ;; background fixnum ;; function fixnum ;; plane_mask )( void "XSetState")) (defentry XSetStipple( fixnum ;; display fixnum ;; gc fixnum ;; stipple )( void "XSetStipple")) (defentry XSetSubwindowMode( fixnum ;; display fixnum ;; gc fixnum ;; subwindow_mode )( void "XSetSubwindowMode")) (defentry XSetTSOrigin( fixnum ;; display fixnum ;; gc fixnum ;; ts_x_origin fixnum ;; ts_y_origin )( void "XSetTSOrigin")) (defentry XSetTile( fixnum ;; display fixnum ;; gc fixnum ;; tile )( void "XSetTile")) (defentry XSetWindowBackground( fixnum ;; display fixnum ;; w fixnum ;; background_pixel )( void "XSetWindowBackground")) (defentry XSetWindowBackgroundPixmap( fixnum ;; display fixnum ;; w fixnum ;; background_pixmap )( void "XSetWindowBackgroundPixmap")) (defentry XSetWindowBorder( fixnum ;; display fixnum ;; w fixnum ;; border_pixel )( void "XSetWindowBorder")) (defentry XSetWindowBorderPixmap( fixnum ;; display fixnum ;; w fixnum ;; border_pixmap )( void "XSetWindowBorderPixmap")) (defentry XSetWindowBorderWidth( fixnum ;; display fixnum ;; w fixnum ;; width )( void "XSetWindowBorderWidth")) (defentry XSetWindowColormap( fixnum ;; display fixnum ;; w fixnum ;; colormap )( void "XSetWindowColormap")) (defentry XStoreBuffer( fixnum ;; display object ;; bytes fixnum ;; nbytes fixnum ;; buffer )( void "XStoreBuffer")) (defentry XStoreBytes( fixnum ;; display object ;; bytes fixnum ;; nbytes )( void "XStoreBytes")) (defentry XStoreColor( fixnum ;; display fixnum ;; colormap fixnum ;; color )( void "XStoreColor")) (defentry XStoreColors( fixnum ;; display fixnum ;; colormap fixnum ;; color fixnum ;; ncolors )( void "XStoreColors")) (defentry XStoreName( fixnum ;; display fixnum ;; w object ;; window_name )( void "XStoreName")) (defentry XStoreNamedColor( fixnum ;; display fixnum ;; colormap object ;; color fixnum ;; pixel fixnum ;; flags )( void "XStoreNamedColor")) (defentry XSync( fixnum ;; display fixnum ;; discard )( void "XSync")) (defentry XTextExtents( fixnum ;; font_struct object ;; string fixnum ;; nchars fixnum ;; direction_return fixnum ;; font_ascent_return fixnum ;; font_descent_return fixnum ;; overall_return )( void "XTextExtents")) (defentry XTextExtents16( fixnum ;; font_struct fixnum ;; string fixnum ;; nchars fixnum ;; direction_return fixnum ;; font_ascent_return fixnum ;; font_descent_return fixnum ;; overall_return )( void "XTextExtents16")) (defentry XTextWidth( fixnum ;; font_struct object ;; string fixnum ;; count )( fixnum "XTextWidth")) (defentry XTextWidth16( fixnum ;; font_struct fixnum ;; string fixnum ;; count )( fixnum "XTextWidth16")) (defentry XTranslateCoordinates( fixnum ;; display fixnum ;; src_w fixnum ;; dest_w fixnum ;; src_x fixnum ;; src_y fixnum ;; dest_x_return fixnum ;; dest_y_return fixnum ;; child_return )( fixnum "XTranslateCoordinates")) (defentry XUndefineCursor( fixnum ;; display fixnum ;; w )( void "XUndefineCursor")) (defentry XUngrabButton( fixnum ;; display fixnum ;; button fixnum ;; modifiers fixnum ;; grab_window )( void "XUngrabButton")) (defentry XUngrabKey( fixnum ;; display fixnum ;; keycode fixnum ;; modifiers fixnum ;; grab_window )( void "XUngrabKey")) (defentry XUngrabKeyboard( fixnum ;; display fixnum ;; fixnum )( void "XUngrabKeyboard")) (defentry XUngrabPointer( fixnum ;; display fixnum ;; fixnum )( void "XUngrabPointer")) (defentry XUngrabServer( fixnum ;; display )( void "XUngrabServer")) (defentry XUninstallColormap( fixnum ;; display fixnum ;; colormap )( void "XUninstallColormap")) (defentry XUnloadFont( fixnum ;; display fixnum ;; font )( void "XUnloadFont")) (defentry XUnmapSubwindows( fixnum ;; display fixnum ;; w )( void "XUnmapSubwindows")) (defentry XUnmapWindow( fixnum ;; display fixnum ;; w )( void "XUnmapWindow")) (defentry XVendorRelease( fixnum ;; display )( fixnum "XVendorRelease")) (defentry XWarpPointer( fixnum ;; display fixnum ;; src_w fixnum ;; dest_w fixnum ;; src_x fixnum ;; src_y fixnum ;; src_width fixnum ;; src_height fixnum ;; dest_x fixnum ;; dest_y )( void "XWarpPointer")) (defentry XWidthMMOfScreen( fixnum ;; screen )( fixnum "XWidthMMOfScreen")) (defentry XWidthOfScreen( fixnum ;; screen )( fixnum "XWidthOfScreen")) (defentry XWindowEvent( fixnum ;; display fixnum ;; w fixnum ;; event_mask fixnum ;; event_return )( void "XWindowEvent")) (defentry XWriteBitmapFile( fixnum ;; display object ;; filename fixnum ;; bitmap fixnum ;; width fixnum ;; height fixnum ;; x_hot fixnum ;; y_hot )( fixnum "XWriteBitmapFile")) ;;;;;;;;;problems ;;(defentry fixnum (int Synchronize( ;; fixnum ;; display ;; fixnum ;; onoff ;;))()()) ;;(defentry fixnum (int SetAfterFunction( ;; fixnum ;; display ;; fixnum (int ( fixnum ;; display ;; ) ;; procedure ;;))()()) ;;(defentry void XPeekIfEvent( ;; fixnum ;; display ;; fixnum ;; event_return ;; fixnum (int ( fixnum ;; display ;; fixnum ;; event ;; object ;; arg ;; ) ;; predicate ;; object ;; arg ;;)()) ;;(defentry fixnum XCheckIfEvent( ;; fixnum ;; display ;; fixnum ;; event_return ;; fixnum (int ( fixnum ;; display ;; fixnum ;; event ;; object ;; arg ;; ) ;; predicate ;; object ;; arg ;;)()) ;;(defentry void XIfEvent( ;; fixnum ;; display ;; fixnum ;; event_return ;; fixnum (int ( fixnum ;; display ;; fixnum ;; event ;; object ;; arg ;; ) ;; predicate ;; object ;; arg ;;)()) gcl-2.6.14/xgcl-2/gcl_draw.lsp0000644000175000017500000011265614360276512014404 0ustar cammcamm; draw.lsp Gordon S. Novak Jr. ; 06 Dec 07 ; Functions to make drawings interactively ; Copyright (c) 2007 Gordon S. Novak Jr. and The University of Texas at Austin. ; 11 Nov 94; 05 Jan 95; 15 Jan 98; 09 Feb 99; 04 Dec 00; 28 Feb 02; 05 Jan 04 ; 27 Jan 06 ; See the file gnu.license ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu ; Use (draw 'foo) to make a drawing named foo. ; When finished with the drawing, give commands "Origin - to zero", "Program". ; This will produce a program (DRAW-FOO w x y) to make the drawing. ; The LaTex command will print Latex input to make the drawing ; (but LaTex cannot draw things as well as the draw program). ; (draw-output &optional names) will save things in a file for later. ; The small square in the drawing menu is a "button" for picture menus. ; If buttons are used, a picmenu-spec will be produced with the program. (defvar *draw-window* nil) (defvar *draw-window-width* 600) (defvar *draw-window-height* 600) (defvar *draw-leave-window* nil) ; t to leave window displayed at end (defvar *draw-menu-set* nil) (defvar *draw-zero-vector* '(0 0) ) (defvar *draw-latex-factor* 1) ; multiplier from pixels to LaTex (defvar *draw-snap-flag* t) (defvar *draw-objects* nil) (defvar *draw-latex-mode* nil) (glispglobals (*draw-window* window) ) (defmacro draw-descr (name) `(get ,name 'draw-descr)) (glispobjects (draw-desc (listobject (name symbol) (objects (listof draw-object)) (offset vector) (size vector)) prop ((fnname draw-desc-fnname) (refpt draw-desc-refpt)) msg ((draw draw-desc-draw) (snap draw-desc-snap) (find draw-desc-find) (delete draw-desc-delete)) ) (draw-object (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) default ((linewidth 1)) prop ((region ((virtual region with start = offset size = size))) (vregion ((virtual region with start = vstart size = vsize))) (vstart ((virtual vector with x = (min (x offset) ((x offset) + (x size))) - 2 y = (min (y offset) ((y offset) + (y size))) - 2))) (vsize ((virtual vector with x = (abs (x size)) + 4 y = (abs (y size)) + 4))) ) msg ((erase draw-object-erase) (draw draw-object-draw) (snap draw-object-snap) (selectedp draw-object-selectedp) (move draw-object-move)) ) (draw-line (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) prop ((line ((virtual line-segment with p1 = offset p2 = (offset + size))))) msg ((draw draw-line-draw) (snap draw-line-snap) (selectedp draw-line-selectedp) ) supers (draw-object) ) (draw-arrow (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) prop ((line ((virtual line-segment with p1 = offset p2 = (offset + size))))) msg ((draw draw-arrow-draw) (snap draw-line-snap) (selectedp draw-line-selectedp) ) supers (draw-object) ) (draw-box (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-box-draw) (snap draw-box-snap) (selectedp draw-box-selectedp) ) supers (draw-object) ) (draw-rcbox (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-rcbox-draw) (snap draw-rcbox-snap) (selectedp draw-rcbox-selectedp) ) supers (draw-object) ) (draw-erase (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-erase-draw) (snap draw-no-snap) (selectedp draw-erase-selectedp) ) supers (draw-object) ) (draw-circle (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) prop ((radius ((x size) / 2)) (center (offset + size / 2))) msg ((draw draw-circle-draw) (snap draw-circle-snap) (selectedp draw-circle-selectedp) ) supers (draw-object) ) (draw-ellipse (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) prop ((radiusx ((x size) / 2)) (radiusy ((y size) / 2)) (radius ((max radiusx radiusy))) (center (offset + size / 2)) (delta ((sqrt (abs (radiusx ^ 2 - radiusy ^ 2))))) (p1 ((if (radiusx > radiusy) ; 05 Jan 04 (a vector x = (x center) - delta y = (y center)) (a vector x = (x center) y = (y center) - delta)))) (p2 ((if (radiusx > radiusy) (a vector x = (x center) + delta y = (y center)) (a vector x = (x center) y = (y center) + delta)))) ) msg ((draw draw-ellipse-draw) (snap draw-ellipse-snap) (selectedp draw-ellipse-selectedp) ) supers (draw-object) ) (draw-dot (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-dot-draw) (snap draw-dot-snap) (selectedp draw-button-selectedp) ) supers (draw-object) ) (draw-button (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-button-draw) (snap draw-dot-snap) (selectedp draw-button-selectedp) ) supers (draw-object) ) (draw-text (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-text-draw) (snap draw-no-snap) (selectedp draw-text-selectedp) ) supers (draw-object) ) ; null object: no image, cannot be selected. (draw-null (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-null-draw) (snap draw-no-snap) (selectedp draw-null-selectedp) ) supers (draw-object) ) (draw-refpt (listobject (offset vector) (size vector) (contents anything) (linewidth integer)) msg ((draw draw-refpt-draw) (snap draw-refpt-snap) (selectedp draw-refpt-selectedp) ) supers (draw-object) ) ; multi-item drawing group (draw-multi (listobject (offset vector) (size vector) (contents (listof draw-object)) (linewidth integer)) msg ((draw draw-multi-draw) (snap draw-no-snap) (selectedp draw-multi-selectedp) ) supers (draw-object) ) ) ; glispobjects ; 05 Jan 04 ; Get drawing description associated with name (gldefun draw-desc ((name symbol)) (result draw-desc) (let ((dd draw-desc)) (dd = (draw-descr name)) (if ~ dd (progn (dd = (a draw-desc with name = name)) (setf (draw-descr name) dd))) dd)) ; Make a window to draw in. (setf (glfnresulttype 'draw-window) 'window) (defun draw-window () (or *draw-window* (setq *draw-window* (window-create *draw-window-width* *draw-window-height* "Draw window"))) ) ; 09 Sep 92; 11 Sep 92; 14 Sep 92; 16 Sep 92; 21 Oct 92; 21 May 93; 17 Dec 93 ; 05 Jan 04 (gldefun draw ((name symbol)) (let (w dd done sel (redraw t) (new draw-object)) (w = (draw-window)) (open w) (or *draw-menu-set* (draw-init-menus)) (dd = (draw-desc name)) (unless (member name *draw-objects*) (setq *draw-objects* (nconc *draw-objects* (list name)))) (draw dd w) (while ~ done do (sel = (menu-set-select *draw-menu-set* redraw)) (redraw = nil) (case (menu-name sel) (command (case (port sel) (done (done = t)) (move (draw-desc-move dd w)) (delete (draw-desc-delete dd w)) (copy (draw-desc-copy dd w)) (redraw (clear w) (setq redraw t) (draw dd w)) (origin (draw-desc-origin dd w) (clear w) (setq redraw t) (draw dd w)) (program (draw-desc-program dd)) (latex (draw-desc-latex dd)) (latexmode (setq *draw-latex-mode* (not *draw-latex-mode*)) (format t "Latex Mode is now ~A~%" *draw-latex-mode*)) )) (draw (new = nil) (case (port sel) (rectangle (new = (draw-box-get dd w))) (rcbox (new = (draw-rcbox-get dd w))) (circle (new = (draw-circle-get dd w))) (ellipse (new = (draw-ellipse-get dd w))) (line (new = (draw-line-get dd w))) (arrow (new = (draw-arrow-get dd w))) (dot (new = (draw-dot-get dd w))) (erase (new = (draw-erase-get dd w))) (button (new = (draw-button-get dd w))) (text (new = (draw-text-get dd w))) (refpt (new = (draw-refpt-get dd w)))) (if new (progn ((offset new) _- (offset dd)) ((objects dd) _+ new) (draw new w (offset dd))))) (background nil)) ) (setf (draw-descr name) dd) (unless *draw-leave-window* (close w)) name )) ; 06 Dec 07 ; Copy a draw description to another name (defun copy-draw-desc (from to) (let (old) (setq old (copy-tree (get from 'draw-descr))) (setf (get to 'draw-descr) (cons (car old) (cons to (cddr old))) ) )) ; 09 Sep 92 (gldefun draw-desc-draw ((dd draw-desc) (w window)) (let ( (off (offset dd)) ) (clear w) (for obj in (objects dd) (draw obj w off)) (force-output w) )) ; 11 Sep 92; 12 Sep 92; 06 Oct 92; 05 Jan 04 ; Find a draw-object such that point p selects it (gldefun draw-desc-selected ((dd draw-desc) (p vector)) (result draw-object) (let (objs objsb obj) (objs = (for obj in objects when (selectedp obj p (offset dd)) collect obj)) (if objs (if (null (rest objs)) (obj = (first objs)) (progn (objsb = (for z in objs when (member (first z) '(draw-button draw-dot)) collect z)) (if (and objsb (null (rest objsb))) (obj = (first objsb)))) ) ) obj)) ; 11 Sep 92; 12 Sep 92; 13 Sep 92; 05 Jan 04 ; Find a draw-object such that point p selects it (gldefun draw-desc-find ((dd draw-desc) (w window) &optional (crossflg boolean)) (result draw-object) (let (p obj) (while ~ obj do (p = (if crossflg (draw-get-cross dd w) (draw-get-crosshairs dd w))) (obj = (draw-desc-selected dd p)) ) obj)) ; 15 Sep 92 (gldefun draw-get-cross ((dd draw-desc) (w window)) (result vector) (draw-desc-snap dd (window-get-cross w))) ; 15 Sep 92 (gldefun draw-get-crosshairs ((dd draw-desc) (w window)) (result vector) (draw-desc-snap dd (window-get-crosshairs w))) ; 12 Sep 92; 14 Sep 92; 06 Oct 92 ; Delete selected object (gldefun draw-desc-delete ((dd draw-desc) (w window)) (let (obj) (obj = (draw-desc-find dd w t)) (erase obj w (offset dd)) ((objects dd) _- obj) )) ; 12 Sep 92; 07 Oct 92 ; Copy selected object (gldefun draw-desc-copy ((dd draw-desc) (w window)) (let (obj (objb draw-object)) (obj = (draw-desc-find dd w)) (objb = (copy-tree obj)) (draw-get-object-pos objb w) ((offset objb) _- (offset dd)) (draw objb w (offset dd)) (force-output w) ((objects dd) _+ objb) )) ; 12 Sep 92; 13 Sep 92; 07 Oct 92; 05 Jan 04 ; Move selected object (gldefun draw-desc-move ((dd draw-desc) (w window)) (let (obj) (if (obj = (draw-desc-find dd w)) (move obj w (offset dd))) )) ; 14 Sep 92; 28 Feb 02; 05 Jan 04; 27 Jan 06 ; Reset origin of object group (gldefun draw-desc-origin ((dd draw-desc) (w window)) (let (sel) (draw-desc-bounds dd) (sel = (menu '(("To zero" . tozero) ("Select" . select)))) (if (sel == 'select) ((offset dd) = (get-box-position w (x (size dd)) (y (size dd)))) (if (sel == 'tozero) ((offset dd) = (a vector x 0 y 0)) ) ))) ; 14 Sep 92 ; Compute boundaries of objects in a drawing; set offset and size of ; the draw-desc and reset offsets of items relative to it. (gldefun draw-desc-bounds ((dd draw-desc)) (let ((xmin 9999) (ymin 9999) (xmax 0) (ymax 0) basev) (for obj in objects do (xmin = (min xmin (x (offset obj)) ((x (offset obj)) + (x (size obj))))) (ymin = (min ymin (y (offset obj)) ((y (offset obj)) + (y (size obj))))) (xmax = (max xmax (x (offset obj)) ((x (offset obj)) + (x (size obj))))) (ymax = (max ymax (y (offset obj)) ((y (offset obj)) + (y (size obj))))) ) ((x (size dd)) = (xmax - xmin)) ((y (size dd)) = (ymax - ymin)) (basev = (a vector with x = xmin y = ymin)) ((offset dd) = basev) (for obj in objects do ((offset obj) _- basev)) )) ; 14 Sep 92; 16 Sep 92; 19 Dec 93; 15 Jan 98; 06 Dec 07 ; Produce LaTex output for object group. ; LaTex can only *approximately* reproduce the picture. (gldefun draw-desc-latex ((dd draw-desc)) (let (base bx by sx sy) (format t " \\begin{picture}(~5,0F,~5,0F)(0,0)~%" (* (x (size dd)) *draw-latex-factor*) (* (y (size dd)) *draw-latex-factor*) ) (for obj in (objects dd) do (base = (offset dd) + (offset obj)) (bx = (x base) * *draw-latex-factor*) (by = (y base) * *draw-latex-factor*) (sx = (x (size obj)) * *draw-latex-factor*) (sy = (y (size obj)) * *draw-latex-factor*) (case (first obj) (draw-line (latex-line (x base) (y base) ((x base) + sx) ((y base) + sy))) (draw-arrow (latex-line (x base) (y base) ((x base) + sx) ((y base) + sy) t) ) (draw-box (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" bx by sx sy)) (draw-rcbox (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" (bx + sx / 2) (by + sy / 2) sx sy)) (draw-circle (format t " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%" (bx + sx / 2) (by + sy / 2) sx)) (draw-ellipse (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" (bx + sx / 2) (by + sy / 2) sx sy)) (draw-button (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" bx by sx sy)) (draw-erase ) (draw-dot (format t " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%" (bx + sx / 2) (by + sy / 2) sx)) (draw-text (format t " \\put(~5,0F,~5,0F) {~A}~%" bx (by + 4 * *draw-latex-factor*) (contents obj)) ) ) ) (format t " \\end{picture}~%") )) ; 14 Sep 92; 15 Sep 92; 16 Sep 92; 05 Oct 92; 17 Dec 93; 21 Dec 93; 28 Feb 02 ; 05 Jan 04 ; Produce program to draw object group (gldefun draw-desc-program ((dd draw-desc)) (let (base bx by sx sy tox toy r rx ry s code fncode fnname cd) (code = (for obj in (objects dd) when (cd = (progn (base = (offset dd) + (offset obj) - (refpt dd)) (bx = (x base)) (by = (y base)) (sx = (x (size obj))) (sy = (y (size obj))) (tox = bx + sx) (toy = by + sy) (if ((car obj) == 'draw-circle) (r = (x (size obj)) / 2)) (if ((car obj) == 'draw-ellipse) (progn (rx = (x (size obj)) / 2) (ry = (y (size obj)) / 2))) (draw-optimize (case (first obj) (draw-line `(window-draw-line-xy w (+ x ,bx) (+ y ,by) (+ x ,tox) (+ y ,toy))) (draw-arrow `(window-draw-arrow-xy w (+ x ,bx) (+ y ,by) (+ x ,tox) (+ y ,toy))) (draw-box `(window-draw-box-xy w (+ x ,bx) (+ y ,by) ,sx ,sy)) (draw-rcbox `(window-draw-rcbox-xy w (+ x ,bx) (+ y ,by) ,sx ,sy 8)) (draw-circle `(window-draw-circle-xy w (+ x ,(+ r bx)) (+ y ,(+ r by)) ,r)) (draw-ellipse `(window-draw-ellipse-xy w (+ x ,(+ rx bx)) (+ y ,(+ ry by)) ,rx ,ry)) ((draw-button draw-refpt) nil) ; let picmenu draw the buttons (draw-erase `(window-erase-area-xy w (+ x ,bx) (+ y ,by) ,sx ,sy)) (draw-dot `(window-draw-dot-xy w (+ x ,(+ 2 bx)) (+ y ,(+ 2 by)))) (draw-text (s = (stringify (contents obj))) `(window-printat-xy w ,s (+ x ,bx) (+ y ,by))) )) )) collect cd)) (fncode = (cons 'lambda (cons (list 'w 'x 'y) (nconc code (list (list 'window-force-output 'w)))))) (fnname = (fnname dd)) (setf (symbol-function fnname) fncode) (format t "Constructed program (~A w x y)~%" fnname) (draw-desc-picmenu dd) )) ; 21 Dec 93 ; Optimize code if GLISP is present (defun draw-optimize (x) (if (fboundp 'glunwrap) (glunwrap x nil) x)) ; 14 Sep 92 (gldefun draw-desc-fnname ((dd draw-desc)) (intern (concatenate 'string "DRAW-" (symbol-name (name dd)))) ) ; 14 Sep 92; 06 Oct 92; 08 Apr 93; 28 Feb 02; 05 Jan 04 ; Produce a picmenu-spec from the buttons of a drawing description (gldefun draw-desc-picmenu ((dd draw-desc)) (let (buttons) (buttons = (for obj in (objects dd) when ((first obj) == 'draw-button) collect (list (contents obj) ((a vector x 2 y 2) + (offset obj) + (offset dd) )) ) ) (if buttons (setf (get (name dd) 'picmenu-spec) (list 'picmenu-spec (x (size dd)) (y (size dd)) buttons t (fnname dd) '9x15))) )) ; 15 Sep 92; 05 Jan 04 (gldefun draw-desc-snap ((dd draw-desc) (p vector)) (result vector) (let (psnap obj (objs (objects dd)) ) (if *draw-snap-flag* (while objs and ~ psnap do (obj = (pop objs)) (psnap = (draw-object-snap obj p (offset dd))) ) ) (or psnap p) )) ; 10 Sep 92; 12 Sep 92 ; Move specified object (gldefun draw-object-move ((d draw-object) (w window) (off vector)) (let () (erase d w off) (draw-get-object-pos d w) ((offset d) _- off) (draw d w off) (force-output w) )) ; 12 Sep 92; 13 Sep 92; 15 Sep 92 ; Draw an object at specified (x y) by calling its drawing function (defun draw-object-draw-at (w x y d) (setf (second d) (list x y)) (draw-object-draw d w *draw-zero-vector*) ) ; 15 Sep 92 ; Simulate glsend of draw message to an object (defun draw-object-draw (d w off) (funcall (glmethod (car d) 'draw) d w off) ) ; 15 Sep 92 ; Simulate glsend of snap message to an object (defun draw-object-snap (d p off) (funcall (glmethod (car d) 'snap) d p off) ) ; 15 Sep 92 ; Simulate glsend of selectedp message to an object (defun draw-object-selectedp (d w off) (funcall (glmethod (car d) 'selectedp) d w off) ) ; 12 Sep 92; 07 Oct 92; 28 Feb 02; 05 Jan 04; 06 Dec 07 (gldefun draw-get-object-pos ((d draw-object) (w window)) (window-get-icon-position w (if ((first d) == 'draw-text) #'draw-text-draw-outline #'draw-object-draw-at) (list d)) ) ; 10 Sep 92; 15 Sep 92; 05 Jan 04 (gldefun draw-object-erase ((d draw-object) (w window) (off vector)) (let () (if ((first d) <> 'draw-erase) (progn (set-xor w) (draw d w off) (unset w)) ))) ; 09 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00 (gldefun draw-line-draw ((d draw-line) (w window) (off vector)) (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) ) (draw-line-xy w (x from) (y from) (x to) (y to)) )) ; 11 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00 (gldefun draw-arrow-draw ((d draw-arrow) (w window) (off vector)) (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) ) (draw-arrow-xy w (x from) (y from) (x to) (y to)) )) ; 09 Sep 92; 10 Sep 92; 12 Sep 92 (gldefun draw-line-selectedp ((d draw-line) (pt vector) (off vector)) (let ((ptp (pt - off))) (and (contains? (vregion d) ptp) ((distance (line d) ptp) < 5) ) )) ; 09 Sep 92; 10 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04 (gldefun draw-line-get ((dd draw-desc) (w window)) (let (from to) (from = (draw-get-crosshairs dd w)) (to = (if *draw-latex-mode* (window-get-latex-position w (x from) (y from) nil) (draw-desc-snap dd (window-get-line-position w (x from) (y from))))) (a draw-line with offset = from size = (to - from)) )) ; 11 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04 (gldefun draw-arrow-get ((dd draw-desc) (w window)) (let (from to) (from = (draw-get-crosshairs dd w)) (to = (if *draw-latex-mode* (window-get-latex-position w (x from) (y from) nil) (draw-desc-snap dd (window-get-line-position w (x from) (y from))))) (a draw-arrow with offset = from size = (to - from)) )) ; 09 Sep 92 (gldefun draw-box-draw ((d draw-box) (w window) (off vector)) (draw-box w (off + (offset d)) (size d)) ) ; 09 Sep 92; 11 Sep 92 (gldefun draw-box-selectedp ((d draw-box) (p vector) (off vector)) (let ((pt (p - off))) (or (and ((y pt) < (top (vregion d)) + 5) ((y pt) > (bottom (vregion d)) - 5) (or ((abs (x pt) - (left (vregion d))) < 5) ((abs (x pt) - (right (vregion d))) < 5))) (and ((x pt) < (right (vregion d)) + 5) ((x pt) > (left (vregion d)) - 5) (or ((abs (y pt) - (top (vregion d))) < 5) ((abs (y pt) - (bottom (vregion d))) < 5))) ) )) ; 11 Sep 92 (gldefun draw-box-get ((dd draw-desc) (w window)) (let (box) (box = (window-get-region w)) (a draw-box with offset = (start box) size = (size box)) )) ; (dotimes (i 10) (print (draw-box-selectedp db (window-get-point dw)))) ; 16 Sep 92 (gldefun draw-rcbox-draw ((d draw-box) (w window) (off vector)) (draw-rcbox-xy w ((x off) + (x (offset d))) ((y off) + (y (offset d))) (x (size d)) (y (size d)) 8) ) ; 16 Sep 92 (gldefun draw-rcbox-selectedp ((d draw-box) (p vector) (off vector)) (let ((pt (p - off))) (or (and ((y pt) < (top (vregion d)) - 3) ((y pt) > (bottom (vregion d)) + 3) (or ((abs (x pt) - (left (vregion d))) < 5) ((abs (x pt) - (right (vregion d))) < 5))) (and ((x pt) < (right (vregion d)) - 3) ((x pt) > (left (vregion d)) + 3) (or ((abs (y pt) - (top (vregion d))) < 5) ((abs (y pt) - (bottom (vregion d))) < 5))) ) )) ; 16 Sep 92 (gldefun draw-rcbox-get ((dd draw-desc) (w window)) (let (box) (box = (window-get-region w)) (a draw-rcbox with offset = (start box) size = (size box)) )) ; 09 Sep 92 (gldefun draw-circle-draw ((d draw-circle) (w window) (off vector)) (draw-circle w (off + (center d)) (radius d)) ) ; 09 Sep 92; 11 Sep 92; 17 Sep 92 (gldefun draw-circle-selectedp ((d draw-circle) (p vector) (off vector)) ((abs (radius d) - (magnitude ((center d) + off) - p)) < 5) ) ; 11 Sep 92; 15 Sep 92 (gldefun draw-circle-get ((dd draw-desc) (w window)) (let (cir cent) (cent = (draw-get-crosshairs dd w)) (cir = (window-get-circle w cent)) (a draw-circle with offset = (a vector with x = ( (x (center cir)) - (radius cir) ) y = ( (y (center cir)) - (radius cir) )) size = (a vector with x = 2 * (radius cir) y = 2 * (radius cir))) )) ; 11 Sep 92 (gldefun draw-ellipse-draw ((d draw-ellipse) (w window) (off vector)) (let ((c (off + (center d)))) (draw-ellipse-xy w (x c) (y c) (radiusx d) (radiusy d)) )) ; 11 Sep 92; 15 Sep 92; 17 Sep 92 ; Uses the fact that sum of distances from foci is constant. (gldefun draw-ellipse-selectedp ((d draw-ellipse) (p vector) (off vector)) (let ((pt (p - off))) ( (abs ( (magnitude ((p1 d) - pt)) + (magnitude ((p2 d) - pt)) ) - 2 * (radius d)) < 2) )) ; print out what the "boundary" of an ellipse looks like via selectedp (defun draw-test-ellipse-selectedp (e) (let ( (size (third e)) (offset (second e)) ) (dotimes (y (+ (cadr size) 10)) (dotimes (x (+ (car size) 10)) (princ (if (draw-ellipse-selectedp e (list (+ x (car offset) -5) (+ y (cadr offset) -5)) (list 0 0)) "T" " "))) (terpri)) )) ; 11 Sep 92 (gldefun draw-ellipse-get ((dd draw-desc) (w window)) (let (ell cent) (cent = (draw-get-crosshairs dd w)) (ell = (window-get-ellipse w cent)) (a draw-ellipse with offset = (a vector with x = ( (x (center ell)) - (x (halfsize ell)) ) y = ( (y (center ell)) - (y (halfsize ell)) )) size = (a vector with x = 2 * (x (halfsize ell)) y = 2 * (y (halfsize ell)))) )) ; 10 Sep 92 (gldefun draw-null-draw ((d draw-null) (w window) (off vector)) nil) ; 10 Sep 92; 11 Sep 92 (gldefun draw-null-selectedp ((d draw-null) (pt vector) (off vector)) nil) ; 11 Sep 92 (gldefun draw-button-draw ((d draw-button) (w window) (off vector)) (draw-box w (off + (offset d)) (a vector x = 4 y = 4)) ) ; 11 Sep 92 (gldefun draw-button-selectedp ((d draw-button) (p vector) (off vector)) (let ( (ptx (((x p) - (x off)) - (x (offset d)))) (pty (((y p) - (y off)) - (y (offset d)))) ) (and (ptx > -2) (ptx < 6) (pty > -2) (pty < 6) ) )) )) ; 11 Sep 92 (gldefun draw-button-get ((dd draw-desc) (w window)) (let (cent var) (princ "Enter button name: ") (var = (read)) (cent = (draw-get-crosshairs dd w)) (a draw-button with offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2)) size = (a vector with x = 4 y = 4) contents = var) )) ; 14 Sep 92 (gldefun draw-erase-draw ((d draw-box) (w window) (off vector)) (erase-area w (off + (offset d)) (size d)) ) ; 14 Sep 92 (gldefun draw-erase-selectedp ((d draw-box) (p vector) (off vector)) (let ((pt (p - off))) (contains? (region d) pt) )) ; 14 Sep 92 (gldefun draw-erase-get ((dd draw-desc) (w window)) (let (box) (box = (window-get-region w)) (a draw-erase with offset = (start box) size = (size box)) )) ; 11 Sep 92; 14 Sep 92 (gldefun draw-dot-draw ((d draw-dot) (w window) (off vector)) (window-draw-dot-xy w ((x off) + (x (offset d)) + 2) ((y off) + (y (offset d)) + 2) ) ) ; 11 Sep 92; 15 Sep 92 (gldefun draw-dot-get ((dd draw-desc) (w window)) (let (cent) (cent = (draw-get-crosshairs dd w)) (a draw-dot with offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2)) size = (a vector with x = 4 y = 4)) )) ; 17 Dec 93 (gldefun draw-refpt-draw ((d draw-refpt) (w window) (off vector)) (window-draw-crosshairs-xy w ((x off) + (x (offset d))) ((y off) + (y (offset d))) ) ) ; 17 Dec 93 (gldefun draw-refpt-selectedp ((d draw-button) (p vector) (off vector)) (let ( (ptx (((x p) - (x off)) - (x (offset d)))) (pty (((y p) - (y off)) - (y (offset d)))) ) (and (ptx > -3) (ptx < 3) (pty > -3) (pty < 3) ) )) ; 17 Dec 93; 05 Jan 04 (gldefun draw-refpt-get ((dd draw-desc) (w window)) (let (cent refpt) (if (refpt = (assoc 'draw-refpt (objects dd))) (progn (set-erase *draw-window*) (draw refpt *draw-window* (a vector with x = 0 y = 0)) (unset *draw-window*) ((objects dd) _- refpt) ) ) (cent = (draw-get-crosshairs dd w)) (a draw-refpt with offset = cent size = (a vector with x = 0 y = 0)) )) ; 17 Dec 93; 05 Jan 04 (gldefun draw-desc-refpt ((dd draw-desc)) (result vector) (let (refpt) (refpt = (assoc 'draw-refpt (objects dd))) (if refpt (offset refpt) (a vector x = 0 y = 0)) )) ; 11 Sep 92; 06 Oct 92; 19 Dec 93; 11 Nov 94 (gldefun draw-text-draw ((d draw-text) (w window) (off vector)) (printat-xy w (contents d) ((x off) + (x (offset d))) ((y off) + (y (offset d)))) ) ; 07 Oct 92 (gldefun draw-text-draw-outline ((w window) (x integer) (y integer) (d draw-text)) (setf (second d) (list x y)) (draw-box-xy w x (y + 2) (x (size d)) (y (size d))) ) ; define compiled version directly to avoid repeated recompilation (defun draw-text-draw-outline (W X Y D) (SETF (SECOND D) (LIST X Y)) (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) ; 11 Sep 92 (gldefun draw-text-selectedp ((d draw-text) (pt vector) (off vector)) (let ((ptp (pt - off))) (contains? (vregion d) ptp))) ; 11 Sep 92; 17 Sep 92; 06 Oct 92; 11 Nov 94 (gldefun draw-text-get ((dd draw-desc) (w window)) (let (txt lng off) (princ "Enter text string: ") (txt = (stringify (read))) (lng = (string-width w txt)) (off = (get-box-position w lng 14)) (a draw-text with offset = (off + (a vector x 0 y 4)) size = (a vector with x = lng y = 14) contents = txt) )) ; 15 Sep 92; 05 Jan 04 ; Test if a point p1 is close to a point p2. If so, result is p2, else nil. (gldefun draw-snapp ((p1 vector) (off vector) (p2x integer) (p2y integer)) (if (and ((abs ((x p1) - (x off) - p2x)) < 4) ((abs ((y p1) - (y off) - p2y)) < 4) ) (a vector with x = ((x off) + p2x) y = ((y off) + p2y)) )) ; 15 Sep 92 (gldefun draw-dot-snap ((d draw-dot) (p vector) (off vector)) (draw-snapp p off ((x (offset d)) + 2) ((y (offset d)) + 2) ) ) ; 17 Dec 93 (gldefun draw-refpt-snap ((d draw-refpt) (p vector) (off vector)) (draw-snapp p off (x (offset d)) (y (offset d)) ) ) ; 15 Sep 92 (gldefun draw-line-snap ((d draw-line) (p vector) (off vector)) (or (draw-snapp p off (x (offset d)) (y (offset d))) (draw-snapp p off ( (x (offset d)) + (x (size d)) ) ( (y (offset d)) + (y (size d)) ) ) )) ; 15 Sep 92; 19 Dec 93 ; Snap for square: corners, middle of sides. (gldefun draw-box-snap ((d draw-box) (p vector) (off vector)) (let ((xoff (x (offset d))) (yoff (y (offset d))) (xsize (x (size d)) ) (ysize (y (size d)) ) ) (or (draw-snapp p off xoff yoff) (draw-snapp p off (xoff + xsize) (yoff + ysize)) (draw-snapp p off (xoff + xsize) yoff) (draw-snapp p off xoff (yoff + ysize)) (draw-snapp p off (xoff + xsize / 2) yoff) (draw-snapp p off xoff (yoff + ysize / 2)) (draw-snapp p off (xoff + xsize / 2) (yoff + ysize)) (draw-snapp p off (xoff + xsize) (yoff + ysize / 2)) ) )) ; 15 Sep 92 (gldefun draw-circle-snap ((d draw-circle) (p vector) (off vector)) (or (draw-snapp p off ( (x (offset d)) + (radius d) ) ( (y (offset d)) + (radius d) ) ) (draw-snapp p off ( (x (offset d)) + (radius d) ) (y (offset d)) ) (draw-snapp p off (x (offset d)) ( (y (offset d)) + (radius d) ) ) (draw-snapp p off ( (x (offset d)) + (radius d) ) ( (y (offset d)) + (y (size d)) ) ) (draw-snapp p off ( (x (offset d)) + (x (size d)) ) ( (y (offset d)) + (radius d) ) ) )) ; 15 Sep 92 (gldefun draw-ellipse-snap ((d draw-ellipse) (p vector) (off vector)) (or (draw-snapp p off ( (x (offset d)) + (radiusx d) ) ( (y (offset d)) + (radiusy d) ) ) (draw-snapp p off ( (x (offset d)) + (radiusx d) ) (y (offset d)) ) (draw-snapp p off (x (offset d)) ( (y (offset d)) + (radiusy d) ) ) (draw-snapp p off ( (x (offset d)) + (radiusx d) ) ( (y (offset d)) + (y (size d)) ) ) (draw-snapp p off ( (x (offset d)) + (x (size d)) ) ( (y (offset d)) + (radiusy d) ) ) )) ; 16 Sep 92 (gldefun draw-rcbox-snap ((d draw-rcbox) (p vector) (off vector)) (let ( (rx ((x (size d)) / 2)) (ry ((y (size d)) / 2)) ) (or (draw-snapp p off ( (x (offset d)) + rx ) (y (offset d)) ) (draw-snapp p off (x (offset d)) ( (y (offset d)) + ry ) ) (draw-snapp p off ( (x (offset d)) + rx ) ( (y (offset d)) + (y (size d)) ) ) (draw-snapp p off ( (x (offset d)) + (x (size d)) ) ( (y (offset d)) + ry ) ) ) )) ; 15 Sep 92 (gldefun draw-no-snap ((d draw-ellipse) (p vector) (off vector)) nil) ; 11 Sep 92 (gldefun draw-multi-draw ((d draw-multi) (w window) (off vector)) (let ( (totaloff ((offset d) + off)) ) (for subd in (contents d) do (draw subd w totaloff)) )) ; 11 Sep 92; 13 Sep 92; 15 Sep 92; 16 Sep 92; 29 Sep 92; 17 Dec 93; 07 Jan 94 ; Initialize drawing and command menus (defun draw-init-menus () (let ((w (draw-window))) (window-clear w) (dolist (fn '(draw-menu-rectangle draw-menu-circle draw-menu-ellipse draw-menu-line draw-menu-arrow draw-menu-dot draw-menu-button draw-menu-text)) (setf (get fn 'display-size) '(30 20)) ) (setq *draw-menu-set* (menu-set-create w nil)) (menu-set-add-menu *draw-menu-set* 'draw nil "Draw" '((draw-menu-rectangle . rectangle) (draw-menu-rcbox . rcbox) (draw-menu-circle . circle) (draw-menu-ellipse . ellipse) (draw-menu-line . line) (draw-menu-arrow . arrow) (draw-menu-dot . dot) (" " . erase) (draw-menu-button . button) (draw-menu-text . text) (draw-menu-refpt . refpt)) (list 0 0)) (menu-set-adjust *draw-menu-set* 'draw 'top nil 1) (menu-set-adjust *draw-menu-set* 'draw 'right nil 2) (menu-set-add-menu *draw-menu-set* 'command nil "Commands" '(("Done" . done) ("Move" . move) ("Delete" . delete) ("Copy" . copy) ("Redraw" . redraw) ("Origin" . origin) ("LaTex Mode" . latexmode) ("Make Program" . program) ("Make LaTex" . latex)) (list 0 0)) (menu-set-adjust *draw-menu-set* 'command 'top 'draw 5) (menu-set-adjust *draw-menu-set* 'command 'right nil 2) )) ; 10 Sep 92 (defun draw-menu-rectangle (w x y) (window-draw-box-xy w (+ x 3) (+ y 3) 24 14 1)) (defun draw-menu-rcbox (w x y) (window-draw-rcbox-xy w (+ x 3) (+ y 3) 24 14 3 1)) (defun draw-menu-circle (w x y) (window-draw-circle-xy w (+ x 15) (+ y 10) 8 1)) (defun draw-menu-ellipse (w x y) (window-draw-ellipse-xy w (+ x 15) (+ y 10) 12 8 1)) (defun draw-menu-line (w x y) (window-draw-line-xy w (+ x 4) (+ y 4) (+ x 26) (+ y 16) 1)) (defun draw-menu-arrow (w x y) (window-draw-arrow-xy w (+ x 4) (+ y 4) (+ x 26) (+ y 16) 1)) (defun draw-menu-dot (w x y) (window-draw-dot-xy w (+ x 15) (+ y 10)) ) (defun draw-menu-button (w x y) (window-draw-box-xy w (+ x 14) (+ y 5) 4 4 1)) (defun draw-menu-text (w x y) (window-printat-xy w "A" (+ x 12) (+ y 5))) (defun draw-menu-refpt (w x y) (window-draw-crosshairs-xy w (+ x 15) (+ y 9)) (window-draw-circle-xy w (+ x 15) (+ y 9) 2)) ; 14 Sep 92; 15 Jan 98 ; Draw a line or arrow in LaTex form (defun latex-line (fromx fromy x y &optional arrowflg) (let (dx dy sx sy siz err errb) (setq dx (- x fromx)) (setq dy (- y fromy)) (if (= dx 0) (progn (setq sx 0) (setq sy (if (>= dy 0) 1 -1)) (setq siz (* (abs dy) *draw-latex-factor*))) (if (= dy 0) (progn (setq sx (if (>= dx 0) 1 -1)) (setq sy 0) (setq siz (* (abs dx) *draw-latex-factor*))) (progn (setq err 9999) (setq siz (* (abs dx) *draw-latex-factor*)) (dotimes (i (if arrowflg 4 6)) (dotimes (j (if arrowflg 4 6)) (setq errb (abs (- (/ (float (1+ i)) (float (1+ j))) (abs (/ (float dx) (float dy)))))) (if (and (= (gcd (1+ i) (1+ j)) 1) (< errb err)) (progn (setq err errb) (setq sx (1+ i)) (setq sy (1+ j)))))) (setq sx (* sx (latex-sign dx))) (setq sy (* sy (latex-sign dy))) ))) (format t " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%" (* fromx *draw-latex-factor*) (* fromy *draw-latex-factor*) (if arrowflg "vector" "line") sx sy siz) )) (defun latex-sign (x) (if (>= x 0) 1 -1)) ; 16 Sep 92; 30 Sep 92; 02 Oct 92; 07 Oct 92 (defun draw-output (outfilename &optional names) (prog (prettysave lengthsave d fnname code) (or names (setq names *draw-objects*)) (if (symbolp names) (setq names (list names))) (with-open-file (outfile outfilename :direction :output :if-exists :supersede) (setq prettysave *print-pretty*) (setq lengthsave *print-length*) (setq *print-pretty* t) (setq *print-length* 80) (format outfile "; ~A ~A~%" outfilename (draw-get-time-string)) (dolist (name names) (if (setq d (get name 'draw-descr)) (progn (terpri outfile) (print `(setf (get ',name 'draw-descr) ',d) outfile) (if (and (setq fnname (draw-desc-fnname d)) (setq code (symbol-function fnname))) (progn (terpri outfile) (print (cons 'defun (if (eq (car code) 'lambda-block) (cdr code) (cons fnname (cdr code)))) outfile)) ))) (if (setq d (get name 'picmenu-spec)) (progn (terpri outfile) (print `(setf (get ',name 'picmenu-spec) ',d) outfile)))) (terpri outfile) (setq *print-pretty* prettysave) (setq *print-length* lengthsave) ) (return outfilename) )) ; 09 Sep 92 (defun draw-get-time-string () (let (second minute hour date month year) (multiple-value-setq (second minute hour date month year) (get-decoded-time)) (format nil "~2D ~A ~4D ~2D:~2D:~2D" date (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) year hour minute second) )) ; 14 Sep 92; 16 Sep 92; 13 July 93 ; Compile the draw.lsp and menu-set files into a plain Lisp file (defun compile-draw () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp") '("glisp/menu-set.lsp" ; translated files "glisp/draw.lsp") "glisp/drawtrans.lsp" ; output file "glisp/draw-header.lsp") ; header file (cf drawtrans) ) (defun compile-drawb () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/menu-set.lsp" ; translated files "glisp/draw.lsp") "glisp/drawtrans.lsp" ; output file "glisp/draw-header.lsp") ; header file ) ; 16 Nov 92; 08 Apr 93; 08 Oct 93; 20 Apr 94; 29 Oct 94; 09 Feb 99 ; Output drawing descriptions and functions to the specified file (defun draw-out (&optional names file) (or names (setq names *draw-objects*)) (if (not (consp names)) (setq names (list names))) (draw-output (or file "glisp/draw.del") names) (setq *draw-objects* (set-difference *draw-objects* names)) names ) gcl-2.6.14/xgcl-2/gcl_dwtestcases.lsp0000644000175000017500000000131014360276512015760 0ustar cammcamm(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtrans.lsp") (use-package 'xlib) (load "/stage/ftp/pub/novak/xgcl-4/gcl_drawtrans.lsp") (load "/stage/ftp/pub/novak/xgcl-4/gcl_editorstrans.lsp") (load "/stage/ftp/pub/novak/xgcl-4/gcl_lispservertrans.lsp") (load "/stage/ftp/pub/novak/xgcl-4/gcl_menu-settrans.lsp") (load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtest.lsp") (load "/stage/ftp/pub/novak/xgcl-4/gcl_draw-gates.lsp") (wtesta) (wtestb) (wtestc) (wtestd) (wteste) (wtestf) (wtestg) (wtesth) (wtesti) (wtestj) (wtestk) (window-clear myw) (edit-color myw) (lisp-server) (draw 'foo) (window-draw-box-xy myw 48 48 204 204) (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good")) (draw-nand myw 50 50) gcl-2.6.14/xgcl-2/sysdef.lisp0000644000175000017500000000500714360276512014257 0ustar cammcamm; Copyright (c) 1994 William F. Schelter ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. (load "package.lisp") (in-package :XLIB) (defvar *files* '( "gcl_Xlib" "gcl_Xutil" "gcl_X" "gcl_XAtom" "gcl_defentry_events" "gcl_Xstruct" "gcl_XStruct_l_3" "gcl_general" "gcl_keysymdef" "gcl_X10" "gcl_Xinit" "gcl_dwtrans" "gcl_tohtml" "gcl_index" ; "gcl_sysinit" )) (defun compile-xgcl() #+(or m68k sh4) (progn (trace si::readdir si::opendir si::closedir si::pathname-match-p) (print (directory "*.c")) (untrace si::readdir si::opendir si::closedir si::pathname-match-p)) (mapc (lambda (x) (let ((x (concatenate 'string compiler::*cc* " -I../h " (namestring x)))) (unless (zerop (system x)) (error "compile failure: ~s~%" x)))) (or (directory "*.c") #+(or m68k sh4) (progn (print "qemu/readdir issue still present") (mapcar (lambda (x) (truename (merge-pathnames ".c" x))) '("XStruct-4" "general-c" "Xutil-2" "Events" "XStruct-2"))))) (mapc (lambda (x) (compile-file (format nil "~a.lsp" x) :system-p t)) *files*)) (defun load-xgcl() (mapcar (lambda (x) (load (format nil "~a.o" x))) *files*)) (defun load-xgcl-interp() (mapcar (lambda (x) (load (format nil "~a.lsp" x))) *files*)) (defun save-xgcl (pn) (let* ((x (mapcar (lambda (x) (probe-file (concatenate 'string x ".o"))) *files*)) (y (directory "*.o")) (z (set-difference y x :test 'equal))) (compiler::link x (namestring pn) (format nil "(load ~s)(mapc 'load '~s)" "sysdef.lisp" x) (reduce (lambda (&rest xy) (when xy (concatenate 'string (namestring (car xy)) " " (cadr xy)))) z :initial-value " -lXmu -lXt -lXext -lXaw -lX11" :from-end t) nil))) gcl-2.6.14/xgcl-2/Events.c0000644000175000017500000016040614360276512013506 0ustar cammcamm/* Events.c Hiep Huu Nguyen 27 Jun 06 */ /*; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; edited 27 Aug 92; 12 Aug 2002; 23 Jun 06 by GSN; 27 Jun 06 by GSN ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. */ #include #include /********* XKeyEvent functions *****/ long make_XKeyEvent (){ return ((long) calloc(1, sizeof(XKeyEvent))); } int XKeyEvent_same_screen(i) XKeyEvent* i; { return(i->same_screen); } void set_XKeyEvent_same_screen(i, j) XKeyEvent* i; int j; { i->same_screen = j; } int XKeyEvent_keycode(i) XKeyEvent* i; { return(i->keycode); } void set_XKeyEvent_keycode(i, j) XKeyEvent* i; int j; { i->keycode = j; } int XKeyEvent_state(i) XKeyEvent* i; { return(i->state); } void set_XKeyEvent_state(i, j) XKeyEvent* i; int j; { i->state = j; } int XKeyEvent_y_root(i) XKeyEvent* i; { return(i->y_root); } void set_XKeyEvent_y_root(i, j) XKeyEvent* i; int j; { i->y_root = j; } int XKeyEvent_x_root(i) XKeyEvent* i; { return(i->x_root); } void set_XKeyEvent_x_root(i, j) XKeyEvent* i; int j; { i->x_root = j; } int XKeyEvent_y(i) XKeyEvent* i; { return(i->y); } void set_XKeyEvent_y(i, j) XKeyEvent* i; int j; { i->y = j; } int XKeyEvent_x(i) XKeyEvent* i; { return(i->x); } void set_XKeyEvent_x(i, j) XKeyEvent* i; int j; { i->x = j; } int XKeyEvent_time(i) XKeyEvent* i; { return(i->time); } void set_XKeyEvent_time(i, j) XKeyEvent* i; int j; { i->time = j; } int XKeyEvent_subwindow(i) XKeyEvent* i; { return(i->subwindow); } void set_XKeyEvent_subwindow(i, j) XKeyEvent* i; int j; { i->subwindow = j; } int XKeyEvent_root(i) XKeyEvent* i; { return(i->root); } void set_XKeyEvent_root(i, j) XKeyEvent* i; int j; { i->root = j; } int XKeyEvent_window(i) XKeyEvent* i; { return(i->window); } void set_XKeyEvent_window(i, j) XKeyEvent* i; int j; { i->window = j; } long XKeyEvent_display(i) XKeyEvent* i; { return((long) i->display); } void set_XKeyEvent_display(i, j) XKeyEvent* i; long j; { i->display = (Display *) j; } int XKeyEvent_send_event(i) XKeyEvent* i; { return(i->send_event); } void set_XKeyEvent_send_event(i, j) XKeyEvent* i; int j; { i->send_event = j; } int XKeyEvent_serial(i) XKeyEvent* i; { return(i->serial); } void set_XKeyEvent_serial(i, j) XKeyEvent* i; int j; { i->serial = j; } int XKeyEvent_type(i) XKeyEvent* i; { return(i->type); } void set_XKeyEvent_type(i, j) XKeyEvent* i; int j; { i->type = j; } /********* XButtonEvent functions *****/ long make_XButtonEvent (){ return ((long) calloc(1, sizeof(XButtonEvent))); } int XButtonEvent_same_screen(i) XButtonEvent* i; { return(i->same_screen); } void set_XButtonEvent_same_screen(i, j) XButtonEvent* i; int j; { i->same_screen = j; } int XButtonEvent_button(i) XButtonEvent* i; { return(i->button); } void set_XButtonEvent_button(i, j) XButtonEvent* i; int j; { i->button = j; } int XButtonEvent_state(i) XButtonEvent* i; { return(i->state); } void set_XButtonEvent_state(i, j) XButtonEvent* i; int j; { i->state = j; } int XButtonEvent_y_root(i) XButtonEvent* i; { return(i->y_root); } void set_XButtonEvent_y_root(i, j) XButtonEvent* i; int j; { i->y_root = j; } int XButtonEvent_x_root(i) XButtonEvent* i; { return(i->x_root); } void set_XButtonEvent_x_root(i, j) XButtonEvent* i; int j; { i->x_root = j; } int XButtonEvent_y(i) XButtonEvent* i; { return(i->y); } void set_XButtonEvent_y(i, j) XButtonEvent* i; int j; { i->y = j; } int XButtonEvent_x(i) XButtonEvent* i; { return(i->x); } void set_XButtonEvent_x(i, j) XButtonEvent* i; int j; { i->x = j; } int XButtonEvent_time(i) XButtonEvent* i; { return(i->time); } void set_XButtonEvent_time(i, j) XButtonEvent* i; int j; { i->time = j; } int XButtonEvent_subwindow(i) XButtonEvent* i; { return(i->subwindow); } void set_XButtonEvent_subwindow(i, j) XButtonEvent* i; int j; { i->subwindow = j; } int XButtonEvent_root(i) XButtonEvent* i; { return(i->root); } void set_XButtonEvent_root(i, j) XButtonEvent* i; int j; { i->root = j; } int XButtonEvent_window(i) XButtonEvent* i; { return(i->window); } void set_XButtonEvent_window(i, j) XButtonEvent* i; int j; { i->window = j; } long XButtonEvent_display(i) XButtonEvent* i; { return((long) i->display); } void set_XButtonEvent_display(i, j) XButtonEvent* i; long j; { i->display = (Display *) j; } int XButtonEvent_send_event(i) XButtonEvent* i; { return(i->send_event); } void set_XButtonEvent_send_event(i, j) XButtonEvent* i; int j; { i->send_event = j; } int XButtonEvent_serial(i) XButtonEvent* i; { return(i->serial); } void set_XButtonEvent_serial(i, j) XButtonEvent* i; int j; { i->serial = j; } int XButtonEvent_type(i) XButtonEvent* i; { return(i->type); } void set_XButtonEvent_type(i, j) XButtonEvent* i; int j; { i->type = j; } /********* XMotionEvent functions *****/ long make_XMotionEvent (){ return ((long) calloc(1, sizeof(XMotionEvent))); } int XMotionEvent_same_screen(i) XMotionEvent* i; { return(i->same_screen); } void set_XMotionEvent_same_screen(i, j) XMotionEvent* i; int j; { i->same_screen = j; } char XMotionEvent_is_hint(i) XMotionEvent* i; { return(i->is_hint); } void set_XMotionEvent_is_hint(i, j) XMotionEvent* i; char j; { i->is_hint = j; } int XMotionEvent_state(i) XMotionEvent* i; { return(i->state); } void set_XMotionEvent_state(i, j) XMotionEvent* i; int j; { i->state = j; } int XMotionEvent_y_root(i) XMotionEvent* i; { return(i->y_root); } void set_XMotionEvent_y_root(i, j) XMotionEvent* i; int j; { i->y_root = j; } int XMotionEvent_x_root(i) XMotionEvent* i; { return(i->x_root); } void set_XMotionEvent_x_root(i, j) XMotionEvent* i; int j; { i->x_root = j; } int XMotionEvent_y(i) XMotionEvent* i; { return(i->y); } void set_XMotionEvent_y(i, j) XMotionEvent* i; int j; { i->y = j; } int XMotionEvent_x(i) XMotionEvent* i; { return(i->x); } void set_XMotionEvent_x(i, j) XMotionEvent* i; int j; { i->x = j; } int XMotionEvent_time(i) XMotionEvent* i; { return(i->time); } void set_XMotionEvent_time(i, j) XMotionEvent* i; int j; { i->time = j; } int XMotionEvent_subwindow(i) XMotionEvent* i; { return(i->subwindow); } void set_XMotionEvent_subwindow(i, j) XMotionEvent* i; int j; { i->subwindow = j; } int XMotionEvent_root(i) XMotionEvent* i; { return(i->root); } void set_XMotionEvent_root(i, j) XMotionEvent* i; int j; { i->root = j; } int XMotionEvent_window(i) XMotionEvent* i; { return(i->window); } void set_XMotionEvent_window(i, j) XMotionEvent* i; int j; { i->window = j; } long XMotionEvent_display(i) XMotionEvent* i; { return((long) i->display); } void set_XMotionEvent_display(i, j) XMotionEvent* i; long j; { i->display = (Display *) j; } int XMotionEvent_send_event(i) XMotionEvent* i; { return(i->send_event); } void set_XMotionEvent_send_event(i, j) XMotionEvent* i; int j; { i->send_event = j; } int XMotionEvent_serial(i) XMotionEvent* i; { return(i->serial); } void set_XMotionEvent_serial(i, j) XMotionEvent* i; int j; { i->serial = j; } int XMotionEvent_type(i) XMotionEvent* i; { return(i->type); } void set_XMotionEvent_type(i, j) XMotionEvent* i; int j; { i->type = j; } /********* XCrossingEvent functions *****/ long make_XCrossingEvent (){ return ((long) calloc(1, sizeof(XCrossingEvent))); } int XCrossingEvent_state(i) XCrossingEvent* i; { return(i->state); } void set_XCrossingEvent_state(i, j) XCrossingEvent* i; int j; { i->state = j; } int XCrossingEvent_focus(i) XCrossingEvent* i; { return(i->focus); } void set_XCrossingEvent_focus(i, j) XCrossingEvent* i; int j; { i->focus = j; } int XCrossingEvent_same_screen(i) XCrossingEvent* i; { return(i->same_screen); } void set_XCrossingEvent_same_screen(i, j) XCrossingEvent* i; int j; { i->same_screen = j; } int XCrossingEvent_detail(i) XCrossingEvent* i; { return(i->detail); } void set_XCrossingEvent_detail(i, j) XCrossingEvent* i; int j; { i->detail = j; } int XCrossingEvent_mode(i) XCrossingEvent* i; { return(i->mode); } void set_XCrossingEvent_mode(i, j) XCrossingEvent* i; int j; { i->mode = j; } int XCrossingEvent_y_root(i) XCrossingEvent* i; { return(i->y_root); } void set_XCrossingEvent_y_root(i, j) XCrossingEvent* i; int j; { i->y_root = j; } int XCrossingEvent_x_root(i) XCrossingEvent* i; { return(i->x_root); } void set_XCrossingEvent_x_root(i, j) XCrossingEvent* i; int j; { i->x_root = j; } int XCrossingEvent_y(i) XCrossingEvent* i; { return(i->y); } void set_XCrossingEvent_y(i, j) XCrossingEvent* i; int j; { i->y = j; } int XCrossingEvent_x(i) XCrossingEvent* i; { return(i->x); } void set_XCrossingEvent_x(i, j) XCrossingEvent* i; int j; { i->x = j; } int XCrossingEvent_time(i) XCrossingEvent* i; { return(i->time); } void set_XCrossingEvent_time(i, j) XCrossingEvent* i; int j; { i->time = j; } int XCrossingEvent_subwindow(i) XCrossingEvent* i; { return(i->subwindow); } void set_XCrossingEvent_subwindow(i, j) XCrossingEvent* i; int j; { i->subwindow = j; } int XCrossingEvent_root(i) XCrossingEvent* i; { return(i->root); } void set_XCrossingEvent_root(i, j) XCrossingEvent* i; int j; { i->root = j; } int XCrossingEvent_window(i) XCrossingEvent* i; { return(i->window); } void set_XCrossingEvent_window(i, j) XCrossingEvent* i; int j; { i->window = j; } long XCrossingEvent_display(i) XCrossingEvent* i; { return((long) i->display); } void set_XCrossingEvent_display(i, j) XCrossingEvent* i; long j; { i->display = (Display *) j; } int XCrossingEvent_send_event(i) XCrossingEvent* i; { return(i->send_event); } void set_XCrossingEvent_send_event(i, j) XCrossingEvent* i; int j; { i->send_event = j; } int XCrossingEvent_serial(i) XCrossingEvent* i; { return(i->serial); } void set_XCrossingEvent_serial(i, j) XCrossingEvent* i; int j; { i->serial = j; } int XCrossingEvent_type(i) XCrossingEvent* i; { return(i->type); } void set_XCrossingEvent_type(i, j) XCrossingEvent* i; int j; { i->type = j; } /********* XFocusChangeEvent functions *****/ long make_XFocusChangeEvent (){ return ((long) calloc(1, sizeof(XFocusChangeEvent))); } int XFocusChangeEvent_detail(i) XFocusChangeEvent* i; { return(i->detail); } void set_XFocusChangeEvent_detail(i, j) XFocusChangeEvent* i; int j; { i->detail = j; } int XFocusChangeEvent_mode(i) XFocusChangeEvent* i; { return(i->mode); } void set_XFocusChangeEvent_mode(i, j) XFocusChangeEvent* i; int j; { i->mode = j; } int XFocusChangeEvent_window(i) XFocusChangeEvent* i; { return(i->window); } void set_XFocusChangeEvent_window(i, j) XFocusChangeEvent* i; int j; { i->window = j; } long XFocusChangeEvent_display(i) XFocusChangeEvent* i; { return((long) i->display); } void set_XFocusChangeEvent_display(i, j) XFocusChangeEvent* i; long j; { i->display = (Display *) j; } int XFocusChangeEvent_send_event(i) XFocusChangeEvent* i; { return(i->send_event); } void set_XFocusChangeEvent_send_event(i, j) XFocusChangeEvent* i; int j; { i->send_event = j; } int XFocusChangeEvent_serial(i) XFocusChangeEvent* i; { return(i->serial); } void set_XFocusChangeEvent_serial(i, j) XFocusChangeEvent* i; int j; { i->serial = j; } int XFocusChangeEvent_type(i) XFocusChangeEvent* i; { return(i->type); } void set_XFocusChangeEvent_type(i, j) XFocusChangeEvent* i; int j; { i->type = j; } /********* XKeymapEvent functions *****/ long make_XKeymapEvent (){ return ((long) calloc(1, sizeof(XKeymapEvent))); } char* XKeymapEvent_key_vector(i) XKeymapEvent* i; { return(i->key_vector); } int XKeymapEvent_window(i) XKeymapEvent* i; { return(i->window); } void set_XKeymapEvent_window(i, j) XKeymapEvent* i; int j; { i->window = j; } long XKeymapEvent_display(i) XKeymapEvent* i; { return((long) i->display); } void set_XKeymapEvent_display(i, j) XKeymapEvent* i; long j; { i->display = (Display *) j; } int XKeymapEvent_send_event(i) XKeymapEvent* i; { return(i->send_event); } void set_XKeymapEvent_send_event(i, j) XKeymapEvent* i; int j; { i->send_event = j; } int XKeymapEvent_serial(i) XKeymapEvent* i; { return(i->serial); } void set_XKeymapEvent_serial(i, j) XKeymapEvent* i; int j; { i->serial = j; } int XKeymapEvent_type(i) XKeymapEvent* i; { return(i->type); } void set_XKeymapEvent_type(i, j) XKeymapEvent* i; int j; { i->type = j; } /********* XExposeEvent functions *****/ long make_XExposeEvent (){ return ((long) calloc(1, sizeof(XExposeEvent))); } int XExposeEvent_count(i) XExposeEvent* i; { return(i->count); } void set_XExposeEvent_count(i, j) XExposeEvent* i; int j; { i->count = j; } int XExposeEvent_height(i) XExposeEvent* i; { return(i->height); } void set_XExposeEvent_height(i, j) XExposeEvent* i; int j; { i->height = j; } int XExposeEvent_width(i) XExposeEvent* i; { return(i->width); } void set_XExposeEvent_width(i, j) XExposeEvent* i; int j; { i->width = j; } int XExposeEvent_y(i) XExposeEvent* i; { return(i->y); } void set_XExposeEvent_y(i, j) XExposeEvent* i; int j; { i->y = j; } int XExposeEvent_x(i) XExposeEvent* i; { return(i->x); } void set_XExposeEvent_x(i, j) XExposeEvent* i; int j; { i->x = j; } int XExposeEvent_window(i) XExposeEvent* i; { return(i->window); } void set_XExposeEvent_window(i, j) XExposeEvent* i; int j; { i->window = j; } long XExposeEvent_display(i) XExposeEvent* i; { return((long) i->display); } void set_XExposeEvent_display(i, j) XExposeEvent* i; long j; { i->display = (Display *) j; } int XExposeEvent_send_event(i) XExposeEvent* i; { return(i->send_event); } void set_XExposeEvent_send_event(i, j) XExposeEvent* i; int j; { i->send_event = j; } int XExposeEvent_serial(i) XExposeEvent* i; { return(i->serial); } void set_XExposeEvent_serial(i, j) XExposeEvent* i; int j; { i->serial = j; } int XExposeEvent_type(i) XExposeEvent* i; { return(i->type); } void set_XExposeEvent_type(i, j) XExposeEvent* i; int j; { i->type = j; } /********* XGraphicsExposeEvent functions *****/ long make_XGraphicsExposeEvent (){ return ((long) calloc(1, sizeof(XGraphicsExposeEvent))); } int XGraphicsExposeEvent_minor_code(i) XGraphicsExposeEvent* i; { return(i->minor_code); } void set_XGraphicsExposeEvent_minor_code(i, j) XGraphicsExposeEvent* i; int j; { i->minor_code = j; } int XGraphicsExposeEvent_major_code(i) XGraphicsExposeEvent* i; { return(i->major_code); } void set_XGraphicsExposeEvent_major_code(i, j) XGraphicsExposeEvent* i; int j; { i->major_code = j; } int XGraphicsExposeEvent_count(i) XGraphicsExposeEvent* i; { return(i->count); } void set_XGraphicsExposeEvent_count(i, j) XGraphicsExposeEvent* i; int j; { i->count = j; } int XGraphicsExposeEvent_height(i) XGraphicsExposeEvent* i; { return(i->height); } void set_XGraphicsExposeEvent_height(i, j) XGraphicsExposeEvent* i; int j; { i->height = j; } int XGraphicsExposeEvent_width(i) XGraphicsExposeEvent* i; { return(i->width); } void set_XGraphicsExposeEvent_width(i, j) XGraphicsExposeEvent* i; int j; { i->width = j; } int XGraphicsExposeEvent_y(i) XGraphicsExposeEvent* i; { return(i->y); } void set_XGraphicsExposeEvent_y(i, j) XGraphicsExposeEvent* i; int j; { i->y = j; } int XGraphicsExposeEvent_x(i) XGraphicsExposeEvent* i; { return(i->x); } void set_XGraphicsExposeEvent_x(i, j) XGraphicsExposeEvent* i; int j; { i->x = j; } Drawable XGraphicsExposeEvent_drawable(i) XGraphicsExposeEvent* i; { return(i->drawable); } void set_XGraphicsExposeEvent_drawable(i, j) XGraphicsExposeEvent* i; Drawable j; { i->drawable = j; } long XGraphicsExposeEvent_display(i) XGraphicsExposeEvent* i; { return((long) i->display); } void set_XGraphicsExposeEvent_display(i, j) XGraphicsExposeEvent* i; long j; { i->display = (Display *) j; } int XGraphicsExposeEvent_send_event(i) XGraphicsExposeEvent* i; { return(i->send_event); } void set_XGraphicsExposeEvent_send_event(i, j) XGraphicsExposeEvent* i; int j; { i->send_event = j; } int XGraphicsExposeEvent_serial(i) XGraphicsExposeEvent* i; { return(i->serial); } void set_XGraphicsExposeEvent_serial(i, j) XGraphicsExposeEvent* i; int j; { i->serial = j; } int XGraphicsExposeEvent_type(i) XGraphicsExposeEvent* i; { return(i->type); } void set_XGraphicsExposeEvent_type(i, j) XGraphicsExposeEvent* i; int j; { i->type = j; } /********* XNoExposeEvent functions *****/ long make_XNoExposeEvent (){ return ((long) calloc(1, sizeof(XNoExposeEvent))); } int XNoExposeEvent_minor_code(i) XNoExposeEvent* i; { return(i->minor_code); } void set_XNoExposeEvent_minor_code(i, j) XNoExposeEvent* i; int j; { i->minor_code = j; } int XNoExposeEvent_major_code(i) XNoExposeEvent* i; { return(i->major_code); } void set_XNoExposeEvent_major_code(i, j) XNoExposeEvent* i; int j; { i->major_code = j; } Drawable XNoExposeEvent_drawable(i) XNoExposeEvent* i; { return(i->drawable); } void set_XNoExposeEvent_drawable(i, j) XNoExposeEvent* i; Drawable j; { i->drawable = j; } long XNoExposeEvent_display(i) XNoExposeEvent* i; { return((long) i->display); } void set_XNoExposeEvent_display(i, j) XNoExposeEvent* i; long j; { i->display = (Display *) j; } int XNoExposeEvent_send_event(i) XNoExposeEvent* i; { return(i->send_event); } void set_XNoExposeEvent_send_event(i, j) XNoExposeEvent* i; int j; { i->send_event = j; } int XNoExposeEvent_serial(i) XNoExposeEvent* i; { return(i->serial); } void set_XNoExposeEvent_serial(i, j) XNoExposeEvent* i; int j; { i->serial = j; } int XNoExposeEvent_type(i) XNoExposeEvent* i; { return(i->type); } void set_XNoExposeEvent_type(i, j) XNoExposeEvent* i; int j; { i->type = j; } /********* XVisibilityEvent functions *****/ long make_XVisibilityEvent (){ return ((long) calloc(1, sizeof(XVisibilityEvent))); } int XVisibilityEvent_state(i) XVisibilityEvent* i; { return(i->state); } void set_XVisibilityEvent_state(i, j) XVisibilityEvent* i; int j; { i->state = j; } int XVisibilityEvent_window(i) XVisibilityEvent* i; { return(i->window); } void set_XVisibilityEvent_window(i, j) XVisibilityEvent* i; int j; { i->window = j; } long XVisibilityEvent_display(i) XVisibilityEvent* i; { return((long) i->display); } void set_XVisibilityEvent_display(i, j) XVisibilityEvent* i; long j; { i->display = (Display *) j; } int XVisibilityEvent_send_event(i) XVisibilityEvent* i; { return(i->send_event); } void set_XVisibilityEvent_send_event(i, j) XVisibilityEvent* i; int j; { i->send_event = j; } int XVisibilityEvent_serial(i) XVisibilityEvent* i; { return(i->serial); } void set_XVisibilityEvent_serial(i, j) XVisibilityEvent* i; int j; { i->serial = j; } int XVisibilityEvent_type(i) XVisibilityEvent* i; { return(i->type); } void set_XVisibilityEvent_type(i, j) XVisibilityEvent* i; int j; { i->type = j; } /********* XCreateWindowEvent functions *****/ long make_XCreateWindowEvent (){ return ((long) calloc(1, sizeof(XCreateWindowEvent))); } int XCreateWindowEvent_override_redirect(i) XCreateWindowEvent* i; { return(i->override_redirect); } void set_XCreateWindowEvent_override_redirect(i, j) XCreateWindowEvent* i; int j; { i->override_redirect = j; } int XCreateWindowEvent_border_width(i) XCreateWindowEvent* i; { return(i->border_width); } void set_XCreateWindowEvent_border_width(i, j) XCreateWindowEvent* i; int j; { i->border_width = j; } int XCreateWindowEvent_height(i) XCreateWindowEvent* i; { return(i->height); } void set_XCreateWindowEvent_height(i, j) XCreateWindowEvent* i; int j; { i->height = j; } int XCreateWindowEvent_width(i) XCreateWindowEvent* i; { return(i->width); } void set_XCreateWindowEvent_width(i, j) XCreateWindowEvent* i; int j; { i->width = j; } int XCreateWindowEvent_y(i) XCreateWindowEvent* i; { return(i->y); } void set_XCreateWindowEvent_y(i, j) XCreateWindowEvent* i; int j; { i->y = j; } int XCreateWindowEvent_x(i) XCreateWindowEvent* i; { return(i->x); } void set_XCreateWindowEvent_x(i, j) XCreateWindowEvent* i; int j; { i->x = j; } int XCreateWindowEvent_window(i) XCreateWindowEvent* i; { return(i->window); } void set_XCreateWindowEvent_window(i, j) XCreateWindowEvent* i; int j; { i->window = j; } int XCreateWindowEvent_parent(i) XCreateWindowEvent* i; { return(i->parent); } void set_XCreateWindowEvent_parent(i, j) XCreateWindowEvent* i; int j; { i->parent = j; } long XCreateWindowEvent_display(i) XCreateWindowEvent* i; { return((long) i->display); } void set_XCreateWindowEvent_display(i, j) XCreateWindowEvent* i; long j; { i->display = (Display *) j; } int XCreateWindowEvent_send_event(i) XCreateWindowEvent* i; { return(i->send_event); } void set_XCreateWindowEvent_send_event(i, j) XCreateWindowEvent* i; int j; { i->send_event = j; } int XCreateWindowEvent_serial(i) XCreateWindowEvent* i; { return(i->serial); } void set_XCreateWindowEvent_serial(i, j) XCreateWindowEvent* i; int j; { i->serial = j; } int XCreateWindowEvent_type(i) XCreateWindowEvent* i; { return(i->type); } void set_XCreateWindowEvent_type(i, j) XCreateWindowEvent* i; int j; { i->type = j; } /********* XDestroyWindowEvent functions *****/ long make_XDestroyWindowEvent (){ return ((long) calloc(1, sizeof(XDestroyWindowEvent))); } int XDestroyWindowEvent_window(i) XDestroyWindowEvent* i; { return(i->window); } void set_XDestroyWindowEvent_window(i, j) XDestroyWindowEvent* i; int j; { i->window = j; } int XDestroyWindowEvent_event(i) XDestroyWindowEvent* i; { return(i->event); } void set_XDestroyWindowEvent_event(i, j) XDestroyWindowEvent* i; int j; { i->event = j; } long XDestroyWindowEvent_display(i) XDestroyWindowEvent* i; { return((long) i->display); } void set_XDestroyWindowEvent_display(i, j) XDestroyWindowEvent* i; long j; { i->display = (Display *) j; } int XDestroyWindowEvent_send_event(i) XDestroyWindowEvent* i; { return(i->send_event); } void set_XDestroyWindowEvent_send_event(i, j) XDestroyWindowEvent* i; int j; { i->send_event = j; } int XDestroyWindowEvent_serial(i) XDestroyWindowEvent* i; { return(i->serial); } void set_XDestroyWindowEvent_serial(i, j) XDestroyWindowEvent* i; int j; { i->serial = j; } int XDestroyWindowEvent_type(i) XDestroyWindowEvent* i; { return(i->type); } void set_XDestroyWindowEvent_type(i, j) XDestroyWindowEvent* i; int j; { i->type = j; } /********* XUnmapEvent functions *****/ long make_XUnmapEvent (){ return ((long) calloc(1, sizeof(XUnmapEvent))); } int XUnmapEvent_from_configure(i) XUnmapEvent* i; { return(i->from_configure); } void set_XUnmapEvent_from_configure(i, j) XUnmapEvent* i; int j; { i->from_configure = j; } int XUnmapEvent_window(i) XUnmapEvent* i; { return(i->window); } void set_XUnmapEvent_window(i, j) XUnmapEvent* i; int j; { i->window = j; } int XUnmapEvent_event(i) XUnmapEvent* i; { return(i->event); } void set_XUnmapEvent_event(i, j) XUnmapEvent* i; int j; { i->event = j; } long XUnmapEvent_display(i) XUnmapEvent* i; { return((long) i->display); } void set_XUnmapEvent_display(i, j) XUnmapEvent* i; long j; { i->display = (Display *) j; } int XUnmapEvent_send_event(i) XUnmapEvent* i; { return(i->send_event); } void set_XUnmapEvent_send_event(i, j) XUnmapEvent* i; int j; { i->send_event = j; } int XUnmapEvent_serial(i) XUnmapEvent* i; { return(i->serial); } void set_XUnmapEvent_serial(i, j) XUnmapEvent* i; int j; { i->serial = j; } int XUnmapEvent_type(i) XUnmapEvent* i; { return(i->type); } void set_XUnmapEvent_type(i, j) XUnmapEvent* i; int j; { i->type = j; } /********* XMapEvent functions *****/ long make_XMapEvent (){ return ((long) calloc(1, sizeof(XMapEvent))); } int XMapEvent_override_redirect(i) XMapEvent* i; { return(i->override_redirect); } void set_XMapEvent_override_redirect(i, j) XMapEvent* i; int j; { i->override_redirect = j; } int XMapEvent_window(i) XMapEvent* i; { return(i->window); } void set_XMapEvent_window(i, j) XMapEvent* i; int j; { i->window = j; } int XMapEvent_event(i) XMapEvent* i; { return(i->event); } void set_XMapEvent_event(i, j) XMapEvent* i; int j; { i->event = j; } long XMapEvent_display(i) XMapEvent* i; { return((long) i->display); } void set_XMapEvent_display(i, j) XMapEvent* i; long j; { i->display = (Display *) j; } int XMapEvent_send_event(i) XMapEvent* i; { return(i->send_event); } void set_XMapEvent_send_event(i, j) XMapEvent* i; int j; { i->send_event = j; } int XMapEvent_serial(i) XMapEvent* i; { return(i->serial); } void set_XMapEvent_serial(i, j) XMapEvent* i; int j; { i->serial = j; } int XMapEvent_type(i) XMapEvent* i; { return(i->type); } void set_XMapEvent_type(i, j) XMapEvent* i; int j; { i->type = j; } /********* XMapRequestEvent functions *****/ long make_XMapRequestEvent (){ return ((long) calloc(1, sizeof(XMapRequestEvent))); } int XMapRequestEvent_window(i) XMapRequestEvent* i; { return(i->window); } void set_XMapRequestEvent_window(i, j) XMapRequestEvent* i; int j; { i->window = j; } int XMapRequestEvent_parent(i) XMapRequestEvent* i; { return(i->parent); } void set_XMapRequestEvent_parent(i, j) XMapRequestEvent* i; int j; { i->parent = j; } long XMapRequestEvent_display(i) XMapRequestEvent* i; { return((long) i->display); } void set_XMapRequestEvent_display(i, j) XMapRequestEvent* i; long j; { i->display = (Display *) j; } int XMapRequestEvent_send_event(i) XMapRequestEvent* i; { return(i->send_event); } void set_XMapRequestEvent_send_event(i, j) XMapRequestEvent* i; int j; { i->send_event = j; } int XMapRequestEvent_serial(i) XMapRequestEvent* i; { return(i->serial); } void set_XMapRequestEvent_serial(i, j) XMapRequestEvent* i; int j; { i->serial = j; } int XMapRequestEvent_type(i) XMapRequestEvent* i; { return(i->type); } void set_XMapRequestEvent_type(i, j) XMapRequestEvent* i; int j; { i->type = j; } /********* XReparentEvent functions *****/ long make_XReparentEvent (){ return ((long) calloc(1, sizeof(XReparentEvent))); } int XReparentEvent_override_redirect(i) XReparentEvent* i; { return(i->override_redirect); } void set_XReparentEvent_override_redirect(i, j) XReparentEvent* i; int j; { i->override_redirect = j; } int XReparentEvent_y(i) XReparentEvent* i; { return(i->y); } void set_XReparentEvent_y(i, j) XReparentEvent* i; int j; { i->y = j; } int XReparentEvent_x(i) XReparentEvent* i; { return(i->x); } void set_XReparentEvent_x(i, j) XReparentEvent* i; int j; { i->x = j; } int XReparentEvent_parent(i) XReparentEvent* i; { return(i->parent); } void set_XReparentEvent_parent(i, j) XReparentEvent* i; int j; { i->parent = j; } int XReparentEvent_window(i) XReparentEvent* i; { return(i->window); } void set_XReparentEvent_window(i, j) XReparentEvent* i; int j; { i->window = j; } int XReparentEvent_event(i) XReparentEvent* i; { return(i->event); } void set_XReparentEvent_event(i, j) XReparentEvent* i; int j; { i->event = j; } long XReparentEvent_display(i) XReparentEvent* i; { return((long) i->display); } void set_XReparentEvent_display(i, j) XReparentEvent* i; long j; { i->display = (Display *) j; } int XReparentEvent_send_event(i) XReparentEvent* i; { return(i->send_event); } void set_XReparentEvent_send_event(i, j) XReparentEvent* i; int j; { i->send_event = j; } int XReparentEvent_serial(i) XReparentEvent* i; { return(i->serial); } void set_XReparentEvent_serial(i, j) XReparentEvent* i; int j; { i->serial = j; } int XReparentEvent_type(i) XReparentEvent* i; { return(i->type); } void set_XReparentEvent_type(i, j) XReparentEvent* i; int j; { i->type = j; } /********* XConfigureEvent functions *****/ long make_XConfigureEvent (){ return ((long) calloc(1, sizeof(XConfigureEvent))); } int XConfigureEvent_override_redirect(i) XConfigureEvent* i; { return(i->override_redirect); } void set_XConfigureEvent_override_redirect(i, j) XConfigureEvent* i; int j; { i->override_redirect = j; } int XConfigureEvent_above(i) XConfigureEvent* i; { return(i->above); } void set_XConfigureEvent_above(i, j) XConfigureEvent* i; int j; { i->above = j; } int XConfigureEvent_border_width(i) XConfigureEvent* i; { return(i->border_width); } void set_XConfigureEvent_border_width(i, j) XConfigureEvent* i; int j; { i->border_width = j; } int XConfigureEvent_height(i) XConfigureEvent* i; { return(i->height); } void set_XConfigureEvent_height(i, j) XConfigureEvent* i; int j; { i->height = j; } int XConfigureEvent_width(i) XConfigureEvent* i; { return(i->width); } void set_XConfigureEvent_width(i, j) XConfigureEvent* i; int j; { i->width = j; } int XConfigureEvent_y(i) XConfigureEvent* i; { return(i->y); } void set_XConfigureEvent_y(i, j) XConfigureEvent* i; int j; { i->y = j; } int XConfigureEvent_x(i) XConfigureEvent* i; { return(i->x); } void set_XConfigureEvent_x(i, j) XConfigureEvent* i; int j; { i->x = j; } int XConfigureEvent_window(i) XConfigureEvent* i; { return(i->window); } void set_XConfigureEvent_window(i, j) XConfigureEvent* i; int j; { i->window = j; } int XConfigureEvent_event(i) XConfigureEvent* i; { return(i->event); } void set_XConfigureEvent_event(i, j) XConfigureEvent* i; int j; { i->event = j; } long XConfigureEvent_display(i) XConfigureEvent* i; { return((long) i->display); } void set_XConfigureEvent_display(i, j) XConfigureEvent* i; long j; { i->display = (Display *) j; } int XConfigureEvent_send_event(i) XConfigureEvent* i; { return(i->send_event); } void set_XConfigureEvent_send_event(i, j) XConfigureEvent* i; int j; { i->send_event = j; } int XConfigureEvent_serial(i) XConfigureEvent* i; { return(i->serial); } void set_XConfigureEvent_serial(i, j) XConfigureEvent* i; int j; { i->serial = j; } int XConfigureEvent_type(i) XConfigureEvent* i; { return(i->type); } void set_XConfigureEvent_type(i, j) XConfigureEvent* i; int j; { i->type = j; } /********* XGravityEvent functions *****/ long make_XGravityEvent (){ return ((long) calloc(1, sizeof(XGravityEvent))); } int XGravityEvent_y(i) XGravityEvent* i; { return(i->y); } void set_XGravityEvent_y(i, j) XGravityEvent* i; int j; { i->y = j; } int XGravityEvent_x(i) XGravityEvent* i; { return(i->x); } void set_XGravityEvent_x(i, j) XGravityEvent* i; int j; { i->x = j; } int XGravityEvent_window(i) XGravityEvent* i; { return(i->window); } void set_XGravityEvent_window(i, j) XGravityEvent* i; int j; { i->window = j; } int XGravityEvent_event(i) XGravityEvent* i; { return(i->event); } void set_XGravityEvent_event(i, j) XGravityEvent* i; int j; { i->event = j; } long XGravityEvent_display(i) XGravityEvent* i; { return((long) i->display); } void set_XGravityEvent_display(i, j) XGravityEvent* i; long j; { i->display = (Display *) j; } int XGravityEvent_send_event(i) XGravityEvent* i; { return(i->send_event); } void set_XGravityEvent_send_event(i, j) XGravityEvent* i; int j; { i->send_event = j; } int XGravityEvent_serial(i) XGravityEvent* i; { return(i->serial); } void set_XGravityEvent_serial(i, j) XGravityEvent* i; int j; { i->serial = j; } int XGravityEvent_type(i) XGravityEvent* i; { return(i->type); } void set_XGravityEvent_type(i, j) XGravityEvent* i; int j; { i->type = j; } /********* XResizeRequestEvent functions *****/ long make_XResizeRequestEvent (){ return ((long) calloc(1, sizeof(XResizeRequestEvent))); } int XResizeRequestEvent_height(i) XResizeRequestEvent* i; { return(i->height); } void set_XResizeRequestEvent_height(i, j) XResizeRequestEvent* i; int j; { i->height = j; } int XResizeRequestEvent_width(i) XResizeRequestEvent* i; { return(i->width); } void set_XResizeRequestEvent_width(i, j) XResizeRequestEvent* i; int j; { i->width = j; } int XResizeRequestEvent_window(i) XResizeRequestEvent* i; { return(i->window); } void set_XResizeRequestEvent_window(i, j) XResizeRequestEvent* i; int j; { i->window = j; } long XResizeRequestEvent_display(i) XResizeRequestEvent* i; { return((long) i->display); } void set_XResizeRequestEvent_display(i, j) XResizeRequestEvent* i; long j; { i->display = (Display *) j; } int XResizeRequestEvent_send_event(i) XResizeRequestEvent* i; { return(i->send_event); } void set_XResizeRequestEvent_send_event(i, j) XResizeRequestEvent* i; int j; { i->send_event = j; } int XResizeRequestEvent_serial(i) XResizeRequestEvent* i; { return(i->serial); } void set_XResizeRequestEvent_serial(i, j) XResizeRequestEvent* i; int j; { i->serial = j; } int XResizeRequestEvent_type(i) XResizeRequestEvent* i; { return(i->type); } void set_XResizeRequestEvent_type(i, j) XResizeRequestEvent* i; int j; { i->type = j; } /********* XConfigureRequestEvent functions *****/ long make_XConfigureRequestEvent (){ return ((long) calloc(1, sizeof(XConfigureRequestEvent))); } int XConfigureRequestEvent_value_mask(i) XConfigureRequestEvent* i; { return(i->value_mask); } void set_XConfigureRequestEvent_value_mask(i, j) XConfigureRequestEvent* i; int j; { i->value_mask = j; } int XConfigureRequestEvent_detail(i) XConfigureRequestEvent* i; { return(i->detail); } void set_XConfigureRequestEvent_detail(i, j) XConfigureRequestEvent* i; int j; { i->detail = j; } int XConfigureRequestEvent_above(i) XConfigureRequestEvent* i; { return(i->above); } void set_XConfigureRequestEvent_above(i, j) XConfigureRequestEvent* i; int j; { i->above = j; } int XConfigureRequestEvent_border_width(i) XConfigureRequestEvent* i; { return(i->border_width); } void set_XConfigureRequestEvent_border_width(i, j) XConfigureRequestEvent* i; int j; { i->border_width = j; } int XConfigureRequestEvent_height(i) XConfigureRequestEvent* i; { return(i->height); } void set_XConfigureRequestEvent_height(i, j) XConfigureRequestEvent* i; int j; { i->height = j; } int XConfigureRequestEvent_width(i) XConfigureRequestEvent* i; { return(i->width); } void set_XConfigureRequestEvent_width(i, j) XConfigureRequestEvent* i; int j; { i->width = j; } int XConfigureRequestEvent_y(i) XConfigureRequestEvent* i; { return(i->y); } void set_XConfigureRequestEvent_y(i, j) XConfigureRequestEvent* i; int j; { i->y = j; } int XConfigureRequestEvent_x(i) XConfigureRequestEvent* i; { return(i->x); } void set_XConfigureRequestEvent_x(i, j) XConfigureRequestEvent* i; int j; { i->x = j; } int XConfigureRequestEvent_window(i) XConfigureRequestEvent* i; { return(i->window); } void set_XConfigureRequestEvent_window(i, j) XConfigureRequestEvent* i; int j; { i->window = j; } int XConfigureRequestEvent_parent(i) XConfigureRequestEvent* i; { return(i->parent); } void set_XConfigureRequestEvent_parent(i, j) XConfigureRequestEvent* i; int j; { i->parent = j; } long XConfigureRequestEvent_display(i) XConfigureRequestEvent* i; { return((long) i->display); } void set_XConfigureRequestEvent_display(i, j) XConfigureRequestEvent* i; long j; { i->display = (Display *) j; } int XConfigureRequestEvent_send_event(i) XConfigureRequestEvent* i; { return(i->send_event); } void set_XConfigureRequestEvent_send_event(i, j) XConfigureRequestEvent* i; int j; { i->send_event = j; } int XConfigureRequestEvent_serial(i) XConfigureRequestEvent* i; { return(i->serial); } void set_XConfigureRequestEvent_serial(i, j) XConfigureRequestEvent* i; int j; { i->serial = j; } int XConfigureRequestEvent_type(i) XConfigureRequestEvent* i; { return(i->type); } void set_XConfigureRequestEvent_type(i, j) XConfigureRequestEvent* i; int j; { i->type = j; } /********* XCirculateEvent functions *****/ long make_XCirculateEvent (){ return ((long) calloc(1, sizeof(XCirculateEvent))); } int XCirculateEvent_place(i) XCirculateEvent* i; { return(i->place); } void set_XCirculateEvent_place(i, j) XCirculateEvent* i; int j; { i->place = j; } int XCirculateEvent_window(i) XCirculateEvent* i; { return(i->window); } void set_XCirculateEvent_window(i, j) XCirculateEvent* i; int j; { i->window = j; } int XCirculateEvent_event(i) XCirculateEvent* i; { return(i->event); } void set_XCirculateEvent_event(i, j) XCirculateEvent* i; int j; { i->event = j; } long XCirculateEvent_display(i) XCirculateEvent* i; { return((long) i->display); } void set_XCirculateEvent_display(i, j) XCirculateEvent* i; long j; { i->display = (Display *) j; } int XCirculateEvent_send_event(i) XCirculateEvent* i; { return(i->send_event); } void set_XCirculateEvent_send_event(i, j) XCirculateEvent* i; int j; { i->send_event = j; } int XCirculateEvent_serial(i) XCirculateEvent* i; { return(i->serial); } void set_XCirculateEvent_serial(i, j) XCirculateEvent* i; int j; { i->serial = j; } int XCirculateEvent_type(i) XCirculateEvent* i; { return(i->type); } void set_XCirculateEvent_type(i, j) XCirculateEvent* i; int j; { i->type = j; } /********* XCirculateRequestEvent functions *****/ long make_XCirculateRequestEvent (){ return ((long) calloc(1, sizeof(XCirculateRequestEvent))); } int XCirculateRequestEvent_place(i) XCirculateRequestEvent* i; { return(i->place); } void set_XCirculateRequestEvent_place(i, j) XCirculateRequestEvent* i; int j; { i->place = j; } int XCirculateRequestEvent_window(i) XCirculateRequestEvent* i; { return(i->window); } void set_XCirculateRequestEvent_window(i, j) XCirculateRequestEvent* i; int j; { i->window = j; } int XCirculateRequestEvent_parent(i) XCirculateRequestEvent* i; { return(i->parent); } void set_XCirculateRequestEvent_parent(i, j) XCirculateRequestEvent* i; int j; { i->parent = j; } long XCirculateRequestEvent_display(i) XCirculateRequestEvent* i; { return((long) i->display); } void set_XCirculateRequestEvent_display(i, j) XCirculateRequestEvent* i; long j; { i->display = (Display *) j; } int XCirculateRequestEvent_send_event(i) XCirculateRequestEvent* i; { return(i->send_event); } void set_XCirculateRequestEvent_send_event(i, j) XCirculateRequestEvent* i; int j; { i->send_event = j; } int XCirculateRequestEvent_serial(i) XCirculateRequestEvent* i; { return(i->serial); } void set_XCirculateRequestEvent_serial(i, j) XCirculateRequestEvent* i; int j; { i->serial = j; } int XCirculateRequestEvent_type(i) XCirculateRequestEvent* i; { return(i->type); } void set_XCirculateRequestEvent_type(i, j) XCirculateRequestEvent* i; int j; { i->type = j; } /********* XPropertyEvent functions *****/ long make_XPropertyEvent (){ return ((long) calloc(1, sizeof(XPropertyEvent))); } int XPropertyEvent_state(i) XPropertyEvent* i; { return(i->state); } void set_XPropertyEvent_state(i, j) XPropertyEvent* i; int j; { i->state = j; } int XPropertyEvent_time(i) XPropertyEvent* i; { return(i->time); } void set_XPropertyEvent_time(i, j) XPropertyEvent* i; int j; { i->time = j; } int XPropertyEvent_atom(i) XPropertyEvent* i; { return(i->atom); } void set_XPropertyEvent_atom(i, j) XPropertyEvent* i; int j; { i->atom = j; } int XPropertyEvent_window(i) XPropertyEvent* i; { return(i->window); } void set_XPropertyEvent_window(i, j) XPropertyEvent* i; int j; { i->window = j; } long XPropertyEvent_display(i) XPropertyEvent* i; { return((long) i->display); } void set_XPropertyEvent_display(i, j) XPropertyEvent* i; long j; { i->display = (Display *) j; } int XPropertyEvent_send_event(i) XPropertyEvent* i; { return(i->send_event); } void set_XPropertyEvent_send_event(i, j) XPropertyEvent* i; int j; { i->send_event = j; } int XPropertyEvent_serial(i) XPropertyEvent* i; { return(i->serial); } void set_XPropertyEvent_serial(i, j) XPropertyEvent* i; int j; { i->serial = j; } int XPropertyEvent_type(i) XPropertyEvent* i; { return(i->type); } void set_XPropertyEvent_type(i, j) XPropertyEvent* i; int j; { i->type = j; } /********* XSelectionClearEvent functions *****/ long make_XSelectionClearEvent (){ return ((long) calloc(1, sizeof(XSelectionClearEvent))); } int XSelectionClearEvent_time(i) XSelectionClearEvent* i; { return(i->time); } void set_XSelectionClearEvent_time(i, j) XSelectionClearEvent* i; int j; { i->time = j; } int XSelectionClearEvent_selection(i) XSelectionClearEvent* i; { return(i->selection); } void set_XSelectionClearEvent_selection(i, j) XSelectionClearEvent* i; int j; { i->selection = j; } int XSelectionClearEvent_window(i) XSelectionClearEvent* i; { return(i->window); } void set_XSelectionClearEvent_window(i, j) XSelectionClearEvent* i; int j; { i->window = j; } long XSelectionClearEvent_display(i) XSelectionClearEvent* i; { return((long) i->display); } void set_XSelectionClearEvent_display(i, j) XSelectionClearEvent* i; long j; { i->display = (Display *) j; } int XSelectionClearEvent_send_event(i) XSelectionClearEvent* i; { return(i->send_event); } void set_XSelectionClearEvent_send_event(i, j) XSelectionClearEvent* i; int j; { i->send_event = j; } int XSelectionClearEvent_serial(i) XSelectionClearEvent* i; { return(i->serial); } void set_XSelectionClearEvent_serial(i, j) XSelectionClearEvent* i; int j; { i->serial = j; } int XSelectionClearEvent_type(i) XSelectionClearEvent* i; { return(i->type); } void set_XSelectionClearEvent_type(i, j) XSelectionClearEvent* i; int j; { i->type = j; } /********* XSelectionRequestEvent functions *****/ long make_XSelectionRequestEvent (){ return ((long) calloc(1, sizeof(XSelectionRequestEvent))); } int XSelectionRequestEvent_time(i) XSelectionRequestEvent* i; { return(i->time); } void set_XSelectionRequestEvent_time(i, j) XSelectionRequestEvent* i; int j; { i->time = j; } int XSelectionRequestEvent_property(i) XSelectionRequestEvent* i; { return(i->property); } void set_XSelectionRequestEvent_property(i, j) XSelectionRequestEvent* i; int j; { i->property = j; } int XSelectionRequestEvent_target(i) XSelectionRequestEvent* i; { return(i->target); } void set_XSelectionRequestEvent_target(i, j) XSelectionRequestEvent* i; int j; { i->target = j; } int XSelectionRequestEvent_selection(i) XSelectionRequestEvent* i; { return(i->selection); } void set_XSelectionRequestEvent_selection(i, j) XSelectionRequestEvent* i; int j; { i->selection = j; } int XSelectionRequestEvent_requestor(i) XSelectionRequestEvent* i; { return(i->requestor); } void set_XSelectionRequestEvent_requestor(i, j) XSelectionRequestEvent* i; int j; { i->requestor = j; } int XSelectionRequestEvent_owner(i) XSelectionRequestEvent* i; { return(i->owner); } void set_XSelectionRequestEvent_owner(i, j) XSelectionRequestEvent* i; int j; { i->owner = j; } long XSelectionRequestEvent_display(i) XSelectionRequestEvent* i; { return((long) i->display); } void set_XSelectionRequestEvent_display(i, j) XSelectionRequestEvent* i; long j; { i->display = (Display *) j; } int XSelectionRequestEvent_send_event(i) XSelectionRequestEvent* i; { return(i->send_event); } void set_XSelectionRequestEvent_send_event(i, j) XSelectionRequestEvent* i; int j; { i->send_event = j; } int XSelectionRequestEvent_serial(i) XSelectionRequestEvent* i; { return(i->serial); } void set_XSelectionRequestEvent_serial(i, j) XSelectionRequestEvent* i; int j; { i->serial = j; } int XSelectionRequestEvent_type(i) XSelectionRequestEvent* i; { return(i->type); } void set_XSelectionRequestEvent_type(i, j) XSelectionRequestEvent* i; int j; { i->type = j; } /********* XSelectionEvent functions *****/ long make_XSelectionEvent (){ return ((long) calloc(1, sizeof(XSelectionEvent))); } int XSelectionEvent_time(i) XSelectionEvent* i; { return(i->time); } void set_XSelectionEvent_time(i, j) XSelectionEvent* i; int j; { i->time = j; } int XSelectionEvent_property(i) XSelectionEvent* i; { return(i->property); } void set_XSelectionEvent_property(i, j) XSelectionEvent* i; int j; { i->property = j; } int XSelectionEvent_target(i) XSelectionEvent* i; { return(i->target); } void set_XSelectionEvent_target(i, j) XSelectionEvent* i; int j; { i->target = j; } int XSelectionEvent_selection(i) XSelectionEvent* i; { return(i->selection); } void set_XSelectionEvent_selection(i, j) XSelectionEvent* i; int j; { i->selection = j; } int XSelectionEvent_requestor(i) XSelectionEvent* i; { return(i->requestor); } void set_XSelectionEvent_requestor(i, j) XSelectionEvent* i; int j; { i->requestor = j; } long XSelectionEvent_display(i) XSelectionEvent* i; { return((long) i->display); } void set_XSelectionEvent_display(i, j) XSelectionEvent* i; long j; { i->display = (Display *) j; } int XSelectionEvent_send_event(i) XSelectionEvent* i; { return(i->send_event); } void set_XSelectionEvent_send_event(i, j) XSelectionEvent* i; int j; { i->send_event = j; } int XSelectionEvent_serial(i) XSelectionEvent* i; { return(i->serial); } void set_XSelectionEvent_serial(i, j) XSelectionEvent* i; int j; { i->serial = j; } int XSelectionEvent_type(i) XSelectionEvent* i; { return(i->type); } void set_XSelectionEvent_type(i, j) XSelectionEvent* i; int j; { i->type = j; } /********* XColormapEvent functions *****/ long make_XColormapEvent (){ return ((long) calloc(1, sizeof(XColormapEvent))); } int XColormapEvent_state(i) XColormapEvent* i; { return(i->state); } void set_XColormapEvent_state(i, j) XColormapEvent* i; int j; { i->state = j; } int XColormapEvent_new(i) XColormapEvent* i; { return(i->new); } void set_XColormapEvent_new(i, j) XColormapEvent* i; int j; { i->new = j; } int XColormapEvent_colormap(i) XColormapEvent* i; { return(i->colormap); } void set_XColormapEvent_colormap(i, j) XColormapEvent* i; int j; { i->colormap = j; } int XColormapEvent_window(i) XColormapEvent* i; { return(i->window); } void set_XColormapEvent_window(i, j) XColormapEvent* i; int j; { i->window = j; } long XColormapEvent_display(i) XColormapEvent* i; { return((long) i->display); } void set_XColormapEvent_display(i, j) XColormapEvent* i; long j; { i->display = (Display *) j; } int XColormapEvent_send_event(i) XColormapEvent* i; { return(i->send_event); } void set_XColormapEvent_send_event(i, j) XColormapEvent* i; int j; { i->send_event = j; } int XColormapEvent_serial(i) XColormapEvent* i; { return(i->serial); } void set_XColormapEvent_serial(i, j) XColormapEvent* i; int j; { i->serial = j; } int XColormapEvent_type(i) XColormapEvent* i; { return(i->type); } void set_XColormapEvent_type(i, j) XColormapEvent* i; int j; { i->type = j; } /********* XClientMessageEvent functions *****/ long make_XClientMessageEvent (){ return ((long) calloc(1, sizeof(XClientMessageEvent))); } int XClientMessageEvent_format(i) XClientMessageEvent* i; { return(i->format); } void set_XClientMessageEvent_format(i, j) XClientMessageEvent* i; int j; { i->format = j; } int XClientMessageEvent_message_type(i) XClientMessageEvent* i; { return(i->message_type); } void set_XClientMessageEvent_message_type(i, j) XClientMessageEvent* i; int j; { i->message_type = j; } int XClientMessageEvent_window(i) XClientMessageEvent* i; { return(i->window); } void set_XClientMessageEvent_window(i, j) XClientMessageEvent* i; int j; { i->window = j; } long XClientMessageEvent_display(i) XClientMessageEvent* i; { return((long) i->display); } void set_XClientMessageEvent_display(i, j) XClientMessageEvent* i; long j; { i->display = (Display *) j; } int XClientMessageEvent_send_event(i) XClientMessageEvent* i; { return(i->send_event); } void set_XClientMessageEvent_send_event(i, j) XClientMessageEvent* i; int j; { i->send_event = j; } int XClientMessageEvent_serial(i) XClientMessageEvent* i; { return(i->serial); } void set_XClientMessageEvent_serial(i, j) XClientMessageEvent* i; int j; { i->serial = j; } int XClientMessageEvent_type(i) XClientMessageEvent* i; { return(i->type); } void set_XClientMessageEvent_type(i, j) XClientMessageEvent* i; int j; { i->type = j; } /********* XMappingEvent functions *****/ long make_XMappingEvent (){ return ((long) calloc(1, sizeof(XMappingEvent))); } int XMappingEvent_count(i) XMappingEvent* i; { return(i->count); } void set_XMappingEvent_count(i, j) XMappingEvent* i; int j; { i->count = j; } int XMappingEvent_first_keycode(i) XMappingEvent* i; { return(i->first_keycode); } void set_XMappingEvent_first_keycode(i, j) XMappingEvent* i; int j; { i->first_keycode = j; } int XMappingEvent_request(i) XMappingEvent* i; { return(i->request); } void set_XMappingEvent_request(i, j) XMappingEvent* i; int j; { i->request = j; } int XMappingEvent_window(i) XMappingEvent* i; { return(i->window); } void set_XMappingEvent_window(i, j) XMappingEvent* i; int j; { i->window = j; } long XMappingEvent_display(i) XMappingEvent* i; { return((long) i->display); } void set_XMappingEvent_display(i, j) XMappingEvent* i; long j; { i->display = (Display *) j; } int XMappingEvent_send_event(i) XMappingEvent* i; { return(i->send_event); } void set_XMappingEvent_send_event(i, j) XMappingEvent* i; int j; { i->send_event = j; } int XMappingEvent_serial(i) XMappingEvent* i; { return(i->serial); } void set_XMappingEvent_serial(i, j) XMappingEvent* i; int j; { i->serial = j; } int XMappingEvent_type(i) XMappingEvent* i; { return(i->type); } void set_XMappingEvent_type(i, j) XMappingEvent* i; int j; { i->type = j; } /********* XErrorEvent functions *****/ long make_XErrorEvent (){ return ((long) calloc(1, sizeof(XErrorEvent))); } char XErrorEvent_minor_code(i) XErrorEvent* i; { return(i->minor_code); } void set_XErrorEvent_minor_code(i, j) XErrorEvent* i; char j; { i->minor_code = j; } char XErrorEvent_request_code(i) XErrorEvent* i; { return(i->request_code); } void set_XErrorEvent_request_code(i, j) XErrorEvent* i; char j; { i->request_code = j; } char XErrorEvent_error_code(i) XErrorEvent* i; { return(i->error_code); } void set_XErrorEvent_error_code(i, j) XErrorEvent* i; char j; { i->error_code = j; } int XErrorEvent_serial(i) XErrorEvent* i; { return(i->serial); } void set_XErrorEvent_serial(i, j) XErrorEvent* i; int j; { i->serial = j; } int XErrorEvent_resourceid(i) XErrorEvent* i; { return(i->resourceid); } void set_XErrorEvent_resourceid(i, j) XErrorEvent* i; int j; { i->resourceid = j; } long XErrorEvent_display(i) XErrorEvent* i; { return((long) i->display); } void set_XErrorEvent_display(i, j) XErrorEvent* i; long j; { i->display = (Display *) j; } int XErrorEvent_type(i) XErrorEvent* i; { return(i->type); } void set_XErrorEvent_type(i, j) XErrorEvent* i; int j; { i->type = j; } /********* XAnyEvent functions *****/ long make_XAnyEvent (){ return ((long) calloc(1, sizeof(XAnyEvent))); } int XAnyEvent_window(i) XAnyEvent* i; { return(i->window); } void set_XAnyEvent_window(i, j) XAnyEvent* i; int j; { i->window = j; } long XAnyEvent_display(i) XAnyEvent* i; { return((long) i->display); } void set_XAnyEvent_display(i, j) XAnyEvent* i; long j; { i->display = (Display *) j; } int XAnyEvent_send_event(i) XAnyEvent* i; { return(i->send_event); } void set_XAnyEvent_send_event(i, j) XAnyEvent* i; int j; { i->send_event = j; } int XAnyEvent_serial(i) XAnyEvent* i; { return(i->serial); } void set_XAnyEvent_serial(i, j) XAnyEvent* i; int j; { i->serial = j; } int XAnyEvent_type(i) XAnyEvent* i; { return(i->type); } void set_XAnyEvent_type(i, j) XAnyEvent* i; int j; { i->type = j; } /********* XEvent functions *****/ long make_XEvent (){ return ((long) calloc(1, sizeof(XEvent))); } gcl-2.6.14/xgcl-2/gcl_editors.lsp0000644000175000017500000004330514360276512015112 0ustar cammcamm; editors.lsp Gordon S. Novak Jr. ; 08 Dec 08 ; Copyright (c) 2008 Gordon S. Novak Jr. and The University of Texas at Austin. ; 13 Apr 95; 02 Jan 97; 28 Feb 02; 08 Jan 04; 03 Mar 04; 26 Jan 06; 27 Jan 06 ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Graphical editor functions ; (edit-thermom 75 myw 20 20 150 250) ; (window-draw-thermometer myw 0 20 5 50 50 50 232) ; (window-adjust-thermometer myw 0 20 5 50 50 50 232) ; 20 Nov 91; 03 Dec 91; 27 Dec 91; 26 Dec 93; 28 Feb 02; 08 Jan 04 ; Edit an integer with a thermometer-like display (gldefun edit-thermom ((num number) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (prog (nmin ndel ndiv range pten drange pair neww (res num) off) (if ~ sizex (progn (sizex = 150) (sizey = 250))) (if ~ offsetx (progn (off = (centeroffset w (a vector with x = sizex y = sizey))) (offsetx = (x off)) (offsety = (y off)))) (neww = (window-create sizex sizey nil (parent w) offsetx offsety)) (window-draw-button neww "Typein" 80 20 50 25) (window-draw-button neww "Adjust" 80 70 50 25) (window-draw-button neww "Done" 80 120 50 25) rn (range = (abs res) * 2) (if (range == 0) (range = 50)) (if ((range < 8) and (integerp num)) (range = 10)) (pten = (expt 10 (truncate (log range 10)))) (drange = (range * 10) / pten) (setq pair (car (some #'(lambda (x) (> (car x) drange)) '((14 2) (20 4) (40 5) (70 10) (101 20))))) (setq ndel ((cadr pair) * pten / 10)) (setq ndiv (ceiling (range / ndel))) (setq nmin (if (>= res 0) 0 (- ndel * ndiv))) (window-draw-thermometer neww nmin ndel ndiv res 10 10 (sizey - 20)) lp (case (button-select neww '((done (84 124) (42 17)) (adjust (84 74) (42 17)) (typein (84 24) (42 17)))) (done (destroy neww) (return res)) (adjust (setq res (window-adjust-thermometer neww nmin ndel ndiv res 10 10 (sizey - 20))) (go lp)) (typein (princ "Enter new value: ") (setq res (read)) (if ((res >= nmin) and (res <= (nmin + ndel * ndiv))) (progn (window-set-thermometer neww nmin ndel ndiv res 10 10 (sizey - 20)) (go lp)) (go rn)) ) ) )) ; 20 Nov 91; 04 Dec 91 ; Draw a button-like icon (gldefun window-draw-button ((w window) (s string) (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (sw) (erase-area-xy w offsetx offsety sizex sizey 8) (draw-rcbox-xy w offsetx offsety sizex sizey 8) (sw = (string-width w s)) (printat-xy w s (offsetx + (sizex - sw) / 2) (offsety + 8)) (force-output w))) ; 17 Dec 91 ; Print in the center of a specified region (gldefun window-center-print ((w window) (s string) (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (sw) (erase-area-xy w offsetx offsety sizex sizey 8) (sw = (string-width w s)) (printat-xy w s (offsetx + (sizex - sw) / 2) (offsety + (sizey - 10) / 2) ) (force-output w))) ; 20 Nov 91; 03 Dec 91; 26 Dec 93 ; Draw a thermometer-like icon (gldefun window-draw-thermometer ((w window) (nmin integer) (ndel integer) (ndiv integer) (val number) (offsetx integer) (offsety integer) (sizey integer)) (let (hdel marky) (erase-area-xy w offsetx offsety 66 sizey) (editors-print-in-box val w offsetx offsety 40 20) (draw-arc-xy w (offsetx + 12) (offsety + 36) 12 12 132 276) (draw-line-xy w (offsetx + 4) (offsety + 44) (offsetx + 4) (offsety + sizey - 8) ) (draw-line-xy w (offsetx + 20) (offsety + 44) (offsetx + 20) (offsety + sizey - 8) ) (draw-arc-xy w (offsetx + 12) (offsety + sizey - 8) 8 8 0 180) (draw-circle-xy w (offsetx + 12) (offsety + 36) 4 7) (hdel = (sizey - 56) / ndiv) (draw-line-xy w (offsetx + 12) (offsety + 35) (offsetx + 12) (offsety + 48 + hdel * ((val - nmin) / ndel)) 7) (dotimes (i (1+ ndiv)) (marky = (offsety + 48 + i * hdel)) (draw-line-xy w (offsetx + 24) marky (offsetx + 34) marky) (printat-xy w (nmin + i * ndel) (offsetx + 36) (marky - 6)) ) (force-output w))) ; 20 Nov 91; 03 Dec 91; 13 Apr 95 ; Draw value for a thermometer-like icon (gldefun window-set-thermometer ((w window) (nmin integer) (ndel integer) (ndiv integer) (val number) (offsetx integer) (offsety integer) (sizey integer)) (let (hdel) (hdel = (sizey - 56) / ndiv) (erase-area-xy w (offsetx + 7) (offsety + 48) 10 (sizey - 56)) (draw-line-xy w (offsetx + 12) (offsety + 35) (offsetx + 12) (offsety + 48 + hdel * ((val - nmin) / ndel)) 7) (editors-update-in-box val w offsetx offsety 40 20)))) ; 20 Nov 91; 03 Dec 91; 15 Oct 93; 02 Dec 93; 08 Jan 04 ; Adjust a thermometer-like icon with the mouse. Returns new value. (gldefun window-adjust-thermometer ((w window) (nmin integer) (ndel integer) (ndiv integer) (val number) (offsetx integer) (offsety integer) (sizey integer)) (let (hdel (lasty integer) xmin xmax ymin ymax inside (newval number)) (hdel = (sizey - 56) / ndiv) (lasty = (truncate (offsety + 48 + hdel * ((val - nmin) / ndel)))) (xmin = offsetx + 4) (xmax = offsetx + 20) (ymin = offsety + 48) (ymax = offsety + sizey - 8) (window-track-mouse w #'(lambda (x y code) (inside = (and (>= x xmin) (<= x xmax) (>= y ymin) (<= y ymax))) (when (and inside (/= y lasty)) (if (> y lasty) (draw-line-xy w (offsetx + 12) lasty (offsetx + 12) y 7) (erase-area-xy w (offsetx + 7) (y + 1) 10 (- lasty y))) (lasty = y) (newval = ( ( (lasty - (offsety + 48)) / (float hdel)) * ndel) + nmin) (if (integerp val) (newval = (truncate newval))) (editors-update-in-box newval w offsetx offsety 40 20)) (not (zerop code)))) (if inside newval val) )) ; 20 Nov 91; 15 Oct 93; 08 Jan 04; 26 Jan 06 ; Get a mouse selection from a button area. cf. picmenu-select (gldefun button-select ((mw window) (buttons (listof picmenu-button))) (let ((current-button picmenu-button) item items (val picmenu-button) xzero yzero inside) (xzero = 0) ; (menu-x m 0) (yzero = 0) ; (menu-y m 0) (track-mouse mw #'(lambda (x y code) (x = (x - xzero)) (y = (y - yzero)) (if ((x >= 0) and (y >= 0)) (inside = t)) (if current-button (if ~ (button-containsxy? current-button x y) (progn (button-invert mw current-button) (current-button = nil)))) (if ~ current-button (progn (items = buttons) (while ~ current-button and (item -_ items) do (if (button-containsxy? item x y) (progn (current-button = item) (button-invert mw current-button) ))))) (if (> code 0) (progn (if current-button (button-invert mw current-button) ) (val = (or current-button *picmenu-no-selection*)) ))) t) (if (val <> *picmenu-no-selection*) (buttonname val)) )) ; 03 Dec 91 (gldefun button-invert ((w window) (button picmenu-button)) (window-invert-area w (offset button) (size button)) ) (gldefun window-undraw-box ((w window) offset size &optional lw) (set-erase w) (window-draw-box w offset size lw) (unset w) ) ; 20 Nov 91; 08 Jan 04 (gldefun button-containsxy? ((b picmenu-button) (x integer) (y integer)) (let ((xsize 6) (ysize 6)) (if (size b) (progn (xsize = (x (size b))) (ysize = (y (size b))))) ((x >= (x (offset b))) and (x <= ((x (offset b)) + xsize)) and (y >= (y (offset b))) and (y <= ((y (offset b)) + ysize)) ) )) (glispobjects (menu-item (z anything) prop ((value ((if z is atomic z (cdr z)))) ) msg ((print-size menu-item-print-size) (draw menu-item-draw)) ) ) ; glispobjects (gldefun menu-item-print-size ((item menu-item) (w window)) (result vector) (let (siz) (if item is atomic (a vector with x = (string-width w item) y = 11) (if (car item) is a string (a vector with x = (string-width w (car item)) y = 11) (if ((symbolp (car item)) and (siz = (get (car item) 'display-size))) siz (a vector with x = 50 y = 11)))) )) ; 17 Dec 91; 08 Jan 04 (gldefun menu-item-draw ((item menu-item) (w window) (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (if item is atomic (window-center-print w item offsetx offsety sizex sizey) (if ((symbolp (car item)) and (fboundp (car item))) (funcall (car item) w offsetx offsety) (window-center-print w (car item) offsetx offsety sizex sizey))) ) ; 03 Dec 91; 26 Dec 93; 08 Jan 04 (gldefun pick-one-size ((items (listof menu-item)) (w window)) (let (wid) (for item in items do (wid = (if wid (max wid (x (print-size item w))) (x (print-size item w))) ) ) (a vector with x = wid y = 11) )) ; 03 Dec 91; 26 Dec 93; 29 Jul 94; 28 Feb 02 (gldefun draw-pick-one ((items (listof menu-item)) (val anything) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (itm) (if (itm = (that item with (value (that item)) == val)) (draw itm w offsetx offsety sizex sizey)))) ; 04 Dec 91; 26 Dec 93; 29 Jul 94; 08 Jan 04 (gldefun edit-pick-one ((items (listof menu-item)) (val anything) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (newval) (if ((length items) <= 3) (if (equal val (value (first items))) (newval = (value (second items))) (if (equal val (value (second items))) (newval = (if (third items) (value (third items)) (value (first items)))) (newval = (value (first items))))) (newval = (menu items)) ) (draw-pick-one newval w items offsetx offsety sizex sizey) newval )) ; 13 Dec 91; 26 Dec 93; 28 Jul 94; 28 Feb 02; 08 Jan 04 (gldefun draw-black-white ((items (listof menu-item)) (val anything) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (itm) (erase-area-xy w offsetx offsety sizex sizey) (if (itm = (that item with (value (that item)) == val)) (if (eql (if (consp itm) (car itm) itm) 1) (invert-area-xy w offsetx offsety sizex sizey)) ) )) ; 13 Dec 91; 15 Dec 91; 26 Dec 93; 28 Jul 94; 08 Jan 04 (gldefun edit-black-white ((items (listof menu-item)) (val anything) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (let (newval) (if (equal val (value (first items))) (newval = (value (second items))) (if (equal val (value (second items))) (newval = (value (first items))))) (draw-black-white items newval w offsetx offsety sizex sizey) newval )) ; 23 Dec 91; 26 Dec 93 (gldefun draw-integer ((val integer) (w window) &optional (offsetx integer) (offsety integer) (sizex integer) (sizey integer)) (editors-anything-print val w offsetx offsety sizex sizey) ) ; 24 Dec 91; 26 Dec 93 (defun draw-real (val w &optional offsetx offsety sizex sizey) (let (str nc lng fmt) (if (null sizex) (setq sizex 50)) (setq nc (max 1 (truncate sizex 7))) (setq str (princ-to-string val)) (setq lng (length str)) (if (> lng nc) (if (or (find #\. str :start nc) (find #\E str) (find #\L str)) (if (>= nc 8) (progn (setq fmt (cadr (or (assoc nc '((8 "~8,2E") (9 "~9,2E") (10 "~10,2E") (11 "~11,2E") (12 "~12,2E") (13 "~13,2E") (14 "~14,2E"))) '(15 "~15,2E")))) (setq str (format nil fmt val))) (setq str "*******")) (setq str (subseq str 0 nc)) )) (editors-anything-print w str offsetx offsety sizex sizey) )) ; 09 Dec 91; 10 Dec 91; 23 Dec 91; 26 Dec 93; 22 Jul 94 ; Display function for use when a more specific one is not found. (gldefun editors-anything-print (obj (w window) offsetx offsety sizex sizey) (let ((s (stringify obj)) swidth smax dx dy) (erase-area-xy w offsetx offsety sizex sizey) (swidth = (string-width w s)) (smax = (min swidth sizex)) (dx = (sizex - smax) / 2) (dy = (max 0 ((sizey - 10) / 2))) (printat-xy w (editors-string-limit obj w smax) (offsetx + dx) (offsety + dy)) )) ; 26 Dec 93 (gldefun editors-print-in-box (obj (w window) offsetx offsety sizex sizey) (printat-xy w (editors-string-limit obj w sizex) (offsetx + 4) (offsety + (sizey - 10) / 2)) (draw-box-xy w offsetx offsety sizex sizey) ) ; 26 Dec 93 (gldefun editors-update-in-box (obj (w window) offsetx offsety sizex sizey) (erase-area-xy w (offsetx + 3) (offsety + 3) (sizex - 6) (sizey - 6)) (printat-xy w (editors-string-limit obj w sizex) (offsetx + 4) (offsety + (sizey - 10) / 2)) ) ; 28 Oct 91; 26 Dec 93; 08 Jan 04 ; Limit string to a specified number of pixels (gldefun editors-string-limit ((s string) (w window) (max integer)) (result string) (let ((str (stringify s)) (lng integer) (nc integer)) (lng = (string-width w str)) (if (lng > max) (progn (nc = (((length str) * max) / lng)) (subseq str 0 nc)) str) )) (defvar *edit-color-menu-set* nil) (defvar *edit-color-rmenu* nil) (defvar *edit-color-old-color* nil) (glispglobals (*edit-color-menu-set* menu-set) (*edit-color-rmenu* barmenu)) ; 03 Jan 94; 04 Jan 94; 05 Jan 94; 08 Dec 08 (gldefun edit-color-init ((w window)) (let (rm gm bm rgb) (rgb = (a rgb)) (glcc 'edit-color-red) (glcc 'edit-color-green) (glcc 'edit-color-blue) (*edit-color-menu-set* = (menu-set-create w nil)) (rm = (barmenu-create 256 200 10 "" nil #'edit-color-red (list rgb) w 120 40 nil t (a rgb with red = 65535))) (*edit-color-rmenu* = rm) (gm = (barmenu-create 256 50 10 "" nil #'edit-color-green (list rgb) w 170 40 nil t (a rgb with green = 65535))) (bm = (barmenu-create 256 250 10 "" nil #'edit-color-blue (list rgb) w 220 40 nil t (a rgb with blue = 65535))) (add-barmenu *edit-color-menu-set* 'red nil rm "Red" '(120 40)) (add-barmenu *edit-color-menu-set* 'green nil gm "Green" '(170 40)) (add-barmenu *edit-color-menu-set* 'blue nil bm "Blue" '(220 40)) (add-menu *edit-color-menu-set* 'done nil "" '(("Done" . done)) '(30 150)) (edit-color-red 200 rgb) (edit-color-green 50 rgb) (edit-color-blue 250 rgb) )) ; 03 Jan 94; 04 Jan 94 (gldefun edit-color-red ((val integer) (color rgb)) (let ((w (window *edit-color-menu-set*))) (printat-xy w (format nil "~3D" val) 113 20) ((red color) = (max 0 (val * 256 - 1))) (edit-display-color w color) )) ; 03 Jan 94; 04 Jan 94 (gldefun edit-color-green ((val integer) (color rgb)) (let ((w (window *edit-color-menu-set*))) (printat-xy w (format nil "~3D" val) 163 20) ((green color) = (max 0 (val * 256 - 1))) (edit-display-color w color) )) ; 03 Jan 94; 04 Jan 94 (gldefun edit-color-blue ((val integer) (color rgb)) (let ((w (window *edit-color-menu-set*))) (printat-xy w (format nil "~3D" val) 213 20) ((blue color) = (max 0 (val * 256 - 1))) (edit-display-color w color) )) ; 03 Jan 94 (gldefun edit-display-color ((w window) (color rgb)) (window-set-color w color) (window-draw-line-xy w 50 40 50 100 60) (window-reset-color w) (if *edit-color-old-color* (window-free-color w *edit-color-old-color*)) (*edit-color-old-color* = *window-xcolor*) ) ; 03 Jan 94; 04 Jan 94; 05 Jan 94; 28 Feb 02 (gldefun edit-color ((w window)) (let (done (color rgb) sel) (if (or (null *edit-color-menu-set*) (not (eq w (menu-window (menu (first (menu-items *edit-color-menu-set*))))))) (edit-color-init w)) (color = (first (subtrackparms *edit-color-rmenu*))) (draw *edit-color-menu-set*) (edit-color-red (truncate (1+ (red color)) 256) color) (edit-color-green (truncate (1+ (green color)) 256) color) (edit-color-blue (truncate (1+ (blue color)) 256) color) (while ~ done (sel = (select *edit-color-menu-set*)) (done = (and sel ((first sel) == 'done))) ) color)) ; 08 Dec 08 (gldefun color-dot ((w window) (x integer) (y integer) (color symbol)) (let (rgb) (setq rgb (cdr (assoc color '((red 65535 0 0) (yellow 65535 57600 0) (green 0 50175 12287) (blue 0 0 65535))))) (or rgb (setq rgb '(30000 30000 30000))) (set-color w rgb) (draw-dot-xy w x y) (reset-color w) )) ; 15 Oct 93; 26 Jan 06 ; Compile the editors.lsp file into a plain Lisp file (defun compile-editors () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp") '("glisp/editors.lsp") ; translated files "glisp/editorstrans.lsp" ; output file "glisp/gpl.txt") ; header file (cf editorstrans) ) ; Compile the editors.lsp file into a plain Lisp file for XGCL (defun compile-editorsb () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/editors.lsp") ; translated files "glisp/editorstrans.lsp" ; output file "glisp/gpl.txt") ; header file ) gcl-2.6.14/xgcl-2/gcl_dwtrans.lsp0000644000175000017500000032452314360276512015127 0ustar cammcamm; 13 Jan 2010 17:40:33 EST ; dwtrans.lsp -- translation of dwindow.lsp ; 07 Jan 10 ; Copyright (c) 2010 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (in-package :xlib) (defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) (setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer) (setf (get 'xlib::fixnum-pos 'user::glfnresulttype) 'lisp::integer) ; exported symbols: from dwimports.lsp (dolist (x '( menu stringify window picmenu textmenu editmenu barmenu display-size window-get-mouse-position window-create window-set-font window-font-info window-gcontext window-parent window-drawable-height window-drawable-width window-label window-font window-foreground window-set-foreground window-background window-set-background window-wfunction window-get-geometry window-get-geometry-b window-sync window-screen-height window-geometry window-size window-left window-top-neg-y window-reset-geometry window-force-output window-query-pointer window-set-xor window-unset window-reset window-set-erase window-set-copy window-set-invert window-set-line-width window-set-line-attr window-std-line-attr window-draw-line window-draw-line-xy window-draw-arrowhead-xy window-draw-arrow-xy window-draw-arrow2-xy window-draw-box window-draw-box-xy window-xor-box-xy window-draw-box-corners window-draw-rcbox-xy window-draw-arc-xy window-draw-circle-xy window-draw-circle window-erase-area window-erase-area-xy window-erase-box-xy window-draw-ellipse-xy window-copy-area-xy window-invertarea window-invert-area window-invert-area-xy window-prettyprintat window-prettyprintat-xy window-printat window-printat-xy window-string-width window-string-height window-string-extents window-font-string-width window-yposition window-centeroffset dowindowcom window-menu window-close window-unmap window-open window-map window-destroy window-destroy-selected-window window-clear window-moveto-xy window-paint window-move window-draw-border window-track-mouse window-wait-exposure window-wait-unmap window-init-mouse-poll window-poll-mouse menu-init menu-calculate-size menu-adjust-offset menu-draw menu-item-value menu-find-item-width menu-find-item-height menu-clear menu-display-item menu-choose menu-box-item menu-unbox-item menu-item-position menu-select menu-select! menu-select-b menu-destroy menu-create menu-offset menu-size menu-moveto-xy menu-reposition picmenu-create picmenu-create-spec picmenu-create-from-spec picmenu-calculate-size picmenu-init picmenu-draw picmenu-draw-button picmenu-delete-named-button picmenu-select picmenu-box-item picmenu-unbox-item picmenu-destroy picmenu-button-containsxy? picmenu-item-position barmenu-create barmenu-calculate-size barmenu-init barmenu-draw barmenu-select barmenu-update-value window-get-point window-get-click window-get-line-position window-get-latex-position window-get-box-position window-get-icon-position window-get-region window-get-box-size window-track-mouse-in-region window-adjust-box-side window-adj-box-xy window-get-circle window-circle-radius window-draw-circle-pt window-get-ellipse window-draw-ellipse-pt window-draw-vector-pt window-get-vector-end window-get-crosshairs window-draw-crosshairs-xy window-get-cross window-draw-cross-xy window-draw-dot-xy window-draw-latex-xy window-reset-color window-set-color-rgb window-set-xcolor window-set-color window-set-color window-free-color window-get-chars window-process-char-event window-input-string window-input-char-fn window-draw-carat window-init-keymap window-set-cursor window-positive-y window-code-char window-get-raw-char window-print-line window-print-lines textmenu-create textmenu-calculate-size textmenu-init textmenu-draw textmenu-select textmenu-set-text textmenu editmenu editmenu-create editmenu-calculate-size editmenu-init editmenu-draw editmenu-display window-edit window-edit-display editmenu-carat editmenu-erase window-edit-erase editmenu-select editmenu-edit-fn window-edit-fn editmenu-setxy editmenu-char editmenu-edit *window-editmenu-kill-strings* *window-add-menu-title* *window-menu* *mouse-x* *mouse-y* *mouse-window* *window-fonts* *window-display* *window-screen* *root-window* *black-pixel* *white-pixel* *default-fg-color* *default-bg-color* *default-size-hints* *default-GC* *default-colormap* *window-event* *window-default-pos-x* *window-default-pos-y* *window-default-border* *window-default-font-name* *window-default-cursor* *window-save-foreground* *window-save-function* *window-attributes* *window-attr* *menu-title-pad* *root-return* *child-return* *root-x-return* *root-y-return* *win-x-return* *win-y-return* *mask-return* *x-return* *y-return* *width-return* *height-return* *depth-return* *border-width-return* *text-width-return* *direction-return* *ascent-return* *descent-return* *overall-return* *GC-Values* *window-xcolor* *window-menu-code* *window-keymap* *window-shiftkeymap* *window-keyinit* *window-meta* *window-ctrl* *window-shift* *window-string* *window-string-count* *window-string-max* *window-input-string-x* *window-input-string-y* *window-input-string-charwidth* *window-shift-keys* *window-control-keys* *window-meta-keys* *barmenu-update-value-cons* *picmenu-no-selection* *min-keycodes-return* *max-keycodes-return* *keycodes-return* )) (export x)) ; export the above symbols (DEFVAR *WINDOW-ADD-MENU-TITLE* NIL) (DEFVAR *WINDOW-MENU* NIL) (DEFVAR *MOUSE-X* NIL) (DEFVAR *MOUSE-Y* NIL) (DEFVAR *MOUSE-WINDOW* NIL) (DEFVAR *WINDOW-FONTS* (LIST (LIST 'COURIER-BOLD-12 "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1") (LIST 'COURIER-MEDIUM-12 "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1") (LIST '6X12 "6x12") (LIST '8X13 "8x13") (LIST '9X15 "9x15"))) (DEFVAR *WINDOW-DISPLAY* NIL) (DEFVAR *WINDOW-SCREEN* NIL) (DEFVAR *ROOT-WINDOW*) (DEFVAR *BLACK-PIXEL*) (DEFVAR *WHITE-PIXEL*) (DEFVAR *DEFAULT-FG-COLOR*) (DEFVAR *DEFAULT-BG-COLOR*) (DEFVAR *DEFAULT-SIZE-HINTS*) (DEFVAR *DEFAULT-GC*) (DEFVAR *DEFAULT-COLORMAP*) (DEFVAR *WINDOW-EVENT*) (DEFVAR *WINDOW-DEFAULT-POS-X* 10) (DEFVAR *WINDOW-DEFAULT-POS-Y* 20) (DEFVAR *WINDOW-DEFAULT-BORDER* 1) (DEFVAR *WINDOW-DEFAULT-FONT-NAME* 'COURIER-BOLD-12) (DEFVAR *WINDOW-DEFAULT-CURSOR* 68) (DEFVAR *WINDOW-SAVE-FOREGROUND*) (DEFVAR *WINDOW-SAVE-FUNCTION*) (DEFVAR *WINDOW-ATTRIBUTES*) (DEFVAR *WINDOW-ATTR*) (DEFVAR *MENU-TITLE-PAD* 30) (DEFVAR *ROOT-RETURN* (FIXNUM-ARRAY 1)) (DEFVAR *CHILD-RETURN* (FIXNUM-ARRAY 1)) (DEFVAR *ROOT-X-RETURN* (INT-ARRAY 1)) (DEFVAR *ROOT-Y-RETURN* (INT-ARRAY 1)) (DEFVAR *WIN-X-RETURN* (INT-ARRAY 1)) (DEFVAR *WIN-Y-RETURN* (INT-ARRAY 1)) (DEFVAR *MASK-RETURN* (INT-ARRAY 1)) (DEFVAR *X-RETURN* (INT-ARRAY 1)) (DEFVAR *Y-RETURN* (INT-ARRAY 1)) (DEFVAR *WIDTH-RETURN* (INT-ARRAY 1)) (DEFVAR *HEIGHT-RETURN* (INT-ARRAY 1)) (DEFVAR *DEPTH-RETURN* (INT-ARRAY 1)) (DEFVAR *BORDER-WIDTH-RETURN* (INT-ARRAY 1)) (DEFVAR *TEXT-WIDTH-RETURN* (INT-ARRAY 1)) (DEFVAR *DIRECTION-RETURN* (INT-ARRAY 1)) (DEFVAR *ASCENT-RETURN* (INT-ARRAY 1)) (DEFVAR *DESCENT-RETURN* (INT-ARRAY 1)) (DEFVAR *OVERALL-RETURN* (INT-ARRAY 1)) (DEFVAR *GC-VALUES*) (DEFVAR *WINDOW-XCOLOR* NIL) (DEFVAR *WINDOW-MENU-CODE* NIL) (DEFVAR *WINDOW-KEYMAP* (MAKE-ARRAY 256)) (DEFVAR *WINDOW-SHIFTKEYMAP* (MAKE-ARRAY 256)) (DEFVAR *WINDOW-KEYINIT* NIL) (DEFVAR *WINDOW-META*) (DEFVAR *WINDOW-CTRL*) (DEFVAR *WINDOW-SHIFT*) (DEFVAR *WINDOW-SHIFT-KEYS* NIL) (DEFVAR *WINDOW-CONTROL-KEYS* NIL) (DEFVAR *WINDOW-META-KEYS* NIL) (DEFVAR *MIN-KEYCODES-RETURN* (INT-ARRAY 1)) (DEFVAR *MAX-KEYCODES-RETURN* (INT-ARRAY 1)) (DEFVAR *KEYCODES-RETURN* (INT-ARRAY 1)) (SETQ *WINDOW-KEYINIT* NIL) (DEFMACRO PICMENU-SPEC (SYMBOL) (LIST 'GET SYMBOL ''PICMENU-SPEC)) (DEFVAR *PICMENU-NO-SELECTION* '(NO-SELECTION (0 0) (0 0) NIL NIL)) (DEFUN STRINGIFY (X) (COND ((STRINGP X) X) ((SYMBOLP X) (COPY-SEQ (SYMBOL-NAME X))) (T (PRINC-TO-STRING X)))) (DEFUN WINDOW-XINIT () (SETQ *WINDOW-DISPLAY* (XOPENDISPLAY (GET-C-STRING ""))) (IF (OR (NOT (NUMBERP *WINDOW-DISPLAY*)) (< *WINDOW-DISPLAY* 10000)) (ERROR "DISPLAY did not open: return value ~A~%" *WINDOW-DISPLAY*)) (SETQ *WINDOW-SCREEN* (XDEFAULTSCREEN *WINDOW-DISPLAY*)) (SETQ *ROOT-WINDOW* (XROOTWINDOW *WINDOW-DISPLAY* *WINDOW-SCREEN*)) (SETQ *BLACK-PIXEL* (XBLACKPIXEL *WINDOW-DISPLAY* *WINDOW-SCREEN*)) (SETQ *WHITE-PIXEL* (XWHITEPIXEL *WINDOW-DISPLAY* *WINDOW-SCREEN*)) (SETQ *DEFAULT-FG-COLOR* *BLACK-PIXEL*) (SETQ *DEFAULT-BG-COLOR* *WHITE-PIXEL*) (SETQ *DEFAULT-GC* (XDEFAULTGC *WINDOW-DISPLAY* *WINDOW-SCREEN*)) (SETQ *DEFAULT-COLORMAP* (XDEFAULTCOLORMAP *WINDOW-DISPLAY* *WINDOW-SCREEN*)) (SETQ *WINDOW-ATTRIBUTES* (MAKE-XSETWINDOWATTRIBUTES)) (SET-XSETWINDOWATTRIBUTES-BACKING_STORE *WINDOW-ATTRIBUTES* WHENMAPPED) (SET-XSETWINDOWATTRIBUTES-SAVE_UNDER *WINDOW-ATTRIBUTES* 1) (SETQ *WINDOW-ATTR* (MAKE-XWINDOWATTRIBUTES)) (XFLUSH *WINDOW-DISPLAY*) (SETQ *DEFAULT-SIZE-HINTS* (MAKE-XSIZEHINTS)) (SETQ *WINDOW-EVENT* (MAKE-XEVENT)) (SETQ *GC-VALUES* (MAKE-XGCVALUES))) (DEFUN WINDOW-GET-MOUSE-POSITION () (XQUERYPOINTER *WINDOW-DISPLAY* *ROOT-WINDOW* *ROOT-RETURN* *CHILD-RETURN* *ROOT-X-RETURN* *ROOT-Y-RETURN* *WIN-X-RETURN* *WIN-Y-RETURN* *MASK-RETURN*) (SETQ *MOUSE-X* (INT-POS *ROOT-X-RETURN* 0)) (SETQ *MOUSE-Y* (INT-POS *ROOT-Y-RETURN* 0)) (SETQ *MOUSE-WINDOW* (FIXNUM-POS *CHILD-RETURN* 0))) (DEFUN WINDOW-CREATE (WIDTH HEIGHT &OPTIONAL STR PARENTW POS-X POS-Y FONT) (LET (W PW FG-COLOR BG-COLOR) (OR *WINDOW-DISPLAY* (WINDOW-XINIT)) (SETQ FG-COLOR *DEFAULT-FG-COLOR*) (SETQ BG-COLOR *DEFAULT-BG-COLOR*) (UNLESS POS-X (SETQ POS-X *WINDOW-DEFAULT-POS-X*)) (UNLESS POS-Y (SETQ POS-Y *WINDOW-DEFAULT-POS-Y*)) (SETQ W (LIST 'WINDOW NIL NIL HEIGHT WIDTH (IF STR (STRINGIFY STR) " ") NIL)) (SETQ PW (OR PARENTW *ROOT-WINDOW*)) (WINDOW-GET-GEOMETRY-B PW) (SETF (CADR W) (XCREATESIMPLEWINDOW *WINDOW-DISPLAY* PW POS-X (- (- (INT-POS *HEIGHT-RETURN* 0) POS-Y) HEIGHT) WIDTH HEIGHT *WINDOW-DEFAULT-BORDER* FG-COLOR BG-COLOR)) (SET-XSIZEHINTS-X *DEFAULT-SIZE-HINTS* POS-X) (SET-XSIZEHINTS-Y *DEFAULT-SIZE-HINTS* POS-Y) (SET-XSIZEHINTS-WIDTH *DEFAULT-SIZE-HINTS* (FIFTH W)) (SET-XSIZEHINTS-HEIGHT *DEFAULT-SIZE-HINTS* (CADDDR W)) (SET-XSIZEHINTS-FLAGS *DEFAULT-SIZE-HINTS* 12) (XSETSTANDARDPROPERTIES *WINDOW-DISPLAY* (CADR W) (GET-C-STRING (SIXTH W)) (GET-C-STRING (SIXTH W)) 0 0 0 *DEFAULT-SIZE-HINTS*) (SETF (CADDR W) (XCREATEGC *WINDOW-DISPLAY* (CADR W) 0 0)) (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) FG-COLOR) (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) BG-COLOR) (WINDOW-SET-FONT W (OR FONT *WINDOW-DEFAULT-FONT-NAME*)) (LET (C) (SETQ C (XCREATEFONTCURSOR *WINDOW-DISPLAY* *WINDOW-DEFAULT-CURSOR*)) (XDEFINECURSOR *WINDOW-DISPLAY* (CADR W) C)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0) (XCHANGEWINDOWATTRIBUTES *WINDOW-DISPLAY* (CADR W) 1088 *WINDOW-ATTRIBUTES*) (XSELECTINPUT *WINDOW-DISPLAY* (CADR W) 32876) (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE W) W)) (DEFUN WINDOW-SET-FONT (W FONTSYMBOL) (LET (FONTSTRING FONT-INFO) (SETQ FONTSTRING (OR (CADR (ASSOC FONTSYMBOL *WINDOW-FONTS*)) (STRINGIFY FONTSYMBOL))) (SETQ FONT-INFO (XLOADQUERYFONT *WINDOW-DISPLAY* (GET-C-STRING FONTSTRING))) (IF (ZEROP FONT-INFO) (FORMAT T "~%can't open font ~a ~a~%" FONTSYMBOL FONTSTRING) (PROGN (XSETFONT *WINDOW-DISPLAY* (CADDR W) (XFONTSTRUCT-FID FONT-INFO)) (SETF (SEVENTH W) FONT-INFO))))) (DEFUN WINDOW-FONT-INFO (FONTSYMBOL) (XLOADQUERYFONT *WINDOW-DISPLAY* (GET-C-STRING (OR (CADR (ASSOC FONTSYMBOL *WINDOW-FONTS*)) (STRINGIFY FONTSYMBOL))))) (DEFUN WINDOW-GCONTEXT (W) (CADDR W)) (DEFUN WINDOW-PARENT (W) (CADR W)) (DEFUN WINDOW-DRAWABLE-HEIGHT (W) (CADDDR W)) (DEFUN WINDOW-DRAWABLE-WIDTH (W) (FIFTH W)) (DEFUN WINDOW-LABEL (W) (SIXTH W)) (DEFUN WINDOW-FONT (W) (SEVENTH W)) (DEFUN WINDOW-FOREGROUND (W) (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*)) (DEFUN WINDOW-SET-FOREGROUND (W FG-COLOR) (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) FG-COLOR)) (DEFUN WINDOW-BACKGROUND (W) (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)) (DEFUN WINDOW-SET-BACKGROUND (W BG-COLOR) (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) BG-COLOR)) (DEFUN WINDOW-WFUNCTION (W) (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*)) (DEFUN WINDOW-GET-GEOMETRY (W) (WINDOW-GET-GEOMETRY-B (CADR W))) (DEFUN WINDOW-SET-CURSOR (W N) (LET (C) (SETQ C (XCREATEFONTCURSOR *WINDOW-DISPLAY* N)) (XDEFINECURSOR *WINDOW-DISPLAY* (CADR W) C))) (DEFUN WINDOW-GET-GEOMETRY-B (W) (XGETGEOMETRY *WINDOW-DISPLAY* W *ROOT-RETURN* *X-RETURN* *Y-RETURN* *WIDTH-RETURN* *HEIGHT-RETURN* *BORDER-WIDTH-RETURN* *DEPTH-RETURN*)) (DEFUN WINDOW-SYNC (W) (declare (ignore w)) (XSYNC *WINDOW-DISPLAY* 1)) (DEFUN WINDOW-SCREEN-HEIGHT () (WINDOW-GET-GEOMETRY-B *ROOT-WINDOW*) (INT-POS *HEIGHT-RETURN* 0)) (DEFUN WINDOW-GEOMETRY (W) (LET (SH) (SETQ SH (WINDOW-SCREEN-HEIGHT)) (WINDOW-GET-GEOMETRY-B (CADR W)) (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0)) (LIST (INT-POS *X-RETURN* 0) (- (- SH (INT-POS *Y-RETURN* 0)) (INT-POS *HEIGHT-RETURN* 0)) (INT-POS *WIDTH-RETURN* 0) (INT-POS *HEIGHT-RETURN* 0) (INT-POS *BORDER-WIDTH-RETURN* 0)))) (DEFUN WINDOW-SIZE (W) (WINDOW-GET-GEOMETRY-B (CADR W)) (LIST (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0)))) (DEFUN WINDOW-LEFT (W) (WINDOW-GET-GEOMETRY-B (CADR W)) (INT-POS *X-RETURN* 0)) (DEFUN WINDOW-TOP-NEG-Y (W) (WINDOW-GET-GEOMETRY-B (CADR W)) (INT-POS *Y-RETURN* 0)) (DEFUN WINDOW-RESET-GEOMETRY (W) (WINDOW-GET-GEOMETRY-B (CADR W)) (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0))) (DEFUN WINDOW-FORCE-OUTPUT (&OPTIONAL W) (declare (ignore w)) (XFLUSH *WINDOW-DISPLAY*)) (DEFUN WINDOW-QUERY-POINTER (W) (WINDOW-QUERY-POINTER-B (CADR W))) (DEFUN WINDOW-QUERY-POINTER-B (W) (XQUERYPOINTER *WINDOW-DISPLAY* W *ROOT-RETURN* *CHILD-RETURN* *ROOT-X-RETURN* *ROOT-Y-RETURN* *WIN-X-RETURN* *WIN-Y-RETURN* *MASK-RETURN*)) (DEFUN WINDOW-POSITIVE-Y (W Y) (- (CADDDR W) Y)) (DEFUN WINDOW-SET-XOR (W) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))))) (DEFUN WINDOW-UNSET (W) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (DEFUN WINDOW-RESET (W) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (XSETFOREGROUND *WINDOW-DISPLAY* GC *DEFAULT-FG-COLOR*) (XSETBACKGROUND *WINDOW-DISPLAY* GC *DEFAULT-BG-COLOR*))) (DEFUN WINDOW-SET-ERASE (W) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (DEFUN WINDOW-SET-COPY (W) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* (CADDR W) 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*)))) (DEFUN WINDOW-SET-INVERT (W) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))))) (DEFUN WINDOW-SET-LINE-WIDTH (W WIDTH) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR WIDTH 1) 0 1 0)) (DEFUN WINDOW-SET-LINE-ATTR (W WIDTH &OPTIONAL LINE-STYLE CAP-STYLE JOIN-STYLE) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR WIDTH 1) (OR LINE-STYLE 0) (OR CAP-STYLE 1) (OR JOIN-STYLE 0))) (DEFUN WINDOW-STD-LINE-ATTR (W) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (DEFUN WINDOW-DRAW-LINE (W FROM TO &OPTIONAL LINEWIDTH) (WINDOW-DRAW-LINE-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO) LINEWIDTH)) (DEFUN WINDOW-DRAW-LINE-XY (W FROMX FROMY TOX TOY &OPTIONAL LINEWIDTH OPERATION) (LET ((QQWHEIGHT (CADDDR W))) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (CASE OPERATION (XOR (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))))) (ERASE (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (T)) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) FROMX (- QQWHEIGHT FROMY) TOX (- QQWHEIGHT TOY)) (CASE OPERATION ((XOR ERASE) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (T)) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) (DEFUN WINDOW-DRAW-ARROWHEAD-XY (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) (LET (TH THETA YSTH YCTH (Y2DELA 0) (Y2DELB 0) (X2DELA 0) (X2DELB 0)) (OR SIZE (SETQ SIZE (+ 20 (* LINEWIDTH 5)))) (SETQ TH (ATAN (- Y2 Y1) (- X2 X1))) (SETQ THETA (* TH (/ 180.0 PI))) (SETQ YSTH (ROUND (* (1+ SIZE) (SIN TH)))) (SETQ YCTH (ROUND (* (1+ SIZE) (COS TH)))) (IF (AND (EQL Y1 Y2) (EVENP LINEWIDTH)) (IF (> X2 X1) (SETQ Y2DELB 1) (SETQ Y2DELA 1))) (IF (AND (EQL X1 X2) (EVENP LINEWIDTH)) (IF (> Y2 Y1) (SETQ X2DELB 1) (SETQ X2DELA 1))) (WINDOW-DRAW-ARC-XY W (- (- X2 YSTH) X2DELA) (+ (+ Y2 YCTH) Y2DELA) SIZE SIZE (+ 240 THETA) 30 LINEWIDTH) (WINDOW-DRAW-ARC-XY W (- (+ X2 YSTH) X2DELB) (+ (- Y2 YCTH) Y2DELB) SIZE SIZE (+ 90 THETA) 30 LINEWIDTH))) (DEFUN WINDOW-DRAW-ARROW-XY (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) (WINDOW-DRAW-LINE-XY W X1 Y1 X2 Y2 LINEWIDTH) (WINDOW-DRAW-ARROWHEAD-XY W X1 Y1 X2 Y2 LINEWIDTH SIZE)) (DEFUN WINDOW-DRAW-ARROW2-XY (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) (WINDOW-DRAW-LINE-XY W X1 Y1 X2 Y2 LINEWIDTH) (WINDOW-DRAW-ARROWHEAD-XY W X1 Y1 X2 Y2 LINEWIDTH SIZE) (WINDOW-DRAW-ARROWHEAD-XY W X2 Y2 X1 Y1 LINEWIDTH SIZE)) (DEFUN WINDOW-DRAW-BOX (W OFFSET SIZE &OPTIONAL LINEWIDTH) (WINDOW-DRAW-BOX-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) (CADR SIZE) LINEWIDTH)) (DEFUN WINDOW-DRAW-BOX-XY (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL LINEWIDTH) (LET ((QQWHEIGHT (CADDDR W)) LW LW2 LW2B (PW (CADR W)) (GC (CADDR W))) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (SETQ LW (OR LINEWIDTH 1)) (SETQ LW2 (TRUNCATE LW 2)) (SETQ LW2B (TRUNCATE (1+ LW) 2)) (XDRAWLINE *WINDOW-DISPLAY* PW GC (- OFFSETX LW2) (- QQWHEIGHT OFFSETY) (- (+ OFFSETX SIZEX) LW2) (- QQWHEIGHT OFFSETY)) (XDRAWLINE *WINDOW-DISPLAY* PW GC (+ OFFSETX SIZEX) (- QQWHEIGHT (- OFFSETY LW2B)) (+ OFFSETX SIZEX) (- QQWHEIGHT (+ SIZEY (- OFFSETY LW2B)))) (XDRAWLINE *WINDOW-DISPLAY* PW GC (+ OFFSETX SIZEX LW2B) (- QQWHEIGHT (+ OFFSETY SIZEY)) (+ OFFSETX LW2B) (- QQWHEIGHT (+ OFFSETY SIZEY))) (XDRAWLINE *WINDOW-DISPLAY* PW GC OFFSETX (- QQWHEIGHT (+ OFFSETY SIZEY LW2)) OFFSETX (- QQWHEIGHT (+ OFFSETY LW2))) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) (DEFUN WINDOW-XOR-BOX-XY (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL LINEWIDTH) (WINDOW-SET-XOR W) (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY LINEWIDTH) (WINDOW-UNSET W)) (DEFUN WINDOW-DRAW-BOX-CORNERS (W XA YA XB YB &OPTIONAL LW) (WINDOW-DRAW-BOX-XY W (MIN XA XB) (MIN YA YB) (ABS (- XA XB)) (ABS (- YA YB)) LW)) (DEFUN WINDOW-DRAW-RCBOX-XY (W X Y WIDTH HEIGHT RADIUS &OPTIONAL LINEWIDTH) (LET (X1 X2 Y1 Y2 R LW2 LW2B FUDGE) (SETQ R (MAX 0 (MIN RADIUS (TRUNCATE (ABS WIDTH) 2) (TRUNCATE (ABS HEIGHT) 2)))) (IF (NOT (NUMBERP LINEWIDTH)) (SETQ LINEWIDTH 1)) (SETQ LW2 (TRUNCATE LINEWIDTH 2)) (SETQ LW2B (TRUNCATE (1+ LINEWIDTH) 2)) (SETQ FUDGE (IF (ODDP LINEWIDTH) 0 1)) (SETQ X1 (+ X R)) (SETQ X2 (- (+ X WIDTH) R)) (SETQ Y1 (+ Y R)) (SETQ Y2 (- (+ Y HEIGHT) R)) (LET ((QQWHEIGHT (CADDDR W))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (1- X1) LW2) (- QQWHEIGHT Y) X2 (- QQWHEIGHT Y)) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (LET ((QQWHEIGHT (CADDDR W))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ X WIDTH) (- QQWHEIGHT (- Y1 LW2B)) (+ X WIDTH) (- QQWHEIGHT (1+ Y2))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (LET ((QQWHEIGHT (CADDDR W))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (1- X1) (- QQWHEIGHT (+ Y HEIGHT)) (+ X2 LW2) (- QQWHEIGHT (+ Y HEIGHT))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (LET ((QQWHEIGHT (CADDDR W))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- QQWHEIGHT Y1) X (- QQWHEIGHT (1+ Y2))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (- X1 FUDGE) R) (- (CADDDR W) (+ Y1 R)) (* 2 R) (* 2 R) 11520 5760) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X2 R) (- (CADDDR W) (+ Y1 R)) (* 2 R) (* 2 R) 17280 5760) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X2 R) (- (CADDDR W) (+ (+ Y2 FUDGE) R)) (* 2 R) (* 2 R) 0 5760) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (- X1 FUDGE) R) (- (CADDDR W) (+ (+ Y2 FUDGE) R)) (* 2 R) (* 2 R) 5760 5760) (IF (AND LINEWIDTH (/= LINEWIDTH 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) (DEFUN WINDOW-DRAW-ARC-XY (W X Y RADIUSX RADIUSY ANGLEA ANGLEB &OPTIONAL LINEWIDTH) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RADIUSX) (- (CADDDR W) (+ Y RADIUSY)) (* 2 RADIUSX) (* 2 RADIUSY) (TRUNCATE (* 64 ANGLEA)) (TRUNCATE (* 64 ANGLEB))) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (DEFUN WINDOW-DRAW-CIRCLE-XY (W X Y RADIUS &OPTIONAL LINEWIDTH) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RADIUS) (- (CADDDR W) (+ Y RADIUS)) (* 2 RADIUS) (* 2 RADIUS) 0 23040) (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (DEFUN WINDOW-DRAW-CIRCLE (W POS RADIUS &OPTIONAL LINEWIDTH) (WINDOW-DRAW-CIRCLE-XY W (CAR POS) (CADR POS) RADIUS LINEWIDTH)) (DEFUN WINDOW-ERASE-AREA (W OFFSET SIZE) (WINDOW-ERASE-AREA-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) (CADR SIZE))) (DEFUN WINDOW-ERASE-AREA-XY (W XOFF YOFF XSIZE YSIZE) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) XOFF (- (CADDDR W) (1- (+ YOFF YSIZE))) XSIZE YSIZE 0)) (DEFUN WINDOW-ERASE-BOX-XY (W XOFF YOFF XSIZE YSIZE &OPTIONAL LINEWIDTH) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (- XOFF (TRUNCATE (OR LINEWIDTH 1) 2)) (- (CADDDR W) (+ YOFF YSIZE (TRUNCATE (OR LINEWIDTH 1) 2))) (+ XSIZE (OR LINEWIDTH 1)) (+ YSIZE (OR LINEWIDTH 1)) 0)) (DEFUN WINDOW-DRAW-ELLIPSE-XY (W X Y RX RY &OPTIONAL LW) (IF (AND LW (NOT (EQL LW 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LW 1) 0 1 0)) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RX) (- (CADDDR W) (+ Y RY)) (* 2 RX) (* 2 RY) 0 23040) (IF (AND LW (NOT (EQL LW 1))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) (DEFUN WINDOW-COPY-AREA-XY (W FROMX FROMY TOX TOY WIDTH HEIGHT) (LET ((QQWHEIGHT (CADDDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* (CADDR W) 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XCOPYAREA *WINDOW-DISPLAY* (CADR W) (CADR W) (CADDR W) FROMX (- QQWHEIGHT (+ FROMY HEIGHT)) WIDTH HEIGHT TOX (- QQWHEIGHT (+ TOY HEIGHT))) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) (DEFUN WINDOW-INVERTAREA (W AREA) (WINDOW-INVERT-AREA-XY W (CAAR AREA) (CADAR AREA) (CAADR AREA) (CADADR AREA))) (DEFUN WINDOW-INVERT-AREA (W OFFSET SIZE) (WINDOW-INVERT-AREA-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) (CADR SIZE))) (DEFUN WINDOW-INVERT-AREA-XY (W LEFT BOTTOM WIDTH HEIGHT) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR W) (CADDR W) LEFT (- (CADDDR W) (1- (+ BOTTOM HEIGHT))) WIDTH HEIGHT) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (DEFUN WINDOW-PRETTYPRINTAT (W S POS) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR POS) (- (CADDDR W) (CADR POS)) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-PRETTYPRINTAT-XY (W S X Y) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-PRINTAT (W S POS) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR POS) (- (CADDDR W) (CADR POS)) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-PRINTAT-XY (W S X Y) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-PRINT-LINE (W STR X Y &OPTIONAL DELTAY) (LET ((N 0) END STRB DONE) (WHILE (NOT DONE) (SETQ END (POSITION #\Newline STR :TEST #'CHAR= :START N)) (SETQ STRB (SUBSEQ STR N END)) (LET ((SSTR (STRINGIFY STRB))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) (IF (NUMBERP END) (SETQ N (1+ END)) (SETQ DONE T)) (DECF Y (OR DELTAY 16)) (IF (MINUSP Y) (SETQ DONE T))) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN WINDOW-PRINT-LINES (W LINES X Y &OPTIONAL DELTAY) (DOLIST (STR LINES) (WHEN (PLUSP Y) (LET ((SSTR (STRINGIFY STR))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) (DECF Y (OR DELTAY 16))))) (DEFUN WINDOW-STRING-WIDTH (W S) (LET ((SSTR (STRINGIFY S))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-STRING-EXTENTS (W S) (LET ((SSTR (STRINGIFY S))) (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR) *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN* *OVERALL-RETURN*) (LIST (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0)))) (DEFUN WINDOW-STRING-HEIGHT (W S) (LET ((SSTR (STRINGIFY S))) (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR) *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN* *OVERALL-RETURN*) (+ (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0)))) (DEFUN WINDOW-FONT-STRING-WIDTH (FONT S) (LET ((SSTR (STRINGIFY S))) (XTEXTWIDTH FONT (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN WINDOW-YPOSITION (W) (WINDOW-GET-MOUSE-POSITION) (- (CADDDR W) (- *MOUSE-Y* (PROGN (WINDOW-GET-GEOMETRY-B (CADR W)) (INT-POS *Y-RETURN* 0))))) (DEFUN WINDOW-CENTEROFFSET (W V) (LIST (TRUNCATE (- (FIFTH W) (CAR V)) 2) (TRUNCATE (- (CADDDR W) (CADR V)) 2))) (DEFUN DOWINDOWCOM (W) (LET (COMM) (SETQ COMM (MENU-SELECT (WINDOW-MENU))) (CASE COMM (CLOSE (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP W)) (PAINT (WINDOW-PAINT W)) (CLEAR (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*)) (MOVE (WINDOW-MOVE W)) (T (WHEN COMM (PRINC "This command not implemented.") (TERPRI)))))) (DEFUN WINDOW-MENU () (OR *WINDOW-MENU* (SETQ *WINDOW-MENU* (LIST 'MENU (COPY-LIST '(WINDOW NIL NIL 0 0 "" NIL)) NIL NIL 0 0 0 0 "" NIL NIL 0 '(CLOSE PAINT CLEAR MOVE))))) (DEFUN WINDOW-CLOSE (W) (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP W)) (DEFUN WINDOW-UNMAP (W) (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W))) (DEFUN WINDOW-OPEN (W) (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE W)) (DEFUN WINDOW-MAP (W) (XMAPWINDOW *WINDOW-DISPLAY* (CADR W))) (DEFUN WINDOW-DESTROY (W) (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (SETF (CADR W) NIL) (XFREEGC *WINDOW-DISPLAY* (CADDR W)) (SETF (CADDR W) NIL)) (DEFUN WINDOW-DESTROY-SELECTED-WINDOW () (PROG (WW CHILD) (SLEEP 3) (SETQ WW *ROOT-WINDOW*) LP (WINDOW-QUERY-POINTER-B WW) (SETQ CHILD (FIXNUM-POS *CHILD-RETURN* 0)) (IF (> CHILD 0) (PROGN (SETQ WW CHILD) (GO LP))) (IF (/= WW *ROOT-WINDOW*) (PROGN (XDESTROYWINDOW *WINDOW-DISPLAY* WW) (XFLUSH *WINDOW-DISPLAY*))))) (DEFUN WINDOW-CLEAR (W) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*)) (DEFUN WINDOW-MOVETO-XY (W X Y) (XMOVEWINDOW *WINDOW-DISPLAY* (CADR W) X (- (WINDOW-SCREEN-HEIGHT) Y))) (DEFUN WINDOW-PAINT (WINDOW) (LET (STATE) (WINDOW-TRACK-MOUSE WINDOW #'(LAMBDA (X Y CODE) (IF (= CODE 1) (IF (= STATE 1) (SETQ STATE 0) (SETQ STATE 1)) (IF (= CODE 2) (IF (= STATE 2) (SETQ STATE 0) (SETQ STATE 2)))) (IF (= STATE 1) (WINDOW-DRAW-LINE-XY WINDOW X Y X Y 1 'PAINT) (IF (= STATE 2) (WINDOW-DRAW-LINE-XY WINDOW X Y X Y 1 'ERASE))) (= CODE 3))))) (DEFUN WINDOW-MOVE (W) (WINDOW-GET-MOUSE-POSITION) (XMOVEWINDOW *WINDOW-DISPLAY* (CADR W) *MOUSE-X* (- (WINDOW-SCREEN-HEIGHT) *MOUSE-Y*))) (DEFUN WINDOW-DRAW-BORDER (W) (WINDOW-DRAW-BOX-XY W 0 1 (1- (CAR (WINDOW-SIZE W))) (1- (CADR (WINDOW-SIZE W)))) (XFLUSH *WINDOW-DISPLAY*)) (DEFUN WINDOW-TRACK-MOUSE (W FN &OPTIONAL OUTFLG) (LET (WIN H) (SETQ WIN (WINDOW-PARENT W)) (SETQ H (WINDOW-DRAWABLE-HEIGHT W)) (XSYNC *WINDOW-DISPLAY* 1) (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ BUTTONPRESSMASK POINTERMOTIONMASK)) (DO ((RES NIL)) (RES RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) (WHEN (OR (AND (EQL EVENTWINDOW WIN) (OR (EQL TYPE MOTIONNOTIFY) (EQL TYPE BUTTONPRESS))) (AND OUTFLG (EQL TYPE BUTTONPRESS))) (LET ((X (XMOTIONEVENT-X *WINDOW-EVENT*)) (Y (XMOTIONEVENT-Y *WINDOW-EVENT*)) (CODE (IF (EQL TYPE BUTTONPRESS) (XBUTTONEVENT-BUTTON *WINDOW-EVENT*) 0))) (SETQ RES (IF (EQL EVENTWINDOW WIN) (FUNCALL FN X (- H Y) CODE) (FUNCALL FN -1 -1 CODE))))))))) (DEFUN WINDOW-WAIT-EXPOSURE (W) (PROG (WIN START-TIME MAX-TIME EVENTWINDOW TYPE) (SETQ WIN (WINDOW-PARENT W)) (XGETWINDOWATTRIBUTES *WINDOW-DISPLAY* WIN *WINDOW-ATTR*) (UNLESS (EQL (XWINDOWATTRIBUTES-MAP_STATE *WINDOW-ATTR*) ISUNMAPPED) (RETURN T)) (SETQ START-TIME (GET-INTERNAL-REAL-TIME)) (SETQ MAX-TIME INTERNAL-TIME-UNITS-PER-SECOND) (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ EXPOSUREMASK)) LP (COND ((> (XPENDING *WINDOW-DISPLAY*) 0) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) (SETQ TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) (SETQ EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*)) (IF (AND (EQL EVENTWINDOW WIN) (EQL TYPE EXPOSE)) (RETURN T))) ((> (- (GET-INTERNAL-REAL-TIME) START-TIME) MAX-TIME) (RETURN NIL))) (GO LP))) (DEFUN WINDOW-WAIT-UNMAP (W) (PROG (WIN START-TIME MAX-TIME) (SETQ WIN (WINDOW-PARENT W)) (SETQ START-TIME (GET-INTERNAL-REAL-TIME)) (SETQ MAX-TIME INTERNAL-TIME-UNITS-PER-SECOND) LP (XGETWINDOWATTRIBUTES *WINDOW-DISPLAY* WIN *WINDOW-ATTR*) (IF (EQL (XWINDOWATTRIBUTES-MAP_STATE *WINDOW-ATTR*) ISUNMAPPED) (RETURN T) (IF (> (- (GET-INTERNAL-REAL-TIME) START-TIME) MAX-TIME) (RETURN NIL))) (GO LP))) (DEFUN WINDOW-INIT-MOUSE-POLL (W) (LET (WIN) (SETQ WIN (WINDOW-PARENT W)) (XSYNC *WINDOW-DISPLAY* 1) (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ BUTTONPRESSMASK POINTERMOTIONMASK)))) (DEFUN WINDOW-POLL-MOUSE (W) (LET (WIN H EVENTTYPE EVENTWINDOW X Y CD (CODE 0)) (SETQ WIN (WINDOW-PARENT W)) (SETQ H (WINDOW-DRAWABLE-HEIGHT W)) (WHILE (> (XPENDING *WINDOW-DISPLAY*) 0) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) (SETQ EVENTTYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) (SETQ EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*)) (IF (EQL EVENTWINDOW WIN) (IF (EQL EVENTTYPE MOTIONNOTIFY) (PROGN (SETQ X (XMOTIONEVENT-X *WINDOW-EVENT*)) (SETQ Y (XMOTIONEVENT-Y *WINDOW-EVENT*))) (IF (EQL EVENTTYPE BUTTONPRESS) (IF (> (SETQ CD (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)) 0) (SETQ CODE CD)))))) (IF (OR X (> CODE 0)) (LIST X (IF Y (- H Y)) CODE)))) (DEFUN MENU-INIT (M) (OR *WINDOW-DISPLAY* (WINDOW-XINIT)) (MENU-CALCULATE-SIZE M) (IF (NOT (CADDR M)) (SETF (CADR M) (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") (CADDDR M) (FIFTH M) (SIXTH M) (NTH 10 M))))) (DEFUN MENU-CALCULATE-SIZE (M) (LET (MAXWIDTH TOTALHEIGHT NITEMS) (OR (NTH 10 M) (SETF (NTH 10 M) '9X15)) (SETQ MAXWIDTH (+ (MENU-FIND-ITEM-WIDTH M (NINTH M)) (IF (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*) 0 *MENU-TITLE-PAD*))) (SETQ NITEMS (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) 1 0)) (SETQ TOTALHEIGHT (* 13 NITEMS)) (DOLIST (ITEM (NTH 12 M)) (INCF NITEMS) (SETQ MAXWIDTH (MAX MAXWIDTH (MENU-FIND-ITEM-WIDTH M ITEM))) (INCF TOTALHEIGHT (MENU-FIND-ITEM-HEIGHT M ITEM))) (SETF (NTH 11 M) (+ 6 MAXWIDTH)) (SETF (SEVENTH M) (1+ (NTH 11 M))) (SETF (EIGHTH M) (+ 2 TOTALHEIGHT)) (MENU-ADJUST-OFFSET M))) (DEFUN MENU-ADJUST-OFFSET (M) (LET (XBASE YBASE WBASE HBASE XOFF YOFF WGM WIDTH HEIGHT) (SETQ WIDTH (SEVENTH M)) (SETQ HEIGHT (EIGHTH M)) (WHEN (NOT (CADDDR M)) (WINDOW-GET-MOUSE-POSITION) (SETQ WGM T) (SETF (CADDDR M) *ROOT-WINDOW*)) (WINDOW-GET-GEOMETRY-B (CADDDR M)) (SETQ XBASE (INT-POS *X-RETURN* 0)) (SETQ YBASE (INT-POS *Y-RETURN* 0)) (SETQ WBASE (INT-POS *WIDTH-RETURN* 0)) (SETQ HBASE (INT-POS *HEIGHT-RETURN* 0)) (IF (OR (NOT (FIFTH M)) (ZEROP (FIFTH M))) (PROGN (OR WGM (WINDOW-GET-MOUSE-POSITION)) (SETQ XOFF (+ -4 (- (- *MOUSE-X* XBASE) (TRUNCATE WIDTH 2)))) (SETQ YOFF (- (- HBASE (- *MOUSE-Y* YBASE)) (TRUNCATE HEIGHT 2)))) (PROGN (SETQ XOFF (FIFTH M)) (SETQ YOFF (SIXTH M)))) (SETF (FIFTH M) (MAX 0 (MIN XOFF (- WBASE WIDTH)))) (SETF (SIXTH M) (MAX 0 (MIN YOFF (- HBASE HEIGHT)))))) (DEFUN MENU-DRAW (M) (LET (MW XZERO YZERO BOTTOM) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (MENU-INIT M)) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (SETQ MW (CADR M)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE MW) (MENU-CLEAR M) (IF (CADDR M) (WINDOW-DRAW-BOX-XY MW (1- XZERO) YZERO (+ 2 (SEVENTH M)) (1+ (EIGHTH M)) 1)) (SETQ BOTTOM (+ 3 (+ YZERO (EIGHTH M)))) (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (INCF BOTTOM -15) (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) (+ 3 XZERO) (- (CADDDR MW) BOTTOM) (GET-C-STRING SSTR) (LENGTH SSTR))) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO (+ -12 (- (CADDDR MW) BOTTOM)) (1+ (SEVENTH M)) 15) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (DOLIST (ITEM (NTH 12 M)) (DECF BOTTOM (MENU-FIND-ITEM-HEIGHT M ITEM)) (MENU-DISPLAY-ITEM M ITEM (+ 3 XZERO) BOTTOM)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN MENU-ITEM-VALUE (SELF ITEM) (declare (ignore self)) (IF (CONSP ITEM) (CDR ITEM) ITEM)) (DEFUN MENU-FIND-ITEM-WIDTH (SELF ITEM) (LET (TMP) (IF (AND (CONSP ITEM) (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) (OR (AND (SETQ TMP (GET (CAR ITEM) 'DISPLAY-SIZE)) (CAR TMP)) 40) (WINDOW-FONT-STRING-WIDTH (OR (AND (CADDR SELF) (CADR SELF) (SEVENTH (CADR SELF))) (WINDOW-FONT-INFO (NTH 10 SELF))) (STRINGIFY (IF (CONSP ITEM) (CAR ITEM) ITEM)))))) (DEFUN MENU-FIND-ITEM-HEIGHT (SELF ITEM) (declare (ignore self)) (LET (TMP) (IF (AND (CONSP ITEM) (SYMBOLP (CAR ITEM)) (SETQ TMP (GET (CAR ITEM) 'DISPLAY-SIZE))) (+ 3 (CADR TMP)) 15))) (DEFUN MENU-CLEAR (M) (IF (CADDR M) (LET ((GLVAR386 (+ 3 (EIGHTH M)))) (XCLEARAREA *WINDOW-DISPLAY* (CADADR M) (1- (IF (CADDR M) (FIFTH M) 0)) (- (CADDDR (CADR M)) (1- (+ (1- (IF (CADDR M) (SIXTH M) 0)) GLVAR386))) (+ 3 (SEVENTH M)) GLVAR386 0)) (PROGN (XCLEARWINDOW *WINDOW-DISPLAY* (CADADR M)) (XFLUSH *WINDOW-DISPLAY*)))) (DEFUN MENU-DISPLAY-ITEM (SELF ITEM X Y) (LET ((MW (CADR SELF))) (IF (CONSP ITEM) (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) (FUNCALL (CAR ITEM) MW X Y) (IF (OR (STRINGP (CAR ITEM)) (SYMBOLP (CAR ITEM)) (NUMBERP (CAR ITEM))) (LET ((SSTR (STRINGIFY (CAR ITEM)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X (- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) (LET ((SSTR (STRINGIFY (STRINGIFY ITEM)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X (- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR))))) (LET ((SSTR (STRINGIFY (STRINGIFY ITEM)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X (- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))))) (DEFUN MENU-CHOOSE (M INSIDE) (LET (MW CURRENT-ITEM YBASE ITEMH VAL MAXX MAXY XZERO YZERO) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (MENU-INIT M)) (SETQ MW (CADR M)) (MENU-DRAW M) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (SETQ MAXX (+ XZERO (SEVENTH M))) (SETQ MAXY (+ YZERO (EIGHTH M))) (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (INCF MAXY -15)) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (SETQ *WINDOW-MENU-CODE* CODE) (IF (AND (>= X XZERO) (<= X MAXX) (>= Y YZERO) (<= Y MAXY)) (IF (OR (NULL CURRENT-ITEM) (< Y YBASE) (> Y (+ YBASE ITEMH))) (PROGN (IF CURRENT-ITEM (MENU-BOX-ITEM M CURRENT-ITEM YBASE)) (SETQ CURRENT-ITEM (MENU-FIND-ITEM-Y M (- Y YZERO))) (WHEN CURRENT-ITEM (SETQ YBASE (MENU-ITEM-Y M CURRENT-ITEM)) (SETQ ITEMH (MENU-FIND-ITEM-HEIGHT M CURRENT-ITEM)) (MENU-BOX-ITEM M CURRENT-ITEM YBASE) (SETQ INSIDE T)) (WHEN (PLUSP CODE) (MENU-BOX-ITEM M CURRENT-ITEM YBASE) (SETQ VAL 1))) (WHEN (PLUSP CODE) (MENU-BOX-ITEM M CURRENT-ITEM YBASE) (SETQ VAL 1))) (PROGN (WHEN CURRENT-ITEM (MENU-BOX-ITEM M CURRENT-ITEM YBASE) (SETQ CURRENT-ITEM NIL)) (IF (OR (PLUSP CODE) (AND INSIDE (OR (< X XZERO) (> X MAXX) (< Y YZERO) (> Y MAXY)))) (SETQ VAL -777))))) T) (IF (NOT (EQL VAL -777)) (IF (CONSP CURRENT-ITEM) (CDR CURRENT-ITEM) CURRENT-ITEM)))) (DEFUN MENU-BOX-ITEM (M ITEM YBASE) (LET ((MW (OR (CADR M) (MENU-INIT M)))) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (WINDOW-DRAW-BOX-XY MW (1+ (IF (CADDR M) (FIFTH M) 0)) (+ 2 (+ (IF (CADDR M) (SIXTH M) 0) YBASE)) (+ -2 (NTH 11 M)) (MENU-FIND-ITEM-HEIGHT M ITEM) 1) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) (DEFUN MENU-UNBOX-ITEM (M ITEM YBASE) (MENU-BOX-ITEM M ITEM YBASE)) (DEFUN MENU-ITEM-POSITION (M ITEMNAME &OPTIONAL PLACE) (LET ((XSIZE (NTH 11 M)) YBASE ITEM YSIZE) (SETQ ITEM (MENU-FIND-ITEM M ITEMNAME)) (SETQ YSIZE (MENU-FIND-ITEM-HEIGHT M ITEM)) (SETQ YBASE (MENU-ITEM-Y M ITEM)) (LIST (+ (IF (CADDR M) (FIFTH M) 0) (CASE PLACE ((CENTER TOP BOTTOM) (TRUNCATE XSIZE 2)) (LEFT -1) (RIGHT (+ 2 XSIZE)) (T 0))) (+ (+ (IF (CADDR M) (SIXTH M) 0) YBASE) (CASE PLACE ((CENTER RIGHT LEFT) (TRUNCATE YSIZE 2)) (BOTTOM 0) (TOP YSIZE) (T 0)))))) (DEFUN MENU-FIND-ITEM (M ITEMNAME) (LET (FOUND ITMS ITEM) (SETQ ITMS (NTH 12 M)) (SETQ FOUND (NULL ITEMNAME)) (WHILE (AND ITMS (NOT FOUND)) (SETQ ITEM (POP ITMS)) (IF (OR (EQ ITEM ITEMNAME) (AND (CONSP ITEM) (OR (EQ ITEMNAME (CAR ITEM)) (AND (STRINGP (CAR ITEM)) (STRING= (STRINGIFY ITEMNAME) (CAR ITEM))) (EQ (CDR ITEM) ITEMNAME) (AND (CONSP (CDR ITEM)) (EQ (CADR ITEM) ITEMNAME))))) (SETQ FOUND T))) ITEM)) (DEFUN MENU-ITEM-Y (M ITEM) (LET (FOUND ITMS ITM YBASE) (SETQ YBASE (1- (EIGHTH M))) (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (INCF YBASE -15)) (SETQ ITMS (NTH 12 M)) (WHILE (AND ITMS (NOT FOUND)) (SETQ ITM (POP ITMS)) (DECF YBASE (MENU-FIND-ITEM-HEIGHT M ITM)) (SETQ FOUND (EQ ITEM ITM))) YBASE)) (DEFUN MENU-FIND-ITEM-Y (M Y) (LET (FOUND ITMS ITM YBASE) (SETQ YBASE (1- (EIGHTH M))) (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (INCF YBASE -15)) (SETQ ITMS (NTH 12 M)) (WHILE (AND ITMS (NOT FOUND)) (SETQ ITM (POP ITMS)) (DECF YBASE (MENU-FIND-ITEM-HEIGHT M ITM)) (SETQ FOUND (AND (>= Y YBASE) (<= Y (+ YBASE (MENU-FIND-ITEM-HEIGHT M ITM)))))) (AND FOUND ITM))) (DEFUN MENU-SELECT (M &OPTIONAL INSIDE) (MENU-SELECT-B M NIL INSIDE)) (DEFUN MENU-SELECT! (M) (MENU-SELECT-B M T NIL)) (DEFUN MENU-SELECT-B (M FLG INSIDE) (PROG (RES) LP (SETQ RES (MENU-CHOOSE M INSIDE)) (IF (AND FLG (NOT RES)) (GO LP)) (IF (NOT (TENTH M)) (IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*)) (PROGN (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP (CADR M))))) (RETURN RES))) (DEFUN MENU-DESTROY (M) (WHEN (NOT (CADDR M)) (XDESTROYWINDOW *WINDOW-DISPLAY* (CADADR M)) (XFLUSH *WINDOW-DISPLAY*) (SETF (CADADR M) NIL) (XFREEGC *WINDOW-DISPLAY* (CADDR (CADR M))) (SETF (CADDR (CADR M)) NIL) (SETF (CADR M) NIL))) (DEFUN MENU (ITEMS &OPTIONAL TITLE) (LET (M RES) (SETQ M (MENU-CREATE ITEMS TITLE)) (SETQ RES (MENU-SELECT M)) (MENU-DESTROY M) RES)) (DEFUN MENU-CREATE (ITEMS &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT) (LIST 'MENU (IF FLAT PARENTW) FLAT (CADR PARENTW) X Y 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM FONT 0 ITEMS)) (DEFUN MENU-OFFSET (M) (LIST (IF (CADDR M) (FIFTH M) 0) (IF (CADDR M) (SIXTH M) 0))) (DEFUN MENU-SIZE (M) (IF (<= (SEVENTH M) 0) (CASE (FIRST M) (PICMENU (PICMENU-CALCULATE-SIZE M)) (BARMENU (BARMENU-CALCULATE-SIZE M)) (TEXTMENU (TEXTMENU-CALCULATE-SIZE M)) (EDITMENU (EDITMENU-CALCULATE-SIZE M)) (T (MENU-CALCULATE-SIZE M)))) (LIST (SEVENTH M) (EIGHTH M))) (DEFUN MENU-MOVETO-XY (M X Y) (WHEN (CADDR M) (SETF (FIFTH M) X) (SETF (SIXTH M) Y) (MENU-ADJUST-OFFSET M))) (DEFUN MENU-REPOSITION (M) (LET (SIZEV POS) (WHEN (CADDR M) (SETQ SIZEV (MENU-SIZE M)) (SETQ POS (WINDOW-GET-BOX-POSITION (CADR M) (CAR SIZEV) (CADR SIZEV))) (MENU-MOVETO-XY M (CAR POS) (CADR POS))))) (DEFUN MENU-REPOSITION-LINE (M OFFSET TARGET) (LET (SIZEV POS) (WHEN (CADDR M) (SETQ SIZEV (MENU-SIZE M)) (SETQ POS (WINDOW-GET-BOX-LINE-POSITION (CADR M) (CAR SIZEV) (CADR SIZEV) (CAR OFFSET) (CADR OFFSET) (CAR TARGET) (CADR TARGET))) (MENU-MOVETO-XY M (CAR POS) (CADR POS))))) (DEFUN PICMENU-CREATE (BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL TITLE DOTFLG PARENTW X Y PERM FLAT FONT BOXFLG) (PICMENU-CREATE-FROM-SPEC (PICMENU-CREATE-SPEC BUTTONS WIDTH HEIGHT DRAWFN DOTFLG FONT) TITLE PARENTW X Y PERM FLAT BOXFLG)) (DEFUN PICMENU-CREATE-SPEC (BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL DOTFLG FONT) (LIST 'PICMENU-SPEC WIDTH HEIGHT BUTTONS DOTFLG DRAWFN (OR FONT '9X15))) (DEFUN PICMENU-CREATE-FROM-SPEC (SPEC &OPTIONAL TITLE PARENTW X Y PERM FLAT BOXFLG) (LIST 'PICMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) X Y 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM SPEC BOXFLG NIL NIL)) (DEFUN PICMENU-CALCULATE-SIZE (M) (LET (MAXWIDTH MAXHEIGHT) (SETQ MAXWIDTH (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) (CADR (NTH 10 M)))) (SETQ MAXHEIGHT (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) 15 0) (CADDR (NTH 10 M)))) (SETF (SEVENTH M) MAXWIDTH) (SETF (EIGHTH M) MAXHEIGHT))) (DEFUN PICMENU-INIT (M) (PICMENU-CALCULATE-SIZE M) (MENU-ADJUST-OFFSET M) (IF (NOT (CADDR M)) (SETF (CADR M) (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") (CADDDR M) (FIFTH M) (SIXTH M) (SEVENTH (NTH 10 M)))))) (DEFUN PICMENU-DRAW (M) (LET (MW BOTTOM XZERO YZERO) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (PICMENU-INIT M)) (SETQ MW (CADR M)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE MW) (MENU-CLEAR M) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (SETQ BOTTOM (+ YZERO (EIGHTH M))) (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) (+ 3 XZERO) (+ 13 (- (CADDDR MW) BOTTOM)) (GET-C-STRING SSTR) (LENGTH SSTR))) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO (- (CADDDR MW) BOTTOM) (SEVENTH M) 16) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (FUNCALL (SIXTH (NTH 10 M)) MW XZERO YZERO) (IF (NTH 11 M) (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) (IF (FIFTH (NTH 10 M)) (DOLIST (B (CADDDR (NTH 10 M))) (PICMENU-DRAW-BUTTON M B))) (SETF (NTH 12 M) NIL) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN PICMENU-DRAW-NAMED-BUTTON (M NM) (PICMENU-DRAW-BUTTON M (ASSOC NM (CADDDR (NTH 10 M))))) (DEFUN PICMENU-SET-NAMED-BUTTON-COLOR (M NM COLOR) (LET (LST) (IF (SETQ LST (ASSOC NM (NTH 13 M))) (SETF (CADR LST) COLOR) (PUSH (LIST NM COLOR) (NTH 13 M))))) (DEFUN PICMENU-DRAW-BUTTON (M B) (LET ((MW (CADR M)) COL) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (WINDOW-DRAW-BOX-XY MW (+ -2 (+ (IF (CADDR M) (FIFTH M) 0) (CAADR B))) (+ -2 (+ (IF (CADDR M) (SIXTH M) 0) (CADADR B))) 4 4 1) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) (WHEN (SETQ COL (ASSOC (CAR B) (NTH 13 M))) (WINDOW-SET-COLOR-RGB MW (CAADR COL) (CADADR COL) (CADDR (CADR COL))) (WINDOW-DRAW-BOX-XY MW (1- (+ (IF (CADDR M) (FIFTH M) 0) (CAADR B))) (1- (+ (IF (CADDR M) (SIXTH M) 0) (CADADR B))) 3 3 2) (WINDOW-RESET-COLOR MW)))) (DEFUN PICMENU-DELETE-NAMED-BUTTON (M NAME) (LET (B) (WHEN (AND (SETQ B (ASSOC NAME (CADDDR (NTH 10 M)))) (NOT (MEMBER NAME (NTH 12 M) :TEST #'EQUAL))) (IF (FIFTH (NTH 10 M)) (PICMENU-DRAW-BUTTON M B)) (PUSH NAME (NTH 12 M))) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN PICMENU-SELECT (M &OPTIONAL INSIDE ANYCLICK) (LET (MW CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO CODEVAL) (SETQ MW (OR (CADR M) (PICMENU-INIT M))) (IF (NOT (TENTH M)) (PICMENU-DRAW M)) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (SETQ *WINDOW-MENU-CODE* CODE) (DECF X XZERO) (DECF Y YZERO) (IF (AND (>= X 0) (<= X (SEVENTH M)) (>= Y 0) (<= Y (EIGHTH M))) (SETQ INSIDE T)) (IF CURRENT-BUTTON (WHEN (NOT (PICMENU-BUTTON-CONTAINSXY? CURRENT-BUTTON X Y)) (PICMENU-UNBOX-ITEM M CURRENT-BUTTON) (SETQ CURRENT-BUTTON NIL))) (WHEN (NOT CURRENT-BUTTON) (SETQ ITEMS (CADDDR (NTH 10 M))) (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS))) (WHEN (AND (PICMENU-BUTTON-CONTAINSXY? ITEM X Y) (NOT (MEMBER (CAR ITEM) (NTH 12 M) :TEST #'EQUAL))) (PICMENU-BOX-ITEM M ITEM) (SETQ CURRENT-BUTTON ITEM)))) (WHEN (OR (PLUSP CODE) (AND INSIDE (OR (MINUSP X) (> X (SEVENTH M)) (MINUSP Y) (> Y (EIGHTH M))))) (IF CURRENT-BUTTON (PICMENU-UNBOX-ITEM M CURRENT-BUTTON)) (SETQ CODEVAL CODE) (SETQ VAL (IF (AND (PLUSP CODE) CURRENT-BUTTON) CURRENT-BUTTON *PICMENU-NO-SELECTION*)))) T) (IF (NOT (TENTH M)) (IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*)) (PROGN (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP (CADR M))))) (IF (EQUAL VAL *PICMENU-NO-SELECTION*) (AND (PLUSP CODEVAL) ANYCLICK) (CAR VAL)))) (DEFUN PICMENU-BOX-ITEM (M ITEM) (LET ((MW (OR (CADR M) (PICMENU-INIT M))) XOFF YOFF SIZ) (SETQ XOFF (+ (IF (CADDR M) (FIFTH M) 0) (CAADR ITEM))) (SETQ YOFF (+ (IF (CADDR M) (SIXTH M) 0) (CADADR ITEM))) (IF (CADDDR ITEM) (FUNCALL (CADDDR ITEM) (OR (CADR M) (PICMENU-INIT M)) XOFF YOFF) (PROGN (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (IF (SETQ SIZ (CADDR ITEM)) (WINDOW-DRAW-BOX-XY MW (- XOFF (TRUNCATE (CAR SIZ) 2)) (- YOFF (TRUNCATE (CADR SIZ) 2)) (CAR SIZ) (CADR SIZ) 1) (WINDOW-DRAW-BOX-XY MW (+ -6 XOFF) (+ -6 YOFF) 12 12 1)) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) (XFLUSH *WINDOW-DISPLAY*))))) (DEFUN PICMENU-UNBOX-ITEM (M ITEM) (IF (FIFTH ITEM) (PROGN (FUNCALL (FIFTH ITEM) (OR (CADR M) (PICMENU-INIT M)) (CAADR ITEM) (CADADR ITEM)) (XFLUSH *WINDOW-DISPLAY*)) (PICMENU-BOX-ITEM M ITEM))) (DEFUN PICMENU-DESTROY (M) (MENU-DESTROY M)) (DEFUN PICMENU-BUTTON-CONTAINSXY? (B X Y) (LET ((XSIZE 6) (YSIZE 6)) (WHEN (CADDR B) (SETQ XSIZE (TRUNCATE (CAADDR B) 2)) (SETQ YSIZE (TRUNCATE (CADR (CADDR B)) 2))) (AND (>= X (- (CAADR B) XSIZE)) (<= X (+ (CAADR B) XSIZE)) (>= Y (- (CADADR B) YSIZE)) (<= Y (+ (CADADR B) YSIZE))))) (DEFUN PICMENU-ITEM-POSITION (M ITEMNAME &OPTIONAL PLACE) (LET (B (XSIZE 0) (YSIZE 0) XOFF YOFF) (IF (NULL ITEMNAME) (PROGN (SETQ XSIZE (SEVENTH M)) (SETQ YSIZE (TRUNCATE (- (EIGHTH M) (CADDR (NTH 10 M))) 2)) (SETQ XOFF (TRUNCATE XSIZE 2)) (SETQ YOFF (+ (CADDR (NTH 10 M)) (TRUNCATE YSIZE 2)))) (WHEN (SETQ B (ASSOC ITEMNAME (CADDDR (NTH 10 M)))) (WHEN (CADDR B) (SETQ XSIZE (CAADDR B)) (SETQ YSIZE (CADR (CADDR B)))) (SETQ XOFF (CAADR B)) (SETQ YOFF (CADADR B)))) (IF XOFF (LIST (+ (+ (IF (CADDR M) (FIFTH M) 0) XOFF) (CASE PLACE ((CENTER TOP BOTTOM) 0) (LEFT (- (TRUNCATE XSIZE 2))) (RIGHT (TRUNCATE XSIZE 2)) (T 0))) (+ (+ (IF (CADDR M) (SIXTH M) 0) YOFF) (CASE PLACE ((CENTER RIGHT LEFT) 0) (BOTTOM (- (TRUNCATE YSIZE 2))) (TOP (TRUNCATE YSIZE 2)) (T 0))))))) (DEFUN BARMENU-CREATE (MAXVAL INITVAL BARWIDTH &OPTIONAL TITLE HORIZONTAL SUBTRACKFN SUBTRACKPARMS PARENTW X Y PERM FLAT COLOR) (LIST 'BARMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM COLOR INITVAL MAXVAL BARWIDTH HORIZONTAL SUBTRACKFN SUBTRACKPARMS)) (DEFUN BARMENU-CALCULATE-SIZE (M) (LET (MAXWIDTH MAXHEIGHT) (SETQ MAXWIDTH (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) (NTH 13 M))) (SETQ MAXHEIGHT (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) 15 0) (NTH 12 M))) (SETF (SEVENTH M) MAXWIDTH) (SETF (EIGHTH M) MAXHEIGHT))) (DEFUN BARMENU-INIT (M) (BARMENU-CALCULATE-SIZE M) (MENU-ADJUST-OFFSET M) (IF (NOT (CADDR M)) (SETF (CADR M) (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") (CADDDR M) (FIFTH M) (SIXTH M))))) (DEFUN BARMENU-DRAW (M) (LET (MW XZERO YZERO) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (BARMENU-INIT M)) (SETQ MW (CADR M)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE MW) (MENU-CLEAR M) (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M))) (IF (NTH 14 M) (LET ((QQWHEIGHT (CADDDR (CADR M)))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) (OR (NTH 13 M) 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO (- QQWHEIGHT YZERO) (+ XZERO (NTH 11 M)) (- QQWHEIGHT YZERO)) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 1 0))) (LET ((QQWHEIGHT (CADDDR (CADR M)))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) (OR (NTH 13 M) 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO (- QQWHEIGHT YZERO) XZERO (- QQWHEIGHT (+ YZERO (NTH 11 M)))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 1 0)))) (IF (NTH 10 M) (WINDOW-RESET-COLOR MW)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN BARMENU-SELECT (M &OPTIONAL INSIDE) (declare (ignore inside)) (LET (MW XZERO YZERO VAL) (SETQ MW (OR (CADR M) (BARMENU-INIT M))) (IF (NOT (TENTH M)) (BARMENU-DRAW M)) (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (WHEN (WINDOW-TRACK-MOUSE-IN-REGION MW (IF (CADDR M) (FIFTH M) 0) YZERO (SEVENTH M) (EIGHTH M) T T) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (SETQ *WINDOW-MENU-CODE* CODE) (SETQ VAL (IF (NTH 14 M) (- X XZERO) (- Y YZERO))) (BARMENU-UPDATE-VALUE M VAL) (IF (PLUSP CODE) CODE))) VAL))) (DEFVAR *BARMENU-UPDATE-VALUE-CONS* (CONS NIL NIL)) (DEFUN BARMENU-UPDATE-VALUE (M VAL) (LET ((MW (OR (CADR M) (BARMENU-INIT M))) XZERO YZERO) (SETQ VAL (MAX 0 (MIN VAL (NTH 12 M)))) (WHEN (/= VAL (NTH 11 M)) (IF (< VAL (NTH 11 M)) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))) (IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M)))) (SETQ XZERO (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (IF (NTH 14 M) (LET ((QQWHEIGHT (CADDDR (CADR M)))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) (OR (NTH 13 M) 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) (+ XZERO (NTH 11 M)) (- QQWHEIGHT YZERO) (+ XZERO VAL) (- QQWHEIGHT YZERO)) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 1 0))) (LET ((QQWHEIGHT (CADDDR (CADR M)))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) (OR (NTH 13 M) 1) 0 1 0)) (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO (- QQWHEIGHT (+ YZERO (NTH 11 M))) XZERO (- QQWHEIGHT (+ YZERO VAL))) (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 1 0)))) (IF (< VAL (NTH 11 M)) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) (IF (NTH 10 M) (WINDOW-RESET-COLOR MW))) (SETF (NTH 11 M) VAL) (WHEN (NTH 15 M) (SETF (CAR *BARMENU-UPDATE-VALUE-CONS*) VAL) (SETF (CDR *BARMENU-UPDATE-VALUE-CONS*) (NTH 16 M)) (APPLY (NTH 15 M) *BARMENU-UPDATE-VALUE-CONS*)) (XFLUSH *WINDOW-DISPLAY*)))) (DEFUN TEXTMENU-CREATE (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG INITIAL-TEXT) (LIST 'TEXTMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM INITIAL-TEXT WIDTH HEIGHT BOXFLG (OR FONT '9X15))) (DEFUN TEXTMENU-CALCULATE-SIZE (M) (LET (MAXWIDTH MAXHEIGHT) (SETQ MAXWIDTH (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) (NTH 11 M))) (SETQ MAXHEIGHT (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) 15 0) (NTH 12 M))) (SETF (SEVENTH M) MAXWIDTH) (SETF (EIGHTH M) MAXHEIGHT))) (DEFUN TEXTMENU-INIT (M) (TEXTMENU-CALCULATE-SIZE M) (MENU-ADJUST-OFFSET M) (IF (NOT (CADDR M)) (SETF (CADR M) (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M))))) (DEFUN TEXTMENU-DRAW (M) (LET (MW BOTTOM XZERO YZERO) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (TEXTMENU-INIT M)) (SETQ MW (CADR M)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE MW) (MENU-CLEAR M) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (SETQ BOTTOM (+ YZERO (EIGHTH M))) (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) (+ 3 XZERO) (+ 13 (- (CADDDR MW) BOTTOM)) (GET-C-STRING SSTR) (LENGTH SSTR))) (LET ((GC (CADDR MW))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO (- (CADDDR MW) BOTTOM) (SEVENTH M) 16) (LET ((GC (CADDR MW))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (IF (NTH 10 M) (LET ((SSTR (STRINGIFY (NTH 10 M)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) (+ 10 XZERO) (+ 8 (- (CADDDR MW) (+ YZERO (TRUNCATE (EIGHTH M) 2)))) (GET-C-STRING SSTR) (LENGTH SSTR)))) (IF (NTH 13 M) (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN TEXTMENU-SELECT (M &OPTIONAL INSIDE) (declare (ignore inside)) (LET (MW XZERO YZERO CODEVAL) (SETQ MW (OR (CADR M) (TEXTMENU-INIT M))) (IF (NOT (TENTH M)) (TEXTMENU-DRAW M)) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (SETQ *WINDOW-MENU-CODE* CODE) (DECF X XZERO) (DECF Y YZERO) (IF (OR (PLUSP CODE) (MINUSP X) (> X (SEVENTH M)) (MINUSP Y) (> Y (EIGHTH M))) (SETQ CODEVAL CODE))) T) (WHEN (AND (NOT (TENTH M)) (NOT (CADDR M))) (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP (CADR M))) (WHEN (PLUSP CODEVAL) (TEXTMENU-DRAW M) (WINDOW-INPUT-STRING MW (NTH 10 M) (+ 10 XZERO) (+ -8 (+ YZERO (TRUNCATE (EIGHTH M) 2))) (+ -12 (SEVENTH M)))))) (DEFUN TEXTMENU-SET-TEXT (M &OPTIONAL S) (SETF (NTH 10 M) (OR S ""))) (DEFUN WINDOW-GET-POINT (W) (LET (ORGX ORGY) (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (WHEN (NOT (ZEROP CODE)) (SETQ ORGX X) (SETQ ORGY Y)))) (LIST ORGX ORGY))) (DEFUN WINDOW-GET-CLICK (W) (LET (ORGX ORGY BUTTON) (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (WHEN (NOT (ZEROP CODE)) (SETQ BUTTON CODE) (SETQ ORGX X) (SETQ ORGY Y)))) (LIST BUTTON (LIST ORGX ORGY)))) (DEFUN WINDOW-GET-LINE-POSITION (W ORGX ORGY) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-LINE-XY (LIST ORGX ORGY 1 'PAINT))) (DEFUN WINDOW-GET-LATEX-POSITION (W ORGX ORGY &OPTIONAL FLG) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-LATEX-XY (LIST ORGX ORGY FLG))) (DEFUN WINDOW-GET-BOX-POSITION (W WIDTH HEIGHT &OPTIONAL (DX 0) (DY 0)) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-XY (LIST WIDTH HEIGHT 1) DX DY)) (DEFUN WINDOW-GET-BOX-LINE-POSITION (W WIDTH HEIGHT OFFX OFFY TOX TOY &OPTIONAL (DX 0) (DY 0)) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-LINE-XY (LIST WIDTH HEIGHT OFFX OFFY TOX TOY) DX DY)) (DEFUN WINDOW-DRAW-BOX-LINE-XY (W X Y WIDTH HEIGHT OFFX OFFY TOX TOY) (WINDOW-DRAW-BOX-XY W X Y WIDTH HEIGHT) (WINDOW-DRAW-LINE-XY W (+ X OFFX) (+ Y OFFY) TOX TOY)) (DEFUN WINDOW-GET-ICON-POSITION (W FN ARGS &OPTIONAL (DX 0) (DY 0)) (LET (LASTX LASTY ARGL) (SETQ ARGL (CONS W (CONS 0 (CONS 0 ARGS)))) (WINDOW-SET-XOR W) (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (WHEN (OR (NULL LASTX) (/= X LASTX) (/= Y LASTY)) (IF LASTX (APPLY FN ARGL)) (RPLACA (CDR ARGL) (+ X DX)) (RPLACA (CDDR ARGL) (+ Y DY)) (APPLY FN ARGL) (SETQ LASTX X) (SETQ LASTY Y)) (NOT (ZEROP CODE)))) (APPLY FN ARGL) (WINDOW-UNSET W) (WINDOW-FORCE-OUTPUT W) (LIST LASTX LASTY))) (DEFUN WINDOW-GET-REGION (W &OPTIONAL WID HT) (LET (LASTX LASTY START END WIDTH HEIGHT PLACE OFFX OFFY STX STY) (IF (AND (NUMBERP WID) (NUMBERP HT)) (PROGN (SETQ START (WINDOW-GET-BOX-POSITION W WID HT (- WID) (- HT))) (SETQ STX (- (CAR START) WID)) (SETQ STY (- (CADR START) HT))) (PROGN (SETQ START (WINDOW-GET-POINT W)) (SETQ STX (CAR START)) (SETQ STY (CADR START)))) (SETQ END (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-CORNERS (LIST STX STY 1))) (SETQ LASTX (CAR END)) (SETQ LASTY (CADR END)) (SETQ WIDTH (ABS (- STX LASTX))) (SETQ HEIGHT (ABS (- STY LASTY))) (SETQ OFFX (- (MIN STX LASTX) LASTX)) (SETQ OFFY (- (MIN STY LASTY) LASTY)) (SETQ PLACE (WINDOW-GET-BOX-POSITION W WIDTH HEIGHT OFFX OFFY)) (LIST (LIST (+ OFFX (FIRST PLACE)) (+ OFFY (SECOND PLACE))) (LIST WIDTH HEIGHT)))) (DEFUN WINDOW-GET-BOX-SIZE (W OFFSETX OFFSETY) (LET (LEGENDY LASTX LASTY DX DY) (SETQ OFFSETY (MAX OFFSETY 30)) (SETQ LEGENDY (- OFFSETY 25)) (WINDOW-ERASE-AREA-XY W OFFSETX LEGENDY 71 21) (WINDOW-DRAW-BOX-XY W OFFSETX LEGENDY 70 20) (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (WHEN (OR (NULL LASTX) (/= X LASTX) (/= Y LASTY)) (IF LASTX (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY (- LASTX OFFSETX) (- LASTY OFFSETY))) (SETQ LASTX NIL) (SETQ DX (- X OFFSETX)) (SETQ DY (- Y OFFSETY)) (WHEN (AND (> DX 0) (> DY 0)) (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY DX DY) (WINDOW-PRINTAT-XY W (FORMAT NIL "~3D x ~3D" DX DY) (+ OFFSETX 3) (+ LEGENDY 5)) (SETQ LASTX X) (SETQ LASTY Y))) (NOT (ZEROP CODE)))) (IF LASTX (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY (- LASTX OFFSETX) (- LASTY OFFSETY))) (WINDOW-ERASE-AREA-XY W OFFSETX LEGENDY 71 21) (WINDOW-FORCE-OUTPUT W) (LIST DX DY))) (DEFUN WINDOW-TRACK-MOUSE-IN-REGION (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL BOXFLG INSIDE) (LET (RES) (WHEN BOXFLG (WINDOW-SET-XOR W) (WINDOW-DRAW-BOX-XY W (- OFFSETX 4) (- OFFSETY 4) (+ SIZEX 8) (+ SIZEY 8)) (WINDOW-UNSET W) (WINDOW-FORCE-OUTPUT W)) (SETQ RES (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (IF (> CODE 0) (IF INSIDE (LIST CODE (LIST X Y)) T) (IF (OR (< X OFFSETX) (> X (+ OFFSETX SIZEX)) (< Y OFFSETY) (> Y (+ OFFSETY SIZEY))) INSIDE (AND (SETQ INSIDE T) NIL)))))) (WHEN BOXFLG (WINDOW-SET-XOR W) (WINDOW-DRAW-BOX-XY W (- OFFSETX 4) (- OFFSETY 4) (+ SIZEX 8) (+ SIZEY 8)) (WINDOW-UNSET W) (WINDOW-FORCE-OUTPUT W)) (IF (CONSP RES) RES))) (DEFUN WINDOW-ADJUST-BOX-SIDE (W ORGX ORGY WIDTH HEIGHT SIDE) (LET (NEW (XX ORGX) (YY ORGY) (WW WIDTH) (HH HEIGHT)) (SETQ NEW (WINDOW-GET-ICON-POSITION W #'WINDOW-ADJ-BOX-XY (LIST ORGX ORGY WIDTH HEIGHT SIDE))) (CASE SIDE (LEFT (SETQ XX (CAR NEW)) (SETQ WW (+ WIDTH (- ORGX (CAR NEW))))) (RIGHT (SETQ WW (- (CAR NEW) ORGX))) (TOP (SETQ HH (- (CADR NEW) ORGY))) (BOTTOM (SETQ YY (CADR NEW)) (SETQ HH (+ HEIGHT (- ORGY (CADR NEW)))))) (LIST (LIST XX YY) (LIST WW HH)))) (DEFUN WINDOW-ADJ-BOX-XY (W X Y ORGX ORGY WIDTH HEIGHT SIDE) (LET ((XX ORGX) (YY ORGY) (WW WIDTH) (HH HEIGHT)) (CASE SIDE (LEFT (SETQ XX X) (SETQ WW (+ WIDTH (- ORGX X)))) (RIGHT (SETQ WW (- X ORGX))) (TOP (SETQ HH (- Y ORGY))) (BOTTOM (SETQ YY Y) (SETQ HH (+ HEIGHT (- ORGY Y))))) (WINDOW-DRAW-BOX-XY W XX YY WW HH))) (DEFUN WINDOW-GET-CIRCLE (W &OPTIONAL CENTER) (LET (PT) (OR CENTER (SETQ CENTER (WINDOW-GET-CROSSHAIRS W))) (SETQ PT (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CIRCLE-PT (LIST CENTER))) (LIST CENTER (WINDOW-CIRCLE-RADIUS (CAR PT) (CADR PT) CENTER)))) (DEFUN WINDOW-CIRCLE-RADIUS (X Y CENTER) (LET ((DX (- X (CAR CENTER))) (DY (- Y (CADR CENTER)))) (TRUNCATE (+ 0.5 (SQRT (+ (* DX DX) (* DY DY))))))) (DEFUN WINDOW-DRAW-CIRCLE-PT (W X Y CENTER) (WINDOW-DRAW-CIRCLE W CENTER (WINDOW-CIRCLE-RADIUS X Y CENTER) 1)) (DEFUN WINDOW-GET-ELLIPSE (W &OPTIONAL CENTER) (LET (CIR RADIUSX PT) (SETQ CIR (WINDOW-GET-CIRCLE W CENTER)) (SETQ CENTER (CAR CIR)) (SETQ RADIUSX (CADR CIR)) (SETQ PT (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-ELLIPSE-PT (LIST CENTER RADIUSX))) (LIST CENTER (LIST RADIUSX (ABS (- (CADR PT) (CADR CENTER))))))) (DEFUN WINDOW-DRAW-ELLIPSE-PT (W X Y CENTER RADIUSX) (declare (ignore x)) (WINDOW-DRAW-ELLIPSE-XY W (CAR CENTER) (CADR CENTER) RADIUSX (ABS (- Y (CADR CENTER))))) (DEFUN WINDOW-DRAW-VECTOR-PT (W X Y CENTER RADIUS) (LET (DX DY THETA) (SETQ DY (- Y (CADR CENTER))) (SETQ DX (- X (CAR CENTER))) (WHEN (OR (/= DX 0) (/= DY 0)) (SETQ THETA (ATAN (- Y (CADR CENTER)) (- X (CAR CENTER)))) (WINDOW-DRAW-LINE-XY W (CAR CENTER) (CADR CENTER) (+ (CAR CENTER) (* RADIUS (COS THETA))) (+ (CADR CENTER) (* RADIUS (SIN THETA))))))) (DEFUN WINDOW-GET-VECTOR-END (W CENTER RADIUS) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-VECTOR-PT (LIST CENTER RADIUS))) (DEFUN WINDOW-GET-CROSSHAIRS (W) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CROSSHAIRS-XY NIL)) (DEFUN WINDOW-DRAW-CROSSHAIRS-XY (W X Y) (WINDOW-DRAW-LINE-XY W (- X 12) Y (- X 3) Y) (WINDOW-DRAW-LINE-XY W (+ X 3) Y (+ X 12) Y) (WINDOW-DRAW-LINE-XY W X (- Y 12) X (- Y 3)) (WINDOW-DRAW-LINE-XY W X (+ Y 3) X (+ Y 12))) (DEFUN WINDOW-GET-CROSS (W) (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CROSS-XY NIL)) (DEFUN WINDOW-DRAW-CROSS-XY (W X Y) (WINDOW-DRAW-LINE-XY W (- X 10) (- Y 10) (+ X 10) (+ Y 10) 2) (WINDOW-DRAW-LINE-XY W (+ X 10) (- Y 10) (- X 10) (+ Y 10) 2)) (DEFUN WINDOW-DRAW-DOT-XY (W X Y) (WINDOW-DRAW-CIRCLE-XY W X Y 1) (WINDOW-DRAW-CIRCLE-XY W X Y 2) (WINDOW-DRAW-LINE-XY W X Y (+ X 1) Y 1)) (DEFUN WINDOW-DRAW-LATEX-XY (W X Y ORGX ORGY FLG) (LET (DX DY DELX DELY N RATIO CD NRAT) (SETQ DX (- X ORGX)) (SETQ DY (- Y ORGY)) (IF (OR (= DX 0) (= DY 0)) (WINDOW-DRAW-LINE-XY W X Y ORGX ORGY) (PROGN (SETQ N (IF FLG 4 6)) (IF (> (ABS DY) (ABS DX)) (PROGN (SETQ RATIO (ROUND (/ (* (ABS DX) N) (ABS DY)))) (SETQ CD (GCD N RATIO)) (SETQ N (/ N CD)) (SETQ RATIO (/ RATIO CD)) (SETQ NRAT (ROUND (/ (ABS DY) N))) (SETQ DELY (* (SIGNUM DY) NRAT N)) (SETQ DELX (* (SIGNUM DX) NRAT RATIO))) (PROGN (SETQ RATIO (ROUND (/ (* (ABS DY) N) (ABS DX)))) (SETQ CD (GCD N RATIO)) (SETQ N (/ N CD)) (SETQ RATIO (/ RATIO CD)) (SETQ NRAT (ROUND (/ (ABS DX) N))) (SETQ DELX (* (SIGNUM DX) NRAT N)) (SETQ DELY (* (SIGNUM DY) NRAT RATIO)))) (WINDOW-DRAW-LINE-XY W (+ ORGX DELX) (+ ORGY DELY) ORGX ORGY))))) (DEFUN WINDOW-RESET-COLOR (W) (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) *DEFAULT-FG-COLOR*) (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) *DEFAULT-BG-COLOR*)) (DEFUN WINDOW-SET-COLOR-RGB (W R G B &OPTIONAL BACKGROUND) (LET (RET) (OR *WINDOW-XCOLOR* (SETQ *WINDOW-XCOLOR* (MAKE-XCOLOR))) (SET-XCOLOR-RED *WINDOW-XCOLOR* (+ R 0)) (SET-XCOLOR-GREEN *WINDOW-XCOLOR* (+ G 0)) (SET-XCOLOR-BLUE *WINDOW-XCOLOR* (+ B 0)) (SETQ RET (XALLOCCOLOR *WINDOW-DISPLAY* *DEFAULT-COLORMAP* *WINDOW-XCOLOR*)) (IF (NOT (EQL RET 0)) (WINDOW-SET-XCOLOR W *WINDOW-XCOLOR* BACKGROUND)))) (DEFUN WINDOW-SET-XCOLOR (W &OPTIONAL XCOLOR BACKGROUND) (IF BACKGROUND (WINDOW-SET-BACKGROUND W (XCOLOR-PIXEL XCOLOR)) (WINDOW-SET-FOREGROUND W (XCOLOR-PIXEL XCOLOR))) XCOLOR) (DEFUN WINDOW-SET-COLOR (W RGB &OPTIONAL BACKGROUND) (WINDOW-SET-COLOR-RGB W (FIRST RGB) (SECOND RGB) (THIRD RGB) BACKGROUND)) (DEFUN WINDOW-FREE-COLOR (W &OPTIONAL XCOLOR) (declare (ignore w)) (OR XCOLOR (SETQ XCOLOR *WINDOW-XCOLOR*)) (IF XCOLOR (UNLESS (OR (EQL XCOLOR *DEFAULT-FG-COLOR*) (EQL XCOLOR *DEFAULT-BG-COLOR*)) (XFREECOLORS *WINDOW-DISPLAY* *DEFAULT-COLORMAP* XCOLOR 1 0)))) (DEFUN WINDOW-GET-CHARS (W FN &OPTIONAL ARGS) (LET (WIN RES) (OR *WINDOW-KEYINIT* (WINDOW-INIT-KEYMAP)) (SETQ *WINDOW-SHIFT* NIL) (SETQ *WINDOW-CTRL* NIL) (SETQ *WINDOW-META* NIL) (SETQ WIN (WINDOW-PARENT W)) (XSYNC *WINDOW-DISPLAY* 1) (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ KEYPRESSMASK KEYRELEASEMASK BUTTONPRESSMASK)) (WHILE (NULL RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) (IF (EQL EVENTWINDOW WIN) (SETQ RES (WINDOW-PROCESS-CHAR-EVENT W TYPE FN ARGS))))) RES)) (DEFUN WINDOW-PROCESS-CHAR-EVENT (W TYPE FN ARGS) (LET (CODE) (IF (EQL TYPE KEYRELEASE) (PROGN (SETQ CODE (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)) (IF (MEMBER CODE *WINDOW-SHIFT-KEYS*) (SETQ *WINDOW-SHIFT* NIL) (IF (MEMBER CODE *WINDOW-CONTROL-KEYS*) (SETQ *WINDOW-CTRL* NIL) (IF (MEMBER CODE *WINDOW-META-KEYS*) (SETQ *WINDOW-META* NIL))))) (IF (EQL TYPE KEYPRESS) (PROGN (SETQ CODE (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)) (IF (MEMBER CODE *WINDOW-SHIFT-KEYS*) (PROGN (SETQ *WINDOW-SHIFT* T) NIL) (IF (MEMBER CODE *WINDOW-CONTROL-KEYS*) (PROGN (SETQ *WINDOW-CTRL* T) NIL) (IF (MEMBER CODE *WINDOW-META-KEYS*) (PROGN (SETQ *WINDOW-META* T) NIL) (FUNCALL FN W (WINDOW-CHAR-DECODE CODE) 0 0 0 ARGS))))) (IF (EQL TYPE BUTTONPRESS) (FUNCALL FN W 0 (XBUTTONEVENT-BUTTON *WINDOW-EVENT*) (XMOTIONEVENT-X *WINDOW-EVENT*) (- (WINDOW-DRAWABLE-HEIGHT W) (XMOTIONEVENT-Y *WINDOW-EVENT*)) ARGS)))))) (DEFUN WINDOW-CHAR-DECODE (CODE) (LET (CHAR) (SETQ CHAR (AREF (IF *WINDOW-SHIFT* *WINDOW-SHIFTKEYMAP* *WINDOW-KEYMAP*) CODE)) (IF (AND CHAR *WINDOW-CTRL*) (SETQ CHAR (CODE-CHAR (- (CHAR-CODE (CHAR-UPCASE CHAR)) 64)))) (IF (AND CHAR *WINDOW-META*) (SETQ CHAR (CODE-CHAR (+ (CHAR-CODE (CHAR-UPCASE CHAR)) 128)))) (OR CHAR #\Space))) (DEFUN WINDOW-GET-RAW-CHAR (W) (LET (WIN RES) (OR *WINDOW-KEYINIT* (WINDOW-INIT-KEYMAP)) (SETQ *WINDOW-SHIFT* NIL) (SETQ *WINDOW-CTRL* NIL) (SETQ *WINDOW-META* NIL) (SETQ WIN (WINDOW-PARENT W)) (XSYNC *WINDOW-DISPLAY* 1) (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ KEYPRESSMASK KEYRELEASEMASK)) (WHILE (NULL RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) (IF (AND (EQL EVENTWINDOW WIN) (EQL TYPE KEYPRESS)) (SETQ RES (XBUTTONEVENT-BUTTON *WINDOW-EVENT*))))) RES)) (DEFUN WINDOW-INPUT-STRING (W STR X Y &OPTIONAL SIZE) (CAR (WINDOW-EDIT W X Y (OR SIZE 100) 16 (LIST (OR STR "")) NIL T T))) (DEFUN WINDOW-EDIT (W X Y WIDTH HEIGHT &OPTIONAL STRINGS BOXFLG SCROLL ENDP) (LET (EM) (SETQ EM (EDITMENU-CREATE WIDTH HEIGHT NIL W X Y NIL T '9X15 BOXFLG STRINGS SCROLL ENDP)) (EDITMENU-EDIT EM) (EDITMENU-CARAT EM) (NTH 10 EM))) (DEFUN EDITMENU-CREATE (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG INITIAL-TEXT SCROLLVAL ENDP) (LIST 'EDITMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM (OR INITIAL-TEXT (LIST "")) WIDTH HEIGHT BOXFLG (OR FONT '9X15) (IF ENDP (LENGTH (NTH (IF (NUMBERP SCROLLVAL) SCROLLVAL 0) INITIAL-TEXT)) 0) (IF (NUMBERP SCROLLVAL) SCROLLVAL 0) (OR SCROLLVAL 0))) (DEFUN EDITMENU-CALCULATE-SIZE (M) (SETF (SEVENTH M) (NTH 11 M)) (SETF (EIGHTH M) (NTH 12 M))) (DEFUN EDITMENU-INIT (M) (EDITMENU-CALCULATE-SIZE M) (MENU-ADJUST-OFFSET M) (IF (NOT (CADDR M)) (SETF (CADR M) (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M))))) (DEFUN EDITMENU-DRAW (M) (LET (MW XZERO YZERO) (OR (AND (CADR M) (PLUSP (EIGHTH M))) (EDITMENU-INIT M)) (SETQ MW (CADR M)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE MW) (MENU-CLEAR M) (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) (IF (NTH 13 M) (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) (EDITMENU-DISPLAY M 0 0 (NOT (NUMBERP (NTH 17 M)))))) (DEFUN EDITMENU-DISPLAY (M LINE CHAR ONLY) (LET (LINES Y MAXWIDTH LINEWIDTH (W (OR (CADR M) (EDITMENU-INIT M)))) (SETQ LINES (NTHCDR LINE (NTH 10 M))) (SETQ Y (+ (IF (CADDR M) (SIXTH M) 0) (- (EIGHTH M) (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg") (1+ (- (- LINE (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)) (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)))))))) (SETQ MAXWIDTH (TRUNCATE (+ -6 (SEVENTH M)) (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) (GET-C-STRING SSTR) (LENGTH SSTR))))) (WHILE (AND LINES (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0)))) (IF (< CHAR MAXWIDTH) (IF (PLUSP CHAR) (LET ((SSTR (STRINGIFY (SUBSEQ (FIRST LINES) CHAR (MIN MAXWIDTH (LENGTH (FIRST LINES))))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ (IF (CADDR M) (FIFTH M) 0) (+ 2 (* CHAR (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) (GET-C-STRING SSTR) (LENGTH SSTR)))))) (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) (LET ((SSTR (STRINGIFY (IF (<= (LENGTH (FIRST LINES)) MAXWIDTH) (FIRST LINES) (SUBSEQ (FIRST LINES) 0 MAXWIDTH))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 2 (IF (CADDR M) (FIFTH M) 0)) (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))))) (SETQ LINEWIDTH (+ 2 (* (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) (GET-C-STRING SSTR) (LENGTH SSTR))) (LENGTH (FIRST LINES))))) (WINDOW-ERASE-AREA-XY W (+ (IF (CADDR M) (FIFTH M) 0) LINEWIDTH) (+ -2 Y) (+ -2 (- (SEVENTH M) LINEWIDTH)) (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg")) (DECF Y (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg")) (IF ONLY (SETQ LINES NIL) (PROGN (POP LINES) (IF (AND (NULL LINES) (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0)))) (WINDOW-ERASE-AREA-XY W (+ 2 (IF (CADDR M) (FIFTH M) 0)) (+ -2 Y) (+ -4 (SEVENTH M)) (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg"))))) (SETQ CHAR 0)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN EDITMENU-CARAT (M) (WINDOW-DRAW-CARAT (OR (CADR M) (EDITMENU-INIT M)) (+ (IF (CADDR M) (FIFTH M) 0) (+ 2 (* (NTH 15 M) (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) (GET-C-STRING SSTR) (LENGTH SSTR)))))) (+ -2 (+ (IF (CADDR M) (SIXTH M) 0) (- (EIGHTH M) (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg") (1+ (- (NTH 16 M) (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))))))))) (XFLUSH *WINDOW-DISPLAY*)) (DEFUN EDITMENU-ERASE (M ONEP) (LET ((W (OR (CADR M) (EDITMENU-INIT M))) XW) (SETQ XW (+ 2 (* (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))) (NTH 15 M)))) (LET ((GLVAR423 (WINDOW-STRING-HEIGHT W "Tg"))) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ (IF (CADDR M) (FIFTH M) 0) XW) (- (CADDDR W) (1- (+ (- (+ (IF (CADDR M) (SIXTH M) 0) (- (EIGHTH M) (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg") (1+ (- (NTH 16 M) (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))))))) (CADR (LET ((SSTR (STRINGIFY "Tg"))) (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR) *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN* *OVERALL-RETURN*) (LIST (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0))))) GLVAR423))) (IF ONEP (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))) (- (SEVENTH M) XW)) GLVAR423 0)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN EDITMENU-LINE-Y (M LINE) (+ (IF (CADDR M) (SIXTH M) 0) (- (EIGHTH M) (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg") (1+ (- LINE (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)))))))) (DEFUN EDITMENU-SELECT (M &OPTIONAL INSIDE) (declare (ignore inside)) (LET (MW CODEVAL XVAL YVAL) (SETQ MW (OR (CADR M) (EDITMENU-INIT M))) (IF (NOT (TENTH M)) (EDITMENU-DRAW M)) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (SETQ *WINDOW-MENU-CODE* CODE) (WHEN (OR (PLUSP CODE) (< X (FIFTH M)) (> X (+ (FIFTH M) (SEVENTH M))) (< Y (SIXTH M)) (> Y (+ (SIXTH M) (EIGHTH M)))) (SETQ CODEVAL CODE) (SETQ XVAL X) (SETQ YVAL Y))) T) (IF (PLUSP CODEVAL) (EDITMENU-EDIT M CODEVAL XVAL YVAL)))) (DEFVAR *WINDOW-EDITMENU-KILL-STRINGS* NIL) (DEFUN EDITMENU-EDIT (M &OPTIONAL CODE X Y) (LET ((MW (OR (CADR M) (EDITMENU-INIT M)))) (EDITMENU-DRAW M) (EDITMENU-CARAT M) (IF CODE (EDITMENU-EDIT-FN MW NIL CODE X Y (LIST M))) (SETQ *WINDOW-EDITMENU-KILL-STRINGS* NIL) (WINDOW-GET-CHARS MW #'EDITMENU-EDIT-FN (LIST M)) (NTH 10 M))) (DEFUN EDITMENU-EDIT-FN (W CHAR BUTTON BUTTONX BUTTONY ARGS) (declare (ignore w)) (LET (M INSIDE DONE) (SETQ M (CAR ARGS)) (EDITMENU-CARAT M) (IF (AND (NUMBERP BUTTON) (NOT (ZEROP BUTTON))) (PROGN (SETQ INSIDE (EDITMENU-SETXY M BUTTONX BUTTONY)) (CASE BUTTON (1 (IF INSIDE (PROGN (EDITMENU-CARAT M) NIL) T)) (2 (WHEN INSIDE (EDITMENU-YANK M) (EDITMENU-CARAT M) NIL)))) (PROGN (IF (< (CHAR-CODE CHAR) 32) (CASE CHAR (#\Return (IF (NUMBERP (NTH 17 M)) (EDITMENU-RETURN M) (SETQ DONE T))) (#\Backspace (EDITMENU-BACKSPACE M)) (#\^D (EDITMENU-DELETE M)) (#\^N (IF (NUMBERP (NTH 17 M)) (EDITMENU-NEXT M))) (#\^P (EDITMENU-PREVIOUS M)) (#\^F (EDITMENU-FORWARD M)) (#\^B (EDITMENU-BACKWARD M)) (#\^A (EDITMENU-BEGINNING M)) (#\^E (EDITMENU-END M)) (#\^K (EDITMENU-KILL M)) (#\^Y (EDITMENU-YANK M)) (T NIL)) (IF (> (CHAR-CODE CHAR) 128) (PROGN (SETQ CHAR (CODE-CHAR (+ -128 (CHAR-CODE CHAR)))) (CASE CHAR (#\B (EDITMENU-META-B M)) (#\F (EDITMENU-META-F M)) (T NIL))) (EDITMENU-CHAR M CHAR))) (EDITMENU-CARAT M) DONE)))) (DEFUN EDITMENU-SETXY (M BUTTONX BUTTONY) (LET (LINECONS OKAY) (SETQ OKAY (AND (>= BUTTONX (FIFTH M)) (<= BUTTONX (+ (FIFTH M) (SEVENTH M))) (>= BUTTONY (SIXTH M)) (<= BUTTONY (+ (SIXTH M) (EIGHTH M))))) (WHEN OKAY (SETF (NTH 16 M) (MIN (1- (LENGTH (NTH 10 M))) (+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0) (TRUNCATE (- (+ (IF (CADDR M) (SIXTH M) 0) (+ -6 (EIGHTH M))) BUTTONY) (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) "Tg"))))) (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) (SETF (NTH 15 M) (MIN (LENGTH (CAR LINECONS)) (TRUNCATE (+ -2 (- BUTTONX (IF (CADDR M) (FIFTH M) 0))) (LET ((SSTR (STRINGIFY "W"))) (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) (GET-C-STRING SSTR) (LENGTH SSTR))))))) OKAY)) (DEFUN EDITMENU-CHAR (M CHAR) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) (SETF (CAR LINECONS) (CONCATENATE 'STRING (CAR LINECONS) (STRING CHAR))) (SETF (CAR LINECONS) (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)) (STRING CHAR) (SUBSEQ (CAR LINECONS) (NTH 15 M))))) (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T) (INCF (NTH 15 M)))) (DEFUN EDITMENU-CURRENT-CHAR (M) (CHAR (NTH (NTH 16 M) (NTH 10 M)) (NTH 15 M))) (DEFUN EDITMENU-RETURN (M) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) (PUSH "" (CDR LINECONS)) (PROGN (PUSH (SUBSEQ (CAR LINECONS) (NTH 15 M)) (CDR LINECONS)) (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))))) (EDITMENU-DISPLAY M (NTH 16 M) 0 NIL) (INCF (NTH 16 M)) (SETF (NTH 15 M) 0))) (DEFUN EDITMENU-BACKSPACE (M) (LET (TMP LINEDEL (LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (IF (PLUSP (NTH 15 M)) (PROGN (DECF (NTH 15 M)) (SETF (CAR LINECONS) (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)) (SUBSEQ (CAR LINECONS) (1+ (NTH 15 M)))))) (WHEN (PLUSP (NTH 16 M)) (DECF (NTH 16 M)) (SETQ LINEDEL T) (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) (SETF (NTH 15 M) (LENGTH (CAR LINECONS))) (SETQ TMP (CONCATENATE 'STRING (CAR LINECONS) (CADR LINECONS))) (SETF (CDR LINECONS) (CDDR LINECONS)) (SETF (CAR LINECONS) TMP))) (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) (NOT LINEDEL)))) (DEFUN EDITMENU-END (M) (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) (DEFUN EDITMENU-BEGINNING (M) (SETF (NTH 15 M) 0)) (DEFUN EDITMENU-FORWARD (M) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (IF (< (NTH 15 M) (LENGTH (CAR LINECONS))) (INCF (NTH 15 M)) (WHEN (NUMBERP (NTH 17 M)) (INCF (NTH 16 M)) (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST ""))) (SETF (NTH 15 M) 0))))) (DEFUN EDITMENU-META-F (M) (LET (FOUND DONE) (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M)))) (< (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) (NOT FOUND)) (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) (SETQ FOUND T) (EDITMENU-FORWARD M))) (IF FOUND (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M)))) (< (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) (NOT DONE)) (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) (EDITMENU-FORWARD M) (SETQ DONE T)))))) (DEFUN EDITMENU-ALPHANUMBERICP (X) (OR (ALPHA-CHAR-P X) (NOT (NULL (DIGIT-CHAR-P X))))) (DEFUN EDITMENU-NEXT (M) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (INCF (NTH 16 M)) (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST ""))) (SETQ LINECONS (CDR LINECONS)) (SETF (NTH 15 M) (MIN (NTH 15 M) (LENGTH (CAR LINECONS)))))) (DEFUN EDITMENU-BACKWARD (M) (IF (PLUSP (NTH 15 M)) (DECF (NTH 15 M)) (WHEN (PLUSP (NTH 16 M)) (DECF (NTH 16 M)) (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))))) (DEFUN EDITMENU-META-B (M) (LET (FOUND DONE) (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M))) (NOT FOUND)) (EDITMENU-BACKWARD M) (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) (SETQ FOUND T))) (WHEN FOUND (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M))) (NOT DONE)) (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) (EDITMENU-BACKWARD M) (SETQ DONE T))) (UNLESS (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) (EDITMENU-FORWARD M))))) (DEFUN EDITMENU-PREVIOUS (M) (WHEN (PLUSP (NTH 16 M)) (DECF (NTH 16 M)) (SETF (NTH 15 M) (MIN (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))))) (DEFUN EDITMENU-DELETE (M) (EDITMENU-FORWARD M) (EDITMENU-BACKSPACE M)) (DEFUN EDITMENU-KILL (M) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) (IF (< (NTH 15 M) (LENGTH (CAR LINECONS))) (PROGN (SETQ *WINDOW-EDITMENU-KILL-STRINGS* (LIST (SUBSEQ (CAR LINECONS) (NTH 15 M)))) (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))) (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T)) (EDITMENU-DELETE M)))) (DEFUN EDITMENU-YANK (M) (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) (COL (NTH 15 M))) (WHEN *WINDOW-EDITMENU-KILL-STRINGS* (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) (PROGN (SETF (CAR LINECONS) (CONCATENATE 'STRING (CAR LINECONS) (CAR *WINDOW-EDITMENU-KILL-STRINGS*))) (SETF (NTH 15 M) (LENGTH (CAR LINECONS)))) (PROGN (SETF (CAR LINECONS) (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 COL) (CAR *WINDOW-EDITMENU-KILL-STRINGS*) (SUBSEQ (CAR LINECONS) COL))) (INCF (NTH 15 M) (LENGTH (CAR *WINDOW-EDITMENU-KILL-STRINGS*))))) (EDITMENU-DISPLAY M (NTH 16 M) COL T)))) (DEFUN WINDOW-DRAW-CARAT (W X Y) (WINDOW-SET-XOR W) (WINDOW-DRAW-LINE-XY W (- X 5) (- Y 2) X Y) (WINDOW-DRAW-LINE-XY W X Y (+ X 5) (- Y 2)) (WINDOW-UNSET W) (WINDOW-FORCE-OUTPUT W)) (DEFUN WINDOW-INIT-KEYMAP () (LET (MINCODE MAXCODE KEYCODE KEYSYM KEYNUM SHIFTKEYNUM CHAR) (XDISPLAYKEYCODES *WINDOW-DISPLAY* *MIN-KEYCODES-RETURN* *MAX-KEYCODES-RETURN*) (SETQ MINCODE (INT-POS *MIN-KEYCODES-RETURN* 0)) (SETQ MAXCODE (INT-POS *MAX-KEYCODES-RETURN* 0)) (SETQ *WINDOW-KEYMAP* (MAKE-ARRAY (1+ MAXCODE) :INITIAL-ELEMENT NIL)) (SETQ *WINDOW-SHIFTKEYMAP* (MAKE-ARRAY (1+ MAXCODE) :INITIAL-ELEMENT NIL)) (SETQ *WINDOW-SHIFT-KEYS* NIL) (SETQ *WINDOW-CONTROL-KEYS* NIL) (SETQ *WINDOW-META-KEYS* NIL) (DOTIMES (I (1+ (- MAXCODE MINCODE))) (SETQ KEYCODE (+ I MINCODE)) (SETQ KEYSYM (XGETKEYBOARDMAPPING *WINDOW-DISPLAY* KEYCODE 1 *KEYCODES-RETURN*)) (SETQ KEYNUM (FIXNUM-POS KEYSYM 0)) (SETQ SHIFTKEYNUM (FIXNUM-POS KEYSYM 1)) (IF (AND (>= KEYNUM 65) (<= KEYNUM 90) (EQL SHIFTKEYNUM NOSYMBOL)) (PROGN (SETQ SHIFTKEYNUM KEYNUM) (SETQ KEYNUM (+ KEYNUM 32)))) (IF (> KEYNUM 0) (IF (SETQ CHAR (WINDOW-CODE-CHAR KEYNUM)) (SETF (AREF *WINDOW-KEYMAP* KEYCODE) CHAR) (IF (> KEYNUM 256) (COND ((OR (EQL KEYNUM XK_SHIFT_R) (EQL KEYNUM XK_SHIFT_L)) (PUSH KEYCODE *WINDOW-SHIFT-KEYS*)) ((OR (EQL KEYNUM XK_CONTROL_L) (EQL KEYNUM XK_CONTROL_R)) (PUSH KEYCODE *WINDOW-CONTROL-KEYS*)) ((OR (EQL KEYNUM XK_ALT_R) (EQL KEYNUM XK_ALT_L)) (PUSH KEYCODE *WINDOW-META-KEYS*)))))) (IF (> SHIFTKEYNUM 0) (IF (SETQ CHAR (WINDOW-CODE-CHAR SHIFTKEYNUM)) (SETF (AREF *WINDOW-SHIFTKEYMAP* KEYCODE) CHAR)))) (SETQ *WINDOW-KEYINIT* T))) (DEFUN WINDOW-CODE-CHAR (CODE) (IF (> CODE 0) (IF (< CODE 256) (CODE-CHAR CODE) (COND ((EQL CODE XK_RETURN) #\Return) ((EQL CODE XK_TAB) #\Tab) ((EQL CODE XK_BACKSPACE) #\Backspace))))) gcl-2.6.14/xgcl-2/gcl_index.lsp0000644000175000017500000000561314360276512014550 0ustar cammcamm; index.lsp Gordon S. Novak Jr. 08 Dec 00; 18 May 06 ; This program processes LaTeX index entries, printing an index in ; either LaTeX or HTML form. ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; To use: Gather the LaTeX index data: use \index{foo} within the ; text and include a \makeindex command at the top of the file, ; producing a file .idx when the file is run through LaTeX. ; Use an editor to change the index data from LaTeX form to Lisp: ; \indexentry{combination}{37} LaTeX ; ((combination) 37) Lisp ; We assume that indexdata is a list of such entries, as illustrated ; at the end of this file. ; Warning: quote characters or apostrophes within the indexed ; entries will not read into Lisp as expected. ; Get rid of ' or change it to \' ; Start /p/bin/gcl ; (load "index.lsp") ; (printindex indexdata) ; for LaTeX output ; (printindex indexdata "prefix") ; for HTML output ; where "prefix" is the file name prefix for HTML files. ; Print index for LaTeX given a list of items ((words ...) page-number) (in-package 'xlib) (defun printindex (origlst &optional html) (let (lst top) (setq lst (sort origlst #'(lambda (x y) (or (wordlist< (car x) (car y)) (and (equal (car x) (car y)) (< (cadr x) (cadr y))))))) (terpri) (while lst (setq top (pop lst)) (if (not html) (princ "\\item ")) (dolist (word (car top)) (princ (string-downcase (symbol-name word))) (princ " ")) (printindexn (cadr top) html nil) (while (equal (caar lst) (car top)) (setq top (pop lst)) (printindexn (cadr top) html t) ) (if html (format t "

~%") (terpri)) ) )) (defun wordlist< (x y) (and (consp x) (consp y) (or (string< (symbol-name (car x)) (symbol-name (car y))) (and (eq (car x) (car y)) (or (and (null (cdr x)) (cdr y)) (and (cdr x) (cdr y) (wordlist< (cdr x) (cdr y)))))))) (defun printindexn (n html comma) (if comma (princ ", ")) (if html (format t "~D" html n n) (princ n)) ) (setq indexdata '( ; Insert index entry data here. Data should look like: ; ((isomorphism) 20) ; ((artificial intelligence) 30) )) gcl-2.6.14/xgcl-2/dwdoc.tex0000644000175000017500000011703614360276512013721 0ustar cammcamm% dwdoc.tex Gordon S. Novak Jr. % 08 Oct 92; 08 Oct 93; 16 Nov 94; 05 Jan 95; 25 Jan 06; 26 Jan 06; 08 Dec 08 \documentstyle[12pt]{article} \setlength{\oddsidemargin}{0 in} \setlength{\textwidth}{6.5 in} \setlength{\textheight}{9.0 in} \setlength{\parskip}{0.1 in} \setlength{\parindent}{0.0 in} \setlength{\topmargin}{-0.4in} \hyphenpenalty=9990 \begin{document} \Large \begin{center} {\bf Interface from GCL to X Windows} \\ \end{center} \normalsize \vspace*{0.1in} \begin{center} \large{Gordon S. Novak Jr. \\ Department of Computer Sciences \\ University of Texas at Austin \\ Austin, TX 78712} \\ \end{center} Software copyright \copyright \/ by Gordon S. Novak Jr. and The University of Texas at Austin. Distribution and use are allowed under the Gnu Public License. Also see the copyright section at the end of this document for the copyright on X Consortium software. \vspace*{-0.2in} \section{Introduction} This document describes a relatively easy-to-use interface between XGCL (X version of Gnu Common Lisp) and X windows. The interface consists of several parts: \begin{enumerate} \item Hiep Huu Nguyen has written (and adapted from X Consortium software) an interface between GCL and Xlib, the X library in C. Xlib functions can be called directly if desired, but most users will find the {\tt dwindow} functions easier to use. There is little documentation of these functions, but the Xlib documentation can be consulted, and the {\tt dwindow} functions can be examined as examples. \item The {\tt dwindow} functions described in this document, which call the Xlib functions and provide an easier interface for Lisp programs. \item It is possible to make an interactive graphical interface within a web page; this is described in a section below. \end{enumerate} The source file for the interface (written in GLISP) is {\tt dwindow.lsp}; this file is compiled into a file in plain Lisp, {\tt dwtrans.lsp}. {\tt dwtrans.lsp} is compiled as part of XGCL. The functions in this package use the convention that the coordinate {\tt (0 0)} is the lower-left corner of a window, with positive {\tt y} being upward. This is different from the convention used by X, which assumes that {\tt (0 0)} is the upper left corner and that positive {\tt y} is downward. In the descriptions below, some function arguments are shown with a type, e.g. {\tt arg:type}, to indicate the expected type of the argument. The type {\tt vector} is a list {\tt (x y)} of integers. The argument {\tt w} that is used with many functions is of type {\tt window} ({\tt window} is a Lisp data structure used by the {\tt dwindow} functions). Both the Xlib and {\tt dwindow} functions are in the package {\tt xlib:}. In order to use these functions, the Lisp command {\tt (use-package 'xlib)} should be used to import the {\tt dwindow} symbols. \section{Examples and Utilities} \subsection{{\tt dwtest}} The file {\tt dwtest.lsp} contains example functions that illustrate the use of the {\tt dwindow} package. The function call {\tt (wtesta)} creates a small window for testing. {\tt (wtestb)} through {\tt (wtestk)} perform drawing and mouse interaction tests using the window. These functions may be consulted as examples of the use of commonly used {\tt dwindow} functions. \subsection{{\tt pcalc}} The file {\tt pcalc.lsp} implements a pocket calculator as a {\tt picmenu}; its entry is {\tt (pcalc)}. \subsection{{\tt draw}} The file {\tt drawtrans.lsp} contains an interactive drawing program; its entry is {\tt (draw 'foo)} where {\tt foo} is the name of the drawing. The file {\tt ice-cream.lsp} can be loaded, followed by {\tt (draw 'ice-cream)} to examine an example drawing. {\tt draw} can produce a Lisp program or a set of \LaTeX \ commands to recreate the drawing; use {\tt origin to zero} before making a program. {\tt (draw-out file names)} will write definitions of drawings in the list {\tt names} to the file {\tt file}. \subsection{{\tt editors}} The file {\tt editorstrans.lsp} contains some interactive editing programs; it is a translation of the file {\tt editors.lsp} . One useful editor is the color editor; after entering {\tt (wtesta)} (in file {\tt dwtest.lsp}), enter {\tt (edit-color myw)} to edit a color. The result is an {\tt rgb} list as used in {\tt window-set-color}. A simple line editor and an Emacs-like text editor are described in sections \ref{texted} and \ref{emacsed} below. \section{Menus} The function {\tt menu} provides an easy interface to make a pop-up menu, get a selection from it, and destroy it: \\ \vspace{-0.2in} {\tt \hspace*{0.5in} (menu items \&optional title)} \\ \vspace{-0.1in} Example: {\tt (menu '(red white blue))} This simple call is all that is needed in most cases. More sophisticated menu features are described below. The {\tt items} in a menu is a list; each item may be a symbol, a {\tt cons} of a symbol or string and the corresponding value, or a {\tt cons} of a function name and the corresponding value. In the latter case, the function is expected to draw the corresponding menu item. If a function name is specified as the first element of a menu item, the drawing function should have arguments {\tt (fn w x y)}, where {\tt w} is the window and {\tt x} and {\tt y} are the lower-left corner of the drawing area. The property list of the function name should have the property {\tt display-size}, which should be a list {\tt (width height)} in pixels of the displayed symbol. Menus can be associated with a particular window; if no window is specified, the menu is associated with the window where the mouse cursor is located when the menu is initialized (which might not be a Lisp user's window). If a menu is associated with a user window, it may be {\em permanent} (left displayed after a selection is made) and may be {\em flat} (drawn directly on the containing window, rather than having its own window). A menu can be created by {\tt menu-create} : \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (menu-create items \&optional title w:window x y perm flat font)} \\ \vspace{-0.1in} {\tt title}, if specified, is displayed over the menu. {\tt w} is an existing {\tt window}; if specified, the menu is put within this window at the {\tt x y} offsets specified (adjusted if necessary to keep the menu inside the window). If no {\tt w} is specified, or if {\tt x} is {\tt nil}, the menu is put where the cursor is the first time the menu is displayed. {\tt perm} is non-{\tt nil} if the menu is to be permanent, {\em i.e.}, is to be left displayed after a selection has been made. {\tt flat} is non-{\tt nil} if the menu is to be drawn directly on the containing window. {\tt font} is a symbol or string that names the font to be used; the default is a {\tt 9x15} typewriter font. The menu is returned as the value of {\tt menu-create}. Such a menu can be saved; selections can be made from a menu {\tt m} as follows: \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (menu-select m \&optional inside)} \ \ \ \ \ or {\tt \hspace*{0.5in} (menu-select! m)} \\ \vspace{-0.1in} {\tt menu-select} will return {\tt nil} if the mouse is clicked outside the menu, or is moved outside after it has been inside (or if {\tt inside} is not {\tt nil}), provided that the menu is contained within a user-created window. {\tt menu-select!} requires that a choice be made. In order to avoid wasting storage, unused menus should be destroyed: {\tt (menu-destroy m)}. The simple {\tt menu} function destroys its menu after it is used. {\tt \hspace*{0.5in} (menu-size m)} \\ {\tt \hspace*{0.5in} (menu-moveto-xy m x y)} \\ {\tt \hspace*{0.5in} (menu-reposition m)} \ {\tt menu-reposition} will reposition a {\tt flat} menu within its parent window by allowing the user to position a ghost box using the mouse. {\tt menu-size} returns the size of the menu as a vector, {\tt (x y)}. {\tt menu-moveto-xy} adjusts the offsets to move a {\tt flat} menu to the specified position within its parent window. These functions and {\tt menu-destroy} work for picmenus and barmenus as well. {\tt \hspace*{0.5in} (menu-item-position m name \&optional location)} \\ \vspace{-0.1in} {\tt menu-item-position} returns a vector {\tt (x y)} that gives the coordinates of the menu item whose name is {\tt name}. {\tt location} may be {\tt center}, {\tt left}, {\tt right}, {\tt top}, or {\tt bottom}; the default is the lower-left corner of the menu item. {\tt center} specifies the center of the box containing the menu item; the other {\tt location} values are at the center of the specified edge of the box. \subsection{Picmenus} A {\tt picmenu} (picture menu) is analogous to a menu, but involves a user-defined picture containing sensitive spots or ``buttons''. The test function {\tt (wteste)} shows an example of a {\tt picmenu}. A {\tt picmenu} is created by: \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (picmenu-create buttons width height drawfn \\ \hspace*{1.5in} \&optional title dotflg w:window x y perm flat font boxflg)} \\ \vspace{-0.1in} If a picmenu is to be used more than once, the common parts can be made into a {\tt picmenu-spec} and reused: \vspace{-0.1in} {\tt \hspace*{0.5in} (picmenu-create-spec buttons width height drawfn \\ \hspace*{1.5in} \&optional dotflg font)} \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (picmenu-create-from-spec spec:picmenu-spec \\ \hspace*{1.5in} \&optional title w:window x y perm flat boxflg)} \\ \vspace{-0.1in} {\tt width} and {\tt height} are the size of the area occupied by the picture. {\tt (drawfn w x y)} should draw the picture at the offset {\tt x y}. Note that the {\tt draw} utility can be used to make the drawing function, including {\tt picmenu} buttons. {\tt dotflg} is non-{\tt nil} if it is desired that small boxes be automatically added to the sensitive points when the picture is drawn. {\tt boxflg} is non-{\tt nil} if a box is to be drawn around the picmenu when the picture is drawn (this is only needed for flat picmenus). If {\tt perm} is non-nil, the drawing program is not called when a selection is to be made, so that an external program must draw the {\tt picmenu}; this avoids the need to redraw a complex picture. The remaining arguments are as described for menus. Each of the {\tt buttons} in a picmenu is a list: \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (buttonname offset size highlightfn unhighlightfn)} \\ \vspace{-0.1in} {\tt buttonname} is the name of the button; it is the value returned when that button is selected. {\tt offset} is a vector {\tt (x y)} that gives the offset of the center of the button from the lower-left corner of the picture. The remainder of the button list may be omitted. {\tt size} is an optional list {\tt (width height)} that gives the size of the sensitive area of the button; the default size is {\tt (12\ 12)}. {\tt (highlightfn w x y)} and {\tt (unhighlightfn w x y)} (where {\tt (x y)} is the center of the button in the coordinates of {\tt w}) are optional functions to highlight the button area when the cursor is moved into it and unhighlight the button when the cursor is moved out; the default is to display a box of the specified {\tt size}. {\tt \hspace*{0.5in} (picmenu-select m \&optional inside)} \\ If the {\tt picmenu} is not {\tt flat}, its window should be destroyed following the selection using {\tt menu-destroy}. {\tt \hspace*{0.5in} (picmenu-item-position m name \&optional location)} \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (picmenu-delete-named-button m name:symbol)} \\ This deletes a button from a displayed {\tt picmenu}. The set of deleted buttons is reset to {\tt nil} when the picmenu is drawn. \subsection{Barmenus} A {\tt barmenu} displays a bar graph whose size can be adjusted using the mouse. {\tt \hspace*{0.5in} (barmenu-create maxval initval barwidth \\ \hspace*{1.5in} \&optional title horizontal subtrackfn subtrackparms \\ \hspace*{1.5in} parentw x y perm flat color)} A value is selected by: {\tt (barmenu-select m:barmenu \&optional inside)} \\ If the {\tt barmenu} is not {\tt flat}, its window should be destroyed following the selection using {\tt menu-destroy}. The user must first click the mouse in the bar area; then the size of the displayed bar is adjusted as the user moves the mouse pointer. In addition, the {\tt subtrackfn} is called with arguments of the size of the bar followed by the {\tt subtrackparms}; this can be used, for example, to display a numeric value in addition to the bar size. \subsection{Menu Sets and Menu Conns} A {\tt menu-set} is a set of multiple menus, picmenus, or barmenus that are simultaneously active within the same window. Menu-sets can be used to implement graphical user interfaces. A {\tt menu-conns} is a menu-set that includes connections between menus; this can be used to implement interfaces that allow the user to construct a network from components. The source file for menu-sets is the GLISP file {\tt menu-set.lsp}; this file is translated as part of the file {\tt drawtrans.lsp} in plain Lisp. Examples of the use of menu sets are given at the top of the file {\tt menu-set.lsp}. In the following descriptions, {\tt ms} is a {\tt menu-set} and {\tt mc} is a {\tt menu-conns}. {\tt \hspace*{0.5in} (menu-set-create w)} creates a menu set to be displayed in the window {\tt w}. {\tt \hspace*{0.5in} (menu-set-name symbol)} makes a {\tt gensym} name that begins with {\tt symbol}. {\tt \hspace*{0.5in} (menu-set-add-menu ms name:symbol sym title items} \\ \hspace*{1.5in} {\tt \&optional offset:vector)} This function adds a menu to a menu-set. {\tt sym} is arbitrary information that is saved with the menu. {\tt \hspace*{0.5in} (menu-set-add-picmenu ms name sym title spec:picmenu-spec} \\ \hspace*{1.5in} {\tt \&optional offset:vector nobox)} {\tt \hspace*{0.5in} (menu-set-add-component ms name \&optional offset:vector)} This adds a component that has a {\tt picmenu-spec} defined on the property list of {\tt name}. {\tt \hspace*{0.5in} (menu-set-add-barmenu ms name sym barmenu title} \\ \hspace*{1.5in} {\tt \&optional offset:vector)} {\tt \hspace*{0.5in} (menu-set-draw ms)} draws all the menus. {\tt \hspace*{0.5in} (menu-set-select ms \&optional redraw enabled)} {\tt menu-set-select} gets a selection from a menu-set. If {\tt redraw} is non-{\tt nil}, the menu-set is drawn. {\tt enabled} may be a list of names of menus that are enabled for selection. The result is {\tt (selection menu-name)}, or {\tt ((x y) BACKGROUND button)} for a click outside any menu. {\tt \hspace*{0.5in} (menu-conns-create ms)} creates a {\tt menu-conns} from a {\tt menu-set}. {\tt \hspace*{0.5in} (menu-conns-add-conn mc)} This function allows the user to select two ports from menus of the {\tt menu-conns}. It then draws a line between the ports and adds the connection to the {\tt connections} of the {\tt menu-conns}. {\tt \hspace*{0.5in} (menu-conns-move mc)} This function allows the user to select a menu and move it. The {\tt menu-set} and connections are redrawn afterwards. {\tt \hspace*{0.5in} (menu-conns-find-conn mc pt:vector)} \\ This finds the connection selected by the point {\tt pt}, if any. This is useful to allow the user to delete a connection: {\tt \hspace*{0.5in} (menu-conns-delete-conn mc conn)} {\tt \hspace*{0.5in} (menu-conns-find-conns mc menuname port)} \\ This returns all the connections from the specified {\tt port} (selection) of the menu whose name is {\tt menuname}. \section{Windows} {\tt \hspace*{0.5in} (window-create width height \&optional title parentw x y font)} \\ \vspace{-0.1in} {\tt window-create} makes a new window of the specified {\tt width} and {\tt height}. {\tt title}, if specified, becomes the displayed title of the window. If {\tt parentw} is specified, it should be the {\tt window-parent} property of an existing window, which becomes the parent window of the new window. {\tt x} and {\tt y} are the offset of the new window from the parent window. {\tt font} is the font to be used for printing in the window; the default is given by {\tt *window-default-font-name*}, initially {\tt courier-bold-12}. {\tt \hspace*{0.5in} (window-open w)} causes a window to be displayed on the screen. {\tt \hspace*{0.5in} (window-close w)} removes the window from the display; it can be re-opened. {\tt \hspace*{0.5in} (window-destroy w)} {\tt \hspace*{0.5in} (window-moveto-xy w x y)} {\tt \hspace*{0.5in} (window-geometry w)} queries X for the window geometry. The result is a list, \linebreak {\tt (x y width height border-width)} . {\tt \hspace*{0.5in} (window-size w)} returns a list {\tt (width height)} . \vspace{-0.1in} Note that the width and height are cached within the structure so that no call to X is needed to examine them. However, if the window is resized, it is necessary to call {\tt (window-reset-geometry\ w)} to reset the local parameters to their correct values. % ; Paint in window with mouse \\ % these are not really working... % {\tt \hspace*{0.5in} (window-paint w)} \\ % % {\tt \hspace*{0.5in} (window-move w)} \\ % % {\tt \hspace*{0.5in} (dowindowcom w)} \\ The following functions provide access to the parts of the {\tt window} data structure; most applications will not need to use them. \\ \vspace{-0.1in} {\tt \hspace*{0.5in} (window-gcontext w)} \\ {\tt \hspace*{0.5in} (window-parent w)} \\ {\tt \hspace*{0.5in} (window-drawable-height w)} \\ {\tt \hspace*{0.5in} (window-drawable-width w)} \\ {\tt \hspace*{0.5in} (window-label w)} \\ {\tt \hspace*{0.5in} (window-font w)} \\ {\tt \hspace*{0.5in} (window-screen-height)} \\ \section{Drawing Functions} {\tt \hspace*{0.5in} (window-clear w)} clears the window to the background color. {\tt \hspace*{0.5in} (window-force-output \&optional w)} \vspace{-0.1in} Communication between the running program and X windows is done through a stream; actual drawing on the display is done asynchronously. {\tt window-force-output} causes the current drawing commands, if any, to be sent to X. Without this, commands may be left in the stream buffer and may appear not to have been executed. The argument {\tt w} is not used. In all of the drawing functions, the {\tt linewidth} argument is optional and defaults to {\tt 1}. \vspace{0.1in} {\tt \hspace*{0.5in} (window-draw-line w from:vector to:vector linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-line-xy w x1 y1 x2 y2 \&optional linewidth op)} \\ \hspace*{1.0in} {\tt op} may be {\tt xor} or {\tt erase}. \vspace{0.1in} {\tt \hspace*{0.5in} (window-draw-arrow-xy w x1 y1 x2 y2 \&optional linewidth size)} \\ {\tt \hspace*{0.5in} (window-draw-arrow2-xy w x1 y1 x2 y2 \&optional linewidth size)} \\ {\tt \hspace*{0.5in} (window-draw-arrowhead-xy w x1 y1 x2 y2 \&optional linewidth size)} \vspace{-0.1in} These draw a line with an arrowhead at the second point, a line with an arrowhead at both points, or an arrowhead alone at the second point, respectively. {\tt size} is the arrowhead size; the default is {\tt (+ 20 (* linewidth 5))}. \vspace{0.1in} {\tt \hspace*{0.5in} (window-draw-box-xy w x y width height linewidth)} \\ {\tt \hspace*{0.5in} (window-xor-box-xy w x y width height linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-box w offset:vector size:vector linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-box-corners w x1 y1 x2 y2 linewidth)} \\ \hspace*{1.0in} where {\tt (x1 y1)} and {\tt (x2 y2)} are opposite corners. \\ {\tt \hspace*{0.5in} (window-draw-rcbox-xy w x y width height radius linewidth)} \\ \hspace*{1.0in} draws a box with rounded corners. {\tt \hspace*{0.5in} (window-draw-arc-xy w x y radiusx radiusy anglea angleb linewidth)} \vspace{-0.1in} {\tt anglea} is the angle, in degrees, at which the arc is started. {\tt angleb} is the angle, in degrees, that specifies the amount of arc to be drawn, counterclockwise from the starting position. \vspace{0.1in} {\tt \hspace*{0.5in} (window-draw-circle-xy w x y radius linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-circle w center:vector radius linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-ellipse-xy w x y radiusx radiusy linewidth)} \\ {\tt \hspace*{0.5in} (window-draw-dot-xy w x y)} \vspace{0.1in} {\tt \hspace*{0.5in} (window-erase-area-xy w left bottom width height)} \\ {\tt \hspace*{0.5in} (window-erase-area w offset:vector size:vector)} \\ {\tt \hspace*{0.5in} (window-copy-area-xy w fromx fromy tox toy width height)} \\ {\tt \hspace*{0.5in} (window-invert-area w offset:vector size:vector)} \\ {\tt \hspace*{0.5in} (window-invert-area-xy w left bottom width height)} \vspace{0.1in} {\tt \hspace*{0.5in} (window-printat-xy w s x y)} \\ {\tt \hspace*{0.5in} (window-printat w s at:vector)} \\ {\tt \hspace*{0.5in} (window-prettyprintat-xy w s x y)} \\ {\tt \hspace*{0.5in} (window-prettyprintat w s at:vector)} \\ \vspace{-0.1in} The argument {\tt s} is printed at the specified position. {\tt s} is stringified if necessary. Currently, the pretty-print versions are the same as the plain versions. \vspace{0.1in} {\tt \hspace*{0.5in} (window-draw-border w)} draws a border just inside a window. \section{Fonts, Operations, Colors} {\tt \hspace*{0.5in} (window-set-font w font)} \vspace{-0.1in} The font symbols that are currently defined are {\tt courier-bold-12}, {\tt 8x10}, and {\tt 9x15} . The global variable {\tt *window-fonts*} contains correspondences between font symbols and font strings. A font string may also be specified instead of a font symbol. {\tt \hspace*{0.5in} (window-string-width w s)} \\ {\tt \hspace*{0.5in} (window-string-extents w s)} \\ These give the width and the vertical size {\tt (ascent descent)} in pixels of the specified string {\tt s} using the font of the specified window. {\tt s} is stringified if necessary. Operations on a window other than direct drawing are performed by setting a condition for the window, performing the operation, and then unsetting the condition with {\tt window-unset}. {\tt window-reset} will reset a window to its ``standard'' setting; it is useful primarily for cases in which a program bug causes window settings to be in an undesired state. \vspace{-0.1in} {\tt \hspace*{0.5in} (window-set-xor w)} \\ {\tt \hspace*{0.5in} (window-set-erase w)} \\ {\tt \hspace*{0.5in} (window-set-copy w)} \\ {\tt \hspace*{0.5in} (window-set-invert w)} \\ {\tt \hspace*{0.5in} (window-unset w)} \\ {\tt \hspace*{0.5in} (window-reset w)} \\ {\tt \hspace*{0.5in} (window-set-line-width w width)} \\ {\tt \hspace*{0.5in} (window-set-line-attr w width \&optional line-style cap-style join-style)} \\ {\tt \hspace*{0.5in} (window-std-line-attr w)} \\ {\tt \hspace*{0.5in} (window-foreground w)} \\ {\tt \hspace*{0.5in} (window-set-foreground w fg-color)} \\ {\tt \hspace*{0.5in} (window-background w)} \\ {\tt \hspace*{0.5in} (window-set-background w bg-color)} \\ \subsection{Color} The color of the foreground (things that are drawn, such as lines or characters) is set by: {\tt \hspace*{0.5in} (window-set-color w rgb \&optional background)} \\ {\tt \hspace*{0.5in} (window-set-color-rgb w r g b \&optional background)} \\ {\tt rgb} is a list {\tt (red green blue)} of 16-bit unsigned integers in the range {\tt 0} to {\tt 65535}. {\tt background} is non-{\tt nil} to set the background color rather than the foreground color. {\tt \hspace*{0.5in} (window-reset-color w)} \\ {\tt window-reset-color} resets a window's colors to the default values. Colors are a scarce resource; there is only a finite number of available colors, such as 256 colors. If you only use a small, fixed set of colors, the finite set of colors will not be a problem. However, if you create a lot of colors that are used only briefly, it will be necessary to release them after they are no longer needed. {\tt window-set-color} will leave the global variable {\tt *window-xcolor*} set to an integer value that denotes an X color; this value should be saved and used as the argument to {\tt window-free-color} to release the color after it is no longer needed. {\tt \hspace*{0.5in} (window-free-color w \&optional xcolor)} \\ {\tt window-free-color} frees either the last color used, as given by {\tt *window-xcolor*}, or the specified color. \subsection{Character Input} \label{texted} Characters can be input within a window by the call: {\tt \hspace*{0.5in} (window-input-string w str x y \&optional size)} \\ {\tt window-input-string} will print the initial string {\tt str}, if non-{\tt nil}, at the specified position in the window; {\tt str}, if not modified by the user, will also be the initial part of the result. A caret is displayed showing the location of the next input character. Characters are echoed as they are typed; backspacing erases characters, including those from the initial string {\tt str}. An area of width {\tt size} (default 100) is erased to the right of the initial caret. \subsection{Emacs-like Editing} \label{emacsed} {\tt window-edit} allows editing of text using an Emacs-subset editor. Only a few simple Emacs commands are implemented. \begin{verbatim} (window-edit w x y width height &optional strings boxflg scroll endp) \end{verbatim} {\tt x y width height} specify the offset and size of the editing area; it is a good idea to draw a box around this area first. {\tt strings} is an initial list of strings; the return value is a list of strings. {\tt scroll} is number of lines to scroll down before displaying text, or {\tt T} to have one line only and terminate on return. {\tt endp} is {\tt T} to begin editing at the end of the first line. Example: \begin{verbatim} (window-draw-box-xy myw 48 48 204 204) (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good")) \end{verbatim} \section{Mouse Interaction} {\tt \hspace*{0.5in} (window-get-point w)} \\ {\tt \hspace*{0.5in} (window-get-crosshairs w)} \\ {\tt \hspace*{0.5in} (window-get-cross w)} \\ These functions get a point position by mouse click; they return {\tt (x y)} . The following function gets a point position by mouse click. It returns {\tt (button (x y))} where {\tt button} is {\tt 1} for the left button, {\tt 2} for middle, {\tt 3} for right. {\tt \hspace*{0.5in} (window-get-click w)} \\ The following function gets a point position by mouse click within a specified region. It returns {\tt (button (x y))} or {\tt NIL} if the mouse leaves the region. If {\tt boxflg} is {\tt t}, a box will be drawn outside the region while the mouse is being tracked. {\tt \hspace*{0.5in} (window-track-mouse-in-region w x y sizex sizey \&optional boxflg)} \\ The following functions get a point position indicated by drawing a line from a specified origin position to the cursor position; they return {\tt (x y)} at the cursor position when a mouse button is clicked. The {\tt latex} version restricts the slope of the line to be a slope that \LaTeX \ can draw; if {\tt flg} is non-{\tt nil}, the slope is restricted to be a \LaTeX \ {\tt vector} slope. {\tt \hspace*{0.5in} (window-get-line-position w orgx orgy)} \\ {\tt \hspace*{0.5in} (window-get-latex-position w orgx orgy flg)} \\ The following function gets a position by moving a ``ghost'' icon, defined by the icon drawing function {\tt fn}. This allows exact positioning of an object by the user. {\tt \hspace*{0.5in} (window-get-icon-position w fn args \&optional (dx 0) (dy 0))} \\ \vspace{-0.15in} The function {\tt fn} has arguments {\tt (fn w x y . args)} , where {\tt x} and {\tt y} are the offset within the window {\tt w} at which the icon is to be drawn, and {\tt args} is a list of arbitrary arguments, e.g., the size of the icon, that are passed through to the drawing function. The icon is drawn in {\tt xor} mode, so it must be drawn using only ``plain'' drawing functions, without resetting window attributes. The returned value is {\tt (x y)} at the cursor position when a button is clicked. {\tt dx} and {\tt dy}, if specified, are offsets of {\tt x} and {\tt y} from the cursor position. The following function gets a position by moving a ``ghost'' box icon. {\tt \hspace*{0.5in} (window-get-box-position w width height \&optional (dx 0) (dy 0))} \\ \vspace{-0.15in} By default, the lower-left corner of the box is placed at the cursor position; {\tt dx} and {\tt dy} may be used to offset the box from the cursor, e.g., to move the box by a different corner. The returned value is {\tt (x y)} at the cursor position when a button is clicked. The following function gets coordinates of a box of arbitrary size and position. {\tt \hspace*{0.5in} (window-get-region w)} \\ \vspace{-0.15in} The user first clicks for one corner of the box, moves the mouse and clicks again for the opposite corner, then moves the box into the desired position. The returned value is \linebreak {\tt ((x y) (width height))}, where {\tt (x y)} is the lower-left corner of the box. The following function gets the size of a box by mouse selection, echoing the size in pixels below the box. {\tt offsety} should be at least {\tt 30} to leave room to display the size of the box. {\tt \hspace*{0.5in} (window-get-box-size w offsetx offsety)} \\ The following function adjusts one side of a box. {\tt \hspace*{0.5in} (window-adjust-box-side w x y width height side)} \\ \vspace{-0.15in} {\tt side} specifies the side of the box to be adjusted: {\tt left}, {\tt right}, {\tt top}, or {\tt bottom}. The result is {\tt ((x y) (width height))} for the resulting box. {\tt \hspace*{0.5in} (window-get-circle w \&optional center:vector)} \\ {\tt \hspace*{0.5in} (window-get-ellipse w \&optional center:vector)} \\ These functions interactively get a circle or ellipse. For an ellipse, a circle is gotten first for the horizontal size; then the vertical size of the ellipse is adjusted. {\tt window-get-circle} returns {\tt ((x y) radius)}. {\tt window-get-ellipse} returns {\tt ((x y) (xradius yradius))}. % {\tt \hspace*{0.5in} (window-sync w)} will clear the event queue of any % previous motion events. {\tt window-track-mouse} is the basic function for following the mouse and performing some action as it moves. This function is used in the implementation of menus and the mouse-interaction functions described in this section. {\tt \hspace*{0.5in} (window-track-mouse w fn \&optional outflg)} \vspace{-0.05in} Each time the mouse position changes or a mouse button is pressed, the function {\tt fn} is called with arguments {\tt (x y code)} where {\tt x} and {\tt y} are the cursor position, {\tt code} is a button code ({\tt 0} if no button, {\tt 1} for the left button, {\tt 2} for the middle button, or {\tt 3} for the right button). {\tt window-track-mouse} continues to track the mouse until {\tt fn} returns a value other than {\tt nil}, at which time {\tt window-track-mouse} returns that value. Usually, it is a good idea for {\tt fn} to return a value other than {\tt nil} upon a mouse click. If the argument {\tt outflg} is non-{\tt nil}, the function {\tt fn} will be called for button clicks outside the window {\tt w}; note, however, that such clicks will not be seen if the containing window intercepts them, so that this feature will work only if the window {\tt w} is inside another Lisp user window. \section{Miscellaneous Functions} {\tt \hspace*{0.5in} (stringify x)} makes its argument into a string. {\tt \hspace*{0.5in} (window-destroy-selected-window)} waits 3 seconds, then destroys the window containing the mouse cursor. This function should be used with care; it can destroy a non-user window, causing processes associated with the window to be destroyed. It is useful primarily in debugging, to get rid of a window that is left on the screen due to an error. \section{Examples} Several interactive programs using this software for their graphical interface can be found at {\tt http://www.cs.utexas.edu/users/novak/} under the heading Software Demos. \section{Web Interface} This software allows a Lisp program to be used interactively within a web page. There are two approaches, either using an X server on the computer of the person viewing the web page, or using WeirdX, a Java program that emulates an X server. Details can be found at: {\tt http://www.cs.utexas.edu/users/novak/dwindow.html} \section{Files} \begin{tabular}{ll} {\tt dec.copyright} & Copyright and license for DEC/MIT files \\ {\tt draw.lsp} & GLISP source code for interactive drawing utility \\ {\tt drawtrans.lsp} & {\tt draw.lsp} translated into plain Lisp \\ {\tt draw-gates.lsp} & Code to draw {\tt nand} gates etc. \\ {\tt dwdoc.tex} & \LaTeX \ source for this document \\ {\tt dwexports.lsp} & exported symbols \\ {\tt dwimportsb.lsp} & imported symbols \\ {\tt dwindow.lsp} & GLISP source code for {\tt dwindow} functions \\ {\tt dwtest.lsp} & Examples of use of {\tt dwindow} functions \\ {\tt dwtrans.lsp} & {\tt dwindow.lsp} translated into plain Lisp \\ {\tt editors.lsp} & Editors for colors etc. \\ {\tt editorstrans.lsp} & translation of {\tt editors.lsp} \\ {\tt gnu.license} & GNU General Public License \\ {\tt ice-cream.lsp} & Drawing of an ice cream cone made with {\tt draw} \\ {\tt lispserver.lsp} & Example web demo: a Lisp server \\ {\tt lispservertrans.lsp} & translation of {\tt lispserver.lsp} \\ {\tt menu-set.lsp} & GLISP source code for menu-set functions \\ {\tt menu-settrans.lsp} & translation of {\tt menu-set.lsp} \\ {\tt pcalc.lsp} & Pocket calculator implemented as a {\tt picmenu} \\ \end{tabular} \pagebreak \section{Data Types} \begin{verbatim} (window (listobject (parent drawable) (gcontext anything) (drawable-height integer) (drawable-width integer) (label string) (font anything) ) \end{verbatim} \vspace*{-.2in} \begin{verbatim} (menu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (menu-font symbol) (item-width integer) (item-height integer) (items (listof symbol)) ) \end{verbatim} \vspace*{-.2in} \begin{verbatim} (picmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (spec (transparent picmenu-spec)) (boxflg boolean) (deleted-buttons (listof symbol)) ) \end{verbatim} \vspace*{-.2in} \begin{verbatim} (picmenu-spec (listobject (drawing-width integer) (drawing-height integer) (buttons (listof picmenu-button)) (dotflg boolean) (drawfn anything) (menu-font symbol) )) \end{verbatim} \vspace*{-.2in} \begin{verbatim} (picmenu-button (list (buttonname symbol) (offset vector) (size vector) (highlightfn anything) (unhighlightfn anything)) \end{verbatim} \vspace*{-.2in} \begin{verbatim} (barmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (color rgb) (value integer) (maxval integer) (barwidth integer) (horizontal boolean) (subtrackfn anything) (subtrackparms (listof anything))) \end{verbatim} \pagebreak \section{Copyright} The following copyright notice applies to the portions of the software that were adapted from X Consortium software: \begin{verbatim} ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** \end{verbatim} \end{document} % Previous UT copyright: ; Copyright 1992, The University of Texas at Austin (UTA). All rights ; reserved. By using this software the USER indicates that he or she ; has read, understood and will comply with the following: ; ; -UTA hereby grants USER nonexclusive permission to use, copy and/or ; modify this software for internal, noncommercial, research purposes only. ; Any distribution, including commercial sale or license, of this software, ; copies of the software, its associated documentation and/or modifications ; of either is strictly prohibited without the prior consent of UTA. Title ; to copyright to this software and its associated documentation shall at ; all times remain with UTA. Appropriate copyright notice shall be placed ; on all software copies, and a complete copy of this notice shall be ; included in all copies of the associated documentation. No right is ; granted to use in advertising, publicity or otherwise any trademark, ; service mark, or the name of UTA. Software and/or its associated ; documentation identified as "confidential," if any, will be protected ; from unauthorized use/disclosure with the same degree of care USER ; regularly employs to safeguard its own such information. ; ; -This software and any associated documentation is provided "as is," and ; UTA MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED, INCLUDING ; THOSE OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, OR THAT ; USE OF THE SOFTWARE, MODIFICATIONS, OR ASSOCIATED DOCUMENTATION WILL ; NOT INFRINGE ANY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER INTELLECTUAL ; PROPERTY RIGHTS OF A THIRD PARTY. UTA, the University of Texas System, ; its Regents, officers, and employees shall not be liable under any ; circumstances for any direct, indirect, special, incidental, or ; consequential damages with respect to any claim by USER or any third ; party on account of or arising from the use, or inability to use, this ; software or its associated documentation, even if UTA has been advised ; of the possibility of those damages. ; ; -Submit software operation questions to: Gordon S. Novak Jr., Department ; of Computer Sciences, UT, Austin, TX 78712, novak@cs.utexas.edu . ; ; -Submit commercialization requests to: Office of the Executive Vice ; President and Provost, UT Austin, 201 Main Bldg., Austin, TX, 78712, ; ATTN: Technology Licensing Specialist. gcl-2.6.14/xgcl-2/gcl_Xstruct.lsp0000644000175000017500000004545414360276512015124 0ustar cammcamm(in-package :XLIB) ; Xstruct.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;;;;; _XQEvent functions ;;;;;; (defentry make-_XQEvent () ( fixnum "make__XQEvent" )) (defentry _XQEvent-event (fixnum) ( fixnum "_XQEvent_event" )) (defentry set-_XQEvent-event (fixnum fixnum) ( void "set__XQEvent_event" )) (defentry _XQEvent-next (fixnum) ( fixnum "_XQEvent_next" )) (defentry set-_XQEvent-next (fixnum fixnum) ( void "set__XQEvent_next" )) ;;;;;; XCharStruct functions ;;;;;; (defentry make-XCharStruct () ( fixnum "make_XCharStruct" )) (defentry XCharStruct-attributes (fixnum) ( fixnum "XCharStruct_attributes" )) (defentry set-XCharStruct-attributes (fixnum fixnum) ( void "set_XCharStruct_attributes" )) (defentry XCharStruct-descent (fixnum) ( fixnum "XCharStruct_descent" )) (defentry set-XCharStruct-descent (fixnum fixnum) ( void "set_XCharStruct_descent" )) (defentry XCharStruct-ascent (fixnum) ( fixnum "XCharStruct_ascent" )) (defentry set-XCharStruct-ascent (fixnum fixnum) ( void "set_XCharStruct_ascent" )) (defentry XCharStruct-width (fixnum) ( fixnum "XCharStruct_width" )) (defentry set-XCharStruct-width (fixnum fixnum) ( void "set_XCharStruct_width" )) (defentry XCharStruct-rbearing (fixnum) ( fixnum "XCharStruct_rbearing" )) (defentry set-XCharStruct-rbearing (fixnum fixnum) ( void "set_XCharStruct_rbearing" )) (defentry XCharStruct-lbearing (fixnum) ( fixnum "XCharStruct_lbearing" )) (defentry set-XCharStruct-lbearing (fixnum fixnum) ( void "set_XCharStruct_lbearing" )) ;;;;;; XFontProp functions ;;;;;; (defentry make-XFontProp () ( fixnum "make_XFontProp" )) (defentry XFontProp-card32 (fixnum) ( fixnum "XFontProp_card32" )) (defentry set-XFontProp-card32 (fixnum fixnum) ( void "set_XFontProp_card32" )) (defentry XFontProp-name (fixnum) ( fixnum "XFontProp_name" )) (defentry set-XFontProp-name (fixnum fixnum) ( void "set_XFontProp_name" )) ;;;;;; XFontStruct functions ;;;;;; (defentry make-XFontStruct () ( fixnum "make_XFontStruct" )) (defentry XFontStruct-descent (fixnum) ( fixnum "XFontStruct_descent" )) (defentry set-XFontStruct-descent (fixnum fixnum) ( void "set_XFontStruct_descent" )) (defentry XFontStruct-ascent (fixnum) ( fixnum "XFontStruct_ascent" )) (defentry set-XFontStruct-ascent (fixnum fixnum) ( void "set_XFontStruct_ascent" )) (defentry XFontStruct-per_char (fixnum) ( fixnum "XFontStruct_per_char" )) (defentry set-XFontStruct-per_char (fixnum fixnum) ( void "set_XFontStruct_per_char" )) (defentry XFontStruct-max_bounds (fixnum) ( fixnum "XFontStruct_max_bounds" )) (defentry set-XFontStruct-max_bounds (fixnum fixnum) ( void "set_XFontStruct_max_bounds" )) (defentry XFontStruct-min_bounds (fixnum) ( fixnum "XFontStruct_min_bounds" )) (defentry set-XFontStruct-min_bounds (fixnum fixnum) ( void "set_XFontStruct_min_bounds" )) (defentry XFontStruct-properties (fixnum) ( fixnum "XFontStruct_properties" )) (defentry set-XFontStruct-properties (fixnum fixnum) ( void "set_XFontStruct_properties" )) (defentry XFontStruct-n_properties (fixnum) ( fixnum "XFontStruct_n_properties" )) (defentry set-XFontStruct-n_properties (fixnum fixnum) ( void "set_XFontStruct_n_properties" )) (defentry XFontStruct-default_char (fixnum) ( fixnum "XFontStruct_default_char" )) (defentry set-XFontStruct-default_char (fixnum fixnum) ( void "set_XFontStruct_default_char" )) (defentry XFontStruct-all_chars_exist (fixnum) ( fixnum "XFontStruct_all_chars_exist" )) (defentry set-XFontStruct-all_chars_exist (fixnum fixnum) ( void "set_XFontStruct_all_chars_exist" )) (defentry XFontStruct-max_byte1 (fixnum) ( fixnum "XFontStruct_max_byte1" )) (defentry set-XFontStruct-max_byte1 (fixnum fixnum) ( void "set_XFontStruct_max_byte1" )) (defentry XFontStruct-min_byte1 (fixnum) ( fixnum "XFontStruct_min_byte1" )) (defentry set-XFontStruct-min_byte1 (fixnum fixnum) ( void "set_XFontStruct_min_byte1" )) (defentry XFontStruct-max_char_or_byte2 (fixnum) ( fixnum "XFontStruct_max_char_or_byte2" )) (defentry set-XFontStruct-max_char_or_byte2 (fixnum fixnum) ( void "set_XFontStruct_max_char_or_byte2" )) (defentry XFontStruct-min_char_or_byte2 (fixnum) ( fixnum "XFontStruct_min_char_or_byte2" )) (defentry set-XFontStruct-min_char_or_byte2 (fixnum fixnum) ( void "set_XFontStruct_min_char_or_byte2" )) (defentry XFontStruct-direction (fixnum) ( fixnum "XFontStruct_direction" )) (defentry set-XFontStruct-direction (fixnum fixnum) ( void "set_XFontStruct_direction" )) (defentry XFontStruct-fid (fixnum) ( fixnum "XFontStruct_fid" )) (defentry set-XFontStruct-fid (fixnum fixnum) ( void "set_XFontStruct_fid" )) (defentry XFontStruct-ext_data (fixnum) ( fixnum "XFontStruct_ext_data" )) (defentry set-XFontStruct-ext_data (fixnum fixnum) ( void "set_XFontStruct_ext_data" )) ;;;;;; XTextItem functions ;;;;;; (defentry make-XTextItem () ( fixnum "make_XTextItem" )) (defentry XTextItem-font (fixnum) ( fixnum "XTextItem_font" )) (defentry set-XTextItem-font (fixnum fixnum) ( void "set_XTextItem_font" )) (defentry XTextItem-delta (fixnum) ( fixnum "XTextItem_delta" )) (defentry set-XTextItem-delta (fixnum fixnum) ( void "set_XTextItem_delta" )) (defentry XTextItem-nchars (fixnum) ( fixnum "XTextItem_nchars" )) (defentry set-XTextItem-nchars (fixnum fixnum) ( void "set_XTextItem_nchars" )) (defentry XTextItem-chars (fixnum) ( fixnum "XTextItem_chars" )) (defentry set-XTextItem-chars (fixnum fixnum) ( void "set_XTextItem_chars" )) ;;;;;; XChar2b functions ;;;;;; (defentry make-XChar2b () ( fixnum "make_XChar2b" )) (defentry XChar2b-byte2 (fixnum) ( char "XChar2b_byte2" )) (defentry set-XChar2b-byte2 (fixnum char) ( void "set_XChar2b_byte2" )) (defentry XChar2b-byte1 (fixnum) ( char "XChar2b_byte1" )) (defentry set-XChar2b-byte1 (fixnum char) ( void "set_XChar2b_byte1" )) ;;;;;; XTextItem16 functions ;;;;;; (defentry make-XTextItem16 () ( fixnum "make_XTextItem16" )) (defentry XTextItem16-font (fixnum) ( fixnum "XTextItem16_font" )) (defentry set-XTextItem16-font (fixnum fixnum) ( void "set_XTextItem16_font" )) (defentry XTextItem16-delta (fixnum) ( fixnum "XTextItem16_delta" )) (defentry set-XTextItem16-delta (fixnum fixnum) ( void "set_XTextItem16_delta" )) (defentry XTextItem16-nchars (fixnum) ( fixnum "XTextItem16_nchars" )) (defentry set-XTextItem16-nchars (fixnum fixnum) ( void "set_XTextItem16_nchars" )) (defentry XTextItem16-chars (fixnum) ( fixnum "XTextItem16_chars" )) (defentry set-XTextItem16-chars (fixnum fixnum) ( void "set_XTextItem16_chars" )) ;;;;;; XEDataObject functions ;;;;;; (defentry make-XEDataObject () ( fixnum "make_XEDataObject" )) (defentry XEDataObject-font (fixnum) ( fixnum "XEDataObject_font" )) (defentry set-XEDataObject-font (fixnum fixnum) ( void "set_XEDataObject_font" )) (defentry XEDataObject-pixmap_format (fixnum) ( fixnum "XEDataObject_pixmap_format" )) (defentry set-XEDataObject-pixmap_format (fixnum fixnum) ( void "set_XEDataObject_pixmap_format" )) (defentry XEDataObject-screen (fixnum) ( fixnum "XEDataObject_screen" )) (defentry set-XEDataObject-screen (fixnum fixnum) ( void "set_XEDataObject_screen" )) (defentry XEDataObject-visual (fixnum) ( fixnum "XEDataObject_visual" )) (defentry set-XEDataObject-visual (fixnum fixnum) ( void "set_XEDataObject_visual" )) (defentry XEDataObject-gc (fixnum) ( fixnum "XEDataObject_gc" )) (defentry set-XEDataObject-gc (fixnum fixnum) ( void "set_XEDataObject_gc" )) ;;;;;; XSizeHints functions ;;;;;; (defentry make-XSizeHints () ( fixnum "make_XSizeHints" )) (defentry XSizeHints-win_gravity (fixnum) ( fixnum "XSizeHints_win_gravity" )) (defentry set-XSizeHints-win_gravity (fixnum fixnum) ( void "set_XSizeHints_win_gravity" )) (defentry XSizeHints-base_height (fixnum) ( fixnum "XSizeHints_base_height" )) (defentry set-XSizeHints-base_height (fixnum fixnum) ( void "set_XSizeHints_base_height" )) (defentry XSizeHints-base_width (fixnum) ( fixnum "XSizeHints_base_width" )) (defentry set-XSizeHints-base_width (fixnum fixnum) ( void "set_XSizeHints_base_width" )) (defentry XSizeHints-max_aspect_x (fixnum) ( fixnum "XSizeHints_max_aspect_x" )) (defentry set-XSizeHints-max_aspect_x (fixnum fixnum) ( void "set_XSizeHints_max_aspect_x" )) (defentry XSizeHints-max_aspect_y (fixnum) ( fixnum "XSizeHints_max_aspect_y" )) (defentry set-XSizeHints-max_aspect_y (fixnum fixnum) ( void "set_XSizeHints_max_aspect_y" )) (defentry XSizeHints-min_aspect_x (fixnum) ( fixnum "XSizeHints_min_aspect_x" )) (defentry set-XSizeHints-min_aspect_x (fixnum fixnum) ( void "set_XSizeHints_min_aspect_x" )) (defentry XSizeHints-min_aspect_y (fixnum) ( fixnum "XSizeHints_min_aspect_y" )) (defentry set-XSizeHints-min_aspect_y (fixnum fixnum) ( void "set_XSizeHints_min_aspect_y" )) (defentry XSizeHints-height_inc (fixnum) ( fixnum "XSizeHints_height_inc" )) (defentry set-XSizeHints-height_inc (fixnum fixnum) ( void "set_XSizeHints_height_inc" )) (defentry XSizeHints-width_inc (fixnum) ( fixnum "XSizeHints_width_inc" )) (defentry set-XSizeHints-width_inc (fixnum fixnum) ( void "set_XSizeHints_width_inc" )) (defentry XSizeHints-max_height (fixnum) ( fixnum "XSizeHints_max_height" )) (defentry set-XSizeHints-max_height (fixnum fixnum) ( void "set_XSizeHints_max_height" )) (defentry XSizeHints-max_width (fixnum) ( fixnum "XSizeHints_max_width" )) (defentry set-XSizeHints-max_width (fixnum fixnum) ( void "set_XSizeHints_max_width" )) (defentry XSizeHints-min_height (fixnum) ( fixnum "XSizeHints_min_height" )) (defentry set-XSizeHints-min_height (fixnum fixnum) ( void "set_XSizeHints_min_height" )) (defentry XSizeHints-min_width (fixnum) ( fixnum "XSizeHints_min_width" )) (defentry set-XSizeHints-min_width (fixnum fixnum) ( void "set_XSizeHints_min_width" )) (defentry XSizeHints-height (fixnum) ( fixnum "XSizeHints_height" )) (defentry set-XSizeHints-height (fixnum fixnum) ( void "set_XSizeHints_height" )) (defentry XSizeHints-width (fixnum) ( fixnum "XSizeHints_width" )) (defentry set-XSizeHints-width (fixnum fixnum) ( void "set_XSizeHints_width" )) (defentry XSizeHints-y (fixnum) ( fixnum "XSizeHints_y" )) (defentry set-XSizeHints-y (fixnum fixnum) ( void "set_XSizeHints_y" )) (defentry XSizeHints-x (fixnum) ( fixnum "XSizeHints_x" )) (defentry set-XSizeHints-x (fixnum fixnum) ( void "set_XSizeHints_x" )) (defentry XSizeHints-flags (fixnum) ( fixnum "XSizeHints_flags" )) (defentry set-XSizeHints-flags (fixnum fixnum) ( void "set_XSizeHints_flags" )) ;;;;;; XWMHints functions ;;;;;; (defentry make-XWMHints () ( fixnum "make_XWMHints" )) (defentry XWMHints-window_group (fixnum) ( fixnum "XWMHints_window_group" )) (defentry set-XWMHints-window_group (fixnum fixnum) ( void "set_XWMHints_window_group" )) (defentry XWMHints-icon_mask (fixnum) ( fixnum "XWMHints_icon_mask" )) (defentry set-XWMHints-icon_mask (fixnum fixnum) ( void "set_XWMHints_icon_mask" )) (defentry XWMHints-icon_y (fixnum) ( fixnum "XWMHints_icon_y" )) (defentry set-XWMHints-icon_y (fixnum fixnum) ( void "set_XWMHints_icon_y" )) (defentry XWMHints-icon_x (fixnum) ( fixnum "XWMHints_icon_x" )) (defentry set-XWMHints-icon_x (fixnum fixnum) ( void "set_XWMHints_icon_x" )) (defentry XWMHints-icon_window (fixnum) ( fixnum "XWMHints_icon_window" )) (defentry set-XWMHints-icon_window (fixnum fixnum) ( void "set_XWMHints_icon_window" )) (defentry XWMHints-icon_pixmap (fixnum) ( fixnum "XWMHints_icon_pixmap" )) (defentry set-XWMHints-icon_pixmap (fixnum fixnum) ( void "set_XWMHints_icon_pixmap" )) (defentry XWMHints-initial_state (fixnum) ( fixnum "XWMHints_initial_state" )) (defentry set-XWMHints-initial_state (fixnum fixnum) ( void "set_XWMHints_initial_state" )) (defentry XWMHints-input (fixnum) ( fixnum "XWMHints_input" )) (defentry set-XWMHints-input (fixnum fixnum) ( void "set_XWMHints_input" )) (defentry XWMHints-flags (fixnum) ( fixnum "XWMHints_flags" )) (defentry set-XWMHints-flags (fixnum fixnum) ( void "set_XWMHints_flags" )) ;;;;;; XTextProperty functions ;;;;;; (defentry make-XTextProperty () ( fixnum "make_XTextProperty" )) (defentry XTextProperty-nitems (fixnum) ( fixnum "XTextProperty_nitems" )) (defentry set-XTextProperty-nitems (fixnum fixnum) ( void "set_XTextProperty_nitems" )) (defentry XTextProperty-format (fixnum) ( fixnum "XTextProperty_format" )) (defentry set-XTextProperty-format (fixnum fixnum) ( void "set_XTextProperty_format" )) (defentry XTextProperty-encoding (fixnum) ( fixnum "XTextProperty_encoding" )) (defentry set-XTextProperty-encoding (fixnum fixnum) ( void "set_XTextProperty_encoding" )) (defentry XTextProperty-value (fixnum) ( fixnum "XTextProperty_value" )) (defentry set-XTextProperty-value (fixnum fixnum) ( void "set_XTextProperty_value" )) ;;;;;; XIconSize functions ;;;;;; (defentry make-XIconSize () ( fixnum "make_XIconSize" )) (defentry XIconSize-height_inc (fixnum) ( fixnum "XIconSize_height_inc" )) (defentry set-XIconSize-height_inc (fixnum fixnum) ( void "set_XIconSize_height_inc" )) (defentry XIconSize-width_inc (fixnum) ( fixnum "XIconSize_width_inc" )) (defentry set-XIconSize-width_inc (fixnum fixnum) ( void "set_XIconSize_width_inc" )) (defentry XIconSize-max_height (fixnum) ( fixnum "XIconSize_max_height" )) (defentry set-XIconSize-max_height (fixnum fixnum) ( void "set_XIconSize_max_height" )) (defentry XIconSize-max_width (fixnum) ( fixnum "XIconSize_max_width" )) (defentry set-XIconSize-max_width (fixnum fixnum) ( void "set_XIconSize_max_width" )) (defentry XIconSize-min_height (fixnum) ( fixnum "XIconSize_min_height" )) (defentry set-XIconSize-min_height (fixnum fixnum) ( void "set_XIconSize_min_height" )) (defentry XIconSize-min_width (fixnum) ( fixnum "XIconSize_min_width" )) (defentry set-XIconSize-min_width (fixnum fixnum) ( void "set_XIconSize_min_width" )) ;;;;;; XClassHint functions ;;;;;; (defentry make-XClassHint () ( fixnum "make_XClassHint" )) (defentry XClassHint-res_class (fixnum) ( fixnum "XClassHint_res_class" )) (defentry set-XClassHint-res_class (fixnum fixnum) ( void "set_XClassHint_res_class" )) (defentry XClassHint-res_name (fixnum) ( fixnum "XClassHint_res_name" )) (defentry set-XClassHint-res_name (fixnum fixnum) ( void "set_XClassHint_res_name" )) ;;;;;; XComposeStatus functions ;;;;;; (defentry make-XComposeStatus () ( fixnum "make_XComposeStatus" )) (defentry XComposeStatus-chars_matched (fixnum) ( fixnum "XComposeStatus_chars_matched" )) (defentry set-XComposeStatus-chars_matched (fixnum fixnum) ( void "set_XComposeStatus_chars_matched" )) (defentry XComposeStatus-compose_ptr (fixnum) ( fixnum "XComposeStatus_compose_ptr" )) (defentry set-XComposeStatus-compose_ptr (fixnum fixnum) ( void "set_XComposeStatus_compose_ptr" )) ;;;;;; XVisualInfo functions ;;;;;; (defentry make-XVisualInfo () ( fixnum "make_XVisualInfo" )) (defentry XVisualInfo-bits_per_rgb (fixnum) ( fixnum "XVisualInfo_bits_per_rgb" )) (defentry set-XVisualInfo-bits_per_rgb (fixnum fixnum) ( void "set_XVisualInfo_bits_per_rgb" )) (defentry XVisualInfo-colormap_size (fixnum) ( fixnum "XVisualInfo_colormap_size" )) (defentry set-XVisualInfo-colormap_size (fixnum fixnum) ( void "set_XVisualInfo_colormap_size" )) (defentry XVisualInfo-blue_mask (fixnum) ( fixnum "XVisualInfo_blue_mask" )) (defentry set-XVisualInfo-blue_mask (fixnum fixnum) ( void "set_XVisualInfo_blue_mask" )) (defentry XVisualInfo-green_mask (fixnum) ( fixnum "XVisualInfo_green_mask" )) (defentry set-XVisualInfo-green_mask (fixnum fixnum) ( void "set_XVisualInfo_green_mask" )) (defentry XVisualInfo-red_mask (fixnum) ( fixnum "XVisualInfo_red_mask" )) (defentry set-XVisualInfo-red_mask (fixnum fixnum) ( void "set_XVisualInfo_red_mask" )) (defentry XVisualInfo-class (fixnum) ( fixnum "XVisualInfo_class" )) (defentry set-XVisualInfo-class (fixnum fixnum) ( void "set_XVisualInfo_class" )) (defentry XVisualInfo-depth (fixnum) ( fixnum "XVisualInfo_depth" )) (defentry set-XVisualInfo-depth (fixnum fixnum) ( void "set_XVisualInfo_depth" )) (defentry XVisualInfo-screen (fixnum) ( fixnum "XVisualInfo_screen" )) (defentry set-XVisualInfo-screen (fixnum fixnum) ( void "set_XVisualInfo_screen" )) (defentry XVisualInfo-visualid (fixnum) ( fixnum "XVisualInfo_visualid" )) (defentry set-XVisualInfo-visualid (fixnum fixnum) ( void "set_XVisualInfo_visualid" )) (defentry XVisualInfo-visual (fixnum) ( fixnum "XVisualInfo_visual" )) (defentry set-XVisualInfo-visual (fixnum fixnum) ( void "set_XVisualInfo_visual" )) ;;;;;; XStandardColormap functions ;;;;;; (defentry make-XStandardColormap () ( fixnum "make_XStandardColormap" )) (defentry XStandardColormap-killid (fixnum) ( fixnum "XStandardColormap_killid" )) (defentry set-XStandardColormap-killid (fixnum fixnum) ( void "set_XStandardColormap_killid" )) (defentry XStandardColormap-visualid (fixnum) ( fixnum "XStandardColormap_visualid" )) (defentry set-XStandardColormap-visualid (fixnum fixnum) ( void "set_XStandardColormap_visualid" )) (defentry XStandardColormap-base_pixel (fixnum) ( fixnum "XStandardColormap_base_pixel" )) (defentry set-XStandardColormap-base_pixel (fixnum fixnum) ( void "set_XStandardColormap_base_pixel" )) (defentry XStandardColormap-blue_mult (fixnum) ( fixnum "XStandardColormap_blue_mult" )) (defentry set-XStandardColormap-blue_mult (fixnum fixnum) ( void "set_XStandardColormap_blue_mult" )) (defentry XStandardColormap-blue_max (fixnum) ( fixnum "XStandardColormap_blue_max" )) (defentry set-XStandardColormap-blue_max (fixnum fixnum) ( void "set_XStandardColormap_blue_max" )) (defentry XStandardColormap-green_mult (fixnum) ( fixnum "XStandardColormap_green_mult" )) (defentry set-XStandardColormap-green_mult (fixnum fixnum) ( void "set_XStandardColormap_green_mult" )) (defentry XStandardColormap-green_max (fixnum) ( fixnum "XStandardColormap_green_max" )) (defentry set-XStandardColormap-green_max (fixnum fixnum) ( void "set_XStandardColormap_green_max" )) (defentry XStandardColormap-red_mult (fixnum) ( fixnum "XStandardColormap_red_mult" )) (defentry set-XStandardColormap-red_mult (fixnum fixnum) ( void "set_XStandardColormap_red_mult" )) (defentry XStandardColormap-red_max (fixnum) ( fixnum "XStandardColormap_red_max" )) (defentry set-XStandardColormap-red_max (fixnum fixnum) ( void "set_XStandardColormap_red_max" )) (defentry XStandardColormap-colormap (fixnum) ( fixnum "XStandardColormap_colormap" )) (defentry set-XStandardColormap-colormap (fixnum fixnum) ( void "set_XStandardColormap_colormap" )) gcl-2.6.14/xgcl-2/gcl_dwsyms.lsp0000644000175000017500000000712014360276512014762 0ustar cammcamm; dwsyms.lsp Gordon S. Novak Jr. 14 Mar 95 ; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; This file imports symbols from the X library (in XLIB: package) ; to the current package (such as the :USER package). ; This will allow these symbols to be accessed by just their ; names and without any package qualifier. ; This file may be useful if you wish to modify dwindow.lsp or dwtrans.lsp . ; This file should be loaded immediately after starting Lisp: ; If Lisp has seen any of these symbols, loading this file will cause an error. (import '( xlib::BUTTONPRESS xlib::BUTTONPRESSMASK xlib::BUTTONRELEASEMASK xlib::CAPBUTT xlib::CWBACKINGSTORE xlib::CWSAVEUNDER xlib::EXPOSE xlib::EXPOSUREMASK xlib::GCBACKGROUND xlib::GCFOREGROUND xlib::GCFUNCTION xlib::GET-C-STRING xlib::GXCOPY xlib::GXXOR xlib::INT-ARRAY xlib::INT-POS xlib::ISUNMAPPED xlib::JOINMITER xlib::KEYPRESS xlib::KEYPRESSMASK xlib::KEYRELEASE xlib::KEYRELEASEMASK xlib::LEAVEWINDOWMASK xlib::LINESOLID xlib::MAKE-XCOLOR xlib::MAKE-XEVENT xlib::MAKE-XGCVALUES xlib::MAKE-XSETWINDOWATTRIBUTES xlib::MAKE-XSIZEHINTS xlib::MAKE-XWINDOWATTRIBUTES xlib::MOTIONNOTIFY xlib::NONE xlib::NoSymbol xlib::POINTERMOTIONMASK xlib::PPOSITION xlib::PSIZE xlib::SET-XCOLOR-BLUE xlib::SET-XCOLOR-GREEN xlib::SET-XCOLOR-RED xlib::SET-XSETWINDOWATTRIBUTES-BACKING_STORE xlib::SET-XSETWINDOWATTRIBUTES-SAVE_UNDER xlib::SET-XSIZEHINTS-HEIGHT xlib::SET-XSIZEHINTS-FLAGS xlib::SET-XSIZEHINTS-WIDTH xlib::SET-XSIZEHINTS-X xlib::SET-XSIZEHINTS-Y xlib::WHENMAPPED xlib::XALLOCCOLOR xlib::XANYEVENT-TYPE xlib::XANYEVENT-WINDOW xlib::XBLACKPIXEL xlib::XBUTTONEVENT-BUTTON xlib::XCHANGEWINDOWATTRIBUTES xlib::XCLEARAREA xlib::XCLEARWINDOW xlib::XCOLOR-PIXEL xlib::XCOPYAREA xlib::XCREATEFONTCURSOR xlib::XCREATEGC xlib::XCREATESIMPLEWINDOW xlib::XDEFAULTCOLORMAP xlib::XDEFAULTGC xlib::XDEFAULTSCREEN xlib::XDEFINECURSOR xlib::XDESTROYWINDOW xlib::XDRAWARC xlib::XDRAWIMAGESTRING xlib::XDRAWLINE xlib::XFILLRECTANGLE xlib::XFONTSTRUCT-FID xlib::XFLUSH xlib::XFREECOLORS xlib::XFREEGC xlib::XGCVALUES-BACKGROUND xlib::XGCVALUES-FOREGROUND xlib::XGCVALUES-FUNCTION xlib::XGETGCVALUES xlib::XGETGEOMETRY xlib::XGETWINDOWATTRIBUTES xlib::XLOADQUERYFONT xlib::XMAPWINDOW xlib::XMOTIONEVENT-X xlib::XMOTIONEVENT-Y xlib::XMOVEWINDOW xlib::XNEXTEVENT xlib::XOPENDISPLAY xlib::XPENDING xlib::XQUERYPOINTER xlib::XRECOLORCURSOR xlib::XROOTWINDOW xlib::XSELECTINPUT xlib::XSETBACKGROUND xlib::XSETFONT xlib::XSETFOREGROUND xlib::XSETFUNCTION xlib::XSETLINEATTRIBUTES xlib::XSETSTANDARDPROPERTIES xlib::XSYNC xlib::XTEXTEXTENTS xlib::XTEXTWIDTH xlib::XUNMAPWINDOW xlib::XWHITEPIXEL xlib::XWINDOWATTRIBUTES-MAP_STATE xlib::XDisplayKeycodes xlib::XGetKeyboardMapping xlib::XFree xlib::XK_Shift_R xlib::XK_Shift_L xlib::XK_Control_L xlib::XK_Control_R xlib::XK_Alt_R xlib::XK_Alt_L xlib::XK_Return xlib::XK_Tab xlib::XK_BackSpace )) (setf (get 'xlib::int-pos 'glfnresulttype) 'integer) gcl-2.6.14/xgcl-2/gcl_draw-gates.lsp0000644000175000017500000000667314360276512015506 0ustar cammcamm; draw-gates.lsp Gordon S. Novak Jr. 20 Oct 94 ; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (defun draw-nand (w x y) (window-draw-arc-xy w (+ x 24) (+ y 16) 16 16 -90 180) (window-draw-circle-xy w (+ x 45) (+ y 16) 4) (window-draw-line-xy w (+ x 24) (+ y 32) x (+ y 32)) (window-draw-line-xy w x (+ y 32) x y) (window-draw-line-xy w x y (+ x 24) y) (window-force-output w)) (setf (get 'nand 'picmenu-spec) '(picmenu-spec 52 32 ((in1 (0 26)) (in2 (0 6)) (out (50 16))) t draw-nand 9x15)) (defun draw-and (w x y) (window-draw-arc-xy w (+ x 24) (+ y 16) 16 16 -90 180) (window-draw-line-xy w (+ x 24) (+ y 32) x (+ y 32)) (window-draw-line-xy w x (+ y 32) x y) (window-draw-line-xy w x y (+ x 24) y) (window-force-output w)) (setf (get 'and 'picmenu-spec) '(picmenu-spec 40 32 ((in1 (0 26)) (in2 (0 6)) (out (40 16))) t draw-and 9x15)) (defun draw-not (w x y) (window-draw-line-xy w x (+ y 24) (+ x 21) (+ y 12)) (window-draw-line-xy w x y (+ x 21) (+ y 12)) (window-draw-line-xy w x y x (+ y 24)) (window-draw-circle-xy w (+ x 23) (+ y 12) 3) (window-force-output w)) (setf (get 'not 'picmenu-spec) '(picmenu-spec 27 24 ((in (0 12)) (out (27 12))) t draw-not 9x15)) (defun draw-or (w x y) (window-draw-arc-xy w x (- y 26) 58 58 46.4 43.6) (window-draw-arc-xy w x (+ y 58) 58 58 270.0 43.6) (window-draw-arc-xy w (- x 16) (+ y 16) 23 23 315 90) (window-force-output w) ) (setf (get 'or 'picmenu-spec) '(picmenu-spec 40 32 ((in1 (6 26)) (in2 (6 6)) (out (40 16))) t draw-or 9x15)) (defun draw-xor (w x y) (window-draw-arc-xy w (- x 16) (+ y 16) 23 23 315 90) (draw-or w (+ x 6) y))) (setf (get 'xor 'picmenu-spec) '(picmenu-spec 46 32 ((in1 (6 26)) (in2 (6 6)) (out (46 16))) t draw-xor 9x15)) (defun draw-nor (w x y) (window-draw-circle-xy w (+ x 44) (+ y 16) 4) (draw-or w x y))) (setf (get 'nor 'picmenu-spec) '(picmenu-spec 48 32 ((in1 (0 26)) (in2 (0 6)) (out (48 16))) t draw-nor 9x15)) (defun draw-nor2 (w x y) (window-draw-circle-xy w (+ x 4) (+ y 6) 4) (window-draw-circle-xy w (+ x 4) (+ y 26) 4) (draw-and w (+ x 8) y))) (setf (get 'nor2 'picmenu-spec) '(picmenu-spec 48 32 ((in1 (0 26)) (in2 (0 6)) (out (48 16))) t draw-nor2 9x15)) (defun draw-nand2 (w x y) (window-draw-circle-xy w (+ x 4) (+ y 6) 4) (window-draw-circle-xy w (+ x 4) (+ y 26) 4) (draw-or w (+ x 4) y))) (setf (get 'nand2 'picmenu-spec) '(picmenu-spec 44 32 ((in1 (0 26)) (in2 (0 6)) (out (44 16))) t draw-nand2 9x15)) gcl-2.6.14/xgcl-2/gcl_X.lsp0000644000175000017500000005223414360276512013651 0ustar cammcamm(in-package :XLIB) ; X.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;; ;; $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $ ;; Definitions for the X window system likely to be used by applications ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;;modified by Hiep H Nguyen 28 Jul 91 ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** (defconstant X_PROTOCOL 11 ) ;; current protocol version (defconstant X_PROTOCOL_REVISION 0 ) ;; current minor version (defconstant True 1) (defconstant False 0) ;; Resources ;;typedef unsigned long XID) ; ;;typedef XID Window) ; ;;typedef XID Drawable) ; ;;typedef XID Font) ; ;;typedef XID Pixmap) ; ;;typedef XID Cursor) ; ;;typedef XID Colormap) ; ;;typedef XID GContext) ; ;;typedef XID KeySym) ; ;;typedef unsigned long Mask) ; ;;typedef unsigned long Atom) ; ;;typedef unsigned long VisualID) ; ;;typedef unsigned long Time) ; ;;typedef unsigned char KeyCode) ; ;;**************************************************************** ;; * RESERVED RESOURCE AND CONSTANT DEFINITIONS ;; **************************************************************** (defconstant None 0 ) ;; universal null resource or null atom (defconstant ParentRelative 1 ) ;; background pixmap in CreateWindow ;;and ChangeWindowAttributes (defconstant CopyFromParent 0 ) ;; border pixmap in CreateWindow ;;and ChangeWindowAttributes ;;special VisualID and special window ;; class passed to CreateWindow (defconstant PointerWindow 0 ) ;; destination window in SendEvent (defconstant InputFocus 1 ) ;; destination window in SendEvent (defconstant PointerRoot 1 ) ;; focus window in SetInputFocus (defconstant AnyPropertyType 0 ) ;; special Atom, passed to GetProperty (defconstant AnyKey 0 ) ;; special Key Code, passed to GrabKey (defconstant AnyButton 0 ) ;; special Button Code, passed to GrabButton (defconstant AllTemporary 0 ) ;; special Resource ID passed to KillClient (defconstant CurrentTime 0 ) ;; special Time (defconstant NoSymbol 0 ) ;; special KeySym ;;**************************************************************** ;; * EVENT DEFINITIONS ;; **************************************************************** ;; Input Event Masks. Used as event-mask window attribute and as arguments ;; to Grab requests. Not to be confused with event names. (defconstant NoEventMask 0) (defconstant KeyPressMask (expt 2 0) ) (defconstant KeyReleaseMask (expt 2 1) ) (defconstant ButtonPressMask (expt 2 2) ) (defconstant ButtonReleaseMask (expt 2 3) ) (defconstant EnterWindowMask (expt 2 4) ) (defconstant LeaveWindowMask (expt 2 5) ) (defconstant PointerMotionMask (expt 2 6) ) (defconstant PointerMotionHintMask (expt 2 7) ) (defconstant Button1MotionMask (expt 2 8) ) (defconstant Button2MotionMask (expt 2 9) ) (defconstant Button3MotionMask (expt 2 10) ) (defconstant Button4MotionMask (expt 2 11) ) (defconstant Button5MotionMask (expt 2 12) ) (defconstant ButtonMotionMask (expt 2 13) ) (defconstant KeymapStateMask (expt 2 14)) (defconstant ExposureMask (expt 2 15) ) (defconstant VisibilityChangeMask (expt 2 16) ) (defconstant StructureNotifyMask (expt 2 17) ) (defconstant ResizeRedirectMask (expt 2 18) ) (defconstant SubstructureNotifyMask (expt 2 19) ) (defconstant SubstructureRedirectMask (expt 2 20) ) (defconstant FocusChangeMask (expt 2 21) ) (defconstant PropertyChangeMask (expt 2 22) ) (defconstant ColormapChangeMask (expt 2 23) ) (defconstant OwnerGrabButtonMask (expt 2 24) ) ;; Event names. Used in "type" field in XEvent structures. Not to be ;;confused with event masks above. They start from 2 because 0 and 1 ;;are reserved in the protocol for errors and replies. (defconstant KeyPress 2) (defconstant KeyRelease 3) (defconstant ButtonPress 4) (defconstant ButtonRelease 5) (defconstant MotionNotify 6) (defconstant EnterNotify 7) (defconstant LeaveNotify 8) (defconstant FocusIn 9) (defconstant FocusOut 10) (defconstant KeymapNotify 11) (defconstant Expose 12) (defconstant GraphicsExpose 13) (defconstant NoExpose 14) (defconstant VisibilityNotify 15) (defconstant CreateNotify 16) (defconstant DestroyNotify 17) (defconstant UnmapNotify 18) (defconstant MapNotify 19) (defconstant MapRequest 20) (defconstant ReparentNotify 21) (defconstant ConfigureNotify 22) (defconstant ConfigureRequest 23) (defconstant GravityNotify 24) (defconstant ResizeRequest 25) (defconstant CirculateNotify 26) (defconstant CirculateRequest 27) (defconstant PropertyNotify 28) (defconstant SelectionClear 29) (defconstant SelectionRequest 30) (defconstant SelectionNotify 31) (defconstant ColormapNotify 32) (defconstant ClientMessage 33) (defconstant MappingNotify 34) (defconstant LASTEvent 35 ) ;; must be bigger than any event # ;; Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, ;; state in various key-, mouse-, and button-related events. (defconstant ShiftMask (expt 2 0)) (defconstant LockMask (expt 2 1)) (defconstant ControlMask (expt 2 2)) (defconstant Mod1Mask (expt 2 3)) (defconstant Mod2Mask (expt 2 4)) (defconstant Mod3Mask (expt 2 5)) (defconstant Mod4Mask (expt 2 6)) (defconstant Mod5Mask (expt 2 7)) ;; modifier names. Used to build a SetModifierMapping request or ;; to read a GetModifierMapping request. These correspond to the ;; masks defined above. (defconstant ShiftMapIndex 0) (defconstant LockMapIndex 1) (defconstant ControlMapIndex 2) (defconstant Mod1MapIndex 3) (defconstant Mod2MapIndex 4) (defconstant Mod3MapIndex 5) (defconstant Mod4MapIndex 6) (defconstant Mod5MapIndex 7) ;; button masks. Used in same manner as Key masks above. Not to be confused ;; with button names below. (defconstant Button1Mask (expt 2 8)) (defconstant Button2Mask (expt 2 9)) (defconstant Button3Mask (expt 2 10)) (defconstant Button4Mask (expt 2 11)) (defconstant Button5Mask (expt 2 12)) (defconstant AnyModifier (expt 2 15) ) ;; used in GrabButton, GrabKey ;; button names. Used as arguments to GrabButton and as detail in ButtonPress ;; and ButtonRelease events. Not to be confused with button masks above. ;; Note that 0 is already defined above as "AnyButton". (defconstant Button1 1) (defconstant Button2 2) (defconstant Button3 3) (defconstant Button4 4) (defconstant Button5 5) ;; Notify modes (defconstant NotifyNormal 0) (defconstant NotifyGrab 1) (defconstant NotifyUngrab 2) (defconstant NotifyWhileGrabbed 3) (defconstant NotifyHint 1 ) ;; for MotionNotify events ;; Notify detail (defconstant NotifyAncestor 0) (defconstant NotifyVirtual 1) (defconstant NotifyInferior 2) (defconstant NotifyNonlinear 3) (defconstant NotifyNonlinearVirtual 4) (defconstant NotifyPointer 5) (defconstant NotifyPointerRoot 6) (defconstant NotifyDetailNone 7) ;; Visibility notify (defconstant VisibilityUnobscured 0) (defconstant VisibilityPartiallyObscured 1) (defconstant VisibilityFullyObscured 2) ;; Circulation request (defconstant PlaceOnTop 0) (defconstant PlaceOnBottom 1) ;; protocol families (defconstant FamilyInternet 0) (defconstant FamilyDECnet 1) (defconstant FamilyChaos 2) ;; Property notification (defconstant PropertyNewValue 0) (defconstant PropertyDelete 1) ;; Color Map notification (defconstant ColormapUninstalled 0) (defconstant ColormapInstalled 1) ;; GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes (defconstant GrabModeSync 0) (defconstant GrabModeAsync 1) ;; GrabPointer, GrabKeyboard reply status (defconstant GrabSuccess 0) (defconstant AlreadyGrabbed 1) (defconstant GrabInvalidTime 2) (defconstant GrabNotViewable 3) (defconstant GrabFrozen 4) ;; AllowEvents modes (defconstant AsyncPointer 0) (defconstant SyncPointer 1) (defconstant ReplayPointer 2) (defconstant AsyncKeyboard 3) (defconstant SyncKeyboard 4) (defconstant ReplayKeyboard 5) (defconstant AsyncBoth 6) (defconstant SyncBoth 7) ;; Used in SetInputFocus, GetInputFocus (defconstant RevertToNone None) (defconstant RevertToPointerRoot PointerRoot) (defconstant RevertToParent 2) ;;**************************************************************** ;; * ERROR CODES ;; **************************************************************** (defconstant Success 0 ) ;; everything's okay (defconstant BadRequest 1 ) ;; bad request code (defconstant BadValue 2 ) ;; int parameter out of range (defconstant BadWindow 3 ) ;; parameter not a Window (defconstant BadPixmap 4 ) ;; parameter not a Pixmap (defconstant BadAtom 5 ) ;; parameter not an Atom (defconstant BadCursor 6 ) ;; parameter not a Cursor (defconstant BadFont 7 ) ;; parameter not a Font (defconstant BadMatch 8 ) ;; parameter mismatch (defconstant BadDrawable 9 ) ;; parameter not a Pixmap or Window (defconstant BadAccess 10 ) ;; depending on context: ;;- key/button already grabbed ;;- attempt to free an illegal ;; cmap entry ;;- attempt to store into a read-only ;; color map entry. ;;- attempt to modify the access control ;; list from other than the local host. (defconstant BadAlloc 11 ) ;; insufficient resources (defconstant BadColor 12 ) ;; no such colormap (defconstant BadGC 13 ) ;; parameter not a GC (defconstant BadIDChoice 14 ) ;; choice not in range or already used (defconstant BadName 15 ) ;; font or color name doesn't exist (defconstant BadLength 16 ) ;; Request length incorrect (defconstant BadImplementation 17 ) ;; server is defective (defconstant FirstExtensionError 128) (defconstant LastExtensionError 255) ;;**************************************************************** ;; * WINDOW DEFINITIONS ;; **************************************************************** ;; Window classes used by CreateWindow ;; Note that CopyFromParent is already defined as 0 above (defconstant InputOutput 1) (defconstant InputOnly 2) ;; Window attributes for CreateWindow and ChangeWindowAttributes (defconstant CWBackPixmap (expt 2 0)) (defconstant CWBackPixel (expt 2 1)) (defconstant CWBorderPixmap (expt 2 2)) (defconstant CWBorderPixel (expt 2 3)) (defconstant CWBitGravity (expt 2 4)) (defconstant CWWinGravity (expt 2 5)) (defconstant CWBackingStore (expt 2 6)) (defconstant CWBackingPlanes (expt 2 7)) (defconstant CWBackingPixel (expt 2 8)) (defconstant CWOverrideRedirect (expt 2 9)) (defconstant CWSaveUnder (expt 2 10)) (defconstant CWEventMask (expt 2 11)) (defconstant CWDontPropagate (expt 2 12)) (defconstant CWColormap (expt 2 13)) (defconstant CWCursor (expt 2 14)) ;; ConfigureWindow structure (defconstant CWX (expt 2 0)) (defconstant CWY (expt 2 1)) (defconstant CWWidth (expt 2 2)) (defconstant CWHeight (expt 2 3)) (defconstant CWBorderWidth (expt 2 4)) (defconstant CWSibling (expt 2 5)) (defconstant CWStackMode (expt 2 6)) ;; Bit Gravity (defconstant ForgetGravity 0) (defconstant NorthWestGravity 1) (defconstant NorthGravity 2) (defconstant NorthEastGravity 3) (defconstant WestGravity 4) (defconstant CenterGravity 5) (defconstant EastGravity 6) (defconstant SouthWestGravity 7) (defconstant SouthGravity 8) (defconstant SouthEastGravity 9) (defconstant StaticGravity 10) ;; Window gravity + bit gravity above (defconstant UnmapGravity 0) ;; Used in CreateWindow for backing-store hint (defconstant NotUseful 0) (defconstant WhenMapped 1) (defconstant Always 2) ;; Used in GetWindowAttributes reply (defconstant IsUnmapped 0) (defconstant IsUnviewable 1) (defconstant IsViewable 2) ;; Used in ChangeSaveSet (defconstant SetModeInsert 0) (defconstant SetModeDelete 1) ;; Used in ChangeCloseDownMode (defconstant DestroyAll 0) (defconstant RetainPermanent 1) (defconstant RetainTemporary 2) ;; Window stacking method (in configureWindow) (defconstant Above 0) (defconstant Below 1) (defconstant TopIf 2) (defconstant BottomIf 3) (defconstant Opposite 4) ;; Circulation direction (defconstant RaiseLowest 0) (defconstant LowerHighest 1) ;; Property modes (defconstant PropModeReplace 0) (defconstant PropModePrepend 1) (defconstant PropModeAppend 2) ;;**************************************************************** ;; * GRAPHICS DEFINITIONS ;; **************************************************************** ;; graphics functions, as in GC.alu (defconstant GXclear 0 ) ;; 0 (defconstant GXand 1 ) ;; src AND dst (defconstant GXandReverse 2 ) ;; src AND NOT dst (defconstant GXcopy 3 ) ;; src (defconstant GXandInverted 4 ) ;; NOT src AND dst (defconstant GXnoop 5 ) ;; dst (defconstant GXxor 6 ) ;; src XOR dst (defconstant GXor 7 ) ;; src OR dst (defconstant GXnor 8 ) ;; NOT src AND NOT dst (defconstant GXequiv 9 ) ;; NOT src XOR dst (defconstant GXinvert 10 ) ;; NOT dst (defconstant GXorReverse 11 ) ;; src OR NOT dst (defconstant GXcopyInverted 12 ) ;; NOT src (defconstant GXorInverted 13 ) ;; NOT src OR dst (defconstant GXnand 14 ) ;; NOT src OR NOT dst (defconstant GXset 15 ) ;; 1 ;; LineStyle (defconstant LineSolid 0) (defconstant LineOnOffDash 1) (defconstant LineDoubleDash 2) ;; capStyle (defconstant CapNotLast 0) (defconstant CapButt 1) (defconstant CapRound 2) (defconstant CapProjecting 3) ;; joinStyle (defconstant JoinMiter 0) (defconstant JoinRound 1) (defconstant JoinBevel 2) ;; fillStyle (defconstant FillSolid 0) (defconstant FillTiled 1) (defconstant FillStippled 2) (defconstant FillOpaqueStippled 3) ;; fillRule (defconstant EvenOddRule 0) (defconstant WindingRule 1) ;; subwindow mode (defconstant ClipByChildren 0) (defconstant IncludeInferiors 1) ;; SetClipRectangles ordering (defconstant Unsorted 0) (defconstant YSorted 1) (defconstant YXSorted 2) (defconstant YXBanded 3) ;; CoordinateMode for drawing routines (defconstant CoordModeOrigin 0 ) ;; relative to the origin (defconstant CoordModePrevious 1 ) ;; relative to previous point ;; Polygon shapes ;(defconstant Complex 0 ) ;; paths may intersect (defconstant Nonconvex 1 ) ;; no paths intersect, but not convex (defconstant Convex 2 ) ;; wholly convex ;; Arc modes for PolyFillArc (defconstant ArcChord 0 ) ;; join endpoints of arc (defconstant ArcPieSlice 1 ) ;; join endpoints to center of arc ;; GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into ;; GC.stateChanges (defconstant GCFunction (expt 2 0)) (defconstant GCPlaneMask (expt 2 1)) (defconstant GCForeground (expt 2 2)) (defconstant GCBackground (expt 2 3)) (defconstant GCLineWidth (expt 2 4)) (defconstant GCLineStyle (expt 2 5)) (defconstant GCCapStyle (expt 2 6)) (defconstant GCJoinStyle (expt 2 7)) (defconstant GCFillStyle (expt 2 8)) (defconstant GCFillRule (expt 2 9) ) (defconstant GCTile (expt 2 10)) (defconstant GCStipple (expt 2 11)) (defconstant GCTileStipXOrigin (expt 2 12)) (defconstant GCTileStipYOrigin (expt 2 13)) (defconstant GCFont (expt 2 14)) (defconstant GCSubwindowMode (expt 2 15)) (defconstant GCGraphicsExposures (expt 2 16)) (defconstant GCClipXOrigin (expt 2 17)) (defconstant GCClipYOrigin (expt 2 18)) (defconstant GCClipMask (expt 2 19)) (defconstant GCDashOffset (expt 2 20)) (defconstant GCDashList (expt 2 21)) (defconstant GCArcMode (expt 2 22)) (defconstant GCLastBit 22) ;;**************************************************************** ;; * FONTS ;; **************************************************************** ;; used in QueryFont -- draw direction (defconstant FontLeftToRight 0) (defconstant FontRightToLeft 1) (defconstant FontChange 255) ;;**************************************************************** ;; * IMAGING ;; **************************************************************** ;; ImageFormat -- PutImage, GetImage (defconstant XYBitmap 0 ) ;; depth 1, XYFormat (defconstant XYPixmap 1 ) ;; depth == drawable depth (defconstant ZPixmap 2 ) ;; depth == drawable depth ;;**************************************************************** ;; * COLOR MAP STUFF ;; **************************************************************** ;; For CreateColormap (defconstant AllocNone 0 ) ;; create map with no entries (defconstant AllocAll 1 ) ;; allocate entire map writeable ;; Flags used in StoreNamedColor, StoreColors (defconstant DoRed (expt 2 0)) (defconstant DoGreen (expt 2 1)) (defconstant DoBlue (expt 2 2)) ;;**************************************************************** ;; * CURSOR STUFF ;; **************************************************************** ;; QueryBestSize Class (defconstant CursorShape 0 ) ;; largest size that can be displayed (defconstant TileShape 1 ) ;; size tiled fastest (defconstant StippleShape 2 ) ;; size stippled fastest ;;**************************************************************** ;; * KEYBOARD/POINTER STUFF ;; **************************************************************** (defconstant AutoRepeatModeOff 0) (defconstant AutoRepeatModeOn 1) (defconstant AutoRepeatModeDefault 2) (defconstant LedModeOff 0) (defconstant LedModeOn 1) ;; masks for ChangeKeyboardControl (defconstant KBKeyClickPercent (expt 2 0)) (defconstant KBBellPercent (expt 2 1)) (defconstant KBBellPitch (expt 2 2)) (defconstant KBBellDuration (expt 2 3)) (defconstant KBLed (expt 2 4)) (defconstant KBLedMode (expt 2 5)) (defconstant KBKey (expt 2 6)) (defconstant KBAutoRepeatMode (expt 2 7)) (defconstant MappingSuccess 0) (defconstant MappingBusy 1) (defconstant MappingFailed 2) (defconstant MappingModifier 0) (defconstant MappingKeyboard 1) (defconstant MappingPointer 2) ;;**************************************************************** ;; * SCREEN SAVER STUFF ;; **************************************************************** (defconstant DontPreferBlanking 0) (defconstant PreferBlanking 1) (defconstant DefaultBlanking 2) (defconstant DisableScreenSaver 0) (defconstant DisableScreenInterval 0) (defconstant DontAllowExposures 0) (defconstant AllowExposures 1) (defconstant DefaultExposures 2) ;; for ForceScreenSaver (defconstant ScreenSaverReset 0) (defconstant ScreenSaverActive 1) ;;**************************************************************** ;; * HOSTS AND CONNECTIONS ;; **************************************************************** ;; for ChangeHosts (defconstant HostInsert 0) (defconstant HostDelete 1) ;; for ChangeAccessControl (defconstant EnableAccess 1 ) (defconstant DisableAccess 0) ;; Display classes used in opening the connection ;; * Note that the statically allocated ones are even numbered and the ;; * dynamically changeable ones are odd numbered (defconstant StaticGray 0) (defconstant GrayScale 1) (defconstant StaticColor 2) (defconstant PseudoColor 3) (defconstant TrueColor 4) (defconstant DirectColor 5) ;; Byte order used in imageByteOrder and bitmapBitOrder (defconstant LSBFirst 0) (defconstant MSBFirst 1) ;(defconstant NULL 0) gcl-2.6.14/xgcl-2/XStruct-2.c0000644000175000017500000005121614360276512014013 0ustar cammcamm/* XStruct-2.c Hiep Huu Nguyen 27 Jun 06 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; edited 27 Aug 92; 12 Aug 02 by G. Novak; 24 Jun 06 by GSN ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. */ /********* _XQEvent functions *****/ #define NEED_EVENTS #include #include #include long make__XQEvent (){ return ((long) calloc(1, sizeof(_XQEvent))); } XEvent _XQEvent_event(i) _XQEvent* i; { return(i->event); } void set__XQEvent_event(i, j) _XQEvent* i; XEvent j; { i->event = j; } long _XQEvent_next(i) _XQEvent* i; { return((long) i->next); } void set__XQEvent_next(i, j) _XQEvent* i; long j; { i->next = (struct _XSQEvent *) j; } /********* XCharStruct functions *****/ long make_XCharStruct (){ return ((long) calloc(1, sizeof(XCharStruct))); } int XCharStruct_attributes(i) XCharStruct* i; { return(i->attributes); } void set_XCharStruct_attributes(i, j) XCharStruct* i; int j; { i->attributes = j; } int XCharStruct_descent(i) XCharStruct* i; { return(i->descent); } void set_XCharStruct_descent(i, j) XCharStruct* i; int j; { i->descent = j; } int XCharStruct_ascent(i) XCharStruct* i; { return(i->ascent); } void set_XCharStruct_ascent(i, j) XCharStruct* i; int j; { i->ascent = j; } int XCharStruct_width(i) XCharStruct* i; { return(i->width); } void set_XCharStruct_width(i, j) XCharStruct* i; int j; { i->width = j; } int XCharStruct_rbearing(i) XCharStruct* i; { return(i->rbearing); } void set_XCharStruct_rbearing(i, j) XCharStruct* i; int j; { i->rbearing = j; } int XCharStruct_lbearing(i) XCharStruct* i; { return(i->lbearing); } void set_XCharStruct_lbearing(i, j) XCharStruct* i; int j; { i->lbearing = j; } /********* XFontProp functions *****/ long make_XFontProp (){ return ((long) calloc(1, sizeof(XFontProp))); } int XFontProp_card32(i) XFontProp* i; { return(i->card32); } void set_XFontProp_card32(i, j) XFontProp* i; int j; { i->card32 = j; } int XFontProp_name(i) XFontProp* i; { return(i->name); } void set_XFontProp_name(i, j) XFontProp* i; int j; { i->name = j; } /********* XFontStruct functions *****/ long make_XFontStruct (){ return ((long) calloc(1, sizeof(XFontStruct))); } int XFontStruct_descent(i) XFontStruct* i; { return(i->descent); } void set_XFontStruct_descent(i, j) XFontStruct* i; int j; { i->descent = j; } int XFontStruct_ascent(i) XFontStruct* i; { return(i->ascent); } void set_XFontStruct_ascent(i, j) XFontStruct* i; int j; { i->ascent = j; } long XFontStruct_per_char(i) XFontStruct* i; { return((long) i->per_char); } void set_XFontStruct_per_char(i, j) XFontStruct* i; long j; { i->per_char = (XCharStruct *) j; } long XFontStruct_max_bounds(i) XFontStruct* i; { return((long) &i->max_bounds); } long XFontStruct_min_bounds(i) XFontStruct* i; { return((long) &i->min_bounds); } void set_XFontStruct_max_bounds(i, j) XFontStruct* i; XCharStruct j; { i->max_bounds = j; } void set_XFontStruct_min_bounds(i, j) XFontStruct* i; XCharStruct j; { i->min_bounds = j; } long XFontStruct_properties(i) XFontStruct* i; { return((long) i->properties); } void set_XFontStruct_properties(i, j) XFontStruct* i; long j; { i->properties = (XFontProp *) j; } int XFontStruct_n_properties(i) XFontStruct* i; { return(i->n_properties); } void set_XFontStruct_n_properties(i, j) XFontStruct* i; int j; { i->n_properties = j; } int XFontStruct_default_char(i) XFontStruct* i; { return(i->default_char); } void set_XFontStruct_default_char(i, j) XFontStruct* i; int j; { i->default_char = j; } int XFontStruct_all_chars_exist(i) XFontStruct* i; { return(i->all_chars_exist); } void set_XFontStruct_all_chars_exist(i, j) XFontStruct* i; int j; { i->all_chars_exist = j; } int XFontStruct_max_byte1(i) XFontStruct* i; { return(i->max_byte1); } void set_XFontStruct_max_byte1(i, j) XFontStruct* i; int j; { i->max_byte1 = j; } int XFontStruct_min_byte1(i) XFontStruct* i; { return(i->min_byte1); } void set_XFontStruct_min_byte1(i, j) XFontStruct* i; int j; { i->min_byte1 = j; } int XFontStruct_max_char_or_byte2(i) XFontStruct* i; { return(i->max_char_or_byte2); } void set_XFontStruct_max_char_or_byte2(i, j) XFontStruct* i; int j; { i->max_char_or_byte2 = j; } int XFontStruct_min_char_or_byte2(i) XFontStruct* i; { return(i->min_char_or_byte2); } void set_XFontStruct_min_char_or_byte2(i, j) XFontStruct* i; int j; { i->min_char_or_byte2 = j; } int XFontStruct_direction(i) XFontStruct* i; { return(i->direction); } void set_XFontStruct_direction(i, j) XFontStruct* i; int j; { i->direction = j; } int XFontStruct_fid(i) XFontStruct* i; { return(i->fid); } void set_XFontStruct_fid(i, j) XFontStruct* i; int j; { i->fid = j; } long XFontStruct_ext_data(i) XFontStruct* i; { return((long) i->ext_data); } void set_XFontStruct_ext_data(i, j) XFontStruct* i; long j; { i->ext_data = (XExtData *) j; } /********* XTextItem functions *****/ long make_XTextItem (){ return ((long) calloc(1, sizeof(XTextItem))); } int XTextItem_font(i) XTextItem* i; { return(i->font); } void set_XTextItem_font(i, j) XTextItem* i; int j; { i->font = j; } int XTextItem_delta(i) XTextItem* i; { return(i->delta); } void set_XTextItem_delta(i, j) XTextItem* i; int j; { i->delta = j; } int XTextItem_nchars(i) XTextItem* i; { return(i->nchars); } void set_XTextItem_nchars(i, j) XTextItem* i; int j; { i->nchars = j; } long XTextItem_chars(i) XTextItem* i; { return((long) i->chars); } void set_XTextItem_chars(i, j) XTextItem* i; long j; { i->chars = (char *) j; } /********* XChar2b functions *****/ long make_XChar2b (){ return ((long) calloc(1, sizeof(XChar2b))); } char XChar2b_byte2(i) XChar2b* i; { return(i->byte2); } void set_XChar2b_byte2(i, j) XChar2b* i; char j; { i->byte2 = j; } char XChar2b_byte1(i) XChar2b* i; { return(i->byte1); } void set_XChar2b_byte1(i, j) XChar2b* i; char j; { i->byte1 = j; } /********* XTextItem16 functions *****/ long make_XTextItem16 (){ return ((long) calloc(1, sizeof(XTextItem16))); } int XTextItem16_font(i) XTextItem16* i; { return(i->font); } void set_XTextItem16_font(i, j) XTextItem16* i; int j; { i->font = j; } int XTextItem16_delta(i) XTextItem16* i; { return(i->delta); } void set_XTextItem16_delta(i, j) XTextItem16* i; int j; { i->delta = j; } int XTextItem16_nchars(i) XTextItem16* i; { return(i->nchars); } void set_XTextItem16_nchars(i, j) XTextItem16* i; int j; { i->nchars = j; } long XTextItem16_chars(i) XTextItem16* i; { return((long) i->chars); } void set_XTextItem16_chars(i, j) XTextItem16* i; long j; { i->chars = (XChar2b *) j; } /********* XEDataObject functions *****/ long make_XEDataObject (){ return ((long) calloc(1, sizeof(XEDataObject))); } long XEDataObject_font(i) XEDataObject* i; { return((long) i->font); } void set_XEDataObject_font(i, j) XEDataObject* i; long j; { i->font = (XFontStruct *) j; } long XEDataObject_pixmap_format(i) XEDataObject* i; { return((long) i->pixmap_format); } void set_XEDataObject_pixmap_format(i, j) XEDataObject* i; long j; { i->pixmap_format = (ScreenFormat *) j; } long XEDataObject_screen(i) XEDataObject* i; { return((long) i->screen); } void set_XEDataObject_screen(i, j) XEDataObject* i; long j; { i->screen = (Screen *) j; } long XEDataObject_visual(i) XEDataObject* i; { return((long) i->visual); } void set_XEDataObject_visual(i, j) XEDataObject* i; long j; { i->visual = (Visual *) j; } GC XEDataObject_gc(i) XEDataObject* i; { return(i->gc); } void set_XEDataObject_gc(i, j) XEDataObject* i; GC j; { i->gc = j; } /********* XSizeHints functions *****/ long make_XSizeHints (){ return ((long) calloc(1, sizeof(XSizeHints))); } int XSizeHints_win_gravity(i) XSizeHints *i; { return(i->win_gravity); } void set_XSizeHints_win_gravity(i, j) XSizeHints *i; int j; { i->win_gravity = j; } int XSizeHints_base_height(i) XSizeHints* i; { return(i->base_height); } void set_XSizeHints_base_height(i, j) XSizeHints* i; int j; { i->base_height = j; } int XSizeHints_base_width(i) XSizeHints* i; { return(i->base_width); } void set_XSizeHints_base_width(i, j) XSizeHints* i; int j; { i->base_width = j; } int XSizeHints_height_inc(i) XSizeHints* i; { return(i->height_inc); } void set_XSizeHints_height_inc(i, j) XSizeHints* i; int j; { i->height_inc = j; } int XSizeHints_width_inc(i) XSizeHints* i; { return(i->width_inc); } void set_XSizeHints_width_inc(i, j) XSizeHints* i; int j; { i->width_inc = j; } int XSizeHints_max_height(i) XSizeHints* i; { return(i->max_height); } void set_XSizeHints_max_height(i, j) XSizeHints* i; int j; { i->max_height = j; } int XSizeHints_max_width(i) XSizeHints* i; { return(i->max_width); } void set_XSizeHints_max_width(i, j) XSizeHints* i; int j; { i->max_width = j; } int XSizeHints_min_height(i) XSizeHints* i; { return(i->min_height); } void set_XSizeHints_min_height(i, j) XSizeHints* i; int j; { i->min_height = j; } int XSizeHints_min_width(i) XSizeHints* i; { return(i->min_width); } void set_XSizeHints_min_width(i, j) XSizeHints* i; int j; { i->min_width = j; } int XSizeHints_height(i) XSizeHints* i; { return(i->height); } void set_XSizeHints_height(i, j) XSizeHints* i; int j; { i->height = j; } int XSizeHints_width(i) XSizeHints* i; { return(i->width); } void set_XSizeHints_width(i, j) XSizeHints* i; int j; { i->width = j; } int XSizeHints_y(i) XSizeHints* i; { return(i->y); } void set_XSizeHints_y(i, j) XSizeHints* i; int j; { i->y = j; } int XSizeHints_x(i) XSizeHints* i; { return(i->x); } void set_XSizeHints_x(i, j) XSizeHints* i; int j; { i->x = j; } int XSizeHints_flags(i) XSizeHints* i; { return(i->flags); } void set_XSizeHints_flags(i, j) XSizeHints* i; int j; { i->flags = j; } int XSizeHints_max_aspect_x(i) XSizeHints* i; { return(i->max_aspect.x); } void set_XSizeHints_max_aspect_x(i, j) XSizeHints* i; int j; { i->max_aspect.x = j; } int XSizeHints_max_aspect_y(i) XSizeHints* i; { return(i->max_aspect.y); } void set_XSizeHints_max_aspect_y(i, j) XSizeHints* i; int j; { i->max_aspect.y = j; } int XSizeHints_min_aspect_x(i) XSizeHints* i; { return(i->min_aspect.x); } void set_XSizeHints_min_aspect_x(i, j) XSizeHints* i; int j; { i->min_aspect.x = j; } int XSizeHints_min_aspect_y(i) XSizeHints* i; { return(i->min_aspect.y); } void set_XSizeHints_min_aspect_y(i, j) XSizeHints* i; int j; { i->min_aspect.y = j; } /********* XWMHints functions *****/ long make_XWMHints (){ return ((long) calloc(1, sizeof(XWMHints))); } int XWMHints_window_group(i) XWMHints* i; { return(i->window_group); } void set_XWMHints_window_group(i, j) XWMHints* i; int j; { i->window_group = j; } int XWMHints_icon_mask(i) XWMHints* i; { return(i->icon_mask); } void set_XWMHints_icon_mask(i, j) XWMHints* i; int j; { i->icon_mask = j; } int XWMHints_icon_y(i) XWMHints* i; { return(i->icon_y); } void set_XWMHints_icon_y(i, j) XWMHints* i; int j; { i->icon_y = j; } int XWMHints_icon_x(i) XWMHints* i; { return(i->icon_x); } void set_XWMHints_icon_x(i, j) XWMHints* i; int j; { i->icon_x = j; } int XWMHints_icon_window(i) XWMHints* i; { return(i->icon_window); } void set_XWMHints_icon_window(i, j) XWMHints* i; int j; { i->icon_window = j; } int XWMHints_icon_pixmap(i) XWMHints* i; { return(i->icon_pixmap); } void set_XWMHints_icon_pixmap(i, j) XWMHints* i; int j; { i->icon_pixmap = j; } int XWMHints_initial_state(i) XWMHints* i; { return(i->initial_state); } void set_XWMHints_initial_state(i, j) XWMHints* i; int j; { i->initial_state = j; } int XWMHints_input(i) XWMHints* i; { return(i->input); } void set_XWMHints_input(i, j) XWMHints* i; int j; { i->input = j; } int XWMHints_flags(i) XWMHints* i; { return(i->flags); } void set_XWMHints_flags(i, j) XWMHints* i; int j; { i->flags = j; } /********* XTextProperty functions *****/ long make_XTextProperty (){ return ((long) calloc(1, sizeof(XTextProperty))); } int XTextProperty_nitems(i) XTextProperty *i; { return(i->nitems); } void set_XTextProperty_nitems(i, j) XTextProperty* i; int j; { i->nitems = j; } int XTextProperty_format(i) XTextProperty* i; { return(i->format); } void set_XTextProperty_format(i, j) XTextProperty* i; int j; { i->format = j; } int XTextProperty_encoding(i) XTextProperty* i; { return(i->encoding); } void set_XTextProperty_encoding(i, j) XTextProperty* i; int j; { i->encoding = j; } long XTextProperty_value(i) XTextProperty* i; { return((long) i->value); } void set_XTextProperty_value(i, j) XTextProperty* i; long j; { i->value = (unsigned char *) j; } /********* XIconSize functions *****/ long make_XIconSize (){ return ((long) calloc(1, sizeof(XIconSize))); } int XIconSize_height_inc(i) XIconSize* i; { return(i->height_inc); } void set_XIconSize_height_inc(i, j) XIconSize* i; int j; { i->height_inc = j; } int XIconSize_width_inc(i) XIconSize* i; { return(i->width_inc); } void set_XIconSize_width_inc(i, j) XIconSize* i; int j; { i->width_inc = j; } int XIconSize_max_height(i) XIconSize* i; { return(i->max_height); } void set_XIconSize_max_height(i, j) XIconSize* i; int j; { i->max_height = j; } int XIconSize_max_width(i) XIconSize* i; { return(i->max_width); } void set_XIconSize_max_width(i, j) XIconSize* i; int j; { i->max_width = j; } int XIconSize_min_height(i) XIconSize* i; { return(i->min_height); } void set_XIconSize_min_height(i, j) XIconSize* i; int j; { i->min_height = j; } int XIconSize_min_width(i) XIconSize* i; { return(i->min_width); } void set_XIconSize_min_width(i, j) XIconSize* i; int j; { i->min_width = j; } /********* XClassHint functions *****/ long make_XClassHint (){ return ((long) calloc(1, sizeof(XClassHint))); } long XClassHint_res_class(i) XClassHint* i; { return((long) i->res_class); } void set_XClassHint_res_class(i, j) XClassHint* i; long j; { i->res_class = (char *) j; } long XClassHint_res_name(i) XClassHint* i; { return((long) i->res_name); } void set_XClassHint_res_name(i, j) XClassHint* i; long j; { i->res_name = (char *) j; } /********* XComposeStatus functions *****/ long make_XComposeStatus (){ return ((long) calloc(1, sizeof(XComposeStatus))); } int XComposeStatus_chars_matched(i) XComposeStatus* i; { return(i->chars_matched); } void set_XComposeStatus_chars_matched(i, j) XComposeStatus* i; int j; { i->chars_matched = j; } long XComposeStatus_compose_ptr(i) XComposeStatus* i; { return((long) i->compose_ptr); } void set_XComposeStatus_compose_ptr(i, j) XComposeStatus* i; long j; { i->compose_ptr = (XPointer) j; } /********* XVisualInfo functions *****/ long make_XVisualInfo (){ return ((long) calloc(1, sizeof(XVisualInfo))); } int XVisualInfo_bits_per_rgb(i) XVisualInfo* i; { return(i->bits_per_rgb); } void set_XVisualInfo_bits_per_rgb(i, j) XVisualInfo* i; int j; { i->bits_per_rgb = j; } int XVisualInfo_colormap_size(i) XVisualInfo* i; { return(i->colormap_size); } void set_XVisualInfo_colormap_size(i, j) XVisualInfo* i; int j; { i->colormap_size = j; } int XVisualInfo_blue_mask(i) XVisualInfo* i; { return(i->blue_mask); } void set_XVisualInfo_blue_mask(i, j) XVisualInfo* i; int j; { i->blue_mask = j; } int XVisualInfo_green_mask(i) XVisualInfo* i; { return(i->green_mask); } void set_XVisualInfo_green_mask(i, j) XVisualInfo* i; int j; { i->green_mask = j; } int XVisualInfo_red_mask(i) XVisualInfo* i; { return(i->red_mask); } void set_XVisualInfo_red_mask(i, j) XVisualInfo* i; int j; { i->red_mask = j; } int XVisualInfo_class(i) XVisualInfo* i; { return(i->class); } void set_XVisualInfo_class(i, j) XVisualInfo* i; int j; { i->class = j; } int XVisualInfo_depth(i) XVisualInfo* i; { return(i->depth); } void set_XVisualInfo_depth(i, j) XVisualInfo* i; int j; { i->depth = j; } int XVisualInfo_screen(i) XVisualInfo* i; { return(i->screen); } void set_XVisualInfo_screen(i, j) XVisualInfo* i; int j; { i->screen = j; } int XVisualInfo_visualid(i) XVisualInfo* i; { return(i->visualid); } void set_XVisualInfo_visualid(i, j) XVisualInfo* i; int j; { i->visualid = j; } long XVisualInfo_visual(i) XVisualInfo* i; { return((long) i->visual); } void set_XVisualInfo_visual(i, j) XVisualInfo* i; long j; { i->visual = (Visual *) j; } /********* XStandardColormap functions *****/ long make_XStandardColormap (){ return ((long) calloc(1, sizeof(XStandardColormap))); } int XStandardColormap_killid(i) XStandardColormap* i; { return(i->killid); } void set_XStandardColormap_killid(i, j) XStandardColormap* i; int j; { i->killid = j; } int XStandardColormap_visualid(i) XStandardColormap* i; { return(i->visualid); } void set_XStandardColormap_visualid(i, j) XStandardColormap* i; int j; { i->visualid = j; } int XStandardColormap_base_pixel(i) XStandardColormap* i; { return(i->base_pixel); } void set_XStandardColormap_base_pixel(i, j) XStandardColormap* i; int j; { i->base_pixel = j; } int XStandardColormap_blue_mult(i) XStandardColormap* i; { return(i->blue_mult); } void set_XStandardColormap_blue_mult(i, j) XStandardColormap* i; int j; { i->blue_mult = j; } int XStandardColormap_blue_max(i) XStandardColormap* i; { return(i->blue_max); } void set_XStandardColormap_blue_max(i, j) XStandardColormap* i; int j; { i->blue_max = j; } int XStandardColormap_green_mult(i) XStandardColormap* i; { return(i->green_mult); } void set_XStandardColormap_green_mult(i, j) XStandardColormap* i; int j; { i->green_mult = j; } int XStandardColormap_green_max(i) XStandardColormap* i; { return(i->green_max); } void set_XStandardColormap_green_max(i, j) XStandardColormap* i; int j; { i->green_max = j; } int XStandardColormap_red_mult(i) XStandardColormap* i; { return(i->red_mult); } void set_XStandardColormap_red_mult(i, j) XStandardColormap* i; int j; { i->red_mult = j; } int XStandardColormap_red_max(i) XStandardColormap* i; { return(i->red_max); } void set_XStandardColormap_red_max(i, j) XStandardColormap* i; int j; { i->red_max = j; } int XStandardColormap_colormap(i) XStandardColormap* i; { return(i->colormap); } void set_XStandardColormap_colormap(i, j) XStandardColormap* i; int j; { i->colormap = j; } gcl-2.6.14/xgcl-2/gcl_menu-settrans.lsp0000644000175000017500000005012614360276512016245 0ustar cammcamm; 07 Jan 2010 16:46:11 EST ; menu-settrans.lsp -- translation of menu-set.lsp Gordon S. Novak Jr. ; Copyright 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (defmacro nconc1 (lst x) `(nconc ,lst (cons ,x nil))) (defmacro glmethod (class selector) `(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) ) (SETF (GET 'MENU-SET 'GLSTRUCTURE) '((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM)) (COMMANDFN ANYTHING)) MSG ((DRAW MENU-SET-DRAW) (SELECT MENU-SET-SELECT) (NAMED-MENU MENU-SET-NAMED-MENU) (NAMED-ITEM MENU-SET-NAMED-ITEM) (ADD-MENU MENU-SET-ADD-MENU) (ADD-PICMENU MENU-SET-ADD-PICMENU) (ADD-COMPONENT MENU-SET-ADD-COMPONENT) (ADD-BARMENU MENU-SET-ADD-BARMENU) (ADD-ITEM MENU-SET-ADD-ITEM) (FIND-ITEM MENU-SET-FIND-ITEM) (DELETE-ITEM MENU-SET-DELETE-ITEM) (REMOVE-ITEMS MENU-SET-REMOVE-ITEMS) (ITEM-POSITION MENU-SET-ITEM-POSITION) (ITEMP MENU-SET-ITEMP) (ADJUST MENU-SET-ADJUST) (MOVE MENU-SET-MOVE) (DRAW-CONN MENU-SET-DRAW-CONN)))) (SETF (GET 'MENU-SET-ITEM 'GLSTRUCTURE) '((LIST (MENU-NAME SYMBOL) (SYM ANYTHING) (MENU MENU-SET-MENU)) PROP ((LEFT ((PARENT-OFFSET-X MENU))) (BOTTOM ((PARENT-OFFSET-Y MENU))) (WIDTH ((PICTURE-WIDTH MENU))) (HEIGHT ((PICTURE-HEIGHT MENU)))) SUPERS (REGION))) (SETF (GET 'MENU-SET-MENU 'GLSTRUCTURE) '((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW)))) (SETF (GET 'MENU-PORT 'GLSTRUCTURE) '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL)))) (SETF (GET 'MENU-SELECTION 'GLSTRUCTURE) '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER)))) (SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE) '((LIST (FROM MENU-PORT) (TO MENU-PORT)))) (SETF (GET 'MENU-CONNS 'GLSTRUCTURE) '((LISTOBJECT (MENU-SET MENU-SET) (CONNECTIONS (LISTOF MENU-SET-CONN))) PROP ((WINDOW ((WINDOW (MENU-SET SELF))))) MSG ((DRAW MENU-CONNS-DRAW) (REDRAW MENU-CONNS-REDRAW) (MOVE MENU-CONNS-MOVE) (ADD-CONN MENU-CONNS-ADD-CONN) (ADD-ITEM MENU-CONNS-ADD-ITEM OPEN T) (FIND-CONN MENU-CONNS-FIND-CONN) (FIND-ITEM MENU-CONNS-FIND-ITEM) (DELETE-ITEM MENU-CONNS-DELETE-ITEM) (DELETE-CONN MENU-CONNS-DELETE-CONN) (REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS) (FIND-CONNS MENU-CONNS-FIND-CONNS) (CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS) (NEW-CONN MENU-CONNS-NEW-CONN) (NAMED-MENU MENU-CONNS-NAMED-MENU) (NAMED-ITEM MENU-CONNS-NAMED-ITEM)))) (DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN)) (SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS) '((W WINDOW) (&OPTIONAL NIL))) (SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET) (DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED) (LET (RES RESB ITM SEL LASTX LASTY) (IF REDRAW (MENU-SET-DRAW MS)) (WHILE (NOT (OR RES RESB)) (SETQ ITM (WINDOW-TRACK-MOUSE (CADR MS) #'(LAMBDA (X Y CODE) (OR (AND (PLUSP CODE) (SETQ LASTX X) (SETQ LASTY Y) CODE) (SOME #'(LAMBDA (GLVAR237) (IF (AND (BETWEEN X (FIFTH (CADDR GLVAR237)) (+ (FIFTH (CADDR GLVAR237)) (SEVENTH (CADDR GLVAR237)))) (BETWEEN Y (SIXTH (CADDR GLVAR237)) (+ (SIXTH (CADDR GLVAR237)) (EIGHTH (CADDR GLVAR237))))) GLVAR237)) (CADDR MS)))))) (IF (NUMBERP ITM) (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM)) (WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED)) (SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T))) (IF SEL (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*)) (IF (AND *WINDOW-MENU-CODE* (NOT (ZEROP *WINDOW-MENU-CODE*))) (SETQ RES (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*))))))) (XFLUSH *WINDOW-DISPLAY*) (OR RES RESB))) (SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS) '((MS MENU-SET) (&OPTIONAL BOOLEAN) (REDRAW (LISTOF SYMBOL)))) (SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION) (DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET) (LET (MENU) (SETQ MENU (MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) T T)) (MENU-INIT MENU) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) (EIGHTH MENU)))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU))) (SETF (GET 'MENU-SET-ADD-MENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) (ITEMS NIL) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU) (SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL)))) (SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) (SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL)) (SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET))) (SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-PICMENU (MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX) (LET (MENU MAXWIDTH MAXHEIGHT) (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC))) (SETQ MENU (PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) T T (NOT NOBOX))) (SETQ MAXWIDTH (MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC))) (SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC))) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU))) (SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) (SPEC PICMENU-SPEC) (&OPTIONAL VECTOR) (OFFSET BOOLEAN))) (SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET) (MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T)) (SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET) (BARMENU-INIT MENU) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) (EIGHTH MENU)))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU)) (SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU) (TITLE STRING) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-NAME (NM) (INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM))))) (SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL))) (SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL) (DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS))) (SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL))) (SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-SET-NAMED-MENU (MS NAME) (CADDR (MENU-SET-NAMED-ITEM MS NAME))) (SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL))) (SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) (DEFUN MENU-SET-ITEMP (MS NAME ITEMNAME) (LET ((THISMENU (MENU-SET-NAMED-MENU MS NAME))) (IF (EQ (FIRST THISMENU) 'MENU) (SOME #'(LAMBDA (X) (OR (EQ X ITEMNAME) (AND (CONSP X) (EQ (CAR X) ITEMNAME)))) (NTH 13 THISMENU)) (IF (EQ (FIRST THISMENU) 'PICMENU) (ASSOC ITEMNAME (CADDDR (NTH 10 THISMENU))))))) (SETF (GET 'MENU-SET-ITEMP 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (ITEMNAME SYMBOL))) (SETF (GET 'MENU-SET-ITEMP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN MENU-CONNS-NAMED-ITEM (MC NAME) (MENU-SET-NAMED-ITEM (CADR MC) NAME)) (SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL))) (SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-CONNS-NAMED-MENU (MC NAME) (MENU-SET-NAMED-MENU (CADR MC) NAME)) (SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL))) (SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) (DEFUN MENU-SET-FIND-ITEM (MS POS) (LET (MITEM) (DOLIST (MI (CADDR MS)) (IF (AND (BETWEEN (CAR POS) (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (FIFTH SELF) 0)) (+ (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (FIFTH SELF) 0)) (SEVENTH (CADDR MI)))) (BETWEEN (CADR POS) (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (SIXTH SELF) 0)) (+ (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (SIXTH SELF) 0)) (EIGHTH (CADDR MI))))) (SETQ MITEM MI))) MITEM)) (SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS) '((MS MENU-SET) (POS VECTOR))) (SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-SET-DELETE-ITEM (MS MI) (SETF (CADDR MS) (REMOVE MI (CADDR MS)))) (SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS) '((MS MENU-SET) (MI MENU-SET-ITEM))) (SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-MOVE (MS) (LET (SEL M) (SETQ SEL (MENU-SET-SELECT MS NIL T)) (SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL))) (MENU-REPOSITION M))) (DEFUN MENU-MDRAW (M) (CASE (FIRST M) (MENU (MENU-DRAW M)) (PICMENU (PICMENU-DRAW M)) (BARMENU (BARMENU-DRAW M)) (TEXTMENU (TEXTMENU-DRAW M)) (EDITMENU (EDITMENU-DRAW M)) (T (GLSEND M DRAW)))) (DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK) (CASE (FIRST M) (MENU (MENU-SELECT M T)) (PICMENU (PICMENU-SELECT M T ANYCLICK)) (BARMENU (BARMENU-SELECT M)) (TEXTMENU (TEXTMENU-SELECT M T)) (EDITMENU (EDITMENU-SELECT M T)) (T (GLSEND M SELECT)))) (DEFUN MENU-MITEM-POSITION (M NAME LOC) (CASE (FIRST M) (MENU (MENU-ITEM-POSITION M NAME LOC)) (PICMENU (PICMENU-ITEM-POSITION M NAME LOC)) (T (GLSEND M ITEM-POSITION NAME LOC)))) (DEFUN MENU-SET-DRAW (MS) (XMAPWINDOW *WINDOW-DISPLAY* (CADADR MS)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE (CADR MS)) (DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM)))) (DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC) (LET (M) (SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC))) (OR (MENU-MITEM-POSITION M (CAR DESC) LOC) (MENU-MITEM-POSITION M NIL LOC)))) (SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS) '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL SYMBOL))) (SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR) (DEFUN MENU-SET-DRAW-CONN (MS CONN) (LET (PA PB TMP (DESCA (CAR CONN)) (DESCB (CADR CONN))) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) (WHEN (> (CAR PA) (CAR PB)) (SETQ TMP DESCA) (SETQ DESCA DESCB) (SETQ DESCB TMP)) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PA) (CADR PA) 3 NIL) (WINDOW-DRAW-LINE-XY (CADR MS) (CAR PA) (CADR PA) (CAR PB) (CADR PB) NIL) (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PB) (CADR PB) 3 NIL) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET) (LET (M FROMM PLACE) (WHEN (SETQ M (MENU-SET-NAMED-ITEM MS NAME)) (IF FROM (PROGN (SETQ FROMM (MENU-SET-NAMED-ITEM MS FROM)) (SETQ PLACE (CASE EDGE (TOP (SIXTH (CADDR FROMM))) (BOTTOM (+ (SIXTH (CADDR FROMM)) (EIGHTH (CADDR FROMM)))) (LEFT (+ (FIFTH (CADDR FROMM)) (SEVENTH (CADDR FROMM)))) (RIGHT (FIFTH (CADDR FROMM)))))) (SETQ PLACE (CASE EDGE (TOP (CADDDR (CADR MS))) ((BOTTOM LEFT) 0) (RIGHT (FIFTH (CADR MS)))))) (CASE EDGE (TOP (SETF (SIXTH (CADDR M)) (- (- PLACE (EIGHTH (CADDR M))) OFFSET))) (BOTTOM (SETF (SIXTH (CADDR M)) (+ PLACE OFFSET))) (LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET))) (RIGHT (SETF (FIFTH (CADDR M)) (- (- PLACE (SEVENTH (CADDR M))) OFFSET))))))) (SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL) (OFFSET INTEGER))) (SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER) (DEFUN VECTOR-SNAP (FIXED APPROX &OPTIONAL TOLERANCE) (OR TOLERANCE (SETQ TOLERANCE 10)) (IF (< (ABS (- (CAR FIXED) (CAR APPROX))) TOLERANCE) (LIST (CAR FIXED) (CADR APPROX)) (IF (< (ABS (- (CADR FIXED) (CADR APPROX))) TOLERANCE) (LIST (CAR APPROX) (CADR FIXED)) APPROX))) (SETF (GET 'VECTOR-SNAP 'GLARGUMENTS) '((FIXED VECTOR) (APPROX VECTOR) (&OPTIONAL NIL))) (SETF (GET 'VECTOR-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL)) (SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET))) (SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS) (DEFUN MENU-CONNS-DRAW (MC) (MENU-SET-DRAW (CADR MC)) (DOLIST (C (CADDR MC)) (MENU-SET-DRAW-CONN (CADR MC) C))) (DEFUN MENU-CONNS-MOVE (MC) (MENU-SET-MOVE (CADR MC)) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) (XFLUSH *WINDOW-DISPLAY*) (MENU-CONNS-DRAW MC)) (DEFUN MENU-CONNS-REDRAW (MC) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) (XFLUSH *WINDOW-DISPLAY*) (MENU-CONNS-DRAW MC)) (DEFUN MENU-CONNS-ADD-CONN (MC) (LET (SEL SELB CONN) (SETQ SEL (MENU-SET-SELECT (CADR MC))) (IF (EQ (CADR SEL) 'BACKGROUND) SEL (PROGN (SETQ SELB (MENU-SET-SELECT (CADR MC))) (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND)) (SETQ CONN (LIST SEL SELB)) (MENU-SET-DRAW-CONN (CADR MC) CONN) (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))) NIL)))) (SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS))) (SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION) (DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT) (LET (CONN) (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME))) (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))) (SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL) (TONAME SYMBOL) (TOPORT SYMBOL))) (SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU) (MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU)) (SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) (SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-CONNS-FIND-CONN (MC PT) (LET (MS LS FOUND RES PA PB TMP DESCA DESCB) (SETQ LS (LIST (COPY-LIST '(0 0)) (COPY-LIST '(0 0)))) (SETQ MS (CADR MC)) (DOLIST (CONN (CADDR MC)) (UNLESS FOUND (SETQ DESCA (CAR CONN)) (SETQ DESCB (CADR CONN)) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) (WHEN (> (CAR PA) (CAR PB)) (SETQ TMP DESCA) (SETQ DESCA DESCB) (SETQ DESCB TMP)) (SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) (SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS)) (- (CADR PT) (CADAR LS))) (* (- (CADADR LS) (CADAR LS)) (- (CAR PT) (CAAR LS)))) (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2) (EXPT (- (CADADR LS) (CADAR LS)) 2))))) 5) (SETQ FOUND T) (SETQ RES CONN)))) RES)) (SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (PT VECTOR))) (SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN) (DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT)) (SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (PT VECTOR))) (SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-CONNS-DELETE-CONN (MC CONN) (SETF (CADDR MC) (REMOVE CONN (CADDR MC)))) (SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (CONN MENU-SET-CONN))) (SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-DELETE-ITEM (MC MI) (LET (MS) (SETQ MS (CADR MC)) (MENU-SET-DELETE-ITEM MS MI) (DOLIST (CONN (CADDR MC)) (IF (OR (EQ (CADAR CONN) (CAR MI)) (EQ (CADADR CONN) (CAR MI))) (MENU-CONNS-DELETE-CONN MC CONN))))) (DEFUN MENU-CONNS-REMOVE-ITEMS (MC) (MENU-SET-REMOVE-ITEMS (CADR MC)) (SETF (CADDR MC) NIL)) (SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS))) (SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-CONNECTED-PORTS (MC BOXNAME) (LET (PORTS) (DOLIST (CONN (CADDR MC)) (IF (EQ BOXNAME (CADADR CONN)) (PUSHNEW (CAADR CONN) PORTS) (IF (EQ BOXNAME (CADAR CONN)) (PUSHNEW (CAAR CONN) PORTS)))) PORTS)) (DEFUN MENU-CONNS-FIND-CONNS (MC BOXNAME PORT) (LET (RES) (DOLIST (CONN (CADDR MC)) (IF (AND (EQ BOXNAME (CADADR CONN)) (EQ PORT (CAADR CONN))) (SETQ RES (NCONC RES (CONS (CAR CONN) NIL)))) (IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN))) (SETQ RES (NCONC RES (CONS (CADR CONN) NIL))))) RES)) (SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS) '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL))) (SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT)) (DEFUN COMPILE-MENU-SET () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" "glisp/menu-set-header.lsp") (COMPILE-FILE "glisp/menu-settrans.lsp")) (DEFUN COMPILE-MENU-SETB () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" "glisp/menu-set-header.lsp")) gcl-2.6.14/xgcl-2/gcl_XStruct_l_3.lsp0000644000175000017500000007722614360276512015623 0ustar cammcamm(in-package :XLIB) ; XStruct-l-3.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;;;;; XExtCodes functions ;;;;;; (defentry make-XExtCodes () ( fixnum "make_XExtCodes" )) (defentry XExtCodes-first_error (fixnum) ( fixnum "XExtCodes_first_error" )) (defentry set-XExtCodes-first_error (fixnum fixnum) ( void "set_XExtCodes_first_error" )) (defentry XExtCodes-first_event (fixnum) ( fixnum "XExtCodes_first_event" )) (defentry set-XExtCodes-first_event (fixnum fixnum) ( void "set_XExtCodes_first_event" )) (defentry XExtCodes-major_opcode (fixnum) ( fixnum "XExtCodes_major_opcode" )) (defentry set-XExtCodes-major_opcode (fixnum fixnum) ( void "set_XExtCodes_major_opcode" )) (defentry XExtCodes-extension (fixnum) ( fixnum "XExtCodes_extension" )) (defentry set-XExtCodes-extension (fixnum fixnum) ( void "set_XExtCodes_extension" )) ;;;;;; XPixmapFormatValues functions ;;;;;; (defentry make-XPixmapFormatValues () ( fixnum "make_XPixmapFormatValues" )) (defentry XPixmapFormatValues-scanline_pad (fixnum) ( fixnum "XPixmapFormatValues_scanline_pad" )) (defentry set-XPixmapFormatValues-scanline_pad (fixnum fixnum) ( void "set_XPixmapFormatValues_scanline_pad" )) (defentry XPixmapFormatValues-bits_per_pixel (fixnum) ( fixnum "XPixmapFormatValues_bits_per_pixel" )) (defentry set-XPixmapFormatValues-bits_per_pixel (fixnum fixnum) ( void "set_XPixmapFormatValues_bits_per_pixel" )) (defentry XPixmapFormatValues-depth (fixnum) ( fixnum "XPixmapFormatValues_depth" )) (defentry set-XPixmapFormatValues-depth (fixnum fixnum) ( void "set_XPixmapFormatValues_depth" )) ;;;;;; XGCValues functions ;;;;;; (defentry make-XGCValues () ( fixnum "make_XGCValues" )) (defentry XGCValues-dashes (fixnum) ( char "XGCValues_dashes" )) (defentry set-XGCValues-dashes (fixnum char) ( void "set_XGCValues_dashes" )) (defentry XGCValues-dash_offset (fixnum) ( fixnum "XGCValues_dash_offset" )) (defentry set-XGCValues-dash_offset (fixnum fixnum) ( void "set_XGCValues_dash_offset" )) (defentry XGCValues-clip_mask (fixnum) ( fixnum "XGCValues_clip_mask" )) (defentry set-XGCValues-clip_mask (fixnum fixnum) ( void "set_XGCValues_clip_mask" )) (defentry XGCValues-clip_y_origin (fixnum) ( fixnum "XGCValues_clip_y_origin" )) (defentry set-XGCValues-clip_y_origin (fixnum fixnum) ( void "set_XGCValues_clip_y_origin" )) (defentry XGCValues-clip_x_origin (fixnum) ( fixnum "XGCValues_clip_x_origin" )) (defentry set-XGCValues-clip_x_origin (fixnum fixnum) ( void "set_XGCValues_clip_x_origin" )) (defentry XGCValues-graphics_exposures (fixnum) ( fixnum "XGCValues_graphics_exposures" )) (defentry set-XGCValues-graphics_exposures (fixnum fixnum) ( void "set_XGCValues_graphics_exposures" )) (defentry XGCValues-subwindow_mode (fixnum) ( fixnum "XGCValues_subwindow_mode" )) (defentry set-XGCValues-subwindow_mode (fixnum fixnum) ( void "set_XGCValues_subwindow_mode" )) (defentry XGCValues-font (fixnum) ( fixnum "XGCValues_font" )) (defentry set-XGCValues-font (fixnum fixnum) ( void "set_XGCValues_font" )) (defentry XGCValues-ts_y_origin (fixnum) ( fixnum "XGCValues_ts_y_origin" )) (defentry set-XGCValues-ts_y_origin (fixnum fixnum) ( void "set_XGCValues_ts_y_origin" )) (defentry XGCValues-ts_x_origin (fixnum) ( fixnum "XGCValues_ts_x_origin" )) (defentry set-XGCValues-ts_x_origin (fixnum fixnum) ( void "set_XGCValues_ts_x_origin" )) (defentry XGCValues-stipple (fixnum) ( fixnum "XGCValues_stipple" )) (defentry set-XGCValues-stipple (fixnum fixnum) ( void "set_XGCValues_stipple" )) (defentry XGCValues-tile (fixnum) ( fixnum "XGCValues_tile" )) (defentry set-XGCValues-tile (fixnum fixnum) ( void "set_XGCValues_tile" )) (defentry XGCValues-arc_mode (fixnum) ( fixnum "XGCValues_arc_mode" )) (defentry set-XGCValues-arc_mode (fixnum fixnum) ( void "set_XGCValues_arc_mode" )) (defentry XGCValues-fill_rule (fixnum) ( fixnum "XGCValues_fill_rule" )) (defentry set-XGCValues-fill_rule (fixnum fixnum) ( void "set_XGCValues_fill_rule" )) (defentry XGCValues-fill_style (fixnum) ( fixnum "XGCValues_fill_style" )) (defentry set-XGCValues-fill_style (fixnum fixnum) ( void "set_XGCValues_fill_style" )) (defentry XGCValues-join_style (fixnum) ( fixnum "XGCValues_join_style" )) (defentry set-XGCValues-join_style (fixnum fixnum) ( void "set_XGCValues_join_style" )) (defentry XGCValues-cap_style (fixnum) ( fixnum "XGCValues_cap_style" )) (defentry set-XGCValues-cap_style (fixnum fixnum) ( void "set_XGCValues_cap_style" )) (defentry XGCValues-line_style (fixnum) ( fixnum "XGCValues_line_style" )) (defentry set-XGCValues-line_style (fixnum fixnum) ( void "set_XGCValues_line_style" )) (defentry XGCValues-line_width (fixnum) ( fixnum "XGCValues_line_width" )) (defentry set-XGCValues-line_width (fixnum fixnum) ( void "set_XGCValues_line_width" )) (defentry XGCValues-background (fixnum) ( fixnum "XGCValues_background" )) (defentry set-XGCValues-background (fixnum fixnum) ( void "set_XGCValues_background" )) (defentry XGCValues-foreground (fixnum) ( fixnum "XGCValues_foreground" )) (defentry set-XGCValues-foreground (fixnum fixnum) ( void "set_XGCValues_foreground" )) (defentry XGCValues-plane_mask (fixnum) ( fixnum "XGCValues_plane_mask" )) (defentry set-XGCValues-plane_mask (fixnum fixnum) ( void "set_XGCValues_plane_mask" )) (defentry XGCValues-function (fixnum) ( fixnum "XGCValues_function" )) (defentry set-XGCValues-function (fixnum fixnum) ( void "set_XGCValues_function" )) ;;;;;; *GC functions ;;;;;; ;;(defentry make-*GC () ( fixnum "make_*GC" )) ;;(defentry *GC-values (fixnum) ( fixnum "*GC_values" )) ;;(defentry set-*GC-values (fixnum fixnum) ( void "set_*GC_values" )) ;;(defentry *GC-dirty (fixnum) ( fixnum "*GC_dirty" )) ;;(defentry set-*GC-dirty (fixnum fixnum) ( void "set_*GC_dirty" )) ;;(defentry *GC-dashes (fixnum) ( fixnum "*GC_dashes" )) ;;(defentry set-*GC-dashes (fixnum fixnum) ( void "set_*GC_dashes" )) ;;(defentry *GC-rects (fixnum) ( fixnum "*GC_rects" )) ;;(defentry set-*GC-rects (fixnum fixnum) ( void "set_*GC_rects" )) ;;(defentry *GC-gid (fixnum) ( fixnum "*GC_gid" )) ;;(defentry set-*GC-gid (fixnum fixnum) ( void "set_*GC_gid" )) ;;(defentry *GC-ext_data (fixnum) ( fixnum "*GC_ext_data" )) ;;(defentry set-*GC-ext_data (fixnum fixnum) ( void "set_*GC_ext_data" )) ;;;;;; Visual functions ;;;;;; (defentry make-Visual () ( fixnum "make_Visual" )) (defentry Visual-map_entries (fixnum) ( fixnum "Visual_map_entries" )) (defentry set-Visual-map_entries (fixnum fixnum) ( void "set_Visual_map_entries" )) (defentry Visual-bits_per_rgb (fixnum) ( fixnum "Visual_bits_per_rgb" )) (defentry set-Visual-bits_per_rgb (fixnum fixnum) ( void "set_Visual_bits_per_rgb" )) (defentry Visual-blue_mask (fixnum) ( fixnum "Visual_blue_mask" )) (defentry set-Visual-blue_mask (fixnum fixnum) ( void "set_Visual_blue_mask" )) (defentry Visual-green_mask (fixnum) ( fixnum "Visual_green_mask" )) (defentry set-Visual-green_mask (fixnum fixnum) ( void "set_Visual_green_mask" )) (defentry Visual-red_mask (fixnum) ( fixnum "Visual_red_mask" )) (defentry set-Visual-red_mask (fixnum fixnum) ( void "set_Visual_red_mask" )) (defentry Visual-class (fixnum) ( fixnum "Visual_class" )) (defentry set-Visual-class (fixnum fixnum) ( void "set_Visual_class" )) (defentry Visual-visualid (fixnum) ( fixnum "Visual_visualid" )) (defentry set-Visual-visualid (fixnum fixnum) ( void "set_Visual_visualid" )) (defentry Visual-ext_data (fixnum) ( fixnum "Visual_ext_data" )) (defentry set-Visual-ext_data (fixnum fixnum) ( void "set_Visual_ext_data" )) ;;;;;; Depth functions ;;;;;; (defentry make-Depth () ( fixnum "make_Depth" )) (defentry Depth-visuals (fixnum) ( fixnum "Depth_visuals" )) (defentry set-Depth-visuals (fixnum fixnum) ( void "set_Depth_visuals" )) (defentry Depth-nvisuals (fixnum) ( fixnum "Depth_nvisuals" )) (defentry set-Depth-nvisuals (fixnum fixnum) ( void "set_Depth_nvisuals" )) (defentry Depth-depth (fixnum) ( fixnum "Depth_depth" )) (defentry set-Depth-depth (fixnum fixnum) ( void "set_Depth_depth" )) ;;;;;; Screen functions ;;;;;; (defentry make-Screen () ( fixnum "make_Screen" )) (defentry Screen-root_input_mask (fixnum) ( fixnum "Screen_root_input_mask" )) (defentry set-Screen-root_input_mask (fixnum fixnum) ( void "set_Screen_root_input_mask" )) (defentry Screen-save_unders (fixnum) ( fixnum "Screen_save_unders" )) (defentry set-Screen-save_unders (fixnum fixnum) ( void "set_Screen_save_unders" )) (defentry Screen-backing_store (fixnum) ( fixnum "Screen_backing_store" )) (defentry set-Screen-backing_store (fixnum fixnum) ( void "set_Screen_backing_store" )) (defentry Screen-min_maps (fixnum) ( fixnum "Screen_min_maps" )) (defentry set-Screen-min_maps (fixnum fixnum) ( void "set_Screen_min_maps" )) (defentry Screen-max_maps (fixnum) ( fixnum "Screen_max_maps" )) (defentry set-Screen-max_maps (fixnum fixnum) ( void "set_Screen_max_maps" )) (defentry Screen-black_pixel (fixnum) ( fixnum "Screen_black_pixel" )) (defentry set-Screen-black_pixel (fixnum fixnum) ( void "set_Screen_black_pixel" )) (defentry Screen-white_pixel (fixnum) ( fixnum "Screen_white_pixel" )) (defentry set-Screen-white_pixel (fixnum fixnum) ( void "set_Screen_white_pixel" )) (defentry Screen-cmap (fixnum) ( fixnum "Screen_cmap" )) (defentry set-Screen-cmap (fixnum fixnum) ( void "set_Screen_cmap" )) (defentry Screen-default_gc (fixnum) ( fixnum "Screen_default_gc" )) (defentry set-Screen-default_gc (fixnum fixnum) ( void "set_Screen_default_gc" )) (defentry Screen-root_visual (fixnum) ( fixnum "Screen_root_visual" )) (defentry set-Screen-root_visual (fixnum fixnum) ( void "set_Screen_root_visual" )) (defentry Screen-root_depth (fixnum) ( fixnum "Screen_root_depth" )) (defentry set-Screen-root_depth (fixnum fixnum) ( void "set_Screen_root_depth" )) (defentry Screen-depths (fixnum) ( fixnum "Screen_depths" )) (defentry set-Screen-depths (fixnum fixnum) ( void "set_Screen_depths" )) (defentry Screen-ndepths (fixnum) ( fixnum "Screen_ndepths" )) (defentry set-Screen-ndepths (fixnum fixnum) ( void "set_Screen_ndepths" )) (defentry Screen-mheight (fixnum) ( fixnum "Screen_mheight" )) (defentry set-Screen-mheight (fixnum fixnum) ( void "set_Screen_mheight" )) (defentry Screen-mwidth (fixnum) ( fixnum "Screen_mwidth" )) (defentry set-Screen-mwidth (fixnum fixnum) ( void "set_Screen_mwidth" )) (defentry Screen-height (fixnum) ( fixnum "Screen_height" )) (defentry set-Screen-height (fixnum fixnum) ( void "set_Screen_height" )) (defentry Screen-width (fixnum) ( fixnum "Screen_width" )) (defentry set-Screen-width (fixnum fixnum) ( void "set_Screen_width" )) (defentry Screen-root (fixnum) ( fixnum "Screen_root" )) (defentry set-Screen-root (fixnum fixnum) ( void "set_Screen_root" )) (defentry Screen-display (fixnum) ( fixnum "Screen_display" )) (defentry set-Screen-display (fixnum fixnum) ( void "set_Screen_display" )) (defentry Screen-ext_data (fixnum) ( fixnum "Screen_ext_data" )) (defentry set-Screen-ext_data (fixnum fixnum) ( void "set_Screen_ext_data" )) ;;;;;; ScreenFormat functions ;;;;;; (defentry make-ScreenFormat () ( fixnum "make_ScreenFormat" )) (defentry ScreenFormat-scanline_pad (fixnum) ( fixnum "ScreenFormat_scanline_pad" )) (defentry set-ScreenFormat-scanline_pad (fixnum fixnum) ( void "set_ScreenFormat_scanline_pad" )) (defentry ScreenFormat-bits_per_pixel (fixnum) ( fixnum "ScreenFormat_bits_per_pixel" )) (defentry set-ScreenFormat-bits_per_pixel (fixnum fixnum) ( void "set_ScreenFormat_bits_per_pixel" )) (defentry ScreenFormat-depth (fixnum) ( fixnum "ScreenFormat_depth" )) (defentry set-ScreenFormat-depth (fixnum fixnum) ( void "set_ScreenFormat_depth" )) (defentry ScreenFormat-ext_data (fixnum) ( fixnum "ScreenFormat_ext_data" )) (defentry set-ScreenFormat-ext_data (fixnum fixnum) ( void "set_ScreenFormat_ext_data" )) ;;;;;; XSetWindowAttributes functions ;;;;;; (defentry make-XSetWindowAttributes () ( fixnum "make_XSetWindowAttributes" )) (defentry XSetWindowAttributes-cursor (fixnum) ( fixnum "XSetWindowAttributes_cursor" )) (defentry set-XSetWindowAttributes-cursor (fixnum fixnum) ( void "set_XSetWindowAttributes_cursor" )) (defentry XSetWindowAttributes-colormap (fixnum) ( fixnum "XSetWindowAttributes_colormap" )) (defentry set-XSetWindowAttributes-colormap (fixnum fixnum) ( void "set_XSetWindowAttributes_colormap" )) (defentry XSetWindowAttributes-override_redirect (fixnum) ( fixnum "XSetWindowAttributes_override_redirect" )) (defentry set-XSetWindowAttributes-override_redirect (fixnum fixnum) ( void "set_XSetWindowAttributes_override_redirect" )) (defentry XSetWindowAttributes-do_not_propagate_mask (fixnum) ( fixnum "XSetWindowAttributes_do_not_propagate_mask" )) (defentry set-XSetWindowAttributes-do_not_propagate_mask (fixnum fixnum) ( void "set_XSetWindowAttributes_do_not_propagate_mask" )) (defentry XSetWindowAttributes-event_mask (fixnum) ( fixnum "XSetWindowAttributes_event_mask" )) (defentry set-XSetWindowAttributes-event_mask (fixnum fixnum) ( void "set_XSetWindowAttributes_event_mask" )) (defentry XSetWindowAttributes-save_under (fixnum) ( fixnum "XSetWindowAttributes_save_under" )) (defentry set-XSetWindowAttributes-save_under (fixnum fixnum) ( void "set_XSetWindowAttributes_save_under" )) (defentry XSetWindowAttributes-backing_pixel (fixnum) ( fixnum "XSetWindowAttributes_backing_pixel" )) (defentry set-XSetWindowAttributes-backing_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_pixel" )) (defentry XSetWindowAttributes-backing_planes (fixnum) ( fixnum "XSetWindowAttributes_backing_planes" )) (defentry set-XSetWindowAttributes-backing_planes (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_planes" )) (defentry XSetWindowAttributes-backing_store (fixnum) ( fixnum "XSetWindowAttributes_backing_store" )) (defentry set-XSetWindowAttributes-backing_store (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_store" )) (defentry XSetWindowAttributes-win_gravity (fixnum) ( fixnum "XSetWindowAttributes_win_gravity" )) (defentry set-XSetWindowAttributes-win_gravity (fixnum fixnum) ( void "set_XSetWindowAttributes_win_gravity" )) (defentry XSetWindowAttributes-bit_gravity (fixnum) ( fixnum "XSetWindowAttributes_bit_gravity" )) (defentry set-XSetWindowAttributes-bit_gravity (fixnum fixnum) ( void "set_XSetWindowAttributes_bit_gravity" )) (defentry XSetWindowAttributes-border_pixel (fixnum) ( fixnum "XSetWindowAttributes_border_pixel" )) (defentry set-XSetWindowAttributes-border_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_border_pixel" )) (defentry XSetWindowAttributes-border_pixmap (fixnum) ( fixnum "XSetWindowAttributes_border_pixmap" )) (defentry set-XSetWindowAttributes-border_pixmap (fixnum fixnum) ( void "set_XSetWindowAttributes_border_pixmap" )) (defentry XSetWindowAttributes-background_pixel (fixnum) ( fixnum "XSetWindowAttributes_background_pixel" )) (defentry set-XSetWindowAttributes-background_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_background_pixel" )) (defentry XSetWindowAttributes-background_pixmap (fixnum) ( fixnum "XSetWindowAttributes_background_pixmap" )) (defentry set-XSetWindowAttributes-background_pixmap (fixnum fixnum) ( void "set_XSetWindowAttributes_background_pixmap" )) ;;;;;; XWindowAttributes functions ;;;;;; (defentry make-XWindowAttributes () ( fixnum "make_XWindowAttributes" )) (defentry XWindowAttributes-screen (fixnum) ( fixnum "XWindowAttributes_screen" )) (defentry set-XWindowAttributes-screen (fixnum fixnum) ( void "set_XWindowAttributes_screen" )) (defentry XWindowAttributes-override_redirect (fixnum) ( fixnum "XWindowAttributes_override_redirect" )) (defentry set-XWindowAttributes-override_redirect (fixnum fixnum) ( void "set_XWindowAttributes_override_redirect" )) (defentry XWindowAttributes-do_not_propagate_mask (fixnum) ( fixnum "XWindowAttributes_do_not_propagate_mask" )) (defentry set-XWindowAttributes-do_not_propagate_mask (fixnum fixnum) ( void "set_XWindowAttributes_do_not_propagate_mask" )) (defentry XWindowAttributes-your_event_mask (fixnum) ( fixnum "XWindowAttributes_your_event_mask" )) (defentry set-XWindowAttributes-your_event_mask (fixnum fixnum) ( void "set_XWindowAttributes_your_event_mask" )) (defentry XWindowAttributes-all_event_masks (fixnum) ( fixnum "XWindowAttributes_all_event_masks" )) (defentry set-XWindowAttributes-all_event_masks (fixnum fixnum) ( void "set_XWindowAttributes_all_event_masks" )) (defentry XWindowAttributes-map_state (fixnum) ( fixnum "XWindowAttributes_map_state" )) (defentry set-XWindowAttributes-map_state (fixnum fixnum) ( void "set_XWindowAttributes_map_state" )) (defentry XWindowAttributes-map_installed (fixnum) ( fixnum "XWindowAttributes_map_installed" )) (defentry set-XWindowAttributes-map_installed (fixnum fixnum) ( void "set_XWindowAttributes_map_installed" )) (defentry XWindowAttributes-colormap (fixnum) ( fixnum "XWindowAttributes_colormap" )) (defentry set-XWindowAttributes-colormap (fixnum fixnum) ( void "set_XWindowAttributes_colormap" )) (defentry XWindowAttributes-save_under (fixnum) ( fixnum "XWindowAttributes_save_under" )) (defentry set-XWindowAttributes-save_under (fixnum fixnum) ( void "set_XWindowAttributes_save_under" )) (defentry XWindowAttributes-backing_pixel (fixnum) ( fixnum "XWindowAttributes_backing_pixel" )) (defentry set-XWindowAttributes-backing_pixel (fixnum fixnum) ( void "set_XWindowAttributes_backing_pixel" )) (defentry XWindowAttributes-backing_planes (fixnum) ( fixnum "XWindowAttributes_backing_planes" )) (defentry set-XWindowAttributes-backing_planes (fixnum fixnum) ( void "set_XWindowAttributes_backing_planes" )) (defentry XWindowAttributes-backing_store (fixnum) ( fixnum "XWindowAttributes_backing_store" )) (defentry set-XWindowAttributes-backing_store (fixnum fixnum) ( void "set_XWindowAttributes_backing_store" )) (defentry XWindowAttributes-win_gravity (fixnum) ( fixnum "XWindowAttributes_win_gravity" )) (defentry set-XWindowAttributes-win_gravity (fixnum fixnum) ( void "set_XWindowAttributes_win_gravity" )) (defentry XWindowAttributes-bit_gravity (fixnum) ( fixnum "XWindowAttributes_bit_gravity" )) (defentry set-XWindowAttributes-bit_gravity (fixnum fixnum) ( void "set_XWindowAttributes_bit_gravity" )) (defentry XWindowAttributes-class (fixnum) ( fixnum "XWindowAttributes_class" )) (defentry set-XWindowAttributes-class (fixnum fixnum) ( void "set_XWindowAttributes_class" )) (defentry XWindowAttributes-root (fixnum) ( fixnum "XWindowAttributes_root" )) (defentry set-XWindowAttributes-root (fixnum fixnum) ( void "set_XWindowAttributes_root" )) (defentry XWindowAttributes-visual (fixnum) ( fixnum "XWindowAttributes_visual" )) (defentry set-XWindowAttributes-visual (fixnum fixnum) ( void "set_XWindowAttributes_visual" )) (defentry XWindowAttributes-depth (fixnum) ( fixnum "XWindowAttributes_depth" )) (defentry set-XWindowAttributes-depth (fixnum fixnum) ( void "set_XWindowAttributes_depth" )) (defentry XWindowAttributes-border_width (fixnum) ( fixnum "XWindowAttributes_border_width" )) (defentry set-XWindowAttributes-border_width (fixnum fixnum) ( void "set_XWindowAttributes_border_width" )) (defentry XWindowAttributes-height (fixnum) ( fixnum "XWindowAttributes_height" )) (defentry set-XWindowAttributes-height (fixnum fixnum) ( void "set_XWindowAttributes_height" )) (defentry XWindowAttributes-width (fixnum) ( fixnum "XWindowAttributes_width" )) (defentry set-XWindowAttributes-width (fixnum fixnum) ( void "set_XWindowAttributes_width" )) (defentry XWindowAttributes-y (fixnum) ( fixnum "XWindowAttributes_y" )) (defentry set-XWindowAttributes-y (fixnum fixnum) ( void "set_XWindowAttributes_y" )) (defentry XWindowAttributes-x (fixnum) ( fixnum "XWindowAttributes_x" )) (defentry set-XWindowAttributes-x (fixnum fixnum) ( void "set_XWindowAttributes_x" )) ;;;;;; XHostAddress functions ;;;;;; (defentry make-XHostAddress () ( fixnum "make_XHostAddress" )) (defentry XHostAddress-address (fixnum) ( fixnum "XHostAddress_address" )) (defentry set-XHostAddress-address (fixnum fixnum) ( void "set_XHostAddress_address" )) (defentry XHostAddress-length (fixnum) ( fixnum "XHostAddress_length" )) (defentry set-XHostAddress-length (fixnum fixnum) ( void "set_XHostAddress_length" )) (defentry XHostAddress-family (fixnum) ( fixnum "XHostAddress_family" )) (defentry set-XHostAddress-family (fixnum fixnum) ( void "set_XHostAddress_family" )) ;;;;;; XImage functions ;;;;;; (defentry make-XImage () ( fixnum "make_XImage" )) ;;(defentry XImage-f (fixnum) ( fixnum "XImage_f" )) ;;(defentry set-XImage-f (fixnum fixnum) ( void "set_XImage_f" )) (defentry XImage-obdata (fixnum) ( fixnum "XImage_obdata" )) (defentry set-XImage-obdata (fixnum fixnum) ( void "set_XImage_obdata" )) (defentry XImage-blue_mask (fixnum) ( fixnum "XImage_blue_mask" )) (defentry set-XImage-blue_mask (fixnum fixnum) ( void "set_XImage_blue_mask" )) (defentry XImage-green_mask (fixnum) ( fixnum "XImage_green_mask" )) (defentry set-XImage-green_mask (fixnum fixnum) ( void "set_XImage_green_mask" )) (defentry XImage-red_mask (fixnum) ( fixnum "XImage_red_mask" )) (defentry set-XImage-red_mask (fixnum fixnum) ( void "set_XImage_red_mask" )) (defentry XImage-bits_per_pixel (fixnum) ( fixnum "XImage_bits_per_pixel" )) (defentry set-XImage-bits_per_pixel (fixnum fixnum) ( void "set_XImage_bits_per_pixel" )) (defentry XImage-bytes_per_line (fixnum) ( fixnum "XImage_bytes_per_line" )) (defentry set-XImage-bytes_per_line (fixnum fixnum) ( void "set_XImage_bytes_per_line" )) (defentry XImage-depth (fixnum) ( fixnum "XImage_depth" )) (defentry set-XImage-depth (fixnum fixnum) ( void "set_XImage_depth" )) (defentry XImage-bitmap_pad (fixnum) ( fixnum "XImage_bitmap_pad" )) (defentry set-XImage-bitmap_pad (fixnum fixnum) ( void "set_XImage_bitmap_pad" )) (defentry XImage-bitmap_bit_order (fixnum) ( fixnum "XImage_bitmap_bit_order" )) (defentry set-XImage-bitmap_bit_order (fixnum fixnum) ( void "set_XImage_bitmap_bit_order" )) (defentry XImage-bitmap_unit (fixnum) ( fixnum "XImage_bitmap_unit" )) (defentry set-XImage-bitmap_unit (fixnum fixnum) ( void "set_XImage_bitmap_unit" )) (defentry XImage-byte_order (fixnum) ( fixnum "XImage_byte_order" )) (defentry set-XImage-byte_order (fixnum fixnum) ( void "set_XImage_byte_order" )) (defentry XImage-data (fixnum) ( fixnum "XImage_data" )) (defentry set-XImage-data (fixnum fixnum) ( void "set_XImage_data" )) (defentry XImage-format (fixnum) ( fixnum "XImage_format" )) (defentry set-XImage-format (fixnum fixnum) ( void "set_XImage_format" )) (defentry XImage-xoffset (fixnum) ( fixnum "XImage_xoffset" )) (defentry set-XImage-xoffset (fixnum fixnum) ( void "set_XImage_xoffset" )) (defentry XImage-height (fixnum) ( fixnum "XImage_height" )) (defentry set-XImage-height (fixnum fixnum) ( void "set_XImage_height" )) (defentry XImage-width (fixnum) ( fixnum "XImage_width" )) (defentry set-XImage-width (fixnum fixnum) ( void "set_XImage_width" )) ;;;;;; XWindowChanges functions ;;;;;; (defentry make-XWindowChanges () ( fixnum "make_XWindowChanges" )) (defentry XWindowChanges-stack_mode (fixnum) ( fixnum "XWindowChanges_stack_mode" )) (defentry set-XWindowChanges-stack_mode (fixnum fixnum) ( void "set_XWindowChanges_stack_mode" )) (defentry XWindowChanges-sibling (fixnum) ( fixnum "XWindowChanges_sibling" )) (defentry set-XWindowChanges-sibling (fixnum fixnum) ( void "set_XWindowChanges_sibling" )) (defentry XWindowChanges-border_width (fixnum) ( fixnum "XWindowChanges_border_width" )) (defentry set-XWindowChanges-border_width (fixnum fixnum) ( void "set_XWindowChanges_border_width" )) (defentry XWindowChanges-height (fixnum) ( fixnum "XWindowChanges_height" )) (defentry set-XWindowChanges-height (fixnum fixnum) ( void "set_XWindowChanges_height" )) (defentry XWindowChanges-width (fixnum) ( fixnum "XWindowChanges_width" )) (defentry set-XWindowChanges-width (fixnum fixnum) ( void "set_XWindowChanges_width" )) (defentry XWindowChanges-y (fixnum) ( fixnum "XWindowChanges_y" )) (defentry set-XWindowChanges-y (fixnum fixnum) ( void "set_XWindowChanges_y" )) (defentry XWindowChanges-x (fixnum) ( fixnum "XWindowChanges_x" )) (defentry set-XWindowChanges-x (fixnum fixnum) ( void "set_XWindowChanges_x" )) ;;;;;; XColor functions ;;;;;; (defentry make-XColor () ( fixnum "make_XColor" )) (defentry XColor-pad (fixnum) ( char "XColor_pad" )) (defentry set-XColor-pad (fixnum char) ( void "set_XColor_pad" )) (defentry XColor-flags (fixnum) ( char "XColor_flags" )) (defentry set-XColor-flags (fixnum char) ( void "set_XColor_flags" )) (defentry XColor-blue (fixnum) ( fixnum "XColor_blue" )) (defentry set-XColor-blue (fixnum fixnum) ( void "set_XColor_blue" )) (defentry XColor-green (fixnum) ( fixnum "XColor_green" )) (defentry set-XColor-green (fixnum fixnum) ( void "set_XColor_green" )) (defentry XColor-red (fixnum) ( fixnum "XColor_red" )) (defentry set-XColor-red (fixnum fixnum) ( void "set_XColor_red" )) (defentry XColor-pixel (fixnum) ( fixnum "XColor_pixel" )) (defentry set-XColor-pixel (fixnum fixnum) ( void "set_XColor_pixel" )) ;;;;;; XSegment functions ;;;;;; (defentry make-XSegment () ( fixnum "make_XSegment" )) (defentry XSegment-y2 (fixnum) ( fixnum "XSegment_y2" )) (defentry set-XSegment-y2 (fixnum fixnum) ( void "set_XSegment_y2" )) (defentry XSegment-x2 (fixnum) ( fixnum "XSegment_x2" )) (defentry set-XSegment-x2 (fixnum fixnum) ( void "set_XSegment_x2" )) (defentry XSegment-y1 (fixnum) ( fixnum "XSegment_y1" )) (defentry set-XSegment-y1 (fixnum fixnum) ( void "set_XSegment_y1" )) (defentry XSegment-x1 (fixnum) ( fixnum "XSegment_x1" )) (defentry set-XSegment-x1 (fixnum fixnum) ( void "set_XSegment_x1" )) ;;;;;; XPoint functions ;;;;;; (defentry make-XPoint () ( fixnum "make_XPoint" )) (defentry XPoint-y (fixnum) ( fixnum "XPoint_y" )) (defentry set-XPoint-y (fixnum fixnum) ( void "set_XPoint_y" )) (defentry XPoint-x (fixnum) ( fixnum "XPoint_x" )) (defentry set-XPoint-x (fixnum fixnum) ( void "set_XPoint_x" )) ;;;;;; XRectangle functions ;;;;;; (defentry make-XRectangle () ( fixnum "make_XRectangle" )) (defentry XRectangle-height (fixnum) ( fixnum "XRectangle_height" )) (defentry set-XRectangle-height (fixnum fixnum) ( void "set_XRectangle_height" )) (defentry XRectangle-width (fixnum) ( fixnum "XRectangle_width" )) (defentry set-XRectangle-width (fixnum fixnum) ( void "set_XRectangle_width" )) (defentry XRectangle-y (fixnum) ( fixnum "XRectangle_y" )) (defentry set-XRectangle-y (fixnum fixnum) ( void "set_XRectangle_y" )) (defentry XRectangle-x (fixnum) ( fixnum "XRectangle_x" )) (defentry set-XRectangle-x (fixnum fixnum) ( void "set_XRectangle_x" )) ;;;;;; XArc functions ;;;;;; (defentry make-XArc () ( fixnum "make_XArc" )) (defentry XArc-angle2 (fixnum) ( fixnum "XArc_angle2" )) (defentry set-XArc-angle2 (fixnum fixnum) ( void "set_XArc_angle2" )) (defentry XArc-angle1 (fixnum) ( fixnum "XArc_angle1" )) (defentry set-XArc-angle1 (fixnum fixnum) ( void "set_XArc_angle1" )) (defentry XArc-height (fixnum) ( fixnum "XArc_height" )) (defentry set-XArc-height (fixnum fixnum) ( void "set_XArc_height" )) (defentry XArc-width (fixnum) ( fixnum "XArc_width" )) (defentry set-XArc-width (fixnum fixnum) ( void "set_XArc_width" )) (defentry XArc-y (fixnum) ( fixnum "XArc_y" )) (defentry set-XArc-y (fixnum fixnum) ( void "set_XArc_y" )) (defentry XArc-x (fixnum) ( fixnum "XArc_x" )) (defentry set-XArc-x (fixnum fixnum) ( void "set_XArc_x" )) ;;;;;; XKeyboardControl functions ;;;;;; (defentry make-XKeyboardControl () ( fixnum "make_XKeyboardControl" )) (defentry XKeyboardControl-auto_repeat_mode (fixnum) ( fixnum "XKeyboardControl_auto_repeat_mode" )) ;;(defentry set-XKeyboardControl-auto_repeat_mode (fixnum fixnum) ( void "set_XKeyboardControl_auto_repeat_mode" )) (defentry XKeyboardControl-key (fixnum) ( fixnum "XKeyboardControl_key" )) (defentry set-XKeyboardControl-key (fixnum fixnum) ( void "set_XKeyboardControl_key" )) (defentry XKeyboardControl-led_mode (fixnum) ( fixnum "XKeyboardControl_led_mode" )) (defentry set-XKeyboardControl-led_mode (fixnum fixnum) ( void "set_XKeyboardControl_led_mode" )) (defentry XKeyboardControl-led (fixnum) ( fixnum "XKeyboardControl_led" )) (defentry set-XKeyboardControl-led (fixnum fixnum) ( void "set_XKeyboardControl_led" )) (defentry XKeyboardControl-bell_duration (fixnum) ( fixnum "XKeyboardControl_bell_duration" )) (defentry set-XKeyboardControl-bell_duration (fixnum fixnum) ( void "set_XKeyboardControl_bell_duration" )) (defentry XKeyboardControl-bell_pitch (fixnum) ( fixnum "XKeyboardControl_bell_pitch" )) (defentry set-XKeyboardControl-bell_pitch (fixnum fixnum) ( void "set_XKeyboardControl_bell_pitch" )) (defentry XKeyboardControl-bell_percent (fixnum) ( fixnum "XKeyboardControl_bell_percent" )) (defentry set-XKeyboardControl-bell_percent (fixnum fixnum) ( void "set_XKeyboardControl_bell_percent" )) (defentry XKeyboardControl-key_click_percent (fixnum) ( fixnum "XKeyboardControl_key_click_percent" )) (defentry set-XKeyboardControl-key_click_percent (fixnum fixnum) ( void "set_XKeyboardControl_key_click_percent" )) ;;;;;; XKeyboardState functions ;;;;;; (defentry make-XKeyboardState () ( fixnum "make_XKeyboardState" )) (defentry XKeyboardState-auto_repeats (fixnum) ( fixnum "XKeyboardState_auto_repeats" )) (defentry set-XKeyboardState-auto_repeats (fixnum object) ( void "set_XKeyboardState_auto_repeats" )) (defentry XKeyboardState-global_auto_repeat (fixnum) ( fixnum "XKeyboardState_global_auto_repeat" )) (defentry set-XKeyboardState-global_auto_repeat (fixnum fixnum) ( void "set_XKeyboardState_global_auto_repeat" )) (defentry XKeyboardState-led_mask (fixnum) ( fixnum "XKeyboardState_led_mask" )) (defentry set-XKeyboardState-led_mask (fixnum fixnum) ( void "set_XKeyboardState_led_mask" )) (defentry XKeyboardState-bell_duration (fixnum) ( fixnum "XKeyboardState_bell_duration" )) (defentry set-XKeyboardState-bell_duration (fixnum fixnum) ( void "set_XKeyboardState_bell_duration" )) (defentry XKeyboardState-bell_pitch (fixnum) ( fixnum "XKeyboardState_bell_pitch" )) (defentry set-XKeyboardState-bell_pitch (fixnum fixnum) ( void "set_XKeyboardState_bell_pitch" )) (defentry XKeyboardState-bell_percent (fixnum) ( fixnum "XKeyboardState_bell_percent" )) (defentry set-XKeyboardState-bell_percent (fixnum fixnum) ( void "set_XKeyboardState_bell_percent" )) (defentry XKeyboardState-key_click_percent (fixnum) ( fixnum "XKeyboardState_key_click_percent" )) (defentry set-XKeyboardState-key_click_percent (fixnum fixnum) ( void "set_XKeyboardState_key_click_percent" )) ;;;;;; XTimeCoord functions ;;;;;; (defentry make-XTimeCoord () ( fixnum "make_XTimeCoord" )) (defentry XTimeCoord-y (fixnum) ( fixnum "XTimeCoord_y" )) (defentry set-XTimeCoord-y (fixnum fixnum) ( void "set_XTimeCoord_y" )) (defentry XTimeCoord-x (fixnum) ( fixnum "XTimeCoord_x" )) (defentry set-XTimeCoord-x (fixnum fixnum) ( void "set_XTimeCoord_x" )) (defentry XTimeCoord-time (fixnum) ( fixnum "XTimeCoord_time" )) (defentry set-XTimeCoord-time (fixnum fixnum) ( void "set_XTimeCoord_time" )) ;;;;;; XModifierKeymap functions ;;;;;; (defentry make-XModifierKeymap () ( fixnum "make_XModifierKeymap" )) (defentry XModifierKeymap-modifiermap (fixnum) ( fixnum "XModifierKeymap_modifiermap" )) (defentry set-XModifierKeymap-modifiermap (fixnum fixnum) ( void "set_XModifierKeymap_modifiermap" )) (defentry XModifierKeymap-max_keypermod (fixnum) ( fixnum "XModifierKeymap_max_keypermod" )) (defentry set-XModifierKeymap-max_keypermod (fixnum fixnum) ( void "set_XModifierKeymap_max_keypermod" )) gcl-2.6.14/xgcl-2/gcl_Xutil.lsp0000644000175000017500000003642014360276512014546 0ustar cammcamm(in-package :XLIB) ; Xutil.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;; $XConsortium: Xutil.h,v 11.58 89/12/12 20:15:40 jim Exp $ */ ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;;modified by Hiep H Nguyen 28 Jul 91 ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** ;; ;; * Bitmask returned by XParseGeometry(). Each bit tells if the corresponding) ;; * value (x, y, width, height) was found in the parsed string.) (defconstant NoValue 0000) (defconstant XValue 0001) (defconstant YValue 0002) (defconstant WidthValue 0004) (defconstant HeightValue 0008) (defconstant AllValues 15) (defconstant XNegative 16) (defconstant YNegative 32) ;; ;; The next block of definitions are for window manager properties that ;; clients and applications use for communication. ;; flags argument in size hints (defconstant USPosition (expt 2 0) ) ;; user specified x, y (defconstant USSize (expt 2 1) ) ;; user specified width, height (defconstant PPosition (expt 2 2) ) ;; program specified position (defconstant PSize (expt 2 3) ) ;; program specified size (defconstant PMinSize (expt 2 4) ) ;; program specified minimum size (defconstant PMaxSize (expt 2 5) ) ;; program specified maximum size (defconstant PResizeInc (expt 2 6) ) ;; program specified resize increments (defconstant PAspect (expt 2 7) ) ;; program specified min and max aspect ratios (defconstant PBaseSize (expt 2 8) ) ;; program specified base for incrementing (defconstant PWinGravity (expt 2 9) ) ;; program specified window gravity ;; obsolete (defconstant PAllHints (+ PPosition PSize PMinSize PMaxSize PResizeInc PAspect)) ;; definition for flags of XWMHints (defconstant InputHint (expt 2 0)) (defconstant StateHint (expt 2 1)) (defconstant IconPixmapHint (expt 2 2)) (defconstant IconWindowHint (expt 2 3)) (defconstant IconPositionHint (expt 2 4)) (defconstant IconMaskHint (expt 2 5)) (defconstant WindowGroupHint (expt 2 6)) (defconstant AllHints ( + InputHint StateHint IconPixmapHint IconWindowHint IconPositionHint IconMaskHint WindowGroupHint)) ;; definitions for initial window state (defconstant WithdrawnState 0 ) ;; for windows that are not mapped (defconstant NormalState 1 ) ;; most applications want to start this way (defconstant IconicState 3 ) ;; application wants to start as an icon ;; ;; Obsolete states no longer defined by ICCCM (defconstant DontCareState 0 ) ;; don't know or care (defconstant ZoomState 2 ) ;; application wants to start zoomed (defconstant InactiveState 4 ) ;; application believes it is seldom used; ;; some wm's may put it on inactive menu ;; ;; opaque reference to Region data type ;;typedef struct _XRegion *Region; ;; Return values from XRectInRegion() (defconstant RectangleOut 0) (defconstant RectangleIn 1) (defconstant RectanglePart 2) (defconstant VisualNoMask 0) (defconstant VisualIDMask 1) (defconstant VisualScreenMask 2) (defconstant VisualDepthMask 4) (defconstant VisualClassMask 8) (defconstant VisualRedMaskMask 16) (defconstant VisualGreenMaskMask 32) (defconstant VisualBlueMaskMask 64) (defconstant VisualColormapSizeMask 128) (defconstant VisualBitsPerRGBMask 256) (defconstant VisualAllMask 511) (defconstant ReleaseByFreeingColormap 1) ;; for killid field above ;; ;; return codes for XReadBitmapFile and XWriteBitmapFile (defconstant BitmapSuccess 0) (defconstant BitmapOpenFailed 1) (defconstant BitmapFileInvalid 2) (defconstant BitmapNoMemory 3) ;; ;; Declare the routines that don't return int. ;; *************************************************************** ;; * ;; * Context Management ;; * ;; *************************************************************** ;; Associative lookup table return codes (defconstant XCSUCCESS 0 ) ;; No error. (defconstant XCNOMEM 1 ) ;; Out of memory (defconstant XCNOENT 2 ) ;; No entry in table ;;typedef fixnum XContext; (defentry XSaveContext( fixnum ;; display fixnum ;; w fixnum ;; context fixnum ;; data )( fixnum "XSaveContext")) (defentry XFindContext( fixnum ;; display fixnum ;; w fixnum ;; context fixnum ;; data_return )( fixnum "XFindContext")) (defentry XDeleteContext( fixnum ;; display fixnum ;; w fixnum ;; context )( fixnum "XDeleteContext")) (defentry XGetWMHints( fixnum ;; display fixnum ;; w )( fixnum "XGetWMHints")) (defentry XCreateRegion( ;; void )( fixnum "XCreateRegion")) (defentry XPolygonRegion( fixnum ;; points fixnum ;; n fixnum ;; fill_rule )( fixnum "XPolygonRegion")) (defentry XGetVisualInfo( fixnum ;; display fixnum ;; vinfo_mask fixnum ;; vinfo_template fixnum ;; nitems_return )( fixnum "XGetVisualInfo")) ;; Allocation routines for properties that may get longer (defentry XAllocSizeHints ( ;; void )( fixnum "XAllocSizeHints" )) (defentry XAllocStandardColormap ( ;; void )( fixnum "XAllocStandardColormap" )) (defentry XAllocWMHints ( ;; void )( fixnum "XAllocWMHints" )) (defentry XAllocClassHint ( ;; void )( fixnum "XAllocClassHint" )) (defentry XAllocIconSize ( ;; void )( fixnum "XAllocIconSize" )) ;; ICCCM routines for data structures defined in this file (defentry XGetWMSizeHints( fixnum ;; display fixnum ;; w fixnum ;; hints_return fixnum ;; supplied_return fixnum ;; property )( fixnum "XGetWMSizeHints")) (defentry XGetWMNormalHints( fixnum ;; display fixnum ;; w fixnum ;; hints_return fixnum ;; supplied_return )( fixnum "XGetWMNormalHints")) (defentry XGetRGBColormaps( fixnum ;; display fixnum ;; w fixnum ;; stdcmap_return fixnum ;; count_return fixnum ;; property )( fixnum "XGetRGBColormaps")) (defentry XGetTextProperty( fixnum ;; display fixnum ;; window fixnum ;; text_prop_return fixnum ;; property )( fixnum "XGetTextProperty")) (defentry XGetWMName( fixnum ;; display fixnum ;; w fixnum ;; text_prop_return )( fixnum "XGetWMName")) (defentry XGetWMIconName( fixnum ;; display fixnum ;; w fixnum ;; text_prop_return )( fixnum "XGetWMIconName")) (defentry XGetWMClientMachine( fixnum ;; display fixnum ;; w fixnum ;; text_prop_return )( fixnum "XGetWMClientMachine")) (defentry XSetWMProperties( fixnum ;; display fixnum ;; w fixnum ;; window_name fixnum ;; icon_name fixnum ;; argv fixnum ;; argc fixnum ;; normal_hints fixnum ;; wm_hints fixnum ;; class_hints )( void "XSetWMProperties")) (defentry XSetWMSizeHints( fixnum ;; display fixnum ;; w fixnum ;; hints fixnum ;; property )( void "XSetWMSizeHints")) (defentry XSetWMNormalHints( fixnum ;; display fixnum ;; w fixnum ;; hints )( void "XSetWMNormalHints")) (defentry XSetRGBColormaps( fixnum ;; display fixnum ;; w fixnum ;; stdcmaps fixnum ;; count fixnum ;; property )( void "XSetRGBColormaps")) (defentry XSetTextProperty( fixnum ;; display fixnum ;; w fixnum ;; text_prop fixnum ;; property )( void "XSetTextProperty")) (defentry XSetWMName( fixnum ;; display fixnum ;; w fixnum ;; text_prop )( void "XSetWMName")) (defentry XSetWMIconName( fixnum ;; display fixnum ;; w fixnum ;; text_prop )( void "XSetWMIconName")) (defentry XSetWMClientMachine( fixnum ;; display fixnum ;; w fixnum ;; text_prop )( void "XSetWMClientMachine")) (defentry XStringListToTextProperty( fixnum ;; list fixnum ;; count fixnum ;; text_prop_return )( fixnum "XStringListToTextProperty")) (defentry XTextPropertyToStringList( fixnum ;; text_prop fixnum ;; list_return fixnum ;; count_return )( fixnum "XTextPropertyToStringList")) ;; The following declarations are alphabetized. (defentry XClipBox( fixnum ;; r fixnum ;; rect_return )( void "XClipBox")) (defentry XDestroyRegion( fixnum ;; r )( void "XDestroyRegion")) (defentry XEmptyRegion( fixnum ;; r )( void "XEmptyRegion")) (defentry XEqualRegion( fixnum ;; r1 fixnum ;; r2 )( void "XEqualRegion")) (defentry XGetClassHint( fixnum ;; display fixnum ;; w fixnum ;; class_hints_return )( fixnum "XGetClassHint")) (defentry XGetIconSizes( fixnum ;; display fixnum ;; w fixnum ;; size_list_return fixnum ;; count_return )( fixnum "XGetIconSizes")) (defentry XGetNormalHints( fixnum ;; display fixnum ;; w fixnum ;; hints_return )( fixnum "XGetNormalHints")) (defentry XGetSizeHints( fixnum ;; display fixnum ;; w fixnum ;; hints_return fixnum ;; property )( fixnum "XGetSizeHints")) (defentry XGetStandardColormap( fixnum ;; display fixnum ;; w fixnum ;; colormap_return fixnum ;; property )( fixnum "XGetStandardColormap")) (defentry XGetZoomHints( fixnum ;; display fixnum ;; w fixnum ;; zhints_return )( fixnum "XGetZoomHints")) (defentry XIntersectRegion( fixnum ;; sra fixnum ;; srb fixnum ;; dr_return )( void "XIntersectRegion")) (defentry XLookupString( fixnum ;; event_struct object ;; buffer_return fixnum ;; bytes_buffer fixnum ;; keysym_return fixnum ;; int_in_out )( fixnum "XLookupString")) (defentry XMatchVisualInfo( fixnum ;; display fixnum ;; screen fixnum ;; depth fixnum ;; class fixnum ;; vinfo_return )( fixnum "XMatchVisualInfo")) (defentry XOffsetRegion( fixnum ;; r fixnum ;; dx fixnum ;; dy )( void "XOffsetRegion")) (defentry XPointInRegion( fixnum ;; r fixnum ;; x fixnum ;; y )( fixnum "XPointInRegion")) (defentry XRectInRegion( fixnum ;; r fixnum ;; x fixnum ;; y fixnum ;; width fixnum ;; height )( fixnum "XRectInRegion")) (defentry XSetClassHint( fixnum ;; display fixnum ;; w fixnum ;; class_hints )( void "XSetClassHint")) (defentry XSetIconSizes( fixnum ;; display fixnum ;; w fixnum ;; size_list fixnum ;; count )( void "XSetIconSizes")) (defentry XSetNormalHints( fixnum ;; display fixnum ;; w fixnum ;; hints )( void "XSetNormalHints")) (defentry XSetSizeHints( fixnum ;; display fixnum ;; w fixnum ;; hints fixnum ;; property )( void "XSetSizeHints")) (defentry XSetStandardProperties( fixnum ;; display fixnum ;; w object ;; window_name object ;; icon_name fixnum ;; icon_pixmap fixnum ;; argv fixnum ;; argc fixnum ;; hints )( void "XSetStandardProperties")) (defentry XSetWMHints( fixnum ;; display fixnum ;; w fixnum ;; wm_hints )( void "XSetWMHints")) (defentry XSetRegion( fixnum ;; display fixnum ;; gc fixnum ;; r )( void "XSetRegion")) (defentry XSetStandardColormap( fixnum ;; display fixnum ;; w fixnum ;; colormap fixnum ;; property )( void "XSetStandardColormap")) (defentry XSetZoomHints( fixnum ;; display fixnum ;; w fixnum ;; zhints )( void "XSetZoomHints")) (defentry XShrinkRegion( fixnum ;; r fixnum ;; dx fixnum ;; dy )( void "XShrinkRegion")) (defentry XSubtractRegion( fixnum ;; sra fixnum ;; srb fixnum ;; dr_return )( void "XSubtractRegion")) (defentry XUnionRectWithRegion( fixnum ;; rectangle fixnum ;; src_region fixnum ;; dest_region_return )( void "XUnionRectWithRegion")) (defentry XUnionRegion( fixnum ;; sra fixnum ;; srb fixnum ;; dr_return )( void "XUnionRegion")) (defentry XWMGeometry( fixnum ;; display fixnum ;; screen_number object ;; user_geometry object ;; default_geometry fixnum ;; border_width fixnum ;; hints fixnum ;; x_return fixnum ;; y_return fixnum ;; width_return fixnum ;; height_return fixnum ;; gravity_return )( fixnum "XWMGeometry")) (defentry XXorRegion( fixnum ;; sra fixnum ;; srb fixnum ;; dr_return )( void "XXorRegion")) ;; ;; These macros are used to give some sugar to the image routines so that ;; naive people are more comfortable with them. (defentry XDestroyImage(fixnum) (fixnum "XDestroyImage")) (defentry XGetPixel(fixnum fixnum fixnum) (fixnum "XGetPixel" )) (defentry XPutPixel(fixnum fixnum int fixnum) ( fixnum "XPutPixel")) (defentry XSubImage(fixnum fixnum int fixnum fixnum) (fixnum "XSubImage")) (defentry XAddPixel(fixnum fixnum) (fixnum "XAddPixel")) ;; ;; Keysym macros, used on Keysyms to test for classes of symbols (defentry IsKeypadKey(fixnum) (fixnum "IsKeypadKey")) (defentry IsCursorKey(fixnum) (fixnum "IsCursorKey")) (defentry IsPFKey(fixnum) (fixnum "IsPFKey")) (defentry IsFunctionKey(fixnum) (fixnum "IsFunctionKey")) (defentry IsMiscFunctionKey(fixnum) (fixnum "IsMiscFunctionKey")) (defentry IsModifierKey(fixnum) (fixnum "IsModifierKey")) (defentry XUniqueContext() (fixnum "XUniqueContext")) (defentry XStringToContext(object) (fixnum "XStringToContext")) gcl-2.6.14/xgcl-2/version0000644000175000017500000000000214360276512013467 0ustar cammcamm2 gcl-2.6.14/xgcl-2/gcl_Xinit.lsp0000644000175000017500000001262514360276512014535 0ustar cammcamm(in-package :XLIB) ; Xinit.lsp Hiep Huu Nguyen 27 Aug 92; GSN 07 Mar 95 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;a word about Xakcl: ;;Since Xakcl is a direct translation of the X library in C to lisp to a ;;large extent. it would be beneficial to use a X 11 version 4, manual ;;in order to look up functions. the only unique functions of Xakcl are those ;;that involove manipulating C structs. all functions involved in creating ;;a C struct in X starts with a 'make' followed by the structure name. all ;;functions involved in getting a field of a C struct strats with the ;;name of the C struct followed by the name of the field. the ;;parameters it excepts is the variable contaning the structure. all ;;functions to set a field of a C struct starts with 'set' followed by ;;the C struct name followed by the field name. these functions accept ;;as parameter, the variable containing the struct and the value to be ;;put in the field. ;;;; ;;contents of this file: ;;;; ;;this files has examples of initializing the display, screen, ;;root-window, pixel value, gc, and colormap. ;;;; ;;gives an example of opening windows, setting size's and sizehints for ;;the window manager getting drawbles' geometry ;;;; ;;drawing lines , drawing in color, changing line, attributes ;;;; ;;tracking the mouse and handling events and manipulating the event ;;queue ;;;; ;;there is also some basic text handling stuff ;;;; ;;globals (defvar *default-display* ) (defvar *default-screen* ) (defvar *default-colormap*) (defvar *root-window* ) (defvar *black-pixel* ) (defvar *white-pixel* ) (defvar *default-size-hints* (make-XsizeHints) ) (defvar *default-GC* ) (defvar *default-event* (make-XEvent)) (defvar *pos-x* 10) (defvar *pos-y* 20) (defvar *win-width* 225) (defvar *win-height* 400) (defvar *border-width* 1) (defvar *root-return* (int-array 1)) (defvar *x-return* (int-array 1)) (defvar *y-return* (int-array 1) ) (defvar *width-return* (int-array 1)) (defvar *height-return* (int-array 1)) (defvar *border-width-return* (int-array 1)) (defvar *depth-return* (int-array 1)) (defvar *GC-Values* (make-XGCValues)) ;;an example window (defvar a-window) ;;;;;;;;;;;;;;;;;;;;;; ;;this function initializes all variables needed by most applications. ;;it uses all defaults which is inherited from the root window, and ;;screen. (defun Xinit() (setq *default-display* (XOpenDisplay (get-c-string ""))) (setq *default-screen* (XdefaultScreen *default-display*)) (setq *root-window* (XRootWindow *default-display* *default-screen*)) (setq *black-pixel* (XBlackPixel *default-display* *default-screen*)) (setq *white-pixel* (XWhitePixel *default-display* *default-screen*)) (setq *default-GC* (XDefaultGC *default-display* *default-screen*)) (setq *default-colormap* ( XDefaultColormap *default-display* *default-screen*)) (Xflush *default-display* )) ;;;;;;;;;;;;;;;;;;;;;; ;;this is an example of creating a window. this function takes care of ;;positioning, size and other attirbutes of the window. (defun open-window(&key (pos-x *pos-x* ) (pos-y *pos-y*) (win-width *win-width*) (win-height *win-height* ) (border-width *border-width*) (window-name "My Window") (icon-name "My Icon")) ;;create the window (let (( a-window (XCreateSimpleWindow *default-display* *root-window* pos-x pos-y win-width win-height border-width *black-pixel* *white-pixel*))) ;; all children of the root window needs a XSizeHints to tell the window manager ;; how to position it, etc (set-Xsizehints-x *default-size-hints* pos-x) (set-xsizehints-y *default-size-hints* pos-y) (set-xsizehints-width *default-size-hints* win-width) (set-xsizehints-height *default-size-hints* win-height) (set-xsizehints-flags *default-size-hints* (+ Psize Pposition)) (XsetStandardProperties *default-display* a-window (get-c-string window-name) (get-c-string icon-name) none 0 0 *default-size-hints*) ;; the events or input a window can have are set with Xselectinput ;; (Xselectinput *default-display* a-window ;; (+ ButtonpressMask PointerMotionMask ExposureMask)) ;; the window needs to be mapped (Xmapwindow *default-display* a-window) ;;the X server needs to have the output buffer sent to it before it can ;;process requests. this is acomplished with XFlush or functions that ;;read and manipulate the event queue. remember to do this after ;;operations that won't be calling an eventhandling function (Xflush *default-display* ) ;;after flushing the request buffer the X server draws window as requested a-window)) gcl-2.6.14/xgcl-2/gcl_dwimportsb.lsp0000644000175000017500000000760014360276512015631 0ustar cammcamm; dwimportsb.lsp Gordon S. Novak Jr. 11 Sep 06 ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This file imports symbols of the XGCL package; these symbols may be ; needed by a hard-core user of the Xlib functions. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; This file imports symbols from the dwindow.lsp file (in XLIB: package) ; to the current package (such as the :USER package). ; This will allow the dwindow.lsp functions to be called by just their ; names and without any package qualifier. ; This file should be loaded immediately after starting Lisp: ; If Lisp has seen any of these symbols, loading this file will cause an error. (dolist (x '(xlib::XRecolorCursor xlib::XFlush xlib::XUnMapWindow xlib::XClearWindow xlib::XMapWindow xlib::XTextWidth xlib::XOpenDisplay xlib::XdefaultScreen xlib::XRootWindow xlib::XBlackPixel xlib::XWhitePixel xlib::XDefaultGC xlib::XDefaultColormap xlib::make-XsetWindowAttributes xlib::set-XsetWindowAttributes-backing_store xlib::set-XsetWindowAttributes-save_under xlib::make-XWindowAttributes xlib::make-XsizeHints xlib::make-XEvent xlib::make-XGCValues xlib::XQueryPointer xlib::XCreateSimpleWindow xlib::XsetStandardProperties xlib::XCreateGC xlib::CWSaveUnder xlib::CWBackingStore xlib::XloadQueryFont xlib::XsetFont xlib::XGetGCValues xlib::XGCValues-foreground xlib::XsetForeground xlib::XGCValues-Background xlib::XsetBackground xlib::XGCValues-function xlib::XCreateFontCursor xlib::XDefineCursor xlib::XGetGeometry xlib::Xsync xlib::XsetFunction xlib::GXxor xlib::GXcopy xlib::XsetLineAttributes xlib::LineSolid xlib::CapButt xlib::JoinMiter xlib::XDrawLine xlib::XdrawArc xlib::XClearArea xlib::XCopyArea xlib::XFillRectangle xlib::XdrawImageString xlib::XTextExtents xlib::XDestroyWindow xlib::XFreeGC xlib::XMoveWindow xlib::Xsync xlib::Xselectinput xlib::ButtonPressMask xlib::PointerMotionMask xlib::XNextEvent xlib::XAnyEvent-type xlib::XAnyEvent-window xlib::MotionNotify xlib::ButtonPress xlib::XMotionEvent-x xlib::XMotionEvent-y xlib::XButtonEvent-button xlib::XAnyEvent-window xlib::XButtonEvent-button xlib::XWindowAttributes-map_state xlib::ISUnmapped xlib::XPending xlib::Expose xlib::XAllocColor xlib::XColor-Pixel xlib::XFreeColors xlib::KeyPressMask xlib::KeyReleaseMask xlib::KeyRelease xlib::KeyPress xlib::ButtonPress xlib::XDisplayKeycodes xlib::XGetKeyboardMapping xlib::XFree xlib::XK_Shift_R xlib::XK_Shift_L xlib::XK_Control_L xlib::XK_Control_R xlib::XK_Alt_R xlib::XK_Alt_L xlib::XK_Return xlib::XK_Tab xlib::XK_BackSpace xlib::get-c-string xlib::int-pos xlib::fixnum-array xlib::int-array xlib::fixnum-pos xlib::set-xsizehints-x xlib::set-xsizehints-y xlib::set-xsizehints-width xlib::set-xsizehints-height xlib::set-xsizehints-flags xlib::set-foreground xlib::set-background xlib::set-font xlib::set-cursor xlib::set-line-width xlib::set-line-attr xlib::set-Xcolor-red xlib::set-Xcolor-green xlib::set-Xcolor-blue xlib::WhenMapped xlib::Psize xlib::Pposition xlib::CWSaveUnder xlib::CWBackingStore xlib::NoSymbol xlib::leavewindowmask xlib::buttonreleasemask xlib::exposuremask xlib::GCForeground xlib::GCBackground xlib::GCFunction xlib::None xlib::Xfontstruct-fid xlib::XChangeWindowAttributes xlib::XGetWindowAttributes lisp::null xlib::Make-Xcolor )) (import x) ) gcl-2.6.14/xgcl-2/gcl_dwexports.lsp0000644000175000017500000001200014360276512015464 0ustar cammcamm; dwexports.lsp Gordon S. Novak Jr. 26 Jan 2006 (setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer) (in-package :xlib) ; exported symbols: from dwimports.lsp (dolist (x '( menu stringify window picmenu textmenu editmenu barmenu window-get-mouse-position window-create window-set-font window-font-info window-gcontext window-parent window-drawable-height window-drawable-width window-label window-font window-foreground window-set-foreground window-background window-set-background window-wfunction window-get-geometry window-get-geometry-b window-sync window-screen-height window-geometry window-size window-left window-top-neg-y window-reset-geometry window-force-output window-query-pointer window-set-xor window-unset window-reset window-set-erase window-set-copy window-set-invert window-set-line-width window-set-line-attr window-std-line-attr window-draw-line window-draw-line-xy window-draw-arrowhead-xy window-draw-arrow-xy window-draw-arrow2-xy window-draw-box window-draw-box-xy window-xor-box-xy window-draw-box-corners window-draw-rcbox-xy window-draw-arc-xy window-draw-circle-xy window-draw-circle window-erase-area window-erase-area-xy window-erase-box-xy window-draw-ellipse-xy window-copy-area-xy window-invertarea window-invert-area window-invert-area-xy window-prettyprintat window-prettyprintat-xy window-printat window-printat-xy window-string-width window-string-height window-string-extents window-font-string-width window-yposition window-centeroffset dowindowcom window-menu window-close window-unmap window-open window-map window-destroy window-destroy-selected-window window-clear window-moveto-xy window-paint window-move window-draw-border window-track-mouse window-wait-exposure window-wait-unmap window-init-mouse-poll window-poll-mouse menu-init menu-calculate-size menu-adjust-offset menu-draw menu-item-value menu-find-item-width menu-find-item-height menu-clear menu-display-item menu-choose menu-box-item menu-unbox-item menu-item-position menu-select menu-select! menu-select-b menu-destroy menu-create menu-offset menu-size menu-moveto-xy menu-reposition picmenu-create picmenu-create-spec picmenu-create-from-spec picmenu-calculate-size picmenu-init picmenu-draw picmenu-draw-button picmenu-delete-named-button picmenu-select picmenu-box-item picmenu-unbox-item picmenu-destroy picmenu-button-containsxy? picmenu-item-position barmenu-create barmenu-calculate-size barmenu-init barmenu-draw barmenu-select barmenu-update-value window-get-point window-get-click window-get-line-position window-get-latex-position window-get-box-position window-get-icon-position window-get-region window-get-box-size window-track-mouse-in-region window-adjust-box-side window-adj-box-xy window-get-circle window-circle-radius window-draw-circle-pt window-get-ellipse window-draw-ellipse-pt window-draw-vector-pt window-get-vector-end window-get-crosshairs window-draw-crosshairs-xy window-get-cross window-draw-cross-xy window-draw-dot-xy window-draw-latex-xy window-reset-color window-set-color-rgb window-set-xcolor window-set-color window-set-color window-free-color window-get-chars window-process-char-event window-input-string window-input-char-fn window-draw-carat window-init-keymap window-set-cursor window-positive-y window-code-char window-get-raw-char window-print-line window-print-lines textmenu-create textmenu-calculate-size textmenu-init textmenu-draw textmenu-select textmenu-set-text textmenu editmenu editmenu-create editmenu-calculate-size editmenu-init editmenu-draw editmenu-display window-edit window-edit-display editmenu-carat editmenu-erase window-edit-erase editmenu-select editmenu-edit-fn window-edit-fn editmenu-setxy editmenu-char editmenu-edit *window-editmenu-kill-strings* *window-add-menu-title* *window-menu* *mouse-x* *mouse-y* *mouse-window* *window-fonts* *window-display* *window-screen* *root-window* *black-pixel* *white-pixel* *default-fg-color* *default-bg-color* *default-size-hints* *default-GC* *default-colormap* *window-event* *window-default-pos-x* *window-default-pos-y* *window-default-border* *window-default-font-name* *window-default-cursor* *window-save-foreground* *window-save-function* *window-attributes* *window-attr* *menu-title-pad* *root-return* *child-return* *root-x-return* *root-y-return* *win-x-return* *win-y-return* *mask-return* *x-return* *y-return* *width-return* *height-return* *depth-return* *border-width-return* *text-width-return* *direction-return* *ascent-return* *descent-return* *overall-return* *GC-Values* *window-xcolor* *window-menu-code* *window-keymap* *window-shiftkeymap* *window-keyinit* *window-meta* *window-ctrl* *window-shift* *window-string* *window-string-count* *window-string-max* *window-input-string-x* *window-input-string-y* *window-input-string-charwidth* *window-shift-keys* *window-control-keys* *window-meta-keys* *barmenu-update-value-cons* *picmenu-no-selection* *min-keycodes-return* *max-keycodes-return* *keycodes-return* )) (export x)) ; export the above symbols gcl-2.6.14/xgcl-2/gcl_defentry_events.lsp0000644000175000017500000016330614360276512016651 0ustar cammcamm(in-package :XLIB) ; defentry-events.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;;;;; XKeyEvent functions ;;;;;; (defentry make-XKeyEvent () ( fixnum "make_XKeyEvent" )) (defentry XKeyEvent-same_screen (fixnum) ( fixnum "XKeyEvent_same_screen" )) (defentry set-XKeyEvent-same_screen (fixnum fixnum) ( void "set_XKeyEvent_same_screen" )) (defentry XKeyEvent-keycode (fixnum) ( fixnum "XKeyEvent_keycode" )) (defentry set-XKeyEvent-keycode (fixnum fixnum) ( void "set_XKeyEvent_keycode" )) (defentry XKeyEvent-state (fixnum) ( fixnum "XKeyEvent_state" )) (defentry set-XKeyEvent-state (fixnum fixnum) ( void "set_XKeyEvent_state" )) (defentry XKeyEvent-y_root (fixnum) ( fixnum "XKeyEvent_y_root" )) (defentry set-XKeyEvent-y_root (fixnum fixnum) ( void "set_XKeyEvent_y_root" )) (defentry XKeyEvent-x_root (fixnum) ( fixnum "XKeyEvent_x_root" )) (defentry set-XKeyEvent-x_root (fixnum fixnum) ( void "set_XKeyEvent_x_root" )) (defentry XKeyEvent-y (fixnum) ( fixnum "XKeyEvent_y" )) (defentry set-XKeyEvent-y (fixnum fixnum) ( void "set_XKeyEvent_y" )) (defentry XKeyEvent-x (fixnum) ( fixnum "XKeyEvent_x" )) (defentry set-XKeyEvent-x (fixnum fixnum) ( void "set_XKeyEvent_x" )) (defentry XKeyEvent-time (fixnum) ( fixnum "XKeyEvent_time" )) (defentry set-XKeyEvent-time (fixnum fixnum) ( void "set_XKeyEvent_time" )) (defentry XKeyEvent-subwindow (fixnum) ( fixnum "XKeyEvent_subwindow" )) (defentry set-XKeyEvent-subwindow (fixnum fixnum) ( void "set_XKeyEvent_subwindow" )) (defentry XKeyEvent-root (fixnum) ( fixnum "XKeyEvent_root" )) (defentry set-XKeyEvent-root (fixnum fixnum) ( void "set_XKeyEvent_root" )) (defentry XKeyEvent-window (fixnum) ( fixnum "XKeyEvent_window" )) (defentry set-XKeyEvent-window (fixnum fixnum) ( void "set_XKeyEvent_window" )) (defentry XKeyEvent-display (fixnum) ( fixnum "XKeyEvent_display" )) (defentry set-XKeyEvent-display (fixnum fixnum) ( void "set_XKeyEvent_display" )) (defentry XKeyEvent-send_event (fixnum) ( fixnum "XKeyEvent_send_event" )) (defentry set-XKeyEvent-send_event (fixnum fixnum) ( void "set_XKeyEvent_send_event" )) (defentry XKeyEvent-serial (fixnum) ( fixnum "XKeyEvent_serial" )) (defentry set-XKeyEvent-serial (fixnum fixnum) ( void "set_XKeyEvent_serial" )) (defentry XKeyEvent-type (fixnum) ( fixnum "XKeyEvent_type" )) (defentry set-XKeyEvent-type (fixnum fixnum) ( void "set_XKeyEvent_type" )) ;;;;;; XButtonEvent functions ;;;;;; (defentry make-XButtonEvent () ( fixnum "make_XButtonEvent" )) (defentry XButtonEvent-same_screen (fixnum) ( fixnum "XButtonEvent_same_screen" )) (defentry set-XButtonEvent-same_screen (fixnum fixnum) ( void "set_XButtonEvent_same_screen" )) (defentry XButtonEvent-button (fixnum) ( fixnum "XButtonEvent_button" )) (defentry set-XButtonEvent-button (fixnum fixnum) ( void "set_XButtonEvent_button" )) (defentry XButtonEvent-state (fixnum) ( fixnum "XButtonEvent_state" )) (defentry set-XButtonEvent-state (fixnum fixnum) ( void "set_XButtonEvent_state" )) (defentry XButtonEvent-y_root (fixnum) ( fixnum "XButtonEvent_y_root" )) (defentry set-XButtonEvent-y_root (fixnum fixnum) ( void "set_XButtonEvent_y_root" )) (defentry XButtonEvent-x_root (fixnum) ( fixnum "XButtonEvent_x_root" )) (defentry set-XButtonEvent-x_root (fixnum fixnum) ( void "set_XButtonEvent_x_root" )) (defentry XButtonEvent-y (fixnum) ( fixnum "XButtonEvent_y" )) (defentry set-XButtonEvent-y (fixnum fixnum) ( void "set_XButtonEvent_y" )) (defentry XButtonEvent-x (fixnum) ( fixnum "XButtonEvent_x" )) (defentry set-XButtonEvent-x (fixnum fixnum) ( void "set_XButtonEvent_x" )) (defentry XButtonEvent-time (fixnum) ( fixnum "XButtonEvent_time" )) (defentry set-XButtonEvent-time (fixnum fixnum) ( void "set_XButtonEvent_time" )) (defentry XButtonEvent-subwindow (fixnum) ( fixnum "XButtonEvent_subwindow" )) (defentry set-XButtonEvent-subwindow (fixnum fixnum) ( void "set_XButtonEvent_subwindow" )) (defentry XButtonEvent-root (fixnum) ( fixnum "XButtonEvent_root" )) (defentry set-XButtonEvent-root (fixnum fixnum) ( void "set_XButtonEvent_root" )) (defentry XButtonEvent-window (fixnum) ( fixnum "XButtonEvent_window" )) (defentry set-XButtonEvent-window (fixnum fixnum) ( void "set_XButtonEvent_window" )) (defentry XButtonEvent-display (fixnum) ( fixnum "XButtonEvent_display" )) (defentry set-XButtonEvent-display (fixnum fixnum) ( void "set_XButtonEvent_display" )) (defentry XButtonEvent-send_event (fixnum) ( fixnum "XButtonEvent_send_event" )) (defentry set-XButtonEvent-send_event (fixnum fixnum) ( void "set_XButtonEvent_send_event" )) (defentry XButtonEvent-serial (fixnum) ( fixnum "XButtonEvent_serial" )) (defentry set-XButtonEvent-serial (fixnum fixnum) ( void "set_XButtonEvent_serial" )) (defentry XButtonEvent-type (fixnum) ( fixnum "XButtonEvent_type" )) (defentry set-XButtonEvent-type (fixnum fixnum) ( void "set_XButtonEvent_type" )) ;;;;;; XMotionEvent functions ;;;;;; (defentry make-XMotionEvent () ( fixnum "make_XMotionEvent" )) (defentry XMotionEvent-same_screen (fixnum) ( fixnum "XMotionEvent_same_screen" )) (defentry set-XMotionEvent-same_screen (fixnum fixnum) ( void "set_XMotionEvent_same_screen" )) (defentry XMotionEvent-is_hint (fixnum) ( char "XMotionEvent_is_hint" )) (defentry set-XMotionEvent-is_hint (fixnum char) ( void "set_XMotionEvent_is_hint" )) (defentry XMotionEvent-state (fixnum) ( fixnum "XMotionEvent_state" )) (defentry set-XMotionEvent-state (fixnum fixnum) ( void "set_XMotionEvent_state" )) (defentry XMotionEvent-y_root (fixnum) ( fixnum "XMotionEvent_y_root" )) (defentry set-XMotionEvent-y_root (fixnum fixnum) ( void "set_XMotionEvent_y_root" )) (defentry XMotionEvent-x_root (fixnum) ( fixnum "XMotionEvent_x_root" )) (defentry set-XMotionEvent-x_root (fixnum fixnum) ( void "set_XMotionEvent_x_root" )) (defentry XMotionEvent-y (fixnum) ( fixnum "XMotionEvent_y" )) (defentry set-XMotionEvent-y (fixnum fixnum) ( void "set_XMotionEvent_y" )) (defentry XMotionEvent-x (fixnum) ( fixnum "XMotionEvent_x" )) (defentry set-XMotionEvent-x (fixnum fixnum) ( void "set_XMotionEvent_x" )) (defentry XMotionEvent-time (fixnum) ( fixnum "XMotionEvent_time" )) (defentry set-XMotionEvent-time (fixnum fixnum) ( void "set_XMotionEvent_time" )) (defentry XMotionEvent-subwindow (fixnum) ( fixnum "XMotionEvent_subwindow" )) (defentry set-XMotionEvent-subwindow (fixnum fixnum) ( void "set_XMotionEvent_subwindow" )) (defentry XMotionEvent-root (fixnum) ( fixnum "XMotionEvent_root" )) (defentry set-XMotionEvent-root (fixnum fixnum) ( void "set_XMotionEvent_root" )) (defentry XMotionEvent-window (fixnum) ( fixnum "XMotionEvent_window" )) (defentry set-XMotionEvent-window (fixnum fixnum) ( void "set_XMotionEvent_window" )) (defentry XMotionEvent-display (fixnum) ( fixnum "XMotionEvent_display" )) (defentry set-XMotionEvent-display (fixnum fixnum) ( void "set_XMotionEvent_display" )) (defentry XMotionEvent-send_event (fixnum) ( fixnum "XMotionEvent_send_event" )) (defentry set-XMotionEvent-send_event (fixnum fixnum) ( void "set_XMotionEvent_send_event" )) (defentry XMotionEvent-serial (fixnum) ( fixnum "XMotionEvent_serial" )) (defentry set-XMotionEvent-serial (fixnum fixnum) ( void "set_XMotionEvent_serial" )) (defentry XMotionEvent-type (fixnum) ( fixnum "XMotionEvent_type" )) (defentry set-XMotionEvent-type (fixnum fixnum) ( void "set_XMotionEvent_type" )) ;;;;;; XCrossingEvent functions ;;;;;; (defentry make-XCrossingEvent () ( fixnum "make_XCrossingEvent" )) (defentry XCrossingEvent-state (fixnum) ( fixnum "XCrossingEvent_state" )) (defentry set-XCrossingEvent-state (fixnum fixnum) ( void "set_XCrossingEvent_state" )) (defentry XCrossingEvent-focus (fixnum) ( fixnum "XCrossingEvent_focus" )) (defentry set-XCrossingEvent-focus (fixnum fixnum) ( void "set_XCrossingEvent_focus" )) (defentry XCrossingEvent-same_screen (fixnum) ( fixnum "XCrossingEvent_same_screen" )) (defentry set-XCrossingEvent-same_screen (fixnum fixnum) ( void "set_XCrossingEvent_same_screen" )) (defentry XCrossingEvent-detail (fixnum) ( fixnum "XCrossingEvent_detail" )) (defentry set-XCrossingEvent-detail (fixnum fixnum) ( void "set_XCrossingEvent_detail" )) (defentry XCrossingEvent-mode (fixnum) ( fixnum "XCrossingEvent_mode" )) (defentry set-XCrossingEvent-mode (fixnum fixnum) ( void "set_XCrossingEvent_mode" )) (defentry XCrossingEvent-y_root (fixnum) ( fixnum "XCrossingEvent_y_root" )) (defentry set-XCrossingEvent-y_root (fixnum fixnum) ( void "set_XCrossingEvent_y_root" )) (defentry XCrossingEvent-x_root (fixnum) ( fixnum "XCrossingEvent_x_root" )) (defentry set-XCrossingEvent-x_root (fixnum fixnum) ( void "set_XCrossingEvent_x_root" )) (defentry XCrossingEvent-y (fixnum) ( fixnum "XCrossingEvent_y" )) (defentry set-XCrossingEvent-y (fixnum fixnum) ( void "set_XCrossingEvent_y" )) (defentry XCrossingEvent-x (fixnum) ( fixnum "XCrossingEvent_x" )) (defentry set-XCrossingEvent-x (fixnum fixnum) ( void "set_XCrossingEvent_x" )) (defentry XCrossingEvent-time (fixnum) ( fixnum "XCrossingEvent_time" )) (defentry set-XCrossingEvent-time (fixnum fixnum) ( void "set_XCrossingEvent_time" )) (defentry XCrossingEvent-subwindow (fixnum) ( fixnum "XCrossingEvent_subwindow" )) (defentry set-XCrossingEvent-subwindow (fixnum fixnum) ( void "set_XCrossingEvent_subwindow" )) (defentry XCrossingEvent-root (fixnum) ( fixnum "XCrossingEvent_root" )) (defentry set-XCrossingEvent-root (fixnum fixnum) ( void "set_XCrossingEvent_root" )) (defentry XCrossingEvent-window (fixnum) ( fixnum "XCrossingEvent_window" )) (defentry set-XCrossingEvent-window (fixnum fixnum) ( void "set_XCrossingEvent_window" )) (defentry XCrossingEvent-display (fixnum) ( fixnum "XCrossingEvent_display" )) (defentry set-XCrossingEvent-display (fixnum fixnum) ( void "set_XCrossingEvent_display" )) (defentry XCrossingEvent-send_event (fixnum) ( fixnum "XCrossingEvent_send_event" )) (defentry set-XCrossingEvent-send_event (fixnum fixnum) ( void "set_XCrossingEvent_send_event" )) (defentry XCrossingEvent-serial (fixnum) ( fixnum "XCrossingEvent_serial" )) (defentry set-XCrossingEvent-serial (fixnum fixnum) ( void "set_XCrossingEvent_serial" )) (defentry XCrossingEvent-type (fixnum) ( fixnum "XCrossingEvent_type" )) (defentry set-XCrossingEvent-type (fixnum fixnum) ( void "set_XCrossingEvent_type" )) ;;;;;; XFocusChangeEvent functions ;;;;;; (defentry make-XFocusChangeEvent () ( fixnum "make_XFocusChangeEvent" )) (defentry XFocusChangeEvent-detail (fixnum) ( fixnum "XFocusChangeEvent_detail" )) (defentry set-XFocusChangeEvent-detail (fixnum fixnum) ( void "set_XFocusChangeEvent_detail" )) (defentry XFocusChangeEvent-mode (fixnum) ( fixnum "XFocusChangeEvent_mode" )) (defentry set-XFocusChangeEvent-mode (fixnum fixnum) ( void "set_XFocusChangeEvent_mode" )) (defentry XFocusChangeEvent-window (fixnum) ( fixnum "XFocusChangeEvent_window" )) (defentry set-XFocusChangeEvent-window (fixnum fixnum) ( void "set_XFocusChangeEvent_window" )) (defentry XFocusChangeEvent-display (fixnum) ( fixnum "XFocusChangeEvent_display" )) (defentry set-XFocusChangeEvent-display (fixnum fixnum) ( void "set_XFocusChangeEvent_display" )) (defentry XFocusChangeEvent-send_event (fixnum) ( fixnum "XFocusChangeEvent_send_event" )) (defentry set-XFocusChangeEvent-send_event (fixnum fixnum) ( void "set_XFocusChangeEvent_send_event" )) (defentry XFocusChangeEvent-serial (fixnum) ( fixnum "XFocusChangeEvent_serial" )) (defentry set-XFocusChangeEvent-serial (fixnum fixnum) ( void "set_XFocusChangeEvent_serial" )) (defentry XFocusChangeEvent-type (fixnum) ( fixnum "XFocusChangeEvent_type" )) (defentry set-XFocusChangeEvent-type (fixnum fixnum) ( void "set_XFocusChangeEvent_type" )) ;;;;;; XKeymapEvent functions ;;;;;; (defentry make-XKeymapEvent () ( fixnum "make_XKeymapEvent" )) ;;(defentry XKeymapEvent-key_vector[32] (fixnum) ( char "XKeymapEvent_key_vector[32]" )) ;;(defentry set-XKeymapEvent-key_vector[32] (fixnum char) ( void "set_XKeymapEvent_key_vector[32]" )) (defentry XKeymapEvent-window (fixnum) ( fixnum "XKeymapEvent_window" )) (defentry set-XKeymapEvent-window (fixnum fixnum) ( void "set_XKeymapEvent_window" )) (defentry XKeymapEvent-display (fixnum) ( fixnum "XKeymapEvent_display" )) (defentry set-XKeymapEvent-display (fixnum fixnum) ( void "set_XKeymapEvent_display" )) (defentry XKeymapEvent-send_event (fixnum) ( fixnum "XKeymapEvent_send_event" )) (defentry set-XKeymapEvent-send_event (fixnum fixnum) ( void "set_XKeymapEvent_send_event" )) (defentry XKeymapEvent-serial (fixnum) ( fixnum "XKeymapEvent_serial" )) (defentry set-XKeymapEvent-serial (fixnum fixnum) ( void "set_XKeymapEvent_serial" )) (defentry XKeymapEvent-type (fixnum) ( fixnum "XKeymapEvent_type" )) (defentry set-XKeymapEvent-type (fixnum fixnum) ( void "set_XKeymapEvent_type" )) ;;;;;; XExposeEvent functions ;;;;;; (defentry make-XExposeEvent () ( fixnum "make_XExposeEvent" )) (defentry XExposeEvent-count (fixnum) ( fixnum "XExposeEvent_count" )) (defentry set-XExposeEvent-count (fixnum fixnum) ( void "set_XExposeEvent_count" )) (defentry XExposeEvent-height (fixnum) ( fixnum "XExposeEvent_height" )) (defentry set-XExposeEvent-height (fixnum fixnum) ( void "set_XExposeEvent_height" )) (defentry XExposeEvent-width (fixnum) ( fixnum "XExposeEvent_width" )) (defentry set-XExposeEvent-width (fixnum fixnum) ( void "set_XExposeEvent_width" )) (defentry XExposeEvent-y (fixnum) ( fixnum "XExposeEvent_y" )) (defentry set-XExposeEvent-y (fixnum fixnum) ( void "set_XExposeEvent_y" )) (defentry XExposeEvent-x (fixnum) ( fixnum "XExposeEvent_x" )) (defentry set-XExposeEvent-x (fixnum fixnum) ( void "set_XExposeEvent_x" )) (defentry XExposeEvent-window (fixnum) ( fixnum "XExposeEvent_window" )) (defentry set-XExposeEvent-window (fixnum fixnum) ( void "set_XExposeEvent_window" )) (defentry XExposeEvent-display (fixnum) ( fixnum "XExposeEvent_display" )) (defentry set-XExposeEvent-display (fixnum fixnum) ( void "set_XExposeEvent_display" )) (defentry XExposeEvent-send_event (fixnum) ( fixnum "XExposeEvent_send_event" )) (defentry set-XExposeEvent-send_event (fixnum fixnum) ( void "set_XExposeEvent_send_event" )) (defentry XExposeEvent-serial (fixnum) ( fixnum "XExposeEvent_serial" )) (defentry set-XExposeEvent-serial (fixnum fixnum) ( void "set_XExposeEvent_serial" )) (defentry XExposeEvent-type (fixnum) ( fixnum "XExposeEvent_type" )) (defentry set-XExposeEvent-type (fixnum fixnum) ( void "set_XExposeEvent_type" )) ;;;;;; XGraphicsExposeEvent functions ;;;;;; (defentry make-XGraphicsExposeEvent () ( fixnum "make_XGraphicsExposeEvent" )) (defentry XGraphicsExposeEvent-minor_code (fixnum) ( fixnum "XGraphicsExposeEvent_minor_code" )) (defentry set-XGraphicsExposeEvent-minor_code (fixnum fixnum) ( void "set_XGraphicsExposeEvent_minor_code" )) (defentry XGraphicsExposeEvent-major_code (fixnum) ( fixnum "XGraphicsExposeEvent_major_code" )) (defentry set-XGraphicsExposeEvent-major_code (fixnum fixnum) ( void "set_XGraphicsExposeEvent_major_code" )) (defentry XGraphicsExposeEvent-count (fixnum) ( fixnum "XGraphicsExposeEvent_count" )) (defentry set-XGraphicsExposeEvent-count (fixnum fixnum) ( void "set_XGraphicsExposeEvent_count" )) (defentry XGraphicsExposeEvent-height (fixnum) ( fixnum "XGraphicsExposeEvent_height" )) (defentry set-XGraphicsExposeEvent-height (fixnum fixnum) ( void "set_XGraphicsExposeEvent_height" )) (defentry XGraphicsExposeEvent-width (fixnum) ( fixnum "XGraphicsExposeEvent_width" )) (defentry set-XGraphicsExposeEvent-width (fixnum fixnum) ( void "set_XGraphicsExposeEvent_width" )) (defentry XGraphicsExposeEvent-y (fixnum) ( fixnum "XGraphicsExposeEvent_y" )) (defentry set-XGraphicsExposeEvent-y (fixnum fixnum) ( void "set_XGraphicsExposeEvent_y" )) (defentry XGraphicsExposeEvent-x (fixnum) ( fixnum "XGraphicsExposeEvent_x" )) (defentry set-XGraphicsExposeEvent-x (fixnum fixnum) ( void "set_XGraphicsExposeEvent_x" )) (defentry XGraphicsExposeEvent-drawable (fixnum) (fixnum "XGraphicsExposeEvent_drawable" )) (defentry set-XGraphicsExposeEvent-drawable (fixnum fixnum) ( void "set_XGraphicsExposeEvent_drawable" )) (defentry XGraphicsExposeEvent-display (fixnum) ( fixnum "XGraphicsExposeEvent_display" )) (defentry set-XGraphicsExposeEvent-display (fixnum fixnum) ( void "set_XGraphicsExposeEvent_display" )) (defentry XGraphicsExposeEvent-send_event (fixnum) ( fixnum "XGraphicsExposeEvent_send_event" )) (defentry set-XGraphicsExposeEvent-send_event (fixnum fixnum) ( void "set_XGraphicsExposeEvent_send_event" )) (defentry XGraphicsExposeEvent-serial (fixnum) ( fixnum "XGraphicsExposeEvent_serial" )) (defentry set-XGraphicsExposeEvent-serial (fixnum fixnum) ( void "set_XGraphicsExposeEvent_serial" )) (defentry XGraphicsExposeEvent-type (fixnum) ( fixnum "XGraphicsExposeEvent_type" )) (defentry set-XGraphicsExposeEvent-type (fixnum fixnum) ( void "set_XGraphicsExposeEvent_type" )) ;;;;;; XNoExposeEvent functions ;;;;;; (defentry make-XNoExposeEvent () ( fixnum "make_XNoExposeEvent" )) (defentry XNoExposeEvent-minor_code (fixnum) ( fixnum "XNoExposeEvent_minor_code" )) (defentry set-XNoExposeEvent-minor_code (fixnum fixnum) ( void "set_XNoExposeEvent_minor_code" )) (defentry XNoExposeEvent-major_code (fixnum) ( fixnum "XNoExposeEvent_major_code" )) (defentry set-XNoExposeEvent-major_code (fixnum fixnum) ( void "set_XNoExposeEvent_major_code" )) (defentry XNoExposeEvent-drawable (fixnum) ( fixnum "XNoExposeEvent_drawable" )) (defentry set-XNoExposeEvent-drawable (fixnum fixnum) ( void "set_XNoExposeEvent_drawable" )) (defentry XNoExposeEvent-display (fixnum) ( fixnum "XNoExposeEvent_display" )) (defentry set-XNoExposeEvent-display (fixnum fixnum) ( void "set_XNoExposeEvent_display" )) (defentry XNoExposeEvent-send_event (fixnum) ( fixnum "XNoExposeEvent_send_event" )) (defentry set-XNoExposeEvent-send_event (fixnum fixnum) ( void "set_XNoExposeEvent_send_event" )) (defentry XNoExposeEvent-serial (fixnum) ( fixnum "XNoExposeEvent_serial" )) (defentry set-XNoExposeEvent-serial (fixnum fixnum) ( void "set_XNoExposeEvent_serial" )) (defentry XNoExposeEvent-type (fixnum) ( fixnum "XNoExposeEvent_type" )) (defentry set-XNoExposeEvent-type (fixnum fixnum) ( void "set_XNoExposeEvent_type" )) ;;;;;; XVisibilityEvent functions ;;;;;; (defentry make-XVisibilityEvent () ( fixnum "make_XVisibilityEvent" )) (defentry XVisibilityEvent-state (fixnum) ( fixnum "XVisibilityEvent_state" )) (defentry set-XVisibilityEvent-state (fixnum fixnum) ( void "set_XVisibilityEvent_state" )) (defentry XVisibilityEvent-window (fixnum) ( fixnum "XVisibilityEvent_window" )) (defentry set-XVisibilityEvent-window (fixnum fixnum) ( void "set_XVisibilityEvent_window" )) (defentry XVisibilityEvent-display (fixnum) ( fixnum "XVisibilityEvent_display" )) (defentry set-XVisibilityEvent-display (fixnum fixnum) ( void "set_XVisibilityEvent_display" )) (defentry XVisibilityEvent-send_event (fixnum) ( fixnum "XVisibilityEvent_send_event" )) (defentry set-XVisibilityEvent-send_event (fixnum fixnum) ( void "set_XVisibilityEvent_send_event" )) (defentry XVisibilityEvent-serial (fixnum) ( fixnum "XVisibilityEvent_serial" )) (defentry set-XVisibilityEvent-serial (fixnum fixnum) ( void "set_XVisibilityEvent_serial" )) (defentry XVisibilityEvent-type (fixnum) ( fixnum "XVisibilityEvent_type" )) (defentry set-XVisibilityEvent-type (fixnum fixnum) ( void "set_XVisibilityEvent_type" )) ;;;;;; XCreateWindowEvent functions ;;;;;; (defentry make-XCreateWindowEvent () ( fixnum "make_XCreateWindowEvent" )) (defentry XCreateWindowEvent-override_redirect (fixnum) ( fixnum "XCreateWindowEvent_override_redirect" )) (defentry set-XCreateWindowEvent-override_redirect (fixnum fixnum) ( void "set_XCreateWindowEvent_override_redirect" )) (defentry XCreateWindowEvent-border_width (fixnum) ( fixnum "XCreateWindowEvent_border_width" )) (defentry set-XCreateWindowEvent-border_width (fixnum fixnum) ( void "set_XCreateWindowEvent_border_width" )) (defentry XCreateWindowEvent-height (fixnum) ( fixnum "XCreateWindowEvent_height" )) (defentry set-XCreateWindowEvent-height (fixnum fixnum) ( void "set_XCreateWindowEvent_height" )) (defentry XCreateWindowEvent-width (fixnum) ( fixnum "XCreateWindowEvent_width" )) (defentry set-XCreateWindowEvent-width (fixnum fixnum) ( void "set_XCreateWindowEvent_width" )) (defentry XCreateWindowEvent-y (fixnum) ( fixnum "XCreateWindowEvent_y" )) (defentry set-XCreateWindowEvent-y (fixnum fixnum) ( void "set_XCreateWindowEvent_y" )) (defentry XCreateWindowEvent-x (fixnum) ( fixnum "XCreateWindowEvent_x" )) (defentry set-XCreateWindowEvent-x (fixnum fixnum) ( void "set_XCreateWindowEvent_x" )) (defentry XCreateWindowEvent-window (fixnum) ( fixnum "XCreateWindowEvent_window" )) (defentry set-XCreateWindowEvent-window (fixnum fixnum) ( void "set_XCreateWindowEvent_window" )) (defentry XCreateWindowEvent-parent (fixnum) ( fixnum "XCreateWindowEvent_parent" )) (defentry set-XCreateWindowEvent-parent (fixnum fixnum) ( void "set_XCreateWindowEvent_parent" )) (defentry XCreateWindowEvent-display (fixnum) ( fixnum "XCreateWindowEvent_display" )) (defentry set-XCreateWindowEvent-display (fixnum fixnum) ( void "set_XCreateWindowEvent_display" )) (defentry XCreateWindowEvent-send_event (fixnum) ( fixnum "XCreateWindowEvent_send_event" )) (defentry set-XCreateWindowEvent-send_event (fixnum fixnum) ( void "set_XCreateWindowEvent_send_event" )) (defentry XCreateWindowEvent-serial (fixnum) ( fixnum "XCreateWindowEvent_serial" )) (defentry set-XCreateWindowEvent-serial (fixnum fixnum) ( void "set_XCreateWindowEvent_serial" )) (defentry XCreateWindowEvent-type (fixnum) ( fixnum "XCreateWindowEvent_type" )) (defentry set-XCreateWindowEvent-type (fixnum fixnum) ( void "set_XCreateWindowEvent_type" )) ;;;;;; XDestroyWindowEvent functions ;;;;;; (defentry make-XDestroyWindowEvent () ( fixnum "make_XDestroyWindowEvent" )) (defentry XDestroyWindowEvent-window (fixnum) ( fixnum "XDestroyWindowEvent_window" )) (defentry set-XDestroyWindowEvent-window (fixnum fixnum) ( void "set_XDestroyWindowEvent_window" )) (defentry XDestroyWindowEvent-event (fixnum) ( fixnum "XDestroyWindowEvent_event" )) (defentry set-XDestroyWindowEvent-event (fixnum fixnum) ( void "set_XDestroyWindowEvent_event" )) (defentry XDestroyWindowEvent-display (fixnum) ( fixnum "XDestroyWindowEvent_display" )) (defentry set-XDestroyWindowEvent-display (fixnum fixnum) ( void "set_XDestroyWindowEvent_display" )) (defentry XDestroyWindowEvent-send_event (fixnum) ( fixnum "XDestroyWindowEvent_send_event" )) (defentry set-XDestroyWindowEvent-send_event (fixnum fixnum) ( void "set_XDestroyWindowEvent_send_event" )) (defentry XDestroyWindowEvent-serial (fixnum) ( fixnum "XDestroyWindowEvent_serial" )) (defentry set-XDestroyWindowEvent-serial (fixnum fixnum) ( void "set_XDestroyWindowEvent_serial" )) (defentry XDestroyWindowEvent-type (fixnum) ( fixnum "XDestroyWindowEvent_type" )) (defentry set-XDestroyWindowEvent-type (fixnum fixnum) ( void "set_XDestroyWindowEvent_type" )) ;;;;;; XUnmapEvent functions ;;;;;; (defentry make-XUnmapEvent () ( fixnum "make_XUnmapEvent" )) (defentry XUnmapEvent-from_configure (fixnum) ( fixnum "XUnmapEvent_from_configure" )) (defentry set-XUnmapEvent-from_configure (fixnum fixnum) ( void "set_XUnmapEvent_from_configure" )) (defentry XUnmapEvent-window (fixnum) ( fixnum "XUnmapEvent_window" )) (defentry set-XUnmapEvent-window (fixnum fixnum) ( void "set_XUnmapEvent_window" )) (defentry XUnmapEvent-event (fixnum) ( fixnum "XUnmapEvent_event" )) (defentry set-XUnmapEvent-event (fixnum fixnum) ( void "set_XUnmapEvent_event" )) (defentry XUnmapEvent-display (fixnum) ( fixnum "XUnmapEvent_display" )) (defentry set-XUnmapEvent-display (fixnum fixnum) ( void "set_XUnmapEvent_display" )) (defentry XUnmapEvent-send_event (fixnum) ( fixnum "XUnmapEvent_send_event" )) (defentry set-XUnmapEvent-send_event (fixnum fixnum) ( void "set_XUnmapEvent_send_event" )) (defentry XUnmapEvent-serial (fixnum) ( fixnum "XUnmapEvent_serial" )) (defentry set-XUnmapEvent-serial (fixnum fixnum) ( void "set_XUnmapEvent_serial" )) (defentry XUnmapEvent-type (fixnum) ( fixnum "XUnmapEvent_type" )) (defentry set-XUnmapEvent-type (fixnum fixnum) ( void "set_XUnmapEvent_type" )) ;;;;;; XMapEvent functions ;;;;;; (defentry make-XMapEvent () ( fixnum "make_XMapEvent" )) (defentry XMapEvent-override_redirect (fixnum) ( fixnum "XMapEvent_override_redirect" )) (defentry set-XMapEvent-override_redirect (fixnum fixnum) ( void "set_XMapEvent_override_redirect" )) (defentry XMapEvent-window (fixnum) ( fixnum "XMapEvent_window" )) (defentry set-XMapEvent-window (fixnum fixnum) ( void "set_XMapEvent_window" )) (defentry XMapEvent-event (fixnum) ( fixnum "XMapEvent_event" )) (defentry set-XMapEvent-event (fixnum fixnum) ( void "set_XMapEvent_event" )) (defentry XMapEvent-display (fixnum) ( fixnum "XMapEvent_display" )) (defentry set-XMapEvent-display (fixnum fixnum) ( void "set_XMapEvent_display" )) (defentry XMapEvent-send_event (fixnum) ( fixnum "XMapEvent_send_event" )) (defentry set-XMapEvent-send_event (fixnum fixnum) ( void "set_XMapEvent_send_event" )) (defentry XMapEvent-serial (fixnum) ( fixnum "XMapEvent_serial" )) (defentry set-XMapEvent-serial (fixnum fixnum) ( void "set_XMapEvent_serial" )) (defentry XMapEvent-type (fixnum) ( fixnum "XMapEvent_type" )) (defentry set-XMapEvent-type (fixnum fixnum) ( void "set_XMapEvent_type" )) ;;;;;; XMapRequestEvent functions ;;;;;; (defentry make-XMapRequestEvent () ( fixnum "make_XMapRequestEvent" )) (defentry XMapRequestEvent-window (fixnum) ( fixnum "XMapRequestEvent_window" )) (defentry set-XMapRequestEvent-window (fixnum fixnum) ( void "set_XMapRequestEvent_window" )) (defentry XMapRequestEvent-parent (fixnum) ( fixnum "XMapRequestEvent_parent" )) (defentry set-XMapRequestEvent-parent (fixnum fixnum) ( void "set_XMapRequestEvent_parent" )) (defentry XMapRequestEvent-display (fixnum) ( fixnum "XMapRequestEvent_display" )) (defentry set-XMapRequestEvent-display (fixnum fixnum) ( void "set_XMapRequestEvent_display" )) (defentry XMapRequestEvent-send_event (fixnum) ( fixnum "XMapRequestEvent_send_event" )) (defentry set-XMapRequestEvent-send_event (fixnum fixnum) ( void "set_XMapRequestEvent_send_event" )) (defentry XMapRequestEvent-serial (fixnum) ( fixnum "XMapRequestEvent_serial" )) (defentry set-XMapRequestEvent-serial (fixnum fixnum) ( void "set_XMapRequestEvent_serial" )) (defentry XMapRequestEvent-type (fixnum) ( fixnum "XMapRequestEvent_type" )) (defentry set-XMapRequestEvent-type (fixnum fixnum) ( void "set_XMapRequestEvent_type" )) ;;;;;; XReparentEvent functions ;;;;;; (defentry make-XReparentEvent () ( fixnum "make_XReparentEvent" )) (defentry XReparentEvent-override_redirect (fixnum) ( fixnum "XReparentEvent_override_redirect" )) (defentry set-XReparentEvent-override_redirect (fixnum fixnum) ( void "set_XReparentEvent_override_redirect" )) (defentry XReparentEvent-y (fixnum) ( fixnum "XReparentEvent_y" )) (defentry set-XReparentEvent-y (fixnum fixnum) ( void "set_XReparentEvent_y" )) (defentry XReparentEvent-x (fixnum) ( fixnum "XReparentEvent_x" )) (defentry set-XReparentEvent-x (fixnum fixnum) ( void "set_XReparentEvent_x" )) (defentry XReparentEvent-parent (fixnum) ( fixnum "XReparentEvent_parent" )) (defentry set-XReparentEvent-parent (fixnum fixnum) ( void "set_XReparentEvent_parent" )) (defentry XReparentEvent-window (fixnum) ( fixnum "XReparentEvent_window" )) (defentry set-XReparentEvent-window (fixnum fixnum) ( void "set_XReparentEvent_window" )) (defentry XReparentEvent-event (fixnum) ( fixnum "XReparentEvent_event" )) (defentry set-XReparentEvent-event (fixnum fixnum) ( void "set_XReparentEvent_event" )) (defentry XReparentEvent-display (fixnum) ( fixnum "XReparentEvent_display" )) (defentry set-XReparentEvent-display (fixnum fixnum) ( void "set_XReparentEvent_display" )) (defentry XReparentEvent-send_event (fixnum) ( fixnum "XReparentEvent_send_event" )) (defentry set-XReparentEvent-send_event (fixnum fixnum) ( void "set_XReparentEvent_send_event" )) (defentry XReparentEvent-serial (fixnum) ( fixnum "XReparentEvent_serial" )) (defentry set-XReparentEvent-serial (fixnum fixnum) ( void "set_XReparentEvent_serial" )) (defentry XReparentEvent-type (fixnum) ( fixnum "XReparentEvent_type" )) (defentry set-XReparentEvent-type (fixnum fixnum) ( void "set_XReparentEvent_type" )) ;;;;;; XConfigureEvent functions ;;;;;; (defentry make-XConfigureEvent () ( fixnum "make_XConfigureEvent" )) (defentry XConfigureEvent-override_redirect (fixnum) ( fixnum "XConfigureEvent_override_redirect" )) (defentry set-XConfigureEvent-override_redirect (fixnum fixnum) ( void "set_XConfigureEvent_override_redirect" )) (defentry XConfigureEvent-above (fixnum) ( fixnum "XConfigureEvent_above" )) (defentry set-XConfigureEvent-above (fixnum fixnum) ( void "set_XConfigureEvent_above" )) (defentry XConfigureEvent-border_width (fixnum) ( fixnum "XConfigureEvent_border_width" )) (defentry set-XConfigureEvent-border_width (fixnum fixnum) ( void "set_XConfigureEvent_border_width" )) (defentry XConfigureEvent-height (fixnum) ( fixnum "XConfigureEvent_height" )) (defentry set-XConfigureEvent-height (fixnum fixnum) ( void "set_XConfigureEvent_height" )) (defentry XConfigureEvent-width (fixnum) ( fixnum "XConfigureEvent_width" )) (defentry set-XConfigureEvent-width (fixnum fixnum) ( void "set_XConfigureEvent_width" )) (defentry XConfigureEvent-y (fixnum) ( fixnum "XConfigureEvent_y" )) (defentry set-XConfigureEvent-y (fixnum fixnum) ( void "set_XConfigureEvent_y" )) (defentry XConfigureEvent-x (fixnum) ( fixnum "XConfigureEvent_x" )) (defentry set-XConfigureEvent-x (fixnum fixnum) ( void "set_XConfigureEvent_x" )) (defentry XConfigureEvent-window (fixnum) ( fixnum "XConfigureEvent_window" )) (defentry set-XConfigureEvent-window (fixnum fixnum) ( void "set_XConfigureEvent_window" )) (defentry XConfigureEvent-event (fixnum) ( fixnum "XConfigureEvent_event" )) (defentry set-XConfigureEvent-event (fixnum fixnum) ( void "set_XConfigureEvent_event" )) (defentry XConfigureEvent-display (fixnum) ( fixnum "XConfigureEvent_display" )) (defentry set-XConfigureEvent-display (fixnum fixnum) ( void "set_XConfigureEvent_display" )) (defentry XConfigureEvent-send_event (fixnum) ( fixnum "XConfigureEvent_send_event" )) (defentry set-XConfigureEvent-send_event (fixnum fixnum) ( void "set_XConfigureEvent_send_event" )) (defentry XConfigureEvent-serial (fixnum) ( fixnum "XConfigureEvent_serial" )) (defentry set-XConfigureEvent-serial (fixnum fixnum) ( void "set_XConfigureEvent_serial" )) (defentry XConfigureEvent-type (fixnum) ( fixnum "XConfigureEvent_type" )) (defentry set-XConfigureEvent-type (fixnum fixnum) ( void "set_XConfigureEvent_type" )) ;;;;;; XGravityEvent functions ;;;;;; (defentry make-XGravityEvent () ( fixnum "make_XGravityEvent" )) (defentry XGravityEvent-y (fixnum) ( fixnum "XGravityEvent_y" )) (defentry set-XGravityEvent-y (fixnum fixnum) ( void "set_XGravityEvent_y" )) (defentry XGravityEvent-x (fixnum) ( fixnum "XGravityEvent_x" )) (defentry set-XGravityEvent-x (fixnum fixnum) ( void "set_XGravityEvent_x" )) (defentry XGravityEvent-window (fixnum) ( fixnum "XGravityEvent_window" )) (defentry set-XGravityEvent-window (fixnum fixnum) ( void "set_XGravityEvent_window" )) (defentry XGravityEvent-event (fixnum) ( fixnum "XGravityEvent_event" )) (defentry set-XGravityEvent-event (fixnum fixnum) ( void "set_XGravityEvent_event" )) (defentry XGravityEvent-display (fixnum) ( fixnum "XGravityEvent_display" )) (defentry set-XGravityEvent-display (fixnum fixnum) ( void "set_XGravityEvent_display" )) (defentry XGravityEvent-send_event (fixnum) ( fixnum "XGravityEvent_send_event" )) (defentry set-XGravityEvent-send_event (fixnum fixnum) ( void "set_XGravityEvent_send_event" )) (defentry XGravityEvent-serial (fixnum) ( fixnum "XGravityEvent_serial" )) (defentry set-XGravityEvent-serial (fixnum fixnum) ( void "set_XGravityEvent_serial" )) (defentry XGravityEvent-type (fixnum) ( fixnum "XGravityEvent_type" )) (defentry set-XGravityEvent-type (fixnum fixnum) ( void "set_XGravityEvent_type" )) ;;;;;; XResizeRequestEvent functions ;;;;;; (defentry make-XResizeRequestEvent () ( fixnum "make_XResizeRequestEvent" )) (defentry XResizeRequestEvent-height (fixnum) ( fixnum "XResizeRequestEvent_height" )) (defentry set-XResizeRequestEvent-height (fixnum fixnum) ( void "set_XResizeRequestEvent_height" )) (defentry XResizeRequestEvent-width (fixnum) ( fixnum "XResizeRequestEvent_width" )) (defentry set-XResizeRequestEvent-width (fixnum fixnum) ( void "set_XResizeRequestEvent_width" )) (defentry XResizeRequestEvent-window (fixnum) ( fixnum "XResizeRequestEvent_window" )) (defentry set-XResizeRequestEvent-window (fixnum fixnum) ( void "set_XResizeRequestEvent_window" )) (defentry XResizeRequestEvent-display (fixnum) ( fixnum "XResizeRequestEvent_display" )) (defentry set-XResizeRequestEvent-display (fixnum fixnum) ( void "set_XResizeRequestEvent_display" )) (defentry XResizeRequestEvent-send_event (fixnum) ( fixnum "XResizeRequestEvent_send_event" )) (defentry set-XResizeRequestEvent-send_event (fixnum fixnum) ( void "set_XResizeRequestEvent_send_event" )) (defentry XResizeRequestEvent-serial (fixnum) ( fixnum "XResizeRequestEvent_serial" )) (defentry set-XResizeRequestEvent-serial (fixnum fixnum) ( void "set_XResizeRequestEvent_serial" )) (defentry XResizeRequestEvent-type (fixnum) ( fixnum "XResizeRequestEvent_type" )) (defentry set-XResizeRequestEvent-type (fixnum fixnum) ( void "set_XResizeRequestEvent_type" )) ;;;;;; XConfigureRequestEvent functions ;;;;;; (defentry make-XConfigureRequestEvent () ( fixnum "make_XConfigureRequestEvent" )) (defentry XConfigureRequestEvent-value_mask (fixnum) ( fixnum "XConfigureRequestEvent_value_mask" )) (defentry set-XConfigureRequestEvent-value_mask (fixnum fixnum) ( void "set_XConfigureRequestEvent_value_mask" )) (defentry XConfigureRequestEvent-detail (fixnum) ( fixnum "XConfigureRequestEvent_detail" )) (defentry set-XConfigureRequestEvent-detail (fixnum fixnum) ( void "set_XConfigureRequestEvent_detail" )) (defentry XConfigureRequestEvent-above (fixnum) ( fixnum "XConfigureRequestEvent_above" )) (defentry set-XConfigureRequestEvent-above (fixnum fixnum) ( void "set_XConfigureRequestEvent_above" )) (defentry XConfigureRequestEvent-border_width (fixnum) ( fixnum "XConfigureRequestEvent_border_width" )) (defentry set-XConfigureRequestEvent-border_width (fixnum fixnum) ( void "set_XConfigureRequestEvent_border_width" )) (defentry XConfigureRequestEvent-height (fixnum) ( fixnum "XConfigureRequestEvent_height" )) (defentry set-XConfigureRequestEvent-height (fixnum fixnum) ( void "set_XConfigureRequestEvent_height" )) (defentry XConfigureRequestEvent-width (fixnum) ( fixnum "XConfigureRequestEvent_width" )) (defentry set-XConfigureRequestEvent-width (fixnum fixnum) ( void "set_XConfigureRequestEvent_width" )) (defentry XConfigureRequestEvent-y (fixnum) ( fixnum "XConfigureRequestEvent_y" )) (defentry set-XConfigureRequestEvent-y (fixnum fixnum) ( void "set_XConfigureRequestEvent_y" )) (defentry XConfigureRequestEvent-x (fixnum) ( fixnum "XConfigureRequestEvent_x" )) (defentry set-XConfigureRequestEvent-x (fixnum fixnum) ( void "set_XConfigureRequestEvent_x" )) (defentry XConfigureRequestEvent-window (fixnum) ( fixnum "XConfigureRequestEvent_window" )) (defentry set-XConfigureRequestEvent-window (fixnum fixnum) ( void "set_XConfigureRequestEvent_window" )) (defentry XConfigureRequestEvent-parent (fixnum) ( fixnum "XConfigureRequestEvent_parent" )) (defentry set-XConfigureRequestEvent-parent (fixnum fixnum) ( void "set_XConfigureRequestEvent_parent" )) (defentry XConfigureRequestEvent-display (fixnum) ( fixnum "XConfigureRequestEvent_display" )) (defentry set-XConfigureRequestEvent-display (fixnum fixnum) ( void "set_XConfigureRequestEvent_display" )) (defentry XConfigureRequestEvent-send_event (fixnum) ( fixnum "XConfigureRequestEvent_send_event" )) (defentry set-XConfigureRequestEvent-send_event (fixnum fixnum) ( void "set_XConfigureRequestEvent_send_event" )) (defentry XConfigureRequestEvent-serial (fixnum) ( fixnum "XConfigureRequestEvent_serial" )) (defentry set-XConfigureRequestEvent-serial (fixnum fixnum) ( void "set_XConfigureRequestEvent_serial" )) (defentry XConfigureRequestEvent-type (fixnum) ( fixnum "XConfigureRequestEvent_type" )) (defentry set-XConfigureRequestEvent-type (fixnum fixnum) ( void "set_XConfigureRequestEvent_type" )) ;;;;;; XCirculateEvent functions ;;;;;; (defentry make-XCirculateEvent () ( fixnum "make_XCirculateEvent" )) (defentry XCirculateEvent-place (fixnum) ( fixnum "XCirculateEvent_place" )) (defentry set-XCirculateEvent-place (fixnum fixnum) ( void "set_XCirculateEvent_place" )) (defentry XCirculateEvent-window (fixnum) ( fixnum "XCirculateEvent_window" )) (defentry set-XCirculateEvent-window (fixnum fixnum) ( void "set_XCirculateEvent_window" )) (defentry XCirculateEvent-event (fixnum) ( fixnum "XCirculateEvent_event" )) (defentry set-XCirculateEvent-event (fixnum fixnum) ( void "set_XCirculateEvent_event" )) (defentry XCirculateEvent-display (fixnum) ( fixnum "XCirculateEvent_display" )) (defentry set-XCirculateEvent-display (fixnum fixnum) ( void "set_XCirculateEvent_display" )) (defentry XCirculateEvent-send_event (fixnum) ( fixnum "XCirculateEvent_send_event" )) (defentry set-XCirculateEvent-send_event (fixnum fixnum) ( void "set_XCirculateEvent_send_event" )) (defentry XCirculateEvent-serial (fixnum) ( fixnum "XCirculateEvent_serial" )) (defentry set-XCirculateEvent-serial (fixnum fixnum) ( void "set_XCirculateEvent_serial" )) (defentry XCirculateEvent-type (fixnum) ( fixnum "XCirculateEvent_type" )) (defentry set-XCirculateEvent-type (fixnum fixnum) ( void "set_XCirculateEvent_type" )) ;;;;;; XCirculateRequestEvent functions ;;;;;; (defentry make-XCirculateRequestEvent () ( fixnum "make_XCirculateRequestEvent" )) (defentry XCirculateRequestEvent-place (fixnum) ( fixnum "XCirculateRequestEvent_place" )) (defentry set-XCirculateRequestEvent-place (fixnum fixnum) ( void "set_XCirculateRequestEvent_place" )) (defentry XCirculateRequestEvent-window (fixnum) ( fixnum "XCirculateRequestEvent_window" )) (defentry set-XCirculateRequestEvent-window (fixnum fixnum) ( void "set_XCirculateRequestEvent_window" )) (defentry XCirculateRequestEvent-parent (fixnum) ( fixnum "XCirculateRequestEvent_parent" )) (defentry set-XCirculateRequestEvent-parent (fixnum fixnum) ( void "set_XCirculateRequestEvent_parent" )) (defentry XCirculateRequestEvent-display (fixnum) ( fixnum "XCirculateRequestEvent_display" )) (defentry set-XCirculateRequestEvent-display (fixnum fixnum) ( void "set_XCirculateRequestEvent_display" )) (defentry XCirculateRequestEvent-send_event (fixnum) ( fixnum "XCirculateRequestEvent_send_event" )) (defentry set-XCirculateRequestEvent-send_event (fixnum fixnum) ( void "set_XCirculateRequestEvent_send_event" )) (defentry XCirculateRequestEvent-serial (fixnum) ( fixnum "XCirculateRequestEvent_serial" )) (defentry set-XCirculateRequestEvent-serial (fixnum fixnum) ( void "set_XCirculateRequestEvent_serial" )) (defentry XCirculateRequestEvent-type (fixnum) ( fixnum "XCirculateRequestEvent_type" )) (defentry set-XCirculateRequestEvent-type (fixnum fixnum) ( void "set_XCirculateRequestEvent_type" )) ;;;;;; XPropertyEvent functions ;;;;;; (defentry make-XPropertyEvent () ( fixnum "make_XPropertyEvent" )) (defentry XPropertyEvent-state (fixnum) ( fixnum "XPropertyEvent_state" )) (defentry set-XPropertyEvent-state (fixnum fixnum) ( void "set_XPropertyEvent_state" )) (defentry XPropertyEvent-time (fixnum) ( fixnum "XPropertyEvent_time" )) (defentry set-XPropertyEvent-time (fixnum fixnum) ( void "set_XPropertyEvent_time" )) (defentry XPropertyEvent-atom (fixnum) ( fixnum "XPropertyEvent_atom" )) (defentry set-XPropertyEvent-atom (fixnum fixnum) ( void "set_XPropertyEvent_atom" )) (defentry XPropertyEvent-window (fixnum) ( fixnum "XPropertyEvent_window" )) (defentry set-XPropertyEvent-window (fixnum fixnum) ( void "set_XPropertyEvent_window" )) (defentry XPropertyEvent-display (fixnum) ( fixnum "XPropertyEvent_display" )) (defentry set-XPropertyEvent-display (fixnum fixnum) ( void "set_XPropertyEvent_display" )) (defentry XPropertyEvent-send_event (fixnum) ( fixnum "XPropertyEvent_send_event" )) (defentry set-XPropertyEvent-send_event (fixnum fixnum) ( void "set_XPropertyEvent_send_event" )) (defentry XPropertyEvent-serial (fixnum) ( fixnum "XPropertyEvent_serial" )) (defentry set-XPropertyEvent-serial (fixnum fixnum) ( void "set_XPropertyEvent_serial" )) (defentry XPropertyEvent-type (fixnum) ( fixnum "XPropertyEvent_type" )) (defentry set-XPropertyEvent-type (fixnum fixnum) ( void "set_XPropertyEvent_type" )) ;;;;;; XSelectionClearEvent functions ;;;;;; (defentry make-XSelectionClearEvent () ( fixnum "make_XSelectionClearEvent" )) (defentry XSelectionClearEvent-time (fixnum) ( fixnum "XSelectionClearEvent_time" )) (defentry set-XSelectionClearEvent-time (fixnum fixnum) ( void "set_XSelectionClearEvent_time" )) (defentry XSelectionClearEvent-selection (fixnum) ( fixnum "XSelectionClearEvent_selection" )) (defentry set-XSelectionClearEvent-selection (fixnum fixnum) ( void "set_XSelectionClearEvent_selection" )) (defentry XSelectionClearEvent-window (fixnum) ( fixnum "XSelectionClearEvent_window" )) (defentry set-XSelectionClearEvent-window (fixnum fixnum) ( void "set_XSelectionClearEvent_window" )) (defentry XSelectionClearEvent-display (fixnum) ( fixnum "XSelectionClearEvent_display" )) (defentry set-XSelectionClearEvent-display (fixnum fixnum) ( void "set_XSelectionClearEvent_display" )) (defentry XSelectionClearEvent-send_event (fixnum) ( fixnum "XSelectionClearEvent_send_event" )) (defentry set-XSelectionClearEvent-send_event (fixnum fixnum) ( void "set_XSelectionClearEvent_send_event" )) (defentry XSelectionClearEvent-serial (fixnum) ( fixnum "XSelectionClearEvent_serial" )) (defentry set-XSelectionClearEvent-serial (fixnum fixnum) ( void "set_XSelectionClearEvent_serial" )) (defentry XSelectionClearEvent-type (fixnum) ( fixnum "XSelectionClearEvent_type" )) (defentry set-XSelectionClearEvent-type (fixnum fixnum) ( void "set_XSelectionClearEvent_type" )) ;;;;;; XSelectionRequestEvent functions ;;;;;; (defentry make-XSelectionRequestEvent () ( fixnum "make_XSelectionRequestEvent" )) (defentry XSelectionRequestEvent-time (fixnum) ( fixnum "XSelectionRequestEvent_time" )) (defentry set-XSelectionRequestEvent-time (fixnum fixnum) ( void "set_XSelectionRequestEvent_time" )) (defentry XSelectionRequestEvent-property (fixnum) ( fixnum "XSelectionRequestEvent_property" )) (defentry set-XSelectionRequestEvent-property (fixnum fixnum) ( void "set_XSelectionRequestEvent_property" )) (defentry XSelectionRequestEvent-target (fixnum) ( fixnum "XSelectionRequestEvent_target" )) (defentry set-XSelectionRequestEvent-target (fixnum fixnum) ( void "set_XSelectionRequestEvent_target" )) (defentry XSelectionRequestEvent-selection (fixnum) ( fixnum "XSelectionRequestEvent_selection" )) (defentry set-XSelectionRequestEvent-selection (fixnum fixnum) ( void "set_XSelectionRequestEvent_selection" )) (defentry XSelectionRequestEvent-requestor (fixnum) ( fixnum "XSelectionRequestEvent_requestor" )) (defentry set-XSelectionRequestEvent-requestor (fixnum fixnum) ( void "set_XSelectionRequestEvent_requestor" )) (defentry XSelectionRequestEvent-owner (fixnum) ( fixnum "XSelectionRequestEvent_owner" )) (defentry set-XSelectionRequestEvent-owner (fixnum fixnum) ( void "set_XSelectionRequestEvent_owner" )) (defentry XSelectionRequestEvent-display (fixnum) ( fixnum "XSelectionRequestEvent_display" )) (defentry set-XSelectionRequestEvent-display (fixnum fixnum) ( void "set_XSelectionRequestEvent_display" )) (defentry XSelectionRequestEvent-send_event (fixnum) ( fixnum "XSelectionRequestEvent_send_event" )) (defentry set-XSelectionRequestEvent-send_event (fixnum fixnum) ( void "set_XSelectionRequestEvent_send_event" )) (defentry XSelectionRequestEvent-serial (fixnum) ( fixnum "XSelectionRequestEvent_serial" )) (defentry set-XSelectionRequestEvent-serial (fixnum fixnum) ( void "set_XSelectionRequestEvent_serial" )) (defentry XSelectionRequestEvent-type (fixnum) ( fixnum "XSelectionRequestEvent_type" )) (defentry set-XSelectionRequestEvent-type (fixnum fixnum) ( void "set_XSelectionRequestEvent_type" )) ;;;;;; XSelectionEvent functions ;;;;;; (defentry make-XSelectionEvent () ( fixnum "make_XSelectionEvent" )) (defentry XSelectionEvent-time (fixnum) ( fixnum "XSelectionEvent_time" )) (defentry set-XSelectionEvent-time (fixnum fixnum) ( void "set_XSelectionEvent_time" )) (defentry XSelectionEvent-property (fixnum) ( fixnum "XSelectionEvent_property" )) (defentry set-XSelectionEvent-property (fixnum fixnum) ( void "set_XSelectionEvent_property" )) (defentry XSelectionEvent-target (fixnum) ( fixnum "XSelectionEvent_target" )) (defentry set-XSelectionEvent-target (fixnum fixnum) ( void "set_XSelectionEvent_target" )) (defentry XSelectionEvent-selection (fixnum) ( fixnum "XSelectionEvent_selection" )) (defentry set-XSelectionEvent-selection (fixnum fixnum) ( void "set_XSelectionEvent_selection" )) (defentry XSelectionEvent-requestor (fixnum) ( fixnum "XSelectionEvent_requestor" )) (defentry set-XSelectionEvent-requestor (fixnum fixnum) ( void "set_XSelectionEvent_requestor" )) (defentry XSelectionEvent-display (fixnum) ( fixnum "XSelectionEvent_display" )) (defentry set-XSelectionEvent-display (fixnum fixnum) ( void "set_XSelectionEvent_display" )) (defentry XSelectionEvent-send_event (fixnum) ( fixnum "XSelectionEvent_send_event" )) (defentry set-XSelectionEvent-send_event (fixnum fixnum) ( void "set_XSelectionEvent_send_event" )) (defentry XSelectionEvent-serial (fixnum) ( fixnum "XSelectionEvent_serial" )) (defentry set-XSelectionEvent-serial (fixnum fixnum) ( void "set_XSelectionEvent_serial" )) (defentry XSelectionEvent-type (fixnum) ( fixnum "XSelectionEvent_type" )) (defentry set-XSelectionEvent-type (fixnum fixnum) ( void "set_XSelectionEvent_type" )) ;;;;;; XColormapEvent functions ;;;;;; (defentry make-XColormapEvent () ( fixnum "make_XColormapEvent" )) (defentry XColormapEvent-state (fixnum) ( fixnum "XColormapEvent_state" )) (defentry set-XColormapEvent-state (fixnum fixnum) ( void "set_XColormapEvent_state" )) (defentry XColormapEvent-new (fixnum) ( fixnum "XColormapEvent_new" )) (defentry set-XColormapEvent-new (fixnum fixnum) ( void "set_XColormapEvent_new" )) (defentry XColormapEvent-colormap (fixnum) ( fixnum "XColormapEvent_colormap" )) (defentry set-XColormapEvent-colormap (fixnum fixnum) ( void "set_XColormapEvent_colormap" )) (defentry XColormapEvent-window (fixnum) ( fixnum "XColormapEvent_window" )) (defentry set-XColormapEvent-window (fixnum fixnum) ( void "set_XColormapEvent_window" )) (defentry XColormapEvent-display (fixnum) ( fixnum "XColormapEvent_display" )) (defentry set-XColormapEvent-display (fixnum fixnum) ( void "set_XColormapEvent_display" )) (defentry XColormapEvent-send_event (fixnum) ( fixnum "XColormapEvent_send_event" )) (defentry set-XColormapEvent-send_event (fixnum fixnum) ( void "set_XColormapEvent_send_event" )) (defentry XColormapEvent-serial (fixnum) ( fixnum "XColormapEvent_serial" )) (defentry set-XColormapEvent-serial (fixnum fixnum) ( void "set_XColormapEvent_serial" )) (defentry XColormapEvent-type (fixnum) ( fixnum "XColormapEvent_type" )) (defentry set-XColormapEvent-type (fixnum fixnum) ( void "set_XColormapEvent_type" )) ;;;;;; XClientMessageEvent functions ;;;;;; (defentry make-XClientMessageEvent () ( fixnum "make_XClientMessageEvent" )) (defentry XClientMessageEvent-format (fixnum) ( fixnum "XClientMessageEvent_format" )) (defentry set-XClientMessageEvent-format (fixnum fixnum) ( void "set_XClientMessageEvent_format" )) (defentry XClientMessageEvent-message_type (fixnum) ( fixnum "XClientMessageEvent_message_type" )) (defentry set-XClientMessageEvent-message_type (fixnum fixnum) ( void "set_XClientMessageEvent_message_type" )) (defentry XClientMessageEvent-window (fixnum) ( fixnum "XClientMessageEvent_window" )) (defentry set-XClientMessageEvent-window (fixnum fixnum) ( void "set_XClientMessageEvent_window" )) (defentry XClientMessageEvent-display (fixnum) ( fixnum "XClientMessageEvent_display" )) (defentry set-XClientMessageEvent-display (fixnum fixnum) ( void "set_XClientMessageEvent_display" )) (defentry XClientMessageEvent-send_event (fixnum) ( fixnum "XClientMessageEvent_send_event" )) (defentry set-XClientMessageEvent-send_event (fixnum fixnum) ( void "set_XClientMessageEvent_send_event" )) (defentry XClientMessageEvent-serial (fixnum) ( fixnum "XClientMessageEvent_serial" )) (defentry set-XClientMessageEvent-serial (fixnum fixnum) ( void "set_XClientMessageEvent_serial" )) (defentry XClientMessageEvent-type (fixnum) ( fixnum "XClientMessageEvent_type" )) (defentry set-XClientMessageEvent-type (fixnum fixnum) ( void "set_XClientMessageEvent_type" )) ;;;;;; XMappingEvent functions ;;;;;; (defentry make-XMappingEvent () ( fixnum "make_XMappingEvent" )) (defentry XMappingEvent-count (fixnum) ( fixnum "XMappingEvent_count" )) (defentry set-XMappingEvent-count (fixnum fixnum) ( void "set_XMappingEvent_count" )) (defentry XMappingEvent-first_keycode (fixnum) ( fixnum "XMappingEvent_first_keycode" )) (defentry set-XMappingEvent-first_keycode (fixnum fixnum) ( void "set_XMappingEvent_first_keycode" )) (defentry XMappingEvent-request (fixnum) ( fixnum "XMappingEvent_request" )) (defentry set-XMappingEvent-request (fixnum fixnum) ( void "set_XMappingEvent_request" )) (defentry XMappingEvent-window (fixnum) ( fixnum "XMappingEvent_window" )) (defentry set-XMappingEvent-window (fixnum fixnum) ( void "set_XMappingEvent_window" )) (defentry XMappingEvent-display (fixnum) ( fixnum "XMappingEvent_display" )) (defentry set-XMappingEvent-display (fixnum fixnum) ( void "set_XMappingEvent_display" )) (defentry XMappingEvent-send_event (fixnum) ( fixnum "XMappingEvent_send_event" )) (defentry set-XMappingEvent-send_event (fixnum fixnum) ( void "set_XMappingEvent_send_event" )) (defentry XMappingEvent-serial (fixnum) ( fixnum "XMappingEvent_serial" )) (defentry set-XMappingEvent-serial (fixnum fixnum) ( void "set_XMappingEvent_serial" )) (defentry XMappingEvent-type (fixnum) ( fixnum "XMappingEvent_type" )) (defentry set-XMappingEvent-type (fixnum fixnum) ( void "set_XMappingEvent_type" )) ;;;;;; XErrorEvent functions ;;;;;; (defentry make-XErrorEvent () ( fixnum "make_XErrorEvent" )) (defentry XErrorEvent-minor_code (fixnum) ( char "XErrorEvent_minor_code" )) (defentry set-XErrorEvent-minor_code (fixnum char) ( void "set_XErrorEvent_minor_code" )) (defentry XErrorEvent-request_code (fixnum) ( char "XErrorEvent_request_code" )) (defentry set-XErrorEvent-request_code (fixnum char) ( void "set_XErrorEvent_request_code" )) (defentry XErrorEvent-error_code (fixnum) ( char "XErrorEvent_error_code" )) (defentry set-XErrorEvent-error_code (fixnum char) ( void "set_XErrorEvent_error_code" )) (defentry XErrorEvent-serial (fixnum) ( fixnum "XErrorEvent_serial" )) (defentry set-XErrorEvent-serial (fixnum fixnum) ( void "set_XErrorEvent_serial" )) (defentry XErrorEvent-resourceid (fixnum) ( fixnum "XErrorEvent_resourceid" )) (defentry set-XErrorEvent-resourceid (fixnum fixnum) ( void "set_XErrorEvent_resourceid" )) (defentry XErrorEvent-display (fixnum) ( fixnum "XErrorEvent_display" )) (defentry set-XErrorEvent-display (fixnum fixnum) ( void "set_XErrorEvent_display" )) (defentry XErrorEvent-type (fixnum) ( fixnum "XErrorEvent_type" )) (defentry set-XErrorEvent-type (fixnum fixnum) ( void "set_XErrorEvent_type" )) ;;;;;; XAnyEvent functions ;;;;;; (defentry make-XAnyEvent () ( fixnum "make_XAnyEvent" )) (defentry XAnyEvent-window (fixnum) ( fixnum "XAnyEvent_window" )) (defentry set-XAnyEvent-window (fixnum fixnum) ( void "set_XAnyEvent_window" )) (defentry XAnyEvent-display (fixnum) ( fixnum "XAnyEvent_display" )) (defentry set-XAnyEvent-display (fixnum fixnum) ( void "set_XAnyEvent_display" )) (defentry XAnyEvent-send_event (fixnum) ( fixnum "XAnyEvent_send_event" )) (defentry set-XAnyEvent-send_event (fixnum fixnum) ( void "set_XAnyEvent_send_event" )) (defentry XAnyEvent-serial (fixnum) ( fixnum "XAnyEvent_serial" )) (defentry set-XAnyEvent-serial (fixnum fixnum) ( void "set_XAnyEvent_serial" )) (defentry XAnyEvent-type (fixnum) ( fixnum "XAnyEvent_type" )) (defentry set-XAnyEvent-type (fixnum fixnum) ( void "set_XAnyEvent_type" )) ;;;;;; XEvent functions ;;;;;; (defentry make-XEvent () ( fixnum "make_XEvent" )) ;;(defentry XEvent-pad[24] (fixnum) ( fixnum "XEvent_pad[24]" )) ;;(defentry set-XEvent-pad[24] (fixnum fixnum) ( void "set_XEvent_pad[24]" )) ;;(defentry XEvent-xkeymap (fixnum) ( XKeymapEvent "XEvent_xkeymap" )) ;;(defentry set-XEvent-xkeymap (fixnum XKeymapEvent) ( void "set_XEvent_xkeymap" )) ;;(defentry XEvent-xerror (fixnum) ( XErrorEvent "XEvent_xerror" )) ;;(defentry set-XEvent-xerror (fixnum XErrorEvent) ( void "set_XEvent_xerror" )) ;;(defentry XEvent-xmapping (fixnum) ( XMappingEvent "XEvent_xmapping" )) ;;(defentry set-XEvent-xmapping (fixnum XMappingEvent) ( void "set_XEvent_xmapping" )) ;;(defentry XEvent-xclient (fixnum) ( XClientMessageEvent "XEvent_xclient" )) ;;(defentry set-XEvent-xclient (fixnum XClientMessageEvent) ( void "set_XEvent_xclient" )) ;;(defentry XEvent-xcolormap (fixnum) ( XColormapEvent "XEvent_xcolormap" )) ;;(defentry set-XEvent-xcolormap (fixnum XColormapEvent) ( void "set_XEvent_xcolormap" )) ;;(defentry XEvent-xselection (fixnum) ( XSelectionEvent "XEvent_xselection" )) ;;(defentry set-XEvent-xselection (fixnum XSelectionEvent) ( void "set_XEvent_xselection" )) ;;(defentry XEvent-xselectionrequest (fixnum) ( XSelectionRequestEvent "XEvent_xselectionrequest" )) ;;(defentry set-XEvent-xselectionrequest (fixnum XSelectionRequestEvent) ( void "set_XEvent_xselectionrequest" )) ;;(defentry XEvent-xselectionclear (fixnum) ( XSelectionClearEvent "XEvent_xselectionclear" )) ;;(defentry set-XEvent-xselectionclear (fixnum XSelectionClearEvent) ( void "set_XEvent_xselectionclear" )) ;;(defentry XEvent-xproperty (fixnum) ( XPropertyEvent "XEvent_xproperty" )) ;;(defentry set-XEvent-xproperty (fixnum XPropertyEvent) ( void "set_XEvent_xproperty" )) ;;(defentry XEvent-xcirculaterequest (fixnum) ( XCirculateRequestEvent "XEvent_xcirculaterequest" )) ;;(defentry set-XEvent-xcirculaterequest (fixnum XCirculateRequestEvent) ( void "set_XEvent_xcirculaterequest" )) ;;(defentry XEvent-xcirculate (fixnum) ( XCirculateEvent "XEvent_xcirculate" )) ;;(defentry set-XEvent-xcirculate (fixnum XCirculateEvent) ( void "set_XEvent_xcirculate" )) ;;(defentry XEvent-xconfigurerequest (fixnum) ( XConfigureRequestEvent "XEvent_xconfigurerequest" )) ;;(defentry set-XEvent-xconfigurerequest (fixnum XConfigureRequestEvent) ( void "set_XEvent_xconfigurerequest" )) ;;(defentry XEvent-xresizerequest (fixnum) ( XResizeRequestEvent "XEvent_xresizerequest" )) ;;(defentry set-XEvent-xresizerequest (fixnum XResizeRequestEvent) ( void "set_XEvent_xresizerequest" )) ;;(defentry XEvent-xgravity (fixnum) ( XGravityEvent "XEvent_xgravity" )) ;;(defentry set-XEvent-xgravity (fixnum XGravityEvent) ( void "set_XEvent_xgravity" )) ;;(defentry XEvent-xconfigure (fixnum) ( XConfigureEvent "XEvent_xconfigure" )) ;;(defentry set-XEvent-xconfigure (fixnum XConfigureEvent) ( void "set_XEvent_xconfigure" )) ;;(defentry XEvent-xreparent (fixnum) ( XReparentEvent "XEvent_xreparent" )) ;;(defentry set-XEvent-xreparent (fixnum XReparentEvent) ( void "set_XEvent_xreparent" )) ;;(defentry XEvent-xmaprequest (fixnum) ( XMapRequestEvent "XEvent_xmaprequest" )) ;;(defentry set-XEvent-xmaprequest (fixnum XMapRequestEvent) ( void "set_XEvent_xmaprequest" )) ;;(defentry XEvent-xmap (fixnum) ( XMapEvent "XEvent_xmap" )) ;;(defentry set-XEvent-xmap (fixnum XMapEvent) ( void "set_XEvent_xmap" )) ;;(defentry XEvent-xunmap (fixnum) ( XUnmapEvent "XEvent_xunmap" )) ;;(defentry set-XEvent-xunmap (fixnum XUnmapEvent) ( void "set_XEvent_xunmap" )) ;;(defentry XEvent-xdestroywindow (fixnum) ( XDestroyWindowEvent "XEvent_xdestroywindow" )) ;;(defentry set-XEvent-xdestroywindow (fixnum XDestroyWindowEvent) ( void "set_XEvent_xdestroywindow" )) ;;(defentry XEvent-xcreatewindow (fixnum) ( XCreateWindowEvent "XEvent_xcreatewindow" )) ;;(defentry set-XEvent-xcreatewindow (fixnum XCreateWindowEvent) ( void "set_XEvent_xcreatewindow" )) ;;(defentry XEvent-xvisibility (fixnum) ( XVisibilityEvent "XEvent_xvisibility" )) ;;(defentry set-XEvent-xvisibility (fixnum XVisibilityEvent) ( void "set_XEvent_xvisibility" )) ;;(defentry XEvent-xnoexpose (fixnum) ( XNoExposeEvent "XEvent_xnoexpose" )) ;;(defentry set-XEvent-xnoexpose (fixnum XNoExposeEvent) ( void "set_XEvent_xnoexpose" )) ;;(defentry XEvent-xgraphicsexpose (fixnum) ( XGraphicsExposeEvent "XEvent_xgraphicsexpose" )) ;;(defentry set-XEvent-xgraphicsexpose (fixnum XGraphicsExposeEvent) ( void "set_XEvent_xgraphicsexpose" )) ;;(defentry XEvent-xexpose (fixnum) ( XExposeEvent "XEvent_xexpose" )) ;;(defentry set-XEvent-xexpose (fixnum XExposeEvent) ( void "set_XEvent_xexpose" )) ;;(defentry XEvent-xfocus (fixnum) ( XFocusChangeEvent "XEvent_xfocus" )) ;;(defentry set-XEvent-xfocus (fixnum XFocusChangeEvent) ( void "set_XEvent_xfocus" )) ;;(defentry XEvent-xcrossing (fixnum) ( XCrossingEvent "XEvent_xcrossing" )) ;;(defentry set-XEvent-xcrossing (fixnum XCrossingEvent) ( void "set_XEvent_xcrossing" )) ;;(defentry XEvent-xmotion (fixnum) ( XMotionEvent "XEvent_xmotion" )) ;;(defentry set-XEvent-xmotion (fixnum XMotionEvent) ( void "set_XEvent_xmotion" )) ;;(defentry XEvent-xbutton (fixnum) ( XButtonEvent "XEvent_xbutton" )) ;;(defentry set-XEvent-xbutton (fixnum XButtonEvent) ( void "set_XEvent_xbutton" )) ;;(defentry XEvent-xkey (fixnum) ( XKeyEvent "XEvent_xkey" )) ;;(defentry set-XEvent-xkey (fixnum XKeyEvent) ( void "set_XEvent_xkey" )) ;;(defentry XEvent-xany (fixnum) ( XAnyEvent "XEvent_xany" )) ;;(defentry set-XEvent-xany (fixnum XAnyEvent) ( void "set_XEvent_xany" )) ;;(defentry XEvent-type (fixnum) ( fixnum "XEvent_type" )) ;;(defentry set-XEvent-type (fixnum fixnum) ( void "set_XEvent_type" )) gcl-2.6.14/xgcl-2/gcl_sysinit.lsp0000644000175000017500000000452714360276512015146 0ustar cammcamm; Copyright (c) 1994 William F. Schelter ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. (in-package :XLIB) ;; This file is used for defining the C function user_init, to run the ;; initialization code from a list of files in *files*. These files ;; should have been compiled with (compile-file "foo.lsp" :system-p t) ;; and have been linked into the image. It presumes the .o files ;; are in the current directory, and the files *files* are in the proper ;; order to be loaded. ;;define a function USER::USER-INIT, which will run the init code for a set ;;of files which are linked into an image. (clines "#define init_or_load(fn,file) do {extern void fn(void); gcl_init_or_load1(fn,file);} while(0)") (clines "static void") (clines "load1(char *x) {") (clines "printf(\"loading %s\\n\",x);") (clines "fflush(stdout);") (clines "load(x);") (clines "}") #. (let ((files *files*)) (declare (special object-path)) (with-open-file (st "maxobjs" :direction :output) `(progn (clines "object user_init() {") (clines "load1(\"../xgcl-2/sysdef.lisp\");") ,@(sloop::sloop for x in files for f = (substitute #\_ #\- x) for ff = (namestring (merge-pathnames (make-pathname :type "o") (pathname (format nil "~a.lsp" x)))) do (princ ff st) (princ " " st) collect `(clines ,(Format nil "init_or_load(init_~a,\"~a\");" (string-downcase f) ff)) finally (terpri st) )) )) (clines "return Cnil;}") ;; invoke this to initialize maxima. ;; make this if you dont want the invocation done automatically. ;(defentry user::user-init () "user_init") gcl-2.6.14/xgcl-2/gcl_menu-set.lsp0000644000175000017500000004407514360276512015203 0ustar cammcamm; menu-set.lsp Gordon S. Novak Jr. ; 17 Jan 08 ; Functions to handle a set of menus within a single window. ; Copyright (c) 2008 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu ; 12 Aug 96; 04 Nov 97; 28 Feb 02; 05 Jan 04; 03 Mar 04; 30 Jul 04; 02 Aug 04 ; 27 Jan 06 ; (wtesta) ; in dwtest.lsp, to create window myw ; (setq ms (menu-set-create myw nil)) ; (menu-set-add-menu ms 'flag1 nil "Colors" '(red white blue)) ; position w/mouse ; (menu-set-add-menu ms 'Test1 nil "Choice" '(yes no)) ; position w/mouse ; do (wteste) to create the square picmenu ; (menu-set-add-picmenu ms 'square1 nil "Square" mypms) ; following is alternative -- window is too small to hold both square and cone ; create cone with draw ; (menu-set-add-picmenu ms 'cone1 'cone "Cone" 'cone) ; (menu-set-add-component ms 'nand) ; load draw-gates for nand and cone ; ; (menu-set-draw ms) ; (menu-set-select ms) ; click a menu or background ; (setq mc (menu-conns-create ms)) ; make a menu-conns object from menu set ; (menu-conns-add-conn mc) ; click two buttons/menu items ; repeat above as desired ; (menu-conns-move mc) ; click a menu and move it (glispobjects (menu-set (listobject (window window) (menu-items (listof menu-set-item)) (commandfn anything)) msg ((draw menu-set-draw) (select menu-set-select) (named-menu menu-set-named-menu) (named-item menu-set-named-item) (add-menu menu-set-add-menu) (add-picmenu menu-set-add-picmenu) (add-component menu-set-add-component) (add-barmenu menu-set-add-barmenu) (add-item menu-set-add-item) (find-item menu-set-find-item) (delete-item menu-set-delete-item) (remove-items menu-set-remove-items) (item-position menu-set-item-position) (itemp menu-set-itemp) (adjust menu-set-adjust) (move menu-set-move) (draw-conn menu-set-draw-conn) ) ) (menu-set-item (list (menu-name symbol) (sym anything) ; extra info (menu menu-set-menu) ) prop ((left ((parent-offset-x menu))) (bottom ((parent-offset-y menu))) (width ((picture-width menu))) (height ((picture-height menu))) ) supers (region) ) (menu-set-menu (transparent menu) ; menu or picmenu msg ((draw menu-mdraw)) ) (menu-port (list (port symbol) (menu-name symbol)) ) (menu-selection (list (port symbol) (menu-name symbol) (button integer)) ) (menu-set-conn (list (from menu-port) (to menu-port))) (menu-conns (listobject (menu-set menu-set) (connections (listof menu-set-conn))) prop ((window ((window (menu-set self))))) msg ((draw menu-conns-draw) (redraw menu-conns-redraw) (move menu-conns-move) (add-conn menu-conns-add-conn) (add-item menu-conns-add-item open t) (find-conn menu-conns-find-conn) (find-item menu-conns-find-item) (delete-item menu-conns-delete-item) (delete-conn menu-conns-delete-conn) (remove-items menu-conns-remove-items) (find-conns menu-conns-find-conns) (connected-ports menu-conns-connected-ports) (new-conn menu-conns-new-conn) (named-menu menu-conns-named-menu) (named-item menu-conns-named-item) ) ) ) ; glispobjects ; 04 Sep 92; 09 Feb 94; 12 Oct 94 (gldefun menu-set-create ((w window) &optional fn) (a menu-set with window = w commandfn = fn)) ; 05 Sep 92; 09 Sep 92; 10 Sep 92; 02 Nov 92; 05 May 93; 07 May 93; 04 Aug 93 ; 03 Jan 94; 07 Jan 94; 03 May 94; 05 Jan 95; 11 Apr 95; 03 Nov 97; 05 Jan 04 ; Select from multiple menu-like regions within a window. ; Result is a menu-selection, i.e., a list of the value selected, ; menu name, and button used, ; e.g., (QUIT COMMAND 1) for selecting the QUIT item from the COMMAND menu. ; A click outside any menu returns ((x y) BACKGROUND button-code). ; enabled, if specified, is a list of names of menus enabled for selection. (gldefun menu-set-select ((ms menu-set) &optional (redraw boolean) (enabled (listof symbol))) (result menu-selection) (let ((res menu-selection) resb (itm menu-set-item) (sel symbol) lastx lasty) (if redraw (draw ms)) (while ~ (or res resb) (setq itm (window-track-mouse (window ms) #'(lambda (x y code) (or (and (> code 0) (setq lastx x) (setq lasty y) code) (that menu-item with (contains-xy (that menu-item) x y)))))) (if (numberp itm) (resb = (a menu-selection with port (a vector with x = lastx y = lasty) menu-name 'background button itm)) (if (or (atom enabled) (member (menu-name itm) enabled)) (progn (sel = (menu-mselect (menu itm) (eq enabled t))) (if sel (res = (a menu-selection with menu-name (menu-name itm) port sel button *window-menu-code*)) (if (and *window-menu-code* (*window-menu-code* <> 0)) (res = (a menu-selection with menu-name (menu-name itm) port nil button *window-menu-code*)))) ) ) )) (force-output (window ms)) (or res resb) )) ; 05 Sep 92; 25 Sep 92; 29 Sep 92 ; Add a menu to a menu set. ; name is the name of the menu. sym is extra info such as data type. (gldefun menu-set-add-menu ((ms menu-set) (name symbol) (sym symbol) (title string) items &optional (offset vector)) (let (menu) (menu = (menu-create items title (window ms) (x offset) (y offset) t t)) (init menu) (if ~ offset (offset = (get-box-position (window ms) (picture-width menu) (picture-height menu)))) ((parent-offset-x menu) = (x offset)) ((parent-offset-y menu) = (y offset)) (add-item ms name sym menu) )) ; 25 Sep 92; 29 Sep 92; 07 May 93 (gldefun menu-set-add-item ((ms menu-set) (name symbol) (sym symbol) (menu menu)) ((menu-items ms) _+ (a menu-set-item with menu-name = name sym = sym menu = menu)) ) ; 25 Sep 92 (gldefun menu-set-remove-items ((ms menu-set)) ((menu-items ms) = nil) ) ; 06 Sep 92; 08 Sep 92; 14 Sep 92; 25 Sep 92; 29 Sep 92; 05 Jan 04; 23 Jun 04 (gldefun menu-set-add-picmenu ((ms menu-set) (name symbol) (sym symbol) (title string) (spec picmenu-spec) &optional (offset vector) (nobox boolean)) (let (menu maxwidth maxheight) (if (and spec (symbolp spec)) (spec = (get spec 'picmenu-spec)) ) (menu = (picmenu-create-from-spec spec title (window ms) (x offset) (y offset) t t (not nobox))) (maxwidth = (max (if title ((* 9 (length title)) + 6) 0) (drawing-width spec))) (maxheight = (if title 15 0) + (drawing-height spec)) (if ~ offset (offset = (get-box-position (window ms) maxwidth maxheight))) ((parent-offset-x menu) = (x offset)) ((parent-offset-y menu) = (y offset)) (add-item ms name sym menu) )) ; 11 Oct 93 (gldefun menu-set-add-component ((ms menu-set) (name symbol) &optional (offset vector)) (menu-set-add-picmenu ms (menu-set-name name) name nil name offset t)) ; 03 Jan 94; 05 Jan 04 ; Add a barmenu to a menu set. (gldefun menu-set-add-barmenu ((ms menu-set) (name symbol) (sym symbol) (menu barmenu) (title string) &optional (offset vector)) (let () (init menu) (if ~ offset (offset = (get-box-position (window ms) (picture-width menu) (picture-height menu)))) ((parent-offset-x menu) = (x offset)) ((parent-offset-y menu) = (y offset)) (add-item ms name sym menu) )) ; 11 Oct 93 (gldefun menu-set-name ((nm symbol)) (result symbol) (intern (symbol-name (gensym (symbol-name nm)))) ) ; 29 Sep 92; 07 May 93; 28 Feb 02 (gldefun menu-set-named-item ((ms menu-set) (name symbol)) (result menu-set-item) (that menu-item with (menu-name (that menu-item)) == name) ) ; 08 Sep 92; 29 Sep 92 (gldefun menu-set-named-menu ((ms menu-set) (name symbol)) (result menu-set-menu) (menu (named-item ms name))) ; 17 Jan 08 (gldefun menu-set-itemp ((ms menu-set) (name symbol) (itemname symbol)) (let ((thismenu (named-menu ms name))) (if thismenu is a menu (some #'(lambda (x) (or (eq x itemname) (and (consp x) (eq (car x) itemname)))) (items thismenu)) (if thismenu is a picmenu (assoc itemname (buttons thismenu)) ) ) )) ; 30 Jul 04 (gldefun menu-conns-named-item ((mc menu-conns) (name symbol)) (result menu-set-item) (named-item (menu-set mc) name) ) ; 01 Feb 94 (gldefun menu-conns-named-menu ((mc menu-conns) (name symbol)) (result menu-set-menu) (named-menu (menu-set mc) name) ) ; 29 Apr 93; 30 Apr 93; 05 Jan 04 ; Find the item at specified position, if any (gldefun menu-set-find-item ((ms menu-set) (pos vector)) (result menu-set-item) (let (mitem) (for mi in (menu-items ms) do (if (contains? (menu mi) pos) (mitem = mi))) mitem)) ; 29 Apr 93 ; Delete an item (gldefun menu-set-delete-item ((ms menu-set) (mi menu-set-item)) ((menu-items ms) _- mi)) ; 08 Sep 92; 10 Sep 92; 05 May 93; 06 May 93; 07 May 93 (gldefun menu-set-move ((ms menu-set)) (let (sel m) (sel = (menu-set-select ms nil t)) (m = (named-menu ms (menu-name sel))) (menu-reposition m) )) ; 10 Sep 92; 05 Jan 94; 06 Jan 94; 20 Apr 95; 12 Aug 96 ; Draw either a menu or picmenu (gldefun menu-mdraw (m) (case (first m) (menu (menu-draw m)) (picmenu (picmenu-draw m)) (barmenu (barmenu-draw m)) (textmenu (textmenu-draw m)) (editmenu (editmenu-draw m)) (t (glsend m draw)) ) ) ; 10 Sep 92; 29 Sep 92; 05 May 93; 03 Jan 94; 06 Jan 94; 20 Apr 95; 21 Apr 95 ; 12 Aug 96 ; Select from either a menu or picmenu (gldefun menu-mselect (m &optional anyclick) (case (first m) (menu (menu-select m t)) (picmenu (picmenu-select m t anyclick)) (barmenu (barmenu-select m)) (textmenu (textmenu-select m t)) (editmenu (editmenu-select m t)) (t (glsend m select)) ) ) ; 10 Sep 92; 06 Jan 94 ; Get item position from either a menu or picmenu; 20 Apr 95 (gldefun menu-mitem-position (m name loc) (case (first m) (menu (menu-item-position m name loc)) (picmenu (picmenu-item-position m name loc)) (t (glsend m item-position name loc)) ) ) ; 05 Sep 92; 08 Sep 92 (gldefun menu-set-draw ((ms menu-set)) (let () (open (window ms)) (for item in (menu-items ms) do (draw (menu item))) )) ; 08 Sep 92; 28 Sep 92; 07 May 93; 25 Jan 94 (gldefun menu-set-item-position ((ms menu-set) (desc menu-port) &optional (loc symbol)) (result vector) (let (m) (m = (named-menu ms (menu-name desc))) (or (menu-mitem-position m (port desc) loc) (menu-mitem-position m nil loc)) )) ; header if it cannot be found ; 08 Sep 92; 05 Jan 04 (gldefun menu-set-draw-conn ((ms menu-set) (conn menu-set-conn)) (let (pa pb tmp (desca (from conn)) (descb (to conn))) (pa = (menu-set-item-position ms desca 'center)) (pb = (menu-set-item-position ms descb 'center)) (if ((x pa) > (x pb)) (progn (tmp = desca) (desca = descb) (descb = tmp))) (pa = (menu-set-item-position ms desca 'right)) (pb = (menu-set-item-position ms descb 'left)) (draw-circle (window ms) pa 3) (draw-line (window ms) pa pb) (draw-circle (window ms) pb 3) (force-output (window ms)) )) ; 02 Dec 93; 07 Jan 94; 05 Jan 04 (gldefun menu-set-adjust ((ms menu-set) (name symbol) (edge symbol) (from symbol) (offset integer)) (let (m fromm place) (if (m = (named-item ms name)) (progn (if from (progn (fromm = (named-item ms from)) (place = (case edge (top (bottom fromm)) (bottom (top fromm)) (left (right fromm)) (right (left fromm))))) (place = (case edge (top (height (window ms))) ((bottom left) 0) (right (width (window ms))) )) ) (case edge (top ((bottom m) = place - (height m) - offset)) (bottom ((bottom m) = place + offset)) (left ((left m) = place + offset)) (right ((left m) = place - (width m) - offset)))) ) )) ; 21 Nov 08 ; align the vector approx with the vector fixed if within tolerance (gldefun vector-snap ((fixed vector) (approx vector) &optional tolerance) (let () (or tolerance (tolerance = 10)) (if (< (abs (- (x fixed) (x approx))) tolerance) (a vector x = (x fixed) y = (y approx)) (if (< (abs (- (y fixed) (y approx))) tolerance) (a vector x = (x approx) y = (y fixed)) approx) ) )) ; 12 Oct 94; 28 Feb 02 (gldefun menu-conns-create ((ms menu-set)) (a menu-conns with menu-set = ms)) ; 08 Sep 92 (gldefun menu-conns-draw ((mc menu-conns)) (let () (draw (menu-set mc)) (for c in (connections mc) (draw-conn (menu-set mc) c)) )) ; 08 Sep 92 (gldefun menu-conns-move ((mc menu-conns)) (let () (menu-set-move (menu-set mc)) (clear (window mc)) (draw mc) )) ; 29 Apr 93 (gldefun menu-conns-redraw ((mc menu-conns)) (let () (clear (window mc)) (draw mc) )) ; 08 Sep 92; 07 May 93; 21 Oct 93; 05 Jan 95; 28 Feb 02; 05 Jan 04 (gldefun menu-conns-add-conn ((mc menu-conns)) (let (sel selb conn) (sel = (select (menu-set mc))) (if ((menu-name sel) == 'background) sel (progn (selb = (select (menu-set mc))) (if ((menu-name selb) <> 'background) (progn (conn = (a menu-set-conn with from = sel to = selb)) (draw-conn (menu-set mc) conn) ((connections mc) _+ conn))) nil) ) )) ; 02 Aug 04 (gldefun menu-conns-new-conn ((mc menu-conns) (fromname symbol) (fromport symbol) (toname symbol) (toport symbol)) (let (conn) (conn = (a menu-set-conn with from = (a menu-port with menu-name = fromname port = fromport) to = (a menu-port with menu-name = toname port = toport))) ((connections mc) _+ conn) )) ; 30 Apr 93 (gldefun menu-conns-add-item ((mc menu-conns) (name symbol) (sym symbol) (menu menu)) (add-item (menu-set mc) name sym menu)) ; 29 Apr 93; 05 Jan 04 ; Find the connection that is selected by the given point, if any. (gldefun menu-conns-find-conn ((mc menu-conns) (pt vector)) (result menu-set-conn) (let (ms ls found res pa pb tmp desca descb) (ls = (a line-segment)) (ms = (menu-set mc)) (for conn in (connections mc) when (not found) do (desca = (from conn)) (descb = (to conn)) (pa = (menu-set-item-position ms desca 'center)) (pb = (menu-set-item-position ms descb 'center)) (if ((x pa) > (x pb)) (progn (tmp = desca) (desca = descb) (descb = tmp))) ((p1 ls) = (menu-set-item-position ms desca 'right)) ((p2 ls) = (menu-set-item-position ms descb 'left)) (if (< (distance ls pt) 5) (progn (found = t) (res = conn)) )) res)) ; 29 Apr 93; 30 Apr 93 ; Find the menu item that is selected by the given point, if any. (gldefun menu-conns-find-item ((mc menu-conns) (pt vector)) (result menu-set-item) (find-item (menu-set mc) pt)) ; 29 Apr 93 ; Delete a connection (gldefun menu-conns-delete-conn ((mc menu-conns) (conn menu-set-conn)) ((connections mc) _- conn)) ; 29 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04 ; Delete a menu item and all its connections (gldefun menu-conns-delete-item ((mc menu-conns) (mi menu-set-item)) (let (ms) (ms = (menu-set mc)) (delete-item ms mi) (for conn in (connections mc) do (if (or ((menu-name (from conn)) == (menu-name mi)) ((menu-name (to conn)) == (menu-name mi))) (delete-conn mc conn))) )) ; 30 Apr 93 (gldefun menu-conns-remove-items ((mc menu-conns)) (remove-items (menu-set mc)) ((connections mc) = nil)) ; 30 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04 ; find all ports of a given named menu that are connected to something (gldefun menu-conns-connected-ports ((mc menu-conns) (boxname symbol)) (let (ports) (for conn in (connections mc) do (if (boxname == (menu-name (to conn))) (pushnew (port (to conn)) ports) (if (boxname == (menu-name (from conn))) (pushnew (port (from conn)) ports)))) ports)) ; 30 Apr 93; 07 May 93; 28 Feb 02 ; Find connections of a given port of a named box (gldefun menu-conns-find-conns ((mc menu-conns) (boxname symbol) (port symbol)) (result (listof menu-port)) (let (res) (for conn in (connections mc) do (if (and (boxname == (menu-name (to conn))) (port == (port (to conn)))) (res _+ (from conn))) (if (and (boxname == (menu-name (from conn))) (port == (port (from conn)))) (res _+ (to conn))) ) res)) ; 03 May 94 ; Compile menu-set.lsp into a plain Lisp file (defun compile-menu-set () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp") '("glisp/menu-set.lsp") ; translated files "glisp/menu-settrans.lsp" ; output file "glisp/menu-set-header.lsp") ; header file (compile-file "glisp/menu-settrans.lsp") ) ; Compile menu-set.lsp into a plain Lisp file for XGCL distribution (defun compile-menu-setb () (glcompfiles *directory* '("glisp/vector.lsp" ; auxiliary files "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/menu-set.lsp") ; translated files "glisp/menu-settrans.lsp" ; output file "glisp/menu-set-header.lsp") ; header file ) gcl-2.6.14/xgcl-2/gcl_dispatch-events.lsp0000644000175000017500000000330114360276512016532 0ustar cammcamm(in-package :XLIB) ; dispatch-events.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;have to make each type have it's own eventlist ;;and eventmask (defun dispatch-events () (setq *exit* nil) (mapcar #'(lambda (x) (Xsync x 1)) *display-list*) (do ((window nil) (call-back-fn nil) (type nil)) (*exit*) (dolist (a-display *display-list*) (unless (= (XPending a-display) 0) (XNextEvent a-display *default-event*) (setq type (XAnyEvent-type *default-event*)) (setq window (gethash (XAnyEvent-window *default-event*) *window-table*)) (setq call-back-fns (rest (assoc type (slot-value window 'eventlist)))) (if call-back-fns (dolist (call-back-fn call-back-fns) (eval `(,call-back-fn ',window)))))))) gcl-2.6.14/xgcl-2/gcl_XAtom.lsp0000644000175000017500000000654114360276512014472 0ustar cammcamm(in-package :XLIB) ; XAtom.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;; THIS IS A GENERATED FILE ;; ;; Do not change! Changing this file implies a protocol change! (defconstant XA_PRIMARY 1) (defconstant XA_SECONDARY 2) (defconstant XA_ARC 3) (defconstant XA_ATOM 4) (defconstant XA_BITMAP 5) (defconstant XA_CARDINAL 6) (defconstant XA_COLORMAP 7) (defconstant XA_CURSOR 8) (defconstant XA_CUT_BUFFER0 9) (defconstant XA_CUT_BUFFER1 10) (defconstant XA_CUT_BUFFER2 11) (defconstant XA_CUT_BUFFER3 12) (defconstant XA_CUT_BUFFER4 13) (defconstant XA_CUT_BUFFER5 14) (defconstant XA_CUT_BUFFER6 15) (defconstant XA_CUT_BUFFER7 16) (defconstant XA_DRAWABLE 17) (defconstant XA_FONT 18) (defconstant XA_INTEGER 19) (defconstant XA_PIXMAP 20) (defconstant XA_POINT 21) (defconstant XA_RECTANGLE 22) (defconstant XA_RESOURCE_MANAGER 23) (defconstant XA_RGB_COLOR_MAP 24) (defconstant XA_RGB_BEST_MAP 25) (defconstant XA_RGB_BLUE_MAP 26) (defconstant XA_RGB_DEFAULT_MAP 27) (defconstant XA_RGB_GRAY_MAP 28) (defconstant XA_RGB_GREEN_MAP 29) (defconstant XA_RGB_RED_MAP 30) (defconstant XA_STRING 31) (defconstant XA_VISUALID 32) (defconstant XA_WINDOW 33) (defconstant XA_WM_COMMAND 34) (defconstant XA_WM_HINTS 35) (defconstant XA_WM_CLIENT_MACHINE 36) (defconstant XA_WM_ICON_NAME 37) (defconstant XA_WM_ICON_SIZE 38) (defconstant XA_WM_NAME 39) (defconstant XA_WM_NORMAL_HINTS 40) (defconstant XA_WM_SIZE_HINTS 41) (defconstant XA_WM_ZOOM_HINTS 42) (defconstant XA_MIN_SPACE 43) (defconstant XA_NORM_SPACE 44) (defconstant XA_MAX_SPACE 45) (defconstant XA_END_SPACE 46) (defconstant XA_SUPERSCRIPT_X 47) (defconstant XA_SUPERSCRIPT_Y 48) (defconstant XA_SUBSCRIPT_X 49) (defconstant XA_SUBSCRIPT_Y 50) (defconstant XA_UNDERLINE_POSITION 51) (defconstant XA_UNDERLINE_THICKNESS 52) (defconstant XA_STRIKEOUT_ASCENT 53) (defconstant XA_STRIKEOUT_DESCENT 54) (defconstant XA_ITALIC_ANGLE 55) (defconstant XA_X_HEIGHT 56) (defconstant XA_QUAD_WIDTH 57) (defconstant XA_WEIGHT 58) (defconstant XA_POINT_SIZE 59) (defconstant XA_RESOLUTION 60) (defconstant XA_COPYRIGHT 61) (defconstant XA_NOTICE 62) (defconstant XA_FONT_NAME 63) (defconstant XA_FAMILY_NAME 64) (defconstant XA_FULL_NAME 65) (defconstant XA_CAP_HEIGHT 66) (defconstant XA_WM_CLASS 67) (defconstant XA_WM_TRANSIENT_FOR 68) (defconstant XA_LAST_PREDEFINED 68) gcl-2.6.14/xgcl-2/gcl_imports.lsp0000644000175000017500000012457014360276512015142 0ustar cammcamm; From: Bill Schelter imports.lsp 16 Nov 94 ; Copyright (c) 1994 William Schelter and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; The following will make ALL currently defined functions and special variables ; in the xlib package be imported into user. (in-package :XLIB) (import '(SET-XGCVALUES-SUBWINDOW_MODE SET-XGCVALUES-ARC_MODE WINDOW-SET-CURSOR MAKE-XVISUALINFO XCOLORMAPEVENT-SERIAL XGCVALUES-LINE_WIDTH WINDOW-CIRCLE-RADIUS XVISIBILITYEVENT-SERIAL XCOLOR-GREEN XTEXTPROPERTY-VALUE XCREATEREGION XGCVALUES-SUBWINDOW_MODE MAKE-XTEXTPROPERTY PICMENU-CREATE XDISPLAYKEYCODES XGCVALUES-DASHES WINDOW-CLOSE SET-XGCVALUES-BACKGROUND SET-XGCVALUES-FOREGROUND XUNIONRECTWITHREGION XTEXTITEM-DELTA XCONNECTIONNUMBER MAKE-XEXTCODES SCREENFORMAT-SCANLINE_PAD XFREEGC XARC-HEIGHT XPARSECOLOR XKEYCODETOKEYSYM XBUTTONEVENT-TIME WINDOW-SET-INVERT XPROTOCOLREVISION XPROTOCOLVERSION SET-XFOCUSCHANGEEVENT-TYPE BARMENU-INIT XSTANDARDCOLORMAP-BLUE_MULT XSTANDARDCOLORMAP-GREEN_MULT XSTANDARDCOLORMAP-RED_MULT SET-XCOLOR-FLAGS XQUERYTREE XQUERYCOLOR MAKE-DEPTH XCHANGESAVESET XCOLORMAPEVENT-COLORMAP SET-XRECTANGLE-HEIGHT XBUTTONEVENT-TYPE XALLOWEVENTS XDRAWRECTANGLES XSETFILLRULE XGCVALUES-GRAPHICS_EXPOSURES XSETFILLSTYLE XCOLOR-FLAGS SET-XKEYBOARDCONTROL-LED_MODE XSETSTATE XBUTTONEVENT-STATE XQUERYTEXTEXTENTS SCREEN-DEPTHS SCREEN-NDEPTHS MENU-INIT SET-XGCVALUES-LINE_WIDTH SCREENFORMAT-DEPTH XINSTALLCOLORMAP XARC-Y SET-XFOCUSCHANGEEVENT-SERIAL XOFFSETREGION SET-XFONTPROP-CARD32 XIMAGE-BITMAP_BIT_ORDER SET-XWMHINTS-INITIAL_STATE XSTORECOLOR MAKE-XMAPEVENT XBUTTONEVENT-SERIAL SET-XKEYBOARDCONTROL-BELL_PITCH SET-XKEYBOARDSTATE-BELL_PITCH SET-XKEYEVENT-KEYCODE SCREENFORMAT-BITS_PER_PIXEL XKEYSYMTOSTRING SET-XCLIENTMESSAGEEVENT-FORMAT SET-XRESIZEREQUESTEVENT-WIDTH WINDOW-DRAW-LINE XGCVALUES-PLANE_MASK XFILLRECTANGLES XDRAWSEGMENTS WINDOW-DRAW-CIRCLE SET-XUNMAPEVENT-TYPE XEXPOSEEVENT-HEIGHT XSTANDARDCOLORMAP-BLUE_MAX XSTANDARDCOLORMAP-GREEN_MAX XSTANDARDCOLORMAP-RED_MAX XSETWMSIZEHINTS XKEYEVENT-KEYCODE WINDOW-FORCE-OUTPUT WINDOW-UNMAP XCHARSTRUCT-WIDTH XDEFAULTCOLORMAPOFSCREEN SET-XFOCUSCHANGEEVENT-DETAIL XSEGMENT-X1 SCREEN-ROOT XEDATAOBJECT-SCREEN XSEGMENT-Y1 SET-XMODIFIERKEYMAP-MAX_KEYPERMOD SET-XGCVALUES-CLIP_Y_ORIGIN SET-XGCVALUES-CLIP_X_ORIGIN SET-XGCVALUES-TS_Y_ORIGIN SET-XGCVALUES-TS_X_ORIGIN SET-XGCVALUES-CLIP_MASK SET-XGCVALUES-PLANE_MASK XCHECKMASKEVENT XDEFAULTCOLORMAP XSEGMENT-X2 SCREEN-DISPLAY XBUTTONEVENT-SAME_SCREEN XSEGMENT-Y2 XCREATEWINDOWEVENT-BORDER_WIDTH XCREATEWINDOWEVENT-WIDTH WINDOW-CLEAR SET-SCREEN-EXT_DATA XEXPOSEEVENT-COUNT SET-XUNMAPEVENT-SERIAL SET-XCLIENTMESSAGEEVENT-SEND_EVENT XGCVALUES-TS_Y_ORIGIN XGCVALUES-TS_X_ORIGIN XDRAWARCS XDEFAULTGCOFSCREEN XIMAGE-XOFFSET SET-SCREEN-DEFAULT_GC SET-XCLIENTMESSAGEEVENT-DISPLAY XCOLORMAPEVENT-SEND_EVENT XHOSTADDRESS-FAMILY XPROPERTYEVENT-ATOM XMAPPINGEVENT-TYPE WINDOW-PRINTAT XVISIBILITYEVENT-SEND_EVENT XCOLORMAPEVENT-DISPLAY XCHANGEPROPERTY XDEFAULTDEPTHOFSCREEN XBUTTONEVENT-BUTTON XSETWINDOWATTRIBUTES-BACKING_STORE SET-XCLIENTMESSAGEEVENT-WINDOW XIMAGE-FORMAT XVISIBILITYEVENT-DISPLAY WINDOW-LEFT WINDOW-UNSET VERTEX-ARRAY XCOLORMAPEVENT-WINDOW XBUTTONEVENT-X SET-XWMHINTS-ICON_PIXMAP XEDATAOBJECT-PIXMAP_FORMAT XSELECTIONEVENT-REQUESTOR WINDOW-FONT PICMENU-INIT WINDOW-SET-FONT XEDATAOBJECT-GC XVISIBILITYEVENT-WINDOW XDELETEPROPERTY XFINDONEXTENSIONLIST XGETFONTPATH XBUTTONEVENT-Y WINDOW-CENTEROFFSET SET-XKEYBOARDSTATE-LED_MASK XEDATAOBJECT-FONT XREBINDKEYSYM SCREEN-SAVE_UNDERS SET-XGCVALUES-DASHES XMAPPINGEVENT-SERIAL SET-XARC-Y SET-XARC-X WINDOW-INPUT-STRING SET-XGCVALUES-GRAPHICS_EXPOSURES SET-XCOLOR-BLUE XDEFAULTVISUALOFSCREEN SET-XWMHINTS-FLAGS VISUAL-CLASS SET-XRESIZEREQUESTEVENT-HEIGHT WINDOW-PARENT XMATCHVISUALINFO SET-SCREEN-BACKING_STORE WINDOW-XOR-BOX-XY XFONTSTRUCT-PER_CHAR XFONTSTRUCT-DEFAULT_CHAR SET-XMODIFIERKEYMAP-MODIFIERMAP SET-XWMHINTS-WINDOW_GROUP FREE SET-XSETWINDOWATTRIBUTES-BACKING_PIXEL SET-XSETWINDOWATTRIBUTES-BORDER_PIXEL SET-XSETWINDOWATTRIBUTES-BACKGROUND_PIXEL XMOTIONEVENT-TIME XCHARSTRUCT-DESCENT XCHARSTRUCT-ASCENT SET-XNOEXPOSEEVENT-TYPE XCHARSTRUCT-ATTRIBUTES XARC-WIDTH SET-XFOCUSCHANGEEVENT-SEND_EVENT WINDOW-INIT-MOUSE-POLL XBUTTONEVENT-ROOT XBUTTONEVENT-X_ROOT XBUTTONEVENT-Y_ROOT XMOTIONEVENT-TYPE XCOPYCOLORMAPANDFREE SET-XFOCUSCHANGEEVENT-DISPLAY XBUTTONEVENT-SEND_EVENT XCREATEWINDOWEVENT-HEIGHT XSETWINDOWATTRIBUTES-COLORMAP SET-XKEYBOARDCONTROL-KEY XCHANGEWINDOWATTRIBUTES WINDOW-GCONTEXT WINDOW-DRAW-BORDER XBUTTONEVENT-DISPLAY XSELECTIONEVENT-PROPERTY XNOOP XERROREVENT-MINOR_CODE XERROREVENT-REQUEST_CODE XERROREVENT-ERROR_CODE XMOTIONEVENT-STATE XERROREVENT-RESOURCEID XFREEMODIFIERMAP SET-XFOCUSCHANGEEVENT-WINDOW XGETATOMNAME XGETICONNAME SET-XCONFIGUREEVENT-ABOVE SET-XCONFIGUREREQUESTEVENT-ABOVE WINDOW-INPUT-CHAR-FN WINDOW-PROCESS-CHAR-EVENT XSETWINDOWATTRIBUTES-BORDER_PIXMAP XSETWINDOWATTRIBUTES-BACKGROUND_PIXMAP MAKE-XMOTIONEVENT SET-XKEYBOARDCONTROL-BELL_PERCENT SET-XKEYBOARDCONTROL-KEY_CLICK_PERCENT SET-XKEYBOARDSTATE-BELL_PERCENT SET-XKEYBOARDSTATE-KEY_CLICK_PERCENT XBUTTONEVENT-WINDOW XBUTTONEVENT-SUBWINDOW SET-XWMHINTS-INPUT SET-XNOEXPOSEEVENT-SERIAL SET-XSETWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK SET-XSETWINDOWATTRIBUTES-EVENT_MASK SET-XTEXTITEM-DELTA SET-XTEXTITEM16-DELTA XSETWINDOWCOLORMAP XSETWINDOWBACKGROUNDPIXMAP XSETWINDOWBORDERPIXMAP XSETWINDOWATTRIBUTES-SAVE_UNDER XVISUALINFO-SCREEN SET-XKEYBOARDSTATE-AUTO_REPEATS XMOTIONEVENT-SERIAL XGETDEFAULT XQUERYEXTENSION DEPTH-VISUALS SET-XSELECTIONREQUESTEVENT-OWNER XMAPWINDOW WINDOW-DESTROY SET-XCONFIGUREEVENT-TYPE SET-XCONFIGUREREQUESTEVENT-TYPE XCELLSOFSCREEN SET-XWMHINTS-ICON_WINDOW XFONTSTRUCT-MAX_BOUNDS XFONTSTRUCT-MIN_BOUNDS XDEFAULTROOTWINDOW XFONTSTRUCT-DESCENT XFONTSTRUCT-ASCENT SET-XTEXTPROPERTY-VALUE WINDOW-DRAW-BOX-CORNERS SET-XUNMAPEVENT-EVENT SET-XUNMAPEVENT-SEND_EVENT WINDOW-DESTROY-SELECTED-WINDOW WINDOW-POSITIVE-Y XFREEFONTPATH XSETWINDOWBORDER SET-XSETWINDOWATTRIBUTES-BACKING_PLANES XWMHINTS-ICON_MASK SET-XSELECTIONREQUESTEVENT-REQUESTOR SET-XSELECTIONEVENT-REQUESTOR SET-XUNMAPEVENT-DISPLAY XGETWMNAME XSETWINDOWATTRIBUTES-OVERRIDE_REDIRECT WINDOW-DRAW-VECTOR-PT SET-XANYEVENT-TYPE XREMOVEFROMSAVESET XSETWMNAME XDEFAULTSCREENOFDISPLAY XMOTIONEVENT-SAME_SCREEN SET-XUNMAPEVENT-WINDOW XSETWINDOWATTRIBUTES-CURSOR SET-XCONFIGUREEVENT-SERIAL SET-XCONFIGUREREQUESTEVENT-SERIAL WINDOW-DRAW-ARROW2-XY XSELECTIONREQUESTEVENT-OWNER SET-XCOLORMAPEVENT-TYPE MAKE-XPIXMAPFORMATVALUES XNEXTREQUEST MAKE-XWMHINTS SET-XCOLORMAPEVENT-STATE XALLOCWMHINTS SET-XPOINT-X XFREECOLORMAP SET-XANYEVENT-SERIAL XSELECTIONREQUESTEVENT-REQUESTOR XMAPPINGEVENT-SEND_EVENT SET-XCONFIGUREREQUESTEVENT-DETAIL SET-SCREEN-DEPTHS SET-SCREEN-NDEPTHS XFONTPROP-CARD32 SET-SCREEN-SAVE_UNDERS XMAPPINGEVENT-DISPLAY SET-XPOINT-Y SET-XCOLORMAPEVENT-SERIAL XMOTIONEVENT-X WINDOW-DRAW-ARROWHEAD-XY SET-XHOSTADDRESS-LENGTH XMAPPINGEVENT-WINDOW XVISUALINFO-CLASS XREMOVEHOSTS SET-XFONTSTRUCT-EXT_DATA SET-XSELECTIONREQUESTEVENT-PROPERTY SET-XSELECTIONEVENT-PROPERTY XMOTIONEVENT-Y WINDOW-ERASE-BOX-XY MENU-CHOOSE XCONFIGUREEVENT-BORDER_WIDTH XCONFIGUREEVENT-WIDTH XGRABPOINTER SET-XCHARSTRUCT-WIDTH XSETFONTPATH MAKE-XWINDOWATTRIBUTES WINDOW-QUERY-POINTER XMOTIONEVENT-IS_HINT MAKE-XIMAGE SET-XCONFIGUREEVENT-X SET-XCONFIGUREREQUESTEVENT-X SET-XFONTPROP-NAME WINDOW-DRAW-DOT-XY XCOPYAREA SET-SCREEN-DISPLAY SET-XEXTCODES-MAJOR_OPCODE WINDOW-DRAW-RCBOX-XY WINDOW-DRAW-LATEX-XY WINDOW-DRAW-BOX-XY SET-XCONFIGUREEVENT-Y SET-XCONFIGUREREQUESTEVENT-Y SET-XCOLORMAPEVENT-COLORMAP MAKE-XNOEXPOSEEVENT XDRAWLINE XDRAWLINES XSCREENNUMBEROFSCREEN WINDOW-PRETTYPRINTAT XSELECTIONREQUESTEVENT-PROPERTY XWMHINTS-ICON_X SET-XNOEXPOSEEVENT-SEND_EVENT XFREECOLORS XMOTIONEVENT-ROOT XMOTIONEVENT-X_ROOT XMOTIONEVENT-Y_ROOT SET-XCONFIGUREEVENT-OVERRIDE_REDIRECT XMOTIONEVENT-SEND_EVENT SET-XNOEXPOSEEVENT-DISPLAY XWMHINTS-ICON_Y XSETWINDOWATTRIBUTES-WIN_GRAVITY XSETWINDOWATTRIBUTES-BIT_GRAVITY XBLACKPIXELOFSCREEN XRECTANGLE-X XMOTIONEVENT-DISPLAY XDESTROYWINDOW WINDOW-WFUNCTION XRECTANGLE-Y XADDPIXEL SET-SCREENFORMAT-EXT_DATA XGETPIXEL XMOTIONEVENT-WINDOW XMOTIONEVENT-SUBWINDOW SET-XEXPOSEEVENT-WIDTH XWINDOWCHANGES-STACK_MODE XPUTPIXEL XBITMAPBITORDER XDOESBACKINGSTORE XSETFUNCTION XSETICONNAME SET-XCONFIGUREREQUESTEVENT-PARENT SET-XMOTIONEVENT-TIME MAKE-XICONSIZE SET-XCONFIGUREEVENT-EVENT SET-XCONFIGUREEVENT-SEND_EVENT SET-XCONFIGUREREQUESTEVENT-SEND_EVENT SET-XMOTIONEVENT-TYPE XALLOCICONSIZE XDISPLAYNAME XFINDCONTEXT XSIZEHINTS-HEIGHT_INC XSIZEHINTS-WIDTH_INC SET-XCONFIGUREEVENT-DISPLAY SET-XCONFIGUREREQUESTEVENT-DISPLAY XKEYMAPEVENT-TYPE MAKE-VISUAL WINDOW-WAIT-UNMAP SET-XMOTIONEVENT-STATE XTIMECOORD-TIME WINDOW-PRINTAT-XY SET-XCONFIGUREEVENT-WINDOW SET-XCONFIGUREREQUESTEVENT-WINDOW SET-XGRAPHICSEXPOSEEVENT-TYPE SET-XANYEVENT-SEND_EVENT XCONFIGUREEVENT-HEIGHT SET-XANYEVENT-DISPLAY SET-XCHARSTRUCT-DESCENT SET-XCHARSTRUCT-ASCENT XEHEADOFEXTENSIONLIST SET-XCHARSTRUCT-ATTRIBUTES XSIZEHINTS-BASE_WIDTH XSIZEHINTS-MAX_WIDTH XSIZEHINTS-MIN_WIDTH XSIZEHINTS-WIDTH SET-XMOTIONEVENT-SERIAL SET-XIMAGE-BITMAP_PAD XBELL SET-XCREATEWINDOWEVENT-TYPE SET-XHOSTADDRESS-ADDRESS XLOOKUPSTRING XDISPLAYSTRING SET-XCOLORMAPEVENT-SEND_EVENT XKEYMAPEVENT-SERIAL SET-XANYEVENT-WINDOW XRESIZEREQUESTEVENT-WIDTH SET-XCOLORMAPEVENT-DISPLAY VISUAL-MAP_ENTRIES SET-XGRAPHICSEXPOSEEVENT-SERIAL XWINDOWCHANGES-BORDER_WIDTH XWINDOWCHANGES-WIDTH SET-XCOLORMAPEVENT-WINDOW SET-VISUAL-EXT_DATA ISPFKEY WINDOW-YPOSITION XWIDTHMMOFSCREEN XWINDOWATTRIBUTES-DEPTH SET-XCREATEWINDOWEVENT-SERIAL SET-XMOTIONEVENT-SAME_SCREEN XGRAPHICSEXPOSEEVENT-MINOR_CODE XGRAPHICSEXPOSEEVENT-MAJOR_CODE XCONFIGUREREQUESTEVENT-BORDER_WIDTH XCONFIGUREREQUESTEVENT-WIDTH XWINDOWATTRIBUTES-BORDER_WIDTH XWINDOWATTRIBUTES-WIDTH MAKE-XRECTANGLE XWINDOWATTRIBUTES-BACKING_PIXEL XINITEXTENSION SET-XFONTSTRUCT-DIRECTION SET-XIMAGE-DEPTH SET-XMAPEVENT-TYPE XDESTROYWINDOWEVENT-TYPE XWINDOWATTRIBUTES-VISUAL SET-XEXPOSEEVENT-HEIGHT WINDOW-PRETTYPRINTAT-XY XGRAPHICSEXPOSEEVENT-DRAWABLE SET-XIMAGE-WIDTH XDESTROYSUBWINDOWS SET-XIMAGE-BITS_PER_PIXEL XUNMAPEVENT-FROM_CONFIGURE XGETWMHINTS GET_C_STRING_2 XGETIMAGE SET-XMOTIONEVENT-X SET-XFONTSTRUCT-PROPERTIES SET-XFONTSTRUCT-N_PROPERTIES XDISPLAYWIDTHMM SET-XEXTCODES-EXTENSION XPUTIMAGE XCONFIGUREREQUESTEVENT-VALUE_MASK XDRAWSTRING16 XSUBIMAGE XWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK XWINDOWATTRIBUTES-YOUR_EVENT_MASK MAKE-XPROPERTYEVENT SET-XMAPEVENT-SERIAL XDESTROYWINDOWEVENT-SERIAL SET-XEXPOSEEVENT-COUNT SET-XMOTIONEVENT-Y XWINDOWCHANGES-X SET-XSTANDARDCOLORMAP-KILLID SET-XGRAPHICSEXPOSEEVENT-X WINDOW-GET-VECTOR-END SET-XIMAGE-BLUE_MASK SET-XIMAGE-GREEN_MASK SET-XIMAGE-RED_MASK _XQEVENT-EVENT XRECOLORCURSOR XWINDOWCHANGES-Y XWIDTHOFSCREEN XWINDOWATTRIBUTES-X SET-XVISUALINFO-VISUALID XTIMECOORD-X XSIZEHINTS-BASE_HEIGHT XSIZEHINTS-MAX_HEIGHT XSIZEHINTS-MIN_HEIGHT XSIZEHINTS-HEIGHT MENU-DISPLAY-ITEM LISP-STRING-2 SET-XGRAPHICSEXPOSEEVENT-Y XWINDOWATTRIBUTES-BACKING_PLANES MENU-FIND-ITEM-WIDTH XSTRINGTOKEYSYM _XQEVENT-NEXT SET-XCREATEWINDOWEVENT-X SET-XMOTIONEVENT-IS_HINT MAKE-XANYEVENT XWINDOWATTRIBUTES-Y SET-XGRAVITYEVENT-TYPE XTIMECOORD-Y XRESIZEREQUESTEVENT-HEIGHT XDOESSAVEUNDERS SET-XCREATEWINDOWEVENT-Y XWINDOWATTRIBUTES-ALL_EVENT_MASKS XFONTPROP-NAME XSCREENOFDISPLAY XLISTEXTENSIONS XWINDOWCHANGES-HEIGHT XGRAPHICSEXPOSEEVENT-WIDTH SET-XCREATEWINDOWEVENT-OVERRIDE_REDIRECT XPARSEGEOMETRY SET-XMOTIONEVENT-ROOT SET-XMOTIONEVENT-X_ROOT SET-XMOTIONEVENT-Y_ROOT PICMENU-DRAW-BUTTON SET-XFONTSTRUCT-ALL_CHARS_EXIST SET-XVISUALINFO-BITS_PER_RGB SET-VERTEX-ARRAY SET-XMOTIONEVENT-SEND_EVENT XCONFIGUREREQUESTEVENT-HEIGHT XWINDOWATTRIBUTES-HEIGHT XWARPPOINTER XKEYMAPEVENT-SEND_EVENT SET-XMOTIONEVENT-DISPLAY SET-XGRAVITYEVENT-SERIAL XCROSSINGEVENT-MODE SET-XMAPPINGEVENT-TYPE XKEYMAPEVENT-DISPLAY SET-_XQEVENT-EVENT XRESOURCEMANAGERSTRING SET-XIMAGE-HEIGHT SET-XGRAPHICSEXPOSEEVENT-SEND_EVENT SET-XMOTIONEVENT-WINDOW SET-XMOTIONEVENT-SUBWINDOW SET-XCREATEWINDOWEVENT-PARENT XKEYMAPEVENT-WINDOW SET-XGRAPHICSEXPOSEEVENT-DISPLAY SET-_XQEVENT-NEXT XQUERYPOINTER SET-CHAR-ARRAY ISCURSORKEY SET-XCREATEWINDOWEVENT-SEND_EVENT XSAVECONTEXT SET-XWINDOWCHANGES-STACK_MODE SET-XMAPEVENT-OVERRIDE_REDIRECT XGETCLASSHINT WINDOW-GET-ELLIPSE PICMENU-ITEM-POSITION SET-XCREATEWINDOWEVENT-DISPLAY XQUERYTEXTEXTENTS16 SET-XMAPPINGEVENT-SERIAL SET-XMAPREQUESTEVENT-TYPE SET-XIMAGE-BITMAP_UNIT SET-XVISUALINFO-DEPTH SET-XCROSSINGEVENT-TIME SET-XCREATEWINDOWEVENT-WINDOW XNOEXPOSEEVENT-TYPE SET-XVISUALINFO-COLORMAP_SIZE SET-XCROSSINGEVENT-TYPE SET-XERROREVENT-TYPE XSIZEHINTS-MAX_ASPECT_X XSIZEHINTS-MIN_ASPECT_X XGETTRANSIENTFORHINT MENU-FIND-ITEM-HEIGHT XADDHOSTS SET-XVISUALINFO-VISUAL SET-XCROSSINGEVENT-STATE XSIZEHINTS-MAX_ASPECT_Y XSIZEHINTS-MIN_ASPECT_Y SET-XMAPEVENT-EVENT SET-XMAPEVENT-SEND_EVENT SET-XMAPREQUESTEVENT-SERIAL XDESTROYWINDOWEVENT-EVENT XDESTROYWINDOWEVENT-SEND_EVENT SET-XGRAVITYEVENT-X XFOCUSCHANGEEVENT-TYPE SET-XSTANDARDCOLORMAP-COLORMAP SET-VISUAL-MAP_ENTRIES XDRAWTEXT16 WINDOW-GET-BOX-SIZE MAKE-XSELECTIONCLEAREVENT MAKE-XSELECTIONREQUESTEVENT MAKE-XSELECTIONEVENT SET-XMAPEVENT-DISPLAY XDESTROYWINDOWEVENT-DISPLAY XNOEXPOSEEVENT-SERIAL SET-XGRAVITYEVENT-Y XFETCHBUFFER XGRAPHICSEXPOSEEVENT-HEIGHT WINDOW-SET-COLOR-RGB SET-XCROSSINGEVENT-SERIAL SET-XERROREVENT-SERIAL SET-XVISUALINFO-BLUE_MASK SET-XVISUALINFO-GREEN_MASK SET-XVISUALINFO-RED_MASK SET-XWINDOWATTRIBUTES-DEPTH SET-XMAPEVENT-WINDOW XDESTROYWINDOWEVENT-WINDOW SET-XSIZEHINTS-HEIGHT_INC SET-XSIZEHINTS-WIDTH_INC XPOINTINREGION GET-ST-POINT2 SET-XWINDOWATTRIBUTES-BORDER_WIDTH SET-XWINDOWATTRIBUTES-WIDTH SET-XWINDOWCHANGES-BORDER_WIDTH SET-XWINDOWCHANGES-WIDTH SET-VISUAL-CLASS GET-C-STRING XSETWMHINTS SET-XWINDOWATTRIBUTES-BACKING_PIXEL MAKE-SCREEN SET-XEDATAOBJECT-GC XFOCUSCHANGEEVENT-SERIAL XWHITEPIXELOFSCREEN XTEXTEXTENTS SET-XWINDOWATTRIBUTES-VISUAL PICMENU-DELETE-NAMED-BUTTON XARC-ANGLE1 SET-XCROSSINGEVENT-DETAIL XGRAPHICSEXPOSEEVENT-COUNT XWRITEBITMAPFILE XMINCMAPSOFSCREEN SET-XPIXMAPFORMATVALUES-SCANLINE_PAD WINDOW-GET-REGION SET-XCROSSINGEVENT-SAME_SCREEN XMAXCMAPSOFSCREEN SET-XSIZEHINTS-BASE_WIDTH SET-XSIZEHINTS-MAX_WIDTH SET-XSIZEHINTS-MIN_WIDTH SET-XSIZEHINTS-WIDTH SET-XSEGMENT-X1 XARC-ANGLE2 MAKE-XREPARENTEVENT SET-XSEGMENT-Y1 SET-SCREEN-ROOT XFOCUSCHANGEEVENT-DETAIL XSETCLIPORIGIN SET-XSEGMENT-X2 SET-XGRAVITYEVENT-EVENT SET-XGRAVITYEVENT-SEND_EVENT XPOINT-Y XSETCLIPMASK SET-XSEGMENT-Y2 SET-XWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK SET-XWINDOWATTRIBUTES-YOUR_EVENT_MASK XFILLARCS XDISPLAYHEIGHTMM SET-XGRAVITYEVENT-DISPLAY XGETSTANDARDCOLORMAP XQUERYBESTTILE XIMAGEBYTEORDER SET-XPROPERTYEVENT-TIME SCREEN-BLACK_PIXEL SET-XGRAVITYEVENT-WINDOW SET-XPROPERTYEVENT-TYPE SET-XCROSSINGEVENT-X XICONSIZE-HEIGHT_INC SET-XWINDOWATTRIBUTES-X SET-XWINDOWCHANGES-X SET-XPIXMAPFORMATVALUES-DEPTH XGETSIZEHINTS SET-XWINDOWATTRIBUTES-BACKING_PLANES XQUERYBESTCURSOR SET-XPROPERTYEVENT-STATE SET-XCROSSINGEVENT-Y XSETWMPROPERTIES WINDOW-GET-CROSSHAIRS SET-XWINDOWATTRIBUTES-Y SET-XWINDOWCHANGES-Y SET-XMAPPINGEVENT-SEND_EVENT SET-XPIXMAPFORMATVALUES-BITS_PER_PIXEL MAKE-XCLASSHINT XCREATEBITMAPFROMDATA XALLOCCLASSHINT SET-XMAPPINGEVENT-DISPLAY SET-XWINDOWATTRIBUTES-ALL_EVENT_MASKS XQUERYBESTSTIPPLE SET-XPROPERTYEVENT-SERIAL SET-XMAPPINGEVENT-WINDOW SET-XMAPREQUESTEVENT-PARENT WINDOW-SET-FOREGROUND WINDOW-SET-BACKGROUND WINDOW-GET-POINT SET-XWINDOWATTRIBUTES-HEIGHT SET-XWINDOWCHANGES-HEIGHT XGETWMCLIENTMACHINE XGETERRORDATABASETEXT XSTRINGLISTTOTEXTPROPERTY SET-XMAPREQUESTEVENT-SEND_EVENT XGETERRORTEXT XSETCLIPRECTANGLES XGETTEXTPROPERTY XSETCLASSHINT XCROSSINGEVENT-FOCUS SET-XMAPREQUESTEVENT-DISPLAY XDRAWSTRING XNOEXPOSEEVENT-SEND_EVENT MAKE-XRESIZEREQUESTEVENT XGETMODIFIERMAPPING XDEFAULTDEPTH SET-XCROSSINGEVENT-ROOT SET-XCROSSINGEVENT-X_ROOT SET-XCROSSINGEVENT-Y_ROOT XLISTPROPERTIES SET-XEDATAOBJECT-SCREEN XSTANDARDCOLORMAP-KILLID MAKE-XEDATAOBJECT XNOEXPOSEEVENT-DISPLAY SET-XSIZEHINTS-BASE_HEIGHT SET-XSIZEHINTS-MAX_HEIGHT SET-XSIZEHINTS-MIN_HEIGHT SET-XSIZEHINTS-HEIGHT SET-XCROSSINGEVENT-SEND_EVENT MAKE-XSTANDARDCOLORMAP XALLOCSTANDARDCOLORMAP SET-XMAPREQUESTEVENT-WINDOW CALLOC XNEXTEVENT ISKEYPADKEY XSENDEVENT SET-XCROSSINGEVENT-DISPLAY SET-XERROREVENT-DISPLAY WINDOW-INVERT-AREA WINDOW-INVERTAREA XADDHOST XSETFONT XGCVALUES-CAP_STYLE XDEFAULTVISUAL XFOCUSCHANGEEVENT-SEND_EVENT XSETTRANSIENTFORHINT MENU SET-XCROSSINGEVENT-WINDOW SET-XCROSSINGEVENT-SUBWINDOW XICONSIZE-MAX_WIDTH XICONSIZE-MIN_WIDTH XENABLEACCESSCONTROL XMAPSUBWINDOWS XFOCUSCHANGEEVENT-DISPLAY WINDOW-GET-GEOMETRY XCONVERTSELECTION WINDOW-SET-LINE-WIDTH MENU-CLEAR XKEYBOARDCONTROL-BELL_DURATION XFOCUSCHANGEEVENT-WINDOW XSETACCESSCONTROL MAKE-XCHARSTRUCT XCHANGEKEYBOARDMAPPING XDISPLAYOFSCREEN XGCVALUES-FILL_RULE XAUTOREPEATOFF XEXTCODES-FIRST_ERROR XGCVALUES-FILL_STYLE SET-XEDATAOBJECT-PIXMAP_FORMAT WINDOW-FOREGROUND XSETERRORHANDLER XSTOREBUFFER XFILLARC WINDOW-BACKGROUND SET-XEDATAOBJECT-FONT XMAPREQUESTEVENT-TYPE XANYEVENT-TYPE MENU-DRAW MAKE-XCONFIGUREEVENT MAKE-XCONFIGUREREQUESTEVENT XEXTCODES-FIRST_EVENT LISP-STRING XDRAWRECTANGLE XIMAGE-BITMAP_PAD XIMAGE-BLUE_MASK MAKE-XCLIENTMESSAGEEVENT XTEXTITEM16-FONT VISUAL-BLUE_MASK XKEYBOARDSTATE-BELL_DURATION XGCVALUES-JOIN_STYLE XGETSELECTIONOWNER XTEXTITEM16-NCHARS XTEXTITEM16-CHARS XUNGRABBUTTON XMAPREQUESTEVENT-SERIAL SET-XCOLOR-PIXEL SET-XSIZEHINTS-MAX_ASPECT_X SET-XSIZEHINTS-MIN_ASPECT_X XUNGRABPOINTER SET-XPROPERTYEVENT-SEND_EVENT XSETSTANDARDCOLORMAP XSERVERVENDOR XRECTANGLE-WIDTH XCLASSHINT-RES_NAME SCREEN-MWIDTH SCREEN-WIDTH XICONSIZE-WIDTH_INC XPLANESOFSCREEN XCIRCULATESUBWINDOWSUP WINDOW-ERASE-AREA XUNGRABSERVER MAKE-XBUTTONEVENT XCHANGEKEYBOARDCONTROL SET-XSIZEHINTS-MAX_ASPECT_Y SET-XSIZEHINTS-MIN_ASPECT_Y SET-XPROPERTYEVENT-DISPLAY XKEYBOARDSTATE-GLOBAL_AUTO_REPEAT VISUAL-VISUALID XFILLRECTANGLE XHEIGHTOFSCREEN XCOLOR-PIXEL XLOADFONT XLISTFONTS XHOSTADDRESS-LENGTH XEXPOSEEVENT-TYPE XGCVALUES-LINE_STYLE WINDOW-TOP-NEG-Y MAKE-XCIRCULATEEVENT MAKE-XCIRCULATEREQUESTEVENT XTRANSLATECOORDINATES MENU-ITEM-POSITION XSETSIZEHINTS XSTANDARDCOLORMAP-COLORMAP SET-XPROPERTYEVENT-WINDOW XICONSIZE-MAX_HEIGHT XICONSIZE-MIN_HEIGHT XGETCOMMAND WINDOW-STD-LINE-ATTR WINDOW-SET-LINE-ATTR XUNINSTALLCOLORMAP MAKE-SCREENFORMAT XGRAVITYEVENT-X SCREEN-CMAP XSELECTIONCLEAREVENT-TIME XALLOCNAMEDCOLOR XHEIGHTMMOFSCREEN XQUERYFONT SCREENFORMAT-EXT_DATA SET-XFOCUSCHANGEEVENT-MODE WINDOW-SET-XCOLOR WINDOW-SET-COLOR XBITMAPPAD XCLIENTMESSAGEEVENT-MESSAGE_TYPE XCLIENTMESSAGEEVENT-TYPE XGRAVITYEVENT-Y XSELECTIONCLEAREVENT-TYPE MAKE-XDESTROYWINDOWEVENT WINDOW-SYNC XGCVALUES-TILE XCLOSEDISPLAY XGCVALUES-DASH_OFFSET XEXPOSEEVENT-SERIAL XQUERYKEYMAP WINDOW-ADJUST-BOX-SIDE VISUAL-BITS_PER_RGB WINDOW-CREATE XSETSTANDARDPROPERTIES XSELECTIONEVENT-TIME XIMAGE-GREEN_MASK XGCVALUES-FUNCTION XSETWMCLIENTMACHINE SET-XREPARENTEVENT-TYPE XSELECTIONEVENT-TYPE XTEXTPROPERTY-ENCODING XCREATECOLORMAP XSHRINKREGION SET-INT-ARRAY VISUAL-GREEN_MASK XCREATEPIXMAPFROMBITMAPDATA CHAR-ARRAY SET-XRECTANGLE-X XSETTEXTPROPERTY XCLIENTMESSAGEEVENT-SERIAL MAKE-XCOLORMAPEVENT SET-XGCVALUES-STIPPLE XFREESTRINGLIST XSELECTIONCLEAREVENT-SERIAL XSETMODIFIERMAPPING WINDOW-MOVE XCREATEPIXMAP BARMENU-SELECT SET-XGCVALUES-FILL_RULE SET-XRECTANGLE-Y WINDOW-LABEL SET-XGCVALUES-TILE SET-XGCVALUES-FILL_STYLE SET-XGCVALUES-JOIN_STYLE SET-XGCVALUES-CAP_STYLE SET-XGCVALUES-LINE_STYLE XPENDING XIMAGE-DEPTH XGCVALUES-STIPPLE BARMENU-DRAW XSYNC XIMAGE-WIDTH SET-XREPARENTEVENT-SERIAL XSELECTIONEVENT-SERIAL WINDOW-SIZE XLISTHOSTS XIMAGE-BITS_PER_PIXEL XQUERYCOLORS MAKE-XMODIFIERKEYMAP XCOLORMAPEVENT-NEW XLISTPIXMAPFORMATS XFONTSTRUCT-EXT_DATA XRMINITIALIZE XRECTANGLE-HEIGHT XKEYEVENT-TIME SCREEN-MHEIGHT SCREEN-HEIGHT SET-XRESIZEREQUESTEVENT-TYPE SET-XKEYEVENT-X SET-XCOLOR-PAD WINDOW-FREE-COLOR XEDATAOBJECT-VISUAL XMAPPINGEVENT-FIRST_KEYCODE XARC-X XPUTBACKEVENT XKEYEVENT-TYPE SET-XUNMAPEVENT-FROM_CONFIGURE XNEWMODIFIERMAP XGRAVITYEVENT-TYPE SET-XKEYEVENT-Y SET-XCOLOR-RED XRESTACKWINDOWS XWITHDRAWWINDOW XCHANGEGC MENU-REPOSITION XMAPREQUESTEVENT-PARENT MAKE-XEVENT XEXPOSEEVENT-X VERTEX-POS-X SCREEN-MIN_MAPS SCREEN-MAX_MAPS XKEYEVENT-STATE XPROPERTYEVENT-TIME WINDOW-QUERY-POINTER-B MAKE-XCROSSINGEVENT XFREEFONT XKILLCLIENT XMAPREQUESTEVENT-SEND_EVENT WINDOW-OPEN XIMAGE-RED_MASK WINDOW-SET-XOR XCHARSTRUCT-RBEARING XCHARSTRUCT-LBEARING XGETWINDOWATTRIBUTES XEXPOSEEVENT-Y XPROPERTYEVENT-TYPE VERTEX-POS-Y XSTORECOLORS XCREATEWINDOWEVENT-TYPE XMAPREQUESTEVENT-DISPLAY MENU-SELECT XSELECTIONCLEAREVENT-SELECTION MAKE-XCREATEWINDOWEVENT SET-XRESIZEREQUESTEVENT-SERIAL XDEFINECURSOR XMAPEVENT-TYPE VISUAL-RED_MASK XTEXTWIDTH XGRABBUTTON XREFRESHKEYBOARDMAPPING XHOSTADDRESS-ADDRESS XGETWMCOLORMAPWINDOWS XPROPERTYEVENT-STATE MENU-ADJUST-OFFSET XGRAVITYEVENT-SERIAL XMAPREQUESTEVENT-WINDOW XVISUALINFO-VISUALID GET-ST-POINT XGRABSERVER XANYEVENT-DISPLAY XIMAGE-BITMAP_UNIT XCLIENTMESSAGEEVENT-FORMAT XSELECTIONEVENT-SELECTION SET-XSELECTIONCLEAREVENT-TIME SET-XSELECTIONREQUESTEVENT-TIME SET-XSELECTIONEVENT-TIME MAKE-XVISIBILITYEVENT XKEYSYMTOKEYCODE SET-XREPARENTEVENT-X WINDOW-TRACK-MOUSE XPROPERTYEVENT-SERIAL XCREATEWINDOWEVENT-SERIAL XSETWINDOWBACKGROUND SET-XSELECTIONCLEAREVENT-TYPE SET-XSELECTIONREQUESTEVENT-TYPE SET-XSELECTIONEVENT-TYPE WINDOW-FONT-STRING-WIDTH XFREECURSOR XCREATEGLYPHCURSOR XSETSELECTIONOWNER SET-XWMHINTS-ICON_MASK XCREATEWINDOW WINDOW-DRAWABLE-WIDTH STRINGIFY XCLASSHINT-RES_CLASS SET-XREPARENTEVENT-Y XQLENGTH WINDOW-RESET MENU-UNBOX-ITEM SET-XNOEXPOSEEVENT-MINOR_CODE SET-XNOEXPOSEEVENT-MAJOR_CODE XEXPOSEEVENT-SEND_EVENT XANYEVENT-SERIAL XGEOMETRY XVISUALINFO-BITS_PER_RGB MAKE-XFONTPROP XGCVALUES-FONT SET-XKEYEVENT-TIME XEXPOSEEVENT-DISPLAY SET-XREPARENTEVENT-OVERRIDE_REDIRECT SET-XGCVALUES-FUNCTION XIMAGE-HEIGHT XDELETECONTEXT PICMENU-SELECT WINDOW-PAINT SET-XFONTSTRUCT-MAX_BYTE1 SET-XFONTSTRUCT-MIN_BYTE1 XSELECTIONEVENT-TARGET SET-XKEYEVENT-TYPE WINDOW-XINIT SET-XNOEXPOSEEVENT-DRAWABLE SET-XGCVALUES-DASH_OFFSET XSELECTIONREQUESTEVENT-TIME XCREATEFONTCURSOR WINDOW-DRAW-BOX XSETCOMMAND XEXPOSEEVENT-WINDOW XTEXTPROPERTY-FORMAT SET-XSELECTIONCLEAREVENT-SERIAL SET-XSELECTIONREQUESTEVENT-SERIAL SET-XSELECTIONEVENT-SERIAL XCLIENTMESSAGEEVENT-SEND_EVENT WINDOW-POLL-MOUSE PICMENU-DRAW SET-XFONTSTRUCT-MAX_CHAR_OR_BYTE2 SET-XFONTSTRUCT-MIN_CHAR_OR_BYTE2 XDESTROYIMAGE XSELECTIONCLEAREVENT-SEND_EVENT SET-XKEYEVENT-STATE XSELECTIONREQUESTEVENT-TYPE WINDOW-FONT-INFO XSETWINDOWATTRIBUTES-BACKING_PIXEL XSETWINDOWATTRIBUTES-BORDER_PIXEL XSETWINDOWATTRIBUTES-BACKGROUND_PIXEL XCLIENTMESSAGEEVENT-DISPLAY XSELECTIONCLEAREVENT-DISPLAY XCHECKTYPEDEVENT XCHECKTYPEDWINDOWEVENT SET-XBUTTONEVENT-TIME XKEYEVENT-X XCHANGEPOINTERCONTROL XSETWINDOWBORDERWIDTH SET-XDESTROYWINDOWEVENT-TYPE SET-XREPARENTEVENT-PARENT SET-XBUTTONEVENT-TYPE SET-XGCVALUES-FONT XCLIENTMESSAGEEVENT-WINDOW XSELECTIONCLEAREVENT-WINDOW SET-XSETWINDOWATTRIBUTES-BACKING_STORE XKEYEVENT-Y XTEXTPROPERTY-NITEMS SET-XREPARENTEVENT-EVENT SET-XREPARENTEVENT-SEND_EVENT SET-XKEYEVENT-SERIAL XSELECTIONEVENT-SEND_EVENT WINDOW-MENU WINDOW-INVERT-AREA-XY SET-XBUTTONEVENT-STATE XVISUALINFO-DEPTH SET-XREPARENTEVENT-DISPLAY XSELECTIONEVENT-DISPLAY WINDOW-TRACK-MOUSE-IN-REGION XINSERTMODIFIERMAPENTRY WINDOW-DRAW-CARAT XCREATEWINDOWEVENT-X XTEXTPROPERTYTOSTRINGLIST SET-SCREEN-ROOT_DEPTH XSELECTIONREQUESTEVENT-SERIAL WINDOW-STRING-WIDTH MENU-DESTROY XSETWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK XSETWINDOWATTRIBUTES-EVENT_MASK SET-XREPARENTEVENT-WINDOW XVISUALINFO-COLORMAP_SIZE SET-SCREEN-MWIDTH SET-SCREEN-WIDTH XINTERNATOM SET-XKEYBOARDCONTROL-BELL_DURATION SET-XKEYBOARDSTATE-BELL_DURATION XCREATEWINDOWEVENT-Y MENU-OFFSET SET-XDESTROYWINDOWEVENT-SERIAL SET-SCREEN-BLACK_PIXEL SET-SCREEN-WHITE_PIXEL SCREEN-ROOT_DEPTH XLISTDEPTHS XLOADQUERYFONT SET-XBUTTONEVENT-SERIAL XVISUALINFO-VISUAL XFREE WINDOW-SET-COPY SET-SCREEN-ROOT_VISUAL XTEXTITEM-NCHARS SET-XKEYEVENT-SAME_SCREEN XTEXTITEM-FONT XCREATEWINDOWEVENT-OVERRIDE_REDIRECT XTEXTITEM-CHARS SET-XSELECTIONCLEAREVENT-SELECTION SET-XSELECTIONREQUESTEVENT-SELECTION SET-XSELECTIONEVENT-SELECTION SET-XKEYBOARDSTATE-GLOBAL_AUTO_REPEAT XFONTSTRUCT-DIRECTION WINDOW-GEOMETRY XCREATEPIXMAPCURSOR XSETWINDOWATTRIBUTES-BACKING_PLANES XUNLOADFONT SCREEN-ROOT_VISUAL SET-XRESIZEREQUESTEVENT-SEND_EVENT MAKE-XUNMAPEVENT WINDOW-DRAWABLE-HEIGHT XKEYEVENT-ROOT XDELETEMODIFIERMAPENTRY XSELECTINPUT SET-XRESIZEREQUESTEVENT-DISPLAY XWMHINTS-FLAGS XGETGCVALUES XVISUALINFO-BLUE_MASK XVISUALINFO-GREEN_MASK XVISUALINFO-RED_MASK XGRAVITYEVENT-EVENT XGRAVITYEVENT-SEND_EVENT CHAR-POS WINDOW-INIT-KEYMAP SET-SCREEN-ROOT_INPUT_MASK WINDOW-DRAW-ELLIPSE-PT WINDOW-DRAW-CIRCLE-PT SET-XBUTTONEVENT-SAME_SCREEN XVISUALIDFROMVISUAL DEPTH-NVISUALS XGRAVITYEVENT-DISPLAY WINDOW-RESET-COLOR SET-XRESIZEREQUESTEVENT-WINDOW ISFUNCTIONKEY XCREATEWINDOWEVENT-PARENT WINDOW-SCREEN-HEIGHT XFONTSTRUCT-PROPERTIES XFONTSTRUCT-N_PROPERTIES MENU-BOX-ITEM SET-XSETWINDOWATTRIBUTES-COLORMAP SCREEN-ROOT_INPUT_MASK PICMENU-DESTROY XPROPERTYEVENT-SEND_EVENT XCREATEWINDOWEVENT-SEND_EVENT SET-XSELECTIONREQUESTEVENT-TARGET SET-XSELECTIONEVENT-TARGET XGRAVITYEVENT-WINDOW XSTORENAMEDCOLOR MAKE-XGCVALUES XKEYEVENT-DISPLAY XSELECTIONREQUESTEVENT-SELECTION XMAPEVENT-EVENT XPROPERTYEVENT-DISPLAY SET-XTEXTPROPERTY-ENCODING XCREATEWINDOWEVENT-DISPLAY SET-XSETWINDOWATTRIBUTES-BORDER_PIXMAP SET-XSETWINDOWATTRIBUTES-BACKGROUND_PIXMAP XGETWMNORMALHINTS SET-XCONFIGUREEVENT-BORDER_WIDTH SET-XCONFIGUREEVENT-WIDTH SET-XCONFIGUREREQUESTEVENT-BORDER_WIDTH SET-XCONFIGUREREQUESTEVENT-WIDTH XANYEVENT-SEND_EVENT XDESTROYREGION SET-XKEYMAPEVENT-TYPE SET-XARC-ANGLE1 WINDOW-MOVETO-XY XPROPERTYEVENT-WINDOW SET-XBUTTONEVENT-BUTTON XCREATEWINDOWEVENT-WINDOW XSETWMCOLORMAPWINDOWS SET-XSETWINDOWATTRIBUTES-SAVE_UNDER SET-XBUTTONEVENT-X SET-XFONTSTRUCT-FID WINDOW-ERASE-AREA-XY XMAPEVENT-DISPLAY XKEYEVENT-SERIAL XFREEFONTINFO SET-XARC-ANGLE2 XMAPPINGEVENT-COUNT SET-XCOMPOSESTATUS-CHARS_MATCHED XCHAR2B-BYTE1 SET-XSELECTIONCLEAREVENT-SEND_EVENT SET-XSELECTIONREQUESTEVENT-SEND_EVENT SET-XSELECTIONEVENT-SEND_EVENT XERROREVENT-TYPE SET-XBUTTONEVENT-Y XWMHINTS-INPUT XWMHINTS-ICON_PIXMAP SCREEN-WHITE_PIXEL XCONFIGUREEVENT-ABOVE XUNMAPSUBWINDOWS XSELECTIONREQUESTEVENT-TARGET SET-XSELECTIONCLEAREVENT-DISPLAY SET-XSELECTIONREQUESTEVENT-DISPLAY SET-XSELECTIONEVENT-DISPLAY XCHAR2B-BYTE2 SET-SCREEN-MHEIGHT SET-SCREEN-HEIGHT SET-XSETWINDOWATTRIBUTES-OVERRIDE_REDIRECT XROTATEBUFFERS SET-XKEYMAPEVENT-SERIAL XBLACKPIXEL XTEXTEXTENTS16 SET-XCONFIGUREREQUESTEVENT-VALUE_MASK SET-XWMHINTS-ICON_X MAKE-XERROREVENT COMPILE-DWINDOW WINDOW-STRING-EXTENTS SET-XSELECTIONCLEAREVENT-WINDOW XFREEFONTNAMES XFONTSTRUCT-ALL_CHARS_EXIST XMAPEVENT-SERIAL SET-XKEYEVENT-ROOT SET-XKEYEVENT-X_ROOT SET-XKEYEVENT-Y_ROOT WINDOW-RESET-GEOMETRY SET-XSETWINDOWATTRIBUTES-CURSOR XCONFIGUREEVENT-TYPE XMAPPINGEVENT-REQUEST SET-XKEYEVENT-SEND_EVENT XFLUSH WINDOW-DRAW-ARC-XY MAKE-XARC XREMOVEHOST XKEYEVENT-SAME_SCREEN WINDOW-COPY-AREA-XY SET-XWMHINTS-ICON_Y WINDOW-DRAW-ELLIPSE-XY WINDOW-DRAW-CIRCLE-XY WINDOW-DRAW-LINE-XY XERROREVENT-SERIAL SET-SCREEN-MIN_MAPS SET-SCREEN-MAX_MAPS SET-XKEYEVENT-DISPLAY MAKE-XWINDOWCHANGES XSELECTIONREQUESTEVENT-SEND_EVENT SET-DEPTH-DEPTH SET-XCHARSTRUCT-RBEARING SET-XCHARSTRUCT-LBEARING XGETWINDOWPROPERTY XANYEVENT-WINDOW XFILLPOLYGON XSELECTIONREQUESTEVENT-DISPLAY XWMHINTS-INITIAL_STATE SET-XKEYEVENT-WINDOW SET-XKEYEVENT-SUBWINDOW XDRAWPOINTS INT-POS SET-XBUTTONEVENT-ROOT SET-XBUTTONEVENT-X_ROOT SET-XBUTTONEVENT-Y_ROOT SET-XDESTROYWINDOWEVENT-EVENT SET-XDESTROYWINDOWEVENT-SEND_EVENT XICONIFYWINDOW SET-XBUTTONEVENT-SEND_EVENT XLASTKNOWNREQUESTPROCESSED SET-XDESTROYWINDOWEVENT-DISPLAY XADDTOEXTENSIONLIST XCONFIGUREEVENT-SERIAL XGETICONSIZES WINDOW-DRAW-CROSS-XY WINDOW-DRAW-CROSSHAIRS-XY XCREATESIMPLEWINDOW SET-XBUTTONEVENT-DISPLAY XRECTINREGION XREPARENTWINDOW MAKE-XFONTSTRUCT XRESIZEWINDOW SET-XDESTROYWINDOWEVENT-WINDOW WINDOW-DRAW-ARROW-XY WINDOW-WAIT-EXPOSURE MENU-SIZE XMAPEVENT-OVERRIDE_REDIRECT SET-XBUTTONEVENT-WINDOW SET-XBUTTONEVENT-SUBWINDOW SET-XGRAPHICSEXPOSEEVENT-MINOR_CODE SET-XGRAPHICSEXPOSEEVENT-MAJOR_CODE XCLEARWINDOW BARMENU-UPDATE-VALUE SET-XCONFIGUREEVENT-HEIGHT SET-XCONFIGUREREQUESTEVENT-HEIGHT SET-XCOLORMAPEVENT-NEW SET-XEXPOSEEVENT-TYPE SET-XGRAPHICSEXPOSEEVENT-DRAWABLE XMOVERESIZEWINDOW XREPARENTEVENT-TYPE XCOLOR-PAD XWMHINTS-ICON_WINDOW XGETZOOMHINTS MAKE-XFOCUSCHANGEEVENT MAKE-XTEXTITEM16 XUNIQUECONTEXT XWMHINTS-WINDOW_GROUP SET-XTEXTPROPERTY-FORMAT XWINDOWATTRIBUTES-MAP_INSTALLED XDRAWPOINT XCOPYGC SET-XEXPOSEEVENT-SERIAL MAKE-XEXPOSEEVENT SET-XIMAGE-OBDATA XCHECKWINDOWEVENT SET-XSETWINDOWATTRIBUTES-WIN_GRAVITY SET-XSETWINDOWATTRIBUTES-BIT_GRAVITY XCONFIGUREEVENT-X XCOLOR-RED XREPARENTEVENT-SERIAL XKEYEVENT-SEND_EVENT MAKE-XPOINT XTEXTWIDTH16 MAKE-XHOSTADDRESS XCONFIGUREEVENT-Y SET-XTEXTPROPERTY-NITEMS SET-SCREENFORMAT-SCANLINE_PAD WINDOW-MAP XCOMPOSESTATUS-CHARS_MATCHED MAKE-_XQEVENT SET-XTEXTITEM-FONT SET-XTEXTITEM16-FONT MAKE-XGRAPHICSEXPOSEEVENT XRESIZEREQUESTEVENT-TYPE XWMGEOMETRY XKEYEVENT-SUBWINDOW XCONFIGUREREQUESTEVENT-ABOVE SET-XKEYMAPEVENT-SEND_EVENT SET-XTEXTITEM-NCHARS SET-XTEXTITEM-CHARS SET-XTEXTITEM16-NCHARS SET-XTEXTITEM16-CHARS XMODIFIERKEYMAP-MAX_KEYPERMOD XBITMAPUNIT XCONFIGUREEVENT-OVERRIDE_REDIRECT XGETGEOMETRY XMAPEVENT-SEND_EVENT XWINDOWCHANGES-SIBLING SET-XKEYMAPEVENT-DISPLAY XPOLYGONREGION XROTATEWINDOWPROPERTIES MAKE-XGRAVITYEVENT XSETWMNORMALHINTS MENU-MOVETO-XY DOWINDOWCOM SET-XGRAPHICSEXPOSEEVENT-WIDTH SET-XIMAGE-BYTES_PER_LINE XSCREENCOUNT XALLPLANES SET-XKEYMAPEVENT-WINDOW XDISPLAYWIDTH XCONFIGUREREQUESTEVENT-TYPE SET-XFONTSTRUCT-PER_CHAR SET-XFONTSTRUCT-DEFAULT_CHAR XGETWMICONNAME XERROREVENT-DISPLAY XWINDOWATTRIBUTES-BACKING_STORE MAKE-XCHAR2B SET-VISUAL-VISUALID PICMENU-CREATE-FROM-SPEC PICMENU-CREATE-SPEC XRESIZEREQUESTEVENT-SERIAL XPIXMAPFORMATVALUES-SCANLINE_PAD XKEYEVENT-X_ROOT SET-XCREATEWINDOWEVENT-BORDER_WIDTH SET-XCREATEWINDOWEVENT-WIDTH XWINDOWATTRIBUTES-MAP_STATE SET-SCREENFORMAT-DEPTH XGETWMPROTOCOLS SET-XEXPOSEEVENT-X XKEYEVENT-Y_ROOT XCONFIGUREEVENT-EVENT XCONFIGUREEVENT-SEND_EVENT XSETTSORIGIN XKEYEVENT-WINDOW SET-SCREENFORMAT-BITS_PER_PIXEL SET-XHOSTADDRESS-FAMILY XGETKEYBOARDMAPPING XCONFIGUREEVENT-DISPLAY XREPARENTEVENT-X SET-XEXPOSEEVENT-Y ISMODIFIERKEY XCONFIGUREREQUESTEVENT-SERIAL XSETLINEATTRIBUTES XSETIOERRORHANDLER WINDOW-GET-GEOMETRY-B XREPARENTEVENT-Y XCONFIGUREEVENT-WINDOW SET-VISUAL-BITS_PER_RGB MENU-SELECT! BARMENU-CALCULATE-SIZE XLOWERWINDOW XSTORENAME XMAPEVENT-WINDOW XUNGRABKEY XPIXMAPFORMATVALUES-DEPTH SET-XSTANDARDCOLORMAP-VISUALID XREPARENTEVENT-OVERRIDE_REDIRECT SET-XFONTSTRUCT-MAX_BOUNDS SET-XFONTSTRUCT-MIN_BOUNDS XCONFIGUREREQUESTEVENT-DETAIL SET-XFONTSTRUCT-DESCENT SET-XFONTSTRUCT-ASCENT XLISTINSTALLEDCOLORMAPS XPIXMAPFORMATVALUES-BITS_PER_PIXEL XDISPLAYPLANES SET-XMAPPINGEVENT-FIRST_KEYCODE XGETINPUTFOCUS PICMENU-UNBOX-ITEM XUNMAPEVENT-TYPE XWINDOWATTRIBUTES-SCREEN XSETICONSIZES XMODIFIERKEYMAP-MODIFIERMAP XWINDOWATTRIBUTES-COLORMAP XSIZEHINTS-FLAGS XINIT SET-XEXPOSEEVENT-SEND_EVENT XCOPYPLANE XREPARENTEVENT-PARENT SET-XCOMPOSESTATUS-COMPOSE_PTR SET-XCIRCULATEEVENT-PLACE SET-XCIRCULATEREQUESTEVENT-PLACE SET-XEXPOSEEVENT-DISPLAY XGRAPHICSEXPOSEEVENT-TYPE XFREEPIXMAP XDISPLAYCELLS SET-XTIMECOORD-TIME XREPARENTEVENT-EVENT XREPARENTEVENT-SEND_EVENT MENU-CREATE XGETKEYBOARDCONTROL MENU-CALCULATE-SIZE SET-XGRAPHICSEXPOSEEVENT-HEIGHT XGETFONTPROPERTY XUNMAPEVENT-SERIAL XREPARENTEVENT-DISPLAY XDISPLAYHEIGHT SET-XEXPOSEEVENT-WINDOW XCIRCULATEEVENT-PLACE SET-XEXTCODES-FIRST_ERROR XCONFIGUREREQUESTEVENT-X XGETSUBIMAGE XLOOKUPKEYSYM XACTIVATESCREENSAVER XWINDOWATTRIBUTES-SAVE_UNDER XNOEXPOSEEVENT-MINOR_CODE XNOEXPOSEEVENT-MAJOR_CODE XRECONFIGUREWMWINDOW XLOOKUPCOLOR XSETZOOMHINTS SET-XCREATEWINDOWEVENT-HEIGHT XREPARENTEVENT-WINDOW XCONFIGUREREQUESTEVENT-Y SET-XERROREVENT-MINOR_CODE SET-XERROREVENT-REQUEST_CODE SET-XERROREVENT-ERROR_CODE SET-XERROREVENT-RESOURCEID SET-XARC-WIDTH XSETREGION SET-XVISIBILITYEVENT-TYPE XGRAPHICSEXPOSEEVENT-SERIAL XNOEXPOSEEVENT-DRAWABLE XXORREGION SET-XGRAPHICSEXPOSEEVENT-COUNT SET-XIMAGE-XOFFSET SET-XIMAGE-BITMAP_BIT_ORDER SET-XIMAGE-BYTE_ORDER XWINDOWATTRIBUTES-OVERRIDE_REDIRECT SET-XEXTCODES-FIRST_EVENT XSETCLOSEDOWNMODE XRAISEWINDOW SET-XVISIBILITYEVENT-STATE SET-XCROSSINGEVENT-MODE XREADBITMAPFILE SET-VISUAL-BLUE_MASK SET-VISUAL-GREEN_MASK SET-VISUAL-RED_MASK SET-XIMAGE-FORMAT SET-SCREEN-CMAP SET-XCIRCULATEEVENT-TYPE SET-XCIRCULATEREQUESTEVENT-TYPE XMAXREQUESTSIZE XRESIZEREQUESTEVENT-SEND_EVENT XGRABKEY SET-XWINDOWATTRIBUTES-MAP_INSTALLED SET-XSTANDARDCOLORMAP-BASE_PIXEL XWINDOWATTRIBUTES-CLASS XLISTFONTSWITHINFO XRESIZEREQUESTEVENT-DISPLAY XFOCUSCHANGEEVENT-MODE XEVENTSQUEUED SET-XVISIBILITYEVENT-SERIAL XDRAWTEXT XCIRCULATEEVENT-TYPE INT-ARRAY XMAPRAISED XCONFIGUREREQUESTEVENT-PARENT WINDOW-GET-CIRCLE XKEYBOARDCONTROL-LED XWINDOWATTRIBUTES-ROOT XRESIZEREQUESTEVENT-WINDOW XWHITEPIXEL XCREATEGC XCONFIGUREREQUESTEVENT-SEND_EVENT PICMENU-CALCULATE-SIZE XDRAWIMAGESTRING16 XCROSSINGEVENT-TIME XCONFIGUREREQUESTEVENT-DISPLAY SET-XCIRCULATEEVENT-SERIAL SET-XCIRCULATEREQUESTEVENT-SERIAL XUNMAPWINDOW XCROSSINGEVENT-TYPE SET-XCLASSHINT-RES_NAME MAKE-XKEYMAPEVENT XSETWMICONNAME MAKE-XKEYBOARDSTATE XEMPTYREGION XCLIPBOX XSETSTIPPLE XEQUALREGION XFORCESCREENSAVER XCONFIGUREREQUESTEVENT-WINDOW XCIRCULATEEVENT-SERIAL PICMENU-BUTTON-CONTAINSXY? XWINDOWEVENT WINDOW-GET-CLICK XCROSSINGEVENT-STATE XGRAPHICSEXPOSEEVENT-X XSETWMPROTOCOLS XSIZEHINTS-WIN_GRAVITY XGRAPHICSEXPOSEEVENT-Y SET-XWINDOWCHANGES-SIBLING XGETPOINTERMAPPING XFETCHNAME XCHANGEACTIVEPOINTERGRAB SET-XWINDOWATTRIBUTES-BACKING_STORE SET-XTIMECOORD-X XCROSSINGEVENT-SERIAL SET-XWINDOWATTRIBUTES-MAP_STATE SCREEN-DEFAULT_GC SET-XARC-HEIGHT XGETSCREENSAVER SET-XVISUALINFO-SCREEN SET-XTIMECOORD-Y SET-DEPTH-NVISUALS XCOMPOSESTATUS-COMPOSE_PTR MAKE-XSETWINDOWATTRIBUTES XUNMAPEVENT-EVENT XUNMAPEVENT-SEND_EVENT XMASKEVENT XPEEKEVENT XKEYBOARDCONTROL-AUTO_REPEAT_MODE XKEYBOARDCONTROL-LED_MODE XCROSSINGEVENT-DETAIL XTEXTITEM16-DELTA XUNMAPEVENT-DISPLAY XWINDOWATTRIBUTES-WIN_GRAVITY XWINDOWATTRIBUTES-BIT_GRAVITY XCONFIGUREWINDOW XSETINPUTFOCUS XCROSSINGEVENT-SAME_SCREEN MAKE-XKEYBOARDCONTROL XCIRCULATEREQUESTEVENT-PLACE XCLEARAREA XFONTSTRUCT-FID XUNMAPEVENT-WINDOW XGRAPHICSEXPOSEEVENT-SEND_EVENT XKEYBOARDCONTROL-BELL_PITCH XGETRGBCOLORMAPS XPOINT-X XSETPLANEMASK XFETCHBYTES XGRAPHICSEXPOSEEVENT-DISPLAY XSUBTRACTREGION XEXTCODES-MAJOR_OPCODE SET-XSTANDARDCOLORMAP-BLUE_MULT SET-XSTANDARDCOLORMAP-GREEN_MULT SET-XSTANDARDCOLORMAP-RED_MULT MAKE-XTIMECOORD SET-XWINDOWATTRIBUTES-SCREEN XADDTOSAVESET XGETPOINTERCONTROL WINDOW-GET-LATEX-POSITION WINDOW-GET-LINE-POSITION WINDOW-GET-ICON-POSITION WINDOW-GET-BOX-POSITION WINDOW-GET-MOUSE-POSITION SET-XWINDOWATTRIBUTES-COLORMAP XCROSSINGEVENT-X XDISABLEACCESSCONTROL SET-XMAPPINGEVENT-COUNT XGETNORMALHINTS SET-XVISIBILITYEVENT-SEND_EVENT XCROSSINGEVENT-Y XSETFOREGROUND SET-XVISIBILITYEVENT-DISPLAY SET-XICONSIZE-HEIGHT_INC SET-XICONSIZE-WIDTH_INC MAKE-XCOLOR SET-XCIRCULATEREQUESTEVENT-PARENT XMOVEWINDOW XCIRCULATEREQUESTEVENT-TYPE XALLOCCOLOR XSETDASHES XGCVALUES-ARC_MODE XDRAWARC MENU-SELECT-B SET-XVISUALINFO-CLASS SET-XWINDOWATTRIBUTES-SAVE_UNDER SET-XCIRCULATEEVENT-EVENT SET-XCIRCULATEEVENT-SEND_EVENT SET-XCIRCULATEREQUESTEVENT-SEND_EVENT SET-XVISIBILITYEVENT-WINDOW XOPENDISPLAY XQUERYBESTSIZE MAKE-XSIZEHINTS SET-XMAPPINGEVENT-REQUEST PICMENU-BOX-ITEM SET-DEPTH-VISUALS WINDOW-GET-CHARS SET-XEDATAOBJECT-VISUAL XKEYBOARDSTATE-BELL_PITCH MAKE-XSEGMENT XALLOCSIZEHINTS SET-XCIRCULATEEVENT-DISPLAY SET-XCIRCULATEREQUESTEVENT-DISPLAY XFREEEXTENSIONLIST SET-XSTANDARDCOLORMAP-BLUE_MAX SET-XSTANDARDCOLORMAP-GREEN_MAX SET-XSTANDARDCOLORMAP-RED_MAX ISMISCFUNCTIONKEY XSIZEHINTS-X XCIRCULATEEVENT-EVENT XCIRCULATEEVENT-SEND_EVENT XSTANDARDCOLORMAP-VISUALID MAKE-XTEXTITEM SET-XICONSIZE-MAX_WIDTH SET-XICONSIZE-MIN_WIDTH XGETVISUALINFO MENU-ITEM-VALUE SET-XCIRCULATEEVENT-WINDOW SET-XCIRCULATEREQUESTEVENT-WINDOW XCIRCULATEEVENT-DISPLAY XUNGRABKEYBOARD SET-XPROPERTYEVENT-ATOM XSIZEHINTS-Y SET-XWINDOWATTRIBUTES-OVERRIDE_REDIRECT MAKE-XKEYEVENT XCIRCULATEREQUESTEVENT-SERIAL XGCVALUES-BACKGROUND WINDOW-GET-CROSS WINDOW-ADJ-BOX-XY XEXTCODES-EXTENSION XCROSSINGEVENT-ROOT XCROSSINGEVENT-X_ROOT XCROSSINGEVENT-Y_ROOT XCIRCULATEEVENT-WINDOW OPEN-WINDOW XVENDORRELEASE SET-XSIZEHINTS-X SET-XSIZEHINTS-FLAGS SET-XCROSSINGEVENT-FOCUS XIMAGE-BYTES_PER_LINE XCROSSINGEVENT-SEND_EVENT SET-XCLASSHINT-RES_CLASS SCREEN-BACKING_STORE XCROSSINGEVENT-DISPLAY SET-XSIZEHINTS-Y SET-XWINDOWATTRIBUTES-CLASS XDEFAULTGC WINDOW-SET-ERASE XDISPLAYMOTIONBUFFERSIZE XUNDEFINECURSOR DEPTH-DEPTH SCREEN-EXT_DATA XRESETSCREENSAVER XSETGRAPHICSEXPOSURES SET-XWINDOWATTRIBUTES-ROOT XCROSSINGEVENT-WINDOW XCROSSINGEVENT-SUBWINDOW SET-XCHAR2B-BYTE1 XROOTWINDOW XFONTSTRUCT-MAX_BYTE1 XFONTSTRUCT-MIN_BYTE1 SET-XCHAR2B-BYTE2 XGCVALUES-FOREGROUND XADDEXTENSION XSTRINGTOCONTEXT XSETPOINTERMAPPING SET-XIMAGE-DATA XFONTSTRUCT-MAX_CHAR_OR_BYTE2 XFONTSTRUCT-MIN_CHAR_OR_BYTE2 BARMENU-CREATE XSETARCMODE XCREATEIMAGE XKEYBOARDCONTROL-KEY XDEFAULTSCREEN XSETSCREENSAVER XCIRCULATESUBWINDOWSDOWN XKEYBOARDSTATE-LED_MASK XINTERSECTREGION MAKE-XMAPREQUESTEVENT XGETWMSIZEHINTS XKEYBOARDCONTROL-BELL_PERCENT XKEYBOARDCONTROL-KEY_CLICK_PERCENT XCOLOR-BLUE XSETBACKGROUND XSTANDARDCOLORMAP-BASE_PIXEL XUNIONREGION VERTEX-POS-FLAG SET-XICONSIZE-MAX_HEIGHT SET-XICONSIZE-MIN_HEIGHT XSETSUBWINDOWMODE XGCVALUES-CLIP_Y_ORIGIN XGCVALUES-CLIP_X_ORIGIN XGCVALUES-CLIP_MASK SET-XRECTANGLE-WIDTH XSETRGBCOLORMAPS XGCONTEXTFROMGC XALLOCCOLORPLANES SET-XWINDOWATTRIBUTES-WIN_GRAVITY SET-XWINDOWATTRIBUTES-BIT_GRAVITY MAKE-XMAPPINGEVENT XDRAWIMAGESTRING MAKE-XCOMPOSESTATUS XIMAGE-OBDATA XIMAGE-DATA XCIRCULATESUBWINDOWS SET-XCLIENTMESSAGEEVENT-MESSAGE_TYPE SET-XCLIENTMESSAGEEVENT-TYPE XSTOREBYTES XCIRCULATEREQUESTEVENT-PARENT XCOLORMAPEVENT-TYPE VISUAL-EXT_DATA SET-XSIZEHINTS-WIN_GRAVITY XCIRCULATEREQUESTEVENT-SEND_EVENT XKEYBOARDSTATE-BELL_PERCENT XKEYBOARDSTATE-KEY_CLICK_PERCENT XSETNORMALHINTS XVISIBILITYEVENT-TYPE XSETTILE XAUTOREPEATON XALLOCCOLORCELLS XGETMOTIONEVENTS XCOLORMAPEVENT-STATE PICMENU-SPEC XCIRCULATEREQUESTEVENT-DISPLAY XEVENTMASKOFSCREEN SET-XKEYBOARDCONTROL-LED XGRABKEYBOARD XKEYBOARDSTATE-AUTO_REPEATS XIMAGE-BYTE_ORDER XVISIBILITYEVENT-STATE XROOTWINDOWOFSCREEN XEXPOSEEVENT-WIDTH XCIRCULATEREQUESTEVENT-WINDOW SET-XCLIENTMESSAGEEVENT-SERIAL SET-XCOLOR-GREEN window-code-char gcfunction gcforeground gcbackground GXxor GXcopy LineSolid CapButt JoinMiter XK_Shift_R XK_Shift_L XK_Control_L XK_Control_R XK_Alt_R XK_Alt_L XK_Return XK_Tab XK_BackSpace window-get-raw-char ) :user) (import '(*WINDOW-META* *TEXT-WIDTH-RETURN* *WINDOW-STRING* *WINDOW-SCREEN* *WINDOW-EVENT* *WINDOW-MENU* *WINDOW-KEYMAP* *WINDOW-SHIFT* *BORDER-WIDTH* *ROOT-X-RETURN* *POS-X* *ROOT-Y-RETURN* *DEFAULT-GC* *DEFAULT-EVENT* *GC-VALUES* *MENU-TITLE-PAD* *DEFAULT-SCREEN* *CHILD-RETURN* *DEPTH-RETURN* *WINDOW-ADD-MENU-TITLE* *OVERALL-RETURN* *WINDOW-DEFAULT-BORDER* *BORDER-WIDTH-RETURN* *DEFAULT-COLORMAP* *MOUSE-X* *MOUSE-Y* *WINDOW-INPUT-STRING-CHARWIDTH* A-WINDOW *WINDOW-DISPLAY* *WINDOW-ATTRIBUTES* *DESCENT-RETURN* *WIDTH-RETURN* *WIN-Y-RETURN* *WIN-X-RETURN* *WINDOW-KEYINIT* *BARMENU-UPDATE-VALUE-CONS* *ROOT-WINDOW* *PICMENU-NO-SELECTION* *WINDOW-CTRL* *WINDOW-XCOLOR* *DIRECTION-RETURN* *WINDOW-FONTS* *WINDOW-ATTR* *POS-Y* *X-RETURN* *Y-RETURN* *WIN-WIDTH* *MASK-RETURN* *ASCENT-RETURN* *ROOT-RETURN* *HEIGHT-RETURN* *BLACK-PIXEL* *WINDOW-DEFAULT-FONT-NAME* *DEFAULT-BG-COLOR* *DEFAULT-FG-COLOR* *DEFAULT-SIZE-HINTS* *DEFAULT-DISPLAY* *WINDOW-DEFAULT-CURSOR* *WINDOW-SHIFTKEYMAP* *WINDOW-DEFAULT-POS-X* *WINDOW-DEFAULT-POS-Y* *WINDOW-MENU-CODE* *MOUSE-WINDOW* *WINDOW-INPUT-STRING-X* *WINDOW-INPUT-STRING-Y* *WINDOW-STRING-MAX* *WINDOW-STRING-COUNT* *WINDOW-SAVE-FOREGROUND* *WINDOW-SAVE-FUNCTION* *WIN-HEIGHT* *WHITE-PIXEL* *min-keycodes-return* *max-keycodes-return* *keycodes-return* *window-shift-keys* *window-control-keys* *window-meta-keys* ) :user) (import '(courier-bold-12 8x10 9x15 top bottom left right center paint xor erase copy close move clear display-size menu window picmenu picmenu-spec barmenu picmenu-button) :user) gcl-2.6.14/xgcl-2/gcl_drawtrans.lsp0000644000175000017500000022504214360276512015446 0ustar cammcamm; 07 Jan 2010 16:40:19 EST ; drawtrans.lsp -- translation of draw.lsp Gordon S. Novak Jr. ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (IN-PACKAGE :USER) (defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) (defmacro nconc1 (lst x) `(nconc ,lst (cons ,x nil))) (defmacro glmethod (class selector) `(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) ) (SETF (GET 'MENU-SET 'GLSTRUCTURE) '((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM)) (COMMANDFN ANYTHING)) MSG ((DRAW MENU-SET-DRAW) (SELECT MENU-SET-SELECT) (NAMED-MENU MENU-SET-NAMED-MENU) (NAMED-ITEM MENU-SET-NAMED-ITEM) (ADD-MENU MENU-SET-ADD-MENU) (ADD-PICMENU MENU-SET-ADD-PICMENU) (ADD-COMPONENT MENU-SET-ADD-COMPONENT) (ADD-BARMENU MENU-SET-ADD-BARMENU) (ADD-ITEM MENU-SET-ADD-ITEM) (FIND-ITEM MENU-SET-FIND-ITEM) (DELETE-ITEM MENU-SET-DELETE-ITEM) (REMOVE-ITEMS MENU-SET-REMOVE-ITEMS) (ITEM-POSITION MENU-SET-ITEM-POSITION) (ITEMP MENU-SET-ITEMP) (ADJUST MENU-SET-ADJUST) (MOVE MENU-SET-MOVE) (DRAW-CONN MENU-SET-DRAW-CONN)))) (SETF (GET 'MENU-SET-ITEM 'GLSTRUCTURE) '((LIST (MENU-NAME SYMBOL) (SYM ANYTHING) (MENU MENU-SET-MENU)) PROP ((LEFT ((PARENT-OFFSET-X MENU))) (BOTTOM ((PARENT-OFFSET-Y MENU))) (WIDTH ((PICTURE-WIDTH MENU))) (HEIGHT ((PICTURE-HEIGHT MENU)))) SUPERS (REGION))) (SETF (GET 'MENU-SET-MENU 'GLSTRUCTURE) '((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW)))) (SETF (GET 'MENU-PORT 'GLSTRUCTURE) '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL)))) (SETF (GET 'MENU-SELECTION 'GLSTRUCTURE) '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER)))) (SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE) '((LIST (FROM MENU-PORT) (TO MENU-PORT)))) (SETF (GET 'MENU-CONNS 'GLSTRUCTURE) '((LISTOBJECT (MENU-SET MENU-SET) (CONNECTIONS (LISTOF MENU-SET-CONN))) PROP ((WINDOW ((WINDOW (MENU-SET SELF))))) MSG ((DRAW MENU-CONNS-DRAW) (REDRAW MENU-CONNS-REDRAW) (MOVE MENU-CONNS-MOVE) (ADD-CONN MENU-CONNS-ADD-CONN) (ADD-ITEM MENU-CONNS-ADD-ITEM OPEN T) (FIND-CONN MENU-CONNS-FIND-CONN) (FIND-ITEM MENU-CONNS-FIND-ITEM) (DELETE-ITEM MENU-CONNS-DELETE-ITEM) (DELETE-CONN MENU-CONNS-DELETE-CONN) (REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS) (FIND-CONNS MENU-CONNS-FIND-CONNS) (CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS) (NEW-CONN MENU-CONNS-NEW-CONN) (NAMED-MENU MENU-CONNS-NAMED-MENU) (NAMED-ITEM MENU-CONNS-NAMED-ITEM)))) (DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN)) (SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS) '((W WINDOW) (&OPTIONAL NIL))) (SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET) (DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED) (LET (RES RESB ITM SEL LASTX LASTY) (IF REDRAW (MENU-SET-DRAW MS)) (WHILE (NOT (OR RES RESB)) (SETQ ITM (WINDOW-TRACK-MOUSE (CADR MS) #'(LAMBDA (X Y CODE) (OR (AND (PLUSP CODE) (SETQ LASTX X) (SETQ LASTY Y) CODE) (SOME #'(LAMBDA (GLVAR128) (IF (AND (BETWEEN X (FIFTH (CADDR GLVAR128)) (+ (FIFTH (CADDR GLVAR128)) (SEVENTH (CADDR GLVAR128)))) (BETWEEN Y (SIXTH (CADDR GLVAR128)) (+ (SIXTH (CADDR GLVAR128)) (EIGHTH (CADDR GLVAR128))))) GLVAR128)) (CADDR MS)))))) (IF (NUMBERP ITM) (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM)) (WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED)) (SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T))) (IF SEL (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*)) (IF (AND *WINDOW-MENU-CODE* (NOT (ZEROP *WINDOW-MENU-CODE*))) (SETQ RES (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*))))))) (XFLUSH *WINDOW-DISPLAY*) (OR RES RESB))) (SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS) '((MS MENU-SET) (&OPTIONAL BOOLEAN) (REDRAW (LISTOF SYMBOL)))) (SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION) (DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET) (LET (MENU) (SETQ MENU (MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) T T)) (MENU-INIT MENU) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) (EIGHTH MENU)))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU))) (SETF (GET 'MENU-SET-ADD-MENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) (ITEMS NIL) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU) (SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL)))) (SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) (SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL)) (SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET))) (SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-PICMENU (MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX) (LET (MENU MAXWIDTH MAXHEIGHT) (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC))) (SETQ MENU (PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) T T (NOT NOBOX))) (SETQ MAXWIDTH (MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC))) (SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC))) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU))) (SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) (SPEC PICMENU-SPEC) (&OPTIONAL VECTOR) (OFFSET BOOLEAN))) (SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET) (MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T)) (SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET) (BARMENU-INIT MENU) (IF (NOT OFFSET) (SETQ OFFSET (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) (EIGHTH MENU)))) (SETF (FIFTH MENU) (CAR OFFSET)) (SETF (SIXTH MENU) (CADR OFFSET)) (MENU-SET-ADD-ITEM MS NAME SYM MENU)) (SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU) (TITLE STRING) (&OPTIONAL VECTOR))) (SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-NAME (NM) (INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM))))) (SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL))) (SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL) (DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS))) (SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL))) (SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-SET-NAMED-MENU (MS NAME) (CADDR (MENU-SET-NAMED-ITEM MS NAME))) (SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL))) (SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) (DEFUN MENU-SET-ITEMP (MS NAME ITEMNAME) (LET ((THISMENU (MENU-SET-NAMED-MENU MS NAME))) (IF (EQ (FIRST THISMENU) 'MENU) (SOME #'(LAMBDA (X) (OR (EQ X ITEMNAME) (AND (CONSP X) (EQ (CAR X) ITEMNAME)))) (NTH 13 THISMENU)) (IF (EQ (FIRST THISMENU) 'PICMENU) (ASSOC ITEMNAME (CADDDR (NTH 10 THISMENU))))))) (SETF (GET 'MENU-SET-ITEMP 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (ITEMNAME SYMBOL))) (SETF (GET 'MENU-SET-ITEMP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN MENU-CONNS-NAMED-ITEM (MC NAME) (MENU-SET-NAMED-ITEM (CADR MC) NAME)) (SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL))) (SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-CONNS-NAMED-MENU (MC NAME) (MENU-SET-NAMED-MENU (CADR MC) NAME)) (SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL))) (SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) (DEFUN MENU-SET-FIND-ITEM (MS POS) (LET (MITEM) (DOLIST (MI (CADDR MS)) (IF (AND (BETWEEN (CAR POS) (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (FIFTH SELF) 0)) (+ (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (FIFTH SELF) 0)) (SEVENTH (CADDR MI)))) (BETWEEN (CADR POS) (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (SIXTH SELF) 0)) (+ (LET ((SELF (CADDR MI))) (IF (CADDR SELF) (SIXTH SELF) 0)) (EIGHTH (CADDR MI))))) (SETQ MITEM MI))) MITEM)) (SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS) '((MS MENU-SET) (POS VECTOR))) (SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-SET-DELETE-ITEM (MS MI) (SETF (CADDR MS) (REMOVE MI (CADDR MS)))) (SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS) '((MS MENU-SET) (MI MENU-SET-ITEM))) (SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-SET-MOVE (MS) (LET (SEL M) (SETQ SEL (MENU-SET-SELECT MS NIL T)) (SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL))) (MENU-REPOSITION M))) (DEFUN MENU-MDRAW (M) (CASE (FIRST M) (MENU (MENU-DRAW M)) (PICMENU (PICMENU-DRAW M)) (BARMENU (BARMENU-DRAW M)) (TEXTMENU (TEXTMENU-DRAW M)) (EDITMENU (EDITMENU-DRAW M)) (T (GLSEND M DRAW)))) (DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK) (CASE (FIRST M) (MENU (MENU-SELECT M T)) (PICMENU (PICMENU-SELECT M T ANYCLICK)) (BARMENU (BARMENU-SELECT M)) (TEXTMENU (TEXTMENU-SELECT M T)) (EDITMENU (EDITMENU-SELECT M T)) (T (GLSEND M SELECT)))) (DEFUN MENU-MITEM-POSITION (M NAME LOC) (CASE (FIRST M) (MENU (MENU-ITEM-POSITION M NAME LOC)) (PICMENU (PICMENU-ITEM-POSITION M NAME LOC)) (T (GLSEND M ITEM-POSITION NAME LOC)))) (DEFUN MENU-SET-DRAW (MS) (XMAPWINDOW *WINDOW-DISPLAY* (CADADR MS)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE (CADR MS)) (DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM)))) (DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC) (LET (M) (SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC))) (OR (MENU-MITEM-POSITION M (CAR DESC) LOC) (MENU-MITEM-POSITION M NIL LOC)))) (SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS) '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL SYMBOL))) (SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR) (DEFUN MENU-SET-DRAW-CONN (MS CONN) (LET (PA PB TMP (DESCA (CAR CONN)) (DESCB (CADR CONN))) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) (WHEN (> (CAR PA) (CAR PB)) (SETQ TMP DESCA) (SETQ DESCA DESCB) (SETQ DESCB TMP)) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PA) (CADR PA) 3 NIL) (WINDOW-DRAW-LINE-XY (CADR MS) (CAR PA) (CADR PA) (CAR PB) (CADR PB) NIL) (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PB) (CADR PB) 3 NIL) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET) (LET (M FROMM PLACE) (WHEN (SETQ M (MENU-SET-NAMED-ITEM MS NAME)) (IF FROM (PROGN (SETQ FROMM (MENU-SET-NAMED-ITEM MS FROM)) (SETQ PLACE (CASE EDGE (TOP (SIXTH (CADDR FROMM))) (BOTTOM (+ (SIXTH (CADDR FROMM)) (EIGHTH (CADDR FROMM)))) (LEFT (+ (FIFTH (CADDR FROMM)) (SEVENTH (CADDR FROMM)))) (RIGHT (FIFTH (CADDR FROMM)))))) (SETQ PLACE (CASE EDGE (TOP (CADDDR (CADR MS))) ((BOTTOM LEFT) 0) (RIGHT (FIFTH (CADR MS)))))) (CASE EDGE (TOP (SETF (SIXTH (CADDR M)) (- (- PLACE (EIGHTH (CADDR M))) OFFSET))) (BOTTOM (SETF (SIXTH (CADDR M)) (+ PLACE OFFSET))) (LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET))) (RIGHT (SETF (FIFTH (CADDR M)) (- (- PLACE (SEVENTH (CADDR M))) OFFSET))))))) (SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS) '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL) (OFFSET INTEGER))) (SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER) (DEFUN VECTOR-SNAP (FIXED APPROX &OPTIONAL TOLERANCE) (OR TOLERANCE (SETQ TOLERANCE 10)) (IF (< (ABS (- (CAR FIXED) (CAR APPROX))) TOLERANCE) (LIST (CAR FIXED) (CADR APPROX)) (IF (< (ABS (- (CADR FIXED) (CADR APPROX))) TOLERANCE) (LIST (CAR APPROX) (CADR FIXED)) APPROX))) (SETF (GET 'VECTOR-SNAP 'GLARGUMENTS) '((FIXED VECTOR) (APPROX VECTOR) (&OPTIONAL NIL))) (SETF (GET 'VECTOR-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL)) (SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET))) (SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS) (DEFUN MENU-CONNS-DRAW (MC) (MENU-SET-DRAW (CADR MC)) (DOLIST (C (CADDR MC)) (MENU-SET-DRAW-CONN (CADR MC) C))) (DEFUN MENU-CONNS-MOVE (MC) (MENU-SET-MOVE (CADR MC)) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) (XFLUSH *WINDOW-DISPLAY*) (MENU-CONNS-DRAW MC)) (DEFUN MENU-CONNS-REDRAW (MC) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) (XFLUSH *WINDOW-DISPLAY*) (MENU-CONNS-DRAW MC)) (DEFUN MENU-CONNS-ADD-CONN (MC) (LET (SEL SELB CONN) (SETQ SEL (MENU-SET-SELECT (CADR MC))) (IF (EQ (CADR SEL) 'BACKGROUND) SEL (PROGN (SETQ SELB (MENU-SET-SELECT (CADR MC))) (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND)) (SETQ CONN (LIST SEL SELB)) (MENU-SET-DRAW-CONN (CADR MC) CONN) (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))) NIL)))) (SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS))) (SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION) (DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT) (LET (CONN) (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME))) (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))) (SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL) (TONAME SYMBOL) (TOPORT SYMBOL))) (SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU) (MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU)) (SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) (SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) (DEFUN MENU-CONNS-FIND-CONN (MC PT) (LET (MS LS FOUND RES PA PB TMP DESCA DESCB) (SETQ LS (LIST (COPY-LIST '(0 0)) (COPY-LIST '(0 0)))) (SETQ MS (CADR MC)) (DOLIST (CONN (CADDR MC)) (UNLESS FOUND (SETQ DESCA (CAR CONN)) (SETQ DESCB (CADR CONN)) (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) (WHEN (> (CAR PA) (CAR PB)) (SETQ TMP DESCA) (SETQ DESCA DESCB) (SETQ DESCB TMP)) (SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) (SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS)) (- (CADR PT) (CADAR LS))) (* (- (CADADR LS) (CADAR LS)) (- (CAR PT) (CAAR LS)))) (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2) (EXPT (- (CADADR LS) (CADAR LS)) 2))))) 5) (SETQ FOUND T) (SETQ RES CONN)))) RES)) (SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (PT VECTOR))) (SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN) (DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT)) (SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS) '((MC MENU-CONNS) (PT VECTOR))) (SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) (DEFUN MENU-CONNS-DELETE-CONN (MC CONN) (SETF (CADDR MC) (REMOVE CONN (CADDR MC)))) (SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS) '((MC MENU-CONNS) (CONN MENU-SET-CONN))) (SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-DELETE-ITEM (MC MI) (LET (MS) (SETQ MS (CADR MC)) (MENU-SET-DELETE-ITEM MS MI) (DOLIST (CONN (CADDR MC)) (IF (OR (EQ (CADAR CONN) (CAR MI)) (EQ (CADADR CONN) (CAR MI))) (MENU-CONNS-DELETE-CONN MC CONN))))) (DEFUN MENU-CONNS-REMOVE-ITEMS (MC) (MENU-SET-REMOVE-ITEMS (CADR MC)) (SETF (CADDR MC) NIL)) (SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS))) (SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE) '(LISTOF MENU-SET-CONN)) (DEFUN MENU-CONNS-CONNECTED-PORTS (MC BOXNAME) (LET (PORTS) (DOLIST (CONN (CADDR MC)) (IF (EQ BOXNAME (CADADR CONN)) (PUSHNEW (CAADR CONN) PORTS) (IF (EQ BOXNAME (CADAR CONN)) (PUSHNEW (CAAR CONN) PORTS)))) PORTS)) (DEFUN MENU-CONNS-FIND-CONNS (MC BOXNAME PORT) (LET (RES) (DOLIST (CONN (CADDR MC)) (IF (AND (EQ BOXNAME (CADADR CONN)) (EQ PORT (CAADR CONN))) (SETQ RES (NCONC RES (CONS (CAR CONN) NIL)))) (IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN))) (SETQ RES (NCONC RES (CONS (CADR CONN) NIL))))) RES)) (SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS) '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL))) (SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT)) (DEFUN COMPILE-MENU-SET () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" "glisp/menu-set-header.lsp") (COMPILE-FILE "glisp/menu-settrans.lsp")) (DEFUN COMPILE-MENU-SETB () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" "glisp/menu-set-header.lsp")) (DEFVAR *DRAW-WINDOW* NIL) (DEFVAR *DRAW-WINDOW-WIDTH* 600) (DEFVAR *DRAW-WINDOW-HEIGHT* 600) (DEFVAR *DRAW-LEAVE-WINDOW* NIL) (DEFVAR *DRAW-MENU-SET* NIL) (DEFVAR *DRAW-ZERO-VECTOR* '(0 0)) (DEFVAR *DRAW-LATEX-FACTOR* 1) (DEFVAR *DRAW-SNAP-FLAG* T) (DEFVAR *DRAW-OBJECTS* NIL) (DEFVAR *DRAW-LATEX-MODE* NIL) (DEFVAR *DRAW-WINDOW*) (SETF (GET '*DRAW-WINDOW* 'GLISPGLOBALVAR) T) (SETF (GET '*DRAW-WINDOW* 'GLISPGLOBALVARTYPE) 'WINDOW) (DEFMACRO DRAW-DESCR (NAME) (LIST 'GET NAME ''DRAW-DESCR)) (SETF (GET 'DRAW-DESC 'GLSTRUCTURE) '((LISTOBJECT (NAME SYMBOL) (OBJECTS (LISTOF DRAW-OBJECT)) (OFFSET VECTOR) (SIZE VECTOR)) PROP ((FNNAME DRAW-DESC-FNNAME) (REFPT DRAW-DESC-REFPT)) MSG ((DRAW DRAW-DESC-DRAW) (SNAP DRAW-DESC-SNAP) (FIND DRAW-DESC-FIND) (DELETE DRAW-DESC-DELETE)))) (SETF (GET 'DRAW-OBJECT 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) DEFAULT ((LINEWIDTH 1)) PROP ((REGION ((VIRTUAL REGION WITH START = OFFSET SIZE = SIZE))) (VREGION ((VIRTUAL REGION WITH START = VSTART SIZE = VSIZE))) (VSTART ((VIRTUAL VECTOR WITH X = (MIN (X OFFSET) ((X OFFSET) + (X SIZE))) - 2 Y = (MIN (Y OFFSET) ((Y OFFSET) + (Y SIZE))) - 2))) (VSIZE ((VIRTUAL VECTOR WITH X = (ABS (X SIZE)) + 4 Y = (ABS (Y SIZE)) + 4)))) MSG ((ERASE DRAW-OBJECT-ERASE) (DRAW DRAW-OBJECT-DRAW) (SNAP DRAW-OBJECT-SNAP) (SELECTEDP DRAW-OBJECT-SELECTEDP) (MOVE DRAW-OBJECT-MOVE)))) (SETF (GET 'DRAW-LINE 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) PROP ((LINE ((VIRTUAL LINE-SEGMENT WITH P1 = OFFSET P2 = (OFFSET + SIZE))))) MSG ((DRAW DRAW-LINE-DRAW) (SNAP DRAW-LINE-SNAP) (SELECTEDP DRAW-LINE-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-ARROW 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) PROP ((LINE ((VIRTUAL LINE-SEGMENT WITH P1 = OFFSET P2 = (OFFSET + SIZE))))) MSG ((DRAW DRAW-ARROW-DRAW) (SNAP DRAW-LINE-SNAP) (SELECTEDP DRAW-LINE-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-BOX 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-BOX-DRAW) (SNAP DRAW-BOX-SNAP) (SELECTEDP DRAW-BOX-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-RCBOX 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-RCBOX-DRAW) (SNAP DRAW-RCBOX-SNAP) (SELECTEDP DRAW-RCBOX-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-ERASE 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-ERASE-DRAW) (SNAP DRAW-NO-SNAP) (SELECTEDP DRAW-ERASE-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-CIRCLE 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) PROP ((RADIUS ((X SIZE) / 2)) (CENTER (OFFSET + SIZE / 2))) MSG ((DRAW DRAW-CIRCLE-DRAW) (SNAP DRAW-CIRCLE-SNAP) (SELECTEDP DRAW-CIRCLE-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-ELLIPSE 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) PROP ((RADIUSX ((X SIZE) / 2)) (RADIUSY ((Y SIZE) / 2)) (RADIUS ((MAX RADIUSX RADIUSY))) (CENTER (OFFSET + SIZE / 2)) (DELTA ((SQRT (ABS (RADIUSX ^ 2 - RADIUSY ^ 2))))) (P1 ((IF (RADIUSX > RADIUSY) (A VECTOR X = (X CENTER) - DELTA Y = (Y CENTER)) (A VECTOR X = (X CENTER) Y = (Y CENTER) - DELTA)))) (P2 ((IF (RADIUSX > RADIUSY) (A VECTOR X = (X CENTER) + DELTA Y = (Y CENTER)) (A VECTOR X = (X CENTER) Y = (Y CENTER) + DELTA))))) MSG ((DRAW DRAW-ELLIPSE-DRAW) (SNAP DRAW-ELLIPSE-SNAP) (SELECTEDP DRAW-ELLIPSE-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-DOT 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-DOT-DRAW) (SNAP DRAW-DOT-SNAP) (SELECTEDP DRAW-BUTTON-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-BUTTON 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-BUTTON-DRAW) (SNAP DRAW-DOT-SNAP) (SELECTEDP DRAW-BUTTON-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-TEXT 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-TEXT-DRAW) (SNAP DRAW-NO-SNAP) (SELECTEDP DRAW-TEXT-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-NULL 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-NULL-DRAW) (SNAP DRAW-NO-SNAP) (SELECTEDP DRAW-NULL-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-REFPT 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-REFPT-DRAW) (SNAP DRAW-REFPT-SNAP) (SELECTEDP DRAW-REFPT-SELECTEDP)) SUPERS (DRAW-OBJECT))) (SETF (GET 'DRAW-MULTI 'GLSTRUCTURE) '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS (LISTOF DRAW-OBJECT)) (LINEWIDTH INTEGER)) MSG ((DRAW DRAW-MULTI-DRAW) (SNAP DRAW-NO-SNAP) (SELECTEDP DRAW-MULTI-SELECTEDP)) SUPERS (DRAW-OBJECT))) (DEFUN DRAW-DESC (NAME) (LET (DD) (SETQ DD (DRAW-DESCR NAME)) (WHEN (NOT DD) (SETQ DD (LIST 'DRAW-DESC NAME NIL (COPY-LIST '(0 0)) (COPY-LIST '(0 0)))) (SETF (DRAW-DESCR NAME) DD)) DD)) (SETF (GET 'DRAW-DESC 'GLARGUMENTS) '((NAME SYMBOL))) (SETF (GET 'DRAW-DESC 'GLFNRESULTTYPE) 'DRAW-DESC) (SETF (GET 'DRAW-WINDOW 'GLFNRESULTTYPE) 'WINDOW) (DEFUN DRAW-WINDOW () (OR *DRAW-WINDOW* (SETQ *DRAW-WINDOW* (WINDOW-CREATE *DRAW-WINDOW-WIDTH* *DRAW-WINDOW-HEIGHT* "Draw window")))) (DEFUN DRAW (NAME) (LET (W DD DONE SEL (REDRAW T) NEW) (SETQ W (DRAW-WINDOW)) (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-EXPOSURE W) (OR *DRAW-MENU-SET* (DRAW-INIT-MENUS)) (SETQ DD (DRAW-DESC NAME)) (UNLESS (MEMBER NAME *DRAW-OBJECTS*) (SETQ *DRAW-OBJECTS* (NCONC *DRAW-OBJECTS* (LIST NAME)))) (DRAW-DESC-DRAW DD W) (WHILE (NOT DONE) (SETQ SEL (MENU-SET-SELECT *DRAW-MENU-SET* REDRAW)) (SETQ REDRAW NIL) (CASE (CADR SEL) (COMMAND (CASE (CAR SEL) (DONE (SETQ DONE T)) (MOVE (DRAW-DESC-MOVE DD W)) (DELETE (DRAW-DESC-DELETE DD W)) (COPY (DRAW-DESC-COPY DD W)) (REDRAW (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (SETQ REDRAW T) (DRAW-DESC-DRAW DD W)) (ORIGIN (DRAW-DESC-ORIGIN DD W) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (SETQ REDRAW T) (DRAW-DESC-DRAW DD W)) (PROGRAM (DRAW-DESC-PROGRAM DD)) (LATEX (DRAW-DESC-LATEX DD)) (LATEXMODE (SETQ *DRAW-LATEX-MODE* (NOT *DRAW-LATEX-MODE*)) (FORMAT T "Latex Mode is now ~A~%" *DRAW-LATEX-MODE*)))) (DRAW (SETQ NEW NIL) (CASE (CAR SEL) (RECTANGLE (SETQ NEW (DRAW-BOX-GET DD W))) (RCBOX (SETQ NEW (DRAW-RCBOX-GET DD W))) (CIRCLE (SETQ NEW (DRAW-CIRCLE-GET DD W))) (ELLIPSE (SETQ NEW (DRAW-ELLIPSE-GET DD W))) (LINE (SETQ NEW (DRAW-LINE-GET DD W))) (ARROW (SETQ NEW (DRAW-ARROW-GET DD W))) (DOT (SETQ NEW (DRAW-DOT-GET DD W))) (ERASE (SETQ NEW (DRAW-ERASE-GET DD W))) (BUTTON (SETQ NEW (DRAW-BUTTON-GET DD W))) (TEXT (SETQ NEW (DRAW-TEXT-GET DD W))) (REFPT (SETQ NEW (DRAW-REFPT-GET DD W)))) (WHEN NEW (SETF (CADR NEW) (LIST (- (CAADR NEW) (CAR (CADDDR DD))) (- (CADADR NEW) (CADR (CADDDR DD))))) (SETF (CADDR DD) (NCONC (CADDR DD) (CONS NEW NIL))) (DRAW-OBJECT-DRAW NEW W (CADDDR DD)))) (BACKGROUND))) (SETF (DRAW-DESCR NAME) DD) (UNLESS *DRAW-LEAVE-WINDOW* (PROGN (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP W))) NAME)) (SETF (GET 'DRAW 'GLARGUMENTS) '((NAME SYMBOL))) (SETF (GET 'DRAW 'GLFNRESULTTYPE) 'SYMBOL) (DEFUN COPY-DRAW-DESC (FROM TO) (LET (OLD) (SETQ OLD (COPY-TREE (GET FROM 'DRAW-DESCR))) (SETF (GET TO 'DRAW-DESCR) (CONS (CAR OLD) (CONS TO (CDDR OLD)))))) (DEFUN DRAW-DESC-DRAW (DD W) (LET ((OFF (CADDDR DD))) (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) (XFLUSH *WINDOW-DISPLAY*) (DOLIST (OBJ (CADDR DD)) (DRAW-OBJECT-DRAW OBJ W OFF)) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN DRAW-DESC-SELECTED (DD P) (LET (OBJS OBJSB OBJ) (SETQ OBJS (MAPCAN #'(LAMBDA (OBJ) (AND (DRAW-OBJECT-SELECTEDP OBJ P (CADDDR DD)) (CONS OBJ NIL))) (CADDR DD))) (IF OBJS (IF (NULL (REST OBJS)) (SETQ OBJ (FIRST OBJS)) (PROGN (SETQ OBJSB (MAPCAN #'(LAMBDA (Z) (AND (MEMBER (FIRST Z) '(DRAW-BUTTON DRAW-DOT)) (CONS Z NIL))) OBJS)) (IF (AND OBJSB (NULL (REST OBJSB))) (SETQ OBJ (FIRST OBJSB)))))) OBJ)) (SETF (GET 'DRAW-DESC-SELECTED 'GLARGUMENTS) '((DD DRAW-DESC) (P VECTOR))) (SETF (GET 'DRAW-DESC-SELECTED 'GLFNRESULTTYPE) 'DRAW-OBJECT) (DEFUN DRAW-DESC-FIND (DD W &OPTIONAL CROSSFLG) (LET (P OBJ) (WHILE (NOT OBJ) (SETQ P (IF CROSSFLG (DRAW-GET-CROSS DD W) (DRAW-GET-CROSSHAIRS DD W))) (SETQ OBJ (DRAW-DESC-SELECTED DD P))) OBJ)) (SETF (GET 'DRAW-DESC-FIND 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW) (&OPTIONAL BOOLEAN))) (SETF (GET 'DRAW-DESC-FIND 'GLFNRESULTTYPE) 'DRAW-OBJECT) (DEFUN DRAW-GET-CROSS (DD W) (DRAW-DESC-SNAP DD (WINDOW-GET-CROSS W))) (SETF (GET 'DRAW-GET-CROSS 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-GET-CROSS 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-GET-CROSSHAIRS (DD W) (DRAW-DESC-SNAP DD (WINDOW-GET-CROSSHAIRS W))) (SETF (GET 'DRAW-GET-CROSSHAIRS 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-GET-CROSSHAIRS 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-DESC-DELETE (DD W) (LET (OBJ) (SETQ OBJ (DRAW-DESC-FIND DD W T)) (DRAW-OBJECT-ERASE OBJ W (CADDDR DD)) (SETF (CADDR DD) (REMOVE OBJ (CADDR DD))))) (SETF (GET 'DRAW-DESC-DELETE 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-DESC-DELETE 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT)) (DEFUN DRAW-DESC-COPY (DD W) (LET (OBJ OBJB) (SETQ OBJ (DRAW-DESC-FIND DD W)) (SETQ OBJB (COPY-TREE OBJ)) (DRAW-GET-OBJECT-POS OBJB W) (SETF (CADR OBJB) (LIST (- (CAADR OBJB) (CAR (CADDDR DD))) (- (CADADR OBJB) (CADR (CADDDR DD))))) (DRAW-OBJECT-DRAW OBJB W (CADDDR DD)) (XFLUSH *WINDOW-DISPLAY*) (SETF (CADDR DD) (NCONC (CADDR DD) (CONS OBJB NIL))))) (SETF (GET 'DRAW-DESC-COPY 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-DESC-COPY 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT)) (DEFUN DRAW-DESC-MOVE (DD W) (LET (OBJ) (IF (SETQ OBJ (DRAW-DESC-FIND DD W)) (DRAW-OBJECT-MOVE OBJ W (CADDDR DD))))) (DEFUN DRAW-DESC-ORIGIN (DD W) (LET (SEL) (DRAW-DESC-BOUNDS DD) (SETQ SEL (MENU '(("To zero" . TOZERO) ("Select" . SELECT)))) (IF (EQ SEL 'SELECT) (SETF (CADDDR DD) (WINDOW-GET-BOX-POSITION W (CAR (FIFTH DD)) (CADR (FIFTH DD)))) (IF (EQ SEL 'TOZERO) (SETF (CADDDR DD) (COPY-LIST '(0 0))))))) (SETF (GET 'DRAW-DESC-ORIGIN 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-DESC-ORIGIN 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-DESC-BOUNDS (DD) (LET ((XMIN 9999) (YMIN 9999) (XMAX 0) (YMAX 0) BASEV) (DOLIST (OBJ (CADDR DD)) (SETQ XMIN (MIN XMIN (CAADR OBJ) (+ (CAADR OBJ) (CAADDR OBJ)))) (SETQ YMIN (MIN YMIN (CADADR OBJ) (+ (CADADR OBJ) (CADR (CADDR OBJ))))) (SETQ XMAX (MAX XMAX (CAADR OBJ) (+ (CAADR OBJ) (CAADDR OBJ)))) (SETQ YMAX (MAX YMAX (CADADR OBJ) (+ (CADADR OBJ) (CADR (CADDR OBJ)))))) (SETF (CAR (FIFTH DD)) (- XMAX XMIN)) (SETF (CADR (FIFTH DD)) (- YMAX YMIN)) (SETQ BASEV (LIST XMIN YMIN)) (SETF (CADDDR DD) BASEV) (DOLIST (OBJ (CADDR DD)) (SETF (CADR OBJ) (LIST (- (CAADR OBJ) (CAR BASEV)) (- (CADADR OBJ) (CADR BASEV))))))) (DEFUN DRAW-DESC-LATEX (DD) (LET (BASE BX BY SX SY) (FORMAT T " \\begin{picture}(~5,0F,~5,0F)(0,0)~%" (* (CAR (FIFTH DD)) *DRAW-LATEX-FACTOR*) (* (CADR (FIFTH DD)) *DRAW-LATEX-FACTOR*)) (DOLIST (OBJ (CADDR DD)) (SETQ BASE (LIST (+ (CAR (CADDDR DD)) (CAADR OBJ)) (+ (CADR (CADDDR DD)) (CADADR OBJ)))) (SETQ BX (* (CAR BASE) *DRAW-LATEX-FACTOR*)) (SETQ BY (* (CADR BASE) *DRAW-LATEX-FACTOR*)) (SETQ SX (* (CAADDR OBJ) *DRAW-LATEX-FACTOR*)) (SETQ SY (* (CADR (CADDR OBJ)) *DRAW-LATEX-FACTOR*)) (CASE (FIRST OBJ) (DRAW-LINE (LATEX-LINE (CAR BASE) (CADR BASE) (+ (CAR BASE) SX) (+ (CADR BASE) SY))) (DRAW-ARROW (LATEX-LINE (CAR BASE) (CADR BASE) (+ (CAR BASE) SX) (+ (CADR BASE) SY) T)) (DRAW-BOX (FORMAT T " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" BX BY SX SY)) (DRAW-RCBOX (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX SY)) (DRAW-CIRCLE (FORMAT T " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%" (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX)) (DRAW-ELLIPSE (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX SY)) (DRAW-BUTTON (FORMAT T " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" BX BY SX SY)) (DRAW-ERASE) (DRAW-DOT (FORMAT T " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%" (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX)) (DRAW-TEXT (FORMAT T " \\put(~5,0F,~5,0F) {~A}~%" BX (+ BY (* 4 *DRAW-LATEX-FACTOR*)) (CADDDR OBJ))))) (FORMAT T " \\end{picture}~%"))) (DEFUN DRAW-DESC-PROGRAM (DD) (LET (BASE BX BY SX SY TOX TOY R RX RY S CODE FNCODE FNNAME CD) (SETQ CODE (MAPCAN #'(LAMBDA (OBJ) (AND (SETQ CD (PROGN (SETQ BASE (LET ((GLVAR133 (LIST (+ (CAR (CADDDR DD)) (CAADR OBJ)) (+ (CADR (CADDDR DD)) (CADADR OBJ)))) (GLVAR134 (DRAW-DESC-REFPT DD))) (LIST (- (CAR GLVAR133) (CAR GLVAR134)) (- (CADR GLVAR133) (CADR GLVAR134))))) (SETQ BX (CAR BASE)) (SETQ BY (CADR BASE)) (SETQ SX (CAADDR OBJ)) (SETQ SY (CADR (CADDR OBJ))) (SETQ TOX (+ BX SX)) (SETQ TOY (+ BY SY)) (IF (EQ (CAR OBJ) 'DRAW-CIRCLE) (SETQ R (* 1/2 (CAADDR OBJ)))) (WHEN (EQ (CAR OBJ) 'DRAW-ELLIPSE) (SETQ RX (* 1/2 (CAADDR OBJ))) (SETQ RY (* 1/2 (CADR (CADDR OBJ))))) (DRAW-OPTIMIZE (CASE (FIRST OBJ) (DRAW-LINE (LIST 'WINDOW-DRAW-LINE-XY 'W (LIST '+ 'X BX) (LIST '+ 'Y BY) (LIST '+ 'X TOX) (LIST '+ 'Y TOY))) (DRAW-ARROW (LIST 'WINDOW-DRAW-ARROW-XY 'W (LIST '+ 'X BX) (LIST '+ 'Y BY) (LIST '+ 'X TOX) (LIST '+ 'Y TOY))) (DRAW-BOX (LIST 'WINDOW-DRAW-BOX-XY 'W (LIST '+ 'X BX) (LIST '+ 'Y BY) SX SY)) (DRAW-RCBOX (LIST 'WINDOW-DRAW-RCBOX-XY 'W (LIST '+ 'X BX) (LIST '+ 'Y BY) SX SY 8)) (DRAW-CIRCLE (LIST 'WINDOW-DRAW-CIRCLE-XY 'W (LIST '+ 'X (+ R BX)) (LIST '+ 'Y (+ R BY)) R)) (DRAW-ELLIPSE (LIST 'WINDOW-DRAW-ELLIPSE-XY 'W (LIST '+ 'X (+ RX BX)) (LIST '+ 'Y (+ RY BY)) RX RY)) ((DRAW-BUTTON DRAW-REFPT) NIL) (DRAW-ERASE (LIST 'WINDOW-ERASE-AREA-XY 'W (LIST '+ 'X BX) (LIST '+ 'Y BY) SX SY)) (DRAW-DOT (LIST 'WINDOW-DRAW-DOT-XY 'W (LIST '+ 'X (+ 2 BX)) (LIST '+ 'Y (+ 2 BY)))) (DRAW-TEXT (SETQ S (STRINGIFY (CADDDR OBJ))) (LIST 'WINDOW-PRINTAT-XY 'W S (LIST '+ 'X BX) (LIST '+ 'Y BY))))))) (CONS CD NIL))) (CADDR DD))) (SETQ FNCODE (CONS 'LAMBDA (CONS (LIST 'W 'X 'Y) (NCONC CODE (LIST (LIST 'WINDOW-FORCE-OUTPUT 'W)))))) (SETQ FNNAME (DRAW-DESC-FNNAME DD)) (SETF (SYMBOL-FUNCTION FNNAME) FNCODE) (FORMAT T "Constructed program (~A w x y)~%" FNNAME) (DRAW-DESC-PICMENU DD))) (DEFUN DRAW-OPTIMIZE (X) (IF (FBOUNDP 'GLUNWRAP) (GLUNWRAP X NIL) X)) (DEFUN DRAW-DESC-FNNAME (DD) (INTERN (CONCATENATE 'STRING "DRAW-" (SYMBOL-NAME (CADR DD))))) (SETF (GET 'DRAW-DESC-FNNAME 'GLARGUMENTS) '((DD DRAW-DESC))) (SETF (GET 'DRAW-DESC-FNNAME 'GLFNRESULTTYPE) 'SYMBOL) (DEFUN DRAW-DESC-PICMENU (DD) (LET (BUTTONS) (SETQ BUTTONS (MAPCAN #'(LAMBDA (OBJ) (AND (EQ (FIRST OBJ) 'DRAW-BUTTON) (CONS (LIST (CADDDR OBJ) (LET ((GLVAR136 (LET ((GLVAR135 (COPY-LIST '(2 2)))) (LIST (+ (CAR GLVAR135) (CAADR OBJ)) (+ (CADR GLVAR135) (CADADR OBJ)))))) (LIST (+ (CAR GLVAR136) (CAR (CADDDR DD))) (+ (CADR GLVAR136) (CADR (CADDDR DD)))))) NIL))) (CADDR DD))) (IF BUTTONS (SETF (GET (CADR DD) 'PICMENU-SPEC) (LIST 'PICMENU-SPEC (CAR (FIFTH DD)) (CADR (FIFTH DD)) BUTTONS T (DRAW-DESC-FNNAME DD) '9X15))))) (SETF (GET 'DRAW-DESC-PICMENU 'GLARGUMENTS) '((DD DRAW-DESC))) (SETF (GET 'DRAW-DESC-PICMENU 'GLFNRESULTTYPE) '(LIST GLTYPE INTEGER INTEGER (LISTOF (LIST ANYTHING VECTOR)) BOOLEAN SYMBOL SYMBOL)) (DEFUN DRAW-DESC-SNAP (DD P) (LET (PSNAP OBJ (OBJS (CADDR DD))) (IF *DRAW-SNAP-FLAG* (WHILE (AND OBJS (NOT PSNAP)) (SETQ OBJ (POP OBJS)) (SETQ PSNAP (DRAW-OBJECT-SNAP OBJ P (CADDDR DD))))) (OR PSNAP P))) (SETF (GET 'DRAW-DESC-SNAP 'GLARGUMENTS) '((DD DRAW-DESC) (P VECTOR))) (SETF (GET 'DRAW-DESC-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-OBJECT-MOVE (D W OFF) (DRAW-OBJECT-ERASE D W OFF) (DRAW-GET-OBJECT-POS D W) (SETF (CADR D) (LIST (- (CAADR D) (CAR OFF)) (- (CADADR D) (CADR OFF)))) (DRAW-OBJECT-DRAW D W OFF) (XFLUSH *WINDOW-DISPLAY*)) (DEFUN DRAW-OBJECT-DRAW-AT (W X Y D) (SETF (SECOND D) (LIST X Y)) (DRAW-OBJECT-DRAW D W *DRAW-ZERO-VECTOR*)) (DEFUN DRAW-OBJECT-DRAW (D W OFF) (FUNCALL (GLMETHOD (CAR D) 'DRAW) D W OFF)) (DEFUN DRAW-OBJECT-SNAP (D P OFF) (FUNCALL (GLMETHOD (CAR D) 'SNAP) D P OFF)) (DEFUN DRAW-OBJECT-SELECTEDP (D W OFF) (FUNCALL (GLMETHOD (CAR D) 'SELECTEDP) D W OFF)) (DEFUN DRAW-GET-OBJECT-POS (D W) (WINDOW-GET-ICON-POSITION W (IF (EQ (FIRST D) 'DRAW-TEXT) #'DRAW-TEXT-DRAW-OUTLINE #'DRAW-OBJECT-DRAW-AT) (LIST D))) (SETF (GET 'DRAW-GET-OBJECT-POS 'GLARGUMENTS) '((D DRAW-OBJECT) (W WINDOW))) (SETF (GET 'DRAW-GET-OBJECT-POS 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-OBJECT-ERASE (D W OFF) (WHEN (NOT (EQ (FIRST D) 'DRAW-ERASE)) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (DRAW-OBJECT-DRAW D W OFF) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) (DEFUN DRAW-LINE-DRAW (D W OFF) (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) (TO (LET ((GLVAR137 (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) (LIST (+ (CAR GLVAR137) (CAADDR D)) (+ (CADR GLVAR137) (CADR (CADDR D))))))) (LET ((QQWHEIGHT (CADDDR W))) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR FROM) (- QQWHEIGHT (CADR FROM)) (CAR TO) (- QQWHEIGHT (CADR TO))) NIL))) (DEFUN DRAW-ARROW-DRAW (D W OFF) (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) (TO (LET ((GLVAR138 (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) (LIST (+ (CAR GLVAR138) (CAADDR D)) (+ (CADR GLVAR138) (CADR (CADDR D))))))) (WINDOW-DRAW-ARROW-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO)))) (DEFUN DRAW-LINE-SELECTEDP (D PT OFF) (LET ((PTP (LIST (- (CAR PT) (CAR OFF)) (- (CADR PT) (CADR OFF))))) (AND (BETWEEN (CAR PTP) (+ -2 (+ (CAADR D) (MIN 0 (CAADDR D)))) (+ 2 (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D))))) (BETWEEN (CADR PTP) (+ -2 (+ (CADADR D) (MIN 0 (CADR (CADDR D))))) (+ 2 (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D)))))) (< (ABS (/ (- (* (CAADDR D) (- (CADR PTP) (CADADR D))) (* (CADR (CADDR D)) (- (CAR PTP) (CAADR D)))) (SQRT (+ (EXPT (CAADDR D) 2) (EXPT (CADR (CADDR D)) 2))))) 5)))) (SETF (GET 'DRAW-LINE-SELECTEDP 'GLARGUMENTS) '((D DRAW-LINE) (PT VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-LINE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-LINE-GET (DD W) (LET (FROM TO) (SETQ FROM (DRAW-GET-CROSSHAIRS DD W)) (SETQ TO (IF *DRAW-LATEX-MODE* (WINDOW-GET-LATEX-POSITION W (CAR FROM) (CADR FROM) NIL) (DRAW-DESC-SNAP DD (WINDOW-GET-LINE-POSITION W (CAR FROM) (CADR FROM))))) (LIST 'DRAW-LINE FROM (LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL 1))) (SETF (GET 'DRAW-LINE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-LINE-GET 'GLFNRESULTTYPE) 'DRAW-LINE) (DEFUN DRAW-ARROW-GET (DD W) (LET (FROM TO) (SETQ FROM (DRAW-GET-CROSSHAIRS DD W)) (SETQ TO (IF *DRAW-LATEX-MODE* (WINDOW-GET-LATEX-POSITION W (CAR FROM) (CADR FROM) NIL) (DRAW-DESC-SNAP DD (WINDOW-GET-LINE-POSITION W (CAR FROM) (CADR FROM))))) (LIST 'DRAW-ARROW FROM (LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL 1))) (SETF (GET 'DRAW-ARROW-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-ARROW-GET 'GLFNRESULTTYPE) 'DRAW-ARROW) (DEFUN DRAW-BOX-DRAW (D W OFF) (LET ((GLVAR139 (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) (WINDOW-DRAW-BOX-XY W (CAR GLVAR139) (CADR GLVAR139) (CAADDR D) (CADR (CADDR D)) NIL))) (DEFUN DRAW-BOX-SELECTEDP (D P OFF) (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) (OR (AND (< (CADR PT) (+ 7 (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D)))))) (> (CADR PT) (+ -7 (+ (CADADR D) (MIN 0 (CADR (CADDR D)))))) (OR (< (ABS (+ 2 (- (CAR PT) (+ (CAADR D) (MIN 0 (CAADDR D)))))) 5) (< (ABS (+ -2 (- (CAR PT) (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D)))))) 5))) (AND (< (CAR PT) (+ 7 (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D))))) (> (CAR PT) (+ -7 (+ (CAADR D) (MIN 0 (CAADDR D))))) (OR (< (ABS (+ -2 (- (CADR PT) (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D))))))) 5) (< (ABS (+ 2 (- (CADR PT) (+ (CADADR D) (MIN 0 (CADR (CADDR D))))))) 5)))))) (SETF (GET 'DRAW-BOX-SELECTEDP 'GLARGUMENTS) '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-BOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-BOX-GET (DD W) (LET (BOX) (SETQ BOX (WINDOW-GET-REGION W)) (LIST 'DRAW-BOX (CAR BOX) (CADR BOX) NIL 1))) (SETF (GET 'DRAW-BOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-BOX-GET 'GLFNRESULTTYPE) 'DRAW-BOX) (DEFUN DRAW-RCBOX-DRAW (D W OFF) (WINDOW-DRAW-RCBOX-XY W (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)) (CAADDR D) (CADR (CADDR D)) 8)) (DEFUN DRAW-RCBOX-SELECTEDP (D P OFF) (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) (OR (AND (< (CADR PT) (1- (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D)))))) (> (CADR PT) (1+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))))) (OR (< (ABS (+ 2 (- (CAR PT) (+ (CAADR D) (MIN 0 (CAADDR D)))))) 5) (< (ABS (+ -2 (- (CAR PT) (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D)))))) 5))) (AND (< (CAR PT) (1- (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D))))) (> (CAR PT) (1+ (+ (CAADR D) (MIN 0 (CAADDR D))))) (OR (< (ABS (+ -2 (- (CADR PT) (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D))))))) 5) (< (ABS (+ 2 (- (CADR PT) (+ (CADADR D) (MIN 0 (CADR (CADDR D))))))) 5)))))) (SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLARGUMENTS) '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-RCBOX-GET (DD W) (LET (BOX) (SETQ BOX (WINDOW-GET-REGION W)) (LIST 'DRAW-RCBOX (CAR BOX) (CADR BOX) NIL 1))) (SETF (GET 'DRAW-RCBOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-RCBOX-GET 'GLFNRESULTTYPE) 'DRAW-RCBOX) (DEFUN DRAW-CIRCLE-DRAW (D W OFF) (LET ((GLVAR142 (LET ((GLVAR141 (LET ((GLVAR140 (LIST (* 1/2 (CAADDR D)) (* 1/2 (CADR (CADDR D)))))) (LIST (+ (CAADR D) (CAR GLVAR140)) (+ (CADADR D) (CADR GLVAR140)))))) (LIST (+ (CAR OFF) (CAR GLVAR141)) (+ (CADR OFF) (CADR GLVAR141)))))) (WINDOW-DRAW-CIRCLE-XY W (CAR GLVAR142) (CADR GLVAR142) (* 1/2 (CAADDR D)) NIL))) (DEFUN DRAW-CIRCLE-SELECTEDP (D P OFF) (< (ABS (- (* 1/2 (CAADDR D)) (LET ((SELF (LET ((GLVAR146 (LET ((GLVAR145 (LET ((GLVAR144 (LIST (* 1/2 (CAADDR D)) (* 1/2 (CADR (CADDR D)))))) (LIST (+ (CAADR D) (CAR GLVAR144)) (+ (CADADR D) (CADR GLVAR144)))))) (LIST (+ (CAR GLVAR145) (CAR OFF)) (+ (CADR GLVAR145) (CADR OFF)))))) (LIST (- (CAR GLVAR146) (CAR P)) (- (CADR GLVAR146) (CADR P)))))) (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))))) 5)) (SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLARGUMENTS) '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-CIRCLE-GET (DD W) (LET (CIR CENT) (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) (SETQ CIR (WINDOW-GET-CIRCLE W CENT)) (LIST 'DRAW-CIRCLE (LIST (- (CAAR CIR) (CADR CIR)) (- (CADAR CIR) (CADR CIR))) (LIST (* 2 (CADR CIR)) (* 2 (CADR CIR))) NIL 1))) (SETF (GET 'DRAW-CIRCLE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-CIRCLE-GET 'GLFNRESULTTYPE) 'DRAW-CIRCLE) (DEFUN DRAW-ELLIPSE-DRAW (D W OFF) (LET ((C (LET ((GLVAR148 (LET ((GLVAR147 (LIST (* 1/2 (CAADDR D)) (* 1/2 (CADR (CADDR D)))))) (LIST (+ (CAADR D) (CAR GLVAR147)) (+ (CADADR D) (CADR GLVAR147)))))) (LIST (+ (CAR OFF) (CAR GLVAR148)) (+ (CADR OFF) (CADR GLVAR148)))))) (LET ((GLVAR149 (* 1/2 (CAADDR D))) (GLVAR150 (* 1/2 (CADR (CADDR D))))) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (CAR C) GLVAR149) (- (CADDDR W) (+ (CADR C) GLVAR150)) (* 2 GLVAR149) (* 2 GLVAR150) 0 23040) NIL))) (DEFUN DRAW-ELLIPSE-SELECTEDP (D P OFF) (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) (< (ABS (- (+ (LET ((SELF (LET ((GLVAR156 (IF (> (CAADDR D) (CADR (CADDR D))) (LIST (ROUND (- (+ (CAADR D) (* 1/2 (CAADDR D))) (SQRT (ABS (* 1/4 (- (EXPT (CAADDR D) 2) (EXPT (CADR (CADDR D)) 2))))))) (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) (LIST (+ (CAADR D) (* 1/2 (CAADDR D))) (ROUND (- (+ (CADADR D) (* 1/2 (CADR (CADDR D)))) (SQRT (ABS (* 1/4 (- (EXPT (CAADDR D) 2) (EXPT (CADR (CADDR D)) 2))))))))))) (LIST (- (CAR GLVAR156) (CAR PT)) (- (CADR GLVAR156) (CADR PT)))))) (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))) (LET ((SELF (LET ((GLVAR161 (IF (> (CAADDR D) (CADR (CADDR D))) (LIST (ROUND (+ (+ (CAADR D) (* 1/2 (CAADDR D))) (SQRT (ABS (* 1/4 (- (EXPT (CAADDR D) 2) (EXPT (CADR (CADDR D)) 2))))))) (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) (LIST (+ (CAADR D) (* 1/2 (CAADDR D))) (ROUND (+ (+ (CADADR D) (* 1/2 (CADR (CADDR D)))) (SQRT (ABS (* 1/4 (- (EXPT (CAADDR D) 2) (EXPT (CADR (CADDR D)) 2))))))))))) (LIST (- (CAR GLVAR161) (CAR PT)) (- (CADR GLVAR161) (CADR PT)))))) (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))) (* 2 (MAX (* 1/2 (CAADDR D)) (* 1/2 (CADR (CADDR D))))))) 2))) (SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLARGUMENTS) '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-TEST-ELLIPSE-SELECTEDP (E) (LET ((SIZE (THIRD E)) (OFFSET (SECOND E))) (DOTIMES (Y (+ (CADR SIZE) 10)) (DOTIMES (X (+ (CAR SIZE) 10)) (PRINC (IF (DRAW-ELLIPSE-SELECTEDP E (LIST (+ X (CAR OFFSET) -5) (+ Y (CADR OFFSET) -5)) (LIST 0 0)) "T" " "))) (TERPRI)))) (DEFUN DRAW-ELLIPSE-GET (DD W) (LET (ELL CENT) (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) (SETQ ELL (WINDOW-GET-ELLIPSE W CENT)) (LIST 'DRAW-ELLIPSE (LIST (- (CAAR ELL) (CAADR ELL)) (- (CADAR ELL) (CADADR ELL))) (LIST (* 2 (CAADR ELL)) (* 2 (CADADR ELL))) NIL 1))) (SETF (GET 'DRAW-ELLIPSE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-ELLIPSE-GET 'GLFNRESULTTYPE) 'DRAW-ELLIPSE) (DEFUN DRAW-NULL-DRAW (D W OFF) NIL) (DEFUN DRAW-NULL-SELECTEDP (D PT OFF) NIL) (DEFUN DRAW-BUTTON-DRAW (D W OFF) (LET ((GLVAR162 (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) (GLVAR163 (COPY-LIST '(4 4)))) (WINDOW-DRAW-BOX-XY W (CAR GLVAR162) (CADR GLVAR162) (CAR GLVAR163) (CADR GLVAR163) NIL))) (DEFUN DRAW-BUTTON-SELECTEDP (D P OFF) (LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D))) (PTY (- (- (CADR P) (CADR OFF)) (CADADR D)))) (AND (> PTX -2) (< PTX 6) (> PTY -2) (< PTY 6)))) (SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLARGUMENTS) '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-BUTTON-GET (DD W) (LET (CENT VAR) (PRINC "Enter button name: ") (SETQ VAR (READ)) (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) (LIST 'DRAW-BUTTON (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT))) (COPY-LIST '(4 4)) VAR 1))) (SETF (GET 'DRAW-BUTTON-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-BUTTON-GET 'GLFNRESULTTYPE) 'DRAW-BUTTON) (DEFUN DRAW-ERASE-DRAW (D W OFF) (LET ((GLVAR164 (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) (WINDOW-ERASE-AREA-XY W (CAR GLVAR164) (CADR GLVAR164) (CAADDR D) (CADR (CADDR D))))) (DEFUN DRAW-ERASE-SELECTEDP (D P OFF) (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) (AND (BETWEEN (CAR PT) (CAADR D) (+ (CAADR D) (CAADDR D))) (BETWEEN (CADR PT) (CADADR D) (+ (CADADR D) (CADR (CADDR D))))))) (SETF (GET 'DRAW-ERASE-SELECTEDP 'GLARGUMENTS) '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-ERASE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-ERASE-GET (DD W) (LET (BOX) (SETQ BOX (WINDOW-GET-REGION W)) (LIST 'DRAW-ERASE (CAR BOX) (CADR BOX) NIL 1))) (SETF (GET 'DRAW-ERASE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-ERASE-GET 'GLFNRESULTTYPE) 'DRAW-ERASE) (DEFUN DRAW-DOT-DRAW (D W OFF) (WINDOW-DRAW-DOT-XY W (+ 2 (+ (CAR OFF) (CAADR D))) (+ 2 (+ (CADR OFF) (CADADR D))))) (DEFUN DRAW-DOT-GET (DD W) (LET (CENT) (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) (LIST 'DRAW-DOT (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT))) (COPY-LIST '(4 4)) NIL 1))) (SETF (GET 'DRAW-DOT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-DOT-GET 'GLFNRESULTTYPE) 'DRAW-DOT) (DEFUN DRAW-REFPT-DRAW (D W OFF) (WINDOW-DRAW-CROSSHAIRS-XY W (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) (DEFUN DRAW-REFPT-SELECTEDP (D P OFF) (LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D))) (PTY (- (- (CADR P) (CADR OFF)) (CADADR D)))) (AND (> PTX -3) (< PTX 3) (> PTY -3) (< PTY 3)))) (SETF (GET 'DRAW-REFPT-SELECTEDP 'GLARGUMENTS) '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-REFPT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-REFPT-GET (DD W) (LET (CENT REFPT) (WHEN (SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD))) (LET ((GC (CADDR *DRAW-WINDOW*))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))) (DRAW-OBJECT-DRAW REFPT *DRAW-WINDOW* (COPY-LIST '(0 0))) (LET ((GC (CADDR *DRAW-WINDOW*))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) (SETF (CADDR DD) (REMOVE REFPT (CADDR DD)))) (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) (LIST 'DRAW-REFPT CENT (COPY-LIST '(0 0)) NIL 1))) (SETF (GET 'DRAW-REFPT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-REFPT-GET 'GLFNRESULTTYPE) 'DRAW-REFPT) (DEFUN DRAW-DESC-REFPT (DD) (LET (REFPT) (SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD))) (IF REFPT (CADR REFPT) (COPY-LIST '(0 0))))) (SETF (GET 'DRAW-DESC-REFPT 'GLARGUMENTS) '((DD DRAW-DESC))) (SETF (GET 'DRAW-DESC-REFPT 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-TEXT-DRAW (D W OFF) (LET ((SSTR (STRINGIFY (CADDDR D)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ (CAR OFF) (CAADR D)) (- (CADDDR W) (+ (CADR OFF) (CADADR D))) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN DRAW-TEXT-DRAW-OUTLINE (W X Y D) (SETF (SECOND D) (LIST X Y)) (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) (DEFUN DRAW-TEXT-DRAW-OUTLINE (W X Y D) (SETF (SECOND D) (LIST X Y)) (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) (DEFUN DRAW-TEXT-SELECTEDP (D PT OFF) (LET ((PTP (LIST (- (CAR PT) (CAR OFF)) (- (CADR PT) (CADR OFF))))) (AND (BETWEEN (CAR PTP) (+ -2 (+ (CAADR D) (MIN 0 (CAADDR D)))) (+ 2 (+ (+ (CAADR D) (MIN 0 (CAADDR D))) (ABS (CAADDR D))))) (BETWEEN (CADR PTP) (+ -2 (+ (CADADR D) (MIN 0 (CADR (CADDR D))))) (+ 2 (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) (ABS (CADR (CADDR D))))))))) (SETF (GET 'DRAW-TEXT-SELECTEDP 'GLARGUMENTS) '((D DRAW-TEXT) (PT VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-TEXT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) (DEFUN DRAW-TEXT-GET (DD W) (LET (TXT LNG OFF) (PRINC "Enter text string: ") (SETQ TXT (STRINGIFY (READ))) (SETQ LNG (LET ((SSTR (STRINGIFY TXT))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (SETQ OFF (WINDOW-GET-BOX-POSITION W LNG 14)) (LIST 'DRAW-TEXT (LET ((GLVAR167 (COPY-LIST '(0 4)))) (LIST (+ (CAR OFF) (CAR GLVAR167)) (+ (CADR OFF) (CADR GLVAR167)))) (LIST LNG 14) TXT 1))) (SETF (GET 'DRAW-TEXT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) (SETF (GET 'DRAW-TEXT-GET 'GLFNRESULTTYPE) 'DRAW-TEXT) (DEFUN DRAW-SNAPP (P1 OFF P2X P2Y) (IF (AND (< (ABS (- (- (CAR P1) (CAR OFF)) P2X)) 4) (< (ABS (- (- (CADR P1) (CADR OFF)) P2Y)) 4)) (LIST (+ (CAR OFF) P2X) (+ (CADR OFF) P2Y)))) (SETF (GET 'DRAW-SNAPP 'GLARGUMENTS) '((P1 VECTOR) (OFF VECTOR) (P2X INTEGER) (P2Y INTEGER))) (SETF (GET 'DRAW-SNAPP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-DOT-SNAP (D P OFF) (DRAW-SNAPP P OFF (+ 2 (CAADR D)) (+ 2 (CADADR D)))) (SETF (GET 'DRAW-DOT-SNAP 'GLARGUMENTS) '((D DRAW-DOT) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-DOT-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-REFPT-SNAP (D P OFF) (DRAW-SNAPP P OFF (CAADR D) (CADADR D))) (SETF (GET 'DRAW-REFPT-SNAP 'GLARGUMENTS) '((D DRAW-REFPT) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-REFPT-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-LINE-SNAP (D P OFF) (OR (DRAW-SNAPP P OFF (CAADR D) (CADADR D)) (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) (CADR (CADDR D)))))) (SETF (GET 'DRAW-LINE-SNAP 'GLARGUMENTS) '((D DRAW-LINE) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-LINE-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-BOX-SNAP (D P OFF) (LET ((XOFF (CAADR D)) (YOFF (CADADR D)) (XSIZE (CAADDR D)) (YSIZE (CADR (CADDR D)))) (OR (DRAW-SNAPP P OFF XOFF YOFF) (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF YSIZE)) (DRAW-SNAPP P OFF (+ XOFF XSIZE) YOFF) (DRAW-SNAPP P OFF XOFF (+ YOFF YSIZE)) (DRAW-SNAPP P OFF (+ XOFF (* 1/2 XSIZE)) YOFF) (DRAW-SNAPP P OFF XOFF (+ YOFF (* 1/2 YSIZE))) (DRAW-SNAPP P OFF (+ XOFF (* 1/2 XSIZE)) (+ YOFF YSIZE)) (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF (* 1/2 YSIZE)))))) (SETF (GET 'DRAW-BOX-SNAP 'GLARGUMENTS) '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-BOX-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-CIRCLE-SNAP (D P OFF) (OR (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (+ (CADADR D) (* 1/2 (CAADDR D)))) (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (CADADR D)) (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) (* 1/2 (CAADDR D)))) (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (+ (CADADR D) (CADR (CADDR D)))) (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) (* 1/2 (CAADDR D)))))) (SETF (GET 'DRAW-CIRCLE-SNAP 'GLARGUMENTS) '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-CIRCLE-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-ELLIPSE-SNAP (D P OFF) (OR (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (CADADR D)) (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (+ (CADADR D) (CADR (CADDR D)))) (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) (* 1/2 (CADR (CADDR D))))))) (SETF (GET 'DRAW-ELLIPSE-SNAP 'GLARGUMENTS) '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-ELLIPSE-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-RCBOX-SNAP (D P OFF) (LET ((RX (* 1/2 (CAADDR D))) (RY (* 1/2 (CADR (CADDR D))))) (OR (DRAW-SNAPP P OFF (+ (CAADR D) RX) (CADADR D)) (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) RY)) (DRAW-SNAPP P OFF (+ (CAADR D) RX) (+ (CADADR D) (CADR (CADDR D)))) (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) RY))))) (SETF (GET 'DRAW-RCBOX-SNAP 'GLARGUMENTS) '((D DRAW-RCBOX) (P VECTOR) (OFF VECTOR))) (SETF (GET 'DRAW-RCBOX-SNAP 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-NO-SNAP (D P OFF) NIL) (DEFUN DRAW-MULTI-DRAW (D W OFF) (LET ((TOTALOFF (LIST (+ (CAADR D) (CAR OFF)) (+ (CADADR D) (CADR OFF))))) (DOLIST (SUBD (CADDDR D)) (DRAW-OBJECT-DRAW SUBD W TOTALOFF)))) (DEFUN DRAW-INIT-MENUS () (LET ((W (DRAW-WINDOW))) (WINDOW-CLEAR W) (DOLIST (FN '(DRAW-MENU-RECTANGLE DRAW-MENU-CIRCLE DRAW-MENU-ELLIPSE DRAW-MENU-LINE DRAW-MENU-ARROW DRAW-MENU-DOT DRAW-MENU-BUTTON DRAW-MENU-TEXT)) (SETF (GET FN 'DISPLAY-SIZE) '(30 20))) (SETQ *DRAW-MENU-SET* (MENU-SET-CREATE W NIL)) (MENU-SET-ADD-MENU *DRAW-MENU-SET* 'DRAW NIL "Draw" '((DRAW-MENU-RECTANGLE . RECTANGLE) (DRAW-MENU-RCBOX . RCBOX) (DRAW-MENU-CIRCLE . CIRCLE) (DRAW-MENU-ELLIPSE . ELLIPSE) (DRAW-MENU-LINE . LINE) (DRAW-MENU-ARROW . ARROW) (DRAW-MENU-DOT . DOT) (" " . ERASE) (DRAW-MENU-BUTTON . BUTTON) (DRAW-MENU-TEXT . TEXT) (DRAW-MENU-REFPT . REFPT)) (LIST 0 0)) (MENU-SET-ADJUST *DRAW-MENU-SET* 'DRAW 'TOP NIL 1) (MENU-SET-ADJUST *DRAW-MENU-SET* 'DRAW 'RIGHT NIL 2) (MENU-SET-ADD-MENU *DRAW-MENU-SET* 'COMMAND NIL "Commands" '(("Done" . DONE) ("Move" . MOVE) ("Delete" . DELETE) ("Copy" . COPY) ("Redraw" . REDRAW) ("Origin" . ORIGIN) ("LaTex Mode" . LATEXMODE) ("Make Program" . PROGRAM) ("Make LaTex" . LATEX)) (LIST 0 0)) (MENU-SET-ADJUST *DRAW-MENU-SET* 'COMMAND 'TOP 'DRAW 5) (MENU-SET-ADJUST *DRAW-MENU-SET* 'COMMAND 'RIGHT NIL 2))) (DEFUN DRAW-MENU-RECTANGLE (W X Y) (WINDOW-DRAW-BOX-XY W (+ X 3) (+ Y 3) 24 14 1)) (DEFUN DRAW-MENU-RCBOX (W X Y) (WINDOW-DRAW-RCBOX-XY W (+ X 3) (+ Y 3) 24 14 3 1)) (DEFUN DRAW-MENU-CIRCLE (W X Y) (WINDOW-DRAW-CIRCLE-XY W (+ X 15) (+ Y 10) 8 1)) (DEFUN DRAW-MENU-ELLIPSE (W X Y) (WINDOW-DRAW-ELLIPSE-XY W (+ X 15) (+ Y 10) 12 8 1)) (DEFUN DRAW-MENU-LINE (W X Y) (WINDOW-DRAW-LINE-XY W (+ X 4) (+ Y 4) (+ X 26) (+ Y 16) 1)) (DEFUN DRAW-MENU-ARROW (W X Y) (WINDOW-DRAW-ARROW-XY W (+ X 4) (+ Y 4) (+ X 26) (+ Y 16) 1)) (DEFUN DRAW-MENU-DOT (W X Y) (WINDOW-DRAW-DOT-XY W (+ X 15) (+ Y 10))) (DEFUN DRAW-MENU-BUTTON (W X Y) (WINDOW-DRAW-BOX-XY W (+ X 14) (+ Y 5) 4 4 1)) (DEFUN DRAW-MENU-TEXT (W X Y) (WINDOW-PRINTAT-XY W "A" (+ X 12) (+ Y 5))) (DEFUN DRAW-MENU-REFPT (W X Y) (WINDOW-DRAW-CROSSHAIRS-XY W (+ X 15) (+ Y 9)) (WINDOW-DRAW-CIRCLE-XY W (+ X 15) (+ Y 9) 2)) (DEFUN LATEX-LINE (FROMX FROMY X Y &OPTIONAL ARROWFLG) (LET (DX DY SX SY SIZ ERR ERRB) (SETQ DX (- X FROMX)) (SETQ DY (- Y FROMY)) (IF (= DX 0) (PROGN (SETQ SX 0) (SETQ SY (IF (>= DY 0) 1 -1)) (SETQ SIZ (* (ABS DY) *DRAW-LATEX-FACTOR*))) (IF (= DY 0) (PROGN (SETQ SX (IF (>= DX 0) 1 -1)) (SETQ SY 0) (SETQ SIZ (* (ABS DX) *DRAW-LATEX-FACTOR*))) (PROGN (SETQ ERR 9999) (SETQ SIZ (* (ABS DX) *DRAW-LATEX-FACTOR*)) (DOTIMES (I (IF ARROWFLG 4 6)) (DOTIMES (J (IF ARROWFLG 4 6)) (SETQ ERRB (ABS (- (/ (FLOAT (1+ I)) (FLOAT (1+ J))) (ABS (/ (FLOAT DX) (FLOAT DY)))))) (IF (AND (= (GCD (1+ I) (1+ J)) 1) (< ERRB ERR)) (PROGN (SETQ ERR ERRB) (SETQ SX (1+ I)) (SETQ SY (1+ J)))))) (SETQ SX (* SX (LATEX-SIGN DX))) (SETQ SY (* SY (LATEX-SIGN DY)))))) (FORMAT T " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%" (* FROMX *DRAW-LATEX-FACTOR*) (* FROMY *DRAW-LATEX-FACTOR*) (IF ARROWFLG "vector" "line") SX SY SIZ))) (DEFUN LATEX-SIGN (X) (IF (>= X 0) 1 -1)) (DEFUN DRAW-OUTPUT (OUTFILENAME &OPTIONAL NAMES) (PROG (PRETTYSAVE LENGTHSAVE D FNNAME CODE) (OR NAMES (SETQ NAMES *DRAW-OBJECTS*)) (IF (SYMBOLP NAMES) (SETQ NAMES (LIST NAMES))) (WITH-OPEN-FILE (OUTFILE OUTFILENAME :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE) (SETQ PRETTYSAVE *PRINT-PRETTY*) (SETQ LENGTHSAVE *PRINT-LENGTH*) (SETQ *PRINT-PRETTY* T) (SETQ *PRINT-LENGTH* 80) (FORMAT OUTFILE "; ~A ~A~%" OUTFILENAME (DRAW-GET-TIME-STRING)) (DOLIST (NAME NAMES) (IF (SETQ D (GET NAME 'DRAW-DESCR)) (PROGN (TERPRI OUTFILE) (PRINT (LIST 'SETF (LIST 'GET (LIST 'QUOTE NAME) ''DRAW-DESCR) (LIST 'QUOTE D)) OUTFILE) (IF (AND (SETQ FNNAME (DRAW-DESC-FNNAME D)) (SETQ CODE (SYMBOL-FUNCTION FNNAME))) (PROGN (TERPRI OUTFILE) (PRINT (CONS 'DEFUN (IF (EQ (CAR CODE) 'LAMBDA-BLOCK) (CDR CODE) (CONS FNNAME (CDR CODE)))) OUTFILE))))) (IF (SETQ D (GET NAME 'PICMENU-SPEC)) (PROGN (TERPRI OUTFILE) (PRINT (LIST 'SETF (LIST 'GET (LIST 'QUOTE NAME) ''PICMENU-SPEC) (LIST 'QUOTE D)) OUTFILE)))) (TERPRI OUTFILE) (SETQ *PRINT-PRETTY* PRETTYSAVE) (SETQ *PRINT-LENGTH* LENGTHSAVE)) (RETURN OUTFILENAME))) (DEFUN DRAW-GET-TIME-STRING () (LET (SECOND MINUTE HOUR DATE MONTH YEAR) (MULTIPLE-VALUE-SETQ (SECOND MINUTE HOUR DATE MONTH YEAR) (GET-DECODED-TIME)) (FORMAT NIL "~2D ~A ~4D ~2D:~2D:~2D" DATE (NTH (1- MONTH) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) YEAR HOUR MINUTE SECOND))) (DEFUN COMPILE-DRAW () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") '("glisp/menu-set.lsp" "glisp/draw.lsp") "glisp/drawtrans.lsp" "glisp/draw-header.lsp") (CF DRAWTRANS)) (DEFUN COMPILE-DRAWB () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/menu-set.lsp" "glisp/draw.lsp") "glisp/drawtrans.lsp" "glisp/draw-header.lsp")) (DEFUN DRAW-OUT (&OPTIONAL NAMES FILE) (OR NAMES (SETQ NAMES *DRAW-OBJECTS*)) (IF (NOT (CONSP NAMES)) (SETQ NAMES (LIST NAMES))) (DRAW-OUTPUT (OR FILE "glisp/draw.del") NAMES) (SETQ *DRAW-OBJECTS* (SET-DIFFERENCE *DRAW-OBJECTS* NAMES)) NAMES) gcl-2.6.14/xgcl-2/gcl_X10.lsp0000644000175000017500000000237314360276512014011 0ustar cammcamm(in-package :XLIB) ; X10.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. (defconstant VertexRelative #x01 ) ;; else absolute (defconstant VertexDontDraw #x02 ) ;; else draw (defconstant VertexCurved #x04 ) ;; else straight (defconstant VertexStartClosed #x08 ) ;; else not (defconstant VertexEndClosed #x10 ) ;; else not gcl-2.6.14/xgcl-2/gcl_lispserver.lsp0000644000175000017500000001074614360276512015642 0ustar cammcamm; lispserver.lsp Gordon S. Novak Jr. ; 26 Jan 06 ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; 06 Jun 02 ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu ;------------------------------------------------------------------------ ; This is an example of a simple interactive graphical interface ; to a Lisp program. It reads Lisp expressions from the user, ; evaluates them, and prints the result. ; Stand-alone usage using XGCL (edit file paths as appropriate): ; (load "/u/novak/X/xgcl-2/dwsyms.lsp") ; (load "/u/novak/X/xgcl-2/dwimports.lsp") ; (load "/u/novak/X/solaris/dwtrans.o") ; (load "/u/novak/glisp/menu-settrans.lsp") ; (load "/u/novak/glisp/lispservertrans.lsp") ; (lisp-server) ; Usage with the WeirdX Java emulation of an X server begins with ; the web page example.html and uses the files lispserver.cgi , ; nph-lisp-action.cgi , and lispdemo.lsp . ;------------------------------------------------------------------------ (defvar *wio-window* nil) (defvar *wio-window-width* 500) (defvar *wio-window-height* 300) (defvar *wio-menu-set* nil) (defvar *wio-font* '8x13) (glispglobals (*wio-window* window) (*wio-window-width* integer) (*wio-window-height* integer) (*wio-menu-set* menu-set) ) (defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) ; 18 Apr 95; 20 Apr 95; 08 May 95; 31 May 02 ; Make a window to use. (setf (glfnresulttype 'wio-window) 'window) (defun wio-window (&optional title width height (posx 0) (posy 0) font) (if width (setq *wio-window-width* width)) (if height (setq *wio-window-height* height)) (or *wio-window* (setq *wio-window* (window-create *wio-window-width* *wio-window-height* title nil posx posy font))) ) ; 19 Apr 95 (defun wio-init-menus (w commands) (let () (window-clear w) (setq *wio-menu-set* (menu-set-create w nil)) (menu-set-add-menu *wio-menu-set* 'command nil "Commands" commands (list 0 0)) (menu-set-adjust *wio-menu-set* 'command 'top nil 2) (menu-set-adjust *wio-menu-set* 'command 'right nil 2) )) ; 19 Apr 95; 20 Apr 95; 25 Apr 95; 02 May 95; 29 May 02 ; Lisp server example (gldefun lisp-server () (let (w inputm done sel (redraw t) str result) (w = (wio-window "Lisp Server")) (open w) (clear w) (set-font w *wio-font*) (wio-init-menus w '(("Quit" . quit))) (window-print-lines w '("Click mouse in the input box, then enter" "a Lisp expression followed by Return." "" "Input: e.g. (+ 3 4) or (sqrt 2)") 10 (- *wio-window-height* 20)) (window-printat-xy w "Result:" 10 (- *wio-window-height* 150)) (inputm = (textmenu-create (- *wio-window-width* 100) 30 nil w 20 (- *wio-window-height* 110) t t '9x15 t)) (add-item *wio-menu-set* 'input nil inputm) (while ~ done do (sel = (menu-set-select *wio-menu-set* redraw)) (redraw = nil) (case (menu-name sel) (command (case (port sel) (quit (done = t)) )) (input (str = (port sel)) (result = (catch 'error (eval (safe-read-from-string str)))) (erase-area-xy w 20 2 (- *wio-window-width* 20) (- *wio-window-height* 160)) (window-print-line w (write-to-string result :pretty t) 20 (- *wio-window-height* 170))) ) ) (close w) )) ; 25 Apr 95; 14 Mar 01 (defun safe-read-from-string (str) (if (and (stringp str) (> (length str) 0)) (read-from-string str nil 'read-error))) (defun compile-lispserver () (glcompfiles *directory* '("glisp/vector.lsp") ; auxiliary files '("glisp/lispserver.lsp") ; translated files "glisp/lispservertrans.lsp") ; output file ) gcl-2.6.14/xgcl-2/makefile0000644000175000017500000000252614360276512013574 0ustar cammcamm-include ../makedefs all: objects #docs objects: $(LISP) echo '(load "sysdef.lisp")(load "sys-proclaim.lisp")(xlib::compile-xgcl)' | $(LISP) saved_xgcl: $(LISP) echo '(load "sysdef.lisp")(load "sys-proclaim.lisp")(xlib::compile-xgcl)(xlib::save-xgcl "$@")' | $(LISP) sys-proclaim.lisp: echo '(load "sysdef.lisp")(compiler::emit-fn t)(xlib::compile-xgcl)(compiler::make-all-proclaims "*.fn")' | $(LISP) docs: dwdoc/dwdoccontents.html dwdoc.pdf dwdoc/dwdoccontents.html: $(LISP) mkdir -p $(@D) && \ cd $(@D) && \ echo '(load "../sysdef.lisp")(in-package :xlib)(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms))(load "../gcl_tohtml.lsp")(load "../gcl_index.lsp")(tohtml "../dwdoc.tex" "dwdoc")(with-open-file (s "dwdoccontents.html" :direction :output) (let ((*standard-output* s)) (xlib::makecont "../dwdoc.tex" 1 "dwdoc")))(with-open-file (s "dwdocindex.html" :direction :output) (let ((*standard-output* s)) (xlib::printindex indexdata "dwdoc")))' | ../$< dwdoc.pdf: dwdoc.tex pdflatex $< clean: rm -f *.o *.data saved_* cmpinclude.h dwdoc.aux dwdoc.log gmon.out rm -f gcl*c gcl*h gcl*data gcl_xrecompile* user-init* *fn clean-docs: rm -rf dwdoc dwdoc.pdf install: -mkdir -p $(DESTDIR)$(INFO_DIR)../doc -cp -r dwdoc $(DESTDIR)$(INFO_DIR)../doc -cp *tex *.pdf $(DESTDIR)$(INFO_DIR)../doc #.INTERMEDIATE: saved_xgcl gcl-2.6.14/xgcl-2/gcl_lispservertrans.lsp0000644000175000017500000001004414360276512016701 0ustar cammcamm; 27 Jan 2006 14:38:08 CST ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA (DEFVAR *WIO-WINDOW* NIL) (DEFVAR *WIO-WINDOW-WIDTH* 500) (DEFVAR *WIO-WINDOW-HEIGHT* 300) (DEFVAR *WIO-MENU-SET* NIL) (DEFVAR *WIO-FONT* '8X13) (DEFVAR *WIO-WINDOW*) (SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVAR) T) (SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVARTYPE) 'WINDOW) (DEFVAR *WIO-WINDOW-WIDTH*) (SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVAR) T) (SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVARTYPE) 'INTEGER) (DEFVAR *WIO-WINDOW-HEIGHT*) (SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVAR) T) (SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVARTYPE) 'INTEGER) (DEFVAR *WIO-MENU-SET*) (SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVAR) T) (SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET) (DEFMACRO WHILE (TEST &REST FORMS) (LIST* 'LOOP (LIST 'UNLESS TEST '(RETURN)) FORMS)) (SETF (GET 'WIO-WINDOW 'GLFNRESULTTYPE) 'WINDOW) (DEFUN WIO-WINDOW (&OPTIONAL TITLE WIDTH HEIGHT (POSX 0) (POSY 0) FONT) (IF WIDTH (SETQ *WIO-WINDOW-WIDTH* WIDTH)) (IF HEIGHT (SETQ *WIO-WINDOW-HEIGHT* HEIGHT)) (OR *WIO-WINDOW* (SETQ *WIO-WINDOW* (WINDOW-CREATE *WIO-WINDOW-WIDTH* *WIO-WINDOW-HEIGHT* TITLE NIL POSX POSY FONT)))) (DEFUN WIO-INIT-MENUS (W COMMANDS) (LET () (WINDOW-CLEAR W) (SETQ *WIO-MENU-SET* (MENU-SET-CREATE W NIL)) (MENU-SET-ADD-MENU *WIO-MENU-SET* 'COMMAND NIL "Commands" COMMANDS (LIST 0 0)) (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'TOP NIL 2) (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'RIGHT NIL 2))) (DEFUN LISP-SERVER () (LET (W INPUTM DONE SEL (REDRAW T) STR RESULT) (SETQ W (WIO-WINDOW "Lisp Server")) (WINDOW-OPEN W) (WINDOW-CLEAR W) (WINDOW-SET-FONT W *WIO-FONT*) (WIO-INIT-MENUS W '(("Quit" . QUIT))) (WINDOW-PRINT-LINES W '("Click mouse in the input box, then enter" "a Lisp expression followed by Return." "" "Input: e.g. (+ 3 4) or (sqrt 2)") 10 (+ -20 *WIO-WINDOW-HEIGHT*)) (WINDOW-PRINTAT-XY W "Result:" 10 (+ -150 *WIO-WINDOW-HEIGHT*)) (SETQ INPUTM (TEXTMENU-CREATE (+ -100 *WIO-WINDOW-WIDTH*) 30 NIL W 20 (+ -110 *WIO-WINDOW-HEIGHT*) T T '9X15 T)) (MENU-SET-ADD-ITEM *WIO-MENU-SET* 'INPUT NIL INPUTM) (WHILE (NOT DONE) (SETQ SEL (MENU-SET-SELECT *WIO-MENU-SET* REDRAW)) (SETQ REDRAW NIL) (CASE (CADR SEL) (COMMAND (CASE (CAR SEL) (QUIT (SETQ DONE T)))) (INPUT (SETQ STR (CAR SEL)) (SETQ RESULT (CATCH 'ERROR (EVAL (SAFE-READ-FROM-STRING STR)))) (WINDOW-ERASE-AREA-XY W 20 2 (+ -20 *WIO-WINDOW-WIDTH*) (+ -160 *WIO-WINDOW-HEIGHT*)) (WINDOW-PRINT-LINE W (WRITE-TO-STRING RESULT :PRETTY T) 20 (+ -170 *WIO-WINDOW-HEIGHT*))))) (WINDOW-CLOSE W))) (DEFUN SAFE-READ-FROM-STRING (STR) (IF (AND (STRINGP STR) (> (LENGTH STR) 0)) (READ-FROM-STRING STR NIL 'READ-ERROR))) (DEFUN COMPILE-LISPSERVER () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp") '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp" "glisp/gpl.txt")) (DEFUN COMPILE-LISPSERVERB () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp" "glisp/gpl.txt")) gcl-2.6.14/xgcl-2/Xutil-2.c0000644000175000017500000000372214360276512013503 0ustar cammcamm/* Xutil-2.c Hiep Huu Nguyen 27 Aug 92 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. */ #include #include #include int IsKeypadKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_KP_Space) && ((unsigned)(keysym) <= XK_KP_Equal));} int IsCursorKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_Home) && ((unsigned)(keysym) < XK_Select));} int IsPFKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_KP_F1) && ((unsigned)(keysym) <= XK_KP_F4));} int IsFunctionKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_F1) && ((unsigned)(keysym) <= XK_F35));} int IsMiscFunctionKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_Select) && ((unsigned)(keysym) < XK_KP_Space));} int IsModifierKey(keysym) int keysym; { return (((unsigned)(keysym) >= XK_Shift_L) && ((unsigned)(keysym) <= XK_Hyper_R));} int XUniqueContext() { return( ((int)XrmUniqueQuark()) ); } int XStringToContext(string) char *string; { return( (int)XrmStringToQuark(string) ); } gcl-2.6.14/xgcl-2/dec.copyright0000644000175000017500000000235114360276512014555 0ustar cammcamm;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** gcl-2.6.14/xgcl-2/gcl_dwtest.lsp0000644000175000017500000001551114360276512014751 0ustar cammcamm; dwtest.lsp Gordon S. Novak Jr. 10 Jan 96 ; Some examples for testing the window interface in dwindow.lsp / dwtrans.lsp ; Copyright (c) 1996 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (use-package :xlib) (defun user::xgcl-demo nil (wtesta) (wtestb) (format t "Try (wtestc) ... (wtestk) for more examples.")) (defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) (defvar *myw*) ; my window (defvar myw) ; Make a window to play in. (defun wtesta () (setq myw (setq *myw* (window-create 300 300 "test window"))) ) ; 15 Aug 91; 12 Sep 91; 05 Oct 94; 06 Oct 94 ; Draw some basic things in the window (defun wtestb () (window-clear *myw*) (window-draw-box-xy *myw* 50 50 50 20 1) (window-printat *myw* "howdy" '(58 55)) (window-draw-line *myw* '(100 70) '(200 170)) (window-draw-arrow-xy *myw* 200 170 165 205) (window-draw-circle-xy *myw* 200 170 50 2) (window-draw-ellipse-xy *myw* 100 170 40 20 1) (window-printat-xy *myw* "ellipse" 70 165) (window-draw-arc-xy *myw* 100 250 20 20 0 90 1) (window-draw-arc-xy *myw* 100 250 20 20 0 -90 1) (window-printat-xy *myw* "arcs" 80 244) (window-printat-xy *myw* "invert" 54 200) (window-invert-area-xy *myw* 50 160 60 60) (window-copy-area-xy *myw* 40 150 200 50 60 40) (window-printat-xy *myw* "copy" 210 100) (window-set-color-rgb *myw* 65535 0 0) ; red foreground (window-printat-xy *myw* "Red" 20 20) (window-draw-rcbox-xy *myw* 15 15 32 20 5) (window-set-color-rgb *myw* 0 0 65535 t) ; blue background (window-set-color-rgb *myw* 0 65535 0) ; green foreground (window-printat-xy *myw* "Green" 120 20) (window-set-color-rgb *myw* 0 65535 0 t) ; green background (window-set-color-rgb *myw* 0 0 65535) ; blue foreground (window-printat-xy *myw* "Blue" 220 20) (window-reset-color *myw*) (window-force-output *myw*) ) ; 15 Aug 91; 19 Aug 91; 03 Sep 91; 21 Apr 95 ; Illustrate mouse interaction: ; click in window *myw* (2 times for line, 3 times for region). (defun wtestc () (let (mymenu result start done) (setq mymenu (menu-create '(quit point line box region) "Choose One:")) (while (not done) (setq result (case (menu-select mymenu) (quit (setq done t)) (point (window-get-point *myw*)) (line (setq start (window-get-point *myw*)) (list start (window-get-line-position *myw* (car start) (cadr start)))) (box (window-get-box-position *myw* 40 20)) (region (window-get-region *myw*)) )) (format t "Result: ~A~%" result) ) (menu-destroy mymenu) )) ; 09 Sep 91 ; Illustrate icons in menus (defun wtestd () (menu '(("Triangle" . triangle) (dwtest-square . square) (dwtest-circle . circle) hexagon) "Icons in Menu") ) (defun dwtest-square (w x y) (window-draw-box-xy w x y 20 20 1)) (setf (get 'dwtest-square 'display-size) '(20 20)) (defun dwtest-circle (w x y) (window-draw-circle-xy w (+ x 10) (+ y 10) 10 1)) (setf (get 'dwtest-circle 'display-size) '(20 20)) (defvar mypms nil) ; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91 ; Illustrate a diagrammatic menu-like object: square with sensitive spots (defun wteste () (let (pm val) (or mypms (mypms-init)) (setq pm (picmenu-create-from-spec mypms "Points on Square")) (setq val (picmenu-select pm)) (picmenu-destroy pm) val )) ; 14 Sep 91 (defun mypms-init () (setq mypms (picmenu-create-spec '((bottom-left ( 20 20)) (center-left ( 20 70)) (top-left ( 20 120)) (bottom-center ( 70 20)) (center ( 70 70) (20 20)) ; larger (top-center ( 70 120)) (bottom-right (120 20)) (center-right (120 70)) (top-right (120 120))) 140 140 'wteste-draw-square t)) ) (defvar mypm nil) ; 10 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91; 17 Sep 91 ; A picmenu that is "flat" within another window, in this case *myw*. ; Must do (wtesta) first. (defun wtestf () (or mypms (mypms-init)) (or mypm (setq mypm (picmenu-create-from-spec mypms "Points on Square" *myw* 50 50 nil t t))) (picmenu-select mypm)) (defun wteste-draw-square (w x y) (window-draw-box-xy w (+ x 20) (+ y 20) 100 100 1)) (defvar mym nil) ; 10 Sep 91; 17 Sep 91 ; A menu that is "flat" within another window, in this case *myw*. ; Must do (wtesta) first. (defun wtestg () (or mym (setq mym (menu-create '(red white blue) "Flag" *myw* 50 50 nil t))) (menu-select mym)) ; 09 Oct 91 ; Demonstrate arrows. Optional arg is line width. (defun wtesth ( &optional (lw 1)) (window-clear *myw*) (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 160 lw)) (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 40 lw)) (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 40 (+ 40 (* i 30)) lw)) (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 160 (+ 40 (* i 30)) lw)) (dotimes (i 5) (window-draw-arrow-xy *myw* 200 (+ 40 (* i 30)) 240 (+ 40 (* i 30)) (1+ i) )) (window-force-output *myw*) ) ; 04 Jan 94 ; Redo some of the arrows from wtesth in color (defun wtesti () (window-set-color-rgb *myw* 65535 0 0) (window-draw-arrow-xy *myw* 200 70 240 70 2) (window-set-color-rgb *myw* 0 65535 0) (window-draw-arrow-xy *myw* 200 100 240 100 3) (window-set-color-rgb *myw* 0 0 65535) (window-draw-arrow-xy *myw* 200 130 240 130 4) (window-reset-color *myw*) (window-force-output *myw*) ) ; 04 Jan 94 ; Get text from a window. Move mouse pointer into test window. ; Add characters and/or backspace, Return. ; Note: it might be necessary to change the keyboard mapping, using ; (window-init-keyboard-mapping *myw*) and (window-print-keyboard-mapping) (defun wtestj () (window-input-string *myw* "Foo" 50 200 200)) ; 04 Jan 94 ; Change foreground and background colors and input a string (defun wtestk () (window-set-color-rgb *myw* 0 65535 0) ; green foreground (window-set-color-rgb *myw* 0 0 65535 t) ; blue background (prog1 (window-input-string *myw* "Foo" 50 200 200) (window-reset-color *myw*) (window-force-output *myw*) ) ) gcl-2.6.14/xgcl-2/gcl_init_xgcl.lsp0000644000175000017500000001111514360276512015413 0ustar cammcamm; Copyright (c) 1994 William F. Schelter ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. (in-package :XLIB) (in-package "COMPILER") (in-package "SYSTEM") (defvar *command-args* nil) (in-package "USER") (in-package "LISP") (lisp::in-package "SLOOP") ;;Appropriate for Austin #-winnt (setq SYSTEM:*DEFAULT-TIME-ZONE* 6) #+winnt (setq SYSTEM:*DEFAULT-TIME-ZONE* (GET-SYSTEM-TIME-ZONE)) (in-package "USER") (progn (allocate 'cons 100) (allocate 'string 40) (system:init-system) (gbc t) (si::multiply-bignum-stack 25) (or si::*link-array* (setq si::*link-array* (make-array 500 :element-type 'fixnum :fill-pointer 0))) (use-fast-links t) (setq compiler::*cmpinclude* "") (load #"../cmpnew/cmpmain.lsp") (gbc t) (load #"../cmpnew/lfun_list.lsp") (gbc t) (load #"../cmpnew/cmpopt.lsp") (gbc t) (load #"../lsp/auto.lsp") (gbc t) (defun si::src-path (x) (si::string-concatenate (or si::*lib-directory* "GCLDIR/") x)) (when compiler::*cmpinclude-string* (with-open-file (st "../h/cmpinclude.h") (let ((tem (make-array (file-length st) :element-type 'standard-char :static t))) (if (si::fread tem 0 (length tem) st) (setq compiler::*cmpinclude-string* tem))))) ;;compile-file is in cmpmain.lsp (setf (symbol-function 'si:clear-compiler-properties) (symbol-function 'compiler::compiler-clear-compiler-properties)) ; (load "../lsp/setdoc.lsp") (setq system::*old-top-level* (symbol-function 'system:top-level)) (defvar si::*command-args* nil) (defun si::get-command-arg (a &optional val-if-there) ;; return non nil if a is in si::*command-args* and return ;; the string which is after it if there is one" (let ((tem (member a si::*command-args* :test 'equal))) (if tem (or val-if-there (cadr tem) t)))) (defvar si::*lib-directory* nil) (defun system::gcl-top-level (&aux tem) (dotimes (i (si::argc)) (setq si::*command-args* (cons (si::argv i) si::*command-args*))) (setq si::*command-args* (nreverse si::*command-args* )) (setq si::*system-directory* (or (si::get-command-arg "-dir") (car si::*command-args*))) (setq si::*lib-directory* (si::get-command-arg "-libdir")) (when (si::get-command-arg "-compile") (let ((system::*quit-tag* (cons nil nil)) (system::*quit-tags* nil) (system::*break-level* '()) (system::*break-env* nil) (system::*ihs-base* 1) (system::*ihs-top* 1) (system::*current-ihs* 1) (*break-enable* nil)) (system:error-set '(progn (compile-file (si::get-command-arg "-compile") :output-file (or (si::get-command-arg "-o") (si::get-command-arg "-compile")) :o-file (not (si::get-command-arg "-no-o" t)) :c-file (si::get-command-arg "-system-p" t) :h-file (si::get-command-arg "-system-p" t) :data-file (si::get-command-arg "-system-p" t) :system-p (si::get-command-arg "-system-p" t)))) (bye (if compiler::*error-p* 1 0)))) (format t "GCL (GNU Common Lisp) ~A~%~a~%~a~%" "DATE" "Licensed under GNU Public Library License" "Contains Enhancements by W. Schelter") (setq si::*ihs-top* 1) (in-package 'system::user) (incf system::*ihs-top* 2) (funcall system::*old-top-level*)) (setq si::*gcl-version* 600) (defun lisp-implementation-version nil (format nil "1-~a" si::*gcl-version*)) (setq si:*inhibit-macro-special* t) ;(setq *modules* nil) (gbc t) (system:reset-gbc-count) (allocate 'cons 200) (defun system:top-level nil (system::gcl-top-level)) (unintern 'system) (unintern 'lisp) (unintern 'compiler) (unintern 'user) (si::chdir "/d19/staff/wfs/novak-xgcl")(user::user-init)(si::save-system "saved_xgcl") (if (fboundp 'user-init) (user-init)) (system:save-system "saved_gcl") (bye) (defun system:top-level nil (system::gcl-top-level)) (save "saved_gcl") (bye)) gcl-2.6.14/xgcl-2/gcl_tohtml.lsp0000644000175000017500000004125314360276512014750 0ustar cammcamm; tohtml.lsp Gordon S. Novak Jr. ; 13 Jan 06 ; Translate LaTex file to HTML web pages ; Make table of contents for LaTex files of slides ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; 21 Aug 00; 07 Sep 00; 11 Sep 00; 07 Dec 00; 24 Jul 02; 25 Jul 02; 29 Jul 02 ; 12 Feb 03; 28 Aug 03; 29 Aug 03; 15 Jan 04; 11 May 04; 29 Aug 05 ; This program converts a LaTeX file into one or more HTML files. ; The HTML file may need some minor hand editing. ; The program produces a new file in response to \pagebreak ; and puts in links to other pages. ; I have used it to put class lecture slides on the web; ; see http://www.cs.utexas.edu/users/novak/cs375contents.html ; See the README for notes on how this is all created. ; See also the file index.lsp for making indexes. ; To use: ; Start Lisp: e.g. /p/bin/gcl ; (load "tohtml.lsp") ; To translate LaTeX to HTML web pages: ; (tohtml "myfile.tex" "myprefix" ) ; where "myfile.tex" = LaTeX file ; "myprefix" = file name prefix for HTML files ; = number of first page if not 1 ; \setcounter{page} will override this ; To make contents: ; The contents program looks for header lines, which ; in my files look something like: ; \begin{center} {\bf Lexical Analysis} \end{center} ; (makecont "myfile.tex" ) ; where "myfile.tex" = LaTeX file ; = number of first page if not 1 ; = t for html output, nil for LaTeX output ; 22 Aug 97; 28 Apr 00; 07 Aug 00; 08 Aug 00; 17 Aug 00; 18 Aug 00; 07 Dec 00 ; 24 Jul 02; 26 Aug 03; 28 Aug 03; 11 Jan 05 ; Make a contents list for a file of LaTex slides ; n is first page number: required if first page is not 1. ; html is prefix string to make html contents (in-package 'xlib) (defvar *line*) (defvar *ptr*) (defvar *lng*) (defun makecont (filenm &optional (n 1) html) (let (line ptr lng done depth pagebr lastbr doit (first t)) (with-open-file (infile filenm :direction :input :if-does-not-exist nil) (while (not (or (null infile) (eq (setq line (read-line infile nil 'zzeofvalue)) 'zzeofvalue) )) (setq lng (length line)) (setq lastbr pagebr) (setq pagebr (and (>= lng 10) (string= line "\\pagebreak" :end1 10))) (if (and pagebr (not first)) (incf n)) (when (and (> lng 18) (string= line "\\setcounter{page}{" :end1 18)) (setq *line* line) (setq *lng* lng) (setq *ptr* 18) (setq n (parse-int))) (when (and (> lng 20) (string= line "\\addtocounter{page}{" :end1 20)) (setq *line* line) (setq *lng* lng) (setq *ptr* 20) (setq n (+ n (parse-int))) ) (setq doit nil) (if (and (> lng 30) (or (string= line "\\begin{center} {\\bf " :end1 20) (string= line "\\begin{center} {\\bf " :end1 21))) (progn (setq doit t) (setq ptr 20)) ) (if (and (> lng 6) lastbr (string= line "{\\bf " :end1 5)) (progn (setq doit t) (setq ptr 5)) ) (when doit (setq first nil) (if html (format t "~D. " html n n)) (setq lng (length line)) (setq done nil) (setq depth 0) (if (char= (char line ptr) #\Space) (incf ptr)) (while (and (< ptr lng) (not done)) (if (char= (char line ptr) #\\) (if (string= line "\\index" :start1 ptr :end1 (min lng (+ ptr 6))) (progn (while (and (< ptr lng) (not (char= (char line ptr) #\}))) (incf ptr)) (incf ptr)))) (if (char= (char line ptr) #\{) (progn (incf depth) (princ (char line ptr))) (if (char= (char line ptr) #\}) (if (> depth 0) (progn (decf depth) (princ (char line ptr))) (setq done t)) (princ (char line ptr))) ) (incf ptr)) (if html (format t "

~%") (format t "~60T& ~D \\\\~%" n)) ) ) ) )) (defvar *prefix* "") (defvar *feof* nil) (defvar *done* nil) (defvar *pagenumber* 0) (defvar *firstpage* 1) (defvar *lastpage* 999) (defvar *center* nil) (defvar *modestack* nil) (defvar *verbatim* nil) (defvar *ignore* t) (defvar *specials* nil) ; ¬in &there4 &nsub © ° (setq *specials* '(("pm" "±") ("cdot" "·") ("cap" "&cap") ("cup" "&cup") ("vee" "&or") ("wedge" "&and") ("leq" "&le") ("geq" "&ge") ("subset" "&sub") ("subseteq" "&sube") ("supset" "&sup") ("supseteq" "&supe") ("in" "&isin") ("perp" "&perp") ("cong" "&cong") ("sim" "&tilde") ("neq" "&ne") ("mid" "|") ("leftarrow" "&larr") ("rightarrow" "&rarr") ("leftrightarrow" "&harr") ("Leftarrow" "&lArr") ("Rightarrow" "&rArr") ("Leftrightarrow" "&hArr") ("uparrow" "&uarr") ("downarrow" "&darr") ("surd" "&radic ") ("emptyset" "&empty") ("forall" "&forall") ("exists" "&exist") ("neg" "¬") ("Box" "□") ("models" "⊨") ("vdash" "⊢") ("filledBox" "■") ("sum" "&sum") ("prod" "&prod") ("int" "&int") ("infty" "&infin") ("times" "X") ("sqrt" "&radic ") ("ll" "< < ") ("alpha" "&alpha") ("beta" "&beta") ("gamma" "&gamma") ("delta" "&delta") ("epsilon" "&epsilon") ("zeta" "&zeta") ("eta" "&eta") ("theta" "&theta") ("iota" "&iota") ("kappa" "&kappa") ("lambda" "&lambda") ("mu" "&mu") ("nu" "&nu") ("xi" "&xi") ("pi" "&pi") ("rho" "&rho") ("sigma" "&sigma") ("tau" "&tau") ("upsilon" "&upsilon") ("phi" "&phi") ("chi" "&chi") ("psi" "&psi") ("omega" "&omega") ("Alpha" "&Alpha") ("Beta" "&Beta") ("Gamma" "&Gamma") ("Delta" "&Delta") ("Epsilon" "&Epsilon") ("Zeta" "&Zeta") ("Eta" "&Eta") ("Theta" "&Theta") ("Iota" "&Iota") ("Kappa" "&Kappa") ("Lambda" "&Lambda") ("Mu" "&Mu") ("Nu" "&Nu") ("Xi" "&Xi") ("Pi" "&Pi") ("Rho" "&Rho") ("Sigma" "&Sigma") ("Tau" "&Tau") ("Upsilon" "&Upsilon") ("Phi" "&Phi") ("Chi" "&Chi") ("Psi" "&Psi") ("Omega" "&Omega") ("vert" "|") ) ) ; 28 Apr 00; 07 Aug 00 ; Translate a file of LaTex slides to HTML ; prefix is a prefix string for output files ; pagenumber is first page number. (defun tohtml (filenm prefix &optional (pagenumber 1)) (let (c) (setq *pagenumber* pagenumber) (setq *prefix* (stringify prefix)) (setq *feof* nil) (setq *ignore* t) (setq *center* nil) (setq *modestack* nil) (setq *verbatim* nil) (with-open-file (infile filenm :direction :input :if-does-not-exist nil) ; skip initial stuff (while (and *ignore* (not (or (null infile) (eq (setq *line* (read-line infile nil 'zzeofvalue)) 'zzeofvalue) ))) (setq *lng* (length *line*)) (setq *ptr* 0) (while (< *ptr* *lng*) (setq c (char *line* *ptr*)) (incf *ptr*) (if (and (char= c #\%) (not *verbatim*)) (flushline) (if (char= c #\\) (if (alpha-char-p (safe-char)) (docommand nil) ) ) ) ) ) (while (not *feof*) (dohtml infile)) ) )) ; 08 Aug 00; 18 Aug 00; 21 Aug 00; 07 Sep 00; 24 Jul 02; 25 Jul 02; 13 Jan 06 ; Process input to produce one .html file (defvar c) (defun dohtml (infile) (let (c) (setq *done* nil) (with-open-file (outfile (concatenate 'string *prefix* (stringify *pagenumber*) ".html") :direction :output :if-exists :supersede) (princ " " outfile) (princ *prefix* outfile) (princ " p. " outfile) (princ (stringify *pagenumber*) outfile) (princ " " outfile) (terpri outfile) (princ "" outfile) (terpri outfile) (terpri outfile) (while (not (or *done* *feof* (setq *feof* (eq (setq *line* (read-line infile nil 'zzeofvalue)) 'zzeofvalue)))) (doline outfile) (terpri outfile) ) ; *pagenumber* is too large by 1 at this point... (if *feof* (incf *pagenumber*)) (format outfile "Contents   ~%" *prefix*) (if (>= *pagenumber* (+ *firstpage* 11)) (format outfile "Page-10   ~%" *prefix* (- *pagenumber* 11))) (if (>= *pagenumber* (+ *firstpage* 2)) (format outfile "Prev   ~%" *prefix* (- *pagenumber* 2))) (if (<= *pagenumber* *lastpage*) (format outfile "Next   ~%" *prefix* *pagenumber*)) (if (<= *pagenumber* (- *lastpage* 9)) (format outfile "Page+10   ~%" *prefix* (+ *pagenumber* 9))) (format outfile "Index   ~%" *prefix*) (princ "" outfile) (terpri outfile) ) )) ; 13 Jan 06 ; process *line* (defun doline (outfile) (let () (setq *lng* (length *line*)) (setq *ptr* 0) (if (and (= *lng* 0) (not *verbatim*)) (princ "

" outfile)) (while (< *ptr* *lng*) (setq c (char *line* *ptr*)) (incf *ptr*) (if (and (char= c #\%) (not *verbatim*)) (flushline) (if (char= c #\\) (if (alpha-char-p (setq c (safe-char))) (docommand outfile) (if (char= c #\\) (progn (termline outfile) (incf *ptr*)) (if (char= c #\/) (progn (princ " " outfile) (incf *ptr*)) (if (char= c #\[) (progn (pushfont '$ outfile) (incf *ptr*)) (if (char= c #\]) (progn (popenv outfile) (incf *ptr*)) (progn (if *verbatim* (princ #\\ outfile)) (princ c outfile) (incf *ptr*))))))) (if (char= c #\&) (princ "" outfile) (if (char= c #\{) (if *verbatim* (princ #\{ outfile) (pushenv nil)) (if (char= c #\}) (if *verbatim* (princ #\} outfile) (popenv outfile)) (if (and (char= c #\$) (not *verbatim*)) (if (eq (car *modestack*) '$) (popenv outfile) (pushfont '$ outfile)) (if (and (or (char= c #\^) (char= c #\_)) (eq (car *modestack*) '$)) (progn (pushfont (if (char= c #\^) 'sup 'sub) outfile) (searchfor #\{)) (princ (if (char= c #\>) "> " (if (char= c #\<) "< " c)) outfile))))))))) )) ; 24 Jul 02; 25 Jul 02; 29 Jul 02; 12 Feb 03; 28 Aug 03 (defun docommand (outfile) (let (wordstring word subword termch done tmp c pair (saveptr (1- *ptr*))) (setq wordstring (car (parse-word nil))) (setq word (intern (string-upcase wordstring))) (case word ((documentstyle pagestyle setlength hyphenpenalty sloppy large) (flushline)) (setcounter (searchfor #\{) (setq subword (intern (car (parse-word t)))) (when (eq subword 'page) (searchfor #\{) (setq *pagenumber* (1- (parse-int))) ; assumes pagebreak (flushline)) ) (addtocounter (searchfor #\{) (setq subword (intern (car (parse-word t)))) (when (eq subword 'page) (searchfor #\{) (setq *pagenumber* (+ *pagenumber* (parse-int))) (flushline)) ) (includegraphics (searchfor #\{) (searchforalpha) (setq done nil) (while (not done) (setq tmp (parse-word nil)) (if (char= (cadr tmp) #\}) (setq done t) (if (char= (cadr tmp) #\.) (progn (setq done t) (princ "" outfile) (terpri outfile) (flushline) ) (incf *ptr*))))) (begin (searchfor #\{) (setq subword (intern (car (parse-word t)))) (searchfor #\}) ; (format t "subword = ~s~%" subword) (case subword (document (setq *ignore* nil)) (center (pushenv 'center)) (itemize (princ "

    " outfile) (terpri outfile)) (enumerate (princ "
      " outfile) (terpri outfile)) (verbatim (princ "
      " outfile) (terpri outfile)
		    (setq *verbatim* t))
	  (tabular (dotabular outfile))
	  ((quotation abstract quote)
	    (princ "
      " outfile) (terpri outfile))
	  ))
      (end (searchfor #\{)
	(setq subword (intern (car (parse-word t))))
	(searchfor #\})
	(case subword
	  (document (setq *feof* t))
	  (center (popenv outfile))
	  (itemize (princ "
" outfile) (terpri outfile)) (enumerate (princ "" outfile) (terpri outfile)) (verbatim (princ "" outfile) (terpri outfile) (setq *verbatim* nil)) (tabular (princ "" outfile) (terpri outfile) (popenv outfile)) ((quotation abstract quote) (princ "" outfile) (terpri outfile)) )) (item (princ "
  • " outfile)) (pagebreak (setq *done* t) (incf *pagenumber*)) ((bf tt em it) (pushfont word outfile)) ((title section subsection subsubsection paragraph) (searchfor #\{) (pushfont (cadr (assoc word '((title h1) (section h2) (subsection h3) (subsubsection h4) (paragraph b)))) outfile)) ((vspace vspace*) (searchfor #\}) (princ "

    " outfile) (terpri outfile)) ((hspace hspace*) (searchfor #\}) (dotimes (i 8) (princ " " outfile))) ((index) (searchfor #\})) ; ignore and consume (verb (setq termch (char *line* *ptr*)) (incf *ptr*) (pushfont 'tt outfile) (xferchars outfile termch) (popenv outfile) ) ((cite bibitem) (searchfor #\{) (princ "[" outfile) (xferchars outfile #\}) (princ "]" outfile) ) (footnote (searchfor #\{) (princ "[" outfile) (pushenv 'footnote)) (t (if *verbatim* (while (< saveptr *ptr*) (princ (char *line* saveptr) outfile) (incf saveptr)) (if (setq pair (assoc wordstring *specials* :test #'string=)) (princ (cadr pair) outfile)) ) ) ) )) ; push a new item on the mode stack (defun pushenv (item) (if (and *modestack* (eq (car *modestack*) nil)) (setf (car *modestack*) item) (push item *modestack*))) ; 24 Jul 02; 25 Jul 02 (defun popenv (outfile) (let ((item (pop *modestack*)) new) (setq new (cadr (assoc item '((em i) (bf b) (it i) ($ i))))) (case item ((bf tt it em $ h1 h2 h3 h4 sub sup) (princ "" outfile)) (footnote (princ "]" outfile)) ) item)) (defun pushfont (word outfile) (let ((new (cadr (assoc word '((em i) (bf b) (it i) ($ i)))))) (pushenv word) (princ "<" outfile) (princ (or new word) outfile) (princ ">" outfile) )) ; transfer chars to output until termch (defun xferchars (outfile termch) (let (done) (while (and (< *ptr* *lng*) (not done)) (setq c (char *line* *ptr*)) (incf *ptr*) (if (char= c termch) (setq done t) (princ c outfile)) ) )) (defun dotabular (outfile) (let ((ncols 0) done) (searchfor #\{) (while (and (< *ptr* *lng*) (not done)) (setq c (char *line* *ptr*)) (incf *ptr*) (if (char= c #\}) (setq done t) (if (or (char= c #\l) (char= c #\r) (char= c #\c)) (incf ncols))) ) (princ "" outfile) (terpri outfile) (princ "" outfile) (terpri outfile) (princ "
    " outfile) (pushenv 'table) )) (defun termline (outfile) (if (eq (car *modestack*) 'table) (progn (princ "
    " outfile)) (progn (princ "
    " outfile) (terpri outfile) ))) (defun safe-char () (if (< *ptr* *lng*) (char *line* *ptr*) #\Space)) ; Parse a word of alpha/num characters ; Returns ("word" ch) where ch is the terminating character (defun parse-word (upper) (let (c res) (while (and (< *ptr* *lng*) (or (alpha-char-p (setq c (char *line* *ptr*))) (and res (digit-char-p c)) (char= c #\*))) (push (if upper (char-upcase c) c) res) (incf *ptr*)) (if res (list (coerce (nreverse res) 'string) (and (not (alpha-char-p c)) c))) )) (defun searchfor (ch) (let (c) (while (and (< *ptr* *lng*) (setq c (char *line* *ptr*)) (not (char= ch c))) (incf *ptr*)) (if (and c (char= ch c)) (incf *ptr*)) c)) (defun searchforalpha () (while (and (< *ptr* *lng*) (not (alpha-char-p (char *line* *ptr*)))) (incf *ptr*))) (defun flushline () (setq *lng* 0)) (defun stringify (x) (cond ((stringp x) x) ((symbolp x) (symbol-name x)) (t (princ-to-string x)))) ; Parse an integer (defun parse-int () (let (c (n 0) digit found) (while (and (< *ptr* *lng*) (setq digit (digit-char-p (setq c (char *line* *ptr*))))) (setq found (or found digit)) (setq n (+ (* n 10) digit)) (incf *ptr*)) (if found n) )) gcl-2.6.14/xgcl-2/Xakcl.paper0000644000175000017500000007171114360276512014171 0ustar cammcamm A Guide to Xakcl ---------------- by Hiep H Nguyen Table of Contents ----------------- A. Getting Started 1. A brief description of X windows 2. A few commands to initialize graphics B. Creating and Using Windows 1. Creating Windows 2. Controling Window attributes 3. Getting Window Geometry C. How to Use the Graphics Context 1. Changing the Graphics Context 2. Getting Information form the Graphics Context D. Basic Drawing and Color Drawing 1. Drawing Lines 2. Drawing Rectangles 2. Drawing Arcs 3. Drawing Text E. Handling Events 1. The event queue 2. Examples of Mouse Events 3. Examples of Keyboard Events 4. A sample program to track the mouse F. Conclusion G. Copyright Software Copyright (c) 1992, The University of Texas at Austin. All rights reserved. See section G for full copyright statement. A Guide to Xakcl ---------------- Xakcl is the basic Xwindows library for Akcl lisp (the C header files for the library correspond to Xlib.h, Xutil.h, and X.h). Since Xakcl supports only the basic Xwindows library, Xakcl programming is intended to be a low level programming aproach to graphics. As a consequence, any Xwindows program written in C can also be written in Xakcl, with little cost in performance. The primitive operations range from controling minute details in color, to creating pixmaps, and configuring windows. Thus a programer using xakcl can exploit both the extensibility of Xwindows graphics capabilities and the ease of lisp programming. It is assumed that the reader is familiar with Lisp, and has some passing knowledge of C. Also familiarity with the Xwindows library routines and programming conventions would be helpful but is not required. All X functions in Xakcl begin with the letter 'X' , unless otherwise mentioned. The Syntax and names of Xakcl functions are kept as closely to the X library functions as possible, so that a user of the Xwindows' C libary will have no trouble in learning how to use Xakcl. Of course this also makes translation of X programs in C, into Lisp easier. For an introduction to X programming in C 'Xlib Programming Manual for version 11' by Adrian Nye is suggested. Also, any reference manual on the X library would be helpful, since the names of Xakcl functions are identical to those of the C libararies' functions. A. Getting Started. In order to start using graphics in Xakcl, a few initializations must take place. These initializations correspond to Xwindows call to get the root window, the display, the current screen, the Graphics Context and other properties needed by X. The use of these features will be described further in later sections. I. Initializing the Display In the X windows system, a display on which graphics is being done must be specified. The display is initilized by calling the X function XOpenDisplay. For example, (setq *default-display* (XOpenDisplay (get-c-string ""))) This functions needs a C string which is the name of the host, which can be specified with the default host. It returns a display in which graphics will be manipulated. For example, if two windows are created on this display, than when handling events, both windows could be polled. However, if two different displays are used, than the user can only handle events for one display at a time. Creating many displays could be useful for applications with many different windows, but there is a performance cost. It usually takes the X serever some time to return a display ID. II. The Default Screen and the Root Window The next steps in getting started is to get the desired screen (usually the default screen), and the root window. These two operations are similar to getting a display and is straight forward. Use the commands: (setq *default-screen* (XdefaultScreen *default-display*)) (setq *root-window* (XRootWindow *default-display* *default-screen*)) The default screen is the screen on which graphics will be drawn, and the root window, is the window that the X serever creates from which all other windows are created. This is the window that is created with the call to xstart, and resides in the background. III. The Black and White Pixel All graphics drawing, such as simple line drawing or text, must be done with a specified color. The default color is of course black and white. These pixel values will be used in creating windows or telling X how to draw black and white lines. X provides two functions for getting the value for the black and white pixel value, XBlackPixel and XWhitePixel. (setq *balck-pixel* (XBlackPixel *default-display* *default-screen*)) (setq *white-pixel* (XWhitePixel *default-display* *default-screen*)) Again these commands are straight forward. These two functions are examples of the facilities that X uses to control color. X will use pixel values to make color drawings. IV. The Default Graphics Context and Creation of a General GC Among other places, the pixel value, which will determine the color of drawings, will be used in determining the Graphics Context. In X, the graphics context is the structure that contains information on how drawings will be done. The line width will be determined by the graphics context, as well as the color and the way lines join (if they join at a rounded edge or at an angle.) For now, only the creation of the graphics context will be of concern. XDefaultGC will get a default grapics context. For example: (setq *default-GC* (XDefaultGC *default-display* *default-screen*)) However, a more general graphics context can be created with XCreateGC. The foreground color can be set to the black pixel and the background color can be set to the white pixel. (setq *default-GC* (XCreateGC *default-display* *root-window* 0 NULL)) (XSetForeground *default-display* *default-GC* *black-pixel*) (XSetBackground *default-display* *default-GC* *white-pixel*) After calling the above functions, a new graphics context will be created. The new Graphics Context will tell X how to draw. For example, when using XDrawString, X will use the foreground pixel, in this case, Black in the GC to draw the string. Also, XDrawImageString could be used. This routine, X draws the string in the foreground pixel and fills the background with the background pixel. If the foregorund and background pixels were switched than the string would be white letters on a black background. This is an example of highlighting text. VI. The Default Color Map X uses a colormap in order to allocate colors for a client. A colormap allows the user to match pixel values to an rgb value. The black pixel created by XBlackPixel is an example of a pixel value. A colormap may or may not have the exact color that is being requested. The closest pixel value is given to the user. In order to get a set of specific colors it is necesary to create a unique colormap, however for most applications, the default colormap will do. An example of creating a default colormap is shown below. (setq *default-colormap* ( XDefaultColormap *default-display* *default-screen*)) B. Creating and Using Windows I. Creating a Window To create windows in lisp two functions are available, XCreateWindow and XCreateSimpleWindow. Even though XCreateWindow is a more expansive function, for most applications XCreateSimpleWindow will do. Below is an example of the use of XCreateSimpleWindow. (setq a-window (XCreateSimpleWindow *default-display* *root-window* pos-x pos-y win-width win-height border-width *black-pixel* *white-pixel*)) This function will return an id number for the window. This id number will be used whenever there is an operation on the window. XCreateSimpleWindow expects the position (pos-x and pos-y), the size, the border width, the foreground pixel (in this case *black-pixel*), the background pixel (*white-pixel*), the display and the parent window (in this case the root window). Thus these attributes can be assigned at the creation of a window. II. The XSizeHints, telling the Window Manager what to do In the example above, the window being created is the child of the root window. So, this window sits inside the root window. Of course a window doesn't have to be the child of the root window, in which case it would reside in that parent window. However children of the root window are special. They must be managed by the window manager. In an Xwindows environment, the window manager is a program that manages among other things, the size and placement of windows on the screen. The user can tell the manager how to control different aspects of a window or drawable by passing to the window manager size hints. This is done by first creating a structure know as the Xsizehints. Below are examples of creating an instance of this structure, and it's initialization. (setq *default-size-hints* (make-XsizeHints)) (set-Xsizehints-x *default-size-hints* 10) (set-xsizehints-y *default-size-hints* 20) (set-xsizehints-width *default-size-hints* 225) (set-xsizehints-height *default-size-hints* 400) (set-xsizehints-flags *default-size-hints* (+ Psize Pposition)) Like all Xwindows structures in Xakcl, XSizeHints can be created using the function make followed by the type name of the struture (note however that unlike Xsizehints, the graphics context is created using the X function XCreateGC. The reason is that X provides a means of creating this structure, while the 'make' facility is provided to make C's struct in lisp). The fields in the structure is set using the functions set, followed by the type of the structure and the name of the field. These fields can be assessed with the function that begins with the type name followed by the name of the field. For example, after setting the hints as described above, (XSizeHints-x *default-size-hints*) will return 10. After Getting the Size Hints, the call to XSetStandardProperties will tell the window manager how to manage windows in the root window. (XsetStandardProperties *default-display* a-window (get-c-string window-name) (get-c-string icon-name) none null null *default-size-hints*) Along with the size hints, XsetStandardProperties also expects the display, the window being managed, the window name, and the icon name. XSetStandardProperties also expects three other parameters, an icon_pixmap, which will represent the window when it is iconized, and two arguments coressponding to resource information. Both these featrues are beyond the scope of this paper (see 'Xlib Programming Manual for version 11' for more information). After XSetStandardProperties tells the window manager what to do, the window needs to be mapped. Mapping will request that the X server draw the window on the screen. (Xmapwindow *default-display* a-window) The above function will map the window. Only one last function needs to be caled for a window to appear on the screen. This function is XFlush. This function, or another function that affects the event queue (discussed later) must be called whenever there is a drawing request for the X server. III. Changing Window Attributes After creating and drawing a window, the window's attributes can and modified using several X routines. A window could be resized, or the height of a window could could be extracted and used to do scaling measurements. Like most operations in X, there are two ways to change window attributes. The attributes could be changed directly by calling XChangeWindowAttributes with one of the parameters being a C structure, with the new information, and another parameter to specifiy which attribute is being changed. This could be clumbersome and inefficeint in lisp, but fortunately X usually provides a functional way of doing a task. Some functions for changing the window attributes are listed. Like most functions in X the names are self descriptive of the function. XSetWindowBackgroundPixmap XSetWindowBackground XSetWindowBorderPixmap XSetWindowBorder XSelectInput XSetWindowColormap XDefineCursor As can be seen, the regularity in nameing conventions of X routines. Only the function XSelectInput will be discussd in this report (see section E). The list shown is meant to demonstrate how X names functions, and how X can provid for functional equivalents for most operations. (Ofcourse any function that is not provided by X can be written in lisp using primitive operations like XChangeWindowAttributes. The same applies for all objects in X.) VI. Getting the Window Geometry In order to extract important information about a window, one of two functions can be used. These functions are XGetGeometry and XGetWindowProperty. For most applications these functions perform the same task, but because XGetGeometry deals not only with windows but with all drawbles, only XGetGeometry will be discussed ( all objects that can be drawn, such as a window or an icon is a drawable). Below is an example of a call to XGetGeometry. (XGetGeometry display a-drawable *root-return* *x-return* *y-return* *width-return* *height-return* *border-width-return* *depth-return*) The values that are returned by XGetGeometry is pointed to by the parameters that are denoted by teh word 'return'. A root of a window can be extracted, along with it's position, and size. Its border width can also be returned, along with it's depth ( a depth tells X how many colors can be drawn for a drawble). This functions also demonstrates how poitners are used in Xakcl to return multiple values. It is necessary to allocate an area of memory in order to write into that memory locations. The functions int-array and char-array will create a C array of integers and characters respectively. A pointer to the array is returned. XGetGemoetry expects pointers to integers so it is necessary to alocate integer arrays of one element. For example: (defvar *x-return* (int-array 1)) As is obvious, the parameter to int-array is the size of the array. The value itself can be obtained by the function int-pos as follows: (int-pos *x-return* 0) Notice that the index '0' is supplied in order to get the first element. This is identical to lisp arrays which start with index '0'. The rest of the information returned by XGetGeometry can be obtained similarly. C. The Graphics Context I. Changing the Graphics Context After Creating a Graphics context, or getting a default graphics context as shown in section A, the graphics context can be used to control drawing applications. By changing the graphics context, the drawing operations will draw in a different manner. For example, drawing different color lines can be accomplished this way. X provides two ways of changing the Graphics Context. Like the window attributes, the graphics context can be changed with function calls or by calling a function that expects structures (in this case XCreateGC). In this case as well, the functional ways of setting and changing the graphics context is easier. Some functions for setting the graphics context are shown below. XSetBackGround XSetForeGround XSetLineAttributes XSetFont XSetFunction i. XSetBackGround and XSetForeGround. XSetForeground and XSetBackground sets the foreground and background pixel as mentioned in section A. In order to Allocate a pixel besides black and white, a call to XAllocNamedColor must be done. XAllocNamedColor needs two Xcolor structrues, so they must be created as well. For example: (setq pixel-xcolor (make-Xcolor)) (setq exact-rgb (make-Xcolor)) (XAllocNamedColor display colormap (get-c-string color) pixel-xcolor exact-rgb) The above function will return a pixel value in the structure pixel-color. this informaion can be extracted with (Xcolor-pixel pixel-xcolor). XAllocNamedColo also expects a colormap (the default colormap will do), a display, and a String specifying the color (for a list of colors see the file rgb.txt in /usr/lib/X11). Thus the following function will cause all drawings to be done the specified color. (Xsetforeground display GC (Xcolor-pixel pixel-xcolor)) Similair to Xsetforeground, XSetBackGround will cause all drawings needing the background color to use the sepcified pixel value. ii. XSetLineAttributes In order to change how lines are drawn the function XSetLineAttributes must be used. For example: (XSetLineAttributes display GC width line-style cap-style join-style) As can be seen XSetLineAttributes will specify the width of the line, the style of the line, the way lines end (the cap style) and the way lines join. The width is an integer, while line-style, cap-style and join-style are constants. The default styles are LineSolid, CapButt, and JoinMitter. This will make lines appear solid. They will join at a sharp angle and the lines will end in a flat edge. See any X refernce manual for the complete options on the line styles. iii. XSetFont In order to draw text a font must be specified. The font tells X how characters will look on the screen. Thus a font must be loaded before drawing can occur. The function XloadQueryFont will return a structure of a valid font if one can be found, otherwise it will return 0. The functions below will get a specified font and if a valid font is found, will set it in the graphics context. (setq font-info (XloadQueryFont display (get-c-string a-string))) (if (not (eql 0 font-info)) (XsetFont display GC (Xfontstruct-fid font-info)) (format t "~%can't open font ~a" a-string)) First the font is loaded with XloadQueryFont. This function expects the display and a string which specifies the font (for complete font information see the directories /usr/lib/X11/fonts). After loading the font must be set in the specified graphics context. XSetFont expects the font id. This id resides in the XFontStruct returned by XloadQueryFont (this field of the structure is known as fid). iv. XSetFunction Xwindows draws by applying bit operations on the pixel vlaues on the screen along with a mask that it creates called the plan_mask. Most often only the pixel already on the screen is manipulated. This default logical operation is GXcopy (which is the default). However to perform moer complicated operations such as drawing 'ghost' images (drawing and erasing images with out affecting drawings in the background) other functions could be used. These functions are specified with a call to XSetFunction. (Xsetfunction *default-display* *default-GC* GXxor) The above function will make X draw ghost images in mono color screens using the function Xor. The pixel value on the screen is Xored with the pixel value of the plan_mask (which is derived from the foregroudn color). On color screens the foregorund color must be set to (logxor foreground-pixel background-pixel) in order for ghosting effects to occurr. Below is the complete function for ghosting effects. (Xsetforeground *default-display* *default-GC* (logxor foreground-pixel background-pixel )) II. Getting Information from the Graphics Context In the above function, the foreground-pixel and background-pixel must be extracted from the graphics context. In order to get information from the graphcis context the function XGetGCVlues must be used. XGetGCVlues is an example of a X function that expects a structure, and a value mask. Below are functions for extracted the foreground color from the graphics context. Other properties such as the background pixel value. (setq *GC-Values* (make-XGCValues)) (XGetGCValues display GC (+ GCForeground) *GC-Values*) (XGCValues-foreground *GC-Values*) A XGCValues structrue must be created and passed to XGetGCValues. The values that are requested are the mask passed to XGetGCValues (in this case it is GCForeground). XGetGCValues also expects the display and the graphics context. The values themselves can be extracted from the structure XGCValues with one of it's selector, just as in the case of XSizeHints. D. Basic Drawing and Color Drawing Now that the tools for drawing can be specified, the drawings themselves can be accomplished by drawing requests to the X server. An example of a drawing request is XMapWindow as mentioned in Section B. More generic drawings line line drawings, arc drawings and text drawings can also be done. I. Drawing Lines XDrawLine will draw lines in a drawable given the specification in the graphics context. For example: (XDrawLine display window GC x1 y1 x2 y2) (Xflush display) XDrawLine will draw a line from x1 y1 to x2 y2 where x and y are the positions. In this case 'window' is the destination drawable. Thus with the specification in the GC, a line on a specified with will be drawn. Its cap style will also be drawn accordingly. As in other drawing request. the display must be specified and a call to Xflush must be made in order to request that the X server process the request. II. Drawing Rectangles Drawing Rectangles is similar to drawing lines. The only difference is that the size of the recatangle must be specified. (XDrawRectangle *default-display* a-window *default-GC* x y width height) (Xflush *default-display* ) The function expects the x and y position and the width and height. II. Drawing Arcs. Arcs can form enclosed areas such as elipses or cirlces or they could be a curved line. The function XDrawArc will draw arcs. (XdrawArc *default-display* a-window *default-GC* 100 100 10 10 0 (* 360 64)) (Xflush *default-display* ) This function call will draw a circle. The Arc will be bounded by a rectangle. The points 100 100 correspond to the upper left edge of the recatangle. 10 and 10 specifies the width and height respectively. The starting and ending position of the arc must also be specified. These two points are in sixty-fourths of a degrees. The first angle is relative to the three-o'clock position and the second is relative to the starting position. Thus with the example above, the starting point will be drawn zero degrees away from the 3 o'clock position, while the ending point will be 360 degrees away ( a complete circle, since the arc is bounded by a square). The ending point of 360 degrees as all points in degrees must be multiplied by 64. III. Drawing Text With the font loaded in the Graphics Context as shown in Section C, several functions can be called in order to draw text. Only XDrawString will be dicussed here, but the other functions are similar. (XDrawString *default-display* a-window *default-GC* 10 15 (get-c-string "hello") 4) (Xflush *default-display*) The above function will draw the string 'hello' at positions 10, 15 with the font specified in the default grpahics context. XDrawString also expects the length of the string (in this case 4), and the display. Often it is necesssary to the size of the string (the rectangle that bounds the string). This can be done with a call to XTextExtents. (XTextExtents font_struct (get-c-string "hello") 4 direction_return font_ascent_return font_descent_return overall_return ) Font_struct is the structure returned by XLoadQueryFont. This can be kept as a global or it can be obtained from the Graphics Context as shown in section C. XTextExtents also expects the string drawn and the length of the string. It returns the direction, font_ascent, font_descent, and the overall metric of the string. Only the overall_return will be important for most uses (the direction specifies which direction the string is drawn - ie left to right, and font_ascent, font_descent pretain only to the font itself, and not the string). The overall metric information is the structure XCharStruct. Some members of this structure is the descent, the ascent and the width (an ascent tells how far above a baseline a character is drawn, while the descent tells how far below). After a call to XTextExtents, the ascent will be have the maximum ascent of all the characters in the string. Likewise the descent will have the maximum descent of all the characters. The width will be the sum of the characer width of all the characters in the string (thus the width of the string in number of pixels). From this information, the user shouldbe able to position text precisely on the screen. E. Handling Events So far only request to the X server to do output on the screen have been discussed. X also has a means of getting information about what is inputed by a user as well. The inputs can range from moving or clicking the mouse to keys being pressed on the keyboard. The input also encompases events like a window being uncovered or exposed by another window, or a window being resized. I. Setting the Input These inputs are called Events. The Events themseleves only have meaning when they pertain to a window. In other words, events occur in windows. Thus an attribute of the window must be set. The function XSelectInput must be used. (Xselectinput *default-display* a-window (+ ButtonpressMask PointerMotionMask ExposureMask)) The above function will tell X that in a-window only Buttonpress Events, PointerMotion Events, and Exposure Event can occur. As can be seen this is specified using mask (for other mask see a Xlib manual or the file X.lsp or X.h). After Specifiying the input, all events that occur in that will go on the event queue. The event queue is a queue of what events have occurred, the first one being on top. The client can both get information form the queue and manipulate the queue. II. Getting Information form the Event Queue Several functions are provided for getting information the event queue. Below is a list of some of these functions along with a description. XNextEvent -- Waits for the next event, and returns that event. XPeekEvent -- Sees what is next on the queue without changing the queue -- if no events exist it waits until one occurs. XPending -- returns the number of events in the queue XPutBackEvent -- puts an event on the queue XNextEvent is the most commonly used function, even though the other functions can be useful as well. Only the call to XNextEvent will be described because the other functions are similar to XNextEvent. The following functions will get an event from the queue and retrieve the type of the event along with the window that it occurs in. (XNextEvent *default-display* *default-event*) (setq type (XAnyEvent-type *default-event*)) (setq active-window (XAnyevent-window *default-event*)) XNextEvent returns a structure, XEvent. This structure in turn is a union of other structures, one for each type of event that can occur. In order to handle an event the appropriate structure must be assessed. For example, if the PointerMotion event needs to be handled than the *default-event* must be assessed as a XMotionEvent structure. Below is an example of getting the x and y position of the pointer when a PointerMotion Event has occurred, and the pointer is in the correct window. (if (and (eql type MotionNotify) (eql active-window correct-window)) (let ((x (XMotionEvent-x *default-event*)) (y (XMotionEvent-y *default-event*))) ` ;;trace the mouse (format t "~% pos-x: ~a pos-y: ~a" x y))) III. Manipulating the Event Queue For most applications the client will never have to change the event queue, besides removing events of the top or the queue, however sometimes the queue needs to be cleared by the client. The function XSync can be used to do this. For example: (Xsync *default-display* 1) F. Conclusion With the commands demonstarted in this tutorial, most applications can be managed. Windows can be created, and graphics operations can be performed. For more complex applications a widget set can be created similar to the X Intrinsics library and the Athena Widget Set. For a lisp like implementation of widgets and an advance aplications see the GWM application, in the GWM Manual by Colas Nahaboo. GWM is a generic window manager, that is similar to Xakcl. It supports objects that are similar to Widgets in most C Xwindows libraries. G. Copyright ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** gcl-2.6.14/xgcl-2/gcl_pcalc.lsp0000644000175000017500000001022014360276512014511 0ustar cammcamm; pcalc.lsp Gordon S. Novak Jr. 20 Oct 94 ; Pocket calculator implemented using a picmenu. Entry is (pcalc) . ; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu (defvar *pcalcw* nil) ; window (defvar *pcalcm* nil) ; picmenu (defun pcalc-draw (w x y) (let (items item over up) (window-open w) (window-clear w) (window-draw-rcbox-xy *pcalcw* 0 0 170 215 10 2) (window-draw-rcbox-xy *pcalcw* 10 180 150 25 6) (setq items '(0 \. = + 1 2 3 - 4 5 6 * 7 8 9 / off ac ce +-)) (dotimes (i 5) (setq up (+ 10 (* i 35))) (dotimes (j 4) (setq over (+ 10 (* j 40))) (setq item (pop items)) (window-printat-xy *pcalcw* item (+ over 15 (* (if (numberp item) 1 (length (stringify item))) -5)) (+ up 3)) (window-draw-rcbox-xy *pcalcw* over up 28 20 6) )) (window-force-output) )) (defun pcalc-init () (prog ((n 15)) (setq *pcalcw* (window-create 170 215 "pcalc" nil nil nil '9x15)) lp (when (and (> n 0) (null (window-wait-exposure *pcalcw*))) (sleep 1.0) (decf n) (go lp)) (setq *pcalcm* (picmenu-create '((0 (24 20) (24 16)) (\. (64 20) (24 16)) (= (104 20) (24 16)) (+ (144 20) (24 16)) (1 (24 55) (24 16)) (2 (64 55) (24 16)) (3 (104 55) (24 16)) (- (144 55) (24 16)) (4 (24 90) (24 16)) (5 (64 90) (24 16)) (6 (104 90) (24 16)) (* (144 90) (24 16)) (7 (24 125) (24 16)) (8 (64 125) (24 16)) (9 (104 125) (24 16)) (/ (144 125) (24 16)) (off (24 160) (24 16)) (ac (64 160) (24 16)) (ce (104 160) (24 16)) (+- (144 160) (24 16))) 170 215 'pcalc-draw nil nil *pcalcw* 0 0 t t)) )) (defun pcalc-display (val) (let (str) (window-erase-area-xy *pcalcw* 15 182 140 20) (setq str (if (integerp val) (princ-to-string val) (format nil "~8,4F" val))) (window-printat-xy *pcalcw* str (- 131 (* 9 (length str))) 185) (window-force-output) )) (defun pcalc () (prog (key (ent 0) (ac 0) decpt lastop lastkey) (or *pcalcw* (pcalc-init)) (pcalc-draw *pcalcw* 0 0) (pcalc-display ent) lp (setq key (picmenu-select *pcalcm*)) (if (numberp key) (progn (when (eq lastkey '=) (setq ent 0) (setq decpt nil) (setq ac 0) (setq lastop nil)) (if decpt (progn (setq ent (+ ent (* key decpt))) (setq decpt (/ decpt 10.0)) ) (setq ent (+ key (* ent 10))) ) (pcalc-display ent)) (case key ((+ - * /) (if lastop (progn (setq ac (if (eq lastop '/) (/ (float ac) ent) (funcall lastop ac ent))) (pcalc-display ac)) (setq ac ent)) (setq lastop key) (setq ent 0) (setq decpt nil)) (= (if lastop (progn (setq ent (if (eq lastop '/) (/ (float ac) ent) (funcall lastop ac ent))) (pcalc-display ent))) (setq lastop nil)) (\. (when (eq lastkey '=) (setq ent 0) (setq ac 0) (setq lastop nil)) (setq decpt 0.1) (setq ent (float ent)) (pcalc-display ent)) (+- (setq ent (- ent)) (pcalc-display ent)) (ce (setq ent 0) (setq decpt nil) (pcalc-display ent)) (ac (setq ent 0) (setq decpt nil) (setq ac 0) (setq lastop nil) (pcalc-display ent)) (off (window-close *pcalcw*) (return nil)) ) ) (setq lastkey key) (go lp) )) gcl-2.6.14/xgcl-2/gcl_keysymdef.lsp0000644000175000017500000015776114360276512015455 0ustar cammcamm(in-package :XLIB) ; keysymdef.lsp modified by Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;; $XConsortium: keysymdef.h,v 1.13 89/12/12 16:23:30 rws Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant XK_VoidSymbol #xFFFFFF ;; void symbol ;;#ifdef XK_MISCELLANY ;; ; TTY Functions, cleverly chosen to map to ascii, for convenience of ; programming, but could have been arbitrary at the cost of lookup ; tables in client code. )(defconstant XK_BackSpace #xFF08 ;; back space, back char )(defconstant XK_Tab #xFF09 )(defconstant XK_Linefeed #xFF0A ;; Linefeed, LF )(defconstant XK_Clear #xFF0B )(defconstant XK_Return #xFF0D ;; Return, enter )(defconstant XK_Pause #xFF13 ;; Pause, hold )(defconstant XK_Scroll_Lock #xFF14 )(defconstant XK_Escape #xFF1B )(defconstant XK_Delete #xFFFF ;; Delete, rubout ;; International & multi-key character composition )(defconstant XK_Multi_key #xFF20 ;; Multi-key character compose ;; Japanese keyboard support )(defconstant XK_Kanji #xFF21 ;; Kanji, Kanji convert )(defconstant XK_Muhenkan #xFF22 ;; Cancel Conversion )(defconstant XK_Henkan_Mode #xFF23 ;; Start/Stop Conversion )(defconstant XK_Henkan #xFF23 ;; Alias for Henkan_Mode )(defconstant XK_Romaji #xFF24 ;; to Romaji )(defconstant XK_Hiragana #xFF25 ;; to Hiragana )(defconstant XK_Katakana #xFF26 ;; to Katakana )(defconstant XK_Hiragana_Katakana #xFF27 ;; Hiragana/Katakana toggle )(defconstant XK_Zenkaku #xFF28 ;; to Zenkaku )(defconstant XK_Hankaku #xFF29 ;; to Hankaku )(defconstant XK_Zenkaku_Hankaku #xFF2A ;; Zenkaku/Hankaku toggle )(defconstant XK_Touroku #xFF2B ;; Add to Dictionary )(defconstant XK_Massyo #xFF2C ;; Delete from Dictionary )(defconstant XK_Kana_Lock #xFF2D ;; Kana Lock )(defconstant XK_Kana_Shift #xFF2E ;; Kana Shift )(defconstant XK_Eisu_Shift #xFF2F ;; Alphanumeric Shift )(defconstant XK_Eisu_toggle #xFF30 ;; Alphanumeric toggle ;; Cursor control & motion )(defconstant XK_Home #xFF50 )(defconstant XK_Left #xFF51 ;; Move left, left arrow )(defconstant XK_Up #xFF52 ;; Move up, up arrow )(defconstant XK_Right #xFF53 ;; Move right, right arrow )(defconstant XK_Down #xFF54 ;; Move down, down arrow )(defconstant XK_Prior #xFF55 ;; Prior, previous )(defconstant XK_Next #xFF56 ;; Next )(defconstant XK_End #xFF57 ;; EOL )(defconstant XK_Begin #xFF58 ;; BOL ;; Misc Functions )(defconstant XK_Select #xFF60 ;; Select, mark )(defconstant XK_Print #xFF61 )(defconstant XK_Execute #xFF62 ;; Execute, run, do )(defconstant XK_Insert #xFF63 ;; Insert, insert here )(defconstant XK_Undo #xFF65 ;; Undo, oops )(defconstant XK_Redo #xFF66 ;; redo, again )(defconstant XK_Menu #xFF67 )(defconstant XK_Find #xFF68 ;; Find, search )(defconstant XK_Cancel #xFF69 ;; Cancel, stop, abort, exit )(defconstant XK_Help #xFF6A ;; Help, ? )(defconstant XK_Break #xFF6B )(defconstant XK_Mode_switch #xFF7E ;; Character set switch )(defconstant XK_script_switch #xFF7E ;; Alias for mode_switch )(defconstant XK_Num_Lock #xFF7F ;; Keypad Functions, keypad numbers cleverly chosen to map to ascii )(defconstant XK_KP_Space #xFF80 ;; space )(defconstant XK_KP_Tab #xFF89 )(defconstant XK_KP_Enter #xFF8D ;; enter )(defconstant XK_KP_F1 #xFF91 ;; PF1, KP_A, ... )(defconstant XK_KP_F2 #xFF92 )(defconstant XK_KP_F3 #xFF93 )(defconstant XK_KP_F4 #xFF94 )(defconstant XK_KP_Equal #xFFBD ;; equals )(defconstant XK_KP_Multiply #xFFAA )(defconstant XK_KP_Add #xFFAB )(defconstant XK_KP_Separator #xFFAC ;; separator, often comma )(defconstant XK_KP_Subtract #xFFAD )(defconstant XK_KP_Decimal #xFFAE )(defconstant XK_KP_Divide #xFFAF )(defconstant XK_KP_0 #xFFB0 )(defconstant XK_KP_1 #xFFB1 )(defconstant XK_KP_2 #xFFB2 )(defconstant XK_KP_3 #xFFB3 )(defconstant XK_KP_4 #xFFB4 )(defconstant XK_KP_5 #xFFB5 )(defconstant XK_KP_6 #xFFB6 )(defconstant XK_KP_7 #xFFB7 )(defconstant XK_KP_8 #xFFB8 )(defconstant XK_KP_9 #xFFB9 ;; ; Auxiliary Functions; note the duplicate definitions for left and right ; function keys; Sun keyboards and a few other manufactures have such ; function key groups on the left and/or right sides of the keyboard. ; We've not found a keyboard with more than 35 function keys total. )(defconstant XK_F1 #xFFBE )(defconstant XK_F2 #xFFBF )(defconstant XK_F3 #xFFC0 )(defconstant XK_F4 #xFFC1 )(defconstant XK_F5 #xFFC2 )(defconstant XK_F6 #xFFC3 )(defconstant XK_F7 #xFFC4 )(defconstant XK_F8 #xFFC5 )(defconstant XK_F9 #xFFC6 )(defconstant XK_F10 #xFFC7 )(defconstant XK_F11 #xFFC8 )(defconstant XK_L1 #xFFC8 )(defconstant XK_F12 #xFFC9 )(defconstant XK_L2 #xFFC9 )(defconstant XK_F13 #xFFCA )(defconstant XK_L3 #xFFCA )(defconstant XK_F14 #xFFCB )(defconstant XK_L4 #xFFCB )(defconstant XK_F15 #xFFCC )(defconstant XK_L5 #xFFCC )(defconstant XK_F16 #xFFCD )(defconstant XK_L6 #xFFCD )(defconstant XK_F17 #xFFCE )(defconstant XK_L7 #xFFCE )(defconstant XK_F18 #xFFCF )(defconstant XK_L8 #xFFCF )(defconstant XK_F19 #xFFD0 )(defconstant XK_L9 #xFFD0 )(defconstant XK_F20 #xFFD1 )(defconstant XK_L10 #xFFD1 )(defconstant XK_F21 #xFFD2 )(defconstant XK_R1 #xFFD2 )(defconstant XK_F22 #xFFD3 )(defconstant XK_R2 #xFFD3 )(defconstant XK_F23 #xFFD4 )(defconstant XK_R3 #xFFD4 )(defconstant XK_F24 #xFFD5 )(defconstant XK_R4 #xFFD5 )(defconstant XK_F25 #xFFD6 )(defconstant XK_R5 #xFFD6 )(defconstant XK_F26 #xFFD7 )(defconstant XK_R6 #xFFD7 )(defconstant XK_F27 #xFFD8 )(defconstant XK_R7 #xFFD8 )(defconstant XK_F28 #xFFD9 )(defconstant XK_R8 #xFFD9 )(defconstant XK_F29 #xFFDA )(defconstant XK_R9 #xFFDA )(defconstant XK_F30 #xFFDB )(defconstant XK_R10 #xFFDB )(defconstant XK_F31 #xFFDC )(defconstant XK_R11 #xFFDC )(defconstant XK_F32 #xFFDD )(defconstant XK_R12 #xFFDD )(defconstant XK_R13 #xFFDE )(defconstant XK_F33 #xFFDE )(defconstant XK_F34 #xFFDF )(defconstant XK_R14 #xFFDF )(defconstant XK_F35 #xFFE0 )(defconstant XK_R15 #xFFE0 ;; Modifiers )(defconstant XK_Shift_L #xFFE1 ;; Left shift )(defconstant XK_Shift_R #xFFE2 ;; Right shift )(defconstant XK_Control_L #xFFE3 ;; Left control )(defconstant XK_Control_R #xFFE4 ;; Right control )(defconstant XK_Caps_Lock #xFFE5 ;; Caps lock )(defconstant XK_Shift_Lock #xFFE6 ;; Shift lock )(defconstant XK_Meta_L #xFFE7 ;; Left meta )(defconstant XK_Meta_R #xFFE8 ;; Right meta )(defconstant XK_Alt_L #xFFE9 ;; Left alt )(defconstant XK_Alt_R #xFFEA ;; Right alt )(defconstant XK_Super_L #xFFEB ;; Left super )(defconstant XK_Super_R #xFFEC ;; Right super )(defconstant XK_Hyper_L #xFFED ;; Left hyper )(defconstant XK_Hyper_R #xFFEE ;; Right hyper ;;#endif ;; XK_MISCELLANY ;; ; Latin 1 ; Byte 3 = 0 ;;ifdef XK_LATIN1 )(defconstant XK_space #x020 )(defconstant XK_exclam #x021 )(defconstant XK_quotedbl #x022 )(defconstant XK_numbersign #x023 )(defconstant XK_dollar #x024 )(defconstant XK_percent #x025 )(defconstant XK_ampersand #x026 )(defconstant XK_apostrophe #x027 )(defconstant XK_quoteright #x027 ;; deprecated )(defconstant XK_parenleft #x028 )(defconstant XK_parenright #x029 )(defconstant XK_asterisk #x02a )(defconstant XK_plus #x02b )(defconstant XK_comma #x02c )(defconstant XK_minus #x02d )(defconstant XK_period #x02e )(defconstant XK_slash #x02f )(defconstant XK_0 #x030 )(defconstant XK_1 #x031 )(defconstant XK_2 #x032 )(defconstant XK_3 #x033 )(defconstant XK_4 #x034 )(defconstant XK_5 #x035 )(defconstant XK_6 #x036 )(defconstant XK_7 #x037 )(defconstant XK_8 #x038 )(defconstant XK_9 #x039 )(defconstant XK_colon #x03a )(defconstant XK_semicolon #x03b )(defconstant XK_less #x03c )(defconstant XK_equal #x03d )(defconstant XK_greater #x03e )(defconstant XK_question #x03f )(defconstant XK_at #x040 )(defconstant XK_A #x041 )(defconstant XK_B #x042 )(defconstant XK_C #x043 )(defconstant XK_D #x044 )(defconstant XK_E #x045 )(defconstant XK_F #x046 )(defconstant XK_G #x047 )(defconstant XK_H #x048 )(defconstant XK_I #x049 )(defconstant XK_J #x04a )(defconstant XK_K #x04b )(defconstant XK_L #x04c )(defconstant XK_M #x04d )(defconstant XK_N #x04e )(defconstant XK_O #x04f )(defconstant XK_P #x050 )(defconstant XK_Q #x051 )(defconstant XK_R #x052 )(defconstant XK_S #x053 )(defconstant XK_T #x054 )(defconstant XK_U #x055 )(defconstant XK_V #x056 )(defconstant XK_W #x057 )(defconstant XK_X #x058 )(defconstant XK_Y #x059 )(defconstant XK_Z #x05a )(defconstant XK_bracketleft #x05b )(defconstant XK_backslash #x05c )(defconstant XK_bracketright #x05d )(defconstant XK_asciicircum #x05e )(defconstant XK_underscore #x05f )(defconstant XK_grave #x060 )(defconstant XK_quoteleft #x060 ;; deprecated )(defconstant XK_a #x061 )(defconstant XK_b #x062 )(defconstant XK_c #x063 )(defconstant XK_d #x064 )(defconstant XK_e #x065 )(defconstant XK_f #x066 )(defconstant XK_g #x067 )(defconstant XK_h #x068 )(defconstant XK_i #x069 )(defconstant XK_j #x06a )(defconstant XK_k #x06b )(defconstant XK_l #x06c )(defconstant XK_m #x06d )(defconstant XK_n #x06e )(defconstant XK_o #x06f )(defconstant XK_p #x070 )(defconstant XK_q #x071 )(defconstant XK_r #x072 )(defconstant XK_s #x073 )(defconstant XK_t #x074 )(defconstant XK_u #x075 )(defconstant XK_v #x076 )(defconstant XK_w #x077 )(defconstant XK_x #x078 )(defconstant XK_y #x079 )(defconstant XK_z #x07a )(defconstant XK_braceleft #x07b )(defconstant XK_bar #x07c )(defconstant XK_braceright #x07d )(defconstant XK_asciitilde #x07e )(defconstant XK_nobreakspace #x0a0 )(defconstant XK_exclamdown #x0a1 )(defconstant XK_cent #x0a2 )(defconstant XK_sterling #x0a3 )(defconstant XK_currency #x0a4 )(defconstant XK_yen #x0a5 )(defconstant XK_brokenbar #x0a6 )(defconstant XK_section #x0a7 )(defconstant XK_diaeresis #x0a8 )(defconstant XK_copyright #x0a9 )(defconstant XK_ordfeminine #x0aa )(defconstant XK_guillemotleft #x0ab ;; left angle quotation mark )(defconstant XK_notsign #x0ac )(defconstant XK_hyphen #x0ad )(defconstant XK_registered #x0ae )(defconstant XK_macron #x0af )(defconstant XK_degree #x0b0 )(defconstant XK_plusminus #x0b1 )(defconstant XK_twosuperior #x0b2 )(defconstant XK_threesuperior #x0b3 )(defconstant XK_acute #x0b4 )(defconstant XK_mu #x0b5 )(defconstant XK_paragraph #x0b6 )(defconstant XK_periodcentered #x0b7 )(defconstant XK_cedilla #x0b8 )(defconstant XK_onesuperior #x0b9 )(defconstant XK_masculine #x0ba )(defconstant XK_guillemotright #x0bb ;; right angle quotation mark )(defconstant XK_onequarter #x0bc )(defconstant XK_onehalf #x0bd )(defconstant XK_threequarters #x0be )(defconstant XK_questiondown #x0bf )(defconstant XK_Agrave #x0c0 )(defconstant XK_Aacute #x0c1 )(defconstant XK_Acircumflex #x0c2 )(defconstant XK_Atilde #x0c3 )(defconstant XK_Adiaeresis #x0c4 )(defconstant XK_Aring #x0c5 )(defconstant XK_AE #x0c6 )(defconstant XK_Ccedilla #x0c7 )(defconstant XK_Egrave #x0c8 )(defconstant XK_Eacute #x0c9 )(defconstant XK_Ecircumflex #x0ca )(defconstant XK_Ediaeresis #x0cb )(defconstant XK_Igrave #x0cc )(defconstant XK_Iacute #x0cd )(defconstant XK_Icircumflex #x0ce )(defconstant XK_Idiaeresis #x0cf )(defconstant XK_ETH #x0d0 )(defconstant XK_Eth #x0d0 ;; deprecated )(defconstant XK_Ntilde #x0d1 )(defconstant XK_Ograve #x0d2 )(defconstant XK_Oacute #x0d3 )(defconstant XK_Ocircumflex #x0d4 )(defconstant XK_Otilde #x0d5 )(defconstant XK_Odiaeresis #x0d6 )(defconstant XK_multiply #x0d7 )(defconstant XK_Ooblique #x0d8 )(defconstant XK_Ugrave #x0d9 )(defconstant XK_Uacute #x0da )(defconstant XK_Ucircumflex #x0db )(defconstant XK_Udiaeresis #x0dc )(defconstant XK_Yacute #x0dd )(defconstant XK_THORN #x0de )(defconstant XK_Thorn #x0de ;; deprecated )(defconstant XK_ssharp #x0df )(defconstant XK_agrave #x0e0 )(defconstant XK_aacute #x0e1 )(defconstant XK_acircumflex #x0e2 )(defconstant XK_atilde #x0e3 )(defconstant XK_adiaeresis #x0e4 )(defconstant XK_aring #x0e5 )(defconstant XK_ae #x0e6 )(defconstant XK_ccedilla #x0e7 )(defconstant XK_egrave #x0e8 )(defconstant XK_eacute #x0e9 )(defconstant XK_ecircumflex #x0ea )(defconstant XK_ediaeresis #x0eb )(defconstant XK_igrave #x0ec )(defconstant XK_iacute #x0ed )(defconstant XK_icircumflex #x0ee )(defconstant XK_idiaeresis #x0ef )(defconstant XK_eth #x0f0 )(defconstant XK_ntilde #x0f1 )(defconstant XK_ograve #x0f2 )(defconstant XK_oacute #x0f3 )(defconstant XK_ocircumflex #x0f4 )(defconstant XK_otilde #x0f5 )(defconstant XK_odiaeresis #x0f6 )(defconstant XK_division #x0f7 )(defconstant XK_oslash #x0f8 )(defconstant XK_ugrave #x0f9 )(defconstant XK_uacute #x0fa )(defconstant XK_ucircumflex #x0fb )(defconstant XK_udiaeresis #x0fc )(defconstant XK_yacute #x0fd )(defconstant XK_thorn #x0fe )(defconstant XK_ydiaeresis #x0ff ;;endif ;; XK_LATIN1 ;; ; Latin 2 ; Byte 3 = 1 ;;ifdef XK_LATIN2 )(defconstant XK_Aogonek #x1a1 )(defconstant XK_breve #x1a2 )(defconstant XK_Lstroke #x1a3 )(defconstant XK_Lcaron #x1a5 )(defconstant XK_Sacute #x1a6 )(defconstant XK_Scaron #x1a9 )(defconstant XK_Scedilla #x1aa )(defconstant XK_Tcaron #x1ab )(defconstant XK_Zacute #x1ac )(defconstant XK_Zcaron #x1ae )(defconstant XK_Zabovedot #x1af )(defconstant XK_aogonek #x1b1 )(defconstant XK_ogonek #x1b2 )(defconstant XK_lstroke #x1b3 )(defconstant XK_lcaron #x1b5 )(defconstant XK_sacute #x1b6 )(defconstant XK_caron #x1b7 )(defconstant XK_scaron #x1b9 )(defconstant XK_scedilla #x1ba )(defconstant XK_tcaron #x1bb )(defconstant XK_zacute #x1bc )(defconstant XK_doubleacute #x1bd )(defconstant XK_zcaron #x1be )(defconstant XK_zabovedot #x1bf )(defconstant XK_Racute #x1c0 )(defconstant XK_Abreve #x1c3 )(defconstant XK_Lacute #x1c5 )(defconstant XK_Cacute #x1c6 )(defconstant XK_Ccaron #x1c8 )(defconstant XK_Eogonek #x1ca )(defconstant XK_Ecaron #x1cc )(defconstant XK_Dcaron #x1cf )(defconstant XK_Dstroke #x1d0 )(defconstant XK_Nacute #x1d1 )(defconstant XK_Ncaron #x1d2 )(defconstant XK_Odoubleacute #x1d5 )(defconstant XK_Rcaron #x1d8 )(defconstant XK_Uring #x1d9 )(defconstant XK_Udoubleacute #x1db )(defconstant XK_Tcedilla #x1de )(defconstant XK_racute #x1e0 )(defconstant XK_abreve #x1e3 )(defconstant XK_lacute #x1e5 )(defconstant XK_cacute #x1e6 )(defconstant XK_ccaron #x1e8 )(defconstant XK_eogonek #x1ea )(defconstant XK_ecaron #x1ec )(defconstant XK_dcaron #x1ef )(defconstant XK_dstroke #x1f0 )(defconstant XK_nacute #x1f1 )(defconstant XK_ncaron #x1f2 )(defconstant XK_odoubleacute #x1f5 )(defconstant XK_udoubleacute #x1fb )(defconstant XK_rcaron #x1f8 )(defconstant XK_uring #x1f9 )(defconstant XK_tcedilla #x1fe )(defconstant XK_abovedot #x1ff ;;endif ;; XK_LATIN2 ;; ; Latin 3 ; Byte 3 = 2 ;;ifdef XK_LATIN3 )(defconstant XK_Hstroke #x2a1 )(defconstant XK_Hcircumflex #x2a6 )(defconstant XK_Iabovedot #x2a9 )(defconstant XK_Gbreve #x2ab )(defconstant XK_Jcircumflex #x2ac )(defconstant XK_hstroke #x2b1 )(defconstant XK_hcircumflex #x2b6 )(defconstant XK_idotless #x2b9 )(defconstant XK_gbreve #x2bb )(defconstant XK_jcircumflex #x2bc )(defconstant XK_Cabovedot #x2c5 )(defconstant XK_Ccircumflex #x2c6 )(defconstant XK_Gabovedot #x2d5 )(defconstant XK_Gcircumflex #x2d8 )(defconstant XK_Ubreve #x2dd )(defconstant XK_Scircumflex #x2de )(defconstant XK_cabovedot #x2e5 )(defconstant XK_ccircumflex #x2e6 )(defconstant XK_gabovedot #x2f5 )(defconstant XK_gcircumflex #x2f8 )(defconstant XK_ubreve #x2fd )(defconstant XK_scircumflex #x2fe ;;endif ;; XK_LATIN3 ;; ; Latin 4 ; Byte 3 = 3 ;;ifdef XK_LATIN4 )(defconstant XK_kra #x3a2 )(defconstant XK_kappa #x3a2 ;; deprecated )(defconstant XK_Rcedilla #x3a3 )(defconstant XK_Itilde #x3a5 )(defconstant XK_Lcedilla #x3a6 )(defconstant XK_Emacron #x3aa )(defconstant XK_Gcedilla #x3ab )(defconstant XK_Tslash #x3ac )(defconstant XK_rcedilla #x3b3 )(defconstant XK_itilde #x3b5 )(defconstant XK_lcedilla #x3b6 )(defconstant XK_emacron #x3ba )(defconstant XK_gcedilla #x3bb )(defconstant XK_tslash #x3bc )(defconstant XK_ENG #x3bd )(defconstant XK_eng #x3bf )(defconstant XK_Amacron #x3c0 )(defconstant XK_Iogonek #x3c7 )(defconstant XK_Eabovedot #x3cc )(defconstant XK_Imacron #x3cf )(defconstant XK_Ncedilla #x3d1 )(defconstant XK_Omacron #x3d2 )(defconstant XK_Kcedilla #x3d3 )(defconstant XK_Uogonek #x3d9 )(defconstant XK_Utilde #x3dd )(defconstant XK_Umacron #x3de )(defconstant XK_amacron #x3e0 )(defconstant XK_iogonek #x3e7 )(defconstant XK_eabovedot #x3ec )(defconstant XK_imacron #x3ef )(defconstant XK_ncedilla #x3f1 )(defconstant XK_omacron #x3f2 )(defconstant XK_kcedilla #x3f3 )(defconstant XK_uogonek #x3f9 )(defconstant XK_utilde #x3fd )(defconstant XK_umacron #x3fe ;;endif ;; XK_LATIN4 ;; ; Katakana ; Byte 3 = 4 ;;ifdef XK_KATAKANA )(defconstant XK_overline #x47e )(defconstant XK_kana_fullstop #x4a1 )(defconstant XK_kana_openingbracket #x4a2 )(defconstant XK_kana_closingbracket #x4a3 )(defconstant XK_kana_comma #x4a4 )(defconstant XK_kana_conjunctive #x4a5 )(defconstant XK_kana_middledot #x4a5 ;; deprecated )(defconstant XK_kana_WO #x4a6 )(defconstant XK_kana_a #x4a7 )(defconstant XK_kana_i #x4a8 )(defconstant XK_kana_u #x4a9 )(defconstant XK_kana_e #x4aa )(defconstant XK_kana_o #x4ab )(defconstant XK_kana_ya #x4ac )(defconstant XK_kana_yu #x4ad )(defconstant XK_kana_yo #x4ae )(defconstant XK_kana_tsu #x4af )(defconstant XK_kana_tu #x4af ;; deprecated )(defconstant XK_prolongedsound #x4b0 )(defconstant XK_kana_A #x4b1 )(defconstant XK_kana_I #x4b2 )(defconstant XK_kana_U #x4b3 )(defconstant XK_kana_E #x4b4 )(defconstant XK_kana_O #x4b5 )(defconstant XK_kana_KA #x4b6 )(defconstant XK_kana_KI #x4b7 )(defconstant XK_kana_KU #x4b8 )(defconstant XK_kana_KE #x4b9 )(defconstant XK_kana_KO #x4ba )(defconstant XK_kana_SA #x4bb )(defconstant XK_kana_SHI #x4bc )(defconstant XK_kana_SU #x4bd )(defconstant XK_kana_SE #x4be )(defconstant XK_kana_SO #x4bf )(defconstant XK_kana_TA #x4c0 )(defconstant XK_kana_CHI #x4c1 )(defconstant XK_kana_TI #x4c1 ;; deprecated )(defconstant XK_kana_TSU #x4c2 )(defconstant XK_kana_TU #x4c2 ;; deprecated )(defconstant XK_kana_TE #x4c3 )(defconstant XK_kana_TO #x4c4 )(defconstant XK_kana_NA #x4c5 )(defconstant XK_kana_NI #x4c6 )(defconstant XK_kana_NU #x4c7 )(defconstant XK_kana_NE #x4c8 )(defconstant XK_kana_NO #x4c9 )(defconstant XK_kana_HA #x4ca )(defconstant XK_kana_HI #x4cb )(defconstant XK_kana_FU #x4cc )(defconstant XK_kana_HU #x4cc ;; deprecated )(defconstant XK_kana_HE #x4cd )(defconstant XK_kana_HO #x4ce )(defconstant XK_kana_MA #x4cf )(defconstant XK_kana_MI #x4d0 )(defconstant XK_kana_MU #x4d1 )(defconstant XK_kana_ME #x4d2 )(defconstant XK_kana_MO #x4d3 )(defconstant XK_kana_YA #x4d4 )(defconstant XK_kana_YU #x4d5 )(defconstant XK_kana_YO #x4d6 )(defconstant XK_kana_RA #x4d7 )(defconstant XK_kana_RI #x4d8 )(defconstant XK_kana_RU #x4d9 )(defconstant XK_kana_RE #x4da )(defconstant XK_kana_RO #x4db )(defconstant XK_kana_WA #x4dc )(defconstant XK_kana_N #x4dd )(defconstant XK_voicedsound #x4de )(defconstant XK_semivoicedsound #x4df )(defconstant XK_kana_switch #xFF7E ;; Alias for mode_switch ;;endif ;; XK_KATAKANA ;; ; Arabic ; Byte 3 = 5 ;;ifdef XK_ARABIC )(defconstant XK_Arabic_comma #x5ac )(defconstant XK_Arabic_semicolon #x5bb )(defconstant XK_Arabic_question_mark #x5bf )(defconstant XK_Arabic_hamza #x5c1 )(defconstant XK_Arabic_maddaonalef #x5c2 )(defconstant XK_Arabic_hamzaonalef #x5c3 )(defconstant XK_Arabic_hamzaonwaw #x5c4 )(defconstant XK_Arabic_hamzaunderalef #x5c5 )(defconstant XK_Arabic_hamzaonyeh #x5c6 )(defconstant XK_Arabic_alef #x5c7 )(defconstant XK_Arabic_beh #x5c8 )(defconstant XK_Arabic_tehmarbuta #x5c9 )(defconstant XK_Arabic_teh #x5ca )(defconstant XK_Arabic_theh #x5cb )(defconstant XK_Arabic_jeem #x5cc )(defconstant XK_Arabic_hah #x5cd )(defconstant XK_Arabic_khah #x5ce )(defconstant XK_Arabic_dal #x5cf )(defconstant XK_Arabic_thal #x5d0 )(defconstant XK_Arabic_ra #x5d1 )(defconstant XK_Arabic_zain #x5d2 )(defconstant XK_Arabic_seen #x5d3 )(defconstant XK_Arabic_sheen #x5d4 )(defconstant XK_Arabic_sad #x5d5 )(defconstant XK_Arabic_dad #x5d6 )(defconstant XK_Arabic_tah #x5d7 )(defconstant XK_Arabic_zah #x5d8 )(defconstant XK_Arabic_ain #x5d9 )(defconstant XK_Arabic_ghain #x5da )(defconstant XK_Arabic_tatweel #x5e0 )(defconstant XK_Arabic_feh #x5e1 )(defconstant XK_Arabic_qaf #x5e2 )(defconstant XK_Arabic_kaf #x5e3 )(defconstant XK_Arabic_lam #x5e4 )(defconstant XK_Arabic_meem #x5e5 )(defconstant XK_Arabic_noon #x5e6 )(defconstant XK_Arabic_ha #x5e7 )(defconstant XK_Arabic_heh #x5e7 ;; deprecated )(defconstant XK_Arabic_waw #x5e8 )(defconstant XK_Arabic_alefmaksura #x5e9 )(defconstant XK_Arabic_yeh #x5ea )(defconstant XK_Arabic_fathatan #x5eb )(defconstant XK_Arabic_dammatan #x5ec )(defconstant XK_Arabic_kasratan #x5ed )(defconstant XK_Arabic_fatha #x5ee )(defconstant XK_Arabic_damma #x5ef )(defconstant XK_Arabic_kasra #x5f0 )(defconstant XK_Arabic_shadda #x5f1 )(defconstant XK_Arabic_sukun #x5f2 )(defconstant XK_Arabic_switch #xFF7E ;; Alias for mode_switch ;;endif ;; XK_ARABIC ;; ; Cyrillic ; Byte 3 = 6 ;;ifdef XK_CYRILLIC )(defconstant XK_Serbian_dje #x6a1 )(defconstant XK_Macedonia_gje #x6a2 )(defconstant XK_Cyrillic_io #x6a3 )(defconstant XK_Ukrainian_ie #x6a4 )(defconstant XK_Ukranian_je #x6a4 ;; deprecated )(defconstant XK_Macedonia_dse #x6a5 )(defconstant XK_Ukrainian_i #x6a6 )(defconstant XK_Ukranian_i #x6a6 ;; deprecated )(defconstant XK_Ukrainian_yi #x6a7 )(defconstant XK_Ukranian_yi #x6a7 ;; deprecated )(defconstant XK_Cyrillic_je #x6a8 )(defconstant XK_Serbian_je #x6a8 ;; deprecated )(defconstant XK_Cyrillic_lje #x6a9 )(defconstant XK_Serbian_lje #x6a9 ;; deprecated )(defconstant XK_Cyrillic_nje #x6aa )(defconstant XK_Serbian_nje #x6aa ;; deprecated )(defconstant XK_Serbian_tshe #x6ab )(defconstant XK_Macedonia_kje #x6ac )(defconstant XK_Byelorussian_shortu #x6ae )(defconstant XK_Cyrillic_dzhe #x6af )(defconstant XK_Serbian_dze #x6af ;; deprecated )(defconstant XK_numerosign #x6b0 )(defconstant XK_Serbian_DJE #x6b1 )(defconstant XK_Macedonia_GJE #x6b2 )(defconstant XK_Cyrillic_IO #x6b3 )(defconstant XK_Ukrainian_IE #x6b4 )(defconstant XK_Ukranian_JE #x6b4 ;; deprecated )(defconstant XK_Macedonia_DSE #x6b5 )(defconstant XK_Ukrainian_I #x6b6 )(defconstant XK_Ukranian_I #x6b6 ;; deprecated )(defconstant XK_Ukrainian_YI #x6b7 )(defconstant XK_Ukranian_YI #x6b7 ;; deprecated )(defconstant XK_Cyrillic_JE #x6b8 )(defconstant XK_Serbian_JE #x6b8 ;; deprecated )(defconstant XK_Cyrillic_LJE #x6b9 )(defconstant XK_Serbian_LJE #x6b9 ;; deprecated )(defconstant XK_Cyrillic_NJE #x6ba )(defconstant XK_Serbian_NJE #x6ba ;; deprecated )(defconstant XK_Serbian_TSHE #x6bb )(defconstant XK_Macedonia_KJE #x6bc )(defconstant XK_Byelorussian_SHORTU #x6be )(defconstant XK_Cyrillic_DZHE #x6bf )(defconstant XK_Serbian_DZE #x6bf ;; deprecated )(defconstant XK_Cyrillic_yu #x6c0 )(defconstant XK_Cyrillic_a #x6c1 )(defconstant XK_Cyrillic_be #x6c2 )(defconstant XK_Cyrillic_tse #x6c3 )(defconstant XK_Cyrillic_de #x6c4 )(defconstant XK_Cyrillic_ie #x6c5 )(defconstant XK_Cyrillic_ef #x6c6 )(defconstant XK_Cyrillic_ghe #x6c7 )(defconstant XK_Cyrillic_ha #x6c8 )(defconstant XK_Cyrillic_i #x6c9 )(defconstant XK_Cyrillic_shorti #x6ca )(defconstant XK_Cyrillic_ka #x6cb )(defconstant XK_Cyrillic_el #x6cc )(defconstant XK_Cyrillic_em #x6cd )(defconstant XK_Cyrillic_en #x6ce )(defconstant XK_Cyrillic_o #x6cf )(defconstant XK_Cyrillic_pe #x6d0 )(defconstant XK_Cyrillic_ya #x6d1 )(defconstant XK_Cyrillic_er #x6d2 )(defconstant XK_Cyrillic_es #x6d3 )(defconstant XK_Cyrillic_te #x6d4 )(defconstant XK_Cyrillic_u #x6d5 )(defconstant XK_Cyrillic_zhe #x6d6 )(defconstant XK_Cyrillic_ve #x6d7 )(defconstant XK_Cyrillic_softsign #x6d8 )(defconstant XK_Cyrillic_yeru #x6d9 )(defconstant XK_Cyrillic_ze #x6da )(defconstant XK_Cyrillic_sha #x6db )(defconstant XK_Cyrillic_e #x6dc )(defconstant XK_Cyrillic_shcha #x6dd )(defconstant XK_Cyrillic_che #x6de )(defconstant XK_Cyrillic_hardsign #x6df )(defconstant XK_Cyrillic_YU #x6e0 )(defconstant XK_Cyrillic_A #x6e1 )(defconstant XK_Cyrillic_BE #x6e2 )(defconstant XK_Cyrillic_TSE #x6e3 )(defconstant XK_Cyrillic_DE #x6e4 )(defconstant XK_Cyrillic_IE #x6e5 )(defconstant XK_Cyrillic_EF #x6e6 )(defconstant XK_Cyrillic_GHE #x6e7 )(defconstant XK_Cyrillic_HA #x6e8 )(defconstant XK_Cyrillic_I #x6e9 )(defconstant XK_Cyrillic_SHORTI #x6ea )(defconstant XK_Cyrillic_KA #x6eb )(defconstant XK_Cyrillic_EL #x6ec )(defconstant XK_Cyrillic_EM #x6ed )(defconstant XK_Cyrillic_EN #x6ee )(defconstant XK_Cyrillic_O #x6ef )(defconstant XK_Cyrillic_PE #x6f0 )(defconstant XK_Cyrillic_YA #x6f1 )(defconstant XK_Cyrillic_ER #x6f2 )(defconstant XK_Cyrillic_ES #x6f3 )(defconstant XK_Cyrillic_TE #x6f4 )(defconstant XK_Cyrillic_U #x6f5 )(defconstant XK_Cyrillic_ZHE #x6f6 )(defconstant XK_Cyrillic_VE #x6f7 )(defconstant XK_Cyrillic_SOFTSIGN #x6f8 )(defconstant XK_Cyrillic_YERU #x6f9 )(defconstant XK_Cyrillic_ZE #x6fa )(defconstant XK_Cyrillic_SHA #x6fb )(defconstant XK_Cyrillic_E #x6fc )(defconstant XK_Cyrillic_SHCHA #x6fd )(defconstant XK_Cyrillic_CHE #x6fe )(defconstant XK_Cyrillic_HARDSIGN #x6ff ;;endif ;; XK_CYRILLIC ;; ; Greek ; Byte 3 = 7 ;;ifdef XK_GREEK )(defconstant XK_Greek_ALPHAaccent #x7a1 )(defconstant XK_Greek_EPSILONaccent #x7a2 )(defconstant XK_Greek_ETAaccent #x7a3 )(defconstant XK_Greek_IOTAaccent #x7a4 )(defconstant XK_Greek_IOTAdiaeresis #x7a5 )(defconstant XK_Greek_OMICRONaccent #x7a7 )(defconstant XK_Greek_UPSILONaccent #x7a8 )(defconstant XK_Greek_UPSILONdieresis #x7a9 )(defconstant XK_Greek_OMEGAaccent #x7ab )(defconstant XK_Greek_accentdieresis #x7ae )(defconstant XK_Greek_horizbar #x7af )(defconstant XK_Greek_alphaaccent #x7b1 )(defconstant XK_Greek_epsilonaccent #x7b2 )(defconstant XK_Greek_etaaccent #x7b3 )(defconstant XK_Greek_iotaaccent #x7b4 )(defconstant XK_Greek_iotadieresis #x7b5 )(defconstant XK_Greek_iotaaccentdieresis #x7b6 )(defconstant XK_Greek_omicronaccent #x7b7 )(defconstant XK_Greek_upsilonaccent #x7b8 )(defconstant XK_Greek_upsilondieresis #x7b9 )(defconstant XK_Greek_upsilonaccentdieresis #x7ba )(defconstant XK_Greek_omegaaccent #x7bb )(defconstant XK_Greek_ALPHA #x7c1 )(defconstant XK_Greek_BETA #x7c2 )(defconstant XK_Greek_GAMMA #x7c3 )(defconstant XK_Greek_DELTA #x7c4 )(defconstant XK_Greek_EPSILON #x7c5 )(defconstant XK_Greek_ZETA #x7c6 )(defconstant XK_Greek_ETA #x7c7 )(defconstant XK_Greek_THETA #x7c8 )(defconstant XK_Greek_IOTA #x7c9 )(defconstant XK_Greek_KAPPA #x7ca )(defconstant XK_Greek_LAMDA #x7cb )(defconstant XK_Greek_LAMBDA #x7cb )(defconstant XK_Greek_MU #x7cc )(defconstant XK_Greek_NU #x7cd )(defconstant XK_Greek_XI #x7ce )(defconstant XK_Greek_OMICRON #x7cf )(defconstant XK_Greek_PI #x7d0 )(defconstant XK_Greek_RHO #x7d1 )(defconstant XK_Greek_SIGMA #x7d2 )(defconstant XK_Greek_TAU #x7d4 )(defconstant XK_Greek_UPSILON #x7d5 )(defconstant XK_Greek_PHI #x7d6 )(defconstant XK_Greek_CHI #x7d7 )(defconstant XK_Greek_PSI #x7d8 )(defconstant XK_Greek_OMEGA #x7d9 )(defconstant XK_Greek_alpha #x7e1 )(defconstant XK_Greek_beta #x7e2 )(defconstant XK_Greek_gamma #x7e3 )(defconstant XK_Greek_delta #x7e4 )(defconstant XK_Greek_epsilon #x7e5 )(defconstant XK_Greek_zeta #x7e6 )(defconstant XK_Greek_eta #x7e7 )(defconstant XK_Greek_theta #x7e8 )(defconstant XK_Greek_iota #x7e9 )(defconstant XK_Greek_kappa #x7ea )(defconstant XK_Greek_lamda #x7eb )(defconstant XK_Greek_lambda #x7eb )(defconstant XK_Greek_mu #x7ec )(defconstant XK_Greek_nu #x7ed )(defconstant XK_Greek_xi #x7ee )(defconstant XK_Greek_omicron #x7ef )(defconstant XK_Greek_pi #x7f0 )(defconstant XK_Greek_rho #x7f1 )(defconstant XK_Greek_sigma #x7f2 )(defconstant XK_Greek_finalsmallsigma #x7f3 )(defconstant XK_Greek_tau #x7f4 )(defconstant XK_Greek_upsilon #x7f5 )(defconstant XK_Greek_phi #x7f6 )(defconstant XK_Greek_chi #x7f7 )(defconstant XK_Greek_psi #x7f8 )(defconstant XK_Greek_omega #x7f9 )(defconstant XK_Greek_switch #xFF7E ;; Alias for mode_switch ;;endif ;; XK_GREEK ;; ; Technical ; Byte 3 = 8 ;;ifdef XK_TECHNICAL )(defconstant XK_leftradical #x8a1 )(defconstant XK_topleftradical #x8a2 )(defconstant XK_horizconnector #x8a3 )(defconstant XK_topintegral #x8a4 )(defconstant XK_botintegral #x8a5 )(defconstant XK_vertconnector #x8a6 )(defconstant XK_topleftsqbracket #x8a7 )(defconstant XK_botleftsqbracket #x8a8 )(defconstant XK_toprightsqbracket #x8a9 )(defconstant XK_botrightsqbracket #x8aa )(defconstant XK_topleftparens #x8ab )(defconstant XK_botleftparens #x8ac )(defconstant XK_toprightparens #x8ad )(defconstant XK_botrightparens #x8ae )(defconstant XK_leftmiddlecurlybrace #x8af )(defconstant XK_rightmiddlecurlybrace #x8b0 )(defconstant XK_topleftsummation #x8b1 )(defconstant XK_botleftsummation #x8b2 )(defconstant XK_topvertsummationconnector #x8b3 )(defconstant XK_botvertsummationconnector #x8b4 )(defconstant XK_toprightsummation #x8b5 )(defconstant XK_botrightsummation #x8b6 )(defconstant XK_rightmiddlesummation #x8b7 )(defconstant XK_lessthanequal #x8bc )(defconstant XK_notequal #x8bd )(defconstant XK_greaterthanequal #x8be )(defconstant XK_integral #x8bf )(defconstant XK_therefore #x8c0 )(defconstant XK_variation #x8c1 )(defconstant XK_infinity #x8c2 )(defconstant XK_nabla #x8c5 )(defconstant XK_approximate #x8c8 )(defconstant XK_similarequal #x8c9 )(defconstant XK_ifonlyif #x8cd )(defconstant XK_implies #x8ce )(defconstant XK_identical #x8cf )(defconstant XK_radical #x8d6 )(defconstant XK_includedin #x8da )(defconstant XK_includes #x8db )(defconstant XK_intersection #x8dc )(defconstant XK_union #x8dd )(defconstant XK_logicaland #x8de )(defconstant XK_logicalor #x8df )(defconstant XK_partialderivative #x8ef )(defconstant XK_function #x8f6 )(defconstant XK_leftarrow #x8fb )(defconstant XK_uparrow #x8fc )(defconstant XK_rightarrow #x8fd )(defconstant XK_downarrow #x8fe ;;endif ;; XK_TECHNICAL ;; ; Special ; Byte 3 = 9 ;;ifdef XK_SPECIAL )(defconstant XK_blank #x9df )(defconstant XK_soliddiamond #x9e0 )(defconstant XK_checkerboard #x9e1 )(defconstant XK_ht #x9e2 )(defconstant XK_ff #x9e3 )(defconstant XK_cr #x9e4 )(defconstant XK_lf #x9e5 )(defconstant XK_nl #x9e8 )(defconstant XK_vt #x9e9 )(defconstant XK_lowrightcorner #x9ea )(defconstant XK_uprightcorner #x9eb )(defconstant XK_upleftcorner #x9ec )(defconstant XK_lowleftcorner #x9ed )(defconstant XK_crossinglines #x9ee )(defconstant XK_horizlinescan1 #x9ef )(defconstant XK_horizlinescan3 #x9f0 )(defconstant XK_horizlinescan5 #x9f1 )(defconstant XK_horizlinescan7 #x9f2 )(defconstant XK_horizlinescan9 #x9f3 )(defconstant XK_leftt #x9f4 )(defconstant XK_rightt #x9f5 )(defconstant XK_bott #x9f6 )(defconstant XK_topt #x9f7 )(defconstant XK_vertbar #x9f8 ;;endif ;; XK_SPECIAL ;; ; Publishing ; Byte 3 = a ;;ifdef XK_PUBLISHING )(defconstant XK_emspace #xaa1 )(defconstant XK_enspace #xaa2 )(defconstant XK_em3space #xaa3 )(defconstant XK_em4space #xaa4 )(defconstant XK_digitspace #xaa5 )(defconstant XK_punctspace #xaa6 )(defconstant XK_thinspace #xaa7 )(defconstant XK_hairspace #xaa8 )(defconstant XK_emdash #xaa9 )(defconstant XK_endash #xaaa )(defconstant XK_signifblank #xaac )(defconstant XK_ellipsis #xaae )(defconstant XK_doubbaselinedot #xaaf )(defconstant XK_onethird #xab0 )(defconstant XK_twothirds #xab1 )(defconstant XK_onefifth #xab2 )(defconstant XK_twofifths #xab3 )(defconstant XK_threefifths #xab4 )(defconstant XK_fourfifths #xab5 )(defconstant XK_onesixth #xab6 )(defconstant XK_fivesixths #xab7 )(defconstant XK_careof #xab8 )(defconstant XK_figdash #xabb )(defconstant XK_leftanglebracket #xabc )(defconstant XK_decimalpoint #xabd )(defconstant XK_rightanglebracket #xabe )(defconstant XK_marker #xabf )(defconstant XK_oneeighth #xac3 )(defconstant XK_threeeighths #xac4 )(defconstant XK_fiveeighths #xac5 )(defconstant XK_seveneighths #xac6 )(defconstant XK_trademark #xac9 )(defconstant XK_signaturemark #xaca )(defconstant XK_trademarkincircle #xacb )(defconstant XK_leftopentriangle #xacc )(defconstant XK_rightopentriangle #xacd )(defconstant XK_emopencircle #xace )(defconstant XK_emopenrectangle #xacf )(defconstant XK_leftsinglequotemark #xad0 )(defconstant XK_rightsinglequotemark #xad1 )(defconstant XK_leftdoublequotemark #xad2 )(defconstant XK_rightdoublequotemark #xad3 )(defconstant XK_prescription #xad4 )(defconstant XK_minutes #xad6 )(defconstant XK_seconds #xad7 )(defconstant XK_latincross #xad9 )(defconstant XK_hexagram #xada )(defconstant XK_filledrectbullet #xadb )(defconstant XK_filledlefttribullet #xadc )(defconstant XK_filledrighttribullet #xadd )(defconstant XK_emfilledcircle #xade )(defconstant XK_emfilledrect #xadf )(defconstant XK_enopencircbullet #xae0 )(defconstant XK_enopensquarebullet #xae1 )(defconstant XK_openrectbullet #xae2 )(defconstant XK_opentribulletup #xae3 )(defconstant XK_opentribulletdown #xae4 )(defconstant XK_openstar #xae5 )(defconstant XK_enfilledcircbullet #xae6 )(defconstant XK_enfilledsqbullet #xae7 )(defconstant XK_filledtribulletup #xae8 )(defconstant XK_filledtribulletdown #xae9 )(defconstant XK_leftpointer #xaea )(defconstant XK_rightpointer #xaeb )(defconstant XK_club #xaec )(defconstant XK_diamond #xaed )(defconstant XK_heart #xaee )(defconstant XK_maltesecross #xaf0 )(defconstant XK_dagger #xaf1 )(defconstant XK_doubledagger #xaf2 )(defconstant XK_checkmark #xaf3 )(defconstant XK_ballotcross #xaf4 )(defconstant XK_musicalsharp #xaf5 )(defconstant XK_musicalflat #xaf6 )(defconstant XK_malesymbol #xaf7 )(defconstant XK_femalesymbol #xaf8 )(defconstant XK_telephone #xaf9 )(defconstant XK_telephonerecorder #xafa )(defconstant XK_phonographcopyright #xafb )(defconstant XK_caret #xafc )(defconstant XK_singlelowquotemark #xafd )(defconstant XK_doublelowquotemark #xafe )(defconstant XK_cursor #xaff ;;endif ;; XK_PUBLISHING ;; ; APL ; Byte 3 = b ;;ifdef XK_APL )(defconstant XK_leftcaret #xba3 )(defconstant XK_rightcaret #xba6 )(defconstant XK_downcaret #xba8 )(defconstant XK_upcaret #xba9 )(defconstant XK_overbar #xbc0 )(defconstant XK_downtack #xbc2 )(defconstant XK_upshoe #xbc3 )(defconstant XK_downstile #xbc4 )(defconstant XK_underbar #xbc6 )(defconstant XK_jot #xbca )(defconstant XK_quad #xbcc )(defconstant XK_uptack #xbce )(defconstant XK_circle #xbcf )(defconstant XK_upstile #xbd3 )(defconstant XK_downshoe #xbd6 )(defconstant XK_rightshoe #xbd8 )(defconstant XK_leftshoe #xbda )(defconstant XK_lefttack #xbdc )(defconstant XK_righttack #xbfc ;;endif ;; XK_APL ;; ; Hebrew ; Byte 3 = c ;;ifdef XK_HEBREW )(defconstant XK_hebrew_doublelowline #xcdf )(defconstant XK_hebrew_aleph #xce0 )(defconstant XK_hebrew_bet #xce1 )(defconstant XK_hebrew_beth #xce1 ;; deprecated )(defconstant XK_hebrew_gimel #xce2 )(defconstant XK_hebrew_gimmel #xce2 ;; deprecated )(defconstant XK_hebrew_dalet #xce3 )(defconstant XK_hebrew_daleth #xce3 ;; deprecated )(defconstant XK_hebrew_he #xce4 )(defconstant XK_hebrew_waw #xce5 )(defconstant XK_hebrew_zain #xce6 )(defconstant XK_hebrew_zayin #xce6 ;; deprecated )(defconstant XK_hebrew_chet #xce7 )(defconstant XK_hebrew_het #xce7 ;; deprecated )(defconstant XK_hebrew_tet #xce8 )(defconstant XK_hebrew_teth #xce8 ;; deprecated )(defconstant XK_hebrew_yod #xce9 )(defconstant XK_hebrew_finalkaph #xcea )(defconstant XK_hebrew_kaph #xceb )(defconstant XK_hebrew_lamed #xcec )(defconstant XK_hebrew_finalmem #xced )(defconstant XK_hebrew_mem #xcee )(defconstant XK_hebrew_finalnun #xcef )(defconstant XK_hebrew_nun #xcf0 )(defconstant XK_hebrew_samech #xcf1 )(defconstant XK_hebrew_samekh #xcf1 ;; deprecated )(defconstant XK_hebrew_ayin #xcf2 )(defconstant XK_hebrew_finalpe #xcf3 )(defconstant XK_hebrew_pe #xcf4 )(defconstant XK_hebrew_finalzade #xcf5 )(defconstant XK_hebrew_finalzadi #xcf5 ;; deprecated )(defconstant XK_hebrew_zade #xcf6 )(defconstant XK_hebrew_zadi #xcf6 ;; deprecated )(defconstant XK_hebrew_qoph #xcf7 )(defconstant XK_hebrew_kuf #xcf7 ;; deprecated )(defconstant XK_hebrew_resh #xcf8 )(defconstant XK_hebrew_shin #xcf9 )(defconstant XK_hebrew_taw #xcfa )(defconstant XK_hebrew_taf #xcfa ;; deprecated )(defconstant XK_Hebrew_switch #xFF7E ;; Alias for mode_switch ;;endif ;; XK_HEBREW ) gcl-2.6.14/xgcl-2/XStruct-4.c0000644000175000017500000010407314360276512014015 0ustar cammcamm/* XStruct-4.c Hiep Huu Nguyen 27 Jun 06 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; edited 27 Aug 92; 12 Aug 2002 by G. Novak; 24 Jun 06 by GSN ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. */ #include #include #include #include /********* XExtCodes functions *****/ long make_XExtCodes (){ return ((long) calloc(1, sizeof(XExtCodes))); } int XExtCodes_first_error(i) XExtCodes* i; { return(i->first_error); } void set_XExtCodes_first_error(i, j) XExtCodes* i; int j; { i->first_error = j; } int XExtCodes_first_event(i) XExtCodes* i; { return(i->first_event); } void set_XExtCodes_first_event(i, j) XExtCodes* i; int j; { i->first_event = j; } int XExtCodes_major_opcode(i) XExtCodes* i; { return(i->major_opcode); } void set_XExtCodes_major_opcode(i, j) XExtCodes* i; int j; { i->major_opcode = j; } int XExtCodes_extension(i) XExtCodes* i; { return(i->extension); } void set_XExtCodes_extension(i, j) XExtCodes* i; int j; { i->extension = j; } /********* XPixmapFormatValues functions *****/ long make_XPixmapFormatValues (){ return ((long) calloc(1, sizeof(XPixmapFormatValues))); } int XPixmapFormatValues_scanline_pad(i) XPixmapFormatValues* i; { return(i->scanline_pad); } void set_XPixmapFormatValues_scanline_pad(i, j) XPixmapFormatValues* i; int j; { i->scanline_pad = j; } int XPixmapFormatValues_bits_per_pixel(i) XPixmapFormatValues* i; { return(i->bits_per_pixel); } void set_XPixmapFormatValues_bits_per_pixel(i, j) XPixmapFormatValues* i; int j; { i->bits_per_pixel = j; } int XPixmapFormatValues_depth(i) XPixmapFormatValues* i; { return(i->depth); } void set_XPixmapFormatValues_depth(i, j) XPixmapFormatValues* i; int j; { i->depth = j; } /********* XGCValues functions *****/ long make_XGCValues (){ return ((long) calloc(1, sizeof(XGCValues))); } char XGCValues_dashes(i) XGCValues* i; { return(i->dashes); } void set_XGCValues_dashes(i, j) XGCValues* i; char j; { i->dashes = j; } int XGCValues_dash_offset(i) XGCValues* i; { return(i->dash_offset); } void set_XGCValues_dash_offset(i, j) XGCValues* i; int j; { i->dash_offset = j; } int XGCValues_clip_mask(i) XGCValues* i; { return(i->clip_mask); } void set_XGCValues_clip_mask(i, j) XGCValues* i; int j; { i->clip_mask = j; } int XGCValues_clip_y_origin(i) XGCValues* i; { return(i->clip_y_origin); } void set_XGCValues_clip_y_origin(i, j) XGCValues* i; int j; { i->clip_y_origin = j; } int XGCValues_clip_x_origin(i) XGCValues* i; { return(i->clip_x_origin); } void set_XGCValues_clip_x_origin(i, j) XGCValues* i; int j; { i->clip_x_origin = j; } int XGCValues_graphics_exposures(i) XGCValues* i; { return(i->graphics_exposures); } void set_XGCValues_graphics_exposures(i, j) XGCValues* i; int j; { i->graphics_exposures = j; } int XGCValues_subwindow_mode(i) XGCValues* i; { return(i->subwindow_mode); } void set_XGCValues_subwindow_mode(i, j) XGCValues* i; int j; { i->subwindow_mode = j; } int XGCValues_font(i) XGCValues* i; { return(i->font); } void set_XGCValues_font(i, j) XGCValues* i; int j; { i->font = j; } int XGCValues_ts_y_origin(i) XGCValues* i; { return(i->ts_y_origin); } void set_XGCValues_ts_y_origin(i, j) XGCValues* i; int j; { i->ts_y_origin = j; } int XGCValues_ts_x_origin(i) XGCValues* i; { return(i->ts_x_origin); } void set_XGCValues_ts_x_origin(i, j) XGCValues* i; int j; { i->ts_x_origin = j; } int XGCValues_stipple(i) XGCValues* i; { return(i->stipple); } void set_XGCValues_stipple(i, j) XGCValues* i; int j; { i->stipple = j; } int XGCValues_tile(i) XGCValues* i; { return(i->tile); } void set_XGCValues_tile(i, j) XGCValues* i; int j; { i->tile = j; } int XGCValues_arc_mode(i) XGCValues* i; { return(i->arc_mode); } void set_XGCValues_arc_mode(i, j) XGCValues* i; int j; { i->arc_mode = j; } int XGCValues_fill_rule(i) XGCValues* i; { return(i->fill_rule); } void set_XGCValues_fill_rule(i, j) XGCValues* i; int j; { i->fill_rule = j; } int XGCValues_fill_style(i) XGCValues* i; { return(i->fill_style); } void set_XGCValues_fill_style(i, j) XGCValues* i; int j; { i->fill_style = j; } int XGCValues_join_style(i) XGCValues* i; { return(i->join_style); } void set_XGCValues_join_style(i, j) XGCValues* i; int j; { i->join_style = j; } int XGCValues_cap_style(i) XGCValues* i; { return(i->cap_style); } void set_XGCValues_cap_style(i, j) XGCValues* i; int j; { i->cap_style = j; } int XGCValues_line_style(i) XGCValues* i; { return(i->line_style); } void set_XGCValues_line_style(i, j) XGCValues* i; int j; { i->line_style = j; } int XGCValues_line_width(i) XGCValues* i; { return(i->line_width); } void set_XGCValues_line_width(i, j) XGCValues* i; int j; { i->line_width = j; } int XGCValues_background(i) XGCValues* i; { return(i->background); } void set_XGCValues_background(i, j) XGCValues* i; int j; { i->background = j; } int XGCValues_foreground(i) XGCValues* i; { return(i->foreground); } void set_XGCValues_foreground(i, j) XGCValues* i; int j; { i->foreground = j; } int XGCValues_plane_mask(i) XGCValues* i; { return(i->plane_mask); } void set_XGCValues_plane_mask(i, j) XGCValues* i; int j; { i->plane_mask = j; } int XGCValues_function(i) XGCValues* i; { return(i->function); } void set_XGCValues_function(i, j) XGCValues* i; int j; { i->function = j; } /********* GC functions ***** int make_GC (){ GC i; return ((int) &i); } int GC_values(i) GC i; { return(i->values); } void set_GC_values(i, j) GC i; int j; { i->values = j; } int GC_dirty(i) GC i; { return(i->dirty); } void set_GC_dirty(i, j) GC i; int j; { i->dirty = j; } int GC_dashes(i) GC i; { return(i->dashes); } void set_GC_dashes(i, j) GC i; int j; { i->dashes = j; } int GC_rects(i) GC i; { return(i->rects); } void set_GC_rects(i, j) GC i; int j; { i->rects = j; } int GC_gid(i) GC i; { return(i->gid); } void set_GC_gid(i, j) GC i; int j; { i->gid = j; } int GC_ext_data(i) GC i; { return(i->ext_data); } void set_GC_ext_data(i, j) GC i; int j; { i->ext_data = j; } */ /********* Visual functions *****/ long make_Visual (){ return ((long) calloc(1, sizeof(Visual))); } int Visual_map_entries(i) Visual* i; { return(i->map_entries); } void set_Visual_map_entries(i, j) Visual* i; int j; { i->map_entries = j; } int Visual_bits_per_rgb(i) Visual* i; { return(i->bits_per_rgb); } void set_Visual_bits_per_rgb(i, j) Visual* i; int j; { i->bits_per_rgb = j; } int Visual_blue_mask(i) Visual* i; { return(i->blue_mask); } void set_Visual_blue_mask(i, j) Visual* i; int j; { i->blue_mask = j; } int Visual_green_mask(i) Visual* i; { return(i->green_mask); } void set_Visual_green_mask(i, j) Visual* i; int j; { i->green_mask = j; } int Visual_red_mask(i) Visual* i; { return(i->red_mask); } void set_Visual_red_mask(i, j) Visual* i; int j; { i->red_mask = j; } int Visual_class(i) Visual* i; { return(i->class); } void set_Visual_class(i, j) Visual* i; int j; { i->class = j; } int Visual_visualid(i) Visual* i; { return(i->visualid); } void set_Visual_visualid(i, j) Visual* i; int j; { i->visualid = j; } long Visual_ext_data(i) Visual* i; { return((long) i->ext_data); } void set_Visual_ext_data(i, j) Visual* i; long j; { i->ext_data = (XExtData *) j; } /********* Depth functions *****/ long make_Depth (){ return ((long) calloc(1, sizeof(Depth))); } long Depth_visuals(i) Depth* i; { return((long) i->visuals); } void set_Depth_visuals(i, j) Depth* i; long j; { i->visuals = (Visual *) j; } int Depth_nvisuals(i) Depth* i; { return(i->nvisuals); } void set_Depth_nvisuals(i, j) Depth* i; int j; { i->nvisuals = j; } int Depth_depth(i) Depth* i; { return(i->depth); } void set_Depth_depth(i, j) Depth* i; int j; { i->depth = j; } /********* Screen functions *****/ long make_Screen (){ return ((long) calloc(1, sizeof(Screen))); } int Screen_root_input_mask(i) Screen* i; { return(i->root_input_mask); } void set_Screen_root_input_mask(i, j) Screen* i; int j; { i->root_input_mask = j; } int Screen_save_unders(i) Screen* i; { return(i->save_unders); } void set_Screen_save_unders(i, j) Screen* i; int j; { i->save_unders = j; } int Screen_backing_store(i) Screen* i; { return(i->backing_store); } void set_Screen_backing_store(i, j) Screen* i; int j; { i->backing_store = j; } int Screen_min_maps(i) Screen* i; { return(i->min_maps); } void set_Screen_min_maps(i, j) Screen* i; int j; { i->min_maps = j; } int Screen_max_maps(i) Screen* i; { return(i->max_maps); } void set_Screen_max_maps(i, j) Screen* i; int j; { i->max_maps = j; } int Screen_black_pixel(i) Screen* i; { return(i->black_pixel); } void set_Screen_black_pixel(i, j) Screen* i; int j; { i->black_pixel = j; } int Screen_white_pixel(i) Screen* i; { return(i->white_pixel); } void set_Screen_white_pixel(i, j) Screen* i; int j; { i->white_pixel = j; } int Screen_cmap(i) Screen* i; { return(i->cmap); } void set_Screen_cmap(i, j) Screen* i; int j; { i->cmap = j; } long Screen_default_gc(i) Screen* i; { return((long) i->default_gc); } void set_Screen_default_gc(i, j) Screen* i; long j; { i->default_gc = (GC) j; } long Screen_root_visual(i) Screen* i; { return((long) i->root_visual); } void set_Screen_root_visual(i, j) Screen* i; long j; { i->root_visual = (Visual *) j; } int Screen_root_depth(i) Screen* i; { return(i->root_depth); } void set_Screen_root_depth(i, j) Screen* i; int j; { i->root_depth = j; } long Screen_depths(i) Screen* i; { return((long) i->depths); } void set_Screen_depths(i, j) Screen* i; long j; { i->depths = (Depth *) j; } int Screen_ndepths(i) Screen* i; { return(i->ndepths); } void set_Screen_ndepths(i, j) Screen* i; int j; { i->ndepths = j; } int Screen_mheight(i) Screen* i; { return(i->mheight); } void set_Screen_mheight(i, j) Screen* i; int j; { i->mheight = j; } int Screen_mwidth(i) Screen* i; { return(i->mwidth); } void set_Screen_mwidth(i, j) Screen* i; int j; { i->mwidth = j; } int Screen_height(i) Screen* i; { return(i->height); } void set_Screen_height(i, j) Screen* i; int j; { i->height = j; } int Screen_width(i) Screen* i; { return(i->width); } void set_Screen_width(i, j) Screen* i; int j; { i->width = j; } int Screen_root(i) Screen* i; { return(i->root); } void set_Screen_root(i, j) Screen* i; int j; { i->root = j; } long Screen_display(i) Screen* i; { return((long) i->display); } void set_Screen_display(i, j) Screen* i; long j; { i->display = (struct _XDisplay *) j; } long Screen_ext_data(i) Screen* i; { return((long) i->ext_data); } void set_Screen_ext_data(i, j) Screen* i; long j; { i->ext_data = (XExtData *) j; } /********* ScreenFormat functions *****/ long make_ScreenFormat (){ return ((long) calloc(1, sizeof(ScreenFormat))); } int ScreenFormat_scanline_pad(i) ScreenFormat* i; { return(i->scanline_pad); } void set_ScreenFormat_scanline_pad(i, j) ScreenFormat* i; int j; { i->scanline_pad = j; } int ScreenFormat_bits_per_pixel(i) ScreenFormat* i; { return(i->bits_per_pixel); } void set_ScreenFormat_bits_per_pixel(i, j) ScreenFormat* i; int j; { i->bits_per_pixel = j; } int ScreenFormat_depth(i) ScreenFormat* i; { return(i->depth); } void set_ScreenFormat_depth(i, j) ScreenFormat* i; int j; { i->depth = j; } long ScreenFormat_ext_data(i) ScreenFormat* i; { return((long) i->ext_data); } void set_ScreenFormat_ext_data(i, j) ScreenFormat* i; long j; { i->ext_data = (XExtData *) j; } /********* XSetWindowAttributes functions *****/ long make_XSetWindowAttributes (){ return ((long) calloc(1, sizeof(XSetWindowAttributes))); } int XSetWindowAttributes_cursor(i) XSetWindowAttributes* i; { return(i->cursor); } void set_XSetWindowAttributes_cursor(i, j) XSetWindowAttributes* i; int j; { i->cursor = j; } int XSetWindowAttributes_colormap(i) XSetWindowAttributes* i; { return(i->colormap); } void set_XSetWindowAttributes_colormap(i, j) XSetWindowAttributes* i; int j; { i->colormap = j; } int XSetWindowAttributes_override_redirect(i) XSetWindowAttributes* i; { return(i->override_redirect); } void set_XSetWindowAttributes_override_redirect(i, j) XSetWindowAttributes* i; int j; { i->override_redirect = j; } int XSetWindowAttributes_do_not_propagate_mask(i) XSetWindowAttributes* i; { return(i->do_not_propagate_mask); } void set_XSetWindowAttributes_do_not_propagate_mask(i, j) XSetWindowAttributes* i; int j; { i->do_not_propagate_mask = j; } int XSetWindowAttributes_event_mask(i) XSetWindowAttributes* i; { return(i->event_mask); } void set_XSetWindowAttributes_event_mask(i, j) XSetWindowAttributes* i; int j; { i->event_mask = j; } int XSetWindowAttributes_save_under(i) XSetWindowAttributes* i; { return(i->save_under); } void set_XSetWindowAttributes_save_under(i, j) XSetWindowAttributes* i; int j; { i->save_under = j; } int XSetWindowAttributes_backing_pixel(i) XSetWindowAttributes* i; { return(i->backing_pixel); } void set_XSetWindowAttributes_backing_pixel(i, j) XSetWindowAttributes* i; int j; { i->backing_pixel = j; } int XSetWindowAttributes_backing_planes(i) XSetWindowAttributes* i; { return(i->backing_planes); } void set_XSetWindowAttributes_backing_planes(i, j) XSetWindowAttributes* i; int j; { i->backing_planes = j; } int XSetWindowAttributes_backing_store(i) XSetWindowAttributes* i; { return(i->backing_store); } void set_XSetWindowAttributes_backing_store(i, j) XSetWindowAttributes* i; int j; { i->backing_store = j; } int XSetWindowAttributes_win_gravity(i) XSetWindowAttributes* i; { return(i->win_gravity); } void set_XSetWindowAttributes_win_gravity(i, j) XSetWindowAttributes* i; int j; { i->win_gravity = j; } int XSetWindowAttributes_bit_gravity(i) XSetWindowAttributes* i; { return(i->bit_gravity); } void set_XSetWindowAttributes_bit_gravity(i, j) XSetWindowAttributes* i; int j; { i->bit_gravity = j; } int XSetWindowAttributes_border_pixel(i) XSetWindowAttributes* i; { return(i->border_pixel); } void set_XSetWindowAttributes_border_pixel(i, j) XSetWindowAttributes* i; int j; { i->border_pixel = j; } int XSetWindowAttributes_border_pixmap(i) XSetWindowAttributes* i; { return(i->border_pixmap); } void set_XSetWindowAttributes_border_pixmap(i, j) XSetWindowAttributes* i; int j; { i->border_pixmap = j; } int XSetWindowAttributes_background_pixel(i) XSetWindowAttributes* i; { return(i->background_pixel); } void set_XSetWindowAttributes_background_pixel(i, j) XSetWindowAttributes* i; int j; { i->background_pixel = j; } int XSetWindowAttributes_background_pixmap(i) XSetWindowAttributes* i; { return(i->background_pixmap); } void set_XSetWindowAttributes_background_pixmap(i, j) XSetWindowAttributes* i; int j; { i->background_pixmap = j; } /********* XWindowAttributes functions *****/ long make_XWindowAttributes (){ return ((long) calloc(1, sizeof(XWindowAttributes))); } long XWindowAttributes_screen(i) XWindowAttributes* i; { return((long) i->screen); } void set_XWindowAttributes_screen(i, j) XWindowAttributes* i; long j; { i->screen = (Screen *) j; } int XWindowAttributes_override_redirect(i) XWindowAttributes* i; { return(i->override_redirect); } void set_XWindowAttributes_override_redirect(i, j) XWindowAttributes* i; int j; { i->override_redirect = j; } int XWindowAttributes_do_not_propagate_mask(i) XWindowAttributes* i; { return(i->do_not_propagate_mask); } void set_XWindowAttributes_do_not_propagate_mask(i, j) XWindowAttributes* i; int j; { i->do_not_propagate_mask = j; } int XWindowAttributes_your_event_mask(i) XWindowAttributes* i; { return(i->your_event_mask); } void set_XWindowAttributes_your_event_mask(i, j) XWindowAttributes* i; int j; { i->your_event_mask = j; } int XWindowAttributes_all_event_masks(i) XWindowAttributes* i; { return(i->all_event_masks); } void set_XWindowAttributes_all_event_masks(i, j) XWindowAttributes* i; int j; { i->all_event_masks = j; } int XWindowAttributes_map_state(i) XWindowAttributes* i; { return(i->map_state); } void set_XWindowAttributes_map_state(i, j) XWindowAttributes* i; int j; { i->map_state = j; } int XWindowAttributes_map_installed(i) XWindowAttributes* i; { return(i->map_installed); } void set_XWindowAttributes_map_installed(i, j) XWindowAttributes* i; int j; { i->map_installed = j; } int XWindowAttributes_colormap(i) XWindowAttributes* i; { return(i->colormap); } void set_XWindowAttributes_colormap(i, j) XWindowAttributes* i; int j; { i->colormap = j; } int XWindowAttributes_save_under(i) XWindowAttributes* i; { return(i->save_under); } void set_XWindowAttributes_save_under(i, j) XWindowAttributes* i; int j; { i->save_under = j; } int XWindowAttributes_backing_pixel(i) XWindowAttributes* i; { return(i->backing_pixel); } void set_XWindowAttributes_backing_pixel(i, j) XWindowAttributes* i; int j; { i->backing_pixel = j; } int XWindowAttributes_backing_planes(i) XWindowAttributes* i; { return(i->backing_planes); } void set_XWindowAttributes_backing_planes(i, j) XWindowAttributes* i; int j; { i->backing_planes = j; } int XWindowAttributes_backing_store(i) XWindowAttributes* i; { return(i->backing_store); } void set_XWindowAttributes_backing_store(i, j) XWindowAttributes* i; int j; { i->backing_store = j; } int XWindowAttributes_win_gravity(i) XWindowAttributes* i; { return(i->win_gravity); } void set_XWindowAttributes_win_gravity(i, j) XWindowAttributes* i; int j; { i->win_gravity = j; } int XWindowAttributes_bit_gravity(i) XWindowAttributes* i; { return(i->bit_gravity); } void set_XWindowAttributes_bit_gravity(i, j) XWindowAttributes* i; int j; { i->bit_gravity = j; } int XWindowAttributes_class(i) XWindowAttributes* i; { return(i->class); } void set_XWindowAttributes_class(i, j) XWindowAttributes* i; int j; { i->class = j; } int XWindowAttributes_root(i) XWindowAttributes* i; { return(i->root); } void set_XWindowAttributes_root(i, j) XWindowAttributes* i; int j; { i->root = j; } long XWindowAttributes_visual(i) XWindowAttributes* i; { return((long) i->visual); } void set_XWindowAttributes_visual(i, j) XWindowAttributes* i; long j; { i->visual = (Visual *) j; } int XWindowAttributes_depth(i) XWindowAttributes* i; { return(i->depth); } void set_XWindowAttributes_depth(i, j) XWindowAttributes* i; int j; { i->depth = j; } int XWindowAttributes_border_width(i) XWindowAttributes* i; { return(i->border_width); } void set_XWindowAttributes_border_width(i, j) XWindowAttributes* i; int j; { i->border_width = j; } int XWindowAttributes_height(i) XWindowAttributes* i; { return(i->height); } void set_XWindowAttributes_height(i, j) XWindowAttributes* i; int j; { i->height = j; } int XWindowAttributes_width(i) XWindowAttributes* i; { return(i->width); } void set_XWindowAttributes_width(i, j) XWindowAttributes* i; int j; { i->width = j; } int XWindowAttributes_y(i) XWindowAttributes* i; { return(i->y); } void set_XWindowAttributes_y(i, j) XWindowAttributes* i; int j; { i->y = j; } int XWindowAttributes_x(i) XWindowAttributes* i; { return(i->x); } void set_XWindowAttributes_x(i, j) XWindowAttributes* i; int j; { i->x = j; } /********* XHostAddress functions *****/ long make_XHostAddress (){ return ((long) calloc(1, sizeof(XHostAddress))); } long XHostAddress_address(i) XHostAddress* i; { return((long) i->address); } void set_XHostAddress_address(i, j) XHostAddress* i; long j; { i->address = (char *) j; } int XHostAddress_length(i) XHostAddress* i; { return(i->length); } void set_XHostAddress_length(i, j) XHostAddress* i; int j; { i->length = j; } int XHostAddress_family(i) XHostAddress* i; { return(i->family); } void set_XHostAddress_family(i, j) XHostAddress* i; int j; { i->family = j; } /********* XImage functions *****/ long make_XImage (){ return ((long) calloc(1, sizeof(XImage))); } long XImage_obdata(i) XImage* i; { return((long) i->obdata); } void set_XImage_obdata(i, j) XImage* i; long j; { i->obdata = (XPointer) j; } int XImage_blue_mask(i) XImage* i; { return(i->blue_mask); } void set_XImage_blue_mask(i, j) XImage* i; int j; { i->blue_mask = j; } int XImage_green_mask(i) XImage* i; { return(i->green_mask); } void set_XImage_green_mask(i, j) XImage* i; int j; { i->green_mask = j; } int XImage_red_mask(i) XImage* i; { return(i->red_mask); } void set_XImage_red_mask(i, j) XImage* i; int j; { i->red_mask = j; } int XImage_bits_per_pixel(i) XImage* i; { return(i->bits_per_pixel); } void set_XImage_bits_per_pixel(i, j) XImage* i; int j; { i->bits_per_pixel = j; } int XImage_bytes_per_line(i) XImage* i; { return(i->bytes_per_line); } void set_XImage_bytes_per_line(i, j) XImage* i; int j; { i->bytes_per_line = j; } int XImage_depth(i) XImage* i; { return(i->depth); } void set_XImage_depth(i, j) XImage* i; int j; { i->depth = j; } int XImage_bitmap_pad(i) XImage* i; { return(i->bitmap_pad); } void set_XImage_bitmap_pad(i, j) XImage* i; int j; { i->bitmap_pad = j; } int XImage_bitmap_bit_order(i) XImage* i; { return(i->bitmap_bit_order); } void set_XImage_bitmap_bit_order(i, j) XImage* i; int j; { i->bitmap_bit_order = j; } int XImage_bitmap_unit(i) XImage* i; { return(i->bitmap_unit); } void set_XImage_bitmap_unit(i, j) XImage* i; int j; { i->bitmap_unit = j; } int XImage_byte_order(i) XImage* i; { return(i->byte_order); } void set_XImage_byte_order(i, j) XImage* i; int j; { i->byte_order = j; } long XImage_data(i) XImage* i; { return((long) i->data); } void set_XImage_data(i, j) XImage* i; long j; { i->data = (char *) j; } int XImage_format(i) XImage* i; { return(i->format); } void set_XImage_format(i, j) XImage* i; int j; { i->format = j; } int XImage_xoffset(i) XImage* i; { return(i->xoffset); } void set_XImage_xoffset(i, j) XImage* i; int j; { i->xoffset = j; } int XImage_height(i) XImage* i; { return(i->height); } void set_XImage_height(i, j) XImage* i; int j; { i->height = j; } int XImage_width(i) XImage* i; { return(i->width); } void set_XImage_width(i, j) XImage* i; int j; { i->width = j; } /********* XWindowChanges functions *****/ long make_XWindowChanges (){ return ((long) calloc(1, sizeof(XWindowChanges))); } int XWindowChanges_stack_mode(i) XWindowChanges* i; { return(i->stack_mode); } void set_XWindowChanges_stack_mode(i, j) XWindowChanges* i; int j; { i->stack_mode = j; } int XWindowChanges_sibling(i) XWindowChanges* i; { return(i->sibling); } void set_XWindowChanges_sibling(i, j) XWindowChanges* i; int j; { i->sibling = j; } int XWindowChanges_border_width(i) XWindowChanges* i; { return(i->border_width); } void set_XWindowChanges_border_width(i, j) XWindowChanges* i; int j; { i->border_width = j; } int XWindowChanges_height(i) XWindowChanges* i; { return(i->height); } void set_XWindowChanges_height(i, j) XWindowChanges* i; int j; { i->height = j; } int XWindowChanges_width(i) XWindowChanges* i; { return(i->width); } void set_XWindowChanges_width(i, j) XWindowChanges* i; int j; { i->width = j; } int XWindowChanges_y(i) XWindowChanges* i; { return(i->y); } void set_XWindowChanges_y(i, j) XWindowChanges* i; int j; { i->y = j; } int XWindowChanges_x(i) XWindowChanges* i; { return(i->x); } void set_XWindowChanges_x(i, j) XWindowChanges* i; int j; { i->x = j; } /********* XColor functions *****/ long make_XColor (){ return ((long) calloc(1, sizeof(XColor))); } char XColor_pad(i) XColor* i; { return(i->pad); } void set_XColor_pad(i, j) XColor* i; char j; { i->pad = j; } char XColor_flags(i) XColor* i; { return(i->flags); } void set_XColor_flags(i, j) XColor* i; char j; { i->flags = j; } int XColor_blue(i) XColor* i; { return(i->blue); } void set_XColor_blue(i, j) XColor* i; int j; { i->blue = j; } int XColor_green(i) XColor* i; { return(i->green); } void set_XColor_green(i, j) XColor* i; int j; { i->green = j; } int XColor_red(i) XColor* i; { return(i->red); } void set_XColor_red(i, j) XColor* i; int j; { i->red = j; } int XColor_pixel(i) XColor* i; { return(i->pixel); } void set_XColor_pixel(i, j) XColor* i; int j; { i->pixel = j; } /********* XSegment functions *****/ long make_XSegment (){ return ((long) calloc(1, sizeof(XSegment))); } int XSegment_y2(i) XSegment* i; { return(i->y2); } void set_XSegment_y2(i, j) XSegment* i; int j; { i->y2 = j; } int XSegment_x2(i) XSegment* i; { return(i->x2); } void set_XSegment_x2(i, j) XSegment* i; int j; { i->x2 = j; } int XSegment_y1(i) XSegment* i; { return(i->y1); } void set_XSegment_y1(i, j) XSegment* i; int j; { i->y1 = j; } int XSegment_x1(i) XSegment* i; { return(i->x1); } void set_XSegment_x1(i, j) XSegment* i; int j; { i->x1 = j; } /********* XPoint functions *****/ long make_XPoint (){ return ((long) calloc(1, sizeof(XPoint))); } int XPoint_y(i) XPoint* i; { return(i->y); } void set_XPoint_y(i, j) XPoint* i; int j; { i->y = j; } int XPoint_x(i) XPoint* i; { return(i->x); } void set_XPoint_x(i, j) XPoint* i; int j; { i->x = j; } /********* XRectangle functions *****/ long make_XRectangle (){ return ((long) calloc(1, sizeof(XRectangle))); } int XRectangle_height(i) XRectangle* i; { return(i->height); } void set_XRectangle_height(i, j) XRectangle* i; int j; { i->height = j; } int XRectangle_width(i) XRectangle* i; { return(i->width); } void set_XRectangle_width(i, j) XRectangle* i; int j; { i->width = j; } int XRectangle_y(i) XRectangle* i; { return(i->y); } void set_XRectangle_y(i, j) XRectangle* i; int j; { i->y = j; } int XRectangle_x(i) XRectangle* i; { return(i->x); } void set_XRectangle_x(i, j) XRectangle* i; int j; { i->x = j; } /********* XArc functions *****/ long make_XArc (){ return ((long) calloc(1, sizeof(XArc))); } int XArc_angle2(i) XArc* i; { return(i->angle2); } void set_XArc_angle2(i, j) XArc* i; int j; { i->angle2 = j; } int XArc_angle1(i) XArc* i; { return(i->angle1); } void set_XArc_angle1(i, j) XArc* i; int j; { i->angle1 = j; } int XArc_height(i) XArc* i; { return(i->height); } void set_XArc_height(i, j) XArc* i; int j; { i->height = j; } int XArc_width(i) XArc* i; { return(i->width); } void set_XArc_width(i, j) XArc* i; int j; { i->width = j; } int XArc_y(i) XArc* i; { return(i->y); } void set_XArc_y(i, j) XArc* i; int j; { i->y = j; } int XArc_x(i) XArc* i; { return(i->x); } void set_XArc_x(i, j) XArc* i; int j; { i->x = j; } /********* XKeyboardControl functions *****/ long make_XKeyboardControl (){ return ((long) calloc(1, sizeof(XKeyboardControl))); } int XKeyboardControl_auto_repeat_mode(i) XKeyboardControl* i; { return(i->auto_repeat_mode); } void set_XKeyboardControl_auto_repeat_mode(i, j) XKeyboardControl* i; int j; { i->auto_repeat_mode = j; } int XKeyboardControl_key(i) XKeyboardControl* i; { return(i->key); } void set_XKeyboardControl_key(i, j) XKeyboardControl* i; int j; { i->key = j; } int XKeyboardControl_led_mode(i) XKeyboardControl* i; { return(i->led_mode); } void set_XKeyboardControl_led_mode(i, j) XKeyboardControl* i; int j; { i->led_mode = j; } int XKeyboardControl_led(i) XKeyboardControl* i; { return(i->led); } void set_XKeyboardControl_led(i, j) XKeyboardControl* i; int j; { i->led = j; } int XKeyboardControl_bell_duration(i) XKeyboardControl* i; { return(i->bell_duration); } void set_XKeyboardControl_bell_duration(i, j) XKeyboardControl* i; int j; { i->bell_duration = j; } int XKeyboardControl_bell_pitch(i) XKeyboardControl* i; { return(i->bell_pitch); } void set_XKeyboardControl_bell_pitch(i, j) XKeyboardControl* i; int j; { i->bell_pitch = j; } int XKeyboardControl_bell_percent(i) XKeyboardControl* i; { return(i->bell_percent); } void set_XKeyboardControl_bell_percent(i, j) XKeyboardControl* i; int j; { i->bell_percent = j; } int XKeyboardControl_key_click_percent(i) XKeyboardControl* i; { return(i->key_click_percent); } void set_XKeyboardControl_key_click_percent(i, j) XKeyboardControl* i; int j; { i->key_click_percent = j; } /********* XKeyboardState functions *****/ long make_XKeyboardState (){ return ((long) calloc(1, sizeof(XKeyboardState))); } char *XKeyboardState_auto_repeats(i) XKeyboardState* i; { return(i->auto_repeats); } void set_XKeyboardState_auto_repeats(i, j) XKeyboardState* i; char *j; { strcpy(i->auto_repeats, j); } int XKeyboardState_global_auto_repeat(i) XKeyboardState* i; { return(i->global_auto_repeat); } void set_XKeyboardState_global_auto_repeat(i, j) XKeyboardState* i; int j; { i->global_auto_repeat = j; } int XKeyboardState_led_mask(i) XKeyboardState* i; { return(i->led_mask); } void set_XKeyboardState_led_mask(i, j) XKeyboardState* i; int j; { i->led_mask = j; } int XKeyboardState_bell_duration(i) XKeyboardState* i; { return(i->bell_duration); } void set_XKeyboardState_bell_duration(i, j) XKeyboardState* i; int j; { i->bell_duration = j; } int XKeyboardState_bell_pitch(i) XKeyboardState* i; { return(i->bell_pitch); } void set_XKeyboardState_bell_pitch(i, j) XKeyboardState* i; int j; { i->bell_pitch = j; } int XKeyboardState_bell_percent(i) XKeyboardState* i; { return(i->bell_percent); } void set_XKeyboardState_bell_percent(i, j) XKeyboardState* i; int j; { i->bell_percent = j; } int XKeyboardState_key_click_percent(i) XKeyboardState* i; { return(i->key_click_percent); } void set_XKeyboardState_key_click_percent(i, j) XKeyboardState* i; int j; { i->key_click_percent = j; } /********* XTimeCoord functions *****/ long make_XTimeCoord (){ return ((long) calloc(1, sizeof(XTimeCoord))); } int XTimeCoord_y(i) XTimeCoord* i; { return(i->y); } void set_XTimeCoord_y(i, j) XTimeCoord* i; int j; { i->y = j; } int XTimeCoord_x(i) XTimeCoord* i; { return(i->x); } void set_XTimeCoord_x(i, j) XTimeCoord* i; int j; { i->x = j; } int XTimeCoord_time(i) XTimeCoord* i; { return(i->time); } void set_XTimeCoord_time(i, j) XTimeCoord* i; int j; { i->time = j; } /********* XModifierKeymap functions *****/ long make_XModifierKeymap (){ return ((long) calloc(1, sizeof(XModifierKeymap))); } long XModifierKeymap_modifiermap(i) XModifierKeymap* i; { return((long) i->modifiermap); } void set_XModifierKeymap_modifiermap(i, j) XModifierKeymap* i; long j; { i->modifiermap = (KeyCode *) j; } int XModifierKeymap_max_keypermod(i) XModifierKeymap* i; { return(i->max_keypermod); } void set_XModifierKeymap_max_keypermod(i, j) XModifierKeymap* i; int j; { i->max_keypermod = j; } gcl-2.6.14/xgcl-2/sys-proclaim.lisp0000644000175000017500000003105214360276512015403 0ustar cammcamm (COMMON-LISP::IN-PACKAGE "COMMON-LISP-USER") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-UNSET XLIB::WINDOW-GET-GEOMETRY XLIB::WINDOW-SET-INVERT XLIB::WINDOW-FONT-INFO XLIB::GET-ST-POINT XLIB::EDITMENU-YANK XLIB::WINDOW-INIT-MOUSE-POLL XLIB::WINDOW-SET-XOR XLIB::WINDOW-TOP-NEG-Y XLIB::WINDOW-LEFT XLIB::WINDOW-QUERY-POINTER XLIB::TEXTMENU-DRAW XLIB::EDITMENU-CARAT XLIB::EDITMENU-DRAW XLIB::WINDOW-STD-LINE-ATTR XLIB::WINDOW-UNMAP XLIB::WINDOW-QUERY-POINTER-B XLIB::WINDOW-BACKGROUND XLIB::EDITMENU-DELETE XLIB::WINDOW-MOVE XLIB::DOWINDOWCOM XLIB::WINDOW-SYNC XLIB::PICMENU-DRAW XLIB::WINDOW-MAP XLIB::WINDOW-RESET-COLOR XLIB::EDITMENU-KILL XLIB::BARMENU-DRAW XLIB::WINDOW-GET-GEOMETRY-B XLIB::MENU-CLEAR XLIB::WINDOW-RESET XLIB::WINDOW-WFUNCTION XLIB::MENU-DRAW XLIB::WINDOW-FOREGROUND XLIB::WINDOW-CLEAR XLIB::EDITMENU-BACKSPACE XLIB::WINDOW-DRAW-BORDER XLIB::LISP-STRING XLIB::WINDOW-SET-ERASE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T) XLIB::OPEN-WINDOW)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-GET-ELLIPSE XLIB::EDITMENU-SELECT XLIB::WINDOW-SET-XCOLOR XLIB::TEXTMENU-SELECT XLIB::PICMENU-SELECT XLIB::MAKECONT XLIB::WINDOW-GET-CIRCLE XLIB::MENU XLIB::WINDOW-GET-REGION XLIB::TEXTMENU-SET-TEXT XLIB::MENU-SELECT XLIB::BARMENU-SELECT XLIB::PICMENU-CREATE-FROM-SPEC XLIB::PRINTINDEX XLIB::EDITMENU-EDIT XLIB::MENU-CREATE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::BARMENU-UPDATE-VALUE XLIB::WINDOW-FONT-STRING-WIDTH XLIB::MENU-FIND-ITEM-WIDTH XLIB::WINDOW-STRING-WIDTH XLIB::PICMENU-BOX-ITEM XLIB::WINDOW-SET-FOREGROUND XLIB::WINDOW-INVERTAREA XLIB::PICMENU-UNBOX-ITEM XLIB::PICMENU-DRAW-NAMED-BUTTON XLIB::WINDOW-SET-CURSOR XLIB::WINDOW-SET-LINE-WIDTH XLIB::PICMENU-DELETE-NAMED-BUTTON XLIB::EDITMENU-ERASE XLIB::PICMENU-DRAW-BUTTON XLIB::WINDOW-SET-BACKGROUND)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*) XLIB::XINIT XLIB::WINDOW-SCREEN-HEIGHT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T)) XLIB::WINDOW-CIRCLE-RADIUS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-XOR-BOX-XY XLIB::WINDOW-DRAW-BOX-CORNERS XLIB::WINDOW-DRAW-LINE-XY XLIB::WINDOW-DRAW-ARROW2-XY XLIB::WINDOW-DRAW-ARROW-XY XLIB::WINDOW-DRAW-ELLIPSE-XY XLIB::WINDOW-ERASE-BOX-XY XLIB::WINDOW-DRAW-BOX-XY XLIB::WINDOW-DRAW-ARROWHEAD-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-COPY-AREA-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-PRETTYPRINTAT XLIB::MENU-UNBOX-ITEM XLIB::WINDOW-PRINTAT XLIB::WINDOW-DRAW-CROSSHAIRS-XY XLIB::WINDOW-MOVETO-XY XLIB::WINDOW-INVERT-AREA XLIB::WINDOW-DRAW-DOT-XY XLIB::WINDOW-DRAW-CARAT XLIB::WINDOW-ERASE-AREA XLIB::MENU-BOX-ITEM XLIB::WINDOW-DRAW-CROSS-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-DRAW-CIRCLE-XY XLIB::WINDOW-PRINT-LINE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-PRETTYPRINTAT-XY XLIB::WINDOW-DRAW-CIRCLE-PT XLIB::EDITMENU-DISPLAY XLIB::WINDOW-PRINTAT-XY XLIB::WINDOW-PROCESS-CHAR-EVENT XLIB::MENU-DISPLAY-ITEM)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-ADJ-BOX-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-DRAW-ARC-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-DRAW-ELLIPSE-PT XLIB::WINDOW-ERASE-AREA-XY XLIB::WINDOW-INVERT-AREA-XY XLIB::WINDOW-DRAW-VECTOR-PT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-DRAW-LINE XLIB::WINDOW-DRAW-BOX XLIB::WINDOW-DRAW-CIRCLE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-DRAW-RCBOX-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-DRAW-LATEX-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-SET-LINE-ATTR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) XLIB::WINDOW-DRAW-BOX-LINE-XY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) XLIB::WINDOW-POSITIVE-Y XLIB::WINDOW-STRING-EXTENTS XLIB::MENU-CHOOSE XLIB::WINDOW-SET-FONT XLIB::PUSHFONT XLIB::WINDOW-STRING-HEIGHT XLIB::WORDLIST< XLIB::EDITMENU-LINE-Y XLIB::MENU-ITEM-Y XLIB::MENU-FIND-ITEM-HEIGHT XLIB::XFERCHARS XLIB::WINDOW-CENTEROFFSET XLIB::MENU-FIND-ITEM-Y XLIB::EDITMENU-CHAR XLIB::MENU-ITEM-VALUE XLIB::MENU-FIND-ITEM)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-FREE-COLOR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) XLIB::SEARCHFORALPHA XLIB::SAFE-CHAR XLIB::WINDOW-XINIT XLIB::WINDOW-MENU XLIB::WINDOW-INIT-KEYMAP XLIB::PARSE-INT XLIB::WINDOW-DESTROY-SELECTED-WINDOW XLIB::WINDOW-GET-MOUSE-POSITION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::FIXNUM) XLIB::FLUSHLINE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) XLIB::PICMENU-BUTTON-CONTAINSXY? XLIB::MENU-MOVETO-XY XLIB::WINDOW-GET-BOX-SIZE XLIB::PRINTINDEXN XLIB::WINDOW-GET-LINE-POSITION XLIB::PICMENU-SET-NAMED-BUTTON-COLOR XLIB::EDITMENU-SETXY XLIB::MENU-SELECT-B XLIB::MENU-REPOSITION-LINE XLIB::WINDOW-GET-VECTOR-END)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-CREATE XLIB::WINDOW-TRACK-MOUSE XLIB::PICMENU-ITEM-POSITION XLIB::WINDOW-GET-CHARS XLIB::TEXTMENU-CREATE XLIB::EDITMENU-CREATE XLIB::TOHTML XLIB::WINDOW-SET-COLOR XLIB::MENU-ITEM-POSITION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-INPUT-STRING XLIB::PICMENU-CREATE-SPEC XLIB::WINDOW-SET-COLOR-RGB XLIB::WINDOW-PRINT-LINES XLIB::PICMENU-CREATE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-GET-ICON-POSITION XLIB::BARMENU-CREATE XLIB::WINDOW-GET-LATEX-POSITION XLIB::WINDOW-GET-BOX-POSITION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-EDIT XLIB::WINDOW-TRACK-MOUSE-IN-REGION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) XLIB::WINDOW-ADJUST-BOX-SIDE XLIB::EDITMENU-EDIT-FN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) XLIB::WINDOW-GET-BOX-LINE-POSITION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) XLIB::WINDOW-DESTROY XLIB::EDITMENU-CALCULATE-SIZE XLIB::STRINGIFY XLIB::DOLINE XLIB::PUSHENV XLIB::WINDOW-POLL-MOUSE XLIB::WINDOW-FONT XLIB::WINDOW-SIZE XLIB::EDITMENU-END XLIB::WINDOW-PAINT XLIB::WINDOW-GEOMETRY XLIB::MENU-DESTROY XLIB::WINDOW-LABEL XLIB::PICMENU-CALCULATE-SIZE XLIB::POPENV XLIB::WINDOW-PARENT XLIB::WINDOW-WAIT-UNMAP XLIB::EDITMENU-INIT XLIB::WINDOW-GET-POINT XLIB::MENU-SELECT! XLIB::MENU-CALCULATE-SIZE XLIB::BARMENU-INIT XLIB::DOCOMMAND XLIB::MENU-INIT XLIB::WINDOW-OPEN XLIB::EDITMENU-META-B XLIB::WINDOW-GET-RAW-CHAR XLIB::WINDOW-DRAWABLE-HEIGHT XLIB::MENU-REPOSITION XLIB::WINDOW-YPOSITION XLIB::EDITMENU-ALPHANUMBERICP XLIB::EDITMENU-NEXT XLIB::MENU-SIZE XLIB::EDITMENU-PREVIOUS XLIB::EDITMENU-FORWARD XLIB::EDITMENU-BEGINNING XLIB::PICMENU-DESTROY XLIB::WINDOW-RESET-GEOMETRY XLIB::WINDOW-GCONTEXT XLIB::EDITMENU-BACKWARD XLIB::TERMLINE XLIB::WINDOW-DRAWABLE-WIDTH XLIB::WINDOW-GET-CROSSHAIRS XLIB::BARMENU-CALCULATE-SIZE XLIB::WINDOW-CHAR-DECODE XLIB::DOTABULAR XLIB::PICMENU-INIT XLIB::WINDOW-WAIT-EXPOSURE XLIB::PARSE-WORD XLIB::TEXTMENU-INIT XLIB::SEARCHFOR XLIB::MENU-OFFSET XLIB::MENU-ADJUST-OFFSET XLIB::WINDOW-SET-COPY XLIB::TEXTMENU-CALCULATE-SIZE XLIB::WINDOW-GET-CROSS XLIB::EDITMENU-META-F XLIB::WINDOW-GET-CLICK XLIB::EDITMENU-CURRENT-CHAR XLIB::DOHTML XLIB::WINDOW-CLOSE XLIB::EDITMENU-RETURN XLIB::WINDOW-CODE-CHAR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) XLIB::WINDOW-FORCE-OUTPUT)) gcl-2.6.14/xgcl-2/gcl_editorstrans.lsp0000644000175000017500000005740214360276512016165 0ustar cammcamm; 07 Jan 2010 16:43:40 EST ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, see . (DEFUN EDIT-THERMOM (NUM W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (PROG (NMIN NDEL NDIV RANGE PTEN DRANGE PAIR NEWW (RES NUM) OFF) (WHEN (NOT SIZEX) (SETQ SIZEX 150) (SETQ SIZEY 250)) (WHEN (NOT OFFSETX) (SETQ OFF (LET ((GLVAR168 (LIST SIZEX SIZEY))) (LIST (TRUNCATE (- (FIFTH W) (CAR GLVAR168)) 2) (TRUNCATE (- (CADDDR W) (CADR GLVAR168)) 2)))) (SETQ OFFSETX (CAR OFF)) (SETQ OFFSETY (CADR OFF))) (SETQ NEWW (WINDOW-CREATE SIZEX SIZEY NIL (CADR W) OFFSETX OFFSETY)) (WINDOW-DRAW-BUTTON NEWW "Typein" 80 20 50 25) (WINDOW-DRAW-BUTTON NEWW "Adjust" 80 70 50 25) (WINDOW-DRAW-BUTTON NEWW "Done" 80 120 50 25) RN (SETQ RANGE (* 2 (ABS RES))) (IF (ZEROP RANGE) (SETQ RANGE 50)) (IF (AND (< RANGE 8) (INTEGERP NUM)) (SETQ RANGE 10)) (SETQ PTEN (EXPT 10 (TRUNCATE (LOG RANGE 10)))) (SETQ DRANGE (/ (* 10 RANGE) PTEN)) (SETQ PAIR (CAR (SOME #'(LAMBDA (X) (> (CAR X) DRANGE)) '((14 2) (20 4) (40 5) (70 10) (101 20))))) (SETQ NDEL (* 1/10 (* (CADR PAIR) PTEN))) (SETQ NDIV (CEILING (/ RANGE NDEL))) (SETQ NMIN (IF (>= RES 0) 0 (- (* NDEL NDIV)))) (WINDOW-DRAW-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10 (+ -20 SIZEY)) LP (CASE (BUTTON-SELECT NEWW '((DONE (84 124) (42 17)) (ADJUST (84 74) (42 17)) (TYPEIN (84 24) (42 17)))) (DONE (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR NEWW)) (XFLUSH *WINDOW-DISPLAY*) (SETF (CADR NEWW) NIL) (XFREEGC *WINDOW-DISPLAY* (CADDR NEWW)) (SETF (CADDR NEWW) NIL) (RETURN RES)) (ADJUST (SETQ RES (WINDOW-ADJUST-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10 (+ -20 SIZEY))) (GO LP)) (TYPEIN (PRINC "Enter new value: ") (SETQ RES (READ)) (IF (AND (>= RES NMIN) (<= RES (+ NMIN (* NDEL NDIV)))) (PROGN (WINDOW-SET-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10 (+ -20 SIZEY)) (GO LP)) (GO RN)))))) (SETF (GET 'EDIT-THERMOM 'GLARGUMENTS) '((NUM NUMBER) (W WINDOW) (&OPTIONAL INTEGER) (OFFSETX INTEGER) (OFFSETY INTEGER) (SIZEX INTEGER))) (SETF (GET 'EDIT-THERMOM 'GLFNRESULTTYPE) 'NUMBER) (DEFUN WINDOW-DRAW-BUTTON (W S OFFSETX OFFSETY SIZEX SIZEY) (LET (SW) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) (WINDOW-DRAW-RCBOX-XY W OFFSETX OFFSETY SIZEX SIZEY 8) (SETQ SW (LET ((SSTR (STRINGIFY S))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ OFFSETX (* 1/2 (- SIZEX SW))) (+ -8 (- (CADDDR W) OFFSETY)) (GET-C-STRING SSTR) (LENGTH SSTR))) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN WINDOW-CENTER-PRINT (W S OFFSETX OFFSETY SIZEX SIZEY) (LET (SW) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) (SETQ SW (LET ((SSTR (STRINGIFY S))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (LET ((SSTR (STRINGIFY S))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ OFFSETX (* 1/2 (- SIZEX SW))) (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) (GET-C-STRING SSTR) (LENGTH SSTR))) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN WINDOW-DRAW-THERMOMETER (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) (LET (HDEL MARKY) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) 66 SIZEY 0) (EDITORS-PRINT-IN-BOX VAL W OFFSETX OFFSETY 40 20) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX (+ -48 (- (CADDDR W) OFFSETY)) 24 24 8448 17664) (LET ((QQWHEIGHT (CADDDR W))) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) (+ -44 (- QQWHEIGHT OFFSETY)) (+ 4 OFFSETX) (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY))))) (LET ((QQWHEIGHT (CADDDR W))) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 20 OFFSETX) (+ -44 (- QQWHEIGHT OFFSETY)) (+ 20 OFFSETX) (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY))))) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) (- (CADDDR W) (+ OFFSETY SIZEY)) 16 16 0 11520) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 8 OFFSETX) (+ -40 (- (CADDDR W) OFFSETY)) 8 8 0 23040) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0) (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) (LET ((QQWHEIGHT (CADDDR W))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX) (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX) (- QQWHEIGHT (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (DOTIMES (I (1+ NDIV)) (SETQ MARKY (+ (+ 48 OFFSETY) (* I HDEL))) (LET ((QQWHEIGHT (CADDDR W))) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 24 OFFSETX) (- QQWHEIGHT MARKY) (+ 34 OFFSETX) (- QQWHEIGHT MARKY)) NIL) (LET ((SSTR (STRINGIFY (+ NMIN (* I NDEL))))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 36 OFFSETX) (+ 6 (- (CADDDR W) MARKY)) (GET-C-STRING SSTR) (LENGTH SSTR)))) (XFLUSH *WINDOW-DISPLAY*))) (DEFUN WINDOW-SET-THERMOMETER (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) (LET (HDEL) (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) (LET ((GLVAR204 (+ -56 SIZEY))) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX) (- (CADDDR W) (1- (+ (+ 48 OFFSETY) GLVAR204))) 10 GLVAR204 0)) (LET ((QQWHEIGHT (CADDDR W))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX) (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX) (- QQWHEIGHT (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (EDITORS-UPDATE-IN-BOX VAL W OFFSETX OFFSETY 40 20))) (DEFUN WINDOW-ADJUST-THERMOMETER (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) (LET (HDEL LASTY XMIN XMAX YMIN YMAX INSIDE NEWVAL) (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) (SETQ LASTY (TRUNCATE (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) (SETQ XMIN (+ 4 OFFSETX)) (SETQ XMAX (+ 20 OFFSETX)) (SETQ YMIN (+ 48 OFFSETY)) (SETQ YMAX (+ -8 (+ OFFSETY SIZEY))) (WINDOW-TRACK-MOUSE W #'(LAMBDA (X Y CODE) (SETQ INSIDE (AND (>= X XMIN) (<= X XMAX) (>= Y YMIN) (<= Y YMAX))) (WHEN (AND INSIDE (/= Y LASTY)) (IF (> Y LASTY) (LET ((QQWHEIGHT (CADDDR W))) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX) (- QQWHEIGHT LASTY) (+ 12 OFFSETX) (- QQWHEIGHT Y)) (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) (LET ((GLVAR214 (- LASTY Y))) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX) (- (CADDDR W) (1- (+ (1+ Y) GLVAR214))) 10 GLVAR214 0))) (SETQ LASTY Y) (SETQ NEWVAL (+ (* (/ (+ -48 (- LASTY OFFSETY)) (FLOAT HDEL)) NDEL) NMIN)) (IF (INTEGERP VAL) (SETQ NEWVAL (TRUNCATE NEWVAL))) (EDITORS-UPDATE-IN-BOX NEWVAL W OFFSETX OFFSETY 40 20)) (NOT (ZEROP CODE)))) (IF INSIDE NEWVAL VAL))) (SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLARGUMENTS) '((W WINDOW) (NMIN INTEGER) (NDEL INTEGER) (NDIV INTEGER) (VAL NUMBER) (OFFSETX INTEGER) (OFFSETY INTEGER) (SIZEY INTEGER))) (SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLFNRESULTTYPE) 'NUMBER) (DEFUN BUTTON-SELECT (MW BUTTONS) (LET (CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO) (SETQ XZERO 0) (SETQ YZERO 0) (WINDOW-TRACK-MOUSE MW #'(LAMBDA (X Y CODE) (DECF X XZERO) (DECF Y YZERO) (AND (>= X 0) (>= Y 0)) (IF CURRENT-BUTTON (WHEN (NOT (BUTTON-CONTAINSXY? CURRENT-BUTTON X Y)) (BUTTON-INVERT MW CURRENT-BUTTON) (SETQ CURRENT-BUTTON NIL))) (WHEN (NOT CURRENT-BUTTON) (SETQ ITEMS BUTTONS) (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS))) (WHEN (BUTTON-CONTAINSXY? ITEM X Y) (SETQ CURRENT-BUTTON ITEM) (BUTTON-INVERT MW CURRENT-BUTTON)))) (WHEN (PLUSP CODE) (IF CURRENT-BUTTON (BUTTON-INVERT MW CURRENT-BUTTON)) (SETQ VAL (OR CURRENT-BUTTON *PICMENU-NO-SELECTION*)))) T) (IF (NOT (EQUAL VAL *PICMENU-NO-SELECTION*)) (CAR VAL)))) (SETF (GET 'BUTTON-SELECT 'GLARGUMENTS) '((MW WINDOW) (BUTTONS (LISTOF PICMENU-BUTTON)))) (SETF (GET 'BUTTON-SELECT 'GLFNRESULTTYPE) 'SYMBOL) (DEFUN BUTTON-INVERT (W BUTTON) (WINDOW-INVERT-AREA W (CADR BUTTON) (CADDR BUTTON))) (DEFUN WINDOW-UNDRAW-BOX (W OFFSET SIZE &OPTIONAL LW) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 3) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*)))) (WINDOW-DRAW-BOX W OFFSET SIZE LW) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) (DEFUN BUTTON-CONTAINSXY? (B X Y) (LET ((XSIZE 6) (YSIZE 6)) (WHEN (CADDR B) (SETQ XSIZE (CAADDR B)) (SETQ YSIZE (CADR (CADDR B)))) (AND (>= X (CAADR B)) (<= X (+ (CAADR B) XSIZE)) (>= Y (CADADR B)) (<= Y (+ (CADADR B) YSIZE))))) (SETF (GET 'BUTTON-CONTAINSXY? 'GLARGUMENTS) '((B PICMENU-BUTTON) (X INTEGER) (Y INTEGER))) (SETF (GET 'BUTTON-CONTAINSXY? 'GLFNRESULTTYPE) 'BOOLEAN) (SETF (GET 'MENU-ITEM 'GLSTRUCTURE) '((Z ANYTHING) PROP ((VALUE ((IF Z IS ATOMIC Z (CDR Z))))) MSG ((PRINT-SIZE MENU-ITEM-PRINT-SIZE) (DRAW MENU-ITEM-DRAW)))) (DEFUN MENU-ITEM-PRINT-SIZE (ITEM W) (LET (SIZ) (IF (ATOM ITEM) (LIST (LET ((SSTR (STRINGIFY ITEM))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))) 11) (IF (STRINGP (CAR ITEM)) (LIST (LET ((SSTR (STRINGIFY (CAR ITEM)))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))) 11) (IF (AND (SYMBOLP (CAR ITEM)) (SETQ SIZ (GET (CAR ITEM) 'DISPLAY-SIZE))) SIZ (COPY-LIST '(50 11))))))) (SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLARGUMENTS) '((ITEM MENU-ITEM) (W WINDOW))) (SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLFNRESULTTYPE) 'VECTOR) (DEFUN MENU-ITEM-DRAW (ITEM W OFFSETX OFFSETY SIZEX SIZEY) (IF (ATOM ITEM) (WINDOW-CENTER-PRINT W ITEM OFFSETX OFFSETY SIZEX SIZEY) (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) (FUNCALL (CAR ITEM) W OFFSETX OFFSETY) (WINDOW-CENTER-PRINT W (CAR ITEM) OFFSETX OFFSETY SIZEX SIZEY)))) (DEFUN PICK-ONE-SIZE (ITEMS W) (LET (WID) (DOLIST (ITEM ITEMS) (SETQ WID (IF WID (MAX WID (CAR (MENU-ITEM-PRINT-SIZE ITEM W))) (CAR (MENU-ITEM-PRINT-SIZE ITEM W))))) (LIST WID 11))) (SETF (GET 'PICK-ONE-SIZE 'GLARGUMENTS) '((ITEMS (LISTOF MENU-ITEM)) (W WINDOW))) (SETF (GET 'PICK-ONE-SIZE 'GLFNRESULTTYPE) 'VECTOR) (DEFUN DRAW-PICK-ONE (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (LET (ITM) (IF (SETQ ITM (SOME #'(LAMBDA (GLVAR216) (IF (EQUAL (IF (ATOM GLVAR216) GLVAR216 (CDR GLVAR216)) VAL) GLVAR216)) ITEMS)) (MENU-ITEM-DRAW ITM W OFFSETX OFFSETY SIZEX SIZEY)))) (DEFUN EDIT-PICK-ONE (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (LET (NEWVAL) (IF (<= (LENGTH ITEMS) 3) (IF (EQUAL VAL (LET ((SELF (FIRST ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (SETQ NEWVAL (LET ((SELF (SECOND ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (IF (EQUAL VAL (LET ((SELF (SECOND ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (SETQ NEWVAL (IF (THIRD ITEMS) (LET ((SELF (THIRD ITEMS))) (IF (ATOM SELF) SELF (CDR SELF))) (LET ((SELF (FIRST ITEMS))) (IF (ATOM SELF) SELF (CDR SELF))))) (SETQ NEWVAL (LET ((SELF (FIRST ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))))) (SETQ NEWVAL (MENU ITEMS))) (DRAW-PICK-ONE NEWVAL W ITEMS OFFSETX OFFSETY SIZEX SIZEY) NEWVAL)) (DEFUN DRAW-BLACK-WHITE (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (LET (ITM) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) (IF (SETQ ITM (SOME #'(LAMBDA (GLVAR218) (IF (EQUAL (IF (ATOM GLVAR218) GLVAR218 (CDR GLVAR218)) VAL) GLVAR218)) ITEMS)) (WHEN (EQL (IF (CONSP ITM) (CAR ITM) ITM) 1) (LET ((GC (CADDR W))) (SETQ *WINDOW-SAVE-FUNCTION* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) (XGCVALUES-FUNCTION *GC-VALUES*))) (XSETFUNCTION *WINDOW-DISPLAY* GC 6) (SETQ *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) (XGCVALUES-FOREGROUND *GC-VALUES*))) (XSETFOREGROUND *WINDOW-DISPLAY* GC (LOGXOR *WINDOW-SAVE-FOREGROUND* (PROGN (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) (XGCVALUES-BACKGROUND *GC-VALUES*))))) (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY) (LET ((GC (CADDR W))) (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))))) (DEFUN EDIT-BLACK-WHITE (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (LET (NEWVAL) (IF (EQUAL VAL (LET ((SELF (FIRST ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (SETQ NEWVAL (LET ((SELF (SECOND ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (IF (EQUAL VAL (LET ((SELF (SECOND ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))) (SETQ NEWVAL (LET ((SELF (FIRST ITEMS))) (IF (ATOM SELF) SELF (CDR SELF)))))) (DRAW-BLACK-WHITE ITEMS NEWVAL W OFFSETX OFFSETY SIZEX SIZEY) NEWVAL)) (DEFUN DRAW-INTEGER (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (EDITORS-ANYTHING-PRINT VAL W OFFSETX OFFSETY SIZEX SIZEY)) (DEFUN DRAW-REAL (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) (LET (STR NC LNG FMT) (IF (NULL SIZEX) (SETQ SIZEX 50)) (SETQ NC (MAX 1 (TRUNCATE SIZEX 7))) (SETQ STR (PRINC-TO-STRING VAL)) (SETQ LNG (LENGTH STR)) (IF (> LNG NC) (IF (OR (FIND #\. STR :START NC) (FIND #\E STR) (FIND #\L STR)) (IF (>= NC 8) (PROGN (SETQ FMT (CADR (OR (ASSOC NC '((8 "~8,2E") (9 "~9,2E") (10 "~10,2E") (11 "~11,2E") (12 "~12,2E") (13 "~13,2E") (14 "~14,2E"))) '(15 "~15,2E")))) (SETQ STR (FORMAT NIL FMT VAL))) (SETQ STR "*******")) (SETQ STR (SUBSEQ STR 0 NC)))) (EDITORS-ANYTHING-PRINT W STR OFFSETX OFFSETY SIZEX SIZEY))) (DEFUN EDITORS-ANYTHING-PRINT (OBJ W OFFSETX OFFSETY SIZEX SIZEY) (LET (SWIDTH SMAX DX DY) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) (SETQ SWIDTH (LET ((SSTR (STRINGIFY (STRINGIFY OBJ)))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (SETQ SMAX (MIN SWIDTH SIZEX)) (SETQ DX (* 1/2 (- SIZEX SMAX))) (SETQ DY (MAX 0 (+ -5 (* 1/2 SIZEY)))) (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SMAX)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ OFFSETX DX) (- (CADDDR W) (+ OFFSETY DY)) (GET-C-STRING SSTR) (LENGTH SSTR))))) (DEFUN EDITORS-PRINT-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY) (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) (GET-C-STRING SSTR) (LENGTH SSTR))) (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY)) (DEFUN EDITORS-UPDATE-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY) (LET ((GLVAR229 (+ -6 SIZEY))) (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 3 OFFSETX) (- (CADDDR W) (1- (+ (+ 3 OFFSETY) GLVAR229))) (+ -6 SIZEX) GLVAR229 0)) (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) (GET-C-STRING SSTR) (LENGTH SSTR)))) (DEFUN EDITORS-STRING-LIMIT (S W MAX) (LET ((STR (STRINGIFY S)) LNG NC) (SETQ LNG (LET ((SSTR (STRINGIFY STR))) (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) (IF (> LNG MAX) (PROGN (SETQ NC (/ (* (LENGTH STR) MAX) LNG)) (SUBSEQ STR 0 NC)) STR))) (SETF (GET 'EDITORS-STRING-LIMIT 'GLARGUMENTS) '((S STRING) (W WINDOW) (MAX INTEGER))) (SETF (GET 'EDITORS-STRING-LIMIT 'GLFNRESULTTYPE) 'STRING) (DEFVAR *EDIT-COLOR-MENU-SET* NIL) (DEFVAR *EDIT-COLOR-RMENU* NIL) (DEFVAR *EDIT-COLOR-OLD-COLOR* NIL) (DEFVAR *EDIT-COLOR-MENU-SET*) (SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVAR) T) (SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET) (DEFVAR *EDIT-COLOR-RMENU*) (SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVAR) T) (SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVARTYPE) 'BARMENU) (DEFUN EDIT-COLOR-INIT (W) (LET (RM GM BM RGB) (SETQ RGB (COPY-LIST '(0 0 0))) (GLCC 'EDIT-COLOR-RED) (GLCC 'EDIT-COLOR-GREEN) (GLCC 'EDIT-COLOR-BLUE) (SETQ *EDIT-COLOR-MENU-SET* (MENU-SET-CREATE W NIL)) (SETQ RM (BARMENU-CREATE 256 200 10 "" NIL #'EDIT-COLOR-RED (LIST RGB) W 120 40 NIL T (COPY-LIST '(65535 0 0)))) (SETQ *EDIT-COLOR-RMENU* RM) (SETQ GM (BARMENU-CREATE 256 50 10 "" NIL #'EDIT-COLOR-GREEN (LIST RGB) W 170 40 NIL T (COPY-LIST '(0 65535 0)))) (SETQ BM (BARMENU-CREATE 256 250 10 "" NIL #'EDIT-COLOR-BLUE (LIST RGB) W 220 40 NIL T (COPY-LIST '(0 0 65535)))) (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'RED NIL RM "Red" '(120 40)) (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'GREEN NIL GM "Green" '(170 40)) (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'BLUE NIL BM "Blue" '(220 40)) (MENU-SET-ADD-MENU *EDIT-COLOR-MENU-SET* 'DONE NIL "" '(("Done" . DONE)) '(30 150)) (EDIT-COLOR-RED 200 RGB) (EDIT-COLOR-GREEN 50 RGB) (EDIT-COLOR-BLUE 250 RGB))) (DEFUN EDIT-COLOR-RED (VAL COLOR) (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 113 (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) (SETF (CAR COLOR) (MAX 0 (1- (* 256 VAL)))) (EDIT-DISPLAY-COLOR W COLOR))) (DEFUN EDIT-COLOR-GREEN (VAL COLOR) (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 163 (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) (SETF (CADR COLOR) (MAX 0 (1- (* 256 VAL)))) (EDIT-DISPLAY-COLOR W COLOR))) (DEFUN EDIT-COLOR-BLUE (VAL COLOR) (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 213 (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) (SETF (CADDR COLOR) (MAX 0 (1- (* 256 VAL)))) (EDIT-DISPLAY-COLOR W COLOR))) (DEFUN EDIT-DISPLAY-COLOR (W COLOR) (WINDOW-SET-COLOR W COLOR) (WINDOW-DRAW-LINE-XY W 50 40 50 100 60) (WINDOW-RESET-COLOR W) (IF *EDIT-COLOR-OLD-COLOR* (WINDOW-FREE-COLOR W *EDIT-COLOR-OLD-COLOR*)) (SETQ *EDIT-COLOR-OLD-COLOR* *WINDOW-XCOLOR*)) (DEFUN EDIT-COLOR (W) (LET (DONE COLOR SEL) (IF (OR (NULL *EDIT-COLOR-MENU-SET*) (NOT (EQ W (CADR (CADDR (CAADDR *EDIT-COLOR-MENU-SET*)))))) (EDIT-COLOR-INIT W)) (SETQ COLOR (FIRST (NTH 16 *EDIT-COLOR-RMENU*))) (MENU-SET-DRAW *EDIT-COLOR-MENU-SET*) (EDIT-COLOR-RED (TRUNCATE (1+ (CAR COLOR)) 256) COLOR) (EDIT-COLOR-GREEN (TRUNCATE (1+ (CADR COLOR)) 256) COLOR) (EDIT-COLOR-BLUE (TRUNCATE (1+ (CADDR COLOR)) 256) COLOR) (WHILE (NOT DONE) (SETQ SEL (MENU-SET-SELECT *EDIT-COLOR-MENU-SET*)) (SETQ DONE (AND SEL (EQ (FIRST SEL) 'DONE)))) COLOR)) (SETF (GET 'EDIT-COLOR 'GLARGUMENTS) '((W WINDOW))) (SETF (GET 'EDIT-COLOR 'GLFNRESULTTYPE) 'RGB) (DEFUN COLOR-DOT (W X Y COLOR) (LET (RGB) (SETQ RGB (CDR (ASSOC COLOR '((RED 65535 0 0) (YELLOW 65535 57600 0) (GREEN 0 50175 12287) (BLUE 0 0 65535))))) (OR RGB (SETQ RGB '(30000 30000 30000))) (WINDOW-SET-COLOR W RGB) (WINDOW-DRAW-DOT-XY W X Y) (WINDOW-RESET-COLOR W))) (DEFUN COMPILE-EDITORS () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt") (CF EDITORSTRANS)) (DEFUN COMPILE-EDITORSB () (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt")) gcl-2.6.14/xgcl-2/gnu.license0000644000175000017500000003031014360276512014221 0ustar cammcamm GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! gcl-2.6.14/xgcl-2/gcl_ice-cream.lsp0000644000175000017500000000316114360276512015262 0ustar cammcamm; ice-cream.lsp 14 Nov 1994 16:16:15 (SETF (GET 'ICE-CREAM 'DRAW-DESCR) '(DRAW-DESC ICE-CREAM ((DRAW-DOT (79 294) (4 4) NIL 0) (DRAW-CIRCLE (7 222) (148 148) NIL 0) (DRAW-ELLIPSE (7 274) (148 44) NIL 0) (DRAW-LINE (81 296) (0 -278) NIL 0) (DRAW-LINE (81 18) (74 278) NIL 0) (DRAW-LINE (81 18) (-74 278) NIL 0) (DRAW-ELLIPSE (0 269) (162 54) NIL 0) (DRAW-ARROW (154 391) (-27 -35) NIL 0) (DRAW-TEXT (140 395) (63 14) "Ice Cream" 0) (DRAW-ARROW (81 296) (-74 0) NIL 0) (DRAW-TEXT (47 299) (7 14) "r" 0) (DRAW-TEXT (86 186) (7 14) "h" 0) (DRAW-LINE (81 0) (81 296) NIL 0) (DRAW-LINE (81 0) (-81 296) NIL 0)) (0 0) (203 409))) (DEFUN DRAW-ICE-CREAM (W X Y) (WINDOW-DRAW-DOT-XY W (+ 81 X) (+ 296 Y)) (WINDOW-DRAW-CIRCLE-XY W (+ 81 X) (+ 296 Y) 74) (WINDOW-DRAW-ELLIPSE-XY W (+ 81 X) (+ 296 Y) 74 22) (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 296 Y) (+ 81 X) (+ 18 Y)) (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 18 Y) (+ 155 X) (+ 296 Y)) (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 18 Y) (+ 7 X) (+ 296 Y)) (WINDOW-DRAW-ELLIPSE-XY W (+ 81 X) (+ 296 Y) 81 27) (WINDOW-DRAW-ARROW-XY W (+ 154 X) (+ 391 Y) (+ 127 X) (+ 356 Y)) (WINDOW-PRINTAT-XY W "Ice Cream" (+ 140 X) (+ 395 Y)) (WINDOW-DRAW-ARROW-XY W (+ 81 X) (+ 296 Y) (+ 7 X) (+ 296 Y)) (WINDOW-PRINTAT-XY W "r" (+ 47 X) (+ 299 Y)) (WINDOW-PRINTAT-XY W "h" (+ 86 X) (+ 186 Y)) (WINDOW-DRAW-LINE-XY W (+ 81 X) Y (+ 162 X) (+ 296 Y)) (WINDOW-DRAW-LINE-XY W (+ 81 X) Y X (+ 296 Y)) (WINDOW-FORCE-OUTPUT W)) gcl-2.6.14/xgcl-2/package.lisp0000644000175000017500000000005314360276512014351 0ustar cammcamm(make-package :XLIB :use '(:lisp :system)) gcl-2.6.14/xgcl-2/dwdoc.pdf0000644000175000017500000031455714360276512013701 0ustar cammcamm%PDF-1.5 % 3 0 obj << /Length 2329 /Filter /FlateDecode >> stream xڕXK6Wm4W|sJx ك[3#X-5p{}XE'QEXϯGtBIk6iRq&ީaC2ؗ۝v6y#޿H=CߝnFM"oEfgP:{޷ݡms%>]{U>&)>o@"7kM,~.OE7f t}xA biIU62ȇL.T_QՀ%ۭI jWm+o㼓j6hfm0|AM06x|j@gNсWɾ=) 7,zh=_/.BlJ&(3I=X5yA" =Ѓ6xЃ;/uR4>tzHG[&m)Dž^|jX~qH@/7؇m4$lu;<0xpxCx_W{ZeӗA<[bҗuKrOqJdLܩ8&!w@؏˜xh;Z07iYkb5} x>G[9Y pڐ:r NR6"K!HJ~񖾿 )69/I ]YYLwmw!V|HוspoعCR@C|;-c-D/3ϊ$fw΢4=&Ku%>0IT[x0wrه~rIrt֩:- F)AW7UDlҮ}c;F`hn4@@Sp J}_ױg&^ani&+x8Hx$+0xnSXYf3,K:%1 +"r\Pޔ20v,< Z\ O{+sIr|ç?j:-QWR t2#ܰe}>>UD@ ^-[5 0ꢛYE:fh$za. &QɲݽCB͎QcHqQ6:I@A]pSPsXK"1FSv;PT5Űg C4ŌIrn0<[-\ bN w@Q!\FѾ2$Tʂ^V{: ڊ`UŶz5lS<)Cבϣe@y[ӤKBY9Nhp4^LCCG~t=׹NHo'pwCx+.R*WbX΄볹Ayn><6S]OXAz+ǩ#OTz'Xt6nG'x\@#ZGoS'8,Ǔ7+D0W54::@EJz'ŕZEƂq*\1jN,XpeG:(./bG !2NtgQ<\4Gejja5\&pŷ_9KiIwE(Vl:MYӇuRIsל gf)_9^_z _,j[Ѓ{dN25t~;n^aAak 0eT0bP0E7 @9^ k.%{z5lvbd~FP\H DDT`rnWsN]2V.ibdH5znBXTz{ endstream endobj 12 0 obj << /Length 1878 /Filter /FlateDecode >> stream xڕXK6 W̩j,;9-=)zcͬx`{2I~{olakm wHĜ ~/cmX U] {;RLT d˔+ƉJ$K* 10J<VhRtxHˢyͧ;"Nu@2 `^dc )>ϊ9CDӪ K5˸\3Z]J ;[ǯ-_Q~F_9_+$ T{ߜqG5#صh9Rx#dt0:Śm$aR\v"X2& O00ErMq,4y96*֬N1>)uRKI-?D'pȺH| V$p/3X\s OrJP_S,MPwED+\ KR(٪)-}jk6|Yȑ4N5I&F4vGm=I MDU'hH s+oA[i.ߒ¼}g8[^ G\PS4R썆< * _XxtE.pwo5>ޫ9 ֊C%'fJn!I1QɈgO2;zlδoq’Yunc1VoPAɘ6Ē ZrYXhȨqcwK}obu}ۮͳ<ηcg.CS  wJny #o>?ADA5fkِ|s^"Z< $`)֮"0?tNoU { HED w%:WZrpnZ?E N)pĮ}dN[`T ؽ`W ӵԜ]vrZPbFg(%Щ4=5;?GԨ}V ]OGQJŵz=N;LT'ܸONU3н5'$z|"ww藜} endstream endobj 16 0 obj << /Length 2872 /Filter /FlateDecode >> stream xڍZK \wX+R$%휒lզ-bceeɑ(2='  !ՓY|z9=TuV韻s7?Jr[j:%mZ~yq^shvΞwSKx=?#;4 ,ݍz'X6mj_/{ʟBeJi·^;KI]ۏH[IU:-y#YdU^b[LbU@^P\rVYU M!A;:878F,1]pM'$dJ]dRka Vj<}8'\n뇣U(ꬔ/R501^p*}}@(*XL`eQ`=tK7404Es VJe2D%ԱͲY+ 4_г6f ^ɸed 28,K:/3% =tB!v?Z }c|g֞"v4ᭈ1[4Vq_qsK#g.s̴Z\'P/@ {LiiQ;h%\޹I,7­"(L>v$ 4@-G ,"yΤ\C=T5}n8N=-^båaI9.Yhc=$<O; A  Z_mDyVM&)AKu(1d7L"֮I!(р c0 +JaK ,MԟS("6 1 JI+|d"xQ0MwҶ^Bq4=,ҷ |~z]i+N'řoK<2A\&c7+N;Ϩgi1ƕ80K✼*IdVgE3Ǵ{K7SxGM@X-3 \>ٽ>YM*A$XH32Qzw-˙Mo,nE Gl6`!c)va8s1l&z7v鍹wklzDUfyU0wGti0{ Tl*Ҙ~3#>ؘ RS][Un}_*݃P&IBU|1cUERPج&] m $XZQANKDc>h4 D]ǮeO58b}hlDn=ZzН䪩*K5o;,J<*emsl^9 ݬsC7!`@='Ăب+Qk_ֵk׷(aRnl8w$u|,nn[ Be8L"*wx .}?n IfjFEt 0gۍs/B^)D|\0/uPC?_; a4rw]Ć-ߧ8 ܠ'UNCJixޜDǰk"&oBfJ)#vn>%yVY\~jTL wW+_TGwAʎ{1R wUq5P[e8__~?(= endstream endobj 20 0 obj << /Length 2465 /Filter /FlateDecode >> stream xڥYKϯ0rX+$Μ6.ZRCS"G3Y$OL+·";R~0s;Ǔ(tΗ֍ys5'_LɌ;$.A.qN7Ke`RG}fk1v`zRy#(LR6lƨsy'v<ۧK bysԖAʓق+"><\?pz{ˡ/ɣ 0u3}K#VYO61mwz4IN1l{e_B3*xssqpĕ[6[׷FSީ;rdLLzޝIPpXE=//5+@15yU,`cA|$ ߨ SLf"@ M|!)J%f[_4i؏⊖(Pkg> stream xXK6ϯB (i,Y @䠖v0Dj<_*VQrg2ERz~U|E]2]_pӱܱA=N =M6=񢌪~hM_2o~P$g")]LiϚ#$ xoq*rdfkli0ke4yl-U@2z2Y"a)yacBz8#KnOWy7ȿ9z=/O,rWgX= arl1 eH(c}}(- f{jKL%F6DžϴN ٓSWoΆ?$Jfڶr ]bNXlvT]O;[ubRG>__٦;.N++zD qd΅TFRwjϛmn*m(\IpBI<Ӕ=SqG5kƁ= CMtQ_#e7>`~elRK'j^thY"r A&Kwh\Nm˅WeW?Ҩ߃`H\zI~ piw!ygǡ3|ϱGZFtQƇqV!ْ[A'"VK6}NgWav40_ɼzo:-‘}n YZoCe{={/)hӣ6}"NJFߕ#>cxC)DbL |wƻGOqFfN 6Hd{ӑrK9d lKBNp^@l2ElWAur]Soܧΰ^vW@D8C’XV=b$,Խ;ןgz걣y~a(x^[RTGe;>CUAHJGum:,LE4+xXioל9O끊^zQ:zl /UT^!ޤWA %jL, ~OvrWlpDmbevZn6)@SG%)`Ѳ84E`{Gi-5i{_23%y|D$* lu<(l[/pwnvIQe+ O];KI3XDřQQ^Y l2v["IpBt4g!|"JaԍHIQ.S[]v2\X f& 鑲WPI1~Mx΀eI_V4$\4+4}R;K#  )T63UB)KJR;|Gw‰}愩ϠKœK(隦G"BYhKGd|S!j]3s KQMNa+4fL4B?ѱξ^xn`6YJ&;rDz;eWS~-0*g3ʪ|Qt *J|Q.$GM__(,go{c# kNq $4)}^&=dA9*$Jv\i0%3Kdl;Un  AqH[:}a1׉8I1&ߖ},M5t~+[1_DhkH=g#^:3ꋢ@S'`c0RZB2 CЕd!Ӌs' uE )My`2yU E^LaKMpZ $>g(%3"7PA<5jl|Lv1酑M, 2'rXlh_N ӥDy(wrLjwRxJR~qu_u[ݙT1|}cW׶!%ҭpx~+uϹ3 WH4Tm^,Td6Tt[ZJsٕit ՞Nl`cze2 S۠<췚ywp|Qq&TWm,'U-i-ŵ7?`Y endstream endobj 26 0 obj << /Length 1652 /Filter /FlateDecode >> stream xڝXK6WT@ň)J{kڦH @EMZؒ!qwCw79y}һ7oߋl9 %0Բbci`lZo)N֩29>hƴc{0XuUTLU ĤTDdnjw_v=0srdb }\:Ovv 8w2iX if;lB3"T\eD(x(0VMc=j%VÍFnE-m]wL, Ђh==(IT )I {Mm=KqvUxMw4EyRytdE6?44y1U[#(~@޶}} L " WPӗ!qy+,z7P-Fyp ygDeCy] (9೒gq΃RG!p5wM_D6PquЍqC؊*7^0gJLMe%(tJl¯C}d#T*[F fs Șkn:*cFďР .`~:TZ(ߨH:_r4l`{U+`o@Ff.[;P~"r2FTG rUFWŴ\_eo`SWYPajgM|Rd]. Ӌnx{άYW;oJo"X]d 3>_ *5_ 0#pL3/hGCr+ )A2 2v`oD_z0IjdJ][P5t⣚ѪnĮ21,#SsP DsLgrh)bo\HLc GÒ,^Q]*39]7B *VB|}}9*EПt/2VAgBIsI'Z6q595G\eQ]-$vi>m{C BZk}YF:?(*o@D1d.X&8Ҁ"ȃq -Gq5U]O JM]1A 9!cx6A03~xR n0JMwa}ۤ7?߿Z8x endstream endobj 29 0 obj << /Length 1854 /Filter /FlateDecode >> stream xڕXr6W蔢L[L9* E( %_n4@2e{."XzntVn,ݦ"毠T670e,߆ dr؆I q͖-YpQ'G6ngk:W.?}pc  Gymb$#\QQ}@\KZj윰Pi„QeQf̪lkCO:h҆LrZ WO`~O@mp=;7 kiX𨹼jx:KkM&eo+/iU}ZFAoV̓Ş߾Fb  @X00؈ځӬ |b3e/{^ȝZ^F,KC3 }cgh}`O{$qZ?. Pa/㚹XV؟qfƴ\[ӊ[!M"~Z:W]2p<q$Jtr^oq; m1,P*sAʳ'8~^E0*3UC\ w[SfժWHɃ+" XŗHj[bjE $<^F)ܦW\= x^xo'Tj3qlZ8z󾸽;wW;nt)Q3#+Dp=c8ɤ?䓬GF&eR{ޏGodE,٭Gg y ߸e(!sho΅ȊQyҍŊ*9|'w +k@XŮ"׫-D@1k!$ư*aT[%flwdËfn9wsN3Uu2lTQY$P;?zeI endstream endobj 33 0 obj << /Length 1239 /Filter /FlateDecode >> stream xX˖6W1I[ckf"efalJ6G SRɀfhLuJUu%3f"Ie9<#Ef/HP=36/|LҔ(E浜,8ØbBG!]NfI/\jJ(Uj1&*Hv#cB$ͲYr~h'ۺۅ*wa4``By$S3gٵeÍlNfZ#Z@,7eT<3B9e-^s[=lď n_Xl:;Y \Eյ~r㢸d`6=N2]bA;F|>1ȏvB"|&hmu6Ee䛝a|YAb( >p*JY M'.JPߞXYY#zfPiNo :a,ڡqh$nI%AqO|N߷j. Wq'iFG&՝:1vހ K!XXt-wyx!6QmzئIt{>cپ e~5gQLF֔Wi m1)*-.&kց;>֠qZm_/cWu`[A޺#ipx)EVczZ. \2F/Eʹo"HuK[BպTТyV)Myc9#q.9ϓ;@EsNi<9@[._{z<۳TS"=WNgnUyر_ ڋm\Z֢v7tpR3^4gar/O' endstream endobj 36 0 obj << /Length 1499 /Filter /FlateDecode >> stream xڝX;6+4)2DŽ $ȤJ2quq Iy_],:9͉vO\bgrwwSbd kvF>\dѧ})ۧ<},|_顲_w|$2`4eH$KLOm|wvg\FOE4b-/rɤII 9,ƗPa߾iמ*^ -0imBgp(4` %G_зMEHR0ʉCHbe&'!9B<)9qZQ5!);g%g% >Q1E;-=U,SUqIpmUETOcAGqr,2H=llLW:@SoUYfXj{F]ѿY@|%|Gݟ_t n!8L1wE,)EPt:b΍F9õ?c>cG?ڗֻ2MMR RCa]8/# 7P_߾9+>fz[Iij0qrPae` Os~`;p^;h=M`~apT h`tyT Um@3k;? %yo=A\/JNt`g+3?e"7;Җyb~S˰ *$%ex̳, >aSxcoNK^t=37n{wC ftt: X `j>eԒР z:CNW?ʁ+xBUe1G~{/! endstream endobj 39 0 obj << /Length 2110 /Filter /FlateDecode >> stream xڕXKﯘCL,$}r\sH.sHUF$)RER(Ej8݋F?~/i$ʲySReoq_}[wm7nw]m &=ikR:d|t|5Ṡh4,٤etf` 1Mc'K32Mf"\6IŲirS?UɄag@7[]~QxrB^6[uۇS@d}c_9j7E4\v('4IX\v|RmEE- o.`@tO,3lENz+(,LYM@g!_}m72 TDvw`B?pz(qb;ܢKq"!HhGVf|ۦL"?e%q6GZs`ۚ&F5Β-|bݏ$&^rC:WZq\.AJ&ĥC9*EYta'{ εʴYa{ANk8M[vM*SA1J.ѷё S ၤlc ?*8`wijRR*ƘHK&R3ɶ4 heD,Np99A#S@&Uzws(UZM Lx]"f"ՋP^n;GlTU=1ˡ:QN\pȢuw-%O*ү2R Fͨka"8NaY0LѿPtYt /FvZ<_/J tou3A %xḧyTx*)69 $K>"#In =_5QA I.I@čWp=6rBk@M_bx=z;o Ip] g i*/UɃda⡘{Kh! 7ͥ2Y>IJ--vjX3A`Y**OnhsCPe/aΈf~\ɳ/1L6=M0puF89uB$75o|AĂ4x:͂bviXm/w}Cߍ OlPóiP9΍ŽfpdRh~ & +"8=kF;rA;8;J֑!oQх8s_g ߇ݑfxPdBwt5z?Aڐ}ߝ&!B" Z@_CyCܨ”Kcʻ iΠLx\JTlIfk"@aɒ ⍗1@K''bqOֽ?C !>g+LBjdwöotBQS JWH٤H=|Շce`)9&a9(b OM+XB-q`*K_@<ݕ'? ̈ DD|xNХR'xFN94ܷi=/QHӣj!3/뾑<|/k-+q7LU6 SUڣM(L:T`_sz|[c@bN2nDOeޑ&Lȇ}k8# @ORRNy^ (I ǯцw u/dm.Lb'q#> stream xڽYM6ϯ0rXIQS$,vԇ;{P[ZjH_U%tEH_UyoҮJx_Yq&RPʬٞr֬4-C廡jo*ZI)2cjj-ԐUSm CլV"'c^un>so-8*YO;m]$f R8 4e}=OlQhj#~p,+S4Jd#_f}wF$QYn+LbW[%E[ X$[7ruX^I8tc 6(@r2EE*zn0Bx鷶QLcٕ)8/ ̋yUдVsWo;J]u`RX* j50vP"Bz % x^։296!<OO<B 8Ww~h[Kgjƍub\†U/6؝#;Llw}ޡ*J>;G>;{wE"ȿ/T$Q Ϧ3,2!R!6 h]5RPdz< 6쇮 =mO廥vOr3*#tœf-9僭L-^ _WVd6B sS~CaRdӴJ)_ؘz9jߙ ~B4N䡍jP6 ]h¦4%I{7&OxIo z "UD \GJ$SF^1d0{ӉgpMXZptYfhh]Y":_}>{=(`X5kJ,4x³HekBۃ N|g{cȤ##uy9ͮ"qdJ %Cߵ^$6v͡&LLp\7e-;Ɓ"PJ`LG {kRltvP;!cf&Qw8=ii_b4h`ЄTSD:Z߭/nBoUsK8+iS.(:-x 'h$FO"lpY} SOkJBHu^5?*8rtze*aLEQ-x-T @ܗ=xZ y}p ~1Z(c@=1*2WH@ z0g,Xbč=5 ,q$7wr'jN/WoKX@䚃)36tND_;z+D3\5X`-ʭDa&7zH?,z K~ 9oO)uNXzx|Aޡ窀l$Dz:/1; (nNFTo\] ᣣ9.5i7;ͯ 0Ap >hd<}O@%Tffm7v) 2LYB%Kl9:a7 $2U"Ǵu#755C$ *0h`9\EZ:>ҩOySi_ӽ+ތϻe>Ac 'U@.bT;"mWT M6 544rP#2YS~O3(Hg̟~}? o7 endstream endobj 45 0 obj << /Length 2544 /Filter /FlateDecode >> stream xڭrm"xa="y %3L􌠚Nsа*&f˦=L_.Dl&@S #S<lYL!2 Sf+ ex_5@M&qqP \VQμތέ]\]-DGo ATӉVNuNe+B* D,r_NPxQ(rR,K o(Aȭ5alj+[)\fš>M79aY,iV=2h&%xHp"9e#05\x}#xڒBqT[#?JHjKZc|Z^M4ib!)?zz iPem( D.!J֘4zߙU3^)am0,/5Dli]EuODll& eiԖ@lI/EW`Gkx߼r7G޽V3Ie|7l\:MSN WyK!ހRCH>40Ka2PZԯWxݴ~ I)M !sό c!!f LP)Tcg_3tBC?My! V$O90pǹXձ&ۈ0dt-26qx>@7dXqhC?%zF?x T+u6G{3iZ5 X#C gt}%` #D]1`.y,;Ji^leaa+q#]65 N]PbÐWr9A)iz?lYo*W$3)T{ ij%ex&^ Ma:ʪ[vc2" \lj&pLz]D-NUx 'h㇡BKŇæGư盋NO{* բ(ԺTVK0x(GhpJ!x[#lNnKn `NpPi?4gj㔮HDZBGûV a(0V1Wep߹f\N[B432{C7o";&lQTUܩ@wt+ M璄gF*?/w{m}.!fӱ}ggZb w9Kz]͆ckB_*4 %vˡ&$aFsޱo ePg ez /> rCoV{<&'h/L#q\z 5=:d>¥t,J>M 'v~tXxg:7U[R{YTbQIܦ}a 4)u.U, Gry/ͶK$p;P{8I fF!SI~}yAsE^Nk~i| :8퍡s:8i!eJ\l S㒁9)UE@zi` ! Ti7̭ p#?-Acϫ+ؠͧ*+%XITC H.mO#UQ/Lzam*[&~^RϜ;Rgs=پ[Fa\2'dm,lry%k޾G SȔUWa H~w[@&Lc ~%.ܰjs?8i'}Ʌ6dŒ_v^?(iZOCνwmge&6abr"N0¼w騿Zt2mYNnc];+6G?dXM -qD$niS'I.% FT. %V-ߚt=5D:+\A^ʬq@c͑Kכm?/ f>`{X*;rhh`B)Ԧǖړ$I8fU#?X BZFAS‰ChR!|k׎!`: ,ǐ JxJl a]bBMdi+c?HJq.BkFQi9i- ev#(Ǒ*~.-)`ۈcD!8xXAQ%mn.|)P jF\o endstream endobj 48 0 obj << /Length 1388 /Filter /FlateDecode >> stream xڵXKo6QV%&EihFmbeI#pH%rDp߼H, Co-"o w-qZE{G9]rUL$liQv%{n%F%;#4ڃ$BR:9V-̆fh#0@ 7.Y{sK\68,C:Cޡ @H[E{tӱ!BZl|`x#jsvW֖QR=݉TG- vʮh @k<`A!m[V}߳a]+ɬ[u8Twj ,,EbY(`$bi(z!e3BEM(^&Q\Kܭ9h6 6DSFA?תhEa?҇Q@ph5;` ҤhPKt``==7`R ,)~ qqGJ2tռ }B9u"]iy q vEhԍ=xd?(جޠw8 Ckȁ]DMĻeZC4"Gdrʆtk$ ؅l sJᣰQSZZ{R!o+LwԞc>qnJZ؎%Q fT@GiRYHvt.${:p }$Uu;7 Gl5CR+iZLu|.1a 2'fÒMhw]M,mWPL.]wSg{1Y,lf:ܸL4l x~ a,3Ֆܒ$@|wM&XTYЁOD,8`q2EQEE|=-Dz.<q&czx\PI-,QZ~<מLFs3Sk0K}k9kv 3Uәv|7B ?uژ`P>0u.+Cp*T.L&s#0 endstream endobj 52 0 obj << /Length 568 /Filter /FlateDecode >> stream xݖ0{?(r$$[KR#l2X<>jJ-Ry0?dW=zYċi$7+C_>b2?t=@e_^I)c z8!ϐJc?$iQ4R~GE#"}]H@ Pow[X!HWj7 Q(g 퇔Qvy+sUXmCԚfRw.pf537l5hz:[̀+4 7! ∭V\Z as& Y~u,[iy>s݂c56֮NtlSZ:pAˈxH\|;`K!3Eeaj? ŵ^3S{'jg<[OLv_-a =\'BvR])hwfwQ䐻47,h;_2ӉKA~uڿ)-4Z6$/ո5v,/6<=p@x!n[;rf endstream endobj 55 0 obj << /Length 432 /Filter /FlateDecode >> stream xڍ=s0{ J( Z$̥rQ"$q_e88*g?^G{zQՔQEe*nQt)m'kJR d/h]V]9-q<^6XK ɟWf(BF|CVB޼GТ@ƽ8=sV1S u|DMwʦkQg@E,۽^}uo-ž:賗m^̲7:O̹*qL=* Wv `ؙp3J?epwf']> stream xڥVr6+8NBcccҜ#@ch`̀"LZA84V޾}rB~~=NwcIߖ=?ضY!Cv:C~mAǼi[Iz~[E``81gh.Jn҆rɝ>\WI< kx6=` FS*0V95)`Z& >՜ס6Ey ۬rc 5QĎn(@";xm첪+e9)Vm㙻|UU4D 1YwPV\n}hƯnNͱW3} m`5oI Lt@ԑf$Yܨ[|PI4Ʃ=[3a#rVBw.Tvmۻkak+ AoU33u1 aD(L "i#8xd4 ҉8s yY2%IrY8x0mlJDi8 0yׇA USLbe`!`l`;yA:?Ktl T^ xSag菥$/`fy od)5;ɖQ2k)d$3SYfNIT1A432_cy!"> stream xڍP ]www ww5; 8J꽢 fuޫwȉUM쌀v L<Q9Mf+ ,95?vXru-?@CQ b `f0s0s01XCsZv@'XrQ;{G 3s:20sss:Z ́6 *v@gIAgl`h`h&@Mpp6(@_6Kc%[8ˡbgf|-N!.&@GGugY=_dnW" ۿ l m=,l@,3/G$ ى/h Y8?˵s251K= ؿ9&?633tݍ*aC=Cpvtx`ba 0Ya ܿ;@cLDŽZ{}Ō%h-N;w=;+ dgov?*ZtL2~5pKG#ߓAﵡoyy;/Kw+IX[ohcao<8솜dž__ -bgm} ?6Dmpp(Z8ks ɭ-lvN=8zf&9cGv?VKۙ{,CGGCXcagx1, 029>LaQ_!N`ELF?(?Ad rGN"G? ǩ5?|Їn_Q)>M?T ?QC`0!|0pG_n;|P?`@"=???:yl@5R~?T?ݟp|xX?aCӟCPAwx|~rvG0n Y>y?O㿒Ϛ8:~|~w@;vuΘ7ز>Vύ~|_#koDdꚬɣ}{TwBkD^maJ/ʳ+3CӅ U_@s\$'Bj8d^բtJI `hPܑQs߉ia}΢YYb=7+UYzpp P'f)DRJcC#M Z#:wOc#͆+풋[ta6p̽2:)ubzFV-d9 Y9+'XQ Bu,s rQ6& ů9kz#wq>򙞖}\@upٜ8P5껕(^Y,DnO~oAkz|OB`.+&٘ K^[qRZl#TJ9@zΚRC”|J0ےEٲp&5"& ޳g.Bܾ!UWLI.+X5 z&fn09TqFHp*1f hYޛ6Ѧռڃ}i$?! ZD>s)prAXZ٩L.T+Tţtghe߀ۅ>f^qw$VqZż,f1pnDlj5Wq!Rg'}锧:!kTV(t$C,{{9f+vj9.UF *_JBF< <&P?/<5"ey^!s52u 2 lF?؄ʃڦ'0༚g:B,A$w( ¬mNdV SQ!0k rVA* nBˇXx!BK$!!ظnRsj]emҞzCա>B4wf+F'[MRӢIN_XIoomUuy(ZR8m`ƈ$~ 5̤d+ ::ޘo/W2>`d3?Ӈ<8ar/3sWN6c3can*,`ݱZ6gCI7\e9OhĦ'5>0eU+ihi0l\@05Zis'+x>:)jP5_-_jnzt`0T8 lfǺ䲳A-I]E-P8(RlFWv'bW~s}M!P4h*nܒC,%-Mrv4+xMLZqBd]jW $EѢ0s4N˩g2CUU%*O{~(4ߚt,1'-l2 _=hT@}-$9 [@vlC]=dO2i8G]d:&}/^7?~cU Tx"k"_EMkg& :;ՀA,5o Y,Sz'կ>#enө?[ c{^=٥Džݺ'[qgSX"棪46dKAFcM;B<公鍩c \DԄ$q®ȉgwLʭ$etGӣSLߥ) n~#@vkFIBИb8Q)DJzpAic ȍVI"UPCʌX=ع%\V- .79ո1'q%߽A^ПnuܲTW;yF" Z3^'_۹9ý;I]#ʞA\@VL MrRJQ5_v g^W3+~ތy`UZ )Ule4bߒi n6#`d-}Og?T&8ضMi=}f:3AWQ]ʧH"3~kލ~+ns]wF'Urwĵ%J@gGh<4<˝Y;Av$vx ,}~kg)w7) fuъip^JlT8\5jY`#xw4|G_kWKMM'W9GܕƳE#3SlLbP510x:AVԞ=wΔ_x7_HGО_FG]"[Hv7ltt v'qc2DԐONW9rE? IՉ(QJN+ҬSBϢZ̝5Rڗ?% U\ ,D:{H)ېJ=Vshݯ Ƿ6k V3䢜H|91shGx,ڄ.1`$gӍ3"l .c,Rd$'$#=Gxzy8ܭn֑pS; %w6k\@>-B[ IHг@j #!mXR`ACNE_8r~^Fd9?$8Gt\5=|P0"ԙM+3EdAf?<@}$~M91 LZm(W۴VUs78 32F +݃9%\> '#n7G׻LR\#=qց8ĠivYe!F/S%_>&c=0#+{ 5l9qwQv-rzti^+' *>soapN?#v,>n5zfz9(ϙQGxʫHnz[}HN h'S%K%˽K_ڻNE=L\~.Py<rwyUП3@>I2W;j~a[4sĵA/K7%mZ|VXڶ!=[r⦟mJ% j  pe<ʇ`g Gb KcD\R. 3[x) 1+7vC]gqsEm#fd07Q\@ (J\>{=Ӿ/15ƙ`@_UUqT)/?\]K "j3¥iyyFn1cßsS6k}j7$73A3;X8U ϏͿ ^X|:h~91+큤eɝE y?ȅ뒇@0pA; NJS3!-tWU!G;kq.H$eXcBf[l2C99)#Bio8Ox/ʼd2b(.F]̧}2ZIҞ~o* ܈oB${n<\uuJ9}A7,%@)~Pf86hd"ΚQ6pc׭~~p[gwjPݥmWeQ4309SW!^-.p&CXfȹkey"t?^mavxtrl-I=-X9 "Sds+õ*ƈO;ý<0`gKPKڶ#,VKo"q"aNX_MZ.eRɟκb[&]ğwi\~@{Ī L;p2{^\/QL~3cr=Ia>#nEKc(d B>wn;ɪ3=!ȩH2ˈE\]LH]yHPC(Z ®48 A!u!E msWsK Jm {3(+B*'ߊ~+_wQ2lZfL{ ³צ7{ VȯeϱC)e-|EdBW+Üzi-Qnʺ0#sqUr嵤#d6L禛.:fa W DrQy ѴCȟSS;9UCZYNW q'aBNNE>!>}ZB)o'R% 3E\s`͵5C{CW!Dgeb RM2_fKSߩG&OI x S /vP5¾vͿ;rN~#wOu0'd5cD_W+grx~ԕe=ƳI:H{$ΛI'7,iv'_A\ON(eOgkߋI(!F4f!Q] mT)#YTO:p9{ȺHFb0%"}C +&:aU<[f~yDܧh7=*|. )xE2`mQjk1Vo@zs4Fծwov=cڏ~f5 wΜ8P*F/Rf?;!DA"QYdi[cO& *aHS)?2'ԭiוA_lC7׵ͥxl<)?1(T  }x2ce>ߙPF$}?%UB4 UE&,P2(wJ~YGDK"iØPEӠbuhZ+Au3r6 jD]Yr?[OїPp?r8f{2G'M6#9zOYL2(Pek.OPa{49z9Avcf|oawXj@ܸlE^r+3XeK{XgF1_򋳐QGQ_AKs]FxZ.8}"f:5$|,4BNdZ5}oF_*Ǐl˙Rl P 1' ;΃&M QGdh0b`5jJhB B_Ѡn UH&O1COpԵ}I@e\\-37NLGSul=Dj)sޅf,>|D Y-=87p4Cz~83Pƪ2Y:;*:fE 'x{s]n) tJSz s" NV;!U3f~}u (r9+yS'6~ߵ3ԃM;n9,78@>kmlĶ܁s` OF#E%DeN c%k/U FG|o-h['ÿ~jZNm{yZ w׫-nqM'n%Xl<±VLnW,#9ur`袏IxM P=qX]q{`GwV%Lˇe ISW =ߣ}W±xcDxbˇ_32F 5|^҇V,oğb5Fx|he)r2 *W֧{=洯q_$2戅a״q¾>Q7g+9x=};ȭ}'(tSoT%ة &&>kZϾoxO4MJ~QGE?iϹtNLBiT4&F*>_1Q  $0EaڹqN[gK i#ک<Ȅp/:Al +\ߋƏhbK.F}7IX|Z~o˗7#-[Ǟ_I[e L< 'ǒΡ.IG\망Udy%`־F̡JK1C'6j`-sêFu´<, )U1.1@$_2)G8QƀuƂ6iRcU:ԁ1W(5 #|4! V&m\( );(Eq'F('”C2{^^x ju++e@+U/[zm_רTn$Q:瑶WI A5@cpp|20ojm5l'~U#$!ӈc+T:0룵wY~d t;a@ :DT^8/7u&1EdL4|nvzʆb*oZ/tERƧU$3tnfs~ߚtw\xsR9DzCeJ*L'y}2^C})Pfan1"؝h GܬD N*Э%K~[PtQ|Qm65ӆK9[+~DI\ׯ_MKFF]ԥB ig_=ODsY ^:D|6}A'.М9IG0c paL3}A%&h5/1avg?v qVR.=knQʙ+=s ]m7hMs00#r_vE9@e:_>`MmdtzB?DB'~=Şa# pwT{:"g KSF $ [c<0fg TҶxf͂3,g?yeı淧(n`)[k)NҐi )I\n[h^`GqJ Nn)l97 o21ML݆ĕ8Rwwq ׊s JUrIöd, ( 6s-!<W?lO!Ե4D5^8%)HKq_  ɶKQM8c0rL֧ ;աko%W)F  PS ڑI8)bPr4D ǻHoR4>A}v%Xtq?L=WFm[^ui$,ˈzLstS`펖R6y(! T$]Te8tD_5*$%i(O EꩨrR_yi q)kS4i|=4Wä6U$ %$ I^ -^\E%s0. <{ڊ:u>Wt-NmGg6Qd1̣j7ah?AXϸÀ tcHu9E8 "')GZ0}Ԋ^ |fyy(F@(y{J8\< [gX߼`R[RZWb8K:kC;NDg:; k#Ic}ES,еo`&?uĒ ;|CgJK͎'* zL}8VE?N3S􍟵/RFPt2.<.[p8EB$(f#ZW޾_nׄV-"W6Y |ߔt_^mtr3e!j8*OZiMdgjC?\b9?};v4qܳaSr> I@b>f.>vRx{vBWcwH)ᛪgRsr#=ne8> H|KB^u^|_O#td}QSӅZM0}qIE\D;%DXh7EWf J<'_ӆl;cE3,?~7h[bI3ͤ#=m(8ZR"|0V7łolhSF.ėɢHNQFrUP36bFG=Ruk Fސ$=/S3gY3y&roTAHV^$ozFU_ᮭd"zŧ8w2Bed~x50~&*nKJnsH#^hS$?tJ:QNkf!/Q~IY0򧺊jaU]yo0>pԆhT귚 2~$ƟbKK`a: V⸻l6=bk?7Հ^(Uߤf&V6dxۥa-@(&;ޗ;Su9#ub‹C9sm6u$CRSVpM xlO-Ov7IўF陷&7}){icH;z Mw'ru 6d\,j҅6 5Z#ƱD&oDݏ=7]P&*{r0L7Z߂aBT xWQ`Um¡ 7#p6+d#NQ1L34yPXs9i LșNǙV(N7VY'crnJ\=^ R>08ݗsm|倿.R"cY,A#4O1<=MCIlt貋z4D;̲E5di:ջF,dldX+!1']OTD[;-KJ\XF<=ۈK`KK ŵy;/Ȍ垿b`Gl:no@⾃ ԳP*1:ϺKmf#ć׌pEv+ [H?Q X [1,4HTCX1Nt:_ZUH-녾(듅v|fUPn5GzɹeWX3.inh Nߨ{fl&K+"-?W<٣؍}uI$/ '"x<1Pd/Qh;m解~[j% )&Du eA]!CsJIkw9BEg5Yi&c_dQ$-oV`X0eojA iM/D V+lkYFrd_NѢ+b6VhVgE<_s (*};tɮ$"1Zau+?tPx_&٘ $ i^ V*[FS<;;}=)>i`}H_5"G殃 ̆l+ȦĄ^.A0K-fiԾdayY-@M/YRq>|]—ʀbht5 gmOw NDߛJ4Cf"$w. a:>cBUc!I+birrEdh>{\+<8/엤JR| TTvN=j`Eɮ0X/|M>#?w V5ΰ&ngRp}"dewY<#͈ YH0B$g֒ēš-AL|IBL`L|Y)!d̤]̀En-F)CAPUY֋` w52 L߻p2͒Ȗ]Ej/iaTލ/^m,(oh5Ak'062 "uսϺY_7Rq>5ŒI5_!HVqlJzj*Dؕ7eJϋJ.%ϲV0%̷t1 'wj F%$ z,$Y"/)!JaK`կ#dudg-õ SwܠZ|=%R%+zK!lClijK>Eu endstream endobj 67 0 obj << /Length1 2485 /Length2 18286 /Length3 0 /Length 19716 /Filter /FlateDecode >> stream xڌPA!;!mkpww Np'$ޢ X-gu2"e:!##=#7@XVB CFbh Cw0#@nw|H9YXLL܌fFFsD͌)k { 40qqqڛ[dMV -6f@G5utf`pqq׷r7᧢9@{g/9}+?a*fؕm]큀w!=hx/P 'ooLL7/"3뿓 ml̬Mf@ #-@@}K|}g}3K}OR W_yﲨ d-m\ ͬadˠjmf7ft122rpv)_*nLx~z|uw흀_t/ab: &f0@\`뿿iIA^YF}d J cfcpqr8_UA߳1&6p#wVP{c[A}ߛhob{ 1'K˿ݔVfnoy73, 42s^IG!dmb69 MYL``[cbd?fh8o:oIQkC3;@^ }_/0[8yma(;A/?}~#o ` E߈ 1$~#o `ޫFer{u" {轂oV7z7z_}{u"wcaebe;2;4=w:_7_m`0{dfk #f|?WX߻eNff{O~_?Zm~=bll?Ԭ-ƿ~jA*߃}'sqX_p_3{gzooI@+]b ޻``eWGS{!G?9rE{vӻpL@Jed> ǿ?EP]0s6<B.tc|d.w8="@%PU % @Z\"|zR40?,TׇG"bkS,ΉA!ޥWܵty$hnWq]t.R5B˷h, cґ#5ʹ+4JT, HQ*]ؤXnPF&ɿ~:HœZ\n?41i}WNRldxzDUQ$kԺ%G|ٛ%G,ncV%z:u)zBu[0>hV9BHޮs$ր*ZC3(~KϖIz Њ̅T6%aMިhYCAukB, n8F]-W .N$IBzjv K쀮v1,UZA[ }H6ZjPUE6g:r>TtCX&JTH+ePW߯δyKM?!Y~CȔ9ΉbA{.n8 x X )]|k0gIr=NU{P9<> m7ÆvRqlYX'`UV.Z+տ2b4k9r2h/q K'kjEy >Ш LdS: 7pׅ)JGN91")^^ٺU4?}:>C9<^*hw)EaԇID^wa5wPĩg`|2->. >Jʕq;)b(3TlٸVTAZjT:֬pX;0c净b29F+XF Uk> Nb/*$d>.H:$1:cpsѸѪD)x8"}3IR=.T6CRUpy{+g_`I((un ,],d6A?XG TzlthP q=;QCg"-FFb8^WaƢGZLAjhzPf y>~9ƵTTCr.~Hm\ ["W%HOIw8P>I8/uhEdpoɂo Gqx|QB)S mQuϠZd9d|$?膜j -M6hS4 eݑ]BaKϥF:;.u`Mk!TvGl}!׺:N&gTOB)ǀC|^kҒViȹ]yZ1e3DŽ/[j)Mr-0w'?5>U_& .|dl:P #7+5Ȥ'gvAH;͡h[I jJk=Oz.P2*JPB䏉H45׺W,+z*p%ڙ=lJ tݔX!BG+y#prVp?B/;[p\+wGZܭ:C,>-&ۅ@Q'ߚ[jd:F p38.^,㊥!TN#|*Ib~4pE"7F#Կ]NM+) n5y5N,M0yr0L{M_MW fŃR>kNwQy㚩ӡ&3HVV\J_8)v _\ɛK ֵp9gMǸQBQHZ96OWrɑ%}Wr! |6"P@} ۹õ\'bjЃg@Zv1Ti] ,ob(G̭# J x ?Z"qWKFD$ФM}H}~Epѧ$d.:^DM~Qbį~dJ,>Pntԙ=#bxܗ<:h2;&H/$7WHQ ":?6tKX_3$lDj}2(+͡!#Bpm'T'0cC1@!) 26 OS[b Ow\0R]չ#(.ש.g+ mc JI'ýqǀ^T9b{{a^,ZW(X@!=r@ G-")xU:G] Co\%:Q xf N5ebT͌ ]no6ۼm`!5x݈`1:0F"*GsHpS=M~f\.`}c6RRM؋6G [.c?0!x [\05ZJw a lqa|qp}[&^rD˺YZ@I5C ((tg^8V=^>9C葠(G]keF⇆ypCw!s n6({Y7dBQvO4:4|䕜E U ?h?~PZt⨷vone ʒErepi}ITFSg^,?\،|o6qa$Ф;곍sKX r";_/i*oxpHN&CO[Vv9g. *q?!Fc>@2>QѸ5:{,-H/69c}#n|Ge:(K!^/׺.d$ɩ%y0+.Ex6]9@صߦL.GZPN09-θwgy:ٜ}$D^.k(kG Ϧ\6 Y׎ [2j! 1=e%/5S.r/5ne^kN$ruguILXxFYc qOb,.ֶ"5'Pn7;>B,QJHY@!v} U=/iZTI'Cc*qc^Fh76fuyp5̠cMlM"0HSw1]2R&)]eLjprI7)]mԙΥzWq!:*O-,X`'Oq`6v1R! zVSX@l\>vtsQGhҰC0T!U`e*jlgBr#R…Ӥ=uK]Y^u;s"Vlcz3IPGWwh4F:P.xYY; ssjF ( 6m*cnLS)ͷo0ܧR~3XҴ  嚗H '`^wִQrI"/к(>ϥD3T+oO{ьeO.ГƮ^;'нkje;i hNFCP?4T2kB._E]Yh_A-QG-}_lɦ?tm)@t5QiO=9v4O+>]DcߧP+@VDRvJ.vQ2D!·V#+)Y&:܍*=GK/RKJ7_KQ_.Ms4>޶FKuh"Nh-̲` PjҲ+gA2Jzd[&oڏ)?qǟUUˆ)U]H{H{=읽'ʛXg0к>u\kr*R3stdqkߘYPMeNP<8ď 2AwR,%#x|5;@4)/r1PKXx o!hPW7Z{ 8^DV qn3RږDXJvC$R֝kCѩ!P[Ȳnl;n\\@CHm5[[h6THBix:J|ȡT&Bx th{rgw`bky+kkɎpyk.+l> 1o9Ci#Mko'4B D9g g|D槁 ams,F_Ȉ4{ t9>3rDB؋X":%5Y{vh#RdȻ2J NVkE %%cW<ŠwHm}5Ӯ)}rCb`&_ EމZn0,#M-o\g5P82Elu?r*$ 9bGXVvW\EtS8vUiQHz[a{+|ݙ_H|y; h[#p?`p~%V]hiRt|Ь X/EA6OAppO]8pi(p5 :.Q >,{-trrb~Vcy8Gf,0'*Ş)i|o.6T T8| 7Y-&-g~/rO:Nџ15|f] g@DN GPFtʐoĥI~2jc֣)O1ujՎ$폼(+'uHm75{Ѯ y;P'"B+} lӗaSLW\KOXh()9ZM|A>uNrT U\ d`e'3ꙸwY>D 9#Jg DZB>8Fcuư^H`QɩKDf[i~zy4Gjr%ǮL*eK9yHJXBslM9;/? gQ:&6Y"!Q*{4> GE5)7~GZH_Mg=1y7?y)z.*BI!hA84L̔ yS=ئzr0ߵxl:F(@8,\k"Գcmҷp)r[J8 N7A^': #JPH>mfS+7ٓE_C2/s(2D -h dy02ٴobCöG'6J7Ƃo#`iE1oT`$h iD~;i8۷1UlkRec-"xU\8CqZ$h;{[դDo:i!ه+-]D3#?ǂ;|dWZ9U=p&1hU4VdIE6FJa;%3݃%Sű^-͏йm 0Q.Ɗ TZ3eXḾGJqcyE3\f%!Z ?/eh|3Sn7ʾk sWJfXa׸ 23t;%`rʊ>p~/\%cG_%zX-CCj cKch.Ui.R}5)"?B[?4z1 e]9򩄤&Mn}-tUԨR2*<$2 y3ϰ ZҒch/8iy{& $_d zsO9YFoG*z#ZΰfQ:xƖ&Q.™P^%iQH TcKt%d K݂5S ǎ tKq!EtY#%5[oh%5X~Ӳ%$x5gm:D0Hϕ+\KfF<޴gc$?q@"@b/! Se^xIp/LR&ѓGJ-\=: !_r<6IhZxźjb彿H1Su՝.{$Kk>#g9sBnU0Hq(}*zi BZO9ŎA6Jm{twmz1<8i$Ejd'|Z;'UdOTF4-c ,3|Jپ͐rmBVCL ꄾ-Sk%j2x[$C]W~?MZՙUp~VJ\ܬRJAc])tܠ Zo*p g!XØ= <9t⠴"pif e~OpC,?i yqe!0qSaY34,>p^$V;~$5F[4@!-(e L n\9= pnxm)l9`͒gC{|P:`{p}[ؗ[}EiM >SW[ȻbMBeQ ]$L+WdP}Di՝q'f7¢U=6A%||Rd O=g3?4xB<<)gq ؏85B>4('H?f_%fi\Pktw!IX$Kf7BaԈ]:-͸Zq=l';T i^a1=ؠ{qxuL\ij}0D"e ?1 󘕚, ͽ|0s]ę g^+Czl@$6QEQ嵖'MԩYS^^)d k9 h|o p.,`݆R .Jĩ>~uxSUE!0Jޖ"9XVbR}оCkVmeKdW4b[Ih8tΚ^?顶yoTͳI$q9hcDxcю,|KuSG(VVTj]SaڷJƏܖP}ESJTS2]qi o"?c.X @>w*13 g?|3ml& Y~!JW"=޳ ꢒ[!ٯf(='sS]wC g* WjT LQ: a*!"9p<.K2"Hru5c+8y:UpwJ]c+׮}rymwm4O.zm&ű#H̆fba9d-;V{0_z{IJ%A~9{}k z~P gIdҔF&!*U-CI4,=wS5&(Dϫ/6KtYMگi&4\4D O]A-ч&w]r 4 f Vd?ҜT-tq1 dĠ[odB/ V`5sMNPBBrqhD-!t~=ZiCB fx *xV>VvOp>hw=v D1hx5@tV&R-XAkh%sc€KyqoO/.^Q.Pɍ8j>Xo9HP5ٟ1j8 -;a'ZO؞i6yu(.c)xGxoNH &vE gްlz,0<) ^&zWVvu'LؕeA{˟xL\81hh`/wrY)?"!*'+GM#`L5 ,ߙhl}/5>Z U s0Hy)ԟo]mx@"ڶs_`ȿ_ΐͬǴx6Ny-˖x"zAlͿ=y?}XATcଯRY2q] 'CI&hbW:lүR?\~ n q:өԀA<<ԬjG\$\'u(v9;nń X][>hGRd BI//VA:sb>M+At 9?<"EyOM>Sqv*^yE >9ѣȧ݄[AYX%xzU'_a/xiYGe W븟z#vi?/{%g%yv xB rhD=Ip{ FVP)U*E+PSt$'l{rp @Òap&J3F%bbLIROUf2D5;mF>[&.^I߭uKFw;fb=(QPimNxXN>bP0q#pX'<2B;h ~OC0n*tTK4BSXƖEв7c7,Q Y|b-tb%Z+6t\ V-G͚& !W s+.ʣO"NO,a_E>lǗOBZeH ^=~ KXAʓH eA)ƐCҶ^"6y[ q 8V qr*4+C:==sRSE3Nf_Ɑe1 +RG etŔ|0f慂ڍRD*g9R$D:Y Y"*0@i7&ND.źjg67j495' Uy˜܏|XScC*b&? JNҒB++"0:V:&5kbFC*]1B^O)˼ZT'(T3R]tw™2a1%(}V1.? "+?ߙת~N5d=XViLw=Ӵˉ¤GVzsY̸gb&;d8N] ̊Bz-ڧ3gZ _;W!-ԗo}^VGWʹJV\XD?Ƒy5VU aS2'ĬZg㈕4}Gy18()&mZQgBنbu]xw"*"%/G6Sa^bNL5{m0g˜W6hƒ!1@BgN*\5"ϑ5m04q>ݬ R+1<ruJ~P6GQ9UjK BGNuıݤdV/>[,aaT'hz1d;T(,3' ҏ)X3ϓ8_0 wY:g'V+ ˈp#E4cILD%-JGB_mNP&~mzS|VYYG2"oA}~%f69vtg櫧?ghkApO]ceӵ%y6 2Wi ˌd ^IrmĝZqԦyn$ [V4AOjZ@G|pP9} oVQ. URjm-V#$^C'-CRHk-WW>.ThM 9?S(>ɤ??'ʽxa#4,9}x>lIk@ԫ3Dyr5s:k, )x5#*JuV2KF3.6AWIJkR.h1[r2Ÿ[OYH.pxmRS)|CiYO:@<)&x~3'y&1ki`VI-)H}"V)YX|d0~ɏߌ}9=lhI|R5jsj2\0ʿƧ~<|ISݰXXjʱb&XVωASɲ:b`{,?؋H2e2ZnՎ_?&ŏڮP“ K^89iMN_9[8м("k@@c+Hս#nTu{+, g-K"T e2.ؤS7S;VJ)Sع'"ƾsX mϑ5Ȫn$$j _v>&+3 TkJ7&4N XP+wGpv2WS4.׉?Ԣ+?9C+Š=,X 9؅'( cU(f*$ Yr cL j5 q3ۋ4 ɢO#?Z>BujY֡Pڹ< o)j,C4MLWFkõ2XN~s[ZHz_u#gpA %jfjr7sCgCif*b)uIҠ&SrROZs]H\ pc,}(3)v bE]VvE+Gp(!,Pҟ匾|ZxP7hG,דJyđ^]D8 yX;='PQ$:Hں1iV1 #okR/HOZ#d{NolUQ +>8Ilf6p7R'~~tUij5|,c( Ao/ky1CDPڵ6$lV6 +xC>.MELOʁߐ^4311vE/x4OH_{;3Tc!.H{P2, C?M Ǯu*(wfz(~a/Sv\7?!C&ξ .{cG"'`\_g>v(f+p+vb Rw;~U 8G]PIڅ+{^hI:_o6A%^ٹmR GHJҺC:_yiGBЅwqU{ eҙH&rjK%kbCWdGg$|r eTQj21y GmoaG kk㨎;cc!Xk'MZ.v915 muDDu i(X˙!Nm%lokc_V w`ɳdg:` Ju4y sfF-a'>J4̭aUQ,=c~ޛ *І_R7Ӡ;t kcyS3gc@2Q_4zg8+=#u/Ka8 pÍC |i/w4S {1ʈ%C9<ٽ` pOZ( Z$cJ-):ַ)Vuܧl#oUx!qK' O{V:T܏~_*͓UW;qCۤcS鐸_"H]׏9CMfHjF$E(kPy÷u$<]Q|lg0,9 6b~L3M aLJHTa2fΗ+04u;]5A %PjkB;ieǒc2U^3hj`k|7* %d\xڣCaUe%Ȣ*+#?m*Gc,Dmⶔ6(kKL4ȭmcb֞“: 'ְWSŷda7û eM6k"hhVZ{?iSZx`Ūf K"}?i8uPHrP玥d6Lڥ1͛ߜ>lV(.5IP *9^m9m.SۡBk a[f%\Uv|m[794f=s|)a>KQ Ihn[!9>-1Zm@n nTKs-1ꌃj/% s.ޝtmyշvQ품 9fțȯيXgt_uta) ;g"B%T%!^?M (_X.iu PX;PBb;O~!`dA! 5 l (~̔ cow|L "  ;~D2rkx"9VƸ <Vk?#Ȉ=n(Wvn>զN|n7ka[ @H)D9ŒG|t#E1h:w~Kװֲ \Eb۟q6:>(`kRgNӑMg;ER/;Ѣ\ʙU z,uocυ !%_Q,DA< 4B9MbJ~äٜw+dyçi?,=od=ju; M<&/̃MύO/ LBր#oI Rcxfs5'xΣΜM7 WS=ȲE~&[w3.\(`!ضmi:sf'"8"SbC؃tfA.@ ck.rV^v 0aⓑ="W< !ZRby\y[4^>nW:xm]E~yM |`4@2N ?]_SLpn)lV 3 '7Y0z.bh(ljsThOwYN yHuCדَW#e MZG>cnk.[(*ĢI'B1f_k5pAǺf1Qμ-Z swB5כǙiOSyNTpvZ\\H55(ַ/GJD1Oa$,sW/`kࢬ w*4+Aiׇؓ0w\)Suihu^M4鿷ѩb !ኘ'\z>-[mUuT,9u:_b~v8wTmNG::;''7frkaRƹc|jWG }^oNGd#Vzh,|* ~v2._Thktsܭ J{qlinTL&u.ߊ,Z}K>ȐK$gMF:aL!ttw: %*@B^X ;m)kV䄮snӽ/nMsnP5奉 ? *JE O*fP;zKHJU+7-lN(~qaxiM&Rpt沟FԪ৅y)qH!04Y}\jrM6n=`6֣h ÀJ>Iܴʳsp߰[&Y~KT#`+q$$$Ti-̈́gbG_,r JqWvA?l}?uw% ktBmusKs$p74zm@,+G~5tWۮ\fȰsX@^[_8| 2Xsbr$ԅQu> stream xڍTTݛKR{HNtADR$A[@:DIj9gͽos9L` 8 % IrsAPPVRn 0 _65 tPPȉd #j /#@_ܪpN( Bݱ@P)FCNT[# !(  Fx @DHf.fS( Cb0G0 0za j@U rp{`>3  5DPs"|c~P6Dt@@f<',p #C H@#;C`TǚN챓G@0+1,_W6Xn9aPWBKCW7]**p OXB ,.%ɈdW_[@?&OEm ON)~;<w_Uy4Po//!P?XQXEñg=";BFP9CDR;AP.`C!0 bbj c0/͉KI@ȇ;xN Ċk ¦NpyJKDHU@`{؞ ƀH']7T*x *q{/7hFRWd?Z@)~w4~(!Ÿ.dd0CЋ՝l$fJ!n:yF'Β5 i%q!Es&9 Ql4{ã1gCW:Iq/,NΕ#3q1Y2l<ѹ1Wrџ>< n 6p11i.4h%q$J}YhG &C 2Uv#Oi҃skP4^:pr? =SX=K2*E"χI25=K`=gz͋gi, Jg!7jHc0p0{]rXmvY.!>54S`E]iCOưPMsۅ13FuA/{›7@@h͖W,SznG%'ԏcL-ζ,HJCtɗm:oG4/r} X˓$dCG ݗFN lO {7Ň@eLo8?bݱg>(;0!Os?Ʋ5kh(Mw1h2LN! a0wE̍0wGil8F/" 囔i vT 4[&A(02rӦMLϪ]rzmnkߧ}cnˤwI<.Qԭ`̎9F{{C|Cחn5\h:BhƉTl7-}l8k"|EyϾƖ5Ҋۮ-LcƱLCm&ηȫ5=cO i#N)ژJ&;S5Jg(𮗽x"35 ;TPZr`υ{Y]|w4q/ Qdqrq,~T,|+[*ؚDpہ]〚lzÄ4mb&vFey{[q>|ޔ޵ ހPA6[xjnr1> %J頯N}*qq׷`}5Em$)8bKX}GQ=8ЙLzmfH3lF:N?dpC P?>- ^ 5ih722NvXDif&KL(+W*!h-3w37z}eMgo &V0=%Etꑪ!F'Uý ?f1߅vl>[ADŽ9gqeǃJ/:FY]*;-˾m8?x^MBslֱʕQcӢ*m5n)( 'P#ě۹ש,6psk:J Il:VjA#眻qDaa2%ef-caaם40N)Ky sI{ '<֧ݥxޙ0 o@bzjdudX\qʬId #7=wS-s,YdIяbɃXdFڜ@Uޒܩ{K;lGo8I_.޾5 #yAж 楙WZmz"]G{l,A'*&9L[2T.T% fsE^0p?#Lp3;V8Sе;ZWqepAvzXtqϱicu7;'1.u>{O&4`st r7M;Ҿ|3v`wdZ w|b񳇛>i.Q]"e=:͙G9.{uxb =Gආp@ϖlLH 4⇩A*m%+I/R# Vwۡv{ՙI2)5{@yC6~ ؘ f'JmjEC0-+6kI6y1BvɫRe*ڦ8,D pu^z>Z559UȥkEiZ32OS]dj$)|_g|x-/J >&URR ?CM{'2LPb`ryCQ̢J!T릋H N]zb3m;NN)gwFAT7tO-W@m=WzԵk]ٳWQO:<\BP։cnm EVU)\P[{)M툅W'x>xx`.7؉wZ+.?!!hN8ӌ]cD]E$69Z٠Ƈ#(z?*_- :<'BfH̽ oEhNZnyV8rc3xoeu^XAёY9T$PubN 4C/}"?i{HP m xz0vϊ5)qupgrɩr 'XMqOIa쁎5{ڮy5ԷײEN'ZUi'=|Ԅ%OFT{3irQgW<{-Ǩ`E+mOǥ޻GT55]J% Gan$cY zyZP0\?e'{^/eL.0ʭV$4XbJ3mRJ!_=L@ba轾5riP M'ԥotɂ!- *AQ NDwΖ.#bJg2ubxU\.oݔbwtcFKO:ZQČ[U:l)-呛Eެl h i8H|жWj\Bxv_RlpFiolcrԪU)$ր5AuSzPcV`oI ,^+.5UB~.q@tg`^^ESV.FҾyZ_B6 1 /0͎:n NdPu WTI=!'Z'pkaEa|@ɟ|g9cI+Z6 FkUuyU/߄_F-Kr~Ӹb^7\J]@egsB.Brjp_ \ГK9l5!o&:p-nYy^S# GQ|BQ+܎<ˎ69w* ^sd;)tMT|_HPͲ\Q>N_mp-}"m \yZVAW?*ܐ,6|p>w-7x,$k D\W^Goͮ{wRJ7 =ruXF'=YAsᕍ2||Sp>#Sdi*pYfBIw!@$ (OT_*.O_$]d@Wq'+Ȩ_f=hcˎ6WG[q]'x.` |]PSX{jXWFjIمc4+5__VXʾшg>d{܆ 6Ge~_2OuۊfwfZLegZR5٧*X# k /;$B"rxž ڮ+$- _*],Ԫ{4y]ŽtEν~*07V|= t{'[4ݣݰRr ,(=70jz׆1gV@FevVȻjPRtfʯHGo\|&CFQe;ǥc[~bڕr]^Mq~hto H> stream xڍxT6"J5 ޥw)!!$t^7JGTRU&MtϽ_VJ=~<nCaeBbDU=+1 IMXo;)9 G!eaq65C!1 ,edj 8'BB1ܪ( #Pv $@u*A bbDPn BO8 ` @</}+5RnzܠC\;uLuh(/_!+ݟ_ 0!HG  4tE^X! !0(\<Gp[4 ?0`788J;fu$D Eb1wq-.H' ~рE͐Pm?6G( @^`'_Lf_4 h@0(nPtsE*&X$wv k ` O ד NaoZ3C_NWX\ ,#I%o!gwQ Cd";xQߟ> g(qob!,{Go?_r# pzvfCC- wwo6e#NbE1p/(;#( ׽ˇ= nZM?#(ȯ@ޤ8V_1ܬB^%A?r#X& PayIQR{{P/(tn u~vV)6L`)yK9Pi?ݳҴx+*_;B!(fQ'Q+{Flքּa]땟_t`l\E'Ti,X܎mV\KATq4nfq*m1L߼W2?~|D@JE8-=ܡ~&{<NBp{}A mpEINv-ڭf~%є$TK w2W%&d`vԛDZ7? 63QL&Uq3)C;zf1~7@MkM>tKHY/f2hM`W>k~"(=sg+Q[Fgi?`Khڡ)w_Ifv3\2ߔzTw/]lr$n)[|ۧMwޏ_Q3OUrݨU}Qq[N *VA y*?hK=ȃ;^?˳TJX{~_k/^ZOi5e9C  -̬@mGM$n]oa GĬOnm7?h(ygd$V^Eߡ!O#E` EymkMԵ5'ݬi[jXEO 50I@ꍷ2fC`fHۋŇMVSo , u/Wěh.Ei1zM0 lv3N[d3TO9(h?q @I]#kыQ }I(l "s X}a`\٦5|8T``"Czɗ?oSNZetw +vl_c#ĚF a lrI׋eZy󅱟-t!'=Zr$)vզܔKɮ ڷR\[Cj&UcBl#5'R&I%;~lvXb]Y6s.=>=dP3R:a#j:~:,{.AvVHx2C޸{φx$N qq:)n+.%C=(faW4)'IKFށ"B C+ғ')®j=d1fKjoFƲJִW}sqr]d Nr Y!o+:] w~+MJ> >/0~v!@!MzƑٍ`F;FL3Ohkфe[Lӵ@!RXCP g\F깻-IA< 5ma㧥6D}JyiY3W.J4rJ)2r`='n̷\^̒sյ ՑNPiц΁6D%xieWLdV&`K`a>:M\aξUYv2o8z$o ٙiG,{Lv8Ԧc"'wc'FMڰTPfwqf7 !k, doDYz_#:Ybf?0U?g)Х3h. nyv;?49}yn[:otք1~mv0%!C 7KLMʫ)ͯ۱|k< /̈^[a@S(4Vԁ2qLK_$;ֽdTWm嵐9\Yt6͌ 7wda[GAĽW-Wd|F.`$_-F Di0uv{w̪}*EL"&O:(F@]H稸4_2|9"Z&:G3\8up'Wc,:[@̖"Xd::2gkL<ћ3Wr:h܆g}Bk]Q#5y7}/-bO:1\3ki^ DL'mǀ$ЇLmèmP&O{/g-3tI`=D'oEZ'zvK]p]!P^r\f0 AJ#? ɄT|=XWo˔^ew$񀒜|[敓u,uߛ7?|6 {2zvʴ-;#"ŽM[5xɅuѾ,n·&.t fn}4݆Eo=4 ?=𓿌43&d|-f_]K etD+ U s.V:"KK2J )Q2<,Hg/DpzBɜ:) BW]"PuJ5iAv[F*Ge ZI(7r|=VQJJj:NvQX\RNW 뉣#'UnVq(4mқ'uvbď=?e< :c -o6hpF &31XƋ0+7DD=z)=!7+uh>Lk*s\Uk,;ƩīwϲA)[%"E}{XžHK&em~F3ʀϗViszX")8Dss#ϟv3T\n͕ )^6s7l3Haׁ_l6[Yt5]dM PR^NYؕv$9[CF+>ι;;]J%PgxQZ+]jg6Y!O}Փ {1-ePpћ/;1cO|\\\lnoWaM߫ZU -ҔHR4aBSImZwė:q<>rw:s\VoG궳}`xhhzy2r JX*ğ;4 ;jI]Z.8ŷRe=[BUfĞ- ,z5U+/Yc tXcq}z)O)x&[q $槲(cNؚbbf,̕S<[J:ngsӠfaذ;˪Z/O~f̤.௙kUX]O6aOC⚄>^}Lo"e0p΋|Oj4 9[uF&:Ҵr8%SNхX5 pB ¾xW~~l]%+-6V~&ϐ~c[L& !ҧ\%Ҵ̙O 5[T"NN5uf jY7jmE2,L_;st6[Y]loG.{kDJ]`C=iΣz 3z6d-=n&Q_\r3ZT%mᒶbHF 3ʐ$q/$^EaVT :ْc{Yj gEW o&Hc'>r:c97k0IMh??V}Ty/U4ISLN$Ah298Y>.ⅺg4S\ࣈ@P$~Pi`uacŋWlѵf>dbӼUsM7e3*ɷ\Obx;I~,[dYh|IX :ϻJ)ibM+RSN>?{#OoV³(y/zȈ\L;0{;$"y2G͆ cHǣk벊]ؔ"3puri .CU!/wي)Gq~P ˸5mk T_%"ɀ9qm`*u& ?*MOh3#C0GZCucِRfgkd蜘9ݸ#9[xdo*%jCܑ\}[yvDПHosZ7)\ӫ*ξؚNi&afVݖ>AB/X֮jH{?K s%j/lcg=B§07:wk%/G]-d`i# lDCeKsYxQgq݄iҼkIh<8+ZY [ZI*F0UBܻ:+Ww7ߗ*0d"lq&` Ak9 DlיjgX:0CgA"jlvmß2zS <#墉ٙRZf= I1:)ݷiD[Q5MB@Գ:Ǖà;J㪺GM ^>ui4-d]!0 gOHK|xf/ͩČ9v(;z5%1JdpmG™\ApA,KUN5vb,>G%OXyPV1o추 <&Xįx|_3mZ>Hp$uh!T˔{0% ֽ>^6-}'B\?7mt)+eRiĻTaH>vխx]9Nyw9K2v=L?!h\m0]ʸ6H^#ODZ ,Ι2D\sMn%.zdJDJ]PWO%R݃QX=lA;hWe7IաIg=s՘$t5"^2W h{O L>LxT ˏEhu|G2o @'QtA柞N0͉7) EμI4hybpq'!,. aﯬKs(B\`y%kO.ޛrn{ꚳ#WnHodgOlѤq-Awdg&4WLG so@?WLJȗH-v9[] 룅GԬ)2b$+EuduBǫMLҼ5y6Zq< TEtlUnGtXEOO"iYPehg WkjDB/R+_%Ys?ٰ@! "C3{181}+ؓ#<6߳b5҅V"RJ-]Ok?[ LIp񊬀NbMfR}Ιd)dH"j (w8x endstream endobj 73 0 obj << /Length1 1537 /Length2 7852 /Length3 0 /Length 8875 /Filter /FlateDecode >> stream xڍuTk5;"\;$@pJ+Z[\[8\sw{WJޙ3gU`P/% @0a; PApLi _fKt#biڂ:Z;`׿J0ں: srzxxp;9`.6,l-@ (TRdhB`֮.`b RܠV`CwHVp\\)gBdsKK9 XC59eWOW69{7w78[<~9@NR`O~pK+qőWcZIPW8-݋CaP,k +7'N( gv@An!@ ; ~X~0}`矁[\\++lb] ~ `|'Y^SIYV?)'(%ع\\@:9C|;APk@?ڰAg0o_\%*~Ǚ?qsGן=> aC *`+GA;" y9;/?.[C\-m_xapȯ{! Y?-6}e0_+0wq1>茛V`pr@a)~k 8~[\m8pBa 86N?LnL^a0 x.0 1tsqy~K_ [bM,EBB[.j$)=7FyGb˒oiK^GJvLnF_~#.o#ڛ|͈&khAXc#ڃ+qo*@lHk{JL9mLeȋ2:=@gjFF'F mjlÏ%F'?۹[/cCdP>vR:OP2L0wɒ]'01[Dkjs('X}_%;)>zuta`.:Rt*5~I\7gB{\i-#ioVȪ0>Tuk93GnKM;̏^E ##)]eґ`P0O4y2[љiSm lRr֣ӥAZm(iA۶#;"Z_F-L8J+Jh5ődD67u0$E% FԨPrfRWfiǠRIA')t+"G8ј?֏/5 >Zzz* GHI A^mő׋r~ZlzMkcLL&X&h/ӞR4`hdoTTiЍ&k-ҪG X'~Ҿ)H,\({ΊGv7}lŏɩͤjU?0tT͕df c|6q:_ޒ+Y v8:uʂJ ^R|gT68 ֟ѹA(&H25 XG7?hHS1}{>z_N|,!7zT3k)Ad?9f5дpyiuSbyFn`˩̀1"q+/M*h& :(rp3⛷SeUA&Vt7{BsKPYSorGR'H/1Y<5"Ȉ? |V-̶axkA`dz[\~fTDXc5 (0Oeb4& 2w"B>+ PɗAX ϐN6ma$ʂ}{caP% ">b‘s~ƒ;WM: ?o 8V=QD"kD_L= yU1/xZTw!mPG)cR+"Yx%Gy,EE쟮nh_6c N|Dѕ(7p g+j y5]̻Ւ>ArZ&#Vu-([q'ԇxXo1&86 \Lr( 4HQW#9؏?jټۋ"BJɎ!~QT%)4:hOaj[2 wQҼΫ1*@pQ1Rnɑ&`ilɮ⬞YO%mqG}zz\*8$RT<~B-I@Prrz.'lH>_4o ir .]qmsȜ->ﶡIVxQ}5,MlDDobxyៈ8bghZH$XBnAL8(J胷+@ )'S1ӊE /@5$Qlh+̒2YchL[=xMX:ZOpxYӛAf)20nĶ*2 -PJ|aszGXڒ3cTҎwש1d,)gԢ}aRIRۥlucC?ө -tJ8u9Y'2YV)bU<%qmź҃bUekTs %h_ g&sƯ dpoACǞOW հr/(!)]y@i3̴# Bhmw{ 5W/QU/l˚奎 goŖh dS=G h;ڝ(p) 7syUvI!T3|/OAƵY{3O 58+'W\xh(7ON7R01H|fqq,#n0Vߋ$AR GoQMRk1#uG)8yMԮ͠HmkP4YX~'xrzh q_+oLzu[yh7jڢBB/l6=7Օ=.QI .tƏ?tP{nVg⼯V6W]kU5ˆ=oȡ*ySګDyleo鷴\JfMǜdV7G]a}'qP{ϲ򬩤|C2P=smBG$c]N-$#lTىȩZ4y>J?H-|[\Od. 1XQ.'Ɏg40PjJ.)m^ArAP|9KC8A첧v;N\ baLBA9TRj:t𳤅"AIà+u$uuD= l %K1E8Rc K ) D CwSir_.䪮UZ=g59 @6W!S[eARk~탶`'NH'.kҵOJ{jA34IA\`_Tc/wZ{*fL*zM$5cwLj,?"Ƞ P ~g,;*AR$SFY/O /%+iup#E)x7t9QƜ5R3Ҹ ࢴHy 竾=̜<X9}plZਫ3XۚCY 1Ox Llހ\qM@il$e|jW7gÃ) lGZv]QdSp\4pi4p[>&o/ -W:_u{);dXotKᥳGFzi,95 gxx(CWFMrHTЕBA˩o{8184!}甊j|P#1E+o }71fb}qԘÎˋQ,\ɨ84+}ڣv8ރ&os᷹K(n[h|Q+,zqۢV*ܤ]]BE?-SH_K:2c">QGM< ;?|}_T&<4ȷ++$BEg'ۢTOθ'h1O|^4<֍N9382pOh;>VHkktm67_t@Ց!y޸U^o*#(eZ 5> _j0Ufut:ky{03jO Wӗ h`=2jcPD@xAF[AM^P> }mL6I~߽ȹ_r*:;ifAӶꞙ6=VLOkRVDEbcD`|CtHTIɭ^AC[SUmN_P%&)6j[#6<:ߦpz5HFD d/t^iYm&˱&76~Ѐƣ.Azc2-!OUM(R= %xsL]GKSWfC>n(Pz'ٴyÙMnwZwG$b a:EMS=_ZFP'( 4?I}'+=g4IJCq_R4mcsN,qSOG$ ᡃ̩.!ЄјʤDCYeA1ˑĚd&EpG7Ѭk*7aa^>x}L*%zDyĜDj%oDž4NieE7 */Ȉ6?} o _d}vk0tP9\c׋h~]{}kRWXf@w,X|H&mX:b-_Zpӛ~,1Z мKRr| &5Q$LҀ~F \Ib6w)0kaa,vCѹ{ɘW;M7(!BN1}_Z(݃cv5Ԇg@T:ʋ!+;*P_,ҘlZJ~Q9J-{i,QRU_ VV zy Ifִ*oQ3$?=) ,xyp]kzKᓅVc"~{`m^%&] 'FbdOM [Uάߩc&kVfpgo(V_D0bhᒼZ9Sr!!3NPP\I]1Ttc緉(?tbC_CȂ mӝԱtuqؾolnE!a uo{Ө_;`&nq7m5lE~ztjHa9ʾȋDzd&x/fًL}̝"I dEwCE8TU53;D rX";d7Q$.ZڻJKPW᥏xi'usbvCv N9 )"$,ue Ɲe4Z z0cՒ4k#|&6ͅ!1:k[ p]D^ {Mu\rDYpӈtȳS~cX2"1>nELͦԵMpY;*$ȃ]{n5DoTH L3Ci$RFzN"Զ9pCKJtӞ [.'h@*Ղ3$%x5`Cfzpc $F{?} }AmDϊJ DoS{jfP6Q)Z8~Y7Sb&qu%ߝjDVF4SCdSp>liPswu,kZZM()2_uƕ,R 9z!^˳^j܊p"5sSW R> stream xڍTk %] 13tHt%"%] %99x߷Ykf׎{7CG&iAnl\iU.n'';''7*?9*K+BhɘA U!`/% !E c `+*4dcFK&_IG  P5w:B#Z;! (Emܜ98<==]!.6/X 7[.f4vT:-o6 @@+lt@UN@*i_9[ZB ˩yV \!Pssrshjrrsew97 Ͳ`+i#;? wo YVֿ˰rw݁2@EO2St,m9~v-qXCTWs  `tXm@`'vh7 ` ?.׿Lf;x?uj,RJ aqyB|[jKa'7'>E5 w a7:@sqZB߸?_.&7ߌ3m7w9xcfw7fBzYhrwZE7sHmm$UY51;( Ԁ~76.N=Nq_* tQl z|ssoTN|q|;jk`` qA}|ߢ?C 8 C 8dE'B'P|BO] A>!ht'/FxBO] Ak?!^|B\4H3@4wtnR^hС?9BM-_YBS/oSa|bx$8;Mja )Gh ml?,2+/J>;hl42 \hdV{TT"A2Mz07Z|9+,G:yދn~WcInYOA# E$:?թC\>o(|^?e1JdǜWBn]sIԀM6b_ʦe8D~ #W.wKPAa~-bD̏Y<'l%_0ϠӋS/?r'- 8(8 k'oވbGyɍ[fO;˸P3{ŘFhq>W8^JMӤx|9D/ǍM\8Wq2l1̴rczs/;qb]}/;IZα:"T?ffא#Zx]nq{5xzܮ-^*6c\ٸB"aZIZe. Xb7g,#򵗅v0 /2[J&1-Wmwn5:/yr2M#dGZ>Υ9P%>C׏~,A` mTC& 3rrV9i 5"^.n Pm),lDo"q;SlJ#In_V+:hJkΣ{+U*kcc 3X3hv@Nv)hF+'E#8~]*%zE9K42YL鷧o?GʈmLj& 䅣ױydngNkg_y\}b$DX ICa+M4N> f9}}T4 }"a FGn<ѧ扬K*ҲI9Q%zob9;#{`G֘l9ΤY5( ؑڢ'o!Տ].6Ho0yB.{w?UYO5=GK[EƊD*Gk]AzI-Œ[\ QA, Q9aƸ!WNG0n3/t{Y\ɍW_ ]f2<.VLك&tXM6;_f̆䖃W =H*;IB?Ϗt67c`A!#b@ Ȝ.<'+q |kt/K(;C}:N{Z]0eK rcD>G9zIhGͳϤY&Qc=XDLƋ 8x04ۛB6I22 VGah0/BMK7;*kezWSh%Ϻyl$WM,MfGʼnV1_3ڣc|ITAԮtpuwf:KCRYb&s"`0!$~((81RΣc}P%}ePk'tgg'M*0 MwiWEys$s`qUhRl_o $N'3U9uWy_ݾ(I7bdб7VI'oܫ4g@~>$|ߦ((11,JIng2S~kV a'- 榌O7f>$Z07H00u5Y,ѷ7ra @=ܩ4oc刘m= fjsaT|ҵZ)ml92QI+^ݡ6=\0z9`82oꀢiݗ6C؊ϴ?>mZM|^kqUC(^ѻv{(ݙv|ٯ丟&h/ٕta&\LJ+_=8]L1!Evy%_5I?|e,U ǽף/A$Eʨgѵ7[]n숸݅4n`جώ]fދ |e?$|527˯Pi ۭ2 8 T[U^2 q|5}܈)\Wu7Ԧ2v҉a<ML=o#OYuYYiҔ4 >ƜD>D; FҨ?=mC8˜Jo.cX&lݔO2%1̻IYY ag/DEщ=/1H:D_Ⲟ=LHl h^fIBiɋ9 ]Ŝӏ&ZiE{XR#?Don?Ňp&-Z"oZ*,ָBFfݝ붶z-g8?y3qd:0싍ܐI"eU /Xuү`:jMMo\33@=gۀ 7QzmJYh#WR"r!JX@#ѫRxWdũ<4ir(;sW>2+pISC9i /c}#d&$dl3 s5DZO!ekhK%tm6.KNRoiJaZ?=6\2|ؔ#X<:]}o.e:{޷X"0 \EBή+WF+3^!]\K45#E;sperpG:+RT/^hów|om y<,.O3ji!>h/Tõly<|p>!+gx3 ?-U/apѭ{/v\!x YC ^>ںU\tfzc{}e1O<1J ^~%,9;W/jYՈ _ #U?߾J5q 79:ebOtiyZ_0 'EeLpI@)eJĹqv_d] 4: t(~Æ&|m'){W;RE_Jv' (0\>1əKv7!坕!6>=b $H?wXWյ2 @:֗56jЋ?6(WL(9BCYl%‚NVJ GaoY:$R{XwcvR]Os\ۊG<B;J(CG5 ]+)CT(hU."lF4}@ALʭ4XqtaƠDMci{oL)]g$HJJd}PCXA9 `+X\<3)4܉ {'[6 LHZO^j63BN~,&x+I \؎uS|]fE [ǣ_f8i[s\gަk]1a%25ҦӮRq6 XǸ}.jPS,vv-ku VFzKWh>يf24&vò5pNLri4Oo%IwR+҉mb5,"dӥ_ғ;(wCw'\Btrw+iD%2돈p@[5~n=/Sr vMXٿAhEa OD@\@^mǶs1jqF)ņ+;Id7t 6da@f?hU)-D]ՔJL+9uBNNuH\ⰏkdrEXhFWT=d"LޱȖ c8-~6E`^m`OVIWT/)07Whn;nϘ лlm3 r >sE9*o9·RU 0vOs%㒔.A,*v-*9]쬟efUiˬ# (hDWXV5嫖4utᜅC~`ʘcm#`Ov^﯑$\QwK޻n(SP>(xJta+ =UB47>F#-rH`Ol,.lJY)AӌNt2muS]H5xqُ9sTj,zlrGTiQr i`T%7üŽJ]Wwb'e2?Q;I@̚'0Fl0>PZP9O/Ev*p.XN`]?궻z %sJ)nږf'=Ÿ/gRɕs8~Ukv@蚲 d3Z^~ޣnn00a~VO#ϡI 0h@/ WpbWaF/tBS+w`BF}-2l sŠHѸeL8/d:*Ԑ@[Si9<+^0Pl[6A GKf y iko4vڵ5+Àly[,~\KDvU$|+<)xޅe5i%zo ڶuvϣw ql},GH-]OAقeČ`}>DVE29\h<#'RHi(_&=S 8ӳ"~BbJ^1~, xAmy(ɊnRWYavshm5T9mԩX5MO4aÆ7=KvSf'U="gc0ߔ|0J)e!ML |.M+R3$qaJIX/1~~avn7&º~/M'1uq]QLffPXuoC1 8 S@>4ehZu-<3f-OMD-sP="Efkè 1 靑2&c'ݮӯձ9c_ KP|rh Ib!0ƍG7<]zZ+YL-4G'ruX⥥ b {r$x8ƱG뽾RNcðj=ʾb 4#L)Ss6%.I/L*1?m R]hYk5W-~Ij:a9^I!i٘=ǣƏiC*?; ֪1͎H1(pqn!kREMy3wHD4mt>.TJK^<}Ǫ/8ØAD;jdmlkc2CbZ"i~]}>ɋСg1 ߒj;qoԯ; Ft]+a6rLetGW%##d3:R X#1O 3e)Ik=w[%fC$nsS\E|o7[oH {7O\W1$Kl8/BuAF=_Վ t4٦ ̔x9;iVNȔgcrPļcBhbn*nfs@e蜋72۟-Rplc#"QSS {rV2H)J6$^B:lDLr(T,T l \@\[)LՍp)z jBHv(ϱQo L]Glf!R9#R 7}VSmC=} y@ . aUN W1H[Huϲ] ykh/I B#dbc0gj09$n;^ybO"QW_z&v]I.)=}~(t_.1΁E[߿KM5Ժ0L K"qr\KP-͜(Y-(4prO_U2Ț!g)2 [V>%|_YHKE 2eM½ TpmT4 h(oèʋtYwę*JHm"wC--)x39 xGSNcxT45vCwIrzSNV Yxd褂$=ro \[<e) (tأ(QL*X>a5#r:䟂T&IєBh*,3qGX9X/eA6X5Q.TI`ƈ3'gU \㎡rREV|:5-Y#vj I!EVh(2+^jIMN3=?x~sHZӧ&2 ͋,=LL1BSZ㎽|] rs=|O 1tMi`_ )N(i])[ L휒pɔ|(rHF Z䔴RG 64f>S{˳bA64.k"İSv`7(I%".I-!&~f؜ιd5} L9V͗ٝCu56AwV^/Kb#+x?)ymjh󰘿x)y\M9kب LaErטhjѝ }02niw͆H^ԧNHG9jϔ6^rS0pHm2:SwtҦśY_PXN:ϙsiܫ<,5•AvV]n7¬{NJR@o0s2<rBѿ CЧ>YDDRG1⫘\샤^}v@k*G2fxAK /%>}c 1|tEJ הP(d* qY }gȞ=CbJ긦,)]g8L7'WZ=G*ư3K{ i.=h'}u<@eNCp!ܷe>o` W>Dhg);玧k֓.q( Jn)iՔUEmtmGM*m ƽkKg-3V׿^U4*iI_OOQf]bňr+@zjXUu<$]̀1qeFًؒ6ݘ q3qQTuY*ٚs?PtMİsnGۘ8C܊̣29( endstream endobj 79 0 obj << /Producer (pdfTeX-1.40.14) /Creator (TeX) /CreationDate (D:20140509181836Z) /ModDate (D:20140509181836Z) /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.1415926-2.5-1.40.14 (TeX Live 2013/Debian) kpathsea version 6.1.1) >> endobj 8 0 obj << /Type /ObjStm /N 55 /First 418 /Length 1903 /Filter /FlateDecode >> stream xYn7}WEa~SՍ[ ?l䍭V\:!WJ+ŕ}( qyΜ9RbIɠLtYg0,YCȔbJ UGYgʰ,B̕62 J1[k4U y%Ӑw^tȊ7@!1hw! (I` [[g:,=@S 5:i)@cN32Gs*R𱁞pCD44y梀 yAZ0P 9 xh;yN*fpc|ΣG~d(;|o4I4B_f++1u(薝 th YZƘbǤ:٣GiUEh<v pO?)o'lu%jx [l JS8ܵmo@A4+BZJwց:Xj 6MjoR[@m]}!Vz/VV><5/pr9кMКj̳m+}*mBl-L読hO-.JԴ:x.4݀-Hx]&IV$Mi,ps=NHӎj=5Rj sI`"=| tc{sIiu[#ϜR8ߕ@0kz@#8ȰN\gNG֤]y;Tީ7k{\6K8IT z*:`<)޸=eqbT8ftkGY Bt6qy\"$냲qfpNfhlG{?WoIƐbLg.OO|sG7 xotuUs^K g1~/rw>W|ȇaG|_qSVhǼU-,[UGgRp.w^? _9!QCavAM/P|&_!zVMפV;(?MrmMÁ&A6LjjU?CǭR>O׎$޼=F k(KۋDл\#nǻ')V{"ۉHڿ{6dG/FeoteNR:AnQ~k]=jB3(uC*z?\VƗ%a6-m57MM{l45斗ߒmr[7sjsIjɶmfmrX2ZkZLwc]PqYb1<=͖L:;W<=r;Mh]&_٬9RG [W .:Y>D\ endstream endobj 80 0 obj << /Type /XRef /Index [0 81] /Size 81 /W [1 3 1] /Root 78 0 R /Info 79 0 R /ID [<2BAF1A88AAA0FCB4EF7D26DD72D47628> <2BAF1A88AAA0FCB4EF7D26DD72D47628>] /Length 233 /Filter /FlateDecode >> stream x%Ͻ.qsUJ)jѦK1Y!i ` ф+6RJn t}q pC1%BD[]L0-zk7gR$sFy$2"MtOe,qzsًsA $oX^ҹ*J$bM}ߟT_[$~|mSU#/'+ZM>|?kN endstream endobj startxref 104331 %%EOF gcl-2.6.14/xgcl-2/general-c.c0000644000175000017500000000364214360276512014075 0ustar cammcamm/* general-c.c Hiep Huu Nguyen 24 Jun 06 */ /* 27 Aug 92; 24 Jan 06; 22 Jun 06 */ /* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. */ /* 24 Jan 06: edited by G. Novak to remove vertex_array functions, remove includes, change function arg lists to new form */ /* 22 Jun 06: edited by G. Novak to be compatible with 64-bit machines */ #include #define fixnum long fixnum char_array(int size) { return ((fixnum) calloc (size, sizeof(char))); } char char_pos (char* array, int pos) { return (array[pos]); } void set_char_array (char* array, int pos, char val) { array[pos] = val; } fixnum int_array(int size) { return ((fixnum) calloc (size, sizeof(int))); } int int_pos (int* array, int pos) { return (array[pos]); } void set_int_array (int* array, int pos, int val) { array[pos] = val; } fixnum fixnum_array(int size) { return ((fixnum) calloc (size, sizeof(fixnum))); } fixnum fixnum_pos (fixnum* array, int pos) { return (array[pos]); } void set_fixnum_array (fixnum* array, int pos, fixnum val) { array[pos] = val; } gcl-2.6.14/xgcl-2/gcl_Xakcl.example.lsp0000644000175000017500000003054014360276512016132 0ustar cammcamm(in-package :XLIB) ; Xakcl.example.lsp Hiep Huu Nguyen 27 Aug 92 ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 1, or (at your option) ; any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ;;;;;;;;;;;;;;;;;;;;;; ;;this is an example of getting a geometry feature of a drawable there ;;is also XGetWindowAttributes for just windows. See reference manual ;;on X lib. it is probably more efficient to use XGetGeometry function ;;once when a lot of geometry information is needed since, XGetGeometry ;;returns many values. also as can be noticed, XGetGeometry needs C ;;Pointers, so it is best to allocate these pointers as globals so that ;;they won't have to be created and destroyed all the time, taking time ;;and fragmenting memory (defun drawable-height (a-drawable &key (display *default-display*)) (XGetGeometry display a-drawable *root-return* *x-return* *y-return* *width-return* *height-return* *border-width-return* *depth-return*) (int-pos *height-return* 0)) ;;;;;;;;;;;;;;;;;;;;;; ;;this function is a simple application of line drawing. it uses the ;;drawable-height function and the default globals like ;;*default-display* and *default-GC* (defun graph-x-y (info &key (test #'first) (scale 10) (displ 0) (invert t)) (let* ((info (sort info #'< :key test)) (first-x-y (first info)) (prev-x (* (first first-x-y) scale)) (mid-height ( / (drawable-height a-window) 2)) (prev-y (if invert (- mid-height (* (+ (second first-x-y) displ) scale)) (* (+ (second first-x-y) displ) scale)))) (print info) (dolist (next-x-y (rest info)) (let ((pres-x (* (first next-x-y) scale)) (pres-y (if invert (- mid-height (* (+ (second next-x-y) displ) scale)) (* (+ (second next-x-y) displ) scale)))) ;; (format t "~%prev-x : ~a prev-y: ~a pres-x: ~a pres-y: ~a" prev-x prev-y pres-x pres-y) (Xdrawline *default-display* a-window *default-GC* prev-x prev-y pres-x pres-y) (Xflush *default-display*) (setq prev-x pres-x) (setq prev-y pres-y))))) ;;;;;;;;;;;;;;;;;;;;;; ;; here's an example of getting values stored in a certain GC ;; the structure XGCValues contain values for a GC (defun get-foreground-of-gc (display GC) (XGetGCValues display GC (+ GCForeground) *GC-Values*) (XGCValues-foreground *GC-Values*)) ;;;;;;;;;;;;;;;;;;;;;; ;;this is an example of changing the graphics context and allocating a ;;color for drawing. this is also an example of setting the line ;;attributes this function changes the graphics context so becareful. ;;also notice that c-types Xcolor is created and freed. again it is ;;possible to make them global, because they could be used often. this ;;function was fixed to have no side effects. Side effects are a danger ;;with passing C structures. the structures could be changed as a side ;;effect if you're not careful (defun my-draw-line (&key (display *default-display*) (GC *default-GC*) x1 y1 x2 y2 (width 0) (color "BLACK") (line-style LineSolid) (cap-style CapRound) (join-style JoinRound) (colormap *default-colormap*) window) (let ((pixel-xcolor (make-Xcolor)) (exact-rgb (make-Xcolor)) (prev-fore-pixel (get-foreground-of-gc display GC))) (XSetLineAttributes display GC width line-style cap-style join-style) (XAllocNamedColor display colormap (get-c-string color) pixel-xcolor exact-rgb) (Xsetforeground display GC (Xcolor-pixel pixel-xcolor)) (XDrawLine display window GC x1 y1 x2 y2) (Xflush display) (free pixel-xcolor) (free exact-rgb) (XSetForeground display GC prev-fore-pixel))) (defun colors () (let ((pixel-xcolor (make-Xcolor)) (y 0) (r 0) (b 0) (g 0)) (dotimes (g 65535) ;; (format t "~% ~a ~a ~a" r b g) (set-Xcolor-red pixel-xcolor r) (set-Xcolor-blue pixel-xcolor b) (set-Xcolor-green pixel-xcolor g) (if (not (eql 0 (XallocColor *default-display* *default-colormap* pixel-xcolor))) (progn (Xsetforeground *default-display* *default-GC* (Xcolor-pixel pixel-xcolor)) (XDrawLine *default-display* a-window *default-GC* 0 0 200 y) (Xflush *default-display*) (incf y 1)) ;; (format t "~%error in reading color") )))) (defun return-r-b-g (color &key (display *default-display*) (GC *default-GC*) (colormap *default-colormap*) ) (let ((pixel-xcolor (make-Xcolor)) (exact-rgb (make-Xcolor))) (XAllocNamedColor display colormap (get-c-string color) pixel-xcolor pixel-xcolor) (format t "~% red: ~a blue: ~a green: ~a" (Xcolor-red pixel-xcolor) (Xcolor-blue pixel-xcolor) (Xcolor-green pixel-xcolor)))) ;;;;;;;;;;;;;;;;;;;;;; ;;this function tracks the mouse. when the mouse button is pressed a ;;line is drawn from the previous position to the current position. ;;this function also shows a way of handling exposure events. The ;;positions are remembered in order to redraw the contents of the window ;;when it is exposed. this function handles events in two windows, the ;;quit window and the draw window. there is an example of setting the ;;input for a window. the draw window can have button press events, ;;pointer motion events and exposure events, while the quit window ;;(button) only needs button press events, and exposure events. notice ;;that the event queue is actually flushed at the beginng of the ;;functions. There is also an example of drawing and inverting text. ;;and handling sub windows. the sub windows are destroyed at the end of ;;the function. (defun track-mouse (a-window) (Xsync *default-display* 1) ;; this clears the event queue so that previous ;; motion events won't show up (XClearWindow *default-display* a-window) ;; create two sub window (let ((quit-window (XCreateSimpleWindow *default-display* a-window 2 2 50 20 1 *black-pixel* *white-pixel*)) (draw-window (XCreateSimpleWindow *default-display* a-window 2 32 220 350 1 *black-pixel* *white-pixel*))) (Xselectinput *default-display* quit-window (+ ButtonpressMask ExposureMask)) (Xselectinput *default-display* draw-window (+ ButtonpressMask PointerMotionMask ExposureMask)) (XMapWindow *default-display* quit-window) (XMapWindow *default-display* draw-window) (Xflush *default-display* ) (XDrawString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) (Xflush *default-display* ) (do ((exit nil) (lines-list nil) (prev-x nil) (prev-y nil)) (exit) (XNextEvent *default-display* *default-event*) (let ((type (XAnyEvent-type *default-event*)) (active-window (XAnyevent-window *default-event*))) (cond ((eql draw-window active-window) (cond ;;; draw a line ((eql type ButtonPress) (let ((x (XButtonEvent-x *default-event*)) (y (XButtonEvent-y *default-event*))) (if prev-x (XDrawLine *default-display* draw-window *default-GC* prev-x prev-y x y)) (setq prev-x x) (setq prev-y y) (push (list x y) lines-list))) ;;; track the mouse ((eql type MotionNotify) (let ((x (XMotionEvent-x *default-event*)) (y (XMotionEvent-y *default-event*)) (time (XmotionEvent-time *default-event*))) ;;trace the mouse ;;(format t "~% pos-x: ~a pos-y: ~a" x y) ;;(format t "~%time: ~a" time) )) ;;;; redraw window after expose event ((eql type Expose) (let* ((first-xy (first lines-list)) (prev-x (first first-xy)) (prev-y (second first-xy))) (dolist (an-xy (rest lines-list)) (let ((x (first an-xy)) (y (second an-xy))) (XDrawLine *default-display* draw-window *default-GC* prev-x prev-y x y) (setq prev-x x) (setq prev-y y))))))) ;; exit if the quit button is pressed ((eql quit-window active-window) (cond ((eql type ButtonPress) (setq exit t) (XSetForeground *default-display* *default-GC* *white-pixel*) (XSetBackground *default-display* *default-GC* *black-pixel*) (XDrawImageString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) (Xflush *default-display*) ;;the drawing goes so fast that you can't see the text invert, so the ;;function wiats for for about .2 seconds. but it would be better to ;;keep the text inverted until the button is released this is done by ;;setting the quit window to have buton release events as well and ;;handling it appropriately (dotimes (i 1500)) (XSetForeground *default-display* *default-GC* *black-pixel*) (XSetBackground *default-display* *default-GC* *white-pixel*) (XDrawImageString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) (Xflush *default-display*)) ;; do quit window expose event ((eql type Expose) (XDrawString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4))))))) (XDestroySubWindows *default-display* a-window) (Xflush *default-display*))) ;;;;;;;;;;;;;;;;;;;;;; ;;this function demonstrtes using different fonts of text (defun basic-text (a-window &key (display *default-display*) (GC *default-GC* )) (my-load-font "9x15" :display display :GC GC) (Xdrawstring display a-window GC 50 100 (get-c-string "hello") 5) (my-load-font "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1" :display display :GC GC) (Xdrawstring display a-window GC 50 150 (get-c-string "hello") 5) (Xflush display)) ;;;;;;;;;;;;;;;;;;;;;; ;;this function demonstartes getting different fonts and setting them in a GC (defun my-load-font (a-string &key (display *default-display*) (GC *default-GC* )) (let ((font-info (XloadQueryFont display (get-c-string a-string)))) (if (not (eql 0 font-info)) (XsetFont display GC (Xfontstruct-fid font-info)) (format t "~%can't open font ~a" a-string)))) ;;;;;;;;;;;;;;;;;;;;;; ;;this function draws a ghst line by setting the X function to GXXor. and the ;;foreground color to th logxor of the back and foreground pixel ;;this function actually changes the graphics context. and does not change it back ;;to use the ghost method and switch back to regular drawing. set the function ;;back to GXcopy and the foregorund pixel appropriately (defun do-ghost-line-1 (a-window) (Xsync *default-display* 1);; this clears the event queue so that previous ;; motion events won't show up (XClearWindow *default-display* a-window) (XdrawRectangle *default-display* a-window *default-GC* 0 0 100 100) (Xdrawarc *default-display* a-window *default-GC* 100 200 100 100 0 (* 360 64)) (Xsetfunction *default-display* *default-GC* GXxor) (Xsetforeground *default-display* *default-GC* (logxor *black-pixel* *white-pixel*)) (Xselectinput *default-display* a-window PointerMotionMask ) (do ((exit nil) (prev-x 0) (prev-y 0)) (exit) (XNextEvent *default-display* *default-event*) (let ((type (XAnyEvent-type *default-event*))) (cond ;;draw ghost line ((eql type MotionNotify) (let ((x (XMotionEvent-x *default-event*)) (y (XMotionEvent-y *default-event*)) (time (XmotionEvent-time *default-event*))) (Xdrawline *default-display* a-window *default-GC* 0 0 prev-x prev-y) (Xdrawline *default-display* a-window *default-GC* 0 0 x y) (setq prev-x x) (setq prev-y y) )))))) ;;example of a circle ;;position 100 100 diameter 100 ;;(XdrawArc *default-display* a-window *default-GC* 100 100 100 100 0 (* 360 64)) ;;example of font ;;(XloadFont *default-display* (get-c-string "8x10")) ;; set a pixel ;;(XallocNamedColor *default-display* *default-colormap* (get-c-string "aquamarine") a b) gcl-2.6.14/xgcl-2/gcl_dwimports.lsp0000644000175000017500000001076114360276512015471 0ustar cammcamm; dwimports.lsp Gordon S. Novak Jr. 08 Sep 06 ; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. ; This file imports symbols of the XGCL package; these symbols may be ; needed by a more serious user of some of the XGCL functions. ; See the file gnu.license . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ; This file should be loaded immediately after starting Lisp: ; If Lisp has seen any of these symbols, loading this file will cause an error. (dolist (x '( xlib::picmenu-spec xlib::picmenu-button xlib::rgb xlib::menu-window xlib::flat xlib::parent-window xlib::parent-offset-x xlib::parent-offset-y xlib::picture-width xlib::picture-height xlib::title xlib::permanent xlib::menu-font xlib::item-width xlib::item-height xlib::items xlib::menuw xlib::title-present xlib::width xlib::height xlib::base-x xlib::base-y xlib::offset xlib::size xlib::region xlib::voffset xlib::vsize xlib::init xlib::init? xlib::contains? xlib::create xlib::clear xlib::select xlib::select! xlib::choose xlib::draw xlib::destroy xlib::moveto-xy xlib::reposition xlib::box-item xlib::unbox-item xlib::display-item xlib::item-value xlib::item-position xlib::find-item-width xlib::find-item-height xlib::adjust-offset xlib::calculate-size xlib::menu-x xlib::menu-y xlib::spec xlib::boxflg xlib::deleted-buttons xlib::draw-button xlib::delete-named-button xlib::drawing-width xlib::drawing-height xlib::buttons xlib::dotflg xlib::drawfn xlib::menu-font xlib::offset xlib::size xlib::highlightfn xlib::unhighlightfn xlib::containsxy? xlib::color xlib::value xlib::maxval xlib::barwidth xlib::horizontal xlib::subtrackfn xlib::subtrackparms xlib::update-value xlib::gcontext xlib::parent xlib::drawable-height xlib::drawable-width xlib::label xlib::font xlib::width xlib::height xlib::left xlib::right xlib::top-neg-y xlib::leftmargin xlib::rightmargin xlib::yposition xlib::wfunction xlib::foreground xlib::background xlib::force-output xlib::set-font xlib::set-foreground xlib::set-background xlib::set-cursor xlib::set-erase xlib::set-xor xlib::set-invert xlib::set-copy xlib::set-line-width xlib::set-line-attr xlib::std-line-attr xlib::unset xlib::reset xlib::sync xlib::geometry xlib::size xlib::get-geometry xlib::reset-geometry xlib::query-pointer xlib::wait-exposure xlib::wait-unmap xlib::clear xlib::mapw xlib::unmap xlib::destroy xlib::positive-y xlib::drawline xlib::draw-line xlib::draw-line-xy xlib::draw-latex-xy xlib::draw-arrow-xy xlib::draw-arrow2-xy xlib::draw-arrowhead-xy xlib::draw-box xlib::draw-box-xy xlib::draw-box-corners xlib::draw-rcbox-xy xlib::xor-box-xy xlib::draw-circle xlib::draw-circle-xy xlib::draw-ellipse-xy xlib::draw-arc-xy xlib::invertarea xlib::invert-area xlib::invert-area-xy xlib::copy-area-xy xlib::printat xlib::printat-xy xlib::prettyprintat-xy xlib::prettyprintat xlib::string-width xlib::string-extents xlib::erase-area xlib::erase-area-xy xlib::erase-box-xy xlib::moveto-xy xlib::move xlib::paint xlib::centeroffset xlib::draw-border xlib::track-mouse xlib::track-mouse-in-region xlib::init-mouse-poll xlib::poll-mouse xlib::get-point xlib::get-click xlib::get-line-position xlib::get-latex-position xlib::get-icon-position xlib::get-box-position xlib::get-box-size xlib::get-region xlib::adjust-box-side xlib::get-mouse-position xlib::get-circle xlib::get-ellipse xlib::get-crosshairs xlib::draw-crosshairs-xy xlib::get-cross xlib::draw-cross-xy xlib::draw-dot-xy xlib::draw-vector-pt xlib::get-vector-end xlib::reset-color xlib::set-color-rgb xlib::set-color xlib::set-xcolor xlib::free-color xlib::get-chars xlib::input-string xlib::courier-bold-12 xlib::8x10 xlib::9x15 xlib::center xlib::top xlib::bottom xlib::xor xlib::erase xlib::copy xlib::buttonname )) (import x)) gcl-2.6.14/xgcl-2/gcl_dwindow.lsp0000644000175000017500000033534114360276512015120 0ustar cammcamm; dwindow.lsp Gordon S. Novak Jr. ; 13 Jan 10 ; Window types and interface functions for using X windows from GNU Common Lisp ; Copyright (c) 2010 Gordon S. Novak Jr. and The University of Texas at Austin. ; 08 Jan 97; 17 May 02; 17 May 04; 18 May 04; 01 Jun 04; 18 Aug 04; 21 Jan 06 ; 24 Jan 06; 24 Jun 06; 25 Jun 06; 17 Jul 06; 23 Aug 06; 08 Sep 06; 21 May 09 ; 28 Aug 09; 31 Aug 09; 28 Oct 09; 07 Nov 09; 12 Jan 10 ; See the files gnu.license and dec.copyright . ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; Some of the files that interface to the Xlib are adapted from DEC/MIT files. ; See the file dec.copyright for details. ; Written by: Gordon S. Novak Jr., Department of Computer Sciences, ; University of Texas at Austin 78712. novak@cs.utexas.edu ; These functions use the convention that positive y is upwards, ; (0 0) is the lower-left corner of a window. ; derived from {DSK}DWINDOW.CL;1 1-Mar-89 13:16:20 ; Modified for AKCL/X using Hiep Huu Nguyen's interfaces from AKCL -> C -> X. ; Parts of Nguyen's file Xinit.lsp are included. (defvar *window-add-menu-title* nil) ; t to add title bar within menu area (defvar *window-menu* nil) (defvar *mouse-x* nil) (defvar *mouse-y* nil) (defvar *mouse-window* nil) (defvar *window-fonts* (list (list 'courier-bold-12 "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1") (list 'courier-medium-12 "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1") (list '6x12 "6x12") (list '8x13 "8x13") (list '9x15 "9x15"))) (glispglobals (*window-menu* menu) (*mouse-x* integer) (*mouse-y* integer) (*mouse-window* window) (*picmenu-no-selection* picmenu-button) ) (defvar *window-display* nil) (defvar *window-screen* nil) (defvar *root-window*) (defvar *black-pixel*) (defvar *white-pixel*) (defvar *default-fg-color*) (defvar *default-bg-color*) (defvar *default-size-hints*) (defvar *default-GC*) (defvar *default-colormap*) (defvar *window-event*) (defvar *window-default-pos-x* 10) (defvar *window-default-pos-y* 20) (defvar *window-default-border* 1) (defvar *window-default-font-name* 'courier-bold-12) (defvar *window-default-cursor* 68) (defvar *window-save-foreground*) (defvar *window-save-function*) (defvar *window-attributes*) (defvar *window-attr*) (defvar *menu-title-pad* 30) ; extra space for title bar of menu ; The following -return globals are used in calls to Xlib ; routines. ; Where the Xlib parameter is int*, the parameter must be ; initialized to (int-array 1) and is accessed with ; (int-pos param 0). ; The following X types are CARD32: (from Xproto.h) ; Window Drawable Font Pixmap Cursor Colormap GContext ; Atom VisualID Time KeySym ; KeyCode = CARD8 (defvar *root-return* (fixnum-array 1)) (defvar *child-return* (fixnum-array 1)) (defvar *root-x-return* (int-array 1)) (defvar *root-y-return* (int-array 1)) (defvar *win-x-return* (int-array 1)) (defvar *win-y-return* (int-array 1)) (defvar *mask-return* (int-array 1)) (defvar *x-return* (int-array 1)) (defvar *y-return* (int-array 1)) (defvar *width-return* (int-array 1)) (defvar *height-return* (int-array 1)) (defvar *depth-return* (int-array 1)) (defvar *border-width-return* (int-array 1)) (defvar *text-width-return* (int-array 1)) (defvar *direction-return* (int-array 1)) (defvar *ascent-return* (int-array 1)) (defvar *descent-return* (int-array 1)) (defvar *overall-return* (int-array 1)) (defvar *GC-Values*) (defvar *window-xcolor* nil) (defvar *window-menu-code* nil) (defvar *window-keymap* (make-array 256)) (defvar *window-shiftkeymap* (make-array 256)) (defvar *window-keyinit* nil) (defvar *window-meta*) ; set if meta down when char is pressed (defvar *window-ctrl*) ; set if ctrl down when char is pressed (defvar *window-shift*) ; set if shift down when char is pressed (defvar *window-shift-keys* nil) (defvar *window-control-keys* nil) (defvar *window-meta-keys* nil) (defvar *min-keycodes-return* (int-array 1)) (defvar *max-keycodes-return* (int-array 1)) (defvar *keycodes-return* (int-array 1)) (setq *window-keyinit* nil) (defmacro picmenu-spec (symbol) `(get ,symbol 'picmenu-spec)) (glispobjects (drawable anything) (menu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (menu-font symbol) (item-width integer) (items (listof symbol)) ) prop ((menuw (menu-window or (menu-init self)) result window) (title-present (title and ((length title) > 0))) (width (picture-width)) (height (picture-height)) (base-x ((if flat parent-offset-x 0))) (base-y ((if flat parent-offset-y 0))) (offset menu-offset) (size menu-size) (region ((virtual region with start = voffset size = vsize))) (voffset ((virtual vector with x = base-x y = base-y))) (vsize ((virtual vector with x = picture-width y = picture-height))) ) msg ((init menu-init) (init? ((menu-window and (picture-height > 0)) or (init self))) (contains? (glambda (m p) (contains? (region m) p))) (create menu-create result menu) (clear menu-clear) (select menu-select) (select! menu-select!) (choose menu-choose) (draw menu-draw) (destroy menu-destroy) (moveto-xy menu-moveto-xy) (reposition menu-reposition) (reposition-line menu-reposition-line) (box-item menu-box-item) (unbox-item menu-box-item) ; same since it uses xor (display-item menu-display-item) (item-value menu-item-value open t) (item-position menu-item-position result vector) (find-item-width menu-find-item-width) (find-item-height menu-find-item-height) (adjust-offset menu-adjust-offset) (calculate-size menu-calculate-size) (menu-x (glambda (m x) ((base-x m) + x))) (menu-y (glambda (m y) ((base-y m) + y))) ) ) ; picture menu: a drawn object with "hot buttons" at certain points. ; note: the first 10 data items of picmenu must be the same as in menu. (picmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (spec (transparent picmenu-spec)) (boxflg boolean) (deleted-buttons (listof symbol)) (button-colors (listof (list (name symbol) (color rgb)))) ) prop ((menuw (menu-window or (picmenu-init self)) result window) ) msg ((init picmenu-init) (init? ((menu-window and (picture-height > 0)) or (init self))) (create picmenu-create result picmenu) (select picmenu-select) (draw picmenu-draw) (draw-button picmenu-draw-button) (draw-named-button picmenu-draw-named-button) (set-named-button-color picmenu-set-named-button-color) (delete-named-button picmenu-delete-named-button) (box-item picmenu-box-item) (unbox-item picmenu-unbox-item) (calculate-size picmenu-calculate-size) (item-position picmenu-item-position result vector) ) supers (menu) ) (picmenu-spec (listobject (drawing-width integer) (drawing-height integer) (buttons (listof picmenu-button)) (dotflg boolean) (drawfn anything) (menu-font symbol) )) (picmenu-button (list (buttonname symbol) (offset vector) (size vector) (highlightfn anything) (unhighlightfn anything)) msg ((containsxy? picmenu-button-containsxy?)) ) (barmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (color rgb) (value integer) (maxval integer) (barwidth integer) (horizontal boolean) (subtrackfn anything) (subtrackparms (listof anything))) prop ((menuw (menu-window or (barmenu-init self)) result window) (picture-width ((if (horizontal m) (maxval m) (barwidth m)) )) (picture-height ((if (horizontal m) (barwidth m) (maxval m)) )) ) msg ((init barmenu-init) (init? ((menu-window and (picture-height > 0)) or (init self))) (create barmenu-create result barmenu) (select barmenu-select) (draw barmenu-draw) (update-value barmenu-update-value) (calculate-size barmenu-calculate-size) ) supers (menu)) ; Note: data through 'permanent' must be same as in menu. (textmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (text string) (drawing-width integer) (drawing-height integer) (boxflg boolean) (menu-font symbol) ) prop ((menuw (menu-window or (textmenu-init self)) result window) ) msg ((init textmenu-init) (init? ((menu-window and (picture-height > 0)) or (init self))) (create textmenu-create result textmenu) (select textmenu-select) (draw textmenu-draw) (calculate-size textmenu-calculate-size) (set-text textmenu-set-text open t) ) supers (menu) ) ; Note: data through 'permanent' must be same as in menu. (editmenu (listobject (menu-window window) (flat boolean) (parent-window drawable) (parent-offset-x integer) (parent-offset-y integer) (picture-width integer) (picture-height integer) (title string) (permanent boolean) (text (listof string)) (drawing-width integer) (drawing-height integer) (boxflg boolean) (menu-font symbol) (column integer) (line integer) (scrollval integer) ) prop ((menuw (menu-window or (editmenu-init self)) result window) (scroll ((if (numberp scrollval) scrollval 0))) ) msg ((init editmenu-init) (init? ((menu-window and (picture-height > 0)) or (init self))) (create editmenu-create result editmenu) (select editmenu-select) (draw editmenu-draw) (edit editmenu-edit) (carat editmenu-carat) (display editmenu-display) (calculate-size editmenu-calculate-size) (line-y editmenu-line-y open t) ) supers (menu) ) (window (listobject (parent drawable) (gcontext anything) (drawable-height integer) (drawable-width integer) (label string) (font anything) ) default ((self nil)) prop ((width (drawable-width)) (height (drawable-height)) (left window-left open t result integer) (right (left + width)) (top-neg-y window-top-neg-y open t result integer) (leftmargin (1)) (rightmargin (width - 1)) (yposition window-yposition result integer open t) (wfunction window-wfunction open t) (foreground window-foreground open t) (background window-background open t) (font-width ((string-width self "W"))) (font-height ((string-height self "Tg"))) ) msg ((force-output window-force-output open t) (set-font window-set-font) (set-foreground window-set-foreground open t) (set-background window-set-background open t) (set-cursor window-set-cursor open t) (set-erase window-set-erase open t) (set-xor window-set-xor open t) (set-invert window-set-invert open t) (set-copy window-set-copy open t) (set-line-width window-set-line-width open t) (set-line-attr window-set-line-attr open t) (std-line-attr window-std-line-attr open t) (unset window-unset open t) (reset window-reset open t) (sync window-sync open t) (geometry window-geometry open t) (size window-size) (get-geometry window-get-geometry open t) (reset-geometry window-reset-geometry open t) (query-pointer window-query-pointer open t) (wait-exposure window-wait-exposure) (wait-unmap window-wait-unmap) (clear window-clear open t) (mapw window-map open t) (unmap window-unmap open t) (open window-open open t) (close window-close open t) (destroy window-destroy open t) (positive-y window-positive-y open t) (drawline window-draw-line open t) (draw-line window-draw-line open t) (draw-line-xy window-draw-line-xy open t) (draw-latex-xy window-draw-latex-xy) (draw-arrow-xy window-draw-arrow-xy ) (draw-arrow2-xy window-draw-arrow2-xy ) (draw-arrowhead-xy window-draw-arrowhead-xy ) (draw-box window-draw-box open t) (draw-box-xy window-draw-box-xy) (draw-box-corners window-draw-box-corners open t) (draw-rcbox-xy window-draw-rcbox-xy) (draw-box-line-xy window-draw-box-line-xy) (xor-box-xy window-xor-box-xy open t) (draw-circle window-draw-circle open t) (draw-circle-xy window-draw-circle-xy open t) (draw-ellipse-xy window-draw-ellipse-xy open t) (draw-arc-xy window-draw-arc-xy open t) (invertarea window-invertarea open t) (invert-area window-invert-area open t) (invert-area-xy window-invert-area-xy open t) (copy-area-xy window-copy-area-xy open t) (printat window-printat open t) (printat-xy window-printat-xy open t) (print-line window-print-line) (print-lines window-print-lines) (prettyprintat window-prettyprintat open t) (prettyprintat-xy window-prettyprintat-xy open t) (string-width window-string-width open t) (string-extents window-string-extents open t) (erase-area window-erase-area open t) (erase-area-xy window-erase-area-xy open t) (erase-box-xy window-erase-box-xy open t) (moveto-xy window-moveto-xy) (move window-move) (paint window-paint) (centeroffset window-centeroffset open t) (draw-border window-draw-border open t) (track-mouse window-track-mouse) (track-mouse-in-region window-track-mouse-in-region) (init-mouse-poll window-init-mouse-poll) (poll-mouse window-poll-mouse) (get-point window-get-point) (get-click window-get-click) (get-line-position window-get-line-position) (get-latex-position window-get-latex-position) (get-icon-position window-get-icon-position) (get-box-position window-get-box-position) (get-box-line-position window-get-box-line-position) (get-box-size window-get-box-size) (get-region window-get-region) (adjust-box-side window-adjust-box-side) (get-mouse-position window-get-mouse-position) (get-circle window-get-circle) (get-ellipse window-get-ellipse) (get-crosshairs window-get-crosshairs) (draw-crosshairs-xy window-draw-crosshairs-xy) (get-cross window-get-cross) (draw-cross-xy window-draw-cross-xy) (draw-dot-xy window-draw-dot-xy) (draw-vector-pt window-draw-vector-pt) (get-vector-end window-get-vector-end) (reset-color window-reset-color) (set-color-rgb window-set-color-rgb) (set-color window-set-color) (set-xcolor window-set-xcolor) (free-color window-free-color) (get-chars window-get-chars) (input-string window-input-string) (string-width window-string-width) (string-extents window-string-extents) (string-height window-string-height) (draw-carat window-draw-carat) )) (rgb (list (red integer) (green integer) (blue integer))) ) ; glispobjects (glispconstants ; used by GEV (windowcharwidth 9 integer) (windowlineyspacing 17 integer) ) (defvar *picmenu-no-selection* '(no-selection (0 0) (0 0) nil nil)) ; 14 Mar 95 ; Make something into a string. ; The copy-seq avoids an error with get-c-string on Sun. (defun stringify (x) (cond ((stringp x) x) ((symbolp x) (copy-seq (symbol-name x))) (t (princ-to-string x)))) ; 24 Jun 06 ; This function initializes variables needed by most applications. ; It uses all defaults inherited from the root window, and screen. ; H. Nguyen (defun window-Xinit () (setq *window-display* (XOpenDisplay (get-c-string ""))) (if (or (not (numberp *window-display*)) ; 22 Jun 06 (< *window-display* 10000)) (error "DISPLAY did not open: return value ~A~%" *window-display*)) (setq *window-screen* (XdefaultScreen *window-display*)) (setq *root-window* (XRootWindow *window-display* *window-screen*)) (setq *black-pixel* (XBlackPixel *window-display* *window-screen*)) (setq *white-pixel* (XWhitePixel *window-display* *window-screen*)) (setq *default-fg-color* *black-pixel*) (setq *default-bg-color* *white-pixel*) (setq *default-GC* (XDefaultGC *window-display* *window-screen*)) (setq *default-colormap* (XDefaultColormap *window-display* *window-screen*)) (setq *window-attributes* (make-XsetWindowAttributes)) (set-XsetWindowAttributes-backing_store *window-attributes* WhenMapped) (set-XsetWindowAttributes-save_under *window-attributes* 1) ; True (setq *window-attr* (make-XWindowAttributes)) (Xflush *window-display*) (setq *default-size-hints* (make-XsizeHints)) (setq *window-event* (make-XEvent)) (setq *GC-Values* (make-XGCValues)) ) (defun window-get-mouse-position () (XQueryPointer *window-display* *root-window* *root-return* *child-return* *root-x-return* *root-y-return* *win-x-return* *win-y-return* *mask-return*) (setq *mouse-x* (int-pos *root-x-return* 0)) (setq *mouse-y* (int-pos *root-y-return* 0)) (setq *mouse-window* (fixnum-pos *child-return* 0)) ) ; 22 Jun 06 ; 13 Aug 91; 14 Aug 91; 06 Sep 91; 12 Sep 91; 06 Dec 91; 01 May 92; 01 Sep 92 ; 08 Sep 06 (setf (glfnresulttype 'window-create) 'window) (gldefun window-create (width height &optional str parentw pos-x pos-y font) (let (w pw fg-color bg-color (null 0)) (or *window-display* (window-Xinit)) (setq fg-color *default-fg-color*) (setq bg-color *default-bg-color*) (unless pos-x (pos-x = *window-default-pos-x*)) (unless pos-y (pos-y = *window-default-pos-y*)) (w = (a window with drawable-width = width drawable-height = height label = (if str (stringify str) " ") )) (pw = (or parentw *root-window*)) (window-get-geometry-b pw) ((parent w) = (XCreateSimpleWindow *window-display* pw pos-x ((int-pos *height-return* 0) - pos-y - height) width height *window-default-border* fg-color bg-color)) (set-xsizehints-x *default-size-hints* pos-x) (set-xsizehints-y *default-size-hints* pos-y) (set-xsizehints-width *default-size-hints* (width w)) (set-xsizehints-height *default-size-hints* (height w)) (set-xsizehints-flags *default-size-hints* (+ Psize Pposition)) (XsetStandardProperties *window-display* (parent w) (get-c-string (label w)) (get-c-string (label w)) ; icon name none null null *default-size-hints*) ((gcontext w) = (XCreateGC *window-display* (parent w) 0 null)) (set-foreground w fg-color) (set-background w bg-color) (set-font w (or font *window-default-font-name*)) (set-cursor w *window-default-cursor*) (set-line-width w 1) (XChangeWindowAttributes *window-display* (parent w) (+ CWSaveUnder CWBackingStore) *window-attributes*) (Xselectinput *window-display* (parent w) (+ leavewindowmask buttonpressmask buttonreleasemask pointermotionmask exposuremask)) (open w) w )) ; 06 Aug 91; 17 May 04 ; Set the font for a window to the one specified by fontsymbol. ; derived from Nguyen's my-load-font. (gldefun window-set-font ((w window) (fontsymbol symbol)) (let (fontstring font-info (display *window-display*)) (fontstring = (or (cadr (assoc fontsymbol *window-fonts*)) (stringify fontsymbol))) (font-info = (XloadQueryFont display (get-c-string fontstring))) (if (eql 0 font-info) (format t "~%can't open font ~a ~a~%" fontsymbol fontstring) (progn (XsetFont display (gcontext w) (Xfontstruct-fid font-info)) ((font w) = font-info)) ) )) ; 15 Oct 91 (defun window-font-info (fontsymbol) (XloadQueryFont *window-display* (get-c-string (or (cadr (assoc fontsymbol *window-fonts*)) (stringify fontsymbol))))) ; Functions to allow access to window properties from plain Lisp (gldefun window-gcontext ((w window)) (gcontext w)) (gldefun window-parent ((w window)) (parent w)) (gldefun window-drawable-height ((w window)) (drawable-height w)) (gldefun window-drawable-width ((w window)) (drawable-width w)) (gldefun window-label ((w window)) (label w)) (gldefun window-font ((w window)) (font w)) ; 07 Aug 91; 14 Aug 91 (gldefun window-foreground ((w window)) (XGetGCValues *window-display* (gcontext w) GCForeground *GC-Values*) (XGCValues-foreground *GC-Values*) ) (gldefun window-set-foreground ((w window) (fg-color integer)) (XsetForeground *window-display* (gcontext w) fg-color)) (gldefun window-background ((w window)) (XGetGCValues *window-display* (gcontext w) GCBackground *GC-Values*) (XGCValues-Background *GC-Values*) ) (gldefun window-set-background ((w window) (bg-color integer)) (XsetBackground *window-display* (gcontext w) bg-color)) ; 08 Aug 91 (gldefun window-wfunction ((w window)) (XGetGCValues *window-display* (gcontext w) GCFunction *GC-Values*) (XGCValues-function *GC-Values*) ) ; 08 Aug 91 ; Get the geometry parameters of a window into global variables (gldefun window-get-geometry ((w window)) (window-get-geometry-b (parent w))) ; 06 Dec 91 ; Set cursor to a selected cursor number (gldefun window-set-cursor ((w window) (n integer)) (let (c) (c = (XCreateFontCursor *window-display* n) ) (XDefineCursor *window-display* (parent w) c) )) (defun window-get-geometry-b (w) (XGetGeometry *window-display* w *root-return* *x-return* *y-return* *width-return* *height-return* *border-width-return* *depth-return*) ) ; 15 Aug 91 ; clear event queue of previous motion events (gldefun window-sync ((w window)) (Xsync *window-display* 1) ) ; 03 Oct 91; 06 Oct 94 (gldefun window-screen-height () (window-get-geometry-b *root-window*) (int-pos *height-return* 0) ) ; 08 Aug 91; 12 Sep 91; 28 Oct 91 ; Make a list of window geometry, (x y width height border-width). (gldefun window-geometry ((w window)) (let (sh) (sh = (window-screen-height)) (get-geometry w) ((drawable-width w) = (int-pos *width-return* 0)) ((drawable-height w) = (int-pos *height-return* 0)) (list (int-pos *x-return* 0) (sh - (int-pos *y-return* 0) - (int-pos *height-return* 0)) (int-pos *width-return* 0) (int-pos *height-return* 0) (int-pos *border-width-return* 0)) )) ; 27 Nov 91 (gldefun window-size ((w window)) (result vector) (get-geometry w) (list ((drawable-width w) = (int-pos *width-return* 0)) ((drawable-height w) = (int-pos *height-return* 0)) ) ) (gldefun window-left ((w window)) (get-geometry w) (int-pos *x-return* 0)) ; Get top of window in X (y increasing downwards) coordinates. (gldefun window-top-neg-y ((w window)) (get-geometry w) (int-pos *y-return* 0)) ; 08 Aug 91 ; Reset the local geometry parameters of a window from its X values. ; Needed, for example, if the user resizes the window by mouse command. (gldefun window-reset-geometry ((w window)) (get-geometry w) ((drawable-width w) = (int-pos *width-return* 0)) ((drawable-height w) = (int-pos *height-return* 0)) ) (gldefun window-force-output (&optional (w window)) (Xflush *window-display*)) (gldefun window-query-pointer ((w window)) (window-query-pointer-b (parent w)) ) (defun window-query-pointer-b (w) (XQueryPointer *window-display* w *root-return* *child-return* *root-x-return* *root-y-return* *win-x-return* *win-y-return* *mask-return*) ) (gldefun window-positive-y ((w window) (y integer)) ((height w) - y)) ; 08 Aug 91 ; Set parameters of a window for drawing by XOR, saving old values. (gldefun window-set-xor ((w window)) (let ((gc (gcontext w)) ) (setq *window-save-function* (wfunction w)) (XsetFunction *window-display* gc GXxor) (setq *window-save-foreground* (foreground w)) (XsetForeground *window-display* gc (logxor *window-save-foreground* (background w))) )) ; 08 Aug 91 ; Reset parameters of a window after change, using saved values. (gldefun window-unset ((w window)) (let ((gc (gcontext w)) ) (XsetFunction *window-display* gc *window-save-function*) (XsetForeground *window-display* gc *window-save-foreground*) )) ; 04 Sep 91 ; Reset parameters of a window, using default values. (gldefun window-reset ((w window)) (let ((gc (gcontext w)) ) (XsetFunction *window-display* gc GXcopy) (XsetForeground *window-display* gc *default-fg-color*) (XsetBackground *window-display* gc *default-bg-color*) )) ; 09 Aug 91; 03 Sep 92 ; Set parameters of a window for erasing, saving old values. (gldefun window-set-erase ((w window)) (let ((gc (gcontext w)) ) (setq *window-save-function* (wfunction w)) (XsetFunction *window-display* gc GXcopy) (setq *window-save-foreground* (foreground w)) (XsetForeground *window-display* gc (background w)) )) (gldefun window-set-copy ((w window)) (let ((gc (gcontext w)) ) (setq *window-save-function* (wfunction w)) (XsetFunction *window-display* gc GXcopy) (setq *window-save-foreground* (foreground w)) )) ; 12 Aug 91 ; Set parameters of a window for inversion, saving old values. (gldefun window-set-invert ((w window)) (let ((gc (gcontext w)) ) (setq *window-save-function* (wfunction w)) (XsetFunction *window-display* gc GXxor) (setq *window-save-foreground* (foreground w)) (XsetForeground *window-display* gc (logxor *window-save-foreground* (background w))) )) ; 13 Aug 91 (gldefun window-set-line-width ((w window) (width integer)) (set-line-attr w width nil nil nil)) ; 13 Aug 91; 12 Sep 91 (gldefun window-set-line-attr (w\:window width &optional line-style cap-style join-style) (XsetLineAttributes *window-display* (gcontext w) (or width 1) (or line-style LineSolid) (or cap-style CapButt) (or join-style JoinMiter) ) ) ; 13 Aug 91 ; Set standard line attributes (gldefun window-std-line-attr ((w window)) (XsetLineAttributes *window-display* (gcontext w) 1 LineSolid CapButt JoinMiter) ) ; 06 Aug 91; 08 Aug 91; 12 Sep 91 (gldefun window-draw-line ((w window) (from vector) (to vector) &optional linewidth) (window-draw-line-xy w (x from) (y from) (x to) (y to) linewidth) ) ; 19 Dec 90; 07 Aug 91; 08 Aug 91; 09 Aug 91; 13 Aug 91; 12 Sep 91; 28 Sep 94 (gldefun window-draw-line-xy ((w window) (fromx integer) (fromy integer) (tox integer) (toy integer) &optional linewidth (operation atom)) (let ( (qqwheight (drawable-height w)) ) (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) (case operation (xor (set-xor w)) (erase (set-erase w)) (t nil)) (XDrawLine *window-display* (parent w) (gcontext w) fromx (- qqwheight fromy) tox (- qqwheight toy) ) (case operation ((xor erase) (unset w)) (t nil)) (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )) ; 09 Oct 91 (defun window-draw-arrowhead-xy (w x1 y1 x2 y2 &optional (linewidth 1) size) (let (th theta ysth ycth (y2dela 0) (y2delb 0) (x2dela 0) (x2delb 0)) (or size (setq size (+ 20 (* linewidth 5)))) (setq th (atan (- y2 y1) (- x2 x1))) (setq theta (* th (/ 180.0 pi))) (setq ysth (round (* (1+ size) (sin th)))) (setq ycth (round (* (1+ size) (cos th)))) (if (and (eql y1 y2) (evenp linewidth)) ; correct for even-size lines (if (> x2 x1) (setq y2delb 1) (setq y2dela 1))) (if (and (eql x1 x2) (evenp linewidth)) ; correct for even-size lines (if (> y2 y1) (setq x2delb 1) (setq x2dela 1))) (window-draw-arc-xy w (- (- x2 ysth) x2dela) (+ (+ y2 ycth) y2dela) size size (+ 240 theta) 30 linewidth) (window-draw-arc-xy w (- (+ x2 ysth) x2delb) (+ (- y2 ycth) y2delb) size size (+ 90 theta) 30 linewidth) )) (defun window-draw-arrow-xy (w x1 y1 x2 y2 &optional (linewidth 1) size) (window-draw-line-xy w x1 y1 x2 y2 linewidth) (window-draw-arrowhead-xy w x1 y1 x2 y2 linewidth size) ) (defun window-draw-arrow2-xy (w x1 y1 x2 y2 &optional (linewidth 1) size) (window-draw-line-xy w x1 y1 x2 y2 linewidth) (window-draw-arrowhead-xy w x1 y1 x2 y2 linewidth size) (window-draw-arrowhead-xy w x2 y2 x1 y1 linewidth size) ) ; 08 Aug 91; 14 Aug 91; 12 Sep 91 (gldefun window-draw-box ((w window) (offset vector) (size vector) &optional linewidth) (window-draw-box-xy w (x offset) (y offset) (x size) (y size) linewidth) ) ; 08 Aug 91; 12 Sep 91; 11 Dec 91; 01 Sep 92; 02 Sep 92; 17 Jul 06 ; New version avoids XDrawRectangle, which messes up when used with XOR. ; was (XDrawRectangle *window-display* (parent w) (gcontext w) ; offsetx (- qqwheight (offsety + sizey)) sizex sizey) (gldefun window-draw-box-xy ((w window) (offsetx integer) (offsety integer) (sizex integer) (sizey integer) &optional linewidth) (let ((qqwheight (drawable-height w)) lw lw2 lw2b (pw (parent w)) (gc (gcontext w))) (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) (lw = (or linewidth 1)) (lw2 = (truncate lw 2)) (lw2b = (truncate (lw + 1) 2)) (XdrawLine *window-display* pw gc (- offsetx lw2) (- qqwheight offsety) (- (+ offsetx sizex) lw2) (- qqwheight offsety)) (XdrawLine *window-display* pw gc (+ offsetx sizex) (- qqwheight (- offsety lw2b)) (+ offsetx sizex) (- qqwheight (+ sizey (- offsety lw2b)))) (XdrawLine *window-display* pw gc (+ offsetx sizex lw2b) (- qqwheight (+ offsety sizey)) (+ offsetx lw2b) (- qqwheight (+ offsety sizey))) (XdrawLine *window-display* pw gc offsetx (- qqwheight (+ offsety sizey lw2)) offsetx (- qqwheight (+ offsety lw2)) ) (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )) ; 26 Nov 91 (gldefun window-xor-box-xy ((w window) (offsetx integer) (offsety integer) (sizex integer) (sizey integer) &optional linewidth) (window-set-xor w) (window-draw-box-xy w offsetx offsety sizex sizey linewidth) (window-unset w)) ; 15 Aug 91; 12 Sep 91 ; Draw a box whose corners are specified (gldefun window-draw-box-corners ((w window) (xa integer) (ya integer) (xb integer) (yb integer) &optional lw) (draw-box-xy w (min xa xb) (min ya yb) (abs (- xa xb)) (abs (- ya yb)) lw) ) ; 13 Sep 91; 17 Jul 06 ; Draw a box with round corners (gldefun window-draw-rcbox-xy ((w window) (x integer) (y integer) (width integer) (height integer) (radius integer) &optional linewidth) (let (x1 x2 y1 y2 r lw2 lw2b fudge) (r = (max 0 (min radius (truncate (abs width) 2) (truncate (abs height) 2)))) (if (not (numberp linewidth)) (linewidth = 1)) (lw2 = (truncate linewidth 2)) (lw2b = (truncate (1+ linewidth) 2)) (fudge = (if (oddp linewidth) 0 1)) (x1 = x + r) (x2 = x + width - r) (y1 = y + r) (y2 = y + height - r) (draw-line-xy w (- (- x1 1) lw2) y x2 y linewidth) ; bottom (draw-line-xy w (x + width) (- y1 lw2b) (x + width) (+ y2 1) linewidth) ; right (draw-line-xy w (- x1 1) (+ y height) (+ x2 lw2) (+ y height) linewidth) (draw-line-xy w x y1 x (+ y2 1) linewidth) ; left (draw-arc-xy w (- x1 fudge) y1 r r 180 90 linewidth) (draw-arc-xy w x2 y1 r r 270 90 linewidth) (draw-arc-xy w x2 (+ y2 fudge) r r 0 90 linewidth) (draw-arc-xy w (- x1 fudge) (+ y2 fudge) r r 90 90 linewidth) )) ; 13 Aug 91; 15 Aug 91; 12 Sep 91 (gldefun window-draw-arc-xy ((w window) (x integer) (y integer) (radiusx integer) (radiusy integer) (anglea number) (angleb number) &optional linewidth) (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) (XdrawArc *window-display* (parent w) (gcontext w) (x - radiusx) (positive-y w (y + radiusy)) (radiusx * 2) (radiusy * 2) (truncate (* anglea 64)) (truncate (* angleb 64))) (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) ) ; 08 Aug 91; 12 Sep 91 (gldefun window-draw-circle-xy ((w window) (x integer) (y integer) (radius integer) &optional linewidth) (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) (XdrawArc *window-display* (parent w) (gcontext w) (x - radius) (positive-y w (y + radius)) (radius * 2) (radius * 2) 0 (* 360 64)) (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) ) ; 06 Aug 91; 14 Aug 91; 12 Sep 91 (gldefun window-draw-circle ((w window) (pos vector) (radius integer) &optional linewidth) (window-draw-circle-xy w (x pos) (y pos) radius linewidth) ) ; 08 Aug 91; 09 Sep 91 (gldefun window-erase-area ((w window) (offset vector) (size vector)) (window-erase-area-xy w (x offset) (y offset) (x size) (y size))) ; 09 Sep 91; 11 Dec 91 (gldefun window-erase-area-xy ((w window) (xoff integer) (yoff integer) (xsize integer) (ysize integer)) (XClearArea *window-display* (parent w) xoff (positive-y w (yoff + ysize - 1)) xsize ysize 0 )) ; exposures ; 21 Dec 93; 08 Sep 06 (gldefun window-erase-box-xy ((w window) (xoff integer) (yoff integer) (xsize integer) (ysize integer) &optional (linewidth integer)) (XClearArea *window-display* (parent w) (xoff - (truncate (or linewidth 1) 2)) (positive-y w (+ yoff ysize (truncate (or linewidth 1) 2))) (xsize + (or linewidth 1)) (ysize + (or linewidth 1)) 0 )) ; exposures ; 15 Aug 91; 12 Sep 91 (gldefun window-draw-ellipse-xy ((w window) (x integer) (y integer) (rx integer) (ry integer) &optional lw) (draw-arc-xy w x y rx ry 0 360 lw)) ; 09 Aug 91 (gldefun window-copy-area-xy ((w window) fromx (fromy integer) tox (toy integer) width height) (let ((qqwheight (drawable-height w))) (set-copy w) (XCopyArea *window-display* (parent w) (parent w) (gcontext w) fromx (- qqwheight (+ fromy height)) width height tox (- qqwheight (+ toy height))) (unset w) )) ; 07 Dec 90; 09 Aug 91; 12 Sep 91 (gldefun window-invertarea ((w window) (area region)) (window-invert-area-xy w (left area) (bottom area) (width area) (height area))) ; 07 Dec 90; 09 Aug 91; 12 Sep 91 (gldefun window-invert-area ((w window) (offset vector) (size vector)) (window-invert-area-xy w (x offset) (y offset) (x size) (y size)) ) ; 12 Aug 91; 15 Aug 91; 13 Dec 91 (gldefun window-invert-area-xy ((w window) left (bottom integer) width height) (set-invert w) (XFillRectangle *window-display* (parent w) (gcontext w) left (- (drawable-height w) (bottom + height - 1)) width height) (unset w) ) ; 05 Dec 90; 15 Aug 91 (gldefun window-prettyprintat ((w window) (s string) (pos vector)) (printat w s pos) ) (gldefun window-prettyprintat-xy ((w window) (s string) (x integer) (y integer)) (printat-xy w s x y)) ; 06 Aug 91; 08 Aug 91; 15 Aug 91 (gldefun window-printat ((w window) (s string) (pos vector)) (printat-xy w s (x pos) (y pos)) ) ; 06 Aug 91; 08 Aug 91; 12 Aug 91 (gldefun window-printat-xy ((w window) (s string) (x integer) (y integer)) (let ( (sstr (stringify s)) ) (XdrawImageString *window-display* (parent w) (gcontext w) x (- (drawable-height w) y) (get-c-string sstr) (length sstr)) )) ; 19 Apr 95; 02 May 95; 17 May 04 ; Print a string that may contain #\Newline characters in a window. (gldefun window-print-line ((w window) (str string) (x integer) (y integer) &optional (deltay integer)) (let ((lng (length str)) (n 0) end strb done) (while ~done (end = (position #\Newline str :test #'char= :start n)) (strb = (subseq str n end)) (printat-xy w strb x y) (if (numberp end) (n = (1+ end)) (done = t)) (y _- (or deltay 16)) (if (y < 0) (done = t))) (force-output w) )) ; 02 May 95; 08 May 95 ; Print a list of strings in a window. (gldefun window-print-lines ((w window) (lines (listof string)) (x integer) (y integer) &optional (deltay integer)) (for str in lines when (y > 0) (printat-xy w str x y) (y _- (or deltay 16))) ) ; 08 Aug 91 ; Find the width of a string when printed in a given window (gldefun window-string-width ((w window) (s string)) (let ((sstr (stringify s))) (XTextWidth (font w) (get-c-string sstr) (length sstr)) )) ; 01 Dec 93 ; Find the ascent and descent of a string when printed in a given window (gldefun window-string-extents ((w window) (s string)) (let ((sstr (stringify s))) (XTextExtents (font w) (get-c-string sstr) (length sstr) *direction-return* *ascent-return* *descent-return* *overall-return*) (list (int-pos *ascent-return* 0) (int-pos *descent-return* 0)) )) ; Find the height (ascent + descent) of a string when printed in a given window (gldefun window-string-height ((w window) (s string)) (let ((sstr (stringify s))) (XTextExtents (font w) (get-c-string sstr) (length sstr) *direction-return* *ascent-return* *descent-return* *overall-return*) (+ (int-pos *ascent-return* 0) (int-pos *descent-return* 0)) )) ; 15 Oct 91 (gldefun window-font-string-width (font (s string)) (let ((sstr (stringify s))) (XTextWidth font (get-c-string sstr) (length sstr)) )) (gldefun window-yposition ((w window)) (window-get-mouse-position) (positive-y w (- *mouse-y* (top-neg-y w))) ) (gldefun window-centeroffset ((w window) (v vector)) (a vector with x = (truncate ((width w) - (x v)) 2) y = (truncate ((height w) - (y v)) 2))) ; 18 Aug 89; 15 Aug 91 ; Command to a window display manager (gldefun dowindowcom ((w window)) (let (comm) (comm = (select (window-menu)) ) (case comm (close (close w)) (paint (paint w)) (clear (clear w)) (move (move w)) (t (when comm (princ "This command not implemented.") (terpri))) ) )) (gldefun window-menu () (result menu) (or *window-menu* (setq *window-menu* (a menu with items = '(close paint clear move)))) ) ; 06 Dec 90; 11 Mar 93 (gldefun window-close ((w window)) (unmap w) (force-output w) (window-wait-unmap w)) (gldefun window-unmap ((w window)) (XUnMapWindow *window-display* (parent w)) ) ; 06 Aug 91; 22 Aug 91 (gldefun window-open ((w window)) (mapw w) (force-output w) (wait-exposure w) ) (gldefun window-map ((w window)) (XMapWindow *window-display* (parent w)) ) ; 08 Aug 91; 02 Sep 91 (gldefun window-destroy ((w window)) (XDestroyWindow *window-display* (parent w)) (force-output w) ((parent w) = nil) (XFreeGC *window-display* (gcontext w)) ((gcontext w) = nil) ) ; 09 Sep 91 ; Wait 3 seconds, then destroy the window where the mouse is. Use with care. (defun window-destroy-selected-window () (prog (ww child) (sleep 3) (setq ww *root-window*) lp (window-query-pointer-b ww) (setq child (fixnum-pos *child-return* 0)) ; 22 Jun 06 (if (> child 0) (progn (setq ww child) (go lp))) (if (/= ww *root-window*) (progn (XDestroyWindow *window-display* ww) (Xflush *window-display*))) )) ; 07 Aug 91 (gldefun window-clear ((w window)) (XClearWindow *window-display* (parent w)) (force-output w) ) ; 08 Aug 91 (gldefun window-moveto-xy ((w window) (x integer) (y integer)) (XMoveWindow *window-display* (parent w) x (- (window-screen-height) y)) ) ; 15 Aug 91; 05 Sep 91 ; Paint in window with mouse: Left paints, Middle erases, Right quits. (defun window-paint (window) (let (state) (window-track-mouse window #'(lambda (x y code) (if (= code 1) (if (= state 1) (setq state 0) (setq state 1)) (if (= code 2) (if (= state 2) (setq state 0) (setq state 2)))) (if (= state 1) (window-draw-line-xy window x y x y 1 'paint) (if (= state 2) (window-draw-line-xy window x y x y 1 'erase))) (= code 3)) ) )) ; 15 Aug 91; 06 May 93 ; Move a window. (gldefun window-move ((w window)) (window-get-mouse-position) (XMoveWindow *window-display* (parent w) *mouse-x* (- (window-screen-height) *mouse-y*)) ) ; 15 Sep 93; 06 Jan 94 (gldefun window-draw-border ((w window)) (draw-box-xy w 0 1 ((x (size w)) - 1) ((y (size w)) - 1)) (force-output w) ) ; 13 Aug 91; 22 Aug 91; 27 Aug 91; 14 Oct 91 ; Track the mouse within a window, calling function fn with args (x y event). ; event is 0 = no button, 1 = left button, 2 = middle, 3 = right button. ; Tracking continues until fn returns non-nil; result is that value. ; Partly adapted from Hiep Nguyen's code. (defun window-track-mouse (w fn &optional outflg) (let (win h) (setq win (window-parent w)) (setq h (window-drawable-height w)) (Xsync *window-display* 1) ; clear event queue of prev motion events (Xselectinput *window-display* win (+ ButtonPressMask PointerMotionMask)) ;; Event processing loop: stop when function returns non-nil. (do ((res nil)) (res res) (XNextEvent *window-display* *window-event*) (let ((type (XAnyEvent-type *window-event*)) (eventwindow (XAnyEvent-window *window-event*))) (when (or (and (eql eventwindow win) (or (eql type MotionNotify) (eql type ButtonPress))) (and outflg (eql type ButtonPress))) (let ((x (XMotionEvent-x *window-event*)) (y (XMotionEvent-y *window-event*)) (code (if (eql type ButtonPress) (XButtonEvent-button *window-event*) 0))) (setq res (if (eql eventwindow win) (funcall fn x (- h y) code) (funcall fn -1 -1 code))) ) ) ) ) )) ; 22 Aug 91; 23 Aug 91; 27 Aug 91; 04 Sep 92; 11 Mar 93 ; Wait for a window to become exposed, but not more than 1 second. (defun window-wait-exposure (w) (prog (win start-time max-time eventwindow type) (setq win (window-parent w)) (XGetWindowAttributes *window-display* win *window-attr*) (unless (eql (XWindowAttributes-map_state *window-attr*) ISUnmapped) (return t)) (setq start-time (get-internal-real-time)) (setq max-time internal-time-units-per-second) (Xselectinput *window-display* win (+ ExposureMask)) ; Event processing loop: stop when exposure is seen or time out lp (cond ((> (XPending *window-display*) 0) (XNextEvent *window-display* *window-event*) (setq type (XAnyEvent-type *window-event*)) (setq eventwindow (XAnyEvent-window *window-event*)) (if (and (eql eventwindow win) (eql type Expose)) (return t))) ((> (- (get-internal-real-time) start-time) max-time) (return nil)) ) (go lp) )) ; 11 Mar 93; 06 May 93 ; Wait for a window to become unmapped, but not more than 1 second. (defun window-wait-unmap (w) (prog (win start-time max-time) (setq win (window-parent w)) (setq start-time (get-internal-real-time)) (setq max-time internal-time-units-per-second) lp (XGetWindowAttributes *window-display* win *window-attr*) (if (eql (XWindowAttributes-map_state *window-attr*) ISUnmapped) (return t) (if (> (- (get-internal-real-time) start-time) max-time) (return nil))) (go lp) )) ; 07 Oct 93 ; Initialize to poll the mouse for a specified window (defun window-init-mouse-poll (w) (let (win) (setq win (window-parent w)) (Xsync *window-display* 1) ; clear event queue of prev motion events (Xselectinput *window-display* win (+ ButtonPressMask PointerMotionMask)) )) ; 07 Oct 93 ; Poll the mouse for a position change or button push ; Returns nil if no mouse activity, ; else (x y code), where x and y are positions, or nil if no movement, ; and code is 0 if no button else button number (defun window-poll-mouse (w) (let (win h eventtype eventwindow x y cd (code 0)) (setq win (window-parent w)) (setq h (window-drawable-height w)) (while (> (XPending *window-display*) 0) (XNextEvent *window-display* *window-event*) (setq eventtype (XAnyEvent-type *window-event*)) (setq eventwindow (XAnyEvent-window *window-event*)) (if (eql eventwindow win) (if (eql eventtype MotionNotify) (progn (setq x (XMotionEvent-x *window-event*)) (setq y (XMotionEvent-y *window-event*))) (if (eql eventtype ButtonPress) (if (> (setq cd (XButtonEvent-button *window-event*)) 0) (setq code cd))))) ) (if (or x (> code 0)) (list x (if y (- h y)) code)) )) ; 14 Dec 90; 17 Dec 90; 13 Aug 91; 20 Aug 91; 30 Aug 91; 09 Sep 91; 11 Sep 91 ; 15 Oct 91; 16 Oct 91; 10 Feb 92; 25 Sep 92; 26 Sep 92 ; Initialize a menu (gldefun menu-init ((m menu)) (let () (or *window-display* (window-Xinit)) ; init windows if necessary (calculate-size m) (if ~ (flat m) ((menu-window m) = (window-create (picture-width m) (picture-height m) ((title m) or "") (parent-window m) (parent-offset-x m) (parent-offset-y m) (menu-font m) )) ) )) ; 25 Sep 92; 26 Sep 92; 11 Mar 93; 05 Oct 93; 08 Oct 93; 17 May 04; 12 Jan 10 ; Calculate the displayed size of a menu (gldefun menu-calculate-size ((m menu)) (let (maxwidth totalheight nitems) (or (menu-font m) ((menu-font m) = '9x15)) (maxwidth = (find-item-width m (title m)) + (if (or (flat m) *window-add-menu-title*) 0 *menu-title-pad*)) (nitems = (if (and (title-present m) (or (flat m) *window-add-menu-title*)) 1 0)) (totalheight = (* nitems 13)) ; ***** fix for font (for item in (items m) do (nitems _+ 1) (maxwidth = (max maxwidth (find-item-width m item))) (totalheight =+ (menu-find-item-height m item)) ) ((item-width m) = maxwidth + 6) ((picture-width m) = (item-width m) + 1) ((picture-height m) = totalheight + 2) (adjust-offset m) )) ; 06 Sep 91; 09 Sep 91; 10 Sep 91; 21 May 93; 30 May 02; 17 May 04; 08 Sep 06 ; Adjust a menu's offset position if necessary to keep it in parent window. (gldefun menu-adjust-offset ((m menu)) (let (xbase ybase wbase hbase xoff yoff wgm width height) (width = (picture-width m)) (height = (picture-height m)) (if ~ (parent-window m) (progn (window-get-mouse-position) ; put it where the mouse is (wgm = t) ; set flag that we got mouse position ((parent-window m) = *root-window*))) ; 21 May 93 was *mouse-window* (window-get-geometry-b (parent-window m)) (setq xbase (int-pos *x-return* 0)) (setq ybase (int-pos *y-return* 0)) (setq wbase (int-pos *width-return* 0)) (setq hbase (int-pos *height-return* 0)) (if (~ (parent-offset-x m) or (parent-offset-x m) == 0) (progn (or wgm (window-get-mouse-position)) (xoff = ((*mouse-x* - xbase) - (truncate width 2) - 4)) (yoff = ((hbase - (*mouse-y* - ybase)) - (truncate height 2)))) (progn (xoff = (parent-offset-x m)) (yoff = (parent-offset-y m)))) ((parent-offset-x m) = (max 0 (min xoff (wbase - width)))) ((parent-offset-y m) = (max 0 (min yoff (hbase - height)))) )) ; 07 Dec 90; 14 Dec 90; 12 Aug 91; 22 Aug 91; 09 Sep 91; 10 Sep 91; 28 Jan 92; ; 10 Feb 92; 26 Sep 92; 11 Mar 93; 08 Oct 93; 17 May 04; 12 Jan 10 (gldefun menu-draw ((m menu)) (let (mw xzero yzero bottom) (init? m) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (mw = (menu-window m)) (open mw) (clear m) (if (flat m) (draw-box-xy mw (xzero - 1) yzero ((picture-width m) + 2) ((picture-height m) + 1) 1)) (bottom = (yzero + (picture-height m) + 3)) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (progn (bottom _- 15) ; ***** fix for font (printat-xy mw (stringify (title m)) (+ xzero 3) bottom) (invert-area-xy mw xzero (bottom - 2) ((picture-width m) + 1) 15))) (for item in (items m) do (bottom _- (menu-find-item-height m item)) (display-item m item (+ xzero 3) bottom) ) (force-output mw) )) ; 17 May 04 (gldefun menu-item-value (self item) (if (consp item) (cdr item) item)) ; 06 Sep 91; 11 Sep 91; 15 Oct 91; 16 Oct 91; 23 Oct 91; 17 May 04 (gldefun menu-find-item-width ((self menu) item) (let ((tmp vector)) (if (and (consp item) (symbolp (car item)) (fboundp (car item))) (or (and (tmp = (get (car item) 'display-size)) (x tmp)) 40) (window-font-string-width (or (and (flat self) (menu-window self) (font (menu-window self))) (window-font-info (menu-font self))) (stringify (if (consp item) (car item) item)))) )) ; 09 Sep 91; 10 Sep 91; 11 Sep 91; 17 mAY 04 (gldefun menu-find-item-height ((self menu) item) ; ***** fix for font (let ((tmp vector)) (if (and (consp item) (symbolp (car item)) (tmp = (get (car item) 'display-size))) ((y tmp) + 3) 15) )) ; 09 Sep 91; 10 Sep 91; 10 Feb 92; 17 May 04 (gldefun menu-clear ((m menu)) (if (flat m) (erase-area-xy (menu-window m) ((base-x m) - 1) ((base-y m) - 1) ((picture-width m) + 3) ((picture-height m) + 3)) (clear (menu-window m))) ) ; 06 Sep 91; 04 Dec 91; 17 May 04 (gldefun menu-display-item ((self menu) item x y) (let ((mw (menu-window self))) (if (consp item) (if (and (symbolp (car item)) (fboundp (car item))) (funcall (car item) mw x y) (if (or (stringp (car item)) (symbolp (car item)) (numberp (car item))) (printat-xy mw (car item) x y) (printat-xy mw (stringify item) x y))) (printat-xy mw (stringify item) x y)) )) ; 07 Dec 90; 18 Dec 90; 15 Aug 91; 27 Aug 91; 06 Sep 91; 10 Sep 91; 29 Sep 92 ; 04 Aug 93; 07 Jan 94; 17 May 04; 18 May 04; 12 Jan 10; 13 Jan 10 (gldefun menu-choose ((m menu) (inside boolean)) (let (mw current-item ybase itemh val maxx maxy xzero yzero) (init? m) (mw = (menu-window m)) (draw m) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (maxx = (+ xzero (picture-width m))) (maxy = (+ yzero (picture-height m))) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (maxy =- 15)) (track-mouse mw #'(lambda (x y code) (setq *window-menu-code* code) (if (and (>= x xzero) (<= x maxx) ; is mouse in menu area? (>= y yzero) (<= y maxy)) (if (or (null current-item) ; is mouse in a new item? (< y ybase) (> y (+ ybase itemh)) ) (progn (if current-item (unbox-item m current-item ybase)) (current-item = (menu-find-item-y m (- y yzero))) (if current-item (progn (ybase = (menu-item-y m current-item)) (itemh = (menu-find-item-height m current-item)) (box-item m current-item ybase) (inside = t))) (if (> code 0) ; same item: click? (progn (unbox-item m current-item ybase) (val = 1)))) (if (> code 0) ; same item: click? (progn (unbox-item m current-item ybase) (val = 1)))) (progn (if current-item ; mouse outside area (progn (unbox-item m current-item ybase) (current-item = nil))) (if (or (> code 0) (and inside (or (< x xzero) (> x maxx) (< y yzero) (> y maxy)))) (val = -777))))) t) (if (not (eql val -777)) (item-value m current-item)) )) ; 07 Dec 90; 12 Aug 91; 10 Sep 91; 05 Oct 92; 12 Jan 10 (gldefun menu-box-item ((m menu) (item menu-item) (ybase integer)) (let ( (mw (menuw m)) ) (set-xor mw) (draw-box-xy mw (menu-x m 1) ((menu-y m ybase) + 2) ((item-width m) - 2) (menu-find-item-height m item) 1) (unset mw) )) ; 07 Dec 90; 12 Aug 91; 14 Aug 91; 15 Aug 91; 05 Oct 92; 12 Jan 10 (gldefun menu-unbox-item ((m menu) (item menu-item) (ybase integer)) (box-item m item ybase) ) ; 11 Sep 91; 08 Sep 92; 28 Sep 92; 18 Jan 94; 08 Sep 06; 12 Jan 10; 13 Jan 10 (gldefun menu-item-position ((m menu) (itemname symbol) &optional (place symbol)) (let ( (xsize (item-width m)) ybase item ysize) (item = (menu-find-item m itemname)) (ysize = (menu-find-item-height m item)) (ybase = (menu-item-y m item)) (a vector with x = ((menu-x m 0) + (case place ((center top bottom) (truncate xsize 2)) (left -1) (right xsize + 2) else 0)) y = ((menu-y m ybase) + (case place ((center right left) (truncate ysize 2)) (bottom 0) (top ysize) else 0)) ) )) ; 13 Jan 10 ; find the y position of bottom of item with given name (gldefun menu-find-item ((m menu) (itemname symbol)) (let (found itms item) (itms = (items m)) (found = (null itemname)) (while (and itms (not found)) (item -_ itms) (if (or (eq item itemname) (and (consp item) (or (eq itemname (car item)) (and (stringp (car item)) (string= (stringify itemname) (car item))) (eq (cdr item) itemname) (and (consp (cdr item)) (eq (cadr item) itemname))))) (found = t))) item)) ; 12 Jan 10 ; find the y position of bottom of a given item (gldefun menu-item-y ((m menu) (item menu-item)) (let (found itms itm ybase) (ybase = (picture-height m) - 1) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (ybase =- 15)) (itms = (items m)) (while (and itms (not found)) (itm -_ itms) (ybase =- (menu-find-item-height m itm)) (found = (eq item itm)) ) ybase)) ; 12 Jan 10 ; find item based on y position (gldefun menu-find-item-y ((m menu) (y integer)) (let (found itms itm ybase) (ybase = (picture-height m) - 1) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (ybase =- 15)) (itms = (items m)) (while (and itms (not found)) (itm -_ itms) (ybase =- (menu-find-item-height m itm)) (found = (and (>= y ybase) (<= y (+ ybase (menu-find-item-height m itm)))))) (and found itm))) ; 10 Dec 90; 13 Dec 90; 10 Sep 91; 29 Sep 92; 17 May 04 ; Choose from menu, then close it (gldefun menu-select ((m menu) &optional inside) (menu-select-b m nil inside)) (gldefun menu-select! ((m menu)) (menu-select-b m t nil)) (gldefun menu-select-b ((m menu) (flg boolean) (inside boolean)) (prog (res) lp (res = (choose m inside)) (if (flg and ~res) (go lp)) (if ~(permanent m) (if (flat m) (progn (clear m) (force-output (menu-window m))) (close (menu-window m)))) (return res))) ; 12 Aug 91; 17 May 04 (gldefun menu-destroy ((m menu)) (if ~ (flat m) (progn (destroy (menu-window m)) ((menu-window m) = nil) ))) ; 19 Aug 91; 02 Sep 91 ; Easy interface to make a menu, select from it, and destroy it. (defun menu (items &optional title) (let (m res) (setq m (menu-create items title)) (setq res (menu-select m)) (menu-destroy m) res )) ; 12 Aug 91; 15 Aug 91; 06 Sep 91; 09 Sep 91; 12 Sep 91; 23 Oct 91; 17 May 04 ; Simple call from plain Lisp to make a menu. (setf (glfnresulttype 'menu-create) 'menu) (gldefun menu-create (items &optional title (parentw window) x y (perm boolean) (flat boolean) (font symbol)) (a menu with title = (if title (stringify title) "") menu-window = (if flat parentw) items = items parent-window = (parent parentw) parent-offset-x = x parent-offset-y = y permanent = perm flat = flat menu-font = font )) ; 15 Oct 91; 30 Oct 91 (gldefun menu-offset ((m menu)) (result vector) (a vector with x = (base-x m) y = (base-y m))) ; 15 Oct 91; 30 Oct 91; 25 Sep 92; 29 Sep 92; 18 Apr 95; 25 Jul 96 (gldefun menu-size ((m menu)) (result vector) (if ((picture-width m) <= 0) (case (first m) (picmenu (picmenu-calculate-size m)) (barmenu (barmenu-calculate-size m)) (textmenu (textmenu-calculate-size m)) (editmenu (editmenu-calculate-size m)) (t (menu-calculate-size m)))) (a vector with x = (picture-width m) y = (picture-height m)) ) ; 15 Oct 91; 17 May 04 (gldefun menu-moveto-xy ((m menu) (x integer) (y integer)) (if (flat m) (progn ((parent-offset-x m) = x) ((parent-offset-y m) = y) (adjust-offset m)) )) ; 27 Nov 92; 17 May 04 ; Reposition a menu to a position specified by the user by mouse click (gldefun menu-reposition ((m menu)) (let (sizev pos) (if (flat m) (progn (sizev = (size m)) (pos = (get-box-position (menu-window m) (x sizev) (y sizev))) (moveto-xy m (x pos) (y pos)) ) ))) ; 31 Aug 09 ; Reposition a menu to a position specified by the user by mouse click (gldefun menu-reposition-line ((m menu) (offset vector) (target vector)) (let (sizev pos) (if (flat m) (progn (sizev = (size m)) (pos = (get-box-line-position (menu-window m) (x sizev) (y sizev) (x offset) (y offset) (x target) (y target))) (moveto-xy m (x pos) (y pos)) ) ))) ; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91 ; Simple call from plain Lisp to make a picture menu. (setf (glfnresulttype 'picmenu-create) 'picmenu) (gldefun picmenu-create (buttons (width integer) (height integer) drawfn &optional title (dotflg boolean) (parentw window) x y (perm boolean) (flat boolean) (font symbol) (boxflg boolean)) (picmenu-create-from-spec (picmenu-create-spec buttons width height drawfn dotflg font) title parentw x y perm flat boxflg)) ; 14 Sep 91 (setf (glfnresulttype 'picmenu-create-spec) 'picmenu-spec) (gldefun picmenu-create-spec (buttons (width integer) (height integer) drawfn &optional (dotflg boolean) (font symbol)) (a picmenu-spec with drawing-width = width drawing-height = height buttons = buttons dotflg = dotflg drawfn = drawfn menu-font = (font or '9x15))) ; 14 Sep 91; 17 May 04 (setf (glfnresulttype 'picmenu-create-from-spec) 'picmenu) (gldefun picmenu-create-from-spec ((spec picmenu-spec) &optional title (parentw window) x y (perm boolean) (flat boolean) (boxflg boolean)) (a picmenu with title = (if title (stringify title) "") menu-window = (if flat parentw) parent-window = (if parentw (parent parentw)) parent-offset-x = x parent-offset-y = y permanent = perm flat = flat spec = spec boxflg = boxflg )) ; 29 Sep 92; 13 Oct 93; 17 May 04 (gldefun picmenu-calculate-size ((m picmenu)) (let (maxwidth maxheight) (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) 0) (drawing-width m))) (maxheight = (if (and (title-present m) (or (flat m) *window-add-menu-title*)) 15 0) + (drawing-height m)) ((picture-width m) = maxwidth) ((picture-height m) = maxheight) )) ; 09 Sep 91; 10 Sep 91; 29 Sep 92 ; Initialize a picture menu (gldefun picmenu-init ((m picmenu)) (let () (calculate-size m) (adjust-offset m) (if ~ (flat m) ((menu-window m) = (window-create (picture-width m) (picture-height m) ((title m) or "") (parent-window m) (parent-offset-x m) (parent-offset-y m) (menu-font m) )) ) )) ; 09 Sep 91; 10 Sep 91; 11 Sep 91; 10 Feb 92; 05 Oct 92; 30 Oct 92; 13 Oct 93 ; 17 May 04 ; Draw a picture menu (gldefun picmenu-draw ((m picmenu)) (let (mw bottom xzero yzero) (init? m) (mw = (menu-window m)) (open mw) (clear m) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (bottom = yzero + (picture-height m)) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13)) (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16))) (funcall (drawfn m) mw xzero yzero) (if (boxflg m) (draw-box-xy mw xzero yzero (picture-width m) (picture-height m) 1)) (if (dotflg m) (for b in (buttons m) do (draw-button m b)) ) ((deleted-buttons m) = nil) (force-output mw) )) ; 28 Oct 09 (gldefun picmenu-draw-named-button ((m picmenu) (nm symbol)) (draw-button m (assoc nm (buttons m)))) ; 28 Oct 09 (gldefun picmenu-set-named-button-color ((m picmenu) (nm symbol) (color rgb)) (let (lst) (if (lst = (assoc nm (button-colors m))) ((color lst) = color) ((button-colors m) +_ (list nm color)) ) )) ; 05 Oct 92; 28 Oct 09 (gldefun picmenu-draw-button ((m picmenu) (b picmenu-button)) (let ((mw (menu-window m)) col) (set-invert mw) (draw-box-xy mw ((menu-x m 0) + (x (offset b)) - 2) ((menu-y m 0) + (y (offset b)) - 2) 4 4 1) (unset mw) (if (setq col (assoc (buttonname b) (button-colors m))) (progn (window-set-color-rgb mw (red (color col)) (green (color col)) (blue (color col))) (draw-box-xy mw ((menu-x m 0) + (x (offset b)) - 1) ((menu-y m 0) + (y (offset b)) - 1) 3 3 2) (window-reset-color mw)) ) )) ; 05 Oct 92; 30 Oct 92; 17 May 04 ; Delete a button and erase it from the display (gldefun picmenu-delete-named-button ((m picmenu) (name symbol)) (let (b) (if (and (b = (assoc name (buttons m))) ~ (name <= (deleted-buttons m))) (progn (if (dotflg m) (draw-button m b)) ((deleted-buttons m) +_ name) )) (force-output (menu-window m)) )) ; 09 Sep 91; 10 Sep 91; 18 Sep 91; 29 Sep 92; 26 Oct 92; 30 Oct 92; 06 May 93 ; 04 Aug 93; 07 Jan 94; 30 May 02; 17 May 04; 18 May 04; 01 Jun 04; 24 Jan 06 ; inside = t if the mouse is already inside the menu area ; anyclick = value to return for a mouse click that is not on a button. (gldefun picmenu-select ((m picmenu) &optional inside anyclick) (let (mw (current-button picmenu-button) item items (val picmenu-button) xzero yzero codeval) (mw = (menuw m)) (if ~ (permanent m) (draw m)) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (track-mouse mw #'(lambda (x y code) (setq *window-menu-code* code) (x = (x - xzero)) (y = (y - yzero)) (if ((x >= 0) and (x <= (picture-width m)) and (y >= 0) and (y <= (picture-height m))) (inside = t)) (if current-button (if ~ (containsxy? current-button x y) (progn (unbox-item m current-button) (current-button = nil)))) (if ~ current-button (progn (items = (buttons m)) (while ~ current-button and (item -_ items) do (if (and (containsxy? item x y) (not ((buttonname item) <= (deleted-buttons m)))) (progn (box-item m item) (current-button = item)))))) (if (or (> code 0) (and inside (or (x < 0) (x > (picture-width m)) (y < 0) (y > (picture-height m))))) (progn (if current-button (unbox-item m current-button)) (codeval = code) (val = (if (and (> code 0) current-button) current-button *picmenu-no-selection*)) ))) t) (if ~(permanent m) (if (flat m) (progn (clear m) (force-output (menu-window m))) (close (menu-window m)))) (if (val == *picmenu-no-selection*) (and (> codeval 0) anyclick) (buttonname val)) )) ; 09 Sep 91; 10 Sep 91; 17 May 04; 08 Sep 06 (gldefun picmenu-box-item ((m picmenu) (item picmenu-button)) (let ((mw (menuw m)) xoff yoff siz) (xoff = (menu-x m (x (offset item)))) (yoff = (menu-y m (y (offset item)))) (if (highlightfn item) (funcall (highlightfn item) (menuw m) xoff yoff) (progn (set-xor mw) (if (siz = (size item)) (draw-box-xy mw (xoff - (truncate (x siz) 2)) (yoff - (truncate (y siz) 2)) (x siz) (y siz) 1) (draw-box-xy mw (xoff - 6) (yoff - 6) 12 12 1)) (unset mw) (force-output mw) ) ))) ; 09 Sep 91; 06 May 93; 17 May 04 (gldefun picmenu-unbox-item ((m picmenu) (item picmenu-button)) (let ((mw (menuw m))) (if (unhighlightfn item) (progn (funcall (unhighlightfn item) (menuw m) (x (offset item)) (y (offset item))) (force-output mw)) (box-item m item) ) )) (defun picmenu-destroy (m) (menu-destroy m)) ; 09 Sep 91; 10 Sep 91; 11 Sep 91; 08 Sep 06 (gldefun picmenu-button-containsxy? ((b picmenu-button) (x integer) (y integer)) (let ((xsize 6) (ysize 6)) (if (size b) (progn (xsize = (truncate (x (size b)) 2)) (ysize = (truncate (y (size b)) 2)))) ((x >= ((x (offset b)) - xsize)) and (x <= ((x (offset b)) + xsize)) and (y >= ((y (offset b)) - ysize)) and (y <= ((y (offset b)) + ysize)) ) )) ; 11 Sep 91; 08 Sep 92; 18 Jan 94; 30 May 02; 17 May 04; 24 Jan 06; 08 Sep 06 (gldefun picmenu-item-position ((m picmenu) (itemname symbol) &optional (place symbol)) (let ((b picmenu-button) (xsize 0) (ysize 0) xoff yoff) (if (null itemname) (progn (xsize = (picture-width m)) (ysize = (truncate ((picture-height m) - (drawing-height m)) 2)) (xoff = (truncate xsize 2)) (yoff = (drawing-height m) + (truncate ysize 2))) (if (b = (that (buttons m) with buttonname == itemname)) (progn (if (size b) (progn (xsize = (x (size b))) (ysize = (y (size b))))) (xoff = (x (offset b))) (yoff = (y (offset b))) ) )) (if xoff (a vector with x = ((menu-x m xoff) + (case place ((center top bottom) 0) (left (- (truncate xsize 2))) (right (truncate xsize 2)) else 0)) y = ((menu-y m yoff) + (case place ((center right left) 0) (bottom (- (truncate ysize 2))) (top (truncate ysize 2)) else 0))) ) )) ; 03 Jan 94; 18 Jan 94; 17 May 04 ; Simple call from plain Lisp to make a picture menu. (setf (glfnresulttype 'barmenu-create) 'barmenu) (gldefun barmenu-create ((maxval integer) (initval integer) (barwidth integer) &optional title (horizontal boolean) subtrackfn subtrackparms (parentw window) x y (perm boolean) (flat boolean) (color rgb)) (a barmenu with title = (if title (stringify title) "") menu-window = (if flat parentw) parent-window = (if parentw (parent parentw)) parent-offset-x = (or x 0) parent-offset-y = (or y 0) permanent = perm flat = flat value = initval maxval = maxval barwidth = barwidth horizontal = horizontal subtrackfn = subtrackfn subtrackparms = subtrackparms color = color) ) ; 03 Jan 94; 17 May 04 (gldefun barmenu-calculate-size ((m barmenu)) (let (maxwidth maxheight) (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) 0) (barwidth m))) (maxheight = (if (and (title-present m) (or (flat m) *window-add-menu-title*)) 15 0) + (maxval m)) ((picture-width m) = maxwidth) ((picture-height m) = maxheight) )) ; 03 Jan 94 ; Initialize a picture menu (gldefun barmenu-init ((m barmenu)) (let () (calculate-size m) (adjust-offset m) (if ~ (flat m) ((menu-window m) = (window-create (picture-width m) (picture-height m) ((title m) or "") (parent-window m) (parent-offset-x m) (parent-offset-y m) )) ) )) ; 03 Jan 94; 18 Jan 94; 17 May 04; 18 May 04; 08 Sep 06 ; Draw a picture menu (gldefun barmenu-draw ((m barmenu)) (let (mw xzero yzero) (init? m) (mw = (menu-window m)) (open mw) (clear m) (xzero = (menu-x m (truncate (picture-width m) 2))) (yzero = (menu-y m 0)) (if (color m) (window-set-color mw (color m))) (if (horizontal m) (draw-line-xy (menu-window m) xzero yzero (xzero + (value m)) yzero (barwidth m)) (draw-line-xy (menu-window m) xzero yzero xzero (+ yzero (value m)) (barwidth m)) ) (if (color m) (window-reset-color mw)) (force-output mw) )) ; 03 Jan 94; 04 Jan 94; 07 Jan 94; 18 Jan 94; 08 Sep 06 ; inside = t if the mouse is already inside the menu area (gldefun barmenu-select ((m barmenu) &optional inside) (let (mw xzero yzero val) (mw = (menuw m)) (if ~ (permanent m) (draw m)) (xzero = (menu-x m (truncate (picture-width m) 2))) (yzero = (menu-y m 0)) (when (window-track-mouse-in-region mw (menu-x m 0) yzero (picture-width m) (picture-height m) t t) (track-mouse mw #'(lambda (x y code) (setq *window-menu-code* code) (val = (if (horizontal m) (x - xzero) (y - yzero))) (update-value m val) (if (> code 0) code) )) val) )) ; 03 Jan 93; 17 May 04; 08 Sep 06 (defvar *barmenu-update-value-cons* (cons nil nil)) ; reusable cons (gldefun barmenu-update-value ((m barmenu) (val integer)) (let ((mw (menuw m)) xzero yzero) (val = (max 0 (min val (maxval m)))) (if (val <> (value m)) (progn (if (val < (value m)) (set-erase mw) (if (color m) (window-set-color mw (color m)))) (xzero = (menu-x m (truncate (picture-width m) 2))) (yzero = (menu-y m 0)) (if (horizontal m) (draw-line-xy (menu-window m) (+ xzero (value m)) yzero (+ xzero val) yzero (barwidth m)) (draw-line-xy (menu-window m) xzero (+ yzero (value m)) xzero (+ yzero val) (barwidth m)) ) (if (val < (value m)) (unset mw) (if (color m) (window-reset-color mw)) ) ((value m) = val) (if (subtrackfn m) (progn ((car *barmenu-update-value-cons*) = val) ((cdr *barmenu-update-value-cons*) = (subtrackparms m)) (apply (subtrackfn m) *barmenu-update-value-cons*))) (force-output mw) ) ))) ; Functions for text input "menus". Derived from picmenu code. ; Making text input analogous to menus allows use with menu-sets. ; 18 Apr 95; 17 May 04 ; (setq tm (textmenu-create 200 30 nil myw 50 50 t t '9x15 t "Rutabagas")) ; Simple call from plain Lisp to make a text menu. (setf (glfnresulttype 'textmenu-create) 'textmenu) (gldefun textmenu-create ((width integer) (height integer) &optional title (parentw window) x y (perm boolean) (flat boolean) (font symbol) (boxflg boolean) (initial-text string)) (a textmenu with title = (if title (stringify title) "") menu-window = (if flat parentw) parent-window = (if parentw (parent parentw)) parent-offset-x = (or x 0) parent-offset-y = (or y 0) permanent = perm flat = flat drawing-width = width drawing-height = height menu-font = (font or '9x15) boxflg = boxflg text = initial-text) ) ; 18 Apr 95; 17 May 04 (gldefun textmenu-calculate-size ((m textmenu)) (let (maxwidth maxheight) (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) 0) (drawing-width m))) (maxheight = (if (and (title-present m) (or (flat m) *window-add-menu-title*)) 15 0) + (drawing-height m)) ((picture-width m) = maxwidth) ((picture-height m) = maxheight) )) ; 18 Apr 95 ; Initialize a picture menu (gldefun textmenu-init ((m textmenu)) (let () (calculate-size m) (adjust-offset m) (if ~ (flat m) ((menu-window m) = (window-create (picture-width m) (picture-height m) ((title m) or "") (parent-window m) (parent-offset-x m) (parent-offset-y m) (menu-font m) )) ) )) ; 18 Apr 95; 14 Aug 96; 17 May 04; 08 Sep 06 ; Draw a picture menu (gldefun textmenu-draw ((m textmenu)) (let (mw bottom xzero yzero) (init? m) (mw = (menu-window m)) (open mw) (clear m) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (bottom = yzero + (picture-height m)) (if (and (title-present m) (or (flat m) *window-add-menu-title*)) (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13)) (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16))) (if (text m) (printat-xy mw (text m) (xzero + 10) (yzero + (truncate (picture-height m) 2) - 8))) (if (boxflg m) (draw-box-xy mw xzero yzero (picture-width m) (picture-height m) 1)) (force-output mw) )) ; 18 Apr 95; 20 Apr 95; 21 Apr 95; 14 Aug 96; 17 May 04; 01 Jun 04; 08 Sep 06 (gldefun textmenu-select ((m textmenu) &optional inside) (let (mw xzero yzero codeval res) (mw = (menuw m)) (if ~ (permanent m) (draw m)) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (track-mouse mw #'(lambda (x y code) (setq *window-menu-code* code) (x = (x - xzero)) (y = (y - yzero)) (if (or (> code 0) (or (x < 0) (x > (picture-width m)) (y < 0) (y > (picture-height m)))) (codeval = code)) ) t) (if (and (not (permanent m)) (not (flat m))) (close (menu-window m))) (if (codeval > 0) (progn (draw m) (input-string mw (text m) (xzero + 10) (yzero + (truncate (picture-height m) 2) - 8) ((picture-width m) - 12)) ) ))) (gldefun textmenu-set-text ((m textmenu) &optional (s string)) ((text m) = (or s ""))) ; 15 Aug 91 ; Get a point position by mouse click. Returns (x y). (setf (glfnresulttype 'window-get-point) 'vector) (defun window-get-point (w) (let (orgx orgy) (window-track-mouse w ; get one point #'(lambda (x y code) (when (not (zerop code)) (setq orgx x) (setq orgy y)))) (list orgx orgy) )) ; 23 Aug 91 ; Get a point position by mouse click. Returns (button (x y)). (setf (glfnresulttype 'window-get-click) '(list (button integer) (pos vector))) (defun window-get-click (w) (let (orgx orgy button) (window-track-mouse w ; get one point #'(lambda (x y code) (when (not (zerop code)) (setq button code) (setq orgx x) (setq orgy y)))) (list button (list orgx orgy)) )) ; 13 Aug 91; 06 Aug 91 ; Get a position indicated by a line from a specified origin position. ; Returns (x y) at end of line. (setf (glfnresulttype 'window-get-line-position) 'vector) (defun window-get-line-position (w orgx orgy) (window-get-icon-position w #'window-draw-line-xy (list orgx orgy 1 'paint))) ; 17 Dec 93 ; Get a position indicated by a line from a specified origin position. ; The visual feedback is restricted to lines that LaTex can draw. ; Returns (x y) at end of line. flg is T for a vector position, nil for line. (setf (glfnresulttype 'window-get-latex-position) 'vector) (defun window-get-latex-position (w orgx orgy &optional flg) (window-get-icon-position w #'window-draw-latex-xy (list orgx orgy flg))) ; 13 Aug 91; 15 Aug 91; 05 Sep 91 ; Get a position indicated by a box of a specified size. ; (dx dy) is offset of lower-left corner of box from mouse ; Returns (x y) of lower-left corner of box. (setf (glfnresulttype 'window-get-box-position) 'vector) (defun window-get-box-position (w width height &optional (dx 0) (dy 0)) (window-get-icon-position w #'window-draw-box-xy (list width height 1) dx dy)) ; 28 Aug 09 ; Get a position indicated by a box and line to a specified point (setf (glfnresulttype 'window-get-box-line-position) 'vector) (defun window-get-box-line-position (w width height offx offy tox toy &optional (dx 0) (dy 0)) (window-get-icon-position w #'window-draw-box-line-xy (list width height offx offy tox toy) dx dy)) ; 01 Sep 09 (defun window-draw-box-line-xy (w x y width height offx offy tox toy) (window-draw-box-xy w x y width height) (window-draw-line-xy w (+ x offx) (+ y offy) tox toy)) ; 05 Sep 91 ; Get a position indicated by an icon. ; fn is the function to draw the icon: (fn w x y . args) . ; fn must simply draw the icon, not set window parameters. ; (dx dy) is offset of lower-left corner of icon (x y) from mouse. ; Returns (x y) of mouse. (setf (glfnresulttype 'window-get-icon-position) 'vector) (defun window-get-icon-position (w fn args &optional (dx 0) (dy 0)) (let (lastx lasty argl) (setq argl (cons w (cons 0 (cons 0 args)))) ; arg list for fn (window-set-xor w) (window-track-mouse w #'(lambda (x y code) (when (or (null lastx) (/= x lastx) (/= y lasty)) (if lastx (apply fn argl)) ; undraw (rplaca (cdr argl) (+ x dx)) (rplaca (cddr argl) (+ y dy)) (apply fn argl) ; draw (setq lastx x) (setq lasty y)) (not (zerop code)) )) (apply fn argl) ; undraw (window-unset w) (window-force-output w) (list lastx lasty) )) ; 13 Aug 91; 06 Sep 91; 06 Nov 91 ; Get a box size and position. ; Click for top right, then click for bottom left, then move it. ; Returns ((x y) (width height)) where (x y) is lower-left corner of box. (setf (glfnresulttype 'window-get-region) 'region) (defun window-get-region (w &optional wid ht) (let (lastx lasty start end width height place offx offy stx sty) (if (and (numberp wid) (numberp ht)) (progn (setq start (window-get-box-position w wid ht (- wid) (- ht))) (setq stx (- (car start) wid)) (setq sty (- (cadr start) ht)) ) (progn (setq start (window-get-point w)) (setq stx (car start)) (setq sty (cadr start)))) (setq end (window-get-icon-position w #'window-draw-box-corners (list stx sty 1))) (setq lastx (car end)) (setq lasty (cadr end)) (setq width (abs (- stx lastx))) (setq height (abs (- sty lasty))) (setq offx (- (min stx lastx) lastx)) (setq offy (- (min sty lasty) lasty)) (setq place (window-get-box-position w width height offx offy)) (list (list (+ offx (first place)) (+ offy (second place))) (list width height)) )) ; 27 Nov 91; 10 Sep 92 ; Get box size and echo the size in pixels. Click for top right. ; Returns (width height) of box. (setf (glfnresulttype 'window-get-box-size) 'vector) (defun window-get-box-size (w offsetx offsety) (let (legendy lastx lasty dx dy) (setq offsety (max offsety 30)) (setq legendy (- offsety 25)) (window-erase-area-xy w offsetx legendy 71 21) (window-draw-box-xy w offsetx legendy 70 20) (window-track-mouse w #'(lambda (x y code) (when (or (null lastx) (/= x lastx) (/= y lasty)) (if lastx (window-xor-box-xy w offsetx offsety (- lastx offsetx) (- lasty offsety))) (setq lastx nil) (setq dx (- x offsetx)) (setq dy (- y offsety)) (when (and (> dx 0) (> dy 0)) (window-xor-box-xy w offsetx offsety dx dy) (window-printat-xy w (format nil "~3D x ~3D" dx dy) (+ offsetx 3) (+ legendy 5)) (setq lastx x) (setq lasty y))) (not (zerop code)) )) (if lastx (window-xor-box-xy w offsetx offsety (- lastx offsetx) (- lasty offsety))) (window-erase-area-xy w offsetx legendy 71 21) (window-force-output w) (list dx dy) )) ; 29 Oct 91; 30 Oct 91; 04 Jan 94 ; Track mouse until a button is pressed or it leaves specified region. ; Returns (x y code) or nil. boxflg is T to box the region. (setf (glfnresulttype 'window-track-mouse-in-region) '(list (code integer) (position (transparent vector)))) (defun window-track-mouse-in-region (w offsetx offsety sizex sizey &optional boxflg inside) (let (res) (when boxflg (window-set-xor w) (window-draw-box-xy w (- offsetx 4) (- offsety 4) (+ sizex 8) (+ sizey 8)) (window-unset w) (window-force-output w) ) (setq res (window-track-mouse w #'(lambda (x y code) (if (> code 0) (if inside (list code (list x y)) t) (if (or (< x offsetx) (> x (+ offsetx sizex)) (< y offsety) (> y (+ offsety sizey))) inside (and (setq inside t) nil)))) ) ) (when boxflg (window-set-xor w) (window-draw-box-xy w (- offsetx 4) (- offsety 4) (+ sizex 8) (+ sizey 8)) (window-unset w) (window-force-output w) ) (if (consp res) res) )) ; 04 Nov 91 ; Adjust one side of a box by mouse movement. Returns ((x y) (width height)). (setf (glfnresulttype 'window-adjust-box-side) 'region) (defun window-adjust-box-side (w orgx orgy width height side) (let (new (xx orgx) (yy orgy) (ww width) (hh height)) (setq new (window-get-icon-position w #'window-adj-box-xy (list orgx orgy width height side))) (case side (left (setq xx (car new)) (setq ww (+ width (- orgx (car new))))) (right (setq ww (- (car new) orgx))) (top (setq hh (- (cadr new) orgy))) (bottom (setq yy (cadr new)) (setq hh (+ height (- orgy (cadr new))))) ) (list (list xx yy) (list ww hh)) )) ; 04 Nov 91 (defun window-adj-box-xy (w x y orgx orgy width height side) (let ((xx orgx) (yy orgy) (ww width) (hh height)) (case side (left (setq xx x) (setq ww (+ width (- orgx x)))) (right (setq ww (- x orgx))) (top (setq hh (- y orgy))) (bottom (setq yy y) (setq hh (+ height (- orgy y)))) ) (window-draw-box-xy w xx yy ww hh) )) ; 10 Sep 92 ; Get a circle with a specified center and size. ; center is initial center position, if specified. ; Returns ((x y) radius) (setf (glfnresulttype 'window-get-circle) '(list (center vector) (radius integer))) (defun window-get-circle (w &optional center) (let (pt) (or center (setq center (window-get-crosshairs w))) (setq pt (window-get-icon-position w #'window-draw-circle-pt (list center))) (list center (window-circle-radius (car pt) (cadr pt) center)) )) ; 10 Sep 92 (defun window-circle-radius (x y center) (let ((dx (- x (car center))) (dy (- y (cadr center)))) (truncate (+ 0.5 (sqrt (+ (* dx dx) (* dy dy))))) )) ; 10 Sep 92 (defun window-draw-circle-pt (w x y center) (window-draw-circle w center (window-circle-radius x y center) 1)) ; 10 Sep 92; 15 Sep 92; 06 Nov 92 ; Get an ellipse with a specified center and sizes. ; center is initial center position, if specified. ; First gets a circle whose radius is x size, then adjusts it. ; Returns ((x y) (radiusx radiusy)) (setf (glfnresulttype 'window-get-ellipse) '(list (center vector) (halfsize vector))) (defun window-get-ellipse (w &optional center) (let (cir radiusx pt) (setq cir (window-get-circle w center)) (setq center (car cir)) (setq radiusx (cadr cir)) (setq pt (window-get-icon-position w #'window-draw-ellipse-pt (list center radiusx))) (list center (list radiusx (abs (- (cadr pt) (cadr center))))) )) ; 10 Sep 92 (defun window-draw-ellipse-pt (w x y center radiusx) (window-draw-ellipse-xy w (car center) (cadr center) radiusx (abs (- y (cadr center)))) ) ; 30 Dec 93 (defun window-draw-vector-pt (w x y center radius) (let (dx dy theta) (setq dy (- y (cadr center))) (setq dx (- x (car center))) (when (or (/= dx 0) (/= dy 0)) (setq theta (atan (- y (cadr center)) (- x (car center)))) (window-draw-line-xy w (car center) (cadr center) (+ (car center) (* radius (cos theta))) (+ (cadr center) (* radius (sin theta))) ) ) )) ; 30 Dec 93 (setf (glfnresulttype 'window-get-vector-end) 'vector) (defun window-get-vector-end (w center radius) (window-get-icon-position w #'window-draw-vector-pt (list center radius)) ) ; 12 Sep 92 (setf (glfnresulttype 'window-get-crosshairs) 'vector) (defun window-get-crosshairs (w) (window-get-icon-position w #'window-draw-crosshairs-xy nil) ) ; 12 Sep 92 (defun window-draw-crosshairs-xy (w x y) (window-draw-line-xy w (- x 12) y (- x 3) y) (window-draw-line-xy w (+ x 3) y (+ x 12) y) (window-draw-line-xy w x (- y 12) x (- y 3)) (window-draw-line-xy w x (+ y 3) x (+ y 12)) ) ; 12 Sep 92 (setf (glfnresulttype 'window-get-cross) 'vector) (defun window-get-cross (w) (window-get-icon-position w #'window-draw-cross-xy nil) ) ; 12 Sep 92 (defun window-draw-cross-xy (w x y) (window-draw-line-xy w (- x 10) (- y 10) (+ x 10) (+ y 10) 2) (window-draw-line-xy w (+ x 10) (- y 10) (- x 10) (+ y 10) 2) ) ; 11 Sep 92; 14 Sep 92 ; Draw a dot whose center is at (x y) (defun window-draw-dot-xy (w x y) (window-draw-circle-xy w x y 1) (window-draw-circle-xy w x y 2) (window-draw-line-xy w x y (+ x 1) y 1) ) ; 17 Dec 93; 19 Dec 93 ; Draw a line close to the specified coordinates, but restricted to slopes ; that can be drawn by LaTex. flg = T to restrict slopes for vector. (defun window-draw-latex-xy (w x y orgx orgy flg) (let (dx dy delx dely n ratio cd nrat) (setq dx (- x orgx)) (setq dy (- y orgy)) (if (or (= dx 0) (= dy 0)) (window-draw-line-xy w x y orgx orgy) (progn (setq n (if flg 4 6)) (if (> (abs dy) (abs dx)) (progn (setq ratio (round (/ (* (abs dx) n) (abs dy)))) (setq cd (gcd n ratio)) (setq n (/ n cd)) (setq ratio (/ ratio cd)) (setq nrat (round (/ (abs dy) n))) (setq dely (* (signum dy) nrat n)) (setq delx (* (signum dx) nrat ratio)) ) (progn (setq ratio (round (/ (* (abs dy) n) (abs dx)))) (setq cd (gcd n ratio)) (setq n (/ n cd)) (setq ratio (/ ratio cd)) (setq nrat (round (/ (abs dx) n))) (setq delx (* (signum dx) nrat n)) (setq dely (* (signum dy) nrat ratio)) )) (window-draw-line-xy w (+ orgx delx) (+ orgy dely) orgx orgy)) ) )) ; 31 Dec 93 ; Reset window colors to default foreground and background. (gldefun window-reset-color ((w window)) (XSetForeground *window-display* (gcontext w) *default-fg-color*) (XSetBackground *window-display* (gcontext w) *default-bg-color*) ) ; 31 Dec 93; 04 Jan 94; 05 Jan 94 ; Set color to be used in a window to specified red/green/blue values. ; Values of r, g, b are integers on scale of 65535. ; Background is t if the background color is to be set, else foreground is set. ; Returns an xcolor. (defun window-set-color-rgb (w r g b &optional background) (let (ret) (or *window-xcolor* (setq *window-xcolor* (Make-Xcolor))) (set-Xcolor-red *window-xcolor* (+ r 0)) (set-Xcolor-green *window-xcolor* (+ g 0)) (set-Xcolor-blue *window-xcolor* (+ b 0)) (setq ret (XAllocColor *window-display* *default-colormap* *window-xcolor*)) (if (not (eql ret 0)) (window-set-xcolor w *window-xcolor* background)) )) ; 05 Jan 94 (defun window-set-xcolor (w &optional xcolor background) (if background (window-set-background w (XColor-Pixel xcolor)) (window-set-foreground w (XColor-Pixel xcolor))) xcolor) ; 03 Jan 94 (defun window-set-color (w rgb &optional background) (window-set-color-rgb w (first rgb) (second rgb) (third rgb) background) ) ; 31 Dec 93; 03 Jan 94; 05 Jan 94 ; Free the last xcolor used (defun window-free-color (w &optional xcolor) (or xcolor (setq xcolor *window-xcolor*)) (if xcolor (unless (or (eql xcolor *default-fg-color*) (eql xcolor *default-bg-color*)) (XFreeColors *window-display* *default-colormap* xcolor 1 0)) ) ) ; 31 Dec 93; 18 Jul 96; 25 Jul 96 ; Get characters or mouse clicks within a window, calling function fn ; with arguments (char button x y args). ; Tracking continues until fn returns non-nil; result is that value. (defun window-get-chars (w fn &optional args) (let (win res) (or *window-keyinit* (window-init-keymap)) (setq *window-shift* nil) (setq *window-ctrl* nil) (setq *window-meta* nil) (setq win (window-parent w)) (Xsync *window-display* 1) ; clear event queue of prev motion events (Xselectinput *window-display* win (+ KeyPressMask KeyReleaseMask ButtonPressMask)) ;; Event processing loop: stop when function returns non-nil. (while (null res) (XNextEvent *window-display* *window-event*) (let ((type (XAnyEvent-type *window-event*)) (eventwindow (XAnyEvent-window *window-event*))) (if (eql eventwindow win) (setq res (window-process-char-event w type fn args))) )) res)) ; 31 Dec 93; 18 Jan 94; 04 Oct 94; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96 ; 25 Jul 96; 08 Sep 06 ; Process a character event. type is event type. ; For Control, Shift, and Meta, global flags are set. ; (fn char button x y) is called for other characters. (defun window-process-char-event (w type fn args) (let (code) (if (eql type KeyRelease) (progn (setq code (XButtonEvent-button *window-event*)) (if (member code *window-shift-keys*) (setq *window-shift* nil) (if (member code *window-control-keys*) (setq *window-ctrl* nil) (if (member code *window-meta-keys*) (setq *window-meta* nil))))) (if (eql type KeyPress ) (progn (setq code (XButtonEvent-button *window-event*)) (if (member code *window-shift-keys*) (progn (setq *window-shift* t) nil) (if (member code *window-control-keys*) (progn (setq *window-ctrl* t) nil) (if (member code *window-meta-keys*) (progn (setq *window-meta* t) nil) (funcall fn w (window-char-decode code) 0 0 0 args) )))) (if (eql type ButtonPress) (funcall fn w 0 (XButtonEvent-button *window-event*) (XMotionEvent-x *window-event*) (- (window-drawable-height w) (XMotionEvent-y *window-event*)) args)) ) ) )) ; 23 Jul 96; 23 Dec 96 ; Change keyboard code into character; assumes ASCII for control chars (defun window-char-decode (code) (let (char) (setq char (aref (if *window-shift* *window-shiftkeymap* *window-keymap*) code)) (if (and char *window-ctrl*) (setq char (code-char (- (char-code (char-upcase char)) 64)))) (if (and char *window-meta*) ; simulate meta using 128 (setq char (code-char (+ (char-code (char-upcase char)) 128)))) (or char #\Space) )) ; 31 Dec 93; 04 Oct 94; 16 Nov 94 ; Get character within a window, calling function fn with arg (char). ; Tracking continues until fn returns non-nil; result is that value. (defun window-get-raw-char (w) (let (win res) (or *window-keyinit* (window-init-keymap)) (setq *window-shift* nil) (setq *window-ctrl* nil) (setq *window-meta* nil) (setq win (window-parent w)) (Xsync *window-display* 1) ; clear event queue of prev motion events (Xselectinput *window-display* win (+ KeyPressMask KeyReleaseMask)) ;; Event processing loop: stop when function returns non-nil. (while (null res) (XNextEvent *window-display* *window-event*) (let ((type (XAnyEvent-type *window-event*)) (eventwindow (XAnyEvent-window *window-event*))) (if (and (eql eventwindow win) (eql type KeyPress)) (setq res (XButtonEvent-button *window-event*)) ) )) res)) ; 31 Dec 93; 19 Jul 96; 12 Aug 96; 13 Aug 96 ; Input a string from keyboard, echo in window. str is initial string. ; Backspace is handled; terminate with return. Size is max width in pixels. (defun window-input-string (w str x y &optional size) (car (window-edit w x y (or size 100) 16 (list (or str "")) nil t t) ) ) ; 19 Jul 96; 22 Jul 96; 12 Aug 96; 13 Aug 96 ; Edit strings in a window area with Emacs-subset editor ; strings is a list of strings, which is the return value ; scroll is number of lines to scroll down before displaying text, ; or t to have one line only and terminate on return. ; endp is T to begin edit at end of first line ; e.g. (window-draw-box-xy myw 48 48 204 204) ; (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good")) (gldefun window-edit (w x y width height &optional strings boxflg scroll endp) (let (em) (em = (editmenu-create width height nil w x y nil t '9x15 boxflg strings scroll endp)) (edit em) (carat em) ; erase the carat (text em) )) ; 25 Jul 96; 26 Jul 96; 12 Aug 96; 13 Aug 96; 15 Aug 96; 17 May 04 ; (setq em (editmenu-create 200 30 nil myw 50 50 t t '9x15 t ("Rutabagas"))) ; Simple call from plain Lisp to make an edit menu. (setf (glfnresulttype 'editmenu-create) 'editmenu) (gldefun editmenu-create ((width integer) (height integer) &optional title (parentw window) x y (perm boolean) (flat boolean) (font symbol) (boxflg boolean) (initial-text (listof string)) scrollval (endp boolean)) (an editmenu with title = (if title (stringify title) "") menu-window = (if flat parentw) parent-window = (if parentw (parent parentw)) parent-offset-x = (or x 0) parent-offset-y = (or y 0) permanent = perm flat = flat drawing-width = width drawing-height = height menu-font = (font or '9x15) boxflg = boxflg text = (or initial-text (list "")) scrollval = (or scrollval 0) line = (if (numberp scrollval) scrollval 0) column = (if endp (length (car (nthcdr (if (numberp scrollval) scrollval 0) initial-text))) 0)) ) ; 25 Jul 96 (gldefun editmenu-calculate-size ((m editmenu)) ((picture-width m) = (drawing-width m)) ((picture-height m) = (drawing-height m)) ) ; 18 Apr 95 ; Initialize a picture menu (gldefun editmenu-init ((m editmenu)) (let () (calculate-size m) (adjust-offset m) (if ~ (flat m) ((menu-window m) = (window-create (picture-width m) (picture-height m) ((title m) or "") (parent-window m) (parent-offset-x m) (parent-offset-y m) (menu-font m) )) ) )) ; 25 Jul 96; 31 July 96; 14 Aug 96 (gldefun editmenu-draw ((m editmenu)) (let (mw xzero yzero) (init? m) (mw = (menu-window m)) (open mw) (clear m) (xzero = (menu-x m 0)) (yzero = (menu-y m 0)) (if (boxflg m) (draw-box-xy mw xzero yzero (picture-width m) (picture-height m) 1)) (display m 0 0 (not (numberp scrollval))) )) ; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 31 July 96; 01 Aug 96; 17 May 04 ; 18 Aug 04; 27 Jan 06 ; Display contents of edit area ; Begin with the specified line and char number; one line only if only is T. (gldefun editmenu-display ((m editmenu) line char only) (let (lines y maxwidth linewidth (w (menuw m))) (setq lines (nthcdr line (text m))) (setq y (line-y m (- line (scroll m)))) (setq maxwidth (truncate (- (picture-width m) 6) (font-width (menuw m)))) (while (and lines (>= y (menu-y m 4))) (when (< char maxwidth) (if (> char 0) (printat-xy w (subseq (first lines) char (min maxwidth (length (first lines)))) (menu-x m (+ 2 (* char (font-width (menuw m))))) y) (printat-xy w (if (<= (length (first lines)) maxwidth) (first lines) (subseq (first lines) 0 maxwidth)) (menu-x m 2) y))) (setq linewidth (+ 2 (* (font-width (menuw m)) (length (first lines))))) (window-erase-area-xy w (menu-x m linewidth) (- y 2) (- (picture-width m) (+ linewidth 2)) (font-height (menuw m))) (y _- (font-height (menuw m))) (if only (setq lines nil) (progn (pop lines) (if (and (null lines) (>= y (menu-y m 4))) ; erase an extra line at the end (window-erase-area-xy w (menu-x m 2) (- y 2) (- (picture-width m) 4) (font-height (menuw m))) ) )) (setq char 0) ) (force-output w) )) ; 19 Jul 96; 22 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96 ; draw/erase carat at the specified position (gldefun editmenu-carat ((m editmenu)) (let ((w (menuw m))) (draw-carat w (menu-x m (+ 2 (* (column m) (font-width (menuw m))))) (- (line-y m (line m)) 2)) (force-output w) )) ; 19 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96; 17 May 04 ; erase at the current position. onep = t to erase only one char (gldefun editmenu-erase ((m editmenu) onep) (let ((w (menuw m)) xw) (xw = (+ 2 (* (font-width w) (column m)))) (erase-area-xy w (menu-x m xw) (- (line-y m (line m)) (cadr (string-extents w "Tg"))) (if onep (font-width w) (- (picture-width m) xw)) (font-height w)) (force-output w) )) ; 01 Aug 96 ; Calculate the y position of the current line (gldefun editmenu-line-y ((m editmenu) (line integer)) (menu-y m (- (picture-height m) (+ -1 (* (font-height (menuw m)) (1+ (- line (scroll m))))))) ) ; 25 Jul 96; 30 Jul 96; 31 Jul 96; 01 Aug 96; 13 Aug 96; 24 Sep 96; 08 Jan 97 ; 17 May 04 (gldefun editmenu-select ((m editmenu) &optional inside) (let (mw codeval res xval yval) (mw = (menuw m)) (if ~ (permanent m) (draw m)) (track-mouse mw #'(lambda (x y code) (setq *window-menu-code* code) (if (or (> code 0) (x < (parent-offset-x m)) (x > (+ (parent-offset-x m) (picture-width m))) (y < (parent-offset-y m)) (y > (+ (parent-offset-y m) (picture-height m)))) (progn (codeval = code) (xval = x) (yval = y)) )) t) ; (if (and (not (permanent m)) (not (flat m)) (close (menu-window m)))) ; ?? (if (codeval > 0) (editmenu-edit m codeval xval yval)) )) (defvar *window-editmenu-kill-strings* nil) ; 13 Aug 96; 15 Aug 96 ; begin active editing of an editmenu. ; (code x y), if present, represent a mouse click in the window. (gldefun editmenu-edit ((m editmenu) &optional code x y) (let ((mw (menuw m))) (draw m) (carat m) (if code (editmenu-edit-fn mw nil code x y (list m)) ) (setq *window-editmenu-kill-strings* nil) (window-get-chars mw #'editmenu-edit-fn (list m)) (text m) )) ; 31 Dec 93; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 26 Jul 96 ; 30 Jul 96; 13 Aug 96; 14 Aug 96; 23 Dec 96; 17 May 04; 18 May 04 ; Process input characters and mouse clicks for editmenu eidting (gldefun editmenu-edit-fn ((w window) char (button integer) (buttonx integer) (buttony integer) args) (let (m\:editmenu inside done) (m = (car args)) (carat m) ; erase carat (if (and (numberp button) (not (zerop button))) (progn (inside = (editmenu-setxy m buttonx buttony)) (case button (1 (if inside (progn (carat m) nil) ; return nil to continue input t)) ; quit on click outside the editing area (2 (if inside (progn (editmenu-yank m) (carat m) nil)) ))) (progn (if (< (char-code char) 32) (case char of (#\Return (if (numberp (scrollval m)) (editmenu-return m) (done = t)) ) (#\Backspace (editmenu-backspace m)) (#\^D (editmenu-delete m)) (#\^N (if (numberp (scrollval m)) (editmenu-next m))) (#\^P (editmenu-previous m)) (#\^F (editmenu-forward m)) (#\^B (editmenu-backward m)) (#\^A (editmenu-beginning m)) (#\^E (editmenu-end m)) (#\^K (editmenu-kill m)) (#\^Y (editmenu-yank m)) else nil) (if (> (char-code char) 128) (progn (setq char (code-char (- (char-code char) 128))) (case char of (#\B (editmenu-meta-b m)) (#\F (editmenu-meta-f m)) else nil)) (editmenu-char m char))) (carat m) done) ))) ; return nil to continue input ; 31 Jul 96; 15 Aug 96; 17 May 04 ; Set cursor location based on mouse click; returns T if inside menu region (gldefun editmenu-setxy ((m editmenu) (buttonx integer) (buttony integer)) (let (linecons okay) (setq okay (and (>= buttonx (parent-offset-x m)) (<= buttonx (+ (parent-offset-x m) (picture-width m))) (>= buttony (parent-offset-y m)) (<= buttony (+ (parent-offset-y m) (picture-height m))) )) (if okay (progn ((line m) = (min (1- (length (text m))) (+ (scroll m) (truncate (- (menu-y m (- (picture-height m) 6)) buttony) (font-height (menuw m)))))) (linecons = (nthcdr (line m) (text m))) ((column m) = (min (length (car linecons)) (truncate (- buttonx (menu-x m 2)) (font-width (menuw m))))) )) okay)) ; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04 ; Process an ordinary input character (gldefun editmenu-char ((m editmenu) char) (let ((linecons (nthcdr (line m) (text m))) ) (if (<= (length (car linecons)) (column m)) ((car linecons) = ; insert char at end of line (concatenate 'string (car linecons) (string char))) ((car linecons) = ; insert char in middle of line (concatenate 'string (subseq (car linecons) 0 (column m)) (string char) (subseq (car linecons) (column m)))) ) (display m (line m) (column m) t) ((column m) _+ 1) )) ; 23 Dec 96 ; Get the current character in an editment (gldefun editmenu-current-char ((m editmenu)) (let ((linecons (nthcdr (line m) (text m))) ) (char (car linecons) (column m)) )) ; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04 ; Process a Return character (gldefun editmenu-return ((m editmenu)) (let ((linecons (nthcdr (line m) (text m)))) (if (<= (length (car linecons)) (column m)) ((cdr linecons) = (cons "" (cdr linecons))) ; end of line (progn ((cdr linecons) = (cons (subseq (car linecons) (column m)) (cdr linecons))) ((car linecons) = (subseq (car linecons) 0 (column m))))) (display m (line m) 0 nil) ((line m) _+ 1) ((column m) = 0) )) ; 19 Jul 96; 22 Jul 96; 25 Jul 96; 30 Jul 96; 31 Jul 96; 17 May 04 ; Process a backspace (gldefun editmenu-backspace ((m editmenu)) (let (tmp linedel (linecons (nthcdr (line m) (text m)))) (if (> (column m) 0) (progn ((column m) _- 1) ; middle/end of line ((car linecons) = (concatenate 'string (subseq (car linecons) 0 (column m)) (subseq (car linecons) (1+ (column m)))))) (if (> (line m) 0) (progn ((line m) _- 1) (linedel = t) (linecons = (nthcdr (line m) (text m))) ((column m) = (length (car linecons))) (tmp = (concatenate 'string (car linecons) (cadr linecons))) ((cdr linecons) = (cddr linecons)) ((car linecons) = tmp) ) )) (display m (line m) (column m) (not linedel)) )) ; 23 Jul 96; 25 Jul 96 ; Move cursor to end of line: C-E (gldefun editmenu-end ((m editmenu)) (let ((linecons (nthcdr (line m) (text m))) ) ((column m) = (length (car linecons))) )) ; 23 Jul 96; 25 Jul 96 ; Move cursor to beginning of line: C-A (gldefun editmenu-beginning ((m editmenu)) ((column m) = 0)) ; 22 Jul 96; 25 Jul 96; 14 Aug 96; 17 May 04 ; Move cursor forward: C-F (gldefun editmenu-forward ((m editmenu)) (let ((linecons (nthcdr (line m) (text m)))) (if (< (column m) (length (car linecons))) ((column m) _+ 1) (if (numberp (scrollval m)) (progn ((line m) _+ 1) (if (null (cdr linecons)) ((cdr linecons) = (list ""))) ((column m) = 0)) ) ))) ; 23 Dec 96; 17 May 04 ; Move cursor forward over a word: M-F (gldefun editmenu-meta-f ((m editmenu)) (let (found done) (while (and (or (< (line m) (1- (length (text m)))) (< (column m) (length (nth (line m) (text m))))) (not found)) (if (editmenu-alphanumbericp (editmenu-current-char m)) (found = t) (editmenu-forward m) ) ) (if found (while (and (or (< (line m) (1- (length (text m)))) (< (column m) (length (nth (line m) (text m))))) (not done)) (if (editmenu-alphanumbericp (editmenu-current-char m)) (editmenu-forward m) (done = t) )) ) )) ; 23 Dec 96 ; alphanumbericp not defined in gcl (defun editmenu-alphanumbericp (x) (or (alpha-char-p x) (not (null (digit-char-p x)))) ) ; 22 Jul 96; 25 Jul 96 ; Move cursor to next line: C-N (gldefun editmenu-next ((m editmenu)) (let ((linecons (nthcdr (line m) (text m)))) ((line m)_+ 1) (if (null (cdr linecons)) ((cdr linecons) = (list ""))) (setq linecons (cdr linecons)) ((column m) = (min (column m) (length (car linecons)))) )) ; 22 Jul 96; 23 Jul 96; 25 Jul 96; 30 Jul 96; 17 May 04 ; Move cursor backward: C-B (gldefun editmenu-backward ((m editmenu)) (if (> (column m) 0) ((column m) _- 1) (if (> (line m) 0) (progn ((line m) _- 1) ((column m) = (length (nth (line m) (text m)))) ) ) )) ; 23 Dec 96; 17 May 04 ; Move cursor backward over a word: M-B (gldefun editmenu-meta-b ((m editmenu)) (let (found done) (while (and (or (> (column m) 0) (> (line m) 0)) (not found)) (editmenu-backward m) (if (editmenu-alphanumbericp (editmenu-current-char m)) (found = t))) (if found (progn (while (and (or (> (column m) 0) (> (line m) 0)) (not done)) (if (editmenu-alphanumbericp (editmenu-current-char m)) (editmenu-backward m) (done = t) )) (unless (editmenu-alphanumbericp (editmenu-current-char m)) (editmenu-forward m)) ) ))) ; 22 Jul 96; 23 Jul 96; 25 Jul 96; 17 May 04 ; Move cursor to previous line: C-P (gldefun editmenu-previous ((m editmenu)) (if (> (line m) 0) (progn ((line m) _- 1) ((column m) = (min (column m) (length (nth (line m) (text m)))))))) ; 23 Jul 96; 25 Jul 96 ; Delete character ahead of cursor: C-D (gldefun editmenu-delete ((m editmenu)) (editmenu-forward m) (editmenu-backspace m)) ; 31 Jul 96; 17 May 04 (gldefun editmenu-kill ((m editmenu)) (let ((linecons (nthcdr (line m) (text m)))) (if ((column m) < (length (car linecons))) (progn (setq *window-editmenu-kill-strings* (list (subseq (car linecons) (column m)))) ((car linecons) = (subseq (car linecons) 0 (column m))) (display m (line m) (column m) t)) (editmenu-delete m) ) )) ; 31 Jul 96; 01 Aug 96; 17 May 04 (gldefun editmenu-yank ((m editmenu)) (let ((linecons (nthcdr (line m) (text m))) (col (column m))) (when *window-editmenu-kill-strings* (if (<= (length (car linecons)) (column m)) (progn ((car linecons) = ; insert at end of line (concatenate 'string (car linecons) (car *window-editmenu-kill-strings*))) ((column m) = (length (car linecons)))) (progn ((car linecons) = ; insert in middle of line (concatenate 'string (subseq (car linecons) 0 col) (car *window-editmenu-kill-strings*) (subseq (car linecons) col))) ((column m) _+ (length (car *window-editmenu-kill-strings*))) )) (display m (line m) col t) ) )) ; 31 Dec 93; 19 Jul 96 ; Draw a carat symbol /\ centered at x and with top at y. (defun window-draw-carat (w x y) (window-set-xor w) (window-draw-line-xy w (- x 5) (- y 2) x y) (window-draw-line-xy w x y (+ x 5) (- y 2)) (window-unset w) (window-force-output w) ) ; 31 Dec 93; 04 Oct 94; 15 Nov 94; 16 Nov 94; 14 Mar 95; 25 Jun 06 ; Initialize mapping between keys and ASCII. (defun window-init-keymap () (let (mincode maxcode keycode keysym keynum shiftkeynum char) ; Get the min and max keycodes for this keyboard (XDisplayKeycodes *window-display* *min-keycodes-return* *max-keycodes-return*) (setq mincode (int-pos *min-keycodes-return* 0)) (setq maxcode (int-pos *max-keycodes-return* 0)) (setq *window-keymap* (make-array (1+ maxcode) :initial-element nil)) (setq *window-shiftkeymap* (make-array (1+ maxcode) :initial-element nil)) (setq *window-shift-keys* nil) (setq *window-control-keys* nil) (setq *window-meta-keys* nil) ; Get the ASCII corresponding to these keycodes (dotimes (i (1+ (- maxcode mincode))) (setq keycode (+ i mincode)) (setq keysym (XGetKeyboardMapping *window-display* keycode 1 *keycodes-return*)) (setq keynum (fixnum-pos keysym 0)) ; ascii integer code (setq shiftkeynum (fixnum-pos keysym 1)) ; (XFree keysym) ; ***** commented out -- causes error on Sun ; Following is a Kludge (TM) for Sun keyboard (if (and (>= keynum 65) (<= keynum 90) (eql shiftkeynum NoSymbol)) (progn (setq shiftkeynum keynum) (setq keynum (+ keynum 32)))) (if (> keynum 0) (if (setq char (window-code-char keynum)) (setf (aref *window-keymap* keycode) char) (if (> keynum 256) (cond ((or (eql keynum XK_Shift_R) (eql keynum XK_Shift_L)) (push keycode *window-shift-keys*)) ((or (eql keynum XK_Control_L) (eql keynum XK_Control_R)) (push keycode *window-control-keys*)) ((or (eql keynum XK_Alt_R) (eql keynum XK_Alt_L)) (push keycode *window-meta-keys*)))))) (if (> shiftkeynum 0) (if (setq char (window-code-char shiftkeynum)) (setf (aref *window-shiftkeymap* keycode) char) )) ) (setq *window-keyinit* t) )) ; signify initialization done ; 15 Nov 94 (defun window-code-char (code) (if (> code 0) (if (< code 256) (code-char code) (cond ((eql code XK_Return) #\Return) ((eql code XK_Tab) #\Tab) ((eql code XK_BackSpace) #\Backspace)) ) ) ) ; 14 Dec 90; 12 Aug 91; 09 Oct 91; 09 Sep 92; 04 Aug 93; 06 Oct 94 ; Compile the dwindow file into a plain Lisp file (defun compile-dwindow () (glcompfiles *directory* '("glisp/vector.lsp") ; auxiliary files '("X/dwindow.lsp") ; translated files "X/dwtrans.lsp" ; output file "X/dwhead.lsp" ; header file '(glfnresulttype glmacro glispobjects glispconstants glispglobals compile-dwindow compile-dwindowb)) (compile-file (concatenate 'string *directory* "X/dwtrans.lsp")) ) (defun compile-dwindowb () (glcompfiles *directory* '("glisp/vector.lsp") ; auxiliary files '("X/dwindow.lsp") ; translated files "X/dwtransb.lsp") ; output file (compile-file (concatenate 'string *directory* "X/dwtransb.lsp")) ) ; Note: when compiling dwtrans.lsp, be sure glmacros.lsp is loaded. gcl-2.6.14/xgcl-2/README0000644000175000017500000001145614360276512012756 0ustar cammcammREADME for xgcl: Gnu Common Lisp interface to X windows. 28 Aug 2006 Distributed under GNU Public License; copyright notices at the bottom. xgcl is an interface from Gnu Common Lisp to the X library, Xlib. This software provides a lightweight and fairy easy-to-use way to: * Draw diagrams from Lisp * Create interactive graphical interfaces * Make the interactive Lisp interfaces available via the Web Beginning with release 2.6.8, xgcl is built into the make of GCL. There is a "raw" interface to the Xlib, and an "easy-to-use" interface built on top of it; we will only discuss the "easy-to-use" version. To use xgcl, start GCL and enter: (xgcl) This will load xgcl and print a message inviting you to try (xgcl-demo). (xgcl-demo) will create a small window and draw some examples in it. You can try (wtestc), (wtestd), ... (wtestk) to try some other things. The xgcl files are located in the directory xgcl-2/ relative to the GCL directory. The file gcl_dwtest.lsp contains the test examples; one way to get started quickly is by using this file for examples. There is also documentation: dwdoc.tex dwdoc.dvi dwdoc.html http://www.cs.utexas.edu/users/novak/dwdoc.html dwdoc.pdf dwdoc.ps To use the basic xgcl, you only need to invoke (xgcl). To use some of the more advanced features such as menu-set, described below, also load the file gcl_dwimportsb.lsp immediately after invoking (xgcl), to import symbols. Additional files that may be useful: gcl_menu-set.lsp Source and some comments for menu-set gcl_menu-settrans.lsp menu-set translated to Common Lisp gcl_pcalc.lsp Pocket calculator example gcl_draw-gates.lsp Draw boolean gate symbols gcl_draw.lsp Interactive drawing program source gcl_drawtrans.lsp Drawing program translated to Common Lisp gcl_dwindow.lsp Easy-to-use interface source with comments gcl_dwtrans.lsp Easy-to-use interface translated to Common Lisp gcl_editors.lsp Editors for colors etc. gcl_editorstrans.lsp Editors translated to Common Lisp gcl_ice-cream.lsp Example created using Draw lispserver.lsp Example web demo: a Lisp server lispservertrans.lsp Lisp server translated to Common Lisp Xakcl.paper Documentation on the "raw" Xlib interface Xakcl.example.lsp some PRIMITIVE examples This software provides a way to interface Lisp programs to the Web; see: http://www.cs.utexas.edu/users/novak/dwindow.html There are two ways to accomplish a Web interface. The first uses X directly, and requires that the user have an X server; this is reliable and fast, but it only works for the Linux/Mac/Cygwin subset of the world. There can also be firewall issues. The other option uses WeirdX, an X server written in Java. The WeirdX interface is often slow, and sometimes doesn't work at all, but when it works, it works with any web browser, even on Windows. The WeirdX interface tends to leave "mouse droppings" on interactive drawings. There are numerous examples of these web interfaces at: http://www.cs.utexas.edu/users/novak/ The Draw demo is a good one to try. --------------------------------------------------------------------------- Copyright (c) 2006 Gordon S. Novak Jr., Hiep Huu Nguyen, William F. Schelter, Camm Maguire, and The University of Texas at Austin. Copyright 1987 by Digital Equipment Corporation and Massachusetts Institute of Technology. See the files gnu.license and dec.copyright for copyright details. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Some of the files that interface to the Xlib are adapted from DEC/MIT files. See the file dec.copyright for details. Written by: Gordon S. Novak Jr., Hiep Huu Nguyen, and William F. Schelter, Department of Computer Sciences, University of Texas at Austin 78712, and Camm Maguire. Xgcl is an interface from Gnu Common Lisp to the X library, Xlib, adapted from X Consortium code by Hiep Huu Nguyen (hiep@cs.utexas.edu). dwindow.lsp is an "easy to use" interface from Lisp to the Xlib, written by Gordon S. Novak Jr. (novak@cs.utexas.edu) It is written in GLISP and has been translated into the Common Lisp file dwtrans.lsp, which is incorporated into the make of Xgcl. gcl-2.6.14/xgcl-2/.gitignore0000644000175000017500000000006514360276512014060 0ustar cammcammgcl_*.c gcl_*.h dwdoc.aux dwdoc.log dwdoc.pdf dwdoc/ gcl-2.6.14/xgcl-2/dwdoc/0000755000175000017500000000000014360276512013167 5ustar cammcammgcl-2.6.14/xgcl-2/dwdoc/dwdoc1.html0000644000175000017500000011314414360276512015242 0ustar cammcamm dwdoc p. 1

    Interface from GCL to X Windows

    Department of Computer Sciences
    University of Texas at Austin
    Austin, TX 78712

    Software copyright   by Gordon S. Novak Jr. and The University of Texas at Austin. Distribution and use are allowed under the Gnu Public License. Also see the copyright section at the end of this document for the copyright on X Consortium software.

    Introduction

    This document describes a relatively easy-to-use interface between XGCL (X version of Gnu Common Lisp) and X windows. The interface consists of several parts:

    1. Hiep Huu Nguyen has written (and adapted from X Consortium software) an interface between GCL and Xlib, the X library in C. Xlib functions can be called directly if desired, but most users will find the dwindow functions easier to use. There is little documentation of these functions, but the Xlib documentation can be consulted, and the dwindow functions can be examined as examples.

    2. The dwindow functions described in this document, which call the Xlib functions and provide an easier interface for Lisp programs.

    3. It is possible to make an interactive graphical interface within a web page; this is described in a section below.
    The source file for the interface (written in GLISP) is dwindow.lsp; this file is compiled into a file in plain Lisp, dwtrans.lsp. dwtrans.lsp is compiled as part of XGCL.

    The functions in this package use the convention that the coordinate (0 0) is the lower-left corner of a window, with positive y being upward. This is different from the convention used by X, which assumes that (0 0) is the upper left corner and that positive y is downward.

    In the descriptions below, some function arguments are shown with a type, e.g. arg:type, to indicate the expected type of the argument. The type vector is a list (x y) of integers. The argument w that is used with many functions is of type window ( window is a Lisp data structure used by the dwindow functions).

    Both the Xlib and dwindow functions are in the package xlib:. In order to use these functions, the Lisp command (use-package 'xlib) should be used to import the dwindow symbols.

    Examples and Utilities

    dwtest

    The file dwtest.lsp contains example functions that illustrate the use of the dwindow package. The function call (wtesta) creates a small window for testing. (wtestb) through (wtestk) perform drawing and mouse interaction tests using the window. These functions may be consulted as examples of the use of commonly used dwindow functions.

    pcalc

    The file pcalc.lsp implements a pocket calculator as a picmenu; its entry is (pcalc).

    draw

    The file drawtrans.lsp contains an interactive drawing program; its entry is (draw 'foo) where foo is the name of the drawing. The file ice-cream.lsp can be loaded, followed by (draw 'ice-cream) to examine an example drawing. draw can produce a Lisp program or a set of commands to recreate the drawing; use origin to zero before making a program. (draw-out file names) will write definitions of drawings in the list names to the file file.

    editors

    The file editorstrans.lsp contains some interactive editing programs; it is a translation of the file editors.lsp . One useful editor is the color editor; after entering (wtesta) (in file dwtest.lsp), enter (edit-color myw) to edit a color. The result is an rgb list as used in window-set-color.

    A simple line editor and an Emacs-like text editor are described in sections texted and emacsed below.

    Menus

    The function menu provides an easy interface to make a pop-up menu, get a selection from it, and destroy it:

             (menu items &optional title)

    Example: (menu '(red white blue))

    This simple call is all that is needed in most cases. More sophisticated menu features are described below.

    The items in a menu is a list; each item may be a symbol, a cons of a symbol or string and the corresponding value, or a cons of a function name and the corresponding value. In the latter case, the function is expected to draw the corresponding menu item.

    If a function name is specified as the first element of a menu item, the drawing function should have arguments (fn w x y), where w is the window and x and y are the lower-left corner of the drawing area. The property list of the function name should have the property display-size, which should be a list (width height) in pixels of the displayed symbol.

    Menus can be associated with a particular window; if no window is specified, the menu is associated with the window where the mouse cursor is located when the menu is initialized (which might not be a Lisp user's window). If a menu is associated with a user window, it may be permanent (left displayed after a selection is made) and may be flat (drawn directly on the containing window, rather than having its own window).

    A menu can be created by menu-create :

             (menu-create items &optional title w:window x y perm flat font)

    title, if specified, is displayed over the menu. w is an existing window; if specified, the menu is put within this window at the x y offsets specified (adjusted if necessary to keep the menu inside the window). If no w is specified, or if x is nil, the menu is put where the cursor is the first time the menu is displayed. perm is non- nil if the menu is to be permanent, i.e., is to be left displayed after a selection has been made. flat is non- nil if the menu is to be drawn directly on the containing window. font is a symbol or string that names the font to be used; the default is a 9x15 typewriter font.

    The menu is returned as the value of menu-create. Such a menu can be saved; selections can be made from a menu m as follows:

             (menu-select m &optional inside) or          (menu-select! m)

    menu-select will return nil if the mouse is clicked outside the menu, or is moved outside after it has been inside (or if inside is not nil), provided that the menu is contained within a user-created window. menu-select! requires that a choice be made.

    In order to avoid wasting storage, unused menus should be destroyed: (menu-destroy m). The simple menu function destroys its menu after it is used.

             (menu-size m)
             (menu-moveto-xy m x y)
             (menu-reposition m)

    menu-reposition will reposition a flat menu within its parent window by allowing the user to position a ghost box using the mouse. menu-size returns the size of the menu as a vector, (x y). menu-moveto-xy adjusts the offsets to move a flat menu to the specified position within its parent window. These functions and menu-destroy work for picmenus and barmenus as well.

             (menu-item-position m name &optional location)

    menu-item-position returns a vector (x y) that gives the coordinates of the menu item whose name is name. location may be center, left, right, top, or bottom; the default is the lower-left corner of the menu item. center specifies the center of the box containing the menu item; the other location values are at the center of the specified edge of the box.

    Picmenus

    A picmenu (picture menu) is analogous to a menu, but involves a user-defined picture containing sensitive spots or ``buttons''. The test function (wteste) shows an example of a picmenu. A picmenu is created by:

             (picmenu-create buttons width height drawfn
             &optional title dotflg w:window x y perm flat font boxflg)

    If a picmenu is to be used more than once, the common parts can be made into a picmenu-spec and reused:

             (picmenu-create-spec buttons width height drawfn
             &optional dotflg font)

             (picmenu-create-from-spec spec:picmenu-spec
             &optional title w:window x y perm flat boxflg)

    width and height are the size of the area occupied by the picture. (drawfn w x y) should draw the picture at the offset x y. Note that the draw utility can be used to make the drawing function, including picmenu buttons. dotflg is non- nil if it is desired that small boxes be automatically added to the sensitive points when the picture is drawn. boxflg is non- nil if a box is to be drawn around the picmenu when the picture is drawn (this is only needed for flat picmenus). If perm is non-nil, the drawing program is not called when a selection is to be made, so that an external program must draw the picmenu; this avoids the need to redraw a complex picture. The remaining arguments are as described for menus.

    Each of the buttons in a picmenu is a list:

             (buttonname offset size highlightfn unhighlightfn)

    buttonname is the name of the button; it is the value returned when that button is selected. offset is a vector (x y) that gives the offset of the center of the button from the lower-left corner of the picture. The remainder of the button list may be omitted. size is an optional list (width height) that gives the size of the sensitive area of the button; the default size is (12 12). (highlightfn w x y) and (unhighlightfn w x y) (where (x y) is the center of the button in the coordinates of w) are optional functions to highlight the button area when the cursor is moved into it and unhighlight the button when the cursor is moved out; the default is to display a box of the specified size.

             (picmenu-select m &optional inside)
    If the picmenu is not flat, its window should be destroyed following the selection using menu-destroy.

             (picmenu-item-position m name &optional location)

             (picmenu-delete-named-button m name:symbol)
    This deletes a button from a displayed picmenu. The set of deleted buttons is reset to nil when the picmenu is drawn.

    Barmenus

    A barmenu displays a bar graph whose size can be adjusted using the mouse.

             (barmenu-create maxval initval barwidth
             &optional title horizontal subtrackfn subtrackparms
             parentw x y perm flat color)

    A value is selected by: (barmenu-select m:barmenu &optional inside)
    If the barmenu is not flat, its window should be destroyed following the selection using menu-destroy.

    The user must first click the mouse in the bar area; then the size of the displayed bar is adjusted as the user moves the mouse pointer. In addition, the subtrackfn is called with arguments of the size of the bar followed by the subtrackparms; this can be used, for example, to display a numeric value in addition to the bar size.

    Menu Sets and Menu Conns

    A menu-set is a set of multiple menus, picmenus, or barmenus that are simultaneously active within the same window. Menu-sets can be used to implement graphical user interfaces. A menu-conns is a menu-set that includes connections between menus; this can be used to implement interfaces that allow the user to construct a network from components.

    The source file for menu-sets is the GLISP file menu-set.lsp; this file is translated as part of the file drawtrans.lsp in plain Lisp. Examples of the use of menu sets are given at the top of the file menu-set.lsp. In the following descriptions, ms is a menu-set and mc is a menu-conns.

             (menu-set-create w) creates a menu set to be displayed in the window w.

             (menu-set-name symbol) makes a gensym name that begins with symbol.

             (menu-set-add-menu ms name:symbol sym title items
             &optional offset:vector)

    This function adds a menu to a menu-set. sym is arbitrary information that is saved with the menu.

             (menu-set-add-picmenu ms name sym title spec:picmenu-spec
             &optional offset:vector nobox)

             (menu-set-add-component ms name &optional offset:vector)

    This adds a component that has a picmenu-spec defined on the property list of name.

             (menu-set-add-barmenu ms name sym barmenu title
             &optional offset:vector)

             (menu-set-draw ms) draws all the menus.

             (menu-set-select ms &optional redraw enabled)

    menu-set-select gets a selection from a menu-set. If redraw is non- nil, the menu-set is drawn. enabled may be a list of names of menus that are enabled for selection. The result is (selection menu-name), or ((x y) BACKGROUND button) for a click outside any menu.

             (menu-conns-create ms) creates a menu-conns from a menu-set.

             (menu-conns-add-conn mc)

    This function allows the user to select two ports from menus of the menu-conns. It then draws a line between the ports and adds the connection to the connections of the menu-conns.

             (menu-conns-move mc)

    This function allows the user to select a menu and move it. The menu-set and connections are redrawn afterwards.

             (menu-conns-find-conn mc pt:vector)
    This finds the connection selected by the point pt, if any. This is useful to allow the user to delete a connection:

             (menu-conns-delete-conn mc conn)

             (menu-conns-find-conns mc menuname port)
    This returns all the connections from the specified port (selection) of the menu whose name is menuname.

    Windows

             (window-create width height &optional title parentw x y font)

    window-create makes a new window of the specified width and height. title, if specified, becomes the displayed title of the window. If parentw is specified, it should be the window-parent property of an existing window, which becomes the parent window of the new window. x and y are the offset of the new window from the parent window. font is the font to be used for printing in the window; the default is given by *window-default-font-name*, initially courier-bold-12.

             (window-open w) causes a window to be displayed on the screen.

             (window-close w) removes the window from the display; it can be re-opened.

             (window-destroy w)

             (window-moveto-xy w x y)

             (window-geometry w) queries X for the window geometry. The result is a list, (x y width height border-width) .

             (window-size w) returns a list (width height) .

    Note that the width and height are cached within the structure so that no call to X is needed to examine them. However, if the window is resized, it is necessary to call (window-reset-geometry w) to reset the local parameters to their correct values.

    The following functions provide access to the parts of the window data structure; most applications will not need to use them.

             (window-gcontext w)
             (window-parent w)
             (window-drawable-height w)
             (window-drawable-width w)
             (window-label w)
             (window-font w)
             (window-screen-height)

    Drawing Functions

             (window-clear w) clears the window to the background color.

             (window-force-output &optional w)

    Communication between the running program and X windows is done through a stream; actual drawing on the display is done asynchronously. window-force-output causes the current drawing commands, if any, to be sent to X. Without this, commands may be left in the stream buffer and may appear not to have been executed. The argument w is not used.

    In all of the drawing functions, the linewidth argument is optional and defaults to 1.

             (window-draw-line w from:vector to:vector linewidth)
             (window-draw-line-xy w x1 y1 x2 y2 &optional linewidth op)
             op may be xor or erase.

             (window-draw-arrow-xy w x1 y1 x2 y2 &optional linewidth size)
             (window-draw-arrow2-xy w x1 y1 x2 y2 &optional linewidth size)
             (window-draw-arrowhead-xy w x1 y1 x2 y2 &optional linewidth size)

    These draw a line with an arrowhead at the second point, a line with an arrowhead at both points, or an arrowhead alone at the second point, respectively. size is the arrowhead size; the default is (+ 20 (* linewidth 5)).

             (window-draw-box-xy w x y width height linewidth)
             (window-xor-box-xy w x y width height linewidth)
             (window-draw-box w offset:vector size:vector linewidth)
             (window-draw-box-corners w x1 y1 x2 y2 linewidth)
             where (x1 y1) and (x2 y2) are opposite corners.
             (window-draw-rcbox-xy w x y width height radius linewidth)
             draws a box with rounded corners.

             (window-draw-arc-xy w x y radiusx radiusy anglea angleb linewidth)

    anglea is the angle, in degrees, at which the arc is started. angleb is the angle, in degrees, that specifies the amount of arc to be drawn, counterclockwise from the starting position.

             (window-draw-circle-xy w x y radius linewidth)
             (window-draw-circle w center:vector radius linewidth)
             (window-draw-ellipse-xy w x y radiusx radiusy linewidth)
             (window-draw-dot-xy w x y)

             (window-erase-area-xy w left bottom width height)
             (window-erase-area w offset:vector size:vector)
             (window-copy-area-xy w fromx fromy tox toy width height)
             (window-invert-area w offset:vector size:vector)
             (window-invert-area-xy w left bottom width height)

             (window-printat-xy w s x y)
             (window-printat w s at:vector)
             (window-prettyprintat-xy w s x y)
             (window-prettyprintat w s at:vector)

    The argument s is printed at the specified position. s is stringified if necessary. Currently, the pretty-print versions are the same as the plain versions.

             (window-draw-border w) draws a border just inside a window.

    Fonts, Operations, Colors

             (window-set-font w font)

    The font symbols that are currently defined are courier-bold-12, 8x10, and 9x15 . The global variable *window-fonts* contains correspondences between font symbols and font strings. A font string may also be specified instead of a font symbol.

             (window-string-width w s)
             (window-string-extents w s)
    These give the width and the vertical size (ascent descent) in pixels of the specified string s using the font of the specified window. s is stringified if necessary.

    Operations on a window other than direct drawing are performed by setting a condition for the window, performing the operation, and then unsetting the condition with window-unset. window-reset will reset a window to its ``standard'' setting; it is useful primarily for cases in which a program bug causes window settings to be in an undesired state.

             (window-set-xor w)
             (window-set-erase w)
             (window-set-copy w)
             (window-set-invert w)
             (window-unset w)
             (window-reset w)

             (window-set-line-width w width)
             (window-set-line-attr w width &optional line-style cap-style join-style)
             (window-std-line-attr w)

             (window-foreground w)
             (window-set-foreground w fg-color)
             (window-background w)
             (window-set-background w bg-color)

    Color

    The color of the foreground (things that are drawn, such as lines or characters) is set by:

             (window-set-color w rgb &optional background)
             (window-set-color-rgb w r g b &optional background)

    rgb is a list (red green blue) of 16-bit unsigned integers in the range 0 to 65535. background is non- nil to set the background color rather than the foreground color.

             (window-reset-color w)
    window-reset-color resets a window's colors to the default values.

    Colors are a scarce resource; there is only a finite number of available colors, such as 256 colors. If you only use a small, fixed set of colors, the finite set of colors will not be a problem. However, if you create a lot of colors that are used only briefly, it will be necessary to release them after they are no longer needed. window-set-color will leave the global variable *window-xcolor* set to an integer value that denotes an X color; this value should be saved and used as the argument to window-free-color to release the color after it is no longer needed.

             (window-free-color w &optional xcolor)

    window-free-color frees either the last color used, as given by *window-xcolor*, or the specified color.

    Character Input

    texted

    Characters can be input within a window by the call:

             (window-input-string w str x y &optional size)

    window-input-string will print the initial string str, if non- nil, at the specified position in the window; str, if not modified by the user, will also be the initial part of the result. A caret is displayed showing the location of the next input character. Characters are echoed as they are typed; backspacing erases characters, including those from the initial string str. An area of width size (default 100) is erased to the right of the initial caret.

    Emacs-like Editing

    emacsed

    window-edit allows editing of text using an Emacs-subset editor. Only a few simple Emacs commands are implemented. 

    
   (window-edit w x y width height
    		optional strings boxflg scroll endp) x y width height specify the offset and size of the editing area; it is a good idea to draw a box around this area first. strings is an initial list of strings; the return value is a list of strings. scroll is number of lines to scroll down before displaying text, or T to have one line only and terminate on return. endp is T to begin editing at the end of the first line. Example: 
    
  (window-draw-box-xy myw 48 48 204 204)
  (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good"))

    Mouse Interaction

             (window-get-point w)
             (window-get-crosshairs w)
             (window-get-cross w)
    These functions get a point position by mouse click; they return (x y) .

    The following function gets a point position by mouse click. It returns (button (x y)) where button is 1 for the left button, 2 for middle, 3 for right.

             (window-get-click w)

    The following function gets a point position by mouse click within a specified region. It returns (button (x y)) or NIL if the mouse leaves the region. If boxflg is t, a box will be drawn outside the region while the mouse is being tracked.

             (window-track-mouse-in-region w x y sizex sizey &optional boxflg)

    The following functions get a point position indicated by drawing a line from a specified origin position to the cursor position; they return (x y) at the cursor position when a mouse button is clicked. The latex version restricts the slope of the line to be a slope that can draw; if flg is non- nil, the slope is restricted to be a vector slope.

             (window-get-line-position w orgx orgy)
             (window-get-latex-position w orgx orgy flg)

    The following function gets a position by moving a ``ghost'' icon, defined by the icon drawing function fn. This allows exact positioning of an object by the user.

             (window-get-icon-position w fn args &optional (dx 0) (dy 0))

    The function fn has arguments (fn w x y . args) , where x and y are the offset within the window w at which the icon is to be drawn, and args is a list of arbitrary arguments, e.g., the size of the icon, that are passed through to the drawing function. The icon is drawn in xor mode, so it must be drawn using only ``plain'' drawing functions, without resetting window attributes. The returned value is (x y) at the cursor position when a button is clicked. dx and dy, if specified, are offsets of x and y from the cursor position.

    The following function gets a position by moving a ``ghost'' box icon.

             (window-get-box-position w width height &optional (dx 0) (dy 0))

    By default, the lower-left corner of the box is placed at the cursor position; dx and dy may be used to offset the box from the cursor, e.g., to move the box by a different corner. The returned value is (x y) at the cursor position when a button is clicked.

    The following function gets coordinates of a box of arbitrary size and position.

             (window-get-region w)

    The user first clicks for one corner of the box, moves the mouse and clicks again for the opposite corner, then moves the box into the desired position. The returned value is ((x y) (width height)), where (x y) is the lower-left corner of the box.

    The following function gets the size of a box by mouse selection, echoing the size in pixels below the box. offsety should be at least 30 to leave room to display the size of the box.

             (window-get-box-size w offsetx offsety)

    The following function adjusts one side of a box.

             (window-adjust-box-side w x y width height side)

    side specifies the side of the box to be adjusted: left, right, top, or bottom. The result is ((x y) (width height)) for the resulting box.

             (window-get-circle w &optional center:vector)
             (window-get-ellipse w &optional center:vector)
    These functions interactively get a circle or ellipse. For an ellipse, a circle is gotten first for the horizontal size; then the vertical size of the ellipse is adjusted. window-get-circle returns ((x y) radius). window-get-ellipse returns ((x y) (xradius yradius)).

    window-track-mouse is the basic function for following the mouse and performing some action as it moves. This function is used in the implementation of menus and the mouse-interaction functions described in this section.

             (window-track-mouse w fn &optional outflg)

    Each time the mouse position changes or a mouse button is pressed, the function fn is called with arguments (x y code) where x and y are the cursor position, code is a button code ( 0 if no button, 1 for the left button, 2 for the middle button, or 3 for the right button). window-track-mouse continues to track the mouse until fn returns a value other than nil, at which time window-track-mouse returns that value. Usually, it is a good idea for fn to return a value other than nil upon a mouse click. If the argument outflg is non- nil, the function fn will be called for button clicks outside the window w; note, however, that such clicks will not be seen if the containing window intercepts them, so that this feature will work only if the window w is inside another Lisp user window.

    Miscellaneous Functions

             (stringify x) makes its argument into a string.

             (window-destroy-selected-window) waits 3 seconds, then destroys the window containing the mouse cursor. This function should be used with care; it can destroy a non-user window, causing processes associated with the window to be destroyed. It is useful primarily in debugging, to get rid of a window that is left on the screen due to an error.

    Examples

    Several interactive programs using this software for their graphical interface can be found at http://www.cs.utexas.edu/users/novak/ under the heading Software Demos.

    Web Interface

    This software allows a Lisp program to be used interactively within a web page. There are two approaches, either using an X server on the computer of the person viewing the web page, or using WeirdX, a Java program that emulates an X server. Details can be found at: http://www.cs.utexas.edu/users/novak/dwindow.html

    Files

    dec.copyright Copyright and license for DEC/MIT files
    draw.lsp GLISP source code for interactive drawing utility
    drawtrans.lsp draw.lsp translated into plain Lisp
    draw-gates.lsp Code to draw nand gates etc.
    dwdoc.tex source for this document
    dwexports.lsp exported symbols
    dwimportsb.lsp imported symbols
    dwindow.lsp GLISP source code for dwindow functions
    dwtest.lsp Examples of use of dwindow functions
    dwtrans.lsp dwindow.lsp translated into plain Lisp
    editors.lsp Editors for colors etc.
    editorstrans.lsp translation of editors.lsp
    gnu.license GNU General Public License
    ice-cream.lsp Drawing of an ice cream cone made with draw
    lispserver.lsp Example web demo: a Lisp server
    lispservertrans.lsp translation of lispserver.lsp
    menu-set.lsp GLISP source code for menu-set functions
    menu-settrans.lsp translation of menu-set.lsp
    pcalc.lsp Pocket calculator implemented as a picmenu

    Contents    Next    Page+10    Index    gcl-2.6.14/xgcl-2/dwdoc/dwdoc3.html0000644000175000017500000000332014360276512015236 0ustar cammcamm dwdoc p. 3

    Copyright

    The following copyright notice applies to the portions of the software that were adapted from X Consortium software: 

    
;;**********************************************************
;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts.

;;                        All Rights Reserved

;;Permission to use, copy, modify, and distribute this software and its 
;;documentation for any purpose and without fee is hereby granted, 
;;provided that the above copyright notice appear in all copies and that
;;both that copyright notice and this permission notice appear in 
;;supporting documentation, and that the names of Digital or MIT not be
;;used in advertising or publicity pertaining to distribution of the
;;software without specific, written prior permission.  

;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;;SOFTWARE.

;;*****************************************************************

    Contents    Prev    Next    Page+10    Index    gcl-2.6.14/xgcl-2/dwdoc/dwdoccontents.html0000644000175000017500000000010014360276512016722 0ustar cammcamm1. Interface from GCL to X Windows

    gcl-2.6.14/xgcl-2/dwdoc/dwdocindex.html0000644000175000017500000000000114360276512016174 0ustar cammcamm gcl-2.6.14/xgcl-2/dwdoc/dwdoc2.html0000644000175000017500000000634114360276512015243 0ustar cammcamm dwdoc p. 2

    Data Types

    
(window (listobject  (parent          drawable)
                     (gcontext        anything)
                     (drawable-height integer)
                     (drawable-width  integer)
                     (label           string)
                     (font            anything) )


    
(menu (listobject (menu-window     window)
                  (flat            boolean)
                  (parent-window   drawable)
                  (parent-offset-x integer)
                  (parent-offset-y integer)
                  (picture-width   integer)
                  (picture-height  integer)
                  (title           string)
                  (permanent       boolean)
                  (menu-font       symbol)
                  (item-width      integer)
                  (item-height     integer)
                  (items           (listof symbol)) )


    
(picmenu (listobject (menu-window     window)
                     (flat            boolean)
                     (parent-window   drawable)
                     (parent-offset-x integer)
                     (parent-offset-y integer)
                     (picture-width   integer)
                     (picture-height  integer)
                     (title           string)
                     (permanent       boolean)
                     (spec            (transparent picmenu-spec))
                     (boxflg          boolean)
                     (deleted-buttons (listof symbol)) )


    
(picmenu-spec (listobject (drawing-width   integer)
                          (drawing-height  integer)
                          (buttons         (listof picmenu-button))
                          (dotflg          boolean)
                          (drawfn          anything)
                          (menu-font       symbol) ))


    
(picmenu-button (list (buttonname     symbol)
                      (offset         vector)
                      (size           vector)
                      (highlightfn    anything)
                      (unhighlightfn  anything))


    
(barmenu (listobject (menu-window     window)
                     (flat            boolean)
                     (parent-window   drawable)
                     (parent-offset-x integer)
                     (parent-offset-y integer)
                     (picture-width   integer)
                     (picture-height  integer)
                     (title           string)
                     (permanent       boolean)
                     (color           rgb)
                     (value           integer)
                     (maxval          integer)
                     (barwidth        integer)
                     (horizontal      boolean)
                     (subtrackfn      anything)
                     (subtrackparms   (listof anything)))

    Contents    Prev    Next    Page+10    Index    gcl-2.6.14/bfdtest.c0000644000175000017500000003243114360276512012575 0ustar cammcamm#define IN_GCC #include #include #include #include static bfd *exe_bfd = NULL; struct bfd_link_info link_info; int build_symbol_table_bfd ( char *oname ) { int u,v; asymbol **q; if ( ! ( exe_bfd = bfd_openr ( oname, 0 ) ) ) { fprintf ( stderr, "Cannot open self.\n" ); exit ( 0 ); } if ( ! bfd_check_format ( exe_bfd, bfd_object ) ) { fprintf ( stderr, "I'm not an object.\n" ); exit ( 0 ); } if (!(link_info.hash = bfd_link_hash_table_create (exe_bfd))) { fprintf ( stderr, "Cannot make hash table.\n" ); exit ( 0 ); } if (!bfd_link_add_symbols(exe_bfd,&link_info)) { fprintf ( stderr, "Cannot add self symbols\n.\n" ); exit ( 0 ); } if ((u=bfd_get_symtab_upper_bound(exe_bfd))<0) { fprintf ( stderr, "Cannot get self's symtab upper bound.\n" ); exit ( 0 ); } fprintf ( stderr, "Allocating symbol table (%d bytes)\n", u ); q = (asymbol **) malloc ( u ); if ( ( v = bfd_canonicalize_symtab ( exe_bfd, q ) ) < 0 ) { fprintf ( stderr, "Cannot canonicalize self's symtab.\n" ); exit ( 0 ); } #ifdef _WIN32 for ( u=0; u < v; u++ ) { char *c; if ( ( c = (char *) strstr ( q[u]->name, "_" ) ) ) { struct bfd_link_hash_entry *h; if ( ! ( h = bfd_link_hash_lookup ( link_info.hash, q[u]->name, true, true, true ) ) ) fprintf ( stderr, "Cannot make new hash entry.\n" ); h->type=bfd_link_hash_defined; if ( !q[u]->section ) fprintf ( stderr, "Symbol is missing section.\n" ); h->u.def.value = q[u]->value + q[u]->section->vma; h->u.def.section = q[u]->section; fprintf ( stderr, "Processed %s\n", q[u]->name ); } } #else for (u=0;uname,"@@GLIBC\n" ))) { struct bfd_link_hash_entry *h; *c=0; if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,true,true,true))) fprintf ( stderr, "Cannot make new hash entry.\n" ); h->type=bfd_link_hash_defined; if (!q[u]->section) fprintf ( stderr, "Symbol is missing section.\n" ); h->u.def.value=q[u]->value+q[u]->section->vma; h->u.def.section=q[u]->section; *c='@'; } } #endif bfd_close ( exe_bfd ); free(q); return 0; } /* align for power of two n */ static void * round_up(void *address, unsigned long n) { fprintf ( stderr, "round_up: address = %d, n = %d, returning %d\n", address, n, (void *)(((unsigned long)address + n -1) & ~(n-1)) ); fflush ( stderr ); return (void *)(((unsigned long)address + n -1) & ~(n-1)) ; } #define ROUND_UP(a,b) round_up(a,b) static boolean madd_archive_element (struct bfd_link_info * link_info, bfd *abfd, const char *name) { fprintf ( stderr, "madd_archive_element\n"); return false; } static boolean mmultiple_definition (struct bfd_link_info * link_info, const char *name, bfd *obfd, asection *osec, bfd_vma oval, bfd *nbfd, asection *nsec, bfd_vma nval) { fprintf ( stderr, "mmultiple_definition\n"); return false; } static boolean mmultiple_common (struct bfd_link_info * link_info, const char *name, bfd *obfd, enum bfd_link_hash_type otype, bfd_vma osize, bfd *nbfd, enum bfd_link_hash_type ntype, bfd_vma nsize) { fprintf ( stderr, " mmultiple_common\n"); return false; } static boolean madd_to_set (struct bfd_link_info * link_info, struct bfd_link_hash_entry *entry, bfd_reloc_code_real_type reloc, bfd *abfd, asection *sec, bfd_vma value) { fprintf ( stderr, "madd_to_set\n"); return false; } static boolean mconstructor (struct bfd_link_info * link_info,boolean constructor, const char *name, bfd *abfd, asection *sec, bfd_vma value) { fprintf ( stderr, "mconstructor\n"); return false; } static boolean mwarning (struct bfd_link_info * link_info, const char *warning, const char *symbol, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, "mwarning\n"); return false; } static boolean mundefined_symbol (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address, boolean fatal) { printf("mundefined_symbol %s is undefined\n",name); return false; } static boolean mreloc_overflow (struct bfd_link_info * link_info, const char *name, const char *reloc_name, bfd_vma addend, bfd *abfd, asection *section, bfd_vma address) { printf("mreloc_overflow reloc for %s is overflowing\n",name); return false; } static boolean mreloc_dangerous (struct bfd_link_info * link_info, const char *message, bfd *abfd, asection *section, bfd_vma address) { printf("mreloc_dangerous reloc is dangerous %s\n",message); return false; } static boolean munattached_reloc (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, " munattached_reloc\n"); return false; } static boolean mnotice (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { fprintf ( stderr, "mnotice\n"); return false; } int main ( int argc, char ** argv ) { int init_address=-1; int max_align = 0; unsigned long curr_size = 0; bfd *obj_bfd = NULL; bfd_error_type myerr; unsigned u = 0, v = 0; asymbol **q = NULL; asection *s = NULL; static struct bfd_link_callbacks link_callbacks; static struct bfd_link_order link_order; void *current = NULL; void *cfd_self = NULL; void *cfd_start = NULL; int cfd_size = 0; void *the_start = NULL; void *start_address = NULL; void *m = NULL; fprintf ( stderr, "In BFD fast load test.\n" ); if ( argc < 3 ) { fprintf ( stderr, "Need an executable and an object file as arguments.\n" ); } else { memset ( &link_info, 0, sizeof (link_info) ); memset ( &link_order, 0, sizeof (link_order) ); memset ( &link_callbacks, 0, sizeof (link_callbacks) ); bfd_init(); fprintf ( stderr, "BUILDING EXECUTABLE SYMBOL TABLE (ARGV[1]) \n\n" ); build_symbol_table_bfd ( argv[1] ); link_callbacks.add_archive_element=madd_archive_element; link_callbacks.multiple_definition=mmultiple_definition; link_callbacks.multiple_common=mmultiple_common; link_callbacks.add_to_set=madd_to_set; link_callbacks.constructor=mconstructor; link_callbacks.warning=mwarning; link_callbacks.undefined_symbol=mundefined_symbol; link_callbacks.reloc_overflow=mreloc_overflow; link_callbacks.reloc_dangerous=mreloc_dangerous; link_callbacks.unattached_reloc=munattached_reloc; link_callbacks.notice = mnotice; link_info.callbacks = &link_callbacks; link_order.type = bfd_indirect_link_order; if ( ! ( obj_bfd = bfd_openr ( argv[2], 0 ) ) ) { fprintf ( stderr, "Cannot open bfd.\n" ); } if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { fprintf ( stderr, "Unknown bfd error code on openr %s %d\n.", argv[2], myerr ); } fflush ( stderr ); if ( ! bfd_check_format ( obj_bfd, bfd_object ) ) { fprintf ( stderr, "Unknown bfd format %s.\n", argv[2] ); } if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { fprintf ( stderr, "Unknown bfd error code on check_format %s\n", argv[2] ); } bfd_set_error(0); current = NULL; fprintf ( stderr, "CALCULATING CURRENT, MAX_ALIGN and ALLOCATING \n\n" ); for ( s= obj_bfd->sections;s;s=s->next) { s->owner = obj_bfd; s->output_section = ( s->flags & SEC_ALLOC) ? s : obj_bfd->sections; s->output_offset=0; if (!(s->flags & SEC_ALLOC)) continue; if (max_alignalignment_power) max_align=s->alignment_power; current=round_up(current,1<alignment_power); current+=s->_raw_size; fprintf ( stderr, "Section %s: owner = %x, output_offset = %x, output_section = %x (%s)\n", s->name, s->owner, s->output_offset, s->output_section, s->output_section->name ); } fprintf ( stderr, "1\n"); curr_size=(unsigned long)current; max_align=1< sizeof(char *) ? max_align :0); cfd_start = (void *) malloc ( cfd_size ); the_start = start_address = cfd_start; fprintf ( stderr, "ALLOCATED %d bytes \n\n", cfd_size ); fprintf ( stderr, "max_align = %d, current = %d, cfd_self = %x, " "cfd_size = %x, cfd_start = %x\n", max_align, current, cfd_self, cfd_size, cfd_start ); start_address = ROUND_UP ( start_address, max_align ); cfd_size = cfd_size - ( start_address - the_start ); cfd_start = (void *) start_address; fprintf ( stderr, "max_align = %d, current = %d, cfd_self = %x, " "cfd_size = %x, cfd_start = %x\n", max_align, current, cfd_self, cfd_size, cfd_start ); memset ( cfd_start, 0, cfd_size ); for ( m = start_address, s = obj_bfd->sections; s; s=s->next ) { if (!(s->flags & SEC_ALLOC)) continue; m=round_up(m,1<alignment_power); s->output_section->vma=(unsigned long)m; m+=s->_raw_size; fprintf ( stderr, "Section address %x\n", s ); fprintf ( stderr, "m loop Section %s: owner = %x, output_offset = %x, " "output_section = %x (%s), vma = %x, m = %x\n", s->name, s->owner, s->output_offset, s->output_section, s->output_section->name, s->output_section->vma, m ); } fprintf ( stderr, "\n\nDOING SOMETHING WITH THE HASHED SYMBOLS\n\n" ); if ((u=bfd_get_symtab_upper_bound(obj_bfd))<0) fprintf ( stderr, "Cannot get symtab uppoer bound.\n" ); q = (asymbol **) alloca ( u ); if ( ( v = bfd_canonicalize_symtab ( obj_bfd, q ) ) < 0 ) fprintf ( stderr, "cannot canonicalize symtab.\n" ); fprintf ( stderr, "u = %d, v = %d\n", u, v ); for (u=0;uname = %s\n", u, q[u]->name ); if (!strncmp("init_",q[u]->name,5)) { init_address=q[u]->value; continue; } if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name, false, false, true))) continue; if (h->type!=bfd_link_hash_defined) fprintf ( stderr, "Undefined symbol.\n" ); if (h->u.def.section) { q[u]->value=h->u.def.value+h->u.def.section->vma; q[u]->flags|=BSF_WEAK; } else fprintf ( stderr, "Symbol without section.\n" ); } fprintf ( stderr, "\n\nDOING RELOCATIONS\n\n", cfd_size ); fflush ( stderr ); for ( s = obj_bfd->sections; s; s = s->next ) { fprintf ( stderr, "s->name %s, s->flags = %x\n", s->name, s->flags ); if ( ! ( s->flags & SEC_LOAD ) ) continue; link_order.u.indirect.section=s; fprintf ( stderr, "About to get reloc section contents\n" ); fprintf ( stderr, "obj_bfd = %x, section %s, s->output_section = %x, q = %x\n", obj_bfd, s->name, s->output_section, q); fflush ( stderr ); if (!bfd_get_relocated_section_contents(obj_bfd, &link_info,&link_order, (void *)(unsigned long)s->output_section->vma,0,q)) fprintf ( stderr, "Cannot get relocated section contents\n"); } bfd_close ( obj_bfd ); printf("start address -T %x \n", cfd_start); } } gcl-2.6.14/add-defs.bat0000755000175000017500000000315714360276512013143 0ustar cammcamm@echo off if .%1==. goto err_param if NOT EXIST h\%1.def goto err_not_found IF EXIST unixport\saved_kc.exe goto found_saved_kcl_exe echo WARNING : unixport/saved_kcl.exe file not found echo _ you will not be able to recompile the .lsp files echo _ nor start akcl :found_saved_kcl_exe echo %1 > machine if .%2==. goto only_1_param if exist %2\c\print.d goto only_1_param echo %2 is not the main kcl directory :only_1_param make -f Smakefile merge copy tmpxx_.tem tmpxx del makedefs echo AKCLDIR=/akcl >makedefs echo SHELL=/bin/sh >>makedefs echo MACHINE=%1 >>makedefs type h\%1.def >>makedefs if exist %2\c\print.d echo MAINDIR = %2 >> makedefs type makedefs >>tmpxx echo # end makedefs >>tmpxx echo @s] >> tmpxx echo inserting h\%1.def in .. for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do go32 merge %%v tmpxx %%v.new for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v %%v.bak for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v.new %%v go32 merge unixport\makefile.dos tmpxx unixport\makefile.new if exist unixport\makefile.new mv unixport\makefile.dos unixport\makefile.bak if exist unixport\makefile.new mv unixport\makefile.new unixport\makefile.dos rem rm -f Vmakefile rem rm -f tmpxx rem Copy the config.h over. copy h\%1.h h\config.h rem fix the cmpinclude.h goto end :err_param echo usage: Provide a machine name as arg goto end :err_not_found echo h\%1.def does not exist echo Build one or use one of `ls h\*.def` goto end :end gcl-2.6.14/configure.in0000644000175000017500000020407214360276512013311 0ustar cammcammAC_INIT AC_PREREQ([2.68]) AC_CONFIG_HEADERS([h/gclincl.h]) VERSION=`cat majvers`.`cat minvers` AC_SUBST(VERSION) # # Host information # AC_CANONICAL_HOST canonical=$host my_host_kernel=`echo $host_os | awk '{j=split($1,A,"-");print A[[1]]}'` my_host_system=`echo $host_os | awk '{j=split($1,A,"-");if (j>=2) print A[[2]]}'` AC_DEFINE_UNQUOTED(HOST_CPU,"`echo $host_cpu | awk '{print toupper($0)}'`",[Host cpu]) AC_DEFINE_UNQUOTED(HOST_KERNEL,"`echo $my_host_kernel | awk '{print toupper($0)}'`",[Host kernel]) if test "$my_host_system" != "" ; then AC_DEFINE_UNQUOTED(HOST_SYSTEM,"`echo $my_host_system | awk '{print toupper($0)}'`",[Host system]) fi ## host=CPU-COMPANY-SYSTEM AC_MSG_RESULT(host=$host) use=unknown case $canonical in sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *riscv64*linux*) use=riscv64-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; m68k*linux*) use=m68k-linux;; alpha*linux*) use=alpha-linux;; mips*linux*) use=mips-linux;; mipsel*linux*) use=mipsel-linux;; sparc*linux*) use=sparc-linux;; aarch64*linux*) use=aarch64-linux;; arm*linux*hf) use=armhf-linux;; arm*linux*) use=arm-linux;; s390*linux*) use=s390-linux;; ia64*linux*) use=ia64-linux;; hppa*linux*) use=hppa-linux;; powerpc*linux*) use=powerpc-linux;; powerpc-*-darwin*) use=powerpc-macosx;; *86*darwin*) use=386-macosx;; i*mingw*|i*msys*) use=mingw;; *cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) use=FreeBSD;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; esac AC_ARG_ENABLE([machine],[ --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs], [echo enable_machine=$enableval ; use=$enableval]) AC_MSG_RESULT([use=$use]) def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" def_oldgmp="no" def_pic="no"; def_static="no"; def_debug="no"; case $use in *kfreebsd) ln -snf linux.defs h/$use.defs;; *gnu) ln -snf linux.defs h/$use.defs;; *linux) ln -snf linux.defs h/$use.defs; case $use in ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; esac;; esac AC_ARG_ENABLE([widecons],[ --enable-widecons will use a three word cons with simplified typing], [if test "$enableval" = "yes" ; then AC_DEFINE([WIDE_CONS],[1],[three word cons]) fi]) AC_ARG_ENABLE([safecdr],[ --enable-safecdr will protect cdr from immfix and speed up type processing], [if test "$enableval" = "yes" ; then AC_DEFINE([USE_SAFE_CDR],[1],[protect cdr from immfix and speed up type processing]) AC_ARG_ENABLE([safecdrdbg],[ --enable-safecdrdbg will debug safecdr code], [if test "$enableval" = "yes" ; then AC_DEFINE([DEBUG_SAFE_CDR],[1],[debug safecdr code]) fi]) fi]) AC_ARG_ENABLE([prelink],[ --enable-prelink will insist that the produced images may be prelinked], [if test "$enable_prelink" = "yes" ; then PRELINK_CHECK=t; fi]) AC_SUBST(PRELINK_CHECK) AC_ARG_ENABLE([vssize],[ --enable-vssize=XXXX will compile in a value stack of size XXX], [AC_DEFINE_UNQUOTED(VSSIZE,$enableval,[value stack size])]) AC_ARG_ENABLE([bdssize],[ --enable-bdssize=XXXX will compile in a binding stack of size XXX], [AC_DEFINE_UNQUOTED(BDSSIZE,$enableval,[binding stack size])]) AC_ARG_ENABLE([ihssize],[ --enable-ihssize=XXXX will compile in a invocation history stack of size XXX], [AC_DEFINE_UNQUOTED(IHSSIZE,$enableval,[invocation history stack size])]) AC_ARG_ENABLE([frssize],[ --enable-frssize=XXXX will compile in a frame stack of size XXX], [AC_DEFINE_UNQUOTED(FRSSIZE,$enableval,[frame stack size])]) AC_ARG_ENABLE([infodir],[ --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info], [INFO_DIR=$enableval],[INFO_DIR=$prefix/share/info]) INFO_DIR=`eval echo $INFO_DIR/` AC_ARG_ENABLE([emacsdir],[ --enable-emacsdir=XXXX will manually specify the location for elisp files], [EMACS_SITE_LISP=$enableval],[EMACS_SITE_LISP=$prefix/share/emacs/site-lisp]) EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` AC_ARG_ENABLE([xgcl],[ --enable-xgcl=yes will compile in support for XGCL],,[enable_xgcl=yes]) AC_ARG_ENABLE([dlopen],[ --enable-dlopen uses dlopen for loading objects, which can then not be retained in saved images], ,[enable_dlopen=$def_dlopen]) AC_ARG_ENABLE([statsysbfd],[ --enable-statsysbfd uses a static system bfd library for loading and relocating object files], ,[enable_statsysbfd=$def_statsysbfd]) AC_ARG_ENABLE([dynsysbfd],[ --enable-dynsysbfd uses a dynamic shared system bfd library for loading and relocating object files], ,[enable_dynsysbfd=no]) AC_ARG_ENABLE([custreloc],[ --enable-custreloc uses custom gcl code if available for loading and relocationing object files], ,[enable_custreloc=$def_custreloc]) AC_ARG_ENABLE([debug],[ --enable-debug builds gcl with -g in CFLAGS to enable running under gdb], ,[enable_debug=$def_debug]) AC_ARG_ENABLE([static],[ --enable-static will link your GCL against static as opposed to shared system libraries], ,[enable_static=$def_static]) AC_ARG_ENABLE([pic],[ --enable-pic builds gcl with -fPIC in CFLAGS],,[enable_pic=$def_pic]) load_opt=0 if test "$enable_dlopen" = "yes" ; then load_opt=1 fi if test "$enable_statsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; esac fi if test "$enable_dynsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; esac fi if test "$enable_custreloc" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; 4) load_opt=5;; esac fi if test "$load_opt" != "1" ; then echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd custreloc=$enable_custreloc" AC_MSG_ERROR([loader option failure]) fi # # System programs # # We set the default CFLAGS below, and don't want the autoconf default # CM 20040106 if test "$CFLAGS" = "" ; then CFLAGS=" " fi if test "$LDFLAGS" = "" ; then LDFLAGS=" " fi AC_PROG_CC AC_PROG_CPP AC_SUBST(CC) add_arg_to_cflags() { AC_MSG_CHECKING([for CFLAG $1]) CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS -Werror $1 `echo $1|sed 's,-Wno-,-W,1'`" AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]],[[]])], [CFLAGS="$CFLAGS_ORI $1";AC_MSG_RESULT([yes]);return 0], [AC_MSG_RESULT([no])], [AC_MSG_RESULT([no])]) CFLAGS=$CFLAGS_ORI return 1 } assert_arg_to_cflags() { if ! add_arg_to_cflags "$1" ; then AC_MSG_RESULT([cannot add $1 to CFLAGS]); exit 1 ; fi return 0 } add_args_to_cflags() { while test "$#" -ge 1 ; do add_arg_to_cflags $1 shift done } add_arg_to_ldflags() { AC_MSG_CHECKING([for LDFLAG $1]) LDFLAGS_ORI=$LDFLAGS LDFLAGS="$LDFLAGS -Werror $1" AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]],[[]])], [LDFLAGS="$LDFLAGS_ORI $1";AC_MSG_RESULT([yes]);return 0], [AC_MSG_RESULT([no])], [AC_MSG_RESULT([no])]) LDFLAGS=$LDFLAGS_ORI return 1 } assert_arg_to_ldflags() { if ! add_arg_to_ldflags $1 ; then AC_MSG_RESULT([cannot add $1 to LDFLAGS]); exit 1 ; fi return 0 } add_args_to_ldflags() { while test "$#" -ge 1 ; do add_arg_to_ldflags $1 shift done } remove_arg_from_ldflags() { NEW_LDFLAGS="" for i in $LDFLAGS; do if ! test "$i" = "$1" ; then NEW_LDFLAGS="$NEW_LDFLAGS $i" else AC_MSG_RESULT([removing $1 from LDFLAGS]) fi done LDFLAGS=$NEW_LDFLAGS return 0 } add_args_to_cflags -fsigned-char -pipe -fcommon \ -fno-builtin-malloc -fno-builtin-free \ -fno-PIE -fno-pie -fno-PIC -fno-pic \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable add_args_to_ldflags -no-pie # -Wl,-z,lazy AC_MSG_CHECKING([for inline semantics]) AC_COMPILE_IFELSE( [AC_LANG_SOURCE([[ inline int foo(int i) {return i;} int bar(int i) {return foo(i);} ]])], [if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then AC_MSG_RESULT([new]) else AC_COMPILE_IFELSE( [AC_LANG_SOURCE([[ extern inline int foo(int i) {return i;} int bar(int i) {return foo(i);} ]])], [if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then AC_MSG_RESULT([old]) AC_DEFINE([OLD_INLINE],[1],[extern inline semantics]) else AC_MSG_ERROR([need working inline semantics]) fi], [AC_MSG_ERROR([need to probe inline semantics])]) fi], [AC_MSG_ERROR([need to probe inline semantics])]) AC_MSG_CHECKING([for clang]) AC_RUN_IFELSE( [AC_LANG_PROGRAM([[ #ifdef __clang__ #define RET 0 #else #define RET 1 #endif ]], [[ return RET; ]])], [AC_MSG_RESULT([yes]) clang="yes" remove_arg_from_ldflags -pie AC_DEFINE([CLANG],[1],[running clang compiler])], [AC_MSG_RESULT([no])]) case $use in *mingw*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields for i in makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp h/gclincl.h; do cat $i.in | sed 's,[^\r]\n$,\r\n,g' >tmp && mv tmp $i.in; done OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; *gnuwin*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields assert_arg_to_ldflags -Wl,--stack,8000000 OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; 386-macosx) # assert_arg_to_cflags -Wno-error=implicit-function-declaration add_arg_to_cflags -Wno-incomplete-setjmp-declaration assert_arg_to_ldflags -Wl,-no_pie if test "$build_cpu" = "x86_64" ; then assert_arg_to_cflags -m64 assert_arg_to_ldflags -m64 assert_arg_to_ldflags -Wl,-headerpad,72 else assert_arg_to_cflags -m32 assert_arg_to_ldflags -m32 assert_arg_to_ldflags -Wl,-headerpad,56 fi;; FreeBSD) assert_arg_to_ldflags -Z;; esac if test "$enable_static" = "yes" ; then assert_arg_to_ldflags -static assert_arg_to_ldflags -Wl,-zmuldefs AC_DEFINE(STATIC_LINKING,1,[staticly linked images]) fi TO3FLAGS="" TO2FLAGS="" case "$use" in *mingw*) TFPFLAG="";; m68k*)#FIXME gcc 4.x bug workaround TFPFLAG="";; *) TFPFLAG="-fomit-frame-pointer";; esac AC_CHECK_PROGS(AWK,[gawk nawk awk]) GCL_CC_ARGS=`echo $CC | ${AWK} '{$1="";print}'` GCL_CC="`basename $CC` $GCL_CC_ARGS" if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi AC_SUBST(GCL_CC) AC_ARG_ENABLE([gprof],[ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof], [if test "$enableval" = "yes" ; then AC_MSG_CHECKING([working gprof]) case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then enableval="no"; fi;; s390*) enableval="no";;#mcount smashes float args in make_shortfloat 20180313 sh4*) enableval="no";; m68k*) enableval="no";; ia64*) enableval="no";; hppa*) enableval="no";; # arm*) if echo $canonical |grep -q hf$; then enableval="no"; fi;;#FIXME CALL and JUMP24 veneers needed for thumb 20190201 #FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible aarch64*) enableval="no";;#unreproducible buildd bug 20170824 *gnu) enableval="no";; esac GP_FLAG="" if test "$enableval" != "yes" ; then AC_MSG_RESULT([disabled]) else AC_MSG_RESULT([ok]) OLD_CFLAGS=$CFLAGS # Do not run configure tests with -pg assert_arg_to_cflags -pg GP_FLAG="-pg" CFLAGS=$OLD_CFLAGS TFPFLAG="" AC_DEFINE(GCL_GPROF,1,[use gprof profiling]) fi fi]) if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TO3FLAGS="-O3 $TFPFLAG" TO2FLAGS="-O" fi # gcc on ppc cannot compile our new_init.c with full opts --CM TONIFLAGS="" case $use in powerpc*macosx) assert_arg_to_cflags -mlongcall;; *linux) case $use in alpha*) assert_arg_to_cflags -mieee # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) assert_arg_to_cflags -mlong-calls TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 ;; mips*) case $canonical in mips64*linux*) # assert_arg_to_cflags -mxgot assert_arg_to_ldflags -Wl,-z,now;; esac ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) AC_DEFINE([SET_STACK_POINTER],["mov %%sp,%0\n\t"],[asm string to set the stack pointer]) AC_MSG_CHECKING([how to set stack pointer]) AC_MSG_RESULT([done]) assert_arg_to_cflags -fdollars-in-identifiers assert_arg_to_cflags -g #? ;; powerpc*) assert_arg_to_cflags -mlongcall if test "$host_cpu" != "powerpc64le" ; then assert_arg_to_cflags -mno-pltseq; fi ;; esac;; esac if test "$enable_pic" = "yes" ; then assert_arg_to_cflags -fPIC fi FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` #CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` FOOPT1="$FOOPT1$TMPF" CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` if test "$FOOPT0" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` else if test "$FOOPT1" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[2-3]],-O1,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[2-3]],-O1,g'` else if test "$FOOPT2" != "" ; then TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` fi fi fi if test "$FDEBUG" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" fi # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") AC_SUBST(MAKEINFO) AC_MSG_CHECKING([system version (for dynamic loading)]) if machine=`uname -m` ; then true; else machine=unknown ; fi if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_RESULT([unknown (cannot find uname command)]) system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi AC_MSG_RESULT($system) fi fi case $use in *macosx) AC_CHECK_HEADERS(malloc/malloc.h,,[AC_MSG_ERROR([need malloc.h on macosx])]) AC_CHECK_MEMBER([struct _malloc_zone_t.memalign], AC_DEFINE(HAVE_MALLOC_ZONE_MEMALIGN,1,[memalign element present]), [], [ #include ]) AC_SUBST(HAVE_MALLOC_ZONE_MEMALIGN) ;; esac AC_CHECK_HEADERS( [setjmp.h], [AC_MSG_CHECKING([sizeof jmp_buf]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sizeof(jmp_buf)); fclose(fp); ]])], [sizeof_jmp_buf=`cat conftest1` AC_MSG_RESULT($sizeof_jmp_buf) AC_DEFINE_UNQUOTED(SIZEOF_JMP_BUF,$sizeof_jmp_buf,[sizeof jmp_buf])], [AC_MSG_RESULT([no])])]) # sysconf AC_CHECK_HEADERS( [unistd.h], [AC_CHECK_LIB( [c],[sysconf], [AC_MSG_CHECKING([_SC_CLK_TCK]) hz=0 AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); fclose(fp); ]], [hz=`cat conftest1` AC_DEFINE_UNQUOTED(HZ,$hz,[time system constant])])]) AC_MSG_RESULT($hz)])]) rm -f makedefsafter AC_ARG_ENABLE([dynsysgmp], [ --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source]) if test "$enable_dynsysgmp" != "no" ; then AC_CHECK_HEADERS( [gmp.h], [AC_CHECK_LIB( [gmp],[__gmpz_init], [AC_MSG_CHECKING([for external gmp version]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif ]])], [AC_MSG_RESULT([good]) TLIBS="$TLIBS -lgmp" echo "#include \"gmp.h\"" >foo.c echo "int main() {return 0;}" >>foo.c MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` rm -f foo.c])])]) if test "$MP_INCLUDE" = "" ; then AC_MSG_RESULT([Cannot use dynamic gmp lib]) fi fi if test "$MP_INCLUDE" = "" ; then GMPDIR=gmp4 AC_MSG_CHECKING([doing configure in gmp directory]) echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of GMP" echo "#" echo "#" if test "$use_common_binary" = "yes"; then cd $GMPDIR && ./configure --build=$host && cd .. else cd $GMPDIR && ./configure --host=$host --build=$build && cd .. fi #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of GMP done" echo "# ------------------------" echo "#" if test "$MP_INCLUDE" = "" ; then cp $GMPDIR/gmp.h h/gmp.h MP_INCLUDE=h/gmp.h MPFILES=gmp_all fi fi AC_MSG_CHECKING([for leading underscore in object symbols]) cat>foo.c < #include int main() {FILE *f;double d=0.0;getc(f);d=cos(d);return 0;} EOFF $CC -c foo.c -o foo.o if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then LEADING_UNDERSCORE=1 AC_DEFINE(LEADING_UNDERSCORE,1,[symbol name mangling convention]) AC_MSG_RESULT("yes") else LEADING_UNDERSCORE="" AC_MSG_RESULT("no") fi AC_MSG_CHECKING("for GNU ld option -Map") touch map $CC -o foo [ -Wl,-Map ] map foo.o >/dev/null 2>&1 if test `cat map | wc -l` != "0" ; then AC_MSG_RESULT("yes") AC_DEFINE(HAVE_GNU_LD,1,[gnu linker present]) GNU_LD=1 else AC_MSG_RESULT("no") GNU_LD= fi rm -f foo.c foo.o foo map AC_MSG_CHECKING([for size of gmp limbs]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]], [[ FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); ]])],[mpsize=`cat conftest1`],[AC_MSG_ERROR([Cannot determine mpsize])]) AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize,[sizeof mp_limb in gmp library]) AC_MSG_RESULT($mpsize) AC_MSG_CHECKING([_SHORT_LIMB]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]], [[ #ifdef _SHORT_LIMB return 0; #else return 1; #endif ]])],[AC_DEFINE(__SHORT_LIMB,1,[short gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) AC_MSG_CHECKING([_LONG_LONG_LIMB]) AC_RUN_IFELSE([AC_LANG_PROGRAM([[ #include #include "$MP_INCLUDE" ]], [[ #ifdef _LONG_LONG_LIMB return 0; #else return 1; #endif ]])],[AC_DEFINE(__LONG_LONG_LIMB,1,[long gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) GMP=1 AC_DEFINE(GMP,1,[using gmp]) AC_SUBST(GMP) AC_SUBST(GMPDIR) echo > makedefsafter echo "MPFILES=$MPFILES" >> makedefsafter echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter echo >> makedefsafter # # X windows # if test "$enable_xgcl" = "yes" ; then AC_PATH_X AC_CHECK_LIB(X11,main, [X_LIBS="$X_LIBS -lX11" AC_DEFINE(HAVE_XGCL,1,[using xgcl])], [AC_MSG_RESULT([missing x libraries -- cannot compile xgcl])]) fi AC_SUBST(X_LIBS) AC_SUBST(X_CFLAGS) # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then AC_CHECK_LIB([dl],[dlopen],,AC_MSG_ERROR([Cannot find dlopen])) TLIBS="$TLIBS -ldl -rdynamic" assert_arg_to_cflags -fPIC AC_DEFINE(USE_DLOPEN,1,[link compiled objects via libdl]) fi if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then AC_CHECK_HEADERS( [bfd.h], AC_CHECK_LIB( [bfd],[bfd_init], # # Old binutils appear to need CONST defined to const # AC_MSG_CHECKING([need to define CONST for bfd]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define IN_GCC #include ]], [[ symbol_info t; ]])], AC_MSG_RESULT([no]), AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define CONST const #define IN_GCC #include ]], [[ symbol_info t; ]])], AC_MSG_RESULT([yes]) AC_DEFINE(NEED_CONST,1,[binutils requires CONST definition]), AC_MSG_ERROR([cannot use bfd]), AC_MSG_ERROR([cannot use bfd])), AC_MSG_ERROR([cannot use bfd])) ,,-liberty)) AC_DEFINE(HAVE_LIBBFD,1,[use libbfd]) # # BFD boolean syntax # AC_MSG_CHECKING(for useable bfd_boolean) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define IN_GCC #include bfd_boolean foo() {return FALSE;} ]], [[]])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_BFD_BOOLEAN,1,[bfd_boolean defined])], [AC_MSG_RESULT(no)]) # # bfd_link_info.output_bfd minimal configure change check # AC_CHECK_MEMBER([struct bfd_link_info.output_bfd], AC_DEFINE(HAVE_OUTPUT_BFD,1,[output_bfd element present]), [], [[ #include #include ]]) AC_SUBST(HAVE_OUTPUT_BFD) # # FIXME: Need to workaround mingw before this point -- CM # if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$CC [ -Wl,-M ] -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,\"/\");for (j=1;j<=i;j++) if (j>1 && A[[j]]==\"..\") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf(\"%s%s\",A[[j]],j!=i ? \"/\" : \"\")}'`" else AC_MSG_ERROR([cannot locate external libbfd.a]) fi if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,\"/\");for (j=1;j<=i;j++) if (j>1 && A[[j]]==\"..\") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf(\"%s%s\",A[[j]],j!=i ? \"/\" : \"\")}'`" else AC_MSG_ERROR([cannot locate external libiberty.a]) fi BUILD_BFD=copy_bfd AC_CHECK_LIB(z,inflate, [TLIBS="$TLIBS -lz"], AC_MSG_ERROR([Need zlib for bfd linking]),[]) AC_CHECK_LIB(dl,dlsym, [TLIBS="$TLIBS -ldl"], AC_MSG_ERROR([Need libdl for bfd linking]),[]) AC_SUBST(BUILD_BFD) AC_SUBST(LIBBFD) AC_SUBST(LIBIBERTY) else TLIBS="$TLIBS -lbfd -liberty -ldl" fi fi AC_ARG_ENABLE([xdr],[ --enable-xdr=yes will compile in support for XDR]) if test "$enable_xdr" != "no" ; then XDR_LIB="" AC_CHECK_FUNC([xdr_double],XDR_LIB=" ", [AC_CHECK_LIB([tirpc],[xdr_double],[XDR_LIB=tirpc], [AC_CHECK_LIB([gssrpc],[xdr_double],[XDR_LIB=gssrpc], [AC_CHECK_LIB([rpc],[xdr_double],[XDR_LIB=rpc], [AC_CHECK_LIB([oncrpc],[xdr_double],[XDR_LIB=oncrpc])])])])]) if test "$XDR_LIB" != ""; then AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) if test "$XDR_LIB" != " "; then TLIBS="$TLIBS -l$XDR_LIB" add_arg_to_cflags -I/usr/include/$XDR_LIB fi fi fi AC_MSG_CHECKING([__builtin_clzl]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ unsigned long u; long j; if (__builtin_clzl(0)!=sizeof(long)*8) return -1; for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) if (__builtin_clzl(u)!=j) return -1; ]])], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_CLZL,[1],[clzl instruction])], [AC_MSG_RESULT([no])]) AC_MSG_CHECKING([__builtin_ctzl]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ unsigned long u; long j; if (__builtin_ctzl(0)!=sizeof(long)*8) return -1; for (u=1,j=0;j]) if test "$use" != "mingw" ; then if test "$ac_cv_sizeof_time_t" != "8" ; then AC_MSG_ERROR([Cannot define a 64 bit time_t]) fi fi #### Memory areas and alignment AC_MSG_CHECKING(for byte order) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[]], [[ /* Are we little or big endian? Adapted from Harbison&Steele. */ union {long l;char c[sizeof(long)];} u; u.l = 1; return u.c[sizeof(long)-1] ? 1 : 0; ]])],[ AC_MSG_RESULT(little)], [AC_MSG_RESULT(big) AC_DEFINE(WORDS_BIGENDIAN,1,[big endian byte order])]) AC_SUBST(WORDS_BIGENDIAN) AC_MSG_CHECKING(for word order) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[]], [[ /* Are we little or big endian? Adapted from Harbison&Steele. */ union {double d;int l[sizeof(double)/sizeof(int)];} u; u.d = 1.0; return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; ]])], [AC_MSG_RESULT(little)], [AC_MSG_RESULT(big) AC_DEFINE(DOUBLE_BIGENDIAN,1,[big endian word order])]) AC_SUBST(DOUBLE_BIGENDIAN) # pagewidth AC_MSG_CHECKING(for pagewidth) case $use in mips*) min_pagewidth=14;; *) min_pagewidth=12;; esac AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include #ifdef __CYGWIN__ #define getpagesize() 4096 #endif ]], [[ size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); j=j<$min_pagewidth ? $min_pagewidth : j; fprintf(fp,"%u",j); ]])], [PAGEWIDTH=`cat conftest1`], [PAGEWIDTH=0]) AC_MSG_RESULT($PAGEWIDTH) AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH,[system pagewidth]) AC_SUBST(PAGEWIDTH) AC_MSG_CHECKING([for required object alignment]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "./h/enum.h" #define OBJ_ALIGN #include "./h/type.h" #include "./h/lu.h" #include "./h/object.h" ]], [[ unsigned long i; FILE *fp=fopen("conftest1","w"); for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); if (!i) return -1; fprintf(fp,"%lu",i); fclose(fp); return 0; ]])], [obj_align=`cat conftest1` AC_MSG_RESULT($obj_align) AC_DEFINE_UNQUOTED(OBJ_ALIGNMENT,$obj_align,[needed object alignment bytes])], [AC_MSG_ERROR([Cannot find object alignent])]) AC_MSG_CHECKING([for C extension variable alignment]) AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]], [[ char *v __attribute__ ((aligned ($obj_align))); ]])],[obj_align="__attribute__ ((aligned ($obj_align)))"],[AC_MSG_ERROR([Need alignment attributes])]) AC_MSG_RESULT($obj_align) AC_DEFINE_UNQUOTED(OBJ_ALIGN,$obj_align,[can use C extension for object alignment]) AC_MSG_CHECKING([for C extension noreturn function attribute]) AC_RUN_IFELSE( [AC_LANG_PROGRAM([[]], [[ extern int v() __attribute__ ((noreturn)); ]])], [no_return="__attribute__ ((noreturn))"],[no_return=]) AC_MSG_RESULT($no_return) AC_DEFINE_UNQUOTED(NO_RETURN,$no_return,[can use C extension for functions that do not return]) AC_MSG_CHECKING([sizeof struct contblock]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" ]], [[ FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); ]])], [sizeof_contblock=`cat conftest1`], [AC_MSG_ERROR([Cannot find sizeof struct contblock])], [AC_MSG_ERROR([Cannot find sizeof struct contblock])]) AC_MSG_RESULT($sizeof_contblock) AC_DEFINE_UNQUOTED(SIZEOF_CONTBLOCK,$sizeof_contblock,[sizeof linked list for contiguous pages]) AC_MSG_CHECKING([for sbrk]) HAVE_SBRK="" AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); ]])], [HAVE_SBRK=1;AC_MSG_RESULT([yes])], AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx]), AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx])) if test "$use" = "386-macosx" ; then AC_MSG_RESULT([emulating sbrk for mac]); HAVE_SBRK=0 fi if test "$HAVE_SBRK" = "1" ; then AC_MSG_CHECKING([for ADDR_NO_RANDOMIZE constant]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_NO_RANDOMIZE); ]])], [ADDR_NO_RANDOMIZE=`cat conftest1` AC_MSG_RESULT([yes $ADDR_NO_RANDOMIZE])], [ADDR_NO_RANDOMIZE=0 AC_MSG_RESULT([no assuming 0x40000]) AC_DEFINE_UNQUOTED(ADDR_NO_RANDOMIZE,0x40000,[punt guess for no randomize value])]) AC_MSG_CHECKING([for ADDR_COMPAT_LAYOUT constant]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_COMPAT_LAYOUT); ]])], [ADDR_COMPAT_LAYOUT=`cat conftest1` AC_MSG_RESULT([yes $ADDR_COMPAT_LAYOUT])], [ADDR_COMPAT_LAYOUT=0 AC_MSG_RESULT([no])] AC_DEFINE_UNQUOTED(ADDR_COMPAT_LAYOUT,0,[constant to reserve upper 3Gb for C stack])) AC_MSG_CHECKING([for ADDR_LIMIT_3GB constant]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_LIMIT_3GB); ]])], [ADDR_LIMIT_3GB=`cat conftest1` AC_MSG_RESULT([yes $ADDR_LIMIT_3GB])], [ADDR_LIMIT_3GB=0 AC_MSG_RESULT([no])] AC_DEFINE_UNQUOTED(ADDR_LIMIT_3GB,0,[only 3Gb of address space])) AC_MSG_CHECKING([for personality(ADDR_NO_RANDOMIZE) support]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char *argv[],char *envp[]) { #include "h/unrandomize.h" return 0; } ]])], [AC_MSG_RESULT(yes) AC_DEFINE(CAN_UNRANDOMIZE_SBRK,1,[can prevent sbrk from returning random values])], [AC_MSG_RESULT(no)]) AC_MSG_CHECKING([that sbrk is (now) non-random]) SBRK=0 AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); return 0; } ]])],[SBRK=`cat conftest1`]) if test "$SBRK" = "0" ; then AC_MSG_ERROR([cannot trap sbrk]) fi SBRK1=0 AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); return 0; } ]])],[SBRK1=`cat conftest1`]) if test "$SBRK1" = "0" ; then AC_MSG_ERROR([cannot trap sbrk]) fi if test "$SBRK" = "$SBRK1" ; then AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) echo "Cannot build with randomized sbrk. Your options:" echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" echo " - run sysctl kernel.randomize_va_space=0 before using gcl" AC_MSG_ERROR([exiting]) fi fi AC_MSG_CHECKING(CSTACK_DIRECTION) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",(alloca(sizeof(void *))>alloca(sizeof(void *))) ? -1 : 1); fclose(fp); return 0; }]])], [cstack_direction=`cat conftest1`],[cstack_direction=0]) AC_DEFINE_UNQUOTED(CSTACK_DIRECTION,$cstack_direction,[whether C stack grows up or down]) AC_MSG_RESULT($cstack_direction) AC_MSG_CHECKING([finding CSTACK_ALIGNMENT]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif b=alloca(sizeof(b)); c=alloca(sizeof(c)); n=b>c ? b-c : c-b; n=n>sizeof(c) ? n : 1; fprintf(fp,"%ld",n); fclose(fp); return 0; }]])], [cstack_alignment=`cat conftest1`],[cstack_alignment=0]) AC_DEFINE_UNQUOTED(CSTACK_ALIGNMENT,$cstack_alignment,[C stack alignment]) AC_MSG_RESULT($cstack_alignment) AC_ARG_ENABLE([cstackmax],[ --enable-cstackmax=xxxx will ensure that the cstack begins below xxxx or fail], [if test "$enableval" != "" ; then AC_DEFINE_UNQUOTED([CSTACKMAX],$enableval,[cstack max]) fi]) AC_MSG_CHECKING(CSTACK_ADDRESS) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)alloca(sizeof(void *)); if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; }]])], [cstack_address=`cat conftest1`],[cstack_address=0]) AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address,[starting C stack address]) AC_MSG_RESULT($cstack_address) AC_MSG_CHECKING([cstack bits]) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(long)&v; if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%ld",j); fclose(fp); return 0; }]])], [cstack_bits=`cat conftest1`],[cstack_bits=0]) AC_DEFINE_UNQUOTED(CSTACK_BITS,$cstack_bits,[log starting C stack address]) AC_MSG_RESULT($cstack_bits) AC_MSG_CHECKING(NEG_CSTACK_ADDRESS) AC_RUN_IFELSE( [AC_LANG_SOURCE( [[ #include #include int main(int argc,char **argv,char **envp) { #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif return (long)$cstack_address<0 ? 0 : -1; }]])], [AC_MSG_RESULT(yes) neg_cstack_address=1 AC_DEFINE(NEG_CSTACK_ADDRESS,1,[C stack address is negative])], [AC_MSG_RESULT(no) neg_cstack_address=0]) AC_ARG_ENABLE([immfix],[ --enable-immfix will enable an immediate fixnum table above the C stack]) AC_ARG_ENABLE([fastimmfix],[ --enable-fastimmfix=XXXX will reject low immediate fixnums unless 2^XXX can be attained],,[enable_fastimmfix=64]) if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec AC_MSG_CHECKING([finding default linker script]) touch unixport/gcl.script echo "int main() {return 0;}" >foo.c $CC $LDFLAGS -Wl,--verbose foo.c -o foo 2>&1 | \ $AWK '/==================================================/ {i=1-i;next} {if (i) print}' >gcl.script rm -rf foo.c foo if test "`cat gcl.script | wc -l`" != "0" ; then AC_MSG_RESULT([got it]) AC_MSG_CHECKING([output_arch]) output_arch=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1,1'|cut -f1 -d:`; if test "$output_arch" != "" ; then AC_DEFINE_UNQUOTED(OUTPUT_ARCH,bfd_arch_${output_arch},[bfd output arch]) AC_MSG_RESULT([bfd_arch_${output_arch}]) else AC_MSG_RESULT([not found]) fi AC_MSG_NOTICE([trying to adjust text start]) cp gcl.script gcl.script.def n=-1; k=0; lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; max=0; min=$lim; while test $n -lt $lim ; do j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script # diff -u gcl.script.def gcl.script echo "int main() {return 0;}" >foo.c if ( $CC $LDFLAGS -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then if test $n -lt $min ; then min=$n; fi; if test $n -gt $max; then max=$n; fi; elif test $max -gt 0 ; then break; fi; n=`$AWK 'END {print n+1}' n=$n gcl.script AC_MSG_RESULT([done]) rm -f gcl.script.def assert_arg_to_ldflags -Wl,-T,gcl.script cp gcl.script unixport else AC_MSG_RESULT([none found or not needed]) rm -f gcl.script gcl.script.def fi rm -rf foo.c foo else AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) AC_MSG_RESULT([not found]) fi else AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) fi mem_top=0 mem_range=0 AC_MSG_CHECKING(mem top) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ unsigned long i,j,k,l; FILE *fp = fopen("conftest1","w"); for (i=2,k=1;i;k=i,i<<=1); l=$cstack_address; l=$cstack_direction==1 ? (l>=1,i|=j); if (j<(k>>3)) i=0; j=1; j<<=$PAGEWIDTH; j<<=4; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i); fclose(fp); return 0; ]])], [mem_top=`cat conftest1`],[mem_top="0x0"]) AC_MSG_RESULT($mem_top) if test "$mem_top" != "0x0" ; then AC_MSG_CHECKING(finding upper mem half range) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ unsigned long j; FILE *fp = fopen("conftest1","w"); for (j=1;j && !(j& $mem_top);j<<=1); fprintf(fp,"0x%lx",j>>1); fclose(fp); return 0; ]])], [mem_range=`cat conftest1`],[mem_range="0x0"]) AC_MSG_RESULT($mem_range) if test "$mem_range" != "0x0" ; then AC_DEFINE_UNQUOTED(MEM_TOP,$mem_top,[beginning address for immediate fixnum range]) AC_DEFINE_UNQUOTED(MEM_RANGE,$mem_range,[size of immediate fixnum address space]) fi fi if test "$enable_immfix" != "no" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then AC_DEFINE_UNQUOTED(IM_FIX_BASE,${mem_top}UL,[beginning address for immediate fixnum range]) AC_DEFINE_UNQUOTED(IM_FIX_LIM,${mem_range}UL,[size of immediate fixnum address space]) fi fi fi AC_MSG_CHECKING([sizeof long long int]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; ]])], [AC_DEFINE(HAVE_LONG_LONG,1,[long long is available]) AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)]) AC_SUBST(HAVE_LONG_LONG) AC_CHECK_HEADERS([dirent.h], AC_MSG_CHECKING([for d_type]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ struct dirent *d; DIR *r=opendir("./"); for (;(d=readdir(r)) && strcmp("configure",d->d_name);); return d && d->d_type==DT_REG ? 0 : -1; ]])], [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_D_TYPE,1,[have struct dirent d_type field])], AC_MSG_RESULT([no]),AC_MSG_RESULT([no]))) # ansi lisp SYSTEM=ansi_gcl CLSTANDARD=ANSI AC_ARG_ENABLE([ansi],[ --enable-ansi builds a large gcl aiming for ansi compliance], [if test "$enable_ansi" = "no" ; then SYSTEM=gcl CLSTANDARD=CLtL1 else AC_DEFINE([ANSI_COMMON_LISP],[1],[ANSI compliant image]) fi], [AC_DEFINE([ANSI_COMMON_LISP],[1],[ANSI compliant image])]) FLISP="saved_$SYSTEM" AC_SUBST(FLISP) AC_SUBST(SYSTEM) AC_SUBST(CLSTANDARD) # Maximum number of pages # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd) AC_CHECK_FUNCS(getwd) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call])) AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) AC_CHECK_HEADERS(sys/ioctl.h) # OpenBSD has elf_abi.h instead of elf.h AC_CHECK_HEADERS(elf.h elf_abi.h) AC_CHECK_HEADERS(sys/sockio.h) #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- AC_CHECK_FUNC([BSDgettimeofday], [AC_DEFINE(HAVE_BSDGETTIMEOFDAY,1,[have bsdgettimeofday])], [AC_CHECK_FUNC([gettimeofday], , [AC_DEFINE([NO_GETTOD],1,[no gettimeofday call])])]) AC_EGREP_HEADER([gettimeofday], [sys/time.h], [AC_MSG_CHECKING([for gettimeofday declaration]) AC_MSG_RESULT([present])], [AC_MSG_CHECKING([for gettimeofday declaration]) AC_MSG_RESULT([missing]) AC_DEFINE(GETTOD_NOT_DECLARED,1,[No gettimeofday call -- fixme])]) AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) AC_MSG_CHECKING([for buggy maximum sscanf length]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; int n, m; double f; char *endptr; FILE *fp=fopen("conftest1","w"); n=sscanf(s,"%lf%n",&f,&m); fprintf(fp,"%d",m); fclose(fp); return s[m]; ]])], [AC_MSG_RESULT([none])], [buggy_maximum_sscanf_length=`cat conftest1` AC_MSG_RESULT([$buggy_maximum_sscanf_length]) AC_DEFINE_UNQUOTED(BUGGY_MAXIMUM_SSCANF_LENGTH,$buggy_maximum_sscanf_length,[sscanf terminates prematurely (Windows XP)])]) EXTRA_LOBJS= AC_ARG_ENABLE([japi],[ --enable-japi=yes will compile in support for the JAPI graphical interface if present on your system], [if test "$enable_japi" = "yes" ; then AC_CHECK_HEADERS([japi.h], [AC_DEFINE(HAVE_JAPI_H) EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" LIBS="${LIBS} -ljapi -lwsock32"]) fi]) # Should really find a way to check for prototypes, but this # basically works for now. CM # AC_CHECK_HEADERS(math.h,AC_DEFINE(HAVE_MATH_H,1,[have math.h])) AC_CHECK_HEADERS(complex.h,AC_DEFINE(HAVE_COMPLEX_H,1,[have complex.h])) # # For DBL_MAX et. al. on (only) certain Linux arches, apparently CM # AC_CHECK_HEADERS(values.h,AC_DEFINE(HAVE_VALUES_H,1,[have values.h])) # # Sparc solaris keeps this in float.h, rework either/or with values.h later # AC_CHECK_HEADERS(float.h,AC_DEFINE(HAVE_FLOAT_H,1,[have float.h])) # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # AC_MSG_CHECKING([for isnormal]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #define _GNU_SOURCE #include ]], [[ float f; return isnormal(f) || !isnormal(f) ? 0 : 1; ]])], [AC_DEFINE(HAVE_ISNORMAL,1,[Have isnormal function]) AC_MSG_RESULT(yes)], [AC_MSG_CHECKING([for fpclass of ieeefp.h]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ float f; return fpclass(f)>=FP_NZERO || fpclass(f) ]], [[ float f; return isfinite(f) || !isfinite(f) ? 0 : 1; ]])],[AC_DEFINE(HAVE_ISFINITE,1,[Have isfinite function]) AC_MSG_RESULT(yes)], [AC_MSG_CHECKING([for finite()]) AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ float f; return finite(f) || !finite(f) ? 0 : 1; ]])], [AC_DEFINE(HAVE_FINITE,1,[Have finite function]) AC_MSG_RESULT(yes)], [AC_MSG_ERROR(no)])]) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- AC_MSG_CHECKING([for sockets]) tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_LIB(socket, main, TLIBS="$TLIBS -lsocket", tcl_checkBoth=1) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$TLIBS TLIBS="$TLIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [TLIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [TLIBS="$TLIBS -lnsl"])) # readline AC_ARG_ENABLE(readline,[ --enable-readline enables command line completion via the readline library ]) if test "$use" = "mingw" ; then enable_readline=no fi if test "$enable_readline" != "no" ; then AC_CHECK_HEADERS([readline/readline.h], AC_CHECK_LIB([readline],[rl_initialize], [AC_DEFINE(USE_READLINE,1,[use readline library]) AC_CHECK_LIB([readline],[el_getc],AC_DEFINE(READLINE_IS_EDITLINE,1,[readline is editline])) # These tests discover differences between readline 4.1 and 4.3 AC_CHECK_LIB([readline],[rl_completion_matches], [AC_DEFINE(HAVE_DECL_RL_COMPLETION_MATCHES,1,[have readline completion matches]) AC_DEFINE(HAVE_RL_COMPENTRY_FUNC_T,1,[have readline completion matches])]) AC_MSG_CHECKING([RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #include extern Function *rl_completion_entry_function __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION,1,[rl_completion_entry_function returns type Function]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_CHECKING([RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #include extern rl_compentry_func_t *rl_completion_entry_function __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T,1,[rl_completion_entry_function returns type rl_compentry_func_t]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_ERROR([Unknown rl_completion_entry_function return type])])]) AC_MSG_CHECKING([RL_READLINE_NAME_TYPE_CHAR]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #include extern char *rl_readline_name __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_READLINE_NAME_TYPE_CHAR,1,[rl_readline_name returns type char]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_CHECKING([RL_READLINE_NAME_TYPE_CONST_CHAR]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #include extern const char *rl_readline_name __attribute__((weak)); ]], [[]])], [AC_DEFINE(RL_READLINE_NAME_TYPE_CONST_CHAR,1,[rl_readline_name returns type const char]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no]) AC_MSG_ERROR([Unknown rl_readline_name return type])])]) TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline.o]), [],[AC_INCLUDES_DEFAULT([#include ])]) fi AC_SUBST(RL_OBJS) AC_SUBST(RL_LIB) # sockets AC_MSG_CHECKING([For network code for nsocket.c]) AC_LINK_IFELSE( [AC_LANG_PROGRAM( [[ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ ]], [[ connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ]])], [AC_DEFINE(HAVE_NSOCKET,1,[can use nsocket library]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) AC_MSG_CHECKING([check for listen using fcntl]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #include ]], [[ FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ]])], [AC_DEFINE(LISTEN_USE_FCNTL,1,[can use fcntl for listen function]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE,1,[no profil system call])]) AC_SUBST(NO_PROFILE) AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV,1,[have setenv call])],no_setenv=1 ) AC_SUBST(HAVE_SETENV) if test "$no_setenv" = "1" ; then AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV,1,[have putenv call])],) AC_SUBST(HAVE_PUTENV) fi AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP,1,[have _cleanup function])],) AC_SUBST(USE_CLEANUP) gcl_ok=no AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; ULTRIX-4.*) AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) AC_MSG_RESULT(FIONBIO) ;; *) AC_MSG_RESULT(O_NONBLOCK) ;; esac AC_MSG_CHECKING(check for SV_ONSTACK) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include int joe=SV_ONSTACK; ]], [[]])], [AC_DEFINE(HAVE_SV_ONSTACK,1,[have sv_onstack]) AC_SUBST(HAVE_SV_ONSTACK) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) AC_MSG_CHECKING(check for SIGSYS) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include int joe=SIGSYS; ]],[[]])], [AC_DEFINE(HAVE_SIGSYS,1,[have SIGSYS signal]) AC_SUBST(HAVE_SIGSYS) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) AC_MSG_CHECKING(check for SIGEMT) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include int joe=SIGEMT; ]],[[]])], [AC_DEFINE(HAVE_SIGEMT,1,[have SIGEMT signal]) AC_SUBST(HAVE_SIGEMT) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])]) AC_CHECK_FUNCS(sigaltstack) AC_CHECK_FUNCS(feenableexcept) AC_CHECK_HEADERS(dis-asm.h, MLIBS=$LIBS AC_CHECK_LIB(opcodes,init_disassemble_info) AC_CHECK_LIB(dl,dlopen,#opcodes changes too quickly to link directly LIBS="$MLIBS -ldl")) #if test $use = "386-linux" ; then AC_CHECK_HEADERS(asm/sigcontext.h) AC_CHECK_HEADERS(asm/signal.h) AC_MSG_CHECKING([for sigcontext...]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include ]], [[ struct sigcontext foo; ]])], [AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT,1,[have sigcontext of signal.h]) AC_MSG_RESULT([sigcontext of signal.h])], [AC_MSG_RESULT([sigcontext NOT of signal.h]) AC_MSG_CHECKING([for sigcontext...]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[ #include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif ]], [[ struct sigcontext foo; ]])], [AC_DEFINE(HAVE_SIGCONTEXT,1,[have sigcontext]) AC_MSG_RESULT(sigcontext asm files)], [AC_MSG_RESULT([no sigcontext found])])]) AC_PATH_PROG(EMACS,emacs) # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_SITE_LISP="" fi fi AC_MSG_RESULT($EMACS_SITE_LISP) AC_SUBST(EMACS_SITE_LISP) # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d $EMACS_SITE_LISP ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi AC_MSG_RESULT($EMACS_DEFAULT_EL) AC_SUBST(EMACS_DEFAULT_EL) # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` fi fi AC_MSG_RESULT($INFO_DIR) AC_SUBST(INFO_DIR) AC_ARG_ENABLE([tcltk],[ --enable-tcltk will try to build gcl-tk]) AC_ARG_ENABLE([tkconfig], [ --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh], [TK_CONFIG_PREFIX=$enableval],[TK_CONFIG_PREFIX=unknown]) AC_ARG_ENABLE([tclconfig], [ --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh], [TCL_CONFIG_PREFIX=$enableval],[TCL_CONFIG_PREFIX=unknown]) if test "$enable_tcltk" != "no" ; then if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else AC_CHECK_PROG(TCLSH,tclsh,tclsh,${TCLSH}) if test "${TCLSH}" = "" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl < foo and copies orig according to the recipe in orig.V. The advantage of this program is that it does this according to the context of orig. Thus even though orig might change slightly (eg some one added an extra line to the copyright notice), the same change file will probably still be valid. If the first argument is - then the orig is standard input. If a third argument is supplied, it is the name of a file to use instead of standard output. tutorial% merge orig orig.V | merge - change2 final would take the result of merge of orig and orig.V and use it to merge with change2 to produce the file final. The format of a change (.V) file is very simple: There is only ONE type of command in a change file. REPLACE X by Y. Here X represents a chunk of text in the orig file, and Y the substitution which you wish to make for this occurrence. The Y appears explicitly in the change file, while the text X may be specified fully and explicitly, OR by giving sufficient context from the beginning and end of X. Thus in general it takes three things to specify a change. The beginning of X (Xbegin), the end of X (Xend), and all of Y. These three pieces of text are separated by four delimiters. The delimiters are not single characters, but rather sequences of four characters. This is done so as to avoid having to quote the delimiter (see QUOTING below). The delimiters are "\n@s[" "\n@s," "\n@s|" and "\n@s]". NOTE: The \n (Newline) Character IS PART OF THE DELIMITER in ALL CASES. @s[X @s|Y @s] Thus in the above case the X text is only "X" it does not have any newlines in it! They belong to the delimiters. For "X\n" we would see @s[X @s|Y @s] The general case where X is a very long chunk of text, or perhaps something sensitive to copyright, so that you cannot include several pages, you could make Xbegin be the first few lines, and Xend the last few lines. All intervening lines (including the Xbegin and the Xend, would be ripped out, and replaced by Y. @s[Xbegin @s,Xend @s|Y @s] One cycle of the merge may be thought of as: The merge program looks in the change (.V) file for the next \ns[, in order to determine the next values for Xbegin,Xend,and Y. Having determined these, its position in the (.V) file will have advanced to after the \n@s]. The merge program then starts at its current position in the original file and searches for the next occurrence of Xbegin, marking its beginning, then for the end of Xend. The inclusive interval so marked, is deleted and Y is substituted. The current position in the original file is now at the end of the Xend text. The next Xbegin text must occur after that point. Only one pass is made through the files. It is an error if the start of Xend does not follow the end of Xbegin. Thus Xbegin and Xend may NOT overlap. A common case will be that Xbegin is the entire interval and Xend = "" In this case the merge program, if it finds \n@s| before \n@s, will assume you want Xend="". EXAMPLES: @s[Hi bill @s, @s|new body @s] would delete the string "Hi bill" replacing it with "new body" Xbegin="Hi bill" Xend="" Interval = "Hi bill" Equivalently since the E interval is empty, we could have just omitted the \@s, @s[Hi bill @s|new body @s] Example of change file with two changes: **************** @s[(defmacro lcase (item &body body) @s, (setq v (car rest)) @s|(defmacro lcase (items &body body) (setq v (cadr rest)) @s] Comments are allowed in change files. In fact anything not between matching "\ns[" and "\ns]" is a comment. @s[How is he @s, He is fine. @s|He is sick. @s] ******* end of change file The first change would replace the interval of the original file "(defmacro.... (setq v (car rest))" by "(defmacro lcase (items &body body) (setq v (cadr rest))" If the program could not find the interval "(defmacro.... (setq v (car rest))" in the orignal file it would warn you. The intervals in the change file, must occur in the same order as in the original file. There is an emacs program merge.el which can mechanically produce a changes file from an original and an edited version. Note: For convenience we pretend that the change file starts with a new line, even if it does not. Thus if @s[ are the first three characters of the file and CHSTART1 = \n@s[, we count this as a CHSTART1. Since it is in the first column, it "appears" to have the new line there. QUOTING: In order to have a change which involves one of the four letter delimiters given above, we use the convention that "\n@@" in the first column translates to "\n@". You need not perform this quoting of @ unless the merger would be confused. For example \n@(defun .. would be ok, since this can't be mistaken for one of our delimiters. Nonetheless \n@@(defun or \n@@s[ would translate to have one @ sign, in the merge output. The reason for not doubling all @ signs, is that it is very easy to scan (visually) a change you are constructing, to see that there are no @ signs in the first column, or at least none which could be confused for the four letter change delimiters "\n@s[","\n@s," ... A poor human constructing a change (.V) file should not have to sort through the X or Y text adding quoting characters. Note on length: Y may be any length, but Xbegin or Xend, may only be CONTEXT_LIMIT long. */ /****************** THE CODE ********************/ #include #define CONTEXT_LIMIT 3000 /* size of the longest delimiter or replacement */ char *malloc(); void copy_rest(); char ssearch_for_string(); #define NULL_OUT (FILE *)0 #define CHSTART1 "\n@s[" #define CHSTART2 "\n@s," #define CHSTART3 "\n@s|" #define CHSTART4 "\n@s]" #define ACCEPT ",|" #define NOACCEPT (char *) 0 #define NUL '\0' #define TRUE 1 #define FALSE 0 #define eofch(ch) ((unsigned char)ch == (unsigned char) EOF) char filenames[600]; #define myerror(string,arg) {(void)fprintf(stderr,string,arg); exit(-1);} main(argc,argv) int argc; char *argv[]; {FILE *orig,*changes,*out; char *context,*endcontext; char *origname,*altername,*outname; char found; context=malloc(CONTEXT_LIMIT+2); endcontext=malloc(CONTEXT_LIMIT+2); outname=(char *)0; if (argc==1) {int tem; origname=filenames; altername=filenames+200; outname=filenames+400; /* get names from stdin */ if (tem=scanf("%s %s %s",origname,altername,outname)); else myerror("Three args weren't supplied: scanf returned %d\n",tem); } else{ if (!((argc==3) || (argc==4))) { myerror("Usage: merge file-orig file-changes [out-file]\n %d args given",argc-1);} else { origname=argv[1]; altername=argv[2]; if (argc >= 4) outname=argv[3];}}; /* now we have the names either from command or stdin, so open files */ if(origname[0]=='-' && origname[1]==NULL) orig=stdin; else{ orig=fopen(origname,"r"); if (!orig) {perror(origname); exit(-1);}; } changes=fopen(altername,"r"); if (!changes) {perror(origname); exit(-1);}; if (outname) {out=fopen(outname,"w"); if (out); else {perror(outname); exit(-1);}} else out=stdout; /* check if the file starts with chstart1 - newline. to avoid people thinking that starting file with @s[ is ok. */ {char *str = CHSTART1; int ch; while(*(++str)) /* skip the newline start */ { (ch=getc(changes)); if (ch == *str) ; else { ungetc(ch,changes); goto not_found;} } goto got_one; not_found:;} {while(search_for_string(changes,CHSTART1,NULL_OUT,FALSE) > 0) { got_one: if (found= ssearch_for_string(changes,CHSTART2,context,CONTEXT_LIMIT,TRUE, ACCEPT)); else {myerror("\nNo end for start change context in change file:\n`%s'\n",context);}; if (found==ACCEPT[1]) *endcontext=NUL; else { if /* there is probably a non null endcontext */ (ssearch_for_string(changes,CHSTART3,endcontext, CONTEXT_LIMIT,TRUE,NOACCEPT)); else {myerror("No %s at beginning of line to denote end of change context", CHSTART3);}}; /* skip in orig down to the end of the context,copying thru begin context */ if (search_for_string(orig,context,out,FALSE)>0); else{myerror("\nCould not find the change start in original:\n`%s'\n" ,context);}; if /* copy out the changed version */ (search_for_string(changes,CHSTART4,out,TRUE)>0); else {myerror("No %s at beginning of line to denote end of change context", CHSTART4);}; /*finish skipping over the region to be deleted in orig */ {if( search_for_string(orig,endcontext,NULL_OUT,FALSE) > 0); else {myerror("\nCould not find the end of the change in original:\n`%s'\n", endcontext);}} } copy_rest(orig,out); return 0; }} string_match(sta,stb) char *sta, *stb; {while(*sta!=0) {if (*(sta++) != *(stb++)) return 0;} if (*stb==0) return 1; else return 0; } void copy_rest(file,out) FILE *file,*out; {register int ch; while(1) { ch=getc(file); if (eofch(ch) && feof(file)) break; putc(ch,out);}} /* advance file to end of first occurrence of string, copying to out until the beginning of string */ #define USE_UNQUOTE 1 search_for_string(file,string,out,unquoting) FILE *file,*out; char *string; int unquoting; {int result; result=search_for_string1(file,string,out,USE_UNQUOTE && unquoting); return result;} char *nxt,*lim,*ungetlim,*bp; char buffer[CONTEXT_LIMIT]; /* void myungetc(ch) char ch; {*bp++ = ch;} char mygetc(file) FILE *file; {char x=((bp==buffer)? getc(file) : *--bp); return x; } */ #define mygetc(file) ((bp==buffer)? getc(file) : *--bp) #define myungetc(ch) *bp++ = ch search_for_string1(file,string,out,unquoting) FILE *file,*out; char *string; int unquoting; { /* char *nxt,*lim; */ char *s; int ch; nxt=lim=(char *)0; bp=buffer; if (*string==NUL) return 1; unquoting; while(1) {begin: ch=mygetc(file); if ((eofch(ch)) &&(feof(file))) return 0; if( ch==*string) { /* loop for checking */ s = string; while(*(++s)!=0) {(ch=mygetc(file)); if (eofch(ch) && feof(file)) {char *cp=string;while (cp++<=s) {putc(*cp,file) ; return 0;}}; if (*s!=ch) { if (out) putc(*string,out); {char *cp=s; if (!(unquoting && ch==string[1] && (s-string ==2))) myungetc(ch); while (--cp > string) myungetc(*cp); goto begin;}} } return 1; /* printf(""); */ } else if (out) putc(ch,out);}; } #define PUTC(ch,out) {if(ind++ < outlim) ((*(out++))=(ch));\ else return -1;} char ssearch_for_string1(file,string,out,outlim,unquoting,accept) int outlim,unquoting; FILE *file; char *out; char *string,*accept; {register int ch; char *s; int ind=0; if (*string==NUL) return 'a'; while(1) {ch = getc(file); begin: if (feof(file)) return (char) 0; if (ch==(*string)) {s=string; ind=0; while(*(++s)!=0) {if ((*s==(ch=getc(file))) || (accept && *s==*accept && ch == *(accept+1))); else {if (out) {char *cp; cp=string; if (unquoting && ch==string[1] && (s-string ==2)) s--; while (cp!=s) {PUTC(*cp,out);cp++;} } break;}} if(*s==0) {PUTC(((char) 0),out); /* found a match */ return(ch);} else goto begin;} else if (out) PUTC(ch,out); } } char ssearch_for_string(file,string,out1,outlim,unquoting,accept) int outlim; FILE *file; char *out1; char *string,*accept; int unquoting; {char result; result=ssearch_for_string1(file,string,out1,outlim,unquoting,accept); return result;} /* * * To do: * 1)The buffering for mygetc could be more efficient (in local variable). * 2)Eliminate the double function calls used during debugging. * 3)Improve error message, for help in finding context if a change * is not found. */ gcl-2.6.14/readme-bin.mingw0000644000175000017500000000141214360276512014037 0ustar cammcammHi there! WHAT NOW: You are installing GNU Common Lisp for Windows, 2.6.8 This compiler uses the Minimalist GNU Windows 32 compiler tools (MinGW32, see below). IF YOU INSTALL INTO A DIRECTORY WITH SPACES IN THE NAME, MAKE SURE you use the DOSified form eg: c:/Progra~1/somewhere. MINGW32 GCC: The MinGW compiler is provided subject to the terms of the files: "COPYING" and "COPYING.LIB" located in the mingw sub-directory. The source code and updated binary packages can be obtained via the official MinGW web site: http://sourceforge.net/projects/mingw/ We recommend that you use the compiler provided when working with this GCL package for compatibility. Clean and rebuild pre-existing projects whenever you upgrade the GCL binary package for this reason. gcl-2.6.14/add-defs10000755000175000017500000000423014360276512012450 0ustar cammcamm#!/bin/sh #CC=cc if test "$1" = "mingw" -o "$1" = "gnuwin95" ; then EXE=.exe ; # CC=gcc rm -f o/*.ini fi #(cd bin ; make file-sub EXE=${EXE} CC=${CC}) if [ $# -le 0 ] ; then echo usage: ./add-defs machine-type; echo or ' ' ./add-defs machine-type directory echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs echo see echo h/*.defs exit 1 ; fi if [ -f h/$1.defs ] ; then echo using $1.defs ; else echo h/$1.defs does not exist echo Build one or use one of `ls h/*.defs` exit 1 fi echo $1 > machine # rm -f makedefs # echo > makedefs # echo "# begin makedefs" >> makedefs # echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs rm -f makedefs cp makedefc makedefs if [ -d ${PWD}/unixport ] ; then echo "GCLDIR=${PWD}" >> makedefs ; else echo "GCLDIR=`pwd`" >> makedefs ; fi echo "SHELL=/bin/sh" >> makedefs echo "MACHINE=$1" >> makedefs ####machine specific .defs files may over ride the above#### ####### insert the h/machine.defs file ############ cat h/$1.defs >> makedefs if [ -f makedefsafter ] ; then cat makedefsafter >> makedefs ; fi if [ -f ${HOME}/local_gcl.defs ] ; then cat ${HOME}/local_gcl.defs >> makedefs fi echo "" >> makedefs echo "# end makedefs" >> makedefs # echo inserting h/$1.defs in .. # for v in makefile unixport/make_kcn */makefile ; # do # echo " $v," # ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx # mv tmpx $v # done # #echo "" # Copy the config.h over. cat h/$1.h > tmpx if [ -f ${HOME}/local_gcl.h ] ; then cat ${HOME}/local_gcl.h >> tmpx fi if fgrep =unknown makedefs > /dev/null ; then echo " if the 'unknown' directories exist you may provide a second argument to ./add-defs of a local directory where things might be, or edit ./add-defs so that it can find them. Otherwise just continue and the portions with unknown will not be compiled." fi if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; else rm -f h/config.h cp tmpx h/config.h fi rm -f tmpx # machine specific stuff that cant be handled normally... if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi gcl-2.6.14/lsp/0000755000175000017500000000000014360276512011571 5ustar cammcammgcl-2.6.14/lsp/gcl_truename.lsp0000644000175000017500000000354014360276512014760 0ustar cammcamm(in-package :si) (defun link-expand (str &optional (b 0) (n (length str)) fr) (labels ((frame (b e) (make-array (- n b) :element-type 'character :displaced-to str :displaced-index-offset b :fill-pointer (- e b))) (set-fr (fr e &aux (fr (or fr (frame 0 b)))) (setf (fill-pointer fr) e) fr)) (let* ((i (string-match +dirsep+ str b)) (fr (set-fr fr (if (eql i -1) n i))) (l (when (eq (stat1 fr) :link) (readlinkat 0 fr)))) (cond (l (let ((b (if (eql #\/ (aref l 0)) 0 b))) (link-expand (string-concatenate (set-fr fr b) l (frame (if (eql i -1) n i) n)) b))) ((eql i -1) str) ((link-expand str (1+ i) n fr)))))) (defun logical-pathname-designator-p (x) (typecase x (string (logical-pathname-parse x)) (pathname (typep x 'logical-pathname)) (stream (logical-pathname-designator-p (pathname x))))) (defun truename (pd &aux (ns (namestring (translate-logical-pathname pd)))) (declare (optimize (safety 1))) (check-type pd pathname-designator) (when (wild-pathname-p ns) (error 'file-error :pathname pd :format-control "Pathname is wild")) (let* ((ns (ensure-dir-string (link-expand ns))) (ppd (if (eq (namestring pd) ns) pd (pathname ns)))) (unless (or (zerop (length ns)) (stat1 ns)) (error 'file-error :pathname ns :format-control "Pathname does not exist")) (let* ((d (pathname-directory ppd)) (d1 (subst :back :up d)) (ppd (if (eq d d1) ppd (make-pathname :directory d1 :defaults ppd)))) (if (eq (car d) :absolute) ppd (merge-pathnames ppd *current-directory* nil))))) (defun probe-file (pd &aux (pn (translate-logical-pathname pd))) (declare (optimize (safety 1))) (check-type pd pathname-designator) (when (wild-pathname-p pn) (error 'file-error :pathname pn :format-control "Pathname is wild")) (when (eq (stat1 (link-expand (namestring pn))) :file) (truename pn))) gcl-2.6.14/lsp/gcl_make_pathname.lsp0000644000175000017500000001660214360276512015735 0ustar cammcamm(in-package :si) ;; (defun pathnamep (x) ;; (declare (optimize (safety 1))) ;; (when (typep x 'pathname) t)) (eval-when (compile eval) (defun add-dir-sep (s &optional (i 0) (bp 0) (l (length s))) (when (< i l) (let ((x (aref s i))) (append (if (eql x #\/) (if (zerop bp) (list #\[ x #\\ #\]) (list x #\\)) (list x)) (add-dir-sep s (1+ i) (case x (#\[ (1+ bp))(#\] (1- bp))(otherwise bp)) l))))) (defun ads (s) #+winnt (coerce (add-dir-sep s) 'string) #-winnt s)) (defconstant +dirsep+ (compile-regexp #.(ads "/"))) (defconstant +glob-to-regexp-alist+ (list (cons #v"{[^}]*}" (lambda (x) (msub '((#\| . #\,)(#\( . #\{)(#\) . #\})) x))) (cons #v"\\[[^\\]*\\]" (lambda (x) (string-concatenate "(" (substitute #\^ #\! (subseq x 0 2)) (subseq x 2) ")"))) (cons #v"\\*" (lambda (x) #.(ads "([^/.]*)"))) (cons #v"\\?" (lambda (x) #.(ads "([^/.])"))) (cons #v"\\." (lambda (x) "\\.")))) (defconstant +physical-pathname-defaults+ '(("" "" "") #+winnt("" "([A-Za-z]:)?" ":") #-winnt("" "()" "") ("" #.(ads "(/?([^/]*/)*)") "" "" #.(ads "([^/]*/)") "/") ("" #.(ads "([^/.]*)") "") ("." #.(ads "(\\.[^/]*)?") "") ("" "" ""))) (defconstant +logical-pathname-defaults+ '(("" "([-0-9A-Z]+:)?" ":") ("" "" "") ("" "(;?((\\*?([-0-9A-Z]+\\*?)+|\\*|\\*\\*);)*)" "" "" "((\\*?([-0-9A-Z]+\\*?)+|\\*);)" ";") ("" "(\\*?([-0-9A-Z]+\\*?)+|\\*)?" "") ("." "(\\.(\\*?([-0-9A-Z]+\\*?)+|\\*))?" "") ("." "(\\.([1-9][0-9]*|newest|NEWEST|\\*))?" ""))) (defun msub (a x) (if a (msub (cdr a) (substitute (caar a) (cdar a) x)) x)) (defun mglist (x &optional (b 0)) (let* ((y (mapcan (lambda (z &aux (w (string-match (car z) x b))) (unless (eql w -1) (list (list w (match-end 0) z)))) +glob-to-regexp-alist+)) (z (when y (reduce (lambda (y x) (if (< (car x) (car y)) x y)) y)))) (when z (cons z (mglist x (cadr z)))))) (defun mgsub (x &optional (l (mglist x)) (b 0) &aux (w (pop l))) (if w (string-concatenate (subseq x b (car w)) (funcall (cdaddr w) (subseq x (car w) (cadr w))) (mgsub x l (cadr w))) (subseq x b))) (defun elsub (el x rp lp &aux (y x) (pref (pop y))(dflt (pop y))(post (pop y))) ; (destructuring-bind (pref dflt post &rest y) x (etypecase el (string (let ((x (list pref el post))) (unless (zerop (length dflt)) (if rp (mapcar 'mgsub x) x)))) (integer (elsub (write-to-string el) x rp lp)) ((eql :wild-inferiors) (if rp (list "(" dflt "*)") (elsub "**" x rp lp))) ((eql :wild) (if rp (list dflt) (elsub "*" x rp lp))) ((eql :newest) (elsub (if rp "(newest|NEWEST)" "NEWEST") x rp lp)) ((member :up :back) (elsub ".." x rp lp)) ((member nil :unspecific) (when rp (list dflt))) (cons (cons (if (eq (car el) :absolute) (if lp "" "/") (if lp ";" "")) (mapcan (lambda (z) (elsub z y rp lp)) (cdr el))))) ; ) ) (defun to-regexp-or-namestring (x rp lp) (apply 'string-concatenate (mapcan (lambda (x y) (elsub x y rp lp)) x (if lp +logical-pathname-defaults+ +physical-pathname-defaults+)))) (defun directory-list-check (l) (when (listp l) (when (member (car l) '(:absolute :relative)) (mapl (lambda (x &aux (c (car x))(d (cadr x))) (when (and (member d '(:up :back)) (member c '(:absolute :wild-inferiors))) (return-from directory-list-check nil))) l)))) (defun canonicalize-pathname-directory (l &aux x) (cond ((eq l :wild) (canonicalize-pathname-directory '(:absolute :wild-inferiors))) ((stringp l) (canonicalize-pathname-directory (list :absolute l))) ((and (eq (car l) :relative) (stringp (cadr l)) (plusp (length (cadr l))) (eql #\~ (aref (cadr l) 0))) (canonicalize-pathname-directory (nconc (dir-parse (home-namestring (cadr l))) (cddr l)))) ((setq x (member-if (lambda (x) (or (string-equal "" x) (string-equal "." x))) l)) (canonicalize-pathname-directory (nconc (ldiff l x) (cdr x)))) ((setq x (member :back l)) (let* ((y (ldiff l x))(ll (car (last y)))) (canonicalize-pathname-directory (if (or (stringp ll) (eq ll :wild)) (nconc (butlast y) (cdr x)) (nconc y (cons :up (cdr x))))))) (l))) (defvar *default-pathname-defaults* (init-pathname nil nil nil nil nil nil "")) (declaim (type pathname *default-pathname-defaults*)) (defun toggle-case (x) (cond ((symbolp x) x) ((listp x) (mapcar 'toggle-case x)) ((find-if 'upper-case-p x) (if (find-if 'lower-case-p x) x (string-downcase x))) ((find-if 'lower-case-p x) (string-upcase x)) (x))) (defun logical-pathname (spec &aux (p (pathname spec))) (declare (optimize (safety 1))) (check-type spec pathname-designator) (check-type p logical-pathname) p) (eval-when (compile eval) (defun strsym (p &rest r) (declare (:dynamic-extent r)) (intern (apply 'string-concatenate (mapcar 'string-upcase r)) p))) #.`(defun make-pathname (&key (host nil hostp) (device nil devicep) (directory nil directoryp) (name nil namep) (type nil typep) (version nil versionp) defaults (case :local) namestring &aux defaulted (def (when defaults (pathname defaults)))) (declare (optimize (safety 1))) (check-type host (or (member nil :unspecific) string)) (check-type device (or (member nil :unspecific) string)) (check-type directory (or (member nil :unspecific :wild) string list)) (check-type name (or string (member nil :unspecific :wild))) (check-type type (or string (member nil :unspecific :wild))) (check-type version (or (integer 1) (member nil :unspecific :wild :newest))) (check-type defaults (or null pathname-designator)) (check-type case (member :common :local)) ,(flet ((def? (k) `(let* (,@(when (eq k 'host) `((def (or def *default-pathname-defaults*)))) (nk (if ,(strsym :si k "P") ,k (when def (,(strsym :si "C-PATHNAME-" k) def)))) (nk (unless (equal "" nk) nk)) (nk (progn (unless (eq ,k nk) (setq defaulted t)) nk)) (nk (if (eq case :local) nk (progn (setq defaulted t) (toggle-case nk))))) nk))) `(let* ((h ,(def? 'host)) (h (cond ((logical-pathname-host-p h) h)(h (setq defaulted t) nil))) (dev ,(def? 'device)) (d ,(def? 'directory)) (d (let ((d1 (canonicalize-pathname-directory d))) (unless (eq d d1) (setq defaulted t)) d1)) (n ,(def? 'name)) (typ ,(def? 'type)) (v ,(def? 'version)) (p (init-pathname h dev d n typ v (or (unless defaulted namestring) (to-regexp-or-namestring (list h dev d n typ v) nil h))))) (when h (c-set-t-tt p 1)) (unless (eq d (directory-list-check d)) (error 'file-error :pathname p :format-control "Bad directory list")) p))) (macrolet ((pn-accessor (k &aux (f (strsym :si "PATHNAME-" k)) (c (strsym :si "C-PATHNAME-" k))) `(defun ,f (p &key (case :local) &aux (pn (pathname p))) (declare (optimize (safety 1))) (check-type p pathname-designator) (let ((x (,c pn))) (if (eq case :local) x (toggle-case x)))))) (pn-accessor host) (pn-accessor device) (pn-accessor directory) (pn-accessor name) (pn-accessor type) (pn-accessor version)) (defconstant +pathname-keys+ '(:host :device :directory :name :type :version)) #.`(defun mlp (p) (list ,@(mapcar (lambda (x) `(,(strsym :si "C-PATHNAME-" x) p)) +pathname-keys+))) (defun pnl1 (x) (list* (pop x) (pop x) (append (pop x) x))) (defun lnp (x) (list* (pop x) (pop x) (let ((q (last x 3))) (cons (ldiff x q) q)))) gcl-2.6.14/lsp/gcl_auto_new.lsp0000755000175000017500000001702214360276512014764 0ustar cammcamm(in-package :si) ;;; Autoloaders. ;;; DEFAUTOLOAD definitions. for lsp directory files normally loaded. (if (fboundp 'abs) (push :numlib *features*)) ;;hack to avoid interning all the :symbols if the files are loaded.. #-numlib (progn (autoload 'abs '|gcl_numlib|) (autoload 'acos '|gcl_numlib|) (autoload 'acosh '|gcl_numlib|) (autoload 'adjust-array '|gcl_arraylib|) (autoload 'apropos '|gcl_packlib|) (autoload 'apropos-list '|gcl_packlib|) (autoload 'array-dimensions '|gcl_arraylib|) (autoload 'array-in-bounds-p '|gcl_arraylib|) (autoload 'array-row-major-index '|gcl_arraylib|) (autoload 'asin '|gcl_numlib|) (autoload 'asinh '|gcl_numlib|) (autoload 'atanh '|gcl_numlib|) (autoload 'best-array-element-type '|gcl_arraylib|) (autoload 'bit '|gcl_arraylib|) (autoload 'bit-and '|gcl_arraylib|) (autoload 'bit-andc1 '|gcl_arraylib|) (autoload 'bit-andc2 '|gcl_arraylib|) (autoload 'bit-eqv '|gcl_arraylib|) (autoload 'bit-ior '|gcl_arraylib|) (autoload 'bit-nand '|gcl_arraylib|) (autoload 'bit-nor '|gcl_arraylib|) (autoload 'bit-not '|gcl_arraylib|) (autoload 'bit-orc1 '|gcl_arraylib|) (autoload 'bit-orc2 '|gcl_arraylib|) (autoload 'bit-xor '|gcl_arraylib|) (autoload 'byte '|gcl_numlib|) (autoload 'byte-position '|gcl_numlib|) (autoload 'byte-size '|gcl_numlib|) (autoload 'cis '|gcl_numlib|) (autoload 'coerce '|gcl_predlib|) (autoload 'compile-file '|gcl_loadcmp|) (autoload 'compile '|gcl_loadcmp|) (autoload 'disassemble '|gcl_loadcmp|) (autoload 'concatenate '|gcl_seq|) (autoload 'cosh '|gcl_numlib|) (autoload 'count '|gcl_seqlib|) (autoload 'count-if '|gcl_seqlib|) (autoload 'count-if-not '|gcl_seqlib|) (autoload 'decode-universal-time '|gcl_mislib|) (autoload 'delete '|gcl_seqlib|) (autoload 'delete-duplicates '|gcl_seqlib|) (autoload 'delete-if '|gcl_seqlib|) (autoload 'delete-if-not '|gcl_seqlib|) (autoload 'deposit-field '|gcl_numlib|) (autoload 'describe '|gcl_describe|) (autoload 'dpb '|gcl_numlib|) (autoload 'dribble '|gcl_iolib|) (autoload 'encode-universal-time '|gcl_mislib|) (autoload 'every '|gcl_seq|) (autoload 'fceiling '|gcl_numlib|) (autoload 'ffloor '|gcl_numlib|) (autoload 'fill '|gcl_seqlib|) (autoload 'find '|gcl_seqlib|) (autoload 'find-all-symbols '|gcl_packlib|) (autoload 'find-if '|gcl_seqlib|) (autoload 'find-if-not '|gcl_seqlib|) (autoload 'fround '|gcl_numlib|) (autoload 'ftruncate '|gcl_numlib|) #-unix (autoload 'get-decoded-time '|gcl_mislib|) #+aosvs (autoload 'get-universal-time '|gcl_mislib|) (autoload 'get-setf-expansion '|gcl_setf|) (autoload 'inspect '|gcl_describe|) (autoload 'intersection '|gcl_listlib|) (autoload 'isqrt '|gcl_numlib|) (autoload 'ldb '|gcl_numlib|) (autoload 'ldb-test '|gcl_numlib|) (autoload 'logandc1 '|gcl_numlib|) (autoload 'logandc2 '|gcl_numlib|) (autoload 'lognand '|gcl_numlib|) (autoload 'lognor '|gcl_numlib|) (autoload 'lognot '|gcl_numlib|) (autoload 'logorc1 '|gcl_numlib|) (autoload 'logorc2 '|gcl_numlib|) (autoload 'logtest '|gcl_numlib|) (autoload 'make-array '|gcl_arraylib|) (autoload 'make-sequence '|gcl_seq|) (autoload 'map '|gcl_seq|) (autoload 'mask-field '|gcl_numlib|) (autoload 'merge '|gcl_seqlib|) (autoload 'mismatch '|gcl_seqlib|) (autoload 'nintersection '|gcl_listlib|) (autoload 'notany '|gcl_seq|) (autoload 'notevery '|gcl_seq|) (autoload 'si::normalize-type ':predlib) (autoload 'nset-difference '|gcl_listlib|) (autoload 'nset-exclusive-or '|gcl_listlib|) (autoload 'nsubstitute '|gcl_seqlib|) (autoload 'nsubstitute-if '|gcl_seqlib|) (autoload 'nsubstitute-if-not '|gcl_seqlib|) (autoload 'nunion '|gcl_listlib|) (autoload 'phase '|gcl_numlib|) (autoload 'position '|gcl_seqlib|) (autoload 'position-if '|gcl_seqlib|) (autoload 'position-if-not '|gcl_seqlib|) (autoload 'prin1-to-string '|gcl_iolib|) (autoload 'princ-to-string '|gcl_iolib|) (autoload 'rational '|gcl_numlib|) (autoload 'rationalize '|gcl_numlib|) (autoload 'read-from-string '|gcl_iolib|) (autoload 'reduce '|gcl_seqlib|) (autoload 'remove '|gcl_seqlib|) (autoload 'remove-duplicates '|gcl_seqlib|) (autoload 'remove-if '|gcl_seqlib|) (autoload 'remove-if-not '|gcl_seqlib|) (autoload 'replace '|gcl_seqlib|) (autoload 'sbit '|gcl_arraylib|) (autoload 'search '|gcl_seqlib|) (autoload 'set-difference '|gcl_listlib|) (autoload 'set-exclusive-or '|gcl_listlib|) (autoload 'signum '|gcl_numlib|) (autoload 'sinh '|gcl_numlib|) (autoload 'some '|gcl_seq|) (autoload 'sort '|gcl_seqlib|) (autoload 'stable-sort '|gcl_seqlib|) (autoload 'subsetp '|gcl_listlib|) (autoload 'substitute '|gcl_seqlib|) (autoload 'substitute-if '|gcl_seqlib|) (autoload 'substitute-if-not '|gcl_seqlib|) (autoload 'subtypep '|gcl_predlib|) (autoload 'tanh '|gcl_numlib|) (autoload 'typep '|gcl_predlib|) (autoload 'union '|gcl_listlib|) (autoload 'vector '|gcl_arraylib|) (autoload 'vector-pop '|gcl_arraylib|) (autoload 'vector-push '|gcl_arraylib|) (autoload 'vector-extend '|gcl_arraylib|) (autoload 'write-to-string '|gcl_iolib|) (autoload 'y-or-n-p '|gcl_iolib|) (autoload 'yes-or-no-p '|gcl_iolib|) (set-dispatch-macro-character #\# #\a 'si::sharp-a-reader) (set-dispatch-macro-character #\# #\A 'si::sharp-a-reader) (autoload 'si::sharp-a-reader '"iolib") (set-dispatch-macro-character #\# #\s 'si::sharp-s-reader) (set-dispatch-macro-character #\# #\S 'si::sharp-s-reader) (autoload 'si::sharp-s-reader '|gcl_iolib|) ;;; DEFAUTOLOADMACRO definitions. (autoload-macro 'assert '|gcl_assert|) (autoload-macro 'ccase '|gcl_assert|) (autoload-macro 'check-type '|gcl_assert|) (autoload-macro 'ctypecase '|gcl_assert|) (autoload-macro 'decf '|gcl_setf|) (autoload-macro 'define-modify-macro '|gcl_setf|) (autoload-macro 'define-setf-method '|gcl_setf|) (autoload-macro 'defsetf '|gcl_setf|) (autoload-macro 'defstruct '|gcl_defstruct|) (autoload-macro 'si::define-structure '|gcl_defstruct|) (autoload-macro 'deftype '|gcl_predlib|) (autoload-macro 'do-all-symbols '|gcl_packlib|) (autoload-macro 'do-external-symbols '|gcl_packlib|) (autoload-macro 'do-symbols '|gcl_packlib|) (autoload-macro 'ecase '|gcl_assert|) (autoload-macro 'etypecase '|gcl_assert|) (autoload-macro 'incf '|gcl_setf|) (autoload-macro 'pop '|gcl_setf|) (autoload-macro 'push '|gcl_setf|) (autoload-macro 'pushnew '|gcl_setf|) (autoload-macro 'remf '|gcl_setf|) (autoload-macro 'rotatef '|gcl_setf|) (autoload-macro 'setf '|gcl_setf|) (autoload-macro 'shiftf '|gcl_setf|) (autoload-macro 'step '|gcl_trace|) (autoload-macro 'time '|gcl_mislib|) (autoload-macro 'trace '|gcl_trace|) (autoload-macro 'typecase '|gcl_assert|) (autoload-macro 'untrace '|gcl_trace|) (autoload-macro 'with-input-from-string '|gcl_iolib|) (autoload-macro 'with-open-file '|gcl_iolib|) (autoload-macro 'with-open-stream '|gcl_iolib|) (autoload-macro 'with-output-to-string '|gcl_iolib|) ) ;;end autoloads of normally loaded files.j (if (find-package "COMPILER") (push :compiler *features*)) #+compiler (autoload 'compiler::emit-fn '|../cmpnew/gcl_collectfn|) (autoload 'compiler::init-fn '|../cmpnew/gcl_collectfn|) (autoload 'si::monstartup '"gprof") (autoload 'si::set-up-profile '"profile") (AUTOLOAD 'IDESCRIBE '|gcl_info|) (AUTOLOAD 'INFO '|gcl_info|) (AUTOLOAD 'LIST-MATCHES '|gcl_info|) (AUTOLOAD 'get-match '|gcl_info|) (AUTOLOAD 'print-node '|tinfo|) (AUTOLOAD 'offer-choices '|tinfo|) (AUTOLOAD 'tkconnect '|tkl|) (AUTOLOAD 'user::xgcl-demo '|gcl_dwtest|) (defun user::xgcl nil (use-package :xlib) (format t "Welcome to xgcl! Try (xgcl-demo) for a demonstration.")) ;; the sun has a broken ypbind business, if one wants to save. ;; So to stop users from invoking this #+sun (defun user-homedir-pathname () (let* ((tem (si::getenv "HOME"))) (when tem (pathname (coerce-slash-terminated tem))))) (AUTOLOAD 'init-readline '|gcl_readline|) gcl-2.6.14/lsp/gcl_predlib.lsp0000755000175000017500000007513414360276512014574 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; predlib.lsp ;;;; ;;;; predicate routines (in-package :si) (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))) ) ;;; DEFTYPE macro. (defmacro deftype (name lambda-list &rest body) ;; Replace undefaultized optional parameter X by (X '*). (do ((l lambda-list (cdr l)) (m nil (cons (car l) m))) ((null l)) (when (member (car l) lambda-list-keywords) (unless (eq (car l) '&optional) (return nil)) (setq m (cons '&optional m)) (setq l (cdr l)) (do () ((or (null l) (member (car l) lambda-list-keywords))) (if (symbolp (car l)) (setq m (cons (list (car l) ''*) m)) (setq m (cons (car l) m))) (setq l (cdr l))) (setq lambda-list (nreconc m l)) (return nil))) `(eval-when (compile eval load) (si:putprop ',name '(deftype ,name ,lambda-list ,@body) 'deftype-form) (si:putprop ',name #'(lambda ,lambda-list ,@body) 'deftype-definition) (si:putprop ',name ,(find-documentation body) 'type-documentation) ',name)) ;;; Some DEFTYPE definitions. (deftype string-stream nil `(or (satisfies string-input-stream-p) (satisfies string-output-stream-p))) (deftype spice nil `(satisfies spice-p)) (deftype fixnum () `(integer ,most-negative-fixnum ,most-positive-fixnum)) (deftype bit () '(integer 0 1)) (deftype mod (n) `(integer 0 ,(1- n))) (deftype signed-byte (&optional s) (if (eq s '*) `(integer * *) `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s)))))) (deftype unsigned-byte (&optional s) (if (eq s '*) `(integer 0 *) `(integer 0 ,(1- (expt 2 s))))) (deftype signed-char ()`(signed-byte ,char-size)) (deftype unsigned-char ()`(unsigned-byte ,char-size)) (deftype signed-short ()`(signed-byte ,short-size)) (deftype unsigned-short ()`(unsigned-byte ,short-size)) (deftype vector (&optional element-type size) `(array ,element-type (,size))) (deftype string (&optional size) `(vector character ,size)) (deftype base-string (&optional size) `(vector base-char ,size)) (deftype bit-vector (&optional size) `(vector bit ,size)) (deftype simple-vector (&optional size) `(simple-array t (,size))) (deftype simple-string (&optional size) `(simple-array character (,size))) (deftype simple-base-string (&optional size) `(simple-array base-char (,size))) (deftype simple-bit-vector (&optional size) `(simple-array bit (,size))) (defun simple-array-p (x) (and (arrayp x) ;; should be (not (expressly-adjustable-p x)) ;; since the following will always return T ;; (not (adjustable-array-p x)) (not (array-has-fill-pointer-p x)) (not (si:displaced-array-p x)))) (defun logical-pathnamep (x) (when (pathnamep x) (eql (c-t-tt x) 1))) (do ((l '((null . null) (symbol . symbolp) (keyword . keywordp) (atom . atom) (cons . consp) (list . listp) (fixnum . fixnump) (integer . integerp) (rational . rationalp) (number . numberp) (character . characterp) (package . packagep) (stream . streamp) (string-input-stream . string-input-stream-p) (string-output-stream . string-output-stream-p) (file-stream . file-stream-p) (synonym-stream . synonym-stream-p) (broadcast-stream . broadcast-stream-p) (concatenated-stream . concatenated-stream-p) (two-way-stream . two-way-stream-p) (echo-stream . echo-stream-p) (pathname . pathnamep) (pathname-designator . pathname-designatorp) (logical-pathname . logical-pathnamep) (readtable . readtablep) (hash-table . hash-table-p) (random-state . random-state-p) (structure . si:structurep) (function . functionp) (vector . vectorp) (bit-vector . bit-vector-p) (array . arrayp) (string . stringp) (float . floatp) (complex . complexp) (real . realp) (simple-array . simple-array-p) (simple-vector . simple-vector-p) (simple-string . simple-string-p) (simple-bit-vector . simple-bit-vector-p) (compiled-function . compiled-function-p) (common . commonp) ) (cdr l))) ((endp l)) (si:putprop (caar l) (cdar l) 'type-predicate) (si:putprop (cdar l) (caar l) 'predicate-type)) (eval-when (compile eval) (defmacro clh nil `(progn ,@(mapcar (lambda (x &aux (f (when (equal x "FIND-CLASS") `(&optional ep))) (z (intern (string-concatenate "SI-" x)))) `(defun ,z (o ,@f &aux e (x (find-symbol ,x :user))) (cond ((and x (fboundp x) (fboundp (find-symbol "CLASSP" :user))) (prog1 (funcall x o ,@(cdr f)) (fset ',z (symbol-function x)))) ((setq e (get ',z 'early)) (values (funcall e o ,@(cdr f))))))) '("CLASSP" "CLASS-PRECEDENCE-LIST" "FIND-CLASS" "CLASS-OF" "CLASS-NAME"))))) (clh) ;; (defun class-of (object) ;; (declare (ignore object)) ;; nil) ;; (defun classp (object) ;; (declare (ignore object)) ;; nil) ;; (defun class-precedence-list (object) ;; (declare (ignore object)) ;; nil) ;; (defun find-class (object) ;; (declare (ignore object)) ;; nil) ;;; TYPEP predicate. ;;; FIXME --optimize with most likely cases first (defun typep (object type &optional env &aux tp i tem) (declare (ignore env)) (if (atom type) (setq tp type i nil) (setq tp (car type) i (cdr type))) (if (eq tp 'structure-object) (setq tp 'structure)) (case tp (member (member object i)) (not (not (typep object (car i)))) (or (do ((l i (cdr l))) ((null l) nil) (when (typep object (car l)) (return t)))) (and (do ((l i (cdr l))) ((null l) t) (unless (typep object (car l)) (return nil)))) (satisfies (funcall (car i) object)) (eql (eql (car i) object)) (member (member object i)) ((t) t) ((nil) nil) (boolean (or (eq object 't) (eq object 'nil))) (fixnum (eq (type-of object) 'fixnum)) (bignum (eq (type-of object) 'bignum)) (ratio (eq (type-of object) 'ratio)) (standard-char (and (characterp object) (standard-char-p object))) ((base-char character) (characterp object)) (integer (and (integerp object) (in-interval-p object i))) (rational (and (rationalp object) (in-interval-p object i))) (real (and (realp object) (in-interval-p object i))) (float (and (floatp object) (in-interval-p object i))) ((short-float) (and (eq (type-of object) 'short-float) (in-interval-p object i))) ((single-float double-float long-float) (and (eq (type-of object) 'long-float) (in-interval-p object i))) (complex (and (complexp object) (or (null i) (and (typep (realpart object) (car i)) ;;wfs--should only have to check one. ;;Illegal to mix real and imaginary types! (typep (imagpart object) (car i)))) )) (sequence (or (listp object) (vectorp object))) ((base-string string) ;FIXME (and (stringp object) (or (endp i) (match-dimensions (array-dimensions object) i)))) (bit-vector (and (bit-vector-p object) (or (endp i) (match-dimensions (array-dimensions object) i)))) ((simple-base-string simple-string) ;FIXME (and (simple-string-p object) (or (endp i) (match-dimensions (array-dimensions object) i)))) (simple-bit-vector (and (simple-bit-vector-p object) (or (endp i) (match-dimensions (array-dimensions object) i)))) (simple-vector (and (simple-vector-p object) (or (endp i) (and (not (stringp object)) (not (bit-vector-p object))) (equal (best-array-element-type (array-element-type object)) t)) (or (endp i) (match-dimensions (array-dimensions object) i)))) (vector (and (vectorp object) (or (endp i) (eq (car i) '*) (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) (equal (array-element-type object) (best-array-element-type (car i)))) (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) (simple-array (and (simple-array-p object) (or (endp i) (eq (car i) '*) (equal (array-element-type object) (best-array-element-type (car i)))) (or (endp (cdr i)) (eq (cadr i) '*) (if (listp (cadr i)) (match-dimensions (array-dimensions object) (cadr i)) (eql (array-rank object) (cadr i)))))) (array (and (arrayp object) (or (endp i) (eq (car i) '*) ;; Or the element type of object should be EQUAL to (car i). ;; Is this too strict? (equal (array-element-type object) (best-array-element-type (car i)))) (or (endp (cdr i)) (eq (cadr i) '*) (if (listp (cadr i)) (match-dimensions (array-dimensions object) (cadr i)) (eql (array-rank object) (cadr i)))))) (t (cond ((si-classp tp) (if (member type (si-class-precedence-list (si-class-of object))) t nil)) ((setq tem (if (structurep tp) tp (get tp 'si::s-data))) (structure-subtype-p object tem)) ((setq tem (get tp 'type-predicate)) (funcall tem object)) ((setq tem (get tp 'deftype-definition)) (typep object (apply tem i))))))) (defun minmax (i1 i2 low-p e &aux (fn (if low-p (if e '< '>) (if e '> '<)))) (cond ((eq i1 '*) (if e i1 i2)) ((eq i2 '*) (if e i2 i1)) ((funcall fn i1 i2) i1) (i2))) (defun expand-range (low high bottom top) (let ((low (minmax low bottom t t))(high (minmax high top nil t))) (when (or (eq low '*) (eq high '*) (<= low high)) (list low high)))) (defun nc (tp) (when (consp tp) (case (car tp) ;; (immfix (let ((m (cadr tp))(x (caddr tp)) ;; (list (list 'integer (if (eq m '*) most-negative-immfix m) (if (eq x '*) most-positive-immfix x))))) ;; (bfix (let* ((m (cadr tp))(x (caddr tp))(m (if (eq m '*) most-negative-fixnum m))(x (if (eq x '*) most-positive-fixnum x))) ;; (if (< (* m x) 0) ;; `((integer ,m ,(1- most-negative-immfix))(integer ,(1+ most-positive-immfix) ,x)) ;; `((integer ,m ,x))))) ;; (bignum (let* ((m (cadr tp))(x (caddr tp))(sm (or (eq m '*) (< m 0)))(sx (or (eq x '*) (>= x 0)))) ;; (if (and sm sx) ;; `((integer ,m ,(1- most-negative-fixnum))(integer ,(1+ most-positive-fixnum) ,x)) ;; `((integer ,m ,x))))) ((integer ratio short-float long-float) (list tp)) (otherwise (append (nc (car tp)) (nc (cdr tp))))))) (defun expand-ranges (type) (reduce (lambda (y x &aux (z (assoc (car x) y))) (if z (subst (cons (car z) (apply 'expand-range (cadr x) (caddr x) (cdr z))) z y) (cons x y))) (nc type) :initial-value nil)) ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. ;;; The result is always a list. (defun normalize-type (type &aux tp i ) ;; Loops until the car of type has no DEFTYPE definition. (when (and (consp type) (eq (car type) 'satisfies)) (when (setq tp (get (cadr type) 'predicate-type)) (setq type tp))) (loop (if (atom type) (setq tp type i nil) (setq tp (car type) i (cdr type))) (cond ((si-classp tp) (return-from normalize-type (list (si-class-name tp)))) ((get tp 'deftype-definition) (setq type (apply (get tp 'deftype-definition) i))) ((return-from normalize-type (if (atom type) (list type) type)))))) ;;; KNOWN-TYPE-P answers if the given type is a known base type. ;;; The type may not be normalized. ;; FIXME this needs to be more robust (defun known-type-p (type) (when (consp type) (setq type (car type))) (if (or (member type '(t nil boolean null symbol keyword atom cons list sequence signed-char unsigned-char signed-short unsigned-short number integer bignum rational ratio float method-combination short-float single-float double-float long-float complex character standard-char character real package stream pathname readtable hash-table random-state structure array simple-array function compiled-function arithmetic-error base-char base-string broadcast-stream built-in-class cell-error class concatenated-stream condition control-error division-by-zero echo-stream end-of-file error extended-char file-error file-stream floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow generic-function logical-pathname method package-error parse-error print-not-readable program-error reader-error serious-condition simple-base-string simple-condition simple-type-error simple-warning standard-class standard-generic-function standard-method standard-object storage-condition stream-error string-stream structure-class style-warning synonym-stream two-way-stream structure-object type-error unbound-slot unbound-variable undefined-function warning) :test 'eq) (get type 's-data) (equal (string type) "ERROR")) t nil)) ;;; SUBTYPEP predicate. (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) (declare (ignore env)) (let ((c1 (si-classp type1)) (c2 (si-classp type2))) (when (and c1 c2) (return-from subtypep (if (member type2 (si-class-precedence-list type1)) (values t t) (values nil t)))) (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object))) (return-from subtypep (if (member (si-find-class type2) (si-class-precedence-list type1)) (values t t) (values nil t)))) (when (or c1 c2) (return-from subtypep (values nil t)))) (setq type1 (normalize-type type1)) (setq type2 (normalize-type type2)) (when (equal type1 type2) (return-from subtypep (values t t))) (setq t1 (car type1) t2 (car type2)) (setq i1 (cdr type1) i2 (cdr type2)) (cond ((eq t1 'member) (dolist (e i1) (unless (typep e type2) (return-from subtypep (values nil t)))) (return-from subtypep (values t t))) ((eq t1 'or) (dolist (tt i1) (multiple-value-bind (tv flag) (subtypep tt type2) (unless tv (return-from subtypep (values tv flag))))) (return-from subtypep (values t t))) ((eq t1 'and) (dolist (tt i1) (let ((tv (subtypep tt type2))) (when tv (return-from subtypep (values t t))))) (return-from subtypep (values nil nil))) ((eq t1 'not) ;; (return-from subtypep (if (eq t2 'not) (subtypep (car i2) (car i1)) (subtypep t `(or ,type2 ,(car i1))))))) (cond ((eq t2 'member) (return-from subtypep (values nil nil))) ((eq t2 'or) (dolist (tt i2) (let ((tv (subtypep type1 tt))) (when tv (return-from subtypep (values t t))))) (return-from subtypep (values nil nil))) ((eq t2 'and) (dolist (tt i2) (multiple-value-bind (tv flag) (subtypep type1 tt) (unless tv (return-from subtypep (values tv flag))))) (return-from subtypep (values t t))) ((eq t2 'not) (return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil)))) (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2)) (cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t)) ((eq t2 'nil) (values nil ntp1)) ((eq t1 't) (values nil ntp2)) ((eq t1 'common) (values nil ntp2)) ((eq t2 'list) (cond ((member t1 '(null cons)) (values t t)) (t (values nil ntp1)))) ((eq t2 'sequence) (cond ((member t1 '(null cons list)) (values t t)) ((or (eq t1 'simple-array) (eq t1 'array)) (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) (values t t) (values nil t))) (t (values nil ntp1)))) ((eq t1 'list) (values nil ntp2)) ((eq t1 'sequence) (values nil ntp2)) ((eq t2 'atom) (cond ((member t1 '(cons list)) (values nil t)) (ntp1 (values t t)) (t (values nil nil)))) ((eq t1 'atom) (values nil ntp2)) ((eq t2 'symbol) (if (member t1 '(keyword boolean null)) (values t t) (values nil ntp1))) ((eq t2 'function) (if (member t1 '(compiled-function generic-function standard-generic-function)) (values t t) (values nil ntp1))) ((eq t2 'generic-function) (if (eq t1 'standard-generic-function) (values t t) (values nil ntp1))) ((eq t2 'boolean) (if (eq t1 'null) (values t t) (values nil ntp1))) ((eq t2 'standard-object) (if (member t1 '(class built-in-class structure-class standard-class method standard-method)) (values t t) (values nil ntp1))) ((eq t2 'class) (if (member t1 '(built-in-class structure-class standard-class )) (values t t) (values nil ntp1))) ((eq t2 'condition) (if (or (equal (string t1) "ERROR") (member t1 '(serious-condition error type-error simple-type-error parse-error cell-error unbound-slot warning style-warning storage-condition simple-warning unbound-variable control-error program-error undefined-function package-error arithmetic-error division-by-zero simple-condition floating-point-invalid-operation floating-point-inexact floating-point-overflow floating-point-underflow file-error stream-error end-of-file print-not-readable reader-error))) (values t t) (values nil ntp1))) ((eq t2 'serious-condition) (if (or (equal (string t1) "ERROR") (member t1 '( error type-error simple-type-error parse-error cell-error unbound-slot storage-condition unbound-variable control-error program-error undefined-function package-error arithmetic-error division-by-zero simple-type-error floating-point-invalid-operation floating-point-inexact floating-point-overflow floating-point-underflow file-error stream-error end-of-file print-not-readable reader-error))) (values t t) (values nil ntp1))) ((eq t2 'type-error) (if (eq t1 'simple-type-error) (values t t) (values nil ntp1))) ((eq t2 'parse-error) (if (eq t1 'reader-error) (values t t) (values nil ntp1))) ((eq t2 'stream-error) (if (member t1 '(reader-error end-of-file)) (values t t) (values nil ntp1))) ((or (equal (string t2) "ERROR") (eq t2 'error)) (if (member t1 '(simple-type-error type-error parse-error cell-error unbound-slot unbound-variable control-error program-error undefined-function package-error arithmetic-error division-by-zero simple-type-error floating-point-invalid-operation floating-point-inexact floating-point-overflow floating-point-underflow file-error stream-error end-of-file print-not-readable reader-error )) (values t t) (values nil ntp1))) ((eq t2 'stream) (if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream string-stream synonym-stream two-way-stream)) (values t t) (values nil ntp1))) ((eq t2 'pathname) (if (eq t1 'logical-pathname) (values t t) (values nil ntp1))) ((eq t2 'method) (if (eq t1 'standard-method) (values t t) (values nil ntp1))) ((eq t2 'simple-condition) (if (member t1 '(simple-type-error simple-warning)) (values t t) (values nil ntp1))) ((eq t2 'simple-condition) (if (member t1 '(simple-type-error simple-warning)) (values t t) (values nil ntp1))) ((eq t2 'cell-error) (if (member t1 '(unbound-slot unbound-variable undefined-function)) (values t t) (values nil ntp1))) ((eq t2 'warning) (if (member t1 '(style-warning simple-warning)) (values t t) (values nil ntp1))) ((eq t2 'arithmetic-error) (if (member t1 '(division-by-zero floating-point-invalid-operation floating-point-inexact floating-point-overflow floating-point-underflow )) (values t t) (values nil ntp1))) ((eq t2 'keyword) (if (eq t1 'keyword) (values t t) (values nil ntp1))) ((eq t2 'null) (if (eq t1 'null) (values t t) (values nil ntp1))) ((eq t2 'number) (cond ((member t1 '(bignum integer ratio rational float real short-float single-float double-float long-float complex number)) (values t t)) (t (values nil ntp1)))) ((eq t1 'number) (values nil ntp2)) ((or (eq t2 'structure) (eq t2 'structure-object)) (if (or (eq t1 'structure) (get t1 'si::s-data)) (values t t) (values nil ntp1))) ((eq t1 'structure) (values nil ntp2)) ((setq tem (get t1 'si::s-data)) (let ((tem2 (get t2 'si::s-data))) (cond (tem2 (do ((tp1 tem (s-data-includes tp1)) (tp2 tem2)) ((null tp1)(values nil t)) (when (eq tp1 tp2) (return (values t t))))) (t (values nil ntp2))))) ((eq t2 'real) (cond ((and (member t1 '(fixnum integer bignum float short-float single-float double-float long-float real ratio rational)) (sub-interval-p i1 i2)) (values t t)) (t (values nil ntp1)))) ((get t2 'si::s-data) (values nil ntp1)) (t (case t1 (bignum (case t2 (bignum (values t t)) ((integer rational) (if (sub-interval-p '(* *) i2) (values t t) (values nil t))) (t (values nil ntp2)))) (ratio (case t2 (rational (if (sub-interval-p '(* *) i2) (values t t) (values nil t))) (t (values nil ntp2)))) (standard-char (if (member t2 '(base-char character character)) (values t t) (values nil ntp2))) (base-char (if (member t2 '(character character)) (values t t) (values nil ntp2))) (extended-char (if (member t2 '(character character)) (values t t) (values nil ntp2))) (character (if (eq t2 'character) (values t t) (values nil ntp2))) (character (if (eq t2 'character) (values t t) (values nil ntp2))) (integer (if (member t2 '(integer rational)) (values (sub-interval-p i1 i2) t) (values nil ntp2))) (rational (if (eq t2 'rational) (values (sub-interval-p i1 i2) t) (values nil ntp2))) (float (if (eq t2 'float) (values (sub-interval-p i1 i2) t) (values nil ntp2))) ((short-float) (if (member t2 '(short-float float)) (values (sub-interval-p i1 i2) t) (values nil ntp2))) ((single-float double-float long-float) (if (member t2 '(single-float double-float long-float float)) (values (sub-interval-p i1 i2) t) (values nil ntp2))) (complex (if (eq t2 'complex) (subtypep (or (car i1) t) (or (car i2) t)) (values nil ntp2))) (simple-array (cond ((or (eq t2 'simple-array) (eq t2 'array)) (if (or (endp i1) (eq (car i1) '*)) (unless (or (endp i2) (eq (car i2) '*)) (return-from subtypep (values nil t))) (unless (or (endp i2) (eq (car i2) '*)) (unless (or (equal (car i1) (car i2)) ; FIXME (and (eq (car i1) 'base-char) (eq (car i2) 'character))) ;; Unless the element type matches, ;; return NIL T. ;; Is this too strict? (return-from subtypep (values nil t))))) (when (or (endp (cdr i1)) (eq (cadr i1) '*)) (if (or (endp (cdr i2)) (eq (cadr i2) '*)) (return-from subtypep (values t t)) (return-from subtypep (values nil t)))) (when (or (endp (cdr i2)) (eq (cadr i2) '*)) (return-from subtypep (values t t))) (values (match-dimensions (cadr i1) (cadr i2)) t)) (t (values nil ntp2)))) (array (cond ((eq t2 'array) (if (or (endp i1) (eq (car i1) '*)) (unless (or (endp i2) (eq (car i2) '*)) (return-from subtypep (values nil t))) (unless (or (endp i2) (eq (car i2) '*)) (unless (or (equal (car i1) (car i2)) ; FIXME (and (eq (car i1) 'base-char) (eq (car i2) 'character))) (return-from subtypep (values nil t))))) (when (or (endp (cdr i1)) (eq (cadr i1) '*)) (if (or (endp (cdr i2)) (eq (cadr i2) '*)) (return-from subtypep (values t t)) (return-from subtypep (values nil t)))) (when (or (endp (cdr i2)) (eq (cadr i2) '*)) (return-from subtypep (values t t))) (values (match-dimensions (cadr i1) (cadr i2)) t)) (t (values nil ntp2)))) (t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) (defun sub-interval-p (i1 i2) (let (low1 high1 low2 high2) (if (endp i1) (setq low1 '* high1 '*) (if (endp (cdr i1)) (setq low1 (car i1) high1 '*) (setq low1 (car i1) high1 (cadr i1)))) (if (endp i2) (setq low2 '* high2 '*) (if (endp (cdr i2)) (setq low2 (car i2) high2 '*) (setq low2 (car i2) high2 (cadr i2)))) (cond ((eq low1 '*) (unless (eq low2 '*) (return-from sub-interval-p nil))) ((eq low2 '*)) ((consp low1) (if (consp low2) (when (< (car low1) (car low2)) (return-from sub-interval-p nil)) (when (< (car low1) low2) (return-from sub-interval-p nil)))) ((if (consp low2) (when (<= low1 (car low2)) (return-from sub-interval-p nil)) (when (< low1 low2) (return-from sub-interval-p nil))))) (cond ((eq high1 '*) (unless (eq high2 '*) (return-from sub-interval-p nil))) ((eq high2 '*)) ((consp high1) (if (consp high2) (when (> (car high1) (car high2)) (return-from sub-interval-p nil)) (when (> (car high1) high2) (return-from sub-interval-p nil)))) ((if (consp high2) (when (>= high1 (car high2)) (return-from sub-interval-p nil)) (when (> high1 high2) (return-from sub-interval-p nil))))) (return-from sub-interval-p t))) (defun in-interval-p (x interval) (let (low high) (if (endp interval) (setq low '* high '*) (if (endp (cdr interval)) (setq low (car interval) high '*) (setq low (car interval) high (cadr interval)))) (cond ((eq low '*)) ((consp low) (when (<= x (car low)) (return-from in-interval-p nil))) ((when (< x low) (return-from in-interval-p nil)))) (cond ((eq high '*)) ((consp high) (when (>= x (car high)) (return-from in-interval-p nil))) ((when (> x high) (return-from in-interval-p nil)))) (return-from in-interval-p t))) (defun match-dimensions (dim pat) (if (null dim) (null pat) (and (or (eq (car pat) '*) (eql (car dim) (car pat))) (match-dimensions (cdr dim) (cdr pat))))) (defmacro check-type-eval (place type) `(values (assert (typep ,place ,type) (,place) 'type-error :datum ,place :expected-type ,type))) (deftype simple-array (&optional (et '*) (dims '*)) `(array ,et ,(if (not dims) 0 dims))) (deftype null nil `(member nil)) (deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) (deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) #.`(defun coerce (object type &aux (l (listp type))(ctp (if l (car type) type))(i (when l (cdr type)))) (when (case type ,@(mapcar (lambda (x) `(,x (,(get x 'type-predicate) object))) '(string list vector bit-vector array character float cons)) (function (unless (symbolp object) (functionp object)));FIXME (otherwise (typep object type))) (return-from coerce object)) (case ctp ((string list vector bit-vector simple-string simple-vector simple-bit-vector array cons null member) (replace (make-sequence type (length object)) object)) (function (symbol-function object)) (character (character object)) (float (float object)) ((short-float) (float object 0.0S0)) ((single-float double-float long-float) (float object 0.0L0)) (complex (let* ((re (realpart object))(im (imagpart object)) (rt (car i))(rt (unless (eq rt '*) rt)) (re (if rt (coerce re rt) re))(im (if rt (coerce im rt) im))) (complex re im))) (t (cond ((let ((nt (normalize-type type))) (unless (eq nt type) (coerce object nt)))) (t (error "Cannot coerce ~S to ~S." object type)))))) ;; set by unixport/init_kcl.lsp ;; warn if a file was comopiled in another version (defvar *gcl-extra-version* nil) (defvar *gcl-minor-version* nil) (defvar *gcl-major-version* nil) (defvar *gcl-git-tag* nil) (defvar *gcl-release-date* nil) (defun warn-version (majvers minvers extvers) (and *gcl-major-version* *gcl-minor-version* *gcl-extra-version* (or (not (eql extvers *gcl-extra-version*)) (not (eql minvers *gcl-minor-version*)) (not (eql majvers *gcl-major-version*))) *load-verbose* (format t "[compiled in GCL ~a.~a.~a] " majvers minvers extvers))) gcl-2.6.14/lsp/gcl_packages.lsp0000755000175000017500000000000114360276512014706 0ustar cammcamm gcl-2.6.14/lsp/ustreams.lisp0000755000175000017500000000427514360276512014340 0ustar cammcamm ;;; ;;; This file contains some macros for user defined streams ;;; ;;; ;;; probably need to add some fields to "define-user-stream-type" ;;; ;;; ;;; we probably need the ability for user-defined streams to declare ;;; whether they are input/output or both ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package 'lisp) (export '(make-user-stream define-user-stream-type *user-defined-stream-types*)) (defvar *user-defined-stream-types* nil) ;;; list of user defined stream types (defun make-user-stream (str-type) (let (struct) (unless (member str-type *user-defined-stream-types*) (error "Make-user-stream: ~a undefined stream type" str-type)) (setq struct (funcall (get str-type 'lisp::str-conc-name))) (allocate-stream-object str-type struct))) (defmacro define-user-stream-type (str-name str-data str-read-char str-write-char str-peek-char str-force-output str-close str-type &optional str-unread-char) (let ((conc-name (intern (concatenate 'string "KCL-" (symbol-name str-name))))) nil `(progn (setf (get ',str-name 'str-conc-name) ',conc-name) (setf (get ',str-name 'stream) t) (format t "Constructor ") (setq lisp::*user-defined-stream-types* (cons ',str-name lisp::*user-defined-stream-types*)) (defstruct (,str-name (:constructor ,conc-name)) (str-data ,str-data) ;0 (str-read-char ,str-read-char) ;1 (str-write-char ,str-write-char) ;2 (str-peek-char ,str-peek-char) ;3 (str-force-output ,str-force-output) ;4 (str-close ,str-close) ;5 (str-type ,str-type) ;6 (str-unread-char ,str-unread-char) ;7 (str-name ',str-name))))) ;8 ;;; ;;; allocate a stream-object and patch in the struct which holds ;;; the goodies ;;; (Clines " object allocate_stream_object (stream_type, new_struct) object stream_type; object new_struct; { object x; x = alloc_object(t_stream); x->sm.sm_mode = smm_user_defined; x->sm.sm_object1 = new_struct; x->sm.sm_object0 = stream_type; x->sm.sm_int0 = 0; x->sm.sm_fp = 0; x->sm.sm_int1 = 0; return x; }" ) (defentry allocate-stream-object (object object) (object allocate_stream_object)) gcl-2.6.14/lsp/gcl_sloop.lsp0000755000175000017500000012113014360276512014273 0ustar cammcamm;;; -*- Mode:LISP; Package:(SLOOP LISP);Syntax:COMMON-LISP;Base:10 -*- ;;;;; ;;; ;;;;; ;;; Copyright (c) 1985,86 by William Schelter, ;;;;; ;;; All rights reserved ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Report bugs to wfs@carl.ma.utexas.edu ;;; It comes with ABSOLUTELY NO WARRANTY but we hope it is useful. ;;; The following code is meant to run in COMMON LISP and to provide ;;; extensive iteration facilities, with very high backwards compatibility ;;; with the traditional loop macro. It is meant to be publicly available! ;;; Anyone is hereby given permission to copy it provided he does not make ;;; ANY changes to the file unless he is William Schelter. He may change ;;; the behavior after loading it by resetting the global variables such ;;; as like *Use-locatives*, *automatic-declarations*,.. listed at the ;;; beginning of this file. ;;; The original of this file is on ;;; rascal.ics.utexas.edu:/usr2/ftp/pub/sloop.lisp. I am happy to accept ;;; suggestions for different defaults for various implementations, or for ;;; improvements. ;;If you want to redefine the common lisp loop you may include in your code: ;;; (defmacro loop (&body body) (parse-loop body)) ;; Principal New Features ;;; Sloop is extremely user extensible so that you may easily redefine ;;; most behavior, or add additional collections, and paths. There are a ;;; number of such examples defined in this file, including such ;;; constructs as ;;; .. FOR v IN-FRINGE x .. (iterate through the fringe of a tree x) ;;; .. SUM v .. (add the v) ;;; .. AVERAGING v .. ;;; .. FOR sym IN-PACKAGE y (iterate through symbols in a package y) ;;; .. COLLATE v .. (for collecting X into an ordered list), ;;; .. FOR (elt i) IN-ARRAY ar (iterate through array ar, with index i) ;;; .. FOR (key elt) IN-TABLE foo.. (if foo is a hash table) ;;; you can combine any collection method with any path. ;;; Also there is iteration over products so that you may write ;;; (SLOOP FOR i BELOW k ;;; SLOOP (FOR j BELOW i ;;; COLLECTING (foo i j))) ;;; Declare is fully supported. The syntax would be ;;; (sloop for u in l with v = 0 ;;; declare (fixnum u v) ;;; do .... ;;; This extensibility is gained by the ability to define a "loop-macro", ;;; which plays a role analagous to an ordiary lisp macro. See eg. ;;; definitions near that of "averaging". Essentially a "loop-macro" ;;; takes some arguments (supplied from the body of the loop following its ;;; occurrence, and returns a new form to be stuffed onto the front of the ;;; loop form, in place of it and its arguments). ;;; Compile notes: For dec-20 clisp load the lisp file before compiling. ;;; there seems to be no unanimity about what in-package etc. does on ;;; loading and compiling a file. The following is as close to the ;;; examples in the Common Lisp manual, as we could make it. The user ;;; should put (require "SLOOP") and then (use-package "SLOOP") early in ;;; his init file. Note use of the string to avoid interning 'sloop in ;;; some other package. (in-package "SLOOP" :use '(:LISP)) (eval-when (compile eval load) (export '(loop-return sloop def-loop-collect def-loop-map def-loop-for def-loop-macro local-finish sloop-finish) (find-package "SLOOP")) ) ;;; some variables that may be changed to suit different implementations: (eval-when (compile load eval) (defvar *use-locatives* nil "See sloop.lisp") ;#+lispm t #-lispm nil ;;; If t should have locf, such that if we do ;;; (setf b nil) (setq a (locf b)) ;;; then the command ;;; (setf (cdr a) (cons 3 nil)) means that b==>(3). ;;; This is useful for building lists starting with a variable pointing to ;;; nil, since otherwise we must check each time if the list has really ;;; been started, before we do a (setf (cdr b) ..) (defvar *Automatic-declarations* #+lispm nil #-lispm '(:from fixnum) "See sloop.lisp") ;;; some other reasonable ones would be :count fixnum :max fixnum ;;; Automatic declarations for variables in the stepping and collecting, ;;; so for i below n, gives i and n a :from declaration (here fixnum) ;;valid keys in *automatic-declarations* (defvar *auto-type* '(:from :in :collect)) ;;give automatic register declaration to these variables (defvar *auto-register* '(:from :in :collect)) (eval-when (compile eval load) (proclaim '(declaration :register)) ) (defvar *type-check* t "If t adds a type check on bounds of from loop if there is and automatic declare") (defvar *macroexpand-hook-for-no-copy* #-(or lmi ti) 'funcall #+(or lmi ti) t) ;;; some lisps remember a macro so that (loop-return) will expand eq forms ;;; always in the same manner, even if the form is in a macrolet! To ;;; defeat this feature we copy all macro expansions unless ;;; *macro-expand-hook* = *macroexpand-hook-for-no-copy* ) ;;; *****ONLY CONDITIONALIZATIONS BELOW HERE SHOULD BE FOR BUG FIXES****** ;;; eg. some kcls don't return nil from a prog by default! ;;; all macros here in here. (eval-when (compile eval load) (defparameter *sloop-translations* '((appending . append) ((collecting collect) . collect) ((maximizing maximize) . maximize) ((minimizing minimize) . minimize) (nconcing . nconc) ((count counting) . count) (summing . sum) (if . when) (as . for) (in-fringe . in-fringe) (collate . collate) (in-table . in-table) (in-carefully . in-carefully) (averaging . averaging) (repeat . repeat) (first-use . first-use) (in-array . in-array)) "A list of cons's where the translation is the cdr, and the car is a list of names or name to be translated. Essentially allows 'globalizing' a symbol for the purposes of being a keyword in a sloop") (defparameter *additional-collections* nil) (defmacro lcase (item &body body) (let (bod last-case tem) (do ((rest body (cdr rest)) (v)) ((or last-case (null rest))) (setq v (car rest)) (push (cond ((eql (car v) t) (setq last-case t) v) ((eql (car v) :collect) `((loop-collect-keyword-p .item.) ,@ (cdr v))) ((eql (car v) :no-body) `((parse-no-body .item.) ,@ (cdr v))) ((setq tem (member (car v) '(sloop-macro sloop-for sloop-map))) `((and (symbolp .item.)(get .item. ',(car tem))) ,@ (cdr v))) (t `((l-equal .item. ',(car v)) ,@ (cdr v)))) bod)) (or last-case (push `(t (error "lcase fell off end ~a " .item.)) bod)) `(let ((.item. (translate-name ,item))) (cond ,@ (nreverse bod))))) (defun desetq1 (form val) (cond ((symbolp form) (and form `(setf ,form ,val))) ((consp form) `(progn ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) (defmacro loop-return (&rest vals) (cond ((<= (length vals) 1) `(return ,@ vals)) (t`(return (values ,@ vals))))) (defmacro sloop-finish () `(go finish-loop)) (defmacro local-finish () `(go finish-loop)) (defmacro sloop (&body body) (parse-loop body)) (defmacro def-loop-map (name args &body body) (def-loop-internal name args body 'map)) (defmacro def-loop-for (name args &body body ) (def-loop-internal name args body 'for nil 1)) (defmacro def-loop-macro (name args &body body) (def-loop-internal name args body 'macro)) (defmacro def-loop-collect (name arglist &body body ) "Define function of 2 args arglist= (collect-var value-to-collect)" (def-loop-internal name arglist body 'collect '*additional-collections* 2 2)) (defmacro sloop-swap () `(progn (rotatef a *loop-bindings*) (rotatef b *loop-prologue*) (rotatef c *loop-epilogue*) (rotatef e *loop-end-test*) (rotatef f *loop-increment*) (setf *inner-sloop* (not *inner-sloop*)) )) ) ;;end of macros (defun l-equal (a b) (and (symbolp a) (cond ((symbolp b) (equal (symbol-name a) (symbol-name b))) ((listp b) (member a b :test 'l-equal))))) (defun loop-collect-keyword-p (command) (or (member command '(collect append nconc sum count) :test 'l-equal) (find command *additional-collections* :test 'l-equal))) (defun translate-name (name) (cond ((and (symbolp name) (cdar (member name *sloop-translations* :test 'l-equal :key 'car)))) (t name))) (defun loop-pop () (declare (special *last-val* *loop-form*)) (cond (*loop-form* (setq *last-val* (pop *loop-form*))) (t (setq *last-val* 'empty-form) nil))) (defun loop-un-pop () (declare (special *last-val* *loop-form*)) (case *last-val* (empty-form nil) (already-un-popped (error "you are un-popping without popping")) (t (push *last-val* *loop-form*) (setf *last-val* 'alread-un-popped)))) (defun loop-peek () (declare (special *last-val* *loop-form*)) (car *loop-form*)) (defun loop-let-bindings(binds) (do ((v (car binds) (cdr v))) ((null v) (nreverse (car binds))) (or (cdar v) (setf (car v) (caar v))))) (defun parse-loop (form &aux inner-body) (let ((*loop-form* form) (*Automatic-declarations* *Automatic-declarations*) *last-val* *loop-map* *loop-body* *loop-name* *loop-prologue* *inner-sloop* *loop-epilogue* *loop-increment* *loop-collect-pointers* *loop-map-declares* *loop-collect-var* *no-declare* *loop-end-test* *loop-bindings* *product-for* *type-test-limit* local-macros (finish-loop 'finish-loop) ) (declare (special *loop-form* *last-val* *loop-map* *loop-collect-pointers* *loop-name* *inner-sloop* *loop-body* *loop-prologue* *no-declare* *loop-bindings* *loop-collect-var* *loop-map-declares* *loop-epilogue* *loop-increment* *loop-end-test* *product-for* *type-test-limit* )) (unless (and (symbolp (car *loop-form*)) (car *loop-form*)) (push 'do *loop-form*)) ;compatible with common lisp loop.. (parse-loop1) (when (or *loop-map* *product-for*) (or *loop-name* (setf *loop-name* (gensym "SLOOP"))) (and (eql 'finish-loop finish-loop) (setf finish-loop (gensym "FINISH")))) ;;; some one might use local-finish,local-return or sloop-finish, so they might ;;; be bound at an outer level. WE have to always include this since ;;; loop-return may be being bound outside. (and ; *loop-name* (push `(loop-return (&rest vals) `(return-from ,',*loop-name* (values ,@ vals))) local-macros)) (when t;; (or (> *loop-level* 1) (not (eql finish-loop 'finish-loop))) (push `(sloop-finish () `(go ,',finish-loop)) local-macros) (push `(local-finish () `(go ,',finish-loop)) local-macros)) (and *loop-collect-var* (push `(return-from ,*loop-name* , *loop-collect-var*) *loop-epilogue*)) (setq inner-body (append *loop-end-test* (nreverse *loop-body*) (nreverse *loop-increment*))) (cond (*loop-map* (setq inner-body (substitute-sloop-body inner-body))) (t (setf inner-body (cons 'next-loop (append inner-body '((go next-loop))))))) (let ((bod `(macrolet ,local-macros (block ,*loop-name* (tagbody ,@ (append (nreverse *loop-prologue*) inner-body `(,finish-loop) (nreverse *loop-epilogue*) #+kcl '((loop-return nil)))))) )) ;;; temp-fix..should not be necessary but some lisps cache macro ;;; expansions. and ignore the macrolet!! (unless (eql *macroexpand-hook* *macroexpand-hook-for-no-copy*) (setf bod (copy-tree bod))) (dolist (v *loop-bindings*) (setf bod `(let ,(loop-let-bindings v) ,@(and (cdr v) `(,(cons 'declare (cdr v)))) ,bod))) bod ))) (defun parse-loop1 () (declare (special *loop-form* *loop-body* *loop-increment* *no-declare* *loop-end-test* *loop-name* )) (lcase (loop-peek) (named (loop-pop) (setq *loop-name* (loop-pop))) (t nil)) (do ((v (loop-pop) (loop-pop))) ((and (null v) (null *loop-form*))) (lcase v (:no-body) (for (parse-loop-for)) (while (push `(or ,(loop-pop) (local-finish)) *loop-body*)) (until (push `(and ,(loop-pop) (local-finish)) *loop-body*)) (do (setq *loop-body* (append (parse-loop-do) *loop-body*))) ((when unless) (setq *loop-body* (append (parse-loop-when) *loop-body*))) (:collect (setq *loop-body* (append (parse-loop-collect) *loop-body*))) ))) (defun parse-no-body (com &aux (found t) (first t)) "Reads successive no-body-contribution type forms, like declare, initially, etc. which can occur anywhere. Returns t if it finds some otherwise nil" (declare (special *loop-form* *loop-body* *loop-increment* *no-declare* *loop-end-test* *loop-name* )) (do ((v com (loop-pop))) ((null (or first *loop-form*))) (lcase v ((initially finally)(parse-loop-initially v)) (nil nil) (with (parse-loop-with)) (declare (parse-loop-declare (loop-pop) t)) (nodeclare (setq *no-declare* (loop-pop))) ;take argument to be consistent. (increment (setq *loop-increment* (append (parse-loop-do) *loop-increment*))) (end-test (setq *loop-end-test* (append (parse-loop-do) *loop-end-test*))) (with-unique (parse-loop-with nil t)) (sloop-macro (parse-loop-macro v 'sloop-macro)) (t (cond (first (setf found nil)) (t (loop-un-pop))) (return 'done))) (setf first nil)) found) (defun parse-loop-with (&optional and-with only-if-not-there) (let ((var (loop-pop))) (lcase (loop-peek) (= (loop-pop) (or (symbolp var) (error "Not a variable ~a" var)) (loop-add-binding var (loop-pop) (not and-with) nil nil t only-if-not-there)) (t (loop-add-temps var nil nil (not and-with) only-if-not-there))) (lcase (loop-peek) (and (loop-pop) (lcase (loop-pop) (with (parse-loop-with t )) (with-unique (parse-loop-with t t)) (t (loop-un-pop) (parse-loop-with t)) )) (t nil)))) (defun parse-loop-do (&aux result) (declare (special *loop-form*)) (do ((v (loop-pop) (loop-pop)) ) (()) (cond ((listp v) (push v result) (or *loop-form* (return 'done))) (t (loop-un-pop) (return 'done)))) (or result (error "empty clause")) result) (defun parse-loop-initially (command ) (declare (special *loop-prologue* *loop-epilogue* *loop-bindings*)) (lcase command (initially (let ((form (parse-loop-do))) (dolist (v (nreverse form)) (cond ((and (listp v) (member (car v) '(setf setq)) (eql (length v) 3) (symbolp (second v)) (constantp (third v)) (assoc (second v) (caar *loop-bindings*)) (loop-add-binding (second v) (third v) nil nil nil t t) )) (t (setf *loop-prologue* (cons v *loop-prologue*))))))) (finally (setf *loop-epilogue* (append (parse-loop-do) *loop-epilogue*))))) (defun parse-one-when-clause ( &aux this-case (want 'body) v) (declare (special *loop-form*)) (prog nil next-loop (and (null *loop-form*) (return 'done)) (setq v (loop-pop)) (lcase v (:no-body) (:collect (or (eql 'body want) (go finish)) (setq this-case (append (parse-loop-collect) this-case)) (setq want 'and)) (when (or (eql 'body want) (go finish)) (setq this-case (append (parse-loop-when) this-case)) (setq want 'and)) (do (or (eql 'body want) (go finish)) (setq this-case (append (parse-loop-do) this-case)) (setq want 'and)) (and (or (eql 'and want) (error "Premature AND")) (setq want 'body)) (t (loop-un-pop)(return 'done))) (go next-loop) finish (loop-un-pop)) (or this-case (error "Hanging conditional")) this-case) (defun parse-loop-when (&aux initial else else-clause) (declare (special *last-val* )) (let ((test (cond ((l-equal *last-val* 'unless) `(not , (loop-pop))) (t (loop-pop))))) (setq initial (parse-one-when-clause)) (lcase (loop-peek) (else (loop-pop) (setq else t) (setq else-clause (parse-one-when-clause))) (t nil)) `((cond (,test ,@ (nreverse initial)) ,@ (and else `((t ,@ (nreverse else-clause)))))))) (defun pointer-for-collect (collect-var) (declare (special *loop-collect-pointers*)) (or (cdr (assoc collect-var *loop-collect-pointers*)) (let ((sym(loop-add-binding (gensym "POIN") nil nil :collect ))) (push (cons collect-var sym) *loop-collect-pointers*) sym))) (defun parse-loop-collect ( &aux collect-var pointer name-val) (declare (special *last-val* *loop-body* *loop-collect-var* *loop-collect-pointers* *inner-sloop* *loop-prologue* )) (and *inner-sloop* (throw 'collect nil)) (let ((command *last-val*) (val (loop-pop))) (lcase (loop-pop) (into (loop-add-binding (setq collect-var (loop-pop)) nil nil t nil t )) (t (loop-un-pop) (cond (*loop-collect-var* (setf collect-var *loop-collect-var*)) (t (setf collect-var (setf *loop-collect-var* (loop-add-binding (gensym "COLL") nil ))))))) (lcase command ((append nconc collect) (setf pointer (pointer-for-collect collect-var)) (cond (*use-locatives* (pushnew `(setf ,pointer (locf ,collect-var)) *loop-prologue* :test 'equal))) (lcase command ( append (unless (and (listp val) (eql (car val) 'list)) (setf val `(copy-list ,val)))) (t nil))) (t nil)) (cond ((and (listp val) (not *use-locatives*)) (setq name-val (loop-add-binding (gensym "VAL") nil nil))) (t (setf name-val val))) (let ((result (lcase command ((nconc append) (let ((set-pointer `(and (setf (cdr ,pointer) ,name-val) (setf ,pointer (last (cdr ,pointer)))))) (cond (*use-locatives* (list set-pointer)) (t `((cond (,pointer ,set-pointer) (t (setf ,pointer (last (setf ,collect-var ,name-val)))))))))) (collect (cond (*use-locatives* `((setf (cdr ,pointer) (setf ,pointer (cons ,name-val nil))))) (t `((cond (,pointer (setf (cdr ,pointer) (setf ,pointer (cons ,name-val nil)))) (t (setf ,collect-var (setf ,pointer (cons ,name-val nil))))))))) (t (setq command (translate-name command)) (cond ((find command *additional-collections* :test 'l-equal) (loop-parse-additional-collections command collect-var name-val)) (t (error "loop fell off end ~a" command))))))) (cond ((eql name-val val) result) (t (nconc result `((setf ,name-val ,val) ))))))) (defun loop-parse-additional-collections (command collect-var name-val &aux eachtime) (declare (special *loop-prologue* *last-val* *loop-collect-var* *loop-epilogue* )) (let* ((com (find command *additional-collections* :test 'l-equal)) (helper (get com 'sloop-collect))) (let ((form (funcall helper collect-var name-val))) (let ((*loop-form* form) *last-val*) (declare (special *loop-form* *last-val*)) (do ((v (loop-pop) (loop-pop))) ((null *loop-form*)) (lcase v (:no-body) (do (setq eachtime (parse-loop-do))))) eachtime)))) (defun the-type (symbol type) (declare (special *no-declare*)) (and *no-declare* (setf type nil)) (and type (setf type (or (getf *Automatic-declarations* type) (and (not (keywordp type)) type)))) (and (consp type) (eq (car type) 'type) (setf type (second type))) (cond (type (list 'the type symbol )) (t symbol))) (defun type-error () (error "While checking a bound of a sloop, I found the wrong type for something in sloop::*automatic-declarations*. Perhaps your limit is wrong? If not either use nodeclare t or set sloop::*automatic-declarations* to nil. recompile.")) ;;; this puts down code to check that automatic declarations induced by ;;; :from are indeed valid! It checks both ends of the interval, and so ;;; need not check the numbers in between. (defun make-value (value type-key &aux type ) (declare (special *no-declare* *type-test-limit*)) (cond ((and (not *no-declare*) *type-check* (eq type-key :from) (setq type (getf *Automatic-declarations* type-key))) (setq type (cond ((and (consp type) (eq (car type) 'type)) (second type)) (t type))) (cond ((constantp value) (let ((test-value (cond (*type-test-limit* (eval (subst value 'the-value *type-test-limit*))) (t (eval value))))) (or (typep test-value type) (error "~&Sloop found the type of ~a was not type ~a,~%~ Maybe you want to insert SLOOP NODECLARE T ..." value type)) (list value))) (t (let (chk) `((let ,(cond ((atom value) nil) (t `((,(setq chk(gensym)) ,value)))) (or (typep ,(if *type-test-limit* (subst (or chk value) 'the-value *type-test-limit*) (or chk value)) ',type) (type-error)) ,(or chk value))))))) (t (list value)))) ;;; keep track of the bindings in a list *loop-bindings* each element of ;;; the list will give rise to a different let. the car will be the ;;; variable bindings, the cdr the declarations. (defun loop-add-binding (variable value &optional (new-level t) type force-type (force-new-value t) only-if-not-there &aux tem) ;;; Add a variable binding to the current or new level. If FORCE-TYPE, ;;; ignore a *no-declare*. If ONLY-IF-NOT-THERE, check all levels. (declare (special *loop-bindings*)) (when (or new-level (null *loop-bindings*)) (push (cons nil nil) *loop-bindings*)) (cond ((setq tem (assoc variable (caar *loop-bindings*) )) (and force-new-value (setf (cdr tem) (and value (make-value value type))))) ((and (or only-if-not-there (and (null (symbol-package variable)) (constantp value))) (dolist (v (cdr *loop-bindings*)) (cond ((setq tem (assoc variable (car v))) (and force-new-value (setf (cdr tem) (and value (make-value value type)))) (return t)))))) (t (push (cons variable (and value (make-value value type))) (caar *loop-bindings*)))) (and type (loop-declare-binding variable type force-type)) variable) ;(defmacro nth-level (n) `(nth ,n *loop-bindings*)) ;if x = (nth i *loop-bindings*) ;(defmacro binding-declares (x) `(cdr ,x)) ;(cons 'declare (binding-declares x)) to get honest declare statement ;(defmacro binding-values (x) `(car ,x)) ;(let (binding-values x) ) to get let. (defun loop-declare-binding (var type force-type &optional odd-type &aux found ) (declare (special *loop-bindings* *automatic-declarations* *no-declare* *loop-map*)) odd-type ;;ignored (and type (member type *auto-type*) (setf type (getf *automatic-declarations* type)) *auto-register* (loop-declare-binding var :register force-type)) (when (and type(or force-type (null *no-declare*))) (dolist (v *loop-bindings*) (cond ((assoc var (car v)) (setf found t) (pushnew (if (and (consp type) (eq (car type) 'type)) (list 'type (second type) var) (if odd-type (list 'type type var) (list type var))) (cdr v) :test 'equal) (return 'done) ))) (or found *loop-map* (error "Could not find variable ~a in bindings" var))) var) (defun parse-loop-declare (&optional (decl-list (loop-pop)) (force t)) (let ((type (car decl-list)) odd-type) (cond ((eq type 'type) (setf decl-list (cdr decl-list) type (car decl-list) odd-type t))) (dolist (v (cdr decl-list)) (loop-declare-binding v (car decl-list) force odd-type)))) (defun loop-add-temps (form &optional val type new-level only-if-not-there) (cond ((null form)) ((symbolp form) (loop-add-binding form val new-level type nil t only-if-not-there)) ((listp form) (loop-add-temps (car form)) (loop-add-temps (cdr form))))) (defun add-from-data (data &rest args) "rest = var begin end incr direction or-eql" (or data (setq data (copy-list '(nil 0 nil 1 + nil)))) (do ((l data (cdr l)) (v args (cdr v))) ((null v) l) (and (car v) (setf (car l) (car v)))) data) (defun parse-loop-for ( &aux inc from-data) (declare (special *loop-form* *loop-map-declares* *loop-map* *loop-body* *loop-increment* *no-declare* *loop-prologue* *loop-epilogue* *loop-end-test* *loop-bindings* )) (let* ((var (loop-pop)) test incr) (do ((v (loop-pop) (loop-pop))) (()) (lcase v (in (let ((lis (gensym "LIS"))) (loop-add-temps var nil :in t) (loop-add-binding lis (loop-pop) nil) (push `(desetq ,var (car ,lis)) *loop-body*) (setf incr `(setf ,lis (cdr ,lis))) (setq test `(null ,lis) ) )) (on (let ((lis (cond ((symbolp var) var) (t (gensym "LIS"))))) (loop-add-temps var nil :in t) (loop-add-binding lis (loop-pop) nil) (setf incr `(setf ,lis (cdr ,lis))) (unless (eql lis var) (push `(desetq ,var ,lis) *loop-body*)) (setf test `(null ,lis)))) ((upfrom from) (setq from-data (add-from-data from-data var (loop-pop) nil nil '+))) (downfrom (setq from-data (add-from-data from-data var (loop-pop) nil nil '-))) (by (setq inc (loop-pop)) (cond (from-data (setq from-data (add-from-data from-data nil nil nil inc))) (t (assert (eq (car (third incr)) 'cdr)) (setq incr `(setf ,(second incr) ,(if (and (consp inc) (member (car inc) '(quote function))) `(,(second inc) ,(second incr)) `(funcall ,inc ,(second incr)))))))) (below (setq from-data (add-from-data from-data var nil (loop-pop) nil '+))) (above (setq from-data (add-from-data from-data var nil (loop-pop) nil '-))) (to (setq from-data (add-from-data from-data var nil (loop-pop) nil nil t))) (sloop-for (parse-loop-macro (translate-name v) 'sloop-for var ) (return 'done)) (sloop-map (parse-loop-map (translate-name v) var ) (return nil)) (t(or (loop-un-pop)) (return 'done)))) ;;whew finished parsing a for clause.. (cond (from-data (let ((op (nth 4 from-data)) (or-eql (nth 5 from-data)) (var (car from-data)) (end (third from-data)) (inc (fourth from-data)) type) (loop-add-binding var (second from-data) t :from) (or (constantp inc) (setq *no-declare* t)) (setf incr `(setf ,var ,(the-type `(,op ,var ,inc) :from))) (cond (end (let ((lim (gensym "LIM")) (*type-test-limit* (cond ((and (eql inc 1) (null (nth 5 from-data))) nil) (t `(,op the-value , inc))))) (declare (special *type-test-limit*)) (loop-add-binding lim end nil :from nil nil) (setq test `(,(cond (or-eql (if (eq op '+) '> '<)) (t (if (eq op '+) '>= '<=))) ,var ,lim)))) ((and (not *no-declare*) *type-check* (setq type (getf *automatic-declarations* :from)) (progn (if (and (consp type)(eq (car type) 'type)) (setf type (second type))) (subtypep type 'fixnum))) (or (constantp inc) (error "increment must be constant.")) (push `(or ,(cond ((eq op '+) `(< ,var ,(- most-positive-fixnum (or inc 1)))) (t `(> ,var ,(+ most-negative-fixnum (or inc 1))))) (type-error)) *loop-increment*) ))))) (and test (push (copy-tree `(and ,test (local-finish))) *loop-end-test*)) (and incr (push incr *loop-increment*)) )) (defun parse-loop-macro (v type &optional initial &aux result) (declare (special *loop-form*)) (let ((helper (get v type)) args) (setq args (ecase type (sloop-for (let ((tem (get v 'sloop-for-args))) (or (cdr tem) (error "sloop-for macro needs at least one arg")) (cdr tem))) (sloop-macro(get v 'sloop-macro-args)))) (let ((last-helper-apply-arg (cond ((member '&rest args) (prog1 *loop-form* (setf *loop-form* nil))) (t (dotimes (i (length args) (nreverse result)) (push (car *loop-form*) result) (setf *loop-form* (cdr *loop-form*))))))) (setq *loop-form* (append (case type (sloop-for (apply helper initial last-helper-apply-arg)) (sloop-macro(apply helper last-helper-apply-arg))) *loop-form*))))) (defun parse-loop-map (v var) (declare (special *loop-map* *loop-map-declares* *loop-form*)) (and *loop-map* (error "Sorry only one allowed loop-map per sloop")) (let ((helper (get v 'sloop-map)) (args (get v 'sloop-map-args))) (or args (error "map needs one arg before the key word")) (cond ((member '&rest args) (error "Build this in two steps if you want &rest"))) (let* (result (last-helper-apply-arg (dotimes (i (1- (length args)) (nreverse result)) (push (car *loop-form*) result) (setf *loop-form* (cdr *loop-form*))))) (setq *loop-map-declares* (do ((v (loop-pop)(loop-pop)) (result)) ((null (l-equal v 'declare)) (loop-un-pop) (and result (cons 'declare result))) (push (loop-pop) result))) (setq *loop-map* (apply helper var last-helper-apply-arg)) nil))) (defun substitute-sloop-body (inner-body) (declare (special *loop-map* *loop-map-declares*)) (cond (*loop-map* (setf inner-body (list (subst (cons 'progn inner-body) :sloop-body *loop-map*))) (and *loop-map-declares* (setf inner-body(subst *loop-map-declares* :sloop-map-declares inner-body))))) inner-body) ;;; **User Extensible Iteration Facility** (eval-when (compile eval load) (defun def-loop-internal (name args body type &optional list min-args max-args &aux (*print-case* :upcase) (helper (intern (format nil "~a-SLOOP-~a" name type)))) (and min-args (or (>= (length args) min-args)(error "need more args"))) (and max-args (or (<= (length args) max-args)(error "need less args"))) `(eval-when (load compile eval) (defun ,helper ,args ,@ body) ,@ (and list `((pushnew ',name ,list))) (setf (get ',name ',(intern (format nil "SLOOP-~a" type) (find-package 'sloop))) ',helper) (setf (get ',name ',(intern (format nil "SLOOP-~a-ARGS" type) (find-package 'sloop))) ',args))) ) ;;; DEF-LOOP-COLLECT lets you get a handle on the collection var. exactly ;;; two args. First arg=collection-variable. Second arg=value this time ;;; thru the loop. (def-loop-collect sum (ans val) `(initially (setq ,ans 0) do (setq ,ans (+ ,ans ,val)))) (def-loop-collect logxor (ans val) `(initially (setf ,ans 0) do (setf ,ans (logxor ,ans ,val)) declare (fixnum ,ans ,val))) (def-loop-collect maximize (ans val) `(initially (setq ,ans nil) do (if ,ans (setf ,ans (max ,ans ,val)) (setf ,ans ,val)))) (def-loop-collect minimize (ans val) `(initially (setq ,ans nil) do (if ,ans (setf ,ans (min ,ans ,val)) (setf ,ans ,val)))) (def-loop-collect count (ans val) `(initially (setq ,ans 0) do (and ,val (setf ,ans (1+ ,ans))))) (def-loop-collect thereis (ans val)(declare(ignore ans)) `(do (if ,val (loop-return ,val)))) (def-loop-collect always (ans val) `(initially (setq ,ans t) do (and (null ,val)(loop-return nil)))) (def-loop-collect never (ans val) `(initially (setq ,ans t) do (and ,val (loop-return nil)))) ;;; DEF-LOOP-MACRO ;;; If we have done ;;; (def-loop-macro averaging (x) ;;; `(sum ,x into .tot. and count t into .how-many. ;;; finally (loop-return (/ .tot. (float .how-many.))))) ;;; (def-loop-collect average (ans val) ;;; `(initially (setf ,ans 0.0) ;;; with-unique .how-many. = 0 ;;; do (setf ,ans (/ (+ (* .how-many. ,ans) ,val) (incf .how-many.))) ;;; )) ;;; Finally we show how to provide averaging with ;;; current value the acutal average. (def-loop-macro averaging (x) `(with-unique .average. = 0.0 and with-unique .n-to-average. = 0 declare (float .average. ) declare (fixnum .n-to-average.) do (setf .average. (/ (+ (* .n-to-average. .average.) ,x) (incf .n-to-average.))) finally (loop-return .average.))) (def-loop-macro repeat (x) (let ((ind (gensym))) `(for ,ind below ,x))) (def-loop-macro return (x) `(do (loop-return ,@ (if (and (consp x) (eq (car x) 'values)) (cdr x) (list x))))) ;;; then we can write: ;;; (sloop for x in l when (oddp x) averaging x) ;;; DEF-LOOP-FOR def-loop-for and def-loop-macro are almost identical ;;; except that the def-loop-for construct can only occur after a for: ;;; (def-loop-for in-array (vars array) ;;; (let ((elt (car vars)) ;;; (ind (second vars))) ;;; `(for ,ind below (length ,array) do (setf ,elt (aref ,array ,ind))))) ;;; (sloop for (elt ind) in-array ar when (oddp elt) collecting ind) ;;; You are just building something understandable by loop but minus the ;;; for. Since this is almost like a "macro", and users may want to ;;; customize their own, the comparsion of tokens uses eq, ie. you must ;;; import IN-ARRAY to your package if you define it in another one. ;;; Actually we make a fancier in-array below which understands from, to, ;;; below, downfrom,.. and can have either (elt ind) or elt as the ;;; argument vars. ;;; DEF-LOOP-MAP A rather general iteration construct which allows you to ;;; map over things It can only occur after FOR. There can only be one ;;; loop-map for a given loop, so you want to only use them for ;;; complicated iterations. (def-loop-map in-table (var table) `(maphash #'(lambda ,var :sloop-map-declares :sloop-body) ,table)) ;;; Usage (sloop for (key elt) in-table table ;;; declare (fixnum elt) ;;; when (oddp elt) collecting (cons key elt)) (def-loop-map in-package (var pkg) `(do-symbols (,var (find-package ,pkg)) :sloop-body)) ;;; Usage: ;;; (defun te() ;;; (sloop for sym in-package 'sloop when (fboundp sym) count t)) ;;; IN-ARRAY that understands from,downfrowm,to, below, above,etc. I used ;;; a do for the macro iteration to be able include it here. (def-loop-for in-array (vars array &rest args) (let (elt ind to) (cond ((listp vars) (setf elt (car vars) ind (second vars))) (t (setf elt vars ind (gensym "INDEX" )))) (let ((skip (do ((v args (cddr v)) (result)) (()) (lcase (car v) ((from downfrom) ) ((to below above) (setf to t)) (by) (t (setq args (copy-list v)) (return (nreverse result)))) (push (car v) result) (push (second v) result)))) (or to (setf skip (nconc `(below (length ,array)) skip))) `(for ,ind ,@ skip with ,elt do (setf ,elt (aref ,array ,ind)) ,@ args)))) ;;; usage: IN-ARRAY ;;; (sloop for (elt i) in-array ar from 4 ;;; when (oddp i) ;;; collecting elt) ;;; (sloop for elt in-array ar below 10 by 2 ;;; do (print elt)) (def-loop-for = (var val) (lcase (loop-peek) (then (loop-pop) `(with ,var initially (desetq ,var ,val) increment (desetq ,var ,(loop-pop)))) (t `(with ,var do (desetq ,var ,val))))) (def-loop-macro sloop (for-loop) (lcase (car for-loop) (for)) (let (*inner-sloop* *loop-body* *loop-map* inner-body (finish-loop (gensym "FINISH")) a b c e f (*loop-form* for-loop)) (declare (special *inner-sloop* *loop-end-test* *loop-increment* *product-for* *loop-map* *loop-form* *loop-body* *loop-prologue* *loop-epilogue* *loop-end-test* *loop-bindings* )) (setf *product-for* t) (loop-pop) (sloop-swap) (parse-loop-for) (sloop-swap) (do () ((null *loop-form*)) (cond ((catch 'collect (parse-loop1))) ((null *loop-form*)(return 'done)) (t ;(fsignal "hi") (print *loop-form*) (sloop-swap) (parse-loop-collect) (sloop-swap) (print *loop-form*) ))) (sloop-swap) (setf inner-body (nreverse *loop-body*)) (and *loop-map* (setf inner-body (substitute-sloop-body inner-body))) (let ((bod `(macrolet ((local-finish () `(go ,',finish-loop))) (tagbody ,@ (nreverse *loop-prologue*) ,@ (and (null *loop-map*) '(next-loop)) ,@ (nreverse *loop-end-test*) ,@ inner-body ,@ (nreverse *loop-increment*) ,@ (and (null *loop-map*) '((go next-loop))) ,finish-loop ,@ (nreverse *loop-epilogue*))))) (dolist (v *loop-bindings*) (setf bod `(let ,(loop-let-bindings v) ,@(and (cdr v) `(,(cons 'declare (cdr v)))) ,bod))) (sloop-swap) `(do ,bod)))) ;;; Usage: SLOOP (FOR ;;; (defun te () ;;; (sloop for i below 5 ;;; sloop (for j to i collecting (list i j)))) (def-loop-for in-carefully (var lis) "Path with var in lis except lis may end with a non nil cdr" (let ((point (gensym "POINT"))) `(with ,point and with ,var initially (setf ,point ,lis) do(desetq ,var (car ,point)) end-test (and (atom ,point)(local-finish)) increment (setf ,point (cdr ,point))))) ;;; Usage: IN-CAREFULLY ;;; (defun te (l) ;;; (sloop for v in-carefully l collecting v)) ;;; Note the following is much like the mit for i first expr1 then expr2 ;;; but it is not identical, in that if expr1 refers to paralell for loop ;;; it will not get the correct initialization. But since we have such ;;; generality in the our definition of a for construct, it is unlikely ;;; that all people who define This is why we use a different name (def-loop-for first-use (var expr1 then expr2) (or (l-equal then 'then) (error "First must be followed by then")) `(with ,var initially (desetq ,var ,expr1) increment (desetq ,var ,expr2))) ;;; I believe the following is what the original loop does with the FIRST ;;; THEN construction. (def-loop-for first (var expr1 then expr2) (declare (special *loop-increment*)) (or (l-equal then 'then) (error "First must be followed by then")) ;; If this is the first for, then we don't need the flag, but can ;; move the FIRST setting into the INITIALLY section (cond ((null *loop-increment*) `(with ,var initially (desetq ,var ,expr1) increment (desetq ,var ,expr2))) (t (let ((flag (gensym))) `(with ,var with ,flag do (cond (,flag (desetq ,var ,expr2)) (t (desetq ,var ,expr1))) increment (desetq ,flag t)))))) (defvar *collate-order* #'<) ;;; of course this should be a search of the list based on the order and ;;; splitting into halves (binary search). I was too lazy to include one ;;; here, but it should be done. (defun find-in-ordered-list (it list &optional (order-function *collate-order*) &aux prev) (do ((v list (cdr v))) ((null v) (values prev nil)) (cond ((eql (car v) it) (return (values v t))) ((funcall order-function it (car v)) (return (values prev nil)))) (setq prev v))) (def-loop-collect collate (ans val) "Collects values into a sorted list without duplicates. Order based order function *collate-order*" `(do (multiple-value-bind (after already-there ) (find-in-ordered-list ,val ,ans) (unless already-there (cond (after (setf (cdr after) (cons ,val (cdr after)))) (t (setf ,ans (cons ,val ,ans)))))))) ;;; Usage: COLLATE ;;; (defun te () ;;; (let ((res ;;; (sloop for i below 10 ;;; sloop (for j downfrom 8 to 0 ;;; collate (* i (mod j (max i 1)) (random 2))))) ;;; ;;; Two implementations of slooping over the fringe of a tree ;;;(defun map-fringe (fun tree) ;;; (do ((v tree)) ;;; (()) ;;; (cond ((atom v) ;;; (and v (funcall fun v))(return 'done)) ;;; ((atom (car v)) ;;; (funcall fun (car v))) ;;; (t (map-fringe fun (car v) ))) ;;; (setf v (cdr v)))) ;;; ;;;(def-loop-map in-fringe (var tree) ;;; "Map over the non nil atoms in the fringe of tree" ;;; `(map-fringe #'(lambda (,var) :sloop-map-declares :sloop-body) ,tree)) ;;; The next version is equivalent to the previous but uses labels and so ;;; avoids having to funcall an anonymous function. [as suggested ;;; by M. Ballantyne] (def-loop-map in-fringe (var tree) "Map over the non nil atoms in the fringe of tree" (let ((v (gensym))) `(let (,var) (labels ((map-fringe-aux (.xtree.) (do ((,v .xtree.)) ((null ,v)) (cond ((atom ,v) (setf ,var ,v) (setf ,v nil)) (t (setf ,var (car ,v))(setf ,v (cdr ,v)))) (cond ((null ,var)) ((atom ,var) :sloop-map-declares :sloop-body) (t (map-fringe-aux ,var )))))) (map-fringe-aux ,tree))))) ;;; Usage: IN-FRINGE ;;; (sloop for v in-fringe '(1 2 (3 (4 5) . 6) 8 1 2) ;;; declare (fixnum v) ;;; maximize v) gcl-2.6.14/lsp/gcl_assert.lsp0000755000175000017500000000641014360276512014443 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; assert.lsp (in-package :si) (defun read-evaluated-form nil (format *query-io* "~&type a form to be evaluated:~%") (list (eval (read *query-io*)))) (defun check-type-symbol (symbol value type &optional type-string &aux (type-string (when type-string (concatenate 'string ": need a " type-string)))) (restart-case (cerror "Check type again." 'type-error :datum value :expected-type type) (store-value (v) :report (lambda (stream) (format stream "Supply a new value of ~s. ~a" symbol (or type-string ""))) :interactive read-evaluated-form (setf value v))) (if (typep value type) value (check-type-symbol symbol value type type-string))) (defmacro check-type (place typespec &optional string) (declare (optimize (safety 2))) `(progn (,(if (symbolp place) 'setq 'setf) ,place (the ,typespec (if (typep ,place ',typespec) ,place (check-type-symbol ',place ,place ',typespec ',string)))) nil)) (defmacro assert (test-form &optional places string &rest args) `(do nil;(*print-level* 4) (*print-length* 4) (,test-form nil) ,(if string `(cerror "" ,string ,@args) `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form)) ,@(mapcan (lambda (place) `((format *error-output* "Please input the new value for the place ~:@(~S~): " ',place) (finish-output *error-output*) (setf ,place (read)))) places))) (defmacro typecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "TYPECASE")))) (declare (optimize (safety 2))) (labels ((l (x &aux (c (pop x))(tp (pop c))(fm (if (cdr c) (cons 'progn c) (car c)))(y (when x (l x)))) (if (or (eq tp t) (eq tp 'otherwise)) fm `(if (typep ,key ',tp) ,fm ,y)))) (let ((x (l clauses))) (if (eq key keyform) x `(let ((,key ,keyform)) ,x))))) (defmacro ctypecase (keyform &rest clauses &aux (key (sgen "CTYPECASE"))) (declare (optimize (safety 2))) ; (check-type clauses (list-of proper-list)) `(do nil (nil) (typecase ,keyform ,@(mapcar (lambda (l) `(,(car l) (return (progn ,@(subst key keyform (cdr l)))))) clauses)) (check-type ,keyform (or ,@(mapcar 'car clauses))))) (defmacro etypecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "ETYPECASE")))) (declare (optimize (safety 2))) ; (check-type clauses (list-of proper-list)) (let ((tp `(or ,@(mapcar 'car clauses)))) `(let ((,key ,keyform)) (typecase ,key ,@clauses (t (error 'type-error :datum ,key :expected-type ',tp)))))) gcl-2.6.14/lsp/gcl_logical_pathname_translations.lsp0000644000175000017500000000171714360276512021234 0ustar cammcamm(in-package :si) (defvar *pathname-logical* nil) (defun setf-logical-pathname-translations (v k) (declare (optimize (safety 1))) (check-type v list) (check-type k string) (setf (cdr (or (assoc k *pathname-logical* :test 'string-equal) (car (push (cons k t) *pathname-logical*)))) ;(cons k nil) (mapcar (lambda (x) (list (parse-namestring (car x) k) (parse-namestring (cadr x)))) v))) (defsetf logical-pathname-translations (x) (y) `(setf-logical-pathname-translations ,y ,x)) (remprop 'logical-pathname-translations 'si::setf-update-fn) (defun logical-pathname-translations (k) (declare (optimize (safety 1))) (check-type k string) (cdr (assoc k *pathname-logical* :test 'string-equal))) (defun load-logical-pathname-translations (k) (declare (optimize (safety 1))) (unless (logical-pathname-translations k) (error "No translations found for ~s" k))) (defun logical-pathname-host-p (host) (when host (logical-pathname-translations host))) gcl-2.6.14/lsp/gcl_autocmp.lsp0000755000175000017500000000316714360276512014620 0ustar cammcamm;;SAMPLE USAGE: ;;(def-autocomp foo (a b) (+ a b)) ;;(def-autocomp goo (a b) (- a b)) ;; ;;(foo 3 4) ==> 7 (after compiling foo and goo together..) ;; ;;Note: Might want to have a *use-count* which only compiles ;;after *use-count* gets above say 10. Thus it would only compile ;;the set of *new-definitions* when there were more than 10. ;;Would need to change the following slightly. Instead of storing the defun ;;store the lambda form, and have the autocomp do an apply of the lambda ;;form while incrementing the *use-count*. This is probably much better, ;;since the *use-count* much more accurately reflects the cost of not compiling ;;This code is obsolete before being used!! But I have to go now.. (require "SLOOP") (use-package "SLOOP") (defvar *new-definitions* nil) (defun compile-new-definitions (name) (and name (or (member name *new-definitions*) (error "~a is not in *new-definitions*" name))) (let ((lisp-file "cmptemp.lisp")(o-file "cmptemp.o")) ;;in case somehow order matters.. (setq *new-definitions* (nreverse *new-definitions*)) (with-open-file (st lisp-file :direction :output) (sloop for v in *new-definitions* do (princ (get v 'new-definition) st))) (compile-file lisp-file :output-file o-file) (load o-file) (setq *new-definitions* nil))) (defun autocomp (name args) (compile-new-definitions name) (apply name args)) (defmacro def-autocomp (fun args &rest body) (let ((defn (list* 'defun fun args body))) `(progn (push ',fun *new-definitions*) (setf (get ',fun 'new-definition) ',defn) (defun ,fun (&rest args) (autocomp ',fun args))))) gcl-2.6.14/lsp/gcl_defpackage.lsp0000644000175000017500000003103414360276512015211 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: (DEFPACKAGE :COLON-MODE :EXTERNAL) -*- ;;; ;;; THE BOEING COMPANY ;;; BOEING COMPUTER SERVICES ;;; RESEARCH AND TECHNOLOGY ;;; COMPUTER SCIENCE ;;; P.O. BOX 24346, MS 7L-64 ;;; SEATTLE, WA 98124-0346 ;;; ;;; ;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved. ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation and that modifications are ;;; appropriately documented with date, author and description of the ;;; change. ;;; ;;; Stephen L. Nicoud (snicoud@boeing.com) provides this software "as ;;; is" without express or implied warranty by him or The Boeing ;;; Company. ;;; ;;; This software is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY. No author or distributor accepts ;;; responsibility to anyone for the consequences of using it or for ;;; whether it serves any particular purpose or works at all. ;;; ;;; Author: Stephen L. Nicoud ;;; ;;; ----------------------------------------------------------------- ;;; ;;; Read-Time Conditionals used in this file. ;;; ;;; #+LISPM ;;; #+EXCL ;;; #+SYMBOLICS ;;; #+TI ;;; ;;; ----------------------------------------------------------------- ;;; ----------------------------------------------------------------- ;;; ;;; DEFPACKAGE - This files attempts to define a portable ;;; implementation for DEFPACKAGE, as defined in "Common LISP, The ;;; Language", by Guy L. Steele, Jr., Second Edition, 1990, Digital ;;; Press. ;;; ;;; Send comments, suggestions, and/or questions to: ;;; ;;; Stephen L Nicoud ;;; ;;; An early version of this file was tested in Symbolics Common ;;; Lisp (Genera 7.2 & 8.0 on a Symbolics 3650 Lisp Machine), ;;; Franz's Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS ;;; 4.1), and Sun Common Lisp (Lucid Common Lisp 3.0.2 on a Sun 3, ;;; SunOS 4.1). ;;; ;;; 91/5/23 (SLN) - Since the initial testing, modifications have ;;; been made to reflect new understandings of what DEFPACKAGE ;;; should do. These new understandings are the result of ;;; discussions appearing on the X3J13 and Common Lisp mailing ;;; lists. Cursory testing was done on the modified version only ;;; in Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS 4.1). ;;; ;;; ----------------------------------------------------------------- (lisp:in-package :DEFPACKAGE) (export '(defpackage)) ;(provide :defpackage) (use-package :SLOOP) ;(use-package :DEFPACKAGE) (proclaim '(declaration values arglist)) ;#-gcl ;(eval-when (compile load eval) ; #-lispm ; (unless (member :loop *features*) ; (require :loop #+excl (merge-pathnames "loop" excl::*library-code-fasl-pathname*))) ; ; (unless (find-package :common-lisp) ; (rename-package :lisp :common-lisp (union '("CL" "LISP") (package-nicknames (find-package :lisp)) :test #'string=))) ; (unless (find-package :common-lisp-user) ; (rename-package :user :common-lisp-user (union '("CL-USER" "USER") (package-nicknames (find-package :user)) :test #'string=))) ; ; #+lispm ; (shadow (intern "DEFPACKAGE" #+symbolics :scl #+ti :ticl) 'defpackage) ; (proclaim '(declaration values arglist)) ; (export 'defpackage 'defpackage) ; ) (defmacro DEFPACKAGE (name &rest options) (declare (type (or symbol string) name) (arglist defined-package-name &rest options) (values package)) "DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] This creates a new package, or modifies an existing one, whose name is DEFINED-PACKAGE-NAME. The DEFINED-PACKAGE-NAME may be a string or a symbol; if it is a symbol, only its print name matters, and not what package, if any, the symbol happens to be in. The newly created or modified package is returned as the value of the DEFPACKAGE form. Each standard OPTION is a list of keyword (the name of the option) and associated arguments. No part of a DEFPACKAGE form is evaluated. Except for the :SIZE and :DOCUMENTATION options, more than one option of the same kind may occur within the same DEFPACKAGE form. Valid Options: (:documentation string) (:size integer) (:nicknames {package-name}*) (:shadow {symbol-name}*) (:shadowing-import-from package-name {symbol-name}*) (:use {package-name}*) (:import-from package-name {symbol-name}*) (:intern {symbol-name}*) (:export {symbol-name}*) (:export-from {package-name}*) [Note: :EXPORT-FROM is an extension to DEFPACKAGE. If a symbol is interned in the package being created and if a symbol with the same print name appears as an external symbol of one of the packages in the :EXPORT-FROM option, then the symbol is exported from the package being created. :DOCUMENTATION is an extension to DEFPACKAGE. :SIZE is used only in Genera and Allegro.]" (sloop for option in options unless (member (first option) '(:documentation :size :nicknames :shadow :shadowing-import-from :use :import-from :intern :export :export-from)) do (cerror "Proceed, ignoring this option." "~s is not a valid option." option)) (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1))) (option-values-list (option options) (sloop for result = (member option options ':test #'option-test) then (member option (rest result) ':test #'option-test) until (null result) when result collect (rest (first result)))) (option-values (option options) (sloop for result = (member option options ':test #'option-test) then (member option (rest result) ':test #'option-test) until (null result) when result append (rest (first result))))) (sloop for option in '(:size :documentation) when (<= 2 (count option options ':key #'car)) do (error 'program-error :format-control "DEFPACKAGE option ~s specified more than once." :format-arguments (list option))) (setq name (string name)) (let ((nicknames (mapcar #'string (option-values ':nicknames options))) (documentation (first (option-values ':documentation options))) (size (first (option-values ':size options))) (shadowed-symbol-names (mapcar #'string (option-values ':shadow options))) (interned-symbol-names (mapcar #'string (option-values ':intern options))) (exported-symbol-names (mapcar #'string (option-values ':export options))) (shadowing-imported-from-symbol-names-list (sloop for list in (option-values-list ':shadowing-import-from options) collect (cons (string (first list)) (mapcar #'string (rest list))))) (imported-from-symbol-names-list (sloop for list in (option-values-list ':import-from options) collect (cons (string (first list)) (mapcar #'string (rest list))))) (exported-from-package-names (mapcar #'string (option-values ':export-from options)))) (flet ((find-duplicates (&rest lists) (let (results) (sloop for list in lists for more on (cdr lists) for i from 1 do (sloop for elt in list as entry = (find elt results :key #'car :test #'string=) unless (member i entry) do (sloop for l2 in more for j from (1+ i) do (if (member elt l2 :test #'string=) (if entry (nconc entry (list j)) (setq entry (car (push (list elt i j) results)))))))) results))) (sloop for duplicate in (find-duplicates shadowed-symbol-names interned-symbol-names (sloop for list in shadowing-imported-from-symbol-names-list append (rest list)) (sloop for list in imported-from-symbol-names-list append (rest list))) do (error 'program-error :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}" :format-arguments (list (first duplicate) (sloop for num in (rest duplicate) collect (case num (1 :SHADOW) (2 :INTERN) (3 :SHADOWING-IMPORT-FROM) (4 :IMPORT-FROM)))))) (sloop for duplicate in (find-duplicates exported-symbol-names interned-symbol-names) do (error 'program-error :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}" :format-arguments (list (first duplicate) (sloop for num in (rest duplicate) collect (case num (1 :EXPORT) (2 :INTERN))))))) `(eval-when (load eval compile) (if (find-package ,name) (progn (rename-package ,name ,name) ,@(when nicknames `((rename-package ,name ,name ',nicknames))) #+(or symbolics excl) ,@(when size #+symbolics `((when (> ,size (pkg-max-number-of-symbols (find-package ,name))) (pkg-rehash (find-package ,name) ,size))) #+excl `((let ((tab (excl::package-internal-symbols (find-package ,name)))) (when (hash-table-p tab) (setf (excl::ha_rehash-size tab) ,size))))) ,@(when (not (null (member ':use options ':key #'car))) `((unuse-package (package-use-list (find-package ,name)) ,name)))) (make-package ,name ':use 'nil ':nicknames ',nicknames ,@(when size #+lispm `(:size ,size) #+excl `(:internal-symbols ,size)))) ,@(progn `((setf (get ',(intern name :keyword) 'si::package-documentation) ,documentation)) ) (let ((*package* (find-package ,name))) ,@(when SHADOWed-symbol-names `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names)))) ,@(when SHADOWING-IMPORTed-from-symbol-names-list (mapcar #'(lambda (list) `(SHADOWING-IMPORT (mapcar #'(lambda (symbol) (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p) (cerror "Continue anyway" 'package-error :package (first list) :format-control "~%Symbol ~a not present" :format-arguments (list symbol))) (intern symbol ,(first list))) ',(rest list)))) SHADOWING-IMPORTed-from-symbol-names-list)) (USE-PACKAGE ',(if (member ':USE options ':test #'option-test) (mapcar #'string (option-values ':USE options)) "LISP")) ,@(when IMPORTed-from-symbol-names-list (mapcar #'(lambda (list) `(IMPORT (mapcar #'(lambda (symbol) (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p) (cerror "Continue anyway" 'package-error :package (first list) :format-control "~%Symbol ~a not present" :format-arguments (list symbol))) (intern symbol ,(first list))) ',(rest list)))) IMPORTed-from-symbol-names-list)) ,@(when INTERNed-symbol-names `((mapcar #'INTERN ',INTERNed-symbol-names))) ,@(when EXPORTed-symbol-names `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names)))) ,@(when EXPORTed-from-package-names `((dolist (package ',EXPORTed-from-package-names) (do-external-symbols (symbol (find-package package)) (when (nth 1 (multiple-value-list (find-symbol (string symbol)))) (EXPORT (list (intern (string symbol))))))))) ) (find-package ,name))))) ;#+excl ;(excl::defadvice cl:documentation (look-for-package-type :around) ; (let ((symbol (first excl::arglist)) ; (type (second excl::arglist))) ; (if (or (eq ':package (intern (string type) :keyword)) ; (eq ':defpackage (intern (string type) :keyword))) ; (or (get symbol 'excl::%package-documentation) ; (get (intern (string symbol) :keyword) 'excl::%package-documentation)) ; (values :do-it)))) ;#+symbolics ;(scl::advise cl:documentation :around look-for-package-type nil ; (let ((symbol (first scl::arglist)) ; (type (second scl::arglist))) ; (if (or (eq ':package (intern (string type) :keyword)) ; (eq ':defpackage (intern (string type) :keyword))) ; (or (get symbol ':package-documentation) ; (get (intern (string symbol) :keyword) ':package-documentation)) ; (values :do-it)))) ;(pushnew :defpackage *features*) ;(unintern 'defpackage 'user) (provide :defpackage) (pushnew :defpackage *features*) (eval-when (load) (in-package "USER") (unintern 'defpackage 'user) (use-package "DEFPACKAGE")) ;;;; ------------------------------------------------------------ ;;;; End of File ;;;; ------------------------------------------------------------ gcl-2.6.14/lsp/gcl_stack-problem.lsp0000755000175000017500000000136414360276512015710 0ustar cammcamm(in-package :si) (defvar *old-handler* #'si::universal-error-handler) (defentry ihs_function_name (object) (object "ihs_function_name")) (defun new-universal-error-handler (a b c d e &rest l &aux (i 0) (top (si::ihs-top))) (declare (fixnum i top)) (if (search "stack overflow" e) (progn (format t "~a in ~a" e d) (format t "invocation stack:") (loop (cond ((or (> i 20) (< top 10)) (return nil))) (setq i (+ i 1)) (setq top (- top 1)) (format t "< ~s " (ihs_function_name (si::ihs-fun top)))) (format t "Jumping to top") (throw *quit-tag* nil) ) (apply *old-handler* a b c d e l))) (setf (symbol-function 'si::universal-error-handler) #'new-universal-error-handler) gcl-2.6.14/lsp/gcl_parse_namestring.lsp0000644000175000017500000001226314360276512016503 0ustar cammcamm(in-package :si) (deftype seqind nil `fixnum) (defun dir-conj (x) (if (eq x :relative) :absolute :relative)) (defvar *up-key* :up) (defun element (x b i key &optional def) (let* ((z (if (> i b) (subseq x b i) def));(make-array (- i b) :element-type 'character :displaced-to x :displaced-index-offset b) (w (assoc key '((:host . nil) (:device . nil) (:directory . ((".." . :up)("*" . :wild)("**" . :wild-inferiors))) (:name . (("*" . :wild))) (:type . (("*" . :wild))) (:version . (("*" . :wild)("NEWEST" . :newest)))))) (w (assoc z (cdr w) :test 'string-equal)) (z (if w (cdr w) z))) (if (eq z :up) *up-key* z))) (defun dir-parse (x &optional lp (b 0)) (when (stringp x) (let ((i (string-match (if lp #v";" +dirsep+) x b))) (unless (minusp i) (let ((y (cons (element x b i :directory "") (dir-parse x lp (1+ i))))) (if (zerop b) (if (if lp (plusp i) (zerop i)) (cons :absolute (cdr y)) (cons :relative y)) y)))))) (defun match-component (x i k &optional (boff 0) (eoff 0)) (element x (+ (match-beginning i) boff) (+ (match-end i) eoff) k)) (defun version-parse (x) (typecase x (string (when (plusp (length x)) (version-parse (parse-integer x)))) (otherwise x))) (defconstant +generic-logical-pathname-regexp+ (compile-regexp (to-regexp-or-namestring (make-list (length +logical-pathname-defaults+)) t t))) (defun logical-pathname-parse (x &optional host def (b 0) (e (length x))) (when *pathname-logical* ;;accelerator (when (and (eql b (string-match +generic-logical-pathname-regexp+ x b e)) (eql (match-end 0) e)) (let ((mhost (match-component x 1 :host 0 -1))) (when (and host mhost) (unless (string-equal host mhost) (error 'error :format-control "Host part of ~s does not match ~s" :format-arguments (list x host)))) (let ((host (or host mhost (pathname-host def)))) (when (logical-pathname-host-p host) (make-pathname :host host :device :unspecific :name (match-component x 6 :name) :type (match-component x 8 :type 1) :version (version-parse (match-component x 11 :version 1)) :directory (dir-parse (match-component x 2 :none) t);must be last :namestring (when (and mhost (eql b 0) (eql e (length x))) x)))))))) (defconstant +generic-physical-pathname-regexp+ (compile-regexp (to-regexp-or-namestring (make-list (length +physical-pathname-defaults+)) t nil))) (defun expand-home-dir (dir) (if (and (eq (car dir) :relative) (stringp (cadr dir)) (eql #\~ (aref (cadr dir) 0))) (prog1 (append (dir-parse (home-namestring (cadr dir))) (cddr dir)) (setq *canonicalized* t)) dir)) (defun pathname-parse (x b e) (when (and (eql b (string-match +generic-physical-pathname-regexp+ x b e)) (eql (match-end 0) e)) (make-pathname :device (match-component x 1 :none 0 -1) :name (match-component x 4 :name) :type (match-component x 5 :type 1) :directory (dir-parse (match-component x 2 :none));must be last :namestring (when (and (eql b 0) (eql e (length x))) x)))) (defun path-stream-name (x) (check-type x pathname-designator) (typecase x (synonym-stream (path-stream-name (symbol-value (synonym-stream-symbol x)))) (stream (path-stream-name (c-stream-object1 x))) (otherwise x))) (defun parse-namestring (thing &optional host (default-pathname *default-pathname-defaults*) &rest r &key (start 0) end junk-allowed) (declare (optimize (safety 1))(dynamic-extent r)) (check-type thing pathname-designator) (check-type host (or null (satisfies logical-pathname-translations))) (check-type default-pathname pathname-designator) (check-type start seqind) (check-type end (or null seqind)) (typecase thing (string (let* ((e (or end (length thing))) (l (logical-pathname-parse thing host default-pathname start e)) (l (or l (unless host (pathname-parse thing start e))))) (cond (junk-allowed (values l (max 0 (match-end 0)))) (l (values l e)) ((error 'parse-error :format-control "~s is not a valid pathname on host ~s" :format-arguments (list thing host)))))) (stream (apply 'parse-namestring (path-stream-name thing) host default-pathname r)) (pathname (when host (unless (string-equal host (pathname-host thing)) (error 'file-error :pathname thing :format-control "Host does not match ~s" :format-arguments (list host)))) (values thing start)))) (defun pathname (spec) (declare (optimize (safety 1))) (check-type spec pathname-designator) (if (typep spec 'pathname) spec (values (parse-namestring spec)))) (defun sharp-p-reader (stream subchar arg) (declare (ignore subchar arg)) (let ((x (parse-namestring (read stream)))) x)) (defun sharp-dq-reader (stream subchar arg);FIXME arg && read-suppress (declare (ignore subchar arg)) (unread-char #\" stream) (let ((x (parse-namestring (read stream)))) x)) (set-dispatch-macro-character #\# #\p 'sharp-p-reader) (set-dispatch-macro-character #\# #\p 'sharp-p-reader (standard-readtable)) (set-dispatch-macro-character #\# #\P 'sharp-p-reader) (set-dispatch-macro-character #\# #\P 'sharp-p-reader (standard-readtable)) (set-dispatch-macro-character #\# #\" 'sharp-dq-reader) (set-dispatch-macro-character #\# #\" 'sharp-dq-reader (standard-readtable)) gcl-2.6.14/lsp/gcl_packlib.lsp0000755000175000017500000001647514360276512014563 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; packlib.lsp ;;;; ;;;; package routines (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defmacro coerce-to-package (p) (if (eq p '*package*) p (let ((g (gensym))) `(let ((,g ,p)) (if (packagep ,g) ,g (find-package (string ,g))))))) (defun find-all-symbols (string-or-symbol) (when (symbolp string-or-symbol) (setq string-or-symbol (symbol-name string-or-symbol))) (mapcan #'(lambda (p) (multiple-value-bind (s i) (find-symbol string-or-symbol p) (if (or (eq i :internal) (eq i :external)) (list s) nil))) (list-all-packages))) (defmacro do-symbols ((var &optional (package '*package*) (result-form nil)) . body) (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (loop (gensym)) (x (gensym))(y (gensym)) (break (gensym)) declaration) (multiple-value-setq (declaration body) (find-declarations body)) `(let ((,p (coerce-to-package ,package)) ,var ,l ) ,@declaration (dolist (,q (cons ,p (package-use-list ,p)) (progn (setq ,var nil) ,result-form)) (multiple-value-bind (,y ,x) (package-size ,q) (declare (fixnum ,x ,y)) (if (not (eq ,p ,q)) (setq ,x 0)) (dotimes (,i (+ ,x ,y)) (setq ,l (if (< ,i ,x) (si:package-internal ,q ,i) (si:package-external ,q (- ,i ,x)))) ,loop (when (null ,l) (go ,break)) (setq ,var (car ,l)) (if (or (eq ,q ,p) (eq :inherited (car (last (multiple-value-list (find-symbol (symbol-name ,var) ,p)))))) (tagbody ,@body)) (setq ,l (cdr ,l)) (go ,loop) ,break)))))) (defmacro do-external-symbols ((var &optional (package '*package*) (result-form nil)) . body) (let ((p (gensym)) (i (gensym)) (l (gensym)) (loop (gensym)) (break (gensym)) declaration) (multiple-value-setq (declaration body) (find-declarations body)) `(let ((,p (coerce-to-package ,package)) ,var ,l) ,@declaration (dotimes (,i (package-size ,p) (progn (setq ,var nil) ,result-form)) (setq ,l (si:package-external ,p ,i)) ,loop (when (null ,l) (go ,break)) (setq ,var (car ,l)) ,@body (setq ,l (cdr ,l)) (go ,loop) ,break)))) (defmacro do-all-symbols((var &optional (result-form nil)) . body) `(dolist (.v (list-all-packages) ,result-form) (do-symbols (,var .v) (tagbody ,@ body)))) (defun substringp (sub str) (do ((i (- (length str) (length sub))) (l (length sub)) (j 0 (1+ j))) ((> j i) nil) (when (string-equal sub str :start2 j :end2 (+ j l)) (return t)))) (defun print-symbol-apropos (symbol) (prin1 symbol) (when (fboundp symbol) (if (special-operator-p symbol) (princ " Special form") (if (macro-function symbol) (princ " Macro") (princ " Function")))) (when (boundp symbol) (if (constantp symbol) (princ " Constant: ") (princ " has value: ")) (prin1 (symbol-value symbol))) (terpri)) ;(defun apropos (string &optional package) ; (setq string (string string)) ; (cond (package ; (do-symbols (symbol package) ; (when (substringp string (string symbol)) ; (print-symbol-apropos symbol))) ; (do ((p (package-use-list package) (cdr p))) ; ((null p)) ; (do-external-symbols (symbol (car p)) ; (when (substringp string (string symbol)) ; (print-symbol-apropos symbol))))) ; (t ; (do-all-symbols (symbol) ; (when (substringp string (string symbol)) ; (print-symbol-apropos symbol))))) ; (values)) (defun apropos-list (string &optional package &aux list) (setq list nil) (setq string (string string)) (cond (package (do-symbols (symbol package) (when (substringp string (string symbol)) (setq list (cons symbol list)))) (do ((p (package-use-list package) (cdr p))) ((null p)) (do-external-symbols (symbol (car p)) (when (substringp string (string symbol)) (setq list (cons symbol list)))))) (t (do-all-symbols (symbol) (when (substringp string (string symbol)) (setq list (cons symbol list)))))) (stable-sort (delete-duplicates list :test #'eq) #'string< :key #'symbol-name)) (defun apropos (string &optional package) (dolist (symbol (apropos-list string package)) (print-symbol-apropos symbol)) (values)) (defmacro with-package-iterator ((name plist &rest symbol-types) . body) (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (dum (gensym)) (x (gensym))(y (gensym)) (access (gensym)) declaration) (multiple-value-setq (declaration body) (si::find-declarations body)) (if (null symbol-types) (error 'program-error :format-control "Symbol type specifiers must be supplied")) `(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil) (,i -1) (,x 0) (,y 0) (,dum nil) (,access nil)) (declare (fixnum ,x ,y)) (flet ((,name () (tagbody ,name (when (null (setq ,l (cdr ,l))) (when (eql (incf ,i) (+ ,x ,y)) (when (null (setq ,q (cdr ,q))) (when (null (setq ,p (cdr ,p))) (return-from ,name nil)) (rplaca ,p (coerce-to-package (car ,p))) (setq ,q (list (si::coerce-to-package (car ,p)))) (when (member :inherited (list ,@symbol-types)) (rplacd ,q (package-use-list (car ,q))))) (multiple-value-setq (,y ,x) (si::package-size (car ,q))) (when (or (not (member :internal (list ,@symbol-types))) (not (eq (car ,p) (car ,q)))) (setq ,x 0)) (when (and (not (member :external (list ,@symbol-types))) (eq (car ,p) (car ,q))) (setq ,y 0)) (when (zerop (+ ,x ,y)) (setq ,i -1) (go ,name)) (setq ,i 0)) (setq ,l (if (< ,i ,x) (si::package-internal (car ,q) ,i) (si::package-external (car ,q) (- ,i ,x))))) (when (null ,l) (go ,name)) (multiple-value-setq (,dum ,access) (find-symbol (symbol-name (car ,l)) (car ,p))) (when (and (not (eq ,access :inherited)) (not (eq (car ,p) (car ,q)))) (go ,name))) (values 't (car ,l) ,access (car ,p)))) ,@declaration ,@body)))) gcl-2.6.14/lsp/gcl_serror.lsp0000755000175000017500000002337214360276512014464 0ustar cammcamm;; -*-Lisp-*- (in-package :si) (macrolet ((make-conditionp (condition &aux (n (intern (string-concatenate (string condition) "P")))) `(defun ,n (x &aux (z (si-find-class ',condition))) (when z (funcall (setf (symbol-function ',n) (lambda (x) (typep x z))) x)))) (make-condition-classp (class &aux (n (intern (string-concatenate (string class) "-CLASS-P")))) `(defun ,n (x &aux (s (si-find-class 'standard-class)) (z (si-find-class ',class))) (when (and s z) (funcall (setf (symbol-function ',n) (lambda (x &aux (x (if (symbolp x) (si-find-class x) x))) (when (typep x s) (member z (si-class-precedence-list x))))) x))))) (make-conditionp condition) (make-conditionp warning) (make-condition-classp condition) (make-condition-classp simple-condition)) (proclaim '(ftype (function (t *) t) make-condition)) (defun coerce-to-condition (datum arguments default-type function-name) (cond ((conditionp datum) (if arguments (cerror "ignore the additional arguments." 'simple-type-error :datum arguments :expected-type 'null :format-control "you may not supply additional arguments ~ when giving ~s to ~s." :format-arguments (list datum function-name))) datum) ((condition-class-p datum) (apply #'make-condition datum arguments)) ((when (condition-class-p default-type) (or (stringp datum) (functionp datum))) (make-condition default-type :format-control datum :format-arguments arguments)) ((coerce-to-string datum arguments)))) (defvar *handler-clusters* nil) (defvar *break-on-signals* nil) (defun signal (datum &rest arguments) (declare (optimize (safety 1))) (let ((*handler-clusters* *handler-clusters*) (condition (coerce-to-condition datum arguments 'simple-condition 'signal))) (if (typep condition *break-on-signals*) (break "~a~%break entered because of *break-on-signals*." condition)) (do nil ((not *handler-clusters*)) (dolist (handler (pop *handler-clusters*)) (when (typep condition (car handler)) (funcall (cdr handler) condition)))) nil)) (defvar *debugger-hook* nil) (defvar *debug-level* 1) (defvar *debug-restarts* nil) (defvar *debug-abort* nil) (defvar *debug-continue* nil) (defvar *abort-restarts* nil) (defun break-level-invoke-restart (n) (cond ((when (plusp n) (< n (+ (length *debug-restarts*) 1))) (invoke-restart-interactively (nth (1- n) *debug-restarts*))) ((format t "~&no such restart.")))) (defun find-ihs (s i &optional (j i)) (cond ((eq (ihs-fname i) s) i) ((and (> i 0) (find-ihs s (1- i) j))) (j))) (defmacro without-interrupts (&rest forms) `(let (*quit-tag* *quit-tags* *restarts*) ,@forms)) (defun process-args (args &aux (control (member :format-control args))) (labels ((r (x &aux (z (member-if (lambda (x) (member x '(:format-control :format-arguments))) x))) (if z (nconc (ldiff x z) (r (cddr z))) x))) (if control (nconc (r args) (list (apply 'format nil (cadr control) (cadr (member :format-arguments args))))) args))) (defun coerce-to-string (datum args) (cond ((stringp datum) (if args (let ((*print-pretty* nil) (*print-level* *debug-print-level*) (*print-length* *debug-print-level*) (*print-case* :upcase)) (apply 'format nil datum args)) datum)) ((symbolp datum) (let ((args (process-args args))) (substitute #\^ #\~ (coerce-to-string (if args (apply 'string-concatenate (cons datum (make-list (length args) :initial-element " ~s"))) (string datum)) args)))) ("unknown error"))) (defvar *break-on-warnings* nil) (defun warn (datum &rest arguments) (declare (optimize (safety 2))) (let ((c (process-error datum arguments 'simple-warning))) (check-type c (or string (satisfies warningp)) "a warning condition") (when *break-on-warnings* (break "~A~%break entered because of *break-on-warnings*." c)) (restart-case (signal c) (muffle-warning nil :report "Skip warning." (return-from warn nil))) (format *error-output* "~&Warning: ~a~%" c) nil)) (dolist (l '(break cerror error universal-error-handler ihs-top get-sig-fn-name next-stack-frame check-type-symbol)) (setf (get l 'dbl-invisible) t)) (defvar *sig-fn-name* nil) (defun get-sig-fn-name (&aux (p (ihs-top))(p (next-stack-frame p))) (when p (ihs-fname p))) (defun process-error (datum args &optional (default-type 'simple-error)) (let ((internal (cond ((simple-condition-class-p datum) (find-symbol (string-concatenate "INTERNAL-" (string datum)) :conditions)) ((condition-class-p datum) (find-symbol (string-concatenate "INTERNAL-SIMPLE-" (string datum)) :conditions))))) (coerce-to-condition (or internal datum) (if internal (list* :function-name *sig-fn-name* args) args) default-type 'process-error))) (defun universal-error-handler (n cp fn cs es &rest args &aux (*sig-fn-name* fn)) (declare (ignore es)) (if cp (apply #'cerror cs n args) (apply #'error n args))) (defun cerror (continue-string datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) (values (with-simple-restart (continue continue-string args) (apply #'error datum args)))) (putprop 'cerror t 'compiler::cmp-notinline) (defun error (datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) (let ((c (process-error datum args))(q (or *quit-tag* +top-level-quit-tag+))) (signal c) (invoke-debugger c) (throw q q))) (putprop 'error t 'compiler::cmp-notinline) (defun invoke-debugger (condition) (when *debugger-hook* (let ((hook *debugger-hook*) *debugger-hook*) (funcall hook condition hook))) (maybe-clear-input) (let ((correctable (find-restart 'continue)) *print-pretty* (*print-level* *debug-print-level*) (*print-length* *debug-print-level*) (*print-case* :upcase)) (terpri *error-output*) (format *error-output* (if (and correctable *break-enable*) "~&Correctable error: " "~&Error: ")) (let ((*indent-formatted-output* t)) (when (stringp condition) (format *error-output* condition))) (terpri *error-output*) (if (> (length *link-array*) 0) (format *error-output* "Fast links are on: do (si::use-fast-links nil) for debugging~%")) (format *error-output* "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function")) (when (and correctable *break-enable*) (format *error-output* "~&If continued: ") (funcall (restart-report-function correctable) *error-output*)) (force-output *error-output*) (when *break-enable* (break-level condition)))) (defun dbl-eval (- &aux (break-command t)) (let ((val-list (multiple-value-list (cond ((keywordp -) (break-call - nil 'break-command)) ((and (consp -) (keywordp (car -))) (break-call (car -) (cdr -) 'break-command)) ((integerp -) (break-level-invoke-restart -)) (t (setq break-command nil) (evalhook - nil nil *break-env*)))))) (cons break-command val-list))) (defun dbl-rpl-loop (p-e-p) (setq +++ ++ ++ + + -) (if *no-prompt* (setq *no-prompt* nil) (format *debug-io* "~&~a~a>~{~*>~}" (if p-e-p "" "dbl:") (if (eq *package* (find-package 'user)) "" (package-name *package*)) *break-level*)) (force-output *error-output*) (setq - (dbl-read *debug-io* nil *top-eof*)) (when (eq - *top-eof*) (bye -1)) (let* ((ev (dbl-eval -)) (break-command (car ev)) (values (cdr ev))) (unless (and break-command (eq (car values) :resume)) (setq /// // // / / values *** ** ** * * (car /)) (fresh-line *debug-io*) (dolist (val /) (prin1 val *debug-io*) (terpri *debug-io*)) (dbl-rpl-loop p-e-p)))) (defun do-break-level (at env p-e-p debug-level); break-level (unless (with-simple-restart (abort "Return to debug level ~D." debug-level) (catch-fatal 1) (setq *interrupt-enable* t) (cond (p-e-p (format *debug-io* "~&~A~2%" at) (set-current) (setq *no-prompt* nil) (show-restarts)) ((set-back at env))) (not (catch 'step-continue (dbl-rpl-loop p-e-p)))) (terpri *debug-io*) (break-current) (do-break-level at env p-e-p debug-level))) (defun break-level (at &optional env) (let* ((p-e-p (unless (listp at) t)) (+ +) (++ ++) (+++ +++) (- -) (* *) (** **) (*** ***) (/ /) (// //) (/// ///) (debug-level *debug-level*) (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) *quit-tag* (*break-level* (if p-e-p (cons t *break-level*) *break-level*)) (*ihs-base* (1+ *ihs-top*)) (*ihs-top* (ihs-top)) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*current-ihs* *ihs-top*) (*debug-level* (1+ *debug-level*)) (*debug-restarts* (compute-restarts)) (*debug-abort* (find-restart 'abort)) (*debug-continue* (find-restart 'continue)) (*abort-restarts* (remove-if-not (lambda (x) (eq 'abort (restart-name x))) *debug-restarts*)) (*readtable* (or *break-readtable* *readtable*)) *break-env* *read-suppress*) (do-break-level at env p-e-p debug-level))) (putprop 'break-level t 'compiler::cmp-notinline) (defun break (&optional format-string &rest args &aux message (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) (let ((*print-pretty* nil) (*print-level* 4) (*print-length* 4) (*print-case* :upcase)) (terpri *error-output*) (cond (format-string (format *error-output* "~&Break: ") (let ((*indent-formatted-output* t)) (apply 'format *error-output* format-string args)) (terpri *error-output*) (setq message (apply 'format nil format-string args))) (t (format *error-output* "~&Break.~%") (setq message "")))) (with-simple-restart (continue "Return from break.") (break-level message)) nil) (putprop 'break t 'compiler::cmp-notinline) gcl-2.6.14/lsp/gcl_trace.lsp0000755000175000017500000003603114360276512014242 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; trace.lsp ;;;; ;;;; Tracer package for Common Lisp ;;;;;; Modified by Matt Kaufmann to allow tracing options. ;; If you are working in another package you should (import 'si::arglist) ;; to avoid typing the si:: (in-package :si) ;;(proclaim '(optimize (safety 2) (space 3))) (defvar *trace-level* 0) (defvar *trace-list* nil) (defmacro trace (&rest r) (if (null r) '(mapcar #'car *trace-list*) `(let ((old (copy-list *trace-list*)) finish-flg) (unwind-protect (prog1 (mapcan #'trace-one ',r) (setq finish-flg t)) (when (null finish-flg) (format *standard-output* "~%Newly traced functions: ~S" (mapcar #'car (set-difference *trace-list* old :test #'equal)))))))) (defmacro untrace (&rest r) (if (null r) '(mapcan #'untrace-one (mapcar #'car *trace-list*)) `(mapcan #'untrace-one ',r))) (defun trace-one-preprocess (x) (cond ((symbolp x) (trace-one-preprocess (list x))) (t ; We've checked for CONSP with null last CDR (do ((tail (cdr x) (cddr tail)) (declarations) (entryform `(cons (quote ,(car x)) arglist)) (exitform `(cons (quote ,(car x)) values)) (condform t) (entrycondform t) (exitcondform t) (depth) (depthvar)) ((null tail) (when depth ;; Modify the :cond so that it first checks depth, and then ;; modify the :entry so that it first increments depth. Notice ;; that :cond will be fully evaluated before depth is incremented. (setq depthvar (gensym)) ;; now reset the condform (if (eq condform t) (setq condform `(< ,depthvar ,depth)) (setq condform `(if (< ,depthvar ,depth) ,condform nil))) (setq declarations (cons (cons depthvar 0) declarations)) ;; I'll have the depth be incremented for all the entry stuff and no exit stuff, ;; since I don't see any more uniform, logical way to do this. (setq entrycondform `(progn (setq ,depthvar (1+ ,depthvar)) ,entrycondform)) (setq exitcondform `(progn (setq ,depthvar (1- ,depthvar)) ,exitcondform))) `(,(car x) ,declarations (quote ,condform) (quote ,entrycondform) (quote ,entryform) (quote ,exitcondform) (quote ,exitform))) (case (car tail) (:declarations (setq declarations (do ((decls (cadr tail) (cdr decls)) (result)) ((null decls) result) (setq result (cons (if (symbolp (car decls)) (cons (car decls) nil) (cons (caar decls) (eval (cadar decls)))) result))))) (:cond (setq condform (cadr tail))) (:entrycond (setq entrycondform (cadr tail))) (:entry (setq entryform (cadr tail))) (:exitcond (setq exitcondform (cadr tail))) (:exit (setq exitform (cadr tail))) (:depth (setq depth (cadr tail))) (otherwise nil)))))) (defun check-trace-spec (form) (or (symbolp form) (if (and (consp form) (null (cdr (last form)))) (check-trace-args form (cdr form) nil) (error "Each trace spec must be a symbol or a list terminating in NIL, but ~S is not~&." form)))) (defun check-declarations (declarations &aux decl) (when (consp declarations) (setq decl (if (consp (car declarations)) (car declarations) (list (car declarations) nil))) (when (not (symbolp (car decl))) (error "Declarations are supposed to be of symbols, but ~S is not a symbol.~&" (car decl))) (when (cddr decl) (error "Expected a CDDR of NIL in ~S.~&" decl)) (when (assoc (car decl) (all-trace-declarations)) (error "The variable ~A is already declared for tracing" (car decl))))) (defun check-trace-args (form args acc-keywords) (when args (cond ((null (cdr args)) (error "A trace spec must have odd length, but ~S does not.~&" form)) ((member (car args) acc-keywords) (error "The keyword ~A occurred twice in the spec ~S~&" (car args) form)) (t (case (car args) ((:entry :exit :cond :entrycond :exitcond) (check-trace-args form (cddr args) (cons (car args) acc-keywords))) (:depth (when (not (and (integerp (cadr args)) (> (cadr args) 0))) (error "~&Specified depth should be a positive integer, but~&~S is not.~&" (cadr args))) (check-trace-args form (cddr args) (cons :depth acc-keywords))) (:declarations (check-declarations (cadr args)) (check-trace-args form (cddr args) (cons :declarations acc-keywords))) (otherwise (error "Expected :entry, :exit, :cond, :depth, or :declarations~&~ in ~S where instead there was ~S~&" form (car args)))))))) (defun trace-one (form &aux f (fname (if (consp form) (car form) form))) (when (null (fboundp fname)) (format *trace-output* "The function ~S is not defined.~%" fname) (return-from trace-one nil)) (when (special-operator-p fname) (format *trace-output* "~S is a special form.~%" fname) (return-from trace-one nil)) (when (macro-function fname) (format *trace-output* "~S is a macro.~%" fname) (return-from trace-one nil)) (when (get fname 'traced) (untrace-one fname)) (check-trace-spec form) (setq form (trace-one-preprocess form)) (si:fset (setq f (gensym)) (symbol-function fname)) (eval `(defun ,fname (&rest args) (trace-call ',f args ,@(cddr form)))) (si:putprop fname f 'traced) (setq *trace-list* (cons (cons fname (cadr form)) *trace-list*)) (list fname)) (defun reset-trace-declarations (declarations) (when declarations (set (caar declarations) (cdar declarations)) (reset-trace-declarations (cdr declarations)))) (defun all-trace-declarations ( &aux result) (dolist (v *trace-list*) (setq result (append result (cdr v)))) result) (defun trace-call (temp-name args cond entrycond entry exitcond exit &aux (*trace-level* *trace-level*) vals indent) (when (= *trace-level* 0) (reset-trace-declarations (all-trace-declarations))) (cond ((eval `(let ((arglist (quote ,args))) ,cond)) (setq *trace-level* (1+ *trace-level*)) (setq indent (min (* *trace-level* 2) 20)) (fresh-line *trace-output*) (when (or (eq entrycond t) ;optimization for common value (eval `(let ((arglist (quote ,args))) ,entrycond))) ;; put out the prompt before evaluating (format *trace-output* "~V@T~D> " indent *trace-level*) (format *trace-output* "~S~%" (eval `(let ((arglist (quote ,args))) ,entry))) (fresh-line *trace-output*)) (setq vals (multiple-value-list (apply temp-name args))) (when (or (eq exitcond t) ;optimization for common value (eval `(let ((arglist (quote ,args)) (values (quote ,vals))) ,exitcond))) ;; put out the prompt before evaluating (format *trace-output* "~V@T<~D " indent *trace-level*) (format *trace-output* "~S~%" (eval `(let ((arglist (quote ,args)) (values (quote ,vals))) ,exit)))) (setq *trace-level* (1- *trace-level*)) (values-list vals)) (t (apply temp-name args)))) (defun untrace-one (fname &aux sym) (cond ((setq sym (get fname 'traced)) (remprop fname 'traced) (cond ((not (fboundp fname)) (format *trace-output* "The function ~S was traced, but is no longer defined.~%" fname)) ;;(LAMBDA-BLOCK block-name lambda-list (TRACE-CALL ... )) ((and (consp (symbol-function fname)) (consp (nth 3 (symbol-function fname))) (eq (car (nth 3 (symbol-function fname))) 'trace-call)) (si:fset fname (symbol-function sym))) (t (format *trace-output* "The function ~S was traced, but redefined.~%" fname))) (setq *trace-list* (delete-if #'(lambda (u) (eq (car u) fname)) *trace-list* :count 1)) (list fname)) (t (format *trace-output* "The function ~S is not traced.~%" fname) nil))) #| Example of tracing a function "fact" so that only the outermost call is traced. (defun fact (n) (if (= n 0) 1 (* n (fact (1- n))))) ;(defvar in-fact nil) (trace (fact :declarations ((in-fact nil)) :cond (null in-fact) :entry (progn (setq in-fact t) (princ "Here comes input ") (cons 'fact arglist)) :exit (progn (setq in-fact nil) (princ "Here comes output ") (cons 'fact values)))) ; Example of tracing fact so that only three levels are traced (trace (fact :declarations ((fact-depth 0)) :cond (and (< fact-depth 3) (setq fact-depth (1+ fact-depth))) :exit (progn (setq fact-depth (1- fact-depth)) (cons 'fact values)))) |# (defvar *step-level* 0) (defvar *step-quit* nil) (defvar *step-function* nil) (defvar *old-print-level* nil) (defvar *old-print-length* nil) (defun step-read-line () (do ((char (read-char *debug-io*) (read-char *debug-io*))) ((or (char= char #\Newline) (char= char #\Return))))) (defmacro if-error (error-form form) (let ((v (gensym)) (f (gensym)) (b (gensym))) `(let (,v ,f) (block ,b (unwind-protect (setq ,v ,form ,f t) (return-from ,b (if ,f ,v ,error-form))))))) (defmacro step (form) `(let* ((*old-print-level* *print-level*) (*old-print-length* *print-length*) (*print-level* 2) (*print-length* 2)) (read-line) (format *debug-io* "Type ? and a newline for help.~%") (setq *step-quit* nil) (stepper ',form nil))) (defun stepper (form &optional env &aux values (*step-level* *step-level*) indent) (when (eq *step-quit* t) (return-from stepper (evalhook form nil nil env))) (when (numberp *step-quit*) (if (>= (1+ *step-level*) *step-quit*) (return-from stepper (evalhook form nil nil env)) (setq *step-quit* nil))) (when *step-function* (if (and (consp form) (eq (car form) *step-function*)) (let ((*step-function* nil)) (return-from stepper (stepper form env))) (return-from stepper (evalhook form #'stepper nil env)))) (setq *step-level* (1+ *step-level*)) (setq indent (min (* *step-level* 2) 20)) (loop (format *debug-io* "~VT~S " indent form) (finish-output *debug-io*) (case (do ((char (read-char *debug-io*) (read-char *debug-io*))) ((and (char/= char #\Space) (char/= char #\Tab)) char)) ((#\Newline #\Return) (setq values (multiple-value-list (evalhook form #'stepper nil env))) (return)) ((#\n #\N) (step-read-line) (setq values (multiple-value-list (evalhook form #'stepper nil env))) (return)) ((#\s #\S) (step-read-line) (setq values (multiple-value-list (evalhook form nil nil env))) (return)) ((#\p #\P) (step-read-line) (write form :stream *debug-io* :pretty t :level nil :length nil) (terpri)) ((#\f #\F) (let ((*step-function* (if-error nil (prog1 (read-preserving-whitespace *debug-io*) (step-read-line))))) (setq values (multiple-value-list (evalhook form #'stepper nil env))) (return))) ((#\q #\Q) (step-read-line) (setq *step-quit* t) (setq values (multiple-value-list (evalhook form nil nil env))) (return)) ((#\u #\U) (step-read-line) (setq *step-quit* *step-level*) (setq values (multiple-value-list (evalhook form nil nil env))) (return)) ((#\e #\E) (let ((env1 env)) (dolist (x (if-error nil (multiple-value-list (evalhook (if-error nil (prog1 (read-preserving-whitespace *debug-io*) (step-read-line))) nil nil env1)))) (write x :stream *debug-io* :level *old-print-level* :length *old-print-length*) (terpri *debug-io*)))) ((#\r #\R) (let ((env1 env)) (setq values (if-error nil (multiple-value-list (evalhook (if-error nil (prog1 (read-preserving-whitespace *debug-io*) (step-read-line))) nil nil env1))))) (return)) ((#\b #\B) (step-read-line) (let ((*ihs-base* (1+ *ihs-top*)) (*ihs-top* (1- (ihs-top))) (*current-ihs* *ihs-top*)) (simple-backtrace))) (t (step-read-line) (terpri) (format *debug-io* "Stepper commands:~%~ n (or N or Newline): advances to the next form.~%~ s (or S): skips the form.~%~ p (or P): pretty-prints the form.~%~ f (or F) FUNCTION: skips until the FUNCTION is called.~%~ q (or Q): quits.~%~ u (or U): goes up to the enclosing form.~%~ e (or E) FORM: evaluates the FORM ~ and prints the value(s).~%~ r (or R) FORM: evaluates the FORM ~ and returns the value(s).~%~ b (or B): prints backtrace.~%~ ?: prints this.~%") (terpri)))) (when (or (constantp form) (and (consp form) (eq (car form) 'quote))) (return-from stepper (car values))) (if (endp values) (format *debug-io* "~V@T=~%" indent) (do ((l values (cdr l)) (b t nil)) ((endp l)) (if b (format *debug-io* "~V@T= ~S~%" indent (car l)) (format *debug-io* "~V@T& ~S~%" indent (car l))))) (setq *step-level* (- *step-level* 1)) (values-list values)) gcl-2.6.14/lsp/gprof1.lisp0000755000175000017500000000240114360276512013660 0ustar cammcamm(in-package 'si) ;; (load "gprof.o") ;; On a sun in sun0S 3 or 4.0 ;; make a modified copy of /lib/gcrt0.o called gcrt0-mod.o ;; then (cd unixport ; make "EXTRAS=../lsp/gcrt0-mod.o") ;; after compiling some .o files with ;; (cd o ; make "CFLAGS = -I../h -pg -g -c") ;; (invoke gprof-setup) ;; and (monitor #x800 3000000) ;; (monitor 0 0) to start and stop respectively ;; on suns the buffersize = (highpc- lowpc)/2 +6 (clines "#include \"gprof.hc\"") (defun gprof-setup (&optional (n 800000) (m 1000000)) (mymonstartup #x800 n) (set-up-monitor-array m) (format t" ;; and (monitor #x800 3000000) ;; (monitor 0 0) to start and stop respectively ") nil) (defentry mymonstartup (int int) (int "mymonstartup")) ;(defentry monitor1 (int int object) (int "mymonitor")) (defentry monitor2 (int int int int) (int "mymonitor")) (defentry write_outsyms () (int "write_outsyms")) (defvar *monitor-array* nil) (defun set-up-monitor-array (&optional (n 1000000)) (unless *monitor-array* (setf *monitor-array* (make-array n :element-type 'string-char :static t)) ;(mymonstartup 0 2000000) nil )) (defun monitor (low high) (monitor1 low high *monitor-array*)) (defun write-syms.out () (set-up-combined) (write_outsyms)) gcl-2.6.14/lsp/gcl_mislib.lsp0000755000175000017500000001433414360276512014425 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; This file is IMPLEMENTATION-DEPENDENT. (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defmacro time (form) (let ((real-start (gensym)) (real-end (gensym)) (gbc-time-start (gensym)) (gbc-time (gensym)) (x (gensym)) (run-start (gensym)) (run-end (gensym)) (child-run-start (gensym)) (child-run-end (gensym))) `(let (,real-start ,real-end (,gbc-time-start (gbc-time)) ,gbc-time ,x) (setq ,real-start (get-internal-real-time)) (multiple-value-bind (,run-start ,child-run-start) (get-internal-run-time) (gbc-time 0) (setq ,x (multiple-value-list ,form)) (setq ,gbc-time (gbc-time)) (gbc-time (+ ,gbc-time-start ,gbc-time)) (multiple-value-bind (,run-end ,child-run-end) (get-internal-run-time) (setq ,real-end (get-internal-real-time)) (fresh-line *trace-output*) (format *trace-output* "real time : ~10,3F secs~%~ run-gbc time : ~10,3F secs~%~ child run time : ~10,3F secs~%~ gbc time : ~10,3F secs~%" (/ (- ,real-end ,real-start) internal-time-units-per-second) (/ (- (- ,run-end ,run-start) ,gbc-time) internal-time-units-per-second) (/ (- ,child-run-end ,child-run-start) internal-time-units-per-second) (/ ,gbc-time internal-time-units-per-second)))) (values-list ,x)))) (defun this-tz (&aux (x (current-timezone))) (if (current-dstp) (1+ x) x)) (defun decode-universal-time (ut &optional (tz (this-tz) tzp)) (declare (optimize (safety 2))) (check-type ut integer) (check-type tz rational) (let ((ut (+ ut (* (- (this-tz) tz) 3600) #.(* -1 (+ 17 (* 70 365)) 24 60 60)))) (multiple-value-bind (s n h d m y w yd dstp off) (localtime ut) (when (when tzp (> dstp 0)) (multiple-value-setq (s n h d m y w yd) (localtime (- ut 3600)))) (values s n h d (1+ m) (+ 1900 y) (if (zerop w) 6 (1- w)) (unless tzp (> dstp 0)) (if tzp tz (+ (truncate (- off) 3600) dstp)))))) (defun encode-universal-time (s n h d m y &optional (tz (this-tz) tzp)) (declare (optimize (safety 2))) (check-type s (integer 0 59)) (check-type n (integer 0 59)) (check-type h (integer 0 23)) (check-type d (integer 1 31)) (check-type m (integer 1 12)) (check-type y integer) (check-type tz rational) (multiple-value-bind (tm dstp) (mktime s n h d (1- m) (- y 1900)) (+ tm #.(* (+ 17 (* 70 365)) 24 60 60) (* (- tz (this-tz)) 3600) (if tzp (* dstp 3600) 0)))) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")) (defun constantly (x) (lambda (&rest args) (declare (ignore args) (:dynamic-extent args)) x)) (defun complement (fn) (lambda (&rest args) (not (apply fn args)))) (defun default-system-banner () (let (gpled-modules) (dolist (l '(:unexec :bfd :readline :xgcl)) (when (member l *features*) (push l gpled-modules))) (format nil "GCL (GNU Common Lisp) ~a.~a.~a ~a ~a ~a git: ~a~%~a~%~a ~a~%~a~%~a~%~%~a~%" *gcl-major-version* *gcl-minor-version* *gcl-extra-version* *gcl-release-date* (if (member :ansi-cl *features*) "ANSI" "CLtL1") (if (member :gprof *features*) "profiling" "") *gcl-git-tag* "Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)" "Binary License: " (if gpled-modules (format nil "GPL due to GPL'ed components: ~a" gpled-modules) "LGPL") "Modifications of this banner must retain notice of a compatible license" "Dedicated to the memory of W. Schelter" "Use (help) to get some basic information on how to use GCL."))) (defun lisp-implementation-version nil (format nil "GCL ~a.~a.~a git tag ~a" *gcl-major-version* *gcl-minor-version* *gcl-extra-version* *gcl-git-tag*)) (defun objlt (x y) (declare (object x y)) (let ((x (address x)) (y (address y))) (declare (fixnum x y)) (if (< y 0) (if (< x 0) (< x y) t) (if (< x 0) nil (< x y))))) (defun reset-sys-paths (s) (declare (string s)) (setq *lib-directory* s) (setq *system-directory* (string-concatenate s "unixport/")) (let (nl) (dolist (l '("cmpnew/" "gcl-tk/" "lsp/" "xgcl-2/")) (push (string-concatenate s l) nl)) (setq *load-path* nl)) nil) (defun gprof-output (symtab gmon) (with-open-file (s (format nil "|gprof -S '~a' '~a' '~a'" symtab (kcl-self) gmon)) (copy-stream s *standard-output*))) (defun write-symtab (symtab start end &aux (*package* (find-package "KEYWORD"))) (with-open-file (s symtab :direction :output :if-exists :supersede) (format s "~16,'0x T ~a~%" start "GCL_MONSTART") (dolist (p (list-all-packages)) (do-symbols (x p) (when (and (eq (symbol-package x) p) (fboundp x)) (let* ((y (symbol-function x)) (y (if (and (consp y) (eq 'macro (car y))) (cdr y) y)) (y (if (compiled-function-p y) (function-start y) 0))) (when (<= start y end) (format s "~16,'0x T ~s~%" y x)))))) (let ((string-register "")) (dotimes (i (ptable-alloc-length)) (multiple-value-bind (x y) (ptable i string-register) (when (<= start x end) (format s "~16,'0x T ~a~%" x y))))) (format s "~16,'0x T ~a~%" end "GCL_MONEND")) symtab) (defun gprof-start (&optional (symtab "gcl_symtab") (adrs (gprof-addresses)) &aux (start (car adrs))(end (cdr adrs))) (let ((symtab (write-symtab symtab start end))) (when (monstartup start end) symtab))) (defun gprof-quit (&optional (symtab "gcl_symtab") &aux (gmon (mcleanup))) (when gmon (gprof-output symtab gmon))) gcl-2.6.14/lsp/gprof.hc0000755000175000017500000000503314360276512013226 0ustar cammcamm#include #include #define CF_FLAG (1 << 31) static /* mymonitor(low,high,x) int low,high; object x; { if (0 == x) {monitor(0); return 0;} if (type_of(x)!=t_string) FEerror("expected string",0); monitor(low,high,x->ust.ust_self,x->ust.ust_dim,1000); } */ mymonitor(low,high,x,leng) int low,high; object x; { if (0 == x) {monitor(0); return 0;} monitor(low,high,x,leng); } char *sbrk(); static mymonstartup(low,high) int low,high; {char *buf; buf = sbrk(0); monstartup(low,high); return buf; } char *kcl_self; #include #include "../h/ext_sym.h" #define syment nlist #define fileheader exec static char symname [200]; static sym_leng_and_copy(ux,copy) unsigned int ux; int copy; { char *from; int leng=0; if (ux & CF_FLAG) {object x = (object) (ux & ~CF_FLAG); if (x->cf.cf_name ==0) from="ZUNDEF"; else {leng = x->cf.cf_name->s.s_fillp; from = x->cf.cf_name->s.s_self;}} else if (ux) { from= (char *)(ux);} else {from="UNDEF";} if (leng==0) leng=strlen(from); if (leng >= sizeof(symname)) FEerror("Too long symbol",0); if(copy) bcopy(from,symname,leng); symname[leng]='0'; return leng; } extern char *core_end; static write_outsyms() {FILE *fdout,*fdin; static struct syment sym; struct fileheader hdr; fdout= fopen("syms.out","w"); fdin=fopen(kcl_self,"r"); if (fdin == 0) FEerror("Can't find akcl image",0); fread(&hdr,sizeof(hdr),1,fdin); if (fdout == 0) FEerror("Can't open syms.out",0); fclose(fdin); sym.n_type= (N_TEXT | N_EXT); hdr.a_text=sizeof(hdr); hdr.a_data=0; hdr.a_bss=0; hdr.a_trsize=0; hdr.a_drsize=0; hdr.a_syms= (1 + combined_table.length)*sizeof (struct syment); fwrite(&hdr,sizeof(hdr),1,fdout); fseek(fdout,N_SYMOFF(hdr),0); {int i=0; int pos=4; while (i < combined_table.length) { /* printf("%d %d",i,SYM_STRING(combined_table,i)); fflush(stdout); */ sym.n_un.n_strx = pos; sym.n_value=SYM_ADDRESS(combined_table,i); fwrite(&sym,sizeof(sym),1,fdout); pos=pos+ sym_leng_and_copy(SYM_STRING(combined_table,i),1)+1; /* printf("%s\n",symname); */ i++; } sym.n_un.n_strx = pos; sym.n_value=(int)core_end; fwrite(&sym,sizeof(sym),1,fdout); pos=pos+ strlen("_ENDSYM")+1; fwrite(&pos,sizeof(pos),1,fdout); for (i=0; i< combined_table.length ; i++) {int leng=sym_leng_and_copy(SYM_STRING(combined_table,i),1); fwrite(symname,leng,1,fdout); putc(0,fdout);} } fwrite("_ENDSYM",8,1,fdout); fclose(fdout); } gcl-2.6.14/lsp/dummy.lisp0000755000175000017500000000000114360276512013607 0ustar cammcamm gcl-2.6.14/lsp/gcl_readline.lsp0000644000175000017500000000066114360276512014724 0ustar cammcamm(in-package "SI" ) (defun init-readline () ; init Readline word completion list for Gcl (if (fboundp 'si::readline-init) (let (l) (sloop::sloop for v in-package 'lisp do (if (or (boundp v) (fboundp v)) (setq l (cons (symbol-name v) l)))) (sloop::sloop for v in-package 'keyword do (if (or (boundp v) (fboundp v)) (setq l (cons (format nil ":~A" v) l)))) (si::readline-init t "Gcl" 1 l)))) gcl-2.6.14/lsp/gcl_module.lsp0000755000175000017500000000772514360276512014441 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; module.lsp ;;;; ;;;; module routines (in-package :si) (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) (defvar *modules* nil) (defun provide (module-name) (setq *modules* (adjoin (string module-name) *modules* :test #'string=))) (defun require (module-name &optional (pathname (string-downcase (string module-name)))) (let ((*default-pathname-defaults* (make-pathname))) (unless (member (string module-name) *modules* :test #'string=) (if (atom pathname) (load pathname) (do ((p pathname (cdr p))) ((endp p)) (load (car p))))))) (defun documentation (symbol doc-type) (case doc-type (variable (get symbol 'variable-documentation)) (function (get symbol 'function-documentation)) (structure (get symbol 'structure-documentation)) (type (get symbol 'type-documentation)) (setf (get symbol 'setf-documentation)) (t (if (packagep symbol) (get (find-symbol (package-name symbol) :keyword) 'package-documentation) (error "~S is an illegal documentation type." doc-type))))) (defun find-documentation (body) (if (or (endp body) (endp (cdr body))) nil (let ((form (macroexpand (car body)))) (if (stringp form) form (if (and (consp form) (eq (car form) 'declare)) (find-documentation (cdr body)) nil))))) (defun eval-feature (x) (cond ((atom x) (member x *features* :test #'(lambda (a b) (cond ((symbolp a) (and (symbolp b) (string-equal (symbol-name a) (symbol-name b)))) (t (eql a b)))))) ((eq (car x) 'and) (dolist (x (cdr x) t) (unless (eval-feature x) (return nil)))) ((eq (car x) 'or) (dolist (x (cdr x) nil) (when (eval-feature x) (return t)))) ((eq (car x) 'not) (not (eval-feature (cadr x)))) (t (error "~S is not a feature expression." x)))) (defun sharp-+-reader (stream subchar arg) (declare (ignore subchar arg)) (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) (read stream t nil t))) (values (read stream t nil t)) (let ((*read-suppress* t)) (read stream t nil t) (values)))) (set-dispatch-macro-character #\# #\+ 'sharp-+-reader) (set-dispatch-macro-character #\# #\+ 'sharp-+-reader (si::standard-readtable)) (defun sharp---reader (stream subchar arg) (declare (ignore subchar arg)) (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) (read stream t nil t))) (let ((*read-suppress* t)) (read stream t nil t) (values)) (values (read stream t nil t)))) (set-dispatch-macro-character #\# #\- 'sharp---reader) (set-dispatch-macro-character #\# #\- 'sharp---reader (si::standard-readtable)) gcl-2.6.14/lsp/gcl_desetq.lsp0000755000175000017500000000113414360276512014425 0ustar cammcamm (defun desetq-consp-check (val) (or (consp val) (error "~a is not a cons" val))) (defun desetq1 (form val) (cond ((symbolp form) (cond (form ;(push form *desetq-binds*) `(setf ,form ,val)))) ((consp form) `(progn (desetq-consp-check ,val) ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) gcl-2.6.14/lsp/gcl_namestring.lsp0000644000175000017500000000303714360276512015310 0ustar cammcamm(in-package :si) (defun namestring (x) (declare (optimize (safety 1))) (check-type x pathname-designator) (typecase x (string x) (pathname (c-pathname-namestring x)) (stream (namestring (c-stream-object1 x))))) (defun file-namestring (x &aux (px (pathname x))) (declare (optimize (safety 1))) (check-type x pathname-designator) (namestring (make-pathname :name (pathname-name px) :type (pathname-type px) :version (pathname-version px)))) (defun directory-namestring (x &aux (px (pathname x))) (declare (optimize (safety 1))) (check-type x pathname-designator) (namestring (make-pathname :directory (pathname-directory px)))) (defun host-namestring (x &aux (px (pathname x))) (declare (optimize (safety 1))) (check-type x pathname-designator) (or (pathname-host px) "")) #.`(defun enough-namestring (x &optional (def *default-pathname-defaults*) &aux (px (pathname x))(pdef (pathname def))) (declare (optimize (safety 1))) (check-type x pathname-designator) (check-type def pathname-designator) ,(labels ((new? (k &aux (f (intern (string-concatenate "PATHNAME-" (string k)) :si))) `(let ((k (,f px))) (unless (equal k (,f pdef)) k)))) `(namestring (make-pathname ,@(mapcan (lambda (x) (list x (new? x))) +pathname-keys+))))) (defun faslink (file name &aux (pfile (namestring (merge-pathnames (make-pathname :type "o") (pathname file))))(*package* *package*));FIXME (declare (optimize (safety 1))) (check-type file pathname-designator) (check-type name string) (faslink-int pfile name)) gcl-2.6.14/lsp/gcl_debug.lsp0000755000175000017500000005772714360276512014251 0ustar cammcamm;;Copyright William F. Schelter 1990, All Rights Reserved (In-package :si) (import '(sloop::sloop)) (eval-when (compile eval) (proclaim '(optimize (safety 2) (space 3))) (defmacro f (op &rest args) `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) (defmacro fb (op &rest args) `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) ) ;;; Some debugging features: ;;; Search-stack : ;;; (:s "cal") or (:s 'cal) searches the stack for a frame whose function or ;;; special form has a name containing "cal", moves there to display the local ;;; data. ;;; ;;; Break-locals : ;;; :bl displays the args and locals of the current function. ;;; (:bl 4) does this for 4 functions. ;;; ;;; (si:loc i) accesses the local(i): slot. ;;; the *print-level* and *print-depth* are bound to *debug-print-level* ;;; Note you must have space < 3 in your optimize proclamation, in order for ;;; the local variable names to be saved by the compiler. ;;; With BSD You may also use the function write-debug-symbols to ;;; obtain an object file with the correct symbol information for using a ;;; c debugger, on translated lisp code. You should have used the :debug ;;; t keyword when compiling the file. ;;; To Do: add setf method for si:loc. ;;; add restart capability from various spots on the stack. (defun show-break-variables (&optional (n 1)) (loop ;(break-current) (dolist (v (reverse(car *break-env*))) (format *debug-io* "~%~9a: ~s" (car v) (second v))) (or (fb > (incf n -1) 0) (return (values))) (break-previous) )) (defun show-environment (ihs) (let ((lis (vs (ihs-vs ihs)))) (if (listp lis) (dolist (v (reverse (vs (ihs-vs ihs)))) (format *debug-io* "~%~9a: ~s" (car v) (second v)))))) (putprop :a 'show-break-variables 'break-command) ;;make hack in compiler to remember the local variable names for the ;;vs variables and associate it with the function name (defun search-stack (sym &aux string) (setq string (cond((symbolp sym)(symbol-name sym)) (t sym))) (sloop for ihs downfrom (ihs-top) above 2 for fun = (ihs-fun ihs) with name do (cond ((compiled-function-p fun) (setq name (compiled-function-name fun))) ((symbolp fun ) (setq name fun)) ((and (listp fun) (member (car fun) '(lambda lambda-block))) (setq name (second fun))) (t (setq name '||))) when (search string (symbol-name name) :test 'equal) do (return (progn (break-go ihs)(terpri) (break-locals))) finally (format *debug-io* "~%Search for ~a failed" string) )) (defvar *debug-print-level* 3) (defun break-locals (&optional (n 1) &aux (ihs *current-ihs*) (base (ihs-vs ihs)) (*print-level* *debug-print-level*) *print-circle* (*print-length* *debug-print-level*) (current-ihs *current-ihs*) (fun (ihs-fun ihs)) name args) (cond ((fb > n 1) (sloop for i below n for ihs downfrom current-ihs above 2 do (let ((*current-ihs* ihs)) (break-locals) (terpri)(terpri) ))) (t (cond ((compiled-function-p fun) (setq name (compiled-function-name fun))) (t (setq name fun))) (if (symbolp name)(setq args (get name 'debugger))) (let ((next (ihs-vs (f + 1 *current-ihs*)))) (cond (next (format *debug-io* ">> ~a():" name) (cond ((symbolp name) (sloop for i from base below next for j from 0 for u = nil do (cond ((member 0 args);;old debug info. (setf u (getf args j))) (t (setf u (nth j args)))) (cond (u (format t "~%Local~a(~a): ~a" j u (vs i))) (t (format *debug-io* "~%Local(~d): ~a" j (vs i)))))) ((listp name) (show-environment ihs)) (t (format *debug-io* "~%Which case is this??"))))))))) (defun loc (&optional (n 0)) (let ((base (ihs-vs *current-ihs*))) (unless (and (fb >= n 0) (fb < n (f - (ihs-vs (min (ihs-top) (f + 1 *current-ihs*))) base))) (error "Not in current function")) (vs (f + n base)))) (putprop :bl 'break-locals 'break-command) (putprop :s 'search-stack 'break-command) (defvar *record-line-info* (make-hash-table :test 'eq)) (defvar *at-newline* nil) (defvar *standard-readtable* *readtable*) (defvar *line-info-readtable* (copy-readtable)) (defvar *left-parenthesis-reader* (get-macro-character #\( )) (defvar *quotation-reader* (get-macro-character #\" )) (defvar *stream-alist* nil) (defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t)) (defvar *step-next* nil) (defvar *last-dbl-break* nil) #-gcl (eval-when (compile eval load) (defvar *places* '(|*mv0*| |*mv1*| |*mv2*| |*mv3*| |*mv4*| |*mv5*| |*mv6*| |*mv7*| |*mv8*| |*mv9*|)) (defmacro set-mv (i val) `(setf ,(nth i *places*) ,val)) (defmacro mv-ref (i) (nth i *places*)) ) (defmacro mv-setq (lis form) `(prog1 (setf ,(car lis) ,form) ,@ (do ((v (cdr lis) (cdr v)) (i 0 (1+ i)) (res)) ((null v)(nreverse res)) (push `(setf ,(car v) (mv-ref ,i)) res)))) (defmacro mv-values (&rest lis) `(prog1 ,(car lis) ,@ (do ((v (cdr lis) (cdr v)) (i 0 (1+ i)) (res)) ((null v)(nreverse res)) (push `(set-mv ,i ,(car v)) res)))) ;;start a lisp debugger loop. Exit it by using :step (defun dbl () (break-level nil nil)) (defstruct instream stream (line 0 :type fixnum) stream-name) (eval-when (eval compile) (defstruct (bkpt (:type list)) form file file-line function) ) (defun cleanup () (dolist (v *stream-alist*) (if (closedp (instream-stream v)) (setq *stream-alist* (delete v *stream-alist*))))) (defun get-instream (str) (or (dolist (v *stream-alist*) (cond ((eq str (instream-stream v)) (return v)))) (car (setq *stream-alist* (cons (make-instream :stream str :stream-name (if (streamp str) (stream-name str)) ) *stream-alist*))))) (defun newline (str ch) ch (let ((in (get-instream str))) (setf (instream-line in) (the fixnum (f + 1 (instream-line in))))) ;; if the next line begins with '(', then record all cons's eg arglist ) (setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) (values)) (defun quotation-reader (str ch) (let ((tem (funcall *quotation-reader* str ch)) (instr (get-instream str))) (incf (instream-line instr) (count #\newline tem)) tem)) (defvar *old-semicolon-reader* (get-macro-character #\;)) (defun new-semi-colon-reader (str ch) (let ((in (get-instream str)) (next (peek-char nil str nil nil))) (setf (instream-line in) (the fixnum (f + 1 (instream-line in)))) (cond ((eql next #\!) (read-char str) (let* ((*readtable* *standard-readtable*) (command (read-from-string (read-line str nil nil)))) (cond ((and (consp command) (eq (car command) :line) (stringp (second command)) (typep (third command) 'fixnum)) (setf (instream-stream-name in) (second command)) (setf (instream-line in) (third command)))) )) (t (funcall *old-semicolon-reader* str ch))) (setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) (values))) (defun setup-lineinfo () (set-macro-character #\newline #'newline nil *line-info-readtable*) (set-macro-character #\; #'new-semi-colon-reader nil *line-info-readtable*) (set-macro-character #\( 'left-parenthesis-reader nil *line-info-readtable*) (set-macro-character #\" 'quotation-reader nil *line-info-readtable*) ) (defun nload (file &rest args ) (clrhash *record-line-info*) (cleanup) (setq file (truename file)) (setup-lineinfo) (let ((*readtable* *line-info-readtable*)) (apply 'load file args))) (eval-when (compile eval) (defmacro break-data (name line) `(cons ,name ,line)) ) (defun left-parenthesis-reader (str ch &aux line(flag *at-newline*)) (if (eq *at-newline* t) (setq *at-newline* nil)) (when flag (setq flag (get-instream str)) (setq line (instream-line flag)) ) (let ((tem (funcall *left-parenthesis-reader* str ch))) (when flag (setf (gethash tem *record-line-info*) (break-data (instream-name flag) line))) tem)) (defvar *fun-array* (make-array 50 :fill-pointer 0 :adjustable t)) (defun walk-through (body &aux tem) (tagbody top (cond ((consp body) (when (setq tem (gethash body *record-line-info*)) ;; lines beginning with ((< u v)..) ;; aren't eval'd but are part of a special form (cond ((and (consp (car body)) (not (eq (caar body) 'lambda))) (remhash body *record-line-info*) (setf (gethash (car body) *record-line-info*) tem)) (t (vector-push-extend (cons tem body) *fun-array*)))) (walk-through (car body)) (setq body (cdr body)) (go top)) (t nil)))) (defun compiler::compiler-def-hook (name body &aux (ar *fun-array*) (min most-positive-fixnum) (max -1)) (declare (fixnum min max)) ;; (cond ((and (boundp '*do-it*) ;; (eq (car body) 'lambda-block)) ;; (setf (cdr body) (cdr (walk-top body))))) (cond ((atom body) (remprop name 'line-info)) ((eq *readtable* *line-info-readtable*) (setf (fill-pointer *fun-array*) 0) (walk-through body) (dotimes (i (length ar)) (declare (fixnum i)) (let ((n (cdar (aref ar i)))) (declare (fixnum n)) (if (fb > n max) (setf max n)) (if (fb < n min) (setf min n)))) (cond ((fb > (length *fun-array*) 0) (let ((new (make-array (f + (f - max min) 2) :initial-element :blank-line)) (old-info (get name 'line-info))) (setf (aref new 0) (cons (caar (aref ar 0)) min)) (setq min (f - min 1)) (dotimes (i (length ar)) (let ((y (aref ar i))) (setf (aref new (f - (cdar y) min)) (cdr y)))) (setf (get name 'line-info) new) (when old-info (let ((tem (get name 'break-points)) (old-begin (cdr (aref old-info 0)))) (dolist (bptno tem) (let* ((bpt (aref *break-points* bptno)) (fun (bkpt-function bpt)) (li (f - (bkpt-file-line bpt) old-begin))) (setf (aref *break-points* bptno) (make-break-point fun new li)))))))) (t (let ((tem (get name 'break-points))) (iterate-over-bkpts tem :delete))))))) (defun instream-name (instr) (or (instream-stream-name instr) (stream-name (instream-stream instr)))) (eval-when (eval) (defun stream-name (str) (namestring (pathname str)))) (clines "object stream_name(str) object str;{ if (str->sm.sm_object1 != 0 && type_of(str->sm.sm_object1)==t_string) return str->sm.sm_object1; else return Cnil;}") (defentry stream-name (object) (object "stream_name")) (clines "object closedp(str) object str;{return (str->sm.sm_fp==0 ? Ct :Cnil);}") (defentry closedp (object) (object "closedp")) (defun find-line-in-fun (form env fun counter &aux tem) (setq tem (get fun 'line-info)) (if tem (let ((ar tem)) (declare (type (array (t)) ar)) (when ar (dotimes (i (length ar)) (cond ((eq form (aref ar i)) (when counter (decf (car counter)) (cond ((fb > (car counter) 0) ;silent (return-from find-line-in-fun :break)))) (break-level (setq *last-dbl-break* (make-break-point fun ar i)) env ) (return-from find-line-in-fun :break)))))))) ;; get the most recent function on the stack with step info. (defun current-step-fun ( &optional (ihs (ihs-top)) ) (do ((i (1- ihs) (f - i 1))) ((fb <= i 0)) (let ((na (ihs-fname i))) (if (get na 'line-info) (return na))))) (defun init-break-points () (setf (fill-pointer *break-point-vector*) 0) (setf *break-points* *break-point-vector*)) (defun step-into (&optional (n 1)) ;(defun step-into () (declare (ignore n)) ;;FORM is the next form about to be evaluated. (or *break-points* (init-break-points)) (setq *break-step* 'break-step-into) :resume) (defun step-next ( &optional (n 1)) (let ((fun (current-step-fun))) (setq *step-next* (cons n fun)) (or *break-points* (init-break-points)) (setq *break-step* 'break-step-next) :resume)) (defun maybe-break (form line-info fun env &aux pos) (cond ((setq pos (position form line-info)) (setq *break-step* nil) (or (> (length *break-points*) 0) (setf *break-points* nil)) (break-level (make-break-point fun line-info pos) env) t))) ;; These following functions, when they are the value of *break-step* ;; are invoked by an inner hook in eval. They may choose to stop ;; things. (defun break-step-into (form env) (let ((fun (current-step-fun))) (let ((line-info (get fun 'line-info))) (maybe-break form line-info fun env)))) (defun break-step-next (form env) (let ((fun (current-step-fun))) (cond ((eql (cdr *step-next*) fun) (let ((line-info (get fun 'line-info))) (maybe-break form line-info fun env)))))) (setf (get :next 'break-command) 'step-next) (setf (get :step 'break-command) 'step-into) (setf (get :loc 'break-command) 'loc) (defun *break-points* (form env) (let ((pos(position form *break-points* :key 'car))) (format t "Bkpt ~a:" pos) (break-level (aref *break-points* pos) env))) (defun dwim (fun) (dolist (v (list-all-packages)) (multiple-value-bind (sym there) (intern (symbol-name fun) v) (cond ((get sym 'line-info) (return-from dwim sym)) (t (or there (unintern sym)))))) (format t "~a has no line information" fun)) (defun break-function (fun &optional (li 1) absolute &aux fun1) (let ((ar (get fun 'line-info))) (when (null ar) (setq fun1 (dwim fun)) (if fun1 (return-from break-function (break-function fun1 li absolute)))) (or (arrayp ar)(progn (format t "~%No line info for ~a" fun) (return-from break-function nil))) (let ((beg (cdr (aref ar 0)))) (if absolute (setq li (f - li beg))) (or (and (fb >= li 1) (fb < li (length ar))) (progn (format t "~%line out of bounds for ~a" fun)) (return-from break-function nil)) (if (eql li 1) (let ((tem (symbol-function fun))) (cond ((and (consp tem) (eq (car tem) 'lambda-block) (third tem)) (setq li 2))))) (dotimes (i (f - (length ar) li)) (when (not (eq (aref ar i) :blank-line)) (show-break-point (insert-break-point (make-break-point fun ar (f + li i)))) (return-from break-function (values)))) (format t "~%Beyond code for ~a ")))) (defun insert-break-point (bpt &aux at) (or *break-points* (init-break-points)) (setq at (or (position nil *break-points*) (prog1 (length *break-points*) (vector-push-extend nil *break-points*) ))) (let ((fun (bkpt-function bpt))) (push at (get fun 'break-points))) (setf (aref *break-points* at) bpt) at) (defun short-name (name) (let ((Pos (position #\/ name :from-end t))) (if pos (subseq name (f + 1 pos)) name))) (defun show-break-point (n &aux disabled) (let ((bpt (aref *break-points* n))) (when bpt (when (eq (car bpt) nil) (setq disabled t) (setq bpt (cdr bpt))) (format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]" n (short-name (second bpt)) (third bpt) disabled) (let ((fun (fourth bpt))) (format t "(line ~a of ~a)" (relative-line fun (nth 2 bpt)) fun ))))) (defun iterate-over-bkpts (l action) (dotimes (i (length *break-points*)) (if (or (member i l) (null l)) (let ((tem (aref *break-points* i))) (setf (aref *break-points* i) (case action (:delete (if tem (setf (get (bkpt-function tem) 'break-points) (delete i (get (bkpt-function tem) 'break-points)))) nil) (:enable (if (eq (car tem) nil) (cdr tem) nil)) (:disable (if (and tem (not (eq (car tem) nil))) (cons nil tem) tem)) (:show (when tem (show-break-point i) (terpri)) tem ))))))) (setf (get :info 'break-command) '(lambda (type) (case type (:bkpt (iterate-over-bkpts nil :show)) (otherwise (format t "usage: :info :bkpt -- show breakpoints") )))) (defun complete-prop (sym package prop &optional return-list) (cond ((and (symbolp sym)(get sym prop)(equal (symbol-package sym) (find-package package))) (return-from complete-prop sym))) (sloop for v in-package package when (and (get v prop) (eql (string-match sym v) 0)) collect v into all finally (cond (return-list (return-from complete-prop all)) ((> (length all) 1) (format t "~&Not unique with property ~(~a: ~{~s~^, ~}~)." prop all)) ((null all) (format t "~& ~a is not break command" sym)) (t (return-from complete-prop (car all)))))) (setf (get :delete 'break-command) '(lambda (&rest l) (iterate-over-bkpts l :delete)(values))) (setf (get :disable 'break-command) '(lambda (&rest l) (iterate-over-bkpts l :disable)(values))) (setf (get :enable 'break-command) '(lambda (&rest l) (iterate-over-bkpts l :enable)(values))) (setf (get :break 'break-command) '(lambda (&rest l) (print l) (cond (l (apply 'si::break-function l)) (*last-dbl-break* (let ((fun (nth 3 *last-dbl-break*))) (si::break-function fun (nth 2 *last-dbl-break*) t)))))) (setf (get :fr 'break-command) '(lambda (&rest l ) (dbl-up (or (car l) 0) *ihs-top*) (values))) (setf (get :up 'break-command) '(lambda (&rest l ) (dbl-up (or (car l) 1) *current-ihs*) (values))) (setf (get :down 'break-command) '(lambda (&rest l ) (dbl-up ( - (or (car l) 1)) *current-ihs*) (values))) ;; in other common lisps this should be a string output stream. (defvar *display-string* (make-array 100 :element-type 'character :fill-pointer 0 :adjustable t)) (defun display-env (n env) (do ((v (reverse env) (cdr v))) ((or (not (consp v)) (fb > (fill-pointer *display-string*) n))) (or (and (consp (car v)) (listp (cdar v))) (return)) (format *display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))) (defun apply-display-fun (display-fun n lis) (let ((*print-length* *debug-print-level*) (*print-level* *debug-print-level*) (*print-pretty* nil) (*PRINT-CASE* :downcase) (*print-circle* t) ) (setf (fill-pointer *display-string*) 0) (format *display-string* "{") (funcall display-fun n lis) (when (fb > (fill-pointer *display-string*) n) (setf (fill-pointer *display-string*) n) (format *display-string* "...")) (format *display-string* "}") ) *display-string* ) (setf (get :bt 'break-command) 'dbl-backtrace) (setf (get '*break-points* 'dbl-invisible) t) (defun get-line-of-form (form line-info) (let ((pos (position form line-info))) (if pos (f + pos (cdr (aref line-info 0)))))) (defun get-next-visible-fun (ihs) (do ((j ihs (f - j 1))) ((fb < j *ihs-base*) (mv-values nil j)) (let ((na (ihs-fname j))) (cond ((special-operator-p na)) ((get na 'dbl-invisible)) ((fboundp na)(return (mv-values na j))))))) (defun dbl-what-frame (ihs &aux (j *ihs-top*) (i 0) na) (declare (fixnum ihs j i)) (loop (mv-setq (na j) (get-next-visible-fun j)) (cond ((fb <= j ihs) (return i))) (setq i (f + i 1)) (setq j (f - j 1)))) (defun dbl-up (n ihs &aux m fun line file env ) (setq m (dbl-what-frame ihs)) (cond ((fb >= n 0) (mv-setq (*current-ihs* n fun line file env) (nth-stack-frame n ihs)) (set-env) (print-stack-frame (f + m n) t *current-ihs* fun line file env)) (t (setq n (f + m n)) (or (fb >= n 0) (setq n 0)) (dbl-up n *ihs-top*)))) (dolist (v '( break-level universal-error-handler terminal-interrupt break-level evalhook find-line-in-fun)) (setf (get v 'dbl-invisible) t)) (defun next-stack-frame (ihs &aux line-info li i k na) (cond ((fb < ihs *ihs-base*) (mv-values nil nil nil nil nil )) (t (let (fun) ;; next lower visible ihs (mv-setq (fun i) (get-next-visible-fun ihs)) (setq na fun) (cond ((and (setq line-info (get fun 'line-info)) (do ((j (f + ihs 1) (f - j 1)) (form )) ((<= j i) nil) (setq form (ihs-fun j)) (cond ((setq li (get-line-of-form (ihs-fun j) line-info)) (return-from next-stack-frame (mv-values i fun li ;; filename (car (aref line-info 0)) ;;environment (list (vs (setq k (ihs-vs j))) (vs (1+ k)) (vs (+ k 2))) ))))))) ((special-operator-p na) nil) ((get na 'dbl-invisible)) ((fboundp na) (mv-values i na nil nil (if (ihs-not-interpreted-env i) nil (let ((i (ihs-vs i))) (list (vs i) (vs (1+ i)) (vs (f + i 2)))))))) )))) (defun nth-stack-frame (n &optional (ihs *ihs-top*) &aux name line file env next) (or (fb >= n 0) (setq n 0)) (dotimes (i (f + n 1)) (setq next (next-stack-frame ihs)) (cond (next (mv-setq (ihs name line file env) next) (setq ihs (f - next 1))) (t (return (setq n (f - i 1)))))) (setq ihs (f + ihs 1) name (ihs-fname ihs)) (mv-values ihs n name line file env )) (defun dbl-backtrace (&optional (m 1000) (ihs *ihs-top*) &aux fun file line env (i 0)) (loop (mv-setq (ihs fun line file env) (next-stack-frame ihs)) (or (and ihs fun) (return nil)) (print-stack-frame i nil ihs fun line file env) (incf i) (cond ((fb >= i m) (return (values)))) (setq ihs (f - ihs 1)) ) (values)) (defun display-compiled-env ( plength ihs &aux (base (ihs-vs ihs)) (end (min (ihs-vs (1+ ihs)) (vs-top)))) (format *display-string* "") (do ((i base ) (v (get (ihs-fname ihs) 'debugger) (cdr v))) ((or (fb >= i end)(fb > (fill-pointer *display-string*) plength))) (format *display-string* "~a~@[~d~]=~s~@[,~]" (or (car v) 'loc) (if (not (car v)) (f - i base)) (vs i) (fb < (setq i (f + i 1)) end))) ) (defun computing-args-p (ihs) ;; When running interpreted we want a line like ;; (list joe jane) to get recorded in the invocation ;; history while joe and jane are being evaluated, ;; even though list has not yet been invoked. We put ;; it in the history, but with the previous lexical environment. (and (consp (ihs-fun ihs)) (> ihs 3) (not (member (car (ihs-fun ihs)) '(lambda-block lambda))) ;(<= (ihs-vs ihs) (ihs-vs (- ihs 1))) ) ) (defun print-stack-frame (i auto-display ihs fun &optional line file env) (declare (ignore env)) (when (and auto-display line) (format *debug-io* "~a:~a:0:beg~%" file line)) (let ((computing-args (computing-args-p ihs))) (format *debug-io* "~&#~d ~@[~a~] ~a ~@[~a~] " i (and computing-args "Computing args for ") fun (if (not (ihs-not-interpreted-env ihs)) (apply-display-fun 'display-env 80 (car (vs (ihs-vs ihs)))) (apply-display-fun 'display-compiled-env 80 ihs))) (if file (format *debug-io* "(~a line ~a)" file line)) (format *debug-io* "[ihs=~a]" ihs) )) (defun make-break-point (fun ar i) (list ;make-bkpt ;:form (aref ar i) ;:file (car (aref ar 0)) ;:file-line (f + (cdr (aref ar 0)) i) ;:function fun) ) (defun relative-line (fun l) (let ((info (get fun 'line-info))) (if info (f - l (cdr (aref info 0))) 0))) (defvar *step-display* nil) (defvar *null-io* (make-broadcast-stream)) ;; should really use serror to evaluate this inside. ;; rather than just quietening it. It prints a long stack ;; which is time consuming. (defun safe-eval (form env &aux *break-enable*) (let ((*error-output* *null-io*) (*debug-io* *null-io*)) (cond ((symbolp form) (unless (or (boundp form) (assoc form (car env))) (return-from safe-eval :)))) (multiple-value-bind (er val) (si::error-set `(evalhook ',form nil nil ',env)) (if er : val)))) (defvar *no-prompt* nil) (defun set-back (at env &aux (i *current-ihs*)) (setq *no-prompt* nil) (setq *current-ihs* i) (cond (env (setq *break-env* env)) (t (list (vs (ihs-vs i))))) (when (consp at) (format *debug-io* "~a:~a:0:beg~%" (second at) (third at)) (format *debug-io* "(~a line ~a) " (second at) (third at)) ) (dolist (v *step-display*) (let ((res (safe-eval v env))) (or (eq res :) (format t "(~s=~s)" v res))))) (eval-when (load eval) (pushnew :sdebug *features* ) ;(use-fast-links nil) ) gcl-2.6.14/lsp/gcl_restart.lsp0000644000175000017500000001640214360276512014625 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package :si) (defvar *restarts* nil) (defvar *restart-condition* nil) (defmacro restart-bind (bindings &body forms) (declare (optimize (safety 2))) `(let ((*restarts* (list* ,@(mapcar (lambda (x) `(cons (make-restart :name ',(pop x) :function ,(pop x) ,@x) *restart-condition*)) bindings) *restarts*))) ,@forms)) (defmacro with-condition-restarts (condition-form restarts-form &body body) (declare (optimize (safety 1))) (let ((n-cond (gensym))) `(let* ((,n-cond ,condition-form) (*restarts* (nconc (mapcar (lambda (x) (cons x ,n-cond)) ,restarts-form) *restarts*))) ,@body))) (defun condition-pass (condition restart &aux b (f (restart-test-function restart))) (when (if f (funcall f condition) t) (mapc (lambda (x) (when (eq (pop x) restart) (if (if condition (eq x condition) t) (return-from condition-pass t) (setq b (or b x))))) *restarts*) (not b))) (defvar *kcl-top-restarts* nil) (defun make-kcl-top-restart (quit-tag) (make-restart :name 'gcl-top-restart :function (lambda () (throw (car (list quit-tag)) quit-tag)) :report-function (lambda (stream) (let ((b-l (if (eq quit-tag si::*quit-tag*) si::*break-level* (car (or (find quit-tag si::*quit-tags* :key #'cdr) '(:not-found)))))) (cond ((eq b-l :not-found) (format stream "Return to ? level.")) ((null b-l) (format stream "Return to top level.")) (t (format stream "Return to break level ~D." (length b-l)))))))) (defun find-kcl-top-restart (quit-tag) (cdr (or (assoc quit-tag *kcl-top-restarts*) (car (push (cons quit-tag (make-kcl-top-restart quit-tag)) *kcl-top-restarts*))))) (defun kcl-top-restarts () (let* (;(old-tags (ldiff si::*quit-tags* (member nil si::*quit-tags* :key 'cdr))) (old-tags si::*quit-tags*) (old-tags (mapcan (lambda (e) (when (cdr e) (list (cdr e)))) old-tags)) (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags)) (restarts (mapcar 'find-kcl-top-restart tags))) (setq *kcl-top-restarts* (mapcar 'cons tags restarts)) restarts)) (defun compute-restarts (&optional condition) (remove-if-not (lambda (x) (condition-pass condition x)) (remove-duplicates (nconc (mapcar 'car *restarts*) (kcl-top-restarts))))) (defun find-restart (name &optional condition &aux (sn (symbolp name))) (car (member name (compute-restarts condition) :key (lambda (x) (if sn (restart-name x) x))))) (defun transform-keywords (&key report interactive test &aux rr (report (if (stringp report) `(lambda (s) (write-string ,report s)) report))) (macrolet ((do-setf (x) `(when ,x (setf (getf rr ,(intern (string-concatenate (symbol-name x) "-FUNCTION") :keyword)) (list 'function ,x))))) (do-setf report) (do-setf interactive) (do-setf test) rr)) (defun rewrite-restart-case-clause (r &aux (name (pop r))(ll (pop r))) (labels ((l (r) (if (member (car r) '(:report :interactive :test)) (l (cddr r)) r))) (let ((rd (l r))) (list* name (gensym) (apply 'transform-keywords (ldiff r rd)) ll rd)))) (defun restart-case-expression-condition (expression env c &aux (e (macroexpand expression env))(n (when (listp e) (pop e)))) (case n (cerror (let ((ca (pop e))) `((process-error ,(pop e) (list ,@e)) (,n ,ca ,c)))) (error `((process-error ,(pop e) (list ,@e)) (,n ,c))) (warn `((process-error ,(pop e) (list ,@e) 'simple-warning) (,n ,c))) (signal `((coerce-to-condition ,(pop e) (list ,@e) 'simple-condition ',n) (,n ,c))))) (defmacro restart-case (expression &body clauses &environment env) (declare (optimize (safety 2))) (let* ((block-tag (gensym))(args (gensym))(c (gensym)) (data (mapcar 'rewrite-restart-case-clause clauses)) (e (restart-case-expression-condition expression env c))) `(block ,block-tag (let* (,args (,c ,(car e)) (*restart-condition* ,c)) (tagbody (restart-bind ,(mapcar (lambda (x) `(,(pop x) (lambda (&rest r) (setq ,args r) (go ,(pop x))) ,@(pop x))) data) (return-from ,block-tag ,(or (cadr e) expression))) ,@(mapcan (lambda (x &aux (x (cdr x))) `(,(pop x) (return-from ,block-tag (apply (lambda ,(progn (pop x)(pop x)) ,@x) ,args)))) data)))))) (defvar *unique-id-table* (make-hash-table)) (defvar *unique-id-count* -1) (defun unique-id (obj) "generates a unique integer id for its argument." (or (gethash obj *unique-id-table*) (setf (gethash obj *unique-id-table*) (incf *unique-id-count*)))) (defun restart-print (restart stream depth) (declare (ignore depth)) (if *print-escape* (format stream "#<~s.~d>" (type-of restart) (unique-id restart)) (restart-report restart stream))) (defstruct (restart (:print-function restart-print)) name function report-function interactive-function (test-function (lambda (c) (declare (ignore c)) t))) (defun restart-report (restart stream &aux (f (restart-report-function restart))) (if f (funcall f stream) (format stream "~s" (or (restart-name restart) restart)))) (defun invoke-restart (restart &rest values) (let ((real-restart (or (find-restart restart) (error 'control-error :format-control "restart ~s is not active." :format-arguments (list restart))))) (apply (restart-function real-restart) values))) (defun invoke-restart-interactively (restart) (let ((real-restart (or (find-restart restart) (error "restart ~s is not active." restart)))) (apply (restart-function real-restart) (let ((interactive-function (restart-interactive-function real-restart))) (when interactive-function (funcall interactive-function)))))) (defmacro with-simple-restart ((restart-name format-control &rest format-arguments) &body forms) (declare (optimize (safety 1))) `(restart-case (progn ,@forms) (,restart-name nil :report (lambda (stream) (format stream ,format-control ,@format-arguments)) (values nil t)))) (defun abort (&optional condition) "Transfers control to a restart named abort, signalling a control-error if none exists." (invoke-restart (find-restart 'abort condition)) (error 'abort-failure)) (defun muffle-warning (&optional condition) "Transfers control to a restart named muffle-warning, signalling a control-error if none exists." (invoke-restart (find-restart 'muffle-warning condition))) (macrolet ((define-nil-returning-restart (name args doc) (let ((restart (gensym))) `(defun ,name (,@args &optional condition) ,doc (declare (optimize (safety 1))) (let ((,restart (find-restart ',name condition))) (when ,restart (invoke-restart ,restart ,@args))))))) (define-nil-returning-restart continue nil "Transfer control to a restart named continue, returning nil if none exists.") (define-nil-returning-restart store-value (value) "Transfer control and value to a restart named store-value, returning nil if none exists.") (define-nil-returning-restart use-value (value) "Transfer control and value to a restart named use-value, returning nil if none exists.")) (defun show-restarts (&aux (i 0)) (mapc (lambda (x) (format t "~& ~4d ~a ~a ~%" (incf i) (cond ((eq x *debug-abort*) "(abort)") ((eq x *debug-continue*) "(continue)") ("")) x)) *debug-restarts*) nil) gcl-2.6.14/lsp/gcl_loadcmp.lsp0000755000175000017500000000236214360276512014563 0ustar cammcamm(in-package 'compiler) (format t "~%Loading the whole compiler...") (let ((sysd (concatenate 'string si::*system-directory* "../cmpnew/"))) (load (merge-pathnames (concatenate 'string si::*system-directory* "../lsp/defstruct"))) (dolist (v '( "cmpinline" "cmputil" "cmptype" "cmpbind" "cmpblock" "cmpcall" "cmpcatch" "cmpenv" "cmpeval" "cmpflet" "cmpfun" "cmpif" "cmplabel" "cmplam" "cmplet" "cmploc" ; "cmpmain" "cmpmap" "cmpmulti" "cmpspecial" "cmptag" "cmptop" "cmpvar" "cmpvs" "cmpwt" )) (load (merge-pathnames v sysd))) (load (merge-pathnames "cmpmain.lsp" sysd))) (defun compile-file (&rest system::args &aux (*print-pretty* nil) (*package* *package*)) (compiler::init-env) (apply 'compiler::compile-file1 system::args)) (defun compile (&rest system::args &aux (*print-pretty* nil)) (apply 'compiler::compile1 system::args)) (defun disassemble (&rest system::args &aux (*print-pretty* nil)) (apply 'compiler::disassemble1 system::args)) (setf (symbol-function 'si:clear-compiler-properties) (symbol-function 'compiler::compiler-clear-compiler-properties)) gcl-2.6.14/lsp/gcl_fdecl.lsp0000755000175000017500000000575314360276512014230 0ustar cammcamm(in-package 'si) ;; by William F. Schelter ;; Conveniently and economically make operators which declare the type ;; and result of numerical operations. For example (def-op f+ fixnum +) ;; defines a macro f+ which will give optimal code for calling + on ;; several fixnum args expecting a fixnum result. ;; Details: ;; Note these will be macros and cannot be `funcalled'. If you add the ;; feature :debug, then code to check the types of the arguments and ;; result will be inserted, and generic operations will be used. This is ;; useful for checking that you did not insert the wrong type ;; declarations. The code will continue running if *dbreak* is nil, ;; returning the correct result but printing out the type mismatch, as ;; well as the actual args given so that you may more easily locate the ;; bad call in the editor. ;; It is economical, beause all the macros defined are just variations ;; of one closure, and so code is not duplicated. ;; Sample usage (with :debug in *features*): ;; The call will generate warning messages if the args or result are bad. ;; (defun foo (x a) (f+ (* 2 x) a)) ;; SYSTEM>(foo 7.0 9) ;; Bad call (F+ (* 2 X) A) types:(LONG-FLOAT FIXNUM) ;; 23.0 ;; Without debug (f+ a b c) becomes ;; (the fixnum (+ (the fixnum a) (the fixnum ;; (+ (the fixnum b) (the fixnum c))))) ;; which is painful to write by hand, but which will give the best code. (defmacro def-op (name type op &optional return-type) `(setf (macro-function ',name) (make-operation ',type ',op ',return-type))) (defun make-operation (.type .op .return) (or .return (setf .return .type)) #'(lambda (bod env) env (sloop for v in (cdr bod) when (eq t .type) collect v into body else collect `(the , .type ,v) into body finally (setq body `(, .op ,@ body)) (return (if (eq t .return) body `(the , .return ,body)))))) #+debug (progn ;; Enable this to insert type error checking code. (defvar *dbreak* t) (defun callchk-type (lis old na typ sho return-type &aux result) (setq result (apply old lis)) (or (and (sloop for v in lis always (typep v typ)) (or (null return-type) (typep result return-type))) (format t "~%Bad call ~a types:~a" (cons na sho) (sloop:sloop for v in lis collect (type-of v))) (and *dbreak* (break "hi"))) result) ;; debug version: (defmacro def-op (name type old &optional return-type) `(defmacro ,name (&rest l) `(callchk-type (list ,@ l) ',',old ',',name ',',type ',l ',',return-type ))) ) (def-op f+ fixnum +) (def-op f* fixnum *) (def-op f- fixnum -) (def-op +$ double-float +) (def-op *$ double-float *) (def-op -$ double-float -) (def-op 1-$ double-float 1-) (def-op 1+$ double-float 1+) (def-op f1- fixnum 1-) (def-op f1+ fixnum 1+) (def-op //$ double-float quot) (def-op ^ fixnum expt) (def-op ^$ double-float expt) (def-op f> fixnum > t) (def-op f< fixnum < t) (def-op f= fixnum = t) (def-op lsh fixnum ash) (def-op fixnum-remainder fixnum rem) gcl-2.6.14/lsp/gcl_seqlib.lsp0000755000175000017500000007235614360276512014435 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; seqlib.lsp ;;;; ;;;; sequence routines (in-package :si) ;(proclaim '(optimize (safety 2) (space 3))) (proclaim '(function seqtype (t) t)) (defun seqtype (sequence) (cond ((listp sequence) 'list) ((stringp sequence) 'string) ((bit-vector-p sequence) 'bit-vector) ((vectorp sequence) (list 'array (array-element-type sequence))) (t (error "~S is not a sequence." sequence)))) (proclaim '(function call-test (t t t t) t)) (defun call-test (test test-not item keyx) (cond (test (funcall test item keyx)) (test-not (not (funcall test-not item keyx))) (t (eql item keyx)))) (proclaim '(function check-seq-start-end (t t) t)) (defun check-seq-start-end (start end) (unless (and (si:fixnump start) (si:fixnump end)) (error "Fixnum expected.")) (when (> (the fixnum start) (the fixnum end)) (error "START is greater than END."))) (proclaim '(function test-error() t)) (defun test-error() (error "both test and test not supplied")) (defun bad-seq-limit (x &optional y) (error 'type-error :datum (if y (list x y) x) :expected-type 'sequence-limit));FIXME (eval-when (compile eval) (proclaim '(function the-start (t) fixnum)) (proclaim '(function the-end (t t) fixnum)) (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) (defmacro f- (x y) `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) (defmacro with-start-end ( start end seq &body body) `(let ((,start (if ,start (the-start ,start) 0))) (declare (fixnum ,start)) (let ((,end (the-end ,end ,seq))) (declare (fixnum ,end)) (or (<= ,start ,end) (bad-seq-limit ,start ,end)) ,@ body))) ) (defun the-end (x y) (cond ((fixnump x) (or (<= (the fixnum x) (the fixnum (length y))) (bad-seq-limit x)) x) ((null x) (length y)) (t (bad-seq-limit x)))) (defun the-start (x) (cond ((fixnump x) (or (>= (the fixnum x) 0) (bad-seq-limit x)) (the fixnum x)) ((null x) 0) (t (bad-seq-limit x)))) (defun reduce (function sequence &key from-end start end (initial-value nil ivsp) (key #'identity)) (with-start-end start end sequence (cond ((not from-end) (when (null ivsp) (when (>= start end) (return-from reduce (funcall function))) (setq initial-value (funcall key (elt sequence start))) (setf start (f+ 1 start)) ) (do ((x initial-value (funcall function x (funcall key (prog1 (elt sequence start) (setf start (f+ 1 start)) ))))) ((>= start end) x))) (t (when (null ivsp) (when (>= start end) (return-from reduce (funcall function))) (setf end (f+ end -1)) (setq initial-value (funcall key (elt sequence end))) ) (do ((x initial-value (funcall function (funcall key (elt sequence end)) x))) ((>= start end) x) (setf end (f+ -1 end))))))) (defun fill (sequence item &key start end ) (with-start-end start end sequence (do ((i start (f+ 1 i))) ((>= i end) sequence) (declare (fixnum i)) (setf (elt sequence i) item)))) (defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3) (declare (optimize (safety 1))(:dynamic-extent s3)) (when (and (eq s1 s2) (> start1 start2)) (setq s3 (make-list (length s2)) s2 (replace s3 s2))) (let* ((lp1 (listp s1)) (lp2 (listp s2))(start1 start1)(start2 start2) (e1 (or end1 (if lp1 array-dimension-limit (length s1)))) (e2 (or end2 (if lp2 array-dimension-limit (length s2))))) (declare (fixnum start1 start2 e1 e2)) (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2)) (s1 (if (when lp1 (> start1 0)) (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1)) (s2 (if (when lp2 (> start2 0)) (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2))) ((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1) (declare (fixnum i1 i2)) (let ((e2 (if lp2 (car s2) (aref s2 i2)))) (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2)))))) ;; (defun replace (sequence1 sequence2 ;; &key start1 end1 ;; start2 end2 ) ;; (with-start-end start1 end1 sequence1 ;; (with-start-end start2 end2 sequence2 ;; (if (and (eq sequence1 sequence2) ;; (> start1 start2)) ;; (do* ((i 0 (f+ 1 i)) ;; (l (if (< (f- end1 start1) ;; (f- end2 start2)) ;; (f- end1 start1) ;; (f- end2 start2))) ;; (s1 (f+ start1 (f+ -1 l)) (f+ -1 s1)) ;; (s2 (f+ start2 (f+ -1 l)) (f+ -1 s2))) ;; ((>= i l) sequence1) ;; (declare (fixnum i l s1 s2)) ;; (setf (elt sequence1 s1) (elt sequence2 s2))) ;; (do ((i 0 (f+ 1 i)) ;; (l (if (< (f- end1 start1) ;; (f- end2 start2)) ;; (f- end1 start1) ;; (f- end2 start2))) ;; (s1 start1 (f+ 1 s1)) ;; (s2 start2 (f+ 1 s2))) ;; ((>= i l) sequence1) ;; (declare (fixnum i l s1 s2)) ;; (setf (elt sequence1 s1) (elt sequence2 s2))))))) ;;; DEFSEQ macro. ;;; Usage: ;;; ;;; (DEFSEQ function-name argument-list countp everywherep body) ;;; ;;; The arguments ITEM and SEQUENCE (PREDICATE and SEQUENCE) ;;; and the keyword arguments are automatically supplied. ;;; If the function has the :COUNT argument, set COUNTP T. (eval-when (eval compile) (defmacro defseq (f args countp everywherep body &aux (*macroexpand-hook* 'funcall)) (setq *body* body) (list 'progn (let* ((from-end nil) (iterate-i '(i start (f+ 1 i))) (iterate-i-from-end '(i (f+ -1 end) (f+ -1 i))) (endp-i '(>= i end)) (endp-i-from-end '(< i start)) (iterate-i-everywhere '(i 0 (f+ 1 i))) (iterate-i-everywhere-from-end '(i (f+ -1 l) (f+ -1 i))) (endp-i-everywhere '(>= i l)) (endp-i-everywhere-from-end '(< i 0)) (i-in-range '(and (<= start i) (< i end))) (x '(elt sequence i)) (keyx `(funcall key ,x)) (satisfies-the-test `(call-test test test-not item ,keyx)) (number-satisfied `(n (internal-count item sequence :from-end from-end :test test :test-not test-not :start start :end end ,@(if countp '(:count count)) :key key))) (within-count '(< k count)) (kount-0 '(k 0)) (kount-up '(setq k (f+ 1 k)))) `(defun ,f (,@args item sequence &key from-end test test-not start end ,@(if countp '(count)) (key #'identity) ,@(if everywherep (list '&aux '(l (length sequence))) nil)) ,@(if everywherep '((declare (fixnum l)))) (if (eq key nil) (setq key #'identity)) (with-start-end start end sequence (let ,@(if countp '(((count (cond ((null count) most-positive-fixnum) ((< count 0) 0) ((> count most-positive-fixnum) most-positive-fixnum) (t count)))))) ,@(if countp '((declare (fixnum count)))) nil (and test test-not (test-error)) (if (not from-end) ,(eval-body) ,(progn (setq from-end t iterate-i iterate-i-from-end endp-i endp-i-from-end iterate-i-everywhere iterate-i-everywhere-from-end endp-i-everywhere endp-i-everywhere-from-end) (eval-body))))))) `(defun ,(intern (si:string-concatenate (string f) "-IF") (symbol-package f)) (,@args predicate sequence &key from-end start end ,@(if countp '(count)) (key #'identity)) (if (eq key nil) (setq key #'identity)) (,f ,@args predicate sequence :from-end from-end :test #'funcall :start start :end end ,@(if countp '(:count count)) :key key)) `(defun ,(intern (si:string-concatenate (string f) "-IF-NOT") (symbol-package f)) (,@args predicate sequence &key from-end start end ,@(if countp '(count)) (key #'identity)) (if (eq key nil) (setq key #'identity)) (,f ,@args predicate sequence :from-end from-end :test-not #'funcall :start start :end end ,@(if countp '(:count count)) :key key)) (list 'quote f))) (defmacro eval-body () *body*) (defmacro mcf (x) `(when ,x (coerce ,x 'function))) (deftype function-designator nil `(or (and symbol (not boolean)) function)) (defmacro rcollect (r rp form) `(let ((tmp ,form)) (setq ,rp (last (if ,rp (rplacd ,rp tmp) (setq ,r tmp)))))) (defmacro dcollect (r rp form) `(let ((tmp ,form)) (declare (dynamic-extent tmp)) (setq ,rp (cond (,rp (rplacd ,rp tmp) tmp) ((setq ,r tmp)))))) ) (defun remove (item sequence &key key test test-not from-end count (start 0) end &aux (kf (mcf key))(tf (mcf test))(tnf (mcf test-not)) r rp q qp xz (from-end (when count from-end)) (l (listp sequence))(ln (if l array-dimension-limit (length sequence))) (e (if end (min ln (max 0 end)) ln)) (c (if count (min ln (max 0 count)) ln))) (declare (optimize (safety 1))(dynamic-extent q)(fixnum c e)) (check-type sequence sequence) (check-type start seqind) (check-type end (or null seqind)) (check-type count (or null integer)) (check-type key (or null function-designator)) (check-type test (or null function-designator)) (check-type test-not (or null function-designator)) (cond ((unless from-end l) (do ((i start (1+ i))(j 0)(s (if (zerop start) sequence (nthcdr start sequence)) (cdr s))) ((or (endp s) (>= i e) (>= j c)) (rcollect r rp sequence) r) (declare (fixnum i j)) (let* ((x (car s))(kx (if kf (funcall kf x) x))) (when (cond (tf (funcall tf item kx))(tnf (not (funcall tnf item kx)))((eql item kx))) (do nil ((eq sequence s) (setq sequence (cdr sequence))) (rcollect r rp (cons (pop sequence) nil))) (incf j))))) (t (do* ((j 0 (1+ j))) ((not (when (< j c) (setq xz (position item sequence :start (if (unless from-end xz) (1+ xz) start) :end (if (when from-end xz) xz end) :key kf :test tf :test-not tnf :from-end from-end))))) (declare (fixnum j)) (if from-end (push xz q) (dcollect q qp (cons xz nil)))) ; (print q) (cond ((not q) sequence) (l (do* ((lq -1 (car q))(q q (cdr q))(v sequence (cdr v)))((not q) (rcollect r rp v) r) (declare (fixnum lq)) (dotimes (i (the fixnum (- (car q) lq 1))) (declare (fixnum i))(rcollect r rp (cons (pop v) nil))))) ((let ((r (make-array (- (length sequence) (length q)) :element-type (array-element-type sequence)))) (do* ((j 0 (+ j (- (car q) lq 1)))(lq -1 (car q))(q q (cdr q))) ((when (replace r sequence :start1 j :start2 (1+ lq) :end2 (car q)) (not q)) r))))))) ) (defun remove-if (p s &key key from-end count (start 0) end &aux (kf (mcf key))) (declare (optimize (safety 1))) (check-type p function-designator) (check-type s sequence) (check-type start seqind) (check-type end (or null seqind)) (check-type count (or null integer)) (check-type key (or null function-designator)) (remove p s :key kf :test #'funcall :start start :end end :count count :from-end from-end)) (defun remove-if-not (p s &key key from-end count (start 0) end &aux (kf (mcf key))) (declare (optimize (safety 1))) (check-type p function-designator) (check-type s sequence) (check-type start seqind) (check-type end (or null seqind)) (check-type count (or null integer)) (check-type key (or null function-designator)) (remove p s :key kf :test-not #'funcall :start start :end end :count count :from-end from-end)) (defseq delete () t t (if (not from-end) `(if (listp sequence) (let* ((l0 (cons nil sequence)) (l l0)) (do ((i 0 (f+ 1 i))) ((>= i start)) (declare (fixnum i)) (pop l)) (do ((i start (f+ 1 i)) (j 0)) ((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0)) (declare (fixnum i j)) (cond ((call-test test test-not item (funcall key (cadr l))) (setf j (f+ 1 j)) (rplacd l (cddr l))) (t (setq l (cdr l)))))) (let (,number-satisfied) (declare (fixnum n)) (when (< n count) (setq count n)) (do ((newseq (make-sequence (seqtype sequence) (the fixnum (f- l count)))) ,iterate-i-everywhere (j 0) ,kount-0) (,endp-i-everywhere newseq) (declare (fixnum i j k)) (cond ((and ,i-in-range ,within-count ,satisfies-the-test) ,kount-up) (t (setf (elt newseq j) ,x) (setf j (f+ 1 j))))))) `(let (,number-satisfied) (declare (fixnum n)) (when (< n count) (setq count n)) (do ((newseq (make-sequence (seqtype sequence) (the fixnum (f- l count)))) ,iterate-i-everywhere (j (f+ -1 (the fixnum (f- l count)))) ; (j (f- (the fixnum (f+ -1 end)) n)) ,kount-0) (,endp-i-everywhere newseq) (declare (fixnum i j k)) (cond ((and ,i-in-range ,within-count ,satisfies-the-test) ,kount-up) (t (setf (elt newseq j) ,x) (setq j (f+ -1 j)))))))) (defseq count () nil nil `(do (,iterate-i ,kount-0) (,endp-i k) (declare (fixnum i k)) (when (and ,satisfies-the-test) ,kount-up))) (defseq internal-count () t nil `(do (,iterate-i ,kount-0) (,endp-i k) (declare (fixnum i k)) (when (and ,within-count ,satisfies-the-test) ,kount-up))) (defseq substitute (newitem) t t `(do ((newseq (make-sequence (seqtype sequence) l)) ,iterate-i-everywhere ,kount-0) (,endp-i-everywhere newseq) (declare (fixnum i k)) (cond ((and ,i-in-range ,within-count ,satisfies-the-test) (setf (elt newseq i) newitem) ,kount-up) (t (setf (elt newseq i) ,x)))))) (defseq nsubstitute (newitem) t nil `(do (,iterate-i ,kount-0) (,endp-i sequence) (declare (fixnum i k)) (when (and ,within-count ,satisfies-the-test) (setf ,x newitem) ,kount-up))) (defseq find () nil nil `(do (,iterate-i) (,endp-i nil) (declare (fixnum i)) (when ,satisfies-the-test (return ,x)))) (defseq position () nil nil `(do (,iterate-i) (,endp-i nil) (declare (fixnum i)) (when ,satisfies-the-test (return i)))) (defun remove-duplicates (sequence &key from-end test test-not start end (key #'identity)) (and test test-not (test-error)) (when (and (listp sequence) (not from-end) (null start) (null end)) (when (endp sequence) (return-from remove-duplicates nil)) (do ((l sequence (cdr l)) (l1 nil)) ((endp (cdr l)) (return-from remove-duplicates (nreconc l1 l))) (unless (member1 (car l) (cdr l) :test test :test-not test-not :key key) (setq l1 (cons (car l) l1))))) (delete-duplicates sequence :from-end from-end :test test :test-not test-not :start start :end end :key key)) (defun delete-duplicates (sequence &key from-end test test-not start end (key #'identity) &aux (l (length sequence))) (declare (fixnum l)) (and test test-not (test-error)) (when (and (listp sequence) (not from-end) (null start) (null end)) (when (endp sequence) (return-from delete-duplicates nil)) (do ((l sequence)) ((endp (cdr l)) (return-from delete-duplicates sequence)) (cond ((member1 (car l) (cdr l) :test test :test-not test-not :key key) (rplaca l (cadr l)) (rplacd l (cddr l))) (t (setq l (cdr l)))))) (with-start-end start end sequence (if (not from-end) (do ((n 0) (i start (f+ 1 i))) ((>= i end) (do ((newseq (make-sequence (seqtype sequence) (the fixnum (f- l n)))) (i 0 (f+ 1 i)) (j 0)) ((>= i l) newseq) (declare (fixnum i j)) (cond ((and (<= start i) (< i end) (position (funcall key (elt sequence i)) sequence :test test :test-not test-not :start (the fixnum (f+ 1 i)) :end end :key key))) (t (setf (elt newseq j) (elt sequence i)) (setf j (f+ 1 j)))))) (declare (fixnum n i)) (when (position (funcall key (elt sequence i)) sequence :test test :test-not test-not :start (the fixnum (f+ 1 i)) :end end :key key) (setf n (f+ 1 n)))) (do ((n 0) (i (f+ -1 end) (f+ -1 i))) ((< i start) (do ((newseq (make-sequence (seqtype sequence) (the fixnum (f- l n)))) (i (f+ -1 l) (f+ -1 i)) (j (f- (the fixnum (f+ -1 l)) n))) ((< i 0) newseq) (declare (fixnum i j)) (cond ((and (<= start i) (< i end) (position (funcall key (elt sequence i)) sequence :from-end t :test test :test-not test-not :start start :end i :key key))) (t (setf (elt newseq j) (elt sequence i)) (setq j (f+ -1 j)))))) (declare (fixnum n i)) (when (position (funcall key (elt sequence i)) sequence :from-end t :test test :test-not test-not :start start :end i :key key) (setf n (f+ 1 n))))))) (defun mismatch (sequence1 sequence2 &key from-end test test-not (key #'identity) start1 start2 end1 end2) (and test test-not (test-error)) (with-start-end start1 end1 sequence1 (with-start-end start2 end2 sequence2 (if (not from-end) (do ((i1 start1 (f+ 1 i1)) (i2 start2 (f+ 1 i2))) ((or (>= i1 end1) (>= i2 end2)) (if (and (>= i1 end1) (>= i2 end2)) nil i1)) (declare (fixnum i1 i2)) (unless (call-test test test-not (funcall key (elt sequence1 i1)) (funcall key (elt sequence2 i2))) (return i1))) (do ((i1 (f+ -1 end1) (f+ -1 i1)) (i2 (f+ -1 end2) (f+ -1 i2))) ((or (< i1 start1) (< i2 start2)) (if (and (< i1 start1) (< i2 start2)) nil (f+ 1 i1))) (declare (fixnum i1 i2)) (unless (call-test test test-not (funcall key (elt sequence1 i1)) (funcall key (elt sequence2 i2))) (return (f+ 1 i1)))))))) (defun search (sequence1 sequence2 &key from-end test test-not (key #'identity) start1 start2 end1 end2) (and test test-not (test-error)) (with-start-end start1 end1 sequence1 (with-start-end start2 end2 sequence2 (if (not from-end) (loop (do ((i1 start1 (f+ 1 i1)) (i2 start2 (f+ 1 i2))) ((>= i1 end1) (return-from search start2)) (declare (fixnum i1 i2)) (when (>= i2 end2) (return-from search nil)) (unless (call-test test test-not (funcall key (elt sequence1 i1)) (funcall key (elt sequence2 i2))) (return nil))) (setf start2 (f+ 1 start2))) (loop (do ((i1 (f+ -1 end1) (f+ -1 i1)) (i2 (f+ -1 end2) (f+ -1 i2))) ((< i1 start1) (return-from search (the fixnum (f+ 1 i2)))) (declare (fixnum i1 i2)) (when (< i2 start2) (return-from search nil)) (unless (call-test test test-not (funcall key (elt sequence1 i1)) (funcall key (elt sequence2 i2))) (return nil))) (setq end2 (f+ -1 end2))))))) (defun sort (sequence predicate &key (key #'identity)) (if (listp sequence) (list-merge-sort sequence predicate key) (quick-sort sequence 0 (the fixnum (length sequence)) predicate key))) (defun list-merge-sort (l predicate key) (labels ((sort (l) (prog ((i 0) left right l0 l1 key-left key-right) (declare (fixnum i)) (setq i (length l)) (cond ((< i 2) (return l)) ((= i 2) (setq key-left (funcall key (car l))) (setq key-right (funcall key (cadr l))) (cond ((funcall predicate key-left key-right) (return l)) ((funcall predicate key-right key-left) (return (nreverse l))) (t (return l))))) (setq i (floor i 2)) (do ((j 1 (f+ 1 j)) (l1 l (cdr l1))) ((>= j i) (setq left l) (setq right (cdr l1)) (rplacd l1 nil)) (declare (fixnum j))) (setq left (sort left)) (setq right (sort right)) (cond ((endp left) (return right)) ((endp right) (return left))) (setq l0 (cons nil nil)) (setq l1 l0) (setq key-left (funcall key (car left))) (setq key-right (funcall key (car right))) loop (cond ((funcall predicate key-left key-right) (go left)) ((funcall predicate key-right key-left) (go right)) (t (go left))) left (rplacd l1 left) (setq l1 (cdr l1)) (setq left (cdr left)) (when (endp left) (rplacd l1 right) (return (cdr l0))) (setq key-left (funcall key (car left))) (go loop) right (rplacd l1 right) (setq l1 (cdr l1)) (setq right (cdr right)) (when (endp right) (rplacd l1 left) (return (cdr l0))) (setq key-right (funcall key (car right))) (go loop)))) (sort l))) #| (defun list-quick-sort (l predicate key) (if (or (endp l) (endp (cdr l))) l (multiple-value-bind (x y) (list-quick-sort-partition (car l) (cdr l) predicate key) (nconc (list-quick-sort x predicate key) (list (car l)) (list-quick-sort y predicate key))))) (defun list-quick-sort-partition (k l predicate key) (do ((l l (cdr l)) (x nil) (y nil)) ((endp l) (values (nreverse x) (nreverse y))) (if (funcall predicate (funcall key (car l)) (funcall key k)) (setq x (cons (car l) x)) (setq y (cons (car l) y))))) |# (proclaim '(function quick-sort (t fixnum fixnum t t) t)) (defun quick-sort (seq start end pred key) (declare (fixnum start end)) (if (<= end (the fixnum (f+ 1 start))) seq (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) (declare (fixnum j k)) (block outer-loop (loop (loop (setq k (f+ -1 k)) (unless (< j k) (return-from outer-loop)) (when (funcall pred (funcall key (elt seq k)) kd) (return))) (loop (setf j (f+ 1 j)) (unless (< j k) (return-from outer-loop)) (unless (funcall pred (funcall key (elt seq j)) kd) (return))) (let ((temp (elt seq j))) (setf (elt seq j) (elt seq k) (elt seq k) temp)))) (setf (elt seq start) (elt seq j) (elt seq j) d) (quick-sort seq start j pred key) (quick-sort seq (f+ 1 j) end pred key)))) (defun stable-sort (sequence predicate &key (key #'identity)) (if (listp sequence) (list-merge-sort sequence predicate key) (if (or (stringp sequence) (bit-vector-p sequence)) (sort sequence predicate :key key) (coerce (list-merge-sort (coerce sequence 'list) predicate key) (seqtype sequence))))) (defun merge (result-type sequence1 sequence2 predicate &key (key #'identity) &aux (l1 (length sequence1)) (l2 (length sequence2))) (declare (fixnum l1 l2)) (when (equal key 'nil) (setq key #'identity)) (do ((newseq (make-sequence result-type (the fixnum (f+ l1 l2)))) (j 0 (f+ 1 j)) (i1 0) (i2 0)) ((and (= i1 l1) (= i2 l2)) newseq) (declare (fixnum j i1 i2)) (cond ((and (< i1 l1) (< i2 l2)) (cond ((funcall predicate (funcall key (elt sequence1 i1)) (funcall key (elt sequence2 i2))) (setf (elt newseq j) (elt sequence1 i1)) (setf i1 (f+ 1 i1))) ((funcall predicate (funcall key (elt sequence2 i2)) (funcall key (elt sequence1 i1))) (setf (elt newseq j) (elt sequence2 i2)) (setf i2 (f+ 1 i2))) (t (setf (elt newseq j) (elt sequence1 i1)) (setf i1 (f+ 1 i1))))) ((< i1 l1) (setf (elt newseq j) (elt sequence1 i1)) (setf i1 (f+ 1 i1))) (t (setf (elt newseq j) (elt sequence2 i2)) (setf i2 (f+ 1 i2)))))) (defun map-into (result-sequence function &rest sequences) ; "map-into: (result-sequence function &rest sequences)" (let ((nel (apply #'min (if (subtypep (type-of result-sequence) 'vector) (array-dimension result-sequence 0) (length result-sequence)) (mapcar #'length sequences)))) ;; Set the fill pointer to the number of iterations (when (and (subtypep (type-of result-sequence) 'vector) (array-has-fill-pointer-p result-sequence)) (setf (fill-pointer result-sequence) nel)) ;; Perform mapping (dotimes (k nel result-sequence) (setf (elt result-sequence k) (apply function (mapcar #'(lambda (v) (elt v k)) sequences)))))) (defmacro with-hash-table-iterator ((name hash-table) &body body) (let ((table (gensym )) (ind (gensym "ind"))) `(let ((,table ,hash-table) (,ind 0)) (macrolet ((,name () `(multiple-value-bind (more key val) (si::next-hash-table-entry ,',table ,',ind) (cond ((>= (the fixnum more) 0) (setq ,',ind more) (values t key val)) (t (values nil nil nil)))))) ,@body)))) gcl-2.6.14/lsp/gcl_translate_pathname.lsp0000644000175000017500000000667214360276512017023 0ustar cammcamm(in-package :si) (defun lenel (x lp) (case x (:wild 1)(:wild-inferiors 2)(:absolute (if lp -1 0))(:relative (if lp 0 -1)) ((:unspecific nil :newest) -1)(otherwise (length x)))) (defun next-match (&optional (i 1) (k -1) (m (1- (ash (length *match-data*) -1)))) (cond ((< k (match-beginning i) (match-end i)) i) ((< i m) (next-match (1+ i) k m)) (i))) (defun mme2 (s lel lp &optional (b 0) (i (next-match)) r el &aux (e (+ b (lenel (car lel) lp)))(j (match-beginning i))(k (match-end i))) (cond ((< (- b 2) j k (+ e 2)) (let* ((z (car lel))(b1 (max b j))(e1 (min k e)) (z (if (or (< b b1) (< e1 e)) (subseq z (- b1 b) (- e1 b)) z)) (r (if el r (cons nil r)))) (mme2 s lel lp b (next-match i k) (cons (cons z (car r)) (cdr r)) (or el (car lel))))) ((< (1- j) b e (1+ k)) (let ((r (if el r (cons nil r)))) (mme2 s (cdr lel) lp (1+ e) i (cons (cons (car lel) (car r)) (cdr r)) (or el (list (car lel)))))) ((consp el) (let* ((cr (nreverse (car r)))) (mme2 s lel lp b (next-match i k) (cons (cons (car el) (list cr)) (cdr r))))) (el (let* ((cr (nreverse (car r)))) (mme2 s (cdr lel) lp (1+ e) i (cons (cons el cr) (cdr r))))) (lel (mme2 s (cdr lel) lp (1+ e) i (cons (car lel) r))) ((nreverse r)))) (defun do-repl (x y) (labels ((r (x l &optional (b 0) &aux (f (string-match #v"\\*" x b))) (if (eql f -1) (if (eql b 0) x (subseq x b)) (string-concatenate (subseq x b f) (or (car l) "") (r x (cdr l) (1+ f)))))) (r y x))) (defun dir-p (x) (when (consp x) (member (car x) '(:absolute :relative)))) (defun source-portion (x y) (cond ((or (dir-p x) (dir-p y)) (mapcan (lambda (z &aux (w (source-portion (if y (when (wild-dir-element-p z) (setf x (member-if 'listp x)) (pop x)) z) (when y z)))) (if (listp w) w (list w))) (or y x))) ((if y (eq y :wild-inferiors) t) (if (listp x) (if (listp (cadr x)) (cadr x) (car x)) x));(or y) ((eq y :wild) (if (listp x) (car x) x));(or y) ((stringp y) (do-repl (when (listp x) (unless (listp (cadr x)) (cdr x))) y)) (y))) (defun list-toggle-case (x f) (typecase x (string (values (funcall f x))) (cons (mapcar (lambda (x) (list-toggle-case x f)) x)) (otherwise x))) (defun mme3 (sx px flp tlp) (list-toggle-case (lnp (mme2 sx (pnl1 (mlp px)) flp)) (cond ((eq flp tlp) 'identity) (flp 'string-downcase) (tlp 'string-upcase)))) (defun translate-pathname (source from to &key &aux (psource (pathname source)) (pto (pathname to)) (match (pathname-match-p source from))) (declare (optimize (safety 1))) (check-type source pathname-designator) (check-type from pathname-designator) (check-type to pathname-designator) (check-type match (not null)) (apply 'make-pathname :host (pathname-host pto) :device (pathname-device pto) (mapcan 'list +pathname-keys+ (mapcar 'source-portion (mme3 (namestring source) psource (typep psource 'logical-pathname) (typep pto 'logical-pathname)) (mlp pto))))) (defun translate-logical-pathname (spec &key &aux (p (pathname spec))) (declare (optimize (safety 1))) (check-type spec pathname-designator) (typecase p (logical-pathname (let ((rules (assoc p (logical-pathname-translations (pathname-host p)) :test 'pathname-match-p))) (unless rules (error 'file-error :pathname p :format-control "No matching translations")) (translate-logical-pathname (apply 'translate-pathname p rules)))) (otherwise p))) gcl-2.6.14/lsp/gcl_defmacro.lsp0000755000175000017500000002230214360276512014720 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; defmacro.lsp ;;;; ;;;; defines SI:DEFMACRO*, the defmacro preprocessor (in-package :si) (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) ;;; valid lambda-list to DEFMACRO is: ;;; ;;; ( [ &whole sym ] ;;; [ &environment sym ] ;;; { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) ;;; ;;; where v is short for { defmacro-lambda-list | sym }. ;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case ;;; (DEFMACRO ... ) is equivalent to ;;; (DEFMACRO (&REST ) ...). ;;; Defamcro-lambda-list is defined as: ;;; ;;; ( { v }* ;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] ;;; { [ { &rest | &body } v ] ;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* ;;; [ &allow-other-keys ]] ;;; [ &aux { sym | ( v [ init ] ) }* ] ;;; | . sym } ;;; ) ;; defvar is not yet available. (mapc '*make-special '(*dl* *key-check* *arg-check*)) (defun get-&environment(vl &aux env) (let ((env-m (and (listp vl) (do ((tail vl (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail)))))) (cond (env-m (setq env (cadr env-m)) (setq vl (append (ldiff vl env-m) (cddr env-m))))) (values vl env))) (defun si:defmacro* (name vl body &aux *dl* (*key-check* nil) (*arg-check* nil) doc decls whole ppn (env nil) envp) (cond ((listp vl)) ((symbolp vl) (setq vl (list '&rest vl))) (t (error "The defmacro-lambda-list ~s is not a list." vl))) (multiple-value-setq (doc decls body) (find-doc body nil)) (cond ((and (listp vl) (eq (car vl) '&whole)) (setq whole (cadr vl)) (setq vl (cddr vl))) (t (setq whole (gensym)))) (multiple-value-setq (vl env) (get-&environment vl)) (setq envp env) (or env (setq env (gensym))) (setq *dl* `(&aux ,env ,whole)) (setq ppn (dm-vl vl whole t)) (dolist (kc *key-check*) (push `(unless (getf ,(car kc) :allow-other-keys) (do ((vl ,(car kc) (cddr vl))) ((endp vl)) (unless (member (car vl) ',(cdr kc)) (dm-key-not-allowed (car vl)) ))) body)) (dolist (ac *arg-check*) (push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac))) (dm-too-many-arguments)) body)) (unless envp (push `(declare (ignore ,env)) body)) (list doc ppn `(lambda-block ,name ,(nreverse *dl*) ,@(append decls body))) ) (defun dm-vl (vl whole top) (do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil) (auxp nil) (rest nil) (allow-other-keys nil) (keys nil) (no-check nil) (n (if top 1 0)) (ppn nil) ) ((not (consp vl)) (when vl (when restp (dm-bad-key '&rest)) (push (list vl (dm-nth-cdr n whole)) *dl*) (setq no-check t)) (when (and rest (not allow-other-keys)) (push (cons rest keys) *key-check*)) (unless no-check (push (cons whole n) *arg-check*)) ppn ) (let ((v (car vl))) (cond ((eq v '&optional) (when optionalp (dm-bad-key '&optional)) (setq optionalp t) (pop vl)) ((or (eq v '&rest) (eq v '&body)) (when restp (dm-bad-key v)) (dm-v (cadr vl) (dm-nth-cdr n whole)) (setq restp t optionalp t no-check t) (setq vl (cddr vl)) (when (eq v '&body) (setq ppn (if top (1- n) n)))) ((eq v '&key) (when keyp (dm-bad-key '&key)) (setq rest (gensym)) (push (list rest (dm-nth-cdr n whole)) *dl*) (setq keyp t restp t optionalp t no-check t) (pop vl)) ((eq v '&allow-other-keys) (when (or (not keyp) allow-other-keys-p) (dm-bad-key '&allow-other-keys)) (setq allow-other-keys-p t) (setq allow-other-keys t) (pop vl)) ((eq v '&aux) (when auxp (dm-bad-key '&aux)) (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) (pop vl)) (auxp (let (x (init nil)) (cond ((symbolp v) (setq x v)) (t (setq x (car v)) (unless (endp (cdr v)) (setq init (cadr v))))) (dm-v x init)) (pop vl)) (keyp (let ((temp (gensym)) x k (init nil) (sv nil)) (cond ((symbolp v) (setq x v k (intern (string v) 'keyword))) (t (if (symbolp (car v)) (setq x (car v) k (intern (string (car v)) 'keyword)) (setq x (cadar v) k (caar v))) (unless (endp (cdr v)) (setq init (cadr v)) (unless (endp (cddr v)) (setq sv (caddr v)))))) (dm-v temp `(getf ,rest ,k 'failed)) (dm-v x `(if (eq ,temp 'failed) ,init ,temp)) (when sv (dm-v sv `(not (eq ,temp 'failed)))) (push k keys)) (pop vl)) (optionalp (let (x (init nil) (sv nil)) (cond ((symbolp v) (setq x v)) (t (setq x (car v)) (unless (endp (cdr v)) (setq init (cadr v)) (unless (endp (cddr v)) (setq sv (caddr v)))))) (dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init)) (when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole)))))) (incf n) (pop vl) ) (t (dm-v v `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) (dm-too-few-arguments))) (incf n) (pop vl)) )))) (defun dm-v (v init) (if (symbolp v) (push (if init (list v init) v) *dl*) (let ((temp (gensym))) (push (if init (list temp init) temp) *dl*) (dm-vl v temp nil)))) (defun dm-nth (n v) (multiple-value-bind (q r) (floor n 4) (dotimes (i q) (setq v (list 'cddddr v))) (case r (0 (list 'car v)) (1 (list 'cadr v)) (2 (list 'caddr v)) (3 (list 'cadddr v)) ))) (defun dm-nth-cdr (n v) (multiple-value-bind (q r) (floor n 4) (dotimes (i q) (setq v (list 'cddddr v))) (case r (0 v) (1 (list 'cdr v)) (2 (list 'cddr v)) (3 (list 'cdddr v)) ))) (defun dm-bad-key (key) (error "Defmacro-lambda-list contains illegal use of ~s." key)) (defun dm-too-few-arguments () (error "Too few arguments are supplied to defmacro-lambda-list.")) (defun dm-too-many-arguments () (error "Too many arguments are supplied to defmacro-lambda-list.")) (defun dm-key-not-allowed (key) (error "The key ~s is not allowed." key)) (defun find-doc (body ignore-doc) (if (endp body) (values nil nil nil) (let ((d (macroexpand (car body)))) (cond ((stringp d) (if (or (endp (cdr body)) ignore-doc) (values nil nil (cons d (cdr body))) (multiple-value-bind (doc decls b) (find-doc (cdr body) t) (declare (ignore doc)) (values d decls b)))) ((and (consp d) (eq (car d) 'declare)) (multiple-value-bind (doc decls b) (find-doc (cdr body) ignore-doc) (values doc (cons d decls) b))) (t (values nil nil (cons d (cdr body)))))))) (defun find-declarations (body) (if (endp body) (values nil nil) (let ((d (macroexpand (car body)))) (cond ((stringp d) (if (endp (cdr body)) (values nil (list d)) (multiple-value-bind (ds b) (find-declarations (cdr body)) (values (cons d ds) b)))) ((and (consp d) (eq (car d) 'declare)) (multiple-value-bind (ds b) (find-declarations (cdr body)) (values (cons d ds) b))) (t (values nil (cons d (cdr body)))))))) gcl-2.6.14/lsp/gprof_aix.hc0000755000175000017500000001354214360276512014073 0ustar cammcamm#include #include #include extern struct monglobal _mondata; static struct desc { /*function descriptor fields*/ caddr_t begin; /*initial code address*/ caddr_t toc; /*table of contents address*/ caddr_t env; /*environment pointer*/ } ; /*function descriptor structure*/ static struct desc *fd; /*pointer to function descriptor*/ #include "../h/config.h" #include "../h/ext_sym.h" #define CF_FLAG (1 << 31) extern char *kcl_self; #define function_address(f) (((struct desc *)(f))->begin) mymonitor(low,high,x,leng) int low,high; object x; { if (0 == x) {monitor(0); return 0;} monitor(low,high,x,leng); } static int newmonstartup(); mymonstartup(low,high) caddr_t low,high; { /* static struct frag f[3]; f[0].p_low = function_address(&__start); f[0].p_high = function_address(&init_cmpwt); f[1].p_low = low; f[1].p_high = high; f[2].p_low = 0; f[3].p_high = 0; newmonstartup(-1,f); */ _mondata.prof_type = _PROF_TYPE_IS_PG; return monstartup(low,high); } /* symbol table address + &__start == the real address [if the ld is done with -T0 ] */ /* The format of symbol table entries. [144] m 0x0001486c .text 2 extern void() .Foo [145] a2 0 60 188239 152 */ /* the monstartup code in aix3.1 is broken: */ static size1(f) struct frag *f; { int range; int fromsize; int total = 0; int tonum; while (f->p_high) {range = f->p_high - f->p_low; fromsize = FROM_STG_SIZE(range); tonum = TO_NUM_ELEMENTS(range); if ( tonum < MINARCS ) tonum = MINARCS; else if ( tonum > TO_MAX-1 ) tonum = TO_MAX-1; tonum = tonum * sizeof( struct tostruct ); total += fromsize + tonum + sizeof(struct gfctl); f++; } return total; } static int newmonstartup(a,f) struct frag *f; {struct prof *pb = malloc(3*sizeof(struct prof)); struct frag *ff =f; int i = 0 ; int nranges = 0; int total = 0; int range; caddr_t buffer ; int callcntsize; bzero(pb,3*sizeof(struct prof)); while(ff->p_high) { pb[i].p_high = (caddr_t) ROUNDUP((int)f[i].p_high, INST_CNT_SIZE); pb[i].p_low = (caddr_t) ROUNDDOWN((int)f[i].p_low, INST_CNT_SIZE); range = pb[i].p_high - pb[i].p_low; total += HIST_STG_SIZE(range); ff++; i++; } nranges = i; callcntsize = size1(f); total += callcntsize; buffer = (caddr_t) malloc(total); _mondata.monstubuf = buffer; for (i=0; i < nranges; i++) {pb[i].p_buff = (HISTCOUNTER *)buffer; pb[i].p_scale = HIST_SCALE_1_TO_1; pb[i].p_bufsize = HIST_NUM_COUNTERS(pb[i].p_high-pb[i].p_low); if (i == 0) { pb[i].p_bufsize += (((callcntsize + HIST_COUNTER_SIZE -1)/HIST_COUNTER_SIZE) ); } buffer += pb[i].p_bufsize * HIST_COUNTER_SIZE; } monitor(1,1,pb,-1, callcntsize); } static char symname [200]; static sym_leng_and_copy(ux,copy) unsigned int ux; int copy; { char *from; int leng=0; if (ux & CF_FLAG) {object x = (object) (ux & ~CF_FLAG); if (x->cf.cf_name ==0) from="ZUNDEF"; else {leng = x->cf.cf_name->s.s_fillp; from = x->cf.cf_name->s.s_self;}} else if (ux) { from= (char *)(ux);} else {from="UNDEF";} if (leng==0) leng=strlen(from); if (leng >= sizeof(symname)) FEerror("Too long symbol",0); if(copy) bcopy(from,symname,leng); symname[leng]='0'; return leng; } extern char * __start; extern char *core_end; extern int bzero(); static write_outsyms() {FILE *fdout,*fdin; static struct syment sym; static struct syment symaux; struct filehdr Eheader; struct aouthdr header; struct scnhdr shdrs[15]; fdout= fopen("syms.out","w"); fdin=fopen(kcl_self,"r"); if (fdin == 0) FEerror("Can't find akcl image"); fread(&Eheader,1,sizeof(Eheader), fdin); fread(&header,1,Eheader.f_opthdr,fdin); fclose(fdin); if (fdout == 0) FEerror("Can't open syms.out"); Eheader.f_nscns = 2; Eheader.f_symptr = sizeof(Eheader) + sizeof(header) + Eheader.f_nscns*sizeof(struct scnhdr); Eheader.f_nsyms = 2*(1+ combined_table.length); bzero(&shdrs[0],10*sizeof(struct scnhdr)); bzero(&symaux,1*SYMESZ); bzero(&sym,1*SYMESZ); header.tsize=0; header.dsize=0; header.bsize=0; header.o_snentry=1; header.o_sntext=1; header.o_sndata=1; header.o_sntoc=1; header.o_snbss=1; header.o_snloader=2; fwrite(&Eheader,1,sizeof(Eheader), fdout); fwrite(&header,1,Eheader.f_opthdr,fdout); fwrite(&shdrs[1],Eheader.f_nscns,sizeof(struct scnhdr),fdout); fseek(fdout,Eheader.f_symptr,0); sym.n_scnum == header.o_sntext; sym.n_sclass = 0x2 ; sym.n_type = 0x20; sym.n_numaux = 1; printf("(&__start = 0x%x)",function_address(&__start)); {int i=0; int pos=4; while (i < combined_table.length) { unsigned int adr = (unsigned int)(SYM_ADDRESS(combined_table,i)); /* printf("%d %d",i,SYM_STRING(combined_table,i)); fflush(stdout); */ sym.n_offset = pos; sym.n_value= (adr > 0x20000000 ? (unsigned int) function_address(SYM_ADDRESS(combined_table,i)) - 0x10000e00 : adr - 0x10000e00); /* printf("\n %d %s 0x%x %x ",i,SYM_STRING(combined_table,i), adr, adr); */ fwrite(&sym,SYMESZ,1,fdout); fwrite(&symaux,SYMESZ,1,fdout); pos=pos+ sym_leng_and_copy(SYM_STRING(combined_table,i),1)+1; /* printf("%s\n",symname); */ i++; } sym.n_offset = pos; sym.n_value=(int)core_end - (int) & __start; fwrite(&sym,SYMESZ,1,fdout); fwrite(&symaux,SYMESZ,1,fdout); pos=pos+ strlen("_ENDSYM")+1; fwrite(&pos,sizeof(pos),1,fdout); printf("(at %d)",ftell(fdout)); for (i=0; i< combined_table.length ; i++) {int leng=sym_leng_and_copy(SYM_STRING(combined_table,i),1); fwrite(symname,leng,1,fdout); putc(0,fdout);} } fwrite("_ENDSYM",8,1,fdout); fclose(fdout); } gcl-2.6.14/lsp/gcl_autoload.lsp0000755000175000017500000003435114360276512014757 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; AUTOLOAD (in-package :si) (export '(clines defentry defcfun object void int double)) ;(defvar *features*) (defun lisp-implementation-type () "GNU Common Lisp (GCL)") (defun machine-type () #+sun "SUN" #+hp-ux "HP-UX" #+eclipse "ECLIPSE" #+vax "VAX" ) ;(defun machine-type () "DEC VAX11/780") (defun machine-version () (machine-type)) ;(defun machine-version () nil) (defun machine-instance () (machine-type)) ;(defun machine-instance () nil) (defun software-type () #+aosv "AOS/VS" #+bsd "BSD" #+system-v "SYSTEM-V" #+hp-ux "HP-UX") ;(defun software-type () "UNIX BSD") (defun software-version () (software-type)) ;(defun software-version () "4.2BSD") ;(defun short-site-name () "RIMS") (defun short-site-name () nil) ;(defun long-site-name () ; "Research Institute for Mathematical Sciences, Kyoto University") (defun long-site-name () nil) ;;; Compiler functions. (defun proclaim (d) (when (eq (car d) 'special) (mapc #'si:*make-special (cdr d)))) (defun proclamation (d) (and (eq (car d) 'special) (dolist (var (cdr d) t) (unless (si:specialp var) (return nil))))) (defun compile-file (&rest args) (error "COMPILE-FILE is not defined in this load module.")) (defun compile (&rest args) (error "COMPILE is not defined in this load module.")) (defun disassemble (&rest args) (error "DISASSEMBLE is not defined in this load module.")) ;;; Editor. ; (defun get-decoded-time () (decode-universal-time (get-universal-time))) #+never (defun get-universal-time () (multiple-value-bind (sec min h d m y dow dstp tz) (get-decoded-time) (encode-universal-time sec min h d m y tz))) ; Set the default system editor to a fairly certain bet. #-winnt(defvar *gcl-editor* "vi") #+winnt(defvar *gcl-editor* "notepad") (defun new-ed (editor-name) "Change the editor called by (ed) held in *gcl-editor*." (setf *gcl-editor* editor-name)) (defun ed (&optional name) "Edit a file using the editor named in *gcl-editor*; customise with new-ed()." (if (null name) (system *gcl-editor*) (cond ((stringp name) (system (format nil "~A ~A" *gcl-editor* name))) ; If string, assume file name. ((pathnamep name) (system (format nil "~A ~A" *gcl-editor* (namestring name)))) ; If pathname. (t (let ((body (symbol-function name))) (cond ((compiled-function-p body) (error "You can't edit compiled functions.")) ((and body (consp body) (eq (car body) 'lambda-block)) ; If lambda block, save file and edit. (let ((ed-file (concatenate 'string (temp-dir) (format nil "~A" (cadr body)) ".lisp"))) (with-open-file (st ed-file :direction :output) (print `(defun ,name ,@ (cddr body)) st)) (system (format nil "~A ~A" *gcl-editor* ed-file)))) (t (system (format nil "~A ~A" *gcl-editor* name))))))))) ; Use symbol as filename ;;; Allocator. ;(import 'si::allocate) ;(export '(allocate ;allocated-pages maximum-allocatable-pages ;allocate-contiguous-pages ;allocated-contiguous-pages maximum-contiguous-pages ;allocate-relocatable-pages allocated-relocatable-pages ; sfun gfun cfun cclosure spice structure)) ;(defvar type-character-alist ; '((cons . #\.) ; (fixnum . #\N) ; (bignum . #\B) ; (ratio . #\R) ; (short-float . #\F) ; (long-float . #\L) ; (complex . #\C) ; (character . #\#) ; (symbol . #\|) ; (package . #\:) ; (hash-table . #\h) ; (array . #\a) ; (vector . #\v) ; (string . #\") ; (bit-vector . #\b) ; (structure . #\S) ; (sfun . #\g) ; (stream . #\s) ; (random-state . #\$) ; (readtable . #\r) ; (pathname . #\p) ; (cfun . #\f) ; (vfun . #\V) ; (cclosure . #\c) ; (spice . #\!))) ; ;(defun get-type-character (type) ; (let ((a (assoc type type-character-alist))) ; (unless a ; (error "~S is not an implementation type.~%~ ; It should be one of:~%~ ; ~{~10T~S~^~30T~S~^~50T~S~%~}~%" ; type ; (mapcar #'car type-character-alist))) ; (cdr a))) ;(defun allocate (type quantity &optional really-allocate) ; (si:alloc (get-type-character type) quantity really-allocate)) ;(defun allocated-pages (type) ; (si:npage (get-type-character type))) ;(defun maximum-allocatable-pages (type) ; (si:maxpage (get-type-character type))) ;(defun allocate-contiguous-pages (quantity &optional really-allocate) ; (si::alloc-contpage quantity really-allocate)) ;(defun allocated-contiguous-pages () ; (si:ncbpage)) ;(defun maximum-contiguous-pages () ; (si::maxcbpage)) ;(defun allocate-relocatable-pages (quantity &optional really-allocate) ; (si::alloc-relpage quantity)) ;(defun allocated-relocatable-pages () ; (si::nrbpage)) ;; FIXME This has to come straight from enum.h. CM 20050114 (defvar *type-list* '(cons fixnum bignum ratio short-float long-float complex character symbol package hash-table array vector string bit-vector structure stream random-state readtable pathname cfun cclosure sfun gfun vfun afun closure cfdata spice)) (defun heaprep nil (let ((f (list "word size: ~a bits~%" "page size: ~a bytes~%" "heap start: 0x~x~%" "heap max : 0x~x~%" "shared library start: 0x~x~%" "cstack start: 0x~x~%" "cstack mark offset: ~a bytes~%" "cstack direction: ~[downward~;upward~;~]~%" "cstack alignment: ~a bytes~%" "cstack max: ~a bytes~%" "immfix start: 0x~x~%" "immfix size: ~a fixnums~%" "physical memory: ~a pages~%")) (v (multiple-value-list (si::heap-report)))) (do ((v v (cdr v)) (f f (cdr f))) ((not (car v))) (format t (car f) (let ((x (car v))) (cond ((>= x 0) x) ((+ x (* 2 (1+ most-positive-fixnum)))))))))) (defun room (&optional x) (let ((l (multiple-value-list (si:room-report))) maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage maxnpage rbused rbfree nrbpage maxrbpage info-list link-alist) (setq maxpage (nth 0 l) leftpage (nth 1 l) ncbpage (nth 2 l) maxcbpage (nth 3 l) ncb (nth 4 l) cbgbccount (nth 5 l) holepage (nth 6 l) rbused (nth 7 l) rbfree (nth 8 l) nrbpage (nth 9 l) maxrbpage (nth 10 l) rbgbccount (nth 11 l) l (nthcdr 12 l)) (do ((l l (nthcdr 5 l)) (tl *type-list* (cdr tl)) (j 0 (+ j (if (nth 3 l) (nth 3 l) 0))) (i 0 (+ i (if (nth 2 l) (nth 2 l) 0)))) ((null l) (setq npage i maxnpage j)) (let ((typename (car tl)) (nused (nth 0 l)) (nfree (nth 1 l)) (npage (nth 2 l)) (maxpage (nth 3 l)) (gbccount (nth 4 l))) (if nused (push (list typename npage maxpage (if (zerop (+ nused nfree)) 0 (/ nused 0.01 (+ nused nfree))) (if (zerop gbccount) nil gbccount)) info-list) (let ((a (assoc (nth nfree *type-list*) link-alist))) (if a (nconc a (list typename)) (push (list (nth nfree *type-list*) typename) link-alist)))))) (terpri) (dolist (info (nreverse info-list)) (apply #'format t "~8D/~D~19T~6,1F%~@[~8D~]~35T~{~A~^ ~}" (append (cdr info) (if (assoc (car info) link-alist) (list (assoc (car info) link-alist)) (list (list (car info)))))) (terpri) ) (terpri) (format t "~8D/~D~26T~@[~8D~]~35Tcontiguous (~D blocks)~%" ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) (format t "~9T~D~35Thole~%" holepage) (format t "~8D/~D~19T~6,1F%~@[~8D~]~35Trelocatable~%~%" nrbpage maxrbpage (if (zerop (+ rbused rbfree)) 0.0 (/ rbused 0.01 (+ rbused rbfree))) (if (zerop rbgbccount) nil rbgbccount)) (format t "~10D pages for cells~%~%" npage) (format t "~10D total pages in core~%" (+ npage ncbpage nrbpage)) (format t "~10D current core maximum pages~%" (+ maxnpage maxcbpage maxrbpage)) (format t "~10D pages reserved for gc~%" nrbpage) (format t "~10D pages available for adding to core~%" leftpage) (format t "~10D pages reserved for core exhaustion~%~%" (- maxpage (+ maxnpage maxcbpage (ash maxrbpage 1) leftpage))) (format t "~10D maximum pages~%" maxpage) (values) ) (when x (format t "~%~%") (format t "Key:~%~%WS: words per struct~%UP: allocated pages~%MP: maximum pages~%FI: fraction of cells in use on allocated pages~%GC: number of gc triggers allocating this type~%~%") (heaprep)) (values)) ;;; C Interface. (defmacro Clines (&rest r) nil) (defmacro defCfun (&rest r) nil) (defmacro defentry (&rest r) nil) (defmacro defla (&rest r) (cons 'defun r)) ;;; Help. (export '(help help*)) (defun help (&optional (symbol nil s)) (if s (si::print-doc symbol) (progn (princ " Welcome to GNU Common Lisp (GCL for short). Here are some functions you should learn first. (HELP symbol) prints the online documentation associated with the symbol. For example, (HELP 'CONS) will print the useful information about the CONS function, the CONS data type, and so on. (HELP* string) prints the online documentation associated with those symbols whose print-names have the string as substring. For example, (HELP* \"PROG\") will print the documentation of the symbols such as PROG, PROGN, and MULTIPLE-VALUE-PROG1. (SI::INFO ) chooses from a list of all references in the on-line documentation to . (APROPOS ) or (APROPOS ') list all symbols containing . (DESCRIBE ') or (HELP ') describe particular symbols. (BYE) or (BY) ends the current GCL session. Good luck! The GCL Development Team") (values)))) (defun help* (string &optional (package (find-package "LISP"))) (si::apropos-doc string package)) ;;; Pretty-print-formats. ;;; ;;; The number N as the property of a symbol SYMBOL indicates that, ;;; in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM ;;; are the 'body' of the form and thus are treated in a special way by ;;; the KCL pretty-printer. (setf (get 'lambda 'si:pretty-print-format) 1) (setf (get 'lambda-block 'si:pretty-print-format) 2) (setf (get 'lambda-closure 'si:pretty-print-format) 4) (setf (get 'lambda-block-closure 'si:pretty-print-format) 5) (setf (get 'block 'si:pretty-print-format) 1) (setf (get 'case 'si:pretty-print-format) 1) (setf (get 'catch 'si:pretty-print-format) 1) (setf (get 'ccase 'si:pretty-print-format) 1) (setf (get 'clines 'si:pretty-print-format) 0) (setf (get 'compiler-let 'si:pretty-print-format) 1) (setf (get 'cond 'si:pretty-print-format) 0) (setf (get 'ctypecase 'si:pretty-print-format) 1) (setf (get 'defcfun 'si:pretty-print-format) 2) (setf (get 'define-setf-method 'si:pretty-print-format) 2) (setf (get 'defla 'si:pretty-print-format) 2) (setf (get 'defmacro 'si:pretty-print-format) 2) (setf (get 'defsetf 'si:pretty-print-format) 3) (setf (get 'defstruct 'si:pretty-print-format) 1) (setf (get 'deftype 'si:pretty-print-format) 2) (setf (get 'defun 'si:pretty-print-format) 2) (setf (get 'do 'si:pretty-print-format) 2) (setf (get 'do* 'si:pretty-print-format) 2) (setf (get 'do-symbols 'si:pretty-print-format) 1) (setf (get 'do-all-symbols 'si:pretty-print-format) 1) (setf (get 'do-external-symbols 'si:pretty-print-format) 1) (setf (get 'dolist 'si:pretty-print-format) 1) (setf (get 'dotimes 'si:pretty-print-format) 1) (setf (get 'ecase 'si:pretty-print-format) 1) (setf (get 'etypecase 'si:pretty-print-format) 1) (setf (get 'eval-when 'si:pretty-print-format) 1) (setf (get 'flet 'si:pretty-print-format) 1) (setf (get 'labels 'si:pretty-print-format) 1) (setf (get 'let 'si:pretty-print-format) 1) (setf (get 'let* 'si:pretty-print-format) 1) (setf (get 'locally 'si:pretty-print-format) 0) (setf (get 'loop 'si:pretty-print-format) 0) (setf (get 'macrolet 'si:pretty-print-format) 1) (setf (get 'multiple-value-bind 'si:pretty-print-format) 2) (setf (get 'multiple-value-prog1 'si:pretty-print-format) 1) (setf (get 'prog 'si:pretty-print-format) 1) (setf (get 'prog* 'si:pretty-print-format) 1) (setf (get 'prog1 'si:pretty-print-format) 1) (setf (get 'prog2 'si:pretty-print-format) 2) (setf (get 'progn 'si:pretty-print-format) 0) (setf (get 'progv 'si:pretty-print-format) 2) (setf (get 'return 'si:pretty-print-format) 0) (setf (get 'return-from 'si:pretty-print-format) 1) (setf (get 'tagbody 'si:pretty-print-format) 0) (setf (get 'the 'si:pretty-print-format) 1) (setf (get 'throw 'si:pretty-print-format) 1) (setf (get 'typecase 'si:pretty-print-format) 1) (setf (get 'unless 'si:pretty-print-format) 1) (setf (get 'unwind-protect 'si:pretty-print-format) 0) (setf (get 'when 'si:pretty-print-format) 1) (setf (get 'with-input-from-string 'si:pretty-print-format) 1) (setf (get 'with-open-file 'si:pretty-print-format) 1) (setf (get 'with-open-stream 'si:pretty-print-format) 1) (setf (get 'with-output-to-string 'si:pretty-print-format) 1) gcl-2.6.14/lsp/dbind.lisp0000755000175000017500000000050214360276512013542 0ustar cammcamm(in-package 'si) ;(defun joe () ; (dbind ((a) b) (foo) (print (list a b)))) (defmacro destructuring-bind (al val &body body &aux *dl* (*key-check* nil) (*arg-check* nil) (sym (gensym))) (dm-vl al sym t) `(compiler::stack-let ((,sym (cons nil ,val))) (let* (,@ (nreverse *dl*)) ,@body))) gcl-2.6.14/lsp/gcl_setf.lsp0000755000175000017500000005102014360276512014100 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; setf.lsp ;;;; ;;;; setf routines (in-package :si) (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) ;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol))) (eval-when (eval compile) (setq si:*inhibit-macro-special* nil)) ;;; DEFSETF macro. (defmacro defsetf (access-fn &rest rest) (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest)))) `(eval-when(compile eval load) (si:putprop ',access-fn ',(car rest) 'setf-update-fn) (remprop ',access-fn 'setf-lambda) (remprop ',access-fn 'setf-method) (si:putprop ',access-fn ,(when (not (endp (cdr rest))) (unless (stringp (cadr rest)) (error "A doc-string expected.")) (unless (endp (cddr rest)) (error "Extra arguments.")) (cadr rest)) 'setf-documentation) ',access-fn)) (t (unless (= (list-length (cadr rest)) 1) (error "(store-variable) expected.")) `(eval-when (compile eval load) (si:putprop ',access-fn ',rest 'setf-lambda) (remprop ',access-fn 'setf-update-fn) (remprop ',access-fn 'setf-method) (si:putprop ',access-fn ,(find-documentation (cddr rest)) 'setf-documentation) ',access-fn)))) ;;; DEFINE-SETF-METHOD macro. (defmacro define-setf-method (access-fn &rest rest &aux args env body) (multiple-value-setq (args env) (get-&environment (car rest))) (setq body (cdr rest)) (cond (env (setq args (cons env args))) (t (setq args (cons (gensym) args)) (push `(declare (ignore ,(car args))) body))) `(eval-when (compile eval load) (si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method) (remprop ',access-fn 'setf-lambda) (remprop ',access-fn 'setf-update-fn) (si:putprop ',access-fn ,(find-documentation (cdr rest)) 'setf-documentation) ',access-fn)) ;;; GET-SETF-EXPANSION. ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE ;;; and checks the number of the store variable. (defun get-setf-expansion (form &optional env) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value form env) (unless (= (list-length stores) 1) (error "Multiple store-variables are not allowed.")) (values vars vals stores store-form access-form))) ;;;; GET-SETF-METHOD-MULTIPLE-VALUE. (defun get-setf-method-multiple-value (form &optional env &aux tem) (cond ((symbolp form) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form))) ((or (not (consp form)) (not (symbolp (car form)))) (error "Cannot get the setf-method of ~S." form)) ((and env (setq tem (assoc (car form) (second env)))) (setq tem (macroexpand form env)) (if (eq form tem) (error "Cannot get setf-method for ~a" form)) (return-from get-setf-method-multiple-value (get-setf-method-multiple-value tem env))) ((get (car form) 'setf-method) (apply (get (car form) 'setf-method) env (cdr form))) ((or (get (car form) 'setf-update-fn) (setq tem (get (car form) 'si::structure-access))) (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym))) (values vars (cdr form) (list store) (cond (tem (setf-structure-access (car vars) (car tem) (cdr tem) store)) (t `(,(get (car form) 'setf-update-fn) ,@vars ,store))) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym)) (l (get (car form) 'setf-lambda)) ;; this looks bogus to me. What if l is compiled?--wfs (f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l))))) (values vars (cdr form) (list store) (funcall (apply f vars) store) (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand form))) (t (error 'program-error :format-control "Cannot expand the SETF form ~S." :format-arguments (list form))))) ;;;; SETF definitions. (defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y)) (defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y)) (defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y)) (defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y)) (defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) (defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y)) (defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y)) (defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y)) (defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y)) (defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y)) (defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y)) (defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y)) (defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) (defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y)) (defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y)) (defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y)) (defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y)) (defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y)) (defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y)) (defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y)) (defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y)) (defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y)) (defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y)) (defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y)) (defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y)) (defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y)) (defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y)) (defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y)) (defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) (defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y)) (defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y)) (defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) (defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) (defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) (defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y)) (defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y)) (defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y)) (defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y)) (defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y)) (defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y)) (defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y)) (defsetf svref si:svset) (defsetf elt si:elt-set) (defsetf symbol-value set) (defsetf symbol-function si:fset) (defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v)) (defsetf aref si:aset) (defsetf get put-aux) (defmacro put-aux (a b &rest l) `(si::sputprop ,a ,b ,(car (last l)))) (defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v)) (defsetf char si:char-set) (defsetf schar si:schar-set) (defsetf bit si:aset) (defsetf sbit si:aset) (defsetf fill-pointer si:fill-pointer-set) (defsetf symbol-plist si:set-symbol-plist) (defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v)) (defsetf row-major-aref si:aset1) (defsetf readtable-case si::set-readtable-case) (defsetf compiler-macro-function (x) (y) `(setf (get ,x 'compiler-macro) ,y)) (defsetf documentation (s d) (v) `(case ,d (variable (si:putprop ,s ,v 'variable-documentation)) (function (si:putprop ,s ,v 'function-documentation)) (structure (si:putprop ,s ,v 'structure-documentation)) (type (si:putprop ,s ,v 'type-documentation)) (setf (si:putprop ,s ,v 'setf-documentation)) (t (error "~S is an illegal documentation type." ,d)))) (define-setf-method getf (&environment env place indicator &optional default) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) (let ((itemp (gensym)) (store (gensym))) (values `(,@vars ,itemp) `(,@vals ,indicator) (list store) `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp))) ,store-form ,store) `(getf ,access-form ,itemp ,default))))) (defsetf subseq (sequence1 start1 &optional end1) (sequence2) `(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1)) (define-setf-method the (&environment env type form) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion form env) (let ((store (gensym))) (values vars vals (list store) `(let ((,(car stores) (the ,type ,store))) ,store-form) `(the ,type ,access-form))))) #| (define-setf-method apply (&environment env fn &rest rest) (unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn)) (null (cddr fn))) (error "Can't get the setf-method of ~S." fn)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion (cons (cadr fn) rest) env) (unless (eq (car (last store-form)) (car (last vars))) (error "Can't get the setf-method of ~S." fn)) (values vars vals stores `(apply #',(car store-form) ,@(cdr store-form)) `(apply #',(cadr fn) ,@(cdr access-form))))) |# (define-setf-method apply (&environment env fn &rest rest) (unless (and (consp fn) (or (eq (car fn) 'function) (eq (car fn) 'quote)) (symbolp (cadr fn)) (null (cddr fn))) (error "Can't get the setf-method of ~S." fn)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion (cons (cadr fn) rest) env) (cond ((eq (car (last store-form)) (car (last vars))) (values vars vals stores `(apply #',(car store-form) ,@(cdr store-form)) `(apply #',(cadr fn) ,@(cdr access-form)))) ((eq (car (last (butlast store-form))) (car (last vars))) (values vars vals stores `(apply #',(car store-form) ,@(cdr (butlast store-form 2)) (append ,(car (last (butlast store-form))) (list ,(car (last store-form))))) `(apply #',(cadr fn) ,@(cdr access-form)))) (t (error "Can't get the setf-method of ~S." fn))))) (define-setf-method char-bit (&environment env char name) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion char env) (let ((ntemp (gensym)) (store (gensym)) (stemp (first stores))) (values `(,ntemp ,@temps) `(,name ,@vals) (list store) `(let ((,stemp (set-char-bit ,access-form ,ntemp ,store))) ,store-form ,store) `(char-bit ,access-form ,ntemp))))) (define-setf-method ldb (&environment env bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (let ((btemp (gensym)) (store (gensym)) (stemp (first stores))) (values `(,btemp ,@temps) `(,bytespec ,@vals) (list store) `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) `(ldb ,btemp ,access-form))))) (define-setf-method mask-field (&environment env bytespec int) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) (let ((btemp (gensym)) (store (gensym)) (stemp (first stores))) (values `(,btemp ,@temps) `(,bytespec ,@vals) (list store) `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) ,store-form ,store) `(mask-field ,btemp ,access-form))))) ;;; The expansion function for SETF. (defun setf-expand-1 (place newvalue env &aux g) (when (and (consp place) (eq (car place) 'the)) (return-from setf-expand-1 (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env))) (when (and (consp place) (eq (car place) 'values)) (do ((vl (cdr place) (cdr vl)) (sym (gensym)) (forms nil) (n 0 (1+ n))) ((endp vl) (return-from setf-expand-1 `(let ((,sym (multiple-value-list ,newvalue))) (values ,@(nreverse forms))))) (declare (fixnum n) (object vl)) (let ((method (if (symbolp (car vl)) 'setq 'setf))) (push `(,method ,(car vl) (nth ,n ,sym)) forms)))) (when (symbolp place) (return-from setf-expand-1 `(setq ,place ,newvalue))) (when (and (consp place) (not (or (get (car place) 'setf-lambda) (get (car place) 'setf-update-fn)))) (multiple-value-setq (place g) (macroexpand place env)) (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env)))) (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn))) (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue))) (cond ((and (symbolp (car place)) (setq g (get (car place) 'structure-access))) (return-from setf-expand-1 (setf-structure-access (cadr place) (car g) (cdr g) newvalue)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) (declare (ignore access-form)) `(let* ,(mapcar #'list (append vars stores) (append vals (list newvalue))) ,store-form))) (defun setf-structure-access (struct type index newvalue) (case type (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) (vector `(si:elt-set ,struct ,index ,newvalue)) (t `(si::structure-set ,struct ',type ,index ,newvalue)))) (defun setf-expand (l env) (cond ((endp l) nil) ((endp (cdr l)) (error "~S is an illegal SETF form." l)) (t (cons (setf-expand-1 (car l) (cadr l) env) (setf-expand (cddr l) env))))) ;;; SETF macro. (defun setf-helper (rest env) (setq rest (cdr rest)) (cond ((endp rest) nil) ((endp (cdr rest)) (error "~S is an illegal SETF form." rest)) ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) (t (cons 'progn (setf-expand rest env))))) ;(setf (macro-function 'setf) 'setf-help) (si::fset 'setf (cons 'macro (symbol-function 'setf-helper))) ;;; PSETF macro. (defmacro psetf (&environment env &rest rest) (cond ((endp rest) nil) ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest)) ((endp (cddr rest)) `(progn ,(setf-expand-1 (car rest) (cadr rest) env) nil)) (t (do ((r rest (cddr r)) (pairs nil) (store-forms nil)) ((endp r) `(let* ,pairs ,@(nreverse store-forms) nil)) (when (endp (cdr r)) (error "~S is an illegal PSETF form." rest)) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion (car r) env) (declare (ignore access-form)) (setq store-forms (cons store-form store-forms)) (setq pairs (nconc pairs (mapcar #'list (append vars stores) (append vals (list (cadr r))))))))))) ;;; SHIFTF macro. (defmacro shiftf (&environment env &rest rest ) (do ((r rest (cdr r)) (pairs nil) (stores nil) (store-forms nil) (g (gensym)) (access-forms nil)) ((endp (cdr r)) (setq stores (nreverse stores)) (setq store-forms (nreverse store-forms)) (setq access-forms (nreverse access-forms)) `(let* ,(nconc pairs (list (list g (car access-forms))) (mapcar #'list stores (cdr access-forms)) (list (list (car (last stores)) (car r)))) ,@store-forms ,g)) (multiple-value-bind (vars vals stores1 store-form access-form) (get-setf-expansion (car r) env) (setq pairs (nconc pairs (mapcar #'list vars vals))) (setq stores (cons (car stores1) stores)) (setq store-forms (cons store-form store-forms)) (setq access-forms (cons access-form access-forms))))) ;;; ROTATEF macro. (defmacro rotatef (&environment env &rest rest ) (do ((r rest (cdr r)) (pairs nil) (stores nil) (store-forms nil) (access-forms nil)) ((endp r) (setq stores (nreverse stores)) (setq store-forms (nreverse store-forms)) (setq access-forms (nreverse access-forms)) `(let* ,(nconc pairs (mapcar #'list stores (cdr access-forms)) (list (list (car (last stores)) (car access-forms)))) ,@store-forms nil )) (multiple-value-bind (vars vals stores1 store-form access-form) (get-setf-expansion (car r) env) (setq pairs (nconc pairs (mapcar #'list vars vals))) (setq stores (cons (car stores1) stores)) (setq store-forms (cons store-form store-forms)) (setq access-forms (cons access-form access-forms))))) ;;; DEFINE-MODIFY-MACRO macro. (defmacro define-modify-macro (name lambda-list function &optional doc-string) (let ((update-form (do ((l lambda-list (cdr l)) (vs nil)) ((null l) `(list ',function access-form ,@(nreverse vs))) (unless (eq (car l) '&optional) (if (eq (car l) '&rest) (return `(list* ',function access-form ,@(nreverse vs) ,(cadr l)))) (if (symbolp (car l)) (setq vs (cons (car l) vs)) (setq vs (cons (caar l) vs))))))) `(defmacro ,name (&environment env reference . ,lambda-list) ,@(if doc-string (list doc-string)) (when (symbolp reference) (return-from ,name (let ((access-form reference)) (list 'setq reference ,update-form)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion reference env) (list 'let* (mapcar #'list (append vars stores) (append vals (list ,update-form))) store-form)))))))))))))))))))) ;;; Some macro definitions. (defmacro remf (&environment env place indicator) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) `(let* ,(mapcar #'list vars vals) (multiple-value-bind (,(car stores) flag) (si:rem-f ,access-form ,indicator) ,store-form flag)))) (define-modify-macro incf (&optional (delta 1)) +) (define-modify-macro decf (&optional (delta 1)) -) (defmacro push (&environment env item place) (let ((myitem (gensym))) (when (symbolp place) (return-from push `(let* ((,myitem ,item)) (setq ,place (cons ,myitem ,place))))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) `(let* ,(mapcar #'list (append (list myitem) vars stores) (append (list item) vals (list (list 'cons myitem access-form)))) ,store-form)))) (defmacro pushnew (&environment env item place &rest rest) (let ((myitem (gensym))) (cond ((symbolp place) (return-from pushnew `(let* ((,myitem ,item)) (setq ,place (adjoin ,myitem ,place ,@rest)))))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) `(let* ,(mapcar #'list (append (list myitem) vars stores) (append (list item) vals (list (list* 'adjoin myitem access-form rest)))) ,store-form)))) (defmacro pop (&environment env place) (when (symbolp place) (return-from pop (let ((temp (gensym))) `(let ((,temp (car ,place))) (setq ,place (cdr ,place)) ,temp)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) `(let* ,(mapcar #'list (append vars stores) (append vals (list (list 'cdr access-form)))) (prog1 (car ,access-form) ,store-form)))) gcl-2.6.14/lsp/gcl_sharp_uv.lsp0000644000175000017500000000155414360276512014772 0ustar cammcamm(in-package :si) (defun regexp-conv (stream) (let ((tem (make-array 10 :element-type 'character :fill-pointer 0))) (or (eql (read-char stream) #\") (error "sharp-u-reader reader needs a \" right after it")) (loop (let ((ch (read-char stream))) (cond ((eql ch #\") (return tem)) ((eql ch #\\) (setq ch (read-char stream)) (setq ch (or (cdr (assoc ch '((#\n . #\newline) (#\t . #\tab) (#\r . #\return)))) ch)))) (vector-push-extend ch tem))) tem)) (defun sharp-u-reader (stream subchar arg) (declare (ignore subchar arg)) (regexp-conv stream)) (defun sharp-v-reader (stream subchar arg) (declare (ignore subchar arg)) `(load-time-value (compile-regexp ,(regexp-conv stream)))) (set-dispatch-macro-character #\# #\u 'sharp-u-reader) (set-dispatch-macro-character #\# #\v 'sharp-v-reader) gcl-2.6.14/lsp/gcl_info.lsp0000755000175000017500000003710614360276512014103 0ustar cammcamm(in-package :si) (eval-when (compile eval) (defmacro while (test &body body) `(slooP::sloop while ,test do ,@ body)) (defmacro f (op x y) `(the ,(if (get op 'compiler::predicate) 't 'fixnum) (,op (the fixnum ,x) (the fixnum ,y)))) (defmacro fcr (x) `(load-time-value (compile-regexp ,x)))) (defconstant +crlu+ (compile-regexp #u"")) (defconstant +crnp+ (compile-regexp #u"[ ]")) (defvar *info-data* nil) (defvar *current-info-data* nil) (defun file-to-string (file &optional (start 0) &aux (si::*ALLOW-GZIPPED-FILE* t)(len 0)) (with-open-file (st file) (setq len (file-length st)) (or (and (<= 0 start ) (<= start len)) (error "illegal file start ~a" start)) (let ((tem (make-array (- len start) :element-type 'character))) (if (> start 0) (file-position st start)) (si::fread tem 0 (length tem) st) tem))) (defun atoi (string start &aux (ans 0) (ch 0)(len (length string))) (declare (string string)) (declare (fixnum start ans ch len) ) (while (< start len) (setq ch (char-code (aref string start))) (setq start (+ start 1)) (setq ch (- ch #.(char-code #\0))) (cond ((and (>= ch 0) (< ch 10)) (setq ans (+ ch (* 10 ans)))) (t (return nil)))) ans)) (defun info-get-tags (file &aux (lim 0) *match-data* tags files (*case-fold-search* t)) (declare (fixnum lim)) (let ((s (file-to-string file)) (i 0)) (declare (fixnum i) (string s)) (cond ((f >= (string-match (fcr #u"[ \n]+Indirect:") s 0) 0) (setq i (match-end 0)) (setq lim (string-match +crlu+ s i)) (while (f >= (string-match (fcr #u"\n([^\n]+): ([0-9]+)") s i lim) 0) (setq i (match-end 0)) (setq files (cons(cons (atoi s (match-beginning 2)) (get-match s 1) ) files))))) (cond ((f >= (si::string-match (fcr #u"[\n ]+Tag Table:") s i) 0) (setq i (si::match-end 0)) (cond ((f >= (si::string-match +crlu+ s i) 0) (setq tags (subseq s i (si::match-end 0))))))) (if files (or tags (info-error "Need tags if have multiple files"))) (list* tags (nreverse files)))) (defun re-quote-string (x &aux (i 0) ch (extra 0)) (declare (fixnum i extra)) (let ((x (if (stringp x) x (string x)))) (declare (string x)) (let (tem (len (length x))) (declare (fixnum len)) (tagbody AGAIN (while (< i len) (setq ch (aref x i)) (cond ((position ch "\\()[]+.*|^$?") (cond (tem (vector-push-extend #\\ tem)) (t (incf extra))))) (if tem (vector-push-extend ch tem)) (setq i (+ i 1))) (cond (tem ) ((> extra 0) (setq tem (make-array (f + (length x) extra) :element-type 'character :fill-pointer 0)) (setq i 0) (go AGAIN)) (t (setq tem x))) ) tem))) (defun get-match (string i) (subseq string (match-beginning i) (match-end i))) (defun get-nodes (pat node-string &aux (i 0) ans (*case-fold-search* t) *match-data*) (declare (fixnum i)) (when node-string (setq pat (si::string-concatenate "Node: ([^]*" (re-quote-string pat) "[^]*)")) (while (f >= (string-match pat node-string i) 0) (setq i (match-end 0)) (setq ans (cons (get-match node-string 1) ans)) ) (nreverse ans))) (defun get-index-node () (or (third *current-info-data*) (let* ( s (node-string (car (nth 1 *current-info-data*))) (node (and node-string (car (get-nodes "index" node-string))))) (when node (setq s (show-info node nil nil )) (setf (third *current-info-data*) s))))) (defun nodes-from-index (pat &aux (i 0) ans (*case-fold-search* t) *match-data*) (let ((index-string (get-index-node))) (when index-string (setq pat (si::string-concatenate #u"\n\\* ([^:\n]*" (re-quote-string pat) #u"[^:\n]*):[ \t]+([^\t\n,.]+)")) (while (f >= (string-match pat index-string i) 0) (setq i (match-end 0)) (setq ans (cons (cons (get-match index-string 1) (get-match index-string 2)) ans)) ) (nreverse ans)))) (defun get-node-index (pat node-string &aux (node pat) *match-data*) (cond ((null node-string) 0) (t (setq pat (si::string-concatenate "Node: " (re-quote-string pat) "([0-9]+)")) (cond ((f >= (string-match pat node-string) 0) (atoi node-string (match-beginning 1))) (t (info-error "cant find node ~s" node) 0))))) (defun all-matches (pat st &aux (start 0) *match-data*) (declare (fixnum start)) (sloop::sloop while (>= (setq start (si::string-match pat st start)) 0) do nil;(print start) collect (list start (setq start (si::match-end 0))))) (defmacro node (prop x) `(nth ,(position prop '(string begin end header name info-subfile file tags)) ,x)) (defun node-offset (node) (+ (car (node info-subfile node)) (node begin node))) (defvar *info-paths* '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" "/usr/local/gnu/info/" "/usr/share/info/")) (defvar *old-lib-directory* nil) (defun setup-info (name &aux tem file) (unless (eq *old-lib-directory* *lib-directory*) (setq *old-lib-directory* *lib-directory*) (push (string-concatenate *lib-directory* "info/") *info-paths*) (setq *info-paths* (fix-load-path *info-paths*))) (when (equal name "DIR") (setq name "dir")) ;; compressed info reading -- search for gzipped files, and open with base filename ;; relying on si::*allow-gzipped-files* to uncompress (setq file (file-search name *info-paths* '("" ".info" ".gz") nil)) (let ((ext (search ".gz" file))) (when ext (setq file (subseq file 0 ext)))) (unless file (unless (equal name "dir") (let* ((tem (show-info "(dir)Top" nil nil)) *case-fold-search*) (cond ((<= 0 (string-match (string-concatenate "\\(([^(]*" (re-quote-string name) "(.info)?)\\)") tem)) (setq file (get-match tem 1))))))) (IF file (let* ((na (namestring file )));(truename file) (cond ((setq tem (assoc na *info-data* :test 'equal)) (setq *current-info-data* tem)) (t (setq *current-info-data* (list na (info-get-tags na) nil)) (setq *info-data* (cons *current-info-data* *info-data*) )))) (format t "(not found ~s)" name)) nil) (defun get-info-choices (pat type) (if (eql type 'index) (nodes-from-index pat ) (get-nodes pat (car (nth 1 *current-info-data*)))))) (defun add-file (v file &aux (lis v)) (while lis (setf (car lis) (list (car lis) file)) (setq lis (cdr lis))) v) (defvar *info-window* nil) (defvar *tk-connection* nil) (defun info-error (&rest l) (if *tk-connection* (tk::tkerror (apply 'format nil l)) (apply 'error l))) (defvar *last-info-file* nil) ;; cache last file read to speed up lookup since may be gzipped.. (defun info-get-file (pathname) (setq pathname (merge-pathnames pathname (car *current-info-data*))) (cdr (cond ((equal (car *last-info-file*) pathname) *last-info-file*) (t (setq *last-info-file* (cons pathname (file-to-string pathname))))))) (defun waiting (win) (and *tk-connection* (fboundp win) (winfo :exists win :return 'boolean) (funcall win :configure :cursor "watch"))) (defun end-waiting (win) (and (fboundp win) (funcall win :configure :cursor ""))) (defun info-subfile (n &aux ) ; "For an index N return (START . FILE) for info subfile ; which contains N. A second value bounding the limit if known ; is returned. At last file this limit is nil." (let ((lis (cdr (nth 1 *current-info-data*))) ans lim) (and lis (>= n 0) (dolist (v lis) (cond ((> (car v) n ) (setq lim (car v)) (return nil))) (setq ans v) )) (values (or ans (cons 0 (car *current-info-data*))) lim))) ;;used by search (defun info-node-from-position (n &aux (i 0)) (let* ((info-subfile (info-subfile n)) (s (info-get-file (cdr info-subfile))) (end (- n (car info-subfile)))) (while (f >= (string-match +crlu+ s i end) 0) (setq i (match-end 0))) (setq i (- i 1)) (if (f >= (string-match (fcr #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n") s i) 0) (let* ((i (match-beginning 0)) (beg (match-end 0)) (name (get-match s 1)) (end(if (f >= (string-match +crnp+ s beg) 0) (match-beginning 0) (length s))) (node (list* s beg end i name info-subfile *current-info-data*))) node)))) (defun show-info (name &optional position-pattern (use-tk *tk-connection*) &aux info-subfile *match-data* file (initial-offset 0)(subnode -1)) (declare (fixnum subnode initial-offset)) ;;; (pat . node) ;;; node ;;; (node file) ;;; ((pat . node) file) ; (print (list name position-pattern use-tk)) (progn ;decode name (cond ((and (consp name) (consp (cdr name))) (setq file (cadr name) name (car name)))) (cond ((consp name) (setq position-pattern (car name) name (cdr name))))) (or (stringp name) (info-error "bad arg")) (waiting *info-window*) (cond ((f >= (string-match (fcr "^\\(([^(]+)\\)([^)]*)") name) 0) ;; (file)node (setq file (get-match name 1)) (setq name (get-match name 2)) (if (equal name "")(setq name "Top")))) (if file (setup-info file)) (let ((indirect-index (get-node-index name (car (nth 1 *current-info-data*))))) (cond ((null indirect-index) (format t"~%Sorry, Can't find node ~a" name) (return-from show-info nil))) (setq info-subfile (info-subfile indirect-index)) (let* ((s (info-get-file (cdr info-subfile))) (start (- indirect-index (car info-subfile)))) (cond ((f >= (string-match ;; to do fix this ;; see (info)Add for description; ;; the (si::string-concatenate #u"[\n ][^\n]*Node:[ \t]+" (re-quote-string name) #u"[,\t\n][^\n]*\n") s start) 0) (let* ((i (match-beginning 0)) (beg (match-end 0)) (end(if (f >= (string-match +crnp+ s beg) 0) (match-beginning 0) (length s))) (node (list* s beg end i name info-subfile *current-info-data*))) (cond (position-pattern (setq position-pattern (re-quote-string position-pattern)) (let (*case-fold-search* ) (if (or (f >= (setq subnode (string-match (si::string-concatenate #u"\n -+ [A-Za-z ]+: " position-pattern #u"[ \n]") s beg end)) 0) (f >= (string-match position-pattern s beg end) 0)) (setq initial-offset (- (match-beginning 0) beg)) )))) (cond ( use-tk (prog1 (print-node node initial-offset) (end-waiting *info-window*)) ) (t (let ((e (if (and (>= subnode 0) (f >= (string-match (fcr #u"\n -+ [a-zA-Z]") s (let* ((bg (+ beg 1 initial-offset)) (sd (string-match (fcr #u"\n ") s bg end)) (nb (if (minusp sd) bg sd))) nb) end) 0)) (match-beginning 0) end))) ;(print (list beg initial-offset e end)) (subseq s (+ initial-offset beg) e ) ;s ))))) (t (info-error "Cant find node ~a?" name) (end-waiting *info-window*) )) ))) (defvar *default-info-files* '( "gcl-si.info" "gcl-tk.info" "gcl.info")) (defun info-aux (x dirs) (sloop for v in dirs do (setup-info v) append (add-file (get-info-choices x 'node) v) append (add-file (get-info-choices x 'index) v))) (defun info-search (pattern &optional start end &aux limit) ; "search for PATTERN from START up to END where these are indices in ;the general info file. The search goes over all files." (or start (setq start 0)) (while start (multiple-value-bind (file lim) (info-subfile start) (setq limit lim) (and end limit (< end limit) (setq limit end)) (let* ((s (info-get-file (cdr file))) (beg (car file)) (i (- start beg)) (leng (length s))) (cond ((f >= (string-match pattern s i (if limit (- limit beg) leng)) 0) (return-from info-search (+ beg (match-beginning 0)))))) (setq start lim))) -1) #+debug ; try searching (defun try (pat &aux (tem 0) s ) (while (>= tem 0) (cond ((>= (setq tem (info-search pat tem)) 0) (setq s (cdr *last-info-file*)) (print (list tem (list-matches s 0 1 2) (car *last-info-file*) (subseq s (max 0 (- (match-beginning 0) 50)) (min (+ (match-end 0) 50) (length s))))) (setq tem (+ tem (- (match-end 0) (match-beginning 0)))))))) (defun idescribe (name) (let* ((items (info-aux name *default-info-files*))) (dolist (v items) (when (cond ((consp (car v)) (equalp (caar v) name)) (t (equalp (car v) name))) (format t "~%From ~a:~%" v) (princ (show-info v nil nil)))))) (defun info (x &optional (dirs *default-info-files*) &aux wanted *current-info-data* file position-pattern) (unless (consp dirs) (setq dirs *default-info-files*)) (let ((tem (info-aux x dirs))) (cond (*tk-connection* (offer-choices tem dirs) ) (t (when tem (let ((nitems (length tem))) (sloop for i from 0 for name in tem with prev do (setq file nil position-pattern nil) (progn ;decode name (cond ((and (consp name) (consp (cdr name))) (setq file (cadr name) name (car name)))) (cond ((consp name) (setq position-pattern (car name) name (cdr name))))) (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i position-pattern (if (eq file prev) nil (setq prev file)) name)) (if (> (length tem) 1) (format t "~%Enter n, all, none, or multiple choices eg 1 3 : ") (terpri)) (let ((line (if (> (length tem) 1) (read-line) "0")) (start 0) val) (while (equal line "") (setq line (read-line))) (while (multiple-value-setq (val start) (read-from-string line nil nil :start start)) (cond ((numberp val) (setq wanted (cons val wanted))) (t (setq wanted val) (return nil)))) (cond ((consp wanted)(setq wanted (nreverse wanted))) ((symbolp wanted) (setq wanted (and (equal (symbol-name wanted) "ALL") (sloop for i below (length tem) collect i))))) (when wanted ;; Remove invalid (numerical) answers (setf wanted (remove-if #'(lambda (x) (and (integerp x) (>= x nitems))) wanted)) (format t "~%Info from file ~a:" (car *current-info-data*))) (sloop for i in wanted do (princ(show-info (nth i tem))))))))))) ;; idea make info_text window have previous,next,up bindings on keys ;; and on menu bar. Have it bring up apropos menu. allow selection ;; to say spawn another info_text window. The symbol that is the window ;; will carry on its plist the prev,next etc nodes, and the string-to-file ;; cache the last read file as well. Add look up in index file, so that can ;; search an indtqex as well. Could be an optional arg to show-node ;; (defun default-info-hotlist() (namestring (merge-pathnames "hotlist" (user-homedir-pathname)))) (defvar *info-window* nil) (defun add-to-hotlist (node ) (if (symbolp node) (setq node (get node 'node))) (cond (node (with-open-file (st (default-info-hotlist) :direction :output :if-exists :append :if-does-not-exist :create) (cond ((< (file-position st) 10) (princ #u"\nFile:\thotlist\tNode: Top\n\n* Menu: Hot list of favrite info items.\n\n" st))) (format st "* (~a)~a::~%" (node file node)(node name node)))))) (defun list-matches (s &rest l) (sloop for i in l collect (and (f >= (match-beginning i) 0) (get-match s i)))) ;;; Local Variables: *** ;;; mode:lisp *** ;;; version-control:t *** ;;; comment-column:0 *** ;;; comment-start: ";;; " *** ;;; End: *** gcl-2.6.14/lsp/makefile0000644000175000017500000000336214360276512013275 0ustar cammcamm .SUFFIXES: .SUFFIXES: .fn .o .c .lsp -include ../makedefs PORTDIR = ../unixport CAT=cat APPEND=../xbin/append OBJS = gcl_sharp.o gcl_arraylib.o gcl_assert.o gcl_defmacro.o gcl_defstruct.o \ gcl_describe.o gcl_evalmacros.o gcl_fpe.o \ gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \ gcl_packlib.o gcl_predlib.o \ gcl_parse_namestring.o gcl_make_pathname.o gcl_namestring.o gcl_translate_pathname.o\ gcl_logical_pathname_translations.o gcl_directory.o gcl_merge_pathnames.o gcl_truename.o gcl_sharp_uv.o\ gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \ gcl_debug.o gcl_info.o gcl_serror.o gcl_restart.o \ gcl_rename_file.o gcl_pathname_match_p.o gcl_wild_pathname_p.o \ gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS) # export.o autoload.o auto_new.o LISP=$(PORTDIR)/saved_pre_gcl$(EXE) COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile %.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp $(COMPILE_FILE) $* all: $(OBJS) #$(RL_OBJS) .lsp.fn: ../cmpnew/gcl_collectfn.o ../xbin/make-fn $*.lsp $(LISP) all: $(OBJS) fns1: $(FNS) fns: ../cmpnew/gcl_collectfn.o $(MAKE) fns1 -e "FNS=`echo ${OBJS} | sed -e 's:\.o:\.fn:g'`" #../cmpnew/gcl_collectfn.o: ../cmpnew/gcl_collectfn.lsp # (cd ../cmpnew ; $(PORTDIR)/saved_gcl $(PORTDIR)/ gcl_collectfn.lisp gcl_collectfn S1000) clean: rm -f *.o core a.out *.fn *.c *.data *.h allclean: rm -f *.h *.data *.c dummy3 $(NEWCFILES): sys-proclaim.lisp sys-proclaim.lisp: fns echo '(in-package "SYSTEM")' \ '(load "../cmpnew/gcl_collectfn")'\ '(compiler::make-all-proclaims "*.fn")' | ../xbin/gcl newc: $(MAKE) $(OBJS) -e "NEWCFILES=`echo $(OBJS) | sed -e 's:\.o:.c:g'`" gcl-2.6.14/lsp/gcl_fpe.lsp0000644000175000017500000001237114360276512013714 0ustar cammcamm(in-package :fpe) (import 'si::(disassemble-instruction feenableexcept fedisableexcept fld *fixnum *float *double +fe-list+ +mc-context-offsets+ floating-point-error function-by-address clines defentry)) (export '(break-on-floating-point-exceptions read-instruction)) (eval-when (eval compile) (defconstant +feallexcept+ (reduce 'logior (mapcar 'caddr +fe-list+))) (defun moff (i r) (* i (cdr r))) (defun stl (s &aux (s (if (stringp s) (make-string-input-stream s) s))(x (read s nil 'eof))) (unless (eq x 'eof) (cons x (stl s)))) (defun ml (r) (when r (make-list (truncate (car r) (cdr r))))) (defun mcgr (r &aux (i -1)) (mapcar (lambda (x y) `(defconstant ,x ,(moff (incf i) r))) (when r (stl (pop r))) (ml r))) (defun mcr (p r &aux (i -1)) (mapcar (lambda (x) `(defconstant ,(intern (concatenate 'string p (write-to-string (incf i))) :fpe) ,(moff i r))) (ml r))) (defmacro deft (n rt args &rest code) `(progn (clines ,(nstring-downcase (apply 'concatenate 'string (symbol-name rt) " " (symbol-name n) "(" (apply 'concatenate 'string (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) (when (cdr x) (list ", ")))) args)) ") " code))) (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n))))))) #.`(progn ,@(mcgr (first +mc-context-offsets+))) #.`(progn ,@(mcr "ST" (second +mc-context-offsets+))) #.`(progn ,@(mcr "XMM" (third +mc-context-offsets+))) (defconstant +top-readtable+ (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\, #\Space) (set-syntax-from-char #\; #\a) (set-macro-character #\0 '0-reader) (set-macro-character #\$ '0-reader) (set-macro-character #\- '0-reader) (set-macro-character #\% '%-reader) (set-macro-character #\( 'paren-reader) *readtable*)) (defconstant +sub-readtable+ (let ((*readtable* (copy-readtable +top-readtable+))) (set-syntax-from-char #\0 #\a) *readtable*)) (defvar *offset* 0) (defvar *insn* nil) (defvar *context* nil) (defun rf (addr w) (ecase w (4 (*float addr 0 nil nil)) (8 (*double addr 0 nil nil)))) (defun ref (addr p w &aux (i -1)) (if p (map-into (make-list (truncate 16 w)) (lambda nil (rf (+ addr (* w (incf i))) w))) (rf addr w))) (defun gref (addr &aux (z (symbol-name *insn*))(lz (length z))(lz (if (eql (aref z (- lz 3)) #\2) (- lz 3) lz)) (f (eql #\F (aref z 0)))) (ref addr (unless f (eql (aref z (- lz 2)) #\P)) (if (or f (eql (aref z (1- lz)) #\D)) 8 4))) (defun reg-lookup (x) (*fixnum (+ (car *context*) (symbol-value x)) 0 nil nil)) (defun st-lookup (x) (fld (+ (cadr *context*) (symbol-value x)))) (defun xmm-lookup (x) (gref (+ (caddr *context*) (symbol-value x)))) (defun lookup (x &aux (z (symbol-name x))) (case (aref z 0) (#\X (xmm-lookup x)) (#\S (st-lookup x)) (otherwise (reg-lookup x)))) (defun %-reader (stream subchar &aux (*readtable* +sub-readtable+)(*package* (find-package :fpe))) (declare (ignore subchar)) (let ((x (read stream))) (lookup (if (eq x 'st) (intern (concatenate 'string (symbol-name x) (write-to-string (if (eql (peek-char nil stream nil 'eof) #\() (let ((ch (read-char stream))(x (read stream))(ch (read-char stream))) (declare (ignore ch)) x) 0))) :fpe) x)))) (defun 0-reader (stream subchar &aux a (s 1)(*readtable* +sub-readtable+)) (when (eql subchar #\$) (setq a t subchar (read-char stream))) (when (eql subchar #\-) (setq s -1 subchar (read-char stream))) (assert (eql subchar #\0)) (assert (eql (read-char stream) #\x)) (let* ((*read-base* 16)(x (* s (read stream)))) (if a x (let ((*offset* x)) (read stream))))) (defun paren-reader (stream subchar &aux (*readtable* +sub-readtable+)) (declare (ignore subchar)) (let* ((x (read-delimited-list #\) stream))) (gref (+ *offset* (pop x) (if x (* (pop x) (car x)) 0))))) (defun read-operands (s context &aux (*context* context)) (read-delimited-list #\; s)) (defun read-instruction (addr context &aux (*readtable* +top-readtable+) (i (car (disassemble-instruction addr)))(s (make-string-input-stream i)) (*insn* (read s))) (cons i (cons *insn* (when context (read-operands s context))))) (defun fe-enable (a) (declare (fixnum a)) (fedisableexcept) (feenableexcept a)) #.`(let ((fpe-enabled 0)) (defun break-on-floating-point-exceptions (&key suspend ,@(mapcar (lambda (x) `(,(car x) (logtest ,(caddr x) fpe-enabled))) +fe-list+) &aux r) (fe-enable (if suspend 0 (setq fpe-enabled (logior ,@(mapcar (lambda (x) `(cond (,(car x) (push ,(intern (symbol-name (car x)) :keyword) r) ,(caddr x)) (0))) +fe-list+))))) r)) (defun floating-point-error (code addr context) (break-on-floating-point-exceptions :suspend t) (unwind-protect (let* ((fun (function-by-address addr))(m (read-instruction addr context))) ((lambda (&rest r) (apply 'error (if (find-package :conditions) r (list (format nil "~s" r))))) (or (caar (member code +fe-list+ :key 'cadr)) 'arithmetic-error) :operation (list :insn (pop m) :op (pop m) :fun fun :addr addr) :operands m)) (break-on-floating-point-exceptions))) gcl-2.6.14/lsp/fast-mv.lisp0000755000175000017500000000242514360276512014045 0ustar cammcamm(in-package 'compiler) ;; Author W. Schelter ;; Using fast-values in place of values, and fast-multiple-setq ;; allow functions to still be declared to have only 1 value, while ;; in effect returning several. This allows a great speed up in ;; returning extra values. Eventually we may incorporate this system ;; to allow similar code to be put out where multiple values are proclaimed ;; for the function. ;; The primitives set-mv and mv-ref provide access to 10 storage places ;; directly by address, without the indirection of going through an array ;; or symbol. ;; Sample usage: ;;(proclaim '(function goo-fast-mv () t)) ;;(proclaim '(function foo-fast-mv (t) t)) ;; ;;(defun foo-fast-mv (n) ;; (let (x y z) ;; (sloop for i below n ;; do (fast-multiple-value-setq (x y z) (goo-fast-mv))) ;; (list x y z))) ;; ;;(defun goo-fast-mv () (fast-values 1 2 7)) (defmacro fast-values (a &rest l) (or (< (length l) 10) (error "too many values")) `(prog1 ,a ,@ (sloop::sloop for v in l for i below 10 collect `(si::set-mv ,i ,v)))) (defmacro fast-multiple-value-setq ((x &rest l) form) (or (< (length l) 10) (error "too many values")) `(prog1 (setq ,x ,form) ,@ (sloop::sloop for i below 10 for v in l collect `(setq ,v (si::mv-ref ,i))))) gcl-2.6.14/lsp/gcl_pathname_match_p.lsp0000644000175000017500000000100414360276512016421 0ustar cammcamm(in-package :si) (defun to-regexp (x &optional (rp t) &aux (px (pathname x))(lp (typep px 'logical-pathname))) (to-regexp-or-namestring (mlp px) rp lp)) (deftype compiled-regexp nil `(vector unsigned-char)) (defun pathname-match-p (p w &aux (s (namestring p))) (declare (optimize (safety 1))) (check-type p pathname-designator) (check-type w (or compiled-regexp pathname-designator)) (and (zerop (string-match (if (typep w 'compiled-regexp) w (to-regexp w)) s)) (eql (match-end 0) (length s)))) gcl-2.6.14/lsp/gcl_stdlisp.lsp0000755000175000017500000000304614360276512014626 0ustar cammcamm ;; Loading the following causes these non standard symbols in the LISP ;; package, to no longer be automatically exported to packages which ;; use LISP. For example BYE will no longer be accessible from package ;; USER. You will need to type (lisp::bye) to quit. Of course references ;; to BYE before this file was loaded will mean the symbol BYE in the lisp ;; package. ;; Someday this file may be loaded by default in GCL, so you should ;; probably use the LISP:: prefix for these symbols, as protection ;; against that day. (unexport '(LISP::LAMBDA-BLOCK-CLOSURE LISP::BYE LISP::QUIT LISP::EXIT LISP::IEEE-FLOATING-POINT LISP::DEFENTRY LISP::VOID LISP::ALLOCATE-CONTIGUOUS-PAGES LISP::UNSIGNED-SHORT LISP::DOUBLE LISP::BY LISP::GBC LISP::DEFCFUN LISP::SAVE LISP::MAXIMUM-CONTIGUOUS-PAGES LISP::SPICE LISP::DEFLA LISP::ALLOCATED-PAGES LISP::SUN LISP::INT LISP::USE-FAST-LINKS LISP::CFUN LISP::UNSIGNED-CHAR LISP::HELP LISP::HELP* LISP::MACRO LISP::*BREAK-ENABLE* LISP::CLINES LISP::LAMBDA-CLOSURE LISP::OBJECT LISP::FAT-STRING LISP::SIGNED-SHORT LISP::MC68020 LISP::LAMBDA-BLOCK LISP::TAG LISP::PROCLAMATION LISP::ALLOCATED-CONTIGUOUS-PAGES LISP::*EVAL-WHEN-COMPILE* LISP::SIGNED-CHAR LISP::*IGNORE-MAXIMUM-PAGES* LISP::*LINK-ARRAY* LISP::KCL LISP::BSD LISP::ALLOCATE-RELOCATABLE-PAGES LISP::ALLOCATE LISP::UNIX LISP::MAXIMUM-ALLOCATABLE-PAGES LISP::ALLOCATED-RELOCATABLE-PAGES LISP::SYSTEM LISP::KYOTO LISP::CCLOSURE) 'LISP )gcl-2.6.14/lsp/gcl_make-declare.lsp0000755000175000017500000000534214360276512015457 0ustar cammcamm;; By W. Schelter ;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp") (in-package 'si) ;; You may wish to adjust the following to output the proclamations ;; for inclusion in a file. All fixed arg functions should be proclaimed ;; before their references for maximum efficiency. ;; CAVEAT: The following code only checks for fixed args, it does ;; not check for single valuedness BUT does make a proclamation ;; to that effect. Unfortunately it is impossible to tell about ;; multiple values without doing a full compiler type pass over ;; all files in the relevant system. However the GCL compiler should ;; warn if you inadvertantly proclaim foo to be single valued and then try ;; to use more than one value. (DEFVAR *DECLARE-T-ONLY* NIL) (DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*) (WITH-OPEN-FILE (FILE NAME :DIRECTION :INPUT) (LET ((EOF (CONS NIL NIL))) (LOOP (LET ((FORM (READ FILE NIL EOF))) (COND ((EQ EOF FORM) (RETURN NIL)) ((MAKE-DECLARE-FORM FORM )))))))) (DEFVAR *DEFUNS* '(DEFUN)) (DEFUN MAKE-DECLARE-FORM (FORM) ; !!! (WHEN (LISTP FORM) (COND ((MEMBER (CAR FORM) '(EVAL-WHEN )) (DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V))) ((MEMBER (CAR FORM) '(PROGN )) (DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V))) ((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT)) (EVAL FORM)) ((MEMBER (CAR FORM) *DEFUNS*) (COND ((AND (CONSP (CADDR FORM)) (NOT (MEMBER '&REST (CADDR FORM))) (NOT (MEMBER '&BODY (CADDR FORM))) (NOT (MEMBER '&KEY (CADDR FORM))) (NOT (MEMBER '&OPTIONAL (CADDR FORM)))) ;;could print declarations here. ;(print (list (cadr form)(ARG-DECLARES (THIRD FORM)(cdddr FORM)))) (FUNCALL 'PROCLAIM (LIST 'FUNCTION (CADR FORM) (ARG-DECLARES (THIRD FORM) (cdddr FORM)) T)))))))) (DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS) (COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS))) (T (SETQ DECLS (CAR DECLS)))) (COND ((AND (not *declare-t-only*) (CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE)) (DO ((V ARGS (CDR V))) ((OR (EQ (CAR V) '&AUX) (NULL V)) (NREVERSE ANS)) (PUSH (DECL-TYPE (CAR V) DECLS) ANS))) (T (MAKE-LIST (- (LENGTH args) (LENGTH (MEMBER '&AUX args))) :INITIAL-ELEMENT T)))) (DEFUN DECL-TYPE (V DECLS) (DOLIST (D (CDR DECLS)) (CASE (CAR D) (TYPE (IF (MEMBER V (CDDR D)) (RETURN-FROM DECL-TYPE (SECOND D)))) ((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT ) (IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D)))))) T) gcl-2.6.14/lsp/gcl_fpe_test.lsp0000644000175000017500000002657214360276512014763 0ustar cammcamm#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (break-on-floating-point-exceptions)))) (flet ((set-break (x) (when (keywordp r) (apply 'break-on-floating-point-exceptions (append (unless x o) (list r x)))))) (let* ((rr (handler-case (unwind-protect (progn (set-break t) (apply f a)) (set-break nil)) ,@(mapcar (lambda (x &aux (x (car x))) `(,x (c) (setq cc c) ,(intern (symbol-name x) :keyword))) (append si::+fe-list+ '((arithmetic-error)(error))))))) (print (list* f a r rr (when cc (list cc (arithmetic-error-operation cc) (arithmetic-error-operands cc))))) (assert (eql r rr)) (when (and chk cc) (unless (eq 'fnop (cadr (member :op (arithmetic-error-operation cc)))) (assert (eq (symbol-function f) (cadr (member :fun (arithmetic-error-operation cc))))) (assert (or (every 'equalp (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a) (arithmetic-error-operands cc)) (every 'equalp (nreverse (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a)) (arithmetic-error-operands cc))))))))) #+(or x86_64 i386) (progn (eval-when (compile eval) (defmacro deft (n rt args &rest code) `(progn (clines ,(nstring-downcase (apply 'concatenate 'string (symbol-name rt) " " (symbol-name n) "(" (apply 'concatenate 'string (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) (when (cdr x) (list ", ")))) args)) ") " code))) (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n))))))) (deft fdivp object ((object x) (object y)) "{volatile double a=lf(x),b=lf(y),c;" "__asm__ __volatile__ (\"fldl %1;fldl %0;fdivp %%st,%%st(1);fstpl %2;fwait\" " ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" "return make_longfloat(c);}") (deft divpd object ((object x) (object y) (object z)) "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;divpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" " ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" "return z;}") (deft divpdm object ((object x) (object y) (object z)) "{__asm__ __volatile__ (\"movapd %1,%%xmm1;divpd %0,%%xmm1;movapd %%xmm1,%2\" " ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" "return z;}") (deft divps object ((object x) (object y) (object z)) "{__asm__ __volatile__ (\"movaps %0,%%xmm0;movaps %1,%%xmm1;divps %%xmm0,%%xmm1;movaps %%xmm1,%2\" " ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" "return z;}") (deft divpsm object ((object x) (object y) (object z)) "{__asm__ __volatile__ (\"movaps %1,%%xmm1;divps %0,%%xmm1;movaps %%xmm1,%2\" " ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" "return z;}") (deft divsd object ((object x) (object y)) "{volatile double a=lf(x),b=lf(y),c;" "__asm__ __volatile__ (\"movsd %0,%%xmm0;movsd %1,%%xmm1;divsd %%xmm1,%%xmm0;movsd %%xmm0,%2\" " ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" "return make_longfloat(c);}") (deft divsdm object ((object x) (object y)) "{volatile double a=lf(x),b=lf(y),c;" "__asm__ __volatile__ (\"movsd %0,%%xmm0;divsd %1,%%xmm0;movsd %%xmm0,%2\" " ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" "return make_longfloat(c);}") (deft divss object ((object x) (object y)) "{volatile float a=sf(x),b=sf(y),c;" "__asm__ __volatile__ (\"movss %0,%%xmm0;movss %1,%%xmm1;divss %%xmm1,%%xmm0;movss %%xmm0,%2\" " ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" "return make_shortfloat(c);}") (deft divssm object ((object x) (object y)) "{volatile float a=sf(x),b=sf(y),c;" "__asm__ __volatile__ (\"movss %0,%%xmm0;divss %1,%%xmm0;movss %%xmm0,%2\" " ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" "return make_shortfloat(c);}") (deft sqrtpd object ((object x) (object y) (object z)) "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;sqrtpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" " ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" "return z;}") (eval-when (compile load eval) (deft c_array_self fixnum ((object x)) "{return (fixnum)x->a.a_self;}") (defun c-array-eltsize (x) (ecase (array-element-type x) (short-float 4) (long-float 8))) (defun make-aligned-array (alignment size &rest r &aux (ic (member :initial-contents r)) y (c (cadr ic)) (r (append (ldiff r ic) (cddr ic))) (a (apply 'make-array (+ alignment size) (list* :static t r)))) (setq y (map-into (apply 'make-array size :displaced-to a :displaced-index-offset (truncate (- alignment (mod (c_array_self a) alignment)) (c-array-eltsize a)) r) 'identity c)) (assert (zerop (mod (c_array_self y) 16))) y)) (setq fa (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.2s0 2.3s0 3.4s0 4.1s0)) fb (make-aligned-array 16 4 :element-type 'short-float) fc (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.3s0 2.4s0 3.5s0 4.6s0)) fx (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element most-positive-short-float)) fm (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element least-positive-normalized-short-float)) fn (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element -1.0s0)) fr (make-aligned-array 16 4 :element-type 'short-float)) (setq da (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.2 2.3)) db (make-aligned-array 16 2 :element-type 'long-float) dc (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.3 2.4)) dx (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element most-positive-long-float)) dm (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element least-positive-normalized-long-float)) dn (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element -1.0)) dr (make-aligned-array 16 2 :element-type 'long-float)) (test-fpe 'fdivp (list 1.0 2.0) 0.5 t) (test-fpe 'fdivp (list 1.0 0.0) :division-by-zero t) (test-fpe 'fdivp (list 0.0 0.0) :floating-point-invalid-operation t) (test-fpe 'fdivp (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow);fstpl (test-fpe 'fdivp (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow);fstpl (test-fpe 'fdivp (list 1.2 1.3) :floating-point-inexact);post args (test-fpe 'divpd (list da da dr) dr t) (test-fpe 'divpd (list db da dr) :division-by-zero t) (test-fpe 'divpd (list db db dr) :floating-point-invalid-operation t) (test-fpe 'divpd (list dm dx dr) :floating-point-overflow t) (test-fpe 'divpd (list dx dm dr) :floating-point-underflow t) (test-fpe 'divpd (list da dc dr) :floating-point-inexact t) (test-fpe 'divpdm (list da da dr) dr t) (test-fpe 'divpdm (list db da dr) :division-by-zero t) (test-fpe 'divpdm (list db db dr) :floating-point-invalid-operation t) (test-fpe 'divpdm (list dm dx dr) :floating-point-overflow t) (test-fpe 'divpdm (list dx dm dr) :floating-point-underflow t) (test-fpe 'divpdm (list da dc dr) :floating-point-inexact t) (test-fpe 'divps (list fa fa fr) fr t) (test-fpe 'divps (list fb fa fr) :division-by-zero t) (test-fpe 'divps (list fb fb fr) :floating-point-invalid-operation t) (test-fpe 'divps (list fm fx fr) :floating-point-overflow t) (test-fpe 'divps (list fx fm fr) :floating-point-underflow t) (test-fpe 'divps (list fa fc fr) :floating-point-inexact t) (test-fpe 'divpsm (list fa fa fr) fr t) (test-fpe 'divpsm (list fb fa fr) :division-by-zero t) (test-fpe 'divpsm (list fb fb fr) :floating-point-invalid-operation t) (test-fpe 'divpsm (list fm fx fr) :floating-point-overflow t) (test-fpe 'divpsm (list fx fm fr) :floating-point-underflow t) (test-fpe 'divpsm (list fa fc fr) :floating-point-inexact t) (test-fpe 'divsd (list 1.0 2.0) 0.5 t) (test-fpe 'divsd (list 1.0 0.0) :division-by-zero t) (test-fpe 'divsd (list 0.0 0.0) :floating-point-invalid-operation t) (test-fpe 'divsd (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) (test-fpe 'divsd (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) (test-fpe 'divsd (list 1.2 2.3) :floating-point-inexact t) (test-fpe 'divsdm (list 1.0 2.0) 0.5 t) (test-fpe 'divsdm (list 1.0 0.0) :division-by-zero t) (test-fpe 'divsdm (list 0.0 0.0) :floating-point-invalid-operation t) (test-fpe 'divsdm (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) (test-fpe 'divsdm (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) (test-fpe 'divsdm (list 1.2 2.3) :floating-point-inexact t) (test-fpe 'divss (list 1.0s0 2.0s0) 0.5s0 t) (test-fpe 'divss (list 1.0s0 0.0s0) :division-by-zero t) (test-fpe 'divss (list 0.0s0 0.0s0) :floating-point-invalid-operation t) (test-fpe 'divss (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) (test-fpe 'divss (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) (test-fpe 'divss (list 1.2s0 2.3s0) :floating-point-inexact t) (test-fpe 'divssm (list 1.0s0 2.0s0) 0.5s0 t) (test-fpe 'divssm (list 1.0s0 0.0s0) :division-by-zero t) (test-fpe 'divssm (list 0.0s0 0.0s0) :floating-point-invalid-operation t) (test-fpe 'divssm (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) (test-fpe 'divssm (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) (test-fpe 'divssm (list 1.2s0 2.3s0) :floating-point-inexact t) (test-fpe 'sqrtpd (list da db dr) dr t) (test-fpe 'sqrtpd (list dn db dr) :floating-point-invalid-operation t) (test-fpe 'sqrtpd (list da db dr) :floating-point-inexact t)) (defun l/ (x y) (declare (long-float x y)) (/ x y)) (defun s/ (x y) (declare (short-float x y)) (/ x y)) (defun lsqrt (x) (declare (long-float x)) (the long-float (sqrt x))) (test-fpe 'l/ (list 1.0 2.0) 0.5 t) (test-fpe 'l/ (list 1.0 0.0) :division-by-zero t) (test-fpe 'l/ (list 0.0 0.0) :floating-point-invalid-operation t) (test-fpe 'l/ (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) (test-fpe 'l/ (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) (test-fpe 'l/ (list 1.2 1.3) :floating-point-inexact t) (test-fpe 's/ (list 1.0s0 2.0s0) 0.5s0 t) (test-fpe 's/ (list 1.0s0 0.0s0) :division-by-zero t) (test-fpe 's/ (list 0.0s0 0.0s0) :floating-point-invalid-operation t) (test-fpe 's/ (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) (test-fpe 's/ (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) (test-fpe 's/ (list 1.2s0 1.3s0) :floating-point-inexact t) (test-fpe 'lsqrt (list 4.0) 2.0 t) (test-fpe 'lsqrt (list -1.0) :floating-point-invalid-operation t) (test-fpe 'lsqrt (list 1.2) :floating-point-inexact t) gcl-2.6.14/lsp/gcl_auto.lsp0000755000175000017500000001553414360276512014121 0ustar cammcamm(in-package :si) ;;; Autoloaders. ;;; DEFAUTOLOAD definitions. for lsp directory files normally loaded. (if (fboundp 'abs) (push :numlib *features*)) ;;hack to avoid interning all the :symbols if the files are loaded.. #-numlib (progn (autoload 'abs '|numlib|) (autoload 'acos '|numlib|) (autoload 'acosh '|numlib|) (autoload 'adjust-array '|arraylib|) (autoload 'apropos '|packlib|) (autoload 'apropos-list '|packlib|) (autoload 'array-dimensions '|arraylib|) (autoload 'array-in-bounds-p '|arraylib|) (autoload 'array-row-major-index '|arraylib|) (autoload 'asin '|numlib|) (autoload 'asinh '|numlib|) (autoload 'atanh '|numlib|) (autoload 'best-array-element-type '|arraylib|) (autoload 'bit '|arraylib|) (autoload 'bit-and '|arraylib|) (autoload 'bit-andc1 '|arraylib|) (autoload 'bit-andc2 '|arraylib|) (autoload 'bit-eqv '|arraylib|) (autoload 'bit-ior '|arraylib|) (autoload 'bit-nand '|arraylib|) (autoload 'bit-nor '|arraylib|) (autoload 'bit-not '|arraylib|) (autoload 'bit-orc1 '|arraylib|) (autoload 'bit-orc2 '|arraylib|) (autoload 'bit-xor '|arraylib|) (autoload 'byte '|numlib|) (autoload 'byte-position '|numlib|) (autoload 'byte-size '|numlib|) (autoload 'cis '|numlib|) (autoload 'coerce '|predlib|) (autoload 'compile-file '|loadcmp|) (autoload 'compile '|loadcmp|) (autoload 'disassemble '|loadcmp|) (autoload 'concatenate '|seq|) (autoload 'cosh '|numlib|) (autoload 'count '|seqlib|) (autoload 'count-if '|seqlib|) (autoload 'count-if-not '|seqlib|) (autoload 'decode-universal-time '|mislib|) (autoload 'delete '|seqlib|) (autoload 'delete-duplicates '|seqlib|) (autoload 'delete-if '|seqlib|) (autoload 'delete-if-not '|seqlib|) (autoload 'deposit-field '|numlib|) (autoload 'describe '|describe|) (autoload 'dpb '|numlib|) (autoload 'dribble '|iolib|) (autoload 'encode-universal-time '|mislib|) (autoload 'every '|seq|) (autoload 'fceiling '|numlib|) (autoload 'ffloor '|numlib|) (autoload 'fill '|seqlib|) (autoload 'find '|seqlib|) (autoload 'find-all-symbols '|packlib|) (autoload 'find-if '|seqlib|) (autoload 'find-if-not '|seqlib|) (autoload 'fround '|numlib|) (autoload 'ftruncate '|numlib|) #-unix (autoload 'get-decoded-time '|mislib|) #+aosvs (autoload 'get-universal-time '|mislib|) (autoload 'get-setf-method '|setf|) (autoload 'get-setf-method-multiple-value '|setf|) (autoload 'inspect '|describe|) (autoload 'intersection '|listlib|) (autoload 'isqrt '|numlib|) (autoload 'ldb '|numlib|) (autoload 'ldb-test '|numlib|) (autoload 'logandc1 '|numlib|) (autoload 'logandc2 '|numlib|) (autoload 'lognand '|numlib|) (autoload 'lognor '|numlib|) (autoload 'lognot '|numlib|) (autoload 'logorc1 '|numlib|) (autoload 'logorc2 '|numlib|) (autoload 'logtest '|numlib|) (autoload 'make-array '|arraylib|) (autoload 'make-sequence '|seq|) (autoload 'map '|seq|) (autoload 'mask-field '|numlib|) (autoload 'merge '|seqlib|) (autoload 'mismatch '|seqlib|) (autoload 'nintersection '|listlib|) (autoload 'notany '|seq|) (autoload 'notevery '|seq|) (autoload 'si::normalize-type ':predlib) (autoload 'nset-difference '|listlib|) (autoload 'nset-exclusive-or '|listlib|) (autoload 'nsubstitute '|seqlib|) (autoload 'nsubstitute-if '|seqlib|) (autoload 'nsubstitute-if-not '|seqlib|) (autoload 'nunion '|listlib|) (autoload 'phase '|numlib|) (autoload 'position '|seqlib|) (autoload 'position-if '|seqlib|) (autoload 'position-if-not '|seqlib|) (autoload 'prin1-to-string '|iolib|) (autoload 'princ-to-string '|iolib|) (autoload 'rational '|numlib|) (autoload 'rationalize '|numlib|) (autoload 'read-from-string '|iolib|) (autoload 'reduce '|seqlib|) (autoload 'remove '|seqlib|) (autoload 'remove-duplicates '|seqlib|) (autoload 'remove-if '|seqlib|) (autoload 'remove-if-not '|seqlib|) (autoload 'replace '|seqlib|) (autoload 'sbit '|arraylib|) (autoload 'search '|seqlib|) (autoload 'set-difference '|listlib|) (autoload 'set-exclusive-or '|listlib|) (autoload 'signum '|numlib|) (autoload 'sinh '|numlib|) (autoload 'some '|seq|) (autoload 'sort '|seqlib|) (autoload 'stable-sort '|seqlib|) (autoload 'subsetp '|listlib|) (autoload 'substitute '|seqlib|) (autoload 'substitute-if '|seqlib|) (autoload 'substitute-if-not '|seqlib|) (autoload 'subtypep '|predlib|) (autoload 'tanh '|numlib|) (autoload 'typep '|predlib|) (autoload 'union '|listlib|) (autoload 'vector '|arraylib|) (autoload 'vector-pop '|arraylib|) (autoload 'vector-push '|arraylib|) (autoload 'vector-extend '|arraylib|) (autoload 'write-to-string '|iolib|) (autoload 'y-or-n-p '|iolib|) (autoload 'yes-or-no-p '|iolib|) (set-dispatch-macro-character #\# #\a 'si::sharp-a-reader) (set-dispatch-macro-character #\# #\A 'si::sharp-a-reader) (autoload 'si::sharp-a-reader '"iolib") (set-dispatch-macro-character #\# #\s 'si::sharp-s-reader) (set-dispatch-macro-character #\# #\S 'si::sharp-s-reader) (autoload 'si::sharp-s-reader '|iolib|) ;;; DEFAUTOLOADMACRO definitions. (autoload-macro 'assert '|assert|) (autoload-macro 'ccase '|assert|) (autoload-macro 'check-type '|assert|) (autoload-macro 'ctypecase '|assert|) (autoload-macro 'decf '|setf|) (autoload-macro 'define-modify-macro '|setf|) (autoload-macro 'define-setf-method '|setf|) (autoload-macro 'defsetf '|setf|) (autoload-macro 'defstruct '|defstruct|) (autoload-macro 'si::define-structure '|defstruct|) (autoload-macro 'deftype '|predlib|) (autoload-macro 'do-all-symbols '|packlib|) (autoload-macro 'do-external-symbols '|packlib|) (autoload-macro 'do-symbols '|packlib|) (autoload-macro 'ecase '|assert|) (autoload-macro 'etypecase '|assert|) (autoload-macro 'incf '|setf|) (autoload-macro 'pop '|setf|) (autoload-macro 'push '|setf|) (autoload-macro 'pushnew '|setf|) (autoload-macro 'remf '|setf|) (autoload-macro 'rotatef '|setf|) (autoload-macro 'setf '|setf|) (autoload-macro 'shiftf '|setf|) (autoload-macro 'step '|trace|) (autoload-macro 'time '|mislib|) (autoload-macro 'trace '|trace|) (autoload-macro 'typecase '|assert|) (autoload-macro 'untrace '|trace|) (autoload-macro 'with-input-from-string '|iolib|) (autoload-macro 'with-open-file '|iolib|) (autoload-macro 'with-open-stream '|iolib|) (autoload-macro 'with-output-to-string '|iolib|) ) ;;end autoloads of normally loaded files.j (if (find-package "COMPILER") (push :compiler *features*)) #+compiler (autoload 'compiler::emit-fn '|../cmpnew/gcl_collectfn|) (autoload 'compiler::init-fn '|../cmpnew/gcl_collectfn|) (autoload 'si::monstartup '"gprof") (autoload 'si::set-up-profile '"profile") (AUTOLOAD 'IDESCRIBE '|info|) (AUTOLOAD 'INFO '|info|) (AUTOLOAD 'LIST-MATCHES '|info|) (AUTOLOAD 'get-match '|info|) (AUTOLOAD 'print-node '|tinfo|) (AUTOLOAD 'offer-choices '|tinfo|) (AUTOLOAD 'tkconnect '|tkl|) ;; the sun has a broken ypbind business, if one wants to save. ;; So to stop users from invoking this #+sun (defun user-homedir-pathname () (let* ((tem (si::getenv "HOME")) (l (- (length tem) 1))) (cond ((null tem) nil) (t (or (and (>= l 0) (eql (aref tem l) #\/)) (setq tem (concatenate 'string tem "/"))) (pathname tem))))) gcl-2.6.14/lsp/gcl_directory.lsp0000644000175000017500000000702014360276512015141 0ustar cammcamm(in-package :si) (defconstant +d-type-alist+ (d-type-list)) (defun ?push (x tp) (when (and x (eq tp :directory)) (vector-push-extend #\/ x)) x) (defun wreaddir (x s &optional y (ls (length s) lsp) &aux (y (if (rassoc y +d-type-alist+) y :unknown))) (when lsp (setf (fill-pointer s) ls)) (let ((r (readdir x (car (rassoc y +d-type-alist+)) s))) (typecase r (fixnum (wreaddir x (adjust-array s (+ 100 (ash (array-dimension s 0) 1))) y)) (cons (let ((tp (cdr (assoc (cdr r) +d-type-alist+)))) (cons (?push (car r) tp) tp))) (otherwise (?push r y))))) (defun dot-dir-p (r l) (member-if (lambda (x) (string= x r :start2 l)) '("./" "../"))) (defun vector-push-string (x s &optional (ss 0) (lx (length x)) &aux (ls (- (length s) ss))) (let ((x (if (> ls (- (array-dimension x 0) lx)) (adjust-array x (+ ls (ash lx 1))) x))) (setf (fill-pointer x) (+ lx ls)) (replace x s :start1 lx :start2 ss))) (defun walk-dir (s e f &optional (y :unknown) (d (opendir s)) (l (length s)) (le (length e)) &aux (r (wreaddir d s y l))) (cond (r (unless (dot-dir-p r l) (funcall f r (vector-push-string e r l le) l)) (walk-dir s e f y d l le)) ((setf (fill-pointer s) l (fill-pointer e) le) (closedir d)))) (defun recurse-dir (x y f) (funcall f x y) (walk-dir x y (lambda (x y l) (declare (ignore l)) (recurse-dir x y f)) :directory)) (defun make-frame (s &aux (l (length s))) (replace (make-array l :element-type 'character :adjustable t :fill-pointer l) s)) (defun expand-wild-directory (d l f zz &optional (yy (make-frame zz))) (let* ((x (member-if 'wild-dir-element-p l)) (s (namestring (make-pathname :device d :directory (ldiff l x)))) (z (vector-push-string zz s)) (l (length yy)) (y (link-expand (vector-push-string yy s) l)) (y (if (eq y yy) y (make-frame y)))) (when (or (eq (stat1 z) :directory) (zerop (length z))) (cond ((eq (car x) :wild-inferiors) (recurse-dir z y f)) (x (walk-dir z y (lambda (q e l) (declare (ignore l)) (expand-wild-directory d (cons :relative (cdr x)) f q e)) :directory));FIXME ((funcall f z y)))))) (defun directory (p &key &aux (p (translate-logical-pathname p))(d (pathname-directory p)) (c (unless (eq (car d) :absolute) (make-frame (namestring *current-directory*)))) (lc (when c (length c))) (filesp (or (pathname-name p) (pathname-type p))) (v (compile-regexp (to-regexp p)))(*up-key* :back) r) (expand-wild-directory (pathname-device p) d (lambda (dir exp &aux (pexp (pathname (if c (vector-push-string c exp 0 lc) exp)))) (if filesp (walk-dir dir exp (lambda (dir exp pos) (declare (ignore exp)) (when (pathname-match-p dir v) (push (merge-pathnames (parse-namestring dir nil *default-pathname-defaults* :start pos) pexp nil) r))) :file) (when (pathname-match-p dir v) (push (pathname (copy-seq (namestring pexp))) r)))) (make-frame "")) r) (defun chdir (s) (when (chdir1 (namestring (pathname s)));to expand ~/ (setq *current-directory* (current-directory-pathname)))) (defun which (s) (let ((r (with-open-file (s (apply 'string-concatenate "|" #-winnt "command -v " #+winnt "for %i in (" s #+winnt ".exe) do @echo.%~$PATH:i" nil)) (read-line s nil 'eof)))) (unless (eq r 'eof) (string-downcase r)))) (defun get-path (s &aux (e (unless (minusp (string-match #v"([^\n\t\r ]+)([\n\t\r ]|$)" s))(match-end 1))) (w (when e (which (pathname-name (subseq s (match-beginning 1) e)))))) (when w (string-concatenate w (subseq s e)))) gcl-2.6.14/lsp/gcl_doc-file.lsp0000755000175000017500000000147514360276512014632 0ustar cammcamm(defun doc-file (file packages) ;;Write FILE of doc strings for all symbols in PACKAGES ;;This file is suitable for use with the find-doc function. #+kcl (and (member 'lisp packages) (not (documentation 'setq 'function)) (load (format nil "~a../lsp/setdoc.lsp" si::*system-directory*))) (with-open-file (st file :direction :output) (sloop:sloop for v in packages do (setq v (if (packagep v) (package-name v) v)) do (sloop:sloop for w in-package v when (setq doc (documentation w 'function)) do (format st "F~a~%~ain ~a package:~a" w (cond ((special-operator-p w) "Special Form ") ((functionp w) "Function ") ((macro-function w) "Macro ") (t "")) v doc) when (setq doc (documentation w 'variable)) do (format st "V~a~%Variable in ~a package:~a" w v doc) )))) gcl-2.6.14/lsp/gcl_evalmacros.lsp0000755000175000017500000002551114360276512015301 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; evalmacros.lsp (in-package :si) ;(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) ;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol))) (eval-when (eval compile) (setq si:*inhibit-macro-special* nil) (defmacro ?cons (f x &aux (s (sgen "?CONS"))) `(let ((,s ,x)) (if (cdr ,s) (cons ,f ,s) (car ,s)))) (defmacro ?list (x &aux (s (sgen "?LIST"))) `(let ((,s ,x)) (when ,s (list ,s)))) (defmacro collect (v r rp np &aux (s (sgen "COLLECT"))) `(let ((,s ,v)) (setf rp (if rp (rplacd rp (list ,s)) (setq r ,s)) rp np))) (defmacro ?let (k kf r) `(let ((r ,r)) (if (eq ,k ,kf) r `(let ((,,k ,,kf)) (declare (ignorable ,,k)) ,r)))) (defmacro ?key (x &aux (s (sgen "?KEY"))) `(if (or (constantp ,x) (symbolp ,x)) ,x ',s))) (defmacro sgen (&optional (pref "G")) `(load-time-value (gensym ,pref))) (defmacro defvar (var &optional (form nil form-sp) doc-string) (declare (optimize (safety 1))) `(progn (*make-special ',var) ,@(when doc-string `((putprop ',var ,doc-string 'variable-documentation))) ,@(when form-sp `((unless (boundp ',var) (setq ,var ,form)))) ',var)) (defmacro defparameter (var form &optional doc-string) (declare (optimize (safety 1))) `(progn (*make-special ',var) ,@(when doc-string `((putprop ',var ,doc-string 'variable-documentation))) (setq ,var ,form) ',var)) (defmacro defconstant (var form &optional doc-string) (declare (optimize (safety 1))) `(progn (*make-constant ',var ,form) ,@(when doc-string `((putprop ',var ,doc-string 'variable-documentation))) ',var)) ;;; Each of the following macros is also defined as a special form. ;;; Thus their names need not be exported. (defmacro and (&rest forms &aux r rp np) (declare (optimize (safety 1))) (do ((y forms))((endp y) (if forms r t)) (let ((x (pop y))) (if (constantp x) (unless (if (eval x) y) (collect x r rp np) (setq y nil)) (if y (collect `(if ,@(setq np (list x))) r rp np) (collect x r rp np)))))) (defmacro or (&rest forms &aux r rp np (s (sgen "OR"))) (declare (optimize (safety 1))) (do ((y forms))((endp y) r) (let ((x (pop y))) (if (constantp x) (when (eval x) (collect x r rp np) (setq y nil)) (if (symbolp x) (collect `(if ,x ,@(setq np (list x))) r rp np) (if y (collect `(let ((,s ,x)) (if ,s ,@(setq np (list s)))) r rp np) (collect x r rp np))))))) (defun parse-body-header (x) (let* ((doc x)(x (or (when (stringp (car x)) (cdr x)) x)) (dec x)(x (member-if-not (lambda (x) (when (consp x) (eq (car x) 'declare))) x)) (ctp x)(x (member-if-not (lambda (x) (when (consp x) (eq (car x) 'check-type))) x))) (values (car (ldiff doc dec)) (ldiff dec ctp) (ldiff ctp x) x))) (defmacro locally (&rest body) (multiple-value-bind (doc dec) (parse-body-header body) (declare (ignore doc)) `(let (,@(mapcan (lambda (x &aux (z (pop x))(z (if (eq z 'type) (pop x) z))) (case z ((ftype inline notinline optimize) nil) (otherwise (mapcar (lambda (x) (list x x)) x)))) (apply 'append (mapcar 'cdr dec)))) ,@body))) (defmacro loop (&rest body &aux (tag (sgen "LOOP"))) `(block nil (tagbody ,tag ,(?cons 'progn body) (go ,tag)))) (defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms)) (defmacro defmacro (name vl &rest body) `(si:define-macro ',name (si:defmacro* ',name ',vl ',body))) (defmacro defun (name lambda-list &rest body) (multiple-value-bind (doc dec ctp body) (parse-body-header body) `(progn ,@(when doc `((setf (get ',name 'function-documentation) ,doc))) (setf (symbol-function ',name) (lambda ,lambda-list ,@dec ,@ctp (block ,name ,@body))) ',name))) ; assignment (defmacro psetq (&rest args) (declare (optimize (safety 1))) (assert (evenp (length args))) (let ((x (let ((i 0)) (mapcon (lambda (x) (when (oddp (incf i)) `((,(cadr x) ,(car x) ,(gensym))))) args)))) (when x `(let* ,(mapcar (lambda (x) `(,(caddr x) ,(car x))) x) (setq ,@(mapcan 'cdr x)) nil)))) ; conditionals (defmacro cond (&rest clauses &aux r rp np (s (sgen "COND"))) (declare (optimize (safety 1))) (do ((y clauses))((endp y) r) (let* ((x (pop y))(z (pop x))) (if (constantp z) (when (eval z) (collect (if x (?cons 'progn x) z) r rp np) (setq y nil)) (if x (collect `(if ,z ,@(setq np (list (?cons 'progn x)))) r rp np) (if (symbolp z) (collect `(if ,z ,@(setq np (list z))) r rp np) (if y (collect `(let ((,s ,z)) (if ,s ,@(setq np (list s)))) r rp np) (collect `(values ,z) r rp np)))))))) (defmacro when (pred &rest body &aux (x (?cons 'progn body))) (declare (optimize (safety 1))) (if (constantp pred) (if (eval pred) x) `(if ,pred ,x))) (defmacro unless (pred &rest body &aux (x (?cons 'progn body))) (declare (optimize (safety 1))) (if (constantp pred) (if (not (eval pred)) x) `(if (not ,pred) ,x))) ; program feature (defun prog?* (let?* vl body) (multiple-value-bind (doc dec ctp body) (parse-body-header body) (declare (ignore doc)) `(block nil (,let?* ,vl ,@dec (tagbody ,@(append ctp body)))))) (defmacro prog (vl &rest body) (prog?* 'let vl body)) (defmacro prog* (vl &rest body) (prog?* 'let* vl body)) ; sequencing (defmacro prog1 (first &rest body &aux (sym (sgen "PROG1"))) `(let ((,sym ,first)) ,@body ,sym)) (defmacro prog2 (first second &rest body &aux (sym (sgen "PROG2"))) `(progn ,first (let ((,sym ,second)) ,@body ,sym))) ; multiple values (defmacro multiple-value-list (form) `(multiple-value-call 'list ,form)) (defmacro multiple-value-setq (vars form) (declare (optimize (safety 1))) (let ((syms (mapcar (lambda (x) (declare (ignore x)) (gensym)) (or vars (list nil))))) `(multiple-value-bind ,syms ,form ,@(?list (?cons 'setq (mapcan 'list vars syms))) ,(car syms)))) (defmacro multiple-value-bind (vars form &rest body &aux (sym (sgen "MULTIPLE-VALUE-BIND"))) (declare (optimize (safety 1))) `(let* ((,sym (multiple-value-list ,form)) ,@(mapcon (lambda (x) `((,(car x) (car ,sym)) ,@(when (cdr x) `((,sym (cdr ,sym)))))) vars)) (declare (ignorable ,sym)) ,@body)) (defun do?* (?* control test result body &aux (label (sgen "DO"))) (multiple-value-bind (doc dec ctp body) (parse-body-header body) (declare (ignore doc)) (labels ((?let (vl dec body) (if (or vl dec) `(,(if ?* 'let* 'let) ,vl ,@dec ,body) body)) (?tagbody (l x y &aux (x (macroexpand x))) (if x `(tagbody ,l ,x ,@(?list (when (eq (car x) 'if) y))) y))) `(block nil ,(?let (mapcar (lambda (x) (if (listp x) (ldiff x (cddr x)) x)) control) dec (?tagbody label `(unless ,test ,@(?list (?cons 'tagbody (append ctp body))) ,@(?list (?cons (if ?* 'setq 'psetq) (mapcan (lambda (x) (when (and (listp x) (cddr x)) (list (car x) (caddr x)))) control))) (go ,label)) `(return ,(?cons 'progn result)))))))) (defmacro do (control (test . result) &rest body) (do?* nil control test result body)) (defmacro do* (control (test . result) &rest body) (do?* t control test result body)) (defmacro case (keyform &rest clauses &aux r rp np (key (?key keyform))) (declare (optimize (safety 1))) (labels ((sw (x) `(eql ,key ,(if (constantp x) x `',x)))) (do ((y clauses))((endp y) (?let key keyform r)) (let* ((x (pop y))(z (pop x))) (if (member z '(t otherwise)) (if y (error "default case must be last") (collect (?cons 'progn x) r rp np)) (when z (if (constantp key) (let ((key (eval key))) (when (if (listp z) (member key z) (eql key z)) (collect (?cons 'progn x) r rp np) (setq y nil))) (collect `(if ,(if (listp z) (?cons 'or (mapcar #'sw z)) (sw z)) ,@(setq np (list (?cons 'progn x)))) r rp np)))))))) (defmacro ecase (keyform &rest clauses &aux (key (?key keyform))) (declare (optimize (safety 1))) (?let key keyform `(case ,key ,@(mapcar (lambda (x) (if (member (car x) '(t otherwise)) (cons (list (car x)) (cdr x)) x)) clauses) (otherwise (error 'type-error :datum ,key :expected-type '(member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses)))))))) (defmacro ccase (keyform &rest clauses &aux (key (?key keyform))) (declare (optimize (safety 1))) (?let key keyform `(do nil (nil) (case ,key ,@(mapcar (lambda (x &aux (k (pop x))) `(,(if (member k '(t otherwise)) (list k) k) (return ,(?cons 'progn x)))) clauses) (otherwise (check-type ,key (member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses))))))))) (defmacro return (&optional val) `(return-from nil ,val)) (defmacro dolist ((var form &optional (val nil)) &rest body &aux (temp (sgen "DOLIST"))) `(do* ((,temp ,form (cdr ,temp))(,var (car ,temp) (car ,temp))) ((endp ,temp) ,val) ,@body)) ;; In principle, a more complete job could be done here by trying to ;; capture fixnum type declarations from the surrounding context or ;; environment, or from within the compiler's internal structures at ;; compile time. See gcl-devel archives for examples. This ;; implementation relies on the fact that the gcc optimizer will ;; eliminate the bignum branch if the supplied form is a symbol ;; declared to be fixnum, as the comparison of a long integer variable ;; with most-positive-fixnum is then vacuous. Care must be taken in ;; making comparisons with most-negative-fixnum, as the C environment ;; appears to treat this as positive or negative depending on the sign ;; of the other argument in the comparison, apparently to symmetrize ;; the long integer range. 20040403 CM. (defmacro dotimes ((var form &optional val) &rest body &aux (s (sgen "DOTIMES"))(m (sgen "DOTIMES"))) `(let* ((,s (block nil ,form))(,m (min ,s most-positive-fixnum))) (declare (fixnum ,m)) (do ((,var 0 (1+ ,var))) ((>= ,var ,m) (if (eql ,s ,m) ,val (do ((,var ,m (1+ ,var)))((>= ,var ,s) ,val) ,@body))) (declare (fixnum ,var)) ,@body))) (defmacro declaim (&rest l) `(eval-when (compile eval load) ,@(mapcar (lambda (x) `(proclaim ',x)) l))) (defmacro lambda (&rest l) `(function (lambda ,@l))) (defun compiler-macro-function (name) (get name 'compiler-macro)) gcl-2.6.14/lsp/gcl_destructuring_bind.lsp0000644000175000017500000003315614360276512017044 0ustar cammcamm;;;; From CMULISP ;;;; From defmacro.lisp ;;;; Some variable definitions. ;;; Variables for amassing the results of parsing a defmacro. Declarations ;;; in DEFMACRO are the reason this isn't as easy as it sounds. ;;; (in-package :si) (defvar *arg-tests* () "A list of tests that do argument counting at expansion time.") (defvar *system-lets* nil) ;(defvar *system-lets* () ; "Let bindings that are done to make lambda-list parsing possible.") (defvar *user-lets* () "Let bindings that the user has explicitly supplied.") (defvar *default-default* nil "Unsupplied optional and keyword arguments get this value defaultly.") ;; Temps that we introduce and might not reference. (defvar *ignorable-vars*) ;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE. ;;; We save space in macro definitions by callig this function. ;;; (defun do-arg-count-error (error-kind name arg lambda-list minimum maximum) (error "Error in do-arg-count-error: ~S ~S ~S ~S ~S ~S~%" error-kind name arg lambda-list minimum maximum)) ;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare ;;; form to put where this code is inserted, and the documentation for the ;;; parsed body. ;;; (defun parse-defmacro (lambda-list arg-list-name code name error-kind &key (annonymousp nil) (doc-string-allowed t) ((:environment env-arg-name)) ((:default-default *default-default*)) (error-fun 'error)) "Returns as multiple-values a parsed body, any local-declarations that should be made where this body is inserted, and a doc-string if there is one." (multiple-value-bind (body declarations documentation) (parse-body code nil doc-string-allowed) (let* ((*arg-tests* ()) (*user-lets* ()) (*system-lets* ()) (*ignorable-vars* ())) (multiple-value-bind (env-arg-used minimum maximum) (parse-defmacro-lambda-list lambda-list arg-list-name name error-kind error-fun (not annonymousp) nil env-arg-name) (values `(let* ,(nreverse *system-lets*) ,@(when *ignorable-vars* `((declare (ignorable ,@*ignorable-vars*)))) ,@*arg-tests* (let* ,(nreverse *user-lets*) ,@declarations ,@body)) `(,@(when (and env-arg-name (not env-arg-used)) `((declare (ignore ,env-arg-name))))) documentation minimum maximum))))) (defun make-keyword (symbol) "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." (intern (symbol-name symbol) (find-package "KEYWORD"))) (defun verify-keywords (key-list valid-keys allow-other-keys) (do ((already-processed nil) (unknown-keyword nil) (remaining key-list (cddr remaining))) ((null remaining) (if (and unknown-keyword (not allow-other-keys) (not (lookup-keyword :allow-other-keys key-list))) (values :unknown-keyword (list unknown-keyword valid-keys)) (values nil nil))) (cond ((not (and (consp remaining) (listp (cdr remaining)))) (return (values :dotted-list key-list))) ((null (cdr remaining)) (return (values :odd-length key-list))) #+nil ;; Not ANSI compliant to disallow duplicate keywords. ((member (car remaining) already-processed) (return (values :duplicate (car remaining)))) ((or (eq (car remaining) :allow-other-keys) (member (car remaining) valid-keys)) (push (car remaining) already-processed)) (t (setf unknown-keyword (car remaining)))))) (defun lookup-keyword (keyword key-list) (do ((remaining key-list (cddr remaining))) ((endp remaining)) (when (eq keyword (car remaining)) (return (cadr remaining))))) ;;; (defun keyword-supplied-p (keyword key-list) (do ((remaining key-list (cddr remaining))) ((endp remaining)) (when (eq keyword (car remaining)) (return t)))) ;(defun make-keyword (a) ; (error "Need to write make-keyword ~S" a)) ;(defun defmacro-error (a b c) ; (error "Need to write defmacro-error ~S ~S ~S" a b c)) (defun parse-defmacro-lambda-list (lambda-list arg-list-name name error-kind error-fun &optional top-level env-illegal env-arg-name) (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) (now-processing :required) (maximum 0) (minimum 0) (keys ()) rest-name restp allow-other-keys-p env-arg-used) ;; This really strange way to test for '&whole is neccessary because member ;; does not have to work on dotted lists, and dotted lists are legal ;; in lambda-lists. (when (and (do ((list lambda-list (cdr list))) ((atom list) nil) (when (eq (car list) '&whole) (return t))) (not (eq (car lambda-list) '&whole))) (error "&Whole must appear first in ~S lambda-list." error-kind)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((atom rest-of-args) (cond ((null rest-of-args) nil) ;; Varlist is dotted, treat as &rest arg and exit. (t (push-let-binding rest-of-args path nil) (setf restp t)))) (let ((var (car rest-of-args))) (cond ((eq var '&whole) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (push-let-binding (car rest-of-args) arg-list-name nil)) (t (error "Bad &WHOLE")))) ((eq var '&environment) (cond (env-illegal (error "&Environment not valid with ~S." error-kind)) ((not top-level) (error "&Environment only valid at top level of ~ lambda-list."))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (push-let-binding (car rest-of-args) env-arg-name nil) (setf env-arg-used t)) (t (error "Bad &ENVIRONMENT")))) ((or (eq var '&rest) (eq var '&body)) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (push-let-binding (car rest-of-args) path nil)) ;; ;; This branch implements an incompatible extension to ;; Common Lisp. In place of a symbol following &body, ;; there may be a list of up to three elements which will ;; be bound to the body, declarations, and doc-string of ;; the body. ((and (cdr rest-of-args) (consp (cadr rest-of-args)) (symbolp (caadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (setf restp t) (let ((body-name (caar rest-of-args)) (declarations-name (cadar rest-of-args)) (doc-string-name (caddar rest-of-args)) (parse-body-values (gensym))) (push-let-binding parse-body-values `(multiple-value-list (parse-body ,path ,env-arg-name ,(not (null doc-string-name)))) t) (setf env-arg-used t) (when body-name (push-let-binding body-name `(car ,parse-body-values) nil)) (when declarations-name (push-let-binding declarations-name `(cadr ,parse-body-values) nil)) (when doc-string-name (push-let-binding doc-string-name `(caddr ,parse-body-values) nil)))) (t (error "Bad lambda list")))) ((eq var '&optional) (setf now-processing :optionals)) ((eq var '&key) (setf now-processing :keywords) (setf rest-name (gensym "KEYWORDS-")) (push rest-name *ignorable-vars*) (setf restp t) (push-let-binding rest-name path t)) ((eq var '&allow-other-keys) (setf allow-other-keys-p t)) ((eq var '&aux) (setf now-processing :auxs)) ((listp var) (case now-processing (:required (let ((sub-list-name (gensym "SUBLIST-"))) (push-sub-list-binding sub-list-name `(car ,path) var name error-kind error-fun) (parse-defmacro-lambda-list var sub-list-name name error-kind error-fun)) (setf path `(cdr ,path)) (incf minimum) (incf maximum)) (:optionals (when (> (length var) 3) (cerror "Ignore extra noise." "More than variable, initform, and suppliedp ~ in &optional binding - ~S" var)) (push-optional-binding (car var) (cadr var) (caddr var) `(not (null ,path)) `(car ,path) name error-kind error-fun) (setf path `(cdr ,path)) (incf maximum)) (:keywords (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) (car var))) (keyword (if keyword-given (caar var) (make-keyword variable))) (supplied-p (caddr var))) (push-optional-binding variable (cadr var) supplied-p `(keyword-supplied-p ',keyword ,rest-name) `(lookup-keyword ',keyword ,rest-name) name error-kind error-fun) (push keyword keys))) (:auxs (push-let-binding (car var) (cadr var) nil)))) ((symbolp var) (case now-processing (:required (incf minimum) (incf maximum) (push-let-binding var `(car ,path) nil) (setf path `(cdr ,path))) (:optionals (incf maximum) (push-let-binding var `(car ,path) nil `(not (null ,path))) (setf path `(cdr ,path))) (:keywords (let ((key (make-keyword var))) (push-let-binding var `(lookup-keyword ,key ,rest-name) nil) (push key keys))) (:auxs (push-let-binding var nil nil)))) (t (error "Non-symbol in lambda-list - ~S." var))))) ;; Generate code to check the number of arguments, unless dotted ;; in which case length will not work. (unless restp (push `(unless (<= ,minimum (length (the list ,(if top-level `(cdr ,arg-list-name) arg-list-name))) ,@(unless restp (list maximum))) ,(let ((arg (if top-level `(cdr ,arg-list-name) arg-list-name))) (if (eq error-fun 'error) `(do-arg-count-error ',error-kind ',name ,arg ',lambda-list ,minimum ,(unless restp maximum)) `(,error-fun 'defmacro-ll-arg-count-error :kind ',error-kind ,@(when name `(:name ',name)) :argument ,arg :lambda-list ',lambda-list :minimum ,minimum ,@(unless restp `(:maximum ,maximum)))))) *arg-tests*)) (if keys (let ((problem (gensym "KEY-PROBLEM-")) (info (gensym "INFO-"))) (push `(multiple-value-bind (,problem ,info) (verify-keywords ,rest-name ',keys ',allow-other-keys-p) (when ,problem (,error-fun 'defmacro-ll-broken-key-list-error :kind ',error-kind ,@(when name `(:name ',name)) :problem ,problem :info ,info))) *arg-tests*))) (values env-arg-used minimum (if (null restp) maximum nil)))) (defun push-sub-list-binding (variable path object name error-kind error-fun) (let ((var (gensym "TEMP-"))) (push `(,variable (let ((,var ,path)) (if (listp ,var) ,var (,error-fun 'defmacro-bogus-sublist-error :kind ',error-kind ,@(when name `(:name ',name)) :object ,var :lambda-list ',object)))) *system-lets*))) (defun push-let-binding (variable path systemp &optional condition (init-form *default-default*)) (let ((let-form (if condition `(,variable (if ,condition ,path ,init-form)) `(,variable ,path)))) (if systemp (push let-form *system-lets*) (push let-form *user-lets*)))) (defun push-optional-binding (value-var init-form supplied-var condition path name error-kind error-fun) (unless supplied-var (setf supplied-var (gensym "SUPLIEDP-"))) (push-let-binding supplied-var condition t) (cond ((consp value-var) (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) (push-sub-list-binding whole-thing `(if ,supplied-var ,path ,init-form) value-var name error-kind error-fun) (parse-defmacro-lambda-list value-var whole-thing name error-kind error-fun))) ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t (error "Illegal optional variable name: ~S" value-var)))) ;;;; From macros.lisp ;;; Parse-Body -- Public ;;; ;;; Parse out declarations and doc strings, *not* expanding macros. ;;; Eventually the environment arg should be flushed, since macros can't expand ;;; into declarations anymore. ;;; (defun parse-body (body environment &optional (doc-string-allowed t)) "This function is to parse the declarations and doc-string out of the body of a defun-like form. Body is the list of stuff which is to be parsed. Environment is ignored. If Doc-String-Allowed is true, then a doc string will be parsed out of the body and returned. If it is false then a string will terminate the search for declarations. Three values are returned: the tail of Body after the declarations and doc strings, a list of declare forms, and the doc-string, or NIL if none." (declare (ignore environment)) (let ((decls ()) (doc nil)) (do ((tail body (cdr tail))) ((endp tail) (values tail (nreverse decls) doc)) (let ((form (car tail))) (cond ((and (stringp form) (cdr tail)) (if doc-string-allowed (setq doc form ;; Only one doc string is allowed. doc-string-allowed nil) (return (values tail (nreverse decls) doc)))) ((not (and (consp form) (symbolp (car form)))) (return (values tail (nreverse decls) doc))) ((eq (car form) 'declare) (push form decls)) (t (return (values tail (nreverse decls) doc)))))))) ;;;; Destructuring-bind (defmacro destructuring-bind (lambda-list arg-list &rest body) "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." (let* ((arg-list-name (gensym "ARG-LIST-"))) (multiple-value-bind (body local-decls) (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind :annonymousp t :doc-string-allowed nil) `(let ((,arg-list-name ,arg-list)) ,@local-decls ,body)))) gcl-2.6.14/lsp/gcl_japi.lsp0000644000175000017500000003414414360276512014067 0ustar cammcamm;;; Binding to the cross platform Japi GUI library from http://www.japi.de/ (eval-when (load eval) (make-package :japi-primitives :nicknames '(jpr) :use '(lisp))) (in-package :japi-primitives) (clines "#include ") ;; BOOLEAN (defconstant J_TRUE 1) (defconstant J_FALSE 0) ;; ALIGNMENT (defconstant J_LEFT 0) (defconstant J_CENTER 1) (defconstant J_RIGHT 2) (defconstant J_TOP 3) (defconstant J_BOTTOM 4) (defconstant J_TOPLEFT 5) (defconstant J_TOPRIGHT 6) (defconstant J_BOTTOMLEFT 7) (defconstant J_BOTTOMRIGHT 8) ;; CURSOR (defconstant J_DEFAULT_CURSOR 0) (defconstant J_CROSSHAIR_CURSOR 1) (defconstant J_TEXT_CURSOR 2) (defconstant J_WAIT_CURSOR 3) (defconstant J_SW_RESIZE_CURSOR 4) (defconstant J_SE_RESIZE_CURSOR 5) (defconstant J_NW_RESIZE_CURSOR 6) (defconstant J_NE_RESIZE_CURSOR 7) (defconstant J_N_RESIZE_CURSOR 8) (defconstant J_S_RESIZE_CURSOR 9) (defconstant J_W_RESIZE_CURSOR 10) (defconstant J_E_RESIZE_CURSOR 11) (defconstant J_HAND_CURSOR 12) (defconstant J_MOVE_CURSOR 13) ;; ORIENTATION (defconstant J_HORIZONTAL 0) (defconstant J_VERTICAL 1) ;; FONTS (defconstant J_PLAIN 0) (defconstant J_BOLD 1) (defconstant J_ITALIC 2) (defconstant J_COURIER 1) (defconstant J_HELVETIA 2) (defconstant J_TIMES 3) (defconstant J_DIALOGIN 4) (defconstant J_DIALOGOUT 5) ;; COLORS (defconstant J_BLACK 0) (defconstant J_WHITE 1) (defconstant J_RED 2) (defconstant J_GREEN 3) (defconstant J_BLUE 4) (defconstant J_CYAN 5) (defconstant J_MAGENTA 6) (defconstant J_YELLOW 7) (defconstant J_ORANGE 8) (defconstant J_GREEN_YELLOW 9) (defconstant J_GREEN_CYAN 10) (defconstant J_BLUE_CYAN 11) (defconstant J_BLUE_MAGENTA 12) (defconstant J_RED_MAGENTA 13) (defconstant J_DARK_GRAY 14) (defconstant J_LIGHT_GRAY 15) (defconstant J_GRAY 16) ;; BORDERSTYLE (defconstant J_NONE 0) (defconstant J_LINEDOWN 1) (defconstant J_LINEUP 2) (defconstant J_AREADOWN 3) (defconstant J_AREAUP 4) ;; MOUSELISTENER (defconstant J_MOVED 0) (defconstant J_DRAGGED 1) (defconstant J_PRESSED 2) (defconstant J_RELEASED 3) (defconstant J_ENTERERD 4) (defconstant J_EXITED 5) (defconstant J_DOUBLECLICK 6) ;; J_MOVED (defconstant J_RESIZED 1) (defconstant J_HIDDEN 2) (defconstant J_SHOWN 3) ;; WINDOWLISTENER (defconstant J_ACTIVATED 0) (defconstant J_DEACTIVATED 1) (defconstant J_OPENED 2) (defconstant J_CLOSED 3) (defconstant J_ICONIFIED 4) (defconstant J_DEICONIFIED 5) (defconstant J_CLOSING 6) ;; IMAGEFILEFORMAT (defconstant J_GIF 0) (defconstant J_JPG 1) (defconstant J_PPM 2) (defconstant J_BMP 3) (defentry j_start () ( int "j_start" )) (defentry j_connect ( string ) ( int "j_connect" )) (defentry j_setdebug ( int ) ( void "j_setdebug" )) (defentry j_frame ( string ) ( int "j_frame" )) (defentry j_button ( int string ) ( int "j_button" )) (defentry j_graphicbutton ( int string ) ( int "j_graphicbutton" )) (defentry j_checkbox ( int string ) ( int "j_checkbox" )) (defentry j_label ( int string ) ( int "j_label" )) (defentry j_graphiclabel ( int string ) ( int "j_graphiclabel" )) (defentry j_canvas ( int int int ) ( int "j_canvas" )) (defentry j_panel ( int ) ( int "j_panel" )) (defentry j_borderpanel ( int int ) ( int "j_borderpanel" )) (defentry j_radiogroup ( int ) ( int "j_radiogroup" )) (defentry j_radiobutton ( int string ) ( int "j_radiobutton" )) (defentry j_list ( int int ) ( int "j_list" )) (defentry j_choice ( int ) ( int "j_choice" )) (defentry j_dialog ( int string ) ( int "j_dialog" )) (defentry j_window ( int ) ( int "j_window" )) (defentry j_popupmenu ( int string ) ( int "j_popupmenu" )) (defentry j_scrollpane ( int ) ( int "j_scrollpane" )) (defentry j_hscrollbar ( int ) ( int "j_hscrollbar" )) (defentry j_vscrollbar ( int ) ( int "j_vscrollbar" )) (defentry j_line ( int int int int ) ( int "j_line" )) (defentry j_printer ( int ) ( int "j_printer" )) (defentry j_image ( int int ) ( int "j_image" )) (defentry j_filedialog ( int string string string ) ( string "j_filedialog" )) (defentry j_fileselect ( int string string string ) ( string "j_fileselect" )) (defentry j_messagebox ( int string string ) ( int "j_messagebox" )) (defentry j_alertbox ( int string string string ) ( int "j_alertbox" )) (defentry j_choicebox2 ( int string string string string ) ( int "j_choicebox2" )) (defentry j_choicebox3 ( int string string string string string ) ( int "j_choicebox3" )) (defentry j_additem ( int string ) ( void "j_additem" )) (defentry j_textfield ( int int ) ( int "j_textfield" )) (defentry j_textarea ( int int int ) ( int "j_textarea" )) (defentry j_menubar ( int ) ( int "j_menubar" )) (defentry j_menu ( int string ) ( int "j_menu" )) (defentry j_helpmenu ( int string ) ( int "j_helpmenu" )) (defentry j_menuitem ( int string ) ( int "j_menuitem" )) (defentry j_checkmenuitem ( int string ) ( int "j_checkmenuitem" )) (defentry j_pack ( int ) ( void "j_pack" )) (defentry j_print ( int ) ( void "j_print" )) (defentry j_playsoundfile ( string ) ( void "j_playsoundfile" )) (defentry j_play ( int ) ( void "j_play" )) (defentry j_sound ( string ) ( int "j_sound" )) (defentry j_setfont ( int int int int ) ( void "j_setfont" )) (defentry j_setfontname ( int int ) ( void "j_setfontname" )) (defentry j_setfontsize ( int int ) ( void "j_setfontsize" )) (defentry j_setfontstyle ( int int ) ( void "j_setfontstyle" )) (defentry j_seperator ( int ) ( void "j_seperator" )) (defentry j_disable ( int ) ( void "j_disable" )) (defentry j_enable ( int ) ( void "j_enable" )) (defentry j_getstate ( int ) ( int "j_getstate" )) (defentry j_getrows ( int ) ( int "j_getrows" )) (defentry j_getcolumns ( int ) ( int "j_getcolumns" )) (defentry j_getselect ( int ) ( int "j_getselect" )) (defentry j_isselect ( int int ) ( int "j_isselect" )) (defentry j_isvisible ( int ) ( int "j_isvisible" )) (defentry j_isparent ( int int ) ( int "j_isparent" )) (defentry j_isresizable ( int ) ( int "j_isresizable" )) (defentry j_select ( int int ) ( void "j_select" )) (defentry j_deselect ( int int ) ( void "j_deselect" )) (defentry j_multiplemode ( int int ) ( void "j_multiplemode" )) (defentry j_insert ( int int string ) ( void "j_insert" )) (defentry j_remove ( int int ) ( void "j_remove" )) (defentry j_removeitem ( int string ) ( void "j_removeitem" )) (defentry j_removeall ( int ) ( void "j_removeall" )) (defentry j_setstate ( int int ) ( void "j_setstate" )) (defentry j_setrows ( int int ) ( void "j_setrows" )) (defentry j_setcolumns ( int int ) ( void "j_setcolumns" )) (defentry j_seticon ( int int ) ( void "j_seticon" )) (defentry j_setimage ( int int ) ( void "j_setimage" )) (defentry j_setvalue ( int int ) ( void "j_setvalue" )) (defentry j_setradiogroup ( int int ) ( void "j_setradiogroup" )) (defentry j_setunitinc ( int int ) ( void "j_setunitinc" )) (defentry j_setblockinc ( int int ) ( void "j_setblockinc" )) (defentry j_setmin ( int int ) ( void "j_setmin" )) (defentry j_setmax ( int int ) ( void "j_setmax" )) (defentry j_setslidesize ( int int ) ( void "j_setslidesize" )) (defentry j_setcursor ( int int ) ( void "j_setcursor" )) (defentry j_setresizable ( int int ) ( void "j_setresizable" )) (defentry j_getlength ( int ) ( int "j_getlength" )) (defentry j_getvalue ( int ) ( int "j_getvalue" )) (defentry j_getscreenheight () ( int "j_getscreenheight" )) (defentry j_getscreenwidth () ( int "j_getscreenwidth" )) (defentry j_getheight ( int ) ( int "j_getheight" )) (defentry j_getwidth ( int ) ( int "j_getwidth" )) (defentry j_getinsets ( int int ) ( int "j_getinsets" )) (defentry j_getlayoutid ( int ) ( int "j_getlayoutid" )) (defentry j_getinheight ( int ) ( int "j_getinheight" )) (defentry j_getinwidth ( int ) ( int "j_getinwidth" )) (defentry j_gettext ( int string ) ( string "j_gettext" )) (defentry j_getitem ( int int string ) ( string "j_getitem" )) (defentry j_getitemcount ( int ) ( int "j_getitemcount" )) (defentry j_delete ( int int int ) ( void "j_delete" )) (defentry j_replacetext ( int int int int ) ( void "j_replacetext" )) (defentry j_appendtext ( int int ) ( void "j_appendtext" )) (defentry j_inserttext ( int int int ) ( void "j_inserttext" )) (defentry j_settext ( int string ) ( void "j_settext" )) (defentry j_selectall ( int ) ( void "j_selectall" )) (defentry j_selecttext ( int int int ) ( void "j_selecttext" )) (defentry j_getselstart ( int ) ( int "j_getselstart" )) (defentry j_getselend ( int ) ( int "j_getselend" )) ;(defentry j_getseltext ( int string ) ( string "j_getseltext" )) (defentry j_getseltext ( int int ) ( int "j_getseltext" )) (defentry j_getcurpos ( int ) ( int "j_getcurpos" )) (defentry j_setcurpos ( int int ) ( void "j_setcurpos" )) (defentry j_setechochar ( int char ) ( void "j_setechochar" )) (defentry j_seteditable ( int int ) ( void "j_seteditable" )) (defentry j_setshortcut ( int char ) ( void "j_setshortcut" )) (defentry j_quit () ( void "j_quit" )) (defentry j_kill () ( void "j_kill" )) (defentry j_setsize ( int int int ) ( void "j_setsize" )) (defentry j_getaction () ( int "j_getaction" )) (defentry j_nextaction () ( int "j_nextaction" )) (defentry j_show ( int ) ( void "j_show" )) (defentry j_showpopup ( int int int ) ( void "j_showpopup" )) (defentry j_add ( int int ) ( void "j_add" )) (defentry j_release ( int ) ( void "j_release" )) (defentry j_releaseall ( int ) ( void "j_releaseall" )) (defentry j_hide ( int ) ( void "j_hide" )) (defentry j_dispose ( int ) ( void "j_dispose" )) (defentry j_setpos ( int int int ) ( void "j_setpos" )) (defentry j_getviewportheight ( int ) ( int "j_getviewportheight" )) (defentry j_getviewportwidth ( int ) ( int "j_getviewportwidth" )) (defentry j_getxpos ( int ) ( int "j_getxpos" )) (defentry j_getypos ( int ) ( int "j_getypos" )) ;(defentry j_getpos ( int int* int* ) ( void "j_getpos" )) (defentry j_getpos ( int int int ) ( void "j_getpos" )) (defentry j_getparentid ( int ) ( int "j_getparentid" )) (defentry j_setfocus ( int ) ( void "j_setfocus" )) (defentry j_hasfocus ( int ) ( int "j_hasfocus" )) (defentry j_getstringwidth ( int string ) ( int "j_getstringwidth" )) (defentry j_getfontheight ( int ) ( int "j_getfontheight" )) (defentry j_getfontascent ( int ) ( int "j_getfontascent" )) (defentry j_keylistener ( int ) ( int "j_keylistener" )) (defentry j_getkeycode ( int ) ( int "j_getkeycode" )) (defentry j_getkeychar ( int ) ( int "j_getkeychar" )) (defentry j_mouselistener ( int int ) ( int "j_mouselistener" )) (defentry j_getmousex ( int ) ( int "j_getmousex" )) (defentry j_getmousey ( int ) ( int "j_getmousey" )) ;(defentry j_getmousepos ( int int* int* ) ( void "j_getmousepos" )) (defentry j_getmousepos ( int int int ) ( void "j_getmousepos" )) (defentry j_getmousebutton ( int ) ( int "j_getmousebutton" )) (defentry j_focuslistener ( int ) ( int "j_focuslistener" )) (defentry j_componentlistener ( int int ) ( int "j_componentlistener" )) (defentry j_windowlistener ( int int ) ( int "j_windowlistener" )) (defentry j_setflowlayout ( int int ) ( void "j_setflowlayout" )) (defentry j_setborderlayout ( int ) ( void "j_setborderlayout" )) (defentry j_setgridlayout ( int int int ) ( void "j_setgridlayout" )) (defentry j_setfixlayout ( int ) ( void "j_setfixlayout" )) (defentry j_setnolayout ( int ) ( void "j_setnolayout" )) (defentry j_setborderpos ( int int ) ( void "j_setborderpos" )) (defentry j_sethgap ( int int ) ( void "j_sethgap" )) (defentry j_setvgap ( int int ) ( void "j_setvgap" )) (defentry j_setinsets ( int int int int int ) ( void "j_setinsets" )) (defentry j_setalign ( int int ) ( void "j_setalign" )) (defentry j_setflowfill ( int int ) ( void "j_setflowfill" )) (defentry j_translate ( int int int ) ( void "j_translate" )) (defentry j_cliprect ( int int int int int ) ( void "j_cliprect" )) (defentry j_drawrect ( int int int int int ) ( void "j_drawrect" )) (defentry j_fillrect ( int int int int int ) ( void "j_fillrect" )) (defentry j_drawroundrect ( int int int int int int int ) ( void "j_drawroundrect" )) (defentry j_fillroundrect ( int int int int int int int ) ( void "j_fillroundrect" )) (defentry j_drawoval ( int int int int int ) ( void "j_drawoval" )) (defentry j_filloval ( int int int int int ) ( void "j_filloval" )) (defentry j_drawcircle ( int int int int ) ( void "j_drawcircle" )) (defentry j_fillcircle ( int int int int ) ( void "j_fillcircle" )) (defentry j_drawarc ( int int int int int int int ) ( void "j_drawarc" )) (defentry j_fillarc ( int int int int int int int ) ( void "j_fillarc" )) (defentry j_drawline ( int int int int int ) ( void "j_drawline" )) ;(defentry j_drawpolyline ( int int int* int* ) ( void "j_drawpolyline" )) ;(defentry j_drawpolygon ( int int int* int* ) ( void "j_drawpolygon" )) ;(defentry j_fillpolygon ( int int int* int* ) ( void "j_fillpolygon" )) (defentry j_drawpolyline ( int int int int ) ( void "j_drawpolyline" )) (defentry j_drawpolygon ( int int int int ) ( void "j_drawpolygon" )) (defentry j_fillpolygon ( int int int int ) ( void "j_fillpolygon" )) (defentry j_drawpixel ( int int int ) ( void "j_drawpixel" )) (defentry j_drawstring ( int int int string ) ( void "j_drawstring" )) (defentry j_setxor ( int int ) ( void "j_setxor" )) (defentry j_getimage ( int ) ( int "j_getimage" )) ;(defentry j_getimagesource ( int int int int int int* int* int* ) ( void "j_getimagesource" )) ;(defentry j_drawimagesource ( int int int int int int* int* int* ) ( void "j_drawimagesource" )) (defentry j_getimagesource ( int int int int int int int int ) ( void "j_getimagesource" )) (defentry j_drawimagesource ( int int int int int int int int ) ( void "j_drawimagesource" )) (defentry j_getscaledimage ( int int int int int int int ) ( int "j_getscaledimage" )) (defentry j_drawimage ( int int int int ) ( void "j_drawimage" )) (defentry j_drawscaledimage ( int int int int int int int int int int ) ( void "j_drawscaledimage" )) (defentry j_setcolor ( int int int int ) ( void "j_setcolor" )) (defentry j_setcolorbg ( int int int int ) ( void "j_setcolorbg" )) (defentry j_setnamedcolor ( int int ) ( void "j_setnamedcolor" )) (defentry j_setnamedcolorbg ( int int ) ( void "j_setnamedcolorbg" )) (defentry j_loadimage ( string ) ( int "j_loadimage" )) (defentry j_saveimage ( int string int ) ( int "j_saveimage" )) (defentry j_sync () ( void "j_sync" )) (defentry j_beep () ( void "j_beep" )) (defentry j_random () ( int "j_random" )) (defentry j_sleep ( int ) ( void "j_sleep" )) gcl-2.6.14/lsp/gcl_cmpinit.lsp0000755000175000017500000000053114360276512014603 0ustar cammcamm;(proclaim '(optimize (safety 2) (space 3))) (setq compiler::*eval-when-defaults* '(compile eval load)) (or (fboundp 'si::get-&environment) (load "gcl_defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ;;;;; gcl-2.6.14/lsp/make.lisp0000755000175000017500000003373014360276512013410 0ustar cammcamm;;; -*- Mode: Lisp; Package: MAKE; Syntax: Common-Lisp; Base: 10 -*- ;;;; ;; Copyright William F. Schelter 1989. ;; The author expressly permits copying and alteration of this file, ;; provided any modifications are clearly labeled, and this notice is ;; preserved. The author provides no warranty and this software is ;; provided on an 'as is' basis. (in-package "MAKE" :use '("LISP") #+gcl :external #+gcl 11 #+gcl :internal #+gcl 79) (export '(make system-load system-compile)) (provide "MAKE") ;;; ******* Description of Make Facility ************ ;; We provide a simple MAKE facility to allow ;;compiling and loading of a tree of files ;;If the tree is '(a b (d e g h) i) ;; a will be loaded before b is compiled, ;; b will be loaded before d, e, g, h are compiled ;; d e g h will be loaded before i is compiled. ;; A record is kept of write dates of loaded compiled files, and a file ;;won't be reloaded if it is the same version (unless a force flag is t). ;;Thus if you do (make :uinfor) twice in a row, the second one would not ;;load anything. NOTE: If you change a, and a macro in it would affect ;;b, b still will not be recompiled. You must choose the :recompile t ;;option, to force the recompiling if you change macro files. ;;Alternately you may specify dependency information (see :depends below). ;;****** Sample file which when loaded causes system ALGEBRA ;; to be compiled and loaded ****** ;;(require "MAKE") ;;(use-package "MAKE") ;;(setf (get :algebra :make) '(a b (d e) l)) ;;(setf (get :algebra :source-path) "/usr2/wfs/algebra/foo.lisp") ;;(setf (get :algebra :object-path) "/usr2/wfs/algebra/o/foo.o") ;;(make :algebra :compile t) ;; More complex systems may need to do some special operations ;;at certain points of the make. ;;the tree of files may contain some keywords which have special meaning. ;;eg. '(a b (:progn (gbc) (if make::*compile* ;; (format t "A and B finally compiled"))) ;; (:load-source h i) ;; (d e) l) ;;then during the load and compile phases the function (gbc) will be ;;called after a and b have been acted on, and during the compile phase ;;the message about "A and B finally.." will be printed. ;;the lisp files h and i will be loaded after merging the paths with ;;the source directory. This feature is extensible: see the definitions ;;of :load-source and :progn. ;; The keyword feature is extensible, and you may specify what ;;happens during the load or compile phase for your favorite keyword. ;;To do this look at the definition of :progn, and :load-source ;;in the source for make. ;;Dependency feature: ;; This make NEVER loads or compiles files in an order different from ;;that specified by the tree. It will omit loading files which are ;;loaded and up to date, but if two files are out of date, the first (in ;;the printed representation of the tree), will always be loaded before ;;the second. A consequence of this is that circular dependencies can ;;never occur. ;; ;; If the :make tree contains (a b c d (:depends (c d) (a b))) then c ;;and d depend on a and b, so that if a or b need recompilation then c ;;and d will also be recompiled. Thus the general form of a :depends ;;clause is (:depends later earlier) where LATER and EARLIER are either ;;a single file or a list of files. Read it as LATER depends on EARLIER. ;;A declaration of a (:depends (c) (d)) would have no effect, since the ;;order in the tree already rules out such a dependence. ;; An easy way of specifying a linear dependence is by using :serial. ;;The tree (a (:serial b c d) e) is completely equivalent to the tree ;;(a b c d e (:depends c b)(:depends d (b c))), but with a long list of ;;serial files, it is inconvenient to specify them in the ;;latter representation. ;;A common case is a set of macros whose dependence is serial followed by a set ;;of files whose order is unimportant. A conventient way of building that ;;tree is ;; ;;(let ((macros '(a b c d)) ;; (files '(c d e f g))) ;; `((:serial ,@ macros) ;; ,files ;; (:depends ,files ,macros))) ;; The depends clause may occur anywhere within the tree, since ;;an initial pass collects all dependency information. ;; Make takes a SHOW keyword argument. It is almost impossible to simulate ;;all the possible features of make, for show. Nonetheless, it is good ;;to get an idea of the compiling and loading sequence for a new system. ;;As a byproduct, you could use the output, as a simple sequence of calls ;;to compile-file and load, to do the required work, when make is not around ;;to help. ;;***** Definitions ******** (defvar *files-loaded* nil) (defvar *show-files-loaded* nil) ;only for show option (defvar *load* nil "Will be non nil inside load-files") (defvar *compile* nil "Bound by compile-files to t") (defvar *depends* nil) (defvar *depends-new* nil) (defvar *force* nil) (defvar *when-compile* nil "Each compile-file evals things in this list and sets it to nil") #+kcl(defvar *system-p* nil) (defvar *compile-file-function* 'make-compile-file) (defvar *load-function* 'make-load-file) (defvar show nil) (defvar *cflags* #-kcl nil #+kcl '(:system-p *system-p*)) ;;this is the main entry point (defun make (system &key recompile compile batch object-path source-path show proclaims &aux files *depends* *when-compile* *show-files-loaded* #+gcl (*load-fn-too* proclaims) ) "SYSTEM is a tree of files, or a symbol with :make property. It loads all file files in system. If COMPILE it will try to compile files with newer source versions than object versions, before loading. If RECOMPILE it will recompile all files. This is equivalent to deleting all objects and using :compile t. SOURCE-PATH is merged with the name given in the files list, when looking for a file to compile. OBJECT-PATH is merged with the name in the files list, when looking for a file to load. If SYSTEM is a symbol, then a null OBJECT-PATH would be set to the :object-path property of SYSTEM. Similarly for :source-path" (declare (special object-path source-path show)) batch (cond ((symbolp system) (or object-path (setf object-path (get system :object-path))) (or source-path (setf source-path (get system :source-path))) (setf files (get system :make)) (or files (if (get system :files) (error "Use :make property, :files property is obssolet{!"))) ) (t (setf files system))) #+gcl (when proclaims (compiler::emit-fn t) (compiler::setup-sys-proclaims)) (let (#+lispm ( si::inhibit-fdefine-warnings (if batch :just-warn si::inhibit-fdefine-warnings))) (let ((*depends* (if (or compile recompile) (get-depends system))) *depends-new*) (dolist (v files) (when (or compile recompile) (compile-files v recompile)) (load-files v recompile))) #+gcl (if proclaims (compiler::write-sys-proclaims)) )) (defun system-load (system-name &rest names) "If :infor is a system, (system-load :uinfor joe betty) will load joe and betty from the object-path for :uinfor" (load-files names t (get system-name :object-path))) (defun system-compile (system-name &rest names) "If :iunfor is a system, (system-compile :uinfor joe) will in the source path for joe and compile him into the object path for :uinfor" (compile-files names t :source-path (get system-name :source-path) :object-path (get system-name :object-path))) (defun get-depends (system-name &aux result) (dolist (v (get system-name :make)) (cond ((atom v) ) ((eq (car v) :serial) (do ((w (reverse (cdr v))(cdr w))) ((null (cdr w))) (push (list (car w) (cdr w)) result))) ((eq (car v) :depends) (push (cdr v) result )))) result) #+kcl (setq si::*default-time-zone* 6) #+winnt (setq SYSTEM:*DEFAULT-TIME-ZONE* (GET-SYSTEM-TIME-ZONE)) (defun print-date (&optional(stream *standard-output*) (time (get-universal-time))) (multiple-value-bind (sec min hr day mon yr wkday) (decode-universal-time time) (format stream "~a ~a ~a ~d:~2,'0d:~2,'0d ~a" (nth wkday '( "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) (nth (1- mon) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) day hr min sec yr))) ;;This is an awfully roundabout downcase, but some machines ;;like symbolics swap cases on the pathname, so we have to do an extra ;;swap!! (defun lowcase (na &aux (*print-case* :downcase)) (pathname-name (pathname (format nil "~a" na)))) (defun our-merge (name path &optional ign ) ign #+lispm (setq name (string-upcase (string name))) (make-pathname :name (string name) :type (pathname-type path) :version (pathname-version path) :host (pathname-host path) :directory (pathname-directory path))) #+kcl (setf (get :link 'load) #'(lambda (path to-link) (declare (special object-path)) (si::faslink (our-merge (lowcase path) object-path) to-link))) (setf (get :link 'compile) #'(lambda (path to-link) to-link (compile-files path *force*))) (setf (get :progn 'load) #'(lambda (&rest args) (eval (cons 'progn args)))) (setf (get :progn 'compile) (get :progn 'load)) (setf (get :load-source 'load) #'(lambda (&rest args) (declare (special source-path)) (load-files args *force* source-path))) (setf (get :load-source-when-compile 'compile) (get :load-source 'load)) ;;should nott use :lisp anymore (setf (get :lisp 'load) #'(lambda (x) (error "please replace :lisp by :load-source"))) (setf (get :serial 'load) #'(lambda (&rest l)(load-files l))) (setf (get :serial 'compile) #'(lambda (&rest l) (dolist (v l) (compile-files v) (load-files v)))) (defun load-files (files &optional (*force* *force*) (object-path object-path) &aux path tem (*load* t)) (declare (special object-path source-path *force* show)) (cond ((atom files) (setq path (object files)) (cond (show (unless (member path *show-files-loaded* :test 'equalp) (push path *show-files-loaded*) (format t "~%(LOAD ~s)" (namestring path)))) ((null *load-function*)) ((or *force* (or (not (setq tem (member path *files-loaded* :test 'equalp :key 'car))) (> (file-write-date path) (cdr (car tem))))) (funcall *load-function* files) (push (cons path (file-write-date path)) *files-loaded*)))) ((keywordp (car files)) (let ((fun (get (car files) 'load))) (cond (fun (apply fun (cdr files)))))) (t (dolist (v files) (load-files v *force* object-path))))) (defun file-date (file) (if (probe-file file) (or (file-write-date file) 0) 0)) (defun source (file) (declare (special source-path)) (our-merge (lowcase file) source-path)) (defun object (file) (declare (special object-path)) (our-merge (lowcase file) object-path)) ;;for lisp machines, and others where checking date is slow, this ;;we should try to cache some dates, and then remove them as we do ;;things like compile files... (defun file-out-dated (file) (let ((obj-date (file-date (object file)))) (or (<= obj-date (file-date (source file))) (dolist (v *depends*) (cond ((or (and (consp (car v)) (member file (car v))) (eq (car v) file)) (dolist (w (if (consp (second v)) (second v) (cdr v))) (cond ((or (<= obj-date (file-date (source w))) (member w *depends-new*)) (return-from file-out-dated t)))))))))) (defun make-compile-file ( l) (format t "~&Begin compile ~a at ~a~%" l (print-date nil)) (dolist (v *when-compile*) (eval v)) (setq *when-compile* nil) ;;Franz excl needs pathnames quoted, and some other lisp ;;would not allow an apply here. Sad. (eval `(compile-file ',(source l) :output-file ',(object l) ,@ *cflags*)) (format t "~&End compile ~a at ~a~%" l (print-date nil)) ) (defvar *load-fn-too* nil) (defun make-load-file (l) (let ((na (object l))) (load na) (if (and *load-fn-too* (probe-file (setq na (our-merge (lowcase l) (merge-pathnames "foo.fn" na))))) (load na)) )) ;;these are versions which don't really compile or load files, but ;;do create a new "compiled file" and "fake load" to test date mechanism. #+debug (defun make-compile-file (file) (format t "~%Fake Compile ~a" (namestring (source file))) (dolist (v *when-compile*) (eval v)) (setq *when-compile* nil) (with-open-file (st (object file) :direction :output) (format st "(print (list 'hi))"))) #+debug (defun make-load-file (l) (format t "~%Fake loading ~a" (namestring(object l)))) (defun compile-files (files &optional (*force* *force*) &key (source-path source-path) (object-path object-path) &aux (*compile* t) ) (declare (special object-path source-path *force* show)) (cond ((atom files) (when (or *force* (file-out-dated files)) (push files *depends-new*) (cond (show (format t "~%(COMPILE-FILE ~s)" (namestring (source files)))) (t (and *compile-file-function* (funcall *compile-file-function* files)) )))) ((keywordp (car files)) (let ((fun (get (car files) 'compile))) (if fun (apply fun (cdr files))))) (t (dolist (v files) (compile-files v *force*))))) ;;Return the files for SYSTEM (defun system-files (system &aux *files*) (declare (special *files*)) (let ((sys (get system :make))) (get-files1 sys)) (nreverse *files*)) (defun get-files1 (sys) (declare (special *files*)) (cond ((and sys (atom sys) )(pushnew sys *files*)) ((eq (car sys) :serial) (get-files1 (cdr sys))) ((keywordp (car sys))) (t (dolist (v sys) (get-files1 v))))) (defmacro make-user-init (files &aux (object-path (if (boundp 'object-path) object-path "foo.o"))) (declare (special object-path)) `(progn (clines "void gcl_init_or_load1 (); #define init_or_load(fn,file) do {extern int fn(); gcl_init_or_load1(fn,file);} while(0) user_init{") ,@ (sloop::sloop for x in files for f = (substitute #\- #\_ (lowcase x)) for ff = (namestring (truename (object x))) collect `(clines ,(Format nil "init_or_load(init_~a,\"~a\");" f ff))) (clines "}"))) gcl-2.6.14/lsp/gcl_merge_pathnames.lsp0000644000175000017500000000175514360276512016305 0ustar cammcamm(in-package :si) (defun merge-pathnames (p &optional (def *default-pathname-defaults*) (def-v :newest) &aux dflt (pn (pathname p))(def-pn (pathname def))) (declare (optimize (safety 1))) (check-type p pathname-designator) (check-type def pathname-designator) (check-type def-v (or null (eql :newest) seqind)) (labels ((def (x) (when x (setq dflt t) x))) (make-pathname :host (or (pathname-host pn) (def (pathname-host def-pn))) :device (or (pathname-device pn) (def (pathname-device def-pn))) :directory (let ((d (pathname-directory pn))(defd (pathname-directory def-pn))) (or (def (when (and defd (eq (car d) :relative)) (append defd (cdr d)))) d (def defd))) :name (or (pathname-name pn) (def (pathname-name def-pn))) :type (or (pathname-type pn) (def (pathname-type def-pn))) :version (or (pathname-version pn) (def (unless (pathname-name pn) (pathname-version def-pn))) (def def-v)) :version (unless dflt (return-from merge-pathnames pn))))) gcl-2.6.14/lsp/gcl_make_defpackage.lsp0000644000175000017500000000373314360276512016213 0ustar cammcamm;;; Thu Aug 12 14:22:09 1993 by Mark Kantrowitz ;;; make-defpackage.lisp -- 1961 bytes ;;; **************************************************************** ;;; Make a Defpackage Form From Package State ********************** ;;; **************************************************************** (in-package :si) (defun make-defpackage-form (package-name) "Given a package, returns a defpackage form that could recreate the current state of the package, more or less." (let ((package (find-package package-name))) (let* ((name (package-name package)) (nicknames (package-nicknames package)) (package-use-list (package-use-list package)) (use-list (mapcar #'package-name package-use-list)) (externs nil) (shadowed-symbols (package-shadowing-symbols package)) (imports nil) (shadow-imports nil) (pure-shadow nil) (pure-import nil)) (do-external-symbols (sym package) (push (symbol-name sym) externs)) (do-symbols (sym package) (unless (or (eq package (symbol-package sym)) (find (symbol-package sym) package-use-list)) (push sym imports))) (setq shadow-imports (intersection shadowed-symbols imports)) (setq pure-shadow (set-difference shadowed-symbols shadow-imports)) (setq pure-import (set-difference imports shadow-imports)) `(defpackage ,name ,@(when nicknames `((:nicknames ,@nicknames))) ,@(when use-list `((:use ,@use-list))) ,@(when externs `((:export ,@externs))) ;; skip :intern ,@(when pure-shadow `((:shadow ,@(mapcar #'symbol-name pure-shadow)))) ,@(when shadow-imports (mapcar #'(lambda (symbol) `((:shadowing-import-from ,(package-name (symbol-package symbol)) ,(symbol-name symbol)))) shadow-imports)) ,@(when pure-import (mapcar #'(lambda (symbol) `((:import-from ,(package-name (symbol-package symbol)) ,(symbol-name symbol)))) pure-import)))))) ;;; *EOF* gcl-2.6.14/lsp/gcl_describe.lsp0000755000175000017500000004212214360276512014722 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; describe.lsp ;;;; ;;;; DESCRIBE and INSPECT (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defvar *inspect-level* 0) (defvar *inspect-history* nil) (defvar *inspect-mode* nil) (defvar *old-print-level* nil) (defvar *old-print-length* nil) (defun inspect-read-line () (do ((char (read-char *query-io*) (read-char *query-io*))) ((or (char= char #\Newline) (char= char #\Return))))) (defun read-inspect-command (label object allow-recursive) (unless *inspect-mode* (inspect-indent-1) (if allow-recursive (progn (princ label) (inspect-object object)) (format t label object)) (return-from read-inspect-command nil)) (loop (inspect-indent-1) (if allow-recursive (progn (princ label) (inspect-indent) (prin1 object)) (format t label object)) (write-char #\Space) (force-output) (case (do ((char (read-char *query-io*) (read-char *query-io*))) ((and (char/= char #\Space) (char/= #\Tab)) char)) ((#\Newline #\Return) (when allow-recursive (inspect-object object)) (return nil)) ((#\n #\N) (inspect-read-line) (when allow-recursive (inspect-object object)) (return nil)) ((#\s #\S) (inspect-read-line) (return nil)) ((#\p #\P) (inspect-read-line) (let ((*print-pretty* t) (*print-level* nil) (*print-length* nil)) (prin1 object) (terpri))) ((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil)) ((#\u #\U) (return (values t (prog1 (eval (read-preserving-whitespace *query-io*)) (inspect-read-line))))) ((#\e #\E) (dolist (x (multiple-value-list (multiple-value-prog1 (eval (read-preserving-whitespace *query-io*)) (inspect-read-line)))) (write x :level *old-print-level* :length *old-print-length*) (terpri))) ((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil)) (t (inspect-read-line) (terpri) (format t "Inspect commands:~%~ n (or N or Newline): inspects the field (recursively).~%~ s (or S): skips the field.~%~ p (or P): pretty-prints the field.~%~ a (or A): aborts the inspection ~ of the rest of the fields.~%~ u (or U) form: updates the field ~ with the value of the form.~%~ e (or E) form: evaluates and prints the form.~%~ q (or Q): quits the inspection.~%~ ?: prints this.~%~%"))))) (defmacro inspect-recursively (label object &optional place) (if place `(multiple-value-bind (update-flag new-value) (read-inspect-command ,label ,object t) (when update-flag (setf ,place new-value))) `(when (read-inspect-command ,label ,object t) (princ "Not updated.") (terpri)))) (defmacro inspect-print (label object &optional place) (if place `(multiple-value-bind (update-flag new-value) (read-inspect-command ,label ,object nil) (when update-flag (setf ,place new-value))) `(when (read-inspect-command ,label ,object nil) (princ "Not updated.") (terpri)))) (defun inspect-indent () (fresh-line) (format t "~V@T" (* 4 (if (< *inspect-level* 8) *inspect-level* 8)))) (defun inspect-indent-1 () (fresh-line) (format t "~V@T" (- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3))) (defun inspect-symbol (symbol) (let ((p (symbol-package symbol))) (cond ((null p) (format t "~:@(~S~) - uninterned symbol" symbol)) ((eq p (find-package "KEYWORD")) (format t "~:@(~S~) - keyword" symbol)) (t (format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package" symbol (multiple-value-bind (b f) (find-symbol (symbol-name symbol) p) (declare (ignore b)) (eq f :external)) (package-name p))))) (when (boundp symbol) (if *inspect-mode* (inspect-recursively "value:" (symbol-value symbol) (symbol-value symbol)) (inspect-print "value:~% ~S" (symbol-value symbol) (symbol-value symbol)))) (do ((pl (symbol-plist symbol) (cddr pl))) ((endp pl)) (unless (and (symbolp (car pl)) (or (eq (symbol-package (car pl)) (find-package 'system)) (eq (symbol-package (car pl)) (find-package 'compiler)))) (if *inspect-mode* (inspect-recursively (format nil "property ~S:" (car pl)) (cadr pl) (get symbol (car pl))) (inspect-print (format nil "property ~:@(~S~):~% ~~S" (car pl)) (cadr pl) (get symbol (car pl)))))) (when (print-doc symbol t) (format t "~&-----------------------------------------------------------------------------~%")) ) (defun inspect-package (package) (format t "~S - package" package) (when (package-nicknames package) (inspect-print "nicknames: ~S" (package-nicknames package))) (when (package-use-list package) (inspect-print "use list: ~S" (package-use-list package))) (when (package-used-by-list package) (inspect-print "used-by list: ~S" (package-used-by-list package))) (when (package-shadowing-symbols package) (inspect-print "shadowing symbols: ~S" (package-shadowing-symbols package)))) (defun inspect-character (character) (format t (cond ((standard-char-p character) "~S - standard character") (t "~S - character")) character) (inspect-print "code: #x~X" (char-code character)) (inspect-print "bits: ~D" (char-bits character)) (inspect-print "font: ~D" (char-font character))) (defun inspect-number (number) (case (type-of number) (fixnum (format t "~S - fixnum (32 bits)" number)) (bignum (format t "~S - bignum" number)) (ratio (format t "~S - ratio" number) (inspect-recursively "numerator:" (numerator number)) (inspect-recursively "denominator:" (denominator number))) (complex (format t "~S - complex" number) (inspect-recursively "real part:" (realpart number)) (inspect-recursively "imaginary part:" (imagpart number))) ((short-float single-float) (format t "~S - short-float" number) (multiple-value-bind (signif expon sign) (integer-decode-float number) (declare (ignore sign)) (inspect-print "exponent: ~D" expon) (inspect-print "mantissa: ~D" signif))) ((long-float double-float) (format t "~S - long-float" number) (multiple-value-bind (signif expon sign) (integer-decode-float number) (declare (ignore sign)) (inspect-print "exponent: ~D" expon) (inspect-print "mantissa: ~D" signif))))) (defun inspect-cons (cons) (format t (case (car cons) ((lambda lambda-block lambda-closure lambda-block-closure) "~S - function") (quote "~S - constant") (t "~S - cons")) cons) (when *inspect-mode* (do ((i 0 (1+ i)) (l cons (cdr l))) ((atom l) (inspect-recursively (format nil "nthcdr ~D:" i) l (cdr (nthcdr (1- i) cons)))) (inspect-recursively (format nil "nth ~D:" i) (car l) (nth i cons))))) (defun inspect-string (string) (format t (if (simple-string-p string) "~S - simple string" "~S - string") string) (inspect-print "dimension: ~D"(array-dimension string 0)) (when (array-has-fill-pointer-p string) (inspect-print "fill pointer: ~D" (fill-pointer string) (fill-pointer string))) (when *inspect-mode* (dotimes (i (array-dimension string 0)) (inspect-recursively (format nil "aref ~D:" i) (char string i) (char string i))))) (defun inspect-vector (vector) (format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector") vector) (inspect-print "dimension: ~D" (array-dimension vector 0)) (when (array-has-fill-pointer-p vector) (inspect-print "fill pointer: ~D" (fill-pointer vector) (fill-pointer vector))) (when *inspect-mode* (dotimes (i (array-dimension vector 0)) (inspect-recursively (format nil "aref ~D:" i) (aref vector i) (aref vector i))))) (defun inspect-array (array) (format t (if (adjustable-array-p array) "~S - adjustable aray" "~S - array") array) (inspect-print "rank: ~D" (array-rank array)) (inspect-print "dimensions: ~D" (array-dimensions array)) (inspect-print "total size: ~D" (array-total-size array))) (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) (let* ((sd (get name 'si::s-data)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" (aref spos (nth 4 v)) (let ((type (nth 2 v))) (if (eq t type) nil type)) (car v) (structure-ref1 x (nth 4 v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) (when (and (not *inspect-mode*) (or (> *inspect-level* 5) (member object *inspect-history*))) (prin1 object) (return-from inspect-object)) (incf *inspect-level*) (push object *inspect-history*) (catch 'abort-inspect (cond ((symbolp object) (inspect-symbol object)) ((packagep object) (inspect-package object)) ((characterp object) (inspect-character object)) ((numberp object) (inspect-number object)) ((consp object) (inspect-cons object)) ((stringp object) (inspect-string object)) ((vectorp object) (inspect-vector object)) ((arrayp object) (inspect-array object)) ((structurep object)(inspect-structure object)) (t (format t "~S - ~S" object (type-of object)))))) (defun describe (object &aux (*inspect-mode* nil) (*inspect-level* 0) (*inspect-history* nil) (*print-level* nil) (*print-length* nil)) ; "The lisp function DESCRIBE." (terpri) (catch 'quit-inspect (inspect-object object)) (terpri) (values)) (defun inspect (object &aux (*inspect-mode* t) (*inspect-level* 0) (*inspect-history* nil) (*old-print-level* *print-level*) (*old-print-length* *print-length*) (*print-level* 3) (*print-length* 3)) ; "The lisp function INSPECT." (read-line) (princ "Type ? and a newline for help.") (terpri) (catch 'quit-inspect (inspect-object object)) (terpri) (values)) (defun print-doc (symbol &optional (called-from-apropos-doc-p nil) &aux (f nil) x) (flet ((doc1 (doc ind) (setq f t) (format t "~&-----------------------------------------------------------------------------~%~53S~24@A~%~A" symbol ind doc)) (good-package () (if (eq (symbol-package symbol) (find-package "LISP")) (find-package "SYSTEM") *package*))) (cond ((special-operator-p symbol) (doc1 (or (documentation symbol 'function) "") (if (macro-function symbol) "[Special form and Macro]" "[Special form]"))) ((macro-function symbol) (doc1 (or (documentation symbol 'function) "") "[Macro]")) ((fboundp symbol) (doc1 (or (documentation symbol 'function) (if (consp (setq x (symbol-function symbol))) (case (car x) (lambda (format nil "~%Args: ~S" (cadr x))) (lambda-block (format nil "~%Args: ~S" (caddr x))) (lambda-closure (format nil "~%Args: ~S" (car (cddddr x)))) (lambda-block-closure (format nil "~%Args: ~S" (cadr (cddddr x)))) (t "")) "")) "[Function]")) ((setq x (documentation symbol 'function)) (doc1 x "[Macro or Function]"))) (cond ((constantp symbol) (unless (and (eq (symbol-package symbol) (find-package "KEYWORD")) (null (documentation symbol 'variable))) (doc1 (or (documentation symbol 'variable) "") "[Constant]"))) ((si:specialp symbol) (doc1 (or (documentation symbol 'variable) "") "[Special variable]")) ((or (setq x (documentation symbol 'variable)) (boundp symbol)) (doc1 (or x "") "[Variable]"))) (cond ((setq x (documentation symbol 'type)) (doc1 x "[Type]")) ((setq x (get symbol 'deftype-form)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x) "[Type]")))) (cond ((setq x (documentation symbol 'structure)) (doc1 x "[Structure]")) ((setq x (get symbol 'defstruct-form)) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x) "[Structure]"))) (cond ((setq x (documentation symbol 'setf)) (doc1 x "[Setf]")) ((setq x (get symbol 'setf-update-fn)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." `(defsetf ,symbol ,(get symbol 'setf-update-fn))) "[Setf]"))) ((setq x (get symbol 'setf-lambda)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." `(defsetf ,symbol ,@(get symbol 'setf-lambda))) "[Setf]"))) ((setq x (get symbol 'setf-method)) (let ((*package* (good-package))) (doc1 (format nil "~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]" (if (consp x) (case (car x) (lambda `(define-setf-method ,@(cdr x))) (lambda-block `(define-setf-method ,@(cddr x))) (lambda-closure `(define-setf-method ,@(cddddr x))) (lambda-block-closure `(define-setf-method ,@(cdr (cddddr x)))) (t nil)) nil)) "[Setf]")))) ) (idescribe (symbol-name symbol)) (if called-from-apropos-doc-p f (progn (if f (format t "~&-----------------------------------------------------------------------------") (format t "~&No documentation for ~:@(~S~)." symbol)) (values)))) (defun apropos-doc (string &optional (package 'lisp) &aux (f nil)) (setq string (string string)) (if package (do-symbols (symbol package) (when (substringp string (string symbol)) (setq f (or (print-doc symbol t) f)))) (do-all-symbols (symbol) (when (substringp string (string symbol)) (setq f (or (print-doc symbol t) f))))) (if f (format t "~&-----------------------------------------------------------------------------") (format t "~&No documentation for ~S in ~:[any~;~A~] package." string package (and package (package-name (coerce-to-package package))))) (values)) gcl-2.6.14/lsp/gcl_seq.lsp0000755000175000017500000001150014360276512013726 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; seq.lsp ;;;; ;;;; sequence routines (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defun make-sequence (type size &key (initial-element nil iesp) &aux element-type sequence) (setq element-type (cond ((eq type 'list) (return-from make-sequence (if iesp (make-list size :initial-element initial-element) (make-list size)))) ((or (eq type 'simple-string) (eq type 'string)) 'character) ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit) ((or (eq type 'simple-vector) (eq type 'vector)) t) (t (setq type (normalize-type type)) (when (subtypep (car type) 'list) (if (or (and (eq 'null (car type)) (not (equal size 0))) (and (eq 'cons (car type)) (equal size 0))) (error 'type-error :datum type :expected-type (format nil "list (size ~S)" size))) (return-from make-sequence (if iesp (make-list size :initial-element initial-element) (make-list size)))) (unless (or (eq (car type) 'array) (eq (car type) 'simple-array)) (error 'type-error :datum type :expected-type 'sequence)) (let ((ssize (caddr type))) (if (listp ssize) (setq ssize (car ssize))) (if (not (si::fixnump ssize)) (setq ssize size)) (unless (equal ssize size) (error 'type-error :datum type :expected-type (format nil "~S (size ~S)" type size)))) (or (cadr type) t)))) (setq element-type (si::best-array-element-type element-type)) (setq sequence (si:make-vector element-type size nil nil nil nil nil)) (when iesp (do ((i 0 (1+ i)) (size size)) ((>= i size)) (declare (fixnum i size)) (setf (elt sequence i) initial-element))) sequence) (defun concatenate (result-type &rest sequences) (do ((x (make-sequence result-type (apply #'+ (mapcar #'length sequences)))) (s sequences (cdr s)) (i 0)) ((null s) x) (declare (fixnum i)) (do ((j 0 (1+ j)) (n (length (car s)))) ((>= j n)) (declare (fixnum j n)) (setf (elt x i) (elt (car s) j)) (incf i)))) (defun map (result-type function sequence &rest more-sequences) (setq more-sequences (cons sequence more-sequences)) (let ((l (apply #'min (mapcar #'length more-sequences)))) (if (null result-type) (do ((i 0 (1+ i)) (l l)) ((>= i l) nil) (declare (fixnum i l)) (apply function (mapcar #'(lambda (z) (elt z i)) more-sequences))) (let ((x (make-sequence result-type l))) (do ((i 0 (1+ i)) (l l)) ((>= i l) x) (declare (fixnum i l)) (setf (elt x i) (apply function (mapcar #'(lambda (z) (elt z i)) more-sequences)))))))) (defun some (predicate sequence &rest more-sequences) (setq more-sequences (cons sequence more-sequences)) (do ((i 0 (1+ i)) (l (apply #'min (mapcar #'length more-sequences)))) ((>= i l) nil) (declare (fixnum i l)) (let ((that-value (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences)))) (when that-value (return that-value))))) (defun every (predicate sequence &rest more-sequences) (setq more-sequences (cons sequence more-sequences)) (do ((i 0 (1+ i)) (l (apply #'min (mapcar #'length more-sequences)))) ((>= i l) t) (declare (fixnum i l)) (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences)) (return nil)))) (defun notany (predicate sequence &rest more-sequences) (not (apply #'some predicate sequence more-sequences))) (defun notevery (predicate sequence &rest more-sequences) (not (apply #'every predicate sequence more-sequences))) gcl-2.6.14/lsp/gcl_defstruct.lsp0000755000175000017500000007542214360276512015156 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; DEFSTRUCT.LSP ;;;; ;;;; The structure routines. (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defvar *accessors* (make-array 10 :adjustable t)) (defvar *list-accessors* (make-array 2 :adjustable t)) (defvar *vector-accessors* (make-array 2 :adjustable t)) (or (fboundp 'record-fn) (setf (symbol-function 'record-fn) #'(lambda (&rest l) l nil))) (defun make-access-function (name conc-name no-conc type named include no-fun ;; from apply slot-name default-init slot-type read-only offset &optional predicate ) (declare (ignore named default-init predicate )) (let ((access-function (if no-conc slot-name (intern (si:string-concatenate (string conc-name) (string slot-name))))) accsrs dont-overwrite) (ecase type ((nil) (setf accsrs *accessors*)) (list (setf accsrs *list-accessors*)) (vector (setf accsrs *vector-accessors*))) (or (> (length accsrs) offset) (adjust-array accsrs (+ offset 10))) (unless dont-overwrite (record-fn access-function 'defun '(t) slot-type) (or no-fun (and (fboundp access-function) (eq (aref accsrs offset) (symbol-function access-function))) (setf (symbol-function access-function) (or (aref accsrs offset) (setf (aref accsrs offset) (cond ((eq accsrs *accessors*) #'(lambda (x) (or (structurep x) (error "~a is not a structure" x)) (structure-ref1 x offset))) ((eq accsrs *list-accessors*) #'(lambda(x) (si:list-nth offset x))) ((eq accsrs *vector-accessors*) #'(lambda(x) (aref x offset))))))))) (cond (read-only (remprop access-function 'structure-access) (setf (get access-function 'struct-read-only) t)) (t (remprop access-function 'setf-update-fn) (remprop access-function 'setf-lambda) (remprop access-function 'setf-documentation) (let ((tem (get access-function 'structure-access))) (cond ((and (consp tem) include (subtypep include (car tem)) (eql (cdr tem) offset)) ;; don't change overwrite accessor of subtype. (setq dont-overwrite t) ) (t (setf (get access-function 'structure-access) (cons (if type type name) offset)) (when slot-type (proclaim `(ftype (function (,name) ,slot-type) ,access-function))) ))))) nil)) (defun make-constructor (name constructor type named slot-descriptions) (declare (ignore named)) (let ((slot-names ;; Collect the slot-names. (mapcar #'(lambda (x) (cond ((null x) ;; If the slot-description is NIL, ;; it is in the padding of initial-offset. nil) ((null (car x)) ;; If the slot name is NIL, ;; it is the structure name. ;; This is for typed structures with names. (list 'quote (cadr x))) (t (car x)))) slot-descriptions)) (keys ;; Make the keyword parameters. (mapcan #'(lambda (x) (cond ((null x) nil) ((null (car x)) nil) ((null (cadr x)) (list (car x))) (t (list (list (car x) (cadr x)))))) slot-descriptions))) (cond ((consp constructor) ;; The case for a BOA constructor. ;; Dirty code!! ;; We must add an initial value for an optional parameter, ;; if the default value is not specified ;; in the given parameter list and yet the initial value ;; is supplied in the slot description. (do ((a (cadr constructor) (cdr a)) (l nil) (vs nil)) ((endp a) ;; Add those options that do not appear in the parameter list ;; as auxiliary paramters. ;; The parameters are accumulated in the variable VS. (setq keys (nreconc (cons '&aux l) (mapcan #'(lambda (k) (if (member (if (atom k) k (car k)) vs) nil (list k))) keys)))) ;; Skip until &OPTIONAL appears. (when (member (car a) lambda-list-keywords) (or (eq (car a) '&optional) (push '&optional a))) (cond ((eq (car a) '&optional) (setq l (cons '&optional l)) (do ((aa (cdr a) (cdr aa)) (ov) (y)) ((endp aa) ;; Add those options that do not appear in the ;; parameter list. (setq keys (nreconc (cons '&aux l) (mapcan #'(lambda (k) (if (member (if (atom k) k (car k)) vs) nil (list k))) keys))) (return nil)) (when (member (car aa) lambda-list-keywords) (when (eq (car aa) '&rest) ;; &REST is found. (setq l (cons '&rest l)) (setq aa (cdr aa)) (unless (and (not (endp aa)) (symbolp (car aa))) (illegal-boa)) (setq vs (cons (car aa) vs)) (setq l (cons (car aa) l)) (setq aa (cdr aa)) (when (endp aa) (setq keys (nreconc (cons '&aux l) (mapcan #'(lambda (k) (if (member (if (atom k) k (car k)) vs) nil (list k))) keys))) (return nil))) ;; &AUX should follow. (unless (eq (car aa) '&aux) (illegal-boa)) (setq l (cons '&aux l)) (do ((aaa (cdr aa) (cdr aaa))) ((endp aaa)) (setq l (cons (car aaa) l)) (cond ((and (atom (car aaa)) (symbolp (car aaa))) (setq vs (cons (car aaa) vs))) ((and (symbolp (caar aaa)) (or (endp (cdar aaa)) (endp (cddar aaa)))) (setq vs (cons (caar aaa) vs))) (t (illegal-boa)))) ;; End of the parameter list. (setq keys (nreconc l (mapcan #'(lambda (k) (if (member (if (atom k) k (car k)) vs) nil (list k))) keys))) (return nil)) ;; Checks if the optional paramter without a default ;; value has a default value in the slot-description. (if (and (cond ((atom (car aa)) (setq ov (car aa)) t) ((endp (cdar aa)) (setq ov (caar aa)) t) (t nil)) (setq y (member ov keys :key #'(lambda (x) (if (consp x) ;; With default value. (car x)))))) ;; If no default value is supplied for ;; the optional parameter and yet appears ;; in KEYS with a default value, ;; then cons the pair to L, (setq l (cons (car y) l)) ;; otherwise cons just the parameter to L. (setq l (cons (car aa) l))) ;; Checks the form of the optional parameter. (cond ((atom (car aa)) (unless (symbolp (car aa)) (illegal-boa)) (setq vs (cons (car aa) vs))) ((not (symbolp (caar aa))) (illegal-boa)) ((or (endp (cdar aa)) (endp (cddar aa))) (setq vs (cons (caar aa) vs))) ((not (symbolp (caddar aa))) (illegal-boa)) ((not (endp (cdddar aa))) (illegal-boa)) (t (setq vs (cons (caar aa) vs)) (setq vs (cons (caddar aa) vs))))) ;; RETURN from the outside DO. (return nil)) (t (unless (symbolp (car a)) (illegal-boa)) (setq l (cons (car a) l)) (setq vs (cons (car a) vs))))) (setq constructor (car constructor))) (t ;; If not a BOA constructor, just cons &KEY. (setq keys (cons '&key keys)))) (cond ((null type) `(defun ,constructor ,keys (si:make-structure ',name ,@slot-names))) ((or (eq type 'vector) (and (consp type) (eq (car type) 'vector))) `(defun ,constructor ,keys (vector ,@slot-names))) ((eq type 'list) `(defun ,constructor ,keys (list ,@slot-names))) ((error "~S is an illegal structure type" type))))) (defun illegal-boa () (error "An illegal BOA constructor.")) (defun make-predicate (name predicate type named name-offset) (cond ((null type)) ; done in define-structure ((or (eq type 'vector) (and (consp type) (eq (car type) 'vector))) ;; The name is at the NAME-OFFSET in the vector. (unless named (error "The structure should be named.")) `(defun ,predicate (x) (and (vectorp x) (> (the fixnum (length x)) ,name-offset) (eq (aref (the (vector t) x) ,name-offset) ',name)))) ((eq type 'list) ;; The name is at the NAME-OFFSET in the list. (unless named (error "The structure should be named.")) (if (= name-offset 0) `(defun ,predicate (x) (and (consp x) (eq (car x) ',name))) `(defun ,predicate (x) (do ((i ,name-offset (1- i)) (z x (cdr z))) ((= i 0) (and (consp z) (eq (car z) ',name))) (declare (fixnum i)) (unless (consp z) (return nil)))))) ((error "~S is an illegal structure type.")))) ;;; PARSE-SLOT-DESCRIPTION parses the given slot-description ;;; and returns a list of the form: ;;; (slot-name default-init slot-type read-only offset) (defun parse-slot-description (slot-description offset) (let (slot-name default-init slot-type read-only) (cond ((atom slot-description) (setq slot-name slot-description)) ((endp (cdr slot-description)) (setq slot-name (car slot-description))) (t (setq slot-name (car slot-description)) (setq default-init (cadr slot-description)) (do ((os (cddr slot-description) (cddr os)) (o) (v)) ((endp os)) (setq o (car os)) (when (endp (cdr os)) (error "~S is an illegal structure slot option." os)) (setq v (cadr os)) (case o (:type (setq slot-type v)) (:read-only (setq read-only v)) (t (error "~S is an illegal structure slot option." os)))))) (list slot-name default-init slot-type read-only offset))) ;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions ;;; with the new descriptions which are specified in the ;;; :include defstruct option. (defun overwrite-slot-descriptions (news olds) (if (null olds) nil (let ((sds (member (caar olds) news :key #'car))) (cond (sds (when (and (null (cadddr (car sds))) (cadddr (car olds))) ;; If read-only is true in the old ;; and false in the new, signal an error. (error "~S is an illegal include slot-description." sds)) ;; If (setf (caddr (car sds)) (best-array-element-type (caddr (car sds)))) (when (not (equal (normalize-type (or (caddr (car sds)) t)) (normalize-type (or (caddr (car olds)) t)))) (error "Type mismmatch for included slot ~a" (car sds))) (cons (list (caar sds) (cadar sds) (caddar sds) (cadddr (car sds)) ;; The offset if from the old. (car (cddddr (car olds)))) (overwrite-slot-descriptions news (cdr olds)))) (t (cons (car olds) (overwrite-slot-descriptions news (cdr olds)))))))) (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) (defvar *alignment-t* (alignment t)) (defun make-t-type (n include slot-descriptions &aux i) (let ((res (make-array n :element-type 'unsigned-char :static t))) (when include (let ((tem (get include 's-data))raw) (or tem (error "Included structure undefined ~a" include)) (setq raw (s-data-raw tem)) (dotimes (i (min n (length raw))) (setf (aref res i) (aref raw i))))) (dolist (v slot-descriptions) (setq i (nth 4 v)) (let ((type (third v))) (cond ((<= (the fixnum (alignment type)) *alignment-t*) (setf (aref res i) (aet-type type)))))) (cond ((< n (length *all-t-s-type*)) (dotimes (i n) (cond ((not (eql (the fixnum (aref res i)) 0)) (return-from make-t-type res)))) *all-t-s-type*) (t res)))) (defvar *standard-slot-positions* (let ((ar (make-array 50 :element-type 'unsigned-short :static t))) (dotimes (i 50) (declare (fixnum i)) (setf (aref ar i)(* (size-of t) i))) ar)) (eval-when (compile ) (proclaim '(function round-up (fixnum fixnum ) fixnum)) ) (defun round-up (a b) (declare (fixnum a b)) (setq a (ceiling a b)) (the fixnum (* a b))) (defun get-slot-pos (leng include slot-descriptions &aux type small-types has-holes) (declare (special *standard-slot-positions*)) include (dolist (v slot-descriptions) (when (and v (car v)) (setf type (best-array-element-type (caddr v)) (caddr v) type) (let ((val (second v))) (unless (typep val type) (if (and (symbolp val) (constantp val)) (setf val (symbol-value val))) (and (constantp val) (setf (cadr v) (coerce val type))))) (cond ((memq type '(signed-char unsigned-char short unsigned-short long-float bit)) (setq small-types t))))) (cond ((and (null small-types) (< leng (length *standard-slot-positions*)) (list *standard-slot-positions* (* leng (size-of t)) nil))) (t (let ((ar (make-array leng :element-type 'unsigned-short :static t)) (pos 0)(i 0)(align 0)type (next-pos 0)) (declare (fixnum pos i align next-pos)) ;; A default array. (dolist (v slot-descriptions) (setq type (caddr v)) (setq align (alignment type)) (unless (<= align *alignment-t*) (setq type t) (setf (caddr v) t) (setq align *alignment-t*) (setq v (nconc v '(t)))) (setq next-pos (round-up pos align)) (or (eql pos next-pos) (setq has-holes t)) (setq pos next-pos) (setf (aref ar i) pos) (incf pos (size-of type)) (incf i)) (list ar (round-up pos (size-of t)) has-holes) )))) (defun define-structure (name conc-name no-conc type named slot-descriptions copier static include print-function constructors offset predicate &optional documentation no-funs &aux def leng) (and (consp type) (eq (car type) 'vector)(setq type 'vector)) (setq leng(length slot-descriptions)) (dolist (x slot-descriptions) (and x (car x) (apply #'make-access-function name conc-name no-conc type named include no-funs x ))) (when (and copier (not no-funs)) (setf (symbol-function copier) (ecase type ((nil) #'si::copy-structure) (list #'copy-list) (vector #'copy-seq)))) (cond ((and (null type) (eq name 's-data)) ;bootstrapping code! (setq def (make-s-data-structure (make-array (* leng (size-of t)) :element-type 'character :static t) (make-t-type leng nil slot-descriptions) *standard-slot-positions* slot-descriptions t )) ) (t (let (slot-position (size 0) has-holes (include-str (and include (get include 's-data)))) (when include-str (cond ((and (s-data-frozen include-str) (or (not (s-data-included include-str)) (not (let ((te (get name 's-data))) (and te (eq (s-data-includes te) include-str)))))) (warn " ~a was frozen but now included" include))) (pushnew name (s-data-included include-str))) (when (null type) (setf slot-position (get-slot-pos leng include slot-descriptions)) (setf size (cadr slot-position) has-holes (caddr slot-position) slot-position (car slot-position) )) (setf def (make-s-data :name name :length leng :raw (and (null type) (make-t-type leng include slot-descriptions)) :slot-position slot-position :size size :has-holes has-holes :staticp static :includes include-str :print-function print-function :slot-descriptions slot-descriptions :constructors constructors :offset offset :type type :named named :documentation documentation :conc-name conc-name))))) (let ((tem (get name 's-data))) (cond ((eq name 's-data) (if tem (warn "not replacing s-data property")) (or tem (setf (get name 's-data) def))) (tem (check-s-data tem def name)) (t (setf (get name 's-data) def))) (when documentation (setf (get name 'structure-documentation) documentation)) (when (and (null type) predicate) (record-fn predicate 'defun '(t) t) (or no-funs (setf (symbol-function predicate) #'(lambda (x) (si::structure-subtype-p x name)))) (proclaim `(ftype (function (,name) t) ,predicate));FIXME boolean is unboxed ) ) nil) (defmacro defstruct (name &rest slots) (let ((slot-descriptions slots) options conc-name constructors default-constructor no-constructor copier predicate predicate-specified include print-function type named initial-offset offset name-offset documentation static (no-conc nil)) (when (consp name) ;; The defstruct options are supplied. (setq options (cdr name)) (setq name (car name))) ;; The default conc-name. (setq conc-name (si:string-concatenate (string name) "-")) ;; The default constructor. (setq default-constructor (intern (si:string-concatenate "MAKE-" (string name)))) ;; The default copier and predicate. (setq copier (intern (si:string-concatenate "COPY-" (string name))) predicate (intern (si:string-concatenate (string name) "-P"))) ;; Parse the defstruct options. (do ((os options (cdr os)) (o) (v)) ((endp os)) (cond ((and (consp (car os)) (not (endp (cdar os)))) (setq o (caar os) v (cadar os)) (case o (:conc-name (if (null v) (progn (setq conc-name "") (setq no-conc t)) (setq conc-name v))) (:constructor (if (null v) (setq no-constructor t) (if (endp (cddar os)) (setq constructors (cons v constructors)) (setq constructors (cons (cdar os) constructors))))) (:copier (setq copier v)) (:static (setq static v)) (:predicate (setq predicate v) (setq predicate-specified t)) (:include (setq include (cdar os)) (unless (get v 's-data) (error "~S is an illegal included structure." v))) (:print-function (and (consp v) (eq (car v) 'function) (setq v (second v))) (setq print-function v)) (:type (setq type v)) (:initial-offset (setq initial-offset v)) (t (error "~S is an illegal defstruct option." o)))) (t (if (consp (car os)) (setq o (caar os)) (setq o (car os))) (case o (:constructor (setq constructors (cons default-constructor constructors))) ((:copier :predicate :print-function)) (:conc-name (progn (setq conc-name "") (setq no-conc t))) (:named (setq named t)) (t (error "~S is an illegal defstruct option." o)))))) (setq conc-name (intern (string conc-name))) (and include (not print-function) (setq print-function (s-data-print-function (get (car include) 's-data)))) ;; Skip the documentation string. (when (and (not (endp slot-descriptions)) (stringp (car slot-descriptions))) (setq documentation (car slot-descriptions)) (setq slot-descriptions (cdr slot-descriptions))) ;; Check the include option. (when include (unless (equal type (s-data-type (get (car include) 's-data))) (error "~S is an illegal structure include." (car include)))) ;; Set OFFSET. (cond ((null include) (setq offset 0)) (t (setq offset (s-data-offset (get (car include) 's-data))))) ;; Increment OFFSET. (when (and type initial-offset) (setq offset (+ offset initial-offset))) (when (and type named) (setq name-offset offset) (setq offset (1+ offset))) ;; Parse slot-descriptions, incrementing OFFSET for each one. (do ((ds slot-descriptions (cdr ds)) (sds nil)) ((endp ds) (setq slot-descriptions (nreverse sds))) (setq sds (cons (parse-slot-description (car ds) offset) sds)) (setq offset (1+ offset))) ;; If TYPE is non-NIL and structure is named, ;; add the slot for the structure-name to the slot-descriptions. (when (and type named) (setq slot-descriptions (cons (list nil name) slot-descriptions))) ;; Pad the slot-descriptions with the initial-offset number of NILs. (when (and type initial-offset) (setq slot-descriptions (append (make-list initial-offset) slot-descriptions))) ;; Append the slot-descriptions of the included structure. ;; The slot-descriptions in the include option are also counted. (cond ((null include)) ((endp (cdr include)) (setq slot-descriptions (append (s-data-slot-descriptions (get (car include) 's-data)) slot-descriptions))) (t (setq slot-descriptions (append (overwrite-slot-descriptions (mapcar #'(lambda (sd) (parse-slot-description sd 0)) (cdr include)) (s-data-slot-descriptions (get (car include) 's-data) )) slot-descriptions)))) (cond (no-constructor ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors (error "Contradictory constructor options."))) ((null constructors) ;; If no constructor is specified, ;; the default-constructor is made. (setq constructors (list default-constructor)))) ;; We need a default constructor for the sharp-s-reader (or (member t (mapcar 'symbolp constructors)) (push (intern (string-concatenate "__si::" default-constructor)) constructors)) ;; Check the named option and set the predicate. (when (and type (not named)) (when predicate-specified (error "~S is an illegal structure predicate." predicate)) (setq predicate nil)) (when include (setq include (car include))) ;; Check the print-function. (when (and print-function type) (error "A print function is supplied to a typed structure.")) `(progn (define-structure ',name ',conc-name ',no-conc ',type ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors ',offset ',predicate ',documentation ) ,@(mapcar #'(lambda (constructor) (make-constructor name constructor type named slot-descriptions)) constructors) ,@(if (and type predicate) (list (make-predicate name predicate type named name-offset))) ',name ))) ;; First several fields of this must coincide with the C structure ;; s_data (see object.h). (defstruct s-data name (length 0 :type fixnum) raw included includes staticp print-function slot-descriptions slot-position (size 0 :type fixnum) has-holes frozen documentation constructors offset named type conc-name ) (defun check-s-data (tem def name) (cond ((s-data-included tem) (setf (s-data-included def)(s-data-included tem)))) (cond ((s-data-frozen tem) (setf (s-data-frozen def) t))) (unless (equalp def tem) (warn "structure ~a is changing" name) (setf (get name 's-data) def))) (defun freeze-defstruct (name) (let ((tem (and (symbolp name) (get name 's-data)))) (if tem (setf (s-data-frozen tem) t)))) ;;; The #S reader. (defun sharp-s-reader (stream subchar arg) (declare (ignore subchar)) (when (and arg (null *read-suppress*)) (error "An extra argument was supplied for the #S readmacro.")) (let* ((l (prog1 (read stream t nil t) (if *read-suppress* (return-from sharp-s-reader nil)))) (sd (or (get (car l) 's-data) (error "~S is not a structure." (car l))))) ;; Intern keywords in the keyword package. (do ((ll (cdr l) (cddr ll))) ((endp ll) ;; Find an appropriate construtor. (do ((cs (s-data-constructors sd) (cdr cs))) ((endp cs) (error "The structure ~S has no structure constructor." (car l))) (when (symbolp (car cs)) (return (apply (car cs) (cdr l)))))) (rplaca ll (intern (string (car ll)) 'keyword))))) ;; Set the dispatch macro. (set-dispatch-macro-character #\# #\s 'sharp-s-reader) (set-dispatch-macro-character #\# #\S 'sharp-s-reader) ;; Examples from Common Lisp Reference Manual. #| (defstruct ship x-position y-position x-velocity y-velocity mass) (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person1 name (age 20 :type fixnum) sex) (defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) ;(defstruct person name age sex) (defstruct (astronaut (:include person (age 45 :type fixnum)) (:conc-name astro-)) helmet-size (favorite-beverage 'tang)) (defstruct (foo (:constructor create-foo (a &optional b (c 'sea) &rest d &aux e (f 'eff)))) a (b 'bee) c d e f) (defstruct (binop (:type list) :named (:initial-offset 2)) (operator '?) operand-1 operand-2) (defstruct (annotated-binop (:type list) (:initial-offset 3) (:include binop)) commutative associative identity) |# gcl-2.6.14/lsp/sys-proclaim.lisp0000755000175000017500000010154014360276512015110 0ustar cammcamm (COMMON-LISP::IN-PACKAGE "SYSTEM") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T) COMMON-LISP::YES-OR-NO-P SYSTEM::GPROF-START SYSTEM::BREAK-LOCALS ANSI-LOOP::MAKE-LOOP-UNIVERSE SYSTEM::MAKE-CONTEXT SYSTEM::MAYBE-CLEAR-INPUT COMMON-LISP::Y-OR-N-P SLOOP::PARSE-LOOP-DECLARE SYSTEM::STEP-INTO SYSTEM::STEP-NEXT COMMON-LISP::USER-HOMEDIR-PATHNAME COMMON-LISP::ABORT SYSTEM::MAKE-INSTREAM COMMON-LISP::COMPUTE-RESTARTS SYSTEM::LOC SYSTEM::NEXT-MATCH SLOOP::PARSE-LOOP-WITH ANSI-LOOP::LOOP-GENTEMP SYSTEM::CURRENT-STEP-FUN COMMON-LISP::BREAK ANSI-LOOP::MAKE-LOOP-COLLECTOR SYSTEM::MAKE-RESTART COMMON-LISP::MAKE-PATHNAME ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE SYSTEM::MAKE-S-DATA SYSTEM::GPROF-QUIT SYSTEM::TRANSFORM-KEYWORDS COMMON-LISP::DRIBBLE SYSTEM::DESCRIBE-ENVIRONMENT COMMON-LISP::VECTOR SYSTEM::DBL-READ ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL ANSI-LOOP::MAKE-LOOP-PATH ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*) SYSTEM::BREAK-GO SYSTEM::END-WAITING ANSI-LOOP::NAMED-VARIABLE ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES SYSTEM::INSPECT-OBJECT SYSTEM::GET-&ENVIRONMENT SYSTEM::BREAK-LEVEL-INVOKE-RESTART COMMON-LISP::INSPECT SYSTEM::DO-F COMMON-LISP::DESCRIBE SYSTEM::WAITING SYSTEM::FIND-DECLARATIONS COMMON-LISP::PRIN1-TO-STRING ANSI-LOOP::LOOP-LIST-STEP SYSTEM::REWRITE-RESTART-CASE-CLAUSE SYSTEM::EXPAND-RANGES SYSTEM::PARSE-BODY-HEADER COMMON-LISP::INVOKE-RESTART-INTERACTIVELY SYSTEM::INFO-SUBFILE COMMON-LISP::PRINC-TO-STRING SYSTEM::INSTREAM-NAME)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) COMMON-LISP::T) COMMON-LISP::T) SYSTEM::SMALLNTHCDR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::QUICK-SORT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::BIGNTHCDR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) ANSI-LOOP::LOOP-DO-RETURN SLOOP::PARSE-LOOP-COLLECT SYSTEM::READ-EVALUATED-FORM SYSTEM::INSPECT-INDENT-1 SLOOP::PARSE-LOOP-WHEN SYSTEM::TEST-ERROR SLOOP::LOOP-POP SYSTEM::DM-TOO-FEW-ARGUMENTS SYSTEM::INSPECT-READ-LINE SYSTEM::GET-SIG-FN-NAME SLOOP::LOOP-PEEK COMMON-LISP::TYPE-ERROR SYSTEM::SET-UP-TOP-LEVEL ANSI-LOOP::LOOP-DO-REPEAT ANSI-LOOP::LOOP-GET-PROGN SYSTEM::GET-TEMP-DIR SLOOP::PARSE-LOOP1 SYSTEM::SHOW-RESTARTS SYSTEM::KCL-TOP-RESTARTS COMMON-LISP::LISP-IMPLEMENTATION-VERSION SYSTEM::SET-ENV SLOOP::PARSE-ONE-WHEN-CLAUSE SYSTEM::GET-INDEX-NODE ANSI-LOOP::LOOP-DO-INITIALLY SYSTEM::INSPECT-INDENT ANSI-LOOP::LOOP-BIND-BLOCK ANSI-LOOP::LOOP-WHEN-IT-VARIABLE SYSTEM::INIT-BREAK-POINTS SYSTEM::DEFAULT-INFO-HOTLIST SYSTEM::ILLEGAL-BOA ANSI-LOOP::LOOP-DO-FINALLY ANSI-LOOP::LOOP-GET-FORM SYSTEM::CURRENT-DIRECTORY-PATHNAME ANSI-LOOP::LOOP-ITERATION-DRIVER ANSI-LOOP::LOOP-DO-WITH SLOOP::PARSE-LOOP-FOR SLOOP::LOOP-UN-POP ANSI-LOOP::LOOP-CONTEXT SYSTEM::DBL ANSI-LOOP::LOOP-DO-DO SYSTEM::CLEANUP SYSTEM::DEFAULT-SYSTEM-BANNER SYSTEM::STEP-READ-LINE SYSTEM::ALL-TRACE-DECLARATIONS SLOOP::PARSE-LOOP-DO SYSTEM::SET-CURRENT SYSTEM::DM-TOO-MANY-ARGUMENTS ANSI-LOOP::LOOP-DO-NAMED ANSI-LOOP::LOOP-POP-SOURCE SYSTEM::SETUP-LINEINFO SYSTEM::TOP-LEVEL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMMON-LISP::LOGORC2 COMMON-LISP::WITH-PACKAGE-ITERATOR ANSI-LOOP::LOOP-DO-WHILE SLOOP::THEREIS-SLOOP-COLLECT SYSTEM::ADD-FILE SLOOP::IN-CAREFULLY-SLOOP-FOR SLOOP::IN-PACKAGE-SLOOP-MAP SYSTEM::MV-SETQ SYSTEM::IF-ERROR SYSTEM::WITHOUT-INTERRUPTS SYSTEM::DM-NTH COMMON-LISP::CASE ANSI-LOOP::LOOP-ACCUMULATE-MINIMAX-VALUE COMMON-LISP::DEFINE-MODIFY-MACRO SLOOP::COUNT-SLOOP-COLLECT SYSTEM::GET-MATCH COMMON-LISP::SHIFTF SYSTEM::*BREAK-POINTS* COMMON-LISP::RETURN COMMON-LISP::LDB COMMON-LISP::WITH-SIMPLE-RESTART COMMON-LISP::LOGORC1 COMMON-LISP::MULTIPLE-VALUE-BIND FPE::RF COMMON-LISP::WITH-STANDARD-IO-SYNTAX SLOOP::MINIMIZE-SLOOP-COLLECT SYSTEM::DEFINE-SETF-METHOD COMMON-LISP::ECASE COMMON-LISP::DOTIMES SLOOP::DEF-LOOP-COLLECT COMMON-LISP::PROG1 ANSI-LOOP::LOOP-LOOKUP-KEYWORD SYSTEM::SET-BACK COMMON-LISP::LDB-TEST SYSTEM::OBJLT SLOOP::NEVER-SLOOP-COLLECT COMMON-LISP::VECTOR-PUSH SYSTEM::DBL-UP COMMON-LISP::ASSERT SYSTEM::MSUB ANSI-LOOP::LOOP-BODY SYSTEM::COERCE-TO-STRING SYSTEM::GET-INFO-CHOICES SLOOP::IN-FRINGE-SLOOP-MAP COMMON-LISP::PSETF SYSTEM::ALL-MATCHES COMMON-LISP::DO ANSI-LOOP::MAKE-LOOP-MINIMAX SYSTEM::PARSE-SLOT-DESCRIPTION SYSTEM::SET-PATH-STREAM-NAME COMMON-LISP::LOOP-FINISH COMMON-LISP::NTHCDR COMMON-LISP::DO-ALL-SYMBOLS SYSTEM::SGEN SYSTEM::PUT-AUX COMMON-LISP::CCASE SYSTEM::DM-V COMMON-LISP::LOCALLY SLOOP::ALWAYS-SLOOP-COLLECT COMMON-LISP::LAMBDA COMMON-LISP::DEFMACRO ANSI-LOOP::LOOP-TMEMBER COMMON-LISP::WITH-OPEN-STREAM SLOOP::MAXIMIZE-SLOOP-COLLECT SLOOP::DESETQ1 COMMON-LISP::TRACE SYSTEM::CHECK-SEQ-START-END COMMON-LISP::DEFTYPE SLOOP::MAKE-VALUE COMMON-LISP::TYPECASE ANSI-LOOP::LOOP-TEQUAL ANSI-LOOP::LOOP-DO-ALWAYS ANSI-LOOP::WITH-LOOP-LIST-COLLECTION-HEAD SYSTEM::INFO-AUX COMMON-LISP::WITH-OPEN-FILE COMMON-LISP::PROG2 COMMON-LISP::DEFSTRUCT SLOOP::DESETQ SYSTEM::QUOTATION-READER SYSTEM::DM-NTH-CDR SYSTEM::MATCH-DIMENSIONS COMMON-LISP::BYTE FPE::READ-OPERANDS COMMON-LISP::TIME COMMON-LISP::COND COMMON-LISP::DO-EXTERNAL-SYMBOLS COMMON-LISP::WITH-HASH-TABLE-ITERATOR COMMON-LISP::MULTIPLE-VALUE-SETQ COMMON-LISP::DEFCONSTANT ANSI-LOOP::LOOP-DECLARE-VARIABLE COMMON-LISP::LOGNOR ANSI-LOOP::LOOP-COLLECT-ANSWER COMMON-LISP::DEFVAR SYSTEM::SETF-LOGICAL-PATHNAME-TRANSLATIONS SYSTEM::LOOKUP-KEYWORD SYSTEM::SEQUENCE-CURSOR SLOOP::LOGXOR-SLOOP-COLLECT FPE::%-READER SLOOP::DEF-LOOP-FOR COMMON-LISP::PSETQ SLOOP::COLLATE-SLOOP-COLLECT SLOOP::PARSE-LOOP-MAP COMMON-LISP::NTH SYSTEM::SUBSTRINGP SYSTEM::GET-NODES SYSTEM::COERCE-TO-PACKAGE COMMON-LISP::PATHNAME-MATCH-P ANSI-LOOP::HIDE-VARIABLE-REFERENCES SYSTEM::OVERWRITE-SLOT-DESCRIPTIONS ANSI-LOOP::LOOP-DO-IF SYSTEM::INSPECT-PRINT SYSTEM::DOT-DIR-P SYSTEM::SETF-HELPER COMMON-LISP::ROTATEF COMMON-LISP::FILE-STRING-LENGTH COMMON-LISP::POP COMMON-LISP::DO-SYMBOLS ANSI-LOOP::LOOP-MAYBE-BIND-FORM COMMON-LISP::WITH-INPUT-FROM-STRING COMMON-LISP::PROG SLOOP::=-SLOOP-FOR ANSI-LOOP::LOOP-COLLECT-RPLACD COMMON-LISP::DOLIST SYSTEM::SET-DIR COMMON-LISP::WHEN FPE::READ-INSTRUCTION SYSTEM::ITERATE-OVER-BKPTS COMMON-LISP::OR COMMON-LISP::DEFPACKAGE COMMON-LISP::UNTRACE COMMON-LISP::ETYPECASE COMMON-LISP::DO* COMMON-LISP::LOGTEST SYSTEM::IN-INTERVAL-P SYSTEM::LEFT-PARENTHESIS-READER SLOOP::DEF-LOOP-MACRO SLOOP::SLOOP SLOOP::L-EQUAL SYSTEM::BREAK-STEP-NEXT COMMON-LISP::COERCE SYSTEM::GPROF-OUTPUT SLOOP::SUM-SLOOP-COLLECT COMMON-LISP::REMF ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION SLOOP::LOCAL-FINISH COMMON-LISP::CHECK-TYPE ANSI-LOOP::LOOP-COPYLIST* COMMON-LISP::WITH-OUTPUT-TO-STRING SYSTEM::CONDITION-PASS SLOOP::DEF-LOOP-MAP COMMON-LISP::DOCUMENTATION COMMON-LISP::DECF COMMON-LISP::WRITE-BYTE COMMON-LISP::WITH-CONDITION-RESTARTS SYSTEM::INSPECT-RECURSIVELY COMMON-LISP::PUSH COMMON-LISP::MULTIPLE-VALUE-LIST ANSI-LOOP::LOOP-STORE-TABLE-DATA SYSTEM::DISPLAY-ENV SYSTEM::LIST-DELQ COMPILER::COMPILER-DEF-HOOK SLOOP::LOOP-RETURN COMMON-LISP::PROG* SYSTEM::TP-ERROR SYSTEM::LIST-TOGGLE-CASE COMMON-LISP::DECLAIM SYSTEM::SAFE-EVAL COMMON-LISP::DEFSETF COMMON-LISP::LOGANDC1 SYSTEM::SUPER-GO COMMON-LISP::LOGNAND SYSTEM::WHILE SYSTEM::DISPLAY-COMPILED-ENV COMMON-LISP::AND COMMON-LISP::PUSHNEW SYSTEM::INCREMENT-CURSOR COMMON-LISP::INCF COMMON-LISP::NTH-VALUE FPE::0-READER COMMON-LISP::DEFPARAMETER SYSTEM::?PUSH SYSTEM::NODE FPE::PAREN-READER SLOOP::THE-TYPE COMMON-LISP::UNLESS ANSI-LOOP::LOOP-TASSOC COMMON-LISP::LOOP SYSTEM::GET-LINE-OF-FORM SLOOP::IN-TABLE-SLOOP-MAP COMMON-LISP::RESTART-BIND SYSTEM::CHECK-TYPE-EVAL COMMON-LISP::LOGANDC2 COMMON-LISP::STEP SYSTEM::KEYWORD-SUPPLIED-P SLOOP::SLOOP-FINISH SLOOP::LCASE ANSI-LOOP::WITH-MINIMAX-VALUE COMMON-LISP::DEFUN COMMON-LISP::CTYPECASE COMMON-LISP::RESTART-CASE SYSTEM::BREAK-STEP-INTO SLOOP::SLOOP-SWAP COMMON-LISP::DESTRUCTURING-BIND SYSTEM::SUB-INTERVAL-P SYSTEM::MV-VALUES COMMON-LISP::WITH-COMPILATION-UNIT SYSTEM::SETF-EXPAND)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) COMMON-LISP::FCEILING COMMON-LISP::WRITE-TO-STRING COMMON-LISP::USE-VALUE COMMON-LISP::INVOKE-RESTART COMMON-LISP::FROUND COMMON-LISP::ENSURE-DIRECTORIES-EXIST COMMON-LISP::DECODE-UNIVERSAL-TIME SYSTEM::SHOW-INFO SYSTEM::GET-SETF-METHOD-MULTIPLE-VALUE COMMON-LISP::STORE-VALUE COMMON-LISP::PARSE-NAMESTRING SYSTEM::BREAK-FUNCTION SYSTEM::INFO COMMON-LISP::APROPOS COMMON-LISP::APROPOS-LIST ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE COMMON-LISP::READ-FROM-STRING COMMON-LISP::FFLOOR SYSTEM::STEPPER COMMON-LISP::FTRUNCATE COMMON-LISP::GET-SETF-EXPANSION SYSTEM::APROPOS-DOC SYSTEM::PRINT-DOC)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER COMMON-LISP::*) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::FIXNUM) SYSTEM::ATOI)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::FIXNUM) SYSTEM::RELATIVE-LINE ANSI-LOOP::DUPLICATABLE-CODE-P SYSTEM::FASLINK SYSTEM::LENEL SYSTEM::THE-END SYSTEM::GET-NODE-INDEX)) (COMMON-LISP::MAPC (COMMON-LISP::LAMBDA (COMPILER::X) (COMMON-LISP::SETF (COMMON-LISP::GET COMPILER::X 'COMPILER::PROCLAIMED-CLOSURE) COMMON-LISP::T)) '(SYSTEM::CONDITIONP SYSTEM::TRACE-ONE SYSTEM::SI-FIND-CLASS SYSTEM::SI-CLASS-OF SYSTEM::CONDITION-CLASS-P FPE::BREAK-ON-FLOATING-POINT-EXCEPTIONS SYSTEM::SI-CLASS-PRECEDENCE-LIST SYSTEM::AUTOLOAD SYSTEM::UNTRACE-ONE SYSTEM::MAKE-ACCESS-FUNCTION SYSTEM::SI-CLASSP SYSTEM::AUTOLOAD-MACRO SYSTEM::WARNINGP SYSTEM::SI-CLASS-NAME SYSTEM::SIMPLE-CONDITION-CLASS-P SYSTEM::RECORD-FN SYSTEM::DEFINE-STRUCTURE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) SLOOP::FIND-IN-ORDERED-LIST COMMON-LISP::STABLE-SORT COMMON-LISP::SUBTYPEP SYSTEM::PARSE-BODY COMMON-LISP::REDUCE COMMON-LISP::SORT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) COMMON-LISP::SUBST-IF COMMON-LISP::SUBST-IF-NOT COMMON-LISP::SUBST SYSTEM::MASET)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) SYSTEM::PARSE-DEFMACRO-LAMBDA-LIST SYSTEM::PARSE-DEFMACRO)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) SYSTEM::SHARP---READER SYSTEM::LIST-MERGE-SORT SYSTEM::RESTART-PRINT ANSI-LOOP::LOOP-GET-COLLECTION-INFO SYSTEM::VERIFY-KEYWORDS SYSTEM::SHARP-+-READER SYSTEM::READ-INSPECT-COMMAND SYSTEM::SHARP-S-READER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) SYSTEM::TRACE-CALL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) SYSTEM::PUSH-OPTIONAL-BINDING)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::VECTOR COMMON-LISP::CHARACTER COMMON-LISP::*)) COMMON-LISP::T) SYSTEM::RESET-SYS-PATHS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::VECTOR COMMON-LISP::T)) SYSTEM::CONTEXT-VEC)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMMON-LISP::MAKE-STRING-INPUT-STREAM SYSTEM::FILE-TO-STRING SYSTEM::LINK-EXPAND COMMON-LISP::UPGRADED-ARRAY-ELEMENT-TYPE COMMON-LISP::DELETE-DUPLICATES COMMON-LISP::PATHNAME-HOST COMMON-LISP::ARRAY-ROW-MAJOR-INDEX SYSTEM::BAD-SEQ-LIMIT SYSTEM::LOGICAL-PATHNAME-PARSE COMMON-LISP::OPEN SYSTEM::BREAK-LEVEL COMMON-LISP::DIRECTORY SLOOP::LOOP-ADD-TEMPS SYSTEM::DIR-PARSE COMMON-LISP::TRANSLATE-LOGICAL-PATHNAME SYSTEM::MGSUB COMMON-LISP::MERGE-PATHNAMES SYSTEM::MGLIST SYSTEM::FILE-SEARCH SYSTEM::PROCESS-SOME-ARGS COMMON-LISP::ARRAY-IN-BOUNDS-P COMMON-LISP::SBIT COMMON-LISP::FILE-POSITION COMMON-LISP::PATHNAME-VERSION COMMON-LISP::PATHNAME-DIRECTORY COMMON-LISP::PATHNAME-DEVICE SYSTEM::NLOAD COMMON-LISP::WARN COMMON-LISP::ENOUGH-NAMESTRING SYSTEM::NTH-STACK-FRAME ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES COMMON-LISP::BIT COMMON-LISP::WILD-PATHNAME-P COMMON-LISP::READ-BYTE COMMON-LISP::BIT-NOT COMMON-LISP::REQUIRE ANSI-LOOP::LOOP-ERROR ANSI-LOOP::LOOP-WARN COMMON-LISP::PATHNAME-NAME COMMON-LISP::MAKE-ARRAY COMMON-LISP::REMOVE-DUPLICATES SYSTEM::INFO-SEARCH SLOOP::ADD-FROM-DATA SYSTEM::TO-REGEXP COMMON-LISP::LOAD COMMON-LISP::SIGNAL COMMON-LISP::PATHNAME-TYPE COMMON-LISP::FIND-RESTART SYSTEM::LIST-MATCHES COMMON-LISP::CONCATENATE COMMON-LISP::ERROR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) SYSTEM::FIND-DOC COMMON-LISP::RENAME-FILE SYSTEM::DO-REPL SYSTEM::RESTART-REPORT ANSI-LOOP::ESTIMATE-CODE-SIZE ANSI-LOOP::LOOP-REALLY-DESETQ ANSI-LOOP::ESTIMATE-CODE-SIZE-1 SYSTEM::NEW-SEMI-COLON-READER SYSTEM::SOURCE-PORTION SYSTEM::NEWLINE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*) SYSTEM::BREAK-MESSAGE SYSTEM::GCL-TOP-LEVEL SYSTEM::SIMPLE-BACKTRACE SYSTEM::BREAK-RESUME ANSI-LOOP::LOOP-DO-FOR SYSTEM::BREAK-CURRENT SYSTEM::BREAK-HELP)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807) (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::FIXNUM) SYSTEM::ROUND-UP)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::FIXNUM) SYSTEM::DBL-WHAT-FRAME FPE::FE-ENABLE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::OR COMMON-LISP::NULL COMMON-LISP::HASH-TABLE)) SYSTEM::CONTEXT-HASH)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::HASH-TABLE) SYSTEM::CONTEXT-SPICE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION ((COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) SYSTEM::GET-CONTEXT SYSTEM::PUSH-CONTEXT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::EXPAND-RANGE SYSTEM::SETF-STRUCTURE-ACCESS SYSTEM::MME3 SYSTEM::FIND-LINE-IN-FUN SYSTEM::LOAD-PATHNAME SYSTEM::MINMAX SYSTEM::ELSUB SYSTEM::COERCE-TO-CONDITION SYSTEM::DO-BREAK-LEVEL ANSI-LOOP::LOOP-FOR-ARITHMETIC SLOOP::FIRST-USE-SLOOP-FOR SYSTEM::CALL-TEST SLOOP::FIRST-SLOOP-FOR SYSTEM::MAYBE-BREAK)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) SYSTEM::WALK-DIR SYSTEM::PUSH-LET-BINDING SYSTEM::MME2 ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH COMMON-LISP::SUBSTITUTE-IF-NOT ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH SYSTEM::MATCH-COMPONENT SYSTEM::COMPLETE-PROP COMMON-LISP::NSUBSTITUTE-IF-NOT COMMON-LISP::SUBSTITUTE-IF COMMON-LISP::NSUBSTITUTE ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH SYSTEM::CHECK-TYPE-SYMBOL COMMON-LISP::MAP COMMON-LISP::TRANSLATE-PATHNAME COMMON-LISP::SUBSTITUTE ANSI-LOOP::ADD-LOOP-PATH ANSI-LOOP::LOOP-MAKE-VARIABLE SLOOP::LOOP-DECLARE-BINDING COMMON-LISP::NSUBSTITUTE-IF)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::SHARP-V-READER COMMON-LISP::DEPOSIT-FIELD ANSI-LOOP::LOOP-FOR-ON SYSTEM::SETF-EXPAND-1 SYSTEM::SHARP-DQ-READER SYSTEM::CHECK-TRACE-ARGS SYSTEM::PROG?* SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS ANSI-LOOP::PRINT-LOOP-UNIVERSE ANSI-LOOP::LOOP-FOR-IN SYSTEM::CHECK-S-DATA SYSTEM::WARN-VERSION ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE SYSTEM::DEFMACRO* ANSI-LOOP::LOOP-SUM-COLLECTION SYSTEM::PATHNAME-PARSE SYSTEM::GET-SLOT-POS SYSTEM::MAKE-T-TYPE SYSTEM::SHARP-A-READER SYSTEM::RESTART-CASE-EXPRESSION-CONDITION SYSTEM::RECURSE-DIR SYSTEM::SHARP-U-READER SYSTEM::APPLY-DISPLAY-FUN SYSTEM::DM-VL ANSI-LOOP::HIDE-VARIABLE-REFERENCE SYSTEM::MAKE-BREAK-POINT SYSTEM::TO-REGEXP-OR-NAMESTRING ANSI-LOOP::LOOP-FOR-BEING SYSTEM::FLOATING-POINT-ERROR SYSTEM::SHARP-P-READER ANSI-LOOP::LOOP-TRANSLATE COMMON-LISP::DPB ANSI-LOOP::LOOP-FOR-ACROSS FPE::REF SYSTEM::WRITE-SYMTAB ANSI-LOOP::LOOP-STANDARD-EXPANSION ANSI-LOOP::LOOP-ANSI-FOR-EQUALS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::DO?* SYSTEM::MAKE-PREDICATE SYSTEM::MAKE-CONSTRUCTOR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMMON-LISP::NSET-DIFFERENCE COMMON-LISP::COUNT-IF COMMON-LISP::FIND-IF-NOT SYSTEM::INTERNAL-COUNT-IF COMMON-LISP::INTERSECTION COMMON-LISP::REMOVE-IF-NOT SYSTEM::VECTOR-PUSH-STRING COMMON-LISP::EVERY COMMON-LISP::POSITION COMMON-LISP::POSITION-IF-NOT SYSTEM::FIND-IHS SYSTEM::INTERNAL-COUNT COMMON-LISP::BIT-ANDC2 COMMON-LISP::DELETE-IF-NOT COMMON-LISP::BIT-ANDC1 COMMON-LISP::UNION COMMON-LISP::NSET-EXCLUSIVE-OR COMMON-LISP::BIT-XOR SYSTEM::WREADDIR COMMON-LISP::MISMATCH COMMON-LISP::FIND-IF COMMON-LISP::BIT-ORC1 COMMON-LISP::MAKE-SEQUENCE COMMON-LISP::REMOVE COMMON-LISP::COUNT COMMON-LISP::BIT-NOR COMMON-LISP::MAP-INTO COMMON-LISP::NOTEVERY SLOOP::PARSE-LOOP-MACRO COMMON-LISP::FIND COMMON-LISP::BIT-AND COMMON-LISP::CERROR ANSI-LOOP::LOOP-CHECK-DATA-TYPE COMMON-LISP::READ-SEQUENCE COMMON-LISP::BIT-ORC2 COMMON-LISP::FILL COMMON-LISP::SOME COMMON-LISP::NUNION SYSTEM::INTERNAL-COUNT-IF-NOT COMMON-LISP::VECTOR-PUSH-EXTEND COMMON-LISP::REPLACE SLOOP::LOOP-ADD-BINDING COMMON-LISP::NOTANY COMMON-LISP::SET-EXCLUSIVE-OR COMMON-LISP::ADJUST-ARRAY COMMON-LISP::SET-DIFFERENCE COMMON-LISP::BIT-NAND COMMON-LISP::DELETE COMMON-LISP::POSITION-IF COMMON-LISP::SUBSETP COMMON-LISP::DELETE-IF SYSTEM::BREAK-CALL COMMON-LISP::REMOVE-IF COMMON-LISP::WRITE-SEQUENCE COMMON-LISP::BIT-IOR SLOOP::IN-ARRAY-SLOOP-FOR COMMON-LISP::SEARCH COMMON-LISP::COUNT-IF-NOT COMMON-LISP::TYPEP COMMON-LISP::NINTERSECTION COMMON-LISP::BIT-EQV SYSTEM::PROCESS-ERROR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) SYSTEM::PRINT-STACK-FRAME COMMON-LISP::MERGE SYSTEM::EXPAND-WILD-DIRECTORY SLOOP::DEF-LOOP-INTERNAL SYSTEM::ELEMENT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) SYSTEM::SHARP-EQ-READER SYSTEM::SHARP-SHARP-READER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) COMMON-LISP::ENCODE-UNIVERSAL-TIME)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) SYSTEM::DO-ARG-COUNT-ERROR SYSTEM::PUSH-SUB-LIST-BINDING)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) ANSI-LOOP::LOOP-SEQUENCER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) SYSTEM::UNIVERSAL-ERROR-HANDLER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS SYSTEM::CHECK-DECLARATIONS COMMON-LISP::RESTART-NAME ANSI-LOOP::LOOP-COLLECTOR-P COMMON-LISP::LOGNOT ANSI-LOOP::LOOP-CONSTANTP COMMON-LISP::COMPILER-MACRO-FUNCTION SYSTEM::IDESCRIBE COMMON-LISP::FIRST ANSI-LOOP::LOOP-MAKE-DESETQ ANSI-LOOP::LOOP-COLLECTOR-DTYPE SYSTEM::S-DATA-CONC-NAME SYSTEM::VERSION-PARSE SYSTEM::IHS-NOT-INTERPRETED-ENV SYSTEM::EXPAND-HOME-DIR SYSTEM::LOAD-PATHNAME-EXISTS ANSI-LOOP::LOOP-UNIVERSE-P SYSTEM::SIMPLE-ARRAY-P COMMON-LISP::FIFTH SYSTEM::BKPT-FILE-LINE SYSTEM::TRACE-ONE-PREPROCESS SYSTEM::CANONICALIZE-PATHNAME-DIRECTORY COMMON-LISP::PROBE-FILE COMMON-LISP::TRUENAME COMMON-LISP::CONCATENATED-STREAM-STREAMS SYSTEM::SHOW-ENVIRONMENT COMMON-LISP::NINTH SYSTEM::INSPECT-NUMBER SYSTEM::DBL-RPL-LOOP COMMON-LISP::PROVIDE SYSTEM::SETUP-INFO SLOOP::AVERAGING-SLOOP-MACRO COMMON-LISP::ACOS SYSTEM::LNP SYSTEM::COERCE-SLASH-TERMINATED SYSTEM::FIND-KCL-TOP-RESTART ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS SYSTEM::S-DATA-OFFSET COMMON-LISP::SECOND COMMON-LISP::PHASE SYSTEM::EVAL-FEATURE ANSI-LOOP::LOOP-PATH-USER-DATA ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE SYSTEM::PATCH-SHARP ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS COMMON-LISP::COMPILE-FILE-PATHNAME SYSTEM::DIR-P SYSTEM::PATH-STREAM-NAME COMMON-LISP::CIS SYSTEM::S-DATA-RAW SYSTEM::S-DATA-SLOT-DESCRIPTIONS SYSTEM::RESTART-TEST-FUNCTION SYSTEM::KNOWN-TYPE-P ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED COMMON-LISP::FILE-WRITE-DATE COMMON-LISP::RATIONAL ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS SYSTEM::GET-NEXT-VISIBLE-FUN SLOOP::PARSE-LOOP-INITIALLY SYSTEM::S-DATA-STATICP COMMON-LISP::BYTE-SIZE COMMON-LISP::VECTOR-POP COMMON-LISP::PATHNAME SYSTEM::DIRECTORY-LIST-CHECK COMMON-LISP::BROADCAST-STREAM-STREAMS COMMON-LISP::SYNONYM-STREAM-SYMBOL SYSTEM::PNL1 COMMON-LISP::SEVENTH SYSTEM::INFO-GET-TAGS ANSI-LOOP::LOOP-TYPED-INIT SYSTEM::WALK-THROUGH SYSTEM::NUMBER-OF-DAYS-FROM-1900 ANSI-LOOP::LOOP-EMIT-FINAL-VALUE COMMON-LISP::ASINH SYSTEM::S-DATA-FROZEN SYSTEM::GET-STRING-INPUT-STREAM-INDEX SYSTEM::INSTREAM-STREAM SLOOP::LOOP-LET-BINDINGS COMMON-LISP::ECHO-STREAM-OUTPUT-STREAM ANSI-LOOP::LOOP-COLLECTOR-CLASS COMMON-LISP::DELETE-FILE SYSTEM::GET-PATH SYSTEM::LEAP-YEAR-P SYSTEM::REGEXP-CONV COMMON-LISP::SIXTH COMMON-LISP::ATANH SYSTEM::INFO-GET-FILE SYSTEM::S-DATA-PRINT-FUNCTION COMMON-LISP::DIRECTORY-NAMESTRING SYSTEM::INSPECT-CHARACTER SYSTEM::S-DATA-CONSTRUCTORS ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE SYSTEM::INSPECT-VECTOR ANSI-LOOP::LOOP-MINIMAX-TYPE SYSTEM::BKPT-FILE SLOOP::REPEAT-SLOOP-MACRO COMMON-LISP::ABS COMMON-LISP::LOAD-LOGICAL-PATHNAME-TRANSLATIONS COMMON-LISP::SINH COMMON-LISP::TANH SYSTEM::RESTART-FUNCTION SLOOP::POINTER-FOR-COLLECT COMMON-LISP::ECHO-STREAM-INPUT-STREAM SYSTEM::PRINT-SYMBOL-APROPOS SYSTEM::CHDIR SYSTEM::MLP ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE FPE::GREF COMMON-LISP::BYTE-POSITION SYSTEM::INSTREAM-STREAM-NAME SYSTEM::BKPT-FUNCTION ANSI-LOOP::DESTRUCTURING-SIZE SYSTEM::NORMALIZE-TYPE ANSI-LOOP::LOOP-EMIT-BODY SYSTEM::SEARCH-STACK SYSTEM::INSERT-BREAK-POINT SYSTEM::S-DATA-INCLUDES COMMON-LISP::FOURTH COMMON-LISP::TWO-WAY-STREAM-OUTPUT-STREAM FPE::ST-LOOKUP SYSTEM::NODE-OFFSET SYSTEM::S-DATA-TYPE SYSTEM::INSPECT-SYMBOL SLOOP::TRANSLATE-NAME SYSTEM::S-DATA-NAMED SYSTEM::REAL-ASINH SYSTEM::TOGGLE-CASE SLOOP::SLOOP-SLOOP-MACRO ANSI-LOOP::LOOP-DO-THEREIS FPE::LOOKUP SYSTEM::S-DATA-NAME ANSI-LOOP::LOOP-COLLECTOR-DATA SYSTEM::BREAK-FORWARD-SEARCH-STACK COMMON-LISP::EIGHTH ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE SYSTEM::S-DATA-SLOT-POSITION SYSTEM::INFO-NODE-FROM-POSITION COMMON-LISP::THIRD SYSTEM::FRS-KIND SYSTEM::WILD-PATH-ELEMENT-P ANSI-LOOP::LOOP-MAXMIN-COLLECTION SYSTEM::PRINT-FRS SYSTEM::GET-INSTREAM SLOOP::SUBSTITUTE-SLOOP-BODY SYSTEM::RESTART-P COMMON-LISP::FILE-AUTHOR SYSTEM::ADD-TO-HOTLIST SYSTEM::COMPUTING-ARGS-P COMMON-LISP::FILE-NAMESTRING SYSTEM::ENSURE-DIR-STRING COMMON-LISP::FIND-ALL-SYMBOLS SYSTEM::S-DATA-P SYSTEM::BREAK-BACKWARD-SEARCH-STACK SYSTEM::GET-BYTE-STREAM-NCHARS ANSI-LOOP::LOOP-MAKE-PSETQ SYSTEM::ALOAD ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA SYSTEM::MAKE-DEFPACKAGE-FORM COMMON-LISP::ASIN SYSTEM::WILD-DIR-ELEMENT-P SYSTEM::MAKE-FRAME ANSI-LOOP::LOOP-PSEUDO-BODY SYSTEM::DIR-CONJ SYSTEM::DBL-EVAL ANSI-LOOP::LOOP-COLLECTOR-NAME SYSTEM::INSPECT-ARRAY SYSTEM::DM-KEY-NOT-ALLOWED COMMON-LISP::ARRAY-DIMENSIONS ANSI-LOOP::LOOP-CONSTRUCT-RETURN COMMON-LISP::LOGICAL-PATHNAME COMMON-LISP::ACOSH ANSI-LOOP::LOOP-PATH-NAMES ANSI-LOOP::LOOP-PATH-FUNCTION SYSTEM::CHECK-TRACE-SPEC COMMON-LISP::ISQRT SYSTEM::NODES-FROM-INDEX SYSTEM::PRINT-IHS SYSTEM::INSPECT-CONS COMMON-LISP::CONSTANTLY ANSI-LOOP::LOOP-PATH-P SYSTEM::WILD-NAMESTRING-P SYSTEM::DM-BAD-KEY ANSI-LOOP::LOOP-MINIMAX-P SYSTEM::SEQTYPE FPE::XMM-LOOKUP SYSTEM::LOGICAL-PATHNAME-HOST-P COMMON-LISP::INVOKE-DEBUGGER ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS SYSTEM::INSPECT-STRING SYSTEM::NEXT-STACK-FRAME ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS SYSTEM::LOGICAL-PATHNAMEP ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED SLOOP::LOOP-COLLECT-KEYWORD-P COMMON-LISP::SIGNUM SYSTEM::WHICH ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD SYSTEM::SHORT-NAME SYSTEM::SHOW-BREAK-POINT SYSTEM::INSPECT-STRUCTURE SYSTEM::S-DATA-INCLUDED SYSTEM::INSTREAM-P SYSTEM::RE-QUOTE-STRING SYSTEM::RESTRICT-STREAM-ELEMENT-TYPE SYSTEM::RESTART-INTERACTIVE-FUNCTION ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS SYSTEM::UNIQUE-ID SYSTEM::FIX-LOAD-PATH SLOOP::RETURN-SLOOP-MACRO ANSI-LOOP::LOOP-COLLECTOR-HISTORY SYSTEM::S-DATA-DOCUMENTATION SYSTEM::TERMINAL-INTERRUPT COMMON-LISP::TENTH COMMON-LISP::COMPLEMENT SYSTEM::BEST-ARRAY-ELEMENT-TYPE SYSTEM::IHS-VISIBLE SYSTEM::LOGICAL-PATHNAME-DESIGNATOR-P COMMON-LISP::COSH COMMON-LISP::LOGICAL-PATHNAME-TRANSLATIONS SYSTEM::BKPT-FORM SYSTEM::FREEZE-DEFSTRUCT SYSTEM::INSPECT-PACKAGE ANSI-LOOP::LOOP-UNIVERSE-ANSI SLOOP::PARSE-NO-BODY ANSI-LOOP::LOOP-MINIMAX-OPERATIONS ANSI-LOOP::LOOP-LIST-COLLECTION SYSTEM::NC SYSTEM::FIND-DOCUMENTATION SYSTEM::S-DATA-HAS-HOLES COMMON-LISP::TWO-WAY-STREAM-INPUT-STREAM COMMON-LISP::NAMESTRING COMMON-LISP::HOST-NAMESTRING SYSTEM::DWIM SYSTEM::MAKE-KCL-TOP-RESTART SLOOP::PARSE-LOOP SYSTEM::IHS-FNAME COMMON-LISP::STREAM-EXTERNAL-FORMAT SYSTEM::RESTART-REPORT-FUNCTION COMMON-LISP::FILE-LENGTH SYSTEM::PROCESS-ARGS ANSI-LOOP::LOOP-HACK-ITERATION SYSTEM::CONTEXT-P SYSTEM::RESET-TRACE-DECLARATIONS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) SYSTEM::BREAK-LOCAL SYSTEM::BREAK-VS ANSI-LOOP::LOOP-OPTIONAL-TYPE COMMON-LISP::CONTINUE SYSTEM::BREAK-QUIT SYSTEM::BREAK-PREVIOUS SYSTEM::DBL-BACKTRACE SYSTEM::INFO-ERROR COMMON-LISP::MUFFLE-WARNING SYSTEM::SHOW-BREAK-VARIABLES SYSTEM::BREAK-BDS SYSTEM::IHS-BACKTRACE SYSTEM::BREAK-NEXT)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T)) SYSTEM::MAKE-KEYWORD)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM) SYSTEM::THE-START FPE::REG-LOOKUP SYSTEM::INSTREAM-LINE SYSTEM::S-DATA-LENGTH SYSTEM::S-DATA-SIZE)) gcl-2.6.14/lsp/gcl_numlib.lsp0000755000175000017500000002133714360276512014435 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; numlib.lsp ;;;; ;;;; number routines (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defconstant imag-one #C(0.0d0 1.0d0)) (defun isqrt (i) (unless (and (integerp i) (>= i 0)) (error "~S is not a non-negative integer." i)) (if (zerop i) 0 (let ((n (integer-length i))) (do ((x (ash 1 (ceiling n 2))) (y)) (nil) (setq y (floor i x)) (when (<= x y) (return x)) (setq x (floor (+ x y) 2)))))) (defun abs (z) (cond ((complexp z) ;; Compute (sqrt (+ (* x x) (* y y))) carefully to prevent ;; overflow! (let* ((x (abs (realpart z))) (y (abs (imagpart z)))) (if (< x y) (rotatef x y)) (if (zerop x) x (let ((r (/ y x))) (* x (sqrt (+ 1 (* r r)))))))) (t ; Should this be (realp z) instead of t? (if (minusp z) (- z) z)))) (defun phase (x) (atan (imagpart x) (realpart x))) (defun signum (x) (if (zerop x) x (/ x (abs x)))) (defun cis (x) (exp (* imag-one x))) (defun real-asinh (x) (declare (real x)) (float (log (+ x (sqrt (+ 1.0 (* x x))))) (float x))) (defun asin (z) (declare (optimize (safety 1))) (check-type z number) (if (unless (complexp z) (<= -1 z 1)) (atan z (sqrt (- 1 (* z z)))) (let* ((a (sqrt (- 1 z))) (b (sqrt (+ 1 z)))) (complex (atan (realpart z) (realpart (* a b))) (real-asinh (imagpart (* (conjugate a) b))))))) (defun acos (z) (declare (optimize (safety 1))) (check-type z number) (if (unless (complexp z) (<= -1 z 1)) (* 2 (atan (- 1 z) (sqrt (- 1 (* z z))))) (let* ((a (sqrt (- 1 z))) (b (sqrt (+ 1 z)))) (complex (* 2 (atan (realpart a) (realpart b))) (real-asinh (imagpart (* (conjugate b) a))))))) (defun asinh (x) (declare (optimize (safety 1))) (check-type x number) (if (realp x) (real-asinh x) (let* ((r (asin (complex (- (imagpart x)) (realpart x))))) (complex (imagpart r) (- (realpart r)))))) (defun acosh (z) (declare (optimize (safety 1))) (check-type z number) (if (unless (complexp z) (>= z 1)) (real-asinh (sqrt (- (* z z) 1))) (let* ((a (sqrt (- z 1))) (b (sqrt (+ z 1)))) (complex (real-asinh (realpart (* (conjugate a) b))) (* 2 (atan (imagpart a) (realpart b))))))) (defun atanh (x) (declare (optimize (safety 1))) (check-type x number) (if (unless (complexp x) (< -1 x 1)) (/ (log (/ (+ 1 x) (- 1 x))) 2) (/ (- (log (+ 1 x)) (log (- 1 x))) 2))) (defun sinh (z) (cond ((complexp z) ;; For complex Z, compute the real and imaginary parts ;; separately to get better precision. (let ((x (realpart z)) (y (imagpart z))) (complex (* (sinh x) (cos y)) (* (cosh x) (sin y))))) (t ; Should this be (realp z) instead of t? (let ((limit #.(expt (* double-float-epsilon 45/2) 1/5))) (if (< (- limit) z limit) ;; For this region, write use the fact that sinh z = ;; z*exp(z)*[(1 - exp(-2z))/(2z)]. Then use the first ;; 4 terms in the Taylor series expansion of ;; (1-exp(-2z))/2/z. series expansion of (1 - ;; exp(2*x)). This is needed because there is severe ;; roundoff error calculating (1 - exp(-2z)) for z near ;; 0. (* z (exp z) (- 1 (* z (- 1 (* z (- 2/3 (* z (- 1/3 (* 2/15 z))))))))) (let ((e (exp z))) (* 1/2 (- e (/ e))))))))) ;(defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0d0)) (defun cosh (z) (cond ((complexp z) ;; For complex Z, compute the real and imaginary parts ;; separately to get better precision. (let ((x (realpart z)) (y (imagpart z))) (complex (* (cosh x) (cos y)) (* (sinh x) (sin y))))) (t ; Should this be (realp z) instead of t? ;; For real Z, there's no chance of round-off error, so ;; direct evaluation is ok. (let ((e (exp z))) (* 1/2 (+ e (/ e))))))) ;(defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0d0)) (defun tanh (x) (/ (sinh x) (cosh x))) (defun rational (x) (etypecase x (float (multiple-value-bind (i e s) (integer-decode-float x) (if (>= s 0) (* i (expt (float-radix x) e)) (- (* i (expt (float-radix x) e)))))) (rational x))) (setf (symbol-function 'rationalize) (symbol-function 'rational)) ;; although the following is correct code in that it approximates the ;; x to within eps, it does not preserve (eql (float (rationalize x) x) x) ;; since the test for eql is more strict than the float-epsilon ;;; Rationalize originally by Skef Wholey. ;;; Obtained from Daniel L. Weinreb. ;(defun rationalize (x) ; (typecase x ; (rational x) ; (short-float (rationalize-float x short-float-epsilon 1.0s0)) ; (long-float (rationalize-float x long-float-epsilon 1.0d0)) ; (otherwise (error "~S is neither rational nor float." x)))) ; ;(defun rationalize-float (x eps one) ; (cond ((minusp x) (- (rationalize (- x)))) ; ((zerop x) 0) ; (t (let ((y ()) ; (a ())) ; (do ((xx x (setq y (/ one ; (- xx (float a x))))) ; (num (setq a (truncate x)) ; (+ (* (setq a (truncate y)) num) onum)) ; (den 1 (+ (* a den) oden)) ; (onum 1 num) ; (oden 0 den)) ; ((and (not (zerop den)) ; (not (> (abs (/ (- x (/ (float num x) ; (float den x))) ; x)) ; eps))) ; (/ num den))))))) (defun ffloor (x &optional (y 1.0s0)) (multiple-value-bind (i r) (floor (float x) (float y)) (values (float i r) r))) (defun fceiling (x &optional (y 1.0s0)) (multiple-value-bind (i r) (ceiling (float x) (float y)) (values (float i r) r))) (defun ftruncate (x &optional (y 1.0s0)) (multiple-value-bind (i r) (truncate (float x) (float y)) (values (float i r) r))) (defun fround (x &optional (y 1.0s0)) (multiple-value-bind (i r) (round (float x) (float y)) (values (float i r) r))) (defun lognand (x y) (boole boole-nand x y)) (defun lognor (x y) (boole boole-nor x y)) (defun logandc1 (x y) (boole boole-andc1 x y)) (defun logandc2 (x y) (boole boole-andc2 x y)) (defun logorc1 (x y) (boole boole-orc1 x y)) (defun logorc2 (x y) (boole boole-orc2 x y)) (defun lognot (x) (logxor -1 x)) (defun logtest (x y) (not (zerop (logand x y)))) (defun byte (size position) (cons size position)) (defun byte-size (bytespec) (car bytespec)) (defun byte-position (bytespec) (cdr bytespec)) ;; (defun ldb (bytespec integer) ;; (logandc2 (ash integer (- (byte-position bytespec))) ;; (- (ash 1 (byte-size bytespec))))) ;; (defun ldb-test (bytespec integer) ;; (not (zerop (ldb bytespec integer)))) ;; (defun mask-field (bytespec integer) ;; (ash (ldb bytespec integer) (byte-position bytespec))) ;; (defun dpb (newbyte bytespec integer) ;; (logxor integer ;; (mask-field bytespec integer) ;; (ash (logandc2 newbyte ;; (- (ash 1 (byte-size bytespec)))) ;; (byte-position bytespec)))) ;; (defun deposit-field (newbyte bytespec integer) ;; (dpb (ash newbyte (- (byte-position bytespec))) bytespec integer)) (defun ldb (bytespec integer) (logand (ash integer (- (byte-position bytespec))) (1- (ash 1 (byte-size bytespec))))) (defun ldb-test (bytespec integer) (not (zerop (ldb bytespec integer)))) (defun dpb (newbyte bytespec integer &aux (z (1- (ash 1 (byte-size bytespec))))) (logior (logandc2 integer (ash z (byte-position bytespec))) (ash (logand newbyte z) (byte-position bytespec)))) (defun deposit-field (newbyte bytespec integer &aux (z (ash (1- (ash 1 (byte-size bytespec))) (byte-position bytespec)))) (logior (logandc2 integer z) (logand newbyte z))) gcl-2.6.14/lsp/gcl_profile.lsp0000755000175000017500000000720414360276512014604 0ustar cammcamm (in-package :si) (use-package "SLOOP") ;; Sample Usage: ;; (si::set-up-profile 1000000) (si::prof 0 90) ;; run program ;; (si::display-prof) ;; (si::clear-profile) ;; profile can be stopped with (si::prof 0 0) and restarted with ;;start-address will correspond to the beginning of the profile array, and ;;the scale will mean that 256 bytes of code correspond to scale bytes in the ;;profile array. ;;Thus if the profile array is 1,000,000 bytes long and the code segment is ;;5 megabytes long you can profile the whole thing using a scale of 50 ;;Note that long runs may result in overflow, and so an understating of the ;;time in a function. With a scale of 128 it takes 6,000,000 times through ;;a loop to overflow the sampling in one part of the code. ;(defun sort-funs (package) ; (sloop for v in-package package with tem ; when (and (fboundp v) (compiled-function-p ; (setq tem (symbol-function v)))) ; collect (cons (function-start v) v) into all ; finally (loop-return (sort all #'(lambda (x y) ; (< (the fixnum (car x)) ; (the fixnum (car y)))))))) (defvar si::*profile-array* (make-array 20000 :element-type 'string-char :static t :initial-element (code-char 0))) (defun create-profile-array (&optional (n 100000)) (if *profile-array* (profile 0 0)) (setq *profile-array* (make-array n :element-type 'string-char :static t :initial-element (code-char 0))) n ) (defvar *current-profile* nil) (defun pr (&optional n) (sloop with ar = si::*profile-array* declare (string ar) for i below (if n (min n (array-total-size ar)) (array-total-size ar)) do (cond ((not (= 0 i))(if (= 0 (mod i 20)) (terpri)))) (princ (char-code (aref ar i))) (princ " ")) (values)) (defun fprofile(fun &optional (fract 1000) offset) (setq *current-profile* (list (+ (function-start (symbol-function fun)) (or offset 0)) fract)) (apply 'profile *current-profile* )) ;(defun foo (n) (sloop for i below n do nil)) ;;problem: the counter will wrap around at 256, so that it really is not valid ;;for long runs if the functions are heavily used. This means that ;;Remove all previous ticks from the profile array. (defun clear-profile () (sloop with ar = *profile-array* declare (string ar) for i below (array-total-size ar) do (setf (aref ar i) (code-char 0)))) (defun prof-offset (addr) (* (/ (float (cadr *current-profile*)) #x10000) (- addr (car *current-profile*)))) (defun prof (a b) (setf *current-profile* (list a b)) (profile a b)) (defun display-prof() (profile 0 0) (apply 'display-profile *current-profile*) (apply 'profile *current-profile*)) (defun set-up-profile (&optional (array-size 100000)(max-funs 6000) ; (name "saved_kcl")(dir *system-directory*)&aux sym ) ; (compiler::safe-system (format nil "(cd ~a ; rsym ~a \"#sym\")" dir name)) ; (or (probe-file (setq sym (format nil "~a#sym" dir))) (error "could not find ~a" sym)) ; (read-externals sym) (set-up-combined max-funs) (unless (and *profile-array* (>= (array-total-size *profile-array*) array-size)) (print "making new array") (setq *profile-array* (make-array array-size :element-type 'string-char :static t :initial-element (code-char 0)))) (format t "~%Loaded c and other function addresses~ ~%Using profile-array length ~a ~ ~%Use (si::prof 0 90) to start and (prof 0 0) to stop:~ ~%This starts monitoring at address 0 ~ ~%thru byte (256/90)*(length *profile-array*)~ ~%(si::display-prof) displays the results" (length *profile-array*))) gcl-2.6.14/lsp/gcl_listlib.lsp0000755000175000017500000001615514360276512014613 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; listlib.lsp ;;;; ;;;; list manipulating routines ; Rewritten 11 Feb 1993 by William Schelter and Gordon Novak to use iteration ; rather than recursion, as needed for large data sets. (in-package :si) (eval-when (compile) (proclaim '(optimize (safety 0) (space 3))) ) (macrolet ((defl2fn (n &rest body) `(defun ,n (list1 list2 &key key test test-not &aux r rp (key (when key (coerce key 'function))) (test (when test (coerce test 'function))) (test-not (when test-not (coerce test-not 'function)))) (macrolet ((check-list (list) `(do ((l ,list (cdr l))) ((not (consp l)) (when l (error 'type-error :datum l :expected-type 'list))))) (apply-to-stack (form list) `(let (r rp) (dolist (l ,list r) (let ((tmp (cons ,(if form `(,@form l) `l) nil))) (declare (dynamic-extent tmp)) (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp))))))) (collect (x) `(let ((temp ,x)) (setq rp (if rp (cdr (rplacd rp temp)) (setq r temp))))) (do-test (x z) `(cond (test (funcall test ,x ,z)) (test-not (not (funcall test-not ,x ,z))) ((eql ,x ,z)))) (memb (item list &optional rev) `(do ((item ,item)(l ,list (cdr l))) ((not l)) (let ((cl (car l))) (when (do-test ,@(if rev `(cl item) `(item cl))) (return l)))))) (check-list list1)(check-list list2) (let ((klist2 (if key (apply-to-stack (funcall key) list2) list2))) ,@body))))) (defl2fn intersection (dolist (l1 list1 r) (when (memb (if key (funcall key l1) l1) klist2) (collect (cons l1 nil))))) (defl2fn union (dolist (l1 list1) (unless (memb (if key (funcall key l1) l1) klist2) (collect (cons l1 nil)))) (when rp (rplacd rp list2)) (or r list2)) (defl2fn set-difference (dolist (l1 list1 r) (unless (memb (if key (funcall key l1) l1) klist2) (collect (cons l1 nil))))) (defl2fn set-exclusive-or (let ((klist1 (if key (apply-to-stack (funcall key) list1) list1))) (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1)) (unless (memb (car kl1) klist2) (collect (cons (car l1) nil)))) (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) r) (unless (memb (car kl2) klist1 t) (collect (cons (car l2) nil)))))) (defl2fn nintersection (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r) (let ((cl1 (car l1))) (when (memb (if key (funcall key cl1) cl1) klist2) (collect l1))))) (defl2fn nunion (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp list2)) (or r list2)) (let ((cl1 (car l1))) (unless (memb (if key (funcall key cl1) cl1) klist2) (collect l1))))) (defl2fn nset-difference (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r) (let ((cl1 (car l1))) (unless (memb (if key (funcall key cl1) cl1) klist2) (collect l1))))) (defl2fn nset-exclusive-or (let ((klist1 (if key (apply-to-stack (funcall key) list1) (apply-to-stack nil list1)))) (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1)) (unless (memb (car kl1) klist2) (collect l1))) (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) (when rp (rplacd rp nil)) r) (unless (memb (car kl2) klist1 t) (collect l2))))) (defl2fn subsetp r rp (dolist (l1 list1 t) (unless (memb (if key (funcall key l1) l1) klist2) (return nil))))) (defmacro tp-error (x y) `(error 'type-error :datum ,x :expected-type ',y)) (defun smallnthcdr (n x) (declare (fixnum n)) (cond ((= n 0) x) ((atom x) (when x (tp-error x proper-list))) ((smallnthcdr (1- n) (cdr x))))) (defun bignthcdr (n i s f) (declare (fixnum i)) (cond ((atom f) (when f (tp-error f proper-list))) ((atom (cdr f)) (when (cdr f) (tp-error (cdr f) proper-list))) ((eq s f) (smallnthcdr (mod n i) s)) ((bignthcdr n (1+ i) (cdr s) (cddr f))))) (defun nthcdr (n x) (declare (optimize (safety 1))) (cond ((or (not (integerp n)) (minusp n)) (tp-error n (integer 0))) ((< n array-dimension-limit) (smallnthcdr n x)) ((atom x) (when x (tp-error x proper-list))) ((atom (cdr x)) (when (cdr x) (tp-error (cdr x) proper-list))) ((bignthcdr n 1 (cdr x) (cddr x))))) (defun nth (n x) (declare (optimize (safety 2))) (car (nthcdr n x))) (defun first (x) (declare (optimize (safety 2))) (car x)) (defun second (x) (declare (optimize (safety 2))) (cadr x)) (defun third (x) (declare (optimize (safety 2))) (caddr x)) (defun fourth (x) (declare (optimize (safety 2))) (cadddr x)) (defun fifth (x) (declare (optimize (safety 2))) (car (cddddr x))) (defun sixth (x) (declare (optimize (safety 2))) (cadr (cddddr x))) (defun seventh (x) (declare (optimize (safety 2))) (caddr (cddddr x))) (defun eighth (x) (declare (optimize (safety 2))) (cadddr (cddddr x))) (defun ninth (x) (declare (optimize (safety 2))) (car (cddddr (cddddr x)))) (defun tenth (x) (declare (optimize (safety 2))) (cadr (cddddr (cddddr x)))) ; Courtesy Paul Dietz (defmacro nth-value (n expr) (declare (optimize (safety 1))) `(nth ,n (multiple-value-list ,expr))) (eval-when (compile eval) (defmacro repl-if (tc) `(labels ((l (tr &aux (k (if kf (funcall kf tr) tr))) (cond (,tc n) ((atom tr) tr) ((let* ((ca (car tr))(a (l ca))(cd (cdr tr))(d (l cd))) (if (and (eq a ca) (eq d cd)) tr (cons a d))))))) (declare (ftype (function (t) t) l)) (l tr)))) (defun subst (n o tr &key key test test-not &aux (kf (when key (coerce key 'function))) (tf (when test (coerce test 'function))) (ntf (when test-not (coerce test-not 'function)))) (declare (optimize (safety 1))) (check-type key (or null function)) (check-type test (or null function)) (check-type test-not (or null function)) (repl-if (cond (tf (funcall tf o k))(ntf (not (funcall ntf o k)))((eql o k))))) (defun subst-if (n p tr &key key &aux (kf (when key (coerce key 'function)))) (declare (optimize (safety 1))) (check-type p function) (check-type key (or null function)) (repl-if (funcall p k))) (defun subst-if-not (n p tr &key key &aux (kf (when key (coerce key 'function)))) (declare (optimize (safety 1))) (check-type p function) (check-type key (or null function)) (repl-if (not (funcall p k))))) gcl-2.6.14/lsp/gcl_wild_pathname_p.lsp0000644000175000017500000000211114360276512016264 0ustar cammcamm(in-package :si) (defun wild-namestring-p (x) (when (stringp x) (>= (string-match #v"(\\*|\\?|\\[|\\{)" x) 0))) (defun wild-dir-element-p (x) (or (eq x :wild) (eq x :wild-inferiors) (wild-namestring-p x))) (defun wild-path-element-p (x) (or (eq x :wild) (wild-namestring-p x))) #.`(defun wild-pathname-p (pd &optional f) (declare (optimize (safety 1))) (check-type pd pathname-designator) (check-type f (or null (member ,@+pathname-keys+))) (case f ((nil) (or (wild-namestring-p (namestring pd)) (when (typep pd 'pathname);FIXME stream (eq :wild (pathname-version pd))))) ;; ((nil) (if (stringp pd) (wild-namestring-p pd) ;; (let ((p (pathname pd))) ;; (when (member-if (lambda (x) (wild-pathname-p p x)) +pathname-keys+) t)))) ((:host :device) nil) (:directory (when (member-if 'wild-dir-element-p (pathname-directory pd)) t)) (:name (wild-path-element-p (pathname-name pd))) (:type (wild-path-element-p (pathname-type pd))) (:version (wild-path-element-p (pathname-version pd))))) gcl-2.6.14/lsp/ucall.lisp0000755000175000017500000000771514360276512013577 0ustar cammcamm(in-package 'compiler) (import 'si::switch) (import 'sloop::sloop) (provide "UCALL") ;;ucall is like funcall, except it assumes ;;1) its first arg has an inline-always property. ;;2) the order of evaluation of the remaining args is unimportant. ;;This can be useful when we know that the side effects caused by evaluating ;;the args do not affect the order of evaluation. ;;It also returns an indeterminate value. (defun c1ucall (args &aux funob (info (compiler::make-info))) (setq funob (compiler::c1funob (car args))) (compiler::add-info info (cadr funob)) (list 'ucall info funob (compiler::c1args (cdr args) info)) ) (defun c2ucall (funob args &aux (*inline-blocks* 0)(*vs* *vs*)) (let* ((fname (caddr funob)) (props (car (get fname 'inline-always))) new-args ) (or props (error "no inline-always prop")) (do ((v args (cdr v)) (types (car props) (cdr types))) ((null v) (setq new-args (nreverse new-args))) (setq new-args (append (inline-args (list (car v)) (list (car types))) new-args))) (wt-nl) (wt-inline-loc (nth 4 props) new-args) (wt ";") (unwind-exit "Cnil") (close-inline-blocks) )) ;;Usage (comment "hi there") ; will insert a comment at that point in ;;the program. (defun c1comment (args) (list 'comment (make-info) args)) (defun c2comment (args) (let ((string (car args))) (if (find #\/ string) (setq string (remove #\/ string))) (wt "/* "string " */"))) (defmacro comment (a) a nil) ;;Usage: (tlet (char *) jack ....) ;;--> {char * V1; ...V1.. (defun c1tlet (args &aux (info (make-info)) (*vars* *vars*)) (let ((sym (cadr args)) (type (car args)) form ) (let ((var (c1make-var sym nil nil nil))) (cond ((subtypep type 'fixnum) (setf (var-type var) 'fixnum))) (push var *vars*) (setq form (c1expr* (cons 'progn (cddr args)) info)) (list 'tlet (second form) type var form)))) (defun c2tlet (type var orig &aux (stype type)) (setf (var-loc var) (next-cvar)) (or (stringp type) (setq stype (format nil "~(~a~)" type))) (setf (var-kind var) (cond ((subtypep type 'fixnum) (setf (var-type var) 'fixnum)) (t 'object))) (if (listp type) (setq stype (string-trim "()" stype))) (wt-nl "{" stype " V" (var-loc var) ";" ) (c2expr orig) (wt "}")) (si::putprop 'tlet 'c1tlet 'c1special) (si::putprop 'tlet 'c2tlet 'c2) (defun c1clet (args) (let ((string (car args)) (form (c1expr (cons 'progn (cdr args))))) (list 'clet (second form) string form))) (defun c2clet (string orig ) (wt-nl "{" string) (c2expr orig) (wt "}")) ;;Usage: Takes a STRING and BODY. Acts like progn ;;on the body, but the c code will have {string . c code for body} ;;Sample (clet "int jack; char *jane;" ....) (defmacro clet (string &rest body) string `(progn ,@ body)) (si::putprop 'clet 'c1clet 'c1special) (si::putprop 'clet 'c2clet 'c2) (si::putprop 'comment 'c1comment 'c1special) (si::putprop 'comment 'c2comment 'c2) (si::putprop 'ucall 'c1ucall 'c1) (si::putprop 'ucall 'c2ucall 'c2) (defmacro def-inline (name args return-type &rest bod) (let* ((side-effect-p (if (member (car bod) '(:side-effect nil t)) (prog1 (and (car bod) t) (setq bod (cdr bod))) nil)) (inline (list args return-type side-effect-p nil (car bod)))) `(car (push ',inline (get ',name 'inline-always))))) (defmacro defun-inline (name args return-type &rest bod) (let* ((sym (gensym)) (named-args (nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0))) (inline (eval `(def-inline ,sym ,args ,return-type ,@ bod)))) `(progn (defun ,name ,named-args (declare ,@ (sloop for v in named-args for w in args when (not (eq t v)) collect (list w v))) (the ,return-type (,sym ,@ named-args))) (push ',inline (get ',name 'inline-always))))) (defmacro def-ucall (fun args string) (let ((sym (gensym))) `(progn (def-inline ,sym ,args t t ,string) (defmacro ,fun (&rest args) `(ucall ',',sym ,@ args))))) gcl-2.6.14/lsp/gcl_export.lsp0000755000175000017500000007740514360276512014477 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; export.lsp ;;;; ;;;; Exporting external symbols of LISP package (in-package :common-lisp) (export '( &allow-other-keys *print-miser-width* &aux *print-pprint-dispatch* &body *print-pretty* &environment *print-radix* &key *print-readably* &optional *print-right-margin* &rest *query-io* &whole *random-state* * *read-base* ** *read-default-float-format* *** *read-eval* *break-on-signals* *read-suppress* *compile-file-pathname* *readtable* *compile-file-truename* *standard-input* *compile-print* *standard-output* *compile-verbose* *terminal-io* *debug-io* *trace-output* *debugger-hook* + *default-pathname-defaults* ++ *error-output* +++ *features* - *gensym-counter* / *load-pathname* // *load-print* /// *load-truename* /= *load-verbose* 1+ *macroexpand-hook* 1- *modules* < *package* <= *print-array* = *print-base* > *print-case* >= *print-circle* abort *print-escape* abs *print-gensym* acons *print-length* acos *print-level* acosh *print-lines* add-method adjoin atom boundp adjust-array base-char break adjustable-array-p base-string broadcast-stream allocate-instance bignum broadcast-stream-streams alpha-char-p bit built-in-class alphanumericp bit-and butlast and bit-andc1 byte append bit-andc2 byte-position apply bit-eqv byte-size apropos bit-ior caaaar apropos-list bit-nand caaadr aref bit-nor caaar arithmetic-error bit-not caadar arithmetic-error-operands bit-orc1 caaddr arithmetic-error-operation bit-orc2 caadr array bit-vector caar array-dimension bit-vector-p cadaar array-dimension-limit bit-xor cadadr array-dimensions block cadar array-displacement boole caddar array-element-type boole-1 cadddr array-has-fill-pointer-p boole-2 caddr array-in-bounds-p boole-and cadr array-rank boole-andc1 call-arguments-limit array-rank-limit boole-andc2 call-method array-row-major-index boole-c1 call-next-method array-total-size boole-c2 car array-total-size-limit boole-clr case arrayp boole-eqv catch ash boole-ior ccase asin boole-nand cdaaar asinh boole-nor cdaadr assert boole-orc1 cdaar assoc boole-orc2 cdadar assoc-if boole-set cdaddr assoc-if-not boole-xor cdadr atan boolean cdar atanh both-case-p cddaar cddadr clear-input copy-tree cddar clear-output cos cdddar close cosh cddddr clrhash count cdddr code-char count-if cddr coerce count-if-not cdr compilation-speed ctypecase ceiling compile debug cell-error compile-file decf cell-error-name compile-file-pathname declaim cerror compiled-function declaration change-class compiled-function-p declare char compiler-macro decode-float char-code compiler-macro-function decode-universal-time char-code-limit complement defclass char-downcase complex defconstant char-equal complexp defgeneric char-greaterp compute-applicable-methods define-compiler-macro char-int compute-restarts define-condition char-lessp concatenate define-method-combination char-name concatenated-stream define-modify-macro char-not-equal concatenated-stream-streams define-setf-expander char-not-greaterp cond define-symbol-macro char-not-lessp condition defmacro char-upcase conjugate defmethod char/= cons defpackage char< consp defparameter char<= constantly defsetf char= constantp defstruct char> continue deftype char>= control-error defun character copy-alist defvar characterp copy-list delete check-type copy-pprint-dispatch delete-duplicates cis copy-readtable delete-file class copy-seq delete-if class-name copy-structure delete-if-not class-of copy-symbol delete-package denominator eq deposit-field eql describe equal describe-object equalp destructuring-bind error digit-char etypecase digit-char-p eval directory eval-when directory-namestring evenp disassemble every division-by-zero exp do export do* expt do-all-symbols extended-char do-external-symbols fboundp do-symbols fceiling documentation fdefinition dolist ffloor dotimes fifth double-float file-author double-float-epsilon file-error double-float-negative-epsilon file-error-pathname dpb file-length dribble file-namestring dynamic-extent file-position ecase file-stream echo-stream file-string-length echo-stream-input-stream file-write-date echo-stream-output-stream fill ed fill-pointer eighth find elt find-all-symbols encode-universal-time find-class end-of-file find-if endp find-if-not enough-namestring find-method ensure-directories-exist find-package ensure-generic-function find-restart find-symbol get-internal-run-time finish-output get-macro-character first get-output-stream-string fixnum get-properties flet get-setf-expansion float get-universal-time float-digits getf float-precision gethash float-radix go float-sign graphic-char-p floating-point-inexact handler-bind floating-point-invalid-operation handler-case floating-point-overflow hash-table floating-point-underflow hash-table-count floatp hash-table-p floor hash-table-rehash-size fmakunbound hash-table-rehash-threshold force-output hash-table-size format hash-table-test formatter host-namestring fourth identity fresh-line if fround ignorable ftruncate ignore ftype ignore-errors funcall imagpart function import function-keywords in-package function-lambda-expression incf functionp initialize-instance gcd inline generic-function input-stream-p gensym inspect gentemp integer get integer-decode-float get-decoded-time integer-length get-dispatch-macro-character integerp get-internal-real-time interactive-stream-p intern lisp-implementation-type internal-time-units-per-second lisp-implementation-version intersection list invalid-method-error list* invoke-debugger list-all-packages invoke-restart list-length invoke-restart-interactively listen isqrt listp keyword load keywordp load-logical-pathname-translations labels load-time-value lambda locally lambda-list-keywords log lambda-parameters-limit logand last logandc1 lcm logandc2 ldb logbitp ldb-test logcount ldiff logeqv least-negative-double-float logical-pathname least-negative-long-float logical-pathname-translations least-negative-normalized-double-float logior least-negative-normalized-long-float lognand least-negative-normalized-short-float lognor least-negative-normalized-single-float lognot least-negative-short-float logorc1 least-negative-single-float logorc2 least-positive-double-float logtest least-positive-long-float logxor least-positive-normalized-double-float long-float least-positive-normalized-long-float long-float-epsilon least-positive-normalized-short-float long-float-negative-epsilon least-positive-normalized-single-float long-site-name least-positive-short-float loop least-positive-single-float loop-finish length lower-case-p let machine-instance let* machine-type machine-version mask-field macro-function max macroexpand member macroexpand-1 member-if macrolet member-if-not make-array merge make-broadcast-stream merge-pathnames make-concatenated-stream method make-condition method-combination make-dispatch-macro-character method-combination-error make-echo-stream method-qualifiers make-hash-table min make-instance minusp make-instances-obsolete mismatch make-list mod make-load-form most-negative-double-float make-load-form-saving-slots most-negative-fixnum make-method most-negative-long-float make-package most-negative-short-float make-pathname most-negative-single-float make-random-state most-positive-double-float make-sequence most-positive-fixnum make-string most-positive-long-float make-string-input-stream most-positive-short-float make-string-output-stream most-positive-single-float make-symbol muffle-warning make-synonym-stream multiple-value-bind make-two-way-stream multiple-value-call makunbound multiple-value-list map multiple-value-prog1 map-into multiple-value-setq mapc multiple-values-limit mapcan name-char mapcar namestring mapcon nbutlast maphash nconc mapl next-method-p maplist nil nintersection package-error ninth package-error-package no-applicable-method package-name no-next-method package-nicknames not package-shadowing-symbols notany package-use-list notevery package-used-by-list notinline packagep nreconc pairlis nreverse parse-error nset-difference parse-integer nset-exclusive-or parse-namestring nstring-capitalize pathname nstring-downcase pathname-device nstring-upcase pathname-directory nsublis pathname-host nsubst pathname-match-p nsubst-if pathname-name nsubst-if-not pathname-type nsubstitute pathname-version nsubstitute-if pathnamep nsubstitute-if-not peek-char nth phase nth-value pi nthcdr plusp null pop number position numberp position-if numerator position-if-not nunion pprint oddp pprint-dispatch open pprint-exit-if-list-exhausted open-stream-p pprint-fill optimize pprint-indent or pprint-linear otherwise pprint-logical-block output-stream-p pprint-newline package pprint-pop pprint-tab read-char pprint-tabular read-char-no-hang prin1 read-delimited-list prin1-to-string read-from-string princ read-line princ-to-string read-preserving-whitespace print read-sequence print-not-readable reader-error print-not-readable-object readtable print-object readtable-case print-unreadable-object readtablep probe-file real proclaim realp prog realpart prog* reduce prog1 reinitialize-instance prog2 rem progn remf program-error remhash progv remove provide remove-duplicates psetf remove-if psetq remove-if-not push remove-method pushnew remprop quote rename-file random rename-package random-state replace random-state-p require rassoc rest rassoc-if restart rassoc-if-not restart-bind ratio restart-case rational restart-name rationalize return rationalp return-from read revappend read-byte reverse room simple-bit-vector rotatef simple-bit-vector-p round simple-condition row-major-aref simple-condition-format-arguments rplaca simple-condition-format-control rplacd simple-error safety simple-string satisfies simple-string-p sbit simple-type-error scale-float simple-vector schar simple-vector-p search simple-warning second sin sequence single-float serious-condition single-float-epsilon set single-float-negative-epsilon set-difference sinh set-dispatch-macro-character sixth set-exclusive-or sleep set-macro-character slot-boundp set-pprint-dispatch slot-exists-p set-syntax-from-char slot-makunbound setf slot-missing setq slot-unbound seventh slot-value shadow software-type shadowing-import software-version shared-initialize some shiftf sort short-float space short-float-epsilon special short-float-negative-epsilon special-operator-p short-site-name speed signal sqrt signed-byte stable-sort signum standard simple-array standard-char simple-base-string standard-char-p standard-class sublis standard-generic-function subseq standard-method subsetp standard-object subst step subst-if storage-condition subst-if-not store-value substitute stream substitute-if stream-element-type substitute-if-not stream-error subtypep stream-error-stream svref stream-external-format sxhash streamp symbol string symbol-function string-capitalize symbol-macrolet string-downcase symbol-name string-equal symbol-package string-greaterp symbol-plist string-left-trim symbol-value string-lessp symbolp string-not-equal synonym-stream string-not-greaterp synonym-stream-symbol string-not-lessp t string-right-trim tagbody string-stream tailp string-trim tan string-upcase tanh string/= tenth string< terpri string<= the string= third string> throw string>= time stringp trace structure translate-logical-pathname structure-class translate-pathname structure-object tree-equal style-warning truename truncate values-list two-way-stream variable two-way-stream-input-stream vector two-way-stream-output-stream vector-pop type vector-push type-error vector-push-extend type-error-datum vectorp type-error-expected-type warn type-of warning typecase when typep wild-pathname-p unbound-slot with-accessors unbound-slot-instance with-compilation-unit unbound-variable with-condition-restarts undefined-function with-hash-table-iterator unexport with-input-from-string unintern with-open-file union with-open-stream unless with-output-to-string unread-char with-package-iterator unsigned-byte with-simple-restart untrace with-slots unuse-package with-standard-io-syntax unwind-protect write update-instance-for-different-class write-byte update-instance-for-redefined-class write-char upgraded-array-element-type write-line upgraded-complex-part-type write-sequence upper-case-p write-string use-package write-to-string use-value y-or-n-p user-homedir-pathname yes-or-no-p values zerop)) gcl-2.6.14/lsp/gcl_rename_file.lsp0000644000175000017500000000334414360276512015410 0ustar cammcamm(in-package :si) (defun set-path-stream-name (x y) (check-type x pathname-designator) (typecase x (synonym-stream (set-path-stream-name (symbol-value (synonym-stream-symbol x)) y)) (stream (c-set-stream-object1 x y)))) (defun rename-file (f n &aux (pf (pathname f))(pn (merge-pathnames n pf nil)) (tpf (truename pf))(nf (namestring tpf)) (tpn (translate-logical-pathname pn))(nn (namestring tpn))) (declare (optimize (safety 1))) (check-type f pathname-designator) (check-type n (and pathname-designator (not stream))) (unless (rename nf nn) (error 'file-error :pathname pf :format-control "Cannot rename ~s to ~s." :format-arguments (list nf nn))) (set-path-stream-name f pn) (values pn tpf (truename tpn))) (defun user-homedir-pathname (&optional (host :unspecific hostp)) (declare (optimize (safety 1))) (check-type host (or string list (eql :unspecific))) (unless hostp (pathname (home-namestring "~")))) (defun delete-file (f &aux (pf (truename f))(nf (namestring pf))) (declare (optimize (safety 1))) (check-type f pathname-designator) (unless (if (eq :directory (stat1 nf)) (rmdir nf) (unlink nf)) (error 'file-error :pathname (pathname nf) :format-control "Cannot delete pathname.")) t) (defun file-write-date (spec) (declare (optimize (safety 1))) (check-type spec pathname-designator) (multiple-value-bind (tp sz tm) (stat (namestring (truename spec))) (declare (ignore tp sz)) (+ tm (* (+ 17 (* 70 365)) (* 24 60 60))))) (defun file-author (spec) (declare (optimize (safety 1))) (check-type spec pathname-designator) (multiple-value-bind (tp sz tm uid) (stat (namestring (truename spec))) (declare (ignore tp sz tm)) (uid-to-name uid))) gcl-2.6.14/lsp/gcl_top.lsp0000755000175000017500000005252714360276512013756 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; top.lsp ;;;; ;;;; Top-level loop, break loop, and error handlers ;;;; ;;;; Revised on July 11, by Carl Hoffman. (in-package :si) (export '*break-readtable*) (export '(loc *debug-print-level*)) (export '(vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go)) (defvar *command-args* nil) (defvar +) (defvar ++) (defvar +++) (defvar -) (defvar *) (defvar **) (defvar ***) (defvar /) (defvar //) (defvar ///) ;; setup file search and autoload (defvar *fixed-load-path* nil) (defvar *load-path* nil) (defvar *load-types* '(".o" ".lsp" ".lisp")) (defvar *lisp-initialized* nil) (defconstant +top-level-quit-tag+ (cons nil nil)) (defvar *quit-tag* +top-level-quit-tag+) (defvar *quit-tags* nil) (defvar *break-level* '()) (defvar *break-env* nil) (defvar *ihs-base* 1) (defvar *ihs-top* 1) (defvar *current-ihs* 1) (defvar *frs-base* 0) (defvar *frs-top* 0) (defvar *break-enable* t) (defvar *break-message* "") (defvar *break-readtable* nil) (defvar *top-level-hook* nil) (defvar *top-eof* (cons nil nil)) (defvar *no-prompt* nil) (defun top-level () (let ((+ nil) (++ nil) (+++ nil) (- nil) (* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil)) (setq *lisp-initialized* t) (catch *quit-tag* (progn (cond (*multiply-stacks* (setq *multiply-stacks* nil)) ((when (fboundp 'probe-file) (probe-file "init.lsp")) (load "init.lsp")))) (when (if (symbolp *top-level-hook*) (fboundp *top-level-hook*) (functionp *top-level-hook*)) (funcall *top-level-hook*))) (when (boundp '*system-banner*) (format t *system-banner*) (format t "Temporary directory for compiler files:~%~a~%" *tmp-dir*)) (loop (setq +++ ++ ++ + + -) (if *no-prompt* (setq *no-prompt* nil) (format t "~%~a>" (if (eq *package* (find-package 'user)) "" (package-name *package*)))) (reset-stack-limits) ;; have to exit and re-enter to multiply stacks (cond (*multiply-stacks* (Return-from top-level))) (when (catch *quit-tag* (setq - (locally (declare (notinline read)) (read *standard-input* nil *top-eof*))) (when (eq - *top-eof*) (bye)) (let ((values (multiple-value-list (locally (declare (notinline eval)) (eval -))))) (setq /// // // / / values *** ** ** * * (car /)) (fresh-line) (dolist (val /) (locally (declare (notinline prin1)) (prin1 val)) (terpri)) nil)) (setq *evalhook* nil *applyhook* nil) (terpri *error-output*) (break-current))))) (defun set-dir (sym val) (let ((tem (or val (and (boundp sym) (symbol-value sym))))) (if tem (set sym (coerce-slash-terminated tem))))) (defvar *error-p* nil) (defvar *lib-directory* nil) (defun process-some-args (args &optional compile &aux *load-verbose*) (when args (let ((x (pop args))) (cond ((equal x "-load") (load (pop args))) ((equal x "-eval") (eval (read-from-string (pop args)))) ((equal x "-batch") (setq *top-level-hook* 'bye)) ((equal x "-o-file") (unless (read-from-string (car args)) (push (cons :o-file nil) compile) (pop args))) ((equal x "-h-file") (push (cons :h-file t) compile)) ((equal x "-data-file") (push (cons :data-file t) compile)) ((equal x "-c-file") (push (cons :c-file t) compile)) ((equal x "-system-p") (push (cons :system-p t) compile)) ((equal x "-compile") (push (cons :compile (pop args)) compile)) ((equal x "-o") (push (cons :o (pop args)) compile)) ((equal x "-libdir") (set-dir '*lib-directory* (pop args))) ((equal x "-dir") (set-dir '*system-directory* (pop args))) ((equal x "-f") (do-f (car (setq *command-args* args)))) ((equal x "--") (setq *command-args* args args nil)))) (process-some-args args compile)) (when compile (let* (*break-enable* (file (cdr (assoc :compile compile))) (o (cdr (assoc :o compile))) (compile (remove :o (remove :compile compile :key 'car) :key 'car)) + (compile (cons (cons :output-file (or o (merge-pathnames ".o" file))) compile)) (result (system:error-set `(apply 'compile-file ,file ',(mapcan (lambda (x) (list (car x) (cdr x))) compile))))) (bye (if (or *error-p* (equal result '(nil))) 1 0))))) (defun dbl-read (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) &aux tem ch) (tagbody top (setq ch (read-char stream eof-error-p eof-value)) (cond ((eql ch #\newline) (go top)) ((eq ch eof-value) (return-from dbl-read eof-value))) (unread-char ch stream)) (cond ((eql #\: ch) (setq tem (string-concatenate "(" (read-line stream eof-error-p eof-value)")")) (read (make-string-input-stream tem) eof-error-p eof-value)) (t (read stream eof-error-p eof-value)))) (defvar *debug-print-level* 3) (defun terminal-interrupt (correctablep) (let ((*break-enable* t)) (if correctablep (cerror "Type :r to resume execution, or :q to quit to top level." "Console interrupt.") (error "Console interrupt -- cannot continue.")))) (defun break-call (key args &optional (prop 'si::break-command) &aux fun) (setq fun (complete-prop key 'keyword prop)) (or fun (return-from break-call nil)) (setq fun (get fun prop)) (cond (fun (setq args (cons fun args)) (or (symbolp fun) (setq args (cons 'funcall args))) (evalhook args nil nil *break-env*) ) (t (format *debug-io* "~&~S is undefined break command.~%" key)))) (defun break-quit (&optional (level 0) &aux (current-level (length *break-level*))) (when (and (>= level 0) (< level current-level)) (let ((x (nthcdr (- current-level level 1) *quit-tags*)) (y (member nil *quit-tags* :key 'cdr))) (if (tailp x y) (format *debug-io* "The *quit-tag* is disabled at level ~s.~%" (length y)) (throw (cdar x) (cdar x))))) (break-current)) (defun break-previous (&optional (offset 1)) (do ((i (1- *current-ihs*) (1- i))) ((or (< i *ihs-base*) (<= offset 0)) (set-env) (break-current)) (when (ihs-visible i) (setq *current-ihs* i) (setq offset (1- offset))))) (defun set-current () (do ((i *current-ihs* (1- i))) ((or (ihs-visible i) (<= i *ihs-base*)) (setq *current-ihs* i) (set-env) (format *debug-io* "Broken at ~:@(~S~).~:[ Type :H for Help.~;~]" (ihs-fname *current-ihs*) (cdr *break-level*))))) (defun break-next (&optional (offset 1)) (do ((i *current-ihs* (1+ i))) ((or (> i *ihs-top*) (< offset 0)) (set-env) (break-current)) (when (ihs-visible i) (setq *current-ihs* i) (setq offset (1- offset))))) (defun break-go (ihs-index) (setq *current-ihs* (min (max ihs-index *ihs-base*) *ihs-top*)) (if (ihs-visible *current-ihs*) (progn (set-env) (break-current)) (break-previous))) (defun break-message () (princ *break-message* *debug-io*) (terpri *debug-io*) (values)) (defun describe-environment (&optional (env *break-env*) (str *debug-io*)) (or (eql (length env) 3) (error "bad env")) (let ((fmt "~a~#[none~;~S~;~S and ~S~ ~:;~@{~#[~;and ~]~S~^, ~}~].~%")) (apply 'format str fmt "Local variables: " (mapcar #'car (car *break-env*))) (apply 'format str fmt "Local functions: " (mapcar #'car (cadr *break-env*))) (apply 'format str fmt "Local blocks: " (mapcan #'(lambda (x) (when (eq (cadr x) 'block) (list (car x)))) (caddr *break-env*))) (apply 'format str fmt "Local tags: " (mapcan #'(lambda (x) (when (eq (cadr x) 'tag) (list (car x)))) (caddr *break-env*))))) (defun break-vs (&optional (x (ihs-vs *ihs-base*)) (y (ihs-vs *ihs-top*))) (setq x (max x (ihs-vs *ihs-base*))) (setq y (min y (1- (ihs-vs (1+ *ihs-top*))))) (do ((ii *ihs-base* (1+ ii))) ((or (>= ii *ihs-top*) (>= (ihs-vs ii) x)) (do ((vi x (1+ vi))) ((> vi y) (values)) (do () ((> (ihs-vs ii) vi)) (when (ihs-visible ii) (print-ihs ii)) (incf ii)) (format *debug-io* "~&VS[~d]: ~s" vi (vs vi)))))) (defun break-local (&optional (n 0) &aux (x (+ (ihs-vs *current-ihs*) n))) (break-vs x x)) (defun break-bds (&rest vars &aux (fi *frs-base*)) (do ((bi (1+ (frs-bds (1- *frs-base*))) (1+ bi)) (last (frs-bds (1+ *frs-top*)))) ((> bi last) (values)) (when (or (null vars) (member (bds-var bi) vars)) (do () ((or (> fi *frs-top*) (> (frs-bds fi) bi))) (print-frs fi) (incf fi)) (format *debug-io* "~&BDS[~d]: ~s = ~s" bi (bds-var bi) (bds-val bi))))) (defun simple-backtrace () (princ "Backtrace: " *debug-io*) (do* ((i *ihs-base* (1+ i)) (b nil t)) ((> i *ihs-top*) (terpri *debug-io*) (values)) (when (ihs-visible i) (when b (princ " > " *debug-io*)) (write (ihs-fname i) :stream *debug-io* :escape t :case (if (= i *current-ihs*) :upcase :downcase))))) (defun ihs-backtrace (&optional (from *ihs-base*) (to *ihs-top*)) (setq from (max from *ihs-base*)) (setq to (min to *ihs-top*)) (do* ((i from (1+ i)) (j (or (sch-frs-base *frs-base* from) (1+ *frs-top*)))) ((> i to) (values)) (when (ihs-visible i) (print-ihs i)) (do () ((or (> j *frs-top*) (> (frs-ihs j) i))) (print-frs j) (incf j)))) (defun print-ihs (i &aux (*print-level* 2) (*print-length* 4)) (format t "~&~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]" (= i *current-ihs*) i (let ((fun (ihs-fun i))) (cond ((or (symbolp fun) (compiled-function-p fun)) fun) ((consp fun) (case (car fun) (lambda fun) ((lambda-block lambda-block-expanded) (cdr fun)) (lambda-closure (cons 'lambda (cddddr fun))) (lambda-block-closure (cddddr fun)) (t (cond ((and (symbolp (car fun)) (or (special-operator-p(car fun)) (fboundp (car fun)))) (car fun)) (t '(:zombi)))))) (t (print fun) :zombi))) (ihs-vs i))) (defun print-frs (i) (format *debug-io* "~& FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]" i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i))) (defun frs-kind (i &aux x) (case (frs-class i) (:catch (if (spicep (frs-tag i)) (or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2)) :key #'caddr :test #'eq)) (if (eq (cadar x) 'block) `(block ,(caar x) ***) `(tagbody ,@(reverse (mapcar #'car (remove (frs-tag i) x :test-not #'eq :key #'caddr))) ***))) `(block/tagbody ,(frs-tag i))) `(catch ',(frs-tag i) ***))) (:protect '(unwind-protect ***)) (t `(system-internal-catcher ,(frs-tag i))))) (defun break-current () (if *break-level* (format *debug-io* "Broken at ~:@(~S~)." (ihs-fname *current-ihs*)) (format *debug-io* "~&Top level.")) (values)) (defvar *break-hidden-packages* nil) (defun ihs-visible (i &aux (tem (ihs-fname i))) (and tem (not (member tem *break-hidden-packages*)))) (defun ihs-fname (ihs-index) (let ((fun (ihs-fun ihs-index))) (cond ((symbolp fun) fun) ((consp fun) (case (car fun) (lambda 'lambda) ((lambda-block lambda-block-expanded) (cadr fun)) (lambda-block-closure (nth 4 fun)) (lambda-closure 'lambda-closure) (t (if (and (symbolp (car fun)) (or (special-operator-p (car fun)) (fboundp (car fun)))) (car fun) :zombi) ))) ((compiled-function-p fun) (compiled-function-name fun)) (t :zombi)))) (defun ihs-not-interpreted-env (ihs-index) (let ((fun (ihs-fun ihs-index))) (cond ((and (consp fun) (> ihs-index 3) ;(<= (ihs-vs ihs-index) (ihs-vs (- ihs-index 1))) ) nil) (t t)))) (defun set-env () (setq *break-env* (if (ihs-not-interpreted-env *current-ihs*) nil (let ((i (ihs-vs *current-ihs*))) (list (vs i) (vs (1+ i)) (vs (+ i 2))))))) (defun list-delq (x l) (cond ((null l) nil) ((eq x (car l)) (cdr l)) (t (rplacd l (list-delq x (cdr l)))))) (defun super-go (i tag &aux x) (when (and (>= i *frs-base*) (<= i *frs-top*) (spicep (frs-tag i))) (if (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2)) :key #'caddr :test #'eq)) ; Interpreted TAGBODY. (when (and (eq (cadar x) 'tag) (member tag (mapcar #'car (remove (frs-tag i) x :test-not #'eq :key #'caddr)))) (internal-super-go (frs-tag i) tag t)) ; Maybe, compiled cross-closure TAGBODY. ; But, it may also be compiled cross-closure BLOCK, in which case ; SUPER-GO just RETURN-FROMs with zero values. (internal-super-go (frs-tag i) tag nil))) (format *debug-io* "~s is invalid tagbody identification for ~s." i tag)) (defun break-backward-search-stack (sym &aux string) (setq string (string sym)) (do* ((ihs (1- *current-ihs*) (1- ihs)) (fname (ihs-fname ihs) (ihs-fname ihs))) ((< ihs *ihs-base*) (format *debug-io* "Search for ~a failed.~%" string)) (when (and (ihs-visible ihs) (search string (symbol-name fname) :test #'char-equal)) (break-go ihs) (return)))) (defun break-forward-search-stack (sym &aux string) (setq string (string sym)) (do* ((ihs (1+ *current-ihs*) (1+ ihs)) (fname (ihs-fname ihs) (ihs-fname ihs))) ((> ihs *ihs-top*) (format *debug-io* "Search for ~a failed.~%" string)) (when (and (ihs-visible ihs) (search string (symbol-name fname) :test #'char-equal)) (break-go ihs) (return)))) (defun break-resume () (if *debug-continue* (invoke-restart *debug-continue*) :resume)) (putprop :b 'simple-backtrace 'break-command) (putprop :r 'break-resume 'break-command) (putprop :resume (get :r 'break-command) 'break-command) (putprop :bds 'break-bds 'break-command) (putprop :blocks 'break-blocks 'break-command) (putprop :bs 'break-backward-search-stack 'break-command) (putprop :c 'break-current 'break-command) (putprop :fs 'break-forward-search-stack 'break-command) (putprop :functions 'break-functions 'break-command) (putprop :go 'break-go 'break-command) (putprop :h 'break-help 'break-command) (putprop :help 'break-help 'break-command) (putprop :ihs 'ihs-backtrace 'break-command) (putprop :env '(lambda () (describe-environment *break-env*)) 'break-command) (putprop :m 'break-message 'break-command) (putprop :n 'break-next 'break-command) (putprop :p 'break-previous 'break-command) (putprop :q 'break-quit 'break-command) (putprop :s 'break-backward-search-stack 'break-command) (putprop :vs 'break-vs 'break-command) (defun break-help () (dolist (v '( " Break-loop Command Summary ([] indicates optional arg) -------------------------- :bl [j] show local variables and their values, or segment of vs if compiled in j stack frames starting at the current one. :bt [n] BACKTRACE [n steps] :down [i] DOWN i frames (one if no i) :env describe ENVIRONMENT of this stack frame (for interpreted). :fr [n] show frame n :loc [i] return i'th local of this frame if its function is compiled (si::loc i) " ":r RESUME (return from the current break loop). :up [i] UP i frames (one if no i) Example: print a bactrace of the last 4 frames >>:bt 4 Note: (use-fast-links nil) makes all non system function calls be recorded in the stack. (use-fast-links t) is the default Low level commands: ------------------ :p [i] make current the i'th PREVIOUS frame (in list show by :b) :n [i] make current the i'th NEXT frame (in list show by :b) :go [ihs-index] make current the frame corresponding ihs-index " ":m print the last break message. :c show function of the current ihs frame. :q [i] quit to top level :r resume from this break loop. :b full backtrace of all functions and special forms. :bs [name] backward search for frame named 'name' :fs [name] search for frame named 'name' :vs [from] [to] Show value stack between FROM and TO :ihs [from] [to] Show Invocation History Stack " " :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 ")) (format *debug-io* v)) (format *debug-io* "~%Here is a COMPLETE list of bindings. Too add a new one, add a 'si::break-command property:") (do-symbols (v (find-package "KEYWORD")) (cond ((get v 'si::break-command) (format *debug-io* "~%~(~a -- ~a~)" v (get v 'si::break-command))))) (values) ) ;;make sure '/' terminated (defun coerce-slash-terminated (v) (let ((n (length v))) (if (and (> n 0) (eql (aref v (1- n)) #\/)) v (string-concatenate v "/")))) (defun fix-load-path (l) (when (not (equal l *fixed-load-path*)) (do ((x l (cdr x)) ) ((atom x)) (setf (car x) (coerce-slash-terminated (car x)))) (do ((v l (cdr v))) ((atom v)) (do ((w v (cdr w))) ((atom (cdr w))) (cond ((equal (cadr w) (car v)) (setf (cdr w)(cddr w))))))) (setq *fixed-load-path* l)) (defun file-search (NAME &optional (dirs *load-path*) (extensions *load-types*) (fail-p t) &aux tem) "Search for NAMME in DIRS with EXTENSIONS. First directory is checked for first name and all extensions etc." (fix-load-path dirs) (dolist (v dirs) (dolist (e extensions) (if (probe-file (setq tem (si::string-concatenate v name e))) (return-from file-search tem)))) (if fail-p (let ((*path* nil)) (declare (special *path*)) (cerror "Do (setq si::*path* \"pathname\") for path to use then :r to continue" "Lookup failed in directories:~s for name ~s with extensions ~s" dirs name extensions) *path*))) (defun aload (path) (load (file-search path *load-path* *load-types*))) (defun autoload (sym path &aux (si::*ALLOW-GZIPPED-FILE* t)) (or (fboundp sym) (setf (symbol-function sym) #'(lambda (&rest l) (aload path) (apply sym l))))) (defun autoload-macro (sym path &aux (si::*ALLOW-GZIPPED-FILE* t)) (or (fboundp sym) (setf (macro-function sym) #'(lambda (form env) (aload path) (funcall sym form env))))) (eval-when (compile) (proclaim '(optimize (safety 0))) ) (defvar si::*command-args* nil) (defvar *tmp-dir*) (defun ensure-dir-string (str) (if (eq (stat1 str) :directory) (coerce-slash-terminated str) str)) (defun get-temp-dir () (dolist (x `(,@(mapcar 'si::getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" "")) (when x (let ((x (coerce-slash-terminated x))) (when (eq (stat1 x) :directory) (return-from get-temp-dir x)))))) (defvar *cc* "cc") (defvar *ld* "ld") (defvar *objdump* nil) (defvar *current-directory* *system-directory*) (defun current-directory-pathname nil (pathname (coerce-slash-terminated (getcwd)))) (defun set-up-top-level (&aux (i (argc)) tem) (declare (fixnum i)) (setq *current-directory* (current-directory-pathname)) (setq *tmp-dir* (get-temp-dir) *cc* (or (get-path *cc*) *cc*) *ld* (or (get-path *ld*) *ld*) *objdump* (get-path "objdump --source ")) (dotimes (j i) (push (argv j) tem)) (setq *command-args* (nreverse tem)) (setq tem *lib-directory*) (process-some-args *command-args*) (unless *lib-directory* (let ((dir (getenv "GCL_LIBDIR"))) (when dir (setq *lib-directory* (coerce-slash-terminated dir))))) (unless (and *load-path* (equal tem *lib-directory*)) (mapc (lambda (x) (push (string-concatenate *lib-directory* x) *load-path*)) '("lsp/" "gcl-tk/" "xgcl-2/"))) (unless (boundp '*system-directory*) (setq *system-directory* (namestring (truename (make-pathname :name nil :type nil :defaults (argv 0)))))))) (defvar *old-top-level* #'top-level) (defun gcl-top-level nil (set-up-top-level) (in-package :user) (setq *ihs-top* (ihs-top)) (funcall *old-top-level*)) (defun do-f (file &aux *break-enable*) (catch *quit-tag* (labels ((read-loop (st &aux (tem (read st nil 'eof))) (when (eq tem 'eof) (bye)) (eval tem) (read-loop st)) (read-file (st) (read-line st nil 'eof) (read-loop st))) (if file (with-open-file (st file) (read-file st)) (read-file *standard-input*)))) (bye 1)) gcl-2.6.14/lsp/gcl_loop.lsp0000644000175000017500000024561714360276512014126 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase:T -*- ;;;> ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. ;;;> All Rights Reserved. ;;;> ;;;> Permission to use, copy, modify and distribute this software and its ;;;> documentation for any purpose and without fee is hereby granted, ;;;> provided that the M.I.T. copyright notice appear in all copies and that ;;;> both that copyright notice and this permission notice appear in ;;;> supporting documentation. The names "M.I.T." and "Massachusetts ;;;> Institute of Technology" may not be used in advertising or publicity ;;;> pertaining to distribution of the software without specific, written ;;;> prior permission. Notice must be given in supporting documentation that ;;;> copying distribution is by permission of M.I.T. M.I.T. makes no ;;;> representations about the suitability of this software for any purpose. ;;;> It is provided "as is" without express or implied warranty. ;;;> ;;;> Massachusetts Institute of Technology ;;;> 77 Massachusetts Avenue ;;;> Cambridge, Massachusetts 02139 ;;;> United States of America ;;;> +1-617-253-1000 ;;;> ;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. ;;;> All Rights Reserved. ;;;> ;;;> Permission to use, copy, modify and distribute this software and its ;;;> documentation for any purpose and without fee is hereby granted, ;;;> provided that the Symbolics copyright notice appear in all copies and ;;;> that both that copyright notice and this permission notice appear in ;;;> supporting documentation. The name "Symbolics" may not be used in ;;;> advertising or publicity pertaining to distribution of the software ;;;> without specific, written prior permission. Notice must be given in ;;;> supporting documentation that copying distribution is by permission of ;;;> Symbolics. Symbolics makes no representations about the suitability of ;;;> this software for any purpose. It is provided "as is" without express ;;;> or implied warranty. ;;;> ;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, ;;;> and Zetalisp are registered trademarks of Symbolics, Inc. ;;;> ;;;> Symbolics, Inc. ;;;> 8 New England Executive Park, East ;;;> Burlington, Massachusetts 01803 ;;;> United States of America ;;;> +1-617-221-1000 ;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ #+cmu (ext:file-comment "$Header$") ;;;; LOOP Iteration Macro #+allegro (in-package :excl) #+ecls (in-package "SI") #-(or allegro ecls) (in-package :ansi-loop) (export '(loop loop-finish)) #-ecls (provide :loop) #+Cloe-Runtime ;Don't ask. (car (push "%Z% %M% %I% %E% %U%" system::*module-identifications*)) ;;; Technology. ;;; ;;; The LOOP iteration macro is one of a number of pieces of code ;;; originally developed at MIT for which free distribution has been ;;; permitted, as long as the code is not sold for profit, and as long ;;; as notification of MIT's interest in the code is preserved. ;;; ;;; This version of LOOP, which is almost entirely rewritten both as ;;; clean-up and to conform with the ANSI Lisp LOOP standard, started ;;; life as MIT LOOP version 829 (which was a part of NIL, possibly ;;; never released). ;;; ;;; A "light revision" was performed by me (Glenn Burke) while at ;;; Palladian Software in April 1986, to make the code run in Common ;;; Lisp. This revision was informally distributed to a number of ;;; people, and was sort of the "MIT" version of LOOP for running in ;;; Common Lisp. ;;; ;;; A later more drastic revision was performed at Palladian perhaps a ;;; year later. This version was more thoroughly Common Lisp in style, ;;; with a few miscellaneous internal improvements and extensions. I ;;; have lost track of this source, apparently never having moved it to ;;; the MIT distribution point. I do not remember if it was ever ;;; distributed. ;;; ;;; This revision for the ANSI standard is based on the code of my April ;;; 1986 version, with almost everything redesigned and/or rewritten. ;;; The design of this LOOP is intended to permit, using mostly the same ;;; kernel of code, up to three different "loop" macros: ;;; ;;; (1) The unextended, unextensible ANSI standard LOOP; ;;; ;;; (2) A clean "superset" extension of the ANSI LOOP which provides ;;; functionality similar to that of the old LOOP, but "in the style of" ;;; the ANSI LOOP. For instance, user-definable iteration paths, with a ;;; somewhat cleaned-up interface. ;;; ;;; (3) Extensions provided in another file which can make this LOOP ;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, ;;; with only a small addition of code (instead of two whole, separate, ;;; LOOP macros). ;;; ;;; Each of the above three LOOP variations can coexist in the same LISP ;;; environment. ;;; ;;;; Miscellaneous Environment Things ;;;The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or ;;; its obvious expansion (prog1 (car x) (setq x (cdr x))). Usually this involves ;;; shifting fenceposts in an iteration or series of carcdr operations. This is ;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's ;;; destructuring setq code. (eval-when (compile load eval) #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*) ) ;;; The uses of this macro are retained in the CL version of loop, in ;;; case they are needed in a particular implementation. Originally ;;; dating from the use of the Zetalisp COPYLIST* function, this is used ;;; in situations where, were cdr-coding in use, having cdr-NIL at the ;;; end of the list might be suboptimal because the end of the list will ;;; probably be RPLACDed and so cdr-normal should be used instead. (defmacro loop-copylist* (l) #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) ;;Explorer?? #-Genera `(copy-list ,l) ) (defvar *loop-gentemp* nil) (defun loop-gentemp (&optional (pref 'loopvar-)) (if *loop-gentemp* (gentemp (string pref)) (gensym))) (defvar *loop-real-data-type* 'real) (defun loop-optimization-quantities (env) ;; The ANSI conditionalization here is for those lisps that implement ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). ;; It is really commentary on how this code could be written. I don't ;; actually expect there to be an ANSI #+-conditional -- it should be ;; replaced with the appropriate conditional name for your ;; implementation/dialect. (declare #-ANSI (ignore env) #+Genera (values speed space safety compilation-speed debug)) #+ANSI (let ((stuff (declaration-information 'optimize env))) (values (or (cdr (assoc 'speed stuff)) 1) (or (cdr (assoc 'space stuff)) 1) (or (cdr (assoc 'safety stuff)) 1) (or (cdr (assoc 'compilation-speed stuff)) 1) (or (cdr (assoc 'debug stuff)) 1))) #+CLOE-Runtime (values compiler::time compiler::space compiler::safety compiler::compilation-speed 1) #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) ;;; The following form takes a list of variables and a form which presumably ;;; references those variables, and wraps it somehow so that the compiler does not ;;; consider those variables have been referenced. The intent of this is that ;;; iteration variables can be flagged as unused by the compiler, e.g. I in ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage ;;; of it is "invisible" or "not to be considered". ;;;We implicitly assume that a setq does not count as a reference. That is, the ;;; kind of form generated for the above loop construct to step I, simplified, is ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). (defun hide-variable-references (variable-list form) (declare #-Genera (ignore variable-list)) #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) #-Genera form) ;;; The following function takes a flag, a variable, and a form which presumably ;;; references that variable, and wraps it somehow so that the compiler does not ;;; consider that variable to have been referenced. The intent of this is that ;;; iteration variables can be flagged as unused by the compiler, e.g. I in ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage ;;; of it is "invisible" or "not to be considered". ;;;We implicitly assume that a setq does not count as a reference. That is, the ;;; kind of form generated for the above loop construct to step I, simplified, is ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). ;;;Certain cases require that the "invisibility" of the reference be conditional upon ;;; something. This occurs in cases of "named" variables (the USING clause). For instance, ;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) ;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is ;;; not referenced. However, if no USING clause is present, we definitely do not ;;; want to be informed that some random gensym is not used. ;;;It is easier for the caller to do this conditionally by passing a flag (which ;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than ;;; for all callers to contain the conditional invisibility construction. (defun hide-variable-reference (really-hide variable form) (declare #-Genera (ignore really-hide variable)) #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns `(compiler:invisible-references (,variable) ,form) form) #-Genera form) ;;;; List Collection Macrology (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) &body body) ;; TI? Exploder? #+LISPM (let ((head-place (or user-head-var head-var))) `(let* ((,head-place nil) (,tail-var ,(hide-variable-reference user-head-var user-head-var `(progn #+Genera (scl:locf ,head-place) #-Genera (system:variable-location ,head-place))))) ,@body)) #-LISPM (let ((l (and user-head-var (list (list user-head-var nil))))) #+CLOE `(sys::with-stack-list* (,head-var nil nil) (let ((,tail-var ,head-var) ,@l) ,@body)) #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) ,@body))) (defmacro loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) (declare #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. ) (setq form (macroexpand form env)) (flet ((cdr-wrap (form n) (declare (fixnum n)) (do () ((<= n 4) (setq form `(,(case n (1 'cdr) (2 'cddr) (3 'cdddr) (4 'cddddr)) ,form))) (setq form `(cddddr ,form) n (- n 4))))) (let ((tail-form form) (ncdrs nil)) ;;Determine if the form being constructed is a list of known length. (when (consp form) (cond ((eq (car form) 'list) (setq ncdrs (1- (length (cdr form)))) ;; Because the last element is going to be RPLACDed, ;; we don't want the cdr-coded implementations to use ;; cdr-nil at the end (which would just force copying ;; the whole list again). #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) ((member (car form) '(list* cons)) (when (and (cddr form) (member (car (last form)) '(nil 'nil))) (setq ncdrs (- (length (cdr form)) 2)))))) (let ((answer (cond ((null ncdrs) `(when (setf (cdr ,tail-var) ,tail-form) (setq ,tail-var (last (cdr ,tail-var))))) ((< ncdrs 0) (return-from loop-collect-rplacd nil)) ((= ncdrs 0) ;; Here we have a choice of two idioms: ;; (rplacd tail (setq tail tail-form)) ;; (setq tail (setf (cdr tail) tail-form)). ;;Genera and most others I have seen do better with the former. `(rplacd ,tail-var (setq ,tail-var ,tail-form))) (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) ncdrs)))))) ;;If not using locatives or something similar to update the user's ;; head variable, we've got to set it... It's harmless to repeatedly set it ;; unconditionally, and probably faster than checking. #-LISPM (when user-head-var (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) answer)))) (defmacro loop-collect-answer (head-var &optional user-head-var) (or user-head-var (progn ;;If we use locatives to get tail-updating to update the head var, ;; then the head var itself contains the answer. Otherwise we ;; have to cdr it. #+LISPM head-var #-LISPM `(cdr ,head-var)))) ;;;; Maximization Technology #| The basic idea of all this minimax randomness here is that we have to have constructed all uses of maximize and minimize to a particular "destination" before we can decide how to code them. The goal is to not have to have any kinds of flags, by knowing both that (1) the type is something which we can provide an initial minimum or maximum value for and (2) know that a MAXIMIZE and MINIMIZE are not being combined. SO, we have a datastructure which we annotate with all sorts of things, incrementally updating it as we generate loop body code, and then use a wrapper and internal macros to do the coding when the loop has been constructed. |# (defstruct (loop-minimax #+ecls (:type vector) (:constructor make-loop-minimax-internal) #+nil (:copier nil) #+nil (:predicate nil)) answer-variable type temp-variable flag-variable operations infinity-data) (defvar *loop-minimax-type-infinities-alist* ;; This is the sort of value this should take on for a Lisp that has ;; "eminently usable" infinities. n.b. there are neither constants nor ;; printed representations for infinities defined by CL. ;; This grotesque read-from-string below is to help implementations ;; which croak on the infinity character when it appears in a token, even ;; conditionalized out. ; #+Genera ; '#.(read-from-string ; "((fixnum most-positive-fixnum most-negative-fixnum) ; (short-float +1s -1s) ; (single-float +1f -1f) ; (double-float +1d -1d) ; (long-float +1l -1l))") ;;This is how the alist should look for a lisp that has no infinities. In ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. #+(or CLOE-Runtime Minima) '((fixnum most-positive-fixnum most-negative-fixnum) (short-float most-positive-short-float most-negative-short-float) (single-float most-positive-single-float most-negative-single-float) (double-float most-positive-double-float most-negative-double-float) (long-float most-positive-long-float most-negative-long-float)) ;; CMUCL has infinities so let's use them. #+CMU '((fixnum most-positive-fixnum most-negative-fixnum) (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity) (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity) (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity) (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity)) ;; If we don't know, then we cannot provide "infinite" initial values for any of the ;; types but FIXNUM: #-(or Genera CLOE-Runtime Minima CMU) '((fixnum most-positive-fixnum most-negative-fixnum)) ) (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type :temp-variable (loop-gentemp 'loop-maxmin-temp-) :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) :operations nil :infinity-data infinity-data))) (defun loop-note-minimax-operation (operation minimax) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) operation) (defmacro with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) (which (car (loop-minimax-operations lm))) (infinity-data (loop-minimax-infinity-data lm)) (answer-var (loop-minimax-answer-variable lm)) (temp-var (loop-minimax-temp-variable lm)) (flag-var (loop-minimax-flag-variable lm)) (type (loop-minimax-type lm))) (if flag-var `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) (declare (type ,type ,answer-var ,temp-var)) ,@body) `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) (,temp-var ,init)) (declare (type ,type ,answer-var ,temp-var)) ,@body)))) (defmacro loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) (temp-var (loop-minimax-temp-variable lm)) (flag-var (loop-minimax-flag-variable lm)) (test (hide-variable-reference t (loop-minimax-answer-variable lm) `(,(ecase operation (min '<) (max '>)) ,temp-var ,answer-var)))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) (setq ,@(and flag-var `(,flag-var t)) ,answer-var ,temp-var))))) ;;;; Loop Keyword Tables #| LOOP keyword tables are hash tables string keys and a test of EQUAL. The actual descriptive/dispatch structure used by LOOP is called a "loop universe" contains a few tables and parameterizations. The basic idea is that we can provide a non-extensible ANSI-compatible loop environment, an extensible ANSI-superset loop environment, and (for such environments as CLOE) one which is "sufficiently close" to the old Genera-vintage LOOP for use by old user programs without requiring all of the old LOOP code to be loaded. |# ;;;; Token Hackery ;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, ;;; the second a symbol to check against. (defun loop-tequal (x1 x2) (and (symbolp x1) (string= x1 x2))) (defun loop-tassoc (kwd alist) (and (symbolp kwd) (assoc kwd alist :test #'string=))) (defun loop-tmember (kwd list) (and (symbolp kwd) (member kwd list :test #'string=))) (defun loop-lookup-keyword (loop-token table) (and (symbolp loop-token) (values (gethash (symbol-name loop-token) table)))) (defmacro loop-store-table-data (symbol table datum) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) (defstruct (loop-universe #+ecls (:type vector) #-ecls (:print-function print-loop-universe) #+nil (:copier nil) #+nil (:predicate nil)) keywords ;hash table, value = (fn-name . extra-data). iteration-keywords ;hash table, value = (fn-name . extra-data). for-keywords ;hash table, value = (fn-name . extra-data). path-keywords ;hash table, value = (fn-name . extra-data). type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. ansi ;NIL, T, or :EXTENDED. implicit-for-required ;see loop-hack-iteration ) #-ecls (defun print-loop-universe (u stream level) (declare (ignore level)) (let ((str (case (loop-universe-ansi u) ((nil) "Non-ANSI") ((t) "ANSI") (:extended "Extended-ANSI") (t (loop-universe-ansi u))))) ;;Cloe could be done with the above except for bootstrap lossage... #+CLOE (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u)) #+Genera ; This is reallly the ANSI definition. (print-unreadable-object (u stream :type t :identity t) (princ str stream)) #-(or Genera CLOE) (format stream "#<~S ~A>" (type-of u) str) )) ;;;This is the "current" loop context in use when we are expanding a ;;;loop. It gets bound on each invocation of LOOP. (defvar *loop-universe*) (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords type-keywords type-symbols ansi) #-(and CLOE Source-Bootstrap ecls) (check-type ansi (member nil t :extended)) (flet ((maketable (entries) (let* ((size (length entries)) (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) ht))) (make-loop-universe :keywords (maketable keywords) :for-keywords (maketable for-keywords) :iteration-keywords (maketable iteration-keywords) :path-keywords (maketable path-keywords) :ansi ansi :implicit-for-required (not (null ansi)) :type-keywords (maketable type-keywords) :type-symbols (let* ((size (length type-symbols)) (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) (dolist (x type-symbols) (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) ht)))) ;;;; Setq Hackery (defvar *loop-destructuring-hooks* nil "If not NIL, this must be a list of two things: a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq (list (car frobs) (if (null (cddr frobs)) (cadr frobs) `(prog1 ,(cadr frobs) ,(loop-make-psetq (cddr frobs)))))))) (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) nil (cons (if *loop-destructuring-hooks* (cadr *loop-destructuring-hooks*) 'loop-really-desetq) var-val-pairs))) (defvar *loop-desetq-temporary* (make-symbol "LOOP-DESETQ-TEMP")) (defmacro loop-really-desetq (&environment env &rest var-val-pairs) (labels ((find-non-null (var) ;; see if there's any non-null thing here ;; recurse if the list element is itself a list (do ((tail var)) ((not (consp tail)) tail) (when (find-non-null (pop tail)) (return t)))) (loop-desetq-internal (var val &optional temp) ;; returns a list of actions to be performed (typecase var (null (when (consp val) ;; don't lose possible side-effects (if (eq (car val) 'prog1) ;; these can come from psetq or desetq below. ;; throw away the value, keep the side-effects. ;;Special case is for handling an expanded POP. (mapcan #'(lambda (x) (and (consp x) (or (not (eq (car x) 'car)) (not (symbolp (cadr x))) (not (symbolp (setq x (macroexpand x env))))) (cons x nil))) (cdr val)) `(,val)))) (cons (let* ((car (car var)) (cdr (cdr var)) (car-non-null (find-non-null car)) (cdr-non-null (find-non-null cdr))) (when (or car-non-null cdr-non-null) (if cdr-non-null (let* ((temp-p temp) (temp (or temp *loop-desetq-temporary*)) (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal car `(prog1 (car ,temp) (setq ,temp (cdr ,temp)))) ,@(loop-desetq-internal cdr temp temp)) #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp)) (setq ,temp (cdr ,temp)) ,@(loop-desetq-internal cdr temp temp)))) (if temp-p `(,@(unless (eq temp val) `((setq ,temp ,val))) ,@body) `((let ((,temp ,val)) ,@body)))) ;; no cdring to do (loop-desetq-internal car `(car ,val) temp))))) (otherwise (unless (eq var val) `((setq ,var ,val))))))) (do ((actions)) ((null var-val-pairs) (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) (setq actions (nreconc;revappend (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) actions))))) ;;;; LOOP-local variables ;;;This is the "current" pointer into the LOOP source code. (defvar *loop-source-code*) ;;;This is the pointer to the original, for things like NAMED that ;;;insist on being in a particular position (defvar *loop-original-source-code*) ;;;This is *loop-source-code* as of the "last" clause. It is used ;;;primarily for generating error messages (see loop-error, loop-warn). (defvar *loop-source-context*) ;;;List of names for the LOOP, supplied by the NAMED clause. (defvar *loop-names*) ;;;The macroexpansion environment given to the macro. (defvar *loop-macro-environment*) ;;;This holds variable names specified with the USING clause. ;;; See LOOP-NAMED-VARIABLE. (defvar *loop-named-variables*) ;;; LETlist-like list being accumulated for one group of parallel bindings. (defvar *loop-variables*) ;;;List of declarations being accumulated in parallel with ;;;*loop-variables*. (defvar *loop-declarations*) ;;;Used by LOOP for destructuring binding, if it is doing that itself. ;;; See loop-make-variable. (defvar *loop-desetq-crocks*) ;;; List of wrapping forms, innermost first, which go immediately inside ;;; the current set of parallel bindings being accumulated in ;;; *loop-variables*. The wrappers are appended onto a body. E.g., ;;; this list could conceivably has as its value ((with-open-file (g0001 ;;; g0002 ...))), with g0002 being one of the bindings in ;;; *loop-variables* (this is why the wrappers go inside of the variable ;;; bindings). (defvar *loop-wrappers*) ;;;This accumulates lists of previous values of *loop-variables* and the ;;;other lists above, for each new nesting of bindings. See ;;;loop-bind-block. (defvar *loop-bind-stack*) ;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause ;;;which inhibits LOOP from actually outputting a type declaration for ;;;an iteration (or any) variable. (defvar *loop-nodeclare*) ;;;This is simply a list of LOOP iteration variables, used for checking ;;;for duplications. (defvar *loop-iteration-variables*) ;;;List of prologue forms of the loop, accumulated in reverse order. (defvar *loop-prologue*) (defvar *loop-before-loop*) (defvar *loop-body*) (defvar *loop-after-body*) ;;;This is T if we have emitted any body code, so that iteration driving ;;;clauses can be disallowed. This is not strictly the same as ;;;checking *loop-body*, because we permit some clauses such as RETURN ;;;to not be considered "real" body (so as to permit the user to "code" ;;;an abnormal return value "in loop"). (defvar *loop-emitted-body*) ;;;List of epilogue forms (supplied by FINALLY generally), accumulated ;;; in reverse order. (defvar *loop-epilogue*) ;;;List of epilogue forms which are supplied after the above "user" ;;;epilogue. "normal" termination return values are provide by putting ;;;the return form in here. Normally this is done using ;;;loop-emit-final-value, q.v. (defvar *loop-after-epilogue*) ;;;The "culprit" responsible for supplying a final value from the loop. ;;;This is so loop-emit-final-value can moan about multiple return ;;;values being supplied. (defvar *loop-final-value-culprit*) ;;;If not NIL, we are in some branch of a conditional. Some clauses may ;;;be disallowed. (defvar *loop-inside-conditional*) ;;;If not NIL, this is a temporary bound around the loop for holding the ;;;temporary value for "it" in things like "when (f) collect it". It ;;;may be used as a supertemporary by some other things. (defvar *loop-when-it-variable*) ;;;Sometimes we decide we need to fold together parts of the loop, but ;;;some part of the generated iteration code is different for the first ;;;and remaining iterations. This variable will be the temporary which ;;;is the flag used in the loop to tell whether we are in the first or ;;;remaining iterations. (defvar *loop-never-stepped-variable*) ;;;List of all the value-accumulation descriptor structures in the loop. ;;; See loop-get-collection-info. (defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) ;;;Flag indicating value accumulation without into (defvar *loop-collection-no-into*) ;;;; Code Analysis Stuff (defun loop-constant-fold-if-possible (form &optional expected-type) #+Genera (declare (values new-form constantp constant-value)) (let ((new-form form) (constantp nil) (constant-value nil)) #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* :repeat t :do-macro-expansion t :do-named-constants t :do-inline-forms t :do-optimizers t :do-constant-folding t :do-function-args t) constantp (constantp new-form *loop-macro-environment*) constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) #-Genera (when (setq constantp (constantp new-form)) (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (typep constant-value expected-type) (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." form constant-value expected-type) (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) (defun loop-constantp (form) #+Genera (constantp form *loop-macro-environment*) #-Genera (constantp form)) ;;;; LOOP Iteration Optimization (defvar *loop-duplicate-code* nil) (defvar *loop-iteration-flag-variable* (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) (multiple-value-bind (speed space) (loop-optimization-quantities env) (+ 40 (* (- speed space) 10)))) (defmacro loop-body (&environment env prologue before-loop main-body after-loop epilogue &aux rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: (when (equal before-loop after-loop) (setq main-body (append before-loop main-body) before-loop nil after-loop nil));accelerator (setq rbefore (reverse before-loop) rafter (reverse after-loop)) (labels ((psimp (l) (let ((ans nil)) (dolist (x l) (when x (push x ans) (when (and (consp x) (member (car x) '(go return return-from))) (return nil)))) (nreverse ans))) (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) (makebody () (let ((form `(tagbody ,@(psimp (append prologue (nreverse rbefore))) next-loop ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) end-loop ,@(psimp epilogue)))) (if flagvar `(let ((,flagvar nil)) ,form) form)))) (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test generated ;; plus once more for the forms that don't need a flag test (do ((threshold (loop-code-duplication-threshold env))) (nil) (declare (fixnum threshold)) ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent ;; forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) ;; The first forms in rbefore & rafter (which are the chronologically ;; last forms in the list) differ, therefore they cannot be moved ;; into the main body. If everything that chronologically precedes ;; them either differs or is equal but is okay to duplicate, we can ;; just put all of rbefore in the prologue and all of rafter after ;; the body. Otherwise, there is something that is not okay to ;; duplicate, so it and everything chronologically after it in ;; rbefore and rafter must go into the body, with a flag test to ;; distinguish the first time around the loop from later times. ;; What chronologically precedes the non-duplicatable form will ;; be handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) ((null bb) (return-from loop-body (makebody))) ;Did it. (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) ((or (not (setq inc (estimate-code-size (car bb) env))) (> (incf count inc) threshold)) ;; Ok, we have found a non-duplicatable piece of code. Everything ;; chronologically after it must be in the central body. ;; Everything chronologically at and after lastdiff goes into the ;; central body under a flag test. (let ((then nil) (else nil)) (do () (nil) (push (pop rbefore) else) (push (pop rafter) then) (when (eq rbefore (cdr lastdiff)) (return))) (unless flagvar (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) main-body)) ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) ;; is the same in rbefore and rafter so just copy it into the body (do () (nil) (pop rafter) (push (pop rbefore) main-body) (when (eq rbefore (cdr bb)) (return))) (return))))))) (defun duplicatable-code-p (expr env) (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) ;; Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of ;; optimize quantities back to help quantify how much code we are willing to ;; duplicate. ans))) (defvar *special-code-sizes* '((return 0) (progn 0) (null 1) (not 1) (eq 1) (car 1) (cdr 1) (when 1) (unless 1) (if 1) (caar 2) (cadr 2) (cdar 2) (cddr 2) (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) (defvar *estimate-code-size-punt* '(block do do* dolist flet labels lambda let let* locally macrolet multiple-value-bind prog prog* symbol-macrolet tagbody unwind-protect with-open-file)) (defun destructuring-size (x) (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) ((atom x) (+ n (if (null x) 0 1))))) (defun estimate-code-size (x env) (catch 'estimate-code-size (estimate-code-size-1 x env))) (defun estimate-code-size-1 (x env) (flet ((list-size (l) (let ((n 0)) (declare (fixnum n)) (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) ;; ???? (declare (function list-size (list) fixnum)) (cond ((constantp x #+Genera env) 1) ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) 1))) ((atom x) 1) ;??? self-evaluating??? ((symbolp (car x)) (let ((fn (car x)) (tem nil) (n 0)) (declare (symbol fn) (fixnum n)) (macrolet ((f (overhead &optional (args nil args-p)) `(the fixnum (+ (the fixnum ,overhead) (the fixnum (list-size ,(if args-p args '(cdr x)))))))) (cond ((setq tem (get fn 'estimate-code-size)) (typecase tem (fixnum (f tem)) (t (funcall tem x env)))) ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) #+Genera ((eq fn 'compiler:invisible-references) (list-size (cddr x))) ((eq fn 'cond) (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) ((eq fn 'desetq) (do ((l (cdr x) (cdr l))) ((null l) n) (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) ((member fn '(setq psetq)) (do ((l (cdr x) (cdr l))) ((null l) n) (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) ((eq fn 'go) 1) ((eq fn 'function) ;;This skirts the issue of implementationally-defined lambda macros ;; by recognizing CL function names and nothing else. (if (or (symbolp (cadr x)) (and (consp (cadr x)) (eq (caadr x) 'setf))) 1 (throw 'duplicatable-code-p nil))) ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) (throw 'estimate-code-size nil)) (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) (f 3)))))))) (t (throw 'estimate-code-size nil))))) ;;;; Loop Errors (defun loop-context () (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) ((eq l (cdr *loop-source-code*)) (nreverse new)))) (defun loop-error (format-string &rest format-args) #+(or Genera CLOE) (declare (dbg:error-reporter)) #+Genera (setq format-args (copy-list format-args)) ;Don't ask. (error 'program-error :format-control "~?~%Current LOOP context:~{ ~S~}." :format-arguments (list format-string format-args (loop-context)))) (defun loop-warn (format-string &rest format-args) (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) (defun loop-check-data-type (specified-type required-type &optional (default-type required-type)) (if (null specified-type) default-type (multiple-value-bind (a b) (subtypep specified-type required-type) (cond ((not b) (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." specified-type required-type)) ((not a) (loop-error "Specified data type ~S is not a subtype of ~S." specified-type required-type))) specified-type))) ;;;INTERFACE: Traditional, ANSI, Lucid. (defmacro loop-finish () "Causes the iteration to terminate \"normally\", the same as implicit termination by an iteration driving clause, or by use of WHILE or UNTIL -- the epilogue code (if any) will be run, and any implicitly collected result will be returned as the value of the LOOP." '(go end-loop)) (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) (*loop-source-context* nil) (*loop-iteration-variables* nil) (*loop-variables* nil) (*loop-nodeclare* nil) (*loop-named-variables* nil) (*loop-declarations* nil) (*loop-desetq-crocks* nil) (*loop-bind-stack* nil) (*loop-prologue* nil) (*loop-wrappers* nil) (*loop-before-loop* nil) (*loop-body* nil) (*loop-emitted-body* nil) (*loop-after-body* nil) (*loop-epilogue* nil) (*loop-after-epilogue* nil) (*loop-final-value-culprit* nil) (*loop-inside-conditional* nil) (*loop-when-it-variable* nil) (*loop-never-stepped-variable* nil) (*loop-names* nil) (*loop-collection-no-into* nil) (*loop-collection-cruft* nil)) (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body ,(nreverse *loop-prologue*) ,(nreverse *loop-before-loop*) ,(nreverse *loop-body*) ,(nreverse *loop-after-body*) ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) ; (do () (nil) ; (setq answer `(block ,(pop *loop-names*) ,answer)) ; (unless *loop-names* (return nil))) ; (setq answer `(block ,(car *loop-names*) ,answer)) (dolist (entry *loop-bind-stack*) (let ((vars (first entry)) (dcls (second entry)) (crocks (third entry)) (wrappers (fourth entry))) (dolist (w wrappers) (setq answer (append w (list answer)))) (when (or vars dcls crocks) (let ((forms (list answer))) ;;(when crocks (push crocks forms)) (when dcls (push `(declare ,@dcls) forms)) (setq answer `(,(cond ((not vars) 'locally) (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) (t 'let)) ,vars ,@(if crocks `((destructuring-bind ,@crocks ,@forms)) forms))))))) (setq answer `(block ,(car *loop-names*) ,answer)) answer))) (defun loop-iteration-driver () (do () ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) (loop-error "~S found where LOOP keyword expected." keyword)) (t (setq *loop-source-context* *loop-source-code*) (loop-pop-source) (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) (apply (symbol-function (first tem)) (rest tem))) ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) (loop-hack-iteration tem)) ((loop-tmember keyword '(and else)) ;; Alternative is to ignore it, ie let it go around to the next keyword... (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." keyword (car *loop-source-code*) (cadr *loop-source-code*))) (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) (defun loop-pop-source () (if *loop-source-code* (pop *loop-source-code*) (loop-error "LOOP source code ran out when another token was expected."))) (defun loop-get-progn () (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) (nextform (car *loop-source-code*) (car *loop-source-code*))) ((atom nextform) (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) (defun loop-get-form () (if *loop-source-code* (loop-pop-source) (loop-error "LOOP code ran out where a form was expected."))) (defun loop-construct-return (form) `(return-from ,(car *loop-names*) ,form)) (defun loop-pseudo-body (form) (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) (setq *loop-emitted-body* t) (loop-pseudo-body form)) (defun loop-emit-final-value (form) (push (loop-construct-return form) *loop-after-epilogue*) (when *loop-final-value-culprit* (if *loop-collection-no-into* (error 'program-error :format-control "LOOP clause is providing a value for the iteration,~@ however one was already established by a ~S clause." :format-arguments (list *loop-final-value-culprit*)) (loop-warn "LOOP clause is providing a value for the iteration,~@ however one was already established by a ~S clause." *loop-final-value-culprit*))) (setq *loop-final-value-culprit* (car *loop-source-context*))) (defun loop-disallow-conditional (&optional kwd) #+(or Genera CLOE) (declare (dbg:error-reporter)) (when *loop-inside-conditional* (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) ;;;; Loop Types (defun loop-typed-init (data-type) (when (and data-type (subtypep data-type 'number)) (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) (coerce 0 data-type) 0))) (defun loop-optional-type (&optional variable) ;;No variable specified implies that no destructuring is permissible. (and *loop-source-code* ;Don't get confused by NILs... (let ((z (car *loop-source-code*))) (cond ((loop-tequal z 'of-type) ;;This is the syntactically unambigous form in that the form of the ;; type specifier does not matter. Also, it is assumed that the ;; type specifier is unambiguously, and without need of translation, ;; a common lisp type specifier or pattern (matching the variable) thereof. (loop-pop-source) (loop-pop-source)) ((symbolp z) ;;This is the (sort of) "old" syntax, even though we didn't used to support all of ;; these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) (when type-spec (loop-pop-source) type-spec))) (t ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, ;; so we will be compulsive (should we really be?) and require that we in fact be ;; doing variable destructuring here. We must translate the old keyword pattern typespec ;; into a fully-specified pattern of real type specifiers here. (if (consp variable) (unless (consp z) (loop-error "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." z)) (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) (loop-pop-source) (labels ((translate (k v) (cond ((null k) nil) ((atom k) (replicate (or (gethash k (loop-universe-type-symbols *loop-universe*)) (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) (loop-error "Destructuring type pattern ~S contains unrecognized type keyword ~S." z k)) v)) ((atom v) (loop-error "Destructuring type pattern ~S doesn't match variable pattern ~S." z variable)) (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) (replicate (typ v) (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) (translate z variable))))))) ;;;; Loop Variables (defun loop-bind-block () (when (or *loop-variables* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) *loop-bind-stack*) (setq *loop-variables* nil *loop-declarations* nil *loop-desetq-crocks* nil *loop-wrappers* nil))) (defun loop-make-variable (name initialization dtype &optional iteration-variable-p) (cond ((null name) (cond ((not (null initialization)) (push (list (setq name (loop-gentemp 'loop-ignore-)) initialization) *loop-variables*) (push `(ignore ,name) *loop-declarations*)))) ((atom name) (cond (iteration-variable-p (if (member name *loop-iteration-variables*) (loop-error "Duplicated LOOP iteration variable ~S." name) (push name *loop-iteration-variables*))) ((assoc name *loop-variables*) (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) (unless (symbolp name) (loop-error "Bad variable ~S somewhere in LOOP." name)) (loop-declare-variable name dtype) ;; We use ASSOC on this list to check for duplications (above), ;; so don't optimize out this list: (push (list name (or initialization (loop-typed-init dtype))) *loop-variables*)) (initialization (cond (*loop-destructuring-hooks* (loop-declare-variable name dtype) (push (list name initialization) *loop-variables*)) (t (let ((newvar (loop-gentemp 'loop-destructure-))) (push (list newvar initialization) *loop-variables*) ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. (setq *loop-desetq-crocks* (list* name newvar *loop-desetq-crocks*)) #+ignore (loop-make-variable name nil dtype iteration-variable-p))))) (t (let ((tcar nil) (tcdr nil)) (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype))) (loop-make-variable (car name) nil tcar iteration-variable-p) (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) name) (defun loop-make-iteration-variable (name initialization dtype) (loop-make-variable name initialization dtype t)) (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) (let ((dtype #-cmu dtype #+cmu (let ((init (loop-typed-init dtype))) (if (typep init dtype) dtype `(or (member ,init) ,dtype))))) (push `(type ,dtype ,name) *loop-declarations*)))) ((consp name) (cond ((consp dtype) (loop-declare-variable (car name) (car dtype)) (loop-declare-variable (cdr name) (cdr dtype))) (t (loop-declare-variable (car name) dtype) (loop-declare-variable (cdr name) dtype)))) (t (error "Invalid LOOP variable passed in: ~S." name)))) (defun loop-maybe-bind-form (form data-type) (if (loop-constantp form) form (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) (defun loop-do-if (for negatep) (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil)) (flet ((get-clause (for) (do ((body nil)) (nil) (let ((key (car *loop-source-code*)) (*loop-body* nil) data) (cond ((not (symbolp key)) (loop-error "~S found where keyword expected getting LOOP clause after ~S." key for)) (t (setq *loop-source-context* *loop-source-code*) (loop-pop-source) (when (loop-tequal (car *loop-source-code*) 'it) (setq *loop-source-code* (cons (or it-p (setq it-p (loop-when-it-variable))) (cdr *loop-source-code*)))) (cond ((or (not (setq data (loop-lookup-keyword key (loop-universe-keywords *loop-universe*)))) (progn (apply (symbol-function (car data)) (cdr data)) (null *loop-body*))) (loop-error "~S does not introduce a LOOP clause that can follow ~S." key for)) (t (setq body (nreconc *loop-body* body))))))) (if (loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) (let ((then (get-clause for)) (else (when (loop-tequal (car *loop-source-code*) :else) (loop-pop-source) (list (get-clause :else))))) (when (loop-tequal (car *loop-source-code*) :end) (loop-pop-source)) (when it-p (setq form `(setq ,it-p ,form))) (loop-pseudo-body `(if ,(if negatep `(not ,form) form) ,then ,@else)))))) (defun loop-do-initially () (loop-disallow-conditional :initially) (push (loop-get-progn) *loop-prologue*)) (defun loop-do-finally () (loop-disallow-conditional :finally) (push (loop-get-progn) *loop-epilogue*)) (defun loop-do-do () (loop-emit-body (loop-get-progn))) (defun loop-do-named () (let ((name (loop-pop-source))) (unless (symbolp name) (loop-error "~S is an invalid name for your LOOP." name)) (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) (loop-error "The NAMED ~S clause occurs too late." name)) (when *loop-names* (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." (car *loop-names*) name)) (setq *loop-names* (list name nil)))) (defun loop-do-return () (loop-pseudo-body (loop-construct-return (loop-get-form)))) ;;;; Value Accumulation: List (defstruct (loop-collector #+ecls (:type vector) #+nil (:copier nil) #+nil (:predicate nil)) name class (history nil) (tempvars nil) dtype (data nil)) ;collector-specific data (defun loop-get-collection-info (collector class default-type) (unless (loop-tequal (car *loop-source-code*)'into) (setq *loop-collection-no-into* t)) (let ((form (loop-get-form)) (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) (name (when (loop-tequal (car *loop-source-code*) 'into) (loop-pop-source) (loop-pop-source)))) (when (not (symbolp name)) (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (the symbol name) *loop-collection-cruft* :key #'loop-collector-name))) (cond ((not cruft) (push (setq cruft (make-loop-collector :name name :class class :history (list collector) :dtype dtype)) *loop-collection-cruft*)) (t (unless (eq (loop-collector-class cruft) class) (loop-error "Incompatible kinds of LOOP value accumulation specified for collecting~@ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." name (car (loop-collector-history cruft)) collector)) (unless (equal dtype (loop-collector-dtype cruft)) (loop-warn "Unequal datatypes specified in different LOOP value accumulations~@ into ~S: ~S and ~S." name dtype (loop-collector-dtype cruft)) (when (eq (loop-collector-dtype cruft) t) (setf (loop-collector-dtype cruft) dtype))) (push collector (loop-collector-history cruft)))) (values cruft form)))) (defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) (setq tempvars (list* (loop-gentemp 'loop-list-head-) (loop-gentemp 'loop-list-tail-) (and (loop-collector-name lc) (list (loop-collector-name lc)))))) (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) (unless (loop-collector-name lc) (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) (ecase specifically (list (setq form `(list ,form))) (nconc nil) (append (unless (and (consp form) (eq (car form) 'list)) (setq form `(loop-copylist* ,form))))) (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) ;;;; Value Accumulation: max, min, sum, count. (defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT (multiple-value-bind (lc form) (loop-get-collection-info specifically 'sum default-type) (loop-check-data-type (loop-collector-dtype lc) required-type) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars (setf (loop-collector-tempvars lc) (setq tempvars (list (loop-make-variable (or (loop-collector-name lc) (loop-gentemp 'loop-sum-)) nil (loop-collector-dtype lc))))) (unless (loop-collector-name lc) (loop-emit-final-value (car (loop-collector-tempvars lc))))) (loop-emit-body (if (eq specifically 'count) `(when ,form (setq ,(car tempvars) ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) `(setq ,(car tempvars) (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) ,form))))))) (defun loop-maxmin-collection (specifically) (multiple-value-bind (lc form) (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) (let ((data (loop-collector-data lc))) (unless data (setf (loop-collector-data lc) (setq data (make-loop-minimax (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) (loop-collector-dtype lc)))) (unless (loop-collector-name lc) (loop-emit-final-value (loop-minimax-answer-variable data)))) (loop-note-minimax-operation specifically data) (push `(with-minimax-value ,data) *loop-wrappers*) (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) ))) ;;;; Value Accumulation: Aggregate Booleans ;;;ALWAYS and NEVER. ;;; Under ANSI these are not permitted to appear under conditionalization. (defun loop-do-always (restrictive negate) (let ((form (loop-get-form))) (when restrictive (loop-disallow-conditional)) (loop-emit-body `(,(if negate 'when 'unless) ,form ,(loop-construct-return nil))) (loop-emit-final-value t))) ;;;THERIS. ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) (when restrictive (loop-disallow-conditional)) (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) ,(loop-construct-return *loop-when-it-variable*))) (loop-emit-final-value nil)) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) (loop-disallow-conditional kwd) (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) (defun loop-do-with () (loop-disallow-conditional :with) (do ((var) (val) (dtype)) (nil) (setq var (loop-pop-source) dtype (loop-optional-type var) val (cond ((loop-tequal (car *loop-source-code*) :=) (loop-pop-source) (loop-get-form)) (t nil))) (loop-make-variable var val dtype) (if (loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (return (loop-bind-block))))) ;;;; The iteration driver (defun loop-hack-iteration (entry) (flet ((make-endtest (list-of-forms) (cond ((null list-of-forms) nil) ((member t list-of-forms) '(go end-loop)) (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) (car list-of-forms) (cons 'or list-of-forms)) (go end-loop)))))) (do ((pre-step-tests nil) (steps nil) (post-step-tests nil) (pseudo-steps nil) (pre-loop-pre-step-tests nil) (pre-loop-steps nil) (pre-loop-post-step-tests nil) (pre-loop-pseudo-steps nil) (tem) (data)) (nil) ;; Note we collect endtests in reverse order, but steps in correct ;; order. MAKE-ENDTEST does the nreverse for us. (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) (and (car tem) (push (car tem) pre-step-tests)) (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (when *loop-emitted-body* (loop-error "Iteration in LOOP follows body code.")) (unless tem (setq tem data)) (when (car tem) (push (car tem) pre-loop-pre-step-tests)) (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) (unless (loop-tequal (car *loop-source-code*) :and) (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) (make-endtest pre-loop-post-step-tests) (loop-make-psetq pre-loop-steps) (make-endtest pre-loop-pre-step-tests) *loop-before-loop*) *loop-after-body* (list* (loop-make-desetq pseudo-steps) (make-endtest post-step-tests) (loop-make-psetq steps) (make-endtest pre-step-tests) *loop-after-body*)) (loop-bind-block) (return nil)) (loop-pop-source) ; flush the "AND" (when (and (not (loop-universe-implicit-for-required *loop-universe*)) (setq tem (loop-lookup-keyword (car *loop-source-code*) (loop-universe-iteration-keywords *loop-universe*)))) ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. (loop-pop-source) (setq entry tem))))) ;;;; Main Iteration Drivers ;FOR variable keyword ..args.. (defun loop-do-for () (let* ((var (loop-pop-source)) (data-type (loop-optional-type var)) (keyword (loop-pop-source)) (first-arg nil) (tem nil)) (setq first-arg (loop-get-form)) (unless (and (symbolp keyword) (setq tem (loop-lookup-keyword keyword (loop-universe-for-keywords *loop-universe*)))) (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) (apply (car tem) var first-arg data-type (cdr tem)))) (defun loop-do-repeat () (let ((form (loop-get-form)) (type (loop-check-data-type (loop-optional-type) *loop-real-data-type*))) (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type)) (setq type (second form))) (multiple-value-bind (number constantp value) (loop-constant-fold-if-possible form type) (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ())) (t (let ((var (loop-make-variable (loop-gentemp 'loop-repeat-) number type))) (if constantp `((not (plusp (setq ,var (1- ,var)))) () () () () () () ()) `((minusp (setq ,var (1- ,var))) () () ())))))))) (defun loop-when-it-variable () (or *loop-when-it-variable* (setq *loop-when-it-variable* (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) ;;;; Various FOR/AS Subdispatches ;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN ;;; is omitted (other than being more stringent in its placement), and like ;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first ;;; initialization occurs in the loop body (first-step), not in the variable binding ;;; phase. (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) ;;Then we are the same as "FOR x FIRST y THEN z". (loop-pop-source) `(() (,var ,(loop-get-form)) () () () (,var ,val) () ())) (t ;;We are the same as "FOR x = y". `(() (,var ,val) () ())))) (defun loop-for-across (var val data-type) (loop-make-iteration-variable var nil data-type) (let ((vector-var (loop-gentemp 'loop-across-vector-)) (index-var (loop-gentemp 'loop-across-index-))) (multiple-value-bind (vector-form constantp vector-value) (loop-constant-fold-if-possible val 'vector) (loop-make-variable vector-var vector-form (if (and (consp vector-form) (eq (car vector-form) 'the)) (cadr vector-form) 'vector)) #+Genera (push `(system:array-register ,vector-var) *loop-declarations*) (loop-make-variable index-var 0 'fixnum) (let* ((length 0) (length-form (cond ((not constantp) (let ((v (loop-gentemp 'loop-across-limit-))) (push `(setq ,v (length ,vector-var)) *loop-prologue*) (loop-make-variable v 0 'fixnum))) (t (setq length (length vector-value))))) (first-test `(>= ,index-var ,length-form)) (other-test first-test) (step `(,var (aref ,vector-var ,index-var))) (pstep `(,index-var (1+ ,index-var)))) (declare (fixnum length)) (when constantp (setq first-test (= length 0)) (when (<= length 1) (setq other-test t))) `(,other-test ,step () ,pstep ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) ;;;; List Iteration (defun loop-list-step (listvar) ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used ;; as the stepping function. ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not ;; recognizing FOO may defeat some LOOP optimizations. (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) (loop-pop-source) (loop-get-form)) (t '(function cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") (values `(funcall ,stepper ,listvar) nil)) ((and (consp stepper) (eq (car stepper) 'function)) (values (list (cadr stepper) listvar) (cadr stepper))) (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) ,listvar) nil))))) (defun loop-for-on (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list) (loop-make-iteration-variable var nil data-type))) (multiple-value-bind (list-step step-function) (loop-list-step listvar) (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) ;; The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. (let* ((first-endtest (hide-variable-reference (eq var listvar) listvar ;; the following should use `atom' instead of `endp', per ;; [bug2428] `(atom ,listvar))) (other-endtest first-endtest)) (when (and constantp (listp list-value)) (setq first-endtest (null list-value))) (cond ((eq var listvar) ;;Contour of the loop is different because we use the user's variable... `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest () () () ,first-endtest ())) #+LOOP-Prefer-POP ((and step-function (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) (cdddr . 3) (cddddr . 4)))))) (and n (do ((l var (cdr l)) (i 0 (1+ i))) ((atom l) (and (null l) (= i n))) (declare (fixnum i)))))) (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) `(,other-endtest () () ,step ,first-endtest () () ,step))) (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) `(,other-endtest ,step () ,pseudo ,@(and (not (eq first-endtest other-endtest)) `(,first-endtest ,step () ,pseudo))))))))))) (defun loop-for-in (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar (loop-gentemp 'loop-list-))) (loop-make-iteration-variable var nil data-type) (loop-make-variable listvar list 'list) (multiple-value-bind (list-step step-function) (loop-list-step listvar) #-LOOP-Prefer-POP (declare (ignore step-function)) (let* ((first-endtest `(endp ,listvar)) (other-endtest first-endtest) (step `(,var (car ,listvar))) (pseudo-step `(,listvar ,list-step))) (when (and constantp (listp list-value)) (setq first-endtest (null list-value))) #+LOOP-Prefer-POP (when (eq step-function 'cdr) (setq step `(,var (pop ,listvar)) pseudo-step nil)) `(,other-endtest ,step () ,pseudo-step ,@(and (not (eq first-endtest other-endtest)) `(,first-endtest ,step () ,pseudo-step)))))))) ;;;; Iteration Paths (defstruct (loop-path #+ecls (:type vector) #+nil (:copier nil) #+nil (:predicate nil)) names preposition-groups inclusive-permitted function user-data) (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) (unless (listp names) (setq names (list names))) ;; Can't do this due to CLOS bootstrapping problems. #-(or Genera (and CLOE Source-Bootstrap) ecls) (check-type universe loop-universe) (let ((ht (loop-universe-path-keywords universe)) (lp (make-loop-path :names (mapcar #'symbol-name names) :function function :user-data user-data :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) lp)) ;;; Note: path functions are allowed to use loop-make-variable, hack ;;; the prologue, etc. (defun loop-for-being (var val data-type) ;; FOR var BEING each/the pathname prep-phrases using-stuff... ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. (let ((path nil) (data nil) (inclusive nil) (stuff nil) (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) ((loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (setq inclusive t) (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." (car *loop-source-code*))) (loop-pop-source) (setq path (loop-pop-source)) (setq initial-prepositions `((:in ,val)))) (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) (cond ((not (symbolp path)) (loop-error "~S found where a LOOP iteration path name was expected." path)) ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) (loop-error "~S is not the name of a LOOP iteration path." path)) ((and inclusive (not (loop-path-inclusive-permitted data))) (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) (preps (nconc initial-prepositions (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive (apply fun var data-type preps :inclusive t user-data) (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user ;; and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) (loop-make-iteration-variable x nil nil) (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) ;;;INTERFACE: Lucid, exported. ;;; i.e., this is part of our extended ansi-loop interface. (defun named-variable (name) (let ((tem (loop-tassoc name *loop-named-variables*))) (declare (list tem)) (cond ((null tem) (values (loop-gentemp) nil)) (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) (prepositional-phrases initial-phrases) (this-group nil nil) (this-prep nil nil) (disallowed-prepositions (mapcan #'(lambda (x) (loop-copylist* (find (car x) preposition-groups :test #'in-group-p))) initial-phrases)) (used-prepositions (mapcar #'car initial-phrases))) ((null *loop-source-code*) (nreverse prepositional-phrases)) (declare (symbol this-prep)) (setq token (car *loop-source-code*)) (dolist (group preposition-groups) (when (setq this-prep (in-group-p token group)) (return (setq this-group group)))) (cond (this-group (when (member this-prep disallowed-prepositions) (loop-error (if (member this-prep used-prepositions) "A ~S prepositional phrase occurs multiply for some LOOP clause." "Preposition ~S used when some other preposition has subsumed it.") token)) (setq used-prepositions (if (listp this-group) (append this-group used-prepositions) (cons this-group used-prepositions))) (loop-pop-source) (push (list this-prep (loop-get-form)) prepositional-phrases)) ((and USING-allowed (loop-tequal token 'using)) (loop-pop-source) (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) (when (or (atom z) (atom (cdr z)) (not (null (cddr z))) (not (symbolp (car z))) (and (cadr z) (not (symbolp (cadr z))))) (loop-error "~S bad variable pair in path USING phrase." z)) (when (cadr z) (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) (loop-error "The variable substitution for ~S occurs twice in a USING phrase,~@ with ~S and ~S." (car z) (cadr z) (cadr tem)) (push (cons (car z) (cadr z)) *loop-named-variables*))) (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) (return nil)))) (t (return (nreverse prepositional-phrases))))))) ;;;; Master Sequencer Function (defun loop-sequencer (indexv indexv-type indexv-user-specified-p variable variable-type sequence-variable sequence-type step-hack default-top prep-phrases) (let ((endform nil) ;Form (constant or variable) with limit value. (sequencep nil) ;T if sequence arg has been provided. (testfn nil) ;endtest function (test nil) ;endtest form. (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. (stepby-constantp t) (step nil) ;step form. (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. (inclusive-iteration nil) ;T if include last index. (start-given nil) ;T when prep phrase has specified start (start-value nil) (start-constantp nil) (limit-given nil) ;T when prep phrase has specified end (limit-constantp nil) (limit-value nil) ) (when variable (loop-make-iteration-variable variable nil variable-type)) (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) (setq prep (caar l) form (cadar l)) (case prep ((:of :in) (setq sequencep t) (loop-make-variable sequence-variable form sequence-type)) ((:from :downfrom :upfrom) (setq start-given t) (cond ((eq prep :downfrom) (setq dir ':down)) ((eq prep :upfrom) (setq dir ':up))) (multiple-value-setq (form start-constantp start-value) (loop-constant-fold-if-possible form indexv-type)) (loop-make-iteration-variable indexv form indexv-type)) ((:upto :to :downto :above :below) (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) ((loop-tequal prep :to) (setq inclusive-iteration t)) ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) ((loop-tequal prep :above) (setq dir ':down)) ((loop-tequal prep :below) (setq dir ':up))) (setq limit-given t) (multiple-value-setq (form limit-constantp limit-value) (loop-constant-fold-if-possible form indexv-type)) (setq endform (if limit-constantp `',limit-value (loop-make-variable (loop-gentemp 'loop-limit-) form indexv-type)))) (:by (multiple-value-setq (form stepby-constantp stepby) (loop-constant-fold-if-possible form indexv-type)) (unless stepby-constantp (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) (t (loop-error "~S invalid preposition in sequencing or sequence path.~@ Invalid prepositions specified in iteration path descriptor or something?" prep))) (when (and odir dir (not (eq dir odir))) (loop-error "Conflicting stepping directions in LOOP sequencing path")) (setq odir dir)) (when (and sequence-variable (not sequencep)) (loop-error "Missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. (unless start-given (loop-make-iteration-variable indexv (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) indexv-type)) (cond ((member dir '(nil :up)) (when (or limit-given default-top) (unless limit-given (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) nil indexv-type) (push `(setq ,endform ,default-top) *loop-prologue*)) (setq testfn (if inclusive-iteration '> '>=))) (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) (t (unless start-given (unless default-top (loop-error "Don't know where to start stepping.")) (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) (when (and default-top (not endform)) (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) (when endform (setq testfn (if inclusive-iteration '< '<=))) (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) (when step-hack (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) (let ((first-test test) (remaining-tests test)) (when (and stepby-constantp start-constantp limit-constantp) (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) (setq remaining-tests t))) `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack () () ,first-test ,step-hack)))) ;;;; Interfaces to the Master Sequencer (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer var (loop-check-data-type data-type *loop-real-data-type*) t nil nil nil nil nil nil (loop-collect-prepositional-phrases '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) nil (list (list kwd val))))) (defun loop-sequence-elements-path (variable data-type prep-phrases &key fetch-function size-function sequence-type element-type) (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) (let ((sequencev (named-variable 'sequence))) #+Genera (when (and sequencev (symbolp sequencev) sequence-type (subtypep sequence-type 'vector) (not (member (the symbol sequencev) *loop-nodeclare*))) (push `(sys:array-register ,sequencev) *loop-declarations*)) (list* nil nil ; dummy bindings and prologue (loop-sequencer indexv 'fixnum indexv-user-specified-p variable (or data-type element-type) sequencev sequence-type `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) prep-phrases))))) ;;;; Builtin LOOP Iteration Paths #|| (loop for v being the hash-values of ht do (print v)) (loop for k being the hash-keys of ht do (print k)) (loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) (loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) ||# (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) (check-type which (member hash-key hash-value)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error "Too many prepositions!")) ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) (let ((ht-var (loop-gentemp 'loop-hashtab-)) (next-fn (loop-gentemp 'loop-hashtab-next-)) (dummy-predicate-var nil) (post-steps nil)) (multiple-value-bind (other-var other-p) (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) ;; named-variable returns a second value of T if the name was actually ;; specified, so clever code can throw away the gensym'ed up variable if ;; it isn't really needed. ;;The following is for those implementations in which we cannot put dummy NILs ;; into multiple-value-setq variable lists. #-Genera (setq other-p t dummy-predicate-var (loop-when-it-variable)) (let ((key-var nil) (val-var nil) (bindings `((,variable nil ,data-type) (,ht-var ,(cadar prep-phrases)) ,@(and other-p other-var `((,other-var nil)))))) (if (eq which 'hash-key) (setq key-var variable val-var (and other-p other-var)) (setq key-var (and other-p other-var) val-var variable)) (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (consp key-var) (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) ,@post-steps)) (push `(,key-var nil) bindings)) (when (consp val-var) (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) ,@post-steps)) (push `(,val-var nil) bindings)) `(,bindings ;bindings () ;prologue () ;pre-test () ;parallel steps (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn))) ;post-test ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error "Too many prepositions!")) ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path."))) (unless (symbolp variable) (loop-error "Destructuring is not valid for package symbol iteration.")) (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) (next-fn (loop-gentemp 'loop-pkgsym-next-))) (push `(lisp::with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases))) () () () (not (multiple-value-setq (,(progn ;; If an implementation can get away without actually ;; using a variable here, so much the better. #+Genera NIL #-Genera (loop-when-it-variable)) ,variable) (,next-fn))) ()))) ;;;; ANSI Loop (defun make-ansi-loop-universe (extended-p) (let ((w (make-standard-loop-universe :keywords `((named (loop-do-named)) (initially (loop-do-initially)) (finally (loop-do-finally)) (do (loop-do-do)) (doing (loop-do-do)) (return (loop-do-return)) (collect (loop-list-collection list)) (collecting (loop-list-collection list)) (append (loop-list-collection append)) (appending (loop-list-collection append)) (nconc (loop-list-collection nconc)) (nconcing (loop-list-collection nconc)) (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) (counting (loop-sum-collection count ,*loop-real-data-type* fixnum)) (sum (loop-sum-collection sum number number)) (summing (loop-sum-collection sum number number)) (maximize (loop-maxmin-collection max)) (minimize (loop-maxmin-collection min)) (maximizing (loop-maxmin-collection max)) (minimizing (loop-maxmin-collection min)) (always (loop-do-always t nil)) ; Normal, do always (never (loop-do-always t t)) ; Negate the test on always. (thereis (loop-do-thereis t)) (while (loop-do-while nil :while)) ; Normal, do while (until (loop-do-while t :until)) ; Negate the test on while (when (loop-do-if when nil)) ; Normal, do when (if (loop-do-if if nil)) ; synonymous (unless (loop-do-if unless t)) ; Negate the test on when (with (loop-do-with))) :for-keywords '((= (loop-ansi-for-equals)) (across (loop-for-across)) (in (loop-for-in)) (on (loop-for-on)) (from (loop-for-arithmetic :from)) (downfrom (loop-for-arithmetic :downfrom)) (upfrom (loop-for-arithmetic :upfrom)) (below (loop-for-arithmetic :below)) (above (loop-for-arithmetic :above)) (by (loop-for-arithmetic :by)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) (as (loop-do-for)) (repeat (loop-do-repeat))) :type-symbols '(array atom bignum bit bit-vector character compiled-function complex cons double-float fixnum float function hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string base-char symbol t vector) :type-keywords nil :ansi (if extended-p :extended t)))) (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:which hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:which hash-value)) (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:internal :external :inherited))) (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:external))) (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil :user-data '(:symbol-types (:internal))) w)) (defparameter *loop-ansi-universe* (make-ansi-loop-universe nil)) (defun loop-standard-expansion (keywords-and-forms environment universe) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) (let ((tag (gensym))) `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) ;;;INTERFACE: ANSI (defmacro loop (&environment env &rest keywords-and-forms) #+Genera (declare (compiler:do-not-record-macroexpansions) (zwei:indentation . zwei:indent-loop)) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) #+allegro (defun excl::complex-loop-expander (body env) (loop-standard-expansion body env *loop-ansi-universe*)) gcl-2.6.14/lsp/gcl_iolib.lsp0000755000175000017500000005063014360276512014243 0ustar cammcamm;; -*-Lisp-*- ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; iolib.lsp ;;;; ;;;; The IO library. (in-package :si) (defun concatenated-stream-streams (stream) (declare (optimize (safety 2))) (check-type stream concatenated-stream) (c-stream-object0 stream)) (defun broadcast-stream-streams (stream) (declare (optimize (safety 2))) (check-type stream broadcast-stream) (c-stream-object0 stream)) (defun two-way-stream-input-stream (stream) (declare (optimize (safety 2))) (check-type stream two-way-stream) (c-stream-object0 stream)) (defun echo-stream-input-stream (stream) (declare (optimize (safety 2))) (check-type stream echo-stream) (c-stream-object0 stream)) (defun two-way-stream-output-stream (stream) (declare (optimize (safety 2))) (check-type stream two-way-stream) (c-stream-object1 stream)) (defun echo-stream-output-stream (stream) (declare (optimize (safety 2))) (check-type stream echo-stream) (c-stream-object1 stream)) (defun synonym-stream-symbol (stream) (declare (optimize (safety 2))) (check-type stream synonym-stream) (c-stream-object0 stream)) (defun maybe-clear-input (&optional (x *standard-input*)) (typecase x (synonym-stream (maybe-clear-input (symbol-value (synonym-stream-symbol x)))) (two-way-stream (maybe-clear-input (two-way-stream-input-stream x))) (stream (when (terminal-input-stream-p x) (clear-input t))))) (defmacro with-open-stream ((var stream) . body) (declare (optimize (safety 1))) (multiple-value-bind (ds b) (find-declarations body) `(let ((,var ,stream)) ,@ds (unwind-protect (progn ,@b) (close ,var))))) (defun make-string-input-stream (string &optional (start 0) end) (declare (optimize (safety 1))) (check-type string string) (check-type start seqind) (check-type end (or null seqind)) (let ((l (- (or end (length string)) start))) (make-string-input-stream-int (make-array l :element-type (array-element-type string) :displaced-to string :displaced-index-offset start :fill-pointer 0) 0 l))) (defun get-string-input-stream-index (stream &aux (s (c-stream-object0 stream))) (+ (fill-pointer s) (multiple-value-bind (a b) (array-displacement s) (declare (ignore a)) b))) (defmacro with-input-from-string ((var string &key index (start 0) end) . body) (declare (optimize (safety 1))) (multiple-value-bind (ds b) (find-declarations body) `(let ((,var (make-string-input-stream ,string ,start ,end))) ,@ds (unwind-protect (multiple-value-prog1 (progn ,@b) ,@(when index `((setf ,index (get-string-input-stream-index ,var))))) (close ,var))))) (defmacro with-output-to-string ((var &optional string &key element-type) . body) (declare (optimize (safety 1))) (let ((s (sgen "STRING"))) (multiple-value-bind (ds b) (find-declarations body) `(let* ((,s ,string) (,var (if ,s (make-string-output-stream-from-string ,s) (make-string-output-stream :element-type ,element-type)))) ,@ds (unwind-protect (block nil (multiple-value-prog1 (progn ,@b) (unless ,s (return (get-output-stream-string ,var))))) (close ,var)))))) (defun read-from-string (string &optional (eof-error-p t) eof-value &key (start 0) end preserve-whitespace) (declare (optimize (safety 1))) (check-type string string) (check-type start seqind) (check-type end (or null seqind)) (let ((stream (make-string-input-stream string start (or end (length string))))) (values (if preserve-whitespace (read-preserving-whitespace stream eof-error-p eof-value) (read stream eof-error-p eof-value)) (get-string-input-stream-index stream)))) ;; (defun write (x &key stream ;; (array *print-array*) ;; (base *print-base*) ;; (case *print-case*) ;; (circle *print-circle*) ;; (escape *print-escape*) ;; (gensym *print-gensym*) ;; (length *print-length*) ;; (level *print-level*) ;; (lines *print-lines*) ;; (miser-width *print-miser-width*) ;; (pprint-dispatch *print-pprint-dispatch*) ;; (pretty *print-pretty*) ;; (radix *print-radix*) ;; (readably *print-readably*) ;; (right-margin *print-right-margin*)) ;; (write-int x stream array base case circle escape gensym ;; length level lines miser-width pprint-dispatch ;; pretty radix readably right-margin)) (defun write-to-string (object &rest rest &key (escape *print-escape*)(radix *print-radix*)(base *print-base*) (circle *print-circle*)(pretty *print-pretty*)(level *print-level*) (length *print-length*)(case *print-case*)(gensym *print-gensym*) (array *print-array*)(lines *print-lines*)(miser-width *print-miser-width*) (pprint-dispatch *print-pprint-dispatch*)(readably *print-readably*) (right-margin *print-right-margin*) &aux (stream (make-string-output-stream)) (*print-escape* escape)(*print-radix* radix)(*print-base* base) (*print-circle* circle)(*print-pretty* pretty)(*print-level* level) (*print-length* length)(*print-case* case)(*print-gensym* gensym) (*print-array* array)(*print-lines* lines)(*print-miser-width* miser-width) (*print-pprint-dispatch* pprint-dispatch)(*print-readably* readably ) (*print-right-margin* right-margin)) (declare (optimize (safety 1))(dynamic-extent rest)) (apply #'write object :stream stream rest) (get-output-stream-string stream)) (defun prin1-to-string (object &aux (stream (make-string-output-stream))) (declare (optimize (safety 1))) (prin1 object stream) (get-output-stream-string stream)) (defun princ-to-string (object &aux (stream (make-string-output-stream))) (declare (optimize (safety 1))) (princ object stream) (get-output-stream-string stream)) ;; (defun file-string-length (ostream object) ;; (declare (optimize (safety 2))) ;; (let ((ostream (if (typep ostream 'broadcast-stream) ;; (car (last (broadcast-stream-streams ostream))) ;; ostream))) ;; (cond ((not ostream) 1) ;; ((subtypep1 (stream-element-type ostream) 'character) ;; (length (let ((*print-escape* nil)) (write-to-string object))))))) ;; (defmacro with-temp-file ((s pn) (tmp ext) &rest body) ;; (multiple-value-bind ;; (doc decls ctps body) ;; (parse-body-header body) ;; (declare (ignore doc)) ;; `(let* ((,s (temp-stream ,tmp ,ext)) ;; (,pn (stream-object1 ,s))) ;; ,@decls ;; ,@ctps ;; (unwind-protect (progn ,@body) (progn (close ,s) (delete-file ,s)))))) (defmacro with-open-file ((stream . filespec) . body) (declare (optimize (safety 1))) (multiple-value-bind (ds b) (find-declarations body) `(let ((,stream (open ,@filespec))) ,@ds (unwind-protect (progn ,@b) (when ,stream (close ,stream)))))) ;; (defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*)) ;; (declare (optimize (safety 2))) ;; (let ((fun (si:get-pprint-dispatch obj table))) ;; (if fun (values fun t) (values 'si:default-pprint-object nil)))) ;; (setq *print-pprint-dispatch* '(pprint-dispatch . nil)) ;; (defun set-pprint-dispatch (type-spec function &optional ;; (priority 0) ;; (table *print-pprint-dispatch*)) ;; (declare (optimize (safety 2))) ;; (unless (typep priority 'real) ;; (error 'type-error :datum priority :expected-type 'real)) ;; (let ((a (assoc type-spec (cdr table) :test 'equal))) ;; (if a (setf (cdr a) (list function priority)) ;; (rplacd (last table) `((,type-spec ,function ,priority))))) ;; nil) ;; (defun copy-pprint-dispatch (&optional table) ;; (declare (optimize (safety 2))) ;; (unless table ;; (setq table *print-pprint-dispatch*)) ;; (unless (and (eq (type-of table) 'cons) ;; (eq (car table) 'pprint-dispatch)) ;; (error 'type-error :datum table :expected-type 'pprint-dispatch)) ;; (copy-seq table )) (defun y-or-n-p (&optional string &rest args) (declare (optimize (safety 1))) (when string (format *query-io* "~&~? (Y or N) " string args)) (let ((reply (symbol-name (read *query-io*)))) (cond ((string-equal reply "Y") t) ((string-equal reply "N") nil) ((apply 'y-or-n-p string args))))) (defun yes-or-no-p (&optional string &rest args) (declare (optimize (safety 1))) (when string (format *query-io* "~&~? (Yes or No) " string args)) (let ((reply (symbol-name (read *query-io*)))) (cond ((string-equal reply "YES") t) ((string-equal reply "NO") nil) ((apply 'yes-or-no-p string args))))) (defun sharp-a-reader (stream subchar arg) (declare (ignore subchar)) (let ((initial-contents (read stream nil nil t))) (unless *read-suppress* (do ((i 0 (1+ i)) (d nil (cons (length ic) d)) (ic initial-contents (if (zerop (length ic)) ic (elt ic 0)))) ((>= i arg) (make-array (nreverse d) :initial-contents initial-contents)))))) (set-dispatch-macro-character #\# #\a 'sharp-a-reader) (set-dispatch-macro-character #\# #\a 'sharp-a-reader (standard-readtable)) (set-dispatch-macro-character #\# #\A 'sharp-a-reader) (set-dispatch-macro-character #\# #\A 'sharp-a-reader (standard-readtable)) ;; defined in defstruct.lsp (set-dispatch-macro-character #\# #\s 'sharp-s-reader) (set-dispatch-macro-character #\# #\s 'sharp-s-reader (standard-readtable)) (set-dispatch-macro-character #\# #\S 'sharp-s-reader) (set-dispatch-macro-character #\# #\S 'sharp-s-reader (standard-readtable)) (defvar *dribble-stream* nil) (defvar *dribble-io* nil) (defvar *dribble-namestring* nil) (defvar *dribble-saved-terminal-io* nil) (defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede)) (declare (optimize (safety 1))) (cond ((not psp) (when (null *dribble-stream*) (error "Not in dribble.")) (if (eq *dribble-io* *terminal-io*) (setq *terminal-io* *dribble-saved-terminal-io*) (warn "*TERMINAL-IO* was rebound while DRIBBLE is on.~%~ You may miss some dribble output.")) (close *dribble-stream*) (setq *dribble-stream* nil) (format t "~&Finished dribbling to ~A." *dribble-namestring*)) (*dribble-stream* (error "Already in dribble (to ~A)." *dribble-namestring*)) (t (let* ((namestring (namestring pathname)) (stream (open pathname :direction :output :if-exists f :if-does-not-exist :create))) (setq *dribble-namestring* namestring *dribble-stream* stream *dribble-saved-terminal-io* *terminal-io* *dribble-io* (make-two-way-stream (make-echo-stream *terminal-io* stream) (make-broadcast-stream *terminal-io* stream)) *terminal-io* *dribble-io*) (multiple-value-bind (sec min hour day month year) (get-decoded-time) (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)." namestring year month day hour min sec)))))) ;; (defmacro formatter ( control-string ) ;; (declare (optimize (safety 2))) ;; `(progn ;; (lambda (*standard-output* &rest arguments) ;; (let ((*format-unused-args* nil)) ;; (apply 'format t ,control-string arguments) ;; *format-unused-args*)))) (defun stream-external-format (s) (declare (optimize (safety 1))) (check-type s stream) :default) (defvar *print-lines* nil) (defvar *print-miser-width* nil) (defvar *print-pprint-dispatch* nil) (defvar *print-right-margin* nil) (defmacro with-standard-io-syntax (&body body) (declare (optimize (safety 1))) `(let* ((*package* (find-package :cl-user)) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-miser-width* nil) (*print-pprint-dispatch* *print-pprint-dispatch*);FIXME (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) (*print-right-margin* nil) (*read-base* 10) (*read-default-float-format* 'single-float) (*read-eval* t) (*read-suppress* nil) (*readtable* (copy-readtable (standard-readtable)))) ,@body)) ;; (defmacro print-unreadable-object ;; ((object stream &key type identity) &body body) ;; (declare (optimize (safety 2))) ;; (let ((q `(princ " " ,stream))) ;; `(if *print-readably* ;; (error 'print-not-readable :object ,object) ;; (progn ;; (princ "#<" ,stream) ;; ,@(when type `((prin1 (type-of ,object) ,stream) ,q)) ;; ,@body ;; ,@(when identity ;; (let ((z `(princ (address ,object) ,stream))) ;; (if (and (not body) type) (list z) (list q z)))) ;; (princ ">" ,stream) ;; nil)))) ;; (defmacro with-compile-file-syntax (&body body) ;; `(let ((*print-radix* nil) ;; (*print-base* 10) ;; (*print-circle* t) ;; (*print-pretty* nil) ;; (*print-level* nil) ;; (*print-length* nil) ;; (*print-case* :downcase) ;; (*print-gensym* t) ;; (*print-array* t) ;; (*print-package* t) ;; (*print-structure* t)) ;; ,@body)) (defmacro with-compilation-unit (opt &rest body) (declare (optimize (safety 1))) (declare (ignore opt)) `(progn ,@body)) (defconstant char-length 8) (defun get-byte-stream-nchars (s) (let* ((tp (stream-element-type s))) (values (ceiling (if (consp tp) (cadr tp) char-length) char-length)))) ;; (defun parse-integer (s &key start end (radix 10) junk-allowed) ;; (declare (optimize (safety 1))) ;; (parse-integer-int s start end radix junk-allowed)) (defun write-byte (j s &aux (i j)) (declare (optimize (safety 1))) (check-type j integer) (check-type s stream) (dotimes (k (get-byte-stream-nchars s) j) (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s) (setq i (ash i #.(- char-length))))) (defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)) (declare (optimize (safety 1))) (check-type s stream) (dotimes (k (get-byte-stream-nchars s) i) (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value))) (if (eq ch eof-value) (return ch) (char-code ch))) (* k char-length)))))) (defun read-sequence (seq strm &rest r &key (start 0) end &aux (l (listp seq))(seqp (when l (nthcdr start seq))) (cp (eq (stream-element-type strm) 'character))) (declare (optimize (safety 1))(dynamic-extent r)) (check-type seq sequence) (check-type strm stream) (check-type start (integer 0)) (check-type end (or null (integer 0))) (apply 'reduce (lambda (y x &aux (z (if cp (read-char strm nil 'eof) (read-byte strm nil 'eof)))) (declare (seqind y)(ignorable x)) (when (eq z 'eof) (return-from read-sequence y)) (if l (setf (car seqp) z seqp (cdr seqp)) (setf (aref seq y) z)) (1+ y)) seq :initial-value start r)) (defun write-sequence (seq strm &rest r &key (start 0) end &aux (cp (eq (stream-element-type strm) 'character))) (declare (optimize (safety 1))(dynamic-extent r)) (check-type seq sequence) (check-type strm stream) (check-type start (integer 0)) (check-type end (or null (integer 0))) (apply 'reduce (lambda (y x) (declare (seqind y)) (if cp (write-char x strm) (write-byte x strm)) (1+ y)) seq :initial-value start r) seq) (defun restrict-stream-element-type (tp) (cond ((or (member tp '(character :default)) (subtypep tp 'character)) 'character) ((subtypep tp 'integer) (let* ((ntp (car (expand-ranges (normalize-type tp)))) (min (or (cadr ntp) '*))(max (or (caddr ntp) '*)) (s (if (or (eq min '*) (< min 0)) 'signed-byte 'unsigned-byte)) (lim (unless (or (eq min '*) (eq max '*)) (max (integer-length min) (integer-length max)))) (lim (if (and lim (eq s 'signed-byte)) (1+ lim) lim))) (if lim `(,s ,lim) s))) ((check-type tp (member character integer))))) (defun open (f &key (direction :input) (element-type 'character) (if-exists nil iesp) (if-does-not-exist nil idnesp) (external-format :default) &aux (pf (pathname f))) (declare (optimize (safety 1))) (check-type f pathname-designator) (when (wild-pathname-p pf) (error 'file-error :pathname pf :format-control "Pathname is wild.")) (let* ((s (open-int (namestring (translate-logical-pathname pf)) direction (restrict-stream-element-type element-type) if-exists iesp if-does-not-exist idnesp external-format))) (when (typep s 'stream) (c-set-stream-object1 s pf) s))) (defun load-pathname-exists (z) (or (probe-file z) (when *allow-gzipped-file* (when (probe-file (string-concatenate (namestring z) ".gz")) z)))) (defun load-pathname (p print if-does-not-exist external-format &aux (pp (merge-pathnames p)) (epp (reduce (lambda (y x) (or y (load-pathname-exists (translate-pathname x "" p)))) '(#P".o" #P".lsp" #P".lisp" #P"") :initial-value nil)));FIXME newest? (if epp (let* ((*load-pathname* pp)(*load-truename* epp)) (with-open-file (s epp :external-format external-format) (if (member (peek-char nil s nil 'eof) '#.(mapcar 'code-char (list 127 #xcf #xce #x4c #x64))) (load-fasl s print) (let ((*standard-input* s)) (load-stream s print))))) (when if-does-not-exist (error 'file-error :pathname pp :format-control "File does not exist.")))) (defun load (p &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist :error) (external-format :default) &aux (*readtable* *readtable*)(*package* *package*)) (declare (optimize (safety 1))) (check-type p (or stream pathname-designator)) (when verbose (format t ";; Loading ~s~%" p)) (prog1 (typecase p (pathname-designator (load-pathname (pathname p) print if-does-not-exist external-format)) (stream (load-stream p print))) (when verbose (format t ";; Finished loading ~s~%" p)))) (defun ensure-directories-exist (ps &key verbose) (declare (optimize (safety 1))) (check-type ps pathname-designator) (when (wild-pathname-p ps) (error 'file-error :pathname ps :format-control "Pathname is wild")) (let ((pd (pathname-directory ps)) ls) (dotimes (i (length pd)) (let ((s (namestring (make-pathname :directory (if (zerop i) pd (ldiff pd (last pd i))))))) (if (eq (stat1 s) :directory) (return) (push s ls)))) (dolist (s ls) (mkdir s) (when verbose (format *standard-output* "Creating directory ~s~%" s))) (values ps (if ls t)))) (defun file-length (x) (declare (optimize (safety 1))) (check-type x (or broadcast-stream file-stream)) (if (typep x 'broadcast-stream) (let ((s (broadcast-stream-streams x))) (if s (file-length (car (last s))) 0)) (multiple-value-bind (tp sz) (stat x) (declare (ignore tp)) (values (truncate sz (get-byte-stream-nchars x)))))) (defun file-position (x &optional (pos :start pos-p)) (declare (optimize (safety 1))) (check-type x (or broadcast-stream file-stream string-stream)) (check-type pos (or (member :start :end) (integer 0))) (typecase x (broadcast-stream (let ((s (car (last (broadcast-stream-streams x))))) (if s (if pos-p (file-position s pos) (file-position s)) 0))) (string-stream (let* ((st (c-stream-object0 x))(l (length st))(d (array-dimension st 0)) (p (case pos (:start 0) (:end l) (otherwise pos)))) (if pos-p (when (<= p d) (setf (fill-pointer st) p)) l))) (otherwise (let ((n (get-byte-stream-nchars x)) (p (case pos (:start 0) (:end (file-length x)) (otherwise pos)))) (if pos-p (when (fseek x (* p n)) p) (/ (ftell x) n)))))) (defun file-string-length (strm obj) (let* ((pos (file-position strm)) (w (write obj :stream strm :escape nil :readably nil)) (pos1 (file-position strm)));(break) (declare (ignore w)) (file-position strm pos) (- pos1 pos))) gcl-2.6.14/lsp/fasd.lisp0000755000175000017500000001074014360276512013404 0ustar cammcamm(in-package 'si) (require "FASDMACROS" "../cmpnew/fasdmacros.lsp") ;; (test '(a (1)) 2 12.0) --> ((a (1)) 2 12.0) (defmacro dprint (x) `(if (and (boundp 'debug) debug) (format t "~%The value of ~a is ~s" ',x ,x))) (defun keep (x) (setq sil x)) (defun test (&rest l &aux tab) (with-open-file (st "/tmp/foo.l" :direction :output ) (let* ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq))))) (declare (special *fd*)) (si::find-sharing-top l tab) ; (preprocess l tab) (sloop::sloop for v in l do (write-fasd-top v fd) finally (close-fasd fd)))) (test-in)) (defun preprocess1(lis table) (cond ((symbolp lis) (and lis (let ((tem (gethash lis table))) (cond (tem (if (< (the fixnum tem) 0) (setf (gethash lis table) (the fixnum (+ (the fixnum tem) -1))))) (t (setf (gethash lis table) -1)))))) ((consp lis) (preprocess1 (car lis) table) (preprocess1 (cdr lis) table)) ((and (arrayp lis) (eq (array-element-type lis) t)) (sloop::sloop for i below (length lis) do (preprocess1 (aref (the (array t) lis) i) table))) ((and (arrayp lis) (eq (array-element-type lis) t)) (sloop::sloop for i below (length lis) do (preprocess1 (aref (the (array t) lis) i) table))) (t nil))) (defun preprocess (lis table &aux freq) (preprocess1 lis table) (sloop:sloop for (ke val) in-table table with m = 0 declare (fixnum m) do ;(print (list ke val)) (cond((> (the fixnum val) 0) (SETQ m (the fixnum (+ 1 m)))) ((< (the fixnum val) -1) (remhash ke table) (push (cons val ke) freq))) finally (sloop::loop-return (sort freq '> :key 'car )))) (defun test-in () (with-open-file (st "/tmp/foo.l" :direction :input) (let ((fdin (open-fasd st :input (setq eof '(nil)) (keep (make-array 10))))) (sloop while (not (eq eof (setq tem (read-fasd-top fdin)))) collect tem finally (dprint fdin) (close-fasd fdin))))) (defun try-write (file &aux (tab (make-hash-table :test 'eq)) (eof '(nil))) (with-open-file (st file) (with-open-file (st1 "/tmp/foo.l" :direction :output) (sloop while (not (eq eof (setq tem (read st nil eof)))) with fd collect (file-position st1) do(clrhash tab) (setq fd (open-fasd st1 :output nil tab)) ; (let ((prp (preprocess tem tab))) ; (dprint prp)) (write-fasd-top tem fd) (close-fasd fd) (dprint tab) )))) (defvar *differed* nil) (defun try-read (file pos &aux (tab (make-array 10)) (eof '(nil))) (with-open-file (st file) (with-open-file (st1 "/tmp/foo.l") (sloop while (not (eq eof (setq tem (read st nil eof)))) with fd with re for u in pos do (file-position st1 u) (setq fd (open-fasd st1 :input eof tab)) (sloop::sloop for i below (length tab) do (setf (aref (the (array (t)) tab) i) nil)) (setq re (read-fasd-top fd)) (dprint re) (unless (equalp tem re) (push (list tem re) *differed*)) ; (assert (eq eof (read-fasd-top fd))) (close-fasd fd))))) (defun try (file) (let ((pos (try-write file))) (try-read file pos) (print file) (system (format nil "cat ~a | wc ; cat /tmp/foo.l | wc " (namestring file))) )) (defvar *table* (make-hash-table :test 'eq)) (defun do-share (x) (si::find-sharing x *table*)) (defun read-data-file (file) (let ((pack-ops)) (set-dispatch-macro-character #\# #\! #'(lambda (st a b ) (setq pack-ops (read st nil nil) ))) (with-open-file (st file) (let ((tem (read st nil nil))) (list pack-ops tem))))) (defun write-out-data (lis fil) (with-open-file (st fil :direction :output) (let ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq))))) (find-sharing-top lis (fasd-table fd)) (write-fasd-top (car lis) fd) (write-fasd-top (second lis) fd) ; (close-fasd fd) fd))) ;; To convert an ascii .data file to a fasd one. ;(setq bil (si::read-data-file "vmlisp.data") her nil) ;(SI::WRITE-OUT-DATA1 (SECOND BIL) (FIRST BIL) "/tmp/foo.l") (defun write-out-data1 (data-vec pack-ops fil) (with-open-file (st fil :direction :output) (let ((compiler::*data* (list data-vec nil pack-ops)) (compiler::*compiler-output-data* st) (compiler::*fasd-data* (list (open-fasd st :output nil nil)))) (compiler::wt-fasd-data-file) (car compiler::*fasd-data*)))) ;(setq dirs (directory "/public/spad/libraries/A*/index.KAF*")) ;(mapcar 'try dirs) gcl-2.6.14/lsp/gcl_arraylib.lsp0000755000175000017500000002320514360276512014750 0ustar cammcamm;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; arraylib.lsp ;;;; ;;;; array routines (in-package :si) (proclaim '(optimize (safety 2) (space 3))) (defvar *baet-hash* (make-hash-table :test 'equal)) (defun best-array-element-type (type &aux (tps '(character bit signed-char unsigned-char signed-short unsigned-short fixnum short-float long-float t))) (if type (or (car (member type tps)) (gethash type *baet-hash*) (setf (gethash type *baet-hash*) (car (member type tps :test 'subtypep)))) t)) (defun upgraded-array-element-type (type &optional environment) (declare (ignore environment)) (best-array-element-type type)) ;(defun array-displacement (array) ; (let ((x (si:array-displacement1 array))) ; (values (car x) (cdr x))) ; ) (defun make-array (dimensions &key (element-type t) (initial-element nil) (initial-contents nil initial-contents-supplied-p) adjustable fill-pointer displaced-to (displaced-index-offset 0) static) (when (integerp dimensions) (setq dimensions (list dimensions))) (setq element-type (best-array-element-type element-type)) (cond ((= (length dimensions) 1) (let ((x (si:make-vector element-type (car dimensions) adjustable fill-pointer displaced-to displaced-index-offset static initial-element))) (when initial-contents-supplied-p (do ((n (car dimensions)) (lic (listp initial-contents) lic) (ic initial-contents (if lic (cdr ic) ic)) (i 0 (1+ i))) ((>= i n)) (declare (fixnum n i)) (si:aset x i (if lic (car ic) (aref ic i))))) x)) (t (let ((x (make-array1 (the fixnum(get-aelttype element-type)) static initial-element displaced-to (the fixnum displaced-index-offset) dimensions))) (if fill-pointer (error "fill pointer for 1 dimensional arrays only")) (unless (member 0 dimensions) (when initial-contents-supplied-p (do ((cursor (make-list (length dimensions) :initial-element 0))) (nil) (declare (:dynamic-extent cursor)) (aset-by-cursor x (sequence-cursor initial-contents cursor) cursor) (when (increment-cursor cursor dimensions) (return nil))))) x)))) (defun increment-cursor (cursor dimensions) (if (null cursor) t (let ((carry (increment-cursor (cdr cursor) (cdr dimensions)))) (if carry (cond ((>= (the fixnum (1+ (the fixnum (car cursor)))) (the fixnum (car dimensions))) (rplaca cursor 0) t) (t (rplaca cursor (the fixnum (1+ (the fixnum (car cursor))))) nil)) nil)))) (defun sequence-cursor (sequence cursor) (if (null cursor) sequence (sequence-cursor (elt sequence (the fixnum (car cursor))) (cdr cursor)))) (defun vector (&rest objects &aux (l (list (length objects)))) (declare (:dynamic-extent objects l)) (make-array l :element-type t :initial-contents objects)) (defun array-dimensions (array) (do ((i (array-rank array)) (d nil)) ((= i 0) d) (setq i (1- i)) (setq d (cons (array-dimension array i) d)))) (defun array-in-bounds-p (array &rest indices &aux (r (array-rank array))) (declare (:dynamic-extent indices)) (when (/= r (length indices)) (error "The rank of the array is ~R,~%~ ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~ supplied." r (length indices))) (do ((i 0 (1+ i)) (s indices (cdr s))) ((>= i r) t) (when (or (< (car s) 0) (>= (car s) (array-dimension array i))) (return nil)))) (defun array-row-major-index (array &rest indices) (declare (:dynamic-extent indices)) (do ((i 0 (1+ i)) (j 0 (+ (* j (array-dimension array i)) (car s))) (s indices (cdr s))) ((null s) j))) (defun bit (bit-array &rest indices) (declare (:dynamic-extent indices)) (apply #'aref bit-array indices)) (defun sbit (bit-array &rest indices) (declare (:dynamic-extent indices)) (apply #'aref bit-array indices)) (defun bit-and (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-and bit-array1 bit-array2 result-bit-array)) (defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-ior bit-array1 bit-array2 result-bit-array)) (defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-xor bit-array1 bit-array2 result-bit-array)) (defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array)) (defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-nand bit-array1 bit-array2 result-bit-array)) (defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-nor bit-array1 bit-array2 result-bit-array)) (defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array)) (defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array)) (defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array)) (defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) (bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array)) (defun bit-not (bit-array &optional result-bit-array) (bit-array-op boole-c1 bit-array bit-array result-bit-array)) (defun vector-push (new-element vector) (let ((fp (fill-pointer vector))) (declare (fixnum fp)) (cond ((< fp (the fixnum (array-dimension vector 0))) (si:aset vector fp new-element) (si:fill-pointer-set vector (the fixnum (1+ fp))) fp) (t nil)))) (defun vector-push-extend (new-element vector &optional extension) (let ((fp (fill-pointer vector))) (declare (fixnum fp)) (cond ((< fp (the fixnum (array-dimension vector 0))) (si:aset vector fp new-element) (si:fill-pointer-set vector (the fixnum (1+ fp))) fp) (t (adjust-array vector (list (+ (array-dimension vector 0) (or extension (if (> (array-dimension vector 0) 0) (array-dimension vector 0) 5)))) :element-type (array-element-type vector) :fill-pointer fp) (si:aset vector fp new-element) (si:fill-pointer-set vector (the fixnum (1+ fp))) fp)))) (defun vector-pop (vector) (let ((fp (fill-pointer vector))) (declare (fixnum fp)) (when (= fp 0) (error "The fill pointer of the vector ~S zero." vector)) (si:fill-pointer-set vector (the fixnum (1- fp))) (aref vector (the fixnum (1- fp))))) (defun maset (array x dim &optional (cx (cons x -1)) (cur (make-list (length dim) :initial-element 0)) (ind cur)) (declare (dynamic-extent cur)) (cond (dim (dotimes (i (pop dim)) (setf (car cur) i) (maset array x dim cx (cdr cur) ind))) ((incf (cdr cx)) (when (apply 'array-in-bounds-p array ind) (row-major-aset (apply 'aref array ind) (car cx) (cdr cx)))))) (defun adjust-array (array new-dimensions &key element-type initial-element (initial-contents nil initial-contents-supplied-p) fill-pointer displaced-to (displaced-index-offset 0) (static (staticp array)) &aux (fill-pointer (or fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array))))) (let ((x (if initial-contents-supplied-p (make-array new-dimensions :adjustable t :static static :element-type (array-element-type array) :fill-pointer fill-pointer :initial-contents initial-contents :displaced-to displaced-to :displaced-index-offset displaced-index-offset) (make-array new-dimensions :adjustable t :static static :element-type (array-element-type array) :fill-pointer fill-pointer :initial-element initial-element :displaced-to displaced-to :displaced-index-offset displaced-index-offset)))) (unless (or displaced-to initial-contents-supplied-p) (cond ((or (atom new-dimensions) (null (cdr new-dimensions)) (when (equal (cdr new-dimensions) (cdr (array-dimensions array))) (or (not (eq element-type 'bit)) (eql 0 (the fixnum (mod (the fixnum (car (last new-dimensions))) char-size)))))) (copy-array-portion array x 0 0 (min (array-total-size x) (array-total-size array)))) ((maset array x new-dimensions)))) (si:replace-array array x) (when fill-pointer (setf (fill-pointer array) (if (eq fill-pointer t) (array-total-size array) fill-pointer))) array)) gcl-2.6.14/lsp/gcl_sharp.lsp0000644000175000017500000000500214360276512014250 0ustar cammcamm(in-package :si) (defstruct context (vec (make-array 0 :adjustable t :fill-pointer t) :type (vector t)) (hash nil :type (or null hash-table)) (spice (make-hash-table :test 'eq :rehash-size 2.0) :type hash-table)) (defun get-context (i) (declare (fixnum i)) (when *sharp-eq-context* (let ((v (context-vec *sharp-eq-context*))) (if (< i (length v)) (aref v i) (let ((h (context-hash *sharp-eq-context*))) (when h (gethash1 i h))))))) (defun push-context (i) (declare (fixnum i)) (unless *sharp-eq-context* (setq *sharp-eq-context* (make-context))) (let* ((v (context-vec *sharp-eq-context*))(l (length v))(x (cons nil nil))) (cond ((< i l) (error "#~s= multiply defined" i)) ((= i l) (vector-push-extend x v (1+ l)) x) ((let ((h (context-hash *sharp-eq-context*))) (if h (when (gethash1 i h) (error "#~s= multiply defined" i)) (setf (context-hash *sharp-eq-context*) (setq h (make-hash-table :test 'eql :rehash-size 2.0)))) (setf (gethash i h) x)))))) (defconstant +nil-proxy+ (cons nil nil)) (defun sharp-eq-reader (stream subchar i &aux (x (push-context i))) (declare (ignore subchar)(fixnum i)) (let ((y (read stream t 'eof t))) (when (when y (eq y (cdr x))) (error "#= circularly defined")) (setf (car x) (or y +nil-proxy+)) y)) (defun sharp-sharp-reader (stream subchar i &aux (x (get-context i))) (declare (ignore stream subchar)(fixnum i)) (unless x (error "#~s# without preceding #~s=" i i)) (or (cdr x) (let ((s (alloc-spice))) (setf (gethash s (context-spice *sharp-eq-context*)) x (cdr x) s)))) (defun patch-sharp (x) (typecase x (cons (setf (car x) (patch-sharp (car x)) (cdr x) (patch-sharp (cdr x))) x) ((vector t) (dotimes (i (length x) x) (setf (aref x i) (patch-sharp (aref x i))))) ((array t) (dotimes (i (array-total-size x) x) (aset1 x i (patch-sharp (row-major-aref x i))))) (structure (let ((d (structure-def x))) (dotimes (i (structure-length x) x) (declare (fixnum i)) (structure-set x d i (patch-sharp (structure-ref x d i)))))) (spice (let* ((y (gethash1 x (context-spice *sharp-eq-context*))) (z (car y))) (unless y (error "Spice ~s not defined" x)) (unless (eq z +nil-proxy+) z))) (otherwise x))) (set-dispatch-macro-character #\# #\= #'sharp-eq-reader) (set-dispatch-macro-character #\# #\= #'sharp-eq-reader (standard-readtable)) (set-dispatch-macro-character #\# #\# #'sharp-sharp-reader) (set-dispatch-macro-character #\# #\# #'sharp-sharp-reader (standard-readtable)) gcl-2.6.14/lsp/gcl_littleXlsp.lsp0000755000175000017500000001465414360276512015317 0ustar cammcamm;;This file is included as a demonstration of how to link in low level ;;C code. It is also useful! [comments by wfs] ;;Author: Mark Ring (ring@cs.utexas.edu) ;; In the next comment we explain how to link in the file ;; and then a sample usage. #| If you have si::faslink you may use: (si::faslink "/public/gcl/lsp/littleXlsp.o" "/public/gcl/o/littleXwin.o -lX11 -lc") To avoid using faslink which is much less portable, when building the gcl image you may add EXTRAS=${ODIR}/littleXwin.o LIBS= -lX -lm -lg to the h/machine.defs, redo the add-defs machine, and remake so that the low level X code will be linked in. Then you may simply (load "/public/gcl/lsp/littleXlsp.o") ;;Now you may try the following examples: (setq W1 (open-window)) (setq W2 (open-window)) (resize-window w1 200 150) (resize-window w2 240 225) (set-background w1 "red") (clear-window w1) (set-foreground "blue") (draw-line w1 5 5 100 5) (draw-line w1 100 100 100 5) (draw-line w1 100 100 5 100) (dotimes (i 20) (draw-line w1 5 (* i 5) (* i 5) (* i 5))) (dotimes (i 20) (erase-line w1 (+ 7 (* i 5)) 10 (+ 7 (* i 5)) 95)) (use-font "fixed") (draw-text w1 "A Design" 10 112) (clear-text w1 "De" 22 112) (dotimes (i 25) (set-background w2 (format nil "#~2,'0X~2,'0X~2,'0X" (* i 10) (* i 10) (* i 10))) (clear-window w2)) (set-foreground "black") (dotimes (i 20) (draw-arc w2 5 100 100 (- 100 (* i 5)) 0 (* 360 64))) (dotimes (i 20) (draw-arc w2 5 (- 100 (* i 5)) 100 (* i 5) 0 (* 360 64))) (set-arc-mode 'pie) (dotimes (i 10) (fill-arc w2 115 5 100 100 (* i 64 36) (* 64 18))) (set-arc-mode 'chord) (dotimes (i 10) (fill-arc w2 115 105 100 100 (* i 64 36) (* 64 36 3))) (dotimes (i 5) (clear-arc w2 115 105 100 100 (* i 64 36 2) (* 64 36 2))) (use-font "-b&h-lucidabright-demibold-i-normal--18-180-75-75-p-107-iso8859-1") (draw-text w2 "A Bunch of Wierd Things" 2 220) (clear-window w1) (close-window w1) (close-window w2) |# ;;; Open a window. Return window ID as an Integer (defentry open-window () (int open_window)) ;;; Close given window. ;;; Parameter 1: Window ID. (defentry close-window (int) (int close_window)) ;;; Clear a window of its contents. ;;; Parameter 1: Window ID. (defentry clear-window (int) (int clear_window)) ;;; Draw a line in a window. ;;; Parameter 1: Window ID. ;;; Parameter 2: left-most x coordinate ;;; Parameter 3: top-most y coordinate ;;; Parameter 4: right-most x coordinate ;;; Parameter 5: bottom-most y coordinate (defentry draw-line (int int int int int) (int draw_line)) ;;; Erase a line from a window. ;;; Parameter 1: Window ID. ;;; Parameter 2: left-most x coordinate ;;; Parameter 3: top-most y coordinate ;;; Parameter 4: right-most x coordinate ;;; Parameter 5: bottom-most y coordinate (defentry erase-line (int int int int int) (int erase_line)) ;;; Draw an arc in a window. (See X Documentation). ;;; Parameter 1: Window ID. ;;; Parameter 2: left-most x coordinate ;;; Parameter 3: top-most y coordinate ;;; Parameter 4: width of square ;;; Parameter 5: height of square ;;; Parameter 6: starting position: angle 1 (from 3:00) ;;; Parameter 7: ending position: angle 2 (from angle 1) ;;; Angles are specified in 64ths of a degree and go counter-clockwise (defentry draw-arc (int int int int int int int) (int draw_arc)) ;;; Clear an arc from a window. (See X Documentation). ;;; Parameter 1: Window ID. ;;; Parameter 2: left-most x coordinate ;;; Parameter 3: top-most y coordinate ;;; Parameter 4: width of square ;;; Parameter 5: height of square ;;; Parameter 6: starting position: angle 1 (from 3:00) ;;; Parameter 7: ending position: angle 2 (from angle 1) ;;; Angles are specified in 64ths of a degree and go counter-clockwise (defentry clear-arc (int int int int int int int) (int clear_arc)) ;;; Draw a filled arc in a window. (See X Documentation). ;;; Parameter 1: Window ID. ;;; Parameter 2: left-most x coordinate ;;; Parameter 3: top-most y coordinate ;;; Parameter 4: width of square ;;; Parameter 5: height of square ;;; Parameter 6: starting position: angle 1 (from 3:00) ;;; Parameter 7: ending position: angle 2 (from angle 1) ;;; Angles are specified in 64ths of a degree and go counter-clockwise (defentry fill-arc (int int int int int int int) (int fill_arc)) ;;; Resize a window. ;;; Parameter 1: Window ID. ;;; Parameter 2: new width ;;; Parameter 3: new height (defentry resize-window (int int int) (int resize_window)) ;;; Raise a window to the front. ;;; Parameter 1: Window ID. (defentry raise-window (int) (int raise_window)) ;;; Draw Text in a window. ;;; Parameter 1: Window ID. ;;; Parameter 2: text string ;;; Parameter 3: left-most x coordinate ;;; Parameter 4: top-most y coordinate (defentry draw-text-2 (int object int int) (int draw_text)) (defun draw-text (window string x y) (draw-text-2 window (get-c-string string) x y)) ;;; Clear text from a window ;;; Parameter 1: Window ID ;;; Parameter 2: text string ;;; Parameter 3: left-most x coordinate ;;; Parameter 4: top-most y coordinate (defentry clear-text-2 (int object int int) (int erase_text)) (defun clear-text (window string x y) (clear-text-2 window (get-c-string string) x y)) ;;; Set arc-mode to be Pie or Chord ;;; Parameter 1: 'PIE or 'CHORD (defentry set-arc-mode-2 (int) (int set_arc_mode)) (defun set-arc-mode (pie-or-chord) (if (eq pie-or-chord 'pie) (set-arc-mode-2 1) (set-arc-mode-2 0))) ;;; Use a particular font in a given window ;;; Parameter 1: font name (defentry use-font-2 (object) (int use_font)) (defun use-font (string) (use-font-2 (get-c-string string))) ;;; Set background color of window ;;; Parameter 1: Window ID ;;; Parameter 2: color name (string) (defentry set-background-2 (int object) (int set_background)) (defun set-background (window string) (set-background-2 window (get-c-string string))) ;;; Set foreground color ;;; Parameter 1: color name (string) (defentry set-foreground-2 (object) (int set_foreground)) (defun set-foreground (string) (set-foreground-2 (get-c-string string))) ;;;---------------------------------------------------------------------- ;;; General routines. (defCfun "object get_c_string(s) object s;" 0 " return(s->st.st_self);" ) (defentry get_c_string_2 (object) (object get_c_string)) /* make sure string is null terminated */ (defun get-c-string (string) (get_c_string_2 (concatenate 'string string ""))) gcl-2.6.14/lsp/.gitignore0000644000175000017500000000003214360276512013554 0ustar cammcamm*.c *.h gcl_recompile.lsp gcl-2.6.14/lsp/gcl_gprof.lsp0000755000175000017500000001003614360276512014256 0ustar cammcamm(in-package 'si) ;; (load "gprof.o") ;; You must have a kcl image with profiling information and monstartup ;; typically saved_kcp. NOTE: if monstartup calls sbrk (true in ;; most 4.3bsd's except sun >= OS 4.0) you must be very careful to ;; allocate all the space you will use prior to calling monstartup. ;; If subsequent storage allocation causes the hole to move you will ;; most certainly lose. See below for instructions ;; on how to construct saved_kcp. ;; If you want function invocation counts to be kept do ;; (setq compiler::*cc* (concatentate 'string compiler::*cc* " -pg ")) ;; before compiling the relevant files. (This is done when you load ;; lsp/gprof.o) ;; In the image saved_kcp Load in your files. Load in gprof.o: (load ;; "lsp/gprof.o") Invoke monstartup once to setup buffers: (monstartup ;; lowpc highpc) eg. (monstartup #x800 3000000) [highpc should be a bit ;; bigger than the highest address you have seen when loading your files] ;; Use moncontrol to toggle profiling on and off: (moncontrol 0) to turn ;; profiling off, and (moncontrol 1) to turn it on. Use ;; (wrtie-gmons+syms) to terminate with writing a gmon.out and syms.out ;; in the current directory. I know of no way of clearing the buffers, ;; since secret routines set up the buffers, and we don't know where they ;; are or how large. Thus all information is cumulative. ;; % gprof syms.out ;; will display the output (add -b) to make it briefer. ;; A sample session on rascal: #| /usr2/skcl/unixport/saved_kcp GCL (Austin Kyoto Common Lisp) Version(1.147) Sun May 14 15:26:07 CDT 1989 Contains Enhancements by W. Schelter >(load "/tmp/fo") Loading /tmp/fo.o start address -T 1d04e0 Finished loading /tmp/fo.o 528 >(load "/usr2/skcl/lsp/gprof") Loading gprof.o Adding -pg to the *cc* commandstart address -T 1d0800 Finished loading gprof.o 2112 ;; NOTE: If the following calls sbrk [eg 4.3bsd or sun OS3 ] but not Sun OS4, ;; then you MUST make sure to allocate sufficient memory before doing ;; monstartup, so that the hole will not have to be moved. >(si::monstartup #x800 2000000) 2584576 >(si::goo)(si::goo) ;;defined in /tmp/foo.lisp NIL >NIL >(si::write-gmon+syms) writing syms.. 0 [NOTE: The safest way to exit the lisp is to stop it with Ctrl-Z and then kill it. We do NOT want to run the exit code which normally writes out a monitoring file]. rascal% gprof -b syms.out ... called/total parents index %time self descendents called+self name index called/total children 0.00 0.00 1/200 _call_or_link [8] 0.02 0.02 199/200 GOO [2] [1] 49.6 0.02 0.02 200 FOO [1] 0.02 0.00 200/203 _make_cons [4] ... Interpretation: Foo is called 199 times by (parent) goo and once by (parent) call_or_link (the setting up of the fast link). Foo itself calls (child) make_cons 200 of the 203 times that make_cons is called... Lower down we would see that goo is called twice. -- /tmp/fo.lisp -- (defun foo () (cons nil nil)) (defun goo () (sloop::sloop for i below 100 do (foo))) -- end of file -- |# ;; Creating saved_gcp ;; ;; cd gcl ;; make go ;; (cd unixport ; make gcp-sun) ;; (cd go ; ln -s ../o/makefile ../o/*.o ../o/*.c ../o/*.d ../o/*.ini .) ;; remove a few .o files and do ;; (cd go ; make "CFLAGS = -I../h -I../gcl-tk -pg -g -c") ;; then (cd unixport ; make kcp) (clines #-aix3 "#include \"gprof.hc\"" #+aix3 "#include \"aix_gprof.hc\"" ) (eval-when (load) (progn (setq compiler::*cc* (CONCATENATE 'string compiler::*cc* " -pg ")) (format t "~% Adding -pg to the *cc* command")) ) (defun write-gmon+syms() (monitor2 0 0 0 0) (princ "writing syms..") (set-up-combined) (write_outsyms) ) (defentry monstartup (int int) (int "mymonstartup")) (defentry monitor2 (int int int int) (int "mymonitor")) (defentry moncontrol (int) (int "moncontrol")) (defentry write_outsyms () (int "write_outsyms")) gcl-2.6.14/config.sub0000755000175000017500000010511614360276512012762 0ustar cammcamm#! /bin/sh # Configuration validation subroutine script. # Copyright 1992-2022 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale timestamp='2022-01-03' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # Please send patches to . # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # https://git.savannah.gnu.org/cgit/config.git/plain/config.sub # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. # The "shellcheck disable" line above the timestamp inhibits complaints # about features and limitations of the classic Bourne shell that were # superseded or lifted in POSIX. However, this script identifies a wide # variety of pre-POSIX systems that do not have POSIX shells at all, and # even some reasonably current systems (Solaris 10 as case-in-point) still # have a pre-POSIX /bin/sh. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS or ALIAS Canonicalize a configuration name. Options: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright 1992-2022 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; *local*) # First pass through any local machine types. echo "$1" exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Split fields of configuration type # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read field1 field2 field3 field4 <&2 exit 1 ;; *-*-*-*) basic_machine=$field1-$field2 basic_os=$field3-$field4 ;; *-*-*) # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two # parts maybe_os=$field2-$field3 case $maybe_os in nto-qnx* | linux-* | uclinux-uclibc* \ | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ | storm-chaos* | os2-emx* | rtmk-nova*) basic_machine=$field1 basic_os=$maybe_os ;; android-linux) basic_machine=$field1-unknown basic_os=linux-android ;; *) basic_machine=$field1-$field2 basic_os=$field3 ;; esac ;; *-*) # A lone config we happen to match not fitting any pattern case $field1-$field2 in decstation-3100) basic_machine=mips-dec basic_os= ;; *-*) # Second component is usually, but not always the OS case $field2 in # Prevent following clause from handling this valid os sun*os*) basic_machine=$field1 basic_os=$field2 ;; zephyr*) basic_machine=$field1-unknown basic_os=$field2 ;; # Manufacturers dec* | mips* | sequent* | encore* | pc533* | sgi* | sony* \ | att* | 7300* | 3300* | delta* | motorola* | sun[234]* \ | unicom* | ibm* | next | hp | isi* | apollo | altos* \ | convergent* | ncr* | news | 32* | 3600* | 3100* \ | hitachi* | c[123]* | convex* | sun | crds | omron* | dg \ | ultra | tti* | harris | dolphin | highlevel | gould \ | cbm | ns | masscomp | apple | axis | knuth | cray \ | microblaze* | sim | cisco \ | oki | wec | wrs | winbond) basic_machine=$field1-$field2 basic_os= ;; *) basic_machine=$field1 basic_os=$field2 ;; esac ;; esac ;; *) # Convert single-component short-hands not valid as part of # multi-component configurations. case $field1 in 386bsd) basic_machine=i386-pc basic_os=bsd ;; a29khif) basic_machine=a29k-amd basic_os=udi ;; adobe68k) basic_machine=m68010-adobe basic_os=scout ;; alliant) basic_machine=fx80-alliant basic_os= ;; altos | altos3068) basic_machine=m68k-altos basic_os= ;; am29k) basic_machine=a29k-none basic_os=bsd ;; amdahl) basic_machine=580-amdahl basic_os=sysv ;; amiga) basic_machine=m68k-unknown basic_os= ;; amigaos | amigados) basic_machine=m68k-unknown basic_os=amigaos ;; amigaunix | amix) basic_machine=m68k-unknown basic_os=sysv4 ;; apollo68) basic_machine=m68k-apollo basic_os=sysv ;; apollo68bsd) basic_machine=m68k-apollo basic_os=bsd ;; aros) basic_machine=i386-pc basic_os=aros ;; aux) basic_machine=m68k-apple basic_os=aux ;; balance) basic_machine=ns32k-sequent basic_os=dynix ;; blackfin) basic_machine=bfin-unknown basic_os=linux ;; cegcc) basic_machine=arm-unknown basic_os=cegcc ;; convex-c1) basic_machine=c1-convex basic_os=bsd ;; convex-c2) basic_machine=c2-convex basic_os=bsd ;; convex-c32) basic_machine=c32-convex basic_os=bsd ;; convex-c34) basic_machine=c34-convex basic_os=bsd ;; convex-c38) basic_machine=c38-convex basic_os=bsd ;; cray) basic_machine=j90-cray basic_os=unicos ;; crds | unos) basic_machine=m68k-crds basic_os= ;; da30) basic_machine=m68k-da30 basic_os= ;; decstation | pmax | pmin | dec3100 | decstatn) basic_machine=mips-dec basic_os= ;; delta88) basic_machine=m88k-motorola basic_os=sysv3 ;; dicos) basic_machine=i686-pc basic_os=dicos ;; djgpp) basic_machine=i586-pc basic_os=msdosdjgpp ;; ebmon29k) basic_machine=a29k-amd basic_os=ebmon ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson basic_os=ose ;; gmicro) basic_machine=tron-gmicro basic_os=sysv ;; go32) basic_machine=i386-pc basic_os=go32 ;; h8300hms) basic_machine=h8300-hitachi basic_os=hms ;; h8300xray) basic_machine=h8300-hitachi basic_os=xray ;; h8500hms) basic_machine=h8500-hitachi basic_os=hms ;; harris) basic_machine=m88k-harris basic_os=sysv3 ;; hp300 | hp300hpux) basic_machine=m68k-hp basic_os=hpux ;; hp300bsd) basic_machine=m68k-hp basic_os=bsd ;; hppaosf) basic_machine=hppa1.1-hp basic_os=osf ;; hppro) basic_machine=hppa1.1-hp basic_os=proelf ;; i386mach) basic_machine=i386-mach basic_os=mach ;; isi68 | isi) basic_machine=m68k-isi basic_os=sysv ;; m68knommu) basic_machine=m68k-unknown basic_os=linux ;; magnum | m3230) basic_machine=mips-mips basic_os=sysv ;; merlin) basic_machine=ns32k-utek basic_os=sysv ;; mingw64) basic_machine=x86_64-pc basic_os=mingw64 ;; mingw32) basic_machine=i686-pc basic_os=mingw32 ;; mingw32ce) basic_machine=arm-unknown basic_os=mingw32ce ;; monitor) basic_machine=m68k-rom68k basic_os=coff ;; morphos) basic_machine=powerpc-unknown basic_os=morphos ;; moxiebox) basic_machine=moxie-unknown basic_os=moxiebox ;; msdos) basic_machine=i386-pc basic_os=msdos ;; msys) basic_machine=i686-pc basic_os=msys ;; mvs) basic_machine=i370-ibm basic_os=mvs ;; nacl) basic_machine=le32-unknown basic_os=nacl ;; ncr3000) basic_machine=i486-ncr basic_os=sysv4 ;; netbsd386) basic_machine=i386-pc basic_os=netbsd ;; netwinder) basic_machine=armv4l-rebel basic_os=linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony basic_os=newsos ;; news1000) basic_machine=m68030-sony basic_os=newsos ;; necv70) basic_machine=v70-nec basic_os=sysv ;; nh3000) basic_machine=m68k-harris basic_os=cxux ;; nh[45]000) basic_machine=m88k-harris basic_os=cxux ;; nindy960) basic_machine=i960-intel basic_os=nindy ;; mon960) basic_machine=i960-intel basic_os=mon960 ;; nonstopux) basic_machine=mips-compaq basic_os=nonstopux ;; os400) basic_machine=powerpc-ibm basic_os=os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson basic_os=ose ;; os68k) basic_machine=m68k-none basic_os=os68k ;; paragon) basic_machine=i860-intel basic_os=osf ;; parisc) basic_machine=hppa-unknown basic_os=linux ;; psp) basic_machine=mipsallegrexel-sony basic_os=psp ;; pw32) basic_machine=i586-unknown basic_os=pw32 ;; rdos | rdos64) basic_machine=x86_64-pc basic_os=rdos ;; rdos32) basic_machine=i386-pc basic_os=rdos ;; rom68k) basic_machine=m68k-rom68k basic_os=coff ;; sa29200) basic_machine=a29k-amd basic_os=udi ;; sei) basic_machine=mips-sei basic_os=seiux ;; sequent) basic_machine=i386-sequent basic_os= ;; sps7) basic_machine=m68k-bull basic_os=sysv2 ;; st2000) basic_machine=m68k-tandem basic_os= ;; stratus) basic_machine=i860-stratus basic_os=sysv4 ;; sun2) basic_machine=m68000-sun basic_os= ;; sun2os3) basic_machine=m68000-sun basic_os=sunos3 ;; sun2os4) basic_machine=m68000-sun basic_os=sunos4 ;; sun3) basic_machine=m68k-sun basic_os= ;; sun3os3) basic_machine=m68k-sun basic_os=sunos3 ;; sun3os4) basic_machine=m68k-sun basic_os=sunos4 ;; sun4) basic_machine=sparc-sun basic_os= ;; sun4os3) basic_machine=sparc-sun basic_os=sunos3 ;; sun4os4) basic_machine=sparc-sun basic_os=sunos4 ;; sun4sol2) basic_machine=sparc-sun basic_os=solaris2 ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun basic_os= ;; sv1) basic_machine=sv1-cray basic_os=unicos ;; symmetry) basic_machine=i386-sequent basic_os=dynix ;; t3e) basic_machine=alphaev5-cray basic_os=unicos ;; t90) basic_machine=t90-cray basic_os=unicos ;; toad1) basic_machine=pdp10-xkl basic_os=tops20 ;; tpf) basic_machine=s390x-ibm basic_os=tpf ;; udi29k) basic_machine=a29k-amd basic_os=udi ;; ultra3) basic_machine=a29k-nyu basic_os=sym1 ;; v810 | necv810) basic_machine=v810-nec basic_os=none ;; vaxv) basic_machine=vax-dec basic_os=sysv ;; vms) basic_machine=vax-dec basic_os=vms ;; vsta) basic_machine=i386-pc basic_os=vsta ;; vxworks960) basic_machine=i960-wrs basic_os=vxworks ;; vxworks68) basic_machine=m68k-wrs basic_os=vxworks ;; vxworks29k) basic_machine=a29k-wrs basic_os=vxworks ;; xbox) basic_machine=i686-pc basic_os=mingw32 ;; ymp) basic_machine=ymp-cray basic_os=unicos ;; *) basic_machine=$1 basic_os= ;; esac ;; esac # Decode 1-component or ad-hoc basic machines case $basic_machine in # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) cpu=hppa1.1 vendor=winbond ;; op50n) cpu=hppa1.1 vendor=oki ;; op60c) cpu=hppa1.1 vendor=oki ;; ibm*) cpu=i370 vendor=ibm ;; orion105) cpu=clipper vendor=highlevel ;; mac | mpw | mac-mpw) cpu=m68k vendor=apple ;; pmac | pmac-mpw) cpu=powerpc vendor=apple ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) cpu=m68000 vendor=att ;; 3b*) cpu=we32k vendor=att ;; bluegene*) cpu=powerpc vendor=ibm basic_os=cnk ;; decsystem10* | dec10*) cpu=pdp10 vendor=dec basic_os=tops10 ;; decsystem20* | dec20*) cpu=pdp10 vendor=dec basic_os=tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) cpu=m68k vendor=motorola ;; dpx2*) cpu=m68k vendor=bull basic_os=sysv3 ;; encore | umax | mmax) cpu=ns32k vendor=encore ;; elxsi) cpu=elxsi vendor=elxsi basic_os=${basic_os:-bsd} ;; fx2800) cpu=i860 vendor=alliant ;; genix) cpu=ns32k vendor=ns ;; h3050r* | hiux*) cpu=hppa1.1 vendor=hitachi basic_os=hiuxwe2 ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) cpu=m68000 vendor=hp ;; hp9k3[2-9][0-9]) cpu=m68k vendor=hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) cpu=hppa1.1 vendor=hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp cpu=hppa1.1 vendor=hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp cpu=hppa1.1 vendor=hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) cpu=hppa1.1 vendor=hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) cpu=hppa1.0 vendor=hp ;; i*86v32) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv32 ;; i*86v4*) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv4 ;; i*86v) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=sysv ;; i*86sol2) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc basic_os=solaris2 ;; j90 | j90-cray) cpu=j90 vendor=cray basic_os=${basic_os:-unicos} ;; iris | iris4d) cpu=mips vendor=sgi case $basic_os in irix*) ;; *) basic_os=irix4 ;; esac ;; miniframe) cpu=m68000 vendor=convergent ;; *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*) cpu=m68k vendor=atari basic_os=mint ;; news-3600 | risc-news) cpu=mips vendor=sony basic_os=newsos ;; next | m*-next) cpu=m68k vendor=next case $basic_os in openstep*) ;; nextstep*) ;; ns2*) basic_os=nextstep2 ;; *) basic_os=nextstep3 ;; esac ;; np1) cpu=np1 vendor=gould ;; op50n-* | op60c-*) cpu=hppa1.1 vendor=oki basic_os=proelf ;; pa-hitachi) cpu=hppa1.1 vendor=hitachi basic_os=hiuxwe2 ;; pbd) cpu=sparc vendor=tti ;; pbb) cpu=m68k vendor=tti ;; pc532) cpu=ns32k vendor=pc532 ;; pn) cpu=pn vendor=gould ;; power) cpu=power vendor=ibm ;; ps2) cpu=i386 vendor=ibm ;; rm[46]00) cpu=mips vendor=siemens ;; rtpc | rtpc-*) cpu=romp vendor=ibm ;; sde) cpu=mipsisa32 vendor=sde basic_os=${basic_os:-elf} ;; simso-wrs) cpu=sparclite vendor=wrs basic_os=vxworks ;; tower | tower-32) cpu=m68k vendor=ncr ;; vpp*|vx|vx-*) cpu=f301 vendor=fujitsu ;; w65) cpu=w65 vendor=wdc ;; w89k-*) cpu=hppa1.1 vendor=winbond basic_os=proelf ;; none) cpu=none vendor=none ;; leon|leon[3-9]) cpu=sparc vendor=$basic_machine ;; leon-*|leon[3-9]-*) cpu=sparc vendor=`echo "$basic_machine" | sed 's/-.*//'` ;; *-*) # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read cpu vendor <&2 exit 1 ;; esac ;; esac # Here we canonicalize certain aliases for manufacturers. case $vendor in digital*) vendor=dec ;; commodore*) vendor=cbm ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if test x$basic_os != x then # First recognize some ad-hoc cases, or perhaps split kernel-os, or else just # set os. case $basic_os in gnu/linux*) kernel=linux os=`echo "$basic_os" | sed -e 's|gnu/linux|gnu|'` ;; os2-emx) kernel=os2 os=`echo "$basic_os" | sed -e 's|os2-emx|emx|'` ;; nto-qnx*) kernel=nto os=`echo "$basic_os" | sed -e 's|nto-qnx|qnx|'` ;; *-*) # shellcheck disable=SC2162 saved_IFS=$IFS IFS="-" read kernel os <&2 exit 1 ;; esac # As a final step for OS-related things, validate the OS-kernel combination # (given a valid OS), if there is a kernel. case $kernel-$os in linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \ | linux-musl* | linux-relibc* | linux-uclibc* ) ;; uclinux-uclibc* ) ;; -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* ) # These are just libc implementations, not actual OSes, and thus # require a kernel. echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2 exit 1 ;; kfreebsd*-gnu* | kopensolaris*-gnu*) ;; vxworks-simlinux | vxworks-simwindows | vxworks-spe) ;; nto-qnx*) ;; os2-emx) ;; *-eabi* | *-gnueabi*) ;; -*) # Blank kernel with real OS is always fine. ;; *-*) echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2 exit 1 ;; esac # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. case $vendor in unknown) case $cpu-$os in *-riscix*) vendor=acorn ;; *-sunos*) vendor=sun ;; *-cnk* | *-aix*) vendor=ibm ;; *-beos*) vendor=be ;; *-hpux*) vendor=hp ;; *-mpeix*) vendor=hp ;; *-hiux*) vendor=hitachi ;; *-unos*) vendor=crds ;; *-dgux*) vendor=dg ;; *-luna*) vendor=omron ;; *-genix*) vendor=ns ;; *-clix*) vendor=intergraph ;; *-mvs* | *-opened*) vendor=ibm ;; *-os400*) vendor=ibm ;; s390-* | s390x-*) vendor=ibm ;; *-ptx*) vendor=sequent ;; *-tpf*) vendor=ibm ;; *-vxsim* | *-vxworks* | *-windiss*) vendor=wrs ;; *-aux*) vendor=apple ;; *-hms*) vendor=hitachi ;; *-mpw* | *-macos*) vendor=apple ;; *-*mint | *-mint[0-9]* | *-*MiNT | *-MiNT[0-9]*) vendor=atari ;; *-vos*) vendor=stratus ;; esac ;; esac echo "$cpu-$vendor-${kernel:+$kernel-}$os" exit # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl-2.6.14/makdefs0000755000175000017500000000423414360276512012336 0ustar cammcamm# constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: add-defs 386-linux /usr/local/lib # constructed by wfs using: add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: ./add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by using: add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: ./add-defs 386-linux gcl-2.6.14/debian/0000755000175000017500000000000014360276512012215 5ustar cammcammgcl-2.6.14/debian/old.in.gcl-doc.doc-base.main0000644000175000017500000000056314360276512017235 0ustar cammcammDocument: gcl@EXT@-doc Title: GNU Common Lisp Documentation Author: W. Schelter Abstract: A Common Lisp compiler and interpreter based on C Section: Apps/Programming Format: DVI Files: /usr/share/doc/gcl@EXT@-doc/gcl.dvi.gz /usr/share/doc/gcl@EXT@-doc/gcl.dvi Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl/*.html gcl-2.6.14/debian/in.gcl.emacsen-remove0000644000175000017500000000072614360276512016224 0ustar cammcamm#!/bin/sh -e # /usr/lib/emacsen-common/packages/remove/#PACKAGE# FLAVOR=$1 PACKAGE=gcl@EXT@ if [ ${FLAVOR} != emacs ]; then if test -x /usr/sbin/install-info-altdir; then echo remove/${PACKAGE}: removing Info links for ${FLAVOR} install-info-altdir --quiet --remove --dirname=${FLAVOR} /usr/info/#PACKAGE#.info.gz fi echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} fi gcl-2.6.14/debian/gcl.templates0000644000175000017500000000311114360276512014676 0ustar cammcamm# These templates have been reviewed by the debian-l10n-english # team # # If modifications/additions/rewording are needed, please ask # debian-l10n-english@lists.debian.org for advice. # # Even minor modifications require translation updates and such # changes should be coordinated with translators and reviewers. Template: gcl@EXT@/default_gcl_ansi Type: boolean _Description: Use the work-in-progress ANSI build by default? GCL is in the process of providing an ANSI compliant image in addition to its traditional CLtL1 image still in production use. . Please see the README.Debian file for a brief description of these terms. Choosing this option will determine which image will be used by default when executing 'gcl@EXT@'. . This setting may be overridden by setting the GCL_ANSI environment variable to any non-empty string for the ANSI build, and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor will be reported in the initial startup banner. Template: gcl@EXT@/default_gcl_prof Type: boolean _Description: Use the profiling build by default? GCL has optional support for profiling via gprof. . Please see the documentation for si::gprof-start and si::gprof-quit for details. As this build is slower than builds without gprof support, it is not recommended for final production use. . Set the GCL_PROF environment variable to the empty string for more optimized builds, or any non-empty string for profiling support; e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, this will be reported in the initial startup banner. gcl-2.6.14/debian/in.gcl-doc.info0000644000175000017500000000112214360276512015003 0ustar cammcammdebian/tmp/usr/share/info/gcl@EXT@-si.info debian/tmp/usr/share/info/gcl@EXT@-tk.info debian/tmp/usr/share/info/gcl@EXT@-tk.info-1 debian/tmp/usr/share/info/gcl@EXT@-tk.info-2 debian/tmp/usr/share/info/gcl@EXT@.info debian/tmp/usr/share/info/gcl@EXT@.info-1 debian/tmp/usr/share/info/gcl@EXT@.info-2 debian/tmp/usr/share/info/gcl@EXT@.info-3 debian/tmp/usr/share/info/gcl@EXT@.info-4 debian/tmp/usr/share/info/gcl@EXT@.info-5 debian/tmp/usr/share/info/gcl@EXT@.info-6 debian/tmp/usr/share/info/gcl@EXT@.info-7 debian/tmp/usr/share/info/gcl@EXT@.info-8 debian/tmp/usr/share/info/gcl@EXT@.info-9 gcl-2.6.14/debian/in.gcl-doc.README.Debian0000644000175000017500000000045214360276512016173 0ustar cammcammNew in 2.6.2 ------------ The gcl.texi files and the resulting html, info, and pdf outputs have been removed pending an enquiry into the copyright and license status of the dpANS documents upon which they are presumably based. -- Camm Maguire , Fri, 9 May 2014 19:08:59 +0000 gcl-2.6.14/debian/texi.awk0000755000175000017500000000047514360276512013703 0ustar cammcamm#!/usr/bin/awk -f /^@defun/ { a=split($0,A,"("); b=split($0,B,")"); if (a==b) print ; else { i=1; c=$0; } next; } { if (i) { sub("^ *",""); c=c " " $0; a=split(c,A,"("); b=split(c,B,")"); if (a==b) { print c; c=""; i=0; } } else print; } gcl-2.6.14/debian/in.gcl-doc.install0000644000175000017500000000004614360276512015522 0ustar cammcammdebian/tmp/usr/share/doc/gcl@EXT@-doc gcl-2.6.14/debian/rules0000755000175000017500000001712214360276512013300 0ustar cammcamm#!/usr/bin/make -f # Sample debian/rules that uses debhelper. # GNU copyright 1997 by Joey Hess. # # This version is for a hypothetical package that builds an # architecture-dependant package, as well as an architecture-independent # package. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 export GCL_MEM_MULTIPLE=0.1 # This is the debhelper compatability version to use. ARCHT:=$(shell dpkg-architecture -qDEB_HOST_ARCH) MCC?=gcc # ifeq ($(ARCHT),alpha) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),mips) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),mipsel) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),ia64) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),armel) # MCC:=gcc-4.6 # endif # ifeq ($(ARCHT),armhf) # MCC:=gcc-4.6 # endif #RELOC=locbfd #RELOC?=statsysbfd RELOC?=custreloc ifeq ($(ARCHT),ia64) RELOC=dlopen endif # ifeq ($(ARCHT),ppc64) # RELOC=dlopen # endif #ifeq ($(ARCHT),hppa) #RELOC=dlopen #endif GMP?= DEBUG= ARCHCONF?= ifeq ($(ARCHT),armhf) ARCHCONF=--enable-cstackmax=0xc0000000 endif ifeq ($(ARCHT),armel) ARCHCONF=--enable-cstackmax=0xc0000000 endif #ifeq ($(ARCHT),hppa) #DEBUG=--enable-debug #endif VERS=$(shell echo $$(cat majvers).$$(cat minvers)) #EXT:=cvs CFG:=$(addsuffix /config.,.)# gmp4/configfsf. # Bug in autoconf dependency on emacsen-common workaround #CFGS:=$(addsuffix .ori,configure $(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) CFGS:=$(addsuffix .ori,$(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) $(filter %.guess.ori,$(CFGS)): %.ori: /usr/share/misc/config.guess % ! [ -e $* ] || [ -e $@ ] || cp $* $@ [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* touch $@ $(filter %.sub.ori,$(CFGS)): %.ori: /usr/share/misc/config.sub % ! [ -e $* ] || [ -e $@ ] || cp $* $@ [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* touch $@ configure.ori: %.ori: configure.in ! [ -e $* ] || [ -e $@ ] || cp $* $@ cd $(@D) && autoconf touch $@ configure-%-stamp: $(CFGS) dh_testdir ! [ -e unixport/saved_pre_gcl ] || $(MAKE) clean # chmod -R +x gmp4/* [ "$*" != "trad" ] || FLAGS="--disable-ansi" ; \ [ "$*" != "gprof" ] || FLAGS="--disable-ansi --enable-gprof" ; \ [ "$*" != "ansi-gprof" ] || FLAGS="--enable-gprof" ; \ eval `dpkg-buildflags --export=sh` && CC=$(MCC) ./configure \ --host=$$(dpkg-architecture -qDEB_HOST_GNU_TYPE) \ --disable-statsysbfd \ --disable-custreloc \ --disable-dlopen \ --enable-prelink \ --enable-$(RELOC) \ $(GMP) \ $(DEBUG) \ $(ARCHCONF) \ $$FLAGS \ --prefix=/usr \ --mandir=\$${prefix}/share/man \ --enable-infodir=\$${prefix}/share/info \ --enable-emacsdir=\$${prefix}/share/emacs/site-lisp touch $@ build-%-stamp: configure-%-stamp dh_testdir $(MAKE) rm -rf debian/$* mkdir -p debian/$* $(MAKE) install DESTDIR=$$(pwd)/debian/$* [ "$(findstring gprof,$*)" = "" ] || (\ tmp=debian/$*; old=/usr/lib/gcl-$(VERS); new=$$old-prof;\ if [ "$(findstring ansi,$*)" = "" ] ; then i=saved_gcl ; else i=saved_ansi_gcl ; fi;\ mv $$tmp/$$old $$tmp/$$new ;\ echo "(si::reset-sys-paths \"$$new/\")(si::save-system \"debian/tmp-image\")" | $$tmp/$$new/unixport/$$i &&\ mv debian/tmp-image $$tmp/$$new/unixport/$$i;) touch $@ bclean-stamp: $(MAKE) clean touch $@ ansi-tests/test_results: build-ansi-stamp $(MAKE) $@ build: build-arch build-indep build-arch: build-stamp build-indep: build-stamp build-stamp: build-gprof-stamp build-ansi-gprof-stamp build-trad-stamp build-ansi-stamp ansi-tests/test_results touch $@ debian/control.rm: rm -f `echo $@ | sed 's,\.rm$$,,1'` debian/control: debian/control.rm cp debian/control_$(EXT) debian/control clean: debian/control debian/gcl.templates dh_testdir dh_testroot rm -f *stamp debconf-updatepo $(MAKE) clean dh_clean rm -rf debian/gprof debian/ansi-gprof debian/trad debian/ansi $(INS) debian/substvars debian.upstream rm -rf *stamp for i in $(CFGS) ; do ! [ -e $$i ] || mv $$i $${i%.ori} ; done INS:=$(shell for i in debian/in.* ; do echo $$i | sed 's,in.,,1' ; done |sed "s,gcl,gcl$(EXT),g") $(INS): debian/gcl$(EXT)% : debian/in.gcl% cat $< | sed 's,@EXT@,$(EXT),g' >$@ install: install-stamp install-stamp: build-stamp debian/control $(INS) dh_testdir dh_testroot # dh_clean -k dh_prep dh_installdirs mkdir -p debian/tmp cp -a debian/ansi/* debian/tmp/ cp -a debian/trad/* debian/tmp/ cp -a debian/gprof/* debian/tmp/ cp -a debian/ansi-gprof/* debian/tmp/ mv debian/tmp/usr/share/emacs/site-lisp debian/tmp/usr/share/emacs/foo mkdir -p debian/tmp/usr/share/emacs/site-lisp mv debian/tmp/usr/share/emacs/foo debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT) cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el |\ sed "s,(provide 'gcl),(provide 'gcl$(EXT)),1" >tmp &&\ mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl$(EXT).el [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el |\ sed "s,(provide 'dbl),(provide 'dbl$(EXT)),1" >tmp &&\ mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl$(EXT).el [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el [ "$(EXT)" = "" ] || \ for i in debian/tmp/usr/share/info/*.info*; do \ mv $$i $$(echo $$i | sed "s,gcl,gcl$(EXT),g"); done mv debian/tmp/usr/share/doc debian/tmp/usr/share/foo mkdir -p debian/tmp/usr/share/doc/gcl-doc mv debian/tmp/usr/share/foo/* debian/tmp/usr/share/doc/gcl-doc rmdir debian/tmp/usr/share/foo [ "$(EXT)" = "" ] || \ mv debian/tmp/usr/share/doc/gcl-doc debian/tmp/usr/share/doc/gcl$(EXT)-doc [ "$(EXT)" = "" ] || \ (cat debian/tmp/usr/share/man/man1/gcl.1 |sed -e 's, gcl , gcl$(EXT) ,g' 's, GCL , GCL$(EXT) ,g' >debian/foo && \ mv debian/foo debian/tmp/usr/share/man/man1/gcl$(EXT).1) # cat debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp | \ # sed "s,$$(pwd)/debian/tmp,,1" >debian/foo # mv debian/foo debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp rm -f debian/tmp/usr/bin/*.exe debian/tmp/usr/bin/*.bat find debian/tmp -type f -name "*.lsp" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.lisp" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.el" -exec chmod ugo-x {} \; find debian/tmp -type f -name "*.tcl" -exec chmod ugo-x {} \; rm -f debian/tmp/usr/bin/gcl TKVERS=$$(cat bin/gcl | grep /tk | head -1l | sed "s,.*/tk\([0-9.]*\)\").*,\1,1"); \ cat debian/gcl.sh | sed -e "s,@EXT@,$(EXT),g" \ -e "s,@VERS@,$(VERS),g" \ -e "s,@TKVERS@,$$TKVERS,g" >debian/tmp/usr/bin/gcl$(EXT) chmod 0755 debian/tmp/usr/bin/gcl$(EXT) rm -rf debian/tmp/usr/lib/gcl-$(VERS)/info dh_install touch $@ # Build architecture-independent files here. # Pass -i to all debhelper commands in this target to reduce clutter. binary-indep: build install dh_testdir -i dh_testroot -i dh_installdocs -i dh_installinfo -i dh_installchangelogs ChangeLog -i dh_link -i dh_compress -i dh_fixperms -i dh_installdeb -i dh_gencontrol -i dh_md5sums -i dh_builddeb -i binary-arch: build install #debian/substvars dh_testdir -a dh_testroot -a dh_installdocs -a -XRELEASE-2.6.2.html dh_installemacsen -a dh_installman -a dh_installdebconf -a sed -i -e 's,@EXT@,$(EXT),g' debian/gcl$(EXT)/DEBIAN/templates dh_installchangelogs ChangeLog -a dh_strip -a -Xlibgcl -Xlibansi_gcl # -Xgcl-$(VERS)-prof/unixport/saved_gcl -Xgcl-$(VERS)-prof/unixport/saved_ansi_gcl dh_lintian -a dh_link -a dh_compress -a dh_fixperms -a dh_installdeb -a dh_shlibdeps -a dh_gencontrol -a -u"-Vgcc=$(MCC)" dh_md5sums -a dh_builddeb -a binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary install configure .PRECIOUS: configure-trad-stamp configure-ansi-stamp configure-gprof-stamp configure-ansi-gprof-stamp gcl-2.6.14/debian/in.gcl-doc.docs0000644000175000017500000000002714360276512015003 0ustar cammcammfaq readme readme.xgcl gcl-2.6.14/debian/in.gcl.config0000644000175000017500000000073414360276512014562 0ustar cammcamm#!/bin/sh CONFIGFILE=/etc/default/gcl@EXT@ set -e . /usr/share/debconf/confmodule # Load config file, if it exists. if [ -e $CONFIGFILE ]; then . $CONFIGFILE || true # Store values from config file into # debconf db. db_set gcl@EXT@/default_gcl_ansi $DEFAULT_GCL_ANSI db_set gcl@EXT@/default_gcl_prof $DEFAULT_GCL_PROF fi # Ask questions. db_input medium gcl@EXT@/default_gcl_ansi || true db_input medium gcl@EXT@/default_gcl_prof || true db_go || true gcl-2.6.14/debian/upstream/0000755000175000017500000000000014360276512014055 5ustar cammcammgcl-2.6.14/debian/upstream/signing-key.asc0000644000175000017500000001255014360276512016774 0ustar cammcamm-----BEGIN PGP PUBLIC KEY BLOCK----- Version: GnuPG v1 mQGiBD1mWk0RBADdQYIiaNJJOHAZdBpzOBm31v5AlQa1jjYx1W6zKd+ECqZVdonw e+CP/qpVCUXRYmQ3v/ZYpINtcRR2IckTQCs4fvYUAuQir2cpKmRqImnGhzFJ1pd9 Rf2aqPspycMx9IlqKkeY1LwNahitQ93YwyCT1HUCTB0hIuNMtFNte18DpwCgwbYP bBuLYCG/8g+MqoG7SBhN4hkEANafxrX2EEwUCpQlKGkw4P18wCinbs7tjgXwL7SK WV9qpIDkUEnW2cnzfDBrNW24LtHt0qMsGa8sCJW30ZPUv0sebsyzVTJR0O5g6Lpi zlznB1LtmbkDdd79R4Qrs01k+2OK2K0r54xnOlL+ZZQFamP3jvTZAKxyUGI2Fiqu 1O7OA/4xp5/WNyuIUWUho+nfhp0sakzAiC1aBHLtAvhL470sBm3xojM6w3vicTT2 7rnzS1teeUnCOMK+CUzzITXHrnljCkyg8d6QqtlWJCc4T6tTYJNOuWte3AckYDaF 4HhJbwNamrDGKQJ0kYOqtquz5WE8EjkxwglRQSrGanxMXnCsB7QgQ2FtbSBNYWd1 aXJlIDxjYW1tQGVuaGFuY2VkLmNvbT6IXwQTEQIAFwUCPWZaTQULBwoDBAMVAwID FgIBAheAABIJEHMxtcBX8EXcB2VHUEcAAQFCkQCeL84DKju0u23VHI2a9S3CZwpw cEMAn03Jgjje37YEbLCnfh/JN4zhcUeFiQCVAwUQPXktv1RjAAQhp2rpAQEynwP5 AZT5Fmlc6FbnVeusUNz1jtEKysdFc7TBFZSdWK2ftjuQiiiYgLOSM6kLpc6DJxLU 0gc6FmQCme1G3wnQFpi5GXFlYcW5mfe3V5/0Paxcc/CijULb4IRU41KO3tTy7wpY NARRB5I+MeLT39bpqljO0b7PRETncVnXgkm5PEJGV3C0HkNhbW0gTWFndWlyZSA8 Y2FtbUBkZWJpYW4ub3JnPohgBBMRAgAgBQJJmevSAhsjBgsJCAcDAgQVAggDBBYC AwECHgECF4AACgkQczG1wFfwRdxZywCeLfMYW3CQAi8e0C8NAauuIpZJx+wAoJAW eBe0arj/lrwecpn26l63nC5KuQENBD1mWk4QBADRBvXyQ0uxFCkac7ZVSuwEJrbw NdhS3ossQi+gm8aDPSokKFASs75SLNQMfIRhyToGcyplP75OYaMxvyih7DFGBLoB kzCuhBJ09VgLC0BiuJAtEI5orQf9sNt7CwBEG2KZ/X4oHXmKitgP0F4xff9XociT ZusPI90z9yg2treJ4wADBQP/aDZ839IYpwL6ZDZ8faVtgMz65lKaFkLzi/2pHWao SEWYiGcLozizNt+w+qcyMGUDNkDMtTY0Y9cbC8Dn7r/0/CZW1UQ2D3fSeAfsgxEE PnYYFiFr0Xyi+oDu7fkcV9wQdqLZ6OvR0SZqoJwLdmJqjTzz1TJTOfdTcSV/+POJ qCuITgQYEQIABgUCPWZaTgASCRBzMbXAV/BF3AdlR1BHAAEBn/kAn2saGr0hmMfO Nn4j36onyp18oNqYAKCTJZU26kWZcORo+FbyOMQ3+Yd8EZkBogQ6A9NcEQQAiUvw 61oHv/VZvl8uo5hTAaka2HEfECf5aMvG7N1ytUXzKTldnyEBGiqOdbLtF1wL2SUV rdhX0VhH0fi19K2graTGqSQYzdA7uIIOQHOAZ5py5mKQr9zFkKyf5W4RKAbTIUAS uTlSy1NiyKPMXdBlu0f5rkl/m5KODlf1nVtDposAoPuMTY9/D/cOqzB4fmEQ6gMG M2/PA/9nHj4Mow5EkvSLsuAkn/mpI0Rv+ly1pmKJtbsJZIs1PWk/J47TRVigUgft LOlfYMAHXwfF6svodOKF0eOaBjeZmyu1KnDDy9EWWhZwdoT08AD664/bbN1goNzE XFlfD83yPWa1VrPNME2fq6jdY/WKZB5+viKu7yaMGGwQfjg9EwP/QCbz4cZvUiF5 SmlI3u8+wgThk3DXnL9L3GlOASacET6wRFX6C3HYnRBTB0EypYJoUPIj7rt/Ptyl CRHQtMUuSouyq/Smj5ybw8kvGRRH4SgfoghjL+q+sVGwIZiUQXu+g96vSSBuQTE2 x8iZ8mXpPud7jjMc98CfjiB9/ujnqK+0MEVyaWMgU2hhcmtleSA8c2hhcmtleUBz dXBlcmsucGh5c2ljcy5zdW55c2IuZWR1PohfBBMRAgAXBQI6A9NcBQsHCgMEAxUD AgMWAgECF4AAEgkQclUlAyIk+rwHZUdQRwABAcGdAJ45RrdVItJxXhDiCWeXpHKq DfkBIQCg97TpqcIbuDGD1r8gkSb6ErXA+4SJAJUDBRA6L65Bj/xAXv1aZ80BAVlU A/oD8wBcQeTD3HzeBcK6SVygQZlQS2g8v7H4G91Fu9yTESbDdYLjmybniGwTgS7q 0/RbQDRCmh+fyBD38CmB2B23VdpXRYaChDeKTP+Lvg+mQn9zdMFkERD2/W40+TID 1g7lafk3XDe+dOX59Ie0qeCXcccsv8OfhJwoEwHKPC9ZeIhGBBARAgAGBQI87l/I AAoJEHIxQb2lt4IBM5MAnj9wqSGdaLTfHAQb7xk36abh0vboAJwIGkIMfE7HkvbX 9nXqefmNfrns3IhGBBARAgAGBQI9eSPnAAoJEHMxtcBX8EXcnq8An2DneOdg2qBr xF5ZBzEfGBcZHMbCAJ0Z+QKVo1/XQUVcHbGrHo+kF4IfmrQhRXJpYyBTaGFya2V5 IDxzaGFya2V5QGRlYmlhbi5vcmc+iF8EExECABcFAjo5dzoFCwcKAwQDFQMCAxYC AQIXgAASCRByVSUDIiT6vAdlR1BHAAEBo0MAoKXjeu7EYrx9uSrlC6rQHavvmq1u AJsFXSfzM+lgT5lO9a3K0/N+Wr4ZRIhGBBARAgAGBQI87l/fAAoJEHIxQb2lt4IB 8BgAn3ZJz4t/JBnRhEB2I0BA5CiIxKtAAKCf5FHs+3/1vYmhtAX3ouSWyN0jFIhG BBARAgAGBQI9eSPtAAoJEHMxtcBX8EXci7YAnRnwG8BddR4vdcvNGewRxCxweOrz AKCgcm8lYWrd0Ubz4/CtelbxA16yV7kBDQQ6A9NrEAQAyXOKw6Zg+VjOiw10ZKtP mQNmkEA5qUcGgcXKIPwwZ8sMZLzsqzdSM6UVwlN/1D/kH9U5Lkh1LqUxQ+NVC5Qm bGV+Wq52I9id/lpYycfxNkjURk/wXnOdFCY55pJiS2851DiCBpNC/ClFZZe1Yhdd HhUFnJrGRjaKTMoKI3sWUDsAAwYEAIuBP5eMx8I4qzVrt9tgDEx9LZZyd18jqC42 FcMesLMdUi/UKOzrSr/tQ/eiOVMai/RUMmtoyvJzm6bt4UsO54Ynhhul4ySreB4h 4TA7C9vKYTvPmZ5hsOAmguhtvkGOiN+7cXUa35xpL1dbBjelJR8cSFJtAQn2PKkJ JeS6N4LHiE4EGBECAAYFAjoD02sAEgkQclUlAyIk+rwHZUdQRwABAS1yAJwO6YAP f1tU5MvrXRbHC52/dn82kgCgkxPi+HiFgqOc1FCfMByu9ZvzwGaZAaIEPKkVqhEE AMqWl8BYusXdZEt7EE7gDfTtYgCCREiy3B2jTERJ4DXP0hPQDxBOQh6AW0JCtcxT vuNOZnAlMqXKPvV4tc55dSYTBYW6U2ySN+xrHi9GvS9k5JjpsZdstS5MVkTppOS0 nTEBw8KofAHBfFpwisCsz38P5ehLnbpm1M7WNXGxmvDTAKDFxuwQL9S8gRUhXIS3 kAOkDW2eTwP+I5Xil4aIAUnw/JVUaP7wRGUYnFnIisgPftZ+k+R/RfirSlnpPMZr cqC8JpR0Zm2jQ7jSzTdjj4yFM0PTdUg3mUo5IANd31XshDO7utppX8QBQ9c9PYml PSVZTRLiDT50HB4rjsoLTlYQOMsFxG4v9v6ybKCvhmZRvD1J97Q5EEsD/3V+Kor5 8j72RZwrjTspT7roljxyly5D/p6dqiNFLOHjjfuj3SYah7TAlAxtb7CFGsPdNJJf jZvb//IzZw7XNG1EU9+PaV6mbTZNbrXavbKrIkz6AnLB9GDFE1oDWv7c2b5v5HVv SO/hakFEDcgxSPzkMVkc7wGOq+6kClG8z2DMtC1CcmlhbiBSIEZ1cnJ5IChUcnVz dCBObyBPbmUpIDxmYnJpYW5AbmFjLm5ldD6IZQQTEQIAHQUCPKkVqgUJBaOagAUL BwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHvmwCfV6KEnp4tIKHz dZwBGsqnlKSBkpcAmgNdv300le8RtsGdhsDCRT6cUl1TiEYEEBECAAYFAjzqw3EA CgkQclUlAyIk+rw0sgCg6jCNQKL71DqAifPm6o07tkkYoc0An3duMoIdm9g2qV2d OSOpJn63WXKoiEYEEBECAAYFAj15JjIACgkQczG1wFfwRdyRHQCeK2xhxX1ccxDG DzMYZKivG5uUdBoAnRJ62vbPCyQ1I9ihAf1nzygCdxrytC1CcmlhbiBSIEZ1cnJ5 IChUcnVzdCBObyBPbmUpIDxiZnVycnlAbmFjLm5ldD6IZQQTEQIAHQUCPUsJiQUJ BaOagAULBwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHzcACfeVya lc6NRe3Kle9aX9AXxljfdnUAniXqub/sS6WetxJwKrivk3WhyQnEiEYEEBECAAYF Aj15JjgACgkQczG1wFfwRdxRyACgv7su7KfZvI07M31IcMtS0PHL4L4AoL5wr/os n198CXGT8C5eXCRBVa8zuQENBDypFbgQBAC3VMeu+Qsa4IlZzzvFeB9sbnIr7e6P TWuTR3EUnOzEd/h5k/bDdLW11uDnXyhbMSOXzGJaB9HbW5NXUuHIzTEwDzP+/hSJ HNhc3YXREOs4YMrexeTgKEE3RFJ/ulTJ2EvTVdb7+uwKEMctKC+xaK/cIiRZt8Fg Da1KjYBnpr5DvwADBQP5AaCubKcP0z202ys6EuvY/xIgYxJ95x/ermkV91cur7e1 J9NqLOdbgj/yLcco9T92IBMm7zAnzDEtPC7UaqvrtuISvWc+z48Lk19AN7JOOH+g 2oIvspF4Gj2RVc7vijh7gMav5tIflZxqNi2U/QFYqgVTnE0facclV3w2IpMPUpyI VAQYEQIADAUCPKkVuAUJBaOagAASCRByMUG9pbeCAQdlR1BHAAEB+GUAn0etwV2m fUKduxyMlCzpoCtLBzy3AJ99bcVPGhgGkpMktMMRlLjPXiLgGA== =tBlv -----END PGP PUBLIC KEY BLOCK----- gcl-2.6.14/debian/in.gcl-doc.doc-base.main0000644000175000017500000000041714360276512016456 0ustar cammcammDocument: gcl@EXT@-doc Title: GNU Common Lisp Documentation Author: W. Schelter Abstract: A Common Lisp compiler and interpreter based on C Section: Programming Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl/*.html gcl-2.6.14/debian/gcl.lintian-overrides0000644000175000017500000000120414360276512016337 0ustar cammcammgcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12-prof/unixport/saved_ansi_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12-prof/unixport/saved_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12/unixport/saved_ansi_gcl gcl: binary-compiled-with-profiling-enabled usr/lib/gcl-2.6.12/unixport/saved_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12-prof/unixport/saved_ansi_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12-prof/unixport/saved_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12/unixport/saved_ansi_gcl gcl: hardening-no-pie usr/lib/gcl-2.6.12/unixport/saved_gcl gcl: emacsen-common-without-dh-elpa gcl-2.6.14/debian/in.gcl.emacsen-startup0000644000175000017500000000150414360276512016424 0ustar cammcamm;; -*-emacs-lisp-*- ;; ;; Emacs startup file for the Debian GNU/Linux #PACKAGE# package ;; ;; Originally contributed by Nils Naumann ;; Modified by Dirk Eddelbuettel ;; Adapted for dh-make by Jim Van Zandt ;; The #PACKAGE# package follows the Debian/GNU Linux 'emacsen' policy and ;; byte-compiles its elisp files for each 'emacs flavor' (emacs19, ;; xemacs19, emacs20, xemacs20...). The compiled code is then ;; installed in a subdirectory of the respective site-lisp directory. ;; We have to add this to the load-path: (setq load-path (cons (concat "/usr/share/" (symbol-name debian-emacs-flavor) "/site-lisp/gcl@EXT@") load-path)) (autoload 'run@EXT@ "gcl@EXT@" "" t) (autoload 'dbl@EXT@ "dbl@EXT@" "" t) gcl-2.6.14/debian/control_cvs0000644000175000017500000000302714360276512014475 0ustar cammcammSource: gclcvs Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, binutils-dev Standards-Version: 4.5.0 Package: gclcvs Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gclcvs-doc Description: GNU Common Lisp compiler, CVS snapshot GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gclcvs-doc package. Package: gclcvs-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4), ${misc:Depends} Description: Documentation for GNU Common Lisp, CVS snapshot GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl-2.6.14/debian/in.gcl.emacsen-compat0000644000175000017500000000000214360276512016175 0ustar cammcamm0 gcl-2.6.14/debian/watch0000644000175000017500000000016314360276512013246 0ustar cammcammversion=4 options=pasv,pgpsigurlmangle=s/$/.sig/ ftp://ftp.gnu.org/pub/gnu/gcl gcl-([0-9.]*).tar.gz debian uupdate gcl-2.6.14/debian/in.gcl-doc.doc-base.tk0000644000175000017500000000062714360276512016153 0ustar cammcammDocument: gcl@EXT@-tk-doc Title: GNU Common Lisp Tk Interface Documentation Author: W. Schelter Abstract: Documentation for Graphical Interface to GCL using TCL/Tk Section: Programming Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl-tk/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk/*.html gcl-2.6.14/debian/control_0000644000175000017500000000275414360276512013767 0ustar cammcammSource: gcl Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, binutils-dev Standards-Version: 4.5.0 Package: gcl Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl-doc Description: GNU Common Lisp compiler GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gcl-doc package. Package: gcl-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4), ${misc:Depends} Description: Documentation for GNU Common Lisp GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl-2.6.14/debian/source/0000755000175000017500000000000014360276512013515 5ustar cammcammgcl-2.6.14/debian/source/format0000644000175000017500000000001414360276512014723 0ustar cammcamm3.0 (quilt) gcl-2.6.14/debian/source/include-binaries0000644000175000017500000000007614360276512016660 0ustar cammcamminfo/gcl.pdf info/gcl-si.pdf info/gcl-tk.pdf xgcl-2/dwdoc.pdf gcl-2.6.14/debian/source/lintian-overrides0000644000175000017500000000156514360276512017105 0ustar cammcammgcl source: source-is-missing [info/gcl/Constraints-on-the-COMMON_002dLISP-Package-for-Conforming-Programs.html] gcl source: source-is-missing [info/gcl/Defsetf-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Destructuring-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Generic-Function-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Macro-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Ordinary-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/Specialized-Lambda-Lists.html] gcl source: source-is-missing [info/gcl/The-_0022Compound-Type-Specifier-Arguments_0022-Section-of-a-Dictionary-Entry.html] gcl source: source-is-missing [info/gcl/The-_0022Compound-Type-Specifier-Syntax_0022-Section-of-a-Dictionary-Entry.html] gcl source: source-is-missing [info/gcl/defmethod.html] gcl source: source-is-missing [info/gcl/loop.html] gcl-2.6.14/debian/in.gcl.install0000644000175000017500000000010114360276512014747 0ustar cammcammdebian/tmp/usr/lib debian/tmp/usr/bin debian/tmp/usr/share/emacs gcl-2.6.14/debian/in.gcl.manpages0000644000175000017500000000005114360276512015100 0ustar cammcammdebian/tmp/usr/share/man/man1/gcl@EXT@.1 gcl-2.6.14/debian/po/0000755000175000017500000000000014360276512012633 5ustar cammcammgcl-2.6.14/debian/po/gl.po0000644000175000017500000001436114360276512013602 0ustar cammcamm# Galician translation of gclcvs's debconf templates # This file is distributed under the same license as the gclcvs package. # Jacobo Tarrio , 2007. # msgid "" msgstr "" "Project-Id-Version: gclcvs\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-01 13:38+0000\n" "Last-Translator: Jacobo Tarrio \n" "Language-Team: Galician \n" "Language: gl\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "¿Empregar por defecto a versión ANSI que se está a facer?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " "CLtL1 que aínda se emprega en produción." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Consulte o ficheiro README.Debian para ver unha descrición breve deses " "termos. Ao establecer esa variable ha determinar a imaxe que ha empregar por " "defecto ao executar \"gcl@EXT@\"." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Pode empregar a outra imaxe establecendo a variable de ambiente GCL_ANSI a " "calquera cadea non baleira para empregar a versión ANSI, e á cadea baleira " "para empregar a versión CLtL1; por exemplo, GCL_ANSI=t gcl@EXT@. Hase " "informar da versión en uso no cartel que aparece ao iniciar o programa." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "¿Empregar por defecto a versión con cronometrado?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL agora ten soporte opcional de cronometrado mediante gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Consulte a documentación de si::gprof-start e si::gprof-quit para máis " "detalles. Xa que esta versión é máis lenta que as que non teñen soporte de " "gprof, non se recomenda que a empregue para o uso en produción." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Pode empregar unha versión distinta á seleccionada establecendo a variable " "de ambiente GCL_PROF a calquera cadea non baleira para empregar o soporte de " "cronometrado, ou á cadea baleira para as versións máis optimizadas; por " "exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase informar " "diso no cartel que aparece ao iniciar o programa." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " #~ "CLtL1 que aínda se emprega en produción. Consulte o ficheiro README." #~ "Debian para ver unha descrición breve deses termos. Ao estabrecer esa " #~ "variable ha determinar a imaxe que ha empregar por defecto ao executar " #~ "\"gcl@EXT@\". Pode empregar a outra imaxe estabrecendo a variable de " #~ "ambiente GCL_ANSI a calquera cadea non baleira para empregar a versión " #~ "ANSI, e á cadea baleira para empregar a versión CLtL1; por exemplo, " #~ "GCL_ANSI=t gcl@EXT@. Hase informar da versión en uso no cartel que " #~ "aparece ao iniciar o programa." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL agora ten soporte opcional de cronometrado mediante gprof. Consulte a " #~ "documentación de si::gprof-start e si::gprof-quit para máis detalles. Xa " #~ "que esta versión é máis lenta que as que non teñen soporte de gprof, non " #~ "se recomenda que a empregue para o uso en produción. Pode empregar unha " #~ "versión distinta á seleccionada estabrecendo a variable de ambiente " #~ "GCL_PROF a calquera cadea non baleira para empregar o soporte de " #~ "cronometrado, ou á cadea baleira para as versións máis optimizadas; por " #~ "exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase " #~ "informar diso no cartel que aparece ao iniciar o programa." gcl-2.6.14/debian/po/POTFILES.in0000644000175000017500000000005014360276512014403 0ustar cammcamm[type: gettext/rfc822deb] gcl.templates gcl-2.6.14/debian/po/es.po0000644000175000017500000002402014360276512013600 0ustar cammcamm# gcl po-debconf translation to Spanish # Copyright (C) 2005, 2007, 2008 Software in the Public Interest # This file is distributed under the same license as the gcl package. # # Changes: # - Initial translation # César Gómez Martín , 2005 # # - Updates # Rudy Godoy Guillén , 2007 # Francisco Javier Cuadrado , 2008 # # Traductores, si no conoce el formato PO, merece la pena leer la # documentación de gettext, especialmente las secciones dedicadas a este # formato, por ejemplo ejecutando: # # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # # Equipo de traducción al español, por favor, lean antes de traducir # los siguientes documentos: # # - El proyecto de traducción de Debian al español # http://www.debian.org/intl/spanish/ # especialmente las notas de traducción en # http://www.debian.org/intl/spanish/notas # # - La guía de traducción de po's de debconf: # /usr/share/doc/po-debconf/README-trans # o http://www.debian.org/intl/l10n/po-debconf/README-trans # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-45\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-12-04 20:00+0100\n" "Last-Translator: Francisco Javier Cuadrado \n" "Language-Team: Debian l10n spanish \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Spanish\n" "X-Poedit-Country: SPAIN\n" "X-Poedit-SourceCharset: utf-8\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" "¿Utilizar la generación ANSI todavía en desarrollo de manera predeterminada?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GL está en el proceso de proporcionar una imagen ANSI, además de su imagen " "CLtL1 tradicional que todavía se usa." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Por favor, véase el archivo README.Debian para una descripción corta de " "estos términos. Eligiendo esta opción determinará que imagen se usará de " "manera predeterminada al ejecutar «gcl@EXT@»." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Esta configuración se puede sobrescribir cambiando la variable de entorno " "GCL_ANSI a cualquier cadena de caracteres no vacía para la generación ANSI, " "y a una cadena de caracteres vacía para la generación CLtL1, por ejemplo: " "«GCL_ANSI=t gcl@EXT@». El actual tipo de generación se mostrará en la " "información inicial del arranque." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "¿Utilizar la generación con «profiling» de manera predeterminada?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL permite usar «profiling», de manera opcional, mediante gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Por favor, véase la documentación para los detalles de «si::gprof-start» y " "«si::gprof-quit». Ya que esta generación es más lenta que sin el uso de " "gprof, no se recomienda para su uso final." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Cambie el valor de la variable de entorno GCL_PROF a una cadena de " "caracteres vacía para generación más optimizadas, o a una cadena de " "caracteres no vacía para usar el «profiling», por ejemplo: «GCL_PROF=t " "gcl@EXT@». Si el «profiling» está activado, se mostrará en la información " "inicial del arranque." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL está en proceso de incorporar una imagen compatible con ANSI en " #~ "adición a su imagen CLtL1 tradicional que todavía se usa en producción. " #~ "Por favor, véase el fichero README de Debian para una breve descripción " #~ "acerca de estos términos. El definir esta variable determinará qué imagen " #~ "utilizar de manera predeterminada cuando ejecute «gcl@EXT@».\n" #~ "Puede anular esta elección localmente definiendo la variable de entorno " #~ "GCL_ANSI a una cadena no vacía para la compilación ANSI, y a una vacía " #~ "para la compilación CLtL1, ejemplo: GCL_ANSI=t gcl@EXT@. La versión de la " #~ "compilación se indicará en el anuncio inicial de arranque." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "Ahora GCL tiene soporte opcional para perfilado a través de gprof. Por " #~ "favor, mire la documentación de «si::gprof-start» y de «si::gprof-quit» y " #~ "«si::gprof-quit» si desea más detalles. Dado que esta compilación es más " #~ "lenta que otras sin soporte para gprof, no se recomienda usarlo en " #~ "producción. Puede anular esta elección de forma local mediante el " #~ "establecimiento de la variable de entorno GCL_PROF a cualquier cadena no " #~ "vacía para soporte de perfiles, y a la cadena vacía para los paquetes más " #~ "optimizados, es decir GCL_PROF=t gcl. Si el perfilado está activo se " #~ "indicará en el anuncio inicial de arranque." #~ msgid "" #~ "GCL is one of the oldest free common lisp systems still in use. Several " #~ "production systems have used it for over a decade. The common lisp " #~ "standard in effect when GCL was first released is known as \"Common Lisp, " #~ "the Language\" (CLtL1) after a book by Steele of the same name providing " #~ "this specification. Subsequently, a much expanded standard was adopted " #~ "by the American National Standards Institute (ANSI), which is still " #~ "considered the definitive common lisp language specification to this " #~ "day. GCL is in the process of providing an ANSI compliant image in " #~ "addition to its traditional CLtL1 image still in production use. Setting " #~ "this variable will determine which image you will use by default on " #~ "executing 'gcl'. You can locally override this choice by setting the " #~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " #~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " #~ "may be interested in reviewing the ANSI test results sketching the level " #~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " #~ "The flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL es uno de los sistemas libres de «common lisp» más antiguos que " #~ "todavía se usan. Varios sistemas en producción han estado usándolo " #~ "durante más de una década. Cuando GCL se liberó por primera vez, el " #~ "estándar «common lisp» se conocía como «Common Lisp, the " #~ "Language» (CLtL1) después de un libro escrito por Steele que llevaba el " #~ "mismo nombre y que proporcionaba esta especificación. Posteriormente se " #~ "adoptó en el Instituto Nacional de Estándares Americano (ANSI) un " #~ "estándar más extendido, que todavía se considera la especificación " #~ "definitiva del lenguaje «common lisp» hasta hoy. GCL está en el proceso " #~ "de proporcionar una imagen conforme a ANSI además de su imagen CltL1 " #~ "tradicional que todavía se usa en producción. Al establecer esta variable " #~ "se determinará la imagen por omisión que usará al ejecutar «gcl». Puede " #~ "anular esta elección de forma local mediante el establecimiento de la " #~ "variable de entorno GCL_ANSI a cualquier cadena no vacía para el paquete " #~ "ANSI, y a la cadena vacía para el paquete CLtL1, i.e. GCL_ANSI=t gcl. " #~ "Quizás esté interesado en revisar los resultados de las pruebas ANSI " #~ "describiendo el nivel de conformidad logrado hasta ahora en /usr/share/" #~ "doc/gcl/test_results.gz. Se informará del tipo de paquete usado en el " #~ "anuncio inicial de arranque." gcl-2.6.14/debian/po/fr.po0000644000175000017500000001443514360276512013611 0ustar cammcamm# Translation of gcl debconf templates to French # Copyright (C) 2007 Sylvain Archenault # This file is distributed under the same license as the iodine package. # # Sylvain Archenault , 2007. msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-1\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-23 13:03+0100\n" "Last-Translator: Sylvain Archenault \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-15\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Faut-il utiliser la compilation ANSI par dfaut?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL est en passe de fournir une image respectant la norme ANSI en plus de " "l'image traditionnelle CLtL1, toujours utilise en production." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Veuillez lire le fichier README.Debian pour une brve description de ces " "termes. Le choix de cette option dterminera quelle image sera utilise par " "dfaut en excutant gcl@EXT@." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Ce rglage peut tre chang en affectant la variable d'environnement " "GCL_ANSI une chane non vide pour la compilation ANSI, et une chane vide " "pour la compilation CLtL1, par exemple GCL_ANSI=t gcl@EXT@. Le type de " "compilation sera affich dans le bandeau de dmarrage." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Faut-il utiliser le profilage par dfaut?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL permet optionnellement la gestion du profilage via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Veuillez vous reporter la documentation de si::gprof-start et si::" "gprof-quit pour plus de dtails. Comme cet excutable est plus lent que " "les excutables sans la gestion de gprof, il n'est pas recommand de " "l'utiliser en production." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Veuillez affecter une chane vide la variable d'environnement GCL_PROF " "pour des compilations optimises, ou une chane non vide pour avoir la " "gestion du profilage; par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " "activ, cela sera affich dans le bandeau de dmarrage." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL a pour but de fournir une image conforme la dfinition de " #~ "l'ANSI en plus de son image traditionnelle CLtL1 qui est toujours " #~ "utilise en production. Veuillez consulter le fichier README.Debian " #~ "pour plus d'informations sur ces normes. Ce choix dterminera quelle " #~ "norme vous allez utiliser par dfaut lors de l'excution de " #~ "gcl@EXT@. Vous pouvez localement modifier ce choix en " #~ "affectant une chane non vide la variable d'environnement GCL_ANSI " #~ "pour une compilation respectant la norme dfinie par l'ANSI, et une " #~ "chane vide pour une compilation en accord avec la norme CLtL1, par " #~ "exemple GCL_ANSI=t gcl@EXT@. Le type de compilation sera affich dans " #~ "le bandeau de dmarrage." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL gre dsormais le profilage via gprof. Veuillez consulter la " #~ "documentation de si::gprof-start et de si::gprof-quit pour plus " #~ "d'informations. La construction produite avec cette option est plus lente " #~ "que la construction classique. Par consquent il n'est pas recommand " #~ "de l'utiliser en production. Vous pouvez localement modifier ce choix en " #~ "affectant la variable d'environnement GCL_PROF, une chane non vide " #~ "pour activer le profilage, ou une chane vide pour une compilation " #~ "optimise, par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " #~ "activ, cela sera affich dans le bandeau de dmarrage." gcl-2.6.14/debian/po/nl.po0000644000175000017500000000740014360276512013605 0ustar cammcamm# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-01 21:15+0100\n" "Last-Translator: Bart Cornelis \n" "Language-Team: debian-l10n-dutch \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Dutch\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Wilt u standaard de in-ontwikkeling-zijnde ansi-compilatie gebruiken?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL is bezig om, aanvullend op het traditionele CLtL1-compilatie dat nog " "steeds in gebruik is, een aan ANSI voldoend compilatie te voorzien." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Meer informatie hierover vindt u in het bestand /usr/share/doc/gcl/README." "Debian . Deze optie bepaalt welk compilatie standaard gebruikt wordt wanneer " "u 'gcl@EXT@' uitvoert. " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Deze instelling kan altijd overstegen worden door de omgevingsvariabele " "GCL_ANSI in te stellen op een niet-lege string om de ANSI-compilatie te " "bekomen, en op een lege string om de CLtL1-compilatie te bekomen (bv. " "GCL_ANSI=t gcl@EXT@). De momenteel afgedwongen compilatie-soort wordt " "weergegeven in de initiële opstartbanier." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "" "Wilt u standaard een compilatie met ondersteuning voor profilering gebruiken?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL heeft optionele ondersteuning voor profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Meer informatie vindt u in de documentatie voor si::gprof-start en si::gprof-" "quit . Aangezien compilaties met gprof-ondersteuning trager zijn dan deze " "zonder is dit niet aan te raden voor productie-gebruik." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Om een geoptimaliseerde compilatie te verkrijgen stelt u de " "omgevingsvariabele GCL_PROF in op een lege string, of op een niet-lege " "string als u profilering wilt ondersteunen (bv. GCL_PROF=t gcl@EXT@). Als " "profilering geactiveerd is wordt dit weergegeven in de initiële " "opstartbanier ." gcl-2.6.14/debian/po/templates.pot0000644000175000017500000000451614360276512015363 0ustar cammcamm# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" gcl-2.6.14/debian/po/da.po0000644000175000017500000000714114360276512013562 0ustar cammcamm# Danish translation gcl. # Copyright (C) 2012 gcl & nedenstående oversættere. # This file is distributed under the same license as the gcl package. # Joe Hansen (joedalton2@yahoo.dk), 2012. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2012-03-31 12:42+0000\n" "Last-Translator: Joe Hansen \n" "Language-Team: Danish \n" "Language: da\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Brug den foreløbige ANSI bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL er i gang med at tilbyde et ANSI-overholdende aftryk udover det " "traditionelle CLtL1-aftryk som stadig er i produktionsbrug." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Se venligst filen README.Debian for en kort beskrivelse af disse termer. " "Valg af denne indstilling vil bestemme hvilket aftryk som vil blive brugt " "som standard, når der køres »gcl@EXT@«." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Denne indstilling kan overskrives ved at angive miljøvariablen GCL_ANSI til " "enhver streng der ikke er tom for ANSI-bygningen, og til den tomme streng " "for CLtL1-bygningen, f.eks. GCL_ANSI=t gcl@EXT@. Den aktuelt tvungne " "byggevariant vil blive rapporteret i det oprindelige opstartsbanner." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Brug profileringen bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL har valgfri understøttelse for profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Se venligst dokumentationen for si::gprof-start og si::gprof-quit for " "detaljer. Da denne bygning er langsommere end bygninger uden gprof-" "understøttelse, så anbefales den ikke for endelig produktionsbrug." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Angiv miljøvariablen GCL_PROF til den tomme streng for bedre optimerede " "bygninger, eller enhver streng der ikke er tom for " "profileringsunderstøttelse; f.eks. GCL_PROF=t gcl@EXT@. Hvis profilering er " "aktiveret, vil denne blive rapporteret i det oprindelige opstartsbanner." gcl-2.6.14/debian/po/ja.po0000644000175000017500000000747714360276512013604 0ustar cammcamm# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # victory , 2013. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2013-07-27 14:28+0000\n" "PO-Revision-Date: 2013-07-27 23:28+0900\n" "Last-Translator: victory \n" "Language-Team: Japanese \n" "Language: ja\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "未完成の ANSI ビルドをデフォルトで使用しますか?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL は未だに生産利用されている従来の CLtL1 イメージに加えて ANSI 準拠のイメー" "ジを提供する過程にあります。" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "用語については README.Debian ファイルに簡単な説明があります。このオプションの" "選択「gcl@EXT@」を実行するときにどのイメージをデフォルトで利用するのか決定する" "ことになります。" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "この設定は、GCL_ANSI 環境変数に ANSI ビルドでは空白ではない任意の文字列、" "CLtL1 ビルドでは空白文字列をセットすることで上書きできます。例えば GCL_ANSI=t " "gcl@EXT@。現在実行しているビルドの種類は初期の開始時バナーで報告されます。" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "デフォルトで profiling ビルドを使いますか?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "" "GCL にはオプションで gprof 経由の profiling サポートがあります。" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "詳細については si::gprof-start や si::gprof-quit の文書を見てください。このビ" "ルドは gprof サポートのないビルドより遅いため、最終的な生産利用にはお勧めしま" "せん。" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "ビルドをもっと最適化する場合は GCL_PROF 環境変数に空白文字列を、profiling をサ" "ポートさせる場合は空白ではない任意の文字列をセットしてください。例えば GCL_" "PROF=t gcl@EXT@。profiling が有効な場合、初期の開始時バナーで報告されます。" gcl-2.6.14/debian/po/sv.po0000644000175000017500000000770014360276512013627 0ustar cammcamm# translation of gcl_2.6.7-36.1_sv.po to Swedish # Translators, if you are not familiar with the PO format, gettext # documentation is worth reading, especially sections dedicated to # this format, e.g. by running: # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # Some information specific to po-debconf are available at # /usr/share/doc/po-debconf/README-trans # or http://www.debian.org/intl/l10n/po-debconf/README-trans # Developers do not need to manually edit POT or PO files. # # Martin gren , 2008. msgid "" msgstr "" "Project-Id-Version: gcl_2.6.7-36.1_sv\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-07-24 18:21+0200\n" "Last-Translator: Martin gren \n" "Language-Team: Swedish \n" "Language: sv\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Anvnd det nnu inte frdiga ANSI-bygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL arbetar p att tillhandahlla en ANSI-godknd bild frutom dess " "traditionella CLtL1-bild som fortfarande anvnds i produktionsmiljn." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Se README.Debian-filen fr en versiktlig beskrivning av dessa termer. Nr " "du vljer det hr alternativet avgrs vilken bild som kommer anvndas som " "standard nr 'gcl@EXT@' krs." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Denna instllning kan verskridas genom att stta miljvariabeln GCL_ANSI " "till en icke-tom strng fr ANSI-bygget, och till den tomma strngen fr " "CLtL1-bygget, t. ex. GCL_ANSI=t gcl@EXT@. Det bygge som fr tillfllet " "anvnds kommer anges i uppstartsutskriften." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Anvnd profileringsbygget som standard?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL har valfritt std fr profilering via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Se dokumentationen fr si::gprof-start och si::gprof-quit fr detaljer. " "Eftersom detta bygge r lngsammare n byggen utan std fr gprof, " "rekommenderas det inte fr slutlig anvndning i produktionsmilj." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Stt miljvariabeln GCL_PROF till den tomma strngen fr mer optimiserade " "byggen, eller en icke-tom strng fr profileringsstd; t. ex. GCL_PROF=t " "gcl@EXT@. Om profilering r aktiverad, kommer denna rapporteras i den " "ursprungliga uppstartsutskriften." gcl-2.6.14/debian/po/ru.po0000644000175000017500000001077214360276512013630 0ustar cammcamm# translation of ru.po to Russian # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # # Yuri Kozlov , 2008. msgid "" msgstr "" "Project-Id-Version: 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-03 10:22+0300\n" "Last-Translator: Yuri Kozlov \n" "Language-Team: Russian \n" "Language: ru\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" "Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n" "%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Использовать разрабатываемую ANSI сборку по умолчанию?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Помимо обычного образа CLtL1, используемого в повсеместной работе, GCL имеет " "практически готовый образ, соответствующий ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Краткое описание приведено в файле README.Debian. Данным выбором " "определяется, какой из образов будет использован по умолчанию при выполнении " "'gcl@EXT@'." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Эта настройка может быть переопределена установкой переменной окружения " "GCL_ANSI в непустое значение для ANSI сборки, а пустым значением выбирается " "CLtL1 сборка, например GCL_ANSI=t gcl@EXT@. Текущий используемый тип сборки " "будет показан при первом запуске." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Использовать по умолчанию профилируемую сборку?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL поддерживает необязательное профилирование через gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Подробней об этом смотрите в документации на si::gprof-start и si::gprof-" "quit. Так как данная сборка работает медленнее чем без поддержки gprof, её " "не рекомендуется использовать в реальной работе." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Задание переменной окружения GCL_PROF пустого значения включает более " "оптимизированную сборку, а любое непустое -- поддержку профилирования; " "например GCL_PROF=t gcl@EXT@. Если профилирование включено, то об этом будет " "написано при первом запуске." gcl-2.6.14/debian/po/cs.po0000644000175000017500000001445314360276512013607 0ustar cammcamm# # Translators, if you are not familiar with the PO format, gettext # documentation is worth reading, especially sections dedicated to # this format, e.g. by running: # info -n '(gettext)PO Files' # info -n '(gettext)Header Entry' # # Some information specific to po-debconf are available at # /usr/share/doc/po-debconf/README-trans # or http://www.debian.org/intl/l10n/po-debconf/README-trans # # Developers do not need to manually edit POT or PO files. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-24 13:21+0100\n" "Last-Translator: Miroslav Kure \n" "Language-Team: Czech \n" "Language: cs\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Používat implicitně ANSI verzi (stále ve vývoji)?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL se nachází ve fázi, kdy kromě tradičního obrazu CLtL1 (který se stále " "používá) poskytuje i obraz kompatibilní s ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Pro stručný popis těchto termínů si prosím přečtěte soubor README.Debian. " "Touto odpovědí určujete, který obraz se spustí po zadání „gcl@EXT@“. " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Toto nastavení můžete přebít nastavením proměnné prostředí GCL_ANSI na " "neprázdný řetězec (použije ANSI verzi) nebo na prázdnou hodnotu (použije " "CLtL1 verzi). Například GCL_ANSI=t gcl@EXT@. Aktuálně použitá verze se " "zobrazí na úvodní obrazovce." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Používat implicitně profilování?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL nyní podporuje profilování přes gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Podrobnosti naleznete v dokumentaci si::gprof-start a si::gprof-quit. Tato " "verze je pomalejší než verze bez podpory gprof, tudíž ji nedoporučujeme pro " "koncové produkční nasazení." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Toto nastavení můžete přebít nastavením proměnné prostředí GCL_PROF na " "neprázdný řetězec (zapne profilování) nebo na prázdnou hodnotu (povolí lepší " "optimalizace). Například GCL_PROF=t gcl@EXT@. Pokud je profilování zapnuto, " "dozvíte se o tom z úvodní obrazovky." #~ msgid "" #~ "GCL is one of the oldest free common lisp systems still in use. Several " #~ "production systems have used it for over a decade. The common lisp " #~ "standard in effect when GCL was first released is known as \"Common Lisp, " #~ "the Language\" (CLtL1) after a book by Steele of the same name providing " #~ "this specification. Subsequently, a much expanded standard was adopted " #~ "by the American National Standards Institute (ANSI), which is still " #~ "considered the definitive common lisp language specification to this " #~ "day. GCL is in the process of providing an ANSI compliant image in " #~ "addition to its traditional CLtL1 image still in production use. Setting " #~ "this variable will determine which image you will use by default on " #~ "executing 'gcl'. You can locally override this choice by setting the " #~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " #~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " #~ "may be interested in reviewing the ANSI test results sketching the level " #~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " #~ "The flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL je jedním z nejstarších svobodných systémů common lispu, který se " #~ "dosud používá. Několik produkčních systémů jej používá déle než dekádu. " #~ "Při prvním vydání GCL byl v platnosti standard common lispu známý jako " #~ "\"Common Lisp, the Language\" (CLtL1) pojmenovaný podle Steelovy knihy " #~ "stejného jména, která tento standard definovala. Americkým národním " #~ "institutem pro standardizaci (ANSI) pak byl přijat podstatně rozšířený " #~ "standard, který se do dnešní doby považuje za konečnou specifikaci common " #~ "lispu. Kromě tradičního CLtL1 se GCL snaží nabídnout i verzi odpovídající " #~ "ANSI standardu. Nastavením této proměnné určíte, jakým způsobem se má " #~ "binárka 'gcl' chovat. Lokálně můžete toto nastavení přepsat nastavením " #~ "proměnné prostředí GCL_ANSI na neprázdný řetězec (zapne ANSI chování) " #~ "nebo na prázdnou hodnotu (zapne CLtL1 chování). Například GCL_ANSI-t gcl. " #~ "Aktuálně vybraný standard bude zobrazen v úvodní obrazovce prostředí. " #~ "Zajímavé může být porovnání dosud dosažené shody s ANSI standardem v " #~ "souboru /usr/share/doc/gcl/test_results.gz." gcl-2.6.14/debian/po/it.po0000644000175000017500000000734514360276512013620 0ustar cammcamm# ITALIAN TRANSLATION OF GCL'S PO-DEBCONF FILE. # COPYRIGHT (C) 2009 THE GCL'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # # Vincenzo Campanella , 2009. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2009-11-29 08:39+0100\n" "Last-Translator: Vincenzo Campanella \n" "Language-Team: Italian \n" "Language: it\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "" "Usare in modo predefinito la compilazione ANSI, che è in fase di " "approntamento?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "Accanto all'immagine tradizionale CLtL1, in uso in realtà produttive, GCL " "sta preparando un'immagine conforme ad ANSI." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Per maggiori informazioni consultare il file «README.Debian». La scelta di " "questa opzione determinerà quale immagine verrà utilizzata in modo " "predefinito durante l'esecuzione di «gcl@EXT@»." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Questa impostazione può essere sovrascritta impostando la variabile " "d'ambiente «GCL_ANSI» con una stringa non vuota per la compilazione ANSI e " "con una stringa vuota per la compilazione CLtL1, per esempio: «GCL_ANSI=t " "gcl@EXT@». Il tipo di compilazione attualmente in uso viene mostrato nella " "schermata di avvio." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usare il profiling in modo predefinito?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL possiede un supporto opzionale per il profiling tramite gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Per maggiori dettagli consultare la documentazione per «si::gprof-start» e " "«si::gprof-quit». Poiché questa compilazione è più lenta, rispetto a quella " "senza supporto per gprof, non è raccomandata per un utilizzo in realtà " "produttive." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Per compilazioni ottimizzate impostare la variabile d'ambiente «GCL_PROF» a " "una stringa vuota, oppure per impostare il supporto al profiling impostarla " "a una stringa non vuota, per esempio «GCL_PROF=t gcl@EXT@». La schermata " "d'avvio indicherà se il profiling è abilitato." gcl-2.6.14/debian/po/pt_BR.po0000644000175000017500000000725614360276512014213 0ustar cammcamm# Debconf translations for gcl. # Copyright (C) 2016 THE gcl'S COPYRIGHT HOLDER # This file is distributed under the same license as the gcl package. # Adriano Rafael Gomes , 2016. # msgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2016-01-05 11:09-0200\n" "Last-Translator: Adriano Rafael Gomes \n" "Language-Team: Brazilian Portuguese \n" "Language: pt_BR\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Usar a versão ANSI em desenvolvimento por padrão?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "O GCL está em processo de fornecer uma imagem de acordo com o padrão ANSI em " "adição à sua imagem CLtL1 tradicional, ainda em uso em produção." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Por favor, veja o arquivo README.Debian para uma breve descrição desses " "termos. Escolher essa opção determinará qual imagem será usada por padrão ao " "executar \"gcl@EXT@\"." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Essa configuração pode ser sobreposta definindo a variável de ambiente " "GCL_ANSI para qualquer texto não vazio para a versão ANSI, e para um texto " "vazio para a versão CLtL1, por exemplo, GCL_ANSI=t gcl@EXT@. O sabor da " "versão atualmente definida será exibida na mensagem de inicialização." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usar a versão de \"profiling\" por padrão?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "O GCL tem suporte opcional a \"profiling\" via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Por favor, veja a documentação para si::gprof-start e si::gprof-quit para " "detalhes. Como essa versão é mais lenta que versões sem suporte a gprof, ela " "não é recomendada para uso final em produção." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Defina a variável de ambiente GCL_PROF para um texto vazio para versões mais " "otimizadas, ou para qualquer texto não vazio para ter suporte a \"profiling" "\"; por exemplo, GCL_PROF=t gcl@EXT@. Se o \"profiling\" estiver habilitado, " "isso será exibido na mensagem de inicialização." gcl-2.6.14/debian/po/de.po0000644000175000017500000001435314360276512013571 0ustar cammcamm# Translation of gcl debconf templates to German # Copyright (C) Stefan Bauer , 2007. # Copyright (C) Helge Kreutzmann , 2007, 2008. # This file is distributed under the same license as the gcl package. # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-09 11:49+0100\n" "Last-Translator: Stefan Bauer \n" "Language-Team: de \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-15\n" "Content-Transfer-Encoding: 8bit\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Verwende standardmig den sich in Arbeit befindlichen ANSI-Build?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL ist derzeit dabei, zustzlich zu dem noch im Einsatz befindlichen " "traditionellen CLtL1-Image ein ANSI-konformes Image bereitzustellen." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Bitte lesen Sie die Datei README.Debian fr eine kurze Beschreibung dieser " "Begriffe. Die Wahl dieser Option bestimmen, welches Image standardmig " "verwendet wird, wenn gcl@EXT@ ausgefhrt wird." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Diese Einstellung kann mit der Umgebungsvariablen GCL_ANSI berschrieben " "werden. Jede nicht-leere Zeichenkette fhrt zur ANSI-Erstellung, und die " "leere Zeichenkette fhrt zum CLtL1-Bau, z.B. GCL_ANSI=t gcl@EXT@. In der " "Startmeldung wird die derzeit erzwungene Bauart berichtet." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Verwende standardmig den Profiling-Build?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL besitzt optionale Untersttzung fr Profiling mittels Gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Bitte lesen Sie die Dokumentation fr si::gprof-start und si::gprof-quit fr " "Details. Da ein solches Programm langsamer ist als ein Programm ohne Gprof-" "Untersttzung, wird dies fr den Produktiveinsatz nicht empfohlen." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Setzen Sie die Umgebungsvariable GCL_PROF auf die leere Zeichenkette, um ein " "optimiertes Programm zu erhalten oder auf irgendeine nicht-leere " "Zeichenkette, fr Profiling-Untersttzung; z.B. GCL_PROF=t gcl@EXT@. Falls " "Profiling aktiviert ist, wird dies in der Startmeldung angezeigt." #~ msgid "" #~ "GCL is in the process of providing an ANSI compliant image in addition to " #~ "its traditional CLtL1 image still in production use. Please see the " #~ "README.Debian file for a brief description of these terms. Setting this " #~ "variable will determine which image you will use by default on executing " #~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " #~ "environment variable to any non-empty string for the ANSI build, and to " #~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " #~ "flavor of the build in force will be reported in the initial startup " #~ "banner." #~ msgstr "" #~ "GCL arbeitet neben dem traditionellen CLtL1-Image fr den " #~ "Produktiveinsatz zustzlich an der Bereitstellung eines kompatiblen ANSI-" #~ "Images. Bitte beachten Sie die README.Debian-Datei fr eine kurze " #~ "Beschreibung dieses Themas. Durch diese Variable definieren Sie, welches " #~ "Image voreingestellt bei der Ausfhrung von gcl@EXT@ verwendet wird. " #~ "Diese Auswahl kann lokal, durch einen nicht leeren Wert in der " #~ "Umgebungsvariable GCL_ANSI fr den ANSI-Build, bzw. einen leeren Wert " #~ "fr den CLtL1-Build, z.B. GCL_ANSI=t gcl@EXT@ definiert werden. Es " #~ "erfolgt eine Meldung ber die aktive Erstellung im einfhrenden Start-" #~ "Banner." #~ msgid "" #~ "GCL now has optional support for profiling via gprof. Please see the " #~ "documentation for si::gprof-start and si::gprof-quit for details. As this " #~ "build is slower than builds without gprof support, it is not recommended " #~ "for final production use. You can locally override the default choice " #~ "made here by setting the GCL_PROF environment variable to any non-empty " #~ "string for profiling support, and to the empty string for the more " #~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " #~ "this will be reported in the initial startup banner." #~ msgstr "" #~ "GCL besitzt optionale Untersttzung fr Profiling mit gprof. Bitte lesen " #~ "Sie hierzu die Dokumentation von si::gprof-start und si::gprof-quit fr " #~ "weiterfhrende Informationen. Da dieser Build langsamer ist als ohne " #~ "gprof-Untersttzung, wird dieser Weg nicht fr den endgltig produktiven " #~ "Einsatz empfohlen. Sie knnen die hier gemachten Angaben lokal ber die " #~ "GCL_PROF-Umgebungsvariable durch einen beliebigen Wert ndern, bzw. durch " #~ "einen leeren Wert fr das weitaus anpassungsfhigere Build, z.B. " #~ "GCL_PROF=t gcl@EXT@. Falls Profiling aktiviert ist, erfolgt eine Meldung " #~ "im einfhrenden Start-Banner." gcl-2.6.14/debian/po/vi.po0000644000175000017500000001011414360276512013606 0ustar cammcamm# Vietnamese translation for GCL. # Copyright © 2007 Free Software Foundation, Inc. # Clytie Siddall , 2007 # msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2008-01-04 16:27+1030\n" "Last-Translator: Clytie Siddall \n" "Language-Team: Vietnamese \n" "Language: vi\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" "X-Generator: LocFactoryEditor 1.7b1\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Dùng bản xây dựng đang phát triển ANSI theo mặc định không?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL đang phát triển chức năng cung cấp ảnh tùy theo ANSI thêm vào ảnh CLtL1 " "truyền thống vẫn còn được sử dụng trong trường hợp sản xuất." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Xem tài liệu Đọc Đi (README.Debian) để tìm mô tả ngắn về các thuật ngữ này. " "Bật tùy chọn này thì xác định ảnh nào cần dùng theo mặc định khi thực hiện " "lệnh « gcl@EXT@ »." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Vẫn còn có thể ghi đè lên thiết lập này bằng cách đặt biến môi trường « " "GCL_ANSI » thành bắt cứ chuỗi không rỗng cho bản xây dựng ANSI, và cho chuỗi " "rỗng cho bản xây dựng CLtL1, v.d. « GCL_ANSI=t gcl@EXT@ ». Kiểu bản xây dựng " "hiện thời được chọn sẽ được thông báo trên băng cờ khởi chạy đầu tiên." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Dùng bản xây dựng đo hiệu năng sử dụng theo mặc định không?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL có hỗ trợ tùy chọn để đo hiệu năng sử dụng thông qua gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Xem tài liệu hướng dẫn về « si::gprof-start » và « si::gprof-quit » để tìm " "chi tiết. Vì bản xây dựng này chạy chậm hơn các bản xây dựng không hỗ trợ " "gprof, không khuyên bạn sử dụng nó trong trường hợp sản xuất cuối cùng." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Đặt biến môi trường « GCL_PROF » thành chuỗi rỗng cho các bản xây dựng tối " "ưu hơn, hoặc cho bất cứ chuỗi không rỗng nào để hỗ trợ chức năng đo hiệu " "năng sử dụng, v.d. « GCL_PROF=t gcl@EXT@ ». Hiệu lực chức năng đo hiệu năng " "sử dụng thì nó được thông báo trên băng cờ khởi chạy đầu tiên." gcl-2.6.14/debian/po/pt.po0000644000175000017500000000743014360276512013622 0ustar cammcamm# translation of gcl debconf to Portuguese # Copyright (C) 2007 Américo Monteiro # This file is distributed under the same license as the gcl package. # # Américo Monteiro , 2007. msgid "" msgstr "" "Project-Id-Version: gcl 2.6.7-36\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-23 16:44+0000\n" "Last-Translator: Américo Monteiro \n" "Language-Team: Portuguese \n" "Language: pt\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Generator: KBabel 1.11.4\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Usar a compilação 'ainda em desenvolvimento' ANSI por prédefinição? " #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL está no processo de disponibilizar uma imagem compatível com ANSI como " "adição à sua imagem tradicional CLtL1 ainda em utilização de produção." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Por favor veja o ficheiro README.Debian para uma breve descrição destes " "termos. Escolher esta opção irá determinar qual imagem será usada por " "prédefinição ao executar 'gcl@EXT@'." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Esta opção pode ser sobreposta ao regular a variável de ambiente GCL_ANSI " "para qualquer string não-vazia para a compilação ANSI, e para uma string " "vazia para a compilação CLtL1, como por exemplo GCL_ANSI=t gcl@EXT@. O tipo " "de compilação actualmente imposto será reportado no banner inicial de " "arranque." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Usar, como pré-definição, a compilação com 'profiling'?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "O GCL tem suporte opcional para 'profiling' via gprof." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Por favor veja a documentação de si::gprof-start e si::gprof-quit para mais " "detalhes. Como esta compilação é mais lenta do que as compilações sem o " "suporte para gprof, não é recomendada para utilização de produção final." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Regule a variável de ambiente GCL_PROF para uma string vazia para mais " "compilações optimizadas, ou para qualquer string não-vazia para suporte de " "'profiling'; como por exemplo GCL_PROF=t gcl@EXT@. Se o 'profiling' estiver " "activo, isto será reportado no banner inicial de arranque." gcl-2.6.14/debian/po/fi.po0000644000175000017500000000702314360276512013573 0ustar cammcammmsgid "" msgstr "" "Project-Id-Version: gcl\n" "Report-Msgid-Bugs-To: gcl@packages.debian.org\n" "POT-Creation-Date: 2012-12-30 11:53-0400\n" "PO-Revision-Date: 2007-12-29 23:28+0200\n" "Last-Translator: Esko Arajärvi \n" "Language-Team: Finnish \n" "Language: fi\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "X-Poedit-Language: Finnish\n" "X-Poedit-Country: Finland\n" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "Use the work-in-progress ANSI build by default?" msgstr "Käytetäänkö kehitettävää ANSI-käännöstä oletuksena?" #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "GCL is in the process of providing an ANSI compliant image in addition to " "its traditional CLtL1 image still in production use." msgstr "" "GCL:n on tarkoitus tarjota ANSI-yhteensopiva kuva perinteisen, vielä " "tuotantokäytössä olevan CLtL1-kuvan lisäksi." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "Please see the README.Debian file for a brief description of these terms. " "Choosing this option will determine which image will be used by default when " "executing 'gcl@EXT@'." msgstr "" "Tiedostosta README.Debian löytyy (englanniksi) näiden termien lyhyet " "kuvaukset. Tämä valinta vaikuttaa siihen mitä kuvaa käytetään oletuksena " "ajettaessa ”gcl@EXT@”." #. Type: boolean #. Description #: ../gcl.templates:2001 msgid "" "This setting may be overridden by setting the GCL_ANSI environment variable " "to any non-empty string for the ANSI build, and to the empty string for the " "CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " "will be reported in the initial startup banner." msgstr "" "Tämä asetus voidaan ohittaa asettamalla GCL_ANSI-ympäristömuuttuja. Jos " "muuttujan arvo on mikä tahansa ei-tyhjä merkkijono, käytetään ANSI-" "käännöstä, ja jos muuttujan arvo on tyhjä merkkijono, käytetään CLtL1-" "käännöstä. Esimerkiksi: GCL_ANSI=t gcl@EXT@. Käytetty pakotettu käännöstapa " "raportoidaan käynnistysruudussa." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "Use the profiling build by default?" msgstr "Käytetäänkö profilointia oletuksena?" #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "GCL has optional support for profiling via gprof." msgstr "GCL tukee valinnaisesti profilointia gprofin avulla." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Please see the documentation for si::gprof-start and si::gprof-quit for " "details. As this build is slower than builds without gprof support, it is " "not recommended for final production use." msgstr "" "Katso yksityiskohdat (englanniksi) dokumentaatiosta kohdista si::gprof-start " "ja si::gprof-quit. Koska tämä käännös on hitaampi kuin käännökset ilman " "gprof-tukea, tätä ei suositella tuotantokäyttöön." #. Type: boolean #. Description #: ../gcl.templates:3001 msgid "" "Set the GCL_PROF environment variable to the empty string for more optimized " "builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " "gcl@EXT@. If profiling is enabled, this will be reported in the initial " "startup banner." msgstr "" "Aseta GCL_PROF-ympäristömuuttuja tyhjäksi merkkijonoksi käyttääksesi " "optimoidumpia käännöksiä ja miksi tahansa ei-tyhjäksi merkkijonoksi " "käyttääksesi profilointia. Esimerkiksi: GCL_PROF=t gcl@EXT@. Jos profilointi " "on aktivoituna, se raportoidaan käynnistysruudussa." gcl-2.6.14/debian/compat0000644000175000017500000000000314360276512013414 0ustar cammcamm13 gcl-2.6.14/debian/in.gcl-doc.doc-base.si0000644000175000017500000000063114360276512016143 0ustar cammcammDocument: gcl@EXT@-si-doc Title: GNU Common Lisp Documentation -- System Internals Author: W. Schelter Abstract: Documentation on GCL-specific Lisp system functions Section: Programming Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/gcl-si/index.html Files: /usr/share/doc/gcl@EXT@-doc/gcl-si/*.html gcl-2.6.14/debian/in.gcl-doc.doc-base.xgcl0000644000175000017500000000065314360276512016471 0ustar cammcammDocument: gcl@EXT@-xgcl-doc Title: GNU Common Lisp Documentation -- System Internals Author: W. Schelter Abstract: Documentation on GCL-specific Lisp system functions Section: Programming Format: Text Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.tex.gz Format: PDF Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.pdf.gz Format: HTML Index: /usr/share/doc/gcl@EXT@-doc/dwdoc/dwdoc1.html Files: /usr/share/doc/gcl@EXT@-doc/dwdoc/*.html gcl-2.6.14/debian/control0000644000175000017500000000275414360276512013630 0ustar cammcammSource: gcl Section: lisp Priority: optional Maintainer: Camm Maguire Homepage: http://gnu.org/software/gcl Build-Depends: debhelper (>= 13), libeditreadline-dev, m4, tk8.6-dev, libgmp-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev, tcl, binutils-dev Standards-Version: 4.5.0 Package: gcl Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs | emacsen, ucf Breaks: emacsen-common (<< 2.0.0) Suggests: gcl-doc Description: GNU Common Lisp compiler GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains the Lisp system itself. Documentation is provided in the gcl-doc package. Package: gcl-doc Section: doc Architecture: all Conflicts: gclinfo Replaces: gclinfo Depends: dpkg (>= 1.15.4), ${misc:Depends} Description: Documentation for GNU Common Lisp GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter implemented in C, and complying mostly with the standard set forth in the book "Common Lisp, the Language I". It attempts to strike a useful middle ground in performance and portability from its design around C. . This package contains Documentation in info format of both the system internals, as well as the graphical interface currently implemented in Tcl/Tk. gcl-2.6.14/debian/changelog0000644000175000017500000040722014360276512014074 0ustar cammcammgcl (2.6.14-1) unstable; urgency=medium * New Upstream Release -- Camm Maguire Fri, 13 Jan 2023 10:43:17 -0500 gcl (2.6.13-6) unstable; urgency=medium * Version_2_6_14pre5 -- Camm Maguire Sun, 08 Jan 2023 09:49:13 -0500 gcl (2.6.13-5) unstable; urgency=medium * Version_2_6_14pre4 -- Camm Maguire Sun, 25 Dec 2022 07:14:33 -0500 gcl (2.6.13-4) unstable; urgency=medium * Version_2_6_14pre3 -- Camm Maguire Fri, 23 Dec 2022 11:34:35 -0500 gcl (2.6.13-3) unstable; urgency=medium * Version_2_6_14pre2 -- Camm Maguire Thu, 22 Dec 2022 19:09:24 -0500 gcl (2.6.13-2) unstable; urgency=medium * Version_2_6_14pre1 -- Camm Maguire Wed, 21 Dec 2022 14:40:21 -0500 gcl (2.6.13-1) unstable; urgency=medium * New Upstream Release -- Camm Maguire Tue, 20 Dec 2022 10:35:44 -0500 gcl (2.6.12-131) unstable; urgency=medium * Version_2.6.13pre131 -- Camm Maguire Sat, 17 Dec 2022 12:15:58 -0500 gcl (2.6.12-130) unstable; urgency=medium * Version_2.6.13pre130 -- Camm Maguire Fri, 16 Dec 2022 12:41:29 -0500 gcl (2.6.12-129) unstable; urgency=medium * Version_2.6.13pre129 -- Camm Maguire Sun, 13 Nov 2022 07:55:14 -0500 gcl (2.6.12-128) unstable; urgency=medium * Version_2.6.13pre128 -- Camm Maguire Sat, 12 Nov 2022 11:02:31 -0500 gcl (2.6.12-126) unstable; urgency=medium * Version_2.6.13pre126 -- Camm Maguire Tue, 08 Nov 2022 19:43:41 -0500 gcl (2.6.12-125) unstable; urgency=medium * Version_2.6.13pre125 -- Camm Maguire Tue, 08 Nov 2022 15:33:25 -0500 gcl (2.6.12-124) unstable; urgency=medium * Version_2.6.13pre124 -- Camm Maguire Thu, 11 Aug 2022 13:16:42 -0400 gcl (2.6.12-123) unstable; urgency=medium * Version_2.6.13pre123 -- Camm Maguire Mon, 08 Aug 2022 13:00:55 -0400 gcl (2.6.12-122) unstable; urgency=medium * Version_2.6.13pre122 -- Camm Maguire Mon, 08 Aug 2022 11:50:22 -0400 gcl (2.6.12-121) unstable; urgency=medium * Version_2.6.13pre121 -- Camm Maguire Mon, 08 Aug 2022 11:45:30 -0400 gcl (2.6.12-120) unstable; urgency=medium * Version_2.6.13pre120 -- Camm Maguire Sun, 07 Aug 2022 12:26:10 -0400 gcl (2.6.12-119) unstable; urgency=medium * Version_2.6.13pre119 -- Camm Maguire Sun, 31 Jul 2022 12:00:02 -0400 gcl (2.6.12-118) unstable; urgency=medium * Bug fix: "emacs dependency should be "emacs | emacsen"", thanks to Adrian Bunk (Closes: #1006617). * Bug fix: "Please remove dependency on install-info", thanks to hille42@web.de; (Closes: #1013691). * Version_2.6.13pre118 -- Camm Maguire Tue, 12 Jul 2022 17:17:09 -0400 gcl (2.6.12-117) unstable; urgency=medium * Version_2.6.13pre114 -- Camm Maguire Sat, 25 Dec 2021 11:38:16 -0500 gcl (2.6.12-116) unstable; urgency=medium * Version_2.6.13pre113 -- Camm Maguire Wed, 22 Dec 2021 19:52:18 +0000 gcl (2.6.12-115) unstable; urgency=medium * Version_2.6.13pre112 -- Camm Maguire Fri, 17 Dec 2021 16:08:45 +0000 gcl (2.6.12-114) unstable; urgency=medium * Version_2.6.13pre111 -- Camm Maguire Thu, 16 Dec 2021 11:35:04 +0000 gcl (2.6.12-113) unstable; urgency=medium * Version_2.6.13pre110 -- Camm Maguire Thu, 16 Dec 2021 11:35:04 +0000 gcl (2.6.12-112) unstable; urgency=medium * Version_2.6.13pre109 -- Camm Maguire Wed, 15 Dec 2021 19:39:42 +0000 gcl (2.6.12-111) unstable; urgency=medium * Version_2.6.13pre108 -- Camm Maguire Thu, 11 Nov 2021 17:10:43 +0000 gcl (2.6.12-110) unstable; urgency=medium * Version_2.6.13pre107 -- Camm Maguire Thu, 11 Nov 2021 01:34:07 +0000 gcl (2.6.12-109) unstable; urgency=medium * Version_2.6.13pre106 -- Camm Maguire Wed, 10 Nov 2021 18:57:21 +0000 gcl (2.6.12-108) unstable; urgency=medium * Version_2.6.13pre105 -- Camm Maguire Tue, 09 Nov 2021 18:22:58 +0000 gcl (2.6.12-107) unstable; urgency=medium * Version_2.6.13pre103 -- Camm Maguire Tue, 09 Nov 2021 10:10:19 +0000 gcl (2.6.12-106) unstable; urgency=medium * Version_2.6.13pre102 -- Camm Maguire Thu, 04 Nov 2021 14:33:53 +0000 gcl (2.6.12-105) unstable; urgency=medium * Version_2.6.13pre101 * Bug fix: "fails to start with glibc 2.33", thanks to Andreas Kloeckner (Closes: #995323). -- Camm Maguire Sun, 10 Oct 2021 13:18:39 +0000 gcl (2.6.12-104) unstable; urgency=medium * Version_2.6.13pre100 * standardize cstack start address on 32bit arm -- Camm Maguire Sun, 10 Oct 2021 12:44:51 +0000 gcl (2.6.12-103) unstable; urgency=medium * Bug fix: "Fails to install in unstable", thanks to Samuel Thibault (Closes: #993480). -- Camm Maguire Sat, 04 Sep 2021 19:23:26 +0000 gcl (2.6.12-102) unstable; urgency=medium * Version_2.6.13pre99 * Bug fix: "describe fails because gcl-si.info does not exist", thanks to Leo Butler (Closes: #980003). -- Camm Maguire Fri, 29 Jan 2021 19:08:05 +0000 gcl (2.6.12-101) unstable; urgency=medium * Version_2.6.13pre98 -- Camm Maguire Sun, 17 Jan 2021 16:25:34 +0000 gcl (2.6.12-100) unstable; urgency=medium * Version_2.6.13pre97 -- Camm Maguire Fri, 04 Dec 2020 14:51:41 +0000 gcl (2.6.12-99) unstable; urgency=medium * Version_2.6.13pre95 -- Camm Maguire Sat, 28 Nov 2020 15:50:42 +0000 gcl (2.6.12-98) unstable; urgency=medium * Version_2.6.13pre94 -- Camm Maguire Tue, 29 Sep 2020 18:29:10 +0000 gcl (2.6.12-97) unstable; urgency=medium * Bug fix: "Removal of obsolete debhelper compat 5 and 6 in bookworm", thanks to Niels Thykier (Closes: #965543). * Version_2.6.13pre93 -- Camm Maguire Sat, 29 Aug 2020 16:23:07 +0000 gcl (2.6.12-96) unstable; urgency=high * Version_2.6.13pre92: Work around armhf strip bug producing undefined instruction in .plt -- Camm Maguire Sun, 23 Aug 2020 17:53:14 +0000 gcl (2.6.12-95) unstable; urgency=high * Version_2_6_13pre90 * build under GCL_MEM_MULTIPLE=0.1 * Bug fix: "FTBFS: Unrecoverable error: Segmentation violation..", thanks to Lucas Nussbaum (Closes: #952334). -- Camm Maguire Fri, 01 May 2020 12:55:02 +0000 gcl (2.6.12-94) unstable; urgency=medium * re-release to overcome hopefully transient buildd failure -- Camm Maguire Mon, 24 Feb 2020 20:02:52 +0000 gcl (2.6.12-93) unstable; urgency=medium * Version_2_6_13pre90 -- Camm Maguire Fri, 21 Feb 2020 19:06:56 +0000 gcl (2.6.12-92) unstable; urgency=medium * Version_2_6_13pre89 -- Camm Maguire Mon, 30 Dec 2019 15:46:22 +0000 gcl (2.6.12-91) unstable; urgency=medium * Version_2_6_13pre88 -- Camm Maguire Wed, 18 Dec 2019 20:14:09 +0000 gcl (2.6.12-90) unstable; urgency=medium * Version_2_6_13pre87 * latest standards -- Camm Maguire Sun, 08 Dec 2019 19:27:24 +0000 gcl (2.6.12-89) unstable; urgency=medium * Bug fix: "gcl - FTBFS on ppc64el - invalid relocation type 31", thanks to thierry.fauck@fr.ibm.com; (Closes: #942312). * Bug fix: "FTBFS on ppc64el", thanks to Ivo De Decker (Closes: #944651). -- Camm Maguire Sat, 07 Dec 2019 23:27:53 +0000 gcl (2.6.12-88) unstable; urgency=medium * Source only upload -- Camm Maguire Fri, 11 Oct 2019 19:18:44 +0000 gcl (2.6.12-87) unstable; urgency=medium * Version_2_6_13pre84 -- Camm Maguire Sat, 06 Apr 2019 13:03:21 +0000 gcl (2.6.12-86) unstable; urgency=medium * Version_2_6_13pre83 -- Camm Maguire Tue, 02 Apr 2019 19:57:15 +0000 gcl (2.6.12-85) unstable; urgency=medium * Version_2_6_13pre82 -- Camm Maguire Thu, 28 Mar 2019 18:48:55 +0000 gcl (2.6.12-84) unstable; urgency=medium * Version_2_6_13pre80 -- Camm Maguire Thu, 21 Mar 2019 18:59:40 +0000 gcl (2.6.12-83) unstable; urgency=high * Version_2_6_13pre79 * Fix acl2 arm builds (Closes: #919477). -- Camm Maguire Tue, 05 Feb 2019 21:54:42 +0000 gcl (2.6.12-82) unstable; urgency=high * Version_2_6_13pre74 -- Camm Maguire Sat, 02 Feb 2019 17:40:20 +0000 gcl (2.6.12-81) unstable; urgency=high * Version_2_6_13pre72 * Fix to ppc64el for acl2 FTBFS bug -- Camm Maguire Mon, 21 Jan 2019 16:40:36 +0000 gcl (2.6.12-80) unstable; urgency=medium * Version_2_6_13pre71 * Bug fix: "FTBFS on hppa - segmentation fault assembling gbc.s", thanks to John David Anglin (Closes: #912071). -- Camm Maguire Tue, 30 Oct 2018 17:20:43 +0000 gcl (2.6.12-79) unstable; urgency=medium * Version_2_6_13pre70 -- Camm Maguire Mon, 29 Oct 2018 16:52:17 +0000 gcl (2.6.12-78) unstable; urgency=medium * rebuild against latest compilers and tools * Version_2_6_13pre69 -- Camm Maguire Thu, 11 Oct 2018 16:40:48 +0000 gcl (2.6.12-77) unstable; urgency=medium * Version_2_6_13pre68 * Bug fix: "GCL fails to load .o files it generates", thanks to Gong-Yi Liao (Closes: #902475). Add support for R_X86_64_PLT32 relocs. -- Camm Maguire Tue, 24 Jul 2018 20:06:45 +0000 gcl (2.6.12-76) unstable; urgency=medium * Version_2_6_13pre67 -- Camm Maguire Fri, 23 Mar 2018 19:25:22 +0000 gcl (2.6.12-75) unstable; urgency=medium * Version_2_6_13pre65 -- Camm Maguire Wed, 21 Mar 2018 20:28:08 +0000 gcl (2.6.12-74) unstable; urgency=medium * Version_2_6_13pre63 -- Camm Maguire Sat, 17 Mar 2018 11:56:05 +0000 gcl (2.6.12-73) unstable; urgency=medium * Version_2_6_13pre62 -- Camm Maguire Wed, 14 Mar 2018 15:38:43 +0000 gcl (2.6.12-72) unstable; urgency=medium * Version_2_6_13pre61 -- Camm Maguire Tue, 13 Mar 2018 15:32:44 +0000 gcl (2.6.12-71) unstable; urgency=medium * Version_2_6_13pre60 -- Camm Maguire Mon, 12 Mar 2018 19:44:47 +0000 gcl (2.6.12-70) unstable; urgency=medium * Version_2_6_13pre59 -- Camm Maguire Mon, 12 Mar 2018 16:19:00 +0000 gcl (2.6.12-69) unstable; urgency=medium * Version_2_6_13pre58 -- Camm Maguire Fri, 09 Mar 2018 17:10:51 +0000 gcl (2.6.12-68) unstable; urgency=medium * Version_2_6_13pre57 -- Camm Maguire Sun, 04 Mar 2018 13:21:00 +0000 gcl (2.6.12-67) unstable; urgency=medium * Version_2_6_13pre55 -- Camm Maguire Sat, 03 Mar 2018 14:27:51 +0000 gcl (2.6.12-66) unstable; urgency=medium * Version_2_6_13pre54 -- Camm Maguire Fri, 02 Mar 2018 21:19:03 +0000 gcl (2.6.12-65) unstable; urgency=medium * Version_2_6_13pre52 * Bug fix: "FTBFS on hurd-i386", thanks to svante.signell@gmail.com; (Closes: #802593). -- Camm Maguire Fri, 23 Feb 2018 15:55:23 +0000 gcl (2.6.12-64) unstable; urgency=medium * list_order.24 -- Camm Maguire Sun, 04 Feb 2018 13:26:27 +0000 gcl (2.6.12-63) unstable; urgency=medium * list_order.23 -- Camm Maguire Thu, 01 Feb 2018 18:36:29 +0000 gcl (2.6.12-62) unstable; urgency=medium * list_order.22 -- Camm Maguire Thu, 01 Feb 2018 01:05:10 +0000 gcl (2.6.12-61) unstable; urgency=medium * list_order.21 -- Camm Maguire Tue, 30 Jan 2018 21:13:13 +0000 gcl (2.6.12-60) unstable; urgency=medium * list_order.19 -- Camm Maguire Tue, 23 Jan 2018 18:11:59 +0000 gcl (2.6.12-59) unstable; urgency=medium * list_order.16 -- Camm Maguire Fri, 12 Jan 2018 03:25:08 +0000 gcl (2.6.12-58) unstable; urgency=medium * list_order.14 -- Camm Maguire Mon, 18 Sep 2017 15:45:10 +0000 gcl (2.6.12-57) unstable; urgency=medium * list_order.13 -- Camm Maguire Fri, 25 Aug 2017 13:44:10 +0000 gcl (2.6.12-56) unstable; urgency=medium * list_order.12 -- Camm Maguire Thu, 24 Aug 2017 19:12:50 +0000 gcl (2.6.12-55) unstable; urgency=medium * disable gprof on aarch64 * Bug fix: "gcl FTBFS on arm64: Unrecoverable error: Segmentation violation..", thanks to Adrian Bunk (Closes: #873052). -- Camm Maguire Thu, 24 Aug 2017 16:37:07 +0000 gcl (2.6.12-54) unstable; urgency=medium * list_order.11 -- Camm Maguire Wed, 23 Aug 2017 22:19:14 +0000 gcl (2.6.12-53) unstable; urgency=medium * list_order.9 -- Camm Maguire Sun, 18 Jun 2017 18:32:30 +0000 gcl (2.6.12-52) unstable; urgency=medium * list_order.8 -- Camm Maguire Thu, 15 Jun 2017 18:04:41 +0000 gcl (2.6.12-51) unstable; urgency=medium * list_order.7 -- Camm Maguire Wed, 14 Jun 2017 18:30:46 +0000 gcl (2.6.12-50) unstable; urgency=medium * list_order.6 -- Camm Maguire Tue, 13 Jun 2017 22:38:52 +0000 gcl (2.6.12-49) unstable; urgency=medium * list_order.5 -- Camm Maguire Thu, 08 Jun 2017 17:21:01 +0000 gcl (2.6.12-48) unstable; urgency=medium * list_order.1 -- Camm Maguire Sun, 28 May 2017 01:42:29 +0000 gcl (2.6.12-47) unstable; urgency=high * pathnames1.13 -- Camm Maguire Tue, 22 Nov 2016 04:53:35 +0000 gcl (2.6.12-46) unstable; urgency=high * pathnames1.12 * Bug fix: "maintainer script(s) do not start on #!", thanks to treinen@debian.org; (Closes: #843303). -- Camm Maguire Fri, 18 Nov 2016 18:27:53 +0000 gcl (2.6.12-45) unstable; urgency=high * pathnames1.11 -- Camm Maguire Mon, 31 Oct 2016 22:57:27 +0000 gcl (2.6.12-44) unstable; urgency=high * pathnames1.9 -- Camm Maguire Fri, 28 Oct 2016 17:04:38 +0000 gcl (2.6.12-43) unstable; urgency=medium * pathnames1.7 -- Camm Maguire Thu, 27 Oct 2016 03:46:32 +0000 gcl (2.6.12-42) unstable; urgency=medium * pathnames1.6 * Bug fix: "FTBFS with bindnow and PIE enabled", thanks to Balint Reczey (Closes: #837481). * Bug fix: "FTBFS with compilers that default to -fPIE (patch attached)", thanks to Adam Conrad (Closes: #822820). -- Camm Maguire Wed, 26 Oct 2016 23:04:57 +0000 gcl (2.6.12-41) unstable; urgency=medium * pathnames1.4, kfreebsd fix -- Camm Maguire Fri, 14 Oct 2016 01:17:18 +0000 gcl (2.6.12-40) unstable; urgency=medium * pathnames1.2 * Bug fix: "popen arguments not quoted causes trouble and security issues", thanks to axel (Closes: #802203). -- Camm Maguire Wed, 12 Oct 2016 18:09:26 +0000 gcl (2.6.12-39) unstable; urgency=medium * pathnames1.1 * ansi-test clean target -- Camm Maguire Wed, 12 Oct 2016 01:32:05 +0000 gcl (2.6.12-38) unstable; urgency=medium * Version_2_6_13pre50 -- Camm Maguire Tue, 04 Oct 2016 19:45:38 +0000 gcl (2.6.12-37) unstable; urgency=medium * Version_2_6_13pre49 -- Camm Maguire Mon, 03 Oct 2016 14:54:09 +0000 gcl (2.6.12-36) unstable; urgency=medium * Version_2_6_13pre48 -- Camm Maguire Sat, 01 Oct 2016 12:10:25 +0000 gcl (2.6.12-35) unstable; urgency=medium * Version_2_6_13pre47 -- Camm Maguire Fri, 30 Sep 2016 21:21:43 +0000 gcl (2.6.12-34) unstable; urgency=medium * Version_2_6_13pre45 -- Camm Maguire Fri, 23 Sep 2016 19:42:37 +0000 gcl (2.6.12-33) unstable; urgency=medium * Version_2_6_13pre43 -- Camm Maguire Tue, 03 May 2016 16:17:03 +0000 gcl (2.6.12-32) unstable; urgency=medium * Version_2_6_13pre40 * Bug fix: "[INTL:pt_BR] Brazilian Portuguese debconf templates translation", thanks to Adriano Rafael Gomes (Closes: #811523). -- Camm Maguire Wed, 20 Apr 2016 15:18:35 +0000 gcl (2.6.12-31) unstable; urgency=medium * Version_2_6_13pre39 -- Camm Maguire Mon, 11 Apr 2016 00:41:11 +0000 gcl (2.6.12-30) unstable; urgency=medium * Version_2_6_13pre38 -- Camm Maguire Wed, 06 Apr 2016 00:20:15 +0000 gcl (2.6.12-29) unstable; urgency=medium * Version_2_6_13pre35; support latest binutils * Bug fix: "gcl ftbfs on amd64 and i386 with binutils from experimental", thanks to Matthias Klose (Closes: #803214). -- Camm Maguire Thu, 29 Oct 2015 15:20:27 +0000 gcl (2.6.12-28) unstable; urgency=medium * Version_2_6_13pre35; restore hppa build -- Camm Maguire Tue, 27 Oct 2015 20:00:46 +0000 gcl (2.6.12-27) unstable; urgency=medium * Version_2_6_13pre34; mips64 relocs; stack saving tail-recursive equal. -- Camm Maguire Tue, 27 Oct 2015 16:35:06 +0000 gcl (2.6.12-26) unstable; urgency=medium * Version_2_6_13pre32 -- Camm Maguire Fri, 23 Oct 2015 00:03:34 +0000 gcl (2.6.12-25) unstable; urgency=medium * Version_2_6_13pre31, kfreebsd and mips64 FTBFS fix -- Camm Maguire Fri, 16 Oct 2015 15:03:03 +0000 gcl (2.6.12-24) unstable; urgency=medium * Version_2_6_13pre30 -- Camm Maguire Fri, 16 Oct 2015 02:44:23 +0000 gcl (2.6.12-23) unstable; urgency=medium * Version_2_6_13pre29 -- Camm Maguire Thu, 15 Oct 2015 18:09:59 +0000 gcl (2.6.12-22) unstable; urgency=medium * Version_2_6_13pre27 -- Camm Maguire Tue, 13 Oct 2015 14:38:53 +0000 gcl (2.6.12-21) unstable; urgency=medium * Version_2_6_13pre26 -- Camm Maguire Wed, 07 Oct 2015 15:14:27 +0000 gcl (2.6.12-20) unstable; urgency=medium * Version_2_6_13pre25 -- Camm Maguire Thu, 01 Oct 2015 15:16:14 +0000 gcl (2.6.12-19) unstable; urgency=medium * Use-dpkg-buidflags-opt-levels-in-debian-rules, -O3 has bug in 5.2.1 * Version_2_6_13pre24 -- Camm Maguire Wed, 30 Sep 2015 15:45:20 +0000 gcl (2.6.12-18) unstable; urgency=medium * Version_2_6_13pre22 -- Camm Maguire Tue, 29 Sep 2015 16:51:03 +0000 gcl (2.6.12-17) unstable; urgency=medium * Version_2_6_13pre20 -- Camm Maguire Sat, 26 Sep 2015 10:34:23 -0400 gcl (2.6.12-16) unstable; urgency=medium * Version_2_6_13pre19 -- Camm Maguire Fri, 25 Sep 2015 18:39:52 -0400 gcl (2.6.12-15) unstable; urgency=medium * Version_2_6_13pre18 -- Camm Maguire Fri, 25 Sep 2015 15:08:50 +0000 gcl (2.6.12-14) unstable; urgency=medium * Version_2_6_13pre17 -- Camm Maguire Thu, 28 May 2015 03:37:47 +0000 gcl (2.6.12-13) unstable; urgency=medium * Version_2_6_13pre16 -- Camm Maguire Fri, 15 May 2015 18:09:38 +0000 gcl (2.6.12-12) unstable; urgency=medium * Version_2_6_13pre13 -- Camm Maguire Fri, 01 May 2015 11:08:46 -0400 gcl (2.6.12-11) unstable; urgency=medium * Version_2_6_13pre12 -- Camm Maguire Thu, 30 Apr 2015 12:49:16 -0400 gcl (2.6.12-10) unstable; urgency=medium * rebuild in clean sid environment -- Camm Maguire Mon, 27 Apr 2015 15:34:15 -0400 gcl (2.6.12-9) unstable; urgency=medium * Version_2_6_13pre8b * Bug fix: "ftbfs with GCC-5", thanks to Matthias Klose (Closes: #777866). -- Camm Maguire Mon, 27 Apr 2015 12:32:49 -0400 gcl (2.6.12-8) unstable; urgency=medium * Version_2_6_13pre7 -- Camm Maguire Fri, 24 Apr 2015 13:38:30 -0400 gcl (2.6.12-7) unstable; urgency=medium * Version_2_6_13pre6 -- Camm Maguire Thu, 23 Apr 2015 13:43:45 -0400 gcl (2.6.12-6) unstable; urgency=medium * Version_2_6_13pre5 -- Camm Maguire Wed, 22 Apr 2015 17:14:16 -0400 gcl (2.6.12-5) unstable; urgency=medium * Version_2_6_13pre4 -- Camm Maguire Wed, 22 Apr 2015 10:25:36 -0400 gcl (2.6.12-4) unstable; urgency=medium * Version_2_6_13pre3a -- Camm Maguire Mon, 20 Apr 2015 13:26:36 -0400 gcl (2.6.12-3) unstable; urgency=medium * Version_2_6_13pre2 -- Camm Maguire Fri, 17 Apr 2015 15:50:37 -0400 gcl (2.6.12-2) unstable; urgency=medium * Version_2_6_13pre1 -- Camm Maguire Wed, 26 Nov 2014 11:12:46 -0500 gcl (2.6.12-1) unstable; urgency=medium * New upstream release -- Camm Maguire Tue, 28 Oct 2014 09:56:15 -0400 gcl (2.6.11-6) unstable; urgency=medium * 2.6.12pre5 -- Camm Maguire Thu, 23 Oct 2014 17:33:22 -0400 gcl (2.6.11-5) unstable; urgency=medium * 2.6.12pre4 -- Camm Maguire Sat, 18 Oct 2014 09:46:34 -0400 gcl (2.6.11-4) unstable; urgency=medium * 2.6.12pre3 -- Camm Maguire Thu, 16 Oct 2014 11:56:15 -0400 gcl (2.6.11-3) unstable; urgency=medium * 2.6.12pre2 -- Camm Maguire Sun, 28 Sep 2014 20:56:18 -0400 gcl (2.6.11-2) unstable; urgency=medium * 2.6.12pre1 -- Camm Maguire Fri, 19 Sep 2014 14:49:25 -0400 gcl (2.6.11-1) unstable; urgency=medium * New upstream release -- Camm Maguire Sat, 06 Sep 2014 12:28:46 -0400 gcl (2.6.10-54) unstable; urgency=medium * remove-debug-message-from-BUGGY_MAXIMUM_SSCANF_LENGTH-code -- Camm Maguire Fri, 05 Sep 2014 10:35:46 -0400 gcl (2.6.10-53) unstable; urgency=medium * ppc64le-support-headers -- Camm Maguire Wed, 03 Sep 2014 15:02:12 -0400 gcl (2.6.10-52) unstable; urgency=medium * accept-TMP-paths-with-types-versions -- Camm Maguire Fri, 29 Aug 2014 17:51:04 -0400 gcl (2.6.10-51) unstable; urgency=medium * fix-match-function-proclaim-skew -- Camm Maguire Fri, 29 Aug 2014 16:40:30 +0000 gcl (2.6.10-50) unstable; urgency=medium * trial_selinux_support -- Camm Maguire Thu, 21 Aug 2014 17:29:50 +0000 gcl (2.6.10-49) unstable; urgency=medium * R_ARM_JUMP24 -- Camm Maguire Wed, 20 Aug 2014 17:08:23 +0000 gcl (2.6.10-48) unstable; urgency=medium * try-SGC-for-aarch64 -- Camm Maguire Tue, 19 Aug 2014 18:35:22 +0000 gcl (2.6.10-47) unstable; urgency=medium * set-stack_guard-after-alloc-setup * Bug fix: "work around build failure on AArch64", thanks to Matthias Klose (Closes: #758101). -- Camm Maguire Thu, 14 Aug 2014 19:36:48 +0000 gcl (2.6.10-46) unstable; urgency=medium * R_AARCH64_LDST128_ABS_LO12_NC -- Camm Maguire Wed, 13 Aug 2014 21:39:50 +0000 gcl (2.6.10-45) unstable; urgency=medium * fix sh4 CLEAR_CACHE -- Camm Maguire Sun, 10 Aug 2014 20:12:03 +0000 gcl (2.6.10-44) unstable; urgency=medium * clear_protect_memory on all elf machines -- Camm Maguire Sat, 09 Aug 2014 00:55:17 +0000 gcl (2.6.10-43) unstable; urgency=medium * mips uses builtin_clear_cache like mipsel -- Camm Maguire Fri, 08 Aug 2014 23:42:42 +0000 gcl (2.6.10-42) unstable; urgency=medium * backport travel_push_new from master -- Camm Maguire Wed, 06 Aug 2014 20:14:14 +0000 gcl (2.6.10-41) unstable; urgency=medium * protos and CFLAGS for axiom extensions -- Camm Maguire Wed, 06 Aug 2014 01:54:38 +0000 gcl (2.6.10-40) unstable; urgency=medium * better solaris unexec fix -- Camm Maguire Mon, 04 Aug 2014 22:00:54 +0000 gcl (2.6.10-39) unstable; urgency=medium * earlier prelink_init, phys_pages w/o malloc -- Camm Maguire Mon, 04 Aug 2014 16:52:09 +0000 gcl (2.6.10-38) unstable; urgency=medium * error on overflow of array dimensions -- Camm Maguire Fri, 01 Aug 2014 14:35:44 +0000 gcl (2.6.10-37) unstable; urgency=medium * FILE * casts for windows feof wrapper -- Camm Maguire Thu, 31 Jul 2014 02:17:11 +0000 gcl (2.6.10-36) unstable; urgency=medium * better casts for frs_jmpbuf -- Camm Maguire Wed, 30 Jul 2014 17:00:06 +0000 gcl (2.6.10-35) unstable; urgency=medium * find_sym_ptable typo fix -- Camm Maguire Tue, 29 Jul 2014 18:08:57 +0000 gcl (2.6.10-34) unstable; urgency=medium * --enable-prelink configure arg; stack_chk_guard for 68k -- Camm Maguire Fri, 25 Jul 2014 20:39:10 +0000 gcl (2.6.10-33) unstable; urgency=medium * hurd stack_guard, ppc64 C_GC_OFFSET -- Camm Maguire Thu, 24 Jul 2014 21:46:24 +0000 gcl (2.6.10-32) unstable; urgency=medium * __stack_chk_guard fix for arm/sh4 -- Camm Maguire Wed, 23 Jul 2014 18:12:56 +0000 gcl (2.6.10-31) unstable; urgency=medium * dpkg-buildflags trial -- Camm Maguire Tue, 22 Jul 2014 20:06:10 +0000 gcl (2.6.10-30) unstable; urgency=medium * fix offsets ppc -- Camm Maguire Tue, 22 Jul 2014 17:12:27 +0000 gcl (2.6.10-29) unstable; urgency=medium * fix unexec file offsets -- Camm Maguire Tue, 22 Jul 2014 15:36:45 +0000 gcl (2.6.10-28) unstable; urgency=high * enable prelink -- Camm Maguire Fri, 18 Jul 2014 19:24:38 +0000 gcl (2.6.10-27) unstable; urgency=high * protect closure calls from gc -- Camm Maguire Wed, 16 Jul 2014 16:15:33 +0000 gcl (2.6.10-26) unstable; urgency=high * Bug fix: "packages should not build-depend on binutils-dev", thanks to Matthias Klose (Closes: #754840). Please note that gcl has long depended on binutils-dev for good reason -- happily it is no longer necessary -- Camm Maguire Tue, 15 Jul 2014 16:04:04 +0000 gcl (2.6.10-25) unstable; urgency=high * rebuild to get gcc fixes on i386 -- Camm Maguire Fri, 11 Jul 2014 03:14:45 +0000 gcl (2.6.10-24) unstable; urgency=high * try default gcc 4.9 * access libopcodes without link dependency via dlopen * Bug fix: "please switch to emacs24", thanks to Gabriele Giacone (Closes: #754012). -- Camm Maguire Wed, 09 Jul 2014 17:34:21 +0000 gcl (2.6.10-23) unstable; urgency=high * rebuild latest binutils -- Camm Maguire Sat, 05 Jul 2014 23:19:27 +0000 gcl (2.6.10-22) unstable; urgency=high * gcc-4.8 on i386, 4.9 has bugs at present -- Camm Maguire Fri, 04 Jul 2014 01:36:06 +0000 gcl (2.6.10-21) unstable; urgency=high * 2.6.11pre test 20 -- Camm Maguire Mon, 30 Jun 2014 22:43:27 +0000 gcl (2.6.10-20) unstable; urgency=high * 2.6.11pre test 19 -- Camm Maguire Sun, 29 Jun 2014 17:59:59 +0000 gcl (2.6.10-19) unstable; urgency=high * 2.6.11pre test 18 -- Camm Maguire Sun, 29 Jun 2014 16:00:07 +0000 gcl (2.6.10-18) unstable; urgency=high * 2.6.11pre test 17 -- Camm Maguire Sat, 28 Jun 2014 16:57:54 +0000 gcl (2.6.10-17) unstable; urgency=high * 2.6.11pre test 16 -- Camm Maguire Thu, 26 Jun 2014 18:06:42 +0000 gcl (2.6.10-16) unstable; urgency=high * 2.6.11pre test 15 -- Camm Maguire Wed, 18 Jun 2014 17:37:36 +0000 gcl (2.6.10-15) unstable; urgency=high * 2.6.11pre test 14 -- Camm Maguire Tue, 17 Jun 2014 00:39:35 +0000 gcl (2.6.10-14) unstable; urgency=high * 2.6.11pre test 13 -- Camm Maguire Sat, 14 Jun 2014 13:43:57 +0000 gcl (2.6.10-13) unstable; urgency=high * 2.6.11pre test 12 -- Camm Maguire Tue, 20 May 2014 16:00:22 +0000 gcl (2.6.10-12) unstable; urgency=high * 2.6.11pre test 11 -- Camm Maguire Fri, 16 May 2014 17:41:33 +0000 gcl (2.6.10-11) unstable; urgency=high * 2.6.11pre test 10 -- Camm Maguire Fri, 16 May 2014 13:18:07 +0000 gcl (2.6.10-10) unstable; urgency=high * 2.6.11pre test 9 -- Camm Maguire Wed, 07 May 2014 17:10:30 +0000 gcl (2.6.10-9) unstable; urgency=high * 2.6.11pre test 8 -- Camm Maguire Fri, 25 Apr 2014 19:53:10 +0000 gcl (2.6.10-8) unstable; urgency=high * 2.6.11pre test 7 -- Camm Maguire Mon, 21 Apr 2014 14:09:37 +0000 gcl (2.6.10-7) unstable; urgency=high * 2.6.11pre test 6 -- Camm Maguire Sat, 19 Apr 2014 17:52:17 +0000 gcl (2.6.10-6) unstable; urgency=high * 2.6.11pre test 5 -- Camm Maguire Fri, 18 Apr 2014 15:06:09 +0000 gcl (2.6.10-5) unstable; urgency=high * 2.6.11pre test 4 -- Camm Maguire Tue, 15 Apr 2014 20:30:13 +0000 gcl (2.6.10-4) unstable; urgency=high * 2.6.11pre test 3 * Bug fix: "debian/rules uses DEB_BUILD_* macros instead of DEB_HOST_* macros", thanks to Matthias Klose (Closes: #743520). -- Camm Maguire Wed, 09 Apr 2014 13:15:32 +0000 gcl (2.6.10-3) unstable; urgency=high * 2.6.11pre test 2 -- Camm Maguire Thu, 03 Apr 2014 14:24:23 +0000 gcl (2.6.10-2) unstable; urgency=high * 2.6.11pre test 1 * Bug fix: "FTBFS: gcl_readline.d:472:39: error: 'CPPFunction' undeclared (first use in this function)", thanks to David Suárez (Closes: #741819). -- Camm Maguire Mon, 24 Mar 2014 15:47:01 +0000 gcl (2.6.10-1) unstable; urgency=high * New upstream release -- Camm Maguire Wed, 13 Nov 2013 18:39:19 +0000 gcl (2.6.9-17) unstable; urgency=high * 2.6.10pre test 17 -- Camm Maguire Mon, 11 Nov 2013 19:41:45 +0000 gcl (2.6.9-16) unstable; urgency=high * 2.6.10pre test 16 * Bug fix: "gcl 2.6.7+dfsga-20 needs 1 GB disk space on amd64", thanks to Edi Meier (Closes: #714507). * Bug fix: "[INTL:ja] New Japanese translation", thanks to victory (Closes: #718925). -- Camm Maguire Sat, 09 Nov 2013 13:34:32 +0000 gcl (2.6.9-15) unstable; urgency=high * 2.6.10pre test 15 -- Camm Maguire Sat, 02 Nov 2013 22:21:16 +0000 gcl (2.6.9-14) unstable; urgency=high * 2.6.10pre test 14 -- Camm Maguire Wed, 23 Oct 2013 17:44:14 +0000 gcl (2.6.9-13) unstable; urgency=high * environment allocation unrandomize.h -- Camm Maguire Mon, 21 Oct 2013 00:20:16 +0000 gcl (2.6.9-12) unstable; urgency=high * 2.6.10pre test 13 -- Camm Maguire Fri, 18 Oct 2013 14:18:17 +0000 gcl (2.6.9-11) unstable; urgency=high * 2.6.10pre test 12, s390, mingw cleanup, make_bignum bug fix -- Camm Maguire Tue, 15 Oct 2013 23:32:09 +0000 gcl (2.6.9-10) unstable; urgency=high * fast-fixnums -- Camm Maguire Fri, 11 Oct 2013 15:05:58 +0000 gcl (2.6.9-9) unstable; urgency=high * 2.6.10pre test 10 and 11 -- Camm Maguire Wed, 02 Oct 2013 19:12:36 +0000 gcl (2.6.9-8) unstable; urgency=high * 2.6.10pre test 8 and 9 -- Camm Maguire Tue, 01 Oct 2013 21:00:19 +0000 gcl (2.6.9-7) unstable; urgency=high * 2.6.10pre test 6 and 7 -- Camm Maguire Mon, 30 Sep 2013 19:34:38 +0000 gcl (2.6.9-6) unstable; urgency=high * 2.6.10pre test 5 -- Camm Maguire Tue, 24 Sep 2013 17:03:24 +0000 gcl (2.6.9-5) unstable; urgency=high * 2.6.10pre test 4 -- Camm Maguire Mon, 23 Sep 2013 19:27:36 +0000 gcl (2.6.9-4) unstable; urgency=high * 2.6.10pre test 3 -- Camm Maguire Mon, 23 Sep 2013 16:30:09 +0000 gcl (2.6.9-3) unstable; urgency=high * 2.6.10pre test 2 -- Camm Maguire Sun, 22 Sep 2013 03:27:10 +0000 gcl (2.6.9-2) unstable; urgency=high * 2.6.10pre test -- Camm Maguire Sat, 21 Sep 2013 04:14:55 +0000 gcl (2.6.9-1) unstable; urgency=high * New upstream release -- Camm Maguire Wed, 28 Aug 2013 16:49:18 +0000 gcl (2.6.7+dfsga-40) unstable; urgency=high * fix allocate functions -- Camm Maguire Tue, 06 Aug 2013 22:36:37 +0000 gcl (2.6.7+dfsga-39) unstable; urgency=high * lower initial contiguous and relblock allocations, set *ihs-top* properly on startup, protect memory->cfd.cfd_start initialization from gc -- Camm Maguire Mon, 05 Aug 2013 17:38:22 +0000 gcl (2.6.7+dfsga-38) unstable; urgency=high * robustify near oom handling to fix axiom compile of EXPEXPAN on mips -- Camm Maguire Fri, 02 Aug 2013 16:25:16 +0000 gcl (2.6.7+dfsga-37) unstable; urgency=high * ppc64 gprof fix -- Camm Maguire Fri, 26 Jul 2013 23:40:14 +0000 gcl (2.6.7+dfsga-36) unstable; urgency=high * min_pagewidth=14 on mips -- Camm Maguire Fri, 26 Jul 2013 02:20:56 +0000 gcl (2.6.7+dfsga-35) unstable; urgency=high * latest gcc on all platforms, no gprof ppc64, -O1 ia64, -O0 alpha -- Camm Maguire Thu, 25 Jul 2013 14:42:48 +0000 gcl (2.6.7+dfsga-34) unstable; urgency=high * sgc link_array mark fix;rb_end across save fix;more stable gcc on older arches -- Camm Maguire Tue, 23 Jul 2013 17:11:23 +0000 gcl (2.6.7+dfsga-33) unstable; urgency=high * fix mark_link_array for marked sLAlink_arrayA->s.s_dbind -- Camm Maguire Mon, 22 Jul 2013 19:00:43 +0000 gcl (2.6.7+dfsga-32) unstable; urgency=high * protect mark_link_array in sgc -- Camm Maguire Sat, 20 Jul 2013 00:16:07 +0000 gcl (2.6.7+dfsga-31) unstable; urgency=high * properly clean link array on gc -- Camm Maguire Fri, 19 Jul 2013 20:34:34 +0000 gcl (2.6.7+dfsga-30) unstable; urgency=high * fix gcl.script compiler::link, darwin compile warnings -- Camm Maguire Mon, 15 Jul 2013 20:35:03 +0000 gcl (2.6.7+dfsga-29) unstable; urgency=high * fix compiler::link in presence of gcl.script -- Camm Maguire Mon, 15 Jul 2013 16:23:33 +0000 gcl (2.6.7+dfsga-28) unstable; urgency=high * install unixport/gcl.script -- Camm Maguire Sat, 13 Jul 2013 18:42:28 +0000 gcl (2.6.7+dfsga-27) unstable; urgency=high * workaround for ia64 and hurd brk issues -- Camm Maguire Fri, 12 Jul 2013 21:44:54 +0000 gcl (2.6.7+dfsga-26) unstable; urgency=high * -- command line support, map-shared in unexec -- Camm Maguire Fri, 12 Jul 2013 00:52:35 +0000 gcl (2.6.7+dfsga-25) unstable; urgency=high * alpha, mips, 68k -- Camm Maguire Wed, 10 Jul 2013 18:29:37 +0000 gcl (2.6.7+dfsga-24) unstable; urgency=high * sgc and reloc fixes -- Camm Maguire Mon, 08 Jul 2013 13:56:33 +0000 gcl (2.6.7+dfsga-23) unstable; urgency=high * fix for maxima on kfbsd and sparc -- Camm Maguire Wed, 03 Jul 2013 19:19:16 +0000 gcl (2.6.7+dfsga-22) unstable; urgency=high * fix stack definition issues on i386 -- Camm Maguire Tue, 02 Jul 2013 18:27:54 +0000 gcl (2.6.7+dfsga-21) unstable; urgency=high * near out of memory robustification -- Camm Maguire Tue, 02 Jul 2013 15:32:58 +0000 gcl (2.6.7+dfsga-20) unstable; urgency=high * fix 3GB workaround for gprof -- Camm Maguire Fri, 21 Jun 2013 11:09:01 -0400 gcl (2.6.7+dfsga-19) unstable; urgency=high * work around 3GB personality/alloca/malloc bug -- Camm Maguire Fri, 21 Jun 2013 02:46:49 +0000 gcl (2.6.7+dfsga-18) unstable; urgency=high * alpha NULL_OR_ON_C_STACK, attempt to get 32 immfix space with ADDR_LIMIT_3GB|ADDR_COMPAT_LAYOUT personality, clean compile with no immfix -- Camm Maguire Thu, 20 Jun 2013 20:24:29 +0000 gcl (2.6.7+dfsga-17) unstable; urgency=high * small optimizations, #= nil fix -- Camm Maguire Wed, 19 Jun 2013 16:23:27 +0000 gcl (2.6.7+dfsga-16) unstable; urgency=high * no linker script on hurd;fix OBJ_ALIGN -- Camm Maguire Thu, 13 Jun 2013 15:35:00 +0000 gcl (2.6.7+dfsga-15) unstable; urgency=high * ia64 fix -- Camm Maguire Thu, 13 Jun 2013 02:38:47 +0000 gcl (2.6.7+dfsga-14) unstable; urgency=high * eliminate maxpage/dbegin, restore windows and macosx builds -- Camm Maguire Wed, 12 Jun 2013 21:42:29 +0000 gcl (2.6.7+dfsga-13) unstable; urgency=low * ia64/hurd/s390 and SGC -- Camm Maguire Sun, 09 Jun 2013 00:23:51 +0000 gcl (2.6.7+dfsga-12) unstable; urgency=low * ia64/hurd/s390 -- Camm Maguire Sat, 08 Jun 2013 15:24:46 +0000 gcl (2.6.7+dfsga-11) unstable; urgency=high * 2.6.9 test -- Camm Maguire Fri, 07 Jun 2013 21:46:41 +0000 gcl (2.6.7+dfsga-10) unstable; urgency=high * output mips make bug text to stderr -- Camm Maguire Sat, 25 May 2013 12:24:35 +0000 gcl (2.6.7+dfsga-9) unstable; urgency=high * mips make bug workaround -- Camm Maguire Wed, 22 May 2013 14:23:43 +0000 gcl (2.6.7+dfsga-8) unstable; urgency=high * revert doubled default maxpage * export *read-eval* -- Camm Maguire Tue, 21 May 2013 14:42:05 +0000 gcl (2.6.7+dfsga-7) unstable; urgency=high * export ansi symbols -- Camm Maguire Sat, 11 May 2013 21:36:56 +0000 gcl (2.6.7+dfsga-6) unstable; urgency=high * fast hash-equal in compiler -- Camm Maguire Sat, 11 May 2013 19:11:42 +0000 gcl (2.6.7+dfsga-5) unstable; urgency=high * Bug fix: "FTBFS: cp: cannot stat 'debian/tmp/usr/share/info/gcl-si.info': No such file or directory", thanks to Lucas Nussbaum (Closes: #707490). -- Camm Maguire Fri, 10 May 2013 18:09:14 +0000 gcl (2.6.7+dfsga-4) unstable; urgency=high * sgc-on fix with latest gcc -- Camm Maguire Tue, 23 Apr 2013 18:45:11 +0000 gcl (2.6.7+dfsga-3) unstable; urgency=high * hash depth bug fix * new s390 reloc -- Camm Maguire Thu, 24 Jan 2013 19:46:30 +0000 gcl (2.6.7+dfsga-2) unstable; urgency=high * more arm relocs supported;check default timezone dynamically;follow bash ~ semantics in user-homedir-pathname -- Camm Maguire Mon, 21 Jan 2013 18:41:06 +0000 gcl (2.6.7+dfsga-1) unstable; urgency=high * Acknowledge Non-maintainer upload. (thanks David Prévot ) * Remove unused and non DFSG-compliant gmp3/gmp.* from source. (Closes: #695721) * Show translated debconf templates, thanks to Denis Barbier for the analysis and the proposed fixes. (Closes: #691946) * trim excess digits from printed floats -- Camm Maguire Tue, 15 Jan 2013 20:46:25 +0000 gcl (2.6.7-108) unstable; urgency=high * Depend on emacs23 | emacsen to allow wheezy propagation -- Camm Maguire Mon, 08 Oct 2012 18:08:36 +0000 gcl (2.6.7-107) unstable; urgency=high * mode 644 on ucf newfile -- Camm Maguire Wed, 03 Oct 2012 20:38:43 +0000 gcl (2.6.7-106) unstable; urgency=high * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", thanks to Andreas Beckmann (Closes: #688201). -- Camm Maguire Wed, 03 Oct 2012 16:52:10 +0000 gcl (2.6.7-105) unstable; urgency=high * restore #DEBHELPER# to postinst and postrm scripts -- Camm Maguire Mon, 01 Oct 2012 17:31:43 +0000 gcl (2.6.7-104) unstable; urgency=high * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", thanks to Andreas Beckmann (Closes: #688201). -- Camm Maguire Mon, 01 Oct 2012 15:32:52 +0000 gcl (2.6.7-103) unstable; urgency=high * sfaslelf.c: FIX_HIDDEN_SYMBOLS -- Camm Maguire Wed, 22 Aug 2012 15:13:12 +0000 gcl (2.6.7-102) unstable; urgency=high * Fix hash key distribution bug, bitvector equal bug * distinguish car position in equal-hash of lists -- Camm Maguire Mon, 20 Aug 2012 17:33:26 +0000 gcl (2.6.7-101) unstable; urgency=high * add alpha, ppc, ppc64, and ia64 to __builtin__clear_cache exception list as per gcc maintainers * lintian cleanups -- Camm Maguire Sat, 05 May 2012 23:18:56 +0000 gcl (2.6.7-100) unstable; urgency=high * nil case keylist support * Bug fix: "[INTL:da] Danish translation of the debconf templates gcl", thanks to Joe Dalton (Closes: #666528). -- Camm Maguire Fri, 20 Apr 2012 02:25:26 +0000 gcl (2.6.7-99) unstable; urgency=low * case default error checking -- Camm Maguire Fri, 23 Mar 2012 14:14:44 +0000 gcl (2.6.7-98) unstable; urgency=low * restore traditional make-sequence,make-array, and coerce, and optimize replace, as 2.6.8 compiler is still too weak re: inlines -- Camm Maguire Fri, 20 Jan 2012 19:55:45 +0000 gcl (2.6.7-97) unstable; urgency=low * evade __builtin___clear_cache on hppa * make-array;make-sequence;replace;coerce -- Camm Maguire Fri, 20 Jan 2012 05:13:22 +0000 gcl (2.6.7-96) unstable; urgency=low * better XDR detection; no __builtin_clear_cache on sh4 -- Camm Maguire Wed, 18 Jan 2012 01:32:43 +0000 gcl (2.6.7-95) unstable; urgency=low * clear_cache after mprotect -- Camm Maguire Tue, 17 Jan 2012 03:54:56 +0000 gcl (2.6.7-94) unstable; urgency=low * optimize unwind at O0 to workaround gcc bug; centralize on __builtin__clear_cache when available;arm_thm_call reloc support -- Camm Maguire Mon, 16 Jan 2012 20:10:07 +0000 gcl (2.6.7-93) unstable; urgency=low * remove C_GC_OFFSET for sparc64 * remove ncurses dependency for readline * Bug fix: "FTBFS: dpkg-buildpackage: error: dpkg-source -b gcl-2.6.7 gave error exit status 2", thanks to Didier Raboud (Closes: #643131). * Bug fix: "drops readline support if rebuilt", thanks to Sven Joachim (Closes: #646735). * lower opts on sparc64 asof gcc 4.6.1 -- Camm Maguire Wed, 11 Jan 2012 21:04:23 +0000 gcl (2.6.7-92) unstable; urgency=low * remove gprof on arm as mcount calls are 24/22bit -- marginally accessible -- Camm Maguire Sat, 07 Jan 2012 02:42:06 +0000 gcl (2.6.7-91) unstable; urgency=low * s390x reloc support * lower C optimization on ia64, arm and mips for now -- Camm Maguire Thu, 05 Jan 2012 17:30:01 +0000 gcl (2.6.7-90) unstable; urgency=low * libtirpc check for newest glibc * read_preserving_whitespace fix * armhf reloc support * s390x support * try C_GC_OFFSET for sparc64 -- Camm Maguire Wed, 04 Jan 2012 19:51:13 +0000 gcl (2.6.7-89) unstable; urgency=low * support new mips relocs * lower opt to work around gcc 4.6 bug on arm -- Camm Maguire Wed, 11 May 2011 20:06:04 +0000 gcl (2.6.7-88) unstable; urgency=low * Bug fix: "FTBFS: gcl_arraylib.c:4:42: error: 'VV' undeclared (first use in this function)", thanks to Lucas Nussbaum (Closes: #625032). -- Camm Maguire Mon, 09 May 2011 16:00:21 +0000 gcl (2.6.7-87) unstable; urgency=low * mips reloc fix;configure default dlopen fix;clean rules and makefiles -- Camm Maguire Fri, 05 Nov 2010 13:29:05 +0000 gcl (2.6.7-86) unstable; urgency=low * remove binutils subdir, configure and make changes -- Camm Maguire Thu, 04 Nov 2010 17:55:48 +0000 gcl (2.6.7-85) unstable; urgency=low * fix mips relocs for non-static clines -- Camm Maguire Tue, 02 Nov 2010 13:56:40 +0000 gcl (2.6.7-84) unstable; urgency=low * better mips relocs, fix link on mingw32 -- Camm Maguire Sat, 30 Oct 2010 00:07:39 +0000 gcl (2.6.7-83) unstable; urgency=low * fix alpha stubs; fix sparc64 typo; print armhf relocs -- Camm Maguire Thu, 28 Oct 2010 13:43:16 +0000 gcl (2.6.7-82) unstable; urgency=low * mips64 fixes -- Camm Maguire Tue, 26 Oct 2010 18:20:04 +0000 gcl (2.6.7-81) unstable; urgency=low * sparc64;mips64 -- Camm Maguire Tue, 26 Oct 2010 03:33:52 +0000 gcl (2.6.7-80) unstable; urgency=low * alpha stubs; sgc mips kernel bug test; mips GPREL32 reloc -- Camm Maguire Mon, 25 Oct 2010 19:52:51 +0000 gcl (2.6.7-79) unstable; urgency=low * mips ld_bind_now, disable sgc workaround mips SIGBUS bug -- Camm Maguire Wed, 20 Oct 2010 15:31:59 +0000 gcl (2.6.7-78) unstable; urgency=low * mips local got relocs -- Camm Maguire Tue, 12 Oct 2010 17:15:35 +0000 gcl (2.6.7-77) unstable; urgency=low * workaround gcc alpha bug * fix alpha reloc -- Camm Maguire Fri, 01 Oct 2010 21:25:11 +0000 gcl (2.6.7-76) unstable; urgency=low * fix page_multiple usage for runtime pagesize variance and stable mipsel builds * sparc64 support -- Camm Maguire Fri, 01 Oct 2010 19:18:47 +0000 gcl (2.6.7-75) unstable; urgency=low * fix alpha bug -- Camm Maguire Tue, 28 Sep 2010 20:23:21 +0000 gcl (2.6.7-74) unstable; urgency=low * fix alpha relocs for axiom -- Camm Maguire Tue, 28 Sep 2010 16:07:38 +0000 gcl (2.6.7-73) unstable; urgency=low * sparc reloc updates * fast-link fix -- Camm Maguire Fri, 24 Sep 2010 19:23:16 +0000 gcl (2.6.7-72) unstable; urgency=low * remove unused symbols from gcl_cmpopt.lsp * reloc updates * clear gcc warning * default tilde expansion to HOME env in absence of passwd * configure typo fix -- Camm Maguire Wed, 22 Sep 2010 19:32:52 +0000 gcl (2.6.7-71) unstable; urgency=low * print sparc64 relocs -- Camm Maguire Sat, 28 Aug 2010 14:50:00 +0000 gcl (2.6.7-70) unstable; urgency=low * sparc64/m68k -- Camm Maguire Fri, 27 Aug 2010 16:54:11 +0000 gcl (2.6.7-69) unstable; urgency=low * Bug fix: "non-standard gcc/g++ used for build (gcc-4.3)", thanks to Matthias Klose (Closes: #594280). -- Camm Maguire Thu, 26 Aug 2010 19:08:39 +0000 gcl (2.6.7-68) unstable; urgency=low * ppc/mips elf reloc fixes -- Camm Maguire Mon, 23 Aug 2010 20:54:30 +0000 gcl (2.6.7-67) unstable; urgency=low * Fix compiler::link ansi combo -- Camm Maguire Sat, 21 Aug 2010 02:05:37 +0000 gcl (2.6.7-66) unstable; urgency=low * ppc autobuild fix * Bug fix: "FTBFS: sfasli.c:139: error: invalid initializer", thanks to Lucas Nussbaum (Closes: #593037). * Bug fix: "FTBFS on powerpc: Error: The function TK::GET-AUTOLOADS is undefined.", thanks to Mehdi Dogguy (Closes: #593191). -- Camm Maguire Fri, 20 Aug 2010 01:25:09 +0000 gcl (2.6.7-65) unstable; urgency=low * autobuilder fixes -- Camm Maguire Sat, 14 Aug 2010 11:30:46 +0000 gcl (2.6.7-64) unstable; urgency=low * configure fix -- Camm Maguire Fri, 13 Aug 2010 23:26:07 +0000 gcl (2.6.7-63) unstable; urgency=low * macosx support, ppc, i386 and x86_64 -- sfaslmacho.c * windows/wine support -- sfaslcoff.c * better custreloc support obviating my_plt -- sfaslelf.c * debian default custreloc build where supported, all but ia64 and hppa * fix mingw/wine path issues -- Camm Maguire Fri, 13 Aug 2010 16:08:49 +0000 gcl (2.6.7-62) unstable; urgency=high * more stable sgc detection via h/tsgc.h * fix plt.h bug on hppa * sublis1-inline fix for acl2 -- Camm Maguire Mon, 26 Jul 2010 16:03:54 +0000 gcl (2.6.7-61) unstable; urgency=high * mac osx support * fix undef sgc bug in cmpinclude.h -- Camm Maguire Tue, 20 Jul 2010 14:50:19 +0000 gcl (2.6.7-60) unstable; urgency=high * fix sh4 support -- Camm Maguire Thu, 29 Apr 2010 18:09:04 +0000 gcl (2.6.7-59) unstable; urgency=high * fix hurd support -- Camm Maguire Fri, 23 Apr 2010 17:12:54 +0000 gcl (2.6.7-58) unstable; urgency=high * hurd support * sh4 support -- Camm Maguire Fri, 23 Apr 2010 05:09:29 +0000 gcl (2.6.7-57) unstable; urgency=high * static function pointer wrapper for gcl_gmp_allocfun, stabilizing gmp on hppa/ia64 -- Camm Maguire Mon, 12 Apr 2010 22:28:41 +0000 gcl (2.6.7-56) unstable; urgency=high * __builtin___clear_cache on arm * gcc-4.3 on alpha -- Camm Maguire Thu, 28 Jan 2010 00:32:16 +0000 gcl (2.6.7-55) unstable; urgency=low * SGC fix, debian override fix, xgcl update * SGC fix for relocatable and contiguous gmp storage * configure fix for arm and hppa -- Camm Maguire Tue, 26 Jan 2010 19:43:08 +0000 gcl (2.6.7-54) unstable; urgency=low * robustify user_match, unrandomize, read-char-no-hang for sockets * SA_SIGINFO for 386-linux * if cmpinclude.h is not available, use *cmpinclude-string* in compiler-pass2 -- Camm Maguire Wed, 20 Jan 2010 19:02:28 +0000 gcl (2.6.7-53) unstable; urgency=low * revert round ratio to nearest -- Camm Maguire Tue, 05 Jan 2010 03:06:59 +0000 gcl (2.6.7-52) unstable; urgency=low * SIGINFO for kfreebsd-386 -- Camm Maguire Mon, 04 Jan 2010 17:49:05 +0000 gcl (2.6.7-51) unstable; urgency=low * user_match exscapes once only -- Camm Maguire Sun, 03 Jan 2010 05:31:20 +0000 gcl (2.6.7-50) unstable; urgency=low * gcc 4.4 warning cleanups -- Camm Maguire Thu, 31 Dec 2009 20:43:39 +0000 gcl (2.6.7-49) unstable; urgency=low * Bug fix: "/bin/sh: line 6: /bin/gcl: Permission denied", thanks to Nobuhiro Iwamatsu (Closes: #561554). -- Camm Maguire Wed, 30 Dec 2009 23:04:39 +0000 gcl (2.6.7-48) unstable; urgency=low * round to nearest in ratio to double -- Camm Maguire Wed, 16 Dec 2009 15:01:55 +0000 gcl (2.6.7-47) unstable; urgency=low * Bug fix: "configure: error: Need zlib for bfd linking", thanks to Cyril Brulebois (Closes: #560761). * Bug fix: "Disfunctional maintainer address", thanks to Joerg Jaspert (Closes: #560752). -- Camm Maguire Mon, 14 Dec 2009 19:06:45 +0000 gcl (2.6.7-46) unstable; urgency=low * support newer binutils with output_bfd element * Fix 64bit interrupt bug * reader error fix * Ensure plt entries are not blank * plt table reading fix * Bug fix: "FTBFS: current binutils static libs need -lz", thanks to Daniel Schepler (Closes: #521929). * Bug fix: "replacing libreadline5-dev build dependency with libreadline-dev", thanks to Matthias Klose (Closes: #553761). * Bug fix: "crash after ctrl-C", thanks to Miroslaw Kwasniak (Closes: #519903). * Bug fix: "FTBFS with binutils-gold", thanks to Peter Fritzsche (Closes: #554418). -ldl added to bfd linker args * Bug fix: "[INTL:es] Spanish debconf template translation for gcl", thanks to Francisco Javier Cuadrado (Closes: #508728). * Bug fix: "[INTL:it] Italian translation", thanks to Vincenzo Campanella (Closes: #560364). * gcc error/warning cleanups * fix plt table awk -- Camm Maguire Fri, 11 Dec 2009 17:45:14 +0000 gcl (2.6.7-45) unstable; urgency=high * proper word order detection macro, fixes armel -- Camm Maguire Mon, 01 Sep 2008 13:48:16 +0000 gcl (2.6.7-44) unstable; urgency=high * backoff on arm opts * more careful handling of GCL_GPROF_START -- Camm Maguire Sat, 23 Aug 2008 21:28:52 +0000 gcl (2.6.7-43) unstable; urgency=low * redo unrandomize.h to enable compilation under -O2 -- FIXME; Closes: 494153 -- Camm Maguire Wed, 20 Aug 2008 21:18:43 +0000 gcl (2.6.7-42) unstable; urgency=low * more div/rem symbols for alpha -- Camm Maguire Sun, 03 Aug 2008 11:18:51 +0000 gcl (2.6.7-41) unstable; urgency=low * more div/rem symbols for arm and hppa -- Camm Maguire Sat, 02 Aug 2008 00:36:07 +0000 gcl (2.6.7-40) unstable; urgency=low * default gcc with pic enabled on mips/mipsel -- Camm Maguire Fri, 01 Aug 2008 13:28:00 -0400 gcl (2.6.7-39) unstable; urgency=high * gcc 4.2 for mips/mipsel for now * __divdi3 et. al. symbols for ia64 and arm * clean some compiler warnings -- Camm Maguire Fri, 01 Aug 2008 12:53:07 -0400 gcl (2.6.7-38) unstable; urgency=low * No infinite unrandomization loops -- Camm Maguire Thu, 31 Jul 2008 15:18:37 -0400 gcl (2.6.7-37) unstable; urgency=low * Non-maintainer upload to fix pending l10n issues * Debconf templates and debian/control reviewed by the debian-l10n- english team as part of the Smith review project. Closes: #457025 * [Debconf translation updates] - Portuguese. Closes: #457576 - Czech. Closes: #457677 - French. Closes: #458120 - Finnish. Closes: #458255 - Galician. Closes: #458529 - Vietnamese. Closes: #459008 - Russian. Closes: #459308 - Dutch. Closes: #459541 - German. Closes: #459887 * [Lintian] Correct FSF address in debian/copyright * [Lintian] Remove extra whitespaces at the end of debian/in.gcl-doc.doc-base.tk * [Lintian] Correct section in doc-base documents from Apps/Programming to Programming * Accept NMU * Bug fix: "[INTL:sv] po-debconf file for gcl", thanks to Martin Ågren (Closes: #492241). * Bug fix: "gcl: FTBFS [amd64]: cannot trap sbrk", thanks to Daniel Schepler (Closes: #487435). Modified and applied personality handling patch. * Bug fix: "gcl: Builds broken package with gcc-4.3", thanks to Daniel Schepler (Closes: #467474). Added sincos to plttest.c -- Camm Maguire Thu, 31 Jul 2008 15:18:15 -0400 gcl (2.6.7-36) unstable; urgency=low * statsysbfd in Debian, incoporating modules into libgcl.a for compiler::link support -- Camm Maguire Fri, 30 Nov 2007 12:03:31 -0500 gcl (2.6.7-35) unstable; urgency=low * drop gcc-3.4 on arm, Closes: #440421 * Depend on emacs22 | emacsen, Closes: #440190 * debconf translations Closes: #410683, Closes: #419736, Closes: #423706, Closes: #441408 -- Camm Maguire Fri, 23 Nov 2007 10:25:23 -0500 gcl (2.6.7-34) unstable; urgency=low * add read-byte,read-sequence,write-byte,write-sequence support * fix some float parsing inaccuracies * support GNU_HASH sections, Closes: #426135 * safety 2 for certain low level functions in gcl_listlib.lsp, CLoses: #415266 -- Camm Maguire Wed, 4 Jul 2007 16:23:25 -0400 gcl (2.6.7-33) unstable; urgency=low * Fix leading underscore behavior of my_plt * add sqrt to plttest.c * disable-nls added to the binutils subconfigures to avoid msgfmt dependency * remove -lintl from powerpc-macosx.defs * update to make-user-init from cvs head to support hol88, fix link on mingw * solaris-i386 support * fix read-char-no-hang on mingw * fast compile without wrap-literals * sigaltstack support * fix cerror -- Camm Maguire Wed, 16 May 2007 12:45:40 -0400 gcl (2.6.7-32) unstable; urgency=low * static function pointers for hppa -- Camm Maguire Sun, 29 Oct 2006 02:15:13 -0500 gcl (2.6.7-31) unstable; urgency=low * no C optimization on hppa, gcc 4.x on hppa * update cs.po, Closes: #389211 -- Camm Maguire Fri, 27 Oct 2006 13:06:55 -0400 gcl (2.6.7-30) unstable; urgency=low * make sure *tmp-dir* is set * makeinfo is optional -- Camm Maguire Wed, 25 Oct 2006 17:37:54 -0400 gcl (2.6.7-29) unstable; urgency=low * Fix build issues on hppa and m68k -- Camm Maguire Sat, 21 Oct 2006 15:10:41 -0400 gcl (2.6.7-28) unstable; urgency=low * si::gettimeofday function for HOL88 build;macosx fixes -- Camm Maguire Wed, 18 Oct 2006 13:21:26 -0400 gcl (2.6.7-27) unstable; urgency=low * unrestricted gcc for alpha * more default stack space -- Camm Maguire Tue, 17 Oct 2006 16:33:43 -0400 gcl (2.6.7-26) unstable; urgency=low * Fix large float read bug in c1constant-value -- Camm Maguire Mon, 16 Oct 2006 12:41:03 -0400 gcl (2.6.7-25) unstable; urgency=low * build-dep on gcc3.4 where appropriate * Newer standards -- Camm Maguire Thu, 12 Oct 2006 09:37:08 -0400 gcl (2.6.7-24) unstable; urgency=low * build-dep on gcc3.4 where appropriate * Newer standards -- Camm Maguire Thu, 12 Oct 2006 02:22:04 -0400 gcl (2.6.7-23) unstable; urgency=low * backoff to gcc-3.4 on alpha,arm,hppa, and m68k -- Camm Maguire Wed, 11 Oct 2006 10:16:59 -0400 gcl (2.6.7-22) unstable; urgency=low * HAVE_SYS_SOCKIO_H for solaris * autolocbfd for solaris * no -Wall when no gcc * no -fomit-frame-pointer on m68k * no profiling on mips * $(AWK) instead of awk * si::stat function * fix 'the boolean type coersion error * no varargs on cygwin * while eval macro * gensym counter fixes * xgcl updates -- Camm Maguire Fri, 15 Sep 2006 13:48:28 -0400 gcl (2.6.7-21) unstable; urgency=low * Fix socket write error -- Camm Maguire Wed, 6 Sep 2006 09:59:50 -0400 gcl (2.6.7-20) unstable; urgency=low * fix ia64 build -- Camm Maguire Thu, 31 Aug 2006 15:14:18 -0400 gcl (2.6.7-19) unstable; urgency=low * xgcl upgrade * parse_number from cvs head with *read-base* fixes * fix object_to_string * install xgcl-2/sysdef.lisp * fix info dir and emacs site lisp dir installation * New xgcl readme * Remove bashism from debian/rules, Closes: #376806, Closes: #385176. * Fix dwdoc doc-base error, Closes: #385126 -- Camm Maguire Wed, 30 Aug 2006 12:13:46 -0400 gcl (2.6.7-18) unstable; urgency=low * remove emacs build dependency * synch xgcl-2 with Novak edits * fix build errors * Remove power of two limit to MAXPAGE;fix X lib paths * configure cleanup * delete-file works on directories;build xgcl the old way;latest xgcl from Gordon Novak -- Camm Maguire Wed, 23 Aug 2006 14:19:51 -0400 gcl (2.6.7-17) unstable; urgency=low * Bug fix: "gcl: [INTL:sv] Swedish debconf templates translation", thanks to Daniel Nylander (Closes: #343695). * Bug fix: "gcl: French debconf templates translation update", thanks to Sylvain Archenault (Closes: #344629). * clean xgcl-2/gmon.out * cleanup latest gcc type-punning warnings * defentry C proclamations and xgcl cleanup -- Camm Maguire Mon, 26 Jun 2006 16:45:09 +0000 gcl (2.6.7-16) unstable; urgency=high * Add missing build dependencies, omit html generation to avoid non-free dependencies, CLoses: #372574. -- Camm Maguire Mon, 19 Jun 2006 14:05:59 +0000 gcl (2.6.7-15) unstable; urgency=low * Use internal gettext for bfd * Restore xgcl2 * Set compiler::*tmp-dir* at runtime * report tmp-dir setting with system-banner to enable clean -eval - batch operation; fix listen on socket streams; use (abs (getpid)) in tmp names for Windows * fix configure unbalanced quotes * support for bignums in nth et.al. * Fix branch cut of atanh * Fix typep on simple-arrays * prevent nested free errors * revert atanh branch cut change * Fix function documentation wrapping by compile * cond evalmacro from cvs head * Fix fixnum declarations in new smallnthcdr/bignthcdr * fix simple-array typep * updates for lsp/sys-proclaim * xgcl integration -- Camm Maguire Fri, 9 Jun 2006 17:52:22 +0000 gcl (2.6.7-14) unstable; urgency=low * Add mount declaration to plt.c -- Camm Maguire Sun, 18 Dec 2005 12:56:51 +0000 gcl (2.6.7-13) unstable; urgency=low * Add feof to plttest.c for macosx * plt related fixes for macosx * fix configure * Cleanup LEADING_UNDERSCORE case in plt.c et.al for macosx et.al. * pass devices if present in compiler::get-temp-dir, fix disassemble for new gazonk name pattern -- Camm Maguire Sat, 17 Dec 2005 15:22:40 +0000 gcl (2.6.7-12) unstable; urgency=low * Fix read-char-no-hang * Strip emacs warnings when finding site-lisp directory * mach-o update for latest binutils * Latext bfd mach-o support from Aurelien * revert to locbfd default on ppc-macosx * More ppc macosx fixes from Aurelien * revert a few macosx changes * default to void * prototype on my_sbrk for latest macosx pending Aureliens #ifdef * Fix plt.h parsing on macosx * Fix leading_underscore detection on mac * macosx name mangling fixes * multi-process safe gazonk names in compiler::*tmp-dir* * Add underscore-mangled setjmp calls to plttest.c for macosx * Fix POTFILES.in, Closes: #336207. * Update templates, Closes: #324636 * New French and Swedish translations, Closes: #333654, Closes: #336757. -- Camm Maguire Wed, 14 Dec 2005 18:52:49 +0000 gcl (2.6.7-11) unstable; urgency=low * Remove gcc-3.3 for arm in debian/rules * make default maxpage depend on SIZEOF_LONG and PAGEWIDTH in a sane fashion -- Camm Maguire Thu, 20 Oct 2005 00:08:37 +0000 gcl (2.6.7-10) unstable; urgency=low * Fix long-call gcc configure bug for ppc, add fdollars in identifiers on arm * remove gcc restrictions on arm * revert 64bit coersion (gmp_big.c, maybe_replace_big) and replace with code in siLnani (main.c) to get addresses from bignums. 2.7.0 will have 64bit fixnums on 64bit machines, but this should not be backported to 2.6.x -- Camm Maguire Wed, 12 Oct 2005 23:11:12 +0000 gcl (2.6.7-9) unstable; urgency=low * 64bit fixnum fasd data format fix from cvs head -- Camm Maguire Wed, 5 Oct 2005 18:49:50 +0000 gcl (2.6.7-8) unstable; urgency=low * Fix 64bit fixnum coersion bug using code from cvs HEAD -- Camm Maguire Fri, 30 Sep 2005 22:14:38 +0000 gcl (2.6.7-7) unstable; urgency=high * Scan .o file for init name when using dlopen * Set init name using .o file instead of source file by default * wrap-literals function from cvs head to allow optimizations using compile or compile-file * ADDR_NO_RANDOMIZE fix -- Camm Maguire Thu, 29 Sep 2005 17:50:56 +0000 gcl (2.6.7-6) unstable; urgency=high * Build bfd snapshot locally, Closes: #318681 -- Camm Maguire Tue, 20 Sep 2005 17:53:17 +0000 gcl (2.6.7-5) unstable; urgency=high * gcc-3.3 for arm -- Camm Maguire Thu, 15 Sep 2005 20:33:00 +0000 gcl (2.6.7-4) unstable; urgency=high * gcc 3.4 on arm to work around reserved '$' identifiers. * gcl: French translation update * French translation added, Closes: #325214 * Czech translation added, Closes: #325869 -- Camm Maguire Thu, 15 Sep 2005 13:45:11 +0000 gcl (2.6.7-3) unstable; urgency=low * static wraper for compiled_regexp for ia64 -- Camm Maguire Sat, 10 Sep 2005 11:26:37 +0000 gcl (2.6.7-2) unstable; urgency=high * rebuild against libgmp3c2, Closes: #323765 * 2.6.7 fixes all gcc 4.0 issues. Closes: #323979 -- Camm Maguire Wed, 24 Aug 2005 00:44:48 +0000 gcl (2.6.7-1) unstable; urgency=high * Fix (listen) with readline on * fix control-d with readline * libreadline5 support for Debian * Support for pre-compiled regexps and new texinfo format * Reenable run-process * Push function 'accept into lisp, use select for 'listen on socket streams * New Upstream release version * Native-reloc feature * Add daemon capabilities to server sockets, document socket and accept * Some gcl-tk fixes * Update wrapt-literals strategy to be consistent with CVS head -- wrap evreything but symbols and integers, don't wrap when keeping the gazonk files for linking in different images, this is really a compile-file operation * gcltk demo cleanups * Probe-file, open_stream, and the like fail on directories * Resolve symlinks in truename * Place prototypes for defcfun in header files * Support for unique init names for compiler::link and the like * libreadline5 for Debian * remove _o from init-names * gcc-4.0 fixups * Bug fix: "gcl: depends on binutils-dev <<= 2.1.5-999), so uninstallable in unstable", thanks to Steve Langasek (Closes: #318681). Rebuild with new release to autocompute this dep * Bug fix: "gcl: Please switch to po-debconf", thanks to Lucas Wall (Closes: #295930). Apply po-debconf patch * Newer standards -- Camm Maguire Thu, 11 Aug 2005 15:00:26 +0000 gcl (2.6.6-1) unstable; urgency=high * New upstream release * Allow .data section to be first in executable, as on solaris. Also allow for new bfd section size semantics * Don't try to write map file when not using GNU ld. Also allow compile-file to process pathnames with whitespace on Windows * Fix corner case fixnum arithmetic on 64bit machines * Rework gmp_wrappers semantics for older gcc * Explicitly mprotect loaded code pages PROT_EXEC on x86 Linux, as FC3 now requires it. * lisp-implementation-version is GCL * Reader extension patch allowing for foo::(bar foobar) semantics * a shell script variable fix in "unixport/makefile" for MSYS * __MINGW32__ malloc initialisation fix in "o/alloc.c" * Windows file/directory fixes in "o/unixfsys.c" * MinGW32 -march in configure - removes deprecation warnings * MinGW32 directory fix - "o/mingfile.c". * Allow for sysconf to determine clock granularity at compile time to fix time errors on the Itanium * Disable SGC on macosx until the sgc/save problem can be fixed. * Fix fixnum print bug on 64bit * Fix nil types in room report * 64bit fixes to fixnum_add and fixnum_sub * Fix Mac SGC/save bug, at least in part -- Camm Maguire Sun, 16 Jan 2005 02:28:50 +0000 gcl (2.6.5-1) unstable; urgency=high * New gmp_wrappers.{c,h} files that prevent all GBC within gmp, obviating the need for gmp patches and a local gmp configure. FIXME -- extend to all gmp functions in a systematic way, and write header information for future use in the compiler, making sure that plt.c carries the needed gmp symbols at this point * Build support for gmp_wrappers * Support for gmp_wrappers in alloc_relblock/alloc_contblock;Support for GCL_GPROF_START define in gprof functions * dynsysgmp on by default; configure backs off to local gmp configure and build automatically if needed either because gmp not present or patched symbols are needed; autodetect and set the _start symbol when using gprof * Fix (setf (get ...) ...) return bug when interpreted * Fix overwrite end of sgc_type_map bug * Versioned depends on binutils-dev manually installed by Debian build process * New upstream release * Proper binutils dependency for Debian * head -1l -> head -n 1 for freebsd * Cleanup gmp_wrapper code, check for in-place calls as write in one step is not guaranteed in gmp according to its developers * Rebuild against binutils 2.15, Closes: #266253, Closes: #263983 -- Camm Maguire Tue, 17 Aug 2004 18:22:27 +0000 gcl (2.6.4-1) unstable; urgency=high * New upstream release * Make disassemble work when original system directory is gone * New debian/support files for debconf image default selection support * More descriptive compiled C function names for use in gprof when profiling is compiled in * Compiler fix for proclaimed vararg functions * Allow sharp numbers to be bignums * lintian fix in string-match * Prototype for alloca for lint * Improve gprof support * Improve sgc page allocation which optimize-maximum-pages is in effect and the hole is overrun * Build a profiling set of images as well for Debian, toggle between all four by default via debconf * reset-sys-paths lisp function for moving image installation directories, show profiling support in banner if present * Fix typo in sys docs * reset sys paths on installation -- Camm Maguire Thu, 5 Aug 2004 22:48:56 +0000 gcl (2.6.3-1) unstable; urgency=high * Correctly parse gcc version strings in gmp3 subconfigure on arm * Fix variable capture error in dotimes macro * Better sed separator for LI-CC in unixport/makefile * Fix segfault in string-match * vs_top=sup -> (reset-top) where possible in compiler. FIXME: a few items of a different form which need to set *sup-used* too. * Correct room report to show proper percentages when sgc is on * Read in RELOC environment variable if set as default in debian/rules * Remove local bfd libraries from libs variables as their objects are incorporated into libgcl and as the source directory may not be available at runtime * Remove pcl/pcl_gazonk*lsp build-generated files from source -- Camm Maguire Thu, 15 Jul 2004 14:26:44 -0400 gcl (2.6.2-3) unstable; urgency=low * Fix value stack leak in rare compiled call sequence -- Camm Maguire Tue, 13 Jul 2004 10:17:02 -0400 gcl (2.6.2-2) unstable; urgency=low * New upstream point release -- Camm Maguire Tue, 13 Jul 2004 10:08:53 -0400 gcl (2.6.2-1) unstable; urgency=low * gcc-3.4 support * Proper isnormal default courtesy of Magnus Henoch * gclclean makefile target and other small makefile changes * Proper check for C stack array body address in gbc.c and sgbc.c * New upstream release * acconfig.h update for isnormal default * Fix bug in setting elements (si::aset) of 0 rank arrays uncovered by the random tester * No -fomit-frame-pointer on mingw * Backport minimal ansi-test patches from HEAD to enable running of the random tester * installed tcl/tk patch for mingw * Fix banner license detection code in lsp/gcl_mislib.lsp as 8features* entries are now keywords * o/makefile changes to work around trailing slash -I arguments gcc bug on mingw * Patch to mingwin.c:fix_filename to close long standing 'maxima ignore-errors filename corruption' bug on mingw * Check for too large rank supplied to make-array1 * Fix potential stack overwrite bug in quick_call_sfun/eval.c * Add -mprferred-stack-boundary=8 on amd64, as constant integers used in a call must be retrievable with va_arg(,fixnum) * Revert preferred-stack-boundary option on amd64 as it does not play well with external libraries, also eliminate -m64 to allow for user settings. Cast fixnum constant C arguments in gcl_cmploc.lsp explicitly to (long) to ensure they can be extracted via va_arg(,fixnum) * reenable SA_SIGINFO on amd64 to restore SGC there * Include elf.h in FreeBSD.h * Allow for elf_abi.h in FreeBSD.h * Add README.openbsd file * readme.mingw updates * solaris.h updates for custreloc option * Close possibility of malloc failure due to intervening gbc arising from the misordering of allocation calls * C_GC_OFFSET is 2 on m68k-linux * Add release notes, remove gcl document presumably based on dpANS for now * Fixup bad extern declaration of signals_handled in usig.c -- Camm Maguire Fri, 25 Jun 2004 22:43:52 +0000 gcl (2.6.1-39) unstable; urgency=high * Fix segfault in referencing (sgc_)type_map out of bounds which can occurr when C stack is below heap, as on alpha. * Cleanup compiler warnings on bcmp.c bzero.c and bcopy.c * Clean up compiler warning in file.d * Ensure set TLDFLAGS are used in finding DBEGIN in copnfigure.in, for OpenBSD -- Camm Maguire Fri, 7 May 2004 21:50:03 +0000 gcl (2.6.1-38) unstable; urgency=low * Make *features* entries keywords -- add canonical host cpu and kernel-system to *features*, disable h files specific ADDITIONAL_FEATURES macro in main.c * Fix merge-pathanames bug in concatenating default and supplied directory lists * Minor pathname and *features* fixes * Fix recently introduced configure.in syntax bug * Minor patches to support big gcl images -- all page integers must be long ints, need stack space limits that scale with MAXPAGES at least to allow free_map stack array in sgc_start. FIXME -- right now can handle situations where page numbers are ints, but npage*PAGESIZE is a long, need to handle npage >MAX_INT later. This is to support the 'billion cons element acl2 image' requested by a gcl user * Revert winnt features and debugging aids in configure.in * OpenBSD support, gcc warning cleanups for long page integers -- Camm Maguire Mon, 3 May 2004 21:34:57 +0000 gcl (2.6.1-37) unstable; urgency=high * mprotect pages PROT_EXEC as CLEAR_CACHE step on amd64-linux * Prevent recursive malloc calls for OpenBSD error reporting * Push dummy 0 time for child runtime on windows to be compatible with other platforms for now * Make sure pages are mprotected PROT_EXEC for amd64 support -- Camm Maguire Tue, 13 Apr 2004 21:00:22 +0000 gcl (2.6.1-36) unstable; urgency=low * Improve optimize-maximum-pages algorithm -- Camm Maguire Tue, 6 Apr 2004 03:23:40 +0000 gcl (2.6.1-35) unstable; urgency=low * Fix sigcontext autodetection on sparc -- Camm Maguire Sun, 4 Apr 2004 19:26:48 +0000 gcl (2.6.1-34) unstable; urgency=low * Fix GNU_LD autodetection in configure.in * Eliminate C_INCLUDE_PATH from shell script wrapper * Use lisp rather than 'system touch' to make empty map file in compiler::link * fix small bug when info is passed bad second argument * Don't try to open map file if doesn't stat (macosx) * Add earlier forgotten branch patch to sfaslbfd.c for macosx * Backport new eval-when keyword support from 2.7 to run random tester * Perhormance improvement to gcl_seqlib.lsp -- no inner loop over bignums * Proper contblock/relblock determination when expanding string streams * Proper string type determination for *link-array* * .ini files depend on plt.h * plttest.c cannot depend on include.h * Address longstanding FIXmE in gensym, so that two strings are not allocated for each gensym * Fix rare infinite loop bug in array.c * Import si::info into 'user * , -> # as sed separator * Minro warning removals and fixups * Binary searches through ordered arrays of referred and changed variables for dramatic compiler performance improvement in the large case -- support declarations and thereby optimizations of the form (declare ((vector t) foo)), etc. * Better 'time macro * rebuild pcl_gaz* files * cleanup room report and give more space to modern large heaps * room report formatting * Properly gensymmed time macro * Allow for white space chars in compiled filenames * Autodetect and work around sbrk randomization, e.g. on Fedora 1 * Probe for sbrk before probing for randomized sbrk * Openbsd changes -- maximize data seg resource if possible, avoid mallocing error message when allocation routines fails * Fix sigcontext configure tests * Rename loop-finish -> sloop-finish in sloop package so that sloop and ansi loop can be used simultaneously * Handle arguments which are zero in LCM * Fix typo in configure.in * Improved dotimes macro which avoids unnecessary fixnum garbage generation * Backport of ignorable declaration keyword for new dotimes macro * si::*OPTIMIZE-MAXIMUM-PAGES* support * rebuild pcl generated lisp files -- Camm Maguire Sat, 3 Apr 2004 19:27:18 +0000 gcl (2.6.1-33) unstable; urgency=low * Remove extraneous symbols from plt.h, autodetect and correct for leading underscore in object symbols * complete readline version detection commit * Backport support for new eval-when keywords * Autodetect GNU ld and add -Wl,-Map only when appropriate -- Camm Maguire Wed, 10 Mar 2004 22:51:44 +0000 gcl (2.6.1-32) unstable; urgency=low * Try to automatically determine the form used for the explicitly compiled in external function addresses in plt.c * No need to explicitly write cr-lf on windows * Autodetection of machine on FreeBSD * Updated defs and h files for FreeBSD courtesy of Mark Murray * Minor ifdefs needed for FreeBSD * Refer to exported non-static C stub of fSmake_vector1 in plt.c (needed on ia64) * Readline 4.1/4.3 configure magic -- Camm Maguire Tue, 9 Mar 2004 01:58:43 +0000 gcl (2.6.1-31) unstable; urgency=low * Adjustments to vs_top reset logic to clear (hopefully last) remaining bug found by the random-tester * Allow args-info-referred-vars to match replaced vars, clearing bug report submitted by Matt Kauffman * Rework plt code yet again to be compatible with compiler::link for axiom, and mingw32 -- Camm Maguire Mon, 8 Mar 2004 12:16:46 +0000 gcl (2.6.1-30) unstable; urgency=low * Fix rsym generated symbol tables for 64 bit platforms * Make sure 'unwind' in frame.c does nt go below frs_org * Do not define symbols with no value, either in bfd/rsym, or in plt.c. Generates a clear and explicit error of an undefined symbol when we've missed an address * Define the external symbols known to be written at present in plt.c * fix some more compiler errors found by the random tester -- all related to proper unwinding of temporary reductions of vs_top from te local supremum -- Camm Maguire Sat, 6 Mar 2004 02:05:59 +0000 gcl (2.6.1-29) unstable; urgency=low * Remove implicit dependency on gawk, optimize plt.c a little -- Camm Maguire Wed, 3 Mar 2004 16:08:30 +0000 gcl (2.6.1-28) unstable; urgency=low * make sure bfd fasload initializes dum.sm.sm_object1 for read_fasl_vector * When a tagbody contains ccb reference tags, and hence i itself marked ccb, mark all the clb tags therein ccb too, as the tagbody environment will be consed in c2tagbody-ccb. FIXME -- review this logic carefully * fix typoe in o/sfaslbfd.c * Add code to unwind redefinitions of the stack supremum in c2expr-top (used in c2multiple-value-prog1 and c2multiple-value-call in evaluating arguments) on non-local exit * Use new temporarry variables holding lisp stack supremum for lint * Eliminate extraneous warning message when allocating fewer pages than already allocated * Rework internal plt symbol address capture * Cleanup sfaslelf compiler warning -- Camm Maguire Wed, 3 Mar 2004 00:27:08 +0000 gcl (2.6.1-27) unstable; urgency=low * Modify default banner slightly * Homebrew plt-like mechanism for ensuring that valid internal addresses exist to which undefined symbols in compiled lisp objects referring to external shared libraries can be relocated * Make configure demand gettext when choosing --enable-locbfd * Make sure references to ldb1, a stub conventionally optimized away, can be resonled when optimization is turned off * completion_matches -> rl_completion_matches in gcl_readline.d, which is what is exported in the headers -- Camm Maguire Fri, 27 Feb 2004 23:50:49 +0000 gcl (2.6.1-26) unstable; urgency=low * Rework compiler::*ld-libs*, compiler::link, and unixport/makefile to accomodate mingw need for firstfile.o and lastfile.o * Remove incompatible -fomit-frame-pointer when compiling with -pg profiling * Load sys-proclaim.lisp files forimproved linking and smaller object size across the board, install same for use with compiler::link * Use pathnames instead of strings in compiler::link, also in image init files, for Windows * small mod to unixport/makefile re filtering of firstfile and lastfile * Backport zero divisor error cnditions from HEAD for floor,ceiling,truncate * Default to debug mode on hppa to work around gcc compiler optimization bugs * Add missing m4 and automake files in binutils directory to enable automake and autoconf here * Add mach-o specific files from cvs head to local bfd tree * Add bfd/po makefiles * Macosx defaults in configure.in * bfd make and configure file changes to handle mach-o backend * *gcl-version* -> *gcl-minor-version*,*gcl-extra-version* * Support for more informative banner reading features list * Support for both sigbus and sigsegv in sgbc.c as is customary in .h files * mach-o compatible changes in sfaslbfd.c * Support for new debugging section names in sfaslelf.c * powerpc-macosx h and defs files from cvs head -- Camm Maguire Wed, 25 Feb 2004 23:08:59 +0000 gcl (2.6.1-25) unstable; urgency=low * rl_putc_em a carriage return after invoking readline to ensure the prompt in rl_putc_em_line is cleared. * use standard sgc fault recovery element for hppa as recommended by hppa kernel experts * Store banner in si::*system-banner* for possible modification in compatibly licensed programs * exit with -1 when standard in ends in lisp debug mode * Backport macosx files from cvs HEAD * Document system return codes -- Camm Maguire Fri, 13 Feb 2004 20:44:54 +0000 gcl (2.6.1-24) unstable; urgency=low * Revert unixport/makefile link order fix for windows, breaks compiler::link, find another way * runtime SGC fault recovery test * Protect read/fread in case SGC is enabled with safe (restartable) versions * SGC on for arm and hppa * remove fast-link workaround now fixed for windows * Backport HEAD makefile changes to clean .{c,h,data} files and new_decl.h, remove said from repository (generated files) -- Camm Maguire Thu, 12 Feb 2004 05:56:29 +0000 gcl (2.6.1-23) unstable; urgency=low * Remove calls to init-readline with new automatic readline setup -- Camm Maguire Tue, 27 Jan 2004 20:27:20 +0000 gcl (2.6.1-22) unstable; urgency=low * Build depend on emacs21 | emacsen -- Camm Maguire Fri, 23 Jan 2004 22:01:15 +0000 gcl (2.6.1-21) unstable; urgency=low * Automatic readline initialization * Add watch file * Prevent circular error loops * Prevent automatic optimization added to CFLAGS by autoconf * Rework documentation installation in and outside of Debian * Support user deined predicates at an elementary level in the form '(satisfies foop) in gcl_predlib.lsp * Install binary gcd algorithm for ~10% performance increase * Rescale some default allocation parameters -- bignum allocation by relblocks by default, default growth parameters are 1 (min), 0.1*MAXPAGE (max), 0.5 (increase), 0.3 (percent free), holepage is 4*MAXPAGE/1024, INIT_HOLEPAGE, INIT_NRBPAGE and RB_GETA scale accordingly * Clean windows/sysdir.bat * Check for zero args in new gcd code * Default hole is maxpages/10, holesize configure option added * Fix syntax errors in older reloaction code: sfaslelf.c -- Camm Maguire Fri, 16 Jan 2004 16:57:50 +0000 gcl (2.6.1-20) unstable; urgency=low * Fix gcl-doc doc-base files -- Camm Maguire Tue, 30 Dec 2003 22:30:39 +0000 gcl (2.6.1-19) unstable; urgency=low * Fix bug in compiler::c2labels in which *ccb-vs* was missing a ocal rebind * Remove duplicate tags from compiled C switch statements * Minor merges for DARWIN support * Path to configure to make --enable-emacsdir work * Check for readline/readline.h header before configuring for readline * Improve system bfd library location detection * Make sure external gmp lib is compatible via __GNU_MP_VERSION, else backoff to local gmp build; prepend externally defined CFLAGS into output CFLAGS, FINAL_CFLAGS, and NIFLAGS * Remove --enable-gmp configure option; gmp is required for GCL * Use --enable-emacsdir in debian/rules, make sure --enable-emacsdir and --enable-infodir work when arg contains ${prefix} * Fix typo in chap-6.texi * Make sure to export SGC define from config.h to cmpinclude.h -- Now that we used optimized structures in the compiler, we need at least the definition of SGC_TOUCH there to prevent GBC errors. FIXME -- handle header dependencies more robustly. Thanks to Robert Boyer for the report * Improve SGC define extraction for cmpinclude.h * Fix variable reference errors which were occurring for compiled local functions defined within closure-generating or other environment stack pushing functions when safety is set to 3 (thanks Paul Dietz for the report.). When constructing local functions and closures within a 'mother' function, *ccb-vs* will hold the number of closure environments stacked at the point of each closure creation or call to a local function. This value is stored as the cadr of a list pushed onto *local-funs*, and is read when writing out the C code for the local function or closure, where it is used to initialize *ccb-vs* and *initial-ccb-vs* for subsequent processing. The latter is used as the reference point when addressing variables in wt-ccb-vs, as the former could be still further incremented within the closure or local function itself. Local functions as opposed to closures do not increment *ccb-vs* and do not push the environment. When a local function is defined within a closure-generating flet/labels, or a tagbody or block which pushes the environment, the value of *ccb-vs* written to the list corresponding to the local function can be erroneously incremented beyond the *initial-ccb-vs* value established before any environment pushing operations were processed. It is this latter value which is appropriate for use in wt-ccb-vs, as the local functions, unlike the closures, receive an environment level with the mother generating function. We therefore push *initial-ccb-vs* onto the end the list pushed onto *local-funs* only when defining a local function, and use it to initialize an added optional variable initialize-ccb-vs in t3local-fun and t3local-dcfun, which default to the original ccb-vs. We then bind *initial-ccb-vs* to this new optional parameter instead of the former *ccb-vs, which was only appropriate for closures. * Put in rudimentary logic for the selection of stack vs. heap storage for bignums depending on the frame context. FIXME, this logic is too conservative at present. SETQ_II and SETQ_IO take an additional parameter which is malloc when *unwind-exit* is bound and contains 'frame and alloca otherwise. New macro bignum-expansion-storage. FIXME, ensure that IDECL does not need similar modification. * Cleanup a few compiler warnings in the compiler * Cleanup compiler warning in alloc.c * Eliminate unneeded transformatio of contniguous pages to other pages on save-system. * malloc -> gcl_gmp_alloc in recent setjmp frame protected bignum allocation * Add -Wa,--execstack if on an exec-shield enabled system, can be explicitly added otherwise by setting the CFLAGS variable before the configure step * Better execstack flag handling in configure * Allow for commas in CFLAGS in sed command writing *cc* * Preliminary gprof profiling support * Rework html documentation generation and installation, Closes: #221774 * Remove parentheses from setf class-name info node in chap-7.texi -- Camm Maguire Tue, 30 Dec 2003 16:26:45 +0000 gcl (2.6.1-18) unstable; urgency=low * Portability patches to makefiles to support non-GNU grep (no -q), and non-bash sh, C_INCLUDE_PATH=...;export C_INCLUDE_PATH * copy the global *info* parameter in c1flet and c1labels to prevent accumulation of old data -- FIXME -- make sure there are no other copies required, and eventually replace this global parameter with local variables * Turn on some optimization on hppa, -O only * Make all C defined functions installed into lisp static functions to work around dynamic function descriptors on ia64, Closes: #217484, Closes: #204789, (STATIC_FUNCTION_POINTERS define in config.h) -- Camm Maguire Thu, 6 Nov 2003 15:40:25 +0000 gcl (2.6.1-17) unstable; urgency=low * Repair weak symbol addition to the bfd symbol table in sfasli.c * Be more thorough about adding fun-info to call-local info in gcl_cmpflet.lsp, accompanying simplifications in gcl_cmpeval.lsp (call-global lists have info updated by args already in (c1args args info)), small changes in add-info in gcl_cmpinline.lsp, FIXME -- study rational for *info* special variable in certain places as opposed to more common copy-info -- Camm Maguire Thu, 30 Oct 2003 20:03:22 -0500 gcl (2.6.1-16) unstable; urgency=low * Fix sh syntax in debian/gcl.sh * init_or_load1 -> gcl_init_or_load1 in xgcl-2/sysinit.lsp * Load weak symbols as well as undefined symbols in bfd_build_symbol_table, for the purposes of the static build possibility * Map t and nil stream indicators properly in optimized compiled references to read_char1 and read_byte1 (in read.d) -- Camm Maguire Thu, 23 Oct 2003 16:43:15 +0000 gcl (2.6.1-15) unstable; urgency=low * Remove imod/ifloor functions in cmpaux.c and directly inline their fixed equivalents in gcl_cmpopt.lsp -- Camm Maguire Mon, 13 Oct 2003 15:04:24 +0000 gcl (2.6.1-14) unstable; urgency=low * generate less garbage in add-info (gcl_cmpinline.lsp), enabling maxima compile to complete in a finite time :-) -- Camm Maguire Fri, 10 Oct 2003 22:14:04 +0000 gcl (2.6.1-13) unstable; urgency=low * Fix compiler optimization bug in gcl_cmpopt.lsp -- missing parens around inliner for max and min * collect info structures for local functions in flet and labels processing (gcl_cmpflet.lsp), and pass upwards to call-local and call-global (gcl_cmpeval.lsp) to fix certain inlining bugs in via more proper operation of args-info-changed-vars (gcl_cmpinline.lsp, inline-args, gcl_cmplet.lsp, c2let) * Fix an obviou int overflow in ifloor (o/cmpaux.c), handle more proper fixnum/integer determination from declarations later -- Camm Maguire Fri, 10 Oct 2003 02:34:11 +0000 gcl (2.6.1-12) unstable; urgency=low * Restore mpz_to_mpz{1} in gmp_big.c, can be written by compiler * tk8.4 patches * Prevent destructive modification of bignum arguments in log_op/mp_op in gmp_big.c * Make sure to push stack variables onto newly allocated C variable when inlining args and args cause side effects, in inline-args, gcl_cmpinline.lsp * Fix bug related to gcc-3.3 fixes in set_exponent in num_co.c * Remove pcl_methods.c patch. as is apparently no longer needed, TODO -- make sure VOL modifier is inserted where needed to prevent longjmp clobbers -- Camm Maguire Thu, 2 Oct 2003 14:26:43 +0000 gcl (2.6.1-11) unstable; urgency=low * Add compilation step of compiling all lsp and cmpnew .lsp files from an interpreted only saved_pre_gcl before the creation of saved_gcl - - this enables us to use full optimization on these files while getting the STREF constants right on 32bit and 64bit * remove 'attic' from comment in gcl_loop.lsp * configure changes for sizeof(struct contblock) detection -- Camm Maguire Wed, 24 Sep 2003 16:09:44 +0000 gcl (2.6.1-10) unstable; urgency=low * Mac OSX GET_FULL_PATH_SELF * Preliminary subtypep checking for 'satisfies * preliminary 'satisfies support in subtypep, more predicate type pairs and reverse checking * small compiler change to remove unused C variables from optimized compiled macros * Optional compiler init file is called gcl_cmpinit * fasdmacros.lsp -> gcl_fasdmacros.lsp * All cmpinit.lsp files named gcl_cmpinit.lsp; allow full lisp optimization in all directories * collectfn -> gcl_collectfn in lsp/gcl_auto.lsp * collectfn -> gcl_collectfn in cmpnew/gcl_make-fn.lsp * Make sure makefiles can generate sys-proclaim.lsp, regenerate these files and recompile from lsp * Rebuild with opts enabled * Iterate sys-proclaim/rebuild generation once more * Iterate sys-proclaim/rebuild for pcl and clcs -- Camm Maguire Tue, 23 Sep 2003 19:33:27 +0000 gcl (2.6.1-9) unstable; urgency=low * Close streams in fasldlsym.c -- Camm Maguire Tue, 16 Sep 2003 14:57:20 +0000 gcl (2.6.1-8) unstable; urgency=low * Add processor flag variable to flags in configure.in * Autoadd full path to kcl_self to enable save-system when user moves executable and calls without script wrapper * Add special variables si::*collect-binary-modules* and si::*binary- modules* as a facility for discovering the list of fasloaded objects preceding a save-system is required for a subsequent compiler::link * Add collectfn.lsp to distro * Rename some files and init_ functions to eliminate namespace conflicts when building images with compiler::link * Enable compressed info reading * Make sure no opt flags are set when enable debug is specified * Use NIFlAGS to compile new_init with lower opts on ppc to work around gcc bug, restore full opts to other files -- Camm Maguire Sun, 14 Sep 2003 02:18:28 +0000 gcl (2.6.1-7) unstable; urgency=low * Fix permissions bug in temporary gzipped file handling * Propagate control changes correctly with package extension * Newer standards -- Camm Maguire Tue, 9 Sep 2003 17:06:56 +0000 gcl (2.6.1-6) unstable; urgency=low * Remove build-dependency on autoconf as a temporary work around to Debian autoconf's dependency bug on emacsen-common -- Camm Maguire Tue, 9 Sep 2003 15:29:06 +0000 gcl (2.6.1-5) unstable; urgency=low * Redefine temporary files in elisp/makefile -- Camm Maguire Mon, 8 Sep 2003 21:49:09 +0000 gcl (2.6.1-4) unstable; urgency=low * Fix to sfasli.c to avoid defining symbols in other than *UND* sections * Remove some 64 bit warnings * Turn off def_static on ia64 for now -- its broken -- Camm Maguire Sat, 6 Sep 2003 17:22:10 +0000 gcl (2.6.1-3) unstable; urgency=low * Fix static detection fr ia64; contblock size detection on arm * Fix gcc verion checking in gmp3 subconfigure, esp. for arm * Escape all sgc code with #ifdef SGC -- Camm Maguire Fri, 5 Sep 2003 21:32:47 +0000 gcl (2.6.1-2) unstable; urgency=low * Add windows/install.lsp to clean target * Add in macosx files to stable and cvs head * Fix bad debelper postinst, Closes: #208765 -- Camm Maguire Fri, 5 Sep 2003 13:15:11 +0000 gcl (2.6.1-1) unstable; urgency=low * New upstream release * Type-punning warning fixes * small_fixnum overflow fixes * off by one fix in cerror * Fix compiler error which had not recognized defpackage as a package operation * Fix tkl.lisp call to open-named-socket * Make values-list and nreconc signal errors when they should on dotted lists. * Avoid use of windows.h types as macros. * New config.{sub,guess} * Windows installer updates from CVS HEAD * fix potential longjmp clobber in read.d;add some windows files to main makefile clean target; * Darwin revealed fixes to usig.c and unixtime.c * Fix gbc time calculation in case of recursive gbc calls * Run patch_sharp in LSharp_exclamation_reader to handle new case of defpackage ops at head of fasl vector, required for maxima build * Special symbol Dotnil has ordinary list Cnil for plist and hpack * Small fixes for profiling support * Restore pp() function for debugging; print out undefined symbol names * Small patch for fix xgcl demo (thanks Michael Koehne) * Better bfd symbol table strategy * Fix bfd table symbol counting for combined_table profiling * amd64 linux support * O6 -> O3 * static linking on ia64 to work around current mechanism for runtime generated function descriptors * enable-static configure option * Fix debian/gcl-doc.docs for latest texinfo file splitting policy, Closes: #206017 * Fix typo in o/sfasli.c * Rework debian package structure to handle stable and cvs packages simultaneously * Add gazonk*.lsp to clean target * syntax fix to lsp/gprof.hc * Add support for SGC contblock pages * Fixes to debian/rules * Remove unused definitions of Vcs * Increase default maxpages and stack sizes * Maintain a persisten *system-directory* binding * Push installed /h directory onto -I flags on cc command line * Escape old in-package behavior with #ifdef ANSI_COMMON_LISP * define HAVE_XDR in linux.h * reduce resolution of contblock mark_table in gbc.c to match new minimum granularity introduced via CPTR_ALIGN * Remove exit function in main.c -- Camm Maguire Thu, 4 Sep 2003 02:20:52 +0000 gcl (2.5.3-2) unstable; urgency=low * gcc-3.3 all platforms -- Camm Maguire Mon, 7 Jul 2003 16:10:25 +0000 gcl (2.5.3-1) unstable; urgency=low * New upstream release * Restore object_to_float and object_to_double, cmpaux.c, Closes: #195470. * Remove obsolete functiion multiply-bignum-stack from documentation, si-defs.texi * Unstatic object_to_float, object_to_double -- Camm Maguire Mon, 2 Jun 2003 12:38:03 -0400 gcl (2.5.2-1) unstable; urgency=low * New upstream release * Cleanup xdrfuns.c for Axiom * Reenable xgcl build -- Camm Maguire Thu, 20 Mar 2003 09:15:54 -0500 gcl (2.5.1-1) unstable; urgency=high * some optimization now on hppa * Add RELEASE-2.5.1 file * Add dedication notice to the memory of W. Schelter -- Camm Maguire Sun, 2 Mar 2003 10:20:26 -0500 gcl (2.5.0.cvs20020625-80) unstable; urgency=low * enable japi configure flag, defaults to no * enable -mlongcall on ppc when using gcc 3.3 or higher * int -> fixnum in DEFUN function arguments for safety -- ensures pointers and integers passed by lisp are of same size * MYmake_fixnum macro simplification * ufixnum typedef * Prototypes for cmod et.al. -- restoring maxima build on ia64 * Fix unaligned access message on ia64 generated by DFLT_aet_fix * Integer va_arg uses fixnum * Define __*i3 symbols used by GCL, supplied by libc, and written into some GCL compiled objects, restores ARM build with ANSI image * num_log.c miscompilation on ia64 apparently fixed, Closes: #156291 * Ensure cmpinclude.h up to date in main makefile -- Camm Maguire Sat, 1 Mar 2003 17:33:29 -0500 gcl (2.5.0.cvs20020625-79) unstable; urgency=low * Fix Debian package install bug -- Camm Maguire Thu, 27 Feb 2003 23:17:55 -0500 gcl (2.5.0.cvs20020625-78) unstable; urgency=low * Add config.log config.status and config.cache to clean target * Remove xgcl-2/debian directory * Update clcs/sys-proclaim.lisp -- Camm Maguire Thu, 27 Feb 2003 18:48:38 -0500 gcl (2.5.0.cvs20020625-77) unstable; urgency=low * Lintian cleanups * Don't strip libansi_gcl.a, need .data at end of .o, as with libgcl.a * Take newlines out of doc string for init-cmp-anon * Cleanup gcc-3.2 compiler warning * 64 bit STREF fixes * pcl and clcs need to have C rebuilt afresh, as 64 bit machines write different STREF offsets into the C files * Rework Debian package build a bit * README.Debian explaining the toggling of the ANSI image * Typo in debian/rules * Remove debian/gcl.conffiles -- Camm Maguire Thu, 27 Feb 2003 15:56:11 -0500 gcl (2.5.0.cvs20020625-76) unstable; urgency=low * Debian Priority is optional * Configure lowest common denominator on m68k to m68020 -- gcc-3.2 can't handle m68000 -- no __mulsi3 * Fix bit array bug * Add upgraded-array-element-type * Misc typep and subtypep fixes * Proper error handling in certain array.c functions * First needs exactly one arg * Proper error handlin in LAST * bit array allocation fixes in num_log.c * eliminate Iapply_fun_n1 * Dummy system find-class in traditional image, overwritten by pcl version in ANSI * Invalid variable is a program error, not a symbol is a type error * Attempt at uninterned symbol support as slot names * defstruct changes for ANSI conc-name handling * Rework ansi build to follow existing pattern for traditional image, enabling preliminary ansi support on dlopen systems * Fix broken mingw probe in main makefile * Rename pcl and clcs files to avoid init name conflict on dlopen systems * sys-proclaim for clcs * Compiler goto indentation * Compiler pointer cast in call_or_link_closure * *keep-gaz* compiler variable to save anonymously generated lisp * si::init-cmp-anon function to initialize anonymously generated and compiled lisp from .text section of running executable * Debian/rules builds and ships both images * Check for small fixnum in make_fixnum macro * Pass real integers to array functions to minimize fixnum garbage * Larger SHARP_EQ_CONTEXT_SIZE in read.d * Shadowing-import instead of import dummy symbols into common-lisp in ansi_cl.lisp * Rework object definition in makefiles * Remove old gmp directory * Remove old tests directory * Reinsert JAPI configuration * Spruce up clean target * Use saved_gcl to recompile cmpnew files * Toggle ansi image with GCL_ANSI environment variable * Version 2.5.1 -- Camm Maguire Wed, 26 Feb 2003 21:31:04 -0500 gcl (2.5.0.cvs20020625-75) unstable; urgency=low * Export truename for dlopen systems -- Camm Maguire Fri, 14 Feb 2003 23:31:15 -0500 gcl (2.5.0.cvs20020625-74) unstable; urgency=low * Remove duplicates in apropos a la clisp * Use static where possible, remove unused functions, decrease global symbol count by about 1/3 (~ 600 global functions) * Inline optimize cmod,cplus,ctimes and cdifference like maxima * eliminate make-pure-array from lfun_list.lsp, not defined * Prototypes for all possible compiler generated function calls * relative symlink for cmpinclude.h in Debian package -- Camm Maguire Fri, 14 Feb 2003 20:17:31 -0500 gcl (2.5.0.cvs20020625-73) unstable; urgency=low * typep fixes for class types * m68k Build-depend on gcc-2.95 as a temporary work around to bug 179807 * gcc-3.2 warning cleanups * bfd_boolean syntax support for newer binutils * gcc-3.2 on powerpc can't yet handle -O2 and higher * Reenable gcc-3.2 for m68k and do some guesswork in configure -- Camm Maguire Mon, 10 Feb 2003 13:47:00 -0500 gcl (2.5.0.cvs20020625-72) unstable; urgency=high * Fix to siLbit_array_op for 0 dimension arrays * Fixed aref of short-float vector * nconc can take dotted lists * tailp returns t if first arg is nil * Repair nconc and tailp fixes * varargs->stdarg for gcc 3.3 and higher -- Camm Maguire Sun, 9 Feb 2003 16:57:33 -0500 gcl (2.5.0.cvs20020625-71) unstable; urgency=high * ansi changes to sloop.lsp and conditions.lisp to fix symbol tests * :definition-before-pcl -> definition-before-pcl * Allow spaces in pathnames * Significant fixes to gmp_num_log.c affecting bitwise ops on bignums * Fix test segfault arising from faulty structure-type-included-type- name in gcl-low.lisp ; Thanks Peter * aref1 -> row-major-aref * Fixes to certain numerical functions to handle denormalized floating point numbers * Number of argument check in IapplyVector * Print offset bit vectors correctly * Correct precision for formatting short and long doubles * Added si::modf * Do not trigger error in IapplyVector if max args is zero * Fixes to with-package-iterator to cleanup compiler warnings * :invalid-variable is a type error * No max arg checking if &key or &rest present * proper defun declarations in listlib.lsp * class specifiers in typep, subtypep and coerce * Corrections to allow-other-key processing in bind.c * eval sfuns with argument error checking (in one place) * copy-structure takes only one arg * si::classp, si::class-of, and si::class-precedence-list overwritten by pcl analogs when compiling ansi * recompiled core lsp and compiler files * restore dvi and html doc build for non-mingw -- Camm Maguire Fri, 24 Jan 2003 13:55:11 -0500 gcl (2.5.0.cvs20020625-70) unstable; urgency=high * loop fixes * configure fixes * :common-lisp in *features* * :definition-before-clcs -> definition-before-clcs * protect against sgc segfault within fread in fasdump.c -- fixes m68k acl2 build * SGC for s390 -- Camm Maguire Thu, 5 Dec 2002 08:02:17 -0500 gcl (2.5.0.cvs20020625-69) unstable; urgency=high * eval fix * \-mlong-calls for arm -- Camm Maguire Mon, 25 Nov 2002 08:35:27 -0500 gcl (2.5.0.cvs20020625-68) unstable; urgency=high * enable emacsdir configure option * reordered configure X lib detection for solaris * redo integer declarations for gmp bignums to avoid compiler warnings * Clear large and negative count errors for remove/delete * Loop error fixes * cache flush with page granularity on m68k -- Camm Maguire Thu, 21 Nov 2002 17:44:30 -0500 gcl (2.5.0.cvs20020625-67) unstable; urgency=high * Align cache flushes for powerpc and m68k on 32 byte boundaries, should fix acl2 build * Removed diagnostic SIGILL trapping in cmpaux.c -- Camm Maguire Tue, 12 Nov 2002 23:25:49 -0500 gcl (2.5.0.cvs20020625-66) unstable; urgency=high * Fix SIGILL trap in cmpaux.c -- Camm Maguire Mon, 11 Nov 2002 11:14:07 -0500 gcl (2.5.0.cvs20020625-65) unstable; urgency=high * Miscellaneous Freebsd patches * non-recursive with-package-iterator * map-into fill-pointer fixes * changes to the user-init mechanism for portable acl2 build -- Camm Maguire Sun, 10 Nov 2002 12:33:59 -0500 gcl (2.5.0.cvs20020625-64) unstable; urgency=low * Fix epsilon calculations again to reenable arm build -- Camm Maguire Fri, 1 Nov 2002 07:08:33 -0500 gcl (2.5.0.cvs20020625-63) unstable; urgency=low * Add versioned dependency on the gcc used to build gcl -- Camm Maguire Tue, 29 Oct 2002 16:20:22 -0500 gcl (2.5.0.cvs20020625-62) unstable; urgency=low * with-package-iterator modifications * with-package-iterator uses labels to correctly provide for recursion * Fix doc directory problem with install target in info/makefile * Fix info dir setting in configure * Priority extra -- Camm Maguire Mon, 28 Oct 2002 23:45:07 -0500 gcl (2.5.0.cvs20020625-61) unstable; urgency=low * Placeholder support for optional condition in find-restart * defpackage error on importing non-existent symbols * working with-package-iterator macro * various package errors reported as :package-error * Destructuring-bind fixes * delete-package error fix * pcl functions use pcl-destructuring-bind for now -- fix later * Trigger error if function calls use too many 'values' * Maximum values increased to 50 * Enable previously failing tests in multiple-value-{setq,prog1}.lsp * prototype for system_time_zone_helper * Initial changes for solaris support * make -> $(MAKE) in makefiles * Incorporated main GCL (ANSI) Lisp Documentation in distribution -- Camm Maguire Mon, 28 Oct 2002 04:31:33 -0500 gcl (2.5.0.cvs20020625-60) unstable; urgency=low * Still better acosh, courtesy of Barton Willis * Better epsilon contant determination in ieee case * Implicit tagbody in do-symbols and do-all-symbols * Better epsilon handling in ieee case * Add setf (values ... support * invalid-function errors are type errors * ecase and ccase take t and otherwise clauses * ECASE/CCASE test fixes * setf values fixes to use setf instead of setq when target value is not a symbol * ETYPECASE/CTYPECASE can take t and otherwise * Backout of restart-clusters export * fix handler.lisp * Fix to bfd/GBC interaction -- Camm Maguire Wed, 23 Oct 2002 08:38:08 -0400 gcl (2.5.0.cvs20020625-59) unstable; urgency=low * wrong number of arguments, keyword errors in lambda list bindings, are program errors * acosh fix at -1.0 * New config.sub and config.guess files and automatic updates in binutils, gmp, and gmp3 subdirs -- Camm Maguire Wed, 16 Oct 2002 11:38:56 -0400 gcl (2.5.0.cvs20020625-58) unstable; urgency=low * GENSYM fixes * add complement and constantly * import certain symbols into common-lisp package * Fix makefile bug in install target * Prepend instead of overwrite C_INCLUDE_PATH in shell wrapper * More shell variable fixes in main makefile * Corrected order of push and pushnew * Set bfd_error appropriately * Report function for package-error in condition-definitions.lisp;fix internal-package-error deinition and handling;export *restart- clusters* to user error code specified in handler-case;package-error error formatting changes;dummy optional argument added to compute- restarts (for now);Paul Dietz patch to defpackage.lsp fixing several tests (thanks);export/unexport error handling fixes * Recompile c,h and data files * Fix number of argument errors in debug.lsp;documentation support for packages in defpackage.lsp and module.lsp;do-symbols loops over inherited symbols too in packlib.lsp * Reworked EXTRAS variable handling in unixport/makefile * Build-depend on autotools-dev and automatic update of config.sub and config.guess;newer config.sub and config.guess in cvs tree; Closes: #164526 * Remove stray comments in package.d * elt errors of type type error * bad-sequence limit returns type error -- Camm Maguire Tue, 15 Oct 2002 15:39:19 -0400 gcl (2.5.0.cvs20020625-57) unstable; urgency=low * Capitalization changes to names of special characters;graphic-char-p fix * fix shadowing of existing symbols in package.d * (simple-)base-string not a subtype of (simple-)vector * add package-error condition(preliminary);hash conditions only by the error name, not the format string;pass error types for both correctable and non-correctable situations;eliminate duplicate loading of clcs/package.lisp;Allow t doc-types in documentation (returning nil) for now;fix final type errors in predlib.lsp (regarding base-string);other error functions to pass continuable errors (needs cleaning up);package designators can be characters;delete-package added;make-package doesn't :use lisp by default;in-package returns error if package does not exist instead of making the package(relatively big change -- need to address instances of in-package in .lsp code);call make-package on relevant packages in init_gcl.lsp.in and pcl/sys-package.lisp; * \-ffunction-sections for hppa with no-optimization -- enables first maxima build here * separate lisp variables to specify optimization flags for level 2 and 3 * symbol-name throws a type error on bad input * tk8.2 -> tk8.3 * Fix bug in main makefile * Newlines at end of test files -- Camm Maguire Wed, 9 Oct 2002 15:04:41 -0400 gcl (2.5.0.cvs20020625-56) unstable; urgency=high * ansi-test corrections; extra-libs option to LINK function; LINK doc change; subtypep and string changes to pass more tests * Add method-combination and structure-object symbols for ansi;remove unused variables in debug.lsp;remove in-package system from defstruct.lsp;make-keyword and defmacro temporary function placeholders in destructuring_bind.lsp;predlib changes to fix ansi- test type errors;break-call takes 2 args (sys-proclaim.lisp);char and char-set protected by string dimension not fillpointer in string.d;fix bug in string.d:member_char for vector types;redefine slot reader and writer functions in pcl/impl/gcl/gcl-low.lisp -- Camm Maguire Sat, 5 Oct 2002 14:33:46 -0400 gcl (2.5.0.cvs20020625-55) unstable; urgency=high * Add LINK documentation to info pages * 0 length last support * make-sequence error check for 'null type and non-zero size * Dotted-list support in member * Reworked dotnil definitions and support macros * add compile-file-pathname * setup C_INCLUDE_PATH env variable in gcl shell wrapper * POSITIVE-FIXNUM variable type,simple-error->type error where indicated by various ansi tests, eq->eql in ldiff and tailp;proper lists only in member et. al. * rev keyword for member1 to reverse test arguments * specific-error function to pass a given type of error from lisp * set-exclusive-or preserves order of test arguments * type-errors where appropriate in make-sequence * nil keys accepted in remove/delete et.al. * Reworked linking command line to ensure that certain symbols are resolved in libgcl.a as opposed to certain system libraries, e.g. gmp * new gmp for m68k;no -ffloat-store for m68k a requested by user due to performance impact (will alter test results in maxima accordingly) * libgclp.a for objects to be overriden by the C library if necessary * readably support * boolean type * Missing ansi type support * subtype code for boolean * add missing ansi types as known types * other preliminary subtype code for missing ansi types * rework result-type check in make-sequence * :element-type support in make-string (preliminary) * (char ignores fill-pointer * remove -O4 from debian/rules -- Camm Maguire Thu, 3 Oct 2002 01:52:45 -0400 gcl (2.5.0.cvs20020625-54) unstable; urgency=high * Fix delete et. al. :from-end error; typo in gbc.c * character and string-char equal in type hierarchy * concatenate/make-sequence fixes * merge takes nil key argument * make-sequence checks size against result type * install endp macro for dotted list support -- Camm Maguire Tue, 24 Sep 2002 14:57:44 -0400 gcl (2.5.0.cvs20020625-53) unstable; urgency=high * Sleep with (in principle) microsecond precision * nth-value macro added * \-ffloat\-store and warning cleanups for m68k * Compile hppa with debugging, will get a build but a broken one, ok for now, Closes: #159591 -- Camm Maguire Fri, 20 Sep 2002 09:48:35 -0400 gcl (2.5.0.cvs20020625-52) unstable; urgency=high * Fixed gcc version bug in debian/rules -- Camm Maguire Thu, 12 Sep 2002 18:00:50 -0400 gcl (2.5.0.cvs20020625-51) unstable; urgency=high * static gmp for m68k -- Camm Maguire Thu, 12 Sep 2002 09:33:03 -0400 gcl (2.5.0.cvs20020625-50) unstable; urgency=high * Reworked static gmp target for new libgcl.a;gcc-3.2 for hppa,ia64,and arm;libgmp2-dev for m68k;no rsym with dynsysbfd;build_symbol_table earlier to shrink table size; -- Camm Maguire Thu, 12 Sep 2002 00:39:17 -0400 gcl (2.5.0.cvs20020625-49) unstable; urgency=high * Use old gmp for m68k until can pin down test failure with gmp3 -- Camm Maguire Tue, 10 Sep 2002 00:36:10 -0400 gcl (2.5.0.cvs20020625-48) unstable; urgency=high * Rework build and install so that custom images can be made without the source tree, even when using dlopen -- Camm Maguire Mon, 9 Sep 2002 23:26:47 -0400 gcl (2.5.0.cvs20020625-47) unstable; urgency=high * Install cmpinclude.h in system include directory -- Camm Maguire Thu, 29 Aug 2002 23:31:55 -0400 gcl (2.5.0.cvs20020625-46) unstable; urgency=high * Keep a *much* smaller piece of gmp.h in cmpinclude.h, reducing image size by almost 100k * Check for _SHORT_LIMB and _LONG_LONG_LIMB in configure * Remove build specific include directories from compile command in final executable * Include local regexp.h explicitly in cmpinclude.h, to eliminate intereference with system regexp.h, and to fix bug in which gcl compilation depended on existing build directories * Correctly add directory paths to extra gmp file targets in unixport/makefile for m68k -- Camm Maguire Thu, 29 Aug 2002 21:56:28 -0400 gcl (2.5.0.cvs20020625-45) unstable; urgency=high * Fix typo in rshift target for m68k -- Camm Maguire Wed, 28 Aug 2002 18:02:00 -0400 gcl (2.5.0.cvs20020625-44) unstable; urgency=high * Handle second argument to last; treat dotted lists correctly in ldiff et. al., tailp fix * optional key argument for assoc-if et.al.;eval getf deflt if in setf * Fix infinite loop in assoc-if et.al. * X_LIBS and X_CFLAGS determination in configure script -- Camm Maguire Wed, 21 Aug 2002 18:22:37 -0400 gcl (2.5.0.cvs20020625-43) unstable; urgency=high * Larger ihs stack;fix array-total-size-limit;check negative fillp;allow #P * don't make common_lisp package when not configuring with --enable- ansi * Patch gmp3/mpn/m68k/{l,r}shift.asm, restore gmp3 to m68k build * Dynamic libgmp support, overriding with patched functions from local source where necessary -- Camm Maguire Sun, 18 Aug 2002 12:10:55 -0400 gcl (2.5.0.cvs20020625-42) unstable; urgency=high * copy ansidecl.h and symcat.h in h/ for local bfd builds * localize bfd.h includes to sfaslbfd.c * take bfd/po out of the build loop * import xgcl-2, but don't build by default * oldgmp configure option, and made default for m68k as temporary workaround -- Camm Maguire Mon, 12 Aug 2002 23:49:09 -0400 gcl (2.5.0.cvs20020625-41) unstable; urgency=high * Minor rules revision for i164 -- Camm Maguire Sun, 11 Aug 2002 13:49:03 -0400 gcl (2.5.0.cvs20020625-40) unstable; urgency=high * revamp CONST configure test for certain bfd versions -- Camm Maguire Sun, 11 Aug 2002 12:31:35 -0400 gcl (2.5.0.cvs20020625-39) unstable; urgency=high * gcc-3.1 for ia64 fixes a compilation bug in num_co.c for -O3 and higher -- code takes address of a variable kept in a register * compile num_log.c with -O only on ia64 to work around compiler bug -- Camm Maguire Sun, 11 Aug 2002 08:53:03 -0400 gcl (2.5.0.cvs20020625-38) unstable; urgency=high * check for long c statck addresses, fixing NULL_OR_ON_C_STACK macro for ia64 * Remove error in clean target -- Camm Maguire Sat, 10 Aug 2002 13:20:08 -0400 gcl (2.5.0.cvs20020625-37) unstable; urgency=high * Replace tmpnam and mktemp with less dangerous mkstemp -- Camm Maguire Fri, 9 Aug 2002 19:45:52 -0400 gcl (2.5.0.cvs20020625-36) unstable; urgency=high * Fix rsym compilation when not using bfd -- Camm Maguire Fri, 9 Aug 2002 19:10:16 -0400 gcl (2.5.0.cvs20020625-35) unstable; urgency=high * Don't build bfd/po subdir * Build-depend on automake and gettext -- Camm Maguire Fri, 9 Aug 2002 14:36:58 -0400 gcl (2.5.0.cvs20020625-34) unstable; urgency=high * fix zero length array support * reverse configure order for bfd and libiberty -- Camm Maguire Fri, 9 Aug 2002 11:52:38 -0400 gcl (2.5.0.cvs20020625-33) unstable; urgency=high * chmod +x for subconfigures * dlopen for appropriate arches in debian/rules * add custreloc configure option -- Camm Maguire Fri, 9 Aug 2002 10:16:55 -0400 gcl (2.5.0.cvs20020625-32) unstable; urgency=high * Local bfd build option to prepare for arch-specific patches * Try default gmp3 build on m68k * Fix merge-pathnames -- Camm Maguire Fri, 9 Aug 2002 00:13:16 -0400 gcl (2.5.0.cvs20020625-31) unstable; urgency=high * #undef bool in object.h for some gcc-3.1 installations * New number_tan implementation using real tan, so optimized compiled code will find symbol in -lm -- Camm Maguire Tue, 6 Aug 2002 18:37:52 -0400 gcl (2.5.0.cvs20020625-30) unstable; urgency=high * fix bug in cmpif.lsp and recompile compiler * \-O6 \-fomit\-frame\-pointer for Linux, speed gain of ~ 10% * clean saved_gcl_pcl -- Camm Maguire Mon, 5 Aug 2002 16:34:33 -0400 gcl (2.5.0.cvs20020625-29) unstable; urgency=high * Back out of hppa assembler register flush for hppa, apparently issue is cleared by long/object function declaration fix * Remove ansi2knr.1 man page, Closes: #155067 * hppa still has gc leak, possibly due to faulty setjmp. Try Lamont Jones' latest assembler to flush regs -- Camm Maguire Fri, 2 Aug 2002 20:50:21 -0400 gcl (2.5.0.cvs20020625-28) unstable; urgency=high * SGC support for alpha * generic gmp3 build for m68k * compiler changes to declare all functions as returning object, with functions that actually return long being cast appropriately * back out of m68k hack in eval.c and funlink.c -- Camm Maguire Fri, 2 Aug 2002 18:22:04 -0400 gcl (2.5.0.cvs20020625-27) unstable; urgency=high * Use generic lshift.c in gmp3 for m68k * use SGC for ia64 * m68k workaround, cast (object(*)()) to (long(*)()) in funlink.c and eval.c * GBC register spiil asm for hppa * fix hash_equal declaration error in hash.d -- Camm Maguire Thu, 1 Aug 2002 18:12:49 -0400 gcl (2.5.0.cvs20020625-26) unstable; urgency=high * Remove extra load of tkl.o in install target of main makefile * gcc-3.1 for hppa * Remove gcc version spec for m68k * \-fPIC for hppa, needed for dlopen * cleanup gcc 3.1 warning in funlink.c * cc instead of ld for -shared linking in fasldlsym.c (needed for hppa) -- Camm Maguire Wed, 31 Jul 2002 18:46:54 -0400 gcl (2.5.0.cvs20020625-25) unstable; urgency=high * Move chmod +x gmp3/* into debian/rules * Remove gclm.bat from Debian package * Build-Depend on autoconf, Closes: #154909 -- Camm Maguire Wed, 31 Jul 2002 09:44:20 -0400 gcl (2.5.0.cvs20020625-24) unstable; urgency=high * chmod +x gmp3/configure -- Camm Maguire Wed, 31 Jul 2002 07:55:17 -0400 gcl (2.5.0.cvs20020625-23) unstable; urgency=high * 64bit SGC support * SGC on by default for sparc-linux and mips(el)-linux * Optimized logxor funtion * Check for MP_LIMB_SIZE in fasdump.c, for 64bit support * gbc fix for ia64 * gmp3 import for ia64 * system bzero, bcmp, and bcopy function prototypes -- Camm Maguire Tue, 30 Jul 2002 23:11:58 -0400 gcl (2.5.0.cvs20020625-22) unstable; urgency=high * ElfW macros in rsym*.c for 64bit * Allow for 8 byte gmp mp_limbs -- Camm Maguire Thu, 25 Jul 2002 18:52:37 -0400 gcl (2.5.0.cvs20020625-21) unstable; urgency=high * Support for dlopen object loading where bfd is not yet working -- ./configure --enable-dlopen -- Camm Maguire Thu, 25 Jul 2002 15:08:05 -0400 gcl (2.5.0.cvs20020625-20) unstable; urgency=high * Cleanups for --disable-bfd option -- Camm Maguire Wed, 24 Jul 2002 15:05:28 -0400 gcl (2.5.0.cvs20020625-19) unstable; urgency=high * 64bit fixes -- Camm Maguire Wed, 24 Jul 2002 12:16:42 -0400 gcl (2.5.0.cvs20020625-18) unstable; urgency=high * misc. lintian cleanups, mostly for 64 bit -- Camm Maguire Tue, 23 Jul 2002 23:35:03 -0400 gcl (2.5.0.cvs20020625-17) unstable; urgency=high * Fixed typeo in error.c preventing arm compilation -- Camm Maguire Mon, 22 Jul 2002 17:18:18 -0400 gcl (2.5.0.cvs20020625-16) unstable; urgency=high * Fix bad on_stack_list_vector args -- Camm Maguire Mon, 22 Jul 2002 16:10:16 -0400 gcl (2.5.0.cvs20020625-15) unstable; urgency=high * More lint changes for sundry arches * Fixed bug in Iapply_ap -- Camm Maguire Sat, 20 Jul 2002 23:40:33 -0400 gcl (2.5.0.cvs20020625-14) unstable; urgency=high * include stdarg.h when defining _GNU_SOURCE -- Camm Maguire Sat, 20 Jul 2002 18:47:43 -0400 gcl (2.5.0.cvs20020625-13) unstable; urgency=high * Proper va_dcl declarations -- Camm Maguire Sat, 20 Jul 2002 10:40:02 -0400 gcl (2.5.0.cvs20020625-12) unstable; urgency=high * cvs updates for missing ptrdiff_t -- Camm Maguire Sat, 20 Jul 2002 08:41:37 -0400 gcl (2.5.0.cvs20020625-11) unstable; urgency=high * cvs changes to compile cleanly with -Wall -- Camm Maguire Sat, 20 Jul 2002 02:59:33 -0400 gcl (2.5.0.cvs20020625-10) unstable; urgency=high * Architecture any, though still have some issues -- Camm Maguire Fri, 12 Jul 2002 19:02:09 -0400 gcl (2.5.0.cvs20020625-9) unstable; urgency=high * cvs commits for 64bit support -- Camm Maguire Fri, 12 Jul 2002 18:01:21 -0400 gcl (2.5.0.cvs20020625-8) unstable; urgency=high * NULL_OR_ON_C_STACK macro correction for m68k -- Camm Maguire Fri, 12 Jul 2002 14:37:48 -0400 gcl (2.5.0.cvs20020625-7) unstable; urgency=high * arm is bigendian -- Camm Maguire Wed, 10 Jul 2002 18:04:22 -0400 gcl (2.5.0.cvs20020625-6) unstable; urgency=high * cvs updates for arm build -- Camm Maguire Tue, 9 Jul 2002 16:09:26 -0400 gcl (2.5.0.cvs20020625-5) unstable; urgency=high * CC environment variable setting in debian/rules to aid in porting * gcc 2.95 for m68k -- Camm Maguire Sat, 6 Jul 2002 23:00:23 -0400 gcl (2.5.0.cvs20020625-4) unstable; urgency=high * gcc 3.0 for arm * cachectl header for m68k -- Camm Maguire Mon, 1 Jul 2002 15:47:53 -0400 gcl (2.5.0.cvs20020625-3) unstable; urgency=high * Better libbfd detection for arm/alpha -- Camm Maguire Wed, 26 Jun 2002 17:27:21 -0400 gcl (2.5.0.cvs20020625-2) unstable; urgency=high * s390 support -- Camm Maguire Tue, 25 Jun 2002 21:25:35 -0400 gcl (2.5.0.cvs20020625-1) unstable; urgency=high * CVS updates, new s390 arch -- Camm Maguire Tue, 25 Jun 2002 19:26:36 -0400 gcl (2.5.0.cvs20020610-2) unstable; urgency=high * cvs updates -- Camm Maguire Thu, 13 Jun 2002 08:42:32 -0400 gcl (2.5.0.cvs20020610-1) unstable; urgency=high * cvs updates -- Camm Maguire Wed, 12 Jun 2002 23:04:57 -0400 gcl (2.5.0.cvs20020523-2) unstable; urgency=high * configure updates for better tk detection -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 gcl (2.5.0.cvs20020523-1) unstable; urgency=high * New upstream release -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 gcl (2.5.0.cvs20020429-1) unstable; urgency=high * Build-Depend on tk8.2-dev, Closes: #144330 * New cvs updates * Added sparc to arch list, Closes: #143465 -- Camm Maguire Mon, 29 Apr 2002 23:07:36 -0400 gcl (2.5.0.cvs20020219-2) unstable; urgency=medium * flavor ->debian-emacs-flavor in emacsen-startup -- Camm Maguire Mon, 4 Mar 2002 14:29:59 -0500 gcl (2.5.0.cvs20020219-1) unstable; urgency=medium * Updated package descriptions, Closes: #134402 * Static linking of libbfd, Closes: #134647 * Gcl currently only available on i386, arm and m68k as specified in the Architecture control field, Closes: #133912 -- Camm Maguire Tue, 19 Feb 2002 12:04:29 -0500 gcl (2.5.0.cvs-3) unstable; urgency=medium * Build-depend on texi2html, Closes: #133699 -- Camm Maguire Wed, 13 Feb 2002 16:22:35 -0500 gcl (2.5.0.cvs-2) unstable; urgency=medium * Put in versioned dependency on binutils for libbfd support, rebuilt with latest binutils, Closes: #133004 -- Camm Maguire Tue, 12 Feb 2002 13:19:12 -0500 gcl (2.5.0.cvs-1) unstable; urgency=medium * Latest patches from CVS, enabling libbfd relocations, among other things * /etc/emacs/site-start.d/50gcl.el as conffile, Closes: #132137 * limited arm and m68k support -- Camm Maguire Mon, 4 Feb 2002 09:32:29 -0500 gcl (2.5.0-1) unstable; urgency=medium * New maintainer * New upstream release * New release so far builds only on i386, Closes: #116070, Closes: #123371 * New release so far builds only on i386, Closes: #115041 * Gcl must currently use its own copy of gmp, as the upstream version of gmp uses malloc, which interferes with gcl's garbage collection and relocation scheme. The change from malloc to alloca has been suggested to upstream gmp developers. Closes: #108910 * Tcl/Tk support now in. Closes: #113197 -- Camm Maguire Fri, 21 Dec 2001 00:03:43 -0500 gcl (2.4.0-3) unstable; urgency=medium * Make gcl use libgmp3 package. (closes: #108910) * Remove tk support. (closes: #108909) * Fix stupid missing dependency line. (closes: #108907, #108908) * Removed readme.mingw from the debian package, this package is not compiled under mingw (windows gcc port). * Close ITA bug. (closes: #112312) -- Baruch Even Sat, 22 Sep 2001 00:27:14 +0300 gcl (2.4.0-2) unstable; urgency=low * Change tclsh Build-Depends to tcl8.0 because apt is broken. (closes: #99261) -- JP Sugarbroad Wed, 30 May 2001 14:34:53 -0500 gcl (2.4.0-1) unstable; urgency=low * New upstream release -- JP Sugarbroad Sun, 13 May 2001 20:31:01 -0500 gcl (2.3.7+beta3-3) unstable; urgency=low * Move gcl-doc to section doc (closes: #78666) -- JP Sugarbroad Sun, 13 May 2001 20:26:28 -0500 gcl (2.3.7+beta3-2) unstable; urgency=low * Remove alpha from arch list * Move tcl/tk from Depends to Suggests -- JP Sugarbroad Fri, 4 May 2001 16:24:11 -0500 gcl (2.3.7+beta3-1) unstable; urgency=low * New maintainer * Repackaged with debhelper (closes: #42045, #86097, #91475, #91478) * New upstream release (closes: #59577, #71096) * Added sparc+alpha, removed m68k (closes: #87407) -- JP Sugarbroad Mon, 30 Apr 2001 19:07:49 -0500 gcl (2.2.1-6) unstable; urgency=low * Disable stripping of "saved_gcl" binary. (#45778) -- Steve Dunham Fri, 24 Sep 1999 14:39:15 -0400 gcl (2.2.1-5) unstable; urgency=low * Fix m68k build -- Steve Dunham Tue, 6 Jul 1999 09:45:09 -0400 gcl (2.2.1-4) unstable; urgency=low * Fix bug #31718 -- Steve Dunham Fri, 2 Jul 1999 11:11:12 -0400 gcl (2.2.1-3) unstable; urgency=low * Add m68k patches -- Steve Dunham Wed, 16 Dec 1998 14:25:46 -0500 gcl (2.2.1-2) unstable; urgency=low * Compile against libc6. New maintainer. -- Steve Dunham Wed, 5 Nov 1997 10:09:12 -0500 gcl (2.2.1-1) unstable; urgency=low * New upstream release; suggests tcl76, tk42. * gcl-doc contains gcl-si and gcl-tk info pages. * debian/rules: clean target removes temporary files from h and o subdirectories (bug #5984). -- Karl Sackett Fri, 3 Jan 1997 10:16:40 -0600 gcl (2.2-5) unstable; urgency=low * Converted package to 2.1.1.0 standard. * Stripped gcltkaux (bug #5074). * gcl-si and gcl-tk info pages converted to HTML. -- Karl Sackett Tue, 5 Nov 1996 13:30:30 -0600 2.2-4 * add-defs: patched locates for tk.tcl, init.tcl * gcl-tk/tkAppInit.c: patched for tk4.1 support * gcl-tk/tkMain.c: patched for tk4.1 support 2.2-3 * Debian support files now partily architecture independent. There are, however, no add-defs files except for 386-linux. * Rebuilt package to correct corrupted upload problem. 2.2-2 * Removed tk support from distribution. This was written to use tk-3.6 and doesn't support tk-4.0 or tk-4.1. I am not aware of any plans to upgrade the code. (Closes bug #2865) 2.2-1 * Added Debian support files * h/386-linux.defs: set OFLAG = -O2 * h/386-linux.h: undid patch that swaped signal.h for sigcontext.h gcl-2.6.14/debian/copyright0000644000175000017500000000550714360276512014157 0ustar cammcammThis package was debianized by JP Sugarbroad on Mon, 30 Apr 2001 19:07:49 -0500. It was downloaded from http://savannah.gnu.org/projects/gcl Upstream Author: Bill Schelter Copyright: This package is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this package; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. On Debian GNU/Linux systems, the complete text of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL-2'. The source under xgcl-2 is Copyright (c) 1995 Gordon S. Novak Jr., Hiep Huu Nguyen, William F. Schelter, and The University of Texas at Austin. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. and ;;********************************************************** ;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, ;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. ;; All Rights Reserved ;;Permission to use, copy, modify, and distribute this software and its ;;documentation for any purpose and without fee is hereby granted, ;;provided that the above copyright notice appear in all copies and that ;;both that copyright notice and this permission notice appear in ;;supporting documentation, and that the names of Digital or MIT not be ;;used in advertising or publicity pertaining to distribution of the ;;software without specific, written prior permission. ;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL ;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, ;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS ;;SOFTWARE. ;;***************************************************************** On Debian GNU/Linux systems, the complete text of the GNU General Public License can be found in `/usr/share/common-licenses/GPL-1'. gcl-2.6.14/debian/in.gcl.emacsen-install0000644000175000017500000000232714360276512016374 0ustar cammcamm#! /bin/sh -e # /usr/lib/emacsen-common/packages/install/#PACKAGE# # Written by Jim Van Zandt , borrowing heavily # from the install scripts for gettext by Santiago Vila # and octave by Dirk Eddelbuettel . FLAVOR=$1 PACKAGE=gcl@EXT@ if [ ${FLAVOR} = emacs ]; then exit 0; fi echo install/${PACKAGE}: Handling install for emacsen flavor ${FLAVOR} #FLAVORTEST=`echo $FLAVOR | cut -c-6` #if [ ${FLAVORTEST} = xemacs ] ; then # SITEFLAG="-no-site-file" #else # SITEFLAG="--no-site-file" #fi FLAGS="${SITEFLAG} -q -batch -l path.el -f batch-byte-compile" ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} # Install-info-altdir does not actually exist. # Maybe somebody will write it. if test -x /usr/sbin/install-info-altdir; then echo install/${PACKAGE}: install Info links for ${FLAVOR} install-info-altdir --quiet --section "" "" --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz fi install -m 755 -d ${ELCDIR} cd ${ELDIR} FILES=`echo *.el` cp ${FILES} ${ELCDIR} cd ${ELCDIR} cat << EOF > path.el (setq load-path (cons "." load-path) byte-compile-warnings nil) EOF ${FLAVOR} ${FLAGS} ${FILES} rm -f *.el path.el exit 0 gcl-2.6.14/debian/in.gcl.postrm0000644000175000017500000000062414360276512014637 0ustar cammcamm#!/bin/sh set -e case "$1" in purge) for ext in '~' '%' .bak .ucf-new .ucf-old .ucf-dist; do rm -f /etc/default/gcl@EXT@$ext done rm -f /etc/default/gcl@EXT@ if which ucf >/dev/null; then ucf --purge /etc/default/gcl@EXT@ fi if which ucfr >/dev/null; then ucfr --purge gcl@EXT@ /etc/default/gcl@EXT@ fi ;; esac #DEBHELPER# gcl-2.6.14/debian/in.gcl.docs0000644000175000017500000000005314360276512014237 0ustar cammcammansi-tests/test_results RELEASE-2.6.2.html gcl-2.6.14/debian/in.gcl.postinst0000644000175000017500000000143414360276512015176 0ustar cammcamm#!/bin/sh case "$1" in configure) # CONFIGFILE=$(tempfile -m 644) CONFIGFILE=$(mktemp) chmod 644 $CONFIGFILE set -e . /usr/share/debconf/confmodule if [ "$1" = "configure" ] || [ "$1" = "reconfigure" ] ; then db_get gcl@EXT@/default_gcl_ansi if [ "$RET" = "true" ] ; then DEFAULT_GCL_ANSI=t else DEFAULT_GCL_ANSI= fi db_get gcl@EXT@/default_gcl_prof if [ "$RET" = "true" ] ; then DEFAULT_GCL_PROF=y else DEFAULT_GCL_PROF= fi echo "DEFAULT_GCL_ANSI=$DEFAULT_GCL_ANSI" >> $CONFIGFILE echo "DEFAULT_GCL_PROF=$DEFAULT_GCL_PROF" >> $CONFIGFILE fi ucf --debconf-ok $CONFIGFILE /etc/default/gcl@EXT@ ucfr gcl@EXT@ /etc/default/gcl@EXT@ # chmod 644 /etc/default/gcl@EXT@ esac #DEBHELPER# gcl-2.6.14/debian/README.Debian0000644000175000017500000000230614360276512014257 0ustar cammcammThe Debian package gcl ---------------------- GCL is one of the oldest free common lisp systems still in use. Several production systems have used it for over a decade. The common lisp standard in effect when GCL was first released is known as "Common Lisp, the Language" (CLtL1) after a book by Steele of the same name providing this specification. Subsequently, a much expanded standard was adopted by the American National Standards Institute (ANSI), which is still considered the definitive common lisp language specification to this day. Debian GCL now installs both the small 'traditional' lisp image designed to conform to a pre-ANSI Lisp standard, and an experimental ANSI image. Please note that ANSI support in GCL is still preliminary. On an ansi-test suite written by a GCL developer, GCL fails on a little under 3 percent of the tests. Details can be found in /usr/share/doc/gcl/test_results.gz. To toggle the use of the ANSI image, set the environment variable GCL_ANSI to any non-empty string. New in 2.6.2 ------------ Please see the RELEASE-2.6.2.html file for release note information, regression testing, and sample benchmarks. -- Camm Maguire , Wed Dec 14 18:55:19 2005 gcl-2.6.14/debian/gcl.sh0000755000175000017500000000116414360276512013323 0ustar cammcamm#!/bin/sh EXT=@EXT@ VERS=@VERS@ . /etc/default/gcl$EXT if ! set | grep -q -w GCL_ANSI ; then GCL_ANSI=$DEFAULT_GCL_ANSI ; fi if ! set | grep -q -w GCL_PROF ; then GCL_PROF=$DEFAULT_GCL_PROF ; fi if [ "$GCL_PROF" = "" ] ; then DIR=/usr/lib/gcl-$VERS ; else DIR=/usr/lib/gcl-$VERS-prof ; fi if [ "$GCL_ANSI" = "" ] ; then EXE=saved_gcl; else EXE=saved_ansi_gcl; fi SYS=$DIR/unixport exec $SYS/$EXE -dir $SYS/ -libdir $DIR/ \ -eval '(setq si::*allow-gzipped-file* t)' \ -eval '(setq si::*tk-library* "/usr/lib/tk@TKVERS@")' \ "$@" # other options: -load /tmp/foo.o -load jo.lsp -eval "(joe 3)" gcl-2.6.14/misc/0000755000175000017500000000000014360276512011726 5ustar cammcammgcl-2.6.14/misc/check.c0000755000175000017500000000212414360276512013151 0ustar cammcamm#include "include.h" #define CHECK(a,b)\ do{ i++; if (((void *) a) != (void *) b) printf("differed %d %d\n",i, (long ) a - (long) b);}while(0) main() {object x; int i=0; /* 1 2 */ CHECK(&x->s.s_sfdef,&x->c.c_car); CHECK(&x->s.s_dbind,&x->c.c_cdr); /* 3 4 5 6 */ CHECK(&x->s.s_fillp,&x->ust.ust_fillp); CHECK(&x->v.v_fillp,&x->ust.ust_fillp); CHECK(&x->st.st_fillp,&x->ust.ust_fillp); CHECK(&x->bv.bv_fillp,&x->ust.ust_fillp); /* 7 8 9 10 11 12 */ CHECK(&x->st.st_dim,&x->ust.ust_dim); CHECK(&x->v.v_dim,&x->ust.ust_dim); CHECK(&x->bv.bv_dim,&x->ust.ust_dim); CHECK(&x->a.a_dim,&x->ust.ust_dim); CHECK(&x->lfa.lfa_dim,&x->ust.ust_dim); CHECK(&x->sfa.sfa_dim,&x->ust.ust_dim); CHECK(&x->fixa.fixa_dim,&x->ust.ust_dim); CHECK(&x->st.st_self,&x->ust.ust_self); CHECK(&x->v.v_self,&x->ust.ust_self); CHECK(&x->bv.bv_self,&x->ust.ust_self); CHECK(&x->a.a_self,&x->ust.ust_self); CHECK(&x->lfa.lfa_self,&x->ust.ust_self); CHECK(&x->sfa.sfa_self,&x->ust.ust_self); CHECK(&x->fixa.fixa_self,&x->ust.ust_self); CHECK(&x->s.s_self,&x->ust.ust_self); CHECK(&x->v.v_elttype,&x->a.a_elttype); } gcl-2.6.14/misc/test-sgc.lsp0000755000175000017500000000262314360276512014205 0ustar cammcamm(in-package 'si) (or (fboundp 'get-usage) (load "/public/gcl/misc/rusage")) (gbc-time 0) (defun cv (x) (/ x (float INTERNAL-TIME-UNITS-PER-SECOND))) (defvar *all-times* nil) (defmacro with-timing (&rest forms) `(let ((usg0 (get-usage t nil)) (t1 (gbc-time)) (t2 (get-internal-run-time)) (t3 (get-internal-real-time))) (prog1 ,@forms (setq t1 (- (gbc-time ) t1)) (setq t2 (- (get-internal-run-time) t2)) (setq t3 (- (get-internal-real-time) t3)) (let ((usg (get-usage t nil))) (let ((ans (format nil "Run= ~3,2f Elap= ~3,2f Gc= ~3,2f Fault= ~3d" (cv t2) (cv t3) (cv t1) (- (|rusage|-|ru_majflt| usg) (|rusage|-|ru_majflt| usg0))))) (push (list ',(car forms) ans ) *all-times*) (print ans)))))) (setq si::*notify-gbc* t) (allocate 'cons 520 t) (allocate 'fixnum 40) (si::sgc-on nil) (si::allocate-sgc 'symbol 20 30 30) (si::allocate-sgc 'cons 50 3000 40) (si::allocate-sgc 'vector 1 10 30) (si::allocate-sgc 'string 1 10 30) (gbc nil) (si::sgc-on t) (print (in-package "MAXIMA")) (setq $joe #$expand((x+y+z)^20)$) (defun test (form) (gbc nil) (eval form) (push (list form 'cons-pages (si::allocated-pages 'cons)) si::*all-times*) (gbc nil) (si::with-timing (sloop for i below 3 do (displa ($factor $joe)))) ) (test '(si::sgc-on nil)) (test '(si::sgc-on t)) (test '(si::sgc-on nil)) (test '(si::sgc-on t)) (print si::*all-times*) gcl-2.6.14/misc/rusage.lsp0000755000175000017500000000272314360276512013743 0ustar cammcamm;; sun release 4 getrusage interface. (constructed using structs.lsp) (in-package 'si) (DEFSTRUCT (|rusage| (:static t)) (|ru_utime.tv_sec| 0 :TYPE FIXNUM) (|ru_utime.tv_usec| 0 :TYPE FIXNUM) (|ru_stime.tv_sec| 0 :TYPE FIXNUM) (|ru_stime.tv_usec| 0 :TYPE FIXNUM) (|ru_maxrss| 0 :TYPE FIXNUM) (|ru_ixrss| 0 :TYPE FIXNUM) (|ru_idrss| 0 :TYPE FIXNUM) (|ru_isrss| 0 :TYPE FIXNUM) (|ru_minflt| 0 :TYPE FIXNUM) (|ru_majflt| 0 :TYPE FIXNUM) (|ru_nswap| 0 :TYPE FIXNUM) (|ru_inblock| 0 :TYPE FIXNUM) (|ru_oublock| 0 :TYPE FIXNUM) (|ru_msgsnd| 0 :TYPE FIXNUM) (|ru_msgrcv| 0 :TYPE FIXNUM) (|ru_nsignals| 0 :TYPE FIXNUM) (|ru_nvcsw| 0 :TYPE FIXNUM) (|ru_nivcsw| 0 :TYPE FIXNUM)) (clines "static mygetrusage(x,y) int x; object y;{return getrusage(x,y->str.str_self);}") (defentry GETRUSAGE1 (int object) (int "mygetrusage")) (defun get-usage (self usage) (or (typep usage '|rusage|) (setq usage (make-|rusage|))) (getrusage1 (if self 0 -1) usage) usage) (defmacro with-change-displayed (form) `(let ((.beg (get-usage t nil))) (prog1 ,form (let ((.end (get-usage t nil))) (let ((sd (s-data-slot-descriptions (get '|rusage| 's-data)))) (sloop for i from 0 for v in(s-data-slot-descriptions (get '|rusage| 's-data)) for dif = (- (structure-ref1 .end i ) (structure-ref1 .beg i ) ) when (not (zerop dif)) do(print (list (car v) dif)))))))) gcl-2.6.14/misc/warn-slow.lsp0000755000175000017500000000253214360276512014404 0ustar cammcamm;; Warn of some slow calls. (in-package 'compiler) ;; slow if the result type is type T (dolist (v '(+ * / mod - float 1- 1+)) (setf (get v 'slow-test) #'(lambda (name x) (or (null x) (eql (cadar x) t))))) ;; slow if the first arg is type T (dolist (v '(aref si::aset < <= > >=)) (setf (get v 'slow-test) #'(lambda (name x) (or (null x) (eql (caar x) t))))) (dolist (v '(typep)) (setf (get v 'slow-test) #'(lambda (name x) (null x)))) ;; turn the compiler expressions back into something vaguely ;; readable. (defun lispify (x) (let ((tem (car x))) (cond ((equal tem 'var) (var-name (car (third x)))) ((eq tem 'call-global) (cons (third x) (mapcar 'lispify (fourth x)))) ((eq tem 'fixnum-value) (third x)) ((eq tem 'location) (lispify (third x))) (t x)))) (eval-when (load eval) (trace (get-inline-info :entry nil :entrycond nil :exitcond (and (not (equal (car values) nil)) (let ((s (get (car si::arglist) 'slow-test))) (and s (funcall s (car si::arglist) (car values)))) (progn (cmpwarn "Slow code: ~a: " (cons (car si::arglist) (mapcar 'lispify (second si::arglist)))) (format t " ~a --> ~a~%" (mapcar #'(lambda (form) (info-type (cadr form))) (second si::arglist)) (third si::arglist))) nil))) ) gcl-2.6.14/misc/mprotect.ch0000755000175000017500000001001214360276512014074 0ustar cammcammIn this file are all changes necessary to implement the 4.3BSD system call mprotect, and the changes to make sigreturn pass back the address where a fault occurred as the `code' arg. Note that sun passes the address as a 4'th arg. This might be preferable, but would involve changes to locore.s. This has been tested on an hp370 running 4.3 BSD from MT Xinu. A man page entry for the call as implemented below. Inserting file /usr/man/man2/mprotect.2 ---Begin File /usr/man/man2/mprotect.2--- .\" @(#)mprotect.2 .TH MPROTECT 2 "9 December 1989" .SH NAME mprotect \- specify protection of data section memory .SH SYNOPSIS .nf .ft B #include .ft .LP .ft B mprotect(addr, len, prot) caddr_t addr; int len, prot; .ft .fi .IX mprotect "" \fLmprotect\fP .IX "memory management" mprotect "" \fLmprotect\fP .IX "change protections \(em \fLmprotect\fP" .SH DESCRIPTION .LP .B mprotect(\|) changes the access protections on the mappings specified by the range [\fIaddr, addr + len\fP\^) to be that specified by .IR prot . Legitimate values for .I prot are PROT_READ and (PROT_WRITE | PROT_READ). .SH RETURN VALUE .LP .B mprotect(\|) returns 0 on success, \-1 on failure. .SH ERRORS .B mprotect(\|) will fail if: .TP 15 .SM EINVAL .I addr is not a multiple of the page size as returned by .BR getpagesize (2). .TP .SM ENOMEM Addresses in the range [\fIaddr, addr + len\fP) are not in the data section of a process. .LP .SH SEE ALSO .BR getpagesize (2), ---End File /usr/man/man2/mprotect.2--- You need to compile the following and add it to /lib/libc.a Inserting file /usr/src/lib/libc/hp300/sys/mprotect.c ---Begin File /usr/src/lib/libc/hp300/sys/mprotect.c--- #ifdef SYSLIBC_SCCS _sccsid:.asciz "@(#)mprotect.c" #endif SYSLIBC_SCCS #include "SYS.h" SYSCALL(mprotect) rts ---End File /usr/src/lib/libc/hp300/sys/mprotect.c--- *** hp300/machdep.c.orig Tue Aug 29 13:09:56 1989 --- hp300/machdep.c Mon Dec 11 17:07:18 1989 *************** *** 560,566 **** #endif sigf.sf_signum = sig; sigf.sf_code = 0; ! if (sig == SIGILL || sig == SIGFPE) { sigf.sf_code = u.u_code; u.u_code = 0; } --- 560,566 ---- #endif sigf.sf_signum = sig; sigf.sf_code = 0; ! if (sig == SIGILL || sig == SIGFPE || sig == SIGBUS) { sigf.sf_code = u.u_code; u.u_code = 0; } *** sys/kern_mman.c.orig Tue Aug 29 13:16:29 1989 --- sys/kern_mman.c Thu Dec 14 10:07:39 1989 *************** *** 249,257 **** u.u_pofile[fd] &= ~UF_MAPPED; } mprotect() ! { } madvise() --- 249,296 ---- u.u_pofile[fd] &= ~UF_MAPPED; } + mprotect() ! { struct a { ! caddr_t addr; ! int len; ! int prot; ! } *uap = (struct a *)u.u_ap; ! int fv,off; ! int tprot; ! register struct pte *pte; ! struct cmap *c; ! int s; + u.u_r.r_val1 = -1; + + if ((uap->len < 0 || + (int)uap->addr & CLOFSET)) { + u.u_error = EINVAL; + return; + } + + + if ((uap->prot & PROT_WRITE) == 0) + tprot= PG_RO; + else tprot=PG_RW; + /* check the pages are in data section */ + if (!(isadsv(u.u_procp, btoc(uap->addr)) + &&isadsv(u.u_procp ,btoc(uap->addr+uap->len) -1))) + { u.u_error = ENOMEM; + return;} + + + fv = btop(uap->addr); + pte = vtopte(u.u_procp, fv); + for (off = 0; off < uap->len; off += NBPG) { + + *(u_int *)pte &= ~PG_PROT; + *(u_int *)pte |= tprot; + pte++;} + + newptes(vtopte(u.u_procp, fv), fv, btoc(uap->len)); + u.u_r.r_val1 = 0; } madvise() *** hp300/trap.c.orig Tue Aug 29 13:09:59 1989 --- hp300/trap.c Mon Dec 11 17:48:59 1989 *************** *** 112,117 **** --- 112,118 ---- case T_BUSERR+USER: /* bus error */ case T_ADDRERR+USER: /* address error */ + u.u_code=v; i = SIGBUS; break; *************** *** 293,298 **** --- 294,300 ---- printf("PTF|WPF...\n"); if (type == T_MMUFLT) goto copyfault; + u.u_code=v; i = SIGBUS; break; } *************** *** 346,351 **** --- 348,354 ---- #endif if (type == T_MMUFLT) goto copyfault; + u.u_code=v; i = SIGBUS; break; } gcl-2.6.14/misc/cstruct.lsp0000755000175000017500000001161114360276512014140 0ustar cammcamm;; Sample usage: Create lisp defstructs corresponding to C structures: (use-package "SLOOP") ;; How to: Create a file foo.c which contains just structures ;; and possibly some externs. ;; cc -E /tmp/foo1.c > /tmp/fo2.c ;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c ;; then (parse-file "/tmp/fo3.c") ;; will return a list of defstructs and appropriate slot offsets. (defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline #\tab))) (defvar *eof* (code-char 255)) (defun delimiter(ch) (or (white-space ch) (member ch '(#\, #\; #\{ #\} #\*)))) (defun next-char (st) (let ((char (read-char st nil *eof*))) (case char (#\{ char) ( #\/ (cond ((eql (peek-char nil st nil) #\*) (read-char st) (sloop when (eql (read-char st) #\*) do (cond ((eql (read-char st) #\/ ) (return-from next-char (next-char st)))))) (t char))) ((#\tab #\linefeed #\return #\newline ) (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline )) (return-from next-char (next-char st)))) #\space) (t char)))) (defun get-token (st &aux tem) (sloop while (white-space (peek-char nil st nil)) do (read-char st)) (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} )) (return-from get-token (coerce (list (next-char st)) 'string)))) (sloop with x = (make-array 10 :element-type 'character :fill-pointer 0 :adjustable t) when (delimiter (setq tem (next-char st))) do (cond ((> (length x) 0) (or (white-space tem) (unread-char tem st)) (return x))) else do (cond ((eql tem *eof*) (return *eof*)) (t (vector-push-extend tem x))))) (defvar *parse-list* nil) (defvar *structs* nil) (defun parse-file (fi &optional *structs*) (with-open-file (st fi) (let ((*parse-list* (sloop while (not (eql *eof* (setq tem (get-token st)))) collect (intern tem)))) (print *parse-list*) (let ((structs (sloop while (setq tem (parse-struct)) do (push tem *structs*) collect tem))) (get-sizes fi structs) (with-open-file (st "gaz3.lsp") (prog1 (list structs (read st)) (delete-file "gaz3.lsp"))))))) (defparameter *type-alist* '((|short| . signed-short) (|unsigned short| . unsigned-short) (|char| . signed-char) (|unsigned char| . unsigned-char) (|int| . fixnum) (|long| . fixnum) (|object| . t))) (defun parse-type( &aux top) (setq top (pop *parse-list*)) (cond ((member top '(|unsigned| |signed|)) (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*) (parse-type)) ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum) ((eq top '|struct|) (prog1 (cond ((car (member (car *parse-list*) *STRUCTS* :key 'cadr))) (t (error "unknown struct ~a " (car *parse-list*)))) (pop *parse-list*) )) ((cdr (assoc top *type-alist*))) (t (error "unknown type ~a " top)))) (defun expect (x) (or (eql (car *parse-list*) x) (error "expected ~a at beginning of ~s" x *parse-list*)) (pop *parse-list*)) (defun parse-field ( &aux tem) (cond ((eql (car *parse-list*) '|}|) (pop *parse-list*) (expect '|;|) nil) (t (let ((type (parse-type))) (sloop until (eql (setq tem (pop *parse-list*)) '|;|) append (get-field tem type) do (or (eq (car *parse-list*) '|;|) (expect '|,|))))))) (deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum)) (defun get-field (name type) (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer)) ((and (consp type) (eq (car type) 'defstruct)) (sloop for w in (cddr type) append (get-field (intern (format nil "~a.~a" name (car w))) (fourth w)))) (t `((,name ,(if (eq type t) nil 0) :type ,type))))) (defun parse-struct () (cond ((null *parse-list*) (return-from parse-struct nil))) (cond ((not (eq (car *parse-list*) '|struct|)) (sloop until (eq (pop *parse-list*) '|;|)) (return-from parse-struct (parse-struct)))) (expect '|struct|) (let* ((name (prog1 (pop *parse-list*)(expect '|{|)))) `(defstruct ,name ,@ (sloop while (setq tem (parse-field)) append tem)))) (defun printf (st x &rest y) (format st "~%printf(\"~a\"" x) (sloop for w in y do (princ "," st) (princ y st)) (princ ");" st)) (defun get-sizes (file structs) (with-open-file (st "gaz0" :direction :output) (sloop for i from 1 for u in structs do (format st "struct ~a SSS~a;~%" (second u) i)) (format st "~%main() {~%") (printf st "(") (sloop for i from 1 for u in structs do (printf st (format nil "(|~a| " (second u))) (sloop for w in (cddr u) do (printf st " %d " (format nil "(char *)&SSS~a.~a - (char *)&SSS~a" i (car w) i))) (printf st ")")) (printf st ")") (princ " ;}" st)) (system (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (tmpx > gaz3.lsp) ; rm -f gaz0" file))) gcl-2.6.14/misc/test-seek.c0000755000175000017500000000140614360276512014002 0ustar cammcamm#include #include "include.h" #ifdef HAVE_AOUT #include HAVE_AOUT #endif #ifdef HAVE_ELF #include #endif #define OUR_MAX(a,b) (a > b ? a : b) #define SEEK_TO_END_OFILE(fp)\ do{ int m; \ Elf32_Ehdr eheader; \ Elf32_Shdr shdr; \ fseek(fp,0,SEEK_SET); \ fread(&eheader,sizeof(eheader),1,fp); \ fseek(fp,eheader.e_shoff+(eheader.e_shnum -1) \ *eheader.e_shentsize,0); \ fread(&shdr,eheader.e_shentsize,1,fp); \ fseek(fp,OUR_MAX(shdr.sh_offset+ shdr.sh_size, \ eheader.e_shoff+(eheader.e_shnum) \ *eheader.e_shentsize) \ , SEEK_SET);\ }while(0) main(argc,argv) char *argv[]; { FILE *fp; fp = fopen (argv[1],"r"); SEEK_TO_END_OFILE(fp); printf("end = %d\n",ftell(fp)); } gcl-2.6.14/misc/foreign.lsp0000755000175000017500000001011614360276512014101 0ustar cammcamm;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -*- Mode: Lisp; -*- ;;; File: foreign-interface.lisp ;;; Author: Paul Viola (viola@ai.mit.edu) ;;; Copyright (C) Paul Viola, 1993 ;;;*---------------------------------------------------------------------------- ;;;* FUNCTION: Code to support foreign function call interface in GCL. ;;;* ;;;* CLASSES: ;;;* ;;;* RELATED PACKAGES: ;;;* ;;;* HISTORY: ;;;* Last edited: May 7 17:55 1993 (viola) ;;;* Created: Thu May 6 11:36:49 1993 (viola) ;;;*---------------------------------------------------------------------------- (in-package "USER") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code that makes some lucid foreign function definitions work in GCL. (defparameter *lucid-to-gcl-c-types* '((:signed-32bit int) (:unsigned-32bit int) ;I hope this is right. (:double-float double) (:single-float float) (:simple-string string) ((:pointer :signed-32bit) vector-int) ((:pointer :single-float) vector-single-float) ((:pointer :double-float) vector-double-float) (:null void))) (defmacro def-foreign-function ((lisp-name . key-params) . c-params) "I wrote this so that lucid calls to foreign functions could be used directly in GCL. " (progn (print lisp-name) `(defentry-2 ,lisp-name ,(loop for param in c-params collect (cadr (assoc (cadr param) *lucid-to-gcl-c-types* :test #'equal))) ,(list (cadr (assoc (lucid-return-type key-params) *lucid-to-gcl-c-types* :test #'equal)) (lucid-c-name key-params))))) (defun lucid-return-type (key-params) (cadar (member :return-type key-params :key #'car))) (defun lucid-c-name (key-params) (intern (string-upcase (subseq (cadar (member :name key-params :key #'car)) 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Using lisp strings in C is a pain. First they need to be NULL terminated ;;; then they need to be converted into a C object. The code below returns a ;;; C-string from a lisp routine. This is pretty dangerous - I don't know what ;;; would happen if you tried to operate on it. ;;; For an array of ints. (defCfun "object get_c_ints(s) object s;" 0 " return(s->fixa.fixa_self);" ) (defentry get-c-ints (object) (object get_c_ints)) ;;; For an array of single-floats. (defCfun "object get_c_single_floats(s) object s;" 0 " return(s->sfa.sfa_self);" ) (defentry get-c-single-floats (object) (object get_c_single_floats)) ;;; For an array of double-floats. (defCfun "object get_c_double_floats(s) object s;" 0 " return(s->lfa.lfa_self);" ) (defentry get-c-double-floats (object) (object get_c_double_floats)) ;;; For a string. (defCfun "object get_c_string(s) object s;" 0 " return(s->st.st_self);" ) (defentry get_c_string_2 (object) (object get_c_string)) ;; make sure string is null terminated (defun get-c-string (string) (get_c_string_2 (concatenate 'string string " (defparameter *gcl-to-c-types* '((int int nil) (char char nil) (float float nil) (double double nil) (object object nil) (string object get-c-string) (vector-int object get-c-ints) (vector-single-float object get-c-single-floats) (vector-double-float object get-c-double-floats))) (defmacro defentry-2 (func-name param-types declaration) "Macro enhances defentry so that composite types can be passed to C functions. For a list of types look at *gcl-to-c-types*" (let ((f-name (intern (concatenate 'string (symbol-name func-name) "-2"))) (new-types (mapcar #'(lambda (a) (cadr (assoc a *gcl-to-c-types*))) param-types)) (param-list (mapcar #'(lambda (a) (gensym)) param-types))) `(progn (defentry ,f-name ,new-types ,declaration) (defmacro ,func-name ,param-list (list ',f-name ,@(loop for p in param-list for type in param-types for (ntype new-type converter-func) = (assoc type *gcl-to-c-types*) collect (if (null converter-func) p `(list ',converter-func ,p)))))))) gcl-2.6.14/misc/check_obj.c0000755000175000017500000000052114360276512014002 0ustar cammcamm #include "include.h" #define CHECK(a,b) \ do{ i++; if ((void *) a != (void *) b) printf("differed %d\n",i);}while(0) main() {object x; int i=0; CHECK(&x->s.s_self,&x->ust.ust_self); CHECK(&x->s.s_fillp,&x->ust.ust_fillp); CHECK(&x->v.v_fillp,&x->ust.ust_fillp); CHECK(&x->v.v_dim,&x->ust.ust_dim); CHECK(&x->cfn.,&x->ust.ust_dim); } gcl-2.6.14/pcl/0000755000175000017500000000000014360276512011551 5ustar cammcammgcl-2.6.14/pcl/gcl_pcl_fsc.lisp0000644000175000017500000000667114360276512014712 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS ;;; metaclass. Much of the implementation of this metaclass is actually ;;; defined on the class STD-CLASS. What appears in this file is a modest ;;; number of simple methods related to the low-level differences in the ;;; implementation of standard and funcallable-standard instances. ;;; ;;; As it happens, none of these differences are the ones reflected in ;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS ;;; share all their specified methods at STD-CLASS. ;;; ;;; ;;; workings of this metaclass and the standard-class metaclass. ;;; (in-package :pcl) (defmethod wrapper-fetcher ((class funcallable-standard-class)) 'fsc-instance-wrapper) (defmethod slots-fetcher ((class funcallable-standard-class)) 'fsc-instance-slots) (defmethod raw-instance-allocator ((class funcallable-standard-class)) 'allocate-funcallable-instance) ;;; ;;; ;;; (defmethod validate-superclass ((fsc funcallable-standard-class) (class standard-class)) t) ; was (null (wrapper-instance-slots-layout (class-wrapper class))) (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-funcallable-instance (class-wrapper class))) (defmethod make-reader-method-function ((class funcallable-standard-class) slot-name) (make-std-reader-method-function (class-name class) slot-name)) (defmethod make-writer-method-function ((class funcallable-standard-class) slot-name) (make-std-writer-method-function (class-name class) slot-name)) ;;;; ;;;; See the comment about reader-function--std and writer-function--sdt. ;;;; ;(define-function-template reader-function--fsc () '(slot-name) ; `(function ; (lambda (instance) ; (slot-value-using-class (wrapper-class (get-wrapper instance)) ; instance ; slot-name)))) ; ;(define-function-template writer-function--fsc () '(slot-name) ; `(function ; (lambda (nv instance) ; (setf ; (slot-value-using-class (wrapper-class (get-wrapper instance)) ; instance ; slot-name) ; nv)))) ; ;(eval-when (load) ; (pre-make-templated-function-constructor reader-function--fsc) ; (pre-make-templated-function-constructor writer-function--fsc)) gcl-2.6.14/pcl/extensions/0000755000175000017500000000000014360276512013750 5ustar cammcammgcl-2.6.14/pcl/extensions/extensions.lisp0000644000175000017500000005362514360276512017053 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- ;;; ;;; ************************************************************************* ;;; ;;; File: extensions.lisp. ;;; ;;; by Trent E. Lange, Effective Date 04-23-92 ;;; ;;; ;;; This file contains a small set of useful extensions to PCL. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify and distribute this document. ;;; ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; (in-package 'pcl) (eval-when (compile load eval) (defvar *extensions-exports* '(set-standard-instance-access set-funcallable-instance-access funcallable-instance-slot-value set-funcallable-instance-slot-value funcallable-instance-slot-boundp standard-instance-slot-value set-standard-instance-slot-value standard-instance-slot-boundp structure-instance-slot-value set-structure-instance-slot-value structure-instance-slot-boundp #+pcl-user-instances user-instance-slot-value #+pcl-user-instances set-user-instance-slot-value #+pcl-user-instances user-instance-slot-boundp with-optimized-slots with-standard-instance-slots method-needs-next-methods-p map-all-classes finalize-all-classes updater record-updater)) ) (defclass updater () ((dependent :initarg :dependent :reader dependent))) (defun record-updater (class dependee dependent &rest initargs) (let ((updater (apply #'make-instance class :dependent dependent initargs))) (add-dependent dependee updater) updater)) (defun finalize-all-classes (&optional (root-name 't)) "Makes sure that all classes are finalized. If Root-Name is supplied, then finalizes Root-Name and all of its subclasses and their subclasses." (map-all-classes #'(lambda (class) (unless (class-finalized-p class) (finalize-inheritance class))) root-name)) ;;; ;;; ;;; (defmacro slot-value-from-index (instance wrapper slot-name slots index) "Returns instance's slot-value given slot-name's index." (once-only (index) `(if ,index (let ((val (%svref ,slots ,index))) (if (eq val ',*slot-unbound*) (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name) val)) (if *safe-to-use-slot-value-wrapper-optimizations-p* (get-class-slot-value-1 ,instance ,wrapper ,slot-name) (accessor-slot-value ,instance ,slot-name))))) (defmacro set-slot-value-from-index (instance wrapper slot-name slots index new-value) "Sets instance's slot-value to new-value given slot-name's index." (once-only (index) `(if ,index (setf (%svref ,slots ,index) ,new-value) (if *safe-to-use-set-slot-value-wrapper-optimizations-p* (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) (defsetf slot-value-from-index set-slot-value-from-index) (defmacro with-slots-slot-value-from-index (instance wrapper slot-name slots index variable-instance) "Returns instance's slot-value given slot-name's index." (cond ((consp wrapper) `(let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance))) (variable-instance `(let ((,instance ,variable-instance)) (with-slots-slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index NIL))) (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)))) (defmacro set-with-slots-slot-value-from-index (instance wrapper slot-name slots index variable-instance new-value) "Sets instance's slot-value to new-value given slot-name's index." (cond ((consp wrapper) `(let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (set-with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance ,new-value))) (variable-instance `(let ((,instance ,variable-instance)) (set-with-slot-slots-value-from-index ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value))) (T `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index) ,new-value)))) (defsetf with-slots-slot-value-from-index set-with-slots-slot-value-from-index) (defmacro with-slots-slot-value-from-wrapper-and-slots (instance slot-name wrapper slots-layout slots variable-instance) (cond (variable-instance `(let ((,instance ,variable-instance)) (with-slots-slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL))) ((consp wrapper) `(if *safe-to-use-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL)) (accessor-slot-value ,instance ,slot-name))) (T `(if *safe-to-use-slot-value-wrapper-optimizations-p* (slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) (accessor-slot-value ,instance ,slot-name))))) (defmacro set-with-slots-slot-value-from-wrapper-and-slots (instance slot-name wrapper slots-layout slots variable-instance new-value) (cond (variable-instance `(let ((,instance ,variable-instance)) (set-with-slots-slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value))) ((consp wrapper) `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL) ,new-value)) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))) (T `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) ,new-value) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) (defsetf with-slots-slot-value-from-wrapper-and-slots set-with-slots-slot-value-from-wrapper-and-slots) (defun tree-memq-p (item form) (cond ((consp form) (or (tree-memq-p item (car form)) (tree-memq-p item (cdr form)))) (T (eq item form)))) (defmacro with-optimized-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that is faster because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." ;; E.g. (with-optimized-slots (foo-slot ;; (foo-slot-accessor 'foo-slot) ;; (variable-slot-accessor variable-slot)) ;; instance ;; :instance-form (car instances-of-same-class) ;; (loop for instance in objects-of-same-class ;; as variable-slot in variable-slots ;; collect (list foo-slot ;; foo-slot-accessor ;; variable-slot-accessor))) ;; ==> (loop for instance in objects-of-same-class ;; as variable-slot in variable-slots ;; collect (list (slot-value instance 'foo-slot) ;; (slot-value instance 'foo-slot) ;; (slot-value instance variable-slot))) (build-with-optimized-slots-form slot-entries instance-form body)) (defmacro with-standard-instance-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that assumes that the instance-form evaluates to a standard-instance. The result is undefined if it does not. With-standard-instance-slots is faster than With-Slots because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." (build-with-optimized-slots-form slot-entries instance-form body 'std-instance)) (defun build-with-optimized-slots-form (slot-entries instance-form body &optional instance-type) (let* ((variable-instance (if (eq (car body) :variable-instance) (prog1 (cadr body) (setf body (cddr body))))) (hard-accessors (let ((collect NIL)) (dolist (slot-entry slot-entries (nreverse collect)) (when (and (symbolp slot-entry) (tree-memq-p slot-entry body)) (push (cons slot-entry slot-entry) collect)) (when (and (consp slot-entry) (constantp (second slot-entry)) (tree-memq-p (car slot-entry) body)) (push (cons (car slot-entry) (second (second slot-entry))) collect))))) (variable-accessors (let ((collect NIL)) (dolist (slot-entry slot-entries (nreverse collect)) (when (and (consp slot-entry) (not (constantp (second slot-entry))) (tree-memq-p (car slot-entry) body)) (push slot-entry collect)))))) (if *safe-to-use-slot-wrapper-optimizations-p* (build-maybe-safe-w-o-s-v hard-accessors variable-accessors instance-form body variable-instance instance-type) (build-with-accessor-s-v hard-accessors variable-accessors instance-form body variable-instance)))) (defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors instance-form body variable-instance instance-type) (let* ((instance-string (if (symbolp instance-form) (symbol-name instance-form) "")) (instance-form-var (if (and variable-instance (simple-eval-access-p instance-form)) instance-form (gensym (concatenate 'simple-string instance-string "-INSTANCE-FORM")))) (prototype-form (if variable-instance (if (simple-eval-access-p variable-instance) variable-instance (gensym (concatenate 'simple-string "VARIABLE-INSTANCE" instance-string))) instance-form-var)) (wrapper-var (gensym (concatenate 'simple-string instance-string "-WRAPPER"))) (slots-var (unless variable-instance (gensym (concatenate 'simple-string instance-string "-SLOTS")))) (type-var (when (and variable-instance (not instance-type)) (gensym (concatenate 'simple-string instance-string "-TYPE")))) (type-var-std 1) (type-var-fsc 2) #+pcl-user-instances (type-var-user 3) (slot-index-vars (mapcar #'(lambda (slot-entry) (list (car slot-entry) (cdr slot-entry) (gensym (concatenate 'simple-string (if (string= instance-string "") "INSTANCE-FORM-" instance-string) (symbol-name (cdr slot-entry)) "-INDEX")))) (remove-duplicates hard-accessors :key #'cdr))) (slots-layout-var (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string))) (runtime-slots-form (if variable-instance (ecase instance-type (std-instance `(std-instance-slots ,instance-form-var)) (fsc-instance `(fsc-instance-slots ,instance-form-var)) #+pcl-user-instances (user-instance `(get-user-instance-slots ,instance-form-var)) ((nil) `(case ,type-var (,type-var-std (std-instance-slots ,instance-form-var)) (,type-var-fsc (fsc-instance-slots ,instance-form-var)) #+pcl-user-instances (,type-var-user (get-user-instance-slots ,instance-form-var))))) slots-var)) (runtime-wrapper-form (if variable-instance (ecase instance-type (std-instance `(std-instance-wrapper ,instance-form-var)) (fsc-instance `(fsc-instance-wrapper ,instance-form-var)) #+pcl-user-instances (user-instance `(get-user-instance-wrapper ,instance-form-var)) ((nil) `(case ,type-var (,type-var-std (std-instance-wrapper ,instance-form-var)) (,type-var-fsc (fsc-instance-wrapper ,instance-form-var)) #+pcl-user-instances (,type-var-user (get-user-instance-wrapper ,instance-form-var))))) wrapper-var))) (declare (type simple-string instance-string) (type list slot-index-vars)) `(let (,@(unless variable-instance `((,instance-form-var ,instance-form))) ,@(when (and variable-instance (not (eq prototype-form variable-instance))) `((,prototype-form ,variable-instance))) ,wrapper-var ,slots-layout-var ,@(if variable-instance (if type-var `((type-var 0))) (list slots-var)) ,@(mapcar #'third slot-index-vars)) ,@(when type-var `((declare (type index ,type-var)))) (when *safe-to-use-slot-wrapper-optimizations-p* ,@(ecase instance-type (std-instance `((setf ,wrapper-var (std-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (std-instance-slots ,prototype-form)))))) (fsc-instance `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (fsc-instance-slots ,prototype-form)))))) #+pcl-user-instances (user-instance `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (get-user-instance-slots ,prototype-form)))))) ((nil) `((cond ((std-instance-p ,prototype-form) (setf ,wrapper-var (std-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-std) `(setf ,slots-var (std-instance-slots ,prototype-form)))) ((fsc-instance-p ,prototype-form) (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-fsc) `(setf ,slots-var (fsc-instance-slots ,prototype-form)))) #+pcl-user-instances ((get-user-instance-p ,prototype-form) (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-user) `(setf ,slots-var (get-user-instance-slots ,prototype-form)))))))) ,@(if instance-type (build-w-s-v-find-slot-indices wrapper-var slots-layout-var prototype-form slot-index-vars) `((when ,wrapper-var ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var prototype-form slot-index-vars))))) (symbol-macrolet (,@(mapcar #'(lambda (slot-cons) `(,(car slot-cons) (with-slots-slot-value-from-index ,instance-form-var ,runtime-wrapper-form ',(cdr slot-cons) ,runtime-slots-form ,(third (assoc (car slot-cons) slot-index-vars :test #'eq)) ,(when (and variable-instance (not (eq variable-instance instance-form-var))) variable-instance)))) hard-accessors) ,@(mapcar #'(lambda (variable-cons) `(,(car variable-cons) (with-slots-slot-value-from-wrapper-and-slots ,instance-form-var ,(second variable-cons) ,runtime-wrapper-form ,slots-layout-var ,runtime-slots-form ,(when (and variable-instance (not (eq variable-instance instance-form-var))) variable-instance)))) variable-accessors)) ,@body)))) (defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var prototype-form slot-index-vars) (declare (type list slot-index-vars)) `((unless (eq (wrapper-state ,wrapper-var) 't) (setf ,wrapper-var (wrapper-state-trap ,wrapper-var ,prototype-form))) (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var)) ,@(if (<= (length slot-index-vars) 2) (mapcar #'(lambda (slot-cons) `(setf ,(third slot-cons) (instance-slot-index-from-slots-layout ,slots-layout-var ',(second slot-cons)))) slot-index-vars) ;; More than two slots, so more efficient to search slots-layout-var ;; only once, rather than once for each with instance-slot-index. (labels ((build-comps (slot-vars index) (if slot-vars `(if (eq slot-name ',(second (car slot-vars))) (progn (setf ,(third (car slot-vars)) ,index) (if (= matches ,(1- (length slot-index-vars))) (go end-loop) (setf matches (the fixnum (1+ matches))))) ,(build-comps (cdr slot-vars) index))))) `((block nil (let ((slots-left ,slots-layout-var) (slot-name NIL) (index 0) (matches 0)) (declare (type fixnum index matches)) (when slots-left (tagbody begin-instance-slots-loop (setf slot-name (car slots-left)) ,(build-comps slot-index-vars 'index) (setf index (the fixnum (1+ index))) (if (null (setf slots-left (cdr slots-left))) (go end-loop)) (go begin-instance-slots-loop) end-loop))))))))) (defun build-with-accessor-s-v (hard-accessors variable-accessors instance-form body variable-instance) ;; Build the body for with-optimized-slot-value when it is unsafe ;; and accessor-slot-value must be used. (let ((instance-form-var (if variable-instance instance-form (gensym "INSTANCE-FORM")))) `(let (,@(unless variable-instance `((,instance-form-var ,instance-form)))) (symbol-macrolet (,@(mapcar #'(lambda (slot-cons) `(,(car slot-cons) (accessor-slot-value ,instance-form-var ',(cdr slot-cons)))) hard-accessors) ,@(mapcar #'(lambda (variable-cons) `(,(car variable-cons) (accessor-slot-value ,instance-form-var ,(second variable-cons)))) variable-accessors)) ,@body)))) #-(or KCL IBCL) (export *extensions-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *extensions-exports*) (list *the-pcl-package*)) gcl-2.6.14/pcl/extensions/user-instances.lisp0000644000175000017500000006640414360276512017616 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- ;;; ;;; ************************************************************************* ;;; ;;; File: user-instances.lisp. ;;; ;;; by Trent E. Lange, Effective Date 06-02-92 ;;; ;;; ;;; This file contains a metaclass (User-Vector-Class) whose instances ;;; are stored as simple-vectors, saving space over PCL's standard instance ;;; representations of PCL at the cost of some class redefinition flexibiliity. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify and distribute this document. ;;; ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; This file builds on the PCL-USER-INSTANCES feature of July 92 PCL ;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple ;;; vectors. The first element of the instance vector is the instance's ;;; class wrapper (providing internal PCL information about the instance's ;;; class). The remaining elements of the instance vector are the instance's ;;; slots themselves. ;;; ;;; The space overhead of user-vector-instances is only two vector cells ;;; (one for the vector, one for the wrapper). This is contrast to standard ;;; PCL instances, which have a total overhead of four cells. (Standard ;;; instances in PCL are represented as instances of structure STD-INSTANCE ;;; having two slots, one for the wrapper and one holding a simple-vector ;;; which is the instance's slots). This two-cell space savings per instance ;;; comes at the cost of losing some class redefinition flexibility, since ;;; simple-vectors cannot have their sizes changed dynamically. ;;; All current instances of user-instance-vectors therefore become ;;; permanently obsolete if the classes' instance slots change. ;;; ;;; This code requires July 92 PCL or later compiled with the ;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file). ;;; #-pcl-user-instances (eval-when (compile load eval) (error "Cannot use user-instances, since PCL was compiled without PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)") ) (eval-when (compile load eval) (defclass user-vector-class-mixin () () (:documentation "Use this mixin for metaclasses whose instances are USER-INSTANCES instantiated as simple-vectors. This saves space over the standard instances used by standard-class, at the cost of losing the ability to redefine the slots in a class and still have old instances updated correctly.")) (defclass user-vector-class (user-vector-class-mixin standard-class) () (:documentation "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors. This saves space over the standard instances used by standard-class, at the cost of losing the ability to redefine the slots in a class and still have old instances updated correctly.")) (defmethod validate-superclass ((class user-vector-class-mixin) (new-super T)) (or (typep new-super 'user-vector-class-mixin) (eq new-super (find-class 'standard-object)))) (defclass user-vector-object (standard-object) () (:metaclass user-vector-class)) ) ;;; ;;; ;;; Instance allocation stuff. ;;; (defmacro user-vector-instance-p (object) (once-only (object) `(the boolean (and (simple-vector-p ,object) (plusp (length (the simple-vector ,object))) (wrapper-p (%svref ,object 0)))))) (defmacro user-vector-instance-wrapper (object) `(%svref ,object 0)) (defsetf user-vector-instance-wrapper (object) (new-value) `(setf (%svref ,object 0) ,new-value)) (defmacro user-vector-instance-slots (instance) ;; The slots vector of user-vector instances is the instance itself. instance) (defmacro set-user-vector-instance-slots (instance new-value) `(progn (warn "Attempt to set user-vector-instance-slots of ~S to ~S" ,instance ,new-value) ,new-value)) (defun user-instance-p (x) "Is X a user instance, specifically a user-vector-instance?" (user-vector-instance-p x)) (defun user-instance-slots (x) "Return the slots of this user-vector-instance." (user-vector-instance-slots x)) (defun user-instance-wrapper (x) "Return the wrapper of this user-vector-instance." (user-vector-instance-wrapper x)) (defun set-user-instance-wrapper (x new) (setf (user-vector-instance-wrapper x) new)) (defmacro get-user-instance-p (x) `(user-vector-instance-p ,x)) (defmacro get-user-instance-wrapper (x) `(user-vector-instance-wrapper ,x)) (defmacro get-user-instance-slots (x) `(user-vector-instance-slots ,x)) (eval-when (eval #+cmu load) (force-compile 'user-instance-p) (force-compile 'user-instance-slots) (force-compile 'user-instance-wrapper) (force-compile 'set-user-instance-wrapper)) ;;; ;;; Methods needed for user-vector-class-mixin. ;;; (defconstant *not-a-slot* (gensym "NOT-A-SLOT")) (defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (let* ((class-wrapper (class-wrapper class)) (copy-instance (wrapper-allocate-static-slot-storage-copy class-wrapper)) (instance (copy-simple-vector copy-instance))) (declare (type simple-vector copy-instance instance)) (setf (user-vector-instance-wrapper instance) class-wrapper) instance)) (defmethod make-instances-obsolete ((class user-vector-class-mixin)) "The slots of user-vector-instances are stored in the instance vector themselves (a simple-vector), so old instances cannot be updated properly." (setf (slot-value class 'prototype) NIL) (warn "Obsoleting user-vector class ~A, all current instances will be invalid..." class)) (defmethod compute-layout :around ((class user-vector-class-mixin) cpl instance-eslotds) ;; First element of user-vector-instance is actually its wrapper. (declare (ignore cpl instance-eslotds)) (cons *not-a-slot* (call-next-method))) (defmethod compute-instance-layout :around ((class user-vector-class-mixin) instance-eslotds) ;; First element of user-vector-instance is actually its wrapper. (declare (ignore instance-eslotds)) (cons *not-a-slot* (call-next-method))) (defmethod wrapper-fetcher ((class user-vector-class-mixin)) 'user-vector-instance-wrapper) (defmethod slots-fetcher ((class user-vector-class-mixin)) 'user-vector-instance-slots) (defmethod raw-instance-allocator ((class user-vector-class-mixin)) 'allocate-user-vector-instance) ;;; ;;; The following functions and methods are not strictly necessary for ;;; user-vector-instances, but do speed things up a bit. ;;; ;;; Inform PCL that it is still safe to use its standard slot-value ;;; optimizations with user-vector-class-mixin's slot-value-using-class ;;; methods: (pushnew '(user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-slot-value-using-class-specializers*) (pushnew '(T user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-set-slot-value-using-class-specializers*) (pushnew '(user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-slot-boundp-using-class-specializers*) (defmethod slot-value-using-class ((class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (%svref (user-vector-instance-slots object) location)) (cons (cdr location)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be read by the default ~s method." slotd 'slot-value-using-class))))) (if (eq value *slot-unbound*) (slot-unbound class object (slot-definition-name slotd)) value))) (defmethod (setf slot-value-using-class) (new-value (class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (setf (%svref (user-vector-instance-slots object) location) new-value)) (cons (setf (cdr location) new-value)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be written by the default ~s method." slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (%svref (user-vector-instance-slots object) location)) (cons (cdr location)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be read by the default ~s method." slotd 'slot-boundp-using-class))))) (not (eq value *slot-unbound*)))) (defmethod make-optimized-reader-method-function ((class user-vector-class-mixin) generic-function reader-method-prototype slot-name) (declare (ignore generic-function reader-method-prototype)) (make-user-vector-instance-reader-method-function slot-name)) (defmethod make-optimized-writer-method-function ((class user-vector-class-mixin) generic-function reader-method-prototype slot-name) (declare (ignore generic-function reader-method-prototype)) (make-user-vector-instance-writer-method-function slot-name)) (defmethod make-optimized-method-function ((class user-vector-class-mixin) generic-function boundp-method-prototype slot-name) (declare (ignore generic-function boundp-method-prototype)) (make-user-vector-instance-boundp-method-function slot-name)) (defun make-user-vector-instance-reader-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (instance) (user-instance-slot-value instance slot-name))) (defun make-user-vector-instance-writer-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (nv instance) (setf (user-instance-slot-value instance slot-name) nv))) (defun make-user-vector-instance-boundp-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (instance) (user-instance-slot-boundp instance slot-name))) (defun make-optimized-user-reader-method-function (slot-name index) (declare #.*optimize-speed*) (progn slot-name) #'(lambda (instance) (let ((value (%svref (user-vector-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value)))) (defun make-optimized-user-writer-method-function (index) (declare #.*optimize-speed*) #'(lambda (nv instance) (setf (%svref (user-vector-instance-slots instance) index) nv))) (defun make-optimized-user-boundp-method-function (index) (declare #.*optimize-speed*) #'(lambda (instance) (not (eq (%svref (user-vector-instance-slots instance) index) *slot-unbound*)))) (defmacro with-user-instance-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that assumes that the instance-form evaluates to a user-vector-instance. The result is undefined if it does not. With-user-vector-instance-slots is faster than With-Slots because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." (build-with-optimized-slots-form slot-entries instance-form body 'user-instance)) ;;; ;;; Lisp and CLOS print compatability functions: ;;; ;;; This gets really ugly because most lisps don't use PRINT-OBJECT ;;; for the printed representation of their objects like they're supposed ;;; to. (And if the lisp did, it wouldn't be using PCL.). And since ;;; user-vector-instances are implemented as simple-vectors, the only ;;; way to get their printed representations to look right is to make ;;; PRINT-OBJECT object to work. ;;; We therefore have to patch the standard lisp printing functions. ;;; If all goes well, then everything is honky-dory. If it doesn't, then ;;; debugging can get pretty messy since we were screwing with the standard ;;; printing functions. Things should work, but if they don't, then calling ;;; RESTORE-LISP-PRINTERS will get things back to normal. (defvar *old-write* NIL) (defvar *old-princ* NIL) (defvar *old-prin1* NIL) (defvar *old-print* NIL) ;; Structure dummy-print-instance is a structure whose sole purpose ;; in life is to act as a placeholder to allow the print-object of ;; user-vector-class objects to be printed. (defstruct (dummy-print-instance (:print-function print-dummy-print-instance)) (print-object-string nil)) (declaim (type list *dummy-print-instance-garbage*)) (defvar *dummy-print-instance-garbage* NIL) (defconstant *dummy-print-instance-garbage-limit* 100) (defmacro pure-array-p (x &optional (test-user-vector-instance-p T)) "Returns whether item is a 'pure' array -- i.e. not a string, and not something holding a CLOS instance." (once-only (x) `(the boolean (locally (declare (inline arrayp stringp typep)) (and (arrayp ,x) (not (stringp ,x)) #-(or cmu (and lucid pcl)) (not (typep ,x 'structure)) ,@(when test-user-vector-instance-p `((not (user-vector-instance-p ,x)))) #-(or cmu (and lucid pcl)) (not (typep ,x 'standard-object))))))) (defun copy-any-array (old-array &rest keys-passed &key key dimensions) ;; Returns a copy of old-array. If :key is provided, then the ;; elements of the new-array are the result of key applied to ;; old-array's elements. If :dimensions is provided, and it is ;; different than old-array's dimensions, then the new-array is created ;; with those dimensions, and everything that can be copied from ;; old-array is copied into it. It is an error if the rank of ;; the array specified by dimensionss is different than that of the ;; old-array. (declare (type array old-array) (type (or function null) key) (type list dimensions keys-passed)) (cond ((simple-vector-p old-array) (apply #'copy-array-contents old-array (make-array (the index (if dimensions (car dimensions) (length (the simple-vector old-array))))) keys-passed)) ((vectorp old-array) (apply #'copy-array-contents old-array (make-array (the index (if dimensions (car dimensions) (length (the vector old-array)))) :element-type (array-element-type old-array) :adjustable (adjustable-array-p old-array)) keys-passed)) ((arrayp old-array) (let* ((old-dimensions (array-dimensions old-array)) (new-dimensions (or dimensions old-dimensions)) (element-type (array-element-type old-array)) (new-array (make-array new-dimensions :element-type element-type :adjustable (adjustable-array-p old-array)))) (declare (type list old-dimensions new-dimensions) (type array new-array)) (if (or (null dimensions) (equal new-dimensions old-dimensions)) (let* ((displaced-old-array (make-array (array-total-size old-array) :element-type element-type :displaced-to old-array)) (displaced-new-array (make-array (array-total-size new-array) :element-type element-type :displaced-to new-array))) (declare (type array displaced-old-array displaced-new-array)) (copy-array-contents displaced-old-array displaced-new-array :key key)) (let ((first-dimension (min (the index (car new-dimensions)) (the index (car old-dimensions))))) (declare (type index first-dimension)) (walk-dimensions (mapcar #'min (cdr new-dimensions) (cdr old-dimensions)) #'(lambda (post-indices) (copy-array-contents old-array new-array :key key :length first-dimension :post-indices post-indices))))) new-array)))) (defun copy-array-contents (old-array new-array &key key length post-indices &allow-other-keys) ;; Copies the contents of old-array into new-array, using key if ;; supplied. Only the first :length items are copied (defaulting ;; to the length of the old-array). If :post-indices are passed, then ;; they are used as "post" indices to an aref. (macrolet ((do-copy (aref old new key key-type len post-indices) (let ((atype (if (eq aref #'svref) 'simple-vector 'array))) `(dotimes (i (the index ,len)) (setf ,(if post-indices `(apply #'aref (the ,atype ,new) i ,post-indices) `(,aref (the ,atype ,new) i)) ,(if key-type `(funcall (the ,key-type ,key) ,(if post-indices `(apply #'aref (the ,atype ,old) i ,post-indices) `(,aref (the ,atype ,old) i))) (if post-indices `(apply #'aref (the ,atype ,old) i ,post-indices) `(,aref (the ,atype ,old) i))))))) (expand-on-key (aref key old new len post-ind) `(cond ((null ,key) (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind)) ((compiled-function-p ,key) (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind)) (T (do-copy ,aref ,old ,new ,key function ,len ,post-ind))))) (if (simple-vector-p old-array) (progn (when post-indices (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS from simple-vector")) (unless length (setf length (min (length (the simple-vector old-array)) (length (the simple-vector new-array))))) (expand-on-key svref key old-array new-array length NIL)) (progn (unless length (setf length (min (the index (car (array-dimensions old-array))) (the index (car (array-dimensions new-array)))))) (if post-indices (expand-on-key #'aref key old-array new-array length post-indices) (expand-on-key aref key old-array new-array length NIL))))) new-array) (declaim (ftype (function (list function) T) walk-dimensions)) (defun walk-dimensions (dimensions fn) (declare (type list dimensions) (type function fn)) ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks ;; through every possible combination from 0 to 1- each of those ;; dimensions, and calling fn on each of them. (let ((compiled-p (compiled-function-p fn))) (labels ((doit (dims apply-dims) (declare (type list dims apply-dims)) (if (cdr dims) (let ((last-dim NIL) (dims-left NIL)) (loop (when (null (cdr dims)) (setf last-dim (car dims)) (return)) (if dims-left (nconc dims-left (list (car dims))) (setf dims-left (list (car dims)))) (setf dims (cdr dims))) (dotimes (i (the index last-dim)) (doit dims-left (cons i apply-dims)))) (if compiled-p (dotimes (i (the index (car dims))) (funcall (the compiled-function fn) (cons i apply-dims))) (dotimes (i (the index (car dims))) (funcall fn (cons i apply-dims))))))) (doit dimensions NIL)))) (defmacro funcall-printer (applyer print-function object keys) `(progn (if (or (arrayp ,object) (consp ,object)) (multiple-value-bind (converted-item garbage) (convert-user-vector-instances-to-dummy-print-instances ,object) (,applyer (the compiled-function ,print-function) converted-item ,keys) (deallocate-dummy-print-instances garbage)) (,applyer (the compiled-function ,print-function) ,object ,keys)) ,object)) (defun print-dummy-print-instance (instance stream depth) (declare (ignore depth)) (let ((*print-pretty* NIL)) (funcall (the compiled-function *old-princ*) (dummy-print-instance-print-object-string instance) stream))) (defun allocate-dummy-print-instance (print-object-string) (if *dummy-print-instance-garbage* (let ((instance (pop *dummy-print-instance-garbage*))) (setf (dummy-print-instance-print-object-string instance) print-object-string) instance) (make-dummy-print-instance :print-object-string print-object-string))) (defun dummy-print-instance-of (user-vector-instance) (allocate-dummy-print-instance (with-output-to-string (str) (print-object user-vector-instance str)))) (defun deallocate-dummy-print-instances (dummies) (let ((count (length *dummy-print-instance-garbage*))) (declare (type index count)) (dolist (dummy dummies) (when (> count *dummy-print-instance-garbage-limit*) (return)) (push dummy *dummy-print-instance-garbage*) (setf count (the index (1+ count)))))) (defun convert-user-vector-instances-to-dummy-print-instances (item) (let ((print-length (or *print-length* 1000)) (print-level (or *print-level* 1000)) (dummy-print-instances-used NIL)) (declare (fixnum print-length print-level)) (labels ((doit (item level length) (declare (fixnum level length)) (labels ((user-vector-instance-visible-within-p (item level length) (declare (fixnum level length)) (cond ((>= length print-length) NIL) ((> level print-level) NIL) ((= level print-level) (user-vector-instance-p item)) (T (cond ((user-vector-instance-p item) T) ((consp item) (or (user-vector-instance-visible-within-p (car item) (the fixnum (1+ level)) 0) (user-vector-instance-visible-within-p (cdr item) level (the fixnum (1+ length))))) ((and *print-array* (pure-array-p item)) (let ((next-level (the fixnum (1+ level)))) (declare (fixnum next-level)) (dotimes (i (1- (length (the array item))) NIL) (unless (< i print-length) (return NIL)) (if (user-vector-instance-visible-within-p (aref item i) next-level 0) (return T)))))))))) ;; doit body (cond ((user-vector-instance-p item) (let ((dummy (dummy-print-instance-of item))) (push dummy dummy-print-instances-used) dummy)) ((consp item) (if (user-vector-instance-visible-within-p item level length) (cons (doit (car item) (the fixnum (1+ level)) length) (doit (cdr item) level (the fixnum (1+ length)))) item)) ((and *print-array* (pure-array-p item NIL)) (if (user-vector-instance-visible-within-p item level length) (copy-any-array item :key #'(lambda (item) (if (user-vector-instance-p item) (let ((dummy (dummy-print-instance-of item))) (push dummy dummy-print-instances-used) dummy) item)) :dimensions (mapcar #'1+ (array-dimensions item))) item)) (T item))))) ;; convert-user-vector-instances-to-dummy-print-instances body (let ((converted (doit item 0 0))) (values converted dummy-print-instances-used))))) (force-compile 'convert-user-vector-instances-to-dummy-print-instances) (unless *old-write* (setf *old-write* (symbol-function 'write))) (defun new-write (object &rest keys-passed) (declare (list keys-passed)) (funcall-printer apply *old-write* object keys-passed)) (force-compile 'write) (setf (symbol-function 'write) (symbol-function 'new-write)) (unless *old-princ* (setf *old-princ* (symbol-function 'princ))) (defun princ (object &optional stream) (funcall-printer funcall *old-princ* object stream)) (force-compile 'princ) (unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1))) (defun prin1 (object &optional stream) (funcall-printer funcall *old-prin1* object stream)) (force-compile 'prin1) (unless *old-print* (setf *old-print* (symbol-function 'print))) (defun print (object &optional stream) (funcall-printer funcall *old-print* object stream)) (force-compile 'print) (defun new-write-to-string (object &rest keys-passed) (declare (list keys-passed)) (with-output-to-string (string-stream) (apply #'write object :stream string-stream keys-passed))) (force-compile 'write-to-string) (setf (symbol-function 'write-to-string) (symbol-function 'new-write-to-string)) (defun princ-to-string (object) (with-output-to-string (string-stream) (funcall-printer funcall *old-princ* object string-stream) string-stream)) (force-compile 'princ-to-string) (defun prin1-to-string (object) (with-output-to-string (string-stream) (funcall-printer funcall *old-prin1* object string-stream) string-stream)) (force-compile 'prin1-to-string) (defun restore-lisp-printers () (setf (symbol-function 'write) *old-write*) (setf (symbol-function 'princ) *old-princ*) (setf (symbol-function 'prin1) *old-prin1*) (setf (symbol-function 'print) *old-print*)) gcl-2.6.14/pcl/extensions/inline.lisp0000644000175000017500000002233614360276512016125 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- (in-package :pcl) ;; This file contains some of the things that will have to change to support ;; inlining of methods. (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The method-lambda argument to make-method-lambda, ~S,~ is not a lambda form" method-lambda)) (multiple-value-bind (documentation declarations real-body) (extract-declarations (cddr method-lambda) env) (let* ((name-decl (get-declaration 'method-name declarations)) (sll-decl (get-declaration 'method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) (generic-function-name (when method-name (car method-name))) (specialized-lambda-list (or sll-decl (cadr method-lambda)))) (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters (mapcar #'(lambda (r s) (declare (ignore s)) r) parameters specializers)) (slots (mapcar #'list required-parameters)) (calls (list nil)) (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters declarations method-name specializers)) (class-declarations `(declare ,@(remove nil (mapcar #'(lambda (a s) (and (symbolp s) (neq s 't) `(class ,a ,s))) parameters specializers)))) (method-lambda ;; Remove the documentation string and insert the ;; appropriate class declarations. The documentation ;; string is removed to make it easy for us to insert ;; new declarations later, they will just go after the ;; cadr of the method lambda. The class declarations ;; are inserted to communicate the class of the method's ;; arguments to the code walk. `(lambda ,lambda-list ,class-declarations ,@declarations (progn ,@parameters-to-reference) (block ,(if (listp generic-function-name) (cadr generic-function-name) generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p (eval (car real-body)))) (plist (if (and constant-value-p (or (typep constant-value '(or number character)) (and (symbolp constant-value) (symbol-package constant-value)))) (list :constant-value constant-value) ())) (applyp (dolist (p lambda-list nil) (cond ((memq p '(&optional &rest &key)) (return t)) ((eq p '&aux) (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep next-method-p-p) (walk-method-lambda method-lambda required-parameters env slots calls) (multiple-value-bind (ignore walked-declarations walked-lambda-body) (extract-declarations (cddr walked-lambda)) (declare (ignore ignore)) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p 't plist))) (when (some #'cdr slots) (multiple-value-bind (slot-name-lists call-list) (slot-name-lists-from-slots slots calls) (let ((pv-table-symbol (make-symbol "pv-table"))) (setq plist `(,@(when slot-name-lists `(:slot-name-lists ,slot-name-lists)) ,@(when call-list `(:call-list ,call-list)) :pv-table-symbol ,pv-table-symbol ,@plist)) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists ,pv-table-symbol) ,@walked-lambda-body)))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) (setq lambda-list (nconc (ldiff lambda-list aux) (list '&allow-other-keys) aux)))) (values `(lambda (.method-args. .next-methods.) (simple-lexical-method-functions (,lambda-list .method-args. .next-methods. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p :closurep ,closurep :applyp ,applyp) ,@walked-declarations ,@walked-lambda-body)) `(,@(when plist `(:plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) (define-inline-function slot-value (instance slot-name) (form closure-p env) :predicate (and (not closure-p) (constantp slot-name)) :inline-arguments (required-parameters slots) :inline (optimize-slot-value slots (can-optimize-access form required-parameters env) form)) ;collect information about: ; uses of the required-parameters ; uses of call-next-method and next-method-p: ; called-p ; apply-p ; arglist info ;optimize calls to slot-value, set-slot-value, slot-boundp ;optimize calls to find-class ;optimize generic-function calls (defun make-walk-function (required-parameters info slots calls) #'(lambda (form context env) (cond ((not (eq context ':eval)) form) ((not (listp form)) form) ((eq (car form) 'call-next-method) (setq call-next-method-p 't) form) ((eq (car form) 'next-method-p) (setq next-method-p-p 't) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p 't) (setq closurep t) form) ((eq (cadr form) 'next-method-p) (setq next-method-p-p 't) (setq closurep t) form) (t nil)))) ((and (or (eq (car form) 'slot-value) (eq (car form) 'set-slot-value) (eq (car form) 'slot-boundp)) (constantp (caddr form))) (let ((parameter (can-optimize-access form required-parameters env))) (ecase (car form) (slot-value (optimize-slot-value slots parameter form)) (set-slot-value (optimize-set-slot-value slots parameter form)) (slot-boundp (optimize-slot-boundp slots parameter form))))) ((and (or (symbolp (car form)) (and (consp (car form)) (eq (caar form) 'setf))) (gboundp (car form)) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition (car form))) (funcallable-instance-p (gdefinition (car form))))) (optimize-generic-function-call form required-parameters env slots calls)) (t form)))) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let* ((call-next-method-p nil) ;flag indicating that call-next-method ;should be in the method definition (closurep nil) ;flag indicating that #'call-next-method ;was seen in the body of a method (next-method-p-p nil) ;flag indicating that next-method-p ;should be in the method definition (walk-functions `((call-next-method-p ,#'(lambda (form closure-p env) (setq call-next-method-p 't) (when closure-p (setq closurep t)) form)) (next-method-p ,#'(lambda (form closure-p env) (setq next-method-p-p 't) (when closure-p (setq closurep t)) form)) ((slot-value set-slot-value slot-boundp) ,#'(lambda (form closure-p env) (if (and (not closure-p) (constantp (caddr form))) (let ((walked-lambda (walk-form method-lambda env (make-walk-function `((call-next-method-p ,#'(lambda (form closure-p env) (setq call-next-method-p 't) (when closure-p (setq closurep t)) form)) (next-method-p ,#'(lambda (form closure-p env) (setq next-method-p-p 't) (when closure-p (setq closurep t)) form)) ((slot-value set-slot-value slot-boundp) ,#'(lambda (form closure-p env) ( (values walked-lambda call-next-method-p closurep next-method-p-p))))) (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs ':function)) (method-spec (getf initargs ':method-spec)) (plist (getf initargs ':plist)) (pv-table-symbol (getf plist ':pv-table-symbol)) (pv-table nil) (mff (getf initargs ':fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) (when mff (setf (method-function-get mff p) v)))) (when method-spec (when mf (setq mf (set-function-name mf method-spec))) (when mff (let ((name `(,(or (get (car method-spec) 'fast-sym) (setf (get (car method-spec) 'fast-sym) (intern (format nil "FAST-~A" (car method-spec)) *the-pcl-package*))) ,@(cdr method-spec)))) (set-function-name mff name) (unless mf (set-mf-property :name name))))) (when plist (let ((snl (getf plist :slot-name-lists)) (cl (getf plist :call-list))) (when (or snl cl) (setq pv-table (intern-pv-table :slot-name-lists snl :call-list cl)) (when pv-table (set pv-table-symbol pv-table)) (set-mf-property :pv-table pv-table))) (loop (when (null plist) (return nil)) (set-mf-property (pop plist) (pop plist))) (when method (set-mf-property :method method)) (when return-function-p (or mf (method-function-from-fast-function mff))))))) gcl-2.6.14/pcl/gcl_pcl_generic_functions.lisp0000644000175000017500000005620414360276512017640 0ustar cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- (in-package :pcl) ;;; class predicates (defgeneric class-eq-specializer-p (object)) ; (t) ; (class-eq-specializer) (defgeneric classp (object)) ; (t) ; (class) (defgeneric eql-specializer-p (object)) ; (t) ; (eql-specializer) (defgeneric exact-class-specializer-p (object)) ; (t) ; (exact-class-specializer) (defgeneric forward-referenced-class-p (object)) ; (t) ; (forward-referenced-class) (defgeneric funcallable-standard-class-p (object)) ; (t) ; (funcallable-standard-class) (defgeneric generic-function-p (object)) ; (t) ; (generic-function) (defgeneric legal-lambda-list-p (object x)) ; (standard-method t) (defgeneric method-combination-p (object)) ; (t) ; (method-combination) (defgeneric method-p (object)) ; (t) ; (method) (defgeneric short-method-combination-p (object)) ; (short-method-combination) ; (t) (defgeneric slot-class-p (object)) ; (t) ; (slot-class) (defgeneric specializerp (object)) ; (t) ; (specializer) (defgeneric standard-accessor-method-p (object)) ; (t) ; (standard-accessor-method) (defgeneric standard-boundp-method-p (object)) ; (t) ; (standard-boundp-method) (defgeneric standard-class-p (object)) ; (t) ; (standard-class) (defgeneric standard-generic-function-p (object)) ; (t) ; (standard-generic-function) (defgeneric standard-method-p (object)) ; (t) ; (standard-method) (defgeneric standard-reader-method-p (object)) ; (t) ; (standard-reader-method) (defgeneric standard-writer-method-p (object)) ; (t) ; (standard-writer-method) (defgeneric structure-class-p (object)) ; (t) ; (structure-class) ;;; readers (defgeneric accessor-method-slot-definition (standard-accessor-method)) ; (standard-accessor-method) (defgeneric class-can-precede-list (pcl-class)) ; (pcl-class) (defgeneric class-defstruct-constructor (structure-class)) ; (structure-class) (defgeneric class-defstruct-form (structure-class)) ; (structure-class) (defgeneric class-direct-subclasses (class)) ; (class) (defgeneric class-direct-superclasses (class)) ; (class) (defgeneric class-eq-specializer (class)) ; (class) (defgeneric class-incompatible-superclass-list (pcl-class)) ; (pcl-class) (defgeneric class-initialize-info (slot-class)) ; (slot-class) (defgeneric class-name (class)) ; (class) (defgeneric class-precedence-list (pcl-class)) ; (pcl-class) (defgeneric class-predicate-name (class)) ; (class) (defgeneric class-wrapper (pcl-class)) ; (pcl-class) (defgeneric definition-source (definition-source-mixin)) ; (definition-source-mixin) (defgeneric eql-specializer-object (eql-specializer)) ; (eql-specializer) (defgeneric generic-function-method-class (standard-generic-function)) ; (standard-generic-function) (defgeneric generic-function-method-combination (standard-generic-function)) ; (standard-generic-function) (defgeneric generic-function-methods (standard-generic-function)) ; (standard-generic-function) (defgeneric generic-function-name (standard-generic-function)) ; (standard-generic-function) (defgeneric gf-arg-info (standard-generic-function)) ; (standard-generic-function) (defgeneric gf-dfun-state (standard-generic-function)) ; (standard-generic-function) (defgeneric gf-pretty-arglist (standard-generic-function)) ; (standard-generic-function) (defgeneric long-method-combination-function (long-method-combination)) ; (long-method-combination) (defgeneric method-combination-documentation (standard-method-combination)) ; (standard-method-combination) (defgeneric method-combination-options (standard-method-combination)) ; (standard-method-combination) (defgeneric method-combination-type (standard-method-combination)) ; (standard-method-combination) (defgeneric method-fast-function (standard-method)) ; (standard-method) (defgeneric method-generic-function (standard-method)) ; (traced-method) ; (standard-method) (defgeneric object-plist (plist-mixin)) ; (plist-mixin) (defgeneric short-combination-identity-with-one-argument (short-method-combination)) ; (short-method-combination) (defgeneric short-combination-operator (short-method-combination)) ; (short-method-combination) (defgeneric slot-definition-boundp-function (effective-slot-definition)) ; (effective-slot-definition) (defgeneric slot-definition-class (slot-definition)) ; (slot-definition) (defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition)) ; (structure-slot-definition) (defgeneric slot-definition-initargs (slot-definition)) ; (slot-definition) (defgeneric slot-definition-initform (slot-definition)) ; (slot-definition) (defgeneric slot-definition-initfunction (slot-definition)) ; (slot-definition) (defgeneric slot-definition-internal-reader-function (structure-slot-definition)) ; (structure-slot-definition) (defgeneric slot-definition-internal-writer-function (structure-slot-definition)) ; (structure-slot-definition) (defgeneric slot-definition-location (standard-effective-slot-definition)) ; (standard-effective-slot-definition) (defgeneric slot-definition-name (slot-definition)) ; (slot-definition) (defgeneric slot-definition-reader-function (effective-slot-definition)) ; (effective-slot-definition) (defgeneric slot-definition-readers (slot-definition)) ; (slot-definition) (defgeneric slot-definition-type (slot-definition)) ; (slot-definition) (defgeneric slot-definition-writer-function (effective-slot-definition)) ; (effective-slot-definition) (defgeneric slot-definition-writers (slot-definition)) ; (slot-definition) (defgeneric specializer-object (class-eq-specializer)) ; (eql-specializer) ; (class-prototype-specializer) ; (class-eq-specializer) (defgeneric specializer-type (specializer)) ; (specializer) ;;; writers (defgeneric (setf class-defstruct-constructor) (new-value structure-class)) ; (t structure-class) (defgeneric (setf class-defstruct-form) (new-value structure-class)) ; (t structure-class) (defgeneric (setf class-direct-slots) (new-value slot-class)) ; (t slot-class) (defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class)) ; (t pcl-class) (defgeneric (setf class-initialize-info) (new-value slot-class)) ; (t slot-class) (defgeneric (setf class-name) (new-value class)) ; (t class) (defgeneric (setf class-slots) (new-value slot-class)) ; (t slot-class) (defgeneric (setf generic-function-method-class) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf generic-function-methods) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf generic-function-name) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf gf-dfun-state) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function)) ; (t standard-generic-function) (defgeneric (setf method-generic-function) (new-value standard-method)) ; (t traced-method) ; (t standard-method) (defgeneric (setf object-plist) (new-value plist-mixin)) ; (t plist-mixin) (defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition)) ; (t standard-slot-definition) (defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition)) ; (t effective-slot-definition) (defgeneric (setf slot-definition-class) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition)) ; (t structure-slot-definition) (defgeneric (setf slot-definition-initargs) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-initform) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-initfunction) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition)) ; (t structure-slot-definition) (defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition)) ; (t structure-slot-definition) (defgeneric (setf slot-definition-location) (new-value standard-effective-slot-definition)) ; (t standard-effective-slot-definition) (defgeneric (setf slot-definition-name) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition)) ; (t effective-slot-definition) (defgeneric (setf slot-definition-readers) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-type) (new-value slot-definition)) ; (t slot-definition) (defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition)) ; (t effective-slot-definition) (defgeneric (setf slot-definition-writers) (new-value slot-definition)) ; (t slot-definition) ;;; 1 argument (defgeneric accessor-method-class (method)) ; (standard-accessor-method) ; (standard-writer-method) (defgeneric accessor-method-slot-name (m)) ; (traced-method) ; (standard-accessor-method) (defgeneric class-constructors (class)) ; (slot-class) (defgeneric class-default-initargs (class)) ; (slot-class) ; (built-in-class) (defgeneric class-direct-default-initargs (class)) ; (slot-class) ; (built-in-class) (defgeneric class-direct-slots (class)) ; (slot-class) ; (built-in-class) (defgeneric class-finalized-p (class)) ; (pcl-class) (defgeneric class-prototype (class)) ; (pcl-class) ; (std-class) ; (structure-class) (defgeneric class-slot-cells (class)) ; (std-class) (defgeneric class-slots (class)) ; (slot-class) ; (built-in-class) (defgeneric compute-class-precedence-list (root)) ; (slot-class) (defgeneric compute-default-initargs (class)) ; (slot-class) (defgeneric compute-discriminating-function (gf)) ; (standard-generic-function) (defgeneric compute-discriminating-function-arglist-info (generic-function)) ; (standard-generic-function) (defgeneric compute-slots (class)) ; (std-class) ; :around (std-class) ; (structure-class) ; :around (structure-class) (defgeneric finalize-inheritance (class)) ; (structure-class) ; (std-class) (defgeneric function-keywords (method)) ; (standard-method) (defgeneric generic-function-lambda-list (gf)) ; (generic-function) (defgeneric generic-function-pretty-arglist (generic-function)) ; (standard-generic-function) (defgeneric gf-fast-method-function-p (gf)) ; (standard-generic-function) (defgeneric initialize-internal-slot-functions (slotd)) ; (effective-slot-definition) (defgeneric make-instances-obsolete (class)) ; (std-class) ; (symbol) (defgeneric method-function (method)) ; (traced-method) ; (standard-method) (defgeneric method-lambda-list (m)) ; (traced-method) ; (standard-method) (defgeneric method-pretty-arglist (method)) ; (standard-method) (defgeneric method-qualifiers (m)) ; (traced-method) ; (standard-method) (defgeneric method-specializers (m)) ; (traced-method) ; (standard-method) (defgeneric raw-instance-allocator (class)) ; (standard-class) ; (funcallable-standard-class) (defgeneric slot-definition-allocation (slotd)) ; (standard-slot-definition) ; (structure-slot-definition) (defgeneric slots-fetcher (class)) ; (standard-class) ; (funcallable-standard-class) (defgeneric specializer-class (specializer)) ; (class-prototype-specializer) ; (class-eq-specializer) ; (class) ; (eql-specializer) (defgeneric specializer-direct-generic-functions (specializer)) ; (class) ; (specializer-with-object) (defgeneric specializer-direct-methods (specializer)) ; (class) ; (specializer-with-object) (defgeneric specializer-method-table (specializer)) ; (eql-specializer) ; (class-eq-specializer) (defgeneric update-constructors (class)) ; (slot-class) ; (class) (defgeneric wrapper-fetcher (class)) ; (standard-class) ; (funcallable-standard-class) ;;; 2 arguments (defgeneric add-dependent (metaobject dependent)) ; (dependent-update-mixin t) (defgeneric add-direct-method (specializer method)) ; (class method) ; (specializer-with-object method) (defgeneric add-direct-subclass (class subclass)) ; (class class) (defgeneric add-method (generic-function method)) ; (standard-generic-function method) (defgeneric change-class (instance new-class-name)) ; (standard-object standard-class) ; (standard-object funcallable-standard-class) ; (t symbol) (defgeneric class-slot-value (class slot-name)) ; (std-class t) (defgeneric compatible-meta-class-change-p (class proto-new-class)) ; (t t) (defgeneric compute-applicable-methods (generic-function arguments)) ; (generic-function t) (defgeneric compute-applicable-methods-using-classes (generic-function classes)) ; (generic-function t) (defgeneric compute-effective-slot-definition (class dslotds)) ; (slot-class t) (defgeneric compute-effective-slot-definition-initargs (class direct-slotds)) ; (slot-class t) ; :around (structure-class t) (defgeneric default-initargs (class supplied-initargs)) ; (slot-class t) (defgeneric describe-object (object stream)) ; (class t) ; (standard-generic-function t) ; (slot-object t) ; (t t) (defgeneric direct-slot-definition-class (class initargs)) ; (structure-class t) ; (std-class t) (defgeneric effective-slot-definition-class (class initargs)) ; (std-class t) ; (structure-class t) (defgeneric inform-type-system-about-class (class name)) ; (std-class t) ; (structure-class t) (defgeneric legal-documentation-p (object x)) ; (standard-method t) (defgeneric legal-method-function-p (object x)) ; (standard-method t) (defgeneric legal-qualifier-p (object x)) ; (standard-method t) (defgeneric legal-qualifiers-p (object x)) ; (standard-method t) (defgeneric legal-slot-name-p (object x)) ; (standard-method t) (defgeneric legal-specializer-p (object x)) ; (standard-method t) (defgeneric legal-specializers-p (object x)) ; (standard-method t) (defgeneric make-boundp-method-function (class slot-name)) ; (slot-class t) (defgeneric make-reader-method-function (class slot-name)) ; (slot-class t) ; (funcallable-standard-class t) (defgeneric make-writer-method-function (class slot-name)) ; (slot-class t) ; (funcallable-standard-class t) (defgeneric map-dependents (metaobject function)) ; (dependent-update-mixin t) ;(defgeneric maybe-update-constructors (generic-function method)) ; (generic-function method) (defgeneric print-object (mc stream)) ; (t t) ; (class t) ; (slot-definition t) ; (standard-method t) ; (standard-accessor-method t) ; (generic-function t) ; (standard-method-combination t) (defgeneric remove-boundp-method (class generic-function)) ; (slot-class t) (defgeneric remove-dependent (metaobject dependent)) ; (dependent-update-mixin t) (defgeneric remove-direct-method (specializer method)) ; (class method) ; (specializer-with-object method) (defgeneric remove-direct-subclass (class subclass)) ; (class class) (defgeneric remove-method (generic-function method)) ; (standard-generic-function method) (defgeneric remove-reader-method (class generic-function)) ; (slot-class t) (defgeneric remove-writer-method (class generic-function)) ; (slot-class t) (defgeneric same-specializer-p (specl1 specl2)) ; (specializer specializer) ; (class class) ; (class-eq-specializer class-eq-specializer) ; (eql-specializer eql-specializer) (defgeneric slot-accessor-function (slotd type)) ; (effective-slot-definition t) (defgeneric slot-accessor-std-p (slotd type)) ; (effective-slot-definition t) (defgeneric slots-to-inspect (class object)) ; (slot-class slot-object) (defgeneric update-gf-dfun (class gf)) ; (std-class t) (defgeneric validate-superclass (fsc class)) ; (class class) ; (class built-in-class) ; (slot-class forward-referenced-class) ; (funcallable-standard-class standard-class) ;;; 3 arguments (defgeneric add-boundp-method (class generic-function slot-name)) ; (slot-class t t) (defgeneric add-reader-method (class generic-function slot-name)) ; (slot-class t t) (defgeneric add-writer-method (class generic-function slot-name)) ; (slot-class t t) (defgeneric (setf class-slot-value) (nv class slot-name)) ; (t std-class t) (defgeneric compute-effective-method (generic-function combin applicable-methods)) ; (generic-function long-method-combination t) ; (generic-function short-method-combination t) ; (generic-function standard-method-combination t) (defgeneric compute-slot-accessor-info (slotd type gf)) ; (effective-slot-definition t t) (defgeneric find-method-combination (generic-function type options)) ; (generic-function (eql progn) t) ; (generic-function (eql or) t) ; (generic-function (eql nconc) t) ; (generic-function (eql min) t) ; (generic-function (eql max) t) ; (generic-function (eql list) t) ; (generic-function (eql append) t) ; (generic-function (eql and) t) ; (generic-function (eql +) t) ; (generic-function (eql standard) t) (defgeneric (setf slot-accessor-function) (function slotd type)) ; (t effective-slot-definition t) (defgeneric (setf slot-accessor-std-p) (value slotd type)) ; (t effective-slot-definition t) (defgeneric slot-boundp-using-class (class object slotd)) ; (std-class standard-object standard-effective-slot-definition) ; (structure-class structure-object structure-effective-slot-definition) (defgeneric slot-makunbound-using-class (class object slotd)) ; (std-class standard-object standard-effective-slot-definition) ; (structure-class structure-object structure-effective-slot-definition) (defgeneric slot-unbound (class instance slot-name)) ; (t t t) (defgeneric slot-value-using-class (class object slotd)) ; (std-class standard-object standard-effective-slot-definition) ; (structure-class structure-object structure-effective-slot-definition) ;;; 4 arguments (defgeneric make-method-lambda (proto-generic-function proto-method lambda-expression environment)) ; (standard-generic-function standard-method t t) (defgeneric (setf slot-value-using-class) (new-value class object slotd)) ; (t std-class standard-object standard-effective-slot-definition) ; (t structure-class structure-object structure-effective-slot-definition) ;;; 5 arguments (defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment)) ; (standard-generic-function standard-method t t t) ;;; optional arguments (defgeneric (setf documentation) (new-value slotd &optional doc-type)) ; (t t) ; (t documentation-mixin) ; (t standard-slot-definition) (defgeneric documentation (slotd &optional doc-type)) ; (t) ; (documentation-mixin) ; (standard-slot-definition) (defgeneric get-method (generic-function qualifiers specializers &optional (errorp t))) ; (standard-generic-function t t) (defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra)) ; (t t) (defgeneric slot-missing (class instance slot-name operation &optional new-value)) ; (t t t t) ;;; keyword arguments (defgeneric allocate-instance (class &rest initargs)) ; (standard-class) ; (structure-class) ; (funcallable-standard-class) (defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys)) ; (t null) ; (t pcl-class) (defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys)) ; (null t) ; (generic-function t) (defgeneric initialize-instance (gf &key &allow-other-keys)) ; (slot-object) ; :after (standard-generic-function) (defgeneric make-instance (class &rest initargs)) ; (symbol) ; (class) (defgeneric no-applicable-method (generic-function &rest args)) ; (t) (defgeneric reader-method-class (class direct-slot &rest initargs)) ; (slot-class t) (defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys)) ; (slot-object) ; :before (slot-class) ; :after (slot-class) ; (standard-method) ; :after (standard-generic-function) (defgeneric shared-initialize (generic-function slot-names &key &allow-other-keys)) ; (slot-object t) ; :after (documentation-mixin t) ; :after (class-eq-specializer t) ; :after (eql-specializer t) ; :after (std-class t) ; :before (class t) ; :after (structure-class t) ; :before (built-in-class t) ; :after (standard-slot-definition t) ; :after (structure-slot-definition t) ; :before (standard-method t) ; :before (standard-accessor-method t) ; :after (standard-method t) ; :after (standard-accessor-method t) ; :before (standard-generic-function t) (defgeneric update-dependent (metaobject dependent &rest initargs)) (defgeneric update-instance-for-different-class (previous current &rest initargs)) ; (standard-object standard-object) (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs)) ; (standard-object t t t) (defgeneric writer-method-class (class direct-slot &rest initargs)) ; (slot-class t) gcl-2.6.14/pcl/defsys.lisp0000644000175000017500000011136014360276512013741 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a ;;; while. At least until people really get databases and stuff. ;;; ;;; *** *** ;;; *** DIRECTIONS FOR INSTALLING PCL AT YOUR SITE *** ;;; *** *** ;;; ;;; To get PCL working at your site you should: ;;; ;;; - Get all the PCL source files from Xerox. The complete list of source ;;; file names can be found in the defsystem for PCL which appears towards ;;; the end of this file. ;;; ;;; - Edit the variable *pcl-directory* below to specify the directory at ;;; your site where the pcl sources and binaries will be. This variable ;;; can be found by searching from this point for the string "***" in ;;; this file. ;;; ;;; - Use the function (pcl::compile-pcl) to compile PCL for your site. ;;; ;;; - Once PCL has been compiled it can be loaded with (pcl::load-pcl). ;;; Note that PCL cannot be loaded on top of itself, nor can it be ;;; loaded into the same world it was compiled in. ;;; (in-package :user) (load "package.lisp") (eval-when (compile load eval) (export (intern (symbol-name :iterate) ;Have to do this here, (find-package :iterate)) ;because in the defsystem (find-package :iterate)) ;(later in this file) ;we use the symbol iterate ;to name the file ) (in-package :pcl) ;;; ;;; Sure, its weird for this to be here, but in order to follow the rules ;;; about order of export and all that stuff, we can't put it in PKG before ;;; we want to use it. ;;; (defvar *the-pcl-package* (find-package :pcl)) (defvar *pcl-system-date* "September 16 92 PCL (g)") (eval-when (compile load eval) (defvar *pcl-proclaim* '(optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0))) ) #-cmu ; see pclcom.lisp (proclaim *pcl-proclaim*) #+cmu (setf (getf ext:*herald-items* :pcl) `(" CLOS based on PCL version: " ,*pcl-system-date*)) ;;; ;;; Various hacks to get people's *features* into better shape. ;;; (eval-when (compile load eval) #+(and Symbolics Lispm) (multiple-value-bind (major minor) (sct:get-release-version) (etypecase minor (integer) (string (setf minor (parse-integer minor :junk-allowed t)))) (pushnew :genera *features*) (ecase major ((6) (pushnew :genera-release-6 *features*)) ((7) (pushnew :genera-release-7 *features*) (pushnew :copy-&rest-arg *features*) (ecase minor ((0 1) (pushnew :genera-release-7-1 *features*)) ((2) (pushnew :genera-release-7-2 *features*)) ((3) (pushnew :genera-release-7-3 *features*)) ((4) (pushnew :genera-release-7-4 *features*)))) ((8) (pushnew :genera-release-8 *features*) (ecase minor ((0) (pushnew :genera-release-8-0 *features*)) ((1) (pushnew :genera-release-8-1 *features*)))))) #+CLOE-Runtime (let ((version (lisp-implementation-version))) (when (string-equal version "2.0" :end1 (min 3 (length version))) (pushnew :cloe-release-2 *features*))) (dolist (feature *features*) (when (and (symbolp feature) ;3600!! (equal (symbol-name feature) "CMU")) (pushnew :CMU *features*))) #+TI (if (eq (si:local-binary-file-type) :xld) (pushnew ':ti-release-3 *features*) (pushnew ':ti-release-2 *features*)) #+Lucid (when (search "IBM RT PC" (machine-type)) (pushnew :ibm-rt-pc *features*)) #+ExCL (cond ((search "sun3" (lisp-implementation-version)) (push :sun3 *features*)) ((search "sun4" (lisp-implementation-version)) (push :sun4 *features*))) #+(and HP Lucid) (push :HP-Lucid *features*) #+(and HP (not Lucid) (not excl)) (push :HP-HPLabs *features*) #+Xerox (case il:makesysname (:lyric (push :Xerox-Lyric *features*)) (otherwise (push :Xerox-Medley *features*))) ;;; ;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features* ;;; if you have installed turbo-closure patch. See the file kcl-mods.text ;;; for details. ;;; ;;; The xkcl version of KCL has this fixed already. ;;; #+xkcl(pushnew :turbo-closure *features*) ) #+(and excl sun4) (eval-when (eval compile load) (pushnew :excl-sun4 *features*)) ;;; Yet Another Sort Of General System Facility and friends. ;;; ;;; The entry points are defsystem and operate-on-system. defsystem is used ;;; to define a new system and the files with their load/compile constraints. ;;; Operate-on-system is used to operate on a system defined that has been ;;; defined by defsystem. For example: #|| (defsystem my-very-own-system "/usr/myname/lisp/" ((classes (precom) () ()) (methods (precom classes) (classes) ()) (precom () (classes methods) (classes methods)))) This defsystem should be read as follows: * Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries should be in the directory "/usr/me/lisp/". There are three files in the system, there are named classes, methods and precom. (The extension the filenames have depends on the lisp you are running in.) * For the first file, classes, the (precom) in the line means that the file precom should be loaded before this file is loaded. The first () means that no other files need to be loaded before this file is compiled. The second () means that changes in other files don't force this file to be recompiled. * For the second file, methods, the (precom classes) means that both of the files precom and classes must be loaded before this file can be loaded. The (classes) means that the file classes must be loaded before this file can be compiled. The () means that changes in other files don't force this file to be recompiled. * For the third file, precom, the first () means that no other files need to be loaded before this file is loaded. The first use of (classes methods) means that both classes and methods must be loaded before this file can be compiled. The second use of (classes methods) mean that whenever either classes or methods changes precom must be recompiled. Then you can compile your system with: (operate-on-system 'my-very-own-system :compile) and load your system with: (operate-on-system 'my-very-own-system :load) ||# ;;; (defvar *system-directory*) ;;; ;;; *port* is a list of symbols (in the PCL package) which represent the ;;; Common Lisp in which we are now running. Many of the facilities in ;;; defsys use the value of *port* rather than #+ and #- to conditionalize ;;; the way they work. ;;; (defparameter *port+dname-list* (mapcar #'(lambda (x) (cons (if (consp x) (car x) x) (string-downcase (if (consp x) (cadr x) x)))) '(#+Genera (Genera symbolics) ; #+Genera-Release-6 (Rel-6 symbolics) ; #+Genera-Release-7-1 (Rel-7 symbolics) #+Genera-Release-7-2 (Rel-7 symbolics) #+Genera-Release-7-3 (Rel-7 symbolics) #+Genera-Release-7-1 (Rel-7-1 symbolics) #+Genera-Release-7-2 (Rel-7-2 symbolics) #+Genera-Release-7-3 (Rel-7-2 symbolics) ;OK for now #+Genera-Release-7-4 (Rel-7-2 symbolics) ;OK for now #+Genera-Release-8 (Rel-8 symbolics) #+imach (Ivory symbolics) #+Cloe-Runtime (Cloe symbolics) #+Lucid Lucid #+Xerox Xerox #+Xerox-Lyric (Xerox-Lyric xerox) #+Xerox-Medley (Xerox-Medley xerox) #+TI TI #+(and dec vax common) Vaxlisp #+IBCL IBCL #+gcl gcl #+excl (excl franz) #+(and excl sun4) (excl-sun4 franz) #+:CMU CMU #+HP-HPLabs (HP-HPLabs hp) #+:gclisp (gclisp gold-hill) #+pyramid pyramid #+:coral coral))) (defparameter *port* (mapcar #'car *port+dname-list*)) (defparameter *put-impl-binaries-in-impl-directory-p* nil) ;;; ;;; When you get a copy of PCL (by tape or by FTP), the sources files will ;;; have extensions of ".lisp" in particular, this file will be defsys.lisp. ;;; The preferred way to install pcl is to rename these files to have the ;;; extension which your lisp likes to use for its files. Alternately, it ;;; is possible not to rename the files. See below. ;;; ;;; Note: Something people installing PCL on a machine running Unix ;;; might find useful. If you want to change the extensions ;;; of the source files from ".lisp" to ".lsp", *all* you have ;;; to do is the following: ;;; ;;; % foreach i (*.lisp) ;;; ? mv $i $i:r.lsp ;;; ? end ;;; % ;;; ;;; I am sure that a lot of people already know that, and some ;;; Unix hackers may say, "jeez who doesn't know that". Those ;;; same Unix hackers are invited to fix mv so that I can type ;;; "mv *.lisp *.lsp". ;;; (defvar *default-pathname-extensions* (car '(#+(and (not imach) genera) ("lisp" . "bin") #+(and imach genera) ("lisp" . "ibin") #+Cloe-Runtime ("l" . "fasl") #+(and dec common vax (not ultrix)) ("LSP" . "FAS") #+(and dec common vax ultrix) ("lsp" . "fas") #+IBCL ("lsp" . "o") #+Xerox ("lisp" . "dfasl") #+(and Lucid MC68000) ("lisp" . "lbin") #+(and Lucid VAX) ("lisp" . "vbin") #+(and Lucid Prime) ("lisp" . "pbin") #+(and Lucid SUNRise) ("lisp" . "sbin") #+(and Lucid SPARC) ("lisp" . "sbin") #+(and Lucid IBM-RT-PC) ("lisp" . "bbin") #+(and Lucid MIPS) ("lisp" . "mbin") #+(and Lucid PRISM) ("lisp" . "abin") #+(and Lucid PA) ("lisp" . "hbin") #+(and excl SPARC) ("cl" . "sparc") #+(and excl m68k) ("cl" . "m68k") #+excl ("cl" . "fasl") #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*)) #+HP-HPLabs ("l" . "b") #+TI ("lisp" . #.(string (si::local-binary-file-type))) #+:gclisp ("LSP" . "F2S") #+pyramid ("clisp" . "o") #+:coral ("lisp" . "fasl") #-(or symbolics (and dec common vax) KCL IBCL Xerox lucid excl :CMU HP TI :gclisp pyramid coral) ("lisp" . "lbin")))) ;;; Note: In previous versions of PCL, the defvar for *pathname-extensions* ;;; assumed that files WERE renamed, (files-renamed-p was bound to t). ;;; Now, this defvar assumes that the files are not renamed, unless the ;;; symbol :pcl-files-renamed-p is put on the *features* list. #| ; Remove this line if you have renamed the PCL source files. (eval-when (compile load eval) (pushnew :pcl-files-renamed-p *features*)) |# ; Remove this line if you have renamed the PCL source files. (defvar *pathname-extensions* (let ((proper-extensions (or *default-pathname-extensions* '("lisp" . "lbin")))) #+pcl-files-renamed-p proper-extensions #-pcl-files-renamed-p (cons "lisp" (cdr proper-extensions)))) (eval-when (compile load eval) (defun get-system (name) (get name 'system-definition)) (defun set-system (name new-value) (setf (get name 'system-definition) new-value)) (defmacro defsystem (name directory files) `(set-system ',name (list #'(lambda () ,directory) (make-modules ',files) ',(mapcar #'car files)))) ) ;;; ;;; The internal datastructure used when operating on a system. ;;; (defstruct (module (:constructor make-module (name)) (:print-function (lambda (m s d) (declare (ignore d)) (format s "#" (module-name m))))) name load-env comp-env recomp-reasons port) (defun make-modules (system-description) (let ((modules ())) (labels ((get-module (name) (or (find name modules :key #'module-name) (progn (setq modules (cons (make-module name) modules)) (car modules)))) (parse-spec (spec) (if (eq spec 't) (reverse (cdr modules)) (case (car spec) (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec)))) (- (let ((rem (mapcar #'get-module (cdr spec)))) (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules))))) (otherwise (mapcar #'get-module spec)))))) (dolist (file system-description) (let* ((name (car file)) (port (car (cddddr file))) (module nil)) (when (or (null port) (member port *port*)) (setq module (get-module name)) (setf (module-load-env module) (parse-spec (cadr file)) (module-comp-env module) (parse-spec (caddr file)) (module-recomp-reasons module) (parse-spec (cadddr file)) (module-port module) port)))) (let ((filenames (mapcar #'car system-description))) (sort modules #'(lambda (name1 name2) (member name2 (member name1 filenames))) :key #'module-name))))) (defun make-transformations (modules filter make-transform) (declare (type function filter make-transform)) (let ((transforms (list nil))) (dolist (m modules) (when (funcall filter m transforms) (funcall make-transform m transforms))) (reverse (cdr transforms)))) (defun make-compile-transformation (module transforms) (unless (dolist (trans transforms) (and (eq (car trans) ':compile) (eq (cadr trans) module) (return t))) (dolist (c (module-comp-env module)) (make-load-transformation c transforms)) (setf (cdr transforms) (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module))) (cdr transforms))) (push `(:compile ,module) (cdr transforms)))) (defvar *being-loaded* ()) (defun make-load-transformation (module transforms) (if (assoc module *being-loaded*) (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*)))) (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*))) (catch module (unless (dolist (trans transforms) (when (and (eq (car trans) ':load) (eq (cadr trans) module)) (return t))) (dolist (l (module-load-env module)) (make-load-transformation l transforms)) (push `(:load ,module) (cdr transforms))))))) (defun make-load-without-dependencies-transformation (module transforms) (unless (dolist (trans transforms) (and (eq (car trans) ':load) (eq (cadr trans) module) (return trans))) (push `(:load ,module) (cdr transforms)))) (defun compile-filter (module transforms) (or (dolist (r (module-recomp-reasons module)) (when (dolist (transform transforms) (when (and (eq (car transform) ':compile) (eq (cadr transform) r)) (return t))) (return t))) (null (probe-file (make-binary-pathname module))) (> (file-write-date (make-source-pathname module)) (file-write-date (make-binary-pathname module))))) (defun operation-transformations (name mode &optional arg) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) (let ((*system-directory* (funcall (the function (car system)))) (modules (cadr system))) (ecase mode (:compile ;; Compile any files that have changed and any other files ;; that require recompilation when another file has been ;; recompiled. (make-transformations modules #'compile-filter #'make-compile-transformation)) (:recompile ;; Force recompilation of all files. (make-transformations modules #'true #'make-compile-transformation)) (:recompile-some ;; Force recompilation of some files. Also compile the ;; files that require recompilation when another file has ;; been recompiled. (make-transformations modules #'(lambda (m transforms) (or (member (module-name m) arg) (compile-filter m transforms))) #'make-compile-transformation)) (:query-compile ;; Ask the user which files to compile. Compile those ;; and any other files which must be recompiled when ;; another file has been recompiled. (make-transformations modules #'(lambda (m transforms) (or (compile-filter m transforms) (y-or-n-p "Compile ~A?" (module-name m)))) #'make-compile-transformation)) (:confirm-compile ;; Offer the user a chance to prevent a file from being ;; recompiled. (make-transformations modules #'(lambda (m transforms) (and (compile-filter m transforms) (y-or-n-p "Go ahead and compile ~A?" (module-name m)))) #'make-compile-transformation)) (:load ;; Load the whole system. (make-transformations modules #'true #'make-load-transformation)) (:query-load ;; Load only those files the user says to load. (make-transformations modules #'(lambda (m transforms) (declare (ignore transforms)) (y-or-n-p "Load ~A?" (module-name m))) #'make-load-without-dependencies-transformation)))))) (defun true (&rest ignore) (declare (ignore ignore)) 't) #+cmu17 (defparameter *byte-files* '(defclass defcombin iterate env)) (defun operate-on-system (name mode &optional arg print-only) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) (let* ((*system-directory* (funcall (the function (car system)))) (transformations (operation-transformations name mode arg))) (labels ((load-binary (name pathname) (format t "~&Loading binary of ~A...~%" name) (or print-only (load pathname))) (load-module (m) (let* ((name (module-name m)) (*load-verbose* t) (binary (make-binary-pathname m))) (load-binary name binary))) (compile-module (m) (format t "~&Compiling ~A...~%" (module-name m)) (unless print-only (compile-file (make-source-pathname m) :output-file (make-pathname :defaults (make-binary-pathname m) :version :newest) #+cmu17 :byte-compile #+cmu17 (if (and (member (module-name m) *byte-files*) (member :small *features*)) t :maybe))))) (#+Genera compiler:compiler-warnings-context-bind #+TI COMPILER:COMPILER-WARNINGS-CONTEXT-BIND #+:LCL3.0 lucid-common-lisp:with-deferred-warnings #+cmu with-compilation-unit #+cmu () #-(or Genera TI :LCL3.0 cmu) progn (loop (when (null transformations) (return t)) (let ((transform (pop transformations))) (ecase (car transform) (:compile (compile-module (cadr transform))) (:load (load-module (cadr transform))))))))))) (defun make-source-pathname (name) (make-pathname-internal name :source)) (defun make-binary-pathname (name) (make-pathname-internal name :binary)) (defun make-pathname-internal (name-or-module type) (let* ((name (if (module-p name-or-module) (module-name name-or-module) name-or-module)) (port (if (module-p name-or-module) (module-port name-or-module) nil)) (extension (ecase type (:source (car *pathname-extensions*)) (:binary (cdr *pathname-extensions*)))) (directory (pathname (etypecase *system-directory* (string *system-directory*) (pathname *system-directory*) (cons (ecase type (:source (car *system-directory*)) (:binary (cdr *system-directory*))))))) (dir (pathname-directory directory)) (ldir (if (consp dir) dir (pathname-directory (truename directory)))) (port-dname (when (and port (or *put-impl-binaries-in-impl-directory-p* (eq type ':source))) (cdr (assoc port *port+dname-list*)))) (port-directory (if port-dname (append ldir (list "impl" port-dname)) ldir)) (pathname (make-pathname :name (string-downcase (string name)) :type extension :directory port-directory :defaults directory))) #+Genera (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname)) pathname (zl:send pathname :new-raw-type (pathname-type pathname))) pathname)) (defun system-source-files (name) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) (let ((*system-directory* (funcall (the function (car system)))) (modules (cadr system))) (mapcar #'make-source-pathname modules)))) (defun system-binary-files (name) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) (let ((*system-directory* (funcall (the function (car system)))) (modules (cadr system))) (mapcar #'make-binary-pathname modules)))) ;;; *** SITE SPECIFIC PCL DIRECTORY *** ;;; ;;; *pcl-directory* is a variable which specifies the directory pcl is stored ;;; in at your site. If the value of the variable is a single pathname, the ;;; sources and binaries should be stored in that directory. If the value of ;;; that directory is a cons, the CAR should be the source directory and the ;;; CDR should be the binary directory. ;;; ;;; By default, the value of *pcl-directory* is set to the directory that ;;; this file is loaded from. This makes it simple to keep multiple copies ;;; of PCL in different places, just load defsys from the same directory as ;;; the copy of PCL you want to use. ;;; ;;; Note that the value of *PCL-DIRECTORY* is set using a DEFVAR. This is ;;; done to make it possible for users to set it in their init file and then ;;; load this file. The value set in the init file will override the value ;;; here. ;;; ;;; *** *** (defun load-truename (&optional (errorp nil)) #+cmu (declare (ignore errorp)) (flet (#+(or Lispm Xerox LUCID) (bad-time () (when errorp (error "LOAD-TRUENAME called but a file isn't being loaded.")))) #+Lispm (or sys:fdefine-file-pathname (bad-time)) #+excl excl::*source-pathname* #+Xerox (pathname (or (il:fullname *standard-input*) (bad-time))) #+(and dec vax common) (truename (sys::source-file #'load-truename)) ;; ;; The following use of `lucid::' is a kludge for 2.1 and 3.0 ;; compatibility. In 2.1 it was in the SYSTEM package, and i ;; 3.0 it's in the LUCID-COMMON-LISP package. ;; #+LUCID (or lucid::*source-pathname* (bad-time)) #+akcl *load-pathname* #+cmu17 *load-truename* #-(or Lispm excl Xerox (and dec vax common) LUCID akcl cmu17) nil)) #-(or cmu Symbolics) (defvar *pcl-directory* (concatenate 'string user::*system-directory* "../pcl/")) ; (or (load-truename t) ; (error "Because load-truename is not implemented in this port~%~ ; of PCL, you must manually edit the definition of the~%~ ; variable *pcl-directory* in the file defsys.lisp."))) #+cmu (defvar *pcl-directory* (pathname "target:pcl/")) #+Genera (defvar *pcl-directory* (let ((source (load-truename t))) (flet ((subdir (name) (scl:send source :new-pathname :raw-directory (append (scl:send source :raw-directory) (list name))))) (cons source #+genera-release-7-2 (subdir "rel-7-2") #+genera-release-7-3 (subdir "rel-7-3") #+genera-release-7-4 (subdir "rel-7-4") #+genera-release-8-0 (subdir "rel-8-0") #+genera-release-8-1 (subdir "rel-8-1") )))) #+Cloe-Runtime (defvar *pcl-directory* (pathname "/usr3/hornig/pcl/")) (defsystem pcl *pcl-directory* ;; ;; file load compile files which port ;; environment environment force the of ;; recompilation ;; of this file ;; ( ; (rel-6-patches t t () rel-6) ; (rel-7-1-patches t t () rel-7-1) (rel-7-2-patches t t () rel-7-2) (rel-8-patches t t () rel-8) (ti-patches t t () ti) (pyr-patches t t () pyramid) (xerox-patches t t () xerox) (kcl-patches t t () kcl) (ibcl-patches t t () ibcl) (gold-patches t t () gclisp) (gcl_pcl_pkg t t ()) (sys-proclaim t t () kcl) (gcl_pcl_walk (gcl_pcl_pkg) (gcl_pcl_pkg) ()) (gcl_pcl_iterate t t ()) (gcl_pcl_macros t t ()) (gcl_pcl_low (gcl_pcl_pkg gcl_pcl_macros) t (gcl_pcl_macros)) (genera-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Genera) (cloe-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Cloe) (lucid-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Lucid) (Xerox-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Xerox) (ti-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) TI) (vaxl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) vaxlisp) (kcl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) KCL) (ibcl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) IBCL) (gcl_pcl_impl_low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) gcl) (excl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) excl) (cmu-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) CMU) (hp-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) HP-HPLabs) (gold-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) gclisp) (pyr-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) pyramid) (coral-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) coral) (gcl_pcl_fin t t (gcl_pcl_low)) (gcl_pcl_defclass t t (gcl_pcl_low)) (gcl_pcl_defs t t (gcl_pcl_defclass gcl_pcl_macros gcl_pcl_iterate)) (gcl_pcl_fngen t t (gcl_pcl_low)) (gcl_pcl_cache t t (gcl_pcl_low gcl_pcl_defs)) (gcl_pcl_dlisp t t (gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) (gcl_pcl_dlisp2 t t (gcl_pcl_low gcl_pcl_fin gcl_pcl_cache gcl_pcl_dlisp)) (gcl_pcl_boot t t (gcl_pcl_defs gcl_pcl_fin)) (gcl_pcl_vector t t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_cache gcl_pcl_fin)) (gcl_pcl_slots_boot t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_cache gcl_pcl_fin)) (gcl_pcl_combin t t (gcl_pcl_boot gcl_pcl_defs)) (gcl_pcl_dfun t t (gcl_pcl_boot gcl_pcl_low gcl_pcl_cache)) (gcl_pcl_fast_init t t (gcl_pcl_boot gcl_pcl_low)) (gcl_pcl_braid (+ gcl_pcl_precom1 gcl_pcl_precom2) t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) (gcl_pcl_generic_functions t t (gcl_pcl_boot)) (gcl_pcl_slots t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin)) (gcl_pcl_init t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fast_init)) (gcl_pcl_std_class t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_slots)) (gcl_pcl_cpl t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_slots)) (gcl_pcl_fsc t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) (gcl_pcl_methods t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) (gcl_pcl_fixup t t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) (gcl_pcl_defcombin t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) (gcl_pcl_ctypes t t (gcl_pcl_defclass gcl_pcl_defcombin)) (gcl_pcl_env t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) (gcl_pcl_compat t t ()) (gcl_pcl_precom1 (gcl_pcl_dlisp) t (gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_dfun)) (gcl_pcl_precom2 (gcl_pcl_dlisp) t (gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_dfun)) )) (defun compile-pcl (&optional m) (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) #+Lucid (lcl:*redefinition-action* nil) #+excl (excl::*redefinition-warnings* nil) #+Genera (sys:inhibit-fdefine-warnings t) ) (cond ((null m) (operate-on-system 'pcl :compile)) ((eq m :print) (operate-on-system 'pcl :compile () t)) ((eq m :query) (operate-on-system 'pcl :query-compile)) ((eq m :confirm) (operate-on-system 'pcl :confirm-compile)) ((eq m 't) (operate-on-system 'pcl :recompile)) ((listp m) (operate-on-system 'pcl :compile-from m)) ((symbolp m) (operate-on-system 'pcl :recompile-some `(,m)))))) (defun load-pcl (&optional m) (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) #+Lucid (lcl:*redefinition-action* nil) #+excl (excl::*redefinition-warnings* nil) #+Genera (sys:inhibit-fdefine-warnings t) ) (cond ((null m) (operate-on-system 'pcl :load)) ((eq m :query) (operate-on-system 'pcl :query-load))))) #+Genera ;;; Make sure Genera bug mail contains the PCL bug data. A little ;;; kludgy, but what the heck. If they didn't mean for people to do ;;; this, they wouldn't have made private patch notes be flavored ;;; objects, right? Right. (progn (scl:defflavor pcl-private-patch-info ((description)) ()) (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) () (or description (setf description (string-append "PCL version: " *pcl-system-date*)))) (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) () *pcl-directory*) (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info)) sct::*private-patch-info*) (push (scl:make-instance 'pcl-private-patch-info) sct::*private-patch-info*))) (defun bug-report-info (&optional (stream *standard-output*)) (format stream "~&PCL system date: ~A~ ~&Lisp Implementation type: ~A~ ~&Lisp Implementation version: ~A~ ~&*features*: ~S" *pcl-system-date* (lisp-implementation-type) (lisp-implementation-version) *features*)) ;;;; ;;; ;;; This stuff is not intended for external use. ;;; (defun rename-pcl () (dolist (f (cadr (get-system 'pcl))) (let ((old nil) (new nil)) (let ((*system-directory* *default-pathname-defaults*)) (setq old (make-source-pathname (car f)))) (setq new (make-source-pathname (car f))) (rename-file old new)))) #+Genera (defun edit-pcl () (dolist (f (cadr (get-system 'pcl))) (let ((*system-directory* *pcl-directory*)) (zwei:find-file (make-source-pathname (car f)))))) #+Genera (defun hardcopy-pcl (&optional query-p) (let ((files (mapcar #'(lambda (f) (setq f (car f)) (and (or (not query-p) (y-or-n-p "~A? " f)) f)) (cadr (get-system 'pcl)))) (b zwei:*interval*)) (unwind-protect (dolist (f files) (when f (multiple-value-bind (ignore b) (zwei:find-file (make-source-pathname f)) (zwei:hardcopy-buffer b)))) (zwei:make-buffer-current b)))) ;;; ;;; unido!ztivax!dae@seismo.css.gov ;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet ;;; Victor@carmen.uu.se ;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET ;;; #+Genera (defun mail-pcl (to) (let* ((original-buffer zwei:*interval*) (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/") ;(funcall (car (get-system 'pcl))) ) (files (list* 'defsys 'test (caddr (get-system 'pcl)))) (total-number (length files)) (file nil) (number-of-lines 0) (i 0) (mail-buffer nil)) (unwind-protect (loop (when (null files) (return nil)) (setq file (pop files)) (incf i) (multiple-value-bind (ignore b) (zwei:find-file (make-source-pathname file)) (setq number-of-lines (zwei:count-lines b)) (zwei:com-mail-internal t :initial-to to :initial-body b :initial-subject (format nil "PCL file ~A (~A of ~A) ~D lines" file i total-number number-of-lines)) (setq mail-buffer zwei:*interval*) (zwei:com-exit-com-mail) (format t "~&Just sent ~A (~A of ~A)." b i total-number) (zwei:kill-buffer mail-buffer))) (zwei:make-buffer-current original-buffer)))) (defun reset-pcl-package () ; Try to do this safely (let* ((vars '(*pcl-directory* *default-pathname-extensions* *pathname-extensions* *redefined-functions*)) (names (mapcar #'symbol-name vars)) (values (mapcar #'symbol-value vars))) (declare (special *redefined-functions*)) (reset-package "PCL") (let ((pkg (find-package "SLOT-ACCESSOR-NAME"))) (when pkg (do-symbols (sym pkg) (makunbound sym) (fmakunbound sym) (setf (symbol-plist sym) nil)))) (let ((pcl (find-package "PCL"))) (mapcar #'(lambda (name value) (let ((var (intern name pcl))) (proclaim `(special ,var)) (set var value))) names values)) (dolist (sym *redefined-functions*) (setf (symbol-function sym) (get sym 'definition-before-pcl))) nil)) (defun reset-package (&optional (package-name "PCL")) (let ((pkg (find-package package-name))) (do-symbols (sym pkg) (when (eq pkg (symbol-package sym)) (if (or (constantp sym) #-cmu (member sym '(wrapper cache arg-info pv-table)) #+cmu (or (c::info setf inverse sym) (c::info setf expander sym) (c::info type kind sym) (c::info function macro-function sym) (c::info function compiler-macro-function sym))) (unintern sym pkg) (progn (makunbound sym) (unless (or (eq sym 'reset-pcl-package) (eq sym 'reset-package)) (fmakunbound sym) #+cmu (fmakunbound `(setf ,sym))) (setf (symbol-plist sym) nil))))))) gcl-2.6.14/pcl/gcl_pcl_env.lisp0000644000175000017500000003226714360276512014727 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Basic environmental stuff. ;;; (in-package :pcl) #+Lucid (progn (defun pcl-arglist (function &rest other-args) (let ((defn nil)) (cond ((and (fsc-instance-p function) (generic-function-p function)) (generic-function-pretty-arglist function)) ((and (symbolp function) (fboundp function) (setq defn (symbol-function function)) (fsc-instance-p defn) (generic-function-p defn)) (generic-function-pretty-arglist defn)) (t (apply (original-definition 'sys::arglist) function other-args))))) (redefine-function 'sys::arglist 'pcl-arglist) ) ;;; ;;; ;;; (defgeneric describe-object (object stream)) #-Genera (progn (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints) (let (#+Lispm (*describe-no-complaints* no-complaints)) #+Lispm (declare (special *describe-no-complaints*)) (describe-object object *standard-output*) (values))) (defmethod describe-object (object stream) #-cmu (cond ((or #+kcl (packagep object)) (describe-package object stream)) (t (funcall (original-definition 'describe) object))) #+cmu (describe object stream)) #-cmu (redefine-function 'describe 'pcl-describe) ) (defmethod describe-object ((object slot-object) stream) (let* ((class (class-of object)) (slotds (slots-to-inspect class object)) (max-slot-name-length 0) (instance-slotds ()) (class-slotds ()) (other-slotds ())) (flet ((adjust-slot-name-length (name) (setq max-slot-name-length (max max-slot-name-length (length (the string (symbol-name name)))))) (describe-slot (name value &optional (allocation () alloc-p)) (if alloc-p (format stream "~% ~A ~S ~VT ~S" name allocation (+ max-slot-name-length 7) value) (format stream "~% ~A~VT ~S" name max-slot-name-length value)))) ;; Figure out a good width for the slot-name column. (dolist (slotd slotds) (adjust-slot-name-length (slot-definition-name slotd)) (case (slot-definition-allocation slotd) (:instance (push slotd instance-slotds)) (:class (push slotd class-slotds)) (otherwise (push slotd other-slotds)))) (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) (format stream "~%~S is an instance of class ~S:" object class) (when instance-slotds (format stream "~% The following slots have :INSTANCE allocation:") (dolist (slotd (nreverse instance-slotds)) (describe-slot (slot-definition-name slotd) (slot-value-or-default object (slot-definition-name slotd))))) (when class-slotds (format stream "~% The following slots have :CLASS allocation:") (dolist (slotd (nreverse class-slotds)) (describe-slot (slot-definition-name slotd) (slot-value-or-default object (slot-definition-name slotd))))) (when other-slotds (format stream "~% The following slots have allocation as shown:") (dolist (slotd (nreverse other-slotds)) (describe-slot (slot-definition-name slotd) (slot-value-or-default object (slot-definition-name slotd)) (slot-definition-allocation slotd)))) (values)))) (defmethod slots-to-inspect ((class slot-class) (object slot-object)) (class-slots class)) (defvar *describe-metaobjects-as-objects-p* nil) (defmethod describe-object ((fun standard-generic-function) stream) (format stream "~A is a generic function.~%" fun) (format stream "Its arguments are:~% ~S~%" (generic-function-pretty-arglist fun)) (format stream "Its methods are:") (dolist (meth (generic-function-methods fun)) (format stream "~2% ~{~S ~}~:S =>~%" (method-qualifiers meth) (unparse-specializers meth)) (describe-object (or (method-fast-function meth) (method-function meth)) stream)) (when *describe-metaobjects-as-objects-p* (call-next-method))) ;;; ;;; ;;; (defmethod describe-object ((class class) stream) (flet ((pretty-class (c) (or (class-name c) c))) (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) (ft "~&~S is a class, it is an instance of ~S.~%" class (pretty-class (class-of class))) (let ((name (class-name class))) (if name (if (eq class (find-class name nil)) (ft "Its proper name is ~S.~%" name) (ft "Its name is ~S, but this is not a proper name.~%" name)) (ft "It has no name (the name is NIL).~%"))) (ft "The direct superclasses are: ~:S, and the direct~%~ subclasses are: ~:S. The class precedence list is:~%~S~%~ There are ~D methods specialized for this class." (mapcar #'pretty-class (class-direct-superclasses class)) (mapcar #'pretty-class (class-direct-subclasses class)) (mapcar #'pretty-class (class-precedence-list class)) (length (specializer-direct-methods class))))) (when *describe-metaobjects-as-objects-p* (call-next-method))) (defun describe-package (object stream) (unless (packagep object) (setq object (find-package object))) (format stream "~&~S is a ~S.~%" object (type-of object)) (let ((nick (package-nicknames object))) (when nick (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%" (butlast nick) (first (last nick))))) (let* (#+cmu (internal (lisp::package-internal-symbols object)) (internal-count #+cmu (- (lisp::package-hashtable-size internal) (lisp::package-hashtable-free internal)) #-cmu 0) #+cmu (external (lisp::package-external-symbols object)) (external-count #+cmu (- (lisp::package-hashtable-size external) (lisp::package-hashtable-free external)) #-cmu 0)) #-cmu (do-external-symbols (sym object) (declare (ignore sym)) (incf external-count)) #-cmu (do-symbols (sym object) (declare (ignore sym)) (incf internal-count)) #-cmu (decf internal-count external-count) (format stream "It has ~D internal and ~D external symbols (~D total).~%" internal-count external-count (+ internal-count external-count))) (let ((used (package-use-list object))) (when used (format stream "It uses the packages ~{~S~^, ~}.~%" (mapcar #'package-name used)))) (let ((users (package-use-list object))) (when users (format stream "It is used by the packages ~{~S~^, ~}.~%" (mapcar #'package-name users))))) #+cmu (defmethod describe-object ((object package) stream) (describe-package object stream)) #+cmu (defmethod describe-object ((object hash-table) stream) (format stream "~&~S is an ~a hash table." object #-cmu17 (lisp::hash-table-kind object) #+cmu17 (lisp::hash-table-test object)) (format stream "~&Its size is ~d buckets." (lisp::hash-table-size object)) (format stream "~&Its rehash-size is ~d." (lisp::hash-table-rehash-size object)) (format stream "~&Its rehash-threshold is ~d." (hash-table-rehash-threshold object)) (format stream "~&It currently holds ~d entries." (lisp::hash-table-number-entries object))) ;;; ;;; trace-method and untrace-method accept method specs as arguments. A ;;; method-spec should be a list like: ;;; ( qualifiers* (specializers*)) ;;; where should be either a symbol or a list ;;; of (SETF ). ;;; ;;; For example, to trace the method defined by: ;;; ;;; (defmethod foo ((x spaceship)) 'ss) ;;; ;;; You should say: ;;; ;;; (trace-method '(foo (spaceship))) ;;; ;;; You can also provide a method object in the place of the method ;;; spec, in which case that method object will be traced. ;;; ;;; For untrace-method, if an argument is given, that method is untraced. ;;; If no argument is given, all traced methods are untraced. ;;; (defclass traced-method (method) ((method :initarg :method) (function :initarg :function :reader method-function) (generic-function :initform nil :accessor method-generic-function))) (defmethod method-lambda-list ((m traced-method)) (with-slots (method) m (method-lambda-list method))) (defmethod method-specializers ((m traced-method)) (with-slots (method) m (method-specializers method))) (defmethod method-qualifiers ((m traced-method)) (with-slots (method) m (method-qualifiers method))) (defmethod accessor-method-slot-name ((m traced-method)) (with-slots (method) m (accessor-method-slot-name method))) (defvar *traced-methods* ()) (defun trace-method (spec &rest options) #+copy-&rest-arg (setq options (copy-list options)) (multiple-value-bind (gf omethod name) (parse-method-or-spec spec) (let* ((tfunction (trace-method-internal (method-function omethod) name options)) (tmethod (make-instance 'traced-method :method omethod :function tfunction))) (remove-method gf omethod) (add-method gf tmethod) (pushnew tmethod *traced-methods*) tmethod))) (defun untrace-method (&optional spec) (flet ((untrace-1 (m) (let ((gf (method-generic-function m))) (when gf (remove-method gf m) (add-method gf (slot-value m 'method)) (setq *traced-methods* (remove m *traced-methods*)))))) (if (not (null spec)) (multiple-value-bind (gf method) (parse-method-or-spec spec) (declare (ignore gf)) (if (memq method *traced-methods*) (untrace-1 method) (error "~S is not a traced method?" method))) (dolist (m *traced-methods*) (untrace-1 m))))) (defun trace-method-internal (ofunction name options) (eval `(untrace ,name)) (setf (symbol-function name) ofunction) (eval `(trace ,name ,@options)) (symbol-function name)) ;(defun compile-method (spec) ; (multiple-value-bind (gf method name) ; (parse-method-or-spec spec) ; (declare (ignore gf)) ; (compile name (method-function method)) ; (setf (method-function method) (symbol-function name)))) (defmacro undefmethod (&rest args) #+(or (not :lucid) :lcl3.0) (declare (arglist name {method-qualifier}* specializers)) `(undefmethod-1 ',args)) (defun undefmethod-1 (args) (multiple-value-bind (gf method) (parse-method-or-spec args) (when (and gf method) (remove-method gf method) method))) (pushnew :pcl *features*) (pushnew :portable-commonloops *features*) (pushnew :pcl-structures *features*) #+cmu (when (find-package "OLD-PCL") (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) (symbol-function 'pcl::print-object))) ;;;; MAKE-LOAD-FORM #+cmu17 (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL") #+cmu17 (progn (defgeneric make-load-form (object &optional environment)) (defmethod make-load-form ((object structure-object) &optional environment) (declare (ignore environment)) (kernel:make-structure-load-form object)) (defmethod make-load-form ((object wrapper) &optional env) (declare (ignore env)) (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) (unless pname (error "Can't dump wrapper for anonymous class:~% ~S" (kernel:layout-class object))) `(kernel:class-layout (lisp:find-class ',pname)))) (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) (when slot-names (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ slots:~% ~S" object)) :just-dump-it-normally)) ;;; The following are hacks to deal with CMU CL having two different CLASS ;;; classes. ;;; #+cmu17 (defun coerce-to-pcl-class (class) (if (typep class 'lisp:class) (or (kernel:class-pcl-class class) (find-structure-class (lisp:class-name class))) class)) #+cmu17 (progn (defmethod make-instance ((class lisp:class) &rest stuff) (apply #'make-instance (coerce-to-pcl-class class) stuff)) (defmethod change-class (instance (class lisp:class)) (apply #'change-class instance (coerce-to-pcl-class class)))) #+cmu17 (macrolet ((frob (&rest names) `(progn ,@(mapcar #'(lambda (name) `(defmethod ,name ((class lisp:class)) (funcall #',name (coerce-to-pcl-class class)))) names)))) (frob class-direct-slots class-prototype class-precedence-list class-direct-default-initargs class-direct-superclasses compute-class-precedence-list class-default-initargs class-finalized-p class-direct-subclasses class-slots make-instances-obsolete)) gcl-2.6.14/pcl/gcl_pcl_slots_boot.lisp0000644000175000017500000003625714360276512016331 0ustar cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmacro slot-symbol (slot-name type) `(if (symbolp ,slot-name) (or (get ,slot-name ',(ecase type (reader 'reader-symbol) (writer 'writer-symbol) (boundp 'boundp-symbol))) (intern (format nil "~A ~A slot ~a" (if (symbol-package ,slot-name) (package-name (symbol-package ,slot-name)) "UNINTERNED") (symbol-name ,slot-name) ,(symbol-name type)) *slot-accessor-name-package*)) (progn (error "non-symbol and non-interned symbol slot name accessors~ are not yet implemented") ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) ))) (defun slot-reader-symbol (slot-name) (slot-symbol slot-name reader)) (defun slot-writer-symbol (slot-name) (slot-symbol slot-name writer)) (defun slot-boundp-symbol (slot-name) (slot-symbol slot-name boundp)) (defmacro asv-funcall (sym slot-name type &rest args) (declare (ignore type)) `(if (#-akcl fboundp #+akcl %fboundp ',sym) (,sym ,@args) (no-slot ',sym ',slot-name))) (defun no-slot (sym slot-name) (error "No class has a slot named ~S (~s has no function binding)." slot-name sym)) (defmacro accessor-slot-value (object slot-name) (unless (constantp slot-name) (error "~s requires its slot-name argument to be a constant" 'accessor-slot-value)) (let* ((slot-name (eval slot-name)) (sym (slot-reader-symbol slot-name))) `(asv-funcall ,sym ,slot-name reader ,object))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (unless (constantp slot-name) (error "~s requires its slot-name argument to be a constant" 'accessor-set-slot-value)) (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) (let* ((slot-name (eval slot-name)) (bindings (unless (or (constantp new-value) (atom new-value)) (let ((object-var (gensym))) (prog1 `((,object-var ,object)) (setq object object-var))))) (sym (slot-writer-symbol slot-name)) (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object))) (if bindings `(let ,bindings ,form) form))) (defconstant *optimize-slot-boundp* nil) (defmacro accessor-slot-boundp (object slot-name) (unless (constantp slot-name) (error "~s requires its slot-name argument to be a constant" 'accessor-slot-boundp)) (let* ((slot-name (eval slot-name)) (sym (slot-boundp-symbol slot-name))) (if (not *optimize-slot-boundp*) `(slot-boundp-normal ,object ',slot-name) `(asv-funcall ,sym ,slot-name boundp ,object)))) (defun structure-slot-boundp (object) (declare (ignore object)) t) (defun make-structure-slot-boundp-function (slotd) (let* ((reader (slot-definition-internal-reader-function slotd)) (fun #'(lambda (object) (not (eq (funcall reader object) *slot-unbound*))))) (declare (type function reader)) #+(and kcl turbo-closure) (si:turbo-closure fun) fun)) (defun get-optimized-std-accessor-method-function (class slotd name) (if (structure-class-p class) (ecase name (reader (slot-definition-internal-reader-function slotd)) (writer (slot-definition-internal-writer-function slotd)) (boundp (make-structure-slot-boundp-function slotd))) (let* ((fsc-p (cond ((standard-class-p class) nil) ((funcallable-standard-class-p class) t) (t (error "~S is not a standard-class" class)))) (slot-name (slot-definition-name slotd)) (index (slot-definition-location slotd)) (function (ecase name (reader #'make-optimized-std-reader-method-function) (writer #'make-optimized-std-writer-method-function) (boundp #'make-optimized-std-boundp-method-function))) (value (funcall function fsc-p slot-name index))) (declare (type function function)) (values value index)))) (defun make-optimized-std-reader-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (set-function-name (etypecase index (fixnum (if fsc-p #'(lambda (instance) (let ((value (%instance-ref (fsc-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value))) #'(lambda (instance) (let ((value (%instance-ref (std-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value))))) (cons #'(lambda (instance) (let ((value (cdr index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value))))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (set-function-name (etypecase index (fixnum (if fsc-p #'(lambda (nv instance) (setf (%instance-ref (fsc-instance-slots instance) index) nv)) #'(lambda (nv instance) (setf (%instance-ref (std-instance-slots instance) index) nv)))) (cons #'(lambda (nv instance) (declare (ignore instance)) (setf (cdr index) nv)))) `(writer ,slot-name))) (defun make-optimized-std-boundp-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (set-function-name (etypecase index (fixnum (if fsc-p #'(lambda (instance) (not (eq *slot-unbound* (%instance-ref (fsc-instance-slots instance) index)))) #'(lambda (instance) (not (eq *slot-unbound* (%instance-ref (std-instance-slots instance) index)))))) (cons #'(lambda (instance) (declare (ignore instance)) (not (eq *slot-unbound* (cdr index)))))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function (function) #+cmu (declare (type function function)) #'(lambda (class object slotd) (let ((value (funcall function object))) (if (eq value *slot-unbound*) (slot-unbound class object (slot-definition-name slotd)) value)))) (defun make-optimized-structure-setf-slot-value-using-class-method-function (function) #+cmu (declare (type function function)) #'(lambda (nv class object slotd) (declare (ignore class slotd)) (funcall function nv object))) (defun make-optimized-structure-slot-boundp-using-class-method-function (function) #+cmu (declare (type function function)) #'(lambda (class object slotd) (declare (ignore class slotd)) (not (eq (funcall function object) *slot-unbound*)))) (defun get-optimized-std-slot-value-using-class-method-function (class slotd name) (if (structure-class-p class) (ecase name (reader (make-optimized-structure-slot-value-using-class-method-function (slot-definition-internal-reader-function slotd))) (writer (make-optimized-structure-setf-slot-value-using-class-method-function (slot-definition-internal-writer-function slotd))) (boundp (make-optimized-structure-slot-boundp-using-class-method-function (slot-definition-internal-writer-function slotd)))) (let* ((fsc-p (cond ((standard-class-p class) nil) ((funcallable-standard-class-p class) t) (t (error "~S is not a standard-class" class)))) (slot-name (slot-definition-name slotd)) (index (slot-definition-location slotd)) (function (ecase name (reader #'make-optimized-std-slot-value-using-class-method-function) (writer #'make-optimized-std-setf-slot-value-using-class-method-function) (boundp #'make-optimized-std-slot-boundp-using-class-method-function)))) #+cmu (declare (type function function)) (values (funcall function fsc-p slot-name index) index)))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (etypecase index (fixnum (if fsc-p #'(lambda (class instance slotd) (declare (ignore slotd)) (unless (fsc-instance-p instance) (error "not fsc")) (let ((value (%instance-ref (fsc-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound class instance slot-name) value))) #'(lambda (class instance slotd) (declare (ignore slotd)) (unless (std-instance-p instance) (error "not std")) (let ((value (%instance-ref (std-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound class instance slot-name) value))))) (cons #'(lambda (class instance slotd) (declare (ignore slotd)) (let ((value (cdr index))) (if (eq value *slot-unbound*) (slot-unbound class instance slot-name) value)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (declare (ignore slot-name)) (etypecase index (fixnum (if fsc-p #'(lambda (nv class instance slotd) (declare (ignore class slotd)) (setf (%instance-ref (fsc-instance-slots instance) index) nv)) #'(lambda (nv class instance slotd) (declare (ignore class slotd)) (setf (%instance-ref (std-instance-slots instance) index) nv)))) (cons #'(lambda (nv class instance slotd) (declare (ignore class instance slotd)) (setf (cdr index) nv))))) (defun make-optimized-std-slot-boundp-using-class-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (declare (ignore slot-name)) (etypecase index (fixnum (if fsc-p #'(lambda (class instance slotd) (declare (ignore class slotd)) (not (eq *slot-unbound* (%instance-ref (fsc-instance-slots instance) index)))) #'(lambda (class instance slotd) (declare (ignore class slotd)) (not (eq *slot-unbound* (%instance-ref (std-instance-slots instance) index)))))) (cons #'(lambda (class instance slotd) (declare (ignore class instance slotd)) (not (eq *slot-unbound* (cdr index))))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) `(invoke-effective-method-function ,emf nil ,@args))) (set-function-name (case name (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd))) (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd))) (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) (defun make-internal-reader-method-function (class-name slot-name) (list* ':method-spec `(internal-reader-method ,class-name ,slot-name) (make-method-function (lambda (instance) (let ((wrapper (get-instance-wrapper-or-nil instance))) (if wrapper (let* ((class (wrapper-class* wrapper)) (index (or (instance-slot-index wrapper slot-name) (assq slot-name (wrapper-class-slots wrapper))))) (typecase index (fixnum (let ((value (%instance-ref (get-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value))) (cons (let ((value (cdr index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value))) (t (error "The wrapper for class ~S does not have the slot ~S" class slot-name)))) (slot-value instance slot-name))))))) (defun make-std-reader-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) (initargs (copy-tree (make-method-function (lambda (instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) (instance) (instance-slots)) (instance-read-internal .pv. instance-slots 1 (slot-value instance slot-name)))))))) (setf (getf (getf initargs ':plist) ':slot-name-lists) (list (list nil slot-name))) (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) (list* ':method-spec `(reader-method ,class-name ,slot-name) initargs))) (defun make-std-writer-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) (initargs (copy-tree (make-method-function (lambda (nv instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 1 nv (setf (slot-value instance slot-name) nv)))))))) (setf (getf (getf initargs ':plist) ':slot-name-lists) (list nil (list nil slot-name))) (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) (list* ':method-spec `(writer-method ,class-name ,slot-name) initargs))) (defun make-std-boundp-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) (initargs (copy-tree (make-method-function (lambda (instance) (pv-binding1 (.pv. .calls. (symbol-value pv-table-symbol) (instance) (instance-slots)) (instance-boundp-internal .pv. instance-slots 1 (slot-boundp instance slot-name)))))))) (setf (getf (getf initargs ':plist) ':slot-name-lists) (list (list nil slot-name))) (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) (list* ':method-spec `(boundp-method ,class-name ,slot-name) initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type) (when (or (null type) (eq type 'reader)) (let* ((name (slot-reader-symbol slot-name)) (gf (ensure-generic-function name))) (unless (generic-function-methods gf) (add-reader-method *the-class-slot-object* gf slot-name)))) (when (or (null type) (eq type 'writer)) (let* ((name (slot-writer-symbol slot-name)) (gf (ensure-generic-function name))) (unless (generic-function-methods gf) (add-writer-method *the-class-slot-object* gf slot-name)))) (when (and *optimize-slot-boundp* (or (null type) (eq type 'boundp))) (let* ((name (slot-boundp-symbol slot-name)) (gf (ensure-generic-function name))) (unless (generic-function-methods gf) (add-boundp-method *the-class-slot-object* gf slot-name)))) nil) (defun initialize-internal-slot-gfs* (readers writers boundps) (dolist (reader readers) (initialize-internal-slot-gfs reader 'reader)) (dolist (writer writers) (initialize-internal-slot-gfs writer 'writer)) (dolist (boundp boundps) (initialize-internal-slot-gfs boundp 'boundp))) gcl-2.6.14/pcl/gcl_pcl_init.lisp0000644000175000017500000002336714360276512015103 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; This file defines the initialization and related protocols. ;;; (in-package :pcl) (defmethod make-instance ((class symbol) &rest initargs) (apply #'make-instance (find-class class) initargs)) (defmethod make-instance ((class class) &rest initargs) (unless (class-finalized-p class) (finalize-inheritance class)) (setq initargs (default-initargs class initargs)) #|| (check-initargs-1 class initargs (list (list* 'allocate-instance class initargs) (list* 'initialize-instance (class-prototype class) initargs) (list* 'shared-initialize (class-prototype class) t initargs))) ||# (let* ((info (initialize-info class initargs)) (valid-p (initialize-info-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) (error "Invalid initialization argument ~S for class ~S" (cdr valid-p) (class-name class)))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) (defvar *default-initargs-flag* (list nil)) (defmethod default-initargs ((class slot-class) supplied-initargs) (call-initialize-function (initialize-info-default-initargs-function (initialize-info class supplied-initargs)) nil supplied-initargs) #|| ;; This implementation of default initargs is critically dependent ;; on all-default-initargs not having any duplicate initargs in it. (let ((all-default (class-default-initargs class)) (miss *default-initargs-flag*)) (flet ((getf* (plist key) (do () ((null plist) miss) (if (eq (car plist) key) (return (cadr plist)) (setq plist (cddr plist)))))) (labels ((default-1 (tail) (if (null tail) nil (if (eq (getf* supplied-initargs (caar tail)) miss) (list* (caar tail) (funcall (cadar tail)) (default-1 (cdr tail))) (default-1 (cdr tail)))))) (append supplied-initargs (default-1 all-default))))) ||#) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) #|| (check-initargs-1 (class-of instance) initargs (list (list* 'reinitialize-instance instance initargs) (list* 'shared-initialize instance nil initargs))) ||# (let* ((class (class-of instance)) (info (initialize-info class initargs)) (valid-p (initialize-info-ri-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) (error "Invalid initialization argument ~S for class ~S" (cdr valid-p) (class-name class)))) (apply #'shared-initialize instance nil initargs) instance) (defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs) ;; First we must compute the newly added slots. The spec defines ;; newly added slots as "those local slots for which no slot of ;; the same name exists in the previous class." (let ((added-slots '()) (current-slotds (class-slots (class-of current))) (previous-slot-names (mapcar #'slot-definition-name (class-slots (class-of previous))))) (dolist (slotd current-slotds) (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) (eq (slot-definition-allocation slotd) ':instance)) (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs (list (list* 'update-instance-for-different-class previous current initargs) (list* 'shared-initialize current added-slots initargs))) (apply #'shared-initialize current added-slots initargs))) (defmethod update-instance-for-redefined-class ((instance standard-object) added-slots discarded-slots property-list &rest initargs) (check-initargs-1 (class-of instance) initargs (list (list* 'update-instance-for-redefined-class instance added-slots discarded-slots property-list initargs) (list* 'shared-initialize instance added-slots initargs))) (apply #'shared-initialize instance added-slots initargs)) (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) (when (eq slot-names 't) (return-from shared-initialize (call-initialize-function (initialize-info-shared-initialize-t-function (initialize-info (class-of instance) initargs)) instance initargs))) (when (eq slot-names 'nil) (return-from shared-initialize (call-initialize-function (initialize-info-shared-initialize-nil-function (initialize-info (class-of instance) initargs)) instance initargs))) ;; ;; initialize the instance's slots in a two step process ;; (1) A slot for which one of the initargs in initargs can set ;; the slot, should be set by that initarg. If more than ;; one initarg in initargs can set the slot, the leftmost ;; one should set it. ;; ;; (2) Any slot not set by step 1, may be set from its initform ;; by step 2. Only those slots specified by the slot-names ;; argument are set. If slot-names is: ;; T ;; any slot not set in step 1 is set from its ;; initform ;; ;; any slot in the list, and not set in step 1 ;; is set from its initform ;; ;; () ;; no slots are set from initforms ;; (let* ((class (class-of instance)) (slotds (class-slots class)) #-new-kcl-wrapper (std-p #+cmu17 (pcl-instance-p instance) #-cmu17 (or (std-instance-p instance) (fsc-instance-p instance)))) (dolist (slotd slotds) (let ((slot-name (slot-definition-name slotd)) (slot-initargs (slot-definition-initargs slotd))) (unless (progn ;; Try to initialize the slot from one of the initargs. ;; If we succeed return T, otherwise return nil. (doplist (initarg val) initargs (when (memq initarg slot-initargs) (setf (slot-value-using-class class instance slotd) val) (return 't)))) ;; Try to initialize the slot from its initform. (if (and slot-names (or (eq slot-names 't) (memq slot-name slot-names)) (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't)) (not (slot-boundp-using-class class instance slotd)))) (let ((initfunction (slot-definition-initfunction slotd))) (when initfunction (setf (slot-value-using-class class instance slotd) (funcall (the function initfunction))))))))) instance)) ;;; ;;; if initargs are valid return nil, otherwise signal an error ;;; (defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class call-list) (unless allow-other-keys (if plist-p (check-initargs-2-plist initargs class legal error-p) (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (class call-list) (let ((methods (mapcan #'(lambda (call) (if (consp call) (copy-list (compute-applicable-methods (gdefinition (car call)) (cdr call))) (list call))) call-list)) (legal (apply #'append (mapcar #'slot-definition-initargs (class-slots class))))) ;; Add to the set of slot-filling initargs the set of ;; initargs that are accepted by the methods. If at ;; any point we come across &allow-other-keys, we can ;; just quit. (dolist (method methods) (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (when allow-other-keys (return-from check-initargs-values (values nil t))) (setq legal (append keys legal)))) (values legal nil))) (defun check-initargs-2-plist (initargs class legal &optional (error-p t)) (unless (getf initargs :allow-other-keys) ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (doplist (key val) initargs (unless (memq key legal) (if error-p (error "Invalid initialization argument ~S for class ~S" key (class-name class)) (return-from check-initargs-2-plist nil))))) t) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) (unless (memq :allow-other-keys initkeys) ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (dolist (key initkeys) (unless (memq key legal) (if error-p (error "Invalid initialization argument ~S for class ~S" key (class-name class)) (return-from check-initargs-2-list nil))))) t) gcl-2.6.14/pcl/gcl_pcl_std_class.lisp0000644000175000017500000013672114360276512016116 0ustar cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmethod slot-accessor-function ((slotd effective-slot-definition) type) (ecase type (reader (slot-definition-reader-function slotd)) (writer (slot-definition-writer-function slotd)) (boundp (slot-definition-boundp-function slotd)))) (defmethod (setf slot-accessor-function) (function (slotd effective-slot-definition) type) (ecase type (reader (setf (slot-definition-reader-function slotd) function)) (writer (setf (slot-definition-writer-function slotd) function)) (boundp (setf (slot-definition-boundp-function slotd) function)))) (defconstant *slotd-reader-function-std-p* 1) (defconstant *slotd-writer-function-std-p* 2) (defconstant *slotd-boundp-function-std-p* 4) (defconstant *slotd-all-function-std-p* 7) (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) (let ((flags (slot-value slotd 'accessor-flags))) (declare (type fixnum flags)) (if (eq type 'all) (eql *slotd-all-function-std-p* flags) (let ((mask (ecase type (reader *slotd-reader-function-std-p*) (writer *slotd-writer-function-std-p*) (boundp *slotd-boundp-function-std-p*)))) (declare (type fixnum mask)) (not (zerop (the fixnum (logand mask flags)))))))) (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type) (let ((mask (ecase type (reader *slotd-reader-function-std-p*) (writer *slotd-writer-function-std-p*) (boundp *slotd-boundp-function-std-p*))) (flags (slot-value slotd 'accessor-flags))) (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) (if value (the fixnum (logior mask flags)) (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd 'class))) (let ((table (or (gethash name *name->class->slotd-table*) (setf (gethash name *name->class->slotd-table*) (make-hash-table :test 'eq :size 5))))) (setf (gethash class table) slotd)) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type (reader 'slot-value-using-class) (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd 'class)) (old-slotd (find-slot-definition class name)) (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) (if (eq *boot-state* 'complete) (get-accessor-method-function gf type class slotd) (get-optimized-std-accessor-method-function class slotd type)) #+kcl (si:turbo-closure function) (setf (slot-accessor-std-p slotd type) std-p) (setf (slot-accessor-function slotd type) function)) (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) (push (cons class name) *pv-table-cache-update-info*)))) (defmethod slot-definition-allocation ((slotd structure-slot-definition)) :instance) (defmethod shared-initialize :after ((object documentation-mixin) slot-names &key (documentation nil documentation-p)) (declare (ignore slot-names)) (when documentation-p (setf (plist-value object 'documentation) documentation))) (defmethod documentation (object &optional doc-type) (lisp:documentation object doc-type)) (defmethod (setf documentation) (new-value object &optional doc-type) (declare (ignore new-value doc-type)) (error "Can't change the documentation of ~S." object)) (defmethod documentation ((object documentation-mixin) &optional doc-type) (declare (ignore doc-type)) (plist-value object 'documentation)) (defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type) (declare (ignore doc-type)) (setf (plist-value object 'documentation) new-value)) (defmethod documentation ((slotd standard-slot-definition) &optional doc-type) (declare (ignore doc-type)) (slot-value slotd 'documentation)) (defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type) (declare (ignore doc-type)) (setf (slot-value slotd 'documentation) new-value)) ;;; ;;; Various class accessors that are a little more complicated than can be ;;; done with automatically generated reader methods. ;;; (defmethod class-finalized-p ((class pcl-class)) (with-slots (wrapper) class (not (null wrapper)))) (defmethod class-prototype ((class std-class)) (with-slots (prototype) class (or prototype (setq prototype (allocate-instance class))))) (defmethod class-prototype ((class structure-class)) (with-slots (prototype wrapper defstruct-constructor) class (or prototype (setq prototype (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil (allocate-instance class) (allocate-standard-instance wrapper)))))) (defmethod class-direct-default-initargs ((class slot-class)) (plist-value class 'direct-default-initargs)) (defmethod class-default-initargs ((class slot-class)) (plist-value class 'default-initargs)) (defmethod class-constructors ((class slot-class)) (plist-value class 'constructors)) (defmethod class-slot-cells ((class std-class)) (plist-value class 'class-slot-cells)) ;;; ;;; Class accessors that are even a little bit more complicated than those ;;; above. These have a protocol for updating them, we must implement that ;;; protocol. ;;; ;;; ;;; Maintaining the direct subclasses backpointers. The update methods are ;;; here, the values are read by an automatically generated reader method. ;;; (defmethod add-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class (pushnew subclass direct-subclasses) subclass)) (defmethod remove-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class (setq direct-subclasses (remove subclass direct-subclasses)) subclass)) ;;; ;;; Maintaining the direct-methods and direct-generic-functions backpointers. ;;; ;;; There are four generic functions involved, each has one method for the ;;; class case and another method for the damned EQL specializers. All of ;;; these are specified methods and appear in their specified place in the ;;; class graph. ;;; ;;; ADD-DIRECT-METHOD ;;; REMOVE-DIRECT-METHOD ;;; SPECIALIZER-DIRECT-METHODS ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS ;;; ;;; In each case, we maintain one value which is a cons. The car is the list ;;; methods. The cdr is a list of the generic functions. The cdr is always ;;; computed lazily. ;;; (defmethod add-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH (cdr direct-methods) ())) method) (defmethod remove-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer (setf (car direct-methods) (remove method (car direct-methods)) (cdr direct-methods) ())) method) (defmethod specializer-direct-methods ((specializer class)) (with-slots (direct-methods) specializer (car direct-methods))) (defmethod specializer-direct-generic-functions ((specializer class)) (with-slots (direct-methods) specializer (or (cdr direct-methods) (setf (cdr direct-methods) (gathering1 (collecting-once) (dolist (m (car direct-methods)) (gather1 (method-generic-function m)))))))) ;;; ;;; This hash table is used to store the direct methods and direct generic ;;; functions of EQL specializers. Each value in the table is the cons. ;;; (defvar *eql-specializer-methods* (make-hash-table :test #'eql)) (defvar *class-eq-specializer-methods* (make-hash-table :test #'eq)) (defmethod specializer-method-table ((specializer eql-specializer)) *eql-specializer-methods*) (defmethod specializer-method-table ((specializer class-eq-specializer)) *class-eq-specializer-methods*) (defmethod add-direct-method ((specializer specializer-with-object) (method method)) (let* ((object (specializer-object specializer)) (table (specializer-method-table specializer)) (entry (gethash object table))) (unless entry (setq entry (setf (gethash object table) (cons nil nil)))) (setf (car entry) (adjoin method (car entry)) (cdr entry) ()) method)) (defmethod remove-direct-method ((specializer specializer-with-object) (method method)) (let* ((object (specializer-object specializer)) (entry (gethash object (specializer-method-table specializer)))) (when entry (setf (car entry) (remove method (car entry)) (cdr entry) ())) method)) (defmethod specializer-direct-methods ((specializer specializer-with-object)) (car (gethash (specializer-object specializer) (specializer-method-table specializer)))) (defmethod specializer-direct-generic-functions ((specializer specializer-with-object)) (let* ((object (specializer-object specializer)) (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) (setf (cdr entry) (gathering1 (collecting-once) (dolist (m (car entry)) (gather1 (method-generic-function m))))))))) (defun map-specializers (function) (declare (type function function)) (map-all-classes #'(lambda (class) (funcall function (class-eq-specializer class)) (funcall function class))) (maphash #'(lambda (object methods) (declare (ignore methods)) (intern-eql-specializer object)) *eql-specializer-methods*) (maphash #'(lambda (object specl) (declare (ignore object)) (funcall function specl)) *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (declare (type function function)) (let ((all-generic-functions (make-hash-table :test 'eq))) (map-specializers #'(lambda (specl) (dolist (gf (specializer-direct-generic-functions specl)) (unless (gethash gf all-generic-functions) (setf (gethash gf all-generic-functions) t) (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key) (declare (ignore slot-names)) (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) (declare (ignore slot-names)) (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) (defun real-load-defclass (name metaclass-name supers slots other accessors) (do-standard-defsetfs-for-defclass accessors) ;*** (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots :definition-source `((defclass ,name) ,(load-truename)) other))) #+cmu17 (kernel:layout-class (class-wrapper res)) #-cmu17 res)) (setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest all) (apply #'ensure-class-using-class name (find-class name nil) all)) (defmethod ensure-class-using-class (name (class null) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) (inform-type-system-about-class (class-prototype meta) name);*** (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) (inform-type-system-about-class class name) ;*** class)) (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) (unless (eq (class-of class) meta) (change-class class meta)) (apply #'reinitialize-instance class initargs) (setf (find-class name) class) (inform-type-system-about-class class name) ;*** class)) (defmethod class-predicate-name ((class t)) 'function-returning-nil) (defun ensure-class-values (class args) (let* ((initargs (copy-list args)) (unsupplied (list 1)) (supplied-meta (getf initargs :metaclass unsupplied)) (supplied-supers (getf initargs :direct-superclasses unsupplied)) (supplied-slots (getf initargs :direct-slots unsupplied)) (meta (cond ((neq supplied-meta unsupplied) (find-class supplied-meta)) ((or (null class) (forward-referenced-class-p class)) *the-class-standard-class*) (t (class-of class))))) (flet ((fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) (error "~S is not a class or a legal class name." s)) (t (or (find-class s nil) (setf (find-class s) (make-instance 'forward-referenced-class :name s))))))) (loop (unless (remf initargs :metaclass) (return))) (loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-slots) (return))) (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied) (mapcar #'fix-super supplied-supers)) :direct-slots (and (neq supplied-slots unsupplied) supplied-slots) initargs))))) ;;; ;;; ;;; #|| ; since it doesn't do anything (defmethod shared-initialize :before ((class std-class) slot-names &key direct-superclasses) (declare (ignore slot-names)) ;; *** error checking ) ||# (defmethod shared-initialize :after ((class std-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) (direct-default-initargs nil direct-default-initargs-p) (predicate-name nil predicate-name-p)) (declare (ignore slot-names)) (if direct-superclasses-p (progn (setq direct-superclasses (or direct-superclasses (list *the-class-standard-object*))) (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) (error "The class ~S was specified as a~%super-class of the class ~S;~%~ but the meta-classes ~S and~%~S are incompatible.~% Define a method for ~S to avoid this error." superclass class (class-of superclass) (class-of class) 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) (setq direct-superclasses (slot-value class 'direct-superclasses))) (setq direct-slots (if direct-slots-p (setf (slot-value class 'direct-slots) (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots)) (slot-value class 'direct-slots))) (if direct-default-initargs-p (setf (plist-value class 'direct-default-initargs) direct-default-initargs) (setq direct-default-initargs (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) (gathering1 (collecting) (dolist (dslotd direct-slots) (when (eq (slot-definition-allocation dslotd) class) (let ((initfunction (slot-definition-initfunction dslotd))) (gather1 (cons (slot-definition-name dslotd) (if initfunction (funcall initfunction) *slot-unbound*)))))))) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) (car predicate-name)) (or (slot-value class 'predicate-name) (setf (slot-value class 'predicate-name) (make-class-predicate-name (class-name class)))))) (add-direct-subclasses class direct-superclasses) (update-class class nil) (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots)) (defmethod shared-initialize :before ((class class) slot-names &key name) (declare (ignore slot-names name)) (setf (slot-value class 'type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) (defmethod reinitialize-instance :before ((class slot-class) &key) (remove-direct-subclasses class (class-direct-superclasses class)) (remove-slot-accessors class (class-direct-slots class))) (defmethod reinitialize-instance :after ((class slot-class) &rest initargs &key) (map-dependents class #'(lambda (dependent) (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((class structure-class) slot-names &key (direct-superclasses nil direct-superclasses-p) (direct-slots nil direct-slots-p) direct-default-initargs (predicate-name nil predicate-name-p)) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) (or direct-superclasses (setq direct-superclasses (and (not (eq (class-name class) 'structure-object)) (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) (let* ((name (class-name class)) (from-defclass-p (slot-value class 'from-defclass-p)) (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (if direct-slots-p (setf (slot-value class 'direct-slots) (setq direct-slots (mapcar #'(lambda (pl) (when defstruct-p (let* ((slot-name (getf pl :name)) (acc-name (format nil "~s structure class ~a" name slot-name)) (accessor (intern acc-name))) (setq pl (list* :defstruct-accessor-symbol accessor pl)))) (make-direct-slotd class pl)) direct-slots))) (setq direct-slots (slot-value class 'direct-slots))) (when defstruct-p (let* ((include (car (slot-value class 'direct-superclasses))) (conc-name (intern (format nil "~s structure class " name))) (constructor (intern (format nil "~a constructor" conc-name))) (defstruct `(defstruct (,name ,@(when include `((:include ,(class-name include)))) (:print-function print-std-instance) (:predicate nil) (:conc-name ,conc-name) (:constructor ,constructor ())) ,@(mapcar #'(lambda (slot) `(,(slot-definition-name slot) *slot-unbound*)) direct-slots))) (reader-names (mapcar #'(lambda (slotd) (intern (format nil "~A~A reader" conc-name (slot-definition-name slotd)))) direct-slots)) (writer-names (mapcar #'(lambda (slotd) (intern (format nil "~A~A writer" conc-name (slot-definition-name slotd)))) direct-slots)) (readers-init (mapcar #'(lambda (slotd reader-name) (let ((accessor (slot-definition-defstruct-accessor-symbol slotd))) `(defun ,reader-name (obj) (declare (type ,name obj)) (,accessor obj)))) direct-slots reader-names)) (writers-init (mapcar #'(lambda (slotd writer-name) (let ((accessor (slot-definition-defstruct-accessor-symbol slotd))) `(defun ,writer-name (nv obj) (declare (type ,name obj)) (setf (,accessor obj) nv)))) direct-slots writer-names)) (defstruct-form `(progn ,defstruct ,@readers-init ,@writers-init (declare-structure ',name nil nil)))) (unless (structure-type-p name) (eval defstruct-form)) (mapc #'(lambda (dslotd reader-name writer-name) (let* ((reader (gdefinition reader-name)) (writer (when (gboundp writer-name) (gdefinition writer-name)))) (setf (slot-value dslotd 'internal-reader-function) reader) (setf (slot-value dslotd 'internal-writer-function) writer))) direct-slots reader-names writer-names) (setf (slot-value class 'defstruct-form) defstruct-form) (setf (slot-value class 'defstruct-constructor) constructor)))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) #-(or cmu17 new-kcl-wrapper) (unless (slot-value class 'wrapper) (setf (slot-value class 'wrapper) (make-wrapper 0 class))) #+cmu17 (let ((lclass (lisp:find-class (class-name class)))) (setf (kernel:class-pcl-class lclass) class) (setf (slot-value class 'wrapper) (kernel:class-layout lclass))) #+new-kcl-wrapper (let ((wrapper (get (class-name class) 'si::s-data))) (setf (slot-value class 'wrapper) wrapper) (setf (wrapper-class wrapper) class)) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) (car predicate-name)) (or (slot-value class 'predicate-name) (setf (slot-value class 'predicate-name) (make-class-predicate-name (class-name class)))))) (make-class-predicate class predicate-name) (add-slot-accessors class direct-slots)) (defmethod direct-slot-definition-class ((class structure-class) initargs) (declare (ignore initargs)) (find-class 'structure-direct-slot-definition)) (defmethod finalize-inheritance ((class structure-class)) nil) ; always finalized (defun add-slot-accessors (class dslotds) (fix-slot-accessors class dslotds 'add)) (defun remove-slot-accessors (class dslotds) (fix-slot-accessors class dslotds 'remove)) (defun fix-slot-accessors (class dslotds add/remove) (flet ((fix (gfspec name r/w) (let ((gf (ensure-generic-function gfspec))) (case r/w (r (if (eq add/remove 'add) (add-reader-method class gf name) (remove-reader-method class gf))) (w (if (eq add/remove 'add) (add-writer-method class gf name) (remove-writer-method class gf))))))) (dolist (dslotd dslotds) (let ((slot-name (slot-definition-name dslotd))) (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) (defun add-direct-subclasses (class new) (dolist (n new) (unless (memq class (class-direct-subclasses class)) (add-direct-subclass n class)))) (defun remove-direct-subclasses (class new) (let ((old (class-direct-superclasses class))) (dolist (o (set-difference old new)) (remove-direct-subclass o class)))) ;;; ;;; ;;; (defmethod finalize-inheritance ((class std-class)) (update-class class t)) (defun class-has-a-forward-referenced-superclass-p (class) (or (forward-referenced-class-p class) (some #'class-has-a-forward-referenced-superclass-p (class-direct-superclasses class)))) ;;; ;;; Called by :after shared-initialize whenever a class is initialized or ;;; reinitialized. The class may or may not be finalized. ;;; (defun update-class (class finalizep) (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) (update-cpl class (compute-class-precedence-list class)) (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) (update-make-instance-function-table class)) (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) (defun update-cpl (class cpl) (when (class-finalized-p class) (unless (equal (class-precedence-list class) cpl) (force-cache-flushes class))) (setf (slot-value class 'class-precedence-list) cpl) (update-class-can-precede-p cpl)) (defun update-class-can-precede-p (cpl) (when cpl (let ((first (car cpl))) (dolist (c (cdr cpl)) (pushnew c (slot-value first 'can-precede-list)))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) (member class2 (class-can-precede-list class1))) (defun update-slots (class eslotds) (let ((instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) (cond ((eq alloc :instance) (push eslotd instance-slots)) ((classp alloc) (push eslotd class-slots))))) ;; ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. ;; (let* ((nlayout (mapcar #'slot-definition-name (sort instance-slots #'< :key #'slot-definition-location))) (nslots (length nlayout)) (nwrapper-class-slots (compute-class-slots class-slots)) (owrapper (class-wrapper class)) (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) (nwrapper (cond ((null owrapper) (make-wrapper nslots class)) ((and (equal nlayout olayout) (not (iterate ((o (list-elements owrapper-class-slots)) (n (list-elements nwrapper-class-slots))) (unless (eq (car o) (car n)) (return t))))) owrapper) (t ;; ;; This will initialize the new wrapper to have the same ;; state as the old wrapper. We will then have to change ;; that. This may seem like wasted work (it is), but the ;; spec requires that we call make-instances-obsolete. ;; (make-instances-obsolete class) (class-wrapper class))))) (with-slots (wrapper slots) class #+new-kcl-wrapper (setf (si::s-data-name nwrapper) (class-name class)) #+cmu17 (update-lisp-class-layout class nwrapper) (setf slots eslotds (wrapper-instance-slots-layout nwrapper) nlayout (wrapper-class-slots nwrapper) nwrapper-class-slots (wrapper-no-of-instance-slots nwrapper) nslots wrapper nwrapper)) (unless (eq owrapper nwrapper) (update-pv-table-cache-info class))))) (defun compute-class-slots (eslotds) (gathering1 (collecting) (dolist (eslotd eslotds) (gather1 (assoc (slot-definition-name eslotd) (class-slot-cells (slot-definition-allocation eslotd))))))) (defun compute-layout (cpl instance-eslotds) (let* ((names (gathering1 (collecting) (dolist (eslotd instance-eslotds) (when (eq (slot-definition-allocation eslotd) :instance) (gather1 (slot-definition-name eslotd)))))) (order ())) (labels ((rwalk (tail) (when tail (rwalk (cdr tail)) (dolist (ss (class-slots (car tail))) (let ((n (slot-definition-name ss))) (when (member n names) (setq order (cons n order) names (remove n names)))))))) (rwalk (if (slot-boundp (car cpl) 'slots) cpl (cdr cpl))) (reverse (append names order))))) (defun update-gfs-of-class (class) (when (and (class-finalized-p class) (let ((cpl (class-precedence-list class))) (or (member *the-class-slot-class* cpl) (member *the-class-standard-effective-slot-definition* cpl)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) (dolist (gf (specializer-direct-generic-functions class)) (setf (gethash gf gf-table) t)) (mapc #'collect-gfs (class-direct-superclasses class)))) (collect-gfs class) (maphash #'(lambda (gf ignore) (declare (ignore ignore)) (update-gf-dfun class gf)) gf-table))))) (defun update-inits (class inits) (setf (plist-value class 'default-initargs) inits)) ;;; ;;; ;;; (defmethod compute-default-initargs ((class slot-class)) (let ((cpl (class-precedence-list class)) (direct (class-direct-default-initargs class))) (labels ((walk (tail) (if (null tail) nil (let ((c (pop tail))) (append (if (eq c class) direct (class-direct-default-initargs c)) (walk tail)))))) (let ((initargs (walk cpl))) (delete-duplicates initargs :test #'eq :key #'car :from-end t))))) ;;; ;;; Protocols for constructing direct and effective slot definitions. ;;; ;;; ;;; ;;; (defmethod direct-slot-definition-class ((class std-class) initargs) (declare (ignore initargs)) (find-class 'standard-direct-slot-definition)) (defun make-direct-slotd (class initargs) (let ((initargs (list* :class class initargs))) (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) ;;; ;;; ;;; (defmethod compute-slots ((class std-class)) ;; ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once ;; for each different slot name we find in our superclasses. Each ;; call receives the class and a list of the dslotds with that name. ;; The list is in most-specific-first order. ;; (let ((name-dslotds-alist ())) (dolist (c (class-precedence-list class)) (let ((dslotds (class-direct-slots c))) (dolist (d dslotds) (let* ((name (slot-definition-name d)) (entry (assq name name-dslotds-alist))) (if entry (push d (cdr entry)) (push (list name d) name-dslotds-alist)))))) (mapcar #'(lambda (direct) (compute-effective-slot-definition class (nreverse (cdr direct)))) name-dslotds-alist))) (defmethod compute-slots :around ((class std-class)) (let ((eslotds (call-next-method)) (cpl (class-precedence-list class)) (instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) (cond ((eq alloc :instance) (push eslotd instance-slots)) ((classp alloc) (push eslotd class-slots))))) (let ((nlayout (compute-layout cpl instance-slots))) (dolist (eslotd instance-slots) (setf (slot-definition-location eslotd) (position (slot-definition-name eslotd) nlayout)))) (dolist (eslotd class-slots) (setf (slot-definition-location eslotd) (assoc (slot-definition-name eslotd) (class-slot-cells (slot-definition-allocation eslotd))))) (mapc #'initialize-internal-slot-functions eslotds) eslotds)) (defmethod compute-slots ((class structure-class)) (mapcan #'(lambda (superclass) (mapcar #'(lambda (dslotd) (compute-effective-slot-definition class (list dslotd))) (class-direct-slots superclass))) (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) (mapc #'initialize-internal-slot-functions eslotds) eslotds)) (defmethod compute-effective-slot-definition ((class slot-class) dslotds) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) (class (effective-slot-definition-class class initargs))) (apply #'make-instance class initargs))) (defmethod effective-slot-definition-class ((class std-class) initargs) (declare (ignore initargs)) (find-class 'standard-effective-slot-definition)) (defmethod effective-slot-definition-class ((class structure-class) initargs) (declare (ignore initargs)) (find-class 'structure-effective-slot-definition)) (defmethod compute-effective-slot-definition-initargs ((class slot-class) direct-slotds) (let* ((name nil) (initfunction nil) (initform nil) (initargs nil) (allocation nil) (type t) (namep nil) (initp nil) (allocp nil)) (dolist (slotd direct-slotds) (when slotd (unless namep (setq name (slot-definition-name slotd) namep t)) (unless initp (when (slot-definition-initfunction slotd) (setq initform (slot-definition-initform slotd) initfunction (slot-definition-initfunction slotd) initp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) (let ((slotd-type (slot-definition-type slotd))) (setq type (cond ((eq type 't) slotd-type) ((*subtypep type slotd-type) type) (t `(and ,type ,slotd-type))))))) (list :name name :initform initform :initfunction initfunction :initargs initargs :allocation allocation :type type :class class))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) (let ((slotd (car direct-slotds))) (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd) :internal-reader-function (slot-definition-internal-reader-function slotd) :internal-writer-function (slot-definition-internal-writer-function slotd) (call-next-method)))) ;;; ;;; NOTE: For bootstrapping considerations, these can't use make-instance ;;; to make the method object. They have to use make-a-method which ;;; is a specially bootstrapped mechanism for making standard methods. ;;; (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) (find-class 'standard-reader-method)) (defmethod add-reader-method ((class slot-class) generic-function slot-name) (add-method generic-function (make-a-method 'standard-reader-method () (list (or (class-name class) 'object)) (list class) (make-reader-method-function class slot-name) "automatically generated reader method" slot-name))) (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) (find-class 'standard-writer-method)) (defmethod add-writer-method ((class slot-class) generic-function slot-name) (add-method generic-function (make-a-method 'standard-writer-method () (list 'new-value (or (class-name class) 'object)) (list *the-class-t* class) (make-writer-method-function class slot-name) "automatically generated writer method" slot-name))) (defmethod add-boundp-method ((class slot-class) generic-function slot-name) (add-method generic-function (make-a-method 'standard-boundp-method () (list (or (class-name class) 'object)) (list class) (make-boundp-method-function class slot-name) "automatically generated boundp method" slot-name))) (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) (defmethod remove-writer-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list *the-class-t* class) nil))) (when method (remove-method generic-function method)))) (defmethod remove-boundp-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) ;;; ;;; make-reader-method-function and make-write-method function are NOT part of ;;; the standard protocol. They are however useful, PCL makes uses makes use ;;; of them internally and documents them for PCL users. ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor ;;; *** for each possible type test. In order to do this it would be nice ;;; *** to have help from inform-type-system-about-class and friends. ;;; ;;; *** There is a subtle bug here which is going to have to be fixed. ;;; *** Namely, the simplistic use of the template has to be fixed. We ;;; *** have to give the optimize-slot-value method the user might have ;;; *** defined for this metclass a chance to run. ;;; (defmethod make-reader-method-function ((class slot-class) slot-name) (make-std-reader-method-function (class-name class) slot-name)) (defmethod make-writer-method-function ((class slot-class) slot-name) (make-std-writer-method-function (class-name class) slot-name)) (defmethod make-boundp-method-function ((class slot-class) slot-name) (make-std-boundp-method-function (class-name class) slot-name)) ;;;; inform-type-system-about-class ;;;; make-type-predicate ;;; ;;; These are NOT part of the standard protocol. They are internal mechanism ;;; which PCL uses to *try* and tell the type system about class definitions. ;;; In a more fully integrated implementation of CLOS, the type system would ;;; know about class objects and class names in a more fundamental way and ;;; the mechanism used to inform the type system about new classes would be ;;; different. ;;; (defmethod inform-type-system-about-class ((class std-class) name) (inform-type-system-about-std-class name)) (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) (defmethod validate-superclass ((class class) (new-super class)) (or (eq new-super *the-class-t*) (eq (class-of class) (class-of new-super)))) ;;; ;;; ;;; (defun force-cache-flushes (class) (let* ((owrapper (class-wrapper class)) (state (wrapper-state owrapper))) ;; ;; We only need to do something if the state is still T. If the ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those ;; will already be doing what we want. In particular, we must be ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE ;; means do what FLUSH does and then some. ;; (when (eq state 't) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts #+cmu17 (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':flush nwrapper)))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) (set-wrapper instance nwrapper)) ;;; ;;; make-instances-obsolete can be called by user code. It will cause the ;;; next access to the instance (as defined in 88-002R) to trap through the ;;; update-instance-for-redefined-class mechanism. ;;; (defmethod make-instances-obsolete ((class std-class)) (let* ((owrapper (class-wrapper class)) (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts #+cmu17 (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':obsolete nwrapper) class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class))) ;;; ;;; obsolete-instance-trap is the internal trap that is called when we see ;;; an obsolete instance. The times when it is called are: ;;; - when the instance is involved in method lookup ;;; - when attempting to access a slot of an instance ;;; ;;; It is not called by class-of, wrapper-of, or any of the low-level instance ;;; access macros. ;;; ;;; Of course these times when it is called are an internal implementation ;;; detail of PCL and are not part of the documented description of when the ;;; obsolete instance update happens. The documented description is as it ;;; appears in 88-002R. ;;; ;;; This has to return the new wrapper, so it counts on all the methods on ;;; obsolete-instance-trap-internal to return the new wrapper. It also does ;;; a little internal error checking to make sure that the traps are only ;;; happening when they should, and that the trap methods are computing ;;; apropriate new wrappers. ;;; ;;; obsolete-instance-trap might be called on structure instances ;;; after a structure is redefined. In most cases, obsolete-instance-trap ;;; will not be able to fix the old instance, so it must signal an ;;; error. The hard part of this is that the error system and debugger ;;; might cause obsolete-instance-trap to be called again, so in that ;;; case, we have to return some reasonable wrapper, instead. (defvar *in-obsolete-instance-trap* nil) (defvar *the-wrapper-of-structure-object* (class-wrapper (find-class 'structure-object))) #+cmu17 (define-condition obsolete-structure (error) ((datum :reader obsolete-structure-datum :initarg :datum)) (:report (lambda (condition stream) ;; Don't try to print the structure, since it probably ;; won't work. (format stream "Obsolete structure error in ~S:~@ For a structure of type: ~S" (conditions::condition-function-name condition) (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance) (if (not #-(or cmu17 new-kcl-wrapper) (or (std-instance-p instance) (fsc-instance-p instance)) #+cmu17 (pcl-instance-p instance) #+new-kcl-wrapper nil) (if *in-obsolete-instance-trap* *the-wrapper-of-structure-object* (let ((*in-obsolete-instance-trap* t)) #-cmu17 (error "The structure ~S is obsolete." instance) #+cmu17 (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) (copy (allocate-instance class)) ;??? allocate-instance ??? (olayout (wrapper-instance-slots-layout owrapper)) (nlayout (wrapper-instance-slots-layout nwrapper)) (oslots (get-slots instance)) (nslots (get-slots copy)) (oclass-slots (wrapper-class-slots owrapper)) (added ()) (discarded ()) (plist ())) ;; local --> local transfer ;; local --> shared discard ;; local --> -- discard ;; shared --> local transfer ;; shared --> shared discard ;; shared --> -- discard ;; -- --> local add ;; -- --> shared -- ;; ;; Go through all the old local slots. ;; (iterate ((name (list-elements olayout)) (opos (interval :from 0))) (let* ((opos opos) (npos (posq name nlayout))) (declare (fixnum opos)) (if npos (setf (instance-ref nslots npos) (instance-ref oslots opos)) (progn (push name discarded) (unless (eq (instance-ref oslots opos) *slot-unbound*) (setf (getf plist name) (instance-ref oslots opos))))))) ;; ;; Go through all the old shared slots. ;; (iterate ((oclass-slot-and-val (list-elements oclass-slots))) (let ((name (car oclass-slot-and-val)) (val (cdr oclass-slot-and-val))) (let ((npos (posq name nlayout))) (if npos (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) (progn (push name discarded) (unless (eq val *slot-unbound*) (setf (getf plist name) val))))))) ;; ;; Go through all the new local slots to compute the added slots. ;; (dolist (nlocal nlayout) (unless (or (memq nlocal olayout) (assq nlocal oclass-slots)) (push nlocal added))) (swap-wrappers-and-slots instance copy) (update-instance-for-redefined-class instance added discarded plist) nwrapper))) ;;; ;;; ;;; (defmacro copy-instance-internal (instance) `(#+new-kcl-wrapper if #-new-kcl-wrapper progn #+new-kcl-wrapper (not (std-instance-p ,instance)) (let* ((class (class-of instance)) (copy (allocate-instance class))) (if (std-instance-p ,instance) (setf (std-instance-slots ,instance) (std-instance-slots ,instance)) (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance))) copy) #+new-kcl-wrapper (copy-structure-header ,instance))) (defun change-class-internal (instance new-class) (let* ((old-class (class-of instance)) (copy (allocate-instance new-class)) (new-wrapper (get-wrapper copy)) (old-wrapper (class-wrapper old-class)) (old-layout (wrapper-instance-slots-layout old-wrapper)) (new-layout (wrapper-instance-slots-layout new-wrapper)) (old-slots (get-slots instance)) (new-slots (get-slots copy)) (old-class-slots (wrapper-class-slots old-wrapper))) ;; ;; "The values of local slots specified by both the class Cto and ;; Cfrom are retained. If such a local slot was unbound, it remains ;; unbound." ;; (iterate ((new-slot (list-elements new-layout)) (new-position (interval :from 0))) (let* ((new-position new-position) (old-position (posq new-slot old-layout))) (declare (fixnum new-position)) (when old-position (setf (instance-ref new-slots new-position) (instance-ref old-slots old-position))))) ;; ;; "The values of slots specified as shared in the class Cfrom and ;; as local in the class Cto are retained." ;; (iterate ((slot-and-val (list-elements old-class-slots))) (let ((position (posq (car slot-and-val) new-layout))) (when position (setf (instance-ref new-slots position) (cdr slot-and-val))))) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. (swap-wrappers-and-slots instance copy) (update-instance-for-different-class copy instance) instance)) (defmethod change-class ((instance standard-object) (new-class standard-class)) (unless (std-instance-p instance) (error "Can't change the class of ~S to ~S~@ because it isn't already an instance with metaclass~%~S." instance new-class 'standard-class)) (change-class-internal instance new-class)) (defmethod change-class ((instance standard-object) (new-class funcallable-standard-class)) (unless (fsc-instance-p instance) (error "Can't change the class of ~S to ~S~@ because it isn't already an instance with metaclass~%~S." instance new-class 'funcallable-standard-class)) (change-class-internal instance new-class)) (defmethod change-class ((instance t) (new-class-name symbol)) (change-class instance (find-class new-class-name))) ;;; ;;; The metaclass BUILT-IN-CLASS ;;; ;;; This metaclass is something of a weird creature. By this point, all ;;; instances of it which will exist have been created, and no instance ;;; is ever created by calling MAKE-INSTANCE. ;;; ;;; But, there are other parts of the protcol we must follow and those ;;; definitions appear here. ;;; (defmethod shared-initialize :before ((class built-in-class) slot-names &rest initargs) (declare (ignore slot-names initargs)) (error "Attempt to initialize or reinitialize a built in class.")) (defmethod class-direct-slots ((class built-in-class)) ()) (defmethod class-slots ((class built-in-class)) ()) (defmethod class-direct-default-initargs ((class built-in-class)) ()) (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) (eq s *the-class-t*)) ;;; ;;; ;;; (defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) 't) ;;; ;;; ;;; (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) (pushnew dependent (plist-value metaobject 'dependents))) (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) (setf (plist-value metaobject 'dependents) (delete dependent (plist-value metaobject 'dependents)))) (defmethod map-dependents ((metaobject dependent-update-mixin) function) (dolist (dependent (plist-value metaobject 'dependents)) (funcall function dependent))) gcl-2.6.14/pcl/gcl_pcl_dlisp.lisp0000644000175000017500000003740614360276512015252 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; This file is (almost) functionally equivalent to dlap.lisp, ;;; but easier to read. ;;; Might generate faster code, too, depending on the compiler and ;;; whether an implementation-specific lap assembler was used. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p)) (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p)) (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p)) ;;; -------------------------------- (defun emit-one-index-readers (class-slot-p) (emit-one-or-n-index-reader/writer :reader nil class-slot-p)) (defun emit-one-index-writers (class-slot-p) (emit-one-or-n-index-reader/writer :writer nil class-slot-p)) (defun emit-n-n-readers () (emit-one-or-n-index-reader/writer :reader t nil)) (defun emit-n-n-writers () (emit-one-or-n-index-reader/writer :writer t nil)) ;;; -------------------------------- (defun emit-checking (metatypes applyp) (emit-checking-or-caching nil nil metatypes applyp)) (defun emit-caching (metatypes applyp) (emit-checking-or-caching t nil metatypes applyp)) (defun emit-in-checking-cache-p (metatypes) (emit-checking-or-caching nil t metatypes nil)) (defun emit-constant-value (metatypes) (emit-checking-or-caching t t metatypes nil)) ;;; -------------------------------- (defvar *precompiling-lap* nil) (defvar *emit-function-p* t) (defun emit-default-only (metatypes applyp) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-default-only (emit-default-only-function metatypes applyp))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp '(emf) dlap-lambda-list `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) (defmacro emit-default-only-macro (metatypes applyp) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values (emit-default-only metatypes applyp)))) ;;; -------------------------------- (defun generating-lisp (closure-variables args form) (let* ((rest (memq '&rest args)) (ldiff (and rest (ldiff args rest))) (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) (lambda `(lambda ,closure-variables ,@(when (member 'miss-fn closure-variables) `((declare (type function miss-fn)))) (fin-lambda-fn ,args #+copy-&rest-arg ,@(when rest `((setq .lap-rest-arg. (copy-list .lap-rest-arg.)))) (let () (declare #.*optimize-speed*) ,form))))) (values (if *precompiling-lap* `#',lambda (compile-lambda lambda)) nil))) ;;; cmu17 note: since std-instance-p is weakened, that branch may run ;;; on non-pcl instances (structures). The result will be the ;;; non-wrapper layout for the structure, which will cause a miss. The "slots" ;;; will be whatever the first slot is, but will be ignored. Similarly, ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. ;;; (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-reader/writer (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))) (let ((instance nil) (arglist ()) (closure-variables ()) (field (first-wrapper-cache-number-index)) (readp (eq reader/writer :reader)) (read-form (emit-slot-read-form class-slot-p 'index 'slots))) ;;we need some field to do the fast obsolete check (ecase reader/writer (:reader (setq instance (dfun-arg-symbol 0) arglist (list instance))) (:writer (setq instance (dfun-arg-symbol 1) arglist (list (dfun-arg-symbol 0) instance)))) (ecase 1-or-2-class (1 (setq closure-variables '(wrapper-0 index miss-fn))) (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) (generating-lisp closure-variables arglist `(let* (,@(unless class-slot-p `((slots nil))) (wrapper (cond ((std-instance-p ,instance) ,@(unless class-slot-p `((setq slots (std-instance-slots ,instance)))) (std-instance-wrapper ,instance)) ((fsc-instance-p ,instance) ,@(unless class-slot-p `((setq slots (fsc-instance-slots ,instance)))) (fsc-instance-wrapper ,instance)))) ,@(when readp '(value))) (if (or (null wrapper) (zerop (wrapper-cache-number-vector-ref wrapper ,field)) (not (or (eq wrapper wrapper-0) ,@(when (eql 2 1-or-2-class) `((eq wrapper wrapper-1))))) ,@(when readp `((eq *slot-unbound* (setq value ,read-form))))) (funcall miss-fn ,@arglist) ,(if readp 'value `(setf ,read-form ,(car arglist)))))))) (defun emit-slot-read-form (class-slot-p index slots) (if class-slot-p `(cdr ,index) `(%instance-ref ,slots ,index))) (defun emit-boundp-check (value-form miss-fn arglist) `(let ((value ,value-form)) (if (eq value *slot-unbound*) (funcall ,miss-fn ,@arglist) value))) (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) (let ((read-form (emit-slot-read-form class-slot-p index slots))) (ecase reader/writer (:reader (emit-boundp-check read-form miss-fn arglist)) (:writer `(setf ,read-form ,(car arglist)))))) (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-one-or-n-index-reader/writer (emit-one-or-n-index-reader/writer-function reader/writer cached-index-p class-slot-p))) (multiple-value-bind (arglist metatypes) (ecase reader/writer (:reader (values (list (dfun-arg-symbol 0)) '(standard-instance))) (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) '(t standard-instance)))) (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) arglist `(let (,@(unless class-slot-p '(slots)) ,@(when cached-index-p '(index))) ,(emit-dlap arglist metatypes (emit-slot-access reader/writer class-slot-p 'slots 'index 'miss-fn arglist) `(funcall miss-fn ,@arglist) (when cached-index-p 'index) (unless class-slot-p '(slots))))))) (defmacro emit-one-or-n-index-reader/writer-macro (reader/writer cached-index-p class-slot-p) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) (defun emit-miss (miss-fn args &optional applyp) (let ((restl (when applyp '(.lap-rest-arg.)))) (if restl `(apply ,miss-fn ,@args ,@restl) `(funcall ,miss-fn ,@args ,@restl)))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-checking-or-caching (emit-checking-or-caching-function cached-emf-p return-value-p metatypes applyp))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) (args (remove '&rest dlap-lambda-list)) (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) dlap-lambda-list `(let (,@(when cached-emf-p '(emf))) ,(emit-dlap args metatypes (if return-value-p (if cached-emf-p 'emf t) `(invoke-effective-method-function emf ,applyp ,@args ,@restl)) (emit-miss 'miss-fn args applyp) (when cached-emf-p 'emf)))))) (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) (let ((*emit-function-p* nil) (*precompiling-lap* t)) (values (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) (wrapper-bindings (mapcan #'(lambda (arg mt) (unless (eq mt 't) (incf index) `((,(intern (format nil "WRAPPER-~D" index) *the-pcl-package*) ,(emit-fetch-wrapper mt arg 'miss (pop slot-regs)))))) args metatypes)) (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) (unless wrappers (error "Every metatype is T.")) `(block dfun (tagbody (let ((field (cache-field cache)) (cache-vector (cache-vector cache)) (mask (cache-mask cache)) (size (cache-size cache)) (overflow (cache-overflow cache)) ,@wrapper-bindings) (declare (fixnum size field mask)) ,(cond ((cdr wrappers) (emit-greater-than-1-dlap wrappers 'miss value-reg)) (value-reg (emit-1-t-dlap (car wrappers) 'miss value-reg)) (t (emit-1-nil-dlap (car wrappers) 'miss))) (return-from dfun ,hit)) miss (return-from dfun ,miss))))) (defun emit-1-nil-dlap (wrapper miss-label) `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) (location primary)) (declare (fixnum primary location)) (block search (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) (return-from search nil)) (setq location (the fixnum (+ location 1))) (when (= location size) (setq location 0)) (when (= location primary) (dolist (entry overflow) (when (eq (car entry) ,wrapper) (return-from search nil))) (go ,miss-label)))))) (defmacro get-cache-vector-lock-count (cache-vector) `(let ((lock-count (cache-vector-lock-count ,cache-vector))) (unless (typep lock-count 'fixnum) (error "my cache got freed somehow")) (the fixnum lock-count))) (defun emit-1-t-dlap (wrapper miss-label value) `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) (initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum primary initial-lock-count)) (let ((location primary)) (declare (fixnum location)) (block search (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) (setq ,value (cache-vector-ref cache-vector (1+ location))) (return-from search nil)) (setq location (the fixnum (+ location 2))) (when (= location size) (setq location 0)) (when (= location primary) (dolist (entry overflow) (when (eq (car entry) ,wrapper) (setq ,value (cdr entry)) (return-from search nil))) (go ,miss-label)))) (unless (= initial-lock-count (get-cache-vector-lock-count cache-vector)) (go ,miss-label))))) (defun emit-greater-than-1-dlap (wrappers miss-label value) (declare (type list wrappers)) (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) `(let ((primary 0) (size-1 (the fixnum (- size 1)))) (declare (fixnum primary size-1)) ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum initial-lock-count)) (let ((location primary) (next-location 0)) (declare (fixnum location next-location)) (block search (loop (setq next-location (the fixnum (+ location ,cache-line-size))) (when (and ,@(mapcar #'(lambda (wrapper) `(eq ,wrapper (cache-vector-ref cache-vector (setq location (the fixnum (+ location 1)))))) wrappers)) ,@(when value `((setq location (the fixnum (+ location 1))) (setq ,value (cache-vector-ref cache-vector location)))) (return-from search nil)) (setq location next-location) (when (= location size-1) (setq location 0)) (when (= location primary) (dolist (entry overflow) (let ((entry-wrappers (car entry))) (when (and ,@(mapcar #'(lambda (wrapper) `(eq ,wrapper (pop entry-wrappers))) wrappers)) ,@(when value `((setq ,value (cdr entry)))) (return-from search nil)))) (go ,miss-label)))) (unless (= initial-lock-count (get-cache-vector-lock-count cache-vector)) (go ,miss-label))))))) (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) (declare (fixnum wrapper-cache-no)) (when (zerop wrapper-cache-no) (go ,miss-label)) ,(let ((form `(#+lucid %logand #-lucid logand mask wrapper-cache-no))) #+lucid form #-lucid `(the fixnum ,form)))) (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) (declare (type list wrappers)) ;; this returns 1 less that the actual location `(progn ,@(let ((adds 0) (len (length wrappers))) (declare (fixnum adds len)) (mapcar #'(lambda (wrapper) `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) (declare (fixnum wrapper-cache-no)) (when (zerop wrapper-cache-no) (go ,miss-label)) (setq primary (the fixnum (+ primary wrapper-cache-no))) ,@(progn (incf adds) (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) (eql adds len)) `((setq primary ,(let ((form `(#+lucid %logand #-lucid logand primary mask))) #+lucid form #-lucid `(the fixnum ,form)))))))) wrappers)))) ;;; cmu17 note: since std-instance-p is weakened, that branch may run ;;; on non-pcl instances (structures). The result will be the ;;; non-wrapper layout for the structure, which will cause a miss. The "slots" ;;; will be whatever the first slot is, but will be ignored. Similarly, ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. ;;; (defun emit-fetch-wrapper (metatype argument miss-label &optional slot) (ecase metatype ((standard-instance #+new-kcl-wrapper structure-instance) `(cond ((std-instance-p ,argument) ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) (std-instance-wrapper ,argument)) ((fsc-instance-p ,argument) ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) (fsc-instance-wrapper ,argument)) (t (go ,miss-label)))) (class (when slot (error "Can't do a slot reg for this metatype.")) `(wrapper-of-macro ,argument)) ((built-in-instance #-new-kcl-wrapper structure-instance) (when slot (error "Can't do a slot reg for this metatype.")) `(#+new-kcl-wrapper built-in-wrapper-of #-new-kcl-wrapper built-in-or-structure-wrapper ,argument)))) gcl-2.6.14/pcl/gcl_pcl_cpl.lisp0000644000175000017500000002572214360276512014713 0ustar cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; ;;; compute-class-precedence-list ;;; ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. ;;; ;;; The key idea is that we use class-precedence-description (CPD) structures ;;; to store the precedence information as we proceed. The CPD structure for ;;; a class stores two critical pieces of information: ;;; ;;; - a count of the number of "reasons" why the class can't go ;;; into the class precedence list yet. ;;; ;;; - a list of the "reasons" this class prevents others from ;;; going in until after it ;; ;;; A "reason" is essentially a single local precedence constraint. If a ;;; constraint between two classes arises more than once it generates more ;;; than one reason. This makes things simpler, linear, and isn't a problem ;;; as long as we make sure to keep track of each instance of a "reason". ;;; ;;; This code is divided into three phases. ;;; ;;; - the first phase simply generates the CPD's for each of the class ;;; and its superclasses. The remainder of the code will manipulate ;;; these CPDs rather than the class objects themselves. At the end ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs ;;; of the direct superclasses of the class. ;;; ;;; - the second phase folds all the local constraints into the CPD ;;; structure. The CPD-COUNT of each CPD is built up, and the ;;; CPD-AFTER fields are augmented to include precedence constraints ;;; from the CPD-SUPERS field and from the order of classes in other ;;; CPD-SUPERS fields. ;;; ;;; After this phase, the CPD-AFTER field of a class includes all the ;;; direct superclasses of the class plus any class that immediately ;;; follows the class in the direct superclasses of another. There ;;; can be duplicates in this list. The CPD-COUNT field is equal to ;;; the number of times this class appears in the CPD-AFTER field of ;;; all the other CPDs. ;;; ;;; - In the third phase, classes are put into the precedence list one ;;; at a time, with only those classes with a CPD-COUNT of 0 being ;;; candidates for insertion. When a class is inserted , every CPD ;;; in its CPD-AFTER field has its count decremented. ;;; ;;; In the usual case, there is only one candidate for insertion at ;;; any point. If there is more than one, the specified tiebreaker ;;; rule is used to choose among them. ;;; (defmethod compute-class-precedence-list ((root slot-class)) (compute-std-cpl root (class-direct-superclasses root))) (defstruct (class-precedence-description (:conc-name nil) (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str "#" (class-name (cpd-class obj)) (cpd-count obj)))) (:constructor make-cpd ())) (cpd-class nil) (cpd-supers ()) (cpd-after ()) (cpd-count 0 :type fixnum)) (defun compute-std-cpl (class supers) (cond ((null supers) ;First two branches of COND (list class)) ;are implementing the single ((null (cdr supers)) ;inheritance optimization. (cons class (compute-std-cpl (car supers) (class-direct-superclasses (car supers))))) (t (multiple-value-bind (all-cpds nclasses) (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses))))) (defvar *compute-std-cpl-class->entry-table-size* 60) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) (declare (fixnum nclasses)) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) (if (forward-referenced-class-p c) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this ;class before, we can quit. (setf (cpd-class cpd) c) (incf nclasses) (push cpd all-cpds) (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) (dolist (super supers) (walk super (class-direct-superclasses super)))))))) (walk class supers) (values all-cpds nclasses)))) (defun compute-std-cpl-phase-2 (all-cpds) (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) (incf (cpd-count (car supers)) 1) (do* ((t1 supers t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (incf (cpd-count (car t2)) 2) (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (declare (fixnum nclasses)) (let ((candidates ()) (next-cpd nil) (rcpl ())) ;; ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain ;; this list incrementally. ;; (dolist (cpd all-cpds) (when (zerop (cpd-count cpd)) (push cpd candidates))) (loop (when (null candidates) ;; ;; If there are no candidates, and enough classes have been put ;; into the precedence list, then we are all done. Otherwise ;; it means there is a consistency problem. (if (zerop nclasses) (return (reverse rcpl)) (cpl-inconsistent-error class all-cpds))) ;; ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the ;; famous RPG tiebreaker rule. There is some hair here to avoid ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. ;; (setq next-cpd (if (null (cdr candidates)) (prog1 (car candidates) (setq candidates ())) (block tie-breaker (dolist (c rcpl) (let ((supers (class-direct-superclasses c))) (if (memq (cpd-class (car candidates)) supers) (return-from tie-breaker (pop candidates)) (do ((loc candidates (cdr loc))) ((null (cdr loc))) (let ((cpd (cadr loc))) (when (memq (cpd-class cpd) supers) (setf (cdr loc) (cddr loc)) (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; ;;; Support code for signalling nice error messages. ;;; (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" (if (class-name class) (format nil "named ~S" (class-name class)) class) (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))) (cpl-error class "The class ~A is a forward referenced class.~@ The class ~A is ~A." (class-or-name forward-class) (class-or-name forward-class) (if (null (cdr names)) (format nil "a direct superclass of the class ~A" (class-or-name class)) (format nil "reached from the class ~A by following~@ the direct superclass chain through: ~A~ ~% ending at the class ~A" (class-or-name class) (format nil "~{~% the class ~A,~}" (butlast names)) (car (last names)))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) (if (eq c top) (return-from find-superclass-chain (nreverse chain)) (dolist (super (class-direct-superclasses c)) (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class "It is not possible to compute the class precedence list because~@ there ~A in the local precedence relations.~@ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") (format-cycle-reasons (apply #'append reasons))))) (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) (let ((class (cpd-class cpd))) (if (class-name class) (format nil "named ~S" (class-name class)) class)))) (mapcar #'(lambda (reason) (ecase (caddr reason) (:super (format nil "the class ~A appears in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)))) (:in-supers (format nil "the class ~A follows the class ~A in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)) (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) (let ((been-here ()) ;List of classes we have visited. (cycle-reasons ())) (labels ((chase (path) (if (memq (car path) (cdr path)) (record-cycle (memq (car path) (nreverse path))) (unless (memq (car path) been-here) (push (car path) been-here) (dolist (after (cpd-after (car path))) (chase (cons after path)))))) (record-cycle (cycle) (let ((reasons ())) (do* ((t1 cycle t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (let ((c1 (car t1)) (c2 (car t2))) (if (memq c2 (cpd-supers c1)) (push (list c1 c2 :super) reasons) (dolist (cpd all-cpds) (when (memq c2 (memq c1 (cpd-supers cpd))) (return (push (list c1 c2 :in-supers cpd) reasons))))))) (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) (unless (zerop (cpd-count cpd)) (chase (list cpd)))) cycle-reasons))) gcl-2.6.14/pcl/gcl_pcl_precom2.lisp0000644000175000017500000000226014360276512015474 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (precompile-random-code-segments pcl) gcl-2.6.14/pcl/gcl_pcl_methods.lisp0000644000175000017500000016547214360276512015607 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmethod print-object (instance stream) (printing-random-thing (instance stream) (let ((name (class-name (class-of instance)))) (if name (format stream "~S" name) (format stream "Instance"))))) (defmethod print-object ((class class) stream) (named-object-print-function class stream)) (defmethod print-object ((slotd slot-definition) stream) (named-object-print-function slotd stream)) (defun named-object-print-function (instance stream &optional (extra nil extra-p)) (printing-random-thing (instance stream) (if extra-p (format stream "~A ~S ~:S" (capitalize-words (class-name (class-of instance))) (slot-value-or-default instance 'name) extra) (format stream "~A ~S" (capitalize-words (class-name (class-of instance))) (slot-value-or-default instance 'name))))) (defmethod print-object ((mc standard-method-combination) stream) (printing-random-thing (mc stream) (format stream "Method-Combination ~S ~S" (slot-value-or-default mc 'type) (slot-value-or-default mc 'options)))) ;;; ;;; ;;; (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) (declare (ignore slot-names)) (with-slots (allocation class) slotd (setq allocation (if (eq allocation :class) class allocation)))) (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key (allocation :instance)) (declare (ignore slot-names)) (unless (eq allocation :instance) (error "structure slots must have :instance allocation"))) (defmethod inform-type-system-about-class ((class structure-class) (name t)) nil) ;;; ;;; METHODS ;;; ;;; Methods themselves are simple inanimate objects. Most properties of ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-FUNCTION ;;; METHOD-FUNCTION ?? ;;; ;;; (defmethod method-function ((method standard-method)) (or (slot-value method 'function) (let ((fmf (slot-value method 'fast-function))) (unless fmf ; the :before shared-initialize method prevents this (error "~S doesn't seem to have a method-function" method)) (setf (slot-value method 'function) (method-function-from-fast-function fmf))))) (defmethod accessor-method-class ((method standard-accessor-method)) (car (slot-value method 'specializers))) (defmethod accessor-method-class ((method standard-writer-method)) (cadr (slot-value method 'specializers))) (defmethod print-object ((method standard-method) stream) (printing-random-thing (method stream) (if (slot-boundp method 'generic-function) (let ((generic-function (method-generic-function method)) (class-name (capitalize-words (class-name (class-of method))))) (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function (generic-function-name generic-function)) (method-qualifiers method) (unparse-specializers method))) (call-next-method)))) (defmethod print-object ((method standard-accessor-method) stream) (printing-random-thing (method stream) (if (slot-boundp method 'generic-function) (let ((generic-function (method-generic-function method)) (class-name (capitalize-words (class-name (class-of method))))) (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function (generic-function-name generic-function)) (accessor-method-slot-name method) (unparse-specializers method))) (call-next-method)))) ;;; ;;; INITIALIZATION ;;; ;;; Error checking is done in before methods. Because of the simplicity of ;;; standard method objects the standard primary method can fill the slots. ;;; ;;; Methods are not reinitializable. ;;; (defmethod reinitialize-instance ((method standard-method) &rest initargs) (declare (ignore initargs)) (error "Attempt to reinitialize the method ~S.~%~ Method objects cannot be reinitialized." method)) (defmethod legal-documentation-p ((object standard-method) x) (if (or (null x) (stringp x)) t "a string or NULL")) (defmethod legal-lambda-list-p ((object standard-method) x) (declare (ignore x)) t) (defmethod legal-method-function-p ((object standard-method) x) (if (functionp x) t "a function")) (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () (return-from legal-qualifiers-p "Is not a proper list."))) (dolist-carefully (q x improper-list) (let ((ok (legal-qualifier-p object q))) (unless (eq ok t) (return-from legal-qualifiers-p (format nil "Contains ~S which ~A" q ok))))) t)) (defmethod legal-qualifier-p ((object standard-method) x) (if (and x (atom x)) t "is not a non-null atom")) (defmethod legal-slot-name-p ((object standard-method) x) (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") ((keywordp x) "is a keyword and so cannot be bound") ((memq x '(t nil)) "cannot be bound") ((constantp x) "is a constant and so cannot be bound") (t t))) (defmethod legal-specializers-p ((object standard-method) x) (flet ((improper-list () (return-from legal-specializers-p "Is not a proper list."))) (dolist-carefully (s x improper-list) (let ((ok (legal-specializer-p object s))) (unless (eq ok t) (return-from legal-specializers-p (format nil "Contains ~S which ~A" s ok))))) t)) (defvar *allow-experimental-specializers-p* nil) (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* (specializerp x) (or (classp x) (eql-specializer-p x))) t "is neither a class object nor an eql specializer")) (defmethod shared-initialize :before ((method standard-method) slot-names &key qualifiers lambda-list specializers function fast-function documentation) (declare (ignore slot-names)) (flet ((lose (initarg value string) (error "When initializing the method ~S:~%~ The ~S initialization argument was: ~S.~%~ which ~A." method initarg value string))) (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) (check-lambda-list (legal-lambda-list-p method lambda-list)) (check-specializers (legal-specializers-p method specializers)) (check-function (legal-method-function-p method (or function fast-function))) (check-documentation (legal-documentation-p method documentation))) (unless (eq check-qualifiers t) (lose :qualifiers qualifiers check-qualifiers)) (unless (eq check-lambda-list t) (lose :lambda-list lambda-list check-lambda-list)) (unless (eq check-specializers t) (lose :specializers specializers check-specializers)) (unless (eq check-function t) (lose :function function check-function)) (unless (eq check-documentation t) (lose :documentation documentation check-documentation))))) (defmethod shared-initialize :before ((method standard-accessor-method) slot-names &key slot-name slot-definition) (declare (ignore slot-names)) (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) (unless (eq legalp t) (error "The value of the :SLOT-NAME initarg ~A." legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names &rest initargs &key qualifiers method-spec plist) (declare (ignore slot-names method-spec plist)) (initialize-method-function initargs nil method) (setf (plist-value method 'qualifiers) qualifiers) #+ignore (setf (slot-value method 'closure-generator) (method-function-closure-generator (slot-value method 'function)))) (defmethod shared-initialize :after ((method standard-accessor-method) slot-names &key) (declare (ignore slot-names)) (with-slots (slot-name slot-definition) method (unless slot-definition (let ((class (accessor-method-class method))) (when (slot-class-p class) (setq slot-definition (find slot-name (class-direct-slots class) :key #'slot-definition-name))))) (when (and slot-definition (null slot-name)) (setq slot-name (slot-definition-name slot-definition))))) (defmethod method-qualifiers ((method standard-method)) (plist-value method 'qualifiers)) (defvar *the-class-generic-function* (find-class 'generic-function)) (defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) (defmethod print-object ((generic-function generic-function) stream) (named-object-print-function generic-function stream (if (slot-boundp generic-function 'methods) (list (length (generic-function-methods generic-function))) "?"))) (defmethod shared-initialize :before ((generic-function standard-generic-function) slot-names &key (name nil namep) (lambda-list () lambda-list-p) argument-precedence-order declarations documentation (method-class nil method-class-supplied-p) (method-combination nil method-combination-supplied-p)) (declare (ignore slot-names declarations argument-precedence-order documentation lambda-list lambda-list-p)) (when namep (set-function-name generic-function name)) (flet ((initarg-error (initarg value string) (error "When initializing the generic-function ~S:~%~ The ~S initialization argument was: ~A.~%~ It must be ~A." generic-function initarg value string))) (cond (method-class-supplied-p (when (symbolp method-class) (setq method-class (find-class method-class))) (unless (and (classp method-class) (*subtypep (class-eq-specializer method-class) *the-class-method*)) (initarg-error :method-class method-class "a subclass of the class METHOD")) (setf (slot-value generic-function 'method-class) method-class)) ((slot-boundp generic-function 'method-class)) (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD"))) (cond (method-combination-supplied-p (unless (method-combination-p method-combination) (initarg-error :method-combination method-combination "a method combination object"))) ((slot-boundp generic-function 'method-combination)) (t (initarg-error :method-combination "not supplied" "a method combination object"))))) #|| (defmethod reinitialize-instance ((generic-function standard-generic-function) &rest initargs &key name lambda-list argument-precedence-order declarations documentation method-class method-combination) (declare (ignore documentation declarations argument-precedence-order lambda-list name method-class method-combination)) (macrolet ((add-initarg (check name slot-name) `(unless ,check (push (slot-value generic-function ,slot-name) initargs) (push ,name initargs)))) ; (add-initarg name :name 'name) ; (add-initarg lambda-list :lambda-list 'lambda-list) ; (add-initarg argument-precedence-order ; :argument-precedence-order ; 'argument-precedence-order) ; (add-initarg declarations :declarations 'declarations) ; (add-initarg documentation :documentation 'documentation) ; (add-initarg method-class :method-class 'method-class) ; (add-initarg method-combination :method-combination 'method-combination) (apply #'call-next-method generic-function initargs))) ||# ;;; ;;; These three are scheduled for demolition. ;;; (defmethod remove-named-method (generic-function-name argument-specifiers &optional extra) (let ((generic-function ()) (method ())) (cond ((or (null (fboundp generic-function-name)) (not (generic-function-p (setq generic-function (symbol-function generic-function-name))))) (error "~S does not name a generic-function." generic-function-name)) ((null (setq method (get-method generic-function extra (parse-specializers argument-specifiers) nil))) (error "There is no method for the generic-function ~S~%~ which matches the argument-specifiers ~S." generic-function argument-specifiers)) (t (remove-method generic-function method))))) (defun real-add-named-method (generic-function-name qualifiers specializers lambda-list &rest other-initargs) #+copy-&rest-arg (setq other-initargs (copy-list other-initargs)) ;; What about changing the class of the generic-function if there is ;; one. Whose job is that anyways. Do we need something kind of ;; like class-for-redefinition? (let* ((generic-function (ensure-generic-function generic-function-name)) (specs (parse-specializers specializers)) ; (existing (get-method generic-function qualifiers specs nil)) (proto (method-prototype-for-gf generic-function-name)) (new (apply #'make-instance (class-of proto) :qualifiers qualifiers :specializers specs :lambda-list lambda-list other-initargs))) ; (when existing (remove-method generic-function existing)) (add-method generic-function new))) (defun make-specializable (function-name &key (arglist nil arglistp)) (cond ((not (null arglistp))) ((not (fboundp function-name))) ((fboundp 'function-arglist) ;; function-arglist exists, get the arglist from it. (setq arglist (function-arglist function-name))) (t (error "The :arglist argument to make-specializable was not supplied~%~ and there is no version of FUNCTION-ARGLIST defined for this~%~ port of Portable CommonLoops.~%~ You must either define a version of FUNCTION-ARGLIST (which~%~ should be easy), and send it off to the Portable CommonLoops~%~ people or you should call make-specializable again with the~%~ :arglist keyword to specify the arglist."))) (let ((original (and (fboundp function-name) (symbol-function function-name))) (generic-function (make-instance 'standard-generic-function :name function-name)) (nrequireds 0)) (if (generic-function-p original) original (progn (dolist (arg arglist) (if (memq arg lambda-list-keywords) (return) (incf nrequireds))) (setf (gdefinition function-name) generic-function) (set-function-name generic-function function-name) (when arglistp (setf (gf-pretty-arglist generic-function) arglist)) (when original (add-named-method function-name () (make-list nrequireds :initial-element 't) arglist (list :function #'(lambda (args next-methods) (declare (ignore next-methods)) (apply original args))))) generic-function)))) (defun real-get-method (generic-function qualifiers specializers &optional (errorp t)) (let ((hit (dolist (method (generic-function-methods generic-function)) (when (and (equal qualifiers (method-qualifiers method)) (every #'same-specializer-p specializers (method-specializers method))) (return method))))) (cond (hit hit) ((null errorp) nil) (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." generic-function qualifiers specializers))))) ;;; ;;; Compute various information about a generic-function's arglist by looking ;;; at the argument lists of the methods. The hair for trying not to use ;;; &rest arguments lives here. ;;; The values returned are: ;;; number-of-required-arguments ;;; the number of required arguments to this generic-function's ;;; discriminating function ;;; &rest-argument-p ;;; whether or not this generic-function's discriminating ;;; function takes an &rest argument. ;;; specialized-argument-positions ;;; a list of the positions of the arguments this generic-function ;;; specializes (e.g. for a classical generic-function this is the ;;; list: (1)). ;;; (defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)) ;;(declare (values number-of-required-arguments &rest-argument-p ;; specialized-argument-postions)) (let ((number-required nil) (restp nil) (specialized-positions ()) (methods (generic-function-methods generic-function))) (dolist (method methods) (multiple-value-setq (number-required restp specialized-positions) (compute-discriminating-function-arglist-info-internal generic-function method number-required restp specialized-positions))) (values number-required restp (sort specialized-positions #'<)))) (defun compute-discriminating-function-arglist-info-internal (generic-function method number-of-requireds restp specialized-argument-positions) (declare (ignore generic-function) (type (or null fixnum) number-of-requireds)) (let ((requireds 0)) (declare (fixnum requireds)) ;; Go through this methods arguments seeing how many are required, ;; and whether there is an &rest argument. (dolist (arg (method-lambda-list method)) (cond ((eq arg '&aux) (return)) ((memq arg '(&optional &rest &key)) (return (setq restp t))) ((memq arg lambda-list-keywords)) (t (incf requireds)))) ;; Now go through this method's type specifiers to see which ;; argument positions are type specified. Treat T specially ;; in the usual sort of way. For efficiency don't bother to ;; keep specialized-argument-positions sorted, rather depend ;; on our caller to do that. (iterate ((type-spec (list-elements (method-specializers method))) (pos (interval :from 0))) (unless (eq type-spec *the-class-t*) (pushnew pos specialized-argument-positions))) ;; Finally merge the values for this method into the values ;; for the exisiting methods and return them. Note that if ;; num-of-requireds is NIL it means this is the first method ;; and we depend on that. (values (min (or number-of-requireds requireds) requireds) (or restp (and number-of-requireds (/= number-of-requireds requireds))) specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (gathering ((args (collecting))) (iterate ((i (interval :from 0 :below number-required-arguments))) (gather (intern (format nil "Discriminating Function Arg ~D" i)) args))) (when restp `(&rest ,(intern "Discriminating Function &rest Arg"))))) ;;; ;;; ;;; (defmethod generic-function-lambda-list ((gf generic-function)) (gf-lambda-list gf)) (defmethod gf-fast-method-function-p ((gf standard-generic-function)) (gf-info-fast-mf-p (slot-value gf 'arg-info))) (defmethod initialize-instance :after ((gf standard-generic-function) &key (lambda-list nil lambda-list-p) argument-precedence-order) (with-slots (arg-info) gf (if lambda-list-p (set-arg-info gf :lambda-list lambda-list :argument-precedence-order argument-precedence-order) (set-arg-info gf)) (when (arg-info-valid-p arg-info) (update-dfun gf)))) (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest args &key (lambda-list nil lambda-list-p) (argument-precedence-order nil argument-precedence-order-p)) (with-slots (arg-info) gf (if lambda-list-p (if argument-precedence-order-p (set-arg-info gf :lambda-list lambda-list :argument-precedence-order argument-precedence-order) (set-arg-info gf :lambda-list lambda-list)) (set-arg-info gf)) (when (and (arg-info-valid-p arg-info) args (or lambda-list-p (cddr args))) (update-dfun gf)))) ;;; ;;; ;;; (proclaim '(special *lazy-dfun-compute-p*)) (defun set-methods (gf methods) (setf (generic-function-methods gf) nil) (loop (when (null methods) (return gf)) (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) (if (method-generic-function method) (error "The method ~S is already part of the generic~@ function ~S. It can't be added to another generic~@ function until it is removed from the first one." method (method-generic-function method)) (let* ((name (generic-function-name generic-function)) (qualifiers (method-qualifiers method)) (specializers (method-specializers method)) (existing (get-method generic-function qualifiers specializers nil))) ;; ;; If there is already a method like this one then we must ;; get rid of it before proceeding. Note that we call the ;; generic function remove-method to remove it rather than ;; doing it in some internal way. ;; (when existing (remove-method generic-function existing)) ;; (setf (method-generic-function method) generic-function) (pushnew method (generic-function-methods generic-function)) (dolist (specializer specializers) (add-direct-method specializer method)) (set-arg-info generic-function :new-method method) (unless skip-dfun-update-p (when (member name '(make-instance default-initargs allocate-instance shared-initialize initialize-instance)) (update-make-instance-function-table (type-class (car specializers)))) (update-dfun generic-function)) method))) (defun real-remove-method (generic-function method) (if (neq generic-function (method-generic-function method)) (error "The method ~S is attached to the generic function~@ ~S. It can't be removed from the generic function~@ to which it is not attached." method (method-generic-function method)) (let* ((name (generic-function-name generic-function)) (specializers (method-specializers method)) (methods (generic-function-methods generic-function)) (new-methods (remove method methods))) (setf (method-generic-function method) nil) (setf (generic-function-methods generic-function) new-methods) (dolist (specializer (method-specializers method)) (remove-direct-method specializer method)) (set-arg-info generic-function) (when (member name '(make-instance default-initargs allocate-instance shared-initialize initialize-instance)) (update-make-instance-function-table (type-class (car specializers)))) (update-dfun generic-function) generic-function))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) (setq classes (mapcar #'(lambda (class) (if (symbolp class) (find-class class) class)) classes)) (dolist (class classes) (dolist (other-class classes) (unless (eq class other-class) (pushnew other-class (class-incompatible-superclass-list class)))))) (defun superclasses-compatible-p (class1 class2) (let ((cpl1 (class-precedence-list class1)) (cpl2 (class-precedence-list class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) (when (memq ic cpl2) (return-from superclasses-compatible-p nil)))))) (mapc #'proclaim-incompatible-superclasses '(;; superclass class (built-in-class std-class structure-class) ; direct subclasses of pcl-class (standard-class funcallable-standard-class) ;; superclass metaobject (class eql-specializer class-eq-specializer method method-combination generic-function slot-definition) ;; metaclass built-in-class (number sequence character ; direct subclasses of t, but not array standard-object structure-object) ; or symbol (number array character symbol ; direct subclasses of t, but not sequence standard-object structure-object) (complex real) ; direct subclasses of number (float rational) ; direct subclasses of real (integer ratio) ; direct subclasses of rational (list vector) ; direct subclasses of sequence (cons null) ; direct subclasses of list (string bit-vector) ; direct subclasses of vector )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) nil) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) (defmethod specializer-class ((specializer class)) specializer) (defmethod same-specializer-p ((specl1 class-eq-specializer) (specl2 class-eq-specializer)) (eq (specializer-class specl1) (specializer-class specl2))) (defmethod same-specializer-p ((specl1 eql-specializer) (specl2 eql-specializer)) (eq (specializer-object specl1) (specializer-object specl2))) (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) (defvar *in-gf-arg-info-p* nil) (setf (gdefinition 'arg-info-reader) (let ((mf (initialize-method-function (make-internal-reader-method-function 'standard-generic-function 'arg-info) t))) #'(lambda (&rest args) (funcall mf args nil)))) (defun types-from-arguments (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info generic-function) (declare (ignore applyp metatypes nkeys)) (let ((types-rev nil)) (dotimes (i nreq) i (unless arguments (error "The function ~S requires at least ~D arguments" (generic-function-name generic-function) nreq)) (let ((arg (pop arguments))) (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) (unless (eq 't (car mt-tail)) (let ((c-w (class-wrapper class))) (unless c-w (return-from get-wrappers-from-classes nil)) (if (eql nkeys 1) (setq w c-w) (setf (car w-tail) c-w w-tail (cdr w-tail))))) (setq mt-tail (cdr mt-tail))) w)) (defun sdfun-for-caching (gf classes) (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) (compute-applicable-methods-using-types gf types) (function-funcall (get-secondary-dispatch-function1 gf methods types nil t all-applicable-and-sorted-p) nil (mapcar #'class-wrapper classes))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) (method-function-get (or (method-fast-function (car methods)) (method-function (car methods))) :constant-value))) (defun default-secondary-dispatch-function (generic-function) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (let ((methods (compute-applicable-methods generic-function args))) (if methods (let ((emf (get-effective-method-function generic-function methods))) (invoke-emf emf args)) (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) (when (atom y) (return nil)) (unless (eq (car x) (car y)) (return nil)) (setq x (cdr x) y (cdr y)))) (defvar *std-cam-methods* nil) (defun compute-applicable-methods-emf (generic-function) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) (cam-methods (compute-applicable-methods-using-types cam (list `(eql ,generic-function) t)))) (values (get-effective-method-function cam cam-methods) (list-eq cam-methods (or *std-cam-methods* (setq *std-cam-methods* (compute-applicable-methods-using-types cam (list `(eql ,cam) t))))))) (values #'compute-applicable-methods-function t))) (defun compute-applicable-methods-emf-std-p (gf) (gf-info-c-a-m-emf-std-p (gf-arg-info gf))) (defvar *old-c-a-m-gf-methods* nil) (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* (every #'(lambda (old-method) (member old-method methods)) *old-c-a-m-gf-methods*)) (let ((gfs-to-do nil) (gf-classes-to-do nil)) (dolist (method methods) (unless (member method *old-c-a-m-gf-methods*) (let ((specl (car (method-specializers method)))) (if (eql-specializer-p specl) (pushnew (specializer-object specl) gfs-to-do) (pushnew (specializer-class specl) gf-classes-to-do))))) (map-all-generic-functions #'(lambda (gf) (when (or (member gf gfs-to-do) (dolist (class gf-classes-to-do nil) (member class (class-precedence-list (class-of gf))))) (update-c-a-m-gf-info gf))))) (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) (defun update-gf-info (gf) (update-c-a-m-gf-info gf) (update-gf-simple-accessor-type gf)) (defun update-c-a-m-gf-info (gf) (unless (early-gf-p gf) (multiple-value-bind (c-a-m-emf std-p) (compute-applicable-methods-emf gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) (defun update-gf-simple-accessor-type (gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-simple-accessor-type arg-info) (let* ((methods (generic-function-methods gf)) (class (and methods (class-of (car methods)))) (type (and class (cond ((eq class *the-class-standard-reader-method*) 'reader) ((eq class *the-class-standard-writer-method*) 'writer) ((eq class *the-class-standard-boundp-method*) 'boundp))))) (when (and (gf-info-c-a-m-emf-std-p arg-info) type (dolist (method (cdr methods) t) (unless (eq class (class-of method)) (return nil))) (eq (generic-function-method-combination gf) *standard-method-combination*)) type))))) (defun get-accessor-method-function (gf type class slotd) (let* ((std-method (standard-svuc-method type)) (str-method (structure-svuc-method type)) (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) (types (if (eq type 'writer) `(t ,@types1) types1)) (methods (compute-applicable-methods-using-types gf types)) (std-p (null (cdr methods)))) (values (if std-p (get-optimized-std-accessor-method-function class slotd type) (get-accessor-from-svuc-method-function class slotd (get-secondary-dispatch-function gf methods types `((,(car (or (member std-method methods) (member str-method methods) (error "error in get-accessor-method-function"))) ,(get-optimized-std-slot-value-using-class-method-function class slotd type))) (unless (and (eq type 'writer) (dolist (method methods t) (unless (eq (car (method-specializers method)) *the-class-t*) (return nil)))) (let ((wrappers (list (wrapper-of class) (class-wrapper class) (wrapper-of slotd)))) (if (eq type 'writer) (cons (class-wrapper *the-class-t*) wrappers) wrappers)))) type)) std-p))) ;used by optimize-slot-value-by-class-p (vector.lisp) (defun update-slot-value-gf-info (gf type) (unless *new-class* (update-std-or-str-methods gf type)) (when (and (standard-svuc-method type) (structure-svuc-method type)) (flet ((update-class (class) (when (class-finalized-p class) (dolist (slotd (class-slots class)) (compute-slot-accessor-info slotd type gf))))) (if *new-class* (update-class *new-class*) (map-all-classes #'update-class 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) (defvar *standard-slot-boundp-using-class-method* nil) (defvar *structure-slot-value-using-class-method* nil) (defvar *structure-setf-slot-value-using-class-method* nil) (defvar *structure-slot-boundp-using-class-method* nil) (defun standard-svuc-method (type) (case type (reader *standard-slot-value-using-class-method*) (writer *standard-setf-slot-value-using-class-method*) (boundp *standard-slot-boundp-using-class-method*))) (defun set-standard-svuc-method (type method) (case type (reader (setq *standard-slot-value-using-class-method* method)) (writer (setq *standard-setf-slot-value-using-class-method* method)) (boundp (setq *standard-slot-boundp-using-class-method* method)))) (defun structure-svuc-method (type) (case type (reader *structure-slot-value-using-class-method*) (writer *structure-setf-slot-value-using-class-method*) (boundp *structure-slot-boundp-using-class-method*))) (defun set-structure-svuc-method (type method) (case type (reader (setq *structure-slot-value-using-class-method* method)) (writer (setq *structure-setf-slot-value-using-class-method* method)) (boundp (setq *structure-slot-boundp-using-class-method* method)))) (defun update-std-or-str-methods (gf type) (dolist (method (generic-function-methods gf)) (let ((specls (method-specializers method))) (when (and (or (not (eq type 'writer)) (eq (pop specls) *the-class-t*)) (every #'classp specls)) (cond ((and (eq (class-name (car specls)) 'std-class) (eq (class-name (cadr specls)) 'standard-object) (eq (class-name (caddr specls)) 'standard-effective-slot-definition)) (set-standard-svuc-method type method)) ((and (eq (class-name (car specls)) 'structure-class) (eq (class-name (cadr specls)) 'structure-object) (eq (class-name (caddr specls)) 'structure-effective-slot-definition)) (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) (cons (specializer-class spec) (and (classp spec) precompute-p (not (or (eq spec *the-class-t*) (eq spec *the-class-slot-object*) (eq spec *the-class-standard-object*) (eq spec *the-class-structure-object*))) (let ((sc (class-direct-subclasses spec))) (when sc (mapcan #'(lambda (class) (mec-all-classes-internal class precompute-p)) sc)))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) (if (null (cdr classes)) classes (let* ((a-classes (cons nil classes)) (tail classes)) (loop (when (null (cdr tail)) (return (cdr a-classes))) (let ((class (cadr tail)) (ttail (cddr tail))) (if (dolist (c ttail nil) (when (eq class c) (return t))) (setf (cdr tail) (cddr tail)) (setf tail (cdr tail))))))))) (defun mec-all-class-lists (spec-list precompute-p) (if (null spec-list) (list nil) (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p)) (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p))) (mapcan #'(lambda (list) (mapcar #'(lambda (c) (cons c list)) car-all-classes)) all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (metatypes (arg-info-metatypes arg-info)) (wrappers (unless (eq nkeys 1) (make-list nkeys))) (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) (default '(default))) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) (let ((wrappers (get-wrappers-from-classes nkeys wrappers classes metatypes))) (when (and wrappers (eq default (probe-cache cache wrappers default))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) ((eq valuep :constant-value) (value-for-caching generic-function classes))))) (setq cache (fill-cache cache wrappers value t)))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) (mapc #'add-class-list (mec-all-class-lists (method-specializers method) precompute-p)))) cache))) (defmacro class-test (arg class) (cond ((eq class *the-class-t*) 't) ((eq class *the-class-slot-object*) #-(or new-kcl-wrapper cmu17) `(not (eq *the-class-built-in-class* (wrapper-class (std-instance-wrapper (class-of ,arg))))) #+new-kcl-wrapper `(or (std-instance-p ,arg) (fsc-instance-p ,arg)) #+cmu17 `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) #-new-kcl-wrapper ((eq class *the-class-standard-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) #-cmu17 ((eq class *the-class-structure-object*) `(memq ',class (class-precedence-list (class-of ,arg)))) ;; TYPEP is now sometimes faster than doing memq of the cpl (t `(typep ,arg ',(class-name class))))) (defmacro class-eq-test (arg class) `(eq (class-of ,arg) ',class)) (defmacro eql-test (arg object) `(eql ,arg ',object)) (defun dnet-methods-p (form) (and (consp form) (or (eq (car form) 'methods) (eq (car form) 'unordered-methods)))) (defmacro scase (arg &rest clauses) ; This is case, but without gensyms `(let ((.case-arg. ,arg)) (cond ,@(mapcar #'(lambda (clause) (list* (cond ((null (car clause)) nil) ((consp (car clause)) (if (null (cdar clause)) `(eql .case-arg. ',(caar clause)) `(member .case-arg. ',(car clause)))) ((member (car clause) '(t otherwise)) `t) (t `(eql .case-arg. ',(car clause)))) nil (cdr clause))) clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) (defun generate-discrimination-net (generic-function methods types sorted-p) (let* ((arg-info (gf-arg-info generic-function)) (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types #'(lambda (methods known-types) (if (or sorted-p (block one-order-p (let ((sorted-methods nil)) (map-all-orders (copy-list methods) precedence #'(lambda (methods) (when sorted-methods (return-from one-order-p nil)) (setq sorted-methods methods))) (setq methods sorted-methods)) t)) `(methods ,methods ,known-types) `(unordered-methods ,methods ,known-types))) #'(lambda (position type true-value false-value) (let ((arg (dfun-arg-symbol position))) (if (eq (car type) 'eql) (let* ((false-case-p (and (consp false-value) (or (eq (car false-value) 'scase) (eq (car false-value) 'mcase)) (eq arg (cadr false-value)))) (false-clauses (if false-case-p (cddr false-value) `((t ,false-value)))) (case-sym (if (and (dnet-methods-p true-value) (if false-case-p (eq (car false-value) 'mcase) (dnet-methods-p false-value))) 'mcase 'scase)) (type-sym `(,(cadr type)))) `(,case-sym ,arg (,type-sym ,true-value) ,@false-clauses)) `(if ,(let ((arg (dfun-arg-symbol position))) (case (car type) (class `(class-test ,arg ,(cadr type))) (class-eq `(class-eq-test ,arg ,(cadr type))))) ,true-value ,false-value)))) #'identity))) (defun class-from-type (type) (if (or (atom type) (eq (car type) 't)) *the-class-t* (case (car type) (and (dolist (type (cdr type) *the-class-t*) (when (and (consp type) (not (eq (car type) 'not))) (return (class-from-type type))))) (not *the-class-t*) (eql (class-of (cadr type))) (class-eq (cadr type)) (class (cadr type))))) (defun precompute-effective-methods (gf caching-p &optional classes-list-p) (let* ((arg-info (gf-arg-info gf)) (methods (generic-function-methods gf)) (precedence (arg-info-precedence arg-info)) (*in-precompute-effective-methods-p* t) (classes-list nil)) (generate-discrimination-net-internal gf methods nil #'(lambda (methods known-types) (when methods (when classes-list-p (push (mapcar #'class-from-type known-types) classes-list)) (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) (map-all-orders methods precedence #'(lambda (methods) (get-secondary-dispatch-function1 gf methods known-types nil caching-p no-eql-specls-p)))))) #'(lambda (position type true-value false-value) (declare (ignore position type true-value false-value)) nil) #'(lambda (type) (if (and (consp type) (eq (car type) 'eql)) `(class-eq ,(class-of (cadr type))) type))) classes-list)) ; we know that known-type implies neither new-type nor `(not ,new-type) (defun augment-type (new-type known-type) (if (or (eq known-type 't) (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) (cdr known-type) (list known-type)))) (unless (eq (car new-type) 'not) (setq so-far (mapcan #'(lambda (type) (unless (*subtypep new-type type) (list type))) so-far))) (if (null so-far) new-type `(and ,new-type ,@so-far))))) #+lcl3.0 (dont-use-production-compiler) (defun generate-discrimination-net-internal (gf methods types methods-function test-function type-function) #+cmu (declare (type function methods-function test-function type-function)) (let* ((arg-info (gf-arg-info gf)) (precedence (arg-info-precedence arg-info)) (nreq (arg-info-number-required arg-info)) (metatypes (arg-info-metatypes arg-info))) (labels ((do-column (p-tail contenders known-types) (if p-tail (let* ((position (car p-tail)) (known-type (or (nth position types) t))) (if (eq (nth position metatypes) 't) (do-column (cdr p-tail) contenders (cons (cons position known-type) known-types)) (do-methods p-tail contenders known-type () known-types))) (funcall methods-function contenders (let ((k-t (make-list nreq))) (dolist (index+type known-types) (setf (nth (car index+type) k-t) (cdr index+type))) k-t)))) (do-methods (p-tail contenders known-type winners known-types) ;; ;; ;; is a (sorted) list of methods that must be discriminated ;; ;; is the type of this argument, constructed from tests already made. ;; ;; is a (sorted) list of methods that are potentially applicable ;; after the discrimination has been made. ;; (if (null contenders) (do-column (cdr p-tail) winners (cons (cons (car p-tail) known-type) known-types)) (let* ((position (car p-tail)) (method (car contenders)) (specl (nth position (method-specializers method))) (type (funcall type-function (type-from-specializer specl)))) (multiple-value-bind (app-p maybe-app-p) (specializer-applicable-using-type-p type known-type) (flet ((determined-to-be (truth-value) (if truth-value app-p (not maybe-app-p))) (do-if (truth &optional implied) (let ((ntype (if truth type `(not ,type)))) (do-methods p-tail (cdr contenders) (if implied known-type (augment-type ntype known-type)) (if truth (append winners `(,method)) winners) known-types)))) (cond ((determined-to-be nil) (do-if nil t)) ((determined-to-be t) (do-if t t)) (t (funcall test-function position type (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) #+lcl3.0 (use-previous-compiler) (defun compute-secondary-dispatch-function (generic-function net &optional method-alist wrappers) (function-funcall (compute-secondary-dispatch-function1 generic-function net) method-alist wrappers)) (defvar *eq-case-table-limit* 15) (defvar *case-table-limit* 10) (defun compute-mcase-parameters (case-list) (unless (eq 't (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) (unless (or (eq (car case) 't) (symbolp (caar case))) (return nil)))) (len (1- (length case-list))) (type (cond ((= len 1) :simple) ((<= len (if eq-p *eq-case-table-limit* *case-table-limit*)) :assoc) (t :hash-table)))) (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) (unless (or (eq eq-p 't) (null eq-p)) (error "Invalid eq-p argument")) (ecase type (:simple `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) (cdr ,info) ,default)) (:assoc `(dolist (e ,info ,default) (when (,(if eq-p 'eq 'eql) (car e) ,key) (return (cdr e))))) (:hash-table `(gethash ,key ,info ,default)))) (defun net-test-converter (form) (if (atom form) (default-test-converter form) (case (car form) ((invoke-effective-method-function invoke-fast-method-call) '.call.) (methods '.methods.) (unordered-methods '.umethods.) (mcase `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form)))) (t (default-test-converter form))))) (defun net-code-converter (form) (if (atom form) (default-code-converter form) (case (car form) ((methods unordered-methods) (let ((gensym (gensym))) (values gensym (list gensym)))) (mcase (let ((mp (compute-mcase-parameters (cddr form))) (gensym (gensym)) (default (gensym))) (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) (list gensym default)))) (t (default-code-converter form))))) (defun net-constant-converter (form generic-function) (or (let ((c (methods-converter form generic-function))) (when c (list c))) (if (atom form) (default-constant-converter form) (case (car form) (mcase (let* ((mp (compute-mcase-parameters (cddr form))) (list (mapcar #'(lambda (clause) (let ((key (car clause)) (meth (cadr clause))) (cons (if (consp key) (car key) key) (methods-converter meth generic-function)))) (cddr form))) (default (car (last list)))) (list (list* ':mcase mp (nbutlast list)) (cdr default)))) (t (default-constant-converter form)))))) (defun methods-converter (form generic-function) (cond ((and (consp form) (eq (car form) 'methods)) (cons '.methods. (get-effective-method-function1 generic-function (cadr form)))) ((and (consp form) (eq (car form) 'unordered-methods)) (default-secondary-dispatch-function generic-function)))) (defun convert-methods (constant method-alist wrappers) (if (and (consp constant) (eq (car constant) '.methods.)) (funcall (the function (cdr constant)) method-alist wrappers) constant)) (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) (eq (car constant) ':mcase)) (let ((alist (mapcar #'(lambda (k+m) (cons (car k+m) (convert-methods (cdr k+m) method-alist wrappers))) (cddr constant))) (mp (cadr constant))) (ecase (cadr mp) (:simple (car alist)) (:assoc alist) (:hash-table (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) (dolist (k+m alist) (setf (gethash (car k+m) table) (cdr k+m))) table))))))) (defun compute-secondary-dispatch-function1 (generic-function net &optional function-p) (cond ((and (eq (car net) 'methods) (not function-p)) (get-effective-method-function1 generic-function (cadr net))) (t (let* ((name (generic-function-name generic-function)) (arg-info (gf-arg-info generic-function)) (metatypes (arg-info-metatypes arg-info)) (applyp (arg-info-applyp arg-info)) (fmc-arg-info (cons (length metatypes) applyp))) (multiple-value-bind (cfunction constants) (get-function1 (make-dispatch-lambda function-p metatypes applyp `((locally (declare #.*optimize-speed*) (let ((emf ,net)) ,(make-emf-call metatypes applyp 'emf))))) #'net-test-converter #'net-code-converter #'(lambda (form) (net-constant-converter form generic-function))) #'(lambda (method-alist wrappers) (let* ((alist (list nil)) (alist-tail alist)) (dolist (constant constants) (let* ((a (or (dolist (a alist nil) (when (eq (car a) constant) (return a))) (cons constant (or (convert-table constant method-alist wrappers) (convert-methods constant method-alist wrappers))))) (new (list a))) (setf (cdr alist-tail) new) (setf alist-tail new))) (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) (if function-p function (make-fast-method-call :function (set-function-name function `(sdfun-method ,name)) :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) (defun make-unordered-methods-emf (generic-function methods) (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~s~%" (generic-function-name generic-function))) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (let* ((types (types-from-arguments generic-function args 'eql)) (smethods (sort-applicable-methods generic-function methods types)) (emf (get-effective-method-function generic-function smethods))) (invoke-emf emf args)))) ;;; ;;; The value returned by compute-discriminating-function is a function ;;; object. It is called a discriminating function because it is called ;;; when the generic function is called and its role is to discriminate ;;; on the arguments to the generic function and then call appropriate ;;; method functions. ;;; ;;; A discriminating function can only be called when it is installed as ;;; the funcallable instance function of the generic function for which ;;; it was computed. ;;; ;;; More precisely, if compute-discriminating-function is called with an ;;; argument , and returns a result , that result must not be ;;; passed to apply or funcall directly. Rather, must be stored as ;;; the funcallable instance function of the same generic function ;;; (using set-funcallable-instance-function). Then the generic function ;;; can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are ;;; permitted to return a function which itself ends up calling the value ;;; returned by a more specific method. This kind of `encapsulation' of ;;; discriminating function is critical to many uses of the MOP. ;;; ;;; As an example, the following canonical case is legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) ;;; #'(lambda (arg) ;;; (print (list 'call-to-gf gf arg)) ;;; (funcall std arg)))) ;;; ;;; Because many discriminating functions would like to use a dynamic ;;; strategy in which the precise discriminating function changes with ;;; time it is important to specify how a discriminating function is ;;; permitted itself to change the funcallable instance function of the ;;; generic function. ;;; ;;; Discriminating functions may set the funcallable instance function ;;; of the generic function, but the new value must be generated by making ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any ;;; more specific methods which may have encapsulated the discriminating ;;; function will get a chance to encapsulate the new, inner discriminating ;;; function. ;;; ;;; This implies that if a discriminating function wants to modify itself ;;; it should first store some information in the generic function proper, ;;; and then call compute-discriminating-function. The appropriate method ;;; on compute-discriminating-function will see the information stored in ;;; the generic function and generate a discriminating function accordingly. ;;; ;;; The following is an example of a discriminating function which modifies ;;; itself in accordance with this protocol: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; #'(lambda (arg) ;;; (cond ( ;;; ;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) ;;; (t ;;; )))) ;;; ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; #'(lambda (arg) ;;; (cond ( ;;; (set-funcallable-instance-function ;;; gf ;;; #'(lambda (a) ..)) ;;; (funcall gf arg)) ;;; (t ;;; )))) ;;; ;;; NOTE: All the examples above assume that all instances of the class ;;; my-generic-function accept only one argument. ;;; ;;; ;;; ;;; (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) (function-funcall (slot-definition-reader-function slotd) object)) (defun setf-slot-value-using-class-dfun (new-value class object slotd) (declare (ignore class)) (function-funcall (slot-definition-writer-function slotd) new-value object)) (defun slot-boundp-using-class-dfun (class object slotd) (declare (ignore class)) (function-funcall (slot-definition-boundp-function slotd) object)) (defmethod compute-discriminating-function ((gf standard-generic-function)) (with-slots (dfun-state arg-info) gf (typecase dfun-state (null (let ((name (generic-function-name gf))) (when (eq name 'compute-applicable-methods) (update-all-c-a-m-gf-info gf)) (cond ((eq name 'slot-value-using-class) (update-slot-value-gf-info gf 'reader) #'slot-value-using-class-dfun) ((equal name '(setf slot-value-using-class)) (update-slot-value-gf-info gf 'writer) #'setf-slot-value-using-class-dfun) ((eq name 'slot-boundp-using-class) (update-slot-value-gf-info gf 'boundp) #'slot-boundp-using-class-dfun) ((gf-precompute-dfun-and-emf-p arg-info) (make-final-dfun gf)) (t (make-initial-dfun gf))))) (function dfun-state) (cons (car dfun-state))))) (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) #|| (name (generic-function-name gf)) ||# (arg-info (gf-arg-info gf))) (cond #|| ((eq name 'slot-value-using-class) (update-slot-value-gf-info gf 'reader)) ((equal name '(setf slot-value-using-class)) (update-slot-value-gf-info gf 'writer)) ((eq name 'slot-boundp-using-class) (update-slot-value-gf-info gf 'boundp)) ||# ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) (set-dfun gf dfun cache info) ; otherwise cache might get freed twice (update-dfun gf dfun cache info)))))) ;;; ;;; ;;; (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defun method-ll->generic-function-ll (ll) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) (remove-if #'(lambda (s) (or (memq s keyword-parameters) (eq s '&allow-other-keys))) ll))) ;;; ;;; This is based on the rules of method lambda list congruency defined in ;;; the spec. The lambda list it constructs is the pretty union of the ;;; lambda lists of all the methods. It doesn't take method applicability ;;; into account at all yet. ;;; (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) (let ((methods (generic-function-methods generic-function)) (arglist ())) (when methods (multiple-value-bind (required optional rest key allow-other-keys) (method-pretty-arglist (car methods)) (dolist (m (cdr methods)) (multiple-value-bind (method-key-keywords method-allow-other-keys method-key) (function-keywords m) ;; we've modified function-keywords to return what we want as ;; the third value, no other change here. (declare (ignore method-key-keywords)) (setq key (union key method-key)) (setq allow-other-keys (or allow-other-keys method-allow-other-keys)))) (when allow-other-keys (setq arglist '(&allow-other-keys))) (when key (setq arglist (nconc (list '&key) key arglist))) (when rest (setq arglist (nconc (list '&rest rest) arglist))) (when optional (setq arglist (nconc (list '&optional) optional arglist))) (nconc required arglist))))) (defmethod method-pretty-arglist ((method standard-method)) (let ((required ()) (optional ()) (rest nil) (key ()) (allow-other-keys nil) (state 'required) (arglist (method-lambda-list method))) (dolist (arg arglist) (cond ((eq arg '&optional) (setq state 'optional)) ((eq arg '&rest) (setq state 'rest)) ((eq arg '&key) (setq state 'key)) ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) ((memq arg lambda-list-keywords)) (t (ecase state (required (push arg required)) (optional (push arg optional)) (key (push arg key)) (rest (setq rest arg)))))) (values (nreverse required) (nreverse optional) rest (nreverse key) allow-other-keys))) gcl-2.6.14/pcl/notes/0000755000175000017500000000000014360276512012701 5ustar cammcammgcl-2.6.14/pcl/notes/5-22-89-notes.text0000644000175000017500000001242214360276512015561 0ustar cammcammCopyright (c) Xerox Corporation 1989. All rights reserved. These notes correspond to the "5/22/89 Victoria PCL" version of PCL. Please read this entire file carefully. Failure to do so guarantees that you will have problems porting your code from the previous release of PCL. You may also be interested in looking at previous versions of the notes.text file. These are called xxx-notes.text where xxx is the version of the PCL system the file corresponds to. At least the last two versions of this file contain useful information for any PCL user. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2, 7.4 Coral 1.2 Lucid 3.0 IBCL (October 15, 1987) Allegro 3.0.1 Golden Common Lisp 3.1 EnvOS Medley These should work, but haven't been tested yet: TI This release is similar to Cinco de Mayo and Passover PCL. The major difference is that this release actually works. *** *other-exports* flushed. More exports now on *exports* The symbol STANDARD is now exported from the PCL package. standard-class standard-method standard-generic-function standard-object built-in-class structure-class scoping problem with *next-methods* method and generic function initialization protocol methods are immutable type-specifiers --> specializers load-truename etc. defgeneric ensure-generic-function define-method-combination metabraid changes file namings *** There are a number of minor and one major difference between this release and No Cute Name PCL. - In the last release there was an implementation of the specified CLOS initialization protocol. This implementation had the correct behavior, but some of the generic functions had temporary names (*make-instance, *initialize-instance and *default-initargs). This was done to give people time to convert their code to the behavior of the new initialization protocol. In this release, all generic functions in the specified initialization protocol have their proper names. The implementation of the old, obsolete initialization protocol has disappeared entirely. The following renamings have happened: 12/7/88 release this release *make-instance make-instance *initialize-instance initialize-instance *default-initargs default-initargs The functions shared-initialize and reinitialize-instance already had the proper names. The new initialization protocol is documented fully in the 88-002R specification. As part of this change, PCL now uses the new initialization protocol to create metaobjects internally. That is it calls make-instance to create these metaobjects. The actual initargs passed are not yet as specified, that will be in a later release. This is the largest change in this release. If you have not already started using the new initialization protocol (with the temporary *xxx names) you are going to have to do so now. In most cases, old methods on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert them to methods on INITIALIZE and SHARED-INITIALIZE. - slots with :ALLOCATION, :CLASS now inherit properly. As part of this change, some slot description objects now return a class object as the result of SLOTD-ALLOCATION. - There is now a minimal implementation of the DEFGENERIC macro. This implementation supports no options, but it does allow you to define a generic function in one place and put some comments there with it. - The following functions and macros have disappeared. This table also show briefly what you use instead. DEFMETHOD-SETF (use DEFMETHOD) RUN-SUPER (use CALL-NEXT-METHOD) OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) SYMBOL-CLASS (use FIND-CLASS) CBOUNDP (use FIND-CLASS) CLASS-NAMED (use FIND-CLASS) GET-SETF-GENERIC-FUNCTION (use GDEFINITION) - In certain ports, method lookup will be faster because of a new scheme to deal with interrupts and the cache code. In other ports it will be slightly slower. In all ports, the cache code now interacts properly with interrupts. - DEFMETHOD should interact properly with TRACE, ADVISE etc. in most ports. two new port-specific functions (in defs.lisp) implement this. These are unencapsulated-fdefinition and fdefine-carefully. If this doesn't work properly in your port, fix the definition of these functions and send it back so it can be in the next release. - This release runs in Golden Common Lisp version 3.0. - Previously, the use of slot-value (or with-slots) in the body of a method which had an illegal specializer gave strange errors. Now it gives a more reasonable error message. - An annoying problem which caused KCL and friends to complain about *exports* being unbound has been fixed. - The walker has been modified to understand the ccl:%stack-block special form in Coral Common Lisp. - The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. - multiple-value-setq inside of with-slots now returns the correct value. - A minor bug having to do with macroexpansion environments and the KCL walker has been fixed. - A bug in the parsing of defmethod which caused only symbols (rather than non-nil atoms) to be used as qualifiers. gcl-2.6.14/pcl/notes/3-19-87-notes.text0000644000175000017500000001214114360276512015561 0ustar cammcamm These notes correspond to *pcl-system-date* 3/19/87 prime. This release runs in: ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) CMU Lisp (nee Spice) and KCL should be working soon, I will announce another release at that time. I figured it was better to get some people beating on it as soon as possibl. Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. Following is a description of some of the things that are different in this release of PCL. This list isn't in any particular order. There are a number of incompatible changes in this release, please read the whole thing carefully. As usual, please enjoy, and send bug-reports, questions etc. to CommonLoops@Xerox.com. *** The single most significant change is that discriminator-objects with corresponding discriminating functions have been replaced by generic function objects. What does this mean?? Well, in previous releases of PCL, if you did: (defmethod foo ((x class)) 'class) (defmethod foo ((x method)) 'method) Then (discriminator-named 'foo) returned a discriminator object which had both of these methods defined on it. (symbol-function 'foo) returned a discriminating function, which (discriminator-named 'foo) had put in foo's function cell. In this release of PCL, the above defmethod's put a generic-function object in foo's function cell. This generic-function object is a combination of the discriminator object and discriminating function of the previous releases of PCL. This generic-function object is funcallable, funcalling it causes the appropriate method to be looked up and called. This generic function object has accessors which return the methods defined on the generic function. This generic function object is mutable. It is possible to add and remove methods from it. (defmethod foo ((x class)) 'class) (defmethod foo ((x method)) 'method) (generic-function-methods #'foo) (# #) (foo (make 'class)) ==> 'class (foo (make 'method)) ==> 'method (remove-method #'foo (car (generic-function-methods #'foo))) (foo (make 'class)) ==> 'class (foo (make 'method)) ==> no matching method error Note that as part of this change, the name of any function, generic function or class which included the string "DISCRIMINATOR" has changed. The name changes that happened were: The class essential-discriminator was renamed to generic-function, The class basic-discriminator and the class discrimiantor were combined and renamed to standard-generic-function. If you went through your code and made the following name changes, you would probably win, (this is what I did to PCL and it worked). essential-discriminator ==> generic-function basic-discriminator ==> standard-generic-function discriminator (when it appears as a specializer) ==> standard-generic-function discriminator (when it appears as part of a variable name or something) ==> generic-function *** In most Lisp implementations, method lookup is at least twice as fast as it was in the previous release. *** The compiler isn't called when PCL is loaded anymore. In a future release, the compiler will also not be called when any other method definitions are loaded. This is part of an effort to get PCL to a state where the compiler will never be needed when compiled files are loaded. *** PCL now has a mechanism for naming the generic-function's and method functions defined by defmethod. This means that in ports of PCL which take advantage of this mechanism, you will see useful function names in the debugger rather than the useless gensym names that have been in the past few releases. *** Compiled files containing defmethod forms should be smaller and load faster. *** Many of the files in the system have been renamed. More files will be renamed in upcoming releases. *** An important part of the bootstrapping code has been re-written. The remainder of this code (the BRAID1 and BRAID2 files) will be re-written sometime soon. The changes made to bootstrapping in this release were done to make early methods more understandable, and as part of implementing generic function objects. Also, most users should find that PCL loads in less time than it did before. The changes which will be made to bootstrapping in a future release will make understanding the "Braid" stuff easier, and will make it possible to implement slot-description objects as described in the CURRENT DRAFT of the Common Lisp Object System Chapter 3. *** The defsys file has been re-written AGAIN. This shouldn't affect users since there are still the old familiar variables *pcl-pathname-defaults* and *pathname-extensions*. *** The specialized foo-notes files are all gone. Most of them were hopelessly out of date, and installing pcl is now the same operation for any Lisp. In particular, note that in Vaxlisp, it is no longer necessary to push lisp:vaxlisp on the *features* list. gcl-2.6.14/pcl/notes/4-29-87-notes.text0000644000175000017500000000514114360276512015565 0ustar cammcamm These notes correspond to *pcl-system-date* "4/29/87 prime April 29, 1987". The notes from the last release are stored as 4-21-notes.text This release runs in: ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) TI Common Lisp (Release 3) CMU Lisp (nee Spice) should be working soon, I will announce another release at that time. TI release 2 should also be working soon, I will announce that when it happens. Note once again, that Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. You must load PCL BEFORE loading pcl-env. MAJOR CHANGES IN THIS RELEASE: make has been renamed to make-instance make-instance has been renamed to allocate-instance for compatibility, make can continue to be used as a synonym for make-instance. unfortunately, code which used to call make-instance must be converted. I would actually suggest that you do both of these name changes right away. Two passes through the code using Query Replace seems to work quite well (changing make-instance to allocate-instance and then make to make-instance.) I was able to change all of PCL in about 10 minutes that way. --- all functions and generic functions whose name included the string "get-slot" have been renamed. Basically, get-slot was replaced everywhere it appeared with slot-value. get-slot itself still exists for compatibility, but you should start converting your code to use slot-value. OTHER CHANGES in this release: There is a new file called PKG which does the exports for PCL. PCL now exports fewer symbols than before. Specifically, PCL now exports only those symbols documented in the CLOS spec chapters 1 and 2. This means that some symbols which may be needed by some programs are not exported. A good example is print-instance. print-instance is not exported and since print-instance has not yet been renamed to print-object programs which define methods on print-instance may want to import that symbol. --- pcl should load faster in this release. In particular, the file fixup should load in less than half the time it did before. This release should load in something like 80% of the time it took in the last release. Remember, these numbers are only for comparison, your mileage may vary. --- This release of PCL, as well as the last one, has *pcl-system-date* which presents the date in both mm/dd/yy and Month day year format. gcl-2.6.14/pcl/notes/12-7-88-notes.text0000644000175000017500000000262114360276512015561 0ustar cammcammCopyright (c) Xerox Corporation 1988. All rights reserved. These notes correspond to the "12/7/88 Can't think of a cute name PCL" version of PCL. Please read this entire file carefully. You may also be interested in looking at previous versions of the notes.text file. These are called xxx-notes.text where xxx is the version of the PCL system the file corresponds to. At least the last two versions of this file contain useful information for any PCL user. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2 Coral 1.2 Lucid 3.0 KCL (October 15, 1987) Allegro 3.0.1 These three should work, but haven't been tested just yet. EnvOS Medley TI The notes file hasn't yet been fleshed out yet. The two major changes in this release are: - The generic function cache algorithm has been revised. In addition generic function caches now expand automatically. Programs that used to run into problems with lots of cache misses shouldn't run into those problems anymore. - the DEFCONSTRUCTOR hack now works. Please see the construct.lisp file for details. If you are consing lots of instances, you may be able to get a tremendous performance boost by using this hack. Another important change is that this version includes some KCL patches which dramatically improve PCL performance in KCL. See the kcl-mods.text file for more details. gcl-2.6.14/pcl/notes/4-21-87-notes.text0000644000175000017500000000313614360276512015557 0ustar cammcamm These notes correspond to *pcl-system-date* "4/21/87 April 21rst 1987". The notes from the last release are stored as 3-19-notes.text This release runs in: ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) CMU Lisp (nee Spice) should be working soon, I will announce another release at that time. Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. The major difference in this release is that defclass conforms to the CLOS specification (pretty much I hope). Previous warnings about what would happen when defclass became CLOS defclass now apply. Once major difference is that PCL currently does require that all a classes superclasses be defined when a defclass form is evaluated. This will change sometime soon. Other small changes include: Some more of the files have been renamed and restructured (as promised). the defclass parsing protocol has changed slotd datastructures are now instances of the class standard-slot-description. a performance bug in the ExCL port which causes method lookup and slot access to cons needlessly. a bug in the 3600 port which broke the printer for stack consed closures make-specializable a bug in Lucid lisp which made it impossible to say (compile-pcl) has been patched around, this is the bug that manifested itself as NAME being ubound. As usual, please enjoy and send comments. gcl-2.6.14/pcl/notes/8-28-88-notes.text0000644000175000017500000005003014360276512015566 0ustar cammcammCopyright (c) Xerox Corporation 1988. All rights reserved. These notes correspond to the "8/24/88 (beta) AAAI PCL" version of PCL. Please read this entire document carefully. There have been a number of changes since the 8/2/88 version of PCL. As usual, these changes are part of our efforts to make PCL conform with the CLOS specicification (88-002R). This release contains the big changes which the 7/7 through 8/2 releases were really getting ready for. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2 Coral 1.2 Lucid 3.0 Franz ?? Xerox Lyric Xerox Medley (aka EnvOS Medley) KCL (October 15, 1987) Most of the changes in this version of PCL fall into one of two categories. The first major set of changes makes the order of arguments to setf generic functions and methods conform with the spec. In addition, these changes allow the first argument to defmethod to be of the form (SETF ). The second major set of changes have to do with slot access and instance structure. Importantly, PCL now checks to see if a slot is bound, and calls slot-unbound if the slot is unbound. This is a major change from previous releases in which slot access just returned NIL for slots which had not yet been set. These changes affect all the functions which access the slots of an instance. In addition, the generic functions which are called by the slot access functions in exceptional circumstances are affected. This set of changes also include the implemenentation of the real initialization protocol as specified by 88-002R. In addition, there are a number of other changes. The most significant of these has to do with the symbols which the PCL package exports by default. The rest of this document goes on to first describe the slot access changes, then describe the setf generic function changes, and finally describe some of the other minor changes. At the very end of this file is a new section which lists PCL features which are scheduled to disappear in future releases. Please read this section and take it to heart. This features will be disappearing. *** Changes to slot access and instance structure *** This release includes a number of changes to the way slot access works in PCL. Some of these changes are incompatible with old behavior. Code which was written with the actual CLOS spec in mind should not be affected by these incompatible changes, but some older code may be affected. The basic thrust of the changes to slot access is to bring the following functions and generic functions in line with the specification: slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound slot-value slot-boundp-using-class slot-exists-p-using-class slot-makunbound-using-class slot-value-using-class (setf slot-value) (setf slot-value-using-class) change-class make-instances-obsolete make-instance (temporarily called *make-instance) initialize-instance (temporarily called *initialize-instance) reinitialize-instance update-instance-for-different-class update-instance-for-redefined-class shared-initialize In this release, these functions accept the specified number of arguments, return the specified values, have the specified effects, and are called by the rest of PCL in the specified way at the specified times (with the exception that PCL does not yet call *make-instance to create its own metaobjects). Because PCL now checks for unbound slots, you may notice a slight performance degradation in certain applications. For complete information, you should of course see the CLOS specification. The rest of this note is a short summary of how this new behavior is different from the last release. - Dynamic slots are no longer supported. Various functions like slot-value-always and remove-slot no longer exist. Also, slot-value-using-class now only accepts the three arguments as described in the spec. The two extra arguments having to do with dynamic slots are no longer accepted. Shortly, we will release a metaclass which provides the now missing dynamic slot behavior. - slot-missing now receives and accepts different arguments. - slot-unbound is now implemented, and is called at the appropriate times. - the initialization protocol specified in 88-002R is now almost completely implemented. The only difference is that the current implementation does not currently check the validity of initargs. So, no errors are signalled in improper initargs are supplied. Because of name conflicts with the two other initialization protocols PCL currently supports, some of the specified initialization functions do not have their proper name. The mapping between names in the specification and names in this version of PCL is as follows: SPECIFIED IN PCL make-instance *make-instance initialize-instance *initialize-instance reinitialize-instance update-instance-for-different-class update-instance-for-redefined-class shared-initialize In a future release of PCL, these functions will have their proper names, and all the old, obsolete initialization protocols will disappear. Convert to using this new wonderful initialization protocol soon. Sometime soon we will release a version of PCL which does significant optimization of calls to make-instance. This should speed up instance creation dramatically, which should significantly improve the performance of some programs. - The function all-slots no longer exists. There is a new generic function called slots-to-inspect, which controls the default behavior of describe. It also controls the default behavior of the inspector in ports which have connected their inspectors to PCL. It specifies which slots of a given class should be inspected. See the definition in the file high.lisp for more. - the metaclass obsolete-class no longer exists. The mechanism by which instances are marked as being obsolete is now internal, as described in the spec. The generic-function make-instances-obsolete can be used to force the instances of a class to go through the obsolete instance update protocol (see update-instance-for-redefined-class). - all-std-class-readers-miss-1, a generic function which was part of the database interface code I sent out a few weeks ago, has a slightly different argument list. People using the code I sent out a few weeks ago should replace the definition there with: (defmethod all-std-class-readers-miss-1 ((class db-class) wrapper slot-name) (declare (ignore wrapper slot-name)) ()) - The implementation of the slot access generic functions have been considerably streamlined. The impenetrable macrology which used to be used is now gone. - Because the behavior of the underlying slot access generic functions has changed, it is possible that some user code which hacks the underlying instance structure may break. Most of this code shouldn't break though. There have been some questions on the mailing list about what is the right way to modify the structure of an instance. I am working on that section of chapter 3 right now, and will answer those questions sometime soon. *** Changes to SETF generic functions *** This release of PCL includes a significant change related to the order of arguments of setf generic functions. To most user programs, this change should be invisible. Your program should run just fine in the new version of PCL. Even so, there is some conversion you should do to your program, since DEFMETHOD-SETF is now obsolete and will be going away soon. Some programs may take some work to adapt to this change. This will be particularly true of programs which manipulated methods for setf generic-functions using make-instance, add-method and friends. Included here is a brief overview of this change to PCL. Most people will find that this is all they need to know about this change. The CLOS specification assumes a default behavior for SETF in the absence of any defsetf or define-modify-macro. The default behavior is to expand forms like: (SETF (FOO x y) a) into: (FUNCALL #'(SETF FOO) a x y) The key point is that by default, setf expands into a call to a function with a well-defined name, and that in that call, the new value argument comes before all the other arguments. This requires a change in PCL, because previously, PCL arranged for the new-value argument to be the last required argument. This change affects the way automatically generated writer methods work, and the way that defmethod with a first argument of the form (SETF ) works. An important point is that I cannot implement function names of the form (SETF ) portably in PCL. As a result, in PCL, I am using names of the form |SETF FOO|. Note that the symbol |SETF FOO| is interned in the home package of the symbol FOO. (See the description of the GET-SETF-FUNCTION and GET-SETF-FUNCTION-NAME). The user-visible changes are: - DEFMETHOD will accept lists of the form (SETF FOO) as a first argument. This will define methods on the generic function named by the symbol |SETF FOO|. As specified in the spec, these methods should expect to receive the new-value as their first argument. Calls to defmethod of this form will also arrange for SETF of FOO to expand into an appropriate call to |SETF FOO|. - Automatically generated writer methods will expect to receive the new value as their first argument. - DEFMETHOD-SETF will also place the new-value as the first argument. This is for backward compatibility, since defmethod-setf itself will be obsolete, and you should convert your code to stop using it. - GET-SETF-FUNCTION is a function which takes a function name and returns the setf function for that function if there is one. Note that it doesn't take an environment argument. Note that this function is not specified in Common Lisp or CLOS. PCL will continue to support it as an extra export indefinetely. - GET-SETF-FUNCTION-NAME is a function which takes a function name and returns the symbol which names the setf function for that function. Note that this function is not specified in Common Lisp or CLOS. PCL will continue to support it as an extra export indefinetely. - For convenience, PCL defines a macro called DO-STANDARD-DEFSETF which can be used to do the appropriate defsetf. This may be helpful for programs which have calls to setf of a generic-function before any of the generic function's method definitions. A use of this macro looks like: (do-standard-defsetf position-x) Afterwards, a form like (SETF (POSITION-X P) V) will expand into a form like (|SETF POSITION-X| V P). The reason you may have to use do-standard-defsetf is that I cannot portably change every implementations SETF to have the new default behavior. The proper way to use this is to take an early file in your system, and put a bunch of calls to do-standard-defsetf in it. Note that as soon as PCL sees a defmethod with a name argument of the form (SETF FOO), or it sees a :accessor in a defclass, it will do an appropriate do-standard-defsetf for you. In summary, the only things that will need to be changed in most programs is that uses of defmethod-setf should be converted to appropriate uses of defmethod. Here is an example of a typical user program which is affected by this change. (defclass position () ((x :initform 0 :accessor pos-x) (y :initform 0 :accessor pos-y))) (defclass monitored-position (position) ()) (defmethod-setf pos-x :before ((p monitored-position)) (new) (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) (defmethod-setf pos-y :before ((p monitored-position)) (new) (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) To bring this program up to date, you should convert the two defmethod-setf forms as follows: (defmethod (setf pos-x) :before (new (p monitored-position)) (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) (defmethod (setf pos-y) :before (new (p monitored-position)) (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) *** Other changes in this release *** * The symbols exported by the PCL package have now changed. The PCL package now exports the symbols listed in the table of contents of chapter 2 of the spec. This list of symbols is the value of the variable pcl::*exports*. Following is the list of symbols which were exported in the 8/2/88 version but which are not exported in the 8/18/88 version. DEFMETHOD-SETF DEFGENERIC-OPTIONS DEFGENERIC-OPTIONS-SETF CLASS-CHANGED CLASS-NAMED SYMBOL-CLASS CBOUNDP GET-METHOD GET-SETF-GENERIC-FUNCTION MAKE-METHOD-CALL Following is the list of symbols which are exported in the 8/18/88 version, but which were not exported in previous versions: CALL-METHOD CLASS-NAME COMPUTE-APPLICABLE-METHODS DEFGENERIC ENSURE-GENERIC-FUNCTION FIND-METHOD FUNCTION-KEYWORDS GENERIC-FLET GENERIC-LABELS INITIALIZE-INSTANCE MAKE-INSTANCES-OBSOLETE NO-APPLICABLE-METHOD NO-NEXT-METHOD REINITIALIZE-INSTANCE SHARED-INITIALIZE SLOT-BOUNDP SLOT-EXISTS-P SLOT-MAKUNBOUND SLOT-MISSING SLOT-UNBOUND SYMBOL-MACROLET UPDATE-INSTANCE-FOR-DIFFERENT-CLASS UPDATE-INSTANCE-FOR-REDEFINED-CLASS WITH-ADDED-METHODS It should be noted that not all of these newly exported symbols have been "implemented" yet. * Any program written using PCL will need to be completely recompiled to run with this release of PCL. * The generic-function generic-function-pretty-arglist now returns a nice arglist for any generic function. It combines all the keyword arguments accepted by the methods to get the combined set of keywords. In some ports, the environment specific ARGLIST function has been connected to this, and so the environments will print out nice arglists for generic functions. * Some bugs in trace-method have been fixed. Trace-method should now work in all ports of PCL. * NO-MATCHING-METHOD has been renamed to NO-APPLICABLE-METHOD. In addition, it now receives arguments as specified. * defmethod has been modified to allow macros which expand into declarations. * The :documentation slot option is now accepted in defclass forms. The documentation string put here cannot yet be retrieved using the documentation function. That will happen in a later release. * The :writer slot option is now implemented. * Some brain damage in high.lisp which caused method lookup to work incorrectly for built in classes. In addition, it caused the class-local-supers and class-direct-subclasses of the built in classes to be strange. People using CLOS browsers should notice this change dramatically, as it will make the browse of the built in part of the class lattice look right. *** Older Changes *** Following are changes which appeared in release of PCL from 7/7/88 to 8/2/88. Each change is marked with the release it appeared in. 8/2/88 Loading defclass forms should be much faster now. The bug which caused all the generic functions in the world to be invalidated whenever a class was defined has now been fixed. Loading defmethod forms should also be much faster. A bug which caused a tremendous amount of needles computation whenever a method was also fixed. 8/2/88 A bug which caused several slots of the classes T, OBJECT, CLASS and STANDARD-CLASS to be unbound has been fixed. 8/1/88 load-pcl now adds the symbols :PCL and :PORTABLE-COMMONLOOPS to *features*. PCL still doesn't do any sort of call to PROVIDE because of the total lack of uniformity in the behavior of require and provide in the various common lisp implementations. 8/1/88 This version of PCL finally fixes the horrible bug that prevented the initform for :class allocation slots from being evaluated when the class was defined. 7/20/88 PCL now converts the function describe into a generic function of one argument. This is to bring it into conformance with the spec as described in 88-002. In Symbolics Genera, it is actually a function of one required and one optional argument. This is because the 3600 sometimes calls describe with more than one argument. In Lucid Lisp, describe only takes an optional argument. This argument defaults to the value of *. PCL converts describe to a generic function of one required argument so it is not possible to call describe with only one argument. 7/7/88 class-named and symbol-class have been replaced by find-class. find-class is documented in 88-002R. 7/7/88 with-slots and with-accessors now conform to 88-002R. The old definition of with-slots is now called obsolete-with-slots. The same is true for with-accessors. with-slots ---> obsolete-with-slots with-accessors --> obsolete-with-accessors The temporary correct definition of with-slots, with-slots* is now called with-slots. The same is true for with-accessors*. with-slots* --> with-slots with-accessors* -> with-accessors 7/7/88 The class-precedence list of the class null now conforms to 88-002R. In previous releases of PCL, the class precedence-list of the class null was: (null list symbol sequence t). In this release the class precedence list of the class null is: (null symbol list sequence t). This change was made to bring PCL into conformance with the spec. 7/7/88 print-object now takes only two arguments. This changes was made to begin bringing print-object in conformance with 88-002R. print-object conforms to the spec to the extent that is is called at the approrpiate times for PCL instances. In most implementations, it is not called at the appropriate times for other instances. This is not under my control, encourage your vendor to provide the proper support for print-object. 7/7/88 This version of PCL now includes a beta test version of a new iteration package. This iteration package was designed by Pavel Curtis and implemented by Bill vanMelle. This iteration package is defined in the file iterate.lisp. Please feel free to experiment with it. We are all very interested in comments on its use. *** PCL Features that will be disappearing *** This section describes features in PCL that will be disappearing in future releases. For each change, I try to give a release date after which I will feel free to remove this feature. This list should not be considered complete. Certain other PCL features will disappear as well. The items on this list are the user-interface level items that it is possible to give a lot of warning about. Other changes will have more subtle effects, for example when the lambda-list congruence rules are implemented. - :accessor-prefix in defclass Can disappear anytime after 8/29. Warning that this is obsolete has been out for some time. You should use :accessor in each of the slot specifications of the defclass form. It is true that this is slightly more cumbersome, but the semantic difficulties associated with :accesor-prefix are even worse. - :constructor in defclass Can disappear anytime after 8/29. Warning that this is obsolete has been out for some time. It will be disappearing shortly because the intialization protocol which it goes with will be disappearing. A future release of PCL will support a special mechanism for defining functions of the form: (defun make-foo (x y &optional z) (make-instance 'foo 'x x :y y :z z)) In the case where there are only :after methods on initialize-instance and shared-initialize, these functions will run like the wind. We hope to release this facility by 9/15. - old definition of make-instance, intialize, initialize-from-defaults, initialize-from-init-plist Can disappear anytime after 8/29. Convert to using the new initialization protocol as described in the spec and above. - mki, old definition of initialize-instance Can disappear anytime after 8/29. Convert to using the new initialization protocol as described in the spec and above. - defmethod-setf Can disappear anytime after 9/15. Convert to using (defmethod (setf foo) ... gcl-2.6.14/pcl/notes/get-pcl.text0000644000175000017500000001362514360276512015151 0ustar cammcammHere is the standard information about PCL. I have also added you to the CommonLoops@Xerox.com mailing list. Portable CommonLoops (PCL) started out as an implementation of CommonLoops written entirely in CommonLisp. It is in the process of being converted to an implementation of CLOS. Currently it implements a only a subset of the CLOS specification. Unfortunately, there is no detailed description of the differences between PCL and the CLOS specification, the source code is often the best documentation. Currently, PCL runs in the following implementations of Common Lisp: EnvOS Medley Symbolics (Release 7.2) Lucid (3.0) ExCL (Franz Allegro 3.0.1) KCL (June 3, 1987) AKCL (1.86, June 30, 1987) Ibuki Common Lisp (01/01, October 15, 1987) TI (Release 4.1) Coral Common Lisp (Allegro 1.2) Golden Common Lisp (3.1) CMU VAXLisp (2.0) HP Common Lisp Pyramid Lisp There are several ways of obtaining a copy of PCL. *** Arpanet Access to PCL *** The primary way of getting PCL is by Arpanet FTP. The files are stored on arisia.xerox.com. You can copy them using anonymous FTP (username "anonymous", password "anonymous"). There are several directories which are of interest: /pcl This directory contains the PCL sources as well as some rudimentary documentation (including this file). All of these files are combined into a single Unix TAR file. The name of this file is "tarfile". Extract the individual files from this tarfile by saying: tar -xf tarfile * where `tarfile' is the name you have given the tarfile in your directory. Once you have done this, the following files are of special interest: readme.text READ IT notes.text contains notes about the current state of PCL, and some instructions for installing PCL at your site. You should read this file whenever you get a new version of PCL. get-pcl.text contains the latest draft of this message /pcl/doc This directory contains TeX source files for the most recent draft of the CLOS specification. There are TeX source files for two documents called concep.tex and functi.tex. These correspond to chapter 1 and 2 of the CLOS specification. /pcl/archive This directory contains the joint archives of two important mailings lists: CommonLoops@Xerox.com is the mailing list for all PCL users. It carries announcements of new releases of PCL, bug reports and fixes, and general advice about how to use PCL and CLOS. Common-Lisp-Object-System@Sail.Stanford.edu is a small mailing list used by the designers of CLOS. The file cloops.text is always the newest of the archive files. The file cloops1.text is the oldest of the archive files. Higher numbered versions are more recent versions of the files. *** Getting PCL on Macintosh floppies *** PCL is listed in APDAlog. It is distributed on Macintosh floppies. This makes it possible for people who don't have FTP access to arisia (but who do have a Macintosh) to get PCL. For $40 you receive a version of PCL and a copy of the CLOS spec (X3J13 document number 88-002R). The APDAlog catalog number is T0259LL/A and you can order by calling: From the U.S. (800)282-2732 From Canada (800)637-0029 International (408)562-3910 FAX (408)562-3971 NOTE: Whenever there is a new release of PCL you want, you should probably wait a couple of months before ordering it from APDAlog. We want to let new PCL's stabilize a bit before sending it to them, and it will take them some time to integrate the new disks into their distribution. *** Using the BITFTP server at Princeton *** For people who can't FTP from Internet (Arpanet) hosts, but who have mail access to the BITNET, there exists a way to get the PCL files using the BITFTP service provided by Princeton University. If you know exactly where to find the files that interest you, this is quite easy. In particular, you have to know: * the Internet host name of the host that maintains the files (such as `arisia.Xerox.COM') * the directory where to find the files, relative to the root of the FTP tree (i.E. `pub') * whether the files are binary or ASCII text. * the names of the files (say `pcl90.tar.Z' and `pcl90.README') To do this, send a message to BITFTP@PUCC (or BITFTP@PUCC.BITNET if you aren't on BITNET itself). The subject line of the message will be ignored. The text (body) of the message should be: FTP arisia.xerox.com UUENCODE CD pcl BINARY GET tarfile QUIT Then you wait (probably for about a day when you are in Europe) and eventually you will receive E-Mail messages from BITFTP@PUCC (or BITFTP2%PUCC...) with subject lines like `uudecoded file tarfile part 13'. Then you have to carefully concatenate the contents of ALL of these files in the correct order. Note: The following works on our Suns and should work on any Berkeley UNIX machine. If you don't have the `compress' or `zcat' program, you can get a free version (with MIT's X Window System distribution, for example). The resulting file can be `uudecode'd like this: dagobert% uudecode name-of-the-assembled-file This will give you a file tarfile.Z (it may actually have a different name; then you may want to rename it in the first place). The `.Z' at the end means that the file you now have is compressed. You can uncompress it with `uncompress tarfile. You can untar the uncompressed file with `tar -xvf tarfile'. This will write all files in the tarfile to the current directory. If you want to know more about the BITFTP service, send a letter to `BITFTP@PUCC' that contains the single line `HELP'. *** Xerox Internet Access to PCL *** Xerox XNS users can get PCL from {NB:PARC:XEROX} Send any comments, bug-reports or suggestions for improvements to: CommonLoops.pa@Xerox.com Send mailing list requests or other administrative stuff to: CommonLoops-Request@Xerox.com Thanks for your interest in PCL. ---------- gcl-2.6.14/pcl/notes/readme.text0000644000175000017500000000067514360276512015054 0ustar cammcammPlease read the file get-pcl.text carefully, it contains the most up to date version of the message you received when you first asked about PCL. You should read it when you get each new release because it will contain any new information about PCL distribution or documentation. Also whenever there is a new release, you should read the notes.text file carefully. To install PCL at your site, follow the instructions in the defsys.lisp file. gcl-2.6.14/pcl/notes/5-22-87-notes.text0000644000175000017500000000665314360276512015570 0ustar cammcamm These notes correspond to *pcl-system-date* "5/22/87 May 22nd, 1987". The notes from the last release are stored as 4-29-notes.text This release runs in: CMU Lisp ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) TI Common Lisp (Release 3) TI release 2 should also be working soon, I will announce that when it happens. Note once again, that Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. You must load PCL BEFORE loading pcl-env. MAJOR CHANGES IN THIS RELEASE: --- it is possible to forward reference classes in a defclass (or add-named-class) form. This means it is possible to say: (defclass foo (bar) (i j k)) (defclass bar () (x y z)) Rather than having to put the in the "right" order. NOTE: the full-on error checking for this is not finished yet. don't try to break it by doing things like: (defclass foo (bar) (i j k)) (make-instance 'foo) (defclass bar () (x y z)) --- print-instance has been renamed to print-object --- the defclass and class-definition protocol has changed. some of the effects of this change are: * ADD-NAMED-CLASS is a true functional interface for defclass, so for example, (defclass foo () (x y z) (:accessor-prefix foo-)) is equivalent to: (add-named-class (class-prototype (class-named 'class)) 'foo () '(x y z) '((:accessor-prefix foo-))) * defclass (and add-named-class) now undefined accessor methods, reader methods and constructors which 'went away'. For example: (defclass foo () (x y z) (:reader-prefix foo-)) defines methods on the generic functions foo-x foo-y and foo-z. but if you then evaluated the defclass form: (defclass foo () (x y z)) those reader methods will be removed from the generic functions foo-x foo-y and foo-z. Similarly constructors which 'went away' will be undefined. --- writer methods generated by the :accessor and :accessor-prefix options now pay attention to the :type slot-option. So, (defclass foo () ((x :accessor foo-x :type symbol))) (defvar *foo-1* (make-instance 'foo)) (setf (foo-x *foo-1*) 'bar) ; is OK (setf (foo-x *foo-1*) 10) ; signals an error --- There are fewer built-in classes. Specifically, only the following Common Lisp types have classes: ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT INTEGER LIST NULL NUMBER RATIO RATIONAL SEQUENCE STRING SYMBOL T VECTOR * In a future release the subtypes of FLOAT may have classes, that issue is still under discussion. * Some ports of PCL also define classes for: HASH-TABLE PACKAGE PATHNAME RANDOM-STATE READTABLE STREAM it depends on how the type is represented in that Lisp's type system. --- The with-slots option :use-slot-value is now obsolete. You should use the :use-accessors option as specified in the CLOS spec instead. with-slot forms which did not use the :use-slot-value option are OK, you don't have to touch them. with-slot forms which used :USE-SLOT-VALUE T should be changed to say :USE-ACCESSORS NIL. with-slot forms which used :USE-SLOT-VALUE NIL should be changed to use neither option, or if you insist :USE-ACCESSORS T gcl-2.6.14/pcl/notes/3-17-88-notes.text0000644000175000017500000001443414360276512015567 0ustar cammcammCopyright (c) Xerox Corporation 1988. All rights reserved. These notes correspond to the beta test release of March 17th 1988. Later versions of this release will run in the usual lisps, but for the time being this has only been tested in Symbolics, Lucid, Coral, Xerox, Ibuki (01/01), TI and VAXLisp Common Lisps. Note may not run in all Franz Lisps, I believe it runs on the SUN3 though. I will get back to this in a few days when I get the needed code from Franz. *** This release will run in Lucid 3.0 beta 2, with the boolean.lbin patch. *** This release contains a prototype implementation of the make-instance behavior documented in the CLOS specification (X3J13 document # 88-002). This prototype implementation does not provide high performance, but it should conform to the specification with one exception, it does not check the validity of the initargs. All the generic functions in the instance creation protocol are as specified in the CLOS specification except that make-instance is called mki instead. This name is a temporary name, it is so that people can try out the new make-instance protocol without having to convert all their code at once. In a future release, the name make-instance will be switched to the new behavior. *** Standard method combination is supported. General declarative method combination is not yet supported, so define-method-combination does not yet work, but standard method combination is what generic functions do by default now. :after :before :around and unqualified methods are supported. Error checking is minimal. *** call-next-method works with standard-method-combination. call-next-method is much faster than it was before, and call-next-method behaves as a lexically defined function. This means it is possible to pass around funargs which include call-next-method. *** All uses of slot-value within a method body should be optimized. It should no longer be necessary to use with-slots just to get the optimization. *** There are new macros with-slots* and with-accessors*. These correspond to the macros which will appear in the final specification, with-slots and with-accessors. They work as follows: (with-slots* ((x x-slot) (y y-slot)) ===\ (let ((#:g1 (foo))) (foo) ===/ (swapf (slot-value #:g1 'x-slot) (swapf x y)) (slot-value #:g1 'y-slot))) (with-accessors* ((x position-x) (y position-y)) ===\ (let ((#:g1 (foo))) (foo) ===/ (incf (position-x #:g1)) (incf x) (incf (position-y #:g1))) (incf y)) As an abbreviation, the ( ) pairs in with-slots* can be abbreviated to just when the variable and slot name are the same. This means that: (with-slots* (x y z) &body ) is equivalent to: (with-slots* ((x x) (y y) (z z)) &body ) You should begin to convert your code to use these macros as soon as possible since the old macro with-slots will swap names with with-slots* sometime soon. A trick you may want to use for remembering the order of the first two arguments to with-slots* and with-accessors* is that it is "like multiple-value-bind". *** In addition this release includes the beginnings of support for doing some of the compiling which PCL does a load time at compile time instead. To use this support, put the form: (pcl::precompile-random-code-segments) in a file which is compiled after all your other pcl using files are loaded. Then arrange for that file to be loaded before all your other pcl using files are loaded. For example, if your system has two files called "classes" and "methods", create a new file called "precom" that contains: (in-package 'pcl) (pcl::precompile-random-code-segments) Then you can use the defsystem stuff defined in the file defsys to maintain your system as follows: (defsystem my-very-own-system "/usr/myname/lisp/" ((classes (precom) () ()) (methods (precom classes) (classes) ()) (precom () (classes methods) (classes methods)))) This defsystem should be read as follows: * Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries should be in the directory "/usr/me/lisp/". There are three files in the system, there are named classes, methods and precom. (The extension the filenames have depends on the lisp you are running in.) * For the first file, classes, the (precom) in the line means that the file precom should be loaded before this file is loaded. The first () means that no other files need to be loaded before this file is compiled. The second () means that changes in other files don't force this file to be recompiled. * For the second file, methods, the (precom classes) means that both of the files precom and classes must be loaded before this file can be loaded. The (classes) means that the file classes must be loaded before this file can be compiled. The () means that changes in other files don't force this file to be recompiled. * For the third file, precom, the first () means that no other files need to be loaded before this file is loaded. The first use of (classes methods) means that both classes and methods must be loaded before this file can be compiled. The second use of (classes methods) mean that whenever either classes or methods changes precom must be recompiled. Then you can compile your system with: (operate-on-system 'my-very-own-system :compile) and load your system with: (operate-on-system 'my-very-own-system :load) *** The code walker has gone through some signigificant revision. The principle change is that the function walk-form now takes three required arguments, and the walk-function itself now must accept an environment argument. There are other changes having to do with the implementation specific representation of macroexpansion environments. For details see the file walk.lisp. *** The following functions and macros which used to be supported for backward compatibility only are now not supported at all: WITH* and WITH DEFMETH GET-SLOT MAKE *** There are other small changes in this release. If you notice one that causes you problems please send me a message about it. gcl-2.6.14/pcl/notes/lap.text0000644000175000017500000006316514360276512014376 0ustar cammcamm-*- Mode: Text -*- Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. All rights reserved. Use and copying of this document is permitted. Any distribution of this document must comply with all applicable United States export control laws. Last updated: 6/3/89 by Gregor 10/26/89 by Gregor -- added :RETURN, removed :ISHIFT This file contains documentation of the PCL abstract LAP code. Any port of PCL is required to implement the abstract LAP code interface. There is a portable, relatively good performance implementation in the file lap.lisp, port-specific implementations are in that file as well. The PCL abstract LAP code mechanism exists to provide PCL with a way to create high-performance method lookup functions. Using this mechanism, PCL can produce "LAP closures" which do the method lookup. By allowing PCL to specify these closures using abstract LAP code rather that Lisp code we hope to achieve the following: * Better runtime performance. By using abstract LAP code, we will get better machine instruction sequences than we would from compiling Lisp code. * Better load and update time performance. Because it should be possible to "assemble" the LAP code more quickly than compiling Lisp code, PCL will spend less time building the method lookup code. * Ability to use PCL without a compiler. The LAP assembler will still be required but this should be much smaller than the full lisp compiler. Of course, not all implementations of the LAP code mechanism will satisfy all of these goals. The first is the most important. In particular, many PCL ports will use the portable LAP implementation. KCL will use the portable implementation in all of its ports. Other Lisps may have custom LAP implementations for some ports and use the portable implementation for other ports. Some Lisps will have a custom LAP implementation but will nonetheless require the compiler to be loaded to generate LAP closure constructors. An important point is why we have chosen to take this route rather than have each implementation implement the method lookup codes itself. This was done because we are, at PARC, just beginning to study cache behavior for CLOS programs. As we learn more about this we will want to modify the caching strategy PCL uses. This architecture, because it leaves PCL to implement caching behavior makes it possible to do this. Once this study is complete, implementations may want to do their own, ultra high performance implementations of caching strategies. Production of LAP closures is a two step process. In the first step, a port-specific function is called to take abstract LAP code and produce a a "lap closure generator". Lap closure generators are functions which are called with a set of closure variable values and return a LAP closure. The intermediary of the lap closure generators provides an important optimization. Because it is assumed that producing the LAP closure generator can take much longer than producing a LAP closure from the generator, PCL attempts to make only one closure generator for each sequence of LAP code. Because of the way PCL generates the LAP code sequences, this is quite easy for it to do. The rest of this document is divided into six parts. * the metatypes std-instance and fsc-instance * an abstraction for simple vector indices * important optimizations * the port specific function for making lap closure generators * the actual abstract LAP code * examples *** The metatypes STD-INSTANCE and FSC-INSTANCE *** In PCL, instances with metaclass STANDARD-CLASS are represented using the metatype STD-INSTANCE. (Note that in Cinco de Mayo PCL, this metatype is called IWMC-CLASS.) Each port must implement this metatype. The metatype could be implemented by the following DEFSTRUCT. (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor %allocate-std-instance (wrapper slots)) (:constructor %allocate-std-instance-1 ()) (:print-function print-std-instance)) (wrapper nil) (slots nil)) PCL itself will guarantee correct access to this structure and the accessors and constructors. With this in mind, the following are important. * Being able to type test this structure quickly is critical. See the :STD-INSTANCE-P opcode. * The allocation functions should compile inline, do no argument checking and be as fast as possible. * The accessor functions should compile inline, do no checking of their arguments and be as fast as possible. SETF of the accessors should do the same. The port is also required to implement the metatype FSC-INSTANCE (called FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL). Objects with this metatype are used, among other things, to implement generic functions. These objects have field structure associated with them and are also functions that can be applied to arguments. The fields are the same as those for STD-INSTANCE, the FSC-INSTANCE metatype has predicates, print-functions, constructors and accessors as follows: fsc-instance-p print-fsc-instance %fsc-instance-wrapper %fsc-instance-slots %allocate-fsc-instance (wrapper slots) %allocate-fsc-instance-1 () In addition, objects of metatype FSC-INSTANCE have a property called the funcallable instance function. When an FSC-INSTANCE is applied to arguments, the funcallable instance function is what is actually called. The funcallable instance function of an FSC-INSTANCE can be changed using the function SET-FUNCALLABLE-INSTANCE-FUNCTION. There is no mechanism for obtaining the funcallable instance function of an FSC-INSTANCE. It is possible to implement the FSC-INSTANCE metatype in pure Common Lisp. A simple implementation which uses lexical closures as the instances and a hash table to record that the lexical closures are of metatype FSC-INSTANCE is easy to write. Unfortunately, this implementation adds significant overhead: to generic-function-invocation (1 function call) to slot-access (1 function call or one hash table lookup) to class-of a generic-function (1 hash-table lookup) In addition, it would prevent the FSC-INSTANCEs from being garbage collected. In short, the pure Common Lisp implementation really isn't practical. Note that previous implementations of FINS were always based on the lexical closure metatype. In some ports, that provides poor performance. Those ports may want to consider reimplementing to use the compiled code metatype. In that implementation strategy, LAP closure variables would become constants of the compiled code object. The following note from JonL is of interest when working on a FIN implementation: Date: Tue, 16 May 89 05:45:56 PDT From: Jon L White This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL that will "bite" most implementations where different settings of the compiler optimization switches will produce morphologically different (but of course functionally equivalent) function objects. The difficulty is in how discriminator codes service cache misses. They "call out" to (potentially) random functions that will in some cases "smash" the function object that was actually running as the discriminator code. This is all right providing you don't return to that function frame, but alas ... I know this is a more extensive problem because the code in the port-independent function 'notice-methods-change' goes out of its way to do a tail-recursive call to the function that is going to smash the possibly-executing discriminator code. Here is the commentary from that code (sic): ;; In order to prevent this we take a simple measure: we just ;; make sure that it doesn't try to reference our its own closure ;; variables after it makes the dcode change. This is done by ;; having notice-methods-change-2 do the work of making the change ;; AND calling the actual generic function (a closure variable) ;; over. This means that at the time the dcode change is made, ;; there is a pointer to the generic function on the stack where ;; it won't be affected by the change to the closure variables. A similar thing should be done in the construction of standard-accessor, checking, and caching dcodes. In an experimental version here at Lucid, I rewrote dcode.lisp to do that, and there is no problem with it. Although that code is somewhat Lucid-specific, it could be of help to someone who wanted to rewrite the generic dcode.lisp (no pun intended). Contact me privately if you are interested. Doing a tail-recursive call out of dcodes when there is a cache miss is a good thing, regardless of other problems. I think one might as well do it. However, I should point out that in the presence of multiprocessing, there is another more serious problem that cannot be solved so simply. Think about what happens when one process decides to update a dcode while another process is still using it; no such stack-maintenance discipline will fix this case. A tail-recursive exit from the dcode will *immensely* reduce the likelihood that another process can sneak in during the interval in which the dcode requires consistency in its function; but it can't reduce that likelihood to zero. The more desirable thing to do is to put the whole "dcode" down one more level of indirection through the symbol-function cell of the generic function. This is effectively what PCL's 'make-trampoline' function does, but unfortunately that is not a very efficient approach when you consider how most compilers will compile it. Something akin to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) could probably be done for many other implementations as well. *** Index Operations *** Indexes are an abstraction for indexes into a simple vector. This abstraction is used to make it possible to generate more efficient code to access simple vectors. The idea being that this may make it possible to use alternate addressing modes to address these. The "index value" of an index is defined to be the fixnum of which that index is an alternate form. So, using the Lisp function SVREF with the index value of an index accesses the same element as using the index with the appropriate access function or operand. The format of an index is unspecified, but is assumed to be something like a fixnum with certain bits ignored. Accessing a vector using an index must be done using the appropriate special accessor function or opcode. Conversion from index values to indices and vice-versa can be done with the following functions: INDEX-VALUE->INDEX (index-value) INDEX->INDEX-VALUE (index) The following constant indicates the maximum index value an index can have in a given port. This must be at least 2^16. INDEX-VALUE-LIMIT - a fixnum, must be at least 2^16. MAKE-INDEX-MASK ( ) This function is used to make index masks. Because I am lazy, I show an implementation of it in the common case where indexes are just fixnums: (defun make-index-mask (cache-size line-size) (let ((cache-size-in-bits (floor (log cache-size 2))) (line-size-in-bits (floor (log line-size 2))) (mask 0)) (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) mask)) *** Optimizations *** This section discusses two important optimizations related to LAP closures. The first relates to calling LAP closures themselves, the second relates to calling other functions from LAP closures. The important point about calling LAP closures is that almost all of the time, LAP closures will be used as the funcallable-instance-function of funcallable instances. It is required that LAP closures be funcallable themselves, but usually they will be stored in a FIN and the fin will then be funcalled. This brings up several optimizations, including ones having to do with access to the closure variables of a LAP closure. When a LAP closure is used to do method lookup, the function the LAP closure ends up calling has the same number of required arguments as the LAP closure itself. Since the LAP closure must check its required arguments to do the lookup, it is redundant for the function called to do so as well. Since LAP closures do all calls in a tail recursive way, it should even be possible to optimize out certain parts of the normal stack frame initialization. A similar situation occurs between effective method functions and the individual method functions; the difference is that in effective method functions, the calls are not necessarily tail recursive. Consequently, it would be nice to have a way to call certain functions and inhibit the checking of required arguments. This is made possible by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with the PCL-FAST-CALL compiler declaration. The PCL-FAST-CALL compiler declaration declares that a function may be fast called. Not all callers of the function will necessarily fast call it, but most probably will. The :JMP opcode can only be used to call a function compiled with the PCL-FAST-CALL declaration. The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a function. The function argument must be a compiled function that has the PCL-FAST-CALL compiler declaration in its lambda declarations. The basic idea is that the PCL-FAST-CALL compiler declaration causes the compiler to set up an additional entrypoint to the function. This entrypoint comes after checking of required arguments but before processing of other arguments. Note: When FAST-APPLY is used, the required arguments will be given as separate arguments and all other arguments will appear as a single spread argument. For example: (let ((fn (compile () '(lambda (a b &optional (c 'z)) (declare (pcl-fast-call)) (list a b c))))) (pcl-fast-apply fn 'x 'y ()) ;legal (pcl-fast-apply fn 'x 'y '(foo)) ;legal (pcl-fast-apply fn '(a b c)) ;illegal ) *** Producing LAP Closure Generators *** Each implementation of the LAP code mechanism must provide a port specific function making lap closure generators. In the portable implementation, this function is called PLAP-CLOSURE-GENERATOR. In ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc. At any time, the value of the variable *make-lap-closure-generator* is a symbol which names the function currently being used to make lap closure generators. The port specific function must accept arguments as follows: PLAP-CLOSURE-GENERATOR ( ) This returns a lap-closure generator. A lap-closure generator is a function which is called with a number of arguments equal to the length of . These arguments are the values of the closure variables for the lap closure. These values cannot be changed once the LAP closure is created. PCL takes care of keeping track of lap-closure-generators it already has on hand and reusing them. The function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to forget all the lap closure generators it has remembered. A list of symbols. This provides a way to name particular arguments to the LAP closure. Arguments which will not be referenced by name are given as NIL. All required arguments to the LAP closure are explicitly included (perhaps as NIL). If &REST appears at the end of arguments it means that non-required arguments are allowed, these will be processed by the methods. If &REST does not appear at the end of arguments, the lap closure should signal an error if more than the indicated number of arguments are supplied. Examples: - (obj-0 obj-1) Specifies a two argument lap closure. If more or less than two arguments are supplied an error is signalled. Within the actual lap code, both arguments can be referenced by name (see the :ARG operand). - (obj-0 nil &rest) Specifies a two or more argument lap closure. If less than two arguments are supplied an error is signalled. Within the actual lap code, the first argument can be referenced by name (see the :ARG operand). A list of symbols. The closure will have these as closure variables. Within the lap code these can be accessed using the :CVAR operand. The lap code cannot change these values. SET-FUNCALLABLE-INSTANCE-FUNCTION is permitted to have the special knowledge that there are at most ?? of these and to be prepared to do something special when the funcallable instance function of a funcallable instance is set to a lap closure. A list of register numbers. These registers will be used only to hold indexes. Other registers may be used to hold indexes as well, but the only values put into these registers will be indexes. A list of register numbers. These registers will be used only to hold simple-vectors. Other registers may be used to hold simple-vectors as well, but the only values put into these registers will be simple-vectors. The actual lap code for this closure. This is a list of LAP code opcodes. See the section "Abstract LAP Code" for more details. Each implementation must also supply a function named PRE-MAKE-xxx where xxx is the same as the name of its make-lap-closure-generator function. The macro doesn't evaluate its arguments, and when it appears in a file it should try to do some of the work at load time. It might appear in a file like this: (eval-when (load) (setq 1-arg-std-lap (pre-make-plap-closure-generator ...))) *** Abstract LAP Code *** Each lap code operand has the form: (opcode operand1 ... operandn). In some cases, the distinction between an operand and an opcode is somewhat arbitrary. In general, opcodes have a significant "action" component to their behavior. Operands select a piece of data to operate on. Some operands select their data in a more complex way, but they are operands anyways. All data must be in a register before it can be operated on. This requirement means that the only place a non-register operand can appear is as the first argument to the :move opcode. (Actually, there is one other exception, a :iref operand can be the target of a move as well.) Moreover, only register operands can appear as the second argument to the :move opcode and this register must not appear in the operand. >> The operands are: (:reg ) A pseudo register. is an integer in the range [0 , 31]. A particular implementation can map this to a real register, a memory location or the stack. The abstract LAP code itself does not include the notion of a stack. PCL will attempt to optimize register use in two ways. PCL itself will attempt to re-use registers whenever possible. That is, the port should not have to worry with doing live register analysis for the registers. In addition, PCL will consider lower numbered registers to be "faster" than higher numbered ones. (:cvar ) A closure variable of the lap-closure. is a symbol. (:arg ) An argument to the LAP closure. is a symbol. (:std-wrapper ) (:fsc-wrapper ) (:built-in-wrapper ) (:structure-wrapper ) (:other-wrapper ) Get the class wrapper of . For std-instances and fsc-instances this just fetches the wrapper field. The specific port is required to implement fast access to the wrappers of built-in, structure and other metatypes. A callback mechanism allows the port to ask PCL to generate a class and wrapper for objects for which no class and wrapper exists yet. This mechanism is <>. (:std-slots ) (:fsc-slots ) Fetch the slots field of a std-instance or a fsc-instance. (:constant ) This just allows inline constants. can be any Lisp object. The following operands operate on indexes. Each is patterned after a Lisp function which would have a corresponding effect on the index value of the index. (:i1+ ) (:i+ ) (:i- ) (:ilogand ) (:ilogxor ) Like the corresponding Lisp functions. (:iref ) Like the SVREF function. must be a simple vector. (:cref ) The :cref operand is for constant vector references. must be a fixnum. >> The opcodes are: (:move ) A full word move operation. (:eq

    is the ;; primary line of the entry we are finding a free ;; line for, it is used to compute the seperations. (do* ((line s (next-line line)) (nsep (line-separation p s) (1+ nsep))) (()) (declare (type non-negative-fixnum line nsep)) (when (null (line-valid-p line wrappers)) ;If this line is empty or (push line lines) ;invalid, just use it. (return-from find-free)) (when (and wrappedp (>= line primary)) ;; have gone all the way around the cache, time to quit (return-from find-free-cache-line (values primary nil))) (let ((osep (line-separation (line-primary line) line))) (when (>= osep limit) (return-from find-free-cache-line (values primary nil))) (when (cond ((= nsep limit) t) ((= nsep osep) (zerop (random 2))) ((> nsep osep) t) (t nil)) ;; See if we can displace what is in this line so that we ;; can use the line. (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) (setq p (line-primary line)) (setq s (next-line line)) (push line lines) (return nil))) (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) ;; Do all the displacing. (loop (when (null (cdr lines)) (return nil)) (let ((dline (pop lines)) (line (car lines))) (declare (type non-negative-fixnum dline line)) ;;Copy from line to dline (dline is known to be free). (let ((from-loc (line-location line)) (to-loc (line-location dline)) (cache-vector (vector))) (declare (type non-negative-fixnum from-loc to-loc) (simple-vector cache-vector)) (modify-cache cache-vector (mdotimes (i (line-size)) (setf (cache-vector-ref cache-vector (+ to-loc i)) (cache-vector-ref cache-vector (+ from-loc i))) (setf (cache-vector-ref cache-vector (+ from-loc i)) nil)))))) (values (car lines) t)))) (defun default-limit-fn (nlines) (case nlines ((1 2 4) 1) ((8 16) 4) (otherwise 6))) (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms ;;; ;;; pre-allocate generic function caches. The hope is that this will put ;;; them nicely together in memory, and that that may be a win. Of course ;;; the first gc copy will probably blow that out, this really wants to be ;;; wrapped in something that declares the area static. ;;; ;;; This preallocation only creates about 25% more caches than PCL itself ;;; uses. Some ports may want to preallocate some more of these. ;;; (eval-when (load) (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) (let ((n (car n-size)) (size (cadr n-size))) (mapcar #'free-cache-vector (mapcar #'get-cache-vector (make-list n :initial-element size)))))) (defun caches-to-allocate () (sort (let ((l nil)) (maphash #'(lambda (size entry) (push (list (car entry) size) l)) pcl::*free-caches*) l) #'> :key #'cadr)) gcl-2.6.14/pcl/gcl_pcl_defs.lisp0000644000175000017500000007537414360276512015066 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (eval-when (compile load eval) (defvar *defclass-times* '(load eval)) ;Probably have to change this ;if you use defconstructor. (defvar *defmethod-times* '(load eval)) (defvar *defgeneric-times* '(load eval)) ; defvar is now actually in macros ;(defvar *boot-state* ()) ;NIL ;EARLY ;BRAID ;COMPLETE (defvar *fegf-started-p* nil) ) (eval-when (load eval) (when (eq *boot-state* 'complete) (error "Trying to load (or compile) PCL in an environment in which it~%~ has already been loaded. This doesn't work, you will have to~%~ get a fresh lisp (reboot) and then load PCL.")) (when *boot-state* (cerror "Try loading (or compiling) PCL anyways." "Trying to load (or compile) PCL in an environment in which it~%~ has already been partially loaded. This may not work, you may~%~ need to get a fresh lisp (reboot) and then load PCL.")) ) ;;; ;;; This is like fdefinition on the Lispm. If Common Lisp had something like ;;; function specs I wouldn't need this. On the other hand, I don't like the ;;; way this really works so maybe function specs aren't really right either? ;;; ;;; I also don't understand the real implications of a Lisp-1 on this sort of ;;; thing. Certainly some of the lossage in all of this is because these ;;; SPECs name global definitions. ;;; ;;; Note that this implementation is set up so that an implementation which ;;; has a 'real' function spec mechanism can use that instead and in that way ;;; get rid of setf generic function names. ;;; (defmacro parse-gspec (spec (non-setf-var . non-setf-case) (setf-var . setf-case)) (declare (indentation 1 1)) #+setf (declare (ignore setf-var setf-case)) (once-only (spec) `(cond (#-setf (symbolp ,spec) #+setf t (let ((,non-setf-var ,spec)) ,@non-setf-case)) #-setf ((and (listp ,spec) (eq (car ,spec) 'setf) (symbolp (cadr ,spec))) (let ((,setf-var (cadr ,spec))) ,@setf-case)) #-setf (t (error "Can't understand ~S as a generic function specifier.~%~ It must be either a symbol which can name a function or~%~ a list like ~S, where the car is the symbol ~S and the cadr~%~ is a symbol which can name a generic function." ,spec '(setf ) 'setf))))) ;;; ;;; If symbol names a function which is traced or advised, return the ;;; unadvised, traced etc. definition. This lets me get at the generic ;;; function object even when it is traced. ;;; (defun unencapsulated-fdefinition (symbol) #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol)) #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol)) #+excl (or (excl::encapsulated-basic-definition symbol) (symbol-function symbol)) #+xerox (il:virginfn symbol) #+setf (fdefinition symbol) #+kcl (symbol-function (let ((sym (get symbol 'si::traced)) first-form) (if (and sym (consp (symbol-function symbol)) (consp (setq first-form (nth 3 (symbol-function symbol)))) (eq (car first-form) 'si::trace-call)) sym symbol))) #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) ;;; ;;; If symbol names a function which is traced or advised, redefine ;;; the `real' definition without affecting the advise. ;;; (defun fdefine-carefully (name new-definition) #+Lispm (si:fdefine name new-definition t t) #+Lucid (let ((lucid::*redefinition-action* nil)) (setf (symbol-function name) new-definition)) #+excl (setf (symbol-function name) new-definition) #+xerox (let ((advisedp (member name il:advisedfns :test #'eq)) (brokenp (member name il:brokenfns :test #'eq))) ;; In XeroxLisp (late of envos) tracing is implemented ;; as a special case of "breaking". Advising, however, ;; is treated specially. (xcl:unadvise-function name :no-error t) (xcl:unbreak-function name :no-error t) (setf (symbol-function name) new-definition) (when brokenp (xcl:rebreak-function name)) (when advisedp (xcl:readvise-function name))) #+(and setf (not cmu)) (setf (fdefinition name) new-definition) #+kcl (setf (symbol-function (let ((sym (get name 'si::traced)) first-form) (if (and sym (consp (symbol-function name)) (consp (setq first-form (nth 3 (symbol-function name)))) (eq (car first-form) 'si::trace-call)) sym name))) new-definition) #+cmu (progn (c::%%defun name new-definition nil) (c::note-name-defined name :function) new-definition) #-(or Lispm Lucid excl Xerox setf kcl cmu) (setf (symbol-function name) new-definition)) (defun gboundp (spec) (parse-gspec spec (name (fboundp name)) (name (fboundp (get-setf-function-name name))))) (defun gmakunbound (spec) (parse-gspec spec (name (fmakunbound name)) (name (fmakunbound (get-setf-function-name name))))) (defun gdefinition (spec) (parse-gspec spec (name (or #-setf (macro-function name) ;?? (unencapsulated-fdefinition name))) (name (unencapsulated-fdefinition (get-setf-function-name name))))) (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec) (parse-gspec spec (name (fdefine-carefully name new-value)) (name (fdefine-carefully (get-setf-function-name name) new-value)))) (proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* *the-class-null* *the-class-list* *the-class-integer* *the-class-float* *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* *the-class-array* *the-class-slot-object* *the-class-standard-object* *the-class-structure-object* *the-class-class* *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* *the-class-structure-class* *the-class-standard-class* *the-class-funcallable-standard-class* *the-class-method* *the-class-standard-method* *the-class-standard-reader-method* *the-class-standard-writer-method* *the-class-standard-boundp-method* *the-class-standard-generic-function* *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots* *the-eslotd-funcallable-standard-class-slots*)) (proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) ;;;; Type specifier hackery: ;;; internal to this file. (defun coerce-to-class (class &optional make-forward-referenced-class-p) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) (ensure-class class)) class)) ;;; Interface (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) (cond ((symbolp type) (or (and (null args) (find-class type)) (ecase type (class (coerce-to-class (car args))) (prototype (make-instance 'class-prototype-specializer :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) #+cmu17 ((and (null args) (typep type 'lisp:class)) (or (kernel:class-pcl-class type) (find-structure-class (lisp:class-name type)))) ((specializerp type) type))) ;;; interface (defun type-from-specializer (specl) (cond ((eq specl 't) 't) ((consp specl) (unless (member (car specl) '(class prototype class-eq eql)) (error "~S is not a legal specializer type" specl)) specl) ((progn (when (symbolp specl) ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? (setq specl (find-class specl))) (or (not (eq *boot-state* 'complete)) (specializerp specl))) (specializer-type specl)) (t (error "~s is neither a type nor a specializer" specl)))) (defun type-class (type) (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) (if (eq type 't) *the-class-t* (error "bad argument to type-class")) (case (car type) (eql (class-of (cadr type))) (prototype (class-of (cadr type))) ;? (class-eq (cadr type)) (class (cadr type))))) (defun class-eq-type (class) (specializer-type (class-eq-specializer class))) (defun inform-type-system-about-std-class (name) (let ((predicate-name (make-type-predicate-name name))) (setf (gdefinition predicate-name) (make-type-predicate name)) (do-satisfies-deftype name predicate-name))) (defun make-type-predicate (name) (let ((cell (find-class-cell name))) #'(lambda (x) (funcall (the function (find-class-cell-predicate cell)) x)))) ;This stuff isn't right. Good thing it isn't used. ;The satisfies predicate has to be a symbol. There is no way to ;construct such a symbol from a class object if class names change. (defun class-predicate (class) (when (symbolp class) (setq class (find-class class))) #'(lambda (object) (memq class (class-precedence-list (class-of object))))) (defun make-class-eq-predicate (class) (when (symbolp class) (setq class (find-class class))) #'(lambda (object) (eq class (class-of object)))) (defun make-eql-predicate (eql-object) #'(lambda (object) (eql eql-object object))) #|| ; The argument to satisfies must be a symbol. (deftype class (&optional class) (if class `(satisfies ,(class-predicate class)) `(satisfies ,(class-predicate 'class)))) (deftype class-eq (class) `(satisfies ,(make-class-eq-predicate class))) ||# #-(or excl cmu17) (deftype eql (type-object) `(member ,type-object)) ;;; Internal to this file. ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. ;;; (defun *normalize-type (type) (cond ((consp type) (if (member (car type) '(not and or)) `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) (if (null (cdr type)) (*normalize-type (car type)) type))) ((symbolp type) (let ((class (find-class type nil))) (if class (let ((type (specializer-type class))) (if (listp type) type `(,type))) `(,type)))) ((or (not (eq *boot-state* 'complete)) (specializerp type)) (specializer-type type)) (t (error "~s is not a type" type)))) ;;; Not used... #+nil (defun unparse-type-list (tlist) (mapcar #'unparse-type tlist)) ;;; Not used... #+nil (defun unparse-type (type) (if (atom type) (if (specializerp type) (unparse-type (specializer-type type)) type) (case (car type) (eql type) (class-eq `(class-eq ,(class-name (cadr type)))) (class (class-name (cadr type))) (t `(,(car type) ,@(unparse-type-list (cdr type))))))) ;;; internal to this file... (defun convert-to-system-type (type) (case (car type) ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) ((class class-eq) ; class-eq is impossible to do right #-cmu17 (class-name (cadr type)) #+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) type)))) ;;; not used... #+nil (defun *typep (object type) (setq type (*normalize-type type)) (cond ((member (car type) '(eql wrapper-eq class-eq class)) (specializer-applicable-using-type-p type `(eql ,object))) ((eq (car type) 'not) (not (*typep object (cadr type)))) (t (typep object (convert-to-system-type type))))) ;;; *SUBTYPEP -- Interface ;;; ;Writing the missing NOT and AND clauses will improve ;the quality of code generated by generate-discrimination-net, but ;calling subtypep in place of just returning (values nil nil) can be ;very slow. *subtypep is used by PCL itself, and must be fast. (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) (if (eq *boot-state* 'early) (values (eq type1 type2) t) (let ((*in-precompute-effective-methods-p* t)) (declare (special *in-precompute-effective-methods-p*)) ;; *in-precompute-effective-methods-p* is not a good name. ;; It changes the way class-applicable-using-class-p works. (setq type1 (*normalize-type type1)) (setq type2 (*normalize-type type2)) (case (car type2) (not (values nil nil)) ; Should improve this. (and (values nil nil)) ; Should improve this. ((eql wrapper-eq class-eq class) (multiple-value-bind (app-p maybe-app-p) (specializer-applicable-using-type-p type2 type1) (values app-p (or app-p (not maybe-app-p))))) (t (subtypep (convert-to-system-type type1) (convert-to-system-type type2)))))))) (defun do-satisfies-deftype (name predicate) #+cmu17 (declare (ignore name predicate)) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) (let* ((specifier `(satisfies ,predicate)) (expand-fn #'(lambda (&rest ignore) (declare (ignore ignore)) specifier))) ;; Specific ports can insert their own way of doing this. Many ;; ports may find the expand-fn defined above useful. ;; (or #+:Genera (setf (get name 'deftype) expand-fn) #+(and :Lucid (not :Prime)) (system::define-macro `(deftype ,name) expand-fn nil) #+ExCL (setf (get name 'excl::deftype-expander) expand-fn) #+:coral (setf (get name 'ccl::deftype-expander) expand-fn))) #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) ;; This is the default for ports for which we don't know any ;; better. Note that for most ports, providing this definition ;; should just speed up class definition. It shouldn't have an ;; effect on performance of most user code. (eval `(deftype ,name () '(satisfies ,predicate)))) (defun make-type-predicate-name (name &optional kind) (if (symbol-package name) (intern (format nil "~@[~A ~]TYPE-PREDICATE ~A ~A" kind (package-name (symbol-package name)) (symbol-name name)) *the-pcl-package*) (make-symbol (format nil "~@[~A ~]TYPE-PREDICATE ~A" kind (symbol-name name))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) (pushnew 'class *variable-declarations*) (pushnew 'variable-rebinding *variable-declarations*) (defun variable-class (var env) (caddr (variable-declaration 'class var env))) (defvar *name->class->slotd-table* (make-hash-table)) ;;; ;;; This is used by combined methods to communicate the next methods to ;;; the methods they call. This variable is captured by a lexical variable ;;; of the methods to give it the proper lexical scope. ;;; (defvar *next-methods* nil) (defvar *not-an-eql-specializer* '(not-an-eql-specializer)) (defvar *umi-gfs*) (defvar *umi-complete-classes*) (defvar *umi-reorder*) (defvar *invalidate-discriminating-function-force-p* ()) (defvar *invalid-dfuns-on-stack* ()) (defvar *standard-method-combination*) (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;*** (defmacro define-gf-predicate (predicate-name &rest classes) `(progn (defmethod ,predicate-name ((x t)) nil) ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) classes))) (defun make-class-predicate-name (name) (intern (format nil "~A::~A class predicate" (package-name (symbol-package name)) name) *the-pcl-package*)) (defun plist-value (object name) (getf (object-plist object) name)) (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) (if new-value (setf (getf (object-plist object) name) new-value) (progn (remf (object-plist object) name) nil))) (defvar *built-in-classes* ;; ;; name supers subs cdr of cpl ;; prototype '(;(t () (number sequence array character symbol) ()) (number (t) (complex real) (t)) (real (number) (float rational) (number t)) (complex (number) () (number t) #c(1 1)) (float (real) () (real number t) 1.0) (rational (real) (integer ratio) (real number t)) (integer (rational) () (rational real number t) 1) (ratio (rational) () (rational real number t) 1/2) (sequence (t) (list vector) (t)) (list (sequence) (cons null) (sequence t)) (cons (list) () (list sequence t) (nil)) (array (t) (vector) (t) #2A((NIL))) (vector (array sequence) (string bit-vector) (array sequence t) #()) (string (vector) () (vector array sequence t) "") (bit-vector (vector) () (vector array sequence t) #*1) (character (t) () (t) #\c) (symbol (t) (null) (t) symbol) (null (symbol list) () (symbol list sequence t) nil))) #+cmu17 (labels ((direct-supers (class) (if (typep class 'lisp:built-in-class) (kernel:built-in-class-direct-superclasses class) (let ((inherits (kernel:layout-inherits (kernel:class-layout class)))) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) (ext:collect ((res)) (let ((subs (kernel:class-subclasses class))) (when subs (ext:do-hash (sub v subs) (declare (ignore v)) (when (member class (direct-supers sub)) (res sub))))) (res)))) (ext:collect ((res)) (dolist (bic kernel::built-in-classes) (let* ((name (car bic)) (class (lisp:find-class name))) (unless (member name '(t kernel:instance kernel:funcallable-instance function)) (res `(,name ,(mapcar #'lisp:class-name (direct-supers class)) ,(mapcar #'lisp:class-name (direct-subs class)) ,(map 'list #'(lambda (x) (lisp:class-name (kernel:layout-class x))) (reverse (kernel:layout-inherits (kernel:class-layout class)))) ,(let ((found (assoc name *built-in-classes*))) (if found (fifth found) 42))))))) (setq *built-in-classes* (res)))) ;;; ;;; The classes that define the kernel of the metabraid. ;;; (defclass t () () (:metaclass built-in-class)) #+cmu17 (progn (defclass kernel:instance (t) () (:metaclass built-in-class)) (defclass function (t) () (:metaclass built-in-class)) (defclass kernel:funcallable-instance (function) () (:metaclass built-in-class))) (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () (:metaclass slot-class)) (defclass structure-object (slot-object) () (:metaclass structure-class)) (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object (:constructor |STRUCTURE-OBJECT class constructor|))) (defclass standard-object (slot-object) ()) (defclass metaobject (standard-object) ()) (defclass specializer (metaobject) ((type :initform nil :reader specializer-type))) (defclass definition-source-mixin (standard-object) ((source :initform (load-truename) :reader definition-source :initarg :definition-source))) (defclass plist-mixin (standard-object) ((plist :initform () :accessor object-plist))) (defclass documentation-mixin (plist-mixin) ()) (defclass dependent-update-mixin (plist-mixin) ()) ;;; ;;; The class CLASS is a specified basic class. It is the common superclass ;;; of any kind of class. That is any class that can be a metaclass must ;;; have the class CLASS in its class precedence list. ;;; (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer) ((name :initform nil :initarg :name :accessor class-name) (class-eq-specializer :initform nil :reader class-eq-specializer) (direct-superclasses :initform () :reader class-direct-superclasses) (direct-subclasses :initform () :reader class-direct-subclasses) (direct-methods :initform (cons nil nil)) (predicate-name :initform nil :reader class-predicate-name))) ;;; ;;; The class PCL-CLASS is an implementation-specific common superclass of ;;; all specified subclasses of the class CLASS. ;;; (defclass pcl-class (class) ((class-precedence-list :reader class-precedence-list) (can-precede-list :initform () :reader class-can-precede-list) (incompatible-superclass-list :initform () :accessor class-incompatible-superclass-list) (wrapper :initform nil :reader class-wrapper) (prototype :initform nil :reader class-prototype))) (defclass slot-class (pcl-class) ((direct-slots :initform () :accessor class-direct-slots) (slots :initform () :accessor class-slots) (initialize-info :initform nil :accessor class-initialize-info))) ;;; ;;; The class STD-CLASS is an implementation-specific common superclass of ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. ;;; (defclass std-class (slot-class) ()) (defclass standard-class (std-class) ()) (defclass funcallable-standard-class (std-class) ()) (defclass forward-referenced-class (pcl-class) ()) (defclass built-in-class (pcl-class) ()) (defclass structure-class (slot-class) ((defstruct-form :initform () :accessor class-defstruct-form) (defstruct-constructor :initform nil :accessor class-defstruct-constructor) (from-defclass-p :initform nil :initarg :from-defclass-p))) (defclass specializer-with-object (specializer) ()) (defclass exact-class-specializer (specializer) ()) (defclass class-eq-specializer (exact-class-specializer specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass class-prototype-specializer (specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass eql-specializer (exact-class-specializer specializer-with-object) ((object :initarg :object :reader specializer-object :reader eql-specializer-object))) (defvar *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) (make-instance 'eql-specializer :object object)))) ;;; ;;; Slot definitions. ;;; (defclass slot-definition (metaobject) ((name :initform nil :initarg :name :accessor slot-definition-name) (initform :initform nil :initarg :initform :accessor slot-definition-initform) (initfunction :initform nil :initarg :initfunction :accessor slot-definition-initfunction) (readers :initform nil :initarg :readers :accessor slot-definition-readers) (writers :initform nil :initarg :writers :accessor slot-definition-writers) (initargs :initform nil :initarg :initargs :accessor slot-definition-initargs) (type :initform t :initarg :type :accessor slot-definition-type) (documentation :initform "" :initarg :documentation) (class :initform nil :initarg :class :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation :initform :instance :initarg :allocation :accessor slot-definition-allocation))) (defclass structure-slot-definition (slot-definition) ((defstruct-accessor-symbol :initform nil :initarg :defstruct-accessor-symbol :accessor slot-definition-defstruct-accessor-symbol) (internal-reader-function :initform nil :initarg :internal-reader-function :accessor slot-definition-internal-reader-function) (internal-writer-function :initform nil :initarg :internal-writer-function :accessor slot-definition-internal-writer-function))) (defclass direct-slot-definition (slot-definition) ()) (defclass effective-slot-definition (slot-definition) ((reader-function ; #'(lambda (object) ...) :accessor slot-definition-reader-function) (writer-function ; #'(lambda (new-value object) ...) :accessor slot-definition-writer-function) (boundp-function ; #'(lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ((location ; nil, a fixnum, a cons: (slot-name . value) :initform nil :accessor slot-definition-location))) (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) (defclass structure-effective-slot-definition (structure-slot-definition effective-slot-definition) ()) (defclass method (metaobject) ()) (defclass standard-method (definition-source-mixin plist-mixin method) ((generic-function :initform nil :accessor method-generic-function) ; (qualifiers ; :initform () ; :initarg :qualifiers ; :reader method-qualifiers) (specializers :initform () :initarg :specializers :reader method-specializers) (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list) (function :initform nil :initarg :function) ;no writer (fast-function :initform nil :initarg :fast-function ;no writer :reader method-fast-function) ; (documentation ; :initform nil ; :initarg :documentation ; :reader method-documentation) )) (defclass standard-accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name :reader accessor-method-slot-name) (slot-definition :initform nil :initarg :slot-definition :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) (defclass standard-boundp-method (standard-accessor-method) ()) (defclass generic-function (dependent-update-mixin definition-source-mixin documentation-mixin metaobject #+cmu17 kernel:funcallable-instance) () (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) ((name :initform nil :initarg :name :accessor generic-function-name) (methods :initform () :accessor generic-function-methods) (method-class :initarg :method-class :accessor generic-function-method-class) (method-combination :initarg :method-combination :accessor generic-function-method-combination) (arg-info :initform (make-arg-info) :reader gf-arg-info) (dfun-state :initform () :accessor gf-dfun-state) (pretty-arglist :initform () :accessor gf-pretty-arglist) ) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) (defclass method-combination (metaobject) ()) (defclass standard-method-combination (definition-source-mixin method-combination) ((type :reader method-combination-type :initarg :type) (documentation :reader method-combination-documentation :initarg :documentation) (options :reader method-combination-options :initarg :options))) (defparameter *early-class-predicates* '((specializer specializerp) (exact-class-specializer exact-class-specializer-p) (class-eq-specializer class-eq-specializer-p) (eql-specializer eql-specializer-p) (class classp) (slot-class slot-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) (structure-class structure-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) (standard-accessor-method standard-accessor-method-p) (standard-reader-method standard-reader-method-p) (standard-writer-method standard-writer-method-p) (standard-boundp-method standard-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p))) gcl-2.6.14/pcl/gcl_pcl_braid.lisp0000644000175000017500000006651614360276512015224 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Bootstrapping the meta-braid. ;;; ;;; The code in this file takes the early definitions that have been saved ;;; up and actually builds those class objects. This work is largely driven ;;; off of those class definitions, but the fact that STANDARD-CLASS is the ;;; class of all metaclasses in the braid is built into this code pretty ;;; deeply. ;;; ;;; (in-package :pcl) (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) #-new-kcl-wrapper (declare (special *slot-unbound*)) #-new-kcl-wrapper (let ((instance (%%allocate-instance--class))) (setf (std-instance-wrapper instance) wrapper) (setf (std-instance-slots instance) (if slots-init-p (copy-slots slots-init) (make-array (wrapper-no-of-instance-slots wrapper) :initial-element *slot-unbound*))) instance) #+new-kcl-wrapper (apply #'si:make-structure wrapper (if slots-init-p slots-init (let ((no-of-slots (si::s-data-length wrapper))) (if (< no-of-slots (fill-pointer *init-vector*)) (aref *init-vector* no-of-slots) (get-init-list no-of-slots)))))) (defmacro allocate-funcallable-instance-slots (wrapper &optional slots-init-p slots-init) #-new-kcl-wrapper `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) ,(if slots-init-p `(if ,slots-init-p (copy-slots ,slots-init) (make-array no-of-slots :initial-element *slot-unbound*)) `(make-array no-of-slots :initial-element *slot-unbound*))) #+new-kcl-wrapper (if slots-init-p `(if ,slots-init-p (allocate-standard-instance ,wrapper ,slots-init) (allocate-standard-instance ,wrapper)) `(allocate-standard-instance ,wrapper))) (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) (let ((fin (allocate-funcallable-instance-1))) (set-funcallable-instance-function fin (fin-lambda-fn (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S has not been set" fin))) (setf (fsc-instance-wrapper fin) wrapper (fsc-instance-slots fin) (allocate-funcallable-instance-slots wrapper slots-init-p slots-init)) fin)) (defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p)) #-new-kcl-wrapper (let* ((class (wrapper-class wrapper)) (constructor (class-defstruct-constructor class))) (if constructor (let ((instance (funcall constructor)) (slots (class-slots class))) (when slots-init-p (dotimes (i (length slots-init)) (let ((slot (pop slots))) (setf (slot-value-using-class class instance slot) (svref slots-init i))))) instance) (error "Can't allocate an instance of class ~S" (class-name class)))) #+new-kcl-wrapper (if slots-init-p (allocate-standard-instance wrapper slots-init) (allocate-standard-instance wrapper))) ;;; ;;; bootstrap-meta-braid ;;; ;;; This function builds the base metabraid from the early class definitions. ;;; (defmacro initial-classes-and-wrappers (&rest classes) `(progn ,@(mapcar #'(lambda (class) (let ((wr (intern (format nil "~A-WRAPPER" class) *the-pcl-package*))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* #-cmu17 `(make-wrapper (early-class-size ',class)) #+cmu17 `(boot-make-wrapper (early-class-size ',class) ',class)) ,class (allocate-standard-instance ,(if (eq class 'standard-generic-function) 'funcallable-standard-class-wrapper 'standard-class-wrapper)) (wrapper-class ,wr) ,class #+new-kcl-wrapper (si::s-data-name ,wr) #+new-kcl-wrapper ',class (find-class ',class) ,class))) classes))) (defun bootstrap-meta-braid () (let* ((name 'class) (predicate-name (make-type-predicate-name name))) (setf (gdefinition predicate-name) #'(lambda (x) (declare (ignore x)) t)) (do-satisfies-deftype name predicate-name)) (let* ((*create-classes-from-internal-structure-definitions-p* nil) standard-class-wrapper standard-class funcallable-standard-class-wrapper funcallable-standard-class slot-class-wrapper slot-class built-in-class-wrapper built-in-class structure-class-wrapper structure-class standard-direct-slot-definition-wrapper standard-direct-slot-definition standard-effective-slot-definition-wrapper standard-effective-slot-definition class-eq-specializer-wrapper class-eq-specializer standard-generic-function-wrapper standard-generic-function) (initial-classes-and-wrappers standard-class funcallable-standard-class slot-class built-in-class structure-class standard-direct-slot-definition standard-effective-slot-definition class-eq-specializer standard-generic-function) ;; ;; First, make a class metaobject for each of the early classes. For ;; each metaobject we also set its wrapper. Except for the class T, ;; the wrapper is always that of STANDARD-CLASS. ;; (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) (meta (ecd-metaclass definition)) (wrapper (ecase meta (slot-class slot-class-wrapper) (standard-class standard-class-wrapper) (funcallable-standard-class funcallable-standard-class-wrapper) (built-in-class built-in-class-wrapper) (structure-class structure-class-wrapper))) (class (or (find-class name nil) (allocate-standard-instance wrapper)))) (when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class)) (inform-type-system-about-std-class name)) (setf (find-class name) class))) ;; ;; ;; (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) (meta (ecd-metaclass definition)) (source (ecd-source definition)) (direct-supers (ecd-superclass-names definition)) (direct-slots (ecd-canonical-slots definition)) (other-initargs (ecd-other-initargs definition))) (let ((direct-default-initargs (getf other-initargs :direct-default-initargs))) (multiple-value-bind (slots cpl default-initargs direct-subclasses) (early-collect-inheritance name) (let* ((class (find-class name)) (wrapper (cond ((eq class slot-class) slot-class-wrapper) ((eq class standard-class) standard-class-wrapper) ((eq class funcallable-standard-class) funcallable-standard-class-wrapper) ((eq class standard-direct-slot-definition) standard-direct-slot-definition-wrapper) ((eq class standard-effective-slot-definition) standard-effective-slot-definition-wrapper) ((eq class built-in-class) built-in-class-wrapper) ((eq class structure-class) structure-class-wrapper) ((eq class class-eq-specializer) class-eq-specializer-wrapper) ((eq class standard-generic-function) standard-generic-function-wrapper) (t #-cmu17 (make-wrapper (length slots) class) #+cmu17 (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) *the-pcl-package*) class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) (error "Slot allocation ~S not supported in bootstrap."))) (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t (setf (wrapper-instance-slots-layout wrapper) (mapcar #'canonical-slot-name slots)) (setf (wrapper-class-slots wrapper) ())) (setq proto (if (eq meta 'funcallable-standard-class) (allocate-funcallable-instance wrapper) (allocate-standard-instance wrapper))) (setq direct-slots (bootstrap-make-slot-definitions name class direct-slots standard-direct-slot-definition-wrapper nil)) (setq slots (bootstrap-make-slot-definitions name class slots standard-effective-slot-definition-wrapper t)) (case meta ((standard-class funcallable-standard-class) (bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto direct-slots slots direct-default-initargs default-initargs)) (built-in-class ; *the-class-t* (bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto)) (slot-class ; *the-class-slot-object* (bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper proto)) (structure-class ; *the-class-structure-object* (bootstrap-initialize-class meta class name class-eq-specializer-wrapper source direct-supers direct-subclasses cpl wrapper)))))))) (let* ((smc-class (find-class 'standard-method-combination)) (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper)) (smc (allocate-standard-instance smc-wrapper))) (flet ((set-slot (name value) (bootstrap-set-slot 'standard-method-combination smc name value))) (set-slot 'source (load-truename)) (set-slot 'type 'standard) (set-slot 'documentation "The standard method combination.") (set-slot 'options ())) (setq *standard-method-combination* smc)))) ;;; ;;; Initialize a class metaobject. ;;; (defun bootstrap-initialize-class (metaclass-name class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper &optional proto direct-slots slots direct-default-initargs default-initargs) (flet ((classes (names) (mapcar #'find-class names)) (set-slot (slot-name value) (bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) (set-slot 'source source) (set-slot 'type (if (eq class (find-class 't)) t `(class ,class))) (set-slot 'class-eq-specializer (let ((spec (allocate-standard-instance class-eq-wrapper))) (bootstrap-set-slot 'class-eq-specializer spec 'type `(class-eq ,class)) (bootstrap-set-slot 'class-eq-specializer spec 'object class) spec)) (set-slot 'class-precedence-list (classes cpl)) (set-slot 'can-precede-list (classes (cdr cpl))) (set-slot 'incompatible-superclass-list nil) (set-slot 'direct-superclasses (classes direct-supers)) (set-slot 'direct-subclasses (classes direct-subclasses)) (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) #+new-kcl-wrapper (setf (si::s-data-name wrapper) name) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) (make-class-predicate-name name))) (set-slot 'plist `(,@(and direct-default-initargs `(direct-default-initargs ,direct-default-initargs)) ,@(and default-initargs `(default-initargs ,default-initargs)))) (when (memq metaclass-name '(standard-class funcallable-standard-class structure-class slot-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) (if (eq metaclass-name 'structure-class) (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) (make-class-predicate-name name))) (set-slot 'defstruct-form `(defstruct (structure-object (:constructor ,constructor-sym)))) (set-slot 'defstruct-constructor constructor-sym) (set-slot 'from-defclass-p t) (set-slot 'plist nil) (set-slot 'prototype (funcall constructor-sym))) (set-slot 'prototype (or proto (allocate-standard-instance wrapper)))) class)) (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) (let ((index -1)) (mapcar #'(lambda (slot) (incf index) (bootstrap-make-slot-definition name class slot wrapper effective-p index)) slots))) (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) (let* ((slotd-class-name (if effective-p 'standard-effective-slot-definition 'standard-direct-slot-definition)) (slotd (allocate-standard-instance wrapper)) (slot-name (getf slot :name))) (flet ((get-val (name) (getf slot name)) (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val))) (set-val 'name slot-name) (set-val 'initform (get-val :initform)) (set-val 'initfunction (get-val :initfunction)) (set-val 'initargs (get-val :initargs)) (set-val 'readers (get-val :readers)) (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) (set-val 'type (or (get-val :type) t)) (set-val 'documentation (or (get-val :documentation) "")) (set-val 'class class) (when effective-p (set-val 'location index) (let ((fsc-p nil)) (set-val 'reader-function (make-optimized-std-reader-method-function fsc-p slot-name index)) (set-val 'writer-function (make-optimized-std-writer-method-function fsc-p slot-name index)) (set-val 'boundp-function (make-optimized-std-boundp-method-function fsc-p slot-name index))) (set-val 'accessor-flags 7) (let ((table (or (gethash slot-name *name->class->slotd-table*) (setf (gethash slot-name *name->class->slotd-table*) (make-hash-table :test 'eq :size 5))))) (setf (gethash class table) slotd))) (when (and (eq name 'standard-class) (eq slot-name 'slots) effective-p) (setq *the-eslotd-standard-class-slots* slotd)) (when (and (eq name 'funcallable-standard-class) (eq slot-name 'slots) effective-p) (setq *the-eslotd-funcallable-standard-class-slots* slotd)) slotd))) (defun bootstrap-accessor-definitions (early-p) (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) (meta (ecd-metaclass definition))) (unless (eq meta 'built-in-class) (let ((direct-slots (ecd-canonical-slots definition))) (dolist (slotd direct-slots) (let ((slot-name (getf slotd :name)) (readers (getf slotd :readers)) (writers (getf slotd :writers))) (bootstrap-accessor-definitions1 name slot-name readers writers nil) (bootstrap-accessor-definitions1 'slot-object slot-name (list (slot-reader-symbol slot-name)) (list (slot-writer-symbol slot-name)) (list (slot-boundp-symbol slot-name))))))))))) (defun bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) (ecase type (reader (values 'standard-reader-method #'make-std-reader-method-function (list class-name) (list class-name) "automatically generated reader method")) (writer (values 'standard-writer-method #'make-std-writer-method-function (list 'new-value class-name) (list 't class-name) "automatically generated writer method")) (boundp (values 'standard-boundp-method #'make-std-boundp-method-function (list class-name) (list class-name) "automatically generated boundp method"))) (let ((gf (ensure-generic-function accessor-name))) (if (find specls (early-gf-methods gf) :key #'early-method-specializers :test #'equal) (unless (assoc accessor-name *generic-function-fixups* :test #'equal) (update-dfun gf)) (add-method gf (make-a-method accessor-class () arglist specls (funcall make-method-function class-name slot-name) doc slot-name)))))) (defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps) (flet ((do-reader-definition (reader) (bootstrap-accessor-definition class-name reader slot-name 'reader)) (do-writer-definition (writer) (bootstrap-accessor-definition class-name writer slot-name 'writer)) (do-boundp-definition (boundp) (bootstrap-accessor-definition class-name boundp slot-name 'boundp))) (dolist (reader readers) (do-reader-definition reader)) (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) (defun bootstrap-class-predicates (early-p) (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) (class (find-class name))) (setf (find-class-predicate name) (make-class-predicate class (class-predicate-name class))))))) (defun bootstrap-built-in-classes () ;; ;; First make sure that all the supers listed in *built-in-class-lattice* ;; are themselves defined by *built-in-class-lattice*. This is just to ;; check for typos and other sorts of brainos. ;; (dolist (e *built-in-classes*) (dolist (super (cadr e)) (unless (or (eq super 't) (assq super *built-in-classes*)) (error "In *built-in-classes*: ~S has ~S as a super,~%~ but ~S is not itself a class in *built-in-classes*." (car e) super super)))) ;; ;; In the first pass, we create a skeletal object to be bound to the ;; class name. ;; (let* ((built-in-class (find-class 'built-in-class)) (built-in-class-wrapper (class-wrapper built-in-class))) (dolist (e *built-in-classes*) (let ((class (allocate-standard-instance built-in-class-wrapper))) (setf (find-class (car e)) class)))) ;; ;; In the second pass, we initialize the class objects. ;; (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) (dolist (e *built-in-classes*) ; FIXME use regular destructuring-bind (pcl-destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) #+cmu17 (lclass (lisp:find-class name)) (wrapper #-cmu17(make-wrapper 0 class) #+cmu17(kernel:class-layout lclass))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) #+cmu17 (setf (kernel:class-pcl-class lclass) class) #-cmu17 (setf (wrapper-instance-slots-layout wrapper) () (wrapper-class-slots wrapper) ()) (bootstrap-initialize-class 'built-in-class class name class-eq-wrapper nil supers subs (cons name cpl) wrapper prototype))))) (dolist (e *built-in-classes*) (let* ((name (car e)) (class (find-class name))) (setf (find-class-predicate name) (make-class-predicate class (class-predicate-name class)))))) ;;; ;;; ;;; #-(or new-kcl-wrapper cmu17) (progn (defvar *built-in-or-structure-wrapper-table* (make-hash-table :test 'eq)) (defvar wft-type1 nil) (defvar wft-wrapper1 nil) (defvar wft-type2 nil) (defvar wft-wrapper2 nil) (defun wrapper-for-structure (x) (let ((type (structure-type x))) (when (symbolp type) (cond ((eq type 'std-instance) (return-from wrapper-for-structure (std-instance-wrapper x))) ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1)) ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2)) (t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) (let* ((cell (find-class-cell type)) (class (or (find-class-cell-class cell) (let* (#+lucid (*structure-type* type) #+lucid (*structure-length* (structure-length x type))) (find-class-from-cell type cell)))) (wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) (when (symbolp type) (setq wft-type1 type wft-wrapper1 wrapper)) wrapper))) (defun built-in-or-structure-wrapper1 (x) (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*))) (or (and (eq biw *the-wrapper-of-t*) (structurep x) (let* ((type (type-of x)) #+lucid (*structure-type* type) #+lucid (*structure-length* (structure-length x type)) (class (find-class type nil))) (and class (class-wrapper class)))) biw))) ) #|| ; moved to low.lisp (defmacro built-in-or-structure-wrapper (x) (once-only (x) (if (structure-functions-exist-p) ; otherwise structurep is too slow for this `(if (structurep ,x) (wrapper-for-structure ,x) (if (symbolp ,x) (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) (built-in-wrapper-of ,x))) `(or (and (symbolp ,x) (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) (built-in-or-structure-wrapper1 ,x))))) #-cmu17 (defmacro wrapper-of-macro (x) `(cond ((std-instance-p ,x) (std-instance-wrapper ,x)) ((fsc-instance-p ,x) (fsc-instance-wrapper ,x)) (t (#+new-kcl-wrapper built-in-wrapper-of #-new-kcl-wrapper built-in-or-structure-wrapper ,x)))) #+cmu17 (defmacro wrapper-of-macro (x) `(kernel:layout-of ,x)) ||# (defun class-of (x) (wrapper-class* (wrapper-of-macro x))) #+cmu17 (declaim (inline wrapper-of)) (defun wrapper-of (x) (wrapper-of-macro x)) #-cmu17 (defun structure-wrapper (x) (class-wrapper (find-class (structure-type x)))) (defvar find-structure-class nil) (defun eval-form (form) #'(lambda () (eval form))) (defun slot-initargs-from-structure-slotd (slotd) `(:name ,(structure-slotd-name slotd) :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) :internal-reader-function ,(structure-slotd-reader-function slotd) :internal-writer-function ,(structure-slotd-writer-function slotd) :type ,(or (structure-slotd-type slotd) t) :initform ,(structure-slotd-init-form slotd) :initfunction ,(eval-form (structure-slotd-init-form slotd)))) (defun find-structure-class (symbol) (if (structure-type-p symbol) (unless (eq find-structure-class symbol) (let ((find-structure-class symbol)) (ensure-class symbol :metaclass 'structure-class :name symbol :direct-superclasses (when (structure-type-included-type-name symbol) (list (structure-type-included-type-name symbol))) :direct-slots (mapcar #'slot-initargs-from-structure-slotd (structure-type-slot-description-list symbol))))) (error "~S is not a legal structure class name." symbol))) #-cmu17 (eval-when (compile eval) (defun make-built-in-class-subs () (mapcar #'(lambda (e) (let ((class (car e)) (class-subs ())) (dolist (s *built-in-classes*) (when (memq class (cadr s)) (pushnew (car s) class-subs))) (cons class class-subs))) (cons '(t) *built-in-classes*))) (defun make-built-in-class-tree () (let ((subs (make-built-in-class-subs))) (labels ((descend (class) (cons class (mapcar #'descend (cdr (assq class subs)))))) (descend 't)))) (defun make-built-in-wrapper-of-body () (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) 'x #'get-built-in-wrapper-symbol)) (defun make-built-in-wrapper-of-body-1 (tree var get-symbol) (let ((*specials* ())) (declare (special *specials*)) (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) `(locally (declare (special .,*specials*)) ,inner)))) (defun make-built-in-wrapper-of-body-2 (tree var get-symbol) (declare (special *specials*)) (let ((symbol (funcall get-symbol (car tree)))) (push symbol *specials*) (let ((sub-tests (mapcar #'(lambda (x) (make-built-in-wrapper-of-body-2 x var get-symbol)) (cdr tree)))) `(and (typep ,var ',(car tree)) ,(if sub-tests `(or ,.sub-tests ,symbol) symbol))))) ) #-cmu17 (defun built-in-wrapper-of (x) #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file (make-built-in-wrapper-of-body))) (defun method-function-returning-nil (args next-methods) (declare (ignore args next-methods)) nil) (defun method-function-returning-t (args next-methods) (declare (ignore args next-methods)) t) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name)) (mlist (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) (unless mlist (unless (eq class *the-class-t*) (let* ((default-method-function #'method-function-returning-nil) (default-method-initargs (list :function default-method-function)) (default-method (make-a-method 'standard-method () (list 'object) (list *the-class-t*) default-method-initargs "class predicate default method"))) (setf (method-function-get default-method-function :constant-value) nil) (add-method gf default-method))) (let* ((class-method-function #'method-function-returning-t) (class-method-initargs (list :function class-method-function)) (class-method (make-a-method 'standard-method () (list 'object) (list class) class-method-initargs "class predicate class method"))) (setf (method-function-get class-method-function :constant-value) t) (add-method gf class-method))) gf)) #+cmu17 ;;; Set inherits from CPL and register layout. This actually installs the ;;; class in the lisp type system. ;;; (defun update-lisp-class-layout (class layout) (unless (eq (kernel:class-layout (kernel:layout-class layout)) layout) (setf (kernel:layout-inherits layout) (map 'vector #'class-wrapper (reverse (rest (class-precedence-list class))))) (kernel:register-layout layout :invalidate nil))) (eval-when (load eval) (clrhash *find-class*) (bootstrap-meta-braid) (bootstrap-accessor-definitions t) (bootstrap-class-predicates t) (bootstrap-accessor-definitions nil) (bootstrap-class-predicates nil) (bootstrap-built-in-classes) #+cmu17 (ext:do-hash (name x *find-class*) (let* ((class (find-class-from-cell name x)) (layout (class-wrapper class)) (lclass (kernel:layout-class layout)) (lclass-pcl-class (kernel:class-pcl-class lclass)) (olclass (lisp:find-class name nil))) (if lclass-pcl-class (assert (eq class lclass-pcl-class)) (setf (kernel:class-pcl-class lclass) class)) (update-lisp-class-layout class layout) (cond (olclass (assert (eq lclass olclass))) (t (setf (lisp:find-class name) lclass))))) (setq *boot-state* 'braid) ) #-cmu17 (deftype slot-object () '(or standard-object structure-object)) (defmethod no-applicable-method (generic-function &rest args) (cerror "Retry call to ~S" "No matching method for the generic-function ~S,~@ when called with arguments ~S." generic-function args) (apply generic-function args)) gcl-2.6.14/pcl/unused/0000755000175000017500000000000014360276512013054 5ustar cammcammgcl-2.6.14/pcl/unused/precom4.lisp0000644000175000017500000000236214360276512015321 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'pcl) (precompile-function-generators pcl) ;this is half of a call to ;precompile-random-code-segments gcl-2.6.14/pcl/impl/0000755000175000017500000000000014360276512012512 5ustar cammcammgcl-2.6.14/pcl/impl/hp/0000755000175000017500000000000014360276512013121 5ustar cammcammgcl-2.6.14/pcl/impl/hp/hp-low.lisp0000644000175000017500000000245714360276512015230 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the HP Common Lisp version of the file low. ;;; ;;; (in-package 'pcl) (defun printing-random-thing-internal (thing stream) (format stream "~O" (prim:@inf thing))) gcl-2.6.14/pcl/impl/cmu/0000755000175000017500000000000014360276512013276 5ustar cammcammgcl-2.6.14/pcl/impl/cmu/pclload.lisp0000644000175000017500000000063014360276512015604 0ustar cammcamm(in-package "PCL") (unless (find-package "SLOT-ACCESSOR-NAME") (make-package "SLOT-ACCESSOR-NAME")) (rename-package "PCL" "PCL" '("OLD-PCL")) (rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '("OLD-SLOT-ACCESSOR-NAME")) (import 'kernel:funcallable-instance-p) (load "target:pcl/defsys") (load-pcl) (rename-package "PCL" "PCL" '()) (rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '()) gcl-2.6.14/pcl/impl/cmu/pclcom.lisp0000644000175000017500000000407314360276512015450 0ustar cammcamm;; This is "target:tools/pclcom.lisp" (in-package "USER") (when (find-package "PCL") (setf (compiler-macro-function 'make-instance) nil) ;; ;; Undefine all generic functions exported from Lisp so that bootstrapping ;; doesn't get confused. (let ((class (find-class 'generic-function nil))) (when class (do-external-symbols (sym "LISP") (when (and (fboundp sym) (typep (fdefinition sym) class)) (fmakunbound sym)) (let ((ssym `(setf ,sym))) (when (and (fboundp ssym) (typep (fdefinition ssym) class)) (fmakunbound ssym)))))) ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots. (let ((wot (find-symbol "*FIND-CLASS*" "PCL"))) (when (and wot (boundp wot)) (do-hash (name ignore (symbol-value wot)) (declare (ignore ignore)) (let ((class (find-class name nil))) (cond ((not class)) ((typep class 'kernel::std-class) (setf (kernel:class-cell-class (kernel:find-class-cell name)) nil) (setf (info type kind name) nil)) (t (setf (kernel:class-pcl-class class) nil))))))) (rename-package "PCL" "OLD-PCL") (make-package "PCL")) (when (find-package "SLOT-ACCESSOR-NAME") (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME")) (setf c:*suppress-values-declaration* t) (pushnew :setf *features*) (setf (search-list "pcl:") '("target:pcl/")) (let ((obj (make-pathname :defaults "pcl:defsys" :type (c:backend-fasl-file-type c:*backend*)))) (when (< (or (file-write-date obj) 0) (file-write-date "pcl:defsys.lisp")) (compile-file "pcl:defsys" :byte-compile t))) (load "pcl:defsys" :verbose t) (import 'kernel:funcallable-instance-p (find-package "PCL")) (with-compilation-unit (:optimize '(optimize (debug #+small .5 #-small 2) (speed 2) (safety #+small 0 #-small 2) (inhibit-warnings 2)) :optimize-interface '(optimize-interface #+small (safety 1)) :context-declarations '((:external (declare (optimize-interface (safety 2) (debug 1)))) ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) (declare (optimize (speed 0)))))) (pcl::compile-pcl)) gcl-2.6.14/pcl/impl/cmu/cmu-low.lisp0000644000175000017500000001610014360276512015550 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the CMU Lisp version of the file low. ;;; (in-package :pcl) #+small (setq *optimize-speed* '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3))) (defmacro dotimes ((var count &optional (result nil)) &body body) `(lisp:dotimes (,var (the fixnum ,count) ,result) (declare (fixnum ,var)) ,@body)) ;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local ;;; macros spec'ed in low.lisp, but they aren't used. ;;; (defmacro without-interrupts (&rest stuff) `(sys:without-interrupts ,@stuff)) (defun function-arglist (fcn) "Returns the argument list of a compiled function, if possible." (cond ((symbolp fcn) (when (fboundp fcn) (function-arglist (symbol-function fcn)))) ((eval:interpreted-function-p fcn) (eval:interpreted-function-arglist fcn)) ((functionp fcn) (let ((lambda-expr (function-lambda-expression fcn))) (if lambda-expr (cadr lambda-expr) (let ((function (kernel:%closure-function fcn))) (values (read-from-string (kernel:%function-arglist function))))))))) ;;; And returns the function, not the *name*. (defun set-function-name (fcn new-name) "Set the name of a compiled function object." (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) (set-function-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) (if (if (eq *boot-state* 'complete) (typep fcn 'generic-function) (eq (class-of fcn) *the-class-standard-generic-function*)) (setf (kernel:%funcallable-instance-info fcn 1) new-name) (typecase fcn (kernel:byte-closure (set-function-name (kernel:byte-closure-function fcn) new-name)) (kernel:byte-function (setf (kernel:byte-function-name fcn) new-name)))) fcn) ((eval:interpreted-function-p fcn) (setf (eval:interpreted-function-name fcn) new-name) fcn) (t (let ((header (kernel:%closure-function fcn))) #+cmu17 (setf (c::%function-name header) new-name) #-cmu17 (system:%primitive c::set-function-name header new-name)) fcn))) (in-package "C") (def-source-context pcl:defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) ,(nth-value 2 (pcl::parse-specialized-lambda-list (elt stuff arg-pos)))) `(pcl:defmethod ,name "")))) (in-package "PCL") ;;;; STD-INSTANCE ;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate ;;; between functions (including FINs) and normal instances, so we can return ;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) ;;; are changed to pcl-instance-p. ;;; (defmacro std-instance-p (x) `(kernel:%instancep ,x)) (defmacro pcl-instance-p (x) `(typep (kernel:layout-of ,x) 'wrapper)) ;;; We define this as STANDARD-INSTANCE, since we're going to clobber the ;;; layout with some standard-instance layout as soon as we make it, and we ;;; want the accesor to still be type-correct. ;;; (defstruct (standard-instance (:predicate nil) (:constructor %%allocate-instance--class--fn ()) (:alternate-metaclass kernel:instance lisp:standard-class kernel:make-standard-class)) (slots nil)) ;;; Must immediately setf the std-instance-wrapper after calling this. (defmacro %%allocate-instance--class () `(ext:truly-the standard-instance (kernel:%make-instance 2))) ;;; Both of these operations "work" on structures, which allows the above ;;; weakening of std-instance-p. ;;; (defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) (defmacro get-wrapper (inst) (ext:once-only ((wrapper `(wrapper-of ,inst))) `(progn (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") ,wrapper))) (defmacro get-instance-wrapper-or-nil (inst) (ext:once-only ((wrapper `(wrapper-of ,inst))) `(if (typep ,wrapper 'wrapper) ,wrapper nil))) ;;; get-slots harmless (defmacro get-slots-or-nil (inst) (ext:once-only ((n-inst inst)) `(when (pcl-instance-p ,n-inst) (if (std-instance-p ,n-inst) (std-instance-slots ,n-inst) (fsc-instance-slots ,n-inst))))) ;;;; Structure-instance stuff: (pushnew :structure-wrapper *features*) (defun structure-functions-exist-p () t) (defun structure-instance-p (x) (typep x 'lisp:structure-object)) (defun structurep (x) (typep x 'lisp:structure-object)) (defun structure-type (x) (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) (defun structure-type-p (type) (and (symbolp type) (let ((class (lisp:find-class type nil))) (and class (typep (kernel:layout-info (kernel:class-layout class)) 'kernel:defstruct-description))))) (defun get-structure-dd (type) (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) (defun structure-type-included-type-name (type) (let ((include (kernel::dd-include (get-structure-dd type)))) (if (consp include) (car include) include))) (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) (and include (kernel:dd-slots (get-structure-dd include))))) (kernel:dd-slots (get-structure-dd type)))) (defun structure-slotd-name (slotd) (kernel:dsd-name slotd)) (defun structure-slotd-accessor-symbol (slotd) (kernel:dsd-accessor slotd)) (defun structure-slotd-reader-function (slotd) (fdefinition (kernel:dsd-accessor slotd))) (defun structure-slotd-writer-function (slotd) (unless (kernel:dsd-read-only slotd) (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) (defun structure-slotd-type (slotd) (kernel:dsd-type slotd)) (defun structure-slotd-init-form (slotd) (kernel::dsd-default slotd)) gcl-2.6.14/pcl/impl/cmu/README0000644000175000017500000000077414360276512014166 0ustar cammcammTo install, put this version of PCL in cmucl's source directory, and name it pcl. rename the cmucl file tools/pclcom.lisp to tools/pclcom.lisp.original link the file impl/cmu/pclcom.lisp to cmucl/tools/pclcom.lisp link the file impl/cmu/pclload.lisp to pclload.lisp For example, cd cmucl17f mv pcl pcl.original <> cd tools mv pclcom.lisp pclcom.lisp.original ln -s ../pcl/impl/cmu/pclcom.lisp pclcom.lisp cd ../pcl ln -s impl/cmu/pclload.lisp pclload.lisp gcl-2.6.14/pcl/impl/franz/0000755000175000017500000000000014360276512013632 5ustar cammcammgcl-2.6.14/pcl/impl/franz/cpatch.lisp0000644000175000017500000000136314360276512015770 0ustar cammcamm;; -[Thu Feb 22 08:38:07 1990 by jkf]- ;; cpatch.cl ;; compiler patch for the fast clos ;; ;; copyright (c) 1990 Franz Inc. ;; (in-package :comp) (def-quad-op tail-funcall qp-end-block ;; u = (argcount function-object) ;; ;; does a tail call to the function-object given ;; never returns ) (defun-in-runtime sys::copy-function (func)) (in-package :hyperion) (def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad) ;; u = (argcount function) ;; (r-move-single-to-loc (treg-loc (car u)) *count-reg*) (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*) (re restore *zero-reg* *zero-reg*) (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*) (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*) (re nop)) gcl-2.6.14/pcl/impl/franz/excl-low.lisp0000644000175000017500000001046014360276512016256 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the EXCL (Franz) lisp version of the file portable-low. ;;; ;;; This is for version 1.1.2. Many of the special symbols now in the lisp ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in ;;; a later release so this will need to be changed. ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(let ((outer-interrupts excl::*without-interrupts*) (excl::*without-interrupts* 0)) (macrolet ((interrupts-on () '(unless outer-interrupts (setq excl::*without-interrupts* nil))) (interrupts-off () '(setq excl::*without-interrupts* 0))) ,.body))) (eval-when (compile load eval) (unless (fboundp 'excl::sy_hash) (setf (symbol-function 'excl::sy_hash) (symbol-function 'excl::_sy_hash-value))) ) (defmacro memq (item list) (let ((list-var (gensym)) (item-var (gensym))) `(prog ((,list-var ,list) (,item-var ,item)) start (cond ((null ,list-var) (return nil)) ((eq (car ,list-var) ,item-var) (return ,list-var)) (t (pop ,list-var) (go start)))))) (defun std-instance-p (x) (and (excl::structurep x) (locally (declare #.*optimize-speed*) (eq (svref x 0) 'std-instance)))) (excl::defcmacro std-instance-p (x) (once-only (x) `(and (excl::structurep ,x) (locally (declare #.*optimize-speed*) (eq (svref ,x 0) 'std-instance))))) (excl::defcmacro fast-method-call-p (x) (once-only (x) `(and (excl::structurep ,x) (locally (declare #.*optimize-speed*) (eq (svref ,x 0) 'fast-method-call))))) (defmacro %std-instance-wrapper (x) `(svref ,x 1)) (defmacro %std-instance-slots (x) `(svref ,x 2)) (defun printing-random-thing-internal (thing stream) (format stream "~O" (excl::pointer-to-fixnum thing))) #-vax (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((excl::function-object-p fn) (setf (excl::fn_symdef fn) new-name)) (t nil)) fn) (defun function-arglist (f) (excl::arglist f)) (defun symbol-append (sym1 sym2 &optional (package *package*)) ;; This is a version of symbol-append from macros.cl ;; It insures that all created symbols are of one case and that ;; case is the current prefered case. ;; This special version of symbol-append is not necessary if all you ;; want to do is compile and run pcl in a case-insensitive-upper ;; version of cl. ;; (let ((string (string-append sym1 sym2))) (case excl::*current-case-mode* ((:case-insensitive-lower :case-sensitive-lower) (setq string (string-downcase string))) ((:case-insensitive-upper :case-sensitive-upper) (setq string (string-upcase string)))) (intern string package))) ;;; Define inspector hooks for PCL object instances. (defun (:property pcl::std-instance :inspector-function) (object) (let ((class (class-of object))) (cons (inspect::make-field-def "class" #'class-of :lisp) (mapcar #'(lambda (slot) (inspect::make-field-def (string (slot-definition-name slot)) #'(lambda (x) (slot-value-using-class class x slot)) :lisp)) (slots-to-inspect class object))))) (defun (:property pcl::std-instance :inspector-type-function) (x) (class-name (class-of x))) gcl-2.6.14/pcl/impl/franz/quadlap.lisp0000644000175000017500000004124514360276512016160 0ustar cammcamm;; -[Thu Mar 1 10:54:27 1990 by jkf]- ;; pcl to quad translation ;; $Header$ ;; ;; copyright (c) 1990 Franz Inc. ;; (in-package :compiler) (defvar *arg-to-treg* nil) (defvar *cvar-to-index* nil) (defvar *reg-array* nil) (defvar *closure-treg* nil) (defvar *nargs-treg* nil) (defvar *debug-sparc* nil) (defmacro pcl-make-lambda (&key required) `(list 'lambda nil :unknown-type 0 compiler::.function-level. ,required nil nil nil nil nil nil nil nil nil nil 'compiler::none nil nil nil nil nil nil nil nil nil 0 nil)) (defmacro pcl-make-varrec (&key name loc contour-level) `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level)) (defmacro pcl-make-lap (&key lap constants cframe-size locals) `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil)) (defstruct preg ;; pseudo reg descritpor treg ; associated treg index ; :index if this is an index type reg ; :vector if this is a vector type reg ) (defun pcl::excl-lap-closure-generator (closure-vars-names arg-names index-regs vector-regs fixnum-vector-regs t-regs lap-code) (let ((function (pcl::excl-lap-closure-gen closure-vars-names arg-names index-regs (append vector-regs fixnum-vector-regs) t-regs lap-code))) #'(lambda (&rest closure-vals) (insert-closure-vals function closure-vals)))) (defun pcl::excl-lap-closure-gen (closure-vars-names arg-names index-regs vector-regs t-regs lap-code) (let ((*quads* nil) (*treg-num* 0) (*all-tregs* nil) (*bb-count* 0) *treg-bv-size* *treg-vector* (*next-catch-frame* 0) (*max-catch-frame* -1) *catch-labels* *top-label* *mv-treg* *mv-treg-target* *zero-treg* *nil-treg* *bbs* *bb* lap ;; bbs *cross-block-regs* *const-tregs* *move-tregs* *actuals* *ignore-argcount* *binds-specs* *bvl-current-bv* ; for bitvector cacher *bvl-used-bvs* *bvl-index* (*inhibit-call-count* t) ; this fcn *arg-to-treg* *cvar-to-index* *reg-array* minargs maxargs *closure-treg* node otherargregs *nargs-treg* ) (if* *debug-sparc* then (format t ">>** << Generating sparc lap code~%")) (setq *nil-treg* #+allegro-v4.0 (new-reg :global t) #-allegro-v4.0 (new-reg) *mv-treg* (new-reg) *mv-treg-target* (list *mv-treg*) *zero-treg* (comp::new-reg)) ; examine given args (setq minargs 0 maxargs 0) (let (requireds) (dolist (arg arg-names) (if* (eq '&rest arg) then (setq maxargs nil) else (if* (null arg) then ; we want a name even though we won't use it (setq arg (gensym))) (incf minargs) (incf maxargs) (push (cons arg (new-reg)) *arg-to-treg*) (push (pcl-make-varrec :name arg :loc (cdr (car *arg-to-treg*)) :contour-level 0) requireds) )) (setq node (pcl-make-lambda :required (nreverse requireds)))) (setq *arg-to-treg* (nreverse *arg-to-treg*)) ; build closure vector list (let ((index -1)) (dolist (cvar closure-vars-names) (push (cons cvar (incf index)) *cvar-to-index*))) (let ((maxreg (max (apply #'max (cons -1 index-regs)) (apply #'max (cons -1 vector-regs)) (apply #'max (cons -1 t-regs))))) (setq *reg-array* (make-array (1+ maxreg)))) (dolist (index index-regs) (setf (svref *reg-array* index) (make-preg :treg (new-reg) :index :index))) (dolist (vector vector-regs) (setf (svref *reg-array* vector) (make-preg :treg (new-reg) :index :vector))) (dolist (tr t-regs) (setf (svref *reg-array* tr) (make-preg :treg (new-reg)))) (if* closure-vars-names then (setq *closure-treg* (new-reg))) (setq *nargs-treg* (new-reg)) ;; (md-allocate-global-tregs) ; function entry (qe nop :arg :first-block) (qe entry) (qe argcount :arg (list minargs maxargs)) (qe lambda :d (mapcar #'cdr *arg-to-treg*)) (qe register :arg :nargs :d (list *nargs-treg*)) (if* *closure-treg* then ; put the first closure vector in *closure-treg* (qe extract-closure-vec :d (list *closure-treg*)) (let ((offsetreg (new-reg))) (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg)) (qe ref :u (list *closure-treg* offsetreg) :d (list *closure-treg*) :arg :long)) ) (excl-gen-quads lap-code) (if* *debug-sparc* then (do-quad-list (quad next *quads*) (format t "~a~%" quad)) (format t "basic blocks~%")) (setq *bbs* (qc-compute-basic-blocks *quads*)) (excl::target-class-case ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*)))) (qc-live-variable-analysis *bbs*) (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16))) (qc-build-treg-vector) (let ((*dump-bbs* nil) (r::*local-regs* ; use the in registers that aren't in use (append r::*local-regs* (if* maxargs then (nthcdr maxargs r::*in-regs* ))))) (unwind-protect (progn ; machine specific code generation (multiple-value-bind (lap-code literals size-struct locals) #+(target-class r m e) (progn #+allegro-v4.0 (md-codegen node *bbs* nil otherargregs) #-allegro-v4.0 (md-codegen node *bbs* *nil-treg* *mv-treg* *zero-treg* nil otherargregs)) #-(target-class r m e) (md-codegen node *bbs*) (setq lap (pcl-make-lap :lap lap-code :constants literals :cframe-size size-struct :locals locals))) lap) (giveback-bvs))) #+ignore (progn (format t "sparc code pre optimization~%") (dolist (instr (lap-lap lap)) (format t "> ~a~%" instr))) (md-optimize lap) ; peephole optimize (if* *debug-sparc* then (format t "sparc code post optimization~%") (dolist (instr (lap-lap lap)) (format t "> ~a~%" instr))) (md-assemble lap) (setq last-lap lap) (nl-runtime-make-a-fcnobj lap))) (defun qe-slot-access (operand offset dest) ;; access a slot in a structure (let ((temp (new-reg))) (qe const :arg offset :d (list temp)) (qe ref :u (list (get-treg-of operand) temp) :d (list (get-treg-of dest)) :arg :long))) (defun get-treg-of (operand &optional res-operand) ;; get the appropriate treg for the operand (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand)))) (if* (numberp operand) then (let ((treg (new-reg))) (qe const :arg operand :d (list treg)) treg) elseif (consp operand) then (ecase (car operand) (:reg (preg-treg (svref *reg-array* (cadr operand)))) (:arg (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) (if* (null x) then (error "where is arg ~s" operand) else x))) (:cvar (let ((res-treg (or prefer-treg (new-reg))) (temp-treg (new-reg))) (qe const :arg (+ (mdparam 'md-svector-data0-adj) (* 4 (cdr (assoc (cadr operand) *cvar-to-index* :test #'eq)))) :d (list temp-treg)) (qe ref :u (list *closure-treg* temp-treg) :d (list res-treg) :arg :long) res-treg)) (:constant (let ((treg (or prefer-treg (new-reg)))) (qe const :arg (if* (fixnump (cadr operand)) then (* 8 (cadr operand)) ; md!! else (cadr operand)) :d (list treg)) treg)) (:index-constant ; operand invented by jkf to denote an index type constant (let ((treg (or prefer-treg (new-reg)))) (qe const :arg (if* (fixnump (cadr operand)) then (* 4 (cadr operand)) ; md!! else (cadr operand)) :d (list treg)) treg))) else (error "bad operand: ~s" operand)))) (defun simple-get-treg-of (operand) ;; get the treg if it is so simple that we don't have to ;; emit any instructions to access it. ;; return nil if we can't do it. (if* (numberp operand) then nil elseif (consp operand) then (case (car operand) (:reg (preg-treg (svref *reg-array* (cadr operand)))) (:arg (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) (if* (null x) then nil else x)))) else nil)) (defun index-p (operand) ;; determine if the result of this operand is an index value ;* it would be better if conversion between lisp values and ; index values were made explicit in the lap code (and (consp operand) (or (and (eq :reg (car operand)) (eq :index (preg-index (svref *reg-array* (cadr operand))))) (member (car operand) '(:i+ :i- :ilogand :ilogxor :i1+) :test #'eq)) t)) (defun gen-index-treg (operand) ;; return the non-index type operand in a index treg (if* (and (consp operand) (eq ':constant (car operand))) then (get-treg-of `(:index-constant ,(cadr operand))) else (let ((treg (get-treg-of operand)) (new-reg (new-reg)) (shift-reg (new-reg))) (qe const :arg 1 :d (list shift-reg)) (qe lsr :u (list treg shift-reg) :d (list new-reg)) new-reg))) (defun vector-preg-p (operand) (and (consp operand) (eq :reg (car operand)) (eq :vector (preg-index (svref *reg-array* (cadr operand)))))) (defun excl-gen-quads (laps) ;; generate quads from the lap (dolist (lap laps) (if* *debug-sparc* then (format t ">> ~a~%" lap)) (block again (let ((opcode (car lap)) (op1 (cadr lap)) (op2 (caddr lap))) (case opcode (:move ; can be either simple (both args registers) ; or one arg can be complex and the other simple (case (car op2) ((:iref :instance-ref) ;; assume that this is a lisp store ;;(warn "assuming lisp store in ~s" lap) (let (op1-treg) (if* (not (vector-preg-p (cadr op2))) then ; must offset before store (error "must use vector register in ~s" lap) else (setq op1-treg (get-treg-of (cadr op2)))) (qe set :u (list op1-treg (get-treg-of (caddr op2)) (get-treg-of op1)) :arg :lisp) (return-from again))) (:cdr ;; it certainly is a lisp stoer (let (op1-treg const-reg) (setq op1-treg (get-treg-of (cadr op2))) (setq const-reg (new-reg)) (qe const :arg (mdparam 'md-cons-cdr-adj) :d (list const-reg)) (qe set :u (list op1-treg const-reg (get-treg-of op1)) :arg :lisp) (return-from again)))) ; the 'to'address is simple, the from address may not be (let ((index1 (index-p op1)) (index2 (index-p op2)) (vector1 (vector-preg-p op1)) (vector2 (vector-preg-p op2))) (ecase (car op1) ((:reg :cvar :arg :constant :lisp-symbol) (qe move :u (list (get-treg-of op1 op2)) :d (list (get-treg-of op2)))) (:std-wrapper (qe-slot-access (cadr op1) (+ (* 1 4) (comp::mdparam 'md-svector-data0-adj)) op2)) (:std-slots (qe-slot-access (cadr op1) (+ (* 2 4) (comp::mdparam 'md-svector-data0-adj)) op2)) (:fsc-wrapper (qe-slot-access (cadr op1) (+ (* (- 15 1) 4) (comp::mdparam 'md-function-const0-adj)) op2)) (:fsc-slots (qe-slot-access (cadr op1) (+ (* (- 15 2) 4) (comp::mdparam 'md-function-const0-adj)) op2)) ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper) (qe call :arg 'pcl::built-in-or-structure-wrapper :u (list (get-treg-of (cadr op1))) :d (list (get-treg-of op2)))) (:other-wrapper (warn "do other-wrapper")) ((:i+ :i- :ilogand :ilogxor) (qe arith :arg (cdr (assoc (car op1) '((:i+ . :+) (:i- . :-) (:ilogand . :logand) (:ilogxor . :logxor)) :test #'eq)) :u (list (get-treg-of (cadr op1)) (get-treg-of (caddr op1))) :d (list (get-treg-of op2)))) (:i1+ (let ((const-reg (new-reg))) (qe const :arg 4 ; an index value of 1 :d (list const-reg)) (qe arith :arg :+ :u (list const-reg (get-treg-of (cadr op1))) :d (list (get-treg-of op2))))) ((:iref :cref :instance-ref) (let (op1-treg) (if* (not (vector-preg-p (cadr op1))) then ; must offset before store (error "must use vector register in ~s" lap) else (setq op1-treg (get-treg-of (cadr op1)))) (qe ref :u (list op1-treg (get-treg-of (caddr op1) op2)) :d (list (get-treg-of op2)) :arg :long))) (:cdr (let ((const-reg (new-reg))) (qe const :arg (mdparam 'md-cons-cdr-adj) :d (list const-reg)) (qe ref :arg :long :u (list (get-treg-of (cadr op1)) const-reg) :d (list (get-treg-of op2)))))) (if* (not (eq index1 index2)) then (let ((shiftamt (new-reg))) (qe const :arg 1 :d (list shiftamt)) (if* (and index1 (not index2)) then ; converting from index to non-index (qe lsl :u (list (get-treg-of op2) shiftamt) :d (list (get-treg-of op2))) elseif (and (not index1) index2) ; converting to an index then (qe lsr :u (list (get-treg-of op2) shiftamt) :d (list (get-treg-of op2))))) elseif (and vector2 (not vector1)) then ; add vector offset (let ((tempreg (new-reg)) (vreg (get-treg-of op2))) (qe const :arg (mdparam 'md-svector-data0-adj) :d (list tempreg)) (qe arith :arg :+ :u (list vreg tempreg) :d (list vreg)))))) (:fix= (let (tr1 tr2) (if* (index-p op1) then (setq tr1 (get-treg-of op1)) (if* (not (index-p op2)) then (setq tr2 (gen-index-treg op2)) else (setq tr2 (get-treg-of op2))) elseif (index-p op2) then ; assert: op1 isn't an index treg (setq tr1 (gen-index-treg op1)) (setq tr2 (get-treg-of op2)) else (setq tr1 (get-treg-of op1) tr2 (get-treg-of op2))) (qe bcc :u (list tr1 tr2) :arg (cadddr lap) :arg2 :eq ))) ((:eq :neq :fix=) (if* (not (eq (index-p op1) (index-p op2))) then (error "non matching operands indexwise in: ~s" lap)) (qe bcc :u (list (get-treg-of op1) (get-treg-of op2)) :arg (cadddr lap) :arg2 (cdr (assoc opcode '((:eq . :eq) (:neq . :ne)) :test #'eq)))) (:izerop (qe bcc :u (list (get-treg-of op1) *zero-treg*) :arg (caddr lap) :arg2 :eq)) (:std-instance-p (let ((treg (get-treg-of op1)) (tempreg (new-reg)) (temp2reg (new-reg)) (offsetreg (new-reg)) (nope (pc-genlab))) (qe typecheck :u (list treg) :arg nope :arg2 '(not structure)) (qe const :arg 'pcl::std-instance :d (list tempreg)) (qe const :arg (mdparam 'md-svector-data0-adj) :d (list offsetreg)) (qe ref :u (list treg offsetreg) :d (list temp2reg) :arg :long) (qe bcc :arg2 :eq :u (list tempreg temp2reg) :arg (caddr lap)) (qe label :arg nope))) (:fsc-instance-p (let ((treg (get-treg-of op1)) (nope (pc-genlab)) (offsetreg (new-reg)) (tempreg (new-reg)) (checkreg (new-reg))) (qe typecheck :u (list treg) :arg nope :arg2 '(not compiled-function)) (qe const :arg (mdparam 'md-function-flags-adj) :d (list offsetreg)) (qe ref :u (list treg offsetreg) :d (list tempreg) :arg :ubyte) (qe const :arg pcl::funcallable-instance-flag-bit :d (list checkreg)) (qe bcc :u (list checkreg tempreg) :arg (caddr lap) :arg2 :bit-and) (qe label :arg nope))) (:built-in-instance-p ; always true (qe bra :arg (caddr lap))) (:jmp (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1)))) (:structure-instance-p ; always true (qe bra :arg (caddr lap))) (:return (let (op-treg) (if* (index-p op1) then ; convert to lisp before returning (let ((shiftamt (new-reg))) (setq op-treg (new-reg)) (qe const :arg 1 :d (list shiftamt)) (qe lsl :u (list (get-treg-of op1) shiftamt) :d (list op-treg))) else (setq op-treg (get-treg-of op1))) (qe move :u (list op-treg) :d *mv-treg-target*) (qe return :u *mv-treg-target*))) (:go (qe bra :arg (cadr lap))) (:label (qe label :arg (cadr lap))) (t (warn "ignoring ~s" lap))))))) (defun insert-closure-vals (function closure-vals) ;; build a fucntion from the lap and insert (let ((newfun (sys::copy-function function))) (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals))) newfun)) ; test case: ; (pcl::defclass foo () (a b c)) ; (pcl::defmethod barx ((a foo) b c) a ) ; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*) ; ; to turn it on (if* (not (and (boundp 'user::noquad) (symbol-value 'user::noquad))) then (setq pcl::*make-lap-closure-generator* 'pcl::excl-lap-closure-generator)) gcl-2.6.14/pcl/impl/lucid/0000755000175000017500000000000014360276512013612 5ustar cammcammgcl-2.6.14/pcl/impl/lucid/lucid-low.lisp0000644000175000017500000003013414360276512016403 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the Lucid lisp version of the file portable-low. ;;; ;;; Lucid: (415)329-8400 ;;; (in-package 'pcl) ;;; First, import some necessary "internal" or Lucid-specific symbols (eval-when (eval compile load) (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind #+LCL3.0 ((lcl:warning #'(lambda (condition) (declare (ignore condition)) (lcl:muffle-warning)))) (let ((importer #+LCL3.0 #'sys:import-from-lucid-pkg #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID"))) (if (and x (fboundp x)) (symbol-function x) ;; Only the #'(lambda (x) ...) below is really needed, ;; but when available, the "internal" function ;; 'import-from-lucid-pkg' provides better checking. #'(lambda (name) (import (intern name "LUCID"))))))) ;; ;; We need the following "internal", undocumented Lucid goodies: (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE" #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE")) ;; ;; For without-interrupts. ;; #+LCL3.0 (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as SYS:, whereas in 3.0 lisps, they are homed in the ;; LUCID-COMMON-LISP package. (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as LUCID::, whereas in 3.0 lisps, they have to be ;; accessed as SYS: (mapc importer '( "NEW-STRUCTURE" "STRUCTURE-REF" "STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH" "PROCEDUREP" "PROCEDURE-SYMBOL" "PROCEDURE-REF" "SET-PROCEDURE-REF" )) ; ;; ; ;; The following is for the "patch" to the general defstruct printer. ; (mapc importer '( ; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO" ; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT" ; "STRUCTURE-TYPE" "*PRINT-OUTPUT*" ; )) ;; ;; The following is for a "patch" affecting compilation of %logand&. ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS ;; on *FEATURES*, so this conditionalizes correctly for APOLLO. #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) (mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC")) nil)) ;; end of eval-when ) ;;; ;;; Patch up for the fact that the PCL package creation in defsys.lisp ;;; will probably have an explicit :use list ?? ;;; ;;; #+LCL3.0 (use-package *default-make-package-use-list*) #+lcl3.0 (progn (defvar *saved-compilation-speed* 3) ; the production compiler sometimes ; screws up vars within labels (defmacro dont-use-production-compiler () '(eval-when (compile) (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0)) (proclaim '(optimize (compilation-speed 3))))) (defmacro use-previous-compiler () `(eval-when (compile) (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*))))) ) (defmacro %logand (x y) #-VAX `(%logand& ,x ,y) #+VAX `(logand&-variable ,x ,y)) ;;; Fix for VAX LCL #+VAX (defun logand&-variable (x y) (logand&-variable x y)) ;;; Fix for other LCLs #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) (eval-when (compile load eval) (let* ((logand&-fdesc (get-fdesc 'logand&)) (%logand&-fdesc (copy-structure logand&-fdesc))) (setf (structure-ref %logand&-fdesc 0 t) '%logand&) (setf (structure-ref %logand&-fdesc 7 t) nil) (setf (structure-ref %logand&-fdesc 8 t) nil) (set-fdesc '%logand& %logand&-fdesc)) (eval-when (load) (defun %logand& (x y) (%logand& x y))) (eval-when (eval) (compile '%logand& '(lambda (x y) (%logand& x y)))) );#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX) ;;; ;;; From: JonL ;;; Date: November 28th, 1988 ;;; ;;; Here's a better attempt to do the without-interrupts macro for LCL3.0. ;;; For the 2.1 release, maybe you should just ignore it (i.e, turn it ;;; into a PROGN and "take your chances") since there isn't a uniform way ;;; to do inhibition. 2.1 has interrupts, but no multiprocessing. ;;; ;;; The best bet for protecting the cache is merely to inhibit the ;;; scheduler, since asynchronous interrupts are only run when "scheduled". ;;; Of course, there may be other interrupts, which can cons and which ;;; could cause a GC; but at least they wouldn't be running PCL type code. ;;; ;;; Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again, ;;; but rather simply restore it to the state outside the scope of the call ;;; to WITHOUT-INTERRUPTS. Note also that an explicit call to ;;; MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if ;;; there are any interrupts/schedulings pending; at least the test to see ;;; if any are pending is very fast. #+LCL3.0 (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () `(when (null outer-scheduling-state) (setq lcl:*inhibit-scheduling* nil) (when *scheduler-wakeup* (maybe-call-scheduler)))) (interrupts-off () '(setq lcl:*inhibit-scheduling* t))) (let ((outer-scheduling-state lcl:*inhibit-scheduling*)) (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body) (when (and (null outer-scheduling-state) *scheduler-wakeup*) (maybe-call-scheduler)))))) ;;; The following should override the definitions provided by lucid-low. ;;; #+(or LCL3.0 (and APOLLO DOMAIN/OS)) (progn (defstruct-simple-predicate std-instance std-instance-p) (defstruct-simple-predicate fast-method-call fast-method-call-p) (defstruct-simple-predicate method-call method-call-p) ) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (if (not (procedurep fn)) (error "~S is not a procedure." fn) (if (compiled-function-p fn) ;; This is one of: ;; compiled-function, funcallable-instance, compiled-closure ;; or a macro. ;; So just go ahead and set its name. ;; Only change the name when necessary: maybe it is read-only. (unless (eq new-name (procedure-ref fn procedure-symbol)) (set-procedure-ref fn procedure-symbol new-name)) ;; This is an interpreted function. ;; Seems like any number of different things can happen depending ;; vaguely on what release you are running. Try to do something ;; reasonable. (let ((symbol (procedure-ref fn procedure-symbol))) (cond ((symbolp symbol) ;; In fact, this is the name of the procedure. ;; Just set it. (set-procedure-ref fn procedure-symbol new-name)) ((and (listp symbol) (eq (car symbol) 'lambda)) (setf (car symbol) 'named-lambda (cdr symbol) (cons new-name (cdr symbol)))) ((eq (car symbol) 'named-lambda) (setf (cadr symbol) new-name)))))) fn) (defun function-arglist (fn) (arglist fn)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (%pointer thing))) ;;; ;;; 16-Feb-90 Jon L White ;;; ;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0 ;;; release environment. This adds type optimizers for FUNCALL so that ;;; forms such as: ;;; ;;; (FUNCALL (THE PROCEDURE F) ...) ;;; ;;; and: ;;; ;;; (LET ((F (Frobulate))) ;;; (DECLARE (TYPE COMPILED-FUNCTION F)) ;;; (FUNCALL F ...)) ;;; ;;; will just jump directly to the procedure code, rather than waste time ;;; trying to coerce the functional argument into a procedure. ;;; (in-package "LUCID") ;;; (DECLARE-MACHINE-CLASS COMMON) (set-up-compiler-target 'common) (set-function-descriptor 'FUNCALL :TYPE 'LISP :PREDS 'NIL :EFFECTS 'T :OPTIMIZER #'(lambda (form &optional environment) (declare (ignore form environment)) (let* ((fun (second form)) (lambdap (and (consp fun) (eq (car fun) 'function) (consp (second fun)) (memq (car (second fun)) '(lambda internal-lambda))))) (if (not lambdap) form (alphatize (cons (second fun) (cddr form)) environment)))) :FUNCTIONTYPE '(function (function &rest t) (values &rest t)) :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T) ,#'(lambda (anode fun &rest args) (declare (ignore anode fun args)) `(FAST-FUNCALL ,fun ,@args))) ((COMPILED-FUNCTION &REST T) (VALUES &REST T) ,#'(lambda (anode fun &rest args) (declare (ignore anode fun args)) `(FAST-FUNCALL ,fun ,@args)))) :LAMBDALIST '(FN &REST ARGUMENTS) :ARGS '(1 NIL) :VALUES '(0 NIL) ) (def-compiler-macro fast-funcall (&rest args &environment env) (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV) `(FUNCALL-SUBR . ,args) `(&FUNCALL . ,args))) (setf (symbol-function 'funcall-subr) #'funcall) ;;; (UNDECLARE-MACHINE-CLASS) (restore-compiler-params) (in-package 'pcl) (pushnew :structure-wrapper *features*) (defun structure-functions-exist-p () t) (defun structure-instance-p (x) (and (structurep x) (not (eq 'std-instance (structure-type x))))) (defvar *structure-type* nil) (defvar *structure-length* nil) (defun structure-type-p (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (or (and s-data (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this (and type (eq *structure-type* type))))) (defun structure-type-included-type-name (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this (defun structure-type-slot-description-list (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (if s-data (nthcdr (let ((include (structure-ref s-data 6 'defstruct))) (if include (let ((inc-s-data (gethash include lucid::*defstructs*))) (if inc-s-data (length (structure-ref inc-s-data 7 'defstruct)) 0)) 0)) (map 'list #'(lambda (slotd) (let* ((ds 'lucid::defstruct-slot) (slot-name (system:structure-ref slotd 0 ds)) (position (system:structure-ref slotd 1 ds)) (accessor (system:structure-ref slotd 2 ds)) (read-only-p (system:structure-ref slotd 5 ds))) (list slot-name accessor #'(lambda (x) (system:structure-ref x position type)) (unless read-only-p #'(lambda (v x) (setf (system:structure-ref x position type) v)))))) (structure-ref s-data 7 'defstruct))) ; slots - Fix this (let ((result (make-list *structure-length*))) (dotimes (i *structure-length* result) (let* ((name (format nil "SLOT~D" i)) (slot-name (intern name (or (symbol-package type) *package*))) (i i)) (setf (elt result i) (list slot-name nil #'(lambda (x) (system:structure-ref x i type)) nil)))))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) gcl-2.6.14/pcl/impl/coral/0000755000175000017500000000000014360276512013612 5ustar cammcammgcl-2.6.14/pcl/impl/coral/coral-low.lisp0000644000175000017500000000434114360276512016404 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) #-:ccl-1.3 (ccl::add-transform 'std-instance-p :inline #'(lambda (call) (ccl::verify-arg-count call 1 1) (let ((arg (cadr call))) `(and (eq (ccl::%type-of ,arg) 'structure) (eq (%svref ,arg 0) 'std-instance))))) (eval-when (eval compile load) (proclaim '(inline std-instance-p))) (defun printing-random-thing-internal (thing stream) (prin1 (ccl::%ptr-to-int thing) stream)) (defun set-function-name-1 (function new-name uninterned-name) (declare (ignore uninterned-name)) (cond ((ccl::lfunp function) (ccl::lfun-name function new-name))) function) (defun doctor-dfun-for-the-debugger (gf dfun) #+:ccl-1.3 (let* ((gfspec (and (symbolp (generic-function-name gf)) (generic-function-name gf))) (arglist (generic-function-pretty-arglist gf))) (when gfspec (setf (get gfspec 'ccl::%lambda-list) (if (and arglist (listp arglist)) (format nil "~{~A~^ ~}" arglist) (format nil "~:A" arglist))))) dfun) gcl-2.6.14/pcl/impl/kcl/0000755000175000017500000000000014360276512013263 5ustar cammcammgcl-2.6.14/pcl/impl/kcl/sysdef.lisp0000644000175000017500000001011714360276512015451 0ustar cammcamm;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*- ;;; File: sysdef.lisp ;;; Author: Richard Harris (in-package "DSYS") (defvar *pcl-compiled-p* nil) (defvar *pcl-loaded-p* nil) (unless (boundp 'pcl::*redefined-functions*) (setq pcl::*redefined-functions* nil)) (defun reset-pcl-package () (pcl::reset-pcl-package) (let ((defsys (subfile '("pcl") :name "defsys"))) (setq pcl::*pcl-directory* defsys) (load-file defsys)) (mapc #'(lambda (path) (setf (lfi-fwd (get-loaded-file-info path)) 0)) (pcl-binary-files))) (defun pcl-binary-files () (pcl::system-binary-files 'pcl::pcl)) (defun maybe-load-defsys (&optional compile-defsys-p) (let ((defsys (subfile '("pcl") :name "defsys")) (*use-default-pathname-type* nil) (*skip-load-if-loaded-p* t) (*skip-compile-file-fwd* 0)) (set 'pcl::*pcl-directory* defsys) (when compile-defsys-p (compile-file defsys)) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) #+ignore (reset-pcl-package))) (load-file defsys))) (defun maybe-load-pcl (&optional force-p) (unless (and (null force-p) (fboundp 'pcl::system-binary-files) (every #'(lambda (path) (let* ((path-fwd (file-write-date path)) (lfi (get-loaded-file-info path))) (and lfi path-fwd (= path-fwd (lfi-fwd lfi))))) (pcl-binary-files))) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) (reset-pcl-package))) (pcl::load-pcl))) (defsystem pcl (:pretty-name "PCL") #+akcl (:forms :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp"))) (unless (probe-file cfn) (run-unix-command (format nil "ln -s ~A ~A" (namestring (merge-pathnames "../cmpnew/collectfn.lsp" si::*system-directory*)) (namestring cfn)))))) #+akcl "collectfn" (:forms :compile (progn (maybe-load-defsys t) (if (and (fboundp 'pcl::operation-transformations) (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp"))) (every #'(lambda (trans) (eq (car trans) :load)) (pcl::operation-transformations 'pcl::pcl :compile)))) (maybe-load-pcl) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) (reset-pcl-package)) #+akcl (compiler::emit-fn t) #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" si::*system-directory*)) (#+cmu with-compilation-unit #-cmu progn #+cmu (:optimize '(optimize (user::debug-info #+(and small (not testing)) .5 #-(and small (not testing)) 2) (speed #+testing 1 #-testing 2) (safety #+testing 3 #-testing 0) #+ignore (user::inhibit-warnings 2)) :context-declarations '(#+ignore (:external (declare (user::optimize-interface (safety 2) (debug-info 1)))))) (proclaim #+testing *testing-declaration* #-testing *fast-declaration*) (pcl::compile-pcl)) (reset-pcl-package) (maybe-load-pcl t))) #+cmu (purify)) :load (progn (maybe-load-pcl) #+cmu (purify)))) (defparameter *pcl-files* '((("systems") "lisp" "pcl") (("pcl") "lisp" "sysdef" "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat" "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin" "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc" "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches" "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros" "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2" "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches" "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk" "xerox-low" "xerox-patches") (("pcl") "text" "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes" "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes" "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme"))) gcl-2.6.14/pcl/impl/kcl/misc-kcl-patches.text0000644000175000017500000002374614360276512017334 0ustar cammcammc/cmpaux.c *** c/cmpaux.c Mon Jul 6 00:14:55 1992 --- ../akcl-1-615/c/cmpaux.c Thu Jun 18 20:01:07 1992 *************** *** 229,239 **** if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) return x->st.st_self; if (x->st.st_dim == leng && ( leng % sizeof(object)) ) ! { x->st.st_self[leng] = 0; return x->st.st_self; } else {char *res=malloc(leng+1); bcopy(x->st.st_self,res,leng); --- 229,240 ---- if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) return x->st.st_self; if (x->st.st_dim == leng && ( leng % sizeof(object)) ) ! { if(x->st.st_self[leng] != 0) ! x->st.st_self[leng] = 0; return x->st.st_self; } else {char *res=malloc(leng+1); bcopy(x->st.st_self,res,leng); c/main.c *** c/main.c Mon Jul 6 00:14:59 1992 --- ../akcl-1-615/c/main.c Fri Jul 3 02:19:37 1992 *************** *** 611,621 **** {catch_fatal = -1; if (sgc_enabled) { sgc_quit();} if (sgc_enabled==0) { install_segmentation_catcher() ;} ! FEerror("Caught fatal error [memory may be damaged]"); } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX abort(); #endif --- 611,621 ---- {catch_fatal = -1; if (sgc_enabled) { sgc_quit();} if (sgc_enabled==0) { install_segmentation_catcher() ;} ! FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX abort(); #endif *************** *** 853,872 **** siLsave_system() { int i; - #ifdef HAVE_YP_UNBIND - extern object truename(),namestring(); check_arg(1); ! /* prevent subsequent consultation of yp by getting ! truename now*/ ! vs_base[0]=namestring(truename(vs_base[0])); ! {char name[200]; ! char *dom = name; ! if (0== getdomainname(dom,sizeof(name))) ! yp_unbind(dom);} #endif saving_system = TRUE; GBC(t_contiguous); --- 853,867 ---- siLsave_system() { int i; check_arg(1); ! #ifdef HAVE_YP_UNBIND ! /* see unixsave.c */ ! {char *dname; ! yp_get_default_domain(&dname);} #endif saving_system = TRUE; GBC(t_contiguous); c/num_log.c *** c/num_log.c Mon Jul 6 00:15:00 1992 --- ../akcl-1-615/c/num_log.c Mon Jun 15 21:15:59 1992 *************** *** 266,286 **** return(~j); } int big_bitp(x, p) ! object x; ! int p; { GEN u = MP(x); int ans ; int i = p /32; if (signe(u) < 0) { save_avma; u = complementi(u); restore_avma; } ! if (i < lgef(u)) { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} else if (big_sign(x) < 0) ans = 1; else ans = 0; return ans; } --- 266,286 ---- return(~j); } int big_bitp(x, p) ! object x; ! int p; { GEN u = MP(x); int ans ; int i = p /32; if (signe(u) < 0) { save_avma; u = complementi(u); restore_avma; } ! if (i < lgef(u) -MP_CODE_WORDS) { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} else if (big_sign(x) < 0) ans = 1; else ans = 0; return ans; } c/unixsave.c *** c/unixsave.c Mon Jul 6 00:15:07 1992 --- ../akcl-1-615/c/unixsave.c Fri Jul 3 02:52:36 1992 *************** *** 71,81 **** --- 71,160 ---- break; } else break; } + #include "page.h" + /* string is aligned on a word boundary */ + int + find_string_in_memory(string,length,other_p,function) + char *string; + int length,other_p; + int *function(); + { + int *imem_first,*imem_last,*imem,word; + char *mem; + int len,page_first,page_last,i; + int maxpage = page(heap_end); + if(((int)string & 3) == 0 && length >= 4) /* just to be safe */ + {word=*(int *)string; + for (page_first = 0; page_first < maxpage; page_first++) + if ((enum type)type_map[page_first] != t_other) + break; + for (; page_first < maxpage; page_first++) + if (((enum type)type_map[page_first] == t_other)?other_p:!other_p) + {for (page_last = page_first+1; page_last < maxpage; page_last++) + if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) ) + break; + imem_first=(int *)pagetochar(page_first); + imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 ); + for (imem = imem_first; imem <= imem_last; imem++) + if (*imem == word) + {mem=(char *)imem; + for(i=4; i=length) + if((*function)(mem)) + return TRUE;}}} + return FALSE; + } + + int + fsim_first(address) + char *address; + { + return TRUE; + } + + int + fsim_reset_pointer(address) + char **address; + { + *address = NULL; + return FALSE; + } + + #define t_other_PAGES TRUE + #define NOT_t_other_PAGES FALSE + + int + reset_other_pointers(address) + char *address; + { + int word=(int)address; + find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer); + } + + int + maybe_reset_pointers(address) + char *address; + { + int word=(int)address; + if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first)) + reset_other_pointers(address); + return FALSE; + } + + reset_other_pointers_to_string(string) + char *string; + { + int length=strlen(string)+1; + find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers); + } + + bool saving_system; + memory_save(original_file, save_file) char *original_file, *save_file; { MEM_SAVE_LOCALS; char *data_begin, *data_end; int original_data; *************** *** 100,110 **** --- 179,206 ---- n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } + setbuf(save, stdout_buf); + + #ifdef HAVE_YP_UNBIND + /* yp_get_default_domain() caches the result of getdomainname() in + a malloc'ed block of memory; and gethostbyname saves the result of + yp_get_default_domain() in yet another chunk of memory. These + cached values will cause problems if the saved image is run on a + machine having a different local domainname. [When getdomainname + is called (by CLX, for example) KCL will wait forever.] There doesn't + seem to be any way to uncache these things (apparently yp_unbind does + not do this), nor any good way to find these blocks of memory. */ + + if(saving_system) + {char *dname; + yp_get_default_domain(&dname); + reset_other_pointers(dname);} + #endif READ_HEADER; FILECPY_HEADER; for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) cmpnew/cmpcall.lsp *** cmpnew/cmpcall.lsp Mon Jul 6 00:15:13 1992 --- ../akcl-1-615/cmpnew/cmpcall.lsp Thu Jun 18 21:43:24 1992 *************** *** 118,127 **** --- 118,128 ---- ;;; responsible for maintaining this condition. (let ((*vs* *vs*) (form (caddr funob))) (declare (object form)) (cond ((and (listp args) *use-sfuncall* + (<= (length (cdr args)) 10) ;;Determine if only one value at most is required: (or (eq *value-to-go* 'trash) (and (consp *value-to-go*) (eq (car *value-to-go*) 'var)) lsp/autoload.lsp *** lsp/autoload.lsp Mon Jul 6 00:15:27 1992 --- ../akcl-1-615/lsp/autoload.lsp Tue Jun 16 02:36:45 1992 *************** *** 430,440 **** '(cons fixnum bignum ratio short-float long-float complex character symbol package hash-table array vector string bit-vector structure stream random-state readtable pathname ! cfun cclosure sfun gfun cfdata spice fat-string )) (defun room (&optional x) (let ((l (multiple-value-list (si:room-report))) maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage rbused rbfree nrbpage --- 430,440 ---- '(cons fixnum bignum ratio short-float long-float complex character symbol package hash-table array vector string bit-vector structure stream random-state readtable pathname ! cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure)) (defun room (&optional x) (let ((l (multiple-value-list (si:room-report))) maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage rbused rbfree nrbpage lsp/cmpinit.lsp *** lsp/cmpinit.lsp Mon Jul 6 00:15:28 1992 --- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 *************** *** 4,12 **** (setq compiler::*eval-when-defaults* '(compile eval load)) (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! ! ;;;;; --- 4,13 ---- (setq compiler::*eval-when-defaults* '(compile eval load)) (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! (unless (get 'si::basic-wrapper 'si::s-data) ! (setf (get 'si::s-data 'si::s-data) nil) ! (load "../lsp/defstruct.lsp")) ;;;;; gcl-2.6.14/pcl/impl/kcl/kcl-notes.text0000644000175000017500000000352514360276512016075 0ustar cammcamm Some notes on using "5/1/90 May Day PCL (REV 4b)" with KCL and AKCL. 1. KCL will try to load the PCL file "init" when it starts up, if you rename the files as is mentioned in defsys.lisp and the currect directory is the one containing PCL. I suggest that you do not rename any file except maybe "defsys", and also that you change the (files-renamed-p t) to (files-renamed-p nil) in defsys.lisp. 2. Do not comment out the file kcl-patches.lisp, even if you are using AKCL. It contins a patch to make compiler messages more informative for AKCL, and also sets compiler::*compile-ordinaries* to T, so that methods will get compiled. 3. While fixup.lisp compiles, there will be a pause, because KCL's compiler is not reentrant, and some uncompiled code is run. If you want, you can change the form (fix-early-generic-functions) to (fix-early-generic-functions t) in fixup.lisp to see what is happening. 4. (If you are using AKCL 605 or newer, skip this step.) If you want, you can apply the changes in kcl-mods.text to your KCL or AKCL to make PCL run faster. The file kcl-mods.text is different from what it was in versions of PCL earlier than May Day PCL. If you do not make these changes, or if you made the old changes, things will still work. 5. If you are using AKCL, and you previously used the kcl-low.lisp file from rascal.ics.utexas.edu, you should not use it this time. The kcl-low.lisp that comes with May Day PCL works fine. (If you insist on using an old version of kcl-low.lisp, you will need to use an old version of the KCL part of fin.lisp as well: this is what is done for IBCL, by the way.) 6. I recommend that you use AKCL version 457 or newer rather than using KCL or an older version of AKCL, because there are some bugs in KCL that cause problems for May Day PCL. gcl-2.6.14/pcl/impl/kcl/kcl-patches.lisp0000644000175000017500000002731014360276512016355 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "COMPILER") #+akcl (eval-when (compile load eval) (when (<= system::*akcl-version* 609) (pushnew :pre_akcl_610 *features*)) (if (and (boundp 'si::*akcl-version*) (>= si::*akcl-version* 604)) (progn (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) (when (fboundp 'si::allocate-growth) (pushnew :turbo-closure *features*))) ;; patch around compiler bug. (when (<= si::*akcl-version* 609) (let ((vcs "static int Vcs; ")) (unless (search vcs compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string vcs compiler::*cmpinclude-string*))))) (let ((rset "int Rset; ")) (unless (search rset compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string rset compiler::*cmpinclude-string*)))) (when (get 'si::basic-wrapper 'si::s-data) (pushnew :new-kcl-wrapper *features*) (pushnew :structure-wrapper *features*)) ) #+akcl (progn (unless (fboundp 'real-c2lambda-expr-with-key) (setf (symbol-function 'real-c2lambda-expr-with-key) (symbol-function 'c2lambda-expr-with-key))) (defun c2lambda-expr-with-key (lambda-list body) (declare (special *sup-used*)) (setq *sup-used* t) (real-c2lambda-expr-with-key lambda-list body)) ;There is a bug in the implementation of *print-circle* that ;causes some akcl debugging commands (including :bt and :bl) ;to cause the following error when PCL is being used: ;Unrecoverable error: value stack overflow. ;When a CLOS object is printed, travel_push_object ends up ;traversing almost the whole class structure, thereby overflowing ;the value-stack. ;from lsp/debug.lsp. ;*print-circle* is badly implemented in kcl. ;it has two separate problems that should be fixed: ; 1. it traverses the printed object putting all objects found ; on the value stack (rather than in a hash table or some ; other structure; this is a problem because the size of the value stack ; is fixed, and a potentially unbounded number of objects ; need to be traversed), and ; 2. it blindly traverses all slots of any ; kind of structure including std-object structures. ; This is safe, but not always necessary, and is very time-consuming ; for CLOS objects (because it will always traverse every class). ;For now, avoid using *print-circle* T when it will cause problems. (eval-when (compile eval) (defmacro si::f (op &rest args) `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) (defmacro si::fb (op &rest args) `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) ) (defun si::display-env (n env) (do ((v (reverse env) (cdr v))) ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) (or (and (consp (car v)) (listp (cdar v))) (return)) (let ((*print-circle* (can-use-print-circle-p (cadar v)))) (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) (defun si::display-compiled-env ( plength ihs &aux (base (si::ihs-vs ihs)) (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) (format si::*display-string* "") (do ((i base ) (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) (format si::*display-string* "~a~@[~d~]=~s~@[,~]" (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) (si::fb < (setq i (si::f + i 1)) end))))) (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") (defentry objnull-p (object) (object "objnull_p")) (defun can-use-print-circle-p (x) (catch 'can-use-print-circle-p (can-use-print-circle-p1 x nil))) (defun can-use-print-circle-p1 (x so-far) (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? (if (member x so-far) (throw 'can-use-print-circle-p t) (let ((so-far (cons x so-far))) (flet ((can-use-print-circle-p (x) (can-use-print-circle-p1 x so-far))) (typecase x (vector (or (not (eq 't (array-element-type x))) (every #'can-use-print-circle-p x))) (cons (and (can-use-print-circle-p (car x)) (can-use-print-circle-p (cdr x)))) (array (or (not (eq 't (array-element-type x))) (let* ((rank (array-rank x)) (dimensions (make-list rank))) (dotimes (i rank) (setf (nth i dimensions) (array-dimension x i))) (or (member 0 dimensions) (do ((cursor (make-list rank :initial-element 0))) (nil) (declare (:dynamic-extent cursor)) (unless (can-use-print-circle-p (apply #'aref x cursor)) (return nil)) (when (si::increment-cursor cursor dimensions) (return t))))))) (t (or (not (si:structurep x)) (let* ((def (si:structure-def x)) (name (si::s-data-name def)) (len (si::s-data-length def)) (pfun (si::s-data-print-function def))) (and (null pfun) (dotimes (i len t) (unless (can-use-print-circle-p (si:structure-ref x name i)) (return nil))))))))))))) (defun si::apply-display-fun (display-fun n lis) (let ((*print-length* si::*debug-print-level*) (*print-level* si::*debug-print-level*) (*print-pretty* nil) (*PRINT-CASE* :downcase) (*print-circle* nil) ) (setf (fill-pointer si::*display-string*) 0) (format si::*display-string* "{") (funcall display-fun n lis) (when (si::fb > (fill-pointer si::*display-string*) n) (setf (fill-pointer si::*display-string*) n) (format si::*display-string* "...")) (format si::*display-string* "}") ) si::*display-string* ) ;The old definition of this had a bug: ;sometimes it returned without calling mv-values. (defun si::next-stack-frame (ihs &aux line-info li i k na) (cond ((si::fb < ihs si::*ihs-base*) (si::mv-values nil nil nil nil nil)) ((let (fun) ;; next lower visible ihs (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) (setq na fun) (cond ((and (setq line-info (get fun 'si::line-info)) (do ((j (si::f + ihs 1) (si::f - j 1)) (form )) ((<= j i) nil) (setq form (si::ihs-fun j)) (cond ((setq li (si::get-line-of-form form line-info)) (return-from si::next-stack-frame (si::mv-values i fun li ;; filename (car (aref line-info 0)) ;;environment (list (si::vs (setq k (si::ihs-vs j))) (si::vs (1+ k)) (si::vs (+ k 2))))))))))))) ((and (not (special-form-p na)) (not (get na 'si::dbl-invisible)) (fboundp na)) (si::mv-values i na nil nil (if (si::ihs-not-interpreted-env i) nil (let ((i (si::ihs-vs i))) (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) (t (si::mv-values nil nil nil nil nil)))) ) #+pre_akcl_610 (progn ;(proclaim '(optimize (safety 0) (speed 3) (space 1))) ;Not needed... make-top-level-form generates defuns now. ;(setq compiler::*compile-ordinaries* t) (eval-when (compile load eval) (unless (fboundp 'original-co1typep) (setf (symbol-function 'original-co1typep) #'co1typep)) ) (defun new-co1typep (f args) (or (original-co1typep f args) (let ((x (car args)) (type (cadr args))) (when (constantp type) (let ((ntype (si::normalize-type (eval type)))) (when (and (eq (car ntype) 'satisfies) (cadr ntype) (symbolp (cadr ntype)) (symbol-package (cadr ntype))) (c1expr `(the boolean (,(cadr ntype) ,x))))))))) (setf (symbol-function 'co1typep) #'new-co1typep) ) #-(or akcl xkcl) (progn (in-package 'system) ;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere ;;; in the lambda-list. The former allows deviation from the CL spec, ;;; but what the heck. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) (defvar *old-defmacro*) (defun new-defmacro (whole env) (flet ((call-old-definition (new-whole) (funcall *old-defmacro* new-whole env))) (if (not (and (consp whole) (consp (cdr whole)) (consp (cddr whole)) (consp (cdddr whole)))) (call-old-definition whole) (let* ((ll (caddr whole)) (env-tail (do ((tail ll (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail))))) (if env-tail (call-old-definition (list* (car whole) (cadr whole) (append (list '&environment (cadr env-tail)) (ldiff ll env-tail) (cddr env-tail)) (cdddr whole))) (call-old-definition whole)))))) (eval-when (load eval) (unless (boundp '*old-defmacro*) (setq *old-defmacro* (macro-function 'defmacro)) (setf (macro-function 'defmacro) #'new-defmacro))) ;;; ;;; setf patches ;;; (defun get-setf-method (form) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value form) (unless (listp vars) (error "The temporary variables component, ~s, of the setf-method for ~s is not a list." vars form)) (unless (listp vals) (error "The values forms component, ~s, of the setf-method for ~s is not a list." vals form)) (unless (listp stores) (error "The store variables component, ~s, of the setf-method for ~s is not a list." stores form)) (unless (= (list-length stores) 1) (error "Multiple store-variables are not allowed.")) (values vars vals stores store-form access-form))) (defun get-setf-method-multiple-value (form) (cond ((symbolp form) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form))) ((or (not (consp form)) (not (symbolp (car form)))) (error "Cannot get the setf-method of ~S." form)) ((get (car form) 'setf-method) (apply (get (car form) 'setf-method) (cdr form))) ((get (car form) 'setf-update-fn) (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym))) (values vars (cdr form) (list store) `(,(get (car form) 'setf-update-fn) ,@vars ,store) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym)) (l (get (car form) 'setf-lambda)) (f `(lambda ,(car l) (funcall #'(lambda ,(cadr l) ,@(cddr l)) ',store)))) (values vars (cdr form) (list store) (apply f vars) (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand-1 form))) (t (error "Cannot expand the SETF form ~S." form)))) ) gcl-2.6.14/pcl/impl/kcl/sys-package.lisp0000644000175000017500000001540314360276512016366 0ustar cammcamm ;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES '("S-A-N")) ;;; Definitions for package PCL of type ESTABLISH (LISP::IN-PACKAGE "PCL" :USE LISP::NIL) ;;; Definitions for package ITERATE of type ESTABLISH (LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) ;;; Definitions for package WALKER of type ESTABLISH (LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES '("S-A-N")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package PCL of type EXPORT (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION PCL::GENERIC-FUNCTION-METHOD-COMBINATION PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS PCL::ADD-METHOD PCL::WITH-ACCESSORS PCL::SLOT-DEFINITION-ALLOCATION PCL::SLOT-DEFINITION-INITFUNCTION PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE PCL::STANDARD-GENERIC-FUNCTION PCL::ACCESSOR-METHOD-SLOT-DEFINITION PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE PCL::SLOT-DEFINITION-NAME PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) ;;; Definitions for package ITERATE of type EXPORT (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING ITERATE::WITH-GATHERING ITERATE::INTERVAL)) ;;; Definitions for package WALKER of type EXPORT (LISP::IN-PACKAGE "WALKER" :USE '("LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package PCL of type SHADOW (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package WALKER of type SHADOW (LISP::IN-PACKAGE "WALKER") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) (lisp::in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) gcl-2.6.14/pcl/impl/kcl/kcl-mods.text0000644000175000017500000002052714360276512015710 0ustar cammcammIf you have akcl version 604 or newer, do not make these patches. (1) Turbo closure patch To make the turbo closure stuff work, make the following changes to KCL. These changes can also work for an IBCL. The three patches in this file add two features (reflected in the value of *features*) to your KCL or IBCL: a feature named :TURBO-CLOSURE which increases the speed of the code generated by FUNCALLABLE-INSTANCE-DATA-1 (previous versions of the file kcl-mods.text had this feature only), and a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed of the function FUNCALLABLE-INSTANCE-P. (This file comprises two features rather than just one to allow the PCL system to be work in KCL systems that do not have this patch, or that have the old version of this patch.) The first of these patches changes the turbo_closure function to store the size of the environment in the turbo structure. The second of patch fixes a garbage-collector bug in which the turbo structure was sometimes ignored, AND also adapts the garbage-collector to conform to the change made in the first patch. The bug has been fixed in newer versions of AKCL, but it is still necessary to apply this patch, if the first and third patches are applied. The third change pushes :turbo-closure and :turbo-closure-env-size on the *features* list so that PCL will know that turbo closures are enabled. Note that these changes have to be made before PCL is compiled, and a PCL which is compiled in a KCL/IBCL with these changes can only be run in a KCL/IBCL with these changes. (1-1) edit the function turbo_closure in the file kcl/c/cfun.c, change the lines ---------- turbo_closure(fun) object fun; { object l; int n; for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) ; fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object)); for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) fun->cc.cc_turbo[n] = l; } ---------- to ---------- turbo_closure(fun) object fun; { object l,*block; int n; if(fun->cc.cc_turbo==NULL) {for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr); block=(object *)alloc_contblock((1+n)*sizeof(object)); *block=make_fixnum(n); fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) fun->cc.cc_turbo[n] = l;} } ---------- (1-2) edit the function mark_object in the file kcl/c/gbc.c, Find the lines following case t_cclosure: in mark_object. If they look like the ones between the lines marked (KCL), make the first change, but if the look like the lines marked (AKCL), apply the second change instead, and if the file sgbc.c exists, apply the third change to it. (1-2-1) Change: (KCL)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (x->cc.cc_start == NULL) break; if (what_to_collect == t_contiguous) { if (get_mark_bit((int *)(x->cc.cc_start))) break; mark_contblock(x->cc.cc_start, x->cc.cc_size); if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (KCL)---------- to (KCL new)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) if (x->cc.cc_turbo != NULL) { mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } if (x->cc.cc_start == NULL) break; if (what_to_collect == t_contiguous) { if (get_mark_bit((int *)(x->cc.cc_start))) break; mark_contblock(x->cc.cc_start, x->cc.cc_size); } break; (KCL new)---------- (1-2-2) Or, Change: (AKCL)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (AKCL)---------- To: (AKCL new)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } break; (AKCL new)---------- (1-2-3) In sgbc.c (if it exists), Change: (AKCL)---------- case t_cclosure: sgc_mark_object(x->cc.cc_name); sgc_mark_object(x->cc.cc_env); sgc_mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (AKCL)---------- To: (AKCL new)---------- case t_cclosure: sgc_mark_object(x->cc.cc_name); sgc_mark_object(x->cc.cc_env); sgc_mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } break; (AKCL new)---------- (1-3) edit the function init_main in the file kcl/c/main.c, change the lines where setting the value of *features* to add a :turbo-closure and a :turbo-closure-env-size into the list in your KCL/IBCL. For example, in Sun4(SunOS) version of IBCL changing the lines: ---------- make_special("*FEATURES*", make_cons(make_ordinary("SUN4"), make_cons(make_ordinary("SPARC"), make_cons(make_ordinary("IEEE-FLOATING-POINT"), make_cons(make_ordinary("UNIX"), make_cons(make_ordinary("BSD"), make_cons(make_ordinary("COMMON"), make_cons(make_ordinary("IBCL"), Cnil)))))))); ---------- to ---------- make_special("*FEATURES*", make_cons(make_ordinary("SUN4"), make_cons(make_ordinary("SPARC"), make_cons(make_ordinary("IEEE-FLOATING-POINT"), make_cons(make_ordinary("UNIX"), make_cons(make_ordinary("BSD"), make_cons(make_ordinary("COMMON"), make_cons(make_ordinary("IBCL"), make_cons(make_keyword("TURBO-CLOSURE"), make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"), Cnil)))))))))); ---------- But, if the C macro ADD_FEATURE is defined at the end of main.c, use it instead. Insert the lines: ADD_FEATURE("TURBO-CLOSURE"); ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE"); After the line: ADD_FEATURE("AKCL"); gcl-2.6.14/pcl/impl/kcl/new-kcl-wrapper.text0000644000175000017500000016433214360276512017220 0ustar cammcammThe new-kcl-wrapper modifications make the storage of standard-objects and structure objects much more similar than before. These changes should greatly speed up WRAPPER-OF for structure objects and should speed up WRAPPER-OF for standard-instances also (but not funcallable instances). Look first at the defstructs defined here (scan this file for "(defstruct ("). Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of the wrapper structure. Finally, look in low.lisp, at the "#+new-structure-wrapper" for the definition of %allocate-instance--class. You need to have akcl-1-615 to use this file. This file contains new versions of the files V/c/structure.c and V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp. -- The gbc changes allow the garbage collector to work correctly even when structures which define other structures (ones which can be the value of STRUCTURE-DEF) are not allocated in static storage. c/gbc.c *** c/gbc.c Tue Jun 30 04:11:00 1992 --- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992 *************** *** 427,453 **** break; goto COPY_STRING; case t_structure: mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! break; ! {object def=x->str.str_def; ! unsigned char * s_type = &SLOT_TYPE(def,0); ! unsigned short *s_pos= & SLOT_POS(def,0); ! for (i = 0, j = S_DATA(def)->length; i < j; i++) if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! S_DATA(def)->size); } else ! x->str.str_self = (object *) ! copy_relblock((char *)p, S_DATA(def)->size); }} break; case t_stream: switch (x->sm.sm_mode) { --- 427,461 ---- break; goto COPY_STRING; case t_structure: + x->d.m = 2; mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! {x->d.m = TRUE; break;} ! {object def=x->str.str_def; ! struct s_data *sdef=S_DATA(def); ! unsigned char *s_type; ! unsigned short *s_pos; ! if((int)what_to_collect >= (int)t_contiguous && ! !inheap(sdef) && def->d.m==TRUE) ! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); ! s_type = sdef->raw->ust.ust_self; ! s_pos = &USHORT(sdef->slot_position,0); ! for (i = 0, j = sdef->length; i < j; i++) if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! sdef->size); } else ! x->str.str_self = (object *) ! copy_relblock((char *)p, sdef->size); }} + x->d.m = TRUE; break; case t_stream: switch (x->sm.sm_mode) { *** c/sgbc.c Mon Jun 15 21:16:01 1992 --- akcl-1-615/c/sgbc.c Wed Jul 1 18:37:24 1992 *************** *** 355,386 **** if (cp == NULL) break; goto COPY_STRING; case t_structure: sgc_mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! break; ! {object def=x->str.str_def; ! unsigned char * s_type = &SLOT_TYPE(def,0); ! unsigned short *s_pos= & SLOT_POS(def,0); ! for (i = 0, j = S_DATA(def)->length; i < j; i++) if (s_type[i]==0 && ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) ) sgc_mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! S_DATA(def)->size); } else if(SGC_RELBLOCK_P(p)) x->str.str_self = (object *) ! copy_relblock((char *)p, S_DATA(def)->size); }} break; case t_stream: switch (x->sm.sm_mode) { case smm_input: --- 355,394 ---- if (cp == NULL) break; goto COPY_STRING; case t_structure: + x->d.m = 2; sgc_mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! {x->d.m = TRUE; break;} ! {object def=x->str.str_def; ! struct s_data *sdef=S_DATA(def); ! unsigned char *s_type; ! unsigned short *s_pos; ! if((int)what_to_collect >= (int)t_contiguous && ! !inheap(sdef) && def->d.m==TRUE) ! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); ! s_type = sdef->raw->ust.ust_self; ! s_pos = &USHORT(sdef->slot_position,0); ! for (i = 0, j = sdef->length; i < j; i++) if (s_type[i]==0 && ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) ) sgc_mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! sdef->size); } else if(SGC_RELBLOCK_P(p)) x->str.str_self = (object *) ! copy_relblock((char *)p, sdef->size); }} + x->d.m = TRUE; break; case t_stream: switch (x->sm.sm_mode) { case smm_input: cmpnew/cmpinit.lsp *** cmpnew/cmpinit.lsp Tue Jun 30 04:11:13 1992 --- ../akcl-1-615/cmpnew/cmpinit.lsp Mon Jun 22 18:41:51 1992 *************** *** 4,7 **** --- 4,10 ---- (load "sys-proclaim.lisp") (setq compiler::*eval-when-defaults* '(compile eval load)) ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval)) (load (format nil "~(~a~).lsp" v))) + (unless (get 'si::basic-wrapper 'si::s-data) + (setf (get 'si::s-data 'si::s-data) nil) + (load "../lsp/defstruct.lsp")) lsp/cmpinit.lsp *** lsp/cmpinit.lsp Tue Jun 30 04:11:26 1992 --- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 *************** *** 5,12 **** (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! ! ;;;;; --- 5,13 ---- (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! (unless (get 'si::basic-wrapper 'si::s-data) ! (setf (get 'si::s-data 'si::s-data) nil) ! (load "../lsp/defstruct.lsp")) ;;;;; lsp/describe.lsp *** lsp/describe.lsp Tue Jun 30 04:11:27 1992 --- ../akcl-1-615/lsp/describe.lsp Tue Jun 23 16:39:07 1992 *************** *** 266,282 **** (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) ! (let* ((sd (get name 'si::s-data)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" ! (aref spos (nth 4 v)) ! (let ((type (nth 2 v))) (if (eq t type) nil type)) ! (car v) ! (structure-ref1 x (nth 4 v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) --- 266,282 ---- (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) ! (let* ((sd (structure-def x)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" ! (aref spos (slot-offset v)) ! (let ((type (slot-type v))) (if (eq t type) nil type)) ! (slot-name v) ! (structure-ref1 x (slot-offset v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) ============================================================================== =============================== c/structure.c ================================ Changes file for /kcl/c/structure.c Usage \n@s[Original text\n@s|Replacement Text\n@s] See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c for a program to merge change files. Anything not between "\n@s[" and "\n@s]" is a simply a comment. This file was constructed using emacs and merge.el by (Bill Schelter) wfs@carl.ma.utexas.edu ****Change:(orig (15 17 d)) @s[object siSstructure_print_function; object siSstructure_slot_descriptions; object siSstructure_include; @s| @s] ****Change:(orig (18 18 a)) @s[ @s| #define COERCE_DEF(x) if (type_of(x)==t_symbol) \ x=getf(x->s.s_plist,siLs_data,Cnil) #define check_type_structure(x) \ if(type_of((x))!=t_structure) \ FEwrong_type_argument(Sstructure,(x)) @s] ****Change:(orig (22 31 c)) @s[{ do { if (type_of(x) != t_symbol) return(FALSE); @s, } while (x != Cnil); return(FALSE); } @s|{ if (x==y) return 1; if (type_of(x)!= t_structure || type_of(y)!=t_structure) FEerror("bad call to structure_subtypep",0); {if (S_DATA(y)->included == Cnil) return 0; while ((x=S_DATA(x)->includes) != Cnil) { if (x==y) return 1;} return 0; }} @s] ****Change:(orig (32 32 a)) @s[ @s| static bad_raw_type() { FEerror("Bad raw struct type",0);} @s] ****Change:(orig (34 34 c)) @s[structure_ref(x, name, n) @s|structure_ref(x, name, i) @s] ****Change:(orig (36 38 c)) @s[object x, name; int n; { int i; @s|object x, name; int i; {unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || (type_of(name)!=t_structure) || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name), x); s_pos = &SLOT_POS(x->str.str_def,0); switch((SLOT_TYPE(x->str.str_def,i))) { case aet_object: return(STREF(object,x,s_pos[i])); case aet_fix: return(make_fixnum((STREF(int,x,s_pos[i])))); case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); case aet_bit: case aet_char: return(make_fixnum(STREF(char,x,s_pos[i]))); case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i]))); case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); default: bad_raw_type(); return 0; }} @s] ****Change:(orig (40 43 c)) @s[ if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, name)) FEwrong_type_argument(name, x); return(x->str.str_self[n]); @s| void siLstructure_ref1() {object x=vs_base[0]; int n=fix(vs_base[1]); object def; check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) FEerror("Structure ref out of bounds",0); vs_base[0]=structure_ref(x,x->str.str_def,n); vs_top=vs_base+1; @s] ****Change:(orig (45 45 a)) @s[} @s|} void siLstructure_set1() {object x=vs_base[0]; int n=fix(vs_base[1]); object v=vs_base[2]; object def; check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) FEerror("Structure ref out of bounds",0); vs_base[0]=structure_set(x,x->str.str_def,n,v); vs_top=vs_base+1; } @s] ****Change:(orig (47 47 c)) @s[structure_set(x, name, n, v) @s|structure_set(x, name, i, v) @s] ****Change:(orig (49 51 c)) @s[object x, name, v; int n; { int i; @s|object x, name, v; int i; {unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || type_of(name) != t_structure || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name) , x); @s] ****Change:(orig (53 57 c)) @s[ if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, name)) FEwrong_type_argument(name, x); x->str.str_self[n] = v; @s, return(v); @s|#ifdef SGC /* make sure the structure header is on a writable page */ if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0; #endif s_pos= & SLOT_POS(x->str.str_def,0); switch(SLOT_TYPE(x->str.str_def,i)){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); } return(v); @s] ****Change:(orig (59 59 a)) @s[} @s|} void siLstructure_subtype_p() {object x,y; check_arg(2); x=vs_base[0]; y=vs_base[1]; if (type_of(x)!=t_structure) {vs_base[0]=Cnil; goto BOTTOM;} x=x->str.str_def; COERCE_DEF(y); if (structure_subtypep(x,y)) vs_base[0]=Ct; else vs_base[0]=Cnil; BOTTOM: vs_top=vs_base+1; } static object slot_name(x) object x; { if(type_of(x)==t_cons) return car(x); if(type_of(x)==t_structure) return x->str.str_self[0]; return Cnil; } @s] ****Change:(orig (64 64 a)) @s[object x; { object *p, s; @s|object x; { object *p, s; struct s_data *def=S_DATA(x->str.str_def); @s] ****Change:(orig (66 69 c)) @s[ s = getf(x->str.str_name->s.s_plist, siSstructure_slot_descriptions, Cnil); vs_push(x->str.str_name); @s| s = def->slot_descriptions; vs_push(def->name); @s] ****Change:(orig (72 73 c)) @s[ for (i=0, n=x->str.str_length; !endp(s)&&ic.c_cdr, i++) { *p = make_cons(car(s->c.c_car), Cnil); @s| for (i=0, n=def->length; !endp(s)&&ic.c_cdr, i++) { *p = make_cons(slot_name(s->c.c_car), Cnil); @s] ****Change:(orig (75 75 c)) @s[ *p = make_cons(x->str.str_self[i], Cnil); @s| *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil); @s] ****Change:(orig (81 81 a)) @s[ stack_cons(); return(vs_pop); } @s| stack_cons(); return(vs_pop); } void @s] ****Change:(orig (84 85 c)) @s[ object x; int narg, i; @s| object x,name,*base; struct s_data *def; int narg, i,size; base=vs_base; if ((narg = vs_top - base) == 0) too_few_arguments(); x = alloc_object(t_structure); name=base[0]; COERCE_DEF(name); if (type_of(name)!=t_structure || (def=S_DATA(name))->length != --narg) FEerror("Bad make_structure args for type ~a",1, base[0]); x->str.str_def = name; x->str.str_self = NULL; size=S_DATA(name)->size; base[0] = x; x->str.str_self = (object *) (def->staticp == Cnil ? alloc_relblock(size) : alloc_contblock(size)); /* There may be holes in the structure. We want them zero, so that equal can work better. */ if (S_DATA(name)->has_holes != Cnil) bzero(x->str.str_self,size); {unsigned char *s_type; unsigned short *s_pos; s_pos= (&SLOT_POS(x->str.str_def,0)); s_type = (&(SLOT_TYPE(x->str.str_def,0))); base=base+1; for (i = 0; i < narg; i++) {object v=base[i]; switch(s_type[i]){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); @s] ****Change:(orig (87 97 c)) @s[ if ((narg = vs_top - vs_base) == 0) too_few_arguments(); x = alloc_object(t_structure); x->str.str_name = vs_base[0]; @s, x->str.str_self[i] = vs_top[i]; @s| }} vs_top = base; vs_base=base-1; } @s] ****Change:(orig (99 99 a)) @s[} @s|} void @s] ****Change:(orig (103 103 c)) @s[ object x, y; int i, j; @s| object x, y; struct s_data *def; @s] ****Change:(orig (105 105 c)) @s[ check_arg(2); @s| if (vs_top-vs_base < 1) too_few_arguments(); @s] ****Change:(orig (107 110 c)) @s[ if (type_of(x) != t_structure || x->str.str_name != vs_base[1]) FEwrong_type_argument(vs_base[1], x); vs_base[1] = y = alloc_object(t_structure); y->str.str_name = x->str.str_name; @s| check_type_structure(x); vs_base[0] = y = alloc_object(t_structure); def=S_DATA(y->str.str_def = x->str.str_def); @s] ****Change:(orig (112 116 c)) @s[ y->str.str_length = j = x->str.str_length; y->str.str_self = (object *)alloc_relblock(sizeof(object)*j); for (i = 0; i < j; i++) y->str.str_self[i] = x->str.str_self[i]; @s, vs_base++; @s| y->str.str_self = (object *)alloc_relblock(def->size); bcopy(x->str.str_self,y->str.str_self,def->size); vs_top=vs_base+1; @s] ****Change:(orig (118 118 a)) @s[} @s|} void siLcopy_structure_header() { object x, y; if (vs_top-vs_base < 1) too_few_arguments(); x = vs_base[0]; check_type_structure(x); vs_base[0] = y = alloc_object(t_structure); y->str.str_def = x->str.str_def; y->str.str_self = x->str.str_self; vs_top=vs_base+1; } void @s] ****Change:(orig (122 124 c)) @s[ if (type_of(vs_base[0]) != t_structure) FEwrong_type_argument(Sstructure, vs_base[0]); vs_base[0] = vs_base[0]->str.str_name; @s| check_type_structure(vs_base[0]); vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; @s] ****Change:(orig (127 127 c)) @s[} siLstructure_ref() @s|} #define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \ structure_slot_position(str,name)) object structure_ref_new(x, name, i) object x,name,i; @s] ****Change:(orig (129 131 c)) @s[ object x; int i; check_arg(3); @s| return structure_ref(x,name,FIND_SLOT(x,i)); } @s] ****Change:(orig (133 144 c)) @s[ x = vs_base[0]; if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, vs_base[1])) FEwrong_type_argument(vs_base[1], x); @s, vs_base[0] = x->str.str_self[i]; vs_top = vs_base+1; @s|object structure_set_new(x, name, i, v) object x,name,i,v; { return structure_set(x,name,FIND_SLOT(x,i),v); @s] ****Change:(orig (146 146 a)) @s[} @s|} void siLstructure_ref() { check_arg(3); vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]); vs_top=vs_base+1; } void @s] ****Change:(orig (149 150 d)) @s[siLstructure_set() { object x; int i; @s|siLstructure_set() { @s] ****Change:(orig (152 163 c)) @s[ x = vs_base[0]; if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, vs_base[1])) @s, x->str.str_self[i] = vs_base[3]; @s| structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]); @s] ****Change:(orig (166 166 a)) @s[ vs_base = vs_top-1; } @s| vs_base = vs_top-1; } void @s] ****Change:(orig (228 228 c)) @s[init_structure_function() @s|void siLmake_s_data_structure() {object x,y,raw,*base; int i; check_arg(5); x=vs_base[0]; base=vs_base; raw=vs_base[1]; y=alloc_object(t_structure); y->str.str_def=y; y->str.str_self = (object *)( x->v.v_self); S_DATA(y)->name =siLs_data; S_DATA(y)->length=(raw->v.v_dim); S_DATA(y)->raw =raw; for(i=3; iv.v_dim; i++) y->str.str_self[i]=Cnil; S_DATA(y)->slot_position=base[2]; S_DATA(y)->slot_descriptions=base[3]; S_DATA(y)->staticp=base[4]; S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); vs_base[0]=y; vs_top=vs_base+1; } object siSstructure_init,siSstructure_init_named; object siSname,siSdefault_init; object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions; static object slot_value(str,name) object str,name; @s] ****Change:(orig (230 237 c)) @s[ siSstructure_print_function = make_si_ordinary("STRUCTURE-PRINT-FUNCTION"); enter_mark_origin(&siSstructure_print_function); siSstructure_slot_descriptions @s, enter_mark_origin(&siSstructure_include); @s| top: if(type_of(str)==t_structure) return structure_ref_new(str,str->str.str_def,name); if(str->c.c_car==siSstructure_init_named) {object new=get(str->c.c_cdr,siLs_data); str->c.c_car=siSstructure_init; str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} if(siSstructure_init!=car(str)) FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0); {object key=intern(coerce_to_string(name),keyword_package); object value=getf(cdddr(str),key,NULL); if(value!=NULL) return value; else {object slots; if(str==caddr(str)&&name==siSslot_descriptions) FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0); slots=slot_value(caddr(str),siSslot_descriptions); for(;!endp(slots);slots=cdr(slots)) if(name==slot_value(car(slots),siSname)) {object result,form=slot_value(car(slots),siSdefault_init); object *old_vs_base=vs_base,*old_vs_top=vs_top; vs_base=vs_top;vs_push(form);Leval();result=vs_base[0]; vs_base=old_vs_base; vs_top=old_vs_top; return result;} FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}} return Cnil; } @s] ****Change:(orig (238 238 a)) @s[ @s| int structure_slot_position(str,name) object str,name; { if(type_of(name)==t_fixnum) return fix(name); else {object slotd_list; int pos; check_type_structure(str); slotd_list=S_DATA(str->str.str_def)->slot_descriptions; for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list)) {object slotd=car(slotd_list); if(name==((type_of(slotd)==t_structure)? slotd->str.str_self[0]:slot_value(slotd,siSname))) return pos;} FEerror("Slot ~S not found in structure ~S",2,name,str); return 0;} } static object make_structures_internal(value) object value; { object str,def; int def_index,i,ind; switch(type_of(value)) {case t_cons: if(value->c.c_car==siSstructure_init_named) {object new=get(value->c.c_cdr,siLs_data); value->c.c_car=siSstructure_init; value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} if(car(value)!=siSstructure_init) {value->c.c_car=make_structures_internal(value->c.c_car); value->c.c_cdr=make_structures_internal(value->c.c_cdr); break;} if(type_of(cadr(value))==t_structure) {value=value->c.c_cdr->c.c_car; break;} {object def=caddr(value),plist=cdddr(value),result; object slots,slots_tail; int size,staticp,len,i; if(def!=value)def=make_structures_internal(def); result=alloc_object(t_structure); result->str.str_def=(def==value)?result:def; result->str.str_self=NULL; value->c.c_cdr->c.c_car=result; size=fixint(slot_value(def,siSsize)); staticp=Cnil!=slot_value(def,siSstaticp); slots=slot_value(def,siSslot_descriptions); len=length(slots); result->str.str_self=(object *)(staticp?alloc_contblock(size): alloc_relblock(size)); bzero(result->str.str_self,size); if(def==value) {S_DATA(result)->raw=slot_value(def,siSraw); S_DATA(result)->slot_position=slot_value(def,siSslot_position);} for(i=0,slots_tail=slots; istr.str_def,i,svalue);} for(i=0,slots_tail=slots; istr.str_def,i); svalue=make_structures_internal(svalue); structure_set(result,result->str.str_def,i,svalue);} value=result; break;} case t_vector: if ((enum aelttype)value->v.v_elttype == aet_object) {int i,len=value->v.v_dim; for(i=0; iv.v_self[i]=make_structures_internal(value->v.v_self[i]);} break; case t_symbol: {object plist=value->s.s_plist,next; for(;!endp(plist);plist=cddr(plist)) {next=plist->c.c_cdr; if(plist->c.c_car==siLs_data&& type_of(next->c.c_car)==t_cons) next->c.c_car=make_structures_internal(next->c.c_car);} break;}} return value; } void siLmake_structures() { check_arg(1); vs_base[0]=make_structures_internal(vs_base[0]); } void siLstructure_def() {check_arg(1); check_type_structure(vs_base[0]); vs_base[0]=vs_base[0]->str.str_def; } short aet_sizes [] = { sizeof(object), /* aet_object t */ sizeof(char), /* aet_ch string-char */ sizeof(char), /* aet_bit bit */ sizeof(fixnum), /* aet_fix fixnum */ sizeof(float), /* aet_sf short-float */ sizeof(double), /* aet_lf long-float */ sizeof(char), /* aet_char signed char */ sizeof(char), /* aet_uchar unsigned char */ sizeof(short), /* aet_short signed short */ sizeof(short) /* aet_ushort unsigned short */ }; void siLsize_of() { object x= vs_base[0]; int i; i= aet_sizes[get_aelttype(x)]; vs_base[0]=make_fixnum(i); } void siLaet_type() {vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));} /* Return N such that something of type ARG can be aligned on an address which is a multiple of N */ void siLalignment() {struct {double x; int y; double z; float x1; int y1; float z1;} joe; joe.z=3.0; if (vs_base[0]==Slong_float) {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;} else if (vs_base[0]==Sshort_float) {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;} else {siLsize_of();} } void swap_structure_contents(str1,str2) object str1,str2; { object def1,*self1; check_type_structure(str1); check_type_structure(str2); def1=str1->str.str_def; self1=str1->str.str_self; str1->str.str_def=str2->str.str_def; str1->str.str_self=str2->str.str_self; str2->str.str_def=def1; str2->str.str_self=self1; } void siLswap_structure_contents() { check_arg(2); swap_structure_contents(vs_base[0],vs_base[1]); vs_base[0]=Cnil; vs_top=vs_base+1; } void siLset_structure_def() {check_arg(2); check_type_structure(vs_base[0]); check_type_structure(vs_base[1]); vs_base[0]->str.str_def=vs_base[1]; vs_base[0]=vs_base[1]; vs_top=vs_base+1; } init_structure_function() { siLs_data=make_si_ordinary("S-DATA"); siSstructure_init=make_si_ordinary("STRUCTURE-INIT"); siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED"); siSname=make_si_ordinary("NAME"); siSdefault_init=make_si_ordinary("DEFAULT-INIT"); siSraw=make_si_ordinary("RAW"); siSslot_position=make_si_ordinary("SLOT-POSITION"); siSsize=make_si_ordinary("SIZE"); siSstaticp=make_si_ordinary("STATICP"); siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS"); @s] ****Change:(orig (239 239 a)) @s[ make_si_function("MAKE-STRUCTURE", siLmake_structure); @s| make_si_function("MAKE-STRUCTURE", siLmake_structure); make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); @s] ****Change:(orig (240 240 a)) @s[ make_si_function("COPY-STRUCTURE", siLcopy_structure); @s| make_si_function("COPY-STRUCTURE", siLcopy_structure); make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header); @s] ****Change:(orig (242 242 a)) @s[ make_si_function("STRUCTURE-REF", siLstructure_ref); @s| make_si_function("STRUCTURE-REF", siLstructure_ref); make_si_function("STRUCTURE-DEF", siLstructure_def); make_si_function("STRUCTURE-REF1", siLstructure_ref1); make_si_function("STRUCTURE-SET1", siLstructure_set1); @s] ****Change:(orig (245 245 c)) @s[ make_si_function("STRUCTUREP", siLstructurep); @s| make_si_function("STRUCTUREP", siLstructurep); make_si_function("SIZE-OF", siLsize_of); make_si_function("ALIGNMENT",siLalignment); make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); @s] ****Change:(orig (247 247 a)) @s[ make_si_function("LIST-NTH", siLlist_nth); @s| make_si_function("LIST-NTH", siLlist_nth); make_si_function("AET-TYPE",siLaet_type); make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents); make_si_function("SET-STRUCTURE-DEF", siLset_structure_def); make_si_function("MAKE-STRUCTURES", siLmake_structures); @s] ============================================================================== ============================== V/lsp/defstruct.lsp ============================= Changes file for /kcl/lsp/defstruct.lsp Usage \n@s[Original text\n@s|Replacement Text\n@s] See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c for a program to merge change files. Anything not between "\n@s[" and "\n@s]" is a simply a comment. This file was constructed using emacs and merge.el by (Bill Schelter) wfs@carl.ma.utexas.edu ****Change:(orig (20 71 c)) @s[(defun make-access-function (name conc-name type named slot-name default-init slot-type read-only offset) (declare (ignore named default-init slot-type)) @s, ((error "~S is an illegal structure type." type))))) @s|(defvar *accessors* (make-array 10 :adjustable t)) (defvar *list-accessors* (make-array 2 :adjustable t)) (defvar *vector-accessors* (make-array 2 :adjustable t)) @s] ****Change:(orig (72 72 a)) @s[ @s| (or (fboundp 'record-fn) (setf (symbol-function 'record-fn) #'(lambda (&rest l) l nil))) @s] ****Change:(orig (73 73 a)) @s[ @s| (defun boot-slot-value (str name) (if (structurep str) (structure-ref str (structure-def str) name) (getf (cdddr str) (intern (string name) :keyword)))) (defun boot-set-slot-value (str name new-value) (if (structurep str) (structure-set str (structure-def str) name new-value) (setf (getf (cdddr str) (intern (string name) :keyword)) new-value))) (defun boot-subtypep (type1 type2) (or (eq type1 type2) (let* ((s-data (get type1 's-data)) (include (boot-s-data-name (boot-slot-value s-data 'includes)))) (boot-subtypep include type2)))) (defun make-slot-boot (&rest args) (if (get 's-data 's-data) (apply #'make-slot args) (list* 'structure-init nil '(structure-init-named . slot) args))) (defun make-s-data-boot (&rest args) (if (get 's-data 's-data) (apply #'make-s-data args) (list* 'structure-init nil '(structure-init-named . s-data) args))) (defun make-boot-accessor (slot accessor) (setf (symbol-function accessor) #'(lambda (object) (boot-slot-value object slot))) (let ((writer (intern (format nil "SET ~A" accessor)))) (setf (symbol-function writer) #'(lambda (object value) (boot-set-slot-value object slot value))) (eval `(defsetf ,accessor ,writer)))) (defmacro defstructboot (name &rest slots) (let ((conc-name (if (listp name) (string (second (assoc :conc-name (cdr name)))) (format nil "~A-" name)))) `(progn ,@(mapcar #'(lambda (slot) (let ((fname (intern (format nil "~A~A" conc-name slot)))) `(make-boot-accessor ',slot ',fname))) slots)))) (defstructboot (slot (:conc-name boot-slot-)) name default-init type read-only offset accessor-name type-changed) (defstructboot (s-data-internal (:conc-name boot-s-data-)) name length raw included includes staticp print-function slot-descriptions slot-position size has-holes) (defstructboot (basic-wrapper (:conc-name boot-wrapper-)) cache-number-vector state class) (defstructboot (s-data (:conc-name boot-s-data-)) frozen documentation constructors offset named type conc-name) (defun make-access-function (name conc-name type named include no-fun slot) (declare (ignore named)) (let* ((slot-name (boot-slot-name slot)) (slot-type (boot-slot-type slot)) (read-only (boot-slot-read-only slot)) (offset (boot-slot-offset slot)) (access-function (intern (si:string-concatenate (string conc-name) (string slot-name)))) accsrs dont-overwrite) (unless (boot-slot-accessor-name slot) (setf (boot-slot-accessor-name slot) access-function)) (ecase type ((nil) (setf accsrs *accessors*)) (list (setf accsrs *list-accessors*)) (vector (setf accsrs *vector-accessors*))) (or (> (length accsrs) offset) (adjust-array accsrs (+ offset 10))) (unless dont-overwrite (record-fn access-function 'defun '(t) slot-type) (or no-fun (and (fboundp access-function) (eq (aref accsrs offset) (symbol-function access-function))) (setf (symbol-function access-function) (or (aref accsrs offset) (setf (aref accsrs offset) (cond ((eq accsrs *accessors*) #'(lambda (x) (or (structurep x) (error "~a is not a structure" x)) (structure-ref1 x offset))) ((eq accsrs *list-accessors*) #'(lambda(x) (si:list-nth offset x))) ((eq accsrs *vector-accessors*) #'(lambda(x) (aref x offset))))))))) (cond (read-only (remprop access-function 'structure-access) (setf (get access-function 'struct-read-only) t)) (t (remprop access-function 'setf-update-fn) (remprop access-function 'setf-lambda) (remprop access-function 'setf-documentation) (let ((tem (get access-function 'structure-access))) (cond ((and (consp tem) include (if (consp (get include 's-data)) (boot-subtypep include (car tem)) (subtypep include (car tem))) (eql (cdr tem) offset)) ;; don't change overwrite accessor of subtype. (setq dont-overwrite t) ) (t (setf (get access-function 'structure-access) (cons (if type type name) offset))))))) nil)) @s] ****Change:(orig (80 89 c)) @s[ (cond ((null x) ;; If the slot-description is NIL, ;; it is in the padding of initial-offset. nil) @s, (t (car x)))) @s| (or (boot-slot-name x) (and (boot-slot-default-init x) ;; If the slot name is NIL, ;; it is the structure name. ;; This is for typed structures with names. (list 'quote (boot-slot-default-init x))))) @s] ****Change:(orig (94 97 c)) @s[ (cond ((null x) nil) ((null (car x)) nil) ((null (cadr x)) (list (car x))) (t (list (list (car x) (cadr x)))))) @s| (when (boot-slot-name x) (if (boot-slot-default-init x) (list (list (boot-slot-name x) (boot-slot-default-init x))) (list (boot-slot-name x))))) @s] ****Change:(orig (248 248 d)) @s[ ((error "~S is an illegal structure type" type))))) @s| ((error "~S is an illegal structure type" type))))) @s] ****Change:(orig (252 265 d)) @s[ (defun make-copier (name copier type named) (declare (ignore named)) (cond ((null type) @s, ((error "~S is an illegal structure type." type)))) @s| @s] ****Change:(orig (267 275 c)) @s[ (cond ((null type) ;; If TYPE is NIL, the predicate searches the link ;; of structure-include, until there is no included structure. `(defun ,predicate (x) @s, (setq n (get n 'structure-include)))))) @s| (cond ((null type)) ; done in define-structure @s] ****Change:(orig (282 283 c)) @s[ (> (length x) ,name-offset) (eq (elt x ,name-offset) ',name)))) @s| (> (the fixnum (length x)) ,name-offset) (eq (aref (the (vector t) x) ,name-offset) ',name)))) @s] ****Change:(orig (294 294 a)) @s[ ((= i 0) (and (consp y) (eq (car y) ',name))) @s| ((= i 0) (and (consp y) (eq (car y) ',name))) (declare (fixnum i)) @s] ****Change:(orig (300 301 c)) @s[;;; and returns a list of the form: ;;; (slot-name default-init slot-type read-only offset) @s|;;; and returns a slot. @s] ****Change:(orig (325 325 c)) @s[ (list slot-name default-init slot-type read-only offset))) @s| (make-slot-boot :name slot-name :default-init default-init :type slot-type :read-only read-only :offset offset))) @s] ****Change:(orig (335 335 c)) @s[ (let ((sds (member (caar olds) news :key #'car))) @s| (let* ((old (car olds)) (sds (member (boot-slot-name old) news :key #'slot-name)) (new (car sds))) @s] ****Change:(orig (337 348 c)) @s[ (when (and (null (cadddr (car sds))) (cadddr (car olds))) ;; If read-only is true in the old ;; and false in the new, signal an error. @s, (car (cddddr (car olds)))) @s| (when (and (null (boot-slot-read-only new)) (boot-slot-read-only old)) ;; If read-only is true in the old ;; and false in the new, signal an error. (error "~S is an illegal include slot-description." new)) ;; If (setf (boot-slot-type new) (best-array-element-type (boot-slot-type new))) (when (not (equal (normalize-type (or (boot-slot-type new) t)) (normalize-type (or (boot-slot-type old) t)))) (error "Type mismmatch for included slot ~a" new)) (cons (make-slot :name (boot-slot-name new) :default-init (boot-slot-default-init new) :type (boot-slot-type new) :read-only (boot-slot-read-only new) :offset (boot-slot-offset old)) @s] ****Change:(orig (353 353 a)) @s[ (overwrite-slot-descriptions news (cdr olds)))))))) @s| (overwrite-slot-descriptions news (cdr olds)))))))) (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) @s] ****Change:(orig (355 355 c)) @s[;;; The DEFSTRUCT macro. @s|(defun make-t-type (n include slot-descriptions &aux i) (let ((res (make-array n :element-type 'unsigned-char :static t))) (when include (let ((tem (get include 's-data))raw) (or tem (error "Included structure undefined ~a" include)) (setq raw (boot-s-data-raw tem)) (dotimes (i (min n (length raw))) (setf (aref res i) (aref raw i))))) (dolist (v slot-descriptions) (setq i (boot-slot-offset v)) (let ((type (boot-slot-type v))) (cond ((<= (the fixnum (alignment type)) #. (alignment t)) (setf (aref res i) (aet-type type)))))) (cond ((< n (length *all-t-s-type*)) (dotimes (i n) (cond ((not (eql (the fixnum (aref res i)) 0)) (return-from make-t-type res)))) *all-t-s-type*) (t res)))) @s] ****Change:(orig (356 356 a)) @s[ @s| (defvar *standard-slot-positions* (let ((ar (make-array 50 :element-type 'unsigned-short :static t))) (dotimes (i 50) (declare (fixnum i)) (setf (aref ar i)(* #. (size-of t) i))) ar)) (eval-when (compile ) (proclaim '(function round-up (fixnum fixnum ) fixnum)) ) (defun round-up (a b) (declare (fixnum a b)) (setq a (ceiling a b)) (the fixnum (* a b))) (defun get-slot-pos (leng include slot-descriptions &aux type small-types has-holes) (declare (special *standard-slot-positions*)) include (dolist (v slot-descriptions) (when (boot-slot-name v) (setf type (best-array-element-type (boot-slot-type v)) (boot-slot-type v) type) (let ((val (boot-slot-default-init v))) (unless (typep val type) (if (and (symbolp val) (constantp val)) (setf val (symbol-value val))) (and (constantp val) (setf (boot-slot-default-init v) (coerce val type))))) (cond ((memq type '(signed-char unsigned-char short unsigned-short long-float bit)) (setq small-types t))))) (cond ((and (null small-types) (< leng (length *standard-slot-positions*)) (list *standard-slot-positions* (* leng #. (size-of t)) nil))) (t (let ((ar (make-array leng :element-type 'unsigned-short :static t)) (pos 0)(i 0)(align 0)type (next-pos 0)) (declare (fixnum pos i align next-pos)) ;; A default array. (dolist (v slot-descriptions) (setq type (boot-slot-type v)) (setq align (alignment type)) (unless (<= align #. (alignment t)) (setq type t) (setf (boot-slot-type v) t) (setq align #. (alignment t)) (setf (boot-slot-type-changed v) t)) (setq next-pos (round-up pos align)) (or (eql pos next-pos) (setq has-holes t)) (setq pos next-pos) (setf (aref ar i) pos) (incf pos (size-of type)) (incf i)) (list ar (round-up pos (size-of t)) has-holes) )))) (defun define-structure (name conc-name type named slot-descriptions copier static include print-function constructors offset predicate &optional documentation no-funs &aux leng) (and (consp type) (eq (car type) 'vector)(setq type 'vector)) (setq leng (length slot-descriptions)) (setq slot-descriptions (mapcar #'(lambda (info) (make-slot-boot :name (first info) :default-init (second info) :type (third info) :read-only (fourth info) :offset (fifth info) :accessor-name (sixth info) :type-changed (seventh info))) slot-descriptions)) (dolist (x slot-descriptions) (when (boot-slot-name x) (make-access-function name conc-name type named include no-funs x))) (when (and copier (not no-funs)) (setf (symbol-function copier) (ecase type ((nil) #'si::copy-structure) (list #'copy-list) (vector #'copy-seq)))) (let ((include-str (and include (get include 's-data)))) (when (and (eq include 's-data-internal) (not (eq name 'basic-wrapper))) (error "only ~s can include ~s" 'basic-wrapper 's-data-internal)) (when include-str (cond ((and (not (consp include-str)) (s-data-frozen include-str) (or (not (s-data-included include-str)) (not (let ((te (get name 's-data))) (and te (eq (s-data-includes te) include-str)))))) (warn " ~a was frozen but now included" include))) (let ((old-included (boot-slot-value include-str 'included))) (unless (member name old-included) (boot-set-slot-value include-str 'included (cons name old-included))))) (let* ((tem (get name 's-data)) (g-s-p (and (null type) (get-slot-pos leng include slot-descriptions))) (slot-position (car g-s-p)) (size (if g-s-p (cadr g-s-p) 0)) (has-holes (caddr g-s-p)) (def (make-s-data-boot :name name :length leng :raw (and (null type) (make-t-type leng include slot-descriptions)) :slot-position slot-position :size size :has-holes has-holes :staticp static :includes include-str :print-function print-function :slot-descriptions slot-descriptions :constructors constructors :offset offset :type type :named named :documentation documentation :conc-name conc-name))) (check-s-data tem def name) (when (and (consp def) (eq name 's-data)) (make-structures def)))) (when documentation (setf (get name 'structure-documentation) documentation)) (when (and (null type) predicate) (record-fn predicate 'defun '(t) t) (or no-funs (setf (symbol-function predicate) #'(lambda (x) (si::structure-subtype-p x name)))) (setf (get predicate 'compiler::co1) 'compiler::co1structure-predicate) (setf (get predicate 'struct-predicate) name)) nil) (defun check-s-data (old new name) (unless (and old (member name '(slot s-data-internal basic-wrapper s-data))) (when (and old (eq (structure-def old) (get 's-data 's-data))) (boot-set-slot-value new 'included (boot-slot-value old 'included)) (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen))) (unless (and old (eq (structure-def old) (get 's-data 's-data)) (let ((new-cnv (boot-slot-value new 'cache-number-vector)) (old-cnv (boot-slot-value old 'cache-number-vector))) (boot-set-slot-value new 'cache-number-vector old-cnv) (prog1 (equalp new old) (boot-set-slot-value new 'cache-number-vector new-cnv)))) (when old (warn "structure ~a is changing" name) (when (eq (structure-def old) (get 's-data 's-data)) (boot-set-slot-value old 'state (list ':obsolete new)))) (setf (get name 's-data) new)))) @s] ****Change:(orig (364 364 c)) @s[ predicate predicate-specified include @s| predicate predicate-specified include include-s-data @s] ****Change:(orig (367 367 c)) @s[ offset name-offset documentation) @s| offset name-offset documentation static) @s] ****Change:(orig (370 370 c)) @s[ ;; The defstruct options are supplied. @s| ;; The defstruct options are supplied. @s] ****Change:(orig (390 425 c)) @s[ (cond ((and (consp (car os)) (not (endp (cdar os)))) (setq o (caar os) v (cadar os)) (case o (:conc-name @s, (t (error "~S is an illegal defstruct option." o)))))) @s| (cond ((and (consp (car os)) (not (endp (cdar os)))) (setq o (caar os) v (cadar os)) (case o (:conc-name (if (null v) (setq conc-name "") (setq conc-name v))) (:constructor (if (null v) (setq no-constructor t) (if (endp (cddar os)) (setq constructors (cons v constructors)) (setq constructors (cons (cdar os) constructors))))) (:copier (setq copier v)) (:static (setq static v)) (:predicate (setq predicate v) (setq predicate-specified t)) (:include (setq include (cdar os)) (unless (setq include-s-data (get v 's-data)) (error "~S is an illegal included structure." v))) (:print-function (and (consp v) (eq (car v) 'function) (setq v (second v))) (setq print-function v)) (:type (setq type v)) (:initial-offset (setq initial-offset v)) (t (error "~S is an illegal defstruct option." o)))) (t (if (consp (car os)) (setq o (caar os)) (setq o (car os))) (case o (:constructor (setq constructors (cons default-constructor constructors))) ((:conc-name :copier :predicate :print-function)) (:named (setq named t)) (t (error "~S is an illegal defstruct option." o)))))) @s] ****Change:(orig (426 426 a)) @s[ @s| (setq conc-name (intern (string conc-name))) (and include-s-data (not print-function) (setq print-function (boot-s-data-print-function include-s-data))) @s] ****Change:(orig (434 435 c)) @s[ (when include (unless (equal type (get (car include) 'structure-type)) @s| (when include-s-data (unless (equal type (boot-s-data-type include-s-data)) @s] ****Change:(orig (442 443 c)) @s[ (t (setq offset (get (car include) 'structure-offset)))) @s| (t (setq offset (boot-s-data-offset include-s-data)))) @s] ****Change:(orig (457 458 c)) @s[ (setq sds (cons (parse-slot-description (car ds) offset) sds)) (setq offset (1+ offset))) @s| (setq sds (cons (parse-slot-description (car ds) offset) sds)) (setq offset (1+ offset))) @s] ****Change:(orig (464 464 c)) @s[ (cons (list nil name) slot-descriptions))) @s| (cons (make-slot :default-init name) slot-descriptions))) @s] ****Change:(orig (469 469 c)) @s[ (append (make-list initial-offset) slot-descriptions))) @s| (append (mapcar #'make-named-slot (make-list initial-offset)) slot-descriptions))) @s] ****Change:(orig (473 486 c)) @s[ (cond ((null include)) ((endp (cdr include)) (setq slot-descriptions (append (get (car include) 'structure-slot-descriptions) @s, slot-descriptions)))) @s| (let ((include-slot-descriptions (and include (boot-s-data-slot-descriptions include-s-data)))) (cond ((null include)) ((endp (cdr include)) (setq slot-descriptions (append include-slot-descriptions slot-descriptions))) (t (setq slot-descriptions (append (overwrite-slot-descriptions (mapcar #'(lambda (sd) (parse-slot-description sd 0)) (cdr include)) include-slot-descriptions) slot-descriptions))))) @s] ****Change:(orig (489 492 c)) @s[ ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors (error "Contradictory constructor options."))) @s| ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors (error "Contradictory constructor options."))) @s] ****Change:(orig (494 495 c)) @s[ ;; If no constructor is specified, ;; the default-constructor is made. @s| ;; If no constructor is specified, ;; the default-constructor is made. @s] ****Change:(orig (497 497 a)) @s[ (setq constructors (list default-constructor)))) @s| (setq constructors (list default-constructor)))) ;; We need a default constructor for the sharp-s-reader (or (member t (mapcar 'symbolp constructors)) (push (intern (string-concatenate "__si::" default-constructor)) constructors)) @s] ****Change:(orig (509 509 c)) @s[ (error "An print function is supplied to a typed structure.")) @s| (error "A print function is supplied to a typed structure.")) `(progn (define-structure ',name ',conc-name ',type ',named ',(mapcar #'(lambda (slotd) (list (boot-slot-name slotd) (boot-slot-default-init slotd) (boot-slot-type slotd) (boot-slot-read-only slotd) (boot-slot-offset slotd) (boot-slot-accessor-name slotd) (boot-slot-type-changed slotd))) slot-descriptions) ',copier ',static ',include ',print-function ',constructors ',offset ',predicate ',documentation) @s] ****Change:(orig (511 542 c)) @s[ `(progn (si:putprop ',name '(defstruct ,name ,@slots) 'defstruct-form) (si:putprop ',name t 'is-a-structure) @s, (si:putprop ',name ,documentation 'structure-documentation) ',name))) @s| ,@(mapcar #'(lambda (constructor) (make-constructor name constructor type named slot-descriptions)) constructors) ,@(if (and type predicate) (list (make-predicate name predicate type named name-offset))) ',name ))) @s] ****Change:(orig (544 544 a)) @s[ @s| (eval-when (compile load eval) (defconstant wrapper-cache-number-adds-ok 4) (defconstant wrapper-cache-number-length (- (integer-length most-positive-fixnum) wrapper-cache-number-adds-ok)) (defconstant wrapper-cache-number-mask (1- (expt 2 wrapper-cache-number-length))) (defvar *get-wrapper-cache-number* (make-random-state)) (defun get-wrapper-cache-number () (let ((n 0)) (declare (fixnum n)) (loop (setq n (logand wrapper-cache-number-mask (random most-positive-fixnum *get-wrapper-cache-number*))) (unless (zerop n) (return n))))) ) (eval-when (compile load eval) (defconstant wrapper-cache-number-vector-length 8) (deftype cache-number-vector () `(simple-array fixnum (8))) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) ) (defun make-wrapper-cache-number-vector () (let ((cnv (make-array #.wrapper-cache-number-vector-length :element-type 'fixnum))) (dotimes (i #.wrapper-cache-number-vector-length) (setf (aref cnv i) (get-wrapper-cache-number))) cnv)) (defstruct (slot (:static t) (:constructor make-slot) (:constructor make-named-slot (name))) name default-init (type t) read-only offset accessor-name type-changed) ;; All of the fields of s-data-internal must coincide with ;; the C structure s_data (see object.h). (defstruct (s-data-internal (:conc-name s-data-) (:constructor nil) (:static t)) ;; all of these slots are used by c code name ; a symbol (length 0 :type fixnum) ; length of slot-descriptions raw ; a static array of unsigned-short (enum aelttype) included ; a list of the names of structures including this one includes ; nil or a s-data structure staticp ; t or nil print-function ; nil, a symbol, or a lambda expression slot-descriptions ; a list of slots slot-position ; a static array of unsigned-short (size 0 :type fixnum) ; total size to allocate has-holes) ; t or nil (defstruct (basic-wrapper (:include s-data-internal) (:conc-name wrapper-) (:constructor nil) (:static t)) (cache-number-vector (make-wrapper-cache-number-vector)) (state t) ; either t or a list (state-sym new-wrapper) ;; where state-sym is either :flush or :obsolete (class nil)) ;(get name 'si::s-data) ;returns one of these: (defstruct (s-data (:include basic-wrapper) (:static t)) ;; these slots are used only from lisp frozen ; t or nil ; t means won't include this documentation constructors ; a list of either a symbol or a list symbol, arglist offset ; the total number of slots and placeholders named ; t or nil type ; one of: nil, list, or vector conc-name) ; an interned symbol #|| (import '(si::wrapper-state si::wrapper-class si::basic-wrapper)) (defstruct (wrapper (:include basic-wrapper) (:print-function print-wrapper) (:constructor make-wrapper-internal) (:predicate wrapper-p) (:conc-name wrapper-)) (class-slots nil :type list)) (defun print-wrapper (instance stream depth) (printing-random-thing (wrapper stream) (format stream "Wrapper ~S" (wrapper-class wrapper)))) ||# (defun update-wrapper-state (old new same-p) (unless (consp old) (setf (wrapper-state old) (list (if same-p ':flush ':obsolete) new)))) (defun freeze-defstruct (name) (let ((tem (and (symbolp name) (get name 's-data)))) (if tem (setf (s-data-frozen tem) t)))) @s] ****Change:(orig (551 553 c)) @s[ (let ((l (read stream))) (unless (get (car l) 'is-a-structure) (error "~S is not a structure." (car l))) @s| (let* ((l (prog1 (read stream t nil t) (if *read-suppress* (return-from sharp-s-reader nil)))) (sd (or (get (car l) 's-data) (error "~S is not a structure." (car l))))) @s] ****Change:(orig (558 558 c)) @s[ (do ((cs (get (car l) 'structure-constructors) (cdr cs))) @s| (do ((cs (s-data-constructors sd) (cdr cs))) @s] ****Change:(orig (571 571 d)) @s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader) @s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader) @s] ****Change:(orig (582 582 c)) @s[(defstruct person name age sex) @s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person1 name (age 20 :type fixnum) sex) @s] ****Change:(orig (584 584 c)) @s[(defstruct (astronaut (:include person (age 45)) @s|(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) ;(defstruct person name age sex) (defstruct (astronaut (:include person (age 45 :type fixnum)) @s] ****Change:(orig (605 605 a)) @s[ associative identity) @s| associative identity) @s] ============================================================================== gcl-2.6.14/pcl/impl/kcl/makefile.akcl0000644000175000017500000000146714360276512015704 0ustar cammcamm# makefile for making pcl -- W. Schelter. # Directions: # make -f makefile.akcl compile # make -f makefile.akcl saved_pcl SHELL=/bin/sh LISP=akcl SETUP='(load "pkg.lisp")(load "defsys.lisp")' \ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ '(load "sys-proclaim.lisp")(compiler::emit-fn t)' compile: echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} saved_pcl: echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} # remake the sys-package.lisp and sys-proclaim.lisp files # Those files may be empty on a first build. remake-sys-files: echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} cp sys-proclaim.lisp xxx cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp clean: rm -f *.o gcl-2.6.14/pcl/impl/kcl/sys-proclaim.lisp0000644000175000017500000012601414360276512016602 0ustar cammcamm (IN-PACKAGE "USER") (PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM) PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) PCL::FAST-INSTANCE-BOUNDP-INDEX PCL::ONE-INDEX-LIMIT-FN PCL::N-N-ACCESSORS-LIMIT-FN PCL::CHECKING-LIMIT-FN PCL::PV-CACHE-LIMIT-FN PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE PCL::CACHE-MASK PCL::ARG-INFO-NUMBER-REQUIRED PCL::DEFAULT-LIMIT-FN PCL::CACHE-COUNT PCL::CACHING-LIMIT-FN PCL::PV-TABLE-PV-SIZE PCL::EARLY-CLASS-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) (PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) (PROCLAIM '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) (PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) (PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME PCL::MAKE-KEYWORD)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) (PROCLAIM '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) *) PCL::MEMF-CODE-CONVERTER PCL::REAL-LOAD-DEFCLASS PCL::CACHE-MISS-VALUES-INTERNAL PCL::GENERATE-DISCRIMINATION-NET-INTERNAL PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION PCL::DO-SHORT-METHOD-COMBINATION WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::WALK-GATHERING-BODY PCL::CACHE-MISS-VALUES PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::ACCESSOR-VALUES1 PCL::EMIT-READER/WRITER PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER WALKER::WALK-MULTIPLE-VALUE-SETQ PCL::GENERATING-LISP PCL::EMIT-READER/WRITER-FUNCTION PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION WALKER::WALK-LET-IF PCL::SET-SLOT-VALUE PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN PCL::SLOT-BOUNDP-USING-CLASS-DFUN PCL::CHECK-METHOD-ARG-INFO PCL::LOAD-LONG-DEFCOMBIN PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN PCL::MAKE-FINAL-CACHING-DFUN PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN PCL::GET-CLASS-SLOT-VALUE-1 PCL::ACCESSOR-VALUES-INTERNAL PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS PCL::CHECKING-MISS PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) *) PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN WALKER::WALK-TEMPLATE-HANDLE-REPEAT)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION PCL::BOOTSTRAP-ACCESSOR-DEFINITION PCL::GET-ACCESSOR-METHOD-FUNCTION PCL::EMIT-CHECKING-OR-CACHING PCL::EMIT-CHECKING-OR-CACHING-FUNCTION PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN PCL::LOAD-SHORT-DEFCOMBIN PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION PCL::MAKE-SHARED-INITIALIZE-FORM-LIST PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN PCL::MAKE-FINAL-CHECKING-DFUN PCL::ACCESSOR-VALUES PCL::SET-CLASS-SLOT-VALUE-1 PCL::GENERATE-DISCRIMINATION-NET PCL::REAL-MAKE-METHOD-LAMBDA PCL::ORDER-SPECIALIZERS WALKER::WALK-TEMPLATE PCL::ACCESSOR-MISS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) ITERATE::ITERATE-TRANSFORM-BODY)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) PCL::SLOT-VALUE-OR-DEFAULT PCL::MAKE-EFFECTIVE-METHOD-FUNCTION PCL::GET-EFFECTIVE-METHOD-FUNCTION PCL::MAKE-N-N-ACCESSOR-DFUN WALKER:NESTED-WALK-FORM PCL::MAKE-CHECKING-DFUN PCL::LOAD-DEFGENERIC PCL::TYPES-FROM-ARGUMENTS PCL::MAKE-DEFAULT-INITARGS-FORM-LIST PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::MAKE-ACCESSOR-TABLE PCL::GET-SIMPLE-INITIALIZATION-FUNCTION PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) *) PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS PCL::GET-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) ITERATE::SIMPLE-EXPAND-GATHERING-FORM ITERATE::RENAME-AND-CAPTURE-VARIABLES ITERATE::VARIABLE-SAME-P PCL::GET-FUNCTION-GENERATOR WALKER:VARIABLE-DECLARATION PCL::GET-NEW-FUNCTION-GENERATOR PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO PCL::ONE-CLASS-DFUN-INFO PCL::MAP-ALL-ORDERS SYSTEM::APPLY-DISPLAY-FUN PCL::NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL PCL::MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA PCL::OPTIMIZE-GF-CALL-INTERNAL PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P WALKER::WALK-COMPILER-LET PCL::SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY WALKER::WALK-MACROLET PCL::FIX-SLOT-ACCESSORS WALKER::WALK-MULTIPLE-VALUE-BIND PCL:COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SETQ WALKER::WALK-SYMBOL-MACROLET PCL::EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY PCL::EMIT-BOUNDP-CHECK WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* PCL::EXPAND-DEFGENERIC PCL::EMIT-GREATER-THAN-1-DLAP PCL::EMIT-1-T-DLAP PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL PCL::ENTRY-IN-CACHE-P PCL::CONVERT-TABLE PCL::MAKE-METHOD-SPEC PCL::TRACE-EMF-CALL-INTERNAL PCL::FLUSH-CACHE-TRAP PCL::SET-FUNCTION-NAME-1 PCL::OBSOLETE-INSTANCE-TRAP PCL::COMPUTE-PRECEDENCE PCL::PRINT-STD-INSTANCE PCL::|SETF PCL METHOD-FUNCTION-GET| PCL::|SETF PCL PLIST-VALUE| WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE PCL::OPTIMIZE-SET-SLOT-VALUE PCL::DECLARE-STRUCTURE PCL::OPTIMIZE-SLOT-BOUNDP PCL::PRINT-CACHE PCL::COMPUTE-STD-CPL-PHASE-3 PCL::FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS PCL::MAKE-TOP-LEVEL-FORM PCL::INVALIDATE-WRAPPER PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1 PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE PCL::MEMF-TEST-CONVERTER PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR PCL::TWO-CLASS-DFUN-INFO WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 PCL::OPTIMIZE-READER PCL::OPTIMIZE-WRITER PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY PCL::MAYBE-EXPAND-ACCESSOR-FORM PCL::INITIALIZE-INSTANCE-SIMPLE PCL::GET-WRAPPERS-FROM-CLASSES PCL::LOAD-PRECOMPILED-IIS-ENTRY PCL::FILL-CACHE-P PCL::ADJUST-CACHE PCL::EXPAND-CACHE PCL::EXPAND-SYMBOL-MACROLET-INTERNAL PCL::BOOTSTRAP-SET-SLOT PCL::EXPAND-DEFCLASS PCL::GET-CACHE )) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) PCL::LOAD-FUNCTION-GENERATOR PCL::EXPAND-EMF-CALL-METHOD PCL::MAKE-FGEN PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1 PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::COMPUTE-PV-SLOT WALKER::WALK-BINDINGS-1 PCL::OPTIMIZE-INSTANCE-ACCESS PCL::OPTIMIZE-ACCESSOR-CALL PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1 PCL::UPDATE-SLOTS-IN-PV PCL::MAKE-PARAMETER-REFERENCES PCL::MAKE-EMF-CACHE PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL PCL::MAKE-INSTANCE-FUNCTION-COMPLEX PCL::MAKE-INSTANCE-FUNCTION-SIMPLE PCL::OPTIMIZE-GENERIC-FUNCTION-CALL PCL::REAL-MAKE-METHOD-INITARGS-FORM )) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE PCL::MAKE-EMF-FROM-METHOD PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::FIND-CLASS-FROM-CELL PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::INITIALIZE-INFO PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::GET-DECLARATION PCL::GET-METHOD-FUNCTION-PV-CELL PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::EMIT-MISS PCL::METHOD-FUNCTION-GET PCL::PROBE-CACHE PCL::MAP-CACHE PCL::GET-CACHE-FROM-CACHE PCL::PRECOMPUTE-EFFECTIVE-METHODS PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA PCL::CPL-ERROR PCL::REAL-ADD-METHOD PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION PCL::REAL-ENSURE-GF-USING-CLASS--NULL PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T) T) PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS PCL::OPTIMIZE-GF-CALL PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS PCL::MAKE-EARLY-CLASS-DEFINITION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) PCL::LOAD-DEFMETHOD PCL::MAKE-DEFMETHOD-FORM PCL::MAKE-DEFMETHOD-FORM-INTERNAL PCL::EARLY-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) PCL::CHECK-INITARGS-2-PLIST PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST PCL::MAKE-EMF-CALL PCL::CAN-OPTIMIZE-ACCESS1 PCL::EMIT-FETCH-WRAPPER PCL::FILL-CACHE PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::GET-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD PCL::LOAD-DEFMETHOD-INTERNAL )) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T T *) T) PCL::BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::RENEW-SYS-FILES PCL::EMIT-N-N-READERS PCL::EMIT-N-N-WRITERS)) (PROCLAIM '(FTYPE (FUNCTION NIL T) PCL::GET-EFFECTIVE-METHOD-GENSYM PCL::SHOW-EMF-CALL-TRACE PCL::BOOTSTRAP-META-BRAID PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS PCL::DEFAULT-METHOD-ONLY-DFUN-INFO PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST PCL::CACHES-TO-ALLOCATE PCL::UPDATE-DISPATCH-DFUNS PCL::MAKE-CACHE PCL::RESET-PCL-PACKAGE PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2 PCL::%%ALLOCATE-INSTANCE--CLASS PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1 PCL::DISPATCH-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO PCL::INITIAL-DFUN-INFO PCL::NO-METHODS-DFUN-INFO PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CPD PCL::MAKE-ARG-INFO PCL::SHOW-DFUN-CONSTRUCTORS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) PCL::UNTRACE-METHOD PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR PCL::LIST-LARGE-CACHES PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) (PROCLAIM '(FTYPE (FUNCTION (*) T) PCL::|__si::MAKE-DFUN-INFO| PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-INITIAL| PCL::|__si::MAKE-INITIAL-DISPATCH| PCL::|__si::MAKE-DISPATCH| PCL::|__si::MAKE-DEFAULT-METHOD-ONLY| PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-N-N| PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ONE-CLASS| PCL::|__si::MAKE-TWO-CLASS| PCL::|__si::MAKE-ONE-INDEX| PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-ARG-INFO| PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::STRING-APPEND PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE| PCL::FALSE PCL::|STRUCTURE-OBJECT class constructor| PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE PCL::|__si::MAKE-PV-TABLE| PCL::INTERN-PV-TABLE PCL::CALLED-FIN-WITHOUT-FUNCTION PCL::|__si::MAKE-STD-INSTANCE| PCL::TRUE PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CACHE| PCL::MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| PCL::MAKE-METHOD-CALL)) (PROCLAIM '(FTYPE (FUNCTION (T) *) PCL::TYPE-FROM-SPECIALIZER PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE PCL::DEFAULT-CODE-CONVERTER PCL::CONVERT-TO-SYSTEM-TYPE PCL::EMIT-CONSTANT-VALUE PCL::SFUN-P PCL::PCL-DESCRIBE PCL::GET-GENERIC-FUNCTION-INFO PCL::EARLY-METHOD-FUNCTION PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::STRUCTURE-WRAPPER PCL::FIND-STRUCTURE-CLASS PCL::MAKE-DISPATCH-DFUN PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA PCL::FORCE-CACHE-FLUSHES PCL::EMIT-ONE-CLASS-READER PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-TWO-CLASS-READER PCL::EMIT-TWO-CLASS-WRITER PCL::EMIT-ONE-INDEX-READERS PCL::EMIT-ONE-INDEX-WRITERS PCL::NET-CODE-CONVERTER PCL::EMIT-IN-CHECKING-CACHE-P PCL::COMPILE-IIS-FUNCTIONS PCL::ANALYZE-LAMBDA-LIST PCL::COMPUTE-APPLICABLE-METHODS-EMF PCL::GET-DISPATCH-FUNCTION PCL::INSURE-CACHING-DFUN PCL::%FBOUNDP PCL::CCLOSUREP PCL::GENERIC-FUNCTION-NAME-P PCL::MAKE-FINAL-DISPATCH-DFUN PCL::STRUCTURE-SLOTD-INIT-FORM PCL::PARSE-METHOD-GROUP-SPECIFIER PCL::METHOD-PROTOTYPE-FOR-GF PCL::EARLY-COLLECT-INHERITANCE)) (PROCLAIM '(FTYPE (FUNCTION (T) T) PCL::UNENCAPSULATED-FDEFINITION PCL::DFUN-INFO-P PCL::NO-METHODS-P PCL::MAKE-TYPE-PREDICATE PCL::DEFAULT-TEST-CONVERTER PCL::INITIAL-P PCL::UNPARSE-TYPE-LIST PCL::MAKE-CALL-METHODS PCL::DEFAULT-CONSTANT-CONVERTER PCL::INITIAL-DISPATCH-P PCL::DISPATCH-P PCL::GBOUNDP PCL::GMAKUNBOUND PCL::DEFAULT-CONSTANTP PCL::DEFAULT-METHOD-ONLY-P PCL::FGEN-TEST PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-P PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM PCL::ONE-INDEX-DFUN-INFO-P PCL::FAST-METHOD-CALL-P PCL::N-N-P PCL::FAST-INSTANCE-BOUNDP-P PCL::METHOD-FUNCTION-PV-TABLE PCL::METHOD-FUNCTION-METHOD PCL::STORE-FGEN PCL::ONE-CLASS-P PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST PCL::FGEN-GENSYMS PCL::TWO-CLASS-P PCL::ARG-INFO-LAMBDA-LIST PCL::ARG-INFO-PRECEDENCE PCL::ARG-INFO-METATYPES PCL::FGEN-GENERATOR-LAMBDA SYSTEM:%STRUCTURE-NAME PCL::ARG-INFO-NUMBER-OPTIONAL SYSTEM:%COMPILED-FUNCTION-NAME PCL::ARG-INFO-KEY/REST-P PCL::ONE-INDEX-P PCL::ARG-INFO-KEYWORDS PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P PCL::GF-INFO-STATIC-C-A-M-EMF PCL::CHECKING-P PCL::GF-INFO-C-A-M-EMF-STD-P PCL::GF-INFO-FAST-MF-P PCL::UNDEFMETHOD-1 PCL::ARG-INFO-P PCL::FAST-METHOD-CALL-ARG-INFO PCL::ARG-INFO-NKEYS PCL::GF-DFUN-CACHE PCL:CLASS-OF PCL::GF-DFUN-INFO PCL::FUNCTION-RETURNING-NIL PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::EVAL-FORM PCL::ONE-INDEX-DFUN-INFO-INDEX PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::TYPE-CLASS PCL::ONE-CLASS-WRAPPER0 PCL::EXTRACT-PARAMETERS PCL::CLASS-PREDICATE PCL::EXTRACT-REQUIRED-PARAMETERS PCL::MAKE-CLASS-EQ-PREDICATE PCL::TWO-CLASS-WRAPPER1 PCL::MAKE-EQL-PREDICATE PCL::CHECKING-FUNCTION PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS PCL::INITIALIZE-INFO-KEY PCL::BOOTSTRAP-CLASS-PREDICATES PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::INITIALIZE-INFO-WRAPPER PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::DO-STANDARD-DEFSETF-1 PCL::CACHING-P PCL::GFS-OF-TYPE PCL::LEGAL-CLASS-NAME-P PCL::STRUCTURE-TYPE-P PCL::CONSTANT-VALUE-P PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P SYSTEM::NEXT-STACK-FRAME PCL::WRAPPER-FIELD PCL::NEXT-WRAPPER-FIELD PCL::SETFBOUNDP PCL::GET-SETF-FUNCTION-NAME PCL::USE-CACHING-DFUN-P PCL::MAKE-PV-TYPE-DECLARATION PCL::MAKE-CALLS-TYPE-DECLARATION PCL::MAP-SPECIALIZERS WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::SLOT-VECTOR-SYMBOL PCL::MAKE-PERMUTATION-VECTOR PCL::STRUCTURE-OBJECT-P PCL::EXPAND-MAKE-INSTANCE-FORM PCL::MAKE-CONSTANT-FUNCTION PCL::FUNCTION-RETURNING-T PCL::SORT-SLOTS PCL::SORT-CALLS PCL::SYMBOL-PKG-NAME PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P PCL::INITIALIZE-INFO-BOUND-SLOTS PCL::INITIALIZE-INFO-CACHED-VALID-P PCL::GET-MAKE-INSTANCE-FUNCTIONS PCL::INITIALIZE-INFO-CACHED-RI-VALID-P PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST PCL::INITIALIZE-INFO-CACHED-NEW-KEYS PCL::UPDATE-C-A-M-GF-INFO PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE PCL::UPDATE-GFS-OF-CLASS PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS PCL::STANDARD-SVUC-METHOD PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION PCL:EXTRACT-LAMBDA-LIST PCL::%CCLOSURE-ENV PCL::STRUCTURE-SVUC-METHOD PCL::INITIALIZE-INFO-CACHED-CONSTANTS PCL:EXTRACT-SPECIALIZER-NAMES PCL::METHOD-FUNCTION-PLIST PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL PCL::INTERNED-SYMBOL-P PCL::GDEFINITION PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::%STD-INSTANCE-WRAPPER PCL::%STD-INSTANCE-SLOTS PCL::PV-TABLEP PCL::STD-INSTANCE-P PCL::COMPUTE-MCASE-PARAMETERS PCL::COMPUTE-CLASS-SLOTS PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::NET-TEST-CONVERTER PCL:INTERN-EQL-SPECIALIZER PCL::MAKE-INSTANCE-FUNCTION-SYMBOL PCL::UPDATE-ALL-C-A-M-GF-INFO PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DFUN-INFO-CACHE PCL::NO-METHODS-CACHE PCL::ARG-INFO-APPLYP PCL::INITIAL-CACHE PCL::INITIAL-DISPATCH-CACHE PCL::CHECK-CACHE PCL::DISPATCH-CACHE PCL::CLASS-FROM-TYPE PCL::DEFAULT-METHOD-ONLY-CACHE PCL::DNET-METHODS-P PCL::ACCESSOR-DFUN-INFO-CACHE PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION PCL::ONE-INDEX-DFUN-INFO-CACHE PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::KEYWORD-SPEC-NAME PCL::N-N-CACHE PCL::GENERIC-CLOBBERS-FUNCTION PCL::N-N-ACCESSOR-TYPE PCL::FAST-METHOD-CALL-PV-CELL PCL::WRAPPER-FOR-STRUCTURE PCL::ONE-CLASS-CACHE PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL PCL::ONE-CLASS-ACCESSOR-TYPE PCL::ONE-CLASS-INDEX PCL::BUILT-IN-WRAPPER-OF PCL::TWO-CLASS-CACHE PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1 PCL::TWO-CLASS-ACCESSOR-TYPE PCL::TWO-CLASS-INDEX PCL::ALLOCATE-CACHE-VECTOR PCL::TWO-CLASS-WRAPPER0 PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::ONE-INDEX-CACHE PCL::EARLY-CLASS-NAME PCL::ONE-INDEX-ACCESSOR-TYPE PCL::ONE-INDEX-INDEX PCL::INTERN-FUNCTION-NAME PCL::CHECKING-CACHE PCL::COMPILE-LAMBDA-UNCOMPILED PCL::GF-LAMBDA-LIST PCL::CACHING-CACHE PCL::CONSTANT-VALUE-CACHE PCL::COMPILE-LAMBDA-DEFERRED PCL::FUNCALLABLE-INSTANCE-P PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-CACHE-VECTOR PCL::CONSTANT-SYMBOL-P PCL::FREE-CACHE-VECTOR PCL::EARLY-METHOD-LAMBDA-LIST PCL::ARG-INFO-VALID-P PCL::DFUN-ARG-SYMBOL PCL::EARLY-METHOD-CLASS PCL::EARLY-GF-P PCL::EARLY-GF-NAME PCL::CACHING-DFUN-INFO PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P PCL::CONSTANT-VALUE-DFUN-INFO PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::FREE-CACHE PCL::PARSE-SPECIALIZERS PCL::RESET-INITIALIZE-INFO PCL::EARLY-METHOD-QUALIFIERS PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::WRAPPER-OF PCL::EARLY-METHOD-STANDARD-ACCESSOR-P PCL::FUNCTION-PRETTY-ARGLIST PCL::GET-MAKE-INSTANCE-FUNCTION PCL::CHECK-WRAPPER-VALIDITY PCL::UNPARSE-SPECIALIZERS PCL::%SYMBOL-FUNCTION PCL::FINAL-ACCESSOR-DFUN-TYPE PCL::COMPLICATED-INSTANCE-CREATION-METHOD PCL::DEFAULT-STRUCTUREP PCL::UPDATE-GF-INFO PCL::CACHE-OWNER PCL::DEFAULT-STRUCTURE-INSTANCE-P PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE PCL::COMPUTE-STD-CPL-PHASE-2 PCL::GET-PV-CELL-FOR-CLASS PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::CACHE-P PCL::STRUCTURE-SLOTD-NAME PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION PCL::STRUCTURE-SLOTD-WRITER-FUNCTION PCL::FIND-CYCLE-REASONS PCL::EARLY-CLASS-DEFINITION PCL::ECD-SOURCE PCL::STRUCTURE-SLOTD-TYPE PCL::FORMAT-CYCLE-REASONS PCL::ECD-METACLASS PCL::CPD-CLASS PCL::EARLY-CLASS-PRECEDENCE-LIST PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::CPD-SUPERS PCL::EXPAND-LONG-DEFCOMBIN PCL::EARLY-CLASS-NAME-OF PCL::CPD-AFTER PCL::EXPAND-SHORT-DEFCOMBIN PCL::EARLY-CLASS-SLOTDS PCL::CPD-COUNT PCL::EARLY-SLOT-DEFINITION-NAME PCL::SLOT-READER-SYMBOL PCL::EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK PCL::MAKE-INITIAL-DFUN PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME PCL::SLOT-WRITER-SYMBOL WALKER::ENV-DECLARATIONS WALKER::ENV-LEXICAL-VARIABLES PCL::LIST-DFUN PCL::SLOT-BOUNDP-SYMBOL PCL::MAP-ALL-GENERIC-FUNCTIONS PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION PCL::EARLY-CLASS-DIRECT-SUBCLASSES PCL::MAKE-FUNCTION-INLINE PCL::LIST-LARGE-CACHE PCL::CLASS-PRECEDENCE-DESCRIPTION-P PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION WALKER::ENV-WALK-FUNCTION WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE PCL::COUNT-DFUN PCL::MAKE-INITFUNCTION PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::VARIABLES-FROM-LET WALKER::ENV-WALK-FORM PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION PCL::INITIALIZE-INFO-P PCL::ECD-CLASS-NAME PCL::COPY-CACHE PCL::COMPUTE-LINE-SIZE PCL::CANONICAL-SLOT-NAME WALKER::GET-WALKER-TEMPLATE PCL::EARLY-CLASS-SLOTS PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::EARLY-COLLECT-CPL PCL::EARLY-COLLECT-SLOTS PCL::METHOD-LL->GENERIC-FUNCTION-LL PCL::EARLY-COLLECT-DEFAULT-INITARGS PCL::ECD-SUPERCLASS-NAMES PCL::METHOD-CALL-P PCL::STRUCTURE-SLOT-BOUNDP ITERATE::SEQUENCE-ACCESSOR PCL::ECD-CANONICAL-SLOTS PCL::ECD-OTHER-INITARGS)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) PCL::COERCE-TO-CLASS PCL::GET-METHOD-FUNCTION WALKER:MACROEXPAND-ALL PCL::GET-FUNCTION PCL::GET-FUNCTION1 PCL:ENSURE-GENERIC-FUNCTION PCL::PARSE-METHOD-OR-SPEC PCL::EXTRACT-DECLARATIONS PCL::GET-DFUN-CONSTRUCTOR PCL::MAP-ALL-CLASSES PCL::MAKE-CACHING-DFUN WALKER:WALK-FORM PCL:ENSURE-CLASS PCL::MAKE-METHOD-FUNCTION-INTERNAL PCL::PARSE-SPECIALIZED-LAMBDA-LIST PCL::MAKE-METHOD-LAMBDA-INTERNAL PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-DFUN-INTERNAL PCL::COMPILE-LAMBDA)) (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) (PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) PCL::SAUT-CLASS PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP PCL::COMPUTE-TEST PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL PCL::COMPUTE-CODE PCL::CLASS-APPLICABLE-USING-CLASS-P PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-PROTOTYPE COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL:SLOT-BOUNDP PCL::DESTRUCTURE PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE PCL::ENSURE-CLASS-VALUES PCL::MAKE-DIRECT-SLOTD PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SPLIT-DECLARATIONS PCL::EMIT-DEFAULT-ONLY COMPILER::C2LAMBDA-EXPR-WITH-KEY PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING PCL::UPDATE-SLOT-VALUE-GF-INFO PCL::EMIT-CACHING PCL::SDFUN-FOR-CACHING PCL::SLOT-UNBOUND-INTERNAL PCL::MAKE-INSTANCE-1 PCL::SET-FUNCTION-NAME PCL::COMPUTE-STD-CPL-PHASE-1 PCL::FORM-LIST-TO-LISP PCL::FIND-SUPERCLASS-CHAIN PCL::SAUT-CLASS-EQ PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES PCL::CHECK-INITARGS-VALUES PCL::SAUT-EQL PCL::*SUBTYPEP ITERATE::PARSE-DECLARATIONS PCL::INITIAL-DFUN)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) PCL::MAKE-TYPE-PREDICATE-NAME PCL::SET-DFUN PCL:FIND-CLASS PCL::TRACE-METHOD PCL::FIND-CLASS-CELL PCL::MAKE-FINAL-DFUN PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE PCL::EARLY-METHOD-SPECIALIZERS PCL::USE-CONSTANT-VALUE-DFUN-P PCL::MAKE-EARLY-GF PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO PCL::INITIALIZE-METHOD-FUNCTION PCL::UPDATE-DFUN PCL::MAKE-SPECIALIZABLE PCL::ALLOCATE-STRUCTURE-INSTANCE PCL::ALLOCATE-STANDARD-INSTANCE WALKER::WALKER-ENVIRONMENT-BIND-1 ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN PCL::MAKE-WRAPPER)) (PROCLAIM '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS PCL::SORT-METHODS)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) PCL::FDEFINE-CAREFULLY PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION PCL::MAKE-STD-READER-METHOD-FUNCTION PCL::MAKE-STD-WRITER-METHOD-FUNCTION ITERATE::SIMPLE-EXPAND-ITERATE-FORM PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION PCL::DO-SATISFIES-DEFTYPE PCL::MEMF-CONSTANT-CONVERTER PCL::COMPUTE-CONSTANTS PCL::CLASS-CAN-PRECEDE-P PCL::SAUT-NOT-CLASS PCL::SAUT-NOT-CLASS-EQ PCL::SAUT-NOT-PROTOTYPE PCL::GF-MAKE-FUNCTION-FROM-EMF PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P PCL::CLASSES-HAVE-COMMON-SUBCLASS-P SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD SYSTEM::DISPLAY-ENV PCL::DESCRIBE-PACKAGE SYSTEM::DISPLAY-COMPILED-ENV PCL::PRINTING-RANDOM-THING-INTERNAL PCL::MAKE-CLASS-PREDICATE PCL::METHOD-FUNCTION-RETURNING-NIL PCL::METHOD-FUNCTION-RETURNING-T PCL::VARIABLE-CLASS PCL::MAKE-PLIST PCL::REMTAIL PCL:REMOVE-METHOD PCL:SLOT-EXISTS-P PCL::DESTRUCTURE-INTERNAL PCL::ACCESSOR-MISS-FUNCTION PCL::UPDATE-INITIALIZE-INFO-INTERNAL PCL::N-N-DFUN-INFO PCL::MAKE-CAXR PCL::MAKE-CDXR WALKER:VARIABLE-LEXICAL-P WALKER:VARIABLE-SPECIAL-P PCL::CHECKING-DFUN-INFO PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION PCL::MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING PCL::MAKE-DLAP-LAMBDA-LIST PCL::ADD-DIRECT-SUBCLASSES PCL::COMPUTE-PV PCL::MAKE-DFUN-ARG-LIST PCL::COMPUTE-CALLS PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::UPDATE-CLASS PCL::MAP-PV-TABLE-REFERENCES-OF PCL::ADD-SLOT-ACCESSORS WALKER::ENVIRONMENT-FUNCTION PCL::REMOVE-DIRECT-SUBCLASSES PCL::REMOVE-SLOT-ACCESSORS PCL::SYMBOL-LESSP PCL::SYMBOL-OR-CONS-LESSP PCL::|SETF PCL FIND-CLASS| PCL::|SETF PCL FIND-CLASS-PREDICATE| PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::PV-TABLE-LOOKUP PCL::PROCLAIM-DEFGENERIC PCL::UPDATE-CPL PCL::LIST-EQ PCL::UPDATE-SLOTS PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::UPDATE-INITS PCL::UPDATE-STD-OR-STR-METHODS PCL::SET-STANDARD-SVUC-METHOD PCL::EMIT-1-NIL-DLAP PCL::PLIST-VALUE PCL::SET-STRUCTURE-SVUC-METHOD PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::MEC-ALL-CLASSES-INTERNAL PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL::MEC-ALL-CLASSES PCL::%SET-CCLOSURE-ENV PCL::MEC-ALL-CLASS-LISTS PCL::REDEFINE-FUNCTION PCL::METHODS-CONVERTER PCL::COMPUTE-LAYOUT PCL::NO-SLOT PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS PCL::NET-CONSTANT-CONVERTER PCL::AUGMENT-TYPE PCL::CHANGE-CLASS-INTERNAL PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION PCL::VALUE-FOR-CACHING PCL:STANDARD-INSTANCE-ACCESS PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::GET-KEY-ARG PCL::GET-KEY-ARG1 PCL::SET-METHODS PCL::SET-FUNCTION-PRETTY-ARGLIST PCL::FIND-STANDARD-II-METHOD PCL::MAKE-EARLY-ACCESSOR PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::COMPUTE-STD-CPL PCL::|SETF PCL GDEFINITION| PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::ADD-FORMS PCL::CPL-INCONSISTENT-ERROR PCL::REDIRECT-EARLY-FUNCTION-INTERNAL PCL::ADD-TO-CVECTOR PCL::BOOTSTRAP-SLOT-INDEX PCL::QUALIFIER-CHECK-RUNTIME PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR PCL::REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO PCL::CANONICALIZE-SLOT-SPECIFICATION PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SET-WRAPPER PCL::DEAL-WITH-ARGUMENTS-OPTION PCL::PARSE-QUALIFIER-PATTERN PCL::SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ PCL::MAKE-UNORDERED-METHODS-EMF PCL::CLASS-MIGHT-PRECEDE-P ITERATE::EXTRACT-SPECIAL-BINDINGS WALKER::VARIABLE-SYMBOL-MACRO-P PCL::RAISE-METATYPE)) (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) (DOLIST (PCL::V '(PCL::ADD-READER-METHOD PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P PCL::OBJECT-PLIST PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE PCL::CLASS-DEFSTRUCT-CONSTRUCTOR PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP PCL::EXACT-CLASS-SPECIALIZER-P PCL::COMPATIBLE-META-CLASS-CHANGE-P PCL::UPDATE-GF-DFUN PCL::SPECIALIZER-OBJECT PCL::ACCESSOR-METHOD-SLOT-NAME PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS PCL::DOCUMENTATION PCL::METHOD-PRETTY-ARGLIST PCL::CLASS-EQ-SPECIALIZER PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS PCL::ACCESSOR-METHOD-CLASS PCL::GENERIC-FUNCTION-PRETTY-ARGLIST PCL::MAKE-BOUNDP-METHOD-FUNCTION PCL::CLASS-PREDICATE-NAME PCL::CLASSP PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD PCL::LEGAL-LAMBDA-LIST-P PCL::|SETF PCL GENERIC-FUNCTION-NAME| PCL::DESCRIBE-OBJECT PCL::CLASS-INITIALIZE-INFO PCL::MAKE-WRITER-METHOD-FUNCTION PCL::|SETF PCL GF-DFUN-STATE| PCL::|SETF PCL SLOT-DEFINITION-NAME| PCL::|SETF PCL CLASS-NAME| PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS PCL::|SETF PCL SLOT-DEFINITION-TYPE| PCL::METHOD-COMBINATION-P PCL::|SETF PCL GENERIC-FUNCTION-METHODS| PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| PCL::|SETF PCL METHOD-GENERIC-FUNCTION| PCL::|SETF PCL SLOT-ACCESSOR-STD-P| PCL::LEGAL-SPECIALIZERS-P PCL::|SETF PCL OBJECT-PLIST| PCL::|SETF PCL SLOT-DEFINITION-INITFORM| PCL::|SETF PCL CLASS-DEFSTRUCT-FORM| PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS| PCL::SLOT-ACCESSOR-STD-P PCL::|SETF PCL GF-PRETTY-ARGLIST| PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-LOCATION| PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION| PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION| PCL::METHOD-COMBINATION-OPTIONS PCL::|SETF PCL SLOT-DEFINITION-READERS| PCL::|SETF PCL DOCUMENTATION| PCL::FUNCALLABLE-STANDARD-CLASS-P PCL::|SETF PCL SLOT-DEFINITION-CLASS| PCL::|SETF PCL SLOT-VALUE-USING-CLASS| PCL::CLASS-CAN-PRECEDE-LIST PCL::|SETF PCL CLASS-DIRECT-SLOTS| PCL::|SETF PCL CLASS-SLOTS| PCL::SLOT-ACCESSOR-FUNCTION PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| PCL::|SETF PCL SLOT-DEFINITION-WRITERS| PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION PCL::LEGAL-METHOD-FUNCTION-P PCL::GET-METHOD PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO PCL::SPECIALIZER-METHOD-TABLE PCL::MAKE-METHOD-INITARGS-FORM PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST PCL::SAME-SPECIALIZER-P PCL::SLOT-DEFINITION-BOUNDP-FUNCTION PCL::SLOT-DEFINITION-WRITER-FUNCTION PCL::SLOT-DEFINITION-READER-FUNCTION PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION PCL::SLOT-DEFINITION-CLASS PCL::EQL-SPECIALIZER-OBJECT PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS PCL::ADD-WRITER-METHOD PCL::LONG-METHOD-COMBINATION-FUNCTION PCL::GENERIC-FUNCTION-P PCL::LEGAL-SLOT-NAME-P PCL::CLASS-WRAPPER PCL::DEFINITION-SOURCE PCL::DEFAULT-INITARGS PCL::CLASS-SLOT-VALUE PCL::FORWARD-REFERENCED-CLASS-P PCL::GF-FAST-METHOD-FUNCTION-P PCL::LEGAL-QUALIFIER-P PCL::METHOD-P PCL::CLASS-SLOT-CELLS PCL::STANDARD-ACCESSOR-METHOD-P PCL::STANDARD-GENERIC-FUNCTION-P PCL::STANDARD-READER-METHOD-P PCL::STANDARD-METHOD-P PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS PCL::COMPUTE-DEFAULT-INITARGS PCL::|SETF PCL CLASS-SLOT-VALUE| PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P PCL::LEGAL-SPECIALIZER-P PCL::COMPUTE-SLOT-ACCESSOR-INFO PCL::STANDARD-BOUNDP-METHOD-P PCL::RAW-INSTANCE-ALLOCATOR PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| PCL::|SETF PCL CLASS-INITIALIZE-INFO| PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO PCL::STANDARD-WRITER-METHOD-P PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST PCL::WRAPPER-FETCHER PCL::METHOD-COMBINATION-DOCUMENTATION PCL::|SETF PCL SLOT-DEFINITION-INITARGS| PCL::REMOVE-BOUNDP-METHOD PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| PCL::SHORT-COMBINATION-OPERATOR PCL::REMOVE-NAMED-METHOD PCL::LEGAL-DOCUMENTATION-P PCL:CLASS-DIRECT-SUPERCLASSES PCL:CLASS-DIRECT-SUBCLASSES PCL:CLASS-DIRECT-DEFAULT-INITARGS PCL:SLOT-DEFINITION-READERS PCL:SLOT-VALUE-USING-CLASS PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL:CHANGE-CLASS PCL:METHOD-FUNCTION PCL:DIRECT-SLOT-DEFINITION-CLASS PCL:MAKE-METHOD-LAMBDA PCL:EFFECTIVE-SLOT-DEFINITION-CLASS PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE PCL:GENERIC-FUNCTION-LAMBDA-LIST PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS PCL:COMPUTE-DISCRIMINATING-FUNCTION PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME PCL:REMOVE-DEPENDENT PCL:COMPUTE-CLASS-PRECEDENCE-LIST PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS PCL:ACCESSOR-METHOD-SLOT-DEFINITION PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD PCL:SLOT-DEFINITION-LOCATION PCL:SLOT-DEFINITION-INITFUNCTION PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD PCL:GENERIC-FUNCTION-METHOD-CLASS PCL:METHOD-SPECIALIZERS PCL:SLOT-DEFINITION-INITARGS PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS PCL:SPECIALIZER-DIRECT-METHODS PCL:GENERIC-FUNCTION-METHOD-COMBINATION PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS PCL:GENERIC-FUNCTION-METHODS PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST PCL:MAKE-INSTANCE PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS PCL:METHOD-GENERIC-FUNCTION PCL:REMOVE-DIRECT-SUBCLASS PCL:MAKE-INSTANCES-OBSOLETE PCL:SLOT-MAKUNBOUND-USING-CLASS PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL:SLOT-MISSING PCL:MAP-DEPENDENTS PCL:FIND-METHOD-COMBINATION PCL:ENSURE-CLASS-USING-CLASS PCL:NO-APPLICABLE-METHOD PCL:SLOT-DEFINITION-WRITERS PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL:CLASS-PRECEDENCE-LIST)) (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl-2.6.14/pcl/impl/kcl/kcl-low.lisp0000644000175000017500000003522514360276512015533 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for Kyoto Common Lisp (KCL) (in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name %instance-ref %set-instance-ref)) (in-package 'pcl) (shadow 'lisp:dotimes) (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) (declare (ignore doc)) (let ((limit (gensym)) (label (gensym))) `(let ((,limit ,form) (,var 0)) (declare (fixnum ,limit ,var)) ,@decls (block nil (tagbody ,label (when (>= ,var ,limit) (return-from nil ,val)) ,@bod (setq ,var (the fixnum (1+ ,var))) (go ,label))))))) (defun memq (item list) (member item list :test #'eq)) (defun assq (item list) (assoc item list :test #'eq)) (defun posq (item list) (position item list :test #'eq)) (si:define-compiler-macro memq (item list) (let ((var (gensym))) (once-only (item) `(let ((,var ,list)) (loop (unless ,var (return nil)) (when (eq ,item (car ,var)) (return ,var)) (setq ,var (cdr ,var))))))) (si:define-compiler-macro assq (item list) (let ((var (gensym))) (once-only (item) `(dolist (,var ,list nil) (when (eq ,item (car ,var)) (return ,var)))))) (si:define-compiler-macro posq (item list) (let ((var (gensym)) (index (gensym))) (once-only (item) `(let ((,var ,list) (,index 0)) (declare (fixnum ,index)) (dolist (,var ,list nil) (when (eq ,item ,var) (return ,index)) (incf ,index)))))) (defun printing-random-thing-internal (thing stream) (format stream "~X" (si:address thing))) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) ;;; ;;; std-instance-p ;;; #-akcl (si:define-compiler-macro std-instance-p (x) (once-only (x) `(and (si:structurep ,x) (eq (si:%structure-name ,x) 'std-instance)))) #+akcl (progn #-new-kcl-wrapper ;; declare that std-instance-p may be computed simply, and will not change. (si::freeze-defstruct 'std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj); else super_funcall(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) ) ;;; ;;; turbo-closure patch. See the file kcl-mods.text for details. ;;; #-turbo-closure-env-size (clines " object cclosure_env_nthcdr (n,cc) int n; object cc; { object env; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env; }") #+turbo-closure-env-size (clines " object cclosure_env_nthcdr (n,cc) int n; object cc; { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") ;; This is the completely safe version. (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed) (eval-when (compile load eval) #+new-kcl-wrapper (progn (defun instance-ref (slots index) (si:structure-ref1 slots index)) (defun set-instance-ref (slots index value) (si:structure-set1 slots index value)) (defsetf instance-ref set-instance-ref) (defsetf %instance-ref %set-instance-ref) ) (defsetf structure-def set-structure-def) ;;((name args-type result-type side-effect-p new-object-p c-expression) ...) (defparameter *kcl-function-inlines* '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure") #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name") #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") #+new-kcl-wrapper (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]") #+new-kcl-wrapper (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline))))) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let* ((*package* *the-pcl-package*) (name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((make-function-inline ',(cons name (cdr inline))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (,name ,@vars)) (make-function-inline ',inline)))))) *kcl-function-inlines*))) (define-inlines) ) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) #+akcl (clines "#define AKCL206") (clines " #ifdef AKCL206 use_fast_links(); #endif object set_cclosure (result_cc,value_cc,available_size) object result_cc,value_cc; int available_size; { object result_env_tail,value_env_tail; int i; #ifdef AKCL206 /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ use_fast_links(3,Cnil,result_cc); #endif result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; #ifndef AKCL206 result_cc->cc.cc_start=value_cc->cc.cc_start; result_cc->cc.cc_size=value_cc->cc.cc_size; #endif return result_cc; }") (defentry %set-cclosure (object object int) (object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) #+akcl (setq s-data (get type 'si::s-data)) #-akcl (get type 'si::is-a-structure) (null #+akcl (si::s-data-type s-data) #-akcl (get type 'si::structure-type)))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))) #-akcl (get type 'si::structure-include))) (defun structure-type-internal-slotds (type) #+akcl (si::s-data-slot-descriptions (get type 'si::s-data)) #-akcl (get type 'si::structure-slot-descriptions)) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) #-new-kcl-wrapper (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) #+akcl (si:structure-ref1 x offset) #-akcl (si:structure-ref x type offset))) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym reader (and (not read-only-p) writer))))))) #+new-kcl-wrapper (list slotd)) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) #+new-kcl-wrapper (defun si::slot-reader-function (slot) (let ((offset (si::slot-offset slot))) (si:turbo-closure #'(lambda (x) (si::structure-ref1 x offset))))) #+new-kcl-wrapper (defun si::slot-writer-function (slot) (let ((offset (si::slot-offset slot))) (si:turbo-closure #'(lambda (x) (si::structure-set1 x offset))))) (mapcar #'(lambda (fname value) (setf (symbol-function fname) (symbol-function value))) '(structure-slotd-name structure-slotd-accessor-symbol structure-slotd-reader-function structure-slotd-writer-function structure-slotd-type structure-slotd-init-form) #-new-kcl-wrapper '(first second third fourth function-returning-nil function-returning-nil) #+new-kcl-wrapper '(si::slot-name si::slot-accessor-name si::slot-reader-function si::slot-writer-function si::slot-type si::slot-default-init)) ;; Construct files sys-proclaim.lisp and sys-package.lisp ;; The file sys-package.lisp must be loaded first, since the ;; package sys-proclaim.lisp will refer to symbols and they must ;; be in the right packages. sys-proclaim.lisp contains function ;; declarations and declarations that certain things are closures. (defun renew-sys-files() ;; packages: (compiler::get-packages "sys-package.lisp") (with-open-file (st "sys-package.lisp" :direction :output :if-exists :append) (format st "(in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (let ((*package* (find-package 'user))) (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) ;;(format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") ))) gcl-2.6.14/pcl/impl/symbolics/0000755000175000017500000000000014360276512014516 5ustar cammcammgcl-2.6.14/pcl/impl/symbolics/cloe-low.lisp0000644000175000017500000000231014360276512017124 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmacro object-cache-no (object mask) `(logand (sys::address-of ,object) ,mask)) gcl-2.6.14/pcl/impl/symbolics/genera-low.lisp0000644000175000017500000003274214360276512017457 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 3600 version of the file portable-low. ;;; (in-package 'pcl) (pushnew ':pcl-internals dbg:*all-invisible-frame-types*) #+IMach ;On the I-Machine these are (eval-when (compile load eval) ;faster than the versions ;that use :test #'eq. (defmacro memq (item list) `(member ,item ,list)) (defmacro assq (item list) `(assoc ,item ,list)) (defmacro rassq (item list) `(rassoc ,item ,list)) (defmacro delq (item list) `(delete ,item ,list)) (defmacro posq (item list) `(position ,item ,list)) ) compiler:: (defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form) (matchp form (('cl:the type subform) (ignore type) subform) (* form))) (defmacro %ash (x count) (if (and (constantp count) (zerop (eval count))) x `(the fixnum (ash (the fixnum ,x ) ,count)))) ;;; ;;; ;;; (defmacro without-interrupts (&body body) `(let ((outer-scheduling-state si:inhibit-scheduling-flag) (si:inhibit-scheduling-flag t)) (macrolet ((interrupts-on () '(when (null outer-scheduling-state) (setq si:inhibit-scheduling-flag nil))) (interrupts-off () '(setq si:inhibit-scheduling-flag t))) (progn outer-scheduling-state) ,.body))) ;;; ;;; It would appear that #, does not work properly in Genera. At least I can't get it ;;; to work when I use it inside of std-instance-p (defined later in this file). So, ;;; all of this is just to support that. ;;; ;;; WHEN EXPANDS-TO ;;; compile to a file (#:EVAL-AT-LOAD-TIME-MARKER .

    ) ;;; compile to core ' ;;; not in compiler at all (progn ) ;;; ;;; Believe me when I tell you that I don't know why it is I need both a ;;; transformer and an optimizer to get this to work. Believe me when I ;;; tell you that I don't really care why either. ;;; (defmacro load-time-eval (form) ;; The interpreted definition of load-time-eval. This definition ;; never gets compiled. (let ((value (gensym))) `(multiple-value-bind (,value) (progn ,form) ,value))) (compiler:deftransformer (load-time-eval optimize-load-time-eval) (form) (compiler-is-a-loser-internal form)) (compiler:defoptimizer (load-time-eval transform-load-time-eval) (form) (compiler-is-a-loser-internal form)) (defun compiler-is-a-loser-internal (form) ;; When compiling a call to load-time-eval the compiler will call ;; this optimizer before the macro expansion. (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need ;this boundp check ;but it can't hurt. (funcall *compile-function* :to-core-p)) ;; Compiling to core. ;; Evaluate the form now, and expand into a constant ;; (the result of evaluating the form). `',(eval (cadr form)) ;; Compiling to a file. ;; Generate the magic which causes the dumper compiler and loader ;; to do magic and evaluate the form at load time. `',(cons compiler:eval-at-load-time-marker (cadr form)))) ;; ;;;;;; Memory Block primitives. *** ;; (defmacro make-memory-block (size &optional area) `(make-array ,size :area ,area)) (defmacro memory-block-ref (block offset) ;Don't want to go faster yet. `(aref ,block ,offset)) (defvar class-wrapper-area) (eval-when (load eval) (si:make-area :name 'class-wrapper-area :room t :gc :static)) (eval-when (compile load eval) (remprop '%%allocate-instance--class 'inline)) (eval-when (compile load eval) (scl:defflavor std-instance ((wrapper nil) (slots nil)) () (:constructor %%allocate-instance--class()) :ordered-instance-variables) (defvar *std-instance-flavor* (flavor:find-flavor 'std-instance)) ) #-imach (scl:defsubst pcl-%instance-flavor (instance) (declare (compiler:do-not-record-macroexpansions)) (sys::%make-pointer sys:dtp-array (sys:%p-contents-as-locative (sys:follow-structure-forwarding instance)))) #+imach (scl:defsubst pcl-%instance-flavor (instance) (sys:%instance-flavor instance)) (scl::defsubst std-instance-p (x) (and (sys:instancep x) (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*)))) (scl:defmethod (:print-self std-instance) (stream depth slashify) (declare (ignore slashify)) (print-std-instance scl:self stream depth)) (scl:defmethod (:describe std-instance) () (describe-object scl:self *standard-output*)) (defmacro %std-instance-wrapper (std-instance) `(sys:%instance-ref ,std-instance 1)) (defmacro %std-instance-slots (std-instance) `(sys:%instance-ref ,std-instance 2)) (scl:compile-flavor-methods std-instance) (defun printing-random-thing-internal (thing stream) (format stream "~\\si:address\\" (si:%pointer thing))) ;;; ;;; This is hard, I am sweating. ;;; (defun function-arglist (function) (zl:arglist function t)) (defun function-pretty-arglist (function) (zl:arglist function)) ;; New (& complete) fspec handler. ;; 1. uses a single #'equal htable where stored elements are (fn . plist) ;; (maybe we should store the method object instead) ;; 2. also implements the fspec-plist operators here. ;; 3. fdefine not only stores the method, but actually does the loading here! ;; ;;; ;;; genera-low.lisp (replaces old method-function-spec-handler) ;;; ;; New (& complete) fspec handler. ;; 1. uses a single #'equal htable where stored elements are (fn . plist) ;; (maybe we should store the method object instead) ;; 2. also implements the fspec-plist operators here. ;; 3. fdefine not only stores the method, but actually does the loading here! ;; (defvar *method-htable* (make-hash-table :test #'equal :size 500)) (sys:define-function-spec-handler method (op spec &optional arg1 arg2) (if (eq op 'sys:validate-function-spec) (and (let ((gspec (cadr spec))) (or (symbolp gspec) (and (listp gspec) (eq (car gspec) 'setf) (symbolp (cadr gspec)) (null (cddr gspec))))) (let ((tail (cddr spec))) (loop (cond ((null tail) (return nil)) ((listp (car tail)) (return t)) ((atom (pop tail))) (t (return nil)))))) (let ((table *method-htable*) (key spec)) (case op ((si:fdefinedp si:fdefinition) (car (gethash key table nil))) (si:fundefine (remhash key table)) (si:fdefine (let ((old (gethash key table nil)) (quals nil) (specs nil) (ptr (cddr spec))) (setq specs (loop (cond ((null ptr) (return nil)) ((listp (car ptr)) (return (car ptr))) (t (push (pop ptr) quals))))) (setf (gethash key table) (cons arg1 (cdr old))))) (si:get (let ((old (gethash key table nil))) (getf (cdr old) arg1))) (si:plist (let ((old (gethash key table nil))) (cdr old))) (si:putprop (let ((old (gethash key table nil))) (unless old (setf old (cons nil nil)) (setf (gethash key table) old)) (setf (getf (cdr old) arg2) arg1))) (si:remprop (let ((old (gethash key table nil))) (when old (remf (cdr old) arg1)))) (otherwise (si:function-spec-default-handler op spec arg1 arg2)))))) #|| ;; this guy is just a stub to make the fspec handler simpler (and so I could trace it ;; easier). (defun pcl-fdefine-helper (gspec qualifiers specializers fn) (let* ((dlist (scl:debugging-info fn)) (class (cadr (assoc 'pcl-method-class dlist))) (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist))) (if ll-stuff (cadr ll-stuff) (arglist fn)))) (doc (cadr (assoc 'pcl-documentation dlist))) (plist (cadr (assoc 'pcl-plist dlist)))) (load-defmethod (or class 'standard-method) gspec qualifiers specializers lambda-list doc (getf plist :pv-table-cache-symbol) plist fn))) ||# ;; define a few special declarations to get pushed onto the function's debug-info ;; list... note that we do not need to do a (proclaim (declarations ...)) here. ;; (eval-when (compile load eval) (setf (get 'pcl-plist 'si:debug-info) t) (setf (get 'pcl-documentation 'si:debug-info) t) (setf (get 'pcl-method-class 'si:debug-info) t) (setf (get 'pcl-lambda-list 'si:debug-info) t) ) (eval-when (load eval) (setf (get 'defmethod 'zwei:definition-function-spec-type) 'defun (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun (get 'method 'si:definition-type-name) "method" (get 'method 'si:definition-type-name) "method" (get 'declass 'zwei:definition-function-spec-type) 'defclass (get 'defclass 'si:definition-type-name) "Class" (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1)) ) (defun (:property defmethod zwei::definition-function-spec-parser) (bp) (zwei:parse-pcl-defmethod-for-zwei bp nil)) ;;; ;;; Previously, if a source file in a PCL-based package contained what looks ;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form ;;; appears at top level, and then a flavor-style defmethod form) appear, the ;;; parser would break. ;;; ;;; Now, if we can't parse the defmethod form, we send it to the flavor ;;; defmethod parser instead. ;;; ;;; Also now supports multi-line arglist sectionizing. ;;; zwei: (defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp) (block parser (flet ((barf (&optional (error t)) (return-from parser (cond ((eq error :flavor) (funcall (get 'flavor:defmethod 'zwei::definition-function-spec-parser) bp-after-defmethod)) (t (values nil nil nil error)))))) (let ((bp-after-generic (forward-sexp bp-after-defmethod)) (qualifiers ()) (specializers ()) (spec nil) (ignore1 nil) (ignore2 nil)) (when bp-after-generic (multiple-value-bind (generic error-p) (read-fspec-item-from-interval bp-after-defmethod bp-after-generic) (if error-p (barf) ; error here is really bad.... BARF! (progn (when (listp generic) (if (and (symbolp (car generic)) (string-equal (cl:symbol-name (car generic)) "SETF")) (setq generic (second generic) ; is a (setf xxx) form setfp t) (barf :flavor))) ; make a last-ditch-effort with flavor parser (let* ((bp1 bp-after-generic) (bp2 (forward-sexp bp1))) (cl:loop (if (null bp2) (barf :more) ; item not closed - need another line! (multiple-value-bind (item error-p) (read-fspec-item-from-interval bp1 bp2) (cond (error-p (barf)) ; ((listp item) (setq qualifiers (nreverse qualifiers)) (cl:multiple-value-setq (ignore1 ignore2 specializers) (pcl::parse-specialized-lambda-list item)) (setq spec (pcl::make-method-spec (if setfp `(cl:setf ,generic) generic) qualifiers specializers)) (return (values spec 'defun (string-interval bp-after-defmethod bp2)))) (t (push item qualifiers) (setq bp1 bp2 bp2 (forward-sexp bp2)))))))))))))))) zwei: (progn (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore) (let ((here (forward-over *whitespace-chars* (forward-word defmethod-paren)))) (loop until (char-equal (bp-char here) #\() do (setf here (forward-over *whitespace-chars* (forward-sexp here)))) (if (bp-< here bp) (values defmethod-paren nil 2) (values defmethod-paren nil 4)))) (defindentation (pcl::defmethod . indent-clos-defmethod))) ;;; ;;; Teach zwei that when it gets the name of a generic function as an argument ;;; it should edit all the methods of that generic function. This works for ;;; ED as well as meta-point. ;;; (zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR) :around setup-function-specs-to-edit-advice () (let ((old-definitions (cadddr arglist)) (new-definitions ()) (new nil)) (dolist (old old-definitions) (setq new (setup-function-specs-to-edit-advice-1 old)) (push (or new (list old)) new-definitions)) (setf (cadddr arglist) (apply #'append (reverse new-definitions))) :do-it)) (defun setup-function-specs-to-edit-advice-1 (spec) (and (or (symbolp spec) (and (listp spec) (eq (car spec) 'setf))) (gboundp spec) (generic-function-p (gdefinition spec)) (mapcar #'(lambda (m) (make-method-spec spec (method-qualifiers m) (unparse-specializers (method-specializers m)))) (generic-function-methods (gdefinition spec))))) gcl-2.6.14/pcl/impl/symbolics/rel-7-2-patches.lisp0000644000175000017500000003600114360276512020121 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; Does simple constant folding. This works for everything that doesn't have ;;; side-effects. ;;; ALL operands must be constant. ;;; Note that commutative-constant-folder can hack this case perfectly well ;;; by himself for the functions he handles. (defun constant-fold-optimizer (form) (let ((eval-when-load-p nil)) (flet ((constant-form-p (x) (when (constant-form-p x) (cond ((and (listp x) (eq (car x) 'quote) (listp (cadr x)) (eq (caadr x) eval-at-load-time-marker)) (setq eval-when-load-p t) (cdadr x)) (t x))))) (if (every (cdr form) #'constant-form-p) (if eval-when-load-p (list 'quote (list* eval-at-load-time-marker (car form) (mapcar #'constant-form-p (cdr form)))) (condition-case (error-object) (multiple-value-call #'(lambda (&rest values) (if (= (length values) 1) `',(first values) `(values ,@(mapcar #'(lambda (x) `',x) values)))) (eval form)) (error (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" form error-object) form))) form)))) ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; ;;; The damn compiler doesn't compile random forms that appear at top level. ;;; Its difficult to do because you have to get an associated function spec ;;; to go with those forms. This handles that by defining a special form, ;;; top-level-form that compiles its body. It takes a list of eval-when ;;; times just like eval when does. It also takes a name which it uses ;;; to construct a function spec for the top-level-form function it has ;;; to create. ;;; ; ;si:: ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) ; ;si:: ;(define-function-spec-handler pcl::top-level-form ; (operation fspec &optional arg1 arg2) ; (let ((name (cadr fspec))) ; (selectq operation ; (validate-function-spec (and (= (length fspec) 2) ; (or (symbolp name) ; (listp name)))) ; (fdefine ; (setf (gethash name *top-level-form-fdefinitions*) arg1)) ; ((fdefinition fdefinedp) ; (gethash name *top-level-form-fdefinitions*)) ; (fdefinition-location ; (ferror "It is not possible to get the fdefinition-location of ~s." ; fspec)) ; (fundefine (remhash name *top-level-form-fdefinitions*)) ; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) ; ;;; ;;; This is basically stolen from PROGN (surprised?) ;;; ;(si:define-special-form pcl::top-level-form (name times ; &body body ; &environment env) ; (declare lt:(arg-template . body) (ignore name)) ; (si:check-eval-when-times times) ; (when (member 'eval times) (si:eval-body body env))) ; ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) ; (lt::mapforms-list original-form form (cddr form) 'eval usage)) ;;; This is the normal function for looking at each form read from the file and calling ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) ; (CATCH-ERROR-RESTART ; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) ; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) ; (LET ((ERROR-MESSAGE-HOOK ; #'(LAMBDA () ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" ; DBG:*ERROR-MESSAGE-PRINLEVEL* ; DBG:*ERROR-MESSAGE-PRINLENGTH* ; FORM)))) ; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) ; (WHEN (LISTP FORM) ;Ignore atoms at top-level ; (LET ((FUNCTION (FIRST FORM))) ; (SELECTQ FUNCTION ; ((QUOTE)) ;and quoted constants e.g. 'COMPILE ; ((PROGN) ; (DOLIST (FORM (CDR FORM)) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) ; ((EVAL-WHEN) ; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) ; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) ; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) ; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) ; (FORMS (CDDR FORM))) ; (COND (LOAD-P ; (DOLIST (FORM FORMS) ; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) ; (COMPILE-P ; (DOLIST (FORM FORMS) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) ; ((DEFUN) ; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) ; (IF (EQ (CDR TEM) (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) ; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) ; ((MACRO) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) ; ((DECLARE) ; (DOLIST (FORM (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) ; ;; (DECLARE (SPECIAL ... has load-time action as well. ; ;; All other DECLARE's do not. ; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) ; ((COMPILER-LET) ; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) ; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) ; ((SI:DEFINE-SPECIAL-FORM) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) ; ((MULTIPLE-DEFINITION) ; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) ; (LET ((NAME-VALID (AND (NOT (NULL NAME)) ; (OR (SYMBOLP NAME) ; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) ; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) ; (UNLESS (AND NAME-VALID TYPE-VALID) ; (WARN "(~S ~S ~S ...) is invalid because~@ ; ~:[~S is not valid as a definition name~;~*~]~ ; ~:[~&~S is not valid as a definition type~;~*~]" ; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) ; (LET* ((COMPILED-BODY NIL) ; (COMPILE-FUNCTION *COMPILE-FUNCTION*) ; (*COMPILE-FUNCTION* ; (LAMBDA (OPERATION &REST ARGS) ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (SELECTQ OPERATION ; (:DUMP-FORM ; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM ; (FIRST ARGS)) ; COMPILED-BODY)) ; (:INSTALL-DEFINITION ; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) ; COMPILED-BODY)) ; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) ; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) ; ,@LOCAL-DECLARATIONS))) ; (DOLIST (FORM BODY) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) ; (FUNCALL COMPILE-FUNCTION :DUMP-FORM ; `(LOAD-MULTIPLE-DEFINITION ; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) ; ((pcl::top-level-form) ; (destructuring-bind (name times . body) ; (cdr form) ; (si:check-eval-when-times times) ; (let ((compile-p (or (memq 'compile times) ; (and compile-time-too (memq 'eval times)))) ; (load-p (or (memq 'load times) ; (memq 'cl:load times))) ; (fspec `(pcl::top-level-form ,name))) ; (cond (load-p ; (compile-from-stream-1 ; `(progn (defun ,fspec () . ,body) ; (funcall (function ,fspec))) ; (and compile-p ':force))) ; (compile-p ; (dolist (b body) ; (funcall *compile-form-function* form ':force nil))))))) ; (OTHERWISE ; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) ; (IF TEM ; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) ; ; dw:: (defun symbol-flavor-or-cl-type (symbol) (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent non-atomic-deftype)) (multiple-value-bind (result foundp) (gethash symbol *flavor-or-cl-type-cache*) (let ((frob (if foundp result (setf (gethash symbol *flavor-or-cl-type-cache*) (or (get symbol 'flavor:flavor) (not (null (defstruct-type-p symbol))) (let* ((deftype (get symbol 'deftype)) (descriptor (symbol-presentation-type-descriptor symbol)) (typep (unless (and descriptor (presentation-type-explicit-type-function descriptor)) ;; Don't override the one defined in the presentation-type. (get symbol 'typep))) (atomic-subtype-parent (find-atomic-subtype-parent symbol)) (non-atomic-deftype (when (and (not descriptor) deftype) (not (member (first (type-arglist symbol)) '(&rest &key &optional)))))) (if (or typep (not (atom deftype)) non-atomic-deftype ;; deftype overrides atomic-subtype-parent. (and (not deftype) atomic-subtype-parent)) (list-in-area *handler-dynamic-area* deftype typep atomic-subtype-parent non-atomic-deftype) deftype))))))) (locally (declare (inline compiled-function-p)) (etypecase frob (array (values frob)) (null (values nil)) ((member t) (values nil t)) (compiled-function (values nil nil frob)) (lexical-closure (values nil nil frob)) (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) frob (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) (symbol (values nil nil nil nil frob))))))) ;;; ;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser ;;; is willing to look ahead while trying to parse a definition. Even 2 lines is enough ;;; for just about all cases, but there isn't much overhead, and 10 should be enough ;;; to satisfy pretty much everyone... but feel free to change it. ;;; - MT 880921 ;;; zwei: (defvar *sectionize-line-lookahead* 3) zwei: (DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT) (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS) ADDED-COMPLETIONS ;ignored, obsolete (WHEN STREAM (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T)) (INCF *SECTIONIZE-BUFFER*) (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*)) OLD-CHANGED-SECTIONS) (TICK) ;; Flush old section nodes. Also collect the names of those that are modified, they are ;; the ones that will be modified again after a revert buffer. (DOLIST (NODE (NODE-INFERIORS BUFFER)) (AND (> (NODE-TICK NODE) BUFFER-TICK) (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE) (SECTION-NODE-DEFINITION-TYPE NODE)) OLD-CHANGED-SECTIONS)) (FLUSH-BP (INTERVAL-FIRST-BP NODE)) (FLUSH-BP (INTERVAL-LAST-BP NODE))) (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE)) (LIMIT (BP-LINE LAST-BP)) (EOFFLG) (ABNORMAL T) (DEFINITION-LIST NIL) (BP (COPY-BP FIRST-BP)) (FUNCTION-SPEC) (DEFINITION-TYPE) (STR) (INT-LINE) (first-time t) (future-line) ; we actually read into future line (future-int-line) (PREV-NODE-START-BP FIRST-BP) (PREV-NODE-DEFINITION-LINE NIL) (PREV-NODE-FUNCTION-SPEC NIL) (PREV-NODE-TYPE 'HEADER) (PREVIOUS-NODE NIL) (NODE-LIST NIL) (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE))) (NIL) ;; If we have a stream, read another line. (when (AND STREAM (NOT EOFFLG)) (let ((lookahead (if future-line 1 *sectionize-line-lookahead*))) (dotimes (i lookahead) ; startup lookahead (MULTIPLE-VALUE (future-LINE EOFFLG) (LET ((DEFAULT-CONS-AREA *LINE-AREA*)) (SEND STREAM ':LINE-IN LINE-LEADER-SIZE))) (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE))) (when first-time (setq first-time nil) (setq line future-line) (setq int-line future-int-line)) (when eofflg (return))))) (SETQ INT-LINE LINE) (when int-line (MOVE-BP BP INT-LINE 0)) ;Record as potentially start-bp for a section ;; See if the line is the start of a defun. (WHEN (AND LINE (LET (ERR) (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE) (SEND SELF ':SECTION-NAME INT-LINE BP STATE)) (NOT ERR))) (PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST) (SECTION-COMPLETION FUNCTION-SPEC STR NIL) ;; List methods under both names for user ease. (LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION FUNCTION-SPEC INT-LINE))) (WHEN OTHER-COMPLETION (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL))) (LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK))) ;; Don't make a section node if it's completely empty. This avoids making ;; a useless Buffer Header section node. Just set all the PREV variables ;; so that the next definition provokes the *right thing* (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP) (SETQ PREVIOUS-NODE (ADD-SECTION-NODE PREV-NODE-START-BP (SETQ PREV-NODE-START-BP PREV-NODE-END-BP) PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) (EQ PREV-NODE-TYPE TYPE))) *TICK* BUFFER-TICK) BUFFER-TICK)) (PUSH PREVIOUS-NODE NODE-LIST))) (SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC PREV-NODE-TYPE DEFINITION-TYPE PREV-NODE-DEFINITION-LINE INT-LINE)) ;; After processing the last line, exit. (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT))) ;; If reading a stream, we should not have inserted a CR ;; after the eof line. (WHEN STREAM (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T)) ;; The rest of the buffer is part of the last node (UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P) ;; ---oh dear, what sort of section will this be? A non-empty HEADER ;; ---node. Well, ok for now. (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) (EQ PREV-NODE-TYPE TYPE))) *TICK* BUFFER-TICK) BUFFER-TICK) NODE-LIST) (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST))) (SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST)) (SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER))) (SETQ ABNORMAL NIL) ;timing windows here ;; Speed up completion if enabled. (WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS* (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*)) (SETQ *ZMACS-COMPLETION-AARRAY* (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*)) (RETURN (VALUES (CL:SETF (ZMACS-SECTION-LIST BUFFER) (NREVERSE DEFINITION-LIST)) ABNORMAL)))))) gcl-2.6.14/pcl/impl/symbolics/rel-8-patches.lisp0000644000175000017500000002361414360276512017771 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; Does simple constant folding. This works for everything that doesn't have ;;; side-effects. ;;; ALL operands must be constant. ;;; Note that commutative-constant-folder can hack this case perfectly well ;;; by himself for the functions he handles. (defun constant-fold-optimizer (form) (let ((eval-when-load-p nil)) (flet ((constant-form-p (x) (when (constant-form-p x) (cond ((and (listp x) (eq (car x) 'quote) (listp (cadr x)) (eq (caadr x) eval-at-load-time-marker)) (setq eval-when-load-p t) (cdadr x)) (t x))))) (if (every (cdr form) #'constant-form-p) (if eval-when-load-p (list 'quote (list* eval-at-load-time-marker (car form) (mapcar #'constant-form-p (cdr form)))) (condition-case (error-object) (multiple-value-call #'(lambda (&rest values) (if (= (length values) 1) `',(first values) `(values ,@(mapcar #'(lambda (x) `',x) values)))) (eval form)) (error (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" form error-object) form))) form)))) ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; ;;; The damn compiler doesn't compile random forms that appear at top level. ;;; Its difficult to do because you have to get an associated function spec ;;; to go with those forms. This handles that by defining a special form, ;;; top-level-form that compiles its body. It takes a list of eval-when ;;; times just like eval when does. It also takes a name which it uses ;;; to construct a function spec for the top-level-form function it has ;;; to create. ;;; ; ;si:: ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) ; ;si:: ;(define-function-spec-handler pcl::top-level-form ; (operation fspec &optional arg1 arg2) ; (let ((name (cadr fspec))) ; (selectq operation ; (validate-function-spec (and (= (length fspec) 2) ; (or (symbolp name) ; (listp name)))) ; (fdefine ; (setf (gethash name *top-level-form-fdefinitions*) arg1)) ; ((fdefinition fdefinedp) ; (gethash name *top-level-form-fdefinitions*)) ; (fdefinition-location ; (ferror "It is not possible to get the fdefinition-location of ~s." ; fspec)) ; (fundefine (remhash name *top-level-form-fdefinitions*)) ; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) ; ;;; ;;; This is basically stolen from PROGN (surprised?) ;;; ;(si:define-special-form pcl::top-level-form (name times ; &body body ; &environment env) ; (declare lt:(arg-template . body) (ignore name)) ; (si:check-eval-when-times times) ; (when (member 'eval times) (si:eval-body body env))) ; ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) ; (lt::mapforms-list original-form form (cddr form) 'eval usage)) ;;; This is the normal function for looking at each form read from the file and calling ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) ; (CATCH-ERROR-RESTART ; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) ; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) ; (LET ((ERROR-MESSAGE-HOOK ; #'(LAMBDA () ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" ; DBG:*ERROR-MESSAGE-PRINLEVEL* ; DBG:*ERROR-MESSAGE-PRINLENGTH* ; FORM)))) ; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) ; (WHEN (LISTP FORM) ;Ignore atoms at top-level ; (LET ((FUNCTION (FIRST FORM))) ; (SELECTQ FUNCTION ; ((QUOTE)) ;and quoted constants e.g. 'COMPILE ; ((PROGN) ; (DOLIST (FORM (CDR FORM)) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) ; ((EVAL-WHEN) ; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) ; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) ; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) ; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) ; (FORMS (CDDR FORM))) ; (COND (LOAD-P ; (DOLIST (FORM FORMS) ; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) ; (COMPILE-P ; (DOLIST (FORM FORMS) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) ; ((DEFUN) ; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) ; (IF (EQ (CDR TEM) (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) ; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) ; ((MACRO) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) ; ((DECLARE) ; (DOLIST (FORM (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) ; ;; (DECLARE (SPECIAL ... has load-time action as well. ; ;; All other DECLARE's do not. ; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) ; ((COMPILER-LET) ; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) ; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) ; ((SI:DEFINE-SPECIAL-FORM) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) ; ((MULTIPLE-DEFINITION) ; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) ; (LET ((NAME-VALID (AND (NOT (NULL NAME)) ; (OR (SYMBOLP NAME) ; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) ; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) ; (UNLESS (AND NAME-VALID TYPE-VALID) ; (WARN "(~S ~S ~S ...) is invalid because~@ ; ~:[~S is not valid as a definition name~;~*~]~ ; ~:[~&~S is not valid as a definition type~;~*~]" ; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) ; (LET* ((COMPILED-BODY NIL) ; (COMPILE-FUNCTION *COMPILE-FUNCTION*) ; (*COMPILE-FUNCTION* ; (LAMBDA (OPERATION &REST ARGS) ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (SELECTQ OPERATION ; (:DUMP-FORM ; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM ; (FIRST ARGS)) ; COMPILED-BODY)) ; (:INSTALL-DEFINITION ; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) ; COMPILED-BODY)) ; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) ; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) ; ,@LOCAL-DECLARATIONS))) ; (DOLIST (FORM BODY) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) ; (FUNCALL COMPILE-FUNCTION :DUMP-FORM ; `(LOAD-MULTIPLE-DEFINITION ; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) ; ((pcl::top-level-form) ; (destructuring-bind (name times . body) ; (cdr form) ; (si:check-eval-when-times times) ; (let ((compile-p (or (memq 'compile times) ; (and compile-time-too (memq 'eval times)))) ; (load-p (or (memq 'load times) ; (memq 'cl:load times))) ; (fspec `(pcl::top-level-form ,name))) ; (cond (load-p ; (compile-from-stream-1 ; `(progn (defun ,fspec () . ,body) ; (funcall (function ,fspec))) ; (and compile-p ':force))) ; (compile-p ; (dolist (b body) ; (funcall *compile-form-function* form ':force nil))))))) ; (OTHERWISE ; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) ; (IF TEM ; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) ; ; dw:: (defun symbol-flavor-or-cl-type (symbol) (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent non-atomic-deftype)) (multiple-value-bind (result foundp) (gethash symbol *flavor-or-cl-type-cache*) (let ((frob (if foundp result (setf (gethash symbol *flavor-or-cl-type-cache*) (or (get symbol 'flavor:flavor) (let ((class (get symbol 'clos-internals::class-for-name))) (when (and class (not (typep class 'clos:built-in-class))) class)) (not (null (defstruct-type-p symbol))) (let* ((deftype (get symbol 'deftype)) (descriptor (symbol-presentation-type-descriptor symbol)) (typep (unless (and descriptor (presentation-type-explicit-type-function descriptor)) ;; Don't override the one defined in the presentation-type. (get symbol 'typep))) (atomic-subtype-parent (find-atomic-subtype-parent symbol)) (non-atomic-deftype (when (and (not descriptor) deftype) (not (member (first (type-arglist symbol)) '(&rest &key &optional)))))) (if (or typep (not (atom deftype)) non-atomic-deftype ;; deftype overrides atomic-subtype-parent. (and (not deftype) atomic-subtype-parent)) (list-in-area *handler-dynamic-area* deftype typep atomic-subtype-parent non-atomic-deftype) deftype))))))) (locally (declare (inline compiled-function-p)) (etypecase frob (array (values frob)) (instance (values frob)) (null (values nil)) ((member t) (values nil t)) (compiled-function (values nil nil frob)) (lexical-closure (values nil nil frob)) (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) frob (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) (symbol (values nil nil nil nil frob))))))) gcl-2.6.14/pcl/impl/ibcl/0000755000175000017500000000000014360276512013423 5ustar cammcammgcl-2.6.14/pcl/impl/ibcl/ibcl-patches.lisp0000644000175000017500000001036414360276512016656 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'system) ;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere ;;; in the lambda-list. The former allows deviation from the CL spec, ;;; but what the heck. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) (defvar *old-defmacro*) (defun new-defmacro (whole env) (flet ((call-old-definition (new-whole) (funcall *old-defmacro* new-whole env))) (if (not (and (consp whole) (consp (cdr whole)) (consp (cddr whole)) (consp (cdddr whole)))) (call-old-definition whole) (let* ((ll (caddr whole)) (env-tail (do ((tail ll (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail))))) (if env-tail (call-old-definition (list* (car whole) (cadr whole) (append (list '&environment (cadr env-tail)) (ldiff ll env-tail) (cddr env-tail)) (cdddr whole))) (call-old-definition whole)))))) (eval-when (load eval) (unless (boundp '*old-defmacro*) (setq *old-defmacro* (macro-function 'defmacro)) (setf (macro-function 'defmacro) #'new-defmacro))) ;;; ;;; setf patches ;;; (in-package 'system) (defun get-setf-method (form) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value form) (unless (listp vars) (error "The temporary variables component, ~s, of the setf-method for ~s is not a list." vars form)) (unless (listp vals) (error "The values forms component, ~s, of the setf-method for ~s is not a list." vals form)) (unless (listp stores) (error "The store variables component, ~s, of the setf-method for ~s is not a list." stores form)) (unless (= (list-length stores) 1) (error "Multiple store-variables are not allowed.")) (values vars vals stores store-form access-form))) (defun get-setf-method-multiple-value (form) (cond ((symbolp form) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form))) ((or (not (consp form)) (not (symbolp (car form)))) (error "Cannot get the setf-method of ~S." form)) ((get (car form) 'setf-method) (apply (get (car form) 'setf-method) (cdr form))) ((get (car form) 'setf-update-fn) (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym))) (values vars (cdr form) (list store) `(,(get (car form) 'setf-update-fn) ,@vars ,store) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym)) (l (get (car form) 'setf-lambda)) (f `(lambda ,(car l) (funcall #'(lambda ,(cadr l) ,@(cddr l)) ',store)))) (values vars (cdr form) (list store) (apply f vars) (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand-1 form))) (t (error "Cannot expand the SETF form ~S." form)))) gcl-2.6.14/pcl/impl/ibcl/ibcl-low.lisp0000644000175000017500000002546514360276512016040 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for Kyoto Common Lisp (KCL) (in-package 'pcl) ;;; ;;; The reason these are here is because the KCL compiler does not allow ;;; LET to return FIXNUM values as values of (c) type int, hence the use ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces ;;; conversion of ints to objects. ;;; (defmacro %logand (&rest args) (reduce-variadic-to-binary 'logand args 0 t 'fixnum)) ;(defmacro %logxor (&rest args) ; (reduce-variadic-to-binary 'logxor args 0 t 'fixnum)) (defmacro %+ (&rest args) (reduce-variadic-to-binary '+ args 0 t 'fixnum)) ;(defmacro %- (x y) ; `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) (defmacro %* (&rest args) (reduce-variadic-to-binary '* args 1 t 'fixnum)) (defmacro %/ (x y) `(the fixnum (/ (the fixnum ,x) (the fixnum ,y)))) (defmacro %1+ (x) `(the fixnum (1+ (the fixnum ,x)))) (defmacro %1- (x) `(the fixnum (1- (the fixnum ,x)))) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) ;;; ;;; std-instance-p ;;; (si:define-compiler-macro std-instance-p (x) (once-only (x) `(and (si:structurep ,x) (eq (si:structure-name ,x) 'std-instance)))) (dolist (inline '((si:structurep ((t) compiler::boolean nil nil "type_of(#0)==t_structure") compiler::inline-always) (si:structure-name ((t) t nil nil "(#0)->str.str_name") compiler::inline-unsafe))) (setf (get (first inline) (third inline)) (list (second inline)))) (setf (get 'cclosure-env 'compiler::inline-always) (list '((t) t nil nil "(#0)->cc.cc_env"))) ;;; ;;; turbo-closure patch. See the file kcl-mods.text for details. ;;; #+:turbo-closure (progn (CLines "object tc_cc_env_nthcdr (n,tc)" "object n,tc; " "{return (type_of(tc)==t_cclosure&& " " tc->cc.cc_turbo!=NULL&& " " type_of(n)==t_fixnum)? " " tc->cc.cc_turbo[fix(n)]: " ; assume that n is in bounds " Cnil; " "} " ) (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr)) (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe) '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]"))) ) ;;;; low level stuff to hack compiled functions and compiled closures. ;;; ;;; The primary client for this is fsc-low, but since we make some use of ;;; it here (e.g. to implement set-function-name-1) it all appears here. ;;; (eval-when (compile eval) (defmacro define-cstruct-accessor (accessor structure-type field value-type field-type tag-name) (let ((setf (intern (concatenate 'string "SET-" (string accessor)))) (caccessor (format nil "pcl_get_~A_~A" structure-type field)) (csetf (format nil "pcl_set_~A_~A" structure-type field)) (vtype (intern (string-upcase value-type)))) `(progn (CLines ,(format nil "~A ~A(~A) ~%~ object ~A; ~%~ { return ((~A) ~A->~A.~A); } ~%~ ~%~ ~A ~A(~A, new) ~%~ object ~A; ~%~ ~A new; ~%~ { return ((~A)(~A->~A.~A = ~Anew)); } ~%~ " value-type caccessor structure-type structure-type value-type structure-type tag-name field value-type csetf structure-type structure-type value-type value-type structure-type tag-name field field-type )) (defentry ,accessor (object) (,vtype ,caccessor)) (defentry ,setf (object ,vtype) (,vtype ,csetf)) (defsetf ,accessor ,setf) ))) ) ;;; ;;; struct cfun { /* compiled function header */ ;;; short t, m; ;;; object cf_name; /* compiled function name */ ;;; int (*cf_self)(); /* entry address */ ;;; object cf_data; /* data the function uses */ ;;; /* for GBC */ ;;; char *cf_start; /* start address of the code */ ;;; int cf_size; /* code size */ ;;; }; ;;; add field-type tag-name (define-cstruct-accessor cfun-name "cfun" "cf_name" "object" "(object)" "cf") (define-cstruct-accessor cfun-self "cfun" "cf_self" "int" "(int (*)())" "cf") (define-cstruct-accessor cfun-data "cfun" "cf_data" "object" "(object)" "cf") (define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf") (define-cstruct-accessor cfun-size "cfun" "cf_size" "int" "(int)" "cf") (CLines "object pcl_cfunp (x) " "object x; " "{if(x->c.t == (int) t_cfun) " " return (Ct); " " else " " return (Cnil); " " } " ) (defentry cfunp (object) (object pcl_cfunp)) ;;; ;;; struct cclosure { /* compiled closure header */ ;;; short t, m; ;;; object cc_name; /* compiled closure name */ ;;; int (*cc_self)(); /* entry address */ ;;; object cc_env; /* environment */ ;;; object cc_data; /* data the closure uses */ ;;; /* for GBC */ ;;; char *cc_start; /* start address of the code */ ;;; int cc_size; /* code size */ ;;; }; ;;; (define-cstruct-accessor cclosure-name "cclosure" "cc_name" "object" "(object)" "cc") (define-cstruct-accessor cclosure-self "cclosure" "cc_self" "int" "(int (*)())" "cc") (define-cstruct-accessor cclosure-data "cclosure" "cc_data" "object" "(object)" "cc") (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" "(char *)" "cc") (define-cstruct-accessor cclosure-size "cclosure" "cc_size" "int" "(int)" "cc") (define-cstruct-accessor cclosure-env "cclosure" "cc_env" "object" "(object)" "cc") (CLines "object pcl_cclosurep (x) " "object x; " "{if(x->c.t == (int) t_cclosure) " " return (Ct); " " else " " return (Cnil); " " } " ) (defentry cclosurep (object) (object pcl_cclosurep)) ;; ;;;;;; Load Time Eval ;; ;;; ;;; This doesn't work because it looks at a global variable to see if it is ;;; in the compiler rather than looking at the macroexpansion environment. ;;; ;;; The result is that if in the process of compiling a file, we evaluate a ;;; form that has a call to load-time-eval, we will get faked into thinking ;;; that we are compiling that form. ;;; ;;; THIS NEEDS TO BE DONE RIGHT!!! ;;; ;(defmacro load-time-eval (form) ; ;; In KCL there is no compile-to-core case. For things that we are ; ;; "compiling to core" we just expand the same way as if were are ; ;; compiling a file since the form will be evaluated in just a little ; ;; bit when gazonk.o is loaded. ; (if (and (boundp 'compiler::*compiler-input*) ;Hack to see of we are ; compiler::*compiler-input*) ;in the compiler! ; `'(si:|#,| . ,form) ; `(progn ,form))) (defmacro load-time-eval (form) (read-from-string (format nil "'#,~S" form))) (defmacro memory-block-ref (block offset) `(svref (the simple-vector ,block) (the fixnum ,offset))) ;; ;;;;;; Generating CACHE numbers ;; ;;; This needs more work to be sure it is going as fast as possible. ;;; - The calls to si:address should be open-coded. ;;; - The logand should be open coded. ;;; ;(defmacro symbol-cache-no (symbol mask) ; (if (and (constantp symbol) ; (constantp mask)) ; `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask)) ; `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) (defmacro object-cache-no (object mask) `(logand (the fixnum (si:address ,object)) ,mask)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (defun set-function-name-1 (fn new-name ignore) (cond ((cclosurep fn) (setf (cclosure-name fn) new-name)) ((cfunp fn) (setf (cfun-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) #| (defconstant most-positive-small-fixnum 1024) /* should be supplied */ (defconstant most-negative-small-fixnum -1024) /* by ibuki */ (defmacro symbol-cache-no (symbol mask) (if (constantp mask) (if (and (> mask 0) (< mask most-positive-small-fixnum)) (if (constantp symbol) `(load-time-eval (coffset ,symbol ,mask 2)) `(coffset ,symbol ,mask 2)) (if (constantp symbol) `(load-time-eval (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)) `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) (defmacro object-cache-no (object mask) (if (and (constantp mask) (> mask 0) (< mask most-positive-small-fixnum)) `(coffset ,object ,mask 4) `(logand (ash (the fixnum (si:address ,object)) -4) ,mask))) (CLines "object pcl_coffset (sym,mask,lshift)" "object sym,mask,lshift;" "{" " return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));" "}" ) (defentry coffset (object object object) (object pcl_coffset)) |# gcl-2.6.14/pcl/impl/xerox/0000755000175000017500000000000014360276512013657 5ustar cammcammgcl-2.6.14/pcl/impl/xerox/xerox-patches.lisp0000644000175000017500000002260414360276512017346 0ustar cammcamm;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; (in-package "XCL-USER") ;;; Patch a bug with Lambda-substitution #+Xerox-Lyric (defun compiler::meta-call-lambda-substitute (node) (let* ((fn (compiler::call-fn node)) (var-list (compiler::lambda-required fn)) (spec-effects (il:for var il:in var-list il:unless (eq (compiler::variable-scope var) :lexical) il:collect (compiler::effects-representation var))) ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding ;; to set even when nobody cares. (compiler::*subst-occurred* nil)) (il:for var il:in var-list il:as tail il:on (compiler::call-args node) il:when (and (eq (compiler::variable-scope var) :lexical) (compiler::substitutable-p (car tail) var) (dolist (compiler::spec-effect spec-effects t) (when (not (compiler::null-effects-intersection compiler::spec-effect (compiler::node-affected (car tail)))) (return nil))) (dolist (compiler::later-arg (cdr tail) t) (when (not (compiler::passable (car tail) compiler::later-arg)) (return nil)))) il:do (setf (compiler::lambda-body fn) (compiler::meta-substitute (car tail) var (compiler::lambda-body fn)))) (when (null (compiler::node-meta-p (compiler::lambda-body fn))) (setf (compiler::node-meta-p fn) nil) (setq compiler::*made-changes* t)))) ;;; Some simple optimizations missing from the compiler. ;; Shift by a constant. ;; Unfortunately, these cause the compiler to generate spurious warning ;; messages about "Unknown function IL:LLSH1 called from ..." It's not often ;; you come across a place where COMPILER-LET is really needed. #+Xerox-Lyric (progn (defvar *ignore-shift-by-constant-optimization* nil "Marker used for informing the shift-by-constant optimizers that they are in the shift function, and should not optimize.") (defun il:lrsh1 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:lrsh x 1))) (defun il:lrsh8 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:lrsh x 8))) (defun il:llsh1 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:llsh x 1))) (defun il:llsh8 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:llsh x 8))) (defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env) (if (and (constantp n) (not *ignore-shift-by-constant-optimization*)) (let ((shift-factor (eval n))) (cond ((not (numberp shift-factor)) (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor)) ((= shift-factor 0) x) ((< shift-factor 0) `(il:llsh ,x ,(- shift-factor))) ((< shift-factor 8) `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor))) (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8))))) 'compiler:pass)) (defoptimizer il:llsh il:left-shift-by-constant (x n &environment env) (if (and (constantp n) (not *ignore-shift-by-constant-optimization*)) (let ((shift-factor (eval n))) (cond ((not (numberp shift-factor)) (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor)) ((= shift-factor 0) x) ((< shift-factor 0) `(il:lrsh ,x ,(- shift-factor))) ((< shift-factor 8) `(il:llsh (il:llsh1 ,x) ,(1- shift-factor))) (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8))))) 'compiler:pass)) ) ;; Simple TYPEP optimiziation #+Xerox-Lyric (defoptimizer typep type-t-test (object type) "Everything is of type T" (if (and (constantp type) (eq (eval type) t)) `(progn ,object t) 'compiler:pass)) ;;; Declare side-effects (actually, lack of side-effects) info for some ;;; internal arithmetic functions. These are needed because the compiler runs ;;; the optimizers before checking the side-effects, so side-effect ;;; declarations on the "real" functions are oft times ignored. #+Xerox-Lyric (progn (il:putprops cl::%+ compiler::side-effects-data (:none . :none)) (il:putprops cl::%- compiler::side-effects-data (:none . :none)) (il:putprops cl::%* compiler::side-effects-data (:none . :none)) (il:putprops cl::%/ compiler::side-effects-data (:none . :none)) (il:putprops cl::%logior compiler::side-effects-data (:none . :none)) (il:putprops cl::%logeqv compiler::side-effects-data (:none . :none)) (il:putprops cl::%= compiler::side-effects-data (:none . :none)) (il:putprops cl::%> compiler::side-effects-data (:none . :none)) (il:putprops cl::%< compiler::side-effects-data (:none . :none)) (il:putprops cl::%>= compiler::side-effects-data (:none . :none)) (il:putprops cl::%<= compiler::side-effects-data (:none . :none)) (il:putprops cl::%/= compiler::side-effects-data (:none . :none)) (il:putprops il:lrsh1 compiler::side-effects-data (:none . :none)) (il:putprops il:lrsh8 compiler::side-effects-data (:none . :none)) (il:putprops il:llsh1 compiler::side-effects-data (:none . :none)) (il:putprops il:llsh8 compiler::side-effects-data (:none . :none)) ) ;;; Fix a nit in the compiler #+Xerox-Lyric (progn (il:unadvise 'compile) (il:advise 'compile ':around '(let (compiler::*input-stream*) (inner))) ) ;;; While no person would generate code like (logor x), macro can (and do). (defun optimize-logical-op-1-arg (form env ctxt) (declare (ignore env ctxt)) (if (= 2 (length form)) (second form) 'compiler::pass)) (xcl:defoptimizer logior optimize-logical-op-1-arg) (xcl:defoptimizer logxor optimize-logical-op-1-arg) (xcl:defoptimizer logand optimize-logical-op-1-arg) (xcl:defoptimizer logeqv optimize-logical-op-1-arg) #+Xerox-Medley ;; A bug compiling LABELS (defun compiler::meta-call-labels (compiler::node compiler:context) ;; This is similar to META-CALL-LAMBDA, but we have some extra information. ;; There are only required arguments, and we have the correct number of them. (let ((compiler::*made-changes* nil)) ;; First, substitute the functions wherever possible. (dolist (compiler::fn-pair (compiler::labels-funs compiler::node) (when (null (compiler::node-meta-p (compiler::labels-body compiler::node))) (setf (compiler::node-meta-p compiler::node) nil) (setq compiler::*made-changes* t))) (when (compiler::substitutable-p (cdr compiler::fn-pair) (car compiler::fn-pair)) (let ((compiler::*subst-occurred* nil)) ;; First try substituting into the body. (setf (compiler::labels-body compiler::node) (compiler::meta-substitute (cdr compiler::fn-pair) (car compiler::fn-pair) (compiler::labels-body compiler::node))) (when (not compiler::*subst-occurred*) ;; Wasn't in the body - try the other functions. (dolist (compiler::target-pair (compiler::labels-funs compiler::node)) (unless (eq compiler::target-pair compiler::fn-pair) (setf (cdr compiler::target-pair) (compiler::meta-substitute (cdr compiler::fn-pair) (car compiler::fn-pair) (cdr compiler::target-pair))) (when compiler::*subst-occurred* ;Found it, we can stop now. (setf (compiler::node-meta-p compiler::node) nil) (setq compiler::*made-changes* t) (return))))) ;; May need to reanalyze the node, since things might have changed. ;; Note that reanalyzing the parts of the node this way means the the ;; state in the enclosing loop is not lost. (dolist (compiler::fns (compiler::labels-funs compiler::node)) (compiler::meval (cdr compiler::fns) :argument)) (compiler::meval (compiler::labels-body compiler::node) :return)))) ;; Now remove any functions that aren't referenced. (dolist (compiler::fn-pair (prog1 (compiler::labels-funs compiler::node) (setf (compiler::labels-funs compiler::node) nil))) (cond ((null (compiler::variable-read-refs (car compiler::fn-pair))) (compiler::release-tree (cdr compiler::fn-pair)) (setq compiler::*made-changes* t)) (t (push compiler::fn-pair (compiler::labels-funs compiler::node))))) ;; If there aren't any functions left, replace the node with its body. (when (null (compiler::labels-funs compiler::node)) (let ((compiler::body (compiler::labels-body compiler::node))) (setf (compiler::labels-body compiler::node) nil) (compiler::release-tree compiler::node) (setq compiler::node compiler::body compiler::*made-changes* t))) ;; Finally, set the meta-p flag if everythings OK. (if (null compiler::*made-changes*) (setf (compiler::node-meta-p compiler::node) compiler:context) (setf (compiler::node-meta-p compiler::node) nil))) compiler::node) gcl-2.6.14/pcl/impl/xerox/pcl-env.lisp0000644000175000017500000017341714360276512016131 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Xerox-Lisp specific environment hacking for PCL (in-package "PCL") ;; ;; Protect the Corporation ;; (eval-when (eval load) (format *terminal-io* "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~ Xerox Corporation. All rights reserved.~%")) ;;; Make funcallable instances (FINs) print by calling print-object. (eval-when (eval load) (il:defprint 'il:compiled-closure 'il:print-closure)) (defun il:print-closure (x &optional stream depth) ;; See the IRM, section 25.3.3. Unfortunately, that documentation is ;; not correct. In particular, it makes no mention of the third argument. (cond ((not (funcallable-instance-p x)) ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for ;; printing closures (il:\\cclosure.defprint x stream)) ((streamp stream) ;; Use the standard PCL printing method, then return T to tell ;; the printer that we have done the printing ourselves. (print-object x stream) t) (t ;; Internal printing (again, see the IRM section 25.3.3). ;; Return a list containing the string of characters that ;; would be printed, if the object were being printed for ;; real. (with-output-to-string (stream) (list (print-object x stream)))))) ;;; Naming methods (defun gf-named (gf-name) (let ((spec (cond ((symbolp gf-name) gf-name) ((and (consp gf-name) (eq (first gf-name) 'setf) (symbolp (second gf-name)) (null (cddr gf-name))) (get-setf-function-name (second gf-name))) (t nil)))) (if (and (fboundp spec) (generic-function-p (symbol-function spec))) (symbol-function spec) nil))) (defun generic-function-method-names (gf-name hasdefp) (if hasdefp (let ((names nil)) (maphash #'(lambda (key value) (declare (ignore value)) (when (and (consp key) (eql (car key) gf-name)) (pushnew key names))) (gethash 'methods xcl:*definition-hash-table*)) names) (let ((gf (gf-named gf-name))) (when gf (mapcar #'full-method-name (generic-function-methods gf)))))) (defun full-method-name (method) "Return the full name of the method" (let ((specializers (mapcar #'(lambda (x) (cond ((eq x 't) t) ((consp x) x) (t (class-name x)))) (method-type-specifiers method)))) ;; Now go through some hair to make sure that specializer is ;; really right. Once PCL returns the right value for ;; specializers this can be taken out. (let* ((arglist (method-arglist method)) (number-required (or (position-if #'(lambda (x) (member x lambda-list-keywords)) arglist) (length arglist))) (diff (- number-required (length specializers)))) (when (> diff 0) (setq specializers (nconc (copy-list specializers) (make-list diff :initial-element 't))))) (make-full-method-name (generic-function-name (method-generic-function method)) (method-qualifiers method) specializers))) (defun make-full-method-name (generic-function-name qualifiers arg-types) "Return the full name of a method, given the generic-function name, the method qualifiers, and the arg-types" ;; The name of the method is: ;; ( .. ;; (..)) (labels ((remove-trailing-ts (l) (if (null l) nil (let ((tail (remove-trailing-ts (cdr l)))) (if (null tail) (if (eq (car l) 't) nil (list (car l))) (if (eq l tail) l (cons (car l) tail))))))) `(,generic-function-name ,@qualifiers ,(remove-trailing-ts arg-types)))) (defun parse-full-method-name (method-name) "Parse the method name, returning the gf-name, the qualifiers, and the arg-types." (values (first method-name) (butlast (rest method-name)) (car (last method-name)))) (defun prompt-for-full-method-name (gf-name &optional has-def-p) "Prompt the user for the full name of a method on the given generic function name" (let ((method-names (generic-function-method-names gf-name has-def-p))) (cond ((null method-names) nil) ((null (cdr method-names)) (car method-names)) (t (il:menu (il:create il:menu il:items il:_ ;If HAS-DEF-P, include only ; those methods that have a ; symbolic def'n that we can ; find (remove-if #'null (mapcar #'(lambda (m) (if (or (not has-def-p) (il:hasdef m 'methods)) `(,(with-output-to-string (s) (dolist (x m) (format s "~A " x)) s) ',m) nil)) method-names)) il:title il:_ "Which method?")))))) ;;; Converting generic defining macros into DEFDEFINER macros (defmacro make-defdefiner (definer-name definer-type type-description &body definer-options) "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE" (let ((old-definer-macro-name (intern (string-append definer-name " old definition") (symbol-package definer-name))) (old-definer-macro-expander (intern (string-append definer-name " old expander") (symbol-package definer-name)))) `(progn ;; First, move the current defining function off to some safe ;; place (unmake-defdefiner ',definer-name) (cond ((not (fboundp ',definer-name)) (error "~A has no definition!" ',definer-name)) ((fboundp ',old-definer-macro-name)) ((macro-function ',definer-name) ; We have to move the macro ; expansion function as well, ; so it won't get clobbered ; when the original macro is ; redefined. See AR 7410. (let* ((expansion-function (macro-function ',definer-name))) (setf (symbol-function ',old-definer-macro-expander) (loop (if (symbolp expansion-function) (setq expansion-function (symbol-function expansion-function)) (return expansion-function)))) (setf (macro-function ',old-definer-macro-name) ',old-definer-macro-expander) (setf (get ',definer-name 'make-defdefiner) expansion-function))) (t (error "~A does not name a macro." ',definer-name))) ;; Make sure the type is defined (xcl:def-define-type ,definer-type ,type-description) ;; Now redefine the definer, using DEFEDFINER and the original def'n (xcl:defdefiner ,(if definer-options (cons definer-name definer-options) definer-name) ,definer-type (&body b) `(,',old-definer-macro-name ,@,'b))))) (defun unmake-defdefiner (definer-name) (let ((old-expander (get definer-name 'make-defdefiner))) (when old-expander (setf (macro-function definer-name old-expander)) (remprop definer-name 'make-defdefiner)))) ;;; For tricking ED into being able to use just the generic-function-name ;;; instead of the full method name (defun source-manager-method-edit-fn (name type source editcoms options) "Edit a method of the given name" (let ((full-name (if (gf-named name) ;If given the name of a ; generic-function, try to get ; the full method name (prompt-for-full-method-name name t) ; Otherwise it should name the ; method name))) (when (not (null full-name)) (il:default.editdef full-name type source editcoms options)) (or full-name name))) ;Return the name (defun source-manager-method-hasdef-fn (name type &optional source) "Is there a method defined with the given name?" (cond ((not (eq type 'methods)) nil) ((or (symbolp name) (and (consp name) (eq (first name) 'setf) (symbolp (second name)) (null (cddr name)))) ;; If passed in the name of a generic-function, pretend that ;; there is a method by that name if there is a generic function ;; by that name, and there is a method whose source we can find. (if (and (not (null (gf-named name))) (find-if #'(lambda (m) (il:hasdef m type source)) (generic-function-method-names name t))) name nil)) ((and (consp name) (>= (length name) 2)) ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*)) (when (il:getdef name type source '(il:nocopy il:noerror)) name)) (t ;; Nothing else can name a method nil))) ;;; Initialize the PCL env (defun initialize-pcl-env nil "Initialize the Xerox PCL environment" ;; Set up SourceManager DEFDEFINERS for classes and methods. ;; ;; Make sure to define methods before classes, so that (IL:FILES?) will build ;; filecoms that have classes before methods. (unless (il:hasdef 'methods 'il:filepkgtype) (make-defdefiner defmethod methods "methods" (:name (lambda (form) (multiple-value-bind (name qualifiers arglist) (parse-defmethod (cdr form)) (make-full-method-name name qualifiers (extract-specializer-names arglist))))) (:undefiner (lambda (method-name) (multiple-value-bind (name qualifiers arg-types) (parse-full-method-name method-name) (let* ((gf (gf-named name)) (method (when gf (get-method gf qualifiers (mapcar #'find-class arg-types))))) (when method (remove-method gf method)))))))) ;; Include support for DEFGENERIC, if that is defined (unless (or (not (fboundp 'defgeneric)) (il:hasdef 'generic-functions 'il:filepkgtype)) (make-defdefiner defgeneric generic-functions "generic-function definitions")) ;; DEFCLASS FileManager stuff (unless (il:hasdef 'classes 'il:filepkgtype) (make-defdefiner defclass classes "class definitions" (:undefiner (lambda (name) (when (find-class name t) (setf (find-class name) nil))))) ;; CLASSES "include" TYPES. (il:filepkgcom 'classes 'il:contents #'(lambda (com name type &optional reason) (declare (ignore name reason)) (if (member type '(il:types classes) :test #'eq) (cdr com) nil)))) ;; Set up the hooks so that ED can be handed the name of a generic function, ;; and end up editing a method instead (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn 'il:hasdef 'source-manager-method-hasdef-fn) ;; Set up the inspect macro. The right way to do this is to ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now... (push '((il:function pcl-object-p) . \\internal-inspect-object) il:inspectmacros) ;; Unmark any SourceManager changes caused by this loadup (dolist (com (il:filepkgchanges)) (dolist (name (cdr com)) (when (and (symbolp name) (eq (symbol-package name) (find-package "PCL"))) (il:unmarkaschanged name (car com)))))) (eval-when (eval load) (initialize-pcl-env)) ;;; Inspecting PCL objects (defun pcl-object-p (x) "Is the datum a PCL object?" (or (std-instance-p x) (fsc-instance-p x))) (defun \\internal-inspect-object (x type where) (inspect-object x type where)) (defun \\internal-inspect-slot-names (x) (inspect-slot-names x)) (defun \\internal-inspect-slot-value (x slot-name) (inspect-slot-value x slot-name)) (defun \\internal-inspect-setf-slot-value (x slot-name value) (inspect-setf-slot-value x slot-name value)) (defun \\internal-inspect-slot-name-command (slot-name x window) (inspect-slot-name-command slot-name x window)) (defun \\internal-inspect-title (x y) (inspect-title x y)) (defmethod inspect-object (x type where) "Open an insect window on the object x" (il:inspectw.create x '\\internal-inspect-slot-names '\\internal-inspect-slot-value '\\internal-inspect-setf-slot-value '\\internal-inspect-slot-name-command nil nil '\\internal-inspect-title nil where #'(lambda (n v) ;Same effect as NIL, but avoids bug in (declare (ignore v)) ; INSPECTW.CREATE n))) (defmethod inspect-slot-names (x) "Return a list of names of slots of the object that should be shown in the inspector" (mapcar #'(lambda (slotd) (slot-value slotd 'name)) (slots-to-inspect (class-of x) x))) (defmethod inspect-slot-value (x slot-name) (cond ((not (slot-exists-p x slot-name)) "** no such slot **") ((not (slot-boundp x slot-name)) "** slot not bound **") (t (slot-value x slot-name)))) (defmethod inspect-setf-slot-value (x slot-name value) "Used by the inspector to set the value fo a slot" ;; Make this UNDO-able (il:undosave `(inspect-setf-slot-value ,x ,slot-name ,(slot-value x slot-name))) ;; Then change the value (setf (slot-value x slot-name) value)) (defmethod inspect-slot-name-command (slot-name x window) "Allows the user to select a menu item to change a slot value in an inspect window" ;; This code is a very slightly hacked version of the system function ;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the ;; standard version makes some nasty assumptions about ;; structure-objects that are not true for PCL objects. (declare (special il:|SetPropertyMenu|)) (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu) il:|SetPropertyMenu|) (t (il:setq il:|SetPropertyMenu| (il:|create| il:menu il:items il:_ '((set 'set "Allows a new value to be entered" ))))))) (set ;; The user want to set the value (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name window)) il:newvalue il:pwindow) (il:ttydisplaystream (il:setq il:pwindow (il:getpromptwindow window 3))) (il:clearbuf t t) (il:resetlst (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window) (list 'il:\\itemw.flipitem il:oldvalueitem window)) (il:resetsave (il:tty.process (il:this.process))) (il:resetsave (il:printlevel 4 3)) (il:|printout| t "Enter the new " slot-name " for " x t "The expression read will be EVALuated." t "> ") (il:setq il:newvalue (il:lispx (il:lispxread t t) '>)) ; clear tty buffer because it ; sometimes has stuff left. (il:clearbuf t t)) (il:closew il:pwindow) (return (il:inspectw.replace window slot-name il:newvalue))))))) (defmethod inspect-title (x window) "Return the title to use in an inspect window viewing x" (format nil "Inspecting a ~A" (class-name (class-of x)))) (defmethod inspect-title ((x standard-class) window) (format nil "Inspecting the class ~A" (class-name x))) ;;; Debugger support for PCL (il:filesload pcl-env-internal) ;; Non-PCL specific changes to the debugger ;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be ;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP ;; property. (dolist (fn '(si::*unwind-protect* il:*env* evalhook xcl::nohook xcl::undohook xcl::execa0001 xcl::execa0001a0002 xcl::|interpret-UNDOABLY| cl::|interpret-IF| cl::|interpret-FLET| cl::|interpret-LET| cl::|interpret-LETA0001| cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001| il:do-event il:eval-input apply t)) (setf (get fn 'xcl::uninterestingp) t)) (defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg) "Return TRUE iff the frame should be visible for a short backtrace." (declare (special il:openfns)) (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos))) (typecase xcl::name (symbol (case xcl::name (il:*env* ;; *ENV* is used by ENVEVAL etc. nil) (il:errorset (or (<= (il:stknargs xcl::pos) 1) (not (eq (il:stkarg 2 xcl::pos nil) 'il:internal)))) (il:eval (or (<= (il:stknargs xcl::pos) 1) (not (eq (il:stkarg 2 xcl::pos nil) 'xcl::internal)))) (il:apply (or (<= (il:stknargs xcl::pos) 2) (not (il:stkarg 3 xcl::pos nil)))) (otherwise (cond ((get xcl::name 'xcl::uninterestingp) ;; Explicitly declared uninteresting. nil) ((eq (il:chcon1 xcl::name) (char-code #\\)) ;; Implicitly declared uninteresting by starting the ;; name with a "\". nil) ((or (member xcl::name il:openfns :test #'eq) (eq xcl::name 'funcall)) ;;The function won't be seen when compiled, so only show ;;it if INTERPFLG it true xcl::interpflg) (t ;; Interesting by default. t))))) (cons (case (car xcl::name) (:broken t) (otherwise nil))) (otherwise nil)))) (setq il:*short-backtrace-filter* 'xcl::interesting-frame-p) (eval-when (eval compile) (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))) ;; Change the frame inspector to open up lexical environments ;; Since the DEFSTRUCT is going to build the accessors in the package that is ;; current at read-time, and we want the accessors to reside in the IL ;; package, we have got to make sure that the defstruct happens when the ;; package is IL. (in-package "IL") (cl:defstruct (frame-prop-name (:type cl:list)) (label-fn 'nill) (value-fn (function (lambda (prop-name framespec) (frame-prop-name-data prop-name)))) (setf-fn 'nill) (inspect-fn (function (lambda (value prop-name framespec window) (default.inspectw.valuecommandfn value prop-name (car framespec) window)))) (data nil)) (cl:in-package "PCL") (defun il:debugger-stack-frame-prop-names (il:framespec) ;; Frame prop-names are structures of the form ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA) (let ((il:pos (car il:framespec)) (il:backtrace-item (cadr il:framespec))) (il:if (eq 'eval (il:stkname il:pos)) il:then (let ((il:expression (il:stkarg 1 il:pos)) (il:environment (il:stkarg 2 il:pos))) `(,(il:make-frame-prop-name :inspect-fn (il:function (il:lambda (il:value il:prop-name il:framespec il:window) (il:inspect/as/function il:value (car il:framespec) il:window))) :data il:expression) ,(il:make-frame-prop-name :data "ENVIRONMENT") ,@(il:for il:aspect il:in `((,(and il:environment (il:environment-vars il:environment)) "vars") (,(and il:environment (il:environment-functions il:environment)) "functions") (,(and il:environment (il:environment-blocks il:environment)) "blocks") (,(and il:environment (il:environment-tagbodies il:environment)) "tag bodies")) il:bind il:group-name il:p-list il:eachtime (il:setq il:group-name (cadr il:aspect)) (il:setq il:p-list (car il:aspect)) il:when (not (null il:p-list)) il:join `(,(il:make-frame-prop-name :data il:group-name) ,@(il:for il:p il:on il:p-list il:by cddr il:collect (il:make-frame-prop-name :label-fn (il:function (il:lambda (il:prop-name il:framespec) (car (il:frame-prop-name-data il:prop-name)))) :value-fn (il:function (il:lambda (il:prop-name il:framespec) (cadr (il:frame-prop-name-data il:prop-name)))) :setf-fn (il:function (il:lambda (il:prop-name il:framespec il:new-value) (il:change (cadr (il:frame-prop-name-data il:prop-name)) il:new-value))) :data il:p)))))) il:else (flet ((il:build-name (&key il:arg-name il:arg-number) (il:make-frame-prop-name :label-fn (il:function (il:lambda (il:prop-name il:framespec) (car (il:frame-prop-name-data il:prop-name)))) :value-fn (il:function (il:lambda (il:prop-name il:framespec) (il:stkarg (cadr (il:frame-prop-name-data il:prop-name)) (car il:framespec)))) :setf-fn (il:function (il:lambda (il:prop-name il:framespec il:new-value) (il:setstkarg (cadr (il:frame-prop-name-data il:prop-name)) (car il:framespec) il:new-value))) :data (list il:arg-name il:arg-number)))) (let ((il:nargs (il:stknargs il:pos t)) (il:nargs1 (il:stknargs il:pos)) (il:fnname (il:stkname il:pos)) il:argname (il:arglist)) (and (il:litatom il:fnname) (il:ccodep il:fnname) (il:setq il:arglist (il:listp (il:smartarglist il:fnname)))) `(,(il:make-frame-prop-name :inspect-fn (il:function (il:lambda (il:value il:prop-name il:framespec il:window) (il:inspect/as/function il:value (car il:framespec) il:window))) :data (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item)) ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist)) lambda-list-keywords) il:do (il:setq il:mode il:argname)) (il:build-name :arg-name (or (il:stkargname il:i il:pos) ; special (if (case il:mode ((nil &optional) il:argname) (t nil)) (string il:argname) (il:concat "arg " (- il:i 1)))) :arg-number il:i))) ,@(let* ((il:novalue "No value") (il:slots (il:for il:pvar il:from 0 il:as il:i il:from (il:add1 il:nargs1) il:to il:nargs il:by 1 il:when (and (il:neq il:novalue (il:stkarg il:i il:pos il:novalue)) (or (il:setq il:argname (il:stkargname il:i il:pos)) (il:setq il:argname (il:concat "local " il:pvar))) ) il:collect (il:build-name :arg-name il:argname :arg-number il:i)))) (and il:slots (cons (il:make-frame-prop-name :data "locals") il:slots))))))))) (defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name) (il:apply* (il:frame-prop-name-value-fn il:prop-name) il:prop-name il:framespec)) (defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue) (il:apply* (il:frame-prop-name-setf-fn il:prop-name) il:prop-name il:framespec il:newvalue)) (defun il:debugger-stack-frame-value-command (il:datum il:prop-name il:framespec il:window) (il:apply* (il:frame-prop-name-inspect-fn il:prop-name) il:datum il:prop-name il:framespec il:window)) (defun il:debugger-stack-frame-title (il:framespec &optional il:window) (declare (ignore il:window)) (il:concat (il:stkname (car il:framespec)) " Frame")) (defun il:debugger-stack-frame-property (il:prop-name il:framespec) (il:apply* (il:frame-prop-name-label-fn il:prop-name) il:prop-name il:framespec)) ;; Teaching the debugger that there are other file-manager types that can ;; appear on the stack (defvar xcl::*function-types* '(il:fns il:functions) "Manager types that can appear on the stack") ;; Redefine a couple of system functions to use the above stuff #+Xerox-Lyric (progn (defun il:attach-backtrace-menu (&optional (il:ttywindow (il:wfromds (il:ttydisplaystream))) il:skip) (let ((il:bkmenu (il:|create| il:menu il:items il:_ (il:collect-backtrace-items il:ttywindow il:skip) il:whenselectedfn il:_ (il:function il:backtrace-item-selected) il:whenheldfn il:_ #'(il:lambda (il:item il:menu il:button) (declare (ignore il:item il:menu)) (case il:button (il:left (il:promptprint "Open a frame inspector on this stack frame" )) (il:middle (il:promptprint "Inspect/Edit this function")) )) il:menuoutlinesize il:_ 0 il:menufont il:_ il:backtracefont il:menucolumns il:_ 1)) (il:ttyregion (il:windowprop il:ttywindow 'il:region)) il:btw) (cond ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow) il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu)) (eql (il:|fetch| (il:menu il:whenselectedfn) il:|of| (car il:btw)) (il:function il:backtrace-item-selected))) il:|do| (return il:atw))) (il:deletemenu (car (il:windowprop il:btw 'il:menu)) nil il:btw) (il:windowprop il:btw 'il:extent nil) (il:clearw il:btw)) ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region) (il:widthifwindow (il:imin (il:|fetch| (il:menu il:imagewidth ) il:|of| il:bkmenu) il:|MaxBkMenuWidth|)) (il:|fetch| (il:region il:height) il:|of| il:ttyregion ) 'il:left))) (il:attachwindow il:btw il:ttywindow (cond ((il:igreaterp (il:|fetch| (il:region il:left) il:|of| (il:windowprop il:btw 'il:region)) (il:|fetch| (il:region il:left) il:|of| il:ttyregion)) 'il:right) (t 'il:left)) nil 'il:localclose) (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process)) )) (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position il:xcoord il:_ 0 il:ycoord il:_ (il:idifference (il:windowprop il:btw 'il:height) (il:|fetch| (il:menu il:imageheight ) il:|of| il:bkmenu )))))) (defun il:backtrace-item-selected (il:item il:menu il:button) (il:resetlst (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item) )) (cond ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu)) (il:menudeselect il:olditem il:menu) )) (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu) 'il:mainwindow)) (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position)) (il:setq il:pos (il:stknth (- il:framespecn) il:bkpos)) (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos))) (and il:lp (il:stknth 0 il:pos il:lp))) (il:menuselect il:item il:menu) (if (eq il:button 'il:middle) (progn (il:resetsave nil (list 'il:relstk il:pos)) (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name) il:|of| il:item) il:pos il:ttywindow)) (progn (il:setq il:framewindow (xcl:with-profile (il:process.eval (il:windowprop il:ttywindow 'il:process) '(let ((il:profile (xcl:copy-profile (xcl:find-profile "READ-PRINT")))) (setf (xcl::profile-entry-value ' xcl:*eval-function* il:profile) xcl:*eval-function*) (xcl:save-profile il:profile)) t) (il:inspectw.create (list il:pos il:item) 'il:debugger-stack-frame-prop-names 'il:debugger-stack-frame-fetchfn 'il:debugger-stack-frame-storefn nil ' il:debugger-stack-frame-value-command nil ' il:debugger-stack-frame-title nil ( il:make-frame-inspect-window il:ttywindow) 'il:debugger-stack-frame-property))) (cond ((not (il:windowprop il:framewindow 'il:mainwindow)) (il:attachwindow il:framewindow il:ttywindow (cond ((il:igreaterp (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop il:framewindow 'il:region)) (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop il:ttywindow 'il:region))) 'il:top) (t 'il:bottom)) nil 'il:localclose) (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow )))))) (return)))) (defun il:collect-backtrace-items (xcl::tty-window xcl::skip) (let* ((xcl::items (cons nil nil)) (xcl::items-tail xcl::items)) (macrolet ((xcl::collect-item (xcl::new-item) `(progn (setf (rest xcl::items-tail) (cons ,xcl::new-item nil)) (pop xcl::items-tail)))) (let* ((xcl::filter-fn (cond ((null xcl::skip) #'xcl:true) ((eq xcl::skip t) il:*short-backtrace-filter*) (t xcl::skip))) (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window ' il:stack-position))) (xcl::next-frame xcl::top-frame) (xcl::frame-number 0) xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) (loop (when (null xcl::next-frame) (return)) (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) (funcall xcl::filter-fn xcl::next-frame)) (when (null xcl::last-frame-consumed) (setf xcl::last-frame-consumed xcl::next-frame)) (when xcl::interesting-p (when (null xcl::use-frame) (setf xcl::use-frame xcl::last-frame-consumed)) (when (null xcl::label) (setf xcl::label (il:stkname xcl::use-frame)) (if (member xcl::label '(eval il:eval il:apply apply) :test 'eq) (setf xcl::label (il:stkarg 1 xcl::use-frame)))) (loop (cond ((not (typep xcl::next-frame 'il:stackp)) (error "~%Use-frame ~S not found" xcl::use-frame)) ((xcl::stack-eql xcl::next-frame xcl::use-frame) (return)) (t (incf xcl::frame-number) (setf xcl::next-frame (il:stknth -1 xcl::next-frame xcl::next-frame))))) (xcl::collect-item (il:|create| il:bkmenuitem il:label il:_ (let ((*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (prin1-to-string xcl::label)) il:bkmenuinfo il:_ xcl::frame-number il:frame-name il:_ xcl::label))) (loop (cond ((not (typep xcl::next-frame 'il:stackp)) (error "~%Last-frame-consumed ~S not found" xcl::last-frame-consumed)) ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed ) (incf xcl::frame-number) (setf xcl::next-frame (il:stknth -1 xcl::next-frame xcl::next-frame))) (return))))))) (rest xcl::items))) ) #+Xerox-Medley (progn (defun dbg::attach-backtrace-menu (&optional tty-window skip) (declare (special il:\\term.ofd il:backtracefont)) (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream)))) (prog (btw bkmenu (tty-region (il:windowprop tty-window 'il:region)) ;; And, for the FORMAT below... (*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (setq bkmenu (il:|create| il:menu il:items il:_ (dbg::collect-backtrace-items tty-window skip) il:whenselectedfn il:_ 'dbg::backtrace-item-selected il:menuoutlinesize il:_ 0 il:menufont il:_ il:backtracefont il:menucolumns il:_ 1 il:whenheldfn il:_ #'(il:lambda (item menu button) (declare (ignore item menu)) (case button (il:left (il:promptprint "Open a frame inspector on this stack frame")) (il:middle (il:promptprint "Inspect/Edit this function")))))) (cond ((setq btw (dolist (atw (il:attachedwindows tty-window)) ;; Test for an attached window that has a backtrace menu in ;; it. (when (and (setq btw (il:windowprop atw 'il:menu)) (eq (il:|fetch| (il:menu il:whenselectedfn) il:|of| (car btw)) 'dbg::backtrace-item-selected)) (return atw)))) ;; If there is alread a backtrace window, delete the old menu from ;; it. (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw) (il:windowprop btw 'il:extent nil) (il:clearw btw)) ((setq btw (il:createw (dbg::region-next-to (il:windowprop tty-window 'il:region) (il:widthifwindow (il:imin (il:|fetch| (il:menu il:imagewidth) il:|of| bkmenu) il:|MaxBkMenuWidth|)) (il:|fetch| (il:region il:height) il:|of| tty-region) :left))) ; put bt window at left of TTY ; window unless ttywindow is ; near left edge. (il:attachwindow btw tty-window (if (il:igreaterp (il:|fetch| (il:region il:left) il:|of| (il:windowprop btw 'il:region)) (il:|fetch| (il:region il:left) il:|of| tty-region)) 'il:right 'il:left) nil 'il:localclose) ;; So that button clicks will switch the TTY (il:windowprop btw 'il:process (il:windowprop tty-window 'il:process)))) (il:addmenu bkmenu btw (il:|create| il:position il:xcoord il:_ 0 il:ycoord il:_ (- (il:windowprop btw 'il:height) (il:|fetch| (il:menu il:imageheight) il:|of| bkmenu)))) ;; IL:ADDMENU sets up buttoneventfn for window that we don't ;; want. We want to catch middle button events before the menu ;; handler, so that we can pop up edit/inspect menu for the frame ;; currently selected. So replace the buttoneventfn, and can ;; nuke the cursorin and cursormoved guys, cause don't need them. (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn) (il:windowprop btw 'il:cursorinfn nil) (il:windowprop btw 'il:cursormovedfn nil))) (defun dbg::collect-backtrace-items (tty-window skip) (xcl:with-collection ;; ;; There are a number of possibilities for the values returned by the ;; filter-fn. ;; ;; (1) INTERESTING-P is false, and the other values are all NIL. This ;; is the simple case where the stack frame NEXT-POS should be ignored ;; completly, and processing should continue with the next frame. ;; ;; (2) INTERESTING-P is true, and the other values are all NIL. This ;; is the simple case where the stack frame NEXT-POS should appear in ;; the backtrace as is, and processing should continue with the next ;; frame. ;; ;; [Note that these two cases take care of old values of the ;; filter-fn.] ;; ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack ;; frame. In that case, ignore all stack frames from NEXT-POS to ;; LAST-FRAME-CONSUMED, inclusive. ;; ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack ;; frame. In this case, the backtrace should include a single entry ;; coresponding to the frame USE-FRAME (which defaults to ;; LAST-FRAME-CONSUMED), and processing should continue with the next ;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be ;; the label that appears in the backtrace menu; otherwise the name of ;; USE-FRAME will be used (or the form being EVALed if the frame is an ;; EVAL frame). ;; (let* ((filter (cond ((null skip) #'xcl:true) ((eq skip t) il:*short-backtrace-filter*) (t skip))) (top-frame (il:stknth 0 (il:getwindowprop tty-window 'dbg::stack-position))) (next-frame top-frame) (frame-number 0) interestingp last-frame-consumed frame-to-use label-to-use) (loop (when (null next-frame) (return)) ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED, ;; FRAME-TO-USE, and LABEL-TO-USE (multiple-value-setq (interestingp last-frame-consumed frame-to-use label-to-use) (funcall filter next-frame)) (when (null last-frame-consumed) (setf last-frame-consumed next-frame)) (when interestingp (when (null frame-to-use) (setf frame-to-use last-frame-consumed)) (when (null label-to-use) (setf label-to-use (il:stkname frame-to-use)) (if (member label-to-use '(eval il:eval il:apply apply) :test 'eq) (setf label-to-use (il:stkarg 1 frame-to-use)))) ;; Walk the stack until we find the frame to use (loop (cond ((not (typep next-frame 'il:stackp)) (error "~%Use-frame ~S not found" frame-to-use)) ((xcl::stack-eql next-frame frame-to-use) (return)) (t (incf frame-number) (setf next-frame (il:stknth -1 next-frame next-frame))))) ;; Add the menu item to the list under construction (xcl:collect (il:|create| il:bkmenuitem il:label il:_ (let ((*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (prin1-to-string label-to-use)) il:bkmenuinfo il:_ frame-number il:frame-name il:_ label-to-use))) ;; Update NEXT-POS (loop (cond ((not (typep next-frame 'il:stackp)) (error "~%Last-frame-consumed ~S not found" last-frame-consumed)) ((prog1 (xcl::stack-eql next-frame last-frame-consumed) (incf frame-number) (setf next-frame (il:stknth -1 next-frame next-frame))) (return)))))))) (defun dbg::backtrace-menu-buttoneventfn (window &aux menu) (setq menu (car (il:listp (il:windowprop window 'il:menu)))) (unless (or (il:lastmousestate il:up) (null menu)) (il:totopw window) (cond ((il:lastmousestate il:middle) ;; look for a selected frame in this menu, and then pop up ;; the editor invoke menu for that frame. don't change the ;; selection, just present the edit menu. (let* ((selection (il:menu.handler menu (il:windowprop window 'il:dsp))) (tty-window (il:windowprop window 'il:mainwindow)) (last-pos (il:windowprop tty-window 'dbg::lastpos))) ;; don't have to worry about releasing POS because we ;; only look at it here (nobody here hangs on to it) ;; and we will be around for less time than LASTPOS. ;; The debugger is responsible for releasing LASTPOS. (il:inspect/as/function (cond ((and selection (il:|fetch| (il:bkmenuitem il:frame-name) il:|of| (car selection)))) ((and (symbolp (il:stkname last-pos)) (il:getd (il:stkname last-pos))) (il:stkname last-pos)) (t 'il:nill)) last-pos tty-window))) (t (let ((selection (il:menu.handler menu (il:windowprop window 'il:dsp)))) (when selection (il:doselecteditem menu (car selection) (cdr selection)))))))) ;; This function isn't really redefined, but it needs to be recomiled since we ;; changed the def'n of the BKMENUITEM record. (defun dbg::backtrace-item-selected (item menu button) ;;When a frame name is selected in the backtrace menu, this is the function ;;that gets called. (declare (special il:brkenv) (ignore button)) (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item)) (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow)) (bkpos (il:windowprop tty-window 'dbg::stack-position)) (pos (il:stknth (- frame-spec) bkpos))) (let ((lp (il:windowprop tty-window 'dbg::lastpos))) (and lp (il:stknth 0 pos lp))) ;; change the item selected from OLDITEM to ITEM. Only do this on left ;; buttons now. Middle just pops up the edit menu, doesn't select. -woz (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu))) (when old-item (il:menudeselect old-item menu)) (il:menuselect item menu)) ;; Change the lexical environment so it is the one in effect as of this ;; frame. (il:process.eval (il:windowprop tty-window (quote dbg::process)) `(setq il:brkenv ',(il:find-lexical-environment pos)) t) (let ((frame-window (xcl:with-profile (il:process.eval (il:windowprop tty-window 'il:process) `(let ((profile (xcl:copy-profile (xcl:find-profile "READ-PRINT")))) (setf (xcl::profile-entry-value 'xcl:*eval-function* profile) xcl:*eval-function*) (xcl:save-profile profile)) t) (il:inspectw.create pos #'(lambda (pos) (dbg::stack-frame-properties pos t)) 'dbg::stack-frame-fetchfn 'dbg::stack-frame-storefn nil 'dbg::stack-frame-value-command nil (format nil "~S Frame" (il:stkname pos)) nil (dbg::make-frame-inspect-window tty-window) 'dbg::stack-frame-property)))) (when (not (il:windowprop frame-window 'il:mainwindow)) (il:attachwindow frame-window tty-window (if (> (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop frame-window 'il:region)) (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop tty-window 'il:region))) 'il:top 'il:bottom) nil 'il:localclose) (il:windowaddprop frame-window 'il:closefn 'il:detachwindow))))) ) ;end of Xerox-Medley (defun il:select.fns.editor (&optional function) ;; gives the user a menu choice of editors. (il:menu (il:|create| il:menu il:items il:_ (cond ((il:ccodep function) '((il:|InspectCode| 'il:inspectcode "Shows the compiled code.") (il:|DisplayEdit| 'ed "Edit it with the display editor") (il:|TtyEdit| 'il:ef "Edit it with the standard editor"))) ((il:closure-p function) '((il:|Inspect| 'inspect "Inspect this object"))) (t '((il:|DisplayEdit| 'ed "Edit it with the display editor") (il:|TtyEdit| 'il:ef "Edit it with the standard editor")))) il:centerflg il:_ t))) ;; ;; PCL specific extensions to the debugger ;; There are some new things that act as functions, and that we want to be ;; able to edit from a backtrace window (pushnew 'methods xcl::*function-types*) (eval-when (eval compile load) (unless (generic-function-p (symbol-function 'il:inspect/as/function)) (make-specializable 'il:inspect/as/function))) (defmethod il:inspect/as/function (name stack-pointer debugger-window) ;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer ;; and window of the break in which this inspect command was called. (declare (ignore debugger-window)) (let ((editor (il:select.fns.editor name))) (case editor ((nil) ;; No editor chosen, so don't do anything nil) (il:inspectcode ;; Inspect the compiled code (let ((frame (xcl::stack-pointer-frame stack-pointer))) (if (and (il:stackp stack-pointer) (xcl::stack-frame-valid-p frame)) (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame))) (cond ((eq (il:\\get-compiled-code-base name) code-base) name) (t ;; Function executing in this frame is not ;; the one in the definition cell of its ;; name, so fetch the real code. Have to ;; pass a CCODEP (il:make-compiled-closure code-base)))) nil nil nil (xcl::stack-frame-pc frame)) (il:inspectcode name)))) (ed ;; Use the standard editor. ;; This used to take care to apply the editor in the debugger ;; process, so forms evaluated in the editor happen in the ;; context of the break. But that doesn't count for much any ;; more, now that lexical variables are the way to go. Better to ;; use the LEX debugger command (thank you, Herbie) and ;; shift-select pieces of code from the editor into the debugger ;; window. (ed name `(,@xcl::*function-types* :display))) (otherwise (funcall editor name))))) (defmethod il:inspect/as/function ((name standard-object) stkp window) (when (il:menu (il:|create| il:menu il:items il:_ '(("Inspect" t "Inspect this object")))) (inspect name))) (defmethod il:inspect/as/function ((x standard-method) stkp window) (let* ((generic-function-name (slot-value (slot-value x 'generic-function) 'name)) (method-name (full-method-name x)) (editor (il:select.fns.editor method-name))) (il:allow.button.events) (case editor (ed (ed method-name '(:display methods))) (il:inspectcode (il:inspectcode (slot-value x 'function))) ((nil) nil) (otherwise (funcall editor method-name))))) ;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods ;; and generic-functions on the stack. (defun interesting-frame-p (stack-pos &optional interp-flag) ;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and ;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description ;; of how these values are used. (labels ((function-matches-frame-p (function frame) "Is the function being called in this frame?" (let* ((frame-name (il:stkname frame)) (code-being-run (cond ((typep frame-name 'il:closure) frame-name) ((and (consp frame-name) (eq 'il:\\interpreter (xcl::stack-frame-name (il:\\stackargptr frame)))) frame-name) (t (xcl::stack-frame-fn-header (il:\\stackargptr frame)))))) (or (eq function code-being-run) (and (typep function 'il:compiled-closure) (eq (xcl::compiled-closure-fnheader function) code-being-run))))) (generic-function-from-frame (frame) "If this the frame of a generic function return the gf, otherwise return NIL." ;; Generic functions are implemented as compiled closures. On the ;; stack, we only see the fnheader for the the closure. This could ;; be a discriminator code, or in the default method only case it ;; will be the actual method function. To tell if this is a generic ;; function frame, we have to check very carefully to see if the ;; right stuff is on the stack. Specifically, the closure's ccode, ;; and the first local variable has to be a ptrhunk big enough to be ;; a FIN environment, and fin-env-fin of that ptrhunk has to point ;; to a generic function whose ccode and environment match. (let ((n-args (il:stknargs frame)) (env nil) (gf nil)) (if (and ;; is there at least one local? (> (il:stknargs frame t) n-args) ;; and does the local contain something that might be ;; the closure environment of a funcallable instance? (setf env (il:stkarg (1+ n-args) frame)) ;; and does the local contain something that might be ;; the closure environment of a funcallable instance? (typep env *fin-env-type*) (setf gf (fin-env-fin env)) ;; whose fin-env-fin points to a generic function? (generic-function-p gf) ;; whose environment is the same as env? (eq (xcl::compiled-closure-env gf) env) ;; and whose code is the same as the code for this ;; frame? (function-matches-frame-p gf frame)) gf nil)))) (let ((frame-name (il:stkname stack-pos))) ;; See if there is a generic-function on the stack at this ;; location. (let ((gf (generic-function-from-frame stack-pos))) (when gf (return-from interesting-frame-p (values t stack-pos stack-pos gf)))) ;; See if this is an interpreted method. The method body is ;; wrapped in a (BLOCK ...). We look for an ;; interpreted call to BLOCK whose block-name is the name of ;; generic-function. (when (and (eq frame-name 'eval) (consp (il:stkarg 1 stack-pos)) (eq (first (il:stkarg 1 stack-pos)) 'block) (symbolp (second (il:stkarg 1 stack-pos))) (fboundp (second (il:stkarg 1 stack-pos))) (generic-function-p (symbol-function (second (il:stkarg 1 stack-pos))))) (let* ((form (il:stkarg 1 stack-pos)) (block-name (second form)) (generic-function (symbol-function block-name)) (methods (generic-function-methods (symbol-function block-name)))) ;; If this is really a method being called from a ;; generic-function, the g-f should be no more than a ;; few(?) frames up the stack. Check for the method call ;; by looking for a call to APPLY, where the function ;; being applied is the code in one of the methods. (do ((i 100 (1- i)) (previous-pos stack-pos current-pos) (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) (found-method nil) (method-pos)) ((or (null current-pos) (<= i 0)) nil) (cond ((equalp generic-function (generic-function-from-frame current-pos)) (if found-method (return-from interesting-frame-p (values t previous-pos method-pos found-method)) (return))) (found-method nil) ((eq (il:stkname current-pos) 'apply) (dolist (method methods) (when (eq (method-function method) (il:stkarg 1 current-pos)) (setq method-pos current-pos) (setq found-method method) (return)))))))) ;; Try to handle compiled methods (when (and (symbolp frame-name) (not (fboundp frame-name)) (eq (il:chcon1 frame-name) (il:charcode il:\()) (or (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 13) (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 12) (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 8))) ;; Looks like a name that PCL consed up. See if there is a ;; GF nearby up the stack. If there is, use it to help ;; determine which method we have. (do ((i 30 (1- i)) (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) (gf)) ((or (null current-pos) (<= i 0)) nil) (setq gf (generic-function-from-frame current-pos)) (when gf (dolist (method (generic-function-methods gf)) (when (function-matches-frame-p (method-function method) stack-pos) (return-from interesting-frame-p (values t stack-pos stack-pos method)))) (return)))) ;; If we haven't already returned, use the default method. (xcl::interesting-frame-p stack-pos interp-flag)))) (setq il:*short-backtrace-filter* 'interesting-frame-p) ;;; Support for undo (defun undoable-setf-slot-value (object slot-name new-value) (if (slot-boundp object slot-name) (il:undosave (list 'undoable-setf-slot-value object slot-name (slot-value object slot-name))) (il:undosave (list 'slot-makunbound object slot-name))) (setf (slot-value object slot-name) new-value)) (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value) ;;; Support for ?= and friends ;; The arglists for generic-functions are built using gensyms, and don't reflect ;; any keywords (they are all included in an &REST arg). Rather then use the ;; arglist in the code, we use the one that PCL kindly keeps in the generic-function. (xcl:advise-function 'il:smartarglist '(if (and il:explainflg (symbolp il:fn) (fboundp il:fn) (generic-function-p (symbol-function il:fn))) (generic-function-pretty-arglist (symbol-function il:fn)) (xcl:inner)) :when :around :priority :last) (setf (get 'defclass 'il:argnames) '(nil (class-name (#\{ superclass-name #\} #\*) (#\{ slot-specifier #\} #\*) #\{ slot-option #\} #\*))) (setf (get 'defmethod 'il:argnames) '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\* specialized-lambda-list #\{ declaration #\| doc-string #\} #\* #\{ form #\} #\*))) ;;; Prettyprinting support, the result of Harley Davis. ;; Support the standard Prettyprinter. This is really minimal right now. If ;; anybody wants to fix this, I'd be happy to include their code. In fact, ;; there is almost no support for Commonlisp in the standard Prettyprinter, so ;; the field is wide open to hackers with time on their hands. (setf (get 'defmethod :definition-print-template) ;Not quite right, since it '(:name :arglist :body)) ; doesn't handle qualifiers, ; but it will have to do. (defun defclass-prettyprint (form) (let ((left (il:dspxposition)) (char-width (il:charwidth (il:charcode x) *standard-output*))) (xcl:destructuring-bind (defclass name supers slots . options) form (princ "(") (prin1 defclass) (princ " ") (prin1 name) (princ " ") (if (null supers) (princ "()") ;Print "()" instead of "nil" (il:sequential.prettyprint (list supers) (il:dspxposition))) (if (null slots) (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*) (princ "()")) (il:sequential.prettyprint (list slots) (+ left (* 4 char-width)))) (when options (il:sequential.prettyprint options (+ left (* 2 char-width)))) (princ ")") nil))) (let ((pprint-macro (assoc 'defclass il:prettyprintmacros))) (if (null pprint-macro) (push (cons 'defclass 'defclass-prettyprint) il:prettyprintmacros) (setf (cdr pprint-macro) 'defclass-prettyprint))) (defun binder-prettyprint (form) ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS ;; that are of the form (fn (var ...) form &rest body). ;; This code is far from correct, but it's better than nothing. (if (and (consp form) (not (null (cdddr form)))) ;; I have no idea what I'm doing here. Seems I can copy and edit somebody ;; elses code without understanding it. (let ((body-indent (+ (il:dspxposition) (* 2 (il:charwidth (il:charcode x) *standard-output*)))) (form-indent (+ (il:dspxposition) (* 4 (il:charwidth (il:charcode x) *standard-output*))))) (princ "(") (prin1 (first form)) (princ " ") (il:superprint (second form) form nil *standard-output*) (il:sequential.prettyprint (list (third form)) form-indent) (il:sequential.prettyprint (cdddr form) body-indent) (princ ")") nil) ;Return NIL to indicate that we did ; the printing t)) ;Return true to use default printing (dolist (fn '(multiple-value-bind with-accessors with-slots)) (let ((pprint-macro (assoc fn 'il:prettyprintmacros))) (if (null pprint-macro) (push (cons fn 'binder-prettyprint) il:prettyprintmacros) (setf (cdr pprint-macro) 'binder-prettyprint)))) ;; SEdit has its own prettyprinter, so we need to support that too. This is due ;; to Harley Davis. Really. (push (cons :slot-spec '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0) (sedit::set-indent . 1) (sedit::next-inline? 1 break sedit::from-indent . 1) (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0)) ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0) (sedit::set-indent . 1) (sedit::next-inline? 1 break sedit::from-indent . 1) (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0)))) sedit:*indent-alist*) (setf (sedit:get-format :slot-spec) '(:indent :slot-spec :inline t)) (setf (sedit:get-format :slot-spec-list) '(:indent :binding-list :args (:slot-spec) :inline nil)) (setf (sedit:get-format 'defclass) '(:indent ((2) 1) :args (:keyword nil nil :slot-spec-list nil) :sublists (4))) (setf (sedit:get-format 'defmethod) '(:indent ((2)) :args (:keyword nil :lambda-list nil) :sublists (3))) (setf (sedit:get-format 'defgeneric) 'defun) (setf (sedit:get-format 'generic-flet) 'flet) (setf (sedit:get-format 'generic-labels) 'flet) (setf (sedit:get-format 'call-next-method) '(:indent (1) :args (:keyword nil))) (setf (sedit:get-format 'symbol-macrolet) 'let) (setf (sedit:get-format 'with-accessors) '(:indent ((1) 1) :args (:keyword :binding-list nil) :sublists (2) :miser :never)) (setf (sedit:get-format 'with-slots) 'with-accessors) (setf (sedit:get-format 'make-instance) '(:indent ((1)) :args (:keyword nil :slot-spec-list))) (setf (sedit:get-format '*make-instance) 'make-instance) ;;; PrettyFileIndex stuff, the product of Harley Davis. (defvar *pfi-class-type* '(class defclass pfi-class-namer)) (defvar *pfi-method-type* '(method defmethod pfi-method-namer) "Handles method for prettyfileindex") (defvar *pfi-index-accessors* nil "t -> each slot accessor gets a listing in the index.") (defvar *pfi-method-index* :group ":group, :separate, :both, or nil") (defun pfi-add-class-type () (pushnew *pfi-class-type* il:*pfi-types*)) (defun pfi-add-method-type () (pushnew *pfi-method-type* il:*pfi-types*)) (defun pfi-class-namer (expression entry) (let ((class-name (second expression))) ;; Following adds all slot readers/writers/accessors as separate entries in ;; the index. Probably a mistake. (if *pfi-index-accessors* (let ((slot-list (fourth expression)) (accessor-names nil)) (labels ((add-accessor (method-index name-index) (push (case *pfi-method-index* (:group method-index) (:separate name-index) ((t :both) (list method-index name-index)) ((nil) nil) (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))) accessor-names)) (add-reader (reader-name) (add-accessor `(method (,reader-name (,class-name))) `(,reader-name (,class-name)))) (add-writer (writer-name) (add-accessor `(method ((setf ,writer-name) (t ,class-name))) `((setf ,writer-name) (t ,class-name))))) (dolist (slot-def slot-list) (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args)) (slot-arg (first rest-slot-args) (first rest-slot-args))) ((null rest-slot-args)) (case slot-arg (:reader (add-reader (second rest-slot-args))) (:writer (add-writer (second rest-slot-args))) (:accessor (add-reader (second rest-slot-args)) (add-writer (second rest-slot-args))) (otherwise nil)))) (cons `(class (,class-name)) accessor-names))) class-name))) (defun pfi-method-namer (expression entry) (let ((method-name (second expression)) (specializers nil) (qualifiers nil) lambda-list) (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers)) (qualifier (first rest-qualifiers) (first rest-qualifiers))) ((listp qualifier) (setq lambda-list qualifier) (setq qualifiers (reverse qualifiers)) qualifiers) (push qualifier qualifiers)) (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list)) (arg (first rest-lambda-list) (first rest-lambda-list))) ((or (member arg lambda-list-keywords) (null rest-lambda-list)) (setq specializers (reverse specializers))) (push (if (listp arg) (second arg) t) specializers)) (let ((method-index `(method (,method-name ,@qualifiers ,specializers))) (name-index `(,method-name ,@qualifiers ,specializers))) (case *pfi-method-index* (:group method-index) (:separate name-index) ((t :both) (list method-index name-index)) ((nil) nil) (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*)))))) (defun pfi-install-pcl () (pfi-add-method-type) (pfi-add-class-type)) (eval-when (eval load) (when (boundp (quote il:*pfi-types*)) (pfi-install-pcl)) ) gcl-2.6.14/pcl/impl/xerox/pcl-env.text0000644000175000017500000001061514360276512016134 0ustar cammcammA (very) few words about PCL-ENV. If you require more information, consult the source code. While it is not particularly well documented, it is the final arbiter of truth regarding its own functionality. The file PCL-ENV.LISP defines some low-level facilities to integrate PCL into the XeroxLisp environment. The first order of business is teaching the FileManager (nee FilePackage) about CLOS defineing forms. This in turn brings us to the issue of names. o Names and the FileManager For the FileManager to keep track of defining forms, it needs to know how to extract a (unique) name and FileManager type from the form. PCL-ENV includes FileManager support for the definers DEFCLASS, DEFGENERIC, and DEFMETHOD. DEFCLASS The name of a DEFCLASS form is the name of the class defined by the form. The FileManager type is PCL::CLASSES. There is a FileManager "undefiner" provided for DEFCLASS. DEFGENERIC The name of a DEFGENERIC form is the name of the generic-function defined by the form. The FileManager type is PCL::GENERIC-FUNCTIONS. DEFMETHOD The name of a DEFMETHOD form is a list of the form ( {}* ({*})). The FileManager type is PCL::METHODS. There is a FileManager "undefiner" provided for DEFMETHOD. However, note that if a generic-function was created as a side-effect of the DEFMETHOD, the undefiner will leave the generic-function defined (albet with no methods). When editing, it would be onerous to require the programmer to type in the full name of a method. PCL-ENV arranges it so that (ED ) will ask the programmer which method on that generic-function should be edited. (If there is only one method, it is assumed that that is the method to be edited.) As of the Victoria-Day release, EQL specialized methods are handled correctly. o Inspecting CLOS objects (and metaobjects) PCL-ENV defines a protocol that is used to inspect objects, and arranges that the standard INSPECT function uses this protocol. Programmers can use this protocol by defining additional methods on the following generic-functions. INSPECT-SLOT-NAMES object Returns a list of "slots" to include in the inspector. The default method returns a list of all slots on the object. INSPECT-SLOT-VALUE object slot-name Returns the value to associated with the slot-name in the inspector. Slot-name is one of the items returned by INSPECT-SLOT-NAMES. The default method returns (SLOT-VALUE object slot-name). INSPECT-SETF-SLOT-VALUE object slot-name new-value Sets the value associated with the slot-name in the inspector. Slot-name is one of the items returned by INSPECT-SLOT-NAMES. The default method executes (SETF (SLOT-VALUE object slot-name) new-value). INSPECT-TITLE object inspect-window Returns the title to use in the inspect-window when inspecting object. The default returns the string "Inspecting the class " when the object is a class, or "Inspecting a " otherwise. o Debugging and the Stack Debugging in PCL is complicated by generic-functions and methods appear on the stack not as single objects, but as collections of functions that the programmer did not directly call. PCL-ENV redefines a number of internal debugger functions to simplify the presentation of the stack, and allow the programmer to access to the original defining forms from the stack. These changes only affect the "short" display backtrace (brought up by BT in a break window); the full backtrace (brought up by BT!) is unaffected. o Misc Prettyprinting The support for standard Prettyprinting is pretty minimal. Only DEFMETHOD, DEFCLASS, WITH-ACCESSORS, and WITH-SLOTS are supported, and they aren't really done right. Thanks to Harley Davis, PCL-ENV defines SEdit pretty-print specs for the forms DEFCLASS, DEFMETHOD, DEFGENERIC, GENERIC-FLET, GENERIC-LABELS, CALL-NEXT-METHOD, SYMBOL-MACROLET, WITH-ACCESSORS, WITH-SLOTS, and MAKE-INSTANCE. ?= The function SMARTARGLIST is changed to return appropriate values for the arglists of generic-functions. The macros DEFCLASS and DEFMETHOD have "pretty" arglists defined. PrettyFileIndex Again thanks to Harley Davis, PCL-ENV teaches PRETTY-FILE-INDEX about classes, methods, and accessors. The variables PCL::*PFI-INDEX-ACCESSORS* and PCL::*PFI-METHOD-INDEX* may be changed by the user to tailor the computation of the file index. Note that the file PRETTY-FILE-INDEX must be loaded before PCL-ENV for this to take effect. --- smL 25-May-89 gcl-2.6.14/pcl/impl/xerox/pcl-env-internal.lisp0000644000175000017500000002030114360276512017722 0ustar cammcamm(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL") (il:filecreated "28-Aug-87 18:42:36" il:{phylum}pcl-env-internal.\;1 8356 il:|changes| il:|to:| (il:vars il:pcl-env-internalcoms) (il:props (il:pcl-env-internal il:makefile-environment)) (il:functions stack-eql stack-pointer-frame stack-frame-valid-p stack-frame-fn-header stack-frame-pc fnheader-debugging-info stack-frame-name compiled-closure-fnheader compiled-closure-env) ) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:pcl-env-internalcoms) (il:rpaqq il:pcl-env-internalcoms ( (il:* il:|;;;| "***************************************") (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") (il:* il:|;;;| "") (il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.") (il:* il:|;;;| " ") (il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.") (il:* il:|;;;| " ") (il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:") (il:* il:|;;;| " CommonLoops Coordinator") (il:* il:|;;;| " Xerox Artifical Intelligence Systems") (il:* il:|;;;| " 2400 Hanover St.") (il:* il:|;;;| " Palo Alto, CA 94303") (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") (il:* il:|;;;| "") (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") (il:* il:|;;;| " *************************************************************************") (il:* il:|;;;| "") (il:declare\: il:dontcopy (il:prop il:makefile-environment il:pcl-env-internal)) (il:* il:\; "We're off to hack the system...") (il:declare\: il:eval@compile il:dontcopy (il:files pcl::abc) (il:* il:|;;| "The Deltas and The East and The Freeze") ) (il:functions stack-eql stack-pointer-frame stack-frame-valid-p stack-frame-fn-header stack-frame-pc fnheader-debugging-info stack-frame-name compiled-closure-fnheader compiled-closure-env))) (il:* il:|;;;| "***************************************") (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") (il:* il:|;;;| "") (il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws." ) (il:* il:|;;;| " ") (il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification." ) (il:* il:|;;;| " ") (il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:" ) (il:* il:|;;;| " CommonLoops Coordinator") (il:* il:|;;;| " Xerox Artifical Intelligence Systems") (il:* il:|;;;| " 2400 Hanover St.") (il:* il:|;;;| " Palo Alto, CA 94303") (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") (il:* il:|;;;| "") (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") (il:* il:|;;;| " *************************************************************************") (il:* il:|;;;| "") (il:declare\: il:dontcopy (il:putprops il:pcl-env-internal il:makefile-environment (:package "XCL" :readtable "XCL")) ) (il:* il:\; "We're off to hack the system...") (il:declare\: il:eval@compile il:dontcopy (il:filesload pcl::abc) ) (defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x) (il:stackp y) (eql (il:fetch (il:stackp il:edfxp ) il:of x) (il:fetch (il:stackp il:edfxp ) il:of y)))) (defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer)) (defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame))) (defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame)) (defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame)) (defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc) il:of fnheader)) (name-table-words (let ((size (il:fetch (il:fnheader il:ntsize) il:of fnheader))) (if (zerop size) il:wordsperquad (* size 2)))) (past-name-table-in-words (+ (il:fetch (il:fnheader il:overheadwords ) il:of fnheader) name-table-words))) (and (= (- start-pc (* il:bytesperword past-name-table-in-words)) il:bytespercell) (il:* il:|;;| "It's got a debugging-info list.") (il:\\getbaseptr fnheader past-name-table-in-words)))) (defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame)) (defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of| closure)) (defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure)) (il:putprops il:pcl-env-internal il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop gcl-2.6.14/pcl/impl/xerox/xerox-low.lisp0000644000175000017500000001357414360276512016526 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 1100 (Xerox version) of the file portable-low. ;;; (in-package 'pcl) (defmacro load-time-eval (form) `(il:LOADTIMECONSTANT ,form)) ;;; ;;; make the pointer from an instance to its class wrapper be an xpointer. ;;; this prevents instance creation from spending a lot of time incrementing ;;; the large refcount of the class-wrapper. This is safe because there will ;;; always be some other pointer to the wrapper to keep it around. ;;; #+Xerox-Medley (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor %%allocate-instance--class ()) (:fast-accessors t) (:print-function %print-std-instance)) (wrapper nil :type il:fullxpointer) (slots nil)) #+Xerox-Lyric (eval-when (eval load compile) (il:datatype std-instance ((wrapper il:fullxpointer) slots)) (xcl:definline std-instance-p (x) (typep x 'std-instance)) (xcl:definline %%allocate-instance--class () (il:create std-instance)) (xcl:definline %std-instance-wrapper (x) (il:fetch (std-instance wrapper) il:of x)) (xcl:definline %std-instance-slots (x) (il:fetch (std-instance slots) il:of x)) (xcl:definline set-%std-instance-wrapper (x value) (il:replace (std-instance wrapper) il:of x il:with value)) (xcl:definline set-%std-instance-slots (x value) (il:replace (std-instance slots) il:of x il:with value)) (defsetf %std-instance-wrapper set-%std-instance-wrapper) (defsetf %std-instance-slots set-%std-instance-slots) (il:defprint 'std-instance '%print-std-instance) ) (defun %print-std-instance (instance &optional stream depth) ;; See the IRM, section 25.3.3. Unfortunately, that documentation is ;; not correct. In particular, it makes no mention of the third argument. (cond ((streamp stream) ;; Use the standard PCL printing method, then return T to tell ;; the printer that we have done the printing ourselves. (print-std-instance instance stream depth) t) (t ;; Internal printing (again, see the IRM section 25.3.3). ;; Return a list containing the string of characters that ;; would be printed, if the object were being printed for ;; real. (list (with-output-to-string (stream) (print-std-instance instance stream depth)))))) ;; ;;;;;; FUNCTION-ARGLIST ;; (defun function-arglist (x) ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and ;; strings instead of symbols. How silly. (let ((arglist (il:arglist x))) (when (symbolp arglist) ;; This could be due to trying to extract the arglist of an interpreted ;; function (though why that should be hard is beyond me). On the other ;; hand, if the function is compiled, it helps to ask for the "smart" ;; arglist. (setq arglist (if (consp (symbol-function x)) (second (symbol-function x)) (il:arglist x t)))) (if (symbolp arglist) ;; Probably never get here, but just in case (list '&rest 'rest) ;; Make sure there are no strings where there should be symbols (if (some #'stringp arglist) (mapcar #'(lambda (a) (if (symbolp a) a (intern a))) arglist) arglist)))) (defun printing-random-thing-internal (thing stream) (let ((*print-base* 8)) (princ (il:\\hiloc thing) stream) (princ "," stream) (princ (il:\\loloc thing) stream))) (defun record-definition (name type &optional parent-name parent-type) (declare (ignore type parent-name)) ()) ;;; ;;; FIN uses this too! ;;; (eval-when (compile load eval) (il:datatype il:compiled-closure (il:fnheader il:environment)) (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))) ) (defun compiled-closure-fnheader (compiled-closure) (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure)) (defun set-compiled-closure-fnheader (compiled-closure nv) (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv)) (defsetf compiled-closure-fnheader set-compiled-closure-fnheader) ;;; ;;; In Lyric, and until the format of FNHEADER changes, getting the name from ;;; a compiled closure looks like this: ;;; ;;; (fetchfield '(nil 4 pointer) ;;; (fetch (compiled-closure fnheader) closure)) ;;; ;;; Of course this is completely non-robust, but it will work for now. This ;;; is not the place to go into a long tyrade about what is wrong with having ;;; record package definitions go away when you ship the sysout; there isn't ;;; enough diskspace. ;;; (defun set-function-name-1 (fn new-name uninterned-name) (cond ((typep fn 'il:compiled-closure) (il:\\rplptr (compiled-closure-fnheader fn) 4 new-name) (when (and (consp uninterned-name) (eq (car uninterned-name) 'method)) (let ((debug (si::compiled-function-debugging-info fn))) (when debug (setf (cdr debug) uninterned-name))))) (t nil)) fn) gcl-2.6.14/pcl/impl/pyramid/0000755000175000017500000000000014360276512014157 5ustar cammcammgcl-2.6.14/pcl/impl/pyramid/pyr-patches.lisp0000644000175000017500000000043714360276512017313 0ustar cammcamm(in-package 'pcl) ;;; This next kludge disables macro memoization (the default) since somewhere ;;; in PCL, the memoization is getting in the way. (eval-when (load eval) (format t "~&;;; Resetting *MACROEXPAND-HOOK* to #'FUNCALL~%") (setq lisp::*macroexpand-hook* #'funcall)) gcl-2.6.14/pcl/impl/pyramid/pyr-low.lisp0000644000175000017500000000344014360276512016462 0ustar cammcamm;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the Pyramid version of low.lisp -- it runs with versions 1.1 ;;; and newer -- Created by David Bein Mon May 4 11:22:30 1987 ;;; (in-package 'pcl) ;; ;;;;;; Cache No's ;; ;;; The purpose behind the shift is that the bottom 2 bits are always 0 ;;; We use the same scheme for symbols and objects although a good ;;; case may be made for shifting objects more since they will ;;; be aligned differently... ;(defmacro symbol-cache-no (symbol mask) ; `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) ; (the fixnum ,mask))) (defmacro object-cache-no (symbol mask) `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) (the fixnum ,mask))) gcl-2.6.14/pcl/impl/gold-hill/0000755000175000017500000000000014360276512014365 5ustar cammcammgcl-2.6.14/pcl/impl/gold-hill/gold-patches.lisp0000644000175000017500000001314614360276512017635 0ustar cammcamm;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*- (in-package 'user) (setq c::optimize-speed 3) (setq c::optimize-safety 0) (setq c::optimize-space 0) (remprop 'macroexpand 'c::fdesc) (remprop 'macroexpand-1 'c::fdesc) ;;; this is here to fix the printer so it will find the print ;;; functions on structures that have 'em. (in-package 'lisp) (defun %write-structure (struct output-stream print-vars level) (let* ((name (svref struct 0)) (pfun (or (let ((temp (get name 'structure-descriptor))) (and temp (dd-print-function temp))) (get name :print-function)))) (declare (symbol name)) (cond (pfun (funcall pfun struct output-stream level)) ((and (pv-level print-vars) (>= level (pv-level print-vars))) (write-char #\# output-stream)) ((and (pv-circle print-vars) (%write-circle struct output-stream (pv-circle print-vars)))) (t (let ((pv-length (pv-length print-vars)) (pv-pretty (pv-pretty print-vars))) (when pv-pretty (pp-push-level pv-pretty)) (incf level) (write-string "#s(" output-stream) (cond ((and pv-length (>= 0 pv-length)) (write-string "...")) (t (%write-symbol name output-stream print-vars) (do ((i 0 (1+ i)) (n 0) (slots (dd-slots (get name 'structure-descriptor)) (rest slots))) ((endp slots)) (declare (fixnum i n) (list slots)) (when pv-pretty (pp-insert-break pv-pretty *structure-keyword-slot-spec* t)) (write-char #\space output-stream) (when (and pv-length (>= (incf n) pv-length)) (write-string "..." output-stream) (return)) (write-char #\: output-stream) (%write-symbol-name (symbol-name (dsd-name (first slots))) output-stream print-vars) (when pv-pretty (pp-insert-break pv-pretty *structure-data-slot-spec* nil)) (write-char #\space output-stream) (when (and pv-length (>= (incf n) pv-length)) (write-string "..." output-stream) (return)) (%write-object (svref struct (dsd-index (first slots))) output-stream print-vars level)))) (write-char #\) output-stream) (when pv-pretty (pp-pop-level pv-pretty))))))) (eval-when (eval) (compile '%write-structure)) ;;; ;;; Apparently, whoever implemented the TIME macro didn't consider that ;;; someone might want to use it in a non-null lexical environment. Of ;;; course this fix is a loser since it binds a whole mess of variables ;;; around the evaluation of form, but it will do for now. ;;; (in-package 'lisp) (DEFmacro TIME (FORM) `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS) (FORMAT *trace-output* "~&Evaluating: ~A" ,form) ;; read the start time. (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START) (SYS::%SYSINT #X21 #X2C00 0 0 0)) ;; Eval the form. (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form))) ;; Read the end time. (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH) (SYS::%SYSINT #X21 #X2C00 0 0 0)) ;; Unpack start and end times. (SETQ S-HSEC (LOGAND START #X0FF) F-HSEC (LOGAND FINISH #X0FF) S-SEC (LSH START -8) F-SEC (LSH FINISH -8) S-MIN (LOGAND #X0FF S-MIN) F-MIN (LOGAND #X0FF F-MIN)) (SETQ F-HSEC (- F-HSEC S-HSEC)) ; calc hundreths (IF (MINUSP F-HSEC) (SETQ F-HSEC (+ F-HSEC 100) F-SEC (1- F-SEC))) (SETQ F-SEC (- F-SEC S-SEC)) ; calc seconds (IF (MINUSP F-SEC) (SETQ F-SEC (+ F-SEC 60) F-MIN (1- F-MIN))) (SETQ F-MIN (- F-MIN S-MIN)) ; calc minutes (IF (MINUSP F-MIN) (INCF F-MIN 60)) (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%" F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC) (VALUES-LIST VALS))) ;;; ;;; Patch to PROGV ;;; (in-package sys::*compiler-package-load*) ;;; This is a fully portable (though not very efficient) ;;; implementation of PROGV as a macro. It does its own special ;;; binding (shallow binding) by saving the original values in a ;;; list, and marking things that were originally unbound. (defun PORTABLE-PROGV-BIND (symbol old-vals place-holder) (let ((val-to-save '#:value-to-save)) `(let ((,val-to-save (if (boundp ,symbol) (symbol-value ,symbol) ,place-holder))) (if ,old-vals (rplacd (last ,old-vals) (ncons ,val-to-save)) (setq ,old-vals (ncons ,val-to-save)))))) (defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder) (let ((val-to-restore '#:value-to-restore)) `(let ((,val-to-restore (pop ,old-vals))) (if (eq ,val-to-restore ,place-holder) (makunbound ,symbol) (setf (symbol-value ,symbol) ,val-to-restore))))) (deftransform PROGV PORTABLE-PROGV-TRANSFORM (symbols-form values-form &rest body) (let ((symbols-lst '#:symbols-list) (values-lst '#:values-list) (syms '#:symbols) (vals '#:values) (sym '#:symbol) (old-vals '#:old-values) (unbound-holder ''#:unbound-holder)) `(let ((,symbols-lst ,symbols-form) (,values-lst ,values-form) (,old-vals nil)) (unless (and (listp ,symbols-lst) (listp ,values-lst)) (error "PROGV: Both symbols and values must be lists")) (unwind-protect (do ((,syms ,symbols-lst (cdr ,syms)) (,vals ,values-lst (cdr ,vals)) (,sym nil)) ((null ,syms) (progn ,@body)) (setq ,sym (car ,syms)) (if (symbolp ,sym) ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder) (error "PROGV: Object to be bound not a symbol: ~S" ,sym)) (if ,vals (setf (symbol-value ,sym) (first ,vals)) (makunbound ,sym))) (dolist (,sym ,symbols-lst) ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder)))))) gcl-2.6.14/pcl/impl/gold-hill/gold-low.lisp0000644000175000017500000000337314360276512017010 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; (in-package 'pcl) ;;; fix a bug in gcl macro-expander (or->cond->or->cond->...) (setf (get 'cond 'lisp::macro-expander) nil) ;;; fix another bug in gcl3_0 case macro-expander (defun lisp::eqv (a b) (eql a b)) (defun printing-random-thing-internal (thing stream) (multiple-value-bind (offaddr baseaddr) (sys:%pointer thing) (princ baseaddr stream) (princ ", " stream) (princ offaddr stream))) ;;; ;;; This allows the compiler to compile a file with many "DEFMETHODS" ;;; in succession. ;;; (dolist (x '(defmethod defgeneric defclass precompile-random-code-segments)) (setf (get x 'gcl::compile-separately) t)) gcl-2.6.14/pcl/impl/gcl/0000755000175000017500000000000014360276512013257 5ustar cammcammgcl-2.6.14/pcl/impl/gcl/gcl-low.lisp0000644000175000017500000002473714360276512015531 0ustar cammcamm(in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) (declare (ignore doc)) (let ((limit (gensym)) (label (gensym))) `(let ((,limit ,form) (,var 0)) (declare (fixnum ,limit ,var)) ,@decls (block nil (tagbody ,label (when (>= ,var ,limit) (return-from nil ,val)) ,@bod (setq ,var (the fixnum (1+ ,var))) (go ,label))))))) (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (eval-when (compile load eval) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) ) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) (si::freeze-defstruct 'pcl::std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo); else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); else super_funcall_no_event(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) (defun pcl::proclaim-defmethod (x y) y (and (symbolp x) (setf (get x 'compiler::proclaimed-closure ) t))) ;#+turbo-closure-env-size (clines " static object cclosure_env_nthcdr (n,cc) int n; object cc; { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) (eval-when (compile eval load) (defparameter *gcl-function-inlines* '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline))))) ) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let ((name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((eval-when (compile eval load) (make-function-inline ',(cons name (cdr inline)))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (the ,(caddr inline) (,name ,@vars))) (make-function-inline ',inline)))))) *gcl-function-inlines*))) (define-inlines) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) (clines " object fSuse_fast_links(); static object set_cclosure (result_cc,value_cc,available_size) object result_cc,value_cc; int available_size; { object result_env_tail,value_env_tail; int i; /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ (VFUN_NARGS=2,fSuse_fast_links(sLnil,result_cc)); /* use_fast_links(3,Cnil,result_cc); */ result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; return result_cc; }") (defentry %set-cclosure (object object int) (object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) (setq s-data (get type 'si::s-data)) (null (si::s-data-type s-data) ))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))))) (defun structure-type-internal-slotds (type) (si::s-data-slot-descriptions (get type 'si::s-data)) ) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) (si:structure-ref1 x offset) )) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym (and (not read-only-p) writer)))))))) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) ;(defun structure-slotd-writer-function (slotd) ; (third slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) (defun renew-sys-files() ;; packages: (compiler::get-packages "sys-package.lisp") (with-open-file (st "sys-package.lisp" :direction :output :if-exists :append) (format st "(lisp::in-package \"SI\") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package \"PCL\") ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) (format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") )) gcl-2.6.14/pcl/impl/gcl/sys-package.lisp0000644000175000017500000001537514360276512016372 0ustar cammcamm ;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES '("S-A-N")) ;;; Definitions for package PCL of type ESTABLISH (LISP::IN-PACKAGE "PCL" :USE LISP::NIL) ;;; Definitions for package ITERATE of type ESTABLISH (LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) ;;; Definitions for package WALKER of type ESTABLISH (LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES '("S-A-N")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package PCL of type EXPORT (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION PCL::GENERIC-FUNCTION-METHOD-COMBINATION PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS PCL::ADD-METHOD PCL::WITH-ACCESSORS PCL::SLOT-DEFINITION-ALLOCATION PCL::SLOT-DEFINITION-INITFUNCTION PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE PCL::STANDARD-GENERIC-FUNCTION PCL::ACCESSOR-METHOD-SLOT-DEFINITION PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE PCL::SLOT-DEFINITION-NAME PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) ;;; Definitions for package ITERATE of type EXPORT (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING ITERATE::WITH-GATHERING ITERATE::INTERVAL)) ;;; Definitions for package WALKER of type EXPORT (LISP::IN-PACKAGE "WALKER" :USE '("LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package PCL of type SHADOW (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package WALKER of type SHADOW (LISP::IN-PACKAGE "WALKER") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) (in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) gcl-2.6.14/pcl/impl/gcl/gcl-patches.lisp0000644000175000017500000001671414360276512016353 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "COMPILER") ;; do evaluation of top level forms at compile time. (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*) ;; patch around compiler bug. (let ((rset "int Rset; ")) (unless (search rset compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string rset compiler::*cmpinclude-string*)))) (when (get 'si::basic-wrapper 'si::s-data) (pushnew :new-kcl-wrapper *features*) (pushnew :structure-wrapper *features*)) #+akcl (progn (unless (fboundp 'real-c2lambda-expr-with-key) (setf (symbol-function 'real-c2lambda-expr-with-key) (symbol-function 'c2lambda-expr-with-key))) (defun c2lambda-expr-with-key (lambda-list body) (declare (special *sup-used*)) (setq *sup-used* t) (real-c2lambda-expr-with-key lambda-list body)) ;There is a bug in the implementation of *print-circle* that ;causes some akcl debugging commands (including :bt and :bl) ;to cause the following error when PCL is being used: ;Unrecoverable error: value stack overflow. ;When a CLOS object is printed, travel_push_object ends up ;traversing almost the whole class structure, thereby overflowing ;the value-stack. ;from lsp/debug.lsp. ;*print-circle* is badly implemented in kcl. ;it has two separate problems that should be fixed: ; 1. it traverses the printed object putting all objects found ; on the value stack (rather than in a hash table or some ; other structure; this is a problem because the size of the value stack ; is fixed, and a potentially unbounded number of objects ; need to be traversed), and ; 2. it blindly traverses all slots of any ; kind of structure including std-object structures. ; This is safe, but not always necessary, and is very time-consuming ; for CLOS objects (because it will always traverse every class). ;For now, avoid using *print-circle* T when it will cause problems. (eval-when (compile eval ) (defmacro si::f (op &rest args) `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) (defmacro si::fb (op &rest args) `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) ) (defun si::display-env (n env) (do ((v (reverse env) (cdr v))) ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) (or (and (consp (car v)) (listp (cdar v))) (return)) (let ((*print-circle* (can-use-print-circle-p (cadar v)))) (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) (defun si::display-compiled-env ( plength ihs &aux (base (si::ihs-vs ihs)) (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) (format si::*display-string* "") (do ((i base ) (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) (format si::*display-string* "~a~@[~d~]=~s~@[,~]" (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) (si::fb < (setq i (si::f + i 1)) end))))) (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") (defentry objnull-p (object) (object "objnull_p")) (defun can-use-print-circle-p (x) (catch 'can-use-print-circle-p (can-use-print-circle-p1 x nil))) (defun can-use-print-circle-p1 (x so-far) (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? (if (member x so-far) (throw 'can-use-print-circle-p t) (let ((so-far (cons x so-far))) (flet ((can-use-print-circle-p (x) (can-use-print-circle-p1 x so-far))) (typecase x (vector (or (not (eq 't (array-element-type x))) (every #'can-use-print-circle-p x))) (cons (and (can-use-print-circle-p (car x)) (can-use-print-circle-p (cdr x)))) (array (or (not (eq 't (array-element-type x))) (let* ((rank (array-rank x)) (dimensions (make-list rank))) (dotimes (i rank) (setf (nth i dimensions) (array-dimension x i))) (or (member 0 dimensions) (do ((cursor (make-list rank :initial-element 0))) (nil) (declare (:dynamic-extent cursor)) (unless (can-use-print-circle-p (apply #'aref x cursor)) (return nil)) (when (si::increment-cursor cursor dimensions) (return t))))))) (t (or (not (si:structurep x)) (let* ((def (si:structure-def x)) (name (si::s-data-name def)) (len (si::s-data-length def)) (pfun (si::s-data-print-function def))) (and (null pfun) (dotimes (i len t) (unless (can-use-print-circle-p (si:structure-ref x name i)) (return nil))))))))))))) (defun si::apply-display-fun (display-fun n lis) (let ((*print-length* si::*debug-print-level*) (*print-level* si::*debug-print-level*) (*print-pretty* nil) (*PRINT-CASE* :downcase) (*print-circle* nil) ) (setf (fill-pointer si::*display-string*) 0) (format si::*display-string* "{") (funcall display-fun n lis) (when (si::fb > (fill-pointer si::*display-string*) n) (setf (fill-pointer si::*display-string*) n) (format si::*display-string* "...")) (format si::*display-string* "}") ) si::*display-string* ) ;The old definition of this had a bug: ;sometimes it returned without calling mv-values. (defun si::next-stack-frame (ihs &aux line-info li i k na) (cond ((si::fb < ihs si::*ihs-base*) (si::mv-values nil nil nil nil nil)) ((let (fun) ;; next lower visible ihs (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) (setq na fun) (cond ((and (setq line-info (get fun 'si::line-info)) (do ((j (si::f + ihs 1) (si::f - j 1)) (form )) ((<= j i) nil) (setq form (si::ihs-fun j)) (cond ((setq li (si::get-line-of-form form line-info)) (return-from si::next-stack-frame (si::mv-values i fun li ;; filename (car (aref line-info 0)) ;;environment (list (si::vs (setq k (si::ihs-vs j))) (si::vs (1+ k)) (si::vs (+ k 2))))))))))))) ((and (not (special-form-p na)) (not (get na 'si::dbl-invisible)) (fboundp na)) (si::mv-values i na nil nil (if (si::ihs-not-interpreted-env i) nil (let ((i (si::ihs-vs i))) (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) (t (si::mv-values nil nil nil nil nil)))) ) gcl-2.6.14/pcl/impl/gcl/gcl_pcl_impl_low.lisp0000644000175000017500000002544714360276512017471 0ustar cammcamm(in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) ;; The generic dotimes macro is now sufficient for the performance ;; gains sought here. Even the declaration extraction should be the ;; same as that provided in do* which dotimes invokes. 20040403 CM ;(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) ; (multiple-value-bind (doc decls bod) ; (extract-declarations body env) ; (declare (ignore doc)) ; (let ((limit (gensym)) ; (label (gensym))) ; `(let ((,limit ,form) ; (,var 0)) ; (declare (fixnum ,limit ,var)) ; ,@decls ; (block nil ; (tagbody ; ,label ; (when (>= ,var ,limit) (return-from nil ,val)) ; ,@bod ; (setq ,var (the fixnum (1+ ,var))) ; (go ,label))))))) (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (eval-when (compile load eval) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) ) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) (si::freeze-defstruct 'pcl::std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) (*(_funobj->cc.cc_self))(_funobj); else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); else super_funcall_no_event(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) (defun pcl::proclaim-defmethod (x y) y (and (symbolp x) (setf (get x 'compiler::proclaimed-closure ) t))) ;#+turbo-closure-env-size (clines " static object cclosure_env_nthcdr (fixnum n,object cc) { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") (defentry cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) (eval-when (compile eval load) (defparameter *gcl-function-inlines* '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline)))))) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let ((name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((eval-when (compile eval load) (make-function-inline ',(cons name (cdr inline)))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (the ,(caddr inline) (,name ,@vars))) (make-function-inline ',inline)))))) *gcl-function-inlines*))) (define-inlines) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) (clines " object fSuse_fast_links_2(object,object); static object set_cclosure (object result_cc,object value_cc,fixnum available_size) { object result_env_tail,value_env_tail; int i; /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ /* (VFUN_NARGS=2,fSuse_fast_links_2(Cnil,result_cc));*/ fSuse_fast_links_2(Cnil,result_cc); /* use_fast_links(3,Cnil,result_cc); */ result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; return result_cc; }") (defentry %set-cclosure (object object fixnum) (compiler::static object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) (setq s-data (get type 'si::s-data)) (null (si::s-data-type s-data) ))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))))) (defun structure-type-internal-slotds (type) (si::s-data-slot-descriptions (get type 'si::s-data)) ) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) (si:structure-ref1 x offset) )) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym (and (not read-only-p) writer)))))))) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) ;(defun structure-slotd-writer-function (slotd) ; (third slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) (defun renew-sys-files() ;; ;; packages: ;; (compiler::get-packages "sys-package.lisp") ;; (with-open-file (st "sys-package.lisp" ;; :direction :output ;; :if-exists :append) ;; (format st "(lisp::in-package \"SI\") ;; (export '(%structure-name ;; %compiled-function-name ;; %set-compiled-function-name)) ;; (in-package \"PCL\") ;; ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) (format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") )) gcl-2.6.14/pcl/impl/gcl/sys-proclaim.lisp0000644000175000017500000025706314360276512016607 0ustar cammcamm (IN-PACKAGE "PCL") (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) ONE-INDEX-LIMIT-FN N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN PV-CACHE-LIMIT-FN ARG-INFO-NUMBER-REQUIRED DEFAULT-LIMIT-FN CACHE-COUNT CACHING-LIMIT-FN PV-TABLE-PV-SIZE EARLY-CLASS-SIZE CPD-COUNT FAST-INSTANCE-BOUNDP-INDEX)) (PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) (PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN METHOD-CALL-FUNCTION FAST-METHOD-CALL-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING)) (PROCLAIM '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW PV-TABLE-SLOT-NAME-LISTS PV-TABLE-CALL-LIST)) (PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP)) (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) (PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME MAKE-KEYWORD)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) COMPUTE-PRIMARY-CACHE-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (T) (OR CACHE NULL)) PV-TABLE-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::WALK-GATHERING-BODY CACHE-MISS-VALUES MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION OPTIMIZE-SLOT-VALUE-BY-CLASS-P ACCESSOR-VALUES1 EMIT-READER/WRITER EMIT-ONE-OR-N-INDEX-READER/WRITER GENERATING-LISP EMIT-READER/WRITER-FUNCTION EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION WALKER::WALK-LET-IF SET-SLOT-VALUE CONVERT-METHODS |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| CHECK-METHOD-ARG-INFO |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| LOAD-LONG-DEFCOMBIN MAKE-FINAL-N-N-ACCESSOR-DFUN |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| MAKE-FINAL-CACHING-DFUN MAKE-FINAL-CONSTANT-VALUE-DFUN GET-CLASS-SLOT-VALUE-1 ACCESSOR-VALUES-INTERNAL MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES CONSTANT-VALUE-MISS CACHING-MISS |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| CHECKING-MISS GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) *) |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL ADD-METHOD-DECLARATIONS WALK-METHOD-LAMBDA MAKE-TWO-CLASS-ACCESSOR-DFUN |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| BOOTSTRAP-ACCESSOR-DEFINITION GET-ACCESSOR-METHOD-FUNCTION EMIT-CHECKING-OR-CACHING EMIT-CHECKING-OR-CACHING-FUNCTION SETF-SLOT-VALUE-USING-CLASS-DFUN LOAD-SHORT-DEFCOMBIN INITIALIZE-INSTANCE-SIMPLE-FUNCTION MAKE-SHARED-INITIALIZE-FORM-LIST MAKE-ONE-CLASS-ACCESSOR-DFUN MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN MAKE-FINAL-CHECKING-DFUN ACCESSOR-VALUES SET-CLASS-SLOT-VALUE-1 GENERATE-DISCRIMINATION-NET REAL-MAKE-METHOD-LAMBDA ORDER-SPECIALIZERS ACCESSOR-MISS |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) *) MEMF-CODE-CONVERTER CACHE-MISS-VALUES-INTERNAL GENERATE-DISCRIMINATION-NET-INTERNAL MAKE-LONG-METHOD-COMBINATION-FUNCTION DO-SHORT-METHOD-COMBINATION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) *) MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS GET-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) NESTED-WALK-FORM SLOT-VALUE-OR-DEFAULT MAKE-EFFECTIVE-METHOD-FUNCTION GET-EFFECTIVE-METHOD-FUNCTION MAKE-N-N-ACCESSOR-DFUN MAKE-CHECKING-DFUN LOAD-DEFGENERIC TYPES-FROM-ARGUMENTS MAKE-DEFAULT-INITARGS-FORM-LIST MAKE-FINAL-ACCESSOR-DFUN MAKE-ACCESSOR-TABLE GET-SIMPLE-INITIALIZATION-FUNCTION GET-COMPLEX-INITIALIZATION-FUNCTIONS COMPUTE-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| ITERATE::ITERATE-TRANSFORM-BODY)) (PROCLAIM '(FTYPE (FUNCTION (T) NON-NEGATIVE-FIXNUM) CACHE-NLINES CACHE-MAX-LOCATION CACHE-SIZE CACHE-MASK)) (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| MAKE-EFFECTIVE-METHOD-FUNCTION1 MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE MEMF-TEST-CONVERTER LOAD-PRECOMPILED-DFUN-CONSTRUCTOR TWO-CLASS-DFUN-INFO WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 OPTIMIZE-READER OPTIMIZE-WRITER |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| MAYBE-EXPAND-ACCESSOR-FORM |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| INITIALIZE-INSTANCE-SIMPLE |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| GET-WRAPPERS-FROM-CLASSES |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| LOAD-PRECOMPILED-IIS-ENTRY FILL-CACHE-P ADJUST-CACHE |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| EXPAND-CACHE EXPAND-SYMBOL-MACROLET-INTERNAL |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| BOOTSTRAP-SET-SLOT EXPAND-DEFCLASS |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| WALKER::WALK-TEMPLATE |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| MAKE-DISPATCH-LAMBDA |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| CAN-OPTIMIZE-ACCESS |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| OPTIMIZE-SLOT-VALUE |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| OPTIMIZE-SET-SLOT-VALUE |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| DECLARE-STRUCTURE OPTIMIZE-SLOT-BOUNDP PRINT-CACHE FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM WRAP-METHOD-GROUP-SPECIFIER-BINDINGS MAKE-TOP-LEVEL-FORM INVALIDATE-WRAPPER STANDARD-COMPUTE-EFFECTIVE-METHOD MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM WALKER::WALK-MULTIPLE-VALUE-SETQ |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| VARIABLE-DECLARATION |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| ITERATE::SIMPLE-EXPAND-GATHERING-FORM ITERATE::RENAME-AND-CAPTURE-VARIABLES ITERATE::VARIABLE-SAME-P GET-FUNCTION-GENERATOR GET-NEW-FUNCTION-GENERATOR TRACE-METHOD-INTERNAL ONE-INDEX-DFUN-INFO ONE-CLASS-DFUN-INFO MAP-ALL-ORDERS NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA OPTIMIZE-GF-CALL-INTERNAL WALKER::WALK-COMPILER-LET |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| WALKER::WALK-MACROLET |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| FIX-SLOT-ACCESSORS |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| WALKER::WALK-MULTIPLE-VALUE-BIND |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| WALKER::WALK-SETQ |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| WALKER::WALK-SYMBOL-MACROLET |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY EMIT-BOUNDP-CHECK WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* EXPAND-DEFGENERIC EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP MAKE-METHOD-INITARGS-FORM-INTERNAL ENTRY-IN-CACHE-P CONVERT-TABLE MAKE-METHOD-SPEC TRACE-EMF-CALL-INTERNAL FLUSH-CACHE-TRAP SET-FUNCTION-NAME-1 OBSOLETE-INSTANCE-TRAP COMPUTE-PRECEDENCE PRINT-STD-INSTANCE |SETF PCL METHOD-FUNCTION-GET| |SETF PCL PLIST-VALUE| WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| INITIALIZE-INTERNAL-SLOT-GFS* |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| COMPUTE-EFFECTIVE-METHOD SORT-APPLICABLE-METHODS SORT-METHODS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| LOAD-FUNCTION-GENERATOR EXPAND-EMF-CALL-METHOD MAKE-FGEN BOOTSTRAP-MAKE-SLOT-DEFINITIONS BOOTSTRAP-ACCESSOR-DEFINITIONS1 MAKE-FINAL-ORDINARY-DFUN-INTERNAL WALKER::WALK-TEMPLATE-HANDLE-REPEAT COMPUTE-PV-SLOT WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS OPTIMIZE-ACCESSOR-CALL MAKE-METHOD-INITARGS-FORM-INTERNAL1 UPDATE-SLOTS-IN-PV MAKE-PARAMETER-REFERENCES MAKE-EMF-CACHE GET-MAKE-INSTANCE-FUNCTION-INTERNAL |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| MAKE-INSTANCE-FUNCTION-COMPLEX |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| MAKE-INSTANCE-FUNCTION-SIMPLE |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| OPTIMIZE-GENERIC-FUNCTION-CALL REAL-MAKE-METHOD-INITARGS-FORM |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE MAKE-EMF-FROM-METHOD EXPAND-EFFECTIVE-METHOD-FUNCTION NAMED-OBJECT-PRINT-FUNCTION FIND-CLASS-FROM-CELL FIND-CLASS-PREDICATE-FROM-CELL INITIALIZE-INFO GET-EFFECTIVE-METHOD-FUNCTION1 GET-DECLARATION GET-METHOD-FUNCTION-PV-CELL EMIT-MISS METHOD-FUNCTION-GET PROBE-CACHE MAP-CACHE PRECOMPUTE-EFFECTIVE-METHODS RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR REAL-ADD-METHOD REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION REAL-ENSURE-GF-USING-CLASS--NULL COMPUTE-SECONDARY-DISPATCH-FUNCTION1 ENSURE-GENERIC-FUNCTION-USING-CLASS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) REAL-LOAD-DEFCLASS WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 BOOTSTRAP-MAKE-SLOT-DEFINITION EMIT-SLOT-ACCESS OPTIMIZE-GF-CALL SET-ARG-INFO1 LOAD-DEFCLASS MAKE-EARLY-CLASS-DEFINITION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) T) |(FAST-METHOD SLOT-MISSING (T T T T))| EXPAND-DEFMETHOD LOAD-DEFMETHOD-INTERNAL)) (PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) GET-CACHE FILL-CACHE-FROM-CACHE-P)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) EMIT-DLAP GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) CHECK-INITARGS-2-PLIST CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST MAKE-EMF-CALL CAN-OPTIMIZE-ACCESS1 EMIT-FETCH-WRAPPER FILL-CACHE REAL-GET-METHOD CHECK-INITARGS-1 GET-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) LOAD-DEFMETHOD MAKE-DEFMETHOD-FORM MAKE-DEFMETHOD-FORM-INTERNAL EARLY-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE EARLY-ADD-NAMED-METHOD REAL-ADD-NAMED-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T) T) GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T T *) T) BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION NIL *) COUNT-ALL-DFUNS EMIT-N-N-READERS EMIT-N-N-WRITERS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) UNTRACE-METHOD LIST-LARGE-CACHES UPDATE-MAKE-INSTANCE-FUNCTION-TABLE INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR)) (PROCLAIM '(FTYPE (FUNCTION NIL T) RENEW-SYS-FILES GET-EFFECTIVE-METHOD-GENSYM SHOW-EMF-CALL-TRACE BOOTSTRAP-META-BRAID BOOTSTRAP-BUILT-IN-CLASSES LIST-ALL-DFUNS DEFAULT-METHOD-ONLY-DFUN-INFO INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST CACHES-TO-ALLOCATE UPDATE-DISPATCH-DFUNS MAKE-CACHE IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P ALLOCATE-FUNCALLABLE-INSTANCE-2 %%ALLOCATE-INSTANCE--CLASS ALLOCATE-FUNCALLABLE-INSTANCE-1 DISPATCH-DFUN-INFO INITIAL-DISPATCH-DFUN-INFO INITIAL-DFUN-INFO NO-METHODS-DFUN-INFO SHOW-FREE-CACHE-VECTORS MAKE-CPD MAKE-ARG-INFO SHOW-DFUN-CONSTRUCTORS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) (PROCLAIM '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO| |__si::MAKE-NO-METHODS| |__si::MAKE-INITIAL| |__si::MAKE-INITIAL-DISPATCH| |__si::MAKE-DISPATCH| |__si::MAKE-DEFAULT-METHOD-ONLY| |__si::MAKE-ACCESSOR-DFUN-INFO| |__si::MAKE-ONE-INDEX-DFUN-INFO| MAKE-FAST-METHOD-CALL |__si::MAKE-N-N| MAKE-FAST-INSTANCE-BOUNDP |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS| |__si::MAKE-ONE-INDEX| |__si::MAKE-CHECKING| |__si::MAKE-ARG-INFO| FIX-EARLY-GENERIC-FUNCTIONS STRING-APPEND |__si::MAKE-CACHING| |__si::MAKE-CONSTANT-VALUE| FALSE |STRUCTURE-OBJECT class constructor| PV-WRAPPERS-FROM-PV-ARGS MAKE-PV-TABLE |__si::MAKE-PV-TABLE| INTERN-PV-TABLE CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-STD-INSTANCE| MAKE-INITIALIZE-INFO |__si::MAKE-CACHE| MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| MAKE-METHOD-CALL TRUE USE-PACKAGE-PCL ZERO)) (PROCLAIM '(FTYPE (FUNCTION (T) *) TYPE-FROM-SPECIALIZER *NORMALIZE-TYPE DEFAULT-CODE-CONVERTER CONVERT-TO-SYSTEM-TYPE EMIT-CONSTANT-VALUE PCL-DESCRIBE GET-GENERIC-FUNCTION-INFO EARLY-METHOD-FUNCTION EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME SPECIALIZER-FROM-TYPE CLASS-EQ-TYPE STRUCTURE-WRAPPER FIND-STRUCTURE-CLASS MAKE-DISPATCH-DFUN FIND-WRAPPER PARSE-DEFMETHOD PROTOTYPES-FOR-MAKE-METHOD-LAMBDA EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER EMIT-TWO-CLASS-READER EMIT-TWO-CLASS-WRITER EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS NET-CODE-CONVERTER EMIT-IN-CHECKING-CACHE-P COMPILE-IIS-FUNCTIONS ANALYZE-LAMBDA-LIST COMPUTE-APPLICABLE-METHODS-EMF GET-DISPATCH-FUNCTION GENERIC-FUNCTION-NAME-P MAKE-FINAL-DISPATCH-DFUN STRUCTURE-SLOTD-INIT-FORM PARSE-METHOD-GROUP-SPECIFIER METHOD-PROTOTYPE-FOR-GF EARLY-COLLECT-INHERITANCE)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) T) COMPILE-LAMBDA-UNCOMPILED GF-LAMBDA-LIST CACHING-CACHE CONSTANT-VALUE-CACHE COMPILE-LAMBDA-DEFERRED FUNCALLABLE-INSTANCE-P SHOW-DFUN-COSTS RESET-CLASS-INITIALIZE-INFO GET-CACHE-VECTOR CONSTANT-SYMBOL-P FREE-CACHE-VECTOR EARLY-METHOD-LAMBDA-LIST ARG-INFO-VALID-P DFUN-ARG-SYMBOL EARLY-METHOD-CLASS EARLY-GF-P EARLY-GF-NAME CACHING-DFUN-INFO COMPUTE-APPLICABLE-METHODS-EMF-STD-P CONSTANT-VALUE-DFUN-INFO RESET-CLASS-INITIALIZE-INFO-1 FREE-CACHE PARSE-SPECIALIZERS RESET-INITIALIZE-INFO EARLY-METHOD-QUALIFIERS PROCLAIM-INCOMPATIBLE-SUPERCLASSES WRAPPER-OF EARLY-METHOD-STANDARD-ACCESSOR-P FUNCTION-PRETTY-ARGLIST GET-MAKE-INSTANCE-FUNCTION CHECK-WRAPPER-VALIDITY UNPARSE-SPECIALIZERS %SYMBOL-FUNCTION FINAL-ACCESSOR-DFUN-TYPE COMPLICATED-INSTANCE-CREATION-METHOD DEFAULT-STRUCTUREP UPDATE-GF-INFO CACHE-OWNER DEFAULT-STRUCTURE-INSTANCE-P DEFAULT-STRUCTURE-TYPE STRUCTURE-TYPE COMPUTE-STD-CPL-PHASE-2 GET-PV-CELL-FOR-CLASS STRUCTURE-TYPE-INCLUDED-TYPE-NAME STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST CACHE-P STRUCTURE-SLOTD-NAME STRUCTURE-SLOTD-ACCESSOR-SYMBOL SFUN-P DEFAULT-SECONDARY-DISPATCH-FUNCTION STRUCTURE-SLOTD-WRITER-FUNCTION FIND-CYCLE-REASONS EARLY-CLASS-DEFINITION ECD-SOURCE STRUCTURE-SLOTD-TYPE FORMAT-CYCLE-REASONS ECD-METACLASS CPD-CLASS EARLY-CLASS-PRECEDENCE-LIST METHODS-CONTAIN-EQL-SPECIALIZER-P MAKE-TYPE-PREDICATE CPD-SUPERS DEFAULT-TEST-CONVERTER EXPAND-LONG-DEFCOMBIN INITIAL-P EARLY-CLASS-NAME-OF FORCE-CACHE-FLUSHES CPD-AFTER EXPAND-SHORT-DEFCOMBIN MAKE-CALL-METHODS DEFAULT-CONSTANT-CONVERTER EARLY-CLASS-SLOTDS INITIAL-DISPATCH-P DISPATCH-P EARLY-SLOT-DEFINITION-NAME SLOT-READER-SYMBOL GBOUNDP GMAKUNBOUND EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK DEFAULT-CONSTANTP MAKE-INITIAL-DFUN DEFAULT-METHOD-ONLY-P FGEN-TEST EARLY-ACCESSOR-METHOD-SLOT-NAME SLOT-WRITER-SYMBOL LOOKUP-FGEN WALKER::ENV-DECLARATIONS ACCESSOR-DFUN-INFO-P WALKER::ENV-LEXICAL-VARIABLES FGEN-GENERATOR FGEN-SYSTEM LIST-DFUN %FBOUNDP SLOT-BOUNDP-SYMBOL ONE-INDEX-DFUN-INFO-P CCLOSUREP MAP-ALL-GENERIC-FUNCTIONS FAST-METHOD-CALL-P MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION N-N-P EARLY-CLASS-DIRECT-SUBCLASSES FAST-INSTANCE-BOUNDP-P MAKE-FUNCTION-INLINE METHOD-FUNCTION-PV-TABLE LIST-LARGE-CACHE METHOD-FUNCTION-METHOD STORE-FGEN CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-P INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS UNENCAPSULATED-FDEFINITION MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION METHOD-FUNCTION-NEEDS-NEXT-METHODS-P DFUN-INFO-P MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION FTYPE-DECLARATION-FROM-LAMBDA-LIST NO-METHODS-P WALKER::ENV-WALK-FUNCTION FGEN-GENSYMS WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE TWO-CLASS-P COUNT-DFUN ARG-INFO-LAMBDA-LIST MAKE-INITFUNCTION ARG-INFO-PRECEDENCE MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ARG-INFO-METATYPES ITERATE::VARIABLES-FROM-LET FGEN-GENERATOR-LAMBDA WALKER::ENV-WALK-FORM ARG-INFO-NUMBER-OPTIONAL MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION ARG-INFO-KEY/REST-P INITIALIZE-INFO-P ONE-INDEX-P ECD-CLASS-NAME ARG-INFO-KEYWORDS COPY-CACHE GF-INFO-SIMPLE-ACCESSOR-TYPE COMPUTE-LINE-SIZE GF-PRECOMPUTE-DFUN-AND-EMF-P CANONICAL-SLOT-NAME GF-INFO-STATIC-C-A-M-EMF WALKER::GET-WALKER-TEMPLATE CHECKING-P EARLY-CLASS-SLOTS GF-INFO-C-A-M-EMF-STD-P STRUCTURE-TYPE-INTERNAL-SLOTDS GF-INFO-FAST-MF-P UNDEFMETHOD-1 EARLY-COLLECT-CPL EARLY-COLLECT-SLOTS ARG-INFO-P METHOD-LL->GENERIC-FUNCTION-LL FAST-METHOD-CALL-ARG-INFO EARLY-COLLECT-DEFAULT-INITARGS ARG-INFO-NKEYS ECD-SUPERCLASS-NAMES GF-DFUN-CACHE GF-DFUN-INFO METHOD-CALL-P STRUCTURE-SLOT-BOUNDP FUNCTION-RETURNING-NIL ITERATE::SEQUENCE-ACCESSOR ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS EVAL-FORM ONE-INDEX-DFUN-INFO-INDEX ECD-OTHER-INITARGS SLOT-INITARGS-FROM-STRUCTURE-SLOTD TYPE-CLASS ONE-CLASS-WRAPPER0 EXTRACT-PARAMETERS CLASS-PREDICATE EXTRACT-REQUIRED-PARAMETERS MAKE-CLASS-EQ-PREDICATE TWO-CLASS-WRAPPER1 MAKE-EQL-PREDICATE CHECKING-FUNCTION BOOTSTRAP-ACCESSOR-DEFINITIONS INITIALIZE-INFO-KEY BOOTSTRAP-CLASS-PREDICATES GET-BUILT-IN-CLASS-SYMBOL INITIALIZE-INFO-WRAPPER GET-BUILT-IN-WRAPPER-SYMBOL DO-STANDARD-DEFSETF-1 CACHING-P GFS-OF-TYPE LEGAL-CLASS-NAME-P STRUCTURE-TYPE-P CONSTANT-VALUE-P USE-DEFAULT-METHOD-ONLY-DFUN-P INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST WRAPPER-FIELD NEXT-WRAPPER-FIELD SETFBOUNDP GET-SETF-FUNCTION-NAME USE-CACHING-DFUN-P MAKE-PV-TYPE-DECLARATION MAKE-CALLS-TYPE-DECLARATION MAP-SPECIALIZERS SLOT-VECTOR-SYMBOL MAKE-PERMUTATION-VECTOR VARIABLE-GLOBALLY-SPECIAL-P STRUCTURE-OBJECT-P EXPAND-MAKE-INSTANCE-FORM MAKE-CONSTANT-FUNCTION FUNCTION-RETURNING-T SORT-SLOTS SORT-CALLS SYMBOL-PKG-NAME CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P INITIALIZE-INFO-BOUND-SLOTS INITIALIZE-INFO-CACHED-VALID-P GET-MAKE-INSTANCE-FUNCTIONS INITIALIZE-INFO-CACHED-RI-VALID-P INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST INITIALIZE-INFO-CACHED-NEW-KEYS UPDATE-C-A-M-GF-INFO INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION UPDATE-GF-SIMPLE-ACCESSOR-TYPE UPDATE-GFS-OF-CLASS INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION DO-STANDARD-DEFSETFS-FOR-DEFCLASS STANDARD-SVUC-METHOD INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION %CCLOSURE-ENV STRUCTURE-SVUC-METHOD INITIALIZE-INFO-CACHED-CONSTANTS CLASS-OF METHOD-FUNCTION-PLIST INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL INTERNED-SYMBOL-P GDEFINITION UPDATE-CLASS-CAN-PRECEDE-P %STD-INSTANCE-WRAPPER %STD-INSTANCE-SLOTS PV-TABLEP STD-INSTANCE-P COMPUTE-MCASE-PARAMETERS COMPUTE-CLASS-SLOTS MAKE-PV-TABLE-TYPE-DECLARATION INTERN-EQL-SPECIALIZER NET-TEST-CONVERTER MAKE-INSTANCE-FUNCTION-SYMBOL UPDATE-ALL-C-A-M-GF-INFO UPDATE-PV-TABLE-CACHE-INFO DFUN-INFO-CACHE EXTRACT-LAMBDA-LIST NO-METHODS-CACHE ARG-INFO-APPLYP CACHING-DFUN-COST INITIAL-CACHE SYSTEM:%STRUCTURE-NAME INITIAL-DISPATCH-CACHE SYSTEM:%COMPILED-FUNCTION-NAME CHECK-CACHE DISPATCH-CACHE CLASS-FROM-TYPE DEFAULT-METHOD-ONLY-CACHE DNET-METHODS-P ACCESSOR-DFUN-INFO-CACHE METHOD-FUNCTION-FROM-FAST-FUNCTION ONE-INDEX-DFUN-INFO-CACHE ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE METHOD-CALL-CALL-METHOD-ARGS KEYWORD-SPEC-NAME N-N-CACHE GENERIC-CLOBBERS-FUNCTION N-N-ACCESSOR-TYPE FAST-METHOD-CALL-PV-CELL WRAPPER-FOR-STRUCTURE ONE-CLASS-CACHE EXTRACT-SPECIALIZER-NAMES FAST-METHOD-CALL-NEXT-METHOD-CALL ONE-CLASS-ACCESSOR-TYPE ONE-CLASS-INDEX BUILT-IN-WRAPPER-OF TWO-CLASS-CACHE BUILT-IN-OR-STRUCTURE-WRAPPER1 TWO-CLASS-ACCESSOR-TYPE TWO-CLASS-INDEX GET-MAKE-INSTANCE-FUNCTION-SYMBOL ALLOCATE-CACHE-VECTOR TWO-CLASS-WRAPPER0 FLUSH-CACHE-VECTOR-INTERNAL ONE-INDEX-CACHE EARLY-CLASS-NAME ONE-INDEX-ACCESSOR-TYPE ONE-INDEX-INDEX INTERN-FUNCTION-NAME CHECKING-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) COERCE-TO-CLASS GET-METHOD-FUNCTION GET-FUNCTION GET-FUNCTION1 PARSE-METHOD-OR-SPEC EXTRACT-DECLARATIONS GET-DFUN-CONSTRUCTOR MAP-ALL-CLASSES MAKE-CACHING-DFUN MAKE-METHOD-FUNCTION-INTERNAL PARSE-SPECIALIZED-LAMBDA-LIST MAKE-METHOD-LAMBDA-INTERNAL MAKE-CONSTANT-VALUE-DFUN MAKE-FINAL-DFUN-INTERNAL COMPILE-LAMBDA WALK-FORM MACROEXPAND-ALL ENSURE-CLASS ENSURE-GENERIC-FUNCTION DISPATCH-DFUN-COST)) (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) CAPITALIZE-WORDS INITIALIZE-INTERNAL-SLOT-GFS FIND-CLASS MAKE-TYPE-PREDICATE-NAME SET-DFUN TRACE-METHOD FIND-CLASS-CELL MAKE-FINAL-DFUN PV-TABLE-LOOKUP-PV-ARGS USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS USE-CONSTANT-VALUE-DFUN-P MAKE-EARLY-GF ALLOCATE-FUNCALLABLE-INSTANCE SET-ARG-INFO INITIALIZE-METHOD-FUNCTION UPDATE-DFUN MAKE-SPECIALIZABLE ALLOCATE-STRUCTURE-INSTANCE ALLOCATE-STANDARD-INSTANCE WALKER::WALKER-ENVIRONMENT-BIND-1 ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN MAKE-WRAPPER)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) SLOT-BOUNDP SLOT-VALUE SAUT-CLASS SPECIALIZER-APPLICABLE-USING-TYPE-P COMPUTE-TEST GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE CLASS-APPLICABLE-USING-CLASS-P SAUT-AND SAUT-NOT SAUT-PROTOTYPE DESTRUCTURE ENSURE-CLASS-VALUES MAKE-DIRECT-SLOTD SLOT-MAKUNBOUND MAKE-INSTANCE-FUNCTION-TRAP GENERATE-FAST-CLASS-SLOT-ACCESS-P MUTATE-SLOTS-AND-CALLS INVOKE-EMF EMIT-DEFAULT-ONLY-FUNCTION SPLIT-DECLARATIONS EMIT-DEFAULT-ONLY SLOT-NAME-LISTS-FROM-SLOTS EMIT-CHECKING UPDATE-SLOT-VALUE-GF-INFO EMIT-CACHING SDFUN-FOR-CACHING SLOT-UNBOUND-INTERNAL MAKE-INSTANCE-1 SET-FUNCTION-NAME COMPUTE-STD-CPL-PHASE-1 FORM-LIST-TO-LISP FIND-SUPERCLASS-CHAIN SAUT-CLASS-EQ COMPUTE-APPLICABLE-METHODS-USING-TYPES CHECK-INITARGS-VALUES SAUT-EQL INSURE-DFUN *SUBTYPEP ITERATE::PARSE-DECLARATIONS INITIAL-DFUN)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) ADD-METHOD DO-SATISFIES-DEFTYPE MEMF-CONSTANT-CONVERTER COMPUTE-CONSTANTS CLASS-CAN-PRECEDE-P SAUT-NOT-CLASS SAUT-NOT-CLASS-EQ SAUT-NOT-PROTOTYPE GF-MAKE-FUNCTION-FROM-EMF SAUT-NOT-EQL SUPERCLASSES-COMPATIBLE-P CLASSES-HAVE-COMMON-SUBCLASS-P DESCRIBE-PACKAGE PRINTING-RANDOM-THING-INTERNAL MAKE-CLASS-PREDICATE METHOD-FUNCTION-RETURNING-NIL METHOD-FUNCTION-RETURNING-T VARIABLE-CLASS MAKE-PLIST REMTAIL DESTRUCTURE-INTERNAL ACCESSOR-MISS-FUNCTION UPDATE-INITIALIZE-INFO-INTERNAL N-N-DFUN-INFO MAKE-CAXR MAKE-CDXR CHECKING-DFUN-INFO FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-PV-TABLE-INTERNAL FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING MAKE-DLAP-LAMBDA-LIST ADD-DIRECT-SUBCLASSES COMPUTE-PV MAKE-DFUN-ARG-LIST COMPUTE-CALLS MAKE-FAST-METHOD-CALL-LAMBDA-LIST UPDATE-ALL-PV-TABLE-CACHES UPDATE-CLASS MAP-PV-TABLE-REFERENCES-OF ADD-SLOT-ACCESSORS WALKER::ENVIRONMENT-FUNCTION REMOVE-DIRECT-SUBCLASSES REMOVE-SLOT-ACCESSORS SYMBOL-LESSP SYMBOL-OR-CONS-LESSP |SETF PCL FIND-CLASS| |SETF PCL FIND-CLASS-PREDICATE| PV-WRAPPERS-FROM-ALL-ARGS PV-TABLE-LOOKUP PROCLAIM-DEFGENERIC UPDATE-CPL LIST-EQ UPDATE-SLOTS COMPUTE-APPLICABLE-METHODS-FUNCTION VARIABLE-LEXICAL-P VARIABLE-SPECIAL-P UPDATE-INITS UPDATE-STD-OR-STR-METHODS SET-STANDARD-SVUC-METHOD EMIT-1-NIL-DLAP PLIST-VALUE SET-STRUCTURE-SVUC-METHOD EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES-INTERNAL EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES %SET-CCLOSURE-ENV MEC-ALL-CLASS-LISTS REDEFINE-FUNCTION METHODS-CONVERTER COMPUTE-LAYOUT NO-SLOT PV-WRAPPERS-FROM-ALL-WRAPPERS NET-CONSTANT-CONVERTER AUGMENT-TYPE CHANGE-CLASS-INTERNAL VALUE-FOR-CACHING |SETF PCL METHOD-FUNCTION-PLIST| GET-KEY-ARG GET-KEY-ARG1 SET-METHODS SET-FUNCTION-PRETTY-ARGLIST FIND-STANDARD-II-METHOD MAKE-EARLY-ACCESSOR DOCTOR-DFUN-FOR-THE-DEBUGGER COMPUTE-STD-CPL |SETF PCL GDEFINITION| MAKE-DISCRIMINATING-FUNCTION-ARGLIST ADD-FORMS CPL-INCONSISTENT-ERROR REDIRECT-EARLY-FUNCTION-INTERNAL ADD-TO-CVECTOR BOOTSTRAP-SLOT-INDEX QUALIFIER-CHECK-RUNTIME CPL-FORWARD-REFERENCED-CLASS-ERROR REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO CANONICALIZE-SLOT-SPECIFICATION CANONICALIZE-DEFCLASS-OPTION SET-WRAPPER DEAL-WITH-ARGUMENTS-OPTION PARSE-QUALIFIER-PATTERN SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ MAKE-UNORDERED-METHODS-EMF CLASS-MIGHT-PRECEDE-P ITERATE::EXTRACT-SPECIAL-BINDINGS WALKER::VARIABLE-SYMBOL-MACRO-P RAISE-METATYPE SLOT-EXISTS-P PROCLAIM-DEFMETHOD STANDARD-INSTANCE-ACCESS REMOVE-METHOD SET-FUNCALLABLE-INSTANCE-FUNCTION SYSTEM:%SET-COMPILED-FUNCTION-NAME FDEFINE-CAREFULLY MAKE-INTERNAL-READER-METHOD-FUNCTION MAKE-STD-READER-METHOD-FUNCTION MAKE-STD-WRITER-METHOD-FUNCTION ITERATE::SIMPLE-EXPAND-ITERATE-FORM MAKE-STD-BOUNDP-METHOD-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) (IN-PACKAGE "PCL") (DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| ADD-READER-METHOD SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT REMOVE-READER-METHOD |LISP::T class predicate| EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL |PCL::STANDARD-OBJECT class predicate| |PCL::STANDARD-SLOT-DEFINITION class predicate| |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate| |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::STANDARD-METHOD-COMBINATION class predicate| |(FAST-READER-METHOD SLOT-OBJECT METHOD)| |PCL::BUILT-IN-CLASS class predicate| SPECIALIZER-TYPE |LISP::RATIO class predicate| |LISP::RATIONAL class predicate| GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| CLASS-DEFSTRUCT-CONSTRUCTOR |(FAST-READER-METHOD SLOT-OBJECT SOURCE)| |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)| METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)| |(SETF GF-PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| SPECIALIZERP EXACT-CLASS-SPECIALIZER-P |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)| |(FAST-READER-METHOD PCL-CLASS WRAPPER)| |(FAST-READER-METHOD SLOT-OBJECT INITARGS)| |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |LISP::CHARACTER class predicate| COMPATIBLE-META-CLASS-CHANGE-P |LISP::SEQUENCE class predicate| |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)| |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)| |(BOUNDP READERS)| UPDATE-GF-DFUN |(BOUNDP CLASS-PRECEDENCE-LIST)| |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP LOCATION)| |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)| |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)| |PCL::PCL-CLASS class predicate| |PCL::STD-CLASS class predicate| |(BOUNDP DEFSTRUCT-FORM)| |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| CLASS-EQ-SPECIALIZER-P |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD |(BOUNDP WRITER-FUNCTION)| |(BOUNDP INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)| STRUCTURE-CLASS-P |(BOUNDP WRITERS)| |(BOUNDP INITFORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)| |LISP::BIT-VECTOR class predicate| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)| |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| DOCUMENTATION |(BOUNDP FUNCTION)| |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP LAMBDA-LIST)| METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)| |LISP::ARRAY class predicate| |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS |PCL::DEFINITION-SOURCE-MIXIN class predicate| |(BOUNDP DFUN-STATE)| |(BOUNDP FROM-DEFCLASS-P)| |(READER METHOD)| |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)| |(BOUNDP FAST-FUNCTION)| |LISP::COMPLEX class predicate| |(BOUNDP METHOD-CLASS)| |(READER SOURCE)| |(BOUNDP INTERNAL-WRITER-FUNCTION)| |(BOUNDP INTERNAL-READER-FUNCTION)| |(BOUNDP METHOD-COMBINATION)| ACCESSOR-METHOD-CLASS |(BOUNDP DIRECT-SLOTS)| |(BOUNDP DIRECT-METHODS)| |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUBCLASSES)| |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP METHODS)| |(BOUNDP OPTIONS)| |(WRITER METHOD)| |PCL::DEPENDENT-UPDATE-MIXIN class predicate| GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| MAKE-BOUNDP-METHOD-FUNCTION |LISP::STRING class predicate| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |PCL::METAOBJECT class predicate| |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| CLASS-PREDICATE-NAME |PCL::STRUCTURE-OBJECT class predicate| |PCL::STRUCTURE-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| |LISP::SYMBOL class predicate| CLASSP |PCL::EFFECTIVE-SLOT-DEFINITION class predicate| |(COMBINED-METHOD SHARED-INITIALIZE)| LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P |LISP::VECTOR class predicate| |SETF PCL GENERIC-FUNCTION-NAME| |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| |(READER READERS)| DESCRIBE-OBJECT |(READER CLASS-PRECEDENCE-LIST)| |(READER ACCESSOR-FLAGS)| |(READER LOCATION)| |(READER DOCUMENTATION)| CLASS-INITIALIZE-INFO |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION |SETF PCL GF-DFUN-STATE| |(READER INCOMPATIBLE-SUPERCLASS-LIST)| |(READER SPECIALIZERS)| |(READER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF CLASS-INITIALIZE-INFO)| |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)| |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME| |(WRITER READER-FUNCTION)| |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)| |(WRITER PREDICATE-NAME)| |(WRITER READERS)| |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)| INITIALIZE-INTERNAL-SLOT-FUNCTIONS |SETF PCL SLOT-DEFINITION-TYPE| |(WRITER CLASS-PRECEDENCE-LIST)| |(READER WRITERS)| |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| METHOD-COMBINATION-P |(WRITER LOCATION)| |(WRITER DOCUMENTATION)| |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)| |SETF PCL GENERIC-FUNCTION-METHODS| |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| |SETF PCL METHOD-GENERIC-FUNCTION| |(READER SLOT-NAME)| |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL SLOT-ACCESSOR-STD-P| |(CALL REAL-MAKE-METHOD-INITARGS-FORM)| |(READER ALLOCATION)| |(WRITER SPECIALIZERS)| |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)| |(WRITER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF METHOD-GENERIC-FUNCTION)| |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P |SETF PCL OBJECT-PLIST| |LISP::FLOAT class predicate| |(WRITER DEFSTRUCT-FORM)| |(READER FUNCTION)| |(READER GENERIC-FUNCTION)| |(READER LAMBDA-LIST)| |(READER SLOT-DEFINITION)| |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate| |SETF PCL SLOT-DEFINITION-INITFORM| |SETF PCL CLASS-DEFSTRUCT-FORM| |(READER CAN-PRECEDE-LIST)| |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)| |(WRITER INITFUNCTION)| |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P |(WRITER INITFORM)| |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST| |SETF PCL SLOT-ACCESSOR-FUNCTION| |SETF PCL SLOT-DEFINITION-LOCATION| |SETF PCL SLOT-DEFINITION-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-ALLOCATION| |SETF PCL SLOT-DEFINITION-INITFUNCTION| |(WRITER SLOT-NAME)| |(BOUNDP NAME)| |(WRITER ALLOCATION)| |(READER FAST-FUNCTION)| |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| |(READER INTERNAL-WRITER-FUNCTION)| |(READER INTERNAL-READER-FUNCTION)| |(READER METHOD-COMBINATION)| METHOD-COMBINATION-OPTIONS |(READER DIRECT-SLOTS)| |(READER DIRECT-METHODS)| |SETF PCL SLOT-DEFINITION-READERS| |(READER BOUNDP-FUNCTION)| |(WRITER FUNCTION)| |(WRITER GENERIC-FUNCTION)| |(READER DIRECT-SUBCLASSES)| |(READER DIRECT-SUPERCLASSES)| |SETF PCL DOCUMENTATION| |(WRITER LAMBDA-LIST)| |LISP::LIST class predicate| FUNCALLABLE-STANDARD-CLASS-P |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)| |(BOUNDP CLASS)| |(WRITER SLOT-DEFINITION)| |(READER METHODS)| |(READER OPTIONS)| |(WRITER CAN-PRECEDE-LIST)| |SETF PCL SLOT-DEFINITION-CLASS| |SETF PCL SLOT-VALUE-USING-CLASS| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(WRITER PROTOTYPE)| |(BOUNDP OBJECT)| |(BOUNDP TYPE)| CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-DIRECT-SLOTS| |SETF PCL CLASS-SLOTS| SLOT-ACCESSOR-FUNCTION |(BOUNDP PLIST)| |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| |SETF PCL SLOT-DEFINITION-WRITERS| |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)| |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| |(BOUNDP SLOTS)| SLOT-CLASS-P MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)| |PCL::PLIST-MIXIN class predicate| |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)| |(WRITER INTERNAL-WRITER-FUNCTION)| |(WRITER INTERNAL-READER-FUNCTION)| |(WRITER METHOD-COMBINATION)| GET-METHOD |(WRITER DIRECT-SLOTS)| |(WRITER DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUBCLASSES)| |(WRITER DIRECT-SUPERCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(WRITER METHODS)| |(WRITER OPTIONS)| SHORT-METHOD-COMBINATION-P GF-ARG-INFO SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM CLASS-DEFSTRUCT-FORM |LISP::INTEGER class predicate| |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-READER-METHOD CLASS PREDICATE-NAME)| |(FAST-READER-METHOD CLASS NAME)| |(FAST-READER-METHOD SLOT-DEFINITION NAME)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)| |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-READER-METHOD SLOT-OBJECT NAME)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)| GF-PRETTY-ARGLIST SAME-SPECIALIZER-P SLOT-DEFINITION-BOUNDP-FUNCTION SLOT-DEFINITION-WRITER-FUNCTION SLOT-DEFINITION-READER-FUNCTION SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION SLOT-DEFINITION-INTERNAL-READER-FUNCTION |(FAST-READER-METHOD SLOT-OBJECT CLASS)| |(FAST-READER-METHOD SLOT-DEFINITION CLASS)| |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD TRACED-METHOD FUNCTION)| |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT LOCATION)| |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)| |(FAST-READER-METHOD SLOT-OBJECT WRITERS)| |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-READER-METHOD SLOT-OBJECT READERS)| |(FAST-READER-METHOD SLOT-DEFINITION READERS)| |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SPECIALIZER TYPE)| |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)| |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)| |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT OBJECT)| |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-DEFINITION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT TYPE)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-READER-METHOD SLOT-OBJECT INITFORM)| |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-READER-METHOD SLOT-OBJECT PLIST)| |(FAST-READER-METHOD PLIST-MIXIN PLIST)| |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)| |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-READER-METHOD SLOT-OBJECT SLOTS)| |(FAST-READER-METHOD SLOT-CLASS SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-READER-METHOD SLOT-OBJECT METHODS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)| SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT |PCL::DIRECT-SLOT-DEFINITION class predicate| CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)| |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-DIRECT-GENERIC-FUNCTIONS |(BOUNDP CLASS-EQ-SPECIALIZER)| |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)| |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)| |(SETF SLOT-VALUE-USING-CLASS)| |(SETF SLOT-DEFINITION-CLASS)| |(SETF SLOT-ACCESSOR-FUNCTION)| |(SETF SLOT-DEFINITION-INITFUNCTION)| |(SETF SLOT-DEFINITION-ALLOCATION)| |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-READER-FUNCTION)| |(SETF SLOT-DEFINITION-LOCATION)| |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(SETF SLOT-DEFINITION-WRITERS)| |(SETF SLOT-DEFINITION-READERS)| |(SETF SLOT-DEFINITION-TYPE)| |(SETF SLOT-DEFINITION-INITFORM)| |(BOUNDP INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION GENERIC-FUNCTION-P |PCL::SLOT-DEFINITION class predicate| |LISP::NULL class predicate| |(READER NAME)| |(READER CLASS)| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD SLOT-MISSING (T T T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| LEGAL-SLOT-NAME-P |(READER OBJECT)| |(READER TYPE)| CLASS-WRAPPER |(READER PLIST)| |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER OBJECT)| |(WRITER TYPE)| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| |(WRITER PLIST)| |(WRITER SLOTS)| |PCL::DOCUMENTATION-MIXIN class predicate| FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P LEGAL-QUALIFIER-P METHOD-P |PCL::SPECIALIZER-WITH-OBJECT class predicate| CLASS-SLOT-CELLS |(COMBINED-METHOD INITIALIZE-INSTANCE)| |(COMBINED-METHOD REINITIALIZE-INSTANCE)| STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| STANDARD-GENERIC-FUNCTION-P STANDARD-READER-METHOD-P STANDARD-METHOD-P |(READER WRAPPER)| |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| |(READER CLASS-EQ-SPECIALIZER)| COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS COMPUTE-DEFAULT-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)| |(CALL REAL-MAKE-METHOD-LAMBDA)| |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-SLOTS)| |(SETF CLASS-DIRECT-SLOTS)| |(READER OPERATOR)| |(CALL REAL-GET-METHOD)| |(CALL REAL-REMOVE-METHOD)| |(CALL REAL-ADD-METHOD)| |(READER ARG-INFO)| METHOD-COMBINATION-TYPE |(READER DEFSTRUCT-CONSTRUCTOR)| |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)| STANDARD-CLASS-P |LISP::NUMBER class predicate| LEGAL-SPECIALIZER-P |PCL::LONG-METHOD-COMBINATION class predicate| |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)| |(WRITER CLASS-EQ-SPECIALIZER)| STANDARD-BOUNDP-METHOD-P |(SETF DOCUMENTATION)| RAW-INSTANCE-ALLOCATOR |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| |SETF PCL CLASS-INITIALIZE-INFO| |(WRITER OPERATOR)| |(WRITER ARG-INFO)| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO STANDARD-WRITER-METHOD-P CLASS-INCOMPATIBLE-SUPERCLASS-LIST |(WRITER DEFSTRUCT-CONSTRUCTOR)| |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER MAKE-A-METHOD |(WRITER INITIALIZE-INFO)| METHOD-COMBINATION-DOCUMENTATION |SETF PCL SLOT-DEFINITION-INITARGS| REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD |LISP::CONS class predicate| |(WRITER INITARGS)| |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| |(BOUNDP METHOD)| |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-WRITER-METHOD CLASS NAME)| |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-WRITER-METHOD SLOT-OBJECT NAME)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)| |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)| SHORT-COMBINATION-OPERATOR |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)| |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)| |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-WRITER-METHOD SLOT-OBJECT READERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)| |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)| |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)| REMOVE-NAMED-METHOD |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)| |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE READER-METHOD-CLASS REMOVE-METHOD SLOT-DEFINITION-INITFORM UPDATE-INSTANCE-FOR-REDEFINED-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P GENERIC-FUNCTION-NAME REMOVE-DEPENDENT COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION SHARED-INITIALIZE ADD-DIRECT-METHOD SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-ALLOCATION ADD-METHOD GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE SLOT-MAKUNBOUND-USING-CLASS ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD SLOT-DEFINITION-WRITERS COMPUTE-APPLICABLE-METHODS-USING-CLASSES CLASS-PRECEDENCE-LIST)) (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl-2.6.14/pcl/impl/gcl/makefile.gcl0000644000175000017500000000177214360276512015532 0ustar cammcamm# makefile for making pcl -- W. Schelter. # Directions: # make -f makefile.gcl compile # make -f makefile.gcl saved_pcl LISP=gcl SETUP='(load "sys-package.lisp")' \ '(setq *features* (delete (quote kcl) *features*))'\ '(load "defsys.lisp")(push (quote kcl) *features*)' \ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ '(load "sys-proclaim.lisp")(compiler::emit-fn t)' compile: echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} saved_pcl: echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} # remake the sys-package.lisp and sys-proclaim.lisp files # Those files may be empty on a first build. remake-sys-files: echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} cp sys-proclaim.lisp xxx cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp rm xxx tar: make -f makefile.gcl tar1 DIR=`pwd` tar1: (cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz) gcl-2.6.14/pcl/impl/gcl/README0000644000175000017500000000045114360276512014137 0ustar cammcammIncludes changes for gcl version 2.0 by W. Schelter To compile ln -s impl/gcl/makefile.gcl makefile.gcl ln -s impl/gcl/sys-package.lisp sys-package.lisp ln -s impl/gcl/sys-proclaim.lisp sys-proclaim.lisp make -f makefile.gcl compile Then to make saved version make -f makefile.gcl saved_pcl gcl-2.6.14/pcl/impl/vaxlisp/0000755000175000017500000000000014360276512014200 5ustar cammcammgcl-2.6.14/pcl/impl/vaxlisp/vaxl-low.lisp0000644000175000017500000000513214360276512016643 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for VAXLisp ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () `(when (null outer-scheduling-state) (setq system::*critical-section-p* nil) (when (system::%sp-interrupt-queued-p) (system::interrupt-dequeuer t)))) (interrupts-off () `(setq system::*critical-section-p* t))) (let ((outer-scheduling-state system::*critical-section-p*)) (prog1 (let ((system::*critical-section-p* t)) ,@body) (when (and (null outer-scheduling-state) (system::%sp-interrupt-queued-p)) (system::interrupt-dequeuer t)))))) ;; ;;;;;; Load Time Eval ;; (defmacro load-time-eval (form) `(progn ,form)) ;; ;;;;;; Generating CACHE numbers ;; ;;; How are symbols in VAXLisp actually arranged in memory? ;;; Should we be shifting the address? ;;; Are they relocated? ;;; etc. ;(defmacro symbol-cache-no (symbol mask) ; `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask)) (defmacro object-cache-no (object mask) `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (system::%sp-pointer->fixnum thing))) (defun function-arglist (fn) (system::function-lambda-vars (symbol-function fn))) (defun set-function-name-1 (fn name ignore) (cond ((system::slisp-compiled-function-p fn) (system::%sp-b-store fn 3 name))) fn) gcl-2.6.14/pcl/impl/ti/0000755000175000017500000000000014360276512013126 5ustar cammcammgcl-2.6.14/pcl/impl/ti/ti-patches.lisp0000644000175000017500000000763114360276512016067 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; ;;; This little bit of magic keeps the dumper from dumping the lexical ;;; definition of call-next-method when it dumps method functions that ;;; come from defmethod forms. ;;; (proclaim '(notinline nil)) (eval-when (load) (setf (get 'function 'si:type-predicate) 'functionp)) ;; fix defsetf to deal with do-standard-defsetf #!C ; From file SETF.LISP#> KERNEL; VIRGO: #8R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#" (defmacro defsetf (access-function arg1 &optional arg2 &environment env &body body) "Define a SETF expander for ACCESS-FUNCTION. DEFSETF has two forms: The simple form (DEFSETF access-function update-function [doc-string]) can be used as follows: After (DEFSETF GETFROB PUTFROB), \(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO). The complex form is like DEFMACRO: \(DEFSETF access-function access-lambda-list newvalue-lambda-list body...) except there are TWO lambda-lists. The first one represents the argument forms to the ACCESS-FUNCTION. Only &OPTIONAL and &REST are allowed here. The second has only one argument, representing the value to be stored. The body of the DEFSETF definition must then compute a replacement for the SETF form, just as for any other macro. When the body is executed, the args in the lambda-lists will not really contain the value-expression or parts of the form to be set; they will contain gensymmed variables which SETF may or may not eliminate by substitution." ;; REF and VAL are arguments to the expansion function (if (null body) `(defdecl ,access-function setf-method ,arg1) (multiple-value-bind (body decls doc-string) (parse-body body env t) (let* ((access-ll arg1) (value-names arg2) (expansion (let (all-arg-names) (dolist (x access-ll) (cond ((symbolp x) (if (not (member x lambda-list-keywords :test #'eq)) (push x all-arg-names) (when (eq x '&rest) (return)))) ;;9/20/88 clm (t ; it's a list after &optional (push (car x) all-arg-names)))) (setq all-arg-names (reverse all-arg-names)) `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names)) (storevar (gensym))) (values tempvars (list . ,all-arg-names) (list storevar) (let ((,(car value-names) storevar) . ,(loop for arg in all-arg-names for i = 0 then (1+ i) collect `(,arg (nth ,i tempvars)))) ,@decls . ,body) `(,',access-function . ,tempvars)))))) `(define-setf-method ,access-function ,arg1 ,@doc-string ,expansion) )))) )) gcl-2.6.14/pcl/impl/ti/ti-low.lisp0000644000175000017500000000557614360276512015247 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 3600 version of the file portable-low. ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(let ((outer-scheduling-state si:inhibit-scheduling-flag) (si:inhibit-scheduling-flag t)) (macrolet ((interrupts-on () '(when (null outer-scheduling-state) (setq si:inhibit-scheduling-flag nil))) (interrupts-off () '(setq si:inhibit-scheduling-flag t))) ,.body))) (si:defsubst std-instance-p (x) (si:typep-structure-or-flavor x 'std-instance)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:%pointer thing))) (eval-when (compile load eval) ;There seems to be some bug with (setq si::inhibit-displacing-flag t)) ;macrolet'd macros or something. ;This gets around it but its not ;really the right fix. (defun function-arglist (f) (sys::arglist f t)) (defun record-definition (type spec &rest ignore) (if (eql type 'method) (sys:record-source-file-name spec 'defun :no-query) (sys:record-source-file-name spec type :no-query))) (ticl:defprop method method-function-spec-handler sys:function-spec-handler) (defun method-function-spec-handler (function function-spec &optional arg1 arg2) (let ((symbol (second function-spec))) (case function (sys:validate-function-spec t) (otherwise (sys:function-spec-default-handler function function-spec arg1 arg2))))) ;;;Edited by Reed Hastings 13 Aug 87 16:59 ;;;Edited by Reed Hastings 2 Nov 87 22:58 (defun set-function-name (function new-name) (when (si:get-debug-info-struct function) (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name) new-name)) function) gcl-2.6.14/pcl/pcl_methods.patch0000644000175000017500000000045114360276512015073 0ustar cammcamm--- pcl_methods.c Tue Feb 25 12:06:29 2003 +++ pcl_methods.c.new Wed Feb 26 13:07:22 2003 @@ -8110,7 +8110,7 @@ { register object *base=vs_base; register object *sup=base+VM122; VC122 vs_check; - {register object V1409; + {VOL object V1409; object V1410; check_arg(2); V1409=(base[0]); gcl-2.6.14/pcl/gcl_pcl_fast_init.lisp0000644000175000017500000011562214360276512016114 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; This file defines the optimized make-instance functions. ;;; (in-package :pcl) (defvar *compile-make-instance-functions-p* nil) (defun update-make-instance-function-table (&optional (class *the-class-t*)) (when (symbolp class) (setq class (find-class class))) (when (eq class *the-class-t*) (setq class *the-class-slot-object*)) (when (memq *the-class-slot-object* (class-precedence-list class)) (map-all-classes #'reset-class-initialize-info class))) (defun constant-symbol-p (form) (and (constantp form) (let ((object (eval form))) (and (symbolp object) (symbol-package object))))) (defvar *make-instance-function-keys* nil) (defun expand-make-instance-form (form) (let ((class (cadr form)) (initargs (cddr form)) (keys nil)(allow-other-keys-p nil) key value) (when (and (constant-symbol-p class) (let ((initargs-tail initargs)) (loop (when (null initargs-tail) (return t)) (unless (constant-symbol-p (car initargs-tail)) (return nil)) (setq key (eval (pop initargs-tail))) (setq value (pop initargs-tail)) (when (eq ':allow-other-keys key) (setq allow-other-keys-p value)) (push key keys)))) (let* ((class (eval class)) (keys (nreverse keys)) (key (list class keys allow-other-keys-p)) (sym (make-instance-function-symbol key))) (push key *make-instance-function-keys*) (when sym `(,sym ',class ,@initargs)))))) (defmacro expanding-make-instance-top-level (&rest forms &environment env) (let* ((*make-instance-function-keys* nil) (form (macroexpand `(expanding-make-instance ,@forms) env))) `(progn ,@(when *make-instance-function-keys* `((get-make-instance-functions ',*make-instance-function-keys*))) ,form))) (defmacro expanding-make-instance (&rest forms &environment env) `(progn ,@(mapcar #'(lambda (form) (walk-form form env #'(lambda (subform context env) (declare (ignore env)) (or (and (eq context ':eval) (consp subform) (eq (car subform) 'make-instance) (expand-make-instance-form subform)) subform)))) forms))) (defmacro defconstructor (name class lambda-list &rest initialization-arguments) `(expanding-make-instance-top-level (defun ,name ,lambda-list (make-instance ',class ,@initialization-arguments)))) (defun get-make-instance-functions (key-list) (dolist (key key-list) (let* ((cell (find-class-cell (car key))) (make-instance-function-keys (find-class-cell-make-instance-function-keys cell)) (mif-key (cons (cadr key) (caddr key)))) (unless (find mif-key make-instance-function-keys :test #'equal) (push mif-key (find-class-cell-make-instance-function-keys cell)) (let ((class (find-class-cell-class cell))) (when (and class (not (forward-referenced-class-p class))) (update-initialize-info-internal (initialize-info class (car mif-key) nil (cdr mif-key)) 'make-instance-function))))))) (defun make-instance-function-symbol (key) (let* ((class (car key)) (symbolp (symbolp class))) (when (or symbolp (classp class)) (let* ((class-name (if (symbolp class) class (class-name class))) (keys (cadr key)) (allow-other-keys-p (caddr key))) (when (and (or symbolp (and (symbolp class-name) (eq class (find-class class-name nil)))) (symbol-package class-name)) (let ((*package* *the-pcl-package*) (*print-length* nil) (*print-level* nil) (*print-circle* nil) (*print-case* :upcase) (*print-pretty* nil)) (intern (format nil "MAKE-INSTANCE ~S ~S ~S" class-name keys allow-other-keys-p)))))))) (defun make-instance-1 (class &rest initargs) (apply #'make-instance class initargs)) (defmacro define-cached-reader (type name trap) (let ((reader-name (intern (format nil "~A-~A" type name))) (cached-name (intern (format nil "~A-CACHED-~A" type name)))) `(defmacro ,reader-name (info) `(let ((value (,',cached-name ,info))) (if (eq value ':unknown) (progn (,',trap ,info ',',name) (,',cached-name ,info)) value))))) (eval-when (compile load eval) (defparameter initialize-info-cached-slots '(valid-p ; t or (:invalid key) ri-valid-p initargs-form-list combined-initargs-form-list new-keys default-initargs-function shared-initialize-t-function shared-initialize-nil-function constants combined-initialize-function ; allocate-instance + shared-initialize make-instance-function ; nil means use gf make-instance-function-symbol))) (defmacro define-initialize-info () (let ((cached-slot-names (mapcar #'(lambda (name) (intern (format nil "CACHED-~A" name))) initialize-info-cached-slots)) (cached-names (mapcar #'(lambda (name) (intern (format nil "~A-CACHED-~A" 'initialize-info name))) initialize-info-cached-slots))) `(progn (defstruct initialize-info key wrapper ,@(mapcar #'(lambda (name) `(,name :unknown)) cached-slot-names)) (defmacro reset-initialize-info-internal (info) `(progn ,@(mapcar #'(lambda (cname) `(setf (,cname ,info) ':unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) ,@(mapcar #'(lambda (name cached-name) `(unless (eq ':unknown (,cached-name info)) (push ',name slots))) initialize-info-cached-slots cached-names) slots)) ,@(mapcar #'(lambda (name) `(define-cached-reader initialize-info ,name update-initialize-info-internal)) initialize-info-cached-slots)))) (define-initialize-info) (defvar *initialize-info-cache-class* nil) (defvar *initialize-info-cache-initargs* nil) (defvar *initialize-info-cache-info* nil) (defvar *revert-initialize-info-p* nil) (defun reset-initialize-info (info) (setf (initialize-info-wrapper info) (class-wrapper (car (initialize-info-key info)))) (let ((slots-to-revert (if *revert-initialize-info-p* (initialize-info-bound-slots info) '(make-instance-function)))) (reset-initialize-info-internal info) (dolist (slot slots-to-revert) (update-initialize-info-internal info slot)) info)) (defun reset-class-initialize-info (class) (reset-class-initialize-info-1 (class-initialize-info class))) (defun reset-class-initialize-info-1 (cell) (when (consp cell) (when (car cell) (reset-initialize-info (car cell))) (let ((alist (cdr cell))) (dolist (a alist) (reset-class-initialize-info-1 (cdr a)))))) (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) (let ((info nil)) (if (and (eq *initialize-info-cache-class* class) (eq *initialize-info-cache-initargs* initargs)) (setq info *initialize-info-cache-info*) (let ((initargs-tail initargs) (cell (or (class-initialize-info class) (setf (class-initialize-info class) (cons nil nil))))) (loop (when (null initargs-tail) (return nil)) (let ((keyword (pop initargs-tail)) (alist-cell cell)) (when plist-p (if (eq keyword :allow-other-keys) (setq allow-other-keys-arg (pop initargs-tail)) (pop initargs-tail))) (loop (let ((alist (cdr alist-cell))) (when (null alist) (setq cell (cons nil nil)) (setf (cdr alist-cell) (list (cons keyword cell))) (return nil)) (when (eql keyword (caar alist)) (setq cell (cdar alist)) (return nil)) (setq alist-cell alist))))) (setq info (or (car cell) (setf (car cell) (make-initialize-info)))))) (let ((wrapper (initialize-info-wrapper info))) (unless (eq wrapper (class-wrapper class)) (unless wrapper (let* ((initargs-tail initargs) (klist-cell (list nil)) (klist-tail klist-cell)) (loop (when (null initargs-tail) (return nil)) (let ((key (pop initargs-tail))) (setf (cdr klist-tail) (list key))) (setf klist-tail (cdr klist-tail)) (when plist-p (pop initargs-tail))) (setf (initialize-info-key info) (list class (cdr klist-cell) allow-other-keys-arg)))) (reset-initialize-info info))) (setq *initialize-info-cache-class* class) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* info) info)) (defun update-initialize-info-internal (info name) (let* ((key (initialize-info-key info)) (class (car key)) (keys (cadr key)) (allow-other-keys-arg (caddr key))) (ecase name ((initargs-form-list new-keys) (multiple-value-bind (initargs-form-list new-keys) (make-default-initargs-form-list class keys) (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) (setf (initialize-info-cached-new-keys info) new-keys))) ((combined-initargs-form-list) (multiple-value-bind (initargs-form-list new-keys) (make-default-initargs-form-list class keys nil) (setf (initialize-info-cached-combined-initargs-form-list info) initargs-form-list) (setf (initialize-info-cached-new-keys info) new-keys))) ((default-initargs-function) (let ((initargs-form-list (initialize-info-initargs-form-list info))) (setf (initialize-info-cached-default-initargs-function info) (initialize-instance-simple-function 'default-initargs-function info class initargs-form-list)))) ((valid-p ri-valid-p) (flet ((compute-valid-p (methods) (or (not (null allow-other-keys-arg)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class methods) (or (not (null allow-other-keys)) (dolist (key keys t) (unless (member key legal) (return (cons :invalid key))))))))) (let ((proto (class-prototype class))) (setf (initialize-info-cached-valid-p info) (compute-valid-p (list (list* 'allocate-instance class nil) (list* 'initialize-instance proto nil) (list* 'shared-initialize proto t nil)))) (setf (initialize-info-cached-ri-valid-p info) (compute-valid-p (list (list* 'reinitialize-instance proto nil) (list* 'shared-initialize proto nil nil))))))) ((shared-initialize-t-function) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys t nil) (declare (ignore ignore)) (setf (initialize-info-cached-shared-initialize-t-function info) (initialize-instance-simple-function 'shared-initialize-t-function info class initialize-form-list)))) ((shared-initialize-nil-function) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys nil nil) (declare (ignore ignore)) (setf (initialize-info-cached-shared-initialize-nil-function info) (initialize-instance-simple-function 'shared-initialize-nil-function info class initialize-form-list)))) ((constants combined-initialize-function) (let ((initargs-form-list (initialize-info-combined-initargs-form-list info)) (new-keys (initialize-info-new-keys info))) (multiple-value-bind (initialize-form-list constants) (make-shared-initialize-form-list class new-keys t t) (setf (initialize-info-cached-constants info) constants) (setf (initialize-info-cached-combined-initialize-function info) (initialize-instance-simple-function 'combined-initialize-function info class (append initargs-form-list initialize-form-list)))))) ((make-instance-function-symbol) (setf (initialize-info-cached-make-instance-function-symbol info) (make-instance-function-symbol key))) ((make-instance-function) (let* ((function (get-make-instance-function key)) (symbol (initialize-info-make-instance-function-symbol info))) (setf (initialize-info-cached-make-instance-function info) function) (when symbol (setf (gdefinition symbol) (or function #'make-instance-1))))))) info) (defun get-make-instance-function (key) (let* ((class (car key)) (keys (cadr key))) (unless (eq *boot-state* 'complete) (return-from get-make-instance-function nil)) (when (symbolp class) (setq class (find-class class))) (when (classp class) (unless (class-finalized-p class) (finalize-inheritance class))) (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) (class-and-initargs (list* class initargs)) (make-instance (gdefinition 'make-instance)) (make-instance-methods (compute-applicable-methods make-instance class-and-initargs)) (std-mi-meth (find-standard-ii-method make-instance-methods 'class)) (class+initargs (list class initargs)) (default-initargs (gdefinition 'default-initargs)) (default-initargs-methods (compute-applicable-methods default-initargs class+initargs)) (proto (and (classp class) (class-prototype class))) (initialize-instance-methods (when proto (compute-applicable-methods (gdefinition 'initialize-instance) (list* proto initargs)))) (shared-initialize-methods (when proto (compute-applicable-methods (gdefinition 'shared-initialize) (list* proto t initargs))))) (when (null make-instance-methods) (return-from get-make-instance-function #'(lambda (class &rest initargs) (apply #'no-applicable-method make-instance class initargs)))) (unless (and (null (cdr make-instance-methods)) (eq (car make-instance-methods) std-mi-meth) (null (cdr default-initargs-methods)) (eq (car (method-specializers (car default-initargs-methods))) *the-class-slot-class*) (flet ((check-meth (meth) (let ((quals (method-qualifiers meth))) (if (null quals) (eq (car (method-specializers meth)) *the-class-slot-object*) (and (null (cdr quals)) (or (eq (car quals) ':before) (eq (car quals) ':after))))))) (and (every #'check-meth initialize-instance-methods) (every #'check-meth shared-initialize-methods)))) (return-from get-make-instance-function nil)) (get-make-instance-function-internal class key (default-initargs class initargs) initialize-instance-methods shared-initialize-methods)))) (defun get-make-instance-function-internal (class key initargs initialize-instance-methods shared-initialize-methods) (let* (#|(class-key (car key))|# (keys (cadr key)) (allow-other-keys-p (caddr key)) (allocate-instance-methods (compute-applicable-methods (gdefinition 'allocate-instance) (list* class initargs)))) (unless allow-other-keys-p (unless (check-initargs-1 class initargs (append allocate-instance-methods initialize-instance-methods shared-initialize-methods) t nil) (return-from get-make-instance-function-internal nil))) (cond ((or (cdr allocate-instance-methods) (some #'complicated-instance-creation-method initialize-instance-methods) (some #'complicated-instance-creation-method shared-initialize-methods)) (make-instance-function-complex key class keys initialize-instance-methods shared-initialize-methods)) (t #|(or (not (standard-class-p class)) (not (symbolp class-key)) initialize-instance-methods shared-initialize-methods)|# (make-instance-function-simple key class keys initialize-instance-methods shared-initialize-methods)) #|(t (make-instance-function-basic key class keys))|#))) (defun complicated-instance-creation-method (m) (let ((qual (method-qualifiers m))) (if qual (not (and (null (cdr qual)) (eq (car qual) ':after))) (let ((specl (car (method-specializers m)))) (or (not (classp specl)) (not (eq 'slot-object (class-name specl)))))))) (defun find-standard-ii-method (methods class-names) (dolist (m methods) (when (null (method-qualifiers m)) (let ((specl (car (method-specializers m)))) (when (and (classp specl) (if (listp class-names) (member (class-name specl) class-names) (eq (class-name specl) class-names))) (return m)))))) (defmacro call-initialize-function (initialize-function instance initargs) `(let ((.function. ,initialize-function)) (if (and (consp .function.) (eq (car .function.) 'call-initialize-instance-simple)) (initialize-instance-simple (cadr .function.) (caddr .function.) ,instance ,initargs) (funcall (the function .function.) ,instance ,initargs)))) (defmacro copy-slots (slots-init) #-(or lucid cmu17) `(copy-seq ,slots-init) #+(or lucid cmu17) `(let* ((init ,slots-init) (len (length init)) (v #+lucid (system:new-simple-vector len) #+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len))) (declare (simple-vector init v) (type #-cmu fixnum #+cmu lisp::index len)) (dotimes (i len v) (declare (type #-cmu fixnum #+cmu lisp::index i)) (setf (svref v i) (svref init i))))) (defmacro allocate-standard-instance--macro (wrapper slots-init) #-new-kcl-wrapper `(let ((instance (%%allocate-instance--class))) (setf (std-instance-wrapper instance) ,wrapper) (setf (std-instance-slots instance) (copy-slots ,slots-init)) instance) #+new-kcl-wrapper `(allocate-standard-instance ,wrapper ,slots-init)) (defmacro with-make-instance-function-valid-p-check (initargs-form &body body) `(let ((current-class (if class-cell (find-class-from-cell class-key class-cell) class-symbol))) (if (or (not (eq current-class class-symbol)) (invalid-wrapper-p wrapper)) (make-instance-function-trap current-class ,initargs-form) (progn ,@body)))) (defun make-instance-function-trap (class-symbol initargs) (let* ((info (initialize-info class-symbol initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class-symbol initargs))) (defun make-instance-function-simple (key class keys initialize-instance-methods shared-initialize-methods) (let* ((class-key (car key)) (class-cell (when (symbolp class-key) (find-class-cell class-key nil))) (wrapper (class-wrapper class)) (lwrapper (list wrapper)) (allocate-function (cond ((structure-class-p class) #'allocate-structure-instance) ((standard-class-p class) #'allocate-standard-instance) ((funcallable-standard-class-p class) #'allocate-funcallable-instance) (t (error "error in make-instance-function-simple")))) (allocate-macro (cond ((standard-class-p class) 'allocate-standard-instance--macro))) (std-si-meth (find-standard-ii-method shared-initialize-methods 'slot-object)) (shared-initfns (nreverse (mapcar #'(lambda (method) (make-effective-method-function #'shared-initialize `(call-method ,method nil) nil lwrapper)) (remove std-si-meth shared-initialize-methods)))) (std-ii-meth (find-standard-ii-method initialize-instance-methods 'slot-object)) (initialize-initfns (nreverse (mapcar #'(lambda (method) (make-effective-method-function #'initialize-instance `(call-method ,method nil) nil lwrapper)) (remove std-ii-meth initialize-instance-methods))))) (multiple-value-bind (initialize-function constants) (get-simple-initialization-function class keys (caddr key)) (if (eq allocate-macro 'allocate-standard-instance--macro) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let ((instance (allocate-standard-instance--macro wrapper constants))) (call-initialize-function initialize-function instance initargs) (dolist (fn shared-initfns) (invoke-effective-method-function fn t instance t initargs)) (dolist (fn initialize-initfns) (invoke-effective-method-function fn t instance initargs)) instance))) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let* ((instance (funcall allocate-function wrapper constants)) (initargs (call-initialize-function initialize-function instance initargs))) (dolist (fn shared-initfns) (invoke-effective-method-function fn t instance t initargs)) (dolist (fn initialize-initfns) (invoke-effective-method-function fn t instance initargs)) instance))))))) (defun make-instance-function-complex (key class keys initialize-instance-methods shared-initialize-methods) (multiple-value-bind (initargs-function initialize-function) (get-complex-initialization-functions class keys (caddr key)) (let* ((class-key (car key)) (class-cell (when (symbolp class-key) (find-class-cell class-key nil))) (wrapper (class-wrapper class)) (shared-initialize (get-secondary-dispatch-function #'shared-initialize shared-initialize-methods `((class-eq ,class) t t) `((,(find-standard-ii-method shared-initialize-methods 'slot-object) ,#'(lambda (instance init-type &rest initargs) (declare (ignore init-type)) #+copy-&rest-arg (setq initargs (copy-list initargs)) (call-initialize-function initialize-function instance initargs) instance))) (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) (initialize-instance (get-secondary-dispatch-function #'initialize-instance initialize-instance-methods `((class-eq ,class) t) `((,(find-standard-ii-method initialize-instance-methods 'slot-object) ,#'(lambda (instance &rest initargs) #+copy-&rest-arg (setq initargs (copy-list initargs)) (invoke-effective-method-function shared-initialize t instance t initargs)))) (list wrapper *the-wrapper-of-t*)))) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let* ((initargs (call-initialize-function initargs-function nil initargs)) (instance (apply #'allocate-instance class initargs))) (invoke-effective-method-function initialize-instance t instance initargs) instance)))))) #| (defmacro call-initialize-function (initialize-function instance initargs) `(let ((.function. ,initialize-function)) (if (and (consp .function.) (eq (car .function.) 'call-initialize-instance-simple)) (initialize-instance-simple (cadr .function.) (caddr .function.) ,instance ,initargs) (funcall (the function .function.) ,instance ,initargs)))) (defun make-instance-function-basic (key class keys) (let* ((class-key (car key)) (class-cell (find-class-cell class-key nil)) (wrapper (class-wrapper class))) (multiple-value-bind (initialize-function constants) (get-simple-initialization-function class keys (caddr key)) #'(lambda (class-symbol &rest initargs) (let ((current-class (find-class-from-cell class-key class-cell))) (if (or (not (eq current-class class-symbol)) (invalid-wrapper-p wrapper)) (make-instance-function-trap current-class initargs-form) (let ((instance (allocate-standard-instance--macro wrapper constants))) (call-initialize-function initialize-function instance initargs) instance))))))) |# (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) (let ((info (initialize-info class keys nil allow-other-keys-arg))) (values (initialize-info-combined-initialize-function info) (initialize-info-constants info)))) (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg separate-p) (let* ((info (initialize-info class keys nil allow-other-keys-arg)) (default-initargs-function (initialize-info-default-initargs-function info))) (if separate-p (values default-initargs-function (initialize-info-shared-initialize-t-function info)) (values default-initargs-function (initialize-info-shared-initialize-t-function (initialize-info class (initialize-info-new-keys info) nil allow-other-keys-arg)))))) (defun add-forms (forms forms-list) (when forms (setq forms (copy-list forms)) (if (null (car forms-list)) (setf (car forms-list) forms) (setf (cddr forms-list) forms)) (setf (cdr forms-list) (last forms))) (car forms-list)) (defun make-default-initargs-form-list (class keys &optional (separate-p t)) (let ((initargs-form-list (cons nil nil)) (default-initargs (class-default-initargs class)) (nkeys keys) (slots-alist (mapcan #'(lambda (slot) (mapcar #'(lambda (arg) (cons arg slot)) (slot-definition-initargs slot))) (class-slots class))) (nslots nil)) (dolist (key nkeys) (pushnew (cdr (assoc key slots-alist)) nslots)) (dolist (default default-initargs) (let* ((key (car default)) (slot (cdr (assoc key slots-alist))) (function (cadr default))) (unless (member slot nslots) (add-forms `((funcall ,function) (push-initarg ,key)) initargs-form-list) (push key nkeys) (push slot nslots)))) (when separate-p (add-forms `((update-initialize-info-cache ,class ,(initialize-info class nkeys nil))) initargs-form-list)) (add-forms `((finish-pushing-initargs)) initargs-form-list) (values (car initargs-form-list) nkeys))) (defun make-shared-initialize-form-list (class keys si-slot-names simple-p) (let* ((initialize-form-list (cons nil nil)) (type (cond ((structure-class-p class) 'structure) ((standard-class-p class) 'standard) ((funcallable-standard-class-p class) 'funcallable) (t (error "error in make-shared-initialize-form-list")))) (wrapper (class-wrapper class)) (constants (when simple-p (make-array (wrapper-no-of-instance-slots wrapper) ':initial-element *slot-unbound*))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) (slots-key (mapcar #'(lambda (slot) (let ((index most-positive-fixnum)) (dolist (key (slot-definition-initargs slot)) (let ((pos (position key keys))) (when pos (setq index (min index pos))))) (cons slot index))) slots)) (slots (stable-sort slots-key #'< :key #'cdr))) (let ((n-popped 0)) (declare (fixnum n-popped)) (dolist (slot+index slots) (let* ((slot (car slot+index)) (name (slot-definition-name slot)) (npop (1+ (- (the fixnum (cdr slot+index)) n-popped)))) (declare (fixnum npop)) (unless (eql (cdr slot+index) most-positive-fixnum) (let* ((pv-offset (1+ (position name slot-names)))) (add-forms `(,@(when (plusp npop) `((pop-initargs ,(the fixnum (* 2 npop))))) (instance-set ,pv-offset ,slot)) initialize-form-list)) (incf n-popped npop))))) (dolist (slot+index slots) (let* ((slot (car slot+index)) (name (slot-definition-name slot))) (when (and (eql (cdr slot+index) most-positive-fixnum) (or (eq si-slot-names 't) (member name si-slot-names))) (let* ((initform (slot-definition-initform slot)) (initfunction (slot-definition-initfunction slot)) (location (unless (eq type 'structure) (slot-definition-location slot))) (pv-offset (1+ (position name slot-names))) (forms (cond ((null initfunction) nil) ((constantp initform) (let ((value (funcall initfunction))) (if (and simple-p (integerp location)) (progn (setf (svref constants location) value) nil) `((const ,value) (instance-set ,pv-offset ,slot))))) (t `((funcall ,(slot-definition-initfunction slot)) (instance-set ,pv-offset ,slot)))))) (add-forms `(,@(unless (or simple-p (null forms)) `((skip-when-instance-boundp ,pv-offset ,slot ,(length forms)))) ,@forms) initialize-form-list))))) (values (car initialize-form-list) constants))) (defvar *class-pv-table-table* (make-hash-table :test 'eq)) (defun get-pv-cell-for-class (class) (let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) (slot-name-lists (list (cons nil slot-names))) (pv-table (gethash class *class-pv-table-table*))) (unless (and pv-table (equal slot-name-lists (pv-table-slot-name-lists pv-table))) (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) (setf (gethash class *class-pv-table-table*) pv-table)) (pv-table-lookup pv-table (class-wrapper class)))) (defvar *initialize-instance-simple-alist* nil) (defvar *note-iis-entry-p* nil) (defvar *compiled-initialize-instance-simple-functions* (make-hash-table :test #'equal)) (defun initialize-instance-simple-function (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) (key (initialize-info-key info)) (sf-key (list* use (class-name (car key)) (cdr key)))) (if (or *compile-make-instance-functions-p* (gethash sf-key *compiled-initialize-instance-simple-functions*)) (multiple-value-bind (form args) (form-list-to-lisp pv-cell form-list) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (setf (gethash sf-key *compiled-initialize-instance-simple-functions*) t) (if entry (setf (cdddr entry) (union (list sf-key) (cdddr entry) :test #'equal)) (progn (setq entry (list* form nil nil (list sf-key))) (setq *initialize-instance-simple-alist* (nconc *initialize-instance-simple-alist* (list entry))))) (unless (or *note-iis-entry-p* (cadr entry)) (setf (cadr entry) (compile-lambda (car entry)))) (if (cadr entry) (apply (the function (cadr entry)) args) `(call-initialize-instance-simple ,pv-cell ,form-list)))) #|| #'(lambda (instance initargs) (initialize-instance-simple pv-cell form-list instance initargs)) ||# `(call-initialize-instance-simple ,pv-cell ,form-list)))) (defun load-precompiled-iis-entry (form function system uses) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (unless entry (setq entry (list* form nil nil nil)) (setq *initialize-instance-simple-alist* (nconc *initialize-instance-simple-alist* (list entry)))) (setf (cadr entry) function) (setf (caddr entry) system) (dolist (use uses) (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) (setf (cdddr entry) (union uses (cdddr entry) :test #'equal)))) (defmacro precompile-iis-functions (&optional system) (let ((index -1)) `(progn ,@(gathering1 (collecting) (dolist (iis-entry *initialize-instance-simple-alist*) (when (or (null (caddr iis-entry)) (eq (caddr iis-entry) system)) (when system (setf (caddr iis-entry) system)) (gather1 (make-top-level-form `(precompile-initialize-instance-simple ,system ,(incf index)) '(load) `(load-precompiled-iis-entry ',(car iis-entry) #',(car iis-entry) ',system ',(cdddr iis-entry)))))))))) (defun compile-iis-functions (after-p) (let ((*compile-make-instance-functions-p* t) (*revert-initialize-info-p* t) (*note-iis-entry-p* (not after-p))) (declare (special *compile-make-instance-functions-p*)) (when (eq *boot-state* 'complete) (update-make-instance-function-table)))) ;(const const) ;(funcall function) ;(push-initarg const) ;(pop-supplied count) ; a positive odd number ;(instance-set pv-offset slotd) ;(skip-when-instance-boundp pv-offset slotd n) (defun initialize-instance-simple (pv-cell form-list instance initargs) (let ((pv (car pv-cell)) (initargs-tail initargs) (slots (get-slots-or-nil instance)) (class (class-of instance)) value) (loop (when (null form-list) (return nil)) (let ((form (pop form-list))) (ecase (car form) (push-initarg (push value initargs) (push (cadr form) initargs)) (const (setq value (cadr form))) (funcall (setq value (funcall (the function (cadr form))))) (pop-initargs (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) (setq value (pop initargs-tail))) (instance-set (instance-write-internal pv slots (cadr form) value (setf (slot-value-using-class class instance (caddr form)) value))) (skip-when-instance-boundp (when (instance-boundp-internal pv slots (cadr form) (slot-boundp-using-class class instance (caddr form))) (dotimes (i (cadddr form)) (pop form-list)))) (update-initialize-info-cache (when (consp initargs) (setq initargs (cons (car initargs) (cdr initargs)))) (setq *initialize-info-cache-class* (cadr form)) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* (caddr form))) (finish-pushing-initargs (setq initargs-tail initargs))))) initargs)) (defun add-to-cvector (cvector constant) (or (position constant cvector) (prog1 (fill-pointer cvector) (vector-push-extend constant cvector)))) (defvar *inline-iis-instance-locations-p* t) (defun first-form-to-lisp (forms cvector pv) (flet ((const (constant) (cond ((or (numberp constant) (characterp constant)) constant) ((and (symbolp constant) (symbol-package constant)) `',constant) (t `(svref cvector ,(add-to-cvector cvector constant)))))) (let ((form (pop (car forms)))) (ecase (car form) (push-initarg `((push value initargs) (push ,(const (cadr form)) initargs))) (const `((setq value ,(const (cadr form))))) (funcall `((setq value (funcall (the function ,(const (cadr form))))))) (pop-initargs `((setq initargs-tail (,@(let ((pop (1- (cadr form)))) (case pop (1 `(cdr)) (3 `(cdddr)) (t `(nthcdr ,pop)))) initargs-tail)) (setq value (pop initargs-tail)))) (instance-set (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) (default `(setf (slot-value-using-class class instance ,(const (caddr form))) value))) (if *inline-iis-instance-locations-p* (typecase location (fixnum `((setf (%instance-ref slots ,(const location)) value))) (cons `((setf (cdr ,(const location)) value))) (t `(,default))) `((instance-write-internal pv slots ,(const pv-offset) value ,default ,(typecase location (fixnum ':instance) (cons ':class) (t ':default))))))) (skip-when-instance-boundp (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) (default `(slot-boundp-using-class class instance ,(const (caddr form))))) `((unless ,(if *inline-iis-instance-locations-p* (typecase location (fixnum `(not (eq (%instance-ref slots ,(const location)) ',*slot-unbound*))) (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) (t default)) `(instance-boundp-internal pv slots ,(const pv-offset) ,default ,(typecase (pvref pv pv-offset) (fixnum ':instance) (cons ':class) (t ':default)))) ,@(let ((sforms (cons nil nil))) (dotimes (i (cadddr form) (car sforms)) (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) (update-initialize-info-cache `((when (consp initargs) (setq initargs (cons (car initargs) (cdr initargs)))) (setq *initialize-info-cache-class* ,(const (cadr form))) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* ,(const (caddr form))))) (finish-pushing-initargs `((setq initargs-tail initargs))))))) (defmacro iis-body (&body forms) (let ((vars '(initargs-tail pv slots wrapper class value))) `(let ((initargs-tail initargs) (pv (car pv-cell)) (slots nil) (wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil) class value) ,@(progn #-cmu vars #+cmu `((declare (ignorable ,@vars)))) #+cmu17 (cond ((not (typep wrapper 'wrapper))) ((std-instance-p instance) (setq slots (std-instance-slots instance))) (t (setq slots (fsc-instance-slots instance)))) #-cmu17 (cond ((std-instance-p instance) (setq slots (std-instance-slots instance)) (setq wrapper (std-instance-wrapper instance))) ((fsc-instance-p instance) (setq slots (fsc-instance-slots instance)) (setq wrapper (fsc-instance-wrapper instance))) (t (setq wrapper (wrapper-of instance)))) (setq class (wrapper-class wrapper)) ,@forms))) (defun form-list-to-lisp (pv-cell form-list) (let* ((forms (list form-list)) (cvector (make-array (floor (length form-list) 2) :fill-pointer 0 :adjustable t)) (pv (car pv-cell)) (body (let ((rforms (cons nil nil))) (loop (when (null (car forms)) (return (car rforms))) (add-forms (first-form-to-lisp forms cvector pv) rforms)))) (cvector-type `(simple-vector ,(length cvector)))) (values `(lambda (pv-cell cvector) (declare (type ,cvector-type cvector)) #+cmu (declare (ignorable pv-cell cvector)) #'(lambda (instance initargs) (declare #.*optimize-speed*) #+cmu (declare (ignorable instance initargs)) (iis-body ,@body) initargs)) (list pv-cell (coerce cvector cvector-type))))) ;The effect of this is to cause almost all of the overhead of make-instance ;to happen at load time (or maybe at precompile time, as explained in a ;previous message) rather than the first time make-instance is called with ;a given class-name and sequence of keywords. ;This optimization applys only when the first argument and all the even ;numbered arguments are constants evaluating to interned symbols. #+cmu (declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) ; Use this definition in any CL implementation supporting ; both define-compiler-macro and load-time-value. #+cmu (define-compiler-macro make-instance (&whole form &rest args) (declare (ignore args)) (let* ((*make-instance-function-keys* nil) (expanded-form (expand-make-instance-form form))) (if expanded-form `(funcall (the function (symbol-function ;; The symbol is guaranteed to be fbound. ;; Is there a way to declare this? (load-time-value (get-make-instance-function-symbol ',(first *make-instance-function-keys*))))) ,@(cdr expanded-form)) form))) (defun get-make-instance-function-symbol (key) (get-make-instance-functions (list key)) (make-instance-function-symbol key)) gcl-2.6.14/pcl/gcl_pcl_iterate.lisp0000644000175000017500000017113414360276512015571 0ustar cammcamm;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 (in-package :iterate :use '(:lisp :walker)) (export '(iterate iterate* gathering gather with-gathering interval elements list-elements list-tails plist-elements eachtime while until collecting joining maximizing minimizing summing *iterate-warnings*)) (defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized. NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." ) ;;; ITERATE macro (defmacro iterate (clauses &body body &environment env) (optimize-iterate-form clauses body env)) (defun simple-expand-iterate-form (clauses body) ;; Expand ITERATE. This is the "formal semantics" expansion, which we never ;; use. (let* ((block-name (gensym)) (bound-var-lists (mapcar #'(lambda (clause) (let ((names (first clause))) (if (listp names) names (list names)))) clauses)) (generator-vars (mapcar #'(lambda (clause) (declare (ignore clause)) (gensym)) clauses))) `(block ,block-name (let* ,(mapcan #'(lambda (gvar clause var-list) ; For each clause, bind a ; generator temp to the clause, ; then bind the specified ; var(s) (cons (list gvar (second clause)) (copy-list var-list))) generator-vars clauses bound-var-lists) ;; Note bug in formal semantics: there can be declarations in the head ;; of BODY; they go here, rather than inside loop (loop ,@(mapcar #'(lambda (var-list gen-var) ; Set each bound variable (or ; set of vars) to the result of ; calling the corresponding ; generator `(multiple-value-setq ,var-list (funcall ,gen-var #'(lambda nil (return-from ,block-name))))) bound-var-lists generator-vars) ,@body))))) (defparameter *iterate-temp-vars-list* '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8) "Temp var names used by ITERATE expansions.") (defun optimize-iterate-form (clauses body iterate-env) (let* ((temp-vars *iterate-temp-vars-list*) (block-name (gensym)) (finish-form `(return-from ,block-name)) (bound-vars (mapcan #'(lambda (clause) (let ((names (first clause))) (if (listp names) (copy-list names) (list names)))) clauses)) iterate-decls generator-decls update-forms bindings leftover-body) (do ((tail bound-vars (cdr tail))) ((null tail)) ; Check for duplicates (when (member (car tail) (cdr tail)) (warn "Variable appears more than once in ITERATE: ~S" (car tail)))) (flet ((get-iterate-temp nil ;; Make temporary var. Note that it is ok to re-use these symbols ;; in each iterate, because they are not used within BODY. (or (pop temp-vars) (gensym)))) (dolist (clause clauses) (cond ((or (not (consp clause)) (not (consp (cdr clause)))) (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" clause)) (t (unless (null (cddr clause)) (warn "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" clause)) (multiple-value-bind (let-body binding-type let-bindings localdecls otherdecls extra-body) (expand-into-let (second clause) 'iterate iterate-env) ;; We have expanded the generator clause and parsed it into its LET ;; pieces. (prog* ((vars (first clause)) gen-args renamed-vars) (setq vars (if (listp vars) (copy-list vars) (list vars))) ; VARS is now a (fresh) list of ; all iteration vars bound in ; this clause (cond ((eq let-body :abort) ; Already issued a warning ; about malformedness ) ((null (setq let-body (function-lambda-p let-body 1))) ; Not of the expected form (let ((generator (second clause))) (cond ((and (consp generator) (fboundp (car generator))) ; It looks ok--a macro or ; function here--so the guy who ; wrote it just didn't do it in ; an optimizable way (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" generator)) (t ; Perhaps it's just a ; misspelling? Probably user ; error (maybe-warn :user "Iterate operator in clause ~S is not fboundp." generator))) (setq let-body :abort))) (t ;; We have something of the form #'(LAMBDA (finisharg) ...), ;; possibly with some LET bindings around it. LET-BODY = ;; ((finisharg) ...). (setq let-body (cdr let-body)) (setq gen-args (pop let-body)) (when let-bindings ;; The first transformation we want to perform is ;; "LET-eversion": turn (let* ((generator (let (..bindings..) ;; #'(lambda ...)))) ..body..) into (let* (..bindings.. ;; (generator #'(lambda ...))) ..body..). This ;; transformation is valid if nothing in body refers to any ;; of the bindings, something we can assure by ;; alpha-converting the inner let (substituting new names for ;; each var). Of course, none of those vars can be special, ;; but we already checked for that above. (multiple-value-setq (let-bindings renamed-vars) (rename-let-bindings let-bindings binding-type iterate-env leftover-body #'get-iterate-temp)) (setq leftover-body nil) ; If there was any leftover ; from previous, it is now ; consumed ) ;; The second transformation is substituting the body of the ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance ;; in the update form (funcall generator #'(lambda () ;; finish-form)), then simplifying that form. The requirement ;; for this part is that the generator body not refer to any ;; variables that are bound between the generator binding and the ;; appearance in the loop body. The only variables bound in that ;; interval are generator temporaries, which have unique names so ;; are no problem, and the iteration variables remaining for ;; subsequent clauses. We'll discover the story as we walk the ;; body. (multiple-value-bind (finishdecl other rest) (parse-declarations let-body gen-args) (declare (ignore finishdecl)) ; Pull out declares, if any, ; separating out the one(s) ; referring to the finish arg, ; which we will throw away (when other ; Combine remaining decls with ; decls extracted from the LET, ; if any (setq otherdecls (nconc otherdecls other))) (setq let-body (cond (otherdecls ; There are interesting ; declarations, so have to keep ; it wrapped. `(let nil (declare ,@otherdecls) ,@rest)) ((null (cdr rest)) ; Only one form left (first rest)) (t `(progn ,@rest))))) (unless (eq (setq let-body (iterate-transform-body let-body iterate-env renamed-vars (first gen-args) finish-form bound-vars clause)) :abort) ;; Skip the rest if transformation failed. Warning has ;; already been issued. ;; Note possible further optimization: if LET-BODY expanded ;; into (prog1 oldvalue prepare-for-next-iteration), as so ;; many do, then we could in most cases split the PROG1 into ;; two pieces: do the (setq var oldvalue) here, and do the ;; prepare-for-next-iteration at the bottom of the loop. ;; This does a slight optimization of the PROG1 and also ;; rearranges the code in a way that a reasonably clever ;; compiler might detect how to get rid of redundant ;; variables altogether (such as happens with INTERVAL and ;; LIST-TAILS); that would make the whole thing closer to ;; what you might have coded by hand. However, to do this ;; optimization, we need to assure that (a) the ;; prepare-for-next-iteration refers freely to no vars other ;; than the internal vars we have extracted from the LET, and ;; (b) that the code has no side effects. These are both ;; true for all the iterators defined by this module, but how ;; shall we represent side-effect info and/or tap into the ;; compiler's knowledge of same? (when localdecls ; There were declarations for ; the generator locals--have to ; keep them for later, and ; rename the vars mentioned (setq generator-decls (nconc generator-decls (mapcar #'(lambda (decl) (let ((head (car decl))) (cons head (if (eq head 'type) (cons (second decl) (sublis renamed-vars (cddr decl))) (sublis renamed-vars (cdr decl)))))) localdecls))))))) ;; Finished analyzing clause now. LET-BODY is the form which, when ;; evaluated, returns updated values for the iteration variable(s) ;; VARS. (when (eq let-body :abort) ;; Some punt case: go with the formal semantics: bind a var to ;; the generator, then call it in the update section (let ((gvar (get-iterate-temp)) (generator (second clause))) (setq let-bindings (list (list gvar (cond (leftover-body ; Have to use this up `(progn ,@(prog1 leftover-body (setq leftover-body nil)) generator)) (t generator))))) (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) (push (mv-setq (copy-list vars) let-body) update-forms) (dolist (v vars) (declare (ignore v)) ; Pop off the vars we have now ; bound from the list of vars ; to watch out for--we'll bind ; them right now (pop bound-vars)) (setq bindings (nconc bindings let-bindings (cond (extra-body ; There was some computation to ; do after the bindings--here's ; our chance (cons (list (first vars) `(progn ,@extra-body nil)) (rest vars))) (t vars)))))))))) (do ((tail body (cdr tail))) ((not (and (consp tail) (consp (car tail)) (eq (caar tail) 'declare))) ;; TAIL now points at first non-declaration. If there were ;; declarations, pop them off so they appear in the right place (unless (eq tail body) (setq iterate-decls (ldiff body tail)) (setq body tail)))) `(block ,block-name (let* ,bindings ,@(and generator-decls `((declare ,@generator-decls))) ,@iterate-decls ,@leftover-body (loop ,@(nreverse update-forms) ,@body))))) (defun expand-into-let (clause parent-name env) ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra ;; body, where BODY is a single form. If multiple forms in a LET, the ;; preceding forms are returned as extra body. Returns :ABORT if it ;; issued a punt warning. (prog ((expansion clause) expandedp binding-type let-bindings let-body) expand (multiple-value-setq (expansion expandedp) (macroexpand-1 expansion env)) (cond ((not (consp expansion)) ; Shouldn't happen ) ((symbolp (setq binding-type (first expansion))) (case binding-type ((let let*) (setq let-bindings (second expansion)) ; List of variable bindings (setq let-body (cddr expansion)) (go handle-let)))) ((and (consp binding-type) (eq (car binding-type) 'lambda) (not (find-if #'(lambda (x) (member x lambda-list-keywords) ) (setq let-bindings (second binding-type))) ) (eql (length (second expansion)) (length let-bindings)) (null (cddr expansion))) ; A simple LAMBDA form can be ; treated as LET (setq let-body (cddr binding-type)) (setq let-bindings (mapcar #'list let-bindings (second expansion)) ) (setq binding-type 'let) (go handle-let))) ;; Fall thru if not a LET (cond (expandedp ; try expanding again (go expand)) (t ; Boring--return form as the ; body (return expansion))) handle-let (return (let ((locals (variables-from-let let-bindings)) extra-body specials) (multiple-value-bind (localdecls otherdecls let-body) (parse-declarations let-body locals) (cond ((setq specials (extract-special-bindings locals localdecls)) (maybe-warn (cond ((find-if #'variable-globally-special-p specials) ; This could be the fault of a ; user proclamation :user) (t :definition)) "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" parent-name clause specials) :abort) (t (values (cond ((not (consp let-body)) ; Null body of LET? unlikely, ; but someone else will likely ; complain nil) ((null (cdr let-body)) ; A single expression, which we ; hope is (function ; (lambda...)) (first let-body)) (t ;; More than one expression. These are forms to ;; evaluate after the bindings but before the ;; generator form is returned. Save them to ;; evaluate in the next convenient place. Note that ;; this is ok, as there is no construct that can ;; cause a LET to return prematurely (without ;; returning also from some surrounding construct). (setq extra-body (butlast let-body)) (car (last let-body)))) binding-type let-bindings localdecls otherdecls extra-body)))))))) (defun variables-from-let (bindings) ;; Return a list of the variables bound in the first argument to LET[*]. (mapcar #'(lambda (binding) (if (consp binding) (first binding) binding)) bindings)) (defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg finish-form bound-vars clause) ;;; This is the second major transformation for a single iterate clause. ;;; LET-BODY is the body of the iterator after we have extracted its local ;;; variables and declarations. We have two main tasks: (1) Substitute ;;; internal temporaries for occurrences of the LET variables; the alist ;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of ;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we ;;; check for forms that would invalidate these transformations: occurrence of ;;; FINISH-ARG outside of a funcall, and free reference to any element of ;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we ;;; return the transformed body; on failure, :ABORT. (walk-form let-body iterate-env #'(lambda (form context env) (declare (ignore context)) ;; Need to substitute RENAMED-VARS, as well as turn ;; (FUNCALL finish-arg) into the finish form (cond ((symbolp form) (let (renaming) (cond ((and (eq form finish-arg) (variable-same-p form env iterate-env)) ; An occurrence of the finish ; arg outside of FUNCALL ; context--I can't handle this (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." (second clause)) (return-from iterate-transform-body :abort)) ((and (setq renaming (assoc form renamed-vars )) (variable-same-p form env iterate-env)) ; Reference to one of the vars ; we're renaming (cdr renaming)) ((and (member form bound-vars) (variable-same-p form env iterate-env)) ; FORM is a var that is bound ; in this same ITERATE, or ; bound later in this ITERATE*. ; This is a conflict. (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." (second clause) form) (return-from iterate-transform-body :abort)) (t form)))) ((and (consp form) (eq (first form) 'funcall) (eq (second form) finish-arg) (variable-same-p (second form) env iterate-env)) ; (FUNCALL finish-arg) => ; finish-form (unless (null (cddr form)) (maybe-warn :definition "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." (second clause) (cddr form))) finish-form) (t form))))) (defun parse-declarations (tail locals) ;; Extract the declarations from the head of TAIL and divide them into 2 ;; classes: declares about variables in the list LOCALS, and all other ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. (let (localdecls otherdecls form) (loop (unless (and tail (consp (setq form (car tail))) (eq (car form) 'declare)) (return (values localdecls otherdecls tail))) (mapc #'(lambda (decl) (case (first decl) ((inline notinline optimize) ; These don't talk about vars (push decl otherdecls)) (t ; Assume all other kinds are ; for vars (let* ((vars (if (eq (first decl) 'type) (cddr decl) (cdr decl))) (l (intersection locals vars)) other) (cond ((null l) ; None talk about LOCALS (push decl otherdecls)) ((null (setq other (set-difference vars l))) ; All talk about LOCALS (push decl localdecls)) (t ; Some of each (let ((head (cons 'type (and (eq (first decl) 'type) (list (second decl)))))) (push (append head other) otherdecls) (push (append head l) localdecls)))))))) (cdr form)) (pop tail)))) (defun extract-special-bindings (vars decls) ;; Return the subset of VARS that are special, either globally or ;; because of a declaration in DECLS (let ((specials (remove-if-not #'variable-globally-special-p vars))) (dolist (d decls) (when (eq (car d) 'special) (setq specials (union specials (intersection vars (cdr d)))))) specials)) (defun function-lambda-p (form &optional nargs) ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length ;; NARGS, return the lambda expression (let (args body) (and (consp form) (eq (car form) 'function) (consp (setq form (cdr form))) (null (cdr form)) (consp (setq form (car form))) (eq (car form) 'lambda) (consp (setq body (cdr form))) (listp (setq args (car body))) (or (null nargs) (eql (length args) nargs)) form))) (defun rename-let-bindings (let-bindings binding-type env leftover-body &optional tempvarfn) ;; Perform the alpha conversion required for "LET eversion" of (LET[*] ;; LET-BINDINGS . body)--rename each of the variables to an internal name. ;; Returns 2 values: a new set of LET bindings and the alist of old var names ;; to new (so caller can walk the body doing the rest of the renaming). ;; BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of ;; forms that must be eval'ed before the first binding happens. ENV is the ;; macro expansion environment, in case we have to walk a LET*. TEMPVARFN is ;; a function of no args to return a temporary var; if omitted, we use ;; GENSYM. (let (renamed-vars) (values (mapcar #'(lambda (binding) (let ((valueform (cond ((not (consp binding)) ; No initial value nil) ((or (eq binding-type 'let) (null renamed-vars)) ; All bindings are in parallel, ; so none can refer to others (second binding)) (t ; In a LET*, have to substitute ; vars in the 2nd and ; subsequent initialization ; forms (rename-variables (second binding) renamed-vars env)))) (newvar (if tempvarfn (funcall tempvarfn) (gensym)))) (push (cons (if (consp binding) (first binding) binding) newvar) renamed-vars) ; Add new variable to the list ; AFTER we have walked the ; initial value form (when leftover-body ;; Previous clause had some computation to do after ;; its bindings. Here is the first opportunity to ;; do it (setq valueform `(progn ,@leftover-body ,valueform)) (setq leftover-body nil)) (list newvar valueform))) let-bindings) renamed-vars))) (defun rename-variables (form alist env) ;; Walks FORM, renaming occurrences of the key variables in ALIST with ;; their corresponding values. ENV is FORM's environment, so we can ;; make sure we are talking about the same variables. (walk-form form env #'(lambda (form context subenv) (declare (ignore context)) (let (pair) (cond ((and (symbolp form) (setq pair (assoc form alist)) (variable-same-p form subenv env)) (cdr pair)) (t form)))))) (defun mv-setq (vars expr) ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some ;; of the simple cases for benefit of compilers that don't, and I don't care ;; what the value is, and I know that the variables need not be set in ;; parallel, since they can't be used free in EXPR (cond ((null vars) ; EXPR is a side-effect expr) ((not (consp vars)) ; This is an error, but I'll ; let MULTIPLE-VALUE-SETQ ; report it `(multiple-value-setq ,vars ,expr)) ((and (listp expr) (eq (car expr) 'values)) ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq ;; (psetq returns nil, but I don't care about returned value). Do this ;; even for the single variable case so that we catch (mv-setq (a) (values ;; x y)) (pop expr) ; VALUES `(setq ,@(mapcon #'(lambda (tail) (list (car tail) (cond ((or (cdr tail) (null (cdr expr))) ; One result expression for ; this var (pop expr)) (t ; More expressions than vars, ; so arrange to evaluate all ; the rest now. (cons 'prog1 expr))))) vars))) ((null (cdr vars)) ; Simple one variable case `(setq ,(car vars) ,expr)) (t ; General case--I know nothing `(multiple-value-setq ,vars ,expr)))) (defun variable-same-p (var env1 env2) (eq (variable-lexical-p var env1) (variable-lexical-p var env2))) (defun maybe-warn (type &rest warn-args) ;; Issue a warning about not being able to optimize this thing. TYPE ;; is one of :DEFINITION, meaning the definition is at fault, and ;; :USER, meaning the user's code is at fault. (when (case *iterate-warnings* ((nil) nil) ((:user) (eq type :user)) (t t)) (apply #'warn warn-args))) ;; Sample iterators (defmacro interval (&whole whole &key from downfrom to downto above below by type) (cond ((and from downfrom) (error "Can't use both FROM and DOWNFROM in ~S" whole)) ((cdr (remove nil (list to downto above below))) (error "Can't use more than one limit keyword in ~S" whole)) (t (let* ((down (or downfrom downto above)) (limit (or to downto above below)) (inc (cond ((null by) 1) ((constantp by) ; Can inline this increment by)))) `(let ((from ,(or from downfrom 0)) ,@(and limit `((to ,limit))) ,@(and (null inc) `((by ,by)))) ,@(and type `((declare (type ,type from ,@(and limit '(to)) ,@(and (null inc) `(by)))))) #'(lambda (finish) ,@(cond ((null limit) ; We won't use the FINISH arg '((declare (ignore finish))))) (prog1 ,(cond (limit ; Test the limit. If ok, ; return current value and ; increment, else quit `(if (,(cond (above '>) (below '<) (down '>=) (t '<=)) from to) from (funcall finish))) (t ; No test 'from)) (setq from (,(if down '- '+) from ,(or inc 'by)))))))))) (defmacro list-elements (list &key (by '#'cdr)) `(let ((tail ,list)) #'(lambda (finish) (prog1 (if (endp tail) (funcall finish) (first tail)) (setq tail (funcall ,by tail)))))) (defmacro list-tails (list &key (by '#'cdr)) `(let ((tail ,list)) #'(lambda (finish) (prog1 (if (endp tail) (funcall finish) tail) (setq tail (funcall ,by tail)))))) (defmacro elements (sequence) "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." (let* ((type (and (consp sequence) (eq (first sequence) 'the) (second sequence))) (accessor (if type (sequence-accessor type) 'elt)) (listp (eq type 'list))) ;; If type is given via THE, we may be able to generate a good accessor here ;; for the benefit of implementations that aren't smart about (ELT (THE ;; STRING FOO)). I'm not bothering to keep the THE inside the body, ;; however, since I assume any compiler that would understand (AREF (THE ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it. ;; If sequence is declared to be a list, it's better to cdr down it, so we ;; have some extra cases here. Normally folks would write LIST-ELEMENTS, ;; but maybe they wanted to get the index for free... `(let* ((index 0) (s ,sequence) ,@(and (not listp) '((size (length s))))) #'(lambda (finish) (values (cond ,(if listp '((not (endp s)) (pop s)) `((< index size) (,accessor s index))) (t (funcall finish))) (prog1 index (setq index (1+ index)))))))) (defmacro plist-elements (plist) "Generates each time 2 items, the indicator and the value." `(let ((tail ,plist)) #'(lambda (finish) (values (if (endp tail) (funcall finish) (first tail)) (prog1 (if (endp (setq tail (cdr tail))) (funcall finish) (first tail)) (setq tail (cdr tail))))))) (defun sequence-accessor (type) ;; returns the function with which most efficiently to make accesses to ;; a sequence of type TYPE. (case (if (consp type) ; e.g., (VECTOR FLOAT *) (car type) type) ((array simple-array vector) 'aref) (simple-vector 'svref) (string 'char) (simple-string 'schar) (bit-vector 'bit) (simple-bit-vector 'sbit) (t 'elt))) ;; These "iterators" may be withdrawn (defmacro eachtime (expr) `#'(lambda (finish) (declare (ignore finish)) ,expr)) (defmacro while (expr) `#'(lambda (finish) (unless ,expr (funcall finish)))) (defmacro until (expr) `#'(lambda (finish) (when ,expr (funcall finish)))) ; GATHERING macro (defmacro gathering (clauses &body body &environment env) (or (optimize-gathering-form clauses body env) (simple-expand-gathering-form clauses body env))) (defmacro with-gathering (clauses gather-body &body use-body) "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." ;; We may optimize this a little better later for those compilers that ;; don't do a good job on (m-v-bind vars (... (values ...)) ...). `(multiple-value-bind ,(mapcar #'car clauses) (gathering ,clauses ,gather-body) ,@use-body)) (defun simple-expand-gathering-form (clauses body env) (declare (ignore env)) ;; The "formal semantics" of GATHERING. We use this only in cases that can't ;; be optimized. (let ((acc-names (mapcar #'first (if (symbolp clauses) ; Shorthand using anonymous ; gathering site (setq clauses `((*anonymous-gathering-site* (,clauses)))) clauses))) (realizer-names (mapcar #'(lambda (binding) (declare (ignore binding)) (gensym)) clauses))) `(multiple-value-call #'(lambda ,(mapcan #'list acc-names realizer-names) (flet ((gather (value &optional (accumulator *anonymous-gathering-site*) ) (funcall accumulator value))) ,@body (values ,@(mapcar #'(lambda (rname) `(funcall ,rname)) realizer-names)))) ,@(mapcar #'second clauses)))) (defvar *active-gatherers* nil "List of GATHERING bindings currently active during macro expansion)") (defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." ) (defun optimize-gathering-form (clauses body gathering-env) (let* (acc-info leftover-body top-bindings finish-forms top-decls) (dolist (clause (if (symbolp clauses) ; A shorthand `((*anonymous-gathering-site* (,clauses))) clauses)) (multiple-value-bind (let-body binding-type let-bindings localdecls otherdecls extra-body) (expand-into-let (second clause) 'gathering gathering-env) (prog* ((acc-var (first clause)) renamed-vars accumulator realizer) (when (and (consp let-body) (eq (car let-body) 'values) (consp (setq let-body (cdr let-body))) (setq accumulator (function-lambda-p (car let-body))) (consp (setq let-body (cdr let-body))) (setq realizer (function-lambda-p (car let-body) 0)) (null (cdr let-body))) ;; Macro returned something of the form (VALUES #'(lambda (value) ;; ...) #'(lambda () ...)), a function to accumulate values and a ;; function to realize the result. (when binding-type ;; Gatherer expanded into a LET (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" (second clause) `(declare ,@otherdecls)) (go punt))) (when let-bindings ;; The first transformation we want to perform is a ;; variant of "LET-eversion": turn (mv-bind (acc real) ;; (let (..bindings..) (values #'(lambda ...) #'(lambda ;; ...))) ..body..) into (let* (..bindings.. (acc ;; #'(lambda ...)) (real #'(lambda ...))) ..body..). This ;; transformation is valid if nothing in body refers to ;; any of the bindings, something we can assure by ;; alpha-converting the inner let (substituting new names ;; for each var). Of course, none of those vars can be ;; special, but we already checked for that above. (multiple-value-setq (let-bindings renamed-vars) (rename-let-bindings let-bindings binding-type gathering-env leftover-body)) (setq top-bindings (nconc top-bindings let-bindings)) (setq leftover-body nil) ; If there was any leftover ; from previous, it is now ; consumed )) (setq leftover-body (nconc leftover-body extra-body)) ; Computation to do after these ; bindings (push (cons acc-var (rename-and-capture-variables accumulator renamed-vars gathering-env)) acc-info) (setq realizer (rename-variables realizer renamed-vars gathering-env)) (push (cond ((null (cdddr realizer)) ; Simple (LAMBDA () expr) => ; expr (third realizer)) (t ; There could be declarations ; or something, so leave as a ; LET (cons 'let (cdr realizer)))) finish-forms) (unless (null localdecls) ; Declarations about the LET ; variables also has to ; percolate up (setq top-decls (nconc top-decls (sublis renamed-vars localdecls)))) (return)) (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" (second clause)) punt (let ((gs (gensym)) (expansion `(multiple-value-list ,(second clause)))) ; Slow way--bind gensym to the ; macro expansion, and we will ; funcall it in the body (push (list acc-var gs) acc-info) (push `(funcall (cadr ,gs)) finish-forms) (setq top-bindings (nconc top-bindings (list (list gs (cond (leftover-body `(progn ,@(prog1 leftover-body (setq leftover-body nil)) ,expansion)) (t expansion)))))))))) (setq body (walk-gathering-body body gathering-env acc-info)) (cond ((eq body :abort) ; Couldn't finish expansion nil) (t `(let* ,top-bindings ,@(and top-decls `((declare ,@top-decls))) ,body ,(cond ((null (cdr finish-forms)) ; just a single value (car finish-forms)) (t `(values ,@(reverse finish-forms))))))))) (defun rename-and-capture-variables (form alist env) ;; Walks FORM, renaming occurrences of the key variables in ALIST with ;; their corresponding values, and capturing any other free variables. ;; Returns a list of the new form and the list of other closed-over ;; vars. ENV is FORM's environment, so we can make sure we are talking ;; about the same variables. (let (closed) (list (walk-form form env #'(lambda (form context subenv) (declare (ignore context)) (let (pair) (cond ((or (not (symbolp form)) (not (variable-same-p form subenv env))) ; non-variable or one that has ; been rebound form) ((setq pair (assoc form alist)) ; One to rename (cdr pair)) (t ; var is free (pushnew form closed) form))))) closed))) (defun walk-gathering-body (body gathering-env acc-info) ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ;; ACC-INFO is a list of information about each of the gathering "bindings" ;; in the form, in the form (var gatheringfn freevars env) (let ((*active-gatherers* (nconc (mapcar #'car acc-info) *active-gatherers*))) ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER ;; targets. This is so that when we encounter a GATHER not belonging to us ;; we can know whether to warn about it. (walk-form (cons 'progn body) gathering-env #'(lambda (form context env) (declare (ignore context)) (let (info site) (cond ((consp form) (cond ((not (eq (car form) 'gather)) ; We only care about GATHER (when (and (eq (car form) 'function) (eq (cadr form) 'gather)) ; Passed as functional--can't ; macroexpand (maybe-warn :user "Can't optimize GATHERING because of reference to #'GATHER." ) (return-from walk-gathering-body :abort)) form) ((setq info (assoc (setq site (if (null (cddr form)) ' *anonymous-gathering-site* (third form))) acc-info)) ; One of ours--expand (GATHER ; value var). INFO = (var ; gatheringfn freevars env) (unless (null (cdddr form)) (warn "Extra arguments (> 2) in ~S discarded." form) ) (let ((fn (second info))) (cond ((symbolp fn) ; Unoptimized case--just call ; the gatherer. FN is the ; gensym that we bound to the ; list of two values returned ; from the gatherer. `(funcall (car ,fn) ,(second form))) (t ; FN = (lambda (value) ...) (dolist (s (third info)) (unless (or (variable-same-p s env gathering-env) (and (variable-special-p s env) (variable-special-p s gathering-env))) ;; Some var used free in the LAMBDA form has been ;; rebound between here and the parent GATHERING ;; form, so can't substitute the lambda. Ok if it's ;; a special reference both here and in the LAMBDA, ;; because then it's not closed over. (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." s) (return-from walk-gathering-body :abort))) ;; Return ((lambda (value) ...) actual-value). In ;; many cases we could simplify this further by ;; substitution, but we'd have to be careful (for ;; example, we would need to alpha-convert any LET ;; we found inside). Any decent compiler will do it ;; for us. (list fn (second form)))))) ((and (setq info (member site *active-gatherers*)) (or (eq site '*anonymous-gathering-site*) (variable-same-p site env (fourth info)))) ; Some other GATHERING will ; take care of this form, so ; pass it up for now. ; Environment check is to make ; sure nobody shadowed it ; between here and there form) (t ; Nobody's going to handle it (if (eq site '*anonymous-gathering-site*) ; More likely that she forgot ; to mention the site than ; forget to write an anonymous ; gathering. (warn "There is no gathering site specified in ~S." form) (warn "The site ~S in ~S is not defined in an enclosing GATHERING form." site form)) ; Turn it into something else ; so we don't warn twice in the ; nested case `(%orphaned-gather ,@(cdr form))))) ((and (symbolp form) (setq info (assoc form acc-info)) (variable-same-p form env gathering-env)) ; A variable reference to a ; gather binding from ; environment TEM (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." form) (return-from walk-gathering-body :abort)) (t form))))))) ;; Sample gatherers (defmacro collecting (&key initial-value) `(let* ((head ,initial-value) (tail ,(and initial-value `(last head)))) (values #'(lambda (value) (if (null head) (setq head (setq tail (list value))) (setq tail (cdr (rplacd tail (list value)))))) #'(lambda nil head)))) (defmacro joining (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (setq result (nconc result value))) #'(lambda nil result)))) (defmacro maximizing (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (when ,(cond ((and (constantp initial-value) (not (null (eval initial-value)))) ; Initial value is given and we ; know it's not NIL, so leave ; out the null check '(> value result)) (t '(or (null result) (> value result)))) (setq result value))) #'(lambda nil result)))) (defmacro minimizing (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (when ,(cond ((and (constantp initial-value) (not (null (eval initial-value)))) ; Initial value is given and we ; know it's not NIL, so leave ; out the null check '(< value result)) (t '(or (null result) (< value result)))) (setq result value))) #'(lambda nil result)))) (defmacro summing (&key (initial-value 0)) `(let ((sum ,initial-value)) (values #'(lambda (value) (setq sum (+ sum value))) #'(lambda nil sum)))) ; Easier to read expanded code ; if PROG1 gets left alone (define-walker-template prog1 (nil return walker::repeat (eval))) gcl-2.6.14/pcl/gcl_pcl_defclass.lisp0000644000175000017500000004047714360276512015725 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; ;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. ;;; ;;; The original motiviation for this function was to deal with the bug in ;;; the Genera compiler that prevents lambda expressions in top-level forms ;;; other than DEFUN from being compiled. ;;; ;;; Now this function is used to grab other functionality as well. This ;;; includes: ;;; - Preventing the grouping of top-level forms. For example, a ;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped ;;; into the same top-level form. ;;; - Telling the programming environment what the pretty version ;;; of the name of this form is. This is used by WARN. ;;; (defun make-top-level-form (name times form) (flet ((definition-name () (if (and (listp name) (memq (car name) '(defmethod defclass class method method-combination))) (format nil "~A~{ ~S~}" (capitalize-words (car name) ()) (cdr name)) (format nil "~S" name)))) (definition-name) #+Genera (progn #-Genera-Release-8 (let ((thunk-name (gensym "TOP-LEVEL-FORM"))) `(eval-when ,times (defun ,thunk-name () (declare (sys:function-parent ,(cond ((listp name) (case (first name) (defmethod `(method ,@(rest name))) (otherwise (second name)))) (t name)) ,(cond ((listp name) (case (first name) ((defmethod defgeneric) 'defun) ((defclass) 'defclass) (otherwise (first name)))) (t 'defun)))) ,form) (,thunk-name))) #+Genera-Release-8 `(compiler-let ((compiler:default-warning-function ',name)) (eval-when ,times (funcall #'(lambda () (declare ,(cond ((listp name) (case (first name) ((defclass) `(sys:function-parent ,(second name) defclass)) ((defmethod) `(sys:function-name (method ,@(rest name)))) ((defgeneric) `(sys:function-name ,(second name))) (otherwise `(sys:function-name ,name)))) (t `(sys:function-name ,name)))) ,form))))) #+LCL3.0 `(compiler-let ((lucid::*compiler-message-string* (or lucid::*compiler-message-string* ,(definition-name)))) (eval-when ,times ,form)) #+cmu (if (member 'compile times) `(eval-when ,times ,form) form) #+kcl (let* ((*print-pretty* nil) (thunk-name (gensym (definition-name)))) (gensym "G") ; set the prefix back to something less confusing. `(eval-when ,times (defun ,thunk-name () ,form) (,thunk-name))) #-(or Genera LCL3.0 cmu kcl) (make-progn `',name `(eval-when ,times ,form)))) (defun make-progn (&rest forms) (let ((progn-form nil)) (labels ((collect-forms (forms) (unless (null forms) (collect-forms (cdr forms)) (if (and (listp (car forms)) (eq (caar forms) 'progn)) (collect-forms (cdar forms)) (push (car forms) progn-form))))) (collect-forms forms) (cons 'progn progn-form)))) ;;; ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. ;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta- ;;; braid is set up, LOAD-DEFCLASS has a special definition which simply ;;; collects all class definitions up, when the metabraid is initialized it ;;; is done from those class definitions. ;;; ;;; After the metabraid has been setup, and the protocol for defining classes ;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the ;;; file defclass.lisp ;;; (defmacro DEFCLASS (name direct-superclasses direct-slots &rest options) (declare (indentation 2 4 3 1)) (expand-defclass name direct-superclasses direct-slots options)) (defun expand-defclass (name supers slots options) (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) (setq supers (copy-tree supers) slots (copy-tree slots) options (copy-tree options)) (let ((metaclass 'standard-class)) (dolist (option options) (if (not (listp option)) (error "~S is not a legal defclass option." option) (when (eq (car option) ':metaclass) (unless (legal-class-name-p (cadr option)) (error "The value of the :metaclass option (~S) is not a~%~ legal class name." (cadr option))) #-cmu17 (setq metaclass (cadr option)) #+cmu17 (setq metaclass (case (cadr option) (lisp:standard-class 'standard-class) (lisp:structure-class 'structure-class) (t (cadr option)))) (setf options (remove option options)) (return t)))) (let ((*initfunctions* ()) (*accessors* ()) ;Truly a crock, but we got (*readers* ()) ;to have it to live nicely. (*writers* ())) (declare (special *initfunctions* *accessors* *readers* *writers*)) (let ((canonical-slots (mapcar #'(lambda (spec) (canonicalize-slot-specification name spec)) slots)) (other-initargs (mapcar #'(lambda (option) (canonicalize-defclass-option name option)) options)) (defstruct-p (and (eq *boot-state* 'complete) (let ((mclass (find-class metaclass nil))) (and mclass (*subtypep mclass *the-class-structure-class*)))))) (do-standard-defsetfs-for-defclass *accessors*) (let ((defclass-form (make-top-level-form `(defclass ,name) (if defstruct-p '(load eval) *defclass-times*) `(progn ,@(mapcar #'(lambda (x) `(declaim (ftype (function (t) t) ,x))) #+cmu *readers* #-cmu nil) ,@(mapcar #'(lambda (x) #-setf (when (consp x) (setq x (get-setf-function-name (cadr x)))) `(declaim (ftype (function (t t) t) ,x))) #+cmu *writers* #-cmu nil) (let ,(mapcar #'cdr *initfunctions*) (load-defclass ',name ',metaclass ',supers (list ,@canonical-slots) (list ,@(apply #'append (when defstruct-p '(:from-defclass-p t)) other-initargs)) ',*accessors*)))))) (if defstruct-p (progn (eval defclass-form) ; define the class now, so that `(progn ; the defstruct can be compiled. ,(class-defstruct-form (find-class name)) ,defclass-form)) (progn (when (and (eq *boot-state* 'complete) (not (member 'compile *defclass-times*))) (inform-type-system-about-std-class name)) defclass-form))))))) (defun make-initfunction (initform) (declare (special *initfunctions*)) (cond ((or (eq initform 't) (equal initform ''t)) '(function true)) ((or (eq initform 'nil) (equal initform ''nil)) '(function false)) ((or (eql initform '0) (equal initform ''0)) '(function zero)) (t (let ((entry (assoc initform *initfunctions* :test #'equal))) (unless entry (setq entry (list initform (gensym) `(function (lambda () ,initform)))) (push entry *initfunctions*)) (cadr entry))))) (defun canonicalize-slot-specification (class-name spec) (declare (special *accessors* *readers* *writers*)) (cond ((and (symbolp spec) (not (keywordp spec)) (not (memq spec '(t nil)))) `'(:name ,spec)) ((not (consp spec)) (error "~S is not a legal slot specification." spec)) ((null (cdr spec)) `'(:name ,(car spec))) ((null (cddr spec)) (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ Convert it to ~S" class-name spec (list (car spec) :initform (cadr spec)))) (t (let* ((name (pop spec)) (readers ()) (writers ()) (initargs ()) (unsupplied (list nil)) (initform (getf spec :initform unsupplied))) (doplist (key val) spec (case key (:accessor (push val *accessors*) (push val readers) (push `(setf ,val) writers)) (:reader (push val readers)) (:writer (push val writers)) (:initarg (push val initargs)))) (loop (unless (remf spec :accessor) (return))) (loop (unless (remf spec :reader) (return))) (loop (unless (remf spec :writer) (return))) (loop (unless (remf spec :initarg) (return))) (setq *writers* (append writers *writers*)) (setq *readers* (append readers *readers*)) (setq spec `(:name ',name :readers ',readers :writers ',writers :initargs ',initargs ',spec)) (if (eq initform unsupplied) `(list* ,@spec) `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) (defun canonicalize-defclass-option (class-name option) (declare (ignore class-name)) (case (car option) (:default-initargs (let ((canonical ())) (let (key val (tail (cdr option))) (loop (when (null tail) (return nil)) (setq key (pop tail) val (pop tail)) (push ``(,',key ,,(make-initfunction val) ,',val) canonical)) `(':direct-default-initargs (list ,@(nreverse canonical)))))) (otherwise `(',(car option) ',(cdr option))))) ;;; ;;; This is the early definition of load-defclass. It just collects up all ;;; the class definitions in a list. Later, in the file braid1.lisp, these ;;; are actually defined. ;;; ;;; ;;; Each entry in *early-class-definitions* is an early-class-definition. ;;; ;;; (defparameter *early-class-definitions* ()) (defun early-class-definition (class-name) (or (find class-name *early-class-definitions* :key #'ecd-class-name) (error "~S is not a class in *early-class-definitions*." class-name))) (defun make-early-class-definition (name source metaclass superclass-names canonical-slots other-initargs) (list 'early-class-definition name source metaclass superclass-names canonical-slots other-initargs)) (defun ecd-class-name (ecd) (nth 1 ecd)) (defun ecd-source (ecd) (nth 2 ecd)) (defun ecd-metaclass (ecd) (nth 3 ecd)) (defun ecd-superclass-names (ecd) (nth 4 ecd)) (defun ecd-canonical-slots (ecd) (nth 5 ecd)) (defun ecd-other-initargs (ecd) (nth 6 ecd)) (defvar *early-class-slots* nil) (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) (defun early-class-slots (class-name) (cdr (or (assoc class-name *early-class-slots*) (let ((a (cons class-name (mapcar #'canonical-slot-name (early-collect-inheritance class-name))))) (push a *early-class-slots*) a)))) (defun early-class-size (class-name) (length (early-class-slots class-name))) (defun early-collect-inheritance (class-name) ;;(declare (values slots cpl default-initargs direct-subclasses)) (let ((cpl (early-collect-cpl class-name))) (values (early-collect-slots cpl) cpl (early-collect-default-initargs cpl) (gathering1 (collecting) (dolist (definition *early-class-definitions*) (when (memq class-name (ecd-superclass-names definition)) (gather1 (ecd-class-name definition)))))))) (defun early-collect-slots (cpl) (let* ((definitions (mapcar #'early-class-definition cpl)) (super-slots (mapcar #'ecd-canonical-slots definitions)) (slots (apply #'append (reverse super-slots)))) (dolist (s1 slots) (let ((name1 (canonical-slot-name s1))) (dolist (s2 (cdr (memq s1 slots))) (when (eq name1 (canonical-slot-name s2)) (error "More than one early class defines a slot with the~%~ name ~S. This can't work because the bootstrap~%~ object system doesn't know how to compute effective~%~ slots." name1))))) slots)) (defun early-collect-cpl (class-name) (labels ((walk (c) (let* ((definition (early-class-definition c)) (supers (ecd-superclass-names definition))) (cons c (apply #'append (mapcar #'early-collect-cpl supers)))))) (remove-duplicates (walk class-name) :from-end nil :test #'eq))) (defun early-collect-default-initargs (cpl) (let ((default-initargs ())) (dolist (class-name cpl) (let* ((definition (early-class-definition class-name)) (others (ecd-other-initargs definition))) (loop (when (null others) (return nil)) (let ((initarg (pop others))) (unless (eq initarg :direct-default-initargs) (error "The defclass option ~S is not supported by the bootstrap~%~ object system." initarg))) (setq default-initargs (nconc default-initargs (reverse (pop others))))))) (reverse default-initargs))) (defun bootstrap-slot-index (class-name slot-name) (or (position slot-name (early-class-slots class-name)) (error "~S not found" slot-name))) ;;; ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change ;;; the values of slots during bootstrapping. During bootstrapping, there ;;; are only two kinds of objects whose slots we need to access, CLASSes ;;; and SLOT-DEFINITIONs. The first argument to these functions tells whether the ;;; object is a CLASS or a SLOT-DEFINITION. ;;; ;;; Note that the way this works it stores the slot in the same place in ;;; memory that the full object system will expect to find it later. This ;;; is critical to the bootstrapping process, the whole changeover to the ;;; full object system is predicated on this. ;;; ;;; One important point is that the layout of standard classes and standard ;;; slots must be computed the same way in this file as it is by the full ;;; object system later. ;;; (defmacro bootstrap-get-slot (type object slot-name) `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name))) (defun bootstrap-set-slot (type object slot-name new-value) (setf (bootstrap-get-slot type object slot-name) new-value)) (defun early-class-name (class) (bootstrap-get-slot 'class class 'name)) (defun early-class-precedence-list (class) (bootstrap-get-slot 'pcl-class class 'class-precedence-list)) (defun early-class-name-of (instance) (early-class-name (class-of instance))) (defun early-class-slotds (class) (bootstrap-get-slot 'slot-class class 'slots)) (defun early-slot-definition-name (slotd) (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) (defun early-slot-definition-location (slotd) (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) (defun early-accessor-method-slot-name (method) (bootstrap-get-slot 'standard-accessor-method method 'slot-name)) (unless (fboundp 'class-name-of) (setf (symbol-function 'class-name-of) (symbol-function 'early-class-name-of))) (defun early-class-direct-subclasses (class) (bootstrap-get-slot 'class class 'direct-subclasses)) (proclaim '(notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names) (setq supers (copy-tree supers) canonical-slots (copy-tree canonical-slots) canonical-options (copy-tree canonical-options)) (do-standard-defsetfs-for-defclass accessor-names) (when (eq metaclass 'standard-class) (inform-type-system-about-std-class name)) (let ((ecd (make-early-class-definition name (load-truename) metaclass supers canonical-slots canonical-options)) (existing (find name *early-class-definitions* :key #'ecd-class-name))) (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) ecd)) gcl-2.6.14/pcl/gcl_pcl_macros.lisp0000644000175000017500000006321414360276512015417 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. ;;; ;;; For simplicity (not having to use eval-when a lot), this file must be ;;; loaded before it can be compiled. ;;; (in-package :pcl) (proclaim '(declaration #-Genera values ;I use this so that Zwei can remind ;me what values a function returns. #-Genera arglist ;Tells me what the pretty arglist ;of something (which probably takes ;&rest args) is. #-Genera indentation ;Tells ZWEI how to indent things ;like defclass. class variable-rebinding pcl-fast-call method-name method-lambda-list )) ;;; Age old functions which CommonLisp cleaned-up away. They probably exist ;;; in other packages in all CommonLisp implementations, but I will leave it ;;; to the compiler to optimize into calls to them. ;;; ;;; Common Lisp BUG: ;;; Some Common Lisps define these in the Lisp package which causes ;;; all sorts of lossage. Common Lisp should explictly specify which ;;; symbols appear in the Lisp package. ;;; (eval-when (compile load eval) (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) (defmacro delq (item list) `(delete ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro neq (x y) `(not (eq ,x ,y))) (defun make-caxr (n form) (if (< n 4) `(,(nth n '(car cadr caddr cadddr)) ,form) (make-caxr (- n 4) `(cddddr ,form)))) (defun make-cdxr (n form) (cond ((zerop n) form) ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form)) (t (make-cdxr (- n 4) `(cddddr ,form))))) ) (deftype non-negative-fixnum () '(and fixnum (integer 0 *))) (defun true (&rest ignore) (declare (ignore ignore)) t) (defun false (&rest ignore) (declare (ignore ignore)) nil) (defun zero (&rest ignore) (declare (ignore ignore)) 0) (defun make-plist (keys vals) (if (null vals) () (list* (car keys) (car vals) (make-plist (cdr keys) (cdr vals))))) (defun remtail (list tail) (if (eq list tail) () (cons (car list) (remtail (cdr list) tail)))) ;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just ;;; lifted it from there but I am honest. Not only that but this one is ;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more ;;; like rebuilding Rome. (defmacro once-only (vars &body body) (let ((gensym-var (gensym)) (run-time-vars (gensym)) (run-time-vals (gensym)) (expand-time-val-forms ())) (dolist (var vars) (push `(if (or (symbolp ,var) (numberp ,var) (and (listp ,var) (member (car ,var) '(quote function)))) ,var (let ((,gensym-var (gensym))) (push ,gensym-var ,run-time-vars) (push ,var ,run-time-vals) ,gensym-var)) expand-time-val-forms)) `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars (reverse expand-time-val-forms)) ,@body))) `(let ,(mapcar #'list (reverse ,run-time-vars) (reverse ,run-time-vals)) ,wrapped-body)))) (eval-when (compile load eval) (defun extract-declarations (body &optional environment) ;;(declare (values documentation declarations body)) (let (documentation declarations form) (when (and (stringp (car body)) (cdr body)) (setq documentation (pop body))) (block outer (loop (when (null body) (return-from outer nil)) (setq form (car body)) (when (block inner (loop (cond ((not (listp form)) (return-from outer nil)) ((eq (car form) 'declare) (return-from inner 't)) (t (multiple-value-bind (newform macrop) (macroexpand-1 form environment) (if (or (not (eq newform form)) macrop) (setq form newform) (return-from outer nil))))))) (pop body) (dolist (declaration (cdr form)) (push declaration declarations))))) (values documentation (and declarations `((declare ,.(nreverse declarations)))) body))) ) (defun get-declaration (name declarations &optional default) (dolist (d declarations default) (dolist (form (cdr d)) (when (and (consp form) (eq (car form) name)) (return-from get-declaration (cdr form)))))) #+Lucid (eval-when (compile load eval) (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid))))) (defvar *keyword-package* (find-package 'keyword)) (defun make-keyword (symbol) (intern (symbol-name symbol) *keyword-package*)) (eval-when (compile load eval) (defun string-append (&rest strings) (setq strings (copy-list strings)) ;The explorer can't even ;rplaca an &rest arg? (do ((string-loc strings (cdr string-loc))) ((null string-loc) (apply #'concatenate 'string strings)) (rplaca string-loc (string (car string-loc))))) ) (defun symbol-append (sym1 sym2 &optional (package *package*)) (intern (string-append sym1 sym2) package)) (defmacro check-member (place list &key (test #'eql) (pretty-name place)) (once-only (place list) `(or (member ,place ,list :test ,test) (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list)))) (defmacro alist-entry (alist key make-entry-fn) (once-only (alist key) `(or (assq ,key ,alist) (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist)) (car ,alist))))) ;;; A simple version of destructuring-bind. ;;; This does no more error checking than CAR and CDR themselves do. Some ;;; attempt is made to be smart about preserving intermediate values. It ;;; could be better, although the only remaining case should be easy for ;;; the compiler to spot since it compiles to PUSH POP. ;;; ;;; Common Lisp BUG: ;;; Common Lisp should have destructuring-bind. ;;; ;#-gcl ; FIXME use regular destructuring-bind (defmacro pcl-destructuring-bind (pattern form &body body) (multiple-value-bind (ignore declares body) (extract-declarations body) (declare (ignore ignore)) (multiple-value-bind (setqs binds) (destructure pattern form) `(let ,binds ,@declares ,@setqs (progn .destructure-form.) . ,body)))) (eval-when (compile load eval) (defun destructure (pattern form) ;;(declare (values setqs binds)) (let ((*destructure-vars* ()) (setqs ())) (declare (special *destructure-vars*)) (setq *destructure-vars* '(.destructure-form.) setqs (list `(setq .destructure-form. ,form)) form '.destructure-form.) (values (nconc setqs (nreverse (destructure-internal pattern form))) (delete nil *destructure-vars*)))) (defun destructure-internal (pattern form) ;; When we are called, pattern must be a list. Form should be a symbol ;; which we are free to setq containing the value to be destructured. ;; Optimizations are performed for the last element of pattern cases. ;; we assume that the compiler is smart about gensyms which are bound ;; but only for a short period of time. (declare (special *destructure-vars*)) (let ((gensym (gensym)) (pending-pops 0) (var nil) (setqs ())) (labels ((make-pop (var form pop-into) (prog1 (cond ((zerop pending-pops) `(progn ,(and var `(setq ,var (car ,form))) ,(and pop-into `(setq ,pop-into (cdr ,form))))) ((null pop-into) (and var `(setq ,var ,(make-caxr pending-pops form)))) (t `(progn (setq ,pop-into ,(make-cdxr pending-pops form)) ,(and var `(setq ,var (pop ,pop-into)))))) (setq pending-pops 0)))) (do ((pat pattern (cdr pat))) ((null pat) ()) (if (symbolp (setq var (car pat))) (progn #-:coral (unless (memq var '(nil ignore)) (push var *destructure-vars*)) #+:coral (push var *destructure-vars*) (cond ((null (cdr pat)) (push (make-pop var form ()) setqs)) ((symbolp (cdr pat)) (push (make-pop var form (cdr pat)) setqs) (push (cdr pat) *destructure-vars*) (return ())) #-:coral ((memq var '(nil ignore)) (incf pending-pops)) #-:coral ((memq (cadr pat) '(nil ignore)) (push (make-pop var form ()) setqs) (incf pending-pops 1)) (t (push (make-pop var form form) setqs)))) (progn (push `(let ((,gensym ())) ,(make-pop gensym form (if (symbolp (cdr pat)) (cdr pat) form)) ,@(nreverse (destructure-internal (if (consp pat) (car pat) pat) gensym))) setqs) (when (symbolp (cdr pat)) (push (cdr pat) *destructure-vars*) (return))))) setqs))) ) (defmacro collecting-once (&key initial-value) `(let* ((head ,initial-value) (tail ,(and initial-value `(last head)))) (values #'(lambda (value) (if (null head) (setq head (setq tail (list value))) (unless (memq value head) (setq tail (cdr (rplacd tail (list value))))))) #'(lambda nil head)))) (defmacro doplist ((key val) plist &body body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) (declare (ignore doc)) `(let ((.plist-tail. ,plist) ,key ,val) ,@decls (loop (when (null .plist-tail.) (return nil)) (setq ,key (pop .plist-tail.)) (when (null .plist-tail.) (error "Malformed plist in doplist, odd number of elements.")) (setq ,val (pop .plist-tail.)) (progn ,@bod))))) (defmacro if* (condition true &rest false) `(if ,condition ,true (progn ,@false))) (defmacro dolist-carefully ((var list improper-list-handler) &body body) `(let ((,var nil) (.dolist-carefully. ,list)) (loop (when (null .dolist-carefully.) (return nil)) (if (consp .dolist-carefully.) (progn (setq ,var (pop .dolist-carefully.)) ,@body) (,improper-list-handler))))) ;; ;;;;;; printing-random-thing ;; ;;; Similar to printing-random-object in the lisp machine but much simpler ;;; and machine independent. (defmacro printing-random-thing ((thing stream) &body body) #+cmu17 `(print-unreadable-object (,thing ,stream :identity t) ,@body) #-cmu17 (once-only (thing stream) `(progn #+cmu (when *print-readably* (error "~S cannot be printed readably." ,thing)) (format ,stream "#<") ,@body (format ,stream " ") (printing-random-thing-internal ,thing ,stream) (format ,stream ">")))) (defun printing-random-thing-internal (thing stream) (declare (ignore thing stream)) nil) ;; ;;;;;; ;; (defun capitalize-words (string &optional (dashes-p t)) (let ((string (copy-seq (string string)))) (declare (string string)) (do* ((flag t flag) (length (length string) length) (char nil char) (i 0 (+ i 1))) ((= i length) string) (setq char (elt string i)) (cond ((both-case-p char) (if flag (and (setq flag (lower-case-p char)) (setf (elt string i) (char-upcase char))) (and (not flag) (setf (elt string i) (char-downcase char)))) (setq flag nil)) ((char-equal char #\-) (setq flag t) (unless dashes-p (setf (elt string i) #\space))) (t (setq flag nil)))))) #-(or lucid kcl) (eval-when (compile load eval) ;(warn "****** Things will go faster if you fix define-compiler-macro") ) #-(or cmu gcl) (defmacro define-compiler-macro (name arglist &body body) #+(or lucid kcl) `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro ,name ,arglist ,@body) #-(or kcl lucid) (declare (ignore name arglist body)) #-(or kcl lucid) nil) ;;; ;;; FIND-CLASS ;;; ;;; This is documented in the CLOS specification. ;;; (defvar *find-class* (make-hash-table :test #'eq)) (defun make-constant-function (value) #'(lambda (object) (declare (ignore object)) value)) (defun function-returning-nil (x) (declare (ignore x)) nil) (defun function-returning-t (x) (declare (ignore x)) t) (defmacro find-class-cell-class (cell) `(car ,cell)) (defmacro find-class-cell-predicate (cell) `(cadr ,cell)) (defmacro find-class-cell-make-instance-function-keys (cell) `(cddr ,cell)) (defmacro make-find-class-cell (class-name) (declare (ignore class-name)) '(list* nil #'function-returning-nil nil)) (defun find-class-cell (symbol &optional dont-create-p) (or (gethash symbol *find-class*) (unless dont-create-p (unless (legal-class-name-p symbol) (error "~S is not a legal class name." symbol)) (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) (defvar *create-classes-from-internal-structure-definitions-p* t) (defun find-class-from-cell (symbol cell &optional (errorp t)) (or (find-class-cell-class cell) (and *create-classes-from-internal-structure-definitions-p* (structure-type-p symbol) (find-structure-class symbol)) (cond ((null errorp) nil) ((legal-class-name-p symbol) (error "No class named: ~S." symbol)) (t (error "~S is not a legal class name." symbol))))) (defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) (unless (find-class-cell-class cell) (find-class-from-cell symbol cell errorp)) (find-class-cell-predicate cell)) (defun legal-class-name-p (x) (and (symbolp x) (not (keywordp x)))) (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-from-cell symbol (find-class-cell symbol errorp) errorp)) (defun find-class-predicate (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp)) (defvar *boot-state* nil) ; duplicate defvar to defs.lisp ; Use this definition in any CL implementation supporting ; both define-compiler-macro and load-time-value. #+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class (define-compiler-macro find-class (&whole form symbol &optional (errorp t) environment) (declare (ignore environment)) (if (and (constantp symbol) (legal-class-name-p (eval symbol)) (constantp errorp) (member *boot-state* '(braid complete))) (let ((symbol (eval symbol)) (errorp (not (null (eval errorp)))) (class-cell (make-symbol "CLASS-CELL"))) `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) (or (find-class-cell-class ,class-cell) #-cmu17 (find-class-from-cell ',symbol ,class-cell ,errorp) #+cmu17 ,(if errorp `(find-class-from-cell ',symbol ,class-cell t) `(and (kernel:class-cell-class ',(kernel:find-class-cell symbol)) (find-class-from-cell ',symbol ,class-cell nil)))))) form)) #-setf (defsetf find-class (symbol &optional (errorp t) environment) (new-value) (declare (ignore errorp environment)) `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol) (if (legal-class-name-p symbol) (let ((cell (find-class-cell symbol))) (setf (find-class-cell-class cell) new-value) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) #+cmu17 (let ((lclass (kernel:layout-class (class-wrapper new-value)))) (setf (lisp:class-name lclass) (class-name new-value)) (unless (eq (lisp:find-class symbol nil) lclass) (setf (lisp:find-class symbol) lclass))) (setf (find-class-cell-predicate cell) (symbol-function (class-predicate-name new-value))) (when (and new-value (not (forward-referenced-class-p new-value))) (dolist (keys+aok (find-class-cell-make-instance-function-keys cell)) (update-initialize-info-internal (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) 'make-instance-function))))) (error "~S is not a legal class name." symbol))) #-setf (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value) (declare (ignore errorp environment)) `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol)) (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate) (new-value symbol) (if (legal-class-name-p symbol) (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) (error "~S is not a legal class name." symbol))) (defun find-wrapper (symbol) (class-wrapper (find-class symbol))) #|| ; Anything that used this should use eval instead. (defun reduce-constant (old) (let ((new (eval old))) (if (eq new old) new (if (constantp new) (reduce-constant new) new)))) ||# (defmacro gathering1 (gatherer &body body) `(gathering ((.gathering1. ,gatherer)) (macrolet ((gather1 (x) `(gather ,x .gathering1.))) ,@body))) ;;; ;;; ;;; (defmacro vectorizing (&key (size 0)) `(let* ((limit ,size) (result (make-array limit)) (index 0)) (values #'(lambda (value) (if (= index limit) (error "vectorizing more elements than promised.") (progn (setf (svref result index) value) (incf index) value))) #'(lambda () result)))) ;;; ;;; These are augmented definitions of list-elements and list-tails from ;;; iterate.lisp. These versions provide the extra :by keyword which can ;;; be used to specify the step function through the list. ;;; (defmacro *list-elements (list &key (by #'cdr)) `(let ((tail ,list)) #'(lambda (finish) (if (endp tail) (funcall finish) (prog1 (car tail) (setq tail (funcall ,by tail))))))) (defmacro *list-tails (list &key (by #'cdr)) `(let ((tail ,list)) #'(lambda (finish) (prog1 (if (endp tail) (funcall finish) tail) (setq tail (funcall ,by tail)))))) (defmacro function-funcall (form &rest args) #-cmu `(funcall ,form ,@args) #+cmu `(funcall (the function ,form) ,@args)) (defmacro function-apply (form &rest args) #-cmu `(apply ,form ,@args) #+cmu `(apply (the function ,form) ,@args)) ;;; ;;; Convert a function name to its standard setf function name. We have to ;;; do this hack because not all Common Lisps have yet converted to having ;;; setf function specs. ;;; ;;; In a port that does have setf function specs you can use those just by ;;; making the obvious simple changes to these functions. The rest of PCL ;;; believes that there are function names like (SETF ), this is the ;;; only place that knows about this hack. ;;; (eval-when (compile load eval) ; In 15e (and also 16c), using the built in setf mechanism costs ; a hash table lookup every time a setf function is called. ; Uncomment the next line to use the built in setf mechanism. ;#+cmu (pushnew :setf *features*) ) (eval-when (compile load eval) #-setf (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq)) (defun get-setf-function-name (name) #+setf `(setf ,name) #-setf (or (gethash name *setf-function-names*) (setf (gethash name *setf-function-names*) (let ((pkg (symbol-package name))) (if pkg (intern (format nil "SETF ~A ~A" (package-name pkg) (symbol-name name)) *the-pcl-package*) (make-symbol (format nil "SETF ~A" (symbol-name name)))))))) ;;; ;;; Call this to define a setf macro for a function with the same behavior as ;;; specified by the SETF function cleanup proposal. Specifically, this will ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b). ;;; ;;; do-standard-defsetf A macro interface for use at top level ;;; in files. Unfortunately, users may ;;; have to use this for a while. ;;; ;;; do-standard-defsetfs-for-defclass A special version called by defclass. ;;; ;;; do-standard-defsetf-1 A functional interface called by the ;;; above, defmethod and defgeneric. ;;; Since this is all a crock anyways, ;;; users are free to call this as well. ;;; (defmacro do-standard-defsetf (&rest function-names) `(eval-when (compile load eval) (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name)))) (defun do-standard-defsetfs-for-defclass (accessors) (dolist (name accessors) (do-standard-defsetf-1 name))) (defun do-standard-defsetf-1 (function-name) #+setf (declare (ignore function-name)) #+setf nil #-setf (unless (and (setfboundp function-name) (get function-name 'standard-setf)) (setf (get function-name 'standard-setf) t) (let* ((setf-function-name (get-setf-function-name function-name))) #+Genera (let ((fn #'(lambda (form) (lt::help-defsetf '(&rest accessor-args) '(new-value) function-name 'nil `(`(,',setf-function-name ,new-value .,accessor-args)) form)))) (setf (get function-name 'lt::setf-method) fn (get function-name 'lt::setf-method-internal) fn)) #+Lucid (lucid::set-simple-setf-method function-name #'(lambda (form new-value) (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) (cdr form))) (vars (mapcar #'car bindings))) ;; This may wrap spurious LET bindings around some form, ;; but the PQC compiler will unwrap then. `(LET (,.bindings) (,setf-function-name ,new-value . ,vars))))) #+kcl (let ((helper (gensym))) (setf (macro-function helper) #'(lambda (form env) (declare (ignore env)) (let* ((loc-args (butlast (cdr form))) (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args)) (vars (mapcar #'car bindings))) `(let ,bindings (,setf-function-name ,(car (last form)) ,@vars))))) (eval `(defsetf ,function-name ,helper))) #+Xerox (flet ((setf-expander (body env) (declare (ignore env)) (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr body))) (forms (cdr body)) (vars (list (gensym)))) (values temps forms vars `(,setf-function-name ,@vars ,@temps) `(,function-name ,@temps))))) (let ((setf-method-expander (intern (concatenate 'string (symbol-name function-name) "-setf-expander") (symbol-package function-name)))) (setf (get function-name :setf-method-expander) setf-method-expander (symbol-function setf-method-expander) #'setf-expander))) #-(or Genera Lucid kcl Xerox) (eval `(defsetf ,function-name (&rest accessor-args) (new-value) (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args)) (vars (mapcar #'car bindings))) `(let ,bindings (,',setf-function-name ,new-value ,@vars))))) ))) (defun setfboundp (symbol) #+Genera (not (null (get-properties (symbol-plist symbol) 'lt::(derived-setf-function trivial-setf-method setf-equivalence setf-method)))) #+Lucid (locally (declare (special lucid::*setf-inverse-table* lucid::*simple-setf-method-table* lucid::*setf-method-expander-table*)) (or (gethash symbol lucid::*setf-inverse-table*) (gethash symbol lucid::*simple-setf-method-table*) (gethash symbol lucid::*setf-method-expander-table*))) #+kcl (or (get symbol 'si::setf-method) (get symbol 'si::setf-update-fn) (get symbol 'si::setf-lambda)) #+Xerox (or (get symbol :setf-inverse) (get symbol 'il:setf-inverse) (get symbol 'il:setfn) (get symbol :shared-setf-inverse) (get symbol :setf-method-expander) (get symbol 'il:setf-method-expander)) #+:coral (or (get symbol 'ccl::setf-inverse) (get symbol 'ccl::setf-method-expander)) #+cmu (fboundp `(setf ,symbol)) #-(or Genera Lucid KCL Xerox :coral cmu) nil) );eval-when ;;; ;;; PCL, like user code, must endure the fact that we don't have a properly ;;; working setf. Many things work because they get mentioned by a defclass ;;; or defmethod before they are used, but others have to be done by hand. ;;; (do-standard-defsetf class-wrapper ;*** generic-function-name method-function-plist method-function-get plist-value object-plist gdefinition slot-value-using-class ) (defsetf slot-value set-slot-value) (defvar *redefined-functions* nil) (defmacro original-definition (name) `(get ,name 'definition-before-pcl)) (defun redefine-function (name new) (pushnew name *redefined-functions*) (unless (original-definition name) (setf (original-definition name) (symbol-function name))) (setf (symbol-function name) (symbol-function new))) gcl-2.6.14/pcl/old/0000755000175000017500000000000014360276512012327 5ustar cammcammgcl-2.6.14/pcl/old/lap.lisp0000644000175000017500000004015614360276512014002 0ustar cammcamm;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; ;;; This file defines PCL's interface to the LAP mechanism. ;;; ;;; The file is divided into two parts. The first part defines the interface ;;; used by PCL to create abstract LAP code vectors. PCL never creates lists ;;; that represent LAP code directly, it always calls this mechanism to do so. ;;; This provides a layer of error checking on the LAP code before it gets to ;;; the implementation-specific assembler. Note that this error checking is ;;; syntactic only, but even so is useful to have. Because of it, no specific ;;; LAP assembler should worry itself with checking the syntax of the LAP code. ;;; ;;; The second part of the file defines the LAP assemblers for each PCL port. ;;; These are included together in the same file to make it easier to change ;;; them all should some random change be made in the LAP mechanism. ;;; (defvar *make-lap-closure-generator*) (defvar *precompile-lap-closure-generator*) (defvar *lap-in-lisp*) (defun make-lap-closure-generator (closure-variables arguments iregs vregs fvregs tregs lap-code) (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs fvregs tregs lap-code)) (defmacro precompile-lap-closure-generator (cvars args i-regs v-regs fv-regs t-regs lap) (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs fv-regs t-regs lap)) (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap) (declare (ignore cvars args)) `(locally (declare #.*optimize-speed*) ,(make-lap-prog iregs vregs fvregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp))))) ;;; ;;; The following functions and macros are used by PCL when generating LAP ;;; code: ;;; ;;; GENERATING-LAP ;;; WITH-LAP-REGISTERS ;;; ALLOCATE-REGISTER ;;; DEALLOCATE-REGISTER ;;; LAP-FLATTEN ;;; OPCODE ;;; OPERAND ;;; (proclaim '(special *generating-lap*)) ;CAR - alist of free registers ;CADR - alist of allocated registers ;CADDR - max reg number allocated ; ;in each alist, the entries have ;the form: (type . (:REG )) ; ;;; ;;; This goes around the generation of any lap code. should return a lap ;;; code sequence, this macro will take care of converting that to a lap closure ;;; generator. ;;; (defmacro generating-lap (closure-variables arguments &body body) `(let* ((*generating-lap* (list () () -1))) (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body)))) (defmacro generating-lap-in-lisp (closure-variables arguments &body body) `(let* ((*generating-lap* (list () () -1))) (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body)))) ;;; ;;; Each register specification looks like: ;;; ;;; ( &key :reuse ) ;;; (defmacro with-lap-registers (register-specifications &body body) ;; ;; Given that, for now, there is only one keyword argument and ;; that, for now, we do no error checking, we can be pretty ;; sleazy about how this works. ;; (flet ((make-allocations () (gathering1 (collecting) (dolist (spec register-specifications) (gather1 `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec)))))))) (make-deallocations () (gathering1 (collecting) (dolist (spec register-specifications) (gather1 `(unless ,(cadddr spec) (deallocate-register ,(car spec)))))))) `(let ,(make-allocations) (multiple-value-prog1 (progn ,@body) ,@(make-deallocations))))) (defun allocate-register (type) (destructuring-bind (free allocated) *generating-lap* (let ((entry (assoc type free))) (cond (entry (setf (car *generating-lap*) (delete entry free) (cadr *generating-lap*) (cons entry allocated)) (cdr entry)) (t (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*)))))) (setf (cadr *generating-lap*) (cons new allocated)) (cdr new))))))) (defun deallocate-register (reg) (let ((entry (rassoc reg (cadr *generating-lap*)))) (unless entry (error "Attempt to free an unallocated register.")) (push entry (car *generating-lap*)) (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*))))) (defvar *precompiling-lap* nil) (defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code) (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized.")) (let ((iregs ()) (vregs ()) (fvregs ()) (tregs ())) (dolist (entry (car *generating-lap*)) (ecase (car entry) (index (push (caddr entry) iregs)) (vector (push (caddr entry) vregs)) (fixnum-vector (push (caddr entry) fvregs)) ((t) (push (caddr entry) tregs)))) (cond (in-lisp-p `(lap-in-lisp ,closure-variables ,arguments ,iregs ,vregs ,fvregs ,tregs ,lap-code)) (*precompiling-lap* `(precompile-lap-closure-generator ,closure-variables ,arguments ,iregs ,vregs ,fvregs ,tregs ,lap)) (t (make-lap-closure-generator closure-variables arguments iregs vregs fvregs tregs lap-code))))) (defun flatten-lap (&rest opcodes-or-sequences) (let ((result ())) (dolist (opcode-or-sequence opcodes-or-sequences result) (cond ((null opcode-or-sequence)) ((not (consp (car opcode-or-sequence))) ;its an opcode (setf result (append result (list opcode-or-sequence)))) (t (setf result (append result opcode-or-sequence))))))) (defmacro flattening-lap () '(let ((result ())) (values #'(lambda (value) (push value result)) #'(lambda () (apply #'flatten-lap (reverse result)))))) ;;; ;;; This code deals with the syntax of the individual opcodes and operands. ;;; ;;; ;;; The first two of these variables are documented to all ports. They are ;;; lists of the symbols which name the lap opcodes and operands. They can ;;; be useful to determine whether a port has implemented all the required ;;; opcodes and operands. ;;; ;;; The third of these variables is for use of the emitter only. ;;; (defvar *lap-operands* ()) (defvar *lap-opcodes* ()) (defvar *lap-emitters* (make-hash-table :test #'eq :size 30)) (defun opcode (name &rest args) (let ((emitter (gethash name *lap-emitters*))) (if emitter (apply emitter args) (error "No opcode named ~S." name)))) (defun operand (name &rest args) (let ((emitter (gethash name *lap-emitters*))) (if emitter (apply emitter args) (error "No operand named ~S." name)))) (defmacro defopcode (name types) (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*)) (lambda-list (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types))) `(progn (eval-when (load eval) (load-defopcode ',name ',fn-name)) (defun ,fn-name ,lambda-list #+Genera (declare (sys:function-parent ,name defopcode)) (defopcode-1 ',name ',types ,@lambda-list))))) (defmacro defoperand (name types) (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*)) (lambda-list (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types))) `(progn (eval-when (load eval) (load-defoperand ',name ',fn-name)) (defun ,fn-name ,lambda-list #+Genera (declare (sys:function-parent ,name defoperand)) (defoperand-1 ',name ',types ,@lambda-list))))) (defun load-defopcode (name fn-name) (if* (memq name *lap-operands*) (error "LAP opcodes and operands must have disjoint names.") (setf (gethash name *lap-emitters*) fn-name) (pushnew name *lap-opcodes*))) (defun load-defoperand (name fn-name) (if* (memq name *lap-opcodes*) (error "LAP opcodes and operands must have disjoint names.") (setf (gethash name *lap-emitters*) fn-name) (pushnew name *lap-operands*))) (defun defopcode-1 (name operand-types &rest args) (iterate ((arg (list-elements args)) (type (list-elements operand-types))) (check-opcode-arg name arg type)) (cons name (copy-list args))) (defun defoperand-1 (name operand-types &rest args) (iterate ((arg (list-elements args)) (type (list-elements operand-types))) (check-operand-arg name arg type)) (cons name (copy-list args))) (defun check-opcode-arg (name arg type) (labels ((usual (x) (and (consp arg) (eq (car arg) x))) (check (x) (ecase x ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable) (usual x)) (:label (symbolp arg)) (:operand (and (consp arg) (memq (car arg) *lap-operands*)))))) (unless (if (consp type) (if (eq (car type) 'or) (some #'check (cdr type)) (error "What type is this?")) (check type)) (error "The argument ~S to the opcode ~A is not of type ~S." arg name type)))) (defun check-operand-arg (name arg type) (flet ((check (x) (ecase x (:symbol (symbolp arg)) (:register-number (and (integerp arg) (>= arg 0))) (:t t) (:reg (and (consp arg) (eq (car arg) :reg))) (:fixnum (typep arg 'fixnum))))) (unless (if (consp type) (if (eq (car type) 'or) (some #'check (cdr type)) (error "What type is this?")) (check type)) (error "The argument ~S to the operand ~A is not of type ~S." arg name type)))) ;;; ;;; The actual opcodes. ;;; (defopcode :break ()) ;For debugging only. Not (defopcode :beep ()) ;all ports are required to (defopcode :print (:reg)) ;implement this. (defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable))) (defopcode :eq ((or :reg :constant) (or :reg :constant) :label)) (defopcode :neq ((or :reg :constant) (or :reg :constant) :label)) (defopcode :fix= ((or :reg :constant) (or :reg :constant) :label)) (defopcode :izerop (:reg :label)) (defopcode :std-instance-p (:reg :label)) (defopcode :fsc-instance-p (:reg :label)) (defopcode :built-in-instance-p (:reg :label)) (defopcode :structure-instance-p (:reg :label)) (defopcode :jmp ((or :reg :constant))) (defopcode :emf-call ((or :reg :constant))) (defopcode :label (:label)) (defopcode :go (:label)) (defopcode :return ((or :reg :constant))) (defopcode :exit-lap-in-lisp ()) ;;; ;;; The actual operands. ;;; (defoperand :reg (:register-number)) (defoperand :cvar (:symbol)) (defoperand :arg (:symbol)) (defoperand :cdr (:reg)) (defoperand :constant (:t)) (defoperand :std-wrapper (:reg)) (defoperand :fsc-wrapper (:reg)) (defoperand :built-in-wrapper (:reg)) (defoperand :structure-wrapper (:reg)) (defoperand :other-wrapper (:reg)) (defoperand :built-in-or-structure-wrapper (:reg)) (defoperand :std-slots (:reg)) (defoperand :fsc-slots (:reg)) (defoperand :wrapper-cache-number-vector (:reg)) (defoperand :cref (:reg :fixnum)) (defoperand :iref (:reg :reg)) (defoperand :iset (:reg :reg :reg)) (defoperand :instance-ref (:reg :reg)) (defoperand :instance-set (:reg :reg :reg)) (defoperand :i1+ (:reg)) (defoperand :i+ (:reg :reg)) (defoperand :i- (:reg :reg)) (defoperand :ilogand (:reg :reg)) (defoperand :ilogxor (:reg :reg)) (defoperand :ishift (:reg :fixnum)) (defoperand :lisp (:t)) (defoperand :lisp-variable (:symbol)) ;;; ;;; LAP tests (there need to be a lot more of these) ;;; #| (defun make-lap-test-closure-1 (result) #'(lambda (arg1) (declare (pcl-fast-call)) (declare (ignore arg1)) result)) (defun make-lap-test-closure-2 (result) #'(lambda (arg1 arg2) (declare (pcl-fast-call)) (declare (ignore arg1 arg2)) result)) (eval-when (eval) (compile 'make-lap-test-closure-1) (compile 'make-lap-test-closure-2)) (proclaim '(special lap-win lap-lose)) (eval-when (load eval) (setq lap-win (make-lap-test-closure-1 'win) lap-lose (make-lap-test-closure-1 'lose))) (defun lap-test-1 () (let* ((cg (generating-lap '(cache) '(arg) (with-lap-registers ((i0 index) (v0 vector) (t0 t)) (flatten-lap (opcode :move (operand :cvar 'cache) v0) (opcode :move (operand :arg 'arg) i0) (opcode :move (operand :iref v0 i0) t0) (opcode :jmp t0))))) (cache (make-array 32)) (closure (funcall cg cache)) (fn0 (make-lap-test-closure-1 'fn0)) (fn1 (make-lap-test-closure-1 'fn1)) (fn2 (make-lap-test-closure-1 'fn2)) (in0 (index-value->index 2)) (in1 (index-value->index 10)) (in2 (index-value->index 27))) (setf (svref cache (index->index-value in0)) fn0 (svref cache (index->index-value in1)) fn1 (svref cache (index->index-value in2)) fn2) (unless (and (eq (funcall closure in0) 'fn0) (eq (funcall closure in1) 'fn1) (eq (funcall closure in2) 'fn2)) (error "LAP TEST 1 failed.")))) (defun lap-test-2 () (let* ((cg (generating-lap '(cache mask) '(arg) (with-lap-registers ((i0 index) (i1 index) (i2 index) (v0 vector) (t0 t)) (flatten-lap (opcode :move (operand :cvar 'cache) v0) (opcode :move (operand :arg 'arg) i0) (opcode :move (operand :cvar 'mask) i1) (opcode :move (operand :ilogand i0 i1) i2) (opcode :move (operand :iref v0 i2) t0) (opcode :jmp t0))))) (cache (make-array 32)) (mask #b00110) (closure (funcall cg cache mask)) (in0 (index-value->index #b00010)) (in1 (index-value->index #b01010)) (in2 (index-value->index #b10011))) (fill cache lap-lose) (setf (svref cache (index->index-value in0)) lap-win) (unless (and (eq (funcall closure in0) 'win) (eq (funcall closure in1) 'win) (eq (funcall closure in2) 'win)) (error "LAP TEST 2 failed.")))) (defun lap-test-3 () (let* ((cg (generating-lap '(addend) '(arg) (with-lap-registers ((i0 index) (i1 index) (i2 index)) (flatten-lap (opcode :move (operand :cvar 'addend) i0) (opcode :move (operand :arg 'arg) i1) (opcode :move (operand :i+ i0 i1) i2) (opcode :return i2))))) (closure (funcall cg (index-value->index 5)))) (unless (= (index->index-value (funcall closure (index-value->index 2))) 7) (error "LAP TEST 3 failed.")))) (defun lap-test-4 () (let* ((cg (generating-lap '(winner loser) '(arg) (with-lap-registers ((t0 t)) (flatten-lap (opcode :move (operand :arg 'arg) t0) (opcode :eq t0 (operand :constant 'foo) 'win) (opcode :move (operand :cvar 'loser) t0) (opcode :jmp t0) (opcode :label 'win) (opcode :move (operand :cvar 'winner) t0) (opcode :jmp t0))))) (closure (funcall cg #'true #'false))) (unless (and (eq (funcall closure 'foo) 't) (eq (funcall closure 'bar) 'nil)) (error "LAP TEST 4 failed.")))) (defun lap-test-5 () (let* ((cg (generating-lap '(array) '(arg) (with-lap-registers ((r0 vector) (r1 t) (r2 index)) (flatten-lap (opcode :move (operand :cvar 'array) r0) (opcode :move (operand :arg 'arg) r1) (opcode :move (operand :constant (index-value->index 0)) r2) (opcode :move r1 (operand :iref r0 r2)) (opcode :return r1))))) (array (make-array 1)) (closure (funcall cg array))) (unless (and (= (funcall closure 1) (svref array 0)) (eq (funcall closure 'foo) (svref array 0))) (error "LAP TEST 5 failed.")))) |# gcl-2.6.14/pcl/old/construct.lisp0000644000175000017500000011717514360276512015260 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; This file defines the defconstructor and other make-instance optimization ;;; mechanisms. ;;; (in-package :pcl) ;;; ;;; defconstructor is used to define special purpose functions which just ;;; call make-instance with a symbol as the first argument. The semantics ;;; of defconstructor is that it is equivalent to defining a function which ;;; just calls make-instance. The purpose of defconstructor is to provide ;;; PCL with a way of noticing these calls to make-instance so that it can ;;; optimize them. Specific ports of PCL could just have their compiler ;;; spot these calls to make-instance and then call this code. Having the ;;; special defconstructor facility is the best we can do portably. ;;; ;;; ;;; A call to defconstructor like: ;;; ;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r) ;;; ;;; Is equivalent to a defun like: ;;; ;;; (defun make-foo (a b &rest r) ;;; (make-instance 'foo 'a a ':mumble b 'baz r)) ;;; ;;; Calls like the following are also legal: ;;; ;;; (defconstructor make-foo foo ()) ;;; (defconstructor make-bar bar () :x *x* :y *y*) ;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c)) ;;; ;;; ;;; The general idea of this implementation is that the expansion of the ;;; defconstructor form includes the creation of closure generators which ;;; can be called to create constructor code for the class. The ways that ;;; a constructor can be optimized depends not only on the defconstructor ;;; form, but also on the state of the class and the generic functions in ;;; the initialization protocol. Because of this, the determination of the ;;; form of constructor code to be used is a two part process. ;;; ;;; At compile time, make-constructor-code-generators looks at the actual ;;; defconstructor form and makes a list of appropriate constructor code ;;; generators. All that is really taken into account here is whether ;;; any initargs are supplied in the call to make-instance, and whether ;;; any of those are constant. ;;; ;;; At constructor code generation time (see note about lazy evaluation) ;;; compute-constructor-code calls each of the constructor code generators ;;; to try to get code for this constructor. Each generator looks at the ;;; state of the class and initialization protocol generic functions and ;;; decides whether its type of code is appropriate. This depends on things ;;; like whether there are any applicable methods on initialize-instance, ;;; whether class slots are affected by initialization etc. ;;; ;;; ;;; Constructor objects are funcallable instances, the protocol followed to ;;; to compute the constructor code for them is quite similar to the protocol ;;; followed to compute the discriminator code for a generic function. When ;;; the constructor is first loaded, we install as its code a function which ;;; will compute the actual constructor code the first time it is called. ;;; ;;; If there is an update to the class structure which might invalidate the ;;; optimized constructor, the special lazy constructor installer is put back ;;; so that it can compute the appropriate constructor when it is called. ;;; This is the same kind of lazy evaluation update strategy used elswhere ;;; in PCL. ;;; ;;; To allow for flexibility in the PCL implementation and to allow PCL users ;;; to specialize this constructor facility for their own metaclasses, there ;;; is an internal protocol followed by the code which loads and installs ;;; the constructors. This is documented in the comments in the code. ;;; ;;; This code is also designed so that one of its levels, can be used to ;;; implement optimization of calls to make-instance which can't go through ;;; the defconstructor facility. This has not been implemented yet, but the ;;; hooks are there. ;;; ;;; (defmacro defconstructor (name class lambda-list &rest initialization-arguments) (expand-defconstructor class name lambda-list (copy-list initialization-arguments))) (defun expand-defconstructor (class-name name lambda-list supplied-initargs) (let ((class (find-class class-name nil)) (supplied-initarg-names (gathering1 (collecting) (iterate ((name (*list-elements supplied-initargs :by #'cddr))) (gather1 name))))) (when (null class) (error "defconstructor form being compiled (or evaluated) before~@ class ~S is defined." class-name)) `(progn ;; In order to avoid undefined function warnings, we want to tell ;; the compile time environment that a function with this name and ;; this argument list has been defined. The portable way to do this ;; is with defun. (proclaim '(notinline ,name)) (defun ,name ,lambda-list (declare (ignore ,@(extract-parameters lambda-list))) (error "Constructor ~S not loaded." ',name)) ,(make-top-level-form `(defconstructor ,name) '(load eval) `(load-constructor ',class-name ',(class-name (class-of class)) ',name ',supplied-initarg-names ;; make-constructor-code-generators is called to return a list ;; of constructor code generators. The actual interpretation ;; of this list is left to compute-constructor-code, but the ;; general idea is that it should be an plist where the keys ;; name a kind of constructor code and the values are generator ;; functions which return the actual constructor code. The ;; constructor code is usually a closures over the arguments ;; to the generator. ,(make-constructor-code-generators class name lambda-list supplied-initarg-names supplied-initargs)))))) (defun load-constructor (class-name metaclass-name constructor-name supplied-initarg-names code-generators) (let ((class (find-class class-name nil))) (cond ((null class) (error "defconstructor form being loaded (or evaluated) before~@ class ~S is defined." class-name)) ((neq (class-name (class-of class)) metaclass-name) (error "When defconstructor ~S was compiled, the metaclass of the~@ class ~S was ~S. The metaclass is now ~S.~@ The constructor must be recompiled." constructor-name class-name metaclass-name (class-name (class-of class)))) (t (load-constructor-internal class constructor-name supplied-initarg-names code-generators) constructor-name)))) ;;; ;;; The actual constructor objects. ;;; (defclass constructor () ((class ;The class with which this :initarg :class ;constructor is associated. :reader constructor-class) ;The actual class object, ;not the class name. ; (name ;The name of this constructor. :initform nil ;This is the symbol in whose :initarg :name ;function cell the constructor :reader constructor-name) ;usually sits. Of course, this ;is optional. defconstructor ;makes named constructors, but ;it is possible to manipulate ;anonymous constructors also. ; (code-type ;The type of code currently in :initform nil ;use by this constructor. This :accessor constructor-code-type) ;is mostly for debugging and ;analysis purposes. ;The lazy installer sets this ;to LAZY. The most basic and ;least optimized type of code ;is called FALLBACK. ; (supplied-initarg-names ;The names of the initargs this :initarg :supplied-initarg-names ;constructor supplies when it :reader ;"calls" make-instance. constructor-supplied-initarg-names) ; ; (code-generators ;Generators for the different :initarg :code-generators ;types of code this constructor :reader constructor-code-generators)) ;could use. (:metaclass funcallable-standard-class)) ;;; ;;; Because the value in the code-type slot should always correspond to the ;;; funcallable-instance-function of the constructor, this function should ;;; always be used to set the both at the same time. ;;; (defun set-constructor-code (constructor code type) (set-funcallable-instance-function constructor code) (set-function-name constructor (constructor-name constructor)) (setf (constructor-code-type constructor) type)) (defmethod print-object ((constructor constructor) stream) (printing-random-thing (constructor stream) (format stream "~S ~S (~S)" (or (class-name (class-of constructor)) "Constructor") (or (slot-value-or-default constructor 'name) "Anonymous") (slot-value-or-default constructor 'code-type)))) (defmethod describe-object ((constructor constructor) stream) (format stream "~S is a constructor for the class ~S.~%~ The current code type is ~S.~%~ Other possible code types are ~S." constructor (constructor-class constructor) (constructor-code-type constructor) (gathering1 (collecting) (doplist (key val) (constructor-code-generators constructor) (gather1 key))))) ;;; ;;; I am not in a hairy enough mood to make this implementation be metacircular ;;; enough that it can support a defconstructor for constructor objects. ;;; (defun make-constructor (class name supplied-initarg-names code-generators) (make-instance 'constructor :class class :name name :supplied-initarg-names supplied-initarg-names :code-generators code-generators)) ; This definition actually appears in std-class.lisp. ;(defmethod class-constructors ((class std-class)) ; (with-slots (plist) class (getf plist 'constructors))) (defmethod add-constructor ((class slot-class) (constructor constructor)) (with-slots (plist) class (pushnew constructor (getf plist 'constructors)))) (defmethod remove-constructor ((class slot-class) (constructor constructor)) (with-slots (plist) class (setf (getf plist 'constructors) (delete constructor (getf plist 'constructors))))) (defmethod get-constructor ((class slot-class) name &optional (error-p t)) (or (dolist (c (class-constructors class)) (when (eq (constructor-name c) name) (return c))) (if error-p (error "Couldn't find a constructor with name ~S for class ~S." name class) ()))) ;;; ;;; This is called to actually load a defconstructor constructor. It must ;;; install the lazy installer in the function cell of the constructor name, ;;; and also add this constructor to the list of constructors the class has. ;;; (defmethod load-constructor-internal ((class slot-class) name initargs generators) (let ((constructor (make-constructor class name initargs generators)) (old (get-constructor class name nil))) (when old (remove-constructor class old)) (install-lazy-constructor-installer constructor) (add-constructor class constructor) (setf (gdefinition name) constructor))) (defmethod install-lazy-constructor-installer ((constructor constructor)) (let ((class (constructor-class constructor))) (set-constructor-code constructor #'(lambda (&rest args) (multiple-value-bind (code type) (compute-constructor-code class constructor) (prog1 (apply code args) (set-constructor-code constructor code type)))) 'lazy))) ;;; ;;; The interface to keeping the constructors updated. ;;; ;;; add-method and remove-method (for standard-generic-function and -method), ;;; promise to call maybe-update-constructors on the generic function and ;;; the method. ;;; ;;; The class update code promises to call update-constructors whenever the ;;; class is changed. That is, whenever the supers, slots or options change. ;;; If user defined classes of constructor needs to be updated in more than ;;; these circumstances, they should use the dependent updating mechanism to ;;; make sure update-constructors is called. ;;; ;;; Bootstrapping concerns force the definitions of maybe-update-constructors ;;; and update-constructors to be in the file std-class. For clarity, they ;;; also appear below. Be sure to keep the definition here and there in sync. ;;; ;(defvar *initialization-generic-functions* ; (list #'make-instance ; #'default-initargs ; #'allocate-instance ; #'initialize-instance ; #'shared-initialize)) ; ;(defmethod maybe-update-constructors ; ((generic-function generic-function) ; (method method)) ; (when (memq generic-function *initialization-generic-functions*) ; (labels ((recurse (class) ; (update-constructors class) ; (dolist (subclass (class-direct-subclasses class)) ; (recurse subclass)))) ; (when (classp (car (method-specializers method))) ; (recurse (car (method-specializers method))))))) ; ;(defmethod update-constructors ((class slot-class)) ; (dolist (cons (class-constructors class)) ; (install-lazy-constructor-installer cons))) ; ;(defmethod update-constructors ((class class)) ; ()) ;;; ;;; Here is the actual smarts for making the code generators and then trying ;;; each generator to get constructor code. This extensible mechanism allows ;;; new kinds of constructor code types to be added. A programmer defining a ;;; specialization of the constructor class can either use this mechanism to ;;; define new code types, or can override this mechanism by overriding the ;;; methods on make-constructor-code-generators and compute-constructor-code. ;;; ;;; The function defined by define-constructor-code-type will receive the ;;; class object, and the 4 original arguments to defconstructor. It can ;;; return a constructor code generator, or return nil if this type of code ;;; is determined to not be appropriate after looking at the defconstructor ;;; arguments. ;;; ;;; When compute-constructor-code is called, it first performs basic checks ;;; to make sure that the basic assumptions common to all the code types are ;;; valid. (For details see method definition). If any of the tests fail, ;;; the fallback constructor code type is used. If none of the tests fail, ;;; the constructor code generators are called in order. They receive 5 ;;; arguments: ;;; ;;; CLASS the class the constructor is making instances of ;;; WRAPPER that class's wrapper ;;; DEFAULTS the result of calling class-default-initargs on class ;;; INITIALIZE the applicable methods on initialize-instance ;;; SHARED the applicable methosd on shared-initialize ;;; ;;; The first code generator to return code is used. The code generators are ;;; called in reverse order of definition, so define-constructor-code-type ;;; forms which define better code should appear after ones that define less ;;; good code. The fallback code type appears first. Note that redefining a ;;; code type does not change its position in the list. To do that, define ;;; a new type at the end with the behavior. ;;; (defvar *constructor-code-types* ()) (defmacro define-constructor-code-type (type arglist &body body) (let ((fn-name (intern (format nil "CONSTRUCTOR-CODE-GENERATOR ~A ~A" (package-name (symbol-package type)) (symbol-name type)) *the-pcl-package*))) `(progn (defun ,fn-name ,arglist .,body) (load-define-constructor-code-type ',type ',fn-name)))) (defun load-define-constructor-code-type (type generator) (let ((old-entry (assq type *constructor-code-types*))) (if old-entry (setf (cadr old-entry) generator) (push (list type generator) *constructor-code-types*)) type)) (defmethod make-constructor-code-generators ((class slot-class) name lambda-list supplied-initarg-names supplied-initargs) (cons 'list (gathering1 (collecting) (dolist (entry *constructor-code-types*) (let ((generator (funcall (cadr entry) class name lambda-list supplied-initarg-names supplied-initargs))) (when generator (gather1 `',(car entry)) (gather1 generator))))))) (defmethod compute-constructor-code ((class slot-class) (constructor constructor)) (let* ((proto (class-prototype class)) (wrapper (class-wrapper class)) (defaults (class-default-initargs class)) (make (compute-applicable-methods (gdefinition 'make-instance) (list class))) (supplied-initarg-names (constructor-supplied-initarg-names constructor)) (default (compute-applicable-methods (gdefinition 'default-initargs) (list class supplied-initarg-names))) ;? (allocate (compute-applicable-methods (gdefinition 'allocate-instance) (list class))) (initialize (compute-applicable-methods (gdefinition 'initialize-instance) (list proto))) (shared (compute-applicable-methods (gdefinition 'shared-initialize) (list proto t))) (code-generators (constructor-code-generators constructor))) (flet ((call-code-generator (generator) (when (null generator) (unless (setq generator (getf code-generators 'fallback)) (error "No FALLBACK generator?"))) (funcall generator class wrapper defaults initialize shared))) (if (or (cdr make) (cdr default) (cdr allocate) (not (check-initargs-1 class supplied-initarg-names (append initialize shared) nil nil))) ;; These are basic shared assumptions, if one of the ;; has been violated, we have to resort to the fallback ;; case. Any of these assumptions could be moved out ;; of here and into the individual code types if there ;; was a need to do so. (values (call-code-generator nil) 'fallback) ;; Otherwise try all the generators until one produces ;; code for us. (doplist (type generator) code-generators (let ((code (call-code-generator generator))) (when code (return (values code type))))))))) ;;; ;;; The facilities are useful for debugging, and to measure the performance ;;; boost from constructors. ;;; (defun map-constructors (fn) (let ((nclasses 0) (nconstructors 0)) (labels ((recurse (class) (incf nclasses) (dolist (constructor (class-constructors class)) (incf nconstructors) (funcall fn constructor)) (dolist (subclass (class-direct-subclasses class)) (recurse subclass)))) (recurse (find-class 't)) (values nclasses nconstructors)))) (defun reset-constructors () (multiple-value-bind (nclass ncons) (map-constructors #'install-lazy-constructor-installer ) (format t "~&~D classes, ~D constructors." nclass ncons))) (defun disable-constructors () (multiple-value-bind (nclass ncons) (map-constructors #'(lambda (c) (let ((gen (getf (constructor-code-generators c) 'fallback))) (if (null gen) (error "No fallback constructor for ~S." c) (set-constructor-code c (funcall gen (constructor-class c) () () () ()) 'fallback))))) (format t "~&~D classes, ~D constructors." nclass ncons))) (defun enable-constructors () (reset-constructors)) ;;; ;;; Helper functions and utilities that are shared by all of the code types ;;; and by the main compute-constructor-code method as well. ;;; (defvar *standard-initialize-instance-method* (get-method #'initialize-instance () (list *the-class-slot-object*))) (defvar *standard-shared-initialize-method* (get-method #'shared-initialize () (list *the-class-slot-object* *the-class-t*))) (defun non-pcl-initialize-instance-methods-p (methods) (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*)) methods)) (defun non-pcl-shared-initialize-methods-p (methods) (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*)) methods)) (defun non-pcl-or-after-initialize-instance-methods-p (methods) (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*) (equal '(:after) (method-qualifiers m)))) methods)) (defun non-pcl-or-after-shared-initialize-methods-p (methods) (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*) (equal '(:after) (method-qualifiers m)))) methods)) ;;; ;;; This returns two values. The first is a vector which can be used as the ;;; initial value of the slots vector for the instance. The second is a symbol ;;; describing the initforms this class has. ;;; ;;; If the first value is: ;;; ;;; :unsupplied no slot has an initform ;;; :constants all slots have either a constant initform ;;; or no initform at all ;;; t there is at least one non-constant initform ;;; (defun compute-constant-vector (class) ;;(declare (values constants flag)) (let* ((wrapper (class-wrapper class)) (layout (wrapper-instance-slots-layout wrapper)) (flag :unsupplied) (constants ())) (dolist (slotd (class-slots class)) (let ((name (slot-definition-name slotd)) (initform (slot-definition-initform slotd)) (initfn (slot-definition-initfunction slotd))) (cond ((null (memq name layout))) ((null initfn) (push (cons name *slot-unbound*) constants)) ((constantp initform) (push (cons name (eval initform)) constants) (when (eq flag ':unsupplied) (setq flag ':constants))) (t (push (cons name *slot-unbound*) constants) (setq flag 't))))) (let* ((constants-alist (sort constants #'(lambda (x y) (memq (car y) (memq (car x) layout))))) (constants-list (mapcar #'cdr constants-alist))) (values constants-list flag)))) ;;; ;;; This takes a class and a list of initarg-names, and returns an alist ;;; indicating the positions of the slots those initargs may fill. The ;;; order of the initarg-names argument is important of course, since we ;;; have to respect the rules about the leftmost initarg that fills a slot ;;; having precedence. This function allows initarg names to appear twice ;;; in the list, it only considers the first appearance. ;;; (defun compute-initarg-positions (class initarg-names) (let* ((layout (wrapper-instance-slots-layout (class-wrapper class))) (positions (gathering1 (collecting) (iterate ((slot-name (list-elements layout)) (position (interval :from 0))) (gather1 (cons slot-name position))))) (slot-initargs (mapcar #'(lambda (slotd) (list (slot-definition-initargs slotd) (or (cdr (assq (slot-definition-name slotd) positions)) ':class))) (class-slots class)))) ;; Go through each of the initargs, and figure out what position ;; it fills by replacing the entries in slot-initargs it fills. (dolist (initarg initarg-names) (dolist (slot-entry slot-initargs) (let ((slot-initargs (car slot-entry))) (when (and (listp slot-initargs) (not (null slot-initargs)) (memq initarg slot-initargs)) (setf (car slot-entry) initarg))))) (gathering1 (collecting) (dolist (initarg initarg-names) (let ((positions (gathering1 (collecting) (dolist (slot-entry slot-initargs) (when (eq (car slot-entry) initarg) (gather1 (cadr slot-entry))))))) (when positions (gather1 (cons initarg positions)))))))) ;;; ;;; The FALLBACK case allows anything. This always works, and always appears ;;; as the last of the generators for a constructor. It does a full call to ;;; make-instance. ;;; (define-constructor-code-type fallback (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name supplied-initarg-names)) `(function (lambda (&rest ignore) (declare (ignore ignore)) (function (lambda ,arglist (make-instance ',(class-name class) ,@(gathering1 (collecting) (iterate ((tail (*list-tails supplied-initargs :by #'cddr))) (gather1 `',(car tail)) (gather1 (cadr tail)))))))))) ;;; ;;; The GENERAL case allows: ;;; constant, unsupplied or non-constant initforms ;;; constant or non-constant default initargs ;;; supplied initargs ;;; slot-filling initargs ;;; :after methods on shared-initialize and initialize-instance ;;; (define-constructor-code-type general (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (multiple-value-bind (.constants. .constant-initargs. .initfns-initargs-and-positions. .supplied-initarg-positions. .shared-initfns. .initfns.) (general-generator-internal class defaults init shared ',supplied-initarg-names ',supplied-initargs) .supplied-initarg-positions. (when (and .constants. (null (non-pcl-or-after-initialize-instance-methods-p init)) (null (non-pcl-or-after-shared-initialize-methods-p shared))) (function (lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) (.positions. .supplied-initarg-positions.) (.initargs. .constant-initargs.)) .positions. (dolist (entry .initfns-initargs-and-positions.) (let ((val (funcall (car entry))) (initarg (cadr entry))) (when initarg (push val .initargs.) (push initarg .initargs.)) (dolist (pos (cddr entry)) (setf (%instance-ref .slots. pos) val)))) ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs (unless (constantp value) (gather1 `(let ((.value. ,value)) (push .value. .initargs.) (push ',initarg .initargs.) (dolist (.p. (pop .positions.)) (setf (%instance-ref .slots. .p.) .value.))))))) (dolist (fn .shared-initfns.) (apply fn .instance. t .initargs.)) (dolist (fn .initfns.) (apply fn .instance. .initargs.)) .instance.))))))))) (defun general-generator-internal (class defaults init shared supplied-initarg-names supplied-initargs) (flet ((bail-out () (return-from general-generator-internal nil))) (let* ((constants (compute-constant-vector class)) (layout (wrapper-instance-slots-layout (class-wrapper class))) (initarg-positions (compute-initarg-positions class (append supplied-initarg-names (mapcar #'car defaults)))) (initfns-initargs-and-positions ()) (supplied-initarg-positions ()) (constant-initargs ()) (used-positions ())) ;; ;; Go through each of the supplied initargs for three reasons. ;; ;; - If it fills a class slot, bail out. ;; - If its a constant form, fill the constant vector. ;; - Otherwise remember the positions no two initargs ;; will try to fill the same position, since compute ;; initarg positions already took care of that, but ;; we do need to know what initforms will and won't ;; be needed. ;; (doplist (initarg val) supplied-initargs (let ((positions (cdr (assq initarg initarg-positions)))) (cond ((memq :class positions) (bail-out)) ((constantp val) (setq val (eval val)) (push val constant-initargs) (push initarg constant-initargs) (dolist (pos positions) (setf (svref constants pos) val))) (t (push positions supplied-initarg-positions))) (setq used-positions (append positions used-positions)))) ;; ;; Go through each of the default initargs, for three reasons. ;; ;; - If it fills a class slot, bail out. ;; - If it is a constant, and it does fill a slot, put that ;; into the constant vector. ;; - If it isn't a constant, record its initfn and position. ;; (dolist (default defaults) (let* ((name (car default)) (initfn (cadr default)) (form (caddr default)) (value ()) (positions (cdr (assq name initarg-positions)))) (unless (memq name supplied-initarg-names) (cond ((memq :class positions) (bail-out)) ((constantp form) (setq value (eval form)) (push value constant-initargs) (push name constant-initargs) (dolist (pos positions) (setf (svref constants pos) value))) (t (push (list* initfn name positions) initfns-initargs-and-positions))) (setq used-positions (append positions used-positions))))) ;; ;; Go through each of the slot initforms: ;; ;; - If its position has already been filled, do nothing. ;; The initfn won't need to be called, and the slot won't ;; need to be touched. ;; - If it is a class slot, and has an initform, bail out. ;; - If its a constant or unsupplied, ignore it, it is ;; already in the constant vector. ;; - Otherwise, record its initfn and position ;; (dolist (slotd (class-slots class)) (let* ((alloc (slot-definition-allocation slotd)) (name (slot-definition-name slotd)) (form (slot-definition-initform slotd)) (initfn (slot-definition-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) (unless (null initfn) (bail-out))) ((member position used-positions)) ((or (constantp form) (null initfn))) (t (push (list initfn nil position) initfns-initargs-and-positions))))) (values constants constant-initargs (nreverse initfns-initargs-and-positions) (nreverse supplied-initarg-positions) (mapcar #'method-function (remove *standard-shared-initialize-method* shared)) (mapcar #'method-function (remove *standard-initialize-instance-method* init)))))) ;;; ;;; The NO-METHODS case allows: ;;; constant, unsupplied or non-constant initforms ;;; constant or non-constant default initargs ;;; supplied initargs that are arguments to constructor, or constants ;;; slot-filling initargs ;;; (define-constructor-code-type no-methods (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (multiple-value-bind (.constants. .initfns-and-positions. .supplied-initarg-positions.) (no-methods-generator-internal class defaults ',supplied-initarg-names ',supplied-initargs) .initfns-and-positions. .supplied-initarg-positions. (when (and .constants. (null (non-pcl-initialize-instance-methods-p init)) (null (non-pcl-shared-initialize-methods-p shared))) #'(lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) (.positions. .supplied-initarg-positions.)) .positions. (dolist (entry .initfns-and-positions.) (let ((val (funcall (car entry)))) (dolist (pos (cdr entry)) (setf (%instance-ref .slots. pos) val)))) ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs (unless (constantp value) (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) (setf (%instance-ref .slots. .p.) .value.))))))) .instance.)))))))) (defun no-methods-generator-internal (class defaults supplied-initarg-names supplied-initargs) (flet ((bail-out () (return-from no-methods-generator-internal nil))) (let* ((constants (compute-constant-vector class)) (layout (wrapper-instance-slots-layout (class-wrapper class))) (initarg-positions (compute-initarg-positions class (append supplied-initarg-names (mapcar #'car defaults)))) (initfns-and-positions ()) (supplied-initarg-positions ()) (used-positions ())) ;; ;; Go through each of the supplied initargs for three reasons. ;; ;; - If it fills a class slot, bail out. ;; - If its a constant form, fill the constant vector. ;; - Otherwise remember the positions, no two initargs ;; will try to fill the same position, since compute ;; initarg positions already took care of that, but ;; we do need to know what initforms will and won't ;; be needed. ;; (doplist (initarg val) supplied-initargs (let ((positions (cdr (assq initarg initarg-positions)))) (cond ((memq :class positions) (bail-out)) ((constantp val) (setq val (eval val)) (dolist (pos positions) (setf (svref constants pos) val))) (t (push positions supplied-initarg-positions))) (setq used-positions (append positions used-positions)))) ;; ;; Go through each of the default initargs, for three reasons. ;; ;; - If it fills a class slot, bail out. ;; - If it is a constant, and it does fill a slot, put that ;; into the constant vector. ;; - If it isn't a constant, record its initfn and position. ;; (dolist (default defaults) (let* ((name (car default)) (initfn (cadr default)) (form (caddr default)) (value ()) (positions (cdr (assq name initarg-positions)))) (unless (memq name supplied-initarg-names) (cond ((memq :class positions) (bail-out)) ((constantp form) (setq value (eval form)) (dolist (pos positions) (setf (svref constants pos) value))) (t (push (cons initfn positions) initfns-and-positions))) (setq used-positions (append positions used-positions))))) ;; ;; Go through each of the slot initforms: ;; ;; - If its position has already been filled, do nothing. ;; The initfn won't need to be called, and the slot won't ;; need to be touched. ;; - If it is a class slot, and has an initform, bail out. ;; - If its a constant or unsupplied, do nothing, we know ;; that it is already in the constant vector. ;; - Otherwise, record its initfn and position ;; (dolist (slotd (class-slots class)) (let* ((alloc (slot-definition-allocation slotd)) (name (slot-definition-name slotd)) (form (slot-definition-initform slotd)) (initfn (slot-definition-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) (unless (null initfn) (bail-out))) ((member position used-positions)) ((or (constantp form) (null initfn))) (t (push (list initfn position) initfns-and-positions))))) (values constants (nreverse initfns-and-positions) (nreverse supplied-initarg-positions))))) ;;; ;;; The SIMPLE-SLOTS case allows: ;;; constant or unsupplied initforms ;;; constant default initargs ;;; supplied initargs ;;; slot filling initargs ;;; (define-constructor-code-type simple-slots (class name arglist supplied-initarg-names supplied-initargs) (declare (ignore name)) (let ((raw-allocator (raw-instance-allocator class)) (slots-fetcher (slots-fetcher class))) `(function (lambda (class .wrapper. defaults init shared) (when (and (null (non-pcl-initialize-instance-methods-p init)) (null (non-pcl-shared-initialize-methods-p shared))) (multiple-value-bind (.constants. .supplied-initarg-positions.) (simple-slots-generator-internal class defaults ',supplied-initarg-names ',supplied-initargs) (when .constants. (function (lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) (.positions. .supplied-initarg-positions.)) .positions. ,@(gathering1 (collecting) (doplist (initarg value) supplied-initargs (unless (constantp value) (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) (setf (%instance-ref .slots. .p.) .value.))))))) .instance.)))))))))) (defun simple-slots-generator-internal (class defaults supplied-initarg-names supplied-initargs) (flet ((bail-out () (return-from simple-slots-generator-internal nil))) (let* ((constants (compute-constant-vector class)) (layout (wrapper-instance-slots-layout (class-wrapper class))) (initarg-positions (compute-initarg-positions class (append supplied-initarg-names (mapcar #'car defaults)))) (supplied-initarg-positions ()) (used-positions ())) ;; ;; Go through each of the supplied initargs for three reasons. ;; ;; - If it fills a class slot, bail out. ;; - If its a constant form, fill the constant vector. ;; - Otherwise remember the positions, no two initargs ;; will try to fill the same position, since compute ;; initarg positions already took care of that, but ;; we do need to know what initforms will and won't ;; be needed. ;; (doplist (initarg val) supplied-initargs (let ((positions (cdr (assq initarg initarg-positions)))) (cond ((memq :class positions) (bail-out)) ((constantp val) (setq val (eval val)) (dolist (pos positions) (setf (svref constants pos) val))) (t (push positions supplied-initarg-positions))) (setq used-positions (append used-positions positions)))) ;; ;; Go through each of the default initargs for three reasons. ;; ;; - If it isn't a constant form, bail out. ;; - If it fills a class slot, bail out. ;; - If it is a constant, and it does fill a slot, put that ;; into the constant vector. ;; (dolist (default defaults) (let* ((name (car default)) (form (caddr default)) (value ()) (positions (cdr (assq name initarg-positions)))) (unless (memq name supplied-initarg-names) (cond ((memq :class positions) (bail-out)) ((not (constantp form)) (bail-out)) (t (setq value (eval form)) (dolist (pos positions) (setf (svref constants pos) value))))))) ;; ;; Go through each of the slot initforms: ;; ;; - If its position has already been filled, do nothing. ;; The initfn won't need to be called, and the slot won't ;; need to be touched, we are OK. ;; - If it has a non-constant initform, bail-out. This ;; case doesn't handle those. ;; - If it has a constant or unsupplied initform we don't ;; really need to do anything, the value is in the ;; constants vector. ;; (dolist (slotd (class-slots class)) (let* ((alloc (slot-definition-allocation slotd)) (name (slot-definition-name slotd)) (form (slot-definition-initform slotd)) (initfn (slot-definition-initfunction slotd)) (position (position name layout))) (cond ((neq alloc :instance) (unless (null initfn) (bail-out))) ((member position used-positions)) ((or (constantp form) (null initfn))) (t (bail-out))))) (values constants (nreverse supplied-initarg-positions))))) gcl-2.6.14/pcl/old/plap.lisp0000644000175000017500000003037114360276512014160 0ustar cammcamm;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; ;;; The portable implementation of the LAP assembler. ;;; ;;; The portable implementation of the LAP assembler works by translating ;;; LAP code back into Lisp code and then compiling that Lisp code. Note ;;; that this implementation is actually going to get a lot of use. Some ;;; implementations (KCL) won't implement a native LAP assembler at all. ;;; Other implementations may not implement native LAP assemblers for all ;;; of their ports. All of this implies that this portable LAP assembler ;;; needs to generate the best code it possibly can. ;;; ;;; ;;; ;;; (defmacro lap-case (operand &body cases) (once-only (operand) `(ecase (car ,operand) ,@(mapcar #'(lambda (case) `(,(car case) (apply #'(lambda ,(cadr case) ,@(cddr case)) (cdr ,operand)))) cases)))) (defvar *lap-args*) (defvar *lap-rest-p*) (defvar *lap-i-regs*) (defvar *lap-v-regs*) (defvar *lap-fv-regs*) (defvar *lap-t-regs*) (defvar *lap-optimize-declaration* '#.*optimize-speed*) (eval-when (load eval) (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs vector-regs fixnum-vector-regs t-regs lap-code) (compile-lambda (make-lap-closure-generator-lambda closure-var-names arg-names index-regs vector-regs fixnum-vector-regs t-regs lap-code))) *precompile-lap-closure-generator* #'(lambda (cvars args i-regs v-regs fv-regs t-regs lap) `(function ,(make-lap-closure-generator-lambda cvars args i-regs v-regs fv-regs t-regs lap))) *lap-in-lisp* #'(lambda (cvars args iregs vregs fvregs tregs lap) (declare (ignore cvars args)) (make-lap-prog iregs vregs fvregs tregs (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp) ))))) (defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap) (let* ((rest (memq '&rest args)) (ldiff (and rest (ldiff args rest)))) (when rest (setq args (append ldiff '(&rest .lap-rest-arg.)))) (let* ((*lap-args* (if rest ldiff args)) (*lap-rest-p* (not (null rest)))) `(lambda ,cvars #'(lambda ,args #-CMU (declare ,*lap-optimize-declaration*) #-CMU ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap) #+CMU ;; ;; Use LOCALLY instead of a declare on the lambda so that we don't ;; suppress arg count checking... (locally (declare ,*lap-optimize-declaration*) ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap))))))) (defun make-lap-prog (i-regs v-regs fv-regs t-regs lap) (let* ((*lap-args* 'lap-in-lisp) (*lap-rest-p* 'lap-in-lisp)) (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap))) (defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap) (let* ((*lap-i-regs* i-regs) (*lap-v-regs* v-regs) (*lap-fv-regs* fv-regs) (*lap-t-regs* t-regs) (code (mapcar #'lap-opcode lap))) `(prog ,(mapcar #'(lambda (reg) `(,(lap-reg reg) ,(lap-reg-initial-value-form reg))) (append i-regs v-regs fv-regs t-regs)) (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) (type #+structure-wrapper cache-number-vector #-structure-wrapper (simple-array fixnum) ,@(mapcar #'lap-reg *lap-fv-regs*)) #-cmu ,*lap-optimize-declaration*) ,.code))) (defvar *empty-vector* '#()) (defvar *empty-fixnum-vector* (make-array 8 :element-type 'fixnum :initial-element 0)) (defun lap-reg-initial-value-form (reg) (cond ((member reg *lap-i-regs*) 0) ((member reg *lap-v-regs*) '*empty-vector*) ((member reg *lap-fv-regs*) '*empty-fixnum-vector*) ((member reg *lap-t-regs*) nil) (t (error "What kind of register is ~S?" reg)))) (defun lap-opcode (opcode) (lap-case opcode (:move (from to) `(setf ,(lap-operand to) ,(lap-operand from))) ((:eq :neq :fix=) (arg1 arg2 label) `(when ,(lap-operands (ecase (car opcode) (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=)) arg1 arg2) (go ,label))) ((:izerop) (arg label) `(when ,(lap-operands 'RUNTIME\ IZEROP arg) (go ,label))) (:std-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label))) (:fsc-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label))) (:built-in-instance-p (from label) (declare (ignore from)) `(when ,t (go ,label))) ;*** (:structure-instance-p (from label) `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label))) ;*** ((:jmp :emf-call) (fn) (if (eq *lap-args* 'lap-in-lisp) (error "Can't do a :JMP in LAP-IN-LISP.") `(return ,(if (eq (car opcode) :jmp) (if *lap-rest-p* `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.) `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)) `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args* ,@(when *lap-rest-p* `(.lap-rest-arg.))))))) (:return (value) `(return ,(lap-operand value))) (:label (label) label) (:go (label) `(go ,label)) (:exit-lap-in-lisp () `(go exit-lap-in-lisp)) (:break () `(break)) (:beep () #+Genera`(zl:beep)) (:print (val) (lap-operands 'print val)) )) (defun lap-operand (operand) (lap-case operand (:reg (n) (lap-reg n)) (:cdr (reg) (lap-operands 'cdr reg)) ((:cvar :arg) (name) name) (:constant (c) `',c) ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper :std-slots :fsc-slots :wrapper-cache-number-vector) (x) (lap-operands (ecase (car operand) (:std-wrapper 'RUNTIME\ STD-WRAPPER) (:fsc-wrapper 'RUNTIME\ FSC-WRAPPER) (:built-in-wrapper 'RUNTIME\ BUILT-IN-WRAPPER) (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER) (:built-in-or-structure-wrapper 'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER) (:std-slots 'RUNTIME\ STD-SLOTS) (:fsc-slots 'RUNTIME\ FSC-SLOTS) (:wrapper-cache-number-vector 'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR)) x)) (:i1+ (index) (lap-operands 'RUNTIME\ I1+ index)) (:i+ (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2)) (:i- (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2)) (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2)) (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2)) (:iref (vector index) (lap-operands 'RUNTIME\ IREF vector index)) (:iset (vector index value) (lap-operands 'RUNTIME\ ISET vector index value)) (:instance-ref (vector index) (lap-operands 'RUNTIME\ INSTANCE-REF vector index)) (:instance-set (vector index value) (lap-operands 'RUNTIME\ INSTANCE-SET vector index value)) (:cref (vector i) `(RUNTIME\ SVREF ,(lap-operand vector) ,i)) (:lisp-variable (symbol) symbol) (:lisp (form) form) )) (defun lap-operands (fn &rest regs) (cons fn (mapcar #'lap-operand regs))) (defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*)) ;;; ;;; Runtime Implementations of the operands and opcodes. ;;; ;;; In those ports of PCL which choose not to completely re-implement the ;;; LAP code generator, it may still be provident to consider reimplementing ;;; one or more of these to get the compiler to produce better code. That ;;; is why they are split out. ;;; (proclaim '(declaration pcl-fast-call)) (defmacro RUNTIME\ FUNCALL (fn &rest args) #+CMU `(funcall (the function ,fn) ,.args) #-CMU `(funcall ,fn ,.args)) (defmacro RUNTIME\ APPLY (fn &rest args) #+CMU `(apply (the function ,fn) ,.args) #-CMU `(apply ,fn ,.args)) (defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg) `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg)) (defmacro RUNTIME\ STD-WRAPPER (x) `(std-instance-wrapper ,x)) (defmacro RUNTIME\ FSC-WRAPPER (x) `(fsc-instance-wrapper ,x)) (defmacro RUNTIME\ BUILT-IN-WRAPPER (x) `(built-in-wrapper-of ,x)) (defmacro RUNTIME\ STRUCTURE-WRAPPER (x) `(built-in-or-structure-wrapper ,x)) (defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x) `(built-in-or-structure-wrapper ,x)) (defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x) `(structure-instance-p ,x)) (defmacro RUNTIME\ STD-SLOTS (x) `(std-instance-slots (the std-instance ,x))) (defmacro RUNTIME\ FSC-SLOTS (x) `(fsc-instance-slots ,x)) (defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x) `(wrapper-cache-number-vector ,x)) (defmacro RUNTIME\ STD-INSTANCE-P (x) `(std-instance-p ,x)) (defmacro RUNTIME\ FSC-INSTANCE-P (x) `(fsc-instance-p ,x)) (defmacro RUNTIME\ IZEROP (x) `(zerop (the fixnum ,x))) (defmacro RUNTIME\ FIX= (x y) `(= (the fixnum ,x) (the fixnum ,y))) ;;; ;;; These are the implementations of the index operands. The portable ;;; assembler generates Lisp code that uses these macros. Even though ;;; the variables holding the arguments and results have type declarations ;;; on them, we put type declarations in here. ;;; ;;; Some compilers are so stupid... ;;; (defmacro RUNTIME\ IREF (vector index) #-structure-wrapper `(svref (the simple-vector ,vector) (the fixnum ,index)) #+structure-wrapper `(aref ,vector (the fixnum ,index))) (defmacro RUNTIME\ ISET (vector index value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) (defmacro RUNTIME\ INSTANCE-REF (vector index) #-new-kcl-wrapper `(svref (the simple-vector ,vector) (the fixnum ,index)) #+new-kcl-wrapper `(%instance-ref ,vector (the fixnum ,index))) (defmacro RUNTIME\ INSTANCE-SET (vector index value) #-new-kcl-wrapper `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value) #+new-kcl-wrapper `(setf (%instance-ref ,vector (the fixnum ,index)) ,value)) (defmacro RUNTIME\ SVREF (vector fixnum) #-structure-wrapper `(svref (the simple-vector ,vector) (the fixnum ,fixnum)) #+structure-wrapper `(aref ,vector (the fixnum ,fixnum))) (defmacro RUNTIME\ I+ (index1 index2) `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2)))) (defmacro RUNTIME\ I- (index1 index2) `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2)))) (defmacro RUNTIME\ I1+ (index) `(the fixnum (1+ (the fixnum ,index)))) (defmacro RUNTIME\ ILOGAND (index1 index2) #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2))) #+Lucid `(%logand ,index1 ,index2)) (defmacro RUNTIME\ ILOGXOR (index1 index2) `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2)))) ;;; ;;; In the portable implementation, indexes are just fixnums. ;;; (defconstant index-value-limit most-positive-fixnum) (defun index-value->index (index-value) index-value) (defun index->index-value (index) index) (defun make-index-mask (cache-size line-size) (let ((cache-size-in-bits (floor (log cache-size 2))) (line-size-in-bits (floor (log line-size 2))) (mask 0)) (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) mask)) gcl-2.6.14/pcl/old/dlap.lisp0000644000175000017500000005771714360276512014161 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p)) (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p)) (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p)) (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) (let ((instance nil) (arglist ()) (closure-variables ()) (field (first-wrapper-cache-number-index))) ;;we need some field to do the fast obsolete check (ecase reader/writer (:reader (setq instance (dfun-arg-symbol 0) arglist (list instance))) (:writer (setq instance (dfun-arg-symbol 1) arglist (list (dfun-arg-symbol 0) instance)))) (ecase 1-or-2-class (1 (setq closure-variables '(wrapper-0 index miss-fn))) (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) (generating-lap closure-variables arglist (with-lap-registers ((inst t) ;reg for the instance (wrapper #-structure-wrapper vector ;reg for the wrapper #+structure-wrapper t) #+structure-wrapper (cnv fixnum-vector) (cache-no index)) ;reg for the cache no (let ((index cache-no) ;This register is used ;for different values at ;different times. (slots (and (null class-slot-p) (allocate-register #-new-kcl-wrapper 'vector #+new-kcl-wrapper t))) (csv (and class-slot-p (allocate-register t)))) (prog1 (flatten-lap (opcode :move (operand :arg instance) inst) ;get the instance (opcode :std-instance-p inst 'std-instance) ;if not either std-inst (opcode :fsc-instance-p inst 'fsc-instance) ;or fsc-instance then (opcode :go 'trap) ;we lose (opcode :label 'fsc-instance) (opcode :move (operand :fsc-wrapper inst) wrapper) (and slots (opcode :move (operand :fsc-slots inst) slots)) (opcode :go 'have-wrapper) (opcode :label 'std-instance) (opcode :move (operand :std-wrapper inst) wrapper) (and slots (opcode :move (operand :std-slots inst) slots)) (opcode :label 'have-wrapper) #-structure-wrapper (opcode :move (operand :cref wrapper field) cache-no) #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) #+structure-wrapper (opcode :move (operand :cref cnv field) cache-no) (opcode :izerop cache-no 'trap) ;obsolete wrapper? (ecase 1-or-2-class (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap)) (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap))) (if class-slot-p (flatten-lap (opcode :move (operand :cvar 'index) csv) (ecase reader/writer (:reader (emit-get-class-slot csv 'trap inst)) (:writer (emit-set-class-slot csv (car arglist) inst)))) (flatten-lap (opcode :move (operand :cvar 'index) index) (ecase reader/writer (:reader (emit-get-slot slots index 'trap inst)) (:writer (emit-set-slot slots index (car arglist) inst))))) (opcode :label 'trap) (emit-miss 'miss-fn)) (when slots (deallocate-register slots)) (when csv (deallocate-register csv)))))))) (defun emit-one-index-readers (class-slot-p) (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) (emit-dlap arglist '(standard-instance) 'trap (with-lap-registers ((index index)) (flatten-lap (opcode :move (operand :cvar 'index) index) (if class-slot-p (emit-get-class-slot index 'trap slots) (emit-get-slot slots index 'trap)))) (flatten-lap (opcode :label 'trap) (emit-miss 'miss-fn)) nil (and (null class-slot-p) (list slots))))))) (defun emit-one-index-writers (class-slot-p) (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) (emit-dlap arglist '(t standard-instance) 'trap (with-lap-registers ((index index)) (flatten-lap (opcode :move (operand :cvar 'index) index) (if class-slot-p (emit-set-class-slot index (dfun-arg-symbol 0) slots) (emit-set-slot slots index (dfun-arg-symbol 0))))) (flatten-lap (opcode :label 'trap) (emit-miss 'miss-fn)) nil (and (null class-slot-p) (list nil slots))))))) (defun emit-n-n-readers () (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size miss-fn) arglist (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) (index index)) (emit-dlap arglist '(standard-instance) 'trap (emit-get-slot slots index 'trap) (flatten-lap (opcode :label 'trap) (emit-miss 'miss-fn)) index (list slots)))))) (defun emit-n-n-writers () (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size miss-fn) arglist (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) (index index)) (flatten-lap (emit-dlap arglist '(t standard-instance) 'trap (emit-set-slot slots index (dfun-arg-symbol 0)) (flatten-lap (opcode :label 'trap) (emit-miss 'miss-fn)) index (list nil slots))))))) (defun emit-checking (metatypes applyp) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) (generating-lap '(field cache-vector mask size #-excl-sun4 emf #+excl-sun4 function miss-fn) dlap-lambda-list (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) (flatten-lap (opcode :move (operand :cvar #-excl-sun4 'emf #+excl-sun4 'function) #-excl-sun4 emf #+excl-sun4 function) #-excl-sun4 (opcode :emf-call emf) #+excl-sun4 (opcode :jmp function))) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) (opcode :move (operand :cvar 'miss-fn) miss-function) (opcode :jmp miss-function))) nil)))) (defun emit-caching (metatypes applyp) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) (generating-lap '(field cache-vector mask size miss-fn) dlap-lambda-list (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap (flatten-lap #-excl-sun4 (opcode :emf-call emf) #+excl-sun4 (opcode :jmp function)) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) (opcode :move (operand :cvar 'miss-fn) miss-function) (opcode :jmp miss-function))) #-excl-sun4 emf #+excl-sun4 function))))) (defun emit-constant-value (metatypes) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil))) (generating-lap '(field cache-vector mask size miss-fn) dlap-lambda-list (with-lap-registers ((value t)) (emit-dlap dlap-lambda-list metatypes 'trap (flatten-lap (opcode :return value)) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) (opcode :move (operand :cvar 'miss-fn) miss-function) (opcode :jmp miss-function))) value))))) (defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label) (with-lap-registers ((cwrapper #-structure-wrapper vector #+structure-wrapper t)) (flatten-lap (opcode :move (operand :cvar cwrapper-0) cwrapper) (opcode :neq wrapper cwrapper miss-label)))) ;wrappers not eq, trap (defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label) (with-lap-registers ((cwrapper #-structure-wrapper vector #+structure-wrapper t)) (flatten-lap (opcode :move (operand :cvar cwrapper-0) cwrapper) ;This is an OR. Isn't (opcode :eq wrapper cwrapper 'hit-internal) ;assembly code fun (opcode :move (operand :cvar cwrapper-1) cwrapper) ; (opcode :neq wrapper cwrapper miss-label) ; (opcode :label 'hit-internal)))) (defun emit-get-slot (slots index trap-label &optional temp) (let ((slot-unbound (operand :constant *slot-unbound*))) (with-lap-registers ((val t :reuse temp)) (flatten-lap (opcode :move (operand :instance-ref slots index) val) ;get slot value (opcode :eq val slot-unbound trap-label) ;is the slot unbound? (opcode :return val))))) ;return the slot value (defun emit-set-slot (slots index new-value-arg &optional temp) (with-lap-registers ((new-val t :reuse temp)) (flatten-lap (opcode :move (operand :arg new-value-arg) new-val) ;get new value into a reg (opcode :move new-val (operand :instance-ref slots index));set slot value (opcode :return new-val)))) (defun emit-get-class-slot (index trap-label &optional temp) (let ((slot-unbound (operand :constant *slot-unbound*))) (with-lap-registers ((val t :reuse temp)) (flatten-lap (opcode :move (operand :cdr index) val) (opcode :eq val slot-unbound trap-label) (opcode :return val))))) (defun emit-set-class-slot (index new-value-arg &optional temp) (with-lap-registers ((new-val t :reuse temp)) (flatten-lap (opcode :move (operand :arg new-value-arg) new-val) (opcode :move new-val (operand :cdr index)) (opcode :return new-val)))) (defun emit-miss (miss-fn) (with-lap-registers ((miss-fn-reg t)) (flatten-lap (opcode :move (operand :cvar miss-fn) miss-fn-reg) ;get the miss function (opcode :jmp miss-fn-reg)))) ;and call it (defun dlap-wrappers (metatypes) (mapcar #'(lambda (x) (and (neq x 't) (allocate-register #-structure-wrapper 'vector #+structure-wrapper t))) metatypes)) (defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs) (gathering1 (collecting) (iterate ((mt (list-elements metatypes)) (arg (list-elements args)) (wrapper (list-elements wrappers)) (i (interval :from 0))) (when wrapper (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs))))))) (defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs) (let* ((wrappers (dlap-wrappers metatypes)) (nwrappers (remove nil wrappers)) (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs))) (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg) (mapc #'deallocate-register nwrappers)))) (defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg) (cond ((cdr wrapper-regs) (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg)) ((null value-reg) (emit-1-nil-dlap (car wrapper-regs) (car wrapper-moves) hit miss miss-label)) (t (emit-1-t-dlap (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg)))) (defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label) (with-lap-registers ((location index) (primary index) (cache-vector vector)) (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache-vector) cache-vector) (with-lap-registers ((wrapper-cache-no index)) (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no) (opcode :move primary location) (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) ;inline hit code (opcode :izerop wrapper-cache-no miss-label))) (with-lap-registers ((size index)) (flatten-lap (opcode :move (operand :cvar 'size) size) (opcode :label 'loop) (opcode :move (operand :i1+ location) location) (opcode :fix= location primary miss-label) (opcode :fix= location size 'set-location-to-min) (opcode :label 'continue) (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) (opcode :go 'loop) (opcode :label 'set-location-to-min) (opcode :izerop primary miss-label) (opcode :move (operand :constant (index-value->index 0)) location) (opcode :go 'continue))) miss))) ;;; ;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry ;;; in a cache (svref cache-vector 0). This should probably be abstracted. ;;; (defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value) (with-lap-registers ((location index) (primary index) (cache-vector vector) (initial-lock-count t)) (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache-vector) cache-vector) (with-lap-registers ((wrapper-cache-no index)) (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no) (opcode :move primary location) (opcode :move (operand :cref cache-vector 0) initial-lock-count) ;get lock-count (emit-check-cache-entry cache-vector location wrapper 'hit-internal) (opcode :izerop wrapper-cache-no miss-label))) ;check for obsolescence (with-lap-registers ((size index)) (flatten-lap (opcode :move (operand :cvar 'size) size) (opcode :label 'loop) (opcode :move (operand :i1+ location) location) (opcode :move (operand :i1+ location) location) (opcode :label 'continue) (opcode :fix= location primary miss-label) (opcode :fix= location size 'set-location-to-min) (emit-check-cache-entry cache-vector location wrapper 'hit-internal) (opcode :go 'loop) (opcode :label 'set-location-to-min) (opcode :izerop primary miss-label) (opcode :move (operand :constant (index-value->index 2)) location) (opcode :go 'continue))) (opcode :label 'hit-internal) (opcode :move (operand :i1+ location) location) ;position for getting value (opcode :move (emit-cache-vector-ref cache-vector location) value) (emit-lock-count-test initial-lock-count cache-vector 'hit) miss (opcode :label 'hit) hit))) (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value) (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) (with-lap-registers ((location index) (primary index) (cache-vector vector) (initial-lock-count t) (next-location index) (line-size index)) ;Line size holds a constant ;that can be folded in if there was ;a way to add a constant to ;an index register (flatten-lap (apply #'flatten-lap wrapper-moves) (opcode :move (operand :constant cache-line-size) line-size) (opcode :move (operand :cvar 'cache-vector) cache-vector) (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label) (opcode :move primary location) (opcode :move location next-location) (opcode :move (operand :cref cache-vector 0) initial-lock-count) ;get the lock-count (with-lap-registers ((size index)) (flatten-lap (opcode :move (operand :cvar 'size) size) (opcode :label 'continue) (opcode :move (operand :i+ location line-size) next-location) (emit-check-cache-line cache-vector location wrappers 'hit) (emit-adjust-location location next-location primary size 'continue miss-label) (opcode :label 'hit) (and value (opcode :move (emit-cache-vector-ref cache-vector location) value)) (emit-lock-count-test initial-lock-count cache-vector 'hit-internal) miss (opcode :label 'hit-internal) hit)))))) ;;; ;;; Cache related lap code ;;; (defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code) (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache"))) (with-lap-registers ((cwrapper #-structure-wrapper vector #+structure-wrapper t)) (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache) hit-code (opcode :label exit-emit-check-1-wrapper-in-cache))))) (defun emit-check-cache-entry (cache-vector location wrapper hit-label) (with-lap-registers ((cwrapper #-structure-wrapper vector #+structure-wrapper t)) (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) (opcode :eq cwrapper wrapper hit-label)))) (defun emit-check-cache-line (cache-vector location wrappers hit-label) (let ((checks (flatten-lap (gathering1 (flattening-lap) (iterate ((wrapper (list-elements wrappers))) (with-lap-registers ((cwrapper #-structure-wrapper vector #+structure-wrapper t)) (gather1 (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line) (opcode :move (operand :i1+ location) location))))))))) (flatten-lap checks (opcode :go hit-label) (opcode :label 'exit-emit-check-cache-line)))) (defun emit-lock-count-test (initial-lock-count cache-vector hit-label) ;; ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues ;; (with-lap-registers ((new-lock-count t)) (flatten-lap (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count (opcode :fix= new-lock-count initial-lock-count hit-label)))) (defun emit-adjust-location (location next-location primary size cont-label miss-label) (flatten-lap (opcode :move next-location location) (opcode :fix= location size 'at-end-of-cache) (opcode :fix= location primary miss-label) (opcode :go cont-label) (opcode :label 'at-end-of-cache) (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label) (opcode :move (operand :constant (index-value->index 1)) location) (opcode :go cont-label))) ;; From cache.lisp (defun emit-cache-vector-ref (cache-vector-operand location-operand) (operand :iref cache-vector-operand location-operand)) (defun emit-wrapper-ref (wrapper-operand field-operand) (operand :iref wrapper-operand field-operand)) (defun emit-wrapper-cache-number-vector (wrapper-operand) (operand :wrapper-cache-number-vector wrapper-operand)) (defun emit-cache-number-vector-ref (cnv-operand field-operand) (operand :iref cnv-operand field-operand)) (defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) (with-lap-registers ((mask index) #+structure-wrapper (cnv fixnum-vector)) (let ((field wrapper-cache-no)) (flatten-lap (opcode :move (operand :cvar 'mask) mask) (opcode :move (operand :cvar 'field) field) #-structure-wrapper (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) #+structure-wrapper (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) (defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) (with-lap-registers ((field index) (mask index)) (let ((add-wrapper-cache-numbers (flatten-lap (gathering1 (flattening-lap) (iterate ((wrapper (list-elements wrappers)) (i (interval :from 1))) (gather1 (with-lap-registers ((wrapper-cache-no index) #+structure-wrapper (cnv fixnum-vector)) (flatten-lap #-structure-wrapper (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) #+structure-wrapper (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) (opcode :izerop wrapper-cache-no miss-label) (opcode :move (operand :i+ primary wrapper-cache-no) primary) (when (zerop (mod i wrapper-cache-number-adds-ok)) (opcode :move (operand :ilogand primary mask) primary)))))))))) (flatten-lap (opcode :move (operand :constant 0) primary) (opcode :move (operand :cvar 'field) field) (opcode :move (operand :cvar 'mask) mask) add-wrapper-cache-numbers (opcode :move (operand :ilogand primary mask) primary) (opcode :move (operand :i1+ primary) primary))))) (defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) (with-lap-registers ((arg t)) (ecase metatype ((standard-instance #+new-kcl-wrapper structure-instance) (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) (flatten-lap (opcode :move (operand :arg argument) arg) (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? (opcode :go miss-label) (opcode :label get-fsc-inst-wrapper) (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper (and slot (opcode :move (operand :fsc-slots arg) slot)) (opcode :go exit-emit-fetch-wrapper) (opcode :label get-std-inst-wrapper) (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper (and slot (opcode :move (operand :std-slots arg) slot)) (opcode :label exit-emit-fetch-wrapper)))) (class (when slot (error "Can't do a slot reg for this metatype.")) (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) (flatten-lap (opcode :move (operand :arg argument) arg) (opcode :std-instance-p arg get-std-inst-wrapper) (opcode :fsc-instance-p arg get-fsc-inst-wrapper) #-new-kcl-wrapper (opcode :move (operand :built-in-or-structure-wrapper arg) dest) #+new-kcl-wrapper (opcode :move (operand :built-in-wrapper arg) dest) (opcode :go exit-emit-fetch-wrapper) (opcode :label get-fsc-inst-wrapper) (opcode :move (operand :fsc-wrapper arg) dest) (opcode :go exit-emit-fetch-wrapper) (opcode :label get-std-inst-wrapper) (opcode :move (operand :std-wrapper arg) dest) (opcode :label exit-emit-fetch-wrapper)))) ((built-in-instance #-new-kcl-wrapper structure-instance) (when slot (error "Can't do a slot reg for this metatype.")) (let () (flatten-lap (opcode :move (operand :arg argument) arg) (opcode :std-instance-p arg miss-label) (opcode :fsc-instance-p arg miss-label) #-new-kcl-wrapper (opcode :move (operand :built-in-or-structure-wrapper arg) dest) #+new-kcl-wrapper (opcode :move (operand :built-in-wrapper arg) dest)))))))) gcl-2.6.14/pcl/test/0000755000175000017500000000000014360276512012530 5ustar cammcammgcl-2.6.14/pcl/test/makediff0000644000175000017500000000167114360276512014226 0ustar cammcamm#! /bin/csh if ( -e diff ) rm diff #set out = /tmp/diff set out = diff #set outtmp = /tmp/difftmp set outtmp = difftmp cat /dev/null >! $out #cd may-day-4b foreach f (*.lisp *.text) #set old = ../may-day-4/$f set old = ../../../may-day-4b/$f echo "====================" >> $out if ( -e $old ) then diff -c5 $old $f >&! $outtmp if (! $status) then echo " " $old >> $out echo " " $f >> $out endif cat $outtmp >> $out else echo " " $old "does not exist." >> $out echo " " $f >> $out cat $f >> $out echo " " >> $out endif end echo "====================" >> $out cd .. #mv $out . #Then, use emacs, and type: # c-X c-F diff RET # c-X ( c-S c-Q TAB ESC c-A c-F c-F RET c-SPACE c-E m-X untabify RET c-A DEL c-E c-X ) # m-X name-last-kbd-macro RET untabify-diff-output RET # m-0 m-X untabify-diff-output RET c-X c-S #or, eval the following expression to define the macro: #(fset 'untabify-diff-output "  untabify ") gcl-2.6.14/pcl/test/list-functions.lisp0000644000175000017500000001166414360276512016412 0ustar cammcamm (in-package :pcl) (defvar *defun-list* nil) (defvar *defmethod-list* nil) (defvar *defmacro-list* nil) (defvar *defgeneric-list* nil) (defun list-functions (&optional print-p) (let ((eof '(eof)) (*package* *package*)) (setq *defun-list* nil *defmethod-list* nil *defmacro-list* nil) (labels ((process-form (form) (when (consp form) (case (car form) ((in-package export import shadow shadowing-import) (eval form)) #+lcl3.0 (lcl:handler-bind (eval form)) (let (when print-p (print form))) (defun (push (list (cadr form) (caddr form)) *defun-list*)) (defmethod (push (list (cadr form) (caddr form)) *defmethod-list*)) (defmacro (push (list (cadr form) (caddr form)) *defmacro-list*)) (defgeneric (push (list (cadr form) (caddr form)) *defgeneric-list*)) (eval-when (mapc #'process-form (cddr form))) (progn (mapc #'process-form (cdr form))) ((defvar defparameter defconstant proclaim defsetf defstruct deftype define-compiler-macro)) ((define-walker-template defopcode defoperand define-method-combination define-constructor-code-type defclass)) (t (when print-p (print form))))))) (dolist (file (system-source-files 'pcl)) (with-open-file (in file :direction :input) (loop (let ((form (read in nil eof))) (when (eq form eof) (return nil)) (process-form form)))))) (values (length *defun-list*) (length *defmethod-list*) (length *defmacro-list*) (length *defgeneric-list*)))) (defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions")) (let ((keys nil) (opt nil) (gf-vector (make-array 10 :initial-element nil)) (readers nil) (writers nil) (cv nil) (*package* *the-pcl-package*) (*print-pretty* nil) (s-a-n (find-package "SLOT-ACCESSOR-NAME")) (lisp-sans (mapcar #'slot-reader-symbol '(function type)))) ;; This one has no predefined methods. (defgeneric update-dependent (metaobject dependent &rest initargs)) (map-all-generic-functions #'(lambda (gf) (when (or all-p (let ((name (generic-function-name gf))) (when (consp name) (setq name (cadr name))) (and (not (find #\: (symbol-name name))) (or (eq (symbol-package name) *the-pcl-package*) (and san-p (memq name lisp-sans) (and (eq (symbol-package name) s-a-n) (string= "PCL " (symbol-name name) :end2 4))))))) (let ((ll (generic-function-lambda-list gf))) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords) (analyze-lambda-list ll) (cond ((use-constant-value-dfun-p gf t) (push gf cv)) ((or keysp restp allow-other-keys-p keywords) (push gf keys)) ((plusp noptional) (push gf opt)) ((and (= nrequired 1) (let ((m (generic-function-methods gf))) (and m (every #'standard-reader-method-p m)))) (push gf readers)) ((and (= nrequired 2) (let ((m (generic-function-methods gf))) (and m (every #'standard-writer-method-p m)))) (push gf writers)) (t (push gf (aref gf-vector nrequired))))))))) (with-open-file (out (let* ((system (get-system 'pcl)) (*system-directory* (funcall (car system)))) (make-pathname :defaults (truename (make-source-pathname "defsys")) :name name)) :direction :output) (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%") (format out "(in-package :pcl)~%") (flet ((print-gf-list (list) (setq list (sort (mapcar #'generic-function-name list) #'(lambda (sym1 sym2) (let* ((s1 (if (consp sym1) (cadr sym1) sym1)) (s2 (if (consp sym2) (cadr sym2) sym2)) (p1 (symbol-package s1)) (p2 (symbol-package s2))) (if (eq p1 p2) (string< (symbol-name s1) (symbol-name s2)) (string< (package-name p1) (package-name p2))))))) (dolist (sym list) (let* ((*print-case* :downcase) (gf (gdefinition sym)) (lambda-list (generic-function-lambda-list gf))) (format out "~&~S~%" `(defgeneric ,sym ,lambda-list)) (when show-methods-p (dolist (m (generic-function-methods gf)) (let* ((q (method-qualifiers m)) (qs (if (null q) "" (format nil "~{~S~^ ~}" q))) (s (unparse-specializers m))) (format out "~&; ~7A ~S~%" qs s))) (terpri out)))))) (when cv (format out "~%;;; class predicates~%") (print-gf-list cv)) (when readers (format out "~%;;; readers~%") (print-gf-list readers)) (when writers (format out "~%;;; writers~%") (print-gf-list writers)) (dotimes (i 10) (when (aref gf-vector i) (format out "~%;;; ~D argument~:P ~%" i) (print-gf-list (aref gf-vector i)))) (format out "~%;;; optional arguments ~%") (print-gf-list opt) (format out "~%;;; keyword arguments ~%") (print-gf-list keys)) (terpri out)))) gcl-2.6.14/pcl/test/bench-precompile.lisp0000644000175000017500000000010714360276512016633 0ustar cammcamm(in-package :bench) #+pcl (pcl::precompile-random-code-segments bench) gcl-2.6.14/pcl/test/time.lisp0000644000175000017500000001124414360276512014361 0ustar cammcamm(in-package "PCL") (proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0))) (defvar *tests*) (setq *tests* nil) (defvar m (car (generic-function-methods #'shared-initialize))) (defvar gf #'shared-initialize) (defvar c (find-class 'standard-class)) (defclass str () ((slot :initform nil :reader str-slot)) (:metaclass structure-class)) (defvar str (make-instance 'str)) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" '(time-slot-value m 'plist 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" '(time-slot-value m 'generic-function 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" '(time-slot-value str 'slot 10000)) *tests*) (defun time-slot-value (object slot-name n) (time (dotimes (i n) (slot-value object slot-name)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)" '(time-slot-value-function m 10000)) *tests*) (defun time-slot-value-function (object n) (time (dotimes (i n) (slot-value object 'function)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" '(time-slot-value-slot str 10000)) *tests*) (defun time-slot-value-slot (object n) (time (dotimes (i n) (slot-value object 'slot)))) (push (cons "Time one-class dfun." '(time-generic-function-methods gf 10000)) *tests*) (defun time-generic-function-methods (object n) (time (dotimes (i n) (generic-function-methods object)))) (push (cons "Time one-index dfun." '(time-class-precedence-list c 10000)) *tests*) (defun time-class-precedence-list (object n) (time (dotimes (i n) (class-precedence-list object)))) (push (cons "Time n-n dfun." '(time-method-function m 10000)) *tests*) (defun time-method-function (object n) (time (dotimes (i n) (method-function object)))) (push (cons "Time caching dfun." '(time-class-slots c 10000)) *tests*) (defun time-class-slots (object n) (time (dotimes (i n) (class-slots object)))) (push (cons "Time typep for classes." '(time-typep-standard-object m 10000)) *tests*) (defun time-typep-standard-object (object n) (time (dotimes (i n) (typep object 'standard-object)))) (push (cons "Time default-initargs." '(time-default-initargs (find-class 'plist-mixin) 1000)) *tests*) (defun time-default-initargs (class n) (time (dotimes (i n) (default-initargs class nil)))) (push (cons "Time make-instance." '(time-make-instance (find-class 'plist-mixin) 1000)) *tests*) (defun time-make-instance (class n) (time (dotimes (i n) (make-instance class)))) (push (cons "Time constant-keys make-instance." '(time-constant-keys-make-instance 1000)) *tests*) (expanding-make-instance-top-level (defun constant-keys-make-instance (n) (dotimes (i n) (make-instance 'plist-mixin)))) (precompile-random-code-segments) (defun time-constant-keys-make-instance (n) (time (constant-keys-make-instance n))) (defun expand-all-macros (form) (walk-form form nil #'(lambda (form context env) (if (and (eq context :eval) (consp form) (symbolp (car form)) (not (special-form-p (car form))) (macro-function (car form))) (values (macroexpand form env)) form)))) (push (cons "Macroexpand meth-structure-slot-value" '(pprint (multiple-value-bind (pgf pm) (prototypes-for-make-method-lambda 'meth-structure-slot-value) (expand-defmethod 'meth-structure-slot-value pgf pm nil '((object str)) '(#'(lambda () (slot-value object 'slot))) nil)))) *tests*) #-kcl (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." '(disassemble (meth-structure-slot-value str))) *tests*) (defmethod meth-structure-slot-value ((object str)) #'(lambda () (slot-value object 'slot))) #|| ; interesting, but long. (produces 100 lines of output) (push (cons "Macroexpand meth-standard-slot-value" '(pprint (expand-all-macros (expand-defmethod-internal 'meth-standard-slot-value nil '((object standard-method)) '(#'(lambda () (slot-value object 'function))) nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." '(disassemble (meth-standard-slot-value m))) *tests*) (defmethod meth-standard-slot-value ((object standard-method)) #'(lambda () (slot-value object 'function))) ||# (defun do-tests () (dolist (doc+form (reverse *tests*)) (format t "~&~%~A~%" (car doc+form)) (pprint (cdr doc+form)) (eval (cdr doc+form)))) gcl-2.6.14/pcl/test/bench.lisp0000644000175000017500000004321314360276512014503 0ustar cammcamm;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- (in-package :bench :use '(:lisp #-pcl :clos)) #+(and kcl pcl) (eval-when (compile load eval) (shadowing-import 'pcl::dotimes) ) #+pcl (eval-when (compile load eval) (pcl::use-package-pcl)) #-cmu (defmacro declaim (arg) `(proclaim ',arg)) ;;;Here are a few homebrew benchmarks for testing out Lisp performance. ;;; BENCH-THIS-LISP: benchmarks for common lisp. ;;; BENCH-THIS-CLOS: benchmarks for CLOS. ;;; BENCH-FLAVORS: ditto for Symbolics flavors. ;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP ;;; YOU WANT TO TEST. ;;; ;;;Each benchmark is reported as operations per second. Without-interrupts is ;;; used, so the scheduler isn't supposed to get in the way. Accuracy is ;;; generally between one and five percent. ;;; ;;;Elapsed time is measured using get-internal-run-time. Because the accuracy ;;; of this number is fairly crude, it is important to use a large number of ;;; iterations to get an accurate benchmark. The function median-time may ;;; complain to you if you didn't pick enough iterations. ;;; ;;;July 1992. Watch out! In some cases the instruction being timed will be ;;; optimized away by a clever compiler. Beware of benchmarks that are ;;; nearly as fast as *speed-of-empty-loop*. ;;; ;;;Thanks to Ken Anderson for much of this code. ;;; ;;; jeff morrill ;;; jmorrill@bbn.com #+Genera (eval-when (compile load eval) (import '(clos-internals::allocate-instance))) (declaim (optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0))) ;;;********************************************************************* (deftype positive-integer () '(integer 0 *)) (deftype positive-fixnum () '(and fixnum positive-integer)) (defun repeat (fn n) (declare (type function fn) (type positive-integer n)) (multiple-value-bind (ngroups last) (floor n most-positive-fixnum) (declare (type positive-fixnum ngroups last)) (dotimes (i ngroups) (declare (type positive-fixnum i)) (dotimes (j most-positive-fixnum) (declare (fixnum j)) (funcall fn))) (dotimes (j last) (declare (type positive-fixnum j)) (funcall fn))) n) ;; Most compilers other than KCL have optimizers that make this technique ;; unreliable for simple forms. (eval-when (compile load eval) (declaim (fixnum *simple-repeat-count* *simple-iteration-count* *total-simple-iterations*)) (defparameter *simple-repeat-count* #-kcl 1 #+kcl 10) (defparameter *simple-iteration-count* #-kcl 1 #+kcl 10) (defparameter *total-simple-iterations* (* *simple-repeat-count* *simple-iteration-count*)) ) (defmacro simple-repeat (form) (if (eql *simple-iteration-count* 1) form (let ((result (make-symbol "RESULT"))) `(let ((,result nil)) (dotimes (.i. ,*simple-iteration-count* ,result) (declare (fixnum .i.)) ,@(let ((forms nil)) (dotimes (i *simple-repeat-count* forms) (push `(setq ,result ,form) forms)))))))) (defvar *use-gc-p* t) (defvar *estimated-bytes-per-call* 0) (defvar *bytes-per-word* 4) (declaim (type (and (integer 0 *) fixnum) *bytes-per-word* *estimated-bytes-per-call*)) (defmacro with-optional-gc-control (&body body) `(let (#+cmu (ext:*bytes-consed-between-gcs* (if *use-gc-p* (+ ext:*bytes-consed-between-gcs* (* *estimated-bytes-per-call* n)) ext:*bytes-consed-between-gcs*))) ,@body)) (declaim (single-float *min-time* *one-percent-of-min-time*)) (defvar *min-time* (max 1.0 (/ 400.0 (float internal-time-units-per-second))) "At least 2 orders of magnitude larger than our time resolution.") (defparameter *one-percent-of-min-time* (* *min-time* 0.01)) (defvar *elapsed-time-result*) (defun elapsed-time (function n) "Returns the time (seconds) it takes to call function n times." (declare (type function function) (integer n)) (when (and *use-gc-p* (plusp *estimated-bytes-per-call*)) #+cmu (lisp::gc nil)) (let ((start-time (get-internal-run-time))) (setq *elapsed-time-result* (repeat function n)) (let ((end-time (get-internal-run-time))) (/ (float (abs (- end-time start-time))) (float internal-time-units-per-second))))) (defmacro without-interruption (&body forms) #+genera `(scl:without-interrupts ,@forms) #+lucid `(lcl::with-scheduling-inhibited ,@forms) #+allegro `(excl:without-interrupts ,@forms) #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms)) (declaim (type (function (t function &optional fixnum t) single-float) median-time-internal)) (defvar *warn-if-too-fast-p* nil) (defun median-time-internal (form function n &optional (I 5) (warn-p *warn-if-too-fast-p*)) "Return the median time it takes to evaluate form." ;; I: number of samples to take. (declare (type function function) (fixnum i)) (without-interruption (funcall function) (let ((results nil)) (dotimes (ignore I) (declare (fixnum ignore)) (let ((time (elapsed-time function n))) (declare (single-float time)) (when (and (< time *min-time*) warn-p) (format t "~% Warning. Evaluating ~S took only ~S seconds.~ ~% You should probably use more iterations." form time)) (push time results))) (nth (truncate I 2) (sort results #'<))))) (defmacro median-time (form n &optional (I 5) (warn-p *warn-if-too-fast-p*)) "Return the median time it takes to evaluate form n times." ;; I: number of samples to take. `(median-time-internal ',form #'(lambda () (simple-repeat ,form)) (ceiling ,n ,*total-simple-iterations*) ,i ,warn-p)) #+debug (defun test () (median-time (sleep 1.0) 5)) ;;;********************************************************************* ;;; OPERATIONS-PER-SECOND actually does the work of computing a benchmark. ;;; The amount of time it takes to execute the form N times is recorded, ;;; minus the time it takes to execute the empty loop. OP/S = N/time. ;;; This quantity is recomputed five times and the median value is returned. ;;; Variance in the numbers increases when memory is being allocated (cons, ;;; make-instance, etc). (declaim (type (function (t function &optional fixnum integer) single-float) time-form-internal)) (defun time-form-internal (form function &optional (i 5) (default 100)) (declare (integer default) (fixnum i)) (with-optional-gc-control (let ((time (median-time-internal form function default i nil))) (declare (single-float time)) (loop (when (> time *one-percent-of-min-time*) (return nil)) (setq default (* default 10)) (setq time (median-time-internal form function default i nil))) (when (< time *min-time*) (setq default (ceiling default (/ time *min-time*))) (setq time (median-time-internal form function default i nil))) (/ time (float default))))) (defmacro time-form (form &optional (i 5)) `(/ (time-form-internal ',form #'(lambda () (simple-repeat ,form)) ,i) ,(float *total-simple-iterations*))) (defun compute-speed-of-empty-loop () (time-form nil)) (declaim (single-float *speed-of-empty-loop*)) (defparameter *speed-of-empty-loop* (compute-speed-of-empty-loop)) (format t "~%Empty loops per second: ~40T~8,3E~%" (/ 1.0 *speed-of-empty-loop*)) (defmacro operations-per-second (form &optional (i 5)) "Return the number of times FORM can evaluate in one second." `(/ 1.0 (- (time-form ,form ,i) *speed-of-empty-loop*))) (defmacro defun-timer (name args &body body) `(defun ,name ,args ,@body)) (defmacro bench (pretty-name name) `(progn (format t "~%~A: " ,pretty-name) (force-output) (format t "~40T~8,3E" (,name)))) ;;;**************************************************************************** ;;;BENCH-THIS-LISP ;#+bench-this-lisp (progn (defun-timer Nmult () (let ((a 2.1)) (operations-per-second (* a a)))) (defun-timer Nadd () (let ((a 2.1)) (operations-per-second (+ a a)))) (defun square (x) (* x x)) (defun-timer funcall-1 () ;; inlined (let ((x 2.1)) (operations-per-second (funcall #'(lambda (a) (* a a)) x)))) (defun f1 (n) n) (defun-timer funcall-2 () (let ((f #'f1) (x 2.1)) (operations-per-second (funcall f x)))) (defun-timer funcall-3 () (let ((x 2.1)) (operations-per-second (f1 x)))) (defun-timer funcall-4 () (let ((x 2.1)) (operations-per-second (funcall #'square x)))) (defun-timer funcall-5 () (let ((x 2.1) (f #'square)) (let ((g #'(lambda (x) (operations-per-second (funcall f x))))) (funcall g x)))) (defun-timer Nsetf () (let ((array (make-array 15))) (operations-per-second (setf (aref array 5) t)))) (defun-timer Nsymeval () (operations-per-second (eval T))) (defun-timer Repeatuations () (operations-per-second (eval '(* 2.1 2.1)))) (defun-timer n-cons () (let ((a 1)) (operations-per-second (cons a a)))) (defvar *object* t) (defun-timer nspecial () (operations-per-second (null *object*))) (defun-timer nlexical () (let ((o t)) (operations-per-second (null o)))) (defun-timer nfree () (let ((o t)) (let ((g #'(lambda () #+genera (declare (sys:downward-function)) (operations-per-second (null o))))) (funcall g)))) (defun-timer nfree2 () (let ((o t)) (let ((g #'(lambda () (let ((f #'(lambda () #+genera (declare (sys:downward-function)) (operations-per-second (null o))))) (funcall f))))) (funcall g)))) (defun-timer ncompilations () (let ((lambda-expression '(lambda (bar) (let ((baz t)) (if baz (cons bar nil)))))) (operations-per-second (compile 'bob lambda-expression)))) (defun bench-this-lisp () (bench "(* 2.1 2.1)" nmult) (bench "(+ 2.1 2.1)" nadd) (bench "funcall & (* 2.1 2.1)" funcall-3) (bench "special reference" nspecial) (bench "lexical reference" nlexical) ;; (bench "ivar reference" n-ivar-ref) (bench "(setf (aref array 5) t)" nsetf) (bench "(funcall lexical-f x)" funcall-2) (bench "(f x)" funcall-3) ;; (Bench "(eval t)" nsymeval) ;; (bench "(eval '(* 2.1 2.1))" repeatuations) ;; (bench "(cons 1 2)" n-cons) ;; (bench "compile simple function" ncompilations) ) ;(bench-this-lisp) ) ;;;************************************************************** #+genera (progn (scl:defflavor bar (a b) () :initable-instance-variables :writable-instance-variables) (scl:defflavor frob (c) (bar) :initable-instance-variables :writable-instance-variables) (scl:defmethod (hop bar) () a) (scl:defmethod (set-hop bar) () (setq a n)) (scl:defmethod (nohop bar) () 5) (defun n-ivar-ref () (let ((i (scl:make-instance 'bar :a 0 :b 0))) (ivar-ref i N))) (scl:defmethod (ivar-ref bar) () (operations-per-second b)) (defun-timer Ninstances () (operations-per-second (flavor:make-instance 'bar))) (defun-timer n-svref () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (scl:symbol-value-in-instance instance 'a)))) (defun-timer n-hop () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (hop instance)))) (defun-timer n-gf () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (nohop instance)))) (defun-timer n-set-hop () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (set-hop instance)))) (defun-timer n-type-of () (let ((instance (flavor:make-instance 'bar))) (operations-per-second (flavor::%instance-flavor instance)))) (defun-timer n-bar-b () (let ((instance (flavor:make-instance 'bar :a 0 :b 0))) (operations-per-second (bar-b instance)))) (defun-timer n-frob-bar-b () (let ((instance (flavor:make-instance 'frob :a 0 :b 0))) (operations-per-second (bar-b instance)))) (defun bench-flavors () (bench "flavor:make-instance (2 slots)" ninstances) (bench "flavor:symbol-value-in-instance" n-svref) (bench "1 method, 1 dispatch" n-gf) (bench "slot symbol in method (access)" n-hop) (bench "slot symbol in method (modify)" n-hop) (bench "slot accessor bar" n-bar-b) (bench "slot accessor frob" n-frob-bar-b) (bench "instance-flavor" n-type-of)) ) ; end of #+genera ;;;************************************************************** ;;;BENCH-THIS-CLOS ;;; (evolved from Ken Anderson's tests of Symbolics CLOS) #+pcl (let ((*default-pathname-defaults* pcl::*pcl-directory*)) (load "bench-precompile")) (defmethod strange ((x t)) t) ; default method (defmethod area ((x number)) 'green) ; builtin class (defclass point () ((x :initform 0 :accessor x :initarg :x) (y :initform 0 :accessor y :initarg :y))) (defmethod color ((thing point)) 'red) (defmethod address ((thing point)) 'boston) (defmethod area ((thing point)) 0) (defmethod move-to ((p1 point) (p2 point)) 0) (defmethod x-offset ((thing point)) (with-slots (x y) thing x)) (defmethod set-x-offset ((thing point) new-x) (with-slots (x y) thing (setq x new-x))) (defclass box (point) ((width :initform 10 :accessor width :initarg :width) (height :initform 10 :accessor height :initarg :height))) (defmethod area ((thing box)) 0) (defmethod move-to ((box box) (point point)) 0) (defmethod address :around ((thing box)) (call-next-method)) (defvar p (make-instance 'point)) (defvar b (make-instance 'box)) (defun-timer n-strange () (operations-per-second (strange 5))) (defun-timer n-accesses () (operations-per-second (x p))) (defun-timer n-color () (operations-per-second (color p))) (defun-timer n-call-next-method () (let ((p b)) (operations-per-second (address p)))) (defun-timer n-area-1 () (operations-per-second (area p))) (defun-timer n-area-2 () (operations-per-second (area 5))) (defun-timer n-move-1 () (operations-per-second (move-to p p))) (defun-timer n-move-2 () (let ((x p) (y b)) (operations-per-second (move-to x y)))) (defun-timer n-off () (operations-per-second (x-offset p))) (defun-timer n-setoff () (operations-per-second (set-x-offset p 500))) (defun-timer n-slot-value () (operations-per-second (slot-value p 'x))) (defun-timer n-class-of-1 () (operations-per-second (class-of p))) #| ; cmucl can't compile this. (defun-timer n-class-of-2 () (operations-per-second (class-of 5))) |# (defvar nco2 5) (defun-timer n-class-of-2 () (operations-per-second (class-of nco2))) (defvar *size-of-point* (* *bytes-per-word* 8)) (defun-timer n-alloc () (let ((*estimated-bytes-per-call* *size-of-point*) (c (find-class 'point))) (operations-per-second (allocate-instance c)))) (defun-timer n-make () (let ((*estimated-bytes-per-call* *size-of-point*)) (operations-per-second (make-instance 'point)))) (defun-timer n-make-initargs () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4)))) (operations-per-second (make-instance 'point :x 0 :y 5)))) (defun-timer n-make-variable-initargs () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4))) (x 0) (y 5)) (operations-per-second (make-instance 'point :x x :y y)))) #+pcl (#+pcl pcl::expanding-make-instance-top-level #-pcl progn (defun-timer n-make1 () (let ((*estimated-bytes-per-call* *size-of-point*)) (operations-per-second (make-instance 'point)))) (defun-timer n-make-initargs1 () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4)))) (operations-per-second (make-instance 'point :x 0 :y 5)))) (defun-timer n-make-variable-initargs1 () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4))) (x 0) (y 5)) (operations-per-second (make-instance 'point :x x :y y)))) ) #+pcl (defun compile-and-load-file-if-newer (file &rest other-files) #-cmu (declare (ignore other-files)) #-cmu (load (compile-file (make-pathname :defaults file :type "lisp"))) #+cmu ; uses compile-file-pathname (labels ((type-fwd (file &optional type) (let ((path (if type (make-pathname :defaults file :type type) file))) (if (probe-file path) (file-write-date path) 0))) (fwd (file) (max (type-fwd file "lisp") (type-fwd (compile-file-pathname file))))) (let ((other-fwd 0)) (dolist (other other-files) (setq other-fwd (max other-fwd (fwd (merge-pathnames other))))) (setq file (merge-pathnames file)) (when (< (type-fwd (compile-file-pathname file)) (max (type-fwd file "lisp") other-fwd)) (compile-file file) (load file))))) #+pcl (let ((*default-pathname-defaults* pcl::*pcl-directory*)) (compile-and-load-file-if-newer "bench-precompile" "bench")) #+(and lucid (not pcl)) (lcl::precompile-generic-functions) (defun bench-this-clos () (bench "1 default method" n-strange) (bench "1 dispatch, 1 method" n-color) (bench "1 dispatch, :around + primary" n-call-next-method) (bench "1 dispatch, 3 methods, instance" n-area-1) (bench "1 dispatch, 3 methods, noninstance" n-area-2) (bench "2 dispatch, 2 methods" n-move-1) (bench "slot reader method" n-accesses) (bench "with-slots (1 access)" n-off) (bench "with-slots (1 modify)" n-setoff) (bench "naked slot-value" n-slot-value) (bench "class-of instance" n-class-of-1) (bench "class-of noninstance" n-class-of-2) (bench "allocate-instance (2 slots)" n-alloc) (let ((two-c-i #-pcl "make-instance (2 constant initargs)" #+pcl "make-instance (2 initargs)")) (let ((opt #+(and pcl (not cmu)) "" #+(and pcl cmu) " (opt)" #-pcl "")) (flet ((c (s) (concatenate 'string s opt))) (bench (c "make-instance (2 slots)") n-make) (bench (c two-c-i) n-make-initargs) #-pcl (bench (c "make-instance (2 variable initargs)") n-make-variable-initargs))) #+(and pcl (not cmu)) (let ((opt " (opt)")) (flet ((c (s) (concatenate 'string s opt))) (bench (c "make-instance (2 slots)") n-make1) (bench (c two-c-i) n-make-initargs1) #-pcl (bench (c "make-instance (2 variable initargs)") n-make-variable-initargs1))))) (bench-this-clos) gcl-2.6.14/pcl/test/make-test.lisp0000644000175000017500000000274214360276512015320 0ustar cammcamm(in-package :pcl) (defun top-level-form-form (form) #+cmu (if (and (consp form) (eq (car form) 'eval-when)) (third form) form) #+kcl (fourth (third form)) #+lcl3.0 (third (third form))) (defun make-test () (let ((table (make-hash-table :test 'eq)) (count 0)) (labels ((fixup (form) (if (consp form) (cons (fixup (car form)) (fixup (cdr form))) (if (and (symbolp form) (null (symbol-package form))) (or (gethash form table) (setf (gethash form table) (intern (format nil "~A-%-~D" (symbol-name form) (incf count)) *the-pcl-package*))) form)))) (with-open-file (out "test.lisp" :direction :output :if-exists :supersede) (declare (type stream out)) (let ((*print-case* :downcase) (*print-pretty* t) (*package* *the-pcl-package*)) (format out "~S~%" '(in-package :pcl)) (let ((i 0) (f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL)))) (dolist (form (cdr (top-level-form-form f))) (let ((name (intern (format nil "FGEN-~D" (incf i))))) (format out "~S~%" `(defun ,name () ,(fixup form)))))) (let ((i 0) (f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL)))) (dolist (form (cdr f)) (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i)))) (form (top-level-form-form form))) (format out "~S~%" `(defun ,name () (list ,(second form) ,(third form) ,(fixup (macroexpand (fifth form)))))))))))))) gcl-2.6.14/pcl/test/bench.out0000644000175000017500000000312414360276512014340 0ustar cammcamm cmucl17f cmucl17g lucid411g lucid411c 1 default method: 1.810e+6 1.810e+6 1.250E+6 1.000E+7 1 dispatch, 1 method: 7.394e+5 1.173e+6 9.091E+5 1.429E+6 1 dispatch, :around + primary: 5.398e+5 6.441e+5 2.174E+5 1.093E+5 1 dispatch, 3 methods, instance: 7.394e+5 7.130e+5 9.091E+5 1.429E+6 1 dispatch, 3 methods, noninstance: 6.768e+5 1.023e+6 3.509E+5 1.429E+6 2 dispatch, 2 methods: 5.890e+4 9.070e+5 4.255E+5 8.333E+5 slot reader method: 1.533e+6 1.476e+6 1.111E+6 1.429E+6 with-slots (1 access): 2.738e+5 4.994e+5 2.198E+5 6.452E+5 with-slots (1 modify): 4.872e+5 5.961e+5 4.082E+5 5.882E+5 naked slot-value: 1.215e+5 1.687e+5 6.061E+5 8.696E+5 class-of instance: 4.938e+6 4.938e+6 3.333E+6 1.000E+7 class-of noninstance: 1.896e+6 9.070e+5 7.407E+5 2.857E+6 allocate-instance (2 slots): 8.867e+4 6.813e+4 2.475E+4 1.250E+5 make-instance (2 slots) (opt): 5.798e+3 1.002e+5 2.174E+5 1.266E+5 make-instance (2 initargs) (opt): 5.657e+3 7.206e+4 1.099E+5 1.613E+5 make-instance (2 slots): 5.798e+3 1.002e+5 6.969E+3 1.266E+5 make-instance (2 initargs): 5.657e+3 7.206e+4 5.249E+3 1.613E+5 make-instance (2 variable initargs): 1.754E+5 gcl-2.6.14/pcl/sys-proclaim.lisp0000644000175000017500000032256714360276512015103 0ustar cammcamm (COMMON-LISP::IN-PACKAGE "PCL") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::T) PCL::RENEW-SYS-FILES PCL::MAKE-ARG-INFO PCL::INITIAL-DFUN-INFO PCL::BOOTSTRAP-META-BRAID PCL::UPDATE-DISPATCH-DFUNS PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1 PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2 PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST PCL::STRUCTURE-FUNCTIONS-EXIST-P PCL::SHOW-DFUN-CONSTRUCTORS PCL::DEFAULT-METHOD-ONLY-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO PCL::MAKE-CPD PCL::%%ALLOCATE-INSTANCE--CLASS PCL::IN-THE-COMPILER-P PCL::SHOW-EMF-CALL-TRACE PCL::DISPATCH-DFUN-INFO PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS PCL::NO-METHODS-DFUN-INFO PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CACHE PCL::GET-EFFECTIVE-METHOD-GENSYM PCL::CACHES-TO-ALLOCATE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| PCL::EMIT-CHECKING-OR-CACHING-FUNCTION PCL::LOAD-SHORT-DEFCOMBIN PCL::|(FAST-METHOD CHANGE-CLASS (T SYMBOL))| PCL::|(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| PCL::ACCESSOR-MISS PCL::EMIT-CHECKING-OR-CACHING PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION PCL::MAKE-FINAL-CHECKING-DFUN PCL::GET-ACCESSOR-METHOD-FUNCTION PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| PCL::|(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| PCL::|(FAST-METHOD NO-APPLICABLE-METHOD (T))| PCL::BOOTSTRAP-ACCESSOR-DEFINITION PCL::|(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| PCL::|(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| PCL::EXPAND-CACHE PCL::|(FAST-METHOD MAKE-INSTANCE (SYMBOL))| PCL::|(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| PCL::|(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY PCL::|(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN PCL::|(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| PCL::|(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| PCL::ACCESSOR-VALUES PCL::REAL-MAKE-METHOD-LAMBDA PCL::|(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| PCL::GENERATE-DISCRIMINATION-NET PCL::MAKE-SHARED-INITIALIZE-FORM-LIST PCL::ORDER-SPECIALIZERS PCL::SET-CLASS-SLOT-VALUE-1 PCL::|(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| PCL::|(FAST-METHOD DESCRIBE-OBJECT (T T))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::|(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| PCL::CACHING-MISS PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION PCL::EMIT-READER/WRITER PCL::|(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| PCL::ACCESSOR-VALUES1 PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER PCL::FIX-SLOT-ACCESSORS PCL::CHECK-METHOD-ARG-INFO PCL::EMIT-READER/WRITER-FUNCTION PCL::GET-CLASS-SLOT-VALUE-1 PCL::|(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| PCL::|(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-CACHING-DFUN ITERATE::RENAME-VARIABLES PCL::CHECKING-MISS PCL::GENERATING-LISP PCL::|(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| WALKER::WALK-LET-IF PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::|(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION WALKER::WALK-FORM-INTERNAL ITERATE::WALK-GATHERING-BODY PCL::ACCESSOR-VALUES-INTERNAL PCL::CACHE-MISS-VALUES PCL::CONSTANT-VALUE-MISS PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET PCL::|(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| PCL::|(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| PCL::LOAD-LONG-DEFCOMBIN PCL::|(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| PCL::SLOT-BOUNDP-USING-CLASS-DFUN PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| PCL::SET-SLOT-VALUE PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::SLOT-VALUE-OR-DEFAULT PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE PCL::LOAD-DEFGENERIC PCL::MAKE-DEFAULT-INITARGS-FORM-LIST PCL::GET-SIMPLE-INITIALIZATION-FUNCTION PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS PCL::CPL-ERROR PCL::GET-EFFECTIVE-METHOD-FUNCTION PCL::MAKE-CHECKING-DFUN PCL::MAKE-EFFECTIVE-METHOD-FUNCTION PCL::REAL-ADD-METHOD PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION PCL::MAKE-ACCESSOR-TABLE WALKER::NESTED-WALK-FORM PCL::MAKE-N-N-ACCESSOR-DFUN PCL::TYPES-FROM-ARGUMENTS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| PCL::|(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1 PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| PCL::|(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| PCL::|(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| PCL::MAKE-INSTANCE-FUNCTION-SIMPLE PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| PCL::|(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| PCL::|(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| PCL::MAKE-INSTANCE-FUNCTION-COMPLEX PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::|(FAST-METHOD SLOT-MISSING (T T T T))| PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| ITERATE::ITERATE-TRANSFORM-BODY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) PCL::NON-NEGATIVE-FIXNUM) PCL::CACHE-SIZE PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-MASK)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::DO-SHORT-METHOD-COMBINATION PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION PCL::GENERATE-DISCRIMINATION-NET-INTERNAL PCL::MEMF-CODE-CONVERTER PCL::CACHE-MISS-VALUES-INTERNAL PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::GET-SECONDARY-DISPATCH-FUNCTION WALKER::WALK-DECLARATIONS PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T)) PCL::MAKE-CLASS-PREDICATE-NAME PCL::MAKE-KEYWORD)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::REAL-MAKE-A-METHOD)) (COMMON-LISP::MAPC (COMMON-LISP::LAMBDA (COMPILER::X) (COMMON-LISP::SETF (COMMON-LISP::GET COMPILER::X 'COMPILER::PROCLAIMED-CLOSURE) COMMON-LISP::T)) '(PCL::TRACE-METHOD-INTERNAL PCL::FDEFINE-CAREFULLY PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::DO-STANDARD-DEFSETF-1 PCL::REDEFINE-FUNCTION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FUNCTION) PCL::METHOD-CALL-FUNCTION PCL::CACHE-LIMIT-FN PCL::FAST-METHOD-CALL-FUNCTION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) PCL::GF-INFO-STATIC-C-A-M-EMF PCL::GET-MAKE-INSTANCE-FUNCTION-SYMBOL PCL::FGEN-SYSTEM PCL::SETFBOUNDP PCL::ONE-CLASS-CACHE PCL::PARSE-SPECIALIZERS PCL::UNENCAPSULATED-FDEFINITION PCL::INTERN-EQL-SPECIALIZER PCL::ECD-OTHER-INITARGS SYSTEM::%STRUCTURE-NAME PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DEFAULT-STRUCTURE-TYPE WALKER::VARIABLE-GLOBALLY-SPECIAL-P PCL::INITIALIZE-INFO-P PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::COUNT-DFUN PCL::ONE-CLASS-INDEX PCL::ONE-INDEX-DFUN-INFO-P PCL::ARG-INFO-LAMBDA-LIST PCL::DNET-METHODS-P PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION PCL::ARG-INFO-METATYPES PCL::UNDEFMETHOD-1 WALKER::ENV-WALK-FORM PCL::INITIALIZE-INFO-CACHED-VALID-P PCL::STRUCTURE-SVUC-METHOD PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL PCL::EVAL-FORM PCL::DEFAULT-CONSTANTP PCL::SLOT-BOUNDP-SYMBOL PCL::MAKE-FUNCTION-INLINE PCL::CHECK-WRAPPER-VALIDITY PCL::COMPUTE-LINE-SIZE PCL::STRUCTURE-SLOT-BOUNDP PCL::DEFAULT-METHOD-ONLY-CACHE PCL::GF-DFUN-CACHE PCL::MAKE-CALLS-TYPE-DECLARATION PCL::INITIAL-P PCL::ACCESSOR-DFUN-INFO-CACHE PCL::EARLY-CLASS-SLOTS PCL::COMPUTE-STD-CPL-PHASE-2 PCL::STRUCTURE-SLOTD-NAME PCL::BOOTSTRAP-CLASS-PREDICATES PCL::EARLY-METHOD-QUALIFIERS WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE PCL::MAKE-CONSTANT-FUNCTION PCL::CPD-SUPERS PCL::INITIAL-DISPATCH-P PCL::METHOD-FUNCTION-METHOD PCL::MAP-ALL-GENERIC-FUNCTIONS PCL::STRUCTURE-SLOTD-READER-FUNCTION PCL::MAKE-PERMUTATION-VECTOR PCL::DISPATCH-P PCL::CHECKING-P PCL::CHECKING-FUNCTION PCL::FGEN-GENERATOR PCL::ARG-INFO-NUMBER-OPTIONAL PCL::EXTRACT-PARAMETERS ITERATE::VARIABLES-FROM-LET PCL::STRUCTURE-TYPE-P PCL::ONE-INDEX-INDEX PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1 PCL::TWO-CLASS-CACHE PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-SETF-FUNCTION-NAME PCL::ARG-INFO-PRECEDENCE PCL::INITIALIZE-INFO-CACHED-CONSTANTS PCL::FUNCALLABLE-INSTANCE-P PCL::%FBOUNDP COMMON-LISP::CLASS-OF PCL::EARLY-CLASS-DEFINITION PCL::SORT-CALLS PCL::%CCLOSURE-ENV PCL::ACCESSOR-DFUN-INFO-P PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION PCL::WRAPPER-FIELD PCL::STRUCTURE-SLOTD-INIT-FORM PCL::CACHING-CACHE PCL::CHECK-CACHE PCL::TWO-CLASS-P PCL::ECD-SOURCE PCL::EARLY-METHOD-STANDARD-ACCESSOR-P PCL::TYPE-CLASS PCL::ECD-METACLASS PCL::CONSTANT-VALUE-DFUN-INFO PCL::%STD-INSTANCE-WRAPPER PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::EARLY-COLLECT-DEFAULT-INITARGS PCL::COMPUTE-CLASS-SLOTS PCL::UNPARSE-SPECIALIZERS PCL::CONSTANT-VALUE-CACHE PCL::EARLY-COLLECT-CPL PCL::EXPAND-LONG-DEFCOMBIN PCL::FUNCTION-RETURNING-T PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::FAST-METHOD-CALL-ARG-INFO PCL::SHOW-DFUN-COSTS PCL::CANONICAL-SLOT-NAME PCL::ARG-INFO-APPLYP PCL::ONE-CLASS-P PCL::FORMAT-CYCLE-REASONS PCL::STRUCTURE-TYPE PCL::USE-CACHING-DFUN-P PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME PCL::DFUN-INFO-P PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL PCL::ECD-CANONICAL-SLOTS PCL::GET-PV-CELL-FOR-CLASS PCL::ECD-CLASS-NAME PCL::SFUN-P PCL::EARLY-GF-NAME PCL::DISPATCH-CACHE PCL::NO-METHODS-CACHE PCL::CCLOSUREP PCL::ARG-INFO-VALID-P PCL::CACHING-DFUN-INFO PCL::GET-MAKE-INSTANCE-FUNCTIONS PCL::SYMBOL-PKG-NAME PCL::ARG-INFO-KEYWORDS PCL::UPDATE-C-A-M-GF-INFO PCL::COPY-CACHE PCL::INITIALIZE-INFO-KEY PCL::CHECKING-CACHE PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::MAKE-PV-TYPE-DECLARATION PCL::STRUCTURE-OBJECT-P PCL::STRUCTURE-SLOTD-WRITER-FUNCTION PCL::UPDATE-GF-INFO PCL::WRAPPER-FOR-STRUCTURE PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE PCL::CACHING-DFUN-COST PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE PCL::DEFAULT-STRUCTURE-INSTANCE-P PCL::FREE-CACHE-VECTOR PCL::GFS-OF-TYPE PCL::MAKE-CALL-METHODS WALKER::GET-WALKER-TEMPLATE PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION PCL::METHOD-CALL-P ITERATE::SEQUENCE-ACCESSOR PCL::METHOD-LL->GENERIC-FUNCTION-LL PCL::SLOT-WRITER-SYMBOL PCL::NEXT-WRAPPER-FIELD PCL::DEFAULT-METHOD-ONLY-P PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::TWO-CLASS-WRAPPER0 PCL::WRAPPER-OF PCL::STD-INSTANCE-P PCL::GET-CACHE-VECTOR PCL::EARLY-CLASS-DIRECT-SUBCLASSES PCL::FAST-METHOD-CALL-P PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST PCL::N-N-P PCL::TWO-CLASS-WRAPPER1 PCL::DEFAULT-CONSTANT-CONVERTER PCL::ONE-INDEX-ACCESSOR-TYPE PCL::CONSTANT-VALUE-P PCL::CPD-CLASS PCL::ARG-INFO-NKEYS PCL::GMAKUNBOUND PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION PCL::INITIAL-DISPATCH-CACHE PCL::GENERIC-CLOBBERS-FUNCTION PCL::ECD-SUPERCLASS-NAMES PCL::LOOKUP-FGEN PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION PCL::GDEFINITION PCL::UPDATE-ALL-C-A-M-GF-INFO PCL::FAST-INSTANCE-BOUNDP-P PCL::N-N-ACCESSOR-TYPE PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST WALKER::ENV-WALK-FUNCTION PCL::CPD-AFTER PCL::METHOD-FUNCTION-PLIST PCL::ONE-INDEX-DFUN-INFO-INDEX PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P PCL::FREE-CACHE SYSTEM::%COMPILED-FUNCTION-NAME PCL::MAKE-INITFUNCTION PCL::SORT-SLOTS PCL::KEYWORD-SPEC-NAME PCL::GF-DFUN-INFO PCL::DEFAULT-STRUCTUREP PCL::LIST-LARGE-CACHE PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS PCL::N-N-CACHE PCL::INTERNED-SYMBOL-P PCL::ONE-INDEX-P PCL::NET-TEST-CONVERTER WALKER::ENV-LOCK PCL::EXTRACT-LAMBDA-LIST PCL::COMPUTE-MCASE-PARAMETERS PCL::LEGAL-CLASS-NAME-P PCL::GF-INFO-FAST-MF-P PCL::ALLOCATE-CACHE-VECTOR PCL::ONE-CLASS-WRAPPER0 PCL::EARLY-METHOD-LAMBDA-LIST PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::GBOUNDP PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS PCL::SLOT-READER-SYMBOL PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME PCL::CACHE-P PCL::MAKE-INSTANCE-FUNCTION-SYMBOL PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::ONE-INDEX-DFUN-INFO-CACHE PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION PCL::MAKE-CLASS-EQ-PREDICATE PCL::%SYMBOL-FUNCTION PCL::SLOT-VECTOR-SYMBOL PCL::MAKE-EQL-PREDICATE PCL::CLASS-PREDICATE PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION PCL::ONE-INDEX-CACHE PCL::EARLY-CLASS-PRECEDENCE-LIST PCL::STANDARD-SVUC-METHOD PCL::EARLY-CLASS-NAME PCL::INITIALIZE-INFO-WRAPPER PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE PCL::EXPAND-MAKE-INSTANCE-FORM PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P PCL::CONSTANT-SYMBOL-P PCL::CACHE-OWNER PCL::FGEN-GENSYMS PCL::EARLY-COLLECT-SLOTS PCL::FGEN-GENERATOR-LAMBDA PCL::COMPLICATED-INSTANCE-CREATION-METHOD PCL::RESET-INITIALIZE-INFO PCL::TWO-CLASS-ACCESSOR-TYPE PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P PCL::EARLY-METHOD-CLASS PCL::METHOD-FUNCTION-PV-TABLE PCL::LIST-DFUN PCL::INITIAL-CACHE PCL::PV-TABLEP PCL::GF-INFO-C-A-M-EMF-STD-P PCL::DFUN-ARG-SYMBOL PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::TWO-CLASS-INDEX PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::FGEN-TEST PCL::FUNCTION-RETURNING-NIL PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P PCL::INITIALIZE-INFO-BOUND-SLOTS PCL::ARG-INFO-P PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST PCL::CLASS-FROM-TYPE WALKER::ENV-LEXICAL-VARIABLES PCL::DFUN-INFO-CACHE PCL::INTERN-FUNCTION-NAME PCL::EARLY-SLOT-DEFINITION-LOCATION PCL::CACHING-P PCL::NO-METHODS-P PCL::ARG-INFO-KEY/REST-P PCL::GF-LAMBDA-LIST PCL::EXTRACT-SPECIALIZER-NAMES PCL::EXPAND-SHORT-DEFCOMBIN PCL::STORE-FGEN PCL::BUILT-IN-WRAPPER-OF PCL::INITIALIZE-INFO-CACHED-NEW-KEYS PCL::EARLY-CLASS-SLOTDS PCL::FORCE-CACHE-FLUSHES PCL::EARLY-GF-P PCL::STRUCTURE-SLOTD-TYPE PCL::INITIALIZE-INFO-CACHED-RI-VALID-P PCL::ONE-CLASS-ACCESSOR-TYPE PCL::CLASS-PRECEDENCE-DESCRIPTION-P WALKER::ENV-DECLARATIONS PCL::EARLY-SLOT-DEFINITION-NAME PCL::FAST-METHOD-CALL-PV-CELL PCL::%STD-INSTANCE-SLOTS PCL::EXTRACT-REQUIRED-PARAMETERS PCL::EARLY-CLASS-NAME-OF PCL::DEFAULT-TEST-CONVERTER PCL::FUNCTION-PRETTY-ARGLIST)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::*) PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE PCL::MAKE-PROGN COMMON-LISP::METHOD-COMBINATION-ERROR PCL::UNTRACE-METHOD PCL::LIST-LARGE-CACHES PCL::FIX-EARLY-GENERIC-FUNCTIONS COMMON-LISP::INVALID-METHOD-ERROR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::FIXNUM COMMON-LISP::*) COMMON-LISP::T) PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION PCL::GET-CACHE-FROM-CACHE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::FIXNUM COMMON-LISP::T) COMMON-LISP::FIXNUM) PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::INTEGER 1 256)) PCL::CACHE-LINE-SIZE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::INTEGER 1 255)) PCL::CACHE-NKEYS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST PCL::MODIFY-CACHE PCL::CHECKING-DFUN-INFO WALKER::WALKER-ENVIRONMENT-BIND PCL::INITIALIZE-INFO-COMBINED-INITIALIZE-FUNCTION PCL::CACHE-LOCK-COUNT PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-CLASS-CELL-CLASS PCL::MAKE-DFUN-LAMBDA-LIST PCL::WRAPPER-REF PCL::SIMPLE-LEXICAL-METHOD-FUNCTIONS PCL::INITIAL-CLASSES-AND-WRAPPERS PCL::UPDATE-SLOTS PCL::ASSQ PCL::ADD-DIRECT-SUBCLASSES PCL::SAUT-NOT-CLASS-EQ PCL::CHECK-MEMBER PCL::FIN-LAMBDA-FN PCL::INSTANCE-SLOT-INDEX PCL::SAUT-NOT-CLASS WALKER::VARIABLE-SYMBOL-MACRO-P COMMON-LISP::SYMBOL-MACROLET PCL::PV-TABLE-LOOKUP PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL::MCASE PCL::PRINTING-RANDOM-THING PCL::MAYBE-CHECK-CACHE WALKER::WITH-NEW-DEFINITION-IN-ENVIRONMENT PCL::WITH-MAKE-INSTANCE-FUNCTION-VALID-P-CHECK PCL::WRAPPER-CLASS* PCL::FSC-INSTANCE-WRAPPER PCL::FUNCALLABLE-INSTANCE-DATA-1 PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::DEFINE-INITIALIZE-INFO ITERATE::LIST-ELEMENTS PCL::INSTANCE-READ PCL::EMIT-1-NIL-DLAP PCL::RESET-INITIALIZE-INFO-INTERNAL PCL::QUALIFIER-CHECK-RUNTIME PCL::STD-INSTANCE-CLASS PCL::EMIT-READER/WRITER-MACRO PCL::UNDEFMETHOD PCL::SCASE PCL::EMIT-DEFAULT-ONLY-MACRO PCL::INSTANCE-WRITE PCL::PV-BINDING PCL::DELQ PCL::FIND-STANDARD-II-METHOD PCL::ACCESSOR-SLOT-VALUE PCL::SET-STANDARD-SVUC-METHOD ITERATE::JOINING PCL::COMPUTE-STD-CPL PCL::PCL-DESTRUCTURING-BIND PCL::FIND-CLASS-CELL-PREDICATE PCL::UPDATE-STD-OR-STR-METHODS PCL::EARLY-GF-ARG-INFO PCL::PRECOMPILE-DFUN-CONSTRUCTORS PCL::FUNCTION-FUNCALL PCL::DFUN-INFO-FUNCTION PCL::CALLSREF PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::RASSQ PCL::REMOVE-DIRECT-SUBCLASSES PCL::MEC-ALL-CLASS-LISTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS ITERATE::SUMMING PCL::SET-METHODS PCL::WITH-HASH-TABLE PCL::INITIALIZE-INFO-SHARED-INITIALIZE-NIL-FUNCTION PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS PCL::METHOD-FUNCTION-RETURNING-NIL PCL::WRAPPER-STATE PCL::WITH-LOCAL-CACHE-FUNCTIONS PCL::DFUN-INFO-ACCESSOR-TYPE PCL::CHECK-WRAPPER-VALIDITY1 PCL::INVALID-WRAPPER-P PCL::INSTANCE-BOUNDP COMMON-LISP::DEFINE-METHOD-COMBINATION PCL::DO-SATISFIES-DEFTYPE PCL::EQL-TEST PCL::PRECOMPILE-IIS-FUNCTIONS PCL::PRINTING-RANDOM-THING-INTERNAL PCL::UPDATE-INITIALIZE-INFO-INTERNAL ITERATE::WITH-GATHERING PCL::BOOTSTRAP-GET-SLOT PCL::INITIALIZE-INFO-CONSTANTS PCL::GET-INSTANCE-WRAPPER-OR-NIL PCL::BIND-LEXICAL-METHOD-FUNCTIONS PCL::VECTORIZING PCL::N-N-DFUN-INFO PCL::INSTANCE-ACCESSOR-PARAMETER PCL::IF* PCL::PV-OFFSET PCL::GET-SLOTS PCL::CACHE-NUMBER-VECTOR-REF PCL::ALLOCATE-STANDARD-INSTANCE--MACRO ITERATE::MINIMIZING PCL::%SET-CCLOSURE-ENV PCL::ALLOCATE-FUNCALLABLE-INSTANCE-SLOTS WALKER::DEFINE-WALKER-TEMPLATE COMMON-LISP::WITH-ACCESSORS PCL::MAKE-CDXR COMMON-LISP::DEFMETHOD PCL::SYMBOL-LESSP PCL::INVOKE-FAST-METHOD-CALL PCL::BIND-SIMPLE-LEXICAL-METHOD-MACROS PCL::CANONICALIZE-DEFCLASS-OPTION PCL::DESCRIBE-PACKAGE PCL::%SET-SVREF PCL::FSC-INSTANCE-P PCL::MAKE-DFUN-ARG-LIST PCL::GET-SLOTS-OR-NIL PCL::WRAPPER-INSTANCE-SLOTS-LAYOUT PCL::DO-STANDARD-DEFSETF PCL::STD-INSTANCE-SLOTS PCL::INVOKE-METHOD-CALL1 PCL::PARSE-GSPEC PCL::ACCESSOR-SET-SLOT-VALUE PCL::DEFINE-CACHED-READER PCL::INITIALIZE-INFO-MAKE-INSTANCE-FUNCTION-SYMBOL PCL::SET-WRAPPER PCL::SAUT-NOT-PROTOTYPE PCL::MAKE-CLASS-PREDICATE PCL::FIRST-WRAPPER-CACHE-NUMBER-INDEX PCL::MDOTIMES PCL::FUNCTION-APPLY PCL::UPDATE-CLASS PCL::GET-KEY-ARG1 WALKER::ENVIRONMENT-FUNCTION PCL::DOPLIST PCL::WRAPPER-CLASS-SLOTS PCL::FMC-FUNCALL WALKER::VARIABLE-LEXICAL-P COMMON-LISP::ADD-METHOD PCL::INSTANCE-READER ITERATE::EACHTIME PCL::CLASSES-HAVE-COMMON-SUBCLASS-P PCL::INITIALIZE-INFO-INITARGS-FORM-LIST PCL::REMOVE-SLOT-ACCESSORS PCL::DEFINE-GF-PREDICATE PCL::CHANGE-CLASS-INTERNAL PCL::INVOKE-METHOD-CALL PCL::PARSE-QUALIFIER-PATTERN COMMON-LISP::CALL-METHOD PCL::IIS-BODY PCL::NO-SLOT PCL::WRAPPER-NO-OF-INSTANCE-SLOTS PCL::SET-FUNCTION-PRETTY-ARGLIST PCL::INSTANCE-WRITE-INTERNAL PCL::MEMQ PCL::MAP-PV-TABLE-REFERENCES-OF PCL::|SETF PCL FIND-CLASS| COMMON-LISP::SLOT-EXISTS-P PCL::WITH-DFUN-WRAPPERS PCL::CLASS-MIGHT-PRECEDE-P PCL::BOOTSTRAP-SLOT-INDEX PCL::MEC-ALL-CLASSES-INTERNAL PCL::%SVREF PCL::INITIALIZE-INFO-DEFAULT-INITARGS-FUNCTION ITERATE::COLLECTING PCL::MAKE-FIND-CLASS-CELL PCL::COMPUTE-PV PCL::SUPERCLASSES-COMPATIBLE-P PCL::REDIRECT-EARLY-FUNCTION-INTERNAL WALKER::WITH-AUGMENTED-ENVIRONMENT PCL::WITHOUT-INTERRUPTS PCL::CACHE-VECTOR-LOCK-COUNT SYSTEM::%SET-COMPILED-FUNCTION-NAME PCL::MAKE-WRAPPER-INTERNAL PCL::ASV-FUNCALL PCL::FUNCALLABLE-INSTANCE-DATA-POSITION PCL::WRAPPER-CLASS PCL::DFUN-INFO-WRAPPER1 ITERATE::LIST-TAILS PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL::DEFCONSTRUCTOR PCL::MAKE-METHOD-FUNCTION PCL::VALUE-FOR-CACHING PCL::INITIALIZE-INFO-VALID-P PCL::MAKE-DLAP-LAMBDA-LIST PCL::GET-WRAPPER PCL::*LIST-TAILS PCL::UPDATE-CPL PCL::SET-STRUCTURE-SVUC-METHOD PCL::POSQ PCL::SYMBOL-OR-CONS-LESSP PCL::FSC-INSTANCE-SLOTS PCL::ADD-TO-CVECTOR PCL::AUGMENT-TYPE PCL::DFUN-MISS PCL::INVOKE-EFFECTIVE-METHOD-FUNCTION-FAST PCL::ALIST-ENTRY PCL::MEMF-CONSTANT-CONVERTER PCL::PROCLAIM-DEFGENERIC WALKER::NOTE-LEXICAL-BINDING PCL::WRAPPER-OF-MACRO ITERATE::MAXIMIZING ITERATE::ELEMENTS PCL::EXPANDING-MAKE-INSTANCE PCL::INITIALIZE-INFO-COMBINED-INITARGS-FORM-LIST ITERATE::ITERATE PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION WALKER::WALK-REPEAT-EVAL PCL::%INSTANCE-REF PCL::INSTANCE-READ-INTERNAL PCL::DFUN-INFO-INDEX ITERATE::GATHERING PCL::NEQ PCL::FIND-SLOT-DEFINITION PCL::STD-INSTANCE-WRAPPER PCL::%ALLOCATE-STATIC-SLOT-STORAGE--CLASS PCL::MEC-ALL-CLASSES PCL::PVREF PCL::DESTRUCTURE-INTERNAL PCL::CALL-METHOD-LIST PCL::STANDARD-INSTANCE-ACCESS PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-MACRO PCL::WITH-EQ-HASH-TABLE PCL::LIST-EQ WALKER::VARIABLE-SPECIAL-P PCL::SLOT-SYMBOL PCL::EARLY-GF-METHODS COMMON-LISP::REMOVE-METHOD PCL::INITIALIZE-INFO-MAKE-INSTANCE-FUNCTION PCL::COPY-PV PCL::CALL-INITIALIZE-FUNCTION ITERATE::MV-SETQ PCL::DFUN-INFO-WRAPPER0 PCL::METHOD-FUNCTION-RETURNING-T PCL::EMIT-CHECKING-OR-CACHING-MACRO PCL::PRECOMPILE-FUNCTION-GENERATORS PCL::MAKE-PLIST PCL::COMPUTE-LAYOUT PCL::EXPANDING-MAKE-INSTANCE-TOP-LEVEL PCL::DOLIST-CAREFULLY PCL::ACCESSOR-SLOT-BOUNDP PCL::INITIALIZE-INFO-RI-VALID-P PCL::PV-BINDING1 PCL::CANONICALIZE-SLOT-SPECIFICATION PCL::REAL-ENSURE-GF-INTERNAL PCL::COPY-INSTANCE-INTERNAL PCL::REMTAIL ITERATE::PLIST-ELEMENTS PCL::INSTANCE-BOUNDP-INTERNAL PCL::COLLECTING-ONCE PCL::CACHE-VECTOR-REF PCL::INSTANCE-REF PCL::MAKE-CAXR PCL::ADD-FORMS PCL::CLASS-NO-OF-INSTANCE-SLOTS PCL::|SETF PCL FIND-CLASS-PREDICATE| PCL::DEAL-WITH-ARGUMENTS-OPTION PCL::TRACE-EMF-CALL PCL::COMPUTE-CALLS WALKER::ENVIRONMENT-MACRO PCL::FSC-INSTANCE-CLASS PCL::ADD-SLOT-ACCESSORS PCL::INSTANCE-WRITER PCL::SWAP-WRAPPERS-AND-SLOTS PCL::GATHERING1 PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::BIND-ARGS PCL::MAKE-CHECKING-OR-CACHING-FUNCTION-LIST PCL::UPDATE-INITS PCL::DFUN-UPDATE ITERATE::INTERVAL PCL::COPY-SLOTS COMMON-LISP::DEFGENERIC WALKER::GET-WALKER-TEMPLATE-INTERNAL PCL::CACHE-VECTOR-SIZE PCL::VARIABLE-CLASS PCL::NEXT-WRAPPER-CACHE-NUMBER-INDEX PCL::SAUT-NOT-EQL PCL::PV-WRAPPERS-FROM-ALL-ARGS ITERATE::SIMPLE-EXPAND-ITERATE-FORM PCL::PLIST-VALUE PCL::FUNCALLABLE-INSTANCE-MARKER PCL::INVOKE-EFFECTIVE-METHOD-FUNCTION PCL::MAKE-EARLY-ACCESSOR PCL::*LIST-ELEMENTS PCL::PROCLAIM-DEFMETHOD PCL::|SETF PCL GDEFINITION| PCL::INITIALIZE-INFO-NEW-KEYS COMMON-LISP::WITH-SLOTS PCL::ESETF PCL::CLASS-TEST PCL::METHODS-CONVERTER PCL::FAST-LEXICAL-METHOD-FUNCTIONS PCL::DEFINE-INLINES PCL::MLOOKUP PCL::CLASS-EQ-TEST PCL::ONCE-ONLY PCL::CLASS-CAN-PRECEDE-P WALKER::NOTE-DECLARATION PCL::WRAPPER-CACHE-NUMBER-VECTOR-REF PCL::BUILT-IN-OR-STRUCTURE-WRAPPER PCL::PRECOMPILE-RANDOM-CODE-SEGMENTS PCL::GET-KEY-ARG COMMON-LISP::DEFCLASS PCL::ORIGINAL-DEFINITION PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::NET-CONSTANT-CONVERTER PCL::RAISE-METATYPE PCL::METHOD-FUNCTION-CLOSURE-GENERATOR PCL::FIND-CLASS-CELL-MAKE-INSTANCE-FUNCTION-KEYS ITERATE::WHILE PCL::PV-ENV ITERATE::EXTRACT-SPECIAL-BINDINGS ITERATE::UNTIL PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRECOMPILED PCL::WRAPPER-CACHE-NUMBER-VECTOR PCL::GET-CACHE-VECTOR-LOCK-COUNT PCL::INITIALIZE-INFO-SHARED-INITIALIZE-T-FUNCTION PCL::BIND-FAST-LEXICAL-METHOD-MACROS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::GET-DFUN-CONSTRUCTOR PCL::ALLOCATE-STRUCTURE-INSTANCE PCL::COERCE-TO-CLASS WALKER::WALK-FORM PCL::GET-METHOD-FUNCTION COMMON-LISP::ENSURE-GENERIC-FUNCTION PCL::MAKE-SPECIALIZABLE PCL::PARSE-METHOD-OR-SPEC PCL::COMPILE-LAMBDA WALKER::MACROEXPAND-ALL PCL::ENSURE-CLASS PCL::EXTRACT-DECLARATIONS PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-CACHING-DFUN PCL::MAKE-INSTANCE-1 PCL::MAKE-FINAL-DFUN-INTERNAL PCL::GET-FUNCTION PCL::MAKE-METHOD-FUNCTION-INTERNAL PCL::MAKE-METHOD-LAMBDA-INTERNAL PCL::GET-FUNCTION1 PCL::PARSE-SPECIALIZED-LAMBDA-LIST PCL::DISPATCH-DFUN-COST PCL::MAP-ALL-CLASSES)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::BOOLEAN) PCL::CACHE-VALUEP)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) (COMMON-LISP::VALUES COMMON-LISP::T COMMON-LISP::T)) PCL::SYMBOL-APPEND)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::*) COMMON-LISP::T) PCL::MAKE-PV-TABLE PCL::|__si::MAKE-N-N| PCL::|__si::MAKE-ONE-CLASS| PCL::|__si::MAKE-ONE-INDEX| PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-CACHE| PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-ARG-INFO| PCL::ZERO PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CONSTANT-VALUE| WALKER::UNBOUND-LEXICAL-FUNCTION PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::FALSE PCL::|__si::MAKE-DISPATCH| PCL::CALLED-FIN-WITHOUT-FUNCTION PCL::|__si::MAKE-STD-INSTANCE| PCL::STRING-APPEND PCL::MAKE-METHOD-CALL PCL::|__si::MAKE-DFUN-INFO| PCL::|__si::MAKE-INITIAL| PCL::|__si::MAKE-PV-TABLE| PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| PCL::|__si::MAKE-NO-METHODS| PCL::USE-PACKAGE-PCL PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| PCL::|STRUCTURE-OBJECT class constructor| PCL::|__si::MAKE-INITIAL-DISPATCH| PCL::TRUE PCL::|__si::MAKE-DEFAULT-METHOD-ONLY| PCL::INTERN-PV-TABLE PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-TWO-CLASS|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::*) PCL::EMIT-ONE-INDEX-WRITERS PCL::ANALYZE-LAMBDA-LIST PCL::FIND-CYCLE-REASONS PCL::MAKE-TYPE-PREDICATE PCL::FINAL-ACCESSOR-DFUN-TYPE PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::COMPILE-LAMBDA-DEFERRED PCL::MAP-SPECIALIZERS PCL::PARSE-DEFMETHOD PCL::CONVERT-TO-SYSTEM-TYPE PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::GET-MAKE-INSTANCE-FUNCTION PCL::*NORMALIZE-TYPE PCL::EMIT-ONE-INDEX-READERS PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION PCL::STRUCTURE-WRAPPER PCL::NET-CODE-CONVERTER PCL::CLASS-EQ-TYPE PCL::FIND-STRUCTURE-CLASS PCL::EMIT-TWO-CLASS-WRITER PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA PCL::SPECIALIZER-FROM-TYPE PCL::UPDATE-GFS-OF-CLASS PCL::METHOD-PROTOTYPE-FOR-GF PCL::EMIT-CONSTANT-VALUE PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-ONE-CLASS-READER PCL::MAKE-INITIAL-DFUN PCL::COMPUTE-APPLICABLE-METHODS-EMF PCL::COMPILE-LAMBDA-UNCOMPILED PCL::GET-GENERIC-FUNCTION-INFO PCL::FIND-WRAPPER PCL::GET-DISPATCH-FUNCTION PCL::EARLY-METHOD-FUNCTION PCL::MAKE-DISPATCH-DFUN PCL::TYPE-FROM-SPECIALIZER PCL::PCL-DESCRIBE PCL::EMIT-TWO-CLASS-READER PCL::MAKE-FINAL-DISPATCH-DFUN PCL::EARLY-COLLECT-INHERITANCE PCL::EMIT-IN-CHECKING-CACHE-P PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION PCL::GENERIC-FUNCTION-NAME-P PCL::COMPILE-IIS-FUNCTIONS PCL::PARSE-METHOD-GROUP-SPECIFIER PCL::DEFAULT-CODE-CONVERTER)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) PCL::FIND-FREE-CACHE-LINE)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::COMPUTE-CACHE-PARAMETERS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::LIST) PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST PCL::CACHE-OVERFLOW)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) PCL::ENSURE-CLASS-VALUES PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR PCL::REAL-REMOVE-METHOD COMMON-LISP::SLOT-VALUE PCL::SAUT-AND PCL::COMPUTE-STD-CPL-PHASE-1 PCL::INSURE-DFUN PCL::CHECK-INITARGS-VALUES PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF PCL::MAKE-STD-READER-METHOD-FUNCTION PCL::*SUBTYPEP PCL::MAKE-STD-WRITER-METHOD-FUNCTION COMMON-LISP::SLOT-BOUNDP PCL::MAKE-INSTANCE-FUNCTION-TRAP PCL::CLASS-APPLICABLE-USING-CLASS-P PCL::COMPUTE-TEST PCL::COMPUTE-CODE PCL::UPDATE-SLOT-VALUE-GF-INFO ITERATE::PARSE-DECLARATIONS COMMON-LISP::SLOT-MAKUNBOUND PCL::SAUT-PROTOTYPE PCL::COMPUTE-CONSTANTS PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION PCL::ACCESSOR-MISS-FUNCTION PCL::SAUT-CLASS-EQ PCL::SET-FUNCTION-NAME PCL::SAUT-CLASS PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SAUT-EQL PCL::FORM-LIST-TO-LISP PCL::INITIAL-DFUN PCL::GF-MAKE-FUNCTION-FROM-EMF PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL PCL::SAUT-NOT PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::CPL-INCONSISTENT-ERROR PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::DESTRUCTURE PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION PCL::MAKE-DIRECT-SLOTD PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES PCL::MAKE-UNORDERED-METHODS-EMF PCL::EMIT-CACHING PCL::EMIT-CHECKING PCL::FIND-SUPERCLASS-CHAIN PCL::EMIT-DEFAULT-ONLY PCL::SPLIT-DECLARATIONS PCL::SLOT-UNBOUND-INTERNAL PCL::SDFUN-FOR-CACHING)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::MAKE-FINAL-DFUN COMMON-LISP::FIND-CLASS WALKER::RELIST PCL::EARLY-METHOD-SPECIALIZERS PCL::UPDATE-DFUN PCL::FIND-CLASS-CELL PCL::MAKE-WRAPPER ITERATE::MAYBE-WARN WALKER::RELIST* PCL::USE-DISPATCH-DFUN-P PCL::TRACE-METHOD PCL::INITIALIZE-METHOD-FUNCTION PCL::INITIALIZE-INTERNAL-SLOT-GFS PCL::CAPITALIZE-WORDS PCL::SET-DFUN PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-CONSTANT-VALUE-DFUN-P PCL::ALLOCATE-STANDARD-INSTANCE ITERATE::FUNCTION-LAMBDA-P PCL::MAKE-EARLY-GF PCL::FIND-CLASS-PREDICATE WALKER::WALKER-ENVIRONMENT-BIND-1 PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO PCL::MAKE-TYPE-PREDICATE-NAME)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| PCL::|(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| PCL::|(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| PCL::INITIALIZE-INSTANCE-SIMPLE PCL::|(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| PCL::MAYBE-EXPAND-ACCESSOR-FORM WALKER::WALK-LET/LET* PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| PCL::|(FAST-METHOD MAKE-INSTANCE (CLASS))| PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| PCL::|(FAST-METHOD PRINT-OBJECT (T T))| PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| PCL::TWO-CLASS-DFUN-INFO PCL::|(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| PCL::|(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| WALKER::WALK-BINDINGS-2 PCL::|(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1 PCL::|(FAST-METHOD DOCUMENTATION (T))| PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| PCL::|(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| PCL::|(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| PCL::OPTIMIZE-READER PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| PCL::|(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| PCL::OPTIMIZE-WRITER PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| PCL::|(FAST-METHOD PRINT-OBJECT (CLASS T))| PCL::MAKE-DISPATCH-LAMBDA PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| PCL::|(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| PCL::|(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| PCL::MEMF-TEST-CONVERTER PCL::|(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| PCL::|(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| PCL::|(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| PCL::|(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| PCL::|(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| PCL::|(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| PCL::|(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| PCL::EXPAND-DEFCLASS PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| PCL::BOOTSTRAP-SET-SLOT PCL::|(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR PCL::FILL-CACHE-P PCL::GET-WRAPPERS-FROM-CLASSES PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| PCL::|(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| PCL::|(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| PCL::EXPAND-SYMBOL-MACROLET-INTERNAL PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| PCL::|(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| PCL::|(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| WALKER::WALK-PROG/PROG* PCL::|(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| PCL::|(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| PCL::|(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| PCL::|(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| WALKER::WALK-DO/DO* PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| PCL::|(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| PCL::|(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| WALKER::WALK-TEMPLATE PCL::ADJUST-CACHE PCL::LOAD-PRECOMPILED-IIS-ENTRY)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST PCL::EMIT-FETCH-WRAPPER PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::CAN-OPTIMIZE-ACCESS1 PCL::FILL-CACHE PCL::GET-METHOD PCL::MAKE-EMF-CALL PCL::CHECK-INITARGS-2-PLIST)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::REAL-ADD-NAMED-METHOD PCL::FILL-DFUN-CACHE PCL::EARLY-ADD-NAMED-METHOD)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::|(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| WALKER::WALK-NAMED-LAMBDA WALKER::WALK-MACROLET PCL::|(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| PCL::GET-FUNCTION-GENERATOR PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| PCL::ENTRY-IN-CACHE-P PCL::COMPUTE-PRECEDENCE PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| PCL::|(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| PCL::TRACE-EMF-CALL-INTERNAL ITERATE::SIMPLE-EXPAND-GATHERING-FORM PCL::NOTE-PV-TABLE-REFERENCE PCL::|(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| PCL::OPTIMIZE-GF-CALL-INTERNAL PCL::|(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| WALKER::WALK-COMPILER-LET ITERATE::VARIABLE-SAME-P PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| PCL::SET-FUNCTION-NAME-1 PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| PCL::|(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| PCL::MAKE-METHOD-SPEC PCL::|(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| PCL::MAP-ALL-ORDERS PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| PCL::EMIT-SLOT-READ-FORM WALKER::WALK-LABELS PCL::EMIT-BOUNDP-CHECK PCL::ONE-CLASS-DFUN-INFO WALKER::WALK-DO PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL PCL::|(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| WALKER::WALK-PROG PCL::MAKE-TOP-LEVEL-FORM PCL::COMPUTE-EFFECTIVE-METHOD PCL::|(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| WALKER::WALK-IF PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| PCL::MAKE-DFUN-CALL PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| PCL::|(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| WALKER::WALK-MULTIPLE-VALUE-SETQ WALKER::WALK-LAMBDA PCL::OPTIMIZE-SET-SLOT-VALUE PCL::|(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| PCL::EMIT-GREATER-THAN-1-DLAP WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET WALKER::WALK-MULTIPLE-VALUE-BIND PCL::EMIT-1-T-DLAP PCL::SKIP-FAST-SLOT-ACCESS-P PCL::CAN-OPTIMIZE-ACCESS PCL::|(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| PCL::INITIALIZE-INTERNAL-SLOT-GFS* PCL::|SETF PCL METHOD-FUNCTION-GET| WALKER::WALK-SETQ PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| PCL::|(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P WALKER::WALK-PROG* PCL::FIRST-FORM-TO-LISP PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| PCL::PRINT-STD-INSTANCE PCL::|(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| WALKER::WALK-LET* PCL::|(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| PCL::OPTIMIZE-SLOT-VALUE PCL::FLUSH-CACHE-TRAP WALKER::WALK-DO* PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| PCL::|(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| PCL::|SETF PCL PLIST-VALUE| PCL::GET-NEW-FUNCTION-GENERATOR PCL::|(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| PCL::|(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| ITERATE::RENAME-AND-CAPTURE-VARIABLES PCL::EXPAND-DEFGENERIC PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| WALKER::WALK-SYMBOL-MACROLET PCL::|(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| WALKER::WALK-TAGBODY-1 PCL::|(FAST-METHOD SPECIALIZER-CLASS (CLASS))| WALKER::WALK-LOCALLY PCL::INVALIDATE-WRAPPER ITERATE::OPTIMIZE-ITERATE-FORM PCL::|(FAST-METHOD CLASS-PREDICATE-NAME (T))| WALKER::WALK-LET WALKER::RECONS PCL::OBSOLETE-INSTANCE-TRAP WALKER::VARIABLE-DECLARATION WALKER::WALK-TAGBODY PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::DECLARE-STRUCTURE PCL::SORT-APPLICABLE-METHODS PCL::OPTIMIZE-SLOT-BOUNDP PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| ITERATE::OPTIMIZE-GATHERING-FORM PCL::CONVERT-TABLE PCL::|(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| PCL::SORT-METHODS PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD WALKER::RELIST-INTERNAL PCL::PRINT-CACHE PCL::ONE-INDEX-DFUN-INFO)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::REAL-MAKE-METHOD-INITARGS-FORM PCL::COMPUTE-PV-SLOT PCL::|(FAST-METHOD SLOT-UNBOUND (T T T))| PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| PCL::OPTIMIZE-ACCESSOR-CALL PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL WALKER::WALK-TEMPLATE-HANDLE-REPEAT PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| PCL::MAKE-EMF-CACHE PCL::|(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| PCL::|(FAST-METHOD REMOVE-NAMED-METHOD (T T))| WALKER::WALK-BINDINGS-1 PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| PCL::UPDATE-SLOTS-IN-PV PCL::|(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| PCL::MAKE-PARAMETER-REFERENCES PCL::LOAD-FUNCTION-GENERATOR PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| PCL::|(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| PCL::|(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::EXPAND-EMF-CALL-METHOD PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1 PCL::OPTIMIZE-GENERIC-FUNCTION-CALL PCL::MAKE-FGEN PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| PCL::OPTIMIZE-INSTANCE-ACCESS PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T T))| PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::OPTIMIZE-GF-CALL PCL::MAKE-EARLY-CLASS-DEFINITION PCL::REAL-LOAD-DEFCLASS PCL::EMIT-SLOT-ACCESS PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::GET-METHOD-FUNCTION-PV-CELL PCL::RECORD-DEFINITION PCL::PROBE-CACHE PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::EMIT-MISS PCL::INITIALIZE-INFO PCL::MAKE-EMF-FROM-METHOD PCL::PRECOMPUTE-EFFECTIVE-METHODS PCL::REAL-ENSURE-GF-USING-CLASS--NULL PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::NAMED-OBJECT-PRINT-FUNCTION WALKER::CONVERT-MACRO-TO-LAMBDA PCL::METHOD-FUNCTION-GET PCL::GET-DECLARATION PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1 PCL::MAP-CACHE PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION PCL::FIND-CLASS-FROM-CELL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::MAKE-DEFMETHOD-FORM-INTERNAL PCL::MAKE-DEFMETHOD-FORM PCL::LOAD-DEFMETHOD PCL::EARLY-MAKE-A-METHOD)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::EXPAND-DEFMETHOD PCL::LOAD-DEFMETHOD-INTERNAL)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T (COMMON-LISP::INTEGER -9223372036854775808 9223372036854775807)) COMMON-LISP::T) PCL::COMPUTE-STD-CPL-PHASE-3)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::FIXNUM) COMMON-LISP::T) PCL::GET-CACHE PCL::FILL-CACHE-FROM-CACHE-P)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::BOOTSTRAP-INITIALIZE-CLASS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::T) PCL::EMIT-DLAP)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::STREAM COMMON-LISP::T) COMMON-LISP::T) PCL::PRINT-DFUN-INFO)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::FIXNUM) PCL::CACHE-COUNT PCL::ARG-INFO-NUMBER-REQUIRED PCL::PV-TABLE-PV-SIZE PCL::FAST-INSTANCE-BOUNDP-INDEX PCL::CACHING-LIMIT-FN PCL::DEFAULT-LIMIT-FN PCL::CHECKING-LIMIT-FN PCL::EARLY-CLASS-SIZE PCL::ONE-INDEX-LIMIT-FN PCL::PV-CACHE-LIMIT-FN PCL::CPD-COUNT PCL::N-N-ACCESSORS-LIMIT-FN)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM) COMMON-LISP::T) PCL::POWER-OF-TWO-CEILING)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION COMMON-LISP::NIL COMMON-LISP::*) PCL::COUNT-ALL-DFUNS PCL::EMIT-N-N-WRITERS PCL::EMIT-N-N-READERS)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::SIMPLE-VECTOR) PCL::CACHE-VECTOR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::FIXNUM COMMON-LISP::T) COMMON-LISP::T) PCL::%CCLOSURE-ENV-NTHCDR)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) (COMMON-LISP::OR PCL::CACHE COMMON-LISP::NULL)) PCL::PV-TABLE-CACHE)) (IN-PACKAGE "PCL") (DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| ADD-READER-METHOD SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT REMOVE-READER-METHOD EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL |PCL::STANDARD-SLOT-DEFINITION class predicate| |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate| |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::STANDARD-METHOD-COMBINATION class predicate| |(FAST-READER-METHOD SLOT-OBJECT METHOD)| SPECIALIZER-TYPE GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| CLASS-DEFSTRUCT-CONSTRUCTOR |(FAST-READER-METHOD SLOT-OBJECT SOURCE)| |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)| METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)| |(SETF GF-PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| SPECIALIZERP EXACT-CLASS-SPECIALIZER-P |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)| |(FAST-READER-METHOD PCL-CLASS WRAPPER)| |(FAST-READER-METHOD SLOT-OBJECT INITARGS)| |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| COMPATIBLE-META-CLASS-CHANGE-P |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)| |(BOUNDP READER-FUNCTION)| TRACE-METHOD-INTERNAL |(BOUNDP PREDICATE-NAME)| |(BOUNDP READERS)| UPDATE-GF-DFUN |(BOUNDP CLASS-PRECEDENCE-LIST)| |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP LOCATION)| |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)| |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| REDEFINE-FUNCTION SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)| |PCL::PCL-CLASS class predicate| |PCL::STD-CLASS class predicate| |(BOUNDP DEFSTRUCT-FORM)| |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| CLASS-EQ-SPECIALIZER-P |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD |(BOUNDP WRITER-FUNCTION)| |(BOUNDP INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)| STRUCTURE-CLASS-P |(BOUNDP WRITERS)| |(BOUNDP INITFORM)| |SETF COMMON-LISP CLASS-NAME| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)| |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| DOCUMENTATION |(BOUNDP FUNCTION)| |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP LAMBDA-LIST)| METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)| |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS |PCL::DEFINITION-SOURCE-MIXIN class predicate| |(BOUNDP DFUN-STATE)| |(BOUNDP FROM-DEFCLASS-P)| |(READER METHOD)| |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)| |(BOUNDP FAST-FUNCTION)| |(BOUNDP METHOD-CLASS)| |(READER SOURCE)| |(BOUNDP INTERNAL-WRITER-FUNCTION)| |(BOUNDP INTERNAL-READER-FUNCTION)| |(BOUNDP METHOD-COMBINATION)| ACCESSOR-METHOD-CLASS |(BOUNDP DIRECT-SLOTS)| |(BOUNDP DIRECT-METHODS)| |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUBCLASSES)| |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP METHODS)| |(BOUNDP OPTIONS)| |(WRITER METHOD)| |PCL::DEPENDENT-UPDATE-MIXIN class predicate| GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| MAKE-BOUNDP-METHOD-FUNCTION |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |PCL::METAOBJECT class predicate| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| CLASS-PREDICATE-NAME |PCL::STRUCTURE-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::EFFECTIVE-SLOT-DEFINITION class predicate| |(COMBINED-METHOD SHARED-INITIALIZE)| LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P |SETF PCL GENERIC-FUNCTION-NAME| |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| |(READER READERS)| |(READER CLASS-PRECEDENCE-LIST)| |(READER ACCESSOR-FLAGS)| |(READER LOCATION)| |(READER DOCUMENTATION)| CLASS-INITIALIZE-INFO |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION |SETF PCL GF-DFUN-STATE| |(READER INCOMPATIBLE-SUPERCLASS-LIST)| |(READER SPECIALIZERS)| |(READER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF CLASS-INITIALIZE-INFO)| |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)| |SETF PCL SLOT-DEFINITION-NAME| |(WRITER READER-FUNCTION)| |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)| |(WRITER PREDICATE-NAME)| |(WRITER READERS)| |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)| INITIALIZE-INTERNAL-SLOT-FUNCTIONS |SETF PCL SLOT-DEFINITION-TYPE| |(READER WRITERS)| |(WRITER CLASS-PRECEDENCE-LIST)| |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| METHOD-COMBINATION-P |(WRITER LOCATION)| |(WRITER DOCUMENTATION)| |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)| |SETF PCL GENERIC-FUNCTION-METHODS| |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| |SETF PCL METHOD-GENERIC-FUNCTION| |(READER SLOT-NAME)| |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL SLOT-ACCESSOR-STD-P| |(CALL REAL-MAKE-METHOD-INITARGS-FORM)| |(READER ALLOCATION)| |(WRITER SPECIALIZERS)| |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)| |(WRITER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF METHOD-GENERIC-FUNCTION)| |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P |SETF PCL OBJECT-PLIST| |(WRITER DEFSTRUCT-FORM)| |(READER FUNCTION)| |(READER GENERIC-FUNCTION)| |(READER LAMBDA-LIST)| |(READER SLOT-DEFINITION)| |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate| |SETF PCL SLOT-DEFINITION-INITFORM| |SETF PCL CLASS-DEFSTRUCT-FORM| |(READER CAN-PRECEDE-LIST)| |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)| |(WRITER INITFUNCTION)| |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P |(WRITER INITFORM)| |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST| |SETF PCL SLOT-ACCESSOR-FUNCTION| |SETF PCL SLOT-DEFINITION-LOCATION| |SETF PCL SLOT-DEFINITION-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-ALLOCATION| |SETF PCL SLOT-DEFINITION-INITFUNCTION| |(WRITER SLOT-NAME)| |(BOUNDP NAME)| |(READER FAST-FUNCTION)| |(WRITER ALLOCATION)| |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| |(READER INTERNAL-WRITER-FUNCTION)| |(READER INTERNAL-READER-FUNCTION)| |(READER METHOD-COMBINATION)| METHOD-COMBINATION-OPTIONS |(READER DIRECT-SLOTS)| |(READER DIRECT-METHODS)| |SETF PCL SLOT-DEFINITION-READERS| |(WRITER FUNCTION)| |(WRITER GENERIC-FUNCTION)| |(READER BOUNDP-FUNCTION)| |SETF PCL DOCUMENTATION| |(READER DIRECT-SUBCLASSES)| |(READER DIRECT-SUPERCLASSES)| |(WRITER LAMBDA-LIST)| FUNCALLABLE-STANDARD-CLASS-P |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)| |(BOUNDP CLASS)| |(WRITER SLOT-DEFINITION)| |(READER METHODS)| |(READER OPTIONS)| |(WRITER CAN-PRECEDE-LIST)| |SETF PCL SLOT-DEFINITION-CLASS| |SETF PCL SLOT-VALUE-USING-CLASS| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(WRITER PROTOTYPE)| |(BOUNDP TYPE)| |(BOUNDP OBJECT)| CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-DIRECT-SLOTS| |SETF PCL CLASS-SLOTS| SLOT-ACCESSOR-FUNCTION |(BOUNDP PLIST)| |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| |SETF PCL SLOT-DEFINITION-WRITERS| |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)| |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| |(BOUNDP SLOTS)| SLOT-CLASS-P MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)| |PCL::PLIST-MIXIN class predicate| |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)| GET-METHOD |(WRITER INTERNAL-WRITER-FUNCTION)| |(WRITER INTERNAL-READER-FUNCTION)| |(WRITER METHOD-COMBINATION)| |(WRITER DIRECT-SLOTS)| |(WRITER DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUBCLASSES)| |(WRITER DIRECT-SUPERCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(WRITER METHODS)| |(WRITER OPTIONS)| SHORT-METHOD-COMBINATION-P GF-ARG-INFO SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM CLASS-DEFSTRUCT-FORM |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-READER-METHOD CLASS PREDICATE-NAME)| |(FAST-READER-METHOD CLASS NAME)| |(FAST-READER-METHOD SLOT-DEFINITION NAME)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)| |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-READER-METHOD SLOT-OBJECT NAME)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)| GF-PRETTY-ARGLIST SAME-SPECIALIZER-P SLOT-DEFINITION-BOUNDP-FUNCTION SLOT-DEFINITION-WRITER-FUNCTION SLOT-DEFINITION-READER-FUNCTION SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION SLOT-DEFINITION-INTERNAL-READER-FUNCTION |(FAST-READER-METHOD SLOT-OBJECT CLASS)| |(FAST-READER-METHOD SLOT-DEFINITION CLASS)| |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD TRACED-METHOD FUNCTION)| |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT LOCATION)| |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)| |(FAST-READER-METHOD SLOT-OBJECT WRITERS)| |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-READER-METHOD SLOT-OBJECT READERS)| |(FAST-READER-METHOD SLOT-DEFINITION READERS)| |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)| |(FAST-READER-METHOD SPECIALIZER TYPE)| |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)| |(FAST-READER-METHOD SLOT-DEFINITION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT TYPE)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)| |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT OBJECT)| |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-READER-METHOD SLOT-OBJECT INITFORM)| |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-READER-METHOD SLOT-OBJECT PLIST)| |(FAST-READER-METHOD PLIST-MIXIN PLIST)| |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)| |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-READER-METHOD SLOT-OBJECT SLOTS)| |(FAST-READER-METHOD SLOT-CLASS SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT METHODS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)| |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)| SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT |PCL::DIRECT-SLOT-DEFINITION class predicate| CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)| |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-DIRECT-GENERIC-FUNCTIONS |(BOUNDP CLASS-EQ-SPECIALIZER)| |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)| |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)| |(SETF SLOT-VALUE-USING-CLASS)| |(SETF SLOT-DEFINITION-CLASS)| |(SETF SLOT-ACCESSOR-FUNCTION)| |(SETF SLOT-DEFINITION-INITFUNCTION)| |(SETF SLOT-DEFINITION-ALLOCATION)| |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-READER-FUNCTION)| |(SETF SLOT-DEFINITION-LOCATION)| |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(SETF SLOT-DEFINITION-WRITERS)| |(SETF SLOT-DEFINITION-READERS)| |(SETF SLOT-DEFINITION-TYPE)| |(SETF SLOT-DEFINITION-INITFORM)| |(BOUNDP INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION GENERIC-FUNCTION-P |PCL::SLOT-DEFINITION class predicate| |(READER NAME)| |(READER CLASS)| |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| |(FAST-METHOD SLOT-MISSING (T T T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD PRINT-OBJECT (T T))| LEGAL-SLOT-NAME-P |(READER TYPE)| |(READER OBJECT)| CLASS-WRAPPER |(READER PLIST)| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER TYPE)| |(WRITER OBJECT)| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| |(WRITER PLIST)| |(WRITER SLOTS)| |PCL::DOCUMENTATION-MIXIN class predicate| FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P LEGAL-QUALIFIER-P METHOD-P |PCL::SPECIALIZER-WITH-OBJECT class predicate| CLASS-SLOT-CELLS |(COMBINED-METHOD INITIALIZE-INSTANCE)| |(COMBINED-METHOD REINITIALIZE-INSTANCE)| STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| STANDARD-GENERIC-FUNCTION-P STANDARD-READER-METHOD-P STANDARD-METHOD-P |(READER WRAPPER)| |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| |(READER CLASS-EQ-SPECIALIZER)| COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS COMPUTE-DEFAULT-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)| |(CALL REAL-MAKE-METHOD-LAMBDA)| |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| |COMMON-LISP::NULL class predicate| |COMMON-LISP::SYMBOL class predicate| |COMMON-LISP::CHARACTER class predicate| |COMMON-LISP::BIT-VECTOR class predicate| |COMMON-LISP::STRING class predicate| |COMMON-LISP::VECTOR class predicate| |COMMON-LISP::ARRAY class predicate| |COMMON-LISP::CONS class predicate| |COMMON-LISP::LIST class predicate| |COMMON-LISP::SEQUENCE class predicate| |COMMON-LISP::RATIO class predicate| |COMMON-LISP::INTEGER class predicate| |COMMON-LISP::RATIONAL class predicate| |COMMON-LISP::FLOAT class predicate| |COMMON-LISP::COMPLEX class predicate| |COMMON-LISP::NUMBER class predicate| |COMMON-LISP::T class predicate| |COMMON-LISP::STRUCTURE-OBJECT class predicate| |COMMON-LISP::STANDARD-OBJECT class predicate| |COMMON-LISP::BUILT-IN-CLASS class predicate| |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-SLOTS)| |(SETF CLASS-DIRECT-SLOTS)| DO-STANDARD-DEFSETF-1 |(READER OPERATOR)| |(CALL REAL-GET-METHOD)| |(CALL REAL-REMOVE-METHOD)| |(CALL REAL-ADD-METHOD)| |(READER ARG-INFO)| METHOD-COMBINATION-TYPE |(READER DEFSTRUCT-CONSTRUCTOR)| |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)| STANDARD-CLASS-P LEGAL-SPECIALIZER-P |PCL::LONG-METHOD-COMBINATION class predicate| |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)| |(WRITER CLASS-EQ-SPECIALIZER)| STANDARD-BOUNDP-METHOD-P FDEFINE-CAREFULLY |(SETF DOCUMENTATION)| RAW-INSTANCE-ALLOCATOR |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| |SETF PCL CLASS-INITIALIZE-INFO| |(WRITER OPERATOR)| |(WRITER ARG-INFO)| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO STANDARD-WRITER-METHOD-P CLASS-INCOMPATIBLE-SUPERCLASS-LIST |(WRITER DEFSTRUCT-CONSTRUCTOR)| |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER MAKE-A-METHOD |(WRITER INITIALIZE-INFO)| METHOD-COMBINATION-DOCUMENTATION |SETF PCL SLOT-DEFINITION-INITARGS| REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| |(WRITER INITARGS)| |(BOUNDP METHOD)| |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-WRITER-METHOD CLASS NAME)| |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-WRITER-METHOD SLOT-OBJECT NAME)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)| |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)| SHORT-COMBINATION-OPERATOR |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)| |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)| |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-WRITER-METHOD SLOT-OBJECT READERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)| |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)| REMOVE-NAMED-METHOD |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)| |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE CLASSP READER-METHOD-CLASS REMOVE-METHOD SLOT-DEFINITION-INITFORM UPDATE-INSTANCE-FOR-REDEFINED-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P GENERIC-FUNCTION-NAME REMOVE-DEPENDENT COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION SHARED-INITIALIZE ADD-DIRECT-METHOD SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-ALLOCATION ADD-METHOD GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE SLOT-MAKUNBOUND-USING-CLASS ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD SLOT-DEFINITION-WRITERS COMPUTE-APPLICABLE-METHODS-USING-CLASSES CLASS-PRECEDENCE-LIST DISASSEMBLE DESCRIBE-OBJECT COMPILE)) (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl-2.6.14/pcl/gcl_pcl_compat.lisp0000644000175000017500000000220314360276512015405 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) () gcl-2.6.14/pcl/package.lisp0000644000175000017500000000116614360276512014041 0ustar cammcamm(in-package :user) (eval-when (compile load eval) (if (find-package :walker) (use-package '(:lisp) :walker) (make-package :walker :use '(:lisp))) (if (find-package :iterate) (use-package '(:lisp :walker) :iterate) (make-package :iterate :use '(:lisp :walker))) (if (find-package :pcl) (use-package '(:walker :iterate :lisp) :pcl) (make-package :pcl :use '(:walker :iterate :lisp)))) (in-package :pcl) (defvar *the-pcl-package* (find-package :pcl)) (defun load-truename (&optional errorp) *load-pathname*) (import 'si::(clines defentry defcfun object void int double)) (import 'si::compiler-let :walker) gcl-2.6.14/pcl/gcl_pcl_vector.lisp0000644000175000017500000011701414360276512015433 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Permutation vectors. ;;; (in-package :pcl) (defmacro instance-slot-index (wrapper slot-name) `(let ((pos 0)) (declare (fixnum pos)) (block loop (dolist (sn (wrapper-instance-slots-layout ,wrapper)) (when (eq ,slot-name sn) (return-from loop pos)) (incf pos))))) ;;; ;;; ;;; (defun pv-cache-limit-fn (nlines) (default-limit-fn nlines)) (defstruct (pv-table (:predicate pv-tablep) (:constructor make-pv-table-internal (slot-name-lists call-list))) (cache nil :type (or cache null)) (pv-size 0 :type fixnum) (slot-name-lists nil :type list) (call-list nil :type list)) #+cmu (declaim (ext:freeze-type pv-table)) (defvar *initial-pv-table* (make-pv-table-internal nil nil)) ; help new slot-value-using-class methods affect fast iv access (defvar *all-pv-table-list* nil) (defun make-pv-table (&key slot-name-lists call-list) (let ((pv-table (make-pv-table-internal slot-name-lists call-list))) (push pv-table *all-pv-table-list*) pv-table)) (defun make-pv-table-type-declaration (var) `(type pv-table ,var)) (defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) (defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) ;entries in this are lists of (table . pv-offset-list) (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) (defun intern-pv-table (&key slot-name-lists call-list) (let ((new-p nil)) (flet ((inner (x) (or (gethash x *slot-name-lists-inner*) (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) (outer (x) (or (gethash x *slot-name-lists-outer*) (setf (gethash x *slot-name-lists-outer*) (let ((snl (copy-list (cdr x))) (cl (car x))) (setq new-p t) (make-pv-table :slot-name-lists snl :call-list cl)))))) (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) (when new-p (let ((pv-index 1)) (declare (fixnum pv-index)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (note-pv-table-reference slot-name pv-index pv-table) (incf pv-index))) (dolist (gf-call call-list) (note-pv-table-reference gf-call pv-index pv-table) (incf pv-index)) (setf (pv-table-pv-size pv-table) pv-index))) pv-table)))) (defun note-pv-table-reference (ref pv-offset pv-table) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (when (listp entry) (let ((table-entry (assq pv-table entry))) (when (and (null table-entry) (> (length entry) 8)) (let ((new-table-table (make-hash-table :size 16 :test 'eq))) (dolist (table-entry entry) (setf (gethash (car table-entry) new-table-table) (cdr table-entry))) (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) (when (listp entry) (if (null table-entry) (let ((new (cons pv-table pv-offset))) (if (consp entry) (push new (cdr entry)) (setf (gethash ref *pv-key-to-pv-table-table*) (list new)))) (push pv-offset (cdr table-entry))) (return-from note-pv-table-reference nil)))) (let ((list (gethash pv-table entry))) (if (consp list) (push pv-offset (cdr list)) (setf (gethash pv-table entry) (list pv-offset))))) nil) (defun map-pv-table-references-of (ref function) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (if (listp entry) (dolist (table+pv-offset-list entry) (funcall function (car table+pv-offset-list) (cdr table+pv-offset-list))) (maphash function entry))) ref) (defvar *pvs* (make-hash-table :test #'equal)) (defun optimize-slot-value-by-class-p (class slot-name type) (or (not (eq *boot-state* 'complete)) (let ((slotd (find-slot-definition class slot-name))) (and slotd (slot-accessor-std-p slotd type))))) (defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) (if (symbolp slot-name) (when (optimize-slot-value-by-class-p class slot-name 'all) (or (instance-slot-index wrapper slot-name) (let ((cell (assq slot-name class-slots))) (when cell (setf (car class-slot-p-cell) t) cell)))) (when (consp slot-name) (dolist (type '(reader writer) nil) (when (eq (car slot-name) type) (return (let* ((gf-name (cadr slot-name)) (gf (gdefinition gf-name)) (location (when (eq *boot-state* 'complete) (accessor-values1 gf type class)))) (when (consp location) (setf (car class-slot-p-cell) t)) location))))))) (defun compute-pv (slot-name-lists wrappers) (unless (listp wrappers) (setq wrappers (list wrappers))) (let* ((not-simple-p-cell (list nil)) (elements (gathering1 (collecting) (iterate ((slot-names (list-elements slot-name-lists))) (when slot-names (let* ((wrapper (pop wrappers)) (std-p #+cmu17 (typep wrapper 'wrapper) #-cmu17 t) (class (wrapper-class* wrapper)) (class-slots (and std-p (wrapper-class-slots wrapper)))) (dolist (slot-name (cdr slot-names)) (gather1 (when std-p (compute-pv-slot slot-name wrapper class class-slots not-simple-p-cell)))))))))) (if (car not-simple-p-cell) (make-permutation-vector (cons t elements)) (or (gethash elements *pvs*) (setf (gethash elements *pvs*) (make-permutation-vector (cons nil elements))))))) (defun compute-calls (call-list wrappers) (declare (ignore call-list wrappers)) #|| (map 'vector #'(lambda (call) (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) #|| ; Need to finish this, then write the maintenance functions. (defun compute-emf-from-wrappers (call wrappers) (when call ; FIXME use regular destructuring-bind (pcl-destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) (error "should not get here") ; there is another mechanism for this. #'(lambda (&rest args) (if (not (eq *boot-state* 'complete)) (apply (gdefinition gf-name) args) (let* ((gf (gdefinition gf-name)) (arg-info (arg-info-reader gf)) (classes '?) (types '?) (emf (cache-miss-values-internal gf arg-info wrappers classes types 'caching))) (update-all-pv-tables call wrappers emf) #+copy-&rest-arg (setq args (copy-list args)) (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) (make-array (length indexes) :initial-contents indexes)) (defun pv-table-lookup (pv-table pv-wrappers) (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) (call-list (pv-table-call-list pv-table)) (cache (or (pv-table-cache pv-table) (setf (pv-table-cache pv-table) (get-cache (- (length slot-name-lists) (count nil slot-name-lists)) t #'pv-cache-limit-fn 2))))) (or (probe-cache cache pv-wrappers) (let* ((pv (compute-pv slot-name-lists pv-wrappers)) (calls (compute-calls call-list pv-wrappers)) (pv-cell (cons pv calls)) (new-cache (fill-cache cache pv-wrappers pv-cell))) (unless (eq new-cache cache) (setf (pv-table-cache pv-table) new-cache) (free-cache cache)) pv-cell)))) (defun make-pv-type-declaration (var) `(type simple-vector ,var)) (defvar *empty-pv* #()) (defmacro pvref (pv index) `(svref ,pv ,index)) (defmacro copy-pv (pv) `(copy-seq ,pv)) (defun make-calls-type-declaration (var) `(type simple-vector ,var)) (defmacro callsref (calls index) `(svref ,calls ,index)) (defvar *pv-table-cache-update-info* nil) ;called by: ;(method shared-initialize :after (structure-class t)) ;update-slots (defun update-pv-table-cache-info (class) (let ((slot-names-for-pv-table-update nil) (new-icui nil)) (dolist (icu *pv-table-cache-update-info*) (if (eq (car icu) class) (pushnew (cdr icu) slot-names-for-pv-table-update) (push icu new-icui))) (setq *pv-table-cache-update-info* new-icui) (when slot-names-for-pv-table-update (update-all-pv-table-caches class slot-names-for-pv-table-update)))) (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) (std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) (new-values (mapcar #'(lambda (slot-name) (cons slot-name (when std-p (compute-pv-slot slot-name cwrapper class class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name #'(lambda (pv-table pv-offset-list) (declare (ignore pv-offset-list)) (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) (pv-size (pv-table-pv-size pv-table)) (pv-map (make-array pv-size :initial-element nil))) (let ((map-index 1)(param-index 0)) (declare (fixnum map-index param-index)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (let ((a (assoc slot-name new-values))) (setf (svref pv-map map-index) (and a (cons param-index (cdr a))))) (incf map-index)) (incf param-index))) (when cache (map-cache #'(lambda (wrappers pv-cell) (setf (car pv-cell) (update-slots-in-pv wrappers (car pv-cell) cwrapper pv-size pv-map))) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) (if (not (if (atom wrappers) (eq cwrapper wrappers) (dolist (wrapper wrappers nil) (when (eq wrapper cwrapper) (return t))))) pv (let* ((old-intern-p (listp (pvref pv 0))) (new-pv (if old-intern-p (copy-pv pv) pv)) (new-intern-p t)) (if (atom wrappers) (dotimes (i pv-size) (when (consp (let ((map (svref pv-map i))) (if map (setf (pvref new-pv i) (cdr map)) (pvref new-pv i)))) (setq new-intern-p nil))) (let ((param 0)) (declare (fixnum param)) (dolist (wrapper wrappers) (when (eq wrapper cwrapper) (dotimes (i pv-size) (when (consp (let ((map (svref pv-map i))) (if (and map (= (car map) param)) (setf (pvref new-pv i) (cdr map)) (pvref new-pv i)))) (setq new-intern-p nil)))) (incf param)))) (when new-intern-p (setq new-pv (let ((list-pv (coerce pv 'list))) (or (gethash (cdr list-pv) *pvs*) (setf (gethash (cdr list-pv) *pvs*) (if old-intern-p new-pv (make-permutation-vector list-pv))))))) new-pv))) (defun maybe-expand-accessor-form (form required-parameters slots env) (let* ((fname (car form)) #||(len (length form))||# (gf (if (symbolp fname) (unencapsulated-fdefinition fname) (gdefinition fname)))) (macrolet ((maybe-optimize-reader () `(let ((parameter (can-optimize-access1 (cadr form) required-parameters env))) (when parameter (optimize-reader slots parameter gf-name form)))) (maybe-optimize-writer () `(let ((parameter (can-optimize-access1 (caddr form) required-parameters env))) (when parameter (optimize-writer slots parameter gf-name form))))) (unless (and (consp (cadr form)) (eq 'instance-accessor-parameter (caadr form))) (or #|| (cond ((and (= len 2) (symbolp fname)) (let ((gf-name (gethash fname *gf-declared-reader-table*))) (when gf-name (maybe-optimize-reader)))) ((= len 3) (let ((gf-name (gethash fname *gf-declared-writer-table*))) (when gf-name (maybe-optimize-writer))))) ||# (when (and (eq *boot-state* 'complete) (generic-function-p gf)) (let ((methods (generic-function-methods gf))) (when methods (let* ((gf-name (generic-function-name gf)) (arg-info (gf-arg-info gf)) (metatypes (arg-info-metatypes arg-info)) (nreq (length metatypes)) (applyp (arg-info-applyp arg-info))) (when (null applyp) (cond ((= nreq 1) (when (some #'standard-reader-method-p methods) (maybe-optimize-reader))) ((and (= nreq 2) (consp gf-name) (eq (car gf-name) 'setf)) (when (some #'standard-writer-method-p methods) (maybe-optimize-writer)))))))))))))) (defun optimize-generic-function-call (form required-parameters env slots calls) (declare (ignore required-parameters env slots calls)) (or (and (eq (car form) 'make-instance) (expand-make-instance-form form)) #|| (maybe-expand-accessor-form form required-parameters slots env) (let* ((fname (car form)) (len (length form)) (gf (if (symbolp fname) (and (fboundp fname) (unencapsulated-fdefinition fname)) (and (gboundp fname) (gdefinition fname)))) (gf-name (and (fsc-instance-p gf) (if (early-gf-p gf) (early-gf-name gf) (generic-function-name gf))))) (when gf-name (multiple-value-bind (nreq restp) (get-generic-function-info gf) (optimize-gf-call slots calls form nreq restp env)))) ||# form)) (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) (slot-value 'reader) (set-slot-value 'writer) (slot-boundp 'boundp))) (var (cadr form)) (slot-name (eval (caddr form)))) ; known to be constant (can-optimize-access1 var required-parameters env type slot-name))) (defun can-optimize-access1 (var required-parameters env &optional type slot-name) (when (and (consp var) (eq 'the (car var))) (setq var (caddr var))) (when (symbolp var) (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env))) (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) (when parameter-or-nil (let* ((class-name (caddr (variable-declaration 'class parameter-or-nil env))) (class (find-class class-name nil))) (when (or (not (eq *boot-state* 'complete)) (and class (not (class-finalized-p class)))) (setq class nil)) (when (and class-name (not (eq class-name 't))) (when (or (null type) (not (and class (memq *the-class-structure-object* (class-precedence-list class)))) (optimize-slot-value-by-class-p class slot-name type)) (cons parameter-or-nil (or class class-name))))))))) (defun optimize-slot-value (slots sparameter form) (if sparameter ; FIXME use regular destructuring-bind (pcl-destructuring-bind (ignore ignore slot-name-form) form (let ((slot-name (eval slot-name-form))) (optimize-instance-access slots :read sparameter slot-name nil))) `(accessor-slot-value ,@(cdr form)))) (defun optimize-set-slot-value (slots sparameter form) (if sparameter ; FIXME use regular destructuring-bind (pcl-destructuring-bind (ignore ignore slot-name-form new-value) form (let ((slot-name (eval slot-name-form))) (optimize-instance-access slots :write sparameter slot-name new-value))) `(accessor-set-slot-value ,@(cdr form)))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter ; FIXME use regular destructuring-bind (pcl-destructuring-bind (ignore ignore slot-name-form new-value) form (let ((slot-name (eval slot-name-form))) (optimize-instance-access slots :boundp sparameter slot-name new-value))) `(accessor-slot-boundp ,@(cdr form)))) (defun optimize-reader (slots sparameter gf-name form) (if sparameter (optimize-accessor-call slots :read sparameter gf-name nil) form)) (defun optimize-writer (slots sparameter gf-name form) (if sparameter ; FIXME use regular destructuring-bind (pcl-destructuring-bind (ignore ignore new-value) form (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) ;;; ;;; The argument is an alist, the CAR of each entry is the name of ;;; a required parameter to the function. The alist is in order, so the ;;; position of an entry in the alist corresponds to the argument's position ;;; in the lambda list. ;;; (defun optimize-instance-access (slots read/write sparameter slot-name new-value) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) (parameter (if (consp sparameter) (car sparameter) sparameter))) (if (and (eq *boot-state* 'complete) (classp class) (memq *the-class-structure-object* (class-precedence-list class))) (let ((slotd (find-slot-definition class slot-name))) (ecase read/write (:read `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) (:write `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter) ,new-value)) (:boundp 'T))) (let* ((parameter-entry (assq parameter slots)) (slot-entry (assq slot-name (cdr parameter-entry))) (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry (error "Internal error in slot optimization.")) (unless slot-entry (setq slot-entry (list slot-name)) (push slot-entry (cdr parameter-entry))) (push pv-offset-form (cdr slot-entry)) (ecase read/write (:read `(instance-read ,pv-offset-form ,parameter ,position ',slot-name ',class)) (:write `(let ((.new-value. ,new-value)) (instance-write ,pv-offset-form ,parameter ,position ',slot-name ',class .new-value.))) (:boundp `(instance-boundp ,pv-offset-form ,parameter ,position ',slot-name ',class))))))) (defun optimize-accessor-call (slots read/write sparameter gf-name new-value) (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) (parameter (if (consp sparameter) (car sparameter) sparameter)) (parameter-entry (assq parameter slots)) (name (case read/write (:read `(reader ,gf-name)) (:write `(writer ,gf-name)))) (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry (error "Internal error in slot optimization.")) (unless slot-entry (setq slot-entry (list name)) (push slot-entry (cdr parameter-entry))) (push pv-offset-form (cdr slot-entry)) (ecase read/write (:read `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) (:write `(let ((.new-value. ,new-value)) (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class .new-value.)))))) (defvar *unspecific-arg* '..unspecific-arg..) (defun optimize-gf-call-internal (form slots env) (when (and (consp form) (eq (car form) 'the)) (setq form (caddr form))) (or (and (symbolp form) (let* ((rebound? (caddr (variable-declaration 'variable-rebinding form env))) (parameter-or-nil (car (assq (or rebound? form) slots)))) (when parameter-or-nil (let* ((class-name (caddr (variable-declaration 'class parameter-or-nil env)))) (when (and class-name (not (eq class-name 't))) (position parameter-or-nil slots :key #'car)))))) (if (constantp form) (let ((form (eval form))) (if (symbolp form) form *unspecific-arg*)) *unspecific-arg*))) (defun optimize-gf-call (slots calls gf-call-form nreq restp env) (unless (eq (car gf-call-form) 'make-instance) ; needs more work (let* ((args (cdr gf-call-form)) (all-args-p (eq (car gf-call-form) 'make-instance)) (non-required-args (nthcdr nreq args)) (required-args (ldiff args non-required-args)) (call-spec (list (car gf-call-form) nreq restp (mapcar #'(lambda (form) (optimize-gf-call-internal form slots env)) (if all-args-p args required-args)))) (call-entry (assoc call-spec calls :test #'equal)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless (some #'integerp (let ((spec-args (cdr call-spec))) (if all-args-p (ldiff spec-args (nthcdr nreq spec-args)) spec-args))) (return-from optimize-gf-call nil)) (unless call-entry (setq call-entry (list call-spec)) (push call-entry (cdr calls))) (push pv-offset-form (cdr call-entry)) (if (eq (car call-spec) 'make-instance) `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) (invoke-effective-method-function .emf. ,restp ,@required-args ,@(when restp `((list ,@non-required-args))))))))) (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) (define-walker-template instance-accessor-parameter) (defmacro instance-accessor-parameter (x) x) ;; It is safe for these two functions to be wrong. ;; They just try to guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) (let ((class (and (constantp class-form) (eval class-form))) (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) (and slotd (classp (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) (defun skip-optimize-slot-value-by-class-p (class slot-name type) (let ((slotd (find-slot-definition class slot-name))) (and slotd (eq *boot-state* 'complete) (not (slot-accessor-std-p slotd type))))) (defmacro instance-read-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-read-internal type)) (if (eq type ':default) default (let* ((index (gensym)) (value index)) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index ,@(when (or (null type) (eq type ':instance)) `((fixnum (%instance-ref ,slots ,index)))) ,@(when (or (null type) (eq type ':class)) `((cons (cdr ,index)))) (t ',*slot-unbound*))) (if (eq ,value ',*slot-unbound*) ,default ,value)))))) (defmacro instance-read (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'reader) `(accessor-slot-value ,parameter ,slot-name) `(instance-read-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-value ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) ':class ':instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) `(instance-read-internal .pv. ,(slot-vector-symbol position) ,pv-offset (,gf-name (instance-accessor-parameter ,parameter)) :instance)) (defmacro instance-write-internal (pv slots pv-offset new-value default &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-write-internal type)) (if (eq type ':default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index ,@(when (or (null type) (eq type ':instance)) `((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) ,@(when (or (null type) (eq type ':class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) (defmacro instance-write (pv-offset parameter position slot-name class new-value) (if (skip-fast-slot-access-p class slot-name 'writer) `(accessor-set-slot-value ,parameter ,slot-name ,new-value) `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (accessor-set-slot-value ,parameter ,slot-name ,new-value) ,(if (generate-fast-class-slot-access-p class slot-name) ':class ':instance)))) (defmacro instance-writer (pv-offset parameter position gf-name class new-value) (declare (ignore class)) `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (,(if (consp gf-name) (get-setf-function-name gf-name) gf-name) (instance-accessor-parameter ,parameter) ,new-value) :instance)) (defmacro instance-boundp-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type)) (if (eq type ':default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index ,@(when (or (null type) (eq type ':instance)) `((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*))))) ,@(when (or (null type) (eq type ':class)) `((cons (not (eq (cdr ,index) ',*slot-unbound*))))) (t ,default))))))) (defmacro instance-boundp (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'boundp) `(accessor-slot-boundp ,parameter ,slot-name) `(instance-boundp-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) ':class ':instance)))) ;;; ;;; This magic function has quite a job to do indeed. ;;; ;;; The careful reader will recall that contains all of the optimized ;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is ;;; a call to either INSTANCE-READ or INSTANCE-WRITE. ;;; ;;; At the time these calls were produced, the first argument was specified as ;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset ;;; arguments into the actual number that is the correct offset into the pv. ;;; ;;; But first, oh but first, we sort a bit so that for each argument ;;; we have the slots in alphabetical order. This canonicalizes the PV-TABLE's a ;;; bit and will hopefully lead to having fewer PV's floating around. Even ;;; if the gain is only modest, it costs nothing. ;;; (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists (mapcar #'(lambda (parameter-entry) (cons nil (mapcar #'car (cdr parameter-entry)))) slots)) (call-list (mapcar #'car calls))) (dolist (call call-list) (dolist (arg (cdr call)) (when (integerp arg) (setf (car (nth arg slot-name-lists)) t)))) (setq slot-name-lists (mapcar #'(lambda (r+snl) (when (or (car r+snl) (cdr r+snl)) r+snl)) slot-name-lists)) (let ((cvt (apply #'vector (let ((i -1)) (declare (fixnum i)) (mapcar #'(lambda (r+snl) (when r+snl (incf i))) slot-name-lists))))) (setq call-list (mapcar #'(lambda (call) (cons (car call) (mapcar #'(lambda (arg) (if (integerp arg) (svref cvt arg) arg)) (cdr call)))) call-list))) (values slot-name-lists call-list)))) (defun mutate-slots-and-calls (slots calls) (let ((sorted-slots (sort-slots slots)) (sorted-calls (sort-calls (cdr calls))) (pv-offset 0)) ; index 0 is for info (declare (fixnum pv-offset)) (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) (incf pv-offset) (dolist (form (cdr slot-entry)) (setf (cadr form) pv-offset)))) (dolist (call-entry sorted-calls) (incf pv-offset) (dolist (form (cdr call-entry)) (setf (cadr form) pv-offset))) (values sorted-slots sorted-calls))) (defun symbol-pkg-name (sym) (let ((pkg (symbol-package sym))) (if pkg (package-name pkg) ""))) (defun symbol-lessp (a b) (if (eq (symbol-package a) (symbol-package b)) (string-lessp (symbol-name a) (symbol-name b)) (string-lessp (symbol-pkg-name a) (symbol-pkg-name b)))) (defun symbol-or-cons-lessp (a b) (etypecase a (symbol (etypecase b (symbol (symbol-lessp a b)) (cons t))) (cons (etypecase b (symbol nil) (cons (if (eq (car a) (car b)) (symbol-or-cons-lessp (cdr a) (cdr b)) (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) (mapcar #'(lambda (parameter-entry) (cons (car parameter-entry) (sort (cdr parameter-entry) ;slot entries #'symbol-or-cons-lessp :key #'car))) slots)) (defun sort-calls (calls) (sort calls #'symbol-or-cons-lessp :key #'car)) ;;; ;;; This needs to work in terms of metatypes and also needs to work for ;;; automatically generated reader and writer functions. ;;; -- Automatically generated reader and writer functions use this stuff too. (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) &body body) (with-gathering ((slot-vars (collecting)) (pv-parameters (collecting))) (iterate ((slots (list-elements slot-name-lists)) (required-parameter (list-elements required-parameters)) (i (interval :from 0))) (when slots (gather required-parameter pv-parameters) (gather (slot-vector-symbol i) slot-vars))) `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) ,@body))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) slot-vars pv-parameters)) ,@body))) ;This gets used only when the default make-method-lambda is overriden. (defmacro pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) `(let* ((.pv-table. ,pv-table-symbol) (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) (,pv (car .pv-cell.)) (,calls (cdr .pv-cell.))) (declare ,(make-pv-type-declaration pv)) (declare ,(make-calls-type-declaration calls)) ,@(when (symbolp pv-table-symbol) `((declare (special ,pv-table-symbol)))) ,@(progn #-cmu `(,pv ,calls) #+cmu `(declare (ignorable ,pv ,calls))) ,@forms)) (defvar *non-variable-declarations* '(method-name method-lambda-list optimize ftype inline notinline)) (defvar *variable-declarations-with-argument* '(class type)) (defvar *variable-declarations-without-argument* '(ignore special dynamic-extent array atom base-char bignum bit bit-vector character common compiled-function complex cons double-float extended-char fixnum float function hash-table integer keyword list long-float nil null number package pathname random-state ratio rational readtable sequence short-float signed-byte simple-array simple-bit-vector simple-string simple-vector single-float standard-char stream string-char symbol t unsigned-byte vector)) (defun split-declarations (body args) (let ((inner-decls nil) (outer-decls nil) decl) (loop (when (null body) (return nil)) (setq decl (car body)) (unless (and (consp decl) (eq (car decl) 'declare)) (return nil)) (dolist (form (cdr decl)) (when (consp form) (let ((declaration-name (car form))) (if (member declaration-name *non-variable-declarations*) (push `(declare ,form) outer-decls) (let ((arg-p (member declaration-name *variable-declarations-with-argument*)) (non-arg-p (member declaration-name *variable-declarations-without-argument*)) (dname (list (pop form))) (inners nil) (outers nil)) (unless (or arg-p non-arg-p) (warn "The declaration ~S is not understood by ~S.~@ Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ (Assuming it is a variable declarations without argument)." declaration-name 'split-declarations declaration-name '*non-variable-declarations* '*variable-declarations-with-argument* '*variable-declarations-without-argument*) (push declaration-name *variable-declarations-without-argument*)) (when arg-p (setq dname (append dname (list (pop form))))) (dolist (var form) (if (member var args) (push var outers) (push var inners))) (when outers (push `(declare (,@dname ,@outers)) outer-decls)) (when inners (push `(declare (,@dname ,@inners)) inner-decls))))))) (setq body (cdr body))) (values outer-decls inner-decls body))) (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) (let (method-lambda-args lmf lmf-params) (if (not (and (= 3 (length method-lambda)) (= 2 (length (setq method-lambda-args (cadr method-lambda)))) (consp (setq lmf (third method-lambda))) (eq 'simple-lexical-method-functions (car lmf)) (eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf)))) (eq (cadr method-lambda-args) (caddr lmf-params)))) `(list* :function #',method-lambda ',initargs) (let* ((lambda-list (car lmf-params)) (nreq 0)(restp nil)(args nil)) (dolist (arg lambda-list) (when (member arg '(&optional &rest &key)) (setq restp t)(return nil)) (when (eq arg '&aux) (return nil)) (incf nreq)(push arg args)) (setq args (nreverse args)) (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body) (split-declarations body req-args) (let* ((rest-arg (when restp '.rest-arg.)) (args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) `(list* :fast-function #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg) ,@outer-decls .pv-cell. .next-method-call. (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) (declare (ignore pv-table-symbol pv-parameters)) `(let ((,pv (car .pv-cell.)) (,calls (cdr .pv-cell.))) (declare ,(make-pv-type-declaration pv) ,(make-calls-type-declaration calls)) ,pv ,calls ,@forms))) (fast-lexical-method-functions (,(car lmf-params) .next-method-call. ,req-args ,rest-arg ,@(cdddr lmf-params)) ,@inner-decls ,@body))) ',initargs)))) ;use arrays and hash tables and the fngen stuff to make this much better. ;It doesn't really matter, though, because a function returned by this ;will get called only when the user explicitly funcalls a result of method-function. ;BUT, this is needed to make early methods work. (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) (arg-info (method-function-get fmf ':arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function #'(lambda (method-args next-methods) (unless pv-table (setq pv-table (method-function-pv-table fmf))) (let* ((pv-cell (when pv-table (get-method-function-pv-cell method-function method-args pv-table))) (nm (car next-methods)) (nms (cdr next-methods)) (nmc (when nm (make-method-call :function (if (std-instance-p nm) (method-function nm) nm) :call-method-args (list nms))))) (if restp (let* ((rest (nthcdr nreq method-args)) (args (ldiff method-args rest))) (apply fmf pv-cell nmc (nconc args (list rest)))) (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) (name `(,(or (get (car fname) 'method-sym) (setf (get (car fname) 'method-sym) (let ((str (symbol-name (car fname)))) (if (string= "FAST-" str :end2 5) (intern (subseq str 5) *the-pcl-package*) (car fname))))) ,@(cdr fname)))) (set-function-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) (defun get-method-function-pv-cell (method-function method-args &optional pv-table) (let ((pv-table (or pv-table (method-function-pv-table method-function)))) (when pv-table (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) (when pv-wrappers (pv-table-lookup pv-table pv-wrappers)))))) (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) (defun pv-wrappers-from-pv-args (&rest args) (let* ((nkeys (length args)) (pv-wrappers (make-list nkeys)) w (w-t pv-wrappers)) (declare (fixnum nkeys)) (dolist (arg args) (setq w #+cmu17 (wrapper-of arg) #-cmu17 (cond ((std-instance-p arg) (std-instance-wrapper arg)) ((fsc-instance-p arg) (fsc-instance-wrapper arg)) (t #+new-kcl-wrapper (built-in-wrapper-of arg) #-new-kcl-wrapper (built-in-or-structure-wrapper arg)))) (unless (eq 't (wrapper-state w)) (setq w (check-wrapper-validity arg))) (setf (car w-t) w)) (setq w-t (cdr w-t)) (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) pv-wrappers)) (defun pv-wrappers-from-all-args (pv-table args) (let ((nkeys 0) (slot-name-lists (pv-table-slot-name-lists pv-table))) (declare (fixnum nkeys)) (dolist (sn slot-name-lists) (when sn (incf nkeys))) (let* ((pv-wrappers (make-list nkeys)) (pv-w-t pv-wrappers)) (dolist (sn slot-name-lists) (when sn (let* ((arg (car args)) (w (wrapper-of arg))) (unless w ; can-optimize-access prevents this from happening. (error "error in pv-wrappers-from-all-args")) (setf (car pv-w-t) w) (setq pv-w-t (cdr pv-w-t)))) (setq args (cdr args))) (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) pv-wrappers))) (defun pv-wrappers-from-all-wrappers (pv-table wrappers) (let ((nkeys 0) (slot-name-lists (pv-table-slot-name-lists pv-table))) (declare (fixnum nkeys)) (dolist (sn slot-name-lists) (when sn (incf nkeys))) (let* ((pv-wrappers (make-list nkeys)) (pv-w-t pv-wrappers)) (dolist (sn slot-name-lists) (when sn (let ((w (car wrappers))) (unless w ; can-optimize-access prevents this from happening. (error "error in pv-wrappers-from-all-wrappers")) (setf (car pv-w-t) w) (setq pv-w-t (cdr pv-w-t)))) (setq wrappers (cdr wrappers))) (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) pv-wrappers))) gcl-2.6.14/pcl/gcl_pcl_walk.lisp0000644000175000017500000022034214360276512015066 0ustar cammcamm;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope ;;; Moon's Common Lisp code walker ;;; Gary Drescher's code walker ;;; Larry Masinter's simple code walker ;;; . ;;; . ;;; boy, thats fair (I hope). ;;; ;;; For now at least, this code walker really only does what PCL needs it to ;;; do. Maybe it will grow up someday. ;;; ;;; ;;; This code walker used to be completely portable. Now it is just "Real ;;; easy to port". This change had to happen because the hack that made it ;;; completely portable kept breaking in different releases of different ;;; Common Lisps, and in addition it never worked entirely anyways. So, ;;; its now easy to port. To port this walker, all you have to write is one ;;; simple macro and two simple functions. These macros and functions are ;;; used by the walker to manipluate the macroexpansion environments of ;;; the Common Lisp it is running in. ;;; ;;; The code which implements the macroexpansion environment manipulation ;;; mechanisms is in the first part of the file, the real walker follows it. ;;; (in-package :walker) ;;; ;;; The user entry points are walk-form and nested-walked-form. In addition, ;;; it is legal for user code to call the variable information functions: ;;; variable-lexical-p, variable-special-p and variable-class. Some users ;;; will need to call define-walker-template, they will have to figure that ;;; out for themselves. ;;; (export '(define-walker-template walk-form walk-form-expand-macros-p nested-walk-form variable-lexical-p variable-special-p variable-globally-special-p *variable-declarations* variable-declaration macroexpand-all )) ;;; ;;; On the following pages are implementations of the implementation specific ;;; environment hacking functions for each of the implementations this walker ;;; has been ported to. If you add a new one, so this walker can run in a new ;;; implementation of Common Lisp, please send the changes back to us so that ;;; others can also use this walker in that implementation of Common Lisp. ;;; ;;; This code just hacks 'macroexpansion environments'. That is, it is only ;;; concerned with the function binding of symbols in the environment. The ;;; walker needs to be able to tell if the symbol names a lexical macro or ;;; function, and it needs to be able to build environments which contain ;;; lexical macro or function bindings. It must be able, when walking a ;;; macrolet, flet or labels form to construct an environment which reflects ;;; the bindings created by that form. Note that the environment created ;;; does NOT have to be sufficient to evaluate the body, merely to walk its ;;; body. This means that definitions do not have to be supplied for lexical ;;; functions, only the fact that that function is bound is important. For ;;; macros, the macroexpansion function must be supplied. ;;; ;;; This code is organized in a way that lets it work in implementations that ;;; stack cons their environments. That is reflected in the fact that the ;;; only operation that lets a user build a new environment is a with-body ;;; macro which executes its body with the specified symbol bound to the new ;;; environment. No code in this walker or in PCL will hold a pointer to ;;; these environments after the body returns. Other user code is free to do ;;; so in implementations where it works, but that code is not considered ;;; portable. ;;; ;;; There are 3 environment hacking tools. One macro which is used for ;;; creating new environments, and two functions which are used to access the ;;; bindings of existing environments. ;;; ;;; WITH-AUGMENTED-ENVIRONMENT ;;; ;;; ENVIRONMENT-FUNCTION ;;; ;;; ENVIRONMENT-MACRO ;;; (defun unbound-lexical-function (&rest args) (declare (ignore args)) (error "The evaluator was called to evaluate a form in a macroexpansion~%~ environment constructed by the PCL portable code walker. These~%~ environments are only useful for macroexpansion, they cannot be~%~ used for evaluation.~%~ This error should never occur when using PCL.~%~ This most likely source of this error is a program which tries to~%~ to use the PCL portable code walker to build its own evaluator.")) ;;; ;;; In Coral Common Lisp, the macroexpansion environment is just a list ;;; of environment entries. The cadr of each element specifies the type ;;; of the element. The only types that interest us are CCL::MACRO and ;;; FUNCTION. In these cases the element is interpreted as follows. ;;; ;;; ( CCL::MACRO . macroexpansion-function) ;;; ;;; ( FUNCTION . ) ;;; ;;; When in the compiler, is a gensym which will be ;;; a variable which bound at run-time to the function. ;;; When in the interpreter, is the actual function. ;;; ;;; #+:Coral (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (dolist (f functions) (push (list* f 'function (gensym)) env)) (dolist (m macros) (push (list* (car m) 'ccl::macro (cadr m)) env)) env) (defun environment-function (env fn) (let ((entry (assoc fn env :test #'equal))) (and entry (eq (cadr entry) 'function) (cddr entry)))) (defun environment-macro (env macro) (let ((entry (assoc macro env :test #'equal))) (and entry (eq (cadr entry) 'ccl::macro) (cddr entry)))) );#+:Coral ;;; ;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion ;;; environment is just a list of entries. The cadr of each element ;;; specifies the type of the element. The types that interest us ;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These ;;; are interpreted as follows: ;;; ;;; ( FUNCTION . ) ;;; ;;; This happens in the interpreter with lexically ;;; bound functions. ;;; ;;; ( COMPILER::FUNCTION-VALUE . ) ;;; ;;; This happens in the compiler. The gensym represents ;;; a variable which will be bound at run time to the ;;; function object. ;;; ;;; ( EXCL::MACRO . ) ;;; ;;; In both interpreter and compiler, this is the ;;; representation used for macro definitions. ;;; ;;; #+:ExCL (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env))) (dolist (f functions) (push (list* f 'function #'unbound-lexical-function) env)) (dolist (m macros) (push (list* (car m) 'excl::macro (cadr m)) env)) #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail))) (defun environment-function (env fn) (let* (#+allegro-v4.1 (env (car env)) (entry (assoc fn env :test #'equal))) (and entry (or (eq (cadr entry) 'function) (eq (cadr entry) 'compiler::function-value)) (cddr entry)))) (defun environment-macro (env macro) (let* (#+allegro-v4.1 (env (car env)) (entry (assoc macro env :test #'equal))) (and entry (eq (cadr entry) 'excl::macro) (cddr entry)))) );#+:ExCL #+Lucid (progn (proclaim '(inline %alphalex-p add-contour-to-env-shape make-function-variable make-sfc-contour sfc-contour-type sfc-contour-elements add-sfc-contour add-function-contour add-macrolet-contour find-variable-in-contour find-alist-element-in-contour find-macrolet-in-contour)) (defun %alphalex-p (object) #-Prime (eq (cadddr (cddddr object)) 'lucid::%alphalex) #+Prime (eq (caddr (cddddr object)) 'lucid::%alphalex)) #+Prime (defun lucid::augment-lexenv-fvars-dummy (lexical vars) (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) #-lcl4.0 ; Maybe this should be #-lcl4.1 (progn (defconstant function-contour 1) (defconstant macrolet-contour 5)) #+lcl4.0 ; Maybe this should be #+lcl4.1 (progn (defconstant function-contour 2) (defconstant macrolet-contour 6)) (defstruct lucid::contour type elements) (defun add-contour-to-env-shape (contour-type elements env-shape) (cons (make-contour :type contour-type :elements elements) env-shape)) (defstruct (variable (:constructor make-variable (name source-type))) name (identifier nil) source-type) (defconstant function-sfc-contour 1) (defconstant macrolet-sfc-contour 8) (defconstant function-variable-type 1) (defun make-function-variable (name) (make-variable name function-variable-type)) (defun make-sfc-contour (type elements) (cons type elements)) (defun sfc-contour-type (sfc-contour) (car sfc-contour)) (defun sfc-contour-elements (sfc-contour) (cdr sfc-contour)) (defun add-sfc-contour (element-list environment type) (cons (make-sfc-contour type element-list) environment)) (defun add-function-contour (variable-list environment) (add-sfc-contour variable-list environment function-sfc-contour)) (defun add-macrolet-contour (alist environment) (add-sfc-contour alist environment macrolet-sfc-contour)) (defun find-variable-in-contour (name contour) (dolist (element (sfc-contour-elements contour) nil) (when (eq (variable-name element) name) (return element)))) (defun find-alist-element-in-contour (name contour) (cdr (assoc name (sfc-contour-elements contour)))) (defun find-macrolet-in-contour (name contour) (find-alist-element-in-contour name contour)) (defmacro do-sfc-contours ((contour-var environment &optional result) &body body) `(dolist (,contour-var ,environment ,result) ,@body)) (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let* ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) ;;; ;;; with-augmented-environment-internal is where the real work of augmenting ;;; the environment happens. ;;; (defun with-augmented-environment-internal (env functions macros) (let ((function-names (mapcar #'first functions)) (macro-names (mapcar #'first macros)) (macro-functions (mapcar #'second macros))) (cond ((or (null env) (contour-p (first env))) (when function-names (setq env (add-contour-to-env-shape function-contour function-names env))) (when macro-names (setq env (add-contour-to-env-shape macrolet-contour (pairlis macro-names macro-functions) env)))) ((%alphalex-p env) (when function-names (setq env (lucid::augment-lexenv-fvars-dummy env function-names))) (when macro-names (setq env (lucid::augment-lexenv-mvars env macro-names macro-functions)))) (t (when function-names (setq env (add-function-contour (mapcar #'make-function-variable function-names) env))) (when macro-names (setq env (add-macrolet-contour (pairlis macro-names macro-functions) env))))) env)) (defun environment-function (env fn) (cond ((null env) nil) ((contour-p (first env)) (if (lucid::find-lexical-function fn env) t nil)) ((%alphalex-p env) (if (lucid::lexenv-fvar fn env) t nil)) (t (do-sfc-contours (contour env nil) (let ((type (sfc-contour-type contour))) (cond ((eql type function-sfc-contour) (when (find-variable-in-contour fn contour) (return t))) ((eql type macrolet-sfc-contour) (when (find-macrolet-in-contour fn contour) (return nil))))))))) (defun environment-macro (env macro) (cond ((null env) nil) ((contour-p (first env)) (lucid::find-lexical-macro macro env)) ((%alphalex-p env) (lucid::lexenv-mvar macro env)) (t (do-sfc-contours (contour env nil) (let ((type (sfc-contour-type contour))) (cond ((eql type function-sfc-contour) (when (find-variable-in-contour macro contour) (return nil))) ((eql type macrolet-sfc-contour) (let ((fn (find-macrolet-in-contour macro contour))) (when fn (return fn)))))))))) );#+Lucid ;;; ;;; On the 3600, the documentation for how the environments are represented ;;; is in sys:sys;eval.lisp. That total information is not repeated here. ;;; The important points are that: ;;; si:env-variables returns a list of which each element is: ;;; ;;; (symbol value) ;;; or (symbol . locative) ;;; ;;; The first form is for lexical variables, the second for ;;; special and instance variables. In either case CADR of ;;; the entry is the value and SETF of CADR is used to change ;;; the value. Variables are looked up with ASSQ. ;;; ;;; si:env-functions returns a list of which each element is: ;;; ;;; (symbol definition) ;;; ;;; where definition is anything that could go in a function cell. ;;; This is used for both local functions and local macros. ;;; ;;; The 3600 stack conses its environments (at least in the interpreter). ;;; This means that code written using this walker and running on the 3600 ;;; must not hold on to the environment after the walk-function returns. ;;; No code in this walker or in PCL does that. ;;; #+Genera (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) (let ((funs (make-symbol "FNS")) (macs (make-symbol "MACROS")) (new (make-symbol "NEW"))) `(let ((,funs ,functions) (,macs ,macros) (,new ())) (dolist (f ,funs) (push `(,(car f) ,#'unbound-lexical-function) ,new)) (dolist (m ,macs) (push `(,(car m) (special ,(cadr m))) ,new)) (let* ((.old-env. ,old-env) (.old-vars. (pop .old-env.)) (.old-funs. (pop .old-env.)) (.old-blks. (pop .old-env.)) (.old-tags. (pop .old-env.)) (.old-dcls. (pop .old-env.))) (si:with-interpreter-environment (,new-env .old-env. .old-vars. (append ,new .old-funs.) .old-blks. .old-tags. .old-dcls.) ,@body))))) (defun environment-function (env fn) (if (null env) (values nil nil) (let ((entry (assoc fn (si:env-functions env) :test #'equal))) (if (and entry (or (not (listp (cadr entry))) (not (eq (caadr entry) 'special)))) (values (cadr entry) t) (environment-function (si:env-parent env) fn))))) (defun environment-macro (env macro) (if (null env) (values nil nil) (let ((entry (assoc macro (si:env-functions env) :test #'equal))) (if (and entry (listp (cadr entry)) (eq (caadr entry) 'special)) (values (cadadr entry) t) (environment-macro (si:env-parent env) macro))))) );#+Genera #+Cloe-Runtime (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) functions (dolist (m macros) (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) env) (defun environment-function (env fn) nil) (defun environment-macro (env macro) (let ((entry (getf env macro))) (if (and (consp entry) (eq (car entry) 'compiler::macro)) (values (cdr entry) t) (values nil nil)))) );#+Cloe-Runtime ;;; ;;; In Xerox Lisp, the compiler and interpreter use different structures for ;;; the environment. This doesn't cause a serious problem, the parts of the ;;; environments we are concerned with are fairly similar. ;;; #+:Xerox (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let* ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) ;;; ;;; with-augmented-environment-internal is where the real work of augmenting ;;; the environment happens. Before it gets there, env had better not be NIL ;;; anymore because we have to know what kind of environment we are supposed ;;; to be building up. This is probably never a real concern in practice. ;;; It better not be because we don't do anything about it. ;;; (defun with-augmented-environment-internal (env functions macros) (cond ((compiler::env-p env) (dolist (f functions) (setq env (compiler::copy-env-with-function env f :function))) (dolist (m macros) (setq env (compiler::copy-env-with-function env (car m) :macro (cadr m))))) (t (setq env (if (il:environment-p env) (il:\\copy-environment env) (il:\\make-environment))) ;; The functions field of the environment is a plist of function names ;; and conses like (:function . fn) or (:macro . expansion-fn). ;; Note that we can't smash existing entries in this plist since these ;; are likely shared with older environments. (dolist (f functions) (setf (il:environment-functions env) (list* f (cons :function #'unbound-lexical-function) (il:environment-functions env)))) (dolist (m macros) (setf (il:environment-functions env) (list* (car m) (cons :macro (cadr m)) (il:environment-functions env)))))) env) (defun environment-function (env fn) (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) ((il:environment-p env) (eq (getf (il:environment-functions env) fn) :function)) (t nil))) (defun environment-macro (env macro) (cond ((compiler::env-p env) (multiple-value-bind (type def) (compiler:env-fboundp env macro) (when (eq type :macro) def))) ((il:environment-p env) (xcl:destructuring-bind (type . def) (getf (il:environment-functions env) macro) (when (eq type :macro) def))) (t nil))) );#+:Xerox ;;; ;;; In IBUKI Common Lisp, the macroexpansion environment is a three element ;;; list. The second element describes lexical functions and macros. The ;;; function entries in this list have the form ;;; ( . (FUNCTION . ( . nil)) ;;; The macro entries have the form ;;; ( . (MACRO . ( . nil)). ;;; ;;; #+(or KCL IBCL) (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (let ((first (first env)) (lexicals (second env)) (third (third env))) (dolist (f functions) (push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) lexicals)) (dolist (m macros) (push `(,(car m) . (si::macro . ( ,(cadr m) . nil))) lexicals)) (list first lexicals third))) (defun environment-function (env fn) (when env (let ((entry (assoc fn (second env)))) (and entry (eq (cadr entry) 'function) (caddr entry))))) (defun environment-macro (env macro) (when env (let ((entry (assoc macro (second env)))) (and entry (eq (cadr entry) 'si::macro) (caddr entry))))) );#+(or KCL IBCL) ;;; --- TI Explorer -- ;;; An environment is a two element list, whose car we can ignore and ;;; whose cadr is list of the local-definitions-frames. Each ;;; local-definitions-frame holds either macros or functions, but not ;;; both. Each frame is a plist of ... where ;;; is a locative to the function cell of the symbol that names ;;; the function or macro, and is the new def or NIL if this is function ;;; redefinition or (cons 'ticl:macro ) if this is a macro ;;; redefinition. ;;; ;;; Here's an example. For the form: ;;; (defun foo () ;;; (macrolet ((bar (a b) (list a b)) ;;; (bar2 (a b) (list a b))) ;;; (flet ((some-local-fn (c d) (print (list c d))) ;;; (another (c d) (print (list c d)))) ;;; (bar (some-local-fn 1 2) 3)))) ;;; the environment arg to macroexpand-1 when called on ;;; (bar (some-local-fn 1 2) 3) ;;;is ;;;(NIL ((# NIL ;;; # NIL) ;;; (# ;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) ;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) ;;; (BLOCK BAR ....)) ;;; # ;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) ;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) ;;; (BLOCK BAR2 ....)))) #+TI (progn ;;; from sys:site;macros.lisp (eval-when (compile load eval) (DEFMACRO MACRO-DEF? (thing) `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) ;; the following macro generates code to check the 'local' environment ;; for a macro definition for THE SYMBOL . Such a definition would ;; be set up only by a MACROLET. If a macro definition for is ;; found, its expander function is returned. (DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) `(IF ,local-function-environment (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) (DOLIST (frame ,local-function-environment) ;; is nil or a locative (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) vcell))) (When value (RETURN (CAR value)))))) nil))) ;;;Edited by Reed Hastings 13 Jan 88 16:29 (defun environment-macro (env macro) "returns what macro-function would, ie. the expansion function" ;;some code picked off macroexpand-1 (let* ((local-definitions (cadr env)) (local-def (find-local-definition macro local-definitions))) (if (macro-def? local-def) (cdr local-def)))) ;;;Edited by Reed Hastings 13 Jan 88 16:29 ;;;Edited by Reed Hastings 7 Mar 88 19:07 (defun environment-function (env fn) (let* ((local-definitions (cadr env))) (dolist (frame local-definitions) (let ((val (getf frame (ticl::locf (symbol-function fn)) :not-found-marker))) (cond ((eq val :not-found-marker)) ((functionp val) (return t)) ((and (listp val) (eq (car val) 'ticl::macro)) (return nil)) (t (error "we are confused"))))))) ;;;Edited by Reed Hastings 13 Jan 88 16:29 ;;;Edited by Reed Hastings 7 Mar 88 19:07 (defun with-augmented-environment-internal (env functions macros) (let ((local-definitions (cadr env)) (new-local-fns-frame (mapcan #'(lambda (fn) (list (ticl:locf (symbol-function (car fn))) #'unbound-lexical-function)) functions)) (new-local-macros-frame (mapcan #'(lambda (m) (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) macros))) (when new-local-fns-frame (push new-local-fns-frame local-definitions)) (when new-local-macros-frame (push new-local-macros-frame local-definitions)) `(,(car env) ,local-definitions))) ;;;Edited by Reed Hastings 7 Mar 88 19:07 (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) );#+TI #+(and dec vax common) (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) #'(lambda (op &optional (arg nil arg-p)) (cond ((eq op :macro-function) (unless arg-p (error "Invalid environment use.")) (lookup-macro-function arg env functions macros)) (arg-p (error "Invalid environment operation: ~S ~S" op arg)) (t (lookup-macro-function op env functions macros))))) (defun lookup-macro-function (name env fns macros) (let ((m (assoc name macros))) (cond (m (cadr m)) ((assoc name fns) :function) (env (funcall env name)) (t nil)))) (defun environment-macro (env macro) (let ((m (and env (funcall env macro)))) (and (not (eq m :function)) m))) ;;; Nobody calls environment-function. What would it return, anyway? );#+(and dec vax common) ;;; ;;; In Golden Common Lisp, the macroexpansion environment is just a list ;;; of environment entries. Unless the car of the list is :compiler-menv ;;; it is an interpreted environment. The cadr of each element specifies ;;; the type of the element. The only types that interest us are GCL:MACRO ;;; and FUNCTION. In these cases the element is interpreted as follows. ;;; ;;; Compiled: ;;; ( macroexpansion-function) ;;; ( ) ;;; ;;; Interpreted: ;;; ( GCL:MACRO macroexpansion-function) ;;; ( ) ;;; ;;; When in the compiler, is a gensym which will be ;;; a variable which bound at run-time to the function. ;;; When in the interpreter, is the actual function. ;;; ;;; #+gclisp (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) (let ((new-entries nil)) (dolist (f functions) (push (cons (car f) nil) new-entries)) (dolist (m macros) (push (cons (car m) (if (eq :compiler-menv (car env)) (if (eq (caadr m) 'lisp::lambda) `(,(gensym) ,(cadr m)) `(,(gensym) ,@(cadr m))) `(gclisp:MACRO ,@(cadr m)))) new-entries)) (if (eq :compiler-menv (car env)) `(:compiler-menv ,@new-entries ,@(cdr env)) (append new-entries env)))) (defun environment-function (env fn) (let ((entry (lisp::lexical-function fn env))) (and entry (eq entry 'lisp::lexical-function) fn))) (defun environment-macro (env macro) (let ((entry (assoc macro (if (eq :compiler-menv (first env)) (rest env) env)))) (and entry (consp entry) (symbolp (car entry)) ;name (symbolp (cadr entry)) ;gcl:macro or gensym (nthcdr 2 entry)))) );#+gclisp ;;;; CMU Common Lisp version of environment frobbing stuff. ;;; In CMU Common Lisp, the environment is represented with a structure ;;; that holds alists for the functional things, variables, blocks, etc. ;;; Only the c::lexenv-functions slot is relevent. It holds: ;;; Alist (name . what), where What is either a Functional (a local function) ;;; or a list (MACRO . ) (a local macro, with the specifier ;;; expander.) Note that Name may be a (SETF ) function. #+:CMU (progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) ,@body)) (defun with-augmented-environment-internal (env functions macros) ;; Note: In order to record the correct function definition, we would ;; have to create an interpreted closure, but the with-new-definition ;; macro down below makes no distinction between flet and labels, so ;; we have no idea what to use for the environment. So we just blow it ;; off, 'cause anything real we do would be wrong. We still have to ;; make an entry so we can tell functions from macros. (let ((env (or env (c::make-null-environment)))) (c::make-lexenv :default env :functions (append (mapcar #'(lambda (f) (cons (car f) (c::make-functional :lexenv env))) functions) (mapcar #'(lambda (m) (list* (car m) 'c::macro (coerce (cadr m) 'function))) macros))))) (defun environment-function (env fn) (when env (let ((entry (assoc fn (c::lexenv-functions env) :test #'equal))) (and entry (c::functional-p (cdr entry)) (cdr entry))))) (defun environment-macro (env macro) (when env (let ((entry (assoc macro (c::lexenv-functions env) :test #'eq))) (and entry (eq (cadr entry) 'c::macro) (function-lambda-expression (cddr entry)))))) ); end of #+:CMU (defmacro with-new-definition-in-environment ((new-env old-env macrolet/flet/labels-form) &body body) (let ((functions (make-symbol "Functions")) (macros (make-symbol "Macros"))) `(let ((,functions ()) (,macros ())) (ecase (car ,macrolet/flet/labels-form) ((flet labels) (dolist (fn (cadr ,macrolet/flet/labels-form)) (push fn ,functions))) ((macrolet) (dolist (mac (cadr ,macrolet/flet/labels-form)) (push (list (car mac) (convert-macro-to-lambda (cadr mac) (cddr mac) (string (car mac)))) ,macros)))) (with-augmented-environment (,new-env ,old-env :functions ,functions :macros ,macros) ,@body)))) #-Genera (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) (let ((gensym (make-symbol name))) (eval `(defmacro ,gensym ,llist ,@body)) (macro-function gensym))) #+Genera (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) (si:defmacro-1 'sys:named-lambda 'sys:special (make-symbol name) llist body)) ;;; ;;; Now comes the real walker. ;;; ;;; As the walker walks over the code, it communicates information to itself ;;; about the walk. This information includes the walk function, variable ;;; bindings, declarations in effect etc. This information is inherently ;;; lexical, so the walker passes it around in the actual environment the ;;; walker passes to macroexpansion functions. This is what makes the ;;; nested-walk-form facility work properly. ;;; (defmacro walker-environment-bind ((var env &rest key-args) &body body) `(with-augmented-environment (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) .,body)) (defvar *key-to-walker-environment* (gensym)) (defun env-lock (env) (environment-macro env *key-to-walker-environment*)) (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) (walk-form nil wfop) (declarations nil decp) (lexical-variables nil lexp)) (let ((lock (environment-macro env *key-to-walker-environment*))) (list (list *key-to-walker-environment* (list (if wfnp walk-function (car lock)) (if wfop walk-form (cadr lock)) (if decp declarations (caddr lock)) (if lexp lexical-variables (cadddr lock))))))) (defun env-walk-function (env) (car (env-lock env))) (defun env-walk-form (env) (cadr (env-lock env))) (defun env-declarations (env) (caddr (env-lock env))) (defun env-lexical-variables (env) (cadddr (env-lock env))) (defun note-declaration (declaration env) (push declaration (caddr (env-lock env)))) (defun note-lexical-binding (thing env) (push (list thing :lexical-var) (cadddr (env-lock env)))) (defun VARIABLE-LEXICAL-P (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) (when (eq (cadar entry) :lexical-var) entry))) (defun variable-symbol-macro-p (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) (when (eq (cadar entry) :macro) entry))) (defvar *VARIABLE-DECLARATIONS* '(special)) (defun VARIABLE-DECLARATION (declaration var env) (if (not (member declaration *variable-declarations*)) (error "~S is not a recognized variable declaration." declaration) (let ((id (or (variable-lexical-p var env) var))) (dolist (decl (env-declarations env)) (when (and (eq (car decl) declaration) (eq (cadr decl) id)) (return decl)))))) (defun VARIABLE-SPECIAL-P (var env) (or (not (null (variable-declaration 'special var env))) (variable-globally-special-p var))) ;;; ;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been ;;; declared globally special. Any particular CommonLisp implementation ;;; should customize this function accordingly and send their customization ;;; back. ;;; ;;; The default version of variable-globally-special-p is probably pretty ;;; slow, so it uses *globally-special-variables* as a cache to remember ;;; variables that it has already figured out are globally special. ;;; ;;; This would need to be reworked if an unspecial declaration got added to ;;; Common Lisp. ;;; ;;; Common Lisp nit: ;;; variable-globally-special-p should be defined in Common Lisp. ;;; #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs GCLisp TI pyramid) (defvar *globally-special-variables* ()) (defun variable-globally-special-p (symbol) #+Genera (si:special-variable-p symbol) #+Cloe-Runtime (compiler::specialp symbol) #+Lucid (lucid::proclaimed-special-p symbol) #+TI (get symbol 'special) #+Xerox (il:variable-globally-special-p symbol) #+(and dec vax common) (get symbol 'system::globally-special) #+(or KCL IBCL) (si:specialp symbol) #+excl (get symbol 'excl::.globally-special.) #+:CMU (eq (ext:info variable kind symbol) :special) #+HP-HPLabs (member (get symbol 'impl:vartype) '(impl:fluid impl:global) :test #'eq) #+:GCLISP (gclisp::special-p symbol) #+pyramid (or (get symbol 'lisp::globally-special) (get symbol 'clc::globally-special-in-compiler)) #+:CORAL (ccl::proclaimed-special-p symbol) #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs GCLisp TI pyramid :CORAL) (or (not (null (member symbol *globally-special-variables* :test #'eq))) (when (eval `(flet ((ref () ,symbol)) (let ((,symbol '#,(list nil))) (and (boundp ',symbol) (eq ,symbol (ref)))))) (push symbol *globally-special-variables*) t))) ;; ;;;;;; Handling of special forms (the infamous 24). ;; ;;; ;;; and I quote... ;;; ;;; The set of special forms is purposely kept very small because ;;; any program analyzing program (read code walker) must have ;;; special knowledge about every type of special form. Such a ;;; program needs no special knowledge about macros... ;;; ;;; So all we have to do here is a define a way to store and retrieve ;;; templates which describe how to walk the 24 special forms and we are all ;;; set... ;;; ;;; Well, its a nice concept, and I have to admit to being naive enough that ;;; I believed it for a while, but not everyone takes having only 24 special ;;; forms as seriously as might be nice. There are (at least) 3 ways to ;;; lose: ;; ;;; 1 - Implementation x implements a Common Lisp special form as a macro ;;; which expands into a special form which: ;;; - Is a common lisp special form (not likely) ;;; - Is not a common lisp special form (on the 3600 IF --> COND). ;;; ;;; * We can safe ourselves from this case (second subcase really) by ;;; checking to see if there is a template defined for something ;;; before we check to see if we we can macroexpand it. ;;; ;;; 2 - Implementation x implements a Common Lisp macro as a special form. ;;; ;;; * This is a screw, but not so bad, we save ourselves from it by ;;; defining extra templates for the macros which are *likely* to ;;; be implemented as special forms. (DO, DO* ...) ;;; ;;; 3 - Implementation x has a special form which is not on the list of ;;; Common Lisp special forms. ;;; ;;; * This is a bad sort of a screw and happens more than I would like ;;; to think, especially in the implementations which provide more ;;; than just Common Lisp (3600, Xerox etc.). ;;; The fix is not terribly staisfactory, but will have to do for ;;; now. There is a hook in get walker-template which can get a ;;; template from the implementation's own walker. That template ;;; has to be converted, and so it may be that the right way to do ;;; this would actually be for that implementation to provide an ;;; interface to its walker which looks like the interface to this ;;; walker. ;;; (eval-when (compile load eval) (defmacro get-walker-template-internal (x) ;Has to be inside eval-when because `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack ;compile time definition of macros ;right for setf. (defmacro define-walker-template (name &optional (template '(nil repeat (eval)))) `(eval-when (load eval) (setf (get-walker-template-internal ',name) ',template))) ) (defun get-walker-template (x) (cond ((symbolp x) (or (get-walker-template-internal x) (get-implementation-dependent-walker-template x))) ((and (listp x) (or (eq (car x) 'lambda) #+cmu17 (eq (car x) 'kernel:instance-lambda))) '(lambda repeat (eval))) (t (error "Can't get template for ~S" x)))) (defun get-implementation-dependent-walker-template (x) (declare (ignore x)) ()) ;; ;;;;;; The actual templates ;; (define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) (define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) (define-walker-template COMPILER-LET walk-compiler-let) (define-walker-template DECLARE walk-unexpected-declare) (define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) (define-walker-template FLET walk-flet) (define-walker-template FUNCTION (NIL CALL)) (define-walker-template GO (NIL QUOTE)) (define-walker-template IF walk-if) (define-walker-template LABELS walk-labels) (define-walker-template LAMBDA walk-lambda) (define-walker-template LET walk-let) (define-walker-template LET* walk-let*) (define-walker-template LOCALLY walk-locally) (define-walker-template MACROLET walk-macrolet) (define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) (define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) (define-walker-template MULTIPLE-VALUE-SETQ walk-multiple-value-setq) (define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) (define-walker-template PROGN (NIL REPEAT (EVAL))) (define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) (define-walker-template QUOTE (NIL QUOTE)) (define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) (define-walker-template SETQ walk-setq) (define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) (define-walker-template TAGBODY walk-tagbody) (define-walker-template THE (NIL QUOTE EVAL)) #+cmu(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) (define-walker-template THROW (NIL EVAL EVAL)) (define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) ;;; The new special form. ;(define-walker-template pcl::LOAD-TIME-EVAL (NIL EVAL)) ;;; ;;; And the extra templates... ;;; (define-walker-template DO walk-do) (define-walker-template DO* walk-do*) (define-walker-template PROG walk-prog) (define-walker-template PROG* walk-prog*) (define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) #+Genera (progn (define-walker-template zl::named-lambda walk-named-lambda) (define-walker-template SCL:LETF walk-let) (define-walker-template SCL:LETF* walk-let*) ) #+Lucid (progn (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda #-LCL3.0 sys:named-lambda walk-named-lambda) ) #+(or KCL IBCL) (progn (define-walker-template si::lambda-block walk-named-lambda);Not really right, ;we don't hack block ;names anyways. ) #+TI (progn (define-walker-template TICL::LET-IF walk-let-if) ) #+:Coral (progn (define-walker-template ccl:%stack-block walk-let) ) #+cmu17 (progn (define-walker-template kernel:instance-lambda walk-lambda) ) (defvar walk-form-expand-macros-p nil) (defun macroexpand-all (form &optional environment) (let ((walk-form-expand-macros-p t)) (walk-form form environment))) (defun WALK-FORM (form &optional environment (walk-function #'(lambda (subform context env) (declare (ignore context env)) subform))) (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) ;;; ;;; nested-walk-form provides an interface that allows nested macros, each ;;; of which must walk their body to just do one walk of the body of the ;;; inner macro. That inner walk is done with a walk function which is the ;;; composition of the two walk functions. ;;; ;;; This facility works by having the walker annotate the environment that ;;; it passes to macroexpand-1 to know which form is being macroexpanded. ;;; If then the &whole argument to the macroexpansion function is eq to ;;; the env-walk-form of the environment, nested-walk-form can be certain ;;; that there are no intervening layers and that a nested walk is alright. ;;; ;;; There are some semantic problems with this facility. In particular, if ;;; the outer walk function returns T as its walk-no-more-p value, this will ;;; prevent the inner walk function from getting a chance to walk the subforms ;;; of the form. This is almost never what you want, since it destroys the ;;; equivalence between this nested-walk-form function and two seperate ;;; walk-forms. ;;; (defun NESTED-WALK-FORM (whole form &optional environment (walk-function #'(lambda (subform context env) (declare (ignore context env)) subform))) (if (eq whole (env-walk-form environment)) (let ((outer-walk-function (env-walk-function environment))) (throw whole (walk-form form environment #'(lambda (f c e) ;; First loop to make sure the inner walk function ;; has done all it wants to do with this form. ;; Basically, what we are doing here is providing ;; the same contract walk-form-internal normally ;; provides to the inner walk function. (let ((inner-result nil) (inner-no-more-p nil) (outer-result nil) (outer-no-more-p nil)) (loop (multiple-value-setq (inner-result inner-no-more-p) (funcall walk-function f c e)) (cond (inner-no-more-p (return)) ((not (eq inner-result f))) ((not (consp inner-result)) (return)) ((get-walker-template (car inner-result)) (return)) (t (multiple-value-bind (expansion macrop) (walker-environment-bind (new-env e :walk-form inner-result) (macroexpand-1 inner-result new-env)) (if macrop (setq inner-result expansion) (return))))) (setq f inner-result)) (multiple-value-setq (outer-result outer-no-more-p) (funcall outer-walk-function inner-result c e)) (values outer-result (and inner-no-more-p outer-no-more-p))))))) (walk-form form environment walk-function))) ;;; ;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It ;;; takes a form and the current context and walks the form calling itself or ;;; the appropriate template recursively. ;;; ;;; "It is recommended that a program-analyzing-program process a form ;;; that is a list whose car is a symbol as follows: ;;; ;;; 1. If the program has particular knowledge about the symbol, ;;; process the form using special-purpose code. All of the ;;; standard special forms should fall into this category. ;;; 2. Otherwise, if macro-function is true of the symbol apply ;;; either macroexpand or macroexpand-1 and start over. ;;; 3. Otherwise, assume it is a function call. " ;;; (defun walk-form-internal (form context env) ;; First apply the walk-function to perform whatever translation ;; the user wants to this form. If the second value returned ;; by walk-function is T then we don't recurse... (catch form (multiple-value-bind (newform walk-no-more-p) (funcall (env-walk-function env) form context env) (catch newform (cond (walk-no-more-p newform) ((not (eq form newform)) (walk-form-internal newform context env)) ((not (consp newform)) (let ((symmac (car (variable-symbol-macro-p newform env)))) (if symmac (let ((newnewform (walk-form-internal (cddr symmac) context env))) (if (eq newnewform (cddr symmac)) (if walk-form-expand-macros-p newnewform newform) newnewform)) newform))) (t (let* ((fn (car newform)) (template (get-walker-template fn))) (if template (if (symbolp template) (funcall template newform context env) (walk-template newform template context env)) (multiple-value-bind (newnewform macrop) (walker-environment-bind (new-env env :walk-form newform) (macroexpand-1 newform new-env)) (cond (macrop (let ((newnewnewform (walk-form-internal newnewform context env))) (if (eq newnewnewform newnewform) (if walk-form-expand-macros-p newnewform newform) newnewnewform))) ((and (symbolp fn) (not (fboundp fn)) #+cmu17 (special-operator-p fn) #-cmu17 (special-operator-p fn)) (error "~S is a special form, not defined in the CommonLisp.~%~ manual This code walker doesn't know how to walk it.~%~ Define a template for this special form and try again." fn)) (t ;; Otherwise, walk the form as if its just a standard ;; functioncall using a template for standard function ;; call. (walk-template newnewform '(call repeat (eval)) context env)))))))))))) (defun walk-template (form template context env) (if (atom template) (ecase template ((EVAL FUNCTION TEST EFFECT RETURN) (walk-form-internal form :EVAL env)) ((QUOTE NIL) form) (SET (walk-form-internal form :SET env)) ((LAMBDA CALL) (cond ((or (symbolp form) (and (listp form) (= (length form) 2) (eq (car form) 'setf))) form) #+Lispm ((sys:validate-function-spec form) form) (t (walk-form-internal form context env))))) (case (car template) (REPEAT (walk-template-handle-repeat form (cdr template) ;; For the case where nothing happens ;; after the repeat optimize out the ;; call to length. (if (null (cddr template)) () (nthcdr (- (length form) (length (cddr template))) form)) context env)) (IF (walk-template form (if (if (listp (cadr template)) (eval (cadr template)) (funcall (cadr template) form)) (caddr template) (cadddr template)) context env)) (REMOTE (walk-template form (cadr template) context env)) (otherwise (cond ((atom form) form) (t (recons form (walk-template (car form) (car template) context env) (walk-template (cdr form) (cdr template) context env)))))))) (defun walk-template-handle-repeat (form template stop-form context env) (if (eq form stop-form) (walk-template form (cdr template) context env) (walk-template-handle-repeat-1 form template (car template) stop-form context env))) (defun walk-template-handle-repeat-1 (form template repeat-template stop-form context env) (cond ((null form) ()) ((eq form stop-form) (if (null repeat-template) (walk-template stop-form (cdr template) context env) (error "While handling repeat: ~%~Ran into stop while still in repeat template."))) ((null repeat-template) (walk-template-handle-repeat-1 form template (car template) stop-form context env)) (t (recons form (walk-template (car form) (car repeat-template) context env) (walk-template-handle-repeat-1 (cdr form) template (cdr repeat-template) stop-form context env))))) (defun walk-repeat-eval (form env) (and form (recons form (walk-form-internal (car form) :eval env) (walk-repeat-eval (cdr form) env)))) (defun recons (x car cdr) (if (or (not (eq (car x) car)) (not (eq (cdr x) cdr))) (cons car cdr) x)) (defun relist (x &rest args) (if (null args) nil (relist-internal x args nil))) (defun relist* (x &rest args) (relist-internal x args 't)) (defun relist-internal (x args *p) (if (null (cdr args)) (if *p (car args) (recons x (car args) nil)) (recons x (car args) (relist-internal (cdr x) (cdr args) *p)))) ;; ;;;;;; Special walkers ;; (defun walk-declarations (body fn env &optional doc-string-p declarations old-body &aux (form (car body)) macrop new-form) (cond ((and (stringp form) ;might be a doc string (cdr body) ;isn't the returned value (null doc-string-p) ;no doc string yet (null declarations)) ;no declarations yet (recons body form (walk-declarations (cdr body) fn env t))) ((and (listp form) (eq (car form) 'declare)) ;; Got ourselves a real live declaration. Record it, look for more. (dolist (declaration (cdr form)) (let ((type (car declaration)) (name (cadr declaration)) (args (cddr declaration))) (if (member type *variable-declarations*) (note-declaration `(,type ,(or (variable-lexical-p name env) name) ,.args) env) (note-declaration declaration env)) (push declaration declarations))) (recons body form (walk-declarations (cdr body) fn env doc-string-p declarations))) ((and form (listp form) (null (get-walker-template (car form))) (progn (multiple-value-setq (new-form macrop) (macroexpand-1 form env)) macrop)) ;; This form was a call to a macro. Maybe it expanded ;; into a declare? Recurse to find out. (walk-declarations (recons body new-form (cdr body)) fn env doc-string-p declarations (or old-body body))) (t ;; Now that we have walked and recorded the declarations, ;; call the function our caller provided to expand the body. ;; We call that function rather than passing the real-body ;; back, because we are RECONSING up the new body. (funcall fn (or old-body body) env)))) (defun walk-unexpected-declare (form context env) (declare (ignore context env)) (warn "Encountered declare ~S in a place where a declare was not expected." form) form) (defun walk-arglist (arglist context env &optional (destructuringp nil) &aux arg) (cond ((null arglist) ()) ((symbolp (setq arg (car arglist))) (or (member arg lambda-list-keywords) (note-lexical-binding arg env)) (recons arglist arg (walk-arglist (cdr arglist) context env (and destructuringp (not (member arg lambda-list-keywords)))))) ((consp arg) (prog1 (recons arglist (if destructuringp (walk-arglist arg context env destructuringp) (relist* arg (car arg) (walk-form-internal (cadr arg) :eval env) (cddr arg))) (walk-arglist (cdr arglist) context env nil)) (if (symbolp (car arg)) (note-lexical-binding (car arg) env) (note-lexical-binding (cadar arg) env)) (or (null (cddr arg)) (not (symbolp (caddr arg))) (note-lexical-binding (caddr arg) env)))) (t (error "Can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) (defun walk-let* (form context env) (walk-let/let* form context env t)) (defun walk-prog (form context env) (walk-prog/prog* form context env nil)) (defun walk-prog* (form context env) (walk-prog/prog* form context env t)) (defun walk-do (form context env) (walk-do/do* form context env nil)) (defun walk-do* (form context env) (walk-do/do* form context env t)) (defun walk-let/let* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((let/let* (car form)) (bindings (cadr form)) (body (cddr form)) (walked-bindings (walk-bindings-1 bindings old-env new-env context sequentialp)) (walked-body (walk-declarations body #'walk-repeat-eval new-env))) (relist* form let/let* walked-bindings walked-body)))) (defun walk-locally (form context env) (declare (ignore context)) (let* ((locally (car form)) (body (cdr form)) (walked-body (walk-declarations body #'walk-repeat-eval env))) (relist* form locally walked-body))) (defun walk-prog/prog* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((possible-block-name (second form)) (blocked-prog (and (symbolp possible-block-name) (not (eq possible-block-name 'nil))))) (multiple-value-bind (let/let* block-name bindings body) (if blocked-prog (values (car form) (cadr form) (caddr form) (cdddr form)) (values (car form) nil (cadr form) (cddr form))) (let* ((walked-bindings (walk-bindings-1 bindings old-env new-env context sequentialp)) (walked-body (walk-declarations body #'(lambda (real-body real-env) (walk-tagbody-1 real-body context real-env)) new-env))) (if block-name (relist* form let/let* block-name walked-bindings walked-body) (relist* form let/let* walked-bindings walked-body))))))) (defun walk-do/do* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((do/do* (car form)) (bindings (cadr form)) (end-test (caddr form)) (body (cdddr form)) (walked-bindings (walk-bindings-1 bindings old-env new-env context sequentialp)) (walked-body (walk-declarations body #'walk-repeat-eval new-env))) (relist* form do/do* (walk-bindings-2 bindings walked-bindings context new-env) (walk-template end-test '(test repeat (eval)) context new-env) walked-body)))) (defun walk-let-if (form context env) (let ((test (cadr form)) (bindings (caddr form)) (body (cdddr form))) (walk-form-internal `(let () (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) bindings))) (flet ((.let-if-dummy. () ,@body)) (if ,test (let ,bindings (.let-if-dummy.)) (.let-if-dummy.)))) context env))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) (if (some #'(lambda (var) (variable-symbol-macro-p var env)) vars) (let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars)) (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps)) (expanded `(multiple-value-bind ,temps ,(caddr form) ,@sets)) (walked (walk-form-internal expanded context env))) (if (eq walked expanded) form walked)) (walk-template form '(nil (repeat (set)) eval) context env)))) (defun walk-multiple-value-bind (form context old-env) (walker-environment-bind (new-env old-env) (let* ((mvb (car form)) (bindings (cadr form)) (mv-form (walk-template (caddr form) 'eval context old-env)) (body (cdddr form)) walked-bindings (walked-body (walk-declarations body #'(lambda (real-body real-env) (setq walked-bindings (walk-bindings-1 bindings old-env new-env context nil)) (walk-repeat-eval real-body real-env)) new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) (defun walk-bindings-1 (bindings old-env new-env context sequentialp) (and bindings (let ((binding (car bindings))) (recons bindings (if (symbolp binding) (prog1 binding (note-lexical-binding binding new-env)) (prog1 (relist* binding (car binding) (walk-form-internal (cadr binding) context (if sequentialp new-env old-env)) (cddr binding)) ;save cddr for DO/DO* ;it is the next value ;form. Don't walk it ;now though. (note-lexical-binding (car binding) new-env))) (walk-bindings-1 (cdr bindings) old-env new-env context sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context env) (and bindings (let ((binding (car bindings)) (walked-binding (car walked-bindings))) (recons bindings (if (symbolp binding) binding (relist* binding (car walked-binding) (cadr walked-binding) (walk-template (cddr binding) '(eval) context env))) (walk-bindings-2 (cdr bindings) (cdr walked-bindings) context env))))) (defun walk-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((arglist (cadr form)) (body (cddr form)) (walked-arglist (walk-arglist arglist context new-env)) (walked-body (walk-declarations body #'walk-repeat-eval new-env))) (relist* form (car form) walked-arglist walked-body)))) (defun walk-named-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((name (cadr form)) (arglist (caddr form)) (body (cdddr form)) (walked-arglist (walk-arglist arglist context new-env)) (walked-body (walk-declarations body #'walk-repeat-eval new-env))) (relist* form (car form) name walked-arglist walked-body)))) (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) (tail (cdr form))) (loop (when (null tail) (return (nreverse rforms))) (let ((var (pop tail)) (val (pop tail))) (push `(setq ,var ,val) rforms))))) (walked (walk-repeat-eval expanded env))) (if (eq expanded walked) form `(progn ,@walked))) (let* ((var (cadr form)) (val (caddr form)) (symmac (car (variable-symbol-macro-p var env)))) (if symmac (let* ((expanded `(setf ,(cddr symmac) ,val)) (walked (walk-form-internal expanded context env))) (if (eq expanded walked) form walked)) (relist form 'setq (walk-form-internal var :set env) (walk-form-internal val :eval env)))))) (defun walk-symbol-macrolet (form context old-env) (declare (ignore context)) (let* ((bindings (cadr form))) (walker-environment-bind (new-env old-env :lexical-variables (append (mapcar #'(lambda (binding) `(,(car binding) :macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings (walk-repeat-eval (cddr form) new-env))))) (defun walk-tagbody (form context env) (recons form (car form) (walk-tagbody-1 (cdr form) context env))) (defun walk-tagbody-1 (form context env) (and form (recons form (walk-form-internal (car form) (if (symbolp (car form)) 'quote context) env) (walk-tagbody-1 (cdr form) context env)))) (defun walk-compiler-let (form context old-env) (declare (ignore context)) (let ((vars ()) (vals ())) (dolist (binding (cadr form)) (cond ((symbolp binding) (push binding vars) (push nil vals)) (t (push (car binding) vars) (push (eval (cadr binding)) vals)))) (relist* form (car form) (cadr form) (progv vars vals (walk-repeat-eval (cddr form) old-env))))) (defun walk-macrolet (form context old-env) (walker-environment-bind (macro-env nil :walk-function (env-walk-function old-env)) (labels ((walk-definitions (definitions) (and definitions (let ((definition (car definitions))) (recons definitions (relist* definition (car definition) (walk-arglist (cadr definition) context macro-env t) (walk-declarations (cddr definition) #'walk-repeat-eval macro-env)) (walk-definitions (cdr definitions))))))) (with-new-definition-in-environment (new-env old-env form) (relist* form (car form) (walk-definitions (cadr form)) (walk-declarations (cddr form) #'walk-repeat-eval new-env)))))) (defun walk-flet (form context old-env) (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions (walk-lambda (car definitions) context old-env) (walk-definitions (cdr definitions)))))) (recons form (car form) (recons (cdr form) (walk-definitions (cadr form)) (with-new-definition-in-environment (new-env old-env form) (walk-declarations (cddr form) #'walk-repeat-eval new-env)))))) (defun walk-labels (form context old-env) (with-new-definition-in-environment (new-env old-env form) (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions (walk-lambda (car definitions) context new-env) (walk-definitions (cdr definitions)))))) (recons form (car form) (recons (cdr form) (walk-definitions (cadr form)) (walk-declarations (cddr form) #'walk-repeat-eval new-env)))))) (defun walk-if (form context env) (let ((predicate (cadr form)) (arm1 (caddr form)) (arm2 (if (cddddr form) (progn (warn "In the form:~%~S~%~ IF only accepts three arguments, you are using ~D.~%~ It is true that some Common Lisps support this, but ~ it is not~%~ truly legal Common Lisp. For now, this code ~ walker is interpreting ~%~ the extra arguments as extra else clauses. ~ Even if this is what~%~ you intended, you should fix your source code." form (length (cdr form))) (cons 'progn (cdddr form))) (cadddr form)))) (relist form 'if (walk-form-internal predicate context env) (walk-form-internal arm1 context env) (walk-form-internal arm2 context env)))) ;;; ;;; Tests tests tests ;;; #| ;;; ;;; Here are some examples of the kinds of things you should be able to do ;;; with your implementation of the macroexpansion environment hacking ;;; mechanism. ;;; ;;; with-lexical-macros is kind of like macrolet, but it only takes names ;;; of the macros and actual macroexpansion functions to use to macroexpand ;;; them. The win about that is that for macros which want to wrap several ;;; macrolets around their body, they can do this but have the macroexpansion ;;; functions be compiled. See the WITH-RPUSH example. ;;; ;;; If the implementation had a special way of communicating the augmented ;;; environment back to the evaluator that would be totally great. It would ;;; mean that we could just augment the environment then pass control back ;;; to the implementations own compiler or interpreter. We wouldn't have ;;; to call the actual walker. That would make this much faster. Since the ;;; principal client of this is defmethod it would make compiling defmethods ;;; faster and that would certainly be a win. ;;; (defmacro with-lexical-macros (macros &body body &environment old-env) (with-augmented-environment (new-env old-env :macros macros) (walk-form (cons 'progn body) :environment new-env))) (defun expand-rpush (form env) `(push ,(caddr form) ,(cadr form))) (defmacro with-rpush (&body body) `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) ;;; ;;; Unfortunately, I don't have an automatic tester for the walker. ;;; Instead there is this set of test cases with a description of ;;; how each one should go. ;;; (defmacro take-it-out-for-a-test-walk (form) `(take-it-out-for-a-test-walk-1 ',form)) (defun take-it-out-for-a-test-walk-1 (form) (terpri) (terpri) (let ((copy-of-form (copy-tree form)) (result (walk-form form nil #'(lambda (x y env) (format t "~&Form: ~S ~3T Context: ~A" x y) (when (symbolp x) (let ((lexical (variable-lexical-p x env)) (special (variable-special-p x env))) (when lexical (format t ";~3T") (format t "lexically bound")) (when special (format t ";~3T") (format t "declared special")) (when (boundp x) (format t ";~3T") (format t "bound: ~S " (eval x))))) x)))) (cond ((not (equal result copy-of-form)) (format t "~%Warning: Result not EQUAL to copy of start.")) ((not (eq result form)) (format t "~%Warning: Result not EQ to copy of start."))) (pprint result) result)) (defmacro foo (&rest ignore) ''global-foo) (defmacro bar (&rest ignore) ''global-bar) (take-it-out-for-a-test-walk (list arg1 arg2 arg3)) (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) (take-it-out-for-a-test-walk (progn (foo) (bar 1))) (take-it-out-for-a-test-walk (block block-name a b c)) (take-it-out-for-a-test-walk (block block-name (list a) b c)) (take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) ;;; ;;; This is a fairly simple macrolet case. While walking the body of the ;;; macro, x should be lexically bound. In the body of the macrolet form ;;; itself, x should not be bound. ;;; (take-it-out-for-a-test-walk (macrolet ((foo (x) (list x) ''inner)) x (foo 1))) ;;; ;;; A slightly more complex macrolet case. In the body of the macro x ;;; should not be lexically bound. In the body of the macrolet form itself ;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it ;;; tries to macroexpand the call to foo. ;;; (take-it-out-for-a-test-walk (let ((x 1)) (macrolet ((foo () (list x) ''inner)) x (foo)))) ;;; ;;; A truly hairy use of compiler-let and macrolet. In the body of the ;;; macro x should not be lexically bound. In the body of the macrolet ;;; itself x should not be lexically bound. But the macro should expand ;;; into 1. ;;; (take-it-out-for-a-test-walk (compiler-let ((x 1)) (let ((x 2)) (macrolet ((foo () x)) x (foo))))) (take-it-out-for-a-test-walk (flet ((foo (x) (list x y)) (bar (x) (list x y))) (foo 1))) (take-it-out-for-a-test-walk (let ((y 2)) (flet ((foo (x) (list x y)) (bar (x) (list x y))) (foo 1)))) (take-it-out-for-a-test-walk (labels ((foo (x) (bar x)) (bar (x) (foo x))) (foo 1))) (take-it-out-for-a-test-walk (flet ((foo (x) (foo x))) (foo 1))) (take-it-out-for-a-test-walk (flet ((foo (x) (foo x))) (flet ((bar (x) (foo x))) (bar 1)))) (take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b)) (take-it-out-for-a-test-walk (prog () (declare (special a b)))) (take-it-out-for-a-test-walk (let (a b c) (declare (special a b)) (foo a) b c)) (take-it-out-for-a-test-walk (let (a b c) (declare (special a) (special b)) (foo a) b c)) (take-it-out-for-a-test-walk (let (a b c) (declare (special a)) (declare (special b)) (foo a) b c)) (take-it-out-for-a-test-walk (let (a b c) (declare (special a)) (declare (special b)) (let ((a 1)) (foo a) b c))) (take-it-out-for-a-test-walk (eval-when () a (foo a))) (take-it-out-for-a-test-walk (eval-when (eval when load) a (foo a))) (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (declare (special a)) (list a b))) (take-it-out-for-a-test-walk (progn (function foo))) (take-it-out-for-a-test-walk (progn a b (go a))) (take-it-out-for-a-test-walk (if a b c)) (take-it-out-for-a-test-walk (if a b)) (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) 1 2)) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (declare (special a b)) (list a b c))) (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (declare (special a b)) (list a b c))) (take-it-out-for-a-test-walk (let ((a 1) (b 2)) (foo bar) (declare (special a)) (foo a b))) (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) (take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) (take-it-out-for-a-test-walk (progn a b c)) (take-it-out-for-a-test-walk (progv vars vals a b c)) (take-it-out-for-a-test-walk (quote a)) (take-it-out-for-a-test-walk (return-from block-name a b c)) (take-it-out-for-a-test-walk (setq a 1)) (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) (take-it-out-for-a-test-walk (tagbody a b c (go a))) (take-it-out-for-a-test-walk (the foo (foo-form a b c))) (take-it-out-for-a-test-walk (throw tag-form a)) (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) (defmacro flet-1 (a b) ''outer) (defmacro labels-1 (a b) ''outer) (take-it-out-for-a-test-walk (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) (flet-1 1 2) (foo 1 2))) (take-it-out-for-a-test-walk (labels ((label-1 (a b) () (label-1 a b)(list a b))) (label-1 1 2) (foo 1 2))) (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) (macrolet-1 a b) (foo 1 2))) (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) (foo 1))) (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (a) `(inner-bar-expanded ,a))) (bar 2)))) (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (s) (bar s) `(inner-bar-expanded ,s))) (bar 2)))) (take-it-out-for-a-test-walk (cond (a b) ((foo bar) a (foo a)))) (let ((the-lexical-variables ())) (walk-form '(let ((a 1) (b 2)) #'(lambda (x) (list a b x y))) () #'(lambda (form context env) (when (and (symbolp form) (variable-lexical-p form env)) (push form the-lexical-variables)) form)) (or (and (= (length the-lexical-variables) 3) (member 'a the-lexical-variables) (member 'b the-lexical-variables) (member 'x the-lexical-variables)) (error "Walker didn't do lexical variables of a closure properly."))) |# () gcl-2.6.14/pcl/README0000644000175000017500000000055714360276512012440 0ustar cammcammTo install PCL at your site, follow the instructions in the defsys.lisp file. If you use gcl (GNU Common Lisp), follow the instructions in impl/gcl/README. If you use cmucl17f, follow the instructions in impl/cmu/README, then recompile PCL and rebuild the world. If you use lucid, just compile and load defsys, then type (pcl::compile-pcl), or (pcl::load-pcl). gcl-2.6.14/pcl/gcl_pcl_fin.lisp0000644000175000017500000020023714360276512014705 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;; ;;;;;; FUNCALLABLE INSTANCES ;; #| Generic functions are instances with meta class funcallable-standard-class. Instances with this meta class are called funcallable-instances (FINs for short). They behave something like lexical closures in that they have data associated with them (which is used to store the slots) and are funcallable. When a funcallable instance is funcalled, the function that is invoked is called the funcallable-instance-function. The funcallable-instance-function of a funcallable instance can be changed. This file implements low level code for manipulating funcallable instances. It is possible to implement funcallable instances in pure Common Lisp. A simple implementation which uses lexical closures as the instances and a hash table to record that the lexical closures are funcallable instances is easy to write. Unfortunately, this implementation adds significant overhead: to generic-function-invocation (1 function call) to slot-access (1 function call or one hash table lookup) to class-of a generic-function (1 hash-table lookup) In addition, it would prevent the funcallable instances from being garbage collected. In short, the pure Common Lisp implementation really isn't practical. Instead, PCL uses a specially tailored implementation for each Common Lisp and makes no attempt to provide a purely portable implementation. The specially tailored implementations are based on the lexical closure's provided by that implementation and are fairly short and easy to write. Some of the implementation dependent code in this file was originally written by someone in the employ of the vendor of that Common Lisp. That code is explicitly marked saying who wrote it. |# (in-package :pcl) ;;; ;;; The first part of the file contains the implementation dependent code to ;;; implement funcallable instances. Each implementation must provide the ;;; following functions and macros: ;;; ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () ;;; should create and return a new funcallable instance. The ;;; funcallable-instance-data slots must be initialized to NIL. ;;; This is called by allocate-funcallable-instance and by the ;;; bootstrapping code. ;;; ;;; FUNCALLABLE-INSTANCE-P (x) ;;; the obvious predicate. This should be an INLINE function. ;;; it must be funcallable, but it would be nice if it compiled ;;; open. ;;; ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) ;;; change the fin so that when it is funcalled, the new-value ;;; function is called. Note that it is legal for new-value ;;; to be copied before it is installed in the fin, specifically ;;; there is no accessor for a FIN's function so this function ;;; does not have to preserve the actual new value. The new-value ;;; argument can be any funcallable thing, a closure, lambda ;;; compiled code etc. This function must coerce those values ;;; if necessary. ;;; NOTE: new-value is almost always a compiled closure. This ;;; is the important case to optimize. ;;; ;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) ;;; should return the value of the data named data-name in the fin. ;;; data-name is one of the symbols in the list which is the value ;;; of funcallable-instance-data. Since data-name is almost always ;;; a quoted symbol and funcallable-instance-data is a constant, it ;;; is possible (and worthwhile) to optimize the computation of ;;; data-name's offset in the data part of the fin. ;;; This must be SETF'able. ;;; (eval-when (compile load eval) (defconstant funcallable-instance-data '(wrapper slots) "These are the 'data-slots' which funcallable instances have so that the meta-class funcallable-standard-class can store class, and static slots in them.") ) (defmacro funcallable-instance-data-position (data) (if (and (consp data) (eq (car data) 'quote)) (or (position (cadr data) funcallable-instance-data :test #'eq) (progn (warn "Unknown funcallable-instance data: ~S." (cadr data)) `(error "Unknown funcallable-instance data: ~S." ',(cadr data)))) `(position ,data funcallable-instance-data :test #'eq))) (proclaim '(notinline called-fin-without-function)) (defun called-fin-without-function (&rest args) (declare (ignore args)) (error "Attempt to funcall a funcallable-instance without first~%~ setting its funcallable-instance-function.")) ;;; ;;; In Lucid Lisp, compiled functions and compiled closures have the same ;;; representation. They are called procedures. A procedure is a basically ;;; just a constants vector, with one slot which points to the CODE. This ;;; means that constants and closure variables are intermixed in the procedure ;;; vector. ;;; ;;; This code was largely written by JonL@Lucid.com. Problems with it should ;;; be referred to him. ;;; #+Lucid (progn (defconstant procedure-is-funcallable-instance-bit-position 10) (defconstant fin-trampoline-fun-index lucid::procedure-literals) (defconstant fin-size (+ fin-trampoline-fun-index (length funcallable-instance-data) 1)) ;;; ;;; The inner closure of this function will have its code vector replaced ;;; by a hand-coded fast jump to the function that is stored in the ;;; captured-lexical variable. In effect, that code is a hand- ;;; optimized version of the code for this inner closure function. ;;; (defun make-trampoline (function) (declare (optimize (speed 3) (safety 0))) #'(lambda (&rest args) (apply function args))) (eval-when (eval) (compile 'make-trampoline) ) (defun binary-assemble (codes) (let* ((ncodes (length codes)) (code-vec #-LCL3.0 (lucid::new-code ncodes) #+LCL3.0 (lucid::with-current-area lucid::*READONLY-NON-POINTER-AREA* (lucid::new-code ncodes)))) (declare (fixnum ncodes)) (do ((l codes (cdr l)) (i 0 (1+ i))) ((null l) nil) (declare (fixnum i)) (setf (lucid::code-ref code-vec i) (car l))) code-vec)) ;;; ;;; Egad! Binary patching! ;;; See comment following definition of MAKE-TRAMPOLINE -- this is just ;;; the "hand-optimized" machine instructions to make it work. ;;; (defvar *mattress-pad-code* (binary-assemble #+MC68000 '(#x2A6D #x11 #x246D #x1 #x4EEA #x5) #+SPARC (ecase (lucid::procedure-length #'lucid::false) (5 '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)) (8 `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))) #+(and BSP (not LCL3.0 )) '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889) #+(and BSP LCL3.0) '(#x7733 #x7153 #xC155 #x5 #xE885) #+I386 '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE) #+VAX '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5) #+PA '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9) #+MIPS '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000) #-(or MC68000 SPARC BSP I386 VAX PA MIPS) '(0 0 0 0))) (lucid::defsubst funcallable-instance-p (x) (and (lucid::procedurep x) (lucid::logbitp& procedure-is-funcallable-instance-bit-position (lucid::procedure-ref x lucid::procedure-flags)))) (lucid::defsubst set-funcallable-instance-p (x) (if (not (lucid::procedurep x)) (error "Can't make a non-procedure a fin.") (setf (lucid::procedure-ref x lucid::procedure-flags) (logior (expt 2 procedure-is-funcallable-instance-bit-position) (the fixnum (lucid::procedure-ref x lucid::procedure-flags)))))) (defun allocate-funcallable-instance-1 () #+Prime (declare (notinline lucid::new-procedure)) ;fixes a bug in Prime 1.0 in ;which new-procedure expands ;incorrectly (let ((new-fin (lucid::new-procedure fin-size)) (fin-index fin-size)) (declare (fixnum fin-index) (type lucid::procedure new-fin)) (dotimes (i (length funcallable-instance-data)) ;; Initialize the new funcallable-instance. As part of our contract, ;; we have to make sure the initial value of all the funcallable ;; instance data slots is NIL. (decf fin-index) (setf (lucid::procedure-ref new-fin fin-index) nil)) ;; ;; "Assemble" the initial function by installing a fast "trampoline" code; ;; (setf (lucid::procedure-ref new-fin lucid::procedure-code) *mattress-pad-code*) ;; Disable argcount checking in the "mattress-pad" code for ;; ports that go through standardized trampolines #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1) #+MIPS (progn (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0) (setf (sys:procedure-ref new-fin lucid::procedure-max-args) call-arguments-limit)) ;; but start out with the function to be run as an error call. (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index) #'called-fin-without-function) ;; Then mark it as a "fin" (set-funcallable-instance-p new-fin) new-fin)) (defun set-funcallable-instance-function (fin new-value) (unless (funcallable-instance-p fin) (error "~S is not a funcallable-instance" fin)) (if (lucid::procedurep new-value) (progn (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value) fin) (progn (unless (functionp new-value) (error "~S is not a function." new-value)) ;; 'new-value' is an interpreted function. Install a ;; trampoline to call the interpreted function. (set-funcallable-instance-function fin (make-trampoline new-value))))) (defmacro funcallable-instance-data-1 (instance data) `(lucid::procedure-ref ,instance (the fixnum (- (- fin-size 1) (the fixnum (funcallable-instance-data-position ,data)))))) );end of #+Lucid ;;; ;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment ;;; and an ordinary compiled function. The environment is represented as ;;; a CDR-coded list. I know of no way to add a special bit to say that the ;;; closure is a FIN, so for now, closures are marked as FINS by storing a ;;; special marker in the last cell of the environment. ;;; ;;; The new structure of a fin is: ;;; (lex-env lex-fun *marker* fin-data0 fin-data1) ;;; The value returned by allocate is a lexical-closure pointing to the start ;;; of the fin list. Benefits are: no longer ever have to copy environments, ;;; fins can be much smaller (5 words instead of 18), old environments never ;;; get destroyed (so running dcodes dont have the lex env change from under ;;; them any longer). ;;; ;;; Most of the fin operations speed up a little (by as much as 30% on a ;;; 3650), at least one nasty bug is fixed, and so far at least I've not ;;; seen any problems at all with this code. - mike thome (mthome@bbn.com) ;;; #+(and Genera (not Genera-Release-8)) (progn (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) (defun allocate-funcallable-instance-1 () (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data)))) (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure whole-fin 0))) ;; ;; note that we DO NOT turn the real lex-closure part of the fin into ;; a dotted pair, because (1) the machine doesn't care and (2) if we ;; did the garbage collector would reclaim everything after the lexical ;; function. ;; (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*) (setf (si:lexical-closure-function new-fin) #'(lambda (ignore &rest ignore-them-too) (declare (ignore ignore ignore-them-too)) (called-fin-without-function))) #+ignore (setf (si:lexical-closure-environment new-fin) nil) new-fin)) (scl:defsubst funcallable-instance-p (x) (declare (inline si:lexical-closure-p)) (and (si:lexical-closure-p x) (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1)) sys:cdr-next) (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*))) (defun set-funcallable-instance-function (fin new-value) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) ((not (or (functionp new-value) (and (consp new-value) (eq (car new-value) 'si:digested-lambda)))) (error "~S is not a function." new-value)) ((and (si:lexical-closure-p new-value) (compiled-function-p (si:lexical-closure-function new-value))) (let ((env (si:lexical-closure-environment new-value)) (fn (si:lexical-closure-function new-value))) ;; we only have to copy the pointers!! (setf (si:lexical-closure-environment fin) env (si:lexical-closure-function fin) fn) ; (dbg:set-env->fin env fin) )) (t (set-funcallable-instance-function fin (make-trampoline new-value))))) (defun make-trampoline (function) (declare (optimize (speed 3) (safety 0))) #'(lambda (&rest args) #+Genera (declare (dbg:invisible-frame :pcl-internals)) (apply function args))) (defmacro funcallable-instance-data-1 (fin data) `(sys:%p-contents-offset ,fin (+ 3 (funcallable-instance-data-position ,data)))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(setf (sys:%p-contents-offset ,fin (+ 3 (funcallable-instance-data-position ,data))) ,new-value)) ;;; ;;; Make funcallable instances print out properly. ;;; (defvar *print-lexical-closure* nil) (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0)) (declare (ignore depth)) (declare (special *boot-state*)) (if (or (eq *print-lexical-closure* exp) (neq *boot-state* 'complete) (eq (class-of exp) *the-class-t*)) (let ((*print-lexical-closure* nil)) (funcall (original-definition 'si:print-lexical-closure) exp stream slashify-p)) (let ((*print-escape* slashify-p) (*print-lexical-closure* exp)) (print-object exp stream)))) (unless (boundp '*boot-state*) (setq *boot-state* nil)) (redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure) (defvar *function-name-level* 0) (defun pcl-function-name (function &rest other-args) (if (and (eq *boot-state* 'complete) (funcallable-instance-p function) (generic-function-p function) (<= *function-name-level* 2)) (let ((*function-name-level* (1+ *function-name-level*))) (generic-function-name function)) (apply (original-definition 'si:function-name) function other-args))) (redefine-function 'si:function-name 'pcl-function-name) (defun pcl-arglist (function &rest other-args) (let ((defn nil)) (cond ((and (funcallable-instance-p function) (generic-function-p function)) (generic-function-pretty-arglist function)) ((and (sys:validate-function-spec function) (sys:fdefinedp function) (setq defn (sys:fdefinition function)) (funcallable-instance-p defn) (generic-function-p defn)) (generic-function-pretty-arglist defn)) (t (apply (original-definition 'zl:arglist) function other-args))))) (redefine-function 'zl:arglist 'pcl-arglist) ;;; ;;; This code is adapted from frame-lexical-environment and frame-function. ;;; #|| dbg: (progn (defvar *old-frame-function*) (defvar *inside-new-frame-function* nil) (defun new-frame-function (frame) (let* ((fn (funcall *old-frame-function* frame)) (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0)) (env? #+3600 (location-contents location) #+imach (%memory-read location :cycle-type %memory-scavenge))) (or (when (cl:consp env?) (let ((l2 (last2 env?))) (when (eq (car l2) '.this-is-a-dfun.) (cadr l2)))) fn))) (defun pcl::doctor-dfun-for-the-debugger (gf dfun) (when (sys:lexical-closure-p dfun) (let* ((env (si:lexical-closure-environment dfun)) (l2 (last2 env))) (unless (eq (car l2) '.this-is-a-dfun.) (setf (si:lexical-closure-environment dfun) (nconc env (list '.this-is-a-dfun. gf)))))) dfun) (defun last2 (l) (labels ((scan (2ago tail) (if (null tail) 2ago (if (cl:consp tail) (scan (cdr 2ago) (cdr tail)) nil)))) (and (cl:consp l) (cl:consp (cdr l)) (scan l (cddr l))))) (eval-when (load) (unless (boundp '*old-frame-function*) (setq *old-frame-function* #'frame-function) (setf (cl:symbol-function 'frame-function) 'new-frame-function))) ) ||# );end of #+Genera ;;; ;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this. ;;; This minimizes the subprimitive mucking around. ;;; #+(and Genera Genera-Release-8) (progn (clos-internals::ensure-class 'pcl-funcallable-instance :direct-superclasses '(clos-internals:funcallable-instance) :slots `((:name function :initform #'(lambda (ignore &rest ignore-them-too) (declare (ignore ignore ignore-them-too)) (called-fin-without-function)) :initfunction ,#'(lambda nil #'(lambda (ignore &rest ignore-them-too) (declare (ignore ignore ignore-them-too)) (called-fin-without-function)))) ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data)) :metaclass 'clos:funcallable-standard-class) (defun pcl-funcallable-instance-trampoline (extra-arg &rest args) (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg) 3) args)) (defun allocate-funcallable-instance-1 () (let ((fin (clos:make-instance 'pcl-funcallable-instance))) (setf (clos-internals::%funcallable-instance-function fin) #'pcl-funcallable-instance-trampoline) (setf (clos-internals::%funcallable-instance-extra-argument fin) (sys:%make-pointer sys:dtp-instance (clos-internals::%funcallable-instance-extra-argument fin))) (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin) fin)) (scl:defsubst funcallable-instance-p (x) (and (sys:funcallable-instance-p x) (eq (clos-internals::%funcallable-instance-function x) #'pcl-funcallable-instance-trampoline))) (defun set-funcallable-instance-function (fin new-value) (setf (clos:slot-value fin 'function) new-value)) (defmacro funcallable-instance-data-1 (fin data) `(clos-internals:%funcallable-instance-ref ,fin (+ 4 (funcallable-instance-data-position ,data)))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(setf (clos-internals:%funcallable-instance-ref ,fin (+ 4 (funcallable-instance-data-position ,data))) ,new-value)) (clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream) (print-object fin stream)) (clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance)) nil) (clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance)) (declare (special *boot-state*)) (if (and (eq *boot-state* 'complete) (generic-function-p fin)) (generic-function-name fin) fin)) (clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance)) (declare (special *boot-state*)) (if (and (eq *boot-state* 'complete) (generic-function-p fin)) (generic-function-pretty-arglist fin) '(&rest args))) );end of #+Genera #+Cloe-Runtime (progn (defconstant funcallable-instance-closure-slots 5) (defconstant funcallable-instance-closure-size (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1)) #-CLOE-Release-2 (progn (defun allocate-funcallable-instance-1 () (let ((data (system::make-funcallable-structure 'funcallable-instance funcallable-instance-closure-size))) (setf (system::%trampoline-ref data funcallable-instance-closure-slots) 'funcallable-instance) (set-funcallable-instance-function data #'(lambda (&rest ignore-them-too) (declare (ignore ignore-them-too)) (called-fin-without-function))) data)) (proclaim '(inline funcallable-instance-p)) (defun funcallable-instance-p (x) (and (typep x 'system::trampoline) (= (system::%trampoline-data-length x) funcallable-instance-closure-size) (eq (system::%trampoline-ref x funcallable-instance-closure-slots) 'funcallable-instance))) (defun set-funcallable-instance-function (fin new-value) (when (not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) (etypecase new-value (system::trampoline (let ((length (system::%trampoline-data-length new-value))) (cond ((> length funcallable-instance-closure-slots) (set-funcallable-instance-function fin #'(lambda (&rest args) (declare (sys:downward-rest-argument)) (apply new-value args)))) (t (setf (system::%trampoline-function fin) (system::%trampoline-function new-value)) (dotimes (i length) (setf (system::%trampoline-ref fin i) (system::%trampoline-ref new-value i))))))) (compiled-function (setf (system::%trampoline-function fin) new-value)) (function (set-funcallable-instance-function fin #'(lambda (&rest args) (declare (sys:downward-rest-argument)) (apply new-value args)))))) (defmacro funcallable-instance-data-1 (fin data) `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots 1 (funcallable-instance-data-position ,data)))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots 1 (funcallable-instance-data-position ,data))) ,new-value)) ) #+CLOE-Release-2 (progn (defun allocate-funcallable-instance-1 () (let ((data (si::cons-closure funcallable-instance-closure-size))) (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance) (set-funcallable-instance-function data #'(lambda (&rest ignore-them-too) (declare (ignore ignore-them-too)) (error "Called a FIN without first setting its function."))) data)) (proclaim '(inline funcallable-instance-p)) (defun funcallable-instance-p (x) (and (si::closurep x) (= (si::closure-length x) funcallable-instance-closure-size) (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance))) (defun set-funcallable-instance-function (fin new-value) (when (not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) (etypecase new-value (si::closure (let ((length (si::closure-length new-value))) (cond ((> length funcallable-instance-closure-slots) (set-funcallable-instance-function fin #'(lambda (&rest args) (declare (sys:downward-rest-argument)) (apply new-value args)))) (t (setf (si::closure-function fin) (si::closure-function new-value)) (dotimes (i length) (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3)))))))) (compiled-function (setf (si::closure-function fin) new-value)) (function (set-funcallable-instance-function fin #'(lambda (&rest args) (declare (sys:downward-rest-argument)) (apply new-value args)))))) (defmacro funcallable-instance-data-1 (fin data) `(si::closure-ref ,fin (+ funcallable-instance-closure-slots 1 (funcallable-instance-data-position ,data)))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots 1 (funcallable-instance-data-position ,data))) ,new-value)) ) ) ;;; ;;; ;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and ;;; CCODEP. The environment is represented as a block. There is space in ;;; the top 8 bits of the pointers to the CCODE and the environment to use ;;; to mark the closure as being a FIN. ;;; ;;; To help the debugger figure out when it has found a FIN on the stack, we ;;; reserve the last element of the closure environment to use to point back ;;; to the actual fin. ;;; ;;; Note that there is code in xerox-low which lets us access the fields of ;;; compiled-closures and which defines the closure-overlay record. That ;;; code is there because there are some clients of it in that file. ;;; #+Xerox (progn ;; Don't be fooled. We actually allocate one bigger than this to have a place ;; to store the backpointer to the fin. -smL (defconstant funcallable-instance-closure-size 15) ;; This is only used in the file PCL-ENV. (defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t))) ;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL (defstruct fin-env-pointer (pointer nil :type il:fullxpointer)) (defun fin-env-fin (fin-env) (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2)))) (defun |set fin-env-fin| (fin-env new-value) (il:\\rplptr fin-env (* funcallable-instance-closure-size 2) (make-fin-env-pointer :pointer new-value)) new-value) (defsetf fin-env-fin |set fin-env-fin|) ;; The finalization function that will clean up the backpointer from the ;; fin-env to the fin. This needs to be careful to not cons at all. This ;; depends on there being no other finalization function on compiled-closures, ;; since there is only one finalization function per datatype. Too bad. -smL (defun finalize-fin (fin) ;; This could use the fn funcallable-instance-p, but if we get here we know ;; that this is a closure, so we can skip that test. (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin) (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin))) (when env (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2))) (when (il:typep env 'fin-env-pointer) (setf (fin-env-pointer-pointer env) nil))))) nil) ;Return NIL so GC can proceed (eval-when (load) ;; Install the above finalization function. (when (fboundp 'finalize-fin) (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin))) (defun allocate-funcallable-instance-1 () (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t)) (fin (il:make-compiled-closure nil env))) (setf (fin-env-fin env) fin) (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't) (set-funcallable-instance-function fin #'(lambda (&rest ignore) (declare (ignore ignore)) (called-fin-without-function))) fin)) (xcl:definline funcallable-instance-p (x) (and (typep x 'il:compiled-closure) (il:fetch (closure-overlay funcallable-instance-p) il:of x))) (defun set-funcallable-instance-function (fin new) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) ((not (functionp new)) (error "~S is not a function." new)) ((typep new 'il:compiled-closure) (let* ((fin-env (il:fetch (il:compiled-closure il:environment) il:of fin)) (new-env (il:fetch (il:compiled-closure il:environment) il:of new)) (new-env-size (if new-env (il:\\#blockdatacells new-env) 0)) (fin-env-size (- funcallable-instance-closure-size (length funcallable-instance-data)))) (cond ((and new-env (<= new-env-size fin-env-size)) (dotimes (i fin-env-size) (il:\\rplptr fin-env (* i 2) (if (< i new-env-size) (il:\\getbaseptr new-env (* i 2)) nil))) (setf (compiled-closure-fnheader fin) (compiled-closure-fnheader new))) (t (set-funcallable-instance-function fin (make-trampoline new)))))) (t (set-funcallable-instance-function fin (make-trampoline new))))) (defun make-trampoline (function) #'(lambda (&rest args) (apply function args))) (defmacro funcallable-instance-data-1 (fin data) `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin) (* (- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 1) ;Reserve last element to ;point back to actual FIN! 2))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin) (* (- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 1) 2) ,new-value)) );end of #+Xerox ;;; ;;; In Franz Common Lisp ExCL ;;; This code was originally written by: ;;; jkf%franz.uucp@berkeley.edu ;;; and hacked by: ;;; smh%franz.uucp@berkeley.edu #+ExCL (progn (defconstant funcallable-instance-flag-bit #x1) (defun funcallable-instance-p (x) (and (excl::function-object-p x) (eq funcallable-instance-flag-bit (logand (excl::fn_flags x) funcallable-instance-flag-bit)))) (defun make-trampoline (function) #'(lambda (&rest args) (apply function args))) ;; We initialize a fin's procedure function to this because ;; someone might try to funcall it before it has been set up. (defun init-fin-fun (&rest ignore) (declare (ignore ignore)) (called-fin-without-function)) (eval-when (eval) (compile 'make-trampoline) (compile 'init-fin-fun)) ;; new style #+(and gsgc (not sun4) (not cray) (not mips)) (progn ;; set-funcallable-instance-function must work by overwriting the fin itself ;; because the fin must maintain EQ identity. ;; Because the gsgc time needs several of the fields in the function object ;; at gc time in order to walk the stack frame, it is important never to bash ;; a function object that is active in a frame on the stack. Besides, changing ;; the functions closure vector, not to mention overwriting its constant ;; vector, would scramble it's execution when that stack frame continues. ;; Therefore we represent a fin as a funny compiled-function object. ;; The code vector of this object has some hand-coded instructions which ;; do a very fast jump into the real fin handler function. The function ;; which is the fin object *never* creates a frame on the stack. (defun allocate-funcallable-instance-1 () (let ((fin (compiler::.primcall 'sys::new-function)) (init #'init-fin-fun) (mattress-fun #'funcallable-instance-mattress-pad)) (setf (excl::fn_symdef fin) 'anonymous-fin) (setf (excl::fn_constant fin) init) (setf (excl::fn_code fin) ; this must be before fn_start (excl::fn_code mattress-fun)) (setf (excl::fn_start fin) (excl::fn_start mattress-fun)) (setf (excl::fn_flags fin) (logior (excl::fn_flags init) funcallable-instance-flag-bit)) (setf (excl::fn_closure fin) (make-array (length funcallable-instance-data))) fin)) ;; This function gets its code vector modified with a hand-coded fast jump ;; to the function that is stored in place of its constant vector. ;; This function is never linked in and never appears on the stack. (defun funcallable-instance-mattress-pad () (declare (optimize (speed 3) (safety 0))) 'nil) (eval-when (eval) (compile 'funcallable-instance-mattress-pad)) #+(and excl (target-class s)) (eval-when (load eval) (let ((codevec (excl::fn_code (symbol-function 'funcallable-instance-mattress-pad)))) ;; The entire code vector wants to be: ;; move.l 7(a2),a2 ;#x246a0007 ;; jmp 1(a2) ;#x4eea0001 (setf (aref codevec 0) #x246a (aref codevec 1) #x0007 (aref codevec 2) #x4eea (aref codevec 3) #x0001)) ) #+(and excl (target-class a)) (eval-when (load eval) (let ((codevec (excl::fn_code (symbol-function 'funcallable-instance-mattress-pad)))) ;; The entire code vector wants to be: ;; l r5,15(r5) ;#x5850500f ;; l r15,11(r5) ;#x58f0500b ;; br r15 ;#x07ff (setf (aref codevec 0) #x5850 (aref codevec 1) #x500f (aref codevec 2) #x58f0 (aref codevec 3) #x500b (aref codevec 4) #x07ff (aref codevec 5) #x0000)) ) #+(and excl (target-class i)) (eval-when (load eval) (let ((codevec (excl::fn_code (symbol-function 'funcallable-instance-mattress-pad)))) ;; The entire code vector wants to be: ;; movl 7(edx),edx ;#x07528b ;; jmp *3(edx) ;#x0362ff (setf (aref codevec 0) #x8b (aref codevec 1) #x52 (aref codevec 2) #x07 (aref codevec 3) #xff (aref codevec 4) #x62 (aref codevec 5) #x03)) ) (defun funcallable-instance-data-1 (instance data) (let ((constant (excl::fn_closure instance))) (svref constant (funcallable-instance-data-position data)))) (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) (defun set-funcallable-instance-data-1 (instance data new-value) (let ((constant (excl::fn_closure instance))) (setf (svref constant (funcallable-instance-data-position data)) new-value))) (defun set-funcallable-instance-function (fin new-function) (unless (funcallable-instance-p fin) (error "~S is not a funcallable-instance" fin)) (unless (functionp new-function) (error "~S is not a function." new-function)) (setf (excl::fn_constant fin) (if (excl::function-object-p new-function) new-function ;; The new-function is an interpreted function. ;; Install a trampoline to call the interpreted function. (make-trampoline new-function)))) ) ;; end sun3 #+(and gsgc (or sun4 mips)) (progn (eval-when (compile load eval) (defconstant funcallable-instance-constant-count 15) ) (defun allocate-funcallable-instance-1 () (let ((new-fin (compiler::.primcall 'sys::new-function funcallable-instance-constant-count))) ;; Have to set the procedure function to something for two reasons. ;; 1. someone might try to funcall it. ;; 2. the flag bit that says the procedure is a funcallable ;; instance is set by set-funcallable-instance-function. (set-funcallable-instance-function new-fin #'init-fin-fun) new-fin)) (defun set-funcallable-instance-function (fin new-value) ;; we actually only check for a function object since ;; this is called before the funcallable instance flag is set (unless (excl::function-object-p fin) (error "~S is not a funcallable-instance" fin)) (cond ((not (functionp new-value)) (error "~S is not a function." new-value)) ((not (excl::function-object-p new-value)) ;; new-value is an interpreted function. Install a ;; trampoline to call the interpreted function. (set-funcallable-instance-function fin (make-trampoline new-value))) ((> (+ (excl::function-constant-count new-value) (length funcallable-instance-data)) funcallable-instance-constant-count) ; can't fit, must trampoline (set-funcallable-instance-function fin (make-trampoline new-value))) (t ;; tack the instance variables at the end of the constant vector (setf (excl::fn_code fin) ; this must be before fn_start (excl::fn_code new-value)) (setf (excl::fn_start fin) (excl::fn_start new-value)) (setf (excl::fn_closure fin) (excl::fn_closure new-value)) ; only replace the symdef slot if the new value is an ; interned symbol or some other object (like a function spec) (let ((newsym (excl::fn_symdef new-value))) (excl:if* (and newsym (or (not (symbolp newsym)) (symbol-package newsym))) then (setf (excl::fn_symdef fin) newsym))) (setf (excl::fn_formals fin) (excl::fn_formals new-value)) (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value)) (setf (excl::fn_locals fin) (excl::fn_locals new-value)) (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value) funcallable-instance-flag-bit)) ;; on a sun4 we copy over the constants (dotimes (i (excl::function-constant-count new-value)) (setf (excl::function-constant fin i) (excl::function-constant new-value i))) ;(format t "all done copy from ~s to ~s" new-value fin) ))) (defmacro funcallable-instance-data-1 (instance data) `(excl::function-constant ,instance (- funcallable-instance-constant-count (funcallable-instance-data-position ,data) 1))) ) ;; end sun4 or mips #+(and gsgc cray) (progn ;; The cray is like the sun4 in that the constant vector is included in the ;; function object itself. But a mattress pad must be used anyway, because ;; the function start address is copied in the symbol object, and cannot be ;; updated when the fin is changed. ;; We place the funcallable-instance-function into the first constant slot, ;; and leave enough constant slots after that for the instance data. (eval-when (compile load eval) (defconstant fin-fun-slot 0) (defconstant fin-instance-data-slot 1) ) ;; We initialize a fin's procedure function to this because ;; someone might try to funcall it before it has been set up. (defun init-fin-fun (&rest ignore) (declare (ignore ignore)) (called-fin-without-function)) (defun allocate-funcallable-instance-1 () (let ((fin (compiler::.primcall 'sys::new-function (1+ (length funcallable-instance-data)) "funcallable-instance")) (init #'init-fin-fun) (mattress-fun #'funcallable-instance-mattress-pad)) (setf (excl::fn_symdef fin) 'anonymous-fin) (setf (excl::function-constant fin fin-fun-slot) init) (setf (excl::fn_code fin) ; this must be before fn_start (excl::fn_code mattress-fun)) (setf (excl::fn_start fin) (excl::fn_start mattress-fun)) (setf (excl::fn_flags fin) (logior (excl::fn_flags init) funcallable-instance-flag-bit)) fin)) ;; This function gets its code vector modified with a hand-coded fast jump ;; to the function that is stored in place of its constant vector. ;; This function is never linked in and never appears on the stack. (defun funcallable-instance-mattress-pad () (declare (optimize (speed 3) (safety 0))) 'nil) (eval-when (eval) (compile 'funcallable-instance-mattress-pad) (compile 'init-fin-fun)) (eval-when (load eval) (let ((codevec (excl::fn_code (symbol-function 'funcallable-instance-mattress-pad)))) ;; The entire code vector wants to be: ;; a1 b77 ;; a2 12,a1 ;; a1 1,a2 ;; b77 a2 ;; b76 a1 ;; j b76 (setf (aref codevec 0) #o024177 (aref codevec 1) #o101200 (aref codevec 2) 12 (aref codevec 3) #o102100 (aref codevec 4) 1 (aref codevec 5) #o025277 (aref codevec 6) #o025176 (aref codevec 7) #o005076 )) ) (defmacro funcallable-instance-data-1 (instance data) `(excl::function-constant ,instance (+ (funcallable-instance-data-position ,data) fin-instance-dtat-slot))) (defun set-funcallable-instance-function (fin new-function) (unless (funcallable-instance-p fin) (error "~S is not a funcallable-instance" fin)) (unless (functionp new-function) (error "~S is not a function." new-function)) (setf (excl::function-constant fin fin-fun-slot) (if (excl::function-object-p new-function) new-function ;; The new-function is an interpreted function. ;; Install a trampoline to call the interpreted function. (make-trampoline new-function)))) ) ;; end cray #-gsgc (progn (defun allocate-funcallable-instance-1 () (let ((new-fin (compiler::.primcall 'sys::new-function))) ;; Have to set the procedure function to something for two reasons. ;; 1. someone might try to funcall it. ;; 2. the flag bit that says the procedure is a funcallable ;; instance is set by set-funcallable-instance-function. (set-funcallable-instance-function new-fin #'init-fin-fn) new-fin)) (defun set-funcallable-instance-function (fin new-value) ;; we actually only check for a function object since ;; this is called before the funcallable instance flag is set (unless (excl::function-object-p fin) (error "~S is not a funcallable-instance" fin)) (cond ((not (functionp new-value)) (error "~S is not a function." new-value)) ((not (excl::function-object-p new-value)) ;; new-value is an interpreted function. Install a ;; trampoline to call the interpreted function. (set-funcallable-instance-function fin (make-trampoline new-value))) (t ;; tack the instance variables at the end of the constant vector (setf (excl::fn_start fin) (excl::fn_start new-value)) (setf (excl::fn_constant fin) (add-instance-vars (excl::fn_constant new-value) (excl::fn_constant fin))) (setf (excl::fn_closure fin) (excl::fn_closure new-value)) ;; In versions prior to 2.0. comment the next line and any other ;; references to fn_symdef or fn_locals. (setf (excl::fn_symdef fin) (excl::fn_symdef new-value)) (setf (excl::fn_code fin) (excl::fn_code new-value)) (setf (excl::fn_formals fin) (excl::fn_formals new-value)) (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value)) (setf (excl::fn_locals fin) (excl::fn_locals new-value)) (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value) funcallable-instance-flag-bit))))) (defun add-instance-vars (cvec old-cvec) ;; create a constant vector containing everything in the given constant ;; vector plus space for the instance variables (let* ((nconstants (cond (cvec (length cvec)) (t 0))) (ndata (length funcallable-instance-data)) (old-cvec-length (if old-cvec (length old-cvec) 0)) (new-cvec nil)) (cond ((<= (+ nconstants ndata) old-cvec-length) (setq new-cvec old-cvec)) (t (setq new-cvec (make-array (+ nconstants ndata))) (when old-cvec (dotimes (i ndata) (setf (svref new-cvec (- (+ nconstants ndata) i 1)) (svref old-cvec (- old-cvec-length i 1))))))) (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i))) new-cvec)) (defun funcallable-instance-data-1 (instance data) (let ((constant (excl::fn_constant instance))) (svref constant (- (length constant) (1+ (funcallable-instance-data-position data)))))) (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) (defun set-funcallable-instance-data-1 (instance data new-value) (let ((constant (excl::fn_constant instance))) (setf (svref constant (- (length constant) (1+ (funcallable-instance-data-position data)))) new-value))) );end #-gsgc );end of #+ExCL ;;; ;;; In Vaxlisp ;;; This code was originally written by: ;;; vanroggen%bach.DEC@DECWRL.DEC.COM ;;; #+(and dec vax common) (progn ;;; The following works only in Version 2 of VAXLISP, and will have to ;;; be replaced for later versions. (defun allocate-funcallable-instance-1 () (list 'system::%compiled-closure% () #'(lambda (&rest args) (declare (ignore args)) (called-fin-without-function)) (make-array (length funcallable-instance-data)))) (proclaim '(inline funcallable-instance-p)) (defun funcallable-instance-p (x) (and (consp x) (eq (car x) 'system::%compiled-closure%) (not (null (cdddr x))))) (defun set-funcallable-instance-function (fin func) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) ((not (functionp func)) (error "~S is not a function" func)) ((and (consp func) (eq (car func) 'system::%compiled-closure%)) (setf (cadr fin) (cadr func) (caddr fin) (caddr func))) (t (set-funcallable-instance-function fin (make-trampoline func))))) (defun make-trampoline (function) #'(lambda (&rest args) (apply function args))) (eval-when (eval) (compile 'make-trampoline)) (defmacro funcallable-instance-data-1 (instance data) `(svref (cadddr ,instance) (funcallable-instance-data-position ,data))) );end of Vaxlisp (and dec vax common) ;;;; Implementation of funcallable instances for CMU Common Lisp: ;;; #+CMU ;;; Note: returns true for non-pcl funcallable structures. (import 'kernel:funcallable-instance-p) #+CMU (progn (defstruct (pcl-funcallable-instance (:alternate-metaclass kernel:funcallable-instance kernel:random-pcl-class kernel:make-random-pcl-class) (:type kernel:funcallable-structure) (:constructor allocate-funcallable-instance-1 ()) (:conc-name nil)) ;; ;; PCL wrapper is in the layout slot. ;; ;; PCL data vector. (pcl-funcallable-instance-slots nil) ;; ;; The debug-name for this function. (funcallable-instance-name nil)) ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION -- Interface ;;; ;;; Set the function that is called when FIN is called. ;;; (defun set-funcallable-instance-function (fin new-value) (declare (type function new-value)) (assert (funcallable-instance-p fin)) (setf (kernel:funcallable-instance-function fin) new-value)) ;;; FUNCALLABLE-INSTANCE-DATA-1 -- Interface ;;; ;;; This "works" on non-PCL FINs, which allows us to weaken ;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs. This is also ;;; necessary for bootstrapping to work, since the layouts for early GFs are ;;; not initially initialized. ;;; (defmacro funcallable-instance-data-1 (fin slot) (ecase (eval slot) (wrapper `(kernel:%funcallable-instance-layout ,fin)) (slots `(kernel:%funcallable-instance-info ,fin 0)))) (defmacro pcl-funcallable-instance-wrapper (x) `(kernel:%funcallable-instance-layout ,x)) ); End of #+cmu progn ;;; ;;; Kyoto Common Lisp (KCL) ;;; ;;; In KCL, compiled functions and compiled closures are defined as c structs. ;;; This means that in order to access their fields, we have to use C code! ;;; The C code we call and the lisp interface to it is in the file kcl-low. ;;; The lisp interface to this code implements accessors to compiled closures ;;; and compiled functions of about the same level of abstraction as that ;;; which is used by the other implementation dependent versions of FINs in ;;; this file. ;;; #+(and KCL (not IBCL)) (progn (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) (defconstant funcallable-instance-closure-size 15) (defconstant funcallable-instance-closure-size1 (1- funcallable-instance-closure-size)) (defconstant funcallable-instance-available-size (- funcallable-instance-closure-size1 (length funcallable-instance-data))) (defmacro funcallable-instance-marker (x) `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x))) (defun allocate-funcallable-instance-1 () (let ((fin (allocate-funcallable-instance-2)) (env (make-list funcallable-instance-closure-size :initial-element nil))) (setf (%cclosure-env fin) env) #+:turbo-closure (si:turbo-closure fin) (setf (funcallable-instance-marker fin) *funcallable-instance-marker*) fin)) (defun allocate-funcallable-instance-2 () (let ((what-a-dumb-closure-variable ())) #'(lambda (&rest args) (declare (ignore args)) (called-fin-without-function) (setq what-a-dumb-closure-variable (dummy-function what-a-dumb-closure-variable))))) (defun funcallable-instance-p (x) (eq *funcallable-instance-marker* (funcallable-instance-marker x))) (si:define-compiler-macro funcallable-instance-p (x) `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x))) (defun set-funcallable-instance-function (fin new-value) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) ((not (functionp new-value)) (error "~S is not a function." new-value)) ((and (cclosurep new-value) (<= (length (%cclosure-env new-value)) funcallable-instance-available-size)) (%set-cclosure fin new-value funcallable-instance-available-size)) (t (set-funcallable-instance-function fin (make-trampoline new-value)))) fin) (defmacro funcallable-instance-data-1 (fin data &environment env) ;; The compiler won't expand macros before deciding on optimizations, ;; so we must do it here. (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) env)) (index-form (if (constantp pos-form) (- funcallable-instance-closure-size (eval pos-form) 2) `(- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 2)))) `(car (%cclosure-env-nthcdr ,index-form ,fin)))) #+turbo-closure (clines "#define TURBO_CLOSURE") (clines " static void make_trampoline_internal(); static void make_turbo_trampoline_internal(); static object make_trampoline(function) object function; { vs_push(MMcons(function,Cnil)); #ifdef TURBO_CLOSURE if(type_of(function)==t_cclosure) {if(function->cc.cc_turbo==NULL)turbo_closure(function); vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0); return vs_pop;} #endif vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0); return vs_pop; } static void make_trampoline_internal(fun) object fun; {super_funcall_no_event(fun->cc.cc_turbo[0]->c.c_car);} static void make_turbo_trampoline_internal(fun) object fun; { object function=fun->cc.cc_turbo[0]->c.c_car; (*function->cc.cc_self)(function); } ") (defentry make-trampoline (object) (compiler::static object make_trampoline)) ) #+IBCL (progn ; From Rainy Day PCL. (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) (defconstant funcallable-instance-closure-size 15) (defun allocate-funcallable-instance-1 () (let ((fin (allocate-funcallable-instance-2)) (env (make-list funcallable-instance-closure-size :initial-element nil))) (set-cclosure-env fin env) #+:turbo-closure (si:turbo-closure fin) (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) (setf (car env) *funcallable-instance-marker*) fin)) (defun allocate-funcallable-instance-2 () (let ((what-a-dumb-closure-variable ())) #'(lambda (&rest args) (declare (ignore args)) (called-fin-without-function) (setq what-a-dumb-closure-variable (dummy-function what-a-dumb-closure-variable))))) (defun funcallable-instance-p (x) (and (cclosurep x) (let ((env (cclosure-env x))) (when (listp env) (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) (eq (car env) *funcallable-instance-marker*))))) (defun set-funcallable-instance-function (fin new-value) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance" fin)) ((not (functionp new-value)) (error "~S is not a function." new-value)) ((cclosurep new-value) (let* ((fin-env (cclosure-env fin)) (new-env (cclosure-env new-value)) (new-env-size (length new-env)) (fin-env-size (- funcallable-instance-closure-size (length funcallable-instance-data) 1))) (cond ((<= new-env-size fin-env-size) (do ((i 0 (+ i 1)) (new-env-tail new-env (cdr new-env-tail)) (fin-env-tail fin-env (cdr fin-env-tail))) ((= i fin-env-size)) (setf (car fin-env-tail) (if (< i new-env-size) (car new-env-tail) nil))) (set-cclosure-self fin (cclosure-self new-value)) (set-cclosure-data fin (cclosure-data new-value)) (set-cclosure-start fin (cclosure-start new-value)) (set-cclosure-size fin (cclosure-size new-value))) (t (set-funcallable-instance-function fin (make-trampoline new-value)))))) ((typep new-value 'compiled-function) ;; Write NILs into the part of the cclosure environment that is ;; not being used to store the funcallable-instance-data. Then ;; copy over the parts of the compiled function that need to be ;; copied over. (let ((env (cclosure-env fin))) (dotimes (i (- funcallable-instance-closure-size (length funcallable-instance-data) 1)) (setf (car env) nil) (pop env))) (set-cclosure-self fin (cfun-self new-value)) (set-cclosure-data fin (cfun-data new-value)) (set-cclosure-start fin (cfun-start new-value)) (set-cclosure-size fin (cfun-size new-value))) (t (set-funcallable-instance-function fin (make-trampoline new-value)))) fin) (defun make-trampoline (function) #'(lambda (&rest args) (apply function args))) ;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1 ;; and the defsetf (defmacro funcallable-instance-data-1 (fin data &environment env) ;; The compiler won't expand macros before deciding on optimizations, ;; so we must do it here. (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) env)) (index-form (if (constantp pos-form) (- funcallable-instance-closure-size (eval pos-form) 2) `(- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 2)))) #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin)) #-:turbo-closure `(nth ,index-form (cclosure-env ,fin)))) ) ;;; ;;; In H.P. Common Lisp ;;; This code was originally written by: ;;; kempf@hplabs.hp.com (James Kempf) ;;; dsouza@hplabs.hp.com (Roy D'Souza) ;;; #+HP-HPLabs (progn (defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word)) (defmacro fin-set-mem-hword () `(prim::@set-mem-hword (prim::@+ fin (prim::@<< 2 1)) (prim::@+ (prim::@<< 2 8) (prim::@fundef-info-parms (prim::@fundef-info fundef))))) (defun allocate-funcallable-instance-1() (let* ((fundef #'(lambda (&rest ignore) (declare (ignore ignore)) (called-fin-without-function))) (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL)) (fin (prim::@make-fundef (fin-closure-size)))) (fin-set-mem-hword) (prim::@set-svref fin 2 fundef) (prim::@set-svref fin 3 static-link) (prim::@set-svref fin 4 0) (impl::PlantclosureHook fin) fin)) (defmacro funcallable-instance-p (possible-fin) `(= (fin-closure-size) (prim::@header-inf ,possible-fin))) (defun set-funcallable-instance-function (fin new-function) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable instance.~%" fin)) ((not (functionp new-function)) (error "~S is not a function." new-function)) (T (prim::@set-svref fin 2 new-function)))) (defmacro funcallable-instance-data-1 (fin data) `(prim::@svref (prim::@closure-static-link ,fin) (+ 2 (funcallable-instance-data-position ,data)))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(prim::@set-svref (prim::@closure-static-link ,fin) (+ (funcallable-instance-data-position ,data) 2) ,new-value)) (defun funcallable-instance-name (fin) (prim::@svref (prim::@closure-static-link fin) 1)) (defsetf funcallable-instance-name set-funcallable-instance-name) (defun set-funcallable-instance-name (fin new-name) (prim::@set-svref (prim::@closure-static-link fin) 1 new-name)) );end #+HP ;;; ;;; In Golden Common Lisp. ;;; This code was originally written by: ;;; dan%acorn@Live-Oak.LCS.MIT.edu (Dan Jacobs) ;;; ;;; GCLISP supports named structures that are specially marked as funcallable. ;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate, ;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor. ;;; #+GCLISP (progn (defstruct (%funcallable-instance (:predicate funcallable-instance-p) (:copier nil) (:constructor allocate-funcallable-instance-1 ()) (:print-function (lambda (struct stream depth) (declare (ignore depth)) (print-object struct stream)))) (function #'(lambda (ignore-this &rest ignore-these-too) (declare (ignore ignore-this ignore-these-too)) (called-fin-without-function)) :type function) (%hidden% 'gclisp::funcallable :read-only t) (data (vector nil nil) :type simple-vector :read-only t)) (proclaim '(inline set-funcallable-instance-function)) (defun set-funcallable-instance-function (fin new-value) (setf (%funcallable-instance-function fin) new-value)) (defmacro funcallable-instance-data-1 (fin data) `(svref (%funcallable-instance-data ,fin) (funcallable-instance-data-position ,data))) ) ;;; ;;; Explorer Common Lisp ;;; This code was originally written by: ;;; Dussud%Jenner@csl.ti.com ;;; #+ti (progn #+(or :ti-release-3 (and :ti-release-2 elroy)) (defmacro lexical-closure-environment (l) `(cdr (si:%make-pointer si:dtp-list (cdr (si:%make-pointer si:dtp-list ,l))))) #-(or :ti-release-3 elroy) (defmacro lexical-closure-environment (l) `(caar (si:%make-pointer si:dtp-list (cdr (si:%make-pointer si:dtp-list ,l))))) (defmacro lexical-closure-function (l) `(car (si:%make-pointer si:dtp-list ,l))) (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) (defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid ; hassles with the reader, (defmacro allocate-funcallable-instance-2 () ; these two 15's are the (let ((l ())) ; same. Be sure to keep (dotimes (i 15) ; them consistent. (push (list (gensym) nil) l)) `(let ,l #'(lambda (ignore &rest ignore-them-too) (declare (ignore ignore ignore-them-too)) (called-fin-without-function) (values . ,(mapcar #'car l)))))) (defun allocate-funcallable-instance-1 () (let* ((new-fin (allocate-funcallable-instance-2))) (setf (car (nthcdr (1- funcallable-instance-closure-size) (lexical-closure-environment new-fin))) *funcallable-instance-marker*) new-fin)) (eval-when (eval) (compile 'allocate-funcallable-instance-1)) (proclaim '(inline funcallable-instance-p)) (defun funcallable-instance-p (x) (and (typep x #+:ti-release-2 'closure #+:ti-release-3 'si:lexical-closure) (let ((env (lexical-closure-environment x))) (eq (nth (1- funcallable-instance-closure-size) env) *funcallable-instance-marker*)))) (defun set-funcallable-instance-function (fin new-value) (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance")) ((not (functionp new-value)) (error "~S is not a function.")) ((typep new-value 'si:lexical-closure) (let* ((fin-env (lexical-closure-environment fin)) (new-env (lexical-closure-environment new-value)) (new-env-size (length new-env)) (fin-env-size (- funcallable-instance-closure-size (length funcallable-instance-data) 1))) (cond ((<= new-env-size fin-env-size) (do ((i 0 (+ i 1)) (new-env-tail new-env (cdr new-env-tail)) (fin-env-tail fin-env (cdr fin-env-tail))) ((= i fin-env-size)) (setf (car fin-env-tail) (if (< i new-env-size) (car new-env-tail) nil))) (setf (lexical-closure-function fin) (lexical-closure-function new-value))) (t (set-funcallable-instance-function fin (make-trampoline new-value)))))) (t (set-funcallable-instance-function fin (make-trampoline new-value))))) (defun make-trampoline (function) (let ((tmp)) #'(lambda (&rest args) tmp (apply function args)))) (eval-when (eval) (compile 'make-trampoline)) (defmacro funcallable-instance-data-1 (fin data) `(let ((env (lexical-closure-environment ,fin))) (nth (- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 2) env))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(let ((env (lexical-closure-environment ,fin))) (setf (car (nthcdr (- funcallable-instance-closure-size (funcallable-instance-data-position ,data) 2) env)) ,new-value))) );end of code for TI ;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987 ;;; ;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY ;;; recognize as functions. Both Compiled-Function-P and functionp ;;; recognize FINs as first class functions. ;;; ;;; This does not work with PyrLisp versions earlier than 1.1.. #+pyramid (progn (defun make-trampoline (function) #'(lambda (&rest args) (apply function args))) (defun un-initialized-fin (&rest trash) (declare (ignore trash)) (called-fin-without-function)) (eval-when (eval) (compile 'make-trampoline) (compile 'un-initialized-fin)) (defun allocate-funcallable-instance-1 () (let ((fin (system::alloc-funcallable-instance))) (system::set-fin-function fin #'un-initialized-fin) fin)) (defun funcallable-instance-p (object) (typep object 'lisp::funcallable-instance)) (clc::deftransform funcallable-instance-p trans-fin-p (object) `(typep ,object 'lisp::funcallable-instance)) (defun set-funcallable-instance-function (fin new-value) (or (funcallable-instance-p fin) (error "~S is not a funcallable-instance." fin)) (cond ((not (functionp new-value)) (error "~S is not a function." new-value)) ((not (lisp::compiled-function-p new-value)) (set-funcallable-instance-function fin (make-trampoline new-value))) (t (system::set-fin-function fin new-value)))) (defun funcallable-instance-data-1 (fin data-name) (system::get-fin-data fin (funcallable-instance-data-position data-name))) (defun set-funcallable-instance-data-1 (fin data-name value) (system::set-fin-data fin (funcallable-instance-data-position data-name) value)) (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) ); End of #+pyramid ;;; ;;; For Coral Lisp ;;; #+:coral (progn (defconstant ccl::$v_istruct 22) (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data))) (defconstant ccl::fin-function 1) (defconstant ccl::fin-data (+ ccl::FIN-function 1)) (defun allocate-funcallable-instance-1 () (apply #'ccl::%gvector ccl::$v_istruct 'ccl::funcallable-instance #'(lambda (&rest ignore) (declare (ignore ignore)) (called-fin-without-function)) ccl::initial-fin-slots)) #+:ccl-1.3 (eval-when (eval compile load) ;;; Make uvector-based objects (like funcallable instances) print better. (defun print-uvector-object (obj stream &optional print-level) (declare (ignore print-level)) (print-object obj stream)) ;;; Inform the print system about funcallable instance uvectors. (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object) ccl:*write-uvector-alist* :test #'equal) ) (defun funcallable-instance-p (x) (and (eq (ccl::%type-of x) 'ccl::internal-structure) (eq (ccl::%uvref x 0) 'ccl::funcallable-instance))) (defun set-funcallable-instance-function (fin new-value) (unless (funcallable-instance-p fin) (error "~S is not a funcallable-instance." fin)) (unless (functionp new-value) (error "~S is not a function." new-value)) (ccl::%uvset fin ccl::FIN-function new-value)) (defmacro funcallable-instance-data-1 (fin data-name) `(ccl::%uvref ,fin (+ (funcallable-instance-data-position ,data-name) ccl::FIN-data))) (defsetf funcallable-instance-data-1 (fin data) (new-value) `(ccl::%uvset ,fin (+ (funcallable-instance-data-position ,data) ccl::FIN-data) ,new-value)) ); End of #+:coral ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff. ;;; ;;; (defmacro fsc-instance-p (fin) `(funcallable-instance-p ,fin)) (defmacro fsc-instance-class (fin) `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) (defmacro fsc-instance-wrapper (fin) `(funcallable-instance-data-1 ,fin 'wrapper)) (defmacro fsc-instance-slots (fin) `(funcallable-instance-data-1 ,fin 'slots)) gcl-2.6.14/pcl/gcl_pcl_dfun.lisp0000644000175000017500000016363614360276512015100 0ustar cammcamm;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) #| This implementation of method lookup was redone in early August of 89. It has the following properties: - It's modularity makes it easy to modify the actual caching algorithm. The caching algorithm is almost completely separated into the files cache.lisp and dlap.lisp. This file just contains the various uses of it. There will be more tuning as we get more results from Luis' measurements of caching behavior. - The metacircularity issues have been dealt with properly. All of PCL now grounds out properly. Moreover, it is now possible to have metaobject classes which are themselves not instances of standard metaobject classes. ** Modularity of the code ** The actual caching algorithm is isolated in a modest number of functions. The code which generates cache lookup code is all found in cache.lisp and dlap.lisp. Certain non-wrapper-caching special cases are in this file. ** Handling the metacircularity ** In CLOS, method lookup is the potential source of infinite metacircular regress. The metaobject protocol specification gives us wide flexibility in how to address this problem. PCL uses a technique which handles the problem not only for the metacircular language described in Chapter 3, but also for the PCL protocol which includes additional generic functions which control more aspects of the CLOS implementation. The source of the metacircular regress can be seen in a number of ways. One is that the specified method lookup protocol must, as part of doing the method lookup (or at least the cache miss case), itself call generic functions. It is easy to see that if the method lookup for a generic function ends up calling that same generic function there can be trouble. Fortunately, there is an easy solution at hand. The solution is based on the restriction that portable code cannot change the class of a specified metaobject. This restriction implies that for specified generic functions, the method lookup protocol they follow is fixed. More precisely, for such specified generic functions, most generic functions that are called during their own method lookup will not run portable methods. This allows the implementation to usurp the actual generic function call in this case. In short, method lookup of a standard generic function, in the case where the only applicable methods are themselves standard doesn't have to do any method lookup to implement itself. And so, we are saved. |# ;An alist in which each entry is of the form : ; ( . ( ...)) ;Each subentry is of the form: ; ( ) (defvar *dfun-constructors* ()) ;If this is NIL, then the whole mechanism ;for caching dfun constructors is turned ;off. The only time that makes sense is ;when debugging LAP code. (defvar *enable-dfun-constructor-caching* t) (defun show-dfun-constructors () (format t "~&DFUN constructor caching is ~A." (if *enable-dfun-constructor-caching* "enabled" "disabled")) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (format t "~&~S ~S ~A" (cons (car generator-entry) (car args-entry)) (caddr args-entry) (if (cadddr args-entry) "(preliminary)" ""))))) (defvar *raise-metatypes-to-class-p* t) (defun get-dfun-constructor (generator &rest args) (when (and *raise-metatypes-to-class-p* (member generator '(emit-checking emit-caching emit-in-checking-cache-p emit-constant-value))) (setq args (cons (mapcar #'(lambda (mt) (if (eq mt 't) mt 'class)) (car args)) (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) (apply (the function (symbol-function generator)) args) (or (cadr args-entry) (multiple-value-bind (new not-best-p) (apply (the function (symbol-function generator)) args) (let ((entry (list (copy-list args) new (unless not-best-p '+pcl+) not-best-p))) (if generator-entry (push entry (cdr generator-entry)) (push (list generator entry) *dfun-constructors*))) (values new not-best-p)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if args-entry (when (fourth args-entry) (let* ((dfun-type (case generator (emit-checking 'checking) (emit-caching 'caching) (emit-constant-value 'constant-value) (emit-default-only 'default-method-only))) (metatypes (car args)) (gfs (when dfun-type (gfs-of-type dfun-type)))) (dolist (gf gfs) (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) (let ((gf-name (generic-function-name gf))) (and (not (eq gf-name 'slot-value-using-class)) (not (equal gf-name '(setf slot-value-using-class))) (not (eq gf-name 'slot-boundp-using-class))))) (update-dfun gf))) (setf (second args-entry) constructor) (setf (third args-entry) system) (setf (fourth args-entry) nil))) (let ((entry (list args constructor system nil))) (if generator-entry (push entry (cdr generator-entry)) (push (list generator entry) *dfun-constructors*)))))) (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn ,@(gathering1 (collecting) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) (when system (setf (caddr args-entry) system)) (gather1 (make-top-level-form `(precompile-dfun-constructor ,(car generator-entry)) '(load) `(load-precompiled-dfun-constructor ',(car generator-entry) ',(car args-entry) ',system ,(apply (symbol-function (car generator-entry)) (car args-entry)))))))))))) ;;; ;;; When all the methods of a generic function are automatically generated ;;; reader or writer methods a number of special optimizations are possible. ;;; These are important because of the large number of generic functions of ;;; this type. ;;; ;;; There are a number of cases: ;;; ;;; ONE-CLASS-ACCESSOR ;;; In this case, the accessor generic function has only been called ;;; with one class of argument. There is no cache vector, the wrapper ;;; of the one class, and the slot index are stored directly as closure ;;; variables of the discriminating function. This case can convert to ;;; either of the next kind. ;;; ;;; TWO-CLASS-ACCESSOR ;;; Like above, but two classes. This is common enough to do specially. ;;; There is no cache vector. The two classes are stored a separate ;;; closure variables. ;;; ;;; ONE-INDEX-ACCESSOR ;;; In this case, the accessor generic function has seen more than one ;;; class of argument, but the index of the slot is the same for all ;;; the classes that have been seen. A cache vector is used to store ;;; the wrappers that have been seen, the slot index is stored directly ;;; as a closure variable of the discriminating function. This case ;;; can convert to the next kind. ;;; ;;; N-N-ACCESSOR ;;; This is the most general case. In this case, the accessor generic ;;; function has seen more than one class of argument and more than one ;;; slot index. A cache vector stores the wrappers and corresponding ;;; slot indexes. Because each cache line is more than one element ;;; long, a cache lock count is used. ;;; (defstruct (dfun-info (:constructor nil) (:print-function print-dfun-info)) (cache nil)) (defun print-dfun-info (dfun-info stream depth) (declare (ignore depth) (stream stream)) (printing-random-thing (dfun-info stream) (format stream "~A" (type-of dfun-info)))) (defstruct (no-methods (:constructor no-methods-dfun-info ()) (:include dfun-info))) (defstruct (initial (:constructor initial-dfun-info ()) (:include dfun-info))) (defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) (:include dfun-info))) (defstruct (dispatch (:constructor dispatch-dfun-info ()) (:include dfun-info))) (defstruct (default-method-only (:constructor default-method-only-dfun-info ()) (:include dfun-info))) ;without caching: ; dispatch one-class two-class default-method-only ;with caching: ; one-index n-n checking caching ;accessor: ; one-class two-class one-index n-n (defstruct (accessor-dfun-info (:constructor nil) (:include dfun-info)) accessor-type) ; (member reader writer) (defmacro dfun-info-accessor-type (di) `(accessor-dfun-info-accessor-type ,di)) (defstruct (one-index-dfun-info (:constructor nil) (:include accessor-dfun-info)) index) (defmacro dfun-info-index (di) `(one-index-dfun-info-index ,di)) (defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) (:include accessor-dfun-info))) (defstruct (one-class (:constructor one-class-dfun-info (accessor-type index wrapper0)) (:include one-index-dfun-info)) wrapper0) (defmacro dfun-info-wrapper0 (di) `(one-class-wrapper0 ,di)) (defstruct (two-class (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1)) (:include one-class)) wrapper1) (defmacro dfun-info-wrapper1 (di) `(two-class-wrapper1 ,di)) (defstruct (one-index (:constructor one-index-dfun-info (accessor-type index cache)) (:include one-index-dfun-info))) (defstruct (checking (:constructor checking-dfun-info (function cache)) (:include dfun-info)) function) (defmacro dfun-info-function (di) `(checking-function ,di)) (defstruct (caching (:constructor caching-dfun-info (cache)) (:include dfun-info))) (defstruct (constant-value (:constructor constant-value-dfun-info (cache)) (:include dfun-info))) (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) (funcall ,function ,generic-function ,@args) (update-dfun ,generic-function dfun cache info))) (defun accessor-miss-function (gf dfun-info) (ecase (dfun-info-accessor-type dfun-info) (reader #'(lambda (arg) (declare (pcl-fast-call)) (accessor-miss gf nil arg dfun-info))) (writer #'(lambda (new arg) (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) #+cmu (declaim (ext:freeze-type dfun-info)) ;;; ;;; ONE-CLASS-ACCESSOR ;;; (defun make-one-class-accessor-dfun (gf type wrapper index) (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer)) (dfun-info (one-class-dfun-info type index wrapper))) (values (funcall (the function (get-dfun-constructor emit (consp index))) wrapper index (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; ;;; TWO-CLASS-ACCESSOR ;;; (defun make-two-class-accessor-dfun (gf type w0 w1 index) (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer)) (dfun-info (two-class-dfun-info type index w0 w1))) (values (funcall (the function (get-dfun-constructor emit (consp index))) w0 w1 index (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; ;;; std accessors same index dfun ;;; (defun make-one-index-accessor-dfun (gf type index &optional cache) (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers)) (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values (funcall (the function (get-dfun-constructor emit (consp index))) cache index (accessor-miss-function gf dfun-info)) cache dfun-info))) (defun make-final-one-index-accessor-dfun (gf type index table) (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) (make-one-index-accessor-dfun gf type index cache))) (defun one-index-limit-fn (nlines) (default-limit-fn nlines)) (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers)) (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values (funcall (the function (get-dfun-constructor emit)) cache (accessor-miss-function gf dfun-info)) cache dfun-info))) (defun make-final-n-n-accessor-dfun (gf type table) (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) (make-n-n-accessor-dfun gf type cache))) (defun n-n-accessors-limit-fn (nlines) (default-limit-fn nlines)) (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) (return-from make-checking-dfun (make-caching-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) (if (every #'(lambda (mt) (eq mt 't)) metatypes) (let ((dfun-info (default-method-only-dfun-info))) (values (funcall (the function (get-dfun-constructor 'emit-default-only metatypes applyp)) function) nil dfun-info)) (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) (dfun-info (checking-dfun-info function cache))) (values (funcall (the function (get-dfun-constructor 'emit-checking metatypes applyp)) cache function #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (checking-miss generic-function args dfun-info))) cache dfun-info))))) (defun make-final-checking-dfun (generic-function function classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) (if (every #'(lambda (mt) (eq mt 't)) metatypes) (values #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (invoke-emf function args)) nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn classes-list new-class))) (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp nkeys)) (every #'(lambda (mt) (eq mt 't)) metatypes))) (defun use-caching-dfun-p (generic-function) (some #'(lambda (method) (let ((fmf (if (listp method) (third method) (method-fast-function method)))) (method-function-get fmf ':slot-name-lists))) (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function)))) (defun checking-limit-fn (nlines) (default-limit-fn nlines)) ;;; ;;; ;;; (defun make-caching-dfun (generic-function &optional cache) (unless cache (when (use-constant-value-dfun-p generic-function) (return-from make-caching-dfun (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (caching-dfun-info cache))) (values (funcall (the function (get-dfun-constructor 'emit-caching metatypes applyp)) cache #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (caching-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal generic-function t #'caching-limit-fn classes-list new-class))) (make-caching-dfun generic-function cache))) (defun caching-limit-fn (nlines) (default-limit-fn nlines)) (defun insure-dfun (gf caching-p) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq nkeys)) (when (or (null metatypes) (not (null (car metatypes)))) (cond ((use-constant-value-dfun-p gf) (get-dfun-constructor 'emit-constant-value metatypes)) (caching-p (get-dfun-constructor 'emit-caching metatypes applyp)) ((dolist (mt metatypes t) (unless (eq mt 't) (return nil))) (get-dfun-constructor 'emit-default-only metatypes applyp)) (t (get-dfun-constructor 'emit-checking metatypes applyp)))))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) (methods (if early-p (early-gf-methods gf) (generic-function-methods gf))) (default '(unknown))) (and (null applyp) (or (not (eq *boot-state* 'complete)) (compute-applicable-methods-emf-std-p gf)) (notany #'(lambda (method) (or (and (eq *boot-state* 'complete) (some #'eql-specializer-p (method-specializers method))) (let ((value (method-function-get (if early-p (or (third method) (second method)) (or (method-fast-function method) (method-function method))) :constant-value default))) (if boolean-values-p (not (or (eq value 't) (eq value nil))) (eq value default))))) methods))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (constant-value-dfun-info cache))) (values (funcall (the function (get-dfun-constructor 'emit-constant-value metatypes)) cache #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal generic-function :constant-value #'caching-limit-fn classes-list new-class))) (make-constant-value-dfun generic-function cache))) (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) (unless caching-p ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than ;; one (non built-in) typep. ;; Otherwise, it is probably at least as fast to use ;; a caching dfun first, possibly followed by secondary dispatching. (let ((caching-cost (caching-dfun-cost gf))) (< (dispatch-dfun-cost gf caching-cost) caching-cost))))) ;; Try this on print-object, find-method-combination, and documentation. ;; Look at pcl/generic-functions.lisp for other potential test cases. (defun show-dfun-costs (gf) (when (or (symbolp gf) (consp gf)) (setq gf (gdefinition gf))) (format t "~&Name ~S caching cost ~D dispatch cost ~D~%" (generic-function-name gf) (caching-dfun-cost gf) (dispatch-dfun-cost gf))) (defparameter *non-built-in-typep-cost* 1) (defparameter *structure-typep-cost* 1) (defparameter *built-in-typep-cost* 0) (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil #'(lambda (methods known-types) (declare (ignore methods known-types)) 0) #'(lambda (position type true-value false-value) (declare (ignore position)) (let* ((type-test-cost (if (eq 'class (car type)) (let* ((metaclass (class-of (cadr type))) (mcpl (class-precedence-list metaclass))) (cond ((memq *the-class-built-in-class* mcpl) *built-in-typep-cost*) ((memq *the-class-structure-class* mcpl) *structure-typep-cost*) (t *non-built-in-typep-cost*))) 0)) (max-cost-so-far (+ (max true-value false-value) type-test-cost))) (when (and limit (<= limit max-cost-so-far)) (return-from dispatch-dfun-cost max-cost-so-far)) max-cost-so-far)) #'identity)) (defparameter *cache-lookup-cost* 1) (defparameter *wrapper-of-cost* 0) (defparameter *secondary-dfun-call-cost* 1) (defun caching-dfun-cost (gf) (let* ((arg-info (gf-arg-info gf)) (nreq (length (arg-info-metatypes arg-info)))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p (generic-function-methods gf)) *secondary-dfun-call-cost* 0)))) #+cmu (progn (setq *non-built-in-typep-cost* 100) (setq *structure-typep-cost* 15) (setq *built-in-typep-cost* 5) (setq *cache-lookup-cost* 30) (setq *wrapper-of-cost* 15) (setq *secondary-dfun-call-cost* 30)) (defun make-dispatch-dfun (gf) (values (get-dispatch-function gf) nil (dispatch-dfun-info))) (defun get-dispatch-function (gf) (let ((methods (generic-function-methods gf))) (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil nil nil t) nil nil))) (defun make-final-dispatch-dfun (gf) (make-dispatch-dfun gf)) (defun update-dispatch-dfuns () (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) (dfun-update gf #'make-dispatch-dfun))) (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn (+ (hash-table-count table) 3))))) (maphash #'(lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) value t))) table) cache)) (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class (equal (type-of (gf-dfun-info generic-function)) (cond ((eq valuep t) 'caching) ((eq valuep :constant-value) 'constant-value) ((null valuep) 'checking))) new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) (get-cache nkeys (not (null valuep)) limit-fn 4)))) (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) (defmacro dfun-miss ((gf args wrappers invalidp nemf &optional type index caching-p applicable) &body body) (unless applicable (setq applicable (gensym))) `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp ,@(when type `(,type ,index))) (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) (type 'accessor) (t 'checking))) (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) ,@body)) (invoke-emf ,nemf ,args))) ;;; ;;; The dynamically adaptive method lookup algorithm is implemented is ;;; implemented as a kind of state machine. The kinds of discriminating ;;; function is the state, the various kinds of reasons for a cache miss ;;; are the state transitions. ;;; ;;; The code which implements the transitions is all in the miss handlers ;;; for each kind of dfun. Those appear here. ;;; ;;; Note that within the states that cache, there are dfun updates which ;;; simply select a new cache or cache field. Those are not considered ;;; as state transitions. ;;; (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) (defun make-initial-dfun (gf) (let ((initial-dfun (fin-lambda-fn (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) (if (and (eq *boot-state* 'complete) (compute-applicable-methods-emf-std-p gf)) (let* ((caching-p (use-caching-dfun-p gf)) (classes-list (precompute-effective-methods gf caching-p (not *lazy-dfun-compute-p*)))) (if *lazy-dfun-compute-p* (cond ((use-dispatch-dfun-p gf caching-p) (values initial-dfun nil (initial-dispatch-dfun-info))) (t (insure-dfun gf caching-p) (values initial-dfun nil (initial-dfun-info)))) (make-final-dfun-internal gf classes-list))) (let ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) (gf-arg-info gf))) (type nil)) (if (and (gf-precompute-dfun-and-emf-p arg-info) (setq type (final-accessor-dfun-type gf))) (if *early-p* (values (make-early-accessor gf type) nil nil) (make-final-accessor-dfun gf type)) (values initial-dfun nil (initial-dfun-info))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type (reader (fin-lambda-fn (instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-get-slot class-name instance slot-name)))) (writer (fin-lambda-fn (new-value instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-set-slot class-name instance slot-name new-value))))))) (defun initial-dfun (gf args) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) ((and ntype nindex) (dfun-update gf #'make-one-class-accessor-dfun ntype wrappers nindex)) ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t (dfun-update gf #'make-checking-dfun ;; nemf is suitable only for caching, have to do this: (cache-miss-values gf args 'checking)))))) (defun make-final-dfun (gf &optional classes-list) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) (defvar *new-class* nil) (defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) (defmacro with-hash-table ((table test) &body forms) `(let* ((.free. (assoc ',test *free-hash-tables*)) (,table (if (cdr .free.) (pop (cdr .free.)) (make-hash-table :test ',test)))) (multiple-value-prog1 (progn ,@forms) (clrhash ,table) (push ,table (cdr .free.))))) (defmacro with-eq-hash-table ((table) &body forms) `(with-hash-table (,table eq) ,@forms)) (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) (cond ((every #'(lambda (method) (if (consp method) (eq *the-class-standard-reader-method* (early-method-class method)) (standard-reader-method-p method))) methods) 'reader) ((every #'(lambda (method) (if (consp method) (eq *the-class-standard-writer-method* (early-method-class method)) (standard-writer-method-p method))) methods) 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) (with-eq-hash-table (table) (multiple-value-bind (table all-index first second size no-class-slots-p) (make-accessor-table gf type table) (if table (cond ((= size 1) (let ((w (class-wrapper first))) (make-one-class-accessor-dfun gf type w all-index))) ((and (= size 2) (or (integerp all-index) (consp all-index))) (let ((w0 (class-wrapper first)) (w1 (class-wrapper second))) (make-two-class-accessor-dfun gf type w0 w1 all-index))) ((or (integerp all-index) (consp all-index)) (make-final-one-index-accessor-dfun gf type all-index table)) (no-class-slots-p (make-final-n-n-accessor-dfun gf type table)) (t (make-final-caching-dfun gf classes-list new-class))) (make-final-caching-dfun gf classes-list new-class))))) (defun make-final-dfun-internal (gf &optional classes-list) (let ((methods (generic-function-methods gf)) type (new-class *new-class*) (*new-class* nil) specls all-same-p) (cond ((null methods) (values (fin-lambda-fn (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) (setq specls (method-specializers (car methods)))) (setq all-same-p (every #'(lambda (method) (and (equal specls (method-specializers method)))) methods)))) (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) ((use-dispatch-dfun-p gf) (make-final-dispatch-dfun gf)) ((and all-same-p (not (use-caching-dfun-p gf))) (let ((emf (get-secondary-dispatch-function gf methods nil))) (make-final-checking-dfun gf emf classes-list new-class))) (t (make-final-caching-dfun gf classes-list new-class))))) (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) (otype (dfun-info-accessor-type dfun-info)) oindex ow0 ow1 cache (args (ecase otype ;The congruence rules assure (reader (list object)) ;us that this is safe despite (writer (list new object))))) ;not knowing the new type yet. (dfun-miss (gf args wrappers invalidp nemf ntype nindex) ;; ;; The following lexical functions change the state of the ;; dfun to that which is their name. They accept arguments ;; which are the parameters of the new state, and get other ;; information from the lexical variables bound above. ;; (flet ((two-class (index w0 w1) (when (zerop (random 2)) (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index)) (one-index (index &optional cache) (dfun-update gf #'make-one-index-accessor-dfun ntype index cache)) (n-n (&optional cache) (if (consp nindex) (dfun-update gf #'make-checking-dfun nemf) (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) (caching () ; because cached accessor emfs are much faster for accessors (dfun-update gf #'make-caching-dfun)) ;; (do-fill (update-fn) (declare (type function update-fn)) (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) (funcall update-fn ncache))))) (cond ((null ntype) (caching)) ((or invalidp (null nindex))) ((not #-cmu17 (or (std-instance-p object) (fsc-instance-p object)) #+cmu17 (pcl-instance-p object)) (caching)) ((or (neq ntype otype) (listp wrappers)) (caching)) (t (ecase ostate (one-class (setq oindex (dfun-info-index dfun-info)) (setq ow0 (dfun-info-wrapper0 dfun-info)) (unless (eq ow0 wrappers) (if (eql nindex oindex) (two-class nindex ow0 wrappers) (n-n)))) (two-class (setq oindex (dfun-info-index dfun-info)) (setq ow0 (dfun-info-wrapper0 dfun-info)) (setq ow1 (dfun-info-wrapper1 dfun-info)) (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) (if (eql nindex oindex) (one-index nindex) (n-n)))) (one-index (setq oindex (dfun-info-index dfun-info)) (setq cache (dfun-info-cache dfun-info)) (if (eql nindex oindex) (do-fill #'(lambda (ncache) (one-index nindex ncache))) (n-n))) (n-n (setq cache (dfun-info-cache dfun-info)) (if (consp nindex) (caching) (do-fill #'n-n)))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) (cache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) ((eq oemf nemf) (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun nemf ncache)))) (t (dfun-update generic-function #'make-caching-dfun)))))) (defun caching-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t (let ((ncache (fill-cache ocache wrappers emf))) (unless (eq ncache ocache) (dfun-update generic-function #'make-caching-dfun ncache)))))))) (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t (let* ((function (typecase emf (fast-method-call (fast-method-call-function emf)) (method-call (method-call-function emf)))) (value (method-function-get function :constant-value)) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function #'make-constant-value-dfun ncache)))))))) ;;; Given a generic function and a set of arguments to that generic function, ;;; returns a mess of values. ;;; ;;; The compiled effective method function for this set of ;;; arguments. ;;; ;;; Sorted list of applicable methods. ;;; ;;; Is a single wrapper if the generic function has only ;;; one key, that is arg-info-nkeys of the arg-info is 1. ;;; Otherwise a list of the wrappers of the specialized ;;; arguments to the generic function. ;;; ;;; Note that all these wrappers are valid. This function ;;; does invalid wrapper traps when it finds an invalid ;;; wrapper and then returns the new, valid wrapper. ;;; ;;; True if any of the specialized arguments had an invalid ;;; wrapper, false otherwise. ;;; ;;; READER or WRITER when the only method that would be run ;;; is a standard reader or writer method. To be specific, ;;; the value is READER when the method combination is eq to ;;; *standard-method-combination*; there are no applicable ;;; :before, :after or :around methods; and the most specific ;;; primary method is a standard reader method. ;;; ;;; If is READER or WRITER, and the slot accessed is ;;; an :instance slot, this is the index number of that slot ;;; in the object argument. ;;; (defun cache-miss-values (gf args state) (if (null (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf))) (apply #'no-applicable-method gf args) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nreq applyp nkeys)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p wrappers classes types) (error "The function ~S requires at least ~D arguments" gf (length metatypes)) (multiple-value-bind (emf methods accessor-type index) (cache-miss-values-internal gf arg-info wrappers classes types state) (values emf methods dfun-wrappers invalid-wrapper-p accessor-type index)))))) (defun cache-miss-values-internal (gf arg-info wrappers classes types state) (let* ((for-accessor-p (eq state 'accessor)) (for-cache-p (or (eq state 'caching) (eq state 'accessor))) (cam-std-p (or (null arg-info) (gf-info-c-a-m-emf-std-p arg-info)))) (multiple-value-bind (methods all-applicable-and-sorted-p) (if cam-std-p (compute-applicable-methods-using-types gf types) (compute-applicable-methods-using-classes gf classes)) (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) (function-funcall (get-secondary-dispatch-function1 gf methods types nil (and for-cache-p wrappers) all-applicable-and-sorted-p) nil (and for-cache-p wrappers)) (default-secondary-dispatch-function gf)))) (multiple-value-bind (index accessor-type) (and for-accessor-p all-applicable-and-sorted-p methods (accessor-values gf arg-info classes methods)) (values (if (integerp index) index emf) methods accessor-type index)))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) (accessor-class (case accessor-type (reader (car classes)) (writer (cadr classes)) (boundp (car classes))))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values1 (gf accessor-type accessor-class) (let* ((type `(class-eq ,accessor-class)) (types (if (eq accessor-type 'writer) `(t ,type) `(,type))) (methods (compute-applicable-methods-using-types gf types))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) (dolist (meth methods) (when (if (consp meth) (early-method-qualifiers meth) (method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) (early-p (not (eq *boot-state* 'complete))) (slot-name (when accessor-class (if (consp meth) (and (early-method-standard-accessor-p meth) (early-method-standard-accessor-slot-name meth)) (and (member *the-class-standard-object* (if early-p (early-class-precedence-list accessor-class) (class-precedence-list accessor-class))) (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) (standard-accessor-method-p meth)) (if early-p (early-accessor-method-slot-name meth) (accessor-method-slot-name meth)))))) (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) (when (eql slot-name (early-slot-definition-name slot)) (return slot))) (find-slot-definition accessor-class slot-name))))) (when (and slotd (or early-p (slot-accessor-std-p slotd accessor-type))) (values (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)) accessor-type)))) (defun make-accessor-table (gf type &optional table) (unless table (setq table (make-hash-table :test 'eq))) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf))) (all-index nil) (no-class-slots-p t) (early-p (not (eq *boot-state* 'complete))) first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} (dolist (method methods) (let* ((specializers (if (consp method) (early-method-specializers method t) (method-specializers method))) (specl (if (eq type 'reader) (car specializers) (cadr specializers))) (specl-cpl (if early-p (early-class-precedence-list specl) (and (class-finalized-p specl) (class-precedence-list specl)))) (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) (maphash #'(lambda (class slotd) (let ((cpl (if early-p (early-class-precedence-list class) (class-precedence-list class)))) (when (memq specl cpl) (unless (and (or so-p (member *the-class-standard-object* cpl)) (or early-p (slot-accessor-std-p slotd type))) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table))))) (gethash slot-name *name->class->slotd-table*)))) (maphash #'(lambda (class specl+slotd-list) (dolist (sclass (if early-p (early-class-precedence-list class) (class-precedence-list class)) (error "This can't happen")) (let ((a (assq sclass specl+slotd-list))) (when a (let* ((slotd (cdr a)) (index (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)))) (unless index (return-from make-accessor-table nil)) (setf (gethash class table) index) (when (consp index) (setq no-class-slots-p nil)) (setq all-index (if (or (null all-index) (eql all-index index)) index t)) (incf size) (cond ((= size 1) (setq first class)) ((= size 2) (setq second class))) (return nil)))))) table) (values table all-index first second size no-class-slots-p))) (defun compute-applicable-methods-using-types (generic-function types) (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function))) (let ((specls (if (consp method) (early-method-specializers method t) (method-specializers method))) (types types) (possibly-applicable-p t) (applicable-p t)) (dolist (specl specls) (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) (specializer-applicable-using-type-p specl (pop types)) (unless specl-applicable-p (setq applicable-p nil)) (unless specl-possibly-applicable-p (setq possibly-applicable-p nil) (return nil)))) (when possibly-applicable-p (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) (early-gf-arg-info generic-function) (gf-arg-info generic-function))))) (values (sort-applicable-methods precedence (nreverse possibly-applicable-methods) types) definite-p)))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods precedence #'(lambda (class1 class2 index) (let* ((class (type-class (nth index types))) (cpl (if (eq *boot-state* 'complete) (class-precedence-list class) (early-class-precedence-list class)))) (if (memq class2 (memq class1 cpl)) class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (declare (type function compare-classes-function)) (flet ((sorter (method1 method2) (dolist (index precedence) (let* ((specl1 (nth index (if (listp method1) (early-method-specializers method1 t) (method-specializers method1)))) (specl2 (nth index (if (listp method2) (early-method-specializers method2 t) (method-specializers method2)))) (order (order-specializers specl1 specl2 index compare-classes-function))) (when order (return-from sorter (eq order specl1))))))) (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) (declare (type function compare-classes-function)) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) (bootstrap-get-slot 'specializer specl1 'type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) (bootstrap-get-slot 'specializer specl2 'type)))) (cond ((eq specl1 specl2) nil) ((atom type1) specl2) ((atom type2) specl1) (t (case (car type1) (class (case (car type2) (class (funcall compare-classes-function specl1 specl2 index)) (t specl2))) (prototype (case (car type2) (class (funcall compare-classes-function specl1 specl2 index)) (t specl2))) (class-eq (case (car type2) (eql specl2) (class-eq nil) (class type1))) (eql (case (car type2) (eql nil) (t specl1)))))))) (defun map-all-orders (methods precedence function) (declare (type function function)) (let ((choices nil)) (flet ((compare-classes-function (class1 class2 index) (declare (ignore index)) (let ((choice nil)) (dolist (c choices nil) (when (or (and (eq (first c) class1) (eq (second c) class2)) (and (eq (first c) class2) (eq (second c) class1))) (return (setq choice c)))) (unless choice (setq choice (if (class-might-precede-p class1 class2) (if (class-might-precede-p class2 class1) (list class1 class2 nil t) (list class1 class2 t)) (if (class-might-precede-p class2 class1) (list class2 class1 t) (let ((name1 (class-name class1)) (name2 (class-name class2))) (if (and name1 name2 (symbolp name1) (symbolp name2) (string< (symbol-name name1) (symbol-name name2))) (list class1 class2 t) (list class2 class1 t)))))) (push choice choices)) (car choice)))) (loop (funcall function (sort-methods methods precedence #'compare-classes-function)) (unless (dolist (c choices nil) (unless (third c) (rotatef (car c) (cadr c)) (return (setf (third c) t)))) (return nil)))))) (defvar *in-precompute-effective-methods-p* nil) ;used only in map-all-orders (defun class-might-precede-p (class1 class2) (if (not *in-precompute-effective-methods-p*) (not (member class1 (cdr (class-precedence-list class2)))) (class-can-precede-p class1 class2))) (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) (defun saut-and (specl type) (let ((applicable nil) (possibly-applicable t)) (dolist (type (cdr type)) (multiple-value-bind (appl poss-appl) (specializer-applicable-using-type-p specl type) (when appl (return (setq applicable t))) (unless poss-appl (return (setq possibly-applicable nil))))) (values applicable possibly-applicable))) (defun saut-not (specl type) (let ((ntype (cadr type))) (values nil (case (car ntype) (class (saut-not-class specl ntype)) (class-eq (saut-not-class-eq specl ntype)) (prototype (saut-not-prototype specl ntype)) (eql (saut-not-eql specl ntype)) (t (error "~s cannot handle the second argument ~s" 'specializer-applicable-using-type-p type)))))) (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) (cpl (class-precedence-list class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) (eql (class-of (cadr specl))) (class-eq (cadr specl)) (prototype (cadr specl)) (class (cadr specl)))) (cpl (class-precedence-list class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) (eql (class-of (cadr specl))) (class-eq (cadr specl))))) (not (eq class (cadr ntype))))) (defun saut-not-eql (specl ntype) (case (car specl) (eql (not (eql (cadr specl) (cadr ntype)))) (t t))) (defun class-applicable-using-class-p (specl type) (let ((pred (memq specl (if (eq *boot-state* 'complete) (class-precedence-list type) (early-class-precedence-list type))))) (values pred (or pred (if (not *in-precompute-effective-methods-p*) ;; classes might get common subclass (superclasses-compatible-p specl type) ;; worry only about existing classes (classes-have-common-subclass-p specl type)))))) (defun classes-have-common-subclass-p (class1 class2) (or (eq class1 class2) (let ((class1-subs (class-direct-subclasses class1))) (or (memq class2 class1-subs) (dolist (class1-sub class1-subs nil) (when (classes-have-common-subclass-p class1-sub class2) (return t))))))) (defun saut-class (specl type) (case (car specl) (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) (memq (cadr type) (class-precedence-list class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) (values nil (eq (class-of (cadr specl)) (cadr type))) (let ((pred (case (car specl) (class-eq (eq (cadr specl) (cadr type))) (class (or (eq (cadr specl) (cadr type)) (memq (cadr specl) (if (eq *boot-state* 'complete) (class-precedence-list (cadr type)) (early-class-precedence-list (cadr type))))))))) (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) (values nil nil)) ; fix this someday (defun saut-eql (specl type) (let ((pred (case (car specl) (eql (eql (cadr specl) (cadr type))) (class-eq (eq (cadr specl) (class-of (cadr type)))) (class (memq (cadr specl) (let ((class (class-of (cadr type)))) (if (eq *boot-state* 'complete) (class-precedence-list class) (early-class-precedence-list class)))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) (setq specl (type-from-specializer specl)) (when (eq specl 't) (return-from specializer-applicable-using-type-p (values t t))) ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, ;; and has only what they need. (if (or (atom type) (eq (car type) 't)) (values nil t) (case (car type) (and (saut-and specl type)) (not (saut-not specl type)) (class (saut-class specl type)) (prototype (saut-prototype specl type)) (class-eq (saut-class-eq specl type)) (eql (saut-eql specl type)) (t (error "~s cannot handle the second argument ~s" 'specializer-applicable-using-type-p type))))) (defun map-all-classes (function &optional (root 't)) (declare (type function function)) (let ((braid-p (or (eq *boot-state* 'braid) (eq *boot-state* 'complete)))) (labels ((do-class (class) (mapc #'do-class (if braid-p (class-direct-subclasses class) (early-class-direct-subclasses class))) (funcall function class))) (do-class (if (symbolp root) (find-class root) root))))) ;;; ;;; NOTE: We are assuming a restriction on user code that the method ;;; combination must not change once it is connected to the ;;; generic function. ;;; ;;; This has to be legal, because otherwise any kind of method ;;; lookup caching couldn't work. See this by saying that this ;;; cache, is just a backing cache for the fast cache. If that ;;; cache is legal, this one must be too. ;;; ;;; Don't clear this table! (defvar *effective-method-table* (make-hash-table :test 'eq)) (defun get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods types (not (null method-alist)) (not (null wrappers)) (not (methods-contain-eql-specializer-p methods))) method-alist wrappers)) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p &optional all-applicable-p (all-sorted-p t) function-p) (if (null methods) (if function-p #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) (fin-lambda-fn (&rest args) (apply #'no-applicable-method gf args))) #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) #'(lambda (&rest args) (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) (cons nil nil))))) (if (and (null (cdr methods)) all-applicable-p ; the most common case (null method-alist-p) wrappers-p (not function-p)) (or (car ht-value) (setf (car ht-value) (get-secondary-dispatch-function2 gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p))) (let ((akey (list methods (if all-applicable-p 'all-applicable types) method-alist-p wrappers-p function-p))) (or (cdr (assoc akey (cdr ht-value) :test #'equal)) (let ((value (get-secondary-dispatch-function2 gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p))) (push (cons akey value) (cdr ht-value)) value))))))) (defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) (make-effective-method-function1 gf effective method-alist-p wrappers-p)) (let ((effective (standard-compute-effective-method gf nil methods))) (make-effective-method-function1 gf effective method-alist-p wrappers-p))) (let ((net (generate-discrimination-net gf methods types all-sorted-p))) (compute-secondary-dispatch-function1 gf net function-p)))) (defun get-effective-method-function (gf methods &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods nil (not (null method-alist)) (not (null wrappers)) t) method-alist wrappers)) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) (defun methods-contain-eql-specializer-p (methods) (and (eq *boot-state* 'complete) (dolist (method methods nil) (when (dolist (spec (method-specializers method) nil) (when (eql-specializer-p spec) (return t))) (return t))))) (defun update-dfun (generic-function &optional dfun cache info) (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p (early-gf-name generic-function) (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) (let* ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function))) (info (gf-dfun-info generic-function))) (unless (eq 'default-method-only (type-of info)) (setq dfun (doctor-dfun-for-the-debugger generic-function #+cmu dfun #-cmu (set-function-name dfun gf-name)))) (set-funcallable-instance-function generic-function dfun) #+cmu (set-function-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) (defvar dfun-count nil) (defvar dfun-list nil) (defvar *minimum-cache-size-to-list*) (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym dfun-list))) (unless a (push (setq a (list sym)) dfun-list)) (push (generic-function-name gf) (cdr a)))) (defun list-all-dfuns () (setq dfun-list nil) (map-all-generic-functions #'list-dfun) dfun-list) (defun list-large-cache (gf) (let* ((sym (type-of (gf-dfun-info gf))) (cache (gf-dfun-cache gf))) (when cache (let ((size (cache-size cache))) (when (>= size *minimum-cache-size-to-list*) (let ((a (assoc size dfun-list))) (unless a (push (setq a (list size)) dfun-list)) (push (let ((name (generic-function-name gf))) (if (eq sym 'caching) name (list name sym))) (cdr a)))))))) (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq dfun-list nil) (map-all-generic-functions #'list-large-cache) (setq dfun-list (sort dfun-list #'< :key #'car)) (mapc #'print dfun-list) (values)) (defun count-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (cache (gf-dfun-cache gf)) (a (assq sym dfun-count))) (unless a (push (setq a (list sym 0 nil)) dfun-count)) (incf (cadr a)) (when cache (let* ((size (cache-size cache)) (b (assoc size (third a)))) (unless b (push (setq b (cons size 0)) (third a))) (incf (cdr b)))))) (defun count-all-dfuns () (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil)) '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY ONE-INDEX N-N CHECKING CACHING DISPATCH))) (map-all-generic-functions #'count-dfun) (mapc #'(lambda (type+count+sizes) (setf (third type+count+sizes) (sort (third type+count+sizes) #'< :key #'car))) dfun-count) (mapc #'(lambda (type+count+sizes) (format t "~&There are ~4d dfuns of type ~s" (cadr type+count+sizes) (car type+count+sizes)) (format t "~% ~S~%" (caddr type+count+sizes))) dfun-count) (values)) (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) (map-all-generic-functions #'(lambda (gf) (when (memq (type-of (gf-dfun-info gf)) type) (push gf gf-list)))) gf-list)) gcl-2.6.14/pcl/.gitignore0000644000175000017500000000002114360276512013532 0ustar cammcamm*.c *.h *gazonk* gcl-2.6.14/git.tag0000644000175000017500000000002214360276512012245 0ustar cammcamm"Version_2_6_14" gcl-2.6.14/readme.xgcl0000644000175000017500000000574614360276512013123 0ustar cammcammxgcl is an interface from Gnu Common Lisp to the X library, Xlib. This software provides a lightweight and fairy easy-to-use way to: * Draw diagrams from Lisp * Create interactive graphical interfaces * Make the interactive Lisp interfaces available via the Web Beginning with release 2.6.8, xgcl is built into the make of GCL. There is a "raw" interface to the Xlib, and an "easy-to-use" interface built on top of it; we will only discuss the "easy-to-use" version. To use xgcl, start GCL and enter: (xgcl) This will load xgcl and print a message inviting you to try (xgcl-demo). (xgcl-demo) will create a small window and draw some examples in it. You can try (wtestc), (wtestd), ... (wtestk) to try some other things. The xgcl files are located in the directory xgcl-2/ relative to the GCL directory. The file gcl_dwtest.lsp contains the test examples; one way to get started quickly is by using this file for examples. There is also documentation: dwdoc.tex dwdoc.dvi dwdoc.html http://www.cs.utexas.edu/users/novak/dwdoc.html dwdoc.pdf dwdoc.ps To use the basic xgcl, you only need to invoke (xgcl). To use some of the more advanced features such as menu-set, described below, also load the file gcl_dwimportsb.lsp immediately after invoking (xgcl), to import symbols. Additional files that may be useful: gcl_menu-set.lsp Source and some comments for menu-set gcl_menu-settrans.lsp menu-set translated to Common Lisp gcl_pcalc.lsp Pocket calculator example gcl_draw-gates.lsp Draw boolean gate symbols gcl_draw.lsp Interactive drawing program source gcl_drawtrans.lsp Drawing program translated to Common Lisp gcl_dwindow.lsp Easy-to-use interface source with comments gcl_dwtrans.lsp Easy-to-use interface translated to Common Lisp gcl_editors.lsp Editors for colors etc. gcl_editorstrans.lsp Editors translated to Common Lisp gcl_ice-cream.lsp Example created using Draw lispserver.lsp Example web demo: a Lisp server lispservertrans.lsp Lisp server translated to Common Lisp Xakcl.paper Documentation on the "raw" Xlib interface Xakcl.example.lsp some PRIMITIVE examples This software provides a way to interface Lisp programs to the Web; see: http://www.cs.utexas.edu/users/novak/dwindow.html There are two ways to accomplish a Web interface. The first uses X directly, and requires that the user have an X server; this is reliable and fast, but it only works for the Linux/Mac/Cygwin subset of the world. There can also be firewall issues. The other option uses WeirdX, an X server written in Java. The WeirdX interface is often slow, and sometimes doesn't work at all, but when it works, it works with any web browser, even on Windows. The WeirdX interface tends to leave "mouse droppings" on interactive drawings. There are numerous examples of these web interfaces at: http://www.cs.utexas.edu/users/novak/ The Draw demo is a good one to try. gcl-2.6.14/makefile0000644000175000017500000002743714360276512012510 0ustar cammcamm# Compiling gcl: # ./configure # make # For more details see the file readme prefix=/usr/local # This would cause make install to create /usr/local/bin/gcl and # /usr/local/lib/gcl-x.yy/* with some basic files. # This prefix may be overridden e.g. with # ./configure --prefix=/usr/share # Allow platform defs file to override this. TK_LISP_LIB=gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/decode.tcl gcl-tk/demos/*.lsp gcl-tk/demos/*.lisp gcl-tk/demos/*.o TCL_EXES=gcl-tk/gcl.tcl gcl-tk/gcltkaux$(EXE) GCL_DVI=gcl-tk.dvi gcl-si.dvi gcl.dvi GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html -include makedefs BINDIR = bin HDIR = h/ CDIR = c ODIR = o LSPDIR = lsp CMPDIR = cmpnew PORTDIR = unixport CLCSDIR = clcs PCLDIR = pcl MPDIR = mp TESTDIR = ansi-tests #GMP_DIR = gmp3/ VERSION=`cat majvers`.`cat minvers` all: $(BUILD_BFD) system command cmpnew/gcl_collectfn.o lsp/gcl_info.o do-gcl-tk release do-info ASRC:=$(shell ls -1 o/*.c lsp/*.lsp cmpnew/*.lsp pcl/*sp clcs/*sp xgcl-2/*p) #o/*.d o/*.h h/*.h TAGS: $(ASRC) etags --regex='/\#.`(defun[ \n\t]+\([^ \n\t]+\)/' $^ system: $(PORTDIR)/$(FLISP) # [ "$(X_LIBS)" == "" ] || (cd xgcl-2 && make saved_xgcl LISP=../$< && mv saved_xgcl ../$(PORTDIR)/$(FLISP)) touch $@ release: majvers minvers date >$@ xgcl: $(PORTDIR)/saved_xgcl $(PORTDIR)/saved_xgcl: $(PORTDIR)/saved_gcl cd xgcl-2 && $(MAKE) #binutils/intl/libintl.a: # cd $(@D) && $(MAKE) #binutils/bfd/libbfd.a binutils/libiberty/libiberty.a: binutils/intl/libintl.a # cd $(@D) && $(MAKE) copy_iberty: $(LIBIBERTY) mkdir -p binutils/libiberty && cd binutils/libiberty && ar x $< copy_bfd: $(LIBBFD) copy_iberty mkdir -p binutils/bfd && cd binutils/bfd && ar x $< #h/bfd.h: binutils/bfd/libbfd.a binutils/libiberty/libiberty.a # cp $(&1 |tee $(@F) & j=$$! ; \ tail -f --pid=$$j --retry $@ & wait $$j #$(PCLDIR)/saved_gcl_pcl: $(PORTDIR)/saved_gcl # cd $(@D) && $(MAKE) compile LISP="../$<" && $(MAKE) $(@F) LISP="../$<" #$(CLCSDIR)/saved_full_gcl: $(PCLDIR)/saved_gcl_pcl # cd $(@D) && $(MAKE) compile LISP="../$<" && $(MAKE) $(@F) LISP="../$<" #$(PORTDIR)/saved_ansi_gcl: $(CLCSDIR)/saved_full_gcl # cd $(@D) && $(MAKE) $(@F) cmpnew/gcl_collectfn.o lsp/gcl_info.o: cd $(@D) && $(MAKE) $(@F) do-gcl-tk: if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ cd gcl-tk && $(MAKE) ; \ else \ echo "gcl-tk not made..missing include or lib" ; \ fi do-info: cd info && $(MAKE) mpfiles: $(MPFILES) $(MPDIR)/libmport.a: (cd mp ; $(MAKE) all) $(GMPDIR)/libgmp.a: $(GMPDIR)/Makefile cd $(GMPDIR) && $(MAKE) && rm -f libgmp.a && ar qc libgmp.a *.o */*.o PWD_CMD?=pwd gmp_all: $(GMPDIR)/Makefile cd $(GMPDIR) && echo '#include ' >> gmp.h && echo "#include \"`$(PWD_CMD)`/../h/prelink.h\"" >> gmp.h && $(MAKE) touch $@ $(GMPDIR)/mpn/mul_n.o $(GMPDIR)/mpn/lshift.o $(GMPDIR)/mpn/rshift.o: $(GMPDIR)/Makefile cd $(@D) && $(MAKE) $(@F) command: rm -f bin/gcl xbin/gcl MGCLDIR=`echo $(GCLDIR) | sed -e 'sX^\([a-z]\):X/\1Xg'` ; \ GCLDIR=`echo $(GCLDIR)` ; \ $(MAKE) install-command "INSTALL_LIB_DIR=$$GCLDIR" "prefix=$$GCLDIR" "BINDIR=$$MGCLDIR/$(PORTDIR)" (cd xbin ; cp ../bin/gcl .) # GCLDIR=`echo $(GCLDIR) | sed -e 'sX^/cygdrive/\([a-z]\)X\1!Xg' -e 'sX^//\([a-z]\)X\1!Xg'` ; \ merge: $(CC) -o merge merge.c LISP_LIB=cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp xgcl-2/package.lisp pcl/package.lisp clcs/package.lisp xgcl-2/sysdef.lisp xgcl-2/gcl_dwtest.lsp xgcl-2/gcl_dwtestcases.lsp lsp/gcl_gprof.lsp lsp/gcl_info.o lsp/gcl_profile.lsp lsp/gcl_export.lsp lsp/gcl_autoload.lsp cmpnew/gcl_cmpmain.lsp cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp lsp/gcl_auto_new.lsp h/cmpinclude.h unixport/sys_init.lsp unixport/lib$(SYSTEM).a unixport/libgclp.a gcl-tk/tk-package.lsp $(TK_LISP_LIB) $(RL_LIB) $(FIRST_FILE) $(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew xgcl-2 pcl clcs) unixport/gcl.script install-command: rm -f $(DESTDIR)$(prefix)/bin/gcl (echo '#!/bin/sh' ; \ echo exec $(BINDIR)/$(FLISP)$(EXE) \\ ; \ echo ' -dir' $(INSTALL_LIB_DIR)/unixport/ \\ ; \ echo ' -libdir' $(INSTALL_LIB_DIR)/ \\ ; \ echo ' -eval '\''(setq si::*allow-gzipped-file* t)'\' \\ ;\ ! [ -d "$(TK_CONFIG_PREFIX)" ] || echo ' -eval '\''(setq si::*tk-library* '\"$(TK_LIBRARY)\"')'\' \\;\ echo ' '\"\$$@\" ) > $(DESTDIR)$(prefix)/bin/gcl; echo '#' other options: -load "/tmp/foo.o" -load "jo.lsp" -eval '"(joe 3)"' >> $(DESTDIR)$(prefix)/bin/gcl chmod a+x $(DESTDIR)$(prefix)/bin/gcl rm -f $(DESTDIR)$(prefix)/bin/gclm.bat if gcc --version | grep mingw >/dev/null 2>&1 ; then (echo '@SET cd='; \ echo '@SET promp$=%prompt%'; \ echo '@PROMPT SET cd$Q$P'; \ echo '@CALL>%temp%.\setdir.bat'; \ echo '@'; \ echo '% do not delete this line %'; \ echo '@ECHO off'; \ echo 'PROMPT %promp$%'; \ echo 'FOR %%c IN (CALL DEL) DO %%c %temp%.\setdir.bat'; \ echo 'set cwd=%cd%'; \ echo 'set libdir=%cd%\..\lib\gcl-$(VERSION)'; \ echo 'set unixportdir=%libdir%\unixport'; \ echo 'path %cd%\..\mingw\bin;%PATH%'; \ echo "start %unixportdir%\$(FLISP).exe -dir %unixportdir% -libdir %libdir% -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9" ) > $(DESTDIR)$(prefix)/bin/gclm.bat ; fi rm -f $(DESTDIR)$(prefix)/bin/gclfinal.bat if gcc --version | grep -i mingw >/dev/null 2>&1 ; then (echo 'ECHO path %1\mingw\bin;%PATH% > gcli.bat'; \ echo "ECHO start %1\lib\gcl-$(VERSION)\unixport\$(FLISP).exe -dir %1\lib\gcl-$(VERSION)\unixport -libdir %1\lib\gcl-$(VERSION) -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9 >> gcli.bat" ) > $(DESTDIR)$(prefix)/bin/gclfinal.bat ; fi install: $(MAKE) install1 "INSTALL_LIB_DIR=$(prefix)/lib/gcl-`cat majvers`.`cat minvers`" "prefix=$(prefix)" "DESTDIR=$(DESTDIR)" INSTALL_LIB_DIR= install1: mkdir -p $(DESTDIR)$(prefix)/lib mkdir -p $(DESTDIR)$(prefix)/bin mkdir -p $(DESTDIR)$(prefix)/share cp -a man $(DESTDIR)$(prefix)/share/ mkdir -p $(DESTDIR)$(INSTALL_LIB_DIR) MINSTALL_LIB_DIR=`echo $(INSTALL_LIB_DIR) | sed -e 'sX^\([a-z]\):X/\1Xg'` ; \ $(MAKE) install-command "INSTALL_LIB_DIR=$(INSTALL_LIB_DIR)" "prefix=$(prefix)" "DESTDIR=$(DESTDIR)" "BINDIR=$$MINSTALL_LIB_DIR/unixport" rm -f $(DESTDIR)$(prefix)/bin/gcl.exe tar cf - $(PORTDIR)/$(FLISP)$(EXE) info/*.info* $(LISP_LIB) \ $(TCL_EXES) | (cd $(DESTDIR)$(INSTALL_LIB_DIR) ;tar xf -) if gcc --version | grep -i mingw >/dev/null 2>&1 ; then if grep -i oncrpc makedefs >/dev/null 2>&1 ; then cp /mingw/bin/oncrpc.dll $(DESTDIR)$(INSTALL_LIB_DIR)/$(PORTDIR); fi ; fi cd $(DESTDIR)$(INSTALL_LIB_DIR)/$(PORTDIR) && \ mv $(FLISP)$(EXE) temp$(EXE) && \ echo '(si::reset-sys-paths "$(INSTALL_LIB_DIR)/")(si::save-system "$(FLISP)$(EXE)")' | ./temp$(EXE) && \ rm -f temp$(EXE) if [ -e "unixport/rsym$(EXE)" ] ; then cp unixport/rsym$(EXE) $(DESTDIR)$(INSTALL_LIB_DIR)/unixport/ ; fi # ln $(SYMB) $(INSTALL_LIB_DIR)/$(PORTDIR)/$(FLISP)$(EXE) \ # $(DESTDIR)$(prefix)/bin/gcl.exe if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ cat gcl-tk/gcltksrv$(BAT) | \ sed -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=$(INSTALL_LIB_DIR)/gcl-tk!g" \ -e "s!TK_LIBRARY=.*!TK_LIBRARY=$(TK_LIBRARY)!g" > \ $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/gcltksrv$(BAT) ; \ chmod a+x $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/gcltksrv$(BAT) ; fi # if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ # (cd $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/demos ; \ # echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' | ../../$(PORTDIR)/$(FLISP)$(EXE)) ; fi if test "$(EMACS_SITE_LISP)" != "" ; then (cd elisp ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi if test "$(INFO_DIR)" != "unknown"; then (cd info ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi if test "$(INFO_DIR)" != "unknown"; then (cd xgcl-2 ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp COPYING.LIB-2.0 readme-bin.mingw $(prefix) ; fi if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp gcl.ico $(prefix)/bin ; fi if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/install; mkdir $(prefix)/install ; cp windows/install.lsp $(prefix)/install ; windows/instdos.sh windows/sysdir.bat $(prefix)/bin/sysdir.bat ; fi -if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/doc; mkdir $(prefix)/doc; cp info/*.html $(prefix)/doc ; fi -if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/doc; mkdir $(prefix)/doc; cp -rp info/gcl info/gcl-si info/gcl-tk $(prefix)/doc ; fi gclclean: (cd $(BINDIR); $(MAKE) clean) (cd mp ; $(MAKE) clean) (cd $(ODIR); $(MAKE) clean) (cd $(LSPDIR); $(MAKE) clean) (cd $(CMPDIR); $(MAKE) clean) (cd $(PORTDIR); $(MAKE) clean) (cd gcl-tk ; $(MAKE) clean) cd $(CLCSDIR) && $(MAKE) clean cd $(PCLDIR) && $(MAKE) clean cd xgcl-2 && $(MAKE) clean (cd $(TESTDIR); $(MAKE) clean) (cd info ; $(MAKE) clean) # find binutils -name "*.o" -exec rm {} \; rm -rf binutils rm -f foo.tcl config.log makedefs makedefsafter config.cache config.status makedefc rm -f h/config.h h/gclincl.h h/cmpinclude.h h/gmp.h rm -f xbin/gcl foo foo.c bin/gclm.bat gmp_all rm -f h/*-linux.defs h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h rm -f windows/gcl.iss bin/gcl.bat windows/gcl.ansi.iss windows/install.ansi.lsp \ windows/install.lsp windows/sysdir.bat rm -rf windows/Output rm -f ansi-tests/test_results ansi-tests/gazonk*lsp rm -rf autom4te.cache h/mcompdefs.h rm -f config.log config.cache config.status tmpx $(PORTDIR)/gmon.out gcl.script machine system clean: gclclean -[ -z "$(GMPDIR)" ] || (cd $(GMPDIR) && $(MAKE) distclean) -[ -z "$(GMPDIR)" ] || rm -rf $(GMPDIR)/.deps $(GMPDIR)/libgmp.a # -cd binutils/intl && $(MAKE) distclean # -cd binutils/bfd && $(MAKE) distclean # -cd binutils/libiberty && $(MAKE) distclean CMPINCLUDE_FILES=$(HDIR)cmpincl1.h $(HDIR)gclincl.h $(HDIR)compbas.h $(HDIR)type.h $(HDIR)mgmp.h \ $(HDIR)lu.h $(HDIR)globals.h $(HDIR)vs.h \ $(HDIR)bds.h $(HDIR)frame.h \ $(HDIR)lex.h \ $(HDIR)compprotos.h $(HDIR)immnum.h OTHERS=$(HDIR)notcomp.h $(HDIR)rgbc.h $(HDIR)stacks.h $(HDIR)new_decl.h: (cd o && $(MAKE) ../$@) $(HDIR)mcompdefs.h: $(HDIR)compdefs.h $(HDIR)new_decl.h cat $< |\ $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"cmponly.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' |\ $(CC) -E -P -I./$(HDIR) - |\ $(AWK) '/^\-\-\-$$/ {i=1;next} {if (!i) next} {gsub("\"","");print}' >$@ $(HDIR)cmpinclude.h: $(HDIR)mcompdefs.h $(CMPINCLUDE_FILES) $(HDIR)config.h cp $< $(@F) cat $(CMPINCLUDE_FILES) | $(CC) -E -I./$(HDIR) - | $(AWK) '/^# |^$$|^#pragma/ {next}{print}' >> $(@F) ./xbin/move-if-changed mv $(@F) $@ ./xbin/move-if-changed cp $@ o/$(@F) go: mkdir go (cd go ; cp -s ../o/makefile ../o/*.o ../o/*.c ../o/*.d ../o/*.ini .) (cd go ; $(MAKE) go) tar: rm -f gcl-`cat majvers`.`cat minvers` xbin/distribute ../ngcl-`cat majvers`.`cat minvers`-beta.tgz configure: configure.in autoconf configure.in > configure chmod a+rx configure kcp: (cd go ; $(MAKE) "CFLAGS = -I../h -pg -c -g ") (cd unixport ; $(MAKE) gcp) .INTERMEDIATE: $(HDIR)mcompdefs.h gcl-2.6.14/makedefc.in0000644000175000017500000000256014360276512013065 0ustar cammcamm # begin makedefs # use=@use@ # for main link of raw_gcl LIBS=@LIBS@ # root for the installation, eg /usr/local # This would cause make install to create /usr/local/bin/gcl and # /usr/local/lib/gcl-2-??/* with some basic files. prefix=@prefix@ # where to place the info files INFO_DIR=@INFO_DIR@ # where to put emacs lisp files. EMACS_SITE_LISP=@EMACS_SITE_LISP@ # the default.el file EMACS_DEFAULT_EL=@EMACS_DEFAULT_EL@ # numerous TCL/TK variables culled from the tkConfig.sh and tclConfig.sh # if these are found. TK_CONFIG_PREFIX=@TK_CONFIG_PREFIX@ TK_LIBRARY=@TK_LIBRARY@ TCL_LIBRARY=@TCL_LIBRARY@ TK_XINCLUDES=@TK_XINCLUDES@ TK_INCLUDE=@TK_INCLUDE@ TCL_INCLUDE=@TCL_INCLUDE@ TK_LIB_SPEC=@TK_LIB_SPEC@ TK_BUILD_LIB_SPEC=@TK_BUILD_LIB_SPEC@ TK_XLIBSW=@TK_XLIBSW@ TK_XINCLUDES=@TK_XINCLUDES@ TCL_LIB_SPEC=@TCL_LIB_SPEC@ TCL_DL_LIBS=@TCL_DL_LIBS@ TCL_LIBS=@TCL_LIBS@ PRELINK_CHECK=@PRELINK_CHECK@ NOTIFY=@NOTIFY@ CC=@CC@ GCL_CC=@GCL_CC@ CFLAGS=@CFLAGS@ LDFLAGS=@LDFLAGS@ FINAL_CFLAGS=@FINAL_CFLAGS@ NIFLAGS=@NIFLAGS@ O3FLAGS=@O3FLAGS@ O2FLAGS=@O2FLAGS@ RL_OBJS=@RL_OBJS@ RL_LIB=@RL_LIB@ MAKEINFO=@MAKEINFO@ FLISP=@FLISP@ SYSTEM=@SYSTEM@ BUILD_BFD=@BUILD_BFD@ GMPDIR=@GMPDIR@ X_LIBS=@X_LIBS@ X_CFLAGS=@X_CFLAGS@ PROCESSOR_FLAGS=@PROCESSOR_FLAGS@ EXTRA_LOBJS=@EXTRA_LOBJS@ LEADING_UNDERSCORE=@LEADING_UNDERSCORE@ GNU_LD=@GNU_LD@ AWK=@AWK@ LIBBFD=@LIBBFD@ LIBIBERTY=@LIBIBERTY@ gcl-2.6.14/comp/0000755000175000017500000000000014360276512011731 5ustar cammcammgcl-2.6.14/comp/top2.lsp0000755000175000017500000007713214360276512013352 0ustar cammcamm(in-package "BCOMP") ;; pass 2 c compilation (eval-when (compile eval load) (defparameter *pass-2-vars* '( *address-vector* ;; At load time the index in *cfun-addresses* ;; will be the address of the function. This *address-vector* is used ;; at the end to create this vector in the .h file. *next-data* ;; is the next data index available *next-label* ;; is next label available number *next-function* ;; next function number as `3' in L3 *blocks* ;; number of '{' we have nested using open-block *next-cvar* ;; is next c variable number *file-inline-templates* *local-funs* ;; are extra-local-funs to do *local-inline-templates* ;; inline templates *top-level-closure-vars* ;; call links. *links* ;; alist of forms to eval at load time and put in constant vector. *load-time-forms* ;; if not nil open a block *do-pending-open* )) (proclaim (cons 'special *pass-2-vars*)) ) (defun vararg-p (fd) (let ((ll (fdata-ll fd))) (or (ll &optional ll) (ll &rest ll) (ll &key ll)))) (eval-when (load compile eval) (defvar *illegal-names* (make-hash-table :size 100 :test 'equal)) (unless ; (gethash "case" *illegal-names*) (dolist (v'(;;C reserved words: "do" "for" "sizeof" "typedef" "extern" "static" "auto" "register" "void" "char" "short" "int" "long" "float" "double" "signed" "unsigned" "struct" "union" "enum" "const" "volatile" "case" "default" "if" "else" "switch" "while" "do" "for" "goto" "continue" "break" ;;varargs "va_start" "va_end" "va_list" "va_dcl" "va_alist" "stdin" "stdout" "inline" ;lisp specific: "length" "elt" "object" "car" "cdr" "list" "number_plus" "number_times" "bool" fixnum" shortfloat" "doublefloat" )) (setf (gethash v *illegal-names*) t))) (defvar *use-mangled-names* t) (defvar *used-names* ;; bound by lets and constructions which bind variables nil) (defun mangle-name (name name-type &aux p) ;; NAME is a symbol which we wish to mangle, and name-type is ;; 'var or 'function. (cond ((or (null *use-mangled-names*) (null name) (null (setq p (symbol-package name)))) (cond ((eq name-type 'var) *next-cvar*) ((eq name-type 'function) (incf *next-function*)) (t (incf *next-cvar*)))) (t (or (eq name-type 'var) (setq p (get-package-shortname p))) (let ((v (mangle name))) (cond ((eq name-type 'var) (do ((i 0) (w v (setq w (format nil "V~a~a" (incf i) v)))) ((not (or (gethash w *illegal-names*) (member w *used-names* :test 'equal))) (setq w (copy-seq w)) (Push w *used-names*) w))) (t (si::string-concatenate (cond ((eq name-type 'function) "f") ((eq name-type 'symbol) "s") (t "u")) p v ))))))) (defvar *package-names* nil) (defun get-package-shortname (x) (or *package-names* (setq *package-names* `((,(find-package "LISP") . "L") (,(find-package "SYSTEM") . "S") (,(find-package "KEYWORD") . "K")))) (let ((tem (cdr (assoc x *package-names*)))) (cond (tem tem) (t (let((na (or (car (package-nicknames x)) (package-name x)))) (setq na (mangle (string-downcase na))) (if (rassoc na *package-names*) (error "You need to add another nickname: ~a is in use" na)) (setq na (copy-seq na)) (push (cons x na) *package-names*) na))))) (defun next-cvar (&optional v &aux name) (let ((n (incf *next-cvar*))) (cond ((null v) n) ((consp v) (setf (second v) n) v) ((typep v 'var) (cond ((var-special-p v) (setf (var-special-p v) n)) (t (setq name (var-name v)) (setf (var-ind v) (if (and name (symbol-package name)) (copy-seq (mangle-name name 'var)) n))))) (t (wfs-error))))) (defun next-label() (incf *next-label*)) (proclaim (cons 'special *pass-2-vars*)) (defun execute-pass-2 ( &aux (top *top-forms*) ) (let #.*pass-2-vars* (setq *next-data* 0 *next-label* 0 *next-function* 0 *address-vector* (make-array 30 :adjustable t :fill-pointer 0)) (terpri *c-output*) (wr " #include \"cmpinclude.h\" #include \"" (pathname-name *h-output*) ".h\"") (wr " init_code(){IdoInit(sizeof(VV)/sizeof(char *),VV);} ") (sloop for v in top do (do-one-pass-2 v)) (write-out-links) (write-out-address-and-data) (terpri *h-output*) (wr-nl "") ; (print *data*) )) (defun do-one-pass-2 (x &aux df *local-funs* fd) (cond ((consp x) (cond ((and (symbolp (car x)) (setq fd (get (car x) 'e2))) (funcall fd x)) (t (wfs-error)))) ((typep x 'top-form) (cond ((top-form-funp x) (setq df (add-dummy-fun (top-form-walked x)))) (t (push-data 'd_eval_skip (top-form-lisp x))))) (t (wfs-error))) (dolist (v *local-funs*) (do-one-pass-2 v)) (when df (push-data 'd_eval_skip `(si::invoke ,df)))) (proclaim '(ftype (function () t) dummy-top)) (defun add-dummy-fun (x &aux ans) ;; create a simple C function of no args which invokes the ;; lisp form x in compiled form. returns the integer index ;; of the *function-addresses* array where the C function's address resides. (setq ans`(lambda-block ,(make-fun-data 'dummy-top nil nil nil nil x nil))) (setf (fdata-ind (second ans)) (incf *next-function*)) (e2-write-top (make-top-form :walked ans :funp t)) (push-address (second ans)) ) (defun car-get (x flag) (and (consp x) (symbolp (car x)) (get (car x) flag))) (setf (get 'write-top 'e2) 'e2-write-top) (defun e2-write-top (x &aux fd) ;(print x) ; for (lambda #S(fdata ..)) ; sets the ind in #s(fdata ) and writes out the definition. ; writes out the L20() { ..} ; side .. (cond ((and (typep x 'top-form) (setq fd (car-get (top-form-walked x) 'e2))) (return-from e2-write-top (funcall fd (top-form-walked x))))) (unless (and (consp x) (symbolp (car x))) (wfs-error)) (cond ((setq fd (get (car x) 'e2)) (funcall fd x)) (t (wfs-error))) ) ;; writing out the .data file: ;; each time something in *data-table* is first referenced we assign ;; an index and put it in *data*. This normally happens while a function ;; definition (and its local functions) are being written out. After ;; that is written out (so all its constants are looked after) we push ;; the (d_eval_skip (fset argd function-address-index "docstring")) (setf (get 'si::fset 'e2) 'e2fset) (setf (get 'mset 'e2) 'e2fset) (defun push-address (x) (let ((n (fill-pointer *address-vector*))) (vector-push-extend x *address-vector*) n)) (defun link-descriptor-from-decl (argl ret &aux (atypes 0) saw-optional (min 0) (max 0) ) (declare (fixnum min max atypes)) (sloop for v in-list argl when (eq v '&optional) do (setq saw-optional t) else when (member v '#. (cons '* lambda-list-keywords)) do (setq max 63) (return nil) else do ; (if (eq v 'short-float) (setq v 'double-float)) (unless saw-optional (incf min)) (incf max) (cond ((< max 7) (setq atypes (+ atypes (the fixnum (ash (arg-type-code (promote-arg-type v)) (the fixnum (* max 2))))) )))) ;; set the return type: (setq atypes (logior atypes (arg-type-code (promote-arg-type ret)))) (let ((res 0)) (declare (fixnum res)) (setf res (make-argd min max atypes)) (or (eql max min) (setf (argd-flag-p res requires-nargs) t)) (when (or (eql ret '*)(and (consp ret)(eq (car ret) 'values))) (setf (argd-flag-p res sets-mv) t)) res)) (defun make-argd (min max atypes &aux (result 0)) (declare (fixnum min max atypes result)) (setf (argd-minargs result) min) (setf (argd-maxargs result) max) (setf (argd-atypes result) atypes) result) (defun describe-argd (argd) (format t "~%min=~a,max=~a,atypes=~a,arg-types=~a,ret=~a flags[set-mv=~a, requires-nargs=~a,requires-fun-passed=~a " (argd-minargs argd) (argd-maxargs argd) (argd-atypes argd) (argl-from-argd argd) (ret-from-argd argd) (argd-flag-p argd sets-mv) (argd-flag-p argd requires-nargs) (argd-flag-p argd requires-fun-passed))) ;(defstruct arg-stepper (atype 0 :type fixnum)) ;(defvar *arg-stepper* (make-arg-stepper)) ; ;(defun init-arg-stepper (argd) (setf (arg-stepper-atype *arg-stepper*) ; (argd-atypes (the fixnum argd))) ; nil) ; ;(defun next-arg-type () ; (let* ((a (arg-stepper-atype *arg-stepper*)) ; (res (aref *promoted-arg-types* (the fixnum (logand a 3))))) ; (setf a (ash a -2)) ; (setf (arg-stepper-atype *arg-stepper*) a) ; res)) (defun argl-from-argd (argd &aux ans) (declare (fixnum argd)) (let ((atypes (argd-atypes argd)) (min (argd-minargs argd)) (max (argd-maxargs argd)) (i 0)) (declare (fixnum atypes min max i)) (sloop while (<= i 7) do (setq atypes (ash atypes -2)) (cond ((and (>= i min) (eql atypes 0)) (if (< i max) (push '* ans)) (return nil)) ((eql i min) (push '&optional ans))) (push (aref *promoted-arg-types* (logand atypes 3)) ans) (setq i (+ i 1))) (or (eq (car ans) '*) (<= max 7) (push '* ans)) (nreverse ans))) (defun ret-from-argd (argd &aux ans) (declare (Fixnum argd)) (let ((tem (logand (argd-atypes argd) 3))) (declare (fixnum tem)) (setq ans (aref *promoted-arg-types* tem)) (cond ((argd-flag-p argd sets-mv) '*) (t ans)))) ) (defun fdata-to-argd(fdat &aux tem) (cond ((setq tem (fdata-function-declaration fdat)) (return-from fdata-to-argd (the fixnum(car tem))))) (let* ((ll (fdata-ll fdat)) (min (length (ll &required ll))) (max (+ min (length (ll &optional ll)))) (argd 0)) (declare (fixnum min max argd)) (cond ((or (ll &rest ll) (ll &key ll)) (setq max 63))) (setq argd (make-argd min max 0)) (setf (argd-flag-p argd requires-nargs ) (> max min)) (setf (argd-flag-p argd sets-mv) t) (setf (argd-flag-p argd requires-fun-passed)(fdata-closure-vars fdat)) argd)) (defun get-install-form (fdat sym &aux tem) (let ((argd (fdata-to-argd fdat)) (n (push-address fdat))) `(si::initfun ,sym ,n ,argd,@ (sloop for v in (fdata-closure-vars fdat) do (setq tem (cdr (assoc v *top-level-closure-vars*))) (or tem (setq tem (push-data 'dv (cons nil nil)))) collect tem)))) (defun e2fset (form &aux sym fun fdat tem sform) (desetq (sform sym fun) form) (or (typep fun 'top-form) (wfs-error)) (cond ((and (consp (setq tem (top-form-walked fun))) (consp (cdr tem)) (typep (setq fdat (cadr tem)) 'fdata)) (e2-write-top fun) (push-data 'd_eval_skip (ecase sform (si::fset (get-install-form fdat sym)) (mset (cons 'si::initmacro (cdr (get-install-form fdat sym)))))) ) (t (setf (third form) (top-form-lisp (third form))) (push-data 'd_eval_skip form)))) (setf (get 'local-function 'e2) 'e2-local-function) (defun e2-local-function (x ) (e2-write-top (second x)) ) #+later (defun multiple-value-p (ret-type) ;; return T if the ret-type is one for not a single value. (or (eq ret-type '*) (and (consp ret-type) (eq (car ret-type) 'values)))) (setf (get 'lambda-block 'e2) 'e2-lambda-block) (setf (get 'lambda 'e2) 'e2-lambda-block) (defvar *temp-cvars* ;; list of C Vars (ind type) which will be written out as the ;; TEMP_CVARSi macro at the beginning. ) (defvar *next-vcs* ;; size of block of c stack reserved for this function ;; declare by object Vcs[n]; ) (defvar *exit* ;; a CONS whose CAR ;; 'function-return' indicates return from function after set ;; 'next' control just continues ;; a label struct do a goto this lavel ;; Its CDR is a pointer into the control stack. The interval of the controlstack ;; between this pointer and the current *control-stack*, must be unwound before jumping ;; or setting a possibly special variable. ) (defvar *closure-vars* nil) (defvar *fdata* nil) (defvar *used-function-saved-avma* nil ;; is set to t if we need to ;; save the entering avma address. ) (defun e2-lambda-block (x &aux (*next-cvar* 0) (*blocks* 0) fdat *used-names* (*next-vcs* 0) (*next-label* 0) *temp-cvars* *closure-vars* freturn-type *control-stack* ;; in this pass *control-stack* contains info about ;; binding specials,saved-avma, tags so we know when ;; we jump if we need a setjmp, or if we need to unwind. ;; also for function-return. *alloc-decls* *fdata* *used-function-saved-avma* ) (declare (special *fdata*)) (setq fdat (second x)) (setq *fdata* fdat) (unless (fdata-ind fdat) (setf (fdata-ind fdat) (mangle-name (fdata-name fdat) 'function))) (setq *closure-vars* (fdata-closure-vars fdat)) (wr-comment "function definition: " (fdata-name fdat)) (wr" static " (rep-type (setq freturn-type (function-return-type fdat))) " " fdat"(") (wr-h "static " (rep-type freturn-type) fdat "() ;"); (write-args-and-open (fdata-ll fdat) (fdata-closure-vars fdat)) (if (eq freturn-type 'double_ptr)(setq freturn-type 'double-float)) (let* ((var (get-temp freturn-type)) (value `(,(if (eq freturn-type 'mv) 'mv 'var) ,var))) (valex value `(function-return ,var) (expr-b2 (fdata-form fdat)))) (close-blocks) (wr-h-temp-vars) ;; This var is shared elsewhere and we want new reference mechanism. (dolist (v *closure-vars*) (setf (var-ind v) nil)) (when (ll &key (fdata-ll fdat)) (let ((tem (push-address (list 'VK (fdata-ind fdat) )))) (push-data 'd_eval_skip `(si::set-key-struct ,tem)))) ) (defun wr-h-temp-vars( &aux type v) (let ((*c-output* *h-output*)) (wr " #define TEMP_VARS" *fdata*) (cond (*used-function-saved-avma* (wr " long FunctionEntryAvma = avma;"))) (dolist (w *temp-cvars*) (let ((t1 (or (second w) t))) (setq v (car w)) (cond ((eq type t1) (wr " ,V" v) ) (t (or (null type) (wr ";")) (setq type t1) (format *h-output* " ~a V~a" (rep-type type) v))) (cond ((eq type 'integer) (format *h-output* "= 0,V~aalloc" v) )) )) (and *temp-cvars* (format *h-output* ";")) (unless (eql *next-vcs* 0) (format *h-output* " object Vcs[~a];" *next-vcs*)) )) (defun open-block () (incf *blocks*) (wr-nl "{")) (defun close-blocks() (loop (if (<= *blocks* 0) (return nil)) (wr "}")(incf *blocks* -1))) (defun rep-type (type) (cond ((stringp type) (return-from rep-type type))) (case type ((character fixnum boolean) "int ") ((gen integer) "GEN ") (short-float "float ") (double-float "double ") (double_ptr "DoublePtr ") (otherwise "object "))) (defun bind-special (var val) (push 'bdsp *control-stack*) ; (incf *bdsp*) (or (var-ind var) (setf (var-ind var) (get-object (var-name var)))) (wr-nl "BdSp("(var-ind var)","(list 'inline-loc t val)");") ) (defun b2-bind-var (w v) (cond ((typep w 'var) (cond ((var-special-p w) (bind-special w v)) ((var-clb w) (wr-nl) (wr-vind (var-ind w)) (wr "=MakeClosVar(" v ");") (or (var-ind w) (wfs-error)) ) ((and (consp v) (eq (car v) 'var) (eql (second v) (var-ind w)))) (t (wr-set-inline-loc w v)))) ;; save writing V3=V3 ((and (consp w) (eq (car w) 'var)) (cond ((and (typep v 'var) (eql (second w) (var-ind v)))) (t (wr-set-inline-loc w v)))) (t (wfs-error) ;(wr-nl w "=" v ";") ))) (defun b2-bind-var-b2 (var val &aux tem) ;; like b2-bind-var-b2, but does a b2 eval on its second arg. (if (plain-var-p var) (setq tem var ) (setq tem (get-temp t))) (valex (list 'var tem) (next-exit) (expr-b2 val)) (or (eq tem var) (b2-bind-var var tem))) (defun assign-reqds-and-optionals (ll fdat &aux (atypes 0) var tem type (did-required nil) (lis (ll &required ll))) (declare (fixnum atypes)(boolean did-required)) (let ((fdecl (fdata-function-declaration fdat))) (cond (fdecl (setq atypes (argd-atypes(fdecl argd fdecl)))))) (tagbody again (sloop for v on lis with vtype do (setq var (if did-required (caar v) (car v))) (setq type (aref *promoted-arg-types* (logand (setq atypes (ash atypes -2)) 3))) (setq vtype (var-implementation-type var)) (cond ((or (eq type vtype) (eql (rep-type type) (rep-type vtype))) (setq tem var)) (t (setq tem nil) (cond ((plain-var-p var) (next-cvar var) (push var *alloc-decls*))))) (setf (car v) (cons (list 'var (next-cvar tem) type) (car v)))) (unless did-required (setq did-required t) (setq lis (ll &optional ll)) (go again)) )) ;; if not nil try to allocate all rest args on the c stack. (defun wr-decl-var (var) (cond ((typep var 'var) (if (var-volatile var) (wr "VOL ")) (let ((type (var-type var))) (cond ((eq type 'integer) (wr "IDECL("var","var"__space,"var"__alloc);")) (t (wr (rep-type type) " ") (wr-vind (var-ind var))(wr ";"))))) ((and (consp var) (eq (car var) 'var)) (wr (if (third var) (rep-type (third var)) "object ") var ";")) (t (wfs-error)))) (defvar *rest-on-stack* nil) (defvar *alloc-decls* nil) (defun write-args-and-open(ll closure-vars &aux reqds varargp va-start labels deflt rest-var (fdat *fdata*) tem (cfun (fdata-ind fdat))) (assign-reqds-and-optionals ll fdat) (setq reqds (ll &required ll)) (wr-list (mapcar 'car reqds)) (cond ((vararg-p fdat)(setq varargp t) (if reqds (wr ",")) (wr "va_alist) ")) (t (wr ") "))) (sloop for v in reqds do (wr-decl-var (car v))) (cond (varargp (wr "va_dcl "))) (incf *blocks*) (wr " { TEMP_VARS" fdat" ") (sloop for v in *alloc-decls* do (wr-decl-var v)) (setq *alloc-decls* nil) ;; we must actually have the pointers in our function point to the closure cells. ;; Otherwise if noone keeps a pointer to the closure itself during the call, ;; the closure might be gc'd and the variables themselves be unprotected. (when closure-vars (dolist (v closure-vars) (allocate-var v 'kw)) (wr "VOL object CLfun;") (wr-nl "struct { ") (write-alloc-decls (rep-type t)) ;; the *& is to make sure this goes into the Cstack. (wr "} *CLvars = (void *) (*&CLfun = fcall.fun, CLfun->cl.Env);")) (cond (varargp (wr-nl "int Inargs = VFUN_NARGS - " (length reqds)";va_list Iap;") (dolist (v (ll &optional ll)) (wr-decl-var (car v)) (allocate-var (cadddr v) t)) (write-alloc-decls (rep-type t)) (when (ll &rest ll) (setq rest-var (caar (ll &rest ll))) (allocate-var rest-var t)) (write-alloc-decls (rep-type t)) ;; Todo : Use a structure to get named args: ;; struct { object V1,V2,...V10;} Vk; ;; Refer Kw.V2 (when (ll &key ll) (wr-nl " struct {") (dolist (v (ll &key ll)) (allocate-var (car v) 'kw)) (write-alloc-decls (rep-type t)) (dolist (v (ll &key ll)) (allocate-var (caddr v) 'kw)) (wr-nl"") (write-alloc-decls (rep-type t)) (wr "} Vk;")) )) (cond ((and (setq tem (fdata-tail-label fdat))(label-referred tem)) (wr "LA" tem ":;") (push tem *control-stack*) )) (sloop for v in reqds do (b2-bind-var (cdr v) (car v))) (when varargp (wr-nl "Inargs = VFUN_NARGS - " (length reqds) " ; ") (when (ll &optional ll) (let (*control-stack*) ;; don't double BDSP. These will be added below (dolist (opt (ll &optional ll)) (push (next-label) labels) (wr-nl "if( --Inargs < 0)") (wr-go (car labels)) (wr-nl "else {") (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (b2-bind-var (car opt) (list 'next-var-arg)) (b2-bind-var (cadr opt) (car opt)) (wr "}") (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object t))) )) (setq labels (nreverse labels)) (let ((label (next-label))) (wr-go label) ;;; Bind unspecified optional parameters. (dolist-safe (opt (ll &optional ll)) (wr-label (car labels)) (pop labels) (b2-bind-var-b2 (car opt) (caddr opt)) (b2-bind-var (cadr opt) (car opt)) (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object nil)))) (wr-label label) )) ;; bind &rest arg (when rest-var (let ((dynamic-extent (or *rest-on-stack* (eq 'dynamic-extent (var-type rest-var)))) (temp (get-temp t))) (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (wr-nl temp "=" ) (cond ((ll &key ll) (cond (*rest-on-stack* (wr "(ALLOCA_CONS(Inargs),ON_STACK_MAKE_LIST(Inargs));")) (t (wr "make_list(Inargs);")))) (dynamic-extent (wr "(ALLOCA_CONS(Inargs),ON_STACK_LIST_VECTOR(Inargs,Iap));")) (t (wr "list_vector(Inargs,Iap);"))) (b2-bind-var rest-var temp))) ;; bind keywords (when (ll &key ll) (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) (setq deflt (mapcar 'cadr (ll &key ll))) (let ((vkdefaults nil) (n (length (ll &key ll)))) (do* ((v deflt (cdr v)) (kwds (ll &key ll) (cdr kwds)) (kwd (car kwds) (car kwds))) ((null v)) (unless (and (dv-p (car v)) (eq (third (car v)) nil)) (setq vkdefaults t)) (when (or (not (and (dv-p (car v)) (progn (add-data (car v))))) ;; the supplied-p variable is not there (not (null (third kwd))) ) (setf Vkdefaults t) (setf (car v) 0))) (if (> (length deflt) 15) (setq vkdefaults t)) (open-block) (let ((*c-output* *h-output*)) (when vkdefaults (terpri *h-output*) (wr "static int VK" cfun "defaults[" (length deflt) "]={") (do ((v deflt(cdr v))(tem)) ((null v)) (cond ((eql (car v) 0) (wr "-1")) ;; must be location ((and (eq (caar v) 'dv) (eq (setq tem (third (car v))) nil)) (wr "-2")) ;; fix these two to allow fixnum constants. ((eq (caar v) 'dv) (wr (get-dv-index (car v)))) (t (wfs-error))) (if (cdr v) (wr ","))) (wr "};")) (terpri *h-output*) (wr "static struct { short n,allow_other_keys;" "int *defaults;") (wr-nl " int keys[" n "];") (wr "} VK" cfun "key=") (wr "{" (length (ll &key ll)) "," (if (ll &allow-other-keys ll) 1 0) ",") (if vkdefaults (wr "VK" cfun "defaults") (wr "(int *)Cstd_key_defaults")) (when (ll &key ll) (wr ",{") (do ((v (reverse (ll &key ll)) (cdr v))) ((null v)) ;; We write this list backwards for convenience ;; in stepping through it in parse_key (wr (second (add-data (fourth (car v)) ))) (if (cdr v) (wr ","))) (wr "}")) (wr "};") ) (cond (rest-var (wr-nl "parse_key_rest(" rest-var ",")) (t (wr-nl "parse_key_new("))) (wr "Inargs,&Vk,&VK" cfun "key,Iap);") ) ;; end setup keys ;; bind the keys (dolist (kwd (ll &key ll)) (cond ((not (eql 0 (pop deflt))) ;; keyword default bound by parse_key.. and no supplied-p (b2-bind (car kwd))) (t (wr-nl "if(" `(key-var ,(car kwd)) "==0){") (b2-bind-var-b2 (car kwd) (cadr kwd)) (unless (null (caddr kwd)) (b2-bind-var (caddr kwd) (get-object nil))) (wr-nl "}else{") (let (*control-stack*) ;; don't do extr BdSP (b2-bind (car kwd)) (and (caddr kwd) (b2-bind-var (caddr kwd) (get-object t)))) (wr "}")))))) )) (defun b2-bind (w) (cond ((var-special-p w) (b2-bind-var w (var-special-p w))) ((var-clb w) (or (consp (var-ind w)) (wfs-error)) (b2-bind-var w (list 'closure-var-loc w))) (t nil))) (setf (get 'var 'b2) 'b2-var) (setf (get 'dv 'b2) 'b2-dv) (defun b2-dv (x ) (unless (cadr x) (add-data x)) (unwind-set x)) (defun b2-var (v) ;; what about the strategy of having everything except var's ;; eval'd into a temp var. (unwind-set v) v) (defun needs-temp (val sofar rest &aux tem) ;; VAL is the result of a expr-b2 ? '(1val) and SOFAR is the list of ;; results sofar and REST is the list of future arguments to expr-b2. ;; We must create a temp variable and assign it to val if any evaluation ;; of the things in rest or sofar might alter the value in VAL. (and (null sofar) (null rest) (return-from needs-temp nil)) ;; if sofar is only vars and rest is null ;; also would be ok. (cond ((consp val) (cond ((eq (car val) 'var) (return-from needs-temp nil)) ((eq (car val) 'dv) (if (or (numberp (third val)) (keywordp (third val))) (return-from needs-temp nil))) ((eq (car val) 'call) ;; symbol-function does not have side-effect, but ;; we need to preeval both to make sure order is write. ;; (foo (symbol-function 'bil) (deff 'bil)) (cond ((not (side-effect-p val)) (return-from needs-temp nil)))))) ((typep val 'var) (or (null (var-special-p val)) (wfs-error)) (cond ((and (null (var-clb val))) (return-from needs-temp nil))))) (setq tem (get-temp (result-type val))) (wr-nl tem "=" val ";") tem) (defun sets-mv-p (loc) (cond ((atom loc) nil) ((eq (car loc) 'inline-loc) (sets-mv-p (third loc))) ((eq (car loc) 'inline-call) (flag-p (opt flag (cddr loc)) mv)) (t nil))) (defun unwind-avma (ctl-stack) (sloop for v on *control-stack* do (cond ((eq v ctl-stack)(return nil)) ((eq (car v) 'avma-bind-needed) (cond ((member 'inner-avma (cdr v)) (wr-nl "avma = InnerAvma;")) (t (wr-nl "avma = FunctionEntryAvma;") (setq *used-function-saved-avma* t))))))) (defun unwind-stack (ctl-stack) ;; Does the unbinding of special variables, popping the CtlStack, ;; Cases here must also appear in unwind-stack-p (sloop for v on *control-stack* until (eq v ctl-stack) do (case (car v) (bdsp (wr-nl "UnBdSp;")) (ctl-push (wr-nl "CtlPop;")) (t (cond ((consp (car v)) (case (caar v) (progv-bind (wr-nl "IunwindBdSp(" (cadar v) ");")) (unwind-protect (wr-nl "CtlPop;IcallUnwindFun(" (cadar v) ");")) ))))))) (defun unwind-stack-p (ctl-stack) (sloop for v on *control-stack* until (eq v ctl-stack) when (or (eq (car v) 'bdsp) (eq (car v) 'ctl-push) (and (consp (car v)) (or (eq (caar v) 'progv-bind) (eq (caar v) 'unwind-protect)))) do (return t))) (defun restore-function-avma () (wr-nl "avma = EntryAvma;") (setq *used-function-saved-avma* t)) (defun unwind-set (val &optional avma-bind) (cond ((and (typep val 'var) (var-special-p val) (cdr *value*) (unwind-stack-p (cdr *exit*))) (setq val (replace-inline-by-temp val)))) (cond ((second *value*) (unwind-stack (cdr *exit*)) (wr-set-inline-loc (second *value*) val)) ((and (consp val) (eq (car val) 'inline-call)) (let ((flag (opt flag (cddr val)))) (cond ((flag-p flag set) (wr-nl val ";"))) (unwind-stack (cdr *exit*)))) (t (unwind-stack (cdr *exit*)))) (cond ((and (eq (car *value*) 'mv) ;; *MV-N-VALUES-SET* bound to t by values special form (null *MV-N-VALUES-SET*) (not (sets-mv-p val))) ;; detect if val does a set of MV ;; if not then we must (wr "fcall.nvalues = 1;"))) (case (car *exit*) (function-return (or (eq (second *exit*) (second *value*)) (wfs-error)) ;; must make sure CLfun and so its closure vars are not gc'd. The ;; usage *&CLfun may mean this touch can be empty, since I think ANSI (unwind-avma nil) (if *closure-vars* (wr "TOUCH_CLfun;")) (let ((val (second *value*))) (or (eq (car val) 'var) (wfs-error)) (cond ((eq (third val) 'double-float) (wr-nl "RETURN_DOUBLE_PTR(" val ");")) (t (wr-nl "return " val ";"))))) (next (if avma-bind (unwind-avma (cdr *exit*)))) (otherwise (cond ((typep (car *exit*) 'label) (unwind-avma (cdr *exit*)) (wr-go (car *exit*))) (t (wfs-error))))) ;; remove the avma-bind which has just been used. (if avma-bind (remove-avma-bind avma-bind)) ) (defun remove-avma-bind (avma-bind) (cond ((eq *control-stack* avma-bind) (setq *control-stack* (cdr avma-bind))) ((eq (cddr *control-stack*) (cdr avma-bind)) (setq *control-stack* (cons (car *control-stack*) (cdr avma-bind)))) (t (wfs-error)))) (setf (get 'progn 'b2) 'b2-progn) (defun b2-progn (x) (progn-b2 (third x))) (defun progn-b2 (body) (sloop for v on body do (if (cdr v) (valex '(ignore) (next-exit) (expr-b2 (car v))) (expr-b2 (car v)))) (or body (expr-b2 (get-object nil)))) (defun get-temp (type) (cond ((eq type 'integer) (setq type 'gen))) (let ((tem (list 'var (next-cvar) type))) (push (cdr tem) *temp-cvars*) tem)) (defun push-vcs () (prog1 (list 'vcs *next-vcs*) (incf *next-vcs*))) (defun write-alloc-decls(str) (when *alloc-decls* (wr str) (wr-list (nreverse *alloc-decls*)) (wr ";") (setq *alloc-decls* nil))) (defun allocate-var (v type) (cond ((if (null v) (push `(var ,(next-cvar)) *alloc-decls*)) (return-from allocate-var nil)) ((typep v 'var) (cond ((eq type 'kw) (let ((ind (next-cvar v))) (push (list 'var ind) *alloc-decls*) (cond ((var-special-p v) (setf (var-special-p v) `(var (kw ,ind)))) (t (setf (var-ind v) (list 'kw ind)))))) ((var-special-p v)) (t (next-cvar v) (push (list 'var (var-ind v)) *alloc-decls*)))))) (defun plain-var-p (x) (and (typep x 'var) (not (var-special-p x)) (not (var-clb x)))) (setf (get 'let 'b2) 'b2-let) (setf (get 'let* 'b2) 'b2-let) (defvar *last* nil) (defun next-exit () ;; a hack to avoid some consing. (cond ((and *last* (eq (cdr *last*) *control-stack*)) *last*) (t (setq *last* (cons 'next *control-stack*))))) (defun b2-let (x &aux (*control-stack* *control-stack*) (*blocks* 0) binds body (*used-names* *used-names*) todo ) (desetq (binds body) (cddr x)) (open-block) (sloop for (var) in binds when (not (var-special-p var)) do (next-cvar var) (wr-decl-var var)) (sloop for (var val) in binds do (cond ((plain-var-p var) (valex (list 'var var) (next-exit) (expr-b2 val))) (t (let ((tem (get-temp t))) (valex (list 'var tem) (next-exit) (expr-b2 val)) (if (eql (car x) 'let) (push (cons var tem) todo) (b2-bind-var var tem)))))) (sloop for (var . val) in (nreverse todo) do (b2-bind-var var val)) (progn-b2 body) (close-blocks) nil) (defun safe-system (x) (unless (eql 0 (system x)) (error "The command ~s failed" x))) (defun compile-and-add-data-file ( o-file &aux command dir) (declare (special c-debug)) (force-output *c-output*) (force-output *data-output*) (force-output *h-output*) (if (eql *c-output* *standard-output*) (return-from compile-and-add-data-file nil)) (setq dir (namestring (make-pathname :directory (or (pathname-directory *c-output*) '(:current))))) (setq command (format nil "(cd ~a ; ~a -c -I. -I/u/wfs/new-lisp/newh ~a ~a ~a )" dir compiler::*cc* (namestring *c-output*) (if c-debug "-g" "") (if (> *speed* 0) "-O" "") )) (cond (o-file (safe-system command) (with-open-file (st (get-output-pathname "o") :direction :output :if-exists :append) (setq o-file (truename st)) (sloop for v in-array "" do (write-char v st)) (write-char #\N st)) (system (format nil "cat ~a >> ~a" (namestring *data-output*) (namestring o-file))))) ) (defun disassemble1 (name) (with-open-file (st "/tmp/wfs1.lsp" :direction :output) (print `(in-package ,(package-name *package*))) (let ((def (symbol-function name))) (cond ((and (consp def) (eq (car def) 'lambda-block)) (print `(defun ,name ,@ (cddr def)) st)) (t (return-from disassemble1 'cant)))) (force-output st) (compile-file1 (pathname st) :c-file *standard-output*))) gcl-2.6.14/comp/inline.lsp0000755000175000017500000004722414360276512013743 0ustar cammcamm(in-package "BCOMP") (eval-when (compile load eval) (defmacro opt (key opt) `(nth ,(position key '(args return flag template )) ,opt)) ) (eval-when (eval compile load) (defun flags-pos (flag &aux (i 0)) (declare (fixnum i)) (dolist (v *flags*) (cond ((member flag v :test 'eq) (return-from flags-pos i))) (setq i (+ i 1))) (error "unknown opt flag")) (defvar *flags* '((allocates-new-storage ans) ; might invoke gbc (side-effect-p set) ; no effect on arguments (constantp) ; always returns same result, ;double eval ok. (result-type-from-args rfa) ; if passed args of matching ;type result is of result type (is);; extends the `integer stack'. (mv);; in a declaration, function may return MV. (safe);; can be used at safety 3 (notinline) (touch-mv);;Invoking this may alter the MV locations. (not-1-val) ;; obsoluete (proclaim) ; do a proclaim. )) ) (defmacro flags (&rest lis &aux (i 0)) (dolist (v lis) (setq i (logior i (ash 1 (flags-pos v))))) i) (defun print-flag (n &optional safe) (princ "#.(flags") (dotimes (i (length *flags*)) (if (logbitp i n) (format t " ~(~s~)"(car (last (nth i *flags*))) ))) (if safe (princ " safe")) (princ ")") n) ;#+assist (progn ;; Convert old AKCL opts. (defun print-opt (sym prop &aux tem ) (unless (get 'compiler::boolean 'comp-type) (setf (get 'compiler::boolean 'comp-type) 'boolean) (setf (get :dynamic-extent 'comp-type) 'dynamic-extent) (setf (get 'compiler::fixnum-float 'comp-type) 'fix-or-sf-or-df)) (cond ((setq tem (get sym prop)) (format t "~%(defopt ~s" sym) (let ((*print-case* :downcase)) (dolist (v (reverse tem)) (format t "~% (~s ~s " (mapcar 'comp-type (car v)) (comp-type (second v))) (print-flag (third v) (eq prop 'compiler::inline-always)) (format t " ~s)" (if (stringp (fourth v)) (substitute #\$ #\# (fourth v)) (fourth v))))) (princ ")")))) (defun convert-old (&rest props &aux syms) (sloop for pack in '(lisp si compiler) do (sloop for v in-package pack when (sloop for w in props when (get v w) return t) do (push v syms))) (setq syms (sort syms #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) (sloop for v in syms do (sloop for w in props do (print-opt v w)))) ;(with-open-file (*standard-output* "/tmp/opts1.lsp" :direction :output) (convert-old 'compiler::inline-always 'compiler::inline-unsafe)) ;(load "/tmp/opts.lsp") ;(with-open-file (*standard-output* "/tmp/opts.lsp" :direction :output) (convert-old 'bcomp-opt)) ) (defmacro defopt (fname &rest l) ;; adds additional opts to the front. ;; last added is most significant. `(defopt1 ',fname ',l)) (defun defopt1 (fname l) (dolist (v l) (let ((fl (opt flag v))) (cond ((flag-p fl proclaim) (proclaim1 `(ftype (function ,(opt args v) ,(opt return v)) ,fname))))) (push v (get fname 'bcomp-opt)))) (defmacro flag-p (n flag) `(logbitp ,(flags-pos flag) ,n)) (setf (get 'aref 'coerce-arg-types) '(t fixnum fixnum fixnum fixnum)) (setf (get 'si::aset1 'coerce-arg-types) '(t fixnum )) (defun get-inline-template (fname fdecl arg-types ret-type type-wanted &aux lis opt-ret tem (opt-flag 0) (mask (if (> *safety* 0) ;*unsafe* #.(flags safe) #.(flags)))) (declare (fixnum mask opt-flag)) (or (symbolp fname) (wfs-error)) (setq lis (get fname 'bcomp-opt)) (or lis (return-from get-inline-template nil)) (cond ((eq type-wanted 'mv) (setq type-wanted t) (unless (and fdecl (not (flag-p (second fdecl) mv))) ;function proclaimed to return 1 arg (setq mask (logior mask #. (flags mv) ))))) (when (setq tem (get fname 'coerce-arg-types)) (sloop for v on arg-types for w in tem unless (eq w t) do (setf (car v) (type-and (car v) w)))) (if (member type-wanted *immediate-types*) (setq ret-type type-wanted)) (sloop for opt in lis do (setq opt-ret (opt return opt)) (setq opt-flag (opt flag opt)) ;; check return return matches do (when (and (eql mask (logand opt-flag mask)) (or (eql opt-ret t) (eql opt-ret '*) (comp-subtypep ret-type opt-ret))) (sloop for v on arg-types for w on (opt args opt) do (cond ((eq (car w) '*) (return-from get-inline-template opt)) ((or (comp-subtypep (car v) (car w)) (return nil)))) finally (cond ((eq (car w) '*) (return-from get-inline-template opt)) ((and (null v) (null w)) (return-from get-inline-template opt)))))) ) (defun result-from-args (sym argl &aux arg-types) (let ((tem (get sym 'bcomp-opt))) (when tem (sloop for opt in tem when (flag-p (opt flag opt) rfa) do (or arg-types (setq arg-types (mapcar 'result-type argl))) (sloop for v on arg-types for w on (opt args opt) do (cond ((eq (car w) '*) (return-from result-from-args (opt return opt))) ((or (subtypep (car v) (car w)) (return nil)))) finally (cond ((eq (car w) '*) (return-from result-from-args (opt return opt)) ) ((and (null v) (null w)) (return-from result-from-args (opt return opt)) )))) (cond ((get sym 'arithmetic-contagion) (or arg-types (setq arg-types (mapcar 'result-type argl))) (setq tem (or (member 'double-float arg-types ) (member 'short-float arg-types))) (if (and tem (sloop for v in arg-types always (or (subtypep v 'fixnum) (subtypep v 'double-float) (subtypep v 'short-float)))) (return-from result-from-args (car tem))) ))))) (dolist (v '(* + - 1- 1+ /)) (setf (get v 'arithmetic-contagion) t)) ;; symbol_value ;; the result depends on WHEN the form is evaluated. ;; list ;; Different invocations give different results with same ;; args, but order of eval is not important. Double EVAL is. ;; (add x y) ;; May be multiple eval'd. WHEN is not important. ;; (aref x i) ;; May be multiple eval'd. WHEN is important. ;; (set x 3) ;; May be multiple eval'd. Changes something in x. WHEN important. ;; by 'not side-effect' in the property of an inline, means that it may be ;; multiple eval'd as long as there were no intervening operation which does ;; not have the no-side-effect property, and the results would be same EXCEPT, ;; that we might get a different storage location. ;; by allocates-new-storage we mean that storage is allocated. ;; A function which has no-side-effect and 'not allocates-new-storage' ;; must return eq results if multiple-eval'd with no intervening ;; no-side-effect function. ;; Call a function foo and goo `unordered' if ;; (setq a (goo x y)) ;; (setq b (foo x y)) ;; Then no common lisp function could tell whether a or b was computed first. ;; The set of 'not side-effect' functions are unordered. ;; This is the case for LIST, CONS, MAKE-ARRAY, APPEND, AREF, .. (defun inline-args (args arg-types &aux type-wanted) ;; returns (cons arglist referred-vars) ;; where REFERRED-VARS is a list of vars which will be eval'd ;; during the inline writeout of the forms in ARGLIST. The ;; list of these variables is necessary so that INLINE-CALL ;; may produce this list. ;; we check thru each ARG, and any one which we find which does not ;; meet the following criteria, is pre eval'd as a temp. ;; 1: Are them selves inline calls to functions with 'not side-effect-p' flag ;; 2: Refer to vars which are setq'd by subsequent inline-calls (since ;; it will be to late to eliminate them then. Those setq's will actually ;; be written out in the preevalling. ) ;; 3: lexical or special vars unless the last arg. ;; eg (foo x (progn (setq x 3) 7)) would require saving initial value of x in a ;; temp, because it is changed by a subsequent arg. ;; In (foo (progn (setq x 3) 7) x (+ x y)) the second x and the (+ x y) ;; could stay and be inlined. ;; All user functions are presumed to have 'side-effect-p' (sloop for v on args with referred = (cons nil nil) do (setf type-wanted (or (equal arg-types '(*)) (pop arg-types))) collect (inline-arg (car v) type-wanted (cdr v) referred) into all finally (setf (car referred) all) (return referred))) (defun function-constant-p (x) ;; a function which returns something which will be the SAME for a given ;; set of arguments, where SAME means that there would not be a way in common lisp ;; of distinguishing between two results of an invocation OTHER than using eq. (member x '(+ * list cons))) (defun remaining-args-constant (rest &aux cd) (sloop for v in rest do (cond ((atom v)) ((eq (car v) 'var)) ((eq (car v) 'call) (setq cd (third v)) (unless (and (function-constant-p (call-data-fname cd)) (remaining-args-constant (call-data-arglist cd))) (return nil))) (t (return nil))) finally (return t))) (defun is-var-changed (var subsequent-args &aux cd) (sloop for v in subsequent-args do (cond ((or (atom v) (eq (car v) 'var) (eq (car v) 'dv)) nil) ((not (plain-var-p var)) (setq cd (third v)) (unless (and (eq (car v) 'call) (function-constant-p (call-data-fname cd)) (not (is-var-changed var (call-data-arglist cd)))) (return t))) ((typep (second v) 'desk) (return (memq var (desk-changed-vars (second v))))) (t (return t))))) (defun inline-arg(a type-wanted rest referred &aux referred-vars result n tem) ;; a value which can be written inline as an arg, and ;; sets referred-vars ;; (when (eq type-wanted 'fix-or-sf-or-df) (let ((x (car (member (result-type a) '(fixnum short-float double-float))))) (and x (setq type-wanted x)))) (when (eq type-wanted 'double_ptr) (let ((v (get-temp 'double-float)) (tem (inline-arg a 'double-float rest referred))) (wr-set-inline-loc v tem) (return-from inline-arg (list 'address v)))) (cond ((atom a) (or (typep a 'var) (wfs-error)) (setq result a) (cond ((or (null rest) (remaining-args-constant rest) (and (plain-var-p a) (not (is-var-changed a rest)))) (push a (cdr referred))) (t (setq result (get-temp (var-implementation-type a))) (wr-nl result "=" a ";"))) (or (eq (var-implementation-type a) type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'var) ;a temp var (setq result a) (or (eq (third a) type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'dv) (setq result (add-data a)) (or (eq t type-wanted) (setq result (list 'inline-loc type-wanted result)))) ((eq (car a) 'the) (setq result (inline-arg (third a) type-wanted rest referred))) ((eq (car a) 'call) (setq result (inline-call a type-wanted )) (setq tem nil) (setf referred-vars (car result) (car result) 'inline-call) (let ((templ (cddr result)) tem1) (setq n (opt flag templ)) (cond ( ;; need a temp: (or (not (or (flag-p n constantp) (and (not (flag-p n set)) (not (flag-p n ans))))) (and (typep (setq tem1 (fourth templ)) 'link) (or (argd-flag-p (link-argd tem1) requires-nargs) (argd-flag-p (link-argd tem1) requires-fun-passed)))) (setq tem (get-temp type-wanted))) (rest (sloop for referred-var in referred-vars when (is-var-changed referred-var rest) do (setq tem (get-temp (opt return templ))) (loop-finish)))) (unless (null tem) (setq referred-vars nil) (wr-set-inline-loc tem result) (setf result tem)) (unless (eq (opt return templ) type-wanted) (setq result (list 'inline-loc type-wanted result))) (if referred-vars (setf (cdr referred) (nconc referred-vars (cdr referred)))) )) (t (setq result (get-temp type-wanted)) (when *do-pending-open* (setq *do-pending-open* nil)(open-block)) (valex (list 'var result) (next-exit) (expr-b2 a)) result)) result ) (defun constant-inline-fixnum(x &aux y) (or (and (consp x) (eq (car x) 'inline-loc) (eq (second x) 'fixnum) (and (consp (setq y (third x))) (eq (car y) 'dv) (typep (third y) 'fixnum))) (wfs-error)) (third y)) (setf (get 'boole 'bo2) 'bo2-boole) (defun bo2-boole(a type-wanted arg-types) (when (and (equal arg-types '(fixnum fixnum fixnum)) (dv-p (car (call-data-arglist (third a))))) (do-inline-call 'boole3 a 'fixnum))) (defun wr-inline-boole3 (iargs) (wr-inline-call1 (cdr iargs) (ecase (constant-inline-fixnum (car iargs)) (#.boole-ior "(($0) | ($1))" ) (#.boole-xor "(($0) ^ ($1))" ) (#.boole-and "(($0) & ($1))" ) (#.boole-eqv "(~(($0) ^ ($1)))" ) (#.boole-nand "(~(($0) & ($1)))" ) (#.boole-nor "(~(($0) | ($1)))" ) (#.boole-andc1 "((~($0)) & ($1))" ) (#.boole-andc2 "(($0) & (~($1)))" ) (#.boole-orc1 "((~($0)) | ($1))" ) (#.boole-orc2 "(($0) | (~($1)))" ) (#.boole-clr "(0)" ) (#.boole-set "(-1)" ) (#.boole-1 "(($0))" ) (#.boole-2 "(($1))" ) (#.boole-c1 "(~($0))" ) (#.boole-c2 "(~($1))" )))) (defun do-inline-call (fname a type-wanted) (inline-call (list 'call (second a) (make-call-data fname (call-data-arglist (third a)) nil nil)) type-wanted)) (defun coerce-to-binary (sym dsk argl &aux first) (setq first `(call ,dsk ,(make-call-data sym (list (car argl)(second argl)) nil nil))) (cond ((cddr argl) (coerce-to-binary sym dsk (cons first (cddr argl)))) (t first))) (defun bo2-coerce-to-binary (a type-wanted arg-types) arg-types (let* ((form-type (desk-result-type (second a))) (call-dat (third a)) (arglist (call-data-arglist (third a)))) (cond ((and (cddr arglist) (or (not (eq type-wanted t)) (not (eq form-type t)))) (if (eq type-wanted 'mv) (setq type-wanted t)) (inline-call (coerce-to-binary (call-data-fname call-dat) (make-desk (type-and type-wanted form-type)) arglist) type-wanted))))) (dolist (v '(+ * - /)) (setf (get v 'bo2) 'bo2-coerce-to-binary)) (setf (get 'aref 'bo2) 'bo2-aref) (defun bo2-aref (a type-wanted arg-types &aux (cd (third a)) argl type size) arg-types (setq argl (call-data-arglist cd)) (setq type (result-type (car argl))) (cond ((and (= *safety* 0) (eql 3 (length argl)) (consp type) (eq (car type) 'array) (eq (second type) t) (consp (setq size (third type))) (typep (second size) 'fixnum)) (if (eq type-wanted 'mv) (setq type-wanted t)) (inline-call (list 'call (second a) (make-call-data 'aref-2d (append argl (list (get-object (second size)))) nil nil)) type-wanted)))) (defun inline-call (a type-wanted &aux call-dat in-args template tem (*exit* (next-exit))) ;; The arg A is a (call ..) as returned from b1-walk. ;; If TYPE-WANTED is NIL then we may need Mult Values. ;; This function returns a list: ;; (referred-vars inlined-args result-type flags fname-or-string) ;; The REFERRED-VARS and RESULT-TYPE and FLAGS are necessary for ;; recursive calls, while the FNAME-OR-STRING and INLINED-ARGS ;; are used to actually write out the result. (setq call-dat (third a)) (let* ((fname (call-data-fname call-dat)) fdecl check (arglist (call-data-arglist call-dat)) (arg-types (mapcar 'result-type arglist)) (form-type (desk-result-type (second a)))) (cond ((and (setq tem (get fname 'bo2)) (setq tem (funcall tem a type-wanted arg-types))) (return-from inline-call tem))) (cond ((call-data-local-fun call-dat) (setq check t) (setq template (get-template-fdata (second (second (call-data-local-fun call-dat)))))) ((setq template (progn (setq fdecl (function-declaration fname)) (let ((ret (if fdecl (ret-from-argd (fdecl argd fdecl))))) (cond (ret (cond ((eq ret 'double_ptr) (setq form-type (type-and 'double-float form-type))) ((or (eq ret t)(eq ret '*))) (t (setq form-type (type-and ret form-type))))))) (get-inline-template fname fdecl arg-types form-type type-wanted)))) ((setq template (add-link-template fname fdecl arg-types type-wanted)))) ;; now we have template. (when check (sloop for v in (car template) with al = arglist do (cond ((eq v '*) (return t)) ((null al) (comp-error "Too few args passed to ~a " fname)) (t (pop al))))) (cond ((flag-p (opt flag template)is ) (sloop for v on *control-stack* when (or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) do (setf (car v) 'avma-bind-needed) (return nil) finally (wfs-error)))) (setq in-args (inline-args arglist (opt args template))) (list* (cdr in-args) ; the referred-vars (car in-args) ; the arglist template))) (defun add-link-template (fname fdecl arg-types type-wanted &aux tem link ans (leng (length arg-types))) (declare (fixnum leng)) (setq tem (assoc fname *file-inline-templates*)) (when tem (setq link (fourth tem)) (cond ((typep link 'link) (cond ((< leng (argd-minargs (link-argd link))) (setf (argd-minargs (link-argd link)) leng)) ((> leng (argd-maxargs (link-argd link))) (setf (argd-maxargs (link-argd link)) leng)) (t nil)) (if (eq type-wanted 'mv) (setf (argd-flag-p (link-argd link) sets-mv) t)))) (return-from add-link-template (cdr tem))) (let ((ret t) (argl '(*)) (flags #.(flags set ans mv)) (argd 0) link) (declare (fixnum argd)) (cond (fdecl (setq argd (car fdecl)) (setq argl (argl-from-argd argd)) (setq ret (ret-from-argd argd)) (setq flags (second fdecl))) (t (setf (argd-minargs argd) (length arg-types)) (setf (argd-maxargs argd) (length arg-types)) (setf (argd-flag-p argd requires-nargs) t) (setf (argd-flag-p argd sets-mv) t))) (setq link (make-link fname fdecl)) (setf (link-argd link) argd) ;; we need the data object now, so make sure it gets in the vector ;; in time (add-data (get-object fname)) (push (setq ans (list fname argl ret flags link)) *file-inline-templates*) (cdr ans))) (defun get-template-fdata (fd &aux fstring tem) ;; make a template for a local fdata (or (typep fd 'fdata) (wfs-error)) (cond ((setq tem (fdata-local-template fd)) (return-from get-template-fdata tem))) (let* ((vararg (vararg-p fd)) (fdecl (fdata-function-declaration fd)) (ll (fdata-ll fd))) (unless fdecl (setq fdecl (increment-function-decl `(function , (nconc (sloop for v in (ll &required ll) collect (value-type v)) (if (ll &optional ll) (cons '&optional (sloop for v in (ll &optional ll) collect (value-type (car v))))) (if (or (ll &rest ll) (ll &key ll)) '(*) nil)) ;; todo arrange that pickup ret type ;; from fdata some day10q *) nil))) (setq fstring (format nil "L~a($@0)" (fdata-ind fd))) (if vararg (setq fstring (format nil "(VFUN_NARGS = $#,~a)" fstring))) ; (wr-h (rep-type t) " L" (fdata-ind fd) "();") ;; it is only fitting that a closure's template `format string' should in ;; fact be a closure. Takes a closure to know a closure. (cond ((fdata-closure-vars fd) (let ((fdc fd) (string fstring)) (setf fstring #'(lambda (iargs) (wr "(fcall.fun=" (or (fdata-closure-self fdc) (fdata-to-obj fdc)) ",") (wr-inline-call1 iargs string) (wr ")")))))) (let ((ans (list (argl-from-argd (fdecl argd fdecl)) (ret-from-argd (fdecl argd fdecl)) (fdecl flag fdecl) fstring))) (setf (fdata-local-template fd) ans) ans))) (defun replace-inline-by-temp (x) (let* ((type (result-type x)) (tem (get-temp type))) (wr-set-inline-loc tem x) tem)) gcl-2.6.14/comp/bo1.lsp0000755000175000017500000001044614360276512013142 0ustar cammcamm(in-package "BCOMP") (defvar *space* 0) (defmacro once-only (((v val) . res) &body body) (cond (res `(once-only ((,v,val)) (once-only ,res ,@ body))) ((and (consp val) (or (eq (car val) 'function)(eq (car val) 'quote))) `(symbol-macrolet ((,v ,val)) ,@ body)) (t (let ((w (gensym))) `(let ((,w ,val)) (symbol-macrolet ((,v ,w)) ,@ body)))))) (defun get-test (x &aux item lis res key fn) (when (<= *space* 0) (desetq (item lis . res) (cdr x)) (cond (res (desetq (key fn . res) res) (cond ((or res (not (eq key :test)) (not (and (consp fn) (member (car fn) '(quote function))))) nil) (t (cadr fn)))) (t 'eql)))) (setf (get 'assoc 'bo1) 'bo1-assoc) (defun bo1-assoc (x where &aux fn ) where (when (setq fn (get-test x)) `(funcall #'(lambda (item lis) (sloop for v in lis when (funcall #',fn (car v) item) do (return v))) ,@ (cdr x)))) (setf (get 'member 'bo1) 'bo1-member) (defun bo1-member (x where &aux fn ) where (when (setq fn (get-test x)) `(funcall #'(lambda (item lis) (sloop for v on lis when (funcall #',fn (car v) item) do (return v))) ,@ (cdr x)))) (setf (get 'get 'bo1) 'bo1-get) (defun bo1-get (x where) where (when (and (= *safety* 0) (< *space* 2)) `(funcall #'(lambda (plis key &optional dflt) (setq plis (symbol-plist plis)) (loop (cond ((null plis) (return dflt)) ((eq (car plis) key)(return (cadr plis))) (t (setq plis (cddr plis)))))) ,@ (cdr x)))) (setf (get 'mapcar 'bo1) 'bo1-mapcar) (setf (get 'mapc 'bo1) 'bo1-mapcar) (setf (get 'mapcan 'bo1) 'bo1-mapcar) (defun bo1-mapcar (x where &aux fn l coll) where (when (and (= *safety* 0) (< *space* 2)) (desetq (fn l) (cdr x)) (setq coll (cdr (assoc (car x) '((mapcar . collect) (mapc . do) (mapcan . nconc))))) (cond ((cdddr x) nil) ((and (consp fn) (member (car fn) '(quote function))) `(funcall #'(lambda (lis) (sloop for v in lis ,coll (funcall ,fn v))) ,@ (cddr x))) (t `(funcall #'(lambda (fn lis) (if (symbolp fn) (setq fn (symbol-function fn))) (sloop for v in lis ,coll (funcall fn v))) ,@ (cdr x)))))) (setf (get 'funcall 'bo1) 'bo1-funcall) (defun bo1-funcall (x where &aux fn tem args ll w binds) where (desetq (fn . args) (cdr x)) (cond ((and (consp fn) (or (eq (car fn) 'quote) (eq (car fn) 'function)) (consp (cdr fn)) (setq tem (cadr fn)) (symbolp tem)) `(,(cadr fn) ,@ args)) (tem (cond ((and (consp tem) (eq (car tem) 'lambda)) (desetq (ll) (cdr tem)) (setq ll (decode-ll ll)) (cond ((and (null (ll &key ll)) (null (ll &rest ll)) (null (ll &aux ll))) (sloop for v in (ll &required ll) do (desetq (w) args) (setq args (cdr args)) (push (list v w) binds)) (sloop for v in (ll &optional ll) do (cond (args (or (consp args) (comp-error "bad arglist in ~a " x)) (push (list (car v) (pop args)) binds)) (t (push (list (car v) (cadr v)) binds))) (cond ((caddr v) (push (list (caddr v) (not (null args))) binds)))) `(let ,(nreverse binds) ,@ (cddr tem))))))) (t nil))) (setf (get 'typep 'b1.5) 'b1.5-typep) (defun b1.5-typep (x where &aux (cd (third x)) (args (call-data-arglist cd))) where (let ((rt (result-type (nth 0 args))) (typ (nth 1 args))) (cond ((and (consp typ) (eq (car typ) 'dv) (subtypep rt (THIRD typ))) (get-object t))))) (defmacro dotimes ((var form &optional (val nil)) &rest body &aux (temp (gensym))) `(do* ((,temp ,form) (,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) ,@ (cond ((typep form 'fixnum) `((declare (fixnum ,temp ,var))))) ,@body)) (defmacro psetq (&optional var val &rest l &aux sets types decls binds) (cond ((null var) nil) ((null l) `(setq ,var ,val)) (t (loop (push `(,(gensym) ,val) binds) (push var sets) (push (caar binds) sets) (push `(type (type-of ,var) ,(caar binds)) types) (or l (return nil)) (desetq (var val) l) (setq l (cddr l))) `(let ,(nreverse binds) (declare ,@ types) (setq ,@(nreverse sets)))))) ;; ;;- Local variables: ;;- mode:lisp ;;- version-control:t ;;- End: gcl-2.6.14/comp/try1.lsp0000755000175000017500000000024514360276512013354 0ustar cammcamm(setq *load-verbose* nil) (defun compiler::boole3 (a b c) (boole a b c)) (load "sysdef.lsp") (make::make :bcomp) (load "smash-oldcmp.lsp") (setq *load-verbose* t) gcl-2.6.14/comp/utils.lsp0000755000175000017500000001134314360276512013616 0ustar cammcamm (in-package "BCOMP") (defmacro fdecl (key fd) `(nth ,(position key '(argd flag)) ,fd)) (defun comp-warn (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) (if *top-form* (format t ";~%~s is being compiled" *top-form*)) (setq *top-form* nil) (format t ";;~%Warning:") (apply 'format t fmt l)) (defun comp-error (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) (setq *hard-error* t) (format t "~%Error:") (apply 'format t fmt l)) (defun add-prop (symbol-lis prop val) (dolist-safe (v symbol-lis) (or (symbolp v) (comp-error "Can't add ~a prop ~a to non symbol ~a" val prop v)) (setf (get v prop) val))) (defun bad-proclamation () (declare (special *procl*)) (comp-error "The proclamation ~a was illegal." *procl*)) (defun proclaim1 (x &aux ptype body (*procl* x) flag val tem) (declare (special *space* *speed*)) ;; will eventually be proclaim. (declare (special *procl*)) (desetq (ptype . body) x) (case ptype (optimize (sloop for v in-list body do (cond ((atom v) (setq flag v val 3)) (t (desetq (flag val) v))) (or (typep val 'fixnum) (bad-proclamation)) (case flag (safety (if (> (the fixnum val) 0) (setq *safety* val))) (space (setq *space* val)) (speed (setq *speed* val)) (compilation-speed (setq *speed* 0)) (t (comp-warn "Unknown optimize quality ~a" flag))))) (special (dolist-safe (v body) (si::*make-special v))) (type (desetq (ptype . body) body) (setq ptype (comp-type ptype)) (add-prop body 'proclaimed-variable-type ptype)) (function (let (name ) (desetq (name . body) body) (proclaim1 `(ftype (function ,@ body) ,name)))) (ftype (desetq (ptype . body) body) (add-prop body 'proclaimed-function-declaration (increment-function-decl ptype nil))) (inline (add-prop body 'proclaimed-inline t)) (declaration (add-prop body 'proclaimed-declaration t)) (t (cond ((symbolp ptype) (cond ((setq tem (get ptype 'comp-type)) (add-prop body 'proclaimed-variable-type (comp-type ptype))) ((get ptype 'proclaimed-declaration)) (t (bad-proclamation)))) (t (bad-proclamation)))))) (defun ftype-from-fdecl (fdecl &aux (n (fdecl argd fdecl))) ;; (setq fdecl (get fname 'proclaimed-fun57qction-declaration)) (when n (let ((args (argl-from-argd n)) (ret (ret-from-argd n))) `(ftype (function ,args ,ret))))) (defun describe-fdecl(fdecl) (format t "Ftype is ~s, flags are " (ftype-from-fdecl fdecl)) (print-flag (fdecl flag fdecl))) (defun promote-arg-type (x) (setq x (comp-type x)) (case x (fixnum 'fixnum) ((t) t) ; (short-float 'short-float) ((long-float double-float ) 'double_ptr) (t (cond ((subtypep x 'fixnum) 'fixnum) (t t))))) (defvar *promoted-arg-types* #( t fixnum double_ptr ;short-float )) (defun arg-type-code (x) (cond ((eq x t) 0) ((eq x 'fixnum) 1) ((eq x 'double_ptr) 2) ; ((eq x 'short-float) 3) (t (wfs-error) 0))) (defun increment-function-decl (new-prop old-decl &aux tem args ret-types retl) ;; produce a new function-decl with prop added. (setq old-decl (list 0 (if old-decl (second old-decl) #.(flags set ans mv touch-mv) ))) (cond ((atom new-prop) (case new-prop (inline (setf (flag-p (fdecl flag old-decl) notinline) nil)) (notinline (setf (flag-p (fdecl flag old-decl) notinline) t)) (t (wfs-error))) old-decl) ((eq (car new-prop) 'function) (desetq (args . ret-types) (cdr new-prop)) (tagbody again (cond ((null ret-types) (setq retl '*)) ((atom ret-types) (comp-error "Bad return decl ~a" retl)) ((cdr ret-types) (setq retl '*)) ((eq (setq tem (car ret-types)) '*)(setq retl '*)) ((and (consp tem) (eq (car tem) 'values)) (setq ret-types (cdr tem)) (go again)) (t (setq retl (comp-type tem))))) (setf (car old-decl) (link-descriptor-from-decl args retl)) (cond ((not (eq retl '*)) (setf (flag-p (second old-decl) mv) nil))) old-decl) (t (wfs-error)))) (defun function-declaration (v) (or (symbolp v) (wfs-error)) (or (cdr (assoc v *function-decls*)) (get v 'proclaimed-function-declaration))) (defun function-return-type (fdat &aux ret fdecl) ;; returns (member *immediate-types*), T, or MV ;; (member *immediate-types*), T, *, (values t t) (values) .. (let ((fname (fdata-name fdat))) (cond ((and fname (setq fdecl (get fname 'proclaimed-function-declaration))) (setf (fdata-function-declaration fdat) fdecl) (setq ret (ret-from-argd (fdecl argd fdecl))) (cond ((eq ret '*) 'mv) (t ret))) (t 'mv)))) (defun the-list (x &aux (y x)) (sloop while x do (or (consp x) (comp-error "not a list ~a" x)) (setq x (cdr x))) y) gcl-2.6.14/comp/stmt.lsp0000755000175000017500000003004514360276512013445 0ustar cammcamm(in-package "BCOMP") ;; pass 2 c compilation (defvar *value* ;; indicates where to store the value of the current expression being ;; computed. ;; one of '(var ) ;; '(mv ) ;; '(ignore) ) (setf (get 'nil 'dv) "sLnil") (setf (get 't 'dv) "sLt") ;; This function is the main dispatch. It causes writing out of the ;; code for x. An implicit *value* is set during this write out. ;; The code for doing that is in b2-call, b2-var, b2-return, and ;; any other primitives which might return a value. Note things like ;; progn, let, prog1, all just call expr-b2 on their last term. (defun expr-b2(x &aux fd) (cond ((consp x) (setq fd (get (car x) 'b2)) (cond (fd (funcall fd x)) (t (wfs-error)))) ((typep x 'var) (unwind-set x)) ((eq x nil) (unwind-set '(dv "sLnil" nil))) ((eq x t) (unwind-set '(dv "sLt" t))) (t (wfs-error)))) (setf (get 'call 'b2) 'b2-call) (defun maybe-push-avma-bind () (sloop for v on *control-stack* do (cond ((or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) (return nil)) ((typep (car v) 'label) (loop-finish))) finally (push 'avma-bind *control-stack*) (return *control-stack*))) (defun b2-call (x &aux type-wanted (loc (second *value*)) tem avma-bind) (cond ((eq (car *value*) 'mv) (setq type-wanted 'mv)) (loc (cond ((typep loc 'var) (setq type-wanted (var-type loc))) ((and (consp loc) (eq (car loc) 'var)) (setq type-wanted (third loc))) (t (wfs-error)))) (t (setq type-wanted t))) (setq avma-bind (maybe-push-avma-bind)) (setq tem (cons 'inline-call (cdr (inline-call x type-wanted )))) (cond ((eq (car *value*) 'ignore) (unwind-set tem avma-bind)) (t (let ((*MV-N-VALUES-SET* *MV-N-VALUES-SET*)) ;; We must communicate whether or not this inline-call ;; sets multiple values, before we replace it by a temp (when (unwind-stack-p (cdr *exit*)) (if (flag-p (opt flag (cddr tem)) mv) (setq *MV-N-VALUES-SET* t)) (setq tem (replace-inline-by-temp tem))) (unwind-set tem avma-bind)))) ) (setf (get 'setq 'b2) 'b2-setq) (defun b2-setq (form &aux last) ;;(setq desk var val var val..) (do ((x (cddr form) (cddr x))) ((null x)) (setq last (car x)) (valex (list 'var last) (next-exit) (expr-b2 (second x)))) (unwind-set last)) (setf (get 'tagbody 'b2) 'b2-tagbody) (defun b2-tagbody (x &aux bod lab all-labels it (*blocks* 0) (*control-stack* *control-stack*)) (setq bod (third x)) (dolist (v bod) (when (and (consp v) (eq (car v) 'label)) (setq lab (second v)) (setf (label-ind lab) (next-label)) (push lab all-labels))) (sloop for v on *control-stack* when (or (eq (car v) 'avma-bind) (eq (car v) 'avma-bind-needed)) do (push 'inner-avma *control-stack*) (open-block) (wr "long InnerAvma=avma;") (return nil)) (setq *control-stack* (nconc all-labels *control-stack*)) (sloop for v on bod do (setq it (car v)) (valex '(ignore) (next-exit) (expr-b2 it))) ;; this should do the unwinding to the outside frame. (cond ((and (consp it) (or (eq (car it) 'return-from) (eq (car it) 'go))) ;;I don't even think this unwind-stack is necessary. ;; I don't see hwo it will be reached. (unwind-stack (cdr *exit*))) (t (expr-b2 (get-object nil)))) (close-blocks) ) (setf (get 'label 'b2) 'b2-label) (defun b2-label (x &aux (lab (second x))) (or (typep lab 'label) (wfs-error)) (wr-label x) (wr ";")) (setf (get 'go 'b2) 'b2-go) (defun b2-go (x &aux lab) (setq lab (cadr x)) (let ((upto (member lab *control-stack* :test 'eq))) (or upto (wfs-error)) (unwind-stack upto) (wr-go lab))) (setf (get 'if 'b2) 'b2-if) (defmacro ifb (x y) `(nth ,(position x '(test then else)) (cddr ,y))) (defun dv-p (x) (and (consp x) (eq (car x) 'dv))) (defun trans-if (x &aux test then else t-test t-then t-else lab new (desk (second x))) ;; transform an if expression so that the TEST is neither an IF nor a CONSTANT. (desetq (test then else) (cddr x)) (cond ((and (consp test) (eq (car test) 'if)) (setq t-then (ifb then test) t-else (ifb else test) t-test (ifb test test)) (setq lab (make-label)) (cond ((dv-p t-then)) ((dv-p t-else) (setq t-test (do-not t-test)) (rotatef t-then t-else)) (t (return-from trans-if x))) (setq new (cond ((null (third t-then)) `(if ,desk,t-test (progn ,desk ((nlabel ,lab) ,else)) (if ,desk ,t-else ,then (go ,lab) ))) (t `(if ,(second x),t-test (progn ,desk ((nlabel ,lab) ,then)) (if ,desk ,t-else (go ,lab) ,else)))))) ((dv-p test) (setq new (if (third test) then else)) (cond ((and (consp new) (eq (car new) 'if)) (setq new (trans-if new)))) (return-from trans-if new))) (cond (new (trans-if new)) (t x))) (defun do-not (x) `(call ,(make-desk 'boolean) ,(make-call-data 'not (list x) nil nil))) (setf (get 'nlabel 'b2) 'b2-nlabel) (defun b2-nlabel (x) (push (second x) *control-stack*) (wr-label (second x)) (wr ";")) (defun b2-if (form &aux test then else (*control-stack* *control-stack*) avma-bind) (setq form (trans-if form)) (unless (and (consp form) (eq (car form) 'if)) (return-from b2-if (expr-b2 form))) (desetq (test then else) (cddr form)) (setq avma-bind (maybe-push-avma-bind)) (let ((tem (inline-arg test 'boolean nil (cons nil nil)))) (when avma-bind (cond ((eq (car avma-bind) 'avma-bind-needed) (let ((tem1 (get-temp 'boolean))) (valex (list 'var tem1) (next-exit) (unwind-set tem avma-bind)))) (t (remove-avma-bind avma-bind)))) (wr-nl "if(" tem "){")) (let ((*blocks* 0)) (expr-b2 then) (close-blocks) (wr "}")) (unless (and (or (atom else) (eq (car else) 'dv)) (eq (car *value*) 'ignore) (eq (car *exit*) 'next) (not (unwind-stack-p (cdr *exit*)))) (let ((*blocks* 0)) (wr-nl "else ") (open-block) (expr-b2 else) (close-blocks))) ) (setf (get 'block 'b2) 'b2-block) (defun b2-block (x &aux sform block bod dsk end-label (*control-stack* *control-stack*)) (desetq (sform dsk block bod) x) (push block *control-stack*) (setq end-label (make-label)) (setf (block-exit block) (cond ((eq (car *exit*) 'next) (cons end-label (cdr *exit*))) (t *exit*))) (setf (block-value block) *value*) (valex *value* (block-exit block) (progn-b2 bod)) (cond ((label-ind end-label) (wr-label end-label) (wr ";")))) (setf (get 'return-from 'b2) 'b2-return-from) (defun b2-return-from (x &aux block form tem) (desetq (block form) (cddr x)) (cond ((setq tem (member block *control-stack*)) (valex (block-value block) (block-exit block) (expr-b2 form))) (t (wfs-error)))) (setf (get 'the 'b2) 'b2-the) (defun b2-the (x) (expr-b2 (third x))) (defun fdata-to-obj (fdat ) (or (typep fdat 'fdata) (wfs-error)) (or (fdata-ind fdat) (setf (fdata-ind fdat) (incf *next-function*))) (cond ((fdata-closure-vars fdat) (let ((args (mapcar #'(lambda (x) (list 'var (var-ind x))) (fdata-closure-vars fdat)))) (list 'inline-call (list* (get-load-time-form 'si::%memory) fdat args) '(*) t #.(flags ans) (format nil "MakeClosure(~a,~a,$@0)" (length (fdata-closure-vars fdat)) (fdata-to-argd fdat) )))) (t (list 'inline-call (list fdat (fdata-to-argd fdat) (get-load-time-form 'si::%memory) ) '(t fixnum t) t #.(flags ans constantp) "MakeAfun($0,$1,$2)" )))) (setf (get 'pointer-to-funobj 'b2) 'b2-pointer-to-funobj) (defun b2-pointer-to-funobj (x &aux ans tem) (setq tem (second x)) (cond ((and (consp tem) (eq (car tem) 'lambda-block)) (setq tem (second tem)))) (setq ans (fdata-to-obj tem)) (unwind-set ans)) (setf (get 'lambda-block 'b2) 'b2-lambda-block) (setf (get 'lambda 'b2) 'b2-lambda-block) (defun b2-lambda-block (x &aux result (*used-names* *used-names*)) (let ((fdat (second x))) (unless (fdata-ind fdat) (setf (fdata-ind fdat) (mangle-name (fdata-name fdat) 'function))) (push (list 'local-function x) *local-funs*) ; (wr-h "static object " fdat "();") (setq result (fdata-to-obj fdat)) (unwind-set result))) (defun might-touch-mv (x) ;; This needs expanding to handle functions like LIST,+, ;; .. etc which do not touch mv (not (or (atom x) (eq (car x) 'var) (eq (car x) 'dv)))) (setf (get 'values 'b2) 'b2-values) (defun b2-values (x &aux (argl (third x)) avma-bind) (cond ((eq (car *value*) 'mv) (setq avma-bind (maybe-push-avma-bind)) (let ((args (car (inline-args argl '(*))))) (sloop for v on args when (and (consp (car v)) (might-touch-mv (car v))) do (setf (car v) (replace-inline-by-temp (car v)))) (when (cdr args) (wr-nl "{obj *MVptr = &fcall.values[1];" "*MVptr =" (second args) ";") (dolist (v (cddr args))(wr "*(++MVptr) = " v ";")) (wr "}")) (wr " fcall.nvalues=" (length args) ";") (let ((*MV-N-VALUES-SET* t)) (unwind-set (if args (car args) (get-object nil)) avma-bind)) )) (argl (expr-b2 (car argl))) (t (expr-b2 (get-object nil))))) (setf (get 'call-set-mv 'b2) 'b2-call-set-mv) (defun b2-call-set-mv (x &aux form) ;; invoke form setting up multiple-values. ;; x == (call-set-mv desk form) (setq form (third x)) (valex `(mv (var "fcall.values[0]")) (next-exit) (expr-b2 form))) (setf (get 'progv 'b2) 'b2-progv) (defun b2-progv (x &aux binds body) (desetq (binds body) (cddr x)) (let ((tem (get-temp 'fixnum))) (valex `(var ,tem) (next-exit) (expr-b2 binds)) (let ((*control-stack* (cons `(progv-bind ,tem) *control-stack*))) (progn-b2 body)))) (setf (get 'flet 'b2) 'b2-flet) (defun b2-flet (x &aux binds body fd) (desetq (binds body) (cddr x)) (sloop for v in binds do (setq fd (cadr (third v))) (or (typep fd 'fdata) (wfs-error)) (or (fdata-ind fd) (setf (fdata-ind fd) (incf *next-function*))) (valex '(ignore) (next-exit) (expr-b2 (third v))) ) (progn-b2 body)) (defun do-assign-args (x &aux reqs) (setq reqs (ll &required (fdata-ll *fdata*))) (or (eql (length x) (length reqs)) (comp-error "Wrong number of args in call to ~a " (fdata-name *fdata*))) (sloop for v in reqs for val in x do (wr-set-inline-loc (car v) val) ) ) (defvar *aet-types* #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT DOUBLE-FLOAT SIGNED-CHAR UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) (defun aet-type (i) (aref *aet-types* i)) (defun aet-c-type (type) (ecase type ((t) "object") ((string-char signed-char) "char") (fixnum "fixnum") (unsigned-char "unsigned char") (unsigned-short "unsigned short") (signed-short "short") (unsigned-short "unsigned short") (double-float "double") (short-float "float"))) (defun do-structure-ref (iargs &aux x name ind (index 0) sd) (declare (fixnum index)) (setq x (car iargs) name (second iargs) ind (third iargs)) (or (and (consp ind) (eq (car ind)'inline-loc) (dv-p (third ind))) (wfs-error)) (setq index (third (third ind))) (setq sd (get (third name) 'si::s-data)) (or sd (wfs-error)) (let* ((aet (aref (si::s-data-raw sd) index)) (c-type (aet-c-type (aref *aet-types* aet))) (pos (aref (si::s-data-slot-position sd) index))) (wr "STREF(" c-type "," x "," pos")"))) (defun do-structure-set (iargs) (let ((rargs (butlast iargs))) (do-structure-ref rargs) (wr " = " (car (last iargs))))) (defun si::setf-structure-access (struct type index newvalue) (case type (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) (vector `(si:aset ,struct ,index ,newvalue)) (t (let ((sd (get type 'si::s-data))) (when sd (let ((res-type (comp-type(aet-type (aref (si::s-data-raw sd) index))))) (cond ((eq res-type t) `(si::structure-set ,struct ',type ,index ,newvalue)) (t `(the ,res-type (si::structure-set (the (struct ,res-type),struct) ',type ,index (the ,res-type ,newvalue))))))))))) (setf (get 'eval-when 'b2) 'b2-eval-when) (defun b2-eval-when (x) (progn-b2 (cddr x))) gcl-2.6.14/comp/opts.lsp0000755000175000017500000005252714360276512013454 0ustar cammcamm(in-package "BCOMP") (defopt * ((t t) t #.(flags ans safe) "number_times($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)*(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)*(double)($1)") ((integer integer) integer #.(flags rfa is safe) "mulii($0,$1)") ((integer integer integer) integer #.(flags rfa is safe) "mulii($0,mulii($1,$2))") ((fixnum integer) integer #.(flags rfa is safe) "mulsi($0,$1)") ((fixnum fixnum) fixnum #.(flags safe) "($0)*($1)")) (defopt + ((t t) t #.(flags ans safe) "number_plus($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+(double)($1)") ((integer integer) integer #.(flags rfa is safe) "addii($0,$1)") ((integer integer integer) integer #.(flags rfa is safe) "addii($0,addii($1,$2))") ((fixnum fixnum) fixnum #.(flags safe) "($0)+($1)")) (defopt - ((t) t #.(flags ans safe) "number_negate($0)") ((t t) t #.(flags ans safe) "number_minus($0,$1)") ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-(double)($1)") ((fix-or-sf-or-df) short-float #.(flags safe) "-(double)($0)") ((fix-or-sf-or-df) double-float #.(flags safe) "-(double)($0)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-(double)($1)") ((integer integer) integer #.(flags rfa is safe) "subii($0,$1)") ((integer) integer #.(flags rfa is safe) "subii(gzero,$0)") ((fixnum fixnum) fixnum #.(flags safe) "($0)-($1)") ((fixnum) fixnum #.(flags safe) "-($0)")) (defopt / ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags rfa safe) "(double)($0)/(double)($1)") ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags rfa safe) "(double)($0)/(double)($1)") ((fixnum fixnum) fixnum #.(flags ) "($0)/($1)") ) (defopt /= ((t t) boolean #.(flags safe) "number_compare($0,$1)!=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)!=($1)")) (defopt 1+ ((t) t #.(flags ans safe) "one_plus($0)") ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+1") ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+1") ((fixnum) fixnum #.(flags safe) "($0)+1")) (defopt 1- ((t) t #.(flags ans safe) "one_minus($0)") ((fixnum) fixnum #.(flags safe) "($0)-1") ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-1") ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-1")) (defopt < ((t t) boolean #.(flags safe) "number_compare($0,$1)<0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<($1)")) (defopt <= ((t t) boolean #.(flags safe) "number_compare($0,$1)<=0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<=($1)")) (defopt = ((t t) boolean #.(flags safe) "number_compare($0,$1)==0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)==0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)==($1)")) (defopt > ((t t) boolean #.(flags safe) "number_compare($0,$1)>0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>($1)")) (defopt >= ((t t) boolean #.(flags safe) "number_compare($0,$1)>=0") ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>=0") ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>=($1)")) (defopt APPEND ((t t) t #.(flags ans safe) "append($0,$1)")) (defopt aref-2d (((array t) fixnum fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($3)+$2]")) (defopt AREF ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") ((t t) t #.(flags ans) "aref1($0,fix($1))") (((array t) fixnum) t #.(flags) "($0)->v.Body[$1]") (((array character) fixnum) character #.(flags rfa) "($0)->ust.Body[$1]") (((array fixnum) fixnum) fixnum #.(flags rfa) "($0)->fixa.Body[$1]") (((array unsigned-char) fixnum) fixnum #.(flags rfa) "($0)->ust.Body[$1]") (((array signed-char) fixnum) fixnum #.(flags rfa) "SIGNED_CHAR(($0)->ust.Body[$1])") (((array unsigned-short) fixnum) fixnum #.(flags rfa) "((unsigned short *)($0)->ust.Body)[$1]") (((array signed-short) fixnum) fixnum #.(flags rfa) "((short *)($0)->ust.Body)[$1]") (((array short-float) fixnum) short-float #.(flags rfa) "($0)->sfa.Body[$1]") (((array long-float) fixnum) double-float #.(flags rfa) "($0)->lfa.Body[$1]") ((t t t) t #.(flags ans) "@0;aref($0,fix($1)*($0)->a.Dims[1]+fix($2))") (((array t) fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]") (((array character) fixnum fixnum) character #.(flags rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]") (((array fixnum) fixnum fixnum) fixnum #.(flags rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]") (((array short-float) fixnum fixnum) short-float #.(flags rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]") (((array long-float) fixnum fixnum) double-float #.(flags rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]")) (defopt ARRAY-TOTAL-SIZE ((t) fixnum #.(flags rfa) "(($0)->st.Dim)")) (defopt ARRAYP ((t) boolean #.(flags safe) "@0;type_of($0)==t_array|| type_of($0)==t_vector|| type_of($0)==t_string|| type_of($0)==t_bitvector")) (defopt SYSTEM:ASET ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") ((t t t) t #.(flags set) "aset1($0,fix($1),$2)") (((array t) fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)") (((array character) fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)") (((array fixnum) fixnum fixnum) fixnum #.(flags set rfa) "($0)->fixa.Body[$1]= ($2)") (((array signed-short) fixnum fixnum) fixnum #.(flags set rfa) "((short *)($0)->ust.Body)[$1]=($2)") (((array signed-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") (((array unsigned-short) fixnum fixnum) fixnum #.(flags set rfa) "((unsigned short *)($0)->ust.Body)[$1]=($2)") (((array unsigned-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") (((array short-float) fixnum short-float) short-float #.(flags set rfa) "($0)->sfa.Body[$1]= ($2)") (((array long-float) fixnum double-float) double-float #.(flags set rfa) "($0)->lfa.Body[$1]= ($2)") ((t t t t) t #.(flags set) "@0;aset($0,fix($1)*($0)->a.Dims[1]+fix($2),$3)") (((array t) fixnum fixnum t) t #.(flags set) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array character) fixnum fixnum character) character #.(flags set rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array short-float) fixnum fixnum short-float) short-float #.(flags set rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") (((array long-float) fixnum fixnum double-float) double-float #.(flags set rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)")) (defopt ash ((fixnum fixnum) fixnum #.(flags ) "@1;($1 > 0 ? ($0) <<( $1 ): ($0) >> (-($1)))")) (defopt ATOM ((t) boolean #.(flags safe) "type_of($0)!=t_cons")) (defopt BIT-VECTOR-P ((t) boolean #.(flags safe) "(type_of($0)==t_bitvector)")) (defopt BOOLE3 ((fixnum fixnum fixnum) fixnum #.(flags rfa safe) wr-inline-boole3)) (defopt BOUNDP ((t) boolean #.(flags) "($0)->s.Bind!=OBJNULL")) (defopt CAAAAR ((t) t #.(flags) "Mcaaaar($0)")) (defopt CAAADR ((t) t #.(flags) "Mcaaadr($0)")) (defopt CAAAR ((t) t #.(flags) "Mcaaar($0)")) (defopt CAADAR ((t) t #.(flags) "Mcaadar($0)")) (defopt CAADDR ((t) t #.(flags) "Mcaaddr($0)")) (defopt CAADR ((t) t #.(flags) "Mcaadr($0)")) (defopt CAAR ((t) t #.(flags) "Mcaar($0)")) (defopt CADAAR ((t) t #.(flags) "Mcadaar($0)")) (defopt CADADR ((t) t #.(flags) "Mcadadr($0)")) (defopt CADAR ((t) t #.(flags) "Mcadar($0)")) (defopt CADDAR ((t) t #.(flags) "Mcaddar($0)")) (defopt CADDDR ((t) t #.(flags) "Mcadddr($0)")) (defopt CADDR ((t) t #.(flags) "Mcaddr($0)")) (defopt CADR ((t) t #.(flags) "Mcadr($0)")) (defopt CAR ((t) t #.(flags) "Mcar($0)")) (defopt CDAAAR ((t) t #.(flags) "Mcdaaar($0)")) (defopt CDAADR ((t) t #.(flags) "Mcdaadr($0)")) (defopt CDAAR ((t) t #.(flags) "Mcdaar($0)")) (defopt CDADAR ((t) t #.(flags) "Mcdadar($0)" )) (defopt CDADDR ((t) t #.(flags) "Mcdaddr($0)")) (defopt CDADR ((t) t #.(flags) "Mcdadr($0)")) (defopt CDAR ((t) t #.(flags) "Mcdar($0)")) (defopt CDDAAR ((t) t #.(flags) "Mcddaar($0)")) (defopt CDDADR ((t) t #.(flags) "Mcddadr($0)")) (defopt CDDAR ((t) t #.(flags) "Mcddar($0)")) (defopt CDDDAR ((t) t #.(flags) "Mcdddar($0)")) (defopt CDDDDR ((t) t #.(flags) "Mcddddr($0)")) (defopt CDDDR ((t) t #.(flags) "Mcdddr($0)")) (defopt CDDR ((t) t #.(flags) "Mcddr($0)")) (defopt CDR ((t) t #.(flags) "Mcdr($0)")) (defopt CHAR ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags) "code_char(($0)->ust.Body[fix($1)])") ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) (defopt CHAR-CODE ((character) fixnum #.(flags rfa safe) "($0)")) (defopt SYSTEM:CHAR-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) (defopt CHAR/= ((character character) boolean #.(flags safe) "($0)!=($1)") ((t t) boolean #.(flags) "!eql($0,$1)") ((t t) boolean #.(flags) "char_code($0)!=char_code($1)")) (defopt CHAR< ((character character) boolean #.(flags safe) "($0)<($1)")) (defopt CHAR<= ((character character) boolean #.(flags safe) "($0)<=($1)")) (defopt CHAR= ((t t) boolean #.(flags) "eql($0,$1)") ((t t) boolean #.(flags) "char_code($0)==char_code($1)") ((character character) boolean #.(flags) "($0)==($1)")) (defopt CHAR> ((character character) boolean #.(flags safe) "($0)>($1)")) (defopt CHAR>= ((character character) boolean #.(flags safe) "($0)>=($1)")) (defopt CHARACTERP ((t) boolean #.(flags safe) "type_of($0)==t_character")) (defopt CODE-CHAR ((fixnum) character #.(flags safe rfa) "($0)") ((t) character #.(flags rfa) "fix($0)")) (defopt CONS ((t t) t #.(flags ans constantp safe) "make_cons($0,$1)") ((t t) dynamic-extent #.(flags ans safe) "ON_STACK_CONS($0,$1)")) (defopt CONSP ((t) boolean #.(flags safe) "type_of($0)==t_cons")) (defopt COS ((double-float) double-float #.(flags rfa safe) "cos($0)")) (defopt DIGIT-CHAR-P ((character) boolean #.(flags safe) "@0; (($0) <= '9' && ($0) >= '0')")) (defopt ELT ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags ans) "elt($0,fix($1))")) (defopt SYSTEM:ELT-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "elt_set($0,fix($1),$2)")) (defopt ENDP ((t) boolean #.(flags) "($0)==sLnil")) (defopt EQ ((t t) boolean #.(flags safe) "($0)==($1)") ((fixnum fixnum) boolean #.(flags safe) "0")) (defopt EQL ((t t) boolean #.(flags safe) "eql($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EQUAL ((t t) boolean #.(flags safe) "equal($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EQUALP ((t t) boolean #.(flags safe) "equalp($0,$1)") ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) (defopt EXPT ((t t) t #.(flags ans safe) "number_expt($0,$1)") ((integer integer) integer #.(flags is safe) "powerii($0,$1)") ((fixnum fixnum) fixnum #.(flags safe) (lambda (l &aux (x1 (car l))tem) (if (and (consp x1) (eq (car x1) 'inline-loc) (consp (setq tem (third x1)))(eq 'dv (car tem)) (eql (third tem) 2)) (wr-inline-call1 l "(1 << ($1))") (wr-inline-call1 l "fixnum_expt($@0)"))))) (defopt FILL-POINTER ((t) fixnum #.(flags rfa) "(($0)->st.Fillp)")) (defopt SYSTEM:FILL-POINTER-SET ((t fixnum) fixnum #.(flags set rfa) "(($0)->st.Fillp)=($1)")) (defopt FIRST ((t) t #.(flags) "Mcar($0)")) (defopt SYSTEM:FIXNUMP ((t) boolean #.(flags safe) "type_of($0)==t_fixnum") ((fixnum) boolean #.(flags safe) "1")) (defopt FLOAT ((fix-or-sf-or-df) double-float #.(flags safe) "((doublefloat)($0))") ((fix-or-sf-or-df) short-float #.(flags safe) "((shortfloat)($0))")) (defopt FLOATP ((t) boolean #.(flags safe) "@0;type_of($0)==t_shortfloat||type_of($0)==t_doublefloat")) (defopt FLOOR ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)/($1):ifloor($0,$1))")) (defopt FOURTH ((t) t #.(flags) "Mcadddr($0)")) (defopt COMPILER::FP-OK ((t) fixnum #.(flags set) "@0;(type_of($0)==t_stream? (int)(($0)->sm.Fp): 0 )") ((stream) fixnum #.(flags set) "(($0)->sm.Fp)")) (defopt GET ((t t t) t #.(flags safe) "get($0,$1,$2)") ((t t) t #.(flags safe) "get($0,$1,sLnil)")) (defopt INTEGERP ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum||type_of($0)==t_bignum")) (defopt KEYWORDP ((t) boolean #.(flags safe) "@0;(type_of($0)==t_symbol&&($0)->s.Hpack==keyword_package)")) (defopt COMPILER::LDB1 ((fixnum fixnum fixnum) fixnum #.(flags safe) "((((~(-1 << ($0))) << ($1)) & ($2)) >> ($1))")) (defopt LENGTH ((t) fixnum #.(flags rfa safe) "length($0)") (((array t)) fixnum #.(flags rfa) "($0)->v.Fillp") (((vector character)) fixnum #.(flags rfa) "($0)->v.Fillp")) (defopt LIST ((t *) t #.(flags ans safe constantp) "list($#,$@0)") (() t #.(flags ans safe constantp) "sLnil") ) (defopt LIST* ((t *) t #.(flags ans safe constantp) "listA($#,$@0)")) (defopt LISTP ((t) boolean #.(flags constantp safe) "@0;type_of($0)==t_cons||($0)==sLnil")) (defopt LOGAND ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) & ($1))")) (defopt LOGIOR ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) | ($1))")) (defopt LOGNOT ((fixnum) fixnum #.(flags rfa safe) "(~($0))")) (defopt COMPILER::LONG-FLOAT-P ((t) boolean #.(flags safe) "type_of($0)==t_doublefloat")) (defopt MAKE-LIST ((fixnum) dynamic-extent #.(flags ans safe) "@0;(ALLOCA_CONS($0),ON_STACK_MAKE_LIST($0))")) (defopt MAX ((t t) t #.(flags safe) "@01;(number_compare($0,$1)>=0?($0):$1)") ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)>=($1)?($0):$1")) (defopt MIN ((t t) t #.(flags safe) "@01;(number_compare($0,$1)<=0?($0):$1)") ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)<=($1)?($0):$1")) (defopt MINUSP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)>0") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)<0")) (defopt MOD ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)%($1):imod($0,$1))")) (defopt SYSTEM:MV-REF ((fixnum) t #.(flags ans set safe) "(MVloc[($0)])")) (defopt NCONC ((t t) t #.(flags set safe) "nconc($0,$1)")) (defopt NOT ((t) boolean #.(flags safe) "($0)==sLnil") ((boolean) boolean #.(flags safe) "!($0)")) (defopt NREVERSE ((t) t #.(flags ans set safe) "nreverse($0)")) (defopt NTH ((t t) t #.(flags safe) "nth(fixint($0),$1)") ((fixnum t) t #.(flags safe) "nth($0,$1)") ((t t) t #.(flags) "nth(fix($0),$1)")) (defopt NTHCDR ((t t) t #.(flags safe) "nthcdr(fixint($0),$1)") ((fixnum t) t #.(flags safe) "nthcdr($0,$1)") ((t t) t #.(flags) "nthcdr(fix($0),$1)")) (defopt NULL ((t) boolean #.(flags safe) "($0)==sLnil")) (defopt NUMBERP ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum|| type_of($0)==t_bignum|| type_of($0)==t_ratio|| type_of($0)==t_shortfloat|| type_of($0)==t_doublefloat|| type_of($0)==t_complex")) (defopt PLUSP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)<0") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)>0")) (defopt PRIN1 ((t t) t #.(flags set safe) "prin1($0,$1)") ((t) t #.(flags set safe) "prin1($0,sLnil)")) (defopt PRINC ((t t) t #.(flags set safe) "princ($0,$1)") ((t) t #.(flags set safe) "princ($0,sLnil)")) (defopt PRINT ((t t) t #.(flags set safe) "print($0,$1)") ((t) t #.(flags set safe) "print($0,sLnil)")) (defopt PROBE-FILE ((t) boolean #.(flags safe) "(file_exists($0))")) (defopt SYSTEM:PUTPROP ((t t t) t #.(flags set safe) "putprop($0,$1,$2)")) (defopt COMPILER::QFEOF ((fixnum) boolean #.(flags set) "(feof((FILE *)($0)))")) (defopt COMPILER::QGETC ((fixnum) fixnum #.(flags set rfa) "($0=getc((FILE *)($0)))")) (defopt COMPILER::QPUTC ((fixnum fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))") ((character fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))")) (defopt COMPILER::READ-BYTE1 ((t t) t #.(flags ans set) "read_byte1($0,$1)")) (defopt COMPILER::READ-CHAR1 ((t t) t #.(flags ans set) "read_char1($0,$1)")) (defopt REM ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,-1)") ((integer fixnum) fixnum #.(flags rfa is safe) "(FIXtemp=(int)dvmdii($0,stoi($1),-1), (signe(FIXtemp)> 0 ? (int) ((GEN)FIXtemp)[2] : (signe(FIXtemp)< 0 ? -(int)((GEN)FIXtemp)[2] : 0)))") #+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($0)%($1)")) (defopt REMPROP ((t t) t #.(flags set safe) "remprop($0,$1)")) (defopt REST ((t) t #.(flags) "Mcdr($0)")) (defopt REVERSE ((t) t #.(flags ans safe) "reverse($0)")) (defopt RPLACD ((t t) t #.(flags set) "@0;($0->c.Cdr=$1,$0)")) (defopt RPLACA ((t t) t #.(flags set) "@0;($0->c.Car=$1,$0)")) (defopt SCHAR ((t t) t #.(flags ans safe) "elt($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "elt($0,$1)") ((t t) t #.(flags rfa) "code_char(($0)->ust.Body[fix($1)])") ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) (defopt SYSTEM:SCHAR-SET ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) (defopt SECOND ((t) t #.(flags) "Mcadr($0)")) (defopt SYSTEM:SET-MV ((fixnum t) t #.(flags ans set safe) "(MVloc[($0)]=($1))")) (defopt COMPILER::SHIFT<< ((fixnum fixnum) fixnum #.(flags safe) "(($0) << ($1))")) (defopt COMPILER::SHIFT>> ((fixnum fixnum) fixnum #.(flags safe) "(($0) >> (- ($1)))")) (defopt COMPILER::SHORT-FLOAT-P ((t) boolean #.(flags safe) "type_of($0)==t_shortfloat")) (defopt COMPILER::SIDE-EFFECTS (nil t #.(flags ans set safe) "Ct")) (defopt SIN ((double-float) double-float #.(flags rfa safe) "sin($0)")) (defopt SYSTEM:SPUTPROP ((t t t) t #.(flags set safe) "sputprop($0,$1,$2)")) (defopt COMPILER::STACK-CONS ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), STcons$0.Cdr=($2),(object)&STcons$0)") ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), STcons$0.Cdr=($2),(object)&STcons$0)")) (defopt STRING ((t) t #.(flags ans safe) "coerce_to_string($0)")) (defopt STRINGP ((t) boolean #.(flags safe) "type_of($0)==t_string")) (defopt SYSTEM:STRUCTURE-DEF ((t) t #.(flags) "($0)->str.Def")) (defopt SYSTEM:STRUCTURE-REF ((t t fixnum) t #.(flags ans safe) "structure_ref($0,$1,$2)") ((t t fixnum) t #.(flags ) do-structure-ref) (((struct fixnum) t fixnum) fixnum #.(flags ) do-structure-ref) (((struct character) t fixnum) character #.(flags ) do-structure-ref) (((struct double-float) t fixnum) double-float #.(flags ) do-structure-ref) (((struct short-float) t fixnum) short-float #.(flags ) do-structure-ref) ) (defopt SYSTEM:STRUCTURE-SET ((t t fixnum t) t #.(flags set safe) "structure_set($0,$1,$2,$3)") ((t t fixnum t) t #.(flags set ) do-structure-set) (((struct fixnum) t fixnum fixnum) fixnum #.(flags set ) do-structure-set) (((struct character) t fixnum character) character #.(flags set ) do-structure-set) (((struct double-float) t fixnum double-float) double-float #.(flags set ) do-structure-set) (((struct short-float) t fixnum short-float) short-float #.(flags set ) do-structure-set) ) (defopt SYSTEM:STRUCTUREP ((t) boolean #.(flags safe) "type_of($0)==t_structure")) (defopt COMPILER::SUBLIS1 ((t t t) t #.(flags ans set safe) compiler::sublis1-inline)) (defopt SVREF ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") ((t t) t #.(flags) "($0)->v.Body[fix($1)]") ((t fixnum) t #.(flags) "($0)->v.Body[$1]")) (defopt SYSTEM:SVSET ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") ((t t t) t #.(flags set) "(($0)->v.Body[fix($1)]=($2))") ((t fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)")) (defopt COMPILER::SYMBOL-LENGTH ((t) fixnum #.(flags rfa safe) "@0;(type_of($0)==t_symbol ? ($0)->s.Fillp :not_a_variable(($0)))")) (defopt SYMBOL-NAME ((t) t #.(flags ans safe) "symbol_name($0)")) (defopt SYMBOL-PLIST ((t) t #.(flags) "(($0)->s.Plist)")) (defopt SYMBOLP ((t) boolean #.(flags safe) "type_of($0)==t_symbol")) (defopt TAN ((double-float) double-float #.(flags rfa safe) "tan($0)")) (defopt TERPRI ((t) t #.(flags set safe) "terpri($0)") (nil t #.(flags set safe) "terpri(sLnil)")) (defopt THIRD ((t) t #.(flags) "Mcaddr($0)")) (defopt TRUNCATE ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,0)") #+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($1)/($2)") ((fix-or-sf-or-df) fixnum #.(flags safe) "(fixnum)($0)")) (defopt COMPILER::VECTOR-TYPE ((t fixnum) boolean #.(flags safe) "@0;(type_of($0) == t_vector && ($0)->v.Elttype == ($1))")) (defopt VECTORP ((t) boolean #.(flags safe) "@0;type_of($0)==t_vector|| type_of($0)==t_string|| type_of($0)==t_bitvector")) (defopt WRITE-CHAR ((t) t #.(flags set) "@0;(writec_stream(char_code($0),Vstandard_output->s.Bind),($0))")) (defopt ZEROP ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)==0") ((integer) boolean #.(flags rfa safe) "lgef($0)==2") ((fix-or-sf-or-df) boolean #.(flags safe) "($0)==0")) gcl-2.6.14/comp/wr.lsp0000755000175000017500000003236614360276512013116 0ustar cammcamm(in-package "BCOMP") (defmacro wr (&rest l) `(progn ,@ (mapcar #'(lambda (x) (if (stringp x) `(princ ,x *c-output*) `(wr1 ,x))) l ))) (defmacro wr-nl (&rest l) `(wr " " ,@l)) (defmacro wr-h (&rest l) `(progn (princ " " *h-output*) ,@ (mapcar #'(lambda (x) (if (stringp x) `(princ ,x *h-output*) `(wr1-h ,x))) l))) (defun wr1 (x ) (cond ((or (typep x 'fixnum)(stringp x)) (princ x *c-output*)) ((consp x) (or (symbolp (car x)) (wfs-error)) (let ((fd (get (car x) 'wr))) (or fd (wfs-error)) (funcall fd x))) ((typep x 'var) (cond ((var-clb x) (wr "ClosRef(" (list 'closure-var-loc x) ")")) ((var-special-p x) (or (var-ind x) (wfs-error)) (cond ((= *safety* 0) (wr "("(var-ind x)")->s.Bind" )) (t (wr "symbol_value("(var-ind x)")" )))) (t (or (var-ind x) (next-cvar x)) (cond ((stringp (var-ind x)) (wr (var-ind x))) (t (wr "V" (var-ind x))))))) ((eq t x)(wr "Ct")) ((eq nil x)(wr "Cnil")) ((typep x 'label) (or (label-ind x) (setf (label-ind x) (next-label))) (wr (label-ind x))) ((typep x 'fdata) (let ((i (fdata-ind x))) (if (stringp i) (wr i) (wr "L" i)))) (t (wfs-error)))) (defun wr1-h (x &aux (*c-output* *h-output*)) (wr1 x)) (setf (get 'dv 'wr) 'wr-dv) (setf (get 'd_eval 'wr) 'wr-dv) (defun add-data (x &aux tem) (or (and (consp x) (or (eq (car x) 'dv) (eq (car x) 'd_eval))) (wfs-error)) (let ((item (third x))) (unless (second x) (cond ((and (symbolp item) (setq tem (get item 'dv))) (setf (second x) tem)) ((and (typep item 'fixnum) (eql 0 (logand #. (lognot 1023) (the fixnum item)))) (setf (cadr x) (format nil "small_fixnum(~a)" item))) (t (setf (second x) *next-data*) (push-data (car x) (third x))))) x)) ;; Some things namely the keyword mechanism REQUIRES a constant which ;; has an index. This means that named ones will have to get an index ;; We could smash this place (defun get-dv-index (x) ;; a (dv which may have a string. We put an index in the fourth place.) (cond ((typep (second x) 'fixnum) (second x)) ((cdddr x) (fourth x)) (t (setq x (nconc x (list *next-data*))) (push-data (car x) (third x))))) (defun wr-dv (x) (let ((tem (second x))) (cond (tem (cond ((typep tem 'fixnum) (wr "VV[" tem"]")) (t (wr tem)))) (t (add-data x) (wr-dv x))))) (setf (get 'var 'wr) 'wr-var) (defun wr-var (x) (cond ((and (consp x) (eq (car x) 'var)) (wr-vind (second x))) (t (wfs-error)))) (defun wr-vind (x) (if (stringp x) (wr x) (wr "V" x))) (setf (get 'closure-var-loc 'wr) 'wr-closure-var-loc) (defun wr-closure-var-loc (x &aux (var (second x))) (cond ((member var *closure-vars*) (wr "CLvars->") (or (and (consp (var-ind var)) (eq (car (var-ind var)) 'kw)) (wfs-error)) (wr-vind (second (var-ind var)))) (t (wr-vind (var-ind var))))) (setf (get 'key-var 'wr) 'wr-key-var) (defun wr-key-var (x &aux (v (second x)) tem) (or (typep v 'var) (wfs-error)) (cond ((setq tem (var-special-p v)) (wr tem)) (t (wr-vind (var-ind v))))) (setf (get 'vcs 'wr) 'wr-vcs) (defun wr-vcs(x) (wr "cs[" (second x)"]")) (setf (get 'kw 'wr) 'wr-kw) (defun wr-kw(x) (wr "k.") (wr-vind (second x))) (setf (get 'vk 'wr) 'wr-vk) (defun wr-vk (x) (wr "&VK" (second x) "key")) (defun wr-comment (message &optional (symbol nil)) (wr " /* " message) (and symbol (wr (mangle symbol))) (wr " */ ") nil) (setf (get 'label 'wr) 'wr-label) (defun wr-label (n &aux) (when (consp n) (or (eq (car n) 'label) (wfs-error)) (setq n (second n))) (wr " LA" n ": ")) (defun wr-go (n) (if (typep n 'label) (or (label-ind n) (setq n (setf (label-ind n) (next-label))))) (wr "goto LA" n ";")) (defun wr-list (l) (do ((v l (cdr v))) ((null v)) (wr (car v)) (or (null (cdr v)) (wr ",")))) (setf (get 'next-var-arg 'wr) 'wr-next-var-arg) (defun wr-next-var-arg (x) x (wr "va_arg(Iap,object)")) (setf (get 'call 'wr) 'wr-call) (defun wr-call (x) (let* ((cdat (second x)) (fname (call-data-fname cdat)) (name (if (symbolp fname) (symbol-name fname) (format nil "L~a" (fdata-ind fname))))) (wr "CA_" name "(") (wr-list (third x)) (wr ")")) ) (defmacro var-implementation-type (x) `(cond ((and (plain-var-p ,x) (not (and (consp (var-ind ,x)) (eq (car (var-ind ,x)) 'kw)))) (var-type ,x)) (t t))) (defun wr-set-inline-loc (a b &aux type) (cond ((eq a b) (wr ";")(return-from wr-set-inline-loc nil))) (cond((atom a) (or (typep a 'var) (wfs-error)) (cond ((var-special-p a) (setq type 'special) (wr-nl "(" (var-ind a) ")->s.Bind = ")) (t (setq type (var-implementation-type a))))) ((and (consp a) (eq (car a) 'var)) (setq type (third a))) (t (wfs-error))) (cond ((eq type 'integer) (let ((val-type (value-type b))) (case val-type (fixnum (wr-nl "ISETQ_FIX(") ) (integer (wr-nl "SETQ_II(") ) (otherwise (wr-nl "SETQ_IO(") (setq val-type t))) (setq b (list 'inline-loc val-type b)) (wr a","a"__alloc," b ");") (return-from wr-set-inline-loc nil))) ((eq type 'special) (setq type t)) (t (wr-nl a "="))) (case type (fixnum (wr-fixnum-loc b)) (character (wr-character-loc b)) (gen (wr-integer-loc b)) (double-float (wr-double-float-loc b)) (double_ptr (wr-double_ptr-loc b)) (short-float (wr-short-float-loc b)) (boolean (wr-boolean-loc b)) (t (wr-obj-loc b))) (wr ";") ) (defun wr-integer-loc (x) (cond ((and (dv-p x) (typep (third x) 'fixnum)) (setq x (list 'inline-loc 'fixnum x)))) (case (value-type x) (integer (wr x)) (fixnum (wr "stoi(" x ")")) (t (wr "otoi(" x ")")))) (defun value-type (x &aux tem) ;; returns the representation type of form x (setq tem (cond ((consp x) (cond ((eq (car x) 'dv) t) ((eq (car x) 'var) (or (third x) t)) ((eq (car x) 'inline-call) (nth 3 x)) ((eq (car x) 'inline-loc) (nth 1 x)) ((eq (car x) 'let-control-stack) (value-type (second x))) ((eq (car x) 'next-var-arg) t) )) ((typep x 'var) (var-implementation-type x)))) (unless tem (comp-warn "Don't know type of ~a. Assuming type t" x)) (or (memq tem '(fixnum integer short-float double-float character boolean double_ptr)) (setq tem t)) tem) (setf (get 'inline-loc 'wr) 'wr-inline-loc) (defun wr-inline-loc (x &aux (y (third x)) (type (second x))) (case type (fixnum (wr-fixnum-loc y)) (short-float (wr-short-float-loc y)) (double-float (wr-double-float-loc y)) (double_ptr (wr-double_ptr-loc y)) (character (wr-character-loc y)) ((gen integer) (wr-integer-loc y)) (boolean (wr-boolean-loc y)) (t (wr-obj-loc y)))) (setf (get 'fixnum 'loc) 'wr-fixnum) (defun wr-boolean-loc (x) (let ((type (value-type x))) (case type (boolean (wr x)) ((short-float double_ptr character long-float integer) (wr "1")) (t (wr "(" x ")!=sLnil" ))))) (defun wr-fixnum-loc (b) (case (value-type b) (fixnum (wr b)) ((short-float long-float) (wr "(int)(" b")" )) (double_ptr (wr "(int)(*(" b "))")) (integer (wr "itos(" b")")) (t (cond ((and (consp b) (eq (car b) 'dv)) (cond ((typep (third b) 'fixnum) (wr (third b)) (return-from wr-fixnum-loc nil)) (t (comp-warn "Not a fixnum ~a "(third b)))))) (wr "fix(" b ")")))) (defun wr-character-loc (b) (case (value-type b) (character (wr b)) ((short-float long-float) (comp-error "Cant coerce float to character") (wr "(int)(" b")" )) (integer (wfs-todo)) (t (cond ((and (consp b) (eq (car b) 'dv)) (cond ((typep (third b) 'character) (wr (char-code (third b))) (return-from wr-character-loc nil)) (t (comp-warn "Not a character ~a "(third b)))))) (wr "char_code(" b ")")))) (defun wr-double-float-loc (b) (case (value-type b) ((short-float fixnum) (wr "(double)(" b ")")) (double-float (wr b)) (double_ptr (wr "*(" b ")")) (integer (wfs-todo)) (t (wr "DFloat(" b ")")))) (defun wr-short-float-loc (b) (case (value-type b) ((short-float fixnum double-float) (wr "(float)(" b ")")) (double_ptr (wr "(float)(*(" b "))")) (integer (wfs-todo)) (t (wr "SFloat(" b ")")))) (defun wr-double_ptr-loc (b &aux tem) (case (value-type b) ((short-float fixnum) (setq tem (get-temp 'double_ptr)) (wr "*"tem" = (double)(" b ")") ) (double (wr "*("b")")) (integer (wfs-todo)) (t ;;wrong (object (wr "&(DFloat(" b "))"))))) (defun wr-obj-loc (x) (case (value-type x) (short-float (wr "make_shortfloat(" x ")")) (double-float (wr "Imake_doublefloat(" x ")")) (double_ptr (wr "Imake_doublefloat(*(" x "))")) (fixnum (wr "make_fixnum(" x ")")) (integer (wr "make_integer(" x ")")) (character (wr "code_char(" x ")")) (boolean (wr "(" x "? sLt : sLnil)")) (t (wr x)))) (setf (get 'inline-call 'wr) 'wr-inline-call) (defun wr-inline-call (x ) ; (desetq (sform iargs arg-types res flags fstring) x) (wr-inline-call1 (cadr x) (opt template (cddr x)))) (defun wr-link-call (lnk iargs &aux nochange) (let* ((argd (link-argd lnk)) (n (length iargs))) (declare (fixnum argd )) (cond ((< n (argd-minargs argd)) (setf (argd-minargs argd) n)) ((> n (argd-maxargs argd)) (setf (argd-maxargs argd) n)) (t (setq nochange t)) (setf (argd-minargs (link-argd lnk)))) (unless nochange (setf (link-argd lnk) argd)) (or (link-ind lnk) (setf (link-ind lnk) (mangle-name (link-fname lnk) 'function))) (cond ((argd-flag-p argd requires-nargs) (wr "(VFUN_NARGS=" n ","))) (wr "(*LnK" (link-ind lnk) ")(") (wr-list iargs) (wr ")") (cond ((argd-flag-p argd requires-nargs) (wr ")"))))) (defun wr-inline-call1 (iargs fstring &aux (leng 0) wrote-paren (ch #\space) (ind 0) (start 0) (out *c-output*)) ;; $@i : write out all (nthcdr i args) in a comma separated list. ;; $i : write out arg i ( 0<= i < 10) ;; $# : write out (length iargs) ;; @i,j,..; i,j,.. are multiple eval'd. ;; $*i : push args starting at the ith onto value stack and pass the pointer ;; to the place where you start. (declare (character ch) (fixnum ind leng start) (string fstring)) (cond ((stringp fstring)) ((typep fstring 'link) (wr-link-call fstring iargs) (return-from wr-inline-call1 nil)) (t (return-from wr-inline-call1 (funcall fstring iargs)))) (setq leng (length fstring)) ;; save multiple eval'd args. @0,3; means args 0 and 3 need temps. (cond ((eql (aref fstring 0) #\@) (sloop for i from 1 below leng until (eql (setq ch (aref fstring i)) #\;) when (digit-char-p ch) do (let ((tem (nth (setq ind (- (char-code ch )(char-code #\0))) iargs))) (unless (or (typep tem 'var) (and (consp tem) (or (eq (car tem) 'dv) (eq (car tem) 'var)))) (let ((v (get-temp (value-type (nth ind iargs))))) (setf (nth ind iargs) v) (unless wrote-paren (setq wrote-paren t) (wr "(")) (wr v "= " tem ",")))) finally (setq start (+ 1 i))))) ;; write out the template. (sloop for i from start below leng with l = (length iargs) declare (fixnum l) do (setq ch (aref (the string fstring) i)) (cond ((or (eql ch #\$) (eql ch #\#);; compatibility with akcl ) (setq i (+ i 1)) (setq ch (aref (the string fstring) i)) (setq ind (- (char-code ch) (char-code #\0))) (cond ((and (< ind 10) (>= ind 0)) (if (>= ind l) (comp-error "Bad inline template ~a" fstring)) (wr (nth ind iargs))) ((eql ch #\@) (setq i (+ i 1)) (let ((n (- (char-code (aref fstring i)) (char-code #\0)))) (declare (fixnum n)) (wr-list (nthcdr n iargs)))) ((eql ch #\*) (setq i (+ i 1)) (let* ((n (- (char-code (aref fstring i)) (char-code #\0))) (m (- (length iargs) n)) (p (get-temp "object *"))) (declare (fixnum n m)) (wr "(" p "= (vs_top+=" m"),") (sloop for v in (reverse (nthcdr n iargs)) do (wr "*--"p" =" v",")) (wr p ")"))) ((eql ch #\# ) (wr (length iargs))) (t (comp-error "Bad inline string ~s" fstring)))) (t (write-char ch out)))) ; (if wrote-paren (wr ")")) ) (defun write-out-links( &aux lnk) (dolist (v *file-inline-templates*) (or (typep (setq lnk (nth 4 v)) 'link) (wfs-error)) (let ((ind (link-ind lnk)) (rett (rep-type (third v)))) (wr " static " rett "LnKT" ind "(va_alist)va_dcl {va_list Iap; va_start(Iap); return ("rett ")Icall_proc" (if (eq (third v) 'short-float) "_float(" "(") (get-object (link-fname lnk)) "," (link-argd lnk) ",&LnK" (link-ind lnk ) ",Iap);}") (wr-h "static "rett "LnKT"ind"(),(*LnK" ind ")()=LnKT" ind ";") ) )) (defun write-out-address-and-data () (let ((*c-output* *h-output*)) (wr" static object VV[" (max 1 (length *address-vector*) *next-data*) "]={") (let ((l (length *address-vector*)) (i 0)) (declare (fixnum i l)) (sloop while (< i l) do (wr-nl "(void *)" (aref *address-vector* i)) when (< (setq i (+ i 1)) l) do (wr ",")) (if (eql i 0) (wr 0)) (wr "};"))) (wt-data-file)) (setf (get 'address 'wr) 'wr-address) (defun wr-address (x) (wr "&" (second x)))gcl-2.6.14/comp/top.lsp0000755000175000017500000000471114360276512013261 0ustar cammcamm(in-package "BCOMP") (eval-when (compile eval load) (defparameter *comp-vars* '(*c-output* *h-output* *lsp-input* *data-output* *next-vv* *data* *data-table* *hard-error* *top-form* *top-forms* )) (proclaim (cons 'special *comp-vars*)) ) (defun get-output-pathname (ext) (declare (special input-pathname )) (setq input-pathname (pathname input-pathname)) (let ((dir (pathname-directory *default-pathname-defaults*))) (make-pathname :directory (or (pathname-directory input-pathname) dir) :name (pathname-name input-pathname) :type ext))) (defvar *safety* 0 ;; the safety level set by proclaim '(optimize (safety n)) ) (defvar *speed* 3 ;; the desired speed level of the final code. The higher the ;; speed the slower the compilation, but the faster the code runs. ) (proclaim '(fixnum *safety* *space* *speed*)) (defun open-out (ext flag) (if (streamp flag) flag (open (get-output-pathname ext) :direction :output))) (defun compile-file1 (input-pathname &key output-file (load nil) (message-file nil) system-p (c-debug t) (c-file t) (h-file t)( data-file t) (o-file t) &aux (*package* *package*) (*readtable* *readtable*)) (declare (special input-pathname output-file c-debug)) message-file system-p (progv *comp-vars* '#. (make-list (length *comp-vars*)) (unwind-protect (progn (setq *data-table* (make-hash-table :test 'eql)) (setq *data* (list (make-array 50 :fill-pointer 0 ))) (setq *lsp-input* (open input-pathname)) (execute-pass-1) (setq *c-output* (open-out "c" c-file)) (setq *h-output* (open-out "h" h-file)) (setq *data-output* (open-out "data" data-file)) (execute-pass-2) (compile-and-add-data-file o-file) (let ((out (get-output-pathname "o"))) (and output-file (rename-file out output-file)) (if load (load out)) out) ) ;; unwind protect forms: (flet ((maybe-delete (f flag) (cond ((and (streamp f) (not (eq f flag))) (close f) (if (not flag) (delete-file (pathname f))))))) (maybe-delete *c-output* c-file) (maybe-delete *h-output* h-file) (maybe-delete *data-output* data-file) (if (streamp *lsp-input*) (close *lsp-input*)) )))) gcl-2.6.14/comp/exit.lsp0000755000175000017500000000212514360276512013425 0ustar cammcamm(in-package "BCOMP") (setf (get 'let-control-stack 'b2) 'b2-let-control-stack) (defun b2-let-control-stack (x) (let ((*control-stack* *control-stack*)(*blocks* 0)) (open-block) (wr "object *VOL SaveVs = VsTop;") (expr-b2 (cadr x)) (close-blocks) )) (defopt control-jumped-back ((t) boolean #.(flags set safe) control-jumped-back-aux)) (defun control-jumped-back-aux(x) (push 'ctl-push *control-stack*) (wr-inline-call1 x "@0;CtlJumpedBack(ctl_TAGGED_CATCH,$0)")) (defopt push-unwind-protect ;; The second argument is a function to call to do unwinding ((t) t #.(flags safe set) push-unwind-protect-aux)) (defun push-unwind-protect-aux (x) ;; we use this function call to push something on control stack (push (list 'unwind-protect (car x)) *control-stack*) (or (and (eq (car *exit*) 'next) (or (and (eq (cadr *control-stack*) 'avma-bind) (eq (cdr *exit*) (cddr *control-stack*))) (eq (cdr *exit*) (cdr *control-stack*)))) (wfs-error)) (setq *exit* (cons 'next *control-stack*)) (wr-inline-call1 x "CtlUnwindPush($0)")) gcl-2.6.14/comp/defs.lsp0000755000175000017500000000642014360276512013377 0ustar cammcamm (in-package "BCOMP") #| after pass 1 only the following forms are allowed forms1 == (form1 form1 ... form1) form1 == output of (w1-walk form) N == 0,1,2,3.. desk == desk structure var1 == var structure | (var N) binds == ((var1 form1) (var1 form1) ..) arglist == (form1 form1 ... form1) (LET desk binds forms1) ;(LET* desk binds forms1) ; not needed since the variable assign done. (CALL desk call-data ) (FUNCTION desk function-data) ---------------------- |# ;;Globals for Second pass ;; push on to this when special is bound, so that it can be unbound. (defvar *sp-bind* nil) ;; set when a setjmp is laid down, so variables can be declared volatile (defvar *volatile* nil) ;; tells unwind-set that number of values already set. (defvar *MV-N-VALUES-SET* nil) (defvar *top-form* ;; Passes of the compiler may bind this to a form name which they are compiling ;; to make the errors more meaninful. nil) (defstruct var name ;; count of cross lambda block closure references clb type ;; rep type changed ;; var was altered ref ;; var referred to special-p ;; var declared special ;;for special var, something to which wr applies to write it ;;for a closure var, if the the var is NOT in the *closure-vars* ;; (ie those passed in to this function), then it is an (next-cvars) index ;; if the var was passed in then this field is ignored, and the index is ;; the position in the *closure-vars* list. ;;for a normal variable the (next-cvar), eg ind = 3 , var written V3 ind ;; vars which are maybe referred to after return from a setjmp volatile ) (defstruct (desk (:constructor make-desk1 (result-type ))) result-type ;result of first value ;CHANGED-VARS are the plain-var-p vars which are altered in the ;scope of the form of which this desk appears as the second member. ;used when setting up args for a c call, to know if we need to save a var changed-vars single-value ) (defun make-desk (x) (or x (setq x t)) (make-desk1 x)) (defstruct fdata name ll ; list : (ll &required (fdata-ll fd)) == the list of required args. closure-vars ind address-index doc form function-declaration ;; at the time of definition argd local-template ;; local function call template. closure-self ;; if this is a closure and non nil then it points to a funobj = self tail-label ) (defstruct (call-data (:constructor make-call-data (fname arglist local-fun function-declaration))) fname ; may be a name or else fdata for a local function. arglist local-fun ;;declaration at the point of call. ;;If nil, and if not local then ;; it may be retrieved later. function-declaration ) (defstruct label identifier ;; If this label is referred to across functions, a unique-id ;; is assigned and put in the clb-reference field. Otherwise this is nil clb-reference ;; On pass1 this is set to 'clb by clb references. If it is null it is ;; set to t by ordinary references. referred ind ) (defstruct (block (:constructor make-block (label))) label value exit) (defstruct top-form lisp walked funp ;T if contains a function ) (defstruct (link (:constructor make-link (fname proclaimed))) (argd 0 :type fixnum) ind proclaimed fname ) gcl-2.6.14/comp/lambda.lsp0000755000175000017500000000203114360276512013670 0ustar cammcamm(in-package "BCOMP") #| (let ((a 3)) (defun f0 (x) (+ x 2)) (defun f1 (x) (setq a x) (+ x 2)) (defun f2 (x &aux u) #'(lambda (y) (+ x y a u))) (list #'f0 #'f1 #'f2 (f2 1) (f2 1))) f1 alters the a which the function f2 outputs. each call to f2 makes a different closure variable x however. There is only one closure variable a. (function (lambda ....)) is a closure if in (lambda ....) there are references to the cross boundary You get the list of such vars A compiled closure will be struct closure { object name; .. object *cldata; short cldata_dim; } MakeClosure(3,fn,argd,V1,V2,V3) would construct it, and the V1,V2,V4 would be the cons's whose cars represent the closure variables. inside the closure we will have this_cldata variable, and can reference the variables by position for this closure. Each time we enter a let or &aux or lambda variable which freshly binds a closure variable, a new cons must be created. This cons is immediately put in the accessor array for this closure. |# gcl-2.6.14/comp/c-pass1.lsp0000755000175000017500000000352614360276512013731 0ustar cammcamm(in-package "BCOMP") (setf (get 'call-set-mv 'b1) 'b1-call-set-mv) (defun b1-call-set-mv (x where &aux form) where (desetq (nil form) x) `(call-set-mv #.(make-desk t) ,(b1-walk form 'call-set-mv))) (setf (get 'multiple-value-bind 'b1) 'b1-multiple-value-bind) (defun b1-multiple-value-bind(x where &aux vars form body ) (desetq (nil vars form . body) x) (b1-walk `(progn (call-set-mv , form) (let , (sloop for v in vars for i from 0 collect `(,v (nth-mv ,i ))) ,@ body)) where)) (setf (get 'multiple-value-setq 'b1) 'b1-multiple-value-setq) (defun b1-multiple-value-setq(x where &aux vars form body gens) (desetq (nil vars form . body) x) (setq gens (sloop for v in-list vars collect (gensym))) (b1-walk `(multiple-value-bind ,gens ,form (setq ,@ (sloop for v in vars for w in gens collect v collect w)) ,@ body) where )) (setf (get 'multiple-value-list 'b1) 'b1-multiple-value-list) (defun b1-multiple-value-list(x where &aux form ) (desetq (nil form ) x) (b1-walk `(progn (call-set-mv ,form) (list-mv)) where)) ;; replace this by storage allocation in c stack of n*multiple-value-limit ;; and then copy into this storage at each stage. Then c_apply_n ;; which funcalls a vector. (setf (get 'multiple-value-call 'b1) 'b1-multiple-value-call) (defun b1-multiple-value-call(x where &aux bod fun ) (desetq (nil fun . bod) x) (b1-walk `(apply ,fun (nconc ,@ (sloop for v in-list bod collect `(the dynamic-extent (multiple-value-list ,v))))) where )) (setf (get 'multiple-value-prog1 'b1) 'b1-multiple-value-prog1) (defun b1-multiple-value-prog1(x where &aux form bod (sym (gensym ))) (desetq (nil form . bod) x) (b1-walk `(let ((,sym (multiple-value-list ,form))) (declare (dynamic-extent ,sym)) ,@ bod (apply #'values ,sym)) where)) gcl-2.6.14/comp/mangle.lsp0000755000175000017500000000742114360276512013723 0ustar cammcamm(in-package "BCOMP") ;; Naming convention ;; {f | s | q | l} ;; where f = Function, s = Symbol , q = special form (Quote) , l= Lexical ;; eg fLcar, sLnil, fSallocate_internal,sLAstandard_outputA.qLprogn (eval-when (load eval compile) (defvar *mangle-base* (make-array 128 :element-type 'character)) (defvar *mangle-escapes* (make-array 128 :element-type 'character)) (defmacro mangle-type (flag) `(position ',flag '(octal self special-escape))) (defvar *mangle-escape* #\E) (sloop for i below 128 with tem for ch = (code-char i) do (setf (aref *mangle-escapes* i) (code-char 0)) (setf (aref *mangle-base* i) (code-char (mangle-type octal))) (when (alphanumericp ch) (setf (aref *mangle-base* i) (if (upper-case-p ch) (char-downcase ch) (char-upcase ch))))) (sloop for (v ch) in '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) (#\; #\X)(#\. #\Z)(#\, #\Y) (#\ #\E) (#\@ #\B) ) do (setf (aref *mangle-base* (char-code v)) ch) (setf (aref *mangle-base* (char-code v)) ch) (setf (aref *mangle-base* (char-code (char-downcase ch))) (code-char (mangle-type special-escape))) (setf (aref *mangle-escapes* (char-code (char-downcase ch))) (char-downcase ch))) (sloop for i from (char-code #\0) to (char-code #\9) for j from (char-code #\A) do (setf (aref *mangle-escapes* i) (code-char j))) (defvar *mangle-out* (make-array 40 :element-type 'string-char :fill-pointer 0 :adjustable t)) (proclaim '(string *mangle-out* *mangle-escapes* *mangle-base*)) (proclaim '(character *mangle-escape*)) ) (defun mangle(string) (let ((string (if (symbolp string) (symbol-name string) string))) (declare (string string)) (let ((n (length string)) (start 0)) (declare (fixnum n)) (unless (> (array-total-size *mangle-out*) (the fixnum (* 4 n))) (adjust-array *mangle-out* (* 4 n) :fill-pointer 0 )) (cond ((and (> n 0) (digit-char-p (aref string 0))) (setf (aref *mangle-out* 0) *mangle-escape*) (setf (aref *mangle-out* 1) (aref *mangle-escapes* (char-code (aref string 0)))) (setf (fill-pointer *mangle-out*) 2) (incf start)) (t (setf (fill-pointer *mangle-out*) 0))) (sloop for i from start below n do (mangle1 (aref string i))) *mangle-out*))) (defun mangle1 (ch ) (declare (character ch)) (let* ((tem (aref *mangle-base* (char-code ch))) (n (char-code tem)) (out *mangle-out*)) (declare (character tem)(fixnum n)) (cond ((> n (mangle-type special-escape)) (vector-push tem *mangle-out*)) ((= n (mangle-type special-escape)) (vector-push *mangle-escape* out) (vector-push (aref *mangle-escapes* (char-code ch) )out)) ((= n (mangle-type octal)) (vector-push #.(char-upcase *mangle-escape*) out) (let ((m (char-code ch))) (vector-push (code-char (the fixnum (+ (logand (the fixnum (ash m -6)) 7) (char-code #\0)))) out) (vector-push (code-char (the fixnum (+ (logand (the fixnum (ash m -3)) 7) (char-code #\0)))) out) (vector-push (code-char (the fixnum (+ (logand m 7) (char-code #\0)))) out))) (t (wfs-error))))) #+how_to_unmangle ;; get next character and unmangle it. (defun unmangle-next () (let ((y (get-next))) (cond ((alpha-char-p y) (cond ((lower-case-p y) (upcase-char y)) ((eql y *mangle-escape*) (let ((n (get-next))) (cond ((digit-char-p n) (make-octal-char n (get-next) (get-next))) ((upper-case-p n) (code-char (+ (char-code #\0) (- n (char-code #\A))))) (t n)))) ((car (rassoc (list n) '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) (#\; #\X)(#\. #\Z)(#\, #\Y) (#\e #\E))))) (t (char-downcase n)))) (t y)))) gcl-2.6.14/comp/var.lsp0000755000175000017500000010604514360276512013252 0ustar cammcamm;;Copyright William F. Schelter 1990, All Rights Reserved (in-package "BCOMP") (use-package "SLOOP") (setq SYSTEM:*INHIBIT-MACRO-SPECIAL* nil) ;(fmakunbound 'multiple-value-list) (defvar *default-desk* (make-desk t)) (defun get-desk (type) (if (eq type t) *default-desk* (make-desk type))) (defun set-desk-type (desk new-type) (cond ((eq desk *default-desk*) (make-desk new-type)) (t (setf (desk-result-type desk) (type-and (desk-result-type desk) new-type)) desk))) (setq SYSTEM:*INHIBIT-MACRO-SPECIAL* t) (do ((v '(QUOTE b1-quote MACROLET b1-macrolet symbol-macrolet b1-symbol-macrolet MULTIPLE-VALUE-PROG1 b1-MULTIPLE-VALUE-PROG1 UNWIND-PROTECT b1-unwind-protect EVAL-WHEN b1-quote-first LET b1-let RETURN-FROM b1-return-from MULTIPLE-VALUE-LIST b1-eval IF b1-if THE b1-the PROGV b1-progv FUNCTION b1-function FLET b1-flet COMPILER-LET b1-compiler-let DECLARE b1-declare TAGBODY b1-tagbody LABELS b1-flet PROGN b1-progn LET* b1-let* CATCH b1-catch THROW b1-throw BLOCK b1-block GO b1-go SETQ b1-setq VALUES b1-values LAMBDA-BLOCK b1-lambda-block DONE-b1 b1-done-b1 #+c-pass1 MULTIPLE-VALUE-BIND b1-multiple-value-bind #+c-pass1 MULTIPLE-VALUE-setq b1-multiple-value-setq ) (cddr v))) ((null v)) (setf (get (car v) 'b1) (second v))) (defmacro locally (&body body) `(let nil ,@body)) (defvar *control-stack* ;; When a special is bound 'bound-special is pushed ;; When clb lambda is entered 'clb is pushed ;; When save_avma is entered 'save-avma is pushed ;; Thus go can tell whether the tag is acros 'clb or ;; or else how many bds-unbinds it has to do before going. nil) (defvar *walk-functions* ;; bindings of functions and macros by flet,macrolet,labels nil) (defvar *walk-variable-bindings* ;; bindings of variables by let,lambda, let*, symbol-macrolet. ;; nil) (defvar *digest-line-info* (make-hash-table :test 'eq)) (defvar *line-info* nil) (defun walk-environment () (list nil *walk-functions*)) (defun mapcar2 (f lis c &optional last) (or last (setq last c)) (do ((v lis (cdr v)) (result) (ptr)) ((null v) result) (or (consp v) (comp-error "Expected a list of forms ~a" lis)) (let ((tem (funcall (the (function (t t) t) f) (car v) (if (cdr v) c last)))) (cond (ptr (setf (cdr ptr) (list tem)) (setf ptr (cdr ptr))) (t (setq result (setq ptr (list tem)))))))) (eval-when (compile eval load) (defun desetq-consp-check (val) (or (consp val) (error "~a is not a cons" val))) (defun desetq1 (form val) (cond ((symbolp form) (cond (form ;(push form *desetq-binds*) `(setf ,form ,val)))) ((consp form) `(progn (desetq-consp-check ,val) ,(desetq1 (car form) `(car ,val)) ,@ (if (consp (cdr form)) (list(desetq1 (cdr form) `(cdr ,val))) (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) (t (error "")))) ) (defmacro desetq (form val) (cond ((atom val) (desetq1 form val)) (t (let ((value (gensym))) `(let ((,value ,val)) , (desetq1 form value)))))) (defun b1-quote-two (form where &aux sform a b c) where (desetq (sform a b . c) form) (list* sform a b (mapcar2 'b1-walk c sform))) (eval-when (compile eval load) (defun wbind1 (v decls &aux var specialp tem) (or (symbolp v) (comp-error "binding non symbol ~a")) (if (null v) (comp-error "binding nil ~a")) (sloop for w on-list (second decls) when (eq (car w) v) do (setq specialp t)(setf (car w) nil)) (if (si::specialp v) (setq specialp t)) (setq var (makevar v specialp)) (if specialp (push 'bound-special *control-stack*)) (push var *walk-variable-bindings*) (cond ((setq tem (assoc v (car decls))) (setf (var-type var) (cdr tem)))) var ) (defmacro wbind (v decls) `(setf ,v (wbind1 ,v ,decls))) (defun makevar (var specialp) (or (symbolp var) (error "not a symbol ~a" var)) (let ((v (make-var :name var))) (when specialp (setf (var-special-p v) t) (setf (var-ind v) (get-object var))) (setf (var-type v) (or (get var 'proclaimed-variable-type) t)) v)) (defun canon-opt-arg (v type &aux var val supplied-p keyword (intern (eql type '&key))) ;; (list var val supplied-p keyword) (tagbody (if intern (setq keyword v)) (cond ((atom v) (or (symbolp v) (go error)) (setq var v)) (t (cond ((consp (car v)) (or intern (go error)) (setq intern nil) (desetq (keyword var) (car v))) (t (setq keyword (car v) var (car v)))) (or (consp (cdr v)) (go error)) (setq val (cadr v)) (if (consp (cddr v)) (setq supplied-p (caddr v))))) (or (symbolp keyword) (go error)) (or (symbolp var ) (go error)) (or (null intern) (setq keyword (intern (symbol-name keyword) 'keyword))) (return-from canon-opt-arg (list var val supplied-p keyword)) error (comp-error "bad ~a arg ~s" type v))) ;;lambda-list-keywords has value: ;; '(&optional &rest &key &allow-other-keys &aux &whole &environment &body) (defun decode-ll (list) (let (ll sections) (do ((v list (cdr v)) (this (list '&required))) ((null v) (push (nreverse this) sections) (setq sections (nreverse sections ))) (cond ((member (car v) lambda-list-keywords) (push (nreverse this) sections) (setq this (list (car v)))) (t (push (if (consp (car v)) (car v) (if sections (list (car v) nil) (car v))) this)))) (do ((v (cons '&required lambda-list-keywords) (cdr v)) tem) ((eq (car v) '&whole) (or (null sections) (error "unrecognized or duplicate '&' keyword in lambda-list ~a" sections))) (cond ((setq tem (assoc (car v) sections)) (or (eq (car sections) tem) (error "~a in incorrect position" (car v))) (setf sections (cdr sections)))) (push tem ll) ) (setq ll (nreverse ll)) (dolist (v (ll &required ll)) (unless (symbolp v) (error "required arg not a symbol ~a" v))) (if (ll &allow-other-keys ll) (setf (cdr (ll &allow-other-keys ll)) t)) (setf (ll &key ll) (sloop for v in-list (ll &key ll) collect (canon-opt-arg v '&key))) (setf (ll &optional ll) (sloop for v in-list (ll &optional ll) collect (canon-opt-arg v '&optional))) (setf ll (mapcar 'cdr ll)))) (defun lambda-bind-b1 (decoded clb decls) (let ((*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*)) (if clb (push 'clb *walk-variable-bindings*)) (flet ((fbind1 ( l decls &aux v) (sloop for w on l do (cond ((atom (car w)) (wbind (car w) decls)) (t (setq v (car w)) ; v = (list var val supplied-p keyword) (setf (nth 1 v) (b1-walk (nth 1 v) 'bind)) (wbind (nth 0 v) decls) (setq v (cddr v)) (if (car v) (wbind (car v) decls)) (setq v (cdr v)) (if (car v) (setf (car v) (get-object (car v))))))))) (fbind1 (ll &required decoded) decls) (fbind1 (ll &optional decoded) decls) (if (ll &rest decoded) (wbind (caar (ll &rest decoded)) decls)) (fbind1 (ll &key decoded) decls)) (add-remaining-special-decls decls) *walk-variable-bindings*)) ;;end eval-when ) (defvar *contains-function* ;; set if the form contains a lambda expression. ) (defvar *setjmps* ;; the number of setjmps encountered so far. ;; tagbody with clb tags, unwind-protect, catch all lay down setjmps. ) (defun bound-variables-volatile () (dolist (v *walk-variable-bindings*) (cond ((eql v 'clb) (return nil)) ((typep v 'var) (setf (var-volatile v) t))))) (defun check-used (binds pos &aux w) (dolist (v binds) (cond ((consp v) (setq w (nth pos v)) (if (typep w 'var) (or (var-special-p w) (var-changed w ) (var-ref w ) (comp-warn "Variable ~s was not used" (var-name w)))))))) (defun add-remaining-special-decls (decls) (sloop for v in (second decls) when v do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) (defun b1-lambda-block (form where &optional (clb 'clb) &aux sform name closure-record result decls doc (*control-stack* (cons clb *control-stack*)) (*function-decls* *function-decls*) (tail-label (make-label :identifier '#.(gensym "tail"))) ll bod decoded) where (desetq (sform) form) (setq form (cdr form)) ;; set (setq *contains-function* t) (cond ((eq sform 'lambda-block) (desetq (name) form) (setq form (cdr form)))) (desetq (ll . bod) form) (setq decoded (decode-ll ll)) (desetq (decls bod doc) (grab-declares bod t)) (cond ((and (null name) (consp bod) (consp (car bod)) (eq (caar bod) 'block)) (desetq (name) (cdar bod))) ((and (symbolp name) (eq sform 'lambda-block)) (setq bod `((block ,name ,. bod))))) (when clb (dolist (v *walk-variable-bindings*) (and (typep v 'var) (var-clb v) (push (cons v (var-clb v)) closure-record)))) (let* ((*control-stack* *control-stack*) (*walk-variable-bindings* (lambda-bind-b1 decoded clb decls)) (tail-recursion (and (not (ll &optional decoded)) (eq sform 'lambda) (not (ll &key decoded)) (not (ll &rest decoded)) (list 'lambda-block name (ll &required decoded) tail-label)))) (push tail-label *control-stack*) (setq result (b1-walk `(let* ,(ll &aux decoded) ,@ (get-back-some-decls decls (mapcar 'car (ll &aux decoded))) ,@ bod) tail-recursion)) (check-used *walk-variable-bindings* 1)) (if (ll &aux decoded) (setf ll (butlast ll (length (member '&aux ll))))) `(,sform , (make-fun-data name closure-record clb decoded doc result tail-label ) ))) (defun make-fun-data (name closure-record clb ll doc form tail-label &aux tem result) (setq result (make-fdata :name name :ll ll :doc doc)) (setf (fdata-form result) form) (setf (fdata-tail-label result) tail-label) (when clb (dolist (v *walk-variable-bindings*) (cond ((and (typep v 'var) (setq tem (var-clb v))) (if (> tem (or (cdr (assoc v closure-record)) 0)) (push v (fdata-closure-vars result))))))) result) (defun declare-volatile (binds) (dolist (v binds) (or (and (consp v) (typep (car v) 'var) (wfs-error))) (setf (var-volatile (car v)) t))) (defun find-bind (var &optional (set-clb t) &aux clb) (cond ((and (consp var) (eq (car var) 'done-b1)) (setq var (cdr var)))) (dolist (v *walk-variable-bindings*) (cond ((var-p v) (when (or (eq var (var-name v)) (eq var v)) (cond ((and clb set-clb (not (var-special-p v))) (setf (var-clb v) (+ 1 (the fixnum (or (var-clb v) 0)))))) (return-from find-bind v))) ((eq 'clb v) (setq clb t)) ((consp v) (cond ((eq (car v) var) (case (second v) (special (return-from find-bind (third v))) (symbol-macro (return-from find-bind (cdr v))) (otherwise (wfs-error)))))) (t (wfs-error)))) (or (si::specialp var) (keywordp var) (comp-warn "~a is an unknown variable. Assuming it is special." var)) (let ((tem (makevar var t))) (push (list var 'special tem) *walk-variable-bindings*) tem)) (defun b1-macro-function (name) (let ((tem (assoc name *walk-functions*))) (cond (tem (if (eq 'macro (cadr tem)) (third tem) nil)) (t (macro-function name))))) (eval-when (compile) (proclaim '(function expand-fun (t) t))) (defun expand-fun (form &aux f) (unless (and (consp form) (eq (car form) 'lambda-block)) (return-from expand-fun form)) (setq f (second form)) (let* ((line-info (get f 'line-info)) (*digest-line-info* (if (and line-info *digest-line-info*) (progn (clrhash *digest-line-info*) (dotimes (i (length line-info)) (setf (gethash (aref line-info i) *digest-line-info*) i)) *digest-line-info*) nil)) (*line-info* line-info)) (let ((result (walk-top form))) (setf (car form) 'lambda-block-expanded) (setf (cdr form) (cdr result)) form))) (defun walk-top (form) (let ((*walk-variable-bindings* nil) (*control-stack* nil) (*walk-functions* nil) ) (b1-walk form 'top))) (defun transfer-line-info (form result for-sure &aux tem) ;; transfer the line info from FORM to RESULT. ;; If FOR-SURE holds, do it even if this would destroy ;; line info of RESULT. (cond ((atom result) nil) ((setq tem (gethash form *digest-line-info*)) (when (or for-sure (not (gethash result *digest-line-info*))) (remhash form *digest-line-info*) (and *line-info* (setf (aref *line-info* tem) result)) (setf (gethash result *digest-line-info*) tem))))) (defun b1-walk (form where &aux tem sym result (changed 0)) (declare (fixnum changed)) (setq result (cond ((atom form) (cond ((constantp form) (cond ((symbolp form) (get-object (symbol-value form))) (t (get-object form)))) ((symbolp form) (let ((v (find-bind form t))) (cond ((and (consp v) (eq (car v) 'symbol-macro)) (b1-walk (second v) where)) (t (or (var-ref v) (setf (var-ref v) t)) v)))))) ((symbolp (setq sym (car form))) ;;possibly fix line info (and *digest-line-info* (cond ((setq tem (get sym 'wl)) (funcall tem form)))) (setq changed (fill-pointer *changed*)) (cond ((setq tem (get sym 'b1)) (funcall tem form where)) ((and (setq tem (get sym 'bo1)) (setq tem (funcall tem form where))) (b1-walk tem where)) ((b1-macro-function sym) (b1-walk (macroexpand form (walk-environment)) where)) ((setq tem (get sym 'si::structure-access)) (let (arg res-type sd (index (cdr tem))) (desetq (arg) (cdr form)) (setq tem (case (car tem) (vector `(aref (the (array t) ,arg) ,index)) (list `(nth ,index ,arg)) (t (setq sd (get (car tem) 'si::s-data)) (or (null (cddr form)) (comp-warn "Too many args to ~a" sym)) (cond ((null sd) (comp-warn "Structure not defined ~a" (car tem))) (t (setq res-type (comp-type(aet-type (aref (si::s-data-raw sd) index)))) (cond ((eq res-type t) `(si::structure-ref ,arg ',(car tem) ,index)) (t `(the,res-type (si::structure-ref (the (struct ,res-type) ,arg) ',(car tem) ,index))))))))) (b1-walk tem where))) ;; function application (t (do-call-b1 form where) ))) ((and (consp (car form)) (eq (caar form) 'lambda)) (b1-walk `(funcall (function ,(car form)) ,@ (cdr form)) where)) (t (error "unrecognized form to eval ~a" form)))) (when (and (consp result) (consp (cdr result)) (typep (second result) 'desk)) (let ((tem (let ((v *changed*)) (declare (type (vector (t)) v)) (sloop for i from changed below (fill-pointer v) collect (aref v i))))) (when tem (if (eq (second result) *default-desk*) (setf (second result) (make-desk t))) (setf (desk-changed-vars (second result))tem) ))) (and *digest-line-info* (transfer-line-info form result t)) result) (defun constant-call (sym arglist) (and (sloop for v in arglist always (and (consp v) (eq (car v) 'dv))) (cons (b1-walk (apply sym (mapcar 'caddr arglist)) 'call) nil))) (defun do-call-b1 (form where &aux (sym (car form)) tem args) (let* ((wf (cdr (assoc sym *walk-functions*))) (res `(call ,*default-desk* ,(make-call-data sym (setq args (mapcar2 'b1-walk (cdr form) 'funcall)) wf (cdr (assoc sym *function-decls*)) )))) (cond (wf ;; indicate a closure ref if necessary. (if (third wf) (find-bind (var-name (third wf)))) ) ((setq tem (result-from-args sym args)) (setf (second res) (set-desk-type (second res) tem))) ((setq tem (get sym 'proclaimed-function-declaration)) (setq tem (ret-from-argd (fdecl argd tem))) (cond ((eq tem 'double_ptr) (setq tem 'double-float)) ((eq tem '*) (setq tem 't))) (setf (second res) (set-desk-type (second res) tem)))) (cond ((and (member sym '(< > length + - * / )) (setq tem (constant-call sym (call-data-arglist (third res))))) (return-from do-call-b1 (car tem)))) ;; tail recursion???? (cond ((and (consp where) (eq (car where) 'lambda-block) (eq (second where) sym) (not (member 'bound-special *control-stack*)) (not wf)) (format t "~%;;Note: Replaced tail call of ~a by iteration." sym) (let ((args (call-data-arglist (third res)))) (sloop for v in args with s do (unless (cdr args) (setq sets (list (cons 'done-b1 (car args)))) (loop-finish)) (setq s (gensym)) for var in (third where) collect (list s (cons 'done-b1 v)) into binds unless (eq t (var-type var)) collect (list 'type (var-type var) s) into decls collect s into sets finally (setq res (b1-walk `(let ,binds ,(cons 'declare decls) (assign-args ,@sets) (go ,(label-identifier (nth 3 where)))) 'let)))))) ;;ordinary functioncall res)) (defun b1-quote-first (form where &aux sform fir bod) where (desetq (sform fir . bod) form) `(,sform ,fir ,@ (mapcar2 'b1-walk bod sform))) (defun b1-quote (form where &aux val) where (desetq (nil val) form) (and (cddr form) (comp-error "Two many args to quote ~a"form)) (get-object val)) (defun b1-setq (form where &aux sform var bod val ans) where (cond ((null (cdr form)) (return-from b1-setq (get-object nil)))) (desetq (sform var val . bod) form) (do () (nil) (let ((v (find-bind var t))) (setf (var-changed v) t) (and (plain-var-p v) (vector-push-extend v *changed*)) (setq val (b1-walk val sform)) (push v ans) (push val ans) (if bod (desetq (var val . bod) bod) (return nil)))) `(,sform, (make-desk (var-type (second ans))) ,@ (nreverse ans))) (defun b1-eval (form where &aux sform bod) where (desetq (sform . bod) form) `(,sform ,@ (mapcar2 'b1-walk bod sform))) ;; using (control-jumped-back id) ;; ;; and (pass-values) (defun b1-tagbody (form where &aux sform bod (*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*) (longjmp-id (makevar nil nil)) sym (clb-ref (list 0 longjmp-id)) ) where (desetq (sform . bod) form) (push longjmp-id *walk-variable-bindings*) (setq bod (sloop for v in-list bod when (or (integerp v) (symbolp v)) collect (list 'done-b1 'label (let ((tem (make-label :identifier v :clb-reference (cons nil clb-ref) ))) (push tem *control-stack*) tem)) else collect v)) (setq bod (mapcar2 'b1-walk bod sform)) (cond ((var-clb longjmp-id) (setq sym (gensym)) (bound-variables-volatile) `(let-control-stack (let ,*default-desk* ((,longjmp-id ,(b1-walk '(unique-id) 'let-var))) (,(b1-walk `(let ((,sym 0) (ctl-came-back (control-jumped-back (done-b1 . ,longjmp-id)))) (declare (fixnum ,sym)(boolean ctl-came-back)) (if ctl-came-back (progn (nlj-active-off)(setq ,sym (pass-values)))) (switch ,sym ,@ (sloop for v in bod with tem when (and (consp v) (eq (car v) 'label) (setq tem (car (label-clb-reference (cadr v))))) collect `(case ,tem) collect (cons 'done-b1 v)))) 'tagbody))))) (t `(,sform ,*default-desk* ,bod)))) ;; wrapper so you can avoid doing b1 twice on a form. ;; when we need to do it once to get the result type. (defun b1-done-b1 (form where) where (cdr form)) (defun b1-prog1 (form where &aux sform body first) (desetq (sform first body) form) (setq first (b1-walk first where)) (let ((sym (gensym))) (b1-walk `(let ((,sym (done-b1 . ,first))) (declare (type ,(result-type first) ,sym)) ,@ (append body (list sym))) where))) (defun b1-progn (form where &aux sform bod) where (desetq (sform . bod) form) (cond ((and (eq sform 'progn) (null (cdr bod))) (b1-walk (car bod) where)) (t (setq bod (mapcar2 'b1-walk bod sform where)) `(progn ,(make-desk (result-type (car (last bod)))) ,bod )))) (defun b1-if (form where &aux sform test then else) where (desetq (sform test then) form) (setq form (cdddr form)) (when (consp form) (setq else (car form)) (setq form (cdr form))) (if form (error "Too many args to if")) (setq test (b1-walk test sform)) (setq then (b1-walk then where)) (setq else (b1-walk else where)) (cond ((and (consp test) (eq (car test) 'dv)) (return-from b1-if (if (eq (third test) nil) else then)))) `(,sform ,(make-desk (type-and (result-type then) (result-type else))) ,test ,then ,else)) (defun b1-macrolet (form where &aux sform mbinds ll name body mbody funs) (desetq (sform mbinds . body) form) (do ((v mbinds (cdr v))) ((atom v)) (desetq ((name ll . mbody)) v) (let ((fun (second (parse-macro name ll mbody t)))) (push (list name 'macro fun) funs))) (let ((*walk-functions* (nconc (nreverse funs) *walk-functions*))) (b1-walk (cons 'progn body) where))) (defun b1-flet (form where &aux sform mbinds name ll body mbody new-binds fun ans let-binds let-sets var fdat tem (*walk-variable-bindings* *walk-variable-bindings*) (*walk-functions* *walk-functions*)) (desetq (sform mbinds . body) form) (do ((v mbinds (cdr v))) ((atom v)) (desetq ((name ll . mbody)) v) (setq fun `(lambda-block ,name ,ll ,@mbody)) ;;a variable to hold a pointer to the function itself. ;; so we don't have to cons up more than one copy of itself. (setq var (makevar (gensym "flet") nil)) (push var *walk-variable-bindings*) (push (list name fun nil var) new-binds)) (if (eq sform 'labels) (setf *walk-functions* (append new-binds *walk-functions*))) (dolist (v new-binds) (setq var (fourth v)) (setq ans(b1-lambda-block (second v) sform 'clb )) (setq fdat (second ans)) (setf (third v) ans) (cond ((setq tem (fdata-closure-vars fdat)) (cond ((and (null (cdr tem)) (eq (car tem) var)) ;; if the only reason for it being a closure is the self reference var ;; forget it. (setf (fdata-closure-vars fdat) nil)) (t (setf (fdata-closure-self fdat) var) (push (list var nil) let-binds) (push `(pointer-to-funobj ,fdat) let-sets) (push var let-sets)))) (t (setf (fourth v) nil) ))) (if (eq sform 'flet) (setf *walk-functions* (append new-binds *walk-functions*))) (setq body (mapcar2 'b1-walk body sform where)) (setq ans `(flet ,(make-desk (result-type (car (last body)))) ,(reverse new-binds) ,body)) (if let-binds `(let ,(second ans) ,let-binds ((setq ,*default-desk* ,@ let-sets) ,ans)) ans)) (defun b1-symbol-macrolet (x where &aux sform binds body expansion decls tem new-binds name ) (desetq (sform binds . body) x) (desetq (decls body) (grab-declares body t)) (do ((v binds (cdr v))) ((atom v)) (desetq ((name expansion)) v) (if (member name (car decls)) (error "special declaration of symbol-macrolet var ~a" name)) (when (setq tem (assoc name (second decls))) (setf expansion `(the , (cdr tem) ,expansion))) (push (list name 'symbol-macro expansion) new-binds)) (let ((*walk-variable-bindings* (nconc new-binds *walk-variable-bindings*))) (b1-progn (cons 'progn body) where))) (defun b1-let (form where &optional compiler-let &aux sform var vars body val (*function-decls* *function-decls*) (*walk-variable-bindings* *walk-variable-bindings*) (*control-stack* *control-stack*) decls binds) (desetq (sform vars . body) form) (do ((v vars (cdr v))) ((atom v)) (cond ((consp (car v)) (setq var (caar v)) (setq val (cdar v)) (and (not compiler-let) (setq val (b1-walk (car val) sform)))) (t (setq var (car v) val nil))) (push (list var val) binds)) (setq binds (nreverse binds)) (if compiler-let (return-from b1-let (progv (mapcar 'car binds) (mapcar 'cadr binds) (b1-progn (cons 'progn body) where)))) (desetq (decls body) (grab-declares body nil)) (dolist-safe (v binds) (wbind (car v) decls)) (add-remaining-special-decls decls) (cond ((null vars) (b1-progn (cons 'progn body) where)) (t (setq body (mapcar2 'b1-walk body sform where)) (check-used binds 0) `(let ,(make-desk (result-type (car (last body)))) ,binds, body)))) (defun b1-compiler-let (form where) (b1-let form where t)) (defun b1-let* (form where &aux sform var val binds (*function-decls* *function-decls*) (*control-stack* *control-stack*) (*walk-variable-bindings* *walk-variable-bindings*) vars body decls) (desetq (sform vars . body) form) (desetq (decls body) (grab-declares body nil)) (do ((v vars (cdr v))) ((atom v)) (cond ((consp (car v)) (setq var (caar v)) (setq val (cdar v)) (and (consp val) (setq val (b1-walk (car val) sform)))) (t (setq var (car v) val nil))) (push (list var val) binds) (wbind (caar binds) decls) ) (add-remaining-special-decls decls) (setq binds (nreverse binds)) (cond ((null vars) (b1-progn (cons 'progn body) where)) (t (setq body (mapcar2 'b1-walk body sform where)) (check-used binds 0) `(let* ,(make-desk (result-type (car (last body)))) ,binds, body))) ) ;; Scope of declarations: ;; Note Xrj13 voted that for ;; (let ((x 0)) (declare (fixnum x)) ;; .. (let ((x 5))(declare (type t x)) ..)) ;; then the inner declaration of x is also (and fixnum t) ie fixnum. ;; We DO NOT take advantage of this declaration, since it is very easy ;; for users to slip up on this, and since it is contrary to CltlI. The ;; Compiler has license to ignore type decls if it wants, and we do so here. ;; They explicitly say for ;; (let ((x 0)) (declare (special x)) ;; .. (let ((x 5)) ..)) ;; then the inner binding of x is NOT special unless there is another decl. ;; We do this. (defun grab-declares (form doc-allowed &aux (dec t) decls doc tem) doc-allowed ;; return (cons form decls) ;; decls == (list specials type-decls ..) (if (stringp (car form)) (setq doc (car form) form (cdr form))) (sloop while dec do (setq tem (car form)) (cond ((and (consp tem) (eq (car tem) 'declare)) (setq form (cdr form)) (dolist-safe (v (cdr tem)) (setq decls (grab-1-decl v decls)))) ((eq tem (car form))(setq dec nil)) (t (setq form (cons tem (car form)))))) ; (if (and doc (not decls)) (setq form (cons doc form))) ;decls= (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) (list decls form doc)) (defun get-back-some-decls (decls vars &aux specials types tem) ;; build up a declare to restore the decls. (setq specials(sloop for v in vars when (member v (second decls)) collect v )) (setq types(sloop for v in vars when (setq tem (assoc v (car decls))) collect `(type ,(cdr tem) ,v))) (cond (specials (push (cons 'special specials) types))) (if types `((declare ,@ types))nil)) (defun b1-declare (form where &aux type vars) where (dolist (v (cdr form)) (desetq (type . vars) v) (cond ((eq type'special) (sloop for w in-list vars do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) ((member type '(ftype optimize function ignore declaration dynamic-extent)) nil) ((member type '(inline notinline)) (dolist-safe (v vars) (push (cons v (increment-function-decl type (function-declaration v))) *function-decls*))) ((eq type 'type) (desetq (type . vars) vars) ;; do nothing. ))) nil) (defun b1-the (form where &aux sform type val tem) ;; note this takes away the checking (desetq (sform type val) form) (setq val (b1-walk val where)) (setq type (comp-type type)) (cond ((and (consp val) (typep (setq tem (second val)) 'desk)) (setf (second val) (set-desk-type tem type)) ; (unless (and (consp type) (eq (car type )'values) ; (consp (cdr type)) (consp (cddr type))) ; (setf (desk-single-value (second val)) t)) val) (t (setq tem (result-type val)) (setq type (type-and tem type)) `(the ,(make-desk type) ,val)))) (defun b1function-object (object where) ;; this might be called by b1-funcall, b1-mapcar and others ;; to avoid getting closure varialbes. They must promise to inline ;; this, since the closure vars are not set up, for cross closure stuff. (cond ((matches object '(function (lambda . tem))) `(inline-function ,(b1-lambda-block (second object) 'function nil))) (t (b1-walk object where )))) (defun b1-function (form where &aux sform body tem) where (desetq (sform body) form) (cond ((symbolp body) (cond ((setq tem (assoc body *walk-functions*)) (cons 'pointer-to-funobj (cddr tem))) (t (b1-walk `(symbol-function ',body) where)))) ((and (consp body) (eq (car body) 'lambda)) (b1-lambda-block body 'function 'clb)) ;`(lambda-block ,(b1-lambda-block body 'function t)) (t (error "unrecognized function ~a" body)))) (defun b1-go (form where &aux sform label clb result ) where (desetq (sform label) form) (sloop for v in *control-stack* when (eq v 'clb) do (setq clb t) else when (and (typep v 'label) (eql (label-identifier v) label)) do(setq result v) (when clb (setq clb (label-clb-reference v)) (or (car clb) (setf (car clb) (incf (cadr clb)))) (let ((tem (or (var-clb (third clb)) 0))) (incf tem) (setf (var-clb (third clb) ) tem))) (return nil) finally (comp-error "~a label is not found " label)) (cond (clb (b1-walk `(progn (call-set-mv ,(car clb)) (do-throw (done-b1 . ,(third clb))) nil) 'go)) (t (setf (label-referred result) t) (list 'go result)))) ;(defun b1-unwind-protect (x where &aux form cleanup ; (var (gensym)) ; ) ; (desetq (nil form . cleanup) x) ; (bound-variables-volatile) ; (b1-walk ; `(let ((,var (function (lambda () ,@ cleanup)))) ; (declare (dynamic-extent ,var)) ; (push-unwind-protect ,var) ; (multiple-value-prog1 ; ,form ; (pop-control-stack) ; (funcall ,var))) ; where)) (defun simple-b1 (x where &aux sform form) (desetq (sform form) x) `(,sform ,(b1-walk form where))) (setf (get 'let-control-stack 'b1) 'simple-b1) (defun b1-unwind-protect (x where &aux form cleanup (var (gensym)) ) (desetq (nil form . cleanup) x) (bound-variables-volatile) (b1-walk `(let ((,var (function (lambda () ,@ cleanup)))) (declare (dynamic-extent ,var)) (let-control-stack (progn (push-unwind-protect ,var) ,form))) where)) (defun b1-progv (x where &aux vars vals body bind) (desetq (vars vals . body) (cdr x)) (setq bind (b1-walk `(the fixnum (progv-bind ,vars ,vals)) 'progv)) (let ((*control-stack* (cons 'progv *control-stack*))) (setq body (mapcar2 'b1-walk body 'progv where)) `(progv ,(make-desk (result-type (car (last body)))) ,bind ,body))) (defun b1-catch (x where &aux tag bod ) where (desetq (tag . bod) (cdr x)) (bound-variables-volatile) `(let-control-stack ,(b1-walk `(if (control-jumped-back ,tag) (progn (nlj-active-off)(pass-values)) (progn ,@ bod)) 'catch))) (defun b1-throw (x where &aux tag bod form) where (desetq ( tag form . bod ) (cdr x)) (or (null bod) (comp-error "too many args to throw ~a" x)) (let (sym) (b1-walk `(let ,(cond ((and (consp tag)(eq (car tag) 'quote))(setq sym tag) nil) (t (setq sym (gensym)) `((,sym ,tag)))) (call-set-mv ,form) (do-throw ,sym) nil) 'throw))) ;(defun b1-throw (x where &aux tag bod form) where ; (desetq ( tag form . bod ) (cdr x)) ; (or (null bod) (comp-error "too many args to throw ~a" x)) ; `(throw ,*default-desk* ,tag ,(b1-walk form 'throw))) (defun b1-multiple-value-prog1 (x where &aux first bod) (desetq (nil first . bod) x) `(multiple-value-prog1 ,*default-desk* ,(b1-walk first where) ,(mapcar2 'b1-walk bod 'progn))) (defun b1-block (x where &aux sform tag bod ( *control-stack* *control-stack*) (*walk-variable-bindings* *walk-variable-bindings*) block ans var) (desetq (sform tag . bod) x) (setq block (make-block (make-label :identifier tag :clb-reference (setq var (makevar nil nil)) ))) (push var *walk-variable-bindings*) (push block *control-stack*) (or bod (setq bod '(nil))) (setq bod (mapcar2 'b1-walk bod sform where)) (setq ans `(,sform ,(make-desk (result-type (car (last bod)))) ,block ,bod)) (cond ((var-clb var) (bound-variables-volatile) (setq ans `(let-control-stack (let ,(second ans) , `((,var ,(b1-walk '(unique-id) 'let-var))) (,(b1-walk `(if (control-jumped-back (done-b1 . ,var)) (progn (nlj-active-off) (pass-values)) (done-b1 . ,ans)) where)))))) (t (setf (label-clb-reference (block-label block)) nil))) ans ) (defun b1-return-from (x where &aux clb tag block form bod) where (desetq (nil tag . bod) x) (cond ((null bod) (setq form nil)) ((consp bod) (setq form (car bod)) (or (null (cdr bod)) (comp-error "Too many values for return-from ~a"x))) (t (comp-error "Bad return from ~a" x))) (sloop for v in *control-stack* when (eq v 'clb) do (setq clb t) else when (and (typep v 'block) (eql (label-identifier (block-label v)) tag)) do (setq block v) (when clb (setq clb (label-clb-reference (block-label v))) (cond ((var-clb clb) (incf (var-clb clb))) (t (setf (var-clb clb) 1)))) (return nil) finally (comp-error "Could not find ~a tag to return from" block)) (cond (clb (b1-walk `(progn (call-set-mv ,form) (do-throw ,(cons 'done-b1 clb)) nil ) 'return-from)) (t (setq form (b1-walk form 'return-from)) `(return-from ,(make-desk (result-type form)) ,block ,form)))) (defun b1-values (x where) (let ((argl (mapcar2 'b1-walk (cdr x) where))) `(values , (make-desk (if argl (result-type (car argl)) t)) ,argl))) ;; Several WL functions for Walk to fix Line-info, and ;; make it more sensible for special forms. (do ((v '(let wl-let let* wl-let compiler-let wl-let cond wl-cond ) (cddr v))) ((null v)) (setf (get (car v) 'wl) (second v))) (defun wl-let (form &aux sform vars bod) (desetq (sform vars . bod) form) (dolist (v vars) (if (consp v) (transfer-line-info v (second v) nil)))) (defun wl-cond (form &aux clauses) (desetq (nil . clauses) form) (dolist (v clauses) (or (consp v) (error "bad cond clause")) (transfer-line-info v (if (consp (car v)) (car v) (second v)) nil))) (defun use-expansion (do) (if do (setf si::lambda-block-expanded (symbol-function 'si::expand-fun)) (setf si::lambda-block-expanded nil))) (defmacro switch (test &body body &aux tem (tes (gensym ))) (sloop for v in-list body when (and (consp v) (eq (car v) 'case) (consp (cdr v)) (null (cddr v))) collect (setq tem (make-symbol (format nil "case~a_" (cadr v)))) into bod and collect (cons (cadr v) tem) into cases else collect v into bod finally (return `(tagbody (let ((,tes ,test)) (declare (fixnum ,tes)) (cond ,@ (sloop for v in cases when (typep (car v) 'fixnum) collect `((eql ,tes ,(car v))(go ,(cdr v))) else collect `(t (go ,(cdr v)))))) ,@ bod)))) ;(switch n (case 0) 3) ;; ;;- Local variables: ;;- mode:lisp ;;- version-control:t ;;- End: gcl-2.6.14/comp/fasdmacros.lsp0000755000175000017500000000413514360276512014601 0ustar cammcamm(in-package "BCOMP") (provide 'FASDMACROS) (defstruct (fasd (:type vector)) stream table eof direction package index filepos table_length macro ) (defvar *fasd-ops* '( d_nil ;/* dnil: nil */ d_eval_skip ; /* deval o1: evaluate o1 after reading it */ d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */ d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a cf_data with ; this length. Used internally by akcl. Just make ; an array in other lisps */ d_cons ; /* d_cons o1 o2: (o1 . o2) */ d_dot ; d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on ;for (o1 o2 . on) ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) ;*/ d_list1 ;/* nil terminated length 1 d_list1o1 */ d_list2 ; /* nil terminated length 2 */ d_list3 d_list4 d_eval d_short_symbol d_short_string d_short_fixnum d_short_symbol_and_package d_bignum d_fixnum d_string d_objnull d_structure d_package d_symbol d_symbol_and_package d_end_of_file d_standard_character d_vector d_array d_begin_dump d_general_type d_sharp_equals ; /* define a sharp */ d_sharp_value d_sharp_value2 d_new_indexed_item d_new_indexed_items d_reset_index d_macro d_reserve1 d_reserve2 d_reserve3 d_reserve4 d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */ d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index */ d_indexed_item1 d_indexed_item0 ; /* This must occur last ! */ )) (defmacro put-op (op str) `(write-byte ,(or (position op *fasd-ops*) (error "illegal op")) ,str)) (defmacro putd (n str) `(write-byte ,n ,str)) (defmacro put2 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str))) (defmacro put4 (n str) `(progn (write-bytei ,n 0 ,str) (write-bytei ,n 1 ,str) (write-bytei ,n 2 ,str) (write-bytei ,n 3 ,str) )) (defmacro write-bytei (n i str) `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) gcl-2.6.14/comp/makefile0000644000175000017500000000155014360276512013432 0ustar cammcamm LISP=../unixport/saved_kcl LOAD='(load "sysdef.lsp")(make::make :bcomp :compile t)' all: echo ${LOAD} | ${LISP} tests: echo ${LOAD}'(load "try1")(load "../tests/all-tests.lsp")(in-package "BCOMP")(do-some-tests)' \ '(test-sloop)' | ${LISP} test1: echo '(load "../tests/try-comp")' | ${LISP} TFILES=src/makefile comp/makefile unixport/makefile o/makefile \ h/enum.h src/kclobjs src/sobjs src/NewInit src/make-init tar: (cd .. ; tar cvf - ${TFILES} src/sobjs src/*.c src/*.el newh/*.el src/makefile comp/*.lsp comp/*.doc newh/*.h newh/makefile | gzip -c > ${HOME}/`date '+acl-%y%m%d'`.tar.z) all-tests: $(MAKE) - $(MAKE) tests test1 - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") - (cd /u11/wfs/gabriel ; $(MAKE) "LISP=nacl") tests2: $(MAKE) - $(MAKE) tests test1 - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") -include ../makedefs gcl-2.6.14/comp/smash-oldcmp.lsp0000755000175000017500000000041114360276512015037 0ustar cammcamm (dolist (v '((compile-file . bcomp::compile-file1) (proclaim . bcomp::proclaim1) (disassemble . bcomp::disassemble1))) (setf (symbol-function (car v)) (symbol-function (cdr v)))) (setq compiler::*cc* (si::concatenate 'string compiler::*cc* " -g ")) gcl-2.6.14/comp/comptype.lsp0000755000175000017500000001424014360276512014315 0ustar cammcamm(in-package "BCOMP") (defvar *immediate-types* '(fixnum character short-float double-float boolean)) (dolist (v '((t array package atom float pathname bignum function random-state hash-table ratio single-float rational standard-char keyword readtable stream common list sequence compiled-function complex nil signed-byte symbol cons null unsigned-byte t number simple-array vector ) (bit bit) (integer integer) (double-float long-float single-float) (character string-char) ((vector character) string simple-string) ((vector bit) bit-vector simple-bit-vector) ((vector t) simple-vector) (stream stream) (dynamic-extent dynamic-extent ) (fix-or-sf-or-df fix-or-sf-or-df) )) (dolist (w (cdr v)) (setf (get w 'comp-type) (car v)))) (dolist (v *immediate-types*) (setf (get v 'comp-type) v)) (deftype fix-or-sf-or-df nil '(or fixnum short-float double-float)) (deftype boolean nil t) (proclaim '(declaration dynamic-extent)) ;(deftype dynamic-extent nil t) (defun grab-1-decl (x decls &aux type l tem place) (tagbody (go begin) ERROR (comp-warn "bad declaration ~a" x) (return-from grab-1-decl decls) BEGIN (or (consp x) (go error)) (setq type (car x) l (cdr x)) (or (null l) (consp l) (go error)) (unless (symbolp type) (comp-warn "bad declaration ~a" x) (return-from grab-1-decl decls) ) (cond ((or (setq tem (get type 'comp-type)) (and (eq type 'type) (consp l) (setq tem (comp-type (car l))) (setq l (cdr l)))) (unless (eq t (setq tem (comp-type tem))) (or decls (setq decls (list nil))) (dolist-safe (v l) (or (symbolp v) (go error)) (push (cons v tem) (car decls))))) ((eq type 'special) (cond ((null decls) (setq decls (list nil nil))) ((null (cdr decls)) (setf (cdr decls) (list nil)))) (setq place (cdr decls)) (dolist-safe (v l) (or (symbolp v) (go error)) (push v (car place)) )) ((or (eq type 'inline) (eq type 'not-inline) (and (eq type 'ftype) (progn (desetq (type . l) l) t))) (dolist-safe (v l) (push (cons v (increment-function-decl type (function-declaration v))) *function-decls*))) (t nil))) ; (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) decls) (defun best-array-element-type (type) (cond ((or (eql t type) (null type)) t) ((memq type '(bit unsigned-char signed-char unsigned-short signed-short fixnum character )) type) ((subtypep type 'fixnum) (dolist (v '(bit unsigned-char signed-char unsigned-short signed-short) 'fixnum) (cond ((subtypep type v) (return v))))) ((eql type 'string-char) 'character) (t (or (dolist (v '(string-char bit short-float long-float)) (cond ((subtypep type v) (return v)))) t)))) (deftype type-of (x) (cond (*in-pass-1* (let ((tem (b1-walk x 'type-of))) (result-type tem))) (t t))) (defun assure-list (x) (loop (if (null x) (return t)) (if (consp x) (setq x (cdr x)) (error "expected a list ~a" x)))) (deftype struct (x) 'structure) (defun comp-type (type &aux tem element-type sizes) ;; coerce type to ones understood by compiler (cond ;((member type *immediate-types*) ;(return-from comp-type type)) ((and (symbolp type) (setq tem (get type 'comp-type))) (return-from comp-type tem)) ((and(symbolp type) (setq tem (get type 'si::deftype-definition))) (comp-type (funcall tem))) ((consp type) (cond ((eq (car type) 'struct) (list 'struct (best-array-element-type (cadr type)))) ((progn (setq type (si::normalize-type type)) nil)) ((member (car type) '(array simple-array vector simple-vector)) (when (consp (cdr type)) (setq element-type (best-array-element-type (cadr type))) (when(consp (cddr type)) (setq sizes (caddr type)) (cond ((consp sizes) (assure-list sizes) (unless (typep (second sizes) 'fixnum) (setq sizes nil))) ((typep sizes 'fixnum) ) (t (setq sizes nil)))) (cond ((or (eql sizes 1) (null (cdr sizes))) (setq tem 'vector) (setq sizes nil)) (t (setq tem 'array))) (list* tem element-type (if sizes (list sizes))))) ((eq (car type) 'integer) (if (si::sub-interval-p (cdr type) (list most-negative-fixnum most-positive-fixnum)) 'fixnum 'integer)) ((eq (car type) 'values) (if (null (cddr type)) (comp-type (second type)) (cons 'values (mapcar 'comp-type (cdr (the-list type)))))) (t t))) (t t))) (setf (get 'var 'result-type-b1) 'result-type-b1-var) (defun result-type-b1-var (x) (or (third x) t)) (defun result-type (form &aux fd) ;; compute the result type of form , where FORM is somethign ;; returned by b1-walk (cond ((consp form) (cond ((and (symbolp (car form)) (setq fd (get (car form) 'result-type-b1))) (funcall fd form)) ((and (atom (second form)) (typep (second form) 'desk)) (desk-result-type (second form))) (t t))) ((typep form 'var) (var-type form)) (t (wfs-error) ))) (setf (get 'dv 'result-type-b1) 'dv-result-type) (defun dv-result-type (x) (let ((val (third x))) (cond ((typep val 'fixnum) 'fixnum) ((typep val 'short-float) 'short-float) ((typep val 'double-float) 'double-float) ((typep val 'character) 'character) ((typep val 'character) 'character) (t t)))) (defun comp-subtypep (x y &aux xa xb) ; (cond ((and (atom x) (not (eq y t)) (not (eq x y)) ; (subtypep x y))(comp-warn "subtypep ~a ~a" x y))) (cond ((eq y t) t) ((atom x) (subtypep x y)) ((atom y) (subtypep x y)) ((member (car x) '(array struct)) (and (eq (car y) (car y)) (subtypep (cdr x) (cdr y)))) (t (subtypep x y)))) (defun type-and (a b) (if (eq a b) (return-from type-and a)) (if (eq a t) (return-from type-and b)) (if (eq b t) (return-from type-and a)) (multiple-value-bind (typ sure) (subtypep a b) sure (cond (typ (return-from type-and a)))) (multiple-value-bind (typ sure) (subtypep b a) sure (cond (typ (return-from type-and b)))) t) gcl-2.6.14/comp/cmpinit.lsp0000755000175000017500000000116014360276512014115 0ustar cammcamm (proclaim '(optimize (safety 2)(speed 0))) (in-package "BCOMP") (Use-package '("LISP" "SLOOP")) (or (get 'call-data 'si::s-data) (load "defs.lsp")) (or (macro-function 'dolist-safe)(load "macros.lsp")) (or (si::specialp '*top-form*) (load "top.lsp")) (or (si::specialp '*next-data*) (load "top2.lsp")) (or (si::specialp '*C-OUTPUT*) (load "top.lsp")) (or (si::specialp '*function-decls*)(load "top1.lsp")) (or (si::specialp '*immediate-types*) (load "comptype.lsp")) (or (fboundp 'flags-pos) (load "inline.lsp")) (or (si::specialp '*value*)(Load "stmt.lsp")) (or (si::specialp ' *PROMOTED-ARG-TYPES*) (load "utils.lsp")) gcl-2.6.14/comp/defmacro.lsp0000755000175000017500000001747714360276512014254 0ustar cammcamm(in-package "BCOMP") (eval-when (load eval compile) (defvar *let-bindings* nil) (defvar *pending-action* nil) (defun find-declarations (body &aux decls doc bod) (do ((v body (cdr v))) (()) (or (consp v) (return nil)) (cond ((and (consp (car v)) (eq (caar v) 'declare)) (push (car v) decls)) ((stringp (car v))(if doc (return (setq bod v)) (setq doc (car v)))) (t (setq bod v)(return nil)))) (values (if doc (cons doc decls) decls) bod)) (defun parse-mll (argl whole top &aux u (pos 0) key-list key-test) ;; parse a macro lambda list ARGL, where WHOLE is a variable bound ;; to the whole list we gradually cdr down WHOLE ;; This is called recursively by add-binding, whenever the item to be ;; bound is not a symbol. (declare (fixnum pos)) (when (eq (car argl) '&whole) (or (consp (cdr argl)) (macro-arg-error '&whole)) (setq u (cadr argl)) (add-binding u whole) (setq argl (cddr argl))) (if top (push `(setq ,whole (cdr ,whole)) *pending-action*)) (do () ((atom argl) (cond (key-test (setf (third key-test) `(quote , key-list)))) (when argl (if (>= pos 2) (macro-arg-error '&rest)) ;; ` . body' at the end is the same as `&rest body' (add-binding argl whole))) (let ((x (car argl))) (case x ;; The lambda list keywords must appear in the following order (with ommissions). ;; We have deleted the &environment and &whole at this point. ;; pos 1 &optional, 2 &rest &body, 3 &key, 4 &allow-other-keys, 5 &aux (&optional (when (>= pos 1) (macro-arg-error x)) (setq pos 1)) ((&rest &body) (if (>= pos 2) (macro-arg-error x)) (setq argl (cdr argl)) (if (consp argl) nil (macro-arg-error x)) (add-binding (car argl) whole) (setq pos 2) ) (&key (if (>= pos 3) (macro-arg-error x)) (setq key-test `(dont-allow-other-keys ,whole nil)) (push key-test *pending-action*) (setq pos 3)) (&allow-other-keys (if (or (< pos 3) (>= pos 4)) (macro-arg-error x)) (setf (car key-test) 'progn key-test nil) (setq pos 4)) (&aux (if (>= pos 5) (macro-arg-error x)) (setq pos 5)) (t (cond ((= pos 5) ;&aux (let ((var x) (val nil)) (cond ((atom x)) (t (or (consp (cdr x)) (macro-arg-error '&aux)) ;(or (cddr x) (macro-arg-error '&aux)) (setq var (car x) val (cadr x)))) (or (symbolp var) (macro-arg-error '&aux)) (add-binding var val))) ((= pos 4) (macro-arg-error '&allow-other-keys)) ((= pos 3) ; &key (let (var val supplied-p keyword dont-intern) (cond ((atom x) (setq var x keyword x)) (t (setq var (car x)) (cond ((symbolp var) (setq keyword var)) ((consp var) (setq dont-intern t) (if (consp (cdr var)) nil (macro-arg-error '&key)) (setq keyword (car var) var (cadr var)) (if (symbolp keyword) nil (macro-arg-error '&key))) (t (macro-arg-error '&key))) (cond ((consp (cdr x)) (setq val (cadr x)) (cond ((consp (cddr x)) (setq supplied-p (caddr x)))))))) (or dont-intern (setq keyword (intern (symbol-name keyword) 'keyword))) (push keyword key-list) (let ((key-val (gensym))) (add-binding key-val `(getf ,whole ',keyword 'not-found)) (add-binding var `(if (eq ,key-val 'not-found) ,val ,key-val)) (if supplied-p (add-binding supplied-p `(not (eq ,key-val 'not-found))))))) ((= pos 2) ;; they duplicated an &rest arg eg `&rest a b' (macro-arg-error '&rest)) ((= pos 1) ; &optional (let (var val supplied-p) (cond ((atom x) (setq var x)) ((consp (cdr x)) (setq var (car x) val (cadr x)) (if (consp (cddr x)) (setq supplied-p (caddr x)))) (t (macro-arg-error x))) (add-binding var `(cond ((consp ,whole) ,@(if supplied-p `((setq ,supplied-p t))) (prog1 (car ,whole) (setq ,whole (cdr ,whole)))) (t ,val))))) ((= pos 0) ;&required arg (let ((last-arg (or (null (cdr argl)) (and (consp (cdr argl)) (eq (car argl) '&aux))))) (add-binding x `(cond ((consp ,whole) ,(if last-arg `(if (cdr ,whole) (too-many-arguments-to-macro) (car , whole)) `(car ,whole))) (t (too-few-arguments-to-macro)))) (or last-arg (push `(setq ,whole (cdr ,whole)) *pending-action*)) )))))) (pop argl))) (defun too-many-arguments-to-macro() (error "Too many arguments to a macro or destructuring bind")) (defun too-few-arguments-to-macro() (error "Too few arguments to a macro or destructuring bind")) (defun add-binding (v val) (when *pending-action* (setq val `(progn ,@ (reverse *pending-action*) ,val)) (setq *pending-action* nil)) (cond ((symbolp v) (push (list v val) *let-bindings*)) ((consp v) (let ((sub-whole (gensym))) (push `(,sub-whole ,val) *let-bindings*) (parse-mll v sub-whole nil))) (t (error "Bad lambda list entry ~a" v)))) (defun parse-macro (name lambda-list body &optional env &aux envir whole) ;; process a macro function body, laying out code for destructuring the ;; lambda-list. An implicit block with NAME is placed around the body. ;; The resulting lambda expression is a function of two arguments, suitable ;; for calling as a macroexpander. env (let (*let-bindings* *pending-action*) (do ((v lambda-list (cdr v)) (res nil)) (()) (if (atom v) (return nil)) (cond ((eq (car v) '&environment) (if (consp (cdr v)) nil (macro-arg-error '&environment)) (setq envir (cadr v)) (setf lambda-list (nconc (nreverse res) (cddr v))) (return nil)) (t (push (car v) res)))) (if envir nil (setq envir (gensym))) (setq whole (gensym)) (parse-mll lambda-list whole t) `(function (lambda (,whole ,envir) ,envir (block ,name (let* ,(nreverse *let-bindings*) ,@ body)))) )) (defun macro-arg-error (x) (error "Incorrect position or duplication of ~a arg in macro lambda list" x)) (defun dont-allow-other-keys(arglist allowed-keys) ;; Make sure arglist doesn't contain other keys. (do ((v arglist)) ((null v)) (cond ((consp v) (if (consp (cdr v)) nil (error "Odd number of keyword args")) (if (and (eq (car v) :allow-other-keys) (cadr v)) (return nil)) (if (member (car v) allowed-keys :test 'eq) nil (error "~s is not among the permitted keys ~s" (car v) allowed-keys)) (setq v (cddr v))) (t (error "The keyword args end in an atom ~a instead of NIL" v))))) (defun mset (sym fun) (setf (symbol-function sym) (cons 'macro fun))) ;(defmacro defmacro (name ll &body body)) (setf (macro-function 'defmacro) #'(lambda (bod env &aux ll body name) (setf bod (cdr bod)) (or (consp bod) (too-few-arguments-to-macro)) (setq name (car bod) bod (cdr bod)) (or (consp bod) (too-few-arguments-to-macro)) (setq ll (car bod) body (cdr bod)) (let ((doc (car (find-declarations body))) (def `(eval-when (compile eval load) (mset ',name ,(parse-macro name ll body t))))) (when (stringp doc) (setq def `(progn ,def (setf (get ',name 'si::function-documentation) ,doc)))) def))) (defmacro destructuring-bind (lambda-list expr &body body) (let ((whole (gensym)) *let-bindings* *pending-action*) (parse-mll lambda-list whole nil) `(let* ((,whole ,expr) ,@ (nreverse *let-bindings*)) ,@ body))) ) #+test (progn (defmacro1 billy (a b &key ((:u bil) 0 sup) sil &allow-other-keys) `(billy-list ,a ,b ,sil ,bil,sup ,a)) (defmacro1 mwith ((st . open-args) &body body) `(let (,st (open ,@ open-args)) (unwind-protect (progn ,@ body) (close ,st)))) (defmacro1 joe ((st a) y) `(joe-flat ,st,a,y)) (defmacro jo2 ((a b &key c d) &body body) (list 'hi a b c d body)) (jo2 (1 2 :c 3 ) 4 6) (mwith (st "foo" :direction :input) (read-char st)) (billy 1 2 :sil 1 :u 4 :james 1) (joe (1 2) 3) ) gcl-2.6.14/comp/sysdef.lsp0000755000175000017500000000125214360276512013751 0ustar cammcamm(in-package "BCOMP" :use '("LISP" "SLOOP")) (setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) (setf macros '(defmacro data defs macros wr)) (require "MAKE" "../lsp/make.lisp") (setf files '( var c-pass1 fasdmacros lambda top top1 bo1 inline top2 stmt exit mangle utils comptype)) (proclaim '(optimize (speed 0))) (setf (get :bcomp :make) `((:serial ,@ macros) ,@ files (:progn (unless (get 'list 'bcomp-opt) (load "lisp-decls.doc") (load "opts.lsp")) (load "opts-base.lsp") ) (:depends ,files ,macros))) (setf (get :bcomp :source-path) "foo.lsp") (setf (get :bcomp :object-path) "foo.o") gcl-2.6.14/comp/data.lsp0000755000175000017500000000571614360276512013376 0ustar cammcamm (in-package "BCOMP") (eval-when (compile eval) (require 'FASDMACROS "../comp/fasdmacros.lsp") (defvar *data*) (defvar *data-output*) (defmacro data-vector () `(car *data*)) ) (defvar *fasd-data*) ; ; (defun verify-data-vector(vec &aux v) ; (dotimes (i (length vec)) ; (setq v (aref vec i)) ; (let ((has (si::hash-equal (cdr v) -1000))) ; (cond ((and (typep (car v) 'fixnum) ; (not (eql (car v) has))) ; (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v))))) ; (setf (aref vec i) (cdr v))) ; vec ; ) (defun wt-data-file ( &aux (x (data-vector)) (*package* (find-package "LISP")) fd tem ) (declare (type (array (t)) x)) ; (verify-data-vector x) (setq fd (si::open-fasd *data-output* :output nil nil)) (si::find-sharing-top x (fasd-table fd)) (put-op d_enter_vector *data-output*) (sloop for i below (length x) do (setq tem (aref x i)) (cond ((consp tem) (cond ((eq (car tem) 'd_eval_skip) (put-op d_eval_skip *data-output*)) ((eq (car tem) 'd_eval) (put-op d_eval *data-output*))))) (si::write-fasd-top (cdr tem) fd)) (put-op d_delimiter *data-output*) (si::close-fasd fd)) (defun display-data-file(file &aux fd (eof '(nil)) tem ) (with-open-file (st file) ; (setq fd (si::open-fasd st :input eof nil)) (setq fd (si::open-fasd st :input eof (make-array 100 :adjustable t))) (sloop::sloop for i from 0 while (not (eq eof (setq tem (si::read-fasd-top fd)))) do (format t "~%item ~a:~%~s" i tem )) )) (defun display-data-file1(file &aux fd (eof '(nil)) ) (with-open-file (st file) ; (setq fd (si::open-fasd st :input eof nil)) (setq fd (si::open-fasd st :input eof (make-array 100 :adjustable t))) (let ((si::%memory nil)) (declare (special si::%memory)) (si::read-fasd-top fd)))) (defun push-data (flag val) (vector-push-extend (cons flag val) (data-vector)) (prog1 *next-data* (if (or (eq flag 'dv) (eq flag 'd_eval)) (incf *next-data*)))) (defun get-load-time-form (x) (let ((tem (cdr (assoc x *load-time-forms*)))) (cond (tem) (t (setq tem (list 'dv nil x)) (setf (second tem) (push-data 'd_eval x)) (push (cons x tem) *load-time-forms*) tem)))) (defun get-object (x &aux tem) (cond ((setq tem (gethash x *data-table*))) ((typep x 'compiled-function) (setq tem (list 'd_eval nil `(function ,(or (si::compiled-function-name x) (comp-error "Can't dump un named compiled funs"))) )) (setf (gethash x *data-table*) tem) tem) (t (setq tem (list 'dv nil x)) (setf (gethash x *data-table*) tem) tem))) #| steps in loading 0) (let (*cfun-addresses* *data-object*) 1) copy address in VV vector into *vv-addresses* vector. 2) make a *data-object* whose body is the VV. 3) readin the items into the vector. using read-fasd-top |# gcl-2.6.14/comp/macros.lsp0000755000175000017500000000425514360276512013746 0ustar cammcamm(in-package "BCOMP") ;(dolist-safe (a b) (foo a)) (defmacro dolist-safe ((x l &optional res) &body body) (let ((l1 (gensym)) (l2 (gensym))) `(let* ( (,l1 ,l) (,l2 ,l1) ,x) (loop (cond ((consp ,l1) (setq ,x (car ,l1) ,l1 (cdr ,l1)) ,@body) ((null ,l1) (return ,res)) (t (comp-error "expected a list ~a" ,l2)))))))) ;; go through a list safely signalling an error if not a true list. (def-loop-for in-list (var lis) (let ((point (gensym "POINT")) (l1 (gensym))) `(with ,point with ,l1 with ,var initially (setf ,l1 (setf ,point ,lis)) do(or (consp ,point) (comp-error "Expected a list ~a " ,l1)) (desetq ,var (car ,point)) end-test (and (null ,point)(local-finish)) increment (setf ,point (cdr ,point))))) (def-loop-for on-list (point lis) (let ((l1 (gensym))) `(with ,point with ,l1 initially (setf ,l1 (setf ,point ,lis)) do(or (consp ,point) (comp-error "Expected a list ~a " ,l1)) end-test (and (null ,point)(local-finish)) increment (setf ,point (cdr ,point))))) (defmacro safe-cdr (x) (if (symbolp x) `(progn (or (consp ,x)(null ,x) (comp-error "expected list ~a" ,x)) (cdr ,x)) (let ((xx (gensym))) `(let ((,xx ,x)) (safe-cdr ,xx))))) (defmacro memq (a l) `(member ,a,l :test 'eq)) (defmacro valex (a b form) (let (binds ) (or (eq b '*exit*) (push (list '*exit* b) binds)) (or (eq a '*value*) (push (list '*value* a) binds)) `(let ,binds ,form))) (defsetf logbitp logstore) (defmacro logstore ( i a val) `(setf (ldb (byte 1 ,i) ,a) (if ,val 1 0))) (defmacro argd-minargs(x) `(the fixnum (ldb (byte 6 0) (the fixnum ,x)))) (defmacro argd-maxargs(x) `(the fixnum (ldb (byte 6 9) (the fixnum ,x)))) (defmacro argd-flags(x) `(the fixnum (ldb (byte 3 6) (the fixnum ,x)))) (defmacro argd-atypes(x) `(the fixnum (ldb (byte 16 15) (the fixnum ,x)))) (defmacro argd-flag-p (x name) `(logbitp ,(+ 6 (position name '(requires-nargs sets-mv requires-fun-passed))) (the fixnum ,x) )) (defmacro ll (key lambda-list) `(nth ,(position key (cons '&required lambda-list-keywords)) ,lambda-list)) gcl-2.6.14/comp/proclaim.lsp0000755000175000017500000000002514360276512014257 0ustar cammcamm(in-package "BCOMP") gcl-2.6.14/comp/opts-base.lsp0000755000175000017500000000236014360276512014352 0ustar cammcamm(in-package "BCOMP") (defopt NTH-MV ((fixnum) t #.(flags safe constantp) "(fcall.nvalues > $0 ? fcall.values[$0] : sLnil)")) (defopt LIST-MV (() t #.(flags proclaim safe ans ) "ListVector(fcall.nvalues,&fcall.values[0])") ;(() dynamic-extent #.(flags safe ans ) ; "ON_STACK_LIST_VECTOR(fcall.nvalues,&fcall.values[0])") ) ;(defopt pop-control-stack ; (() t #.(flags safe set) "CtlPop")) (defopt progv-bind ((t t) fixnum #.(flags set safe) "IprogvBind(#0,#1)")) (defopt do-throw ((t)t #.(flags proclaim set safe) "Ido_throw(#0)")) (defopt unique-id (() t #.(flags ans safe) "alloc_object(t_spice)")) (defopt pass-values (() * #.(flags proclaim mv safe) "fcall.values[0]")) (defopt nlj-active-off (()t #.(flags safe set) "nlj_active=0;VsTop = SaveVs ")) ;(defopt nlj-active-off ; (()t #.(flags safe set) "nlj_active=0; ")) (defopt assign-args (( *) t #.(flags safe set) do-assign-args)) (defopt funcall ((t *) t #.(flags set ) "@0;(VFUN_NARGS=($#-1),fcall.fun=$0,(type_of($0)==t_afun||type_of($0)==t_closure) && F_PLAIN($0->sfn.Argd) ? *($0->sfn.Body) : fcalln)($@1)")) (proclaim1 '(ftype (function (*) t) si::make-structure)) (defopt si::make-structure ((t *) t #.(flags ans safe) "ImakeStructure($#,$*0)")) gcl-2.6.14/comp/try.lsp0000755000175000017500000000135014360276512013271 0ustar cammcamm(in-package "BCOMP" :use '("SLOOP" "LISP")) (setq *print-pretty* t) (defun compiler::boole3 (a b c) (boole a b c)) (setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) (let ((*load-verbose* nil)) (dolist (v '( data defs macros var c-pass1 fasdmacros lambda top top1 inline top2 stmt wr bo1 exit defmacro utils comptype )) (si::nload (format nil "~(~a~).lsp" v))) (load "opts-base.lsp") (let ((u "top2.o")) (unless (get 'list 'bcomp-opt) (if (probe-file u) (load u)) (load "lisp-decls.doc") (load "opts.lsp") (if (probe-file U ) (si::nload "top2.lsp")) )) (or (fboundp 'do-some-tests) (load "../tests/all-tests.lsp")) (load "mangle") ) gcl-2.6.14/comp/lisp-decls.doc0000755000175000017500000011207314360276512014466 0ustar cammcamm(in-package "BCOMP") ;first load the proclaims then get them: ;(setq lis (sort (sloop for v in-package 'lisp when (get v 'PROCLAIMED-FUNCTION-DECLARATION) collect v) #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) ;(sloop for v in lis when (setq tem (get v 'proclaimed-function-declaration)) do (format t "(~a ~a ~a " v (car tem)(second tem)) (print-flag (third tem))(princ ")") (unless (eq (second tem) '*) (princ " ;Mv touched?")) (terpri)) (defmacro proclaim2 (name args res flag) (progn (proclaim1 `(ftype (function ,args ,res) ,name)) (setf (fdecl flag (get name 'proclaimed-function-declaration) ) flag))) (proclaim2 * (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 + (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 - (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 / (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 /= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 1+ (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 1- (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 < (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 <= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 = (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 > (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 >= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ABS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACONS (T T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACOS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ACOSH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ADJOIN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ADJUST-ARRAY (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ADJUSTABLE-ARRAY-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ALPHA-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ALPHANUMERICP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 APPEND (*) T #.(flags ans set )) ;Mv touched? (proclaim2 APPLY (T T *) * #.(flags ans set mv touch-mv)) (proclaim2 APROPOS (T *) * #.(flags ans set mv touch-mv)) (proclaim2 APROPOS-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 AREF (T &optional fixnum fixnum fixnum fixnum *) T #.(flags ans constantp)) (proclaim2 si::aset1 (T fixnum t) T #.(flags ans set constantp)) (proclaim2 ARRAY-DIMENSION (T FIXNUM) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-DIMENSIONS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-ELEMENT-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-HAS-FILL-POINTER-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-IN-BOUNDS-P (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-RANK (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAY-ROW-MAJOR-INDEX (T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ARRAY-TOTAL-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 ARRAYP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ASH (INTEGER FIXNUM) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 ASIN (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ASINH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ATAN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ATANH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ATOM (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT (T *) BIT #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT-AND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ANDC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ANDC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-EQV (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-IOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NAND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-NOT (T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ORC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-ORC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? (proclaim2 BIT-VECTOR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BIT-XOR (T T *) (ARRAY BIT) #.(flags ans set )) ;Mv touched? (proclaim2 BOOLE (FIXNUM INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 BOTH-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 BREAK (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 BUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 BYTE (FIXNUM FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 BYTE-POSITION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 BYTE-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDAAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDADR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDAR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CDR (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CEILING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 CERROR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CHAR (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-CODE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-DOWNCASE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-INT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NAME (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-NOT-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR-UPCASE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR/= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR< (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR<= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR> (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHAR>= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CHARACTER (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CHARACTERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CIS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLEAR-INPUT (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLEAR-OUTPUT (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CLOSE (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CLRHASH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CODE-CHAR (FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COERCE (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COMPILE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 COMPILE-FILE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 COMPILED-FUNCTION-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 COMPLEX (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 COMPLEXP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CONCATENATE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 CONJUGATE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CONS (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 CONSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 CONSTANTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-ALIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-READTABLE (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-SEQ (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-SYMBOL (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COPY-TREE (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COSH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 COUNT (T T *) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 COUNT-IF (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 COUNT-IF-NOT (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DECODE-UNIVERSAL-TIME (T *) * #.(flags ans set mv touch-mv)) (proclaim2 DELETE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DELETE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DENOMINATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 DEPOSIT-FIELD (INTEGER T INTEGER) INTEGER #.(flags ans set)) ;Mv touched? (proclaim2 DESCRIBE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 DIGIT-CHAR (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DIGIT-CHAR-P (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DIRECTORY (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DIRECTORY-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 DOCUMENTATION (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 DPB (INTEGER T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? (proclaim2 DRIBBLE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ED (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EIGHTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ELT (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? (proclaim2 ENCODE-UNIVERSAL-TIME (T T T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ENDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ENOUGH-NAMESTRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EQ (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQUAL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EQUALP (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 ERROR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EVAL (T) * #.(flags ans set mv touch-mv)) (proclaim2 EVENP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 EVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EXP (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 EXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 EXPT (T T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FBOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 FCEILING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FFLOOR (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FIFTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FILE-AUTHOR (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-LENGTH (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-POSITION (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILE-WRITE-DATE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FILL-POINTER (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FIND (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-ALL-SYMBOLS (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIND-SYMBOL (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FINISH-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FIRST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-DIGITS (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-PRECISION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-RADIX (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOAT-SIGN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOATP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 FLOOR (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FMAKUNBOUND (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FORCE-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FORMAT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FOURTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 FRESH-LINE (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 FROUND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FTRUNCATE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FUNCALL (T *) * #.(flags ans set mv touch-mv)) (proclaim2 FUNCTIONP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 GCD (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GENSYM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GENTEMP (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET (T T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 GET-DECODED-TIME NIL * #.(flags ans set mv touch-mv)) (proclaim2 GET-DISPATCH-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-INTERNAL-REAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-INTERNAL-RUN-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-MACRO-CHARACTER (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-OUTPUT-STREAM-STRING (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GET-PROPERTIES (T T) * #.(flags ans set mv touch-mv)) (proclaim2 GET-SETF-METHOD (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-SETF-METHOD-MULTIPLE-VALUE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 GET-UNIVERSAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 GETF (T T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 GETHASH (T T *) * #.(flags ans set mv touch-mv)) (proclaim2 GRAPHIC-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 HASH-TABLE-COUNT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 HOST-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 IDENTITY (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 IMAGPART (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 IN-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 INPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 INSPECT (T) * #.(flags ans set mv touch-mv)) (proclaim2 INTEGER-DECODE-FLOAT (T) * #.(flags ans set mv touch-mv)) (proclaim2 INTEGER-LENGTH (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 INTEGERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 INTERN (T *) * #.(flags ans set mv touch-mv)) (proclaim2 INTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ISQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 KEYWORDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LCM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LDB (T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? (proclaim2 LDB-TEST (T INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LDIFF (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LENGTH (T) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 LISP-IMPLEMENTATION-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LIST (*) T #.(flags ans constantp)) ;Mv touched? (proclaim2 LIST* (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 LIST-ALL-PACKAGES NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LIST-LENGTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LISTEN (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LISTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOAD (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOG (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOGAND (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGANDC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGANDC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGBITP (FIXNUM INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGCOUNT (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGEQV (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGIOR (*) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNAND (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNOR (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGNOT (INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGORC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGORC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGTEST (INTEGER INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 LOGXOR (*) INTEGER #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LONG-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 LOWER-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 MACHINE-INSTANCE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACHINE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACHINE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MACRO-FUNCTION (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MACROEXPAND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 MACROEXPAND-1 (T *) * #.(flags ans set mv touch-mv)) (proclaim2 MAKE-BROADCAST-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-CONCATENATED-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-DISPATCH-MACRO-CHARACTER (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-ECHO-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-HASH-TABLE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-RANDOM-STATE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SEQUENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING-INPUT-STREAM (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-STRING-OUTPUT-STREAM NIL STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SYMBOL (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-SYNONYM-STREAM (T) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKE-TWO-WAY-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAKUNBOUND (T) T #.(flags ans set )) ;Mv touched? (proclaim2 MAP (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCAN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPCON (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPHASH (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MAPLIST (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MASK-FIELD (T INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 MAX (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MEMBER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MEMBER-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MEMBER-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MERGE (T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MERGE-PATHNAMES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MIN (T *) T #.(flags ans constantp)) ;Mv touched? (proclaim2 MINUSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 MISMATCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 MOD (T T) T #.(flags ans touch-mv)) ;Mv touched? (proclaim2 NAME-CHAR (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NBUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NCONC (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NINTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NINTH (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NOT (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NOTANY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NOTEVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NRECONC (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NREVERSE (T) T #.(flags ans set )) ;Mv touched? (proclaim2 NSET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSTRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NSUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 NTH (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NTHCDR (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 NULL (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NUMBERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 NUMERATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? (proclaim2 NUNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ODDP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 OPEN (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 OUTPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-NAME (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-NICKNAMES (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-SHADOWING-SYMBOLS (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-USE-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PACKAGE-USED-BY-LIST (T) T #.(flags ans constantp)) ;Mv touched? (proclaim2 PAIRLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PARSE-INTEGER (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PARSE-NAMESTRING (T *) * #.(flags ans set mv touch-mv)) (proclaim2 PATHNAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-DEVICE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-DIRECTORY (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-HOST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PATHNAME-VERSION (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PEEK-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PHASE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PLUSP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 POSITION-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRIN1 (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRIN1-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRINC (T *) T #.(flags ans set )) ;Mv touched? (proclaim2 PRINC-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PRINT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 PROBE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RANDOM (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONAL (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONALIZE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RATIONALP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-BYTE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-CHAR-NO-HANG (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-DELIMITED-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-FROM-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 READ-LINE (*) * #.(flags ans set mv touch-mv)) (proclaim2 READ-PRESERVING-WHITESPACE (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REALPART (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REDUCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMHASH (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMOVE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REMPROP (T T) T #.(flags ans set )) ;Mv touched? (proclaim2 RENAME-FILE (T T) * #.(flags ans set mv touch-mv)) (proclaim2 RENAME-PACKAGE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REPLACE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REVAPPEND (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 REVERSE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ROOM (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ROUND (T *) * #.(flags ans set mv touch-mv)) (proclaim2 RPLACA (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 RPLACD (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SBIT (T *) BIT #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SCALE-FLOAT (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SCHAR (T FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SEARCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SECOND (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-DISPATCH-MACRO-CHARACTER (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SET-SYNTAX-FROM-CHAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SEVENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHADOW (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHADOWING-IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SHORT-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIGNUM (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-BIT-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-STRING-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIMPLE-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIN (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SINH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SIXTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SLEEP (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOFTWARE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOFTWARE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SOME (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SPECIAL-FORM-P (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STABLE-SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STANDARD-CHAR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STREAM-ELEMENT-TYPE (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-LEFT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-EQUAL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-NOT-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-RIGHT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING/= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING< (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING<= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING= (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING> (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRING>= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 STRINGP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSEQ (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSETP (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SUBTYPEP (T T) * #.(flags ans set mv touch-mv)) (proclaim2 SVREF ((VECTOR T) FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SXHASH (T) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-FUNCTION (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-PLIST (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOL-VALUE (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 SYMBOLP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TAN (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TANH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TERPRI (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 THIRD (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TREE-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TRUENAME (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TRUNCATE (T *) * #.(flags ans set mv touch-mv)) (proclaim2 TYPE-OF (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 TYPEP (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNEXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNINTERN (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNREAD-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UNUSE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 UPPER-CASE-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 USE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 USER-HOMEDIR-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VALUES (*) * #.(flags ans set mv touch-mv)) (proclaim2 VALUES-LIST (T) * #.(flags ans set mv touch-mv)) (proclaim2 VECTOR (*) (VECTOR T) #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-POP (T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-PUSH (T T) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTOR-PUSH-EXTEND (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 VECTORP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WARN (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-BYTE (INTEGER STREAM) INTEGER #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-LINE (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 WRITE-TO-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 Y-OR-N-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 YES-OR-NO-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 ZEROP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? (proclaim2 si::structure-ref (t t fixnum) t #.(flags ans)) (proclaim2 si::structure-set (t t fixnum t) t #.(flags ans set)) gcl-2.6.14/comp/top1.lsp0000755000175000017500000000645114360276512013345 0ustar cammcamm(in-package "BCOMP") (setf (get 'eval-when 't1) 't1eval-when) (setf (get 'progn 't1) 't1progn) (setf (get 'defun 't1) 't1top-macro) (setf (get 'quote 't1) 't1ignore) (setf (get 'defmacro 't1) 't1top-macro) (setf (get 'defvar 't1) 't1top-macro) (setf (get 'defparameter 't1) 't1top-macro) (defun t1top-macro (x) (let ((*top-form* x)) (setq x (macroexpand x)) (pass-1 x))) (defun t1ignore (form) form nil) (defvar *changed* nil) (defvar *FUNCTION-DECLS* nil) (defvar *in-pass-1* nil) (defun execute-pass-1 ( &aux (eof '(nil)) tem (*in-pass-1* t) (*changed* (make-array 40 :fill-pointer 0 :adjustable t))) (sloop while (not (eq eof (setq tem (read *lsp-input* nil eof)))) do (pass-1 tem)) (setq *top-forms* (nreverse *top-forms*)) ) (defvar *eval-when-defaults* :defaults) (dolist (v '(si::*make-special si::*make-constant proclaim si::define-macro make-package in-package shadow shadowing-import export unexport si::define-structure use-package unuse-package import provide require)) (setf (get v 'eval-at-compile) t)) ;; return t if we do an eval, (defun maybe-comp-eval (default-action form) (or default-action (and (symbolp (car form)) (setq default-action (get (car form) 'eval-at-compile)))) (cond ((or (and default-action (eq :defaults *eval-when-defaults*)) (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* ))) (comp-eval form) t))) (defun t1eval-when (x &aux do-load do-compile) (sloop for v in-list (second x) do (case v (eval) (load (setq do-compile t)) (compile (setq do-compile t)) (otherwise (comp-error "Bad arg to eval-when ~a" v)))) (let ((*eval-when-defaults* (second x))) (cond (do-compile (t1progn (cddr x)))))) (defun walk-top-form (x &aux (*top-form* x)) (let* (*contains-function* (tem (walk-top x))) (setq tem (make-top-form :lisp x :walked tem :funp *contains-function*)))) (defvar *variable-decls*) (defvar *function-decls*) (defun pass-1 (x &aux *variable-decls* fd) ;; fix for symbol macro (cond ((atom x) (return-from pass-1 nil))) (cond ((symbolp (car x)) (cond ((setq fd (get (car x) 't1)) (funcall fd x)) ((macro-function (car x)) (setq x (macroexpand x)) (pass-1 x)) (t (maybe-comp-eval nil x) (push (walk-top-form x) *top-forms*) ))) ((and (consp (car x)) (eq (caar x) 'lambda)) (pass-1 `(funcall (function ,(car x)) ,@ (cdr x)))) (t (comp-error "Unexpected form ~a" x)))) (setf (get 'si::defmacro* 'b1) 'b1-defmacro*) (setf (get 'si::fset 't1) 't1-set) (setf (get 'mset 't1) 't1-set) ;; use for fset,define-macro and defvar (defun t1-set (form &aux var val sform) (maybe-comp-eval nil form) (desetq (sform var val) form) (or (and (consp var) (eq (car var) 'quote) (symbolp (second var))) (error "expected a symbol")) (push `(,sform ,var ,(walk-top-form val)) *top-forms*) ) (defun t1progn(form) (sloop for v in-list form do (pass-1 v))) (defun b1-defmacro* (form where) (let* ((tem (comp-eval form))) (push 'list tem) (b1-walk tem where))) (defun comp-eval (form ) (multiple-value-bind (error res) (si::error-set `(eval ',form)) (or error (return-from comp-eval res))) (comp-error "Evaluation of ~s failed" form)) gcl-2.6.14/comp/integer.doc0000755000175000017500000000225114360276512014060 0ustar cammcamm 1) b2-call (or anyone who calls inline-arg or inline-args) will push an 'avma-bind onto the *control-stack* if it is there is not one between where it is and the next tag. If it did the push, then it will pop it off an leaving. If the 'avma-bind has been changed to 'avma-bind-needed then a) it will also set the *used-function-saved-avma* to be t if at outer scope b) bind *do-restore-avma* to the point in the *control-stack* where we pushed to 'avma-bind, for the benefit of unwind-set. c)It is an error if the *value* var is of type GEN and the level is outer. 2) Any call to an 'is' fun will cause the most recent 'avma-bind or 'avma-bind-needed to 'avma-bind-needed 3) unwind-set if doing a go or return must do the restore to the level appropriate to the tag, if there is an intervening 'avma-bind-needed in the *control-stack* If not going to a tag then if *do-restore-avma* is set, then unwind to the current avma level. current level is global_saved_avma if there is not an intervening inner-avma on the stack. 4) entering tagbody, if there is an 'avma-bind on the stack, then push an 'inner-avma and write { GEN Inner_avma= avma; ..}. gcl-2.6.14/mp/0000755000175000017500000000000014360276512011407 5ustar cammcammgcl-2.6.14/mp/mp_bfffo.c0000755000175000017500000000303314360276512013333 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* double i; ulong x; index of the first non zero bit numbering from left Bit position measured from most significant end to the first non zero bit of x if (x == 2^i) bfffo(x) == (31 - truncate(i)) else if (x==0) 32 [truncate (i) chops off the decimal places] bfffo(0) == 32 bfffo(1) == 31 bfffo(2) == 30 bfffo(3) == 30 bfffo(4) == 29 bfffo(5) == 29 .. */ #include "include.h" #ifndef bfffo int bfffo(x) unsigned plong x; { int sc; static int tabshi[16]={4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0}; if(x&(0xffff0000)) sc=0;else {sc=16;x<<=16;} if(!(x&(0xff000000))) {sc+=8;x<<=8;} if(x&(0xf0000000)) x>>=28;else {sc+=4;x>>=24;} sc+=tabshi[x];return sc; } #else static dummy () {;} #endif gcl-2.6.14/mp/sparcdivul3.s0000755000175000017500000001034314360276512014036 0ustar cammcamm#ifdef __svr4__ #define _err err #define _divul3 divul3 #endif .seg "text" .global _divul3 #define SS0(label) \ addx %o2,%o2,%o2;\ subcc %o2,%o1,%o3;\ bcc label;\ addxcc %o0,%o0,%o0 #define SS1(label) \ addx %o3,%o3,%o3;\ subcc %o3,%o1,%o2;\ bcc label;\ addxcc %o0,%o0,%o0 _divul3: mov %o2,%o4 ld [%o2],%o2 subcc %o2,%o1,%g0 blu 1f addcc %o1,%o1,%g0 mov 0x2f,%o0 call _err,1 nop 1: bcc Lsmalldiv andcc %o1,1,%g0 be Levendiv srl %o1,1,%o1 add %o1,1,%o1 subcc %o2,%o1,%o3 bcc Lb01 addxcc %o0,%o0,%o0 La01: SS0(Lb02) La02: SS0(Lb03) La03: SS0(Lb04) La04: SS0(Lb05) La05: SS0(Lb06) La06: SS0(Lb07) La07: SS0(Lb08) La08: SS0(Lb09) La09: SS0(Lb10) La10: SS0(Lb11) La11: SS0(Lb12) La12: SS0(Lb13) La13: SS0(Lb14) La14: SS0(Lb15) La15: SS0(Lb16) La16: SS0(Lb17) La17: SS0(Lb18) La18: SS0(Lb19) La19: SS0(Lb20) La20: SS0(Lb21) La21: SS0(Lb22) La22: SS0(Lb23) La23: SS0(Lb24) La24: SS0(Lb25) La25: SS0(Lb26) La26: SS0(Lb27) La27: SS0(Lb28) La28: SS0(Lb29) La29: SS0(Lb30) La30: SS0(Lb31) La31: SS0(Lb32) La32: addx %o2,%o2,%o2 xor %o0,-1,%o0 add %o1,%o1,%o1 sub %o1,1,%o1 addcc %o0,%o2,%o2 bcc 1f subcc %o2,%o1,%o3 subcc %o3,%o1,%o2 bcs 2f add %o0,1,%o0 add %o0,1,%o0 3: retl st %o2,[%o4] 1: bcs 3b nop add %o0,1,%o0 2: retl st %o3,[%o4] Lb01: SS1(La02) Lb02: SS1(La03) Lb03: SS1(La04) Lb04: SS1(La05) Lb05: SS1(La06) Lb06: SS1(La07) Lb07: SS1(La08) Lb08: SS1(La09) Lb09: SS1(La10) Lb10: SS1(La11) Lb11: SS1(La12) Lb12: SS1(La13) Lb13: SS1(La14) Lb14: SS1(La15) Lb15: SS1(La16) Lb16: SS1(La17) Lb17: SS1(La18) Lb18: SS1(La19) Lb19: SS1(La20) Lb20: SS1(La21) Lb21: SS1(La22) Lb22: SS1(La23) Lb23: SS1(La24) Lb24: SS1(La25) Lb25: SS1(La26) Lb26: SS1(La27) Lb27: SS1(La28) Lb28: SS1(La29) Lb29: SS1(La30) Lb30: SS1(La31) Lb31: SS1(La32) Lb32: addx %o3,%o3,%o2 xor %o0,-1,%o0 add %o1,%o1,%o1 sub %o1,1,%o1 addcc %o0,%o2,%o2 bcc 1f subcc %o2,%o1,%o3 subcc %o3,%o1,%o2 bcs 2f add %o0,1,%o0 add %o0,1,%o0 3: retl st %o2,[%o4] 1: bcs 3b nop add %o0,1,%o0 2: retl st %o3,[%o4] Lsmalldiv: addcc %o0,%o0,%o0 Lc00: SS0(Ld01) Lc01: SS0(Ld02) Lc02: SS0(Ld03) Lc03: SS0(Ld04) Lc04: SS0(Ld05) Lc05: SS0(Ld06) Lc06: SS0(Ld07) Lc07: SS0(Ld08) Lc08: SS0(Ld09) Lc09: SS0(Ld10) Lc10: SS0(Ld11) Lc11: SS0(Ld12) Lc12: SS0(Ld13) Lc13: SS0(Ld14) Lc14: SS0(Ld15) Lc15: SS0(Ld16) Lc16: SS0(Ld17) Lc17: SS0(Ld18) Lc18: SS0(Ld19) Lc19: SS0(Ld20) Lc20: SS0(Ld21) Lc21: SS0(Ld22) Lc22: SS0(Ld23) Lc23: SS0(Ld24) Lc24: SS0(Ld25) Lc25: SS0(Ld26) Lc26: SS0(Ld27) Lc27: SS0(Ld28) Lc28: SS0(Ld29) Lc29: SS0(Ld30) Lc30: SS0(Ld31) Lc31: SS0(Ld32) Lc32: xor %o0,-1,%o0 retl st %o2,[%o4] Ld01: SS1(Lc02) Ld02: SS1(Lc03) Ld03: SS1(Lc04) Ld04: SS1(Lc05) Ld05: SS1(Lc06) Ld06: SS1(Lc07) Ld07: SS1(Lc08) Ld08: SS1(Lc09) Ld09: SS1(Lc10) Ld10: SS1(Lc11) Ld11: SS1(Lc12) Ld12: SS1(Lc13) Ld13: SS1(Lc14) Ld14: SS1(Lc15) Ld15: SS1(Lc16) Ld16: SS1(Lc17) Ld17: SS1(Lc18) Ld18: SS1(Lc19) Ld19: SS1(Lc20) Ld20: SS1(Lc21) Ld21: SS1(Lc22) Ld22: SS1(Lc23) Ld23: SS1(Lc24) Ld24: SS1(Lc25) Ld25: SS1(Lc26) Ld26: SS1(Lc27) Ld27: SS1(Lc28) Ld28: SS1(Lc29) Ld29: SS1(Lc30) Ld30: SS1(Lc31) Ld31: SS1(Lc32) Ld32: xor %o0,-1,%o0 retl st %o3,[%o4] Levendiv: subcc %o2,%o1,%o3 bcc Lf01 addxcc %o0,%o0,%o0 Le01: SS0(Lf02) Le02: SS0(Lf03) Le03: SS0(Lf04) Le04: SS0(Lf05) Le05: SS0(Lf06) Le06: SS0(Lf07) Le07: SS0(Lf08) Le08: SS0(Lf09) Le09: SS0(Lf10) Le10: SS0(Lf11) Le11: SS0(Lf12) Le12: SS0(Lf13) Le13: SS0(Lf14) Le14: SS0(Lf15) Le15: SS0(Lf16) Le16: SS0(Lf17) Le17: SS0(Lf18) Le18: SS0(Lf19) Le19: SS0(Lf20) Le20: SS0(Lf21) Le21: SS0(Lf22) Le22: SS0(Lf23) Le23: SS0(Lf24) Le24: SS0(Lf25) Le25: SS0(Lf26) Le26: SS0(Lf27) Le27: SS0(Lf28) Le28: SS0(Lf29) Le29: SS0(Lf30) Le30: SS0(Lf31) Le31: SS0(Lf32) Le32: addx %o2,%o2,%o2 xor %o0,-1,%o0 retl st %o2,[%o4] Lf01: SS1(Le02) Lf02: SS1(Le03) Lf03: SS1(Le04) Lf04: SS1(Le05) Lf05: SS1(Le06) Lf06: SS1(Le07) Lf07: SS1(Le08) Lf08: SS1(Le09) Lf09: SS1(Le10) Lf10: SS1(Le11) Lf11: SS1(Le12) Lf12: SS1(Le13) Lf13: SS1(Le14) Lf14: SS1(Le15) Lf15: SS1(Le16) Lf16: SS1(Le17) Lf17: SS1(Le18) Lf18: SS1(Le19) Lf19: SS1(Le20) Lf20: SS1(Le21) Lf21: SS1(Le22) Lf22: SS1(Le23) Lf23: SS1(Le24) Lf24: SS1(Le25) Lf25: SS1(Le26) Lf26: SS1(Le27) Lf27: SS1(Le28) Lf28: SS1(Le29) Lf29: SS1(Le30) Lf30: SS1(Le31) Lf31: SS1(Le32) Lf32: addx %o3,%o3,%o3 xor %o0,-1,%o0 retl st %o3,[%o4] gcl-2.6.14/mp/lo-ibmrt.s0000755000175000017500000000165014360276512013325 0ustar cammcamm # Copyright W. Schelter 1991 # untested .file "foo.c" .data .text .globl .mulul3 .align 1 .nmulul3: .text .set L.1F,0x00000000 .set L.1L,0x00000000 .set L.1R,10 .set L.1A,0x00000004-(4*L.1R-100)-16 stm L.1R,4*L.1R-100(1) cal 1,-(16+L.1A)(1) lr 14,0 lr 12,2 lr 11,3 lr 10,4 # line 5, file "foo.c" mts 10,12 s 13,13 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 m 13,11 # 86 # 46 # line 6, file "foo.c" ci 12,0# 47 bge L.13 # line 7, file "foo.c" a 13,11# 63 L.13: # line 8, file "foo.c" ci 11,0# 47 bge L.14 # line 9, file "foo.c" a 13,12# 63 L.14: # line 10, file "foo.c" st 13,0(10)# 17 mfs 10,2 # line 11, file "foo.c" #clrcb 15,8 # DMAsync lm L.1R,(16+L.1A)+(4*L.1R-100)(1) brx 15 cal 1,16+L.1A(1) .short 0xdf01,L.1R*16+0xdf00,L.1A+16 .data 3 .globl _mulul3 _mulul3: .long .mulul3 .text .data gcl-2.6.14/mp/mpi-bsd68k.s0000755000175000017500000006464114360276512013475 0ustar cammcamm#NO_APP gcc_compiled.: .text .even .globl _mulsi _mulsi: link a6,#0 moveml #0x3f30,sp@- movel a6@(8),d4 movel a6@(12),a2 moveb a2@(4),d6 extbl d6 movel a2@(4),d5 andl #65535,d5 tstl d4 jeq L3 tstl d6 jne L2 L3: movel _gzero,d0 jra L1 L2: tstl d4 jge L4 negl d6 negl d4 jpl L4 movel a2,sp@- movel #-2147483648,sp@- jbsr _stoi addqw #4,sp movel d0,sp@- jbsr _mulii jra L1 L4: movel d5,a3 pea a3@(1) jbsr _cgeti movel d0,a1 clrl d2 movel d5,d0 asll #2,d0 addl d0,a2 lea a1@(4,d0:l),a0 movel d5,d3 subql #2,d3 jra L6 L8: movel d2,d0 movel d4,d1 #APP mulul a2@-,d2:d1 #NO_APP addl d1,d0 clrl d7 #APP addxl d7,d2 #NO_APP movel d0,a0@- L6: dbra d3,L8 clrw d3 subql #1,d3 jcc L8 tstl d2 jeq L9 movel d2,a0@- movel a1@(4),d0 clrw d0 movel d0,a3 lea a3@(1,d5:l),a3 movel a3,a1@(4) jra L10 L9: addql #4,_avma movel a1@,d7 subql #1,d7 movel d7,a1@(4) addqw #4,a1 movel a1@(4),d0 clrw d0 addl d5,d0 movel d0,a1@(4) L10: movel a1@(4),d0 andl #16777215,d0 movel d6,d1 moveq #24,d7 asll d7,d1 addl d1,d0 movel d0,a1@(4) movel a1,d0 L1: moveml a6@(-32),#0xcfc unlk a6 rts .even .globl _expi _expi: link a6,#0 movel d2,sp@- movel a6@(8),a0 movel a0@(4),d0 andl #65535,d0 moveq #2,d2 cmpl d0,d2 jne L12 movel #-8388608,d0 jra L13 L12: subql #2,d0 asll #5,d0 #APP bfffo a0@(8){#0:#0},d1 #NO_APP subl d1,d0 subql #1,d0 L13: movel a6@(-4),d2 unlk a6 rts .even .globl _addsi _addsi: link a6,#0 moveml #0x3e20,sp@- movel a6@(8),d3 movel a6@(12),a2 jne L15 movel a2,sp@- jbsr _icopy jra L14 L15: moveb a2@(4),d4 extbl d4 jne L16 movel d3,sp@- jbsr _stoi jra L14 L16: tstl d3 jge L17 moveq #-1,d5 negl d3 jpl L19 movel a2,sp@- pea _MOST_NEGS jbsr _addii jra L14 L17: moveq #1,d5 L19: movel a2@(4),d2 andl #65535,d2 cmpl d5,d4 jne L20 movel d3,d1 addl a2@(-4,d2:l:4),d3 cmpl d3,d1 jls L21 moveq #1,d0 jra L22 L21: clrl d0 L22: tstl d0 jeq L23 movel d2,a1 pea a1@(1) jbsr _cgeti movel d0,a0 movel d3,a0@(d2:l:4) movel d2,d0 jra L65 L27: moveq #-1,d6 cmpl a2@(-4,d0:l:4),d6 jne L25 clrl a0@(d0:l:4) L65: subql #1,d0 moveq #2,d6 cmpl d0,d6 jlt L27 L25: moveq #2,d6 cmpl d0,d6 jge L28 movel a2@(-4,d0:l:4),d6 addql #1,d6 movel d6,a0@(d0:l:4) jra L66 L31: movel a2@(-4,d0:l:4),a0@(d0:l:4) L66: subql #1,d0 moveq #2,d6 cmpl d0,d6 jlt L31 movel a0@,d0 subql #1,d0 movel d0,a0@(4) movel d0,a0@(8) addqw #4,a0 addql #4,_avma jra L33 L28: moveq #1,d6 movel d6,a0@(8) movel a0@,a0@(4) jra L33 L23: movel d2,sp@- jbsr _cgeti movel d0,a0 movel d3,a0@(-4,d2:l:4) moveq #1,d0 movel d2,d1 subql #1,d1 jra L34 L37: movel a2@(d0:l:4),a0@(d0:l:4) addql #1,d0 L34: cmpl d0,d1 jgt L37 L33: movel a0@(4),d0 andl #16777215,d0 movel d5,d1 jra L67 L20: moveq #3,d6 cmpl d2,d6 jne L39 cmpl a2@(8),d3 jcc L40 pea 3:w jbsr _cgeti movel d0,a0 movel d4,d0 moveq #24,d6 asll d6,d0 addql #3,d0 movel d0,a0@(4) movel a2@(8),d6 subl d3,d6 movel d6,a0@(8) jra L38 L40: cmpl a2@(8),d3 jne L41 movel _gzero,d0 jra L14 L41: pea 3:w jbsr _cgeti movel d0,a0 movel d4,d0 negl d0 moveq #24,d6 asll d6,d0 addql #3,d0 movel d0,a0@(4) subl a2@(8),d3 movel d3,a0@(8) jra L38 L39: movel a2@(-4,d2:l:4),d1 movel d3,d0 movel d1,d3 subl d0,d3 cmpl d1,d0 jhi L42 clrl d0 jra L43 L42: moveq #1,d0 L43: tstl d0 jeq L44 movel d2,sp@- jbsr _cgeti movel d0,a0 movel d3,a0@(-4,d2:l:4) movel d2,d0 subql #2,d0 tstl a2@(d0:l:4) jne L62 L48: moveq #-1,d6 movel d6,a0@(d0:l:4) subql #1,d0 tstl a2@(d0:l:4) jeq L48 L62: movel a2@(d0:l:4),d1 subql #1,d1 movel d1,a0@(d0:l:4) moveq #2,d6 cmpl d0,d6 jlt L50 tstl d1 jeq L49 L50: subql #1,d0 tstl d0 jle L38 L54: movel a2@(d0:l:4),a0@(d0:l:4) subql #1,d0 tstl d0 jgt L54 jra L38 L49: movel a0@,d0 subql #1,d0 movel d0,a0@(4) movel d0,a0@(8) addqw #4,a0 addql #4,_avma movel a0@(4),d0 andl #16777215,d0 movel d4,d1 L67: moveq #24,d6 asll d6,d1 addl d1,d0 movel d0,a0@(4) jra L38 L44: movel d2,sp@- jbsr _cgeti movel d0,a0 movel d3,a0@(-4,d2:l:4) moveq #1,d0 movel d2,d1 subql #1,d1 jra L57 L60: movel a2@(d0:l:4),a0@(d0:l:4) addql #1,d0 L57: cmpl d0,d1 jgt L60 L38: movel a0,d0 L14: moveml a6@(-24),#0x47c unlk a6 rts .even .globl _addii _addii: link a6,#-4 moveml #0x3f3c,sp@- movel a6@(8),a5 movel a6@(12),a6@(-4) movel a5@(4),d4 andl #65535,d4 movel a6@(-4),a4 movel a4@(4),d5 andl #65535,d5 cmpl d4,d5 jle L69 movel a5,a3 movel a6@(-4),a5 movel a3,a6@(-4) movel d4,d6 movel d5,d4 movel d6,d5 L69: movel a6@(-4),a4 moveb a4@(4),d7 extbl d7 movel d7,a2 tstl a2 jne L70 movel a5,sp@- jbsr _icopy jra L68 L70: moveb a5@(4),d6 extbl d6 cmpl d6,a2 jne L71 movel d4,a4 pea a4@(1) jbsr _cgeti movel d0,a3 clrl d1 movel d4,d0 asll #2,d0 lea a3@(4,d0:l),a2 lea a5@(0,d0:l),a1 movel a6@(-4),a4 lea a4@(d5:l:4),a0 movel d5,d2 subql #2,d2 L72: #APP addl #-1,d1 #NO_APP moveq #16,d7 cmpl d7,d2 jhi L77 LI94: movew pc@(L94-LI94-2:b,d2:l:2),d7 jmp pc@(2,d7:w) L94: .word L93-L94 .word L92-L94 .word L91-L94 .word L90-L94 .word L89-L94 .word L88-L94 .word L87-L94 .word L86-L94 .word L85-L94 .word L84-L94 .word L83-L94 .word L82-L94 .word L81-L94 .word L80-L94 .word L79-L94 .word L78-L94 .word L77-L94 L77: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L78: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L79: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L80: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L81: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L82: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L83: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L84: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L85: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L86: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L87: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L88: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L89: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L90: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L91: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L92: movel a1@-,d7 movel a0@-,d3 #APP addxl d3,d7 #NO_APP movel d7,a2@- L93: #APP clrl d1 addxl d1,d1 #NO_APP moveq #-16,d7 addl d7,d2 tstl d2 jgt L72 tstl d1 jeq L95 movel a5,d0 addql #8,d0 L96: subqw #4,a1 movel a1,a0 cmpl a1,d0 jhi L97 moveq #-1,d7 cmpl a1@,d7 jne L98 clrl a2@- jra L96 L98: movel a0@,d7 addql #1,d7 movel d7,a2@- jra L100 L102: movel a0@,a2@- L100: subqw #4,a1 movel a1,a0 cmpl a1,d0 jls L102 jra L160 L97: moveq #1,d7 movel d7,a3@(8) movel a5@(4),d7 addql #1,d7 movel d7,a3@(4) jra L108 L95: movel d4,d1 subl d5,d1 jra L105 L107: movel a1@-,a2@- L105: dbra d1,L107 clrw d1 subql #1,d1 jcc L107 L160: movel a3@,d7 subql #1,d7 movel d7,a3@(4) movel a5@(4),a3@(8) addqw #4,a3 addql #4,_avma jra L108 L71: cmpl d4,d5 jne L109 movel d4,d1 subql #2,d1 lea a5@(8),a1 movel a6@(-4),a0 addqw #8,a0 jra L110 L116: movel a1@+,d2 movel a0@+,d0 cmpl d0,d2 jcc L112 movel a5,a3 movel a6@(-4),a5 movel a3,a6@(-4) movel a2,d6 jra L109 L112: cmpl d2,d0 jcs L109 L110: dbra d1,L116 clrw d1 subql #1,d1 jcc L116 movel _gzero,d0 jra L68 L109: movel d4,sp@- jbsr _cgeti movel d0,a3 clrl d1 movel d4,d0 asll #2,d0 lea a5@(0,d0:l),a1 movel a6@(-4),a4 lea a4@(d5:l:4),a0 lea a3@(0,d0:l),a2 movel d5,d2 subql #2,d2 L118: #APP addl #-1,d1 #NO_APP moveq #16,d7 cmpl d7,d2 jhi L123 LI140: movew pc@(L140-LI140-2:b,d2:l:2),d7 jmp pc@(2,d7:w) L140: .word L139-L140 .word L138-L140 .word L137-L140 .word L136-L140 .word L135-L140 .word L134-L140 .word L133-L140 .word L132-L140 .word L131-L140 .word L130-L140 .word L129-L140 .word L128-L140 .word L127-L140 .word L126-L140 .word L125-L140 .word L124-L140 .word L123-L140 L123: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L124: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L125: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L126: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L127: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L128: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L129: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L130: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L131: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L132: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L133: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L134: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L135: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L136: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L137: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L138: movel a1@-,d7 movel a0@-,d3 #APP subxl d3,d7 #NO_APP movel d7,a2@- L139: #APP clrl d1 addxl d1,d1 #NO_APP moveq #-16,d7 addl d7,d2 tstl d2 jgt L118 tstl d1 jeq L141 jra L142 L144: moveq #-1,d7 movel d7,a2@- L142: movel a1@-,d0 jeq L144 movel a5,d1 addql #8,d1 cmpl a1,d1 jhi L149 subql #1,d0 movel d0,a2@- jra L146 L148: movel a0@,a2@- L146: subqw #4,a1 movel a1,a0 cmpl a1,d1 jls L148 jra L149 L141: movel d4,d2 subl d5,d2 jra L150 L152: movel a1@-,a2@- L150: dbra d2,L152 clrw d2 subql #1,d2 jcc L152 L149: tstl a3@(8) jeq L153 movel a5@(4),a3@(4) jra L108 L153: lea a3@(12),a2 tstl a2@ jne L159 L157: addqw #4,a2 tstl a2@ jeq L157 L159: subqw #8,a2 movel a2,d2 subl a3,d2 jpl L158 addql #3,d2 L158: asrl #2,d2 movel a3@,d0 subl d2,d0 movel d0,a2@ movel d0,a2@(4) movel a2,a3 movel a3@(4),d0 andl #16777215,d0 movel d6,d1 moveq #24,d7 asll d7,d1 addl d1,d0 movel d0,a3@(4) movel d2,d0 asll #2,d0 addl d0,_avma L108: movel a3,d0 L68: moveml a6@(-44),#0x3cfc unlk a6 rts .even .globl _mulss _mulss: link a6,#0 moveml #0x3c00,sp@- movel a6@(8),d0 movel a6@(12),d2 tstl d0 jeq L163 tstl d2 jne L162 L163: movel _gzero,d0 jra L161 L162: moveq #1,d4 tstl d0 jge L164 moveq #-1,d4 negl d0 jpl L164 movel d0,sp@- jbsr _stoi movel d0,sp@- movel d2,sp@- jbsr _mulsi jra L161 L164: tstl d2 jge L166 negl d4 negl d2 jpl L166 pea _ABS_MOST_NEGS tstl d4 jgt L169 negl d0 L169: movel d0,sp@- jbsr _mulsi jra L161 L166: #APP mulul d2,d3:d0 #NO_APP movel d0,d2 tstl d3 jeq L170 pea 4:w jbsr _cgeti movel d0,a0 movel d3,a0@(8) movel d2,a0@(12) jra L171 L170: pea 3:w jbsr _cgeti movel d0,a0 movel d2,a0@(8) L171: movel a0@,a0@(4) movel a0@(4),d0 andl #16777215,d0 movel d4,d1 moveq #24,d5 asll d5,d1 addl d1,d0 movel d0,a0@(4) movel a0,d0 L161: moveml a6@(-16),#0x3c unlk a6 rts .even .globl _mulii _mulii: link a6,#-8 moveml #0x3f3c,sp@- movel a6@(8),a3 movel a6@(12),d7 movel a3@(4),d5 andl #65535,d5 movel d7,a5 movel a5@(4),d6 andl #65535,d6 movel d6,a6@(-4) moveb a3@(4),d2 extbl d2 jeq L188 movel d7,a5 moveb a5@(4),d0 extbl d0 jne L174 L188: movel _gzero,d0 jra L172 L174: tstl d0 jge L175 negl d2 L175: cmpl a6@(-4),d5 jle L176 movel a3,a2 movel d7,a3 movel a2,d7 movel d5,a4 movel a6@(-4),d5 movel a4,a6@(-4) L176: movel a6@(-4),a5 lea a5@(-2,d5:l),a4 cmpl #65535,a4 jle L177 pea 17:w jbsr _err addqw #4,sp L177: movel a4,sp@- jbsr _cgeti movel d0,a2 movel a2@,a2@(4) movel a2@(4),d0 andl #16777215,d0 movel d2,d1 moveq #24,d6 asll d6,d1 addl d1,d0 movel d0,a2@(4) lea a3@(d5:l:4),a5 movel a5,a6@(-8) movel a6@(-8),a5 subqw #4,a5 movel a5,a6@(-8) movel a5@,d4 clrl d2 movel a6@(-4),d3 subql #2,d3 movel d7,a5 movel a6@(-4),d6 lea a5@(d6:l:4),a1 lea a2@(a4:l:4),a3 jra L178 L180: movel d2,d0 movel d4,d1 #APP mulul a1@-,d2:d1 #NO_APP addl d1,d0 clrl d6 #APP addxl d6,d2 #NO_APP movel d0,a3@- L178: dbra d3,L180 clrw d3 subql #1,d3 jcc L180 movel d2,a3@- lea a2@(a4:l:4),a3 movel d7,a5 movel a6@(-4),d6 lea a5@(d6:l:4),a4 subql #2,a6@(-4) subql #2,d5 clrl d7 jra L181 L186: movel a6@(-8),a5 subqw #4,a5 movel a5,a6@(-8) movel a5@,d4 movel a6@(-4),d3 movel a4,a1 lea a3@(-4),a0 movel a0,a3 clrl d1 jra L183 L185: movel a1@-,d0 #APP mulul d4,d2:d0 #NO_APP addl a0@-,d0 #APP addxl d7,d2 #NO_APP addl d1,d0 #APP addxl d7,d2 #NO_APP movel d0,a0@ movel d2,d1 L183: dbra d3,L185 clrw d3 subql #1,d3 jcc L185 movel d2,a0@- L181: subql #1,d5 tstl d5 jgt L186 tstl a2@(8) jne L187 movel a2@(4),d6 subql #1,d6 movel d6,a2@(8) movel a2@,d6 subql #1,d6 movel d6,a2@(4) addqw #4,a2 addql #4,_avma L187: movel a2,d0 L172: moveml a6@(-48),#0x3cfc unlk a6 rts .even .globl _confrac _confrac: link a6,#-8 moveml #0x3f3c,sp@- movel a6@(8),a5 movel a5@,d7 andl #65535,d7 movel d7,a6@(-8) movel a5@(4),d5 andl #16777215,d5 addl #-8388608,d5 moveq #-1,d7 subl d5,d7 movel d7,d5 movel _avma,a6@(-4) movel a6@(-8),a4 subqw #2,a4 movel a4,d7 asll #5,d7 movel d7,a4 addl d5,a4 lea a4@(63),a3 movel a3,d7 asrl #5,d7 movel d7,a3 movel a3,sp@- jbsr _cgeti movel d0,a2 movel d5,d0 asrl #5,d0 clrl d3 addqw #4,sp cmpl d3,d0 jle L216 L193: clrl a2@(d3:l:4) addql #1,d3 cmpl d3,d0 jgt L193 L216: moveq #31,d7 andl d7,d5 jne L194 moveq #2,d4 cmpl a6@(-8),d4 jge L199 L198: movel a5@(d4:l:4),a2@(d3:l:4) addql #1,d3 addql #1,d4 cmpl a6@(-8),d4 jlt L198 jra L199 L194: clrl d6 moveq #2,d4 cmpl a6@(-8),d4 jge L214 moveq #32,d7 subl d5,d7 movel d7,a0 L203: movel d3,d0 movel a5@(d4:l:4),d2 addql #1,d3 movel d2,d1 lsrl d5,d1 addl d6,d1 movel d1,a2@(d0:l:4) movel d2,d6 movel a0,d7 lsll d7,d6 addql #1,d4 cmpl a6@(-8),d4 jlt L203 L214: movel d6,a2@(-8,a3:l:4) L199: clrl a2@(-4,a3:l:4) movel a4,d7 fmovel d7,fp0 fmuld #0r.30102999999999999758,fp0 fmovecr #0x32,fp1 faddx fp1,fp0 fintrzx fp0,fp0 fmovel fp0,d2 moveq #17,d5 addl d2,d5 moveq #9,d7 divsl d7,d5 movel d5,sp@- jbsr _cgeti movel d0,a0 movel d2,a0@ moveq #1,d4 cmpl d4,d5 jle L213 movel #1000000000,d6 L211: clrl d1 movel a3,d3 jra L217 L210: movel d1,d2 movel a2@(d3:l:4),d0 #APP mulul d6,d1:d0 #NO_APP addl d2,d0 clrl d7 #APP addxl d7,d1 #NO_APP movel d0,a2@(d3:l:4) L217: subql #1,d3 jpl L210 movel d1,a0@(d4:l:4) addql #1,d4 cmpl d4,d5 jgt L211 L213: movel a6@(-4),_avma movel a0,d0 moveml a6@(-48),#0x3cfc unlk a6 rts .even .globl _divss _divss: link a6,#0 moveml #0x3820,sp@- movel a6@(8),d4 movel a6@(12),d3 jne L219 pea 23:w jbsr _err addqw #4,sp L219: cmpl #-2147483648,d4 jne L220 movel d3,sp@- movel d4,sp@- jbsr _stoi addqw #4,sp movel d0,sp@- jbsr _divis jra L218 L220: clrl _hiremainder movel d4,sp@- lea _abs,a2 jbsr a2@ movel d0,d2 movel d3,sp@- jbsr a2@ movel _hiremainder,d1 #APP divul d0,d1:d2 #NO_APP movel d1,_hiremainder movel d2,d0 addqw #8,sp tstl d3 jge L221 negl _hiremainder negl d0 L221: tstl d4 jge L222 negl d0 L222: movel d0,sp@- jbsr _stoi L218: moveml a6@(-16),#0x41c unlk a6 rts .even .globl _modss _modss: link a6,#0 moveml #0x3820,sp@- movel a6@(8),d2 movel a6@(12),d4 jne L224 pea 38:w jbsr _err addqw #4,sp L224: cmpl #-2147483648,d2 jne L225 movel d4,sp@- movel d2,sp@- jbsr _stoi addqw #4,sp movel d0,sp@- jbsr _modis jra L223 L225: clrl d3 movel d2,sp@- lea _abs,a2 jbsr a2@ movel d0,d2 movel d4,sp@- jbsr a2@ #APP divul d0,d3:d2 #NO_APP addqw #8,sp tstl d3 jne L226 movel _gzero,d0 jra L223 L226: tstl d3 jge L227 subl d3,d0 movel d0,sp@- jra L229 L227: movel d3,sp@- L229: jbsr _stoi L223: moveml a6@(-16),#0x41c unlk a6 rts .even .globl _resss _resss: link a6,#0 moveml #0x3820,sp@- movel a6@(12),d4 jne L231 pea 40:w jbsr _err addqw #4,sp L231: clrl d3 movel a6@(8),sp@- lea _abs,a2 jbsr a2@ movel d0,d2 movel d4,sp@- jbsr a2@ #APP divul d0,d3:d2 #NO_APP addqw #8,sp tstl d4 jge L232 negl d3 L232: movel d3,sp@- jbsr _stoi moveml a6@(-16),#0x41c unlk a6 rts .even .globl _divsi _divsi: link a6,#0 moveml #0x3820,sp@- movel a6@(8),d3 movel a6@(12),a2 moveb a2@(4),d0 extbl d0 movel a2@(4),d2 andl #65535,d2 tstl d0 jne L235 pea 24:w jbsr _err addqw #4,sp L235: tstl d3 jeq L237 moveq #3,d4 cmpl d2,d4 jlt L237 tstl a2@(8) jge L236 L237: movel d3,_hiremainder movel _gzero,d0 jra L234 L236: cmpl #-2147483648,d3 jne L238 clrl sp@- movel a2,sp@- movel d3,sp@- jbsr _stoi addqw #4,sp movel d0,sp@- jbsr _dvmdii jra L234 L238: clrl _hiremainder movel d3,sp@- jbsr _abs movel _hiremainder,d4 #APP divul a2@(8),d4:d0 #NO_APP movel d4,_hiremainder movel d0,d1 moveb a2@(4),d0 extbl d0 addqw #4,sp jpl L239 negl _hiremainder negl d1 L239: tstl d3 jge L240 negl d1 L240: movel d1,sp@- jbsr _stoi L234: moveml a6@(-16),#0x41c unlk a6 rts .even .globl _divis _divis: link a6,#0 moveml #0x3f30,sp@- movel a6@(8),a2 movel a6@(12),d3 moveb a2@(4),d7 extbl d7 movel a2@(4),d6 andl #65535,d6 tstl d3 jne L242 pea 26:w jbsr _err addqw #4,sp L242: tstl d7 jne L243 clrl _hiremainder movel _gzero,d0 jra L241 L243: tstl d3 jge L244 negl d7 negl d3 jpl L244 clrl sp@- movel d3,sp@- jbsr _stoi addqw #4,sp movel d0,sp@- movel a2,sp@- jbsr _dvmdii jra L241 L244: cmpl a2@(8),d3 jls L246 moveq #3,d5 cmpl d6,d5 jne L247 movel a2,sp@- jbsr _itos movel d0,_hiremainder movel _gzero,d0 jra L241 L247: movel d6,a1 pea a1@(-1) jbsr _cgeti movel d0,a0 movew #1,a3 movel a2@(8),d4 jra L249 L246: movel d6,sp@- jbsr _cgeti movel d0,a0 subl a3,a3 clrl d4 L249: movel a3,d2 addql #2,d2 cmpl d2,d6 jle L256 L253: movel d2,d1 subl a3,d1 movel a2@(d2:l:4),d0 #APP divul d3,d4:d0 #NO_APP movel d0,a0@(d1:l:4) addql #1,d2 cmpl d2,d6 jgt L253 L256: movel a0@,a0@(4) movel a0@(4),d0 andl #16777215,d0 movel d7,d1 moveq #24,d5 asll d5,d1 addl d1,d0 movel d0,a0@(4) tstl d7 jge L254 movel d4,d0 negl d0 jra L255 L254: movel d4,d0 L255: movel d0,_hiremainder movel a0,d0 L241: moveml a6@(-32),#0xcfc unlk a6 rts .even .globl _dvmdii _dvmdii: link a6,#-60 moveml #0x3f3c,sp@- movel a6@(8),a4 moveb a4@(4),d6 extbl d6 movel d6,a6@(-24) movel a6@(12),a1 moveb a1@(4),d6 extbl d6 movel d6,a6@(-28) jne L258 pea 36:w jbsr _err addqw #4,sp L258: tstl a6@(-24) jne L259 moveq #-1,d6 cmpl a6@(16),d6 jeq L361 tstl a6@(16) jeq L361 movel a6@(16),a1 movel _gzero,a1@ L361: movel _gzero,d0 jra L257 L259: movel a4@(4),d6 andl #65535,d6 movel d6,a6@(-8) movel a6@(12),a1 movel a1@(4),d6 andl #65535,d6 movel d6,a6@(-12) movel a6@(-8),d6 subl a6@(-12),d6 movel d6,a6@(-16) jge L262 moveq #-1,d6 cmpl a6@(16),d6 jne L263 movel a4,sp@- jbsr _icopy jra L257 L263: tstl a6@(16) jeq L361 movel a4,sp@- jbsr _icopy movel a6@(16),a1 movel d0,a1@ jra L361 L262: movel _avma,a6@(-4) tstl a6@(-24) jge L265 negl a6@(-28) L265: moveq #3,d6 cmpl a6@(-12),d6 jne L266 movel a6@(12),a1 movel a1@(8),a6@(-60) lea a4@(8),a3 movel a6@(-60),d6 cmpl a4@(8),d6 jls L267 movel a6@(-8),d2 subql #1,d2 movel a3@+,d5 jra L268 L267: movel a6@(-8),d2 clrl d5 L268: movel d2,sp@- jbsr _cgeti movel d0,a6@(-36) movel d2,d7 subql #2,d7 movel d0,a2 addqw #8,a2 addqw #4,sp jra L269 L271: movel a3@+,d0 #APP divul a6@(-60),d5:d0 #NO_APP movel d0,a2@+ L269: dbra d7,L271 clrw d7 subql #1,d7 jcc L271 moveq #-1,d6 cmpl a6@(16),d6 jne L272 movel a6@(-4),_avma tstl d5 jeq L361 pea 3:w jbsr _cgeti movel d0,a6@(-40) movel a6@(-24),d0 moveq #24,d6 asll d6,d0 movel a6@(-40),a1 addql #3,d0 movel d0,a1@(4) movel d5,a1@(8) movel a1,d0 jra L257 L272: moveq #2,d6 cmpl d2,d6 jeq L274 movel a6@(-36),a1 movel a1@,a1@(4) movel a1@(4),d0 andl #16777215,d0 movel a6@(-28),d1 moveq #24,d6 asll d6,d1 addl d1,d0 movel d0,a1@(4) jra L275 L274: movel a6@(-4),_avma movel _gzero,a6@(-36) L275: tstl a6@(16) jne L276 L359: movel a6@(-36),d0 jra L257 L276: tstl d5 jne L277 movel a6@(16),a1 movel _gzero,a1@ jra L359 L277: pea 3:w jbsr _cgeti movel d0,a6@(-40) movel a6@(-24),d0 moveq #24,d6 asll d6,d0 movel a6@(-40),a1 addql #3,d0 movel d0,a1@(4) movel d5,a1@(8) movel a6@(16),a1 movel a6@(-40),a1@ jra L359 L266: movel a6@(-8),sp@- lea _cgeti,a3 jbsr a3@ movel d0,a6@(-36) movel a6@(12),a1 #APP bfffo a1@(8){#0:#0},d6 #NO_APP movel d6,a6@(-20) addqw #4,sp jeq L280 movel a1,a2 addqw #8,a2 movel a6@(-12),sp@- jbsr a3@ movel d0,a6@(-40) movel a2@+,d1 moveq #32,d0 subl d6,d0 movel d1,d5 lsrl d0,d5 lsll d6,d1 movel d1,a6@(-56) movel a6@(-40),a0 addqw #8,a0 movel a6@(-12),d7 subql #3,d7 addqw #4,sp moveq #32,d0 subl d6,d0 jra L281 L283: movel a2@+,d1 movel d1,d5 lsrl d0,d5 movel a6@(-56),d6 addl d5,d6 movel d6,a0@+ movel a6@(-20),d6 lsll d6,d1 movel d1,a6@(-56) L281: dbra d7,L283 clrw d7 subql #1,d7 jcc L283 movel a6@(-56),a0@ clrl a6@(-56) lea a4@(8),a3 movel a6@(-36),a2 addqw #4,a2 movel a6@(-8),d7 subql #2,d7 moveq #32,d0 subl a6@(-20),d0 jra L284 L286: movel a3@+,d1 movel d1,d5 lsrl d0,d5 movel a6@(-56),d6 addl d5,d6 movel d6,a2@+ movel a6@(-20),d6 lsll d6,d1 movel d1,a6@(-56) L284: dbra d7,L286 clrw d7 subql #1,d7 jcc L286 movel a6@(-56),a2@ jra L287 L280: lea a4@(8),a3 movel a6@(-36),a2 addqw #4,a2 clrl a2@+ movel a6@(-8),d4 subql #2,d4 jra L288 L290: movel a3@+,a2@+ L288: dbra d4,L290 clrw d4 subql #1,d4 jcc L290 movel a6@(12),a6@(-40) L287: movel a6@(-40),a1 movel a1@(8),a6@(-60) movel a1@(12),a6@(-32) movel a6@(-36),a2 addqw #4,a2 movel a6@(-16),d7 addql #1,d7 movel a6@(-12),d6 asll #2,d6 movel d6,a6@(-52) jra L291 L322: movel a2@+,d6 cmpl a6@(-60),d6 jne L293 movew #-1,a4 movel a6@(-60),d1 movel d1,d3 addl a2@,d3 cmpl d3,d1 jls L294 moveq #1,d2 jra L295 L294: clrl d2 L295: movel d3,a6@(-56) jra L296 L293: movel a2@,d0 movel a2@(-4),d5 #APP divul a6@(-60),d5:d0 #NO_APP movel d0,a4 clrl d2 movel d5,a6@(-56) L296: tstl d2 jne L297 movel a4,d0 #APP mulul a6@(-32),d5:d0 #NO_APP movel d0,d1 movel a2@(4),d0 movel d1,d3 subl d0,d3 cmpl d1,d0 jhi L298 clrl d2 jra L299 L298: moveq #1,d2 L299: movel d3,a0 movel d5,d1 movel a6@(-56),d0 movel d5,d3 subl a6@(-56),d3 subl d2,d3 cmpl a6@(-56),d5 jcs L362 jra L308 L312: tstl d4 jeq L297 subqw #1,a4 movel a0,d1 movel a6@(-32),d0 movel d1,d3 subl d0,d3 cmpl d1,d0 jhi L306 clrl d2 jra L307 L306: moveq #1,d2 L307: movel d3,a0 movel d4,d1 movel a6@(-60),d0 movel d1,d3 subl d0,d3 subl d2,d3 cmpl d0,d1 jcc L308 L362: moveq #1,d2 jra L309 L308: cmpl d0,d1 jls L309 clrl d2 L309: movel d3,d4 tstl d2 jeq L312 L297: clrl d5 movel a6@(-12),d4 subql #2,d4 movel a6@(-52),d6 lea a2@(-8,d6:l),a0 movel a6@(-40),d6 addl a6@(-52),d6 movel d6,a6@(-56) jra L313 L317: movel d5,d1 movel a6@(-56),a1 subqw #4,a1 movel a1,a6@(-56) movel a4,d0 #APP mulul a1@,d5:d0 #NO_APP movel d0,d3 movel d1,d0 addl d3,d0 clrl d6 #APP addxl d6,d5 #NO_APP movel d0,d2 subqw #4,a0 movel a0,a3 movel a0@,d1 movel d1,d3 subl d2,d3 cmpl d1,d2 jhi L315 clrl d2 jra L316 L315: moveq #1,d2 L316: movel d3,a3@ addl d2,d5 L313: dbra d4,L317 clrw d4 subql #1,d4 jcc L317 cmpl a2@(-4),d5 jls L318 clrl d2 subqw #1,a4 movel a6@(-12),d4 subql #2,d4 movel a6@(-52),d6 lea a2@(-8,d6:l),a0 movel a6@(-40),d6 addl a6@(-52),d6 movel d6,a6@(-56) jra L319 L321: #APP addl #-1,d2 #NO_APP movel a6@(-56),a1 subqw #4,a1 movel a1,a6@(-56) movel a0@-,d0 movel a1@,d6 #APP addxl d6,d0 #NO_APP movel d0,a0@ #APP clrl d2 addxl d2,d2 #NO_APP L319: dbra d4,L321 clrw d4 subql #1,d4 jcc L321 L318: movel a4,a2@(-4) L291: dbra d7,L322 clrw d7 subql #1,d7 jcc L322 movel _avma,d3 moveq #-1,d6 cmpl a6@(16),d6 jeq L323 movel a6@(-16),d2 addql #2,d2 movel a6@(-36),a1 lea a1@(d2:l:4),a2 tstl a1@(4) jeq L324 addql #1,d2 jra L325 L324: tstl a6@(-16) jne L325 clrl a6@(-28) L325: movel d2,sp@- jbsr _cgeti movel d0,a6@(-44) movel d0,a1 lea a1@(d2:l:4),a0 movel d2,d4 subql #2,d4 addqw #4,sp jra L327 L329: movel a2@-,a0@- L327: dbra d4,L329 clrw d4 subql #1,d4 jcc L329 moveq #2,d6 cmpl d2,d6 jcs L330 movel a6@(-44),a1 moveq #2,d6 movel d6,a1@(4) jra L323 L330: movel a6@(-44),a1 movel a1@,a1@(4) movel a1@(4),d0 andl #16777215,d0 movel a6@(-28),d1 moveq #24,d6 asll d6,d1 addl d1,d0 movel d0,a1@(4) L323: tstl a6@(16) jeq L332 movel a6@(-16),d4 addql #2,d4 cmpl a6@(-8),d4 jge L334 L336: movel a6@(-36),a1 tstl a1@(d4:l:4) jne L334 addql #1,d4 cmpl a6@(-8),d4 jlt L336 L334: cmpl a6@(-8),d4 jne L337 movel _gzero,sp@- jbsr _icopy movel d0,a6@(-48) addqw #4,sp jra L332 L337: movel a6@(-8),a0 subl d4,a0 pea a0@(2) jbsr _cgeti movel d0,a6@(-48) movel d0,a1 movel a1@,a1@(4) addqw #4,sp tstl a6@(-20) jne L339 moveq #2,d7 cmpl a6@(-8),d4 jge L344 L343: movel a6@(-48),a1 movel a6@(-36),a5 movel a5@(d4:l:4),a1@(d7:l:4) addql #1,d4 addql #1,d7 cmpl a6@(-8),d4 jlt L343 jra L344 L339: movel a6@(-36),a1 movel a1@(d4:l:4),d1 addql #1,d4 moveq #32,d0 subl a6@(-20),d0 movel d1,d2 movel a6@(-20),d6 lsrl d6,d2 lsll d0,d1 movel d1,a6@(-56) tstl d2 jeq L345 movel a6@(-48),a1 movel d2,a1@(8) moveq #1,d0 jra L346 L345: movel a6@(-48),a1 movel a1@,d6 subql #1,d6 movel d6,a1@(4) addql #4,a6@(-48) addql #4,_avma movel a6@(-48),a1 movel a1@,a1@(4) clrl d0 L346: movel d0,d7 addql #2,d7 cmpl a6@(-8),d4 jge L344 moveq #32,d2 subl a6@(-20),d2 L350: movel a6@(-36),a1 movel a1@(d4:l:4),d1 movel d1,d0 movel a6@(-20),d6 lsrl d6,d0 movel a6@(-48),a1 addl a6@(-56),d0 movel d0,a1@(d7:l:4) lsll d2,d1 movel d1,a6@(-56) addql #1,d4 addql #1,d7 cmpl a6@(-8),d4 jlt L350 L344: movel a6@(-48),a1 movel a1@(4),d0 andl #16777215,d0 movel a6@(-24),d1 moveq #24,d6 asll d6,d1 addl d1,d0 movel d0,a1@(4) L332: moveq #-1,d6 cmpl a6@(16),d6 jne L351 movel a6@(-48),sp@- jra L360 L351: tstl a6@(16) jne L352 movel a6@(-44),sp@- L360: movel d3,sp@- movel a6@(-4),sp@- jbsr _gerepile jra L257 L352: clrl sp@- movel d3,sp@- movel a6@(-4),sp@- jbsr _gerepile moveq #-4,d6 andl d6,d0 movel a6@(16),a1 movel a6@(-48),d6 addl d0,d6 movel d6,a1@ addl a6@(-44),d0 L257: moveml a6@(-100),#0x3cfc unlk a6 rts .even .globl _mulul3 _mulul3: link a6,#0 movel a6@(16),a0 movel a6@(8),d0 movel a0@,d1 #APP mulul a6@(12),d1:d0 #NO_APP movel d1,a0@ unlk a6 rts .even .globl _divul3 _divul3: link a6,#0 movel a6@(16),a0 movel a6@(8),d0 movel a0@,d1 #APP divul a6@(12),d1:d0 #NO_APP movel d1,a0@ unlk a6 rts .comm _in_saved_avma,4 gcl-2.6.14/mp/mpi-sol-sparc.s0000755000175000017500000013316214360276512014272 0ustar cammcamm .file "mpi.c" gcc2_compiled.: .section ".text" .align 4 .global mulsi .type mulsi,#function .proc 0104 mulsi: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 ld [%i1+4],%o1 sra %o1,24,%l1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %i0,0 be .LL3 and %o1,%o0,%l0 cmp %l1,0 bne .LL2 cmp %i0,0 .LL3: sethi %hi(gzero),%o0 b .LL12 ld [%o0+%lo(gzero)],%i0 .LL2: bge .LL4 nop subcc %g0,%i0,%i0 bpos .LL4 sub %g0,%l1,%l1 call stoi,0 sethi %hi(-2147483648),%o0 call mulii,0 mov %i1,%o1 b .LL12 mov %o0,%i0 .LL4: call cgeti,0 add %l0,1,%o0 mov %o0,%g3 mov 0,%o2 sll %l0,2,%o0 add %i1,%o0,%i1 add %g3,%o0,%g2 addcc %l0,-2,%o3 be .LL7 add %g2,4,%g2 .LL8: add %g2,-4,%g2 mov %o2,%o1 add %i1,-4,%i1 mov %i0,%o0 ld [%i1],%l2 or %o0,%l2,%o4 mov %o0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%g0,%o4 tst %l2 bl,a 1f add %o4,%o0,%o4 1: mov %o4,%o2 b 3f rd %y,%o0 2: clr %o2 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%l2,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o0 3: addcc %o1,%o0,%l2 addx %o2,%g0,%o2 addcc %o3,-1,%o3 bne .LL8 st %l2,[%g2] .LL7: cmp %o2,0 be .LL10 sethi %hi(-65536),%o1 st %o2,[%g2-4] ld [%g3+4],%o0 and %o0,%o1,%o0 add %o0,%l0,%o0 b .LL13 add %o0,1,%o0 .LL10: sethi %hi(avma),%o1 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(avma)] ld [%g3],%o0 add %o0,-1,%o0 st %o0,[%g3+4] add %g3,4,%g3 ld [%g3+4],%o0 sethi %hi(-65536),%o1 and %o0,%o1,%o0 add %o0,%l0,%o0 .LL13: st %o0,[%g3+4] ld [%g3+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l1,24,%o0 add %o1,%o0,%o1 st %o1,[%g3+4] mov %g3,%i0 .LL12: ret restore .LLfe1: .size mulsi,.LLfe1-mulsi .align 4 .global expi .type expi,#function .proc 04 expi: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 mov %i0,%o2 ld [%o2+4],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 and %o1,%o0,%i0 cmp %i0,2 be,a .LL15 sethi %hi(-8388608),%i0 call bfffo,0 ld [%o2+8],%o0 add %i0,-2,%i0 sll %i0,5,%i0 sub %i0,%o0,%i0 add %i0,-1,%i0 .LL15: ret restore .LLfe2: .size expi,.LLfe2-expi .align 4 .global addsi .type addsi,#function .proc 0104 addsi: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 orcc %i0,0,%l1 bne,a .LL18 ldsb [%i1+4],%l3 call icopy,0 mov %i1,%o0 b .LL67 mov %o0,%i0 .LL18: cmp %l3,0 bne .LL19 cmp %l1,0 call stoi,0 mov %l1,%o0 b .LL67 mov %o0,%i0 .LL19: bge .LL20 mov 1,%l4 subcc %g0,%l1,%l1 bpos .LL22 mov -1,%l4 sethi %hi(MOST_NEGS),%o0 or %o0,%lo(MOST_NEGS),%o0 call addii,0 mov %i1,%o1 b .LL67 mov %o0,%i0 .LL20: .LL22: ld [%i1+4],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %l4,%l3 bne .LL23 and %o1,%o0,%l0 mov %l1,%o1 sll %l0,2,%l2 add %l2,%i1,%o0 ld [%o0-4],%o0 add %o1,%o0,%o0 cmp %o0,%o1 bgeu .LL24 mov %o0,%l1 call cgeti,0 add %l0,1,%o0 mov %o0,%i0 add %l0,-1,%o2 cmp %o2,2 ble .LL69 st %l1,[%i0+%l2] .LL30: sll %o2,2,%o1 add %o1,%i1,%o0 ld [%o0-4],%o0 cmp %o0,-1 bne .LL69 cmp %o2,2 add %o2,-1,%o2 cmp %o2,2 bg .LL30 st %g0,[%i0+%o1] cmp %o2,2 .LL69: ble .LL31 sll %o2,2,%o1 add %o1,%i1,%o0 ld [%o0-4],%o0 add %o0,1,%o0 b .LL68 st %o0,[%i0+%o1] .LL34: add %o0,%i1,%o1 ld [%o1-4],%o1 st %o1,[%i0+%o0] .LL68: add %o2,-1,%o2 cmp %o2,2 bg .LL34 sll %o2,2,%o0 ld [%i0],%o0 add %o0,-1,%o0 st %o0,[%i0+4] st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(avma),%o1 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 b .LL37 st %o0,[%o1+%lo(avma)] .LL31: mov 1,%o0 st %o0,[%i0+8] ld [%i0],%o0 b .LL37 st %o0,[%i0+4] .LL24: call cgeti,0 mov %l0,%o0 mov %o0,%i0 sll %l0,2,%o0 add %o0,%i0,%o0 st %l1,[%o0-4] mov 1,%o2 add %l0,-1,%o0 cmp %o2,%o0 bge .LL37 mov %o0,%o3 .LL41: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,1,%o2 cmp %o2,%o3 bl .LL41 st %o0,[%i0+%o1] .LL37: ld [%i0+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l4,24,%o0 add %o1,%o0,%o1 b .LL67 st %o1,[%i0+4] .LL23: cmp %l0,3 bne .LL44 sll %l0,2,%l2 ld [%i1+8],%o0 cmp %o0,%l1 bleu .LL45 nop call cgeti,0 mov 3,%o0 mov %o0,%i0 sll %l3,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%i1+8],%o0 sub %o0,%l1,%o0 b .LL67 st %o0,[%i0+8] .LL45: bne .LL46 sethi %hi(gzero),%o0 b .LL67 ld [%o0+%lo(gzero)],%i0 .LL46: call cgeti,0 mov 3,%o0 mov %o0,%i0 sub %g0,%l3,%o0 sll %o0,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%i1+8],%o0 sub %l1,%o0,%o0 b .LL67 st %o0,[%i0+8] .LL44: add %l2,%i1,%o0 ld [%o0-4],%o1 mov %l1,%o0 cmp %o1,%o0 bgeu .LL47 sub %o1,%o0,%l1 call cgeti,0 mov %l0,%o0 mov %o0,%i0 add %l2,%i0,%o0 st %l1,[%o0-4] add %l0,-2,%o2 sll %o2,2,%o0 mov %o0,%o1 ld [%i1+%o0],%o0 cmp %o0,0 bne,a .LL70 sll %o2,2,%o1 mov -1,%o3 st %o3,[%i0+%o1] .LL71: add %o2,-1,%o2 sll %o2,2,%o1 ld [%i1+%o1],%o0 cmp %o0,0 be,a .LL71 st %o3,[%i0+%o1] sll %o2,2,%o1 .LL70: ld [%i1+%o1],%o0 add %o0,-1,%o0 cmp %o2,2 bg .LL54 st %o0,[%i0+%o1] cmp %o0,0 be,a .LL53 ld [%i0],%o0 .LL54: add %o2,-1,%o2 cmp %o2,0 ble .LL67 nop .LL58: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,-1,%o2 cmp %o2,0 bg .LL58 st %o0,[%i0+%o1] b,a .LL67 .LL53: add %o0,-1,%o0 st %o0,[%i0+4] st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(avma),%o1 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(avma)] ld [%i0+4],%o1 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l3,24,%o1 add %o0,%o1,%o0 b .LL67 st %o0,[%i0+4] .LL47: call cgeti,0 mov %l0,%o0 mov %o0,%i0 sll %l0,2,%o0 add %o0,%i0,%o0 st %l1,[%o0-4] mov 1,%o2 add %l0,-1,%o0 cmp %o2,%o0 bge .LL67 mov %o0,%o3 .LL65: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,1,%o2 cmp %o2,%o3 bl .LL65 st %o0,[%i0+%o1] .LL67: ret restore .LLfe3: .size addsi,.LLfe3-addsi .align 4 .global addii .type addii,#function .proc 0104 addii: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 mov %i0,%l0 ld [%l0+4],%o0 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l1 ld [%i1+4],%o0 and %o0,%o1,%l2 cmp %l1,%l2 bge,a .LL236 ldsb [%i1+4],%o5 mov %i1,%l0 mov %i0,%i1 mov %l1,%l3 mov %l2,%l1 mov %l3,%l2 ldsb [%i1+4],%o5 .LL236: cmp %o5,0 bne,a .LL74 ldsb [%l0+4],%l3 call icopy,0 mov %l0,%o0 b .LL201 mov %o0,%i0 .LL74: cmp %l3,%o5 bne .LL75 cmp %l1,%l2 call cgeti,0 add %l1,1,%o0 mov %o0,%i0 mov 0,%o2 sll %l1,2,%o0 add %i0,%o0,%o4 add %o4,4,%o4 add %l0,%o0,%o3 sll %l2,2,%o0 add %i1,%o0,%o1 add %l2,-2,%o5 sethi %hi(.LL113),%o0 or %o0,%lo(.LL113),%g2 add %o5,-1,%o0 .LL237: cmp %o0,15 bgu .LL81 sll %o0,2,%o0 ld [%g2+%o0],%o0 jmp %o0 nop .align 4 .LL113: .word .LL111 .word .LL109 .word .LL107 .word .LL105 .word .LL103 .word .LL101 .word .LL99 .word .LL97 .word .LL95 .word .LL93 .word .LL91 .word .LL89 .word .LL87 .word .LL85 .word .LL83 .word .LL81 .LL81: subcc %g0,%o2,%g0 b .LL82 add %o4,-4,%o4 .LL83: subcc %g0,%o2,%g0 b .LL204 add %o4,-4,%o4 .LL85: subcc %g0,%o2,%g0 b .LL205 add %o4,-4,%o4 .LL87: subcc %g0,%o2,%g0 b .LL206 add %o4,-4,%o4 .LL89: subcc %g0,%o2,%g0 b .LL207 add %o4,-4,%o4 .LL91: subcc %g0,%o2,%g0 b .LL208 add %o4,-4,%o4 .LL93: subcc %g0,%o2,%g0 b .LL209 add %o4,-4,%o4 .LL95: subcc %g0,%o2,%g0 b .LL210 add %o4,-4,%o4 .LL97: subcc %g0,%o2,%g0 b .LL211 add %o4,-4,%o4 .LL99: subcc %g0,%o2,%g0 b .LL212 add %o4,-4,%o4 .LL101: subcc %g0,%o2,%g0 b .LL213 add %o4,-4,%o4 .LL103: subcc %g0,%o2,%g0 b .LL214 add %o4,-4,%o4 .LL105: subcc %g0,%o2,%g0 b .LL215 add %o4,-4,%o4 .LL107: subcc %g0,%o2,%g0 b .LL216 add %o4,-4,%o4 .LL109: subcc %g0,%o2,%g0 b .LL217 add %o4,-4,%o4 .LL111: subcc %g0,%o2,%g0 b .LL218 add %o4,-4,%o4 .LL82: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL204: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL205: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL206: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL207: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL208: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL209: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL210: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL211: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL212: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL213: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL214: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL215: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL216: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL217: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL218: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 addxcc %g3,%l4,%g3 st %g3,[%o4] addx %g0,%g0,%o2 add %o5,-16,%o5 cmp %o5,0 bg .LL237 add %o5,-1,%o0 cmp %o2,0 be .LL115 add %l0,8,%o2 .LL116: add %o3,-4,%o3 cmp %o3,%o2 blu .LL117 mov %o3,%o1 ld [%o3],%o0 cmp %o0,-1 bne .LL118 add %o4,-4,%o4 b .LL116 st %g0,[%o4] .LL118: ld [%o1],%o0 b .LL203 add %o0,1,%o0 .LL122: add %o4,-4,%o4 ld [%o1],%o0 .LL203: st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o2 bgeu .LL122 mov %o3,%o1 b .LL219 ld [%i0],%o0 .LL117: mov 1,%o0 st %o0,[%i0+8] ld [%l0+4],%o0 add %o0,1,%o0 b .LL201 st %o0,[%i0+4] .LL115: subcc %l1,%l2,%o2 be,a .LL219 ld [%i0],%o0 .LL128: add %o4,-4,%o4 add %o3,-4,%o3 ld [%o3],%o0 addcc %o2,-1,%o2 bne .LL128 st %o0,[%o4] ld [%i0],%o0 .LL219: add %o0,-1,%o0 st %o0,[%i0+4] ld [%l0+4],%o0 st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(avma),%o1 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 b .LL201 st %o0,[%o1+%lo(avma)] .LL75: bne .LL131 add %l0,8,%o3 addcc %l1,-2,%o2 be .LL140 add %i1,8,%o1 ld [%o3],%o4 .LL238: add %o3,4,%o3 ld [%o1],%o0 cmp %o0,%o4 bgu .LL202 add %o1,4,%o1 cmp %o4,%o0 bgu .LL131 addcc %o2,-1,%o2 bne,a .LL238 ld [%o3],%o4 .LL140: sethi %hi(gzero),%o0 b .LL201 ld [%o0+%lo(gzero)],%i0 .LL202: mov %l0,%i0 mov %i1,%l0 mov %i0,%i1 mov %o5,%l3 .LL131: call cgeti,0 mov %l1,%o0 mov %o0,%i0 mov 0,%o2 sll %l1,2,%o0 add %l0,%o0,%o3 sll %l2,2,%o1 add %i1,%o1,%o1 add %i0,%o0,%o4 add %l2,-2,%o5 sethi %hi(.LL178),%o0 or %o0,%lo(.LL178),%g2 add %o5,-1,%o0 .LL239: cmp %o0,15 bgu .LL146 sll %o0,2,%o0 ld [%g2+%o0],%o0 jmp %o0 nop .align 4 .LL178: .word .LL176 .word .LL174 .word .LL172 .word .LL170 .word .LL168 .word .LL166 .word .LL164 .word .LL162 .word .LL160 .word .LL158 .word .LL156 .word .LL154 .word .LL152 .word .LL150 .word .LL148 .word .LL146 .LL146: subcc %g0,%o2,%g0 b .LL147 add %o4,-4,%o4 .LL148: subcc %g0,%o2,%g0 b .LL220 add %o4,-4,%o4 .LL150: subcc %g0,%o2,%g0 b .LL221 add %o4,-4,%o4 .LL152: subcc %g0,%o2,%g0 b .LL222 add %o4,-4,%o4 .LL154: subcc %g0,%o2,%g0 b .LL223 add %o4,-4,%o4 .LL156: subcc %g0,%o2,%g0 b .LL224 add %o4,-4,%o4 .LL158: subcc %g0,%o2,%g0 b .LL225 add %o4,-4,%o4 .LL160: subcc %g0,%o2,%g0 b .LL226 add %o4,-4,%o4 .LL162: subcc %g0,%o2,%g0 b .LL227 add %o4,-4,%o4 .LL164: subcc %g0,%o2,%g0 b .LL228 add %o4,-4,%o4 .LL166: subcc %g0,%o2,%g0 b .LL229 add %o4,-4,%o4 .LL168: subcc %g0,%o2,%g0 b .LL230 add %o4,-4,%o4 .LL170: subcc %g0,%o2,%g0 b .LL231 add %o4,-4,%o4 .LL172: subcc %g0,%o2,%g0 b .LL232 add %o4,-4,%o4 .LL174: subcc %g0,%o2,%g0 b .LL233 add %o4,-4,%o4 .LL176: subcc %g0,%o2,%g0 b .LL234 add %o4,-4,%o4 .LL147: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL220: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL221: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL222: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL223: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL224: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL225: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL226: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL227: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL228: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL229: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL230: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL231: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL232: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL233: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] add %o4,-4,%o4 .LL234: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%g3 ld [%o1],%l4 subxcc %g3,%l4,%g3 st %g3,[%o4] addx %g0,%g0,%o2 add %o5,-16,%o5 cmp %o5,0 bg .LL239 add %o5,-1,%o0 cmp %o2,0 be,a .LL180 subcc %l1,%l2,%o5 add %o3,-4,%o3 ld [%o3],%o0 cmp %o0,0 bne .LL240 add %l0,8,%o1 mov -1,%o1 add %o4,-4,%o4 .LL241: st %o1,[%o4] add %o3,-4,%o3 ld [%o3],%o0 cmp %o0,0 be,a .LL241 add %o4,-4,%o4 add %l0,8,%o1 .LL240: cmp %o3,%o1 blu .LL190 add %o0,-1,%o0 add %o4,-4,%o4 st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o1 blu .LL190 mov %o3,%o0 .LL188: add %o4,-4,%o4 ld [%o0],%o0 st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o1 bgeu .LL188 mov %o3,%o0 b .LL235 ld [%i0+8],%o0 .LL180: be,a .LL235 ld [%i0+8],%o0 .LL193: add %o4,-4,%o4 add %o3,-4,%o3 ld [%o3],%o0 addcc %o5,-1,%o5 bne .LL193 st %o0,[%o4] .LL190: ld [%i0+8],%o0 .LL235: cmp %o0,0 be,a .LL195 ld [%i0+12],%o0 ld [%l0+4],%o0 b .LL201 st %o0,[%i0+4] .LL195: cmp %o0,0 bne .LL198 add %i0,12,%o4 add %o4,4,%o4 .LL242: ld [%o4],%o0 cmp %o0,0 be,a .LL242 add %o4,4,%o4 .LL198: add %o4,-8,%o4 sub %o4,%i0,%o5 sra %o5,2,%o5 ld [%i0],%o1 sub %o1,%o5,%o1 st %o1,[%o4] st %o1,[%o4+4] mov %o4,%i0 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l3,24,%o1 add %o0,%o1,%o0 st %o0,[%i0+4] sethi %hi(avma),%o2 sll %o5,2,%o0 ld [%o2+%lo(avma)],%o1 add %o0,%o1,%o0 st %o0,[%o2+%lo(avma)] .LL201: ret restore .LLfe4: .size addii,.LLfe4-addii .align 4 .global mulss .type mulss,#function .proc 0104 mulss: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 orcc %i0,0,%o0 be .LL245 cmp %i1,0 bne .LL244 cmp %o0,0 .LL245: sethi %hi(gzero),%o0 b .LL253 ld [%o0+%lo(gzero)],%i0 .LL244: bge .LL246 mov 1,%l0 subcc %g0,%o0,%o0 bpos .LL246 mov -1,%l0 call stoi,0 nop mov %o0,%o1 b .LL254 mov %i1,%o0 .LL246: cmp %i1,0 bge .LL255 mov %o0,%l1 subcc %g0,%i1,%i1 bpos .LL255 sub %g0,%l0,%l0 cmp %l0,0 bg .LL250 mov %o0,%o1 sub %g0,%o0,%o1 .LL250: mov %o1,%o0 sethi %hi(ABS_MOST_NEGS),%o1 or %o1,%lo(ABS_MOST_NEGS),%o1 .LL254: call mulsi,0 nop b .LL253 mov %o0,%i0 .LL255: or %l1,%i1,%o4 mov %l1,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 tst %i1 bl,a 1f add %o4,%l1,%o4 1: mov %o4,%o2 b 3f rd %y,%l1 2: clr %o2 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%l1 3: orcc %o2,0,%i1 be .LL251 nop call cgeti,0 mov 4,%o0 mov %o0,%i0 st %i1,[%i0+8] b .LL252 st %l1,[%i0+12] .LL251: call cgeti,0 mov 3,%o0 mov %o0,%i0 st %l1,[%i0+8] .LL252: ld [%i0],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l0,24,%o0 add %o1,%o0,%o1 st %o1,[%i0+4] .LL253: ret restore .LLfe5: .size mulss,.LLfe5-mulss .align 4 .global mulii .type mulii,#function .proc 0104 mulii: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 mov %i0,%l4 ld [%l4+4],%o0 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l0 ld [%i1+4],%o2 sra %o0,24,%l3 cmp %l3,0 be .LL276 and %o2,%o1,%l2 ldsb [%i1+4],%o0 cmp %o0,0 bne .LL258 nop .LL276: sethi %hi(gzero),%o0 b .LL275 ld [%o0+%lo(gzero)],%i0 .LL258: bl,a .LL259 sub %g0,%l3,%l3 .LL259: cmp %l0,%l2 ble .LL260 mov %l4,%i0 mov %i1,%l4 mov %i0,%i1 mov %l0,%l1 mov %l2,%l0 mov %l1,%l2 .LL260: add %l0,%l2,%l1 add %l1,-2,%l1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %l1,%o0 ble .LL261 nop call err,0 mov 17,%o0 .LL261: call cgeti,0 mov %l1,%o0 mov %o0,%i0 ld [%i0],%o1 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l3,24,%o1 add %o0,%o1,%o0 st %o0,[%i0+4] sll %l0,2,%o0 add %l4,%o0,%g4 add %g4,-4,%g4 ld [%g4],%g2 mov 0,%o2 sll %l2,2,%o0 add %i1,%o0,%g3 sll %l1,2,%o0 addcc %l2,-2,%o3 be .LL263 add %i0,%o0,%g1 .LL264: add %g1,-4,%g1 mov %o2,%o1 add %g3,-4,%g3 mov %g2,%o0 ld [%g3],%l5 or %o0,%l5,%o4 mov %o0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%g0,%o4 tst %l5 bl,a 1f add %o4,%o0,%o4 1: mov %o4,%o2 b 3f rd %y,%o0 2: clr %o2 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%l5,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o0 3: addcc %o1,%o0,%l5 addx %o2,%g0,%o2 addcc %o3,-1,%o3 bne .LL264 st %l5,[%g1] .LL263: st %o2,[%g1-4] sll %l1,2,%o0 add %i0,%o0,%g1 sll %l2,2,%o0 add %i1,%o0,%i1 add %l0,-3,%l0 cmp %l0,0 ble .LL267 add %l2,-1,%l2 .LL268: add %g4,-4,%g4 ld [%g4],%o7 mov %i1,%g3 add %g1,-4,%o1 mov %o1,%g1 addcc %l2,-1,%o3 be .LL270 mov 0,%g2 .LL271: add %g3,-4,%g3 ld [%g3],%o0 or %o0,%o7,%o4 mov %o0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 tst %o7 bl,a 1f add %o4,%o0,%o4 1: mov %o4,%o2 b 3f rd %y,%o0 2: clr %o2 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o0 3: add %o1,-4,%o1 ld [%o1],%l5 addcc %o0,%l5,%o0 addx %o2,%g0,%o2 addcc %o0,%g2,%l5 addx %o2,%g0,%o2 st %l5,[%o1] addcc %o3,-1,%o3 bne .LL271 mov %o2,%g2 .LL270: add %l0,-1,%l0 cmp %l0,0 bg .LL268 st %o2,[%o1-4] .LL267: ld [%i0+8],%o0 cmp %o0,0 bne .LL275 sethi %hi(avma),%o1 ld [%i0+4],%o0 add %o0,-1,%o0 st %o0,[%i0+8] ld [%i0],%o0 add %o0,-1,%o0 st %o0,[%i0+4] add %i0,4,%i0 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(avma)] .LL275: ret restore .LLfe6: .size mulii,.LLfe6-mulii .global .div .section ".rodata" .align 8 .LLC0: .uaword 0x3fd34413 ! ~3.01030000000000019789e-1 .uaword 0x55475a32 .align 8 .LLC1: .uaword 0x3ff00000 ! ~1.00000000000000000000e0 .uaword 0x0 .section ".text" .align 4 .global confrac .type confrac,#function .proc 0104 confrac: !#PROLOGUE# 0 save %sp,-120,%sp !#PROLOGUE# 1 ld [%i0],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 and %o1,%o0,%l2 ld [%i0+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sethi %hi(8388607),%o0 or %o0,%lo(8388607),%o0 sub %o0,%o1,%l0 sethi %hi(avma),%o0 ld [%o0+%lo(avma)],%l5 add %l2,-2,%l4 sll %l4,5,%l4 add %l4,%l0,%l4 add %l4,63,%l3 sra %l3,5,%l3 call cgeti,0 mov %l3,%o0 sra %l0,5,%o1 mov 0,%g2 cmp %g2,%o1 bge .LL279 mov %o0,%l1 .LL281: sll %g2,2,%o0 add %g2,1,%g2 cmp %g2,%o1 bl .LL281 st %g0,[%l1+%o0] .LL279: andcc %l0,31,%l0 bne .LL283 mov 2,%g3 cmp %g3,%l2 bge .LL305 sll %l3,2,%o0 .LL287: sll %g2,2,%o0 sll %g3,2,%o1 ld [%i0+%o1],%o1 st %o1,[%l1+%o0] add %g3,1,%g3 cmp %g3,%l2 bl .LL287 add %g2,1,%g2 b .LL305 sll %l3,2,%o0 .LL283: cmp %g3,%l2 bge .LL291 mov 0,%o3 mov 32,%o0 sub %o0,%l0,%o4 .LL293: sll %g2,2,%o1 sll %g3,2,%o0 ld [%i0+%o0],%o2 add %g2,1,%g2 srl %o2,%l0,%o0 add %o0,%o3,%o0 st %o0,[%l1+%o1] add %g3,1,%g3 cmp %g3,%l2 bl .LL293 sll %o2,%o4,%o3 .LL291: sll %l3,2,%o0 add %o0,%l1,%o0 st %o3,[%o0-8] sll %l3,2,%o0 .LL305: add %o0,%l1,%o0 st %g0,[%o0-4] st %l4,[%fp-20] ld [%fp-20],%f6 fitod %f6,%f2 sethi %hi(.LLC0),%l6 ldd [%l6+%lo(.LLC0)],%f4 fmuld %f2,%f4,%f2 sethi %hi(.LLC1),%l6 ldd [%l6+%lo(.LLC1)],%f4 faddd %f2,%f4,%f2 fdtoi %f2,%f2 st %f2,[%fp-20] ld [%fp-20],%l0 add %l0,17,%l2 mov %l2,%o0 call .div,0 mov 9,%o1 call cgeti,0 mov %o0,%l2 mov %o0,%i0 mov 1,%g3 cmp %g3,%l2 bge .LL296 st %l0,[%i0] .LL298: addcc %l3,-1,%g2 bneg .LL300 mov 0,%o3 sethi %hi(1000000000),%o0 or %o0,%lo(1000000000),%o7 .LL302: sll %g2,2,%o1 mov %o3,%o2 ld [%l1+%o1],%o0 or %o0,%o7,%o4 mov %o0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 tst %o7 bl,a 1f add %o4,%o0,%o4 1: mov %o4,%o3 b 3f rd %y,%o0 2: clr %o3 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o0 3: addcc %o2,%o0,%l6 addx %o3,%g0,%o3 addcc %g2,-1,%g2 bpos .LL302 st %l6,[%l1+%o1] .LL300: sll %g3,2,%o0 add %g3,1,%g3 cmp %g3,%l2 bl .LL298 st %o3,[%i0+%o0] .LL296: sethi %hi(avma),%o0 st %l5,[%o0+%lo(avma)] ret restore .LLfe7: .size confrac,.LLfe7-confrac .align 4 .global divss .type divss,#function .proc 0104 divss: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 cmp %i1,0 bne .LL315 sethi %hi(-2147483648),%o0 call err,0 mov 23,%o0 sethi %hi(-2147483648),%o0 .LL315: cmp %i0,%o0 bne .LL308 sethi %hi(hiremainder),%o0 call stoi,0 mov %i0,%o0 call divis,0 mov %i1,%o1 b,a .LL314 .LL308: st %g0,[%o0+%lo(hiremainder)] cmp %i0,0 bge .LL309 mov %i0,%o0 sub %g0,%i0,%o0 .LL309: cmp %i1,0 bge .LL310 mov %i1,%o1 sub %g0,%i1,%o1 .LL310: sethi %hi(hiremainder),%l0 call divul3,0 or %l0,%lo(hiremainder),%o2 cmp %i1,0 bge .LL311 mov %o0,%o1 ld [%l0+%lo(hiremainder)],%o0 sub %g0,%o0,%o0 st %o0,[%l0+%lo(hiremainder)] sub %g0,%o1,%o1 .LL311: cmp %i0,0 bl,a .LL312 sub %g0,%o1,%o1 .LL312: call stoi,0 mov %o1,%o0 .LL314: ret restore %g0,%o0,%o0 .LLfe8: .size divss,.LLfe8-divss .align 4 .global modss .type modss,#function .proc 0104 modss: !#PROLOGUE# 0 save %sp,-120,%sp !#PROLOGUE# 1 cmp %i1,0 bne .LL326 sethi %hi(-2147483648),%o0 call err,0 mov 38,%o0 sethi %hi(-2147483648),%o0 .LL326: cmp %i0,%o0 bne .LL318 mov %i0,%o0 call stoi,0 mov %i0,%o0 call modis,0 mov %i1,%o1 b .LL323 mov %o0,%i0 .LL318: cmp %o0,0 bge .LL319 st %g0,[%fp-20] sub %g0,%o0,%o0 .LL319: cmp %i1,0 bl,a .LL320 sub %g0,%i1,%i1 .LL320: mov %i1,%o1 call divul3,0 add %fp,-20,%o2 ld [%fp-20],%o0 cmp %o0,0 bne .LL321 nop sethi %hi(gzero),%o0 b .LL323 ld [%o0+%lo(gzero)],%i0 .LL321: bge .LL325 nop ld [%fp-20],%o0 sub %i1,%o0,%o0 .LL325: call stoi,0 nop mov %o0,%i0 .LL323: ret restore .LLfe9: .size modss,.LLfe9-modss .align 4 .global resss .type resss,#function .proc 0104 resss: !#PROLOGUE# 0 save %sp,-120,%sp !#PROLOGUE# 1 cmp %i1,0 bne .LL334 mov %i0,%o0 call err,0 mov 40,%o0 mov %i0,%o0 .LL334: cmp %o0,0 bge .LL329 st %g0,[%fp-20] sub %g0,%o0,%o0 .LL329: cmp %i1,0 bge .LL330 mov %i1,%o1 sub %g0,%i1,%o1 .LL330: call divul3,0 add %fp,-20,%o2 cmp %i1,0 bge .LL333 ld [%fp-20],%o0 sub %g0,%o0,%o0 .LL333: call stoi,0 nop ret restore %g0,%o0,%o0 .LLfe10: .size resss,.LLfe10-resss .align 4 .global divsi .type divsi,#function .proc 0104 divsi: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 ld [%i1+4],%o0 sra %o0,24,%o2 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 cmp %o2,0 bne .LL336 and %o0,%o1,%l0 call err,0 mov 24,%o0 .LL336: cmp %i0,0 be .LL338 cmp %l0,3 bg .LL345 sethi %hi(hiremainder),%o0 ld [%i1+8],%o0 cmp %o0,0 bge .LL337 sethi %hi(-2147483648),%o0 .LL338: sethi %hi(hiremainder),%o0 .LL345: st %i0,[%o0+%lo(hiremainder)] sethi %hi(gzero),%o0 b .LL343 ld [%o0+%lo(gzero)],%i0 .LL337: cmp %i0,%o0 bne .LL339 sethi %hi(hiremainder),%o0 call stoi,0 mov %i0,%o0 mov %i1,%o1 call dvmdii,0 mov 0,%o2 b .LL343 mov %o0,%i0 .LL339: st %g0,[%o0+%lo(hiremainder)] cmp %i0,0 bge .LL340 mov %i0,%o0 sub %g0,%i0,%o0 .LL340: ld [%i1+8],%o1 sethi %hi(hiremainder),%l0 call divul3,0 or %l0,%lo(hiremainder),%o2 mov %o0,%o1 ldsb [%i1+4],%o0 cmp %o0,0 bge .LL346 cmp %i0,0 ld [%l0+%lo(hiremainder)],%o0 sub %g0,%o0,%o0 st %o0,[%l0+%lo(hiremainder)] sub %g0,%o1,%o1 .LL346: bl,a .LL342 sub %g0,%o1,%o1 .LL342: call stoi,0 mov %o1,%o0 mov %o0,%i0 .LL343: ret restore .LLfe11: .size divsi,.LLfe11-divsi .align 4 .global divis .type divis,#function .proc 0104 divis: !#PROLOGUE# 0 save %sp,-120,%sp !#PROLOGUE# 1 mov %i0,%l3 ld [%l3+4],%o1 sra %o1,24,%l4 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %i1,0 bne .LL348 and %o1,%o0,%l2 call err,0 mov 26,%o0 .LL348: cmp %l4,0 bne .LL349 cmp %i1,0 sethi %hi(hiremainder),%o0 b .LL364 st %g0,[%o0+%lo(hiremainder)] .LL349: bge,a .LL365 ld [%l3+8],%o0 subcc %g0,%i1,%i1 bpos .LL350 sub %g0,%l4,%l4 call stoi,0 mov %i1,%o0 mov %o0,%o1 mov %l3,%o0 call dvmdii,0 mov 0,%o2 b .LL363 mov %o0,%i0 .LL350: ld [%l3+8],%o0 .LL365: cmp %i1,%o0 bleu .LL352 cmp %l2,3 bne .LL353 sethi %hi(hiremainder),%l0 call itos,0 mov %l3,%o0 st %o0,[%l0+%lo(hiremainder)] .LL364: sethi %hi(gzero),%o0 b .LL363 ld [%o0+%lo(gzero)],%i0 .LL353: call cgeti,0 add %l2,-1,%o0 mov %o0,%i0 mov 1,%l1 ld [%l3+8],%o0 b .LL355 st %o0,[%fp-20] .LL352: call cgeti,0 mov %l2,%o0 mov %o0,%i0 mov 0,%l1 st %l1,[%fp-20] .LL355: add %l1,2,%l0 cmp %l0,%l2 bge,a .LL366 ld [%i0],%o0 .LL359: sll %l0,2,%o0 ld [%l3+%o0],%o0 mov %i1,%o1 call divul3,0 add %fp,-20,%o2 sub %l0,%l1,%o1 sll %o1,2,%o1 add %l0,1,%l0 cmp %l0,%l2 bl .LL359 st %o0,[%i0+%o1] ld [%i0],%o0 .LL366: sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l4,24,%o0 add %o1,%o0,%o1 st %o1,[%i0+4] sethi %hi(hiremainder),%o1 cmp %l4,0 bge .LL361 or %o1,%lo(hiremainder),%o2 ld [%fp-20],%o0 sub %g0,%o0,%o0 b .LL363 st %o0,[%o1+%lo(hiremainder)] .LL361: ld [%fp-20],%o0 st %o0,[%o2] .LL363: ret restore .LLfe12: .size divis,.LLfe12-divis .align 4 .global dvmdii .type dvmdii,#function .proc 0104 dvmdii: !#PROLOGUE# 0 save %sp,-136,%sp !#PROLOGUE# 1 mov %i0,%l2 mov %i2,%i5 ldsb [%l2+4],%g1 st %g1,[%fp-28] ldsb [%i1+4],%g4 cmp %g4,0 bne .LL368 st %g4,[%fp-32] call err,0 mov 36,%o0 .LL368: ld [%fp-28],%g1 cmp %g1,0 bne,a .LL369 ld [%l2+4],%o0 cmp %i5,-1 be .LL470 cmp %i5,0 be .LL470 sethi %hi(gzero),%o1 ld [%o1+%lo(gzero)],%o0 st %o0,[%i5] b .LL469 ld [%o1+%lo(gzero)],%i0 .LL369: sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l5 ld [%i1+4],%o0 and %o0,%o1,%i3 subcc %l5,%i3,%i4 bpos .LL372 sethi %hi(avma),%o0 cmp %i5,-1 bne .LL373 cmp %i5,0 call icopy,0 mov %l2,%o0 b .LL469 mov %o0,%i0 .LL373: be .LL478 sethi %hi(gzero),%o0 call icopy,0 mov %l2,%o0 b .LL470 st %o0,[%i5] .LL372: ld [%o0+%lo(avma)],%o0 st %o0,[%fp-24] ld [%fp-28],%g4 cmp %g4,0 bge .LL479 cmp %i3,3 ld [%fp-32],%g1 sub %g0,%g1,%g1 st %g1,[%fp-32] .LL479: bne .LL376 nop ld [%i1+8],%i1 ld [%l2+8],%o0 cmp %i1,%o0 bleu .LL377 add %l2,8,%l1 add %l5,-1,%l0 st %o0,[%fp-20] b .LL378 add %l2,12,%l1 .LL377: mov %l5,%l0 st %g0,[%fp-20] .LL378: call cgeti,0 mov %l0,%o0 mov %o0,%l4 addcc %l0,-2,%l3 be .LL380 add %l4,8,%l2 .LL381: ld [%l1],%o0 add %l1,4,%l1 mov %i1,%o1 call divul3,0 add %fp,-20,%o2 st %o0,[%l2] addcc %l3,-1,%l3 bne .LL381 add %l2,4,%l2 .LL380: cmp %i5,-1 bne .LL383 cmp %l0,2 sethi %hi(avma),%o0 ld [%fp-24],%g4 st %g4,[%o0+%lo(avma)] ld [%fp-20],%o0 cmp %o0,0 bne .LL384 nop .LL470: sethi %hi(gzero),%o0 .LL478: b .LL469 ld [%o0+%lo(gzero)],%i0 .LL384: call cgeti,0 mov 3,%o0 mov %o0,%i0 ld [%fp-28],%g1 sll %g1,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%fp-20],%o0 b .LL469 st %o0,[%i0+8] .LL383: be .LL385 sethi %hi(-16777216),%o1 ld [%l4],%o0 andn %o0,%o1,%o1 ld [%fp-32],%g4 sll %g4,24,%o0 add %o1,%o0,%o1 b .LL386 st %o1,[%l4+4] .LL385: sethi %hi(avma),%o0 ld [%fp-24],%g1 st %g1,[%o0+%lo(avma)] sethi %hi(gzero),%o0 ld [%o0+%lo(gzero)],%l4 .LL386: cmp %i5,0 bne .LL387 ld [%fp-20],%o0 .LL472: b .LL469 mov %l4,%i0 .LL387: cmp %o0,0 bne .LL388 sethi %hi(gzero),%o0 ld [%o0+%lo(gzero)],%o0 b .LL472 st %o0,[%i5] .LL388: call cgeti,0 mov 3,%o0 mov %o0,%i0 ld [%fp-28],%g4 sll %g4,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%fp-20],%o0 st %o0,[%i0+8] b .LL472 st %i0,[%i5] .LL376: call cgeti,0 mov %l5,%o0 mov %o0,%l4 call bfffo,0 ld [%i1+8],%o0 orcc %o0,0,%l7 be .LL391 add %l2,8,%l1 call cgeti,0 mov %i3,%o0 mov %o0,%i0 ld [%i1+8],%o2 add %i1,12,%o1 mov 32,%o0 sub %o0,%l7,%o0 srl %o2,%o0,%o0 st %o0,[%fp-20] sll %o2,%l7,%g2 addcc %i3,-3,%l3 be .LL393 add %i0,8,%o3 mov 32,%o0 sub %o0,%l7,%o4 .LL394: ld [%o1],%o2 add %o1,4,%o1 srl %o2,%o4,%o0 st %o0,[%fp-20] add %g2,%o0,%o0 st %o0,[%o3] add %o3,4,%o3 addcc %l3,-1,%l3 bne .LL394 sll %o2,%l7,%g2 .LL393: st %g2,[%o3] mov 0,%g2 add %l2,8,%l1 addcc %l5,-2,%l3 be .LL397 add %l4,4,%l2 mov 32,%o0 sub %o0,%l7,%o1 .LL398: ld [%l1],%o2 add %l1,4,%l1 srl %o2,%o1,%o0 st %o0,[%fp-20] add %g2,%o0,%o0 st %o0,[%l2] add %l2,4,%l2 addcc %l3,-1,%l3 bne .LL398 sll %o2,%l7,%g2 .LL397: b .LL400 st %g2,[%l2] .LL391: st %g0,[%l4+4] addcc %l5,-2,%l0 be .LL402 add %l4,8,%l2 .LL403: ld [%l1],%o0 st %o0,[%l2] add %l1,4,%l1 addcc %l0,-1,%l0 bne .LL403 add %l2,4,%l2 .LL402: mov %i1,%i0 .LL400: ld [%i0+8],%i1 ld [%i0+12],%i2 addcc %i4,1,%l3 be .LL406 add %l4,4,%l2 sll %i3,2,%l1 .LL407: ld [%l2],%o0 cmp %o0,%i1 bne .LL408 add %l2,4,%l2 mov -1,%o7 mov %i1,%o2 ld [%l2],%o0 add %o2,%o0,%o1 cmp %o1,%o2 addx %g0,0,%o3 b .LL409 mov %o1,%g2 .LL408: ld [%l2-4],%o0 st %o0,[%fp-20] ld [%l2],%o0 mov %i1,%o1 call divul3,0 add %fp,-20,%o2 mov %o0,%o7 mov 0,%o3 ld [%fp-20],%g2 .LL409: cmp %o3,0 bne,a .LL480 st %g0,[%fp-20] mov %o7,%o2 or %o2,%i2,%o4 mov %o2,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%g0,%o4 tst %i2 bl,a 1f add %o4,%o2,%o4 1: mov %o4,%g1 b 3f rd %y,%o2 2: clr %g1 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%i2,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o2 3: st %g1,[%fp-20] ld [%l2+4],%o0 cmp %o2,%o0 addx %g0,0,%o3 sub %o2,%o0,%o4 mov %g1,%o2 mov %g2,%o0 sub %o2,%g2,%o1 cmp %g2,%o2 bgu .LL475 sub %o1,%o3,%o1 b .LL476 cmp %o0,%o2 .LL423: be .LL410 mov %o4,%o2 add %o7,-1,%o7 mov %i2,%o0 cmp %o2,%o0 addx %g0,0,%o3 sub %o2,%o0,%o4 mov %o1,%o2 mov %i1,%o0 sub %o2,%o0,%o1 cmp %o0,%o2 bleu .LL476 sub %o1,%o3,%o1 .LL475: b .LL420 mov 1,%o3 .LL476: blu,a .LL420 mov 0,%o3 .LL420: cmp %o3,0 be .LL423 cmp %o1,0 .LL410: st %g0,[%fp-20] .LL480: add %l2,%l1,%g2 add %g2,-8,%g2 addcc %i3,-2,%l0 be .LL425 add %i0,%l1,%g3 .LL426: ld [%fp-20],%o2 add %g3,-4,%g3 mov %o7,%o1 ld [%g3],%g1 or %o1,%g1,%o4 mov %o1,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g0,%o4 tst %g1 bl,a 1f add %o4,%o1,%o4 1: mov %o4,%g4 b 3f rd %y,%o1 2: clr %g4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o1 3: st %g4,[%fp-20] addcc %o2,%o1,%o3 addx %g4,%g0,%g4 st %g4,[%fp-20] add %g2,-4,%g2 ld [%g2],%o2 sub %o2,%o3,%o1 cmp %o2,%o3 st %o1,[%g2] ld [%fp-20],%o0 addx %g0,%o0,%o0 addcc %l0,-1,%l0 bne .LL426 st %o0,[%fp-20] .LL425: ld [%l2-4],%o1 ld [%fp-20],%o0 cmp %o1,%o0 bgeu,a .LL481 addcc %l3,-1,%l3 mov 0,%o3 add %o7,-1,%o7 add %l2,%l1,%g2 add %g2,-8,%g2 addcc %i3,-2,%l0 be .LL428 add %i0,%l1,%g3 add %g2,-4,%g2 .LL482: subcc %g0,%o3,%g0 add %g3,-4,%g3 ld [%g2],%g1 ld [%g3],%g4 addxcc %g1,%g4,%g1 st %g1,[%g2] addx %g0,%g0,%o3 addcc %l0,-1,%l0 bne,a .LL482 add %g2,-4,%g2 .LL428: addcc %l3,-1,%l3 .LL481: bne .LL407 st %o7,[%l2-4] .LL406: sethi %hi(avma),%o0 cmp %i5,-1 be .LL434 ld [%o0+%lo(avma)],%i0 add %i4,2,%l1 sll %l1,2,%o0 add %l4,%o0,%l2 ld [%l4+4],%o0 cmp %o0,0 be .LL435 cmp %i4,0 b .LL436 add %i4,3,%l1 .LL435: be,a .LL436 st %g0,[%fp-32] .LL436: call cgeti,0 mov %l1,%o0 st %o0,[%fp-36] sll %l1,2,%o0 ld [%fp-36],%g1 addcc %l1,-2,%l0 be .LL439 add %g1,%o0,%o1 .LL440: add %o1,-4,%o1 add %l2,-4,%l2 ld [%l2],%o0 addcc %l0,-1,%l0 bne .LL440 st %o0,[%o1] .LL439: cmp %l1,2 bgu .LL442 mov 2,%o0 ld [%fp-36],%g4 b .LL434 st %o0,[%g4+4] .LL442: ld [%fp-36],%g1 ld [%g1],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 ld [%fp-32],%g4 sll %g4,24,%o0 add %o1,%o0,%o1 st %o1,[%g1+4] .LL434: cmp %i5,0 be .LL483 cmp %i5,-1 add %i4,2,%l0 cmp %l0,%l5 bge .LL484 sll %l0,2,%o0 ld [%l4+%o0],%o0 cmp %o0,0 bne .LL484 cmp %l0,%l5 add %i4,3,%l0 .LL447: cmp %l0,%l5 bge .LL484 sll %l0,2,%o0 ld [%l4+%o0],%o0 cmp %o0,0 be,a .LL447 add %l0,1,%l0 cmp %l0,%l5 .LL484: bne .LL451 sub %l5,%l0,%o0 sethi %hi(gzero),%o0 call icopy,0 ld [%o0+%lo(gzero)],%o0 b .LL444 mov %o0,%l6 .LL451: call cgeti,0 add %o0,2,%o0 mov %o0,%l6 ld [%l6],%o0 cmp %l7,0 bne .LL453 st %o0,[%l6+4] cmp %l0,%l5 bge .LL459 mov 2,%l3 .LL457: sll %l3,2,%o0 sll %l0,2,%o1 ld [%l4+%o1],%o1 st %o1,[%l6+%o0] add %l0,1,%l0 cmp %l0,%l5 bl .LL457 add %l3,1,%l3 b .LL477 ld [%l6+4],%o0 .LL453: st %g0,[%fp-20] sll %l0,2,%o0 ld [%l4+%o0],%o2 add %l0,1,%l0 mov 32,%o0 sub %o0,%l7,%o0 sll %o2,%o0,%o0 st %o0,[%fp-20] srl %o2,%l7,%o3 cmp %o3,0 be .LL460 mov %o0,%g2 st %o3,[%l6+8] b .LL461 mov 1,%o0 .LL460: ld [%l6],%o0 add %o0,-1,%o0 st %o0,[%l6+4] add %l6,4,%l6 sethi %hi(avma),%o1 ld [%o1+%lo(avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(avma)] ld [%l6],%o0 st %o0,[%l6+4] mov 0,%o0 .LL461: cmp %l0,%l5 bge .LL459 add %o0,2,%l3 mov 32,%o0 sub %o0,%l7,%o3 .LL465: sll %l3,2,%o1 sll %l0,2,%o0 ld [%l4+%o0],%o2 sll %o2,%o3,%o0 st %o0,[%fp-20] srl %o2,%l7,%o0 add %o0,%g2,%o0 st %o0,[%l6+%o1] ld [%fp-20],%g2 add %l0,1,%l0 cmp %l0,%l5 bl .LL465 add %l3,1,%l3 .LL459: ld [%l6+4],%o0 .LL477: sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 ld [%fp-28],%g1 sll %g1,24,%o0 add %o1,%o0,%o1 st %o1,[%l6+4] .LL444: cmp %i5,-1 .LL483: bne .LL467 cmp %i5,0 ld [%fp-24],%o0 mov %i0,%o1 b .LL474 mov %l6,%o2 .LL467: be .LL468 ld [%fp-24],%o0 mov %i0,%o1 call gerepile,0 mov 0,%o2 and %o0,-4,%o0 add %l6,%o0,%o1 st %o1,[%i5] ld [%fp-36],%g4 b .LL469 add %g4,%o0,%i0 .LL468: mov %i0,%o1 ld [%fp-36],%o2 .LL474: call gerepile,0 nop mov %o0,%i0 .LL469: ret restore .LLfe13: .size dvmdii,.LLfe13-dvmdii .align 4 .global mulul3 .type mulul3,#function .proc 016 mulul3: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 or %i0,%i1,%o4 mov %i0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 tst %i1 bl,a 1f add %o4,%i0,%o4 1: mov %o4,%g2 b 3f rd %y,%i0 2: clr %g2 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%i0 3: st %g2,[%i2] ret restore .LLfe14: .size mulul3,.LLfe14-mulul3 .ident "GCC: (GNU) 2.8.1" gcl-2.6.14/mp/mp_mulul3.c0000755000175000017500000000326614360276512013502 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" #include "arith.h" /* ulong a,b,y; (y = mulul3(a,b,&hiremainder), hiremainder:y == a*b) is TRUE. */ #ifdef USE_WORD_MULUL3 int mulul3(x,y,hiremainder) ulong x,y,*hiremainder; { ulong xlo,xhi,ylo,yhi; ulong z; TEMPVARS xlo=x&65535;xhi=x>>16;ylo=y&65535;yhi=y>>16; z=addll(xlo*yhi,xhi*ylo); *hiremainder=(overflow)?xhi*yhi+65536+(z>>16):xhi*yhi+(z>>16); z=addll(xlo*ylo,(z<<16));*hiremainder+=overflow; return z; } #else ulong mulul3(a,b,h) unsigned int a,b, *h; {unsigned int temph,templ,ah,al,i; ah=0; al=0; /* in case the shift by 32 does not zero an unsigned int.. we separate out the first step.*/ {if (b & 1) {temph=0;templ=a; lladd(temph,templ,ah,al);} /* printf("\n%d b=%d a=%d (%d:%d)",i,b,a,ah,al); */ b=b>>1; } i=1; while(b) {if (b & 1) {llshift(a,i,temph,templ); lladd(temph,templ,ah,al);} i++;b=b>>1; } *h=ah; return al; } #endif gcl-2.6.14/mp/lo-sgi4d.s0000755000175000017500000000137114360276512013222 0ustar cammcamm # Copyright W. Schelter 1991 #ifdef sgi #include #else #include #endif .text .align 2 .globl mulul3 # MULUL3(x,y,hi) .ent mulul3 mulul3: .frame sp, 0, ra multu a0, a1 # [hi:lo] = d * q mfhi a1 mflo v0 sw a1,0(a2) j ra .end mulul3 .globl Xdivul3 # EXTENDED_DIV(D,H,L,QP,RP) # divul3(x, y, hi) # unsigned int x,h,*hi; #define lo a0 #define q t7 #define y a1 #define h v1 .ent Xdivul3 Xdivul3: .frame sp, 0, ra lw h, 0(a2) li v0, 32 # v0 holds number of shifts loop: srl q, lo, 31 sll h, 1 or h, q sll lo, 1 subu q, h, y # t = h - d bltz q, underflow move h, q or lo, 1 underflow: subu v0, 1 bnez v0, loop move q,a0 sw h, 0(a2) # *rp = h # } j ra .end Xdivul3 gcl-2.6.14/mp/mp_addmul.c0000755000175000017500000000226514360276512013525 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" #include "arith.h" /* (h = hiremainder, y = addmul(a,b), hiremainder:y == a*b + h) is true */ int addmul(x,y) ulong x,y; { ulong xlo,xhi,ylo,yhi; ulong z,z2; TEMPVARS xlo=x&65535;xhi=x>>16;ylo=y&65535;yhi=y>>16; z=addll(xlo*yhi,xhi*ylo); z2=(overflow)?xhi*yhi+65536+(z>>16):xhi*yhi+(z>>16); z=addll(xlo*ylo,(z<<16));z2+=overflow; z=addll(z,hiremainder);hiremainder=z2+overflow; return z; } gcl-2.6.14/mp/fplus.c0000755000175000017500000000462414360276512012715 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* #include "include.h" */ #include "config.h" /* #include "cmpinclude.h" */ /* #include "genpari.h" */ #include "arith.h" object make_integer(); static unsigned plong small_pos_int[3]={0x1000003,0x01000003,0}; static unsigned plong small_neg_int[3]={0x1000003,0xff000003,0}; static unsigned plong s4_neg_int[4]={0x1000004,0xff000004,1,0}; object fplus(a,b) int a,b; { int z ; int x; if (a >= 0) { if (b >= 0) { x = a + b; if (x == 0) return small_fixnum(0); small_pos_int[2]=x; return make_integer(small_pos_int); } else { /* b neg */ x = a + b; return make_fixnum(x); }} else { /* a neg */ if (b >= 0) { x = a + b; return make_fixnum(x);} else { /* both neg */ { unsigned plong Xtx,Xty,overflow,Xtres; Xtres = addll(-a,-b); if (overflow) { s4_neg_int[3]=Xtres; return make_integer(s4_neg_int);} else { small_neg_int[2]=Xtres; return make_integer(small_neg_int);} }}} } object fminus(a,b) int a,b; { int z ; int x; if (a >= 0) { if (b >= 0) { x = a - b; return make_fixnum(x); } else { /* b neg */ x = a - b; if (x==0) return small_fixnum(0); small_pos_int[2]=x; return make_integer(small_pos_int); }} else { /* a neg */ if (b <= 0) { x = a - b; return make_fixnum(x);} else { /* b positive */ { unsigned plong Xtx,Xty,overflow,Xtres; unsigned plong t[4]; Xtres = addll(-a,b); if (overflow) { s4_neg_int[3]=Xtres; return make_integer(s4_neg_int);} else { small_neg_int[2]=Xtres; return make_integer(small_neg_int);} }}} } gcl-2.6.14/mp/mp_divul3_word.c0000755000175000017500000000426114360276512014516 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" #include "arith.h" our_ulong divul3(x,y,hi) our_ulong x,y,*hi; { #define HIBIT 0x80000000 #define HIMASK 0xffff0000 #define LOMASK 0xffff #define HIWORD(a) (a >> 16) /* si le compilateur est bugge, il faut mettre (a >> 16) & LOMASK) */ #define LOWORD(a) (a & LOMASK) #define GLUE(hi, lo) ((hi << 16) + lo) #define SPLIT(a, b, c) b = HIWORD(a); c = LOWORD(a) our_ulong v1, v2, u3, u4, q1, q2, aux, aux1, aux2,hiremainder=*hi; int k; for(k = 0; !(y & HIBIT); k++) { hiremainder <<= 1; if (x & HIBIT) hiremainder++; x <<= 1; y <<= 1; } SPLIT(y, v1, v2); SPLIT(x, u3, u4); q1 = hiremainder / v1; if (q1 & HIMASK) q1 = LOMASK; hiremainder -= q1 * v1; aux = v2 * q1; again: SPLIT(aux, aux1, aux2); if (aux2 > u3) aux1++; if (aux1 > hiremainder) {q1--; hiremainder += v1; aux -= v2; goto again;} u3 -= aux2; hiremainder -= aux1; hiremainder <<= 16; hiremainder += u3 & LOMASK; q2 = hiremainder / v1; if (q2 & HIMASK) q2 = LOMASK; hiremainder -= q2 * v1; aux = v2 * q2; again2: SPLIT(aux, aux1, aux2); if (aux2 > u4) aux1++; if (aux1 > hiremainder) {q2--; hiremainder += v1; aux -= v2; goto again2;} u4 -= aux2; hiremainder -= aux1; hiremainder <<= 16; hiremainder += u4 & LOMASK; hiremainder >>= k; *hi = hiremainder; return GLUE(q1, q2); } gcl-2.6.14/mp/make.defs0000755000175000017500000000231114360276512013167 0ustar cammcammh/dec3100.defs: MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a h/hp300-bsd.defs: MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a h/hp300.defs: # MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a h/hp800.defs: # MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a h/mp386.defs: MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a h/ncr.defs: #:MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a h/ps2_aix.defs: MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a h/rios.defs: MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a h/rt_aix.defs: h/rt_aos.defs: h/sgi.defs: h/sgi4d.defs: MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a h/sig.defs: h/sun2r3.defs: h/sun3-os4.defs: MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a h/sun3.defs: MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a h/sun386i.defs: h/sun4.defs: MPFILES=$(MPDIR)/mpi-sparc.o $(MPDIR)/sparcdivul3.o $(MPDIR)/libmport.a h/symmetry.defs: h/u370_aix.defs: MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-u370_aix.o ${MPDIR}/mp_sl3todivul3.o ${MPDIR}/libmport.a # MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a h/vax.defs: gcl-2.6.14/mp/makefile0000644000175000017500000000302314360276512013105 0ustar cammcammAR = ar qc MPDIR=. RANLIB=ranlib # if you are using gcc for the main link you probably dont need this: GNULIB1= ${MPDIR}/gnulib1.o NATIVE_CC=cc # default mp files (overridden by machine.defs) MPFILES= $(MPDIR)/mpi.o $(MPDIR)/mp2.o $(MPDIR)/libmport.a -include ../makedefs OBJS= mp_divul3.o mp_bfffo.o mp_mulul3.o mp2.o mp_dblrsl3.o mp_dblrul3.o ${GNULIB1} all: $(MAKE) all1 "MPFILES=$(MPFILES)" all1: ${MPFILES} $(MPDIR)/libmport.a: $(OBJS) rm -f libmport.a $(AR) libmport.a ${OBJS} ${RANLIB} libmport.a .s.o: $(AS) $*.s -o $*.o .c.o: $(CC) -c $(OFLAG) -I../h -I. $(CFLAGS) $(ODIR_DEBUG) $*.c mpi-386_no_under.o: mpi-386_no_under.s gcc -traditional -c $*.s -o $*.o mpi-386d.o: mpi-386d.S gcc -traditional -c $*.S -o $*.o mpi-bsd68k.s: mpi.c gcc -S -I../h -O mpi.c -o mpi-bsd68k.s mpi-sparc.s: mpi.c gcc -S -I../h -O mpi.c -o mpi-sparc.s mpi-sol-sparc.s: mpi.c gcc -S -I../h -O mpi.c -o mpi-sol-sparc.s ${MPDIR}/mpi-386.o: ${MPDIR}/mpi-386.s $(AS) $*.s -o $*.o ${MPDIR}/mpi-386.s: mpi.c gcc -S -I../h -O mpi.c -o mpi-386.s ${MPDIR}/mpi-gcc.o: mpi.c gcc -c -O -I../h mpi.c -o mpi-gcc.o ${MPDIR}/gnulib1.o: ${NATIVE_CC} -c -O gnulib1.c $(MPDIR)/mpi-386-winnt.o: $(MPDIR)/mpi-386-winnt.s $(AS) $*.s -o $*.o clean: rm -f *.o *.a make.defs: (cd .. ; for v in h/*.defs; do echo $$v: ; fgrep MPFILES $$v ; done ; true) > make.defs tar: (cd .. ; ls mp/*.c mp/*.s h/*.h h/*.defs mp/makefile mp/make.defs) | sed -e '/foo/d' > tmpx (cd .. ; tar cvf - `cat mp/tmpx`) | compress -c > ${HOME}/tmp/mp.tar.Z rm -f tmpx gcl-2.6.14/mp/mp_dblrsl3.c0000755000175000017500000000236214360276512013622 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "config.h" #include "genpari.h" #include "arith.h" int dblremsl3(x,y,z) int x,y,z; { unsigned plong h; unsigned plong w; if (x>= 0 && y>= 0 && z>0) {w = mulul(x,y,h); divul(x,z,h); return h;} else { plong save = avma; GEN yy = stoi(y); GEN xx = stoi(x); GEN ans = mulii(xx,yy); ans = dvmdii(ans,stoi(z),-1); avma = save; if (signe(ans) > 0) return ans[2]; if (signe(ans) < 0) return -ans[2]; return 0;} } gcl-2.6.14/mp/lo-rios.s0000755000175000017500000000520414360276512013163 0ustar cammcamm.file "lo-rios.s" # Copyright W. Schelter 1991 ######MULUL3####### #unfortunately the mul operation on rios is signed, # so we have to go to a bit of work to get the unsigned op. .toc .globl mulul3[ds] .csect mulul3[ds] .long .mulul3[PR] .long TOC[tc0] .long 0 .toc # MULUL3(x,y,hi) T.mulul3: .tc .mulul3[tc],mulul3[ds] .globl .mulul3[PR] .csect .mulul3[PR] mul. 0,3,4 # hp = r0 cmpi 0,4,0 # bge Ypos # branch if reg4 >=0 a 0,3,0 Ypos: cmpi 0,3,0 bge Xpos a 0,4,0 Xpos: mfmq 3 st 0,0x0(5) br ######### DIVSL3 ############ # a divide just like divul3, except that # it assumes that x,y are signed numbers. .toc .globl divsl3[ds] .csect divsl3[ds] .long .divsl3[PR] .long TOC[tc0] .long 0 .toc # DIVSL3(lo,divisor,rem) # long h,divisor,*rem T.divsl3: .tc .divsl3[tc],divsl3[ds] .globl .divsl3[PR] .csect .divsl3[PR] mtmq 3 # move lo to q reg l 3,0x0(5) # put hi in reg3 div 3,3,4 # r3 = (r3:qreg)/r4 mfmq 4 # move remainder to reg6 st 4,0x0(5) # store 6 in *rem br #########Xdivul3################# # Below is a broken attempt to do a divul3 which # does the test and branches to the slow one if necessary. .globl .slowdivul3[PR] .toc .globl Xdivul3[ds] .csect Xdivul3[ds] .long .Xdivul3[PR] .long TOC[tc0] .long 0 .toc # old(D,H,L,QP,RP) # XDIVUL3(lo,divisor,rem) # long h,divisor,*rem # T.Xdivul3: .tc .Xdivul3[tc],Xdivul3[ds] .globl .Xdivul3[PR] .csect .Xdivul3[PR] cmpi 0,4,0 # l 6,0x0(5) blt Lslow a 0,6,6 cmp 1,4,0 bgt Ldivsl # branch if reg4 >=0 Lslow: b .slowdivul3[PR] Ldivsl: mtmq 3 # move lo to q reg div 3,6,4 # r3 = (r6:qreg)/r4 mfmq 4 # move remainder to reg4 st 4,0x0(5) # store 6 in *rem br ##### Flush the instruction cache. Necessary for loading. .toc #T.myics.s:.tc myics.s[tc],myics.s[rw] .globl myics[ds] .csect myics[ds] .long .myics[PR] .long TOC[tc0] .long 0 .toc T.myics: .tc .myics[tc],myics[ds] .globl .myics[PR] .csect .myics[PR] dcs ics brl #### Allocate lots of space for toc entries during dynamic loading. .globl akcltoc[ds] .csect akcltoc[ds] .long .akcltoc[tc] .csect .akcltoc[tc] .space 24000 .globl toc_start[ds] .csect toc_start[ds] .long TOC[tc0] gcl-2.6.14/mp/mpi-386d.S0000755000175000017500000010475314360276512013017 0ustar cammcamm# 1 "../mp/mpi-386d.S" # 11 "../mp/mpi-386d.S" # 30 "../mp/mpi-386d.S" .file "mpi.c" gcc2_compiled.: ___gnu_compiled_c: .text .align 4 .globl _mulsi ; .align 4,0x90 ; _mulsi: pushl %ebp movl %esp,%ebp subl $20,%esp pushl %edi pushl %esi pushl %ebx movl 12(%ebp),%ebx movl 4(%ebx),%ecx sarl $24,%ecx movl %ecx,-8(%ebp) movzwl 4(%ebx),%edx movl %edx,-12(%ebp) cmpl $0,8(%ebp) je L3 testl %ecx,%ecx jne L2 L3: movl _gzero ,%eax jmp L13 .align 4,0x90 L2: cmpl $0,8(%ebp) jge L4 negl -8(%ebp) negl 8(%ebp) jns L4 pushl %ebx pushl $-2147483648 call _stoi addl $4,%esp pushl %eax call _mulii jmp L13 .align 4,0x90 L4: movl -12(%ebp),%eax incl %eax pushl %eax call _cgeti movl %eax,-16(%ebp) movl $0,-4(%ebp) movl -12(%ebp),%ecx leal 0(,%ecx,4),%eax addl %eax,%ebx movl %ebx,-20(%ebp) movl -16(%ebp),%edx leal 4(%eax,%edx),%esi addl $4,%esp movl %ecx,%edi addl $-2,%edi je L7 .align 2,0x90 L10: addl $-4,%esi movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-20(%ebp) movl -20(%ebp),%ecx movl (%ecx),%ecx pushl %ecx movl 8(%ebp),%edx pushl %edx call _mulul3 addl %ebx,%eax cmpl %ebx,%eax jae L9 incl -4(%ebp) L9: movl %eax,(%esi) addl $12,%esp decl %edi jne L10 L7: cmpl $0,-4(%ebp) je L11 movl -4(%ebp),%ecx movl %ecx,-4(%esi) movl -16(%ebp),%edx movl 4(%edx),%eax andl $-65536,%eax movl -12(%ebp),%ecx leal 1(%ecx,%eax),%eax movl %eax,4(%edx) jmp L12 .align 4,0x90 L11: addl $4,_avma movl -16(%ebp),%edx movl (%edx),%ecx decl %ecx movl %ecx,4(%edx) addl $4,%edx movl %edx,-16(%ebp) movw -12(%ebp),%cx movw %cx,4(%edx) L12: movb -8(%ebp),%dl movl -16(%ebp),%ecx movb %dl,7(%ecx) movl -16(%ebp),%eax L13: leal -32(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _expi ; .align 4,0x90 ; _expi: pushl %ebp movl %esp,%ebp pushl %ebx movl 8(%ebp),%eax movzwl 4(%eax),%ebx cmpl $2,%ebx je L15 movl 8(%eax),%eax pushl %eax call _bfffo leal -2(%ebx),%edx sall $5,%edx subl %eax,%edx decl %edx jmp L16 .align 4,0x90 L15: movl $-8388608,%edx L16: movl %edx,%eax movl -4(%ebp),%ebx movl %ebp,%esp popl %ebp ret .align 4 .globl _addsi ; .align 4,0x90 ; _addsi: pushl %ebp movl %esp,%ebp subl $12,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%edi testl %esi,%esi jne L18 pushl %edi call _icopy jmp L60 .align 4,0x90 L18: movl 4(%edi),%ebx sarl $24,%ebx movl %ebx,-8(%ebp) jne L19 pushl %esi call _stoi jmp L60 .align 4,0x90 L19: testl %esi,%esi jge L20 movl $-1,-4(%ebp) negl %esi jns L22 pushl %edi pushl $ _MOST_NEGS call _addii jmp L60 .align 4,0x90 L20: movl $1,-4(%ebp) L22: movzwl 4(%edi),%ebx movl %ebx,-12(%ebp) movl -8(%ebp),%ebx cmpl %ebx,-4(%ebp) jne L23 movl %esi,%edx movl %edx,%eax movl -12(%ebp),%ebx addl -4(%edi,%ebx,4),%eax movl %eax,%esi cmpl %edx,%eax jae L24 movl %ebx,%eax incl %eax pushl %eax call _cgeti movl %eax,%ecx movl %esi,(%ecx,%ebx,4) movl %ebx,%edx jmp L61 .align 4,0x90 .align 2,0x90 L28: movl $0,(%ecx,%edx,4) L61: decl %edx cmpl $2,%edx jle L29 cmpl $-1,-4(%edi,%edx,4) je L28 cmpl $2,%edx jle L29 movl -4(%edi,%edx,4),%ebx incl %ebx jmp L62 .align 4,0x90 .align 2,0x90 L32: movl -4(%edi,%edx,4),%ebx L62: movl %ebx,(%ecx,%edx,4) decl %edx cmpl $2,%edx jg L32 movl (%ecx),%eax decl %eax movl %eax,4(%ecx) movl %eax,8(%ecx) addl $4,%ecx addl $4,_avma jmp L34 .align 4,0x90 L29: movl $1,8(%ecx) movl (%ecx),%ebx movl %ebx,4(%ecx) jmp L34 .align 4,0x90 L24: movl -12(%ebp),%ebx pushl %ebx call _cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl $1,%edx movl %ebx,%eax decl %eax movl %eax,%esi cmpl %eax,%edx jge L34 .align 2,0x90 L38: movl (%edi,%edx,4),%ebx movl %ebx,(%ecx,%edx,4) incl %edx cmpl %esi,%edx jl L38 L34: movb -4(%ebp),%bl movb %bl,7(%ecx) jmp L39 .align 4,0x90 L23: cmpl $3,-12(%ebp) jne L40 cmpl %esi,8(%edi) jbe L41 pushl $3 call _cgeti movl %eax,%ecx movl -8(%ebp),%eax sall $24,%eax addl $3,%eax movl %eax,4(%ecx) movl 8(%edi),%edi subl %esi,%edi movl %edi,8(%ecx) jmp L39 .align 4,0x90 L41: cmpl %esi,8(%edi) jne L42 movl _gzero ,%eax jmp L60 .align 4,0x90 L42: pushl $3 call _cgeti movl %eax,%ecx movl -8(%ebp),%eax negl %eax sall $24,%eax addl $3,%eax movl %eax,4(%ecx) subl 8(%edi),%esi movl %esi,8(%ecx) jmp L39 .align 4,0x90 L40: movl -12(%ebp),%ebx movl -4(%edi,%ebx,4),%edx movl %esi,%eax movl %edx,%esi subl %eax,%esi cmpl %eax,%edx jae L43 pushl %ebx call _cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl %ebx,%edx addl $-2,%edx cmpl $0,(%edi,%edx,4) jne L45 .align 2,0x90 L47: movl $-1,(%ecx,%edx,4) decl %edx cmpl $0,(%edi,%edx,4) je L47 L45: movl (%edi,%edx,4),%eax decl %eax movl %eax,(%ecx,%edx,4) cmpl $2,%edx jg L49 testl %eax,%eax je L48 L49: decl %edx testl %edx,%edx jle L39 .align 2,0x90 L53: movl (%edi,%edx,4),%ebx movl %ebx,(%ecx,%edx,4) decl %edx testl %edx,%edx jg L53 jmp L39 .align 4,0x90 L48: movl (%ecx),%eax decl %eax movl %eax,4(%ecx) movl %eax,8(%ecx) addl $4,%ecx addl $4,_avma movb -8(%ebp),%bl movb %bl,7(%ecx) jmp L39 .align 4,0x90 L43: movl -12(%ebp),%ebx pushl %ebx call _cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl $1,%edx movl %ebx,%eax decl %eax movl %eax,%esi cmpl %eax,%edx jge L39 .align 2,0x90 L59: movl (%edi,%edx,4),%ebx movl %ebx,(%ecx,%edx,4) incl %edx cmpl %esi,%edx jl L59 L39: movl %ecx,%eax L60: leal -24(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _addii ; .align 4,0x90 ; _addii: pushl %ebp movl %esp,%ebp subl $32,%esp pushl %edi pushl %esi pushl %ebx movl 12(%ebp),%edi movl 8(%ebp),%edx movzwl 4(%edx),%edx movl %edx,-8(%ebp) movzwl 4(%edi),%ecx movl %ecx,-12(%ebp) cmpl %ecx,%edx jge L64 movl 8(%ebp),%edx movl %edx,-16(%ebp) movl %edi,8(%ebp) movl -16(%ebp),%edi movl -8(%ebp),%ecx movl %ecx,-4(%ebp) movl -12(%ebp),%edx movl %edx,-8(%ebp) movl %ecx,-12(%ebp) L64: movl 4(%edi),%esi sarl $24,%esi jne L65 movl 8(%ebp),%ecx pushl %ecx call _icopy jmp L119 .align 4,0x90 L65: movl 8(%ebp),%edx movl 4(%edx),%ecx sarl $24,%ecx movl %ecx,-4(%ebp) cmpl %esi,%ecx jne L66 movl -8(%ebp),%eax incl %eax pushl %eax call _cgeti movl %eax,-16(%ebp) movl $0,-24(%ebp) movl -8(%ebp),%edx leal 0(,%edx,4),%eax movl -16(%ebp),%ecx leal 4(%eax,%ecx),%esi movl 8(%ebp),%ebx addl %eax,%ebx movl -12(%ebp),%edx leal (%edi,%edx,4),%edi movl %edi,-20(%ebp) movl %edx,%edi addl $-2,%edi je L68 .align 2,0x90 L71: addl $-4,%esi addl $-4,%ebx movl (%ebx),%ecx movl %ecx,-28(%ebp) addl $-4,-20(%ebp) movl -20(%ebp),%edx addl (%edx),%ecx movl %ecx,-32(%ebp) movl -28(%ebp),%edx cmpl %edx,%ecx jae L69 movl -24(%ebp),%edx addl %edx,%ecx movl %ecx,-32(%ebp) movl $1,-24(%ebp) movl %ecx,(%esi) jmp L67 .align 4,0x90 L69: movl -24(%ebp),%ecx addl %ecx,-32(%ebp) cmpl %ecx,-32(%ebp) setb %al andl $255,%eax movl %eax,-24(%ebp) movl -32(%ebp),%edx movl %edx,(%esi) L67: decl %edi jne L71 L68: cmpl $0,-24(%ebp) je L72 movl 8(%ebp),%edi addl $8,%edi L73: addl $-4,%ebx movl %ebx,%eax cmpl %edi,%ebx jb L74 cmpl $-1,(%ebx) jne L75 addl $-4,%esi movl $0,(%esi) jmp L73 .align 4,0x90 L75: addl $-4,%esi movl (%eax),%eax incl %eax jmp L121 .align 4,0x90 .align 2,0x90 L79: addl $-4,%esi movl (%eax),%eax L121: movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edi,%ebx jae L79 movl -16(%ebp),%ecx movl (%ecx),%edx decl %edx movl %edx,4(%ecx) movl 8(%ebp),%ecx movl 4(%ecx),%edx movl -16(%ebp),%ecx movl %edx,8(%ecx) addl $4,%ecx movl %ecx,-16(%ebp) addl $4,_avma jmp L85 .align 4,0x90 L74: movl -16(%ebp),%ecx movl $1,8(%ecx) movl 8(%ebp),%ecx movl 4(%ecx),%edx incl %edx movl -16(%ebp),%ecx movl %edx,4(%ecx) jmp L85 .align 4,0x90 L72: movl -8(%ebp),%eax subl -12(%ebp),%eax je L83 .align 2,0x90 L84: addl $-4,%esi addl $-4,%ebx movl (%ebx),%ecx movl %ecx,(%esi) decl %eax jne L84 L83: movl -16(%ebp),%edx movl (%edx),%ecx decl %ecx movl %ecx,4(%edx) movl 8(%ebp),%edx movl 4(%edx),%ecx movl -16(%ebp),%edx movl %ecx,8(%edx) addl $4,%edx movl %edx,-16(%ebp) addl $4,_avma jmp L85 .align 4,0x90 L66: movl -12(%ebp),%edx cmpl %edx,-8(%ebp) jne L86 movl 8(%ebp),%ebx addl $8,%ebx leal 8(%edi),%ecx movl %ecx,-20(%ebp) movl -8(%ebp),%eax addl $-2,%eax je L94 .align 2,0x90 L93: movl (%ebx),%edx movl %edx,-28(%ebp) addl $4,%ebx movl -20(%ebp),%ecx movl (%ecx),%ecx movl %ecx,-32(%ebp) addl $4,-20(%ebp) cmpl %edx,%ecx ja L120 cmpl %ecx,%edx ja L86 decl %eax jne L93 L94: movl _gzero ,%eax jmp L119 .align 4,0x90 L120: movl 8(%ebp),%edx movl %edx,-16(%ebp) movl %edi,8(%ebp) movl -16(%ebp),%edi movl %esi,-4(%ebp) L86: movl -8(%ebp),%ecx pushl %ecx call _cgeti movl %eax,-16(%ebp) movl $0,-24(%ebp) movl -8(%ebp),%edx leal 0(,%edx,4),%eax movl 8(%ebp),%ebx addl %eax,%ebx movl -12(%ebp),%ecx leal (%edi,%ecx,4),%edi movl %edi,-20(%ebp) movl -16(%ebp),%esi addl %eax,%esi movl %ecx,%edi addl $-2,%edi je L96 .align 2,0x90 L101: addl $-4,%esi addl $-4,%ebx movl (%ebx),%edx movl %edx,-28(%ebp) addl $-4,-20(%ebp) movl -20(%ebp),%ecx movl (%ecx),%eax subl %eax,%edx movl -24(%ebp),%ecx subl %ecx,%edx movl %edx,-32(%ebp) cmpl %eax,-28(%ebp) jae L97 movl $1,-24(%ebp) jmp L98 .align 4,0x90 L97: cmpl %eax,-28(%ebp) jbe L98 movl $0,-24(%ebp) L98: movl -32(%ebp),%edx movl %edx,(%esi) decl %edi jne L101 L96: cmpl $0,-24(%ebp) je L102 jmp L122 .align 4,0x90 .align 2,0x90 L105: addl $-4,%esi movl $-1,(%esi) L122: addl $-4,%ebx movl (%ebx),%eax testl %eax,%eax je L105 movl 8(%ebp),%edi addl $8,%edi cmpl %edi,%ebx jb L110 addl $-4,%esi decl %eax movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edi,%ebx jb L110 .align 2,0x90 L109: addl $-4,%esi movl (%eax),%eax movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edi,%ebx jae L109 jmp L110 .align 4,0x90 L102: movl -8(%ebp),%edi subl -12(%ebp),%edi je L110 .align 2,0x90 L113: addl $-4,%esi addl $-4,%ebx movl (%ebx),%ecx movl %ecx,(%esi) decl %edi jne L113 L110: movl -16(%ebp),%edx cmpl $0,8(%edx) je L114 movl 8(%ebp),%ecx movl 4(%ecx),%ecx movl %ecx,4(%edx) jmp L85 .align 4,0x90 L114: movl -16(%ebp),%esi addl $12,%esi movl -16(%ebp),%edx cmpl $0,12(%edx) jne L117 .align 2,0x90 L118: addl $4,%esi cmpl $0,(%esi) je L118 L117: addl $-8,%esi movl %esi,%edi subl -16(%ebp),%edi sarl $2,%edi movl -16(%ebp),%ecx movl (%ecx),%eax subl %edi,%eax movl %eax,(%esi) movl %eax,4(%esi) movl %esi,-16(%ebp) movb -4(%ebp),%dl movb %dl,7(%esi) leal 0(,%edi,4),%eax addl %eax,_avma L85: movl -16(%ebp),%eax L119: leal -44(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _mulss ; .align 4,0x90 ; _mulss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %esi pushl %ebx movl 8(%ebp),%edx movl 12(%ebp),%ebx testl %edx,%edx je L125 testl %ebx,%ebx jne L124 L125: movl _gzero ,%eax jmp L133 .align 4,0x90 L124: movl $1,%esi testl %edx,%edx jge L126 movl $-1,%esi negl %edx jns L126 pushl %edx call _stoi pushl %eax pushl %ebx call _mulsi jmp L133 .align 4,0x90 L126: testl %ebx,%ebx jge L128 negl %esi negl %ebx jns L128 pushl $ _ABS_MOST_NEGS movl %edx,%eax testl %esi,%esi jg L130 negl %eax L130: pushl %eax call _mulsi jmp L133 .align 4,0x90 L128: leal -4(%ebp),%eax pushl %eax pushl %ebx pushl %edx call _mulul3 movl %eax,%ebx addl $12,%esp cmpl $0,-4(%ebp) je L131 pushl $4 call _cgeti movl -4(%ebp),%ecx movl %ecx,8(%eax) movl %ebx,12(%eax) jmp L132 .align 4,0x90 L131: pushl $3 call _cgeti movl %ebx,8(%eax) L132: movl (%eax),%ecx movl %ecx,4(%eax) movl %esi,%ecx movb %cl,7(%eax) L133: leal -12(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .align 4 .globl _mulii ; .align 4,0x90 ; _mulii: pushl %ebp movl %esp,%ebp subl $48,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movzwl 4(%esi),%edi movl %edi,-8(%ebp) movl 12(%ebp),%ecx movzwl 4(%ecx),%ecx movl %ecx,-12(%ebp) movl 4(%esi),%ebx sarl $24,%ebx je L157 movl 12(%ebp),%edi movl 4(%edi),%eax sarl $24,%eax jne L136 L157: movl _gzero ,%eax jmp L156 .align 4,0x90 L136: testl %eax,%eax jge L137 negl %ebx L137: movl -12(%ebp),%ecx cmpl %ecx,-8(%ebp) jle L138 movl %esi,-24(%ebp) movl 12(%ebp),%esi movl -24(%ebp),%edi movl %edi,12(%ebp) movl -8(%ebp),%ecx movl %ecx,-16(%ebp) movl -12(%ebp),%edi movl %edi,-8(%ebp) movl %ecx,-12(%ebp) L138: movl -8(%ebp),%ecx movl -12(%ebp),%edi leal -2(%edi,%ecx),%ecx movl %ecx,-16(%ebp) cmpl $65535,%ecx jle L139 pushl $17 call _err addl $4,%esp L139: movl -16(%ebp),%ecx pushl %ecx call _cgeti movl %eax,-24(%ebp) movl (%eax),%edi movl %edi,4(%eax) movb %bl,7(%eax) movl -8(%ebp),%ecx leal -4(%esi,%ecx,4),%esi movl %esi,-32(%ebp) movl (%esi),%edi movl %edi,-20(%ebp) movl $0,-4(%ebp) movl -12(%ebp),%ecx movl 12(%ebp),%edi leal (%edi,%ecx,4),%ecx movl %ecx,-48(%ebp) movl -16(%ebp),%edi leal (%eax,%edi,4),%edi movl %edi,-28(%ebp) addl $4,%esp movl -12(%ebp),%esi addl $-2,%esi je L141 .align 2,0x90 L144: addl $-4,-28(%ebp) movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-48(%ebp) movl -48(%ebp),%ecx movl (%ecx),%ecx pushl %ecx movl -20(%ebp),%edi pushl %edi call _mulul3 movl %eax,%edx addl %ebx,%edx cmpl %ebx,%edx jae L143 incl -4(%ebp) L143: movl -28(%ebp),%ecx movl %edx,(%ecx) addl $12,%esp decl %esi jne L144 L141: movl -4(%ebp),%ecx movl -28(%ebp),%edi movl %ecx,-4(%edi) movl -16(%ebp),%edi movl -24(%ebp),%ecx leal (%ecx,%edi,4),%edi movl %edi,-28(%ebp) movl -12(%ebp),%ecx movl 12(%ebp),%edi leal (%edi,%ecx,4),%ecx movl %ecx,-36(%ebp) decl -12(%ebp) addl $-3,-8(%ebp) cmpl $0,-8(%ebp) jle L146 .align 2,0x90 L154: addl $-4,-32(%ebp) movl -32(%ebp),%edi movl (%edi),%edi movl %edi,-44(%ebp) movl -36(%ebp),%ecx movl %ecx,-48(%ebp) movl -28(%ebp),%ebx addl $-4,%ebx movl %ebx,-28(%ebp) movl $0,-40(%ebp) movl -12(%ebp),%esi jmp L158 .align 4,0x90 .align 2,0x90 L153: addl $-4,-48(%ebp) leal -4(%ebp),%eax pushl %eax movl -44(%ebp),%edi pushl %edi movl -48(%ebp),%ecx movl (%ecx),%ecx pushl %ecx call _mulul3 addl $-4,%ebx movl %eax,%edx addl (%ebx),%edx cmpl %eax,%edx jae L150 incl -4(%ebp) L150: movl %edx,%eax movl -40(%ebp),%edx addl %eax,%edx cmpl %eax,%edx jae L152 incl -4(%ebp) L152: movl %edx,(%ebx) movl -4(%ebp),%edi movl %edi,-40(%ebp) addl $12,%esp L158: decl %esi jne L153 movl -4(%ebp),%ecx movl %ecx,-4(%ebx) decl -8(%ebp) cmpl $0,-8(%ebp) jg L154 L146: movl -24(%ebp),%edi cmpl $0,8(%edi) jne L155 movl -24(%ebp),%edi movl 4(%edi),%ecx decl %ecx movl %ecx,8(%edi) movl -24(%ebp),%edi movl (%edi),%ecx decl %ecx movl %ecx,4(%edi) addl $4,%edi movl %edi,-24(%ebp) addl $4,_avma L155: movl -24(%ebp),%eax L156: leal -60(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 2 LC0: .long 0x55475a32,0x3fd34413 .align 4 .globl _confrac ; .align 4,0x90 ; _confrac: pushl %ebp movl %esp,%ebp subl $68,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%edx movzwl (%edx),%edx movl %edx,-16(%ebp) movl 8(%ebp),%ecx movl 4(%ecx),%eax andl $16777215,%eax movl $8388607,%edx subl %eax,%edx movl %edx,-20(%ebp) movl _avma ,%ecx movl %ecx,-24(%ebp) movl -16(%ebp),%eax sall $5,%eax leal -64(%edx,%eax),%eax movl %eax,-32(%ebp) addl $63,%eax sarl $5,%eax movl %eax,-28(%ebp) pushl %eax call _cgeti movl %eax,-44(%ebp) movl -20(%ebp),%esi sarl $5,%esi xorl %ebx,%ebx addl $4,%esp cmpl %esi,%ebx jge L161 .align 2,0x90 L163: movl -44(%ebp),%edx movl $0,(%edx,%ebx,4) incl %ebx cmpl %esi,%ebx jl L163 L161: andl $31,-20(%ebp) jne L164 movl $2,%edi cmpl %edi,-16(%ebp) jle L169 .align 2,0x90 L168: movl 8(%ebp),%ecx movl (%ecx,%edi,4),%eax movl -44(%ebp),%ecx movl %eax,(%ecx,%ebx,4) incl %ebx incl %edi cmpl %edi,-16(%ebp) jg L168 jmp L169 .align 4,0x90 L164: movl $0,-40(%ebp) movl $2,%edi cmpl %edi,-16(%ebp) jle L171 movl $32,%edx subl -20(%ebp),%edx movl %edx,-52(%ebp) .align 2,0x90 L173: movl %ebx,-64(%ebp) movl 8(%ebp),%ecx movl (%ecx,%edi,4),%esi incl %ebx movl %esi,%eax movl -52(%ebp),%ecx sall %cl,%eax movl %eax,-68(%ebp) movl %eax,-12(%ebp) movl -20(%ebp),%ecx shrl %cl,%esi movl %esi,%ecx addl -40(%ebp),%ecx movl -64(%ebp),%eax movl -44(%ebp),%edx movl %ecx,(%edx,%eax,4) movl -68(%ebp),%eax movl %eax,-40(%ebp) incl %edi cmpl %edi,-16(%ebp) jg L173 L171: movl -40(%ebp),%eax movl -28(%ebp),%edx movl -44(%ebp),%ecx movl %eax,-8(%ecx,%edx,4) L169: movl -28(%ebp),%edx movl -44(%ebp),%ecx movl $0,-4(%ecx,%edx,4) fldl LC0 fimull -32(%ebp) fld1 faddp %st,%st(1) fnstcw -4(%ebp) movl -4(%ebp),%eax movb $12,%ah movl %eax,-8(%ebp) fldcw -8(%ebp) subl $4,%esp fistpl (%esp) popl %ebx fldcw -4(%ebp) leal 17(%ebx),%edx movl %edx,-36(%ebp) movl -36(%ebp),%eax movl $9,%ecx cltd idivl %ecx movl %eax,-36(%ebp) pushl %eax call _cgeti movl %eax,-48(%ebp) movl %ebx,(%eax) movl $1,%edi addl $4,%esp cmpl %edi,-36(%ebp) jle L175 leal -12(%ebp),%eax movl %eax,-56(%ebp) .align 2,0x90 L183: movl $0,-12(%ebp) movl -28(%ebp),%ebx jmp L184 .align 4,0x90 .align 2,0x90 L182: movl -12(%ebp),%esi movl -56(%ebp),%edx pushl %edx pushl $1000000000 movl -44(%ebp),%ecx movl (%ecx,%ebx,4),%ecx pushl %ecx call _mulul3 movl %eax,-68(%ebp) addl %esi,-68(%ebp) cmpl %esi,-68(%ebp) jae L181 incl -12(%ebp) L181: movl -68(%ebp),%edx movl -44(%ebp),%eax movl %edx,(%eax,%ebx,4) addl $12,%esp L184: decl %ebx jns L182 movl -12(%ebp),%eax movl -48(%ebp),%ecx movl %eax,(%ecx,%edi,4) incl %edi cmpl %edi,-36(%ebp) jg L183 L175: movl -24(%ebp),%edx movl %edx,_avma movl -48(%ebp),%eax leal -80(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _divss ; .align 4,0x90 ; _divss: pushl %ebp movl %esp,%ebp pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%ebx testl %ebx,%ebx jne L186 pushl $23 call _err addl $4,%esp L186: cmpl $-2147483648,%esi jne L187 pushl %ebx pushl $-2147483648 call _stoi addl $4,%esp pushl %eax call _divis jmp L192 .align 4,0x90 L187: movl $0,_hiremainder pushl $ _hiremainder movl %ebx,%eax testl %ebx,%ebx jge L188 negl %eax L188: pushl %eax movl %esi,%eax testl %esi,%esi jge L189 negl %eax L189: pushl %eax call _divul3 addl $12,%esp testl %ebx,%ebx jge L190 negl _hiremainder negl %eax L190: testl %esi,%esi jge L191 negl %eax L191: pushl %eax call _stoi L192: leal -8(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .align 4 .globl _modss ; .align 4,0x90 ; _modss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%ebx testl %ebx,%ebx jne L194 pushl $38 call _err addl $4,%esp L194: cmpl $-2147483648,%esi jne L195 pushl %ebx pushl $-2147483648 call _stoi addl $4,%esp pushl %eax call _modis jmp L201 .align 4,0x90 L195: movl $0,-4(%ebp) leal -4(%ebp),%eax pushl %eax testl %ebx,%ebx jge L196 negl %ebx L196: pushl %ebx movl %esi,%eax testl %eax,%eax jge L197 negl %eax L197: pushl %eax call _divul3 addl $12,%esp cmpl $0,-4(%ebp) jne L198 movl _gzero ,%eax jmp L201 .align 4,0x90 L198: cmpl $0,-4(%ebp) jge L199 movl %ebx,%eax subl -4(%ebp),%eax pushl %eax jmp L202 .align 4,0x90 L199: movl -4(%ebp),%edx pushl %edx L202: call _stoi L201: leal -12(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .align 4 .globl _resss ; .align 4,0x90 ; _resss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %ebx movl 12(%ebp),%ebx testl %ebx,%ebx jne L204 pushl $40 call _err addl $4,%esp L204: movl $0,-4(%ebp) leal -4(%ebp),%eax pushl %eax movl %ebx,%eax testl %ebx,%ebx jge L205 negl %eax L205: pushl %eax movl 8(%ebp),%eax testl %eax,%eax jge L206 negl %eax L206: pushl %eax call _divul3 testl %ebx,%ebx jge L207 movl -4(%ebp),%eax negl %eax pushl %eax jmp L209 .align 4,0x90 L207: movl -4(%ebp),%edx pushl %edx L209: call _stoi movl -8(%ebp),%ebx movl %ebp,%esp popl %ebp ret .align 4 .globl _divsi ; .align 4,0x90 ; _divsi: pushl %ebp movl %esp,%ebp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%ebx movl 12(%ebp),%esi movzwl 4(%esi),%edi cmpb $0,7(%esi) jne L211 pushl $24 call _err addl $4,%esp L211: testl %ebx,%ebx je L213 cmpl $3,%edi jg L213 cmpl $0,8(%esi) jge L212 L213: movl %ebx,_hiremainder movl _gzero ,%eax jmp L218 .align 4,0x90 L212: cmpl $-2147483648,%ebx jne L214 pushl $0 pushl %esi pushl $-2147483648 call _stoi addl $4,%esp pushl %eax call _dvmdii jmp L218 .align 4,0x90 L214: movl $0,_hiremainder pushl $ _hiremainder movl 8(%esi),%edx pushl %edx movl %ebx,%eax testl %ebx,%ebx jge L215 negl %eax L215: pushl %eax call _divul3 addl $12,%esp cmpl $0,4(%esi) jge L216 negl _hiremainder negl %eax L216: testl %ebx,%ebx jge L217 negl %eax L217: pushl %eax call _stoi L218: leal -12(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _divis ; .align 4,0x90 ; _divis: pushl %ebp movl %esp,%ebp subl $24,%esp pushl %edi pushl %esi pushl %ebx movl 12(%ebp),%edi movl 8(%ebp),%edx movl 4(%edx),%ecx sarl $24,%ecx movl %ecx,-8(%ebp) movzwl 4(%edx),%edx movl %edx,-12(%ebp) testl %edi,%edi jne L220 pushl $26 call _err addl $4,%esp L220: cmpl $0,-8(%ebp) jne L221 movl $0,_hiremainder movl _gzero ,%eax jmp L234 .align 4,0x90 L221: testl %edi,%edi jge L222 negl -8(%ebp) negl %edi jns L222 pushl $0 pushl %edi call _stoi addl $4,%esp pushl %eax movl 8(%ebp),%ecx pushl %ecx call _dvmdii jmp L234 .align 4,0x90 L222: movl 8(%ebp),%edx cmpl %edi,8(%edx) jae L224 cmpl $3,-12(%ebp) jne L225 pushl %edx call _itos movl %eax,_hiremainder movl _gzero ,%eax jmp L234 .align 4,0x90 L225: movl -12(%ebp),%eax decl %eax pushl %eax call _cgeti movl %eax,%esi movl $1,-16(%ebp) movl 8(%ebp),%ecx movl 8(%ecx),%ecx movl %ecx,-4(%ebp) jmp L235 .align 4,0x90 L224: movl -12(%ebp),%edx pushl %edx call _cgeti movl %eax,%esi movl $0,-16(%ebp) movl $0,-4(%ebp) L235: addl $4,%esp movl -16(%ebp),%ebx addl $2,%ebx cmpl %ebx,-12(%ebp) jle L229 leal -4(%ebp),%ecx movl %ecx,-20(%ebp) .align 2,0x90 L231: movl -20(%ebp),%edx pushl %edx pushl %edi movl 8(%ebp),%ecx movl (%ecx,%ebx,4),%ecx pushl %ecx call _divul3 movl %ebx,%edx subl -16(%ebp),%edx movl %eax,(%esi,%edx,4) addl $12,%esp incl %ebx cmpl %ebx,-12(%ebp) jg L231 L229: movl (%esi),%ecx movl %ecx,4(%esi) movb -8(%ebp),%dl movb %dl,7(%esi) cmpl $0,-8(%ebp) jge L232 movl -4(%ebp),%ecx negl %ecx movl %ecx,_hiremainder jmp L233 .align 4,0x90 L232: movl -4(%ebp),%edx movl %edx,_hiremainder L233: movl %esi,%eax L234: leal -36(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .align 4 .globl _dvmdii ; .align 4,0x90 ; _dvmdii: pushl %ebp movl %esp,%ebp subl $92,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movl 4(%esi),%edx sarl $24,%edx movl %edx,-36(%ebp) movl 12(%ebp),%ecx movl 4(%ecx),%edi sarl $24,%edi movl %edi,-40(%ebp) jne L237 pushl $36 call _err addl $4,%esp L237: cmpl $0,-36(%ebp) jne L238 cmpl $-1,16(%ebp) je L333 cmpl $0,16(%ebp) je L333 movl _gzero ,%ecx movl 16(%ebp),%edx movl %ecx,(%edx) L333: movl _gzero ,%eax jmp L328 .align 4,0x90 L238: movzwl 4(%esi),%edi movl %edi,-12(%ebp) movl 12(%ebp),%edx movzwl 4(%edx),%edx movl %edx,-16(%ebp) subl %edx,%edi movl %edi,-20(%ebp) jns L241 cmpl $-1,16(%ebp) jne L242 pushl %esi call _icopy jmp L328 .align 4,0x90 L242: cmpl $0,16(%ebp) je L333 pushl %esi call _icopy movl 16(%ebp),%ecx movl %eax,(%ecx) jmp L333 .align 4,0x90 L241: movl _avma ,%edi movl %edi,-8(%ebp) cmpl $0,-36(%ebp) jge L244 negl -40(%ebp) L244: cmpl $3,-16(%ebp) jne L245 movl 12(%ebp),%edx movl 8(%edx),%edx movl %edx,-48(%ebp) leal 8(%esi),%ecx movl %ecx,-88(%ebp) cmpl %edx,8(%esi) jae L246 movl -12(%ebp),%ebx decl %ebx movl 8(%esi),%edi movl %edi,-4(%ebp) addl $12,%esi movl %esi,-88(%ebp) jmp L247 .align 4,0x90 L246: movl -12(%ebp),%ebx movl $0,-4(%ebp) L247: pushl %ebx call _cgeti movl %eax,-56(%ebp) movl %eax,%edx addl $8,%edx movl %edx,-72(%ebp) addl $4,%esp leal -2(%ebx),%ecx movl %ecx,-24(%ebp) testl %ecx,%ecx je L249 leal -4(%ebp),%esi .align 2,0x90 L250: pushl %esi movl -48(%ebp),%edi pushl %edi movl -88(%ebp),%edx movl (%edx),%edx pushl %edx addl $4,-88(%ebp) call _divul3 movl -72(%ebp),%ecx movl %eax,(%ecx) addl $4,%ecx movl %ecx,-72(%ebp) addl $12,%esp decl -24(%ebp) jne L250 L249: cmpl $-1,16(%ebp) jne L251 movl -8(%ebp),%edi movl %edi,_avma cmpl $0,-4(%ebp) je L333 pushl $3 call _cgeti movl %eax,-60(%ebp) movl -36(%ebp),%eax sall $24,%eax addl $3,%eax movl -60(%ebp),%edx movl %eax,4(%edx) movl -4(%ebp),%ecx movl %ecx,8(%edx) movl -60(%ebp),%eax jmp L328 .align 4,0x90 L251: cmpl $2,%ebx je L253 movl -56(%ebp),%edi movl (%edi),%edx movl %edx,4(%edi) movb -40(%ebp),%cl movb %cl,7(%edi) jmp L254 .align 4,0x90 L253: movl -8(%ebp),%edi movl %edi,_avma movl _gzero ,%edx movl %edx,-56(%ebp) L254: cmpl $0,16(%ebp) jne L255 L331: movl -56(%ebp),%eax jmp L328 .align 4,0x90 L255: cmpl $0,-4(%ebp) jne L256 movl _gzero ,%edi movl 16(%ebp),%ecx movl %edi,(%ecx) jmp L331 .align 4,0x90 L256: pushl $3 call _cgeti movl %eax,-60(%ebp) movl -36(%ebp),%eax sall $24,%eax addl $3,%eax movl -60(%ebp),%edx movl %eax,4(%edx) movl -4(%ebp),%ecx movl %ecx,8(%edx) movl 16(%ebp),%edi movl %edx,(%edi) jmp L331 .align 4,0x90 L245: movl -12(%ebp),%edx pushl %edx call _cgeti movl %eax,-56(%ebp) movl 12(%ebp),%ecx movl 8(%ecx),%ecx pushl %ecx call _bfffo movl %eax,-28(%ebp) addl $8,%esp testl %eax,%eax je L259 movl -16(%ebp),%edi pushl %edi call _cgeti movl %eax,-60(%ebp) movl 12(%ebp),%edx movl 8(%edx),%ebx addl $12,%edx movl %edx,-92(%ebp) movl $32,%eax subl -28(%ebp),%eax movl %ebx,%edi movl %eax,%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) movl -60(%ebp),%eax addl $8,%eax addl $4,%esp movl -16(%ebp),%edi addl $-3,%edi movl %edi,-24(%ebp) je L261 movl $32,%edx subl %ecx,%edx movl %edx,-88(%ebp) .align 2,0x90 L262: movl -92(%ebp),%ecx movl (%ecx),%ebx addl $4,%ecx movl %ecx,-92(%ebp) movl %ebx,%edi movl -88(%ebp),%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -32(%ebp),%edx addl %edi,%edx movl %edx,(%eax) addl $4,%eax movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) decl -24(%ebp) jne L262 L261: movl -32(%ebp),%edi movl %edi,(%eax) movl $0,-32(%ebp) addl $8,%esi movl %esi,-88(%ebp) movl -56(%ebp),%edx addl $4,%edx movl %edx,-72(%ebp) movl -12(%ebp),%ecx addl $-2,%ecx movl %ecx,-24(%ebp) je L264 movl $32,%eax subl -28(%ebp),%eax .align 2,0x90 L265: movl -88(%ebp),%edi movl (%edi),%ebx addl $4,%edi movl %edi,-88(%ebp) movl %ebx,%edi movl %eax,%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -32(%ebp),%ecx addl %edi,%ecx movl -72(%ebp),%edx movl %ecx,(%edx) addl $4,%edx movl %edx,-72(%ebp) movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) decl -24(%ebp) jne L265 L264: movl -32(%ebp),%edx movl -72(%ebp),%edi movl %edx,(%edi) jmp L266 .align 4,0x90 L259: addl $8,%esi movl %esi,-88(%ebp) movl -56(%ebp),%ecx movl $0,4(%ecx) addl $8,%ecx movl %ecx,-72(%ebp) movl -12(%ebp),%esi addl $-2,%esi je L268 .align 2,0x90 L269: movl -88(%ebp),%edi movl (%edi),%edx movl -72(%ebp),%edi movl %edx,(%edi) addl $4,-88(%ebp) addl $4,%edi movl %edi,-72(%ebp) decl %esi jne L269 L268: movl 12(%ebp),%ecx movl %ecx,-60(%ebp) L266: movl -60(%ebp),%edi movl 8(%edi),%edi movl %edi,-48(%ebp) movl -60(%ebp),%edx movl 12(%edx),%edx movl %edx,-44(%ebp) movl -56(%ebp),%ecx addl $4,%ecx movl %ecx,-72(%ebp) movl -20(%ebp),%edi incl %edi movl %edi,-24(%ebp) je L271 movl -16(%ebp),%edx sall $2,%edx movl %edx,-80(%ebp) .align 2,0x90 L297: movl -72(%ebp),%ecx movl (%ecx),%eax addl $4,%ecx movl %ecx,-72(%ebp) cmpl %eax,-48(%ebp) jne L272 movl $-1,-52(%ebp) movl -48(%ebp),%ebx movl %ebx,%edi addl (%ecx),%edi movl %edi,-84(%ebp) cmpl %ebx,%edi setb %al andl $255,%eax movl %edi,-32(%ebp) jmp L273 .align 4,0x90 L272: movl -72(%ebp),%edx movl -4(%edx),%edx movl %edx,-4(%ebp) leal -4(%ebp),%eax pushl %eax movl -48(%ebp),%ecx pushl %ecx movl -72(%ebp),%edi movl (%edi),%edi pushl %edi call _divul3 movl %eax,-52(%ebp) xorl %eax,%eax movl -4(%ebp),%edx movl %edx,-32(%ebp) addl $12,%esp L273: testl %eax,%eax jne L274 leal -4(%ebp),%eax pushl %eax movl -44(%ebp),%ecx pushl %ecx movl -52(%ebp),%edi pushl %edi call _mulul3 movl %eax,%ebx movl -72(%ebp),%edx movl 4(%edx),%edx movl %edx,-92(%ebp) addl $12,%esp cmpl %edx,%ebx setb %al andl $255,%eax subl %edx,%ebx movl %ebx,-88(%ebp) movl -4(%ebp),%ebx movl -32(%ebp),%ecx movl %ecx,-92(%ebp) movl %ebx,%edi subl %ecx,%edi subl %eax,%edi movl %edi,-84(%ebp) cmpl %ebx,%ecx ja L334 jmp L281 .align 4,0x90 .align 2,0x90 L285: decl -52(%ebp) movl -88(%ebp),%ebx movl -44(%ebp),%edx movl %edx,-92(%ebp) cmpl %edx,%ebx setb %al andl $255,%eax subl %edx,%ebx movl %ebx,-88(%ebp) movl %esi,%ebx movl -48(%ebp),%ecx movl %ecx,-92(%ebp) movl %ebx,%edi subl %ecx,%edi subl %eax,%edi movl %edi,-84(%ebp) cmpl %ebx,%ecx jbe L281 L334: movl $1,%eax jmp L282 .align 4,0x90 L281: cmpl %ebx,-92(%ebp) jae L282 xorl %eax,%eax L282: movl -84(%ebp),%esi testl %eax,%eax jne L274 testl %esi,%esi jne L285 L274: movl $0,-4(%ebp) movl -72(%ebp),%edx movl -80(%ebp),%ecx leal -8(%ecx,%edx),%edx movl %edx,-88(%ebp) movl -60(%ebp),%edi addl %ecx,%edi movl %edi,-76(%ebp) movl -16(%ebp),%esi addl $-2,%esi je L287 .align 2,0x90 L290: movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-76(%ebp) movl -76(%ebp),%edx movl (%edx),%edx pushl %edx movl -52(%ebp),%ecx pushl %ecx call _mulul3 movl %eax,-84(%ebp) addl %ebx,-84(%ebp) cmpl %ebx,-84(%ebp) jae L289 incl -4(%ebp) L289: movl -84(%ebp),%edi movl %edi,-92(%ebp) addl $-4,-88(%ebp) addl $12,%esp movl -88(%ebp),%edx movl (%edx),%ebx cmpl %edi,%ebx setb %al andl $255,%eax subl %edi,%ebx movl %ebx,(%edx) addl %eax,-4(%ebp) decl %esi jne L290 L287: movl -72(%ebp),%ecx movl -4(%ecx),%eax cmpl %eax,-4(%ebp) jbe L291 xorl %eax,%eax decl -52(%ebp) movl -80(%ebp),%edi leal -8(%edi,%ecx),%edi movl %edi,-88(%ebp) movl -60(%ebp),%edx addl -80(%ebp),%edx movl %edx,-76(%ebp) movl -16(%ebp),%esi addl $-2,%esi je L291 .align 2,0x90 L296: movl -88(%ebp),%ecx addl $-4,%ecx movl %ecx,-92(%ebp) movl %ecx,-88(%ebp) movl (%ecx),%ebx addl $-4,-76(%ebp) movl %ebx,%edx movl -76(%ebp),%edi addl (%edi),%edx movl %edx,-84(%ebp) cmpl %ebx,%edx jae L294 addl %eax,%edx movl %edx,-84(%ebp) movl $1,%eax movl %edx,(%ecx) jmp L292 .align 4,0x90 L294: addl %eax,-84(%ebp) cmpl %eax,-84(%ebp) setb %al andl $255,%eax movl -84(%ebp),%edi movl -92(%ebp),%ecx movl %edi,(%ecx) L292: decl %esi jne L296 L291: movl -52(%ebp),%ecx movl -72(%ebp),%edx movl %ecx,-4(%edx) decl -24(%ebp) jne L297 L271: movl _avma ,%edi movl %edi,-88(%ebp) cmpl $-1,16(%ebp) je L298 movl -20(%ebp),%ebx addl $2,%ebx movl -56(%ebp),%edx leal (%edx,%ebx,4),%edx movl %edx,-72(%ebp) movl -56(%ebp),%ecx cmpl $0,4(%ecx) je L299 movl -20(%ebp),%ebx addl $3,%ebx jmp L300 .align 4,0x90 L299: cmpl $0,-20(%ebp) jne L300 movl $0,-40(%ebp) L300: pushl %ebx call _cgeti movl %eax,-64(%ebp) leal (%eax,%ebx,4),%eax addl $4,%esp leal -2(%ebx),%esi testl %esi,%esi je L303 .align 2,0x90 L304: addl $-4,%eax addl $-4,-72(%ebp) movl -72(%ebp),%edi movl (%edi),%edi movl %edi,(%eax) decl %esi jne L304 L303: cmpl $2,%ebx ja L305 movl -64(%ebp),%edx movl $2,4(%edx) jmp L298 .align 4,0x90 L305: movl -64(%ebp),%ecx movl (%ecx),%edi movl %edi,4(%ecx) movb -40(%ebp),%dl movb %dl,7(%ecx) L298: cmpl $0,16(%ebp) je L307 movl -20(%ebp),%esi addl $2,%esi cmpl %esi,-12(%ebp) jle L309 movl -56(%ebp),%ecx cmpl $0,(%ecx,%esi,4) jne L309 .align 2,0x90 L310: incl %esi cmpl %esi,-12(%ebp) jle L309 movl -56(%ebp),%edi cmpl $0,(%edi,%esi,4) je L310 L309: cmpl %esi,-12(%ebp) jne L312 movl _gzero ,%edx pushl %edx call _icopy movl %eax,-68(%ebp) addl $4,%esp jmp L307 .align 4,0x90 L312: movl -12(%ebp),%eax subl %esi,%eax addl $2,%eax pushl %eax call _cgeti movl %eax,-68(%ebp) movl (%eax),%ecx movl %ecx,4(%eax) addl $4,%esp cmpl $0,-28(%ebp) jne L314 movl $2,-24(%ebp) cmpl %esi,-12(%ebp) jle L319 .align 2,0x90 L318: movl -56(%ebp),%edi movl (%edi,%esi,4),%ecx movl -24(%ebp),%edi movl -68(%ebp),%edx movl %ecx,(%edx,%edi,4) incl %esi incl %edi movl %edi,-24(%ebp) cmpl %esi,-12(%ebp) jg L318 jmp L319 .align 4,0x90 L314: movl $0,-4(%ebp) movl -56(%ebp),%edi movl (%edi,%esi,4),%ebx incl %esi movl $32,%eax subl -28(%ebp),%eax movl %ebx,%edi movl %eax,%ecx sall %cl,%edi movl %edi,%eax movl %eax,-4(%ebp) movl -28(%ebp),%ecx shrl %cl,%ebx movl %ebx,-92(%ebp) movl %eax,-32(%ebp) testl %ebx,%ebx je L320 movl -68(%ebp),%edi movl %ebx,8(%edi) movl $1,%eax jmp L321 .align 4,0x90 L320: movl -68(%ebp),%edx movl (%edx),%ecx decl %ecx movl %ecx,4(%edx) addl $4,%edx movl %edx,-68(%ebp) addl $4,_avma movl -68(%ebp),%edx movl (%edx),%edi movl %edi,4(%edx) xorl %eax,%eax L321: addl $2,%eax movl %eax,-24(%ebp) cmpl %esi,-12(%ebp) jle L319 movl $32,%edx subl -28(%ebp),%edx movl %edx,-84(%ebp) .align 2,0x90 L325: movl -56(%ebp),%ecx movl (%ecx,%esi,4),%ebx movl %ebx,%edi movl -84(%ebp),%ecx sall %cl,%edi movl %edi,-92(%ebp) movl %edi,-4(%ebp) movl %ebx,%eax movl -28(%ebp),%ecx shrl %cl,%eax addl -32(%ebp),%eax movl -24(%ebp),%edi movl -68(%ebp),%edx movl %eax,(%edx,%edi,4) movl -92(%ebp),%ecx movl %ecx,-32(%ebp) incl %esi incl %edi movl %edi,-24(%ebp) cmpl %esi,-12(%ebp) jg L325 L319: movb -36(%ebp),%dl movl -68(%ebp),%ecx movb %dl,7(%ecx) L307: cmpl $-1,16(%ebp) jne L326 movl -68(%ebp),%edi pushl %edi movl -88(%ebp),%edx pushl %edx movl -8(%ebp),%ecx pushl %ecx jmp L332 .align 4,0x90 L326: cmpl $0,16(%ebp) je L327 pushl $0 movl -88(%ebp),%edi pushl %edi movl -8(%ebp),%edx pushl %edx call _gerepile andb $252,%al movl -68(%ebp),%edi addl %eax,%edi movl 16(%ebp),%ecx movl %edi,(%ecx) addl -64(%ebp),%eax jmp L328 .align 4,0x90 L327: movl -64(%ebp),%edx pushl %edx movl -88(%ebp),%ecx pushl %ecx movl -8(%ebp),%edi pushl %edi L332: call _gerepile L328: leal -104(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .comm _in_saved_avma ,4 gcl-2.6.14/mp/lo-rios1.s0000644000175000017500000000105714360276512013243 0ustar cammcamm##### Flush the instruction cache. Necessary for loading. .toc #T.myics.s:.tc myics.s[tc],myics.s[rw] .globl myics[ds] .csect myics[ds] .long .myics[PR] .long TOC[tc0] .long 0 .toc T.myics: .tc .myics[tc],myics[ds] .globl .myics[PR] .csect .myics[PR] dcs ics brl #### Allocate lots of space for toc entries during dynamic loading. .globl akcltoc[ds] .csect akcltoc[ds] .long .akcltoc[tc] .csect .akcltoc[tc] .space 24000 .globl toc_start[ds] .csect toc_start[ds] .long TOC[tc0] gcl-2.6.14/mp/mp2.c0000755000175000017500000002312314360276512012255 0ustar cammcamm /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~ ~*/ /*~ OPERATIONS DE BASE (NOYAU) ~*/ /*~ Functions which can be efficient in plain C ~*/ /*~ ~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ #include "config.h" #include "genpari.h" #include "arith.h" /* -2147483648 */ unsigned plong MOST_NEGS[3]={0x01ff0003, 0xff000003,1<<31}; /* +2147483648 */ unsigned plong ABS_MOST_NEGS[3]={0x01ff0003, 0x01000003,1<<31}; GEN stoi(x) plong x; { GEN y; if(!x) return gzero; y=cgeti(3); if(x>0) {y[1]=0x1000003;y[2]=x;} else{y[1]=0xff000003;y[2]= -x;} return y; } GEN cgetg(x,y) plong x,y; { unsigned plong p1; GEN z; p1=avma-(((unsigned short)x)<<2);if(p13) err(affer2); p1=x[2];if(p1>=0x80000000) err(affer2); p2=(s>0)?p1:(-((plong)p1));return p2; } void affsi(s,x) plong s; GEN x; { plong lx; if(!s) {x[1]=2;return;} lx=lg(x);if(lx<3) err(affer1); if(s>0) {x[1]=0x1000003;x[2]=s;} else { s = -s; if (s < 0) /* s = -2^31 */ { if(lx<4) err(affer1); x[1]=0xff000004; x[2]= 0; x[3]= 1; } else {x[1]=0xff000003;x[2]= s;} } } void affii(x,y) GEN x,y; { plong lx=lgef(x),i; if(x==y) return; if(lg(y)0) {t[1]=0x1000003;t[2]=x;} else {t[1]=0xff000003;t[2]= -x;} return shifti(t,y); } GEN shifti(x,n) GEN x; plong n; { plong lx=lgef(x),i,s=signe(x),d,m,p1,p2,k; GEN y; TEMPVARS2 ulong hiremainder; if(!s) return gzero; if(!n) return icopy(x); if(n>0) { d=n>>5;m=n&31; if(m) { p1=shiftl(x[2],m);p2=hiremainder;k=0; if(p2) { y=cgeti(lx+d+1);for(i=lx+1;i<=lx+d;i++) y[i]=0; for(i=lx;i>=4;i--) {y[i]=shiftl(x[i-1],m)+k;k=hiremainder;} y[3]=p1+k;y[2]=p2; } else { y=cgeti(lx+d);for(i=lx;i=3;i--) {y[i]=shiftl(x[i],m)+k;k=hiremainder;} y[2]=p1+k; } } else { y=cgeti(lx+d);for(i=lx;i=2;i--) y[i]=x[i]; } } else { n= -n;d=n>>5;m=n&31;if(lx>5;m=e&31;if(d>=lx-2) err(truer2); y=cgeti(d+3);y[1]=y[0];setsigne(y,s); if(m==31) for(i=2;i<=d+2;i++) y[i]=x[i]; else { m++;p1=0; for(i=2;i<=d+2;i++) { p2=shiftl(x[i],m);y[i]=hiremainder+p1;p1=p2; } } return y; } GEN mpent(x) GEN x; { plong e,i,lx=lg(x),m,f,p1,p2; unsigned plong d;ulong hiremainder; GEN y,z; TEMPVARS2 if(typ(x)==1) return icopy(x); if(signe(x)>=0) return mptrunc(x); e=expo(x);if(e<0) {y=cgeti(3);y[2]=1;y[1]=0xff000003;return y;} d=e>>5;m=e&31;if(d>=lx-2) err(truer2); y=cgeti(d+3);y[1]=0xff000003+d; if(m==31) { for(i=2;i<=d+2;i++) y[i]=x[i]; while((i=2)&&(y[i]==0xffffffff);i--) y[i]=0; if(i>=2) y[i]++; else { z=y;y=cgeti(1);*y=(*z)+1;y[1]=z[1]+1; } } return y; } int cmpsi(x,y) plong x; GEN y; { ulong p; if(!x) return -signe(y); if(x>0) { if(signe(y)<=0) return 1; if(lgef(y)>3) return -1; p=y[2];if(p==x) return 0; return (p<(ulong)x) ? 1 : -1; } else { /* x <= 0 */ if(signe(y)>=0) return -1; if(lgef(y)>3) { if (-x < 0) { /* x = -2^31 */ if (lgef(y)==4 && y[2] == 0 && y[3] == 1) return 0; else return 1;}} p=y[2];if(p== -x) return 0; return (p<(ulong)(-x)) ? -1 : 1; } } int cmpii(x,y) GEN x,y; { plong sx=signe(x),sy=signe(y),lx,ly,i; if(sxsy) return 1; if(!sx) return 0; lx=lgef(x);ly=lgef(y); if(lx>ly) return sx; if(lx(ulong)y[i]) ? sx : -sx; } GEN addss(x,y) plong x,y; { plong t[3]; if(!x) return stoi(y); t[0]=0x1010003; if(x>0) {t[1]=0x1000003;t[2]=x;} else {t[1]=0xff000003;t[2]= -x;} return addsi(y,t); } GEN subii(x,y) GEN x,y; { plong s=signe(y); GEN z; if(x==y) return gzero; setsigne(y,-s);z=addii(x,y);setsigne(y,s); return z; } GEN subsi(x,y) plong x; GEN y; { plong s=signe(y); GEN z; setsigne(y,-s);z=addsi(x,y);setsigne(y,s);return z; } GEN subss(x,y) plong x,y; { if (y == (1<<31)) return addsi(x,ABS_MOST_NEGS); return addss(-y,x); } GEN convi(x) GEN x; { plong lx,av=avma,lz; GEN z,p1,p2; if(!signe(x)) { z=cgeti(3);z[1]= -1;z[2]=0;avma=av;return z+3; } p1=absi(x);lx=lgef(p1);lz=((lx-2)*15)/14+3;z=cgeti(lz);z[1]= -1; for(p2=z+2;signe(p1);p2++) *p2=divisii(p1,1000000000,p1); avma=av;return p2; } void mulsii(x,y,z) plong x; GEN y,z; { plong av=avma; GEN p1; p1=mulsi(x,y);affii(p1,z);avma=av; } void addsii(x,y,z) plong x; GEN y,z; { plong av=avma; GEN p1; p1=addsi(x,y);affii(p1,z);avma=av; } plong divisii(x,y,z) plong y; GEN x,z; { plong av=avma,k; GEN p1; p1=divis(x,y);affii(p1,z);avma=av; k=hiremainder;return k; } plong vals(x) plong x; { unsigned short int y,z; int s; if(!x) return -1; y=x;if(!y) {s=16;y=((ulong)x)>>16;} else s=0; z=y&255;if(!z) {s+=8;z=y>>8;} y=z&15;if(!y) {s+=4;y=z>>4;} z=y&3;if(!z) {s+=2;z=y>>2;} return (z&1) ? s : s+1; } plong vali(x) GEN x; { plong i,lx=lgef(x); if(!signe(x)) return -1; for(i=lx-1;(i>=2)&&(!x[i]);i--); return ((lx-1-i)<<5)+vals(x[i]); } GEN dvmdss(x,y,z) plong x,y; GEN *z; { GEN p1; p1=divss(x,y);*z=stoi(hiremainder); return p1; } GEN dvmdsi(x,y,z) plong x; GEN y,*z; { GEN p1; p1=divsi(x,y);*z=stoi(hiremainder); return p1; } GEN dvmdis(x,y,z) plong y; GEN x,*z; { GEN p1; p1=divis(x,y);*z=stoi(hiremainder); return p1; } GEN ressi(x,y) plong x; GEN y; { divsi(x,y);return stoi(hiremainder); } GEN modsi(x,y) plong x; GEN y; { plong s; GEN p1; divsi(x,y); if(!hiremainder) return gzero; if(x>0) return stoi(hiremainder); else { s=signe(y);setsigne(y,1);p1=addsi(hiremainder,y); setsigne(y,s);return p1; } } GEN modis(x,y) plong y; GEN x; { divis(x,y);if(!hiremainder) return gzero; return (signe(x)>0) ? stoi(hiremainder) : stoi(abs(y)+hiremainder); } GEN resis(x,y) plong y; GEN x; { divis(x,y);return stoi(hiremainder); } GEN modii(x,y) GEN x,y; { plong av=avma,tetpil; GEN p1; p1=dvmdii(x,y,-1); if(signe(p1)>=0) return p1; tetpil=avma;p1=(signe(y)>0) ? addii(p1,y) : subii(p1,y); return gerepile(av,tetpil,p1); } int mpdivis(x,y,z) GEN x,y,z; { plong av=avma; GEN p1,p2; p1=dvmdii(x,y,&p2); if(signe(p2)) {avma=av;return 0;} affii(p1,z);avma=av;return 1; } int divise(x,y) GEN x,y; { plong av=avma; GEN p1; p1=dvmdii(x,y,-1);avma=av; return signe(p1) ? 0 : 1; } GEN gerepile(l,p,q) GEN l,p,q; { plong av,declg,tl; GEN ll,pp,l1,l2,l3; declg=(plong)l-(plong)p;if(declg<=0) return q; for(ll=l,pp=p;pp>(GEN)avma;) *--ll= *--pp; av=(plong)ll; while((llll) l3=l2;} else {ll+=lg(ll);l3=ll;} for(;l2=(GEN)avma)) { if(l1=(GEN)avma))) { avma=av;return q+(declg>>2); } else {avma=av;return q;} } void cgiv(x) GEN x; { plong p; if((p=pere(x))==255) return; if((x!=(GEN)avma)||(p>1)) {setpere(x,p-1);return;} do x+=lg(x);while(!pere(x)); avma=(plong)x; return; } gcl-2.6.14/mp/gcclab0000755000175000017500000000064314360276512012553 0ustar cammcamm#!/bin/sh TEMP=/tmp/gcc$$tmp BIL="$@" while [ $# -gt 0 ] do case "$1" in -S) Sflag=1;; -o) OUT=$2; shift ;; *.c) FILE=$1;; esac shift done FILE=`echo "${FILE}" | sed -e 's:\.c$::g'` gcc -o ${TEMP}.s ${BIL} -S cat ${TEMP}.s | awk -f gcclab.awk > ${TEMP}1.s if [ "${Sflag}" = "1" ] ; then mv ${TEMP}1.s ${FILE}.s else as -o ${FILE}.o ${TEMP}1.s fi rm -f ${TEMP}.s ${TEMP}1.s gcl-2.6.14/mp/mpi.c0000755000175000017500000003553514360276512012356 0ustar cammcamm /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~ ~*/ /*~ OPERATIONS DE BASE (NOYAU) ~*/ /*~ ~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /* This file was modified by W. Schelter to be suitable for optimization and inlining of assembler for maximum speed */ #include "config.h" #include "genpari.h" #include "arith.h" GEN mulsi(x,y) plong x; GEN y; { TEMPVARS plong s=signe(y),ly=lgef(y),i; GEN z,zp,yp; ulong hiremainder; if((!x)||(!s)) return gzero; if(x<0) {s= -s; x= -x; if (x < 0) /* -2^31 */ {return mulii(stoi(1<<31),y);} } z=cgeti(ly+1); hiremainder=0; MP_START_LOW(yp,y,ly); MP_START_LOW(zp,z,ly+1); i = MP_COUNT_LG(ly); WHILE_COUNT(--i) { MP_NEXT_UP(zp) = addmul(x,MP_NEXT_UP(yp));} if(hiremainder) {MP_NEXT_UP(zp)=hiremainder; setlgef(z,ly+1);} else {avma+=4;z[1]=z[0]-1;z++;setlgef(z,ly);} setsigne(z,s);return z; } int expi(x) GEN x; { plong lx=x[1]&0xffff; return lx==2 ? -8388608 : ((lx-2)<<5)-bfffo(x[2])-1; } GEN addsi(x,y) plong x; GEN y; { plong sx,sy,ly,p,i; ulong overflow; GEN z; TEMPVARS if(!x) return icopy(y); sy=signe(y);if(!sy) return stoi(x); if(x<0) {sx= -1; x= -x; if (x < 0) /* x=-2^31 */ return addii(MOST_NEGS,y); } else sx=1; ly=lgef(y); if(sx==sy) { p=addll(x,y[ly-1]); if(overflow) { z=cgeti(ly+1);z[ly]=p; for(i=ly-1;(i>2)&&(y[i-1]==0xffffffff);i--) z[i]=0; if(i>2) { z[i]=y[i-1]+1;i--;while(i>=3) {z[i]=y[i-1];i--;} z[2]=z[1]=z[0]-1;z++;avma+=4; } else {z[2]=1;z[1]=z[0];} } else { z=cgeti(ly);z[ly-1]=p;for(i=1;i(ulong)x) { z=cgeti(3);z[1]=(sy<<24)+3;z[2]=y[2]-x;return z; } if(y[2]==x) return gzero; z=cgeti(3);z[1]=((-sy)<<24)+3;z[2]=x-y[2];return z; } p=subll(y[ly-1],x); if(overflow) { z=cgeti(ly);z[ly-1]=p; for(i=ly-2;!(y[i]);i--) z[i]=0xffffffff; z[i]=y[i]-1; if((i>2)||z[i]) {i--;for(;i>=1;i--) z[i]=y[i];} else { z[2]=z[1]=z[0]-1;z++;avma+=4;setsigne(z,sy); } } else { z=cgeti(ly);z[ly-1]=p;for(i=1;i=ly so sx==0 ==> sy==0 */ if (0 == (sy=signe(y))) return icopy(x); sx = signe(x); if(sx==sy) { z=cgeti(lx+1);overflow=0; MP_START_LOW(zp,z,lx+1); MP_START_LOW(xp,x,lx); MP_START_LOW(yp,y,ly); #ifdef QUICK_LOOP i = ly - 2; QUICK_LOOP(i,ADDXCC); #else i = MP_COUNT_LG(ly); WHILE_COUNT(--i) {ADDLLX(MP_NEXT_UP(xp),MP_NEXT_UP(yp),MP_NEXT_UP(zp));} #endif if(overflow) { GEN xhigh = &MP_HIGH(x,lx); again: { GEN xpp = &MP_NEXT_UP(xp); if (xpp >= xhigh) { if (*xpp == 0xffffffff) { MP_NEXT_UP(zp)=0; goto again;} else { MP_NEXT_UP(zp) = *xpp + 1; while ((xpp = &MP_NEXT_UP(xp)) >= xhigh) { MP_NEXT_UP(zp) = *xpp ;} z[1]=z[0]-1;z[2]=x[1];z++;avma+=4;}} else {z[2]=1;z[1]=x[1]+1;} }} else { j = COUNT(lx - ly); WHILE_COUNT( --j) { MP_NEXT_UP(zp) = MP_NEXT_UP(xp);} z[1]=z[0]-1;z[2]=x[1];z++;avma+=4; } } else { if(lx==ly) /* we have to compare x and y */ { j = MP_COUNT_LG(lx); MP_START_HIGH(xp,x,lx); MP_START_HIGH(yp,y,lx); WHILE_COUNT(--j) { ulong tx = MP_NEXT_DOWN(xp); ulong ty = MP_NEXT_DOWN(yp); if ( ty > tx) {z=x;x=y;y=z;sz=sx;sx=sy;sy=sz; goto DIFFER;} else if ( tx > ty) {goto DIFFER;}} SAME: return gzero; DIFFER:; } z=cgeti(lx);overflow=0; MP_START_LOW(xp,x,lx);MP_START_LOW(yp,y,ly);MP_START_LOW(zp,z,lx); i = MP_COUNT_LG(ly); #ifdef QUICK_LOOP i = ly - 2; QUICK_LOOP(i,SUBXCC); #else i = MP_COUNT_LG(ly); WHILE_COUNT(--i) {SUBLLX(MP_NEXT_UP(xp),MP_NEXT_UP(yp),MP_NEXT_UP(zp));} #endif if(overflow) { ulong tx ; while((tx=MP_NEXT_UP(xp)) == 0) MP_NEXT_UP(zp) = 0xffffffff; if (xp >= (xhigh = &MP_HIGH(x,lx))) { MP_NEXT_UP(zp) = tx -1; while ((xpp = &MP_NEXT_UP(xp)) >= xhigh) { MP_NEXT_UP(zp) = *xpp;}} } else { i = COUNT(lx - ly); WHILE_COUNT(--i) MP_NEXT_UP(zp) = MP_NEXT_UP(xp); } if(z[2]) z[1]=x[1]; else { zp = &z[3]; while (*zp ==0){zp++;} /* x was != y by above */ zp -= 2; i = zp - z; zp[1] = (zp[0] = z[0]-i); z = zp; setsigne(z,sx); avma+=(i<<2); } } return z; } GEN mulss(x,y) plong x,y; { plong s,p1; GEN z; ulong hiremainder; if((!x)||(!y)) return gzero; s=1; if(x<0) {s= -1; x= -x; if (x<0) return mulsi(y,stoi(x)); } if(y<0) {s= -s; y= -y; if(y<0) return mulsi((s > 0 ? x : -x),ABS_MOST_NEGS); } p1=mulll(x,y); if(hiremainder) {z=cgeti(4);z[2]=hiremainder;z[3]=p1;} else {z=cgeti(3);z[2]=p1;} z[1]=z[0];setsigne(z,s);return z; } GEN mulii(x,y) GEN x,y; { plong i,j,lx=lgef(x),ly=lgef(y),sx,sy,lz,p1,p2; GEN z; TEMPVARS GEN zz,yy,zp,xx; GEN ylow; ulong hiremainder; ulong overflow; sx=signe(x);if(!sx) return gzero; sy=signe(y);if(!sy) return gzero; if(sy<0) sx= -sx; if(lx>ly) {z=x;x=y;y=z;lz=lx;lx=ly;ly=lz;} lz=lx+ly-2;if(lz>=0x10000) err(muler1); z=cgeti(lz);z[1]=z[0];setsigne(z,sx); MP_START_LOW(xx,x,lx); p1 = MP_NEXT_UP(xx); hiremainder=0; i = COUNT(ly-2); MP_START_LOW(yy,y,ly); MP_START_LOW(zz,z,lz); WHILE_COUNT (--i) { MP_NEXT_UP(zz) = addmul(p1,MP_NEXT_UP(yy));} MP_NEXT_UP(zz) = hiremainder; /* restart zz one above bottom */ MP_START_LOW(zz,z,lz); MP_START_LOW(ylow,y,ly); ly = COUNT(ly - MP_CODE_WORDS); lx -= MP_CODE_WORDS; while (--lx > 0) /* one less iteration first term of x, already used */ { plong tem; register plong p11; p11 = MP_NEXT_UP(xx); i = ly; yy = ylow; zp = &MP_NEXT_UP(zz); /* *zp = second from low word of z first time through */ tem = 0; /* ZerO is just a 68k kludge to getit to keep 0 in a reg during this loop*/ #undef ZERO #define ZERO ZerO { int ZerO = 0; WHILE_COUNT(--i) { p2 = MP_NEXT_UP(yy); p2 = mulul(p2,p11,hiremainder); MP_NEXT_UP(zp); p2 = add_carry(p2,*zp,hiremainder); p2 = add_carry(p2,tem,hiremainder); *zp = p2; tem = hiremainder; } } MP_NEXT_UP(zp) = hiremainder; #undef ZERO #define ZERO 0 } if(!MP_HIGH(z,lz)) { /* shift header one along decreasing lg and lgef */ z[2]=z[1]-1;z[1]=z[0]-1;z++;avma+=4; } return z; } GEN confrac(x) GEN x; { plong lx=lg(x),ex= -expo(x)-1,ex1,av=avma,ly,ey; plong lr,nbdec,k,i,j; ulong hiremainder; GEN y,res; TEMPVARS ey=((lx-2)<<5)+ex;ly=(ey+63)>>5;y=cgeti(ly);ex1=ex>>5; /* 95 dans mp.s faux? */ for(i=0;i=0;i--) y[i]=addmul(y[i],1000000000); res[j]=hiremainder; } avma=av;return res; } /* x/y : uses hiremainder for return */ GEN divss(x,y) plong x,y; { plong p1; if(!y) err(diver1); if (x == (1<<31)) return divis(stoi(x),y); hiremainder=0;p1=divll((ulong)abs(x),(ulong)abs(y)); if(y<0) {hiremainder= -((plong)hiremainder);p1= -p1;} if(x<0) p1= -p1; return stoi(p1); } GEN modss(x,y) plong x,y; { plong y1; ulong hiremainder; if(!y) err(moder1); if (x == (1<<31)) return modis(stoi(x),y); hiremainder=0;divll(abs(x),y1=abs(y)); if(!hiremainder) return gzero; return (((plong)hiremainder)<0) ? stoi(y1-hiremainder) : stoi(hiremainder); } GEN resss(x,y) plong x,y; { ulong hiremainder; if(!y) err(reser1); hiremainder=0;divll(abs(x),abs(y)); return (y<0) ? stoi(-((plong)hiremainder)) : stoi(hiremainder); } /* uses hiremainder for return */ GEN divsi(x,y) plong x; GEN y; { plong s=signe(y),ly=lgef(y),p1; if(!s) err(diver2); if((!x)||(ly>3)||(y[2]<0)) {hiremainder=x;return gzero;} if (x== 1<<31) return divii(stoi(x),y); hiremainder=0;p1=divll(abs(x),y[2]); if(signe(y)<0) {hiremainder= -((plong)hiremainder);p1= -p1;} if(x<0) p1= -p1; return stoi(p1); } /* this uses the GLOBAL hiremainder to return its remainder We cannot make it a local. */ GEN divis(y,x) plong x; GEN y; { ulong hi; plong s=signe(y),ly=lgef(y),i,d; GEN z; if(!x) err(diver4); if(!s) {hiremainder=0;return gzero;} if(x<0) {s= -s;x= -x; if (x < 0) return divii(y,stoi(x)); } if((ulong)x>(ulong)y[2]) { if(ly==3) {hiremainder=itos(y);return gzero;} else {z=cgeti(ly-1);d=1;hi=y[2];} } else {z=cgeti(ly);d=0;hi=0;} for(i=d+2;i (ulong)MP_HIGH(x,lx)) { lgp1=lx-1; hiremainder= MP_NEXT_DOWN(xp);} else { lgp1=lx; hiremainder=0;} p1 = cgeti(lgp1); i = MP_COUNT_LG(lgp1); MP_START_HIGH(p1p,p1,lgp1); WHILE_COUNT(--i) { MP_NEXT_DOWN(p1p) = divll(MP_NEXT_DOWN(xp),si);} if((plong)z==0xffffffff) { avma=av;if(!hiremainder) return gzero; p2=cgeti(3);p2[1]=(sx<<24)+3;p2[2]=hiremainder;return p2; } if(lgp1!= 2) {p1[1]=p1[0];setsigne(p1,sy);} else {avma=av;p1=gzero;} if(z==0) return p1; if(!hiremainder) *z=gzero; else {p2=cgeti(3);p2[1]=(sx<<24)+3;p2[2]=hiremainder;*z=p2;} return p1; } else { p1=cgeti(lx); sh=bfffo(y[2]); if(sh) { GEN p2p,yp; MP_START_HIGH(yp,y,ly); p2=cgeti(ly); k=shiftl(MP_NEXT_DOWN(yp),sh); MP_START_HIGH(p2p,p2,ly); i = MP_COUNT_LG(ly-1); WHILE_COUNT(--i) { k1=shiftl(MP_NEXT_DOWN(yp),sh); MP_NEXT_DOWN(p2p) = k + hiremainder; k = k1; } MP_NEXT_DOWN(p2p) = k ; k=0; MP_START_HIGH(xp,x,lx); MP_START_HIGH(p1p,p1,lx); MP_NEXT_UP(p1p) ; /* yes go out of range !! */ i = MP_COUNT_LG(lx); WHILE_COUNT (--i) { k1 = shiftl(MP_NEXT_DOWN(xp),sh); MP_NEXT_DOWN(p1p) = k + hiremainder; k = k1; } MP_NEXT_DOWN(p1p) = k; } else { MP_START_HIGH(xp,x,lx); MP_START_HIGH(p1p,p1,lx); MP_NEXT_UP(p1p) ; /* yes go out of range !! */ MP_NEXT_DOWN(p1p) = 0; j = MP_COUNT_LG(lx); WHILE_COUNT (-- j) { MP_NEXT_DOWN(p1p) = MP_NEXT_DOWN(xp);} p2 = y;} si=p2[2];saux=p2[3]; MP_START_HIGH(p1p,p1,lx); MP_NEXT_UP(p1p) ; /* out of bound */ i = COUNT(lz+1); WHILE_COUNT(--i) { GEN pp; if(MP_NEXT_DOWN(p1p)==si) { /* Using fact that next_down does post increment */ qp=0xffffffff;k=addll(si,*p1p); } else { hiremainder=p1p[-1];qp=divll(*p1p,si); overflow=0;k=hiremainder; } if(!overflow) { /* k1=mulll(qp,saux);k3=subll(k1,p1p[1]);k+=overflow; flk4=((ulong)hiremainder>(ulong)k);k4=subll(hiremainder,k); while(flk4) {qp--;k3=subll(k3,saux); k4-=overflow;flk4=((ulong)k4>(ulong)si); k4=subll(k4,si);} */ k1=mulll(qp,saux);k3=subll(k1,p1p[1]); k4=subllx(hiremainder,k); while((!overflow)&&k4) {qp--;k3=subll(k3,saux);k4=subllx(k4,si);} } hiremainder=0; j = MP_COUNT_LG(ly); MP_START_LOW(pp,p1p,ly-2); MP_START_LOW(p2p,p2,ly); WHILE_COUNT(--j) { GEN ppp; k1=addmul(qp,MP_NEXT_UP(p2p)); ppp = &MP_NEXT_UP(pp); *ppp =subll(*ppp,k1);hiremainder+=overflow; } if((ulong)p1p[-1]<(ulong)hiremainder) { overflow=0;qp--; j = MP_COUNT_LG(ly); MP_START_LOW(pp,p1p,ly-2); MP_START_LOW(p2p,p2,ly); WHILE_COUNT(--j){ GEN ppp = &MP_NEXT_UP(pp); ADDLLX(*ppp,MP_NEXT_UP(p2p),*ppp);} } p1p[-1] = qp; } av1=avma; if((plong)z!=0xffffffff) {ulong lgp3 = lz + 2; MP_START_LOW(p1p,p1,lgp3); if (p1[1]) {lgp3++;} else if (lz==0) sy=0; p3 = cgeti(lgp3); MP_START_LOW(pp,p3,lgp3); j = MP_COUNT_LG(lgp3); WHILE_COUNT(--j) {MP_NEXT_UP(pp) = MP_NEXT_UP(p1p) ;} if(lgp3<3) {p3[1]=2;} else {p3[1]=p3[0];setsigne(p3,sy);} } if(z!=0) { for(j=lz+2;(j>2;*z=p4+dec;return p3+dec; } } /* machines which provide an inline version of mulul need to provide a function for calls where that inlining can't take place */ #ifdef NEED_MULUL3 ulong mulul3(a,b,c) ulong a,b,*c; { return mulul(a,b,*c);} #endif #ifdef NEED_DIVUL3 ulong divul3(a,b,c) ulong a,b,*c; { return divul(a,b,*c);} #endif /* ;;- Local variables: ;;- version-control:t ;;- End: */ gcl-2.6.14/mp/mpi-386_no_under.s0000644000175000017500000010456414360276512014601 0ustar cammcamm .file "mpi.c" .version "01.01" gcc2_compiled.: .text .align 16 .globl mulsi .type mulsi,@function mulsi: pushl %ebp movl %esp,%ebp subl $20,%esp pushl %edi pushl %esi pushl %ebx movl 12(%ebp),%ebx movl 4(%ebx),%edx sarl $24,%edx movl %edx,-8(%ebp) movzwl 4(%ebx),%ecx movl %ecx,-12(%ebp) cmpl $0,8(%ebp) je .L3 testl %edx,%edx jne .L2 .L3: movl gzero,%eax jmp .L14 .align 16 .L2: cmpl $0,8(%ebp) jge .L4 negl -8(%ebp) negl 8(%ebp) jns .L4 pushl %ebx pushl $-2147483648 call stoi addl $4,%esp pushl %eax call mulii jmp .L14 .align 16 .L4: movl -12(%ebp),%eax incl %eax pushl %eax call cgeti movl %eax,-16(%ebp) movl $0,-4(%ebp) movl -12(%ebp),%edx leal 0(,%edx,4),%eax addl %eax,%ebx movl %ebx,-20(%ebp) movl -16(%ebp),%ecx leal 4(%eax,%ecx),%esi addl $4,%esp movl %edx,%edi addl $-2,%edi je .L7 .align 4 .L8: addl $-4,%esi movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-20(%ebp) movl -20(%ebp),%edx movl (%edx),%eax pushl %eax movl 8(%ebp),%ecx pushl %ecx call mulul3 addl %ebx,%eax addl $12,%esp cmpl %ebx,%eax jae .L10 incl -4(%ebp) .L10: movl %eax,(%esi) decl %edi jne .L8 .L7: cmpl $0,-4(%ebp) je .L12 movl -4(%ebp),%eax movl %eax,-4(%esi) movl -16(%ebp),%edx movl 4(%edx),%eax andl $-65536,%eax movl -12(%ebp),%ecx leal 1(%ecx,%eax),%eax movl %eax,4(%edx) jmp .L13 .align 16 .L12: addl $4,avma movl -16(%ebp),%edx movl (%edx),%ecx decl %ecx movl %ecx,4(%edx) addl $4,%edx movl %edx,-16(%ebp) movw -12(%ebp),%cx movw %cx,4(%edx) .L13: movb -8(%ebp),%dl movl -16(%ebp),%ecx movb %dl,7(%ecx) movl -16(%ebp),%eax .L14: leal -32(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe1: .size mulsi,.Lfe1-mulsi .align 16 .globl expi .type expi,@function expi: pushl %ebp movl %esp,%ebp pushl %ebx movl 8(%ebp),%eax movzwl 4(%eax),%ebx cmpl $2,%ebx je .L16 movl 8(%eax),%eax pushl %eax call bfffo movl %eax,%edx leal -2(%ebx),%eax sall $5,%eax subl %edx,%eax decl %eax jmp .L17 .align 16 .L16: movl $-8388608,%eax .L17: movl -4(%ebp),%ebx movl %ebp,%esp popl %ebp ret .Lfe2: .size expi,.Lfe2-expi .align 16 .globl addsi .type addsi,@function addsi: pushl %ebp movl %esp,%ebp subl $12,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%edi testl %esi,%esi jne .L19 pushl %edi call icopy jmp .L68 .align 16 .L19: movl 4(%edi),%ebx sarl $24,%ebx movl %ebx,-8(%ebp) jne .L20 pushl %esi call stoi jmp .L68 .align 16 .L20: testl %esi,%esi jge .L21 movl $-1,-4(%ebp) negl %esi jns .L23 pushl %edi pushl $MOST_NEGS call addii jmp .L68 .align 16 .L21: movl $1,-4(%ebp) .L23: movzwl 4(%edi),%ebx movl %ebx,-12(%ebp) movl -8(%ebp),%ebx cmpl %ebx,-4(%ebp) jne .L24 movl %esi,%edx movl %edx,%eax movl -12(%ebp),%ebx addl -4(%edi,%ebx,4),%eax movl %eax,%esi cmpl %edx,%eax jae .L25 movl %ebx,%eax incl %eax pushl %eax call cgeti movl %eax,%ecx movl %esi,(%ecx,%ebx,4) movl -12(%ebp),%edx decl %edx cmpl $2,%edx jle .L32 .align 4 .L31: cmpl $-1,-4(%edi,%edx,4) jne .L27 movl $0,(%ecx,%edx,4) decl %edx cmpl $2,%edx jg .L31 .L27: cmpl $2,%edx jle .L32 movl -4(%edi,%edx,4),%ebx incl %ebx movl %ebx,(%ecx,%edx,4) jmp .L69 .align 16 .align 4 .L35: movl -4(%edi,%edx,4),%eax movl %eax,(%ecx,%edx,4) .L69: decl %edx cmpl $2,%edx jg .L35 movl (%ecx),%eax decl %eax movl %eax,4(%ecx) movl %eax,8(%ecx) addl $4,%ecx addl $4,avma jmp .L38 .align 16 .L32: movl $1,8(%ecx) movl (%ecx),%eax movl %eax,4(%ecx) jmp .L38 .align 16 .L25: movl -12(%ebp),%ebx pushl %ebx call cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl $1,%edx movl -12(%ebp),%eax decl %eax movl %eax,%esi cmpl %eax,%edx jge .L38 .align 4 .L42: movl (%edi,%edx,4),%eax movl %eax,(%ecx,%edx,4) incl %edx cmpl %esi,%edx jl .L42 .L38: movb -4(%ebp),%bl movb %bl,7(%ecx) jmp .L44 .align 16 .L24: cmpl $3,-12(%ebp) jne .L45 cmpl %esi,8(%edi) jbe .L46 pushl $3 call cgeti movl %eax,%ecx movl -8(%ebp),%eax sall $24,%eax addl $3,%eax movl %eax,4(%ecx) movl 8(%edi),%edi subl %esi,%edi movl %edi,8(%ecx) jmp .L44 .align 16 .L46: cmpl %esi,8(%edi) jne .L47 movl gzero,%eax jmp .L68 .align 16 .L47: pushl $3 call cgeti movl %eax,%ecx movl -8(%ebp),%eax negl %eax sall $24,%eax addl $3,%eax movl %eax,4(%ecx) subl 8(%edi),%esi movl %esi,8(%ecx) jmp .L44 .align 16 .L45: movl -12(%ebp),%ebx movl -4(%edi,%ebx,4),%edx movl %esi,%eax movl %edx,%esi subl %eax,%esi cmpl %eax,%edx jae .L48 pushl %ebx call cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl -12(%ebp),%edx addl $-2,%edx cmpl $0,(%edi,%edx,4) jne .L50 .align 4 .L52: movl $-1,(%ecx,%edx,4) decl %edx cmpl $0,(%edi,%edx,4) je .L52 .L50: movl (%edi,%edx,4),%eax decl %eax movl %eax,(%ecx,%edx,4) cmpl $2,%edx jg .L55 testl %eax,%eax je .L54 .L55: decl %edx testl %edx,%edx jle .L44 .align 4 .L59: movl (%edi,%edx,4),%eax movl %eax,(%ecx,%edx,4) decl %edx testl %edx,%edx jg .L59 jmp .L44 .align 16 .L54: movl (%ecx),%eax decl %eax movl %eax,4(%ecx) movl %eax,8(%ecx) addl $4,%ecx addl $4,avma movb -8(%ebp),%bl movb %bl,7(%ecx) jmp .L44 .align 16 .L48: movl -12(%ebp),%ebx pushl %ebx call cgeti movl %eax,%ecx movl %esi,-4(%ecx,%ebx,4) movl $1,%edx movl -12(%ebp),%eax decl %eax movl %eax,%esi cmpl %eax,%edx jge .L44 .align 4 .L66: movl (%edi,%edx,4),%eax movl %eax,(%ecx,%edx,4) incl %edx cmpl %esi,%edx jl .L66 .L44: movl %ecx,%eax .L68: leal -24(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe3: .size addsi,.Lfe3-addsi .align 16 .globl addii .type addii,@function addii: pushl %ebp movl %esp,%ebp subl $32,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%ecx movzwl 4(%ecx),%ecx movl %ecx,-8(%ebp) movl 12(%ebp),%edi movzwl 4(%edi),%edi movl %edi,-12(%ebp) cmpl %edi,%ecx jge .L71 movl 8(%ebp),%ecx movl %ecx,-16(%ebp) movl 12(%ebp),%edi movl %edi,8(%ebp) movl %ecx,12(%ebp) movl -8(%ebp),%ecx movl %ecx,-4(%ebp) movl -12(%ebp),%edi movl %edi,-8(%ebp) movl %ecx,-12(%ebp) .L71: movl 12(%ebp),%ecx movl 4(%ecx),%esi sarl $24,%esi jne .L72 movl 8(%ebp),%edi pushl %edi call icopy jmp .L135 .align 16 .L72: movl 8(%ebp),%ecx movl 4(%ecx),%ecx sarl $24,%ecx movl %ecx,-4(%ebp) cmpl %esi,%ecx jne .L73 movl -8(%ebp),%eax incl %eax pushl %eax call cgeti movl %eax,-16(%ebp) movl $0,-24(%ebp) movl -8(%ebp),%edi leal 0(,%edi,4),%eax movl -16(%ebp),%ecx leal 4(%eax,%ecx),%esi movl 8(%ebp),%ebx addl %eax,%ebx movl -12(%ebp),%edi movl 12(%ebp),%ecx leal (%ecx,%edi,4),%edi movl %edi,-20(%ebp) movl -12(%ebp),%ecx addl $-2,%ecx movl %ecx,-32(%ebp) je .L75 .align 4 .L76: addl $-4,%esi addl $-4,%ebx movl (%ebx),%edi movl %edi,-28(%ebp) addl $-4,-20(%ebp) movl %edi,%edx movl -20(%ebp),%ecx addl (%ecx),%edx cmpl %edi,%edx jae .L77 addl -24(%ebp),%edx movl $1,-24(%ebp) jmp .L137 .align 16 .L77: addl -24(%ebp),%edx cmpl %edx,-24(%ebp) seta %al andl $255,%eax movl %eax,-24(%ebp) .L137: movl %edx,(%esi) decl -32(%ebp) jne .L76 .L75: cmpl $0,-24(%ebp) je .L80 movl 8(%ebp),%edx addl $8,%edx .L81: addl $-4,%ebx movl %ebx,%eax cmpl %edx,%ebx jb .L82 cmpl $-1,(%ebx) jne .L83 addl $-4,%esi movl $0,(%esi) jmp .L81 .align 16 .L83: addl $-4,%esi movl (%eax),%eax incl %eax jmp .L138 .align 16 .align 4 .L87: addl $-4,%esi movl (%eax),%eax .L138: movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edx,%ebx jae .L87 jmp .L92 .align 16 .L82: movl -16(%ebp),%edi movl $1,8(%edi) movl 8(%ebp),%ecx movl 4(%ecx),%ecx incl %ecx movl %ecx,4(%edi) jmp .L95 .align 16 .L80: movl -8(%ebp),%edx subl -12(%ebp),%edx je .L92 .align 4 .L93: addl $-4,%esi addl $-4,%ebx movl (%ebx),%eax movl %eax,(%esi) decl %edx jne .L93 .L92: movl -16(%ebp),%edi movl (%edi),%ecx decl %ecx movl %ecx,4(%edi) movl 8(%ebp),%edi movl 4(%edi),%eax movl -16(%ebp),%ecx movl %eax,8(%ecx) addl $4,%ecx movl %ecx,-16(%ebp) addl $4,avma jmp .L95 .align 16 .L73: movl -12(%ebp),%edi cmpl %edi,-8(%ebp) jne .L96 movl 8(%ebp),%ebx addl $8,%ebx movl 12(%ebp),%ecx addl $8,%ecx movl %ecx,-20(%ebp) movl -8(%ebp),%edx addl $-2,%edx je .L105 .align 4 .L99: movl (%ebx),%edi movl %edi,-28(%ebp) addl $4,%ebx movl -20(%ebp),%ecx movl (%ecx),%eax addl $4,%ecx movl %ecx,-20(%ebp) cmpl %edi,%eax ja .L136 cmpl %eax,%edi ja .L96 decl %edx jne .L99 .L105: movl gzero,%eax jmp .L135 .align 16 .L136: movl 8(%ebp),%edi movl %edi,-16(%ebp) movl 12(%ebp),%ecx movl %ecx,8(%ebp) movl %edi,12(%ebp) movl %esi,-4(%ebp) .L96: movl -8(%ebp),%edi pushl %edi call cgeti movl %eax,-16(%ebp) movl $0,-24(%ebp) leal 0(,%edi,4),%eax movl 8(%ebp),%ebx addl %eax,%ebx movl -12(%ebp),%ecx movl 12(%ebp),%edi leal (%edi,%ecx,4),%ecx movl %ecx,-20(%ebp) movl -16(%ebp),%esi addl %eax,%esi movl -12(%ebp),%edi addl $-2,%edi movl %edi,-32(%ebp) je .L107 .align 4 .L108: addl $-4,%esi addl $-4,%ebx movl (%ebx),%ecx movl %ecx,-28(%ebp) addl $-4,-20(%ebp) movl -20(%ebp),%edi movl (%edi),%eax movl %ecx,%edx subl %eax,%edx subl -24(%ebp),%edx cmpl %ecx,%eax jbe .L109 movl $1,-24(%ebp) jmp .L110 .align 16 .L109: cmpl %eax,-28(%ebp) jbe .L110 movl $0,-24(%ebp) .L110: movl %edx,(%esi) decl -32(%ebp) jne .L108 .L107: cmpl $0,-24(%ebp) je .L114 jmp .L139 .align 16 .align 4 .L117: addl $-4,%esi movl $-1,(%esi) .L139: addl $-4,%ebx movl (%ebx),%eax testl %eax,%eax je .L117 movl 8(%ebp),%edx addl $8,%edx cmpl %edx,%ebx jb .L124 addl $-4,%esi decl %eax movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edx,%ebx jb .L124 .align 4 .L122: addl $-4,%esi movl (%eax),%eax movl %eax,(%esi) addl $-4,%ebx movl %ebx,%eax cmpl %edx,%ebx jae .L122 jmp .L124 .align 16 .L114: movl -8(%ebp),%ecx subl -12(%ebp),%ecx movl %ecx,-32(%ebp) je .L124 .align 4 .L127: addl $-4,%esi addl $-4,%ebx movl (%ebx),%eax movl %eax,(%esi) decl -32(%ebp) jne .L127 .L124: movl -16(%ebp),%edi cmpl $0,8(%edi) je .L129 movl 8(%ebp),%ecx movl 4(%ecx),%eax movl %eax,4(%edi) jmp .L95 .align 16 .L129: movl -16(%ebp),%esi addl $12,%esi movl -16(%ebp),%edi cmpl $0,12(%edi) jne .L132 .align 4 .L133: addl $4,%esi cmpl $0,(%esi) je .L133 .L132: addl $-8,%esi movl %esi,%ecx subl -16(%ebp),%ecx sarl $2,%ecx movl %ecx,-32(%ebp) movl -16(%ebp),%edi movl (%edi),%eax subl %ecx,%eax movl %eax,(%esi) movl %eax,4(%esi) movl %esi,-16(%ebp) movb -4(%ebp),%cl movb %cl,7(%esi) movl -32(%ebp),%edi leal 0(,%edi,4),%eax addl %eax,avma .L95: movl -16(%ebp),%eax .L135: leal -44(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe4: .size addii,.Lfe4-addii .align 16 .globl mulss .type mulss,@function mulss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %esi pushl %ebx movl 8(%ebp),%edx movl 12(%ebp),%ebx testl %edx,%edx je .L142 testl %ebx,%ebx jne .L141 .L142: movl gzero,%eax jmp .L150 .align 16 .L141: movl $1,%esi testl %edx,%edx jge .L143 movl $-1,%esi negl %edx jns .L143 pushl %edx call stoi pushl %eax pushl %ebx call mulsi jmp .L150 .align 16 .L143: testl %ebx,%ebx jge .L145 negl %esi negl %ebx jns .L145 pushl $ABS_MOST_NEGS movl %edx,%eax testl %esi,%esi jg .L147 negl %eax .L147: pushl %eax call mulsi jmp .L150 .align 16 .L145: leal -4(%ebp),%eax pushl %eax pushl %ebx pushl %edx call mulul3 movl %eax,%ebx addl $12,%esp cmpl $0,-4(%ebp) je .L148 pushl $4 call cgeti movl %eax,%edx movl -4(%ebp),%eax movl %eax,8(%edx) movl %ebx,12(%edx) jmp .L149 .align 16 .L148: pushl $3 call cgeti movl %eax,%edx movl %ebx,8(%edx) .L149: movl (%edx),%eax movl %eax,4(%edx) movl %esi,%ecx movb %cl,7(%edx) movl %edx,%eax .L150: leal -12(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .Lfe5: .size mulss,.Lfe5-mulss .align 16 .globl mulii .type mulii,@function mulii: pushl %ebp movl %esp,%ebp subl $48,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movzwl 4(%esi),%ecx movl %ecx,-8(%ebp) movl 12(%ebp),%edi movzwl 4(%edi),%edi movl %edi,-12(%ebp) movl 4(%esi),%ebx sarl $24,%ebx je .L177 movl 12(%ebp),%ecx movl 4(%ecx),%eax sarl $24,%eax jne .L153 .L177: movl gzero,%eax jmp .L176 .align 16 .L153: testl %eax,%eax jge .L154 negl %ebx .L154: movl -12(%ebp),%edi cmpl %edi,-8(%ebp) jle .L155 movl %esi,-24(%ebp) movl 12(%ebp),%esi movl -24(%ebp),%ecx movl %ecx,12(%ebp) movl -8(%ebp),%edi movl %edi,-16(%ebp) movl -12(%ebp),%ecx movl %ecx,-8(%ebp) movl %edi,-12(%ebp) .L155: movl -8(%ebp),%edi movl -12(%ebp),%ecx leal -2(%ecx,%edi),%edi movl %edi,-16(%ebp) cmpl $65535,%edi jle .L156 pushl $17 call err addl $4,%esp .L156: movl -16(%ebp),%edi pushl %edi call cgeti movl %eax,-24(%ebp) movl (%eax),%eax movl -24(%ebp),%ecx movl %eax,4(%ecx) movb %bl,7(%ecx) movl -8(%ebp),%edi leal -4(%esi,%edi,4),%esi movl %esi,-32(%ebp) movl (%esi),%ecx movl %ecx,-20(%ebp) movl $0,-4(%ebp) movl -12(%ebp),%edi movl 12(%ebp),%ecx leal (%ecx,%edi,4),%edi movl %edi,-48(%ebp) movl -16(%ebp),%ecx movl -24(%ebp),%edi leal (%edi,%ecx,4),%ecx movl %ecx,-28(%ebp) addl $4,%esp movl -12(%ebp),%esi addl $-2,%esi je .L158 .align 4 .L159: addl $-4,-28(%ebp) movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-48(%ebp) movl -48(%ebp),%edi movl (%edi),%eax pushl %eax movl -20(%ebp),%ecx pushl %ecx call mulul3 addl %ebx,%eax addl $12,%esp cmpl %ebx,%eax jae .L161 incl -4(%ebp) .L161: movl -28(%ebp),%edi movl %eax,(%edi) decl %esi jne .L159 .L158: movl -4(%ebp),%eax movl -28(%ebp),%ecx movl %eax,-4(%ecx) movl -16(%ebp),%edi movl -24(%ebp),%ecx leal (%ecx,%edi,4),%edi movl %edi,-28(%ebp) movl -12(%ebp),%ecx movl 12(%ebp),%edi leal (%edi,%ecx,4),%ecx movl %ecx,-36(%ebp) decl -12(%ebp) addl $-3,-8(%ebp) cmpl $0,-8(%ebp) jle .L164 .align 4 .L165: addl $-4,-32(%ebp) movl -32(%ebp),%edi movl (%edi),%edi movl %edi,-44(%ebp) movl -36(%ebp),%ecx movl %ecx,-48(%ebp) movl -28(%ebp),%ebx addl $-4,%ebx movl %ebx,-28(%ebp) movl $0,-40(%ebp) movl -12(%ebp),%esi jmp .L178 .align 16 .align 4 .L168: addl $-4,-48(%ebp) movl -48(%ebp),%edi movl (%edi),%edx leal -4(%ebp),%eax pushl %eax movl -44(%ebp),%ecx pushl %ecx pushl %edx call mulul3 movl %eax,%edx addl $-4,%ebx addl (%ebx),%eax addl $12,%esp cmpl %edx,%eax jae .L170 incl -4(%ebp) .L170: movl %eax,%edx movl -40(%ebp),%eax addl %edx,%eax cmpl %edx,%eax jae .L172 incl -4(%ebp) .L172: movl %eax,(%ebx) movl -4(%ebp),%edi movl %edi,-40(%ebp) .L178: decl %esi jne .L168 movl -4(%ebp),%eax movl %eax,-4(%ebx) decl -8(%ebp) cmpl $0,-8(%ebp) jg .L165 .L164: movl -24(%ebp),%ecx cmpl $0,8(%ecx) jne .L175 movl -24(%ebp),%ecx movl 4(%ecx),%edi decl %edi movl %edi,8(%ecx) movl -24(%ebp),%ecx movl (%ecx),%edi decl %edi movl %edi,4(%ecx) addl $4,%ecx movl %ecx,-24(%ebp) addl $4,avma .L175: movl -24(%ebp),%eax .L176: leal -60(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe6: .size mulii,.Lfe6-mulii .section .rodata .align 4 .LC0: .long 0x55475a32,0x3fd34413 .text .align 16 .globl confrac .type confrac,@function confrac: pushl %ebp movl %esp,%ebp subl $76,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%eax movzwl (%eax),%eax movl %eax,-16(%ebp) movl 8(%ebp),%edx movl 4(%edx),%edx andl $16777215,%edx movl $8388607,%ecx subl %edx,%ecx movl %ecx,-20(%ebp) movl avma,%eax movl %eax,-24(%ebp) movl -16(%ebp),%edx sall $5,%edx leal -64(%ecx,%edx),%edx movl %edx,-32(%ebp) addl $63,%edx sarl $5,%edx movl %edx,-28(%ebp) pushl %edx call cgeti movl %eax,-44(%ebp) movl -20(%ebp),%esi sarl $5,%esi xorl %ebx,%ebx addl $4,%esp cmpl %esi,%ebx jge .L181 .align 4 .L183: movl -44(%ebp),%ecx movl $0,(%ecx,%ebx,4) incl %ebx cmpl %esi,%ebx jl .L183 .L181: andl $31,-20(%ebp) jne .L185 movl $2,%edi cmpl %edi,-16(%ebp) jle .L191 .align 4 .L189: movl 8(%ebp),%eax movl (%eax,%edi,4),%eax movl -44(%ebp),%edx movl %eax,(%edx,%ebx,4) incl %ebx incl %edi cmpl %edi,-16(%ebp) jg .L189 jmp .L191 .align 16 .L185: movl $0,-40(%ebp) movl $2,%edi cmpl %edi,-16(%ebp) jle .L193 movl $32,%ecx subl -20(%ebp),%ecx movl %ecx,-52(%ebp) .align 4 .L195: movl %ebx,-60(%ebp) movl 8(%ebp),%eax movl (%eax,%edi,4),%esi incl %ebx movl %esi,%eax movl -52(%ebp),%ecx sall %cl,%eax movl %eax,-64(%ebp) movl %eax,-12(%ebp) movl -20(%ebp),%ecx shrl %cl,%esi movl %esi,%ecx addl -40(%ebp),%ecx movl -60(%ebp),%eax movl -44(%ebp),%edx movl %ecx,(%edx,%eax,4) movl -64(%ebp),%eax movl %eax,-40(%ebp) incl %edi cmpl %edi,-16(%ebp) jg .L195 .L193: movl -40(%ebp),%eax movl -28(%ebp),%edx movl -44(%ebp),%ecx movl %eax,-8(%ecx,%edx,4) .L191: movl -28(%ebp),%edx movl -44(%ebp),%ecx movl $0,-4(%ecx,%edx,4) fldl .LC0 fimull -32(%ebp) fld1 faddp %st,%st(1) fnstcw -4(%ebp) movl -4(%ebp),%eax movb $12,%ah movl %eax,-8(%ebp) fldcw -8(%ebp) subl $4,%esp fistpl (%esp) popl %ebx fldcw -4(%ebp) leal 17(%ebx),%edx movl %edx,-36(%ebp) movl -36(%ebp),%eax movl $9,%ecx cltd idivl %ecx movl %eax,-36(%ebp) pushl %eax call cgeti movl %eax,-48(%ebp) movl %ebx,(%eax) movl $1,%edi addl $4,%esp cmpl %edi,-36(%ebp) jle .L198 .align 4 .L200: movl $0,-12(%ebp) movl -28(%ebp),%ebx decl %ebx js .L202 .align 4 .L204: movl -12(%ebp),%esi leal -12(%ebp),%eax pushl %eax pushl $1000000000 movl -44(%ebp),%edx movl (%edx,%ebx,4),%edx pushl %edx call mulul3 movl %eax,-64(%ebp) addl %esi,-64(%ebp) addl $12,%esp cmpl %esi,-64(%ebp) jae .L206 incl -12(%ebp) .L206: movl -64(%ebp),%eax movl -44(%ebp),%ecx movl %eax,(%ecx,%ebx,4) decl %ebx jns .L204 .L202: movl -12(%ebp),%edx movl -48(%ebp),%ecx movl %edx,(%ecx,%edi,4) incl %edi cmpl %edi,-36(%ebp) jg .L200 .L198: movl -24(%ebp),%eax movl %eax,avma movl -48(%ebp),%eax leal -88(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe7: .size confrac,.Lfe7-confrac .align 16 .globl divss .type divss,@function divss: pushl %ebp movl %esp,%ebp pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%ebx testl %ebx,%ebx jne .L210 pushl $23 call err addl $4,%esp .L210: cmpl $-2147483648,%esi jne .L211 pushl %ebx pushl $-2147483648 call stoi addl $4,%esp pushl %eax call divis jmp .L216 .align 16 .L211: movl $0,hiremainder pushl $hiremainder movl %ebx,%eax testl %ebx,%ebx jge .L212 negl %eax .L212: pushl %eax movl %esi,%eax testl %esi,%esi jge .L213 negl %eax .L213: pushl %eax call divul3 addl $12,%esp testl %ebx,%ebx jge .L214 negl hiremainder negl %eax .L214: testl %esi,%esi jge .L215 negl %eax .L215: pushl %eax call stoi .L216: leal -8(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .Lfe8: .size divss,.Lfe8-divss .align 16 .globl modss .type modss,@function modss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %esi pushl %ebx movl 8(%ebp),%esi movl 12(%ebp),%ebx testl %ebx,%ebx jne .L218 pushl $38 call err addl $4,%esp .L218: cmpl $-2147483648,%esi jne .L219 pushl %ebx pushl $-2147483648 call stoi addl $4,%esp pushl %eax call modis jmp .L225 .align 16 .L219: movl $0,-4(%ebp) leal -4(%ebp),%eax pushl %eax testl %ebx,%ebx jge .L220 negl %ebx .L220: pushl %ebx movl %esi,%eax testl %eax,%eax jge .L221 negl %eax .L221: pushl %eax call divul3 addl $12,%esp cmpl $0,-4(%ebp) jne .L222 movl gzero,%eax jmp .L225 .align 16 .L222: cmpl $0,-4(%ebp) jge .L223 movl %ebx,%eax subl -4(%ebp),%eax jmp .L226 .align 16 .L223: movl -4(%ebp),%eax .L226: pushl %eax call stoi .L225: leal -12(%ebp),%esp popl %ebx popl %esi movl %ebp,%esp popl %ebp ret .Lfe9: .size modss,.Lfe9-modss .align 16 .globl resss .type resss,@function resss: pushl %ebp movl %esp,%ebp subl $4,%esp pushl %ebx movl 12(%ebp),%ebx testl %ebx,%ebx jne .L228 pushl $40 call err addl $4,%esp .L228: movl $0,-4(%ebp) leal -4(%ebp),%eax pushl %eax movl %ebx,%eax testl %ebx,%ebx jge .L229 negl %eax .L229: pushl %eax movl 8(%ebp),%eax testl %eax,%eax jge .L230 negl %eax .L230: pushl %eax call divul3 addl $12,%esp testl %ebx,%ebx jge .L231 movl -4(%ebp),%eax negl %eax jmp .L233 .align 16 .L231: movl -4(%ebp),%eax .L233: pushl %eax call stoi movl -8(%ebp),%ebx movl %ebp,%esp popl %ebp ret .Lfe10: .size resss,.Lfe10-resss .align 16 .globl divsi .type divsi,@function divsi: pushl %ebp movl %esp,%ebp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%ebx movl 12(%ebp),%esi movzwl 4(%esi),%edi cmpb $0,7(%esi) jne .L235 pushl $24 call err addl $4,%esp .L235: testl %ebx,%ebx je .L237 cmpl $3,%edi jg .L237 cmpl $0,8(%esi) jge .L236 .L237: movl %ebx,hiremainder movl gzero,%eax jmp .L242 .align 16 .L236: cmpl $-2147483648,%ebx jne .L238 pushl $0 pushl %esi pushl $-2147483648 call stoi addl $4,%esp pushl %eax call dvmdii jmp .L242 .align 16 .L238: movl $0,hiremainder pushl $hiremainder movl 8(%esi),%eax pushl %eax movl %ebx,%eax testl %ebx,%ebx jge .L239 negl %eax .L239: pushl %eax call divul3 addl $12,%esp cmpl $0,4(%esi) jge .L240 negl hiremainder negl %eax .L240: testl %ebx,%ebx jge .L241 negl %eax .L241: pushl %eax call stoi .L242: leal -12(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe11: .size divsi,.Lfe11-divsi .align 16 .globl divis .type divis,@function divis: pushl %ebp movl %esp,%ebp subl $24,%esp pushl %edi pushl %esi pushl %ebx movl 12(%ebp),%edi movl 8(%ebp),%edx movl 4(%edx),%edx sarl $24,%edx movl %edx,-8(%ebp) movl 8(%ebp),%ecx movzwl 4(%ecx),%ecx movl %ecx,-12(%ebp) testl %edi,%edi jne .L244 pushl $26 call err addl $4,%esp .L244: cmpl $0,-8(%ebp) jne .L245 movl $0,hiremainder movl gzero,%eax jmp .L259 .align 16 .L245: testl %edi,%edi jge .L246 negl -8(%ebp) negl %edi jns .L246 pushl $0 pushl %edi call stoi addl $4,%esp pushl %eax movl 8(%ebp),%edx pushl %edx call dvmdii jmp .L259 .align 16 .L246: movl 8(%ebp),%ecx cmpl %edi,8(%ecx) jae .L248 cmpl $3,-12(%ebp) jne .L249 pushl %ecx call itos movl %eax,hiremainder movl gzero,%eax jmp .L259 .align 16 .L249: movl -12(%ebp),%eax decl %eax pushl %eax call cgeti movl %eax,%esi movl $1,-16(%ebp) movl 8(%ebp),%edx movl 8(%edx),%eax movl %eax,-4(%ebp) jmp .L260 .align 16 .L248: movl -12(%ebp),%ecx pushl %ecx call cgeti movl %eax,%esi movl $0,-16(%ebp) movl $0,-4(%ebp) .L260: addl $4,%esp movl -16(%ebp),%ebx addl $2,%ebx cmpl %ebx,-12(%ebp) jle .L253 leal -4(%ebp),%edx movl %edx,-20(%ebp) .align 4 .L255: movl -20(%ebp),%ecx pushl %ecx pushl %edi movl 8(%ebp),%edx movl (%edx,%ebx,4),%eax pushl %eax call divul3 movl %eax,-24(%ebp) movl %ebx,%eax subl -16(%ebp),%eax movl -24(%ebp),%ecx movl %ecx,(%esi,%eax,4) addl $12,%esp incl %ebx cmpl %ebx,-12(%ebp) jg .L255 .L253: movl (%esi),%eax movl %eax,4(%esi) movb -8(%ebp),%dl movb %dl,7(%esi) cmpl $0,-8(%ebp) jge .L257 movl -4(%ebp),%ecx negl %ecx movl %ecx,hiremainder jmp .L258 .align 16 .L257: movl -4(%ebp),%eax movl %eax,hiremainder .L258: movl %esi,%eax .L259: leal -36(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe12: .size divis,.Lfe12-divis .align 16 .globl dvmdii .type dvmdii,@function dvmdii: pushl %ebp movl %esp,%ebp subl $88,%esp pushl %edi pushl %esi pushl %ebx movl 8(%ebp),%esi movl 4(%esi),%ecx sarl $24,%ecx movl %ecx,-36(%ebp) movl 12(%ebp),%edi movl 4(%edi),%edi sarl $24,%edi movl %edi,-40(%ebp) jne .L262 pushl $36 call err addl $4,%esp .L262: cmpl $0,-36(%ebp) jne .L263 cmpl $-1,16(%ebp) je .L372 cmpl $0,16(%ebp) je .L372 movl gzero,%eax movl 16(%ebp),%ecx movl %eax,(%ecx) .L372: movl gzero,%eax jmp .L367 .align 16 .L263: movzwl 4(%esi),%edi movl %edi,-12(%ebp) movl 12(%ebp),%ecx movzwl 4(%ecx),%ecx movl %ecx,-16(%ebp) subl %ecx,%edi movl %edi,-20(%ebp) jns .L266 cmpl $-1,16(%ebp) jne .L267 pushl %esi call icopy jmp .L367 .align 16 .L267: cmpl $0,16(%ebp) je .L372 pushl %esi call icopy movl 16(%ebp),%edi movl %eax,(%edi) jmp .L372 .align 16 .L266: movl avma,%ecx movl %ecx,-8(%ebp) cmpl $0,-36(%ebp) jge .L269 negl -40(%ebp) .L269: cmpl $3,-16(%ebp) jne .L270 movl 12(%ebp),%edi movl 8(%edi),%edi movl %edi,-48(%ebp) leal 8(%esi),%ecx movl %ecx,-88(%ebp) cmpl %edi,8(%esi) jae .L271 movl -12(%ebp),%ebx decl %ebx movl 8(%esi),%eax movl %eax,-4(%ebp) addl $12,%esi movl %esi,-88(%ebp) jmp .L272 .align 16 .L271: movl -12(%ebp),%ebx movl $0,-4(%ebp) .L272: pushl %ebx call cgeti movl %eax,-56(%ebp) movl %eax,%edi addl $8,%edi movl %edi,-72(%ebp) addl $4,%esp leal -2(%ebx),%ecx movl %ecx,-24(%ebp) testl %ecx,%ecx je .L274 leal -4(%ebp),%esi .align 4 .L275: pushl %esi movl -48(%ebp),%edi pushl %edi movl -88(%ebp),%ecx movl (%ecx),%eax pushl %eax addl $4,%ecx movl %ecx,-88(%ebp) call divul3 movl -72(%ebp),%edi movl %eax,(%edi) addl $4,%edi movl %edi,-72(%ebp) addl $12,%esp decl -24(%ebp) jne .L275 .L274: cmpl $-1,16(%ebp) jne .L277 movl -8(%ebp),%ecx movl %ecx,avma cmpl $0,-4(%ebp) je .L372 pushl $3 call cgeti movl %eax,-60(%ebp) movl -36(%ebp),%eax sall $24,%eax addl $3,%eax movl -60(%ebp),%edi movl %eax,4(%edi) movl -4(%ebp),%eax movl %eax,8(%edi) movl -60(%ebp),%eax jmp .L367 .align 16 .L277: cmpl $2,%ebx je .L279 movl -56(%ebp),%ecx movl (%ecx),%eax movl %eax,4(%ecx) movb -40(%ebp),%cl movl -56(%ebp),%edi movb %cl,7(%edi) jmp .L280 .align 16 .L279: movl -8(%ebp),%ecx movl %ecx,avma movl gzero,%edi movl %edi,-56(%ebp) .L280: cmpl $0,16(%ebp) jne .L281 .L370: movl -56(%ebp),%eax jmp .L367 .align 16 .L281: cmpl $0,-4(%ebp) jne .L282 movl gzero,%eax movl 16(%ebp),%ecx movl %eax,(%ecx) jmp .L370 .align 16 .L282: pushl $3 call cgeti movl %eax,-60(%ebp) movl -36(%ebp),%eax sall $24,%eax addl $3,%eax movl -60(%ebp),%edi movl %eax,4(%edi) movl -4(%ebp),%eax movl %eax,8(%edi) movl 16(%ebp),%ecx movl %edi,(%ecx) jmp .L370 .align 16 .L270: movl -12(%ebp),%edi pushl %edi call cgeti movl %eax,-56(%ebp) movl 12(%ebp),%ecx movl 8(%ecx),%eax pushl %eax call bfffo movl %eax,-28(%ebp) addl $8,%esp testl %eax,%eax je .L285 movl -16(%ebp),%edi pushl %edi call cgeti movl %eax,-60(%ebp) movl 12(%ebp),%ecx movl 8(%ecx),%ebx movl %ecx,%edx addl $12,%edx movl $32,%eax subl -28(%ebp),%eax movl %ebx,%edi movl %eax,%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) movl -60(%ebp),%eax addl $8,%eax addl $4,%esp movl -16(%ebp),%edi addl $-3,%edi movl %edi,-24(%ebp) je .L287 movl $32,%edi subl %ecx,%edi movl %edi,-88(%ebp) .align 4 .L288: movl (%edx),%ebx addl $4,%edx movl %ebx,%edi movl -88(%ebp),%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -32(%ebp),%ecx addl %edi,%ecx movl %ecx,(%eax) addl $4,%eax movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) decl -24(%ebp) jne .L288 .L287: movl -32(%ebp),%edi movl %edi,(%eax) movl $0,-32(%ebp) addl $8,%esi movl %esi,-88(%ebp) movl -56(%ebp),%ecx addl $4,%ecx movl %ecx,-72(%ebp) movl -12(%ebp),%edi addl $-2,%edi movl %edi,-24(%ebp) je .L291 movl $32,%eax subl -28(%ebp),%eax .align 4 .L292: movl -88(%ebp),%ecx movl (%ecx),%ebx addl $4,%ecx movl %ecx,-88(%ebp) movl %ebx,%edi movl %eax,%ecx shrl %cl,%edi movl %edi,-4(%ebp) movl -32(%ebp),%ecx addl -4(%ebp),%ecx movl -72(%ebp),%edi movl %ecx,(%edi) addl $4,%edi movl %edi,-72(%ebp) movl -28(%ebp),%ecx sall %cl,%ebx movl %ebx,-32(%ebp) decl -24(%ebp) jne .L292 .L291: movl -32(%ebp),%ecx movl -72(%ebp),%edi movl %ecx,(%edi) jmp .L294 .align 16 .L285: addl $8,%esi movl %esi,-88(%ebp) movl -56(%ebp),%edi movl $0,4(%edi) addl $8,%edi movl %edi,-72(%ebp) movl -12(%ebp),%esi addl $-2,%esi je .L296 .align 4 .L297: movl -88(%ebp),%ecx movl (%ecx),%eax movl -72(%ebp),%edi movl %eax,(%edi) addl $4,%ecx movl %ecx,-88(%ebp) addl $4,%edi movl %edi,-72(%ebp) decl %esi jne .L297 .L296: movl 12(%ebp),%ecx movl %ecx,-60(%ebp) .L294: movl -60(%ebp),%edi movl 8(%edi),%edi movl %edi,-48(%ebp) movl -60(%ebp),%ecx movl 12(%ecx),%ecx movl %ecx,-44(%ebp) movl -56(%ebp),%edi addl $4,%edi movl %edi,-72(%ebp) movl -20(%ebp),%ecx incl %ecx movl %ecx,-24(%ebp) je .L300 movl -16(%ebp),%edi sall $2,%edi movl %edi,-80(%ebp) .align 4 .L301: movl -72(%ebp),%ecx movl (%ecx),%eax addl $4,%ecx movl %ecx,-72(%ebp) cmpl %eax,-48(%ebp) jne .L302 movl $-1,-52(%ebp) movl -48(%ebp),%ebx movl %ebx,%edi addl (%ecx),%edi movl %edi,-84(%ebp) cmpl %ebx,%edi setb %al andl $255,%eax movl %edi,-32(%ebp) jmp .L303 .align 16 .L302: movl -72(%ebp),%ecx movl -4(%ecx),%eax movl %eax,-4(%ebp) leal -4(%ebp),%eax pushl %eax movl -48(%ebp),%edi pushl %edi movl (%ecx),%eax pushl %eax call divul3 movl %eax,-52(%ebp) xorl %eax,%eax movl -4(%ebp),%ecx movl %ecx,-32(%ebp) addl $12,%esp .L303: testl %eax,%eax jne .L304 leal -4(%ebp),%eax pushl %eax movl -44(%ebp),%edi pushl %edi movl -52(%ebp),%ecx pushl %ecx call mulul3 movl %eax,%ebx movl -72(%ebp),%edi movl 4(%edi),%edx addl $12,%esp cmpl %edx,%ebx setb %al andl $255,%eax movl %ebx,%esi subl %edx,%esi movl -4(%ebp),%ebx movl -32(%ebp),%edx movl %ebx,%ecx subl %edx,%ecx subl %eax,%ecx movl %ecx,-84(%ebp) cmpl %ebx,%edx ja .L373 jmp .L313 .align 16 .align 4 .L317: cmpl $0,-88(%ebp) je .L304 decl -52(%ebp) movl %esi,%ebx movl -44(%ebp),%edx cmpl %edx,%ebx setb %al andl $255,%eax subl %edx,%esi movl -88(%ebp),%ebx movl -48(%ebp),%edx movl %ebx,%ecx subl %edx,%ecx subl %eax,%ecx movl %ecx,-84(%ebp) cmpl %ebx,%edx jbe .L313 .L373: movl $1,%eax jmp .L314 .align 16 .L313: cmpl %ebx,%edx jae .L314 xorl %eax,%eax .L314: movl -84(%ebp),%edi movl %edi,-88(%ebp) testl %eax,%eax je .L317 .L304: movl $0,-4(%ebp) movl -72(%ebp),%ecx movl -80(%ebp),%edi leal -8(%edi,%ecx),%ecx movl %ecx,-88(%ebp) movl -60(%ebp),%ecx addl %edi,%ecx movl %ecx,-76(%ebp) movl -16(%ebp),%esi addl $-2,%esi je .L319 .align 4 .L320: movl -4(%ebp),%ebx leal -4(%ebp),%eax pushl %eax addl $-4,-76(%ebp) movl -76(%ebp),%edi movl (%edi),%eax pushl %eax movl -52(%ebp),%ecx pushl %ecx call mulul3 movl %eax,-84(%ebp) addl %ebx,-84(%ebp) addl $12,%esp cmpl %ebx,-84(%ebp) jae .L322 incl -4(%ebp) .L322: movl -84(%ebp),%edx addl $-4,-88(%ebp) movl -88(%ebp),%edi movl (%edi),%ebx cmpl %edx,%ebx setb %al andl $255,%eax subl %edx,%ebx movl %ebx,(%edi) addl %eax,-4(%ebp) decl %esi jne .L320 .L319: movl -72(%ebp),%ecx movl -4(%ecx),%eax cmpl %eax,-4(%ebp) jbe .L324 xorl %eax,%eax decl -52(%ebp) movl -80(%ebp),%edi leal -8(%edi,%ecx),%edi movl %edi,-88(%ebp) movl -60(%ebp),%ecx addl -80(%ebp),%ecx movl %ecx,-76(%ebp) movl -16(%ebp),%esi addl $-2,%esi je .L324 .align 4 .L327: movl -88(%ebp),%edx addl $-4,%edx movl %edx,-88(%ebp) movl (%edx),%ebx addl $-4,-76(%ebp) movl %ebx,%ecx movl -76(%ebp),%edi addl (%edi),%ecx movl %ecx,-84(%ebp) cmpl %ebx,%ecx jae .L328 addl %eax,%ecx movl %ecx,-84(%ebp) movl $1,%eax movl %ecx,(%edx) jmp .L325 .align 16 .L328: addl %eax,-84(%ebp) cmpl %eax,-84(%ebp) setb %al andl $255,%eax movl -84(%ebp),%edi movl %edi,(%edx) .L325: decl %esi jne .L327 .L324: movl -52(%ebp),%edi movl -72(%ebp),%ecx movl %edi,-4(%ecx) decl -24(%ebp) jne .L301 .L300: movl avma,%ecx movl %ecx,-88(%ebp) cmpl $-1,16(%ebp) je .L332 movl -20(%ebp),%ebx addl $2,%ebx movl -56(%ebp),%edi leal (%edi,%ebx,4),%edi movl %edi,-72(%ebp) movl -56(%ebp),%ecx cmpl $0,4(%ecx) je .L333 movl -20(%ebp),%ebx addl $3,%ebx jmp .L334 .align 16 .L333: cmpl $0,-20(%ebp) jne .L334 movl $0,-40(%ebp) .L334: pushl %ebx call cgeti movl %eax,-64(%ebp) leal (%eax,%ebx,4),%edx addl $4,%esp leal -2(%ebx),%esi testl %esi,%esi je .L337 .align 4 .L338: addl $-4,%edx addl $-4,-72(%ebp) movl -72(%ebp),%edi movl (%edi),%eax movl %eax,(%edx) decl %esi jne .L338 .L337: cmpl $2,%ebx ja .L340 movl -64(%ebp),%ecx movl $2,4(%ecx) jmp .L332 .align 16 .L340: movl -64(%ebp),%edi movl (%edi),%eax movl %eax,4(%edi) movb -40(%ebp),%cl movb %cl,7(%edi) .L332: cmpl $0,16(%ebp) je .L342 movl -20(%ebp),%esi addl $2,%esi cmpl %esi,-12(%ebp) jle .L344 movl -56(%ebp),%edi cmpl $0,(%edi,%esi,4) jne .L344 movl -20(%ebp),%esi addl $3,%esi cmpl %esi,-12(%ebp) jle .L344 cmpl $0,(%edi,%esi,4) jne .L344 .align 4 .L345: incl %esi cmpl %esi,-12(%ebp) jle .L344 movl -56(%ebp),%ecx cmpl $0,(%ecx,%esi,4) je .L345 .L344: cmpl %esi,-12(%ebp) jne .L349 movl gzero,%eax pushl %eax call icopy movl %eax,-68(%ebp) addl $4,%esp jmp .L342 .align 16 .L349: movl -12(%ebp),%eax subl %esi,%eax addl $2,%eax pushl %eax call cgeti movl %eax,-68(%ebp) movl (%eax),%eax movl -68(%ebp),%edi movl %eax,4(%edi) addl $4,%esp cmpl $0,-28(%ebp) jne .L351 movl $2,-24(%ebp) cmpl %esi,-12(%ebp) jle .L357 .align 4 .L355: movl -56(%ebp),%ecx movl (%ecx,%esi,4),%eax movl -24(%ebp),%edi movl -68(%ebp),%ecx movl %eax,(%ecx,%edi,4) incl %esi incl %edi movl %edi,-24(%ebp) cmpl %esi,-12(%ebp) jg .L355 jmp .L357 .align 16 .L351: movl $0,-4(%ebp) movl -56(%ebp),%edi movl (%edi,%esi,4),%ebx incl %esi movl $32,%eax subl -28(%ebp),%eax movl %ebx,%edi movl %eax,%ecx sall %cl,%edi movl %edi,%eax movl %eax,-4(%ebp) movl %ebx,%edx movl -28(%ebp),%ecx shrl %cl,%edx movl %eax,-32(%ebp) testl %edx,%edx je .L358 movl -68(%ebp),%edi movl %edx,8(%edi) movl $1,%eax jmp .L359 .align 16 .L358: movl -68(%ebp),%ecx movl (%ecx),%edi decl %edi movl %edi,4(%ecx) addl $4,%ecx movl %ecx,-68(%ebp) addl $4,avma movl (%ecx),%eax movl %eax,4(%ecx) xorl %eax,%eax .L359: addl $2,%eax movl %eax,-24(%ebp) cmpl %esi,-12(%ebp) jle .L357 movl $32,%ecx subl -28(%ebp),%ecx movl %ecx,-84(%ebp) .align 4 .L363: movl -56(%ebp),%edi movl (%edi,%esi,4),%ebx movl %ebx,%edx movl -84(%ebp),%ecx sall %cl,%edx movl %edx,-4(%ebp) movl %ebx,%eax movl -28(%ebp),%ecx shrl %cl,%eax addl -32(%ebp),%eax movl -24(%ebp),%edi movl -68(%ebp),%ecx movl %eax,(%ecx,%edi,4) movl %edx,-32(%ebp) incl %esi incl %edi movl %edi,-24(%ebp) cmpl %esi,-12(%ebp) jg .L363 .L357: movb -36(%ebp),%cl movl -68(%ebp),%edi movb %cl,7(%edi) .L342: cmpl $-1,16(%ebp) jne .L365 movl -68(%ebp),%ecx pushl %ecx movl -88(%ebp),%edi pushl %edi movl -8(%ebp),%ecx pushl %ecx jmp .L371 .align 16 .L365: cmpl $0,16(%ebp) je .L366 pushl $0 movl -88(%ebp),%edi pushl %edi movl -8(%ebp),%ecx pushl %ecx call gerepile andb $252,%al movl -68(%ebp),%ecx addl %eax,%ecx movl 16(%ebp),%edi movl %ecx,(%edi) addl -64(%ebp),%eax jmp .L367 .align 16 .L366: movl -64(%ebp),%edi pushl %edi movl -88(%ebp),%ecx pushl %ecx movl -8(%ebp),%edi pushl %edi .L371: call gerepile .L367: leal -100(%ebp),%esp popl %ebx popl %esi popl %edi movl %ebp,%esp popl %ebp ret .Lfe13: .size dvmdii,.Lfe13-dvmdii .ident "GCC: (GNU) 2.7.2.1" gcl-2.6.14/mp/mpi-sparc.s0000755000175000017500000012740114360276512013476 0ustar cammcammgcc2_compiled.: ___gnu_compiled_c: .text .align 4 .global _mulsi .proc 0104 _mulsi: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 ld [%i1+4],%o1 sra %o1,24,%l1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %i0,0 be L3 and %o1,%o0,%l0 cmp %l1,0 bne L2 cmp %i0,0 L3: sethi %hi(_gzero),%o0 b L12 ld [%o0+%lo(_gzero)],%i0 L2: bge L4 nop subcc %g0,%i0,%i0 bpos L4 sub %g0,%l1,%l1 call _stoi,0 sethi %hi(-2147483648),%o0 call _mulii,0 mov %i1,%o1 b L12 mov %o0,%i0 L4: call _cgeti,0 add %l0,1,%o0 mov %o0,%g3 mov 0,%o2 sll %l0,2,%o0 add %i1,%o0,%i1 add %g3,%o0,%g2 addcc %l0,-2,%o3 be L7 add %g2,4,%g2 L8: add %g2,-4,%g2 mov %o2,%o0 add %i1,-4,%i1 ld [%i1],%o1 mov %i0,%l2 or %l2,%o1,%o4 mov %l2,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%g0,%o4 tst %o1 bl,a 1f add %o4,%l2,%o4 1: mov %o4,%o2 b 3f rd %y,%l2 2: clr %o2 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%l2 3: mov %l2,%o1 addcc %o0,%o1,%l2 addx %o2,%g0,%o2 addcc %o3,-1,%o3 bne L8 st %l2,[%g2] L7: cmp %o2,0 be L10 sethi %hi(-65536),%o1 st %o2,[%g2-4] ld [%g3+4],%o0 and %o0,%o1,%o0 add %o0,%l0,%o0 b L13 add %o0,1,%o0 L10: sethi %hi(_avma),%o1 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(_avma)] ld [%g3],%o0 add %o0,-1,%o0 st %o0,[%g3+4] add %g3,4,%g3 ld [%g3+4],%o0 sethi %hi(-65536),%o1 and %o0,%o1,%o0 add %o0,%l0,%o0 L13: st %o0,[%g3+4] ld [%g3+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l1,24,%o0 add %o1,%o0,%o1 st %o1,[%g3+4] mov %g3,%i0 L12: ret restore .align 4 .global _expi .proc 04 _expi: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 mov %i0,%o2 ld [%o2+4],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 and %o1,%o0,%i0 cmp %i0,2 be,a L16 sethi %hi(-8388608),%i0 call _bfffo,0 ld [%o2+8],%o0 add %i0,-2,%i0 sll %i0,5,%i0 sub %i0,%o0,%i0 add %i0,-1,%i0 L16: ret restore .align 4 .global _addsi .proc 0104 _addsi: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 orcc %i0,%g0,%l1 bne,a L18 ldsb [%i1+4],%l3 call _icopy,0 mov %i1,%o0 b L67 mov %o0,%i0 L18: cmp %l3,0 bne L19 cmp %l1,0 call _stoi,0 mov %l1,%o0 b L67 mov %o0,%i0 L19: bge,a L22 mov 1,%l4 subcc %g0,%l1,%l1 bpos L22 mov -1,%l4 sethi %hi(_MOST_NEGS),%o0 or %o0,%lo(_MOST_NEGS),%o0 call _addii,0 mov %i1,%o1 b L67 mov %o0,%i0 L22: ld [%i1+4],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %l4,%l3 bne L23 and %o1,%o0,%l0 mov %l1,%o1 sll %l0,2,%l2 add %l2,%i1,%o0 ld [%o0-4],%o0 add %o1,%o0,%o0 cmp %o0,%o1 bgeu L24 mov %o0,%l1 call _cgeti,0 add %l0,1,%o0 mov %o0,%i0 add %l0,-1,%o2 cmp %o2,2 ble L69 st %l1,[%i0+%l2] L30: sll %o2,2,%o1 add %o1,%i1,%o0 ld [%o0-4],%o0 cmp %o0,-1 bne L69 cmp %o2,2 add %o2,-1,%o2 cmp %o2,2 bg L30 st %g0,[%i0+%o1] cmp %o2,2 L69: ble L31 sll %o2,2,%o1 add %o1,%i1,%o0 ld [%o0-4],%o0 add %o0,1,%o0 b L68 st %o0,[%i0+%o1] L34: add %o0,%i1,%o1 ld [%o1-4],%o1 st %o1,[%i0+%o0] L68: add %o2,-1,%o2 cmp %o2,2 bg L34 sll %o2,2,%o0 ld [%i0],%o0 add %o0,-1,%o0 st %o0,[%i0+4] st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(_avma),%o1 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 b L37 st %o0,[%o1+%lo(_avma)] L31: mov 1,%o0 st %o0,[%i0+8] ld [%i0],%o0 b L37 st %o0,[%i0+4] L24: call _cgeti,0 mov %l0,%o0 mov %o0,%i0 sll %l0,2,%o0 add %o0,%i0,%o0 st %l1,[%o0-4] mov 1,%o2 add %l0,-1,%o0 cmp %o2,%o0 bge L37 mov %o0,%o3 L41: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,1,%o2 cmp %o2,%o3 bl L41 st %o0,[%i0+%o1] L37: ld [%i0+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l4,24,%o0 add %o1,%o0,%o1 b L67 st %o1,[%i0+4] L23: cmp %l0,3 bne L44 sll %l0,2,%l2 ld [%i1+8],%o0 cmp %o0,%l1 bleu L45 nop call _cgeti,0 mov 3,%o0 mov %o0,%i0 sll %l3,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%i1+8],%o0 sub %o0,%l1,%o0 b L67 st %o0,[%i0+8] L45: bne L46 sethi %hi(_gzero),%o0 b L67 ld [%o0+%lo(_gzero)],%i0 L46: call _cgeti,0 mov 3,%o0 mov %o0,%i0 sub %g0,%l3,%o0 sll %o0,24,%o0 add %o0,3,%o0 st %o0,[%i0+4] ld [%i1+8],%o0 sub %l1,%o0,%o0 b L67 st %o0,[%i0+8] L44: add %l2,%i1,%o0 ld [%o0-4],%o1 mov %l1,%o0 cmp %o1,%o0 bgeu L47 sub %o1,%o0,%l1 call _cgeti,0 mov %l0,%o0 mov %o0,%i0 add %l2,%i0,%o0 st %l1,[%o0-4] add %l0,-2,%o2 sll %o2,2,%o0 mov %o0,%o1 ld [%i1+%o0],%o0 cmp %o0,0 bne,a L70 sll %o2,2,%o1 mov -1,%o3 st %o3,[%i0+%o1] L71: add %o2,-1,%o2 sll %o2,2,%o1 ld [%i1+%o1],%o0 cmp %o0,0 be,a L71 st %o3,[%i0+%o1] sll %o2,2,%o1 L70: ld [%i1+%o1],%o0 add %o0,-1,%o0 cmp %o2,2 bg L54 st %o0,[%i0+%o1] cmp %o0,0 be,a L53 ld [%i0],%o0 L54: add %o2,-1,%o2 cmp %o2,0 ble L67 nop L58: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,-1,%o2 cmp %o2,0 bg L58 st %o0,[%i0+%o1] b,a L67 L53: add %o0,-1,%o0 st %o0,[%i0+4] st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(_avma),%o1 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(_avma)] ld [%i0+4],%o1 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l3,24,%o1 add %o0,%o1,%o0 b L67 st %o0,[%i0+4] L47: call _cgeti,0 mov %l0,%o0 mov %o0,%i0 sll %l0,2,%o0 add %o0,%i0,%o0 st %l1,[%o0-4] mov 1,%o2 add %l0,-1,%o0 cmp %o2,%o0 bge L67 mov %o0,%o3 L65: sll %o2,2,%o1 ld [%i1+%o1],%o0 add %o2,1,%o2 cmp %o2,%o3 bl L65 st %o0,[%i0+%o1] L67: ret restore .align 4 .global _addii .proc 0104 _addii: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 mov %i0,%l0 ld [%l0+4],%o0 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l1 ld [%i1+4],%o0 and %o0,%o1,%l2 cmp %l1,%l2 bge,a L204 ldsb [%i1+4],%o5 mov %i1,%l0 mov %i0,%i1 mov %l1,%l3 mov %l2,%l1 mov %l3,%l2 ldsb [%i1+4],%o5 L204: cmp %o5,0 bne,a L74 ldsb [%l0+4],%l3 call _icopy,0 mov %l0,%o0 b L201 mov %o0,%i0 L74: cmp %l3,%o5 bne L75 cmp %l1,%l2 call _cgeti,0 add %l1,1,%o0 mov %o0,%i0 mov 0,%o2 sll %l1,2,%o0 add %i0,%o0,%o4 add %o4,4,%o4 add %l0,%o0,%o3 sll %l2,2,%o0 add %i1,%o0,%o1 add %l2,-2,%o5 sethi %hi(L113),%o0 or %o0,%lo(L113),%g2 add %o5,-1,%o0 L220: cmp %o0,15 bgu L81 sll %o0,2,%o0 ld [%o0+%g2],%o0 jmp %o0 nop L113: .word L111 .word L109 .word L107 .word L105 .word L103 .word L101 .word L99 .word L97 .word L95 .word L93 .word L91 .word L89 .word L87 .word L85 .word L83 .word L81 L81: subcc %g0,%o2,%g0 b L82 add %o4,-4,%o4 L83: subcc %g0,%o2,%g0 b L205 add %o4,-4,%o4 L85: subcc %g0,%o2,%g0 b L206 add %o4,-4,%o4 L87: subcc %g0,%o2,%g0 b L207 add %o4,-4,%o4 L89: subcc %g0,%o2,%g0 b L208 add %o4,-4,%o4 L91: subcc %g0,%o2,%g0 b L209 add %o4,-4,%o4 L93: subcc %g0,%o2,%g0 b L210 add %o4,-4,%o4 L95: subcc %g0,%o2,%g0 b L211 add %o4,-4,%o4 L97: subcc %g0,%o2,%g0 b L212 add %o4,-4,%o4 L99: subcc %g0,%o2,%g0 b L213 add %o4,-4,%o4 L101: subcc %g0,%o2,%g0 b L214 add %o4,-4,%o4 L103: subcc %g0,%o2,%g0 b L215 add %o4,-4,%o4 L105: subcc %g0,%o2,%g0 b L216 add %o4,-4,%o4 L107: subcc %g0,%o2,%g0 b L217 add %o4,-4,%o4 L109: subcc %g0,%o2,%g0 b L218 add %o4,-4,%o4 L111: subcc %g0,%o2,%g0 b L219 add %o4,-4,%o4 L82: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L205: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L206: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L207: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L208: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L209: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L210: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L211: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L212: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L213: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L214: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L215: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L216: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L217: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L218: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L219: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 addxcc %l4,%g3,%o0 st %o0,[%o4] addx %g0,%g0,%o2 add %o5,-16,%o5 cmp %o5,0 bg,a L220 add %o5,-1,%o0 cmp %o2,0 be L115 add %l0,8,%o2 L116: add %o3,-4,%o3 cmp %o3,%o2 blu L117 mov %o3,%o1 ld [%o3],%o0 cmp %o0,-1 bne L118 add %o4,-4,%o4 b L116 st %g0,[%o4] L118: ld [%o1],%o0 b L203 add %o0,1,%o0 L122: add %o4,-4,%o4 ld [%o1],%o0 L203: st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o2 bgeu L122 mov %o3,%o1 b L221 ld [%i0],%o0 L117: mov 1,%o0 st %o0,[%i0+8] ld [%l0+4],%o0 add %o0,1,%o0 b L201 st %o0,[%i0+4] L115: subcc %l1,%l2,%o2 be,a L221 ld [%i0],%o0 L128: add %o4,-4,%o4 add %o3,-4,%o3 ld [%o3],%o0 addcc %o2,-1,%o2 bne L128 st %o0,[%o4] ld [%i0],%o0 L221: add %o0,-1,%o0 st %o0,[%i0+4] ld [%l0+4],%o0 st %o0,[%i0+8] add %i0,4,%i0 sethi %hi(_avma),%o1 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 b L201 st %o0,[%o1+%lo(_avma)] L75: bne L131 add %l0,8,%o3 addcc %l1,-2,%o2 be L140 add %i1,8,%o1 ld [%o3],%o4 L222: add %o3,4,%o3 ld [%o1],%o0 cmp %o0,%o4 bgu L202 add %o1,4,%o1 cmp %o4,%o0 bgu L131 addcc %o2,-1,%o2 bne,a L222 ld [%o3],%o4 L140: sethi %hi(_gzero),%o0 b L201 ld [%o0+%lo(_gzero)],%i0 L202: mov %l0,%i0 mov %i1,%l0 mov %i0,%i1 mov %o5,%l3 L131: call _cgeti,0 mov %l1,%o0 mov %o0,%i0 mov 0,%o2 sll %l1,2,%o0 add %l0,%o0,%o3 sll %l2,2,%o1 add %i1,%o1,%o1 add %i0,%o0,%o4 add %l2,-2,%o5 sethi %hi(L178),%o0 or %o0,%lo(L178),%g2 add %o5,-1,%o0 L238: cmp %o0,15 bgu L146 sll %o0,2,%o0 ld [%o0+%g2],%o0 jmp %o0 nop L178: .word L176 .word L174 .word L172 .word L170 .word L168 .word L166 .word L164 .word L162 .word L160 .word L158 .word L156 .word L154 .word L152 .word L150 .word L148 .word L146 L146: subcc %g0,%o2,%g0 b L147 add %o4,-4,%o4 L148: subcc %g0,%o2,%g0 b L223 add %o4,-4,%o4 L150: subcc %g0,%o2,%g0 b L224 add %o4,-4,%o4 L152: subcc %g0,%o2,%g0 b L225 add %o4,-4,%o4 L154: subcc %g0,%o2,%g0 b L226 add %o4,-4,%o4 L156: subcc %g0,%o2,%g0 b L227 add %o4,-4,%o4 L158: subcc %g0,%o2,%g0 b L228 add %o4,-4,%o4 L160: subcc %g0,%o2,%g0 b L229 add %o4,-4,%o4 L162: subcc %g0,%o2,%g0 b L230 add %o4,-4,%o4 L164: subcc %g0,%o2,%g0 b L231 add %o4,-4,%o4 L166: subcc %g0,%o2,%g0 b L232 add %o4,-4,%o4 L168: subcc %g0,%o2,%g0 b L233 add %o4,-4,%o4 L170: subcc %g0,%o2,%g0 b L234 add %o4,-4,%o4 L172: subcc %g0,%o2,%g0 b L235 add %o4,-4,%o4 L174: subcc %g0,%o2,%g0 b L236 add %o4,-4,%o4 L176: subcc %g0,%o2,%g0 b L237 add %o4,-4,%o4 L147: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L223: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L224: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L225: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L226: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L227: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L228: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L229: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L230: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L231: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L232: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L233: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L234: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L235: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L236: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] add %o4,-4,%o4 L237: add %o3,-4,%o3 add %o1,-4,%o1 ld [%o3],%l4 ld [%o1],%g3 subxcc %l4,%g3,%o0 st %o0,[%o4] addx %g0,%g0,%o2 add %o5,-16,%o5 cmp %o5,0 bg,a L238 add %o5,-1,%o0 cmp %o2,0 be,a L180 subcc %l1,%l2,%o5 add %o3,-4,%o3 ld [%o3],%o0 cmp %o0,0 bne L239 add %l0,8,%o1 mov -1,%o1 add %o4,-4,%o4 L240: st %o1,[%o4] add %o3,-4,%o3 ld [%o3],%o0 cmp %o0,0 be,a L240 add %o4,-4,%o4 add %l0,8,%o1 L239: cmp %o3,%o1 blu L190 add %o0,-1,%o0 add %o4,-4,%o4 st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o1 blu L190 mov %o3,%o0 L188: add %o4,-4,%o4 ld [%o0],%o0 st %o0,[%o4] add %o3,-4,%o3 cmp %o3,%o1 bgeu L188 mov %o3,%o0 b L241 ld [%i0+8],%o0 L180: be,a L241 ld [%i0+8],%o0 L193: add %o4,-4,%o4 add %o3,-4,%o3 ld [%o3],%o0 addcc %o5,-1,%o5 bne L193 st %o0,[%o4] L190: ld [%i0+8],%o0 L241: cmp %o0,0 be,a L195 ld [%i0+12],%o0 ld [%l0+4],%o0 b L201 st %o0,[%i0+4] L195: cmp %o0,0 bne L198 add %i0,12,%o4 add %o4,4,%o4 L242: ld [%o4],%o0 cmp %o0,0 be,a L242 add %o4,4,%o4 L198: add %o4,-8,%o4 sub %o4,%i0,%o5 sra %o5,2,%o5 ld [%i0],%o1 sub %o1,%o5,%o1 st %o1,[%o4] st %o1,[%o4+4] mov %o4,%i0 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l3,24,%o1 add %o0,%o1,%o0 st %o0,[%i0+4] sethi %hi(_avma),%o2 sll %o5,2,%o0 ld [%o2+%lo(_avma)],%o1 add %o0,%o1,%o0 st %o0,[%o2+%lo(_avma)] L201: ret restore .align 4 .global _mulss .proc 0104 _mulss: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 orcc %i0,%g0,%o0 be L245 cmp %i1,0 bne L244 cmp %o0,0 L245: sethi %hi(_gzero),%o0 b L253 ld [%o0+%lo(_gzero)],%i0 L244: bge L246 mov 1,%l0 subcc %g0,%o0,%o0 bpos L246 mov -1,%l0 call _stoi,0 nop mov %o0,%o1 b L254 mov %i1,%o0 L246: cmp %i1,0 bge L255 mov %o0,%l1 subcc %g0,%i1,%i1 bpos L255 sub %g0,%l0,%l0 cmp %l0,0 bg L250 mov %o0,%o1 sub %g0,%o0,%o1 L250: mov %o1,%o0 sethi %hi(_ABS_MOST_NEGS),%o1 or %o1,%lo(_ABS_MOST_NEGS),%o1 L254: call _mulsi,0 nop b L253 mov %o0,%i0 L255: or %l1,%i1,%o4 mov %l1,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 tst %i1 bl,a 1f add %o4,%l1,%o4 1: mov %o4,%o2 b 3f rd %y,%l1 2: clr %o2 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%l1 3: orcc %o2,%g0,%i1 be L251 nop call _cgeti,0 mov 4,%o0 mov %o0,%i0 st %i1,[%i0+8] b L252 st %l1,[%i0+12] L251: call _cgeti,0 mov 3,%o0 mov %o0,%i0 st %l1,[%i0+8] L252: ld [%i0],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l0,24,%o0 add %o1,%o0,%o1 st %o1,[%i0+4] L253: ret restore .align 4 .global _mulii .proc 0104 _mulii: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 mov %i0,%l4 ld [%l4+4],%o0 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l0 ld [%i1+4],%o2 sra %o0,24,%l2 cmp %l2,0 be L276 and %o2,%o1,%l3 ldsb [%i1+4],%o0 cmp %o0,0 bne L258 nop L276: sethi %hi(_gzero),%o0 b L275 ld [%o0+%lo(_gzero)],%i0 L258: bl,a L259 sub %g0,%l2,%l2 L259: cmp %l0,%l3 ble L260 sethi %hi(65535),%o0 mov %l4,%i0 mov %i1,%l4 mov %i0,%i1 mov %l0,%l1 mov %l3,%l0 mov %l1,%l3 L260: add %l0,%l3,%l1 add %l1,-2,%l1 or %o0,%lo(65535),%o0 cmp %l1,%o0 ble L261 nop call _err,0 mov 17,%o0 L261: call _cgeti,0 mov %l1,%o0 mov %o0,%i0 ld [%i0],%o1 sethi %hi(-16777216),%o0 andn %o1,%o0,%o0 sll %l2,24,%o1 add %o0,%o1,%o0 st %o0,[%i0+4] sll %l0,2,%o0 add %l4,%o0,%l2 add %l2,-4,%l2 ld [%l2],%o2 mov 0,%o3 sll %l3,2,%o0 add %i1,%o0,%o7 sll %l1,2,%o0 addcc %l3,-2,%g2 be L263 add %i0,%o0,%g4 L264: add %g4,-4,%g4 mov %o3,%o0 add %o7,-4,%o7 ld [%o7],%o1 mov %o2,%l5 or %l5,%o1,%o4 mov %l5,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%g0,%o4 tst %o1 bl,a 1f add %o4,%l5,%o4 1: mov %o4,%o3 b 3f rd %y,%l5 2: clr %o3 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%o1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%l5 3: mov %l5,%o1 addcc %o0,%o1,%l5 addx %o3,%g0,%o3 addcc %g2,-1,%g2 bne L264 st %l5,[%g4] L263: st %o3,[%g4-4] sll %l1,2,%o0 add %i0,%o0,%g4 sll %l3,2,%o0 add %i1,%o0,%i1 add %l0,-3,%l0 cmp %l0,0 ble L267 add %l3,-1,%l3 L268: add %l2,-4,%l2 ld [%l2],%g1 mov %i1,%o7 add %g4,-4,%o2 mov %o2,%g4 addcc %l3,-1,%g2 be L270 mov 0,%g3 L271: add %o7,-4,%o7 ld [%o7],%o0 mov %o0,%o1 or %o1,%g1,%o4 mov %o1,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g0,%o4 tst %g1 bl,a 1f add %o4,%o1,%o4 1: mov %o4,%o3 b 3f rd %y,%o1 2: clr %o3 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o1 3: add %o2,-4,%o2 ld [%o2],%o0 addcc %o1,%o0,%o0 addx %o3,%g0,%o3 addcc %o0,%g3,%l5 addx %o3,%g0,%o3 st %l5,[%o2] addcc %g2,-1,%g2 bne L271 mov %o3,%g3 L270: add %l0,-1,%l0 cmp %l0,0 bg L268 st %o3,[%o2-4] L267: ld [%i0+8],%o0 cmp %o0,0 bne L275 sethi %hi(_avma),%o1 ld [%i0+4],%o0 add %o0,-1,%o0 st %o0,[%i0+8] ld [%i0],%o0 add %o0,-1,%o0 st %o0,[%i0+4] add %i0,4,%i0 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(_avma)] L275: ret restore .data .align 8 LC0: .word 0x3fd34413 .word 0x55475a32 .align 8 LC1: .word 0x3ff00000 .word 0x0 .text .align 4 .global _confrac .proc 0104 _confrac: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 ld [%i0],%o1 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 and %o1,%o0,%l2 ld [%i0+4],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sethi %hi(8388607),%o0 or %o0,%lo(8388607),%o0 sub %o0,%o1,%l0 sethi %hi(_avma),%o0 ld [%o0+%lo(_avma)],%l5 add %l2,-2,%l4 sll %l4,5,%l4 add %l4,%l0,%l4 add %l4,63,%l3 sra %l3,5,%l3 call _cgeti,0 mov %l3,%o0 sra %l0,5,%o1 mov 0,%g2 cmp %g2,%o1 bge L279 mov %o0,%l1 L281: sll %g2,2,%o0 add %g2,1,%g2 cmp %g2,%o1 bl L281 st %g0,[%l1+%o0] L279: andcc %l0,31,%l0 bne L283 mov 2,%g3 cmp %g3,%l2 bge L305 sll %l3,2,%o0 L287: sll %g2,2,%o0 sll %g3,2,%o1 ld [%i0+%o1],%o1 st %o1,[%l1+%o0] add %g3,1,%g3 cmp %g3,%l2 bl L287 add %g2,1,%g2 b L305 sll %l3,2,%o0 L283: cmp %g3,%l2 bge L291 mov 0,%o3 mov 32,%o0 sub %o0,%l0,%o4 L293: sll %g2,2,%o1 sll %g3,2,%o0 ld [%i0+%o0],%o2 add %g2,1,%g2 srl %o2,%l0,%o0 add %o0,%o3,%o0 st %o0,[%l1+%o1] add %g3,1,%g3 cmp %g3,%l2 bl L293 sll %o2,%o4,%o3 L291: sll %l3,2,%o0 add %o0,%l1,%o0 st %o3,[%o0-8] sll %l3,2,%o0 L305: add %o0,%l1,%o0 st %g0,[%o0-4] st %l4,[%fp-12] ld [%fp-12],%f6 fitod %f6,%f2 sethi %hi(LC0),%l6 ldd [%l6+%lo(LC0)],%f4 fmuld %f2,%f4,%f2 sethi %hi(LC1),%l6 ldd [%l6+%lo(LC1)],%f4 faddd %f2,%f4,%f2 fdtoi %f2,%f2 st %f2,[%fp-12] ld [%fp-12],%l0 add %l0,17,%l2 mov %l2,%o0 call .div,0 mov 9,%o1 call _cgeti,0 mov %o0,%l2 mov %o0,%i0 mov 1,%g3 cmp %g3,%l2 bge L296 st %l0,[%i0] L298: addcc %l3,-1,%g2 bneg L300 mov 0,%o3 sethi %hi(1000000000),%o0 or %o0,%lo(1000000000),%o7 L302: sll %g2,2,%o1 mov %o3,%o2 ld [%l1+%o1],%o0 or %o0,%o7,%o4 mov %o0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 tst %o7 bl,a 1f add %o4,%o0,%o4 1: mov %o4,%o3 b 3f rd %y,%o0 2: clr %o3 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%o7,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o0 3: addcc %o2,%o0,%l6 addx %o3,%g0,%o3 addcc %g2,-1,%g2 bpos L302 st %l6,[%l1+%o1] L300: sll %g3,2,%o0 add %g3,1,%g3 cmp %g3,%l2 bl L298 st %o3,[%i0+%o0] L296: sethi %hi(_avma),%o0 st %l5,[%o0+%lo(_avma)] ret restore .align 4 .global _divss .proc 0104 _divss: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 cmp %i1,0 bne L315 sethi %hi(-2147483648),%o0 call _err,0 mov 23,%o0 sethi %hi(-2147483648),%o0 L315: cmp %i0,%o0 bne L308 sethi %hi(_hiremainder),%o0 call _stoi,0 mov %i0,%o0 call _divis,0 mov %i1,%o1 b L316 mov %o0,%i0 L308: st %g0,[%o0+%lo(_hiremainder)] cmp %i0,0 bge L309 mov %i0,%o0 sub %g0,%i0,%o0 L309: cmp %i1,0 bge L310 mov %i1,%o1 sub %g0,%i1,%o1 L310: sethi %hi(_hiremainder),%l0 call _divul3,0 or %l0,%lo(_hiremainder),%o2 cmp %i1,0 bge L311 mov %o0,%o1 ld [%l0+%lo(_hiremainder)],%o0 sub %g0,%o0,%o0 st %o0,[%l0+%lo(_hiremainder)] sub %g0,%o1,%o1 L311: cmp %i0,0 bl,a L312 sub %g0,%o1,%o1 L312: call _stoi,0 mov %o1,%o0 mov %o0,%i0 L316: ret restore .align 4 .global _modss .proc 0104 _modss: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 cmp %i1,0 bne L327 sethi %hi(-2147483648),%o0 call _err,0 mov 38,%o0 sethi %hi(-2147483648),%o0 L327: cmp %i0,%o0 bne L319 mov %i0,%o0 call _stoi,0 mov %i0,%o0 call _modis,0 mov %i1,%o1 b L325 mov %o0,%i0 L319: cmp %o0,0 bge L320 st %g0,[%fp-12] sub %g0,%o0,%o0 L320: cmp %i1,0 bl,a L321 sub %g0,%i1,%i1 L321: mov %i1,%o1 call _divul3,0 add %fp,-12,%o2 ld [%fp-12],%o0 cmp %o0,0 bne L322 nop sethi %hi(_gzero),%o0 b L325 ld [%o0+%lo(_gzero)],%i0 L322: bge,a L326 ld [%fp-12],%o0 sub %i1,%o0,%o0 L326: call _stoi,0 nop mov %o0,%i0 L325: ret restore .align 4 .global _resss .proc 0104 _resss: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 cmp %i1,0 bne L335 mov %i0,%o0 call _err,0 mov 40,%o0 mov %i0,%o0 L335: cmp %o0,0 bge L330 st %g0,[%fp-12] sub %g0,%o0,%o0 L330: cmp %i1,0 bge L331 mov %i1,%o1 sub %g0,%i1,%o1 L331: call _divul3,0 add %fp,-12,%o2 cmp %i1,0 bge L334 ld [%fp-12],%o0 sub %g0,%o0,%o0 L334: call _stoi,0 nop mov %o0,%i0 ret restore .align 4 .global _divsi .proc 0104 _divsi: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 ld [%i1+4],%o0 sra %o0,24,%o2 sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 cmp %o2,0 bne L337 and %o0,%o1,%l0 call _err,0 mov 24,%o0 L337: cmp %i0,0 be L339 cmp %l0,3 bg L346 sethi %hi(_hiremainder),%o0 ld [%i1+8],%o0 cmp %o0,0 bge L338 sethi %hi(-2147483648),%o0 L339: sethi %hi(_hiremainder),%o0 L346: st %i0,[%o0+%lo(_hiremainder)] sethi %hi(_gzero),%o0 b L344 ld [%o0+%lo(_gzero)],%i0 L338: cmp %i0,%o0 bne L340 sethi %hi(_hiremainder),%o0 call _stoi,0 mov %i0,%o0 mov %i1,%o1 call _dvmdii,0 mov 0,%o2 b L344 mov %o0,%i0 L340: st %g0,[%o0+%lo(_hiremainder)] cmp %i0,0 bge L341 mov %i0,%o0 sub %g0,%i0,%o0 L341: ld [%i1+8],%o1 sethi %hi(_hiremainder),%l0 call _divul3,0 or %l0,%lo(_hiremainder),%o2 mov %o0,%o1 ldsb [%i1+4],%o0 cmp %o0,0 bge L347 cmp %i0,0 ld [%l0+%lo(_hiremainder)],%o0 sub %g0,%o0,%o0 st %o0,[%l0+%lo(_hiremainder)] sub %g0,%o1,%o1 L347: bl,a L343 sub %g0,%o1,%o1 L343: call _stoi,0 mov %o1,%o0 mov %o0,%i0 L344: ret restore .align 4 .global _divis .proc 0104 _divis: !#PROLOGUE# 0 save %sp,-112,%sp !#PROLOGUE# 1 ld [%i0+4],%o1 sra %o1,24,%l4 sethi %hi(65535),%o0 or %o0,%lo(65535),%o0 cmp %i1,0 bne L349 and %o1,%o0,%l3 call _err,0 mov 26,%o0 L349: cmp %l4,0 bne L350 cmp %i1,0 sethi %hi(_hiremainder),%o0 b L365 st %g0,[%o0+%lo(_hiremainder)] L350: bge,a L366 ld [%i0+8],%o0 subcc %g0,%i1,%i1 bpos L351 sub %g0,%l4,%l4 call _stoi,0 mov %i1,%o0 mov %o0,%o1 mov %i0,%o0 call _dvmdii,0 mov 0,%o2 b L364 mov %o0,%i0 L351: ld [%i0+8],%o0 L366: cmp %i1,%o0 bleu L353 cmp %l3,3 bne L354 sethi %hi(_hiremainder),%l0 call _itos,0 mov %i0,%o0 st %o0,[%l0+%lo(_hiremainder)] L365: sethi %hi(_gzero),%o0 b L364 ld [%o0+%lo(_gzero)],%i0 L354: call _cgeti,0 add %l3,-1,%o0 mov %o0,%l2 mov 1,%l1 ld [%i0+8],%o0 b L356 st %o0,[%fp-12] L353: call _cgeti,0 mov %l3,%o0 mov %o0,%l2 mov 0,%l1 st %g0,[%fp-12] L356: add %l1,2,%l0 cmp %l0,%l3 bge,a L367 ld [%l2],%o0 L360: sll %l0,2,%o0 ld [%i0+%o0],%o0 mov %i1,%o1 call _divul3,0 add %fp,-12,%o2 sub %l0,%l1,%o1 sll %o1,2,%o1 add %l0,1,%l0 cmp %l0,%l3 bl L360 st %o0,[%l2+%o1] ld [%l2],%o0 L367: sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 sll %l4,24,%o0 add %o1,%o0,%o1 st %o1,[%l2+4] sethi %hi(_hiremainder),%o1 cmp %l4,0 bge L362 or %o1,%lo(_hiremainder),%o2 ld [%fp-12],%o0 sub %g0,%o0,%o0 b L363 st %o0,[%o1+%lo(_hiremainder)] L362: ld [%fp-12],%o0 st %o0,[%o2] L363: mov %l2,%i0 L364: ret restore .align 4 .global _dvmdii .proc 0104 _dvmdii: !#PROLOGUE# 0 save %sp,-144,%sp !#PROLOGUE# 1 mov %i2,%i4 ldsb [%i0+4],%g4 st %g4,[%fp-28] ldsb [%i1+4],%g1 cmp %g1,0 bne L369 st %g1,[%fp-36] call _err,0 mov 36,%o0 L369: ld [%fp-28],%g4 cmp %g4,0 bne,a L370 ld [%i0+4],%o0 cmp %i4,-1 be L471 cmp %i4,0 be L471 sethi %hi(_gzero),%o1 ld [%o1+%lo(_gzero)],%o0 st %o0,[%i4] b L470 ld [%o1+%lo(_gzero)],%i0 L370: sethi %hi(65535),%o1 or %o1,%lo(65535),%o1 and %o0,%o1,%l6 ld [%i1+4],%o0 and %o0,%o1,%i3 subcc %l6,%i3,%i5 bpos,a L373 sethi %hi(_avma),%o0 cmp %i4,-1 bne L374 cmp %i4,0 call _icopy,0 mov %i0,%o0 b L470 mov %o0,%i0 L374: be L477 sethi %hi(_gzero),%o0 call _icopy,0 mov %i0,%o0 b L471 st %o0,[%i4] L373: ld [%o0+%lo(_avma)],%o0 st %o0,[%fp-20] ld [%fp-28],%g1 cmp %g1,0 bge L478 cmp %i3,3 ld [%fp-36],%g4 sub %g0,%g4,%g4 st %g4,[%fp-36] L478: bne L377 nop ld [%i1+8],%i1 ld [%i0+8],%o0 cmp %i1,%o0 bleu L378 add %i0,8,%l1 add %l6,-1,%l0 st %o0,[%fp-12] b L379 add %i0,12,%l1 L378: mov %l6,%l0 st %g0,[%fp-12] L379: call _cgeti,0 mov %l0,%o0 mov %o0,%l5 addcc %l0,-2,%l3 be L381 add %l5,8,%l2 L382: ld [%l1],%o0 add %l1,4,%l1 mov %i1,%o1 call _divul3,0 add %fp,-12,%o2 st %o0,[%l2] addcc %l3,-1,%l3 bne L382 add %l2,4,%l2 L381: cmp %i4,-1 bne L384 cmp %l0,2 sethi %hi(_avma),%o0 ld [%fp-20],%g1 st %g1,[%o0+%lo(_avma)] ld [%fp-12],%o0 cmp %o0,0 bne L385 nop L471: sethi %hi(_gzero),%o0 L477: b L470 ld [%o0+%lo(_gzero)],%i0 L385: call _cgeti,0 mov 3,%o0 mov %o0,%l4 ld [%fp-28],%g4 sll %g4,24,%o0 add %o0,3,%o0 st %o0,[%l4+4] ld [%fp-12],%o0 st %o0,[%l4+8] b L470 mov %l4,%i0 L384: be L386 sethi %hi(-16777216),%o1 ld [%l5],%o0 andn %o0,%o1,%o1 ld [%fp-36],%g1 sll %g1,24,%o0 add %o1,%o0,%o1 b L387 st %o1,[%l5+4] L386: sethi %hi(_avma),%o0 ld [%fp-20],%g4 st %g4,[%o0+%lo(_avma)] sethi %hi(_gzero),%o0 ld [%o0+%lo(_gzero)],%l5 L387: cmp %i4,0 bne L388 ld [%fp-12],%o0 L473: b L470 mov %l5,%i0 L388: cmp %o0,0 bne L389 sethi %hi(_gzero),%o0 ld [%o0+%lo(_gzero)],%o0 b L473 st %o0,[%i4] L389: call _cgeti,0 mov 3,%o0 mov %o0,%l4 ld [%fp-28],%g1 sll %g1,24,%o0 add %o0,3,%o0 st %o0,[%l4+4] ld [%fp-12],%o0 st %o0,[%l4+8] b L473 st %l4,[%i4] L377: call _cgeti,0 mov %l6,%o0 mov %o0,%l5 call _bfffo,0 ld [%i1+8],%o0 orcc %o0,%g0,%i2 be L392 add %i0,8,%l1 call _cgeti,0 mov %i3,%o0 mov %o0,%l4 ld [%i1+8],%o3 add %i1,12,%o1 mov 32,%o0 sub %o0,%i2,%o0 srl %o3,%o0,%o0 st %o0,[%fp-12] sll %o3,%i2,%g2 addcc %i3,-3,%l3 be L394 add %l4,8,%o2 mov 32,%o0 sub %o0,%i2,%o4 L395: ld [%o1],%o3 add %o1,4,%o1 srl %o3,%o4,%o0 st %o0,[%fp-12] add %g2,%o0,%o0 st %o0,[%o2] add %o2,4,%o2 addcc %l3,-1,%l3 bne L395 sll %o3,%i2,%g2 L394: st %g2,[%o2] mov 0,%g2 add %i0,8,%l1 addcc %l6,-2,%l3 be L398 add %l5,4,%l2 mov 32,%o0 sub %o0,%i2,%o1 L399: ld [%l1],%o3 add %l1,4,%l1 srl %o3,%o1,%o0 st %o0,[%fp-12] add %g2,%o0,%o0 st %o0,[%l2] add %l2,4,%l2 addcc %l3,-1,%l3 bne L399 sll %o3,%i2,%g2 L398: b L401 st %g2,[%l2] L392: st %g0,[%l5+4] addcc %l6,-2,%l0 be L403 add %l5,8,%l2 L404: ld [%l1],%o0 st %o0,[%l2] add %l1,4,%l1 addcc %l0,-1,%l0 bne L404 add %l2,4,%l2 L403: mov %i1,%l4 L401: ld [%l4+8],%i1 ld [%l4+12],%i0 addcc %i5,1,%l3 be L407 add %l5,4,%l2 sll %i3,2,%l1 L408: ld [%l2],%o0 cmp %o0,%i1 bne L409 add %l2,4,%l2 mov -1,%o7 mov %i1,%o3 ld [%l2],%o0 add %o3,%o0,%o1 cmp %o1,%o3 addx %g0,0,%o2 b L410 mov %o1,%g2 L409: ld [%l2-4],%o0 st %o0,[%fp-12] ld [%l2],%o0 mov %i1,%o1 call _divul3,0 add %fp,-12,%o2 mov %o0,%o7 mov 0,%o2 ld [%fp-12],%g2 L410: cmp %o2,0 bne,a L479 st %g0,[%fp-12] mov %o7,%o3 or %o3,%i0,%o4 mov %o3,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%g0,%o4 tst %i0 bl,a 1f add %o4,%o3,%o4 1: mov %o4,%g4 b 3f rd %y,%o3 2: clr %g4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%i0,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o3 3: st %g4,[%fp-12] ld [%l2+4],%o0 cmp %o3,%o0 addx %g0,0,%o2 sub %o3,%o0,%o4 ld [%fp-12],%o3 mov %g2,%o0 sub %o3,%g2,%o1 cmp %g2,%o3 bgu L476 sub %o1,%o2,%o1 b L480 cmp %o0,%o3 L424: be L411 mov %o4,%o3 add %o7,-1,%o7 mov %i0,%o0 cmp %o3,%o0 addx %g0,0,%o2 sub %o3,%o0,%o4 mov %o1,%o3 mov %i1,%o0 sub %o3,%o0,%o1 cmp %o0,%o3 bleu L480 sub %o1,%o2,%o1 L476: b L421 mov 1,%o2 L480: blu,a L421 mov 0,%o2 L421: cmp %o2,0 be L424 cmp %o1,0 L411: st %g0,[%fp-12] L479: add %l2,%l1,%g2 add %g2,-8,%g2 addcc %i3,-2,%l0 be L426 add %l4,%l1,%g3 L427: ld [%fp-12],%o3 add %g3,-4,%g3 ld [%g3],%o0 mov %o7,%o1 or %o1,%o0,%o4 mov %o1,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%g0,%o4 tst %o0 bl,a 1f add %o4,%o1,%o4 1: mov %o4,%g1 b 3f rd %y,%o1 2: clr %g1 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%o0,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%o1 3: st %g1,[%fp-12] mov %g1,%g4 addcc %o3,%o1,%o2 addx %g4,%g0,%g4 st %g4,[%fp-12] add %g2,-4,%g2 ld [%g2],%o3 sub %o3,%o2,%o1 cmp %o3,%o2 st %o1,[%g2] ld [%fp-12],%o0 addx %g0,%o0,%o0 addcc %l0,-1,%l0 bne L427 st %o0,[%fp-12] L426: ld [%l2-4],%o1 ld [%fp-12],%o0 cmp %o1,%o0 bgeu,a L481 addcc %l3,-1,%l3 mov 0,%o2 add %o7,-1,%o7 add %l2,%l1,%g2 add %g2,-8,%g2 addcc %i3,-2,%l0 be L429 add %l4,%l1,%g3 add %g2,-4,%g2 L482: subcc %g0,%o2,%g0 add %g3,-4,%g3 ld [%g2],%g1 ld [%g3],%g4 addxcc %g1,%g4,%o0 st %o0,[%g2] addx %g0,%g0,%o2 addcc %l0,-1,%l0 bne,a L482 add %g2,-4,%g2 L429: addcc %l3,-1,%l3 L481: bne L408 st %o7,[%l2-4] L407: sethi %hi(_avma),%o0 cmp %i4,-1 be L435 ld [%o0+%lo(_avma)],%l4 add %i5,2,%l1 sll %l1,2,%o0 add %l5,%o0,%l2 ld [%l5+4],%o0 cmp %o0,0 be L436 cmp %i5,0 b L437 add %i5,3,%l1 L436: be,a L437 st %g0,[%fp-36] L437: call _cgeti,0 mov %l1,%o0 st %o0,[%fp-44] sll %l1,2,%o0 ld [%fp-44],%g1 addcc %l1,-2,%l0 be L440 add %g1,%o0,%o1 L441: add %o1,-4,%o1 add %l2,-4,%l2 ld [%l2],%o0 addcc %l0,-1,%l0 bne L441 st %o0,[%o1] L440: cmp %l1,2 bgu L443 mov 2,%o0 ld [%fp-44],%g4 b L435 st %o0,[%g4+4] L443: ld [%fp-44],%g1 ld [%g1],%o0 sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 ld [%fp-36],%g4 sll %g4,24,%o0 add %o1,%o0,%o1 st %o1,[%g1+4] L435: cmp %i4,0 be L483 cmp %i4,-1 add %i5,2,%l0 cmp %l0,%l6 bge L484 sll %l0,2,%o0 ld [%l5+%o0],%o0 cmp %o0,0 bne L484 cmp %l0,%l6 add %i5,3,%l0 L448: cmp %l0,%l6 bge L484 sll %l0,2,%o0 ld [%l5+%o0],%o0 cmp %o0,0 be,a L448 add %l0,1,%l0 cmp %l0,%l6 L484: bne L452 sub %l6,%l0,%o0 sethi %hi(_gzero),%o0 call _icopy,0 ld [%o0+%lo(_gzero)],%o0 b L445 mov %o0,%l7 L452: call _cgeti,0 add %o0,2,%o0 mov %o0,%l7 ld [%l7],%o0 cmp %i2,0 bne L454 st %o0,[%l7+4] cmp %l0,%l6 bge L460 mov 2,%l3 L458: sll %l3,2,%o0 sll %l0,2,%o1 ld [%l5+%o1],%o1 st %o1,[%l7+%o0] add %l0,1,%l0 cmp %l0,%l6 bl L458 add %l3,1,%l3 b L485 ld [%l7+4],%o0 L454: st %g0,[%fp-12] sll %l0,2,%o0 ld [%l5+%o0],%o3 add %l0,1,%l0 mov 32,%o0 sub %o0,%i2,%o0 sll %o3,%o0,%o0 st %o0,[%fp-12] srl %o3,%i2,%o2 cmp %o2,0 be L461 mov %o0,%g2 st %o2,[%l7+8] b L462 mov 1,%o0 L461: ld [%l7],%o0 add %o0,-1,%o0 st %o0,[%l7+4] add %l7,4,%l7 sethi %hi(_avma),%o1 ld [%o1+%lo(_avma)],%o0 add %o0,4,%o0 st %o0,[%o1+%lo(_avma)] ld [%l7],%o0 st %o0,[%l7+4] mov 0,%o0 L462: cmp %l0,%l6 bge L460 add %o0,2,%l3 mov 32,%o0 sub %o0,%i2,%o4 L466: sll %l3,2,%o2 sll %l0,2,%o0 ld [%l5+%o0],%o3 sll %o3,%o4,%o1 st %o1,[%fp-12] srl %o3,%i2,%o0 add %o0,%g2,%o0 st %o0,[%l7+%o2] mov %o1,%g2 add %l0,1,%l0 cmp %l0,%l6 bl L466 add %l3,1,%l3 L460: ld [%l7+4],%o0 L485: sethi %hi(-16777216),%o1 andn %o0,%o1,%o1 ld [%fp-28],%g1 sll %g1,24,%o0 add %o1,%o0,%o1 st %o1,[%l7+4] L445: cmp %i4,-1 L483: bne L468 cmp %i4,0 ld [%fp-20],%o0 mov %l4,%o1 b L475 mov %l7,%o2 L468: be L469 ld [%fp-20],%o0 mov %l4,%o1 call _gerepile,0 mov 0,%o2 and %o0,-4,%o0 add %l7,%o0,%o1 st %o1,[%i4] ld [%fp-44],%g4 b L470 add %g4,%o0,%i0 L469: mov %l4,%o1 ld [%fp-44],%o2 L475: call _gerepile,0 nop mov %o0,%i0 L470: ret restore .align 4 .global _mulul3 .proc 016 _mulul3: !#PROLOGUE# 0 save %sp,-104,%sp !#PROLOGUE# 1 or %i0,%i1,%o4 mov %i0,%y andncc %o4,0xfff,%g0 be 2f andcc %g0,%g0,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 tst %i1 bl,a 1f add %o4,%i0,%o4 1: mov %o4,%g2 b 3f rd %y,%i0 2: clr %g2 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%i1,%o4 mulscc %o4,%g0,%o4 rd %y,%o5 sll %o4,12,%o4 srl %o5,20,%o5 or %o5,%o4,%i0 3: st %g2,[%i2] ret restore gcl-2.6.14/mp/mp_shiftl.c0000755000175000017500000000172014360276512013543 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ typedef unsigned plong ulong; ulong hiremainder,overflow; int shiftl(x,y) ulong x,y; { hiremainder=x>>(32-y);return (x<>y); } gcl-2.6.14/mp/mp_dblrul3.c0000755000175000017500000000176414360276512013631 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "config.h" #include "genpari.h" #include "arith.h" unsigned plong dblremul3(x,y,z) int x,y,z; { unsigned plong h; unsigned plong w = mulul(x,y,h); w; /* ignore quotient */ divul(x,z,h); return h; } gcl-2.6.14/mp/mp_divul3.c0000755000175000017500000000362614360276512013467 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* ulong low,divisor,h,q; if divisor!= 0 and if (hiremainder:low)/divisor (ie q) is expressible in 32 bits, then (h = hiremainder, q = divll(low,divisor), h:low == q * divisor + hiremainder && 0<= hiremainder && hiremainder < divisor) is TRUE. [the arithmetic is ordinary arithmetic among unsigned 64 bit integers] A sufficient criteria for (hiremainder:low)/divisor to be expressible in 32 bits, is bfffo(divisor)-bfffo(hiremainder) <= 0 */ #include "include.h" #include "arith.h" #define WORD_SIZE 32 /* SHIFT1BIT: shift h and l left by 1 as 64 bits. We don't care what is coming into the bottom word */ #define shift1bit(h,l) \ l = (h = h << 1, ( l & (1<<(WORD_SIZE -1)) ? h +=1 : 0), l<<1) ulong divul3(x,y,hi) ulong x,y,*hi; {ulong q =0; ulong h = *hi,l=x,hibit; int count = WORD_SIZE; /* if (y<=h) printf("error: the quotient will be more than 32 bits"); */ #ifdef QUICK_DIV QUICK_DIV(x,y,h,hi) #endif do { q = q << 1; hibit = h & (1 << (WORD_SIZE -1)); shift1bit(h,l); if (hibit || (y <= h)) { q += 1; h -= y;} } while(--count > 0); *hi = h; return q; } gcl-2.6.14/mp/gnulib1.c0000755000175000017500000000200714360276512013116 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ double __adddf3 (a, b) double a, b; { return a + b; } double __floatsidf (a) int a; { return (double) a; } #ifndef __GO32__ int __fixdfsi (a) double a; { return (int) a; } #endif double __muldf3 (a, b) double a, b; { return a * b; } gcl-2.6.14/mp/lo-u370_aix.s0000755000175000017500000000242614360276512013551 0ustar cammcamm* --- Copyright W. Schelter 1991 --# file_ lo-aix370.c entry $oVhc2_1r $oVhc2_1r equ 0 entry $oVO $oVO equ 0 L$$C0 csect ds 0d L00$TEXT equ * entry _divsl3 * -------------| divsl3 |-----------------------# ds 0f dc al2(0) arglength in words dc xl2'FFFF' argument regs unknown dc al4(LE$1-_divsl3) code size dc xl2'0000' no flags currently defined dc al1(3) parmlength in words dc al1(1) format _divsl3 ds 0h LX$011 equ * using LX$011,12 stm LR$1,15,x'10'+LV$1(13) lr 12,13 la 11,x'60' slr 13,11 st 12,4(,13) lr 12,15 lr 15,0 l 14,0(,2) dr 14,1 lr 0,15 st 14,0(,2) lm LR$1,14,x'70'+LV$1(13) br 14 LE$1 equ * LR$1 equ 2 LV$1 equ 0 entry _mulul3 * -------------| mulul3 |-----------------------# ds 0f dc al2(0) arglength in words dc xl2'FFFF' argument regs unknown dc al4(LE$2-_mulul3) code size dc xl2'0000' no flags currently defined dc al1(3) parmlength in words dc al1(1) format _mulul3 ds 0h LX$021 equ * using LX$021,12 stm LR$2,15,x'10'+LV$2(13) lr 12,13 la 11,x'60' slr 13,11 st 12,4(,13) lr 12,15 lr 11,0 lr 15,1 mr 14,11 lr 0,14 ltr 11,11 bnm LF$024 ar 0,1 L0$023 equ * LF$024 equ * ltr 1,1 bnm LF$025 ar 0,11 L0$025 equ * LF$025 equ * st 0,0(,2) lr 0,15 lm LR$2,14,x'70'+LV$2(13) br 14 LE$2 equ * LR$2 equ 2 LV$2 equ 0 end gcl-2.6.14/mp/mp_sl3todivul3.c0000755000175000017500000000457014360276512014453 0ustar cammcamm /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define ulong unsigned plong #define shift1BitRight(h,l) \ (l = l >> 1 , (h & 1 ? l = l | (1 << (WORD_SIZE -1)) : 0), h = h >> 1) #define shift2BitRight(h,l) \ (l = l >> 2 , (h & 3 ? l = l | ((h & 3) << (WORD_SIZE -2)) : 0), h = h >> 2) #define addll(x,y) \ (Xtx=(x),Xty=(y), Xtres = Xtx+Xty, \ (Xtres < Xtx ? overflow = 1 :0), Xtres) /* the following defines divul3 in terms of divsl3. */ #define WORD_SIZE 32 divul3(x, y, hi) ulong x, y, *hi; { ulong q = 0,Xtx,Xty,Xtres,addy,overflow; ulong h = *hi, l = x, hibit; ulong dd; /* if (y<=h) printf("error: the quotient will be more than 32 bits"); */ if ((int) y > 0) { dd = y >> 1; if (dd <= h) { unsigned int ll = l; shift1BitRight(h, ll); q = divsl3(ll, y, &h); h = h + h + (l & 1); q = q + q; if (h >= y) { q++; h -= y; } *hi = h; return q; } else { return divsl3(x, y, hi); } } /* negative */ { ulong ll; ulong rem; ll = l; shift2BitRight(h, ll); dd = y >> 1; q = divsl3(ll, dd, &h); rem = h + h; overflow = 0; rem = addll(rem, rem); rem += l & 3; q = q + q; addy = 0; if (y & 1) { if (overflow==0 && rem < q) { addy = 1; rem = addll(rem, y); if (overflow==0 && rem < q) { addy = 2; rem +=y; } } if (q > rem ) overflow = 0; rem -= q; } if (addy > 0) { q -= addy; } else { if (overflow || (rem >= y)) { rem -= y; q++; } } *hi = rem; return q; } } /* ;;- Local variables: ;;- mode:c ;;- version-control:t ;;- End: */ gcl-2.6.14/mp/gcclab.awk0000755000175000017500000000032514360276512013331 0ustar cammcamm /NEW_LABEL/ { lab++; next;} /Lmylabel/ { at = index($0,"Lmylabel"); printf("%s%d%s\n", substr($0,1,at),lab,substr($0,at+1)); next;} {print} gcl-2.6.14/mp/readme0000755000175000017500000000464014360276512012576 0ustar cammcammREADME for multiprecision arithmetic directory. README by W. Schelter The files in this directory gencom.h mp.s sparc.s erreurs.h genport.h are from the PARI distribution version 1.34 written by C. Batut, D. Bernardi, H. Cohen and M. Olivier. The file mp.c from the 1.34 distribution has been divided into mpi.c: The functions benefiting from assembler or assembler macros. mp2.c: Additional integer arithmetic routines. In addition the functions in mpi.c have been somewhat rewritten by Schelter, to improve the efficiency on machines unable to use the 68k assembler in the pari file mp.s. By using gcc and assembler macros, we were able to equal the speed of the excellent pari assembler, on multiply and addition of 100 word bignums. This distribution contains .s files produced by gcc for machines where this has been available. For other machines the functions divul3 and mulul3 may be provided as assembler functions, or they may use the code in the libmport.a which is plain C. mp_mulul3.c: 64 bit multiply in C mp_divul3.c: 64 bit multiply in C mp_bfffo.c: position of first non zero bit in C mpi-*.s: are assembler produced by gcc for several machines. Full sources for PARI/GP are available by anonymous ftp from (Internet number 192.33.148.32). Authors address: Prof. Henri COHEN (re: PARI) UFR de Mathematiques et Informatique Universite Bordeaux I 351 Cours de la Liberation 33405 TALENCE CEDEX FRANCE e-mail: pari@mizar.greco-prog.fr (Internet number 192.33.148.32) The integration of the pari code into AKCL was done by W. Schelter. --------------------------------------------------------------------------- Excerpt from letter from Henri Cohen giving us permission to redistribute this code with AKCL. Received-Date: Fri, 25 Jan 91 12:38:02 -0600 Date: Fri, 25 Jan 91 19:17:34 +0100 From: pari@mizar.greco-prog.fr (Systeme PARI) To: wfs@nicolas.ma.utexas.edu Subject: Re: AKCL Thank you for the clarifications. 1) -2^31: it was mainly a matter of convenience to exclude that value, so that in effect I don't know which programs should be affected if one allows it. If necessary, I can look into it. 2) Yes, go ahead means that you may modify and rearrange things in your own way, and redistribute it, of course keeping us informed. On the other hand, please tell us as soon as possible of any bug that you discover that we should eliminate from the main system itself. .. Sincerely, Henri Cohen gcl-2.6.14/xbin/0000755000175000017500000000000014360276512011733 5ustar cammcammgcl-2.6.14/xbin/test10000755000175000017500000000124214360276512012720 0ustar cammcamm#!/bin/sh TEST=$1 TAR=$2 echo Using tar file ${TAR} in directory ${TEST}/tmp/akcl if [ ! -d ${TEST} ] ; then mkdir ${TEST} ;fi if [ ! -d ${TEST}/tmp ] ; then mkdir ${TEST}/tmp ;fi (cd ${TEST}/tmp ;rm -r -f akcl ; mkdir akcl; cd akcl ;uncompress -c ${TAR} | tar xvf -) (cd ${TEST}/tmp/akcl ; echo Now in `pwd`; \ if [ "`hostname`" = fireant.ma.utexas.edu ] ; \ then ./add-defs sun4 ; else \ if [ "`hostname`" = "nicolas.ma.utexas.edu" ] ; \ then ./add-defs hp300-bsd ; \ else add-defs sun3-os4 \ ;fi ;fi) (cd ${TEST}/tmp/akcl ; make -f Smakefile -e "SU=SKIP" ) (cd ${TEST}/tmp/akcl ; make -f xbin/maketest "LISP=${TEST}/tmp/akcl/xbin/kcl") gcl-2.6.14/xbin/strip-ifdef0000755000175000017500000000055414360276512014101 0ustar cammcamm#!/bin/sh # Sample usage strip-ifdef foo.c -Dmips -DATT # will select only code in those ifdefs which are selected by mips and ATT. # includes, and defines will be left intact, as will comments cat $1 | sed -e "s:^#include:XX#include:g" -e "s:^#define:XX#define:g" > /tmp/tmpx.c shift 1 gcc -E -C /tmp/tmpx.c $@ | sed -e "/^#/d" -e "s:XX#:#:g" -e "/^$/d" | cb gcl-2.6.14/xbin/get-machine0000755000175000017500000000000214360276512014032 0ustar cammcamm gcl-2.6.14/xbin/new-files0000755000175000017500000000215114360276512013551 0ustar cammcamm#!/bin/sh #rm -f tmpx #for v in `cat unixport/lspboots unixport/cmpboots` ; #do echo "/$v.[chd]/d" >>tmpx #done HERE=$1 GCL_VERS=$2 echo > ${HERE}/tmpx GCL=`basename ${HERE}` OBJS=`find ./${GCL} \( -type f \) -a -print | sed -f ${HERE}/tmpx -e "/notyet/d" -e "s:/${GCL}/:/${GCL_VERS}/:g" -e "/~/d" -e "/#/d" -e "/.*\.o/d" -e "/TAGS$/d" -e "/tags$/d" -e "/standard-gcl/d" -e "/core/d" -e "/saved_/d" -e "/unixport\/raw/d" -e "/rsym$/d" -e "/merge$/d" -e "/errs$/d" -e "/dpp$/d" -e "/-$/d" -e "/installed_gcl/d" -e '/\/\.nfs/d' -e "/config\.h/d" -e "/_aos/d" -e "/gazonk/d" -e "/\.out$/d" -e "/print_doc$/d" -e "/foo/d" -e "/gcllib/d" -e "/\.fn$/d" -e "/collectfn.[cdh]/d" -e "/ps2_/d" -e "/.*\.a$/d" -e "/test\//d" -e "/tmpx/d" -e "/makedefs$/d" -e "/\.tgz/d" -e "/\/old\//d" -e "/guis$/d" -e "/\.X$/d" -e "/gcltkaux/d" -e "/\.dvi/d" -e "/\.log/d" -e '/\.aux$/d' -e "/\.exe$/d" -e "/grab_defs$/d" -e "/config.status/d" -e "/config.cache/d" -e "/\.rej$/d" -e "/\/CVS\//d" -e '/file-sub$/d' -e '/\.lo$/d' -e '/gmp\/.*\/Makefile$/d' -e '/\.libs/d' -e /makedefsafter/d ` rm -f ${HERE}/tmpx echo ${OBJS} gcl-2.6.14/xbin/386-linux-fix0000755000175000017500000000030014360276512014113 0ustar cammcamm#!/bin/sh if gcc -v 2>&1 | fgrep 2.96 > /dev/null ; then echo patching o/makefile for gcc bug in 2.96 for v in o/makefile mp/makefile ; do cat $v | sed -e s:-O4:-O:g > foo mv foo $v done fi gcl-2.6.14/xbin/compare.c0000755000175000017500000000125114360276512013527 0ustar cammcamm#include #include /* Skip over SKIP bytes, and then compare files, up to the length of the shortest. */ #define SKIP sizeof(struct exec) main(argc,argv) int argc; char *argv[]; {FILE *fp1,*fp2; int i; if (argc!=2) {printf("Usage:compare file1 file2 "); exit(1);} fp1=fopen(argv[1],"r"); fp2=fopen(argv[2],"r"); if(fp1==0 || fp2==0){ perror("could not open file"); fflush(stdout); exit(1);} for (i=0; i< SKIP; i++) {getc(fp1); getc(fp2);} while (!feof(fp1) && !feof(fp2)) {if (getc(fp1)!=getc(fp2)) { if(feof(fp1)|| feof(fp2)) exit(1); printf("they differed at %d",i);exit(1);} i++;} exit(0);} gcl-2.6.14/xbin/is-V-newest0000755000175000017500000000151214360276512014001 0ustar cammcamm#!/bin/sh cd V OBJS=`find . \( -name '*[0-9a-zA-Z]' -a -type f \) -print` MAINDIR=/public/kcl cd .. for v in ${OBJS} ; do ./merge ${MAINDIR}/$v V/$v tmpx if cmp $v tmpx > /dev/null then true # else echo $v differed do else echo kcl-merge $v # echo ./merge ${MAINDIR}/$v V/$v tmpx # ls -l tmpx $v # diff -c tmpx $v fi done rm tmpx OBJS=`find ./c \( -name '[./0-9a-zA-Z]*.[cd]' -a -type f \) -print` LOBJ=`find ./lsp \( -name '[./0-9a-zA-Z]*.lsp' -a -type f \) -print` CMPOBJ=`find ./cmpnew \( -name '[./0-9a-zA-Z]*.lsp' -a -type f \) -print` HFIL=`find ./h \( -name '[./0-9a-zA-Z]*.h' -a -type f \) -print` for v in ${OBJS} ${LOBJ} ${CMPOBJ} ${HFIL} ; do if [ -f ${MAINDIR}/$v ] then if cmp $v ${MAINDIR}/$v > /dev/null then true else if [ ! -f V/$v ] ; then echo kcl-merge $v ; fi fi fi done gcl-2.6.14/xbin/inc-version0000755000175000017500000000014314360276512014113 0ustar cammcamm#!/bin/sh echo '(@ VER = `cat ../minvers` + 1 ; echo ${VER} > ../minvers)' | /bin/csh ; exit 0 gcl-2.6.14/xbin/make-fn0000755000175000017500000000074214360276512013202 0ustar cammcamm#!/bin/sh LISP=gcl if [ $# = 2 ] ; then LISP=$2 ; fi TMP=/tmp/tmpd$$ mkdir ${TMP} cp $@ ${TMP} for v in $1 ; do echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \ '(compiler::emit-fn t)'\ "(compile-file \"${TMP}/$v\" :o-file nil)" echo '(load (format nil "~a~a" si::*system-directory* "../cmpnew/gcl_collectfn"))' \ '(compiler::emit-fn t)'\ "(compile-file \"${TMP}/$v\" :o-file nil)" | ${LISP} done mv ${TMP}/*.fn . rm -f -r ${TMP} gcl-2.6.14/xbin/get-externals0000755000175000017500000000035214360276512014443 0ustar cammcamm#!/bin/sh for v in $@ ; do echo echo '/*' for file $v '*/' echo grep ":OF" $v > tmpx.c gcc -E tmpx.c | sed -e '/# [0-9]/d' -e '/ static /d' \ -e "s:\\((.*)\\):GPR(\\1);:g" -e "s:va_list ap:...:g" -e "s: extern :extern :g" done gcl-2.6.14/xbin/dos-files0000755000175000017500000000210314360276512013542 0ustar cammcamm#!/bin/sh OBJS=`find ./ \( -type f -o -type l \) -a -print | sed -e "/~/d" -e "/#/d" -e "/.*\.o/d" -e "/.*TAGS/d" -e "/standard-kcl/d" -e "/core/d" -e "/saved/d" -e "/raw/d" -e "/rsym$/d" -e "/merge$/d" -e "/dpp$/d" -e "/-$/d" -e "/installed_kcl/d" -e "/^[^V]*\/cmpinclude.h/d" -e "/config\.h/d" -e "/_aos/d" -e "/gazonk/d" -e "/\.out/d" -e "/print_doc$/d" -e "/foo/d" -e "/akcllib/d" -e "/\.fn/d" -e "/collectfn.[cdh]/d" -e "/Vmakefile/d" -e "/ps2_/d" -e "/.*\.a$/d" -e "/test\//d" -e "/tmpx/d" -e "/V\//d" -e "/xbin\//d" -e "/mpi-386.s/d" ` rm -f unixport/akcldos.lsp (cd unixport ; make -f makefile.dos "CC=gcc -DVOL=volatile " AKCLDIR=/akcl akcldos.lsp) OTHERS="xbin/*.bat tmpxx_.tem" echo ${OBJS} ${OTHERS} rm -f ${HOME}/tmp/akclsrc.zip zip -p ${HOME}/tmp/akclsrc.zip ${OBJS} ${OTHERS} # get a patched h/cmpinclude.h ./xbin/file-sub h/dos-go32.h h/cmpinclude.h "Begin for cmpinclud" "End for cmpinclud" if [ -d /tmp/h ] ; then true ; else mkdir /tmp/h ; fi mv tmpx /tmp/h/cmpinclude.h cd /tmp zip -p ${HOME}/tmp/akclsrc.zip h/cmpinclude.h rm -f h/cmpinclude.h gcl-2.6.14/xbin/maketest10000755000175000017500000000275614360276512013571 0ustar cammcamm TMPDIR=/d/wfs/tmp MAKEFILE=xbin/maketest1 all: xbin/distribute ${HOME}/gcl.tgz ${HOME}/gcl.tgz: xbin/distribute ${HOME}/gcl.tgz HOST=jany jany: make -f ${MAKEFILE} compile HOST=jany TYPE=386-linux DIR="gcl-`cat majvers`.`cat minvers`" kristen: make -f ${MAKEFILE} compile HOST=kristen TYPE=solaris DIR="gcl-`cat majvers`.`cat minvers`" leonhard: make -f ${MAKEFILE} compile HOST=leonhard TYPE=sun4 DIR="gcl-`cat majvers`.`cat minvers`" HOST=leonhard CLX=CLX-5.02-gcl-2.1 PCL=pcl-gcl-2.1 compile: ${HOME}/gcl.tgz cat ${HOME}/gcl.tgz | rsh ${HOST} \ "(rm -rf ${TMPDIR}/${HOST} ; cd ${TMPDIR}; mkdir ${HOST} ; cd ${HOST} ; gzip -dc | tar xvf - )" cat /home/ftp/pub/gcl/${CLX}.tgz | \ rsh ${HOST} "(cd ${TMPDIR}/${HOST} ; gzip -dc | tar xvf -)" cat /home/ftp/pub/gcl/${PCL}.tgz | \ rsh ${HOST} "(cd ${TMPDIR}/${HOST} ; gzip -dc | tar xvf -)" rsh ${HOST} "(cd ${TMPDIR}/${HOST}/${DIR} ; add-defs ${TYPE} ; make >& '#errs')" < /dev/null rsh ${HOST} "(cd ${TMPDIR}/${HOST}/${DIR} ; add-defs ${TYPE} ; (make ; cd ../${CLX}; make -f makefile.gcl LISP=../${DIR}/xbin/gcl ; cd ../${PCL} ; make -f makefile.gcl LISP=../${DIR}/xbin/gcl )>& '#errs')" < /dev/null TEST_DIR=/d/wfs/gcl/test test-xp: rsh ${HOST} "(cd ${TEST_DIR} ; ${TMPDIR}/${HOST}/${DIR}/xbin/gcl -compile xp-code.lisp ; \ ${TMPDIR}/${HOST}/${DIR}/xbin/gcl -load xp-code.o -load xp-test.lisp \ -eval '(progn (load \"/d/wfs/gcl/test/xp-test.lisp\")(setq compile-tests nil)\ (setq failed-tests nil)(do-tests))')" gcl-2.6.14/xbin/setup-tmptest0000755000175000017500000000032614360276512014520 0ustar cammcamm#!/bin/sh TMP=$1 TEST=$2 NQTHM=$3 if [ -d ${TMP} ] ; then rm -f ${TMP}/* ; else mkdir ${TMP} ;fi ln -s `pwd`/xbin/kcl ${TMP} ln -s ${HOME}/little.lisp ${TMP} (cd ${NQTHM} ; ln -s `pwd`/*.lisp ${TMP}) exit 0 gcl-2.6.14/xbin/update0000755000175000017500000000015014360276512013137 0ustar cammcamm#!/bin/sh lis=$* echo make -f Smakefile $lis "CHANGED=${lis}" make -f Smakefile ${lis} "CHANGED=${lis}" gcl-2.6.14/xbin/ibm0000755000175000017500000000026114360276512012427 0ustar cammcamm#!/bin/sh FILE=${HOME}/ibm/ibm-`cat majvers`-`cat minvers`.tar.Z echo creating file ${FILE} tar cvf - `"ls" */rt* */ps2_* */*aos* | sed -e "/~/d"` | compress -c > ${FILE} gcl-2.6.14/xbin/maketest0000755000175000017500000000251314360276512013477 0ustar cammcammLISP=gcl TEST=${HOME} # TEST=/u8/temp # TEST=/public/tmp/wfs NQTHM=${HOME}/nqthm TMP=$(TEST)/tmptest # (cd gcl ; make -f xbin/maketest) # does compilation and test of nqthm # (cd gcl ; make -f xbin/maketest "TAR=/usr2/ftp/gcl.tar.Z") # does compilation of gcl and runs test of nqthm in the resulting lisp all: xbin/setup-tmptest $(TMP) $(TEST) $(NQTHM) (cd $(TMP) ; echo '(load "nqthm.lisp")(compile-nqthm)' | ${LISP}) make -f xbin/maketest run-test "LISP=${LISP}" make -f xbin/maketest sgc "LISP=${LISP}" # untar the tar file ${TAR} in ${TEST}/tmp/gcl and make # then make -f xbin/maketest all make: xbin/test1 ${TEST} ${TAR} run-test: (cd $(TMP) ; echo '(load "nqthm.lisp")(load-nqthm)' \ '(SETQ *THM-SUPPRESS-DISCLAIMER-FLG* T)' \ '(load "little.lisp")' | ${LISP}) # we run the compiler 10 times with sgc on and compare with the result with # sgc off. sgc: cp lsp/sloop.lsp /tmp echo '(compile-file "/tmp/sloop.lsp" :c-file t :o-file nil)' | ${LISP} mv /tmp/sloop.c /tmp/sloop-reg.c echo '(setq si::*notify-gbc* t)(si::sgc-on t)' \ '(dotimes (i 10) (compile-file "/tmp/sloop.lsp" :c-file t :o-file nil)' \ '(if (not (eql 0 (system "diff /tmp/sloop.c /tmp/sloop-reg.c")))' \ '(error ">>>>ERROR: The compilation DIFFERED")))' | ${LISP} diff /tmp/sloop.c /tmp/sloop-reg.c rm -f /tmp/sloop.lsp /tmp/sloop.c /tmp/sloop-reg.c gcl-2.6.14/xbin/if-exist.bat0000755000175000017500000000011114360276512014147 0ustar cammcamm@echo off IF NOT EXIST %1 goto end shift %1 %2 %3 %4 %5 %6 %7 %8 %9 :end gcl-2.6.14/xbin/distribute0000755000175000017500000000267014360276512014044 0ustar cammcamm#!/bin/sh GCL=`pwd` FTPDIR=math.utexas.edu:/home/ftp/pub/gcl # done moving aside the .c files we don't want to ship. OPT=-9 DNAME="gcl-`cat ${GCL}/majvers`.`cat ${GCL}/minvers`" NAME="${DNAME}.tgz" if [ $# -eq 1 ] ; then FILE=$1 ; OPT= else FILE=/tmp/${NAME} rcp ${GCL}/ChangeLog ${FTPDIR}/gcl-ChangeLog rcp ${GCL}/README ${FTPDIR}/GCL.README fi moved=0 nameNow=`basename ${GCL}` cd ${GCL}/.. if [ "${DNAME}" != "${nameNow}" ] ; then rm -f ${DNAME} if [ -d ${DNAME} ] ;then moved=1 mv -f ${DNAME} prev-${DNAME}; fi echo mv -f ${GCL} ${DNAME} mv -f ${GCL} ${DNAME} fi tar cvf - `${DNAME}/xbin/new-files ${DNAME} ${DNAME}` | (cd ${DNAME} ; gzip -c ${OPT} > ${FILE} ) if [ "${DNAME}" != "${nameNow}" ] ; then if [ "${moved}" = "1" ] ; then echo mv ${DNAME} ${GCL} mv -f prev-${DNAME} ${DNAME} fi mv -f ${DNAME} ${GCL} fi if [ $# -eq 0 ] ; then rcp ${FILE} ${FTPDIR}/${NAME} fi if [ $# -eq 0 ] ; then echo wfs > tmpx echo binary >> tmpx echo send ${FILE} /cli/ftp/pub/gcl/${NAME} >> tmpx echo send README /cli/ftp/pub/gcl/GCL.README >> tmpx echo send ChangeLog /cli/ftp/pub/gcl/ChangeLog >> tmpx cat tmpx | ftp ftp.cli.com rm -f tmpx echo binary >tmpx echo cd kcl/akcl >> tmpx echo prompt >> tmpx # echo 'mdel akcl-1*.Z gcl-*' >> tmpx echo send ${FILE} ${NAME} >> tmpx echo send README GCL.README >> tmpx echo send ChangeLog ChangeLog >> tmpx echo quit >> tmpx cat tmpx | ftp 133.11.11.11 fi rm -f tmpx gcl-2.6.14/xbin/exists0000755000175000017500000000011114360276512013171 0ustar cammcamm#!/bin/sh for v in $@ ; do if [ -f $v ] ; then exit 0 ;fi ; done exit 1 gcl-2.6.14/xbin/move-if-changed0000755000175000017500000000040014360276512014604 0ustar cammcamm#!/bin/sh if [ $# -eq 3 ] ; then MOVE=$1 ; shift 1; else MOVE=ln;fi F1=$1 F2=$2 if [ $# -ge 2 ] && [ -f $2 ] && cmp $1 $2 > /dev/null then echo $1 and $2 are identical ; else echo $1 and $2 were not the same. rm -f $2 ${MOVE} $1 $2 echo ln $1 $2 fi gcl-2.6.14/xbin/test-distrib0000755000175000017500000000132014360276512014272 0ustar cammcamm#!/bin/sh # usage: test-distrib machine [ gcl.tgz-file ] # xbin/test-distrib 386-linux /d11/wfs/gcl.tgz >& # xbin/test-distrib solaris /dilbert1/wfs/gcl.tgz >& MACHINE=$1 if [ -d /d11/wfs/test-lisp ] ; then DIR=/d11/wfs ; else if [ -d ${HOME}/test-lisp ] ; then DIR=${HOME}; else echo cant find test-lisp ; exit 1; fi; fi TESTDIR=${DIR}/test-lisp if [ $# -eq 2 ] ;then FILE=$2 ; else FILE=${DIR}/gcl.tgz NAME="gcl-`cat majvers`.`cat minvers`" xbin/distribute ${FILE} fi rm -rf ${DIR}/gcl-test mkdir ${DIR}/gcl-test cd ${DIR}/gcl-test gzip -dc ${FILE} | tar xvf - NAME="gcl-`cat gcl-*/majvers`.`cat gcl-*/minvers`" cd ${NAME} add-defs ${MACHINE} make cd ${TESTDIR} make LISP=${DIR}/gcl-test/${NAME}/unixport/saved_gcl gcl-2.6.14/xbin/spp.c0000755000175000017500000000415114360276512012705 0ustar cammcamm /* * spp.c * Extracts the symbol table from an HP-UX executable file * to be used in a later pass of the linker. (ld does not * support the -A option.) */ #include #include filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } stabcpy(to,from,n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; struct nlist_ nbuf; int len; for (;;) if (n <= 0) break; else { fread(&nbuf,sizeof(nbuf),1,from); len = nbuf.n_length; fread(buffer,len,1,from); buffer[len] = '\0'; nbuf.n_type = EXTERN | ABS; if (((strncmp(buffer,"_end",4) == NULL) && (len == 4)) || ((strncmp(buffer,"_etext",6) == NULL) && (len == 6)) || ((strncmp(buffer,"_edata",6) == NULL) && (len == 6))) buffer[1] = 'E'; fwrite(&nbuf,sizeof(nbuf),1,to); fwrite(buffer,len,1,to); n -= sizeof(nbuf) + nbuf.n_length; } } main(argc,argv) int argc; char *argv[]; { FILE *file,*sfile; struct exec header; char sfile_name[BUFSIZ]; long skip,size0,size1; if(argc != 2) { fprintf(stderr,"usage: spp \n"); exit(1); } if((file = fopen(argv[1],"r")) == NULL) { fprintf(stderr,"can't open exefile: %s\n", argv[1]); exit(1); } strcpy(sfile_name,argv[1]); strcat(sfile_name,".stb"); if((sfile = fopen(sfile_name,"w")) == NULL) { fprintf(stderr,"can't create stbfile: %s\n", sfile_name); exit(1); } fread(&header,sizeof(header),1,file); skip = MODCAL_OFFSET(header); size0 = header.a_pasint; size1= header.a_dnttsize + header.a_sltsize + header.a_vtsize + header.a_trsize + header.a_drsize; header.a_magic.file_type = RELOC_MAGIC; header.a_text = 0; header.a_data = 0; header.a_bss = 0; fwrite(&header,sizeof(header),1,sfile); fseek(file,skip,0); filecpy(sfile,file,size0); stabcpy(sfile,file,header.a_lesyms); filecpy(sfile,file,size1); fclose(file); fclose(sfile); } gcl-2.6.14/xbin/dosmake.bat0000755000175000017500000000272114360276512014053 0ustar cammcamm@echo off rem ---------------------------------------------------------------------- rem No COPYRIGHTs, WARRANTIES, ... rem rem batch file to build akcl for dos. rem Report errors, bugs or enhancements to : rem rcharif@math.utexas.edu rem or wfs@math.utexas.edu rem ---------------------------------------------------------------------- rem Hope no one calls his env variable like that set __MAKE_ER= cd bin make CC=gcc dpp IF ERRORLEVEL 1 set __MAKE_ER=DPP IF ERRORLEVEL 1 goto errEncountered aout2exe dpp cd .. cd mp make all IF ERRORLEVEL 1 set __MAKE_ER=MP IF ERRORLEVEL 1 goto errEncountered cd .. cd o make all IF ERRORLEVEL 1 set __MAKE_ER=O IF ERRORLEVEL 1 goto errEncountered cd .. cd lsp make all IF ERRORLEVEL 1 set __MAKE_ER=LSP IF ERRORLEVEL 1 goto errEncountered cd .. cd cmpnew make all IF ERRORLEVEL 1 set __MAKE_ER=CMPNEW IF ERRORLEVEL 1 goto errEncountered cd .. cd dos make all IF ERRORLEVEL 1 set __MAKE_ER=DOS IF ERRORLEVEL 1 goto errEncountered cd.. cd unixport make rsym IF ERRORLEVEL 1 set __MAKE_ER=RSYM IF ERRORLEVEL 1 goto errEncountered aout2exe rsym make -f makefile.dos raw_kcl IF ERRORLEVEL 1 set __MAKE_ER=RAW_KCL IF ERRORLEVEL 1 goto errEncountered make -f makefile.dos saved_kcl IF ERRORLEVEL 1 set __MAKE_ER=SAVED_KCL IF ERRORLEVEL 1 goto errEncountered rem go32 raw_kcl /dev/null ; then echo $1 ; else echo $2 ; fi exit 0 gcl-2.6.14/xbin/if-exists0000755000175000017500000000014614360276512013575 0ustar cammcamm#!/bin/sh if [ -f $1 ] ; then # echo $2 $2 # echo $3 $3 # echo $4 $4 # echo $5 $5 $6 fi exit 0 gcl-2.6.14/xbin/append.bat0000755000175000017500000000005714360276512013677 0ustar cammcamm@echo off rem echo in append.bat copy /B %2+%1 gcl-2.6.14/xbin/add-dir0000755000175000017500000000066614360276512013175 0ustar cammcamm#!/bin/sh # add-dir filename directories-to-search expression-to-define ####### ITEM=$1 for v in $2 ; do if xbin/exists $v/${ITEM} > /dev/null ; then echo $3 | sed -e 's:$v:'$v':g' >> makedefs ; echo adding $3 | sed -e 's:$v:'$v':g' exit 0; fi ; done echo '#could not find' $1 in $2 1>&2 echo Using: $3 | sed -e 's:$v:unknown:g' 1>&2 echo '#could not find' $1 so using: >> makedefs echo $3 | sed -e 's:$v:unknown:g' >> makedefs exit 0 gcl-2.6.14/xbin/notify0000755000175000017500000000114514360276512013172 0ustar cammcamm#!/bin/sh # Send in a notification about successful compilation, which may # help others, and help in determining on which machines and # levels of the OS compilation has been successful. if [ -f /bin/mail ] ; then echo GCL `cat majvers`.`cat minvers` Machine: `cat machine` > tmpx ls -l h/config.h >> tmpx echo $@ >> tmpx if fgrep gcc tmpx > /dev/null ; then gcc -v 2>> tmpx fi if [ -f /etc/motd ] ; then cat /etc/motd | sed -e "2,10000d" >> tmpx ; fi # if you are wfs dont bother mailing if [ "${HOME}" = "/home/wfs" ] ; then true ; else cat tmpx | /bin/mail gcl@math.utexas.edu fi fi gcl-2.6.14/xbin/comp_rel0000755000175000017500000000047714360276512013471 0ustar cammcamm#!/bin/sh FILE=$1 KCL=${HOME}/akcl/unixport/saved_kcl # the (start address) you observe while running stand alone. ADDR=92000 ld -d -N -x -A ${KCL} -R 92000 $1 -o /tmp/ldtest a.out $1 ${HOME}/akcl/unixport/saved_kcl ${HOME}/akcl/unixport/ if comp /tmp/ldtest /tmp/sfasltest then echo $1 differed else echo $1 ok fi gcl-2.6.14/xbin/get-internal-calls0000755000175000017500000000042214360276512015344 0ustar cammcammecho '(setq all-references (' for v in $@ ; do echo echo ';;/*' for file $v '*/' echo echo '(' \"$v\" grep ":IC" $v > tmpx.c gcc -E tmpx.c | sed -e '/# [0-9]/d' -e '/ static /d' \ -e "s:\\(.*\\) \\([a-zA-Z_0-9]*\\) \\((.*)\\);:\"\\2\":g" | sort echo ')' done echo '))' gcl-2.6.14/xbin/append0000755000175000017500000000011314360276512013123 0ustar cammcamm#!/bin/sh if [ "$#" = "3" ] ;then cat $1 $2 >> $3 ; else cat $1 >> $2 ; fi gcl-2.6.14/xbin/test0000755000175000017500000000050114360276512012634 0ustar cammcamm#!/bin/sh TAR=${HOME}/tmp/gcl.tgz xbin/distribute ${TAR} if [ "$1" = "" ] ; then make -f xbin/maketest make "TAR=${TAR}" else if [ "$1" = "fireant.ma.utexas.edu" ] ; then true; else rcp ${TAR} $1:tmp/${TAR} ;fi rcp xbin/test1 $1:tmp rsh $1 '(cd tmp ; test1 ${HOME} ${HOME}/tmp/gcl.tgz)' < /dev/null fi gcl-2.6.14/xbin/fix-copyright0000755000175000017500000000555514360276512014467 0ustar cammcamm (tags-query-replace "(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. Copying of this file is authorized to users who have executed the true and proper \"License Agreement for Kyoto Common LISP\" with SIGLISP." " Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of Austin Kyoto Common Lisp, herein referred to as AKCL AKCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. AKCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with AKCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. " ) (tags-query-replace ";; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. ;; Copying of this file is authorized to users who have executed the true and ;; proper \"License Agreement for Kyoto Common LISP\" with SIGLISP." ";; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of Austin Kyoto Common Lisp, herein referred to as AKCL ;; ;; AKCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; AKCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ;; for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with AKCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. " ) (tags-query-replace "\\`" " /* Copyright (C) 1994 W. Schelter This file is part of Austin Kyoto Common Lisp, herein referred to as AKCL AKCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. AKCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU library general public license along with AKCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ " ) gcl-2.6.14/xbin/dfiles0000755000175000017500000000013114360276512013122 0ustar cammcamm#!/bin/sh for v in c/*.d ;do echo "ln $v `echo $v | sed -e s:\\\.d:\\\.c:g`" | sh ;done gcl-2.6.14/xbin/compare-src0000755000175000017500000000066414360276512014102 0ustar cammcamm#!/bin/sh OTHER=/rascal/public/akcl for v in lsp/*.lsp cmpnew/*.lsp cmpnew/*.lisp ; do if cmp $v ${OTHER}/$v ; then true ; else ls -l $v ${OTHER}/$v; fi done for v in c/*.c c/*.d unixport/*.c; do if cmp $v ${OTHER}/$v ; then true ; else ls -l $v ${OTHER}/$v; fi done for v in `echo doc/* xbin/* | sed -e "/~/d"` -e "/emacs-path/d" -e "/xbin\/kcl/d" ; do if cmp $v ${OTHER}/$v ; then true ;else ls -l $v ${OTHER}/$v; fi done gcl-2.6.14/xbin/distrib-help0000755000175000017500000000016014360276512014244 0ustar cammcamm#!/bin/sh for v in $@ ; do for w in c h lsp data ; do if [ -f $v.$w- ] ; then mv $v.$w- $v.$w ; fi done done gcl-2.6.14/xbin/.gitignore0000644000175000017500000000000414360276512013715 0ustar cammcammgcl gcl-2.6.14/config.guess0000755000175000017500000014051214360276512013316 0ustar cammcamm#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2022 Free Software Foundation, Inc. # shellcheck disable=SC2006,SC2268 # see below for rationale timestamp='2022-01-09' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # # Originally written by Per Bothner; maintained since 2000 by Ben Elliston. # # You can get the latest version of this script from: # https://git.savannah.gnu.org/cgit/config.git/plain/config.guess # # Please send patches to . # The "shellcheck disable" line above the timestamp inhibits complaints # about features and limitations of the classic Bourne shell that were # superseded or lifted in POSIX. However, this script identifies a wide # variety of pre-POSIX systems that do not have POSIX shells at all, and # even some reasonably current systems (Solaris 10 as case-in-point) still # have a pre-POSIX /bin/sh. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Options: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright 1992-2022 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi # Just in case it came from the environment. GUESS= # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. tmp= # shellcheck disable=SC2172 trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15 set_cc_for_build() { # prevent multiple calls if $tmp is already set test "$tmp" && return 0 : "${TMPDIR=/tmp}" # shellcheck disable=SC2039,SC3028 { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir "$tmp" 2>/dev/null) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir "$tmp" 2>/dev/null) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } dummy=$tmp/dummy case ${CC_FOR_BUILD-},${HOST_CC-},${CC-} in ,,) echo "int x;" > "$dummy.c" for driver in cc gcc c89 c99 ; do if ($driver -c -o "$dummy.o" "$dummy.c") >/dev/null 2>&1 ; then CC_FOR_BUILD=$driver break fi done if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac } # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if test -f /.attbin/uname ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown case $UNAME_SYSTEM in Linux|GNU|GNU/*) LIBC=unknown set_cc_for_build cat <<-EOF > "$dummy.c" #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #elif defined(__GLIBC__) LIBC=gnu #else #include /* First heuristic to detect musl libc. */ #ifdef __DEFINED_va_list LIBC=musl #endif #endif EOF cc_set_libc=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` eval "$cc_set_libc" # Second heuristic to detect musl libc. if [ "$LIBC" = unknown ] && command -v ldd >/dev/null && ldd --version 2>&1 | grep -q ^musl; then LIBC=musl fi # If the system lacks a compiler, then just pick glibc. # We could probably try harder. if [ "$LIBC" = unknown ]; then LIBC=gnu fi ;; esac # Note: order is significant - the case branches are not exclusive. case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". UNAME_MACHINE_ARCH=`(uname -p 2>/dev/null || \ /sbin/sysctl -n hw.machine_arch 2>/dev/null || \ /usr/sbin/sysctl -n hw.machine_arch 2>/dev/null || \ echo unknown)` case $UNAME_MACHINE_ARCH in aarch64eb) machine=aarch64_be-unknown ;; armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; earmv*) arch=`echo "$UNAME_MACHINE_ARCH" | sed -e 's,^e\(armv[0-9]\).*$,\1,'` endian=`echo "$UNAME_MACHINE_ARCH" | sed -ne 's,^.*\(eb\)$,\1,p'` machine=${arch}${endian}-unknown ;; *) machine=$UNAME_MACHINE_ARCH-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently (or will in the future) and ABI. case $UNAME_MACHINE_ARCH in earm*) os=netbsdelf ;; arm*|i386|m68k|ns32k|sh3*|sparc|vax) set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # Determine ABI tags. case $UNAME_MACHINE_ARCH in earm*) expr='s/^earmv[0-9]/-eabi/;s/eb$//' abi=`echo "$UNAME_MACHINE_ARCH" | sed -e "$expr"` ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case $UNAME_VERSION in Debian*) release='-gnu' ;; *) release=`echo "$UNAME_RELEASE" | sed -e 's/[-_].*//' | cut -d. -f1,2` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. GUESS=$machine-${os}${release}${abi-} ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-bitrig$UNAME_RELEASE ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-openbsd$UNAME_RELEASE ;; *:SecBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/SecBSD.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-secbsd$UNAME_RELEASE ;; *:LibertyBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/^.*BSD\.//'` GUESS=$UNAME_MACHINE_ARCH-unknown-libertybsd$UNAME_RELEASE ;; *:MidnightBSD:*:*) GUESS=$UNAME_MACHINE-unknown-midnightbsd$UNAME_RELEASE ;; *:ekkoBSD:*:*) GUESS=$UNAME_MACHINE-unknown-ekkobsd$UNAME_RELEASE ;; *:SolidBSD:*:*) GUESS=$UNAME_MACHINE-unknown-solidbsd$UNAME_RELEASE ;; *:OS108:*:*) GUESS=$UNAME_MACHINE-unknown-os108_$UNAME_RELEASE ;; macppc:MirBSD:*:*) GUESS=powerpc-unknown-mirbsd$UNAME_RELEASE ;; *:MirBSD:*:*) GUESS=$UNAME_MACHINE-unknown-mirbsd$UNAME_RELEASE ;; *:Sortix:*:*) GUESS=$UNAME_MACHINE-unknown-sortix ;; *:Twizzler:*:*) GUESS=$UNAME_MACHINE-unknown-twizzler ;; *:Redox:*:*) GUESS=$UNAME_MACHINE-unknown-redox ;; mips:OSF1:*.*) GUESS=mips-dec-osf1 ;; alpha:OSF1:*:*) # Reset EXIT trap before exiting to avoid spurious non-zero exit code. trap '' 0 case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case $ALPHA_CPU_TYPE in "EV4 (21064)") UNAME_MACHINE=alpha ;; "EV4.5 (21064)") UNAME_MACHINE=alpha ;; "LCA4 (21066/21068)") UNAME_MACHINE=alpha ;; "EV5 (21164)") UNAME_MACHINE=alphaev5 ;; "EV5.6 (21164A)") UNAME_MACHINE=alphaev56 ;; "EV5.6 (21164PC)") UNAME_MACHINE=alphapca56 ;; "EV5.7 (21164PC)") UNAME_MACHINE=alphapca57 ;; "EV6 (21264)") UNAME_MACHINE=alphaev6 ;; "EV6.7 (21264A)") UNAME_MACHINE=alphaev67 ;; "EV6.8CB (21264C)") UNAME_MACHINE=alphaev68 ;; "EV6.8AL (21264B)") UNAME_MACHINE=alphaev68 ;; "EV6.8CX (21264D)") UNAME_MACHINE=alphaev68 ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE=alphaev69 ;; "EV7 (21364)") UNAME_MACHINE=alphaev7 ;; "EV7.9 (21364A)") UNAME_MACHINE=alphaev79 ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. OSF_REL=`echo "$UNAME_RELEASE" | sed -e 's/^[PVTX]//' | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` GUESS=$UNAME_MACHINE-dec-osf$OSF_REL ;; Amiga*:UNIX_System_V:4.0:*) GUESS=m68k-unknown-sysv4 ;; *:[Aa]miga[Oo][Ss]:*:*) GUESS=$UNAME_MACHINE-unknown-amigaos ;; *:[Mm]orph[Oo][Ss]:*:*) GUESS=$UNAME_MACHINE-unknown-morphos ;; *:OS/390:*:*) GUESS=i370-ibm-openedition ;; *:z/VM:*:*) GUESS=s390-ibm-zvmoe ;; *:OS400:*:*) GUESS=powerpc-ibm-os400 ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) GUESS=arm-acorn-riscix$UNAME_RELEASE ;; arm*:riscos:*:*|arm*:RISCOS:*:*) GUESS=arm-unknown-riscos ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) GUESS=hppa1.1-hitachi-hiuxmpp ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. case `(/bin/universe) 2>/dev/null` in att) GUESS=pyramid-pyramid-sysv3 ;; *) GUESS=pyramid-pyramid-bsd ;; esac ;; NILE*:*:*:dcosx) GUESS=pyramid-pyramid-svr4 ;; DRS?6000:unix:4.0:6*) GUESS=sparc-icl-nx6 ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) GUESS=sparc-icl-nx7 ;; esac ;; s390x:SunOS:*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=$UNAME_MACHINE-ibm-solaris2$SUN_REL ;; sun4H:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-hal-solaris2$SUN_REL ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-sun-solaris2$SUN_REL ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) GUESS=i386-pc-auroraux$UNAME_RELEASE ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) set_cc_for_build SUN_ARCH=i386 # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -m64 -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH=x86_64 fi fi SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=$SUN_ARCH-pc-solaris2$SUN_REL ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=sparc-sun-solaris3$SUN_REL ;; sun4*:SunOS:*:*) case `/usr/bin/arch -k` in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'` GUESS=sparc-sun-sunos$SUN_REL ;; sun3*:SunOS:*:*) GUESS=m68k-sun-sunos$UNAME_RELEASE ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x$UNAME_RELEASE" = x && UNAME_RELEASE=3 case `/bin/arch` in sun3) GUESS=m68k-sun-sunos$UNAME_RELEASE ;; sun4) GUESS=sparc-sun-sunos$UNAME_RELEASE ;; esac ;; aushp:SunOS:*:*) GUESS=sparc-auspex-sunos$UNAME_RELEASE ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) GUESS=m68k-atari-mint$UNAME_RELEASE ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) GUESS=m68k-milan-mint$UNAME_RELEASE ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) GUESS=m68k-hades-mint$UNAME_RELEASE ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) GUESS=m68k-unknown-mint$UNAME_RELEASE ;; m68k:machten:*:*) GUESS=m68k-apple-machten$UNAME_RELEASE ;; powerpc:machten:*:*) GUESS=powerpc-apple-machten$UNAME_RELEASE ;; RISC*:Mach:*:*) GUESS=mips-dec-mach_bsd4.3 ;; RISC*:ULTRIX:*:*) GUESS=mips-dec-ultrix$UNAME_RELEASE ;; VAX*:ULTRIX*:*:*) GUESS=vax-dec-ultrix$UNAME_RELEASE ;; 2020:CLIX:*:* | 2430:CLIX:*:*) GUESS=clipper-intergraph-clix$UNAME_RELEASE ;; mips:*:*:UMIPS | mips:*:*:RISCos) set_cc_for_build sed 's/^ //' << EOF > "$dummy.c" #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o "$dummy" "$dummy.c" && dummyarg=`echo "$UNAME_RELEASE" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`"$dummy" "$dummyarg"` && { echo "$SYSTEM_NAME"; exit; } GUESS=mips-mips-riscos$UNAME_RELEASE ;; Motorola:PowerMAX_OS:*:*) GUESS=powerpc-motorola-powermax ;; Motorola:*:4.3:PL8-*) GUESS=powerpc-harris-powermax ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) GUESS=powerpc-harris-powermax ;; Night_Hawk:Power_UNIX:*:*) GUESS=powerpc-harris-powerunix ;; m88k:CX/UX:7*:*) GUESS=m88k-harris-cxux7 ;; m88k:*:4*:R4*) GUESS=m88k-motorola-sysv4 ;; m88k:*:3*:R3*) GUESS=m88k-motorola-sysv3 ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if test "$UNAME_PROCESSOR" = mc88100 || test "$UNAME_PROCESSOR" = mc88110 then if test "$TARGET_BINARY_INTERFACE"x = m88kdguxelfx || \ test "$TARGET_BINARY_INTERFACE"x = x then GUESS=m88k-dg-dgux$UNAME_RELEASE else GUESS=m88k-dg-dguxbcs$UNAME_RELEASE fi else GUESS=i586-dg-dgux$UNAME_RELEASE fi ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) GUESS=m88k-dolphin-sysv3 ;; M88*:*:R3*:*) # Delta 88k system running SVR3 GUESS=m88k-motorola-sysv3 ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) GUESS=m88k-tektronix-sysv3 ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) GUESS=m68k-tektronix-bsd ;; *:IRIX*:*:*) IRIX_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/g'` GUESS=mips-sgi-irix$IRIX_REL ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. GUESS=romp-ibm-aix # uname -m gives an 8 hex-code CPU id ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) GUESS=i386-ibm-aix ;; ia64:AIX:*:*) if test -x /usr/bin/oslevel ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=$UNAME_VERSION.$UNAME_RELEASE fi GUESS=$UNAME_MACHINE-ibm-aix$IBM_REV ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then set_cc_for_build sed 's/^ //' << EOF > "$dummy.c" #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` then GUESS=$SYSTEM_NAME else GUESS=rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then GUESS=rs6000-ibm-aix3.2.4 else GUESS=rs6000-ibm-aix3.2 fi ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El "$IBM_CPU_ID" | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if test -x /usr/bin/lslpp ; then IBM_REV=`/usr/bin/lslpp -Lqc bos.rte.libc | \ awk -F: '{ print $3 }' | sed s/[0-9]*$/0/` else IBM_REV=$UNAME_VERSION.$UNAME_RELEASE fi GUESS=$IBM_ARCH-ibm-aix$IBM_REV ;; *:AIX:*:*) GUESS=rs6000-ibm-aix ;; ibmrt:4.4BSD:*|romp-ibm:4.4BSD:*) GUESS=romp-ibm-bsd4.4 ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and GUESS=romp-ibm-bsd$UNAME_RELEASE # 4.3 with uname added to ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) GUESS=rs6000-bull-bosx ;; DPX/2?00:B.O.S.:*:*) GUESS=m68k-bull-sysv3 ;; 9000/[34]??:4.3bsd:1.*:*) GUESS=m68k-hp-bsd ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) GUESS=m68k-hp-bsd4.4 ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'` case $UNAME_MACHINE in 9000/31?) HP_ARCH=m68000 ;; 9000/[34]??) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if test -x /usr/bin/getconf; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case $sc_cpu_version in 523) HP_ARCH=hppa1.0 ;; # CPU_PA_RISC1_0 528) HP_ARCH=hppa1.1 ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case $sc_kernel_bits in 32) HP_ARCH=hppa2.0n ;; 64) HP_ARCH=hppa2.0w ;; '') HP_ARCH=hppa2.0 ;; # HP-UX 10.20 esac ;; esac fi if test "$HP_ARCH" = ""; then set_cc_for_build sed 's/^ //' << EOF > "$dummy.c" #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS="" $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null) && HP_ARCH=`"$dummy"` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if test "$HP_ARCH" = hppa2.0w then set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH=hppa2.0w else HP_ARCH=hppa64 fi fi GUESS=$HP_ARCH-hp-hpux$HPUX_REV ;; ia64:HP-UX:*:*) HPUX_REV=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*.[0B]*//'` GUESS=ia64-hp-hpux$HPUX_REV ;; 3050*:HI-UX:*:*) set_cc_for_build sed 's/^ //' << EOF > "$dummy.c" #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o "$dummy" "$dummy.c" && SYSTEM_NAME=`"$dummy"` && { echo "$SYSTEM_NAME"; exit; } GUESS=unknown-hitachi-hiuxwe2 ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:*) GUESS=hppa1.1-hp-bsd ;; 9000/8??:4.3bsd:*:*) GUESS=hppa1.0-hp-bsd ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) GUESS=hppa1.0-hp-mpeix ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:*) GUESS=hppa1.1-hp-osf ;; hp8??:OSF1:*:*) GUESS=hppa1.0-hp-osf ;; i*86:OSF1:*:*) if test -x /usr/sbin/sysversion ; then GUESS=$UNAME_MACHINE-unknown-osf1mk else GUESS=$UNAME_MACHINE-unknown-osf1 fi ;; parisc*:Lites*:*:*) GUESS=hppa1.1-hp-lites ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) GUESS=c1-convex-bsd ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) GUESS=c34-convex-bsd ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) GUESS=c38-convex-bsd ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) GUESS=c4-convex-bsd ;; CRAY*Y-MP:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=ymp-cray-unicos$CRAY_REL ;; CRAY*[A-Z]90:*:*:*) echo "$UNAME_MACHINE"-cray-unicos"$UNAME_RELEASE" \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=t90-cray-unicos$CRAY_REL ;; CRAY*T3E:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=alphaev5-cray-unicosmk$CRAY_REL ;; CRAY*SV1:*:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=sv1-cray-unicos$CRAY_REL ;; *:UNICOS/mp:*:*) CRAY_REL=`echo "$UNAME_RELEASE" | sed -e 's/\.[^.]*$/.X/'` GUESS=craynv-cray-unicosmp$CRAY_REL ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz` FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` FUJITSU_REL=`echo "$UNAME_RELEASE" | sed -e 's/ /_/'` GUESS=${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/\///'` FUJITSU_REL=`echo "$UNAME_RELEASE" | tr ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz | sed -e 's/ /_/'` GUESS=sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL} ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) GUESS=$UNAME_MACHINE-pc-bsdi$UNAME_RELEASE ;; sparc*:BSD/OS:*:*) GUESS=sparc-unknown-bsdi$UNAME_RELEASE ;; *:BSD/OS:*:*) GUESS=$UNAME_MACHINE-unknown-bsdi$UNAME_RELEASE ;; arm:FreeBSD:*:*) UNAME_PROCESSOR=`uname -p` set_cc_for_build if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabi else FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL-gnueabihf fi ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case $UNAME_PROCESSOR in amd64) UNAME_PROCESSOR=x86_64 ;; i386) UNAME_PROCESSOR=i586 ;; esac FREEBSD_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_PROCESSOR-unknown-freebsd$FREEBSD_REL ;; i*:CYGWIN*:*) GUESS=$UNAME_MACHINE-pc-cygwin ;; *:MINGW64*:*) GUESS=$UNAME_MACHINE-pc-mingw64 ;; *:MINGW*:*) GUESS=$UNAME_MACHINE-pc-mingw32 ;; *:MSYS*:*) GUESS=$UNAME_MACHINE-pc-msys ;; i*:PW*:*) GUESS=$UNAME_MACHINE-pc-pw32 ;; *:SerenityOS:*:*) GUESS=$UNAME_MACHINE-pc-serenity ;; *:Interix*:*) case $UNAME_MACHINE in x86) GUESS=i586-pc-interix$UNAME_RELEASE ;; authenticamd | genuineintel | EM64T) GUESS=x86_64-unknown-interix$UNAME_RELEASE ;; IA64) GUESS=ia64-unknown-interix$UNAME_RELEASE ;; esac ;; i*:UWIN*:*) GUESS=$UNAME_MACHINE-pc-uwin ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) GUESS=x86_64-pc-cygwin ;; prep*:SunOS:5.*:*) SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/[^.]*//'` GUESS=powerpcle-unknown-solaris2$SUN_REL ;; *:GNU:*:*) # the GNU system GNU_ARCH=`echo "$UNAME_MACHINE" | sed -e 's,[-/].*$,,'` GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's,/.*$,,'` GUESS=$GNU_ARCH-unknown-$LIBC$GNU_REL ;; *:GNU/*:*:*) # other systems with GNU libc and userland GNU_SYS=`echo "$UNAME_SYSTEM" | sed 's,^[^/]*/,,' | tr "[:upper:]" "[:lower:]"` GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC ;; *:Minix:*:*) GUESS=$UNAME_MACHINE-unknown-minix ;; aarch64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC=gnulibc1 ; fi GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; arc:Linux:*:* | arceb:Linux:*:* | arc32:Linux:*:* | arc64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; arm*:Linux:*:*) set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then GUESS=$UNAME_MACHINE-unknown-linux-$LIBC else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabi else GUESS=$UNAME_MACHINE-unknown-linux-${LIBC}eabihf fi fi ;; avr32*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; cris:Linux:*:*) GUESS=$UNAME_MACHINE-axis-linux-$LIBC ;; crisv32:Linux:*:*) GUESS=$UNAME_MACHINE-axis-linux-$LIBC ;; e2k:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; frv:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; hexagon:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; i*86:Linux:*:*) GUESS=$UNAME_MACHINE-pc-linux-$LIBC ;; ia64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; k1om:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; m32r*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; m68*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; mips:Linux:*:* | mips64:Linux:*:*) set_cc_for_build IS_GLIBC=0 test x"${LIBC}" = xgnu && IS_GLIBC=1 sed 's/^ //' << EOF > "$dummy.c" #undef CPU #undef mips #undef mipsel #undef mips64 #undef mips64el #if ${IS_GLIBC} && defined(_ABI64) LIBCABI=gnuabi64 #else #if ${IS_GLIBC} && defined(_ABIN32) LIBCABI=gnuabin32 #else LIBCABI=${LIBC} #endif #endif #if ${IS_GLIBC} && defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 CPU=mipsisa64r6 #else #if ${IS_GLIBC} && !defined(__mips64) && defined(__mips_isa_rev) && __mips_isa_rev>=6 CPU=mipsisa32r6 #else #if defined(__mips64) CPU=mips64 #else CPU=mips #endif #endif #endif #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) MIPS_ENDIAN=el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) MIPS_ENDIAN= #else MIPS_ENDIAN= #endif #endif EOF cc_set_vars=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^CPU\|^MIPS_ENDIAN\|^LIBCABI'` eval "$cc_set_vars" test "x$CPU" != x && { echo "$CPU${MIPS_ENDIAN}-unknown-linux-$LIBCABI"; exit; } ;; mips64el:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; openrisc*:Linux:*:*) GUESS=or1k-unknown-linux-$LIBC ;; or32:Linux:*:* | or1k*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; padre:Linux:*:*) GUESS=sparc-unknown-linux-$LIBC ;; parisc64:Linux:*:* | hppa64:Linux:*:*) GUESS=hppa64-unknown-linux-$LIBC ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) GUESS=hppa1.1-unknown-linux-$LIBC ;; PA8*) GUESS=hppa2.0-unknown-linux-$LIBC ;; *) GUESS=hppa-unknown-linux-$LIBC ;; esac ;; ppc64:Linux:*:*) GUESS=powerpc64-unknown-linux-$LIBC ;; ppc:Linux:*:*) GUESS=powerpc-unknown-linux-$LIBC ;; ppc64le:Linux:*:*) GUESS=powerpc64le-unknown-linux-$LIBC ;; ppcle:Linux:*:*) GUESS=powerpcle-unknown-linux-$LIBC ;; riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; s390:Linux:*:* | s390x:Linux:*:*) GUESS=$UNAME_MACHINE-ibm-linux-$LIBC ;; sh64*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; sh*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; sparc:Linux:*:* | sparc64:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; tile*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; vax:Linux:*:*) GUESS=$UNAME_MACHINE-dec-linux-$LIBC ;; x86_64:Linux:*:*) set_cc_for_build LIBCABI=$LIBC if test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_X32 >/dev/null then LIBCABI=${LIBC}x32 fi fi GUESS=$UNAME_MACHINE-pc-linux-$LIBCABI ;; xtensa*:Linux:*:*) GUESS=$UNAME_MACHINE-unknown-linux-$LIBC ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. GUESS=i386-sequent-sysv4 ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. GUESS=$UNAME_MACHINE-pc-os2-emx ;; i*86:XTS-300:*:STOP) GUESS=$UNAME_MACHINE-unknown-stop ;; i*86:atheos:*:*) GUESS=$UNAME_MACHINE-unknown-atheos ;; i*86:syllable:*:*) GUESS=$UNAME_MACHINE-pc-syllable ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) GUESS=i386-unknown-lynxos$UNAME_RELEASE ;; i*86:*DOS:*:*) GUESS=$UNAME_MACHINE-pc-msdosdjgpp ;; i*86:*:4.*:*) UNAME_REL=`echo "$UNAME_RELEASE" | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then GUESS=$UNAME_MACHINE-univel-sysv$UNAME_REL else GUESS=$UNAME_MACHINE-pc-sysv$UNAME_REL fi ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac GUESS=$UNAME_MACHINE-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 GUESS=$UNAME_MACHINE-pc-sco$UNAME_REL else GUESS=$UNAME_MACHINE-pc-sysv32 fi ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configure will decide that # this is a cross-build. GUESS=i586-pc-msdosdjgpp ;; Intel:Mach:3*:*) GUESS=i386-pc-mach3 ;; paragon:*:*:*) GUESS=i860-intel-osf1 ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then GUESS=i860-stardent-sysv$UNAME_RELEASE # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. GUESS=i860-unknown-sysv$UNAME_RELEASE # Unknown i860-SVR4 fi ;; mini*:CTIX:SYS*5:*) # "miniframe" GUESS=m68010-convergent-sysv ;; mc68k:UNIX:SYSTEM5:3.51m) GUESS=m68k-convergent-sysv ;; M680?0:D-NIX:5.3:*) GUESS=m68k-diab-dnix ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3"$OS_REL"; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) GUESS=m68k-unknown-lynxos$UNAME_RELEASE ;; mc68030:UNIX_System_V:4.*:*) GUESS=m68k-atari-sysv4 ;; TSUNAMI:LynxOS:2.*:*) GUESS=sparc-unknown-lynxos$UNAME_RELEASE ;; rs6000:LynxOS:2.*:*) GUESS=rs6000-unknown-lynxos$UNAME_RELEASE ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) GUESS=powerpc-unknown-lynxos$UNAME_RELEASE ;; SM[BE]S:UNIX_SV:*:*) GUESS=mips-dde-sysv$UNAME_RELEASE ;; RM*:ReliantUNIX-*:*:*) GUESS=mips-sni-sysv4 ;; RM*:SINIX-*:*:*) GUESS=mips-sni-sysv4 ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` GUESS=$UNAME_MACHINE-sni-sysv4 else GUESS=ns32k-sni-sysv fi ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says GUESS=i586-unisys-sysv4 ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm GUESS=hppa1.1-stratus-sysv4 ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. GUESS=i860-stratus-sysv4 ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. GUESS=$UNAME_MACHINE-stratus-vos ;; *:VOS:*:*) # From Paul.Green@stratus.com. GUESS=hppa1.1-stratus-vos ;; mc68*:A/UX:*:*) GUESS=m68k-apple-aux$UNAME_RELEASE ;; news*:NEWS-OS:6*:*) GUESS=mips-sony-newsos6 ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if test -d /usr/nec; then GUESS=mips-nec-sysv$UNAME_RELEASE else GUESS=mips-unknown-sysv$UNAME_RELEASE fi ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. GUESS=powerpc-be-beos ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. GUESS=powerpc-apple-beos ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. GUESS=i586-pc-beos ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. GUESS=i586-pc-haiku ;; x86_64:Haiku:*:*) GUESS=x86_64-unknown-haiku ;; SX-4:SUPER-UX:*:*) GUESS=sx4-nec-superux$UNAME_RELEASE ;; SX-5:SUPER-UX:*:*) GUESS=sx5-nec-superux$UNAME_RELEASE ;; SX-6:SUPER-UX:*:*) GUESS=sx6-nec-superux$UNAME_RELEASE ;; SX-7:SUPER-UX:*:*) GUESS=sx7-nec-superux$UNAME_RELEASE ;; SX-8:SUPER-UX:*:*) GUESS=sx8-nec-superux$UNAME_RELEASE ;; SX-8R:SUPER-UX:*:*) GUESS=sx8r-nec-superux$UNAME_RELEASE ;; SX-ACE:SUPER-UX:*:*) GUESS=sxace-nec-superux$UNAME_RELEASE ;; Power*:Rhapsody:*:*) GUESS=powerpc-apple-rhapsody$UNAME_RELEASE ;; *:Rhapsody:*:*) GUESS=$UNAME_MACHINE-apple-rhapsody$UNAME_RELEASE ;; arm64:Darwin:*:*) GUESS=aarch64-apple-darwin$UNAME_RELEASE ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` case $UNAME_PROCESSOR in unknown) UNAME_PROCESSOR=powerpc ;; esac if command -v xcode-select > /dev/null 2> /dev/null && \ ! xcode-select --print-path > /dev/null 2> /dev/null ; then # Avoid executing cc if there is no toolchain installed as # cc will be a stub that puts up a graphical alert # prompting the user to install developer tools. CC_FOR_BUILD=no_compiler_found else set_cc_for_build fi if test "$CC_FOR_BUILD" != no_compiler_found; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then case $UNAME_PROCESSOR in i386) UNAME_PROCESSOR=x86_64 ;; powerpc) UNAME_PROCESSOR=powerpc64 ;; esac fi # On 10.4-10.6 one might compile for PowerPC via gcc -arch ppc if (echo '#ifdef __POWERPC__'; echo IS_PPC; echo '#endif') | \ (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_PPC >/dev/null then UNAME_PROCESSOR=powerpc fi elif test "$UNAME_PROCESSOR" = i386 ; then # uname -m returns i386 or x86_64 UNAME_PROCESSOR=$UNAME_MACHINE fi GUESS=$UNAME_PROCESSOR-apple-darwin$UNAME_RELEASE ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = x86; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi GUESS=$UNAME_PROCESSOR-$UNAME_MACHINE-nto-qnx$UNAME_RELEASE ;; *:QNX:*:4*) GUESS=i386-pc-qnx ;; NEO-*:NONSTOP_KERNEL:*:*) GUESS=neo-tandem-nsk$UNAME_RELEASE ;; NSE-*:NONSTOP_KERNEL:*:*) GUESS=nse-tandem-nsk$UNAME_RELEASE ;; NSR-*:NONSTOP_KERNEL:*:*) GUESS=nsr-tandem-nsk$UNAME_RELEASE ;; NSV-*:NONSTOP_KERNEL:*:*) GUESS=nsv-tandem-nsk$UNAME_RELEASE ;; NSX-*:NONSTOP_KERNEL:*:*) GUESS=nsx-tandem-nsk$UNAME_RELEASE ;; *:NonStop-UX:*:*) GUESS=mips-compaq-nonstopux ;; BS2000:POSIX*:*:*) GUESS=bs2000-siemens-sysv ;; DS/*:UNIX_System_V:*:*) GUESS=$UNAME_MACHINE-$UNAME_SYSTEM-$UNAME_RELEASE ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "${cputype-}" = 386; then UNAME_MACHINE=i386 elif test "x${cputype-}" != x; then UNAME_MACHINE=$cputype fi GUESS=$UNAME_MACHINE-unknown-plan9 ;; *:TOPS-10:*:*) GUESS=pdp10-unknown-tops10 ;; *:TENEX:*:*) GUESS=pdp10-unknown-tenex ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) GUESS=pdp10-dec-tops20 ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) GUESS=pdp10-xkl-tops20 ;; *:TOPS-20:*:*) GUESS=pdp10-unknown-tops20 ;; *:ITS:*:*) GUESS=pdp10-unknown-its ;; SEI:*:*:SEIUX) GUESS=mips-sei-seiux$UNAME_RELEASE ;; *:DragonFly:*:*) DRAGONFLY_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'` GUESS=$UNAME_MACHINE-unknown-dragonfly$DRAGONFLY_REL ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case $UNAME_MACHINE in A*) GUESS=alpha-dec-vms ;; I*) GUESS=ia64-dec-vms ;; V*) GUESS=vax-dec-vms ;; esac ;; *:XENIX:*:SysV) GUESS=i386-pc-xenix ;; i*86:skyos:*:*) SKYOS_REL=`echo "$UNAME_RELEASE" | sed -e 's/ .*$//'` GUESS=$UNAME_MACHINE-pc-skyos$SKYOS_REL ;; i*86:rdos:*:*) GUESS=$UNAME_MACHINE-pc-rdos ;; i*86:Fiwix:*:*) GUESS=$UNAME_MACHINE-pc-fiwix ;; *:AROS:*:*) GUESS=$UNAME_MACHINE-unknown-aros ;; x86_64:VMkernel:*:*) GUESS=$UNAME_MACHINE-unknown-esx ;; amd64:Isilon\ OneFS:*:*) GUESS=x86_64-unknown-onefs ;; *:Unleashed:*:*) GUESS=$UNAME_MACHINE-unknown-unleashed$UNAME_RELEASE ;; esac # Do we have a guess based on uname results? if test "x$GUESS" != x; then echo "$GUESS" exit fi # No uname command or uname output not recognized. set_cc_for_build cat > "$dummy.c" < #include #endif #if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) #if defined (vax) || defined (__vax) || defined (__vax__) || defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) #include #if defined(_SIZE_T_) || defined(SIGLOST) #include #endif #endif #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) #if !defined (ultrix) #include #if defined (BSD) #if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); #else #if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); #else printf ("vax-dec-bsd\n"); exit (0); #endif #endif #else printf ("vax-dec-bsd\n"); exit (0); #endif #else #if defined(_SIZE_T_) || defined(SIGLOST) struct utsname un; uname (&un); printf ("vax-dec-ultrix%s\n", un.release); exit (0); #else printf ("vax-dec-ultrix\n"); exit (0); #endif #endif #endif #if defined(ultrix) || defined(_ultrix) || defined(__ultrix) || defined(__ultrix__) #if defined(mips) || defined(__mips) || defined(__mips__) || defined(MIPS) || defined(__MIPS__) #if defined(_SIZE_T_) || defined(SIGLOST) struct utsname *un; uname (&un); printf ("mips-dec-ultrix%s\n", un.release); exit (0); #else printf ("mips-dec-ultrix\n"); exit (0); #endif #endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o "$dummy" "$dummy.c" 2>/dev/null && SYSTEM_NAME=`"$dummy"` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo "$ISP-apollo-$SYSTYPE"; exit; } echo "$0: unable to guess system type" >&2 case $UNAME_MACHINE:$UNAME_SYSTEM in mips:Linux | mips64:Linux) # If we got here on MIPS GNU/Linux, output extra information. cat >&2 <&2 <&2 </dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = "$UNAME_MACHINE" UNAME_RELEASE = "$UNAME_RELEASE" UNAME_SYSTEM = "$UNAME_SYSTEM" UNAME_VERSION = "$UNAME_VERSION" EOF fi exit 1 # Local variables: # eval: (add-hook 'before-save-hook 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl-2.6.14/gcl.png0000644000175000017500000003022514360276512012250 0ustar cammcammPNG  IHDR,|Z}PLTEocc۩))fgĿojhxij{trƸm_`vvynnFFujjΦ36{zҿcy93tEXtSoftwaregif2png 2.2.59 IDATx}mCH6`H/d *:vd` K`&PO HI򀭬s 48 $ >'+~}2_hR*&^oܨXTϛjlvi̎#}.%Nyրhl |tŘq-/9өmA85NZ#q,x! E69ZMI:P` X͎/,܀~f#N9@ީ)0kCa®S-f6mvhCro/ePoޔQ6_=?IIR$$2?q74yu%oVq4fɥ=piV4&FDT5LS`Q-zN)ۯ ESuO5ǗpF#z9K2z])Y܏FѢ؛3ucZ``!\GPc}?"ط s^:ʐCx8^QkGutW1여r{6<nMa*X`PHi+wߺ_p;H IG/2o% `}kl-P{E,*X6᪎iKůt'@VWYqBH*Ȅ$7TC^(,F xj3UܞJݐXXS PB+ H zsuxGQ[|~d.#4}uRkL&k s.s0WsaM@IQ%C83; 5اT$Uue$ܤa a+p"8dk LU7]:.͂F06HS&ɉov"O`9WB AW64=uI Iސk i e->݈ J>ے>dꙀ3d(&*Z #I,(HLO29%ƈ%sЕ68_f$ S?uf֫W<[Y)\]M*vP=CYh64_0͕Y$e Pj蛟Jl_D֪uخ n ڹ(6U᱐\= 7=ި jCK#*όm`̾~>EnXʴ4X~,%8== rI݀Q\m^{|v~p;{W|D ROn]K6t5sp>UUc7 狣k=_S=! E&/.Z֔)9Yb8[8M'IDRR` cgzc!< ]؊~YgVx>u8~bq1D Us-3vkA 4ǫ'e.|,`-9 ԕb9:: _yZpD+eM'[Oa> Skijt_ 52?~Ev@[k5u7gWu@ENAjm`^RCP@u7Qcb+` oϟ XCwLb腒YkXVٟX${, !)%H T[9Z 6~h,RuAC9&'WRag1;.xu5ئ*a-"ZVZ޼ٜ `>><X0*c olz@*`5T5DԮ&Jw̴s5q+1sj:(kcE̎Y *5Y]T.BP*0P/@<Zx ,ɛ`X{7'ƟOfx`R{5X~RT*DLJq^4X=U_;-`+YHC.5\̐ް `._*~,ߕp|)/hT奐|f:v<<~C>몓aO-D i]%1H ,`k+OZScozf6 *RGxǏR:K,N|i䩪 Au:roP ͂3OK[qT9+8@ͩ,*[UXNo:9j-|7\*;4A,]@ Aφ\tҚrpCHyH g*xϟ_DFx op)8HcD.3t:pǾg zʢbQ*Y6Ķ'H+ T ڇqeXk,d߾!/P ))c:a]ua.-0Hs`2}]c\R65๡X:)TXOa ?``Vc>[3u'!+6t2 7e;"Xp~΢d ւF=2"JZ '@+h݄V|,(X1KvXzR`CgE#5/ >V`Ao*~бsxluB* 4>9a#\WЮ{iO0(MAnía .tU!1G}YӠs1ʅk4q_ʥa 54*^odOaڶ}:ڿ-B쎔3a%b˛|TYCmW:\xY Qdyo@`#M—'hDI͏^/QK('SF\nV%Buxg٧ggg{gg׀ϣ?~<OQ20]C͏ѿD0(|ZP'r p7>@x}@QӞws>27T$G7/e! Ps$mķN#V+8[)czzhsG T9YLcB=Q_>\Pi)偟 >.da呐W|BqKRb rۮtUUWM|W+<뷧Cb[_ܭMpQE 飖 1`#bMWv ֯;>a?ڻd X!ĖI}o`vnhҧwF]-Б,] @@i3?^a-b\C`,Kxwfh E.t{:oDb6$$*VļL @z\\?ryt"DXS= )I\Ȇ2C3W%@lH 2E<2:rio3qp_B;g^rb^!Wy$.}:2O|#X+;{37k+X@1@- >][t:,Wr٩װh} |,Dж\i߾ǫ#3~͌IAX\\D"GĽ@95 zZ'!$Hu)D=Jcu?H%UFD2ࣣ?IƖc!#N=39Hxq`^ 8 u0u&'qnV@Ji1t!($8>oj+5h/ɧm\Z#[KՀ %@x,w' /["Sꫝ|! B>B s>d0Ɂ`q[xλN*X%nz %;rjGIONb5 xB' w$CS!^^e3RY ]rN .[E!{TK_~4f ?VSjriZ;NcK.Y#I#Rioe#x zI`і| ,s=TQ W0n*Uffڙ un tOrdm?E{-ә畸pQR ~Cc;x5ZC,c4pv:8YFJH`A¾7kRf;4pj6 17繼ʬf[H:. /W$G~WºP)qLPwMgQZ [<"Dcq^x1*GQuΛͮek&={ ϣTQ:ckOQ!E#ka {9ppJ_ٖ)CvtL'~CKN9`(_5pt\᱆Su&zC~T[֠5mMm"߳q(2׫^)X!N ֲ5'Я\ICTi:^NfFaJ:F6ЏDD?KR>^5&D!X(AgE eRW[EwZ ^,NV]|6諲+=u- y)!R sK'k3y`g+Xr/VJ/#e7}f({8%Vb)rXcuif5Eyy:4y1sDibCa:S+7)>jm XF C( kQ1{CJ/ a߫?1mW` Vd i.x**57{E^ 7b1C VlMF:C+V I N5LR.lɓ XO h4X7,n);/YFfėXL*u7n sಥgmvM")kr `MsVutWsj#]aMS7 fwv)eadC,3Ms[r Gr}pM>mopUYdHEbtsuv>KP, Ŀ—-,q\[=pEQ`➰ Ճ綢-@&sG\pQdl:I%{,: 9x^t+W{gvIt2?E<Mq 6NwfX8 lȳI%;5\,vFEx2l6m5|2bhzHEϨr‹t[P$^X4XX):Q%GcJጟ)&'Pҗn;Y$5kжlŕ+m`iSNd,b}uX2n9($ 0.|X5xx}}F)xsT.e8#}|X@;Q@t$6O$ ނ3tK`$4 "#򞗋QrjЀ + Ջ3]'|+0VR KU3[@6$;< 2wh7-<`BOiT|~.:ybOe͚8=s*J]} ]݁">ˑ~鲸ژZ aa8FRak ,VH΃, 9tl_v)%iFTrlj~xp٫mj/xo<LDs5ס?eZ:_*m2A}ӒA:LIfi|x-2IDATBӕklVɠ&jm F= (Z5iryEz`F`qvr ' ZV:ͬḃ^xu=] =kn>(3)Sck(-13,Ƽs2ʉx‹#ibs{<.Btvp0WƩy'[2 BYžclƔ|/̹ݧ{{O.Θ[*7Bj&VJ?SK&:˚f(|Jo5CwݬRlx!3$ ᕿRXcB,WQ4WqIMP{S2ɋ 𙤻ipQf=Sf#(mbuP2`)ZfI\f4͸`M 2lea M'T_OWʦY]b5KN1_ֱņ])BG:Ud@qHRK_HA2"F^[;C{L2UѸ7[, L6 1&K~->ILy|M xs1%?\):u~P\XK9QV[I'P|5V놞 ?VVpN*9ޜ"VX<u-`9ZpzEiI1Z+`&V;^0<:QU<ɢd$m`U}#1?&űȷ ? J6gt8 o l(7wcB% Ƽ#A+ }W=m$ $rwqNޡ3Xo&9,؍I4Zkr ޱO9)ܲ| _UxٹF)4+9[冭Uv(pC[ Dlup$¤-qLJXM{ rO`i)z%8J]k<<$Ӕj_Y[9*?֒Z-_( 1/8|iWvrˤď#*nvkb؟s؇+B֐1<_"X~tPTNkXU:5_N%Ok`K̋6 a>x[+~ʾ^id2u^! X{\PC;"hD c,Rfè:7.%`[`8WCY4Hjdp+*R[Lbou\WY*ec:<5qC$̫rW٩ˆ&X& Ml?Pa.|wssto*o 34Y &)nޓk` gb޺l XG!@@4oLK$*Y`61ͅN[d~Od$zX qWǰr|q+ii&fZ7΂-q E.DƖtEakJj#|,1CtB`Cw 5~Ts=o$8v:X Q.րU8U2ؿ!nq8j+.foLɵͺ61=7abIZ]S;OfxXM ҅hvq0 I|֜ߟM _3[ҤsCp(+HSĉS_ìa0:J2мZo d g80GM:-G%iP^ !i(.bZ|'_4}U̴T9U4Es#Q3;I+&0{:_fnΞwl< ؖ+SX*: ܜDCZւUN8Yk8=cHIUEñXyhv~8F0x(lyp%qdvE`=lBY RlKwb"IMMQƟ^1&G7Էww\[LP-ʴ(seT<+B;dm`MZ\?]]<'zjȑuL2VBHwwol#HE pk,ׇW.qƈ1Eysi ,B+Eyb H'7-t(*uDm>86E CAMhەU.νHƎV2Zz QgEIM4 dڛ "oFwh'墹9LDo85]Q  wp`)*6g >=h_KLۭw0, =8s+orKW|flxF" 8ZǸOQ E^oyYtWL%W9ZO o/j~:[NU24!uqc_4#QShU":0eE007hPQt֍nvdI-Sܶ/"H&n6A.U$]I:DCD{ُ~ߓ-^ZA}8IɷZ<Ϣ2RI#qz͡ 6n%#9Vt=WFD TEm&M}t$2~EUnT$+j2A-LZ;ZA6H+ˈit"1Fib5<5h[|qЇ}>"m Q Y!>&Ob$ $M*Dr\JO(Vٺ-qe+>B+K8ֈ$;C<lv(oIDq i*NE=dϨ~Hj;$nC#)#,lQ6In/?׸L^%2oKlsaSl$sL,!zd"HWîr.*'D)(ee>QVM"h ̟7|{ָ.J36/4 Ht{ P{ч^פWm{nGB"7QOAIqKN/jёorSJ@»L61ٲ:?)- ᄡۧsZW>FL+&dlBH?5r"sW+oix?5EM9eeuƈ%#.IztO PJɥW-RpZcd !V:|pZbRi6P:;IcRѕk P,~FBi]97;"Y4]fxbT]R9'Îw zGW;/Dm&xWbq{ 0|=^W]9Xr!6Ysmlop'_Tzq|,2EGhwf g.]_dۢ+75}9\hZIL:.#r,'#F5~z뿿#Dkϓ,t*1\||}n^cJlZXĈbt^РOvg[{[/Z]uJx}0K e4{pnuu_},}/pjG+X'(-e|3+2zLN OF`{IENDB`gcl-2.6.14/AC_FD_CC0000644000175000017500000000032414360276512012116 0ustar cammcamm#line 40 "configure" #include "confdefs.h" #include main() { char *b = (void *) malloc(1000); FILE *fp = fopen("conftest1","w"); fprintf(fp,"0x%x",((unsigned int) b) & ~0xffffff); fclose(fp); } gcl-2.6.14/o/0000755000175000017500000000000014360276512011231 5ustar cammcammgcl-2.6.14/o/ndiv.c0000755000175000017500000000520114360276512012336 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ /* author: William F. Schelter The following is an implementation of extended_div in C suitable for a machine which can do 32 bit arithmetic. The assembler output could be optimized, so that carry tests were read from the condition codes */ #include "arith.h" /* #define ESTIMATE_LOG_QUOTIENT(x,l,d) estimate_logq(x,l,d) */ #define ESTIMATE_LOG_QUOTIENT(x,l,d) 31 /* int estimate_logq(x,l,div) unsigned int x,div,l; { unsigned int logq,w; if (x==0) {w=0;x=l;} else {w=WSIZ;} for(logq=0; logq < WSIZ ; logq+=1) if ((div << logq) >= x) break; return 31; return logq+w;} */ extended_div(divisor,dh,dl,q,r) unsigned int dh,dl , divisor, *q, *r; { unsigned int Rh,Rl,temph,templ; unsigned int Q; int iter; #ifdef DEBUG char *op; #endif Rh=dh; Rl=dl; /* if (dh) printf("\n(di %d %d %d ",divisor,dh,dl); */ NORMALIZE(Rh,Rl); Q=0; if (dh==0) {*q=dl/divisor; *r=dl%divisor; return;} #ifdef DEBUG printf("\n%d (Q %d %d) (R %d %d) %s" , -1,0,Q,Rh,Rl,"begin"); #endif for (iter=ESTIMATE_LOG_QUOTIENT(dh,dl,divisor); iter >=0 ; iter-= 1) { /* assert(Q*divisor+R ==dividend); */ lshift(divisor,iter,temph,templ); if ((int)Rh>=0) {lsub(temph,templ,Rh,Rl); #ifdef DEBUG op="add"; #endif /* lshift(1,iter,temph,templ); ladd(temph,templ,Qh,Ql); */ /* ladd(0,(1< | fun | | list1 | | : | | : | | listn | top -> | value | ----- the list which should be returned | arg1 | --| | : | |-- arguments to FUN. | : | | On call to FUN, vs_base = top+1 | argn | --| vs_top = top+n+1 |-------| | | VS */ LFD(Lmapcar)(void) { object *top = vs_top; object *base = vs_base; object x, handy; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(Cnil); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { base[0] = Cnil; vs_top = base+1; vs_base = base; return; } vs_push(MMcar(x)); base[i] = MMcdr(x); } handy = top[0] = MMcons(Cnil,Cnil); LOOP: vs_base = top+1; super_funcall(base[0]); MMcar(handy) = vs_base[0]; for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = MMcar(x); base[i] = MMcdr(x); } vs_top = top+n+1; handy = MMcdr(handy) = MMcons(Cnil,Cnil); goto LOOP; } LFD(Lmaplist)(void) { object *top = vs_top; object *base = vs_base; object x, handy; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(Cnil); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { base[0] = Cnil; vs_top = base+1; vs_base = base; return; } vs_push(x); base[i] = MMcdr(x); } handy = top[0] = MMcons(Cnil,Cnil); LOOP: vs_base = top+1; super_funcall(base[0]); MMcar(handy) = vs_base[0]; for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = x; base[i] = MMcdr(x); } vs_top = top+n+1; handy = MMcdr(handy) = MMcons(Cnil,Cnil); goto LOOP; } LFD(Lmapc)(void) { object *top = vs_top; object *base = vs_base; object x; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(base[1]); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_top = top+1; vs_base = top; return; } vs_push(MMcar(x)); base[i] = MMcdr(x); } LOOP: vs_base = top+1; super_funcall(base[0]); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = MMcar(x); base[i] = MMcdr(x); } vs_top = top+n+1; goto LOOP; } LFD(Lmapl)(void) { object *top = vs_top; object *base = vs_base; object x; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(base[1]); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_top = top+1; vs_base = top; return; } vs_push(x); base[i] = MMcdr(x); } LOOP: vs_base = top+1; super_funcall(base[0]); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = x; base[i] = MMcdr(x); } vs_top = top+n+1; goto LOOP; } LFD(Lmapcan)(void) { object *top = vs_top; object *base = vs_base; object x, handy; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(Cnil); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { base[0] = Cnil; vs_top = base+1; vs_base = base; return; } vs_push(MMcar(x)); base[i] = MMcdr(x); } handy = Cnil; LOOP: vs_base = top+1; super_funcall(base[0]); if (endp(handy)) handy = top[0] = vs_base[0]; else { x = MMcdr(handy); while(!endp(x)) { handy = x; x = MMcdr(x); } MMcdr(handy) = vs_base[0]; } for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = MMcar(x); base[i] = MMcdr(x); } vs_top = top+n+1; goto LOOP; } LFD(Lmapcon)(void) { object *top = vs_top; object *base = vs_base; object x, handy; int n = vs_top-vs_base-1; int i; if (n <= 0) too_few_arguments(); vs_push(Cnil); for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { base[0] = Cnil; vs_top = base+1; vs_base = base; return; } vs_push(x); base[i] = MMcdr(x); } handy = Cnil; LOOP: vs_base = top+1; super_funcall(base[0]); if (endp(handy)) handy = top[0] = vs_base[0]; else { x = MMcdr(handy); while(!endp(x)) { handy = x; x = MMcdr(x); } MMcdr(handy) = vs_base[0]; } for (i = 1; i <= n; i++) { x = base[i]; if (endp(x)) { vs_base = top; vs_top = top+1; return; } top[i] = x; base[i] = MMcdr(x); } vs_top = top+n+1; goto LOOP; } void gcl_init_mapfun(void) { make_function("MAPCAR", Lmapcar); make_function("MAPLIST", Lmaplist); make_function("MAPC", Lmapc); make_function("MAPL", Lmapl); make_function("MAPCAN", Lmapcan); make_function("MAPCON", Lmapcon); } gcl-2.6.14/o/internal-calls.lisp0000755000175000017500000013436414360276512015050 0ustar cammcamm(setq all-references ( ;;/* for file nfunlink.X */ ( "nfunlink.X" "FEerror" "FEinvalid_function" "vpush_extend" "FEerror" "vs_overflow" "ihs_punsh_base" "ihs_overflow" "funcall" "FEerror" ) ;;/* for file alloc.X */ ( "alloc.X" "sgc_quit" "GBC" "sgc_start" "error" "error" "alarm" "terminal_interrupt" "GBC" "sgc_count_type" "call_after_gbc_hook" "CEerror" "alarm" "terminal_interrupt" "GBC" "sgc_count_type" "call_after_gbc_hook" "CEerror" "set_up_string_register" "t_from_type" "terminal_interrupt" "insert_contblock" "GBC" "CEerror" "insert_contblock" "terminal_interrupt" "GBC" "FEerror" "error" "CEerror" "getpagesize" "error" "bzero" "getrlimit" "enter_mark_origin" "FEerror" "too_few_arguments" "too_many_arguments" "t_from_type" "FEerror" "strncmp" "FEerror" "check_arg_failed" "check_arg_failed" "too_few_arguments" "too_many_arguments" "FEerror" "printf" "check_arg_failed" "check_arg_failed" "too_few_arguments" "too_many_arguments" "FEerror" "check_arg_failed" "check_arg_failed" "check_arg_failed" "fixint" "FEerror" "endp1" "FEerror" "endp1" "FEerror" "getpagesize" ) ;;/* for file array.X */ ( "array.X" "FEwrong_type_argument" "FEerror" "FEerror" "FEerror" "FEerror" "FEerror" "bcopy" "check_arg_failed" "FEerror" "FEerror" "FEerror" "FEerror" "fixint" "FEerror" "FEerror" "FEerror" "FEerror" "FEerror" "FEerror" "fixnnint" "FEerror" "FEerror" "FEerror" "fixnnint" "FEerror" "too_few_arguments" "FEerror" "fixnnint" "FEerror" "FEerror" "check_arg_failed" "fixnnint" "FEerror" "too_few_arguments" "FEerror" "fixnnint" "fixnnint" "FEwrong_type_argument" "too_few_arguments" "FEerror" "fixnnint" "fixnnint" "FEwrong_type_argument" "check_arg_failed" "check_arg_failed" "check_type_array" "check_arg_failed" "check_type_array" "fixnnint" "FEerror" "check_arg_failed" "check_type_array" "check_arg_failed" "check_type_array" "check_arg_failed" "check_type_array" "check_arg_failed" "FEerror" "illegal_index" "check_arg_failed" "FEerror" "fixnnint" "illegal_index" "check_arg_failed" "check_type_array" "check_arg_failed" "check_type_vector" "FEerror" "check_arg_failed" "check_type_vector" "fixnnint" "FEerror" "check_arg_failed" "FEerror" "check_arg_failed" "endp1" ) ;;/* for file assignment.X */ ( "assignment.X" "not_a_symbol" "FEinvalid_variable" "endp1" "endp1" "FEinvalid_form" "eval" "endp1" "FEinvalid_form" "eval" "check_arg_failed" "not_a_symbol" "FEinvalid_variable" "check_arg_failed" "not_a_symbol" "FEerror" "FEerror" "endp1" "FEinvalid_form" "eval" "check_arg_failed" "not_a_symbol" "FEinvalid_variable" "check_arg_failed" "not_a_symbol" "FEerror" "remf" "endp1" "FEinvalid_form" "setf" "eval" "eval" "eval" "eval" "siLputprop" "eval" "eval" "FEerror" "eval" "eval" "FEerror" "eval" "eval" "eval" "eval" "eval" "eval" "endp1" "eval" "eval" "stack_cons" "FEerror" "funcall" "eval" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "stack_cons" "FEerror" "funcall" "eval" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "stack_cons" "FEerror" "funcall" "eval" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "eval" "stack_cons" "FEerror" "funcall" "eval" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "eval" "stack_cons" "FEerror" "funcall" "eval" "use_fast_links" "check_arg_failed" "enter_mark_origin" ) ;;/* for file backq.X */ ( "backq.X" "FEerror" "backq_car" "stack_cons" "stack_cons" "stack_cons" "error" "stack_cons" "error" "stack_cons" "stack_cons" "stack_cons" "stack_cons" "stack_cons" "error" "stack_cons" "error" "error" "FEerror" "check_arg_failed" "FEerror" "stack_cons" "check_arg_failed" "enter_mark_origin" ) ;;/* for file bcmp.X */ ( "bcmp.X" ) ;;/* for file bcopy.X */ ( "bcopy.X" ) ;;/* for file bds.X */ ( "bds.X" ) ;;/* for file big.X */ ( "big.X" "cmpii" "FEerror" "FEerror" "FEerror" "FEwrong_type_argument" ) ;;/* for file bind.X */ ( "bind.X" "bds_overflow" "FEerror" "endp1" "not_a_symbol" "illegal_lambda" "endp1" "not_a_symbol" "not_a_variable" "illegal_lambda" "not_a_symbol" "illegal_lambda" "not_a_variable" "endp1" "illegal_lambda" "not_a_symbol" "not_a_variable" "keywordp" "illegal_declare" "check_arg_failed" "FEtoo_few_arguments" "check_arg_failed" "FEtoo_many_arguments" "bind_var" "eval" "keywordp" "eval" "eval" "illegal_declare" "check_arg_failed" "FEerror" "FEerror" "endp1" "illegal_declare" "not_a_symbol" "bds_overflow" "eval" "bds_overflow" "eval" "FEerror" "keywordp" "keywordp" "stack_cons" "endp1" "keywordp" "FEerror" "bzero" "FEerror" "FEerror" "FEerror" "enter_mark_origin" ) ;;/* for file bitop.X */ ( "bitop.X" "error" "error" "error" ) ;;/* for file block.X */ ( "block.X" "endp1" "FEtoo_few_argumentsF" "lex_block_bind" "frs_overflow" "eval" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "FEerror" "eval" "unwind" "endp1" "FEtoo_many_argumentsF" "FEerror" "eval" "unwind" "enter_mark_origin" ) ;;/* for file bzero.X */ ( "bzero.X" ) ;;/* for file catch.X */ ( "catch.X" "endp1" "FEtoo_few_argumentsF" "eval" "frs_overflow" "Fprogn" "check_arg_failed" "frs_overflow" "eval" "endp1" "FEtoo_few_argumentsF" "frs_overflow" "Fprogn" "unwind" "eval" "Fprogn" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "FEerror" "unwind" ) ;;/* for file cfun.X */ ( "cfun.X" "FEerror" "FEerror" "check_type" "error" "error" "error" "not_a_symbol" "check_type" "error" "not_a_symbol" "check_type" "error" "set_key_struct" "not_a_symbol" "FEerror" "not_a_symbol" "check_arg_failed" "FEerror" "endp1" "check_arg_failed" ) ;;/* for file character.X */ ( "character.X" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_non_negative_integer" "check_arg_failed" "check_type_character" "too_few_arguments" "check_type_character" "too_few_arguments" "check_type_character" "too_few_arguments" "check_type_character" "too_few_arguments" "check_type_character" "too_few_arguments" "check_type_character" "too_few_arguments" "check_type_character" "check_arg_failed" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "too_few_arguments" "too_many_arguments" "check_type_non_negative_integer" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_non_negative_integer" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_character" "too_few_arguments" "too_many_arguments" "check_type_non_negative_integer" "check_arg_failed" "check_type_character" "check_arg_failed" "check_type_non_negative_integer" "check_arg_failed" "check_type_character" "check_arg_failed" "string_equal" "check_arg_failed" "check_type_character" "FEerror" "check_arg_failed" "check_type_character" "FEerror" "enter_mark_origin" ) ;;/* for file cmpaux.X */ ( "cmpaux.X" "check_arg_failed" "FEerror" "FEerror" "set_VV" "FEerror" "FEerror" "FEerror" "FEerror" "FEwrong_type_argument" "bcopy" "check_type" "check_type" "eval" "printf" "fflush" "printf" "fflush" "load" ) ;;/* for file conditional.X */ ( "conditional.X" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "endp1" "FEerror" "eval" "endp1" "FEtoo_few_argumentsF" "eval" "FEerror" "eql" "eql" "endp1" "FEtoo_few_argumentsF" "eval" "endp1" "FEtoo_few_argumentsF" "eval" "enter_mark_origin" ) ;;/* for file earith.X */ ( "earith.X" "divul3" "integer_quotient_remainder_1" "number_compare" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" ) ;;/* for file error.X */ ( "error.X" "super_funcall" "keywordp" "not_a_keyword" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "unwind" "_flsbuf" "printf" "endp1" "endp1" "fcalln_general" "super_funcall" "enter_mark_origin" ) ;;/* for file eval.X */ ( "eval.X" "check_arg_failed" "FEerror" "FEtoo_few_arguments" "FEtoo_many_arguments" "FEerror" "ihs_overflow" "FEwrong_type_argument" "FEundefined_function" "FEinvalid_function" "ihs_overflow" "lambda_bind" "frs_overflow" "FEwrong_type_argument" "eval" "bds_unwind" "FEerror" "FEwrong_type_argument" "FEerror" "ihs_overflow" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEerror" "ihs_overflow" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEerror" "ihs_overflow" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEerror" "ihs_overflow" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEinvalid_function" "FEundefined_function" "FEinvalid_function" "FEundefined_function" "vs_overflow" "stack_cons" "bds_unwind" "FEunbound_variable" "FEwrong_type_argument" "ihs_overflow" "FEundefined_function" "macro_expand1" "ihs_overflow" "FEwrong_type_argument" "call_applyhook" "FEinvalid_function" "stack_cons" "too_few_arguments" "too_few_arguments" "FEwrong_type_argument" "check_arg_failed" "too_few_arguments" "too_many_arguments" "bds_unwind" "too_few_arguments" "too_many_arguments" "FEwrong_type_argument" "bds_unwind" "check_arg_failed" "frs_overflow" "FEerror" "FEwrong_type_argument" "FEerror" "FEerror" "FEerror" "enter_mark_origin" ) ;;/* for file fat_string.X */ ( "fat_string.X" "error" "printf" "printf" "printf" "_flsbuf" "printf" "_flsbuf" "fflush" "_filbuf" "printf" "fflush" "fread" "printf" "_flsbuf" "fflush" "fwrite" "printf" "_flsbuf" "_filbuf" "printf" "sethash" "fputc" "printf" "fputc" "printf" "printf" "_flsbuf" "printf" "_flsbuf" "FEerror" "FEerror" "write_fasd" "frs_overflow" "_filbuf" "FEerror" "unwind" "check_type" "check_type" "check_type" "array_allocself" "file_position" "fputc" "printf" "_flsbuf" "write_fasd" "_filbuf" "FEerror" "check_type" "gset" "clrhash" "fputc" "file_position" "file_position_set" "printf" "_flsbuf" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "fputc" "printf" "_flsbuf" "fputc" "fputc" "printf" "_flsbuf" "fputc" "fputc" "printf" "_flsbuf" "fputc" "printf" "_flsbuf" "printf" "_flsbuf" "printf" "_flsbuf" "FEerror" "printf" "_flsbuf" "printf" "_flsbuf" "printf" "_flsbuf" "FEerror" "sethash" "find_sharing" "Leval" "bcopy" "FEerror" "_filbuf" "printf" "printf" "printf" "printf" "pp" "printf" "FEerror" "printf" "printf" "printf" "printf" "printf" "printf" "printf" "printf" "siLmake_structure" "printf" "printf" "printf" "array_allocself" "printf" "printf" "printf" "printf" "array_allocself" "printf" "princ_str" "princ_str" "_filbuf" "FEerror" "ungetc" "readc_stream" "unreadc_stream" "unreadc_stream" "gset" "close_stream" "FEerror" "gset" "FEerror" "profil" "check_arg_failed" "FEerror" "perror" "fread" "FEerror" "perror" "_filbuf" "fclose" "check_arg_failed" "check_type_string" "strncpy" "qsort" "free" "FEerror" "FEerror" "qsort" "FEerror" "check_arg_failed" "printf" "fflush" "printf" "fflush" "check_arg_failed" "enter_mark_origin" ) ;;/* for file file.X */ ( "file.X" "error" "FEerror" "FEwrong_type_argument" "error" "FEwrong_type_argument" "error" "FEwrong_type_argument" "endp1" "error" "perm_writable" "setbuf" "insert_contblock" "printf" "too_long_file_name" "cannot_open" "cannot_create" "fclose" "FEerror" "fclose" "FEerror" "cannot_create" "cannot_create" "cannot_open" "FEerror" "cannot_create" "error" "FEerror" "fflush" "fclose" "FEwrong_type_argument" "endp1" "error" "closed_stream" "_filbuf" "FEwrong_type_argument" "endp1" "stream_at_end" "flush_stream" "writec_stream" "cannot_read" "super_funcall" "error" "closed_stream" "ungetc" "FEwrong_type_argument" "endp1" "super_funcall" "error" "FEerror" "closed_stream" "_flsbuf" "FEwrong_type_argument" "endp1" "FEerror" "adjust_displaced" "cannot_write" "super_funcall" "error" "closed_stream" "fflush" "FEwrong_type_argument" "endp1" "FEerror" "super_funcall" "error" "closed_stream" "_filbuf" "ungetc" "FEwrong_type_argument" "endp1" "error" "closed_stream" "ioctl" "FEwrong_type_argument" "endp1" "FEerror" "error" "closed_stream" "FEwrong_type_argument" "error" "closed_stream" "fseek" "FEwrong_type_argument" "error" "closed_stream" "file_len" "FEwrong_type_argument" "error" "FEwrong_type_argument" "endp1" "error" "check_arg_failed" "check_type_symbol" "cannot_write" "stack_cons" "cannot_read" "stack_cons" "check_arg_failed" "cannot_read" "cannot_write" "check_arg_failed" "cannot_read" "cannot_write" "too_few_arguments" "too_many_arguments" "check_type_string" "FEerror" "check_arg_failed" "check_arg_failed" "FEerror" "check_arg_failed" "FEerror" "check_arg_failed" "check_arg_failed" "check_type_stream" "check_arg_failed" "check_type_stream" "check_arg_failed" "check_type_stream" "too_few_arguments" "parse_key" "check_type_stream" "too_few_arguments" "parse_key" "check_type_or_pathname_string_symbol_stream" "FEerror" "too_few_arguments" "too_many_arguments" "check_type_stream" "FEerror" "check_arg_failed" "check_type_stream" "too_few_arguments" "parse_key" "check_type_or_pathname_string_symbol_stream" "string_eq" "file_exists" "setupPRINTdefault" "write_str" "write_object" "cleanupPRINT" "fasload" "setupPRINTdefault" "write_str" "cleanupPRINT" "bds_unwind" "setupPRINTdefault" "write_str" "write_object" "cleanupPRINT" "setupPRINTdefault" "write_str" "write_object" "cleanupPRINT" "frs_overflow" "bds_unwind" "unwind" "eval" "setupPRINTdefault" "write_object" "write_str" "cleanupPRINT" "bds_unwind" "setupPRINTdefault" "write_str" "write_object" "cleanupPRINT" "check_arg_failed" "check_type_stream" "FEerror" "check_arg_failed" "FEerror" "check_arg_failed" "check_type_stream" "FEerror" "FEerror" "FEerror" "FEerror" "FEerror" "check_arg_failed" "FEerror" "FEerror" "FEwrong_type_argument" "check_arg_failed" "check_arg_failed" "check_arg_failed" "fwrite" "check_arg_failed" "fread" "enter_mark_origin" "enter_mark_origin" "fread" "fseek" ) ;;/* for file format.X */ ( "format.X" "fmt_error" "fmt_error" "writec_stream" "fmt_error" "fmt_ascii" "fmt_S_expression" "fmt_decimal" "fmt_binary" "fmt_octal" "fmt_hexadecimal" "fmt_radix" "fmt_plural" "fmt_character" "fmt_fix_float" "fmt_exponential_float" "fmt_general_float" "fmt_dollars_float" "fmt_percent" "fmt_ampersand" "fmt_bar" "fmt_tilde" "fmt_newline" "fmt_tabulate" "fmt_asterisk" "fmt_indirection" "fmt_case" "fmt_conditional" "fmt_iteration" "fmt_justification" "fmt_up_and_out" "fmt_semicolon" "funcall" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "file_column" "writestr_stream" "write_string" "writec_stream" "writec_stream" "write_string" "file_column" "writestr_stream" "write_string" "writec_stream" "writec_stream" "write_string" "fmt_integer" "fmt_integer" "fmt_integer" "fmt_integer" "check_type_integer" "fmt_integer" "fmt_roman" "file_column" "write_object" "writestr_stream" "writestr_stream" "fmt_nonillion" "writestr_stream" "check_type_integer" "FEerror" "fmt_integer" "file_column" "setupPRINTdefault" "write_object" "cleanupPRINT" "writec_stream" "file_column" "write_object" "writec_stream" "fmt_thousand" "writec_stream" "writestr_stream" "fmt_thousand" "writec_stream" "fmt_write_numeral" "writestr_stream" "writec_stream" "fmt_write_ordinal" "fmt_write_numeral" "fmt_write_ordinal" "fmt_write_numeral" "writec_stream" "fmt_write_ordinal" "fmt_write_numeral" "writestr_stream" "writestr_stream" "writec_stream" "fmt_error" "eql" "writec_stream" "writestr_stream" "check_type_character" "writec_stream" "fmt_error" "edit_double" "writec_stream" "writec_stream" "writestr_stream" "writec_stream" "fmt_exponent1" "writec_stream" "fmt_error" "edit_double" "writec_stream" "writec_stream" "writestr_stream" "fmt_error" "edit_double" "writec_stream" "fmt_error" "edit_double" "writec_stream" "writec_stream" "writec_stream" "writec_stream" "file_column" "writec_stream" "writec_stream" "writec_stream" "writec_stream" "file_column" "writestr_stream" "writec_stream" "writec_stream" "file_column" "fmt_error" "fmt_error" "fmt_error" "endp1" "vs_overflow" "fmt_error" "writec_stream" "writec_stream" "writec_stream" "writec_stream" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "fmt_error" "endp1" "vs_overflow" "endp1" "vs_overflow" "endp1" "vs_overflow" "fmt_error" "file_column" "writec_stream" "writec_stream" "fmt_error" "too_few_arguments" "FEerror" "check_type_stream" "check_type_string" "frs_overflow" "file_column" "fmt_error" "flush_stream" "unwind" "FEerror" "enter_mark_origin" ) ;;/* for file frame.X */ ( "frame.X" "bds_unwind" ) ;;/* for file funlink.X */ ( "funlink.X" "FEinvalid_function" "ihs_overflow" "funcall" "vpush_extend" "FEinvalid_function" "vpush_extend" "ihs_overflow" "ihs_overflow" "funcall" "vpush_extend" "use_fast_links" "clean_link_array" "check_type_array" "not_a_symbol" "FEerror" "FEerror" "check_type_symbol" "FEerror" "FEinvalid_function" "vs_overflow" "funcall" "vs_overflow" "super_funcall" "vs_overflow" "super_funcall" "FEerror" "FEerror" "array_allocself" "FEerror" "FEerror" "FEerror" "FEerror" "FEerror" ) ;;/* for file gbc.X */ ( "gbc.X" "error" "error" "mark_object" "mark_contblock" "mark_contblock" "adjust_displaced" "printf" "adjust_displaced" "fclose" "error" "printf" "error" "fprintf" "fflush" "clear_stack" "printf" "fflush" "printf" "fflush" "mark_c_stack" "printf" "_flsbuf" "fflush" "insert_contblock" "printf" "fflush" "error" "sgc_quit" "printf" "sgc_count_type" "sgc_count_writable" "fflush" "printf" "fflush" "sgc_quit" "fprintf" "fflush" "sgc_mark_phase" "printf" "fflush" "printf" "fflush" "sgc_sweep_phase" "printf" "fflush" "printf" "fflush" "sgc_contblock_sweep_phase" "printf" "printf" "printf" "printf" "fflush" "sgc_start" "fprintf" "fflush" "sigint" "check_arg_failed" "vs_overflow" "check_arg_failed" "check_arg_failed" "sgc_mark_object1" "sgc_mark_object1" "adjust_displaced" "printf" "adjust_displaced" "fclose" "error" "printf" "error" "fprintf" "fflush" "clear_stack" "printf" "fflush" "printf" "fflush" "printf" "_flsbuf" "fflush" "insert_contblock" "printf" "fflush" "bzero" "printf" "fflush" "add_page_to_freelist" "printf" "fflush" "printf" "fflush" "sgc_mprotect" "mprotect" "mprotect" "FEerror" "check_arg_failed" "FEerror" "perror" ) ;;/* for file hash.X */ ( "hash.X" "bzero" "eql" "equal" "extend_hashtable" "too_few_arguments" "parse_key" "FEerror" "check_arg_failed" "too_few_arguments" "too_many_arguments" "check_type_hash_table" "check_arg_failed" "check_type_hash_table" "check_arg_failed" "check_type_hash_table" "check_arg_failed" "check_type_hash_table" "check_arg_failed" "check_type_hash_table" "check_arg_failed" "check_arg_failed" "check_type_hash_table" ) ;;/* for file init_pari.X */ ( "init_pari.X" "FEerror" "free" "set_pari_stack" "malloc" ) ;;/* for file iteration.X */ ( "iteration.X" "lex_block_bind" "frs_overflow" "endp1" "eval" "eval" "endp1" "FEinvalid_form" "not_a_variable" "FEerror" "endp1" "FEtoo_few_argumentsF" "FEinvalid_form" "lex_block_bind" "frs_overflow" "eval" "Ftagbody" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "FEinvalid_form" "lex_block_bind" "frs_overflow" "eval" "Ftagbody" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "FEerror" "lex_block_bind" "frs_overflow" "eval" "bind_var" "eval" "Ftagbody" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "FEerror" "lex_block_bind" "frs_overflow" "eval" "FEwrong_type_argument" "bind_var" "number_compare" "eval" "Ftagbody" "bds_unwind" ) ;;/* for file let.X */ ( "let.X" "endp1" "not_a_variable" "not_a_variable" "FEerror" "endp1" "FEerror" "Fprogn" "bds_unwind" "endp1" "FEerror" "Fprogn" "bds_unwind" "endp1" "FEerror" "eval" "not_a_variable" "bind_var" "Fprogn" "bds_unwind" "endp1" "FEerror" "eval" "bind_var" "Fprogn" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "FEerror" "lex_fun_bind" "Fprogn" "endp1" "FEtoo_few_argumentsF" "FEerror" "lex_fun_bind" "Fprogn" "endp1" "FEtoo_few_argumentsF" "FEerror" "lex_macro_bind" "Fprogn" ) ;;/* for file lex.X */ ( "lex.X" "endp1" "endp1" "eql" "endp1" "enter_mark_origin" ) ;;/* for file list.X */ ( "list.X" "eql" "FEerror" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "vs_overflow" "vs_overflow" "FEwrong_type_argument" "vs_overflow" "vs_overflow" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "too_few_arguments" "parse_key" "frs_overflow" "unwind" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "fixint" "FEerror" "FEwrong_type_argument" "check_arg_failed" "fixint" "FEerror" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "too_few_arguments" "too_few_arguments" "parse_key" "check_type_non_negative_integer" "FEerror" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "too_few_arguments" "too_many_arguments" "check_type_non_negative_integer" "FEwrong_type_argument" "vs_overflow" "too_few_arguments" "too_many_arguments" "check_type_non_negative_integer" "FEwrong_type_argument" "check_arg_failed" "FEwrong_type_argument" "vs_overflow" "check_arg_failed" "check_type_cons" "check_arg_failed" "check_type_cons" "too_few_arguments" "parse_key" "frs_overflow" "unwind" "too_few_arguments" "too_few_arguments" "too_few_arguments" "parse_key" "frs_overflow" "unwind" "too_few_arguments" "too_few_arguments" "FEwrong_type_argument" "FEerror" "too_few_arguments" "parse_key" "frs_overflow" "unwind" "too_few_arguments" "parse_key" "frs_overflow" "unwind" "too_few_arguments" "parse_key" "frs_overflow" "FEwrong_type_argument" "unwind" "too_few_arguments" "too_few_arguments" "too_few_arguments" "parse_key" "frs_overflow" "FEwrong_type_argument" "unwind" "check_arg_failed" "FEwrong_type_argument" "too_few_arguments" "check_arg_failed" "too_few_arguments" "too_many_arguments" "FEwrong_type_argument" "FEerror" "vs_overflow" "FEerror" "too_few_arguments" "parse_key" "frs_overflow" "FEwrong_type_argument" "unwind" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" ) ;;/* for file macros.X */ ( "macros.X" "check_arg_failed" "not_a_symbol" "FEerror" "endp1" "FEtoo_few_argumentsF" "not_a_symbol" "FEerror" "super_funcall" "too_few_arguments" "too_many_arguments" "too_few_arguments" "too_many_arguments" "super_funcall" "enter_mark_origin" ) ;;/* for file main.X */ ( "main.X" "setbuf" "error" "clear_stack" "getrlimit" "set_maxpage" "bzero" "sigstack" "init_interrupt" "super_funcall" "multiply_stacks" "printf" "fflush" "initlisp" "init_init" "init_interrupt" "super_funcall" "sigvec" "init_alloc" "init_symbol" "init_package" "import" "export" "enter_mark_origin" "NewInit" "init_typespec" "init_pari" "init_number" "init_character" "init_file" "init_read" "init_bind" "init_pathname" "init_print" "init_GBC" "init_unixfasl" "init_unixsys" "init_unixsave" "init_alloc_function" "init_array_function" "init_character_function" "init_file_function" "init_list_function" "init_package_function" "init_pathname_function" "init_predicate_function" "init_print_function" "init_read_function" "init_sequence_function" "init_socket_function" "init_structure_function" "init_string_function" "init_symbol_function" "init_typespec_function" "init_hash" "init_cfun" "init_unixfsys" "init_unixtime" "init_eval" "init_lex" "init_prog" "init_catch" "init_block" "init_macros" "init_conditional" "init_reference" "init_assignment" "init_multival" "init_error" "init_let" "init_mapfun" "init_iteration" "init_toplevel" "init_cmpaux" "init_main" "init_format" "init_links" "init_fat_string" "init_cmac" "init_interrupt1" "error" "FEerror" "error" "FEerror" "error" "FEerror" "error" "FEerror" "error" "error" "FEerror" "error" "sgc_quit" "FEerror" "printf" "fflush" "FEerror" "too_many_arguments" "printf" "check_arg_failed" "check_arg_failed" "FEerror" "check_arg_failed" "check_type_string" "FEerror" "check_arg_failed" "check_arg_failed" "FEerror" "check_arg_failed" "enter_mark_origin" "array_allocself" "bcopy" "bcopy" "bcopy" "bcopy" "check_arg_failed" "init_system" "check_arg_failed" "check_arg_failed" "fixint" "check_arg_failed" "printf" "check_arg_failed" "check_arg_failed" "check_arg_failed" "getdomainname" "yp_unbind" "GBC" "brk" "Lsave" "enter_mark_origin" ) ;;/* for file mapfun.X */ ( "mapfun.X" "too_few_arguments" "endp1" "super_funcall" "endp1" "too_few_arguments" "endp1" "super_funcall" "endp1" "too_few_arguments" "endp1" "super_funcall" "endp1" "too_few_arguments" "endp1" "super_funcall" "endp1" "too_few_arguments" "endp1" "super_funcall" "endp1" "too_few_arguments" "endp1" "super_funcall" "endp1" ) ;;/* for file multival.X */ ( "multival.X" "check_arg_failed" "endp1" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "endp1" "FEtoo_few_argumentsF" "eval" "super_funcall" "endp1" "FEtoo_few_argumentsF" "eval" ) ;;/* for file nfunlink.X */ ( "nfunlink.X" "FEerror" "FEinvalid_function" "vpush_extend" "FEerror" "vs_overflow" "ihs_punsh_base" "ihs_overflow" "funcall" "FEerror" ) ;;/* for file num_arith.X */ ( "num_arith.X" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "number_zerop" "zero_divisor" "number_minusp" "FEwrong_type_argument" "number_zerop" "zero_divisor" "FEwrong_type_argument" "zero_divisor" "number_zerop" "FEwrong_type_argument" "number_minusp" "number_compare" "check_type_number" "too_few_arguments" "check_type_number" "check_type_number" "too_few_arguments" "check_type_number" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "check_type_integer" "number_minusp" "too_few_arguments" "check_type_integer" "number_minusp" "number_minusp" "FEerror" ) ;;/* for file num_co.X */ ( "num_co.X" "too_few_arguments" "too_many_arguments" "check_type_float" "FEwrong_type_argument" "check_arg_failed" "check_type_rational" "check_arg_failed" "check_type_rational" "too_few_arguments" "FEwrong_type_argument" "too_many_arguments" "number_zerop" "integer_quotient_remainder_1" "number_minusp" "number_plusp" "check_type_or_rational_float" "number_minusp" "number_compare" "too_few_arguments" "FEwrong_type_argument" "too_many_arguments" "number_zerop" "integer_quotient_remainder_1" "number_plusp" "number_minusp" "check_type_or_rational_float" "number_plusp" "number_compare" "too_few_arguments" "FEwrong_type_argument" "too_many_arguments" "integer_quotient_remainder_1" "check_type_or_rational_float" "too_few_arguments" "number_oddp" "FEwrong_type_argument" "too_many_arguments" "check_type_or_rational_float" "number_compare" "number_oddp" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_type_float" "check_arg_failed" "check_type_float" "FEerror" "check_arg_failed" "check_type_float" "too_few_arguments" "too_many_arguments" "check_type_float" "check_arg_failed" "check_type_float" "check_arg_failed" "check_type_float" "check_arg_failed" "check_type_float" "too_few_arguments" "too_many_arguments" "check_type_or_rational_float" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "enter_mark_origin" ) ;;/* for file num_comp.X */ ( "num_comp.X" "cmpii" "number_zerop" "FEwrong_type_argument" "too_few_arguments" "check_type_number" "too_few_arguments" "check_type_number" "too_few_arguments" "check_type_or_rational_float" "too_few_arguments" "check_type_or_rational_float" "too_few_arguments" "check_type_or_rational_float" ) ;;/* for file num_log.X */ ( "num_log.X" "too_few_arguments" "gcopy_to_big" "FEwrong_type_argument" "FEwrong_type_argument" "check_type_integer" "check_type_integer" "check_type_integer" "check_type_integer" "check_arg_failed" "check_type_integer" "fixint" "FEerror" "check_arg_failed" "check_type_integer" "check_arg_failed" "check_type_integer" "FEerror" "check_arg_failed" "check_type_integer" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "siLmake_vector" "siLmake_pure_array" "fixint" "FEerror" "FEerror" ) ;;/* for file num_pred.X */ ( "num_pred.X" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "FEwrong_type_argument" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_or_rational_float" "check_arg_failed" "check_type_or_rational_float" "check_arg_failed" "check_type_integer" "check_arg_failed" "check_type_integer" "enter_mark_origin" ) ;;/* for file num_rand.X */ ( "num_rand.X" "number_compare" "FEwrong_type_argument" "FEerror" "time" "FEwrong_type_argument" "check_arg_failed" "check_type_random_state" "check_arg_failed" "check_arg_failed" ) ;;/* for file num_sfun.X */ ( "num_sfun.X" "FEwrong_type_argument" "FEwrong_type_argument" "number_zerop" "number_plusp" "FEerror" "number_minusp" "number_plusp" "number_evenp" "number_zerop" "FEerror" "number_minusp" "FEwrong_type_argument" "number_zerop" "FEerror" "number_minusp" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEwrong_type_argument" "number_zerop" "FEerror" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "too_few_arguments" "check_type_number" "check_type_number" "too_many_arguments" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "check_arg_failed" "check_type_number" "too_few_arguments" "check_type_number" "check_type_or_rational_float" "too_many_arguments" "enter_mark_origin" ) ;;/* for file number.X */ ( "number.X" "FEerror" "FEerror" "number_zerop" "FEerror" "number_minusp" "enter_mark_origin" "init_num_pred" "init_num_comp" "init_num_arith" "init_num_co" "init_num_log" "init_num_sfun" "init_num_rand" ) ;;/* for file package.X */ ( "package.X" "string_equal" "pack_hash" "package_already" "endp1" "no_package" "endp1" "package_already" "use_package" "equal" "package_already" "endp1" "FEwrong_type_argument" "string_equal" "no_package" "FEerror" "bcmp" "bcmp" "member_eq" "member_eq" "FEerror" "delete_eq" "import" "FEerror" "member_eq" "delete_eq" "FEerror" "delete_eq" "FEerror" "member_eq" "member_eq" "delete_eq" "no_package" "FEerror" "member_eq" "no_package" "delete_eq" "too_few_arguments" "parse_key" "check_type_or_string_symbol" "too_few_arguments" "parse_key" "check_type_or_string_symbol" "check_arg_failed" "check_arg_failed" "check_type_package" "check_arg_failed" "too_few_arguments" "too_many_arguments" "check_type_or_string_symbol" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "stack_cons" "too_few_arguments" "too_many_arguments" "check_type_string" "too_few_arguments" "too_many_arguments" "check_type_string" "too_few_arguments" "too_many_arguments" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_symbol" "too_few_arguments" "too_many_arguments" "endp1" "check_type_package" "too_few_arguments" "too_many_arguments" "endp1" "check_type_package" "check_arg_failed" "check_type_package" "FEerror" "check_arg_failed" "check_type_package" "FEerror" "FEerror" "FEerror" "check_type_package" "check_arg_failed" "enter_mark_origin" ) ;;/* for file pathname.X */ ( "pathname.X" "stack_cons" "FEerror" "endp1" "FEerror" "FEerror" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "too_few_arguments" "parse_key" "check_type_or_pathname_string_symbol_stream" "get_string_start_end" "FEerror" "FEerror" "FEerror" "too_few_arguments" "too_many_arguments" "check_type_or_pathname_string_symbol_stream" "too_few_arguments" "parse_key" "check_arg_failed" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "too_few_arguments" "too_many_arguments" "check_type_or_pathname_string_symbol_stream" "equalp" ) ;;/* for file predicate.X */ ( "predicate.X" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "big_compare" "check_arg_failed" "string_eq" "check_arg_failed" "number_compare" "char_equal" "check_arg_failed" "endp1" "eval" "eval" "endp1" "eval" "eval" "check_arg_failed" "check_arg_failed" "check_arg_failed" ) ;;/* for file print.X */ ( "print.X" "flush_queue" "FEerror" "file_column" "writec_stream" "writec_stream" "file_column" "FEerror" "writec_stream" "writec_stream" "write_decimal1" "FEerror" "alarm" "terminal_interrupt" "frs_overflow" "bds_unwind" "unwind" "digit_weight" "big_zerop" "vs_overflow" "digit_weight" "div_int_big" "error" "FEerror" "potential_number_p" "fixint" "error" "FEwrong_type_argument" "error" "vs_overflow" "FEwrong_type_argument" "FEerror" "FEerror" "FEerror" "FEerror" "flush_stream" "FEwrong_type_argument" "writec_stream" "digitp" "too_few_arguments" "parse_key" "FEerror" "flush_stream" "too_few_arguments" "too_many_arguments" "too_few_arguments" "too_many_arguments" "too_few_arguments" "too_many_arguments" "check_type_stream" "writec_stream" "flush_stream" "too_few_arguments" "too_many_arguments" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_stream" "writec_stream" "too_few_arguments" "parse_key" "get_string_start_end" "check_type_string" "check_type_stream" "writec_stream" "flush_stream" "too_few_arguments" "parse_key" "get_string_start_end" "check_type_string" "check_type_stream" "writec_stream" "flush_stream" "too_few_arguments" "too_many_arguments" "too_few_arguments" "too_many_arguments" "check_type_stream" "file_column" "writec_stream" "flush_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "flush_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "flush_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "check_arg_failed" "FEerror" "check_type_stream" "writec_stream" "error" "enter_mark_origin" "FEerror" "FEerror" "flush_stream" "FEerror" "writec_stream" "flush_stream" "check_type_string" "check_type_stream" "writec_stream" "flush_stream" "check_type_stream" "writestr_stream" "check_type_stream" "writec_stream" "flush_stream" "writec_stream" "flush_stream" ) ;;/* for file prog.X */ ( "prog.X" "endp1" "lex_tag_bind" "frs_overflow" "eql" "FEerror" "eval" "endp1" "FEtoo_few_argumentsF" "lex_block_bind" "frs_overflow" "let_var_list" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "lex_block_bind" "frs_overflow" "let_var_list" "bds_unwind" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "FEerror" "unwind" "endp1" "FEtoo_few_argumentsF" "eval" "not_a_symbol" "FEerror" "Fprogn" "bds_unwind" "endp1" "eval" "endp1" "FEtoo_few_argumentsF" "eval" "endp1" "FEtoo_few_argumentsF" "eval" ) ;;/* for file read.X */ ( "read.X" "FEerror" "FEerror" "readc_stream" "FEwrong_type_argument" "unreadc_stream" "readc_stream" "readc_stream" "frs_overflow" "FEerror" "FEerror" "unwind" "frs_overflow" "unwind" "frs_overflow" "unwind" "vs_overflow" "_filbuf" "end_of_stream" "stream_at_end" "end_of_stream" "readc_stream" "super_funcall" "FEerror" "too_long_token" "_filbuf" "stream_at_end" "readc_stream" "readc_stream" "stream_at_end" "end_of_stream" "readc_stream" "FEerror" "FEerror" "FEerror" "FEerror" "check_arg_failed" "FEerror" "readc_stream" "digitp" "mul_int_big" "add_int_big" "FEerror" "mul_int_big" "add_int_big" "digitp" "mul_int_big" "add_int_big" "readc_stream" "too_long_string" "_filbuf" "stream_at_end" "readc_stream" "check_arg_failed" "check_arg_failed" "FEerror" "readc_stream" "digitp" "super_funcall" "check_arg_failed" "stack_cons" "check_arg_failed" "check_arg_failed" "_filbuf" "stream_at_end" "readc_stream" "check_arg_failed" "extra_argument" "readc_stream" "FEerror" "contains_sharp_comma" "check_type_number" "check_arg_failed" "FEerror" "string_equal" "check_arg_failed" "extra_argument" "stack_cons" "check_arg_failed" "unreadc_stream" "backq_car" "FEerror" "endp1" "vs_overflow" "stack_cons" "vs_overflow" "FEerror" "check_arg_failed" "stream_at_end" "readc_stream" "vs_overflow" "FEerror" "error" "extra_argument" "readc_stream" "too_long_token" "stream_at_end" "end_of_stream" "check_arg_failed" "extra_argument" "check_arg_failed" "extra_argument" "check_arg_failed" "extra_argument" "check_arg_failed" "extra_argument" "extra_argument" "FEerror" "extra_argument" "FEerror" "extra_argument" "FEerror" "check_arg_failed" "FEerror" "FEerror" "check_arg_failed" "FEerror" "eql" "check_arg_failed" "FEerror" "eql" "check_arg_failed" "extra_argument" "readc_stream" "FEerror" "check_arg_failed" "extra_argument" "check_arg_failed" "extra_argument" "FEerror" "FEerror" "too_few_arguments" "too_many_arguments" "check_type_stream" "end_of_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "stream_at_end" "readc_stream" "end_of_stream" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_stream" "frs_overflow" "unwind" "too_few_arguments" "too_many_arguments" "check_type_stream" "stream_at_end" "end_of_stream" "_filbuf" "readc_stream" "too_long_string" "too_few_arguments" "too_many_arguments" "check_type_stream" "stream_at_end" "end_of_stream" "readc_stream" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "stream_at_end" "end_of_stream" "readc_stream" "stream_at_end" "readc_stream" "end_of_stream" "check_type_character" "stream_at_end" "readc_stream" "char_eq" "end_of_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "listen_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "listen_stream" "readc_stream" "too_few_arguments" "too_many_arguments" "check_type_stream" "listen_stream" "readc_stream" "too_few_arguments" "parse_key" "check_type_string" "get_string_start_end" "FEerror" "too_few_arguments" "too_many_arguments" "check_type_stream" "stream_at_end" "end_of_stream" "readc_stream" "stream_at_end" "readc_stream" "stream_at_end" "readc_stream" "too_few_arguments" "too_many_arguments" "check_type_readtable" "check_type_readtable" "check_arg_failed" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "FEerror" "too_few_arguments" "too_many_arguments" "check_type_character" "check_type_readtable" "FEerror" "digitp" "check_arg_failed" "check_type_string" "check_arg_failed" "FEerror" "enter_mark_origin" "init_backq" "frs_overflow" "readc_stream" "vs_overflow" "system_error" "unwind" ) ;;/* for file reference.X */ ( "reference.X" "check_arg_failed" "not_a_symbol" "FEinvalid_function" "FEundefined_function" "check_arg_failed" "not_a_symbol" "stack_cons" "FEundefined_function" "stack_cons" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "FEundefined_function" "FEinvalid_function" "check_arg_failed" "not_a_symbol" "FEunbound_variable" "check_arg_failed" "not_a_symbol" "check_arg_failed" "not_a_symbol" "check_arg_failed" "not_a_symbol" ) ;;/* for file run_process.X */ ( "run_process.X" "malloc" "FEerror" "bzero" "bcopy" "socket" "FEerror" "connect" "close" "FEerror" "getpid" "ioctl" "FEerror" "FEerror" "setup_stream_buffer" "check_arg_failed" "socketpair" "FEerror" "setup_stream_buffer" "FEerror" "fork" "close" "dup" "fprintf" "execvp" "fflush" "object_to_string" ) ;;/* for file sequence.X */ ( "sequence.X" "check_arg_failed" "fixint" "FEerror" "FEwrong_type_argument" "FEerror" "FEerror" "check_arg_failed" "fixint" "FEerror" "FEwrong_type_argument" "FEerror" "FEerror" "too_few_arguments" "too_many_arguments" "fixnnint" "FEwrong_type_argument" "vs_overflow" "stack_cons" "array_allocself" "FEerror" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "check_arg_failed" "FEwrong_type_argument" "array_allocself" "check_arg_failed" "FEwrong_type_argument" ) ;;/* for file sfasl.X */ ( "sfasl.X" "printf" "fflush" "printf" "fflush" "coerce_to_filename" "fread" "FEerror" "fseek" "_filbuf" "ungetc" "build_symbol_table" "get_extra_bss" "relocate_symbols" "close_stream" "free" "call_init" "printf" "fwrite" "fclose" "set_symbol_address" "fprintf" "fflush" "FEerror" "printf" "fflush" "getpid" "coerce_to_filename" "system" "FEerror" "read_special_symbols" "unlink" "qsort" ) ;;/* for file string.X */ ( "string.X" "FEerror" "check_arg_failed" "check_type_string" "illegal_index" "check_arg_failed" "check_type_string" "illegal_index" "check_type_character" "FEerror" "too_few_arguments" "parse_key" "too_few_arguments" "parse_key" "too_few_arguments" "parse_key" "too_few_arguments" "parse_key" "too_few_arguments" "parse_key" "endp1" "FEerror" "Lstring_trim0" "Lstring_trim0" "Lstring_trim0" "check_arg_failed" "too_few_arguments" "parse_key" "too_few_arguments" "parse_key" "check_type_string" "check_arg_failed" ) ;;/* for file structure.X */ ( "structure.X" "FEerror" "FEerror" "FEwrong_type_argument" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "FEerror" "check_arg_failed" "endp1" "stack_cons" "too_few_arguments" "FEerror" "bzero" "too_few_arguments" "FEwrong_type_argument" "bcopy" "check_arg_failed" "FEwrong_type_argument" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "FEerror" "endp1" "check_arg_failed" "FEerror" "endp1" "check_arg_failed" "check_arg_failed" "FEwrong_type_argument" "get_aelttype" "get_aelttype" ) ;;/* for file symbol.X */ ( "symbol.X" "pack_hash" "string_eq" "pack_hash" "string_eq" "error" "pack_hash" "string_eq" "FEunbound_variable" "FEerror" "not_a_symbol" "FEerror" "not_a_symbol" "not_a_symbol" "endp1" "odd_plist" "not_a_symbol" "too_few_arguments" "too_many_arguments" "check_type_symbol" "check_arg_failed" "check_type_symbol" "check_arg_failed" "check_type_symbol" "too_few_arguments" "too_many_arguments" "check_arg_failed" "endp1" "odd_plist" "FEerror" "check_arg_failed" "check_arg_failed" "check_type_string" "too_few_arguments" "too_many_arguments" "check_type_symbol" "too_few_arguments" "too_many_arguments" "check_type_non_negative_integer" "too_few_arguments" "too_many_arguments" "check_type_string" "check_type_package" "check_arg_failed" "check_type_symbol" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_arg_failed" "check_type_symbol" "check_arg_failed" "check_type_symbol" "FEerror" "enter_mark_origin" "enter_mark_origin" ) ;;/* for file toplevel.X */ ( "toplevel.X" "endp1" "FEtoo_few_argumentsF" "FEerror" "not_a_symbol" "check_arg_failed" "check_type_symbol" "FEerror" "check_arg_failed" "check_type_symbol" "FEerror" "endp1" "FEtoo_few_argumentsF" "FEinvalid_form" "eval" "FEerror" "Fprogn" "endp1" "FEtoo_few_argumentsF" "FEtoo_many_argumentsF" "eval" "FEerror" "FEwrong_type_argument" "FEerror" "FEwrong_type_argument" "enter_mark_origin" ) ;;/* for file typespec.X */ ( "typespec.X" "FEerror" "check_arg_failed" "error" "enter_mark_origin" ) ;;/* for file unixfasl.X */ ( "unixfasl.X" "coerce_to_filename" "getpid" "system" "FEerror" "setbuf" "fread" "fclose" "fseek" "close_stream" "printf" "error" "unlink" "call_init" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_type_string" "bds_unwind" ) ;;/* for file unixfsys.X */ ( "unixfsys.X" "bcopy" "getuid" "FEerror" "FEerror" "bcopy" "chdir" "FEerror" "chdir" "strcat" "system" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_type_or_Pathname_string_symbol" "rename" "FEerror" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "unlink" "FEerror" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "too_many_arguments" "getuid" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "strcat" "strcat" "setbuf" "_filbuf" "pclose" "stack_cons" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "chdir" "FEerror" ) ;;/* for file unixint.X */ ( "unixint.X" "terminal_interrupt" "fprintf" "fflush" "gcl_signal" "gcl_signal" "gcl_signal" "alarm" "gcl_signal" "FEerror" "error" "FEerror" "check_arg_failed" "gcl_signal" "check_arg_failed" "gcl_signal" "gcl_signal" ) ;;/* for file unixsave.X */ ( "unixsave.X" "fread" "fwrite" "fread" "fwrite" "fprintf" "setbuf" "fclose" "unlink" "fprintf" "fread" "fwrite" "fseek" "check_arg_failed" "check_type_or_pathname_string_symbol_stream" "coerce_to_filename" "_cleanup" ) ;;/* for file unixsys.X */ ( "unixsys.X" "check_arg_failed" "check_type_string" "FEerror" "system" ) ;;/* for file unixtime.X */ ( "unixtime.X" "check_arg_failed" "time" "check_arg_failed" "check_type_or_rational_float" "number_minusp" "FEerror" "Lround" "sleep" "check_arg_failed" "check_arg_failed" "gettimeofday" "ftime" ) ;;/* for file user_init.X */ ( "user_init.X" ) )) gcl-2.6.14/o/faslsgi4.c0000755000175000017500000002471614360276512013126 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* make sure we do allocate aligned for double */ /* actually I understand that ld -A wants alignment on the page. ie multiple of 0x1000 */ #define ALIGN 12 char * alloc_contblock_aligned(size) int size; { char *tmp_alloc = ALLOC_ALIGNED(alloc_contblock,size,(1<<12)); bzero(tmp_alloc, size); return(tmp_alloc); } #define alloc_contblock alloc_contblock_aligned #ifdef BSD #include #endif #ifdef ATT #ifdef mips #include #include #endif #include #include #include #endif #define MAXPATHLEN 1024 #ifdef HAVE_ELF #include #endif int fasload(faslfile) object faslfile; { #ifdef BSD struct exec header, newheader; #define textsize header.a_text #define datasize header.a_data #define bsssize header.a_bss #define textstart sizeof(header) #define newbsssize newheader.a_bss #endif #ifdef ATT struct filehdr fileheader; struct scnhdr sectionheader; #ifdef mips struct aouthdr aouthdr, newaouthdr; HDRR symhdr; # define textsize aouthdr.tsize # define datasize aouthdr.dsize # define bsssize aouthdr.bsize # define textstart sectionheader.s_scnptr # define newdatasize newaouthdr.dsize # define newbsssize newaouthdr.bsize #else int textsize, datasize, bsssize; int textstart; #endif /* mips */ #endif #ifdef E15 struct exec header; #define textsize header.a_text #define datasize header.a_data #define bsssize header.a_bss #define textstart sizeof(header) #endif object memory, data, tempfile; FILE *fp; char filename[MAXPATHLEN]; char tempfilename[32]; char command[MAXPATHLEN * 2]; int i; object *old_vs_base = vs_base; object *old_vs_top = vs_top; #ifdef IBMRT #endif coerce_to_filename(faslfile, filename); faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); vs_push(faslfile); fp = faslfile->sm.sm_fp; #ifdef BSD fread(&header, sizeof(header), 1, fp); #endif #ifdef ATT fread(&fileheader, sizeof(fileheader), 1, fp); #ifdef mips fread(&aouthdr, AOUTHSZ, 1, fp); #else #ifdef S3000 if(fileheader.f_opthdr != 0) fseek(fp,fileheader.f_opthdr,1); #endif fread(§ionheader, sizeof(sectionheader), 1, fp); textsize = sectionheader.s_size; textstart = sectionheader.s_scnptr; fread(§ionheader, sizeof(sectionheader), 1, fp); datasize = sectionheader.s_size; fread(§ionheader, sizeof(sectionheader), 1, fp); if (strcmp(sectionheader.s_name, ".bss") == 0) bsssize = sectionheader.s_size; else bsssize = 0; #endif /* mips */ #endif #ifdef E15 fread(&header, sizeof(header), 1, fp); #endif memory = alloc_object(t_cfdata); memory->cfd.cfd_self = NULL; memory->cfd.cfd_start = NULL; memory->cfd.cfd_size = textsize + datasize + bsssize; #ifdef mips #define MIPS_ROUND 0xC memory->cfd.cfd_size += MIPS_ROUND; /* room for 'ld' to round text upward */ #endif vs_push(memory); memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); #ifdef BSD fseek(fp, header.a_text+header.a_data+ header.a_syms+header.a_trsize+header.a_drsize, 1); fread(&i, sizeof(i), 1, fp); fseek(fp, i - sizeof(i), 1); #endif #ifdef SYSTYPE_SVR4 SEEK_TO_END_OFILE(fp); #else #ifdef ATT #ifdef mips fseek(fp, fileheader.f_symptr, SEEK_SET); fread(&symhdr, cbHDRR, 1, fp); fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, SEEK_SET); #else fseek(fp, fileheader.f_symptr + SYMESZ*fileheader.f_nsyms, 0); fread(&i, sizeof(i), 1, fp); fseek(fp, i - sizeof(i), 1); while ((i = getc(fp)) == 0) ; ungetc(i, fp); #endif /* mips */ #endif #endif data = read_fasl_vector(faslfile); vs_push(data); close_stream(faslfile); sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); AGAIN: #ifdef BSD sprintf(command, "ld -d -N -x -A %s -T %x %s -o %s", kcl_self, memory->cfd.cfd_start, filename, tempfilename); #endif #ifdef ATT #ifdef mips sprintf(command, "ld -s -A %s -N -T %x %s -o %s", kcl_self, (long)memory->cfd.cfd_start+SCNROUND-1&~(SCNROUND-1), filename, tempfilename); #else coerce_to_filename(symbol_value(sSAsystem_directoryA), system_directory); sprintf(command, "%sild %s %d %s %s", system_directory, kcl_self, memory->cfd.cfd_start, filename, tempfilename); #endif /* mips */ #endif #ifdef E15 coerce_to_filename(symbol_value(sSAsystem_directoryA), system_directory); sprintf(command, "%sild %s %d %s %s", system_directory, kcl_self, memory->cfd.cfd_start, filename, tempfilename); #endif if (system(command) != 0) FEerror("The linkage editor failed.", 0); tempfile = make_simple_string(tempfilename); vs_push(tempfile); tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); vs_push(tempfile); fp = tempfile->sm.sm_fp; #ifdef BSD fread(&newheader, sizeof(header), 1, fp); if (newbsssize != bsssize) { insert_contblock(memory->cfd.cfd_start, memory->cfd.cfd_size); bsssize = newbsssize; memory->cfd.cfd_start = NULL; memory->cfd.cfd_size = textsize + datasize + bsssize; memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); close_stream(tempfile, TRUE); unlink(tempfilename); goto AGAIN; } #endif #ifdef mips fseek(fp, FILHSZ, SEEK_CUR); fread(&newaouthdr, AOUTHSZ, 1, fp); if (newdatasize + newbsssize > datasize + bsssize) { insert_contblock(memory->cfd.cfd_start, memory->cfd.cfd_size); datasize = newdatasize; bsssize = newbsssize; memory->cfd.cfd_start = NULL; memory->cfd.cfd_size = textsize + datasize + bsssize + MIPS_ROUND; memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); close_stream(tempfile); unlink(tempfilename); goto AGAIN; } fread(§ionheader, sizeof sectionheader, 1, fp); #endif if (fseek(fp, textstart, 0) < 0) error("file seek error"); #ifdef mips printf("start address -T %x ",memory->cfd.cfd_start); bzero(memory->cfd.cfd_start, MIPS_ROUND); fread((void *)sectionheader.s_vaddr, textsize + datasize, 1, fp); #else fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); #endif close_stream(tempfile); unlink(tempfilename); call_init(0,memory,data,0); vs_base = old_vs_base; vs_top = old_vs_top; return(memory->cfd.cfd_size); } #if defined BSD || defined mips int faslink(faslfile, ldargstring) object faslfile, ldargstring; { #ifdef mips struct filehdr faslheader; struct aouthdr aouthdr; struct scnhdr sectionheader; HDRR symhdr; #define ldcmdfmt "ld -s -A %s -N -T %x %s %s -o %s" #else struct exec header, faslheader; #define textsize header.a_text #define datasize header.a_data #define bsssize header.a_bss #define textstart sizeof(header) #define ldcmdfmt "ld -d -N -x -A %s -T %x %s %s -o %s" #endif object memory, data, tempfile; FILE *fp; char filename[MAXPATHLEN]; char ldargstr[MAXPATHLEN]; char tempfilename[32]; char command[MAXPATHLEN * 2]; char buf[BUFSIZ]; int i; object *old_vs_base = vs_base; object *old_vs_top = vs_top; #ifdef IBMRT #endif coerce_to_filename(ldargstring, ldargstr); coerce_to_filename(faslfile, filename); sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); sprintf(command, ldcmdfmt, kcl_self, (int)core_end, filename, ldargstr, tempfilename); if (system(command) != 0) FEerror("The linkage editor failed.", 0); fp = fopen(tempfilename, "r"); setbuf(fp, buf); #ifdef mips fseek(fp, FILHSZ, SEEK_CUR); fread(&aouthdr, AOUTHSZ, 1, fp); #else fread(&header, sizeof(header), 1, fp); #endif memory = alloc_object(t_cfdata); memory->cfd.cfd_self = NULL; memory->cfd.cfd_start = NULL; memory->cfd.cfd_size = textsize + datasize + bsssize; #ifdef mips memory->cfd.cfd_size += MIPS_ROUND; #endif vs_push(memory); memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); fclose(fp); faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); vs_push(faslfile); fp = faslfile->sm.sm_fp; fread(&faslheader, sizeof(faslheader), 1, fp); #ifdef mips fseek(fp, AOUTHSZ, SEEK_CUR); fread(§ionheader, SCNHSZ, 1, fp); fseek(fp, faslheader.f_symptr, SEEK_SET); fread(&symhdr, cbHDRR, 1, fp); fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, SEEK_SET); #else fseek(fp, faslheader.a_text+faslheader.a_data+ faslheader.a_syms+faslheader.a_trsize+faslheader.a_drsize, 1); fread(&i, sizeof(i), 1, fp); fseek(fp, i - sizeof(i), 1); #endif data = read_fasl_vector(faslfile); vs_push(data); close_stream(faslfile); sprintf(command, ldcmdfmt, kcl_self, #ifdef mips (long)memory->cfd.cfd_start+SCNROUND-1&~(SCNROUND-1), #else memory->cfd.cfd_start, #endif filename, ldargstr, tempfilename); if (system(command) != 0) FEerror("The linkage editor failed.", 0); tempfile = make_simple_string(tempfilename); vs_push(tempfile); tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); vs_push(tempfile); fp = tempfile->sm.sm_fp; #ifdef mips fseek(fp, FILHSZ, SEEK_CUR); fread(&aouthdr, AOUTHSZ, 1, fp); fread(§ionheader, sizeof sectionheader, 1, fp); #endif if (fseek(fp, textstart, 0) < 0) error("file seek error"); #ifdef mips printf("start address -T %x ",memory->cfd.cfd_start); bzero(memory->cfd.cfd_start, MIPS_ROUND); fread((void *)sectionheader.s_vaddr, textsize + datasize, 1, fp); #else fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); #endif close_stream(tempfile); unlink(tempfilename); call_init(0,memory,data,0); vs_base = old_vs_base; vs_top = old_vs_top; return(memory->cfd.cfd_size); } siLfaslink() { bds_ptr old_bds_top; int i; object package; check_arg(2); check_type_or_pathname_string_symbol_stream(&vs_base[0]); check_type_string(&vs_base[1]); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_base[0]->pn.pn_type = FASL_string; vs_base[0] = namestring(vs_base[0]); package = symbol_value(sLApackageA); old_bds_top = bds_top; bds_bind(sLApackageA, package); i = faslink(vs_base[0], vs_base[1]); bds_unwind(old_bds_top); vs_top = vs_base; vs_push(make_fixnum(i)); } #endif #define FASLINK gcl-2.6.14/o/gdb_commands0000755000175000017500000000114514360276512013575 0ustar cammcamm# $ma break in main_signal_handler # $ra break in raise_pending_signals command $ma silent echo (main_..)signo= output signo echo allowed= output (enum signals_allowed_values) allowed echo , seePending echo ,\n called in: fr 2 continue end define seePending echo signals_pending= output (unsigned long)signals_pending echo [ output /t signals_pending echo ] end command $ra silent echo (raise..)signo= output *p echo ,allowed= output (enum signals_allowed_values) cond seePending echo ,\n called in: fr 1 continue end command $in silent echo for invoke... frame 1 frame 2 frame 3 echo ...done\n continue end gcl-2.6.14/o/bsearch.c0000755000175000017500000000124214360276512013006 0ustar cammcamm#include void * bsearch(const void *key, const void *base, size_t nel, size_t keysize, int (*compar)(const void *, const void *)) { char *beg=base; char *end=base+keysize*(nel-1); char *mid; int cmp,tem; if (nel==0) return 0; cmp=(*compar)(beg,key); if (cmp==0) return beg; if (cmp> 0) return 0; cmp= (*compar)(key,end); if (cmp==0) return end; if (cmp> 0)return 0; /* key is in range from here on */ start: if (nel<=2) return 0; tem=nel; nel=nel/2; mid=beg+(nel)*keysize; cmp= (*compar)(key,mid); if (cmp==0) return mid; if (cmp< 0) {end=mid; nel++; goto start;; } beg=mid; nel=tem-(nel); goto start; } gcl-2.6.14/o/mingwin.c0000755000175000017500000006030414360276512013053 0ustar cammcamm#include "include.h" #include "winsock2.h" #include "windows.h" #include "errno.h" #include "signal.h" #include "stdlib.h" #ifdef DODEBUG #define dprintf(s,arg) emsg(s,arg) #else #define dprintf(s,arg) #endif #ifndef EWOULDBLOCK #define EWOULDBLOCK EAGAIN #endif #include "errno.h" #include #include #include #include #define Tcl_GetErrno() errno #define Tcl_SetErrno(n) errno=n /* * The following structure contains pointers to all of the WinSock API entry * points used by Tcl. It is initialized by InitSockets. Since we * dynamically load Winsock.dll on demand, we must use this function table * to refer to functions in the socket API. */ static struct { HINSTANCE hInstance; /* Handle to WinSock library. */ SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr, int FAR *addrlen); int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr, int namelen); int (PASCAL FAR *closesocket)(SOCKET s); int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name, int namelen); int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp); int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname, char FAR * optval, int FAR *optlen); u_short (PASCAL FAR *htons)(u_short hostshort); unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp); char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in); int (PASCAL FAR *listen)(SOCKET s, int backlog); u_short (PASCAL FAR *ntohs)(u_short netshort); int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags); int (PASCAL FAR *select)(int nfds, fd_set FAR * readfds, fd_set FAR * writefds, fd_set FAR * exceptfds, const struct timeval FAR * tiemout); int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags); int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname, const char FAR * optval, int optlen); int (PASCAL FAR *shutdown)(SOCKET s, int how); SOCKET (PASCAL FAR *socket)(int af, int type, int protocol); struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name); struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr, int addrlen, int addrtype); int (PASCAL FAR *gethostname)(char FAR * name, int namelen); int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen); struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name, const char FAR * proto); int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen); int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData); int (PASCAL FAR *WSACleanup)(void); int (PASCAL FAR *WSAGetLastError)(void); int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg, long lEvent); } winSock; static int SocketsEnabled(); static void close_winsock(); extern void doReverse ( char *s, int n ); /* *---------------------------------------------------------------------- * * InitSockets -- * * Initialize the socket module. Attempts to load the wsock32.dll * library and set up the winSock function table. If successful, * registers the event window for the socket notifier code. * * Assumes Mutex is held. * * Results: * None. * * Side effects: * Dynamically loads wsock32.dll, and registers a new window * class and creates a window for use in asynchronous socket * notification. * *---------------------------------------------------------------------- */ static void InitSockets() { WSADATA wsaData; static int initialized; if (! initialized) { initialized = 1; winSock.hInstance = LoadLibraryA("wsock32.dll"); /* * Initialize the function table. */ if (!SocketsEnabled()) { return; } winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s, struct sockaddr FAR *addr, int FAR *addrlen)) GetProcAddress(winSock.hInstance, "accept"); winSock.bind = (int (PASCAL FAR *)(SOCKET s, const struct sockaddr FAR *addr, int namelen)) GetProcAddress(winSock.hInstance, "bind"); winSock.closesocket = (int (PASCAL FAR *)(SOCKET s)) GetProcAddress(winSock.hInstance, "closesocket"); winSock.connect = (int (PASCAL FAR *)(SOCKET s, const struct sockaddr FAR *name, int namelen)) GetProcAddress(winSock.hInstance, "connect"); winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd, u_long FAR *argp)) GetProcAddress(winSock.hInstance, "ioctlsocket"); winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s, int level, int optname, char FAR * optval, int FAR *optlen)) GetProcAddress(winSock.hInstance, "getsockopt"); winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort)) GetProcAddress(winSock.hInstance, "htons"); winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp)) GetProcAddress(winSock.hInstance, "inet_addr"); winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in)) GetProcAddress(winSock.hInstance, "inet_ntoa"); winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog)) GetProcAddress(winSock.hInstance, "listen"); winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort)) GetProcAddress(winSock.hInstance, "ntohs"); winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf, int len, int flags)) GetProcAddress(winSock.hInstance, "recv"); winSock.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds, fd_set FAR * writefds, fd_set FAR * exceptfds, const struct timeval FAR * tiemout)) GetProcAddress(winSock.hInstance, "select"); winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf, int len, int flags)) GetProcAddress(winSock.hInstance, "send"); winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level, int optname, const char FAR * optval, int optlen)) GetProcAddress(winSock.hInstance, "setsockopt"); winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how)) GetProcAddress(winSock.hInstance, "shutdown"); winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type, int protocol)) GetProcAddress(winSock.hInstance, "socket"); winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *) (const char FAR *addr, int addrlen, int addrtype)) GetProcAddress(winSock.hInstance, "gethostbyaddr"); winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *) (const char FAR *name)) GetProcAddress(winSock.hInstance, "gethostbyname"); winSock.gethostname = (int (PASCAL FAR *)(char FAR * name, int namelen)) GetProcAddress(winSock.hInstance, "gethostname"); winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen)) GetProcAddress(winSock.hInstance, "getpeername"); winSock.getservbyname = (struct servent FAR * (PASCAL FAR *) (const char FAR * name, const char FAR * proto)) GetProcAddress(winSock.hInstance, "getservbyname"); winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock, struct sockaddr FAR *name, int FAR *namelen)) GetProcAddress(winSock.hInstance, "getsockname"); winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired, LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup"); winSock.WSACleanup = (int (PASCAL FAR *)(void)) GetProcAddress(winSock.hInstance, "WSACleanup"); winSock.WSAGetLastError = (int (PASCAL FAR *)(void)) GetProcAddress(winSock.hInstance, "WSAGetLastError"); winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd, u_int wMsg, long lEvent)) GetProcAddress(winSock.hInstance, "WSAAsyncSelect"); /* * Now check that all fields are properly initialized. If not, return * zero to indicate that we failed to initialize properly. */ if ((winSock.hInstance == NULL) || (winSock.accept == NULL) || (winSock.bind == NULL) || (winSock.closesocket == NULL) || (winSock.connect == NULL) || (winSock.ioctlsocket == NULL) || (winSock.getsockopt == NULL) || (winSock.htons == NULL) || (winSock.inet_addr == NULL) || (winSock.inet_ntoa == NULL) || (winSock.listen == NULL) || (winSock.ntohs == NULL) || (winSock.recv == NULL) || (winSock.select == NULL) || (winSock.send == NULL) || (winSock.setsockopt == NULL) || (winSock.socket == NULL) || (winSock.gethostbyname == NULL) || (winSock.gethostbyaddr == NULL) || (winSock.gethostname == NULL) || (winSock.getpeername == NULL) || (winSock.getservbyname == NULL) || (winSock.getsockname == NULL) || (winSock.WSAStartup == NULL) || (winSock.WSACleanup == NULL) || (winSock.WSAGetLastError == NULL) || (winSock.WSAAsyncSelect == NULL)) { goto unloadLibrary; } /* * Initialize the winsock library and check the version number. */ if ((*winSock.WSAStartup)(MAKEWORD(2,2), &wsaData) != 0) { emsg("unloading"); goto unloadLibrary; } #ifdef WSA_VERSION_REQD if (wsaData.wVersion != WSA_VERSION_REQD) { (*winSock.WSACleanup)(); goto unloadLibrary; } #endif } atexit(close_winsock); return; /* * Check for per-thread initialization. */ unloadLibrary: FreeLibrary(winSock.hInstance); winSock.hInstance = NULL; return; } /* *---------------------------------------------------------------------- * * SocketsEnabled -- * * Check that the WinSock DLL is loaded and ready. * * Results: * 1 if it is. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int SocketsEnabled() { int enabled; enabled = (winSock.hInstance != NULL); if (!enabled) { InitSockets(); enabled = (winSock.hInstance != NULL); } return enabled; } static void close_winsock() { if (winSock.hInstance != NULL) (*winSock.WSACleanup)(); } /* *---------------------------------------------------------------------- * * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: * 1 if the host was valid, 0 if the host could not be converted to * an IP address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ static int CreateSocketAddress(sockaddrPtr, host, port) struct sockaddr_in *sockaddrPtr; /* Socket address */ char *host; /* Host. NULL implies INADDR_ANY */ int port; /* Port number */ { struct hostent *hostent; /* Host database entry */ struct in_addr addr; /* For 64/32 bit madness */ /* * Check that WinSock is initialized; do not call it if not, to * prevent system crashes. This can happen at exit time if the exit * handler for WinSock ran before other exit handlers that want to * use sockets. */ if (!SocketsEnabled()) { Tcl_SetErrno(EFAULT); return 0; } (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); sockaddrPtr->sin_family = AF_INET; sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF)); if (host == NULL) { addr.s_addr = INADDR_ANY; } else { addr.s_addr = (*winSock.inet_addr)(host); if (addr.s_addr == INADDR_NONE) { hostent = (*winSock.gethostbyname)(host); if (hostent != NULL) { memcpy((char *) &addr, (char *) hostent->h_addr_list[0], (size_t) hostent->h_length); } else { #ifdef EHOSTUNREACH Tcl_SetErrno(EHOSTUNREACH); #else #ifdef ENXIO Tcl_SetErrno(ENXIO); #endif #endif return 0; /* Error. */ } } } /* * NOTE: On 64 bit machines the assignment below is rumored to not * do the right thing. Please report errors related to this if you * observe incorrect behavior on 64 bit machines such as DEC Alphas. * Should we modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ } #ifdef DEBUG static void myerr(char *s,int d) { if (0) emsg(s,d); } #else #define myerr(a,b) #endif /* *---------------------------------------------------------------------- * * CreateSocket -- * * This function opens a new socket and initializes the * return -1 on failure, or else an fd * *---------------------------------------------------------------------- */ static int myerror; int CreateSocket(port, host, server, myaddr, myport, async) int port; /* Port number to open. */ char *host; /* Name of host on which to open port. */ int server; /* 1 if socket should be a server socket, * else 0 for a client socket. */ char *myaddr; /* Optional client-side address */ int myport; /* Optional client-side port */ int async; /* If nonzero, connect client socket * asynchronously. */ { u_long flag = 1; /* Indicates nonblocking mode. */ int asyncConnect = 0; /* Will be 1 if async connect is * in progress. */ struct sockaddr_in sockaddr; /* Socket address */ struct sockaddr_in mysockaddr; /* Socket address for client */ SOCKET sock = 0; /* * Check that WinSock is initialized; do not call it if not, to * prevent system crashes. This can happen at exit time if the exit * handler for WinSock ran before other exit handlers that want to * use sockets. */ if (!SocketsEnabled()) { return -1; } if (! CreateSocketAddress(&sockaddr, host, port)) { goto error; } if ((myaddr != NULL || myport != 0) && ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { goto error; } sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0); if (sock == INVALID_SOCKET) { goto error; } /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 ); /* * Set kernel space buffering */ /* TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); */ if (server) { /* * Bind to the specified port. Note that we must not call setsockopt * with SO_REUSEADDR because Microsoft allows addresses to be reused * even if they are still in use. * * Bind should not be affected by the socket having already been * set into nonblocking mode. If there is trouble, this is one place * to look for bugs. */ if ((*winSock.bind)(sock, (struct sockaddr *) &sockaddr, sizeof(sockaddr)) == SOCKET_ERROR) { goto error; } /* * Set the maximum number of pending connect requests to the * max value allowed on each platform (Win32 and Win32s may be * different, and there may be differences between TCP/IP stacks). */ if ((*winSock.listen)(sock, SOMAXCONN) == SOCKET_ERROR) { goto error; } } else { /* * Try to bind to a local port, if specified. */ if (myaddr != NULL || myport != 0) { if ((*winSock.bind)(sock, (struct sockaddr *) &mysockaddr, sizeof(struct sockaddr)) == SOCKET_ERROR) { goto error; } } /* * Set the socket into nonblocking mode if the connect should be * done in the background. */ if (async) { if ((*winSock.ioctlsocket)(sock, FIONBIO, &flag) == SOCKET_ERROR) { goto error; } } /* * Attempt to connect to the remote socket. */ if ((*winSock.connect)(sock, (struct sockaddr *) &sockaddr, sizeof(sockaddr)) == SOCKET_ERROR) { myerror = (*winSock.WSAGetLastError)(); if (myerror != WSAEWOULDBLOCK) { goto error; } } /* * The connection is progressing in the background. */ asyncConnect = 1; } /* * Set up the select mask for read/write events. If the connect * attempt has not completed, include connect events. */ /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ (*winSock.ioctlsocket)(sock, FIONBIO, &flag); /* SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); */ return sock; error: /* TclWinConvertWSAError((*winSock.WSAGetLastError)()); if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), (char *) NULL); } */ if (sock != INVALID_SOCKET) { (*winSock.closesocket)(sock); } return -1; } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * * This procedure is called by the generic IO level to write data * to a socket based channel. * * Results: * The number of bytes written or -1 on failure. * * Side effects: * Produces output on the socket. * *---------------------------------------------------------------------- */ int TcpOutputProc ( int fd, char *buf, int toWrite, int *errorCodePtr, int block ) { int bytesWritten=0; int error; int count=1000*30; *errorCodePtr = 0; /* * Check that WinSock is initialized; do not call it if not, to * prevent system crashes. This can happen at exit time if the exit * handler for WinSock ran before other exit handlers that want to * use sockets. */ if (!SocketsEnabled()) { *errorCodePtr = EFAULT; return -1; } while (block) { AGAIN: /* * In the blocking case, wait until the file becomes writable * or closed and try again. */ { fd_set writefds; int res; struct timeval timeout; FD_ZERO(&writefds); FD_SET(fd,&writefds); timeout.tv_sec = (block == 0 ? 0 : 60*60*24*30); timeout.tv_usec = 0; if (!(res=(*winSock.select)(fd+1,NULL,&writefds,NULL,&timeout)) ) { bytesWritten = -1; break; } } bytesWritten = (*winSock.send)(fd, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* * Since Windows won't generate a new write event until we hit * an overflow condition, we need to force the event loop to * poll until the condition changes. */ break; } /* * Check for error condition or overflow. In the event of overflow, we * need to clear the FD_WRITE flag so we can detect the next writable * event. Note that Windows only sends a new writable event after a * send fails with WSAEWOULDBLOCK. */ error = (*winSock.WSAGetLastError)(); if (error == WSAEWOULDBLOCK) { *errorCodePtr = EWOULDBLOCK; CHECK_INTERRUPT; Sleep(30); bytesWritten = -1; if (--count < 0) break; else goto AGAIN; } else { /* TclWinConvertWSAError(error); */ *errorCodePtr = EINVAL; bytesWritten = -1; break; } } return bytesWritten; } /* getCharGclSocket(strm,block) -- get one character from a socket stream. Results: a character or EOF if at end of file Side Effects: The buffer may be filled, and the fill pointer of the buffer may be changed. */ int getCharGclSocket(strm,block) object strm; object block; { object bufp = SOCKET_STREAM_BUFFER(strm); if (!SocketsEnabled()) { return -1; } if (bufp->ust.ust_fillp > 0) { dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; } else { fd_set readfds; struct timeval timeout; int fd = SOCKET_STREAM_FD(strm); if (1) { int high; AGAIN: /* under cygwin a too large timout like (1<<30) does not work */ timeout.tv_sec = (block != Ct ? 0 : 0); timeout.tv_usec = (block != Ct ? 0 : 10000); FD_ZERO(&readfds); FD_SET(fd,&readfds); high = (*winSock.select)(fd+1,&readfds,NULL,NULL,&timeout); if (high > 0) { object bufp = SOCKET_STREAM_BUFFER(strm); int n; n = (*winSock.recv)(fd,bufp->st.st_self ,bufp->ust.ust_dim,0); doReverse(bufp->st.st_self,n); bufp->ust.ust_fillp=n; if (n > 0) { return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; } else { return EOF; FEerror("select said there was stuff there but there was not",0); } } CHECK_INTERRUPT; /* probably a signal interrupted us.. */ if (block == Ct) goto AGAIN; return EOF; } } } void tcpCloseSocket(SOCKET fd) { (*winSock.closesocket)(fd); } void ungetCharGclSocket ( int c, object strm) { object bufp = SOCKET_STREAM_BUFFER(strm); if (c == EOF) return; dprintf("pushing back %c\n",c); if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=c; } else { FEerror("Tried to unget too many chars",0); } } void doReverse ( char *s, int n ) { char *p=&s[n-1]; int m = n/2; while (--m>=0) { int tem = *s; *s = *p; *p = tem; s++; p--; } } /* void sigint() { install_default_signals(); terminal_interrupt(1); } */ #if 0 BOOL WINAPI inthandler(DWORD i) { emsg("in handler %d",i); terminal_interrupt(1); return TRUE; } #endif void alarm(int n) { return; } /* to do: in the lisp: start a shared named file based on the pid. Then others will be able to send us messages, eg:interrupt! and we will check this value in the CHECK_INTERRUPT places.. Then a little program like test4 or test3 can change the memory. */ static struct { HANDLE handle; LPVOID address; DWORD length ; char name[20] ; } sharedMemory = {0,0,0x10000} ; void sigterm() { exit(0); } #ifdef SIGABRT void sigabrt() { do_gcl_abort(); } #endif void sigkill() { do_gcl_abort(); } static void init_signals_pendingPtr() { static unsigned int where; if (sharedMemory.address) { signalsPendingPtr = sharedMemory.address; } else { signalsPendingPtr = (void *)&where; } gcl_signal(SIGKILL,sigkill); gcl_signal(SIGTERM,sigterm); #ifdef SIGABRT gcl_signal(SIGABRT,sigabrt); #endif } void close_shared_memory() { if (sharedMemory.handle) CloseHandle(sharedMemory.handle); sharedMemory.handle = NULL; if (sharedMemory.address) UnmapViewOfFile(sharedMemory.address); sharedMemory.address = NULL; init_signals_pendingPtr(); } void init_shared_memory (void) { static int n; if (n) return; n=1; sharedMemory.address=0; init_signals_pendingPtr(); return; sprintf(sharedMemory.name,"gcl-%d",getpid()); sharedMemory.handle = CreateFileMapping((HANDLE)-1,NULL,PAGE_READWRITE,0,sharedMemory.length ,TEXT(sharedMemory.name)); if (sharedMemory.handle == NULL) error("CreateFileMapping failed"); sharedMemory.address = MapViewOfFile(sharedMemory.handle, /* Handle to mapping object. */ FILE_MAP_WRITE, /* Read/write permission */ 0, /* Max. object size. */ 0, /* Size of hFile. */ 0); /* Map entire file. */ if (sharedMemory.address == NULL) error("MapViewOfFile failed"); init_signals_pendingPtr(); atexit(close_shared_memory); } /* The only signal REALLY handled somewhat under mingw is the SIGINT, and we need to make the following allow blocking of this. by for example taking the signal and then recording we got it, but delivering it later in the unblock code time ... ie in the */ static sigset_t _current_set=0; void sigemptyset( sigset_t *set) { *set = 0; } void sigaddset( sigset_t *set, int n) { *set |= (1 << n); } int sigismember ( sigset_t *set, int n) { return ((*set & (1 << n)) != 0); } int sigprocmask (int how , const sigset_t *set,sigset_t *oldset) { if (oldset) *oldset = _current_set; if (set) { switch (how) { case SIG_BLOCK: _current_set |= *set; break; case SIG_UNBLOCK: _current_set &= ~(*set); break; case SIG_SETMASK: _current_set = *set; break; } } return 0; } char *GCLExeName ( void ) { static char module_name_buf[128]; char *rv = NULL; module_name_buf[0] = 0; DWORD result = GetModuleFileName ( (HMODULE) NULL, (LPTSTR) &module_name_buf, 128 ); if ( result != 0 ) { rv = module_name_buf; } return ( (char *) rv ); } int vsystem(const char *command) { STARTUPINFO s={0}; PROCESS_INFORMATION p={0}; long unsigned int e; massert(CreateProcess(NULL,(void *)command,NULL,NULL,FALSE,0,NULL,NULL,&s,&p)); massert(!WaitForSingleObject(p.hProcess,INFINITE)); massert(GetExitCodeProcess(p.hProcess,&e)); massert(CloseHandle(p.hProcess)); massert(CloseHandle(p.hThread)); return e; } gcl-2.6.14/o/gmp_big.c0000755000175000017500000002641714360276512013016 0ustar cammcamm /* Copyright William F. Schelter 1991 Bignum routines. num_arith.c: add_int_big num_arith.c: big_minus num_arith.c: big_plus num_arith.c: big_quotient_remainder num_arith.c: big_sign num_arith.c: big_times num_arith.c: complement_big num_arith.c: copy_big num_arith.c: div_int_big num_arith.c: mul_int_big num_arith.c: normalize_big num_arith.c: normalize_big_to_object num_arith.c: stretch_big num_arith.c: sub_int_big num_comp.c: big_compare num_comp.c: big_sign num_log.c: big_sign num_log.c: copy_to_big num_log.c: normalize_big num_log.c: normalize_big_to_object num_log.c: stretch_big num_pred.c: big_sign number.c: big_to_double predicate.c: big_compare typespec.c: big_sign print.d: big_minus print.d: big_sign print.d: big_zerop print.d: copy_big print.d: div_int_big read.d: add_int_big read.d: big_to_double read.d: complement_big read.d: mul_int_big read.d: normalize_big read.d: normalize_big_to_object */ #include #define DEBUG_GMP #ifdef DEBUG_GMP #define ABS(x) ((x) < 0 ? -(x) : (x)) /* static object */ /* verify_big(object big) */ /* { int size; */ /* if(type_of(big)!=t_bignum) FEerror("Not a bignum",0); */ /* size = MP_SIZE(big); */ /* if ( size ==0 || (MP_SELF(big))[ABS(size)-1]==0) */ /* FEerror("badly formed",0); */ /* return big; */ /* } */ static object verify_big_or_zero(object big) { int size; if(type_of(big)!=t_bignum) FEerror("Not a bignum",0); size = MP_SIZE(big); if ( size && (MP_SELF(big))[ABS(size)-1]==0) FEerror("badly formed",0); return big; } /* static */ /* MP_INT* */ /* verify_mp(MP_INT *u) */ /* { int size = u->_mp_size; */ /* if (size != 0 && u->_mp_d[ABS(size)] == 0) */ /* FEerror("bad mp",0); */ /* return u; */ /* } */ #else #define verify_mp(x) #define verify_big(x) #define verify_big_or_zero(x) #endif object new_bignum(void) { object ans; {BEGIN_NO_INTERRUPT; ans = alloc_object(t_bignum); MP_SELF(ans) = 0; mpz_init(MP(ans)); END_NO_INTERRUPT; } return ans; } /* we have to store the body of a u in a bignum object so that the garbage collecter will move it and save it, and then we can copy it back */ #define GCPROTECT(u) \ MP_INT * __u = MP(big_gcprotect); \ (__u)->_mp_d = (u)->_mp_d; \ (__u)->_mp_alloc = (u)->_mp_alloc #define GC_PROTECTED_SELF (__u)->_mp_d #define END_GCPROTECT (__u)->_mp_d = 0 static object make_bignum(__mpz_struct *u) { object ans=alloc_object(t_bignum); memset(MP(ans),0,sizeof(*MP(ans))); mpz_init_set(MP(ans),u); return ans; } /* static object */ /* make_bignum(__mpz_struct *u) */ /* { object ans ; */ /* int size; */ /* {BEGIN_NO_INTERRUPT; */ /* /\* make sure we follow the bignum body of u if it gets moved... *\/ */ /* { GCPROTECT(u); */ /* ans = alloc_object(t_bignum); */ /* size = u->_mp_size; */ /* MP(ans)->_mp_d = 0; */ /* if (size == 0 ) */ /* size = 1; */ /* else if (size < 0) size= -size; */ /* MP(ans)->_mp_d = (mp_ptr) gcl_gmp_alloc (size*MP_LIMB_SIZE); */ /* MP(ans)->_mp_alloc = size; */ /* MP(ans)->_mp_size = u->_mp_size; */ /* memcpy(MP(ans)->_mp_d,GC_PROTECTED_SELF,size*MP_LIMB_SIZE); */ /* END_GCPROTECT; */ /* } */ /* END_NO_INTERRUPT; */ /* return ans; */ /* } */ /* } */ /* coerce a mpz_t to a bignum or fixnum */ object make_integer(__mpz_struct *u) { if ((u)->_mp_size == 0) return small_fixnum(0); if (mpz_fits_slong_p(u)) { return make_fixnum(mpz_get_si(u)); } return make_bignum(u); } /* like make_integer except that the storage of u is cleared if it is a fixnum, and if not the storage of u is actually copied to the new bignum */ #ifdef OBSOLETE object make_integer_clear(u) mpz_t u; { object ans; if ((u)->_mp_size == 0) return small_fixnum(0); if (mpz_fits_slong_p(u)) { fixnum x = mpz_get_si(u); mpz_clear(u); return make_fixnum(x); } {BEGIN_NO_INTERRUPT; { GCPROTECT(u); ans = alloc_object(t_bignum); MP(ans)->_mp_alloc = u->_mp_alloc; MP(ans)->_mp_size = u->_mp_size; /* the u->_mp_d may have moved */ MP_SELF(ans) = GC_PROTECTED_SELF; mpz_clear(u); END_GCPROTECT; } END_NO_INTERRUPT; } return ans; } #endif /* obsolete */ /* static int */ /* big_zerop(object x) */ /* { return (mpz_sgn(MP(x))== 0);} */ int big_compare(object x, object y) {return mpz_cmp(MP(x),MP(y)); } object normalize_big_to_object(object x) { return maybe_replace_big(x); } /* static void */ /* gcopy_to_big(__mpz_struct *res, object x) */ /* { */ /* mpz_set(MP(x),res); */ /* } */ /* destructively modifies x = i - x; */ void add_int_big(int i, object x) { MPOP_DEST(x,addsi,i,MP(x)); } /* static void */ /* sub_int_big(int i, object x) */ /* { */ /* SI_TEMP_DECL(mpz_int_temp); */ /* MPOP_DEST(x,subsi,i,MP(x)); */ /* } */ void mul_int_big(int i, object x) { MPOP_DEST(x,mulsi,i,MP(x)); } /* Div_int_big(i, x) destructively divides non-negative bignum x by positive int i. X will hold the quotient from the division. Div_int_big(i, x) returns the remainder of the division. I should be positive. X should be non-negative. */ /* static int */ /* div_int_big(int i, object x) */ /* { */ /* return mpz_tdiv_q_ui(MP(x),MP(x),i); */ /* } */ /* static object */ /* big_plus(object x, object y) */ /* { */ /* MPOP(return,addii,MP(x),MP(y)); */ /* } */ /* static object */ /* big_times(object x, object y) */ /* { */ /* MPOP(return,mulii,MP(x),MP(y)); */ /* } */ /* x is a big, and it is coerced to a fixnum (and the big is cleared) or it is smashed */ object normalize_big(object x) { if (MP_SIZE(x) == 0) return small_fixnum(0); if (mpz_fits_slong_p(MP(x))) { MP_INT *u = MP(x); return make_fixnum(mpz_get_si(u)); } else return x; } object big_minus(object x) { object y = new_bignum(); mpz_neg(MP(y),MP(x)); return normalize_big(y); } /* static void */ /* big_quotient_remainder(object x0, object y0, object *qp, object *rp) */ /* { */ /* object res,quot; */ /* res = new_bignum(); */ /* quot = new_bignum(); */ /* mpz_tdiv_qr(MP(quot),MP(res),MP(x0),MP(y0)); */ /* *qp = normalize_big(quot); */ /* *rp = normalize_big(res); */ /* return; */ /* } */ #ifndef IEEEFLOAT #error big_to_double requires IEEEFLOAT #endif static int double_exponent(double d) { union {double d;int i[2];} u; if (d == 0.0) return(0); u.d=d; return (((u.i[HIND] & 0x7ff00000) >> 20) - 1022); } static double set_exponent(double d, int e) { union {double d;int i[2];} u; if (d == 0.0) return(0.0); u.d=d; u.i[HIND]= (u.i[HIND] & 0x800fffff) | (((e + 1022) << 20) & 0x7ff00000); return(u.d); } double big_to_double(object x) { double d=mpz_get_d(MP(x)); int s=mpz_sizeinbase(MP(x),2); if (s>=54 && mpz_tstbit(MP(x),s-54)) { union {double d;int i[2];} u; u.i[HIND]=0; u.i[LIND]=1; d+=(d>0.0 ? 1.0 : -1.0)*set_exponent(u.d,double_exponent(d)-53); } return d; } /* static object copy_big(object x) */ /* { */ /* if (type_of(x)==t_bignum) */ /* return make_bignum(MP(x)); */ /* else FEerror("bignum expected",0); */ /* return Cnil; */ /* } */ /* this differes from old copy_to_big in that it does not alter copy a bignum. */ /* static object */ /* copy_to_big(object x) { */ /* if (type_of(x) == t_fixnum) { */ /* object ans = new_bignum(); */ /* mpz_set_si(MP(ans),fix(x)); */ /* return ans; */ /* } else { */ /* return x; */ /* } */ /* } */ /* put in to get (declare integer working with existing setup. should be optimized at some point, as we're just converting and reconverting integer data, it appears -- CM */ int obj_to_mpz(object x,MP_INT * y) { switch(type_of(x)) { case t_fixnum: mpz_set_si(y,fix(x)); break; case t_bignum: if (abs(MP(x)->_mp_size)<=y->_mp_alloc) mpz_set(y,MP(x)); else return abs(MP(x)->_mp_size)*sizeof(*y->_mp_d); break; default: FEerror("fixnum or bignum expected",0); break; } return 0; } int obj_to_mpz1(object x,MP_INT * y,void *v) { switch(type_of(x)) { case t_fixnum: mpz_set_si(y,fix(x)); break; case t_bignum: y->_mp_alloc=abs(MP(x)->_mp_size); y->_mp_d=v; mpz_set(y,MP(x)); break; default: FEerror("fixnum or bignum expected",0); break; } return 0; } int mpz_to_mpz(MP_INT * x,MP_INT * y) { if (abs(x->_mp_size)<=y->_mp_alloc) mpz_set(y,x); else return abs(x->_mp_size)*sizeof(*y->_mp_d); return 0; } int mpz_to_mpz1(MP_INT * x,MP_INT * y,void *v) { y->_mp_alloc=abs(x->_mp_size); y->_mp_d=v; mpz_set(y,x); return 0; } void isetq_fix(MP_INT * var,int s) { mpz_set_si(var,s); } MP_INT * otoi(object x) { if (type_of(x)==t_fixnum) { object y = new_bignum(); mpz_set_si(MP(y),fix(x)); return MP(y); } if (type_of(x)==t_bignum) return (MP(x)); FEwrong_type_argument(sLinteger,x); return NULL; } /* end added section for declare integer -- CM */ /* return object like *xpt coercing to a fixnum if necessary, or return the actual bignum replacing it with another */ object maybe_replace_big(object x) { /* note mpz_fits_sint_p(MP(x)) returns arbitrary result if passed 0 in bignum form. bug or feature of gmp.. */ if (MP_SIZE(x) == 0) return small_fixnum(0); if (mpz_fits_slong_p(MP(x))) { MP_INT *u = MP(x); return make_fixnum(mpz_get_si(u)); } return make_bignum(MP(x)); } object bignum2(unsigned int h, unsigned int l) { object x = new_bignum(); mpz_set_ui(MP(x),h); mpz_mul_2exp(MP(x),MP(x),32); mpz_add_ui(MP(x),MP(x),l); return normalize_big(x); } void integer_quotient_remainder_1(object x, object y, object *qp, object *rp,fixnum d) { if (type_of(x)==t_fixnum && type_of(y)==t_fixnum) { fixnum fx=fix(x),fy=fix(y); if (fx!=-fx) {/*MOST_NEGATIVE_FIX*/ if (qp) { fixnum z=fixnum_div(fx,fy,d); if (rp) *rp=make_fixnum(fx-fy*z); *qp=make_fixnum(z); } else if (rp) *rp=make_fixnum(fixnum_rem(fx,fy,d)); return; } } { __mpz_struct *b1=INTEGER_TO_MP(x,big_fixnum1),*b2=INTEGER_TO_MP(y,big_fixnum2); if (qp) { if (rp) { void (*f)()=d<0 ? mpz_fdiv_qr : (d>0 ? mpz_cdiv_qr : mpz_tdiv_qr); f(MP(big_fixnum3),MP(big_fixnum4),b1,b2); *rp=maybe_replace_big(big_fixnum4); } else { void (*f)()=d<0 ? mpz_fdiv_q : (d>0 ? mpz_cdiv_q : mpz_tdiv_q); f(MP(big_fixnum3),b1,b2); } *qp=maybe_replace_big(big_fixnum3); } else if (rp) { void (*f)()=d<0 ? mpz_fdiv_r : (d>0 ? mpz_cdiv_r : mpz_tdiv_r); f(MP(big_fixnum4),b1,b2); *rp=maybe_replace_big(big_fixnum4); } } } #define HAVE_MP_COERCE_TO_STRING object coerce_big_to_string(object x, int printbase) { int i; int sign = BIG_SIGN(x); int ss = mpz_sizeinbase(MP(x),printbase); char *p; object ans = alloc_simple_string(ss+2+(sign<0? 1: 0)); ans->st.st_self=p=alloc_relblock(ans->st.st_dim); /* if (sign < 0) *p++='-'; */ mpz_get_str(p, printbase,MP(x)); i = ans->st.st_dim-5; if (i <0 ) i=0; while(ans->st.st_self[i]) { i++;} ans->st.st_fillp=i; return ans; } void gcl_init_big(void) { gcl_init_big1(); big_gcprotect=alloc_object(t_bignum); MP_SELF(big_gcprotect)=0; MP_ALLOCATED(big_gcprotect)=0; big_fixnum1=new_bignum(); big_fixnum2=new_bignum(); big_fixnum3=new_bignum(); big_fixnum4=new_bignum(); enter_mark_origin(&big_fixnum1); enter_mark_origin(&big_gcprotect); enter_mark_origin(&big_fixnum2); enter_mark_origin(&big_fixnum3); enter_mark_origin(&big_fixnum4); } gcl-2.6.14/o/string.d0000755000175000017500000003536514360276512012723 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* string.d string routines */ #include #include "include.h" object sKstart1; object sKend1; object sKstart2; object sKend2; object sKinitial_element; object sKelement_type; object alloc_simple_string(l) int l; { object x; x = alloc_object(t_string); x->st.st_hasfillp = FALSE; x->st.st_adjustable = FALSE; x->st.st_displaced = Cnil; x->st.st_dim = x->st.st_fillp = l; x->st.st_self = NULL; return(x); } /* Make_simple_string(s) makes a simple string from C string s. */ object make_simple_string(s) const char *s; { int l, i; char *p; object x; vs_mark; {BEGIN_NO_INTERRUPT; for (l = 0; s[l] != '\0'; l++) ; x = alloc_simple_string(l); vs_push(x); p = alloc_relblock(l); for (i = 0; i < l; i++) p[i] = s[i]; x->st.st_self = p; vs_reset; END_NO_INTERRUPT;} return(x); } /* This correponds to string= (just the string equality). */ bool string_eq(x, y) object x, y; { int i, j; /* if (type_of(x) != t_string || type_of(y) != t_string) error("string expected"); */ i = x->st.st_fillp; j = y->st.st_fillp; if (i != j) return(FALSE); for (i = 0; i < j; i++) if (x->st.st_self[i] != y->st.st_self[i]) return(FALSE); return(TRUE); } /* This corresponds to string-equal (string equality ignoring the case). */ bool string_equal(x, y) object x, y; { int i, j; char *p, *q; /* if (type_of(x) != t_string || type_of(y) != t_string) error("string expected"); */ i = x->st.st_fillp; j = y->st.st_fillp; if (i != j) return(FALSE); p = x->st.st_self; q = y->st.st_self; for (i = 0; i < j; i++) if ((isLower(p[i]) ? p[i] - ('a' - 'A') : p[i]) != (isLower(q[i]) ? q[i] - ('a' - 'A') : q[i])) return(FALSE); return(TRUE); } /* Copy_simple_string(x) copies string x to a simple string. */ object copy_simple_string(x) object x; { object y; int i; vs_mark; vs_push(x); /* if (type_of(x) != t_string) error("string expected"); */ {BEGIN_NO_INTERRUPT; y = alloc_object(t_string); y->st.st_dim = y->st.st_fillp = x->st.st_fillp; y->st.st_hasfillp = FALSE; y->st.st_adjustable = FALSE; y->st.st_displaced = Cnil; y->st.st_self = NULL; vs_push(y); y->st.st_self = alloc_relblock(x->st.st_fillp); for (i = 0; i < x->st.st_fillp; i++) y->st.st_self[i] = x->st.st_self[i]; vs_reset; END_NO_INTERRUPT; } return(y); } object coerce_to_string(x) object x; { object y; int i; vs_mark; switch (type_of(x)) { case t_symbol: {BEGIN_NO_INTERRUPT; y = alloc_simple_string(x->s.s_fillp); vs_push(y); if (x->s.s_self < heap_end) y->st.st_self = x->s.s_self; else { y->st.st_self = alloc_relblock(x->s.s_fillp); for (i = 0; i < x->s.s_fillp; i++) y->st.st_self[i] = x->s.s_self[i]; } vs_reset; END_NO_INTERRUPT;} return(y); case t_fixnum: x = coerce_to_character(x); vs_push(x); case t_character: {BEGIN_NO_INTERRUPT; y = alloc_simple_string(1); vs_push(y); y->st.st_self = alloc_relblock(1); y->st.st_self[0] = char_code(x); vs_reset; END_NO_INTERRUPT;} return(y); case t_string: return(x); default: break; } vs_push(x); x=wrong_type_argument(sLstring,x); vs_popp; return(Cnil); } @(defun char (s i) int j; @ check_type_string(&s); if (type_of(i) != t_fixnum) illegal_index(s, i); if ((j = fix(i)) < 0 || j >= s->st.st_dim) illegal_index(s, i); @(return `code_char(s->ust.ust_self[j])`) @) LFD(siLchar_set)() { int j; check_arg(3); check_type_string(&vs_base[0]); if (type_of(vs_base[1]) != t_fixnum) illegal_index(vs_base[0], vs_base[1]); if ((j = fix(vs_base[1])) < 0 || j >= vs_base[0]->st.st_dim) illegal_index(vs_base[0], vs_base[1]); check_type_character(&vs_base[2]); vs_base[0]->st.st_self[j] = char_code(vs_base[2]); vs_base += 2; } void get_string_start_end(string, start, end, ps, pe) object string, start, end; int *ps, *pe; { if (start == Cnil) *ps = 0; else if (type_of(start) != t_fixnum) goto E; else { *ps = fix(start); if (*ps < 0) goto E; } if (end == Cnil) { *pe = string->st.st_fillp; if (*pe < *ps) goto E; } else if (type_of(end) != t_fixnum) goto E; else { *pe = fix(end); if (*pe < *ps || *pe > string->st.st_fillp) goto E; } return; E: FEerror("~S and ~S are illegal as :START and :END~%\ for the string ~S.", 3, start, end, string); } @(defun string_eq (string1 string2 &key start1 end1 start2 end2) int s1=0, e1=0, s2=0, e2=0; @ string1 = coerce_to_string(string1); string2 = coerce_to_string(string2); get_string_start_end(string1, start1, end1, &s1, &e1); get_string_start_end(string2, start2, end2, &s2, &e2); if (e1 - s1 != e2 - s2) @(return Cnil) while (s1 < e1) if (string1->st.st_self[s1++] != string2->st.st_self[s2++]) @(return Cnil) @(return Ct) @) @(defun string_equal (string1 string2 &key start1 end1 start2 end2) int s1=0, e1=0, s2=0, e2=0; int i1, i2; @ string1 = coerce_to_string(string1); string2 = coerce_to_string(string2); get_string_start_end(string1, start1, end1, &s1, &e1); get_string_start_end(string2, start2, end2, &s2, &e2); if (e1 - s1 != e2 - s2) @(return Cnil) while (s1 < e1) { i1 = string1->st.st_self[s1++]; i2 = string2->st.st_self[s2++]; if (isLower(i1)) i1 -= 'a' - 'A'; if (isLower(i2)) i2 -= 'a' - 'A'; if (i1 != i2) @(return Cnil) } @(return Ct) @) int string_sign, string_boundary; @(static defun string_cmp (string1 string2 &key start1 end1 start2 end2) int s1=0, e1=0, s2=0, e2=0; int i1, i2; int s; @ string1 = coerce_to_string(string1); string2 = coerce_to_string(string2); get_string_start_end(string1, start1, end1, &s1, &e1); get_string_start_end(string2, start2, end2, &s2, &e2); while (s1 < e1) { if (s2 == e2) @(return `string_sign>0 ? Cnil : make_fixnum(s1)`) i1 = string1->ust.ust_self[s1]; i2 = string2->ust.ust_self[s2]; if (string_sign == 0) { if (i1 != i2) @(return `make_fixnum(s1)`) } else { s = string_sign*(i2-i1); if (s > 0) @(return `make_fixnum(s1)`) if (s < 0) @(return Cnil) } s1++; s2++; } if (s2 == e2) @(return `string_boundary==0 ? make_fixnum(s1) : Cnil`) @(return `string_sign>=0 ? make_fixnum(s1) : Cnil`) @) LFD(Lstring_l)() { string_sign = 1; string_boundary = 1; FFN(Lstring_cmp)(); } LFD(Lstring_g)() { string_sign = -1; string_boundary = 1; FFN(Lstring_cmp)(); } LFD(Lstring_le)() { string_sign = 1; string_boundary = 0; FFN(Lstring_cmp)(); } LFD(Lstring_ge)() { string_sign = -1; string_boundary = 0; FFN(Lstring_cmp)(); } LFD(Lstring_neq)() { string_sign = 0; string_boundary = 1; FFN(Lstring_cmp)(); } @(static defun string_compare (string1 string2 &key start1 end1 start2 end2) int s1=0, e1=0, s2=0, e2=0; int i1, i2; int s; @ string1 = coerce_to_string(string1); string2 = coerce_to_string(string2); get_string_start_end(string1, start1, end1, &s1, &e1); get_string_start_end(string2, start2, end2, &s2, &e2); while (s1 < e1) { if (s2 == e2) @(return `string_sign>0 ? Cnil : make_fixnum(s1)`) i1 = string1->ust.ust_self[s1]; if (isLower(i1)) i1 -= 'a' - 'A'; i2 = string2->ust.ust_self[s2]; if (isLower(i2)) i2 -= 'a' - 'A'; if (string_sign == 0) { if (i1 != i2) @(return `make_fixnum(s1)`) } else { s = string_sign*(i2-i1); if (s > 0) @(return `make_fixnum(s1)`) if (s < 0) @(return Cnil) } s1++; s2++; } if (s2 == e2) @(return `string_boundary==0 ? make_fixnum(s1) : Cnil`) @(return `string_sign>=0 ? make_fixnum(s1) : Cnil`) @) LFD(Lstring_lessp)() { string_sign = 1; string_boundary = 1; FFN(Lstring_compare)(); } LFD(Lstring_greaterp)() { string_sign = -1; string_boundary = 1; FFN(Lstring_compare)(); } LFD(Lstring_not_greaterp)(){ string_sign = 1; string_boundary = 0; FFN(Lstring_compare)(); } LFD(Lstring_not_lessp)() { string_sign = -1; string_boundary = 0; FFN(Lstring_compare)(); } LFD(Lstring_not_equal)() { string_sign = 0; string_boundary = 1; FFN(Lstring_compare)(); } /* element_type is currently ignored -- character == base-char == standard-char */ @(defun make_string (size &key (initial_element `code_char(' ')` ) element_type &aux x) int i; @ while (type_of(size) != t_fixnum || fix(size) < 0) size = wrong_type_argument(TSnon_negative_integer, size); /* bignum not allowed, this is PRACTICAL!! */ while (type_of(initial_element) != t_character || char_bits(initial_element) != 0 || char_font(initial_element) != 0) initial_element = wrong_type_argument(sLcharacter, initial_element); {BEGIN_NO_INTERRUPT; x = alloc_simple_string(fix(size)); x->st.st_self = alloc_relblock(fix(size)); for (i = 0; i < fix(size); i++) x->st.st_self[i] = char_code(initial_element); END_NO_INTERRUPT; } @(return x) @) static bool member_char(c, char_bag) int c; object char_bag; { int i, f; switch (type_of(char_bag)) { case t_symbol: case t_cons: while (!endp(char_bag)) { if (type_of(char_bag->c.c_car) == t_character && c == char_code(char_bag->c.c_car)) return(TRUE); char_bag = char_bag->c.c_cdr; } return(FALSE); case t_vector: for (i = 0, f = char_bag->v.v_fillp; i < f; i++) { if (type_of(char_bag->v.v_self[i]) == t_character && c == char_code(char_bag->v.v_self[i])) return(TRUE); } return(FALSE); case t_string: for (i = 0, f = char_bag->st.st_fillp; i < f; i++) { if (c == char_bag->st.st_self[i]) return(TRUE); } return(FALSE); case t_bitvector: return(FALSE); default: FEerror("~S is not a sequence.", 1, char_bag); return(FALSE); } } /*static void Lstring_trim0();*/ @(static defun string_trim0 (char_bag strng &aux res) int i, j, k; @ strng = coerce_to_string(strng); i = 0; j = strng->st.st_fillp - 1; if (left_trim) for (; i <= j; i++) if (!member_char(strng->st.st_self[i], char_bag)) break; if (right_trim) for (; j >= i; --j) if (!member_char(strng->st.st_self[j], char_bag)) break; k = j - i + 1; {BEGIN_NO_INTERRUPT; res = alloc_simple_string(k); res->st.st_self = alloc_relblock(k); for (j = 0; j < k; j++) res->st.st_self[j] = strng->st.st_self[i + j]; END_NO_INTERRUPT; } @(return res) @) LFD(Lstring_trim)() { left_trim = right_trim = TRUE; FFN(Lstring_trim0)(); } LFD(Lstring_left_trim)() { left_trim = TRUE; right_trim = FALSE; FFN(Lstring_trim0)(); } LFD(Lstring_right_trim)() { left_trim = FALSE; right_trim = TRUE; FFN(Lstring_trim0)();} static int char_upcase(c, bp) int c, *bp; { if (isLower(c)) return(c - ('a' - 'A')); else return(c); } static int char_downcase(c, bp) int c, *bp; { if (isUpper(c)) return(c + ('a' - 'A')); else return(c); } static int char_capitalize(c, bp) int c, *bp; { if (isLower(c)) { if (*bp) c -= 'a' - 'A'; *bp = FALSE; } else if (isUpper(c)) { if (!*bp) c += 'a' - 'A'; *bp = FALSE; } else if (!isDigit(c)) *bp = TRUE; else *bp = FALSE; return(c); } @(static defun string_case (strng &key start end &aux conv) int s=0, e=0, i; bool b; @ strng = coerce_to_string(strng); get_string_start_end(strng, start, end, &s, &e); conv = copy_simple_string(strng); b = TRUE; for (i = s; i < e; i++) conv->st.st_self[i] = (*casefun)(conv->st.st_self[i], &b); @(return conv) @) LFD(Lstring_upcase)() { casefun = char_upcase; FFN(Lstring_case)(); } LFD(Lstring_downcase)() { casefun = char_downcase; FFN(Lstring_case)(); } LFD(Lstring_capitalize)() { casefun = char_capitalize; FFN(Lstring_case)(); } @(static defun nstring_case (strng &key start end) int s=0, e=0, i; bool b; @ check_type_string(&strng); get_string_start_end(strng, start, end, &s, &e); b = TRUE; for (i = s; i < e; i++) strng->st.st_self[i] = (*casefun)(strng->st.st_self[i], &b); @(return strng) @) LFD(Lnstring_upcase)() { casefun = char_upcase; FFN(Lnstring_case)(); } LFD(Lnstring_downcase)() { casefun = char_downcase; FFN(Lnstring_case)(); } LFD(Lnstring_capitalize)() { casefun = char_capitalize; FFN(Lnstring_case)(); } @(defun string (x) @ @(return `coerce_to_string(x)`) @) DEFUN_NEW("STRING-CONCATENATE",object,fLstring_concatenate,SI,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { fixnum i,l,m,narg=VFUN_NARGS; object x; va_list ap; va_start(ap,first); vs_base=vs_top; for (l=i=0;ist.st_fillp; } va_end(ap); { object *p; BEGIN_NO_INTERRUPT; x=alloc_simple_string(l); (x)->st.st_self = alloc_relblock(l); for (l=0,p=vs_base;pst.st_fillp)>=0;p++,l+=m) memcpy(x->st.st_self+l,(*p)->st.st_self,m); END_NO_INTERRUPT; } RETURN1(x); } void gcl_init_string_function() { sKstart1 = make_keyword("START1"); sKend1 = make_keyword("END1"); sKstart2 = make_keyword("START2"); sKend2 = make_keyword("END2"); sKinitial_element = make_keyword("INITIAL-ELEMENT"); sKelement_type = make_keyword("ELEMENT-TYPE"); sKstart = make_keyword("START"); sKend = make_keyword("END"); make_function("CHAR", Lchar); make_si_function("CHAR-SET", siLchar_set); make_function("SCHAR", Lchar); make_si_function("SCHAR-SET", siLchar_set); make_function("STRING=", Lstring_eq); make_function("STRING-EQUAL", Lstring_equal); make_function("STRING<", Lstring_l); make_function("STRING>", Lstring_g); make_function("STRING<=", Lstring_le); make_function("STRING>=", Lstring_ge); make_function("STRING/=", Lstring_neq); make_function("STRING-LESSP", Lstring_lessp); make_function("STRING-GREATERP", Lstring_greaterp); make_function("STRING-NOT-LESSP", Lstring_not_lessp); make_function("STRING-NOT-GREATERP", Lstring_not_greaterp); make_function("STRING-NOT-EQUAL", Lstring_not_equal); make_function("MAKE-STRING", Lmake_string); make_function("STRING-TRIM", Lstring_trim); make_function("STRING-LEFT-TRIM", Lstring_left_trim); make_function("STRING-RIGHT-TRIM", Lstring_right_trim); make_function("STRING-UPCASE", Lstring_upcase); make_function("STRING-DOWNCASE", Lstring_downcase); make_function("STRING-CAPITALIZE", Lstring_capitalize); make_function("NSTRING-UPCASE", Lnstring_upcase); make_function("NSTRING-DOWNCASE", Lnstring_downcase); make_function("NSTRING-CAPITALIZE", Lnstring_capitalize); make_function("STRING", Lstring); } gcl-2.6.14/o/read.d0000755000175000017500000016074314360276512012327 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* read.d */ #define NEED_ISFINITE #include "include.h" #include #include #include "num_include.h" static object current_readtable(void); DEFVAR("PATCH-SHARP",sSpatch_sharp,SI,sLnil,""); static object patch_sharp(object x) {return ifuncall1(sSpatch_sharp,x);} #define digitp digitp1 static inline int digitp(int i,int r) { if ( r<=10 || i<='9' ) i-='0'; else { i=tolower(i)-'a'; i=i<0 ? i : i+10; } return i=0;u=0,o=o && f=0;u=0,o=o && fBUGGY_MAXIMUM_SSCANF_LENGTH) { char *q1=s+BUGGY_MAXIMUM_SSCANF_LENGTH-strlen(q); memmove(q1,q,strlen(q)+1); q=q1; } #endif n=sscanf(s,"%lf%n",&f,&m); *q=c; if (n!=1||s[m]) return OBJNULL; switch (ch=='e' || ch=='E' ? READdefault_float_format : ch) { case 's':case 'S': return make_shortfloat((float)f); case 'f':case 'F':case 'd':case 'D':case 'l':case 'L': return make_longfloat(f); default: return OBJNULL; } } } static inline void too_long_token(void) { char *q; int i; BEGIN_NO_INTERRUPT; q = alloc_contblock(token->st.st_dim*2); for (i = 0; i < token->st.st_dim; i++) q[i] = token->st.st_self[i]; token->st.st_self = q; token->st.st_dim *= 2; END_NO_INTERRUPT; } static inline void null_terminate_token(void) { if (token->st.st_fillp==token->st.st_dim) too_long_token(); token->st.st_self[token->st.st_fillp]=0; } #define token_buffer token->st.st_self /* the active length of the token */ int tok_leng; object dispatch_reader; #define cat(c) (READtable->rt.rt_self[char_code((c))] \ .rte_chattrib) static void setup_READtable() { READtable = current_readtable(); } /*bootstrap code*/ DEFUN_NEW("SHARP-EQ-READER",object,fSsharp_eq_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object ch,object ind),"") { object x,res; if (READsuppress) return Cnil; if (ind==Cnil) FEerror("The #= readmacro requires an argument.", 0); for (x=sSAsharp_eq_contextA->s.s_dbind;type_of(x)==t_cons && !(eql(x->c.c_car->c.c_car,ind));x=x->c.c_cdr); if (x!=Cnil) FEerror("Duplicate definitions for #~D=.",1,ind); x=x->c.c_car; sSAsharp_eq_contextA->s.s_dbind=MMcons((x=MMcons(ind,MMcons(Cnil,OBJNULL))),sSAsharp_eq_contextA->s.s_dbind); res=x->c.c_cdr->c.c_car=read_object(s); if (res==x->c.c_cdr->c.c_cdr) FEerror("#~D# is defined by itself.",1,x->c.c_car); return res; } DEFUN_NEW("SHARP-SHARP-READER",object,fSsharp_sharp_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object ch,object ind),"") { object x; if (READsuppress) return Cnil; if (ind==Cnil) FEerror("The ## readmacro requires an argument.", 0); for (x=sSAsharp_eq_contextA->s.s_dbind;type_of(x)==t_cons && !(eql(x->c.c_car->c.c_car,ind));x=x->c.c_cdr); if (x==Cnil) FEerror("#~D# is undefined.",1,ind); x=x->c.c_car; if (x->c.c_cdr->c.c_cdr==OBJNULL) x->c.c_cdr->c.c_cdr=alloc_object(t_spice); return x->c.c_cdr->c.c_cdr; } DEFUN_NEW("PATCH-SHARP",object,fSpatch_sharp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { int i,j; object y,p; switch (type_of(x)) { case t_spice: for (y=sSAsharp_eq_contextA->s.s_dbind;type_of(y)==t_cons && y->c.c_car->c.c_cdr->c.c_cdr!=x;y=y->c.c_cdr); return y->c.c_car->c.c_cdr->c.c_car; break; case t_cons: y=x; do { y->c.c_car=FFN(fSpatch_sharp)(y->c.c_car); p=y; y=y->c.c_cdr; } while (type_of(y)==t_cons); p->c.c_cdr=FFN(fSpatch_sharp)(p->c.c_cdr); break; case t_vector: if ((enum aelttype)x->v.v_elttype==aet_object) for (i=0;iv.v_fillp;i++) x->v.v_self[i]=FFN(fSpatch_sharp)(x->v.v_self[i]); break; case t_array: if ((enum aelttype)x->a.a_elttype==aet_object) { for (i=0,j=1;ia.a_rank;i++) j*=x->a.a_dims[i]; for (i=0;ia.a_self[i]=FFN(fSpatch_sharp)(x->a.a_self[i]); } break; case t_structure: y=x->str.str_def; i=S_DATA(y)->length; while (i-->0) structure_set(x,y,i,FFN(fSpatch_sharp)(structure_ref(x,y,i))); break; default: break; } return(x); } /*end bootstrap code*/ DEFVAR("*SHARP-EQ-CONTEXT*",sSAsharp_eq_contextA,SI,sLnil,""); DEFUN_NEW("ALLOC-SPICE",object,fSalloc_spice,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { return alloc_object(t_spice); } DEFUN_NEW("SPICE-P",object,fSspice_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { return type_of(x)==t_spice ? Ct : Cnil; } static void setup_READ() { object x; READtable = current_readtable(); x = symbol_value(sLAread_default_float_formatA); if (x == sLshort_float) READdefault_float_format = 'S'; else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float) READdefault_float_format = 'F'; else { vs_push(x); sLAread_default_float_formatA->s.s_dbind = sLsingle_float; FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", 1, x); } x = symbol_value(sLAread_baseA); if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { vs_push(x); sLAread_baseA->s.s_dbind = make_fixnum(10); FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); } READbase = fix(x); READsuppress = symbol_value(sLAread_suppressA) != Cnil; sSAsharp_eq_contextA->s.s_dbind=Cnil; backq_level = 0; } /* static void */ /* setup_standard_READ() */ /* { */ /* READtable = standard_readtable; */ /* READdefault_float_format = 'F'; */ /* READbase = 10; */ /* READsuppress = FALSE; */ /* sSAsharp_eq_contextA->s.s_dbind=Cnil; */ /* backq_level = 0; */ /* } */ object read_char(in) object in; { return(code_char(readc_stream(in))); } #define read_char(in) code_char(readc_stream(in)) static void unread_char(c, in) object c, in; { if (type_of(c) != t_character) FEwrong_type_argument(sLcharacter, c); unreadc_stream(char_code(c), in); } /* Peek_char corresponds to COMMON Lisp function PEEK-CHAR. When pt is TRUE, preceeding whitespaces are ignored. */ object peek_char(pt, in) bool pt; object in; { object c; if (pt) { do c = read_char(in); while (cat(c) == cat_whitespace); unread_char(c, in); return(c); } else { c = read_char(in); unread_char(c, in); return(c); } } static object read_object_recursive(in) object in; { VOL object x; bool e; object old_READtable = READtable; int old_READdefault_float_format = READdefault_float_format; int old_READbase = READbase; bool old_READsuppress = READsuppress; /* BUG FIX by Toshiba */ vs_push(old_READtable); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } READtable = current_readtable(); x = symbol_value(sLAread_default_float_formatA); if (x == sLshort_float) READdefault_float_format = 'S'; else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float) READdefault_float_format = 'F'; else { vs_push(x); sLAread_default_float_formatA->s.s_dbind = sLsingle_float; FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", 1, x); } x = symbol_value(sLAread_baseA); if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { vs_push(x); sLAread_baseA->s.s_dbind = make_fixnum(10); FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); } READbase = fix(x); READsuppress = symbol_value(sLAread_suppressA) != Cnil; x = read_object(in); e = FALSE; L: frs_pop(); READtable = old_READtable; READdefault_float_format = old_READdefault_float_format; READbase = old_READbase; READsuppress = old_READsuppress; /* BUG FIX by Toshiba */ vs_popp; if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } return(x); } object read_object_non_recursive(in) object in; { VOL object x; bool e; object old_READtable; int old_READdefault_float_format; int old_READbase; int old_READsuppress; object old_READcontext; int old_backq_level; old_READtable = READtable; old_READdefault_float_format = READdefault_float_format; old_READbase = READbase; old_READsuppress = READsuppress; old_READcontext=sSAsharp_eq_contextA->s.s_dbind; /* BUG FIX by Toshiba */ vs_push(old_READtable); old_backq_level = backq_level; setup_READ(); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } x = read_object(in); vs_push(x); #ifndef _WIN32 while (listen_stream(in)) { object c=read_char(in); if (cat(c)!=cat_whitespace) { unread_char(c,in); break; } } #endif if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) x = vs_head = patch_sharp(x); e = FALSE; L: frs_pop(); READtable = old_READtable; READdefault_float_format = old_READdefault_float_format; READbase = old_READbase; READsuppress = old_READsuppress; sSAsharp_eq_contextA->s.s_dbind=old_READcontext; backq_level = old_backq_level; if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } vs_popp; /* BUG FIX by Toshiba */ vs_popp; return(x); } #ifdef UNIX /* faster code for inner loop from file stream */ #define xxxread_char_to(res,in,eof_code) \ do{FILE *fp; \ if(fp=in->sm.sm_fp) \ {int ch = getc(fp); \ if (ch==EOF) { \ if (feof(fp)) { eof_code;} \ else if (in->sm.sm_mode==smm_socket) \ { ch = getOneChar(fp); \ if (ch==EOF) { eof_code;}}} \ else res=code_char(ch);} \ else \ { if (stream_at_end(in)) \ {eof_code;} \ else res=read_char(in);}} while(0) #define read_char_to(res,in,eof_code) \ do{FILE *fp; \ if((fp=in->sm.sm_fp)) \ {int ch = getc(fp); \ if (ch==EOF && feof(fp)) \ { eof_code;} \ else res=code_char(ch);} \ else \ {int ch ; \ if(stream_at_end(in)) {eof_code ;} \ ch = readc_stream(in); \ if (ch == EOF) { eof_code;} \ res = code_char(ch); \ }} while(0) #else #define read_char_to(res,in,eof_code) \ do {if(stream_at_end(in)) {eof_code ;} \ else { int ch = readc_stream(in); \ if (ch == EOF) { eof_code;} \ res = code_char(ch); \ } \ } while(0) #endif /* Read_object(in) reads an object from stream in. This routine corresponds to COMMON Lisp function READ. */ /* FIXME What should this be? Apparently no reliable way to use value stack */ #define MAX_PACKAGE_STACK 1024 static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP; object read_object(in) object in; { object x; object c=Cnil; enum chattrib a; object *old_vs_base; object result; object p; int colon=0, colon_type; int i; bool df, ilf; VOL int length; vs_mark; cs_check(in); vs_check_push(delimiting_char); delimiting_char = OBJNULL; df = detect_eos_flag; detect_eos_flag = FALSE; ilf = in_list_flag; in_list_flag = FALSE; dot_flag = FALSE; BEGIN: do { read_char_to(c,in, { if (df) { vs_reset; return(OBJNULL); } else end_of_stream(in); }); a = cat(c); } while (a == cat_whitespace); if (c->ch.ch_code == '(') { /* Loose package extension */ LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */ if (LP) { if (PP0-P0>=MAX_PACKAGE_STACK) FEerror("Too many nested package specifiers",0); *PP0++=LP; LP=NULL; } } else if (LP) FEerror("Loose package prefix must be followed by a list",0); if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior, will pop stack to beginning as parens must match before the reader starts */ delimiting_char = vs_head; if (delimiting_char != OBJNULL && c == delimiting_char) { delimiting_char = OBJNULL; vs_reset; return(OBJNULL); } delimiting_char = OBJNULL; if (a == cat_terminating || a == cat_non_terminating) { object *fun_box = vs_top; old_vs_base = vs_base; vs_push(Cnil); vs_base = vs_top; vs_push(in); vs_push(c); x = READtable->rt.rt_self[char_code(c)].rte_macro; fun_box[0] = x; super_funcall(x); i = vs_top - vs_base; if (i == 0) { vs_base = old_vs_base; vs_top = old_vs_top + 1; goto BEGIN; } if (i > 1) { vs_push(make_fixnum(i)); FEerror("The readmacro ~S returned ~D values.", 2, fun_box[0], vs_top[-1]); } result = vs_base[0]; vs_base = old_vs_base; vs_reset; return(result); } escape_flag = FALSE; length = 0; tok_leng=0; colon_type = 0; goto L; for (;;) { if (length >= token->st.st_dim) too_long_token(); token_buffer[(tok_leng++,length++)] = char_code(c); K: read_char_to(c,in,goto M); a = cat(c); L: if (a == cat_single_escape) { c = read_char(in); a = cat_constituent; escape_flag = TRUE; } else if (a == cat_multiple_escape) { escape_flag = TRUE; for (;;) { if (stream_at_end(in)) end_of_stream(in); c = read_char(in); a = cat(c); if (a == cat_single_escape) { c = read_char(in); a = cat_constituent; } else if (a == cat_multiple_escape) break; if (length >= token->st.st_dim) too_long_token(); token_buffer[(tok_leng++,length++)] = char_code(c); } goto K; } else if (a == cat_terminating) { break; } else if (a == cat_whitespace) { /* skip all whitespace after trailing colon if no escape seen */ if (colon+colon_type==length && !escape_flag) goto K; else break; } else { switch(char_code(c)) { case '\b': case '\t': case '\n': case '\r': case '\f': case ' ': case '\177': READER_ERROR(in,"Cannot read character"); default: break; } if ('a' <= char_code(c) && char_code(c) <= 'z') { if ('a' <= char_code(c) && char_code(c) <= 'z' && (READtable->rt.rt_case==sKupcase || READtable->rt.rt_case==sKinvert)) c = code_char(char_code(c) - ('a' - 'A')); else if ('A' <= char_code(c) && char_code(c) <= 'Z' && (READtable->rt.rt_case==sKdowncase || READtable->rt.rt_case==sKinvert)) c = code_char(char_code(c) + ('a' - 'A')); } else if (char_code(c) == ':') { if (colon_type == 0) { colon_type = 1; colon = length; } else if (colon_type == 1 && colon == length-1) colon_type = 2; else colon_type = -1; /* Colon has appeared twice. */ } } } if (preserving_whitespace_flag || cat(c) != cat_whitespace) unread_char(c, in); M: if (READsuppress) { token->st.st_fillp = length; vs_reset; return(Cnil); } if (ilf && !escape_flag && length == 1 && token->st.st_self[0] == '.') { dot_flag = TRUE; vs_reset; return(Cnil); } else if (!escape_flag && length > 0) { for (i = 0; i < length; i++) if (token->st.st_self[i] != '.') goto N; FEerror("Dots appeared illegally.", 0); } N: token->st.st_fillp = length; if (escape_flag || (READbase<=10 && token_buffer[0]>'9')) goto SYMBOL; null_terminate_token(); x = parse_number(token_buffer, READbase); if (x != OBJNULL) { vs_reset; return(x); } SYMBOL: if (colon_type == 1 /* && length > colon + 1 */) { if (colon == 0) p = keyword_package; else { token->st.st_fillp = colon; p = find_package(token); if (p == Cnil) { vs_push(copy_simple_string(token)); FEerror("There is no package with the name \"~A\".", 1, vs_head); } } for (i = colon + 1; i < length; i++) token_buffer[i - (colon + 1)] = token_buffer[i]; token->st.st_fillp = length - (colon + 1); if (colon > 0) { x = find_symbol(token, p); if (intern_flag != EXTERNAL) { vs_push(copy_simple_string(token)); FEerror("Cannot find the external symbol ~A in ~S.", 2, vs_head, p); /* no need to push a package */ } vs_reset; return(x); } } else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) { token->st.st_fillp = colon; p = find_package(token); if (p == Cnil) { vs_push(copy_simple_string(token)); FEerror("There is no package with the name \"~A\".", 1, vs_head); } for (i = colon + 2; i < length; i++) token_buffer[i - (colon + 2)] = token_buffer[i]; token->st.st_fillp = length - (colon + 2); } else p = current_package(); /* loose package is an empty token following a non-beginning colon with no escape, to allow for ||*/ if (!token->st.st_fillp && colon && !escape_flag) { LP=p; goto BEGIN; } /* unless package specified for this symbol, use loose package if present */ if (PP0>P0 && !colon_type) p=PP0[-1]; vs_push(p); x = intern(token, p); vs_push(x); if (x->s.s_self == token_buffer) { {BEGIN_NO_INTERRUPT; x->s.s_self = alloc_relblock(token->st.st_fillp); for (i = 0; i < token->st.st_fillp; i++) x->s.s_self[i] = token_buffer[i]; END_NO_INTERRUPT;} } vs_reset; return(x); } static void Lleft_parenthesis_reader() { object in, x; object *p; check_arg(2); in = vs_base[0]; vs_top=vs_base+1; p = &vs_head; for (;;) { delimiting_char = code_char(')'); in_list_flag = TRUE; if ((x=read_object(in))==OBJNULL) { *p=Cnil; break; } if (dot_flag) { if (p==&vs_head) READER_ERROR(in,"A dot appeared after a left parenthesis."); delimiting_char = code_char(')'); in_list_flag = TRUE; *p=SAFE_CDR(read_object(in)); if (dot_flag) READER_ERROR(in,"Two dots appeared consecutively."); if (*p==OBJNULL) READER_ERROR(in,"Object missing after dot."); delimiting_char = code_char(')'); in_list_flag = TRUE; if (read_object(in)!=OBJNULL) READER_ERROR(in,"Two objects after dot."); break; } collect(p,make_cons(x,Cnil)); } } /* Read_string(delim, in) reads a simple string terminated by character code delim and places it in token. Delim is not included in the string but discarded. */ static void read_string(delim, in) int delim; object in; { int i; object c; i = 0; for (;;) { c = read_char(in); if (char_code(c) == delim) break; else if (cat(c) == cat_single_escape) c = read_char(in); if (i >= token->st.st_dim) too_long_token(); token_buffer[i++] = char_code(c); } token->st.st_fillp = i; } /* Read_constituent(in) reads a sequence of constituent characters from stream in and places it in token_buffer. */ static void read_constituent(in) object in; { int i, j; object c; i = 0; for (;;) { read_char_to(c,in,goto FIN); if (cat(c) != cat_constituent) { unread_char(c, in); break; } j = char_code(c); token_buffer[i++] = j; } FIN: token->st.st_fillp = i; } static void Ldouble_quote_reader() { check_arg(2); vs_popp; read_string('"', vs_base[0]); vs_base[0] = copy_simple_string(token); } static void Ldispatch_reader() { object c, x; int i, j; object in; check_arg(2); in = vs_base[0]; c = vs_base[1]; if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL) FEerror("~C is not a dispatching macro character", 1, c); for (i=0;ist.st_dim;i++) { c=read_char(in); j=char_code(c); if (digitp(j,10)<0) break; token->st.st_self[i]=j; } if (i==token->st.st_dim) FEerror("Dispatch number too long", 0); if (i) { token->st.st_fillp=i; null_terminate_token(); x=parse_number(token->st.st_self,10); if (x == OBJNULL) FEerror("Cannot parse the dispatch macro number.", 0); } else x=Cnil; vs_push(x); x = READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)]; vs_base[1] = c; super_funcall(x); } static void Lsingle_quote_reader() { check_arg(2); vs_base[0] = list(2,sLquote,read_object(vs_base[0])); vs_top=vs_base+1; } static void Lright_parenthesis_reader() { check_arg(2); vs_popp; vs_popp; /* no result */ } /* Lcomma_reader(){} */ static void Lsemicolon_reader() { object c; object str= vs_base[0]; check_arg(2); vs_popp; do { read_char_to(c,str, goto L); } while (char_code(c) != '\n'); L: vs_popp; vs_base[0] = Cnil; /* no result */ } /* Lbackquote_reader(){} */ /* sharpmacro routines */ static void extra_argument(int); static void Lsharp_C_reader() { object x, c; check_arg(3); if (vs_base[2] != Cnil && !READsuppress) extra_argument('C'); vs_popp; vs_popp; c = read_char(vs_base[0]); if (char_code(c) != '(') FEerror("A left parenthesis is expected.", 0); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x == OBJNULL) FEerror("No real part.", 0); vs_push(x); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x == OBJNULL) FEerror("No imaginary part.", 0); vs_push(x); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x != OBJNULL) FEerror("A right parenthesis is expected.", 0); if (READsuppress) vs_base[0]= Cnil ; else if (contains_sharp_comma(vs_base[1]) || contains_sharp_comma(vs_base[2])) { vs_base[0] = alloc_object(t_complex); vs_base[0]->cmp.cmp_real = vs_base[1]; vs_base[0]->cmp.cmp_imag = vs_base[2]; } else { check_type_number(&vs_base[1]); check_type_number(&vs_base[2]); vs_base[0] = make_complex(vs_base[1], vs_base[2]); } vs_top = vs_base + 1; } static void Lsharp_backslash_reader() { object c; check_arg(3); if (vs_base[2] != Cnil && !READsuppress) if (type_of(vs_base[2]) != t_fixnum || fix(vs_base[2]) != 0) FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]); /* assuming that CHAR-FONT-LIMIT is 1 */ vs_popp; vs_popp; unread_char(code_char('\\'), vs_base[0]); if (READsuppress) { (void)read_object(vs_base[0]); vs_base[0] = Cnil; return; } READsuppress = TRUE; (void)read_object(vs_base[0]); READsuppress = FALSE; c = token; if (c->s.s_fillp == 1) { vs_base[0] = code_char(c->ust.ust_self[0]); return; } if (string_equal(c, STreturn)) vs_base[0] = code_char('\r'); else if (string_equal(c, STspace)) vs_base[0] = code_char(' '); else if (string_equal(c, STrubout)) vs_base[0] = code_char('\177'); else if (string_equal(c, STpage)) vs_base[0] = code_char('\f'); else if (string_equal(c, STtab)) vs_base[0] = code_char('\t'); else if (string_equal(c, STbackspace)) vs_base[0] = code_char('\b'); else if (string_equal(c, STlinefeed) || string_equal(c, STnewline)) vs_base[0] = code_char('\n'); else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^') vs_base[0] = code_char(c->s.s_self[1] & 037); else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) { int i, n; for (n = 0, i = 1; i < c->s.s_fillp; i++) if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i]) FEerror("Octal digit expected.", 0); else n = 8*n + c->s.s_self[i] - '0'; vs_base[0] = code_char(n & 0377); } else FEerror("~S is an illegal character name.", 1, c); } static void Lsharp_single_quote_reader() { check_arg(3); if(vs_base[2] != Cnil && !READsuppress) extra_argument('#'); vs_base[0] = list(2,sLfunction,read_object(vs_base[0])); vs_top=vs_base+1; } #define QUOTE 1 #define EVAL 2 #define LIST 3 #define LISTA 4 #define APPEND 5 #define NCONC 6 object siScomma; static void Lsharp_left_parenthesis_reader() { int dim=0; int dimcount; object in, x; int a; object *vsp; check_arg(3); if (vs_base[2] == Cnil || READsuppress) dim = -1; else if (type_of(vs_base[2]) == t_fixnum) dim = fix(vs_base[2]); vs_popp; vs_popp; in = vs_base[0]; if (backq_level > 0) { unreadc_stream('(', in); vs_push(read_object(in)); a = backq_car(vs_base[1]); if (a == APPEND || a == NCONC) FEerror(",at or ,. has appeared in an illegal position.", 0); if (a == QUOTE) { vsp = vs_top; dimcount = 0; for (x = vs_base[2]; !endp(x); x = x->c.c_cdr) { vs_check_push(x->c.c_car); dimcount++; } goto L; } vs_base[0]=list(4,siScomma,sLapply,list(2,sLquote,sLvector),vs_base[2]); vs_top=vs_base+1; return; } vsp = vs_top; dimcount = 0; for (;;) { delimiting_char = code_char(')'); x = read_object(in); if (x == OBJNULL) break; vs_check_push(x); dimcount++; } L: if (dim >= 0) { if (dimcount > dim) FEerror("Too many elements in #(...).", 0); else { if (dimcount == 0) FEerror("Cannot fill the vector #().", 0); x = vs_head; for (; dimcount < dim; dimcount++) vs_push(x); } } {BEGIN_NO_INTERRUPT; x = alloc_simple_vector(dimcount, aet_object); vs_push(x); x->v.v_self = (object *)alloc_relblock(dimcount * sizeof(object)); vs_popp; for (dim = 0; dim < dimcount; dim++) x->v.v_self[dim] = vsp[dim]; vs_top = vs_base; END_NO_INTERRUPT;} vs_push(x); } static void Lsharp_asterisk_reader() { int dim=0; int dimcount; object in, x; object *vsp; check_arg(3); if (READsuppress) { read_constituent(vs_base[0]); vs_popp; vs_popp; vs_base[0] = Cnil; return; } if (vs_head == Cnil) dim = -1; else if (type_of(vs_head) == t_fixnum) dim = fix(vs_head); vs_popp; vs_popp; in = vs_head; vsp = vs_top; dimcount = 0; for (;;) { if (stream_at_end(in)) break; x = read_char(in); if (char_code(x) != '0' && char_code(x) != '1') { unread_char(x, in); break; } vs_check_push(x); dimcount++; } if (dim >= 0) { if (dimcount > dim) FEerror("Too many elements in #*....", 0); else { if (dimcount == 0) error("Cannot fill the bit-vector #*."); x = vs_head; for (; dimcount < dim; dimcount++) vs_push(x); } } {BEGIN_NO_INTERRUPT; x = alloc_simple_bitvector(dimcount); vs_push(x); x->bv.bv_self = alloc_relblock((dimcount + 7)/8); vs_popp; for (dim = 0; dim < dimcount; dim++) if (char_code(vsp[dim]) == '0') x->bv.bv_self[dim/8] &= ~(0200 >> dim%8); else x->bv.bv_self[dim/8] |= 0200 >> dim%8; END_NO_INTERRUPT;} vs_top = vs_base; vs_push(x); } static void Lsharp_colon_reader() { object in; int length; object c; enum chattrib a; if (vs_base[2] != Cnil && !READsuppress) extra_argument(':'); vs_popp; vs_popp; in = vs_base[0]; c = read_char(in); a = cat(c); escape_flag = FALSE; length = 0; tok_leng=0; goto L; for (;;) { if (length >= token->st.st_dim) too_long_token(); token_buffer[(tok_leng++,length++)] = char_code(c); K: if (stream_at_end(in)) goto M; c = read_char(in); a = cat(c); L: if (a == cat_single_escape) { c = read_char(in); a = cat_constituent; escape_flag = TRUE; } else if (a == cat_multiple_escape) { escape_flag = TRUE; for (;;) { if (stream_at_end(in)) end_of_stream(in); c = read_char(in); a = cat(c); if (a == cat_single_escape) { c = read_char(in); a = cat_constituent; } else if (a == cat_multiple_escape) break; if (length >= token->st.st_dim) too_long_token(); token_buffer[(tok_leng++,length++)] = char_code(c); } goto K; } else if ('a' <= char_code(c) && char_code(c) <= 'z') c = code_char(char_code(c) - ('a' - 'A')); if (a == cat_whitespace || a == cat_terminating) break; } if (preserving_whitespace_flag || cat(c) != cat_whitespace) unread_char(c, in); M: if (READsuppress) { vs_base[0] = Cnil; return; } token->st.st_fillp = length; vs_base[0] = copy_simple_string(token); vs_base[0] = make_symbol(vs_base[0]); } static void Lsharp_dot_reader() { check_arg(3); if(vs_base[2] != Cnil && !READsuppress) extra_argument('.'); vs_popp; vs_popp; if (READsuppress) { read_object(vs_base[0]); vs_base[0] = Cnil; return; } vs_base[0] = read_object(vs_base[0]); vs_base[0] = ieval(vs_base[0]); } static void Lsharp_comma_reader() { check_arg(3); if(vs_base[2] != Cnil && !READsuppress) extra_argument(','); vs_popp; vs_popp; if (READsuppress) { read_object(vs_base[0]); vs_base[0] = Cnil; return; } vs_base[0] = read_object(vs_base[0]); vs_base[0] = ieval(vs_base[0]); } static void FFN(siLsharp_comma_reader_for_compiler)() { check_arg(3); if(vs_base[2] != Cnil && !READsuppress) extra_argument(','); vs_popp; vs_popp; if (READsuppress) { vs_base[0] = Cnil; return; } vs_base[0] = read_object(vs_base[0]); vs_base[0] = make_cons(siSsharp_comma, vs_base[0]); } static void Lsharp_B_reader() { if(vs_base[2] != Cnil && !READsuppress) extra_argument('B'); vs_popp; vs_popp; read_constituent(vs_base[0]); if (READsuppress) { vs_base[0] = Cnil; return; } null_terminate_token(); vs_base[0] = parse_number(token_buffer, 2); if (vs_base[0] == OBJNULL) FEerror("Cannot parse the #B readmacro.", 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) FEerror("The float ~S appeared after the #B readmacro.", 1, vs_base[0]); } static void Lsharp_O_reader() { if(vs_base[2] != Cnil && !READsuppress) extra_argument('O'); vs_popp; vs_popp; read_constituent(vs_base[0]); if (READsuppress) { vs_base[0] = Cnil; return; } null_terminate_token(); vs_base[0] = parse_number(token_buffer, 8); if (vs_base[0] == OBJNULL) FEerror("Cannot parse the #O readmacro.", 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) FEerror("The float ~S appeared after the #O readmacro.", 1, vs_base[0]); } static void Lsharp_X_reader() { if(vs_base[2] != Cnil && !READsuppress) extra_argument('X'); vs_popp; vs_popp; read_constituent(vs_base[0]); if (READsuppress) { vs_base[0] = Cnil; return; } null_terminate_token(); vs_base[0] = parse_number(token_buffer, 16); if (vs_base[0] == OBJNULL) FEerror("Cannot parse the #X readmacro.", 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) FEerror("The float ~S appeared after the #X readmacro.", 1, vs_base[0]); } static void Lsharp_R_reader() { int radix=0; check_arg(3); if (READsuppress) radix = 10; else if (type_of(vs_base[2]) == t_fixnum) { radix = fix(vs_base[2]); if (radix > 36 || radix < 2) FEerror("~S is an illegal radix.", 1, vs_base[2]); } else FEerror("No radix was supplied in the #R readmacro.", 0); vs_popp; vs_popp; read_constituent(vs_base[0]); if (READsuppress) { vs_base[0] = Cnil; return; } null_terminate_token(); vs_base[0] = parse_number(token_buffer, radix); if (vs_base[0] == OBJNULL) FEerror("Cannot parse the #R readmacro.", 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) FEerror("The float ~S appeared after the #R readmacro.", 1, vs_base[0]); } static void Lsharp_plus_reader(){} static void Lsharp_minus_reader(){} static void Lsharp_vertical_bar_reader() { int c; int level = 0; check_arg(3); if (vs_base[2] != Cnil && !READsuppress) extra_argument('|'); vs_popp; vs_popp; for (;;) { c = readc_stream(vs_base[0]); L: if (c == '#') { c = readc_stream(vs_base[0]); if (c == '|') level++; } else if (c == '|') { c = readc_stream(vs_base[0]); if (c == '#') { if (level == 0) break; else --level; } else goto L; } } vs_popp; vs_base[0] = Cnil; /* no result */ } static void Ldefault_dispatch_macro() { FEerror("The default dispatch macro signalled an error.", 0); } /* #$ fixnum returns a random-state with the fixnum as its content. */ static void Lsharp_dollar_reader() { object x; enum type tx; check_arg(3); if (vs_base[2] != Cnil && !READsuppress) extra_argument('$'); vs_popp; vs_popp; x = read_object(vs_base[0]); tx=type_of(x); vs_base[0] = alloc_object(t_random); init_gmp_rnd_state(&vs_base[0]->rnd.rnd_state); if (tx!=t_fixnum || fix(x)) { if (tx==t_fixnum) { if (vs_base[0]->rnd.rnd_state._mp_seed->_mp_size!=1) FEerror("Cannot make a random-state with the value ~S.",1, x); mpz_set_ui(vs_base[0]->rnd.rnd_state._mp_seed,fix(x)); } else { if (x->big.big_mpz_t._mp_size!=vs_base[0]->rnd.rnd_state._mp_seed->_mp_size) FEerror("Cannot make a random-state with the value ~S.",1, x); memcpy(vs_base[0]->rnd.rnd_state._mp_seed->_mp_d,x->big.big_mpz_t._mp_d, vs_base[0]->rnd.rnd_state._mp_seed->_mp_size*sizeof(*vs_base[0]->rnd.rnd_state._mp_seed->_mp_d)); } } } /* readtable routines */ static object copy_readtable(from, to) object from, to; { struct rtent *rtab; int i, j; vs_mark; {BEGIN_NO_INTERRUPT; if (to == Cnil) { to = alloc_object(t_readtable); to->rt.rt_self = NULL; to->rt.rt_case = sKupcase; /* For GBC not to go mad. */ vs_push(to); /* Saving for GBC. */ to->rt.rt_self = rtab = (struct rtent *) alloc_contblock(RTABSIZE * sizeof(struct rtent)); for (i = 0; i < RTABSIZE; i++) rtab[i] = from->rt.rt_self[i]; /* structure assignment */ } else rtab=to->rt.rt_self; for (i = 0; i < RTABSIZE; i++) if (from->rt.rt_self[i].rte_dtab != NULL) { rtab[i].rte_dtab = (object *) alloc_contblock(RTABSIZE * sizeof(object)); for (j = 0; j < RTABSIZE; j++) rtab[i].rte_dtab[j] = from->rt.rt_self[i].rte_dtab[j]; } to->rt.rt_case=from->rt.rt_case; vs_reset; END_NO_INTERRUPT;} return(to); } static object current_readtable() { object r; r = symbol_value(Vreadtable); if (type_of(r) != t_readtable) { Vreadtable->s.s_dbind = copy_readtable(standard_readtable,sLnil); FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r); } return(r); } @(defun read (&optional (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep &aux x) @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); if (recursivep == Cnil) preserving_whitespace_flag = FALSE; detect_eos_flag = TRUE; if (recursivep == Cnil) x = read_object_non_recursive(strm); else x = read_object_recursive(strm); if (x == OBJNULL) { if (eof_errorp == Cnil && recursivep == Cnil) @(return eof_value) end_of_stream(strm); } @(return x) @) @(static defun read_preserving_whitespace (&optional (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep &aux x) object c; @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); while (!stream_at_end(strm)) { c = read_char(strm); if (cat(c) != cat_whitespace) { unread_char(c, strm); goto READ; } } /* if (eof_errorp == Cnil && recursivep == Cnil) */ /* @(return eof_value) */ /* end_of_stream(strm); */ READ: if (recursivep == Cnil) preserving_whitespace_flag = TRUE; detect_eos_flag = TRUE; if (recursivep == Cnil) x = read_object_non_recursive(strm); else x = read_object_recursive(strm); if (x == OBJNULL) { if (eof_errorp == Cnil && recursivep == Cnil) @(return eof_value) end_of_stream(strm); } @(return x) @) @(defun read_delimited_list (d &optional (strm `symbol_value(sLAstandard_inputA)`) recursivep &aux l x) object *p; bool e; volatile object old_READcontext; volatile int old_backq_level=0; @ check_type_character(&d); if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); if (recursivep == Cnil) { old_READcontext=sSAsharp_eq_contextA->s.s_dbind; old_backq_level = backq_level; setup_READ(); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } } l = Cnil; p = &l; preserving_whitespace_flag = FALSE; /* necessary? */ for (;;) { delimiting_char = d; x = read_object_recursive(strm); if (x == OBJNULL) break; collect(p,make_cons(x,Cnil)); } if (recursivep == Cnil) { if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) l = patch_sharp(l); e = FALSE; L: frs_pop(); sSAsharp_eq_contextA->s.s_dbind=old_READcontext; backq_level = old_backq_level; if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } } @(return l) @) @(defun read_line (&optional (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep &aux c) int i; @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); if (stream_at_end(strm)) { if (eof_errorp == Cnil && recursivep == Cnil) @(return eof_value) else end_of_stream(strm); } i = 0; for (;;) { read_char_to(c,strm,c = Ct; goto FINISH); if (char_code(c) == '\n') { c = Cnil; break; } if (i >= token->st.st_dim-1) too_long_token(); token->st.st_self[i++] = char_code(c); } FINISH: #ifdef DOES_CRLF if (i > 0 && token->st.st_self[i-1] == '\r') i--; #endif token->st.st_fillp = i; /* no disadvantage to returning an adjustable string */ {object uu= copy_simple_string(token); /* uu->st.st_hasfillp=TRUE; uu->st.st_adjustable=TRUE; */ @(return uu c) } @) @(defun read_char (&optional (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep) @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); {object x ; read_char_to(x,strm,goto AT_EOF); @(return `x`) AT_EOF: if (eof_errorp == Cnil && recursivep == Cnil) @(return eof_value) else end_of_stream(strm); } @) @(defun unread_char (c &optional (strm `symbol_value(sLAstandard_inputA)`)) @ check_type_character(&c); if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); unread_char(c, strm); @(return Cnil) @) @(defun peek_char (&optional peek_type (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep) object c; @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); setup_READtable(); if (peek_type == Cnil) { if (stream_at_end(strm)) { if (eof_errorp == Cnil && recursivep == Cnil) @(return eof_value) else end_of_stream(strm); } c = read_char(strm); unread_char(c, strm); @(return c) } if (peek_type == Ct) { while (!stream_at_end(strm)) { c = read_char(strm); if (cat(c) != cat_whitespace) { unread_char(c, strm); @(return c) } } if (eof_errorp == Cnil) @(return eof_value) else end_of_stream(strm); } check_type_character(&peek_type); while (!stream_at_end(strm)) { c = read_char(strm); if (char_eq(c, peek_type)) { unread_char(c, strm); @(return c) } } if (eof_errorp == Cnil) @(return eof_value) else end_of_stream(strm); @) @(defun listen (&optional (strm `symbol_value(sLAstandard_inputA)`)) @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); if (listen_stream(strm)) @(return Ct) else @(return Cnil) @) @(defun read_char_no_hang (&optional (strm `symbol_value(sLAstandard_inputA)`) (eof_errorp Ct) eof_value recursivep) @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); if (stream_at_end(strm)) { if (eof_errorp == Cnil) @(return eof_value) else end_of_stream(strm); } if (!listen_stream(strm)) @(return Cnil) @(return `read_char(strm)`) @) @(defun clear_input (&optional (strm `symbol_value(sLAstandard_inputA)`)) @ if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); #ifdef LISTEN_FOR_INPUT while(listen_stream(strm)) {readc_stream(strm);} #endif @(return Cnil) @) @(defun parse_integer (strng &key start end (radix `make_fixnum(10)`) junk_allowed &aux x) int s, e, ep; @ check_type_string(&strng); get_string_start_end(strng, start, end, &s, &e); if (type_of(radix) != t_fixnum || fix(radix) < 2 || fix(radix) > 36) FEerror("~S is an illegal radix.", 1, radix); setup_READtable(); while (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]].rte_chattrib == cat_whitespace && s < e) s++; if (s >= e) { if (junk_allowed != Cnil) @(return Cnil `make_fixnum(s)`) else goto CANNOT_PARSE; } { char *q; while (token->st.st_dimst.st_self,strng->st.st_self+s,e-s); token->st.st_fillp=e-s; null_terminate_token(); x = parse_integer(token->st.st_self, &q, fix(radix)); ep=q-token->st.st_self; } if (x == OBJNULL) { if (junk_allowed != Cnil) @(return Cnil `make_fixnum(ep+s)`) else goto CANNOT_PARSE; } if (junk_allowed != Cnil) @(return x `make_fixnum(ep+s)`) for (s += ep ; s < e; s++) if (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]] .rte_chattrib != cat_whitespace) goto CANNOT_PARSE; @(return x `make_fixnum(e)`) CANNOT_PARSE: FEerror("Cannot parse an integer in the string ~S.", 1, strng); @) @(defun read_byte (binary_input_stream &optional eof_errorp eof_value) int c; @ check_type_stream(&binary_input_stream); if (stream_at_end(binary_input_stream)) { if (eof_errorp == Cnil) @(return eof_value) else end_of_stream(binary_input_stream); } c = readc_stream(binary_input_stream); @(return `make_fixnum(c)`) @) object read_byte1(strm,eof) object strm,eof; { if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (stream_at_end(strm)) return eof; return make_fixnum(readc_stream(strm)); } object read_char1(strm,eof) object strm,eof; { if (strm == Cnil) strm = symbol_value(sLAstandard_inputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (stream_at_end(strm)) return eof; return code_char(readc_stream(strm)); } @(defun copy_readtable (&optional (from `current_readtable()`) to) @ if (from == Cnil) { from = standard_readtable; if (to != Cnil) check_type_readtable(&to); to = copy_readtable(from, to); to->rt.rt_self['#'].rte_dtab['!'] = default_dispatch_macro; /* We must forget #! macro. */ @(return to) } check_type_readtable(&from); if (to != Cnil) check_type_readtable(&to); @(return `copy_readtable(from, to)`) @) LFD(Lreadtablep)() { check_arg(1); if (type_of(vs_base[0]) == t_readtable) vs_base[0] = Ct; else vs_base[0] = Cnil; } @(defun set_syntax_from_char (tochr fromchr &optional (tordtbl `current_readtable()`) fromrdtbl) int i; @ check_type_character(&tochr); check_type_character(&fromchr); check_type_readtable(&tordtbl); {BEGIN_NO_INTERRUPT; if (fromrdtbl == Cnil) fromrdtbl = standard_readtable; else check_type_readtable(&fromrdtbl); tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib; tordtbl->rt.rt_self[char_code(tochr)].rte_macro = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro; if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab) != NULL) { tordtbl->rt.rt_self[char_code(tochr)].rte_dtab = (object *) alloc_contblock(RTABSIZE * sizeof(object)); for (i = 0; i < RTABSIZE; i++) tordtbl->rt.rt_self[char_code(tochr)] .rte_dtab[i] = fromrdtbl->rt.rt_self[char_code(fromchr)] .rte_dtab[i]; } END_NO_INTERRUPT;} @(return Ct) @) @(defun set_macro_character (chr fnc &optional ntp (rdtbl `current_readtable()`)) int c; @ check_type_character(&chr); check_type_readtable(&rdtbl); c = char_code(chr); if (ntp != Cnil) rdtbl->rt.rt_self[c].rte_chattrib = cat_non_terminating; else rdtbl->rt.rt_self[c].rte_chattrib = cat_terminating; rdtbl->rt.rt_self[c].rte_macro = fnc; SGC_TOUCH(rdtbl); @(return Ct) @) @(defun get_macro_character (chr &optional (rdtbl `current_readtable()`)) object m; @ check_type_character(&chr); check_type_readtable(&rdtbl); if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro) == OBJNULL) @(return Cnil) if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib == cat_non_terminating) @(return m Ct) else @(return m Cnil) @) @(static defun make_dispatch_macro_character (chr &optional ntp (rdtbl `current_readtable()`)) int i; @ check_type_character(&chr); check_type_readtable(&rdtbl); {BEGIN_NO_INTERRUPT; if (ntp != Cnil) rdtbl->rt.rt_self[char_code(chr)].rte_chattrib = cat_non_terminating; else rdtbl->rt.rt_self[char_code(chr)].rte_chattrib = cat_terminating; rdtbl->rt.rt_self[char_code(chr)].rte_dtab = (object *) alloc_contblock(RTABSIZE * sizeof(object)); for (i = 0; i < RTABSIZE; i++) rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i] = default_dispatch_macro; rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader; END_NO_INTERRUPT;} @(return Ct) @) @(static defun set_dispatch_macro_character (dspchr subchr fnc &optional (rdtbl `current_readtable()`)) @ check_type_character(&dspchr); check_type_character(&subchr); check_type_readtable(&rdtbl); if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) FEerror("~S is not a dispatch character.", 1, dspchr); rdtbl->rt.rt_self[char_code(dspchr)] .rte_dtab[char_code(subchr)] = fnc; if ('a' <= char_code(subchr) && char_code(subchr) <= 'z') rdtbl->rt.rt_self[char_code(dspchr)] .rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc; @(return Ct) @) DEFUN_NEW("READTABLE-CASE",object,fLreadtable_case,LISP,1,1,NONE,OO,OO,OO,OO,(object rt),"") { check_type_readtable_no_default(&rt); RETURN1(rt->rt.rt_case); } DEFUN_NEW("SET-READTABLE-CASE",object,fSset_readtable_case,SI,2,2,NONE,OO,OO,OO,OO,(object rt,object cas),"") { check_type_readtable_no_default(&rt); if (cas!=sKupcase && cas!=sKdowncase && cas!=sKpreserve && cas!=sKinvert) TYPE_ERROR(cas,list(5,sLmember,sKupcase,sKdowncase,sKpreserve,sKinvert)); RETURN1(rt->rt.rt_case=cas); } @(static defun get_dispatch_macro_character (dspchr subchr &optional (rdtbl `current_readtable()`)) @ check_type_character(&dspchr); check_type_character(&subchr); check_type_readtable(&rdtbl); if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) FEerror("~S is not a dispatch character.", 1, dspchr); if (digitp(char_code(subchr),10) >= 0) @(return Cnil) else { object x=rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab[char_code(subchr)]; @(return `x==default_dispatch_macro ? Cnil : x`) } @) static object string_to_object(x) object x; { object in; vs_mark; in = fSmake_string_input_stream_int(x, 0, x->st.st_fillp); vs_push(in); preserving_whitespace_flag = FALSE; detect_eos_flag = FALSE; x = read_object_non_recursive(in); vs_reset; return(x); } LFD(siLstring_to_object)() { check_arg(1); check_type_string(&vs_base[0]); vs_base[0] = string_to_object(vs_base[0]); } static void FFN(siLstandard_readtable)() { check_arg(0); vs_push(standard_readtable); } static void extra_argument(c) int c; { FEerror("~S is an extra argument for the #~C readmacro.", 2, vs_base[2], code_char(c)); } #define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0) DEFVAR("*READ-DEFAULT-FLOAT-FORMAT*",sLAread_default_float_formatA, LISP,sLsingle_float,""); DEFVAR("*READ-BASE*",sLAread_baseA,LISP,make_fixnum(10),""); DEFVAR("*READ-SUPPRESS*",sLAread_suppressA,LISP,Cnil,""); void gcl_init_read() { struct rtent *rtab; object *dtab; int i; standard_readtable = alloc_object(t_readtable); enter_mark_origin(&standard_readtable); standard_readtable->rt.rt_self = rtab = (struct rtent *) alloc_contblock(RTABSIZE * sizeof(struct rtent)); for (i = 0; i < RTABSIZE; i++) { rtab[i].rte_chattrib = cat_constituent; rtab[i].rte_macro = OBJNULL; rtab[i].rte_dtab = NULL; } dispatch_reader = make_cf(Ldispatch_reader); enter_mark_origin(&dispatch_reader); rtab['\t'].rte_chattrib = cat_whitespace; rtab['\n'].rte_chattrib = cat_whitespace; rtab['\f'].rte_chattrib = cat_whitespace; rtab['\r'].rte_chattrib = cat_whitespace; rtab[' '].rte_chattrib = cat_whitespace; rtab['"'].rte_chattrib = cat_terminating; rtab['"'].rte_macro = make_cf(Ldouble_quote_reader); rtab['#'].rte_chattrib = cat_non_terminating; rtab['#'].rte_macro = dispatch_reader; rtab['\''].rte_chattrib = cat_terminating; rtab['\''].rte_macro = make_cf(Lsingle_quote_reader); rtab['('].rte_chattrib = cat_terminating; rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader); rtab[')'].rte_chattrib = cat_terminating; rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader); /* rtab[','].rte_chattrib = cat_terminating; rtab[','].rte_macro = make_cf(Lcomma_reader); */ rtab[';'].rte_chattrib = cat_terminating; rtab[';'].rte_macro = make_cf(Lsemicolon_reader); rtab['\\'].rte_chattrib = cat_single_escape; /* rtab['`'].rte_chattrib = cat_terminating; rtab['`'].rte_macro = make_cf(Lbackquote_reader); */ rtab['|'].rte_chattrib = cat_multiple_escape; /* rtab['|'].rte_macro = make_cf(Lvertical_bar_reader); */ default_dispatch_macro = make_cf(Ldefault_dispatch_macro); rtab['#'].rte_dtab = dtab = (object *)alloc_contblock(RTABSIZE * sizeof(object)); for (i = 0; i < RTABSIZE; i++) dtab[i] = default_dispatch_macro; dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader); dtab['\\'] = make_cf(Lsharp_backslash_reader); dtab['\''] = make_cf(Lsharp_single_quote_reader); dtab['('] = make_cf(Lsharp_left_parenthesis_reader); dtab['*'] = make_cf(Lsharp_asterisk_reader); dtab[':'] = make_cf(Lsharp_colon_reader); dtab['.'] = make_cf(Lsharp_dot_reader); dtab[','] = make_cf(Lsharp_comma_reader); dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader); dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader); dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader); dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader); /* dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader); dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader); */ dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER"); dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER"); dtab['='] = make_si_ordinary("SHARP-EQ-READER"); dtab['#'] = make_si_ordinary("SHARP-SHARP-READER"); dtab['+'] = make_cf(Lsharp_plus_reader); dtab['-'] = make_cf(Lsharp_minus_reader); /* dtab['<'] = make_cf(Lsharp_less_than_reader); */ dtab['|'] = make_cf(Lsharp_vertical_bar_reader); /* This is specific to this implimentation */ dtab['$'] = make_cf(Lsharp_dollar_reader); /* This is specific to this implimentation */ /* dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f'] = make_cf(Lsharp_whitespace_reader); dtab[')'] = make_cf(Lsharp_right_parenthesis_reader); */ gcl_init_backq(); sKupcase = make_keyword("UPCASE"); sKdowncase = make_keyword("DOWNCASE"); sKpreserve = make_keyword("PRESERVE"); sKinvert = make_keyword("INVERT"); standard_readtable->rt.rt_case=sKupcase; Vreadtable = make_special("*READTABLE*", copy_readtable(standard_readtable, Cnil)); Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!'] = default_dispatch_macro; /* We must forget #! macro. */ sKstart = make_keyword("START"); sKend = make_keyword("END"); sKradix = make_keyword("RADIX"); sKjunk_allowed = make_keyword("JUNK-ALLOWED"); READtable = symbol_value(Vreadtable); enter_mark_origin(&READtable); READdefault_float_format = 'F'; READbase = 10; READsuppress = FALSE; sSAsharp_eq_contextA->s.s_dbind=Cnil; siSsharp_comma = make_si_ordinary("#,"); enter_mark_origin(&siSsharp_comma); delimiting_char = OBJNULL; enter_mark_origin(&delimiting_char); detect_eos_flag = FALSE; in_list_flag = FALSE; dot_flag = FALSE; } void gcl_init_read_function() { make_function("READ", Lread); make_function("READ-PRESERVING-WHITESPACE", Lread_preserving_whitespace); make_function("READ-DELIMITED-LIST", Lread_delimited_list); make_function("READ-LINE", Lread_line); make_function("READ-CHAR", Lread_char); make_function("UNREAD-CHAR", Lunread_char); make_function("PEEK-CHAR", Lpeek_char); make_function("LISTEN", Llisten); make_function("READ-CHAR-NO-HANG", Lread_char_no_hang); make_function("CLEAR-INPUT", Lclear_input); make_function("PARSE-INTEGER", Lparse_integer); make_function("READ-BYTE", Lread_byte); make_function("COPY-READTABLE", Lcopy_readtable); make_function("READTABLEP", Lreadtablep); make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char); make_function("SET-MACRO-CHARACTER", Lset_macro_character); make_function("GET-MACRO-CHARACTER", Lget_macro_character); make_function("MAKE-DISPATCH-MACRO-CHARACTER", Lmake_dispatch_macro_character); make_function("SET-DISPATCH-MACRO-CHARACTER", Lset_dispatch_macro_character); make_function("GET-DISPATCH-MACRO-CHARACTER", Lget_dispatch_macro_character); make_si_function("SHARP-COMMA-READER-FOR-COMPILER", siLsharp_comma_reader_for_compiler); make_si_function("STRING-TO-OBJECT", siLstring_to_object); make_si_function("STANDARD-READTABLE", siLstandard_readtable); } object sSPinit; /* object */ /* read_fasl_vector1(in) */ /* object in; */ /* { */ /* int dimcount, dim; */ /* VOL object *vsp; */ /* object vspo; */ /* VOL object x; */ /* long i; */ /* bool e; */ /* object old_READtable; */ /* int old_READdefault_float_format; */ /* int old_READbase; */ /* int old_READsuppress; */ /* volatile object old_READcontext; */ /* int old_backq_level; */ /* /\* to prevent longjmp clobber *\/ */ /* i=(long)&vsp; */ /* i+=i; */ /* vsp=&vspo; */ /* old_READtable = READtable; */ /* old_READdefault_float_format = READdefault_float_format; */ /* old_READbase = READbase; */ /* old_READsuppress = READsuppress; */ /* old_READcontext=sSAsharp_eq_contextA->s.s_dbind; */ /* /\* BUG FIX by Toshiba *\/ */ /* vs_push(old_READtable); */ /* old_backq_level = backq_level; */ /* setup_standard_READ(); */ /* frs_push(FRS_PROTECT, Cnil); */ /* if (nlj_active) { */ /* e = TRUE; */ /* goto L; */ /* } */ /* while (readc_stream(in) != '#') */ /* ; */ /* while (readc_stream(in) != '(') */ /* ; */ /* vsp = vs_top; */ /* dimcount = 0; */ /* for (;;) { */ /* sSAsharp_eq_contextA->s.s_dbind=Cnil; */ /* backq_level = 0; */ /* delimiting_char = code_char(')'); */ /* preserving_whitespace_flag = FALSE; */ /* detect_eos_flag = FALSE; */ /* x = read_object(in); */ /* if (x == OBJNULL) */ /* break; */ /* vs_check_push(x); */ /* if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) */ /* x = vs_head = patch_sharp(x); */ /* dimcount++; */ /* } */ /* if(dimcount==1 && type_of(vs_head)==t_vector) */ /* {/\* new style where all read at once *\/ */ /* x=vs_head; */ /* goto DONE;} */ /* /\* old style separately sharped, and no %init *\/ */ /* {BEGIN_NO_INTERRUPT; */ /* x=alloc_simple_vector(dimcount,aet_object); */ /* vs_push(x); */ /* x->v.v_self */ /* = (object *)alloc_relblock(dimcount * sizeof(object)); */ /* END_NO_INTERRUPT;} */ /* for (dim = 0; dim < dimcount; dim++) */ /* {SGC_TOUCH(x); */ /* x->cfd.cfd_self[dim] = vsp[dim];} */ /* DONE: */ /* e = FALSE; */ /* L: */ /* frs_pop(); */ /* READtable = old_READtable; */ /* READdefault_float_format = old_READdefault_float_format; */ /* READbase = old_READbase; */ /* READsuppress = old_READsuppress; */ /* sSAsharp_eq_contextA->s.s_dbind=old_READcontext; */ /* backq_level = old_backq_level; */ /* if (e) { */ /* nlj_active = FALSE; */ /* unwind(nlj_fr, nlj_tag); */ /* } */ /* vs_top = (object *)vsp; */ /* return(x); */ /* } */ gcl-2.6.14/o/rel_hp300.c0000755000175000017500000001233314360276512013076 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #undef NSYMS #define NSYMS(hdr) count_symbols(&hdr,fp) #ifndef dprintf #define dprintf(a,b) #endif /* the routines other than relocate are also used in rsym.c */ #ifdef IN_RSYM #define temp_malloc malloc #else relocate() { char *where; { unsigned int new_value; where = the_start + relocation_info.r_address; switch(relocation_info.r_segment){ case RNOOP: goto DONT; case REXT: new_value = symbol_table[relocation_info. r_symbolnum].n_value; break; case RDATA: case RBSS: case RTEXT: new_value= (int)start_address; break; default: dprintf(relocation_info.r_address = %d, relocation_info.r_address); printf( "\nRel_Info {r_segment = %x, r_symbolnum= %x, r_address = %d} -- Ignored", relocation_info.r_segment, relocation_info.r_symbolnum, relocation_info.r_address); fflush(stdout); goto DONT; }; switch(relocation_info.r_length){ case 0: *( char *)where = new_value + *( char *) where; break; case 1: *( short *)where = new_value + *( short *) where; break; case 2: *( long *)where = new_value + *( long *) where; break; } DONT: ; } } #ifdef PRIVATE_FASLINK int faslink(faslfile, ldargstring) object faslfile, ldargstring; { struct exec tmpheader, faslheader; FILE *fp; TABL *table; char filename[MAXPATHLEN]; char ldargstr[MAXPATHLEN]; char stbfilename[32]; char tmpfilename[32]; char command[MAXPATHLEN * 2]; char buf[BUFSIZ], *p; int i, res; object tmpfile, data; object *old_vs_base = vs_base; object *old_vs_top = vs_top; coerce_to_filename(ldargstring, ldargstr); coerce_to_filename(faslfile, filename); /* Print out symbol table */ sprintf(stbfilename, "/tmp/stb%d", getpid()); fp = fopen(stbfilename, "w"); for(i = 0, p = (char *)&tmpheader; i < sizeof(struct exec); i++) *p++ = '\0'; tmpheader.a_magic.system_id = HP9000S200_ID; tmpheader.a_magic.file_type = RELOC_MAGIC; tmpheader.a_stamp = 2; fwrite(&tmpheader, sizeof(struct exec), 1, fp); table = c_table.ptable; for(i = 0; i < c_table.length; i++) { struct nlist_ nbuf; int len; char *string; unsigned int address; string =(*table)[i].string; address =(*table)[i].address; len = strlen(string); if (((strncmp(string,"_end", 4) == NULL) && (len == 4)) || ((strncmp(string,"_etext",6) == NULL) && (len == 6)) || ((strncmp(string,"_edata",6) == NULL) && (len == 6))) continue; nbuf.n_value = address; nbuf.n_type = N_ABS | N_EXT; nbuf.n_length = len; nbuf.n_almod = 0; nbuf.n_unused = 0; fwrite(&nbuf,sizeof(nbuf),1,fp); fwrite(string,len,1,fp); tmpheader.a_lesyms += sizeof(struct nlist_) + len; } fseek(fp,0,0); fwrite(&tmpheader, sizeof(struct exec), 1, fp); fclose(fp); sprintf(tmpfilename, "/tmp/fasl%d", getpid()); sprintf(command, "ld -r -o %s -x %s %s %s -h _edata -h _etext", tmpfilename, stbfilename, filename, ldargstr); if (system(command) != 0) FEerror("The linkage editor failed.", 0); unlink(stbfilename); faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); vs_push(faslfile); fp = faslfile->sm.sm_fp; fread(&faslheader, sizeof(faslheader), 1, fp); fseek(fp,RDATA_OFFSET(faslheader)+faslheader.a_drsize,0); { FILE *tmpfp; int fpthis,fpend; fpthis = ftell(fp); fseek(fp,0,2); fpend = ftell(fp); fseek(fp,fpthis,0); tmpfp = fopen(tmpfilename,"a+"); fseek(tmpfp,0,2); filecpy(tmpfp,fp,fpend-fpthis); fclose(tmpfp); } close_stream(faslfile); tmpfile = make_simple_string(tmpfilename); vs_push(tmpfile); res = fasload(tmpfile); unlink(tmpfilename); vs_base = old_vs_base; vs_top = old_vs_top; return(res); } #endif #endif count_symbols(phdr,fp) struct exec *phdr; FILE *fp; {int nsyms,i; fseek(fp,(int)(LESYM_OFFSET(*phdr)), 0); for(i = phdr->a_lesyms, nsyms = 0; i > 0; nsyms++) { struct syment tmp; fread((char *)&tmp, SYMESZ, 1, fp); i -= SYMESZ; fseek(fp,(int)tmp.n_length,1); i -= tmp.n_length; } return (nsyms); } #define READ_IN_STRING_TABLE(fp,size) \ read_in_string_table(fp,&fileheader,size,OUR_ALLOCA(size)) char * read_in_string_table(fp,pfileheader,string_size,buf) FILE *fp; struct exec *pfileheader; int string_size ; char *buf; { char *p,*ans; int slen,i,j; ans=p = buf; dprintf( string table leng = %d, string_size); fseek(fp,LESYM_OFFSET(*pfileheader), 0); for (i = pfileheader->a_lesyms,j=0; i > 0; i=i- slen-SYMESZ) { fseek(fp,SYMESZ, 1); slen = symbol_table[j++].n_length; fread(p,slen,1,fp); *((p)+slen) = '\0'; dprintf( p %s , p); dprintf( slen %d,slen); p += slen + 1; } return (ans); } gcl-2.6.14/o/sfasli.c0000755000175000017500000000600514360276512012662 0ustar cammcamm/* Copyright William Schelter. All rights reserved. */ #if !defined(HAVE_LIBBFD) && !defined(SPECIAL_RSYM) #error Need either BFD or SPECIAL_RSYM #endif #ifndef SPECIAL_RSYM /* Replace this with gcl's own hash structure at some point */ static int build_symbol_table_bfd(void) { int u,v; unsigned long pa; asymbol **q; bfd_init(); if (!(bself=bfd_openr(kcl_self,0))) FEerror("Cannot open self\n",0); if (!bfd_check_format(bself,bfd_object)) FEerror("I'm not an object",0); /* if (link_info.hash) */ /* bfd_link_hash_table_free(bself,link_info.hash); */ #ifdef HAVE_OUTPUT_BFD link_info.output_bfd = bfd_openw("/dev/null", bfd_get_target(bself)); #endif if (!(link_info.hash = bfd_link_hash_table_create (bself))) FEerror("Cannot make hash table",0); if (!bfd_link_add_symbols(bself,&link_info)) FEerror("Cannot add self symbols\n",0); if ((u=bfd_get_symtab_upper_bound(bself))<0) FEerror("Cannot get self's symtab upper bound",0); #ifdef HAVE_ALLOCA q=(asymbol **)alloca(u); #else q=(asymbol **)malloc(u); #endif if ((v=bfd_canonicalize_symtab(bself,q))<0) FEerror("Cannot canonicalize self's symtab",0); for (u=0;uname) continue; if (strncmp(q[u]->section->name,"*UND*",5) && !(q[u]->flags & BSF_WEAK)) continue; if ((c=(char *)strstr(q[u]->name,"@@"))) { *c=0; if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_TRUE,MY_BFD_TRUE,MY_BFD_TRUE))) FEerror("Cannot make new hash entry",0); h->type=bfd_link_hash_new; } else if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_FALSE,MY_BFD_FALSE,MY_BFD_TRUE)) && !(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_TRUE,MY_BFD_TRUE,MY_BFD_TRUE))) FEerror("Cannot make new hash entry",0); if (h->type!=bfd_link_hash_defined) { if (!q[u]->section) FEerror("Symbol ~S is missing section",1,make_simple_string(q[u]->name)); if (!my_plt(q[u]->name,&pa)) { /* printf("my_plt %s %p\n",q[u]->name,(void *)pa); */ if (q[u]->value && q[u]->value!=pa) FEerror("plt address mismatch", 0); else q[u]->value=pa; } if (q[u]->value) { h->type=bfd_link_hash_defined; h->u.def.value=q[u]->value+q[u]->section->vma; h->u.def.section=q[u]->section; } } if (c) { *c='@'; c=NULL; } } #ifndef HAVE_ALLOCA free(q); #endif return 0; } #endif /* special_rsym */ LFD(build_symbol_table)(void) { printf("Building symbol table for %s ..\n",kcl_self);fflush(stdout); #ifdef SPECIAL_RSYM #ifndef USE_DLOPEN load_self_symbols(); #endif #else build_symbol_table_bfd(); #endif } #ifndef _WIN32 int use_symbols(double d,...) { double d2; #ifndef DARWIN extern void sincos(double,double *,double *); sincos(d,&d,&d2); #else d=sin(d)+cos(d); d2=sin(d)+cos(d); #endif return (int)(d+d2); } #endif void gcl_init_sfasl() { #ifdef SFASL make_si_function("BUILD-SYMBOL-TABLE",build_symbol_table); #endif } gcl-2.6.14/o/nmul.c0000755000175000017500000000122114360276512012347 0ustar cammcamm#include "arith.h" extended_mul(a,b,c,h,l) unsigned int a,b,c, *h, *l; {unsigned int temph,templ,ah,al,i; ah=0; al=0; /* in case the shift by 32 does not zero an unsigned int.. we separate out the first step.*/ {if (b & 1) {temph=0;templ=a; ladd(temph,templ,ah,al);} /* printf("\n%d b=%d a=%d (%d:%d)",i,b,a,ah,al); */ b=b>>1; } i=1; while(b) {if (b & 1) {lshift(a,i,temph,templ); ladd(temph,templ,ah,al);} i++;b=b>>1; } ladd(0,c,ah,al); KCLNORMALIZE(ah,al); *h=ah;*l=al; } #ifndef VSSIZE try(h,d, h1,l1, qp, rp) unsigned int d, h, h1,l1,*qp, *rp; { extended_mul (h,d,h1,qp,rp); } #endif gcl-2.6.14/o/makefun.c0000755000175000017500000001506014360276512013030 0ustar cammcamm#include "include.h" #include "funlink.h" #define PADDR(i) ((void *)(sSPinit->s.s_dbind->fixa.fixa_self[Mfix(i)])) /* eg: MakeAfun(addr,F_ARGD(min,max,flags,ARGTYPES(a,b,c,d)),0); MakeAfun(addr,F_ARGD(2,3,NONE,ARGTYPES(OO,OO,OO,OO)),0); */ static int mv; object MakeAfun(object (*addr)(object,object), unsigned int argd, object data) { ufixnum at=F_TYPES(argd)>>F_TYPE_WIDTH; ufixnum ma=F_MIN_ARGS(argd); ufixnum xa=F_MAX_ARGS(argd); ufixnum rt=F_RESULT_TYPE(argd); int type = (F_ARG_FLAGS_P(argd,F_requires_fun_passed) ? t_closure : (!at&&!rt&&ma==xa&&!mv ? t_sfun : t_afun)); object x = alloc_object(type); x->sfn.sfn_name = Cnil; x->sfn.sfn_self = addr; x->sfn.sfn_argd = type==t_sfun ? ma : argd; if (type == t_closure) { x->cl.cl_env = 0; x->cl.cl_envdim=0;} x->sfn.sfn_data = data; return x; } static object fSmakefun(object sym, object (*addr) (/* ??? */), unsigned int argd) {object ans = MakeAfun(addr,argd, (sSPmemory && sSPmemory->s.s_dbind && type_of(sSPmemory->s.s_dbind)==t_cfdata) ? sSPmemory->s.s_dbind : 0); ans->sfn.sfn_name = sym; return ans; } /* static object */ /* ImakeClosure(object (*addr)(),int argd,int n,...) */ /* { object x = fSmakefun(Cnil,addr,argd); */ /* va_list ap; */ /* va_start(ap,n); */ /* IsetClosure(x,n,ap); */ /* va_end(ap); */ /* return x; */ /* } */ static void IsetClosure(object x, int n, va_list ap) { /* this will change so that we can allocate 'hunks' which will be little blocks the size of an array header say with only one header word. This will be more economical. Because of gc, we can't allocate relblock, it might move while in the closure. */ object *p; if (type_of(x) != t_closure) { FEerror("Not a closure",0);} if (x->cl.cl_envdim < n) {BEGIN_NO_INTERRUPT; x->cl.cl_env = (object *)alloc_relblock(n); x->cl.cl_envdim = n; END_NO_INTERRUPT; } p = x->cl.cl_env; while (--n >= 0) { *p++ = va_arg(ap,object); } } DEFUN_NEW("INITFUN",object,fSinitfun,SI,3,ARG_LIMIT,NONE,OO,OO,OO,OO, (object sym,object addr_ind,object argd,...), "Store a compiled function on SYMBOL whose body is in the VV array at \ INDEX, and whose argd descriptor is ARGD. If more arguments IND1, IND2,.. \ are supplied these are indices in the VV array for the environment of this \ closure.") { int nargs = F_NARGS(VFUN_NARGS) -3; va_list ap; object fun = fSmakefun(IisSymbol(sym),PADDR(addr_ind),Mfix(argd)); if (nargs > 0) { va_start(ap,argd); IsetClosure(fun,nargs,ap); while (--nargs >= 0) /* the things put in by IsetClosure were only the indices of the closure variables not the actual variables */ { fun->cl.cl_env[nargs]= (object) PADDR(fun->cl.cl_env[nargs]);} va_end(ap); } fSfset(sym,fun); return sym; } #include "apply_n.h" DEFUN_NEW("INITMACRO",object,fSinitmacro,SI,4,ARG_LIMIT,NONE,OO,OO,OO,OO,(object first,...), "Like INITFUN, but makes then sets the 'macro' flag on this symbol") {va_list ap; object res; int n = VFUN_NARGS; object *new; va_start(ap,first); COERCE_VA_LIST_NEW(new,first,ap,n); res= c_apply_n_f((void *)FFN(fSinitfun),n,new,3,ARG_LIMIT); va_end(ap); res->s.s_mflag = 1; return res; } DEFUN_NEW("SET-KEY-STRUCT",object,fSset_key_struct,SI,1,1,NONE,OO,OO,OO,OO,(object key_struct_ind), "Called inside the loader. The keystruct is set up in the file with \ indexes rather than the actual entries. We change these indices to \ the objects") { set_key_struct(PADDR(key_struct_ind),sSPmemory->s.s_dbind); return Cnil; } #define mcollect(top_,next_,val_) ({object _x=MMcons(val_,Cnil);\ if (top_==Cnil) top_=next_=_x; \ else next_=next_->c.c_cdr=_x;}) static void put_fn_procls(object sym,fixnum argd,fixnum oneval,object def,object rdef) { unsigned int atypes=F_TYPES(argd) >> F_TYPE_WIDTH; unsigned int minargs=F_MIN_ARGS(argd); unsigned int maxargs=F_MAX_ARGS(argd); unsigned int rettype=F_RESULT_TYPE(argd); unsigned int i; object ta=Cnil,na=Cnil; for (i=0;i>=F_TYPE_WIDTH) switch(maxargs!=minargs ? F_object : atypes & MASK_RANGE(0,F_TYPE_WIDTH)) { case F_object: mcollect(ta,na,def); break; case F_int: mcollect(ta,na,sLfixnum); break; case F_shortfloat: mcollect(ta,na,sLshort_float); break; case F_double_ptr: mcollect(ta,na,sLlong_float); break; default: FEerror("Bad sfn declaration",0); break; } if (maxargs!=minargs) mcollect(ta,na,sLA); putprop(sym,ta,sSproclaimed_arg_types); ta=na=Cnil; if (oneval) switch(rettype) { case F_object: ta=rdef; break; case F_int: ta=sLfixnum; break; case F_shortfloat: ta=sLshort_float; break; case F_double_ptr: ta=sLlong_float; break; default: FEerror("Bad sfn declaration",0); break; } else /* ta=MMcons(sLA,Cnil); */ ta=sLA; putprop(sym,ta,sSproclaimed_return_type); if (oneval) putprop(sym,Ct,sSproclaimed_function); } void SI_makefun(char *strg, void *fn, unsigned int argd) { object sym = make_si_ordinary(strg); fSfset(sym, fSmakefun(sym,fn,argd)); put_fn_procls(sym,argd,1,Ct,Ct); } void LISP_makefun(char *strg, void *fn, unsigned int argd) { object sym = make_ordinary(strg); fSfset(sym, fSmakefun(sym,fn,argd)); put_fn_procls(sym,argd,1,Ct,Ct); } void SI_makefunm(char *strg, void *fn, unsigned int argd) { object sym = make_si_ordinary(strg); mv=1; fSfset(sym, fSmakefun(sym,fn,argd)); mv=0; put_fn_procls(sym,argd,0,Ct,Ct); } void LISP_makefunm(char *strg, void *fn, unsigned int argd) { object sym = make_ordinary(strg); mv=1; fSfset(sym, fSmakefun(sym,fn,argd)); mv=0; put_fn_procls(sym,argd,0,Ct,Ct); } /* static object */ /* MakeClosure(int n,int argd,object data,object (*fn)(),...) */ /* { object x; */ /* va_list ap; */ /* x = alloc_object(t_closure); */ /* x->cl.cl_name = Cnil; */ /* x->cl.cl_self = fn; */ /* x->cl.cl_data = data; */ /* x->cl.cl_argd = argd; */ /* x->cl.cl_env = 0; */ /* x->cl.cl_env = (object *)alloc_contblock(n*sizeof(object)); */ /* x->cl.cl_envdim=n; */ /* va_start(ap,fn); */ /* { object *p = x->cl.cl_env; */ /* while (--n>= 0) */ /* { *p++ = va_arg(ap,object);} */ /* va_end(ap); */ /* } */ /* return x; */ /* } */ DEFUN_NEW("INVOKE",object,fSinvoke,SI,1,ARG_LIMIT,NONE,OO,OO,OO,OO,(object x), "Invoke a C function whose body is at INDEX in the VV array") { int (*fn)(); fn = (void *) PADDR(x); (*fn)(); return Cnil; } gcl-2.6.14/o/rel_u370aix.c0000755000175000017500000000462514360276512013451 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c */ print_rel(rel,sym) struct syment *sym; struct reloc *rel; {char tem[10]; printf(" (name = %s)",SYM_NAME(sym)); printf("{r_type=%d",rel->r_type); fflush(stdout); } #ifdef DEBUG #define describe_sym describe_sym1 describe_sym1(n) int n; {char *str; char tem[9]; struct syment *sym; sym= &symbol_table[n]; str = SYM_NAME(sym); if (debug == 0) return 1; printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); printf("symbol is (%s):\nsymbol_table[n]._n._n_name %d\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d " "\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", symbol_table[n]._n._n_name, symbol_table[n]._n._n_n._n_zeroes , symbol_table[n]._n._n_n._n_offset , symbol_table[n]._n._n_nptr[0] , symbol_table[n]._n._n_nptr[1] , symbol_table[n].n_value , symbol_table[n].n_scnum , symbol_table[n].n_type , symbol_table[n].n_sclass , symbol_table[n].n_numaux ); } #endif #define LONG_AT_ADDR(p) *((unsigned int *)p) #define STORE_LONG(p,val) (*((unsigned int *)p)) = (val) relocate() { char *where; int old_val,new_val; #ifdef DEBUG if (debug) {print_rel(&relocation_info,&symbol_table[relocation_info.r_symndx]); describe_sym(relocation_info.r_symndx);} #endif where = the_start + relocation_info.r_vaddr; dprintf (where has %x , *where); dprintf( at %x -->, where ); if (relocation_info.r_type == R_ABS) { dprintf( r_abs ,0); return; } old_val = LONG_AT_ADDR(where); switch(relocation_info.r_type) { int *q; case R_RELLONG: case R_DIR32: new_val= old_val + symbol_table[relocation_info.r_symndx].n_value; dprintf(new val r_dir32 %x , new_val); STORE_LONG(where,new_val); break; case R_PCRLONG: new_val = old_val - (int) start_address + symbol_table[relocation_info.r_symndx].n_value; dprintf( r_pcrlong new value = %x , new_val) STORE_LONG(where,new_val); break; default: fprintf(stderr, "%d: unsupported relocation type.", relocation_info.r_type); FEerror("The relocation type was unknown",0,0); } } gcl-2.6.14/o/prelink.c0000644000175000017500000000214614360276512013044 0ustar cammcamm#define NO_PRELINK_UNEXEC_DIVERSION #include "include.h" #if !defined(__MINGW32__) && !defined(__CYGWIN__) extern FILE *stdin __attribute__((weak)); extern FILE *stderr __attribute__((weak)); extern FILE *stdout __attribute__((weak)); #ifdef USE_READLINE #if defined(RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION) extern Function *rl_completion_entry_function __attribute__((weak)); #elif defined(RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T) extern rl_compentry_func_t *rl_completion_entry_function __attribute__((weak)); #else #error Unknown rl_completion_entry_function return type #endif #if defined(RL_READLINE_NAME_TYPE_CHAR) extern char *rl_readline_name __attribute__((weak)); #elif defined(RL_READLINE_NAME_TYPE_CONST_CHAR) extern const char *rl_readline_name __attribute__((weak)); #else #error Unknown rl_readline_name return type #endif #endif #endif void prelink_init(void) { my_stdin=stdin; my_stdout=stdout; my_stderr=stderr; #ifdef USE_READLINE my_rl_completion_entry_function_ptr=(void *)&rl_completion_entry_function; my_rl_readline_name_ptr=(void *)&rl_readline_name; #endif } gcl-2.6.14/o/nfunlink.c0000755000175000017500000002464214360276512013234 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #include "include.h" #include "funlink.h" int Rset; #define COSF(x) (bill.f = x , (object )(bill.p)) #define COERCE_F_TYPE(val, in_type,out_type) \ (in_type == out_type \ ? val \ :in_type == F_int \ ?(out_type == F_object ? make_fixnum((long)val) :\ out_type == F_double_ptr \ ?(object) (void *) & lf(make_longfloat((double)(long) val)) \ :out_type == F_shortfloat? COSF((float)(long)val) \ :(object) 0 ) \ :in_type == F_object \ ?(out_type == F_int ? (object)(void *) Mfix(val) \ :out_type == F_double_ptr ? (object)(void *) & lf(val)\ :out_type == F_shortfloat? COSF(Msf(val)) \ :(object) 0)\ :in_type == F_double_ptr \ ?(out_type == F_int ? (object)(void *)(long)*(double *)(void *)val \ :out_type == F_object ? make_longfloat(*(double *)(void *)val) \ :out_type == F_shortfloat? COSF(*(double *)(void *)val) \ :(object) 0) \ :in_type == F_shortfloat \ ?(out_type == F_int ? (object)(bill.p = val, (long) bill.f) \ :out_type == F_object ? make_shortfloat((bill.p=val,(double)(bill.f))) \ :out_type == F_double_ptr ? (object)(void *) \ &lf(make_longfloat((bill.p = val,bill.f))) \ :(object) 0) \ :(object)0) union {int i; float f; double d; void * p; } bill; /* static object coerce_df(object x) */ /* {if (type_of(x)==t_longfloat) return x; */ /* if (type_of(x)==t_shortfloat) return make_longfloat(Msf(x)); */ /* FEerror("Not of float type ~a" ,1,x); */ /* return Cnil; */ /* } */ /* static object */ /* Icall_proc(object fun_name, int link_desk, object (**link_loc) (/\* ??? *\/), va_list ap) */ /* { object fun,res; */ /* object (*fn)(); */ /* int nargs; */ /* unsigned int fargd ; */ /* used for laying out a call in the bad case. This could be static, but it would need gcprotecting, and saving at interrupts. */ /* object vec [64]; */ /* if (type_of(fun_name)!=t_symbol || fun_name->s.s_gfdef ==0 */ /* ) */ /* fun_name = IisFboundp(fun_name); */ /* if (fun_name->s.s_sfdef != NOT_SPECIAL || fun_name->s.s_mflag) */ /* FEinvalid_function(fun_name); */ /* fun = fun_name->s.s_gfdef; */ /* if (Rset == 0 || */ /* !( type_of(fun)==t_afun || type_of(fun)==t_closure)) */ /* goto GENERAL; */ /* fn = (void *) fun->sfn.sfn_self; */ /* fargd = fun->sfn.sfn_argd; */ /* if ( (F_ARG_FLAGS(fargd) & F_ARG_FLAGS(link_desk)) == F_ARG_FLAGS(fargd) */ /* && F_MIN_ARGS(fargd) <= F_MIN_ARGS(link_desk) */ /* && F_MAX_ARGS(fargd) >= F_MIN_ARGS(link_desk) */ /* && F_TYPES(fargd) == F_TYPES(link_desk)) */ /* { /\* do the link *\/ */ /* (void) vpush_extend(link_loc,sLAlink_arrayA->s.s_dbind); */ /* (void) vpush_extend(*link_loc,sLAlink_arrayA->s.s_dbind); */ /* *link_loc = fn;} */ /* make this call */ /* figure out the true number of args passed */ /* nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ? */ /* F_NARGS(VFUN_NARGS) : F_NARGS(link_desk)); */ /* {unsigned int atypes = (F_TYPES(link_desk) >> F_TYPE_WIDTH); */ /* unsigned int ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH); */ /* int i; */ /* object *new ; */ /* if (atypes==ftypes) */ /* { */ /* #ifdef MUST_COPY_VA_LIST */ /* new = vec; */ /* for (i=0; i < nargs ; i++) new[i] = va_arg(ap,object); */ /* #else */ /* new = (object *) ap; */ /* #endif */ /* } */ /* else */ /* { new = vec; */ /* for (i = 0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH, */ /* ftypes >>= F_TYPE_WIDTH) */ /* { int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); */ /* int ftyp = ftypes & MASK_RANGE(0,F_TYPE_WIDTH); */ /* object next = va_arg(ap,object); */ /* new [i] = COERCE_F_TYPE(next, atyp ,ftyp); */ /* }} */ /* res = c_apply_n(fn,nargs,new); */ /* { int lret_type = F_TYPES(link_desk) & MASK_RANGE(0,F_TYPE_WIDTH); */ /* int fret_type = F_TYPES(fargd) & MASK_RANGE(0,F_TYPE_WIDTH); */ /* return COERCE_F_TYPE(res,fret_type,lret_type); */ /* }} */ /* GENERAL: */ /* figure out the true number of args passed */ /* nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ? */ /* F_NARGS(VFUN_NARGS) : F_NARGS(link_desk)); */ /* { int atypes,i,restype; */ /* object res; */ /* object *base = vs_top; */ /* #define DEBUG */ /* #ifdef DEBUG */ /* bds_ptr oldbd = bds_top; */ /* frame_ptr oldctl = frs_top; */ /* #endif */ /* restype = F_RESULT_TYPE(link_desk); */ /* atypes = F_TYPES(link_desk)>> F_TYPE_WIDTH; */ /* vs_top+= nargs; */ /* for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) */ /* { object next = va_arg(ap,object); */ /* int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); */ /* base[i] = COERCE_F_TYPE(next,atyp,F_object);} */ /* res = IapplyVector(fun,nargs,base); */ /* vs_top = base; */ /* res = COERCE_F_TYPE(res,F_object,restype); */ /* #ifdef DEBUG */ /* if (oldctl != frs_top || oldbd != bds_top) */ /* FEerror("compiler error ? ",0 ); */ /* #endif */ /* return res; */ /* }} */ /* for making a link which calls a function returning a double */ /* static float */ /* Icall_proc_float(object fun_name, int link_desk, object (**link_loc) (/\* ??? *\/), va_list ap) */ /* { object val; */ /* val = Icall_proc(fun_name,link_desk,link_loc,ap); */ /* { union { void *p; */ /* float f;} bil; */ /* bil.p = val; */ /* return bil.f;} */ /* } */ #include "apply_n.h" object IapplyVector(object fun, int nargs, object *base) /* Call FUN a lisp object on NARGS which are loaded into an array starting at BASE. This pushes on the CallHist, and puts the args onto the arg stack, so that debuggers may examine them. It sets fcall.nvalues appropriately. */ { object res,*abase; int i; object *oldtop = vs_top; unsigned int atypes; if (oldtop == base) vs_top += nargs; else { object *b = base; int n = nargs; base = vs_top; vs_top +=n; while (--n>=0) { base[n] = b[n];}} vs_check; switch(type_of(fun)) { case t_closure: case t_afun: ihs_push_base(fun,base); ihs_check; VFUN_NARGS=nargs; fcall.fun = fun; if (nargs < F_MIN_ARGS(fun->sfn.sfn_argd)) FEtoo_few_arguments(base,vs_top); if (nargs > F_MAX_ARGS(fun->sfn.sfn_argd) && F_MAX_ARGS(fun->sfn.sfn_argd)) FEtoo_many_arguments(base,vs_top); atypes = F_TYPES(fun->sfn.sfn_argd) >> F_TYPE_WIDTH; if (atypes==0) {abase = base;} else { abase = vs_top; for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) { object next = base[i]; switch (atypes & MASK_RANGE(0,F_TYPE_WIDTH)) { case F_object: break; case F_int: ASSURE_TYPE(next,t_fixnum); next = COERCE_F_TYPE(next,F_object,F_int); break; case F_shortfloat: ASSURE_TYPE(next,t_shortfloat); next = COERCE_F_TYPE(next,F_object,F_shortfloat); break; case F_double_ptr: ASSURE_TYPE(next,t_longfloat); next = COERCE_F_TYPE(next,F_object,F_double_ptr); break; default: FEerror("cant get here!",0); } vs_push(next);} } res = c_apply_n_fun(fun,nargs,abase); res = COERCE_F_TYPE(res,F_RESULT_TYPE(fun->sfn.sfn_argd),F_object); if (F_ARG_FLAGS_P(fun->sfn.sfn_argd,F_caller_sets_one_val)) { fcall.nvalues = 1;} vs_top = oldtop; ihs_pop(); return res; break; default: vs_base = base; funcall(fun); fcall.nvalues = vs_top - vs_base; {int i = fcall.nvalues ; object *p = vs_top; object *b = &fcall.values[i]; vs_top = oldtop; if (i == 0) return sLnil; while(--i > 0) *(--b) = *(--p);} return vs_base[0]; break; } } /* use the following to define functions passing on the value stack, from ones on the C stack. Laref() { Iinvoke_c_function_from_value_stack(fLaref,F_ARGD(2,2,0,ARGTYPES(oo,io,oo,oo))); return; } */ void Iinvoke_c_function_from_value_stack(object (*f)(), int fargd) { int atypes = F_TYPES(fargd)>> F_TYPE_WIDTH; object *base = vs_base; int i; int nargs = vs_top - vs_base; object x[64],res; int min,max; min = F_MIN_ARGS(fargd); max = F_MAX_ARGS(fargd); if (nargs < min || nargs > max) { FEerror("Wrong number of args",0); } for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) { object next = base[i]; int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); if (atyp == F_object) x[i] = next; else if (atyp == F_int) { ASSURE_TYPE(next,t_fixnum); x[i] = COERCE_F_TYPE(next,F_object,F_int);} else if (atyp == F_shortfloat) { ASSURE_TYPE(next,t_shortfloat); x[i] = COERCE_F_TYPE(next,F_object,F_shortfloat);} else if (atyp == F_double_ptr) { ASSURE_TYPE(next,t_longfloat); x[i] = COERCE_F_TYPE(next,F_object,F_double_ptr);} else {FEerror("cant get here!",0);}} VFUN_NARGS = nargs; res = c_apply_n_f(f,nargs,x,min,max); res = COERCE_F_TYPE(res,F_RESULT_TYPE(fargd),F_object); base[0]=res; if (F_ARG_FLAGS_P(fargd,F_caller_sets_one_val)) { vs_top=base+ 1; } else { vs_top=base + fcall.nvalues; { int nn = fcall.nvalues; while (--nn > 0) { base[nn] = fcall.values[nn]; } } } vs_base=base; return; } #define TYPE_STRING(i) (i == F_object ? "object" : i == F_int ? "int" : i == F_double_ptr ? "double ptr" : "unknown") /* static int */ /* print_fargd(int fargd) */ /* { int i; */ /* int nargs = 7; */ /* unsigned int ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH); */ /* printf("minargs=%d,maxargs=%d, arg_types=(",F_MIN_ARGS(fargd), */ /* F_MAX_ARGS(fargd)); */ /* for (i = 0; i < F_MAX_ARGS(fargd) ; i++, ftypes >>= F_TYPE_WIDTH) */ /* {int ftyp = ftypes & MASK_RANGE(0,F_TYPE_WIDTH); */ /* printf(" %s,",TYPE_STRING(ftyp)); */ /* if (i >= nargs) { printf("...object.."); break;} */ /* } */ /* printf(") result_type=%s\n",TYPE_STRING(F_RESULT_TYPE(fargd))); */ /* fflush(stdout); */ /* return 0; */ /* } */ gcl-2.6.14/o/error.c0000755000175000017500000003117714360276512012542 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* error.c Errors */ #include #include #include "include.h" object siSuniversal_error_handler; object sSterminal_interrupt; void assert_error(const char *a,unsigned l,const char *f,const char *n) { if (!raw_image && core_end && core_end==sbrk(0)) FEerror("The assertion ~a on line ~a of ~a in function ~a failed: ~a",5, make_simple_string(a),make_fixnum(l), make_simple_string(f),make_simple_string(n),make_simple_string(strerror(errno))); else { emsg("The assertion %s on line %d of %s in function %s failed: %s",a,l,f,n,strerror(errno)); do_gcl_abort(); } } void terminal_interrupt(int correctable) { signals_allowed = sig_normal; ifuncall1(sSterminal_interrupt, correctable?Ct:Cnil); } static object ihs_function_name(object x) { object y; switch (type_of(x)) { case t_symbol: return(x); case t_cons: y = x->c.c_car; if (y == sLlambda) return(sLlambda); if (y == sSlambda_closure) return(sSlambda_closure); if (y == sSlambda_block || y == sSlambda_block_expanded) { x = x->c.c_cdr; if (type_of(x) != t_cons) return(sSlambda_block); return(x->c.c_car); } if (y == sSlambda_block_closure) { x = x->c.c_cdr; if (type_of(x) != t_cons) return(sSlambda_block_closure); x = x->c.c_cdr; if (type_of(x) != t_cons) return(sSlambda_block_closure); x = x->c.c_cdr; if (type_of(x) != t_cons) return(sSlambda_block_closure); x = x->c.c_cdr; if (type_of(x) != t_cons) return(sSlambda_block_closure); return(x->c.c_car); } /* a general special form */ if (y->s.s_sfdef != NOT_SPECIAL) return y; return(Cnil); case t_afun: case t_closure: case t_cfun: case t_sfun: case t_vfun: case t_cclosure: case t_gfun: return(x->cf.cf_name); default: return(Cnil); } } object ihs_top_function_name(ihs_ptr h) { object x; while (h >= ihs_org) { x = ihs_function_name(h->ihs_function); if (x != Cnil) return(x); h--; } return(Cnil); } static object Icall_gen_error_handler_ap(object ci,object cs,object en,object es,ufixnum n,va_list ap) { object *b; ufixnum i; n+=5; b=alloca(n*sizeof(*b)); b[0]= en; b[1]= ci; b[2] = ihs_top_function_name(ihs_top); b[3] = cs; b[4] = es; for (i=5;iihs_top ? ihs_top : p; return p; ILLEGAL: FEerror("~S is an illegal ihs index.", 1, x); return(NULL); } DEFUN_NEW("IHS-TOP",object,fSihs_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1(make_fixnum(ihs_top - ihs_org)); } DEFUN_NEW("IHS-FUN",object,fSihs_fun,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = get_ihs_ptr(x0)->ihs_function; RETURN1(x0); } DEFUN_NEW("IHS-VS",object,fSihs_vs,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = make_fixnum(get_ihs_ptr(x0)->ihs_base - vs_org); RETURN1(x0); } static frame_ptr get_frame_ptr(object x) { frame_ptr p; if (type_of(x) != t_fixnum) goto ILLEGAL; p = frs_org + fix(x); if (fix(x)==0) return p; p=pfrs_top ? frs_top : p; return p; ILLEGAL: FEerror("~S is an illegal frs index.", 1, x); return NULL; } DEFUN_NEW("FRS-TOP",object,fSfrs_top,SI ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(frs_top - frs_org))); } DEFUN_NEW("FRS-VS",object,fSfrs_vs,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = make_fixnum(get_frame_ptr(x0)->frs_lex - vs_org); RETURN1(x0); } DEFUN_NEW("FRS-BDS",object,fSfrs_bds,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = make_fixnum(get_frame_ptr(x0)->frs_bds_top - bds_org); RETURN1(x0); } DEFUN_NEW("FRS-CLASS",object,fSfrs_class,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { enum fr_class c; /* 1 args */ c = get_frame_ptr(x0)->frs_class; if (c == FRS_CATCH) x0 = sKcatch; else if (c == FRS_PROTECT) x0 = sKprotect; else if (c == FRS_CATCHALL) x0 = sKcatchall; else FEerror("Unknown frs class was detected.", 0); RETURN1(x0); } DEFUN_NEW("FRS-TAG",object,fSfrs_tag,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = get_frame_ptr(x0)->frs_val; RETURN1(x0); } DEFUN_NEW("FRS-IHS",object,fSfrs_ihs,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = make_fixnum(get_frame_ptr(x0)->frs_ihs - ihs_org); RETURN1(x0); } static bds_ptr get_bds_ptr(object x) { bds_ptr p; if (type_of(x) != t_fixnum) goto ILLEGAL; p = bds_org + fix(x); if (0 == fix(x)) return p; p=pbds_top ? bds_top : p; return p; ILLEGAL: FEerror("~S is an illegal bds index.", 1, x); return NULL; } DEFUN_NEW("BDS-TOP",object,fSbds_top,SI ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(bds_top - bds_org))); } DEFUN_NEW("BDS-VAR",object,fSbds_var,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = get_bds_ptr(x0)->bds_sym; RETURN1(x0); } DEFUN_NEW("BDS-VAL",object,fSbds_val,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = get_bds_ptr(x0)->bds_val; RETURN1(x0); } static object *get_vs_ptr(object x) { object *p; if (type_of(x) != t_fixnum) goto ILLEGAL; p = vs_org + fix(x); p=p=vs_top ? vs_top-1 : p; return p; ILLEGAL: FEerror("~S is an illegal vs index.", 1, x); return NULL; } DEFUN_NEW("VS-TOP",object,fSvs_top,SI ,0,0,NONE,OO,OO,OO,OO,(void),"") { object x; /* 0 args */ x = (make_fixnum(vs_top - vs_org)); RETURN1(x); } DEFUN_NEW("VS",object,fSvs,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ x0 = *get_vs_ptr(x0); RETURN1(x0); } DEFUN_NEW("SCH-FRS-BASE",object,fSsch_frs_base,SI ,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { frame_ptr x; ihs_ptr y; /* 2 args */ y = get_ihs_ptr(x1); for (x = get_frame_ptr(x0); x <= frs_top && x->frs_ihs < y; x++); if (x > frs_top) x0 = Cnil; else x0 = make_fixnum(x - frs_org); RETURN1(x0); } DEFUNM_NEW("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI ,3,3,NONE,OO,OO,OO,OO,(object tag,object x1,object x2),"") { frame_ptr fr; /* 3 args */ fr = frs_sch(tag); if (fr == NULL) FEerror("The tag ~S is missing.", 1, tag); if (x2 == Cnil) tag = x1; else tag = MMcons(tag, x1); unwind(fr,tag); RETURN0 ; } DEF_ORDINARY("UNIVERSAL-ERROR-HANDLER",sSuniversal_error_handler,SI ,"Redefined in lisp, this is the function called by the \ internal error handling mechanism. \ Args: (error-name correctable function-name \ continue-format-string error-format-string \ &rest args)"); DEFUN_NEW("UNIVERSAL-ERROR-HANDLER",object,fSuniversal_error_handler,SI ,5,F_ARG_LIMIT,NONE,OO,OO,OO,OO,(object x0,object x1,object x2,object x3,object error_fmt_string),"") { int i; /* 5 args */ for (i = 0; i < error_fmt_string->st.st_fillp; i++) fputc(error_fmt_string->st.st_self[i],stderr); printf("\nLisp initialization failed.\n"); do_gcl_abort(); RETURN1(x0); } void check_arg_failed(int n) { if (n 0; n--, x = x->c.c_cdr) if(endp(x)) FEerror("APPLY sent too few arguments to LAMBDA.", 0); } void ck_larg_exactly(int n, object x) { for(; n > 0; n--, x = x->c.c_cdr) if(endp(x)) FEerror("APPLY sent too few arguments to LAMBDA.", 0); if(!endp(x)) FEerror("APPLY sent too many arguments to LAMBDA.", 0); } void invalid_macro_call(void) { FEinvalid_macro_call(); } object wrong_type_argument(object typ, object obj) { FEwrong_type_argument(typ, obj); /* no return */ return(Cnil); } void illegal_declare(object form) { FEinvalid_form("~S is an illegal declaration form.", form); } void not_a_string_or_symbol(object x) { FEerror("~S is not a string or symbol.", 1, x); } void not_a_symbol(object obj) { /* FEinvalid_variable("~S is not a symbol.", obj); */ FEwrong_type_argument(sLsymbol,obj); } int not_a_variable(object obj) { FEinvalid_variable("~S is not a variable.", obj); return -1; } void illegal_index(object x, object i) { FEerror("~S is an illegal index to ~S.", 2, i, x); } void check_stream(object strm) { if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); } void vfun_wrong_number_of_args(object x) { FEerror("Expected ~S args but received ~S args",2, x,make_fixnum(VFUN_NARGS)); } void check_arg_range(int n, int m) { if (VFUN_NARGS < n) FEtoo_few_arguments(0,VFUN_NARGS); if (VFUN_NARGS > m) FEtoo_many_arguments(0,VFUN_NARGS); } DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,""); DEF_ORDINARY("CATCH",sKcatch,KEYWORD,""); DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,""); DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,""); DEF_ORDINARY("CONDITION",sLcondition,LISP,""); DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,""); DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,""); DEF_ORDINARY("ERROR",sLerror,LISP,""); DEF_ORDINARY("SIMPLE-ERROR",sLsimple_error,LISP,""); DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,""); DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,KEYWORD,""); DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,""); DEF_ORDINARY("DATUM",sKdatum,KEYWORD,""); DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,""); DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,""); DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,""); DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,""); DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,""); DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,""); DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,""); DEF_ORDINARY("STREAM",sKstream,KEYWORD,""); DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,""); DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,""); DEF_ORDINARY("PATHNAME",sKpathname,KEYWORD,""); DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,""); DEF_ORDINARY("NAME",sKname,KEYWORD,""); DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,""); DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,""); DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,""); DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,""); DEF_ORDINARY("OPERATION",sKoperation,KEYWORD,""); DEF_ORDINARY("OPERANDS",sKoperands,KEYWORD,""); DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,""); DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,""); DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,""); DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,""); DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,""); DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,""); DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,""); DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,""); DEF_ORDINARY("PATHNAME-ERROR",sLpathname_error,SI,""); DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,""); DEF_ORDINARY("WARNING",sLwarning,LISP,""); DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,""); DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,""); void gcl_init_error(void) { null_string = make_simple_string(""); enter_mark_origin(&null_string); } gcl-2.6.14/o/num_comp.c0000755000175000017500000001523414360276512013222 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Comparisons on numbers */ #define NEED_MP_H #include "include.h" #include "num_include.h" /* The value of number_compare(x, y) is -1 if x < y 0 if x = y 1 if x > y. If x or y is complex, 0 or 1 is returned. */ int number_compare(object x, object y) { int i; double dx, dy=0.0; vs_mark; switch (type_of(x)) { case t_fixnum: switch (type_of(y)) { case t_fixnum: if (fix(x) < fix(y)) return(-1); else if (fix(x) == fix(y)) return(0); else return(1); case t_bignum: i = big_sign(y); if (i < 0) return(1); else return(-1); case t_ratio: x = number_times(x, y->rat.rat_den); y = y->rat.rat_num; vs_push(x); i = number_compare(x, y); vs_reset; return(i); case t_shortfloat: dx = (double)(fix(x)); dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dx = (double)(fix(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: wrong_type_argument(sLnumber, y); } case t_bignum: switch (type_of(y)) { case t_fixnum: i = big_sign(x); if (i < 0) return(-1); else return(1); case t_bignum: return cmpii(MP(x),MP(y)); case t_ratio: x = number_times(x, y->rat.rat_den); y = y->rat.rat_num; vs_push(x); i = number_compare(x, y); vs_reset; return(i); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: wrong_type_argument(sLnumber, y); } case t_ratio: switch (type_of(y)) { case t_fixnum: case t_bignum: y = number_times(y, x->rat.rat_den); x = x->rat.rat_num; vs_push(y); i = number_compare(x, y); vs_reset; return(i); case t_ratio: vs_push(number_times(x->rat.rat_num,y->rat.rat_den)); vs_push(number_times(y->rat.rat_num,x->rat.rat_den)); i = number_compare(vs_top[-2], vs_top[-1]); vs_reset; return(i); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: wrong_type_argument(sLnumber, y); } case t_shortfloat: dx = (double)(sf(x)); goto LONGFLOAT0; case t_longfloat: dx = lf(x); LONGFLOAT0: switch (type_of(y)) { case t_fixnum: dy = (double)(fix(y)); goto LONGFLOAT; case t_bignum: case t_ratio: dy = number_to_double(y); goto LONGFLOAT; case t_shortfloat: dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto Y_COMPLEX; default: break; } LONGFLOAT: if (dx == dy) return(0); else if (dx < dy) return(-1); else return(1); Y_COMPLEX: if (number_zerop(y->cmp.cmp_imag)) if (number_compare(x, y->cmp.cmp_real) == 0) return(0); else return(1); else return(1); case t_complex: if (type_of(y) != t_complex) { if (number_zerop(x->cmp.cmp_imag)) if (number_compare(x->cmp.cmp_real, y) == 0) return(0); else return(1); else return(1); } if (number_compare(x->cmp.cmp_real, y->cmp.cmp_real) == 0 && number_compare(x->cmp.cmp_imag, y->cmp.cmp_imag) == 0 ) return(0); else return(1); default: FEwrong_type_argument(sLnumber, x); return(0); } } LFD(Lall_the_same)(void) { int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_number(&vs_base[i]); for (i = 1; i < narg; i++) if (number_compare(vs_base[i-1], vs_base[i]) != 0) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } vs_top = vs_base+1; vs_base[0] = Ct; } LFD(Lall_different)(void) { int narg, i, j; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); else if (narg == 1) { vs_base[0] = Ct; return; } for (i = 0; i < narg; i++) check_type_number(&vs_base[i]); for(i = 1; i < narg; i++) for(j = 0; j < i; j++) if (number_compare(vs_base[j], vs_base[i]) == 0) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } vs_top = vs_base+1; vs_base[0] = Ct; } static void Lnumber_compare(int s, int t) { int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) { check_type_or_rational_float(&vs_base[i]); if (gcl_isnan(vs_base[i])) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } } for (i = 1; i < narg; i++) if (s*number_compare(vs_base[i], vs_base[i-1]) < t) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } vs_top = vs_base+1; vs_base[0] = Ct; } LFD(Lmonotonically_increasing)(void) { Lnumber_compare( 1, 1); } LFD(Lmonotonically_decreasing)(void) { Lnumber_compare(-1, 1); } LFD(Lmonotonically_nondecreasing)(void) { Lnumber_compare( 1, 0); } LFD(Lmonotonically_nonincreasing)(void) { Lnumber_compare(-1, 0); } LFD(Lmax)(void) { object max; int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_or_rational_float(&vs_base[i]); for (i = 1, max = vs_base[0]; i < narg; i++) if (number_compare(max, vs_base[i]) < 0) max = vs_base[i]; vs_top = vs_base+1; vs_base[0] = max; } LFD(Lmin)(void) { object min; int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_or_rational_float(&vs_base[i]); for (i = 1, min = vs_base[0]; i < narg; i++) if (number_compare(min, vs_base[i]) > 0) min = vs_base[i]; vs_top = vs_base+1; vs_base[0] = min; } void gcl_init_num_comp(void) { make_function("=", Lall_the_same); make_function("/=", Lall_different); make_function("<", Lmonotonically_increasing); make_function(">", Lmonotonically_decreasing); make_function("<=", Lmonotonically_nondecreasing); make_function(">=", Lmonotonically_nonincreasing); make_function("MAX", Lmax); make_function("MIN", Lmin); } gcl-2.6.14/o/clxsocket.c0000755000175000017500000001060014360276512013374 0ustar cammcamm/* Copyright Massachusetts Institute of Technology 1988 */ /* * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived * systems. VMS and System V should plan to have their own version. * * This code was cribbed from lib/X/XConnDis.c. * Compile using * % cc -c socket.c -DUNIXCONN */ #include "include.h" #ifdef HAVE_X11 #undef PAGESIZE #undef MAXPATHLEN #ifndef NO_UNIXCONN #define UNIXCONN #endif #include #include #include #include #include #include #include #include #include #ifndef hpux #include #endif extern int errno; /* Certain (broken) OS's don't have this */ /* decl in errno.h */ #ifdef UNIXCONN #include #ifndef X_UNIX_PATH #ifdef hpux #define X_UNIX_PATH "/usr/spool/sockets/X11/" #define OLD_UNIX_PATH "/tmp/.X11-unix/X" #else /* hpux */ #define X_UNIX_PATH "/tmp/.X11-unix/X" #endif /* hpux */ #endif /* X_UNIX_PATH */ #endif /* UNIXCONN */ /* * Attempts to connect to server, given host and display. Returns file * descriptor (network socket) or 0 if connection fails. */ int connect_to_server (host, display) char *host; int display; { struct sockaddr_in inaddr; /* INET socket address. */ struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; int addrlen; /* length of address */ #ifdef UNIXCONN struct sockaddr_un unaddr; /* UNIX socket address. */ #endif extern char *getenv(); extern struct hostent *gethostbyname(); int fd; /* Network socket */ { #ifdef UNIXCONN if ((host[0] == '\0') || (strcmp("unix", host) == 0)) { /* Connect locally using Unix domain. */ unaddr.sun_family = AF_UNIX; (void) strcpy(unaddr.sun_path, X_UNIX_PATH); (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); addr = (struct sockaddr *) &unaddr; addrlen = strlen(unaddr.sun_path) + 2; /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { #ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ if (errno == ENOENT) { /* No such file or directory */ (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); addrlen = strlen(unaddr.sun_path) + 2; if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) return(-1); /* errno set by most recent system call. */ } else #endif /* hpux */ return(-1); /* errno set by system call. */ } } else #endif /* UNIXCONN */ { /* Get the statistics on the specified host. */ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { if ((host_ptr = gethostbyname(host)) == NULL) { /* No such host! */ errno = EINVAL; return(-1); } /* Check the address type for an internet host. */ if (host_ptr->h_addrtype != AF_INET) { /* Not an Internet host! */ errno = EPROTOTYPE; return(-1); } /* Set up the socket data. */ inaddr.sin_family = host_ptr->h_addrtype; #ifdef hpux (void) memcpy((char *)&inaddr.sin_addr, (char *)host_ptr->h_addr, sizeof(inaddr.sin_addr)); #else /* hpux */ (void) bcopy((char *)host_ptr->h_addr, (char *)&inaddr.sin_addr, sizeof(inaddr.sin_addr)); #endif /* hpux */ } else { inaddr.sin_family = AF_INET; } addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); inaddr.sin_port = display + X_TCP_PORT; inaddr.sin_port = htons(inaddr.sin_port); /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ return(-1); /* errno set by system call. */} /* make sure to turn off TCP coalescence */ #ifdef TCP_NODELAY { int mi = 1; setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); } #endif } /* * Changed 9/89 to retry connection if system call was interrupted. This * is necessary for multiprocessing implementations that use timers, * since the timer results in a SIGALRM. -- jdi */ while (connect(fd, addr, addrlen) == -1) { if (errno != EINTR) { (void) close (fd); return(-1); /* errno set by system call. */ } } } /* * Return the id if the connection succeeded. */ return(fd); } #endif gcl-2.6.14/o/external_funs.h0000755000175000017500000004505614360276512014274 0ustar cammcamm/* for file nfunlink.X */ extern object Icall_proc GPR((object fun_name, int link_desk, object (**link_loc) ( ), ...));; extern float Icall_proc_float GPR((object fun_name, int link_desk, object (**link_loc) ( ), ...));; extern object IapplyVector GPR((object fun, int nargs, object *base));; extern int Iinvoke_c_function_from_value_stack GPR((int f, int fargd));; /* for file alloc.X */ extern char *alloc_page GPR((int n));; extern void add_page_to_freelist GPR((char *p, struct typemanager *tm));; extern object alloc_object GPR((enum type t));; extern int grow_linear GPR((int old, int fract, int grow_min, int grow_max));; extern object make_cons GPR((object a, object d));; extern object on_stack_cons GPR((object x, object y));; extern void call_after_gbc_hook GPR((int t));; extern object fSallocated GPR((object typ));; extern char *alloc_contblock GPR((int n));; extern int insert_contblock GPR((char *p, int s));; extern int insert_maybe_sgc_contblock GPR((char *p, int s));; extern char *alloc_relblock GPR((int n));; extern int init_tm GPR((enum type t, char *name, int elsize, int nelts, int sgc));; extern int set_maxpage GPR((void));; extern int init_alloc GPR((void));; extern int cant_get_a_type GPR((void));; extern int siLallocate GPR((void));; extern int t_from_type GPR((object type));; extern object siSallocate_sgc GPR((object type, int min, int max, int free_percent));; extern object siSallocate_growth GPR((object type, int min, int max, int percent, int percent_free));; extern int siLallocated_pages GPR((void));; extern int siLmaxpage GPR((void));; extern int siLalloc_contpage GPR((void));; extern int siLncbpage GPR((void));; extern int siLmaxcbpage GPR((void));; extern int siLalloc_relpage GPR((void));; extern int siLnrbpage GPR((void));; extern int siLget_hole_size GPR((void));; extern int siLset_hole_size GPR((void));; extern int init_alloc_function GPR((void));; extern char *malloc GPR((int size));; extern void free GPR((void *ptr));; extern char *realloc GPR((char *ptr, int size));; extern char *calloc GPR((int nelem, int elsize));; extern int cfree GPR((char *ptr));; extern char *memalign GPR((int align, int size));; extern char *valloc GPR((int size));; /* for file array.X */ extern enum aelttype get_aelttype GPR((object x));; extern enum aelttype array_elttype GPR((object x));; extern char *array_address GPR((object x, int inc));; extern char *raw_aet_ptr GPR((object x, short int typ));; extern int gset GPR((char *p1, char *val, int n, int typ));; extern int copy_array_portion GPR((object x, object y, int i1, int i2, int n1));; extern int siLcopy_array_portion GPR((void));; extern int array_allocself GPR((object x, bool staticp, object dflt));; extern object aref GPR((object x, int index));; extern object aset GPR((object x, int index, object value));; extern object aref1 GPR((object v, int index));; extern object aset1 GPR((object v, int index, object val));; extern int displace GPR((object from, object to, object offset));; extern int undisplace GPR((object from));; extern int check_displaced GPR((object dlist, object orig, int newdim));; extern int adjust_displaced GPR((object x, int diff));; extern int setup_fillp GPR((object x, object fillp));; extern int siLmake_pure_array GPR((void));; extern int siLmake_vector GPR((void));; extern int Laref GPR((void));; extern int siLaset GPR((void));; extern int Larray_element_type GPR((void));; extern int Larray_rank GPR((void));; extern int Larray_dimension GPR((void));; extern int Larray_total_size GPR((void));; extern int Ladjustable_array_p GPR((void));; extern int siLdisplaced_array_p GPR((void));; extern int Lsvref GPR((void));; extern int siLsvset GPR((void));; extern int Larray_has_fill_pointer_p GPR((void));; extern int Lfill_pointer GPR((void));; extern int siLfill_pointer_set GPR((void));; extern int siLreplace_array GPR((void));; extern int siLaset_by_cursor GPR((void));; extern int init_array_function GPR((void));; /* for file assignment.X */ extern int setq GPR((object sym, object val));; extern int Fsetq GPR((object form));; extern int Fpsetq GPR((object arg));; extern int Lset GPR((void));; extern int siLfset GPR((void));; extern int Fmultiple_value_setq GPR((object form));; extern int Lmakunbound GPR((void));; extern int Lfmakunbound GPR((void));; extern int Fsetf GPR((object form));; extern int setf GPR((object place, object form));; extern int Fpush GPR((object form));; extern int Fpop GPR((object form));; extern int Fincf GPR((object form));; extern int Fdecf GPR((object form));; extern object clear_compiler_properties GPR((object sym, object code));; extern int siLclear_compiler_properties GPR((void));; extern int init_assignment GPR((void));; /* for file backq.X */ extern int kwote_cdr GPR((void));; extern int kwote_car GPR((void));; extern int backq_cdr GPR((object x));; extern int backq_car GPR((object x));; extern object backq GPR((object x));; extern int Lcomma_reader GPR((void));; extern int Lbackquote_reader GPR((void));; extern int init_backq GPR((void));; /* for file bcmp.X */ extern int bcmp GPR((char *s1, char *s2, int n));; /* for file bcopy.X */ extern void bcopy GPR((char *s1, char *s2, int n));; /* for file bds.X */ extern int bds_unwind GPR((bds_ptr new_bds_top));; /* for file big.X */ extern int bcopy_body GPR((GEN x, GEN y));; extern object make_integer GPR((GEN u));; extern object make_bignum GPR((GEN u));; extern int big_zerop GPR((object x));; extern int big_compare GPR((object x, object y));; extern object big_minus GPR((object x));; extern int gcopy_to_big GPR((GEN res, object x));; extern int add_int_big GPR((int i, object x));; extern int sub_int_big GPR((int i, object x));; extern int mul_int_big GPR((int i, object x));; extern int div_int_big GPR((int i, object x));; extern object big_plus GPR((object x, object y));; extern object big_times GPR((object x, object y));; extern int big_quotient_remainder GPR((object x0, object y0, object *qp, object *rp));; extern double big_to_double GPR((object x));; extern object normalize_big_to_object GPR((object x));; extern object copy_big GPR((object x));; extern object copy_to_big GPR((object x));; extern GEN powerii GPR((GEN x, GEN y));; extern int replace_copy1 GPR((GEN x, GEN y));; extern GEN replace_copy2 GPR((GEN x, GEN y));; extern int obj_replace_copy1 GPR((object x, GEN y));; extern GEN obj_replace_copy2 GPR((object x, GEN y));; extern GEN1 otoi GPR((object x));; extern object alloc_bignum_static GPR((int len));; extern GEN1 setq_io GPR((GEN x, object *all, object val));; extern GEN1 setq_ii GPR((GEN x, object *all, GEN val));; extern void isetq_fix GPR((GEN var, int s));; extern GEN icopy_bignum GPR((object a, GEN y));; extern GEN icopy_fixnum GPR((object a, GEN y));; /* for file bind.X */ extern int lambda_bind GPR((object *arg_top));; extern int bind_var GPR((object var, object val, object spp));; extern int illegal_lambda GPR((void));; extern object find_special GPR((object body, struct bind_temp *start, struct bind_temp *end));; extern object let_bind GPR((object body, struct bind_temp *start, struct bind_temp *end));; extern object letA_bind GPR((object body, struct bind_temp *start, struct bind_temp *end));; extern int parse_key GPR((object *base, bool rest, bool allow_other_keys, register int n, int __builtin_va_alist));; extern int check_other_key GPR((object l, int n, int __builtin_va_alist));; extern int parse_key_new GPR((int n, object *base, struct key *keys, ...));; extern int parse_key_rest GPR((object rest, int n, object *base, struct key *keys, ...));; extern int set_key_struct GPR((struct key *ks, object data));; extern int init_bind GPR((void));; /* for file bitop.X */ extern int get_mark_bit GPR((void));; extern int set_mark_bit GPR((void));; extern int get_set_mark_bit GPR((void));; /* for file block.X */ extern int Fblock GPR((object args));; extern int Freturn_from GPR((object args));; extern int Freturn GPR((object args));; extern int init_block GPR((void));; /* for file bzero.X */ extern int bzero GPR((char *b, int length));; /* for file catch.X */ extern int Fcatch GPR((object args));; extern int siLerror_set GPR((void));; extern int Funwind_protect GPR((object args));; extern int Fthrow GPR((object args));; extern int init_catch GPR((void));; /* for file cfun.X */ extern object make_cfun GPR((int (*self) ( ), object name, object data, char *start, int size));; extern object make_sfun GPR((object name, int (*self) ( ), int argd, object data));; extern object make_vfun GPR((object name, int (*self) ( ), int argd, object data));; extern object make_cclosure_new GPR((int (*self) ( ), object name, object env, object data));; extern object make_cclosure GPR((int (*self) ( ), object name, object env, object data, char *start, int size));; extern int siLmc GPR((void));; extern object MFsfun GPR((object sym, int (*self) ( ), int argd, object data));; extern int siLmfsfun GPR((void));; extern object MFvfun GPR((object sym, int (*self) ( ), int argd, object data));; extern int siLmfvfun GPR((void));; extern object MFvfun_key GPR((object sym, int (*self) ( ), int argd, object data, char *keys));; extern int siLmfvfun_key GPR((void));; extern object MFnew GPR((object sym, int (*self) ( ), object data));; extern int siLmf GPR((void));; extern object MF GPR((object sym, int (*self) ( ), char *start, int size, object data));; extern object MM GPR((object sym, int (*self) ( ), char *start, int size, object data));; extern int siLmm GPR((void));; extern object make_function GPR((char *s, int (*f) ( )));; extern object make_si_sfun GPR((char *s, int (*f) ( ), int argd));; extern object make_si_vfun1 GPR((char *s, int (*f) ( ), int argd));; extern object make_si_function GPR((char *s, int (*f) ( )));; extern object make_special_form GPR((char *s, int (*f) ( )));; extern int siLcompiled_function_name GPR((void));; extern int turbo_closure GPR((object fun));; extern int siLturbo_closure GPR((void));; extern int init_cfun GPR((void));; /* for file character.X */ extern int Lstandard_char_p GPR((void));; extern int Lgraphic_char_p GPR((void));; extern int Lstring_char_p GPR((void));; extern int Lalpha_char_p GPR((void));; extern int Lupper_case_p GPR((void));; extern int Llower_case_p GPR((void));; extern int Lboth_case_p GPR((void));; extern int digitp GPR((int i, int r));; extern int Ldigit_char_p GPR((void));; extern int Lalphanumericp GPR((void));; extern bool char_eq GPR((object x, object y));; extern int Lchar_eq GPR((void));; extern int Lchar_neq GPR((void));; extern int char_cmp GPR((object x, object y));; extern int Lchar_cmp GPR((int s, int t));; extern int Lchar_l GPR((void));; extern int Lchar_g GPR((void));; extern int Lchar_le GPR((void));; extern int Lchar_ge GPR((void));; extern bool char_equal GPR((object x, object y));; extern int Lchar_equal GPR((void));; extern int Lchar_not_equal GPR((void));; extern int char_compare GPR((object x, object y));; extern int Lchar_compare GPR((int s, int t));; extern int Lchar_lessp GPR((void));; extern int Lchar_greaterp GPR((void));; extern int Lchar_not_greaterp GPR((void));; extern int Lchar_not_lessp GPR((void));; extern object coerce_to_character GPR((object x));; extern int Lcharacter GPR((void));; extern int Lchar_code GPR((void));; extern int Lchar_bits GPR((void));; extern int Lchar_font GPR((void));; extern int Lcode_char GPR((void));; extern int Lmake_char GPR((void));; extern int Lchar_upcase GPR((void));; extern int Lchar_downcase GPR((void));; extern int digit_weight GPR((int w, int r));; extern int Ldigit_char GPR((void));; extern int Lchar_int GPR((void));; extern int Lint_char GPR((void));; extern int Lchar_name GPR((void));; extern int Lname_char GPR((void));; extern int Lchar_bit GPR((void));; extern int Lset_char_bit GPR((void));; extern int init_character GPR((void));; extern int init_character_function GPR((void));; /* for file cmpaux.X */ extern int siLspecialp GPR((void));; extern void siLdefvar1 GPR((void));; extern void siLdebug GPR((void));; extern void siLsetvv GPR((void));; extern int init_cmpaux GPR((void));; extern int ifloor GPR((int x, int y));; extern int imod GPR((int x, int y));; extern int set_VV_data GPR((object *VV, int n, object data, char *start, int size));; extern int set_VV GPR((object *VV, int n, object data));; extern char object_to_char GPR((object x));; extern int object_to_int GPR((object x));; extern float object_to_float GPR((object x));; extern double object_to_double GPR((object x));; extern char *object_to_string GPR((object x));; extern int call_init GPR((int init_address, object memory, object fasl_vec));; extern int do_init GPR((object *statVV));; extern void init_or_load1 GPR((int (*fn) ( ), char *file));; /* for file conditional.X */ extern int Fif GPR((object form));; extern int Fcond GPR((object args));; extern int Fcase GPR((object arg));; extern int Fwhen GPR((object form));; extern int Funless GPR((object form));; extern int init_conditional GPR((void));; /* for file earith.X */ extern int init_cmac GPR((void));; extern object signed_bignum2 GPR((int hi, int lo));; extern object fplus GPR((int a, int b));; extern object fminus GPR((int a, int b));; extern int dblrem GPR((int a, int b, int mod));; extern object cmod GPR((object x));; extern object ctimes GPR((object a, object b));; extern object cdifference GPR((object a, object b));; extern object cplus GPR((object a, object b));; extern void siLcmod GPR((void));; extern void siLcplus GPR((void));; extern void siLctimes GPR((void));; extern void siLcdifference GPR((void));; extern object memq GPR((register object a, register object b));; /* for file error.X */ extern int terminal_interrupt GPR((int correctable));; extern object ihs_function_name GPR((object x));; extern object ihs_top_function_name GPR((void));; extern int call_error_handler GPR((void));; extern int FEerror GPR((char *s, int num, object arg1, object arg2, object arg3, object arg4));; extern int FEwrong_type_argument GPR((object type, object value));; extern int FEtoo_few_arguments GPR((object *base, object *top));; extern int FEtoo_few_argumentsF GPR((object args));; extern int FEtoo_many_arguments GPR((object *base, object *top));; extern int FEtoo_many_argumentsF GPR((object args));; extern int FEinvalid_macro_call GPR((void));; extern int FEunexpected_keyword GPR((object key));; extern int FEinvalid_form GPR((char *s, object form));; extern int FEunbound_variable GPR((object sym));; extern int FEinvalid_variable GPR((char *s, object obj));; extern int FEundefined_function GPR((object fname));; extern int FEinvalid_function GPR((object obj));; extern int CEerror GPR((char *err_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4));; extern ihs_ptr get_ihs_ptr GPR((object x));; extern int siLihs_top GPR((void));; extern int siLihs_fun GPR((void));; extern int siLihs_vs GPR((void));; extern frame_ptr get_frame_ptr GPR((object x));; extern int siLfrs_top GPR((void));; extern int siLfrs_vs GPR((void));; extern int siLfrs_bds GPR((void));; extern int siLfrs_class GPR((void));; extern int siLfrs_tag GPR((void));; extern int siLfrs_ihs GPR((void));; extern bds_ptr get_bds_ptr GPR((object x));; extern int siLbds_top GPR((void));; extern int siLbds_var GPR((void));; extern int siLbds_val GPR((void));; extern object *get_vs_ptr GPR((object x));; extern int siLvs_top GPR((void));; extern int siLvs GPR((void));; extern int siLsch_frs_base GPR((void));; extern int siLinternal_super_go GPR((void));; extern int siLuniversal_error_handler GPR((void));; extern int check_arg_failed GPR((int n));; extern int too_few_arguments GPR((void));; extern int too_many_arguments GPR((void));; extern int ck_larg_at_least GPR((int n, object x));; extern int ck_larg_exactly GPR((int n, object x));; extern int invalid_macro_call GPR((void));; extern int keyword_value_mismatch GPR((void));; extern int not_a_keyword GPR((object x));; extern int unexpected_keyword GPR((object key));; extern object wrong_type_argument GPR((object typ, object obj));; extern int illegal_declare GPR((int form));; extern int not_a_symbol GPR((int obj));; extern int not_a_variable GPR((int obj));; extern int illegal_index GPR((object x, object i));; extern int Lerror GPR((void));; extern object LVerror GPR((int __builtin_va_alist));; extern int Lcerror GPR((void));; extern int vfun_wrong_number_of_args GPR((object x));; extern int init_error GPR((void));; /* for file eval.X */ extern int quick_call_sfun GPR((object fun));; extern int call_sfun_no_check GPR((object fun));; extern int call_vfun GPR((object fun));; extern int funcall GPR((object fun));; extern int funcall_no_event GPR((object fun));; extern int lispcall GPR((object *funp, int narg));; extern int lispcall_no_event GPR((object *funp, int narg));; extern int symlispcall GPR((object sym, object *base, int narg));; extern int symlispcall_no_event GPR((object sym, object *base, int narg));; extern object simple_lispcall GPR((object *funp, int narg));; extern object simple_lispcall_no_event GPR((object *funp, int narg));; extern object simple_symlispcall GPR((object sym, object *base, int narg));; extern object simple_symlispcall_no_event GPR((object sym, object *base, int narg));; extern int super_funcall GPR((object fun));; extern int super_funcall_no_event GPR((object fun));; extern int eval GPR((object form));; extern int call_applyhook GPR((object fun));; extern int Lfuncall GPR((void));; extern int Lapply GPR((void));; extern int Leval GPR((void));; extern int Levalhook GPR((void));; extern int Lapplyhook GPR((void));; extern int Lconstantp GPR((void));; extern object ieval GPR((object x));; extern object ifuncall1 GPR((object fun, object arg1));; extern object ifuncall2 GPR((object fun, object arg1, object arg2));; extern object ifuncall3 GPR((object fun, object arg1, object arg2, object arg3));; extern int funcall_with_catcher GPR((object fname, object fun));; extern object fcalln_cclosure GPR((...));; extern object fcalln_general GPR((...));; extern object fcalln_vfun GPR((va_list vl));; extern object fcalln GPR((int __builtin_va_alist));; extern object funcall_cfun GPR((funcvoid fn, int n, int __builtin_va_alist));; extern int init_eval GPR((void));; gcl-2.6.14/o/strcspn.c0000755000175000017500000000046514360276512013101 0ustar cammcammsize_t strcspn(const char *s1, const char *s2) { register char *scan1; register char *scan2; register int count; count = 0; for (scan1 = s1; *scan1 != '\0'; scan1++) { for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ if (*scan1 == *scan2++) return(count); count++; } return(count); } gcl-2.6.14/o/bitop.c0000755000175000017500000000124514360276512012517 0ustar cammcamm#include "include.h" /* static void */ /* get_mark_bit(void) */ /* {error("get_mark_bit called");} */ /* static void */ /* set_mark_bit(void) */ /* {error("set_mark_bit called");} */ /* static void */ /* get_set_mark_bit(void) */ /* {error("get_set_mark_bit called");} */ /* These have all been replaced by macros extern int *mark_table; static get_mark_bit(x) int x; { int y; y = (*(mark_table+(x/4/32)) >> (x/4%32)) & 1; return(y); } static set_mark_bit(x) int x; { int y; y = 1 << (x/4%32); y = (*(mark_table+(x/4/32))) | y; *(mark_table+ (x/4/32))=y; } static get_set_mark_bit(x) int x; { int y; y = get_mark_bit(x); set_mark_bit(x); return(y); } */ gcl-2.6.14/o/bzero.c0000755000175000017500000000014714360276512012523 0ustar cammcamm#include void bzero(void *b, size_t length) { char *c=b; while(length-->0) *c++ = 0; } gcl-2.6.14/o/cmpaux.c0000755000175000017500000003123514360276512012701 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* cmpaux.c */ #include #include #include #include #include #define NEED_MP_H #include "include.h" #define dcheck_type(a,b) check_type(a,b) #include "page.h" #ifdef HAVE_AOUT #undef ATT #undef BSD #ifndef HAVE_ELF #ifndef HAVE_FILEHDR #define BSD #endif #endif #include HAVE_AOUT #endif DEFUNO_NEW("SPECIALP",object,fSspecialp,SI ,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"") { /* 1 args */ if (type_of(sym) == t_symbol && (enum stype)sym->s.s_stype == stp_special) sym = Ct; else sym = Cnil; RETURN1(sym); } DEF_ORDINARY("DEBUGGER",sSdebugger,SI,""); DEFUN_NEW("DEFVAR1",object,fSdefvar1,SI ,2,3,NONE,OO,OO,OO,OO,(object sym,object val,...),"") { int n=VFUN_NARGS; object doc; va_list ap; { va_start(ap,val); if (n>=3) doc=va_arg(ap,object);else goto LDEFAULT3; goto LEND_VARARG; LDEFAULT3: doc = Cnil; LEND_VARARG: va_end(ap);} CHECK_ARG_RANGE(2,3); if(sym->s.s_dbind==0 && n > 1) sym->s.s_dbind= val; sym->s.s_stype=(short)stp_special; if(n > 2) putprop(sym,doc,sSvariable_documentation); RETURN1(sym); } DEFUN_NEW("DEBUG",object,fLdebug,LISP ,2,2,NONE,OO,OO,OO,OO,(object sym,object val),"") { /* 2 args */ putprop(sym,val,sSdebugger); RETURN1(sym); } DEFUN_NEW("SETVV",object,fSsetvv,SI ,2,2,NONE,OO,OO,OO,OO,(object index,object val),"") { /* 2 args */ if(type_of(sSPmemory->s.s_dbind)==t_cfdata) sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val; else FEerror("setvv called outside %init",0); RETURN1(index); } DEF_ORDINARY("%MEMORY",sSPmemory,SI,""); DEF_ORDINARY("%INIT",sSPinit,SI,""); /* void Lidentity(void); */ void gcl_init_cmpaux(void) { /* real one defined in predlib.lsp, need this for bootstrap */ /* make_si_function("WARN-VERSION",Lidentity); */ } /* Now inlined directly by optimizer */ /* int */ /* ifloor(int x, int y) */ /* { */ /* if (y == 0) { */ /* FEerror("Zero divizor", 0); */ /* return 0; */ /* } */ /* if (y > 0) { */ /* if (x >= 0) */ /* return(x/y); */ /* else */ /* FIXME, deal with possible overflow here*/ /* return(-((-x-1))/y-1); */ /* } */ /* if (x >= 0) */ /* FIXME, deal with possible overflow here*/ /* return(-((x-1)/(-y))-1); */ /* else */ /* return((-x)/(-y)); */ /* } */ /* int */ /* imod(int x, int y) */ /* { */ /* return(x - ifloor(x, y)*y); */ /* } */ /* static void */ /* set_VV(object *, int, object); */ /* static void */ /* set_VV_data(object *VV, int n, object data, char *start, int size) */ /* {set_VV(VV,n,data); */ /* data->cfd.cfd_start=start; */ /* data->cfd.cfd_size = size; */ /* } */ /* static void */ /* set_VV(object *VV, int n, object data) */ /* { */ /* object *p, *q; */ /* p = VV; */ /* q = data->v.v_self; */ /* while (n-- > 0) */ /* *p++ = *q++; */ /* data->cfd.cfd_self = VV; */ /* } */ /* Conversions to C */ char object_to_char(object x) { int c=0; switch (type_of(x)) { case t_fixnum: c = fix(x); break; case t_bignum: {object *to = vs_top; vs_push(x); vs_push(small_fixnum(0xff)); Llogand(); x = vs_base[0]; vs_top = to; c = (char) fix(x); break; } case t_character: c = char_code(x); break; default: FEerror("~S cannot be coerce to a C char.", 1, x); } return(c); } int object_to_int(object x) { int i=0; switch (type_of(x)) { case t_character: i = char_code(x); break; case t_fixnum: i = fix(x); break; case t_bignum: i = number_to_double(x); break; case t_ratio: i = number_to_double(x); break; case t_shortfloat: i = sf(x); break; case t_longfloat: i = lf(x); break; default: FEerror("~S cannot be coerce to a C int.", 1, x); } return(i); } fixnum object_to_fixnum(object x) { fixnum i=0; switch (type_of(x)) { case t_character: i = char_code(x); break; case t_fixnum: i = fix(x); break; case t_bignum: i = number_to_double(x); break; case t_ratio: i = number_to_double(x); break; case t_shortfloat: i = sf(x); break; case t_longfloat: i = lf(x); break; default: FEerror("~S cannot be coerce to a C int.", 1, x); } return(i); } float object_to_float(object x) { float f=0.0; switch (type_of(x)) { case t_character: f = char_code(x); break; case t_fixnum: f = fix(x); break; case t_bignum: case t_ratio: f = number_to_double(x); break; case t_shortfloat: f = sf(x); break; case t_longfloat: f = lf(x); break; default: FEerror("~S cannot be coerce to a C float.", 1, x); } return(f); } double object_to_double(object x) { double d=0.0; switch (type_of(x)) { case t_character: d = char_code(x); break; case t_fixnum: d = fix(x); break; case t_bignum: case t_ratio: d = number_to_double(x); break; case t_shortfloat: d = sf(x); break; case t_longfloat: d = lf(x); break; default: FEerror("~S cannot be coerce to a C double.", 1, x); } return(d); } /* this may allocate storage. The user can prevent this by providing a string will fillpointer < length and have a null character in the fillpointer position. */ char * object_to_string(object x) { unsigned int leng; char *res; if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x); leng= x->st.st_fillp; /* user has thoughtfully provided a null terminated string ! */ if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) return x->st.st_self; if (x->st.st_dim == leng && leng % sizeof(object) && MAYBE_DATA_P(x->st.st_self)) { x->st.st_self[leng] = 0; return x->st.st_self; } res=malloc(leng+1); bcopy(x->st.st_self,res,leng); res[leng]=0; return res; } /* typedef int (*FUNC)(); */ /* perform the actual invocation of the init function durint a fasload init_address is the offset from the place in memory where the code is loaded in. In most systems this will be 0. The new style fasl vector MUST end with an entry (si::%init f1 f2 .....) where f1 f2 are forms to be evaled. */ /* #ifdef CLEAR_CACHE */ /* static int */ /* sigh(int sig,long code,void *scp, char *addr) { */ /* fprintf(stderr,"Received SIGILL at %p\n",((siginfo_t *)code)->si_addr); */ /* exit(1); */ /* } */ /* #endif */ void call_init(int init_address,object memory,object faslfile) { bds_bind(sSPmemory,memory); bds_bind(sSPinit,faslfile); ((FUNC)(memory->cfd.cfd_start+init_address))(); bds_unwind1; bds_unwind1; } /* statVV is the address of some static storage, which is used by the cfunctions to refer to global variables,.. Initially it holds a number of addresses. We also have sSPmemory->s.s_dbind which points to a vector of lisp constants. We switch the fn addresses and lisp constants. We follow this convoluted path, since we don't wish to have a separate block of data space allocated in the object module simply to temporarily have access to the actual function addresses during load. */ object *min_cfd_self=NULL; void do_init(object *statVV) { object faslfile=sSPinit->s.s_dbind; object data=sSPmemory->s.s_dbind; object *p,*q,y; int i,n; object fasl_vec; char ch; ch=readc_stream(faslfile); unreadc_stream(ch,faslfile); if (ch!='\n') { struct fasd * fd; faslfile=fSopen_fasd(faslfile,sKinput,OBJNULL,Cnil); fd=(struct fasd *)faslfile->v.v_self; n=fix(fd->table_length); fd->table->v.v_self=alloca(n*sizeof(object)); memset(fd->table->v.v_self,0,n*sizeof(object)); fd->table->v.v_dim=faslfile->v.v_self[1]->v.v_fillp=n; } n=fix(READ_STREAM_OR_FASD(faslfile)); sSPinit->s.s_dbind=fasl_vec=fSmake_vector1_1(n,aet_object,Cnil); /* switch SPinit to point to a vector of function addresses */ fasl_vec->v.v_elttype = aet_fix; /* swap the entries */ for (i=0,p=fasl_vec->v.v_self,q=statVV;icfd.cfd_self = statVV; if (!min_cfd_self || data->cfd.cfd_selfcfd.cfd_self; data->cfd.cfd_fillp= n; statVV[n-1] = data; /* So now the fasl_vec is a fixnum array, containing random addresses of c functions and other stuff from the compiled code. data is what it wants to be for the init */ /* Now we can run the forms f1 f2 in form= (%init f1 f2 ...) */ fSload_stream(faslfile,Cnil); if (type_of(faslfile)!=t_stream) fSclose_fasd(faslfile); } DEFUN_NEW("MARK-MEMORY-AS-PROFILING",object,fSmark_memory_as_profiling,SI,0,0, NONE,OO,OO,OO,OO,(void),"") { sSPmemory->s.s_dbind->cfd.cfd_prof=1; return Cnil; } #ifdef DOS #define PATH_LIM 8 #define TYPE_LIM 3 char * fix_path_string_dos(s) char *s; {char buf[200]; char *p=s,*q=buf; int i=PATH_LIM; while(*p) { if (IS_DIR_SEPARATOR(*p)) i=PATH_LIM; else if (*p == '.') i = TYPE_LIM; else i--; if (i>=0) *q++ = *p; p++;} *q = 0; strcpy(s,buf); return s; } #endif object new_cfdata(void) { object memory=alloc_object(t_cfdata); memory->cfd.cfd_size=0; memory->cfd.cfd_fillp=0; memory->cfd.cfd_prof=0; memory->cfd.cfd_self=0; memory->cfd.cfd_start=0; return memory; } void gcl_init_or_load1(void (*fn)(void),const char *file) { if (file[strlen(file)-1]=='o') { object memory; object faslfile; file=FIX_PATH_STRING(file); memory=new_cfdata(); memory->cfd.cfd_start= (char *)fn; printf("Initializing %s\n",file); fflush(stdout); faslfile=open_stream(make_simple_string(file),smm_input,Cnil,sKerror); SEEK_TO_END_OFILE(faslfile->sm.sm_fp); call_init(0,memory,faslfile); close_stream(faslfile); } else { printf("loading %s\n",file); fflush(stdout); load(file); } } DEFUN_NEW("INIT-CMP-ANON", object, fSinit_cmp_anon, SI, 0, 0, NONE, OO, OO, OO,OO,(void), "Initialize previously compiled and linked anonymous function from the \ .text section of the running executable. This function is inherently \ dangerous, and is meant as a work-around to facilitate the production \ of an ansi GCL image on systems which must currently link using \ dlopen. On such systems, it is imposible to compile and load \ anonymous functions as part of the initialization sequence of the lisp \ image, as is done in pcl, and preserve that function across a \ save-system call. The approach here is to provide a flag to GCL's \ compile function which will direct the algorithm to forgo \ recompilation and loading in favor of initialization via this \ function.") { int i; i=gcl_init_cmp_anon(); if (i<0) FEerror("No such anonymous function",0); return i ? Cnil : Ct; } object find_init_name1(char *s,unsigned len) { #ifdef _WIN32 char *tmp; if (len) { tmp=alloca(len+1); memcpy(tmp,s,len); tmp[len]=0; } else tmp=s; return find_init_string(tmp); #else /* These functions have no relevance on Windows * as dlopen and friends don't exist in that part of Cyberspace. */ struct stat ss; char *tmp,*q; FILE *f; if (len) { tmp=alloca(len+1); memcpy(tmp,s,len); tmp[len]=0; } else tmp=s; if (stat(tmp,&ss)) FEerror("File ~a does not exist",1,make_simple_string(tmp)); if (!(f=fopen(tmp,"rb"))) FEerror("Cannot open ~a for binary reading",1,make_simple_string(tmp)); tmp=alloca(ss.st_size+1); if (fread(tmp,1,ss.st_size,f)!=ss.st_size) FEerror("Error reading binary file",0); fclose(f); for (s=tmp+1;stmp && (s[-1]=='_' ? (s>tmp+1 && s[-2]) : s[-1]))); q=strstr(s+1,"init_"),s=q ? q : s+strlen(s)+1); if (strncmp(s,"init_",5)) FEerror("Init name not found",0); return make_simple_string(s); #endif /* _WIN32 */ } DEFUN_NEW("FIND-INIT-NAME", object, fSfind_init_name, SI, 1, 1, NONE, OO, OO, OO,OO,(object namestring),"") { check_type_string(&namestring); return find_init_name1(namestring->st.st_self,namestring->st.st_dim); } DEFUN_NEW("SEEK-TO-END-OFILE",object,fSseek_to_end_ofile,SI,1,1,NONE,OO,OO,OO,OO,(object sm),"") { check_type_stream(&sm); SEEK_TO_END_OFILE(sm->sm.sm_fp); RETURN1(sm); } gcl-2.6.14/o/plttest.c0000644000175000017500000000243414360276512013077 0ustar cammcamm#include #include #include #include #include /* We try here to compile in function addresses to which it is known that the compiler will make *direct* reference. 20040308 CM */ #if defined (__APPLE__) && defined (__MACH__) #define DARWIN #endif #ifndef DARWIN extern int _mcount(); #define mmcount _mcount extern void sincos(double,double *,double *); #endif int main(int argc,char * argv[],char *envp[]) { FILE *f=NULL; char ch=0; jmp_buf env; double d=0.1; long l; unsigned long ul; sscanf(argv[1],"%lf",&d); bzero(&env,sizeof(env)); memset(&env,0,sizeof(env)); ul=*(unsigned long *)envp; ul=ul%(ul>>(ul & 0x3)); l=*(long *)argv; l=l%(l<<(l & 0x7)); l/=ul/l; l/=((long)ul)/l; ch=getc(f); ch&=putc(ch,f); ch&=feof(f); f=fdopen(l,"r"); l=read(l,&l,sizeof(l)); l=write(l,&l,sizeof(l)); #ifndef DARWIN ch&=mmcount(); #endif setjmp(env); d=cos(d); d=sin(d); #ifndef DARWIN sincos(d,&d,&d); #endif d=tan(d); d=acos(d); d=asin(d); d=atan(d); d=cosh(d); d=sinh(d); d=tanh(d); #ifndef _WIN32 d=acosh(d); d=asinh(d); d=atanh(d); #endif d=exp(d); d=log(d); #ifdef __i386__/*FIXME*/ d=logl(d); #endif d=sqrt(d); return ul & l & ((unsigned long)d) & ch; } gcl-2.6.14/o/unexec.c0000755000175000017500000010175414360276512012677 0ustar cammcamm/* Copyright (C) 1985,86,87,88,92,93,94 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* Modified to support SysVr3 shared libraries by James Van Artsdalen * of Dell Computer Corporation. james@bigtex.cactus.org. */ /* There are several compilation parameters affecting unexec: * COFF Define this if your system uses COFF for executables. * COFF_ENCAPSULATE Define this if you are using the GNU coff encapsulated a.out format. This is closer to a.out than COFF. You should *not* define COFF if you define COFF_ENCAPSULATE Otherwise we assume you use Berkeley format. * NO_REMAP Define this if you do not want to try to save Emacs's pure data areas as part of the text segment. Saving them as text is good because it allows users to share more. However, on machines that locate the text area far from the data area, the boundary cannot feasibly be moved. Such machines require NO_REMAP. Also, remapping can cause trouble with the built-in startup routine /lib/crt0.o, which defines `environ' as an initialized variable. Dumping `environ' as pure does not work! So, to use remapping, you must write a startup routine for your machine in Emacs's crt0.c. If NO_REMAP is defined, Emacs uses the system's crt0.o. * SECTION_ALIGNMENT Some machines that use COFF executables require that each section start on a certain boundary *in the COFF file*. Such machines should define SECTION_ALIGNMENT to a mask of the low-order bits that must be zero on such a boundary. This mask is used to control padding between segments in the COFF file. If SECTION_ALIGNMENT is not defined, the segments are written consecutively with no attempt at alignment. This is right for unmodified system V. * SEGMENT_MASK Some machines require that the beginnings and ends of segments *in core* be on certain boundaries. For most machines, a page boundary is sufficient. That is the default. When a larger boundary is needed, define SEGMENT_MASK to a mask of the bits that must be zero on such a boundary. * A_TEXT_OFFSET(HDR) Some machines count the a.out header as part of the size of the text segment (a_text); they may actually load the header into core as the first data in the text segment. Some have additional padding between the header and the real text of the program that is counted in a_text. For these machines, define A_TEXT_OFFSET(HDR) to examine the header structure HDR and return the number of bytes to add to `a_text' before writing it (above and beyond the number of bytes of actual program text). HDR's standard fields are already correct, except that this adjustment to the `a_text' field has not yet been made; thus, the amount of offset can depend on the data in the file. * A_TEXT_SEEK(HDR) If defined, this macro specifies the number of bytes to seek into the a.out file before starting to write the text segment. * EXEC_MAGIC For machines using COFF, this macro, if defined, is a value stored into the magic number field of the output file. * ADJUST_EXEC_HEADER This macro can be used to generate statements to adjust or initialize nonstandard fields in the file header * ADDR_CORRECT(ADDR) Macro to correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This macro has a default definition which is usually right. This default definition is a no-op on most machines (where a pointer looks like an int) but not on all machines. */ #ifndef emacs #define PERROR(arg) perror (arg); return -1 #else #define IN_UNEXEC #include "config.h" #define PERROR(file) report_error (file, new) #endif #ifndef CANNOT_DUMP /* all rest of file! */ #ifdef COFF_ENCAPSULATE int need_coff_header = 1; #include /* The location might be a poor assumption */ #else #ifdef MSDOS #include #define filehdr external_filehdr #define scnhdr external_scnhdr #define syment external_syment #define auxent external_auxent #define n_numaux e_numaux #define n_type e_type struct aouthdr { unsigned short magic; /* type of file */ unsigned short vstamp; /* version stamp */ unsigned long tsize; /* text size in bytes, padded to FW bdry*/ unsigned long dsize; /* initialized data " " */ unsigned long bsize; /* uninitialized data " " */ unsigned long entry; /* entry pt. */ unsigned long text_start;/* base of text used for this file */ unsigned long data_start;/* base of data used for this file */ }; #else /* not MSDOS */ #include #endif /* not MSDOS */ #endif /* Define getpagesize if the system does not. Note that this may depend on symbols defined in a.out.h. */ #include "getpagesize.h" #ifndef makedev /* Try to detect types.h already loaded */ #include #endif /* makedev */ #include #include #include #include /* Must be after sys/types.h for USG and BSD4_1*/ #ifdef USG5 #include #endif #ifndef O_RDONLY #define O_RDONLY 0 #endif #ifndef O_RDWR #define O_RDWR 2 #endif #ifdef UNIXSAVE extern char etext; #endif #ifndef start_of_data extern char *start_of_text (); /* Start of text */ extern char *start_of_data (); /* Start of initialized data */ #endif #ifdef COFF static long block_copy_start; /* Old executable start point */ static struct filehdr f_hdr; /* File header */ static struct aouthdr f_ohdr; /* Optional file header (a.out) */ long bias; /* Bias to add for growth */ long lnnoptr; /* Pointer to line-number info within file */ #define SYMS_START block_copy_start static long text_scnptr; static long data_scnptr; #else /* not COFF */ #ifdef HPUX extern void *sbrk (); #else #if 0 /* Some systems with __STDC__ compilers still declare this `char *' in some header file, and our declaration conflicts. The return value is always cast, so it should be harmless to leave it undefined. Hopefully machines with different size pointers and ints declare sbrk in a header file. */ #ifdef __STDC__ extern void *sbrk (); #else extern char *sbrk (); #endif /* __STDC__ */ #endif #endif /* HPUX */ #define SYMS_START ((long) N_SYMOFF (ohdr)) /* Some machines override the structure name for an a.out header. */ #ifndef EXEC_HDR_TYPE #define EXEC_HDR_TYPE struct exec #endif #ifdef HPUX #ifdef HP9000S200_ID #define MY_ID HP9000S200_ID #else #include #define MY_ID MYSYS #endif /* no HP9000S200_ID */ static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; #define N_TXTOFF(x) TEXT_OFFSET(x) #define N_SYMOFF(x) LESYM_OFFSET(x) static EXEC_HDR_TYPE hdr, ohdr; #else /* not HPUX */ #if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX) static struct bhdr hdr, ohdr; #define a_magic fmagic #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #define a_entry entry #define N_BADMAG(x) \ (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) #define NEWMAGIC FMAGIC #else /* IRIS or IBMAIX or not USG */ static EXEC_HDR_TYPE hdr, ohdr; #define NEWMAGIC ZMAGIC #endif /* IRIS or IBMAIX not USG */ #endif /* not HPUX */ static int unexec_text_start; static int unexec_data_start; #ifdef COFF_ENCAPSULATE /* coffheader is defined in the GNU a.out.encap.h file. */ struct coffheader coffheader; #endif #endif /* not COFF */ static int pagemask; /* Correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This is a no-op on ordinary machines, but not on all. */ #ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ #define ADDR_CORRECT(x) ((char *)(x) - (char*)0) #endif #ifdef emacs #include "lisp.h" static report_error (file, fd) char *file; int fd; { if (fd) close (fd); report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); } #endif /* emacs */ #define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 #define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 #define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 static report_error_1 (int fd, char *msg, int a1, int a2) { close (fd); #ifdef emacs error (msg, a1, a2); #else fprintf (stderr, msg, a1, a2); fprintf (stderr, "\n"); #endif } static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name); static int copy_text_and_data (int new, int a_out); static int copy_sym (int new, int a_out, char *a_name, char *new_name); static void mark_x (char *name); /* **************************************************************** * unexec * * driving logic. */ void unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) { int new, a_out = -1; if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) { PERROR (a_name); } if ((new = creat (new_name, 0666)) < 0) { PERROR (new_name); } if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 || copy_text_and_data (new, a_out) < 0 || copy_sym (new, a_out, a_name, new_name) < 0 #ifdef COFF #ifndef COFF_BSD_SYMBOLS || adjust_lnnoptrs (new, a_out, new_name) < 0 #endif #endif ) { close (new); /* unlink (new_name); /* Failed, unlink new a.out */ return -1; } close (new); if (a_out >= 0) close (a_out); mark_x (new_name); return 0; } /* **************************************************************** * make_hdr * * Make the header in the new a.out from the header in core. * Modify the text and data sizes. */ static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) { int tem; #ifdef COFF auto struct scnhdr f_thdr; /* Text section header */ auto struct scnhdr f_dhdr; /* Data section header */ auto struct scnhdr f_bhdr; /* Bss section header */ auto struct scnhdr scntemp; /* Temporary section header */ register int scns; #endif /* COFF */ #ifdef USG_SHARED_LIBRARIES extern unsigned int bss_end; #else unsigned int bss_end; #endif pagemask = getpagesize () - 1; /* Adjust text/data boundary. */ #ifdef NO_REMAP data_start = (int) start_of_data (); #else /* not NO_REMAP */ if (!data_start) data_start = (int) start_of_data (); #endif /* not NO_REMAP */ data_start = ADDR_CORRECT (data_start); #ifdef SEGMENT_MASK data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ #else data_start = data_start & ~pagemask; /* (Down) to page boundary. */ #endif bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; bss_end &= ~ pagemask; /* Adjust data/bss boundary. */ if (bss_start != 0) { bss_start = (ADDR_CORRECT (bss_start) + pagemask); /* (Up) to page bdry. */ bss_start &= ~ pagemask; if (bss_start > bss_end) { ERROR1 ("unexec: Specified bss_start (%u) is past end of program", bss_start); } } else bss_start = bss_end; if (data_start > bss_start) /* Can't have negative data size. */ { ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", data_start, bss_start); } #ifdef COFF /* Salvage as much info from the existing file as possible */ if (a_out >= 0) { if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (a_name); } block_copy_start += sizeof (f_hdr); if (f_hdr.f_opthdr > 0) { if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (a_name); } block_copy_start += sizeof (f_ohdr); } /* Loop through section headers, copying them in */ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) { PERROR (a_name); } if (scntemp.s_scnptr > 0L) { if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) block_copy_start = scntemp.s_scnptr + scntemp.s_size; } if (strcmp (scntemp.s_name, ".text") == 0) { f_thdr = scntemp; } else if (strcmp (scntemp.s_name, ".data") == 0) { f_dhdr = scntemp; } else if (strcmp (scntemp.s_name, ".bss") == 0) { f_bhdr = scntemp; } } } else { ERROR0 ("can't build a COFF file from scratch yet"); } /* Now we alter the contents of all the f_*hdr variables to correspond to what we want to dump. */ #ifdef USG_SHARED_LIBRARIES /* The amount of data we're adding to the file is distance from the * end of the original .data space to the current end of the .data * space. */ bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size); #endif f_hdr.f_flags |= (F_RELFLG | F_EXEC); #ifdef TPIX f_hdr.f_nscns = 3; #endif #ifdef EXEC_MAGIC f_ohdr.magic = EXEC_MAGIC; #endif #ifndef NO_REMAP f_ohdr.text_start = (long) start_of_text (); f_ohdr.tsize = data_start - f_ohdr.text_start; f_ohdr.data_start = data_start; #endif /* NO_REMAP */ f_ohdr.dsize = bss_start - f_ohdr.data_start; f_ohdr.bsize = bss_end - bss_start; #ifndef KEEP_OLD_TEXT_SCNPTR /* On some machines, the old values are right. ??? Maybe on all machines with NO_REMAP. */ f_thdr.s_size = f_ohdr.tsize; f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); #endif /* KEEP_OLD_TEXT_SCNPTR */ #ifdef ADJUST_TEXT_SCNHDR_SIZE /* On some machines, `text size' includes all headers. */ f_thdr.s_size -= f_thdr.s_scnptr; #endif /* ADJUST_TEST_SCNHDR_SIZE */ lnnoptr = f_thdr.s_lnnoptr; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_thdr.s_scnptr = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef TPIX f_thdr.s_scnptr = 0xd0; #endif text_scnptr = f_thdr.s_scnptr; #ifdef ADJUST_TEXTBASE text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr)); #endif #ifndef KEEP_OLD_PADDR f_dhdr.s_paddr = f_ohdr.data_start; #endif /* KEEP_OLD_PADDR */ f_dhdr.s_vaddr = f_ohdr.data_start; f_dhdr.s_size = f_ohdr.dsize; f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef DATA_SECTION_ALIGNMENT /* Some systems require special alignment of the data section only. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; #endif /* DATA_SECTION_ALIGNMENT */ data_scnptr = f_dhdr.s_scnptr; #ifndef KEEP_OLD_PADDR f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; #endif /* KEEP_OLD_PADDR */ f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; f_bhdr.s_size = f_ohdr.bsize; f_bhdr.s_scnptr = 0L; #ifndef USG_SHARED_LIBRARIES bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; #endif if (f_hdr.f_symptr > 0L) { f_hdr.f_symptr += bias; } if (f_thdr.s_lnnoptr > 0L) { f_thdr.s_lnnoptr += bias; } #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER; #endif /* ADJUST_EXEC_HEADER */ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (new_name); } if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (new_name); } #ifndef USG_SHARED_LIBRARIES if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) { PERROR (new_name); } if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) { PERROR (new_name); } if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) { PERROR (new_name); } #else /* USG_SHARED_LIBRARIES */ /* The purpose of this code is to write out the new file's section * header table. * * Scan through the original file's sections. If the encountered * section is one we know (.text, .data or .bss), write out the * correct header. If it is a section we do not know (such as * .lib), adjust the address of where the section data is in the * file, and write out the header. * * If any section precedes .text or .data in the file, this code * will not adjust the file pointer for that section correctly. */ /* This used to use sizeof (f_ohdr) instead of .f_opthdr. .f_opthdr is said to be right when there is no optional header. */ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (a_name); if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ { if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ { if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ { if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) PERROR (new_name); } else { if (scntemp.s_scnptr) scntemp.s_scnptr += bias; if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (new_name); } } #endif /* USG_SHARED_LIBRARIES */ return (0); #else /* if not COFF */ /* Get symbol table info from header of a.out file if given one. */ if (a_out >= 0) { #ifdef COFF_ENCAPSULATE if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader) { PERROR(a_name); } if (coffheader.f_magic != COFF_MAGIC) { ERROR1("%s doesn't have legal coff magic number\n", a_name); } #endif if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) { PERROR (a_name); } if (N_BADMAG (ohdr)) { ERROR1 ("invalid magic number in %s", a_name); } hdr = ohdr; } else { #ifdef COFF_ENCAPSULATE /* We probably could without too much trouble. The code is in gld * but I don't have that much time or incentive. */ ERROR0 ("can't build a COFF file from scratch yet"); #else #ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ bzero ((void *)&hdr, sizeof hdr); #else bzero (&hdr, sizeof hdr); #endif #endif } unexec_text_start = (long) start_of_text (); unexec_data_start = data_start; /* Machine-dependent fixup for header, or maybe for unexec_text_start */ #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER; #endif /* ADJUST_EXEC_HEADER */ hdr.a_trsize = 0; hdr.a_drsize = 0; if (entry_address != 0) hdr.a_entry = entry_address; hdr.a_bss = bss_end - bss_start; hdr.a_data = bss_start - data_start; #ifdef NO_REMAP hdr.a_text = ohdr.a_text; #else /* not NO_REMAP */ hdr.a_text = data_start - unexec_text_start; #ifdef A_TEXT_OFFSET hdr.a_text += A_TEXT_OFFSET (ohdr); #endif #endif /* not NO_REMAP */ #ifdef COFF_ENCAPSULATE /* We are encapsulating BSD format within COFF format. */ { struct coffscn *tp, *dp, *bp; tp = &coffheader.scns[0]; dp = &coffheader.scns[1]; bp = &coffheader.scns[2]; tp->s_size = hdr.a_text + sizeof(struct exec); dp->s_paddr = data_start; dp->s_vaddr = data_start; dp->s_size = hdr.a_data; bp->s_paddr = dp->s_vaddr + dp->s_size; bp->s_vaddr = bp->s_paddr; bp->s_size = hdr.a_bss; coffheader.tsize = tp->s_size; coffheader.dsize = dp->s_size; coffheader.bsize = bp->s_size; coffheader.text_start = tp->s_vaddr; coffheader.data_start = dp->s_vaddr; } if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader) { PERROR(new_name); } #endif /* COFF_ENCAPSULATE */ if (write (new, &hdr, sizeof hdr) != sizeof hdr) { PERROR (new_name); } #if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */ /* This adjustment was done above only #ifndef NO_REMAP, so only undo it now #ifndef NO_REMAP. */ /* #ifndef NO_REMAP */ #endif #ifdef A_TEXT_OFFSET hdr.a_text -= A_TEXT_OFFSET (ohdr); #endif return 0; #endif /* not COFF */ } /* **************************************************************** * copy_text_and_data * * Copy the text and data segments from memory to the new a.out */ static int copy_text_and_data (int new, int a_out) { register char *end; register char *ptr; #ifdef COFF #ifdef USG_SHARED_LIBRARIES int scns; struct scnhdr scntemp; /* Temporary section header */ /* The purpose of this code is to write out the new file's section * contents. * * Step through the section table. If we know the section (.text, * .data) do the appropriate thing. Otherwise, if the section has * no allocated space in the file (.bss), do nothing. Otherwise, * the section has space allocated in the file, and is not a section * we know. So just copy it. */ lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR ("temacs"); if (!strcmp (scntemp.s_name, ".text")) { lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); } else if (!strcmp (scntemp.s_name, ".data")) { lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); } else if (!scntemp.s_scnptr) ; /* do nothing - no data for this section */ else { char page[BUFSIZ]; int size, n; long old_a_out_ptr = lseek (a_out, 0, 1); lseek (a_out, scntemp.s_scnptr, 0); for (size = scntemp.s_size; size > 0; size -= sizeof (page)) { n = size > sizeof (page) ? sizeof (page) : size; if (read (a_out, page, n) != n || write (new, page, n) != n) PERROR ("emacs"); } lseek (a_out, old_a_out_ptr, 0); } } #else /* COFF, but not USG_SHARED_LIBRARIES */ lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; #ifdef HEADER_INCL_IN_TEXT /* For Gould UTX/32, text starts after headers */ ptr = (char *) (ptr + text_scnptr); #endif /* HEADER_INCL_IN_TEXT */ end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); #endif /* USG_SHARED_LIBRARIES */ #else /* if not COFF */ /* Some machines count the header as part of the text segment. That is to say, the header appears in core just before the address that start_of_text returns. For them, N_TXTOFF is the place where the header goes. We must adjust the seek to the place after the header. Note that at this point hdr.a_text does *not* count the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ #ifdef A_TEXT_SEEK lseek (new, (long) A_TEXT_SEEK (hdr), 0); #else lseek (new, (long) N_TXTOFF (hdr), 0); #endif /* no A_TEXT_SEEK */ #ifdef RISCiX /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. * There is a little table in crt0.o that is filled at link time with * the min and current brk positions, among other things. When start * runs, it copies the table to where these parameters live during * execution. This data is in text space, so it cannot be modified here * before saving the executable, so the data is written manually. In * addition, the table does not have a label, and the nearest accessable * label (mcount) is not prefixed with a '_', thus making it inaccessable * from within C programs. To overcome this, emacs's executable is passed * through the command 'nm %s | fgrep mcount' into a pipe, and the * resultant output is then used to find the address of 'mcount'. As far as * is possible to determine, in RISC-iX releases prior to 1.2, the negative * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is * 0x30. bss_end has been rounded up to page boundary. This solution is * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and * avoids the need for a custom version of crt0.o for emacs which has its * table in data space. */ { char command[1024]; char errbuf[1024]; char address_text[32]; int proforma[4]; FILE *pfile; char *temp_ptr; char c; int mcount_address, mcount_offset, count; extern char *_execname; /* The use of _execname is incompatible with RISCiX 1.1 */ sprintf (command, "nm '%s' | fgrep mcount", _execname); if ( (pfile = popen(command, "r")) == NULL) { sprintf (errbuf, "Could not open pipe"); PERROR (errbuf); } count=0; while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31)) address_text[count++]=c; address_text[count]=0; if ((count == 0) || pclose(pfile) != NULL) { sprintf (errbuf, "Failed to execute the command '%s'\n", command); PERROR (errbuf); } sscanf(address_text, "%x", &mcount_address); ptr = (char *) unexec_text_start; mcount_offset = (char *)mcount_address - ptr; #ifdef RISCiX_1_1 #define EDATA_OFFSET 0x2c #else #define EDATA_OFFSET 0x30 #endif end = ptr + mcount_offset - EDATA_OFFSET; write_segment (new, ptr, end); proforma[0] = bss_end; /* becomes _edata */ proforma[1] = bss_end; /* becomes _end */ proforma[2] = bss_end; /* becomes _minbrk */ proforma[3] = bss_end; /* becomes _curbrk */ write (new, proforma, 16); temp_ptr = ptr; ptr = end + 16; end = temp_ptr + hdr.a_text; write_segment (new, ptr, end); } #else /* !RISCiX */ ptr = (char *) unexec_text_start; end = ptr + hdr.a_text; write_segment (new, ptr, end); #endif /* RISCiX */ ptr = (char *) unexec_data_start; end = ptr + hdr.a_data; /* This lseek is certainly incorrect when A_TEXT_OFFSET and I believe it is a no-op otherwise. Let's see if its absence ever fails. */ /* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ write_segment (new, ptr, end); #endif /* not COFF */ return 0; } write_segment (int new, register char *ptr, register char *end) { register int i, nwrite, ret; char buf[80]; extern int errno; char zeros[128]; int amt_to_write = (1 << 13); bzero (zeros, sizeof zeros); for (i = 0; ptr < end;) { /* distance to next multiple of amt_to_write . */ AGAIN: nwrite = (((int) ptr + amt_to_write) & -amt_to_write) - (int) ptr; /* But not beyond specified end. */ if (nwrite > end - ptr) nwrite = end - ptr; ret = write (new, ptr, nwrite); /* If write gets a page fault, it means we reached a gap between the old text segment and the old data segment. This gap has probably been remapped into part of the text segment. So write zeros for it. */ if (ret == -1 #ifdef EFAULT && errno == EFAULT #endif ) { if (amt_to_write > sizeof(zeros)) { amt_to_write = sizeof(zeros); goto AGAIN; } write (new, zeros, nwrite); } else if (nwrite != ret) { sprintf (buf, "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", ptr, new, nwrite, ret, errno); PERROR (buf); } i += nwrite; ptr += nwrite; } } /* **************************************************************** * copy_sym * * Copy the relocation information and symbol table from the a.out to the new */ static int copy_sym (int new, int a_out, char *a_name, char *new_name) { char page[1024]; int n; if (a_out < 0) return 0; #ifdef COFF if (SYMS_START == 0L) return 0; #endif /* COFF */ #ifdef COFF if (lnnoptr) /* if there is line number info */ lseek (a_out, lnnoptr, 0); /* start copying from there */ else #endif /* COFF */ lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ while ((n = read (a_out, page, sizeof page)) > 0) { if (write (new, page, n) != n) { PERROR (new_name); } } if (n < 0) { PERROR (a_name); } return 0; } /* **************************************************************** * mark_x * * After successfully building the new a.out, mark it executable */ static void mark_x (char *name) { struct stat sbuf; int um; int new = 0; /* for PERROR */ um = umask (777); umask (um); if (stat (name, &sbuf) == -1) { PERROR (name); } sbuf.st_mode |= 0111 & ~um; if (chmod (name, sbuf.st_mode) == -1) PERROR (name); } #ifdef COFF #ifndef COFF_BSD_SYMBOLS /* * If the COFF file contains a symbol table and a line number section, * then any auxiliary entries that have values for x_lnnoptr must * be adjusted by the amount that the line number section has moved * in the file (bias computed in make_hdr). The #@$%&* designers of * the auxiliary entry structures used the absolute file offsets for * the line number entry rather than an offset from the start of the * line number section! * * When I figure out how to scan through the symbol table and pick out * the auxiliary entries that need adjustment, this routine will * be fixed. As it is now, all such entries are wrong and sdb * will complain. Fred Fish, UniSoft Systems Inc. */ /* This function is probably very slow. Instead of reopening the new file for input and output it should copy from the old to the new using the two descriptors already open (WRITEDESC and READDESC). Instead of reading one small structure at a time it should use a reasonable size buffer. But I don't have time to work on such things, so I am installing it as submitted to me. -- RMS. */ adjust_lnnoptrs (writedesc, readdesc, new_name) int writedesc; int readdesc; char *new_name; { register int nsyms; register int new; #if defined (amdahl_uts) || defined (pfa) SYMENT symentry; AUXENT auxentry; #else struct syment symentry; union auxent auxentry; #endif if (!lnnoptr || !f_hdr.f_symptr) return 0; #ifdef MSDOS if ((new = writedesc) < 0) #else if ((new = open (new_name, O_RDWR)) < 0) #endif { PERROR (new_name); return -1; } lseek (new, f_hdr.f_symptr, 0); for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) { read (new, &symentry, SYMESZ); if (symentry.n_numaux) { read (new, &auxentry, AUXESZ); nsyms++; if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) { auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; lseek (new, -AUXESZ, 1); write (new, &auxentry, AUXESZ); } } } #ifndef MSDOS close (new); #endif return 0; } #endif /* COFF_BSD_SYMBOLS */ #endif /* COFF */ #endif /* not CANNOT_DUMP */ #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/save.c0000755000175000017500000000114714360276512012341 0ustar cammcamm#ifndef FIRSTWORD #include "include.h" #endif static void memory_save(char *original_file, char *save_file) { #ifdef DO_BEFORE_SAVE DO_BEFORE_SAVE ; #endif unexec(save_file,original_file,0,0,0); } #ifdef USE_CLEANUP extern void _cleanup(); #endif LFD(siLsave)(void) { char filename[256]; extern char *kcl_self; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); gcl_cleanup(1); #ifdef MEMORY_SAVE MEMORY_SAVE(kcl_self,filename); #else memory_save(kcl_self, filename); #endif /* no return */ exit(0); } gcl-2.6.14/o/bind.c0000755000175000017500000006205214360276512012321 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* bind.c */ #include #include "include.h" static void illegal_lambda(void); struct nil3 { object nil3_self[3]; } three_nils; struct nil6 { object nil6_self[6]; } six_nils; struct required { object req_var; object req_spp; }; struct optional { object opt_var; object opt_spp; object opt_init; object opt_svar; object opt_svar_spp; }; struct rest { object rest_var; object rest_spp; }; struct keyword { object key_word; object key_var; object key_spp; object key_init; object key_svar; object key_svar_spp; object key_val; object key_svar_val; }; struct aux { object aux_var; object aux_spp; object aux_init; }; #define isdeclare(x) ((x) == sLdeclare) void lambda_bind(object *arg_top) { object temporary; object lambda, lambda_list, body, form=Cnil, x, ds, vs, v; int narg, i, j; object *base = vs_base; struct required *required; int nreq; struct optional *optional=NULL; int nopt; struct rest *rest=NULL; bool rest_flag; struct keyword *keyword=NULL; bool key_flag; bool allow_other_keys_flag, other_keys_appeared; int nkey; struct aux *aux=NULL; int naux; bool special_processed; object s[1],ss; vs_mark; bds_check; lambda = vs_head; if (!consp(lambda)) FEerror("No lambda list.", 0); lambda_list = lambda->c.c_car; body = lambda->c.c_cdr; required = (struct required *)vs_top; nreq = 0; s[0]=Cnil; for (;;) { if (endp(lambda_list)) goto REQUIRED_ONLY; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; check_symbol(x); if (x == ANDallow_other_keys) illegal_lambda(); if (x == ANDoptional) { nopt = nkey = naux = 0; rest_flag = key_flag = allow_other_keys_flag = FALSE; goto OPTIONAL; } if (x == ANDrest) { nopt = nkey = naux = 0; key_flag = allow_other_keys_flag = FALSE; goto REST; } if (x == ANDkey) { nopt = nkey = naux = 0; rest_flag = allow_other_keys_flag = FALSE; goto KEYWORD; } if (x == ANDaux) { nopt = nkey = naux = 0; rest_flag = key_flag = allow_other_keys_flag = FALSE; goto AUX_L; } if ((enum stype)x->s.s_stype == stp_constant) FEerror("~S is not a variable.", 1, x); vs_push(x); vs_push(Cnil); nreq++; } OPTIONAL: optional = (struct optional *)vs_top; for (;; nopt++) { if (endp(lambda_list)) goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; if (consp(x)) { check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); x = x->c.c_cdr; vs_push(Cnil); if (endp(x)) { *(struct nil3 *)vs_top = three_nils; vs_top += 3; continue; } vs_push(x->c.c_car); x = x->c.c_cdr; if (endp(x)) { vs_push(Cnil); vs_push(Cnil); continue; } check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); vs_push(Cnil); if (!endp(x->c.c_cdr)) illegal_lambda(); } else { check_symbol(x); if (x == ANDoptional || x == ANDallow_other_keys) illegal_lambda(); if (x == ANDrest) goto REST; if (x == ANDkey) goto KEYWORD; if (x == ANDaux) goto AUX_L; check_var(x); vs_push(x); *(struct nil6 *)vs_top = six_nils; vs_top += 4; } } REST: rest = (struct rest *)vs_top; if (endp(lambda_list)) illegal_lambda(); check_symbol(lambda_list->c.c_car); check_var(lambda_list->c.c_car); rest_flag = TRUE; vs_push(lambda_list->c.c_car); vs_push(Cnil); lambda_list = lambda_list->c.c_cdr; if (endp(lambda_list)) goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; check_symbol(x); if (x == ANDoptional || x == ANDrest || x == ANDallow_other_keys) illegal_lambda(); if (x == ANDkey) goto KEYWORD; if (x == ANDaux) goto AUX_L; illegal_lambda(); KEYWORD: keyword = (struct keyword *)vs_top; key_flag = TRUE; for (;; nkey++) { if (endp(lambda_list)) goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; if (consp(x)) { if (consp(x->c.c_car)) { if (type_of(x->c.c_car->c.c_car)!=t_symbol) /* FIXME better message */ FEunexpected_keyword(x->c.c_car->c.c_car); vs_push(x->c.c_car->c.c_car); if (endp(x->c.c_car->c.c_cdr)) illegal_lambda(); check_symbol(x->c.c_car ->c.c_cdr->c.c_car); vs_push(x->c.c_car->c.c_cdr->c.c_car); if (!endp(x->c.c_car->c.c_cdr->c.c_cdr)) illegal_lambda(); } else { check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(intern(x->c.c_car, keyword_package)); vs_push(x->c.c_car); } vs_push(Cnil); x = x->c.c_cdr; if (endp(x)) { *(struct nil6 *)vs_top = six_nils; vs_top += 5; continue; } vs_push(x->c.c_car); x = x->c.c_cdr; if (endp(x)) { *(struct nil6 *)vs_top = six_nils; vs_top += 4; continue; } check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); vs_push(Cnil); if (!endp(x->c.c_cdr)) illegal_lambda(); vs_push(Cnil); vs_push(Cnil); } else { check_symbol(x); if (x == ANDallow_other_keys) { allow_other_keys_flag = TRUE; if (endp(lambda_list)) goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; } if (x == ANDoptional || x == ANDrest || x == ANDkey || x == ANDallow_other_keys) illegal_lambda(); if (x == ANDaux) goto AUX_L; check_var(x); vs_push(intern(x, keyword_package)); vs_push(x); *(struct nil6 *)vs_top = six_nils; vs_top += 6; } } AUX_L: aux = (struct aux *)vs_top; for (;; naux++) { if (endp(lambda_list)) goto SEARCH_DECLARE; x = lambda_list->c.c_car; lambda_list = lambda_list->c.c_cdr; if (consp(x)) { check_symbol(x->c.c_car); check_var(x->c.c_car); vs_push(x->c.c_car); vs_push(Cnil); x = x->c.c_cdr; if (endp(x)) { vs_push(Cnil); continue; } vs_push(x->c.c_car); if (!endp(x->c.c_cdr)) illegal_lambda(); } else { check_symbol(x); if (x == ANDoptional || x == ANDrest || x == ANDkey || x == ANDallow_other_keys || x == ANDaux) illegal_lambda(); check_var(x); vs_push(x); vs_push(Cnil); vs_push(Cnil); } } SEARCH_DECLARE: vs_push(Cnil); for (; !endp(body); body = body->c.c_cdr) { form = body->c.c_car; /* MACRO EXPANSION */ form = macro_expand(form); vs_head = form; if (type_of(form) == t_string) { if (endp(body->c.c_cdr)) break; continue; } if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { if (!consp(ds->c.c_car)) illegal_declare(form); if (ds->c.c_car->c.c_car == sLspecial) { vs = ds->c.c_car->c.c_cdr; for (; !endp(vs); vs = vs->c.c_cdr) { v = vs->c.c_car; check_symbol(v); /**/ special_processed = FALSE; for (i = 0; i < nreq; i++) if (required[i].req_var == v) { required[i].req_spp = Ct; special_processed = TRUE; } for (i = 0; i < nopt; i++) if (optional[i].opt_var == v) { optional[i].opt_spp = Ct; special_processed = TRUE; } else if (optional[i].opt_svar == v) { optional[i].opt_svar_spp = Ct; special_processed = TRUE; } if (rest_flag && rest->rest_var == v) { rest->rest_spp = Ct; special_processed = TRUE; } for (i = 0; i < nkey; i++) if (keyword[i].key_var == v) { keyword[i].key_spp = Ct; special_processed = TRUE; } else if (keyword[i].key_svar == v) { keyword[i].key_svar_spp = Ct; special_processed = TRUE; } for (i = 0; i < naux; i++) if (aux[i].aux_var == v) { aux[i].aux_spp = Ct; special_processed = TRUE; } if (special_processed) continue; s[0] = MMcons(MMcons(v, Cnil), s[0]); /**/ } } } } narg = arg_top - base; if (narg < nreq) { if (nopt == 0 && !rest_flag && !key_flag) { vs_base = base; vs_top = arg_top; check_arg_failed(nreq); } FEtoo_few_arguments(base, arg_top); } if (!rest_flag && !key_flag && narg > nreq+nopt) { if (nopt == 0) { vs_base = base; vs_top = arg_top; check_arg_failed(nreq); } FEtoo_many_arguments(base, arg_top); } for (i = 0; i < nreq; i++) bind_var(required[i].req_var, base[i], required[i].req_spp); for (i = 0; i < nopt; i++) if (nreq+i < narg) { bind_var(optional[i].opt_var, base[nreq+i], optional[i].opt_spp); if (optional[i].opt_svar != Cnil) bind_var(optional[i].opt_svar, Ct, optional[i].opt_svar_spp); } else { eval_assign(temporary, optional[i].opt_init); bind_var(optional[i].opt_var, temporary, optional[i].opt_spp); if (optional[i].opt_svar != Cnil) bind_var(optional[i].opt_svar, Cnil, optional[i].opt_svar_spp); } if (rest_flag) { object *l=vs_top++; for (i=nreq+nopt;irest_var, vs_head, rest->rest_spp); } if (key_flag) { int allow_other_keys_found=0; i = narg - nreq - nopt; if (i >= 0 && i%2 != 0) /* FIXME better message */ FEunexpected_keyword(Cnil); other_keys_appeared = FALSE; for (i = nreq + nopt; i < narg; i += 2) { if (type_of(base[i])!=t_symbol) FEunexpected_keyword(base[i]); if (base[i] == sKallow_other_keys && !allow_other_keys_found) { allow_other_keys_found=1; if (base[i+1] != Cnil) allow_other_keys_flag = TRUE; } for (j = 0; j < nkey; j++) { if (keyword[j].key_word == base[i]) { if (keyword[j].key_svar_val != Cnil) goto NEXT_ARG; keyword[j].key_val = base[i+1]; keyword[j].key_svar_val = Ct; goto NEXT_ARG; } } if (base[i] != sKallow_other_keys) other_keys_appeared = TRUE; NEXT_ARG: continue; } if (other_keys_appeared && !allow_other_keys_flag) /* FIXME better message */ FEunexpected_keyword(Ct); } for (i = 0; i < nkey; i++) if (keyword[i].key_svar_val != Cnil) { bind_var(keyword[i].key_var, keyword[i].key_val, keyword[i].key_spp); if (keyword[i].key_svar != Cnil) bind_var(keyword[i].key_svar, keyword[i].key_svar_val, keyword[i].key_svar_spp); } else { eval_assign(temporary, keyword[i].key_init); bind_var(keyword[i].key_var, temporary, keyword[i].key_spp); if (keyword[i].key_svar != Cnil) bind_var(keyword[i].key_svar, keyword[i].key_svar_val, keyword[i].key_svar_spp); } for (i = 0; i < naux; i++) { eval_assign(temporary, aux[i].aux_init); bind_var(aux[i].aux_var, temporary, aux[i].aux_spp); } if (!consp(body) || body->c.c_car == form) { vs_reset; vs_head = body; } else { body = make_cons(form, body->c.c_cdr); vs_reset; vs_head = body; } if (s[0]!=Cnil) { for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr); ss->c.c_cdr=lex_env[0]; lex_env[0]=s[0]; } return; REQUIRED_ONLY: vs_push(Cnil); for (; !endp(body); body = body->c.c_cdr) { form = body->c.c_car; /* MACRO EXPANSION */ vs_head = form = macro_expand(form); if (type_of(form) == t_string) { if (endp(body->c.c_cdr)) break; continue; } if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { if (!consp(ds->c.c_car)) illegal_declare(form); if (ds->c.c_car->c.c_car == sLspecial) { vs = ds->c.c_car->c.c_cdr; for (; !endp(vs); vs = vs->c.c_cdr) { v = vs->c.c_car; check_symbol(v); /**/ special_processed = FALSE; for (i = 0; i < nreq; i++) if (required[i].req_var == v) { required[i].req_spp = Ct; special_processed = TRUE; } if (special_processed) continue; /* lex_special_bind(v); */ temporary = MMcons(v, Cnil); s[0] = MMcons(temporary, s[0]); /**/ } } } } narg = arg_top - base; if (narg != nreq) { vs_base = base; vs_top = arg_top; check_arg_failed(nreq); } for (i = 0; i < nreq; i++) bind_var(required[i].req_var, base[i], required[i].req_spp); if (!consp(body) || body->c.c_car == form) { vs_reset; vs_head = body; } else { body = make_cons(form, body->c.c_cdr); vs_reset; vs_head = body; } if (s[0]!=Cnil) { for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr); ss->c.c_cdr=lex_env[0]; lex_env[0]=s[0]; } } void bind_var(object var, object val, object spp) { object temporary; vs_mark; switch (var->s.s_stype) { case stp_constant: FEerror("Cannot bind the constant ~S.", 1, var); case stp_special: bds_bind(var, val); break; default: if (spp != Cnil) { /* lex_special_bind(var); */ temporary = MMcons(var, Cnil); lex_env[0] = MMcons(temporary, lex_env[0]); bds_bind(var, val); } else { /* lex_local_bind(var, val); */ temporary = MMcons(val, Cnil); temporary = MMcons(var, temporary); lex_env[0] = MMcons(temporary, lex_env[0]); } break; } vs_reset; } static void illegal_lambda(void) { FEerror("Illegal lambda expression.", 0); } /* struct bind_temp { object bt_var; object bt_spp; object bt_init; object bt_aux; }; */ object find_special(object body, struct bind_temp *start, struct bind_temp *end,object *s) { object temporary; object form=Cnil; object ds, vs, v; struct bind_temp *bt; bool special_processed; vs_mark; vs_push(Cnil); s=s ? s : lex_env; for (; !endp(body); body = body->c.c_cdr) { form = body->c.c_car; /* MACRO EXPANSION */ form = macro_expand(form); vs_head = form; if (type_of(form) == t_string) { if (endp(body->c.c_cdr)) break; continue; } if (!consp(form) || !isdeclare(form->c.c_car)) break; for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { if (!consp(ds->c.c_car)) illegal_declare(form); if (ds->c.c_car->c.c_car == sLspecial) { vs = ds->c.c_car->c.c_cdr; for (; !endp(vs); vs = vs->c.c_cdr) { v = vs->c.c_car; check_symbol(v); /**/ special_processed = FALSE; for (bt = start; bt < end; bt++) if (bt->bt_var == v) { bt->bt_spp = Ct; special_processed = TRUE; } if (special_processed) continue; /* lex_special_bind(v); */ temporary = MMcons(v, Cnil); s[0] = MMcons(temporary, s[0]); /**/ } } } } if (body != Cnil && body->c.c_car != form && type_of(form)==t_cons && isdeclare(form->c.c_car))/*FIXME*/ body = make_cons(form, body->c.c_cdr); vs_reset; return(body); } object let_bind(object body, struct bind_temp *start, struct bind_temp *end) { struct bind_temp *bt; bds_check; for (bt = start; bt < end; bt++) { eval_assign(bt->bt_init, bt->bt_init); } vs_push(find_special(body, start, end,NULL)); for (bt = start; bt < end; bt++) { bind_var(bt->bt_var, bt->bt_init, bt->bt_spp); } return(vs_pop); } object letA_bind(object body, struct bind_temp *start, struct bind_temp *end) { struct bind_temp *bt; object s[1],ss; bds_check; s[0]=Cnil; vs_push(find_special(body, start, end,s)); for (bt = start; bt < end; bt++) { eval_assign(bt->bt_init, bt->bt_init); bind_var(bt->bt_var, bt->bt_init, bt->bt_spp); } if (s[0]!=Cnil) { for (ss=s[0];ss->c.c_cdr!=Cnil;ss=ss->c.c_cdr); ss->c.c_cdr=lex_env[0]; lex_env[0]=s[0]; } return(vs_pop); } #ifdef MV #endif #define NOT_YET stp_ordinary #define FOUND stp_special #define NOT_KEYWORD 1 void parse_key(object *base, bool rest, bool allow_other_keys, int n, ...) { object temporary; va_list ap; object other_key = OBJNULL; int narg, error_flag = 0, allow_other_keys_found=0; object *v, k, *top; register int i; narg = vs_top - base; if (narg <= 0) { if (rest) { base[0] = Cnil; base++; } top = base + n; for (i = 0; i < n; i++) { base[i] = Cnil; top[i] = Cnil; } return; } if (narg%2 != 0) /* FIXME better message */ FEunexpected_keyword(Cnil); if (narg == 2) { k = base[0]; if (type_of(k)!=t_symbol) FEunexpected_keyword(k); if (k == sKallow_other_keys && ! allow_other_keys_found) { allow_other_keys_found=1; if (base[1]!=Cnil) allow_other_keys=TRUE; } temporary = base[1]; if (rest) base++; top = base + n; other_key = k == sKallow_other_keys ? OBJNULL : k; va_start(ap,n); for (i = 0; i < n; i++) { if (va_arg(ap,object) == k) { base[i] = temporary; top[i] = Ct; other_key = OBJNULL; } else { base[i] = Cnil; top[i] = Cnil; } } va_end(ap); if (rest) { temporary = make_cons(temporary, Cnil); base[-1] = make_cons(k, temporary); } if (other_key != OBJNULL && !allow_other_keys) FEunexpected_keyword(other_key); return; } va_start(ap,n); for (i = 0; i < n; i++) { k = va_arg(ap,object); k->s.s_stype = NOT_YET; k->s.s_dbind = Cnil; } va_end(ap); for (v = base; v < vs_top; v += 2) { k = v[0]; if (type_of(k)!=t_symbol) { error_flag = NOT_KEYWORD; other_key = k; continue; } if (k->s.s_stype == NOT_YET) { k->s.s_dbind = v[1]; k->s.s_stype = FOUND; } else if (k->s.s_stype == FOUND) { ; } else if (other_key == OBJNULL && k!=sKallow_other_keys) other_key = k; if (k == sKallow_other_keys && !allow_other_keys_found) { allow_other_keys_found=1; if (v[1] != Cnil) allow_other_keys = TRUE; } } if (rest) { object *a,*l; for (l=a=base;as.s_dbind; top[i] = k->s.s_stype == FOUND ? Ct : Cnil; k->s.s_dbind = k; k->s.s_stype = (short)stp_constant; } va_end(ap); if (error_flag == NOT_KEYWORD) FEunexpected_keyword(other_key); if (other_key != OBJNULL && !allow_other_keys) FEunexpected_keyword(other_key); } void check_other_key(object l, int n, ...) { va_list ap; object other_key = OBJNULL; object k; int i; bool allow_other_keys = FALSE; int allow_other_keys_found=0; for (; !endp(l); l = l->c.c_cdr->c.c_cdr) { k = l->c.c_car; if (type_of(k)!=t_symbol) FEunexpected_keyword(k); if (endp(l->c.c_cdr)) /* FIXME better message */ FEunexpected_keyword(Cnil); if (k == sKallow_other_keys && !allow_other_keys_found) { allow_other_keys_found=1; if (l->c.c_cdr->c.c_car != Cnil) allow_other_keys = TRUE; } else { char buf [100]; bzero(buf,n); va_start(ap,n); for (i = 0; i < n; i++) { if (va_arg(ap,object) == k && buf[i] ==0) {buf[i]=1; break;}} va_end(ap); if (i >= n) other_key = k; } } if (other_key != OBJNULL && !allow_other_keys) FEunexpected_keyword(other_key); } /* struct key {short n,allow_other_keys; */ /* iobject *defaults; */ /* iobject keys[1]; */ /* }; */ object Cstd_key_defaults[15]={Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil, Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil}; /* FIXME rewrite this */ /* static int */ /* parse_key_new(int n, object *base, struct key *keys, va_list ap) */ /* {object *new; */ /* COERCE_VA_LIST(new,ap,n); */ /* new = new + n ; */ /* {int j=keys->n; */ /* object *p= (object *)(keys->defaults); */ /* while (--j >=0) base[j]=p[j]; */ /* } */ /* {if (n==0){ return 0;} */ /* {int allow = keys->allow_other_keys; */ /* object k; */ /* if (!allow) { */ /* int i; */ /* for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */ /* if (i>0 && new[-i+1]!=Cnil) */ /* allow=1; */ /* } */ /* top: */ /* while (n>=2) */ /* {int i= keys->n; */ /* iobject *ke=keys->keys ; */ /* new = new -2; */ /* k = *new; */ /* while(--i >= 0) */ /* {if ((*(ke++)).o == k) */ /* {base[i]= new[1]; */ /* n=n-2; */ /* goto top; */ /* }} */ /* the key is a new one */ /* if (allow || k==sKallow_other_keys) */ /* n=n-2; */ /* else */ /* goto error; */ /* } */ /* FIXME better message */ /* if (n!=0) FEunexpected_keyword(Cnil); */ /* return 0; */ /* error: */ /* FEunexpected_keyword(k); */ /* return -1; */ /* }}} */ int parse_key_new_new(int n, object *base, struct key *keys, object first, va_list ap) {object *new; COERCE_VA_LIST_KR_NEW(new,first,ap,n); /* from here down identical to parse_key_rest */ new = new + n ; {int j=keys->n; object **p= (object **)(keys->defaults); while (--j >=0) base[j]=*(p[j]); } {if (n==0){ return 0;} {int allow = keys->allow_other_keys; object k; if (!allow) { int i; for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); if (i>0 && new[-i+1]!=Cnil) allow=1; } top: while (n>=2) {int i= keys->n; iobject *ke=keys->keys ; new = new -2; k = *new; while(--i >= 0) {if (*(*(ke++)).o == k) {base[i]= new[1]; n=n-2; goto top; }} /* the key is a new one */ if (allow || k==sKallow_other_keys) n=n-2; else goto error; } /* FIXME better message */ if (n!=0) FEunexpected_keyword(Cnil); return 0; error: FEunexpected_keyword(k); return -1; }}} /* static int */ /* parse_key_rest(object rest, int n, object *base, struct key *keys, va_list ap) */ /* {object *new; */ /* COERCE_VA_LIST(new,ap,n); */ /* copy the rest arg */ /* {object *p = new; */ /* int m = n; */ /* while (--m >= 0) */ /* {rest->c.c_car = *p++; */ /* rest = rest->c.c_cdr;}} */ /* new = new + n ; */ /* {int j=keys->n; */ /* object *p= (object *)(keys->defaults); */ /* while (--j >=0) base[j]=p[j]; */ /* } */ /* {if (n==0){ return 0;} */ /* {int allow = keys->allow_other_keys; */ /* object k; */ /* if (!allow) { */ /* int i; */ /* for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */ /* if (i>0 && new[-i+1]!=Cnil) */ /* allow=1; */ /* } */ /* top: */ /* while (n>=2) */ /* {int i= keys->n; */ /* iobject *ke=keys->keys ; */ /* new = new -2; */ /* k = *new; */ /* while(--i >= 0) */ /* {if ((*(ke++)).o == k) */ /* {base[i]= new[1]; */ /* n=n-2; */ /* goto top; */ /* }} */ /* the key is a new one */ /* if (allow || k==sKallow_other_keys) */ /* n=n-2; */ /* else */ /* goto error; */ /* } */ /* FIXME better message */ /* if (n!=0) FEunexpected_keyword(Cnil); */ /* return 0; */ /* error: */ /* FEunexpected_keyword(k); */ /* return -1; */ /* }}} */ int parse_key_rest_new(object rest, int n, object *base, struct key *keys, object first,va_list ap) {object *new; COERCE_VA_LIST_KR_NEW(new,first,ap,n); /* copy the rest arg */ {object *p = new; int m = n; while (--m >= 0) {rest->c.c_car = *p++; rest = rest->c.c_cdr;}} new = new + n ; {int j=keys->n; while (--j >=0) base[j]=*keys->defaults[j].o; } {if (n==0){ return 0;} {int allow = keys->allow_other_keys; object k; if (!allow) { int i; for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); if (i>0 && new[-i+1]!=Cnil) allow=1; } top: while (n>=2) {int i= keys->n; iobject *ke=keys->keys ; new = new -2; k = *new; while(--i >= 0) {if (*(*(ke++)).o == k) {base[i]= new[1]; n=n-2; goto top; }} /* the key is a new one */ if (allow || k==sKallow_other_keys) n=n-2; else goto error; } /* FIXME better message */ if (n!=0) FEunexpected_keyword(Cnil); return 0; error: FEunexpected_keyword(k); return -1; }}} static object foo[2]={Cnil,OBJNULL}; void set_key_struct(struct key *ks, object data) {int i=ks->n; while (--i >=0) {ks->keys[i].o = data->cfd.cfd_self+ks->keys[i].i; if (ks->defaults != (void *)Cstd_key_defaults) {fixnum m=ks->defaults[i].i; ks->defaults[i].o= (m==-2 ? foo : m==-1 ? foo+1 : data->cfd.cfd_self+m);} }} #undef AUX DEF_ORDINARY("ALLOW-OTHER-KEYS",sKallow_other_keys,KEYWORD,""); void gcl_init_bind(void) { ANDoptional = make_ordinary("&OPTIONAL"); enter_mark_origin(&ANDoptional); ANDrest = make_ordinary("&REST"); enter_mark_origin(&ANDrest); ANDkey = make_ordinary("&KEY"); enter_mark_origin(&ANDkey); ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS"); enter_mark_origin(&ANDallow_other_keys); ANDaux = make_ordinary("&AUX"); enter_mark_origin(&ANDaux); make_constant("LAMBDA-LIST-KEYWORDS", make_cons(ANDoptional, make_cons(ANDrest, make_cons(ANDkey, make_cons(ANDallow_other_keys, make_cons(ANDaux, make_cons(make_ordinary("&WHOLE"), make_cons(make_ordinary("&ENVIRONMENT"), make_cons(make_ordinary("&BODY"), Cnil))))))))); make_constant("LAMBDA-PARAMETERS-LIMIT", make_fixnum(MAX_ARGS+1)); three_nils.nil3_self[0] = Cnil; three_nils.nil3_self[1] = Cnil; three_nils.nil3_self[2] = Cnil; six_nils.nil6_self[0] = Cnil; six_nils.nil6_self[1] = Cnil; six_nils.nil6_self[2] = Cnil; six_nils.nil6_self[3] = Cnil; six_nils.nil6_self[4] = Cnil; six_nils.nil6_self[5] = Cnil; } gcl-2.6.14/o/frame.c0000755000175000017500000000365114360276512012477 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* frame.c frame and non-local jump */ #include "include.h" void unwind(frame_ptr fr, object tag) { signals_allowed = 0; nlj_fr = fr; nlj_tag = tag; nlj_active = TRUE; while (frs_top != fr && frs_top->frs_class == FRS_CATCH && frs_top >= frs_org /* && frs_top->frs_class != FRS_PROTECT && frs_top->frs_class != FRS_CATCHALL */ ) { --frs_top; } if (frs_topfrs_lex; ihs_top = frs_top->frs_ihs; bds_unwind(frs_top->frs_bds_top); in_signal_handler = frs_top->frs_in_signal_handler; signals_allowed=sig_normal; longjmp((void *)frs_top->frs_jmpbuf, 0); /* never reached */ } frame_ptr frs_sch (object frame_id) { frame_ptr top; for (top = frs_top; top >= frs_org; top--) if (top->frs_val == frame_id && top->frs_class == FRS_CATCH) return(top); return(NULL); } frame_ptr frs_sch_catch(object frame_id) { frame_ptr top; for(top = frs_top; top >= frs_org ;top--) if ((top->frs_val == frame_id && top->frs_class == FRS_CATCH) || top->frs_class == FRS_CATCHALL ) return(top); return(NULL); } gcl-2.6.14/o/user_init.c0000755000175000017500000000007314360276512013401 0ustar cammcamm#include "include.h" object user_init(void) {return Cnil;} gcl-2.6.14/o/Vmalloc.c0000755000175000017500000000374514360276512013006 0ustar cammcammChanges file for /usr/local/src/kcl/c/malloc.c Created on Tue Oct 24 20:01:59 1989 Usage \n@s[Original text\n@s|Replacement Text\n@s] See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c for a program to merge change files. Anything not between "\n@s[" and "\n@s]" is a simply a comment. This file was constructed using emacs and merge.el Enhancements Copyright (c) W. Schelter All rights reserved. by (Bill Schelter) wfs@carl.ma.utexas.edu ****Change:(orig (131 131 c)) @s[ * if the power of 2 is correct. */ @s| * if the power of 2 is correct. */ /* Oct 89: wfs@cs.utexas.edu: Created V/ merge file for * changes for GCL. * Calls to sbrk replaced by alloc_page. Remove some of the * additions for emacs. * NB: According to the gnu license you may only distribute the * verbatim copy of the gnumalloc.c. Thus we only distribute * an abbreviated diffs file from that verbatim copy. */ @s] ****Change:(orig (162 162 c)) @s[#include "getpagesize.h" @s|#define getpagesize() 2048 @s] ****Change:(orig (170 170 c)) @s[#include @s|/* #include */ @s] ****Change:(orig (202 202 a)) @s[static char *data_space_start; @s|static char *data_space_start; #define PAGEWIDTH 11 char *alloc_page(); #define sbrk our_sbrk char * our_sbrk(x) int x; {return alloc_page((x >> PAGEWIDTH));} @s] ****Change:(orig (338 378 d)) @s[#ifndef VMS /* Maximum virtual memory on VMS is difficult to calculate since it * depends on several dynmacially changing things. Also, alignment * isn't that important. That is why much of the code here is ifdef'ed @s, sbrk (1024 - ((int) cp & 0x3ff)); #endif /* not VMS */ @s| @s] ****Change:(orig (385 385 c)) @s[ if ((cp = sbrk (1 << (siz + 3))) == (char *) -1) @s| if ((cp = sbrk (1 << (siz + 3)))==0) @s] ****Change:(orig (387 393 d)) @s[#ifndef VMS if ((int) cp & 7) { /* shouldn't happen, but just in case */ cp = (char *) (((int) cp + 8) & ~7); @s, } #endif /* not VMS */ @s| @s] gcl-2.6.14/o/unexec-19.29.c0000755000175000017500000010174714360276512013361 0ustar cammcamm/* Copyright (C) 1985,86,87,88,92,93,94 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* Modified to support SysVr3 shared libraries by James Van Artsdalen * of Dell Computer Corporation. james@bigtex.cactus.org. */ /* There are several compilation parameters affecting unexec: * COFF Define this if your system uses COFF for executables. * COFF_ENCAPSULATE Define this if you are using the GNU coff encapsulated a.out format. This is closer to a.out than COFF. You should *not* define COFF if you define COFF_ENCAPSULATE Otherwise we assume you use Berkeley format. * NO_REMAP Define this if you do not want to try to save Emacs's pure data areas as part of the text segment. Saving them as text is good because it allows users to share more. However, on machines that locate the text area far from the data area, the boundary cannot feasibly be moved. Such machines require NO_REMAP. Also, remapping can cause trouble with the built-in startup routine /lib/crt0.o, which defines `environ' as an initialized variable. Dumping `environ' as pure does not work! So, to use remapping, you must write a startup routine for your machine in Emacs's crt0.c. If NO_REMAP is defined, Emacs uses the system's crt0.o. * SECTION_ALIGNMENT Some machines that use COFF executables require that each section start on a certain boundary *in the COFF file*. Such machines should define SECTION_ALIGNMENT to a mask of the low-order bits that must be zero on such a boundary. This mask is used to control padding between segments in the COFF file. If SECTION_ALIGNMENT is not defined, the segments are written consecutively with no attempt at alignment. This is right for unmodified system V. * SEGMENT_MASK Some machines require that the beginnings and ends of segments *in core* be on certain boundaries. For most machines, a page boundary is sufficient. That is the default. When a larger boundary is needed, define SEGMENT_MASK to a mask of the bits that must be zero on such a boundary. * A_TEXT_OFFSET(HDR) Some machines count the a.out header as part of the size of the text segment (a_text); they may actually load the header into core as the first data in the text segment. Some have additional padding between the header and the real text of the program that is counted in a_text. For these machines, define A_TEXT_OFFSET(HDR) to examine the header structure HDR and return the number of bytes to add to `a_text' before writing it (above and beyond the number of bytes of actual program text). HDR's standard fields are already correct, except that this adjustment to the `a_text' field has not yet been made; thus, the amount of offset can depend on the data in the file. * A_TEXT_SEEK(HDR) If defined, this macro specifies the number of bytes to seek into the a.out file before starting to write the text segment. * EXEC_MAGIC For machines using COFF, this macro, if defined, is a value stored into the magic number field of the output file. * ADJUST_EXEC_HEADER This macro can be used to generate statements to adjust or initialize nonstandard fields in the file header * ADDR_CORRECT(ADDR) Macro to correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This macro has a default definition which is usually right. This default definition is a no-op on most machines (where a pointer looks like an int) but not on all machines. */ #ifndef emacs #define PERROR(arg) perror (arg); return -1 #else #define IN_UNEXEC #include "config.h" #define PERROR(file) report_error (file, new) #endif #ifndef CANNOT_DUMP /* all rest of file! */ #ifdef COFF_ENCAPSULATE int need_coff_header = 1; #include /* The location might be a poor assumption */ #else #ifdef MSDOS #include #define filehdr external_filehdr #define scnhdr external_scnhdr #define syment external_syment #define auxent external_auxent #define n_numaux e_numaux #define n_type e_type struct aouthdr { unsigned short magic; /* type of file */ unsigned short vstamp; /* version stamp */ unsigned long tsize; /* text size in bytes, padded to FW bdry*/ unsigned long dsize; /* initialized data " " */ unsigned long bsize; /* uninitialized data " " */ unsigned long entry; /* entry pt. */ unsigned long text_start;/* base of text used for this file */ unsigned long data_start;/* base of data used for this file */ }; #else /* not MSDOS */ #include #endif /* not MSDOS */ #endif /* Define getpagesize if the system does not. Note that this may depend on symbols defined in a.out.h. */ #include "getpagesize.h" #ifndef makedev /* Try to detect types.h already loaded */ #include #endif /* makedev */ #include #include #include #include /* Must be after sys/types.h for USG and BSD4_1*/ #ifdef USG5 #include #endif #ifndef O_RDONLY #define O_RDONLY 0 #endif #ifndef O_RDWR #define O_RDWR 2 #endif #ifdef UNIXSAVE extern char etext; #endif #ifndef start_of_data extern char *start_of_text (); /* Start of text */ extern char *start_of_data (); /* Start of initialized data */ #endif #ifdef COFF static long block_copy_start; /* Old executable start point */ static struct filehdr f_hdr; /* File header */ static struct aouthdr f_ohdr; /* Optional file header (a.out) */ long bias; /* Bias to add for growth */ long lnnoptr; /* Pointer to line-number info within file */ #define SYMS_START block_copy_start static long text_scnptr; static long data_scnptr; #else /* not COFF */ #ifdef HPUX extern void *sbrk (); #else #if 0 /* Some systems with __STDC__ compilers still declare this `char *' in some header file, and our declaration conflicts. The return value is always cast, so it should be harmless to leave it undefined. Hopefully machines with different size pointers and ints declare sbrk in a header file. */ #ifdef __STDC__ extern void *sbrk (); #else extern char *sbrk (); #endif /* __STDC__ */ #endif #endif /* HPUX */ #define SYMS_START ((long) N_SYMOFF (ohdr)) /* Some machines override the structure name for an a.out header. */ #ifndef EXEC_HDR_TYPE #define EXEC_HDR_TYPE struct exec #endif #ifdef HPUX #ifdef HP9000S200_ID #define MY_ID HP9000S200_ID #else #include #define MY_ID MYSYS #endif /* no HP9000S200_ID */ static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; #define N_TXTOFF(x) TEXT_OFFSET(x) #define N_SYMOFF(x) LESYM_OFFSET(x) static EXEC_HDR_TYPE hdr, ohdr; #else /* not HPUX */ #if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX) static struct bhdr hdr, ohdr; #define a_magic fmagic #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #define a_entry entry #define N_BADMAG(x) \ (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) #define NEWMAGIC FMAGIC #else /* IRIS or IBMAIX or not USG */ static EXEC_HDR_TYPE hdr, ohdr; #define NEWMAGIC ZMAGIC #endif /* IRIS or IBMAIX not USG */ #endif /* not HPUX */ static int unexec_text_start; static int unexec_data_start; #ifdef COFF_ENCAPSULATE /* coffheader is defined in the GNU a.out.encap.h file. */ struct coffheader coffheader; #endif #endif /* not COFF */ static int pagemask; /* Correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This is a no-op on ordinary machines, but not on all. */ #ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ #define ADDR_CORRECT(x) ((char *)(x) - (char*)0) #endif #ifdef emacs #include "lisp.h" static report_error (file, fd) char *file; int fd; { if (fd) close (fd); report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); } #endif /* emacs */ #define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 #define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 #define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 static report_error_1 (int fd, char *msg, int a1, int a2) { close (fd); #ifdef emacs error (msg, a1, a2); #else fprintf (stderr, msg, a1, a2); fprintf (stderr, "\n"); #endif } static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name); static int copy_text_and_data (int new, int a_out); static int copy_sym (int new, int a_out, char *a_name, char *new_name); static void mark_x (char *name); /* **************************************************************** * unexec * * driving logic. */ unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) { int new, a_out = -1; if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) { PERROR (a_name); } if ((new = creat (new_name, 0666)) < 0) { PERROR (new_name); } if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 || copy_text_and_data (new, a_out) < 0 || copy_sym (new, a_out, a_name, new_name) < 0 #ifdef COFF #ifndef COFF_BSD_SYMBOLS || adjust_lnnoptrs (new, a_out, new_name) < 0 #endif #endif ) { close (new); /* unlink (new_name); /* Failed, unlink new a.out */ return -1; } close (new); if (a_out >= 0) close (a_out); mark_x (new_name); return 0; } /* **************************************************************** * make_hdr * * Make the header in the new a.out from the header in core. * Modify the text and data sizes. */ static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) { int tem; #ifdef COFF auto struct scnhdr f_thdr; /* Text section header */ auto struct scnhdr f_dhdr; /* Data section header */ auto struct scnhdr f_bhdr; /* Bss section header */ auto struct scnhdr scntemp; /* Temporary section header */ register int scns; #endif /* COFF */ #ifdef USG_SHARED_LIBRARIES extern unsigned int bss_end; #else unsigned int bss_end; #endif pagemask = getpagesize () - 1; /* Adjust text/data boundary. */ #ifdef NO_REMAP data_start = (int) start_of_data (); #else /* not NO_REMAP */ if (!data_start) data_start = (int) start_of_data (); #endif /* not NO_REMAP */ data_start = ADDR_CORRECT (data_start); #ifdef SEGMENT_MASK data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ #else data_start = data_start & ~pagemask; /* (Down) to page boundary. */ #endif bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; bss_end &= ~ pagemask; /* Adjust data/bss boundary. */ if (bss_start != 0) { bss_start = (ADDR_CORRECT (bss_start) + pagemask); /* (Up) to page bdry. */ bss_start &= ~ pagemask; if (bss_start > bss_end) { ERROR1 ("unexec: Specified bss_start (%u) is past end of program", bss_start); } } else bss_start = bss_end; if (data_start > bss_start) /* Can't have negative data size. */ { ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", data_start, bss_start); } #ifdef COFF /* Salvage as much info from the existing file as possible */ if (a_out >= 0) { if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (a_name); } block_copy_start += sizeof (f_hdr); if (f_hdr.f_opthdr > 0) { if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (a_name); } block_copy_start += sizeof (f_ohdr); } /* Loop through section headers, copying them in */ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) { PERROR (a_name); } if (scntemp.s_scnptr > 0L) { if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) block_copy_start = scntemp.s_scnptr + scntemp.s_size; } if (strcmp (scntemp.s_name, ".text") == 0) { f_thdr = scntemp; } else if (strcmp (scntemp.s_name, ".data") == 0) { f_dhdr = scntemp; } else if (strcmp (scntemp.s_name, ".bss") == 0) { f_bhdr = scntemp; } } } else { ERROR0 ("can't build a COFF file from scratch yet"); } /* Now we alter the contents of all the f_*hdr variables to correspond to what we want to dump. */ #ifdef USG_SHARED_LIBRARIES /* The amount of data we're adding to the file is distance from the * end of the original .data space to the current end of the .data * space. */ bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size); #endif f_hdr.f_flags |= (F_RELFLG | F_EXEC); #ifdef TPIX f_hdr.f_nscns = 3; #endif #ifdef EXEC_MAGIC f_ohdr.magic = EXEC_MAGIC; #endif #ifndef NO_REMAP f_ohdr.text_start = (long) start_of_text (); f_ohdr.tsize = data_start - f_ohdr.text_start; f_ohdr.data_start = data_start; #endif /* NO_REMAP */ f_ohdr.dsize = bss_start - f_ohdr.data_start; f_ohdr.bsize = bss_end - bss_start; #ifndef KEEP_OLD_TEXT_SCNPTR /* On some machines, the old values are right. ??? Maybe on all machines with NO_REMAP. */ f_thdr.s_size = f_ohdr.tsize; f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); #endif /* KEEP_OLD_TEXT_SCNPTR */ #ifdef ADJUST_TEXT_SCNHDR_SIZE /* On some machines, `text size' includes all headers. */ f_thdr.s_size -= f_thdr.s_scnptr; #endif /* ADJUST_TEST_SCNHDR_SIZE */ lnnoptr = f_thdr.s_lnnoptr; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_thdr.s_scnptr = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef TPIX f_thdr.s_scnptr = 0xd0; #endif text_scnptr = f_thdr.s_scnptr; #ifdef ADJUST_TEXTBASE text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr)); #endif #ifndef KEEP_OLD_PADDR f_dhdr.s_paddr = f_ohdr.data_start; #endif /* KEEP_OLD_PADDR */ f_dhdr.s_vaddr = f_ohdr.data_start; f_dhdr.s_size = f_ohdr.dsize; f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef DATA_SECTION_ALIGNMENT /* Some systems require special alignment of the data section only. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; #endif /* DATA_SECTION_ALIGNMENT */ data_scnptr = f_dhdr.s_scnptr; #ifndef KEEP_OLD_PADDR f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; #endif /* KEEP_OLD_PADDR */ f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; f_bhdr.s_size = f_ohdr.bsize; f_bhdr.s_scnptr = 0L; #ifndef USG_SHARED_LIBRARIES bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; #endif if (f_hdr.f_symptr > 0L) { f_hdr.f_symptr += bias; } if (f_thdr.s_lnnoptr > 0L) { f_thdr.s_lnnoptr += bias; } #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER; #endif /* ADJUST_EXEC_HEADER */ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (new_name); } if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (new_name); } #ifndef USG_SHARED_LIBRARIES if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) { PERROR (new_name); } if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) { PERROR (new_name); } if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) { PERROR (new_name); } #else /* USG_SHARED_LIBRARIES */ /* The purpose of this code is to write out the new file's section * header table. * * Scan through the original file's sections. If the encountered * section is one we know (.text, .data or .bss), write out the * correct header. If it is a section we do not know (such as * .lib), adjust the address of where the section data is in the * file, and write out the header. * * If any section precedes .text or .data in the file, this code * will not adjust the file pointer for that section correctly. */ /* This used to use sizeof (f_ohdr) instead of .f_opthdr. .f_opthdr is said to be right when there is no optional header. */ lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (a_name); if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ { if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ { if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ { if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) PERROR (new_name); } else { if (scntemp.s_scnptr) scntemp.s_scnptr += bias; if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (new_name); } } #endif /* USG_SHARED_LIBRARIES */ return (0); #else /* if not COFF */ /* Get symbol table info from header of a.out file if given one. */ if (a_out >= 0) { #ifdef COFF_ENCAPSULATE if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader) { PERROR(a_name); } if (coffheader.f_magic != COFF_MAGIC) { ERROR1("%s doesn't have legal coff magic number\n", a_name); } #endif if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) { PERROR (a_name); } if (N_BADMAG (ohdr)) { ERROR1 ("invalid magic number in %s", a_name); } hdr = ohdr; } else { #ifdef COFF_ENCAPSULATE /* We probably could without too much trouble. The code is in gld * but I don't have that much time or incentive. */ ERROR0 ("can't build a COFF file from scratch yet"); #else #ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ bzero ((void *)&hdr, sizeof hdr); #else bzero (&hdr, sizeof hdr); #endif #endif } unexec_text_start = (long) start_of_text (); unexec_data_start = data_start; /* Machine-dependent fixup for header, or maybe for unexec_text_start */ #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER; #endif /* ADJUST_EXEC_HEADER */ hdr.a_trsize = 0; hdr.a_drsize = 0; if (entry_address != 0) hdr.a_entry = entry_address; hdr.a_bss = bss_end - bss_start; hdr.a_data = bss_start - data_start; #ifdef NO_REMAP hdr.a_text = ohdr.a_text; #else /* not NO_REMAP */ hdr.a_text = data_start - unexec_text_start; #ifdef A_TEXT_OFFSET hdr.a_text += A_TEXT_OFFSET (ohdr); #endif #endif /* not NO_REMAP */ #ifdef COFF_ENCAPSULATE /* We are encapsulating BSD format within COFF format. */ { struct coffscn *tp, *dp, *bp; tp = &coffheader.scns[0]; dp = &coffheader.scns[1]; bp = &coffheader.scns[2]; tp->s_size = hdr.a_text + sizeof(struct exec); dp->s_paddr = data_start; dp->s_vaddr = data_start; dp->s_size = hdr.a_data; bp->s_paddr = dp->s_vaddr + dp->s_size; bp->s_vaddr = bp->s_paddr; bp->s_size = hdr.a_bss; coffheader.tsize = tp->s_size; coffheader.dsize = dp->s_size; coffheader.bsize = bp->s_size; coffheader.text_start = tp->s_vaddr; coffheader.data_start = dp->s_vaddr; } if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader) { PERROR(new_name); } #endif /* COFF_ENCAPSULATE */ if (write (new, &hdr, sizeof hdr) != sizeof hdr) { PERROR (new_name); } #if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */ /* This adjustment was done above only #ifndef NO_REMAP, so only undo it now #ifndef NO_REMAP. */ /* #ifndef NO_REMAP */ #endif #ifdef A_TEXT_OFFSET hdr.a_text -= A_TEXT_OFFSET (ohdr); #endif return 0; #endif /* not COFF */ } /* **************************************************************** * copy_text_and_data * * Copy the text and data segments from memory to the new a.out */ static int copy_text_and_data (int new, int a_out) { register char *end; register char *ptr; #ifdef COFF #ifdef USG_SHARED_LIBRARIES int scns; struct scnhdr scntemp; /* Temporary section header */ /* The purpose of this code is to write out the new file's section * contents. * * Step through the section table. If we know the section (.text, * .data) do the appropriate thing. Otherwise, if the section has * no allocated space in the file (.bss), do nothing. Otherwise, * the section has space allocated in the file, and is not a section * we know. So just copy it. */ lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR ("temacs"); if (!strcmp (scntemp.s_name, ".text")) { lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); } else if (!strcmp (scntemp.s_name, ".data")) { lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); } else if (!scntemp.s_scnptr) ; /* do nothing - no data for this section */ else { char page[BUFSIZ]; int size, n; long old_a_out_ptr = lseek (a_out, 0, 1); lseek (a_out, scntemp.s_scnptr, 0); for (size = scntemp.s_size; size > 0; size -= sizeof (page)) { n = size > sizeof (page) ? sizeof (page) : size; if (read (a_out, page, n) != n || write (new, page, n) != n) PERROR ("emacs"); } lseek (a_out, old_a_out_ptr, 0); } } #else /* COFF, but not USG_SHARED_LIBRARIES */ lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; #ifdef HEADER_INCL_IN_TEXT /* For Gould UTX/32, text starts after headers */ ptr = (char *) (ptr + text_scnptr); #endif /* HEADER_INCL_IN_TEXT */ end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); #endif /* USG_SHARED_LIBRARIES */ #else /* if not COFF */ /* Some machines count the header as part of the text segment. That is to say, the header appears in core just before the address that start_of_text returns. For them, N_TXTOFF is the place where the header goes. We must adjust the seek to the place after the header. Note that at this point hdr.a_text does *not* count the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ #ifdef A_TEXT_SEEK lseek (new, (long) A_TEXT_SEEK (hdr), 0); #else lseek (new, (long) N_TXTOFF (hdr), 0); #endif /* no A_TEXT_SEEK */ #ifdef RISCiX /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. * There is a little table in crt0.o that is filled at link time with * the min and current brk positions, among other things. When start * runs, it copies the table to where these parameters live during * execution. This data is in text space, so it cannot be modified here * before saving the executable, so the data is written manually. In * addition, the table does not have a label, and the nearest accessable * label (mcount) is not prefixed with a '_', thus making it inaccessable * from within C programs. To overcome this, emacs's executable is passed * through the command 'nm %s | fgrep mcount' into a pipe, and the * resultant output is then used to find the address of 'mcount'. As far as * is possible to determine, in RISC-iX releases prior to 1.2, the negative * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is * 0x30. bss_end has been rounded up to page boundary. This solution is * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and * avoids the need for a custom version of crt0.o for emacs which has its * table in data space. */ { char command[1024]; char errbuf[1024]; char address_text[32]; int proforma[4]; FILE *pfile; char *temp_ptr; char c; int mcount_address, mcount_offset, count; extern char *_execname; /* The use of _execname is incompatible with RISCiX 1.1 */ sprintf (command, "nm '%s' | fgrep mcount", _execname); if ( (pfile = popen(command, "r")) == NULL) { sprintf (errbuf, "Could not open pipe"); PERROR (errbuf); } count=0; while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31)) address_text[count++]=c; address_text[count]=0; if ((count == 0) || pclose(pfile) != NULL) { sprintf (errbuf, "Failed to execute the command '%s'\n", command); PERROR (errbuf); } sscanf(address_text, "%x", &mcount_address); ptr = (char *) unexec_text_start; mcount_offset = (char *)mcount_address - ptr; #ifdef RISCiX_1_1 #define EDATA_OFFSET 0x2c #else #define EDATA_OFFSET 0x30 #endif end = ptr + mcount_offset - EDATA_OFFSET; write_segment (new, ptr, end); proforma[0] = bss_end; /* becomes _edata */ proforma[1] = bss_end; /* becomes _end */ proforma[2] = bss_end; /* becomes _minbrk */ proforma[3] = bss_end; /* becomes _curbrk */ write (new, proforma, 16); temp_ptr = ptr; ptr = end + 16; end = temp_ptr + hdr.a_text; write_segment (new, ptr, end); } #else /* !RISCiX */ ptr = (char *) unexec_text_start; end = ptr + hdr.a_text; write_segment (new, ptr, end); #endif /* RISCiX */ ptr = (char *) unexec_data_start; end = ptr + hdr.a_data; /* This lseek is certainly incorrect when A_TEXT_OFFSET and I believe it is a no-op otherwise. Let's see if its absence ever fails. */ /* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ write_segment (new, ptr, end); #endif /* not COFF */ return 0; } write_segment (int new, register char *ptr, register char *end) { register int i, nwrite, ret; char buf[80]; extern int errno; char zeros[128]; int amt_to_write = (1 << 13); bzero (zeros, sizeof zeros); for (i = 0; ptr < end;) { /* distance to next multiple of amt_to_write . */ AGAIN: nwrite = (((int) ptr + amt_to_write) & -amt_to_write) - (int) ptr; /* But not beyond specified end. */ if (nwrite > end - ptr) nwrite = end - ptr; ret = write (new, ptr, nwrite); /* If write gets a page fault, it means we reached a gap between the old text segment and the old data segment. This gap has probably been remapped into part of the text segment. So write zeros for it. */ if (ret == -1 #ifdef EFAULT && errno == EFAULT #endif ) { if (amt_to_write > sizeof(zeros)) { amt_to_write = sizeof(zeros); goto AGAIN; } write (new, zeros, nwrite); } else if (nwrite != ret) { sprintf (buf, "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", ptr, new, nwrite, ret, errno); PERROR (buf); } i += nwrite; ptr += nwrite; } } /* **************************************************************** * copy_sym * * Copy the relocation information and symbol table from the a.out to the new */ static int copy_sym (int new, int a_out, char *a_name, char *new_name) { char page[1024]; int n; if (a_out < 0) return 0; #ifdef COFF if (SYMS_START == 0L) return 0; #endif /* COFF */ #ifdef COFF if (lnnoptr) /* if there is line number info */ lseek (a_out, lnnoptr, 0); /* start copying from there */ else #endif /* COFF */ lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ while ((n = read (a_out, page, sizeof page)) > 0) { if (write (new, page, n) != n) { PERROR (new_name); } } if (n < 0) { PERROR (a_name); } return 0; } /* **************************************************************** * mark_x * * After successfully building the new a.out, mark it executable */ static void mark_x (char *name) { struct stat sbuf; int um; int new = 0; /* for PERROR */ um = umask (777); umask (um); if (stat (name, &sbuf) == -1) { PERROR (name); } sbuf.st_mode |= 0111 & ~um; if (chmod (name, sbuf.st_mode) == -1) PERROR (name); } #ifdef COFF #ifndef COFF_BSD_SYMBOLS /* * If the COFF file contains a symbol table and a line number section, * then any auxiliary entries that have values for x_lnnoptr must * be adjusted by the amount that the line number section has moved * in the file (bias computed in make_hdr). The #@$%&* designers of * the auxiliary entry structures used the absolute file offsets for * the line number entry rather than an offset from the start of the * line number section! * * When I figure out how to scan through the symbol table and pick out * the auxiliary entries that need adjustment, this routine will * be fixed. As it is now, all such entries are wrong and sdb * will complain. Fred Fish, UniSoft Systems Inc. */ /* This function is probably very slow. Instead of reopening the new file for input and output it should copy from the old to the new using the two descriptors already open (WRITEDESC and READDESC). Instead of reading one small structure at a time it should use a reasonable size buffer. But I don't have time to work on such things, so I am installing it as submitted to me. -- RMS. */ adjust_lnnoptrs (writedesc, readdesc, new_name) int writedesc; int readdesc; char *new_name; { register int nsyms; register int new; #if defined (amdahl_uts) || defined (pfa) SYMENT symentry; AUXENT auxentry; #else struct syment symentry; union auxent auxentry; #endif if (!lnnoptr || !f_hdr.f_symptr) return 0; #ifdef MSDOS if ((new = writedesc) < 0) #else if ((new = open (new_name, O_RDWR)) < 0) #endif { PERROR (new_name); return -1; } lseek (new, f_hdr.f_symptr, 0); for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) { read (new, &symentry, SYMESZ); if (symentry.n_numaux) { read (new, &auxentry, AUXESZ); nsyms++; if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) { auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; lseek (new, -AUXESZ, 1); write (new, &auxentry, AUXESZ); } } } #ifndef MSDOS close (new); #endif return 0; } #endif /* COFF_BSD_SYMBOLS */ #endif /* COFF */ #endif /* not CANNOT_DUMP */ #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/saveu370.c0000755000175000017500000000767514360276512012774 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* unixsave.c */ #include #include #include #ifdef u370 #undef u370 #include filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } memory_save(original_file, save_file) char *original_file, *save_file; { MEM_SAVE_LOCALS; struct scnhdr shdrs[15]; char *data_begin, *data_end; int original_data; FILE *original, *save; register int n; register char *p; extern char *sbrk(); fclose(stdin); original = fopen(original_file, "r"); if (stdin != original || original->_file != 0) { fprintf(stderr, "Can't open the original file.\n"); exit(1); } setbuf(original, stdin_buf); fclose(stdout); unlink(save_file); n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } setbuf(save, stdout_buf); /* READ_HEADER; */ fread(&fileheader, sizeof(fileheader), 1, original); fread(&header, fileheader.f_opthdr, 1, original); fread(&shdrs[1],sizeof(sectionheader),fileheader.f_nscns,original); data_begin = (char *) shdrs[2].s_paddr; data_end = core_end; original_data = header.a_data; header.a_data = data_end - data_begin; diff = header.a_data - original_data; header.a_bss = sbrk(0) - core_end; fileheader.f_symptr += diff; fwrite(&fileheader, sizeof(fileheader), 1, save); fwrite(&header,fileheader.f_opthdr , 1, save); /* .text */ #define INC_IF(x) if(x) x = x+diff; /* .data */ INC_IF(shdrs[2].s_size); /* .bss */ shdrs[3].s_paddr += diff; shdrs[3].s_vaddr += diff; shdrs[3].s_size = header.a_bss; for (n = 1; n <= fileheader.f_nscns; n++) { INC_IF(shdrs[n].s_lnnoptr); if(n>=3) {INC_IF(shdrs[n].s_scnptr);} }; fwrite(&shdrs[1],sizeof(sectionheader),fileheader.f_nscns,save); filecpy(save,original,shdrs[2].s_scnptr - ftell(save)); for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) if (n > BUFSIZ) fwrite(p, BUFSIZ, 1, save); else if (n > 0) { fwrite(p, 1, n, save); break; } else break; fseek(original, original_data, 1); COPY_TO_SAVE; fclose(original); fclose(save); } Lsave() { char filename[256]; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); _cleanup(); /* { FILE *p; int nfile; nfile = NUMBER_OPEN_FILES; for (p = &_iob[3]; p < &_iob[nfile]; p++) fclose(p); } */ memory_save(kcl_self, filename); /* _exit(0); */ exit(0); /* no return */ } #include "page.h" #undef sbrk char *sbrk (); char * sbrk1(n) { char *m1; char * m = sbrk(0); /* printf("Calling sbrk(0x%08x),[cur,rently sbrk(0)=0x%08x,core_end=0x%08x," ,n,m,core_end); */ m1 = sbrk(n); if (core_end && m1!= m) { if (m1 < m || ((int)m1 % PAGESIZE)) { error("unexpected sbrk"); } while ( m < m1) {type_map[page(m)] = t_other; m += PAGESIZE; } core_end = m;} /* printf("Returning 0x%08x\n",m); */ return m;} gcl-2.6.14/o/backq.c0000755000175000017500000001517114360276512012466 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" #define attach(x) (vs_head = make_cons(x, vs_head)) #define make_list (vs_popp,vs_head=list(2,vs_head,*vs_top)) #define QUOTE 1 #define EVAL 2 #define LIST 3 #define LISTA 4 #define APPEND 5 #define NCONC 6 #define siScomma_at sSYB #define siScomma_dot sSYZ object sSYB; object sSYZ; static void kwote_cdr(void) { object x; x = vs_head; if (type_of(x) == t_symbol) { if ((enum stype)x->s.s_stype == stp_constant && x->s.s_dbind == x) return; goto KWOTE; } else if (type_of(x) == t_cons || type_of(x) == t_vector) goto KWOTE; return; KWOTE: vs_head = make_cons(vs_head, Cnil); vs_head = make_cons(sLquote, vs_head); } static void kwote_car(void) { object x; x = vs_top[-2]; if (type_of(x) == t_symbol) { if ((enum stype)x->s.s_stype == stp_constant && x->s.s_dbind == x) return; goto KWOTE; } else if (type_of(x) == t_cons || type_of(x) == t_vector) goto KWOTE; return; KWOTE: vs_top[-2] = make_cons(vs_top[-2], Cnil); vs_top[-2] = make_cons(sLquote, vs_top[-2]); } /* Backq_cdr(x) pushes a form on vs and returns one of QUOTE the form should be quoted EVAL the form should be evaluated LIST the form should be applied to LIST LISTA the form should be applied to LIST* APPEND the form should be applied to APPEND NCONC the form should be applied to NCONC */ static int backq_cdr(object x) { int a, d; cs_check(x); if (type_of(x) != t_cons) { vs_push(x); return(QUOTE); } if (x->c.c_car == siScomma) { vs_push(x->c.c_cdr); return(EVAL); } if (x->c.c_car == siScomma_at || x->c.c_car == siScomma_dot) FEerror(",@ or ,. has appeared in an illegal position.", 0); a = backq_car(x->c.c_car); d = backq_cdr(x->c.c_cdr); if (d == QUOTE) switch (a) { case QUOTE: vs_popp; vs_head = x; return(QUOTE); case EVAL: if (vs_head == Cnil) { stack_cons(); return(LIST); } if (type_of(vs_head) == t_cons && vs_head->c.c_cdr == Cnil) { vs_head = vs_head->c.c_car; kwote_cdr(); make_list; return(LIST); } kwote_cdr(); make_list; return(LISTA); case APPEND: if (vs_head == Cnil) { vs_popp; return(EVAL); } kwote_cdr(); make_list; return(APPEND); case NCONC: if (vs_head == Cnil) { vs_popp; return(EVAL); } kwote_cdr(); make_list; return(NCONC); default: error("backquote botch"); } if (d == EVAL) switch (a) { case QUOTE: kwote_car(); make_list; return(LISTA); case EVAL: make_list; return(LISTA); case APPEND: make_list; return(APPEND); case NCONC: make_list; return(NCONC); default: error("backquote botch"); } if (a == d) { stack_cons(); return(d); } switch (d) { case LIST: if (a == QUOTE) { kwote_car(); stack_cons(); return(d); } if (a == EVAL) { stack_cons(); return(d); } attach(sLlist); break; case LISTA: if (a == QUOTE) { kwote_car(); stack_cons(); return(d); } if (a == EVAL) { stack_cons(); return(d); } attach(sLlistA); break; case APPEND: attach(sLappend); break; case NCONC: attach(sLnconc); break; default: error("backquote botch"); } switch (a) { case QUOTE: kwote_car(); make_list; return(LISTA); case EVAL: make_list; return(LISTA); case APPEND: make_list; return(APPEND); case NCONC: make_list; return(NCONC); default: error("backquote botch"); return(0); } } /* Backq_car(x) pushes a form on vs and returns one of QUOTE the form should be quoted EVAL the form should be evaluated APPEND the form should be appended into the outer form NCONC the form should be nconc'ed into the outer form */ int backq_car(object x) { int d; cs_check(x); if (type_of(x) != t_cons) { vs_push(x); return(QUOTE); } if (x->c.c_car == siScomma) { vs_push(x->c.c_cdr); return(EVAL); } if (x->c.c_car == siScomma_at) { vs_push(x->c.c_cdr); return(APPEND); } if (x->c.c_car == siScomma_dot) { vs_push(x->c.c_cdr); return(NCONC); } d = backq_cdr(x); switch (d) { case QUOTE: return(QUOTE); case EVAL: return(EVAL); case LIST: attach(sLlist); break; case LISTA: attach(sLlistA); break; case APPEND: attach(sLappend); break; case NCONC: attach(sLnconc); break; default: error("backquote botch"); } return(EVAL); } static object backq(object x) { int a; a = backq_car(x); if (a == APPEND || a == NCONC) FEerror(",@ or ,. has appeared in an illegal position.", 0); if (a == QUOTE) kwote_cdr(); return(vs_pop); } static object fLcomma_reader(object x0, object x1) { object w; object in, c; /* 2 args */ in = x0; if (backq_level <= 0) FEerror("A comma has appeared out of a backquote.", 0); c = peek_char(FALSE, in); if (c == code_char('@')) { w = siScomma_at; read_char(in); } else if (c == code_char('.')) { w=siScomma_dot; read_char(in); } else w=siScomma; --backq_level; x0 = make_cons(w,read_object(in)); backq_level++; RETURN1(x0); } static object fLbackquote_reader(object x0, object x1) { object in; /* 2 args */ in = x0; backq_level++; x0 = read_object(in); --backq_level; x0 = backq(x0); RETURN1(x0); } #define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0); #define MAKE_AFUN(addr,n) MakeAfun(addr,F_ARGD(n,n,NONE,ARGTYPES(OO,OO,OO,OO)),0); DEF_ORDINARY("Y",sSY,SI,""); DEF_ORDINARY("YB",sSYB,SI,""); DEF_ORDINARY("YZ",sSYZ,SI,""); DEF_ORDINARY("LIST*",sLlistA,LISP,""); DEF_ORDINARY("APPEND",sLappend,LISP,""); DEF_ORDINARY("NCONC",sLnconc,LISP,""); DEF_ORDINARY("APPLY",sLapply,LISP,""); DEF_ORDINARY("VECTOR",sLvector,LISP,""); void gcl_init_backq(void) { object r; r = standard_readtable; r->rt.rt_self['`'].rte_chattrib = cat_terminating; r->rt.rt_self['`'].rte_macro = MAKE_AFUN(fLbackquote_reader,2); r->rt.rt_self[','].rte_chattrib = cat_terminating; r->rt.rt_self[','].rte_macro = MAKE_AFUN(fLcomma_reader,2); backq_level = 0; } gcl-2.6.14/o/hash.d0000755000175000017500000004474514360276512012342 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define NEED_MP_H #include #include "include.h" object sLeq; object sLeql; object sLequal; object sLequalp; object sKsize; object sKrehash_size; object sKrehash_threshold; object sKstatic; #define MHSH(a_) ((a_) & ~(1UL<<(sizeof(a_)*CHAR_SIZE-1))) typedef union {/*FIXME size checks*/ float f; unsigned int ul; } F2ul; typedef union { double d; unsigned int ul[2]; } D2ul; typedef unsigned char uchar; static ufixnum rtb[256]; #define MASK(n) (~(~0UL << (n))) static ufixnum ufixhash(ufixnum g) { ufixnum i,h; for (h=i=0;i>=CHAR_SIZE,i++) h^=rtb[g&MASK(CHAR_SIZE)]; return h; } static ufixnum uarrhash(void *v,void *ve,uchar off,uchar bits) { uchar *c=v,*ce=ve-(bits+(off ? off : CHAR_SIZE)>CHAR_SIZE ? 1 : 0),i; ufixnum h=0,*u=v,*ue=u+(ce-c)/sizeof(*u); if (!off) for (;u>(CHAR_SIZE*sizeof(*c)-off) : 0))]; for (i=off;bits--;i=(i+1)%CHAR_SIZE,c=i ? c : c+1) h^=rtb[((*c)>>(CHAR_SIZE-1-i))&0x1]; return h; } #define hash_eq1(x) ufixhash((ufixnum)x/sizeof(x)) #define hash_eq(x) MHSH(hash_eq1(x)) static ufixnum hash_eql(object x) { ufixnum h; switch (type_of(x)) { case t_fixnum: h=ufixhash(fix(x)); break; case t_character: h = rtb[char_code(x)]; break; case t_bignum: { MP_INT *mp = MP(x); void *v1=mp->_mp_d,*ve=v1+mpz_size(mp); h=uarrhash(v1,ve,0,0); } break; case t_ratio: h=hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den); break; case t_shortfloat: /*FIXME, sizeof int = sizeof float*/ { F2ul u; u.f=sf(x); h=ufixhash(u.ul); } break; case t_longfloat: { D2ul u; u.d=lf(x); h=ufixhash(u.ul[0])^ufixhash(u.ul[1]); } break; case t_complex: h=hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag); break; default: h=hash_eq1(x); break; } return MHSH(h); } ufixnum ihash_equal(object x,int depth) { enum type tx; ufixnum h=0; cs_check(x); BEGIN: if (depth++ <=3) switch ((tx=type_of(x))) { case t_cons: h^=ihash_equal(x->c.c_car,depth)^rtb[abs((int)(depth%(sizeof(rtb)/sizeof(*rtb))))];/*FIXME: clang faulty warning*/ x = x->c.c_cdr; goto BEGIN; break; case t_symbol: case t_string: h^=uarrhash(x->st.st_self,x->st.st_self+x->st.st_fillp,0,0); break; case t_package: break; case t_bitvector: { ufixnum l=x->bv.bv_offset+x->bv.bv_fillp; void *v1=x->bv.bv_self+x->bv.bv_offset/CHAR_SIZE,*ve=v1+l/CHAR_SIZE+(x->bv.bv_fillp && l%CHAR_SIZE ? 1 : 0); h^=uarrhash(v1,ve,x->bv.bv_offset%CHAR_SIZE,x->bv.bv_fillp%CHAR_SIZE); } break; case t_pathname: h^=ihash_equal(x->pn.pn_host,depth); h^=ihash_equal(x->pn.pn_device,depth); h^=ihash_equal(x->pn.pn_directory,depth); h^=ihash_equal(x->pn.pn_name,depth); h^=ihash_equal(x->pn.pn_type,depth); /* version is ignored unless logical host */ /* if ((type_of(x->pn.pn_host) == t_string) && */ /* (pathname_lookup(x->pn.pn_host,sSApathname_logicalA) != Cnil)) */ /* h^=ihash_equal(x->pn.pn_version,depth); */ h^=ihash_equal(x->pn.pn_version,depth); break; default: h^=hash_eql(x); break; } return MHSH(h); } DEFUN_NEW("HASH-EQUAL",object,fShash_equal,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum depth),"") { RETURN1(make_fixnum(ihash_equal(x,depth))); } unsigned long ihash_equalp(object x,int depth) { enum type tx; unsigned long h = 0,j; long i; cs_check(x); BEGIN: if (depth++ <=3) switch ((tx=type_of(x))) { case t_cons: h += ihash_equalp(x->c.c_car,depth); x = x->c.c_cdr; goto BEGIN; break; case t_symbol: /* x=coerce_to_string(x); */ { ufixnum len=x->st.st_fillp; uchar *s=(void *)x->st.st_self; for (;len--;) h^=rtb[toupper(*s++)]; } break; case t_package: break; /* case t_simple_string: */ case t_string: /* case t_simple_bitvector: */ /* case t_simple_vector: */ case t_bitvector: case t_vector: h^=ufixhash(j=x->st.st_fillp); j=j>10 ? 10 : j; for (i=0;ia.a_rank); for (i=0;ia.a_dims[i]); j=x->a.a_dim; j=j>10 ? 10 : j; for (i=0;iht.ht_nent); h^=ufixhash(x->ht.ht_test); j=j>10 ? 10 : j; for (i=0;iht.ht_self[i].hte_key!=OBJNULL) switch (x->ht.ht_test) { case htt_eq: h^=(((unsigned long)x->ht.ht_self[i].hte_key)>>3) ^ ihash_equalp(x->ht.ht_self[i].hte_value,depth); break; case htt_eql: h^=hash_eql(x->ht.ht_self[i].hte_key) ^ ihash_equalp(x->ht.ht_self[i].hte_value,depth); break; case htt_equal: h^=ihash_equal(x->ht.ht_self[i].hte_key,depth) ^ ihash_equalp(x->ht.ht_self[i].hte_value,depth); break; case htt_equalp: h^=ihash_equalp(x->ht.ht_self[i].hte_key,depth) ^ ihash_equalp(x->ht.ht_self[i].hte_value,depth); break; } break; case t_pathname: h^=ihash_equalp(x->pn.pn_host,depth); h^=ihash_equalp(x->pn.pn_device,depth); h^=ihash_equalp(x->pn.pn_directory,depth); h^=ihash_equalp(x->pn.pn_name,depth); h^=ihash_equalp(x->pn.pn_type,depth); h^=ihash_equalp(x->pn.pn_version,depth); break; case t_structure: { unsigned char *s_type; struct s_data *def; def=S_DATA(x->str.str_def); s_type= & SLOT_TYPE(x->str.str_def,0); h^=ihash_equalp(def->name,depth); for (i=0;ilength;i++) if (s_type[i]==aet_object) h^=ihash_equalp(x->str.str_self[i],depth); else h^=ufixhash((long)x->str.str_self[i]); break; } case t_character: { vs_mark; /*FIXME*/ object *base=vs_base; vs_base=vs_top; vs_push(x); Lchar_upcase(); x=vs_base[0]; vs_base=base; vs_reset; h^=hash_eql(x); break; } case t_fixnum: case t_bignum: case t_ratio: case t_shortfloat: case t_longfloat: h^=hash_eql(make_longfloat(number_to_double(x))); break; default: h^=hash_eql(x); break; } return MHSH(h); } DEFUN_NEW("HASH-EQUALP",object,fShash_equalp,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum depth),"") { RETURN1(make_fixnum(ihash_equalp(x,depth))); } struct htent * gethash(object key, object ht) { long s,q; struct htent *e,*ee,*first_open=NULL; static struct htent dummy={OBJNULL,OBJNULL}; if (ht->ht.ht_cache && ht->ht.ht_cache->hte_key==key) return ht->ht.ht_cache; ht->ht.ht_cache=NULL; #define eq(x,y) x==y #define hash_loop(t_,i_) \ for (q=ht->ht.ht_size,s=i_%q;s>=0;q=s,s=s?0:-1) \ for (e=ht->ht.ht_self,ee=e+q,e+=s;ehte_key; \ if (hkey==OBJNULL) { \ if (e->hte_value==OBJNULL) return first_open ? first_open : e; \ if (!first_open) first_open=e; \ } else if (t_(key,hkey)) return ht->ht.ht_cache=e; \ } switch (ht->ht.ht_test) { case htt_eq: hash_loop(eq,hash_eq(key)); break; case htt_eql: hash_loop(eql,hash_eql(key)); break; case htt_equal: hash_loop(equal,ihash_equal(key,0)); break; case htt_equalp: hash_loop(equalp,ihash_equalp(key,0)); break; default: FEerror( "gethash: Hash table not of type EQ, EQL, or EQUAL." ,0); return &dummy; } return first_open ? first_open : (FEerror("No free spot in hashtable ~S.", 1, ht),&dummy); } static void extend_hashtable(object); void sethash(key, hashtable, value) object key, hashtable, value; { int i; bool over=FALSE; struct htent *e; i = hashtable->ht.ht_nent + 1; if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum) over = i >= fix(hashtable->ht.ht_rhthresh); else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat) over = i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh); else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat) over = i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh); if (over) extend_hashtable(hashtable); e = gethash(key, hashtable); if (e->hte_key == OBJNULL) hashtable->ht.ht_nent++; e->hte_key = key; e->hte_value = value; } static void extend_hashtable(hashtable) object hashtable; { object old; int new_size=0, i; if (type_of(hashtable->ht.ht_rhsize) == t_fixnum) new_size = hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize); else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat) new_size = hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize); else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat) new_size = hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize); {BEGIN_NO_INTERRUPT; old = alloc_object(t_hashtable); old->ht = hashtable->ht; vs_push(old); hashtable->ht.ht_cache=hashtable->ht.ht_self = NULL; hashtable->ht.ht_size = new_size; if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum) hashtable->ht.ht_rhthresh = make_fixnum(fix(hashtable->ht.ht_rhthresh) + (new_size - old->ht.ht_size)); hashtable->ht.ht_self = hashtable->ht.ht_static ? (struct htent *)alloc_contblock(new_size * sizeof(struct htent)) : (struct htent *)alloc_relblock(new_size * sizeof(struct htent)); for (i = 0; i < new_size; i++) { hashtable->ht.ht_self[i].hte_key = OBJNULL; hashtable->ht.ht_self[i].hte_value = OBJNULL; } for (i = 0; i < old->ht.ht_size; i++) { if (old->ht.ht_self[i].hte_key != OBJNULL) sethash(old->ht.ht_self[i].hte_key, hashtable, old->ht.ht_self[i].hte_value); } hashtable->ht.ht_nent = old->ht.ht_nent; vs_popp; END_NO_INTERRUPT;} } DEFVAR("*DEFAULT-HASH-TABLE-SIZE*",sSAdefault_hash_table_sizeA,SI,make_fixnum(1024),""); DEFVAR("*DEFAULT-HASH-TABLE-REHASH-SIZE*",sSAdefault_hash_table_rehash_sizeA,SI,make_shortfloat((shortfloat)1.5),""); DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thresholdA,SI,make_shortfloat((shortfloat)0.7),""); DEFUN_NEW("MAKE-HASH-TABLE",object,fLmake_hash_table,LISP,0,63,NONE,OO,OO,OO,OO,(object first,...),"") { int i=0,nargs=VFUN_NARGS; object *base=vs_top,test,size,rehash_size,rehash_threshold,staticp,h; enum httest htt=0; va_list ap; if (nargs>0) { vs_push(first); va_start(ap,first); for (i++;is.s_dbind : *base;base++; rehash_size=base[5]==Cnil ? sSAdefault_hash_table_rehash_sizeA->s.s_dbind : *base;base++; rehash_threshold=base[5]==Cnil ? sSAdefault_hash_table_rehash_thresholdA->s.s_dbind : *base;base++; staticp=base[5]==Cnil ? Cnil : *base; vs_top=base; if (test == sLeq || test == sLeq->s.s_gfdef) htt = htt_eq; else if (test == sLeql || test == sLeql->s.s_gfdef) htt = htt_eql; else if (test == sLequal || test == sLequal->s.s_gfdef) htt = htt_equal; else if (test == sLequalp || test == sLequalp->s.s_gfdef) htt = htt_equalp; else FEerror("~S is an illegal hash-table test function.", 1, test); if (type_of(size) != t_fixnum || 0 < fix(size)) ; else FEerror("~S is an illegal hash-table size.", 1, size); if ((type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size)) || (type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size)) || (type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))) ; else FEerror("~S is an illegal hash-table rehash-size.", 1, rehash_size); if ((type_of(rehash_threshold) == t_fixnum && 0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size)) || (type_of(rehash_threshold) == t_shortfloat && 0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0) || (type_of(rehash_threshold) == t_longfloat && 0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)) ; else FEerror("~S is an illegal hash-table rehash-threshold.", 1, rehash_threshold); {BEGIN_NO_INTERRUPT; h = alloc_object(t_hashtable); h->ht.ht_test = (short)htt; h->ht.ht_size = fix(size); h->ht.ht_rhsize = rehash_size; h->ht.ht_rhthresh = rehash_threshold; h->ht.ht_cache=NULL; h->ht.ht_nent = 0; h->ht.ht_static = staticp!=Cnil ? 1 : 0; h->ht.ht_self = NULL; h->ht.ht_self = h->ht.ht_static ? (struct htent *)alloc_contblock(fix(size) * sizeof(struct htent)) : (struct htent *)alloc_relblock(fix(size) * sizeof(struct htent)); for(i = 0; i < fix(size); i++) { h->ht.ht_self[i].hte_key = OBJNULL; h->ht.ht_self[i].hte_value = OBJNULL; } END_NO_INTERRUPT;} RETURN1(h); } object gcl_make_hash_table(object test) { return (VFUN_NARGS=2,FFN(fLmake_hash_table)(sKtest,test)); } LFD(Lhash_table_p)(void) { check_arg(1); if(type_of(vs_base[0]) == t_hashtable) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Lgethash)() { int narg; struct htent *e; narg = vs_top - vs_base; if (narg < 2) too_few_arguments(); else if (narg == 2) vs_push(Cnil); else if (narg > 3) too_many_arguments(); check_type_hash_table(&vs_base[1]); e = gethash(vs_base[0], vs_base[1]); if (e->hte_key != OBJNULL) { vs_base[0] = e->hte_value; vs_base[1] = Ct; } else { vs_base[0] = vs_base[2]; vs_base[1] = Cnil; } vs_popp; } DEFUN_NEW("GETHASH1",object,fSgethash1,SI,2,2,NONE,OO,OO,OO,OO,(object k,object h),"") { struct htent *e; check_type_hash_table(&h); e = gethash(k,h); return e->hte_key != OBJNULL ? e->hte_value : Cnil; } LFD(siLhash_set)() { check_arg(3); check_type_hash_table(&vs_base[1]); sethash(vs_base[0], vs_base[1], vs_base[2]); vs_base += 2; } LFD(Lremhash)() { struct htent *e; check_arg(2); check_type_hash_table(&vs_base[1]); e = gethash(vs_base[0], vs_base[1]); if (e->hte_key != OBJNULL) { e->hte_key = OBJNULL; e->hte_value = Cnil; vs_base[1]->ht.ht_nent--; vs_base[0] = Ct; } else vs_base[0] = Cnil; vs_top = vs_base + 1; } LFD(Lclrhash)() { int i; check_arg(1); check_type_hash_table(&vs_base[0]); for(i = 0; i < vs_base[0]->ht.ht_size; i++) { vs_base[0]->ht.ht_self[i].hte_key = OBJNULL; vs_base[0]->ht.ht_self[i].hte_value = OBJNULL; } vs_base[0]->ht.ht_nent = 0; } LFD(Lhash_table_count)() { check_arg(1); check_type_hash_table(&vs_base[0]); vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent); } LFD(Lsxhash)() { check_arg(1); vs_base[0] = make_fixnum((ihash_equal(vs_base[0],0) & 0x7fffffff)); } LFD(Lmaphash)() { object *base = vs_base; object hashtable; int i; check_arg(2); check_type_hash_table(&vs_base[1]); hashtable = vs_base[1]; for (i = 0; i < hashtable->ht.ht_size; i++) { if(hashtable->ht.ht_self[i].hte_key != OBJNULL) ifuncall2(base[0], hashtable->ht.ht_self[i].hte_key, hashtable->ht.ht_self[i].hte_value); } vs_base[0] = Cnil; vs_popp; } DEFUNM_NEW("NEXT-HASH-TABLE-ENTRY",object,fSnext_hash_table_entry,SI,2,2,NONE,OO,OO,OO,OO,(object table,object ind),"For HASH-TABLE and for index I return three values: NEXT-START, the next KEY and its VALUE. NEXT-START will be -1 if there are no more entries, otherwise it will be a value suitable for passing as an index") { int i = fix(ind); check_type_hash_table(&table); if ( i < 0) { FEerror("needs non negative index",0);} while ( i < table->ht.ht_size) { if (table->ht.ht_self[i].hte_key != OBJNULL) { RETURN(3,object,make_fixnum(i+1), (RV(table->ht.ht_self[i].hte_key), RV(table->ht.ht_self[i].hte_value)));} i++;} RETURN(3,object,small_fixnum(-1),(RV(sLnil),RV(sLnil))); } DEFUN_NEW("HASH-TABLE-TEST",object,fLhash_table_test,LISP,1,1,NONE,OO,OO,OO,OO,(object table), "Given a HASH-TABLE return a symbol which specifies the function used in its test") { check_type_hash_table(&table); switch(table->ht.ht_test) { case htt_equalp: RETURN1(sLequalp); case htt_equal: RETURN1(sLequal); case htt_eq: RETURN1(sLeq); case htt_eql: RETURN1(sLeql); } FEerror("not able to get hash table test for ~a",1,table); RETURN1(sLnil); } DEFUN_NEW("HASH-TABLE-SIZE",object,fLhash_table_size,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") { check_type_hash_table(&table); RETURN1(make_fixnum(table->ht.ht_size)); } DEFUN_NEW("HASH-TABLE-REHASH-SIZE",object,fLhash_table_rehash_size,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") { check_type_hash_table(&table); RETURN1(table->ht.ht_rhsize); } DEFUN_NEW("HASH-TABLE-REHASH-THRESHOLD",object,fLhash_table_rehash_threshold,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") { check_type_hash_table(&table); RETURN1(table->ht.ht_rhthresh); } void gcl_init_hash() { sLeq = make_ordinary("EQ"); sLeql = make_ordinary("EQL"); sLequal = make_ordinary("EQUAL"); sLequalp = make_ordinary("EQUALP"); sKsize = make_keyword("SIZE"); sKtest = make_keyword("TEST"); sKrehash_size = make_keyword("REHASH-SIZE"); sKrehash_threshold = make_keyword("REHASH-THRESHOLD"); sKstatic = make_keyword("STATIC"); make_function("HASH-TABLE-P", Lhash_table_p); make_function("GETHASH", Lgethash); make_function("REMHASH", Lremhash); make_function("MAPHASH", Lmaphash); make_function("CLRHASH", Lclrhash); make_function("HASH-TABLE-COUNT", Lhash_table_count); make_function("SXHASH", Lsxhash); /* make_si_sfun("HASH-EQUAL",hash_equal,ARGTYPE2(f_object,f_fixnum) */ /* | RESTYPE(f_object)); */ make_si_function("HASH-SET", siLhash_set); { object x=find_symbol(make_simple_string("MOST-NEGATIVE-FIXNUM"),find_package(make_simple_string("SI"))); int i; x=number_negate(x->s.s_dbind); for (i=0;i 0 && (Bigm / (-Seven)) < 0 && ((-Seven) / Three) == -2 && (Seven / (-Three)) == -2 && ((-Seven)/ (-Three)) == 2) { printf("#define TRUNCATE_USE_C\n"); } printf("%d\n",(Smallm/-1)); }} #endif gcl-2.6.14/o/try.c0000755000175000017500000003405714360276512012227 0ustar cammcamm#ifndef UNIXSAVE #include "config.h" #endif /* #include */ /* _fmode */ #include #include #include #include #include #ifdef _GNU_H_WINDOWS_H #include "cyglacks.h" #endif #undef DBEGIN #define DBEGIN 0x400000 #include "ntheap.h" /* Info for keeping track of our heap. */ unsigned char *data_region_base = UNINIT_PTR; unsigned char *data_region_end = UNINIT_PTR; unsigned char *real_data_region_end = UNINIT_PTR; unsigned long data_region_size = UNINIT_LONG; unsigned long reserved_heap_size = UNINIT_LONG; void mymemcpy(void *a, void *b ,int n) { char *p=a; char *q=b; while(--n>=0) { int c = q[0]; q++; p[0]=c; p++; } } PIMAGE_SECTION_HEADER get_section_named(PIMAGE_NT_HEADERS nt_header,char *name); /* Dump out .data and .bss sections into a new executable. */ void unexec (char *new_name, char *old_name, void *start_data, void *start_bss, void *entry_address) { file_data in_file, out_file; unsigned long size,header_size,file_size,i; int last,foffset; PIMAGE_DOS_HEADER old_dos_header,new_dos_header; PIMAGE_NT_HEADERS old_nt_header,new_nt_header; PIMAGE_SECTION_HEADER old_section, old_sptr,old_data_section; PIMAGE_SECTION_HEADER new_section, new_sptr,new_data_section; PIMAGE_SECTION_HEADER s; long membase; char *base; if (!get_allocation_unit()) cache_system_info (); if (!open_input_file (&in_file, old_name)) { printf ("Failed to open %s (%d)...bailing.\n", old_name, GetLastError ()); exit (1); } old_dos_header = (PIMAGE_DOS_HEADER) in_file.file_base; if (old_dos_header->e_magic != IMAGE_DOS_SIGNATURE) { printf ("Unknown EXE header in %s...bailing.\n", in_file.name); exit (1); } old_nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) old_dos_header) + old_dos_header->e_lfanew); if (old_nt_header == NULL) { printf ("Failed to find IMAGE_NT_HEADER in %s...bailing.\n", in_file.name); exit (1); } /* Check the NT header signature ... */ if (old_nt_header->Signature != IMAGE_NT_SIGNATURE) { printf ("Invalid IMAGE_NT_SIGNATURE 0x%x in %s...bailing.\n", old_nt_header->Signature, in_file.name); } /* Flip through the sections for .data and .bss ... */ old_section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (old_nt_header); old_sptr= get_section_named(old_nt_header,".bss"); old_data_section= get_section_named(old_nt_header,".data"); header_size = old_section[0].PointerToRawData ; base = alloca(header_size); memcpy (base,in_file.file_base, header_size); new_dos_header = (PIMAGE_DOS_HEADER) base; new_nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) new_dos_header) + new_dos_header->e_lfanew); new_section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (new_nt_header); /* fix up the .bss section so that it is stored in file and mark its characteristics to show load. */ if (old_sptr->Characteristics != old_data_section->Characteristics) { int j; new_sptr= get_section_named(new_nt_header,".bss"); new_data_section= get_section_named(new_nt_header,".data"); new_sptr->Characteristics = old_data_section->Characteristics; j = new_sptr - new_section; #define S_ALIGN (1<<3) #define ROUND_UP(x,n) (((((unsigned int)x)+(n)-1)/(n))*(n)) new_sptr->PointerToRawData = new_sptr[1].PointerToRawData; new_sptr->SizeOfRawData = ROUND_UP(new_sptr->Misc.VirtualSize,S_ALIGN); foffset = new_sptr->SizeOfRawData; foffset = new_sptr->Misc.VirtualSize; for(i= new_sptr-new_section+1; i < new_nt_header->FileHeader.NumberOfSections; i++) {int tem ; new_section[i].PointerToRawData += foffset; tem = new_section[i].PointerToRawData + new_section[i].SizeOfRawData; if (last < tem ) last = tem; } } membase = old_nt_header->OptionalHeader.ImageBase; /* if there is new data from sbrk add it into .dataX section */ if (real_data_region_end - data_region_base) { s = get_section_named(new_nt_header,".dataX"); if (s ) { s->SizeOfRawData = real_data_region_end - data_region_base; } else { /* tack in a new section */ s = &new_section[new_nt_header->FileHeader.NumberOfSections]; *s = *new_data_section; strcpy(s->Name,".dataX"); s->VirtualAddress = data_region_base - (unsigned char *)membase; s->SizeOfRawData = real_data_region_end - data_region_base; s->PointerToRawData = ROUND_UP(last,S_ALIGN) ; new_nt_header->FileHeader.NumberOfSections += 1; if ((char *)&s[1] -base > header_size) { printf("unexpected fit"); /* to do: we will have to recode moving all sections up */ exit(1); } } } s = &new_section[new_nt_header->FileHeader.NumberOfSections-1]; file_size = s->PointerToRawData + s->SizeOfRawData; if (!open_output_file (&out_file, new_name, file_size)) { printf ("Failed to open %s (%d)...bailing.\n", new_name, GetLastError ()); exit (1); } for(i=0; i < file_size; i++) out_file.file_base[i]='a'; memcpy (out_file.file_base,base, header_size); for(i= 0; i < new_nt_header->FileHeader.NumberOfSections; i++) { PIMAGE_SECTION_HEADER new,old; new = &new_section[i]; old = &old_section[i]; if (new->Characteristics == old_data_section->Characteristics) { mymemcpy(out_file.file_base + new->PointerToRawData, (void *) (new->VirtualAddress + membase), new->SizeOfRawData) ; } else if (new->SizeOfRawData) { memcpy(out_file.file_base + new->PointerToRawData, in_file.file_base+ old->PointerToRawData ,new->SizeOfRawData); } } close_file_data (&in_file); close_file_data (&out_file); } PIMAGE_SECTION_HEADER get_section_named(PIMAGE_NT_HEADERS nt_header,char *name) { int i; PIMAGE_SECTION_HEADER section, data_section; section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (nt_header); for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) { if (strcmp(section[i].Name,name) == 0) return §ion[i]; } return 0; } int billy; const char jim[]="before"; char *jill = jim; main(int argc,char *argv[]) { printf("billy=%d,jill=%s",billy,jill); if (billy == 0) { billy=1; jill = sbrk(101); strcpy(jill,"hello"); } unexec(argv[1],argv[0],0,0,0); return 0; } /* File handling. */ int open_input_file (file_data *p_file, char *filename) { HANDLE file; HANDLE file_mapping; void *file_base; unsigned long size, upper_size; file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) return FALSE; size = GetFileSize (file, &upper_size); file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY, 0, size, NULL); if (!file_mapping) return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size); if (file_base == 0) return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; return TRUE; } int open_output_file (file_data *p_file, char *filename, unsigned long size) { HANDLE file; HANDLE file_mapping; void *file_base; file = CreateFile (filename, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) return FALSE; file_mapping = CreateFileMapping (file, NULL, PAGE_READWRITE, 0, size, NULL); if (!file_mapping) return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_WRITE, 0, 0, size); if (file_base == 0) return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; return TRUE; } /* Close the system structures associated with the given file. */ void close_file_data (file_data *p_file) { UnmapViewOfFile (p_file->file_base); CloseHandle (p_file->file_mapping); CloseHandle (p_file->file); } /* #include "lisp.h" */ /* for VALMASK */ #define VALMASK -1 /* try for 500 MB of address space */ #define VALBITS 29 static char * allocate_heap (void) { /* The base address for our GNU malloc heap is chosen in conjuction with the link settings for temacs.exe which control the stack size, the initial default process heap size and the executable image base address. The link settings and the malloc heap base below must all correspond; the relationship between these values depends on how NT and Win95 arrange the virtual address space for a process (and on the size of the code and data segments in temacs.exe). The most important thing is to make base address for the executable image high enough to leave enough room between it and the 4MB floor of the process address space on Win95 for the primary thread stack, the process default heap, and other assorted odds and ends (eg. environment strings, private system dll memory etc) that are allocated before temacs has a chance to grab its malloc arena. The malloc heap base can then be set several MB higher than the executable image base, leaving enough room for the code and data segments. Because some parts of Emacs can use rather a lot of stack space (for instance, the regular expression routines can potentially allocate several MB of stack space) we allow 8MB for the stack. Allowing 1MB for the default process heap, and 1MB for odds and ends, we can base the executable at 16MB and still have a generous safety margin. At the moment, the executable has about 810KB of code (for x86) and about 550KB of data - on RISC platforms the code size could be roughly double, so if we allow 4MB for the executable we will have plenty of room for expansion. Thus we would like to set the malloc heap base to 20MB. However, Win95 refuses to allocate the heap starting at this address, so we set the base to 27MB to make it happy. Since Emacs now leaves 28 bits available for pointers, this lets us use the remainder of the region below the 256MB line for our malloc arena - 229MB is still a pretty decent arena to play in! */ unsigned long base = DBEGIN; /* 27MB */ /* unsigned long base = 0x01B00000; */ /* 27MB */ unsigned long end = 1 << VALBITS; /* 256MB */ void *ptr = NULL; #define NTHEAP_PROBE_BASE 1 #if NTHEAP_PROBE_BASE /* This is never normally defined */ /* Try various addresses looking for one the kernel will let us have. */ while (!ptr && (base < end)) { reserved_heap_size = end - base; ptr = VirtualAlloc ((void *) base, get_reserved_heap_size (), MEM_RESERVE, PAGE_NOACCESS); base += 0x00100000; /* 1MB increment */ } #else reserved_heap_size = end - base; ptr = VirtualAlloc ((void *) base, get_reserved_heap_size (), MEM_RESERVE, PAGE_NOACCESS); #endif return ptr; } /* This gives us the page size and the size of the allocation unit on NT. */ SYSTEM_INFO sysinfo_cache; unsigned long syspage_mask = 0; int nt_major_version; int nt_minor_version; /* Distinguish between Windows NT and Windows 95. */ int os_subtype; /* Cache information describing the NT system for later use. */ void cache_system_info (void) { union { struct info { char major; char minor; short platform; } info; DWORD data; } version; if (os_subtype) return; /* Cache the version of the operating system. */ version.data = GetVersion (); nt_major_version = version.info.major; nt_minor_version = version.info.minor; if (version.info.platform & 0x8000) os_subtype = OS_WIN95; else os_subtype = OS_NT; /* Cache page size, allocation unit, processor type, etc. */ GetSystemInfo (&sysinfo_cache); syspage_mask = sysinfo_cache.dwPageSize - 1; } /* Emulate Unix sbrk. */ void * sbrk (unsigned long increment) { void *result; long size = (long) increment; cache_system_info(); /* Allocate our heap if we haven't done so already. */ if (data_region_base == UNINIT_PTR) { data_region_base = allocate_heap (); if (!data_region_base) return NULL; /* Ensure that the addresses don't use the upper tag bits since the Lisp type goes there. */ if (((unsigned long) data_region_base & ~VALMASK) != 0) { printf ("Error: The heap was allocated in upper memory.\n"); exit (1); } data_region_end = data_region_base; real_data_region_end = data_region_end; data_region_size = get_reserved_heap_size (); } result = data_region_end; /* If size is negative, shrink the heap by decommitting pages. */ if (size < 0) { int new_size; unsigned char *new_data_region_end; size = -size; /* Sanity checks. */ if ((data_region_end - size) < data_region_base) return NULL; /* We can only decommit full pages, so allow for partial deallocation [cga]. */ new_data_region_end = (data_region_end - size); new_data_region_end = (unsigned char *) ((long) (new_data_region_end + syspage_mask) & ~syspage_mask); new_size = real_data_region_end - new_data_region_end; real_data_region_end = new_data_region_end; if (new_size > 0) { /* Decommit size bytes from the end of the heap. */ if (!VirtualFree (real_data_region_end, new_size, MEM_DECOMMIT)) return NULL; } data_region_end -= size; } /* If size is positive, grow the heap by committing reserved pages. */ else if (size > 0) { /* Sanity checks. */ if ((data_region_end + size) > (data_region_base + get_reserved_heap_size ())) return NULL; /* Commit more of our heap. */ if (VirtualAlloc (data_region_end, size, MEM_COMMIT, PAGE_READWRITE) == NULL) return NULL; data_region_end += size; /* We really only commit full pages, so record where the real end of committed memory is [cga]. */ real_data_region_end = (unsigned char *) ((long) (data_region_end + syspage_mask) & ~syspage_mask); } return result; } gcl-2.6.14/o/run_process.c0000755000175000017500000004311114360276512013742 0ustar cammcamm/* By Mike Ballantyne */ /* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #include #define IN_RUN_PROCESS #include "include.h" #if defined(__CYGWIN__) #include #include #include #include #endif #ifdef HAVE_SYS_SOCKIO_H #include #endif #ifdef RUN_PROCESS void setup_stream_buffer(object); object make_two_way_stream(object, object); #if defined(__MINGW32__) || defined(__CYGWIN__) #include #include #include #define PIPE_BUFFER_SIZE 2048 void DisplayError ( char *pszAPI ); void PrepAndLaunchRedirectedChild ( HANDLE hChildStdOut, HANDLE hChildStdIn, HANDLE hChildStdErr, PROCESS_INFORMATION *process_info, char *name ); /* Run a process, with name holding the process name and arguments * To test: * * (setq fp (si::run-process "wish")) * */ void run_process ( char *name ) { object stream_in, stream_out, stream; HANDLE hChildStdoutReadTmp,hChildStdoutRead,hChildStdoutWrite; HANDLE hChildStdinWriteTmp,hChildStdinRead,hChildStdinWrite; HANDLE hChildStderrWrite; SECURITY_ATTRIBUTES sec_att; PROCESS_INFORMATION process_info; int ofd, ifd; FILE *ofp, *ifp; #if 0 DWORD dwRead, dwWritten; /*CHAR chBuf[1024] = "puts $env(PATH)\n\0";*/ CHAR chBuf[60] = "button .hello\npack .hello\n\0"; /*CHAR chBuf[60] = "button .hello\n\0"; */ #endif /* Set up the security attributes struct. */ sec_att.nLength= sizeof(SECURITY_ATTRIBUTES); sec_att.lpSecurityDescriptor = NULL; sec_att.bInheritHandle = TRUE; /* Create the child output r/w pipes. The read pipe is temporary. */ if ( ! CreatePipe ( &hChildStdoutReadTmp, &hChildStdoutWrite, &sec_att, PIPE_BUFFER_SIZE ) ) { DisplayError ( "CreatePipe stdout" ); } /* Duplicate the output write handle to be used as std error * avoiding problems when the spawned process closes a * stdout handle. */ if ( ! DuplicateHandle ( GetCurrentProcess (), hChildStdoutWrite, GetCurrentProcess (), &hChildStderrWrite, 0, TRUE, /* Inheritable */ DUPLICATE_SAME_ACCESS ) ) { DisplayError ( "DuplicateHandle stdout/stderr" ); } /* Likewise, the child input pipes. */ if ( ! CreatePipe ( &hChildStdinRead, &hChildStdinWriteTmp, &sec_att, PIPE_BUFFER_SIZE ) ) { DisplayError ( "CreatePipe stdin" ); } /* Make uninheritable copies of the output read handle and the * input write handles. Stops the spawned process from * inheriting non-closeable pipe handles. */ if ( ! DuplicateHandle ( GetCurrentProcess(), hChildStdoutReadTmp, GetCurrentProcess(), &hChildStdoutRead, /* The new handle. */ 0, FALSE, /* uninheritable. */ DUPLICATE_SAME_ACCESS ) ) { DisplayError ( "DuplicateHandle hChildStdoutRead" ); } if ( ! DuplicateHandle ( GetCurrentProcess (), hChildStdinWriteTmp, GetCurrentProcess(), &hChildStdinWrite, /* New handle. */ 0, FALSE, /* uninheritable. */ DUPLICATE_SAME_ACCESS ) ) { DisplayError ( "DuplicateHandle hChildStdinWrite" ); } /* Kill the inheritable temporary handles. */ if ( ! CloseHandle(hChildStdoutReadTmp ) ) DisplayError ( "CloseHandle: Temporary output read" ); if ( ! CloseHandle(hChildStdinWriteTmp ) ) DisplayError ( "CloseHandle: Temporary input write" ); PrepAndLaunchRedirectedChild ( hChildStdoutWrite, hChildStdinRead, hChildStderrWrite, &process_info, name ); /* Close pipe handles to ensure that no inappropriately accessible pipe handles * remain in this process. */ if ( ! CloseHandle ( hChildStdoutWrite ) ) DisplayError ( "CloseHandle: Output write" ); if ( ! CloseHandle ( hChildStdinRead ) ) DisplayError ( "CloseHandle: Input read" ); if ( ! CloseHandle ( hChildStderrWrite ) ) DisplayError ( "CloseHandle: Error write" ); #if 0 emsg("Before write\n" ); WriteFile ( hChildStdinWrite, chBuf, strlen ( chBuf ), &dwWritten, NULL); FlushFileBuffers ( hChildStdinWrite ); FlushFileBuffers ( hChildStdoutRead ); emsg("Before read\n" ); if ( ! ReadFile( hChildStdoutRead, chBuf, 2, &dwRead, NULL ) || dwRead == 0 ) { DisplayError ( "Nothing read\n" ); } else { emsg("Got Back: %s\n", chBuf ); } emsg("After read\n" ); #endif #if !defined (__CYGWIN__) /* Connect up the Lisp objects with the pipes. */ ofd = _open_osfhandle ( (int)hChildStdoutRead, _O_RDONLY | _O_TEXT ); ofp = _fdopen ( ofd, "r" ); ifd = _open_osfhandle ( (int)hChildStdinWrite, _O_WRONLY | _O_TEXT ); ifp = _fdopen ( ifd, "w" ); #else { extern int cygwin_attach_handle_to_fd(char *,int,HANDLE,mode_t,DWORD); static int rpn; massert(snprintf(FN1,sizeof(FN1),"run_process_stdin_%d",rpn)>0); ofd=cygwin_attach_handle_to_fd(FN1,-1,hChildStdoutRead,0,GENERIC_READ); ofp=fdopen(ofd,"r"); massert(snprintf(FN1,sizeof(FN1),"run_process_stdout_%d",rpn)>0); ifd=cygwin_attach_handle_to_fd(FN1,-1,hChildStdinWrite,0,GENERIC_WRITE); ifp=fdopen(ifd,"w"); rpn++; } #endif #if 0 { char buf[1024]; fprintf ( ifp, "button .wibble\n" ); fflush (ifp); fgets ( buf, 2, ofp ); emsg("run_process: ofd = %x, ofp = %x, ifd = %x, ifp = %x, buf[0] = %x, buf[1] = %x, buf = %s\n", ofd, ofp, ifd, ifp, buf[0], buf[1], buf ); } #endif stream_in = (object) alloc_object(t_stream); stream_in->sm.sm_mode = smm_input; stream_in->sm.sm_fp = ofp; stream_in->sm.sm_buffer = 0; stream_in->sm.sm_flags=0; stream_out = (object) alloc_object(t_stream); stream_out->sm.sm_mode = smm_output; stream_out->sm.sm_fp = ifp; stream_out->sm.sm_buffer = 0; stream_out->sm.sm_flags=0; setup_stream_buffer ( stream_in ); setup_stream_buffer ( stream_out ); stream = make_two_way_stream ( stream_in, stream_out ); vs_base[0] = stream; vs_base[1] = Cnil; vs_top = vs_base + 1; } /* Set up STARTUPINFO structure and launch redirected child. */ void PrepAndLaunchRedirectedChild ( HANDLE hChildStdOut, HANDLE hChildStdIn, HANDLE hChildStdErr, PROCESS_INFORMATION *process_info, char * name ) { STARTUPINFO startup_info; /* Set up the start up info struct. */ ZeroMemory ( &startup_info, sizeof ( STARTUPINFO ) ); startup_info.cb = sizeof ( STARTUPINFO ); startup_info.dwFlags = STARTF_USESTDHANDLES; startup_info.hStdOutput = hChildStdOut; startup_info.hStdInput = hChildStdIn; startup_info.hStdError = hChildStdErr; /* Launch the redirected process. */ if ( ! CreateProcess ( NULL, name, NULL, NULL, TRUE, 0, NULL, NULL, &startup_info, process_info ) ) { DisplayError("CreateProcess"); } } /* Display the error number and the corresponding Windows message. */ void DisplayError(char *pszAPI) { LPVOID lpvMessageBuffer; CHAR szPrintBuffer[512]; DWORD nCharsWritten; FormatMessage ( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError (), MAKELANGID ( LANG_NEUTRAL, SUBLANG_DEFAULT ), (LPTSTR) &lpvMessageBuffer, 0, NULL ); wsprintf ( szPrintBuffer, "%s:\n error code = %d.\n message = %s.\n", pszAPI, GetLastError(), (char *)lpvMessageBuffer ); WriteConsole ( GetStdHandle(STD_OUTPUT_HANDLE), szPrintBuffer, lstrlen ( szPrintBuffer ), &nCharsWritten, NULL ); LocalFree ( lpvMessageBuffer ); FEerror ( "RUN-PROCESS encountered problems.", 0 ); } void siLrun_process() { int i, j; int old = signals_allowed; object x; if (vs_top-vs_base!=2) FEwrong_no_args("RUN-PROCESS requires two arguments",make_fixnum(vs_top-vs_base)); check_type_string(&vs_base[0]); massert(snprintf(FN1,sizeof(FN1),"%.*s%n",vs_base[0]->st.st_fillp,vs_base[0]->st.st_self,&i)>=0); #if defined(__CYGWIN__) cygwin_conv_path(CCP_POSIX_TO_WIN_A,FN1,FN2,sizeof(FN2)); massert(snprintf(FN1,sizeof(FN1),"%s%n",FN2,&i)>=0); #endif x=vs_base[1]; for (;x!=Cnil;x=x->c.c_cdr,i+=j) { check_type_list(&x); check_type_string(&x->c.c_car); massert(snprintf(FN1+i,sizeof(FN1)-i," %.*s %n",x->c.c_car->st.st_fillp,x->c.c_car->st.st_self,&j)>=0); } signals_allowed = sig_at_read; run_process(FN1); signals_allowed = old; } void gcl_init_socket_function() { make_si_function("RUN-PROCESS", siLrun_process); } #else /* __MINGW32__ */ /* * System Include Files * * The system files here each define some part of the information needed to * compile the inet package. They need to exist of every host you port this * code to. I have added some comments that I hope will help you "find" * the file if it does not have the same name of your host. */ #undef PAGESIZE #include /* errno global, error codes for UNIX IO */ #include /* Data types definitions */ #include /* Socket definitions with out this forget it */ #include /* Internet address definition AF_INET etc... */ #include /* UNIX Signal codes */ #include /* IO control standard UNIx fair */ #include #include /* Function to set socket aync/interrupt */ #include /* Time for select time out */ #include /* Data Base interface for network files */ #include /* LISP - Lisp Wrapper for the "c" code. * * The lisp OBJECT is passed to the code and a string must be extracted * and null terminated to make it work with the "C" code. * * Lisp Interface code. */ static char *lisp_to_string(string) object string; { int i, len; char *sself; char *cstr; len = string->st.st_fillp; cstr = (char *) malloc (len+1); sself = &(string->st.st_self[0]); for (i=0; ih_addr, (char *)&sock_add.sin_addr, hp->h_length); sock_add.sin_family = hp->h_addrtype; sock_add.sin_port = htons((short)server); sock = socket( hp->h_addrtype, SOCK_STREAM , 0); if(sock < 1) { FEerror("No Sockets!",0); } if(connect(sock, (const struct sockaddr *)&sock_add, sizeof(sock_add)) < 0) { close(sock); FEerror("Connection Failed.",0); } pid = getpid(); #ifdef __CYGWIN__ if(fcntl(sock, F_SETOWN, pid) < 0) #else if(ioctl(sock, SIOCSPGRP, (char *)&pid) < 0 ) #endif { FEerror("Could not set process group of socket.",0); } #ifdef OVM_IO fcntl(sock,F_SETFL,FASYNC | FNDELAY); #else fcntl(sock,F_SETFL,FASYNC); #endif return(sock); } object make_stream(host_l,socket,smm) object host_l; int socket; enum smmode smm; { char *mode=NULL; object stream; FILE *fp; vs_mark; switch(smm) { case smm_input: mode = "r"; break; case smm_output: mode = "w"; break; default: FEerror("make_stream : wrong mode",0); } fp = fdopen(socket,mode); stream = (object) alloc_object(t_stream); stream->sm.sm_mode = (short)smm; stream->sm.sm_fp = fp; stream->sm.sm_buffer = 0; stream->sm.sm_object0 = sLcharacter; stream->sm.sm_object1 = host_l; stream->sm.sm_int = 0; stream->sm.sm_flags=0; vs_push(stream); setup_stream_buffer(stream); vs_reset; return(stream); } object make_socket_stream(host_l,port) object host_l; object port; { char *host = lisp_to_string(host_l); object stream_in; object stream_out; object stream; int socket; socket = open_connection(host, fix(port)); stream_in = make_stream(host_l,socket, smm_input); stream_out = make_stream(host_l,socket, smm_output); stream = make_two_way_stream(stream_in,stream_out); return(stream); } void FFN(siLmake_socket_stream)() { check_arg(2); vs_base[0] = make_socket_stream(vs_base[0], vs_base[1]); vs_popp; } /* * make 2 two-way streams */ object make_socket_pair() { int sockets_in[2]; int sockets_out[2]; FILE *fp1, *fp2; object stream_in, stream_out, stream; if (socketpair(AF_UNIX, SOCK_STREAM, 0, sockets_in) < 0) FEerror("Failure to open socket stream pair", 0); if (socketpair(AF_UNIX, SOCK_STREAM, 0, sockets_out) < 0) FEerror("Failure to open socket stream pair", 0); fp1 = fdopen(sockets_in[0], "r"); fp2 = fdopen(sockets_out[0], "w"); #ifdef OVM_IO {int pid; pid = getpid(); ioctl(sockets_in[0], SIOCSPGRP, (char *)&pid); if( fcntl(sockets_in[0], F_SETFL, FASYNC | FNDELAY) == -1) perror("Couldn't control socket"); } #endif stream_in = (object) alloc_object(t_stream); stream_in->sm.sm_mode = smm_input; stream_in->sm.sm_fp = fp1; stream_in->sm.sm_buffer = 0; stream_in->sm.sm_int = sockets_in[1]; stream_in->sm.sm_object0=stream_in->sm.sm_object1=OBJNULL; stream_in->sm.sm_flags = 0; stream_out = (object) alloc_object(t_stream); stream_out->sm.sm_mode = smm_output; stream_out->sm.sm_fp = fp2; stream_out->sm.sm_buffer = 0; setup_stream_buffer(stream_in); setup_stream_buffer(stream_out); stream_out->sm.sm_int = sockets_out[1]; stream_out->sm.sm_flags = 0; stream_out->sm.sm_object0=stream_out->sm.sm_object1=OBJNULL; stream = make_two_way_stream(stream_in, stream_out); return(stream); } /* the routines for spawning off a process with streams * * Assumes that istream and ostream are both associated * with "C" type streams. */ static void spawn_process_with_streams(object istream,object ostream,char *pname,char **argv) { int fdin; int fdout; if (istream->sm.sm_fp == NULL || ostream->sm.sm_fp == NULL) FEerror("Cannot spawn process with given stream", 0); fdin = istream->sm.sm_int; fdout = ostream->sm.sm_int; if (!pvfork()) { /* the child --- replace standard in and out with descriptors given */ close(0); massert(dup(fdin)>=0); close(1); massert(dup(fdout)>=0); close(fileno(istream->sm.sm_fp)); close(fileno(ostream->sm.sm_fp)); emsg("\n***** Spawning process %s ", pname); errno=0; execvp(pname,argv); _exit(128|(errno&0x7f)); } else { close(fdin); close(fdout); } } void run_process(char *filename,char **argv) { object stream = make_socket_pair(); spawn_process_with_streams(stream->sm.sm_object1,stream->sm.sm_object0,filename,argv); vs_base[0] = stream; vs_base[1] = Cnil; vs_top = vs_base + 2; } void FFN(siLrun_process)() { int i,j; object x; char **p1,**pp,*c,*spc=" \n\t"; if (vs_top-vs_base!=2) FEwrong_no_args("RUN-PROCESS requires two arguments",make_fixnum(vs_top-vs_base)); check_type_string(&vs_base[0]); massert(snprintf(FN1,sizeof(FN1),"%.*s%n",vs_base[0]->st.st_fillp,vs_base[0]->st.st_self,&i)>=0); x=vs_base[1]; for (;x!=Cnil;x=x->c.c_cdr,i+=j) { check_type_list(&x); check_type_string(&x->c.c_car); massert(snprintf(FN1+i,sizeof(FN1)-i," %.*s %n",x->c.c_car->st.st_fillp,x->c.c_car->st.st_self,&j)>=0); } for (pp=p1=(void *)FN2,c=FN1;(*pp=strtok(c,spc));c=NULL,pp++) massert((void *)(pp+1)<(void *)FN2+sizeof(FN2)); run_process(FN1,(char **)FN2); } void FFN(siLmake_socket_pair)() { make_socket_pair(); } void gcl_init_socket_function() { make_si_function("MAKE-SOCKET-STREAM", siLmake_socket_stream); make_si_function("MAKE-SOCKET-PAIR", siLmake_socket_pair); make_si_function("RUN-PROCESS", siLrun_process); } #ifdef MUST_USE_STATIC_LINK #ifdef __svr4__ getpagesize() { return PAGESIZE; } dlclose() {emsg("calling 'dl' function sun did not supply..exitting") ;do_gcl_abort();} dgettext() {dlclose();} dlopen() {dlclose();} dlerror() {dlclose();} dlsym() {dlclose();} #endif #endif /* MUST_USE_STATIC_LINK */ #endif /* __MINGW32__ */ #else /* no RUN_PROCESS */ /* static void */ /* init_socket_function(void) {;} */ #endif gcl-2.6.14/o/package.d0000755000175000017500000007133514360276512013005 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* package.d */ #include #include "include.h" #define HASHCOEF 12345 /* hashing coefficient */ void check_type_or_symbol_string_package(object *); #define INTERNAL 1 #define EXTERNAL 2 #define INHERITED 3 #define P_INTERNAL(x,j) ((x)->p.p_internal[(j) % (x)->p.p_internal_size]) #define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size]) #define string_eq(a,b) \ ((a)->st.st_fillp==(b)->st.st_fillp && \ bcmp((a)->st.st_self,(b)->st.st_self,(a)->st.st_fillp)==0) static bool member_string_eq(x, l) object x, l; { for (; consp(l); l = l->c.c_cdr) if (string_eq(x, l->c.c_car)) return(TRUE); return(FALSE); } static inline object coerce_to_str(object x) { switch(type_of(x)) { case t_string: case t_symbol: return x; case t_fixnum: case t_character: return coerce_to_string(x); /* printf("foobar\n");fflush(stdout); */ /* token->st.st_self=(char *)&x->ch.ch_code;/\*FIXME*\/ */ /* token->st.st_fillp=1; */ /* return token; */ default: TYPE_ERROR(x,TSor_symbol_string); return Cnil; } } static bool designate_package(object x,struct package *p) { switch(type_of(x)) { case t_string: case t_symbol: return string_eq(x,p->p_name) || member_string_eq(x, p->p_nicknames); break; case t_character: return designate_package(coerce_to_str(x),p); break; case t_package: return x==(object)p; break; default: FEwrong_type_argument(TSor_symbol_string_package,x); break; } return FALSE; } /* #define bad_package_name(a) (type_of(a)==t_string &&\ */ /* (memchr((a)->st.st_self,'-',(a)->st.st_fillp) || \ */ /* ((a)->st.st_self[0]=='*' && (a)->st.st_fillp==1))) */ #define check_package_designator(a) if (!stringp(a) && \ type_of(a)!=t_character && \ type_of(a)!=t_symbol && \ type_of(a)!=t_package) \ FEwrong_type_argument(TSor_symbol_string_package,(a)) #define check_type_or_symbol_string_package(a) check_package_designator(*a) static void rehash_pack(object **ptab,int *n,int m) { object *ntab; object *tab = *ptab; object l,ll; int k,i; i=0; k = *n; {BEGIN_NO_INTERRUPT; ntab= AR_ALLOC(alloc_contblock,m,object); *ptab = ntab; *n=m; while(ic.c_car)%m; ll=l->c.c_cdr; l->c.c_cdr = ntab[j]; ntab[j]=l; l=ll; } END_NO_INTERRUPT;} } /* some prime numbers suitable for package sizes */ static int package_sizes[]={ 97,251, 509, 1021, 2039, 4093, 8191, 16381, 32749, 65521, 131071, 262139, 524287, 1048573}; static int suitable_package_size(int n) {int *i=package_sizes; if (n>= 1000000) return 1048573; while(*i < n) { i++;} return *i;} /* Make_package(n, ns, ul, isize , esize) makes a package with name n, which must be a string or a symbol, and nicknames ns, which must be a list of strings or symbols, and uses packages in list ul, which must be a list of packages or package names i.e. strings or symbols. */ static object make_package(n, ns, ul,isize,esize) object n, ns, ul; int isize,esize; { object x, y; int i; vs_mark; { BEGIN_NO_INTERRUPT; BEGIN: n=coerce_to_string(n); if (find_package(n) != Cnil) { PACKAGE_CERROR(n,"Input new package","Package already exists",0); NEW_INPUT(n); goto BEGIN; } x = alloc_object(t_package); x->p.p_name = n; x->p.p_nicknames = Cnil; x->p.p_shadowings = Cnil; x->p.p_uselist = Cnil; x->p.p_usedbylist = Cnil; x->p.p_internal = NULL; x->p.p_external = NULL; x->p.p_internal_size = (isize ? isize : suitable_package_size(200)); x->p.p_external_size = (esize ? esize : suitable_package_size(60)); x->p.p_internal_fp =0; x->p.p_external_fp =0; vs_push(x); for (; !endp(ns); ns = ns->c.c_cdr) { n = ns->c.c_car; n=coerce_to_string(n); if (find_package(n) != Cnil) { vs_reset; PACKAGE_CERROR(n,"Input new nicknames list","Package already exists",0); NEW_INPUT(ns); goto BEGIN; } x->p.p_nicknames = make_cons(n, x->p.p_nicknames); } for (; !endp(ul); ul = ul->c.c_cdr) { if (type_of(ul->c.c_car) == t_package) y = ul->c.c_car; else { y = find_package(ul->c.c_car); if (y == Cnil) { PACKAGE_CERROR(ul->c.c_car,"Continue anyway","No such package",0); continue; } } x->p.p_uselist = make_cons(y, x->p.p_uselist); y->p.p_usedbylist = make_cons(x, y->p.p_usedbylist); } x->p.p_internal = AR_ALLOC(alloc_contblock,x->p.p_internal_size,object); for (i = 0; i < x->p.p_internal_size; i++) x->p.p_internal[i] = Cnil; x->p.p_external = AR_ALLOC(alloc_contblock,x->p.p_external_size,object); for (i = 0; i < x->p.p_external_size; i++) x->p.p_external[i] = Cnil; x->p.p_link = pack_pointer; pack_pointer = &(x->p); vs_reset; END_NO_INTERRUPT;} return(x); } static void use_package(object,object); static object in_package(n, ns, ul,isize,esize) object n, ns, ul; int isize,esize; { object x, y; vs_mark; BEGIN: x = find_package(n); if (x == Cnil) { #ifdef ANSI_COMMON_LISP PACKAGE_CERROR(n,"Input new package","No such package",0); NEW_INPUT(n); goto BEGIN; return Cnil; #else x = make_package(n, ns, ul,isize,esize); goto L; #endif } if (isize) rehash_pack(&(x->p.p_internal), &x->p.p_internal_size,isize); for (; !endp(ns); ns = ns->c.c_cdr) { n = ns->c.c_car; n=coerce_to_string(n); y = find_package(n); if (x == y) continue; if (y != Cnil) { PACKAGE_CERROR(n,"Input new nicknames list","Package already exists",0); NEW_INPUT(ns); goto BEGIN; } x->p.p_nicknames = make_cons(n, x->p.p_nicknames); } for (; !endp(ul); ul = ul->c.c_cdr) use_package(ul->c.c_car, x); #ifndef ANSI_COMMON_LISP L: #endif sLApackageA->s.s_dbind = x; vs_reset; return(x); } static object rename_package(x, n, ns) object x, n, ns; { object y; vs_mark; BEGIN: n=coerce_to_string(n); if (!(equal(x->p.p_name,n)) && find_package(n) != Cnil) { PACKAGE_CERROR(n,"Input new package","Package already exists",0); NEW_INPUT(n); goto BEGIN; } x->p.p_name = n; x->p.p_nicknames = Cnil; for (; !endp(ns); ns = ns->c.c_cdr) { n = ns->c.c_car; n=coerce_to_string(n); y = find_package(n); if (x == y) continue; if (y != Cnil) { PACKAGE_CERROR(n,"Input nicknames list","Package already exists",0); NEW_INPUT(ns); goto BEGIN; } x->p.p_nicknames = make_cons(n, x->p.p_nicknames); } vs_reset; return(x); } /* Find_package(n) seaches for a package with name n, which is a string or a symbol. If not so, an error is signaled. */ object find_package(n) object n; { struct package *p; check_package_designator(n); for (p = pack_pointer; p != NULL; p = p->p_link) if (designate_package(n,p)) return ((object)p); return(Cnil); } static object coerce_to_package(p) object p; { object pp; if (type_of(p) == t_package) return(p); pp = find_package(p); if (pp == Cnil) { PACKAGE_CERROR(p,"Input new package","No such package",0); NEW_INPUT(p); return coerce_to_package(p); } return(pp); } object current_package() { object x; x = symbol_value(sLApackageA); if (type_of(x) != t_package) { sLApackageA->s.s_dbind = user_package; FEerror("The value of *PACKAGE*, ~S, was not a package.", 1, x); } return(x); } /* Pack_hash(st) hashes string st and returns the index for a hash table of a package. */ int pack_hash(x) object x; {unsigned int h=0; x=coerce_to_str(x); {int len=x->st.st_fillp; char *s; #define HADD(i,j,k,l) (h+=s[i],h+=s[j]<<8,h+=s[k]<<13,h+=s[l]<<23) #define HADD2(i,j) (h+=s[i]<<5,h+=s[j]<<15) s=x->st.st_self; switch(len) { case 0: break; case 10: case 9: HADD(1,4,6,8); HADD2(5,7); goto END; case 8: HADD(1,3,5,7); HADD2(2,4); goto END; case 7: HADD(1,3,4,5); HADD2(6,2); goto END; case 6: HADD(1,3,4,5); HADD2(0,2); goto END; case 5: h+= s[4] << 13; case 4: h+= s[3] << 24; case 3: h+= s[2]<< 16; case 2: h+= s[1] << 8; case 1: h+= s[0] ; break; default: HADD(3,6,len-2,len-4); HADD2(1,len-1); if (len > 15) {HADD2(7,10); } } END: h &= 0x7fffffff; return(h); }} DEFUN_NEW("PACK-HASH",fixnum,fSpack_hash,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1(pack_hash(x)); } DEFUN_NEW("SET-SYMBOL-HPACK",object,fSset_symbol_hpack,SI,2,2,NONE,OO,OO,OO,OO,(object p,object s),"") { check_type_package(&p); check_type_sym(&s); RETURN1(s->s.s_hpack=p); } /* DEFUN_NEW("PACKAGE-INTERNAL",object,fSpackage_internal,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum i),"") { */ /* check_type_package(&x); */ /* RETURN1(x->p.p_internal[i]); */ /* } */ DEFUN_NEW("PACKAGE-INTERNAL_SIZE",fixnum,fSpackage_internal_size,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_package(&x); RETURN1(x->p.p_internal_size); } /* DEFUN_NEW("PACKAGE-EXTERNAL",object,fSpackage_external,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum i),"") { */ /* check_type_package(&x); */ /* RETURN1(x->p.p_external[i]); */ /* } */ DEFUN_NEW("PACKAGE-EXTERNAL_SIZE",fixnum,fSpackage_external_size,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_package(&x); RETURN1(x->p.p_external_size); } /* Intern(st, p) interns string st in package p. */ object intern(st, p) object st, p; { int j; object x, *ip, *ep, l, ul; vs_mark; st=coerce_to_str(st); {BEGIN_NO_INTERRUPT; j = pack_hash(st); ip = &P_INTERNAL(p ,j); for (l = *ip; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = INTERNAL; END_NO_INTERRUPT;return(l->c.c_car); } ep = &P_EXTERNAL(p,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = EXTERNAL; END_NO_INTERRUPT;return(l->c.c_car); } for (ul=p->p.p_uselist; consp(ul); ul=ul->c.c_cdr) for (l = P_EXTERNAL(ul->c.c_car,j); consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = INHERITED; END_NO_INTERRUPT;return(l->c.c_car); } x = make_symbol(st); vs_push(x); if (p == keyword_package) { x->s.s_stype = (short)stp_constant; x->s.s_dbind = x; *ep = make_cons(x, *ep); keyword_package->p.p_external_fp ++; intern_flag = 0; } else { *ip = make_cons(x, *ip); if (p->p.p_internal_fp++>(p->p.p_internal_size << 1)) rehash_pack(&(p->p.p_internal),&p->p.p_internal_size, suitable_package_size(p->p.p_internal_fp)); intern_flag = 0; } if (x->s.s_hpack == Cnil) x->s.s_hpack = p; vs_reset; END_NO_INTERRUPT;return(x); }} /* Find_symbol(st, p) searches for string st in package p. */ object find_symbol(st, p) object st, p; { int j; object *ip, *ep, l, ul; {BEGIN_NO_INTERRUPT; st=coerce_to_str(st); j = pack_hash(st); ip = &P_INTERNAL(p ,j); for (l = *ip; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = INTERNAL; END_NO_INTERRUPT;return(l->c.c_car); } ep = &P_EXTERNAL(p,j); for (l = *ep; consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = EXTERNAL; END_NO_INTERRUPT;return(l->c.c_car); } for (ul=p->p.p_uselist; consp(ul); ul=ul->c.c_cdr) for (l = P_EXTERNAL(ul->c.c_car,j); consp(l); l = l->c.c_cdr) if (string_eq(l->c.c_car, st)) { intern_flag = INHERITED; END_NO_INTERRUPT;return(l->c.c_car); } intern_flag = 0; END_NO_INTERRUPT;return(Cnil); }} static bool unintern(s, p) object s, p; { object x, y, l, *lp; int j; {BEGIN_NO_INTERRUPT; j = pack_hash(s); x = find_symbol(s, p); if (intern_flag == INTERNAL && s == x) { lp = &P_INTERNAL(p ,j); if (member_eq(s, p->p.p_shadowings)) goto L; goto UNINTERN; } if (intern_flag == EXTERNAL && s == x) { lp = &P_EXTERNAL(p,j); if (member_eq(s, p->p.p_shadowings)) goto L; goto UNINTERN; } END_NO_INTERRUPT;return(FALSE); L: x = OBJNULL; for (l = p->p.p_uselist; consp(l); l = l->c.c_cdr) { y = find_symbol(s, l->c.c_car); if (intern_flag == EXTERNAL) { if (x == OBJNULL) x = y; else if (x != y) { PACKAGE_CERROR(p,"Input new symbol","Name conflict on unintern of shadowing symbol ~s",1,s); NEW_INPUT(s); goto L; } } } delete_eq(s, &p->p.p_shadowings); UNINTERN: delete_eq(s, lp); if (s->s.s_hpack == p) s->s.s_hpack = Cnil; if ((enum stype)s->s.s_stype != stp_ordinary) uninterned_list = make_cons(s, uninterned_list); END_NO_INTERRUPT;return(TRUE); }} void export(s, p) object s, p; { object x; int j; object *ep, *ip, l; BEGIN: ip = NULL; j = pack_hash(s); x = find_symbol(s, p); if (intern_flag) { if (x != s) { import(s, p); /* signals an error */ goto BEGIN; } if (intern_flag == INTERNAL) ip = &P_INTERNAL(p ,j); else if (intern_flag == EXTERNAL) return; } else { PACKAGE_CERROR(p,"Input new symbol","Symbol ~s not accessible",1,s); NEW_INPUT(s); goto BEGIN; } for (l = p->p.p_usedbylist; consp(l); l = l->c.c_cdr) { x = find_symbol(s, l->c.c_car); if (intern_flag && s != x && !member_eq(x, l->c.c_car->p.p_shadowings)) { PACKAGE_CERROR(p,"Input new symbol","Name conflict on exporting ~s",1,s); NEW_INPUT(s); goto BEGIN; } } if (ip != NULL) {delete_eq(s, ip); p->p.p_internal_fp--;} ep = &P_EXTERNAL(p,j); p->p.p_external_fp++; *ep = make_cons(s, *ep); } static void unexport(s, p) object s, p; { object x, *ep, *ip; int j; BEGIN: if (p == keyword_package) { PACKAGE_CERROR(p,"Input new package","Cannot unexport a symbol from the keyword",0); NEW_INPUT(p); goto BEGIN; } x = find_symbol(s, p); if (/* intern_flag != EXTERNAL || */ x != s) { PACKAGE_CERROR(p,"Input new symbol","Symbol ~s not in package.",1,s); NEW_INPUT(s); goto BEGIN; } /* "Cannot unexport the symbol ~S~%\ */ /* from ~S,~%\ */ /* because the symbol is not an external symbol~%\ */ /* of the package.", 2, s, p); */ j = pack_hash(s); ep = &P_EXTERNAL(p,j); delete_eq(s, ep); ip = &P_INTERNAL(p ,j); p->p.p_internal_fp++; *ip = make_cons(s, *ip); } void import(s, p) object s, p; { object x; int j; object *ip; BEGIN: x = find_symbol(s, p); if (intern_flag) { if (x != s) { PACKAGE_CERROR(p,"Input new symbol","Name conflict on importing ~s",1,s); NEW_INPUT(s); goto BEGIN; } if (intern_flag == INTERNAL || intern_flag == EXTERNAL) return; } j = pack_hash(s); ip = &P_INTERNAL(p ,j); p->p.p_internal_fp++; *ip = make_cons(s, *ip); if (s->s.s_hpack==Cnil) {if (p==keyword_package) s->s.tt=2;s->s.s_hpack=p;} } static void shadowing_import(s, p) object s, p; { object x, *ip; x=find_symbol(s, p); if (intern_flag && intern_flag != INHERITED) { if (x == s) { if (!member_eq(x, p->p.p_shadowings)) p->p.p_shadowings = make_cons(x, p->p.p_shadowings); return; } if(member_eq(x, p->p.p_shadowings)) delete_eq(x, &p->p.p_shadowings); if (intern_flag == INTERNAL) delete_eq(x, &P_INTERNAL(p,pack_hash(x))); else delete_eq(x, &P_EXTERNAL(p ,pack_hash(x))); if (x->s.s_hpack == p) x->s.s_hpack = Cnil; if ((enum stype)x->s.s_stype != stp_ordinary) uninterned_list = make_cons(x, uninterned_list); } ip = &P_INTERNAL(p ,pack_hash(s)); *ip = make_cons(s, *ip); p->p.p_internal_fp++; p->p.p_shadowings = make_cons(s, p->p.p_shadowings); } static void shadow(s, p) object s, p; { int j; object *ip,x; s=coerce_to_str(s); x=find_symbol(s, p); if (intern_flag == INTERNAL || intern_flag == EXTERNAL) { p->p.p_shadowings = make_cons(x, p->p.p_shadowings); return; } j = pack_hash(s); ip = &P_INTERNAL(p ,j); vs_push(make_symbol(s)); vs_head->s.s_hpack = p; *ip = make_cons(vs_head, *ip); p->p.p_internal_fp++; p->p.p_shadowings = make_cons(vs_head, p->p.p_shadowings); vs_popp; } static void use_package(x0, p) object x0, p; { object x = x0; int i; object y, l; BEGIN: if (type_of(x) != t_package) { x = find_package(x); if (x == Cnil) { PACKAGE_CERROR(x0,"Input new package","No such package",0); NEW_INPUT(x0); goto BEGIN; } } if (x == keyword_package) { PACKAGE_CERROR(x,"Input new package","Cannot use keyword package",0); NEW_INPUT(x); goto BEGIN; } if (p == x) return; if (member_eq(x, p->p.p_uselist)) return; for (i = 0; i < x->p.p_external_size; i++) for (l = P_EXTERNAL(x ,i); consp(l); l = l->c.c_cdr) { y = find_symbol(l->c.c_car, p); if (intern_flag && l->c.c_car != y && ! member_eq(y,p->p.p_shadowings) ) { PACKAGE_CERROR(p,"Input new package","Name conflict on using ~s from ~s",2,p,y); NEW_INPUT(p); goto BEGIN; } } p->p.p_uselist = make_cons(x, p->p.p_uselist); x->p.p_usedbylist = make_cons(p, x->p.p_usedbylist); } static void unuse_package(x0, p) object x0, p; { object x = x0; BEGIN: if (type_of(x) != t_package) { x = find_package(x); if (x == Cnil) { PACKAGE_CERROR(x0,"Input new package","No such package",0); NEW_INPUT(x0); goto BEGIN; } } delete_eq(x, &p->p.p_uselist); delete_eq(p, &x->p.p_usedbylist); } static object delete_package(object n) { struct package *p,*pp; object t; for (p = pack_pointer,pp=NULL; p != NULL; pp=p,p = p->p_link) if (designate_package(n,p)) { if (p->p_usedbylist!=Cnil) { PACKAGE_CERROR((object)n,"Delete anyway","Package used by other packages",0); for (t=p->p_usedbylist;!endp(t);t=t->c.c_cdr) unuse_package((object)p,t->c.c_car); } if (p->p_uselist!=Cnil) { for (t=p->p_uselist;!endp(t);t=t->c.c_cdr) unuse_package(t->c.c_car,(object)p); } p->p_name=Cnil; if (pp) pp->p_link=p->p_link; else pack_pointer=p->p_link; return(Ct); } if (type_of(n)!=t_package) { PACKAGE_CERROR(n,"Input new package","No such package",0); NEW_INPUT(n); return delete_package(n); } return(Cnil); } /* (use `make_cons(lisp_package, Cnil)`) */ @(defun make_package (pack_name &key nicknames (use Cnil) (internal `small_fixnum(0)`) (external `small_fixnum(0)`) ) @ check_type_or_string_symbol(&pack_name); @(return `make_package(pack_name, nicknames, use, fix(internal),fix(external))`) @) @(defun in_package (pack_name &key nicknames (use Cnil use_sp) (internal `small_fixnum(0)`) (external `small_fixnum(0)`) ) @ check_type_or_string_symbol(&pack_name); if (find_package(pack_name) == Cnil && !(use_sp)) use = make_cons(lisp_package, Cnil); @(return `in_package(pack_name, nicknames, use,fix(internal),fix(external))`) @) extern object sKuse; extern object sKnicknames; DEF_ORDINARY("IN-PACKAGE-INTERNAL",sSin_package_internal,SI,""); DEFUN_NEW("IN-PACKAGE-INTERNAL",object,fSin_package_internal,SI,2,2,NONE,OO,OO,OO,OO,(object p,object r),"") { object use=Cnil,nick=Cnil; /*fixme non-std error check?*/ for (;consp(r) && consp(r->c.c_cdr);r=r->c.c_cdr->c.c_cdr) { if (r->c.c_car==sKuse) use=Ieval1(r->c.c_cdr->c.c_car); if (r->c.c_car==sKnicknames) nick=Ieval1(r->c.c_cdr->c.c_car); } RETURN1(in_package(p,nick,use,0,0)); } #ifdef ANSI_COMMON_LISP static void FFN(Fin_package)(void) { object x; if (vs_top-vs_base!=2) FEwrong_no_args("Fin_package requires two arguments",make_fixnum(vs_top-vs_base)); x=MMcadr(vs_base[0]); x=type_of(x)==t_symbol ? list(2,sLquote,x) : x; vs_base[0]=list(3,sSin_package_internal,x,list(2,sLquote,MMcddr(vs_base[0]))); vs_top=vs_base+1; } #endif DEFUN_NEW("FIND-PACKAGE",object,fLfind_package,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(find_package(x));/*FIXME p->p_link not exposable in lisp*/ } LFD(Ldelete_package)() { check_arg(1); vs_base[0] = delete_package(vs_base[0]); } LFD(Lpackage_name)() { object t; check_arg(1); check_package_designator(vs_base[0]); t=coerce_to_package(vs_base[0]); vs_base[0]=t==Cnil ? t : t->p.p_name; } LFD(Lpackage_nicknames)() { check_arg(1); check_package_designator(vs_base[0]); vs_base[0] = coerce_to_package(vs_base[0]); vs_base[0] = vs_base[0]->p.p_nicknames; } @(defun rename_package (pack new_name &o new_nicknames) @ check_package_designator(pack); pack = coerce_to_package(pack); check_type_or_string_symbol(&new_name); @(return `rename_package(pack, new_name, new_nicknames)`) @) LFD(Lpackage_use_list)() { check_arg(1); check_package_designator(vs_base[0]); vs_base[0] = coerce_to_package(vs_base[0]); vs_base[0] = vs_base[0]->p.p_uselist; } LFD(Lpackage_used_by_list)() { check_arg(1); check_package_designator(vs_base[0]); vs_base[0] = coerce_to_package(vs_base[0]); vs_base[0] = vs_base[0]->p.p_usedbylist; } static void FFN(Lpackage_shadowing_symbols)() { check_arg(1); check_package_designator(vs_base[0]); vs_base[0] = coerce_to_package(vs_base[0]); vs_base[0] = vs_base[0]->p.p_shadowings; } LFD(Llist_all_packages)() { struct package *p; object x,*l; int i; check_arg(0); for (l=&x,p=pack_pointer,i=0;p!=NULL;p=p->p_link,i++) collect(l,make_cons((object)p,Cnil)); *l=Cnil; vs_push(x); } @(defun intern (strng &optional (p `current_package()`) &aux sym) @ check_type_string(&strng); check_package_designator(p); p = coerce_to_package(p); sym = intern(strng, p); if (intern_flag == INTERNAL) @(return sym sKinternal) if (intern_flag == EXTERNAL) @(return sym sKexternal) if (intern_flag == INHERITED) @(return sym sKinherited) @(return sym Cnil) @) @(defun find_symbol (strng &optional (p `current_package()`)) object x; @ check_type_string(&strng); check_package_designator(p); p = coerce_to_package(p); x = find_symbol(strng, p); if (intern_flag == INTERNAL) @(return x sKinternal) if (intern_flag == EXTERNAL) @(return x sKexternal) if (intern_flag == INHERITED) @(return x sKinherited) @(return Cnil Cnil) @) @(defun unintern (symbl &optional (p `current_package()`)) @ check_type_sym(&symbl); check_package_designator(p); p = coerce_to_package(p); if (unintern(symbl, p)) @(return Ct) else @(return Cnil) @) @(defun export (symbols &o (pack `current_package()`)) object l; @ check_package_designator(pack); pack = coerce_to_package(pack); BEGIN: switch (type_of(symbols)) { case t_symbol: if (symbols == Cnil) break; export(symbols, pack); break; case t_cons: for (l = symbols; !endp(l); l = l->c.c_cdr) { check_type_sym(&l->c.c_car); export(l->c.c_car, pack); } break; default: check_type_sym(&symbols); goto BEGIN; } @(return Ct) @) @(defun unexport (symbols &o (pack `current_package()`)) object l; @ check_package_designator(pack); pack = coerce_to_package(pack); BEGIN: switch (type_of(symbols)) { case t_symbol: if (symbols == Cnil) break; unexport(symbols, pack); break; case t_cons: for (l = symbols; !endp(l); l = l->c.c_cdr) { check_type_sym(&l->c.c_car); unexport(l->c.c_car, pack); } break; default: check_type_sym(&symbols); goto BEGIN; } @(return Ct) @) @(defun import (symbols &o (pack `current_package()`)) object l; @ check_package_designator(pack); pack = coerce_to_package(pack); BEGIN: switch (type_of(symbols)) { case t_symbol: if (symbols == Cnil) break; import(symbols, pack); break; case t_cons: for (l = symbols; !endp(l); l = l->c.c_cdr) import(l->c.c_car, pack); break; default: check_type_sym(&symbols); goto BEGIN; } @(return Ct) @) @(defun shadowing_import (symbols &o (pack `current_package()`)) object l; @ check_package_designator(pack); pack = coerce_to_package(pack); BEGIN: switch (type_of(symbols)) { case t_symbol: if (symbols == Cnil) break; shadowing_import(symbols, pack); break; case t_cons: for (l = symbols; !endp(l); l = l->c.c_cdr) shadowing_import(l->c.c_car, pack); break; default: check_type_sym(&symbols); goto BEGIN; } @(return Ct) @) @(defun shadow (symbols &o (pack `current_package()`)) object l; @ check_package_designator(pack); pack = coerce_to_package(pack); BEGIN: switch (type_of(symbols)) { case t_symbol: case t_string: case t_character: if (symbols == Cnil) break; shadow(symbols, pack); break; case t_cons: for (l = symbols; !endp(l); l = l->c.c_cdr) shadow(l->c.c_car, pack); break; default: check_type_or_symbol_string(&symbols); goto BEGIN; } @(return Ct) @) @(defun use_package (pack &o (pa `current_package()`)) object l; @ check_package_designator(pa); pa = coerce_to_package(pa); BEGIN: switch (type_of(pack)) { case t_symbol: if (pack == Cnil) break; case t_string: case t_package: case t_character: use_package(pack, pa); break; case t_cons: for (l = pack; !endp(l); l = l->c.c_cdr) use_package(l->c.c_car, pa); break; default: check_type_package(&pack); goto BEGIN; } @(return Ct) @) @(defun unuse_package (pack &o (pa `current_package()`)) object l; @ check_package_designator(pa); pa = coerce_to_package(pa); BEGIN: switch (type_of(pack)) { case t_symbol: if (pack == Cnil) break; case t_string: case t_package: case t_character: unuse_package(pack, pa); break; case t_cons: for (l = pack; !endp(l); l = l->c.c_cdr) unuse_package(l->c.c_car, pa); break; default: check_type_package(&pack); goto BEGIN; } @(return Ct) @) LFD(siLpackage_internal)() { int j=0; check_arg(2); check_type_package(&vs_base[0]); if (type_of(vs_base[1]) != t_fixnum || (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_internal_size) FEerror("~S is an illegal index to a package hashtable.", 1, vs_base[1]); vs_base[0] = P_INTERNAL(vs_base[0],j); vs_popp; } LFD(siLpackage_external)() { int j=0; check_arg(2); check_type_package(&vs_base[0]); if (type_of(vs_base[1]) != t_fixnum || (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_external_size) FEerror("~S is an illegal index to a package hashtable.", 1, vs_base[1]); vs_base[0] = P_EXTERNAL(vs_base[0],j); vs_popp; } static void FFN(siLpackage_size)() {object p; p=vs_base[0]; check_type_package(&p); check_arg(1); vs_base[0]=make_fixnum(p->p.p_external_size); vs_base[1]=make_fixnum(p->p.p_internal_size); vs_top=vs_base+2; return; } DEF_ORDINARY("EXTERNAL",sKexternal,KEYWORD,""); DEF_ORDINARY("INHERITED",sKinherited,KEYWORD,""); DEF_ORDINARY("INTERNAL",sKinternal,KEYWORD,""); DEF_ORDINARY("NICKNAMES",sKnicknames,KEYWORD,""); DEF_ORDINARY("USE",sKuse,KEYWORD,""); DEFVAR("*PACKAGE*",sLApackageA,LISP,lisp_package,""); void gcl_init_package() { lisp_package = make_package(make_simple_string("COMMON-LISP"), list(2,make_simple_string("CL"),make_simple_string("LISP")),Cnil,47,509); user_package = make_package(make_simple_string("COMMON-LISP-USER"), list(2,make_simple_string("CL-USER"),make_simple_string("USER")), make_cons(lisp_package, Cnil),509,97); keyword_package = make_package(make_simple_string("KEYWORD"), Cnil, Cnil,11,509); system_package = make_package(make_simple_string("SYSTEM"), make_cons(make_simple_string("SI"), make_cons(make_simple_string("SYS"), Cnil)), make_cons(lisp_package, Cnil),251,157); /* There is no need to enter a package as a mark origin. */ uninterned_list = Cnil; enter_mark_origin(&uninterned_list); } void gcl_init_package_function() { make_function("MAKE-PACKAGE", Lmake_package); make_function("DELETE-PACKAGE", Ldelete_package); #ifdef ANSI_COMMON_LISP make_si_function("KCL-IN-PACKAGE", Lin_package); make_macro_function("IN-PACKAGE", Fin_package); #else make_function("IN-PACKAGE", Lin_package); #endif make_function("PACKAGE-NAME", Lpackage_name); make_function("PACKAGE-NICKNAMES", Lpackage_nicknames); make_function("RENAME-PACKAGE", Lrename_package); make_function("PACKAGE-USE-LIST", Lpackage_use_list); make_function("PACKAGE-USED-BY-LIST", Lpackage_used_by_list); make_function("PACKAGE-SHADOWING-SYMBOLS",Lpackage_shadowing_symbols); make_function("LIST-ALL-PACKAGES", Llist_all_packages); make_function("INTERN", Lintern); make_function("FIND-SYMBOL", Lfind_symbol); make_function("UNINTERN", Lunintern); make_function("EXPORT", Lexport); make_function("UNEXPORT", Lunexport); make_function("IMPORT", Limport); make_function("SHADOWING-IMPORT", Lshadowing_import); make_function("SHADOW", Lshadow); make_function("USE-PACKAGE", Luse_package); make_function("UNUSE-PACKAGE", Lunuse_package); make_si_function("PACKAGE-SIZE",siLpackage_size); make_si_function("PACKAGE-INTERNAL", siLpackage_internal); make_si_function("PACKAGE-EXTERNAL", siLpackage_external); } gcl-2.6.14/o/bcmp.c0000755000175000017500000000026514360276512012324 0ustar cammcamm#include int bcmp(const void *s1, const void *s2, size_t n) { const char *c1=s1,*c2=s2; while (n-- > 0) {if (*c1++ != *c2++) return 1;} return 0; } gcl-2.6.14/o/faslnt.c0000755000175000017500000000007114360276512012665 0ustar cammcammint fasload(object o) { printf("this is a dummy\n"); } gcl-2.6.14/o/help.el0000755000175000017500000002702014360276512012507 0ustar cammcamm;;convert-one-def ;; do-var (defvar *subs* '((?A . ?*)(?_ . ?-)(?P . ?+))) (defun mysub (x) (let ((i (length x))tem) (while (>= (setq i (- i 1)) 0) (setq tem (cdr (assoc (aref x i) *subs*))) (if tem (aset x i tem))) x)) (defun defu (x) (interactive "sc function name: ") (insert "DEFUN(\"") (let (pack name beg) (cond ((eql (aref x 1) ?L) (setq pack "LISP")) ((eql (aref x 1 ) ?S) (setq pack "SI")) (t (barf))) (setq name (upcase (mysub (substring x 2 nil)))) (insert name "\",object," x "," pack ",0,0,NONE,OO,OO,OO,OO,\"\")") )) (defun insert-vararg-preamble () (interactive) (let (min beg) (beginning-of-line) (looking-at "DEFUN") (save-excursion (search-forward "(") (forward-sexp 5)(forward-sexp -1) (setq min (string-to-int (buffer-substring (point) (+ (point) 3)))) (forward-sexp 1)(forward-sexp -1) (setq max (string-to-int (buffer-substring (point) (+ (point) 3)))) ) (forward-sexp 3) (forward-char -1) (insert (if (eql (char-after (- (point) 1)) ?\( ) "" ",") "va_alist") (search-forward "\n{" ) (forward-char -1) (open-line 1) (insert "va_dcl") (search-forward "\n{" ) (let ((n (read-string "name for n : " "n")) (vars (read-minibuffer "names for args: ")) defaults (beg (point)) ) (insert "\tint " n "=VFUN_NARGS;") (setq vars (mapcar 'symbol-name vars)) (let ((tem vars)) (while tem (insert "\nobject " (car tem) ";") (setq tem (cdr tem))) (setq tem vars) (insert "\nva_list ap;\n{ va_start(ap);\n") (let ((i (+ min 1))) (while tem (setq defaults (cons (format "LDEFAULT%d" i) defaults)) (insert " if (" n (format ">=%d) " i) (car tem) "=va_arg(ap,object);else goto " (car defaults)";\n") (setq i (+ i 1)) (setq tem (cdr tem))) (insert " goto LEND_VARARG;\n") (setq tem vars) (setq defaults (nreverse defaults)) (while tem (insert " "(car defaults) ": " (car tem) " = Cnil;\n") (setq tem (cdr tem)) (setq defaults (cdr defaults))) (insert " LEND_VARARG: va_end(ap);}\n")) (c-indent-region beg (point)) vars)))) (defun get-name-from-point () (beginning-of-line) (let (name) (save-excursion (cond ((looking-at "\\(siL\\|L\\)\\([a-zA-Z0-9_]*\\)") (setq name (buffer-substring (match-beginning 2) (match-end 2))) (concat (if (looking-at "si") "fS" "fL") name)))))) ;(grep "grep -n '^siL[a-zA-Z_]*()' *.c *.d") ;(grep "grep -n '^L[a-zA-Z_]*()' *.c *.d") ;(grep "grep -n 'make_keywo' *.c *.d") ;(setq-default case-fold-search nil) ;(let (case-fold-search case-replace)(tags-query-replace "\\b[K]\\([a-z]\\)" "sK\\1")) ;(let (case-fold-search case-replace) (tags-query-replace "\\([^a-zA-Z_]\\)[S]\\([a-z]\\)" "\\1sL\\2")) ;(query-replace-regexp "\\([^a-zA-Z_]\\)[S]\\([a-z]\\)" "\\1sL\\2" nil) ;(setq-default case-fold-search nil) (defun defo (&optional x n max) (interactive) (beginning-of-line) (let ((old-name (buffer-substring (point) (save-excursion (forward-sexp 1)(point))))) (or x (setq x (read-string "C function name: " (get-name-from-point)))) (insert "DEFUNO(\"") (let (pack name) (cond ((eql (aref x 1) ?L) (setq pack "LISP")) ((eql (aref x 1 ) ?S) (setq pack "SI")) (t (barf))) (setq name (upcase (mysub (substring x 2 nil)))) (insert name "\",object," x "," pack (format "\n ,%d,%d" (or n 0) (or max n 0)) ",NONE,OO,OO,OO,OO," old-name ",\"\")") ) old-name)) (defvar end-def (make-marker)) (setq standard-args '(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) (defun convert-one-def () (interactive) (make-local-variable 'version-control) (setq version-control t) (let ((here (point)) old-name) (mark-c-function) (let ((end (region-end)) n max) (set-marker end-def end) (save-restriction (narrow-to-region (region-beginning) (region-end)) (save-excursion (cond ((re-search-forward "check_arg(\\([0-9]+\\));" end t) (setq n (string-to-int (buffer-substring (match-beginning 1) (match-end 1)))) (delete-region (match-beginning 0) (match-end 0)) (insert (format "/* %d args */" n))) ((or (re-search-forward "if (vs_top - vs_base < \\([0-9]+\\))[ \t\n]+too_few_arguments();[ \t\n]+if (vs_top - vs_base > \\([0-9]+\\))[ \t\n]+too_many_arguments();" nil t) (re-search-forward "CHECK_ARG_RANGE(\\([0-9]+\\),\\([0-9]+\\));" nil t)) (setq n (string-to-int (buffer-substring (match-beginning 1) (match-end 1)))) (setq max (string-to-int (buffer-substring (match-beginning 2) (match-end 2)))) (delete-region (match-beginning 0) (match-end 0)) (insert (format "CHECK_ARG_RANGE(%s,%s);" n max)) )) (goto-char here) (setq old-name (defo nil n max)) (kill-sexp 1) (search-forward "(") (or n (setq n 0)) (let ((i 0) (args "") ok (standard-args standard-args) new) (while (< i n) (setq new (cons (car standard-args) new)) (setq standard-args (cdr standard-args)) (setq i (+ i 1))) (setq new (reverse new)) (save-excursion (while (not ok) (setq standard-args (read-minibuffer "New args: " (format "%s" new))) (setq ok t) (setq standard-args (mapcar 'symbol-name standard-args)) (setq i 0) (while (and ok (< i n)) (setq args (format "%s%s" args (nth i standard-args))) (while (search-forward (nth i standard-args) nil t) (message "conflict %s? space for ok" (nth i standard-args)) (cond ((member (read-char) '(?y ?\ ))) (t (setq ok nil)))) (setq i (+ i 1)) (if (< i n) (setq args (concat args ",")))) )) (insert args) (forward-line 1) (beginning-of-line) (and standard-args (insert "object " args ";\n")) (cond (max (save-excursion (search-backward "\nDEFUN") (forward-char 1) (setq standard-args (append standard-args (insert-vararg-preamble)))))) (goto-char (point-min)) (while (re-search-forward "\\(vs_base\\|base\\)[[]\\([0-9]+\\)[]]" nil t) (let ((m (string-to-int (buffer-substring (match-beginning 2) (match-end 2))))) (cond ((and (nth m standard-args) (my-y-or-n-p (format "replace-> %s" (nth m standard-args)))) (delete-region (match-beginning 0) (match-end 0)) (insert (nth m standard-args)))))) (goto-char (point-max)) (search-backward "}") (open-line 1) (insert "RETURN1(" (or (nth 0 standard-args) "vs_base[0]") ");") (c-indent-command) (goto-char here) (widen) (save-excursion (goto-char (point-max)) (cond ((search-backward old-name nil t) (cond ((my-y-or-n-p "Delete line?") (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point))) (sit-for 1) ) )))) )))))) (defun next-sexp () (let (beg) (forward-sexp 1) (forward-sexp -1) (setq beg (point)) (forward-sexp 1) (buffer-substring beg (point)))) (defun mangle-string (v) (let ((beg (point)) end ans) (insert v) (setq end (point)) (downcase-region beg end) (do-replace '(("[*]" "A") ("[---]" "_") ("[+]" "Q") ("[*]" "A") ("[%]" "P") ("[;]" "X") ("[.]" "Z") ("[,]" "Y") ("[]" "E") ("[@]" "B") ) beg end) (setq ans (buffer-substring beg end)) (delete-region beg end) ans )) (defun do-replace (lis &optional beg end) (save-excursion (let ((ma (make-marker))) (set-marker ma (or end (point-max))) (setq beg (or beg (point-min))) (while lis (goto-char beg) (setq x (car lis) ) (setq lis (cdr lis)) (while (re-search-forward (car x) ma t) (replace-match (nth 1 x) t))) (set-marker ma nil)))) (defun do-var () (interactive) (let (na beg old (m (make-marker))) (save-excursion (setq beg (point)) (setq old (next-sexp)) (cond ((search-forward "(\"" nil t) (setq pt (point)) (forward-char -1) (setq na (next-sexp)) (cond ((looking-at ")")) (t (forward-sexp 1) (forward-sexp -1) (setq val (buffer-substring (point) (progn (search-forward ");") (- (point) 2)))) ;(setq val (next-sexp)) )))) (let ((pack "L")) (goto-char beg) (cond ((search-forward "make_si" pt t) (setq pack "S")) ((search-forward "make_keyw" pt t) (setq pack "K") )) (setq na (concat "s" pack (mangle-string (substring na 1 (- (length na) 1))))) (goto-char beg) (open-line 1) (defva na val) ) ) (set-marker m (point)) (save-excursion (search-forward ");" nil t) (delete-region m (point))) (let ((buf (current-buffer))) (unwind-protect (cond ((and (not (equal old na)) (y-or-n-p (format "Replace %s--> %s :" old na))) (goto-char (point-min)) (tags-query-replace old na nil))) (switch-to-buffer buf) (goto-char m) (set-marker m nil) )))) (defun my-y-or-n-p (string) (message (format "%s (Y or Space for yes): " string)) (member (read-char) '(?y ?\ ))) (defun defva (x &optional val) (interactive "sc Variable name: ") (let (pack name special) (cond ((eql (aref x 1) ?L) (setq pack "LISP")) ((eql (aref x 1 ) ?S) (setq pack "SI")) ((eql (aref x 1 ) ?K) (setq pack "KEYWORD")) (t (barf))) (cond ((eql (aref x 2) ?A) (setq special t))) (insert (if special "DEFVAR(\"" "DEF_ORDINARY(\"")) (setq name (upcase (mysub (substring x 2 nil)))) (insert name "\"," x "," pack) (if special (insert "," (or val "sLnil"))) (insert ",\"\");") ; (insert "\n#define " x " S" (substring x 2 nil)) )) ;(tags-search "BEGIN_NO_INTERRUPT") (global-set-key "\C-x'" 'check-interrupt) (global-set-key "\C-xp" '(lambda()(interactive) (insert "END_NO_INTERRUPT;"))) (global-set-key "\C-xa" '(lambda()(interactive) (insert "{BEGIN_NO_INTERRUPT;") (save-excursion (beginning-of-line) (forward-sexp 1) (insert "}")))) (defun check-interrupt ( ) (interactive) (let (found at (bil (make-marker)) (ok t)) (forward-sexp -1) (setq at (point)) (mark-c-function) (goto-char at) (set-marker bil (region-end)) (while (and ok (re-search-forward "\\(return\\)\\|\\(END_NO_INTERRUPT\\)" bil t)) (cond ((match-beginning 1) (setq found t) (if (my-y-or-n-p "replace?") (replace-match "goto END_INTER " t))) ((match-beginning 2) (setq ok nil) (if (and found (my-y-or-n-p "replace?")) (replace-match "END_INTER: END_NO_INTERRUPT;\n return " t))) )) (set-marker bil nil) (or found (message "was ok")) (if ok (message "problem")) )) (defun foo() (interactive) (let (p tem) (end-of-line) (setq p (point)) (forward-sexp -1) (forward-char 1) (setq tem (buffer-substring (point) p)) (save-excursion (set-buffer (get-buffer "usig2.c<2>")) (insert "\t&" tem ",\n")) (forward-line 1))) (defun fa () (interactive) (let (p tem) (end-of-line) (setq p (point)) (forward-sexp -1) (forward-char 1) (setq tem (buffer-substring (point) p)) (grep (concat "grep -n " tem " o/*.c o/*.d mp/*.c h/*.h ")))) ;(let ((case-fold-search nil)) (tags-query-replace "NONE" "VARARG")) (defun fa () (interactive) (re-search-forward "&\\([a-zA-Z0-9_]+\\)," nil t) (grep (concat "grep -n " (buffer-substring (match-beginning 1) (match-end 1)) " ../o/*c ../o/*.d ../h/*.h ../mp/*.c"))) (defun my-grep () (interactive) (let (end ) (save-excursion (forward-sexp 1) (setq end (point)) (forward-sexp -1) (let ((tem (buffer-substring (point) end))) (setq tem (read-string "Grep: " (concat "grep -n " tem " ../o/*.c ../o/*.d ../h/*.h ../mp/*.c"))) (grep tem))))) gcl-2.6.14/o/utils.c0000755000175000017500000001120614360276512012540 0ustar cammcamm#include #include #include #include "include.h" /* The functions IisProp check the property holds, and return the argument. They may in future allow resetting the argument. */ object IisSymbol(object f) { if (type_of(f) != t_symbol) { FEerror("Not a symbol ~s",1,f); } return f; } /* object */ /* IisFboundp(object f) */ /* { */ /* IisSymbol(f); */ /* if (f->s.s_gfdef ==0) */ /* { FEerror("Not a fboundp ~s",1,f);} */ /* return f; */ /* } */ object IisArray(object f) { if (TS_MEMBER(type_of(f), TS(t_array) |TS(t_vector) |TS(t_bitvector) |TS(t_string))) return f; else { FEwrong_type_argument(sLarray,f); return f; } } object Iis_fixnum(object f) { if (type_of(f)==t_fixnum) { return f;} else { FEerror("Not a fixnum ~s",1,f); return f; } } void Wrong_type_error(char *str,int n,...) { FEerror("Wrong type error",0); } /* static object */ /* Iapply_ap(object (*f) (/\* ??? *\/), va_list ap) */ /* Apply f to the va_list ap, with an implicit number of args passed in VFUN_NARGS */ /* { int n = VFUN_NARGS; */ /* object *new; */ /* COERCE_VA_LIST(new,ap,n); */ /* return c_apply_n(f,n,new); */ /* } */ object Ifuncall_n(object fun,int n,...) { /* call fun on the n optional args supplied, and set the fcall.nvalues etc return the first value */ va_list ap; object *new; va_start(ap,n); COERCE_VA_LIST(new,ap,n); va_end(ap); return IapplyVector(fun,n,new); } /* For applying FUN to args in VA_LIST, where n are supplied directly and the last one is itself a va_list */ /* object */ /* Iapply_fun_n(object fun,int n,int m,...) { */ /* va_list ap1,ap; */ /* object b[F_ARG_LIMIT]; */ /* int i = 0; */ /* va_start(ap1,m); */ /* while (--n >= 0) */ /* { b[i++] = va_arg(ap1,object);} */ /* if (m > 0) { */ /* ap = va_arg(ap1,va_list); */ /* while (--m >= 0) */ /* { b[i++] = va_arg(ap,object);} */ /* } */ /* va_end(ap1); */ /* return IapplyVector(fun,i,b); */ /* } */ /* For applying FUN to args in VA_LIST, where n are supplied directly and the last one is itself a va_list */ /* object */ /* Iapply_fun_n1(object (*fun)(),int n,int m,...) { */ /* va_list ap; */ /* object b[F_ARG_LIMIT],*bb; */ /* int i = 0; */ /* va_start(ap,m); */ /* while (--n >= 0) { */ /* b[i++] = va_arg(ap,object);} */ /* if (m > 0) { */ /* bb = va_arg(ap,object *); */ /* while (--m >= 0) */ /* b[i++] = *bb++; */ /* } */ /* va_end(ap); */ /* return IapplyVector(make_sfun(Cnil,fun,i,Cnil),i,b); */ /* } */ /* For applying FUN to args in VA_LIST, where n are supplied directly and the last one is itself a va_list */ /* object */ /* Iapply_fun_n2(object fun,int n,int m,...) { */ /* va_list ap,*app; */ /* object b[F_ARG_LIMIT]; */ /* int i = 0; */ /* va_start(ap,m); */ /* while (--n >= 0) { */ /* b[i++] = va_arg(ap,object);} */ /* if (m > 0) { */ /* app = va_arg(ap,va_list *); */ /* while (--m >= 0) */ /* b[i++] = va_arg(*app,object); */ /* } */ /* va_end(ap); */ /* return IapplyVector(fun,i,b); */ /* } */ /* static object */ /* ImakeStructure(int n, object *p) */ /* p[0]= structure name , p[1] = 1'st elt,.... p[n-1] = last elt. */ /* { object * r = vs_top; */ /* object res; */ /* if (p+n != r) { FEerror("bad make struct",0);} */ /* vs_base= p; */ /* siLmake_structure(); */ /* res = vs_base[0]; */ /* vs_top=p; */ /* return res; */ /* } */ /* static void */ /* Ineed_in_image(object (*foo) (/\* ??? *\/)) */ /* {;} */ /* Convert a value stack type return to an fcall multiple vaule return and return the actual value (or nil if no values); */ object Ivs_values(void) { fixnum n = fcall.nvalues = vs_top - vs_base; object *b = vs_base,*p=&fcall.values[0]; object res = (n > 0 ? b[0] : sLnil); if (n>=(fixnum)(sizeof(fcall.values)/sizeof(*fcall.values))) FEerror("Too many function call values",0); while (--n > 0) { *++p= *++b;} return res; } /* static void */ /* fatal(char *s, int i1, int i2) */ /* { */ /* fprintf(stderr,s,i1,i2); */ /* exit(1); */ /* } */ /* Copy STRING to BUF which has N bytes available. If there is not enough space, malloc some */ char * lisp_copy_to_null_terminated(object string, char *buf, int n) { if(type_of(string) != t_string && type_of(string) != t_symbol) FEerror("Need to give symbol or string",0); if (string->st.st_fillp +1 > n) { buf= (void *)malloc(string->st.st_fillp +1); } bcopy(string->st.st_self,buf,string->st.st_fillp); buf[string->st.st_fillp] = 0; return buf; } gcl-2.6.14/o/user_match.c0000644000175000017500000000010514360276512013523 0ustar cammcamm#include "include.h" int user_match(const char *s,int n) {return 0;} gcl-2.6.14/o/wpool.c0000644000175000017500000000123014360276512012531 0ustar cammcamm#include #define NO_PRELINK_UNEXEC_DIVERSION char *rb_end=NULL,*rb_start=NULL,*heap_end=NULL; void *data_start=NULL; int multiprocess_memory_pool=1; #include "include.h" #include "page.h" #include "pool.h" /*lintian*/ void assert_error(const char *a,unsigned l,const char *f,const char *n) { update_pool(0); get_pool(); pool_check(); } int main(int argc,char * argv[],char * envp[]) { int s=3; if (argc>1) sscanf(argv[1],"%d",&s); open_pool(); for (;;) { lock_pool(); fprintf(stderr,"master pid %lu %lu processess %lu pages\n",Pool->pid,Pool->n,Pool->s); fflush(stderr); unlock_pool(); sleep(s); } return 0; } gcl-2.6.14/o/rel_aix.c0000755000175000017500000000601414360276512013024 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c */ #define EXTERNAL_P(rel) \ relocation_info.r_type & ) #define HI12 0xfff00000 #define LO20 ~HI12 foo(){}; relocate() { char *where; {unsigned int new_value; char tem [10]; #ifdef DEBUG printf("\nEnter relocate:*srelocation_info {r_symndx= %d, r_vaddr = %d,:", relocation_info.r_symndx, relocation_info.r_vaddr );fflush(stdout); #endif where = the_start + relocation_info.r_vaddr; if(relocation_info.r_symndx < S_BSS){ #ifdef DEBUG printf("(relocation_info.r_symndx = %d < S_BSS)",relocation_info.r_symndx );fflush(stdout); print_name(&symbol_table[relocation_info.r_symndx]); #endif switch(relocation_info.r_type){ case R_KCALL: /* instructions like balix take a 20 bit argument which wants to be the displacement in half words to from the address of the instruction to the actual address. */ {int displ; unsigned int new; displ= symbol_table[relocation_info.r_symndx].n_value - (int)where; new= *(unsigned int *)where; /* *(unsigned int *)where = (new & HI12) | ((displ >> 1) & LO20); */ /* need to store the halves separately, because word pointers must be aligned */ ((unsigned short *)where)[0]=0x8b00; ((unsigned short *)where)[1]=0x0c00; return ;} case R_PCRBYTE: /* byte (pc relative) */ case R_PCRWORD: /* word (pc relative) */ case R_PCRLONG: /* word (pc relative) */ new_value= - (int)start_address + symbol_table[relocation_info.r_symndx].n_value; break; default: { new_value= symbol_table[relocation_info.r_symndx].n_value;}}} else { switch(relocation_info.r_symndx){ case S_DATA: case S_BSS: case S_TEXT: new_value= (int)start_address; break; default: dprintf(relocation_info.r_type = %d, relocation_info.r_type); #ifdef DEBUG printf("\nrelocation_info {r_symndx= %d, r_vaddr = %d, Ignored:", relocation_info.r_symndx, relocation_info.r_vaddr );fflush(stdout); #endif goto DONT;} }; dprintf((type %d),relocation_info.r_type); switch(relocation_info.r_type){ case R_RELBYTE: case R_PCRBYTE: *( char *)where = new_value + *( char *) where; break; case R_RELWORD: case R_PCRWORD: *( short *)where = new_value + *( short *) where; break; case R_RELLONG: case R_PCRLONG: /* I guess it must be long if in these areas I don't see how the size can vary. */ if (((int)where %4) !=0) FEerror("long alignment not long aligned",0,0); *( long *)where = new_value + *( long *) where; break; default: printf("(bad type %d)",relocation_info.r_type); } DONT:; } } typedef int (*FUNC)(); /* #define describe_sym(n) do{if (debug){printf("Sym No %d:",n); print_name(symbol_table+ (n));}}while(0) */ /* #include "spadutils.c" */ gcl-2.6.14/o/unixsave.c0000755000175000017500000000567514360276512013257 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* unixsave.c */ #define IN_UNIXSAVE #ifndef FIRSTWORD #include "include.h" #endif #ifdef UNIXSAVE #include UNIXSAVE #else #ifdef HAVE_FCNTL #include #else #include #endif #ifdef HAVE_AOUT #undef BSD #undef ATT #define BSD #endif #ifdef BSD #include HAVE_AOUT #endif #ifdef DOS void binary_file_mode() {_fmode = O_BINARY;} #endif #ifdef ATT #include #include #include #endif #ifdef E15 #include extern char etext; #endif filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } static void memory_save(original_file, save_file) char *original_file, *save_file; { MEM_SAVE_LOCALS; char *data_begin, *data_end; int original_data; FILE *original, *save; register int n; register char *p; extern char *sbrk(); original = freopen(original_file,"r",stdin); /* fclose(stdin); original = fopen(original_file, "r"); */ if (stdin != original || original->_file != 0) { emsg("Can't open the original file.\n"); do_gcl_abort(); } setbuf(original, stdin_buf); fclose(stdout); unlink(save_file); n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { emsg("Can't open the save file.\n"); do_gcl_abort(); } setbuf(save, stdout_buf); READ_HEADER; FILECPY_HEADER; for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) if (n > BUFSIZ) fwrite(p, BUFSIZ, 1, save); else if (n > 0) { fwrite(p, 1, n, save); break; } else break; fseek(original, original_data, 1); COPY_TO_SAVE; fclose(original); fclose(save); } extern void _cleanup(); LFD(siLsave)() { char filename[256]; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); _cleanup(); memory_save(kcl_self, filename); exit(0); /* no return */ } #endif /* UNIXSAVE include */ void gcl_init_unixsave(void) { make_si_function("SAVE", siLsave); } gcl-2.6.14/o/conditional.c0000755000175000017500000000752014360276512013707 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* conditional.c conditionals */ #include "include.h" object sLotherwise; static void FFN(Fif)(object form) { object *top = vs_top; if (endp(form) || endp(MMcdr(form))) FEtoo_few_argumentsF(form); if (!endp(MMcddr(form)) && !endp(MMcdddr(form))) FEtoo_many_argumentsF(form); eval(MMcar(form)); if (vs_base[0] == Cnil) if (endp(MMcddr(form))) { vs_top = vs_base = top; vs_push(Cnil); } else { vs_top = top; eval(MMcaddr(form)); } else { vs_top = top; eval(MMcadr(form)); } } static void FFN(Fcond)(object args) { object *top = vs_top; object clause; object conseq; while (!endp(args)) { clause = MMcar(args); if (type_of(clause) != t_cons) FEerror("~S is an illegal COND clause.",1,clause); eval(MMcar(clause)); if (vs_base[0] != Cnil) { conseq = MMcdr(clause); if (endp(conseq)) { vs_top = vs_base+1; return; } while (!endp(conseq)) { vs_top = top; eval(MMcar(conseq)); conseq = MMcdr(conseq); } return; } vs_top = top; args = MMcdr(args); } vs_base = vs_top = top; vs_push(Cnil); } static void FFN(Fcase)(object arg) { object *top = vs_top; object clause; object key; object conseq; if (endp(arg)) FEtoo_few_argumentsF(arg); eval(MMcar(arg)); vs_top = top; vs_push(vs_base[0]); arg = MMcdr(arg); while (!endp(arg)) { clause = MMcar(arg); if (type_of(clause) != t_cons) FEerror("~S is an illegal CASE clause.",1,clause); key = MMcar(clause); conseq = MMcdr(clause); if (type_of(key) == t_cons) do { if (eql(MMcar(key),top[0])) goto FOUND; key = MMcdr(key); } while (!endp(key)); else if (key == Cnil) ; else if (key == Ct || key == sLotherwise || eql(key,top[0])) goto FOUND; arg = MMcdr(arg); } vs_base = vs_top = top; vs_push(Cnil); return; FOUND: if (endp(conseq)) { vs_base = vs_top = top; vs_push(Cnil); } else do { vs_top = top; eval(MMcar(conseq)); conseq = MMcdr(conseq); } while (!endp(conseq)); return; } static void FFN(Fwhen)(object form) { object *top = vs_top; if (endp(form)) FEtoo_few_argumentsF(form); eval(MMcar(form)); if (vs_base[0] == Cnil) { vs_base = vs_top = top; vs_push(Cnil); } else { form = MMcdr(form); if (endp(form)) { vs_base = vs_top = top; vs_push(Cnil); } else do { vs_top = top; eval(MMcar(form)); form = MMcdr(form); } while (!endp(form)); } } static void FFN(Funless)(object form) { object *top = vs_top; if (endp(form)) FEtoo_few_argumentsF(form); eval(MMcar(form)); if (vs_base[0] == Cnil) { vs_top = top; form = MMcdr(form); if (endp(form)) { vs_base = vs_top = top; vs_push(Cnil); } else do { vs_top = top; eval(MMcar(form)); form = MMcdr(form); } while (!endp(form)); } else { vs_base = vs_top = top; vs_push(Cnil); } } void gcl_init_conditional(void) { make_special_form("IF",Fif); make_special_form("COND",Fcond); make_special_form("CASE",Fcase); make_special_form("WHEN",Fwhen); make_special_form("UNLESS",Funless); sLotherwise = make_ordinary("OTHERWISE"); enter_mark_origin(&sLotherwise); } gcl-2.6.14/o/catch.c0000755000175000017500000000710014360276512012460 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* catch.c dynamic non-local exit */ #include "include.h" static void FFN(Fcatch)(VOL object args) { object *top = vs_top; if (endp(args)) FEtoo_few_argumentsF(args); eval(MMcar(args)); vs_top = top; vs_push(vs_base[0]); frs_push(FRS_CATCH, vs_base[0]); if (nlj_active) nlj_active = FALSE; else Fprogn(MMcdr(args)); frs_pop(); } DEFUNM_NEW("ERROR-SET",object,fSerror_set,SI ,1,1,NONE,OO,OO,OO,OO,(volatile object x0), "Evaluates the FORM in the null environment. If the evaluation \ of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first \ value and the result of the evaluation as the rest of the values. If, in the \ course of the evaluation, a non-local jump from the FORM is atempted, \ SI:ERROR-SET traps the jump and returns the corresponding jump tag as its \ value.") { object *old_lex = lex_env; /* 1 args */ vs_push(Cnil); frs_push(FRS_CATCHALL, Cnil); if (nlj_active) { nlj_active = FALSE; x0 = nlj_tag; frs_pop(); lex_env = old_lex; RETURN1(x0); } else { lex_env = vs_top; vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); x0 = Ieval(x0); } frs_pop(); lex_env = old_lex; {int i = fcall.nvalues; if (i+1>=sizeof(fcall.values)/sizeof(*fcall.values)) FEerror("Too many function call values",0); while (i > 0) { fcall.values[i+1] = fcall.values[i]; i--;} fcall.nvalues++; fcall.values[1] = x0;} return Cnil; } static void FFN(Funwind_protect)(VOL object args) { object *top = vs_top; object *value_top; if (endp(args)) FEtoo_few_argumentsF(args); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { object tag = nlj_tag; frame_ptr fr = nlj_fr; value_top = vs_top; vs_top = top; while(vs_base, where ); if (relocation_info.r_type == R_ABS) { dprintf( r_abs ,0) return; } switch(relocation_info.r_type) { case R_DIR32: dprintf(new val r_dir32 %x , *((int *)where) + symbol_table[relocation_info.r_symndx].n_value); *(int *)where= *((int *)where) + symbol_table[relocation_info.r_symndx].n_value; break; case R_PCRLONG: dprintf( r_pcrlong new value = %x , *((int *)where) - (int)start_address + symbol_table[relocation_info.r_symndx].n_value ); #ifdef _WIN32 /* the following is logical, except the address offset is not where the 'where' is but where the 'call' is just AFTER the 'where'. */ *(int *)where= symbol_table[relocation_info.r_symndx].n_value - (int) where - sizeof(int *); #else *(int *)where= *((int *)where) - (int)start_address + symbol_table[relocation_info.r_symndx].n_value; #endif break; default: fprintf(stdout, "%d: unsupported relocation type.", relocation_info.r_type); FEerror("The relocation type was unknown",0,0); } } #ifdef DEBUG #define describe_sym describe_sym1 describe_sym1(n) int n; {char *str; char tem[9]; struct syment *sym; sym= &symbol_table[n]; str= sym->n_zeroes == 0 ? &my_string_table[sym->n_offset] : (sym->n_name[SYMNMLEN -1] ? /* MAKE IT NULL TERMINATED */ (strncpy(tem,sym->n_name, SYMNMLEN),tem): sym->n_name ); printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); /* printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d \nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, symbol_table[n]._n._n_name, symbol_table[n]._n._n_n._n_zeroes , symbol_table[n]._n._n_n._n_offset , symbol_table[n]._n._n_nptr[0] , symbol_table[n]._n._n_nptr[1] , symbol_table[n].n_value , symbol_table[n].n_scnum , symbol_table[n].n_type , symbol_table[n].n_sclass , symbol_table[n].n_numaux ); */ } #endif gcl-2.6.14/o/unixtime.c0000755000175000017500000002321614360276512013246 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* unixtime.c */ #define IN_UNIXTIME #include #include "include.h" #include #ifdef UNIX /* all we want from this is HZ the number of clock ticks per second which is usually 60 maybe 100 or something else. */ #undef PAGESIZE #ifndef NO_SYS_PARAM_H #include #endif #endif #ifndef HZ /* #define HZ 60 */ #define HZ 100 #endif /* #define HZ1 (HZ > 100 ? 100 : HZ) */ #define HZ1 HZ #ifdef USE_ATT_TIME # undef BSD # define ATT #endif #if defined __MINGW32__ || !defined NO_SYSTEM_TIME_ZONE # ifdef __MINGW32__ # include # include # include static struct timeb t0; int usleep1 ( unsigned int microseconds ); #undef usleep #define usleep(x) usleep1(x) # endif #endif /* __MINGW32__ or !defined NO_SYSTEM_TIME_ZONE */ #ifdef BSD #include #include #ifndef NO_SYS_TIMES_H #include #endif #include /* static struct timeb beginning; */ #endif #ifdef ATT #include static long beginning; #endif int runtime(void) { #ifdef USE_INTERNAL_REAL_TIME_FOR_RUNTIME # ifdef __MINGW32__ struct timeb t; if ( t0.time == 0 ) { ftime(&t0); } ftime ( &t ); return ( ( t.time - t0.time ) * HZ1 + ( (t.millitm) * HZ1 ) / 1000 ); # else # error Need to return runtime without generating a fixnum (else GBC(t_fixnum) will loop) # endif #else { struct tms buf; times(&buf); return(buf.tms_utime); } #endif } object unix_time_to_universal_time(int i) { object x; vs_mark; vs_push(make_fixnum(24*60*60)); vs_push(make_fixnum(70*365+17)); x = number_times(vs_top[-1], vs_top[-2]); vs_push(x); vs_push(make_fixnum(i)); x = number_plus(vs_top[-1], vs_top[-2]); vs_reset; return(x); } DEFUN_NEW("GET-UNIVERSAL-TIME",object,fLget_universal_time,LISP ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1(unix_time_to_universal_time(time(0))); } LFD(Lsleep)(void) { object z; check_arg(1); check_type_or_rational_float(&vs_base[0]); if (number_minusp(vs_base[0]) == TRUE) FEerror("~S is not a non-negative number.", 1, vs_base[0]); vs_base[0]=number_times(vs_base[0],make_fixnum(1000000)); Lround(); z = vs_base[0]; if (type_of(z) == t_fixnum) usleep(fix(z)); else /* What is this for? -- MJT */ for(;;) #ifdef __MINGW32__ Sleep ( 10000 ); #else sleep(1000); #endif vs_top = vs_base; vs_push(Cnil); } LFD(Lget_internal_run_time)(void) { #ifdef USE_INTERNAL_REAL_TIME_FOR_RUNTIME vs_push(fLget_internal_real_time()); vs_push(small_fixnum(0)); return; #else struct tms buf; check_arg(0); times(&buf); vs_push(make_fixnum(buf.tms_utime)); vs_push(make_fixnum(buf.tms_cutime)); vs_push(make_fixnum(buf.tms_stime)); vs_push(make_fixnum(buf.tms_cstime)); #endif } DEFUN_NEW("GETTIMEOFDAY",object,fSgettimeofday,SI,0,0,NONE,OO,OO,OO,OO,(void),"Return time with maximum resolution") { #ifdef __MINGW32__ LARGE_INTEGER uu,ticks; if (QueryPerformanceFrequency(&ticks)) { QueryPerformanceCounter(&uu); return make_longfloat((longfloat)uu.QuadPart/ticks.QuadPart); } else { FEerror("microsecond timing not available",0); return Cnil; /* static struct timeb t0; */ /* static unsigned u; */ /* struct timeb t; */ /* ftime(&t); */ /* if (t.time!=t0.time || t.millitm!=t0.millitm) {t0=t;u=0;} */ /* u++; */ /* return make_longfloat(((longfloat)t.time+1.0e-3*t.millitm+1.0e-6*(u%1000))); */ } #endif #ifdef BSD struct timeval tzp; gettimeofday(&tzp,0); return make_longfloat((longfloat)tzp.tv_sec+1.0e-6*tzp.tv_usec); #endif #ifdef ATT return make_longfloat((longfloat)time(0)); #endif } DEFUN_NEW("GET-INTERNAL-REAL-TIME",object,fLget_internal_real_time,LISP,0,0,NONE,OO,OO,OO,OO,(void),"Run time relative to beginning") { #ifdef __MINGW32__ struct timeb t; if ( t0.time == 0 ) { ftime ( &t0 ); } ftime(&t); return ( make_fixnum ( ( t.time - t0.time ) * HZ1 + ( (t.millitm) * HZ1 ) / 1000 ) ); #endif #ifdef BSD static struct timeval begin_tzp; struct timeval tzp; if (begin_tzp.tv_sec==0) gettimeofday(&begin_tzp,0); gettimeofday(&tzp,0); /* the value returned will be relative to the first time this is called, plus the fraction of a second. We must make it relative, so this will only wrap if the process lasts longer than 818 days */ return make_fixnum(((tzp.tv_sec-begin_tzp.tv_sec)*HZ1 + ((tzp.tv_usec)*HZ1)/1000000)); #endif #ifdef ATT return make_fixnum((time(0) - beginning)*HZ1); #endif } void gcl_init_unixtime(void) { #ifdef ATT beginning = time(0); #endif # if defined __MINGW32__ ftime(&t0); # endif make_constant("INTERNAL-TIME-UNITS-PER-SECOND", make_fixnum(HZ1)); make_function("SLEEP", Lsleep); make_function("GET-INTERNAL-RUN-TIME", Lget_internal_run_time); } #ifdef __MINGW32__ int usleep1 ( unsigned int microseconds ) { unsigned int milliseconds = microseconds / 1000; return ( SleepEx ( milliseconds, TRUE ) ); } #endif DEFUN_NEW("CURRENT-TIMEZONE",object,fScurrent_timezone,SI,0,0,NONE,IO,OO,OO,OO,(void),"") { #if defined(__MINGW32__) TIME_ZONE_INFORMATION tzi; DWORD TZResult; TZResult = GetTimeZoneInformation ( &tzi ); /* Now UTC = (local time + bias), in units of minutes, so */ /*fprintf ( stderr, "Bias = %ld\n", tzi.Bias );*/ return (object)((tzi.Bias+tzi.DaylightBias)/60); #elif defined NO_SYSTEM_TIME_ZONE return (object)0; #elif defined __CYGWIN__ struct tm gt,lt; fixnum _t=time(0); gmtime_r(&_t, >); localtime_r(&_t, <); return (object)(long)(gt.tm_hour-lt.tm_hour+24*(gt.tm_yday!=lt.tm_yday ? (gt.tm_year>lt.tm_year||gt.tm_yday>lt.tm_yday ? 1 : -1) : 0)); #else time_t _t=time(0); return (object)(-localtime(&_t)->tm_gmtoff/3600); #endif } DEFUN_NEW("CURRENT-DSTP",object,fScurrent_dstp,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { #if defined(__MINGW32__) return Cnil; #elif defined NO_SYSTEM_TIME_ZONE /*solaris*/ return Cnil; #else time_t _t=time(0); return localtime(&_t)->tm_isdst > 0 ? Ct : Cnil; #endif } #if defined(__MINGW32__) /*FIXME range too small for maxima testsuite*/ #undef gmtime #define gmtime _gmtime64 #undef localtime #define localtime _localtime64 #undef mktime #define mktime _mktime64 #undef time_t #define time_t long long #endif static object time_t_to_object(time_t l) { object x=new_bignum(); mpz_set_si(MP(x),l>>32); mpz_mul_2exp(MP(x),MP(x),32); mpz_add_ui(MP(x),MP(x),l&((1ULL<<32)-1)); return normalize_big(x); } static time_t object_to_time_t(object x) { switch(type_of(x)) { case t_fixnum: return fix(x); case t_bignum: { time_t h; mpz_set_si(MP(big_fixnum3),1); mpz_mul_2exp(MP(big_fixnum3),MP(big_fixnum3),31); mpz_fdiv_qr(MP(big_fixnum1),MP(big_fixnum2),MP(x),MP(big_fixnum3)); massert(mpz_fits_slong_p(MP(big_fixnum1))); massert(mpz_fits_slong_p(MP(big_fixnum2))); h=mpz_get_si(MP(big_fixnum1)); h<<=31; h+=mpz_get_si(MP(big_fixnum2)); return h; } default: TYPE_ERROR(x,sLinteger); } } DEFUNM_NEW("LOCALTIME",object,fSlocaltime,SI,1,1,NONE,OO,OO,OO,OO,(object t),"") { #if defined NO_SYSTEM_TIME_ZONE /*solaris*/ return Cnil; #else time_t i=object_to_time_t(t); struct tm *lt; #if defined(__MINGW32__) struct tm *gt; fixnum gmt_hour; massert(gt=gmtime(&i)); gmt_hour=gt->tm_hour; #endif massert(lt=localtime(&i)); RETURN(11,object, make_fixnum(lt->tm_sec), ( RV(make_fixnum(lt->tm_min)), RV(make_fixnum(lt->tm_hour)), RV(make_fixnum(lt->tm_mday)), RV(make_fixnum(lt->tm_mon)), RV(make_fixnum(lt->tm_year)), RV(make_fixnum(lt->tm_wday)), RV(make_fixnum(lt->tm_yday)), RV(make_fixnum(lt->tm_isdst)), #if defined(__MINGW32__) RV(make_fixnum((lt->tm_hour-gmt_hour)*3600)), RV(Cnil) #else RV(make_fixnum(lt->tm_gmtoff)), RV(make_simple_string(lt->tm_zone)) #endif )); #endif } DEFUNM_NEW("GMTIME",object,fSgmtime,SI,1,1,NONE,OO,OO,OO,OO,(object t),"") { #if defined NO_SYSTEM_TIME_ZONE /*solaris*/ return Cnil; #else time_t i=object_to_time_t(t); struct tm *gt; massert(gt=gmtime(&i)); RETURN(11,object, make_fixnum(gt->tm_sec), ( RV(make_fixnum(gt->tm_min)), RV(make_fixnum(gt->tm_hour)), RV(make_fixnum(gt->tm_mday)), RV(make_fixnum(gt->tm_mon)), RV(make_fixnum(gt->tm_year)), RV(make_fixnum(gt->tm_wday)), RV(make_fixnum(gt->tm_yday)), RV(make_fixnum(gt->tm_isdst)), #if defined(__MINGW32__) RV(make_fixnum(0)), RV(Cnil) #else RV(make_fixnum(gt->tm_gmtoff)), RV(make_simple_string(gt->tm_zone)) #endif )); #endif } DEFUNM_NEW("MKTIME",object,fSmktime,SI,6,6,NONE,OI,II,II,IO,(fixnum s,fixnum n,fixnum h,fixnum d,fixnum m,fixnum y),"") { struct tm lt; time_t t; lt.tm_sec=s; lt.tm_min=n; lt.tm_hour=h; lt.tm_mday=d; lt.tm_mon=m; lt.tm_year=y; lt.tm_isdst=-1; massert((t=mktime(<))!=-1); RETURN(2,object,time_t_to_object(t),(RV(make_fixnum(lt.tm_isdst)))); } gcl-2.6.14/o/lex.c0000755000175000017500000000523014360276512012170 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* lex.c lexical environment */ #include "include.h" object assoc_eq(object key, object alist) { while (!endp(alist)) { if (MMcaar(alist) == key) return(MMcar(alist)); alist = MMcdr(alist); } return(Cnil); } void lex_fun_bind(object name, object fun) { object *top = vs_top; vs_push(make_cons(fun, Cnil)); top[0] = make_cons(sLfunction, top[0]); top[0] = make_cons(name, top[0]); lex_env[1] = make_cons(top[0],lex_env[1]); vs_top = top; } void lex_macro_bind(object name, object exp_fun) { object *top = vs_top; vs_push(make_cons(exp_fun, Cnil)); top[0] = make_cons(sSmacro, top[0]); top[0] = make_cons(name, top[0]); lex_env[1]=make_cons(top[0], lex_env[1]); vs_top = top; } void lex_tag_bind(object tag, object id) { object *top = vs_top; vs_push(make_cons(id, Cnil)); top[0] = make_cons(sStag, top[0]); top[0] = make_cons(tag, top[0]); lex_env[2] =make_cons(top[0], lex_env[2]); vs_top = top; } void lex_block_bind(object name, object id) { object *top = vs_top; vs_push(make_cons(id, Cnil)); top[0] = make_cons(sLblock, top[0]); top[0] = make_cons(name, top[0]); lex_env[2]= make_cons(top[0], lex_env[2]); vs_top = top; } object lex_tag_sch(object tag) { object alist = lex_env[2]; while (!endp(alist)) { if (eql(MMcaar(alist), tag) && MMcadar(alist) == sStag) return(MMcar(alist)); alist = MMcdr(alist); } return(Cnil); } object lex_block_sch(object name) { object alist = lex_env[2]; while (!endp(alist)) { if (MMcaar(alist) == name && MMcadar(alist) == sLblock) return(MMcar(alist)); alist = MMcdr(alist); } return(Cnil); } void gcl_init_lex(void) { /* sLfunction = make_ordinary("FUNCTION"); */ /* enter_mark_origin(&sLfunction); */ sSmacro = make_si_ordinary("MACRO"); enter_mark_origin(&sSmacro); sStag = make_si_ordinary("TAG"); enter_mark_origin(&sStag); sLblock = make_ordinary("BLOCK"); enter_mark_origin(&sLblock); } gcl-2.6.14/o/unexlin.c0000755000175000017500000006522314360276512013072 0ustar cammcamm/* Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* MODIFIED by M. Frigo (6 Mar 1993) to work with the linux port * of akcl-1-615 */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* Modified to support SysVr3 shared libraries by James Van Artsdalen * of Dell Computer Corporation. james@bigtex.cactus.org. */ /* There are several compilation parameters affecting unexec: * COFF Define this if your system uses COFF for executables. Otherwise we assume you use Berkeley format. * NO_REMAP Define this if you do not want to try to save Emacs's pure data areas as part of the text segment. Saving them as text is good because it allows users to share more. However, on machines that locate the text area far from the data area, the boundary cannot feasibly be moved. Such machines require NO_REMAP. Also, remapping can cause trouble with the built-in startup routine /lib/crt0.o, which defines `environ' as an initialized variable. Dumping `environ' as pure does not work! So, to use remapping, you must write a startup routine for your machine in Emacs's crt0.c. If NO_REMAP is defined, Emacs uses the system's crt0.o. * SECTION_ALIGNMENT Some machines that use COFF executables require that each section start on a certain boundary *in the COFF file*. Such machines should define SECTION_ALIGNMENT to a mask of the low-order bits that must be zero on such a boundary. This mask is used to control padding between segments in the COFF file. If SECTION_ALIGNMENT is not defined, the segments are written consecutively with no attempt at alignment. This is right for unmodified system V. * SEGMENT_MASK Some machines require that the beginnings and ends of segments *in core* be on certain boundaries. For most machines, a page boundary is sufficient. That is the default. When a larger boundary is needed, define SEGMENT_MASK to a mask of the bits that must be zero on such a boundary. * A_TEXT_OFFSET(HDR) Some machines count the a.out header as part of the size of the text segment (a_text); they may actually load the header into core as the first data in the text segment. Some have additional padding between the header and the real text of the program that is counted in a_text. For these machines, define A_TEXT_OFFSET(HDR) to examine the header structure HDR and return the number of bytes to add to `a_text' before writing it (above and beyond the number of bytes of actual program text). HDR's standard fields are already correct, except that this adjustment to the `a_text' field has not yet been made; thus, the amount of offset can depend on the data in the file. * A_TEXT_SEEK(HDR) If defined, this macro specifies the number of bytes to seek into the a.out file before starting to write the text segment.a * EXEC_MAGIC For machines using COFF, this macro, if defined, is a value stored into the magic number field of the output file. * ADJUST_EXEC_HEADER This macro can be used to generate statements to adjust or initialize nonstandard fields in the file header * ADDR_CORRECT(ADDR) Macro to correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This macro has a default definition which is usually right. This default definition is a no-op on most machines (where a pointer looks like an int) but not on all machines. */ #ifndef emacs #define PERROR(arg) perror (arg); return -1 #else #include "config.h" #define PERROR(file) report_error (file, new) #endif #ifndef CANNOT_DUMP /* all rest of file! */ #ifndef CANNOT_UNEXEC /* most of rest of file */ #include /* Define getpagesize () if the system does not. Note that this may depend on symbols defined in a.out.h */ #ifndef makedev /* Try to detect types.h already loaded */ #include #endif #include #include #include extern char *start_of_text (); /* Start of text */ extern char *start_of_data (); /* Start of initialized data */ #define start_of_data() &etext #define start_of_text() ( (char *) 0 ) extern char etext; static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name), copy_text_and_data (int new, int a_out), copy_sym (int new, int a_out, char *a_name, char *new_name); static int mark_x (char *name); #ifdef COFF #ifndef USG #ifndef STRIDE #ifndef UMAX #ifndef sun386 /* I have a suspicion that these are turned off on all systems and can be deleted. Try it in version 19. */ #include #include #include #include #endif /* not sun386 */ #endif /* not UMAX */ #endif /* Not STRIDE */ #endif /* not USG */ static long block_copy_start; /* Old executable start point */ static struct filehdr f_hdr; /* File header */ static struct aouthdr f_ohdr; /* Optional file header (a.out) */ long bias; /* Bias to add for growth */ long lnnoptr; /* Pointer to line-number info within file */ #define SYMS_START block_copy_start static long text_scnptr; static long data_scnptr; #else /* not COFF */ #define SYMS_START ((long) N_SYMOFF (ohdr)) /* Some machines override the structure name for an a.out header. */ #ifndef EXEC_HDR_TYPE #define EXEC_HDR_TYPE struct exec #endif #ifdef HPUX #ifdef HP9000S200_ID #define MY_ID HP9000S200_ID #else #include #define MY_ID MYSYS #endif /* no HP9000S200_ID */ static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; #define N_TXTOFF(x) TEXT_OFFSET(x) #define N_SYMOFF(x) LESYM_OFFSET(x) static EXEC_HDR_TYPE hdr, ohdr; #else /* not HPUX */ extern char *sbrk (int n); #if defined (USG) && !defined (IBMRTAIX) && !defined (IRIS) && !defined(linux) static struct bhdr hdr, ohdr; #define a_magic fmagic #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #define a_entry entry #define N_BADMAG(x) \ (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) #define NEWMAGIC FMAGIC #else /* IRIS or IBMRTAIX or not USG */ static EXEC_HDR_TYPE hdr, ohdr; #define NEWMAGIC ZMAGIC #endif /* IRIS or IBMRTAIX not USG */ #endif /* not HPUX */ static int unexec_text_start; static int unexec_data_start; #endif /* not COFF */ static int pagemask; /* Correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This is a no-op on ordinary machines, but not on all. */ #ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ #define ADDR_CORRECT(x) ((char *)(x) - (char*)0) #endif #ifdef emacs static report_error (file, fd) char *file; int fd; { if (fd) close (fd); error ("Failure operating on %s", file); } #endif /* emacs */ #define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 #define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 #define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 static report_error_1 (int fd, char *msg, int a1, int a2) { close (fd); #ifdef emacs error (msg, a1, a2); #else fprintf (stderr, msg, a1, a2); fprintf (stderr, "\n"); #endif } /* **************************************************************** * unexec * * driving logic. */ unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) { int new, a_out = -1; if (a_name && (a_out = open (a_name, 0)) < 0) { PERROR (a_name); } if ((new = creat (new_name, 0666)) < 0) { PERROR (new_name); } if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 || copy_text_and_data (new, a_out) < 0 || copy_sym (new, a_out, a_name, new_name) < 0 #ifdef COFF || adjust_lnnoptrs (new, a_out, new_name) < 0 #endif ) { close (new); /* unlink (new_name); /* Failed, unlink new a.out */ return -1; } close (new); if (a_out >= 0) close (a_out); return mark_x (new_name); } /* **************************************************************** * make_hdr * * Make the header in the new a.out from the header in core. * Modify the text and data sizes. */ static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) { int tem; #ifdef COFF auto struct scnhdr f_thdr; /* Text section header */ auto struct scnhdr f_dhdr; /* Data section header */ auto struct scnhdr f_bhdr; /* Bss section header */ auto struct scnhdr scntemp; /* Temporary section header */ register int scns; #endif /* COFF */ #ifdef USG_SHARED_LIBRARIES extern unsigned int bss_end; #else unsigned int bss_end; #endif pagemask = getpagesize () - 1; /* Adjust text/data boundary. */ #ifdef NO_REMAP data_start = (int) start_of_data (); #else /* not NO_REMAP */ if (!data_start) data_start = (int) start_of_data (); #endif /* not NO_REMAP */ data_start = ADDR_CORRECT (data_start); #ifdef SEGMENT_MASK data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ #else data_start = data_start & ~pagemask; /* (Down) to page boundary. */ #endif bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; bss_end &= ~ pagemask; /* Adjust data/bss boundary. */ if (bss_start != 0) { bss_start = (ADDR_CORRECT (bss_start) + pagemask); /* (Up) to page bdry. */ bss_start &= ~ pagemask; if (bss_start > bss_end) { ERROR1 ("unexec: Specified bss_start (%u) is past end of program", bss_start); } } else bss_start = bss_end; if (data_start > bss_start) /* Can't have negative data size. */ { ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", data_start, bss_start); } #ifdef COFF /* Salvage as much info from the existing file as possible */ if (a_out >= 0) { if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (a_name); } block_copy_start += sizeof (f_hdr); if (f_hdr.f_opthdr > 0) { if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (a_name); } block_copy_start += sizeof (f_ohdr); } /* Loop through section headers, copying them in */ for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) { PERROR (a_name); } if (scntemp.s_scnptr > 0L) { if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) block_copy_start = scntemp.s_scnptr + scntemp.s_size; } if (strcmp (scntemp.s_name, ".text") == 0) { f_thdr = scntemp; } else if (strcmp (scntemp.s_name, ".data") == 0) { f_dhdr = scntemp; } else if (strcmp (scntemp.s_name, ".bss") == 0) { f_bhdr = scntemp; } } } else { ERROR0 ("can't build a COFF file from scratch yet"); } /* Now we alter the contents of all the f_*hdr variables to correspond to what we want to dump. */ #ifdef USG_SHARED_LIBRARIES /* The amount of data we're adding to the file is distance from the * end of the original .data space to the current end of the .data * space. */ bias = bss_end - (f_ohdr.data_start + f_dhdr.s_size); #endif f_hdr.f_flags |= (F_RELFLG | F_EXEC); #ifdef TPIX f_hdr.f_nscns = 3; #endif #ifdef EXEC_MAGIC f_ohdr.magic = EXEC_MAGIC; #endif #ifndef NO_REMAP f_ohdr.text_start = (long) start_of_text (); f_ohdr.tsize = data_start - f_ohdr.text_start; f_ohdr.data_start = data_start; #endif /* NO_REMAP */ f_ohdr.dsize = bss_start - f_ohdr.data_start; f_ohdr.bsize = bss_end - bss_start; f_thdr.s_size = f_ohdr.tsize; f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); lnnoptr = f_thdr.s_lnnoptr; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_thdr.s_scnptr = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef TPIX f_thdr.s_scnptr = 0xd0; #endif text_scnptr = f_thdr.s_scnptr; f_dhdr.s_paddr = f_ohdr.data_start; f_dhdr.s_vaddr = f_ohdr.data_start; f_dhdr.s_size = f_ohdr.dsize; f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; #ifdef SECTION_ALIGNMENT /* Some systems require special alignment of the sections in the file itself. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; #endif /* SECTION_ALIGNMENT */ #ifdef DATA_SECTION_ALIGNMENT /* Some systems require special alignment of the data section only. */ f_dhdr.s_scnptr = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; #endif /* DATA_SECTION_ALIGNMENT */ data_scnptr = f_dhdr.s_scnptr; f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; f_bhdr.s_size = f_ohdr.bsize; f_bhdr.s_scnptr = 0L; #ifndef USG_SHARED_LIBRARIES bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; #endif if (f_hdr.f_symptr > 0L) { f_hdr.f_symptr += bias; } if (f_thdr.s_lnnoptr > 0L) { f_thdr.s_lnnoptr += bias; } #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER #endif /* ADJUST_EXEC_HEADER */ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (new_name); } if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (new_name); } #ifndef USG_SHARED_LIBRARIES if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) { PERROR (new_name); } if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) { PERROR (new_name); } if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) { PERROR (new_name); } #else /* USG_SHARED_LIBRARIES */ /* The purpose of this code is to write out the new file's section * header table. * * Scan through the original file's sections. If the encountered * section is one we know (.text, .data or .bss), write out the * correct header. If it is a section we do not know (such as * .lib), adjust the address of where the section data is in the * file, and write out the header. * * If any section preceeds .text or .data in the file, this code * will not adjust the file pointer for that section correctly. */ lseek (a_out, sizeof (f_hdr) + sizeof (f_ohdr), 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (a_name); if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ { if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ { if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) PERROR (new_name); } else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ { if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) PERROR (new_name); } else { if (scntemp.s_scnptr) scntemp.s_scnptr += bias; if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR (new_name); } } #endif /* USG_SHARED_LIBRARIES */ return (0); #else /* if not COFF */ /* Get symbol table info from header of a.out file if given one. */ if (a_out >= 0) { if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) { PERROR (a_name); } if (N_BADMAG (ohdr)) { ERROR1 ("invalid magic number in %s", a_name); } hdr = ohdr; } else { bzero (hdr, sizeof hdr); } unexec_text_start = (long) start_of_text (); unexec_data_start = data_start; /* Machine-dependent fixup for header, or maybe for unexec_text_start */ #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER; #endif /* ADJUST_EXEC_HEADER */ hdr.a_trsize = 0; hdr.a_drsize = 0; if (entry_address != 0) hdr.a_entry = entry_address; hdr.a_bss = bss_end - bss_start; hdr.a_data = bss_start - data_start; #ifdef NO_REMAP hdr.a_text = ohdr.a_text; #else /* not NO_REMAP */ hdr.a_text = data_start - unexec_text_start; #ifdef A_TEXT_OFFSET hdr.a_text += A_TEXT_OFFSET (ohdr); #endif #endif /* not NO_REMAP */ if (write (new, &hdr, sizeof hdr) != sizeof hdr) { PERROR (new_name); } #ifdef A_TEXT_OFFSET hdr.a_text -= A_TEXT_OFFSET (ohdr); #endif return 0; #endif /* not COFF */ } /* **************************************************************** * copy_text_and_data * * Copy the text and data segments from memory to the new a.out */ static int copy_text_and_data (int new, int a_out) { register char *end; register char *ptr; #ifdef COFF #ifdef USG_SHARED_LIBRARIES int scns; struct scnhdr scntemp; /* Temporary section header */ /* The purpose of this code is to write out the new file's section * contents. * * Step through the section table. If we know the section (.text, * .data) do the appropriate thing. Otherwise, if the section has * no allocated space in the file (.bss), do nothing. Otherwise, * the section has space allocated in the file, and is not a section * we know. So just copy it. */ lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); for (scns = f_hdr.f_nscns; scns > 0; scns--) { if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) PERROR ("temacs"); if (!strcmp (scntemp.s_name, ".text")) { lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); } else if (!strcmp (scntemp.s_name, ".data")) { lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); } else if (!scntemp.s_scnptr) ; /* do nothing - no data for this section */ else { char page[BUFSIZ]; int size, n; long old_a_out_ptr = lseek (a_out, 0, 1); lseek (a_out, scntemp.s_scnptr, 0); for (size = scntemp.s_size; size > 0; size -= sizeof (page)) { n = size > sizeof (page) ? sizeof (page) : size; if (read (a_out, page, n) != n || write (new, page, n) != n) PERROR ("xemacs"); } lseek (a_out, old_a_out_ptr, 0); } } #else /* COFF, but not USG_SHARED_LIBRARIES */ lseek (new, (long) text_scnptr, 0); ptr = (char *) f_ohdr.text_start; end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); lseek (new, (long) data_scnptr, 0); ptr = (char *) f_ohdr.data_start; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); #endif /* USG_SHARED_LIBRARIES */ #else /* if not COFF */ /* Some machines count the header as part of the text segment. That is to say, the header appears in core just before the address that start_of_text () returns. For them, N_TXTOFF is the place where the header goes. We must adjust the seek to the place after the header. Note that at this point hdr.a_text does *not* count the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ #ifdef A_TEXT_SEEK lseek (new, (long) A_TEXT_SEEK (hdr), 0); #else #ifdef A_TEXT_OFFSET /* Note that on the Sequent machine A_TEXT_OFFSET != sizeof (hdr) and sizeof (hdr) is the correct amount to add here. */ /* In version 19, eliminate this case and use A_TEXT_SEEK whenever N_TXTOFF is not right. */ lseek (new, (long) N_TXTOFF (hdr) + sizeof (hdr), 0); #else lseek (new, (long) N_TXTOFF (hdr), 0); #endif /* no A_TEXT_OFFSET */ #endif /* no A_TEXT_SEEK */ ptr = (char *) unexec_text_start; end = ptr + hdr.a_text; write_segment (new, ptr, end); ptr = (char *) unexec_data_start; end = ptr + hdr.a_data; /* This lseek is certainly incorrect when A_TEXT_OFFSET and I believe it is a no-op otherwise. Let's see if its absence ever fails. */ /* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ write_segment (new, ptr, end); #endif /* not COFF */ return 0; } write_segment (int new, register char *ptr, register char *end) { register int i, nwrite, ret; char buf[80]; extern int errno; char zeros[128]; bzero (zeros, sizeof zeros); for (i = 0; ptr < end;) { /* distance to next multiple of 128. */ nwrite = (((int) ptr + 128) & -128) - (int) ptr; /* But not beyond specified end. */ if (nwrite > end - ptr) nwrite = end - ptr; ret = write (new, ptr, nwrite); /* If write gets a page fault, it means we reached a gap between the old text segment and the old data segment. This gap has probably been remapped into part of the text segment. So write zeros for it. */ if (ret == -1 && errno == EFAULT) write (new, zeros, nwrite); else if (nwrite != ret) { sprintf (buf, "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", ptr, new, nwrite, ret, errno); PERROR (buf); } i += nwrite; ptr += nwrite; } } /* **************************************************************** * copy_sym * * Copy the relocation information and symbol table from the a.out to the new */ static int copy_sym (int new, int a_out, char *a_name, char *new_name) { char page[1024]; int n; if (a_out < 0) return 0; #ifdef COFF if (SYMS_START == 0L) return 0; #endif /* COFF */ #ifdef COFF if (lnnoptr) /* if there is line number info */ lseek (a_out, lnnoptr, 0); /* start copying from there */ else #endif /* COFF */ lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ while ((n = read (a_out, page, sizeof page)) > 0) { if (write (new, page, n) != n) { PERROR (new_name); } } if (n < 0) { PERROR (a_name); } return 0; } /* **************************************************************** * mark_x * * After succesfully building the new a.out, mark it executable */ static int mark_x (char *name) { struct stat sbuf; int um; int new = 0; /* for PERROR */ um = umask (777); umask (um); if (stat (name, &sbuf) == -1) { PERROR (name); } sbuf.st_mode |= 0111 & ~um; if (chmod (name, sbuf.st_mode) == -1) PERROR (name); return 0; } /* * If the COFF file contains a symbol table and a line number section, * then any auxiliary entries that have values for x_lnnoptr must * be adjusted by the amount that the line number section has moved * in the file (bias computed in make_hdr). The #@$%&* designers of * the auxiliary entry structures used the absolute file offsets for * the line number entry rather than an offset from the start of the * line number section! * * When I figure out how to scan through the symbol table and pick out * the auxiliary entries that need adjustment, this routine will * be fixed. As it is now, all such entries are wrong and sdb * will complain. Fred Fish, UniSoft Systems Inc. */ #ifdef COFF /* This function is probably very slow. Instead of reopening the new file for input and output it should copy from the old to the new using the two descriptors already open (WRITEDESC and READDESC). Instead of reading one small structure at a time it should use a reasonable size buffer. But I don't have time to work on such things, so I am installing it as submitted to me. -- RMS. */ adjust_lnnoptrs (writedesc, readdesc, new_name) int writedesc; int readdesc; char *new_name; { register int nsyms; register int new; #if defined (amdahl_uts) || defined (pfa) SYMENT symentry; AUXENT auxentry; #else struct syment symentry; union auxent auxentry; #endif if (!lnnoptr || !f_hdr.f_symptr) return 0; if ((new = open (new_name, 2)) < 0) { PERROR (new_name); return -1; } lseek (new, f_hdr.f_symptr, 0); for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) { read (new, &symentry, SYMESZ); if (symentry.n_numaux) { read (new, &auxentry, AUXESZ); nsyms++; if (ISFCN (symentry.n_type)) { auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; lseek (new, -AUXESZ, 1); write (new, &auxentry, AUXESZ); } } } close (new); } #endif /* COFF */ #endif /* not CANNOT_UNEXEC */ #endif /* not CANNOT_DUMP */ #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/num_sfun.c0000755000175000017500000003534314360276512013242 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define IN_NUM_CO #include "include.h" #include "num_include.h" object imag_unit, minus_imag_unit, imag_two; int fixnum_expt(int x, int y) { int z; z = 1; while (y > 0) if (y%2 == 0) { x *= x; y /= 2; } else { z *= x; --y; } return(z); } static object number_sin(object); static object number_cos(object); static object number_exp(object); static object number_nlog(object); static object number_atan2(object,object); static object number_exp(object x) { double exp(double); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat((longfloat)exp(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)exp((double)(sf(x))))); case t_longfloat: return(make_longfloat(exp(lf(x)))); case t_complex: { object y, y1; vs_mark; y = x->cmp.cmp_imag; x = x->cmp.cmp_real; x = number_exp(x); vs_push(x); y1 = number_cos(y); vs_push(y1); y = number_sin(y); vs_push(y); y = make_complex(y1, y); vs_push(y); x = number_times(x, y); vs_reset; return(x); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } static inline object number_fix_iexpt(object x,fixnum y,fixnum ly,fixnum j) { object z; if (j+1==ly) return x; z=number_fix_iexpt(number_times(x,x),y,ly,j+1); return fixnum_bitp(j,y) ? number_times(x,z) : z; } static inline object number_big_iexpt(object x,object y,fixnum ly,fixnum j) { object z; if (j+1==ly) return x; z=number_big_iexpt(number_times(x,x),y,ly,j+1); return mpz_tstbit(MP(y),j) ? number_times(x,z) : z; } static inline object number_zero_expt(object x,bool promote_short_p) { if (gcl_is_not_finite(x))/*FIXME, better place?*/ return number_exp(number_times(number_nlog(x),small_fixnum(0))); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return make_fixnum(1); case t_shortfloat: return promote_short_p ? make_longfloat(1.0) : make_shortfloat(1.0); case t_longfloat: return make_longfloat(1.0); case t_complex: return make_complex(number_zero_expt(x->cmp.cmp_real,promote_short_p),small_fixnum(0)); default: FEwrong_type_argument(sLnumber,x); return Cnil; } } static inline object number_ui_expt(object x,fixnum fy) { switch (type_of(x)) { case t_fixnum: { fixnum fx=fix(x); object z; MPOP(z=,mpz_ui_pow_ui,labs(fx),fy); if (fx<0&&(fy&0x1)) return number_negate(z); else return z; } case t_bignum: MPOP(return,mpz_pow_ui,MP(x),fy); case t_ratio: { object n=number_ui_expt(x->rat.rat_num,fy),d=number_ui_expt(x->rat.rat_den,fy),z=alloc_object(t_ratio); z->rat.rat_num=n; z->rat.rat_den=d;/*No need to make_ratio as no common factors*/ return z; } case t_shortfloat: case t_longfloat: case t_complex: { fixnum ly=fixnum_length(fy); return ly ? number_fix_iexpt(x,fy,ly,0) : number_zero_expt(x,0); } default: FEwrong_type_argument(sLnumber,x); return Cnil; } } static inline object number_ump_expt(object x,object y) { return number_big_iexpt(x,y,fix(integer_length(y)),0); } static inline object number_log_expt(object x,object y) { return number_zerop(y) ? number_zero_expt(x,type_of(x)==t_longfloat) : number_exp(number_times(number_nlog(x),y)); } static inline object number_invert(object x,object y,object z) { switch (type_of(z)) { case t_shortfloat: if (!ISNORMAL(sf(z))) return number_log_expt(x,y); break; case t_longfloat: if (!ISNORMAL(lf(z))) return number_log_expt(x,y); break; } return number_divide(small_fixnum(1),z); } static inline object number_si_expt(object x,object y) { switch (type_of(y)) { case t_fixnum: { fixnum fy=fix(y); if (fy>=0) return number_ui_expt(x,fy); if (fy==MOST_NEGATIVE_FIX) return number_invert(x,y,number_ump_expt(x,number_negate(y))); return number_invert(x,y,number_ui_expt(x,-fy)); } case t_bignum: return big_sign(y)<0 ? number_invert(x,y,number_ump_expt(x,number_negate(y))) : number_ump_expt(x,y); case t_ratio: case t_shortfloat: case t_longfloat: case t_complex: return number_log_expt(x,y); default: FEwrong_type_argument(sLnumber,y); return Cnil; } } object number_expt(object x, object y) { if (number_zerop(x)&&y!=small_fixnum(0)) { if (!number_plusp(type_of(y)==t_complex?y->cmp.cmp_real:y)) FEerror("Cannot raise zero to the power ~S.", 1, y); return(number_times(x, y)); } return number_si_expt(x,y); } static object number_nlog(object x) { double log(double); object r=Cnil, i=Cnil, a, p; vs_mark; if (type_of(x) == t_complex) { r = x->cmp.cmp_real; i = x->cmp.cmp_imag; goto COMPLEX; } if (number_zerop(x)) FEerror("Zero is the logarithmic singularity.", 0); if (number_minusp(x)) { r = x; i = small_fixnum(0); goto COMPLEX; } switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat(log(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)log((double)(sf(x))))); case t_longfloat: return(make_longfloat(log(lf(x)))); default: FEwrong_type_argument(sLnumber, x); } COMPLEX: a = number_times(r, r); vs_push(a); p = number_times(i, i); vs_push(p); a = number_plus(a, p); vs_push(a); a = number_nlog(a); vs_push(a); a = number_divide(a, small_fixnum(2)); vs_push(a); p = number_atan2(i, r); vs_push(p); x = make_complex(a, p); vs_reset; return(x); } static object number_log(object x, object y) { object z; vs_mark; if (number_zerop(y)) FEerror("Zero is the logarithmic singularity.", 0); if (number_zerop(x)) return(number_times(x, y)); x = number_nlog(x); vs_push(x); y = number_nlog(y); vs_push(y); z = number_divide(y, x); vs_reset; return(z); } static object number_sqrt(object x) { object z; double sqrt(double); vs_mark; if (type_of(x) == t_complex) goto COMPLEX; if (number_minusp(x)) goto COMPLEX; switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat( (longfloat)sqrt(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)sqrt((double)(sf(x))))); case t_longfloat: return(make_longfloat(sqrt(lf(x)))); default: FEwrong_type_argument(sLnumber, x); } COMPLEX: z = make_ratio(small_fixnum(1), small_fixnum(2)); vs_push(z); z = number_expt(x, z); vs_reset; return(z); } object number_abs(object x) { object r,i,z; switch(type_of(x)) { case t_complex: if (number_zerop(x)) return x->cmp.cmp_real; r=number_abs(x->cmp.cmp_real); i=number_abs(x->cmp.cmp_imag); if (number_compare(r,i)<0) { object z=i; i=r; r=z; } z=number_divide(i,r); return number_times(r,number_sqrt(one_plus(number_times(z,z)))); case t_fixnum: {fixnum fx=fix(x);return fx==MOST_NEGATIVE_FIX ? fixnum_add(1,MOST_POSITIVE_FIX) : (fx<0 ? make_fixnum(-fx) : x);} case t_bignum: return big_sign(x)<0 ? big_minus(x) : x; case t_ratio: {object n=number_abs(x->rat.rat_num);return n==x ? x : make_ratio(n,x->rat.rat_den);} case t_shortfloat: return sf(x)<0.0 ? make_shortfloat(-sf(x)) : x; case t_longfloat: return lf(x)<0.0 ? make_longfloat(-lf(x)) : x; default: FEwrong_type_argument(sLnumber,x); return(Cnil); } } object number_signum(object x) { switch (type_of(x)) { case t_fixnum: {fixnum fx=fix(x);return make_fixnum(fx<0 ? -1 : (fx==0 ? 0 : 1));} case t_bignum: return make_fixnum(big_sign(x)<0 ? -1 : 1); case t_ratio: return number_signum(x->rat.rat_num); case t_shortfloat: return make_shortfloat(sf(x)<0.0 ? -1.0 : (sf(x)==0.0 ? 0.0 : 1.0)); case t_longfloat: return make_longfloat(lf(x)<0.0 ? -1.0 : (lf(x)==0.0 ? 0.0 : 1.0)); case t_complex: return number_zerop(x) ? x : number_divide(x,number_abs(x)); default: FEwrong_type_argument(sLnumber,x); return(Cnil); } } static object number_atan2(object y, object x) { object z; double atan(double), dy, dx, dz=0.0; dy = number_to_double(y); dx = number_to_double(x); if (dx > 0.0) if (dy > 0.0) dz = atan(dy / dx); else if (dy == 0.0) dz = 0.0; else dz = -atan(-dy / dx); else if (dx == 0.0) if (dy > 0.0) dz = PI / 2.0; else if (dy == 0.0) dz = 0.0; else dz = -PI / 2.0; else if (dy > 0.0) dz = PI - atan(dy / -dx); else if (dy == 0.0) dz = PI; else dz = -PI + atan(-dy / -dx); if (type_of(x) == t_shortfloat) z = make_shortfloat((shortfloat)dz); else z = make_longfloat(dz); return(z); } static object number_atan(object y) { object z, z1; vs_mark; if (type_of(y) == t_complex) { z = number_times(imag_unit, y); vs_push(z); z = one_plus(z); vs_push(z); z1 = number_times(y, y); vs_push(z1); z1 = one_plus(z1); vs_push(z1); z1 = number_sqrt(z1); vs_push(z1); z = number_divide(z, z1); vs_push(z); z = number_nlog(z); vs_push(z); z = number_times(minus_imag_unit, z); vs_reset; return(z); } return(number_atan2(y, small_fixnum(1))); } static object number_sin(object x) { double sin(double); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat((longfloat)sin(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)sin((double)(sf(x))))); case t_longfloat: return(make_longfloat(sin(lf(x)))); case t_complex: { object r; object x0, x1, x2; vs_mark; x0 = number_times(imag_unit, x); vs_push(x0); x0 = number_exp(x0); vs_push(x0); x1 = number_times(minus_imag_unit, x); vs_push(x1); x1 = number_exp(x1); vs_push(x1); x2 = number_minus(x0, x1); vs_push(x2); r = number_divide(x2, imag_two); vs_reset; return(r); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } static object number_cos(object x) { double cos(double); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat((longfloat)cos(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)cos((double)(sf(x))))); case t_longfloat: return(make_longfloat(cos(lf(x)))); case t_complex: { object r; object x0, x1, x2; vs_mark; x0 = number_times(imag_unit, x); vs_push(x0); x0 = number_exp(x0); vs_push(x0); x1 = number_times(minus_imag_unit, x); vs_push(x1); x1 = number_exp(x1); vs_push(x1); x2 = number_plus(x0, x1); vs_push(x2); r = number_divide(x2, small_fixnum(2)); vs_reset; return(r); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } static object number_tan1(object x) { double cos(double); switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: return(make_longfloat((longfloat)tan(number_to_double(x)))); case t_shortfloat: return(make_shortfloat((shortfloat)tan((double)(sf(x))))); case t_longfloat: return(make_longfloat(tan(lf(x)))); case t_complex: { object r; object x0, x1, x2; vs_mark; x0 = number_times(imag_two, x); vs_push(x0); x0 = number_exp(x0); vs_push(x0); x1 = number_minus(x0,small_fixnum(1)); vs_push(x1); x2 = number_plus(x0,small_fixnum(1)); vs_push(x2); x2 = number_times(x2,imag_unit); vs_push(x2); r = number_divide(x1, x2); vs_reset; return(r); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } static object number_tan(object x) { object r, c; vs_mark; c = number_cos(x); vs_push(c); if (number_zerop(c) == TRUE) FEerror("Cannot compute the tangent of ~S.", 1, x); r = number_tan1(x); vs_reset; return(r); } LFD(Lexp)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = number_exp(vs_base[0]); } LFD(Lexpt)(void) { check_arg(2); check_type_number(&vs_base[0]); check_type_number(&vs_base[1]); vs_base[0] = number_expt(vs_base[0], vs_base[1]); vs_popp; } LFD(Llog)(void) { int narg; narg = vs_top - vs_base; if (narg < 1) too_few_arguments(); else if (narg == 1) { check_type_number(&vs_base[0]); vs_base[0] = number_nlog(vs_base[0]); } else if (narg == 2) { check_type_number(&vs_base[0]); check_type_number(&vs_base[1]); vs_base[0] = number_log(vs_base[1], vs_base[0]); vs_popp; } else too_many_arguments(); } LFD(Lsqrt)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = number_sqrt(vs_base[0]); } LFD(Lsin)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = number_sin(vs_base[0]); } LFD(Lcos)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = number_cos(vs_base[0]); } LFD(Ltan)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = number_tan(vs_base[0]); } LFD(Latan)(void) { int narg; narg = vs_top - vs_base; if (narg < 1) too_few_arguments(); if (narg == 1) { check_type_number(&vs_base[0]); vs_base[0] = number_atan(vs_base[0]); } else if (narg == 2) { check_type_or_rational_float(&vs_base[0]); check_type_or_rational_float(&vs_base[1]); vs_base[0] = number_atan2(vs_base[0], vs_base[1]); vs_popp; } else too_many_arguments(); } static void FFN(siLmodf)(void) { object x; double d,ip; check_arg(1); check_type_float(&vs_base[0]); x=vs_base[0]; vs_base=vs_top; d=type_of(x) == t_longfloat ? lf(x) : (double)sf(x); d=modf(d,&ip); vs_push(make_fixnum((int)ip)); vs_push(type_of(x) == t_longfloat ? make_longfloat(d) : make_shortfloat((shortfloat)d)); } void gcl_init_num_sfun(void) { imag_unit = make_complex(make_longfloat((longfloat)0.0), make_longfloat((longfloat)1.0)); enter_mark_origin(&imag_unit); minus_imag_unit = make_complex(make_longfloat((longfloat)0.0), make_longfloat((longfloat)-1.0)); enter_mark_origin(&minus_imag_unit); imag_two = make_complex(make_longfloat((longfloat)0.0), make_longfloat((longfloat)2.0)); enter_mark_origin(&imag_two); make_constant("PI", make_longfloat(PI)); make_function("EXP", Lexp); make_function("EXPT", Lexpt); make_function("LOG", Llog); make_function("SQRT", Lsqrt); make_function("SIN", Lsin); make_function("COS", Lcos); make_function("TAN", Ltan); make_function("ATAN", Latan); make_si_function("MODF", siLmodf); } gcl-2.6.14/o/malloc.c0000755000175000017500000005456414360276512012665 0ustar cammcamm/* dynamic memory allocation for GNU. Copyright (C) 1985, 1987 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELY NO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC, RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M. STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTY WHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THIS PROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source file as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy a valid copyright notice "Copyright (C) 1985 Free Software Foundation, Inc."; and include following the copyright notice a verbatim copy of the above disclaimer of warranty and of this License. You may charge a distribution fee for the physical act of transferring a copy. 2. You may modify your copy or copies of this source file or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another unrelated program with this program (or its derivative) on a volume of a storage or distribution medium does not bring the other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this program except as expressly provided under this License Agreement. Any attempt otherwise to copy, sublicense, distribute or transfer this program is void and your rights to use the program under this License agreement shall be automatically terminated. However, parties who have received computer software programs from you with this License Agreement will not have their licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other free programs whose distribution conditions are different, write to the Free Software Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yet worked out a simple rule that can be stated here, but we will often permit this. We will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * @(#)nmalloc.c 1 (Caltech) 2/21/82 * * U of M Modified: 20 Jun 1983 ACT: strange hacks for Emacs * * Nov 1983, Mike@BRL, Added support for 4.1C/4.2 BSD. * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. In this * implementation, the available sizes are (2^n)-4 (or -16) bytes long. * This is designed for use in a program that uses vast quantities of * memory, but bombs when it runs out. To make it a little better, it * warns the user when he starts to get near the end. * * June 84, ACT: modified rcheck code to check the range given to malloc, * rather than the range determined by the 2-power used. * * Jan 85, RMS: calls malloc_warning to issue warning on nearly full. * No longer Emacs-specific; can serve as all-purpose malloc for GNU. * You should call malloc_init to reinitialize after loading dumped Emacs. * Call malloc_stats to get info on memory stats if MSTATS turned on. * realloc knows how to return same block given, just changing its size, * if the power of 2 is correct. */ /* Oct 89: wfs@cs.utexas.edu: Created V/ merge file for * changes for GCL. * Calls to sbrk replaced by alloc_page. Remove some of the * additions for emacs. * NB: According to the gnu license you may only distribute the * verbatim copy of the gnumalloc.c. Thus we only distribute * an abbreviated diffs file from that verbatim copy. */ /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information will * go in the first int of the block, and the returned pointer will point * to the second. * #ifdef MSTATS * nmalloc[i] is the difference between the number of mallocs and frees * for a given block size. #endif /* MSTATS */ #ifdef emacs #include "config.h" #endif /* emacs */ /* Determine which kind of system this is. */ #include #ifndef SIGTSTP #ifndef VMS #ifndef USG #define USG #endif #endif /* not VMS */ #else /* SIGTSTP */ #ifdef SIGIO #define BSD42 #endif /* SIGIO */ #endif /* SIGTSTP */ /* Define getpagesize () if the system does not. */ #define getpagesize() 2048 #ifndef BSD42 #ifndef USG #include /* warn the user when near the end */ #endif /* not USG */ #else /* if BSD42 */ #include /* #include */ #endif /* BSD42 */ extern char *start_of_data (); #ifdef BSD #ifndef DATA_SEG_BITS #define start_of_data() &etext #endif #endif #ifndef emacs #define start_of_data() &etext #endif #define ISALLOC ((char) 0xf7) /* magic byte that implies allocation */ #define ISFREE ((char) 0x54) /* magic byte that implies free block */ /* this is for error checking only */ #define ISMEMALIGN ((char) 0xd6) /* Stored before the value returned by memalign, with the rest of the word being the distance to the true beginning of the block. */ extern char etext; /* These two are for user programs to look at, when they are interested. */ unsigned int malloc_sbrk_used; /* amount of data space used now */ unsigned int malloc_sbrk_unused; /* amount more we can have */ /* start of data space; can be changed by calling init_malloc */ static char *data_space_start; #define PAGEWIDTH 11 char *alloc_page(); #define sbrk our_sbrk char * our_sbrk(x) int x; {return alloc_page((x >> PAGEWIDTH));} #ifdef MSTATS static int nmalloc[30]; static int nmal, nfre; #endif /* MSTATS */ /* If range checking is not turned on, all we have is a flag indicating whether memory is allocated, an index in nextf[], and a size field; to realloc() memory we copy either size bytes or 1<<(index+3) bytes depending on whether the former can hold the exact size (given the value of 'index'). If range checking is on, we always need to know how much space is allocated, so the 'size' field is never used. */ struct mhead { char mh_alloc; /* ISALLOC or ISFREE */ char mh_index; /* index in nextf[] */ /* Remainder are valid only when block is allocated */ unsigned short mh_size; /* size, if < 0x10000 */ #ifdef rcheck unsigned mh_nbytes; /* number of bytes allocated */ int mh_magic4; /* should be == MAGIC4 */ #endif /* rcheck */ }; /* Access free-list pointer of a block. It is stored at block + 4. This is not a field in the mhead structure because we want sizeof (struct mhead) to describe the overhead for when the block is in use, and we do not want the free-list pointer to count in that. */ #define CHAIN(a) \ (*(struct mhead **) (sizeof (char *) + (char *) (a))) #ifdef rcheck /* To implement range checking, we write magic values in at the beginning and end of each allocated block, and make sure they are undisturbed whenever a free or a realloc occurs. */ /* Written in each of the 4 bytes following the block's real space */ #define MAGIC1 0x55 /* Written in the 4 bytes before the block's real space */ #define MAGIC4 0x55555555 #define ASSERT(p) if (!(p)) botch("p"); else #define EXTRA 4 /* 4 bytes extra for MAGIC1s */ #else #define ASSERT(p) #define EXTRA 0 #endif /* rcheck */ /* nextf[i] is free list of blocks of size 2**(i + 3) */ static struct mhead *nextf[30]; /* busy[i] is nonzero while allocation of block size i is in progress. */ static char busy[30]; /* Number of bytes of writable memory we can expect to be able to get */ static unsigned int lim_data; /* Level number of warnings already issued. 0 -- no warnings issued. 1 -- 75% warning already issued. 2 -- 85% warning already issued. */ static int warnlevel; /* Function to call to issue a warning; 0 means don't issue them. */ static void (*warnfunction) (); /* nonzero once initial bunch of free blocks made */ static int gotpool; char *_malloc_base; static void getpool (); /* Cause reinitialization based on job parameters; also declare where the end of pure storage is. */ void malloc_init (start, warnfun) char *start; void (*warnfun) (); { if (start) data_space_start = start; lim_data = 0; warnlevel = 0; warnfunction = warnfun; } /* Return the maximum size to which MEM can be realloc'd without actually requiring copying. */ int malloc_usable_size (mem) char *mem; { int blocksize = 8 << (((struct mhead *) mem) - 1) -> mh_index; return blocksize - sizeof (struct mhead) - EXTRA; } static void morecore (nu) /* ask system for more memory */ register int nu; /* size index to get more of */ { char *sbrk (); register char *cp; register int nblks; register unsigned int siz; int oldmask; #ifdef BSD #ifndef BSD4_1 oldmask = sigsetmask (-1); #endif #endif if (!data_space_start) { data_space_start = start_of_data (); } if (lim_data == 0) get_lim_data (); /* On initial startup, get two blocks of each size up to 1k bytes */ if (!gotpool) { getpool (); getpool (); gotpool = 1; } /* Find current end of memory and issue warning if getting near max */ /* Take at least 2k, and figure out how many blocks of the desired size we're about to get */ nblks = 1; if ((siz = nu) < 8) nblks = 1 << ((siz = 8) - nu); if ((cp = sbrk (1 << (siz + 3)))==0) return; /* no more room! */ /* save new header and link the nblks blocks together */ nextf[nu] = (struct mhead *) cp; siz = 1 << (nu + 3); while (1) { ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = nu; if (--nblks <= 0) break; CHAIN ((struct mhead *) cp) = (struct mhead *) (cp + siz); cp += siz; } CHAIN ((struct mhead *) cp) = 0; #ifdef BSD #ifndef BSD4_1 sigsetmask (oldmask); #endif #endif } static void getpool () { register int nu; char * sbrk (); register char *cp = sbrk (0); if ((int) cp & 0x3ff) /* land on 1K boundaries */ sbrk (1024 - ((int) cp & 0x3ff)); /* Record address of start of space allocated by malloc. */ if (_malloc_base == 0) _malloc_base = cp; /* Get 2k of storage */ cp = sbrk (04000); if (cp == (char *) -1) return; /* Divide it into an initial 8-word block plus one block of size 2**nu for nu = 3 ... 10. */ CHAIN (cp) = nextf[0]; nextf[0] = (struct mhead *) cp; ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = 0; cp += 8; for (nu = 0; nu < 7; nu++) { CHAIN (cp) = nextf[nu]; nextf[nu] = (struct mhead *) cp; ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = nu; cp += 8 << nu; } } char * malloc (n) /* get a block */ unsigned n; { register struct mhead *p; register unsigned int nbytes; register int nunits = 0; /* Figure out how many bytes are required, rounding up to the nearest multiple of 4, then figure out which nextf[] area to use */ nbytes = (n + sizeof *p + EXTRA + 3) & ~3; { register unsigned int shiftr = (nbytes - 1) >> 2; while (shiftr >>= 1) nunits++; } /* In case this is reentrant use of malloc from signal handler, pick a block size that no other malloc level is currently trying to allocate. That's the easiest harmless way not to interfere with the other level of execution. */ while (busy[nunits]) nunits++; busy[nunits] = 1; /* If there are no blocks of the appropriate size, go get some */ /* COULD SPLIT UP A LARGER BLOCK HERE ... ACT */ if (nextf[nunits] == 0) morecore (nunits); /* Get one block off the list, and set the new list head */ if ((p = nextf[nunits]) == 0) { busy[nunits] = 0; return 0; } nextf[nunits] = CHAIN (p); busy[nunits] = 0; /* Check for free block clobbered */ /* If not for this check, we would gobble a clobbered free chain ptr */ /* and bomb out on the NEXT allocate of this size block */ if (p -> mh_alloc != ISFREE || p -> mh_index != nunits) #ifdef rcheck botch ("block on free list clobbered"); #else /* not rcheck */ abort (); #endif /* not rcheck */ /* Fill in the info, and if range checking, set up the magic numbers */ p -> mh_alloc = ISALLOC; #ifdef rcheck p -> mh_nbytes = n; p -> mh_magic4 = MAGIC4; { register char *m = (char *) (p + 1) + n; *m++ = MAGIC1, *m++ = MAGIC1, *m++ = MAGIC1, *m = MAGIC1; } #else /* not rcheck */ p -> mh_size = n; #endif /* not rcheck */ #ifdef MSTATS nmalloc[nunits]++; nmal++; #endif /* MSTATS */ return (char *) (p + 1); } free (mem) char *mem; { register struct mhead *p; { register char *ap = mem; if (ap == 0) return; p = (struct mhead *) ap - 1; if (p -> mh_alloc == ISMEMALIGN) { ap -= p->mh_size; p = (struct mhead *) ap - 1; } if (p -> mh_alloc != ISALLOC) abort (); #ifdef rcheck ASSERT (p -> mh_magic4 == MAGIC4); ap += p -> mh_nbytes; ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); ASSERT (*ap == MAGIC1); #endif /* rcheck */ } { register int nunits = p -> mh_index; ASSERT (nunits <= 29); p -> mh_alloc = ISFREE; /* Protect against signal handlers calling malloc. */ busy[nunits] = 1; /* Put this block on the free list. */ CHAIN (p) = nextf[nunits]; nextf[nunits] = p; busy[nunits] = 0; #ifdef MSTATS nmalloc[nunits]--; nfre++; #endif /* MSTATS */ } } char * realloc (mem, n) char *mem; register unsigned n; { register struct mhead *p; register unsigned int tocopy; register unsigned int nbytes; register int nunits; if ((p = (struct mhead *) mem) == 0) return malloc (n); p--; nunits = p -> mh_index; ASSERT (p -> mh_alloc == ISALLOC); #ifdef rcheck ASSERT (p -> mh_magic4 == MAGIC4); { register char *m = mem + (tocopy = p -> mh_nbytes); ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); ASSERT (*m == MAGIC1); } #else /* not rcheck */ if (p -> mh_index >= 13) tocopy = (1 << (p -> mh_index + 3)) - sizeof *p; else tocopy = p -> mh_size; #endif /* not rcheck */ /* See if desired size rounds to same power of 2 as actual size. */ nbytes = (n + sizeof *p + EXTRA + 7) & ~7; /* If ok, use the same block, just marking its size as changed. */ if (nbytes > (4 << nunits) && nbytes <= (8 << nunits)) { #ifdef rcheck register char *m = mem + tocopy; *m++ = 0; *m++ = 0; *m++ = 0; *m++ = 0; p-> mh_nbytes = n; m = mem + n; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; #else /* not rcheck */ p -> mh_size = n; #endif /* not rcheck */ return mem; } if (n < tocopy) tocopy = n; { register char *new; if ((new = malloc (n)) == 0) return 0; bcopy (mem, new, tocopy); free (mem); return new; } } #ifndef VMS static char * memalign (alignment, size) unsigned alignment, size; { register char *ptr = malloc (size + alignment); register char *aligned; register struct mhead *p; if (ptr == 0) return 0; /* If entire block has the desired alignment, just accept it. */ if (((int) ptr & (alignment - 1)) == 0) return ptr; /* Otherwise, get address of byte in the block that has that alignment. */ aligned = (char *) (((int) ptr + alignment - 1) & -alignment); /* Store a suitable indication of how to free the block, so that free can find the true beginning of it. */ p = (struct mhead *) aligned - 1; p -> mh_size = aligned - ptr; p -> mh_alloc = ISMEMALIGN; return aligned; } #ifndef HPUX /* This runs into trouble with getpagesize on HPUX. Patching out seems cleaner than the ugly fix needed. */ static char * valloc (size) { return memalign (getpagesize (), size); } #endif /* not HPUX */ #endif /* not VMS */ #ifdef MSTATS /* Return statistics describing allocation of blocks of size 2**n. */ struct mstats_value { int blocksize; int nfree; int nused; }; struct mstats_value malloc_stats (size) int size; { struct mstats_value v; register int i; register struct mhead *p; v.nfree = 0; if (size < 0 || size >= 30) { v.blocksize = 0; v.nused = 0; return v; } v.blocksize = 1 << (size + 3); v.nused = nmalloc[size]; for (p = nextf[size]; p; p = CHAIN (p)) v.nfree++; return v; } #endif /* MSTATS */ /* * This function returns the total number of bytes that the process * will be allowed to allocate via the sbrk(2) system call. On * BSD systems this is the total space allocatable to stack and * data. On USG systems this is the data space only. */ #ifdef USG get_lim_data () { extern long ulimit (); lim_data = ulimit (3, 0); lim_data -= (long) data_space_start; } #else /* not USG */ #ifndef BSD42 get_lim_data () { lim_data = vlimit (LIM_DATA, -1); } #else /* BSD42 */ get_lim_data () { struct rlimit XXrlimit; #ifdef RLIMIT_DATA getrlimit (RLIMIT_DATA, &XXrlimit); #endif #ifdef RLIM_INFINITY lim_data = XXrlimit.rlim_cur & RLIM_INFINITY; /* soft limit */ #else lim_data = XXrlimit.rlim_cur; /* soft limit */ #endif } #endif /* BSD42 */ #endif /* not USG */ #ifdef VMS /* There is a problem when dumping and restoring things on VMS. Calls * to SBRK don't necessarily result in contiguous allocation. Dumping * doesn't work when it isn't. Therefore, we make the initial * allocation contiguous by allocating a big chunk, and do SBRKs from * there. Once Emacs has dumped there is no reason to continue * contiguous allocation, malloc doesn't depend on it. * * There is a further problem of using brk and sbrk while using VMS C * run time library routines malloc, calloc, etc. The documentation * says that this is a no-no, although I'm not sure why this would be * a problem. In any case, we remove the necessity to call brk and * sbrk, by calling calloc (to assure zero filled data) rather than * sbrk. * * VMS_ALLOCATION_SIZE is the size of the allocation array. This * should be larger than the malloc size before dumping. Making this * too large will result in the startup procedure slowing down since * it will require more space and time to map it in. * * The value for VMS_ALLOCATION_SIZE in the following define was determined * by running emacs linked (and a large allocation) with the debugger and * looking to see how much storage was used. The allocation was 201 pages, * so I rounded it up to a power of two. */ #ifndef VMS_ALLOCATION_SIZE #define VMS_ALLOCATION_SIZE (512*256) #endif /* Use VMS RTL definitions */ #undef sbrk #undef brk #undef malloc int vms_out_initial = 0; char vms_initial_buffer[VMS_ALLOCATION_SIZE]; static char *vms_current_brk = &vms_initial_buffer; static char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; #include char * sys_sbrk (incr) int incr; { char *sbrk(), *temp, *ptr; if (vms_out_initial) { /* out of initial allocation... */ if (!(temp = malloc (incr))) temp = (char *) -1; } else { /* otherwise, go out of our area */ ptr = vms_current_brk + incr; /* new current_brk */ if (ptr <= vms_end_brk) { temp = vms_current_brk; vms_current_brk = ptr; } else { vms_out_initial = 1; /* mark as out of initial allocation */ if (!(temp = malloc (incr))) temp = (char *) -1; } } return temp; } #endif /* VMS */ gcl-2.6.14/o/rel_sun4.c0000755000175000017500000001053114360276512013133 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c Thanks to Blewett@research.att.com, for an initial effort on this. */ /* Unfortunately the original documentation of the relocation types was rather sketchy, so I was not able to determine the correct behaviour of types which were not currently being output. These will have to be added later, for the moment an abort will occur. One way to check your work is to compile sfasl.c defining STAND, and then compare (using comp.c) the output from it with the output from ld. */ relocate() { char *where; { unsigned int new_value; long x; where = the_start + relocation_info.r_address; dprintf (where has %x , *where); dprintf( at %x -->, where ); #ifdef DEBUG dshow(); #endif if(relocation_info.r_extern) { switch (relocation_info.r_type) { case RELOC_DISP8: /* Disp's (pc-rel) */ case RELOC_DISP16: case RELOC_DISP32: abort(); case RELOC_WDISP30: dprintf ( symbol_table[relocation_info.r_index].n_value %d, symbol_table[relocation_info.r_index].n_value); new_value = symbol_table[relocation_info.r_index].n_value + relocation_info.r_addend - (int)start_address; break; case RELOC_8: /* simplest relocs */ case RELOC_16: case RELOC_32: case RELOC_HI22: /* SR 22-bit relocs */ case RELOC_LO10: dprintf( symbol_table[relocation_info.r_index].n_value = %d , symbol_table[relocation_info.r_index].n_value); new_value = symbol_table[relocation_info.r_index].n_value; break; default: printf ("extern non-supported relocation_info.r_type=%d\n", relocation_info.r_type); fflush (stdout); goto DONT; } dprintf( new value %x , new_value); dprintf( rtype %x , relocation_info.r_type); } else { switch(relocation_info.r_index) /* was symbolnum */ { case N_DATA: case N_BSS: case N_TEXT: new_value= (int)start_address; break; default: abort(); goto DONT; } } switch (relocation_info.r_type) { #define WHERE relocation_info.r_addend case RELOC_8: /* simplest relocs */ *(char *)where = x = new_value + WHERE; break; case RELOC_16: *(short *)where = x = new_value + WHERE; break; case RELOC_32: *(int *)where = x = new_value + WHERE; break; case RELOC_DISP8: /* Disp's (pc-rel) */ abort(); *(char *)where = x = new_value + *(char *) where; break; case RELOC_DISP16: abort(); *(short *)where = x = new_value + *(short *) where; break; case RELOC_DISP32: abort(); *(int *)where = new_value + *(int *) where; x = new_value + *( int *) where; break; case RELOC_WDISP30: /* SR word disp's */ #define MASK30BITS 0x3FFFFFFF *(int *)where = ((((int) new_value) >> 2) & MASK30BITS) | (~MASK30BITS & ( *(int *) where)); break; case RELOC_WDISP22: goto Default; case RELOC_HI22: /* SR 22-bit relocs */ x = ((unsigned long) (new_value + relocation_info.r_addend)) >> 10; #define MASK22 0x3fffff *(long *) where= (~MASK22 & *(long *)where) | x; break; case RELOC_22: case RELOC_13: /* SR 13&10-bit relocs*/ goto Default; case RELOC_LO10: x = ((unsigned long) (new_value + relocation_info.r_addend)) & 0x3ff; *(unsigned short *)(where + 2) |= x; break; case RELOC_SFA_BASE: /* SR S.F.A. relocs */ case RELOC_SFA_OFF13: case RELOC_BASE10: /* base_relative pic */ case RELOC_BASE13: case RELOC_BASE22: case RELOC_PC10: /* special pc-rel pic*/ case RELOC_PC22: case RELOC_JMP_TBL: /* jmp_tbl_rel in pic */ case RELOC_SEGOFF16: /* ShLib offset-in-seg*/ case RELOC_GLOB_DAT: /* rtld relocs */ case RELOC_JMP_SLOT: case RELOC_RELATIVE: Default: default: printf ("non-supported relocation_info.r_type=%d\n", relocation_info.r_type); fflush (stdout); abort(); } DONT:; } } #ifdef DEBUG dshow() { if(debug) printf("\nrelocation_info:{r_address %d,r_index %d,r_extern %d \n r_type %d, r_addend %d" , relocation_info.r_address , relocation_info.r_index , relocation_info.r_extern , relocation_info.r_type , relocation_info.r_addend); fflush(stdout);} #endif /* DEBUG */ gcl-2.6.14/o/unexsgi.c0000755000175000017500000007765614360276512013107 0ustar cammcamm/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. * ELF support added. * * Basic theory: the data space of the running process needs to be * dumped to the output file. Normally we would just enlarge the size * of .data, scooting everything down. But we can't do that in ELF, * because there is often something between the .data space and the * .bss space. * * In the temacs dump below, notice that the Global Offset Table * (.got) and the Dynamic link data (.dynamic) come between .data1 and * .bss. It does not work to overlap .data with these fields. * * The solution is to create a new .data segment. This segment is * filled with data from the current process. Since the contents of * various sections refer to sections by index, the new .data segment * is made the last in the table to avoid changing any existing index. * This is an example of how the section headers are changed. "Addr" * is a process virtual address. "Offset" is a file offset. raid:/nfs/raid/src/dist-18.56/src> dump -h temacs temacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80a98f4 0x608f4 0x449c .bss 0 0 0x4 0 [17] 2 0 0 0x608f4 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x6a484 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x729aa 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x72a3d 0x68b7 .comment 0 0 0x1 0 raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs xemacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [17] 2 0 0 0x7d800 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 [21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 * This is an example of how the file header is changed. "Shoff" is * the section header offset within the file. Since that table is * after the new .data section, it is moved. "Shnum" is the number of * sections, which we increment. * * "Phoff" is the file offset to the program header. "Phentsize" and * "Shentsz" are the program and section header entries sizes respectively. * These can be larger than the apparent struct sizes. raid:/nfs/raid/src/dist-18.56/src> dump -f temacs temacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x792f4 0 0x34 0x20 5 0x28 21 19 raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs xemacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x96200 0 0x34 0x20 5 0x28 22 19 * These are the program headers. "Offset" is the file offset to the * segment. "Vaddr" is the memory load address. "Filesz" is the * segment size as it appears in the file, and "Memsz" is the size in * memory. Below, the third segment is the code and the fourth is the * data: the difference between Filesz and Memsz is .bss raid:/nfs/raid/src/dist-18.56/src> dump -o temacs temacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x215c4 0x25a60 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs xemacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x3e4d0 0x3e4d0 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 */ /* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. * * The above mechanism does not work if the unexeced ELF file is being * re-layout by other applications (such as `strip'). All the applications * that re-layout the internal of ELF will layout all sections in ascending * order of their file offsets. After the re-layout, the data2 section will * still be the LAST section in the section header vector, but its file offset * is now being pushed far away down, and causes part of it not to be mapped * in (ie. not covered by the load segment entry in PHDR vector), therefore * causes the new binary to fail. * * The solution is to modify the unexec algorithm to insert the new data2 * section header right before the new bss section header, so their file * offsets will be in the ascending order. Since some of the section's (all * sections AFTER the bss section) indexes are now changed, we also need to * modify some fields to make them point to the right sections. This is done * by macro PATCH_INDEX. All the fields that need to be patched are: * * 1. ELF header e_shstrndx field. * 2. section header sh_link and sh_info field. * 3. symbol table entry st_shndx field. * * The above example now should look like: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 [17] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [18] 2 0 0 0x7d800 0x9b90 .symtab 19 371 0x4 0x10 [19] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [20] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [21] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 */ #include #include #include #include #include #include #include #include #include #include /* for HDRR declaration */ #include #ifndef emacs #define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) #else extern void fatal(char *, ...); #endif /* Get the address of a particular section or program header entry, * accounting for the size of the entries. */ #define OLD_SECTION_H(n) \ (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) #define NEW_SECTION_H(n) \ (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) #define OLD_PROGRAM_H(n) \ (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) #define NEW_PROGRAM_H(n) \ (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) #define PATCH_INDEX(n) \ do { \ if ((n) >= old_bss_index) \ (n)++; } while (0) typedef unsigned char byte; /* Round X up to a multiple of Y. */ int round_up (x, y) int x, y; { int rem = x % y; if (rem == 0) return x; return x - rem + y; } /* Return the index of the section named NAME. SECTION_NAMES, FILE_NAME and FILE_H give information about the file we are looking in. If we don't find the section NAME, that is a fatal error if NOERROR is 0; we return -1 if NOERROR is nonzero. */ static int find_section (name, section_names, file_name, old_file_h, old_section_h, noerror) char *name; char *section_names; char *file_name; Elf32_Ehdr *old_file_h; Elf32_Shdr *old_section_h; int noerror; { int idx; for (idx = 1; idx < old_file_h->e_shnum; idx++) { #ifdef DEBUG fprintf (stderr, "Looking for %s - found %s\n", name, section_names + OLD_SECTION_H (idx).sh_name); #endif if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, name)) break; } if (idx == old_file_h->e_shnum) { if (noerror) return -1; else fatal ("Can't find .bss in %s.\n", file_name, 0); } return idx; } /* **************************************************************** * unexec * * driving logic. * * In ELF, this works by replacing the old .bss section with a new * .data section, and inserting an empty .bss immediately afterwards. * */ void unexec (new_name, old_name, data_start, bss_start, entry_address) char *new_name, *old_name; unsigned data_start, bss_start, entry_address; { extern unsigned int bss_end; int new_file, old_file, new_file_size; /* Pointers to the base of the image of the two files. */ caddr_t old_base, new_base; /* Pointers to the file, program and section headers for the old and new files. */ Elf32_Ehdr *old_file_h, *new_file_h; Elf32_Phdr *old_program_h, *new_program_h; Elf32_Shdr *old_section_h, *new_section_h; /* Point to the section name table in the old file. */ char *old_section_names; Elf32_Addr old_bss_addr, new_bss_addr; Elf32_Word old_bss_size, new_data2_size; Elf32_Off new_data2_offset; Elf32_Addr new_data2_addr; Elf32_Addr new_offsets_shift; int n, nn, old_bss_index, old_data_index, new_data2_index; int old_mdebug_index; struct stat stat_buf; /* Open the old file & map it into the address space. */ old_file = open (old_name, O_RDONLY); if (old_file < 0) fatal ("Can't open %s for reading: errno %d\n", old_name, errno); if (fstat (old_file, &stat_buf) == -1) fatal ("Can't fstat(%s): errno %d\n", old_name, errno); old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); if (old_base == (caddr_t) -1) fatal ("Can't mmap(%s): errno %d\n", old_name, errno); #ifdef DEBUG fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, old_base); #endif /* Get pointers to headers & section names. */ old_file_h = (Elf32_Ehdr *) old_base; old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); old_section_names = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; /* Find the mdebug section, if any. */ old_mdebug_index = find_section (".mdebug", old_section_names, old_name, old_file_h, old_section_h, 1); /* Find the old .bss section. */ old_bss_index = find_section (".bss", old_section_names, old_name, old_file_h, old_section_h, 0); /* Find the old .data section. Figure out parameters of the new data2 and bss sections. */ old_data_index = find_section (".data", old_section_names, old_name, old_file_h, old_section_h, 0); old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; #if defined(emacs) || !defined(DEBUG) bss_end = (unsigned int) sbrk (0); new_bss_addr = (Elf32_Addr) bss_end; /* add for gcl */ core_end = (char *) bss_end; #else new_bss_addr = old_bss_addr + old_bss_size + 0x1234; #endif new_data2_addr = old_bss_addr; new_data2_size = new_bss_addr - old_bss_addr; new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); new_offsets_shift = new_bss_addr - ((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0)); #ifdef DEBUG fprintf (stderr, "old_bss_index %d\n", old_bss_index); fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); fprintf (stderr, "old_bss_size %x\n", old_bss_size); fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); fprintf (stderr, "new_data2_size %x\n", new_data2_size); fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift); #endif if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) fatal (".bss shrank when undumping???\n", 0, 0); /* Set the output file to the right size and mmap it. Set pointers to various interesting objects. stat_buf still has old_file data. */ new_file = open (new_name, O_RDWR | O_CREAT, 0666); if (new_file < 0) fatal ("Can't creat (%s): errno %d\n", new_name, errno); new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift; if (ftruncate (new_file, new_file_size)) fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, new_file, 0); if (new_base == (caddr_t) -1) fatal ("Can't mmap (%s): errno %d\n", new_name, errno); new_file_h = (Elf32_Ehdr *) new_base; new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); new_section_h = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff + new_offsets_shift); /* Make our new file, program and section headers as copies of the originals. */ memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); memcpy (new_program_h, old_program_h, old_file_h->e_phnum * old_file_h->e_phentsize); /* Modify the e_shstrndx if necessary. */ PATCH_INDEX (new_file_h->e_shstrndx); /* Fix up file header. We'll add one section. Section header is further away now. */ new_file_h->e_shoff += new_offsets_shift; new_file_h->e_shnum += 1; #ifdef DEBUG fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); #endif /* Fix up a new program header. Extend the writable data segment so that the bss area is covered too. Find that segment by looking for a segment that ends just before the .bss area. Make sure that no segments are above the new .data2. Put a loop at the end to adjust the offset and address of any segment that is above data2, just in case we decide to allow this later. */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { /* Compute maximum of all requirements for alignment of section. */ int alignment = (NEW_PROGRAM_H (n)).p_align; if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) alignment = OLD_SECTION_H (old_bss_index).sh_addralign; /* Supposedly this condition is okay for the SGI. */ #if 0 if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) fatal ("Program segment above .bss in %s\n", old_name, 0); #endif if (NEW_PROGRAM_H (n).p_type == PT_LOAD && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + (NEW_PROGRAM_H (n)).p_filesz, alignment) == round_up (old_bss_addr, alignment))) break; } if (n < 0) fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); NEW_PROGRAM_H (n).p_filesz += new_offsets_shift; NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; #if 1 /* Maybe allow section after data2 - does this ever happen? */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { if (NEW_PROGRAM_H (n).p_vaddr && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size; if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) NEW_PROGRAM_H (n).p_offset += new_offsets_shift; } #endif /* Fix up section headers based on new .data2 section. Any section whose offset or virtual address is after the new .data2 section gets its value adjusted. .bss size becomes zero and new address is set. data2 section header gets added by copying the existing .data header and modifying the offset, address and size. */ for (old_data_index = 1; old_data_index < old_file_h->e_shnum; old_data_index++) if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, ".data")) break; if (old_data_index == old_file_h->e_shnum) fatal ("Can't find .data in %s.\n", old_name, 0); /* Walk through all section headers, insert the new data2 section right before the new bss section. */ for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) { caddr_t src; /* If it is bss section, insert the new data2 section before it. */ if (n == old_bss_index) { /* Steal the data section header for this data2 section. */ memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), new_file_h->e_shentsize); NEW_SECTION_H (nn).sh_addr = new_data2_addr; NEW_SECTION_H (nn).sh_offset = new_data2_offset; NEW_SECTION_H (nn).sh_size = new_data2_size; /* Use the bss section's alignment. This will assure that the new data2 section always be placed in the same spot as the old bss section by any other application. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; /* Now copy over what we have in the memory now. */ memcpy (NEW_SECTION_H (nn).sh_offset + new_base, (caddr_t) OLD_SECTION_H (n).sh_addr, new_data2_size); nn++; memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), old_file_h->e_shentsize); /* The new bss section's size is zero, and its file offset and virtual address should be off by NEW_OFFSETS_SHIFT. */ NEW_SECTION_H (nn).sh_offset += new_offsets_shift; NEW_SECTION_H (nn).sh_addr = new_bss_addr; /* Let the new bss section address alignment be the same as the section address alignment followed the old bss section, so this section will be placed in exactly the same place. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; NEW_SECTION_H (nn).sh_size = 0; } else memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), old_file_h->e_shentsize); /* Any section that was original placed AFTER the bss section must now be adjusted by NEW_OFFSETS_SHIFT. */ if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) NEW_SECTION_H (nn).sh_offset += new_offsets_shift; /* If any section hdr refers to the section after the new .data section, make it refer to next one because we have inserted a new section in between. */ PATCH_INDEX (NEW_SECTION_H (nn).sh_link); /* For symbol tables, info is a symbol table index, so don't change it. */ if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) PATCH_INDEX (NEW_SECTION_H (nn).sh_info); /* Now, start to copy the content of sections. */ if (NEW_SECTION_H (nn).sh_type == SHT_NULL || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) continue; /* Write out the sections. .data and .data1 (and data2, called ".data" in the strings table) get copied from the current process instead of the old file. */ if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data1") || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".got")) src = (caddr_t) OLD_SECTION_H (n).sh_addr; else src = old_base + OLD_SECTION_H (n).sh_offset; memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, NEW_SECTION_H (nn).sh_size); /* Adjust the HDRR offsets in .mdebug and copy the line data if it's in its usual 'hole' in the object. Makes the new file debuggable with dbx. patches up two problems: the absolute file offsets in the HDRR record of .mdebug (see /usr/include/syms.h), and the ld bug that gets the line table in a hole in the elf file rather than in the .mdebug section proper. David Anderson. davea@sgi.com Jan 16,1994. */ if (n == old_mdebug_index) { #define MDEBUGADJUST(__ct,__fileaddr) \ if (n_phdrr->__ct > 0) \ { \ n_phdrr->__fileaddr += movement; \ } HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); unsigned movement = new_offsets_shift; MDEBUGADJUST (idnMax, cbDnOffset); MDEBUGADJUST (ipdMax, cbPdOffset); MDEBUGADJUST (isymMax, cbSymOffset); MDEBUGADJUST (ioptMax, cbOptOffset); MDEBUGADJUST (iauxMax, cbAuxOffset); MDEBUGADJUST (issMax, cbSsOffset); MDEBUGADJUST (issExtMax, cbSsExtOffset); MDEBUGADJUST (ifdMax, cbFdOffset); MDEBUGADJUST (crfd, cbRfdOffset); MDEBUGADJUST (iextMax, cbExtOffset); /* The Line Section, being possible off in a hole of the object, requires special handling. */ if (n_phdrr->cbLine > 0) { if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + OLD_SECTION_H (n).sh_size)) { /* line data is in a hole in elf. do special copy and adjust for this ld mistake. */ n_phdrr->cbLineOffset += movement; memcpy (n_phdrr->cbLineOffset + new_base, o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); } else { /* somehow line data is in .mdebug as it is supposed to be. */ MDEBUGADJUST (cbLine, cbLineOffset); } } } /* If it is the symbol table, its st_shndx field needs to be patched. */ if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) { Elf32_Shdr *spt = &NEW_SECTION_H (nn); unsigned int num = spt->sh_size / spt->sh_entsize; Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + new_base); for (; num--; sym++) { if (sym->st_shndx == SHN_UNDEF || sym->st_shndx == SHN_ABS || sym->st_shndx == SHN_COMMON) continue; PATCH_INDEX (sym->st_shndx); } } } /* Close the files and make the new file executable. */ if (close (old_file)) fatal ("Can't close (%s): errno %d\n", old_name, errno); if (close (new_file)) fatal ("Can't close (%s): errno %d\n", new_name, errno); if (stat (new_name, &stat_buf) == -1) fatal ("Can't stat (%s): errno %d\n", new_name, errno); n = umask (777); umask (n); stat_buf.st_mode |= 0111 & ~n; if (chmod (new_name, stat_buf.st_mode) == -1) fatal ("Can't chmod (%s): errno %d\n", new_name, errno); } #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/num_pred.c0000755000175000017500000001005214360276512013207 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Predicates on numbers */ #define NEED_MP_H #include "include.h" #include "num_include.h" int number_zerop(object x) { switch (type_of(x)) { case t_fixnum: if (fix(x) == 0) return(1); else return(0); case t_bignum: case t_ratio: return(0); case t_shortfloat: if (sf(x) == 0.0) return(1); else return(0); case t_longfloat: if (lf(x) == 0.0) return(1); else return(0); case t_complex: return(number_zerop(x->cmp.cmp_real) && number_zerop(x->cmp.cmp_imag)); default: FEwrong_type_argument(sLnumber, x); return(0); } } int number_plusp(object x) { switch (type_of(x)) { case t_fixnum: if (fix(x) > 0) return(1); else return(0); case t_bignum: if (big_sign(x) > 0) return(1); else return(0); case t_ratio: if (number_plusp(x->rat.rat_num)) return(1); else return(0); case t_shortfloat: if (sf(x) > 0.0) return(1); else return(0); case t_longfloat: if (lf(x) > 0.0) return(1); else return(0); default: FEwrong_type_argument(TSor_rational_float,x); return(0); } } int number_minusp(object x) { switch (type_of(x)) { case t_fixnum: if (fix(x) < 0) return(1); else return(0); case t_bignum: if (big_sign(x) < 0) return(1); else return(0); case t_ratio: if (number_minusp(x->rat.rat_num)) return(1); else return(0); case t_shortfloat: if (sf(x) < 0.0) return(1); else return(0); case t_longfloat: if (lf(x) < 0.0) return(1); else return(0); default: FEwrong_type_argument(TSor_rational_float,x); return(0); } } int number_oddp(object x) { int i=0; if (type_of(x) == t_fixnum) i = fix(x); else if (type_of(x) == t_bignum) i = MP_LOW(MP(x),lgef(MP(x))); else FEwrong_type_argument(sLinteger, x); return(i & 1); } int number_evenp(object x) { int i=0; if (type_of(x) == t_fixnum) i = fix(x); else if (type_of(x) == t_bignum) i = MP_LOW(MP(x),lgef(MP(x))); else FEwrong_type_argument(sLinteger, x); return(~i & 1); } LFD(Lzerop)(void) { check_arg(1); check_type_number(&vs_base[0]); if (number_zerop(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Lplusp)(void) { check_arg(1); check_type_or_rational_float(&vs_base[0]); if (number_plusp(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Lminusp)(void) { check_arg(1); check_type_or_rational_float(&vs_base[0]); if (number_minusp(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Loddp)(void) { check_arg(1); check_type_integer(&vs_base[0]); if (number_oddp(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Levenp)(void) { check_arg(1); check_type_integer(&vs_base[0]); if (number_evenp(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } /* this is just to force things into memory in num_co.c */ /* static void _assure_in_memory (void *p) */ /* { */ /* ; */ /* } */ /* static int */ /* lf_eqlp(double *p, double *q) */ /* { */ /* return *p == *q; */ /* } */ void gcl_init_num_pred(void) { #ifndef GMP big_register_1 = new_bignum(); ZERO_BIG(big_register_1); enter_mark_origin(&big_register_1); #endif make_function("ZEROP", Lzerop); make_function("PLUSP", Lplusp); make_function("MINUSP", Lminusp); make_function("ODDP", Loddp); make_function("EVENP", Levenp); } gcl-2.6.14/o/fasdump.c0000755000175000017500000010420314360276512013037 0ustar cammcamm /* Copyright William F. Schelter All Rights Reserved. Utility for writing out lisp objects and reading them in: Basically it attempts to write out only those things which could be written out using princ and reread. It just uses less space and is faster. Primitives for dealing with a `fasd stream'. Such a stream is really an array containing some state and a lisp file stream. Note that having *print-circle* == nil wil make this faster. gensyms will still be dumped correctly in that case. open_fasd write_fasd_top read_fasd_top close_fasd */ #ifndef FAT_STRING #include "include.h" #endif static void clrhash(object); object coerce_stream(); static object fasd_patch_sharp(object x, int depth); object make_pathname (); static int needs_patching; struct fasd current_fasd; enum circ_ind { LATER_INDEX, NOT_INDEXED, FIRST_INDEX, }; enum dump_type { d_nil, /* dnil: nil */ d_eval_skip, /* deval o1: evaluate o1 after reading it */ d_delimiter, /* occurs after d_list,d_general and d_new_indexed_items */ d_enter_vector, /* d_enter_vector o1 o2 .. on d_delimiter , make a cf_data with this length. Used internally by akcl. Just make an array in other lisps */ d_cons, /* d_cons o1 o2: (o1 . o2) */ d_dot, d_list, /* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on for (o1 o2 . on) or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) */ d_list1, /* nil terminated length 1 d_list1,o1 */ d_list2, /* nil terminated length 2 */ d_list3, d_list4, d_eval, d_short_symbol, d_short_string, d_short_fixnum, d_short_symbol_and_package, d_bignum, d_fixnum, d_string, d_objnull, d_structure, d_package, d_symbol, d_symbol_and_package, d_end_of_file, d_standard_character, d_vector, d_array, d_begin_dump, d_general_type, d_sharp_equals, /* define a sharp */ d_sharp_value, d_sharp_value2, d_new_indexed_item, d_new_indexed_items, d_reset_index, d_macro, d_reserve1, d_reserve2, d_reserve3, d_reserve4, d_indexed_item3, /* d_indexed_item3 followed by 3bytes to give index */ d_indexed_item2, /* d_indexed_item2 followed by 2bytes to give index */ d_indexed_item1, d_indexed_item0 /* This must occur last ! */ }; /* set whole structures! */ #define SETUP_FASD_IN(fd) do{ \ fas_stream= (fd)->stream->sm.sm_fp; \ dump_index = fix((fd)->index) ; \ current_fasd= * (fd);}while(0) #define SAVE_CURRENT_FASD \ struct fasd old_fd; \ int old_dump_index = dump_index; \ FILE *old_fas_stream = fas_stream; \ int old_needs_patching = needs_patching; \ old_fd = current_fasd; #define RESTORE_FASD \ current_fasd =old_fd ; \ dump_index= old_dump_index ; \ needs_patching = old_needs_patching ; \ fas_stream = old_fas_stream #define FASD_SHARP_LIMIT 250 /* less than short_max */ #define SETUP_FASD_OUT(fasd) SETUP_FASD_IN(fasd) #define dump_hash_table (current_fasd.table) #define SIZE_D_CODE 8 #define SIZE_BYTE 8 #define SIZE_SHORT ((2*SIZE_BYTE) - SIZE_D_CODE) /* this is not! the maximum short !! It is shorter */ #define SHORT_MAX ((1<< SIZE_SHORT) -1) /* given SHORT extract top code (say 4 bits) and bottom byte */ #define TOP(i) (i >> SIZE_BYTE) #define BOTTOM(i) (i & ~(~0UL << SIZE_BYTE)) #define FASD_VERSION 2 FILE *fas_stream; int dump_index; struct htent *gethash(); static void read_fasd1(int i, object *loc); object extended_read(); /* to enable debugging define the following, and set debug=1 or debug=2 */ /* #define DEBUG */ #ifdef DEBUG #define PUT(x) putc1((char)x,fas_stream) #define GET() getc1() #define D_FWRITE fwrite1 #define D_FREAD fread1 char *dump_type_names[]={ "d_nil", "d_eval_skip", "d_delimiter", "d_enter_vector", "d_cons", "d_dot", "d_list", "d_list1", "d_list2", "d_list3", "d_list4", "d_eval", "d_short_symbol", "d_short_string", "d_short_fixnum", "d_short_symbol_and_package", "d_bignum", "d_fixnum", "d_string", "d_objnull", "d_structure", "d_package", "d_symbol", "d_symbol_and_package", "d_end_of_file", "d_standard_character", "d_vector", "d_array", "d_begin_dump", "d_general_type", "d_sharp_equals", "d_sharp_value", "d_sharp_value2", "d_new_indexed_item", "d_new_indexed_items", "d_reset_index", "d_macro", "d_reserve1", "d_reserve2", "d_reserve3", "d_reserve4", "d_indexed_item3", "d_indexed_item2", "d_indexed_item1", "d_indexed_item0"}; int debug; int print_op(i) {if (debug) {if (i < d_indexed_item0 & i >= 0) {printf("\n<%s>",dump_type_names[i]);} else {printf("\n",i -d_indexed_item0);}} return i; } #define PUTD(str,i) putd(str,i) void putd(str,i) char *str; int i; {if (debug) {printf("{"); printf(str,i); printf("}");} putc(i,fas_stream);} void putc1(x) int x; { if (debug) printf("(%x,%d,%c)",x,x,x); putc(x,fas_stream); fflush(stdout); } int getc1() { int x; x= getc(fas_stream); if (debug) printf("(%x,%d,%c)",x,x,x); fflush(stdout); return x; } int fread1(p,n1,n2,st) FILE* st; char *p; int n1; int n2; {int i,j; j=SAFE_FREAD(p,n1,n2,st); if(debug) {printf("["); n1=n1*n2; for(i=0;i> (SIZE_D_CODE)) /* takes two bytes and reconstructs the SIZE_SHORT int from them after dropping the code */ /* takes two bytes i and j and returns the SHORT associated */ #define LENGTH(i,j) MAKE_SHORT(E_TYPE_OF(i),(j)) #define MAKE_SHORT(top,bot) (((top)<< SIZE_BYTE) + (bot)) #define READ_BYTE1() getc(fas_stream) #define GET8(varx ) \ do{unsigned long long var=READ_BYTE1(); \ var |= ((unsigned long long)READ_BYTE1() << SIZE_BYTE); \ var |= ((unsigned long long)READ_BYTE1() << (2*SIZE_BYTE)); \ var |= ((unsigned long long)READ_BYTE1() << (3*SIZE_BYTE)); \ var |= ((unsigned long long)READ_BYTE1() << (4*SIZE_BYTE)); \ var |= ((unsigned long long)READ_BYTE1() << (5*SIZE_BYTE)); \ var |= ((unsigned long long)READ_BYTE1() << (6*SIZE_BYTE)); \ var |= ((unsigned long long)READ_BYTE1() << (7*SIZE_BYTE)); \ DPRINTF("{8byte:varx= %ld}", var); \ varx=var;} while (0) #define GET4(varx ) \ do{int var=READ_BYTE1(); \ var |= (READ_BYTE1() << SIZE_BYTE); \ var |= (READ_BYTE1() << (2*SIZE_BYTE)); \ var |= (READ_BYTE1() << (3*SIZE_BYTE)); \ DPRINTF("{4byte:varx= %d}", var); \ varx=var;} while (0) #define GET2(varx ) \ do{int var=READ_BYTE1(); \ var |= (READ_BYTE1() << SIZE_BYTE); \ DPRINTF("{2byte:varx= %d}", var); \ varx=var;} while (0) #define GET3(varx ) \ do{int var=READ_BYTE1(); \ var |= (READ_BYTE1() << SIZE_BYTE); \ var |= (READ_BYTE1() << (2*SIZE_BYTE)); \ DPRINTF("{3byte:varx= %d}", var); \ varx=var;} while (0) #define MASK ~(~0UL << 8) #define WRITE_BYTEI(x,i) putc((((x) >> (i*SIZE_BYTE)) & MASK),fas_stream) #define PUTFIX(v_) Join(PUT,SIZEOF_LONG)(v_) #define GETFIX(v_) Join(GET,SIZEOF_LONG)(v_) #define PUT8(varx ) \ do{unsigned long long var= varx ; \ DPRINTF("{8byte:varx= %ld}", var); \ WRITE_BYTEI(var,0); \ WRITE_BYTEI(var,1); \ WRITE_BYTEI(var,2); \ WRITE_BYTEI(var,3); \ WRITE_BYTEI(var,4); \ WRITE_BYTEI(var,5); \ WRITE_BYTEI(var,6); \ WRITE_BYTEI(var,7);} while(0) #define PUT4(varx ) \ do{unsigned long var= varx ; \ DPRINTF("{4byte:varx= %d}", var); \ WRITE_BYTEI(var,0); \ WRITE_BYTEI(var,1); \ WRITE_BYTEI(var,2); \ WRITE_BYTEI(var,3);} while(0) #define PUT2(var ) \ do{unsigned long v=var; \ DPRINTF("{2byte:var= %d}", v); \ WRITE_BYTEI(v,0); \ WRITE_BYTEI(v,1); \ } while(0) #define PUT3(var ) \ do{unsigned long v=var; \ DPRINTF("{3byte:var= %d}", v); \ WRITE_BYTEI(v,0); \ WRITE_BYTEI(v,1); \ WRITE_BYTEI(v,2); \ } while(0) /* constructs the first byte containing ecode and top top either stands for something in extended codes, or for something the top part of a SIZE_SHORT int */ #define MAKE_CODE(CODE,Top) \ ((unsigned int)(CODE) | ((unsigned int)(Top) << SIZE_D_CODE)) /* write out two bytes encoding the enum d_code CODE and SHORT SH. */ #define PUT_CODE_AND_SHORT(CODE,SH) \ PUT(MAKE_CODE(CODE,TOP(SH))); \ PUT(BOTTOM(SH)); #define READ_SYMBOL(leng,pack,to) \ do { BEGIN_NO_INTERRUPT;{char *p=alloc_relblock(leng);\ D_FREAD(p,1,leng,fas_stream); \ string_register->st.st_fillp = \ string_register->st.st_dim = leng; \ string_register->st.st_self = p; \ to=(pack==Cnil ? make_symbol(string_register) : intern(string_register,pack)); \ END_NO_INTERRUPT;} \ }while(0) #define READ_STRING(leng,loc) do {BEGIN_NO_INTERRUPT; \ *loc = alloc_simple_string(leng); \ (*loc)->st.st_self=alloc_relblock(leng); END_NO_INTERRUPT; \ /* Now handled in SAFE_FREAD -- CM 20040210 */ \ /* memset((*loc)->st.st_self,0,leng); */ /* fread won't restart if it triggers an SGC segfault -- CM */ \ D_FREAD((*loc)->st.st_self,1,leng,fas_stream);} while(0) /* if try_hash finds it we don't need to write the object Otherwise we write the index type and the object */ #define NUMBER_ZERO_ITEMS (SHORT_MAX - (int) d_indexed_item0) static enum circ_ind do_hash(object obj, int dot) { struct htent *e; int i; e=gethash(obj,dump_hash_table); if (e->hte_key==OBJNULL) /* We won't index things unless they have < -2 in the hash table */ { if(type_of(obj)!=t_package) return NOT_INDEXED; sethash(obj,dump_hash_table,make_fixnum(dump_index)); e=gethash(obj,dump_hash_table); PUT_OP(d_new_indexed_item); DPRINTF("{dump_index=%d}",dump_index); dump_index++; return FIRST_INDEX;} i = fix(e->hte_value); if (i == -1) return NOT_INDEXED; /* don't want to index this baby */ if (dot) PUT_OP(dot); if ( i < -1) { e->hte_value = make_fixnum(dump_index); PUT_OP(d_new_indexed_item); DPRINTF("{dump_index=%d}",dump_index); dump_index++; return FIRST_INDEX; } if (i < (NUMBER_ZERO_ITEMS)) {PUT_OP(i+(int)d_indexed_item0); return LATER_INDEX;} if (i < (2*SHORT_MAX - (int)d_indexed_item0)) {PUT_OP((int)d_indexed_item1); PUTD("n=%d",i- NUMBER_ZERO_ITEMS); return LATER_INDEX; } if (i < SHORT_MAX*SHORT_MAX) {PUT_OP((int)d_indexed_item2); PUT2(i); return LATER_INDEX; } if (i < SHORT_MAX*SHORT_MAX*SHORT_MAX) {PUT_OP((int)d_indexed_item3); PUT3(i); return LATER_INDEX; } else FEerror("too large an index",0); return LATER_INDEX; } static void write_fasd(object obj); DEFUN_NEW("WRITE-FASD-TOP",object,fSwrite_fasd_top,SI,2,2,NONE,OO,OO,OO,OO,(object obj, object x),"") /* static object */ /* FFN(write_fasd_top)(object obj, object x) */ {struct fasd *fd = (struct fasd *) x->v.v_self; if (fd->direction == sKoutput) SETUP_FASD_IN(fd); else FEerror("bad value for open slot of fasd",0); write_fasd(obj); /* we could really allocate a fixnum and then smash its field if this is to costly */ (fd)->index = make_fixnum(dump_index); return obj; } /* It is assumed that anything passed to eval should be first sharp patched, and that there will be no more patching afterwards. The object returned might have arbitrary complexity. */ #define MAYBE_PATCH(result) \ if (needs_patching) result =fasd_patch_sharp(result,0) DEFUN_NEW("READ-FASD-TOP",object,fSread_fasd_top,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") /* static object */ /* FFN(read_fasd_top)(object x) */ { struct fasd *fd = (struct fasd *) x->v.v_self; VOL int e=0; object result; SAVE_CURRENT_FASD; SETUP_FASD_IN(fd); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } needs_patching=0; if (current_fasd.direction == sKinput) {read_fasd1(GET_OP(),&result); MAYBE_PATCH(result); (fd)->index = make_fixnum(dump_index); fd->direction=current_fasd.direction; } else if(current_fasd.direction== Cnil) result= current_fasd.eof; else FEerror("Stream not open for input",0); L: frs_pop(); if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); fd->direction=Cnil; RESTORE_FASD; return Cnil; } else { RESTORE_FASD; return result;} } #ifdef STATIC_FUNCTION_POINTERS object fSread_fasd_top(object x) { return FFN(fSread_fasd_top)(x); } #endif object sLeq; object sSPinit; void Lmake_hash_table(); DEFUN_NEW("OPEN-FASD",object,fSopen_fasd,SI,4,4,NONE,OO,OO,OO,OO,(object stream, object direction, object eof, object tabl),"") /* static object */ /* FFN(open_fasd)(object stream, object direction, object eof, object tabl) */ { object str=Cnil; object result; if(direction==sKinput) {str=coerce_stream(stream,0); if (tabl==Cnil) tabl=alloc_simple_vector(0,aet_object); else check_type(tabl,t_vector);} if(direction==sKoutput) {str=coerce_stream(stream,1); if(tabl==Cnil) tabl=gcl_make_hash_table(sLeq); else check_type(tabl,t_hashtable);} massert(str==stream); result=alloc_simple_vector(sizeof(struct fasd)/sizeof(object),aet_object); array_allocself(result,1,Cnil); {struct fasd *fd= (struct fasd *)result->v.v_self; fd->table=tabl; fd->stream=stream; fd->direction=direction; fd->eof=eof; fd->index=small_fixnum(0); fd->package=symbol_value(sLApackageA); fd->filepos = make_fixnum(ftell(stream->sm.sm_fp)); SETUP_FASD_IN(fd); if (direction==sKoutput){ PUT_OP((int)d_begin_dump); PUTD("version=%d",FASD_VERSION); PUT4(0); /* reserve space for the size of index array needed */ /* equivalent to: write_fasd(current_fasd.package); except we don't want to index this, so that we can open with an empty array. */ PUT_OP(d_package); write_fasd(current_fasd.package->p.p_name); } else /* input */ { object tem; read_fasd1(GET_OP(),&tem); if(tem!=current_fasd.table) FEerror("not positioned at beginning of a dump",0); } fd->index=make_fixnum(dump_index); fd->filepos=current_fasd.filepos; fd->package=current_fasd.package; fd->table_length=current_fasd.table_length; return result; }} #ifdef STATIC_FUNCTION_POINTERS object fSopen_fasd(object stream, object direction, object eof, object tabl) { return FFN(fSopen_fasd)(stream,direction,eof,tabl); } #endif DEFUN_NEW("CLOSE-FASD",object,fSclose_fasd,SI,1,1,NONE,OO,OO,OO,OO,(object ar),"") /* static object */ /* FFN(close_fasd)(object ar) */ { struct fasd *fd= (struct fasd *)(ar->v.v_self); check_type(ar,t_vector); if (type_of(fd->table)==t_vector) /* input uses a vector */ {if (fd->table->v.v_self) gset(fd->table->v.v_self,0,fix(fd->index),aet_object); } else if(fd->direction==sKoutput) {clrhash(fd->table); SETUP_FASD_IN(fd); PUT_OP(d_end_of_file); {int i = ftell(fd->stream->sm.sm_fp); if(type_of(fd->filepos) == t_fixnum) { fseek(fd->stream->sm.sm_fp,fix(fd->filepos)+2,SEEK_SET); /* record the length of array needed to read the indices */ PUT4(fix(fd->index)); /* move back to where we were */ fseek(fd->stream->sm.sm_fp,i,SEEK_SET); }} } /* else FEerror("bad fasd stream",0); */ fd->direction=Cnil; return ar; } #ifdef STATIC_FUNCTION_POINTERS object fSclose_fasd(object ar) { return FFN(fSclose_fasd)(ar); } #endif #define HASHP(x) 1 #define TRY_HASH \ if(do_hash(obj,0)==LATER_INDEX) return; static void write_fasd(object obj) { fixnum j,leng; /* hook for writing other data in fasd file */ /* check if we have already output the object in a hash table. If so just record the index */ { /* if dump_index is too large or the object has not been written before we output it now */ switch(type_of(obj)){ case DP(t_cons:) TRY_HASH; /* decide how long we think this list is */ {object x=obj->c.c_cdr; int l=0; if (obj->c.c_car == siSsharp_comma) { PUT_OP(d_eval); write_fasd(x); break;} while(1) { if(x==Cnil) {PUT_OP(d_list1+l); break;} if(type_of(x)==t_cons) {if ((int) d_list1 + ++l > (int) d_list4) {PUT_OP(d_list); break;} else {x=x->c.c_cdr; continue;}} /* 1 to 4 done */ if(l==0) {PUT_OP(d_cons); write_fasd(obj->c.c_car); write_fasd(obj->c.c_cdr); return;} else {PUT_OP(d_list); break; }}} /* WRITE_LIST: */ write_fasd(obj->c.c_car); obj=obj->c.c_cdr; {int l=0; while(1) {if (type_of(obj)==t_cons) { enum circ_ind is_indexed=LATER_INDEX; if(HASHP(t_cons)){ is_indexed=do_hash(obj,d_dot); if (is_indexed == LATER_INDEX) return; if (is_indexed==FIRST_INDEX) { PUT_OP(d_cons); write_fasd(obj->c.c_car); write_fasd(obj->c.c_cdr); return;}} write_fasd(obj->c.c_car); l++; obj=obj->c.c_cdr;} else if(obj==Cnil) {if (l> ((int) d_list4- (int) d_list1)) {PUT_OP(d_delimiter);} return;} else {PUT_OP(d_dot); write_fasd(obj); return;}}} case DP(t_symbol:) if (obj==Cnil) {PUT_OP(d_nil); return;} TRY_HASH; leng=obj->s.s_fillp; if (current_fasd.package!=obj->s.s_hpack) {{ if (leng< SHORT_MAX) {PUT_OP(d_short_symbol_and_package); PUTD("leng=%d",leng);} else { j=leng; PUT_OP(d_symbol_and_package); PUT4(j);}} write_fasd(obj->s.s_hpack);} else { if (leng< SHORT_MAX) { PUT_OP(d_short_symbol); PUTD("leng=%d",leng);} else { j=leng; PUT_OP(d_symbol); PUT4(j);} } D_FWRITE(obj->s.s_self,1,leng,fas_stream); break; case DP(t_fixnum:) leng=fix(obj); if ((leng< (SHORT_MAX/2)) && (leng > -(SHORT_MAX/2))) {PUT_OP(d_short_fixnum); PUTD("leng=%d",leng);} else {PUT_OP(d_fixnum); j=leng; PUTFIX(j);} break; case DP(t_character:) PUT_OP(d_standard_character); PUTD("char=%c",char_code(obj)); break; case DP(t_string:) leng=(obj)->st.st_fillp; if (leng< SHORT_MAX) {PUT_OP(d_short_string); PUTD("leng=%d",leng);} else {j=leng; PUT_OP(d_string); PUT4(j);} D_FWRITE(obj->st.st_self,1,leng,fas_stream); break; case DP(t_bignum:) PUT_OP(d_bignum); #ifdef GMP {int l = MP(obj)->_mp_size; int m = (l >= 0 ? l : -l); mp_limb_t *u = MP(obj)->_mp_d; /* fix this */ /* if (sizeof(mp_limb_t) != 4) { FEerror("fix for gmp",0);} */ PUT4(l); while (-- m >=0) { #if MP_LIMB_BYTES == 8 PUT8(*u); #elif MP_LIMB_BYTES == 4 PUT4(*u); #else #error Bad MP_LIMB_BYTES #endif u++; } break;} #else {int l = obj->big.big_length; plong *u = obj->big.big_self; PUT4(l); while (-- l >=0) {PUT4(*u) ; u++;} break;} #endif case DP(t_package:) TRY_HASH; PUT_OP(d_package); write_fasd(obj->p.p_name); break; case DP(t_structure:) TRY_HASH; {int narg=S_DATA(obj->str.str_def)->length; int i; object name= S_DATA(obj->str.str_def)->name; if(narg >= SHORT_MAX) FEerror("Only dump structures whose length < ~a",1,make_fixnum(SHORT_MAX)); PUT_OP(d_structure); PUTD("narg=%d",narg); write_fasd(name); for (i = 0; i < narg; i++) write_fasd(structure_ref(obj,name,i));} break; case DP(t_array:) TRY_HASH; PUT_OP(d_array); { int leng=obj->a.a_dim; int i; PUT4(leng); PUTD("elttype=%d",obj->a.a_elttype); PUTD("rank=%d",obj->a.a_rank); {int i; if (obj->a.a_rank > 1) { for (i=0; ia.a_rank ; i++) PUT4(obj->a.a_dims[i]);}} for(i=0; i< leng ; i++) write_fasd(aref(obj,i));} break; case DP(t_vector:) TRY_HASH; PUT_OP(d_vector); { int leng=obj->v.v_fillp; PUT4 (leng); PUTD("eltype=%d",obj->v.v_elttype); {int i; for(i=0; i< leng ; i++) {write_fasd(aref(obj,i));}}} break; default: PUT_OP(d_general_type); prin1(obj,current_fasd.stream); PUTD("close general:%c",')'); }} } static void fasd_patch_sharp_cons(object x, int depth) { for (;;) { x->c.c_car = fasd_patch_sharp(x->c.c_car,depth+1); if (type_of(x->c.c_cdr) == t_cons) x = x->c.c_cdr; else { x->c.c_cdr = SAFE_CDR(fasd_patch_sharp(x->c.c_cdr,depth+1)); break; } } } static object fasd_patch_sharp(object x, int depth) { cs_check(x); if (++depth > 1000) { object *p = current_fasd.table->v.v_self; while(*p) { if (x== *p++ && type_of(x)!=t_spice) return x;}} /* eval'd forms are already patched, and they might contain circular structure */ { object p = current_fasd.evald_items; while (p != Cnil) { if (p->c.c_car == x) return x; p = p->c.c_cdr;}} switch (type_of(x)) { case DP(t_spice:) { if (x->spc.spc_dummy >= current_fasd.table->v.v_dim) FEerror("bad spice ref",0); return current_fasd.table->v.v_self[x->spc.spc_dummy ]; } case DP(t_cons:) /* x->c.c_car = fasd_patch_sharp(x->c.c_car,depth); x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr,depth); */ fasd_patch_sharp_cons(x,depth); break; case DP(t_vector:) { int i; if ((enum aelttype)x->v.v_elttype != aet_object) break; for (i = 0; i < x->v.v_fillp; i++) x->v.v_self[i] = fasd_patch_sharp(x->v.v_self[i],depth); break; } case DP(t_array:) { int i, j; if ((enum aelttype)x->a.a_elttype != aet_object) break; for (i = 0, j = 1; i < x->a.a_rank; i++) j *= x->a.a_dims[i]; for (i = 0; i < j; i++) x->a.a_self[i] = fasd_patch_sharp(x->a.a_self[i],depth); break; } case DP(t_structure:) {object def = x->str.str_def; int i; i=S_DATA(def)->length; while (i--> 0) structure_set(x,def,i,fasd_patch_sharp(structure_ref(x,def,i),depth)); break; } default: /* dont have to walk other objs */ break; } return(x); } object sharing_table; DEFUN_NEW("FIND-SHARING-TOP",object,fSfind_sharing_top,SI,2,2,NONE,OO,OO,OO,OO,(object x, object table),"") { sharing_table=table; travel_find_sharing(x,table); return Ct; } /* static object */ /* read_fasd(int i) */ /* {object tem; */ /* read_fasd1(i,&tem); */ /* return tem;} */ /* I am not sure if saving vs_top,vs_base is necessary */ static object lisp_eval(object x) { object *b,*t; SAVE_CURRENT_FASD; b=vs_base; t=vs_top; vs_base=vs_top; vs_push(x); Leval(); x=vs_base[0]; vs_base=b; vs_top=t; RESTORE_FASD; return x; } #define CHECK_CH(i) do{if ((i)==EOF && feof(fas_stream)) bad_eof();}while (0) /* grow vector AR of general type */ static void grow_vector(object ar) { int len=ar->v.v_dim; int nl=(int) (1.5*len); {BEGIN_NO_INTERRUPT; {char *p= (char *)AR_ALLOC(alloc_contblock,nl,object); bcopy(ar->v.v_self,p,sizeof(object)* len); ar->v.v_self= (object *)p; ar->v.v_dim= ar->v.v_fillp=nl; while(--nl >=len) ar->v.v_self[nl]=Cnil; END_NO_INTERRUPT;}} } static void bad_eof(void) { FEerror("Unexpected end of file",0);} /* read one starting with byte i into location loc */ static void read_fasd1(int i, object *loc) { object tem; int leng; BEGIN: CHECK_CH(i); switch(D_TYPE_OF(i)) {case DP(d_nil:) *loc=Cnil;return; case DP(d_cons:) read_fasd1(GET_OP(),&tem); collect(loc,make_cons(tem,Cnil)); i=GET_OP(); goto BEGIN; case DP(d_list1:) i=1;goto READ_LIST; case DP(d_list2:) i=2;goto READ_LIST; case DP(d_list3:) i=3;goto READ_LIST; case DP(d_list4:) i=4;goto READ_LIST; case DP(d_list:) i=(1<<30) ; goto READ_LIST; READ_LIST: while(1) {int j; if (--i < 0) {*loc=Cnil; return;} j=GET_OP(); CHECK_CH(j); if (j==d_delimiter) {*loc=Cnil; DPRINTF("{Read end of list(%d)}",i); return;} else if(j==d_dot) { DPRINTF("{Read end of dotted list(%d)}",i); read_fasd1(GET_OP(),loc); return;} else {object tem; DPRINTF("{Read next item in list(%d)}",i); read_fasd1(j,&tem); DPRINTF("{Item=",(debug >= 2 ? pp(tem) : 0)); DPRINTF("}",0); collect(loc,make_cons(tem,Cnil));}} case DP(d_delimiter:) case DP(d_dot:) FEerror("Illegal op at top level",0); break; case DP(d_eval_skip:) read_fasd1(GET_OP(),loc); MAYBE_PATCH(*loc); lisp_eval(*loc); read_fasd1(GET_OP(),loc); break; case d_reserve1: case d_reserve2: case d_reserve3: case d_reserve4: FEerror("Op reserved for future use",0); break; case DP(d_reset_index:) dump_index=0; break; case DP(d_short_symbol:) leng=GETD("leng=%d"); leng = LENGTH(i,leng); READ_SYMBOL(leng,current_fasd.package,tem); *loc=tem; return ; case DP(d_short_symbol_and_package:) {object pack; leng=GETD("leng=%d"); leng = LENGTH(i,leng); read_fasd1(GET_OP(),&pack); READ_SYMBOL(leng,pack,tem); *loc=tem; return;} case DP(d_short_string:) leng=GETD("leng=%d"); leng = LENGTH(i,leng); READ_STRING(leng,loc); return; case DP(d_string:) {int j; GET4(j); READ_STRING(j,loc); return;} case DP(d_indexed_item3:) GET3(i);goto INDEXED; case DP(d_indexed_item2:) GET2(i);goto INDEXED; case DP(d_indexed_item1:) i=GET()+ NUMBER_ZERO_ITEMS ; goto INDEXED; default: case DP(d_indexed_item0:) i = i - (int) d_indexed_item0; goto INDEXED; INDEXED: *loc= current_fasd.table->v.v_self[i]; /* if object not yet built make pointer to it */ if(*loc==0) {*loc=current_fasd.table->v.v_self[i]= alloc_object(t_spice); (*loc)->spc.spc_dummy= i; needs_patching=1;} return; /* the item`s' case does not return a value but is simply a facility to allow convenient dumping of a list of registers at the beginning, follwed by a delimiter. read continues on. */ case DP(d_new_indexed_items:) case DP(d_new_indexed_item:) { int cindex,k; k=GET_OP(); MORE: cindex =dump_index; DPRINTF("{dump_index=%d}",dump_index); if (dump_index >= current_fasd.table->v.v_dim) grow_vector(current_fasd.table); /* grow the array */ current_fasd.table->v.v_self[dump_index++] = 0; read_fasd1(k,loc); current_fasd.table->v.v_self[cindex] = *loc; if (i==d_new_indexed_items) {int k=GET_OP(); if (k==d_delimiter) { DPRINTF("{Reading last of new indexed items}",0); read_fasd1(GET_OP(),loc); return;} else { goto MORE; }} return; } case DP(d_short_fixnum:) {int leng=GETD("n=%d"); if (leng & (1 << (SIZE_SHORT -1))) leng= leng - (1 << (SIZE_SHORT)); *loc=SAFE_CDR(make_fixnum(leng)); return;} case DP(d_fixnum:) {fixnum j; GETFIX(j); *loc=SAFE_CDR(make_fixnum(j)); return;} case DP( d_bignum:) {int j,m; object tem; mp_limb_t *u; GET4(j); #ifdef GMP tem = new_bignum(); m = (j >= 0 ? j : -j); _mpz_realloc(MP(tem),m); MP(tem)->_mp_size = j; j = m; u = MP(tem)->_mp_d; #else { BEGIN_NO_INTERRUPT; tem = alloc_object(t_bignum); tem->big.big_length = j; tem-> big.big_self = 0; u = tem-> big.big_self = (plong *) alloc_relblock(j*sizeof(plong)); END_NO_INTERRUPT; } #endif while ( --j >=0) { #if MP_LIMB_BYTES == 8 GET8(*u); #elif MP_LIMB_BYTES == 4 GET4(*u); #else #error Bad MP_LIMB_BYTES #endif u++; } *loc=tem; return;} case DP(d_objnull:) *loc=0; return; case DP(d_structure:) { int narg,i; object name; narg=GETD("narg=%d"); read_fasd1(GET_OP(),& name); { object *base=vs_top; object *p = base; vs_base=base; vs_top = base + 1 + narg; *p++ = name; for (i=0; i < narg ; i++) read_fasd1(GET_OP(),p++); vs_base=base; vs_top = p; siLmake_structure(); *loc = vs_base[0]; vs_top=vs_base=base; return; }} case DP(d_symbol:) {int i; object tem; GET4(i); READ_SYMBOL(i,current_fasd.package,tem); *loc=tem; return ;} case DP(d_symbol_and_package:) {int i; object pack; GET4(i); read_fasd1(GET_OP(),&pack); READ_SYMBOL(i,pack,*loc); return;} case DP(d_package:) {object pack,tem; read_fasd1(GET_OP(),&tem); pack=find_package(tem); if (pack==Cnil) FEerror("The package named ~a, does not exist",1,tem); *loc=pack; return ;} case DP(d_standard_character:) *loc=(code_char(GETD("char=%c"))); return; case DP(d_vector:) {int leng,j; object y; object x=alloc_object(t_vector); GET4(leng); x->v.v_elttype = GETD("v_elttype=%d"); x->v.v_dim=x->v.v_fillp=leng; x->v.v_self=0; x->v.v_displaced=Cnil; x->v.v_hasfillp=x->v.v_adjustable=0; array_allocself(x,0,Cnil); for (j=0; j< leng ; j++) { DPRINTF("{vector_elt=%d}",j); read_fasd1(GET_OP(),&y); aset(x,j,y);} *loc=x; DPRINTF("{End of length %d vector}",leng); return;} case DP(d_array:) {BEGIN_NO_INTERRUPT; {int leng,i; object y; object x=alloc_object(t_array); GET4(leng); x->a.a_elttype = GETD("a_elttype=%d"); x->a.a_dim=leng; x->a.a_rank= GETD("a_rank=%d"); x->a.a_self=0; x->a.a_displaced=Cnil; x->a.a_adjustable=0; if (x->a.a_rank > 0) { x->a.a_dims = (int *)alloc_relblock(sizeof(int)*(x->a.a_rank)); } for (i=0; i< x->a.a_rank ; i++) GET4(x->a.a_dims[i]); array_allocself(x,0,Cnil); END_NO_INTERRUPT; for (i=0; i< leng ; i++) { read_fasd1(GET_OP(),&y); aset(x,i,y);} *loc=x; return;}} case DP(d_end_of_file:) current_fasd.direction =Cnil; *loc=current_fasd.eof; return; case DP(d_begin_dump:) {int vers=GETD("version=%d"); if(vers!=FASD_VERSION) { object x,x1; x=make_fixnum(vers); x1=make_fixnum(FASD_VERSION); FEerror("This file was dumped with FASD version ~a not ~a.", 2,x,x1);}} {int leng; GET4(leng); current_fasd.table_length=make_fixnum(leng);} read_fasd1(GET_OP(),&tem); if (type_of(tem)==t_package || tem==Cnil) {current_fasd.package = tem; *loc=current_fasd.table;} else FEerror("expected package",0); return; case DP(d_general_type:) *loc=read_object_non_recursive(current_fasd.stream); if(GETD("close general:%c")!=')') FEerror("general type not followed by ')'",0); return; /* Special type, the forms have been sharp patched separately It is also arranged that it does not */ case DP(d_enter_vector:) { extern object sSPmemory; int print_only=0; int n = 0; object vv = sSPmemory->s.s_dbind,tem; if (vv == Cnil) print_only = 1; else if (type_of(vv)!=t_cfdata) FEerror("bad VectorToEnter",0); while ((i=GET_OP()) !=d_delimiter) {int eval=(i==d_eval_skip); if (print_only) { if (eval) princ_str("#!",Ct); else if (i== d_eval) princ_str("#.",Ct);} if(eval) i=GET_OP(); read_fasd1(i, &tem); MAYBE_PATCH(tem); /* the eval entries don't enter it */ if (print_only) {princ(tem,Ct); princ_str(";",Ct); princ(make_fixnum(n),Ct); if (eval==0) n++; princ_str("\n",Ct);} else { if(eval) lisp_eval(tem); else {if (n >= vv->cfd.cfd_fillp) FEerror("cfd too small",0); vv->cfd.cfd_self[n++]=tem;}}} if (print_only==0) vv->cfd.cfd_fillp = n; *loc=vv; return; } case DP(d_eval:) {object tem; read_fasd1(GET_OP(),&tem); MAYBE_PATCH(tem); *loc = lisp_eval(tem); current_fasd.evald_items = make_cons(*loc,current_fasd.evald_items); return; } }} static void clrhash(object table) {int i; if (table->ht.ht_nent > 0 ) for(i = 0; i < table->ht.ht_size; i++) { table->ht.ht_self[i].hte_key = OBJNULL; table->ht.ht_self[i].hte_value = OBJNULL;} table->ht.ht_nent =0;} object IfaslInStream; /* static void */ /* IreadFasdData(void) */ /* While executing this the siPMemory should be bound to the cfdata and the sSPinit to a vector of addresses. */ /* {object ar=open_fasd(IfaslInStream,sKinput,0,Cnil); */ /* int n=fix(current_fasd.table_length); */ /* object result; */ /* {BEGIN_NO_INTERRUPT; */ /* #ifdef HAVE_ALLOCA */ /* current_fasd.table->v.v_self */ /* = (object *)alloca(n*sizeof(object)); */ /* #else */ /* current_fasd.table->v.v_self */ /* = (object *)alloc_relblock(n*sizeof(object)); */ /* #endif */ /* current_fasd.table->v.v_dim=n; */ /* current_fasd.table->v.v_fillp=n; */ /* gset( current_fasd.table->v.v_self,0,n,aet_object); */ /* END_NO_INTERRUPT; */ /* } */ /* result=read_fasd_top(ar); */ /* make sure there is nothing still pointing into the stack */ /* current_fasd.table->v.v_self = 0; */ /* current_fasd.table->v.v_dim=0; */ /* current_fasd.table->v.v_fillp=0; */ /* } */ static void init_fasdump(void) { /* make_si_sfun("READ-FASD-TOP",read_fasd_top,1); */ /* make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2); */ /* make_si_sfun("OPEN-FASD",open_fasd,4); */ /* make_si_sfun("CLOSE-FASD",close_fasd,1); */ /* /\* make_si_sfun("FASD-I-DATA",fasd_i_macro,1); *\/ */ /* make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2); */ } gcl-2.6.14/o/unexmacosx.c0000644000175000017500000010611514360276512013573 0ustar cammcamm/* Dump Gcl in Mach-O format for use on Mac OS X. Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GNU Gcl. GNU Gcl is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. GNU Gcl is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Gcl. If not, see . */ /* Contributed by Andrew Choi (akochoi@mac.com). */ /* Documentation note. Consult the following documents/files for a description of the Mach-O format: the file loader.h, man pages for Mach-O and ld, old NEXTSTEP documents of the Mach-O format. The tool otool dumps the mach header (-h option) and the load commands (-l option) in a Mach-O file. The tool nm on Mac OS X displays the symbol table in a Mach-O file. For examples of unexec for the Mach-O format, see the file unexnext.c in the GNU Gcl distribution, the file unexdyld.c in the Darwin port of GNU Gcl 20.7, and unexdyld.c in the Darwin port of XGcl 21.1. Also the Darwin Libc source contains the source code for malloc_freezedry and malloc_jumpstart. Read that to see what they do. This file was written completely from scratch, making use of information from the above sources. */ /* The Mac OS X implementation of unexec makes use of Darwin's `zone' memory allocator. All calls to malloc, realloc, and free in Gcl are redirected to unexec_malloc, unexec_realloc, and unexec_free in this file. When tgcl is run, all memory requests are handled in the zone GclZone. The Darwin memory allocator library calls maintain the data structures to manage this zone. Dumping writes its contents to data segments of the executable file. When gcl is run, the loader recreates the contents of the zone in memory. However since the initialization routine of the zone memory allocator is run again, this `zone' can no longer be used as a heap. That is why gcl uses the ordinary malloc system call to allocate memory. Also, when a block of memory needs to be reallocated and the new size is larger than the old one, a new block must be obtained by malloc and the old contents copied to it. */ /* Peculiarity of the Mach-O files generated by ld in Mac OS X (possible causes of future bugs if changed). The file offset of the start of the __TEXT segment is zero. Since the Mach header and load commands are located at the beginning of a Mach-O file, copying the contents of the __TEXT segment from the input file overwrites them in the output file. Despite this, unexec works fine as written below because the segment load command for __TEXT appears, and is therefore processed, before all other load commands except the segment load command for __PAGEZERO, which remains unchanged. Although the file offset of the start of the __TEXT segment is zero, none of the sections it contains actually start there. In fact, the earliest one starts a few hundred bytes beyond the end of the last load command. The linker option -headerpad controls the minimum size of this padding. Its setting can be changed in s/darwin.h. A value of 0x690, e.g., leaves room for 30 additional load commands for the newly created __DATA segments (at 56 bytes each). Unexec fails if there is not enough room for these new segments. The __TEXT segment contains the sections __text, __cstring, __picsymbol_stub, and __const and the __DATA segment contains the sections __data, __la_symbol_ptr, __nl_symbol_ptr, __dyld, __bss, and __common. The other segments do not contain any sections. These sections are copied from the input file to the output file, except for __data, __bss, and __common, which are dumped from memory. The types of the sections __bss and __common are changed from S_ZEROFILL to S_REGULAR. Note that the number of sections and their relative order in the input and output files remain unchanged. Otherwise all n_sect fields in the nlist records in the symbol table (specified by the LC_SYMTAB load command) will have to be changed accordingly. */ #include #include #include #include #include #include #include #include #include #include #if defined (__ppc__) #include #endif #include #include #undef malloc #undef realloc #undef free #include #include #ifdef _LP64 #define mach_header mach_header_64 #define segment_command segment_command_64 #undef VM_REGION_BASIC_INFO_COUNT #define VM_REGION_BASIC_INFO_COUNT VM_REGION_BASIC_INFO_COUNT_64 #undef VM_REGION_BASIC_INFO #define VM_REGION_BASIC_INFO VM_REGION_BASIC_INFO_64 #undef LC_SEGMENT #define LC_SEGMENT LC_SEGMENT_64 #define vm_region vm_region_64 #define section section_64 #undef MH_MAGIC #define MH_MAGIC MH_MAGIC_64 #endif #define VERBOSE 0 /* Size of buffer used to copy data from the input file to the output file in function unexec_copy. */ #define UNEXEC_COPY_BUFSZ 1024 /* Regions with memory addresses above this value are assumed to be mapped to dynamically loaded libraries and will not be dumped. */ #define VM_DATA_TOP (20 * 1024 * 1024) /* Type of an element on the list of regions to be dumped. */ struct region_t { vm_address_t address; vm_size_t size; vm_prot_t protection; vm_prot_t max_protection; struct region_t *next; }; /* Head and tail of the list of regions to be dumped. */ static struct region_t *region_list_head = 0; static struct region_t *region_list_tail = 0; /* Pointer to array of load commands. */ static struct load_command **lca; /* Number of load commands. */ static int nlc; /* The highest VM address of segments loaded by the input file. Regions with addresses beyond this are assumed to be allocated dynamically and thus require dumping. */ static vm_address_t infile_lc_highest_addr = 0; /* The lowest file offset used by the all sections in the __TEXT segments. This leaves room at the beginning of the file to store the Mach-O header. Check this value against header size to ensure the added load commands for the new __DATA segments did not overwrite any of the sections in the __TEXT segment. */ static unsigned long text_seg_lowest_offset = 0x10000000; /* Mach header. */ static struct mach_header mh; /* Offset at which the next load command should be written. */ static unsigned long curr_header_offset = sizeof (struct mach_header); /* Offset at which the next segment should be written. */ static unsigned long curr_file_offset = 0; static unsigned long pagesize; #define ROUNDUP_TO_PAGE_BOUNDARY(x) (((x) + pagesize - 1) & ~(pagesize - 1)) static int infd, outfd; static malloc_zone_t gcl_zone_body,*gcl_zone; /* file offset of input file's data segment */ static off_t data_segment_old_fileoff = 0; static struct segment_command *data_segment_scp; void reset_unexec_globals() { region_list_head=NULL; region_list_tail=NULL; lca=NULL; nlc=0; infile_lc_highest_addr=0; text_seg_lowest_offset=0x10000000; memset(&mh,0,sizeof(mh)); curr_header_offset=sizeof (struct mach_header); curr_file_offset=0; pagesize=0; infd=0; outfd=0; gcl_zone=NULL; data_segment_old_fileoff=0; data_segment_scp=NULL; } #define MAX_MARKED_REGIONS 1024 vm_range_t marked_regions [MAX_MARKED_REGIONS]; unsigned num_marked_regions; /* Size of the heap. */ static unsigned long big_heap; /* Start of the heap. */ char *mach_mapstart = 0; /* End of the heap. */ char *mach_maplimit = 0; /* Position ot the break within the heap. */ char *mach_brkpt = 0; /* Read N bytes from infd into memory starting at address DEST. Return true if successful, false otherwise. */ static int unexec_read (void *dest, size_t n) { return n == read (infd, dest, n); } /* Write COUNT bytes from memory starting at address SRC to outfd starting at offset DEST. Return true if successful, false otherwise. */ static int unexec_write (off_t dest, const void *src, size_t count) { if (lseek (outfd, dest, SEEK_SET) != dest) return 0; return write (outfd, src, count) == count; } /* Write COUNT bytes of zeros to outfd starting at offset DEST. Return true if successful, false otherwise. */ static int unexec_write_zero (off_t dest, size_t count) { char buf[UNEXEC_COPY_BUFSZ]; ssize_t bytes; bzero (buf, UNEXEC_COPY_BUFSZ); if (lseek (outfd, dest, SEEK_SET) != dest) return 0; while (count > 0) { bytes = count > UNEXEC_COPY_BUFSZ ? UNEXEC_COPY_BUFSZ : count; if (write (outfd, buf, bytes) != bytes) return 0; count -= bytes; } return 1; } /* Copy COUNT bytes from starting offset SRC in infd to starting offset DEST in outfd. Return true if successful, false otherwise. */ static int unexec_copy (off_t dest, off_t src, ssize_t count) { ssize_t bytes_read; ssize_t bytes_to_read; char buf[UNEXEC_COPY_BUFSZ]; if (lseek (infd, src, SEEK_SET) != src) return 0; if (lseek (outfd, dest, SEEK_SET) != dest) return 0; while (count > 0) { bytes_to_read = count > UNEXEC_COPY_BUFSZ ? UNEXEC_COPY_BUFSZ : count; bytes_read = read (infd, buf, bytes_to_read); if (bytes_read <= 0) return 0; if (write (outfd, buf, bytes_read) != bytes_read) return 0; count -= bytes_read; } return 1; } /* Debugging and informational messages routines. */ #define unexec_error(a,b...) emsg(a,##b),do_gcl_abort() /* More informational messages routines. */ #if VERBOSE static void print_load_command_name (int lc) { switch (lc) { case LC_SEGMENT: #ifndef _LP64 printf ("LC_SEGMENT "); #else printf ("LC_SEGMENT_64 "); #endif break; case LC_LOAD_DYLINKER: printf ("LC_LOAD_DYLINKER "); break; case LC_LOAD_DYLIB: printf ("LC_LOAD_DYLIB "); break; case LC_SYMTAB: printf ("LC_SYMTAB "); break; case LC_DYSYMTAB: printf ("LC_DYSYMTAB "); break; case LC_UNIXTHREAD: printf ("LC_UNIXTHREAD "); break; case LC_PREBOUND_DYLIB: printf ("LC_PREBOUND_DYLIB"); break; case LC_TWOLEVEL_HINTS: printf ("LC_TWOLEVEL_HINTS"); break; #ifdef LC_UUID case LC_UUID: printf ("LC_UUID "); break; #endif #ifdef LC_DYLD_INFO case LC_DYLD_INFO: printf ("LC_DYLD_INFO "); break; case LC_DYLD_INFO_ONLY: printf ("LC_DYLD_INFO_ONLY"); break; #endif default: printf ("unknown "); } } static void print_load_command (struct load_command *lc) { print_load_command_name (lc->cmd); printf ("%8d", lc->cmdsize); if (lc->cmd == LC_SEGMENT) { struct segment_command *scp; struct section *sectp; int j; scp = (struct segment_command *) lc; printf (" %-16.16s %#10lx %#8lx\n", scp->segname, (long) (scp->vmaddr), (long) (scp->vmsize)); sectp = (struct section *) (scp + 1); for (j = 0; j < scp->nsects; j++) { printf (" %-16.16s %#10lx %#8lx\n", sectp->sectname, (long) (sectp->addr), (long) (sectp->size)); sectp++; } } else printf ("\n"); } #endif /* Copy a LC_SEGMENT load command other than the __DATA segment from the input file to the output file, adjusting the file offset of the segment and the file offsets of sections contained in it. */ static void copy_segment (struct load_command *lc) { struct segment_command *scp = (struct segment_command *) lc; unsigned long old_fileoff = scp->fileoff; struct section *sectp; int j; scp->fileoff = curr_file_offset; sectp = (struct section *) (scp + 1); for (j = 0; j < scp->nsects; j++) { sectp->offset += curr_file_offset - old_fileoff; sectp++; } #if VERBOSE printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", scp->segname, (long) (scp->fileoff), (long) (scp->filesize), (long) (scp->vmsize), (long) (scp->vmaddr)); #endif if (!unexec_copy (scp->fileoff, old_fileoff, scp->filesize)) unexec_error ("cannot copy segment from input to output file"); curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (scp->filesize); if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write load command to header"); curr_header_offset += lc->cmdsize; } /* Copy a LC_SEGMENT load command for the __DATA segment in the input file to the output file. We assume that only one such segment load command exists in the input file and it contains the sections __data, __bss, __common, __la_symbol_ptr, __nl_symbol_ptr, and __dyld. The first three of these should be dumped from memory and the rest should be copied from the input file. Note that the sections __bss and __common contain no data in the input file because their flag fields have the value S_ZEROFILL. Dumping these from memory makes it necessary to adjust file offset fields in subsequently dumped load commands. Then, create new __DATA segment load commands for regions on the region list other than the one corresponding to the __DATA segment in the input file. */ static void copy_data_segment (struct load_command *lc) { struct segment_command *scp = (struct segment_command *) lc; struct section *sectp; int j; unsigned long header_offset, old_file_offset; /* The new filesize of the segment is set to its vmsize because data blocks for segments must start at region boundaries. Note that this may leave unused locations at the end of the segment data block because the total of the sizes of all sections in the segment is generally smaller than vmsize. */ scp->filesize = scp->vmsize; #if VERBOSE printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", scp->segname, curr_file_offset, (long)(scp->filesize), (long)(scp->vmsize), (long) (scp->vmaddr)); #endif /* Offsets in the output file for writing the next section structure and segment data block, respectively. */ header_offset = curr_header_offset + sizeof (struct segment_command); sectp = (struct section *) (scp + 1); for (j = 0; j < scp->nsects; j++) { old_file_offset = sectp->offset; sectp->offset = sectp->addr - scp->vmaddr + curr_file_offset; /* The __data section is dumped from memory. The __bss and __common sections are also dumped from memory but their flag fields require changing (from S_ZEROFILL to S_REGULAR). The other three kinds of sections are just copied from the input file. */ if (strncmp (sectp->sectname, SECT_DATA, 16) == 0) { if (!unexec_write (sectp->offset, (void *) sectp->addr, sectp->size)) unexec_error ("cannot write section %s", SECT_DATA); if (!unexec_write (header_offset, sectp, sizeof (struct section))) unexec_error ("cannot write section %s's header", SECT_DATA); } else if (strncmp (sectp->sectname, SECT_COMMON, 16) == 0) { sectp->flags = S_REGULAR; if (!unexec_write (sectp->offset, (void *) sectp->addr, sectp->size)) unexec_error ("cannot write section %s", sectp->sectname); if (!unexec_write (header_offset, sectp, sizeof (struct section))) unexec_error ("cannot write section %s's header", sectp->sectname); } else if (strncmp (sectp->sectname, SECT_BSS, 16) == 0) { /* extern char *my_endbss_static; */ unsigned long my_size; sectp->flags = S_REGULAR; /* Clear uninitialized local variables in statically linked libraries. In particular, function pointers stored by libSystemStub.a, which is introduced in Mac OS X 10.4 for binary compatibility with respect to long double, are cleared so that they will be reinitialized when the dumped binary is executed on other versions of OS. */ my_size = sectp->size;/* (unsigned long)my_endbss_static - sectp->addr; */ /* if (!(sectp->addr <= (unsigned long)my_endbss_static */ /* && my_size <= sectp->size)) */ /* unexec_error ("my_endbss_static is not in section %s", */ /* sectp->sectname); */ if (!unexec_write (sectp->offset, (void *) sectp->addr, my_size)) unexec_error ("cannot write section %s", sectp->sectname); if (!unexec_write_zero (sectp->offset + my_size, sectp->size - my_size)) unexec_error ("cannot write section %s", sectp->sectname); if (!unexec_write (header_offset, sectp, sizeof (struct section))) unexec_error ("cannot write section %s's header", sectp->sectname); } else if (strncmp (sectp->sectname, "__la_symbol_ptr", 16) == 0 || strncmp (sectp->sectname, "__nl_symbol_ptr", 16) == 0 || strncmp (sectp->sectname, "__la_sym_ptr2", 16) == 0 || strncmp (sectp->sectname, "__dyld", 16) == 0 || strncmp (sectp->sectname, "__const", 16) == 0 || strncmp (sectp->sectname, "__cfstring", 16) == 0 || strncmp (sectp->sectname, "__gcc_except_tab", 16) == 0 || strncmp (sectp->sectname, "__program_vars", 16) == 0 || strncmp (sectp->sectname, "__objc_", 7) == 0 || strncmp (sectp->sectname, "__got", 5) == 0)/*FIXME check this, but appears to work*/ { if (!unexec_copy (sectp->offset, old_file_offset, sectp->size)) unexec_error ("cannot copy section %s", sectp->sectname); if (!unexec_write (header_offset, sectp, sizeof (struct section))) unexec_error ("cannot write section %s's header", sectp->sectname); } else unexec_error ("unrecognized section name in __DATA segment"); #if VERBOSE printf (" section %-16.16s at %#8lx - %#8lx (sz: %#8lx)\n", sectp->sectname, (long) (sectp->offset), (long) (sectp->offset + sectp->size), (long) (sectp->size)); #endif header_offset += sizeof (struct section); sectp++; } curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (scp->filesize); if (!unexec_write (curr_header_offset, scp, sizeof (struct segment_command))) unexec_error ("cannot write header of __DATA segment"); curr_header_offset += lc->cmdsize; /* Create new __DATA segment load commands for regions on the region list that do not corresponding to any segment load commands in the input file. */ /* for (j = 0; j < num_unexec_regions; j++) */ { struct segment_command sc; sc.cmd = LC_SEGMENT; sc.cmdsize = sizeof (struct segment_command); /* strncpy (sc.segname, SEG_DATA, 16); */ strncpy (sc.segname, "__HEAP", 16); sc.vmaddr = (long)mach_mapstart; sc.vmsize = mach_maplimit-mach_mapstart; sc.fileoff = curr_file_offset; sc.filesize = core_end-mach_mapstart; sc.maxprot = VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE; sc.initprot = VM_PROT_READ | VM_PROT_WRITE /* | VM_PROT_EXECUTE */; sc.nsects = 0; sc.flags = 0; #if VERBOSE printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", sc.segname, (long) (sc.fileoff), (long) (sc.filesize), (long) (sc.vmsize), (long) (sc.vmaddr)); #endif if (!unexec_write (sc.fileoff, (void *) sc.vmaddr, sc.filesize)) unexec_error ("cannot write new __DATA segment"); curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (sc.filesize); if (!unexec_write (curr_header_offset, &sc, sc.cmdsize)) unexec_error ("cannot write new __DATA segment's header"); curr_header_offset += sc.cmdsize; mh.ncmds++; } } /* Copy a LC_SYMTAB load command from the input file to the output file, adjusting the file offset fields. */ static void copy_symtab (struct load_command *lc, long delta) { struct symtab_command *stp = (struct symtab_command *) lc; stp->symoff += delta; stp->stroff += delta; #if VERBOSE printf ("Writing LC_SYMTAB command\n"); #endif if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write symtab command to header"); curr_header_offset += lc->cmdsize; } /* Fix up relocation entries. */ static void unrelocate (const char *name, off_t reloff, int nrel, vm_address_t base) { int i, unreloc_count; struct relocation_info reloc_info; struct scattered_relocation_info *sc_reloc_info = (struct scattered_relocation_info *) &reloc_info; vm_address_t location; for (unreloc_count = 0, i = 0; i < nrel; i++) { if (lseek (infd, reloff, L_SET) != reloff) unexec_error ("unrelocate: %s:%d cannot seek to reloc_info", name, i); if (!unexec_read (&reloc_info, sizeof (reloc_info))) unexec_error ("unrelocate: %s:%d cannot read reloc_info", name, i); reloff += sizeof (reloc_info); if (sc_reloc_info->r_scattered == 0) switch (reloc_info.r_type) { case GENERIC_RELOC_VANILLA: location = base + reloc_info.r_address; if (location >= data_segment_scp->vmaddr && location < (data_segment_scp->vmaddr + data_segment_scp->vmsize)) { off_t src_off = data_segment_old_fileoff + (location - data_segment_scp->vmaddr); off_t dst_off = data_segment_scp->fileoff + (location - data_segment_scp->vmaddr); if (!unexec_copy (dst_off, src_off, 1 << reloc_info.r_length)) unexec_error ("unrelocate: %s:%d cannot copy original value", name, i); unreloc_count++; } break; default: unexec_error ("unrelocate: %s:%d cannot handle type = %d", name, i, reloc_info.r_type); } else switch (sc_reloc_info->r_type) { #if defined (__ppc__) case PPC_RELOC_PB_LA_PTR: /* nothing to do for prebound lazy pointer */ break; #endif default: unexec_error ("unrelocate: %s:%d cannot handle scattered type = %d", name, i, sc_reloc_info->r_type); } } #if VERBOSE if (nrel > 0) printf ("Fixed up %d/%d %s relocation entries in data segment.\n", unreloc_count, nrel, name); #endif } #if __ppc64__ /* Rebase r_address in the relocation table. */ static void rebase_reloc_address (off_t reloff, int nrel, long linkedit_delta, long diff) { int i; struct relocation_info reloc_info; struct scattered_relocation_info *sc_reloc_info = (struct scattered_relocation_info *) &reloc_info; for (i = 0; i < nrel; i++, reloff += sizeof (reloc_info)) { if (lseek (infd, reloff - linkedit_delta, L_SET) != reloff - linkedit_delta) unexec_error ("rebase_reloc_table: cannot seek to reloc_info"); if (!unexec_read (&reloc_info, sizeof (reloc_info))) unexec_error ("rebase_reloc_table: cannot read reloc_info"); if (sc_reloc_info->r_scattered == 0 && reloc_info.r_type == GENERIC_RELOC_VANILLA) { reloc_info.r_address -= diff; if (!unexec_write (reloff, &reloc_info, sizeof (reloc_info))) unexec_error ("rebase_reloc_table: cannot write reloc_info"); } } } #endif /* Copy a LC_DYSYMTAB load command from the input file to the output file, adjusting the file offset fields. */ static void copy_dysymtab (struct load_command *lc, long delta) { struct dysymtab_command *dstp = (struct dysymtab_command *) lc; vm_address_t base; #ifdef _LP64 #if __ppc64__ { int i; base = 0; for (i = 0; i < nlc; i++) if (lca[i]->cmd == LC_SEGMENT) { struct segment_command *scp = (struct segment_command *) lca[i]; if (scp->vmaddr + scp->vmsize > 0x100000000 && (scp->initprot & VM_PROT_WRITE) != 0) { base = data_segment_scp->vmaddr; break; } } } #else /* First writable segment address. */ base = data_segment_scp->vmaddr; #endif #else /* First segment address in the file (unless MH_SPLIT_SEGS set). */ base = 0; #endif unrelocate ("local", dstp->locreloff, dstp->nlocrel, base); unrelocate ("external", dstp->extreloff, dstp->nextrel, base); if (dstp->nextrel > 0) { dstp->extreloff += delta; } if (dstp->nlocrel > 0) { dstp->locreloff += delta; } if (dstp->nindirectsyms > 0) dstp->indirectsymoff += delta; #if VERBOSE printf ("Writing LC_DYSYMTAB command\n"); #endif if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write symtab command to header"); curr_header_offset += lc->cmdsize; #if __ppc64__ /* Check if the relocation base needs to be changed. */ if (base == 0) { vm_address_t newbase = 0; int i; for (i = 0; i < num_unexec_regions; i++) if (unexec_regions[i].range.address + unexec_regions[i].range.size > 0x100000000) { newbase = data_segment_scp->vmaddr; break; } if (newbase) { rebase_reloc_address (dstp->locreloff, dstp->nlocrel, delta, newbase); rebase_reloc_address (dstp->extreloff, dstp->nextrel, delta, newbase); } } #endif } /* Copy a LC_TWOLEVEL_HINTS load command from the input file to the output file, adjusting the file offset fields. */ static void copy_twolevelhints (struct load_command *lc, long delta) { struct twolevel_hints_command *tlhp = (struct twolevel_hints_command *) lc; if (tlhp->nhints > 0) { tlhp->offset += delta; } #if VERBOSE printf ("Writing LC_TWOLEVEL_HINTS command\n"); #endif if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write two level hint command to header"); curr_header_offset += lc->cmdsize; } #ifdef LC_DYLD_INFO /* Copy a LC_DYLD_INFO(_ONLY) load command from the input file to the output file, adjusting the file offset fields. */ static void copy_dyld_info (struct load_command *lc, long delta) { struct dyld_info_command *dip = (struct dyld_info_command *) lc; if (dip->rebase_off > 0) dip->rebase_off += delta; if (dip->bind_off > 0) dip->bind_off += delta; if (dip->weak_bind_off > 0) dip->weak_bind_off += delta; if (dip->lazy_bind_off > 0) dip->lazy_bind_off += delta; if (dip->export_off > 0) dip->export_off += delta; #if VERBOSE printf ("Writing "); print_load_command_name (lc->cmd); printf (" command\n"); #endif if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write dyld info command to header"); curr_header_offset += lc->cmdsize; } #endif /* Copy other kinds of load commands from the input file to the output file, ones that do not require adjustments of file offsets. */ static void copy_other (struct load_command *lc) { #if VERBOSE printf ("Writing "); print_load_command_name (lc->cmd); printf (" command\n"); #endif if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) unexec_error ("cannot write symtab command to header"); curr_header_offset += lc->cmdsize; } /* Loop through all load commands and dump them. Then write the Mach header. */ static void dump_it () { int i; long linkedit_delta = 0; #if VERBOSE printf ("--- Load Commands written to Output File ---\n"); #endif for (i = 0; i < nlc; i++) switch (lca[i]->cmd) { case LC_SEGMENT: { struct segment_command *scp = (struct segment_command *) lca[i]; if (strncmp (scp->segname, SEG_DATA, 16) == 0) { /* save data segment file offset and segment_command for unrelocate */ if (data_segment_old_fileoff) unexec_error ("cannot handle multiple DATA segments in input file"); data_segment_old_fileoff = scp->fileoff; data_segment_scp = scp; copy_data_segment (lca[i]); } else { if (strncmp (scp->segname, SEG_LINKEDIT, 16) == 0) { if (linkedit_delta) unexec_error ("cannot handle multiple LINKEDIT segments in input file"); linkedit_delta = curr_file_offset - scp->fileoff; } if (strncmp (scp->segname, "__HEAP", 16) != 0) copy_segment (lca[i]); else mh.ncmds--; } } break; case LC_SYMTAB: copy_symtab (lca[i], linkedit_delta); break; case LC_DYSYMTAB: copy_dysymtab (lca[i], linkedit_delta); break; case LC_TWOLEVEL_HINTS: copy_twolevelhints (lca[i], linkedit_delta); break; #ifdef LC_DYLD_INFO case LC_DYLD_INFO: case LC_DYLD_INFO_ONLY: copy_dyld_info (lca[i], linkedit_delta); break; #endif default: copy_other (lca[i]); break; } if (curr_header_offset > text_seg_lowest_offset) unexec_error ("not enough room for load commands for new __DATA segments"); #if VERBOSE printf ("%ld unused bytes follow Mach-O header\n", text_seg_lowest_offset - curr_header_offset); #endif mh.sizeofcmds = curr_header_offset - sizeof (struct mach_header); if (!unexec_write (0, &mh, sizeof (struct mach_header))) unexec_error ("cannot write final header contents"); } /* Read header and load commands from input file. Store the latter in the global array lca. Store the total number of load commands in global variable nlc. */ static void read_load_commands_and_dump () { int i; if (!unexec_read (&mh, sizeof (struct mach_header))) unexec_error ("cannot read mach-o header"); if (mh.magic != MH_MAGIC) unexec_error ("input file not in Mach-O format"); if (mh.filetype != MH_EXECUTE) unexec_error ("input Mach-O file is not an executable object file"); #if VERBOSE printf ("--- Header Information ---\n"); printf ("Magic = 0x%08x\n", mh.magic); printf ("CPUType = %d\n", mh.cputype); printf ("CPUSubType = %d\n", mh.cpusubtype); printf ("FileType = 0x%x\n", mh.filetype); printf ("NCmds = %d\n", mh.ncmds); printf ("SizeOfCmds = %d\n", mh.sizeofcmds); printf ("Flags = 0x%08x\n", mh.flags); #endif nlc = mh.ncmds; lca=alloca(nlc*sizeof(struct load_command *)); for (i = 0; i < nlc; i++) { struct load_command lc; /* Load commands are variable-size: so read the command type and size first and then read the rest. */ if (!unexec_read (&lc, sizeof (struct load_command))) unexec_error ("cannot read load command"); lca[i]=(struct load_command *)alloca(lc.cmdsize); memcpy (lca[i], &lc, sizeof (struct load_command)); if (!unexec_read (lca[i] + 1, lc.cmdsize - sizeof (struct load_command))) unexec_error ("cannot read content of load command"); if (lc.cmd == LC_SEGMENT) { struct segment_command *scp = (struct segment_command *) lca[i]; if (scp->vmaddr + scp->vmsize > infile_lc_highest_addr) infile_lc_highest_addr = scp->vmaddr + scp->vmsize; if (strncmp (scp->segname, SEG_TEXT, 16) == 0) { struct section *sectp = (struct section *) (scp + 1); int j; for (j = 0; j < scp->nsects; j++) if (sectp->offset < text_seg_lowest_offset) text_seg_lowest_offset = sectp->offset; } } } #if VERBOSE printf ("Highest address of load commands in input file: %#8x\n", infile_lc_highest_addr); printf ("Lowest offset of all sections in __TEXT segment: %#8lx\n", text_seg_lowest_offset); printf ("--- List of Load Commands in Input File ---\n"); printf ("# cmd cmdsize name address size\n"); for (i = 0; i < nlc; i++) { printf ("%1d ", i); print_load_command (lca[i]); } #endif dump_it (); } /* Take a snapshot of Gcl and make a Mach-O format executable file from it. The file names of the output and input files are outfile and infile, respectively. The three other parameters are ignored. */ void unexec (char *outfile, char *infile, void *start_data, void *start_bss, void *entry_address) { reset_unexec_globals(); pagesize = getpagesize (); if ((infd = open (infile, O_RDONLY, 0)) < 0) unexec_error ("cannot open input file `%s'", infile); if ((outfd = open (outfile, O_WRONLY | O_TRUNC | O_CREAT, 0755)) < 0) { close (infd); unexec_error ("cannot open output file `%s'", outfile); } read_load_commands_and_dump(); close (outfd); } /* Replacement for broken sbrk(2). */ #include #include unsigned long probe_big_heap(unsigned long try,unsigned long inc,unsigned long max) { void *r; if ((r=mmap(NULL, try, PROT_READ|PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0))==(void *)-1) return try>inc ? probe_big_heap(try-inc,inc>>1,max) : 0; munmap(r,try); return (!inc || try >=max) ? try : probe_big_heap(try+inc,inc,max); } void *my_sbrk (long incr) { char *temp, *ptr; if (mach_brkpt == 0) { big_heap=(1UL)<<35; if (!(big_heap=probe_big_heap(PAGESIZE,big_heap>>1,big_heap))) { unexec_error("my_sbrk(): probe_big_heap() failed\n"); return ((char *)-1); } mach_brkpt=mmap(NULL, big_heap, PROT_READ|PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); mach_mapstart = mach_brkpt; mach_maplimit = mach_brkpt + big_heap; } if (incr == 0) { return (mach_brkpt); } else { ptr = mach_brkpt + incr; if (ptr mach_maplimit) return (char *)-1; temp = mach_brkpt; mach_brkpt = ptr; return (temp); } } static size_t stub_size (malloc_zone_t *zone, const void *ptr) { extern object malloc_list; object *p; for (p = &malloc_list ; *p && !endp(*p) ; p = &((*p)->c.c_cdr)) { size_t size = (*p)->c.c_car->st.st_dim; void *base = (*p)->c.c_car->st.st_self; if (ptr >= base && ptr < base + size) { return (size); } } return (0); } #ifdef HAVE_MALLOC_ZONE_MEMALIGN static void * stub_memalign(size_t boundary, size_t size) { extern void *my_malloc (size_t); void *v=my_malloc(size+boundary-1); return (void *)(((unsigned long)v+boundary-1)&~(boundary-1)); } #endif static void * stub_malloc(malloc_zone_t *zone, size_t size) { extern void *my_malloc (size_t); return my_malloc (size); } static void * stub_calloc(malloc_zone_t *zone, size_t num_items, size_t size) { extern void *my_calloc (size_t, size_t); return my_calloc (num_items, size); } static void * stub_valloc(malloc_zone_t *zone, size_t size) { extern void *my_valloc (size_t); return my_valloc (size); } static void * stub_realloc(malloc_zone_t *zone, void *ptr, size_t size) { extern void *my_realloc (void *, size_t); return my_realloc (ptr, size); } static void stub_free (malloc_zone_t *zone, void *ptr) { extern void my_free (void *ptr); my_free (ptr); } void init_darwin_zone_compat () { extern unsigned malloc_num_zones; extern malloc_zone_t **malloc_zones; unsigned nmzc; malloc_zone_t *mzc[10]; unsigned i; nmzc=malloc_num_zones; assert(nmzc<=sizeof(mzc)/sizeof(*mzc)); memcpy(mzc,malloc_zones,nmzc*sizeof(*mzc)); gcl_zone=&gcl_zone_body; gcl_zone->size = (void *) stub_size; gcl_zone->malloc = (void *) stub_malloc; gcl_zone->calloc = (void *) stub_calloc; gcl_zone->valloc = (void *) stub_valloc; gcl_zone->realloc = (void *) stub_realloc; gcl_zone->free = (void *) stub_free; gcl_zone->destroy = (void *) stub_free; gcl_zone->batch_malloc = (void *) stub_malloc; gcl_zone->batch_free = (void *) stub_free; #ifdef HAVE_MALLOC_ZONE_MEMALIGN gcl_zone->free_definite_size = (void *) stub_free; gcl_zone->memalign = (void *) stub_memalign; #endif for (i=0;i #include "include.h" #include "num_include.h" #ifdef GMP #include "gmp_num_log.c" #else #include "pari_num_log.c" #endif object fixnum_big_shift(fixnum x,fixnum w) { MPOP(return,shifti,SI_TO_MP(x,big_fixnum1),w); } object integer_fix_shift(object x, fixnum w) { if (type_of(x)==t_fixnum) { fixnum fx=fix(x); return (fx!=MOST_NEGATIVE_FIX || w<0) ? fixnum_shft(fx,w) : fixnum_big_shift(fx,w); } MPOP(return,shifti,MP(x),w); } object integer_shift(object x,object y) { enum type tx=type_of(x),ty=type_of(y); if (ty==t_fixnum) return integer_fix_shift(x,fix(y)); else { if (eql(x,make_fixnum(0))) return x; if (big_sign(y)<0) return make_fixnum((tx==t_fixnum ? fix(x) : big_sign(x))<0 ? -1 : 0); FEerror("Insufficient memory",0); return Cnil; } } object integer_length(object x) { return make_fixnum(type_of(x)==t_fixnum ? fixnum_length(fix(x)) : MP_SIZE_IN_BASE2(MP(x))); } object integer_count(object x) { return make_fixnum(type_of(x)==t_fixnum ? fixnum_count(fix(x)) : MP_BITCOUNT(MP(x))); } #define DEFLOG(a_,b_,c_) \ LFD(a_)(void) { \ object x; \ int narg, i; \ \ narg = vs_top - vs_base; \ for (i = 0; i < narg; i++) \ check_type_integer(&vs_base[i]); \ if (narg == 0) { \ vs_top = vs_base; \ vs_push(c_); \ return; \ } \ if (narg == 1) \ return; \ x = log_op(b_); \ vs_top = vs_base; \ vs_push(x); \ } DEFLOG(Llogior,BOOLIOR,small_fixnum(0)); DEFLOG(Llogxor,BOOLXOR,small_fixnum(0)); DEFLOG(Llogand,BOOLAND,small_fixnum(-1)); DEFLOG(Llogeqv,BOOLEQV,small_fixnum(-1)); LFD(Lboole)(void) { object x; object o; check_arg(3); check_type_integer(&vs_base[0]); check_type_integer(&vs_base[1]); check_type_integer(&vs_base[2]); o = vs_base[0]; vs_base++; x = log_op(fix(o)); vs_base--; vs_top = vs_base; vs_push(x); } bool integer_bitp(object p,object x) { enum type tp=type_of(p),tx=type_of(x); if (tp==t_fixnum) { if (tx==t_fixnum) return fixnum_bitp(fix(p),fix(x)); else return big_bitp(x,fix(p)); } else if (big_sign(p)<0) return 0; else if (tx==t_fixnum)/*fixme integer_minusp*/ return fix(x)<0; else return big_sign(x)<0; } LFD(Llogbitp)(void) { check_arg(2); check_type_integer(&vs_base[0]); check_type_integer(&vs_base[1]); vs_top=vs_base; vs_push(integer_bitp(vs_base[0],vs_base[1])?Ct:Cnil); } LFD(Lash)(void) { check_arg(2); check_type_integer(&vs_base[0]); check_type_integer(&vs_base[1]); vs_top=vs_base; vs_push(integer_shift(vs_base[0],vs_base[1])); } LFD(Llogcount)(void) { check_arg(1); check_type_integer(&vs_base[0]); vs_base[0]=integer_count(vs_base[0]); } LFD(Linteger_length)(void) { check_arg(1); check_type_integer(&vs_base[0]); vs_base[0]=integer_length(vs_base[0]); } #define W_SIZE (8*sizeof(int)) static fixnum ior_op(fixnum i, fixnum j) { return(i | j); } static fixnum xor_op(fixnum i, fixnum j) { return(i ^ j); } static fixnum and_op(fixnum i, fixnum j) { return(i & j); } static fixnum eqv_op(fixnum i, fixnum j) { return(~(i ^ j)); } static fixnum nand_op(fixnum i, fixnum j) { return(~(i & j)); } static fixnum nor_op(fixnum i, fixnum j) { return(~(i | j)); } static fixnum andc1_op(fixnum i, fixnum j) { return((~i) & j); } static fixnum andc2_op(fixnum i, fixnum j) { return(i & (~j)); } static fixnum orc1_op(fixnum i, fixnum j) { return((~i) | j); } static fixnum orc2_op(fixnum i, fixnum j) { return(i | (~j)); } static fixnum b_clr_op(fixnum i, fixnum j) { return(0); } static fixnum b_set_op(fixnum i, fixnum j) { return(-1); } static fixnum b_1_op(fixnum i, fixnum j) { return(i); } static fixnum b_2_op(fixnum i, fixnum j) { return(j); } static fixnum b_c1_op(fixnum i, fixnum j) { return(~i); } static fixnum b_c2_op(fixnum i, fixnum j) { return(~j); } LFD(siLbit_array_op)(void) { fixnum i, j, n, d; object o, x, y, r, r0=Cnil; fixnum (*op)()=NULL; bool replace = FALSE; fixnum xi, yi, ri; char *xp, *yp, *rp; fixnum xo, yo, ro; object *base = vs_base; check_arg(4); o = vs_base[0]; x = vs_base[1]; y = vs_base[2]; r = vs_base[3]; if (type_of(x) == t_bitvector) { d = x->bv.bv_dim; xp = x->bv.bv_self; xo = BV_OFFSET(x); if (type_of(y) != t_bitvector) goto ERROR1; if (d != y->bv.bv_dim) goto ERROR1; yp = y->bv.bv_self; yo = BV_OFFSET(y); if (r == Ct) r = x; if (r != Cnil) { if (type_of(r) != t_bitvector) goto ERROR1; if (r->bv.bv_dim != d) goto ERROR1; i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo); if ((i > 0 && i < d) || (i < 0 && -i < d)) { r0 = r; r = Cnil; replace = TRUE; goto L1; } i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo); if ((i > 0 && i < d) || (i < 0 && -i < d)) { r0 = r; r = Cnil; replace = TRUE; } } L1: if (r == Cnil) { vs_base = vs_top; vs_push(sLbit); vs_push(make_fixnum(d)); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); siLmake_vector(); r = vs_base[0]; } } else { if (type_of(x) != t_array) goto ERROR1; if ((enum aelttype)x->a.a_elttype != aet_bit) goto ERROR1; d = x->a.a_dim; xp = x->bv.bv_self; xo = BV_OFFSET(x); if (type_of(y) != t_array) goto ERROR1; if ((enum aelttype)y->a.a_elttype != aet_bit) goto ERROR1; if (x->a.a_rank != y->a.a_rank) goto ERROR1; yp = y->bv.bv_self; yo = BV_OFFSET(y); for (i = 0; i < x->a.a_rank; i++) if (x->a.a_dims[i] != y->a.a_dims[i]) goto ERROR1; if (r == Ct) r = x; if (r != Cnil) { if (type_of(r) != t_array) goto ERROR1; if ((enum aelttype)r->a.a_elttype != aet_bit) goto ERROR1; if (r->a.a_rank != x->a.a_rank) goto ERROR1; for (i = 0; i < x->a.a_rank; i++) if (r->a.a_dims[i] != x->a.a_dims[i]) goto ERROR1; i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo); if ((i > 0 && i < d) || (i < 0 && -i < d)) { r0 = r; r = Cnil; replace = TRUE; goto L2; } i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo); if ((i > 0 && i < d) || (i < 0 && -i < d)) { r0 = r; r = Cnil; replace = TRUE; } } L2: if (r == Cnil) { object b; struct cons *p=alloca(x->a.a_rank*sizeof(struct cons)); if (x->a.a_rank) { object b1; b=(object)p; for (b1=b,i=0;ia.a_rank;i++,b1=b1->c.c_cdr) { #ifdef WIDE_CONS set_type_of(b1,t_cons); #endif b1->c.c_car=/* x->a.a_dims[i]a.a_dims[i]) : */ /* now done in a macro */ make_fixnum(x->a.a_dims[i]); b1->c.c_cdr=ia.a_rank-1 ? (object)++p : Cnil; } } else b=Cnil; r = fSmake_array1(aet_bit,Cnil,small_fixnum(0),Cnil,0,b); /* object b[F_ARG_LIMIT]; */ /* b[0]=Cnil; */ /* for (i = 0; i < x->a.a_rank; i++) */ /* b[i] = (make_fixnum(x->a.a_dims[i])); */ /* r=Iapply_fun_n1(fSmake_array1,5,x->a.a_rank ? x->a.a_rank : 1, */ /* aet_bit, */ /* Cnil, */ /* small_fixnum(0), */ /* Cnil, */ /* Cnil, */ /* b); */ } } rp = r->bv.bv_self; ro = BV_OFFSET(r); switch(fixint(o)) { case BOOLCLR: op = b_clr_op; break; case BOOLSET: op = b_set_op; break; case BOOL1: op = b_1_op; break; case BOOL2: op = b_2_op; break; case BOOLC1: op = b_c1_op; break; case BOOLC2: op = b_c2_op; break; case BOOLAND: op = and_op; break; case BOOLIOR: op = ior_op; break; case BOOLXOR: op = xor_op; break; case BOOLEQV: op = eqv_op; break; case BOOLNAND: op = nand_op; break; case BOOLNOR: op = nor_op; break; case BOOLANDC1: op = andc1_op; break; case BOOLANDC2: op = andc2_op; break; case BOOLORC1: op = orc1_op; break; case BOOLORC2: op = orc2_op; break; default: FEerror("~S is an invalid logical operator.", 1, o); } #define set_high(place, nbits, value) \ ((place)=(((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits))))) #define set_low(place, nbits, value) \ ((place)=(((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits)))))) #define extract_byte(integer, pointer, index, offset) \ (integer) = (pointer)[(index)+1] & 0377; \ (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset))) #define store_byte(pointer, index, offset, value) \ set_low((pointer)[index], 8-(offset), (value)>>(offset)); \ set_high((pointer)[(index)+1], offset, (value)<<(8-(offset))) if (xo == 0 && yo == 0 && ro == 0) { for (n = d/8, i = 0; i < n; i++) rp[i] = (*op)(xp[i], yp[i]); if ((j = d%8) > 0) set_high(rp[n], j, (*op)(xp[n], yp[n])); if (!replace) { vs_top = vs_base = base; vs_push(r); return; } } else { for (n = d/8, i = 0; i <= n; i++) { extract_byte(xi, xp, i, xo); extract_byte(yi, yp, i, yo); if (i == n) { if ((j = d%8) == 0) break; extract_byte(ri, rp, n, ro); set_high(ri, j, (*op)(xi, yi)); } else ri = (*op)(xi, yi); store_byte(rp, i, ro, ri); } if (!replace) { vs_top = vs_base = base; vs_push(r); return; } } rp = r0->bv.bv_self; ro = BV_OFFSET(r0); for (n = d/8, i = 0; i <= n; i++) { if (i == n) { if ((j = d%8) == 0) break; extract_byte(ri, rp, n, ro); set_high(ri, j, r->bv.bv_self[n]); } else ri = r->bv.bv_self[i]; store_byte(rp, i, ro, ri); } vs_top = vs_base = base; vs_push(r0); return; ERROR1: FEerror("Illegal arguments for bit-array operation.", 0); } void gcl_init_num_log(void) { /* int siLbit_array_op(void); */ make_constant("BOOLE-CLR", make_fixnum(BOOLCLR)); make_constant("BOOLE-SET", make_fixnum(BOOLSET)); make_constant("BOOLE-1", make_fixnum(BOOL1)); make_constant("BOOLE-2", make_fixnum(BOOL2)); make_constant("BOOLE-C1", make_fixnum(BOOLC1)); make_constant("BOOLE-C2", make_fixnum(BOOLC2)); make_constant("BOOLE-AND", make_fixnum(BOOLAND)); make_constant("BOOLE-IOR", make_fixnum(BOOLIOR)); make_constant("BOOLE-XOR", make_fixnum(BOOLXOR)); make_constant("BOOLE-EQV", make_fixnum(BOOLEQV)); make_constant("BOOLE-NAND", make_fixnum(BOOLNAND)); make_constant("BOOLE-NOR", make_fixnum(BOOLNOR)); make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1)); make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2)); make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1)); make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2)); make_function("LOGIOR", Llogior); make_function("LOGXOR", Llogxor); make_function("LOGAND", Llogand); make_function("LOGEQV", Llogeqv); make_function("BOOLE", Lboole); make_function("LOGBITP", Llogbitp); make_function("ASH", Lash); make_function("LOGCOUNT", Llogcount); make_function("INTEGER-LENGTH", Linteger_length); sLbit = make_ordinary("BIT"); make_si_function("BIT-ARRAY-OP", siLbit_array_op); } gcl-2.6.14/o/funs0000755000175000017500000000164014360276512012133 0ustar cammcammarray.c:Iarray_element_type(x) array.c:Idisplace_array(from,to,displaced_index_offset) array.c:Icheck_displaced(displaced_list,ar,dim) array.c:Iundisplace(ar) error.c:Icall_error_handler(error_name,error_format_string,nfmt_args,va_alist) eval.c:Ieval(form) fasdump.c:IreadFasdData() makefun.c:ImakeClosure(addr,argd,n,va_alist) makefun.c:IsetClosure(x,n,ap) nfunlink.c:Icall_proc(fun_name,link_desk,link_loc,ap) nfunlink.c:Icall_proc_float(fun_name,link_desk,link_loc,ap) nfunlink.c:IapplyVector(fun,nargs,base) nfunlink.c:Iinvoke_c_function_from_value_stack(fLaref,F_ARGD(2,2,0,ARGTYPES(oo,io,oo,oo))); nfunlink.c:Iinvoke_c_function_from_value_stack(f,fargd) utils.c:IisSymbol(f) utils.c:IisFboundp(f) utils.c:IisArray(f) utils.c:Iis_fixnum(f) utils.c:Iapply_ap(f,ap) utils.c:Ifuncall_n(fun,n,va_alist) utils.c:Iapply_fun_n(fun,n,m,va_alist) utils.c:ImakeStructure(n,p) utils.c:Icheck_one_type(x,t) utils.c:Ineed_in_image(foo) gcl-2.6.14/o/bcopy.c0000755000175000017500000000022414360276512012512 0ustar cammcamm#include void bcopy(const void *s1, void *s2, size_t n) { const char *c1=s1; char *c2=s2; while (n-- > 0) { *c2++ = *c1++; } } gcl-2.6.14/o/ChangeLog0000755000175000017500000014703714360276512013022 0ustar cammcammFri Nov 24 18:42:46 1995 Bill Schelter * alloc.c (ONCE_MORE): * DEFUN("STATICP",.. had accidentally been included in a section which was '#ifdef'ed out on nexts..., making it not be there at link time: moved it to where it is always there. * Nov 11 1995 bill schelter * gcl-2.2 released Sun Oct 1 19:52:45 1995 Bill Schelter * Many changes to gcl 2.1 to support 64 bit machines (eg Dec alpha). Layout of structures etc changed. * a gcl-2.2 beta was released in the summer. since then there have been several bugs fixed. One in cmpfun.lsp affecting write, and another in init_gcl.lsp to make sure the link array is a string array (changed from fixnum which are no longer sufficient to hold pointers). * changes to fix for PA risc hpux in the hp800.h * changes to unexec-19.27.c to allow MUCH faster saving in NFS environment. * testing with maxima 5.1 * reworking makefiles Sat Apr 29 08:48:06 1994 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Changed to release under GNU Public Library license. There have been a number of other fixes including fixes to bignums. Thu Jan 20 10:38:00 1994 Bill Schelter (wfs at nicolas.ma.utexas.edu) * version 624 made. * contains just changes so that compiles on solaris 5.2. The 623 version compiled on solaris 5.3, but the earlier 5.2 version of solaris had some differences which needed patches. These are contained in 624. Fri Dec 10 15:02:14 1993 Bill Schelter (wfs at nicolas.ma.utexas.edu) * version 623 made. * the check on string-trim for a list of chars is fixed. Much earlier the (string-trim '(2) "ab") would run forever. Then string-trim was broken. Sun Dec 5 15:34:44 1993 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add solaris version: changes to several C files and new version of sfasl for elf. * linux port added. Thu Oct 29 13:20:17 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * make sure the signal stack is 8 byte aligned. Needed on sun os 4.1.2 and higher. Thu Jun 4 06:18:20 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix allocation of copy space during an sgc for relocatable Wed Apr 29 09:02:59 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) *cmpnew/lfuns.lsp make load,open, error-set go through lisp symbol, so users can redefine them (eg when loaded common lisp condition code stuff). * defstruct.lsp: put the conc-name in the current package, so that programs can discover the package in effect when the defstruct was done, in order to reconstruct accessors. Sun Apr 26 23:28:42 1992 Bill Schelter (wfs@sonia.ma.utexas.edu) * predicate.c: contains_sharp_comma handle non type t arrays * co1typep optimize for the '(satifies fun) type. * cmpinline.lsp, cmplabel.lsp, cmploc.lsp inline-integer (set-loc unwind-exit get-inline-loc) fixes by r harris. Thu Apr 23 15:09:44 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * cmpenv.lsp fix function return integer proclamation. Sat Apr 11 09:25:05 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * numlib.lsp: changes to ensure double accuracy not lost. Thu Apr 9 11:21:25 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * log,exp,.. get more accuracy if given a fixnum[don't use short-float] * cmptop.lsp empty keyword list bug (defun foo(&key) nil) * many files add hooks for dos port. Fri Mar 27 15:59:24 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * (cmpinline.lsp) inline-args of a closure var which changed later, signalled a compiler error. Wed Mar 25 14:38:41 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * (read.d) make read listen to when ':' is a read macro. in read_object * (cmpfun.lsp,cmpopt.lsp): Fix optimizer for (typep x 'ratio) * (predicate.c): fix equalp so (equalp (format nil "hi") "hi") -->t Wed Mar 11 14:16:59 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * (read.d): fix failure of (read-string "#b1"). Handle eof in read_constituent Wed Feb 26 21:38:04 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * cmpfun.lsp change read-char optimizer so as to avoid a C compiler bug on dec3100, which causes an unaligned access on that machine in calls to read-char. Wed Jan 29 08:30:09 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * hp800.{h,defs} changes to run incrementally loaded text in a separate segment (at 4zillion). Without this hp will only let you run one image at a time. Unfortunately there will be a slight degradation in indirect calls (which includes all calls between user functions). Why do they need to have segments.... Thu Jan 23 17:01:37 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add some save and retore around the terminal interrupt, to prevent some possible lossage when continuing from an interrupt. You still may lose if there is a gc during an interrupt. Wed Jan 22 19:08:11 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * support for mac under AUX. Files mac2.h, mac2.defs [by weigert] * misc small changes to other files for mac. Sun Jan 5 21:35:21 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) * new definitions for fplus and fminus in cmac.c The ones for the 68020 were incorrect (since the changeover of the bignum code). These were only used by maxima. Fri Nov 22 08:39:42 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Change proclaim of function so to turn integer proclained args into type T. It is not possible to pass raw integer type since this would cause a problem with gc. Also currently it would have generated C which broke the C compilation. Tue Oct 29 07:59:02 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add misc/warn-slow.lsp. If this file is loaded, then the compiler warns of certain slow constructs, like undeclared arithmetic, and slow array references. Thu Oct 24 21:34:55 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * funlink.c to handle misproclaimed functions better. * big.c correct one source of "bad length" warning Sun Oct 20 12:55:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * gbc.c change position of where the C stack is marked from. This is relevant for sparcs with the register windows, which are dumped at interrupts. * cfun,gbc changes as per PCL mods for turbo closures. * read.d use 1000000000.0 rather than 1/ this , since it gives more accurate value in read of float. * cmpfun.lsp add hook for (typep x 'foo) so that can expand this differently according to a property of 'foo. * cmpcall.lsp, add a hook so that special code can be emitted for calls where a super_funcall_no_event would have been emitted. This code might be used where we expect closures (cf PCL) Wed Oct 9 21:31:03 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * read.d to make 0.7 and (/ 7.0 10) produce identical results. when read (at least on 68k,sparc, rios). We have left the default number of digits printed out as 17, in spite of the fact that IEE has only 15.95 significant digits. The reason is that correct rounding to 15 or 16 digits, will commonly cause things like most-positive-long-float to print in a form which is not even readable (since it is rounded up above the most-positive-long-float). Mon Oct 7 20:54:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix LD_COMMAND typo in hp800.h * fix replace_array to make the new array not live beyond the call, so that gc won't accidentally mark two copy two identical array bodies (so maybe overstepping the the new relblock) Fri Oct 4 10:58:59 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * close to work on already closed streams. * make_pure_array arg fixed (num_log.c) * estack_buf put in static area on machines like rios. Sun Sep 29 12:43:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix to relblock allocation in sgc_start * fix for paths with "~/" * change default pagesize on sun3 to 4k Sat Sep 7 13:51:24 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix bit-array-op to make correct call to si::make-array-pure (num_log.c) Mon Aug 5 18:06:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * wt-cvars add declaration for VXXalloc variables Tue Jul 30 16:48:09 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * interpreted mapcar not gc protecting when given more than 2 args. Sat Jul 27 12:32:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * changes to subtypep to make (subtypep 'cons '(and t cons)) and (subtypep 'simple-array '(not vector)) correct. Fri Jul 26 09:25:56 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * change equal and hash_equal not to descend into structures. A ruling in CLTL2, clarifies that this should be the case. * alter get-setf-method and friends to accept environment as second argument. Alter all the complex setf methods to pass the environment so that local functional and macro bindings can alter the behaviour of the setf macro. Tue Jul 23 06:25:39 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * sharing for fasd files for package operations was disabled. Otherwise the symbol in a shadow would be shared with the symbol's later occurrence in the file--It is still a good idea to put package operations in a separate lisp file at the beginning of system load. * adjustable arrays brought into conformance with changes in CLTL II. You may now adjust non adjustable arrays, and the fill-pointer argument to adjust-array does not change the property of having or not having a fill pointer for the array. Sun Jul 21 12:44:04 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix cmac.c for maxima (error in dblrem) * sloop for v on l by 'joe changed to allow for the possibility that joe is a macro. [used by maxima]. Wed Jul 10 10:45:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * littleXlsp is included which provides an interface to some simple X windows routines. It is not in the image by default See the file lsp/littleXlsp.lsp for directions. Tue Jul 9 16:29:23 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add VOL declarations for setjmps in format.c to allow to work with gcc on the sparc. * add stuff to cmplam.lsp for VOL declarations of &aux variables. Wed Jun 26 20:59:04 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Change to gc mark of c stack to make sure register windows are flushed, by calling recursively. * add special bignum code for rs 6000 and aix 370 * fix for read suppress and the defstruct reader. * Source level debugging improved (see doc/DOC and doc/dbl.el) * Catch infinite recursion of proclaimed functions. Handle segmentation faults on an alternate stack--so don't play around to much after a segmentation fault before quitting to top level. * support for hp800 (and hp700) added. Wed May 22 14:54:29 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * added new slot to struct stream, to hold the buffer. gbc.c and file.d had been referencing the field in FILE directly, but that is not reliable on att Sys V 4. Thu Apr 11 17:04:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add conc-name to the s-data structure so users may get at it (defstruct.lsp). * add install_segmentation_catcher() and also in error() (ususually arises from real segmentation faults), then turn off sgc, if it's on, to avoid having the error handler stall on trying to alter pages which are write protected (since we are still within the memprotect_handler. Thu Apr 4 08:37:50 1991 Bill Schelter (wfs at max.ma.utexas.edu) * If HAVE_YP_UNBIND is defined, added to c/main.c the unbinding of the default yp domain. In sun os 4.1 we were getting a segmentation fault in _yp_dobind_soft() on a restarted system. Sat Mar 30 09:01:57 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Fix listen and clear-input (file.d and read.d). macros LISTEN_FOR_INPUT and HAVE_IOCTL are defined in att.h, bsd.h, and for the aix systems. I have tested it under aix, sun, 4.3bsd, sgi4d and hpux. Not sure about vannilla sysv (may have to be #undef'd there). * fixed pathnames such as "~wfs/foo.lisp" to work. (see unixfsys.c). Mon Mar 25 12:25:34 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Make sure that long float arrays get allocated on multiple of sizeof(double ) alignment array.c,gbc.c.. Also unixfasl.c * Add to Smakefile an initial execution of xbin/{machine}-fixes if that file exists. Use this for correction of temporary bug fixes, such as the bad sgi4d c compiler. Mon Mar 18 12:06:26 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * The structure of bignums and the underlying code was changed completely. This affected many files including big.c,num_co.c print.d, read.d, predicate.c, num_arith.c,.. See the file doc/bignum for a discussion. The compiler was also changed to include integer as a primitive type with storage allocated on the stack. * A notion of deducing result type from argument types was added to the compiler. Initially we are just doing that for the basic integer functions, but it can be extended to others * The optimization in cmpopt.lsp have been changed to allow more flags to accommodate things like the result-type-from-args. The compiler will normally warn (for the time being) if you give it old style optimizations. Because of the extensive changes to the compiler I have changed the default safety for compiling the cmpnew directory back to 2. Thu Feb 14 16:06:42 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * debug.lsp, eval.c: fix break-step-next and break-step-into to pass the correct environment back so that evaluating variables or local functions will be done correctly in the debugger. Mon Feb 11 16:24:15 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Fixed *break-points* function to bind the correct enviroment so that variables will get the right values. Mon Jan 7 21:21:22 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) * make inline string adjustable (cmptop.lsp) * multiple changes to lsp/debug.lsp and lsp/top.lsp to allow source line debugging using si::nload. * debugger largely redone. :bt new backtrace function (:b still there). see DOC file * add xdr-open xdr-write xdr-read to the si package. * akcl 532 compatible with maxima 4-153 Wed Dec 5 01:49:50 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * check_alist should allow nil, since the CLTL allows nil in place of a cons in an alist. * many changes to debug.lsp, eval.c and top.lsp to allow source level debugging. The emacs file dbl.el was added. It and the DOC file contain more information, but basically there is automatic source display when broken in the debugger (for lisp files loaded with nload). Tue Nov 20 20:07:02 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Changes to all places where function assignments are made to allow the hook compiler-def-hook, to be run. This hook is used by the new source code debugger dbl. * dbl allows debugging of lisp code with a display of an arrow in the window opposite the line currently broken at or being executed. * The safety on the cmpnew files has been changed to safety 0. Please notify of any places where this causes a problem! It should result in significantly faster compilation. The error checks should be in the source. Thu Nov 8 05:31:34 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix aix3_mprotect/mprotect.c [wrong calculation of overflow] * fix memory_protect in sgbc.c Wed Nov 7 09:56:30 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Change compiler-clear-compiler-properties, to take 2 args. This is to provide compiler-def-hook, which lets you get the code just before it is installed. * Misc support for IBM 370 mainframe running under AIX. (u370) * change malloc at startup to use some static space, since the gc may not be initialized before some startup routines need to malloc (aix3). * fix to cmptag.lsp. Tags in cross closure tagobdies were sometimes not being written out. (bug had been there forever). C compiler would fail when the tag was not there. Fri Oct 26 15:00:37 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * change call_proc, the routine used to link proclaimed functions. It was not incrementing vs_top soon enough, so that with args (t t fixnum), with fast links off, the make_fixnum caused by the last arg, might cause a gc which zeroed the vs stack above vs_top, so eliminating arg1. Symptom was an passed as second arg. This could only happen when functions were proclaimed, and had type not = t. Sat Oct 6 08:08:47 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * change assoc in list.d so (assoc nil '(nil (nil . a))) --> (nil . a) also change cmpfun.lsp in the compiler for this. (bug rep mccain) * Allow #' in the (:print-function #'(lambda (..)) defstruct option (bug report baxter) Thu Sep 20 19:05:05 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Fix cmpthrow in cmpcatch.lsp so that handles lexical closures correctly. * Fix cmpeval.lsp for incrementing a structure slot which is fixnum. * Fix cmpmain.lsp adding support for the floating point save ops on rios. Sun Sep 2 16:44:24 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Fix perm_writable. It was leaving out the last page! (Vignaux) Mon Aug 20 15:15:03 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix acos and asin in numlib.lsp (bug was (acos .5) was complex!) Wed Aug 15 14:01:06 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * to fasdump.c: close_fasd was munging the array handed to it to cleanup. This could cause gc problems later. * Several changes to gc. The alloc_relblock function fixed to take into acount that rb_start - heap_end may not be holepage anymore [since if sgc_enabled we have a second `sgc' rb_start after the first]. We ensure that nrbpage is actually the combined number of pages for relblock, for sgc and regular gc. (alloc.c) Tue Aug 14 16:04:19 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * changes to sgc to the way memory protection is turned on. * There may be problems with saving an image with (sgc-on t) These have not been resolved, at least under rios, and perhaps other machines. * many changes for aix 3, for rios * for sgi, change the Init_links to come before doinit * the sgi4d does not need the links stuff. Wed Aug 8 21:59:37 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Change to h/secondary_sun_magic to make it have 8 characters. * fix use-package so that allows using a package with an external symbol, if that symbol is shadowed by the current package. * Several fixes for sun os 4.1 (secondary magic stuff). Wed May 23 11:47:34 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Make traced functions stay traced after redefinition [change clear_compiler_properties, and its many callers] * Fix two bugs introduced in trace.lsp when its functionality was increased. * fasdump.c (fix coercion). Thu Apr 12 15:28:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Change behaviour of proclaimed, compiled keyword argument functions, so that duplicate keys are allowed, and the leftmost takes precedence. [bind.c:parse_key_new] Mon Apr 9 14:48:43 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * make subtypep (predlib.lsp) handle types of form '(not p) correctly. This in turn influences compiler optimizer handling of (typep x '(not p)) * fix read (read.d) so that it allows eof to occur during reading of a semicolon comment line. * fix c1values (cmpmulti.lsp) so that (values (truncate a b)) does just return one value. Sun Apr 1 22:11:46 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * make float-digits and float-precision return the significant digits in terms of float-radix. * If si::*print-nans* is not nil, then the C printing of Nan's and infinity surrounded by #< > will be used. Fri Mar 30 10:24:35 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * gbc.c, sgbc.c: displaced arrays have been a real headache. (dotimes (i 5000) (make-array 1 :element-type 'string-char :displaced-to (format nil "0"))) would cause bad things to happen in kcl and akcl. I finally decided that the link between an array and the array it is displaced to should be made firm. If A is displaced to B, the user can always do adjust-array on A to destroy the displacement. But from now on, as long as the displacement exists then if B is marked this will cause marking of A, and vice versa. Wed Mar 28 16:41:17 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * cmpeval.lsp co1structure-predicate: (defstruct foo a b ..) then foo-p was less efficient than it had been in some earlier release. Note:after (si::freeze-defstruct 'foo) you get the fastest foo-p, since this declares the hierarchy of structures including foo to be frozen. Wed Mar 7 13:30:57 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fixed copying of relblock in gc, so that if an array body is allocated on C stack [the read_fasd does this for a temp array it needs] then this array will not be copied. In some cases this could have caused the copied relblock to exceed nrbpage size, which is all that sbrk had provided. * read-fasd could not be recursively entered from the lisp_eval calls which were possible [from things like require or other package ops]. Fixed in fasdump.c Mon Mar 5 11:54:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Increase BDSGETA to allow some freedom in the debugger after a bds overflow. Tue Feb 27 09:19:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * fix printing NIL relative to a package not using LISP. Tue Feb 20 00:10:58 1990 Bill Schelter (wfs at fireant.ma.utexas.edu) * Add compiler::*split-files*, to allow convenient splittling of large lisp files, for C compilers which can't handle infinitely long C files. See doc/DOC file. * Fix to fasdump.c. Broke when a .o file was loaded during compilation. Fri Feb 16 09:11:08 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * si::*load-pathname* is now bound to the pathname of the current file being loaded. Sat Feb 10 13:36:44 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Add the co1special prop check in c1symbol-fun, for fixing macros which expand into declares in do, do*, prog, prog* (see also cmpfun.lsp) * Fix level in c2call-local (bug report by harris). Tue Jan 23 18:37:58 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * change to siLreplace_array, so that the first word of the old array header is preserved, so that in case sgc is on, the array won't be marked SGC_RECENT, and so garbage collected if there were no pointers to it. Sun Jan 21 20:30:48 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Many changes to the compiler: Only defuns and defmacros are compiled by default. A flag compiler::*compile-ordinaries* if t means all forms will be compiled (use this for pcl at the moment). See doc under compile-file. * eval-when default behaviour changed to be in line with the X3j13 CL standard. See compile-file doc. files: fasdump.c,cmpaux.c,cfun.c, cmptop, cmpwt,cmpenv, cmpspecial, cmpflet. * some advantages of the new init scheme. Some files can be substantially smaller, and there is more flexibility in writing out the init. Things like closures which are constant, can be set in as constants. Thu Jan 4 23:24:46 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) * make sublis for eql equal and eq be substantially more efficient. [list.d, and cmpfun.lsp] * fix file_exists for AIX (stat returns 0 there even if file ending in slash is not a directory (ie /u/all/bmt/.login/ would have existed. * make boolean be a real type, so that we can distinguish between calls to a function which want only a boolean reply or calls which need more. An example is probe-file which can be 30 times faster when only a boolean reply is needed, not the truename. This required changes to cmptype,cmpif cmpinline. * add additional optimizations to cmpopt.lsp. * fix vector-push-extend optimization [cmpfun, cmpopt] * various fixes to sgc Sat Dec 23 18:30:03 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Fix multiple-value-prog1 in cmpmulti.lsp (eval-when (compile) (proclaim '(function foo (t t) t))) (defun jil () (multiple-value-prog1 (values 1 2) (foo 3 4))) (defun foo (a b) (joe a b) (cons a b)) (defun joe (a b) (list a b)) would have (jil) --> 3 4 until this fix. This dates from original kcl. Tue Dec 5 20:22:58 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * changes to alloc.c, gbc.c, page.h, object.h to allow stratified garbage collection [SGC]. This should help systems with a large amount of relatively static data. Only pages written to since sgc-on need be marked and swept. See DOC file. Sat Nov 11 07:08:27 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Add various va_end(ap)'s to match unmatched va_start's. * add in some changes for hp300's faslink. * add additional support for cmpnew/collectfn.lsp See the documentation in the DOC file for emit-fn and friends. Basically it is for getting proclamation info, who-calls info, undefined info, from a pass of the compiler on a system. * add additional undefined warnings for undefined lisp package functions in addition to the list-undefined-functions. Tue Oct 31 06:02:18 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add support of Iris 4d machine. * Fix COERCE_VA_LIST for non standard machines, to take the argument n. * Make sure defun, defmacro,.. clear the accessor property for defstruct slots. Sat Oct 28 11:06:25 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * remove an abort() from rel_sun4.c. This type of relocation now occurs, and our method has been tested. Fri Oct 27 23:01:42 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * if the *system-directory* directory contains the file sys-init.lsp then this file will be loaded at startup. This facility is used for printing the warning message at startup, but can be used for local modifications. Also by having two system directories [via links and different commands] different startups could be loaded. All this is in addition to the regular init.lsp. The purpose of this is to allow patches to be loaded, without requiring a resaving of the image. [Recall the system directory is the first argument to invoking a saved_kcl, or the first part of the pathname if there is not a first arg Typically it is the unixport directory if you use the xbin/kcl command] Tue Oct 24 20:23:56 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * Add packlib to the unixport/boots file so that help* gets compiled using the new do-symbols macro. * Add alternate malloc.c file from gnu emacs, if you define GNU_MALLOC. This runs much faster (15X) if you are incorporating lots of C code with mallocs. Thu Oct 19 21:28:25 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) * add si::fwrite and si::fread for doing io on file streams. * Eliminate the need for the separate compiler file cmpinclude.h This means that only one file is now needed for an executable, and there won't be confusion over which cmpinclude.h goes with which version. We store the file as a string, and write it into the c files as they are compiled [if *cmpinclude-string* is a string and :system-p t is not given to compile]. The time difference for doing the extra write is not measurable, even with tiny compiles. Wed Oct 4 23:41:17 1989 Bill Schelter (wfs at rascal) * co1eql was causing a double evaluation in some special circumstances. Mon Oct 2 08:48:30 1989 Bill Schelter (wfs at rascal) * Many changes to the compiler to support &optional, &rest &key args to be passed on the C stack. This is still limited to functions proclaimed to return one value. * Allow user to grow the stacks from top level [see *multiply-stacks* doc] * Code for making proclamation files and collecting cross referencing data in cmpnew/collectfn.lisp. This is to allow a second compile of a system to take advantage of information obtained in the first compile. * catch-fatal added. * read.d float read fixed for little endian machines. * do,prog,prog* and do* compilation fixed so that declare's at the beginnning of the bodies which are hidden by macros, are detected and processed. * :dynamic-extent declaration recognized to allow &rest * proclaimed functions with one return value, will now be compiled to use the C stack even if they have more than 10 args. Tue Sep 5 22:15:23 1989 Bill Schelter (wfs at rascal) * Change add-function-proclamation to be more efficient when handed long lists of proclaims. Maxima for example generates 3871 proclaims of functions. This now takes 4 seconds instead of 2 minutes. Mon Sep 4 00:25:29 1989 Bill Schelter (wfs at rascal) * cfun_to_combined fixed for t_sfun,t_gfun. * ihs_function_name fixed for t_sfun,t_gfun Mainly used in error handling and printing. * compiled-function-name fixed to handle t_sfun,t_gfun [this is used in the error handler] Thu Aug 31 09:57:09 1989 Bill Schelter (wfs at rascal) * fix reduce in seqlib.lsp. Wed Aug 30 16:44:05 1989 Bill Schelter (wfs at rascal) * change cmpeval.lsp,cmploc.lsp to make small fixnums write out without the indirection through VV ---------Version 206------------- Mon Aug 28 13:44:49 1989 Bill Schelter (wfs at rascal) * cmptag.lsp:add-reg changed to handle dotted list case * Added new types t_sfun, t_gfun of compiled function objects to save space and speed funcall. See doc/funcall for details. Many c files changed as well as compiler. * cmpeval.lsp: made #, have the c1special property, instead of c1, so these will compile properly on safety 3 * add si::set-mv, si::mv-ref, to allow people to implement faster version of multiple values. Someday this way will be the default [see doc/multiple-values and lsp/fast-mv.lisp] Thu Aug 10 11:51:05 1989 Bill Schelter (wfs at rascal) * Fixed prev fix to print in print.d so that ok if stream = t. Mon Aug 7 10:19:11 1989 Bill Schelter (wfs at rascal) * Support for HP300bsd (bsd from mt xinu) added. * print fixed to add space after printing. * describe modified to print more information on structures Fri Jul 28 09:18:15 1989 Bill Schelter (wfs at rascal) * trace.lsp Add keyword args allowing special entry, exit, conditional and other handling of traced forms. You can for example specially print args, or break if args or values are inappropriate. See file doc/trace. * c1decl-body: recognize safety level on first pass. Sat Jul 8 15:21:42 1989 Bill Schelter (wfs at rascal) * defstruct.lsp and read.d: Fix patch_sharp to handle structures, and sharp-s-reader to do its reads recursively. Allows constructs such as #1=#S(joe a #1#) to work. Fri Jul 7 13:40:45 1989 Bill Schelter (wfs at rascal) * make sure the co1 properties are cleared when functions are defined. Mon Jul 3 15:05:51 1989 Bill Schelter (wfs at rascal) * Fix sharp-s-reader in defstruct.lsp and remove it from iolib.lsp * remove =* and =- from gbc.c package.d * fix c1value to behave correctly when one value supplied in cmpmulti.lsp * change #. and #, to interact correctly when called after #+ or #- Fri Jun 2 20:48:06 1989 Bill Schelter (wfs at rascal) * sfasl.c gbc.c change error messages from using stderr to stdout. Note the first file descriptor the user opens is typically stderr, so these error messages (which rarely occurred) did not appear on the screen but rather caused resetting the file pointer of the user's stream! Wed May 31 20:31:04 1989 Bill Schelter (wfs at rascal) * package.d,symbol.d, packlib.lsp: Changes to package hashing and intern. Allow flexibly sized packages instead of insisting that all internal and external packages use table with 512 elts. I recommend a prime number as size. The size of the internals table is automatically grown when there are 2 x as many symbols as the table size. For the byte-reader.im-test file (580K) the read time went from 24 seconds to 16.8 seconds. (had been 53 seconds). in-package and make-package take keyword args :external and :internal to allow specification of the size of the table for a new package. Tue May 30 23:00:46 1989 Bill Schelter (wfs at rascal) * fix writing of small and large double floats in cmpeval.lsp, so that all numbers from smallest double to largest may be included as constants in compiled code. Sun May 28 16:22:07 1989 Bill Schelter (wfs at rascal) * array.c:array_allocself takes an additional argument, specifying the default value, or NULL if no initial value is to be given. si::make-vector has an additional optional arg of the default value. * seqlib also has calls to array_allocself, which take a 0 final arg, indicating that the initialization is not to be done. * array.c: siLcopy_array_portion added, to allow quick copying from one array to another. * In top.lsp the *eof* is changed to a local, so as not to conflict with the si::*eof* which is the value returned by the system when doing getc. g Fri May 12 10:57:39 1989 Bill Schelter (wfs at rascal) * Add optimization for (type x 'foo) where foo is a structure. This also affects foo-p. If you (setq compiler::*frozen-defstructs* t) this allows the compiler to assume that a given defstruct will not be extended (by including it in more structures) by new defstructs loaded in later files. This can significantly speed up type checking. Thu May 11 07:43:52 1989 Bill Schelter (wfs at rascal) * Fix omission of the extended mul for sun4 in 1.22 Now a new dependent feature EMUL lets you specify an assembler file in the o directory, which will be loaded in at the end. * AKCL added to the *features* list. This is now necessary because of internal differences in structures between the standard kcl and akcl. Structure changes are pretty well complete. Wed May 3 12:11:54 1989 Bill Schelter (wfs at rascal) * Fix ceiling and floor (num_co.c) by riley Mon May 1 08:05:55 1989 Bill Schelter (wfs at rascal) * fix to gc of displaced arrays. (bug report and partial fix by riley). Files gbc.c array.c undisplace was referrring to possibly freed list structure. * Structures are being completely reworked. There are two reasons: To use much less overhead at compile time of the original defstruct. To allow raw types in defstructs, and allow packing of these. For example a slot (x 0 :type (mod 50)) will only require 1 byte. These structs may be made to coincide with C structs more closely. All ptr or full fixnum fields will be aligned on a multiple of the size of ptr however for speed of reference and portability. Needless to say recompilation is necessary for most files. System files affected gbc.c, defstruct.c, predicate.c, print.d defstruct.lsp cmpfun.lsp cmputil.lsp cmpeval.lsp predlib.lsp and maybe some other small changes. Naturally significant speedups will be gained if one can keep integers in raw form: (defstruct ja1 (a #\a :type character)(b 0 :type fixnum)) (defun joe (x n) (sloop::sloop for i below n do (setf (ja1-b x) i))) Then (joe (make-ja1) 1000000) takes less than 1 second now, as opposed to over 50 seconds prior to these changes. Wed Apr 26 11:59:43 1989 Bill Schelter (wfs at rascal) * Add message feature for AKCL start up. If unixport/message exists and unixport/message-suppress does not, then the file unixport/message will be printed on start up. (top.lsp) * make o/akcllib.a, a library containing bcmp .. and other common functions which are not present in all versions of unix. The main link puts this after -lc, so that faster implementation dependent versions will be used if they exist. Mon Apr 24 20:28:49 1989 Bill Schelter (wfs at rascal) * Change to eliminate char_table.s assembler code. This change will unfortunately require users to recompile their object code for use with this system. * Fix bug in cmpinline.lsp, which was allowing (rplacd (cons a b) nil) to give the wrong code. * Add timing for gc, and allow have the si::*notify-gbc* flag cause printing the type of gc. To time gc's. do (si::gbc-time 0), to set the timer to 0, (si::gbc-time -1) to reset and turn it off. It returns an integer in internal time units, similar to get-internal-run-time. * Speed up the lisp reader and intern. On a large file the read is 2.4 times faster than it was. * Many small changes to the include files, to eliminate duplicate definitions of symbols, (not allowed by some compilers) and also adding COMM_LENG, which can be null for most compilers but should be a small integer for the IBM c compiler (it does not accept external declarations int foo[], so we do foo[COMM_LENG]; Fri Apr 21 18:13:23 1989 Bill Schelter (wfs at rascal) * Fix bug with the new fast read-byte,.... If the stream argument was supplied, and was not a stream but rather T or NIL, there was a problem. If you declare the arg to be of type stream, then you will get identical code to before; otherwise a typecheck for type stream will be supplied, branching into the slower code for non streams. Files cmpopt.lsp and cmptype.lsp Tue Apr 18 22:56:54 1989 Bill Schelter (wfs at rascal) * More changes to read-byte, write-byte, read-char and write-char. I have removed the :in-file and :out-file declarations, and the speed up for the undeclared streams should be virtually the same as obtained with the declarations. This will affect mainly file streams. Files cmpfun.lsp, cmpopt.lsp, cmpinclude.h, read.d Note that on read-byte it is still advantageous to use an eof which is a fixnum. reads where the eof-error-p arg is not nil are not speeded up. It is still the case that two way streams are not speeded up, however if (si::fp-input-stream str) returns non nil, then you can use the resulting stream for fast input. Thu Apr 13 00:20:11 1989 Bill Schelter (wfs at rascal) * fixes to subtypep (as reported by riley) * changes to allow faster operation of read-char,write-char, read-byte and write-byte, when operating on file streams. In order to use these you should declare the stream to be :in-file or :out-file. You can use (typep str :in-file) to check if it is really valid. (defun myread (str) (declare (:in-file str)) (the fixnum (read-byte str nil -100))) The above changes should work for ansi C style stdio, in particular for unix io. At the moment it is conditionalized for +unix. files: cmpfun.lsp, cmpopt.lsp, cmtype.lsp, file.d, cmpenv.lsp The difference in reading speed is substantial: eg 3 microseconds as opposed to 60 microseconds for read-byte. To make your code portable do (proclaim '(declaration :in-file)) In order for the optimizations to cut in, the read functions must be supplied with 3 args and the write functions with 2. The second of the read args must be nil. Note with read-byte, using an eof value which is a fixnum, allows you to declare the location you will pass to as a fixnum. Wed Mar 22 17:19:03 1989 Bill Schelter (wfs at rascal) * Change c1fmla-constant in cmpif.lsp. (if (null 2) x y ) was yielding x not y! Sun Mar 19 12:26:21 1989 Bill Schelter (wfs at rascal) * fix stream_at_end, so that a stream opened for `io' does the check, when reading, so that read can return eof properly. Sun Mar 12 01:40:53 1989 Bill Schelter (wfs at rascal) * speed up the intern of symbol in pack_hash computation. * psetf bug in case of two args (psetf a 3) not passing the environment. setf.lsp Fri Feb 24 22:27:22 1989 Bill Schelter (wfs at rascal) * add fixes for &environment to allow it to come anywhere in the lambda list. defmacro.lsp and cmplam (change from R. Harris). Wed Feb 22 17:24:30 1989 Bill Schelter (wfs at rascal) * fix tree-equal to save the previous test in list.d (assoc '(c) '((a b) ((c) d)) :test #'tree-equal) failed. (by Cooperman) Sun Feb 19 17:42:31 1989 Bill Schelter (wfs at rascal) * Fix hash_equal in hash.d. It was broken for circular structures or lists. This would affect sxhash as well as equal hash tables. * Fix obscure bug in compiler in cmptop.lsp, which could possibly leave out a sup declaration. The c compiler would catch this. * Fix comparison of arrays under equalp in c/predicate.c It had been broken for rank different from 1. * Fix the assembler for the sun4 in sun4_chtab.s for multiply. (bug report by Harris). Fri Dec 9 00:47:46 1988 Bill Schelter (wfs at rascal) * Made changes to sfasl to make it more portable. * added structures and characters to the types handled by fasdump.c * changed the c stack check in gbc.c to use cs_check. Sun Nov 27 12:31:13 1988 Bill Schelter (wfs at rascal) * Add si::fp-input-stream, si::fp-output-stream, Which take one arg a stream, and return a stream with an strm->sm.sm_fp slot suitable for use with fread and fwrite. If this is not possible nil is returned. Wed Nov 2 16:09:17 1988 Bill Schelter (wfs at rascal) * inline-args fix: (defun x (c s i) (declare (optimize (safety 2))) (declare (fixnum i)) (setf (char s (setq i (1+ i))) c)) made c, not just i a fixnum in the char compilation, fixed in inline-args (by E. Wang) edward@ucbarpa.Berkeley.EDU file cmpinline.lsp Wed Oct 12 17:01:06 1988 Bill Schelter (wfs at rascal) * Added new array types: files cmptype,array.c,typespec.c,cmpopt, predlib.lsp, gbc.c, and maybe some others. Purpose of the change was to allow programs like CLX which use lots of numerical arrays, to be much more economical. Also make-array now coerces the element-type in a reasonable way, and the same handling is used in the compiler. New array element types: signed-char, unsigned-char, signed-short, unsigned-short The ranges on a SUN are ((INTEGER -128 127) (INTEGER 0 255) (INTEGER -32768 32767) (INTEGER 0 65535)) respectively. Note that now make-array will always try to find the `best' array to accommodate the element-type specified. For example on a SUN (mod 1) --> bit (integer 0 10) --> unsigned-char (integer -3 10) --> signed-char si::best-array-element-type is the function doing this. It is also used by the compiler, for coercing array element types. If you are going to declare an array you should use the same element type as was used in making it. eg (setq my-array (make-array 4 :element-type '(integer 0 10))) (the (array (integer 0 10)) my-array) .. When wanting to optimize you need to make a reference: (the fixnum (aref (the (array (integer -3 10)) ar) (the fixnum i))) if ar were constructed using the (integer -3 10) element-type. You could of course used signed-char, but since the ranges may be implementation dependent it is better to use -3 10 range. make-array needs to do some calculation with the element-type if you don't provide a primitive data-type. One way of doing this in a machine independent fashion: (defvar *my-elt-type* #. (array-element-type (make-array 1 :element-type '(integer -3 10)))) Then calls to (make-array n :element-type *my-elt-type*) will not have to go through a type inclusion computation. Tue Oct 11 09:52:13 1988 Bill Schelter (wfs at rascal) * When using gcc, it could happen that there was a string in in the init function, which got placed before the init function. Had to add -fwritable-strings to stop this. Sun Oct 2 13:35:11 1988 Bill Schelter (wfs at rascal) * Fix MP386 and att port bugs, introduced with the new mp386.h, att.h and mp386.defs files. * Fix unixtime at least for bsd, so that get-internal-real-time does not wrap every few hours, but will not wrap below 400 days. * Fix directory problems with compiling in other than the current directory, in the name of the file specified in the include. The command on most systems cd 's to the directory to run the cc, and so the .h file needed to use an unprefixed name. Sat Sep 24 16:02:22 1988 Bill Schelter (wfs at rascal) * Changes to the computation of double-float-epsilon and more generally XX-epsilon. First they did not satisfy the condition of (defun fo (e) (not (= (float 1 e) (+ (float 1 e) e)))) (fo double-float-epsilon) --> t as per CLtL. As it stands they at least satisfy the test, although there may be floats slightly smaller which also do. Second on some machines (eg HP) the calculation done in line, carried more precision than that which would be normal when passed through eql, so that we changed the test == in constructing the double float epsilon to use a function call. Otherwise the epsilon was ~10^-20 instead of the correct ~10^-16. Thu Sep 22 14:08:07 1988 Bill Schelter (wfs at rascal) * Fixed hash_equal not to use the cast to int, in computing hash of a symbol name since this made sun4's unhappy (file hash.d ). Wed Sep 14 12:02:35 1988 Bill Schelter (wfs at rascal) * fix to setf to make sure that (defmacro joe (x) `(progn t (car ,x))) (defsetf joe rplaca) work correctly. files changed are assignment.c and setf.lsp The defsetf'd definition takes precedence in the macroexpansion. The bad order was introduced when the evaluation of the macros including their environments was introduced (see below). Mon Sep 12 10:09:56 1988 Bill Schelter (wfs at rascal) * use varargs.h for bind.c and list.d where variable length args are passed. We only use va_arg(ap,object) to access the next arg now. There are no more indexed references, since that is less portable. * A major change for porting: Each machine type now has a .h file of its own, and things like alloc.c, main.c, unixsave.c no longer should be modified for individual machines. The file config.h is a link from `your-machine`.h and things like the VSSIZE, are also specified in that file. There are also files such as bsd.h , att.h (for system V) which can be included by the various special machine files. * c support for extended_div was added, and will be used if USE_C_EXTENDED_DIV is defined. The only function which does not have a C definition on the sun4 version is extended_mul. Note that the c version of extended_div is included in big.c rather than earith.c since the latter is not compiled with the optimize switch. * The assembler functions of bitop.c had been being redefined by macros in gbc.c in an earlier change (this was actually 4 times faster on a sun3), and now those functions have dummy definitions, which will go away soon. Wed Aug 31 23:38:08 1988 Bill Schelter (wfs at rascal) * use varargs for the funlink of proclaimed functions, This affects cmpcall.lsp, funlink.c and requires to be included by cmpinclude. The old variable arg business was not portable to risc architectures, where args are passed in registers. * make print return a value in print.d Hope there are not more `implicit returns' hidden away. Fri Aug 19 15:13:06 1988 Bill Schelter (wfs at rascal) * Make (subtypep 'string-char 'character) --> t Wed Aug 3 11:33:20 1988 Bill Schelter (wfs at rascal) * I have removed the dynamic growing of the special binding stack which I had added a few months ago (cf bds.h,main.c,bds.c.) It had ignored the fact that some functions eg, Levalhook grab a pointer into the bds rather than just an index. These could easily have been changed, but until we allow the other stacks to grow dynamically, it is of questionable value. Fri Jul 1 09:41:36 1988 Bill Schelter (wfs at rascal) * allow assoc to take key in c/list.d as per mail 442 23-Jun pc%linus@mitre-bedford.ar KCL Bug: assoc doesn't take :key Wed Jun 15 16:46:40 1988 Bill Schelter (wfs at rascal) * Added support for switch construct (see cmpnew/cmptag.lsp for documentation) This will allow compiling into the c switch construct if (the test variable is declared to be a subtype of fixnum) which can then allow much faster switching on cases. To do:Should optimize some of case constructs into switch, where applicable. Wed Jun 8 11:43:00 1988 Bill Schelter (wfs at rascal) * Altered the marking of the c stack in gbc.c. Now the current location for the c stack is taken in a separate function from the one where the environment is forced onto the stack, so that we don't have to depend on the c compilers doing things in the expected order. See mark_stack_carefully. Also added a flag C_GC_OFFSET which if defined to 2, will mark the stack twice once on 4m and once on 4m+2. * changed the initialization in main.c of bds_org and bds_limit. This is to fit in with the earlier change to bds_overflow, to allow the bds to grow. bds_org is now a pointer rather than a hardwired value. Tue Jun 7 04:44:15 1988 Bill Schelter (wfs at rascal) * Fix equalp to use the fill-pointer as a limit when comparing strings,vectors and bitvectors. Mon Jun 6 11:29:08 1988 Bill Schelter (wfs at rascal) * Fix rotatef in setf.lsp to return NIL per CLtL * Fix handling of &rest arg in cmplam.lsp c2lambda-expr-without-key as per bug fix of Yuasa 12-Nov yuasa%kurims.kurims.kyoto A bug fix * Add the fix to quick-sort as per 67 12-Jan yuasa%tutics.tut.junet%ut Re: sort bug * Add fix for shadowing-import per 68 12-Jan yuasa%tutics.tut.junet%ut Re: SHADOWING-IMPORT doesn't * Fix (random 0) bug, adding TSpositive_number type. as per 69 12-Jan yuasa%.. Re: (random 0) => losing error message * Fix (make-array 2 0) bug per 70 13-Jan yuasa%tutics.tut.junet%ut Re: Nil is a sequence * Add bogus value (*READ-DEFAULT-FLOAT-FORMAT* t) when printing a float in a compiled file, so that it will always add the type in the printing, and we won't get a float type different from that used at compile time cf. 80 28-Jan yuasa%tutics.tut.junet%ut Re: float numbers * Add fix for bug setf (aref x (decf i)) (aref x 1)) -> "base[2]= aset1(base[0],V1,fix(base[1]));" to cmpinline.lsp, as per 92 8-Feb yuasa%tutics.tut.junet%ut Re: compiler bug? *All fixes by yuasa in the kcl-mail-archive thru Jun 88 are now incorporated in akcl * Altered cmp-macroexpand-1 to use the local macro environment Wed Jun 1 13:29:57 1988 Bill Schelter (wfs at rascal) * Altered macros.c to pass the function-macro environment if it is non nil. This is needed so that macro expansion functions can be called in the correct environment. Altered cmputil.lsp so that cmp-macroexpand and cmp-macro-expand both use the current compiler macro environment. Finally altered setf, so that it looks at the macro environment when it expands the place. Deleted treatment of setf as special form by the compiler, (introduced yesterday!) now that macros are handled correctly, and it is defined correctly as a macro. Things like (macrolet ((ab nil 'a)) (setf (the fixnum (ab)) 3)) Now work to give (set 'a (the fixnum 3)) as expected. Mon May 30 11:40:47 1988 Bill Schelter (wfs at rascal) * Altered setf to macroexpand the place in the current lexical environment so that (macrolet ((joe nil 'bil))(setf (joe) n)) would behave correctly. This change was in assignment.c in `setf' and also in cmputils.lsp adding c1setf, to get analagous treatment for compiler. To do: It is still not totally correct: I don't handle (macrolet ((joe nil 'bil))(setf (the fixnum (joe)) n)) but (macrolet ((joe nil '(the fixnum bil)))(setf (joe) n)) is ok. Tue May 24 09:38:58 1988 Bill Schelter (wfs at rascal) * Changed float to return single-float if given only one arg, as per CLtL. * Added a dynamic growth feature the bds stack, changing bds_org to be a variable rather than a macro, and altering bds_overflow. *Enforce substantial constraints on downward closures ,to be relaxed at a future date: Currently no args, and no cross references to other types of closures. This is done in check-downward in t1defun. gcl-2.6.14/o/format.c0000755000175000017500000014013414360276512012673 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* format.c */ #include "include.h" static int fmt_thousand(int,int,bool,bool,int); static void fmt_exponent1(int); static void fmt_write_numeral(int,int); static void fmt_write_ordinal(int,int); static int fmt_nonillion(int,int,bool,bool,int); static void fmt_roman(int,int,int,int,int); static void fmt_integer(object,bool,bool,int,int,int,int); static void fmt_semicolon(bool,bool); static void fmt_up_and_out(bool,bool); static void fmt_justification(volatile bool,bool); static void fmt_iteration(bool,bool); static void fmt_conditional(bool,bool); static void fmt_case(bool,bool); static void fmt_indirection(bool,bool); static void fmt_asterisk(bool,bool); static void fmt_tabulate(bool,bool); static void fmt_newline(bool,bool); static void fmt_tilde(bool,bool); static void fmt_bar(bool,bool); static void fmt_ampersand(bool,bool); static void fmt_percent(bool,bool); static void fmt_dollars_float(bool,bool); static void fmt_general_float(bool,bool); static void fmt_exponential_float(bool,bool); static void fmt_fix_float(bool,bool); static void fmt_character(bool,bool); static void fmt_plural(bool,bool); static void fmt_radix(bool,bool); static void fmt_hexadecimal(bool,bool); static void fmt_octal(bool,bool); static void fmt_binary(bool,bool); static void fmt_error(char *); static void fmt_ascii(bool, bool); static void fmt_S_expression(bool, bool); static void fmt_decimal(bool, bool); object sSAindent_formatted_outputA; #define ctl_string (fmt_string->st.st_self + ctl_origin) #define fmt_old VOL object old_fmt_stream; \ VOL int old_ctl_origin; \ VOL int old_ctl_index; \ VOL int old_ctl_end; \ object * VOL old_fmt_base; \ VOL int old_fmt_index; \ VOL int old_fmt_end; \ jmp_bufp VOL old_fmt_jmp_bufp; \ VOL int old_fmt_indents; \ VOL object old_fmt_string ; \ VOL format_parameter *old_fmt_paramp #define fmt_save old_fmt_stream = fmt_stream; \ old_ctl_origin = ctl_origin; \ old_ctl_index = ctl_index; \ old_ctl_end = ctl_end; \ old_fmt_base = fmt_base; \ old_fmt_index = fmt_index; \ old_fmt_end = fmt_end; \ old_fmt_jmp_bufp = fmt_jmp_bufp; \ old_fmt_indents = fmt_indents; \ old_fmt_string = fmt_string ; \ old_fmt_paramp = fmt_paramp #define fmt_restore fmt_stream = old_fmt_stream; \ ctl_origin = old_ctl_origin; \ ctl_index = old_ctl_index; \ ctl_end = old_ctl_end; \ fmt_base = old_fmt_base; \ fmt_index = old_fmt_index; \ fmt_end = old_fmt_end; \ fmt_jmp_bufp = old_fmt_jmp_bufp; \ fmt_indents = old_fmt_indents; \ fmt_string = old_fmt_string ; \ fmt_paramp = old_fmt_paramp #define fmt_old1 VOL object old_fmt_stream; \ VOL int old_ctl_origin; \ VOL int old_ctl_index; \ VOL int old_ctl_end; \ jmp_bufp VOL old_fmt_jmp_bufp; \ VOL int old_fmt_indents; \ VOL object old_fmt_string ; \ VOL format_parameter *old_fmt_paramp #define fmt_save1 old_fmt_stream = fmt_stream; \ old_ctl_origin = ctl_origin; \ old_ctl_index = ctl_index; \ old_ctl_end = ctl_end; \ old_fmt_jmp_bufp = fmt_jmp_bufp; \ old_fmt_indents = fmt_indents; \ old_fmt_string = fmt_string ; \ old_fmt_paramp = fmt_paramp #define fmt_restore1 fmt_stream = old_fmt_stream; \ ctl_origin = old_ctl_origin; \ ctl_index = old_ctl_index; \ ctl_end = old_ctl_end; \ fmt_jmp_bufp = old_fmt_jmp_bufp; \ fmt_indents = old_fmt_indents; \ fmt_string = old_fmt_string ; \ fmt_paramp = old_fmt_paramp typedef struct { int fmt_param_type; int fmt_param_value; } format_parameter; format_parameter fmt_param[100]; VOL format_parameter *fmt_paramp; #define FMT_PARAM (fmt_paramp) #ifndef WRITEC_NEWLINE #define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) #endif object fmt_temporary_stream; object fmt_temporary_string; int fmt_nparam; enum fmt_types { fmt_null, fmt_int, fmt_char}; char *fmt_big_numeral[] = { "thousand", "million", "billion", "trillion", "quadrillion", "quintillion", "sextillion", "septillion", "octillion" }; char *fmt_numeral[] = { "zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen", "zero", "ten", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety" }; char *fmt_ordinal[] = { "zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth", "zeroth", "tenth", "twentieth", "thirtieth", "fortieth", "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" }; int fmt_spare_spaces; int fmt_line_length; static int fmt_tempstr(int s) { return(fmt_temporary_string->st.st_self[s]); } static int ctl_advance(void) { if (ctl_index >= ctl_end) fmt_error("unexpected end of control string"); return(ctl_string[ctl_index++]); } static object fmt_advance(void) { if (fmt_index >= fmt_end) fmt_error("arguments exhausted"); return(fmt_base[fmt_index++]); } static void format(object fmt_stream0, int ctl_origin0, int ctl_end0) { int c, i, n; bool colon, atsign; object x; fmt_paramp = fmt_param; /* could eliminate the no interrupt if made the temporary stream on the stack... */ {BEGIN_NO_INTERRUPT; fmt_stream = fmt_stream0; ctl_origin = ctl_origin0; ctl_index = 0; ctl_end = ctl_end0; LOOP: if (ctl_index >= ctl_end) { END_NO_INTERRUPT; return;} if ((c = ctl_advance()) != '~') { writec_stream(c, fmt_stream); goto LOOP; } n = 0; for (;;) { switch (c = ctl_advance()) { case ',': fmt_param[n].fmt_param_type = fmt_null; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': DIGIT: i = 0; do { i = i*10 + (c - '0'); c = ctl_advance(); } while (isDigit(c)); fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = i; break; case '+': c = ctl_advance(); if (!isDigit(c)) fmt_error("digit expected"); goto DIGIT; case '-': c = ctl_advance(); if (!isDigit(c)) fmt_error("digit expected"); i = 0; do { i = i*10 + (c - '0'); c = ctl_advance(); } while (isDigit(c)); fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = -i; break; case '\'': fmt_param[n].fmt_param_type = fmt_char; fmt_param[n].fmt_param_value = ctl_advance(); c = ctl_advance(); break; case 'v': case 'V': x = fmt_advance(); if (type_of(x) == t_fixnum) { fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = fix(x); } else if (type_of(x) == t_character) { fmt_param[n].fmt_param_type = fmt_char; fmt_param[n].fmt_param_value = x->ch.ch_code; } else if (x == Cnil) { fmt_param[n].fmt_param_type = fmt_null; } else fmt_error("illegal V parameter"); c = ctl_advance(); break; case '#': fmt_param[n].fmt_param_type = fmt_int; fmt_param[n].fmt_param_value = fmt_end - fmt_index; c = ctl_advance(); break; default: /* if (n > 0) fmt_error("illegal ,"); else */ /* allow (FORMAT NIL "~5,,X" 10) ; ie ,just before directive */ goto DIRECTIVE; } n++; if (c != ',') break; } DIRECTIVE: colon = atsign = FALSE; if (c == ':') { colon = TRUE; c = ctl_advance(); } if (c == '@') { atsign = TRUE; c = ctl_advance(); } fmt_nparam = n; switch (c) { case 'a': case 'A': fmt_ascii(colon, atsign); break; case 's': case 'S': fmt_S_expression(colon, atsign); break; case 'd': case 'D': fmt_decimal(colon, atsign); break; case 'b': case 'B': fmt_binary(colon, atsign); break; case 'o': case 'O': fmt_octal(colon, atsign); break; case 'x': case 'X': fmt_hexadecimal(colon, atsign); break; case 'r': case 'R': fmt_radix(colon, atsign); break; case 'p': case 'P': fmt_plural(colon, atsign); break; case 'c': case 'C': fmt_character(colon, atsign); break; case 'f': case 'F': fmt_fix_float(colon, atsign); break; case 'e': case 'E': fmt_exponential_float(colon, atsign); break; case 'g': case 'G': fmt_general_float(colon, atsign); break; case '$': fmt_dollars_float(colon, atsign); break; case '%': fmt_percent(colon, atsign); break; case '&': fmt_ampersand(colon, atsign); break; case '|': fmt_bar(colon, atsign); break; case '~': fmt_tilde(colon, atsign); break; case '\n': case '\r': fmt_newline(colon, atsign); break; case 't': case 'T': fmt_tabulate(colon, atsign); break; case '*': fmt_asterisk(colon, atsign); break; case '?': fmt_indirection(colon, atsign); break; case '(': fmt_case(colon, atsign); break; case '[': fmt_conditional(colon, atsign); break; case '{': fmt_iteration(colon, atsign); break; case '<': fmt_justification(colon, atsign); break; case '^': fmt_up_and_out(colon, atsign); break; case ';': fmt_semicolon(colon, atsign); break; default: {object user_fmt=getf(sSAindent_formatted_outputA->s.s_plist,make_fixnum(c),Cnil); if (user_fmt!=Cnil) {object *oldbase=vs_base; object *oldtop=vs_top; vs_base=vs_top; vs_push(fmt_advance()); vs_push(fmt_stream); vs_push(make_fixnum(colon)); vs_push(make_fixnum(atsign)); if (type_of(user_fmt)==t_symbol) user_fmt=symbol_function(user_fmt); funcall(user_fmt); vs_base=oldbase; vs_top=oldtop; break;}} fmt_error("illegal directive"); } goto LOOP; }} static int fmt_skip(void) { int c, level = 0; LOOP: if (ctl_advance() != '~') goto LOOP; for (;;) switch (c = ctl_advance()) { case '\'': ctl_advance(); case ',': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '+': case '-': case 'v': case 'V': case '#': case ':': case '@': continue; default: goto DIRECTIVE; } DIRECTIVE: switch (c) { case '(': case '[': case '<': case '{': level++; break; case ')': case ']': case '>': case '}': if (level == 0) return(ctl_index); else --level; break; case ';': if (level == 0) return(ctl_index); break; } goto LOOP; } static void fmt_max_param(int n) { if (fmt_nparam > n) fmt_error("too many parameters"); } static void fmt_not_colon(bool colon) { if (colon) fmt_error("illegal :"); } static void fmt_not_atsign(bool atsign) { if (atsign) fmt_error("illegal @"); } static void fmt_not_colon_atsign(bool colon, bool atsign) { if (colon && atsign) fmt_error("illegal :@"); } static void fmt_set_param(int i, int *p, int t, int v) { if (i >= fmt_nparam || FMT_PARAM[i].fmt_param_type == fmt_null) *p = v; else if (FMT_PARAM[i].fmt_param_type != t) fmt_error("illegal parameter type"); else *p = FMT_PARAM[i].fmt_param_value; } static void fmt_ascii(bool colon, bool atsign) { int mincol=0, colinc=0, minpad=0, padchar=0; object x; int l, i; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &colinc, fmt_int, 1); fmt_set_param(2, &minpad, fmt_int, 0); fmt_set_param(3, &padchar, fmt_char, ' '); fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); x = fmt_advance(); if (colon && x == Cnil) writestr_stream("()", fmt_temporary_stream); else if (mincol == 0 && minpad == 0) { princ(x, fmt_stream); return; } else princ(x, fmt_temporary_stream); l = fmt_temporary_string->st.st_fillp; for (i = minpad; l + i < mincol; i += colinc) ; if (!atsign) { write_string(fmt_temporary_string, fmt_stream); while (i-- > 0) writec_stream(padchar, fmt_stream); } else { while (i-- > 0) writec_stream(padchar, fmt_stream); write_string(fmt_temporary_string, fmt_stream); } } static void fmt_S_expression(bool colon, bool atsign) { int mincol=0, colinc=0, minpad=0, padchar=0; object x; int l, i; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &colinc, fmt_int, 1); fmt_set_param(2, &minpad, fmt_int, 0); fmt_set_param(3, &padchar, fmt_char, ' '); fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); x = fmt_advance(); if (colon && x == Cnil) writestr_stream("()", fmt_temporary_stream); else if (mincol == 0 && minpad == 0) { prin1(x, fmt_stream); return; } else prin1(x, fmt_temporary_stream); l = fmt_temporary_string->st.st_fillp; for (i = minpad; l + i < mincol; i += colinc) ; if (!atsign) { write_string(fmt_temporary_string, fmt_stream); while (i-- > 0) writec_stream(padchar, fmt_stream); } else { while (i-- > 0) writec_stream(padchar, fmt_stream); write_string(fmt_temporary_string, fmt_stream); } } static void fmt_decimal(bool colon, bool atsign) { int mincol=0, padchar=0, commachar=0; fmt_max_param(3); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_integer(fmt_advance(), colon, atsign, 10, mincol, padchar, commachar); } static void fmt_binary(bool colon, bool atsign) { int mincol=0, padchar=0, commachar=0; fmt_max_param(3); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_integer(fmt_advance(), colon, atsign, 2, mincol, padchar, commachar); } static void fmt_octal(bool colon, bool atsign) { int mincol=0, padchar=0, commachar=0; fmt_max_param(3); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_integer(fmt_advance(), colon, atsign, 8, mincol, padchar, commachar); } static void fmt_hexadecimal(bool colon, bool atsign) { int mincol=0, padchar=0, commachar=0; fmt_max_param(3); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &padchar, fmt_char, ' '); fmt_set_param(2, &commachar, fmt_char, ','); fmt_integer(fmt_advance(), colon, atsign, 16, mincol, padchar, commachar); } static void fmt_radix(bool colon, bool atsign) { int radix=0, mincol=0, padchar=0, commachar=0; object x; int i, j, k; int s, t; bool b; extern void (*write_ch_fun)(int), writec_PRINTstream(int); if (fmt_nparam == 0) { x = fmt_advance(); check_type_integer(&x); if (atsign) { if (type_of(x) == t_fixnum) i = fix(x); else i = -1; if ((!colon && (i <= 0 || i >= 4000)) || (colon && (i <= 0 || i >= 5000))) { fmt_integer(x, FALSE, FALSE, 10, 0, ' ', ','); return; } fmt_roman(i/1000, 'M', '*', '*', colon); fmt_roman(i%1000/100, 'C', 'D', 'M', colon); fmt_roman(i%100/10, 'X', 'L', 'C', colon); fmt_roman(i%10, 'I', 'V', 'X', colon); return; } fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); PRINTstream = fmt_temporary_stream; PRINTradix = FALSE; PRINTbase = 10; write_ch_fun = writec_PRINTstream; write_object(x, 0); s = 0; i = fmt_temporary_string->st.st_fillp; if (i == 1 && fmt_tempstr(s) == '0') { writestr_stream("zero", fmt_stream); if (colon) writestr_stream("th", fmt_stream); return; } else if (fmt_tempstr(s) == '-') { writestr_stream("minus ", fmt_stream); --i; s++; } t = fmt_temporary_string->st.st_fillp; for (;;) if (fmt_tempstr(--t) != '0') break; for (b = FALSE; i > 0; i -= j) { b = fmt_nonillion(s, j = (i+29)%30+1, b, i<=30&&colon, t); s += j; if (b && i > 30) { for (k = (i - 1)/30; k > 0; --k) writestr_stream(" nonillion", fmt_stream); if (colon && s > t) writestr_stream("th", fmt_stream); } } return; } fmt_max_param(4); fmt_set_param(0, &radix, fmt_int, 10); fmt_set_param(1, &mincol, fmt_int, 0); fmt_set_param(2, &padchar, fmt_char, ' '); fmt_set_param(3, &commachar, fmt_char, ','); x = fmt_advance(); check_type_integer(&x); if (radix < 0 || radix > 36) { vs_push(make_fixnum(radix)); FEerror("~D is illegal as a radix.", 1, vs_head); } fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar); } static void fmt_integer(object x, bool colon, bool atsign, int radix, int mincol, int padchar, int commachar) { int l, l1; int s; extern void (*write_ch_fun)(int), writec_PRINTstream(int); if (type_of(x) != t_fixnum && type_of(x) != t_bignum) { fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); {SETUP_PRINT_DEFAULT(x); PRINTstream = fmt_temporary_stream; PRINTescape = FALSE; PRINTbase = radix; write_ch_fun = writec_PRINTstream; write_object(x, 0); CLEANUP_PRINT_DEFAULT;} l = fmt_temporary_string->st.st_fillp; mincol -= l; while (mincol-- > 0) writec_stream(padchar, fmt_stream); for (s = 0; l > 0; --l, s++) writec_stream(fmt_tempstr(s), fmt_stream); return; } fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);*/ STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); PRINTstream = fmt_temporary_stream; PRINTradix = FALSE; PRINTbase = radix; write_ch_fun = writec_PRINTstream; write_object(x, 0); l = l1 = fmt_temporary_string->st.st_fillp; s = 0; if (fmt_tempstr(s) == '-') --l1; mincol -= l; if (colon) mincol -= (l1 - 1)/3; if (atsign && fmt_tempstr(s) != '-') --mincol; while (mincol-- > 0) writec_stream(padchar, fmt_stream); if (fmt_tempstr(s) == '-') { s++; writec_stream('-', fmt_stream); } else if (atsign) writec_stream('+', fmt_stream); while (l1-- > 0) { writec_stream(fmt_tempstr(s++), fmt_stream); if (colon && l1 > 0 && l1%3 == 0) writec_stream(commachar, fmt_stream); } } static int fmt_nonillion(int s, int i, bool b, bool o, int t) { int j; for (; i > 3; i -= j) { b = fmt_thousand(s, j = (i+2)%3+1, b, FALSE, t); if (j != 3 || fmt_tempstr(s) != '0' || fmt_tempstr(s+1) != '0' || fmt_tempstr(s+2) != '0') { writec_stream(' ', fmt_stream); writestr_stream(fmt_big_numeral[(i - 1)/3 - 1], fmt_stream); s += j; if (o && s > t) writestr_stream("th", fmt_stream); } else s += j; } return(fmt_thousand(s, i, b, o, t)); } static int fmt_thousand(int s, int i, bool b, bool o, int t) { if (i == 3 && fmt_tempstr(s) > '0') { if (b) writec_stream(' ', fmt_stream); fmt_write_numeral(s, 0); writestr_stream(" hundred", fmt_stream); --i; s++; b = TRUE; if (o && s > t) writestr_stream("th", fmt_stream); } if (i == 3) { --i; s++; } if (i == 2 && fmt_tempstr(s) > '0') { if (b) writec_stream(' ', fmt_stream); if (fmt_tempstr(s) == '1') { if (o && s + 2 > t) fmt_write_ordinal(++s, 10); else fmt_write_numeral(++s, 10); return(TRUE); } else { if (o && s + 1 > t) fmt_write_ordinal(s, 20); else fmt_write_numeral(s, 20); s++; if (fmt_tempstr(s) > '0') { writec_stream('-', fmt_stream); if (o && s + 1 > t) fmt_write_ordinal(s, 0); else fmt_write_numeral(s, 0); } return(TRUE); } } if (i == 2) s++; if (fmt_tempstr(s) > '0') { if (b) writec_stream(' ', fmt_stream); if (o && s + 1 > t) fmt_write_ordinal(s, 0); else fmt_write_numeral(s, 0); return(TRUE); } return(b); } static void fmt_write_numeral(int s, int i) { writestr_stream(fmt_numeral[fmt_tempstr(s) - '0' + i], fmt_stream); } static void fmt_write_ordinal(int s, int i) { writestr_stream(fmt_ordinal[fmt_tempstr(s) - '0' + i], fmt_stream); } static void fmt_roman(int i, int one, int five, int ten, int colon) { int j; if (i == 0) return; if ((!colon && i < 4) || (colon && i < 5)) for (j = 0; j < i; j++) writec_stream(one, fmt_stream); else if (!colon && i == 4) { writec_stream(one, fmt_stream); writec_stream(five, fmt_stream); } else if ((!colon && i < 9) || colon) { writec_stream(five, fmt_stream); for (j = 5; j < i; j++) writec_stream(one, fmt_stream); } else if (!colon && i == 9) { writec_stream(one, fmt_stream); writec_stream(ten, fmt_stream); } } static void fmt_plural(bool colon, bool atsign) { fmt_max_param(0); if (colon) { if (fmt_index == 0) fmt_error("can't back up"); --fmt_index; } if (eql(fmt_advance(), make_fixnum(1))) if (atsign) writec_stream('y', fmt_stream); else ; else if (atsign) writestr_stream("ies", fmt_stream); else writec_stream('s', fmt_stream); } static void fmt_character(bool colon, bool atsign) { object x; int i; fmt_max_param(0); fmt_temporary_string->st.st_fillp = 0; /* fmt_temporary_stream->sm.sm_int0 = 0;*/ STREAM_FILE_COLUMN(fmt_temporary_stream) = 0; x = fmt_advance(); check_type_character(&x); prin1(x, fmt_temporary_stream); if (!colon && atsign) i = 0; else i = 2; for (; i < fmt_temporary_string->st.st_fillp; i++) writec_stream(fmt_tempstr(i), fmt_stream); } static void fmt_fix_float(bool colon, bool atsign) { int w=0, d=0, k=0, overflowchar=0, padchar=0,dp; double f; int sign; char *buff, *b, *buff1; int exp; int i, j; object x; int n, m; vs_mark; massert(buff=alloca(256)); /*from automatic array -- work around for persistent gcc alpha bug*/ massert(buff1=alloca(256)); b = buff1 + 1; fmt_not_colon(colon); fmt_max_param(5); fmt_set_param(0, &w, fmt_int, 0); if (w < 0) fmt_error("illegal width"); fmt_set_param(0, &w, fmt_int, -1); fmt_set_param(1, &d, fmt_int, 0); if (d < 0) fmt_error("illegal number of digits"); fmt_set_param(1, &d, fmt_int, -1); fmt_set_param(2, &k, fmt_int, 0); fmt_set_param(3, &overflowchar, fmt_char, -1); fmt_set_param(4, &padchar, fmt_char, ' '); x = fmt_advance(); if (type_of(x) == t_fixnum || type_of(x) == t_bignum || type_of(x) == t_ratio) { x = make_shortfloat((shortfloat)number_to_double(x)); vs_push(x); } if (type_of(x) == t_complex) { if (w < 0) prin1(x, fmt_stream); else { fmt_nparam = 1; --fmt_index; fmt_decimal(colon, atsign); } vs_reset; return; } if (type_of(x) == t_longfloat) { n = 17; dp=1; } else { n = 8; dp=0; } f = number_to_double(x); edit_double(n, f, &sign, buff, &exp, dp); if (sign==2) { prin1(x, fmt_stream); vs_reset; return; } if (d >= 0) m = d + exp + k + 1; else if (w >= 0) { if (exp + k >= 0) m = w - 1; else m = w + exp + k - 2; if (sign < 0 || atsign) --m; if (m == 0) m = 1; } else m = n; if (m <= 0) { if (m == 0 && buff[0] >= '5') { exp++; n = m = 1; buff[0] = '1'; } else n = m = 0; } else if (m < n) { n = m; edit_double(n, f, &sign, buff, &exp, dp); } while (n >= 0) if (buff[n - 1] == '0') --n; else break; exp += k; j = 0; if (exp >= 0) { for (i = 0; i <= exp; i++) b[j++] = i < n ? buff[i] : '0'; b[j++] = '.'; if (d >= 0) for (m = i + d; i < m; i++) b[j++] = i < n ? buff[i] : '0'; else for (; i < n; i++) b[j++] = buff[i]; } else { b[j++] = '.'; if (d >= 0) { for (i = 0; i < (-exp) - 1 && i < d; i++) b[j++] = '0'; for (m = d - i, i = 0; i < m; i++) b[j++] = i < n ? buff[i] : '0'; } else if (n > 0) { for (i = 0; i < (-exp) - 1; i++) b[j++] = '0'; for (i = 0; i < n; i++) b[j++] = buff[i]; } } b[j] = '\0'; if (w >= 0) { if (sign < 0 || atsign) --w; if (j > w && overflowchar >= 0) goto OVER; if (j < w && b[j-1] == '.' && d) { b[j++] = '0'; b[j] = '\0'; } if (j < w && b[0] == '.') { *--b = '0'; j++; } for (i = j; i < w; i++) writec_stream(padchar, fmt_stream); } else { if (b[0] == '.') { *--b = '0'; j++; } if (d < 0 && b[j-1] == '.') { b[j++] = '0'; b[j] = '\0'; } } if (sign < 0) writec_stream('-', fmt_stream); else if (atsign) writec_stream('+', fmt_stream); writestr_stream(b, fmt_stream); vs_reset; return; OVER: fmt_set_param(0, &w, fmt_int, 0); for (i = 0; i < w; i++) writec_stream(overflowchar, fmt_stream); vs_reset; return; } static int fmt_exponent_length(int e) { int i; if (e == 0) return(1); if (e < 0) e = -e; for (i = 0; e > 0; i++, e /= 10) ; return(i); } static void fmt_exponent(int e) { if (e == 0) { writec_stream('0', fmt_stream); return; } if (e < 0) e = -e; fmt_exponent1(e); } static void fmt_exponent1(int e) { if (e == 0) return; fmt_exponent1(e/10); writec_stream('0' + e%10, fmt_stream); } static void fmt_exponential_float(bool colon, bool atsign) { int w=0, d=0, e=0, k=0, overflowchar=0, padchar=0, exponentchar=0,dp; double f; int sign; char buff[256], *b, buff1[256]; int exp; int i, j; object x, y; int n, m; enum type t; vs_mark; b = buff1 + 1; fmt_not_colon(colon); fmt_max_param(7); fmt_set_param(0, &w, fmt_int, 0); if (w < 0) fmt_error("illegal width"); fmt_set_param(0, &w, fmt_int, -1); fmt_set_param(1, &d, fmt_int, 0); if (d < 0) fmt_error("illegal number of digits"); fmt_set_param(1, &d, fmt_int, -1); fmt_set_param(2, &e, fmt_int, 0); if (e < 0) fmt_error("illegal number of digits in exponent"); fmt_set_param(2, &e, fmt_int, -1); fmt_set_param(3, &k, fmt_int, 1); fmt_set_param(4, &overflowchar, fmt_char, -1); fmt_set_param(5, &padchar, fmt_char, ' '); fmt_set_param(6, &exponentchar, fmt_char, -1); x = fmt_advance(); if (type_of(x) == t_fixnum || type_of(x) == t_bignum || type_of(x) == t_ratio) { x = make_shortfloat((shortfloat)number_to_double(x)); vs_push(x); } if (type_of(x) == t_complex) { if (w < 0) prin1(x, fmt_stream); else { fmt_nparam = 1; --fmt_index; fmt_decimal(colon, atsign); } vs_reset; return; } if (type_of(x) == t_longfloat) { n = 17; dp=1; } else { n = 8; dp=0; } f = number_to_double(x); edit_double(n, f, &sign, buff, &exp, dp); if (sign==2) { prin1(x, fmt_stream); vs_reset; return; } if (d >= 0) { if (k > 0) { if (!(k < d + 2)) fmt_error("illegal scale factor"); m = d + 1; } else { if (!(k > -d)) fmt_error("illegal scale factor"); m = d + k; } } else if (w >= 0) { if (k > 0) m = w - 1; else m = w + k - 1; if (sign < 0 || atsign) --m; if (e >= 0) m -= e + 2; else m -= fmt_exponent_length(e - k + 1) + 2; } else m = n; if (m <= 0) { if (m == 0 && buff[0] >= '5') { exp++; n = m = 1; buff[0] = '1'; } else n = m = 0; } else if (m < n) { n = m; edit_double(n, f, &sign, buff, &exp, dp); } while (n >= 0) if (buff[n - 1] == '0') --n; else break; exp = exp - k + 1; j = 0; if (k > 0) { for (i = 0; i < k; i++) b[j++] = i < n ? buff[i] : '0'; b[j++] = '.'; if (d >= 0) for (m = i + (d - k + 1); i < m; i++) b[j++] = i < n ? buff[i] : '0'; else for (; i < n; i++) b[j++] = buff[i]; } else { b[j++] = '.'; if (d >= 0) { for (i = 0; i < -k && i < d; i++) b[j++] = '0'; for (m = d - i, i = 0; i < m; i++) b[j++] = i < n ? buff[i] : '0'; } else if (n > 0) { for (i = 0; i < -k; i++) b[j++] = '0'; for (i = 0; i < n; i++) b[j++] = buff[i]; } } b[j] = '\0'; if (w >= 0) { if (sign < 0 || atsign) --w; i = fmt_exponent_length(exp); if (e >= 0) { if (i > e) { if (overflowchar >= 0) goto OVER; else e = i; } w -= e + 2; } else w -= i + 2; if (j > w && overflowchar >= 0) goto OVER; if (j < w && b[j-1] == '.') { b[j++] = '0'; b[j] = '\0'; } if (j < w && b[0] == '.') { *--b = '0'; j++; } for (i = j; i < w; i++) writec_stream(padchar, fmt_stream); } else { if (b[j-1] == '.') { b[j++] = '0'; b[j] = '\0'; } if (d < 0 && b[0] == '.') { *--b = '0'; j++; } } if (sign < 0) writec_stream('-', fmt_stream); else if (atsign) writec_stream('+', fmt_stream); writestr_stream(b, fmt_stream); y = symbol_value(sLAread_default_float_formatA); if (exponentchar < 0) { if (y == sLlong_float || y == sLdouble_float || y == sLsingle_float ) t = t_longfloat; else t = t_shortfloat; if (type_of(x) == t) exponentchar = 'E'; else if (type_of(x) == t_shortfloat) exponentchar = 'S'; else exponentchar = 'L'; } writec_stream(exponentchar, fmt_stream); if (exp < 0) writec_stream('-', fmt_stream); else writec_stream('+', fmt_stream); if (e >= 0) for (i = e - fmt_exponent_length(exp); i > 0; --i) writec_stream('0', fmt_stream); fmt_exponent(exp); vs_reset; return; OVER: fmt_set_param(0, &w, fmt_int, -1); for (i = 0; i < w; i++) writec_stream(overflowchar, fmt_stream); vs_reset; return; } static void fmt_general_float(bool colon, bool atsign) { int w=0, d=0, e=0, k, overflowchar, padchar=0, exponentchar,dp; int sign, exp; char buff[256]; object x; int n, ee, ww, q, dd; vs_mark; fmt_not_colon(colon); fmt_max_param(7); fmt_set_param(0, &w, fmt_int, 0); if (w < 0) fmt_error("illegal width"); fmt_set_param(0, &w, fmt_int, -1); fmt_set_param(1, &d, fmt_int, 0); if (d < 0) fmt_error("illegal number of digits"); fmt_set_param(1, &d, fmt_int, -1); fmt_set_param(2, &e, fmt_int, 0); if (e < 0) fmt_error("illegal number of digits in exponent"); fmt_set_param(2, &e, fmt_int, -1); fmt_set_param(3, &k, fmt_int, 1); fmt_set_param(4, &overflowchar, fmt_char, -1); fmt_set_param(5, &padchar, fmt_char, ' '); fmt_set_param(6, &exponentchar, fmt_char, -1); x = fmt_advance(); if (type_of(x) == t_complex) { if (w < 0) prin1(x, fmt_stream); else { fmt_nparam = 1; --fmt_index; fmt_decimal(colon, atsign); } vs_reset; return; } if (type_of(x) == t_longfloat) { q = 17; dp=1; } else { q = 8; dp=0; } edit_double(q, number_to_double(x), &sign, buff, &exp, dp); n = exp + 1; while (q > 0) if (buff[q - 1] == '0') --q; else break; if (e >= 0) ee = e + 2; else ee = 4; ww = w - ee; if (d < 0) { d = n < 7 ? n : 7; d = q > d ? q : d; } dd = d - n; if (0 <= dd && dd <= d) { FMT_PARAM[0].fmt_param_value = ww; if (w < 0) FMT_PARAM[0].fmt_param_type = fmt_null; FMT_PARAM[1].fmt_param_value = dd; FMT_PARAM[1].fmt_param_type = fmt_int; FMT_PARAM[2].fmt_param_type = fmt_null; if (fmt_nparam > 4) {FMT_PARAM[3] = FMT_PARAM[4]; } else FMT_PARAM[3].fmt_param_type = fmt_null; if (fmt_nparam > 5) {FMT_PARAM[4] = FMT_PARAM[5];} else FMT_PARAM[4].fmt_param_type = fmt_null; fmt_nparam = 5; --fmt_index; fmt_fix_float(colon, atsign); if (w >= 0) while (ww++ < w) writec_stream(padchar, fmt_stream); vs_reset; return; } FMT_PARAM[1].fmt_param_value = d; FMT_PARAM[1].fmt_param_type = fmt_int; --fmt_index; fmt_exponential_float(colon, atsign); vs_reset; } static void fmt_dollars_float(bool colon, bool atsign) { int d=0, n=0, w=0, padchar=0,dp; double f; int sign; char buff[256]; int exp; int q, i; object x; vs_mark; fmt_max_param(4); fmt_set_param(0, &d, fmt_int, 2); if (d < 0) fmt_error("illegal number of digits"); fmt_set_param(1, &n, fmt_int, 1); if (n < 0) fmt_error("illegal number of digits"); fmt_set_param(2, &w, fmt_int, 0); if (w < 0) fmt_error("illegal width"); fmt_set_param(3, &padchar, fmt_char, ' '); x = fmt_advance(); if (type_of(x) == t_complex) { if (w < 0) prin1(x, fmt_stream); else { fmt_nparam = 1; FMT_PARAM[0] = FMT_PARAM[2]; --fmt_index; fmt_decimal(colon, atsign); } vs_reset; return; } q = 8; dp=0; if (type_of(x) == t_longfloat) { q = 17; dp=1; } f = number_to_double(x); edit_double(q, f, &sign, buff, &exp, dp); if ((q = exp + d + 1) > 0) edit_double(q, f, &sign, buff, &exp, dp); exp++; if (w > 100 || exp > 100 || exp < -100) { fmt_nparam = 6; FMT_PARAM[0] = FMT_PARAM[2]; FMT_PARAM[1].fmt_param_value = d + n - 1; FMT_PARAM[1].fmt_param_type = fmt_int; FMT_PARAM[2].fmt_param_type = FMT_PARAM[3].fmt_param_type = FMT_PARAM[4].fmt_param_type = fmt_null; FMT_PARAM[5] = FMT_PARAM[3]; --fmt_index; fmt_exponential_float(colon, atsign); } if (exp > n) n = exp; if (sign < 0 || atsign) --w; if (colon) { if (sign < 0) writec_stream('-', fmt_stream); else if (atsign) writec_stream('+', fmt_stream); while (--w > n + d) writec_stream(padchar, fmt_stream); } else { while (--w > n + d) writec_stream(padchar, fmt_stream); if (sign < 0) writec_stream('-', fmt_stream); else if (atsign) writec_stream('+', fmt_stream); } for (i = n - exp; i > 0; --i) writec_stream('0', fmt_stream); for (i = 0; i < exp; i++) writec_stream((i < q ? buff[i] : '0'), fmt_stream); writec_stream('.', fmt_stream); for (d += i; i < d; i++) writec_stream((i < q ? buff[i] : '0'), fmt_stream); vs_reset; } static void fmt_percent(bool colon, bool atsign) { int n=0, i; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 1); fmt_not_colon(colon); fmt_not_atsign(atsign); while (n-- > 0) { WRITEC_NEWLINE(fmt_stream); if (n == 0) for (i = fmt_indents; i > 0; --i) writec_stream(' ', fmt_stream); } } static void fmt_ampersand(bool colon, bool atsign) { int n=0; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 1); fmt_not_colon(colon); fmt_not_atsign(atsign); if (n == 0) return; if (file_column(fmt_stream) != 0) WRITEC_NEWLINE(fmt_stream); while (--n > 0) WRITEC_NEWLINE(fmt_stream); fmt_indents = 0; } static void fmt_bar(bool colon, bool atsign) { int n=0; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 1); fmt_not_colon(colon); fmt_not_atsign(atsign); while (n-- > 0) writec_stream('\f', fmt_stream); } static void fmt_tilde(bool colon, bool atsign) { int n=0; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 1); fmt_not_colon(colon); fmt_not_atsign(atsign); while (n-- > 0) writec_stream('~', fmt_stream); } static void fmt_newline(bool colon, bool atsign) { fmt_max_param(0); fmt_not_colon_atsign(colon, atsign); if (atsign) WRITEC_NEWLINE(fmt_stream); while (ctl_index < ctl_end && isspace((int)ctl_string[ctl_index])) { if (colon) writec_stream(ctl_string[ctl_index], fmt_stream); ctl_index++; } } static void fmt_tabulate(bool colon, bool atsign) { int colnum=0, colinc=0; int c, i; fmt_max_param(2); fmt_not_colon(colon); fmt_set_param(0, &colnum, fmt_int, 1); fmt_set_param(1, &colinc, fmt_int, 1); if (!atsign) { c = file_column(fmt_stream); if (c < 0) { writestr_stream(" ", fmt_stream); return; } if (c > colnum && colinc <= 0) return; while (c > colnum) colnum += colinc; for (i = colnum - c; i > 0; --i) writec_stream(' ', fmt_stream); } else { for (i = colnum; i > 0; --i) writec_stream(' ', fmt_stream); c = file_column(fmt_stream); if (c < 0 || colinc <= 0) return; colnum = 0; while (c > colnum) colnum += colinc; for (i = colnum - c; i > 0; --i) writec_stream(' ', fmt_stream); } } static void fmt_asterisk(bool colon, bool atsign) { int n=0; fmt_max_param(1); fmt_not_colon_atsign(colon, atsign); if (atsign) { fmt_set_param(0, &n, fmt_int, 0); if (n < 0 || n >= fmt_end) fmt_error("can't goto"); fmt_index = n; } else if (colon) { fmt_set_param(0, &n, fmt_int, 1); if (n > fmt_index) fmt_error("can't back up"); fmt_index -= n; } else { fmt_set_param(0, &n, fmt_int, 1); while (n-- > 0) fmt_advance(); } } static void fmt_indirection(bool colon, bool atsign) { object s, l; fmt_old; jmp_buf fmt_jmp_buf0; int up_colon; /* to prevent longjmp clobber */ up_colon=(long)&old_fmt_paramp; fmt_max_param(0); fmt_not_colon(colon); s = fmt_advance(); if (type_of(s) != t_string) fmt_error("control string expected"); if (atsign) { fmt_save; fmt_jmp_bufp = &fmt_jmp_buf0; fmt_string = s; if ((up_colon = setjmp(*fmt_jmp_bufp))) { if (--up_colon) fmt_error("illegal ~:^"); } else format(fmt_stream, 0, s->st.st_fillp); fmt_restore1; } else { l = fmt_advance(); fmt_save; fmt_base = vs_top; fmt_index = 0; for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) vs_check_push(l->c.c_car); fmt_jmp_bufp = &fmt_jmp_buf0; fmt_string = s; if ((up_colon = setjmp(*fmt_jmp_bufp))) { if (--up_colon) fmt_error("illegal ~:^"); } else format(fmt_stream, 0, s->st.st_fillp); vs_top = fmt_base; fmt_restore; } } static void fmt_case(bool colon, bool atsign) { VOL object x; VOL int i, j; fmt_old1; jmp_buf fmt_jmp_buf0; int up_colon; bool b; x = make_string_output_stream(64); vs_push(x); i = ctl_index; j = fmt_skip(); if (ctl_string[--j] != ')' || ctl_string[--j] != '~') fmt_error("~) expected"); fmt_save1; fmt_jmp_bufp = &fmt_jmp_buf0; if ((up_colon = setjmp(*fmt_jmp_bufp))) ; else format(x, ctl_origin + i, j - i); fmt_restore1; x = x->sm.sm_object0; if (!colon && !atsign) for (i = 0; i < x->st.st_fillp; i++) { j = x->st.st_self[i]; if (isUpper(j)) j += 'a' - 'A'; writec_stream(j, fmt_stream); } else if (colon && !atsign) for (b = TRUE, i = 0; i < x->st.st_fillp; i++) { j = x->st.st_self[i]; if (isLower(j)) { if (b) j -= 'a' - 'A'; b = FALSE; } else if (isUpper(j)) { if (!b) j += 'a' - 'A'; b = FALSE; } else if (!isDigit(j)) b = TRUE; writec_stream(j, fmt_stream); } else if (!colon && atsign) for (b = TRUE, i = 0; i < x->st.st_fillp; i++) { j = x->st.st_self[i]; if (isLower(j)) { if (b) j -= 'a' - 'A'; b = FALSE; } else if (isUpper(j)) { if (!b) j += 'a' - 'A'; b = FALSE; } writec_stream(j, fmt_stream); } else for (i = 0; i < x->st.st_fillp; i++) { j = x->st.st_self[i]; if (isLower(j)) j -= 'a' - 'A'; writec_stream(j, fmt_stream); } vs_popp; if (up_colon) longjmp(*fmt_jmp_bufp, up_colon); } static void fmt_conditional(bool colon, bool atsign) { int i, j, k; object x; int n=0; bool done; fmt_old1; fmt_not_colon_atsign(colon, atsign); if (colon) { fmt_max_param(0); i = ctl_index; j = fmt_skip(); if (ctl_string[--j] != ';' || ctl_string[--j] != '~') fmt_error("~; expected"); k = fmt_skip(); if (ctl_string[--k] != ']' || ctl_string[--k] != '~') fmt_error("~] expected"); if (fmt_advance() == Cnil) { fmt_save1; format(fmt_stream, ctl_origin + i, j - i); fmt_restore1; } else { fmt_save1; format(fmt_stream, ctl_origin + j + 2, k - (j + 2)); fmt_restore1; } } else if (atsign) { i = ctl_index; j = fmt_skip(); if (ctl_string[--j] != ']' || ctl_string[--j] != '~') fmt_error("~] expected"); if (fmt_advance() == Cnil) ; else { --fmt_index; fmt_save1; format(fmt_stream, ctl_origin + i, j - i); fmt_restore1; } } else { fmt_max_param(1); if (fmt_nparam == 0) { x = fmt_advance(); if (type_of(x) != t_fixnum) fmt_error("illegal argument for conditional"); n = fix(x); } else fmt_set_param(0, &n, fmt_int, 0); i = ctl_index; for (done = FALSE;; --n) { j = fmt_skip(); for (k = j; ctl_string[--k] != '~';) ; if (n == 0) { fmt_save1; format(fmt_stream, ctl_origin + i, k - i); fmt_restore1; done = TRUE; } i = j; if (ctl_string[--j] == ']') { if (ctl_string[--j] != '~') fmt_error("~] expected"); return; } if (ctl_string[j] == ';') { if (ctl_string[--j] == '~') continue; if (ctl_string[j] == ':') goto ELSE; } fmt_error("~; or ~] expected"); } ELSE: if (ctl_string[--j] != '~') fmt_error("~:; expected"); j = fmt_skip(); if (ctl_string[--j] != ']' || ctl_string[--j] != '~') fmt_error("~] expected"); if (!done) { fmt_save1; format(fmt_stream, ctl_origin + i, j - i); fmt_restore1; } } } static void fmt_iteration(bool colon, bool atsign) { int i,n=0; VOL int j; int o; bool colon_close = FALSE; object l; VOL object l0; fmt_old; jmp_buf fmt_jmp_buf0; int up_colon; /* to prevent longjmp clobber */ up_colon=(long)&old_fmt_paramp; fmt_max_param(1); fmt_set_param(0, &n, fmt_int, 1000000); i = ctl_index; j = fmt_skip(); if (ctl_string[--j] != '}') fmt_error("~} expected"); if (ctl_string[--j] == ':') { colon_close = TRUE; --j; } if (ctl_string[j] != '~') fmt_error("syntax error"); o = ctl_origin; if (!colon && !atsign) { l = fmt_advance(); fmt_save; fmt_base = vs_top; fmt_index = 0; for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) vs_check_push(l->c.c_car); fmt_jmp_bufp = &fmt_jmp_buf0; if (colon_close) goto L1; while (fmt_index < fmt_end) { L1: if (n-- <= 0) break; if ((up_colon = setjmp(*fmt_jmp_bufp))) { if (--up_colon) fmt_error("illegal ~:^"); break; } format(fmt_stream, o + i, j - i); } vs_top = fmt_base; fmt_restore; } else if (colon && !atsign) { l0 = fmt_advance(); fmt_save; fmt_base = vs_top; fmt_jmp_bufp = &fmt_jmp_buf0; if (colon_close) goto L2; while (!endp(l0)) { L2: if (n-- <= 0) break; l = l0->c.c_car; l0 = l0->c.c_cdr; fmt_index = 0; for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) vs_check_push(l->c.c_car); if ((up_colon = setjmp(*fmt_jmp_bufp))) { vs_top = fmt_base; if (--up_colon) break; else continue; } format(fmt_stream, o + i, j - i); vs_top = fmt_base; } fmt_restore; } else if (!colon && atsign) { fmt_save; fmt_jmp_bufp = &fmt_jmp_buf0; if (colon_close) goto L3; while (fmt_index < fmt_end) { L3: if (n-- <= 0) break; if ((up_colon = setjmp(*fmt_jmp_bufp))) { if (--up_colon) fmt_error("illegal ~:^"); break; } format(fmt_stream, o + i, j - i); } fmt_restore1; } else if (colon && atsign) { if (colon_close) goto L4; while (fmt_index < fmt_end) { L4: if (n-- <= 0) break; l = fmt_advance(); fmt_save; fmt_base = vs_top; fmt_index = 0; for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) vs_check_push(l->c.c_car); fmt_jmp_bufp = &fmt_jmp_buf0; if ((up_colon = setjmp(*fmt_jmp_bufp))) { vs_top = fmt_base; fmt_restore; if (--up_colon) break; else continue; } format(fmt_stream, o + i, j - i); vs_top = fmt_base; fmt_restore; } } } #define FORMAT_DIRECTIVE_LIMIT 100 static void fmt_justification(volatile bool colon, bool atsign) { int mincol=0, colinc=0, minpad=0, padchar=0; object fields[FORMAT_DIRECTIVE_LIMIT]; fmt_old1; jmp_buf fmt_jmp_buf0; VOL int i,j,n,j0; int k,l,m,l0; int up_colon; VOL int special = 0; volatile int spare_spaces=0, line_length=0; vs_mark; /* to prevent longjmp clobber */ up_colon=(long)&old_fmt_paramp; fmt_max_param(4); fmt_set_param(0, &mincol, fmt_int, 0); fmt_set_param(1, &colinc, fmt_int, 1); fmt_set_param(2, &minpad, fmt_int, 0); fmt_set_param(3, &padchar, fmt_char, ' '); n = 0; for (;;) { if (n >= FORMAT_DIRECTIVE_LIMIT) fmt_error("too many fields"); i = ctl_index; j0 = j = fmt_skip(); while (ctl_string[--j] != '~') ; fields[n] = make_string_output_stream(64); vs_push(fields[n]); fmt_save1; fmt_jmp_bufp = &fmt_jmp_buf0; if ((up_colon = setjmp(*fmt_jmp_bufp))) { --n; if (--up_colon) fmt_error("illegal ~:^"); fmt_restore1; while (ctl_string[--j0] != '>') j0 = fmt_skip(); if (ctl_string[--j0] != '~') fmt_error("~> expected"); break; } format(fields[n++], ctl_origin + i, j - i); fmt_restore1; if (ctl_string[--j0] == '>') { if (ctl_string[--j0] != '~') fmt_error("~> expected"); break; } else if (ctl_string[j0] != ';') fmt_error("~; expected"); else if (ctl_string[--j0] == ':') { if (n != 1) fmt_error("illegal ~:;"); special = 1; for (j = j0; ctl_string[j] != '~'; --j) ; fmt_save1; format(fmt_stream, ctl_origin + j, j0 - j + 2); fmt_restore1; spare_spaces = fmt_spare_spaces; line_length = fmt_line_length; } else if (ctl_string[j0] != '~') fmt_error("~; expected"); } for (i = special, l = 0; i < n; i++) l += fields[i]->sm.sm_object0->st.st_fillp; m = n - 1 - special; if (m <= 0 && !colon && !atsign) { m = 0; colon = TRUE; } if (colon) m++; if (atsign) m++; l0 = l; l += minpad * m; for (k = 0; mincol + k * colinc < l; k++) ; l = mincol + k * colinc; if (special != 0 && file_column(fmt_stream) + l + spare_spaces >= line_length) princ(fields[0]->sm.sm_object0, fmt_stream); l -= l0; for (i = special; i < n; i++) { if (m > 0 && (i > 0 || colon)) for (j = l / m, l -= j, --m; j > 0; --j) writec_stream(padchar, fmt_stream); princ(fields[i]->sm.sm_object0, fmt_stream); } if (atsign) for (j = l; j > 0; --j) writec_stream(padchar, fmt_stream); vs_reset; } static void fmt_up_and_out(bool colon, bool atsign) { int i=0, j=0, k=0; fmt_max_param(3); fmt_not_atsign(atsign); if (fmt_nparam == 0) { if (fmt_index >= fmt_end) longjmp(*fmt_jmp_bufp, ++colon); } else if (fmt_nparam == 1) { fmt_set_param(0, &i, fmt_int, 0); if (i == 0) longjmp(*fmt_jmp_bufp, ++colon); } else if (fmt_nparam == 2) { fmt_set_param(0, &i, fmt_int, 0); fmt_set_param(1, &j, fmt_int, 0); if (i == j) longjmp(*fmt_jmp_bufp, ++colon); } else { fmt_set_param(0, &i, fmt_int, 0); fmt_set_param(1, &j, fmt_int, 0); fmt_set_param(2, &k, fmt_int, 0); if (i <= j && j <= k) longjmp(*fmt_jmp_bufp, ++colon); } } static void fmt_semicolon(bool colon, bool atsign) { fmt_not_atsign(atsign); if (!colon) fmt_error("~:; expected"); fmt_max_param(2); fmt_set_param(0, &fmt_spare_spaces, fmt_int, 0); fmt_set_param(1, &fmt_line_length, fmt_int, 72); } DEFUNO_NEW("FORMAT",object,fLformat,LISP ,2,F_ARG_LIMIT,NONE,OO,OO,OO,OO,void,Lformat,(object strm, object control,...),"") { va_list ap; VOL int nargs= VFUN_NARGS; VOL object x = OBJNULL; jmp_buf fmt_jmp_buf0; bool colon, e; fmt_old; nargs=nargs-2; if (nargs < 0) too_few_arguments(); if (strm == Cnil) { strm = make_string_output_stream(64); x = strm->sm.sm_object0; } else if (strm == Ct) strm = symbol_value(sLAstandard_outputA); else if (type_of(strm) == t_string) { x = strm; if (!x->st.st_hasfillp) FEerror("The string ~S doesn't have a fill-pointer.", 1, x); strm = make_string_output_stream(0); strm->sm.sm_object0 = x; } else check_type_stream(&strm); check_type_string(&control); fmt_save; frs_push(FRS_PROTECT, Cnil); if (nlj_active) { e = TRUE; goto L; } va_start(ap,control); {object *l; COERCE_VA_LIST(l,ap,nargs); fmt_base = l; fmt_index = 0; fmt_end = nargs; fmt_jmp_bufp = & fmt_jmp_buf0; if (symbol_value(sSAindent_formatted_outputA) != Cnil) fmt_indents = file_column(strm); else fmt_indents = 0; fmt_string = control; if ((colon = setjmp(*fmt_jmp_bufp))) { if (--colon) fmt_error("illegal ~:^"); vs_base = vs_top; if (x != OBJNULL) vs_push(x); else vs_push(Cnil); e = FALSE; goto L; } format(strm, 0, control->st.st_fillp); flush_stream(strm); } va_end(ap); e = FALSE; L: frs_pop(); fmt_restore; if (e) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } RETURN1 (x ==0 ? Cnil : x); } object fLformat_1(object strm, object control,object x) { VFUN_NARGS=3; return FFN(fLformat)(strm,control,x); } /* object c_apply_n(long int (*fn) (), int n, object *x); */ static void fmt_error(char *s) { vs_push(make_simple_string(s)); vs_push(make_fixnum(&ctl_string[ctl_index] - fmt_string->st.st_self)); FEerror("Format error: ~A.~%~V@TV~%\"~A\"~%", 3, vs_top[-2], vs_top[-1], fmt_string); } DEFVAR("*INDENT-FORMATTED-OUTPUT*",sSAindent_formatted_outputA,SI,Cnil,""); void gcl_init_format(void) { fmt_temporary_stream = make_string_output_stream(64); enter_mark_origin(&fmt_temporary_stream); fmt_temporary_string = fmt_temporary_stream->sm.sm_object0; } gcl-2.6.14/o/grab_defs.c0000755000175000017500000000445614360276512013325 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #include #include #include /* recognize \nDEF ......... ") and output it to stdout [ie '")' is a two character sequence which ends the def recognize \nDO_ [^\n]\n and output it to stdout Thus the DEF's MUST contain a doc string as last component. */ int pos = 0; #define GETC(x) (pos++,getc(x)) int read_some(char *buf, int n, int start_ch, int copy) /* if copy is not 0 then copy characters to stdout while scanning to find start_ch. When you find it, read n characters into buf, return the number of characters read into buf, but these characters MUST be free of start_ch. */ { int ch; int prev = 0; while (1) { ch =GETC(stdin); if (ch == EOF) return -1; if (copy) {putc(ch,stdout); if (prev == '\n' && ch == '{') { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy\n",pos) ; exit(1);} prev = ch; } AGAIN: if (ch == start_ch) { int i = 0; while (i < n) { ch = GETC(stdin); if (ch == EOF) return i; if (copy) {putc(ch,stdout); if (prev == '\n' && ch == '{') { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy",pos) ; exit(1);} prev = ch; } if (ch == start_ch) goto AGAIN; buf[i++] = ch; } return i; }}} int main(void) { char buf[20]; while (3==read_some(buf,3,'\n',0)) { buf[3] = 0; if (strcmp(buf,"DEF") ==0) { printf("\n%s",buf); while(1==read_some(buf,1,'\"',1)) { if (buf[0] == ')') break; }} if (strcmp(buf,"DO_") ==0) {printf("\n%s",buf); read_some(buf,0,'\n',1); ungetc('\n',stdin); } } printf("\n"); exit(0); } gcl-2.6.14/o/sfaslcoff.c0000644000175000017500000002413514360276512013350 0ustar cammcamm#include #include "windows.h" typedef unsigned char uc; typedef unsigned short us; typedef unsigned int ul; struct filehdr { us f_magic; /* magic number */ us f_nscns; /* number of sections */ ul f_timdat; /* time & date stamp */ ul f_ptrsym; /* file pointer to symtab */ ul f_symnum; /* number of symtab entries */ us f_opthdr; /* sizeof(optional hdr) */ us f_flags; /* flags */ }; struct opthdr { us h_magic; uc h_mlv; uc h_nlv; ul h_tsize; ul h_dsize; ul h_bsize; ul h_maddr; ul h_tbase; ul h_dbase; /* = high 32 bits of ibase for PE32+, magic 0x20b*/ ul h_ibase; }; struct scnhdr { uc s_name[8]; /* section name */ ul s_paddr; /* physical address, aliased s_nlib */ ul s_vaddr; /* virtual address */ ul s_size; /* section size */ ul s_scnptr; /* file ptr to raw data for section */ ul s_relptr; /* file ptr to relocation */ ul s_lnnoptr; /* file ptr to line numbers */ us s_nreloc; /* number of relocation entries */ us s_nlnno; /* number of line number entries*/ ul s_flags; /* flags */ }; #define SEC_CODE 0x20 #define SEC_DATA 0x40 #define SEC_BSS 0x80 #define ALLOC_SEC(sec) (sec->s_flags&(SEC_CODE|SEC_DATA|SEC_BSS)) #define LOAD_SEC(sec) (sec->s_flags&(SEC_CODE|SEC_DATA)) #define NM(sym_,tab_,nm_,op_) \ ({char _c=0,*nm_; \ if ((sym_)->n.n.n_zeroes) \ {(nm_)=(sym_)->n.n_name;_c=(nm_)[8];(nm_)[8]=0;} \ else \ (nm_)=(tab_)+(sym_)->n.n.n_offset; \ op_; \ if (_c) (nm_)[8]=_c; \ }) struct reloc { union { ul r_vaddr; ul r_count; /* Set to the real count when IMAGE_SCN_LNK_NRELOC_OVFL is set */ } r; ul r_symndx; us r_type; } __attribute__ ((packed)); #define R_ABS 0x0000 /* absolute, no relocation is necessary */ #define R_DIR32 0x0006 /* Direct 32-bit reference to the symbols virtual address */ #define R_SECREL32 0x000B /* Currently ignored, used only for debugging strings FIXME */ #define R_PCRLONG 0x0014 /* 32-bit reference pc relative to the symbols virtual address */ #define IMAGE_REL_AMD64_REL32 0x0004 /* 32-bit reference pc relative to the symbols virtual address */ #define IMAGE_REL_AMD64_ADDR64 0x0001 /* The 64-bit VA of the relocation target */ #define IMAGE_REL_AMD64_ADDR32NB 0x0003 /* The 32-bit address without an image base (RVA) */ struct syment { union { char n_name[8]; struct { int n_zeroes; int n_offset; } n; } n; ul n_value; short n_scnum; us n_type; uc n_sclass; uc n_numaux; } __attribute__ ((packed)); static int ovchk(ul v,ul m) { m|=m>>1; v&=m; return (!v || v==m); } static int store_val(ul *w,ul m,ul v) { massert(ovchk(v,~m)); *w=(v&m)|(*w&~m); return 0; } static int add_val(ul *w,ul m,ul v) { return store_val(w,m,v+(*w&m)); } static unsigned long self_ibase; #define sym_lvalue(sym_) (!sym_->n_scnum ? self_ibase+sym_->n_value : (unsigned long)start+sym_->n_value) static void relocate(struct scnhdr *sec,struct reloc *rel,struct syment *sym,void *start) { ul *where=start+(sec->s_paddr+rel->r.r_vaddr); switch(rel->r_type) { case R_ABS: case R_SECREL32: break; case IMAGE_REL_AMD64_ADDR64: add_val(where,~0L,sym_lvalue(sym)); #if SIZEOF_LONG == 8 add_val(where+1,~0L,sym_lvalue(sym)>>32); #endif break; case IMAGE_REL_AMD64_ADDR32NB: add_val(where,~0L,sym->n_value); break; case R_DIR32: add_val(where,~0L,sym_lvalue(sym)); break; case R_PCRLONG: case IMAGE_REL_AMD64_REL32: add_val(where,~0L,(ul)((void *)sym_lvalue(sym)-(void *)(where+1))); break; default: fprintf(stdout, "%d: unsupported relocation type.", rel->r_type); FEerror("The relocation type was unknown",0); } } static void find_init_address(struct syment *sym,struct syment *sye,ul *ptr,char *st1) { for(;symn_scnum == 1 && sym->n_value) { char *s=sym->n.n.n_zeroes ? sym->n.n_name : st1+sym->n.n.n_offset; if (!strncmp(s,"init_",5) || !strncmp(s,"_init_",6)) *ptr=sym->n_value; } sym += (sym)->n_numaux; } } static ul get_sym_svalue(const char *name) { struct node *answ; return (answ=find_sym_ptable(name)) ? answ->address-self_ibase : ({massert(!emsg("Unrelocated non-local symbol: %s\n",name));0;}); } static void relocate_symbols(struct syment *sym,struct syment *sye,struct scnhdr *sec1,char *st1) { long value; for (;symn_scnum>0) sym->n_value = sec1[sym->n_scnum-1].s_paddr; else if (!sym->n_scnum) { NM(sym,st1,s,value=get_sym_svalue(s)); sym->n_value=value; } sym += (sym)->n_numaux; } } static object load_memory(struct scnhdr *sec1,struct scnhdr *sece,void *st,ul *init_address) { object memory; struct scnhdr *sec; ul sz,a,ma; BEGIN_NO_INTERRUPT; for (sec=sec1,ma=sz=0;secs_flags>>20)&0xf)-1); massert(a<=8192); ma=ma ? ma : a; sz=(sz+a-1)&~(a-1); sec->s_paddr=sz; sz+=sec->s_size; } ma=ma>sizeof(struct contblock) ? ma-1 : 0; sz+=ma; memory=new_cfdata(); memory->cfd.cfd_size=sz; memory->cfd.cfd_start=alloc_code_space(sz,-1UL); a=(((unsigned long)memory->cfd.cfd_start+ma)&~ma)-((unsigned long)memory->cfd.cfd_start); *init_address+=a; for (sec=sec1;secs_paddr+=a; if (LOAD_SEC(sec)) memcpy((void *)memory->cfd.cfd_start+sec->s_paddr,st+sec->s_scnptr,sec->s_size); } } END_NO_INTERRUPT; return memory; } static int load_self_symbols() { FILE *f; void *v1,*v,*ve; struct filehdr *fhp; struct syment *sy1,*sye,*sym; struct scnhdr *sec1,*sec,*sece; struct opthdr *h; struct node *a; char *st1,*st; ul ns,sl; unsigned long jj; massert(f=fopen(kcl_self,"r")); massert(v1=get_mmap(f,&ve)); v=v1+*(ul *)(v1+0x3c); massert(!memcmp("PE\0\0",v,4)); fhp=v+4; h=(void *)(fhp+1); massert(h->h_magic==0x10b || h->h_magic==0x20b); self_ibase=h->h_ibase; #if SIZEOF_LONG == 8 if (h->h_magic==0x20b) self_ibase=(self_ibase<<32)+h->h_dbase; #endif sec1=(void *)(fhp+1)+fhp->f_opthdr; sece=sec1+fhp->f_nscns; sy1=v1+fhp->f_ptrsym; sye=sy1+fhp->f_symnum; st1=(char *)sye; for (ns=sl=0,sym=sy1;symn_sclass<2 || sym->n_sclass>3 || sym->n_scnum<1) continue; ns++; NM(sym,st1,s,sl+=strlen(s)+1); sym+=sym->n_numaux; } c_table.alloc_length=ns; assert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); assert(st=malloc(sl)); for (a=c_table.ptable,sym=sy1;symn_sclass!=2 || sym->n_scnum<1) continue; NM(sym,st1,s,strcpy(st,s)); sec=sec1+sym->n_scnum-1; jj=self_ibase+sym->n_value+sec->s_vaddr; #ifdef FIX_ADDRESS FIX_ADDRESS(jj); #endif a->address=jj; a->string=st; a++; st+=strlen(st)+1; sym+=sym->n_numaux; } c_table.length=a-c_table.ptable; qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); for (c_table.local_ptable=a,sym=sy1;symn_sclass!=3 || sym->n_scnum<1) continue; NM(sym,st1,s,strcpy(st,s)); sec=sec1+sym->n_scnum-1; jj=self_ibase+sym->n_value+sec->s_vaddr; #ifdef FIX_ADDRESS FIX_ADDRESS(jj); #endif a->address=jj; a->string=st; a++; st+=strlen(st)+1; sym+=sym->n_numaux; } c_table.local_length=a-c_table.local_ptable; qsort(c_table.local_ptable,c_table.local_length,sizeof(*c_table.local_ptable),node_compare); massert(c_table.alloc_length==c_table.length+c_table.local_length); massert(!un_mmap(v1,ve)); massert(!fclose(f)); return 0; } int seek_to_end_ofile(FILE *fp) { void *st,*ve; struct filehdr *fhp; struct scnhdr *sec1,*sece; struct syment *sy1,*sye; const char *st1,*ste; int i; massert(st=get_mmap(fp,&ve)); fhp=st; sec1=(void *)(fhp+1)+fhp->f_opthdr; sece=sec1+fhp->f_nscns; sy1=st+fhp->f_ptrsym; sye=sy1+fhp->f_symnum; st1=(void *)sye; ste=st1+*(ul *)st1; fseek(fp,(void *)ste-st,0); while (!(i=getc(fp))); ungetc(i, fp); massert(!un_mmap(st,ve)); return 0; } object find_init_string(const char *s) { FILE *f; struct filehdr *fhp; struct scnhdr *sec1,*sece; struct syment *sy1,*sym,*sye; char *st1,*ste; void *st,*est; object o=OBJNULL; massert(f=fopen(s,"r")); massert(st=get_mmap(f,&est)); fhp=st; sec1=(void *)(fhp+1)+fhp->f_opthdr; sece=sec1+fhp->f_nscns; sy1=st+fhp->f_ptrsym; sye=sy1+fhp->f_symnum; st1=(void *)sye; ste=st1+*(ul *)st1; for (sym=sy1;symsm.sm_fp; massert(st=get_mmap(fp,&est)); fhp=st; sec1=(void *)(fhp+1)+fhp->f_opthdr; sece=sec1+fhp->f_nscns; sy1=st+fhp->f_ptrsym; sye=sy1+fhp->f_symnum; st1=(void *)sye; ste=st1+*(ul *)st1; find_init_address(sy1,sye,&init_address,st1); memory=load_memory(sec1,sece,st,&init_address); relocate_symbols(sy1,sye,sec1,st1); for (sec=sec1;secs_flags&0xe0) for (rel=st+sec->s_relptr,rele=rel+(sec->s_flags&0x1000000 ? rel->r.r_count : sec->s_nreloc);relr_symndx,memory->cfd.cfd_start); fseek(fp,(void *)ste-st,0); while ((i = getc(fp)) == 0); ungetc(i, fp); massert(!un_mmap(st,est)); #ifdef CLEAR_CACHE CLEAR_CACHE; #endif call_init(init_address,memory,faslfile); if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %p ", memory->cfd.cfd_start); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.6.14/o/mych0000755000175000017500000000171214360276512012120 0ustar cammcammfrom main.c #else kcl_self = find_executable(argv[0]); #endif #ifdef NeXT #include #include static int is_executable(fn) char *fn; { struct stat s; return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG && access (fn, X_OK) != -1; } char * find_executable(fn) char *fn; { char *path, *getenv(); static char buf[MAXPATHLEN+1]; static char msg[100]; register char *p; for (p = fn; *p; p++) { if (*p == '/') { if (is_executable (fn)) return fn; else { sprintf(msg, "%s is not executable", fn); error(msg); } } } if ((path = getenv ("PATH")) == 0) error("PATH is undefined"); do { p = buf; while (*path && *path != ':') *p++ = *path++; if (*path) ++path; if (p > buf) *p++ = '/'; strcpy (p, fn); if (is_executable (buf)) return buf; } while (*path); sprintf(msg, "cannot find pathname of %s", fn); error(msg); } #endif gcl-2.6.14/o/sfaslmacosx.c0000644000175000017500000001604714360276512013730 0ustar cammcamm/* This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #include #include #include #include #include #include #include #include "ptable.h" typedef int (*func) (); /* Externalize the command line used to build loadable object files (a.k.a. bundles). */ object sSAmacosx_ldcmdA = 0L; #define sfasl_error(a,b...) {emsg(a,b);do_gcl_abort();} /* static void get_init_name (object faslfile, char *init_fun) */ /* { */ /* object path = coerce_to_pathname (faslfile); */ /* char *p; */ /* strcpy (init_fun, "_init_"); */ /* coerce_to_filename (path->pn.pn_name, init_fun + 6); */ /* for (p = init_fun + 6 ; *p ; p++) */ /* if (*p == '-') *p = '_'; */ /* } */ static NSSymbol get_init_sym(NSModule module,object ff) { static object inf; static struct string st; object x; char ib[MAXPATHLEN+1]; NSSymbol v; if (!inf) { object x; static struct string st; set_type_of(&st,t_string); st.st_self="COMPILER"; st.st_dim=st.st_fillp=strlen(st.st_self); if ((x=find_package((object)&st))==Cnil) sfasl_error("Cannot find compiler package\n"); st.st_self="INIT-NAME"; st.st_dim=st.st_fillp=strlen(st.st_self); if ((inf=find_symbol((object)&st,x))==Cnil) { inf=NULL; sfasl_error("Cannot find function COMPILER::INIT-NAME\n"); } } set_type_of(&st,t_string); st.st_self=ff->st.st_self; st.st_dim=st.st_fillp=ff->st.st_dim; x=ifuncall1(inf,(object)&st); if (x->d.t!=t_string) sfasl_error("INIT-NAME error\n"); assert(snprintf(ib,sizeof(ib),"_init_%-.*s",x->st.st_dim,x->st.st_self)>0); if (!(v=NSLookupSymbolInModule(module, ib))) { x=ifuncall2(inf,(object)&st,Ct); if (x->d.t!=t_string) sfasl_error("INIT-NAME error\n"); assert(snprintf(ib,sizeof(ib),"_init_%-.*s",x->st.st_dim,x->st.st_self)>0); if (!(v=NSLookupSymbolInModule(module, ib))) sfasl_error("Cannot lookup init-name\n"); } return v; } static func prepare_bundle (object faslfile, char *filename) { NSObjectFileImage image; NSModule module; NSSymbol nssym; int (*fptr) (); unsigned long n; unsigned long vmsize = 0; unsigned long vmaddr_slide = 0; unsigned long base_addr = (unsigned long) -1; extern void mark_region (unsigned long address, unsigned long size); if (NSCreateObjectFileImageFromFile (filename , &image) != NSObjectFileImageSuccess) { sfasl_error ("cannot create object file image\n"); } if (!(module = NSLinkModule (image, filename, NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_PRIVATE | NSLINKMODULE_OPTION_BINDNOW))) { sfasl_error ("cannot link bundle\n"); } nssym=get_init_sym(module,faslfile); /* if (!(nssym = NSLookupSymbolInModule (module, "_init_code"))) */ /* { */ /* char init_fun [256]; */ /* get_init_name (faslfile, init_fun); */ /* if (!(nssym = NSLookupSymbolInModule (module, init_fun))) { */ /* sfasl_error ("cannot retrieve entry point symbol in bundle\n"); */ /* } */ /* } */ if (!(fptr = (int (*) ()) NSAddressOfSymbol (nssym))) { sfasl_error ("cannot retrieve entry point address\n"); } for (n = _dyld_image_count () ; --n != (unsigned long) -1 ; ) { if (strstr (filename, _dyld_get_image_name (n))) { struct mach_header *mh = _dyld_get_image_header (n); struct load_command *lc = (struct load_command *) (mh+1); unsigned long i; vmsize = 0; for (i=0 ; i < mh->ncmds ; i++) { if (lc->cmd == LC_SEGMENT) { if (base_addr == (unsigned long) -1) { base_addr = ((struct segment_command *) lc)->vmaddr; } vmsize += ((struct segment_command *) lc)->vmsize; } lc = (struct load_command *) ((char *) lc + lc->cmdsize); } vmaddr_slide = _dyld_get_image_vmaddr_slide (n); break; } } if (base_addr != (unsigned long) -1) { mark_region (vmaddr_slide - base_addr, vmsize); } else { sfasl_error ("could not retrieve newly created bundle image\n"); } return (fptr); } int fasload (object faslfile) { object faslstream; object memory; object data; int (*fptr) (); char filename [MAXPATHLEN]; char tmpfile [MAXPATHLEN]; char cmd [256]; static int count = 0; static char ldfmt [] = "gcc -bind_at_load -bundle -bundle_loader %s -o %s %s"; char fmt [MAXPATHLEN]; extern int seek_to_end_ofile (FILE *); if (count == 0) { /* DEFVAR ("*MACOSX-LDCMD*",sSAmacosx_ldcmdA,LISP,make_simple_string(ldfmt),""); */ sSAmacosx_ldcmdA = make_special ("*MACOSX-LDCMD*", make_simple_string (ldfmt)); count = time (0); } coerce_to_filename (truename (faslfile), filename); snprintf (tmpfile, sizeof (tmpfile), "/tmp/ufas%dx.so", count++); mkstemp (tmpfile); symlink (filename, tmpfile); faslstream = open_stream (faslfile, smm_input, Cnil, sKerror); /* I guess the program will crash if a dumped image is ever dynamically relinked against a version of a shared library different from the one used at the time the bundle got loaded (if the bundle makes reference to this shared library). To avoid this, we would need all external bundle calls to be indirected through the loader image stubs. */ coerce_to_filename (symbol_value (sSAmacosx_ldcmdA), fmt); snprintf (cmd, sizeof(cmd), fmt, kcl_self, tmpfile, filename); if (system (cmd) != 0) { sfasl_error ("cannot execute command `%s'\n", cmd); } fptr = prepare_bundle (faslfile, tmpfile); if (seek_to_end_ofile (faslstream->sm.sm_fp) != 1) { sfasl_error ("error seeking to end of object file"); } close_stream (faslstream); memory=new_cfdata(); if (symbol_value (sLAload_verboseA) != Cnil) printf (" start address (dynamic) %p ", fptr); call_init (0,memory,faslstream); unlink (tmpfile); return memory->cfd.cfd_size; } void unlink_loaded_files () { } #include "sfasli.c" gcl-2.6.14/o/mingfile.c0000644000175000017500000000030414360276512013164 0ustar cammcamm#include "include.h" #include "winsock2.h" #include "windows.h" int mingwlisten(FILE *fp) { int c = 0; ioctlsocket(fileno(fp), FIONREAD, (void *)&c); if (c<=0) return 1; return 0; } gcl-2.6.14/o/gmp.c0000644000175000017500000000154614360276512012166 0ustar cammcamm#define ALLOCATE(n) (*gcl_gmp_allocfun)(n) void *gcl_gmp_alloc(size_t size) { return (void *) ALLOCATE(size); } static void *gcl_gmp_realloc(void *oldmem, size_t oldsize, size_t newsize) { unsigned int *old,*new; if (!jmp_gmp) { /* No gc in alloc if jmp_gmp */ if (MP_SELF(big_gcprotect)) do_gcl_abort(); MP_SELF(big_gcprotect)=oldmem; MP_ALLOCATED(big_gcprotect)=oldsize/MP_LIMB_SIZE; } new = (void *)ALLOCATE(newsize); old = jmp_gmp ? oldmem : MP_SELF(big_gcprotect); MP_SELF(big_gcprotect)=0; bcopy(old,new,oldsize); /* SGC contblock pages: Its possible this is on an old page CM 20030827 */ /* if (inheap(oldmem)) */ /* #ifdef SGC */ /* insert_maybe_sgc_contblock(oldmem,oldsize); */ /* #else */ /* insert_contblock(oldmem,oldsize); */ /* #endif */ return new; } static void gcl_gmp_free(void *old, size_t oldsize) { } gcl-2.6.14/o/usig.c0000755000175000017500000001717114360276512012356 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define _GNU_SOURCE 1 #include #ifdef __MINGW32__ #include /* sigset_t */ #endif #ifndef IN_UNIXINT #include "include.h" #include #endif #ifdef USIG #include USIG #else #ifdef HAVE_SIGACTION #define HAVE_SIGPROCMASK #endif #include "usig.h" extern char signals_handled[]; void gcl_signal(int signo, void (*handler) (/* ??? */)) { char *p = signals_handled; while (*p) { if (*p==signo) {our_signal_handler[signo] = handler; handler = main_signal_handler; break; } p++;} { #ifdef HAVE_SIGACTION struct sigaction action; action.sa_handler = handler; /* action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? SV_ONSTACK : 0) */ action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? SA_ONSTACK : 0) #ifdef SA_SIGINFO | SA_SIGINFO #endif ; sigemptyset(&action.sa_mask); /* sigaddset(&action.sa_mask,signo); */ sigaction(signo,&action,0); #else #ifdef HAVE_SIGVEC struct sigvec vec; vec.sv_handler = handler; vec.sv_flags = (signo == SIGSEGV || signo == SIGBUS ? SV_ONSTACK : 0); vec.sv_mask = sigmask(signo); sigvec(signo,&vec,0); #else signal(signo,handler); #endif #endif } } /* remove the signal n from the signal mask */ int unblock_signals(int n, int m) { int result = 0; int current_mask; #ifdef SIG_UNBLOCK_SIGNALS SIG_UNBLOCK_SIGNALS(result,n,n); #else #ifdef HAVE_SIGPROCMASK /* posix */ { sigset_t set,oset; sigemptyset(&set); sigaddset(&set,n); sigaddset(&set,m); sigprocmask(SIG_UNBLOCK,&set,&oset); current_mask=0; result =((sigismember(&oset,n) ? signal_mask(n) : current_mask) |(sigismember(&oset,m) ? signal_mask(m) : current_mask)); } #else current_mask = sigblock(0); sigsetmask(~(sigmask(m)) & ~(sigmask(n)) & current_mask); result = (current_mask & sigmask(m) ? signal_mask(m) : 0) | (current_mask & sigmask(n) ? signal_mask(n) : 0); #endif #endif return result; } void unblock_sigusr_sigio(void) { #ifdef HAVE_SIGPROCMASK /* posix */ { sigset_t set; sigemptyset(&set); sigaddset(&set,SIGUSR1); sigaddset(&set,SIGIO); sigprocmask( SIG_UNBLOCK,&set,0); } #else int current_mask = sigblock(0); return sigsetmask(~(sigmask(SIGIO))&~(sigmask(SIGUSR1)) & current_mask); #endif } DEFCONST("+MC-CONTEXT-OFFSETS+",sSPmc_context_offsetsP,SI,FPE_INIT,""); #if defined(__x86_64__) || defined(__i386__) #define ASM __asm__ __volatile__ DEFUN_NEW("FLD",object,fSfld,SI,1,1,NONE,OI,OO,OO,OO,(fixnum val),"") { volatile double d; ASM ("fldt %1;fstpl %0" : "=m" (d): "m" (*(char *)val)); RETURN1(make_longfloat(d)); } #endif /* For now ignore last three args governing offsets and data modification, just to support fpe sync with master*/ DEFUN_NEW("*FIXNUM",object,fSAfixnum,SI,4,4,NONE,II,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { RETURN1((object)*(fixnum *)addr); } DEFUN_NEW("*FLOAT",object,fSAfloat,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { RETURN1(make_shortfloat(*(float *)addr)); } DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,4,4,NONE,OI,OO,OO,OO,(fixnum addr,object x,object y,object z),"") { RETURN1(make_longfloat(*(double *)addr)); } DEFUN_NEW("FEENABLEEXCEPT",object,fSfeenableexcept,SI,1,1,NONE,II,OO,OO,OO,(fixnum x),"") { #ifdef HAVE_FEENABLEEXCEPT x=feenableexcept(x); #elif defined(__x86_64__) || defined(__i386__) #define ASM __asm__ __volatile__ { volatile unsigned short s=0; volatile unsigned int i; ASM("fnstcw %0" :: "m" (s)); s=(s|FE_ALL_EXCEPT)&(~x); ASM("fldcw %0" : "=m" (s)); ASM("stmxcsr %0" :: "m" (i)); i=(i|(FE_ALL_EXCEPT<<7))&(~(x<<7)); ASM("ldmxcsr %0" : "=m" (i)); } #endif RETURN1((object)x); } DEFUN_NEW("FEDISABLEEXCEPT",object,fSfedisableexcept,SI,0,0,NONE,IO,OO,OO,OO,(void),"") { fixnum x; #ifdef HAVE_FEENABLEEXCEPT feclearexcept(FE_ALL_EXCEPT); x=fedisableexcept(FE_ALL_EXCEPT); #elif defined(__x86_64__) || defined(__i386__) #define ASM __asm__ __volatile__ { volatile unsigned int i=0; ASM("fnclex"); ASM("stmxcsr %0" :: "m" (i)); i=(i|(FE_ALL_EXCEPT<<7)); ASM("ldmxcsr %0" : "=m" (i)); x=0; } #endif RETURN1((object)x); } #if defined(__x86_64__) || defined(__i386__) #define FE_TEST(x87sw_,mxcsr_,excepts_) ((x87sw_)&(excepts_))|(~((mxcsr_)>>7)&excepts_) DEFUN_NEW("FPE_CODE",object,fSfpe_code,SI,2,2,NONE,II,OO,OO,OO,(fixnum x87sw,fixnum mxcsr),"") { RETURN1((object)(long)(FE_TEST(x87sw,mxcsr,FE_INVALID) ? FPE_FLTINV : (FE_TEST(x87sw,mxcsr,FE_DIVBYZERO) ? FPE_FLTDIV : (FE_TEST(x87sw,mxcsr,FE_OVERFLOW) ? FPE_FLTOVF : (FE_TEST(x87sw,mxcsr,FE_UNDERFLOW) ? FPE_FLTUND : (FE_TEST(x87sw,mxcsr,FE_INEXACT) ? FPE_FLTRES : 0)))))); } #if defined(__MINGW32__) || defined(__CYGWIN__) DEFUN_NEW("FNSTSW",object,fSfnstsw,SI,0,0,NONE,II,OO,OO,OO,(void),"") { volatile unsigned short t=0; ASM ("fnstsw %0" :: "m" (t)); RETURN1((object)(long)t); } DEFUN_NEW("STMXCSR",object,fSstmxcsr,SI,0,0,NONE,II,OO,OO,OO,(void),"") { volatile unsigned int t=0; ASM ("stmxcsr %0" :: "m" (t)); RETURN1((object)(long)t); } #endif #endif static void sigfpe3(int sig,void *i,void *v) { unblock_signals(SIGFPE,SIGFPE); #ifdef __MINGW32__ gcl_signal(SIGFPE,sigfpe3); #endif ifuncall3(sSfloating_point_error,FPE_CODE(i,v),FPE_ADDR(i,v),FPE_CTXT(v)); } DEFCONST("+FE-LIST+",sSPfe_listP,SI,list(5, list(3,sLdivision_by_zero,make_fixnum(FPE_FLTDIV),make_fixnum(FE_DIVBYZERO)), list(3,sLfloating_point_overflow,make_fixnum(FPE_FLTOVF),make_fixnum(FE_OVERFLOW)), list(3,sLfloating_point_underflow,make_fixnum(FPE_FLTUND),make_fixnum(FE_UNDERFLOW)), list(3,sLfloating_point_inexact,make_fixnum(FPE_FLTRES),make_fixnum(FE_INEXACT)), list(3,sLfloating_point_invalid_operation,make_fixnum(FPE_FLTINV),make_fixnum(FE_INVALID))),""); DEF_ORDINARY("FLOATING-POINT-ERROR",sSfloating_point_error,SI,""); static void sigpipe(void) { unblock_signals(SIGPIPE,SIGPIPE); perror(""); FEerror("Broken pipe", 0); } void sigint(void) { unblock_signals(SIGINT,SIGINT); terminal_interrupt(1); } static void sigalrm(void) { unblock_signals(SIGALRM,SIGALRM); raise_pending_signals(sig_try_to_delay); } DEFVAR("*INTERRUPT-ENABLE*",sSAinterrupt_enableA,SI,sLt,""); DEF_ORDINARY("SIGUSR1-INTERRUPT",sSsigusr1_interrupt,SI,""); DEF_ORDINARY("SIGIO-INTERRUPT",sSsigio_interrupt,SI,""); static void sigusr1(void) {ifuncall1(sSsigusr1_interrupt,Cnil);} static void sigio(void) {ifuncall1(sSsigio_interrupt,Cnil);} static void sigterm(void) {do_gcl_abort();} void install_default_signals(void) { gcl_signal(SIGFPE, sigfpe3); gcl_signal(SIGPIPE, sigpipe); gcl_signal(SIGINT, sigint); gcl_signal(SIGTERM, sigterm); gcl_signal(SIGUSR1, sigusr1); gcl_signal(SIGIO, sigio); gcl_signal(SIGALRM, sigalrm); /*install_segmentation_catcher(); */ signals_allowed = sig_normal; } #endif gcl-2.6.14/o/fasldlsym.c0000755000175000017500000000563514360276512013407 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #include #include #ifdef HAVE_AOUT #include HAVE_AOUT #endif #if defined(HAVE_ELF_H) #include #elif defined(HAVE_ELF_ABI_H) #include #endif struct name_list { struct name_list *next; char name[1]; }; static struct name_list *loaded_files; static void unlink_loaded_files(void) { while(loaded_files) { unlink(loaded_files->name); loaded_files= loaded_files->next; } } int fasload(object faslfile) { void *dlp ; int (*fptr)(); char buf[MAXPATHLEN],b[MAXPATHLEN],filename[MAXPATHLEN]; static int count; object memory,data,faslstream; struct name_list *nl; object x; bzero(buf,sizeof(buf)); /*GC partial stack hole closing*/ bzero(b,sizeof(b)); bzero(filename,sizeof(filename)); /* this is just to allow reloading in the same file twice. */ coerce_to_filename(truename(faslfile), filename); if (!count) count=time(0); massert(snprintf(buf,sizeof(buf),"/tmp/ufas%dxXXXXXX",count++)>0); massert(mkstemp(buf)>=0); massert((nl=(void *) malloc(strlen(buf)+1+sizeof(nl)))); massert(loaded_files || !atexit(unlink_loaded_files)); nl->next = loaded_files; loaded_files = nl; strcpy(nl->name,buf); faslstream = open_stream(faslfile, smm_input, Cnil, sKerror); massert(snprintf(b,sizeof(b),"cc -shared %s -o %s",filename,buf)>0); massert(!psystem(b)); if (!(dlp = dlopen(buf,RTLD_NOW))) { emsg(dlerror()); FEerror("Cannot open for dynamic link ~a",1,make_simple_string(filename)); } x=find_init_name1(buf,0); massert(x->st.st_fillp+1st.st_self,x->st.st_fillp); b[x->st.st_fillp]=0; if (!(fptr=dlsym(dlp,b))) { emsg(dlerror()); FEerror("Cannot lookup ~a in ~a",2,make_simple_string(b),make_simple_string(filename)); } SEEK_TO_END_OFILE(faslstream->sm.sm_fp); data = read_fasl_vector(faslstream); memory=new_cfdata(); if(symbol_value(sLAload_verboseA)!=Cnil) printf(" start address (dynamic) %p ",fptr); call_init(0,memory,data,fptr); unlink(buf); close_stream(faslstream); return memory->cfd.cfd_size; } #include "sfasli.c" gcl-2.6.14/o/list.d0000755000175000017500000007250514360276512012365 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* list.d list manipulating routines */ #include "include.h" #include "page.h" static int reverse_comparison; #define TARG1(a,b) (reverse_comparison ? (b) : (a)) #define TARG2(a,b) (reverse_comparison ? (a) : (b)) object sKinitial_element; #define TEST(x) (*tf)(x) #define saveTEST \ object old_test_function = test_function; \ object old_item_compared = item_compared; \ bool (*old_tf)() = tf; \ object old_key_function = key_function; \ object (*old_kf)() = kf; \ VOL bool eflag = FALSE #define protectTEST \ frs_push(FRS_PROTECT, Cnil); \ if (nlj_active) { \ eflag = TRUE; \ goto L; \ } #define restoreTEST \ L: \ frs_pop(); \ test_function = old_test_function; \ item_compared = old_item_compared; \ tf = old_tf; \ key_function = old_key_function; \ kf = old_kf; \ if (eflag) { \ nlj_active = FALSE; \ unwind(nlj_fr, nlj_tag); \ } static bool test_compare(x) object x; { object b; vs_push((*kf)(x)); b = ifuncall2(test_function, TARG1(item_compared, vs_head), TARG2(item_compared, vs_head)); vs_popp; return(b != Cnil); } static bool test_compare_not(x) object x; { object b; vs_push((*kf)(x)); b = ifuncall2(test_function, TARG1(item_compared, vs_head), TARG2(item_compared, vs_head)); vs_popp; return(b == Cnil); } static bool test_eql(x) object x; { return(eql(item_compared, (*kf)(x))); } static object apply_key_function(x) object x; { return(ifuncall1(key_function, x)); } static object identity(x) object x; { return(x); } static void setupTEST(item, test, test_not, key) object item, test, test_not, key; { item_compared = item; if (test != Cnil) { if (test_not != Cnil) FEerror("Both :TEST and :TEST-NOT are specified.", 0); test_function = test; tf = test_compare; } else if (test_not != Cnil) { test_function = test_not; tf = test_compare_not; } else tf = test_eql; if (key != Cnil) { key_function = key; kf = apply_key_function; } else kf = identity; } #define PREDICATE(f, f_if, f_if_not, n) \ LFD(f_if)() \ { \ if (vs_top - vs_base < n) \ too_few_arguments(); \ vs_push(sKtest); \ vs_push(sLfuncall); \ f(); \ } \ \ LFD(f_if_not)() \ { \ if (vs_top - vs_base < n) \ too_few_arguments(); \ vs_push(sKtest_not); \ vs_push(sLfuncall); \ f(); \ } /* static bool endp1(x) object x; { if (type_of(x) == t_cons) return(FALSE); else * if (x == Cnil) * return(TRUE); vs_push(x); FEwrong_type_argument(sLlist, x); return(FALSE); }*/ object car(x) object x; { if (x == Cnil) return(x); if (type_of(x) == t_cons) return(x->c.c_car); FEwrong_type_argument(sLlist, x); return(Cnil); } object cdr(x) object x; { if (x == Cnil) return(x); if (type_of(x) == t_cons) return(x->c.c_cdr); FEwrong_type_argument(sLlist, x); return(Cnil); } object kar(x) object x; { if (type_of(x) == t_cons) return(x->c.c_car); FEwrong_type_argument(sLcons, x); return(Cnil); } /* static object kdr(x) object x; { if (type_of(x) == t_cons) return(x->c.c_cdr); FEwrong_type_argument(sLcons, x); return(Cnil); }*/ void stack_cons(void) { object d=vs_pop,a=vs_pop; *vs_top++ = make_cons(a,d); } /*static object on_stack_list_vector(n,ap) int n; va_list ap; {object res=(object) alloca_val; struct cons *p; object x; p=(struct cons *) res; if (n<=0) return Cnil; TOP: p->t = (int)t_cons; p->m=FALSE; p->c_car= va_arg(ap,object); if (--n == 0) {p->c_cdr = Cnil; return res;} else { x= (object) p; x->c.c_cdr= (object) ( ++p);} goto TOP; }*/ object on_stack_list_vector_new(int n,object first,va_list ap) {object res=(object) alloca_val; struct cons *p; object x; int jj=0; p=(struct cons *) res; if (n<=0) return Cnil; TOP: #ifdef WIDE_CONS set_type_of(p,t_cons); #endif p->c_car= jj||first==OBJNULL ? va_arg(ap,object) : first; jj=1; if (--n == 0) {p->c_cdr = Cnil; return res;} else { x= (object) p; x->c.c_cdr= (object) ( ++p);} goto TOP; } /* static object list_vector(n,ap) int n; va_list ap; {object ans,*p; if (n == 0) return Cnil; ans = make_cons(va_arg(ap,object),Cnil); p = & (ans->c.c_cdr); while (--n > 0) { *p = make_cons(va_arg(ap,object),Cnil); p = & ((*p)->c.c_cdr); } return ans; }*/ object list_vector_new(int n,object first,va_list ap) { object ans,*p; for (p=&ans;n-->0;first=OBJNULL) collect(p,make_cons(first==OBJNULL ? va_arg(ap,object) : first,Cnil)); *p=Cnil; return ans; } #ifdef WIDE_CONS #define maybe_set_type_of(a,b) set_type_of(a,b) #else #define maybe_set_type_of(a,b) #endif void free_check(void) { int n=tm_table[t_cons].tm_nfree,m; object f=tm_table[t_cons].tm_free; for (m=0;f!=OBJNULL;m++,f=OBJ_LINK(f)); massert(n==m); } #define multi_cons(n_,next_,last_) \ ({_tm->tm_nfree -= n_; \ for(_x=_tm->tm_free,_p=&_x;n_-->0;_p=&(*_p)->c.c_cdr) { \ object _z=*_p; \ pageinfo(_z)->in_use++; \ maybe_set_type_of(_z,t_cons); \ _z->c.c_cdr=OBJ_LINK(_z); \ _z->c.c_car=next_; \ } \ _tm->tm_free=*_p; \ *_p=SAFE_CDR(last_); \ _x;}) #define n_cons(n_,next_,last_) \ ({fixnum _n=n_;object _x=Cnil,*_p; \ static struct typemanager *_tm=tm_table+t_cons; \ if (_n>=0) {/*FIXME vs_toptm_nfree) \ _x=multi_cons(_n,next_,last_); \ else { \ for (_p=&_x;_n--;) \ collect(_p,make_cons(next_,Cnil)); \ *_p=SAFE_CDR(last_); \ } \ END_NO_INTERRUPT; \ } \ _x;}) object n_cons_from_x(fixnum n,object x) { return n_cons(n,({object _z=x->c.c_car;x=x->c.c_cdr;_z;}),Cnil); } object listqA(int a,int n,va_list ap) { return n_cons(n,va_arg(ap,object),a ? va_arg(ap,object) : Cnil); } object list(fixnum n,...) { va_list ap; object lis; va_start(ap,n); lis=listqA(0,n,ap); va_end(ap); return lis; } object listA(fixnum n,...) { va_list ap; object lis; va_start(ap,n); lis=listqA(1,n-1,ap); va_end(ap); return lis; } static bool tree_equal(x, y) object x, y; { cs_check(x); BEGIN: if (type_of(x) == t_cons) if (type_of(y) == t_cons) if (tree_equal(x->c.c_car, y->c.c_car)) { x = x->c.c_cdr; y = y->c.c_cdr; goto BEGIN; } else return(FALSE); else return(FALSE); else { item_compared = x; if (TEST(y)) return(TRUE); else return(FALSE); } } object append(object x, object y) { return n_cons(length(x),({object _t=x->c.c_car;x=x->c.c_cdr;_t;}),y); } /* Copy_list(x) copies list x. */ object copy_list(object x) { object h,y; if (type_of(x) != t_cons) return(x); h=y=make_cons(x->c.c_car, Cnil); for (x = x->c.c_cdr; type_of(x) == t_cons; x = x->c.c_cdr) { y->c.c_cdr = make_cons(x->c.c_car, Cnil); y=y->c.c_cdr; } y->c.c_cdr=SAFE_CDR(x); return(h); } /* Copy_alist(x) copies alist x. */ static object copy_alist(object x) { object h,y; if (endp(x)) return(Cnil); h=y=make_cons(Cnil, Cnil); for (;;) { y->c.c_car=make_cons(car(x->c.c_car), cdr(x->c.c_car)); x=x->c.c_cdr; if (endp(x)) break; y->c.c_cdr=make_cons(Cnil, Cnil); y=y->c.c_cdr; } return(h); } static object copy_tree(object x) { object y; if (type_of(x) == t_cons) { y=make_cons(Cnil,Cnil); y->c.c_car=copy_tree(x->c.c_car); y->c.c_cdr=copy_tree(x->c.c_cdr); x=y; } return x; } /* Nsubst(new, treep) stores the result of nsubstituting new in *treep to *treep. */ static void nsubst(new, treep) object new, *treep; { cs_check(new); if (TEST(*treep)) *treep = new; else if (type_of(*treep) == t_cons) { nsubst(new, &(*treep)->c.c_car); nsubst(new, &(*treep)->c.c_cdr); } } /* Sublis(alist, tree) pushes result of substituting tree by alist onto vs. */ static object sublis(object alist, object tree) { object x; cs_check(alist); for (x=alist;!endp(x);x=x->c.c_cdr) { item_compared=car(x->c.c_car); if (TEST(tree)) return x->c.c_car->c.c_cdr; } if (type_of(tree) == t_cons) { object a=sublis(alist,tree->c.c_car),d=sublis(alist,tree->c.c_cdr); return (a==tree->c.c_car && d==tree->c.c_cdr) ? tree : make_cons(a,d); } else return tree; } /* Nsublis(alist, treep) stores the result of substiting *treep by alist to *treep. */ static void nsublis(alist, treep) object alist, *treep; { object x; cs_check(alist); for (x = alist; !endp(x); x = x->c.c_cdr) { item_compared = car(x->c.c_car); if (TEST(*treep)) { *treep = x->c.c_car->c.c_cdr; return; } } if (type_of(*treep) == t_cons) { nsublis(alist, &(*treep)->c.c_car); nsublis(alist, &(*treep)->c.c_cdr); } } LFD(Lcar)() { check_arg(1); if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil) vs_base[0] = vs_base[0]->c.c_car; else FEwrong_type_argument(sLlist, vs_base[0]); } LFD(Lcdr)() { check_arg(1); if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil) vs_base[0] = vs_base[0]->c.c_cdr; else FEwrong_type_argument(sLlist, vs_base[0]); } object caar(x) object x; { return(car(car(x))); } object cadr(x) object x; { return(car(cdr(x))); } object cdar(x) object x; { return(cdr(car(x))); } object cddr(x) object x; { return(cdr(cdr(x))); } object caaar(x) object x; { return(car(car(car(x)))); } object caadr(x) object x; { return(car(car(cdr(x)))); } object cadar(x) object x; { return(car(cdr(car(x)))); } object caddr(x) object x; { return(car(cdr(cdr(x)))); } object cdaar(x) object x; { return(cdr(car(car(x)))); } object cdadr(x) object x; { return(cdr(car(cdr(x)))); } object cddar(x) object x; { return(cdr(cdr(car(x)))); } object cdddr(x) object x; { return(cdr(cdr(cdr(x)))); } object caaaar(x) object x; { return(car(car(car(car(x))))); } object caaadr(x) object x; { return(car(car(car(cdr(x))))); } object caadar(x) object x; { return(car(car(cdr(car(x))))); } object caaddr(x) object x; { return(car(car(cdr(cdr(x))))); } object cadaar(x) object x; { return(car(cdr(car(car(x))))); } object cadadr(x) object x; { return(car(cdr(car(cdr(x))))); } object caddar(x) object x; { return(car(cdr(cdr(car(x))))); } object cadddr(x) object x; { return(car(cdr(cdr(cdr(x))))); } object cdaaar(x) object x; { return(cdr(car(car(car(x))))); } object cdaadr(x) object x; { return(cdr(car(car(cdr(x))))); } object cdadar(x) object x; { return(cdr(car(cdr(car(x))))); } object cdaddr(x) object x; { return(cdr(car(cdr(cdr(x))))); } object cddaar(x) object x; { return(cdr(cdr(car(car(x))))); } object cddadr(x) object x; { return(cdr(cdr(car(cdr(x))))); } object cdddar(x) object x; { return(cdr(cdr(cdr(car(x))))); } object cddddr(x) object x; { return(cdr(cdr(cdr(cdr(x))))); } LFD(Lcaar)(){ check_arg(1); vs_base[0] = car(car(vs_base[0])); } LFD(Lcadr)(){ check_arg(1); vs_base[0] = car(cdr(vs_base[0])); } LFD(Lcdar)(){ check_arg(1); vs_base[0] = cdr(car(vs_base[0])); } LFD(Lcddr)(){ check_arg(1); vs_base[0] = cdr(cdr(vs_base[0])); } LFD(Lcaaar)(){ check_arg(1); vs_base[0] = car(car(car(vs_base[0]))); } LFD(Lcaadr)(){ check_arg(1); vs_base[0] = car(car(cdr(vs_base[0]))); } LFD(Lcadar)(){ check_arg(1); vs_base[0] = car(cdr(car(vs_base[0]))); } LFD(Lcaddr)(){ check_arg(1); vs_base[0] = car(cdr(cdr(vs_base[0]))); } LFD(Lcdaar)(){ check_arg(1); vs_base[0] = cdr(car(car(vs_base[0]))); } LFD(Lcdadr)(){ check_arg(1); vs_base[0] = cdr(car(cdr(vs_base[0]))); } LFD(Lcddar)(){ check_arg(1); vs_base[0] = cdr(cdr(car(vs_base[0]))); } LFD(Lcdddr)(){ check_arg(1); vs_base[0] = cdr(cdr(cdr(vs_base[0]))); } LFD(Lcaaaar)(){check_arg(1); vs_base[0] = car(car(car(car(vs_base[0]))));} LFD(Lcaaadr)(){check_arg(1); vs_base[0] = car(car(car(cdr(vs_base[0]))));} LFD(Lcaadar)(){check_arg(1); vs_base[0] = car(car(cdr(car(vs_base[0]))));} LFD(Lcaaddr)(){check_arg(1); vs_base[0] = car(car(cdr(cdr(vs_base[0]))));} LFD(Lcadaar)(){check_arg(1); vs_base[0] = car(cdr(car(car(vs_base[0]))));} LFD(Lcadadr)(){check_arg(1); vs_base[0] = car(cdr(car(cdr(vs_base[0]))));} LFD(Lcaddar)(){check_arg(1); vs_base[0] = car(cdr(cdr(car(vs_base[0]))));} LFD(Lcadddr)(){check_arg(1); vs_base[0] = car(cdr(cdr(cdr(vs_base[0]))));} LFD(Lcdaaar)(){check_arg(1); vs_base[0] = cdr(car(car(car(vs_base[0]))));} LFD(Lcdaadr)(){check_arg(1); vs_base[0] = cdr(car(car(cdr(vs_base[0]))));} LFD(Lcdadar)(){check_arg(1); vs_base[0] = cdr(car(cdr(car(vs_base[0]))));} LFD(Lcdaddr)(){check_arg(1); vs_base[0] = cdr(car(cdr(cdr(vs_base[0]))));} LFD(Lcddaar)(){check_arg(1); vs_base[0] = cdr(cdr(car(car(vs_base[0]))));} LFD(Lcddadr)(){check_arg(1); vs_base[0] = cdr(cdr(car(cdr(vs_base[0]))));} LFD(Lcdddar)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(car(vs_base[0]))));} LFD(Lcddddr)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(cdr(vs_base[0]))));} int endp_error(object x) { FEwrong_type_argument(sLlist,x); return 0; } DEFUNO_NEW("NTH",object,fLnth,LISP,2,2,NONE,OI,OO,OO,OO,void,Lnth,(fixnum index,object y),"") { object x = y; if (index < 0) FEerror("Negative index: ~D.", 1, make_fixnum(index)); while (1) {if (type_of(x)==t_cons) { if (index == 0) RETURN1(Mcar(x)); else {x = Mcdr(x); index--;}} else if (x == sLnil) RETURN1(sLnil); else FEwrong_type_argument(sLlist, y);} } #ifdef STATIC_FUNCTION_POINTERS object fLnth(fixnum index,object list) { return FFN(fLnth)(index,list); } #endif DEFUN_NEW("FIRST",object,fLfirst,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(car(x)) ;} DEFUN_NEW("SECOND",object,fLsecond,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(1,x);} DEFUN_NEW("THIRD",object,fLthird,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(2,x);} DEFUN_NEW("FOURTH",object,fLfourth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(3,x);} DEFUN_NEW("FIFTH",object,fLfifth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(4,x);} DEFUN_NEW("SIXTH",object,fLsixth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(5,x);} DEFUN_NEW("SEVENTH",object,fLseventh,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(6,x);} DEFUN_NEW("EIGHTH",object,fLeighth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(7,x);} DEFUN_NEW("NINTH",object,fLninth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(8,x);} DEFUN_NEW("TENTH",object,fLtenth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { return fLnth(9,x);} LFD(Lcons)() { check_arg(2); vs_base[0]=make_cons(vs_base[0],vs_pop); } @(defun tree_equal (x y &key test test_not) saveTEST; @ protectTEST; setupTEST(Cnil, test, test_not, Cnil); x=(tree_equal(x, y) ? Ct : Cnil); restoreTEST; @(return x) @) LFD(Lendp)() { check_arg(1); if (vs_base[0] == Cnil) { vs_base[0] = Ct; return; } if (type_of(vs_base[0]) == t_cons) { vs_base[0] = Cnil; return; } FEwrong_type_argument(sLlist, vs_base[0]); } LFD(Llist_length)() { int n; object fast, slow; check_arg(1); n = 0; fast = slow = vs_base[0]; for (;;) { if (endp(fast)) { vs_base[0] = make_fixnum(n); return; } if (endp(fast->c.c_cdr)) { vs_base[0] = make_fixnum(n + 1); return; } if (fast == slow && n > 0) { vs_base[0] = Cnil; return; } n += 2; fast = fast->c.c_cdr->c.c_cdr; slow = slow->c.c_cdr; } } object nth(int n, object x) { if (n < 0) { vs_push(make_fixnum(n)); FEerror("Negative index: ~D.", 1, vs_head); } while (n-- > 0) if (endp(x)) { return(Cnil); } else x = x->c.c_cdr; if (endp(x)) return(Cnil); else return(x->c.c_car); } LFD(Lnthcdr)() { check_arg(2); vs_base[0] = nthcdr(fixint(vs_base[0]), vs_base[1]); vs_popp; } object nthcdr(int n, object x) { if (n < 0) { vs_push(make_fixnum(n)); FEwrong_type_argument(sLpositive_fixnum, vs_head); } while (n-- > 0) if (endp_prop(x)) { return(Cnil); } else x = x->c.c_cdr; return(x); } LFD(Llast)() { object t; int n; n=vs_top-vs_base; if (n<1) FEtoo_few_arguments(vs_base,vs_top); if (n>2) FEtoo_many_arguments(vs_base,vs_top); if (endp(vs_base[0])) return; if (n==2) { if (type_of(vs_base[1])!=t_fixnum || (n=fix(vs_base[1]))<0) FEwrong_type_argument(sLpositive_fixnum,vs_base[1]); vs_popp; } if (!n) while (type_of(vs_base[0]) == t_cons) vs_base[0]=vs_base[0]->c.c_cdr; else { t=vs_base[0]; while (type_of(vs_base[0]->c.c_cdr) == t_cons && --n) vs_base[0] = vs_base[0]->c.c_cdr; while (type_of(vs_base[0]->c.c_cdr) == t_cons) { t=t->c.c_cdr; vs_base[0] = vs_base[0]->c.c_cdr; } vs_base[0]=t; } } LFD(Llist)() { object *a; a=vs_base; vs_base[0]=n_cons(vs_top-vs_base,*a++,Cnil); vs_top=vs_base+1; } LFD(LlistA)() { object *a; if (vs_top == vs_base) too_few_arguments(); a=vs_base; vs_base[0]=n_cons(vs_top-vs_base-1,*a++,vs_head); vs_top=vs_base+1; } object on_stack_make_list(n) int n; { object res=(object) alloca_val; struct cons *p = (struct cons *)res; if (n<=0) return Cnil; TOP: #ifdef WIDE_CONS set_type_of(p,t_cons); #endif p->c_car=Cnil; if (--n == 0) {p->c_cdr = Cnil; return res;} else {object x= (object) p; x->c.c_cdr= (object) ( ++p);} goto TOP; } object make_list(int n) { return n_cons(n,Cnil,Cnil); } @(defun make_list (size &key initial_element &aux x) @ check_type_non_negative_integer(&size); if (type_of(size) != t_fixnum) FEerror("Cannot make a list of the size ~D.", 1, size); x=n_cons(fix(size),initial_element,Cnil); @(return x) @) LFD(Lappend)() { object x; if (vs_top == vs_base) { vs_push(Cnil); return; } while (vs_top > vs_base + 1) { x = append(vs_top[-2], vs_top[-1]); vs_top[-2] = x; vs_popp; } } LFD(Lcopy_list)() { check_arg(1); vs_base[0] = copy_list(vs_base[0]); } LFD(Lcopy_alist)() { check_arg(1); vs_base[0] = copy_alist(vs_base[0]); } LFD(Lcopy_tree)() { check_arg(1); vs_base[0]=copy_tree(vs_base[0]); } LFD(Lrevappend)() { object x, y; check_arg(2); y=vs_pop; for (x=vs_base[0];!endp(x);x=x->c.c_cdr) y=make_cons(x->c.c_car,y); vs_base[0] = y; } object nconc(object x, object y) { object x1; if (endp(x)) return(y); for (x1 = x; !endp(x1->c.c_cdr); x1 = x1->c.c_cdr) ; x1->c.c_cdr = SAFE_CDR(y); return(x); } LFD(Lnconc)() { object x, l, m=Cnil; int i, narg; narg = vs_top - vs_base - 1; if (narg < 0) { vs_push(Cnil); return; } x = Cnil; for (i = 0; i < narg; i++) { l = vs_base[i]; if (endp(l)) continue; if (x == Cnil) x = m = l; else { m->c.c_cdr = SAFE_CDR(l); m = l; } for (; type_of(m->c.c_cdr)==t_cons; m = m->c.c_cdr); } if (x == Cnil) vs_base[0] = vs_top[-1]; else { m->c.c_cdr = SAFE_CDR(vs_top[-1]); vs_base[0] = x; } vs_top = vs_base+1; } LFD(Lreconc)() { object x, y, z; check_arg(2); y = vs_pop; for (x = vs_base[0]; !endp_prop(x);) { z = x; x = x->c.c_cdr; z->c.c_cdr = SAFE_CDR(y); y = z; } vs_base[0] = y; } @(defun butlast (lis &optional (nn `make_fixnum(1)`)) int i; object *p,x,y,z; @ check_type_non_negative_integer(&nn); if (!listp(lis))/*FIXME checktype*/ FEwrong_type_argument(sLlist, lis); if (type_of(nn) != t_fixnum) @(return Cnil) for (x=y=lis,i=0;ic.c_cdr); for (p=&z;consp(y);x=x->c.c_cdr,y=y->c.c_cdr) collect(p,make_cons(x->c.c_car,Cnil)); *p=i ? Cnil : x; @(return `z`) @) @(defun nbutlast (lis &optional (nn `make_fixnum(1)`)) int i; object x; @ check_type_non_negative_integer(&nn); if (!listp(lis))/*FIXME checktype*/ FEwrong_type_argument(sLlist, lis); if (type_of(nn) != t_fixnum) @(return Cnil) for (i = 0, x = lis; consp(x); i++, x = x->c.c_cdr); if (i <= fix((nn))) @(return Cnil) for (i -= fix((nn)), x = lis; --i > 0; x = x->c.c_cdr) ; x->c.c_cdr = Cnil; @(return lis) @) LFD(Lldiff)() { fixnum i; object x,y,*p,z; check_arg(2); x=vs_base[0]; z=vs_pop; if (!listp(x))/*FIXME checktype*/ FEwrong_type_argument(sLlist, x); for (p=&y,i=0;consp(x) && x!=z;i++,x=x->c.c_cdr) collect(p,make_cons(x->c.c_car,Cnil)); *p=eql(x,z) ? Cnil : x; vs_base[0]=y; } LFD(Lrplaca)() { check_arg(2); check_type_cons(&vs_base[0]); take_care(vs_base[1]); vs_base[0]->c.c_car = vs_base[1]; vs_popp; } LFD(Lrplacd)() { check_arg(2); check_type_cons(&vs_base[0]); vs_base[0]->c.c_cdr = SAFE_CDR(vs_base[1]); vs_popp; } /* @(defun subst (new old tree &key test test_not key) */ /* saveTEST; */ /* @ */ /* protectTEST; */ /* setupTEST(old, test, test_not, key); */ /* subst(new, tree); */ /* tree = vs_pop; */ /* /\* if (kf==identity && *\/ */ /* /\* tf==test_eql && *\/ */ /* /\* (is_imm_fixnum(item_compared) || *\/ */ /* /\* ({enum type tp=type_of(item_compared);tp>t_complex || tpc.c_cdr) { if ((*tst)(v->c.c_car->c.c_car,tree)) return(v->c.c_car->c.c_cdr);} if (type_of(tree)==t_cons){ object a=sublis1(alist,tree->c.c_car,tst),d=sublis1(alist,tree->c.c_cdr,tst); return a==tree->c.c_car && d==tree->c.c_cdr ? tree : make_cons(a,d); } return tree; } /* static int eq(x,y) object x,y; {return (x==y);}*/ void check_alist(alist) object alist; {object v; for (v=alist ; !endp(v) ; v=v->c.c_cdr) {if (type_of(v->c.c_car) != t_cons && v->c.c_car != Cnil) FEerror("Not alist",0);} return ; } @(defun sublis (alist tree &key test test_not key) saveTEST; @ protectTEST; setupTEST(Cnil, test, test_not, key); tree=sublis(alist,tree); restoreTEST; @(return tree) @) @(defun nsublis (alist tree &key test test_not key) saveTEST; @ protectTEST; setupTEST(Cnil, test, test_not, key); nsublis(alist, &tree); restoreTEST; @(return tree) @) @(defun member (item list &key test test_not key) saveTEST; @ protectTEST; setupTEST(item, test, test_not, key); while (!endp_prop(list)) { if (TEST(list->c.c_car)) goto L; list = list->c.c_cdr; } restoreTEST; @(return list) @) PREDICATE(Lmember,Lmember_if,Lmember_if_not, 2) @(static defun member1 (item list &key test test_not key rev) saveTEST; @ protectTEST; if (key != Cnil) item = ifuncall1(key, item); if (rev != Cnil) reverse_comparison=1; setupTEST(item, test, test_not, key); while (!endp(list)) { if (TEST(list->c.c_car)) goto L; list = list->c.c_cdr; } restoreTEST; reverse_comparison=0; @(return list) @) LFD(Ltailp)() { object x; check_arg(2); for (x = vs_base[1]; consp(x); x = x->c.c_cdr) if (x==vs_base[0]) { vs_base[0] = Ct; vs_popp; return; } if (eql(x,vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; vs_popp; return; } LFD(Ladjoin)() { object *base = vs_base, *top = vs_top; if (vs_top - vs_base < 2) too_few_arguments(); while (vs_base < top) vs_push(*vs_base++); FFN(Lmember1)(); if (vs_base[0] == Cnil) base[1] = make_cons(base[0], base[1]); vs_base = base+1; vs_top = base+2; } LFD(Lacons)() { check_arg(3); vs_base[0] = make_cons(vs_base[0], vs_base[1]); vs_base[0] = make_cons(vs_base[0], vs_base[2]); vs_top -= 2; } @(defun pairlis (keys data &optional a_list) object k,d,y,z,*p; @ k=keys; d=data; p=&y; while (!endp(k)) { if (endp(d)) FEerror("The keys ~S and the data ~S are not of the same length",2,keys,data); z=make_cons(Cnil,Cnil); z->c.c_car=make_cons(k->c.c_car,d->c.c_car); collect(p,z); k = k->c.c_cdr; d = d->c.c_cdr; } if (!endp(d)) FEerror("The keys ~S and the data ~S are not of the same length",2,keys,data); *p=a_list; vs_top=vs_base+1; @(return `y`) @) @(static defun assoc_or_rassoc (item a_list &key test test_not key) saveTEST; @ protectTEST; setupTEST(item, test, test_not, key); while (!endp(a_list)) { if (TEST((*car_or_cdr)(a_list->c.c_car)) && a_list->c.c_car != Cnil) { a_list = a_list->c.c_car; goto L; } a_list = a_list->c.c_cdr; } restoreTEST; @(return a_list) @) LFD(Lassoc)() { car_or_cdr = car; FFN(Lassoc_or_rassoc)(); } LFD(Lrassoc)() { car_or_cdr = cdr; FFN(Lassoc_or_rassoc)(); } static bool true_or_false; @(static defun assoc_or_rassoc_predicate (predicate a_list &key key) object x; @ while (!endp(a_list)) { if (a_list->c.c_car!=Cnil) { x=(*car_or_cdr)(a_list->c.c_car); if (key!=Cnil) x=ifuncall1(key,x); if ((ifuncall1(predicate,x) != Cnil) == true_or_false) @(return `a_list->c.c_car`) } a_list = a_list->c.c_cdr; } @(return a_list) @) LFD(Lassoc_if)() { car_or_cdr = car; true_or_false = TRUE; FFN(Lassoc_or_rassoc_predicate)(); } LFD(Lassoc_if_not)() { car_or_cdr = car; true_or_false = FALSE; FFN(Lassoc_or_rassoc_predicate)(); } LFD(Lrassoc_if)() { car_or_cdr = cdr; true_or_false = TRUE; FFN(Lassoc_or_rassoc_predicate)(); } LFD(Lrassoc_if_not)() { car_or_cdr = cdr; true_or_false = FALSE; FFN(Lassoc_or_rassoc_predicate)(); } bool member_eq(x, l) object x, l; { for (; type_of(l) == t_cons; l = l->c.c_cdr) if (x == l->c.c_car) return(TRUE); return(FALSE); } static void FFN(siLmemq)() { object x, l; check_arg(2); x = vs_base[0]; l = vs_base[1]; for (; type_of(l) == t_cons; l = l->c.c_cdr) if (x == l->c.c_car) { vs_base[0] = l; vs_popp; return; } vs_base[0] = Cnil; vs_popp; } void delete_eq(x, lp) object x, *lp; { for (; type_of(*lp) == t_cons; lp = &(*lp)->c.c_cdr) if ((*lp)->c.c_car == x) { *lp = (*lp)->c.c_cdr; return; } } DEFUN_NEW("STATIC-INVERSE-CONS",object,fSstatic_inverse_cons,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { object y=(object)x; return is_imm_fixnum(y) ? Cnil : (is_imm_fixnum(y->c.c_cdr) ? y : (y->d.f||y->d.e ? Cnil : y)); } void gcl_init_list_function() { sKtest = make_keyword("TEST"); sKtest_not = make_keyword("TEST-NOT"); sKkey = make_keyword("KEY"); sKrev = make_keyword("REV"); sKinitial_element = make_keyword("INITIAL-ELEMENT"); make_function("CAR", Lcar); make_function("CDR", Lcdr); make_function("CAAR", Lcaar); make_function("CADR", Lcadr); make_function("CDAR", Lcdar); make_function("CDDR", Lcddr); make_function("CAAAR", Lcaaar); make_function("CAADR", Lcaadr); make_function("CADAR", Lcadar); make_function("CADDR", Lcaddr); make_function("CDAAR", Lcdaar); make_function("CDADR", Lcdadr); make_function("CDDAR", Lcddar); make_function("CDDDR", Lcdddr); make_function("CAAAAR", Lcaaaar); make_function("CAAADR", Lcaaadr); make_function("CAADAR", Lcaadar); make_function("CAADDR", Lcaaddr); make_function("CADAAR", Lcadaar); make_function("CADADR", Lcadadr); make_function("CADDAR", Lcaddar); make_function("CADDDR", Lcadddr); make_function("CDAAAR", Lcdaaar); make_function("CDAADR", Lcdaadr); make_function("CDADAR", Lcdadar); make_function("CDADDR", Lcdaddr); make_function("CDDAAR", Lcddaar); make_function("CDDADR", Lcddadr); make_function("CDDDAR", Lcdddar); make_function("CDDDDR", Lcddddr); make_function("CONS", Lcons); make_function("TREE-EQUAL", Ltree_equal); make_function("ENDP", Lendp); make_function("LIST-LENGTH", Llist_length); make_function("REST", Lcdr); make_function("NTHCDR", Lnthcdr); make_function("LAST", Llast); make_function("LIST", Llist); make_function("LIST*", LlistA); make_function("MAKE-LIST", Lmake_list); make_function("APPEND", Lappend); make_function("COPY-LIST", Lcopy_list); make_function("COPY-ALIST", Lcopy_alist); make_function("COPY-TREE", Lcopy_tree); make_function("REVAPPEND", Lrevappend); make_function("NCONC", Lnconc); make_function("NRECONC", Lreconc); make_function("BUTLAST", Lbutlast); make_function("NBUTLAST", Lnbutlast); make_function("LDIFF", Lldiff); make_function("RPLACA", Lrplaca); make_function("RPLACD", Lrplacd); /* make_function("SUBST", Lsubst); */ /* make_function("SUBST-IF", Lsubst_if); */ /* make_function("SUBST-IF-NOT", Lsubst_if_not); */ make_function("NSUBST", Lnsubst); make_function("NSUBST-IF", Lnsubst_if); make_function("NSUBST-IF-NOT", Lnsubst_if_not); make_function("SUBLIS", Lsublis); make_function("NSUBLIS", Lnsublis); make_function("MEMBER", Lmember); make_function("MEMBER-IF", Lmember_if); make_function("MEMBER-IF-NOT", Lmember_if_not); make_si_function("MEMBER1", Lmember1); make_function("TAILP", Ltailp); make_function("ADJOIN", Ladjoin); make_function("ACONS", Lacons); make_function("PAIRLIS", Lpairlis); make_function("ASSOC", Lassoc); make_function("ASSOC-IF", Lassoc_if); make_function("ASSOC-IF-NOT", Lassoc_if_not); make_function("RASSOC", Lrassoc); make_function("RASSOC-IF", Lrassoc_if); make_function("RASSOC-IF-NOT", Lrassoc_if_not); make_si_function("MEMQ", siLmemq); } gcl-2.6.14/o/assignment.c0000755000175000017500000003254514360276512013561 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* assignment.c Assignment */ #include "include.h" static object setf(object,object); object sLsetf; object sLget; object sLgetf; object sLaref; object sLsvref; object sLelt; object sLchar; object sLschar; object sLfill_pointer; object sLgethash; object sLcar; object sLcdr; object sLpush; object sLpop; object sLincf; object sLdecf; object sSstructure_access; object sSsetf_lambda; object sSclear_compiler_properties; object sLwarn; object sSAinhibit_macro_specialA; void setq(object sym, object val) { object vd; enum stype type; if(type_of(sym) != t_symbol) not_a_symbol(sym); type = (enum stype)sym->s.s_stype; if(type == stp_special) sym->s.s_dbind = val; else if (type == stp_constant) FEinvalid_variable("Cannot assign to the constant ~S.", sym); else { vd = lex_var_sch(sym); if(MMnull(vd) || endp(MMcdr(vd))) sym->s.s_dbind = val; else MMcadr(vd) = val; } } static void FFN(Fsetq)(object form) { object ans; if (endp(form)) { vs_base = vs_top; vs_push(Cnil); } else { object *top = vs_top; do { vs_top = top; if (endp(MMcdr(form))) FEinvalid_form("No value for ~S.", form->c.c_car); setq(MMcar(form),ans=Ieval(MMcadr(form))); form = MMcddr(form); } while (!endp(form)); top[0]=ans; vs_base=top; vs_top= top+1; } } static void FFN(Fpsetq)(object arg) { object *old_top = vs_top; object *top; object argsv = arg; for (top = old_top; !endp(arg); arg = MMcddr(arg), top++) { if(endp(MMcdr(arg))) FEinvalid_form("No value for ~S.", arg->c.c_car); top[0] = Ieval(MMcadr(arg)); vs_top = top + 1; } for (arg = argsv, top = old_top; !endp(arg); arg = MMcddr(arg), top++) setq(MMcar(arg),top[0]); vs_base = vs_top = old_top; vs_push(Cnil); } DEFUNO_NEW("SET",object,fLset,LISP ,2,2,NONE,OO,OO,OO,OO,void,Lset,(object symbol,object value),"") { /* 2 args */ if (type_of(symbol) != t_symbol) not_a_symbol(symbol); if ((enum stype)symbol->s.s_stype == stp_constant) FEinvalid_variable("Cannot assign to the constant ~S.", symbol); symbol->s.s_dbind = value; RETURN1(value); } DEFUNO_NEW("FSET",object,fSfset,SI ,2,2,NONE,OO,OO,OO,OO,void,siLfset,(object sym,object function),"") { /* 2 args */ if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL) { if (sym->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) sym->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, sym); } sym = clear_compiler_properties(sym,function); if (sym->s.s_hpack == lisp_package && sym->s.s_gfdef != OBJNULL && !raw_image) { ifuncall2(sLwarn,make_simple_string("~S is being redefined."), sym); } if (type_of(function) == t_cfun || type_of(function) == t_sfun || type_of(function) == t_vfun || type_of(function) == t_gfun || type_of(function) == t_cclosure|| type_of(function) == t_closure || type_of(function) == t_afun ) { sym->s.s_gfdef = function; sym->s.s_mflag = FALSE; } else if (car(function) == sLspecial) FEerror("Cannot define a special form.", 0); else if (function->c.c_car == sSmacro) { sym->s.s_gfdef = function->c.c_cdr; sym->s.s_mflag = TRUE; } else { sym->s.s_gfdef = function; sym->s.s_mflag = FALSE; } RETURN1(function); } #ifdef STATIC_FUNCTION_POINTERS object fSfset(object sym,object function) { return FFN(fSfset)(sym,function); } #endif static void FFN(Fmultiple_value_setq)(object form) { object vars; int n, i; if (endp(form) || endp(form->c.c_cdr) || !endp(form->c.c_cdr->c.c_cdr)) FEinvalid_form("~S is an illegal argument to MULTIPLE-VALUE-SETQ", form); vars = form->c.c_car; fcall.values[0]=Ieval(form->c.c_cdr->c.c_car); n = fcall.nvalues; for (i = 0; !endp(vars); i++, vars = vars->c.c_cdr) if (i < n) setq(vars->c.c_car, fcall.values[i]); else setq(vars->c.c_car, Cnil); vs_base[0]=fcall.values[0]; vs_top = vs_base+1; } DEFUNO_NEW("MAKUNBOUND",object,fLmakunbound,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lmakunbound,(object sym),"") { /* 1 args */ if (type_of(sym) != t_symbol) not_a_symbol(sym); if ((enum stype)sym->s.s_stype == stp_constant) FEinvalid_variable("Cannot unbind the constant ~S.", sym); sym->s.s_dbind = OBJNULL; RETURN1(sym); } object sStraced; DEFUNO_NEW("FMAKUNBOUND",object,fLfmakunbound,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lfmakunbound,(object sym),"") { /* 1 args */ if(type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL) { if (sym->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) sym->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, sym); } remf(&(sym->s.s_plist),sStraced); clear_compiler_properties(sym,Cnil); if (sym->s.s_hpack == lisp_package && sym->s.s_gfdef != OBJNULL && !raw_image) { ifuncall2(sLwarn, make_simple_string( "~S is being redefined."), sym); } sym->s.s_gfdef = OBJNULL; sym->s.s_mflag = FALSE; RETURN1(sym); } static void FFN(Fsetf)(object form) { object *t,*t1; if (endp(form)) { vs_base = vs_top; vs_push(Cnil); } else { object *top = vs_top; do { vs_top = top; if (endp(MMcdr(form))) FEinvalid_form("No value for ~S.", form->c.c_car); setf(MMcar(form), MMcadr(form)); form = MMcddr(form); } while (!endp(form)); t=vs_base; t1=vs_top; vs_top = vs_base = top; for (;tc.c_car; if (type_of(fun) != t_symbol) goto OTHERWISE; args = place->c.c_cdr; if (fun == sLget) { object sym,val,key; sym = Ieval(car(args)); key = Ieval(car(Mcdr(args))); val = Ieval(form); return putprop(sym,val,key); } if (fun == sLgetf) Ieval(Mcaddr(args)); if (fun == sLaref) { f = siLaset; goto EVAL; } if (fun == sLsvref) { f = siLsvset; goto EVAL; } if (fun == sLelt) { f = siLelt_set; goto EVAL; } if (fun == sLchar) { f = siLchar_set; goto EVAL; } if (fun == sLschar) { f = siLchar_set; goto EVAL; } if (fun == sLfill_pointer) { f = siLfill_pointer_set; goto EVAL; } if (fun == sLgethash) { f = siLhash_set; goto EVAL; } if (fun == sLcar) { x = Ieval(Mcar(args)); result = Ieval(form); if (type_of(x) != t_cons) FEerror("~S is not a cons.", 1, x); Mcar(x) = result; return result; } if (fun == sLcdr) { x = Ieval(Mcar(args)); result = Ieval(form); if (type_of(x) != t_cons) FEerror("~S is not a cons.", 1, x); Mcdr(x) = result; return result; } x = getf(fun->s.s_plist, sSstructure_access, Cnil); if (x == Cnil || type_of(x) != t_cons) goto OTHERWISE; if (getf(fun->s.s_plist, sSsetf_lambda, Cnil) == Cnil) goto OTHERWISE; if (type_of(x->c.c_cdr) != t_fixnum) goto OTHERWISE; i = fix(x->c.c_cdr); /* if (i < 0) goto OTHERWISE; */ x = x->c.c_car; y = Ieval(Mcar(args)); result = Ieval(form); if (x == sLvector) { if (type_of(y) != t_vector || i >= y->v.v_fillp) goto OTHERWISE; y->v.v_self[i] = result; } else if (x == sLlist) { for (x = y; i > 0; --i) x = cdr(x); if (type_of(x) != t_cons) goto OTHERWISE; x->c.c_car = result; } else { structure_set(y, x, i, result); } return result; EVAL: for (; !endp(args); args = args->c.c_cdr) { eval_push(args->c.c_car); } eval_push(form); vs_base = vs; (*f)(); return vs_base[0]; OTHERWISE: vs_base = vs_top; vs_push(list(3,sLsetf,place,result=form)); /***/ #define VS_PUSH_ENV \ if(lex_env[1]){ \ vs_push(list(3,lex_env[0],lex_env[1],lex_env[2]));} \ else {vs_push(Cnil);} VS_PUSH_ENV ; /***/ if (!sLsetf->s.s_mflag || sLsetf->s.s_gfdef == OBJNULL) FEerror("Where is SETF?", 0); funcall(sLsetf->s.s_gfdef); return Ieval(vs_base[0]); } static void FFN(Fpush)(object form) { object var; if (endp(form) || endp(MMcdr(form))) FEtoo_few_argumentsF(form); if (!endp(MMcddr(form))) FEtoo_many_argumentsF(form); var = MMcadr(form); if (type_of(var) != t_cons) { eval(MMcar(form)); form = vs_base[0]; eval(var); vs_base[0] = MMcons(form, vs_base[0]); setq(var, vs_base[0]); return; } vs_base = vs_top; vs_push(make_cons(sLpush,form)); /***/ VS_PUSH_ENV ; /***/ if (!sLpush->s.s_mflag || sLpush->s.s_gfdef == OBJNULL) FEerror("Where is PUSH?", 0); funcall(sLpush->s.s_gfdef); eval(vs_base[0]); } static void FFN(Fpop)(object form) { object var; if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form))) FEtoo_many_argumentsF(form); var = MMcar(form); if (type_of(var) != t_cons) { eval(var); setq(var, cdr(vs_base[0])); vs_base[0] = car(vs_base[0]); return; } vs_base = vs_top; vs_push(make_cons(sLpop,form)); /***/ VS_PUSH_ENV ; /***/ if (!sLpop->s.s_mflag || sLpop->s.s_gfdef == OBJNULL) FEerror("Where is POP?", 0); funcall(sLpop->s.s_gfdef); eval(vs_base[0]); } static void FFN(Fincf)(object form) { object var; object one_plus(object x), number_plus(object x, object y); if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form)) && !endp(MMcddr(form))) FEtoo_many_argumentsF(form); var = MMcar(form); if (type_of(var) != t_cons) { if (endp(MMcdr(form))) { eval(var); vs_base[0] = one_plus(vs_base[0]); setq(var, vs_base[0]); return; } eval(MMcadr(form)); form = vs_base[0]; eval(var); vs_base[0] = number_plus(vs_base[0], form); setq(var, vs_base[0]); return; } vs_base = vs_top; vs_push(make_cons(sLincf,form)); /***/ VS_PUSH_ENV ; /***/ if (!sLincf->s.s_mflag || sLincf->s.s_gfdef == OBJNULL) FEerror("Where is INCF?", 0); funcall(sLincf->s.s_gfdef); eval(vs_base[0]); } static void FFN(Fdecf)(object form) { object var; object one_minus(object x), number_minus(object x, object y); if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form)) && !endp(MMcddr(form))) FEtoo_many_argumentsF(form); var = MMcar(form); if (type_of(var) != t_cons) { if (endp(MMcdr(form))) { eval(var); vs_base[0] = one_minus(vs_base[0]); setq(var, vs_base[0]); return; } eval(MMcadr(form)); form = vs_base[0]; eval(var); vs_base[0] = number_minus(vs_base[0], form); setq(var, vs_base[0]); return; } vs_base = vs_top; vs_push(make_cons(sLdecf,form)); /***/ VS_PUSH_ENV ; /***/ if (!sLdecf->s.s_mflag || sLdecf->s.s_gfdef == OBJNULL) FEerror("Where is DECF?", 0); funcall(sLdecf->s.s_gfdef); eval(vs_base[0]); } /* object */ /* clear_compiler_properties(object sym, object code) */ /* { object tem; */ /* VFUN_NARGS=2; fSuse_fast_links(Cnil,sym); */ /* tem = getf(sym->s.s_plist,sStraced,Cnil); */ /* if (sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind != Cnil) */ /* (void)ifuncall2(sSclear_compiler_properties, sym,code); */ /* if (tem != Cnil) return tem; */ /* return sym; */ /* } */ DEF_ORDINARY("CLEAR-COMPILER-PROPERTIES",sSclear_compiler_properties,SI,""); DEFUN_NEW("CLEAR-COMPILER-PROPERTIES",object,fSclear_compiler_properties,SI ,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { /* 2 args */ RETURN1(Cnil); } DEF_ORDINARY("AREF",sLaref,LISP,""); DEF_ORDINARY("CAR",sLcar,LISP,""); DEF_ORDINARY("CDR",sLcdr,LISP,""); DEF_ORDINARY("CHAR",sLchar,LISP,""); DEF_ORDINARY("DECF",sLdecf,LISP,""); DEF_ORDINARY("ELT",sLelt,LISP,""); DEF_ORDINARY("FILL-POINTER",sLfill_pointer,LISP,""); DEF_ORDINARY("GET",sLget,LISP,""); DEF_ORDINARY("GETF",sLgetf,LISP,""); DEF_ORDINARY("GETHASH",sLgethash,LISP,""); DEF_ORDINARY("INCF",sLincf,LISP,""); DEF_ORDINARY("POP",sLpop,LISP,""); DEF_ORDINARY("PUSH",sLpush,LISP,""); DEF_ORDINARY("SCHAR",sLschar,LISP,""); DEF_ORDINARY("SETF",sLsetf,LISP,""); DEF_ORDINARY("SETF-LAMBDA",sSsetf_lambda,SI,""); DEF_ORDINARY("STRUCTURE-ACCESS",sSstructure_access,SI,""); DEF_ORDINARY("SVREF",sLsvref,LISP,""); DEF_ORDINARY("TRACED",sStraced,SI,""); DEF_ORDINARY("VECTOR",sLvector,LISP,""); void gcl_init_assignment(void) { make_special_form("SETQ", Fsetq); make_special_form("PSETQ", Fpsetq); make_special_form("MULTIPLE-VALUE-SETQ", Fmultiple_value_setq); sLsetf=make_special_form("SETF", Fsetf); sLpush=make_special_form("PUSH", Fpush); sLpop=make_special_form("POP", Fpop); sLincf=make_special_form("INCF", Fincf); sLdecf=make_special_form("DECF", Fdecf); } gcl-2.6.14/o/unixsys.c0000755000175000017500000000746214360276512013133 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #include #include #ifndef __MINGW32__ #include #endif #include "include.h" #if !defined(__MINGW32__) && !defined(__CYGWIN__) int vsystem(const char *command) { unsigned j,n=strlen(command)+1; char *z,*c; const char *x1[]={"/bin/sh","-c",NULL,NULL},*spc=" \n\t",**p1,**pp; int s; pid_t pid; if (strpbrk(command,"\"'$<>")) (p1=x1)[2]=command; else { massert(n0); massert(pid==waitpid(pid,&s,0)); if ((s>>8)&128) emsg("execvp failure when executing '%s': %s\n",command,strerror((s>>8)&0x7f)); return s; } #elif defined(__CYGWIN__) #include #include #include #include int vsystem(const char *command) { STARTUPINFO s={0}; PROCESS_INFORMATION p={0}; unsigned int e; char *cmd=NULL,*r; massert((r=strpbrk(command," \n\t"))-command=0); command=FN1; s.cb=sizeof(s); massert(CreateProcess(cmd,(void *)command,NULL,NULL,FALSE,0,NULL,NULL,&s,&p)); massert(!WaitForSingleObject(p.hProcess,INFINITE)); massert(GetExitCodeProcess(p.hProcess,&e)); massert(CloseHandle(p.hProcess)); massert(CloseHandle(p.hThread)); return e; } #endif #ifdef ATT3B2 #include int system(command) char *command; { char buf[4]; extern sigint(); signal(SIGINT, SIG_IGN); write(4, command, strlen(command)+1); read(5, buf, 1); signal(SIGINT, sigint); return(buf[0]<<8); } #endif #ifdef E15 #include int system(command) char *command; { char buf[4]; extern sigint(); signal(SIGINT, SIG_IGN); write(4, command, strlen(command)+1); read(5, buf, 1); signal(SIGINT, sigint); return(buf[0]<<8); } #endif int msystem(const char *s) { return psystem(s); } static void FFN(siLsystem)(void) { char command[32768]; int i; check_arg(1); check_type_string(&vs_base[0]); if (vs_base[0]->st.st_fillp >= 32768) FEerror("Too long command line: ~S.", 1, vs_base[0]); for (i = 0; i < vs_base[0]->st.st_fillp; i++) command[i] = vs_base[0]->st.st_self[i]; command[i] = '\0'; {int old = signals_allowed; int res; signals_allowed = sig_at_read; res = msystem(command) ; signals_allowed = old; vs_base[0] = make_fixnum(res >> 8); vs_base[1] = make_fixnum((res & 0xff)); vs_top++; } } DEFUN_NEW("GETPID",object,fSgetpid,SI,0,0,NONE,OO,OO,OO,OO,(void), "getpid returns the process ID of the current process") { return make_fixnum(getpid()); } void gcl_init_unixsys(void) { make_si_function("SYSTEM", siLsystem); } gcl-2.6.14/o/gcl_readline.d0000644000175000017500000002015214360276512014006 0ustar cammcamm/* Copyright (C) 2000 Tuukka Toivonen This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* readline.d Here we have GNU Readline 4.0 library interface. */ #define IN_READLINE #include "include.h" #ifdef USE_READLINE /* Here begins GNU Readline support. It was designed for Maxima, * but it works with GCL fine too. If you want to include word completion * code, define RL_COMPLETION, else undefine it. * Todo: context sensitive completion, optional keywords. * To support Readline, we define wrappers (emulation) for putc/ungetc. * by Tuukka Toivonen 2000-07-25, 2000-10-2. */ #define RL_COMPLETION #include #include #include #include #include #include #include int readline_on = 0; /* On (1) or off (0) */ static int rl_ungetc_em_char = -1; static char *rl_putc_em_line = NULL; #ifdef RL_COMPLETION /* New completion generator avoids malloc excet where required, and dynamically searches current package lists -- 20040102 CM */ /* FIXME -- consider mapping malloc to alloca for this function only */ DEFVAR("*READLINE-PREFIX*",sSAreadline_prefixA,SI,Cnil,""); static char * rl_completion_words(const char *text, int state) { static int i,len,internal,size,prefl; static object package,use,tp,*base,l; static const char *ftext,*wtext,*pref; if (state==0) { const char *mch,*fmch,*temp,*temp1,*fpref; int fprefl; fpref=pref=fmch=NULL; fprefl=prefl=0; if (type_of(sSAreadline_prefixA->s.s_dbind)==t_string) { pref=fpref=sSAreadline_prefixA->s.s_dbind->st.st_self; prefl=fprefl=sSAreadline_prefixA->s.s_dbind->st.st_fillp; if ((fmch=memchr(fpref,':',fprefl))) { pref=fmch[1]==':' ? fmch+2 : fmch+1; prefl-=pref-fpref; } } mch=strchr(text,':'); if (!mch) { temp=fmch; temp1=fpref; } else { temp=mch; temp1=text; pref=NULL; prefl=0; } if (!temp) package=sLApackageA->s.s_dbind; else { if (temp==temp1) package=(temp[1]==':') ? sLApackageA->s.s_dbind : keyword_package; else { static struct string st; set_type_of(&st,t_string); st.st_self=(char *)temp1; st.st_fillp=st.st_dim=temp-temp1; st.st_hasfillp=1; package=find_package((object)&st); } } package=package ? package : user_package; use=package->p.p_uselist; internal=temp && temp[1]==':' ? 1 : 0; ftext=text; wtext=mch ? mch+1 : ftext; wtext=*wtext==':' ? wtext+1 : wtext; len=strlen(wtext); tp=package; i=0; base=internal ? tp->p.p_internal : tp->p.p_external; size=internal ? tp->p.p_internal_size : tp->p.p_external_size; l=base[i]; } while (tp && tp != Cnil) { while (1) { while (type_of(l)==t_cons) { struct symbol sym=l->c.c_car->s; l=l->c.c_cdr; if (pref) { if (sym.s_fillp=len && !strncasecmp(wtext,sym.s_self,len)) { static char *c; c=malloc((wtext-ftext)+sym.s_fillp+1); memcpy(c,ftext,wtext-ftext); memcpy(c+(wtext-ftext),sym.s_self,sym.s_fillp); c[(wtext-ftext)+sym.s_fillp]=0; return c; } } if (++i==size) break; l=base[i]; } tp=use->c.c_car; use=use->c.c_cdr; base=internal ? tp->p.p_internal : tp->p.p_external; size=internal ? tp->p.p_internal_size : tp->p.p_external_size; i=0; l=base[i]; } return NULL; } #ifndef HAVE_DECL_RL_COMPLETION_MATCHES /* readline 4.3 has it, readline 4.1 has completion_matches instead */ #define rl_completion_matches completion_matches #endif #ifndef HAVE_RL_COMPENTRY_FUNC_T /* same here */ typedef char *rl_compentry_func_t(const char *, int); #endif #endif static int my_getc(FILE *f) { int c; BEGIN_NO_INTERRUPT; c=getc(f); END_NO_INTERRUPT; return c; } static int my_putc(int c,FILE *f) { BEGIN_NO_INTERRUPT; c=putc(c,f); END_NO_INTERRUPT; return c; } int rl_putc_em(int c, FILE *f) { static int allocated_length = 0; static int current_length = 0; char *old_line; if (f!=stdout || !isatty(fileno(f)) ) goto tail; if (c=='\r' || c=='\n') { current_length = 0; if (allocated_length>0) rl_putc_em_line[0] = 0; goto tail; } if (current_length+2 > allocated_length) { allocated_length = (current_length+8)*2; old_line = rl_putc_em_line; rl_putc_em_line = realloc(old_line, allocated_length); if (rl_putc_em_line==NULL) { free(old_line); allocated_length = 0; current_length = 0; goto tail; } } rl_putc_em_line[current_length++] = (unsigned char)c; rl_putc_em_line[current_length] = 0; tail: return my_putc(c, f); } #include static jmp_buf readline_jmp_buf; static void readline_sigint_handler(int c,siginfo_t *i,void *v) { longjmp(readline_jmp_buf,1); } static char * call_readline() { struct sigaction siga,old_siga; char *line; sigaction(SIGINT,NULL,&old_siga); siga=old_siga; siga.sa_sigaction=readline_sigint_handler; if (setjmp(readline_jmp_buf)) { sigaction(SIGINT,&old_siga,NULL); sigint(); line=malloc(1); line[0]=0; } else { my_putc('\r', stdout); sigaction(SIGINT,&siga,&old_siga); line=readline(rl_putc_em_line); sigaction(SIGINT,&old_siga,NULL); rl_putc_em('\r', stdout); } return line; } static int line_eof_p,line_eol_p; int rl_getc_em(FILE *f) { static char *line; static int linepos; if (f!=stdin || !isatty(fileno(f))) return my_getc(f); if (rl_ungetc_em_char!=-1) { int r = rl_ungetc_em_char; rl_ungetc_em_char = -1; return r; } line_eof_p=line_eol_p=0; if (line==NULL) { if (readline_on==1) { line = call_readline(); if (line==NULL) {line_eof_p=1;return EOF;} if (line[0] != 0) add_history(line); } else { static int c,nlp; if (!nlp) { fd_set fds; int n=fileno(f); FD_ZERO(&fds); FD_SET(n,&fds); while (select(n+1,&fds,NULL,NULL,NULL)<=0); nlp=1; } c=my_getc(f); if (c==10) nlp=0; return c; } } if (line[linepos]==0) { free(line); line = NULL; linepos = 0; line_eol_p=1; return '\n'; } return line[linepos++]; } int rl_stream_p(FILE *f) { return readline_on && f==stdin && isatty(fileno(f)); } int rl_pending_buffered_input_p(FILE *f) { return line_eof_p||line_eol_p ? FALSE :TRUE; } int rl_eof_p(FILE *f) { return line_eof_p ? TRUE : FALSE; } int rl_ungetc_em(int c, FILE *f) { if (f!=stdin || !isatty(fileno(f)) ) return ungetc(c, f); rl_ungetc_em_char = ((unsigned char)c); return c; } static void FFN(siLreadline_on)() { const char *cp; if (!isatty(0)) { FEerror("GCL is not being run from a terminal", 0); return; } if ((cp=getenv("TERM")) && !strcmp(cp,"dumb")) { FEerror("Controlling terminal is not readline capable", 0); return; } readline_on=1; return; } static void FFN(siLreadline_off)() { readline_on=0; return; } void gcl_init_readline_function(void) { char *cp=getenv("TERM"); *my_rl_readline_name_ptr="GCL"; #ifdef RL_COMPLETION *my_rl_completion_entry_function_ptr = rl_completion_words; #endif if (isatty(0) && (!cp || strcmp(cp,"dumb"))) readline_on=1; } void gcl_init_readline(void) { make_si_function("READLINE-ON", siLreadline_on); make_si_function("READLINE-OFF", siLreadline_off); } #endif /* USE_READLINE */ gcl-2.6.14/o/xdrfuns.c0000755000175000017500000000777414360276512013110 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #ifdef HAVE_XDR #ifdef DARWIN #undef __LP64__ /*Apple header declaration bug workaround for xdr_long*/ #endif #ifdef AIX3 #include #endif #ifdef __CYGWIN__ #include #else /* __CYGWIN__ */ #include #endif /* __CYGWIN__ */ extern short aet_sizes[]; static object FFN(siGxdr_open)(f) object f; { XDR *xdrs; object ar= alloc_simple_string(sizeof(XDR)); array_allocself(ar,1,OBJNULL); xdrs= (XDR *) ar->a.a_self; if (f->sm.sm_fp == 0) FEerror("stream not ok for xdr io",0); xdrstdio_create(xdrs, f->sm.sm_fp, (f->sm.sm_mode == smm_input ? XDR_DECODE : f->sm.sm_mode == smm_output ? XDR_ENCODE : (FEerror("stream not input or output",0),XDR_ENCODE))) ; return ar; } static object FFN(siGxdr_write)(object str,object elt) { XDR *xdrp= (XDR *) str->ust.ust_self; xdrproc_t e; switch (type_of(elt)) { case t_fixnum: { fixnum e=fix(elt); if(xdr_long(xdrp,(long *)&e)) goto error; } break; case t_longfloat: if(xdr_double(xdrp,&lf(elt))) goto error; break; case t_shortfloat: if(xdr_float(xdrp,&sf(elt))) goto error; break; case t_vector: switch(elt->v.v_elttype) { case aet_lf: e=(xdrproc_t)xdr_double; break; case aet_sf: e=(xdrproc_t)xdr_float; break; case aet_fix: e=(xdrproc_t)xdr_long; break; case aet_short: e=(xdrproc_t)xdr_short; break; default: FEerror("unsupported xdr size",0); goto error; break; } { u_int tmp=elt->v.v_fillp; if (tmp!=elt->v.v_fillp) goto error; if(xdr_array(xdrp,(void *)&elt->v.v_self, &tmp, elt->v.v_dim, aet_sizes[elt->v.v_elttype], e)) goto error; } break; default: FEerror("unsupported xdr ~a",1,elt); break; } return elt; error: FEerror("bad xdr write",0); return elt; } static object FFN(siGxdr_read)(object str,object elt) { XDR *xdrp= (XDR *) str->ust.ust_self; xdrproc_t e; switch (type_of(elt)) { case t_fixnum: {fixnum l; if(xdr_long(xdrp,(long *)&l)) goto error; return make_fixnum(l);} break; case t_longfloat: {double x; if(xdr_double(xdrp,&x)) goto error; return make_longfloat(x);} case t_shortfloat: {float x; if(xdr_float(xdrp,&x)) goto error; return make_shortfloat(x);} case t_vector: switch(elt->v.v_elttype) { case aet_lf: e=(xdrproc_t)xdr_double; break; case aet_sf: e=(xdrproc_t)xdr_float; break; case aet_fix: e=(xdrproc_t)xdr_long; break; case aet_short: e=(xdrproc_t)xdr_short; break; default: FEerror("unsupported xdr size",0); goto error; break; } { u_int tmp=elt->v.v_fillp; if (tmp!=elt->v.v_fillp) goto error; if(xdr_array(xdrp,(void *)&elt->v.v_self, &tmp, elt->v.v_dim, aet_sizes[elt->v.v_elttype], e)) goto error; } return elt; break; default: FEerror("unsupported xdr ~a",1,elt); return elt; break; } error: FEerror("bad xdr read",0); return elt; } static void gcl_init_xdrfuns() { make_si_sfun("XDR-WRITE",siGxdr_write, ARGTYPE2(f_object,f_object)|RESTYPE(f_object)); make_si_sfun("XDR-READ",siGxdr_read, ARGTYPE2(f_object,f_object)|RESTYPE(f_object)); make_si_sfun("XDR-OPEN",siGxdr_open, ARGTYPE1(f_object)|RESTYPE(f_object)); } #else static void gcl_init_xdrfuns(void) {;} #endif gcl-2.6.14/o/nsocket.c0000644000175000017500000004071014360276512013045 0ustar cammcamm/* the following file compiles under win95 using cygwinb19 */ #include #include "include.h" #include #ifdef DODEBUG #define dprintf(s,arg) emsg(s,arg) #else #define dprintf(s,arg) #endif #ifdef HAVE_NSOCKET #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ /****************end for sockets *******************/ /* * These bits may be ORed together into the "flags" field of a TcpState * structure. */ #define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ #define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ /* * The following defines the maximum length of the listen queue. This is * the number of outstanding yet-to-be-serviced requests for a connection * on a server socket, more than this number of outstanding requests and * the connection request will fail. */ #ifndef SOMAXCONN #define SOMAXCONN 100 #endif #if (SOMAXCONN < 100) #undef SOMAXCONN #define SOMAXCONN 100 #endif #define VOID void #define ERROR_MESSAGE(msg) do{ emsg(msg); do_gcl_abort() ; } while(0) #ifdef STAND main(argc,argv) char *argv[]; int argc; { char buf[1000]; char out[1000]; char op[10]; int n,fd; int x,y,ans,errno; char *bp; fd_set readfds; struct timeval timeout; bp = buf; fd = doConnect(argv[1],atoi(argv[2])); if (fd < 0) { perror("cant connect"); do_gcl_abort(); } while (1) { int high; timeout.tv_sec = 20; timeout.tv_usec = 0; FD_ZERO(&readfds); FD_SET(fd,&readfds); high = select(fd+1,&readfds,NULL,NULL,&timeout); if (high > 0) { int n; n = read(fd,buf,sizeof(buf)); if (3 == sscanf(buf,"%d %s %d",&x,op,&y)) { switch (op[0]) { case '+': sprintf(out,"%d\n",x+y); break; case '*': sprintf(out,"%d\n",x*y); break; default: sprintf(out,"bad operation\n"); } write(fd,out,strlen(out)); } } } } #endif /* *---------------------------------------------------------------------- * * CreateSocketAddress -- * * This function initializes a sockaddr structure for a host and port. * * Results: * 1 if the host was valid, 0 if the host could not be converted to * an IP address. * * Side effects: * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ static int CreateSocketAddress(struct sockaddr_in *sockaddrPtr, char *host, int port) /* Socket address */ /* Host. NULL implies INADDR_ANY */ /* Port number */ { struct hostent *hostent; /* Host database entry */ struct in_addr addr; /* For 64/32 bit madness */ (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); sockaddrPtr->sin_family = AF_INET; sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); if (host == NULL) { addr.s_addr = INADDR_ANY; } else { addr.s_addr = inet_addr(host); if (addr.s_addr == -1) { hostent = /* gethostbyname(host); */ #ifdef STATIC_LINKING NULL; #else gethostbyname(host); #endif if (hostent != NULL) { memcpy((VOID *) &addr, (VOID *) hostent->h_addr_list[0], (size_t) hostent->h_length); } else { #ifdef EHOSTUNREACH errno = EHOSTUNREACH; #else #ifdef ENXIO errno = ENXIO; #endif #endif return 0; /* error */ } } } /* * NOTE: On 64 bit machines the assignment below is rumored to not * do the right thing. Please report errors related to this if you * observe incorrect behavior on 64 bit machines such as DEC Alphas. * Should we modify this code to do an explicit memcpy? */ sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ } /* return -1 on failure, or else an fd */ int CreateSocket(int port, char *host, int server, char *myaddr, int myport, int async) /* Port number to open. */ /* Name of host on which to open port. * NULL implies INADDR_ANY */ /* 1 if socket should be a server socket, * else 0 for a client socket. */ /* Optional client-side address */ /* Optional client-side port */ /* If nonzero and creating a client socket, * attempt to do an async connect. Otherwise * do a synchronous connect or bind. */ { int status, sock, /* asyncConnect, */curState, origState; struct sockaddr_in sockaddr; /* socket address */ struct sockaddr_in mysockaddr; /* Socket address for client */ sock = -1; origState = 0; if (! CreateSocketAddress(&sockaddr, host, port)) { goto addressError; } if ((myaddr != NULL || myport != 0) && ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { goto addressError; } sock = socket(AF_INET, SOCK_STREAM, 0); if (sock < 0) { goto addressError; } /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ fcntl(sock, F_SETFD, FD_CLOEXEC); /* asyncConnect = 0; */ status = 0; if (server) { /* * Set up to reuse server addresses automatically and bind to the * specified port. */ status = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, sizeof(status)); status = bind(sock, (struct sockaddr *) &sockaddr, sizeof(struct sockaddr)); if (status != -1) { status = listen(sock, SOMAXCONN); } } else { if (myaddr != NULL || myport != 0) { curState = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &curState, sizeof(curState)); status = bind(sock, (struct sockaddr *) &mysockaddr, sizeof(struct sockaddr)); if (status < 0) { goto bindError; } } /* * Attempt to connect. The connect may fail at present with an * EINPROGRESS but at a later time it will complete. The caller * will set up a file handler on the socket if she is interested in * being informed when the connect completes. */ if (async) { #ifndef USE_FIONBIO origState = fcntl(sock, F_GETFL); curState = origState | O_NONBLOCK; status = fcntl(sock, F_SETFL, curState); #endif #ifdef USE_FIONBIO curState = 1; status = ioctl(sock, FIONBIO, &curState); #endif } else { status = 0; } if (status > -1) { status = connect(sock, (struct sockaddr *) &sockaddr, sizeof(sockaddr)); if (status < 0) { if (errno == EINPROGRESS) { /* asyncConnect = 1; */ status = 0; } } } } bindError: if (status < 0) { ERROR_MESSAGE("couldn't open socket:"); if (sock != -1) { close(sock); } return -1; } return sock; addressError: if (sock != -1) { close(sock); } ERROR_MESSAGE("couldn't open socket:"); return -1; } #ifdef STAND int doConnect(host,port) char *host; /*name of host we are trying to connect to */ int port; /* port number to use */ { return CreateSocket(port, host, 0 , NULL , 0 , 0); } #endif #define SOCKET_FD(strm) ((strm)->sm.sm_fp ? fileno((strm)->sm.sm_fp) : -1) static void check_socket(object x) { if (type_of(x) != t_stream || x->sm.sm_mode != smm_socket) FEwrong_type_argument(sSsocket,x); } DEFUN_NEW("GETPEERNAME",object,fSgetpeername,SI,1,1,NONE,OO,OO,OO,OO,(object sock), "Return a list of three elements: the address, the hostname and the port for the other end of the socket. If hostname is not available it will be equal to the address. Invalid on server sockets. Return NIL on failure.") { struct sockaddr_in peername; socklen_t size = sizeof(struct sockaddr_in); struct hostent *hostEntPtr; object address,host; check_socket(sock); if (getpeername(SOCKET_FD(sock), (struct sockaddr *) &peername, &size) >= 0) { address=make_simple_string(inet_ntoa(peername.sin_addr)); hostEntPtr = /* gethostbyaddr((char *) &(peername.sin_addr), */ /* sizeof(peername.sin_addr), AF_INET); */ #ifdef STATIC_LINKING NULL; #else gethostbyaddr((char *) &(peername.sin_addr), sizeof(peername.sin_addr), AF_INET); #endif if (hostEntPtr != (struct hostent *) NULL) host = make_simple_string(hostEntPtr->h_name); else host = address; return list(3,address,host,make_fixnum(ntohs(peername.sin_port))); } else { return Cnil; } } DEFUN_NEW("GETSOCKNAME",object,fSgetsockname,SI,1,1,NONE,OO,OO,OO,OO,(object sock), "Return a list of three elements: the address, the hostname and the port for the socket. If hostname is not available it will be equal to the address. Return NIL on failure. ") { struct sockaddr_in sockname; socklen_t size = sizeof(struct sockaddr_in); struct hostent *hostEntPtr; object address,host; check_socket(sock); if (getsockname(SOCKET_FD(sock), (struct sockaddr *) &sockname, &size) >= 0) { address= make_simple_string(inet_ntoa(sockname.sin_addr)); hostEntPtr = /* gethostbyaddr((char *) &(sockname.sin_addr), */ /* sizeof(sockname.sin_addr), AF_INET); */ #ifdef STATIC_LINKING NULL; #else gethostbyaddr((char *) &(sockname.sin_addr), sizeof(sockname.sin_addr), AF_INET); #endif if (hostEntPtr != (struct hostent *) NULL) host = make_simple_string(hostEntPtr->h_name); else host=address; return list(3,address,host,make_fixnum(ntohs(sockname.sin_port))); } else { return Cnil; } } /* TcpBlocking -- Use on a tcp socket to alter the blocking or non blocking. Results 0 if succeeds and errno if fails. Side effects: the channel is setto blocking or nonblocking mode. */ DEFUN_NEW("SET-BLOCKING",object,fSset_blocking,SI,2,2,NONE,OO,OO,OO,OO,(object sock,object setBlocking), "Set blocking on if MODE is T otherwise off. Return 0 if succeeds. Otherwise the error number.") { int setting; int fd ; AGAIN: check_stream(sock); /* set our idea of whether blocking on or off setBlocking==Cnil <==> blocking turned off. */ SET_STREAM_FLAG(sock,gcl_sm_tcp_async,setBlocking==Cnil); if (sock->sm.sm_mode == smm_two_way) { /* check for case they are sock streams and so share the same fd */ if (STREAM_INPUT_STREAM(sock)->sm.sm_fp != NULL &&STREAM_OUTPUT_STREAM(sock)->sm.sm_fp != NULL && (SOCKET_FD(STREAM_INPUT_STREAM(sock))== SOCKET_FD(STREAM_OUTPUT_STREAM(sock)))) { SET_STREAM_FLAG(STREAM_OUTPUT_STREAM(sock), gcl_sm_tcp_async,setBlocking==Cnil); sock = STREAM_INPUT_STREAM(sock); /* they share an 'fd' and so only do one. */ goto AGAIN; } else { int x1 = fix(FFN(fSset_blocking)(STREAM_INPUT_STREAM(sock),setBlocking)); int x2 = fix(FFN(fSset_blocking)(STREAM_OUTPUT_STREAM(sock),setBlocking)); /* if either is negative result return negative. (ie fail) If either is positive return positive (ie fail) Zero result means both ok. (ie succeed) */ return make_fixnum((x1 < 0 || x2 < 0 ? -2 : x1 > 0 ? x1 : x2)); } } if (sock->sm.sm_fp == NULL) return make_fixnum(-2); fd = SOCKET_FD(sock); #ifndef USE_FIONBIO setting = fcntl(fd, F_GETFL); if (setBlocking != Cnil) { setting &= (~(O_NONBLOCK)); } else { setting |= O_NONBLOCK; } if (fcntl(fd, F_SETFL, setting) < 0) { return make_fixnum(errno); } #endif #ifdef USE_FIONBIO if (setBlocking != Cnil) { setting = 0; if (ioctl(fd, (int) FIONBIO, &setting) == -1) { return make_fixnum(errno); } } else { setting = 1; if (ioctl(fd, (int) FIONBIO, &setting) == -1) { return make_fixnum(errno); } } #endif return make_fixnum(0); } /* with 2 args return the function if any. */ /*setHandler(stream,readable,function) object stream; stream to watch object readable; keyword readable,writable object function; the handler function to be invoked with arg stream { } */ /* goes through the streams does a select with 0 timeout, and invokes any handlers */ /* update () { } */ static int joe(int x) { return x; } /* get a character from FP but block, if it would return the EOF, but the stream is not closed. */ int getOneChar(FILE *fp) { fd_set readfds; struct timeval timeout; int fd= fileno(fp); int high; /* fprintf(stderr,"",fp); fflush(stderr); */ emsg("in getOneChar, fd=%d,fp=%p",fd,fp); if (fd == 0) { joe(fd); return -1; } while (1) { timeout.tv_sec = 0; timeout.tv_usec = 200000; FD_ZERO(&readfds); FD_SET(fd,&readfds); CHECK_INTERRUPT; high = select(fd+1,&readfds,NULL,NULL,&timeout); if (high > 0) { int ch ; emsg("in getOneChar, fd=%d,fp=%p",fd,fp); ch = getc(fp); if ( ch != EOF || feof(fp) ) { /* fprintf(stderr,"< 0x%x returning %d,%c>\n",fp,ch,ch); fflush(stderr); */ } emsg("in getOneChar, ch= %c,%d\n",ch,ch); CHECK_INTERRUPT; if (ch != EOF) return ch; if (feof(fp)) return EOF; } } } #ifdef DODEBUG #define dprintf(s,arg) emsg(s,arg) #else #define dprintf(s,arg) #endif void ungetCharGclSocket(int c, object strm) /* the character to unget */ /* stream */ { object bufp = SOCKET_STREAM_BUFFER(strm); if (c == EOF) return; dprintf("pushing back %c\n",c); if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=c; } else { FEerror("Tried to unget too many chars",0); } } /* *---------------------------------------------------------------------- * * TcpOutputProc -- * * This procedure is invoked by the generic IO level to write output * to a TCP socket based channel. * * NOTE: We cannot share code with FilePipeOutputProc because here * we must use send, not write, to get reliable error reporting. * * Results: * The number of bytes written is returned. An output argument is * set to a POSIX error code if an error occurred, or zero. * * Side effects: * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ int TcpOutputProc(int fd, char *buf, int toWrite, int *errorCodePtr) /* Socket state. */ /* The data buffer. */ /* How many bytes to write? */ /* Where to store error code. */ { int written; *errorCodePtr = 0; written = send(fd, buf, (size_t) toWrite, 0); if (written > -1) { return written; } *errorCodePtr = errno; return -1; } void tcpCloseSocket(int fd) { close(fd); } static void doReverse(char *s, int n) { char *p=&s[n-1]; int m = n/2; while (--m>=0) { int tem = *s; *s = *p; *p = tem; s++; p--; } } /* getCharGclSocket(strm,block) -- get one character from a socket stream. Results: a character or EOF if at end of file Side Effects: The buffer may be filled, and the fill pointer of the buffer may be changed. */ int getCharGclSocket(object strm, object block) { object bufp=SOCKET_STREAM_BUFFER(strm); int fd=SOCKET_STREAM_FD(strm); if (bufp->ust.ust_fillp > 0) return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; if (fd>=0) { fd_set readfds; struct timeval t,t1={0,10000},*tp=block==Ct ? NULL : &t; int high,n; FD_ZERO(&readfds); FD_SET(fd,&readfds); for (;(errno=0,t=t1,high=select(fd+1,&readfds,NULL,NULL,tp))==-1 && !tp && errno==EINTR;); if (high > 0) { massert((n=SAFE_READ(fd,bufp->st.st_self,bufp->ust.ust_dim))>=0); if (n) { doReverse(bufp->st.st_self,n); bufp->ust.ust_fillp=n; } else SOCKET_STREAM_FD(strm)=-1; return getCharGclSocket(strm,block); } } return EOF; } #else int getOneChar(fp) FILE *fp; { return getc(fp); } #endif gcl-2.6.14/o/predicate.c0000755000175000017500000003761014360276512013347 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* predicate.c predicates */ #include #include #include "include.h" DEFUN_NEW("PATHNAME-DESIGNATORP",object,fSpathname_designatorp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(pathname_designatorp(x) ? Ct : Cnil); } DEFUNO_NEW("NULL",object,fLnull,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lnull,(object x0),"") { /* 1 args */ if (x0 == Cnil) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUN_NEW("NOT",object,fLnot,LISP ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ if (x0 == Cnil) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("SYMBOLP",object,fLsymbolp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lsymbolp,(object x0),"") { /* 1 args */ if (type_of(x0) == t_symbol) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("ATOM",object,fLatom ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Latom,(object x0),"") { /* 1 args */ if (type_of(x0) != t_cons) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("CONSP",object,fLconsp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lconsp,(object x0),"") { /* 1 args */ if (type_of(x0) == t_cons) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("LISTP",object,fLlistp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Llistp,(object x0),"") { /* 1 args */ if (x0 == Cnil || type_of(x0) == t_cons) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("NUMBERP",object,fLnumberp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lnumberp,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_fixnum || t == t_bignum || t == t_ratio || t == t_shortfloat || t == t_longfloat || t == t_complex) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("INTEGERP",object,fLintegerp ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lintegerp,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_fixnum || t == t_bignum) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUN_NEW("RATIONALP",object,fLrationalp,LISP ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_fixnum || t == t_bignum || t == t_ratio) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUN_NEW("REALP",object,fLrealp,LISP ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { enum type t; t = type_of(x0); RETURN1((TS_MEMBER(t,TS(t_fixnum)| TS(t_bignum)| TS(t_ratio)| TS(t_longfloat)| TS(t_shortfloat)) ? Ct : Cnil)); } DEFUNO_NEW("FLOATP",object,fLfloatp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lfloatp,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_longfloat || t == t_shortfloat) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("COMPLEXP",object,fLcomplexp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lcomplexp,(object x0),"") { /* 1 args */ if (type_of(x0) == t_complex) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("CHARACTERP",object,fLcharacterp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lcharacterp,(object x0),"") { /* 1 args */ if (type_of(x0) == t_character) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("STRINGP",object,fLstringp ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lstringp,(object x0),"") { /* 1 args */ if (type_of(x0) == t_string) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("BIT-VECTOR-P",object,fLbit_vector_p,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lbit_vector_p,(object x0),"") { /* 1 args */ if (type_of(x0) == t_bitvector) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("VECTORP",object,fLvectorp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lvectorp,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_vector || t == t_string || t == t_bitvector) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("SIMPLE-STRING-P",object,fLsimple_string_p,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_string_p,(object x0),"") { /* 1 args */ if (type_of(x0) == t_string && /* !x0->st.st_adjustable && */ !x0->st.st_hasfillp && x0->st.st_displaced->c.c_car == Cnil) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("SIMPLE-BIT-VECTOR-P",object,fLsimple_bit_vector_p ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_bit_vector_p ,(object x0),"") { /* 1 args */ if (type_of(x0) == t_bitvector && /* !x0->bv.bv_adjustable && */ !x0->bv.bv_hasfillp && x0->bv.bv_displaced->c.c_car == Cnil) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("SIMPLE-VECTOR-P",object,fLsimple_vector_p ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_vector_p ,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_vector && /* !x0->v.v_adjustable && */ !x0->v.v_hasfillp && x0->v.v_displaced->c.c_car == Cnil && (enum aelttype)x0->v.v_elttype == aet_object) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("ARRAYP",object,fLarrayp ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Larrayp,(object x0),"") { enum type t; /* 1 args */ t = type_of(x0); if (t == t_array || t == t_vector || t == t_string || t == t_bitvector) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("PACKAGEP",object,fLpackagep ,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lpackagep ,(object x0),"") { /* 1 args */ if (type_of(x0) == t_package) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUNO_NEW("FUNCTIONP",object,fLfunctionp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lfunctionp,(object x0),"") { enum type t; object x; /* 1 args */ t = type_of(x0); if (t == t_cfun || t == t_cclosure || t == t_sfun || t == t_gfun || t == t_closure|| t == t_afun || t == t_vfun) x0 = Ct; else if (t == t_symbol) { if (x0->s.s_gfdef != OBJNULL && x0->s.s_mflag == FALSE) x0 = Ct; else x0 = Cnil; } else if (t == t_cons) { x = x0->c.c_car; if (x == sLlambda || x == sSlambda_block || x == sSlambda_block_expanded || x == sSlambda_closure || x == sSlambda_block_closure) x0 = Ct; else x0 = Cnil; } else x0 = Cnil; RETURN1(x0);} #ifdef STATIC_FUNCTION_POINTERS object fLfunctionp(object x) { return FFN(fLfunctionp)(x); } #endif DEFUNO_NEW("COMMONP",object,fScommonp,SI,1,1,NONE,OO,OO,OO,OO,void,siLcommonp,(object x0),"") { if (type_of(x0) != t_spice) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUNO_NEW("COMPILED-FUNCTION-P",object,fLcompiled_function_p,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lcompiled_function_p,(object x0),"") { /* 1 args */; if (type_of(x0) == t_cfun || type_of(x0) == t_cclosure || type_of(x0) == t_sfun || type_of(x0) == t_gfun || type_of(x0) == t_afun || type_of(x0) == t_closure || type_of(x0) == t_vfun ) x0 = Ct; else x0 = Cnil; RETURN1(x0);} DEFUN_NEW("EQ",object,fLeq,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { RETURN1(x0==x1 ? Ct : Cnil); } #define eqlm(x,y) \ \ case t_fixnum:\ return (fix(x)==fix(y)) ? TRUE : FALSE;\ \ case t_bignum:\ return big_compare(x,y) ? FALSE : TRUE;\ \ case t_ratio:\ return (eql(x->rat.rat_num,y->rat.rat_num) &&\ eql(x->rat.rat_den,y->rat.rat_den)) ? TRUE : FALSE;\ \ case t_shortfloat:\ return sf(x)==sf(y) ? TRUE : FALSE;\ \ case t_longfloat:\ return lf(x)==lf(y) ? TRUE : FALSE;\ \ case t_complex:\ return (eql(x->cmp.cmp_real,y->cmp.cmp_real) &&\ eql(x->cmp.cmp_imag,y->cmp.cmp_imag)) ? TRUE : FALSE;\ \ default:\ return FALSE; bool eql1(register object x,register object y) { /*x and y are not == and not Cnil and not immfix*/ /* if (valid_cdr(x)||valid_cdr(y)||x->d.t!=y->d.t) return FALSE; */ switch (x->d.t) { eqlm(x,y); } } /*for sublis1-inline*/ bool oeql(object x,object y) { return eql(x,y) ? TRUE : FALSE; } DEFUN_NEW("EQL",object,fLeql,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { RETURN1(eql(x0,x1) ? Ct : Cnil); } bool equal1(register object x, register object y) { /*x and y are not == and not Cnil and not immfix*/ /*gcc boolean expression tail position bug*/ /* if (valid_cdr(x)) return valid_cdr(y)&&equal(x->c.c_car,y->c.c_car)&&equal(x->c.c_cdr,y->c.c_cdr); */ if (valid_cdr(x)) return !valid_cdr(y)||!equal(x->c.c_car,y->c.c_car) ? FALSE : equal(x->c.c_cdr,y->c.c_cdr); if (valid_cdr(y)) return FALSE; if (x->d.t!=y->d.t) return FALSE; switch(x->d.t) { case t_string: return(string_eq(x, y)); case t_bitvector: { fixnum i, ox, oy; if (x->bv.bv_fillp != y->bv.bv_fillp) return(FALSE); ox = BV_OFFSET(x); oy = BV_OFFSET(y); for (i = 0; i < x->bv.bv_fillp; i++) if(((x->bv.bv_self[(i+ox)/8] & (0200>>(i+ox)%8)) ? 1 : 0) !=((y->bv.bv_self[(i+oy)/8] & (0200>>(i+oy)%8)) ? 1 : 0)) return(FALSE); return(TRUE); } case t_pathname: if (equal(x->pn.pn_host, y->pn.pn_host) && equal(x->pn.pn_device, y->pn.pn_device) && equal(x->pn.pn_directory, y->pn.pn_directory) && equal(x->pn.pn_name, y->pn.pn_name) && equal(x->pn.pn_type, y->pn.pn_type) && equal(x->pn.pn_version, y->pn.pn_version)) return(TRUE); else return(FALSE); eqlm(x,y); } } /*for sublis1-inline*/ bool oequal(object x,object y) { return equal(x,y) ? TRUE : FALSE; } DEFUN_NEW("EQUAL",object,fLequal,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { RETURN1(equal(x0, x1) ? Ct : Cnil); } #ifdef STATIC_FUNCTION_POINTERS object fLequal(object x,object y) { return FFN(fLequal)(x,y); } #endif bool equalp1(register object x, register object y) { enum type tx,ty; fixnum j; /*x and y are not == and not Cnil*/ /*gcc boolean expression tail position bug*/ /* if (listp(x)) return listp(y)&&equalp(x->c.c_car,y->c.c_car)&&equalp(x->c.c_cdr,y->c.c_cdr); */ if (listp(x)) return !listp(y)||!equalp(x->c.c_car,y->c.c_car) ? FALSE : equalp(x->c.c_cdr,y->c.c_cdr); if (listp(y)) return FALSE; tx=is_imm_fixnum(x) ? t_fixnum : x->d.t; ty=is_imm_fixnum(y) ? t_fixnum : y->d.t; switch(tx) { case t_fixnum: case t_bignum: case t_ratio: case t_shortfloat: case t_longfloat: case t_complex: if (ty==t_fixnum||ty==t_bignum||ty==t_ratio || ty==t_shortfloat||ty==t_longfloat || ty==t_complex) return(!number_compare(x, y)); else return(FALSE); case t_vector: case t_string: case t_bitvector: if (ty==t_vector||ty==t_string||ty==t_bitvector) { j = x->v.v_fillp; if (j != y->v.v_fillp) return FALSE; goto ARRAY; } else return(FALSE); case t_array: if (ty==t_array && x->a.a_rank==y->a.a_rank) { if (x->a.a_rank > 1) { fixnum i; for (i=0; i< x->a.a_rank; i++) { if (x->a.a_dims[i]!=y->a.a_dims[i]) return(FALSE); } } if (x->a.a_dim != y->a.a_dim) return(FALSE); j=x->a.a_dim; goto ARRAY; } else return(FALSE); default: break; } if (tx != ty) return(FALSE); switch (tx) { case t_character: return(char_equal(x, y)); case t_structure: { fixnum i; if (x->str.str_def != y->str.str_def) return(FALSE); { fixnum leng= S_DATA(x->str.str_def)->length; unsigned char *s_type= & SLOT_TYPE(x->str.str_def,0); unsigned short *s_pos= & SLOT_POS(x->str.str_def,0); for (i = 0; i < leng; i++,s_pos++) { if (s_type[i]==aet_object) { if (!equalp(STREF(object,x,*s_pos),STREF(object,y,*s_pos))) return FALSE; } else /* if (! (*s_pos & (sizeof(object)-1))) */ switch(s_type[i]) { case aet_lf: if((! (*s_pos & (sizeof(longfloat)-1))) && STREF(longfloat,x,*s_pos) != STREF(longfloat,y,*s_pos)) return(FALSE); break; case aet_sf: if((! (*s_pos & (sizeof(shortfloat)-1))) && STREF(shortfloat,x,*s_pos)!=STREF(shortfloat,y,*s_pos)) return(FALSE); break; default: if((! (*s_pos & (sizeof(fixnum)-1))) && STREF(fixnum,x,*s_pos)!=STREF(fixnum,y,*s_pos)) return(FALSE); break; } } return(TRUE); } } case t_hashtable: { unsigned i; struct htent *e; if (x->ht.ht_nent!=y->ht.ht_nent) return(FALSE); if (x->ht.ht_test!=y->ht.ht_test) return(FALSE); for (i=0;iht.ht_size;i++) { if (x->ht.ht_self[i].hte_key==OBJNULL) continue; if ((e=gethash(x->ht.ht_self[i].hte_key,y))->hte_key==OBJNULL ||!equalp(x->ht.ht_self[i].hte_value,e->hte_value)) return(FALSE); } return(TRUE); break; } case t_pathname: return(equal(x, y)); case t_random: return(x->rnd.rnd_state._mp_seed->_mp_alloc==y->rnd.rnd_state._mp_seed->_mp_alloc && !memcmp(x->rnd.rnd_state._mp_seed->_mp_d,y->rnd.rnd_state._mp_seed->_mp_d, x->rnd.rnd_state._mp_seed->_mp_alloc*sizeof(*x->rnd.rnd_state._mp_seed->_mp_d))); default: return(FALSE); } ARRAY: { fixnum i; for (i = 0; i < j; i++) if (!equalp(aref(x, i), aref(y, i))) return(FALSE); return(TRUE); } } /*for sublis1-inline*/ bool oequalp(object x,object y) { return equalp(x,y) ? TRUE : FALSE; } DEFUN_NEW("EQUALP",object,fLequalp,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { RETURN1(equalp(x0,x1) ? Ct : Cnil); } static void FFN(Fand)(object args) { object *top = vs_top; if (endp(args)) { vs_base = vs_top; vs_push(Ct); return; } while (!endp(MMcdr(args))) { eval(MMcar(args)); if (vs_base[0] == Cnil) { vs_base = vs_top = top; vs_push(Cnil); return; } vs_top = top; args = MMcdr(args); } eval(MMcar(args)); } static void FFN(For)(object args) { object *top = vs_top; if (endp(args)) { vs_base = vs_top; vs_push(Cnil); return; } while (!endp(MMcdr(args))) { eval(MMcar(args)); if (vs_base[0] != Cnil) { top[0] = vs_base[0]; vs_base = top; vs_top = top+1; return; } vs_top = top; args = MMcdr(args); } eval(MMcar(args)); } /* Contains_sharp_comma returns TRUE, iff the argument contains a cons whose car is si:|#,| or a STRUCTURE. Refer to the compiler about this magic. */ bool contains_sharp_comma(object x) { enum type tx; cs_check(x); BEGIN: tx = type_of(x); if (tx == t_complex) return(contains_sharp_comma(x->cmp.cmp_real) || contains_sharp_comma(x->cmp.cmp_imag)); if (tx == t_vector) { int i; if (x->v.v_elttype == aet_object) for (i = 0; i < x->v.v_fillp; i++) if (contains_sharp_comma(x->v.v_self[i])) return(TRUE); return(FALSE); } if (tx == t_cons) { if (x->c.c_car == siSsharp_comma) return(TRUE); if (contains_sharp_comma(x->c.c_car)) return(TRUE); x = x->c.c_cdr; goto BEGIN; } if (tx == t_array) { int i, j; if (x->a.a_elttype == aet_object) { for (i = 0, j = 1; i < x->a.a_rank; i++) j *= x->a.a_dims[i]; for (i = 0; i < j; i++) if (contains_sharp_comma(x->a.a_self[i])) return(TRUE); } return(FALSE); } if (tx == t_structure) return(TRUE); /* Oh, my god! */ return(FALSE); } DEFUN_NEW("CONTAINS-SHARP-COMMA",object,fScontains_sharp_comma,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ if (contains_sharp_comma(x0)) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUN_NEW("SPICEP",object,fSspicep ,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ if (type_of(x0) == t_spice) x0 = Ct; else x0 = Cnil; RETURN1(x0); } DEFUN_NEW("FIXNUMP",object,fSfixnump,SI ,1,1,NONE,OO,OO,OO,OO,(object x0),"") { /* 1 args */ if (type_of(x0) == t_fixnum) x0 = Ct; else x0 = Cnil; RETURN1(x0); } void gcl_init_predicate_function(void) { sLand=make_special_form("AND",Fand); sLor=make_special_form("OR",For); } gcl-2.6.14/o/pari_big.c0000755000175000017500000002417014360276512013160 0ustar cammcamm /* Copyright William F. Schelter 1991 Bignum routines. num_arith.c: add_int_big num_arith.c: big_minus num_arith.c: big_plus num_arith.c: big_quotient_remainder num_arith.c: big_sign num_arith.c: big_times num_arith.c: complement_big num_arith.c: copy_big num_arith.c: div_int_big num_arith.c: mul_int_big num_arith.c: normalize_big num_arith.c: normalize_big_to_object num_arith.c: stretch_big num_arith.c: sub_int_big num_comp.c: big_compare num_comp.c: big_sign num_log.c: big_sign num_log.c: copy_to_big num_log.c: normalize_big num_log.c: normalize_big_to_object num_log.c: stretch_big num_pred.c: big_sign number.c: big_to_double predicate.c: big_compare typespec.c: big_sign print.d: big_minus print.d: big_sign print.d: big_zerop print.d: copy_big print.d: div_int_big read.d: add_int_big read.d: big_to_double read.d: complement_big read.d: mul_int_big read.d: normalize_big read.d: normalize_big_to_object */ #define BCOPY_BODY(x,y) \ do { int *ucop = (int *)(x); \ int *vcop = (int *) (y); \ {int j = lgef(ucop); \ while(--j >= 0) \ { *vcop++ = *ucop++;}}}while (0) bcopy_body(x,y) GEN x,y; {BCOPY_BODY(x,y);} /* make a bignum with (most <<32 + least) */ object bignum2(most, least) int most, least; { static plong u [4] = {0x01010004 ,0x01010004, 0,0}; GEN w; int l; if(most) {setlgef(u,4),l=4;} else {l=3; setlgef(u,3);} MP_START_LOW(w,u,l); MP_NEXT_UP(w) = least; if (most) MP_NEXT_UP(w) = most; return make_integer(u); } /* coerce a pari GEN to a bignum or fixnum */ object make_integer(u) GEN u; { int l = lgef(u); if (l > (MP_CODE_WORDS+1) || ( l == (MP_CODE_WORDS+1) && (MP_ONLY_WORD(u) & (1<<31)) != 0 && (MP_ONLY_WORD(u) == ( 1<<31) ? signe(u) > 0 : 1))) { object ans ; GEN w; { BEGIN_NO_INTERRUPT; big_register_1->big.big_length = lg(u); big_register_1->big.big_self = u; ans = alloc_object(t_bignum); ans->big.big_self = 0; w = (plong *)alloc_relblock(lg(u)*sizeof(plong)); /* may have been relocated */ u = (GEN) big_register_1->big.big_self ; ans->big.big_self = w; ans->big.big_length = l; BCOPY_BODY(u , w); setlg(w,l); END_NO_INTERRUPT;} return ans; } else if (signe(u) > 0) return make_fixnum(MP_ONLY_WORD(u)); else if (signe(u) < 0) return make_fixnum(-MP_ONLY_WORD(u)); else return(small_fixnum(0)); } static object make_bignum(u) GEN u; { BEGIN_NO_INTERRUPT; { object ans = alloc_object(t_bignum); GEN w; ans->big.big_length = lg(u); /* save u */ ans->big.big_self = u; w = (plong *)alloc_relblock(lg(u)*sizeof(plong)); /* restore u */ u = ans->big.big_self ; ans->big.big_self = w; BCOPY_BODY(u , ans->big.big_self); END_NO_INTERRUPT; return ans; }} static big_zerop(x) object x; { return (signe(MP(x))== 0);} big_compare(x, y) object x,y; {return cmpii(MP(x),MP(y));} object big_minus(x) object x; { object y; setsigne(MP(x),-(signe(MP(x)))); y = make_integer(MP(x)); setsigne(MP(x),-(signe(MP(x)))); return y; } static gcopy_to_big(res,x) GEN res; object x; {int l = (x)->big.big_length; int lgres = lg(res); if (l< lgres) { BEGIN_NO_INTERRUPT; big_register_1->big.big_length = lgres; big_register_1->big.big_self = res; (x)->big.big_self = (GEN) alloc_relblock(lgres*sizeof(int)); (x)->big.big_length = lgres; res = big_register_1->big.big_self ; END_NO_INTERRUPT; } BCOPY_BODY(res,(x)->big.big_self); if (l>lgres) { setlg((x)->big.big_self, l);} } add_int_big(i, x) int i; object x; { MPOP_DEST(x,addsi,i,MP(x)); } static sub_int_big(i, x) int i; object x; { MPOP_DEST(x,subsi,i,MP(x)); } mul_int_big(i, x) int i; object x; { MPOP_DEST(x,mulsi,i,MP(x)); } /* Div_int_big(i, x) destructively divides non-negative bignum x by positive int i. X will hold the quotient from the division. Div_int_big(i, x) returns the remainder of the division. I should be positive. X should be non-negative. */ static div_int_big(i, x) int i; object x; { save_avma; GEN res = divis(MP(x),i); gcopy_to_big(res,x); restore_avma; return hiremainder; } static object big_plus(x, y) object x,y; { MPOP(return,addii,MP(x),MP(y)); } static object big_times(x, y) object x,y; { MPOP(return,mulii,MP(x),MP(y)); } static big_quotient_remainder(x0, y0, qp, rp) object x0,y0,*qp,*rp; { GEN res,quot; save_avma; res = dvmdii(MP(x0),MP(y0),"); *qp = make_integer(res); *rp = make_integer(quot); restore_avma; return; } double big_to_double(x) object x; { double d, e; GEN u = MP(x); unsigned int *w; int l; e = 4.294967296e9; l = lgef(u); MP_START_HIGH(w,(unsigned int *) u,l); l = l - MP_CODE_WORDS; if (l == 0) return 0.0; d = (double) MP_NEXT_DOWN(w); while (--l > 0) {d = e*d + (double)(MP_NEXT_DOWN(w));} if (signe(u)>0) return d; else return -d; } object normalize_big_to_object(x) object x; { return make_integer(MP(x));} static object copy_big(x) object x; { if (type_of(x)==t_bignum) return make_bignum(MP(x)); else FEerror("bignum expected",0); } static object copy_to_big(x) object x; {object y; if (type_of(x) == t_fixnum) { save_avma; y = make_bignum(stoi(fix(x))); restore_avma; } else if (type_of(x) == t_bignum) y = copy_big(x); else FEerror("integer expected",0); return(y); } /* return the power of x */ GEN powerii(x,y) GEN x, y; { GEN ans = gun; if (signe(y) < 0) FEerror("bad",0); while (lgef(y) > 2){ if (MP_LOW(y,lgef(y)) & 1) { ans = mulii(ans,x);} x = mulii(x,x); y = shifti(y,-1);} return ans; } replace_copy1(x,y) GEN y,x; { int j = lgef(x); if (y && j <= lg(y)) { x++; y++; while (--j >0) {*y++ = *x++;} return 0;} END: return j*2*sizeof(GEN); } /* doubles the length ! */ GEN replace_copy2(x,y) GEN y,x; {GEN yp = y; int k,j = lgef(x); k = j; while (--j >=0) {*yp++ = *x++;} y[0] = INT_FLAG + k*2; return y;} #define STOI(x,y) do{ \ if (x ==0) { y[1]=2;} \ else if((x)>0) {y[1]=0x1000003;y[2]=x;} \ else{y[1]=0xff000003;y[2]= -x;}}while (0) /* actually y == 0 is not supposed to happen !*/ obj_replace_copy1(x,y) object x; GEN y; { int j ; GEN xp; { if (type_of(x) == t_bignum) { j = lgef(MP(x)); if (y && j <= lg(y)) { xp=MP(x); xp++; y++; while (--j >0) {*y++ = *xp++;} return 0;}} else { if (y==0) return 3*2*sizeof(GEN) ; STOI(fix(x),y); return 0;}} END: return j*2*sizeof(GEN); } /* doubles the length ! */ GEN obj_replace_copy2(x,y) object x; GEN y; {GEN yp = y; GEN xp; int k,j; if (type_of(x) == t_bignum) { j = lgef(MP(x)); k = j; xp = MP(x); while (--j >=0) {*yp++ = *xp++;} y[0] = INT_FLAG + k*2;} else {STOI(fix(x),yp); y[0] = INT_FLAG+3*2;} return y;} static GEN otoi(x) object x; {if (type_of(x)==t_fixnum) return stoi(fix(x)); if (type_of(x)==t_bignum) return (MP(x)); FEwrong_type_argument(sLinteger,x); return 0; } object alloc_bignum_static(len) int len; { object ans = alloc_object(t_bignum); GEN w; ans->big.big_length = len; ans->big.big_self = 0; w = (GEN)AR_ALLOC(alloc_contblock,len,unsigned plong); ans->big.big_self = w; w[0] = INT_FLAG + len; return ans; } GEN setq_io(x,all,val) GEN x; object val; object *all; {int n= obj_replace_copy1(val,x); if (n) { *all = alloc_bignum_static(n/sizeof(int)); return obj_replace_copy2(val,MP(*all)); } else return x;} GEN setq_ii(x,all,val) GEN x; GEN val; object *all; {int n= replace_copy1(val,x); if (n) { *all = alloc_bignum_static(n/sizeof(int)); return replace_copy2(val,MP(*all)); } else return x;} void isetq_fix(var,s) GEN var; int s; {/* if (var==0) FEerror("unitialized integer var",0); */ STOI(s,var); } GEN icopy_bignum(a,y) object a; GEN y; { int *ucop = (int *)MP(a); int *vcop = (int *) (y); int j = lgef(ucop); {while(--j >= 0) { *vcop++ = *ucop++;} setlg(y,a->big.big_length); return y;}} GEN icopy_fixnum(a,y) object a; GEN y; { int x= fix(a); if(!x) return gzero; y[0]=INT_FLAG+3; if(x>0) {y[1]=0x1000003;y[2]=x;} else{y[1]=0xff000003;y[2]= -x;} return y; } GEN gnil,gzero,gun,gdeux,ghalf,gi; plong lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,0,2,2,1,1,1,0,1,1,1,1}; unsigned plong hiremainder,overflow; #ifdef STANDALONE #define FEerror printf #define make_si_sfun(a,b,c) #endif #define INITIAL_PARI_STACK 400 char initial_pari_stack[400]; our_ulong bot= (our_ulong) initial_pari_stack; our_ulong top = (our_ulong)(initial_pari_stack+INITIAL_PARI_STACK); /* not initted */ our_ulong avma= 0; void err(s) int s; { switch (s) { case errpile: FEerror("Out of bignum stack space, (si::MULTIPLY-BIGNUM-STACK n) to grow",0); case dvmer1: case diver4: case diver2: case diver1: FEerror("Divide by zero",0); case muler1: FEerror("Multiply overflow",0); case moder1: FEerror("Mod by 0",0); default: FEerror("Integer Arithmetic error",0); }} multiply_bignum_stack(n) int n; { int parisize = n* (top - bot); in_saved_avma = 0; if (n> 1) { if (bot != (our_ulong)initial_pari_stack) free(bot); set_pari_stack(parisize); } return parisize; } set_pari_stack(parisize) int parisize; { bot=(plong)malloc(parisize); top = avma = bot + parisize; } /* things to be done every start */ gcl_init_big1() { } gcl_init_big() { if (avma==0) { make_si_sfun("MULTIPLY-BIGNUM-STACK",multiply_bignum_stack, ARGTYPE1(f_fixnum) | RESTYPE(f_fixnum)); avma = top; } /* room for the permanent things */ gnil = cgeti(2);gnil[1]=2; setpere(gnil,255); gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255); gun = stoi(1); setpere(gun, 255); gdeux = stoi(2); setpere(gdeux, 255); ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255); gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255); /* set_pari_stack(BIGNUM_STACK_SIZE);*/ } gcl-2.6.14/o/ntheap.h0000755000175000017500000000747614360276512012702 0ustar cammcamm/* Heap management routines (including unexec) for GNU Emacs on Windows NT. Copyright (C) 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ #ifndef NTHEAP_H_ #define NTHEAP_H_ #include /* * Heap related stuff. */ #define get_reserved_heap_size() reserved_heap_size #define get_committed_heap_size() (get_data_end () - get_data_start ()) #define get_heap_start() get_data_start () #define get_heap_end() get_data_end () #define get_page_size() sysinfo_cache.dwPageSize #define get_allocation_unit() sysinfo_cache.dwAllocationGranularity #define get_processor_type() sysinfo_cache.dwProcessorType #define get_nt_major_version() nt_major_version #define get_nt_minor_version() nt_minor_version extern unsigned char *get_data_start(); extern unsigned char *get_data_end(); extern unsigned long data_region_size; extern unsigned long reserved_heap_size; extern SYSTEM_INFO sysinfo_cache; extern int nt_major_version; extern int nt_minor_version; /* To prevent zero-initialized variables from being placed into the bss section, use non-zero values to represent an uninitialized state. */ #define UNINIT_PTR ((void *) 0xF0A0F0A0) #define UNINIT_LONG (0xF0A0F0A0L) enum { OS_WIN95 = 1, OS_NT }; extern int os_subtype; /* Emulation of Unix sbrk(). */ extern void *sbrk (ptrdiff_t size); /* Recreate the heap created during dumping. */ extern void recreate_heap (char *executable_path); /* Round the heap to this size. */ extern void round_heap (unsigned long size); /* Load in the dumped .bss section. */ extern void read_in_bss (char *name); /* Map in the dumped heap. */ extern void map_in_heap (char *name); /* Cache system info, e.g., the NT page size. */ extern void cache_system_info (void); /* Round ADDRESS up to be aligned with ALIGN. */ extern unsigned char *round_to_next (unsigned char *address, unsigned long align); /* ----------------------------------------------------------------- */ /* Useful routines for manipulating memory-mapped files. */ typedef struct file_data { char *name; unsigned long size; HANDLE file; HANDLE file_mapping; unsigned char *file_base; } file_data; #define OFFSET_TO_RVA(var,section) \ (section->VirtualAddress + ((DWORD)(var) - section->PointerToRawData)) #define RVA_TO_OFFSET(var,section) \ (section->PointerToRawData + ((DWORD)(var) - section->VirtualAddress)) #define RVA_TO_PTR(var,section,filedata) \ ((void *)(RVA_TO_OFFSET(var,section) + (filedata).file_base)) int open_input_file (file_data *p_file, char *name); int open_output_file (file_data *p_file, char *name, unsigned long size); void close_file_data (file_data *p_file); unsigned long get_section_size (PIMAGE_SECTION_HEADER p_section); /* Return pointer to section header for named section. */ IMAGE_SECTION_HEADER * find_section (char * name, IMAGE_NT_HEADERS * nt_header); /* Return pointer to section header for section containing the given relative virtual address. */ IMAGE_SECTION_HEADER * rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header); #endif /* NTHEAP_H_ */ gcl-2.6.14/o/rel_stand.c0000755000175000017500000000401314360276512013351 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #ifdef STAND #define object char * #define close_stream(a) #define coerce_to_filename(a,b) #define FEerror(a,b,c) printf(a) #define vs_push(a) #define read_fasl_vector(a) 0; int test; char *joey="hi bill"; char *kcl_self,*system_directory; main(argc,argv) int argc; char *argv[]; {argc; kcl_self=argv[2]; system_directory=argv[3]; _fmode = O_BINARY; fasload(argv[1]); } node_compare(node1,node2) char *node1, *node2; { return(strcmp( ((struct node *)node1)->string, ((struct node *)node2)->string));} read_special_symbols(symfile) char *symfile; {FILE *symin; char *symbols; int i,jj; struct lsymbol_table tab; if (!(symin=fopen(symfile,"r"))) {perror(symfile);exit(1);}; if(!fread((char *)&tab,sizeof(tab),1,symin)) FEerror("No header",0,0); symbols=malloc(tab.tot_leng); c_table.alloc_length=( (PTABLE_EXTRA+ tab.n_symbols)); (c_table.ptable) = (TABL *) malloc(sizeof(struct node) * c_table.alloc_length); if (!(c_table.ptable)) {perror("could not allocate"); exit(1);}; i=0; c_table.length=tab.n_symbols; while(i < tab.n_symbols) { fread((char *)&jj,sizeof(int),1,symin); (SYM_ADDRESS(c_table,i))=jj; SYM_STRING(c_table,i)=symbols; while( *(symbols++) = getc(symin)) {;} /* dprintf( name %s , SYM_STRING(c_table,i)); dprintf( addr %d , jj); */ i++; } /* for(i=0;i< 5;i++) {printf("Symbol: %d %s %d \n",i,SYM_STRINGN(c_table,i), SYM_ADDRESS(*ptable,i));} */ } #endif /* STAND */ gcl-2.6.14/o/unexelf.c0000755000175000017500000012454414360276512013060 0ustar cammcamm/* Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, old_name, data_start, bss_start, entry_address) * char *new_name, *old_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If old_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing old_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * */ /* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. * ELF support added. * * Basic theory: the data space of the running process needs to be * dumped to the output file. Normally we would just enlarge the size * of .data, scooting everything down. But we can't do that in ELF, * because there is often something between the .data space and the * .bss space. * * In the temacs dump below, notice that the Global Offset Table * (.got) and the Dynamic link data (.dynamic) come between .data1 and * .bss. It does not work to overlap .data with these fields. * * The solution is to create a new .data segment. This segment is * filled with data from the current process. Since the contents of * various sections refer to sections by index, the new .data segment * is made the last in the table to avoid changing any existing index. * This is an example of how the section headers are changed. "Addr" * is a process virtual address. "Offset" is a file offset. raid:/nfs/raid/src/dist-18.56/src> dump -h temacs temacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80a98f4 0x608f4 0x449c .bss 0 0 0x4 0 [17] 2 0 0 0x608f4 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x6a484 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x729aa 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x72a3d 0x68b7 .comment 0 0 0x1 0 raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs xemacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [17] 2 0 0 0x7d800 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 [21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 * This is an example of how the file header is changed. "Shoff" is * the section header offset within the file. Since that table is * after the new .data section, it is moved. "Shnum" is the number of * sections, which we increment. * * "Phoff" is the file offset to the program header. "Phentsize" and * "Shentsz" are the program and section header entries sizes respectively. * These can be larger than the apparent struct sizes. raid:/nfs/raid/src/dist-18.56/src> dump -f temacs temacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x792f4 0 0x34 0x20 5 0x28 21 19 raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs xemacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x96200 0 0x34 0x20 5 0x28 22 19 * These are the program headers. "Offset" is the file offset to the * segment. "Vaddr" is the memory load address. "Filesz" is the * segment size as it appears in the file, and "Memsz" is the size in * memory. Below, the third segment is the code and the fourth is the * data: the difference between Filesz and Memsz is .bss raid:/nfs/raid/src/dist-18.56/src> dump -o temacs temacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x215c4 0x25a60 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs xemacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x3e4d0 0x3e4d0 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 */ /* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. * * The above mechanism does not work if the unexeced ELF file is being * re-layout by other applications (such as `strip'). All the applications * that re-layout the internal of ELF will layout all sections in ascending * order of their file offsets. After the re-layout, the data2 section will * still be the LAST section in the section header vector, but its file offset * is now being pushed far away down, and causes part of it not to be mapped * in (ie. not covered by the load segment entry in PHDR vector), therefore * causes the new binary to fail. * * The solution is to modify the unexec algorithm to insert the new data2 * section header right before the new bss section header, so their file * offsets will be in the ascending order. Since some of the section's (all * sections AFTER the bss section) indexes are now changed, we also need to * modify some fields to make them point to the right sections. This is done * by macro PATCH_INDEX. All the fields that need to be patched are: * * 1. ELF header e_shstrndx field. * 2. section header sh_link and sh_info field. * 3. symbol table entry st_shndx field. * * The above example now should look like: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 [17] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [18] 2 0 0 0x7d800 0x9b90 .symtab 19 371 0x4 0x10 [19] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [20] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [21] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 */ /* We do not use mmap because that fails with NFS. Instead we read the whole file, modify it, and write it out. */ #ifndef emacs #define fatal(a, b...) emsg(a,##b),do_gcl_abort() #else #include "config.h" extern void fatal (char *, ...); #endif #include #include #include #include #include #include #include #include #include #if !defined (__NetBSD__) && !defined (__OpenBSD__) #include #endif #include #if defined (__sony_news) && defined (_SYSTYPE_SYSV) #include #include #endif /* __sony_news && _SYSTYPE_SYSV */ #if __sgi #include /* for HDRR declaration */ #endif /* __sgi */ #include "page.h" #ifndef MAP_ANON #ifdef MAP_ANONYMOUS #define MAP_ANON MAP_ANONYMOUS #else #define MAP_ANON 0 #endif #endif #ifndef MAP_FAILED #define MAP_FAILED ((void *) -1) #endif #if defined (__alpha__) && !defined (__NetBSD__) && !defined (__OpenBSD__) /* Declare COFF debugging symbol table. This used to be in /usr/include/sym.h, but this file is no longer included in Red Hat 5.0 and presumably in any other glibc 2.x based distribution. */ typedef struct { short magic; short vstamp; int ilineMax; int idnMax; int ipdMax; int isymMax; int ioptMax; int iauxMax; int issMax; int issExtMax; int ifdMax; int crfd; int iextMax; long cbLine; long cbLineOffset; long cbDnOffset; long cbPdOffset; long cbSymOffset; long cbOptOffset; long cbAuxOffset; long cbSsOffset; long cbSsExtOffset; long cbFdOffset; long cbRfdOffset; long cbExtOffset; } HDRR, *pHDRR; #define cbHDRR sizeof(HDRR) #define hdrNil ((pHDRR)0) #endif #ifdef __NetBSD__ /* * NetBSD does not have normal-looking user-land ELF support. */ # ifdef __alpha__ # define ELFSIZE 64 # else # define ELFSIZE 32 # endif # include # ifndef PT_LOAD # define PT_LOAD Elf_pt_load # define SHT_SYMTAB Elf_sht_symtab # define SHT_DYNSYM Elf_sht_dynsym # define SHT_NULL Elf_sht_null # define SHT_NOBITS Elf_sht_nobits # define SHT_REL Elf_sht_rel # define SHT_RELA Elf_sht_rela # define SHN_UNDEF Elf_eshn_undefined # define SHN_ABS Elf_eshn_absolute # define SHN_COMMON Elf_eshn_common # endif # ifdef __alpha__ # include # define HDRR struct ecoff_symhdr # define pHDRR HDRR * # endif #endif /* __NetBSD__ */ #ifdef __OpenBSD__ # include #endif #if __GNU_LIBRARY__ - 0 >= 6 # include /* get ElfW etc */ #endif #ifndef ElfW # ifdef __STDC__ # define ElfBitsW(bits, type) Elf##bits##_##type # else # define ElfBitsW(bits, type) Elf/**/bits/**/_/**/type # endif # ifdef _LP64 # define ELFSIZE 64 # else # define ELFSIZE 32 # endif /* This macro expands `bits' before invoking ElfBitsW. */ # define ElfExpandBitsW(bits, type) ElfBitsW (bits, type) # define ElfW(type) ElfExpandBitsW (ELFSIZE, type) #endif #ifndef ELF_BSS_SECTION_NAME #define ELF_BSS_SECTION_NAME ".bss" #endif /* Get the address of a particular section or program header entry, * accounting for the size of the entries. */ /* On PPC Reference Platform running Solaris 2.5.1 the plt section is also of type NOBI like the bss section. (not really stored) and therefore sections after the bss section start at the plt offset. The plt section is always the one just before the bss section. Thus, we modify the test from if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) to if (NEW_SECTION_H (nn).sh_offset >= OLD_SECTION_H (old_bss_index-1).sh_offset) This is just a hack. We should put the new data section before the .plt section. And we should not have this routine at all but use the libelf library to read the old file and create the new file. The changed code is minimal and depends on prep set in m/prep.h Erik Deumens Quantum Theory Project University of Florida deumens@qtp.ufl.edu Apr 23, 1996 */ #define OLD_SECTION_H(n) \ (*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) #define NEW_SECTION_H(n) \ (*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) #define OLD_PROGRAM_H(n) \ (*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) #define NEW_PROGRAM_H(n) \ (*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) #define PATCH_INDEX(n) \ do { \ if ((int) (n) >= old_bss_index) \ (n)++; } while (0) typedef unsigned char byte; /* Round X up to a multiple of Y. */ static ElfW(Addr) round_up (x, y) ElfW(Addr) x, y; { int rem = x % y; if (rem == 0) return x; return x - rem + y; } /* Return the index of the section named NAME. SECTION_NAMES, FILE_NAME and FILE_H give information about the file we are looking in. If we don't find the section NAME, that is a fatal error if NOERROR is 0; we return -1 if NOERROR is nonzero. */ static int find_section (char *name, char *section_names, char *file_name, ElfW(Ehdr) *old_file_h, ElfW(Shdr) *old_section_h, int noerror) { int idx; for (idx = 1; idx < old_file_h->e_shnum; idx++) { #ifdef DEBUG emsg("Looking for %s - found %s\n", name, section_names + OLD_SECTION_H (idx).sh_name); #endif if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, name)) break; } if (idx == old_file_h->e_shnum) { if (noerror) return -1; else fatal ("Can't find %s in %s.\n", name, file_name); } return idx; } /* **************************************************************** * unexec * * driving logic. * * In ELF, this works by replacing the old .bss section with a new * .data section, and inserting an empty .bss immediately afterwards. * */ static void unexec (char *new_name, char *old_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) { int new_file, old_file; /* Pointers to the base of the image of the two files. */ caddr_t old_base, new_base; #if MAP_ANON == 0 int mmap_fd; #else # define mmap_fd -1 #endif /* Pointers to the file, program and section headers for the old and new files. */ ElfW(Ehdr) *old_file_h, *new_file_h; ElfW(Phdr) *old_program_h, *new_program_h; ElfW(Shdr) *old_section_h, *new_section_h; /* Point to the section name table in the old file */ char *old_section_names; ElfW(Addr) old_bss_addr, new_bss_addr,new_data2_addr; ElfW(Off) old_bss_size, new_data2_size,old_bss_offset,new_data2_offset,old_file_size,new_file_size,data_bss_offset; int n, nn; int old_bss_index, old_sbss_index; int old_data_index, new_data2_index; /* int old_mdebug_index; */ struct stat stat_buf; /* Open the old file, allocate a buffer of the right size, and read in the file contents. */ old_file = open (old_name, O_RDONLY); if (old_file < 0) fatal ("Can't open %s for reading: errno %d\n", old_name, errno); if (fstat (old_file, &stat_buf) == -1) fatal ("Can't fstat (%s): errno %d\n", old_name, errno); #if MAP_ANON == 0 mmap_fd = open ("/dev/zero", O_RDONLY); if (mmap_fd < 0) fatal ("Can't open /dev/zero for reading: errno %d\n", errno); #endif /* We cannot use malloc here because that may use sbrk. If it does, we'd dump our temporary buffers with Emacs, and we'd have to be extra careful to use the correct value of sbrk(0) after allocating all buffers in the code below, which we aren't. */ old_file_size = stat_buf.st_size; old_base = mmap (NULL, old_file_size, PROT_READ,MAP_SHARED, old_file, 0); if (old_base == MAP_FAILED) fatal ("Can't allocate buffer for %s\n", old_name); /* errno=0; */ /* if (read (old_file, old_base, stat_buf.st_size) != stat_buf.st_size) */ /* fatal ("Didn't read all of %s: errno %d\n", old_name, errno); */ /* Get pointers to headers & section names */ old_file_h = (ElfW(Ehdr) *) old_base; old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff); old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff); old_section_names = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; /* Find the mdebug section, if any. */ /* old_mdebug_index = find_section (".mdebug", old_section_names, */ /* old_name, old_file_h, old_section_h, 1); */ /* Find the old .bss section. Figure out parameters of the new * data2 and bss sections. */ old_bss_index = find_section (".bss", old_section_names, old_name, old_file_h, old_section_h, 0); old_sbss_index = find_section (".sbss", old_section_names, old_name, old_file_h, old_section_h, 1); if (old_sbss_index != -1) if (OLD_SECTION_H (old_sbss_index).sh_type == SHT_PROGBITS) old_sbss_index = -1; if (old_sbss_index == -1) { old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; old_bss_offset = OLD_SECTION_H (old_bss_index).sh_offset; old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; new_data2_index = old_bss_index; } else { old_bss_addr = OLD_SECTION_H (old_sbss_index).sh_addr; old_bss_offset = OLD_SECTION_H (old_sbss_index).sh_offset; old_bss_size = OLD_SECTION_H (old_bss_index).sh_size + OLD_SECTION_H (old_sbss_index).sh_size; new_data2_index = old_sbss_index; } /* Find the old .data section. Figure out parameters of the new data2 and bss sections. */ old_data_index = find_section (".data", old_section_names, old_name, old_file_h, old_section_h, 0); #if defined (emacs) || !defined (DEBUG) new_bss_addr = (ElfW(Addr)) sbrk (0); #else new_bss_addr = old_bss_addr + old_bss_size + 0x1234; #endif new_data2_addr = old_bss_addr; new_data2_size = new_bss_addr - old_bss_addr; new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + /*to preserve data offset alignment*/ (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); #ifdef DEBUG emsg("old_bss_index %d\n", old_bss_index); emsg("old_bss_addr %x\n", old_bss_addr); emsg("old_bss_size %x\n", old_bss_size); emsg("new_bss_addr %x\n", new_bss_addr); emsg("new_data2_addr %x\n", new_data2_addr); emsg("new_data2_size %x\n", new_data2_size); emsg("new_data2_offset %x\n", new_data2_offset); #endif if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) fatal (".bss shrank when undumping???\n"); /* Set the output file to the right size. Allocate a buffer to hold the image of the new file. Set pointers to various interesting objects. stat_buf still has old_file data. */ new_file = open (new_name, O_RDWR | O_CREAT, 0666); if (new_file < 0) fatal ("Can't creat (%s): errno %d\n", new_name, errno); data_bss_offset=CEI(new_data2_offset-old_bss_offset,sizeof(long));/*????, e.g. sparc64*/ new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size + data_bss_offset; if (ftruncate (new_file, new_file_size)) fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); new_base = mmap (NULL, new_file_size, PROT_READ | PROT_WRITE,MAP_SHARED, new_file, 0); if (new_base == MAP_FAILED) fatal ("Can't allocate buffer for %s\n", old_name); new_file_h = (ElfW(Ehdr) *) new_base; new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff); new_section_h = (ElfW(Shdr) *) ((byte *) new_base + old_file_h->e_shoff + new_data2_size + data_bss_offset); /* Make our new file, program and section headers as copies of the * originals. */ memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); memcpy (new_program_h, old_program_h, old_file_h->e_phnum * old_file_h->e_phentsize); /* Modify the e_shstrndx if necessary. */ PATCH_INDEX (new_file_h->e_shstrndx); /* Fix up file header. We'll add one section. Section header is * further away now. */ new_file_h->e_shoff += new_data2_size + data_bss_offset; new_file_h->e_shnum += 1; #ifdef DEBUG emsg("Old section offset %x\n", old_file_h->e_shoff); emsg("Old section count %d\n", old_file_h->e_shnum); emsg("New section offset %x\n", new_file_h->e_shoff); emsg("New section count %d\n", new_file_h->e_shnum); #endif /* Fix up a new program header. Extend the writable data segment so * that the bss area is covered too. Find that segment by looking * for a segment that ends just before the .bss area. Make sure * that no segments are above the new .data2. Put a loop at the end * to adjust the offset and address of any segment that is above * data2, just in case we decide to allow this later. */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { /* Compute maximum of all requirements for alignment of section. */ ElfW(Word) alignment = (NEW_PROGRAM_H (n)).p_align; if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) alignment = OLD_SECTION_H (old_bss_index).sh_addralign; #ifdef __sgi /* According to r02kar@x4u2.desy.de (Karsten Kuenne) and oliva@gnu.org (Alexandre Oliva), on IRIX 5.2, we always get "Program segment above .bss" when dumping when the executable doesn't have an sbss section. */ if (old_sbss_index != -1) #endif /* __sgi */ if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > (old_sbss_index == -1 ? old_bss_addr : round_up (old_bss_addr, alignment))) fatal ("Program segment above .bss in %s\n", old_name); if (NEW_PROGRAM_H (n).p_type == PT_LOAD && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + (NEW_PROGRAM_H (n)).p_filesz, alignment) <= round_up (old_bss_addr, alignment))) break; } if (n < 0) fatal ("Couldn't find segment next to .bss in %s\n", old_name); /* Make sure that the size includes any padding before the old .bss section. */ NEW_PROGRAM_H (n).p_filesz = new_bss_addr - NEW_PROGRAM_H (n).p_vaddr; NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; #if 0 /* Maybe allow section after data2 - does this ever happen? */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { if (NEW_PROGRAM_H (n).p_vaddr && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) NEW_PROGRAM_H (n).p_offset += new_data2_size; } #endif /* Fix up section headers based on new .data2 section. Any section * whose offset or virtual address is after the new .data2 section * gets its value adjusted. .bss size becomes zero and new address * is set. data2 section header gets added by copying the existing * .data header and modifying the offset, address and size. */ for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum; old_data_index++) if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, ".data")) break; if (old_data_index == old_file_h->e_shnum) fatal ("Can't find .data in %s.\n", old_name); /* Walk through all section headers, insert the new data2 section right before the new bss section. */ for (n = 0, nn = 0; n < (int) old_file_h->e_shnum; n++, nn++) { caddr_t src; /* If it is (s)bss section, insert the new data2 section before it. */ /* new_data2_index is the index of either old_sbss or old_bss, that was chosen as a section for new_data2. */ if (n == new_data2_index) { /* Steal the data section header for this data2 section. */ memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), new_file_h->e_shentsize); NEW_SECTION_H (nn).sh_addr = new_data2_addr; NEW_SECTION_H (nn).sh_offset = new_data2_offset; NEW_SECTION_H (nn).sh_size = new_data2_size; /* Use the bss section's alignment. This will assure that the new data2 section always be placed in the same spot as the old bss section by any other application. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; /* for gcl make the NEW_SECTION_H executable since it will have code in it. */ NEW_SECTION_H (nn).sh_flags |= SHF_EXECINSTR; /* Now copy over what we have in the memory now. */ memcpy (NEW_SECTION_H (nn).sh_offset + new_base, (caddr_t) OLD_SECTION_H (n).sh_addr, new_data2_size); nn++; } memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), old_file_h->e_shentsize); if (n == old_bss_index /* The new bss and sbss section's size is zero, and its file offset and virtual address should be off by NEW_DATA2_SIZE. */ || n == old_sbss_index ) { /* NN should be `old_s?bss_index + 1' at this point. */ NEW_SECTION_H (nn).sh_offset = NEW_SECTION_H (new_data2_index).sh_offset + new_data2_size; NEW_SECTION_H (nn).sh_addr = NEW_SECTION_H (new_data2_index).sh_addr + new_data2_size; /* Let the new bss section address alignment be the same as the section address alignment followed the old bss section, so this section will be placed in exactly the same place. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; NEW_SECTION_H (nn).sh_size = 0; } else { /* Any section that was originally placed after the .bss section should now be off by NEW_DATA2_SIZE. If a section overlaps the .bss section, consider it to be placed after the .bss section. Overlap can occur if the section just before .bss has less-strict alignment; this was observed between .symtab and .bss on Solaris 2.5.1 (sparc) with GCC snapshot 960602. */ #ifdef SOLARIS_POWERPC /* On PPC Reference Platform running Solaris 2.5.1 the plt section is also of type NOBI like the bss section. (not really stored) and therefore sections after the bss section start at the plt offset. The plt section is always the one just before the bss section. It would be better to put the new data section before the .plt section, or use libelf instead. Erik Deumens, deumens@qtp.ufl.edu. */ if (NEW_SECTION_H (nn).sh_offset >= OLD_SECTION_H (old_bss_index-1).sh_offset) NEW_SECTION_H (nn).sh_offset += new_data2_size; #else if (NEW_SECTION_H (nn).sh_offset >= old_bss_offset || /* solaris has symtab straddling bss offset */ NEW_SECTION_H (nn).sh_offset+NEW_SECTION_H (nn).sh_size > old_bss_offset) NEW_SECTION_H (nn).sh_offset += new_data2_size+data_bss_offset; #endif /* Any section that was originally placed after the section header table should now be off by the size of one section header table entry. */ if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff) NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize; } /* If any section hdr refers to the section after the new .data section, make it refer to next one because we have inserted a new section in between. */ PATCH_INDEX (NEW_SECTION_H (nn).sh_link); /* For symbol tables, info is a symbol table index, so don't change it. */ if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) PATCH_INDEX (NEW_SECTION_H (nn).sh_info); if (old_sbss_index != -1) if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".sbss")) { NEW_SECTION_H (nn).sh_offset = round_up (NEW_SECTION_H (nn).sh_offset, NEW_SECTION_H (nn).sh_addralign); NEW_SECTION_H (nn).sh_type = SHT_PROGBITS; } /* Now, start to copy the content of sections. */ if (NEW_SECTION_H (nn).sh_type == SHT_NULL || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) continue; /* Write out the sections. .data and .data1 (and data2, called ".data" in the strings table) get copied from the current process instead of the old file. */ if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".sdata") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".lit4") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".lit8") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".sdata1") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".data1") || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".sbss")) src = (caddr_t) OLD_SECTION_H (n).sh_addr; else src = old_base + OLD_SECTION_H (n).sh_offset; memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, NEW_SECTION_H (nn).sh_size); #ifdef __alpha__ /* Update Alpha COFF symbol table: */ if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug") == 0) { pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base); symhdr->cbLineOffset += new_data2_size; symhdr->cbDnOffset += new_data2_size; symhdr->cbPdOffset += new_data2_size; symhdr->cbSymOffset += new_data2_size; symhdr->cbOptOffset += new_data2_size; symhdr->cbAuxOffset += new_data2_size; symhdr->cbSsOffset += new_data2_size; symhdr->cbSsExtOffset += new_data2_size; symhdr->cbFdOffset += new_data2_size; symhdr->cbRfdOffset += new_data2_size; symhdr->cbExtOffset += new_data2_size; } #endif /* __alpha__ */ #if defined (__sony_news) && defined (_SYSTYPE_SYSV) if (NEW_SECTION_H (nn).sh_type == SHT_MIPS_DEBUG && old_mdebug_index != -1) { int diff = NEW_SECTION_H(nn).sh_offset - OLD_SECTION_H(old_mdebug_index).sh_offset; HDRR *phdr = (HDRR *)(NEW_SECTION_H (nn).sh_offset + new_base); if (diff) { phdr->cbLineOffset += diff; phdr->cbDnOffset += diff; phdr->cbPdOffset += diff; phdr->cbSymOffset += diff; phdr->cbOptOffset += diff; phdr->cbAuxOffset += diff; phdr->cbSsOffset += diff; phdr->cbSsExtOffset += diff; phdr->cbFdOffset += diff; phdr->cbRfdOffset += diff; phdr->cbExtOffset += diff; } } #endif /* __sony_news && _SYSTYPE_SYSV */ #if __sgi /* Adjust the HDRR offsets in .mdebug and copy the line data if it's in its usual 'hole' in the object. Makes the new file debuggable with dbx. patches up two problems: the absolute file offsets in the HDRR record of .mdebug (see /usr/include/syms.h), and the ld bug that gets the line table in a hole in the elf file rather than in the .mdebug section proper. David Anderson. davea@sgi.com Jan 16,1994. */ if (n == old_mdebug_index) { #define MDEBUGADJUST(__ct,__fileaddr) \ if (n_phdrr->__ct > 0) \ { \ n_phdrr->__fileaddr += movement; \ } HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); unsigned movement = new_data2_size; MDEBUGADJUST (idnMax, cbDnOffset); MDEBUGADJUST (ipdMax, cbPdOffset); MDEBUGADJUST (isymMax, cbSymOffset); MDEBUGADJUST (ioptMax, cbOptOffset); MDEBUGADJUST (iauxMax, cbAuxOffset); MDEBUGADJUST (issMax, cbSsOffset); MDEBUGADJUST (issExtMax, cbSsExtOffset); MDEBUGADJUST (ifdMax, cbFdOffset); MDEBUGADJUST (crfd, cbRfdOffset); MDEBUGADJUST (iextMax, cbExtOffset); /* The Line Section, being possible off in a hole of the object, requires special handling. */ if (n_phdrr->cbLine > 0) { if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + OLD_SECTION_H (n).sh_size)) { /* line data is in a hole in elf. do special copy and adjust for this ld mistake. */ n_phdrr->cbLineOffset += movement; memcpy (n_phdrr->cbLineOffset + new_base, o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); } else { /* somehow line data is in .mdebug as it is supposed to be. */ MDEBUGADJUST (cbLine, cbLineOffset); } } } #endif /* __sgi */ /* If it is the symbol table, its st_shndx field needs to be patched. */ if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) { ElfW(Shdr) *spt = &NEW_SECTION_H (nn); unsigned int num = spt->sh_size / spt->sh_entsize; ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset + new_base); for (; num--; sym++) { if ((sym->st_shndx == SHN_UNDEF) || (sym->st_shndx == SHN_ABS) || (sym->st_shndx == SHN_COMMON)) continue; PATCH_INDEX (sym->st_shndx); } } } /* Update the symbol values of _edata and _end. */ for (n = new_file_h->e_shnum - 1; n; n--) { byte *symnames; ElfW(Sym) *symp, *symendp; if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM && NEW_SECTION_H (n).sh_type != SHT_SYMTAB) continue; symnames = ((byte *) new_base + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset); symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base); symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size); for (; symp < symendp; symp ++) if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0 || strcmp ((char *) (symnames + symp->st_name), "end") == 0 || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0 || strcmp ((char *) (symnames + symp->st_name), "edata") == 0) memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr)); } /* This loop seeks out relocation sections for the data section, so that it can undo relocations performed by the runtime linker. */ for (n = new_file_h->e_shnum - 1; n; n--) { ElfW(Shdr) section = NEW_SECTION_H (n); switch (section.sh_type) { default: break; case SHT_REL: case SHT_RELA: /* This code handles two different size structs, but there should be no harm in that provided that r_offset is always the first member. */ nn = section.sh_info; if (nn && (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".sdata") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".lit4") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".lit8") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".sdata1") || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), ".data1"))) { ElfW(Addr) offset = NEW_SECTION_H (nn).sh_addr - NEW_SECTION_H (nn).sh_offset; caddr_t reloc = old_base + section.sh_offset, end; for (end = reloc + section.sh_size; reloc < end; reloc += section.sh_entsize) { ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset; #ifdef __alpha__ /* The Alpha ELF binutils currently have a bug that sometimes results in relocs that contain all zeroes. Work around this for now... */ if (((ElfW(Rel) *) reloc)->r_offset == 0) continue; #endif memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr))); } } break; } } /* Write out new_file, and free the buffers. */ /* if (write (new_file, new_base, new_file_size) != new_file_size) */ /* fatal ("Didn't write %d bytes to %s: errno %d\n", */ /* new_file_size, new_base, errno); */ munmap (old_base, old_file_size); munmap (new_base, new_file_size); /* Close the files and make the new file executable. */ #if MAP_ANON == 0 close (mmap_fd); #endif if (close (old_file)) fatal ("Can't close (%s): errno %d\n", old_name, errno); if (close (new_file)) fatal ("Can't close (%s): errno %d\n", new_name, errno); if (stat (new_name, &stat_buf) == -1) fatal ("Can't stat (%s): errno %d\n", new_name, errno); n = umask (777); umask (n); stat_buf.st_mode |= 0111 & ~n; if (chmod (new_name, stat_buf.st_mode) == -1) fatal ("Can't chmod (%s): errno %d\n", new_name, errno); } /* All of the above is from the emacs-20.7 file. This comment and the following are added for gcl. Also we changed the above (near "for gcl") we make the NEW_SECTION_H executable since it will have code in it. NEW_SECTION_H (nn).sh_flags |= SHF_EXECINSTR; Partly synchronized with Emacs HEAD of 2004-04-12 by Magnus Henoch. The files themselves are no longer mmap'ed, but memory is allocated with mmap, and everything is written to the new file at the end. */ #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/iteration.c0000755000175000017500000002162214360276512013401 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* iteration.c */ #include "include.h" static void FFN(Floop)(object form) { object x; object *oldlex = lex_env; object *top; make_nil_block(); if (nlj_active) { nlj_active = FALSE; frs_pop(); lex_env = oldlex; return; } top = vs_top; for(x = form; !endp(x); x = MMcdr(x)) { vs_top = top; eval(MMcar(x)); } LOOP: /* Just !endp(x) is replaced by x != Cnil. */ for(x = form; x != Cnil; x = MMcdr(x)) { vs_top = top; eval(MMcar(x)); } goto LOOP; } /* use of VS in Fdo and FdoA: | | lex_env -> | lex1 | | lex2 | | lex3 | start -> |-------| where each bt is a bind_temp: | bt1 | |-------| | var | -- name of DO variable : | spp | -- T if special |-------| | init | | btn | | aux | -- step-form or var (if no |-------| step-form is given) end -> | body | old_top-> |-------| If 'spp' != T, it is NIL during initialization, and is the pointer to (var value) in lexical environment during the main loop. */ static void do_var_list(object var_list) { object is, x, y; for (is = var_list; !endp(is); is = MMcdr(is)) { x = MMcar(is); if (type_of(x)==t_symbol) {vs_push(x);vs_push(Cnil);vs_push(Cnil);vs_push(x); continue;} if (!consp(x)) FEinvalid_form("The index, ~S, is illegal.", x); y = MMcar(x); check_var(y); vs_push(y); vs_push(Cnil); if (endp(MMcdr(x))) { vs_push(Cnil); vs_push(y); } else { x = MMcdr(x); vs_push(MMcar(x)); if (endp(MMcdr(x))) vs_push(y); else { x = MMcdr(x); vs_push(MMcar(x)); if (!endp(MMcdr(x))) FEerror("Too many forms to the index ~S.", 1, y); } } } } static void FFN(Fdo)(VOL object arg) { object *oldlex = lex_env; object *old_top; struct bind_temp *start, *end, *bt; object end_test, body; VOL object result; bds_ptr old_bds_top = bds_top; if (endp(arg) || endp(MMcdr(arg))) FEtoo_few_argumentsF(arg); if (endp(MMcadr(arg))) FEinvalid_form("The DO end-test, ~S, is illegal.", MMcadr(arg)); end_test = MMcaadr(arg); result = MMcdadr(arg); make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } start = (struct bind_temp *) vs_top; do_var_list(MMcar(arg)); end = (struct bind_temp *)vs_top; body = let_bind(MMcddr(arg), start, end); vs_push(body); for (bt = start; bt < end; bt++) if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary) bt->bt_spp = Ct; else if (bt->bt_spp == Cnil) bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]); old_top = vs_top; LOOP: /* the main loop */ vs_top = old_top; eval(end_test); if (vs_base[0] != Cnil) { /* RESULT evaluation */ if (endp(result)) { vs_base = vs_top = old_top; vs_push(Cnil); } else do { vs_top = old_top; eval(MMcar(result)); result = MMcdr(result); } while (!endp(result)); goto END; } vs_top = old_top; Ftagbody(body); /* next step */ for (bt = start; btbt_aux != bt->bt_var) { eval_assign(bt->bt_init, bt->bt_aux); } } for (bt = start; btbt_aux != bt->bt_var) { if (bt->bt_spp == Ct) bt->bt_var->s.s_dbind = bt->bt_init; else MMcadr(bt->bt_spp) = bt->bt_init; } } goto LOOP; END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } static void FFN(FdoA)(VOL object arg) { object *oldlex = lex_env; object *old_top; struct bind_temp *start, *end, *bt; object end_test, body; VOL object result; bds_ptr old_bds_top = bds_top; if (endp(arg) || endp(MMcdr(arg))) FEtoo_few_argumentsF(arg); if (endp(MMcadr(arg))) FEinvalid_form("The DO* end-test, ~S, is illegal.", MMcadr(arg)); end_test = MMcaadr(arg); result = MMcdadr(arg); make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } start = (struct bind_temp *)vs_top; do_var_list(MMcar(arg)); end = (struct bind_temp *)vs_top; body = letA_bind(MMcddr(arg), start, end); vs_push(body); for (bt = start; bt < end; bt++) if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary) bt->bt_spp = Ct; else if (bt->bt_spp == Cnil) bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]); old_top = vs_top; LOOP: /* the main loop */ eval(end_test); if (vs_base[0] != Cnil) { /* RESULT evaluation */ if (endp(result)) { vs_base = vs_top = old_top; vs_push(Cnil); } else do { vs_top = old_top; eval(MMcar(result)); result = MMcdr(result); } while (!endp(result)); goto END; } vs_top = old_top; Ftagbody(body); /* next step */ for (bt = start; bt < end; bt++) if (bt->bt_aux != bt->bt_var) { if (bt->bt_spp == Ct) { eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux); } else { eval_assign(MMcadr(bt->bt_spp), bt->bt_aux); } } goto LOOP; END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } static void FFN(Fdolist)(VOL object arg) { object *oldlex = lex_env; object *old_top; struct bind_temp *start; object x, listform, body; VOL object result; bds_ptr old_bds_top = bds_top; if (endp(arg)) FEtoo_few_argumentsF(arg); x = MMcar(arg); if (endp(x)) FEerror("No variable.", 0); start = (struct bind_temp *)vs_top; vs_push(MMcar(x)); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); x = MMcdr(x); if (endp(x)) FEerror("No listform.", 0); listform = MMcar(x); x = MMcdr(x); if (endp(x)) result = Cnil; else { result = MMcar(x); if (!endp(MMcdr(x))) FEerror("Too many resultforms.", 0); } make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } eval_assign(start->bt_init, listform); body = find_special(MMcdr(arg), start, start+1,NULL); /*?*/ vs_push(body); bind_var(start->bt_var, Cnil, start->bt_spp); if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) start->bt_spp = Ct; else if (start->bt_spp == Cnil) start->bt_spp = assoc_eq(start->bt_var, lex_env[0]); old_top = vs_top; LOOP: /* the main loop */ if (endp(start->bt_init)) { if (start->bt_spp == Ct) start->bt_var->s.s_dbind = Cnil; else MMcadr(start->bt_spp) = Cnil; eval(result); goto END; } if (start->bt_spp == Ct) start->bt_var->s.s_dbind = MMcar(start->bt_init); else MMcadr(start->bt_spp) = MMcar(start->bt_init); start->bt_init = MMcdr(start->bt_init); vs_top = old_top; Ftagbody(body); goto LOOP; END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } static void FFN(Fdotimes)(VOL object arg) { object *oldlex = lex_env; object *old_top; struct bind_temp *start; object x, countform, body; VOL object result; bds_ptr old_bds_top = bds_top; if (endp(arg)) FEtoo_few_argumentsF(arg); x = MMcar(arg); if (endp(x)) FEerror("No variable.", 0); start = (struct bind_temp *)vs_top; vs_push(MMcar(x)); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); x = MMcdr(x); if (endp(x)) FEerror("No countform.", 0); countform = MMcar(x); x = MMcdr(x); if (endp(x)) result = Cnil; else { result = MMcar(x); if (!endp(MMcdr(x))) FEerror("Too many resultforms.", 0); } make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } eval_assign(start->bt_init, countform); if (type_of(start->bt_init) != t_fixnum && type_of(start->bt_init) != t_bignum) FEwrong_type_argument(sLinteger, start->bt_init); body = find_special(MMcdr(arg), start, start+1,NULL); /*?*/ vs_push(body); bind_var(start->bt_var, make_fixnum(0), start->bt_spp); if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) { start->bt_spp = Ct; x = start->bt_var->s.s_dbind; } else if (start->bt_spp == Cnil) { start->bt_spp = assoc_eq(start->bt_var, lex_env[0]); x = MMcadr(start->bt_spp); } else x = start->bt_var->s.s_dbind; old_top = vs_top; LOOP: /* the main loop */ if (number_compare(x, start->bt_init) >= 0) { eval(result); goto END; } vs_top = old_top; Ftagbody(body); if (start->bt_spp == Ct) x = start->bt_var->s.s_dbind = one_plus(x); else x = MMcadr(start->bt_spp) = one_plus(x); goto LOOP; END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } void gcl_init_iteration(void) { make_special_form("LOOP", Floop); make_special_form("DO", Fdo); make_special_form("DO*", FdoA); make_special_form("DOLIST", Fdolist); make_special_form("DOTIMES", Fdotimes); } gcl-2.6.14/o/fasldlsym.c.link0000755000175000017500000000401614360276512014333 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #ifdef HAVE_ELF #include #endif /* cc -DVOL=volatile -G 0 -c foo.c ; ld -shared foo.o -o jim.o ; cat foo.data >> jim.o */ int did_a_dynamic_load; fasload(faslfile) object faslfile; { void *dlp ; int (*fptr)(); char buf[200]; static count=0; object memory; object data; char filename[MAXPATHLEN]; coerce_to_filename(truename(faslfile), filename); sprintf(buf,"./ufas%dxXXXXXX",count++); /* this is just to allow reloading in the same file twice. */ mktemp(buf); link(filename,buf); dlp = dlopen(buf,RTLD_NOW); if (dlp ==0) FEerror("Cant open for dynamic link ~a",1,faslfile); fptr = (int (*)())dlsym(dlp, "init_code"); if (fptr == 0) { FEerror("Cant find init_code in ~a",1,make_simple_string(faslfile));} faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); SEEK_TO_END_OFILE(faslfile->sm.sm_fp); data = read_fasl_vector(faslfile); memory = alloc_object(t_cfdata); memory->cfd.cfd_self = NULL; memory->cfd.cfd_start = NULL; memory->cfd.cfd_size = 0; if(symbol_value(sLAload_verboseA)!=Cnil) printf(" start address (dynamic) 0x%x ",fptr); call_init(0,memory,data,fptr); /* unlink(buf); */ did_a_dynamic_load = 1; return memory->cfd.cfd_size; } gcl-2.6.14/o/unixfasl.c0000755000175000017500000001040614360276512013232 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define IN_UNIXFASL #include "include.h" #ifdef UNIXFASL #include UNIXFASL #else #ifdef HAVE_AOUT #undef BSD #undef ATT #define BSD #include HAVE_AOUT #endif #ifdef COFF_ENCAPSULATE #undef BSD #undef ATT #define BSD #include "a.out.encap.h" #endif #ifdef ATT #include #include #include #endif #ifdef E15 #include #define exec bhdr #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #endif #ifdef BSD #define textsize header.a_text #define datasize header.a_data #define bsssize header.a_bss #ifdef COFF_ENCAPSULATE #define textstart sizeof(header) +sizeof(struct coffheader) #else #define textstart sizeof(header) #endif #define newbsssize newheader.a_bss #endif #ifndef HEADER_SEEK #define HEADER_SEEK #endif #ifndef MAXPATHLEN # define MAXPATHLEN 1024 #endif #ifndef SFASL #error must define SFASL #endif /* ifndef SFASL */ #ifndef __svr4__ #ifdef BSD #define FASLINK #ifndef PRIVATE_FASLINK DEFUN_NEW("FASLINK-INT",object,fSfaslink_int,SI,2,2,NONE,II,OO,OO,OO,(object faslfile, object ldargstring),"") { #if defined(__ELF__) || defined(DARWIN) FEerror("faslink() not supported for ELF or DARWIN yet",0); return 0; #else struct exec header, faslheader; object memory, data, tempfile; FILE *fp; char filename[MAXPATHLEN]; char ldargstr[MAXPATHLEN]; char tempfilename[32]; char command[MAXPATHLEN * 2]; char buf[BUFSIZ]; int i; object *old_vs_base = vs_base; object *old_vs_top = vs_top; coerce_to_filename(ldargstring, ldargstr); coerce_to_filename(faslfile, filename); sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); LD_COMMAND(command, kcl_self, (int)core_end, filename, ldargstr, tempfilename); if (system(command) != 0) FEerror("The linkage editor failed.", 0); fp = fopen(tempfilename, "r"); setbuf(fp, buf); fread(&header, sizeof(header), 1, fp); {BEGIN_NO_INTERRUPT; memory=new_cfdata(); memory->cfd.cfd_size = textsize + datasize + bsssize; vs_push(memory); memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, memory->cfd.cfd_size, sizeof(double)); END_NO_INTERRUPT;} fclose(fp); faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); vs_push(faslfile); #ifdef SEEK_TO_END_OFILE SEEK_TO_END_OFILE(faslfile->sm.sm_fp); #else fp = faslfile->sm.sm_fp; fread(&faslheader, sizeof(faslheader), 1, fp); fseek(fp, faslheader.a_text+faslheader.a_data+ faslheader.a_syms+faslheader.a_trsize+faslheader.a_drsize, 1); fread(&i, sizeof(i), 1, fp); fseek(fp, i - sizeof(i), 1); #endif data = read_fasl_vector(faslfile); vs_push(data); close_stream(faslfile); LD_COMMAND(command, kcl_self, memory->cfd.cfd_start, filename, ldargstr, tempfilename); if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %x ",memory->cfd.cfd_start); if (system(command) != 0) FEerror("The linkage editor failed.", 0); tempfile = make_simple_string(tempfilename); vs_push(tempfile); tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); vs_push(tempfile); fp = tempfile->sm.sm_fp; if (fseek(fp, textstart, 0) < 0) error("file seek error"); fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); close_stream(tempfile); unlink(tempfilename); call_init(0,memory,data,0); vs_base = old_vs_base; vs_top = old_vs_top; return(memory->cfd.cfd_size); #endif } #endif #endif #endif/* svr4 */ #endif /* UNIXFASL */ void gcl_init_unixfasl(void) { } gcl-2.6.14/o/sbrk.c0000755000175000017500000000051214360276512012337 0ustar cammcamm#include extern char end; static caddr_t curbrk = &end; caddr_t sbrk(int n); void * sbrk(int n) { int res; if (n==0) return curbrk; { void * x=curbrk; char *p; p=curbrk; p=p+n; res = brk(p); if (res==-1) error("can't set brk"); else curbrk = p; return (x); } } gcl-2.6.14/o/number.c0000755000175000017500000001544014360276512012674 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* number.c IMPLEMENTATION-DEPENDENT This file creates some implementation dependent constants. */ #define IN_NUM_CO #include "include.h" #include "num_include.h" long fixint(object x) { if (type_of(x) != t_fixnum) FEwrong_type_argument(sLfixnum, x); return(fix(x)); } int fixnnint(object x) { if (type_of(x) != t_fixnum || fix(x) < 0) FEerror("~S is not a non-negative fixnum.", 1, x); return(fix(x)); } #if 0 object small_fixnum ( int i ) { #include assert ( ( -SMALL_FIXNUM_LIMIT <= i ) && ( i < SMALL_FIXNUM_LIMIT ) ); (object) small_fixnum_table + SMALL_FIXNUM_LIMIT + i; } #endif /* #if !defined(IM_FIX_BASE) */ #define BIGGER_FIXNUM_RANGE #ifdef BIGGER_FIXNUM_RANGE struct {int min,max;} bigger_fixnums; struct fixnum_struct *bigger_fixnum_table; #if !defined(IM_FIX_BASE) || defined(USE_SAFE_CDR) #define STATIC_BIGGER_FIXNUM_TABLE_BITS 10 static struct fixnum_struct bigger_fixnum_table1[1<<(STATIC_BIGGER_FIXNUM_TABLE_BITS+1)] OBJ_ALIGN; #endif DEFUN_NEW("ALLOCATE-BIGGER-FIXNUM-RANGE",object,fSallocate_bigger_fixnum_range,SI,2,2,NONE,OI,IO,OO,OO,(fixnum min,fixnum max),"") { int j; if (min > max) FEerror("Need Min <= Max",0); #if !defined(IM_FIX_BASE) || defined(USE_SAFE_CDR) if (min==-(1<fw=0; set_type_of(x,t_fixnum); x->FIX.FIXVAL=j; } bigger_fixnums.min=min; bigger_fixnums.max=max; return Ct; } #endif /* #endif */ object make_fixnum1(long i) { object x; /* In a macro now */ /* if (-SMALL_FIXNUM_LIMIT <= i && i < SMALL_FIXNUM_LIMIT) */ /* return(small_fixnum(i)); */ #ifdef BIGGER_FIXNUM_RANGE if (bigger_fixnum_table) { if (i >= bigger_fixnums.min && i < bigger_fixnums.max) return (object)(bigger_fixnum_table +(i -bigger_fixnums.min)); } #endif x = alloc_object(t_fixnum); set_fix(x,i); return(x); } object make_ratio(object num, object den) { object g, r, get_gcd(object x, object y); vs_mark; if (number_zerop(den)) FEerror("Zero denominator.", 0); if (number_zerop(num)) return(small_fixnum(0)); if (type_of(den) == t_fixnum && fix(den) == 1) return(num); if (number_minusp(den)) { num = number_negate(num); vs_push(num); den = number_negate(den); vs_push(den); } g = get_gcd(num, den); vs_push(g); num = integer_divide1(num, g,0); vs_push(num); den = integer_divide1(den, g,0); vs_push(den); if(type_of(den) == t_fixnum && fix(den) == 1) { vs_reset; return(num); } if(type_of(den) == t_fixnum && fix(den) == -1) { num = number_negate(num); vs_reset; return(num); } r = alloc_object(t_ratio); r->rat.rat_num = num; r->rat.rat_den = den; vs_reset; return(r); } object make_shortfloat(double f) { object x; if (f == (shortfloat)0.0) return(shortfloat_zero); x = alloc_object(t_shortfloat); sf(x) = (shortfloat)f; return(x); } object make_longfloat(longfloat f) { object x; if (f == (longfloat)0.0) return(longfloat_zero); x = alloc_object(t_longfloat); lf(x) = f; return(x); } object make_complex(object r, object i) { object c; vs_mark; switch (type_of(r)) { case t_fixnum: case t_bignum: case t_ratio: switch (type_of(i)) { case t_fixnum: if (fix(i) == 0) return(r); break; case t_shortfloat: r = make_shortfloat((shortfloat)number_to_double(r)); vs_push(r); break; case t_longfloat: r = make_longfloat(number_to_double(r)); vs_push(r); break; default: break; } break; case t_shortfloat: switch (type_of(i)) { case t_fixnum: case t_bignum: case t_ratio: i = make_shortfloat((shortfloat)number_to_double(i)); vs_push(i); break; case t_longfloat: r = make_longfloat((double)(sf(r))); vs_push(r); break; default: break; } break; case t_longfloat: switch (type_of(i)) { case t_fixnum: case t_bignum: case t_ratio: case t_shortfloat: i = make_longfloat(number_to_double(i)); vs_push(i); break; default: break; } break; default: break; } c = alloc_object(t_complex); c->cmp.cmp_real = r; c->cmp.cmp_imag = i; vs_reset; return(c); } double number_to_double(object x) { switch(type_of(x)) { case t_fixnum: return((double)(fix(x))); case t_bignum: return(big_to_double(/* (struct bignum *) */x)); case t_ratio: /* vs_base=vs_top; */ /* vs_push(x); */ /* Lround(); */ /* if (vs_base[0]!=small_fixnum(0)) */ /* return number_to_double(vs_base[0])+number_to_double(vs_base[1]); */ /* else */ { double dx,dy; object xx,yy; for (xx=x->rat.rat_num,yy=x->rat.rat_den,dx=number_to_double(xx),dy=number_to_double(yy); dx && dy && (!ISNORMAL(dx) || !ISNORMAL(dy));) { if (ISNORMAL(dx)) dx*=0.5; else { xx=integer_divide1(xx,small_fixnum(2),0); dx=number_to_double(xx); } if (ISNORMAL(dy)) dy*=0.5; else { yy=integer_divide1(yy,small_fixnum(2),0); dy=number_to_double(yy); } } return dx/dy; } case t_shortfloat: return((double)(sf(x))); case t_longfloat: return(lf(x)); default: wrong_type_argument(TSor_rational_float, x); return(0.0); } } void gcl_init_number(void) { #if !defined(IM_FIX_BASE) || defined(USE_SAFE_CDR) FFN(fSallocate_bigger_fixnum_range)(-1024,1024); #endif shortfloat_zero = alloc_object(t_shortfloat); sf(shortfloat_zero) = (shortfloat)0.0; longfloat_zero = alloc_object(t_longfloat); lf(longfloat_zero) = (longfloat)0.0; enter_mark_origin(&shortfloat_zero); enter_mark_origin(&longfloat_zero); make_constant("MOST-POSITIVE-FIXNUM", make_fixnum(MOST_POSITIVE_FIX)); make_constant("MOST-NEGATIVE-FIXNUM", make_fixnum(MOST_NEGATIVE_FIX)); gcl_init_big(); gcl_init_num_pred(); gcl_init_num_comp(); gcl_init_num_arith(); gcl_init_num_co(); gcl_init_num_log(); gcl_init_num_sfun(); gcl_init_num_rand(); } gcl-2.6.14/o/array.c10000755000175000017500000006655614360276512012621 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "include.h" #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP, make_fixnum(ARRAY_RANK_LIMIT),""); DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit, LISP, make_fixnum(MOST_POSITIVE_FIX),""); DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit, LISP, sLarray_dimension_limit,""); DEF_ORDINARY("BIT",sLbit,LISP,""); /* number of bits in unit of storage of x->bv.bv_self[0] */ #define BV_BITS 8 #define BITREF(x,i) \ ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ ? 1 : 0) #define SET_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) #define CLEAR_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) extern short aet_sizes[]; #define ARRAY_BODY_PTR(ar,n) \ (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) #define N_FIXNUM_ARGS 6 DEFUNO("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, NONE, OO, II, II, II,Laref,"") (x, i, va_alist) object x; int i; va_dcl { int n = VFUN_NARGS; int i1; va_list ap; if (type_of(x) == t_array) {int m,k ; int rank = n - 1; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",1,x); if (rank == 1) return fSaref1(x,i); if (rank == 0) return fSaref1(x,0); va_start(ap); m = 0; k = i; /* index into 1 dimensional array */ i1 = 0; rank-- ; while(1) { if (k >= x->a.a_dims[m]) FEerror("Index ~a to array is too large",1,make_fixnum (m)); i1 += k; m ++; if (m <= rank) { i1 = i1 * x->a.a_dims[m]; if (m < N_FIXNUM_ARGS) { k = va_arg(ap,int);} else {object x = va_arg(ap,object); check_type(x,t_fixnum); k = Mfix(x);} } else break;} va_end(ap); return fSaref1(x,i1); } if (n > 2) { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} return fSaref1(x,i); } int fScheck_bounds_bounds(x, i) object x; int i; { switch (type_of(x)) { case t_array: case t_vector: case t_string: if ((unsigned int) i >= x->a.a_dim) FEerror("Array ref out of bounds ~a ~a", 2, x, make_fixnum(i)); default: FEerror("not an array"); } } DEFUN("SVREF", object, fLsvref, LISP, 2, 2, ONE_VAL, OO, IO, OO,OO, "For array X and index I it returns (aref x i) ") (x, i) object x; unsigned int i; { if (type_of(x)==t_vector && (enum aelttype)x->v.v_elttype == aet_object && x->v.v_dim > i) RETURN1(x->v.v_self[i]); if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); FEerror("Bad simple vector ~a",1,x); } DEFUN("AREF1", object, fSaref1, SI, 2, 2, NONE, OO, IO, OO,OO, "For array X and index I it returns (aref x i) as if x were \ 1 dimensional, even though its rank may be bigger than 1") (x, i) object x; int i; { switch (type_of(x)) { case t_array: case t_vector: case t_bitvector: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: return x->v.v_self[i]; case aet_ch: return code_char(x->st.st_self[i]); case aet_bit: i += x->bv.bv_offset; return make_fixnum(BITREF(x, i)); case aet_fix: return make_fixnum(x->fixa.fixa_self[i]); case aet_sf: return make_longfloat(x->sfa.sfa_self[i]); case aet_lf: return make_longfloat(x->lfa.lfa_self[i]); case aet_char: return make_fixnum(x->st.st_self[i]); case aet_uchar: return make_fixnum(x->ust.ust_self[i]); case aet_short: return make_fixnum(SHORT(x, i)); case aet_ushort: return make_fixnum(USHORT(x, i)); default: FEerror("unknown array type"); } case t_string: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); return code_char(x->st.st_self[i]); default: FEerror("not an array"); ; } } DEFUN("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,"") (x, i,val) object x; int i; object val; { switch (type_of(x)) { case t_array: case t_vector: case t_bitvector: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: x->v.v_self[i] = val; break; case aet_ch: ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; case aet_bit: i += x->bv.bv_offset; AGAIN_BIT: ASSURE_TYPE(val,t_fixnum); {int v = Mfix(val); if (v == 0) CLEAR_BITREF(x,i); else if (v == 1) SET_BITREF(x,i); else {val= fSincorrect_type(val,sLbit); goto AGAIN_BIT;} break;} case aet_fix: ASSURE_TYPE(val,t_fixnum); (x->fixa.fixa_self[i]) = Mfix(val); break; case aet_sf: ASSURE_TYPE(val,t_shortfloat); (x->sfa.sfa_self[i]) = Msf(val); break; case aet_lf: ASSURE_TYPE(val,t_longfloat); (x->lfa.lfa_self[i]) = Mlf(val); break; case aet_char: ASSURE_TYPE(val,t_fixnum); x->st.st_self[i] = Mfix(val); break; case aet_uchar: ASSURE_TYPE(val,t_fixnum); (x->ust.ust_self[i])= Mfix(val); break; case aet_short: ASSURE_TYPE(val,t_fixnum); SHORT(x, i) = Mfix(val); break; case aet_ushort: ASSURE_TYPE(val,t_fixnum); USHORT(x, i) = Mfix(val); break; default: FEerror("unknown array type"); } break; case t_string: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; default: FEerror("not an array",0); } return val; } DEFUNO("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, OO, OO, OO,siLaset,"") (x,ii,y, va_alist) object x,y; object ii; va_dcl { int i1; int n = VFUN_NARGS; int i; va_list ap; if (type_of(x) == t_array) {int m,k ; int rank = n - 2; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",x); if (rank == 0) return fSaset1(x,0,ii); ASSURE_TYPE(ii,t_fixnum); i = fix(ii); if (rank == 1) return fSaset1(x,i,y); va_start(ap); m = 0; k = i; /* index into 1 dimensional array body */ i1 = 0; rank-- ; while(1) { if (k >= x->a.a_dims[m]) FEerror("Index ~a to array is too large",1,make_fixnum (m)); i1 += k; if (m < rank) {object u; if (m == 0) { u = y;} else { u = va_arg(ap,object);} check_type(u,t_fixnum); k = Mfix(u); m++ ; i1 = i1 * x->a.a_dims[m]; } else { y = va_arg(ap,object); break ;} } va_end(ap); } else { ASSURE_TYPE(ii,t_fixnum); i1 = fix(ii); } return fSaset1(x,i1,y); } DEFUNO("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, OO,siLsvset,"") (x,i,val) object x,val; int i; { if (TYPE_OF(x) != t_vector || DISPLACED_TO(x) != Cnil) Wrong_type_error("simple array",0); if (i > x->v.v_dim) { FEerror("out of bounds",0); } return x->v.v_self[i] = val; } /* (proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) (defun make-vector1 (n elt-type staticp &optional fillp initial-element displaced-to (displaced-index-offset 0)) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, IO,OO,OO,"") (n,elt_type,staticp,va_alist) int n;int elt_type;object staticp;va_dcl { int displaced_index_offset; int Inargs = VFUN_NARGS - 3; va_list Iap;object fillp;object initial_element;object displaced_to;object V9; object V10,V11,V12,V13,V14; Inargs = VFUN_NARGS - 3 ; { object x; BEGIN_NO_INTERRUPT; switch(elt_type) { case aet_ch: x = alloc_object(t_string); goto a_string; break; case aet_bit: x = alloc_object(t_bitvector); break; default: x = alloc_object(t_vector);} x->v.v_elttype = elt_type; a_string: x->v.v_dim = n; x->v.v_self = 0; x->v.v_displaced = Cnil; if( --Inargs < 0)goto LA1; else { va_start(Iap); fillp=va_arg(Iap,object); if (fillp == Cnil) {x->v.v_hasfillp = 0; x->v.v_fillp = n; } else if(type_of(fillp) == t_fixnum) { x->v.v_fillp = Mfix(fillp); if (x->v.v_fillp > n) FEerror("bad fillp",0); x->v.v_hasfillp = 1; } else { x->v.v_fillp = n; x->v.v_hasfillp = 1; } } if( --Inargs < 0)goto LA2; else { initial_element=va_arg(Iap,object);} if( --Inargs < 0)goto LA4; else { displaced_to=va_arg(Iap,object);} if( --Inargs < 0)goto LA5; else { V9=va_arg(Iap,object); if (displaced_to != Cnil) { ASSURE_TYPE(V9,t_fixnum); displaced_index_offset=Mfix(V9);}} goto LA6; LA1: x->v.v_hasfillp = 0; x->v.v_fillp = n; LA2: initial_element=Cnil; LA4: displaced_to=Cnil; LA5: displaced_index_offset= 0; LA6: x->v.v_adjustable = 1; va_end(Iap); { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } } } static object DFLT_aet_object = Cnil; static char DFLT_aet_ch = ' '; static char DFLT_aet_char = 0; static int DFLT_aet_fix = 0 ; static short DFLT_aet_short = 0; static shortfloat DFLT_aet_sf = 0.0; static longfloat DFLT_aet_lf = 0.0; static object Iname_t = sLt; struct { char * dflt; object *namep;} aet_types[] = { (char *) &DFLT_aet_object, &Iname_t, /* t */ (char *) &DFLT_aet_ch, &sLstring_char,/* string-char */ (char *) &DFLT_aet_fix, &sLbit, /* bit */ (char *) &DFLT_aet_fix, &sLfixnum, /* fixnum */ (char *) &DFLT_aet_sf, &sLshort_float, /* short-float */ (char *) &DFLT_aet_lf, &sLlong_float, /* long-float */ (char *) &DFLT_aet_char,&sLsigned_char, /* signed char */ (char *) &DFLT_aet_char,&sLunsigned_char, /* unsigned char */ (char *) &DFLT_aet_short,&sLsigned_short, /* signed short */ (char *) &DFLT_aet_short, &sLunsigned_short /* unsigned short */ }; DEFUN("GET-AELTTYPE",enum aelttype,fSget_aelttype,SI,1,1,NONE,IO,OO,OO,OO,"") (x) object x; { int i; for (i=0 ; i < aet_last ; i++) if (x == * aet_types[i].namep) return (enum aelttype) i; if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) return aet_lf; return aet_object; } /* backward compatibility only: (si:make-vector element-type 0 dimension 1 adjustable 2 fill-pointer 3 displaced-to 4 displaced-index-offset 5 static 6 &optional initial-element) */ DEFUNO("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, OO,OO,OO,OO,siLmake_vector,"")(x0,x1,x2,x3,x4,x5,x6,va_alist) object x0,x1,x2,x3,x4,x5,x6; va_dcl {int narg=VFUN_NARGS; object initial_elt; va_list ap; object x; {va_start(ap); if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; goto LEND_VARARG; LDEFAULT8: initial_elt = Cnil ; LEND_VARARG: va_end(ap);} /* 8 args */ VFUN_NARGS = 8; x = fSmake_vector1(Mfix(x1), /* n */ fSget_aelttype(x0), /*aelt type */ x6, /* staticp */ x3, /* fillp */ initial_elt, /* initial element */ x4, /*displaced to */ x5); /* displaced-index offset */ x0 = x; RETURN1(x0); } /* (proclaim '(ftype (function (fixnum t *)) make-array1)) (defun make-array1 ( elt-type staticp initial-element displaced-to displaced-index-offset &optional dim1 dim2 .. ) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, NONE,OI,OO,OI,OO,"") (elt_type,staticp,initial_element,displaced_to, displaced_index_offset, dimensions) int elt_type; object staticp,initial_element,displaced_to; int displaced_index_offset; object dimensions; { int rank = length(dimensions); { object x,v; char *tmp_alloc; int dim =1,i; BEGIN_NO_INTERRUPT; x = alloc_object(t_array); x->a.a_elttype = elt_type; x->a.a_self = 0; x->a.a_rank = rank; x->a.a_displaced = Cnil; x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); i = 0; v = dimensions; while (i < rank) { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); dim *= x->a.a_dims[i++]; v = Mcdr(v);} x->a.a_dim = dim; x->a.a_adjustable = 1; { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } }} /* (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) ;{ A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) */ displace(from_array,dest_array,offset) object from_array,dest_array; int offset; { enum aelttype typ; IisArray(from_array); IisArray(dest_array); typ =Iarray_element_type(from_array); if (typ != Iarray_element_type(dest_array)) { Wrong_type_error("same element type",0); } if (offset + from_array->a.a_dim > dest_array->a.a_dim) { FEerror("Destination array too small to hold other array",0); } /* ensure that we have a cons */ if (dest_array->a.a_displaced == Cnil) { dest_array->a.a_displaced = list(2,Cnil,from_array);} else Mcdr(dest_array->a.a_displaced) = make_cons(from_array, Mcdr(dest_array->a.a_displaced)); from_array->a.a_displaced = make_cons(dest_array,sLnil); /* now set the actual body of from_array to be the address of body in dest_array. If it is a bit array, this cannot carry the offset information, since the body is only recorded as multiples of BV_BITS */ if (typ == aet_bit) { offset += dest_array->bv.bv_offset; from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; from_array->bv.bv_offset = offset % BV_BITS; } else from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); } enum aelttype Iarray_element_type(x) object x; {enum aelttype t; switch(TYPE_OF(x)) { case t_array: t = (enum aelttype) x->a.a_elttype; break; case t_vector: t = (enum aelttype) x->v.v_elttype; break; case t_bitvector: t = aet_bit; break; case t_string: t = aet_ch; break; default: FEerror("Not an array ~a ",1,x); } return t; } /* Make the body of FROM array point to the body of TO at the DISPLACED_INDEX_OFFSET */ Idisplace_array(from,to,displaced_index_offset) object from,to; int displaced_index_offset; { enum aelttype t1,t2; object tail; t1 = Iarray_element_type(from); t2 = Iarray_element_type(to); if (t1 != t2) FEerror("Attempt to displace arrays of one type to arrays of another type",0); if (to->a.a_dim > from->a.a_dim - displaced_index_offset) FEerror("To array not large enough for displacement",0); {BEGIN_NO_INTERRUPT; from->a.a_displaced = make_cons(to,Cnil); if (to->a.a_displaced == Cnil) to->a.a_displaced = make_cons(Cnil,Cnil); DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); if (t1 == aet_bit) { displaced_index_offset += to->bv.bv_offset; from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; from->bv.bv_offset = displaced_index_offset%BV_BITS; } else from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); END_NO_INTERRUPT; } } /* add diff to body of x and arrays diisplaced to it */ adjust_displaced(x, diff) object x; int diff; { if (x->ust.ust_self != NULL) x->ust.ust_self = (char *)((int)(x->a.a_self) + diff); for (x = Mcdr(x->ust.ust_displaced); x != Cnil; x = Mcdr(x)) adjust_displaced(Mcar(x), diff); } /* RAW_AET_PTR returns a pointer to something of raw type obtained from X suitable for using GSET for an array of elt type TYP. If x is the null pointer, return a default for that array element type. */ char * raw_aet_ptr(x,typ) short typ; object x; { /* doubles are the largest raw type */ static double u; if (x==Cnil) return aet_types[typ].dflt; switch (typ){ #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; case aet_object: STORE_TYPED(&u,object,x); case aet_ch: STORE_TYPED(&u,char, char_code(x)); case aet_bit: STORE_TYPED(&u,fixnum, -Mfix(x)); case aet_fix: STORE_TYPED(&u,fixnum, Mfix(x)); case aet_sf: STORE_TYPED(&u,shortfloat, Msf(x)); case aet_lf: STORE_TYPED(&u,longfloat, Mlf(x)); case aet_char: STORE_TYPED(&u, char, Mfix(x)); case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x)); case aet_short: STORE_TYPED(&u, short, Mfix(x)); case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x)); default: FEerror("bad elttype",0); } return (char *)&u; } /* GSET copies into array ptr P1, the value pointed to by the ptr VAL into the next N slots. The array type is typ. If VAL is the null ptr, use the default for that element type NOTE: for type aet_bit n is the number of Words ie (nbits +WSIZE-1)/WSIZE and the words are set. */ gset(p1,val,n,typ) char *p1,*val; int n; int typ; { if (val==0) val = aet_types[typ].dflt; switch (typ){ #define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} #define GSET1(p,n,typ,val) while (n-- > 0) \ { *((typ *) p) = val; \ p = p + sizeof(typ); \ } break; case aet_object: GSET(p1,n,object,val); case aet_ch: GSET(p1,n,char,val); /* Note n is number of fixnum WORDS for bit */ case aet_bit: GSET(p1,n,fixnum,val); case aet_fix: GSET(p1,n,fixnum,val); case aet_sf: GSET(p1,n,shortfloat,val); case aet_lf: GSET(p1,n,longfloat,val); case aet_char: GSET(p1,n,char,val); case aet_uchar: GSET(p1,n,unsigned char,val); case aet_short: GSET(p1,n,short,val); case aet_ushort: GSET(p1,n,unsigned short,val); default: FEerror("bad elttype",0); } } #define W_SIZE (BV_BITS*sizeof(fixnum)) /* */ DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, 5,NONE,OO,OI,II,OO, "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ elements if N1 is supplied otherwise, doing the length of X - I1 \ elements. If the types of the arrays are not the same, this has \ implementation dependent results.") (x,y,i1,i2,n1) object x,y; int i1,i2,n1; { enum aelttype typ1=Iarray_element_type(x); enum aelttype typ2=Iarray_element_type(y); int nc; if (VFUN_NARGS==4) { n1 = x->v.v_dim - i1;} if (typ1==aet_bit) {if (i1 % CHAR_SIZE) badcopy: FEerror("Bit copies only if aligned"); else {int rest=n1%CHAR_SIZE; if (rest!=0 ) {if (typ2!=aet_bit) goto badcopy; {while(rest> 0) { fSaset1(y,i2+n1-rest,(fSaref1(x,i1+n1-rest))); rest--;} }} i1=i1/CHAR_SIZE ; n1=n1/CHAR_SIZE; typ1=aet_char; }}; if (typ2==aet_bit) {if (i2 % CHAR_SIZE) goto badcopy; i2=i2/CHAR_SIZE ;} if ((typ1 ==aet_object || typ2 ==aet_object) && typ1 != typ2) FEerror("Can't copy between different array types"); nc=n1 * aet_sizes[(int)typ1]; if (i1+n1 > x->a.a_dim || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) FEerror("Copy out of bounds"); bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), y->ust.ust_self + (i2*aet_sizes[(int)typ2]), nc); return x; } /* X is the header of an array. This supplies the body which will not be relocatable if STATICP. If DFLT is 0, do not initialize (the caller promises to reset these before the next gc!). If DFLT == Cnil then initialize to default type for this array type. Otherwise DFLT is an object and its value is used to init the array */ array_allocself(x, staticp, dflt) object x,dflt; int staticp; { int i, d,n; char *(*fun)(),*tmp_alloc; enum aelttype typ; fun = (staticp ? alloc_contblock : alloc_relblock); { /* this must be called from within no interrupt code */ n = x->a.a_dim; typ = Iarray_element_type(x); switch (typ) { case aet_object: x->a.a_self = AR_ALLOC(*fun,n,object); break; case aet_ch: case aet_char: case aet_uchar: x->st.st_self = AR_ALLOC(*fun,n,char); break; case aet_short: case aet_ushort: x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); break; case aet_bit: n = (n+W_SIZE-1)/W_SIZE; x->bv.bv_offset = 0; case aet_fix: x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); break; case aet_sf: x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); break; case aet_lf: x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); break; } if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); } } DEFUNO("FILL-POINTER-SET",int,fSfill_pointer_set,SI,2,2, NONE,IO,IO,OO,OO,siLfill_pointer_set,"") (x,i) object x; int i; { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} if (i < 0 || i > x->a.a_dim) { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} x->v.v_fillp = i; return i; no_fillp: FEerror("~a does not have a fill pointer",1,x); return 0; } DEFUNO("FILL-POINTER",int,fLfill_pointer,LISP,1,1,NONE,IO, OO,OO,OO,Lfill_pointer,"") (x) object x; { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} return x->v.v_fillp ; no_fillp: FEerror("~a does not have a fill pointer",1,x); return 0; } DEFUN("ARRAY-HAS-FILL-POINTER-P",object, fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,"") (x) object x; { if (TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string))) return (x->v.v_hasfillp == 0 ? Cnil : sLt); else if (TYPE_OF(x) == t_array) { return Cnil;} else IisArray(x); return Cnil; } /* DEFUN("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; */ DEFUNO("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,"") (x) object x; { enum aelttype t; t = Iarray_element_type(x); return * aet_types[(int)t].namep; } DEFUNO("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,"") (x) object x; { return sLt; } DEFUNO("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, 1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,"") (x) object x; { IisArray(x); return (x->a.a_displaced == Cnil ? Cnil : sLt); } DEFUNO("ARRAY-RANK",int,fLarray_rank,LISP,1,1,NONE,IO,OO,OO, OO,Larray_rank,"") (x) object x; { if (type_of(x) == t_array) return x->a.a_rank; IisArray(x); return 1; } DEFUNO("ARRAY-DIMENSION",int,fLarray_dimension,LISP,2,2, NONE,IO,IO,OO,OO,Larray_dimension,"") (x,i) object x; int i; { if (type_of(x) == t_array) { if (i >= x->a.a_rank) FEerror("Index to large for array-dimension"); else { return x->a.a_dims[i];}} IisArray(x); return x->v.v_dim; } Icheck_displaced(displaced_list,ar,dim) object displaced_list,ar; int dim; { while (displaced_list!=Cnil) { object u = Mcar(displaced_list); if (u->a.a_self == NULL) continue; if ((Iarray_element_type(u) == aet_bit && (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + u->bv.bv_offset - ar->bv.bv_offset > 0) || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) FEerror("Bad displacement",0); Icheck_displaced(DISPLACED_FROM(u),ar,dim); displaced_list = Mcdr(displaced_list); } } /* (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) { A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) Destroy the displacement from AR */ Iundisplace(ar) object ar; { object *p,x; if ((x = DISPLACED_TO(ar)) == Cnil || ar->a.a_displaced->d.m == FREE) return; {BEGIN_NO_INTERRUPT; DISPLACED_TO(ar) = Cnil; p = &(DISPLACED_FROM(x)) ; /* walk through the displaced from list and delete AR */ while(1) { if ((*p)->d.m == FREE || *p == Cnil) goto retur; if((Mcar(*p) == ar)) { *p = Mcdr(*p); goto retur;} p = &(Mcdr(*p)); } retur: END_NO_INTERRUPT; return; } } DEFUNO("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, OO,OO,OO,OO,siLreplace_array,"") (old,new) object old,new; { struct dummy fw ; fw = old->d; old = IisArray(old); if (TYPE_OF(old) != TYPE_OF(new) || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) { FAIL: FEerror("Cannot do array replacement ~a by ~a",2,old,new); } { int offset = new->ust.ust_self - old->ust.ust_self; object old_list = DISPLACED_FROM(old); object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); adjust_displaced(old,offset); /* Iundisplace(old); */ if (old->v.v_hasfillp) { new->v.v_hasfillp = 1; new->v.v_fillp = old->v.v_fillp;} if (TYPE_OF(old) == t_string) old->st = new->st; else old->a = new ->a; /* prevent having two arrays with the same body--which are not related that would cause the gc to try to copy both arrays and there might not be enough space. */ new->a.a_dim = 0; new->a.a_self = 0; old->d = fw; old->a.a_displaced = displaced; } return old; } DEFUNO("ARRAY-TOTAL-SIZE",int,fLarray_total_size,LISP,1,1, NONE,IO,OO,OO,OO,Larray_total_size,"") (x) object x; { x = IisArray(x); return x->a.a_dim; } DEFUNO("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, NONE,OO,OO,OO,OO,siLaset_by_cursor,"")(array,val,cursor) object array,val,cursor; { object endp_temp; object x; int i; object ind[ARRAY_RANK_LIMIT]; /* 3 args */ ind[0]=array; if (cursor==sLnil) {fSaset1(array,0,val); RETURN1(array);} ind[1]=MMcar(cursor); i = 2; for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) { ind[i++] = MMcar(x);} ind[i]=val; VFUN_NARGS=i+1; c_apply_n(fSaset,i+1,ind); RETURN1(array); } init_array_function(){;} gcl-2.6.14/o/unixfsys.c0000755000175000017500000003027514360276512013277 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include #define IN_UNIXFSYS #include "include.h" #include #include #ifndef NO_PWD_H #include #endif #ifdef __MINGW32__ # include /* Windows has no symlink, therefore no lstat. Without symlinks lstat is equivalent to stat anyway. */ # define S_ISLNK(a) 0 # define lstat stat #endif static object get_string(object x) { switch(type_of(x)) { case t_symbol: case t_string: return x; case t_pathname: return x->pn.pn_namestring; case t_stream: switch(x->sm.sm_mode) { case smm_input: case smm_output: case smm_probe: case smm_io: return get_string(x->sm.sm_object1); case smm_synonym: return get_string(x->sm.sm_object0->s.s_dbind); } } return Cnil; } void coerce_to_filename1(object spec, char *p,unsigned sz) { object namestring=get_string(spec); massert(type_of(namestring)==t_string); massert(namestring->st.st_fillpst.st_self,namestring->st.st_fillp); p[namestring->st.st_fillp]=0; } #ifndef __MINGW32__ static char GETPW_BUF[16384]; #endif DEFUN_NEW("UID-TO-NAME",object,fSuid_to_name,SI,1,1,NONE,OI,OO,OO,OO,(fixnum uid),"") { #ifndef __MINGW32__ struct passwd *pwent,pw; long r; massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0); massert(r<=sizeof(GETPW_BUF));/*FIXME maybe once at image startup*/ massert(!getpwuid_r(uid,&pw,GETPW_BUF,r,&pwent)); RETURN1(make_simple_string(pwent->pw_name)); #else RETURN1(Cnil); #endif } int home_namestring1(const char *n,int s,char *o,int so) { #ifndef __MINGW32__ struct passwd *pwent,pw; long r; massert(s>0); massert(*n=='~'); massert((r=sysconf(_SC_GETPW_R_SIZE_MAX))>=0); massert(r<=sizeof(GETPW_BUF));/*FIXME maybe once at image startup*/ if (s==1) if ((pw.pw_dir=getenv("HOME"))) pwent=&pw; else massert(!getpwuid_r(getuid(),&pw,GETPW_BUF,r,&pwent) && pwent); else { massert(spw_dir))+2pw_dir,r); o[r]='/'; o[r+1]=0; return 0; #else massert(snprintf(o,so-1,"%s%s",getenv("SystemDrive"),getenv("HOMEPATH"))>=0); return 0; #endif } DEFUN_NEW("HOME-NAMESTRING",object,fShome_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object nm),"") { check_type_string(&nm); massert(!home_namestring1(nm->st.st_self,nm->st.st_fillp,FN1,sizeof(FN1))); RETURN1(make_simple_string(FN1)); } #ifdef STATIC_FUNCTION_POINTERS object fShome_namestring(object x) { return FFN(fShome_namestring)(x); } #endif #define FILE_EXISTS_P(a_,b_) !stat(a_,&b_) && S_ISREG(b_.st_mode) #define DIR_EXISTS_P(a_,b_) !stat(a_,&b_) && S_ISDIR(b_.st_mode) FILE * fopen_not_dir(char *filename,char *option) { struct stat ss; return DIR_EXISTS_P(filename,ss) ? NULL : fopen(filename,option); } int file_len(FILE *fp) {/*FIXME dir*/ struct stat filestatus; return fstat(fileno(fp), &filestatus) ? 0 : filestatus.st_size; } bool file_exists(object x) { struct stat ss; coerce_to_filename(x,FN1); return FILE_EXISTS_P(FN1,ss) ? TRUE : FALSE; } DEF_ORDINARY("DIRECTORY",sKdirectory,KEYWORD,""); DEF_ORDINARY("LINK",sKlink,KEYWORD,""); DEF_ORDINARY("FILE",sKfile,KEYWORD,""); static int stat_internal(object x,struct stat *ssp) { if (type_of(x)==t_string) { coerce_to_filename(x,FN1); #ifdef __MINGW32__ {char *p=FN1+strlen(FN1)-1;for (;p>FN1 && *p=='/';p--) *p=0;} #endif if (lstat(FN1,ssp)) return 0; } else if ((x=file_stream(x))!=Cnil&&x->sm.sm_fp) { if (fstat(fileno((FILE *)x->sm.sm_fp),ssp)) return 0; } else return 0; return 1; } static object stat_mode_key(struct stat *ssp) { return S_ISDIR(ssp->st_mode) ? sKdirectory : (S_ISLNK(ssp->st_mode) ? sKlink : sKfile); } DEFUN_NEW("STAT1",object,fSstat1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { struct stat ss; RETURN1(stat_internal(x,&ss) ? stat_mode_key(&ss) : Cnil); } DEFUNM_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { struct stat ss; if (stat_internal(x,&ss)) RETURN4(stat_mode_key(&ss), make_fixnum(ss.st_size), make_fixnum(ss.st_mtime), make_fixnum(ss.st_uid)); else RETURN1(Cnil); } DEFUN_NEW("FTELL",object,fSftell,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((x=file_stream(x))!=Cnil&&x->sm.sm_fp ? (object)ftell(x->sm.sm_fp) : (object)0); } DEFUN_NEW("FSEEK",object,fSfseek,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum pos),"") { RETURN1((x=file_stream(x))!=Cnil&&x->sm.sm_fp&&!fseek(x->sm.sm_fp,pos,SEEK_SET) ? Ct : Cnil); } #include #include #include #include DEFUN_NEW("READLINKAT",object,fSreadlinkat,SI,2,2,NONE,OI,OO,OO,OO,(fixnum d,object s),"") { ssize_t l,z1; check_type_string(&s); /* l=s->st.st_hasfillp ? s->st.st_fillp : s->st.st_dim; */ z1=length(s); massert(z1st.st_self,z1); FN1[z1]=0; #ifndef __MINGW32__ massert((l=readlinkat(d ? dirfd((DIR *)d) : AT_FDCWD,FN1,FN2,sizeof(FN2)))>=0 && l #include DEFUN_NEW("OPENDIR",object,fSopendir,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_string(&x); coerce_to_filename(x,FN1); return (object)opendir(strlen(FN1) ? FN1 : "./"); } DEFUN_NEW("D-TYPE-LIST",object,fSd_type_list,SI,0,0,NONE,OI,OO,OO,OO,(void),"") { RETURN1( #ifdef HAVE_D_TYPE list(8, MMcons(make_fixnum(DT_BLK),make_keyword("BLOCK")), MMcons(make_fixnum(DT_CHR),make_keyword("CHAR")), MMcons(make_fixnum(DT_DIR),make_keyword("DIRECTORY")), MMcons(make_fixnum(DT_FIFO),make_keyword("FIFO")), MMcons(make_fixnum(DT_LNK),make_keyword("LINK")), MMcons(make_fixnum(DT_REG),make_keyword("FILE")), MMcons(make_fixnum(DT_SOCK),make_keyword("SOCKET")), MMcons(make_fixnum(DT_UNKNOWN),make_keyword("UNKNOWN")) ) #else #undef DT_UNKNOWN #define DT_UNKNOWN 0 #undef DT_REG #define DT_REG 1 #undef DT_DIR #define DT_DIR 2 list(3, MMcons(make_fixnum(DT_REG),make_keyword("FILE")), MMcons(make_fixnum(DT_DIR),make_keyword("DIRECTORY")), MMcons(make_fixnum(DT_UNKNOWN),make_keyword("UNKNOWN")) ) #endif ); } DEFUN_NEW("READDIR",object,fSreaddir,SI,3,3,NONE,OI,IO,OO,OO,(fixnum x,fixnum y,object s),"") { struct dirent *e; object z; long tl; size_t l; long d_type=DT_UNKNOWN; #ifdef HAVE_D_TYPE #define get_d_type(e,s) e->d_type #else #define get_d_type(e,s) \ ({struct stat ss;\ massert(snprintf(FN1,sizeof(FN1),"%-*.*s%s",s->st.st_fillp,s->st.st_fillp,s->st.st_self,e->d_name)>=0);\ lstat(FN1,&ss);S_ISDIR(ss.st_mode) ? DT_DIR : DT_REG;}) #endif if (!x) RETURN1(Cnil); tl=telldir((DIR *)x); for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && y!=(d_type=get_d_type(e,s));); if (!e) RETURN1(Cnil); if (s==Cnil) z=make_simple_string(e->d_name); else { check_type_string(&s); l=strlen(e->d_name); if (s->st.st_dim-s->st.st_fillp>=l) { memcpy(s->st.st_self+s->st.st_fillp,e->d_name,l); s->st.st_fillp+=l; z=s; } else { seekdir((DIR *)x,tl); RETURN1(make_fixnum(l)); } } if (y==DT_UNKNOWN) z=MMcons(z,make_fixnum(d_type)); RETURN1(z); } DEFUN_NEW("CLOSEDIR",object,fSclosedir,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { closedir((DIR *)x); return Cnil; } DEFUN_NEW("RENAME",object,fSrename,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type_string(&x); check_type_string(&y); coerce_to_filename(x,FN1); coerce_to_filename(y,FN2); RETURN1(rename(FN1,FN2) ? Cnil : Ct); } DEFUN_NEW("UNLINK",object,fSunlink,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_string(&x); coerce_to_filename(x,FN1); RETURN1(unlink(FN1) ? Cnil : Ct); } DEFUN_NEW("CHDIR1",object,fSchdir1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_string(&x); coerce_to_filename(x,FN1); RETURN1(chdir(FN1) ? Cnil : Ct); } DEFUN_NEW("MKDIR",object,fSmkdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_string(&x); coerce_to_filename(x,FN1); RETURN1(mkdir(FN1 #ifndef __MINGW32__ ,01777 #endif ) ? Cnil : Ct); } DEFUN_NEW("RMDIR",object,fSrmdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_string(&x); coerce_to_filename(x,FN1); RETURN1(rmdir(FN1) ? Cnil : Ct); } DEFVAR("*LOAD-WITH-FREAD*",sSAload_with_freadA,SI,Cnil,""); #ifdef _WIN32 void * get_mmap(FILE *fp,void **ve) { int n; void *st; size_t sz; HANDLE handle; massert((sz=file_len(fp))>0); if (sSAload_with_freadA->s.s_dbind==Cnil) { n=fileno(fp); massert((n=fileno(fp))>2); massert(handle = CreateFileMapping((HANDLE)_get_osfhandle(n), NULL, PAGE_WRITECOPY, 0, 0, NULL)); massert(st=MapViewOfFile(handle,FILE_MAP_COPY,0,0,sz)); CloseHandle(handle); } else { massert(st=malloc(sz)); massert(fread(st,sz,1,fp)==1); } *ve=st+sz; return st; } int un_mmap(void *v1,void *ve) { if (sSAload_with_freadA->s.s_dbind==Cnil) return UnmapViewOfFile(v1) ? 0 : -1; else { free(v1); return 0; } } #else #include static void * get_mmap_flags(FILE *fp,void **ve,int flags) { int n; void *v1; struct stat ss; massert((n=fileno(fp))>2); massert(!fstat(n,&ss)); if (sSAload_with_freadA->s.s_dbind==Cnil) { massert((v1=mmap(0,ss.st_size,PROT_READ|PROT_WRITE,flags,n,0))!=(void *)-1); } else { massert(v1=malloc(ss.st_size)); massert(fread(v1,ss.st_size,1,fp)==1); } *ve=v1+ss.st_size; return v1; } void * get_mmap(FILE *fp,void **ve) { return get_mmap_flags(fp,ve,MAP_PRIVATE); } void * get_mmap_shared(FILE *fp,void **ve) { return get_mmap_flags(fp,ve,MAP_SHARED); } int un_mmap(void *v1,void *ve) { if (sSAload_with_freadA->s.s_dbind==Cnil) return munmap(v1,ve-v1); else { free(v1); return 0; } } #endif /* export these for AXIOM */ int gcl_putenv(char *s) {return putenv(s);} char *gcl_strncpy(char *d,const char *s,size_t z) {return strncpy(d,s,z);} int gcl_strncpy_chk(char *a1,char *b1,size_t z) {char a[10],b[10];strncpy(a,a1,z);strncpy(b,b1,z);return strncmp(a,b,z);}/*compile in __strncpy_chk with FORTIFY_SOURCE*/ #ifdef __MINGW32__ #define uid_t int #endif uid_t gcl_geteuid(void) { #ifndef __MINGW32__ return geteuid(); #else return 0; #endif } uid_t gcl_getegid(void) { #ifndef __MINGW32__ return getegid(); #else return 0; #endif } int gcl_dup2(int o,int n) {return dup2(o,n);} char *gcl_gets(char *s,int z) {return fgets(s,z,stdin);} int gcl_puts(const char *s) {int i=fputs(s,stdout);fflush(stdout);return i;} int gcl_feof(void *v) {return feof(((FILE *)v));} int gcl_getc(void *v) {return getc(((FILE *)v));} int gcl_putc(int i,void *v) {return putc(i,((FILE *)v));} void gcl_init_unixfsys(void) { } gcl-2.6.14/o/sgbc.c0000755000175000017500000006211414360276512012322 0ustar cammcamm/* Copyright William Schelter. All rights reserved. Stratified Garbage Collection (SGC) Write protects pages to tell which ones have been written to recently, for more efficient garbage collection. */ #ifdef BSD /* ulong may have been defined in mp.h but the define is no longer needed */ #undef ulong #include #define PROT_READ_WRITE_EXEC (PROT_READ | PROT_WRITE |PROT_EXEC) #define PROT_READ_EXEC (PROT_READ|PROT_EXEC) #endif #ifdef AIX3 #include #define PROT_READ_EXEC RDONLY /*FIXME*/ #define PROT_READ_WRITE_EXEC UDATAKEY int mprotect(); #endif #ifdef __MINGW32__ #include #define PROT_READ_WRITE_EXEC PAGE_EXECUTE_READWRITE #define PROT_READ_EXEC PAGE_READONLY /*FIXME*/ int gclmprotect ( void *addr, size_t len, int prot ) { int old, rv; rv = VirtualProtect ( (LPVOID) addr, len, prot, &old ); if ( 0 == rv ) { fprintf ( stderr, "mprotect: VirtualProtect %x %d %d failed\n", addr, len, prot ); rv = -1; } else { rv =0; } return (rv); } /* Avoid clash with libgcc's mprotect */ #define mprotect gclmprotect #endif #if defined(DARWIN) #include #endif #include #ifdef SDEBUG object sdebug; joe1(){;} joe() {;} #endif /* structures and arrays of type t, need to be marked if their bodies are not write protected even if the headers are. So we should keep these on pages particular to them. Actually we will change structure sets to touch the structure header, that way we won't have to keep the headers in memory. This takes only 1.47 as opposed to 1.33 microseconds per set. */ static void sgc_mark_phase(void) { STATIC fixnum i, j; STATIC struct package *pp; STATIC bds_ptr bdp; STATIC frame_ptr frp; STATIC ihs_ptr ihsp; STATIC struct pageinfo *v; mark_object(Cnil->s.s_plist); mark_object(Ct->s.s_plist); /* mark all non recent data on writable pages */ { long t,i=page(heap_end); struct typemanager *tm; char *p; for (v=cell_list_head;v;v=v->next) { i=page(v); if (v->sgc_flags&SGC_PAGE_FLAG || !WRITABLE_PAGE_P(i)) continue; t=v->type; tm=tm_of(t); p=pagetochar(i); for (j = tm->tm_nppage; --j >= 0; p += tm->tm_size) { object x = (object) p; #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(v->type) && x->d.s) continue; #endif mark_object1(x); } } } /* mark all non recent data on writable contiguous pages */ if (what_to_collect == t_contiguous) for (i=0;iv.v_fillp && (v=(void *)contblock_array->v.v_self[i]);i++) if (v->sgc_flags&SGC_PAGE_FLAG) { void *s=CB_DATA_START(v),*e=CB_DATA_END(v),*p,*q; bool z=get_sgc_bit(v,s); for (p=s;pbds_sym); mark_object(bdp->bds_val); } for (frp = frs_org; frp <= frs_top; frp++) mark_object(frp->frs_val); for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) mark_object(ihsp->ihs_function); for (i = 0; i < mark_origin_max; i++) mark_object(*mark_origin[i]); for (i = 0; i < mark_origin_block_max; i++) for (j = 0; j < mark_origin_block[i].mob_size; j++) mark_object(mark_origin_block[i].mob_addr[j]); for (pp = pack_pointer; pp != NULL; pp = pp->p_link) mark_object((object)pp); #ifdef KCLOVM if (ovm_process_created) sgc_mark_all_stacks(); #endif #ifdef DEBUG if (debug) { printf("symbol navigation\n"); fflush(stdout); } #endif mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); } static void sgc_sweep_phase(void) { STATIC long j, k, l; STATIC object x; STATIC char *p; STATIC struct typemanager *tm; STATIC object f; int size; STATIC struct pageinfo *v; for (j= t_start; j < t_contiguous ; j++) { tm_of(j)->tm_free=OBJNULL; tm_of(j)->tm_nfree=0; } for (v=cell_list_head;v;v=v->next) { tm = tm_of((enum type)v->type); p = pagetochar(page(v)); f = FREELIST_TAIL(tm); l = k = 0; size=tm->tm_size; if (v->sgc_flags&SGC_PAGE_FLAG) { for (j = tm->tm_nppage; --j >= 0; p += size) { x = (object)p; if (is_marked(x)) { unmark(x); l++; continue; } #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(v->type) && x->d.s == SGC_NORMAL) continue; #endif k++; make_free(x); SET_LINK(f,x); f = x; #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(v->type)) x->d.s = SGC_RECENT; #endif } SET_LINK(f,OBJNULL); tm->tm_tail = f; tm->tm_nfree += k; v->in_use=l; } else if (WRITABLE_PAGE_P(page(v))) /*non sgc_page */ for (j = tm->tm_nppage; --j >= 0; p += size) { x = (object)p; if (is_marked(x)) { unmark(x); } } } } #undef tm #ifdef SDEBUG sgc_count(object yy) { fixnum count=0; object y=yy; while(y) {count++; y=OBJ_LINK(y);} printf("[length %x = %d]",yy,count); fflush(stdout); } #endif fixnum writable_pages=0; /* count read-only pages */ static fixnum sgc_count_read_only(void) { return sgc_enabled ? sSAwritableA->s.s_dbind->v.v_dim-writable_pages : 0; } fixnum sgc_count_type(int t) { if (t==t_relocatable) return page(rb_limit)-page(rb_start); else return tm_of(t)->tm_npage-tm_of(t)->tm_alt_npage; } #ifdef SGC_CONT_DEBUG void pcb(struct contblock *p) { for (;p;p=p->cb_link) printf("%p %d\n",p,p->cb_size); } void overlap_check(struct contblock *t1,struct contblock *t2) { struct contblock *p; for (;t1;t1=t1->cb_link) { if (!inheap(t1)) { fprintf(stderr,"%p not in heap\n",t1); do_gcl_abort(); } for (p=t2;p;p=p->cb_link) { if (!inheap(p)) { fprintf(stderr,"%p not in heap\n",t1); do_gcl_abort(); } if ((p<=t1 && (void *)p+p->cb_size>(void *)t1) || (t1<=p && (void *)t1+t1->cb_size>(void *)p)) { fprintf(stderr,"Overlap %u %p %u %p\n",t1->cb_size,t1,p->cb_size,p); do_gcl_abort(); } if (p==p->cb_link) { fprintf(stderr,"circle detected at %p\n",p); do_gcl_abort(); } } if (t1==t1->cb_link) { fprintf(stderr,"circle detected at %p\n",t1); do_gcl_abort(); } } } void tcc(struct contblock *t) { for (;t;t=t->cb_link) { if (!inheap(t)) { fprintf(stderr,"%p not in heap\n",t); break; } fprintf(stderr,"%u at %p\n",t->cb_size,t); if (t==t->cb_link) { fprintf(stderr,"circle detected at %p\n",t); break; } } } #endif typedef enum {memprotect_none,memprotect_cannot_protect,memprotect_sigaction, memprotect_bad_return,memprotect_no_signal, memprotect_multiple_invocations,memprotect_no_restart, memprotect_bad_fault_address,memprotect_success} memprotect_enum; static volatile memprotect_enum memprotect_result; static int memprotect_handler_invocations,memprotect_print_enable; static void *memprotect_test_address; #define MEM_ERR_CASE(a_) \ case a_: \ fprintf(stderr,"The SGC segfault recovery test failed with %s, SGC disabled\n",#a_); \ break static void memprotect_print(void) { if (!memprotect_print_enable) return; switch(memprotect_result) { case memprotect_none: case memprotect_success: break; MEM_ERR_CASE(memprotect_cannot_protect); MEM_ERR_CASE(memprotect_sigaction); MEM_ERR_CASE(memprotect_bad_return); MEM_ERR_CASE(memprotect_no_signal); MEM_ERR_CASE(memprotect_no_restart); MEM_ERR_CASE(memprotect_bad_fault_address); MEM_ERR_CASE(memprotect_multiple_invocations); } } static void memprotect_handler_test(int sig, long code, void *scp, char *addr) { char *faddr; faddr=GET_FAULT_ADDR(sig,code,scp,addr); if (memprotect_handler_invocations) { memprotect_result=memprotect_multiple_invocations; do_gcl_abort(); } memprotect_handler_invocations=1; if (page(faddr)!=page(memprotect_test_address)) memprotect_result=memprotect_bad_fault_address; else memprotect_result=memprotect_none; gcl_mprotect(memprotect_test_address,PAGESIZE,PROT_READ_WRITE_EXEC); } static int memprotect_test(void) { char *b1,*b2; unsigned long p=PAGESIZE; struct sigaction sa,sao,saob; if (memprotect_result!=memprotect_none) return memprotect_result!=memprotect_success; if (atexit(memprotect_print)) { fprintf(stderr,"Cannot setup memprotect_print on exit\n"); do_gcl_abort(); } if (!(b1=alloca(2*p))) { memprotect_result=memprotect_cannot_protect; return -1; } if (!(b2=alloca(p))) { memprotect_result=memprotect_cannot_protect; return -1; } memset(b1,32,2*p); memset(b2,0,p); memprotect_test_address=(void *)(((unsigned long)b1+p-1) & ~(p-1)); sa.sa_sigaction=(void *)memprotect_handler_test; sa.sa_flags=MPROTECT_ACTION_FLAGS; if (sigaction(SIGSEGV,&sa,&sao)) { memprotect_result=memprotect_sigaction; return -1; } if (sigaction(SIGBUS,&sa,&saob)) { sigaction(SIGSEGV,&sao,NULL); memprotect_result=memprotect_sigaction; return -1; } { /* mips kernel bug test -- SIGBUS with no faddr when floating point is emulated. */ float *f1=(void *)memprotect_test_address,*f2=(void *)b2,*f1e=f1+p/sizeof(*f1); if (gcl_mprotect(memprotect_test_address,p,PROT_READ_EXEC)) { memprotect_result=memprotect_cannot_protect; return -1; } memprotect_result=memprotect_bad_return; for (;f1_b ? _a : _b;}) /* If opt_maxpage is set, don't lose balancing information gained thus far if we are triggered 'artificially' via a hole overrun. FIXME -- try to allocate a small working set with the right proportions later on. 20040804 CM*/ #define WSGC(tm) ({struct typemanager *_tm=tm;long _t=MMAX(MMIN(_tm->tm_opt_maxpage,_tm->tm_npage),_tm->tm_sgc);_t*scale;}) /* If opt_maxpage is set, add full pages to the sgc set if needed too. 20040804 CM*/ /* #define FSGC(tm) (tm->tm_type==t_cons ? tm->tm_nppage : (tm->tm_opt_maxpage ? 0 : tm->tm_sgc_minfree)) */ #ifdef SGC_WHOLE_PAGE #define FSGC(tm) tm->tm_nppage #else #define FSGC(tm) (!TYPEWORD_TYPE_P(tm->tm_type) ? tm->tm_nppage : tm->tm_sgc_minfree) #endif DEFVAR("*WRITABLE*",sSAwritableA,SI,Cnil,""); unsigned char *wrimap=NULL; int sgc_start(void) { long i,count,minfree,allocate_more_pages=!saving_system && 10*available_pages>2*(real_maxpage-first_data_page); long np; struct typemanager *tm; struct pageinfo *v; object omp=sSAoptimize_maximum_pagesA->s.s_dbind; double tmp,scale; allocate_more_pages=0; if (sgc_enabled) return 1; sSAoptimize_maximum_pagesA->s.s_dbind=Cnil; if (memprotect_result!=memprotect_success && do_memprotect_test()) return 0; empty_relblock(); /* Reset maxpage statistics if not invoked automatically on a hole overrun. 20040804 CM*/ /* if (!hole_overrun) { */ /* vs_mark; */ /* object *old_vs_base=vs_base; */ /* vs_base=vs_top; */ /* FFN(siLreset_gbc_count)(); */ /* vs_base=old_vs_base; */ /* vs_reset; */ /* } */ for (i=t_start,scale=1.0,tmp=0.0;iavailable_pages/10 ? (float)available_pages/(10*tmp) : 1.0; for (i= t_start; i < t_contiguous ; i++) { if (!TM_BASE_TYPE_P(i) || !(np=(tm=tm_of(i))->tm_sgc)) continue; minfree = FSGC(tm) > 0 ? FSGC(tm) : 1; count=0; FIND_FREE_PAGES: for (v=cell_list_head;v && (counttm_sgc_max,WSGC(tm)));v=v->next) { if (v->type!=i || tm->tm_nppage-v->in_usesgc_flags|=SGC_PAGE_FLAG; count++; } if (counttm_sgc_max,WSGC(tm)));v=v->next) { if (v->type!=i || tm->tm_nppage!=v->in_use) continue; v->sgc_flags|=SGC_PAGE_FLAG; count++; if (count >= MMAX(tm->tm_sgc_max,WSGC(tm))) break; } /* don't do any more allocations for this type if saving system */ if (!allocate_more_pages) continue; if (count < WSGC(tm)) { /* try to get some more free pages of type i */ long n = WSGC(tm) - count; long again=0,nfree = tm->tm_nfree; char *p=alloc_page(n); if (tm->tm_nfree > nfree) again=1; /* gc freed some objects */ if (tm->tm_npage+n>tm->tm_maxpage) if (!set_tm_maxpage(tm,tm->tm_npage+n)) n=0; while (n-- > 0) { /* (sgc_enabled=1,add_page_to_freelist(p,tm),sgc_enabled=0); */ add_page_to_freelist(p,tm); p += PAGESIZE; } if (again) goto FIND_FREE_PAGES; } } /* SGC cont pages: Here we implement the contblock page division into SGC and non-SGC types. Unlike the other types, we need *whole* free pages for contblock SGC, as there is no persistent data element (e.g. .m) on an allocated block itself which can indicate its live status. If anything on a page which is to be marked read-only points to a live object on an SGC cont page, it will never be marked and will be erroneously swept. It is also possible for dead objects to unnecessarily mark dead regions on SGC pages and delay sweeping until the pointing type is GC'ed if SGC is turned off for the pointing type, e.g. tm_sgc=0. (This was so by default for a number of types, including bignums, and has now been corrected in gcl_init_alloc in alloc.c.) We can't get around this AFAICT, as old data on (writable) SGC pages must be marked lest it is lost, and (old) data on now writable non-SGC pages might point to live regions on SGC pages, yet might not themselves be reachable from the mark origin through an unbroken chain of writable pages. In any case, the possibility of a lot of garbage marks on contblock pages, especially when the blocks are small as in bignums, makes necessary the sweeping of minimal contblocks to prevent leaks. CM 20030827 */ { void *p=NULL,*pe; struct pageinfo *pi; fixnum i,j,count=0; struct contblock **cbpp; tm=tm_of(t_contiguous); for (i=0;iv.v_fillp && (pi=(void *)contblock_array->v.v_self[i]) && countcb_link) if ((void*)*cbpp>=p && (void *)*cbppcb_size; if (j*tm->tm_nppagesgc_flags=SGC_PAGE_FLAG; count+=pi->in_use; } i=allocate_more_pages ? WSGC(tm) : (saving_system ? 1 : 0); if (i>count) { /* SGC cont pages: allocate more if necessary, dumping possible GBC freed pages onto the old contblock list. CM 20030827*/ unsigned long z=(i-count)+1; ufixnum fp=contblock_array->v.v_fillp; if (maxcbpagev.v_fillp); ((struct pageinfo *)contblock_array->v.v_self[fp])->sgc_flags=SGC_PAGE_FLAG; } } sSAwritableA->s.s_dbind=fSmake_vector1_1((page(heap_end)-first_data_page),aet_bit,Ct); wrimap=(void *)sSAwritableA->s.s_dbind->v.v_self; /* now move the sgc free lists into place. alt_free should contain the others */ for (i= t_start; i < t_contiguous ; i++) if (TM_BASE_TYPE_P(i) && (np=(tm=tm_of(i))->tm_sgc)) { object f=tm->tm_free,xf,yf; struct freelist x,y;/*the f_link heads have to be separated on the stack*/ fixnum count=0; xf=PHANTOM_FREELIST(x.f_link); yf=PHANTOM_FREELIST(y.f_link); while (f!=OBJNULL) { #ifdef SDEBUG if (!is_free(f)) printf("Not FREE in freelist f=%d",f); #endif if (pageinfo(f)->sgc_flags&SGC_PAGE_FLAG) { SET_LINK(xf,f); #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_RECENT; #endif xf=f; count++; } else { SET_LINK(yf,f); #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_NORMAL; #endif yf=f; } f=OBJ_LINK(f); } SET_LINK(xf,OBJNULL); tm->tm_free = OBJ_LINK(&x); tm->tm_tail = xf; SET_LINK(yf,OBJNULL); tm->tm_alt_free = OBJ_LINK(&y); tm->tm_alt_nfree = tm->tm_nfree - count; tm->tm_nfree=count; } { struct pageinfo *pi; ufixnum j; { struct contblock **cbpp; void *p=NULL,*pe; struct pageinfo *pi; ufixnum i; old_cb_pointer=cb_pointer; reset_contblock_freelist(); for (i=0;iv.v_fillp && (pi=(void *)contblock_array->v.v_self[i]);i++) { if (pi->sgc_flags!=SGC_PAGE_FLAG) continue; p=CB_DATA_START(pi); pe=p+CB_DATA_SIZE(pi->in_use); for (cbpp=&old_cb_pointer;*cbpp;) if ((void *)*cbpp>=p && (void *)*cbppcb_size,*l=(*cbpp)->cb_link; set_sgc_bits(pi,s,e); insert_contblock(s,e-s); *cbpp=l; } else cbpp=&(*cbpp)->cb_link; } #ifdef SGC_CONT_DEBUG overlap_check(old_cb_pointer,cb_pointer); #endif } for (i=t_start;itm_alt_npage=0; writable_pages=0; for (pi=cell_list_head;pi;pi=pi->next) { if (pi->sgc_flags&SGC_WRITABLE) SET_WRITABLE(page(pi)); else tm_of(pi->type)->tm_alt_npage++; } for (j=0;jv.v_fillp && (pi=(void *)contblock_array->v.v_self[j]);j++) if (pi->sgc_flags&SGC_WRITABLE) for (i=0;iin_use;i++) SET_WRITABLE(page(pi)+i); else tm_of(t_contiguous)->tm_alt_npage+=pi->in_use; { extern object malloc_list; object x; for (x=malloc_list;x!=Cnil;x=x->c.c_cdr) if (x->c.c_car->st.st_adjustable) for (i=page(x->c.c_car->st.st_self);i<=page(x->c.c_car->st.st_self+x->c.c_car->st.st_fillp-1);i++) SET_WRITABLE(i); } { object v=sSAwritableA->s.s_dbind; for (i=page(v->v.v_self);i<=page(v->v.v_self+CEI(v->bv.bv_offset+v->v.v_dim-1,8*sizeof(fixnum))/(8*sizeof(fixnum)));i++) SET_WRITABLE(i); SET_WRITABLE(page(v)); SET_WRITABLE(page(sSAwritableA)); } tm_of(t_relocatable)->tm_alt_npage=0; fault_pages=0; } /* Whew. We have now allocated the sgc space and modified the tm_table; Turn memory protection on for the pages which are writable. */ sgc_enabled=1; if (memory_protect(1)) sgc_quit(); if (sSAnotify_gbcA->s.s_dbind != Cnil) emsg("[SGC on]"); sSAoptimize_maximum_pagesA->s.s_dbind=omp; return 1; } /* int */ /* pdebug(void) { */ /* extern object malloc_list; */ /* object x=malloc_list; */ /* struct pageinfo *v; */ /* for (;x!=Cnil;x=x->c.c_cdr) */ /* printf("%p %d\n",x->c.c_car->st.st_self,x->c.c_car->st.st_dim); */ /* for (v=contblock_list_head;v;v=v->next) */ /* printf("%p %ld\n",v,v->in_use<<12); */ /* return 0; */ /* } */ int sgc_quit(void) { struct typemanager *tm; struct contblock *tmp_cb_pointer,*next; unsigned long i,np; struct pageinfo *v; memory_protect(0); if(sSAnotify_gbcA->s.s_dbind != Cnil) emsg("[SGC off]"); if (sgc_enabled==0) return 0; sSAwritableA->s.s_dbind=Cnil; wrimap=NULL; sgc_enabled=0; /* SGC cont pages: restore contblocks, each tmp_cb_pointer coming from the new list is guaranteed not to be on the old. Need to grab 'next' before insert_contblock writes is. CM 20030827 */ if (old_cb_pointer) { #ifdef SGC_CONT_DEBUG overlap_check(old_cb_pointer,cb_pointer); #endif for (tmp_cb_pointer=old_cb_pointer;tmp_cb_pointer; tmp_cb_pointer=next) { next=tmp_cb_pointer->cb_link; insert_contblock((void *)tmp_cb_pointer,tmp_cb_pointer->cb_size); } } for (i= t_start; i < t_contiguous ; i++) if (TM_BASE_TYPE_P(i) && (np=(tm=tm_of(i))->tm_sgc)) { object n=tm->tm_free,o=tm->tm_alt_free,f=PHANTOM_FREELIST(tm->tm_free); for (;n!=OBJNULL && o!=OBJNULL;) if (o!=OBJNULL && (n==OBJNULL || otm_tail=f; for (;OBJ_LINK(tm->tm_tail)!=OBJNULL;tm->tm_tail=OBJ_LINK(tm->tm_tail)); tm->tm_nfree += tm->tm_alt_nfree; tm->tm_alt_nfree = 0; tm->tm_alt_free = OBJNULL; } /*FIXME*/ /* remove the recent flag from any objects on sgc pages */ #ifndef SGC_WHOLE_PAGE for (v=cell_list_head;v;v=v->next) if (v->type==(tm=tm_of(v->type))->tm_type && TYPEWORD_TYPE_P(v->type) && v->sgc_flags & SGC_PAGE_FLAG) for (p=pagetochar(page(v)),j=tm->tm_nppage;j>0;--j,p+=tm->tm_size) ((object) p)->d.s=SGC_NORMAL; #endif for (i=0;iv.v_fillp &&(v=(void *)contblock_array->v.v_self[i]);i++) if (v->sgc_flags&SGC_PAGE_FLAG) bzero(CB_SGCF_START(v),CB_DATA_START(v)-CB_SGCF_START(v)); { struct pageinfo *pi; for (pi=cell_list_head;pi;pi=pi->next) pi->sgc_flags&=SGC_PERM_WRITABLE; for (i=0;iv.v_fillp &&(pi=(void *)contblock_array->v.v_self[i]);i++) pi->sgc_flags&=SGC_PERM_WRITABLE; } return 0; } fixnum debug_fault =0; fixnum fault_count =0; extern char etext; static void memprotect_handler(int sig, long code, void *scp, char *addr) { unsigned long p; void *faddr; /* Needed because we must not modify signal handler arguments on the stack! */ #ifdef GET_FAULT_ADDR faddr=GET_FAULT_ADDR(sig,code,scp,addr); debug_fault = (long) faddr; #ifdef DEBUG_MPROTECT printf("fault:0x%x [%d] (%d) ",faddr,page(faddr),faddr >= core_end); #endif if (faddr >= (void *)core_end || faddr < data_start) { static void *old_faddr; if (old_faddr==faddr) if (fault_count++ > 300) error("fault count too high"); old_faddr=faddr; INSTALL_MPROTECT_HANDLER; return; } #else faddr = addr; #endif p = page(faddr); if (p >= first_protectable_page && faddr < (void *)core_end && !(WRITABLE_PAGE_P(p))) { /* CHECK_RANGE(p,1); */ #ifdef DEBUG_MPROTECT printf("mprotect(0x%x,0x%x,0x%x)\n", pagetoinfo(p),PAGESIZE, sbrk(0)); fflush(stdout); #endif #ifndef BSD INSTALL_MPROTECT_HANDLER; #endif massert(!gcl_mprotect(pagetoinfo(p),PAGESIZE,PROT_READ_WRITE_EXEC)); SET_WRITABLE(p); fault_pages++; return; } #ifndef BSD INSTALL_MPROTECT_HANDLER; #endif segmentation_catcher(0); } static int sgc_mprotect(long pbeg, long n, int writable) { /* CHECK_RANGE(pbeg,n); */ #ifdef DEBUG_MPROTECT printf("prot[%d,%d,(%d),%s]\n",pbeg,pbeg+n,writable & SGC_WRITABLE, (writable & SGC_WRITABLE ? "writable" : "not writable")); printf("mprotect(0x%x,0x%x), sbrk(0)=0x%x\n", pagetoinfo(pbeg), n * PAGESIZE, sbrk(0)); fflush(stdout); #endif if(gcl_mprotect(pagetoinfo(pbeg),n*PAGESIZE,(writable & SGC_WRITABLE ? PROT_READ_WRITE_EXEC : PROT_READ_EXEC))) { perror("sgc disabled"); return -1; } return 0; } int memory_protect(int on) { unsigned long i,beg,end= page(core_end); int writable=1; extern void install_segmentation_catcher(void); first_protectable_page=first_data_page; /* turning it off */ if (on==0) { sgc_mprotect(first_protectable_page,end-first_protectable_page,SGC_WRITABLE); install_segmentation_catcher(); return 0; } INSTALL_MPROTECT_HANDLER; beg=first_protectable_page; writable = WRITABLE_PAGE_P(beg); for (i=beg ; ++i<= end; ) { if (writable==WRITABLE_PAGE_P(i) && i Note that the GNU project considers support for HP operation a peripheral activity which should not be allowed to divert effort from development of the GNU system. Changes in this code will be installed when users send them in, but aside from that we don't plan to think about it, or about whether other Emacs maintenance might break it. Unexec creates a copy of the old a.out file, and replaces the old data area with the current data area. When the new file is executed, the process will see the same data structures and data values that the original process had when unexec was called. Unlike other versions of unexec, this one copies symbol table and debug information to the new a.out file. Thus, the new a.out file may be debugged with symbolic debuggers. If you fix any bugs in this, I'd like to incorporate your fixes. Send them to uunet!hpda!hpsemc!jmorris or jmorris%hpsemc@hplabs.HP.COM. CAVEATS: This routine saves the current value of all static and external variables. This means that any data structure that needs to be initialized must be explicitly reset. Variables will not have their expected default values. Unfortunately, the HP-UX signal handler has internal initialization flags which are not explicitly reset. Thus, for signals to work in conjunction with this routine, the following code must executed when the new process starts up. void _sigreturn(); ... sigsetreturn(_sigreturn); */ #include #include #include #include #define NBPG 2048 #define roundup(x,n) ( ( (x)+(n-1) ) & ~(n-1) ) /* n is power of 2 */ #define min(x,y) ( ((x)<(y))?(x):(y) ) /* Create a new a.out file, same as old but with current data space */ unexec(new_name, old_name, new_end_of_text, dummy1, dummy2) char new_name[]; /* name of the new a.out file to be created */ char old_name[]; /* name of the old a.out file */ char *new_end_of_text; /* ptr to new edata/etext; NOT USED YET */ int dummy1, dummy2; /* not used by emacs */ { int old, new; int old_size, new_size; struct header hdr; struct som_exec_auxhdr auxhdr; char stdin_buf[BUFSIZ],stdout_buf[BUFSIZ]; FILE *original,*tem; /* For the greatest flexibility, should create a temporary file in the same directory as the new file. When everything is complete, rename the temp file to the new name. This way, a program could update its own a.out file even while it is still executing. If problems occur, everything is still intact. NOT implemented. */ /* Open the input and output a.out files */ _cleanup(); fclose(stdin); old = open(old_name, O_RDONLY); if (old < 0) { perror(old_name); exit(1); } if ( old < 0) {perror("can't open in"); exit(1);} printf("(%d = old) \n",old); tem = fdopen(old,"r"); setbuf(tem,stdin_buf); fflush(stdout); fclose(stdout); new = open(new_name, O_CREAT|O_RDWR|O_TRUNC, 0777); if (new < 0) { perror(new_name); exit(1); } tem = fdopen(new,"w"); setbuf(tem,stdout_buf); /* Read the old headers */ read_header(old, &hdr, &auxhdr); /* Decide how large the new and old data areas are */ old_size = auxhdr.exec_dsize; new_size = (int)sbrk(0) - auxhdr.exec_dmem; /* Copy the old file to the new, up to the data space */ lseek(old, 0, 0); copy_file(old, new, auxhdr.exec_dfile); /* Skip the old data segment and write a new one */ lseek(old, old_size, 1); save_data_space(new, &hdr, &auxhdr, new_size); /* Copy the rest of the file */ copy_rest(old, new); /* Update file pointers since we probably changed size of data area */ update_file_ptrs(new, &hdr, &auxhdr, auxhdr.exec_dfile, new_size-old_size); /* Save the modified header */ write_header(new, &hdr, &auxhdr); /* Close the binary file */ close(old); close(new); exit(0); } /* Save current data space in the file, update header. */ save_data_space(file, hdr, auxhdr, size) int file; struct header *hdr; struct som_exec_auxhdr *auxhdr; int size; { /* Write the entire data space out to the file */ if (write(file, auxhdr->exec_dmem, size) != size) { perror("Can't save new data space"); exit(1); } /* Update the header to reflect the new data size */ auxhdr->exec_dsize = size; auxhdr->exec_bsize = 0; } /* Update the values of file pointers when something is inserted. */ update_file_ptrs(file, hdr, auxhdr, location, offset) int file; struct header *hdr; struct som_exec_auxhdr *auxhdr; unsigned int location; int offset; { struct subspace_dictionary_record subspace; int i; /* Increase the overall size of the module */ hdr->som_length += offset; /* Update the various file pointers in the header */ #define update(ptr) if (ptr > location) ptr = ptr + offset update(hdr->aux_header_location); update(hdr->space_strings_location); update(hdr->init_array_location); update(hdr->compiler_location); update(hdr->symbol_location); update(hdr->fixup_request_location); update(hdr->symbol_strings_location); update(hdr->unloadable_sp_location); update(auxhdr->exec_tfile); update(auxhdr->exec_dfile); /* Do for each subspace dictionary entry */ lseek(file, hdr->subspace_location, 0); for (i = 0; i < hdr->subspace_total; i++) { if (read(file, &subspace, sizeof(subspace)) != sizeof(subspace)) { perror("Can't read subspace record"); exit(1); } /* If subspace has a file location, update it */ if (subspace.initialization_length > 0 && subspace.file_loc_init_value > location) { subspace.file_loc_init_value += offset; lseek(file, -sizeof(subspace), 1); if (write(file, &subspace, sizeof(subspace)) != sizeof(subspace)) { perror("Can't update subspace record"); exit(1); } } } /* Do for each initialization pointer record */ /* (I don't think it applies to executable files, only relocatables) */ #undef update } /* Read in the header records from an a.out file. */ read_header(file, hdr, auxhdr) int file; struct header *hdr; struct som_exec_auxhdr *auxhdr; { /* Read the header in */ lseek(file, 0, 0); if (read(file, hdr, sizeof(*hdr)) != sizeof(*hdr)) { perror("Couldn't read header from a.out file"); exit(1); } if (hdr->a_magic != EXEC_MAGIC && hdr->a_magic != SHARE_MAGIC && hdr->a_magic != DEMAND_MAGIC) { fprintf(stderr, "a.out file doesn't have legal magic number\n"); exit(1); } lseek(file, hdr->aux_header_location, 0); if (read(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr)) { perror("Couldn't read auxiliary header from a.out file"); exit(1); } } /* Write out the header records into an a.out file. */ write_header(file, hdr, auxhdr) int file; struct header *hdr; struct som_exec_auxhdr *auxhdr; { /* Update the checksum */ hdr->checksum = calculate_checksum(hdr); /* Write the header back into the a.out file */ lseek(file, 0, 0); if (write(file, hdr, sizeof(*hdr)) != sizeof(*hdr)) { perror("Couldn't write header to a.out file"); exit(1); } lseek(file, hdr->aux_header_location, 0); if (write(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr)) { perror("Couldn't write auxiliary header to a.out file"); exit(1); } } /* Calculate the checksum of a SOM header record. */ calculate_checksum(hdr) struct header *hdr; { int checksum, i, *ptr; checksum = 0; ptr = (int *) hdr; for (i=0; i 0; size -= len) { len = min(size, sizeof(buffer)); if (read(old, buffer, len) != len) { perror("Read failure on a.out file"); exit(1); } if (write(new, buffer, len) != len) { perror("Write failure in a.out file"); exit(1); } } } /* Copy the rest of the file, up to EOF. */ copy_rest(old, new) int new, old; { int buffer[4096]; int len; /* Copy bytes until end of file or error */ while ( (len = read(old, buffer, sizeof(buffer))) > 0) if (write(new, buffer, len) != len) break; if (len != 0) { perror("Unable to copy the rest of the file"); exit(1); } } #ifdef DEBUG display_header(hdr, auxhdr) struct header *hdr; struct som_exec_auxhdr *auxhdr; { /* Display the header information (debug) */ printf("\n\nFILE HEADER\n"); printf("magic number %d \n", hdr->a_magic); printf("text loc %.8x size %d \n", auxhdr->exec_tmem, auxhdr->exec_tsize); printf("data loc %.8x size %d \n", auxhdr->exec_dmem, auxhdr->exec_dsize); printf("entry %x \n", auxhdr->exec_entry); printf("Bss segment size %u\n", auxhdr->exec_bsize); printf("\n"); printf("data file loc %d size %d\n", auxhdr->exec_dfile, auxhdr->exec_dsize); printf("som_length %d\n", hdr->som_length); printf("unloadable sploc %d size %d\n", hdr->unloadable_sp_location, hdr->unloadable_sp_size); } #endif /* DEBUG */ #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/gbc.c0000755000175000017500000010274114360276512012140 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* GBC.c IMPLEMENTATION-DEPENDENT */ #define DEBUG #define IN_GBC #define NEED_MP_H #include #include #include "include.h" #include "page.h" #ifdef SGC static void sgc_sweep_phase(void); static void sgc_mark_phase(void); static fixnum sgc_count_read_only(void); #endif static void mark_c_stack(jmp_buf, int, void (*)(void *,void *,int)); static void mark_contblock(void *, int); /* the following in line definitions seem to be twice as fast (at least on mc68020) as going to the assembly function calls in bitop.c so since this is more portable and faster lets use them --W. Schelter These assume that DBEGIN is divisible by 32, or else we should have #define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5))) */ #define LOG_BITS_CHAR 3 #if CPTR_SIZE == 8 #define LOG_BYTES_CONTBLOCK 3 #elif CPTR_SIZE == 16 #define LOG_BYTES_CONTBLOCK 4 #else #error Do not recognize CPTR_SIZE #endif void * cb_in(void *p) { struct contblock **cbpp; int i; for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++) { if ((void *)*cbpp<=p && ((void *)(*cbpp)+(*cbpp)->cb_size) >p) return *cbpp; } return NULL; } int cb_print(void) { struct contblock **cbpp; int i; for (cbpp=&cb_pointer,i=0;*cbpp;cbpp=&((*cbpp)->cb_link),i++) emsg("%lu at %p\n",(*cbpp)->cb_size,*cbpp); emsg("%u blocks\n",i); return 0; } #ifdef CONTBLOCK_MARK_DEBUG int cb_check(void) { struct contblock **cbpp; struct pageinfo *v; void *cbe; for (cbpp=&cb_pointer;*cbpp;cbpp=&((*cbpp)->cb_link)) { v=get_pageinfo(*cbpp); cbe=((void *)(*cbpp)+(*cbpp)->cb_size-1); if (cbe>(void *)v+v->in_use*PAGESIZE) return 1; } return 0; } int m_check(void) { struct contblock **cbpp; void *v,*ve,*p,*pe; extern object malloc_list; object l; for (l=malloc_list;l!=Cnil;l=l->c.c_cdr) { p=l->c.c_car->st.st_self; pe=p+l->c.c_car->st.st_dim; for (cbpp=&cb_pointer;*cbpp;cbpp=&((*cbpp)->cb_link)) { v=(void *)(*cbpp); ve=(v+(*cbpp)->cb_size-1); printf("%p %p %p %p\n",p,pe,v,ve); if ((v<=p && p < ve)||(v=0); massert(v+i<(void *)pi+pi->in_use*PAGESIZE); massert(i<(ve-v)); return 0; } #endif static inline bool pageinfo_p(void *v) { struct pageinfo *pi=v; return pi->magic==PAGE_MAGIC && pi->type<=t_contiguous && (!pi->next || (void *)pi->next>=v+(pi->type==t_contiguous ? pi->in_use : 1)*PAGESIZE); } static inline char get_bit(char *v,struct pageinfo *pi,void *x) { void *ve=CB_DATA_START(pi); fixnum off=(x-ve)>>LOG_BYTES_CONTBLOCK,i=off>>LOG_BITS_CHAR,s=off&~(~0UL<>s)&0x1; } #define bit_get(v,i,s) ((v[i]>>s)&0x1) #define bit_set(v,i,s) (v[i]|=(1UL<>LOG_BYTES_CONTBLOCK;i=_o>>LOG_BITS_CHAR;s=_o&~(~0UL<++i1) memset(v+i1,-1,(i2-i1)); for (;--s2>=0;) bit_set(v,i2,s2); } static inline void * get_bits(char *v,struct pageinfo *pi,void *x) { void *ds=CB_DATA_START(pi),*de=CB_DATA_END(pi); fixnum i,s,ie=mbytes(pi->in_use); bool z; char cz; ptr_set(x,ds,i,s); z=bit_get(v,i,s); cz=z?-1:0; for (;++s= MARK_ORIGIN_MAX) error("too many mark origins"); mark_origin[mark_origin_max++] = p; } /* Whenever two arrays are linked together by displacement, if one is live, the other will be made live */ #define mark_displaced_field(ar) mark_object(ar->a.a_displaced) #define LINK_ARRAY_MARKED(x_) ((*(unsigned long *)(x_))&0x1) #define MARK_LINK_ARRAY(x_) ((*(unsigned long *)(x_))|=1UL) #define CLEAR_LINK_ARRAY(x_) ((*(unsigned long *)(x_))&=~(1UL)) /* #define COLLECT_RELBLOCK_P (what_to_collect == t_relocatable || what_to_collect == t_contiguous) */ bool collect_both=0; #define COLLECT_RELBLOCK_P (what_to_collect == t_relocatable || collect_both) static void mark_link_array(void *v,void *ve) { void **p,**pe; if (NULL_OR_ON_C_STACK(v)) return; if (sSAlink_arrayA->s.s_dbind==Cnil) return; p=(void *)sSAlink_arrayA->s.s_dbind->v.v_self; pe=(void *)p+sSAlink_arrayA->s.s_dbind->v.v_fillp; for (;p=v && *ps.s_dbind==Cnil) return; ne=n=p=(void *)sSAlink_arrayA->s.s_dbind->v.v_self; pe=(void *)p+sSAlink_arrayA->s.s_dbind->v.v_fillp; while (ps.s_dbind->v.v_fillp=(ne-n)*sizeof(*n); } static void sweep_link_array(void) { void ***p,***pe; if (sSAlink_arrayA->s.s_dbind==Cnil) return; p=(void *)sSAlink_arrayA->s.s_dbind->v.v_self; pe=(void *)p+sSAlink_arrayA->s.s_dbind->v.v_fillp; for (;pd.st>=ngc_thresh && (dp=alloc_contblock_no_gc(s,static_promotion_limit))) { *pp=memcpy(dp,p,s); x->d.st=0; return; } if (x && x->d.std.st++; if (p>=(void *)heap_end) *pp=(void *)copy_relblock(p,s); else mark_contblock(p,s); } static void mark_object1(object); #define mark_object(x) if (marking(x)) mark_object1(x) static inline void mark_object_address(object *o,int f) { static ufixnum lp; static ufixnum lr; extern object *min_cfd_self; ufixnum p=page(o); if (lp!=p || !f) { lp=p; lr= #ifdef SGC sgc_enabled ? WRITABLE_PAGE_P(lp) : #endif (o>=min_cfd_self && o<((object *)core_end)); } if (lr) mark_object(*o); } static inline void mark_object_array(object *o,object *oe) { int f=0; if (o) for (;oc.c_car); mark_object(Scdr(x));/*FIXME*/ break; case t_fixnum: break; case t_bignum: MARK_LEAF_DATA(x,MP_SELF(x),MP_ALLOCATED(x)*MP_LIMB_SIZE); break; case t_ratio: mark_object(x->rat.rat_num); mark_object(x->rat.rat_den); case t_shortfloat: break; case t_longfloat: break; case t_complex: mark_object(x->cmp.cmp_imag); mark_object(x->cmp.cmp_real); case t_character: break; case t_symbol: mark_object(x->s.s_plist); mark_object(x->s.s_gfdef); mark_object(x->s.s_dbind); MARK_LEAF_DATA(x,x->s.s_self,x->s.s_fillp); break; case t_package: mark_object(x->p.p_name); mark_object(x->p.p_nicknames); mark_object(x->p.p_shadowings); mark_object(x->p.p_uselist); mark_object(x->p.p_usedbylist); mark_object_array(x->p.p_internal,x->p.p_internal+x->p.p_internal_size); MARK_LEAF_DATA(x,x->p.p_internal,x->p.p_internal_size*sizeof(object)); mark_object_array(x->p.p_external,x->p.p_external+x->p.p_external_size); MARK_LEAF_DATA(x,x->p.p_external,x->p.p_external_size*sizeof(object)); break; case t_hashtable: mark_object(x->ht.ht_rhsize); mark_object(x->ht.ht_rhthresh); if (x->ht.ht_self) for (i=0;iht.ht_size;i++) if (x->ht.ht_self[i].hte_key!=OBJNULL) { mark_object_address(&x->ht.ht_self[i].hte_key,i); mark_object_address(&x->ht.ht_self[i].hte_value,i+1); } i=x->ht.ht_cache-x->ht.ht_self; MARK_LEAF_DATA(x,x->ht.ht_self,x->ht.ht_size*sizeof(*x->ht.ht_self)); if (x->ht.ht_cache) x->ht.ht_cache=x->ht.ht_self+i; break; case t_array: MARK_LEAF_DATA(x,x->a.a_dims,sizeof(*x->a.a_dims)*x->a.a_rank); case t_vector: case t_bitvector: switch(j ? j : (enum aelttype)x->v.v_elttype) { case aet_lf: j= sizeof(longfloat)*x->v.v_dim; if ((COLLECT_RELBLOCK_P) && (void *)x->v.v_self>=(void *)heap_end) rb_pointer=PCEI(rb_pointer,sizeof(double)); /*FIXME GC space violation*/ break; case aet_bit: #define W_SIZE (8*sizeof(fixnum)) j= sizeof(fixnum)*((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); break; case aet_char: case aet_uchar: j=sizeof(char)*x->v.v_dim; break; case aet_short: case aet_ushort: j=sizeof(short)*x->v.v_dim; break; case aet_object: if (x->v.v_displaced->c.c_car==Cnil) mark_object_array(x->v.v_self,x->v.v_self+x->v.v_dim); default: j=sizeof(fixnum)*x->v.v_dim; } case t_string:/*FIXME*/ j=j ? j : x->st.st_dim; if (x->v.v_displaced->c.c_car==Cnil) { void *p=x->v.v_self; MARK_LEAF_DATA(x,x->v.v_self,j); if (x->v.v_displaced!=Cnil) { j=(void *)x->v.v_self-p; x->v.v_self=p; adjust_displaced(x,j); } } mark_object(x->v.v_displaced); break; case t_structure: { object def=x->str.str_def; unsigned char *s_type= &SLOT_TYPE(def,0); unsigned short *s_pos= &SLOT_POS(def,0); mark_object(x->str.str_def); if (x->str.str_self) for (i=0,j=S_DATA(def)->length;istr.str_self,S_DATA(def)->size); } break; case t_stream: switch (x->sm.sm_mode) { case smm_input: case smm_output: case smm_io: case smm_socket: case smm_probe: mark_object(x->sm.sm_object0); mark_object(x->sm.sm_object1); if (x->sm.sm_fp) { MARK_LEAF_DATA(x,x->sm.sm_buffer,BUFSIZ); } break; case smm_synonym: mark_object(x->sm.sm_object0); break; case smm_broadcast: case smm_concatenated: mark_object(x->sm.sm_object0); break; case smm_two_way: case smm_echo: mark_object(x->sm.sm_object0); mark_object(x->sm.sm_object1); break; case smm_string_input: case smm_string_output: mark_object(x->sm.sm_object0); break; #ifdef USER_DEFINED_STREAMS case smm_user_defined: mark_object(x->sm.sm_object0); mark_object(x->sm.sm_object1); break; #endif default: error("mark stream botch"); } break; case t_random: MARK_LEAF_DATA_ALIGNED(x,x->rnd.rnd_state._mp_seed->_mp_d,x->rnd.rnd_state._mp_seed->_mp_alloc*MP_LIMB_SIZE,MP_LIMB_SIZE); break; case t_readtable: mark_object(x->rt.rt_case); if (x->rt.rt_self) { for (i=0;irt.rt_self[i].rte_macro,i); for (i=0;irt.rt_self[i].rte_dtab,x->rt.rt_self[i].rte_dtab+RTABSIZE); MARK_LEAF_DATA(x,x->rt.rt_self[i].rte_dtab,RTABSIZE*sizeof(object)); } } MARK_LEAF_DATA(x,x->rt.rt_self,RTABSIZE*sizeof(struct rtent)); break; case t_pathname: mark_object(x->pn.pn_host); mark_object(x->pn.pn_device); mark_object(x->pn.pn_directory); mark_object(x->pn.pn_name); mark_object(x->pn.pn_type); mark_object(x->pn.pn_version); mark_object(x->pn.pn_namestring); break; case t_closure: mark_object_array(x->cl.cl_env,x->cl.cl_env+x->cl.cl_envdim); MARK_LEAF_DATA(x,x->cl.cl_env,x->cl.cl_envdim*sizeof(object)); case t_cfun: case t_sfun: case t_vfun: case t_afun: case t_gfun: mark_object(x->cf.cf_name); mark_object(x->cf.cf_data); break; case t_cfdata: mark_object_array(x->cfd.cfd_self,x->cfd.cfd_self+x->cfd.cfd_fillp); if (what_to_collect == t_contiguous) mark_link_array(x->cfd.cfd_start,x->cfd.cfd_start+x->cfd.cfd_size); MARK_LEAF_DATA(NULL,x->cfd.cfd_start,x->cfd.cfd_size);/*Code cannot move*/ break; case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (x->cc.cc_turbo) { x->cc.cc_turbo--; mark_object_array(x->cc.cc_turbo,x->cc.cc_turbo+fix(x->cc.cc_turbo[0])); MARK_LEAF_DATA(x,x->cc.cc_turbo,(1+fix(x->cc.cc_turbo[0]))*sizeof(*x->cc.cc_turbo)); x->cc.cc_turbo++; } break; case t_spice: break; default: #ifdef DEBUG if (debug) printf("\ttype = %d\n", type_of(x)); #endif error("mark botch"); } } static long *c_stack_where; static void mark_stack_carefully(void *topv, void *bottomv, int offset) { long pageoffset; long p; object x; struct typemanager *tm; register long *j; long *top=topv,*bottom=bottomv; /* if either of these happens we are marking the C stack and need to use a local */ if (top==0) top = c_stack_where; if (bottom==0) bottom= c_stack_where; /* On machines which align local pointers on multiple of 2 rather than 4 we need to mark twice */ if (offset) mark_stack_carefully((((char *) top) +offset),bottom,0); for (j=top ; j >= bottom ; j--) { void *v=(void *)(*j); struct pageinfo *pi; if (!VALID_DATA_ADDRESS_P(v)) continue; if ((p=page(v))type); if (tm->tm_type>=t_end) continue; if (pageoffset<0 || pageoffset>=tm->tm_size*tm->tm_nppage) continue; x=(object)(v-pageoffset%tm->tm_size); if (is_marked_or_free(x)) continue; mark_object(x); } } static void mark_phase(void) { STATIC fixnum i, j; STATIC struct package *pp; STATIC bds_ptr bdp; STATIC frame_ptr frp; STATIC ihs_ptr ihsp; mark_object(Cnil->s.s_plist); mark_object(Ct->s.s_plist); mark_stack_carefully(vs_top-1,vs_org,0); mark_stack_carefully(MVloc+(sizeof(MVloc)/sizeof(object)),MVloc,0); #ifdef DEBUG if (debug) { printf("value stack marked\n"); fflush(stdout); } #endif for (bdp = bds_org; bdp<=bds_top; bdp++) { mark_object(bdp->bds_sym); mark_object(bdp->bds_val); } for (frp = frs_org; frp <= frs_top; frp++) mark_object(frp->frs_val); for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) mark_object(ihsp->ihs_function); for (i = 0; i < mark_origin_max; i++) mark_object(*mark_origin[i]); for (i = 0; i < mark_origin_block_max; i++) for (j = 0; j < mark_origin_block[i].mob_size; j++) mark_object(mark_origin_block[i].mob_addr[j]); for (pp = pack_pointer; pp != NULL; pp = pp->p_link) mark_object((object)pp); #ifdef DEBUG if (debug) { printf("symbol navigation\n"); fflush(stdout); } #endif /* mark the c stack */ #ifndef N_RECURSION_REQD #define N_RECURSION_REQD 2 #endif mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); } #if defined(__ia64__) asm(" .text"); asm(" .psr abi64"); asm(" .psr lsb"); asm(" .lsb"); asm(""); asm(" .text"); asm(" .align 16"); asm(" .global GC_save_regs_in_stack"); asm(" .proc GC_save_regs_in_stack"); asm("GC_save_regs_in_stack:"); asm(" .body"); asm(" flushrs"); asm(" ;;"); asm(" mov r8=ar.bsp"); asm(" br.ret.sptk.few rp"); asm(" .endp GC_save_regs_in_stack"); void * GC_save_regs_in_stack(); #endif #if defined(__hppa__) /* Courtesy of Lamont Jones */ /* the calling sequence */ struct regs { void *callee_saves[16]; }; void hppa_save_regs(struct regs); /* the code */ asm(".code"); asm(".export hppa_save_regs, entry"); asm(".label hppa_save_regs"); asm(".proc"); asm(".callinfo"); asm(".entry"); asm("stw %r3,0(%arg0)"); asm("stw %r4,4(%arg0)"); asm("stw %r5,8(%arg0)"); asm("stw %r6,12(%arg0)"); asm("stw %r7,16(%arg0)"); asm("stw %r8,20(%arg0)"); asm("stw %r9,24(%arg0)"); asm("stw %r10,28(%arg0)"); asm("stw %r11,32(%arg0)"); asm("stw %r12,36(%arg0)"); asm("stw %r13,40(%arg0)"); asm("stw %r14,44(%arg0)"); asm("stw %r15,48(%arg0)"); asm("stw %r16,52(%arg0)"); asm("stw %r17,56(%arg0)"); asm("bv 0(%rp)"); asm("stw %r18,60(%arg0)"); asm(".exit"); asm(".procend"); asm(".end"); #endif static void mark_c_stack(jmp_buf env1, int n, void (*fn)(void *,void *,int)) { #if defined(__hppa__) struct regs hppa_regs; #endif jmp_buf env; int where; if (n== N_RECURSION_REQD) c_stack_where = (long *) (void *) &env; if (n > 0 ) { #if defined(__hppa__) hppa_save_regs(hppa_regs); #else setjmp(env); #endif mark_c_stack(env,n - 1,fn); } else { /* If the locals of type object in a C function could be aligned other than on multiples of sizeof (char *) then define this. At the moment 2 is the only other legitimate value besides 0 */ #ifndef C_GC_OFFSET #define C_GC_OFFSET 0 #endif if (&where > cs_org) (*fn)(0,cs_org,C_GC_OFFSET); else (*fn)(cs_org,0,C_GC_OFFSET); } #if defined(__ia64__) { extern void * __libc_ia64_register_backing_store_base; void * bst=GC_save_regs_in_stack(); void * bsb=__libc_ia64_register_backing_store_base; if (bsb>bst) (*fn)(bsb,bst,C_GC_OFFSET); else (*fn)(bst,bsb,C_GC_OFFSET); } #endif } static void sweep_phase(void) { STATIC long j, k, l; STATIC object x; STATIC char *p; STATIC struct typemanager *tm; STATIC object f; STATIC struct pageinfo *v; for (j= t_start; j < t_contiguous ; j++) { tm_of(j)->tm_free=OBJNULL; tm_of(j)->tm_nfree=0; } for (v=cell_list_head;v;v=v->next) { tm = tm_of((enum type)v->type); p = pagetochar(page(v)); f = FREELIST_TAIL(tm); l = k = 0; for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { x = (object)p; if (is_marked(x)) { unmark(x); l++; continue; } k++; make_free(x); SET_LINK(f,x); f = x; } SET_LINK(f,OBJNULL); tm->tm_tail = f; tm->tm_nfree += k; pagetoinfo(page(v))->in_use=l; } } static void contblock_sweep_phase(void) { struct pageinfo *v; STATIC char *s, *e, *p, *q; ufixnum i; reset_contblock_freelist(); for (i=0;iv.v_fillp && (v=(void *)contblock_array->v.v_self[i]);i++) { bool z; #ifdef SGC if (sgc_enabled && !(v->sgc_flags&SGC_PAGE_FLAG)) continue; #endif s=CB_DATA_START(v); e=(void *)v+v->in_use*PAGESIZE; z=get_mark_bit(v,s); for (p=s;pcb_link,ncb++); return ncb; } void GBC(enum type t) { #ifdef DEBUG int tm=0; #endif BEGIN_NO_INTERRUPT; if (t==t_other) { collect_both=1; t=t_contiguous; } ngc_thresh=fix(sSAleaf_collection_thresholdA->s.s_dbind); recent_allocation=0; if (in_signal_handler && t == t_relocatable) error("cant gc relocatable in signal handler"); if (GBC_enter_hook != NULL) (*GBC_enter_hook)(); if (!GBC_enable) error("GBC is not enabled"); interrupt_enable = FALSE; if (saving_system) { struct pageinfo *v; void *x; struct typemanager *tm=tm_of(t_stream); unsigned j; for (v=cell_list_head;v;v=v->next) if (tm->tm_type==v->type) for (x=pagetochar(page(v)),j=tm->tm_nppage;j--;x+=tm->tm_size) { object o=x; if (type_of(o)==t_stream && !is_free(o) && o->sm.sm_fp && o->sm.sm_fp!=stdin && o->sm.sm_fp!=stdout && o->sm.sm_fp!=stderr) close_stream(o); } gc_time = -1; } #ifdef DEBUG debug = symbol_value(sSAgbc_messageA) != Cnil; #endif what_to_collect = t; tm_table[(int)t].tm_gbccount++; tm_table[(int)t].tm_adjgbccnt++; if (sSAnotify_gbcA->s.s_dbind != Cnil #ifdef DEBUG || debug #endif ) { if (gc_time < 0) gc_time=0; #ifdef SGC emsg("[%s for %ld %s pages..", (sgc_enabled ? "SGC" : "GC"), (sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage), (tm_table[(int)t].tm_name)+1); #else emsg("[%s for %ld %s pages..", ("GC"), (tm_of(t)->tm_npage), (tm_table[(int)t].tm_name)+1); #endif #ifdef SGC if(sgc_enabled) printf("(%ld faulted pages, %ld writable, %ld read only)..", fault_pages,(page(core_end)-first_data_page)-(page(rb_start)-page(heap_end))-sgc_count_read_only(), sgc_count_read_only()); #endif fflush(stdout); } if (gc_time >=0 && !gc_recursive++) {gc_start=runtime();} if (COLLECT_RELBLOCK_P) { static_promotion_limit=rb_starts.s_dbind->v.v_self; #endif } if (t == t_contiguous) { #ifdef DEBUG if (debug) { printf("contblock sweep phase\n"); fflush(stdout); tm = runtime(); } #endif contblock_sweep_phase(); #ifdef DEBUG if (debug) printf("contblock sweep ended (%d)\n", runtime() - tm); #endif } #ifdef DEBUG if (debug) { int i,j; for (i = 0, j = 0; i < (int)t_end; i++) { if (tm_table[i].tm_type == (enum type)i) { printf("%13s: %8ld used %8ld free %4ld/%ld pages\n", tm_table[i].tm_name, TM_NUSED(tm_table[i]), tm_table[i].tm_nfree, tm_table[i].tm_npage, tm_table[i].tm_maxpage); j += tm_table[i].tm_npage; } else printf("%13s: linked to %s\n", tm_table[i].tm_name, tm_table[(int)tm_table[i].tm_type].tm_name); } printf("contblock: %ld blocks %ld pages\n", count_contblocks(), ncbpage); printf("hole: %lu pages\n", (ufixnum)page(rb_start-heap_end)); printf("relblock: %ld bytes used %ld bytes free %ld pages\n", (long)(rb_pointer - rb_start), (long)(rb_end - rb_pointer), nrbpage); printf("GBC ended\n"); fflush(stdout); } #endif interrupt_enable = TRUE; if (GBC_exit_hook != NULL) (*GBC_exit_hook)(); if(gc_time>=0 && !--gc_recursive) {gc_time=gc_time+(gc_start=(runtime()-gc_start));} if (sSAnotify_gbcA->s.s_dbind != Cnil) { if (gc_recursive) emsg("(T=...).GC finished]\n"); else emsg("(T=%d).GC finished]\n",gc_start); } collect_both=0; END_NO_INTERRUPT; CHECK_INTERRUPT; } static void FFN(siLheap_report)(void) { int i; check_arg(0); vs_check_push(make_fixnum(sizeof(fixnum)*CHAR_SIZE)); vs_push(make_fixnum(PAGESIZE)); vs_push(make_fixnum((ufixnum)data_start)); vs_push(make_fixnum((ufixnum)data_start+(real_maxpage<>1)); vs_push(make_fixnum(CSTACK_ALIGNMENT)); vs_push(make_fixnum(labs(cs_limit-cs_org)));/*CSSIZE*/ #if defined(IM_FIX_BASE) && defined(IM_FIX_LIM) #ifdef LOW_IM_FIX vs_push(make_fixnum(-LOW_IM_FIX)); vs_push(make_fixnum(1UL<>PAGEWIDTH)); vs_push(make_fixnum(rb_pointer - rb_begin())); vs_push(make_fixnum((rb_begin()+rb_size()) - rb_pointer)); vs_push(make_fixnum(nrbpage)); vs_push(make_fixnum(maxrbpage)); vs_push(make_fixnum(rbgbccount)); for (i = 0; i < (int)t_end; i++) { if (tm_table[i].tm_type == (enum type)i) { vs_check_push(make_fixnum(TM_NUSED(tm_table[i]))); vs_push(make_fixnum(tm_table[i].tm_nfree+tm_table[i].tm_alt_nfree)); vs_push(make_fixnum(tm_table[i].tm_npage)); vs_push(make_fixnum(tm_table[i].tm_maxpage)); vs_push(make_fixnum(tm_table[i].tm_gbccount)); } else { vs_check_push(Cnil); vs_push(make_fixnum(tm_table[i].tm_type)); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); } } } static void FFN(siLreset_gbc_count)(void) { int i; check_arg(0); for (i = 0; i < t_other; i++) tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt = tm_table[i].tm_opt_maxpage = 0; } /* copy S bytes starting at P to beyond rb_pointer1 (temporarily) but return a pointer to where this will be copied back to, when gc is done. alignment of rb_pointer is kept at a multiple of sizeof(char *); */ static char * copy_relblock(char *p, int s) { char *q = rb_pointer; s = CEI(s,PTR_ALIGN); rb_pointer += s; memmove(q,p,s);/*FIXME memcpy*/ return q; } static void mark_contblock(void *p, int s) { STATIC char *q; STATIC char *x, *y; struct pageinfo *v; if (NULL_OR_ON_C_STACK(p)) return; q = p + s; /* SGC cont pages: contblock pages must be no smaller than sizeof(struct contblock). CM 20030827 */ x = (char *)PFLR(p,CPTR_SIZE); y = (char *)PCEI(q,CPTR_SIZE); massert(v=get_pageinfo(x)); #ifdef SGC if (!sgc_enabled || (v->sgc_flags&SGC_PAGE_FLAG)) #endif set_mark_bits(v,x,y); } DEFUN_NEW("CONTIGUOUS-REPORT",object,fScontiguous_report,SI,1,1,NONE,OO,OO,OO,OO,(void),"") { struct contblock **cbpp; struct pageinfo *v; ufixnum i,j,k,s; struct typemanager *tm=tm_of(t_cfdata); void *p; for (i=j=0,cbpp=&cb_pointer;(*cbpp);) { for (k=0,s=(*cbpp)->cb_size,p=*cbpp;*cbpp && (*cbpp)->cb_size==s;i+=(*cbpp)->cb_size,j++,k++,cbpp=&(*cbpp)->cb_link); emsg("%lu %lu starting at %p\n",k,s,p); } emsg("\nTotal free %lu in %lu pieces\n\n",i,j); for (i=j=k=0;kv.v_fillp && (v=(void *)contblock_array->v.v_self[k]);k++,i+=v->in_use,j++) emsg("%lu pages at %p\n",(unsigned long)v->in_use,v); emsg("\nTotal pages %lu in %lu pieces\n\n",i,j); for (i=j=0,v=cell_list_head;v;v=v->next) if (tm->tm_type==v->type) { void *p; ufixnum k; for (p=pagetochar(page(v)),k=0;ktm_nppage;k++,p+=tm->tm_size) { object o=p; if (!is_free(o) && type_of(o)==t_cfdata && (void *)o->cfd.cfd_start>=data_start) { emsg("%lu code bytes at %p\n",(unsigned long)o->cfd.cfd_size,o->cfd.cfd_start); i+=o->cfd.cfd_size; j++; } } } emsg("\nTotal code bytes %lu in %lu pieces\n",i,j); for (i=j=0,v=cell_list_head;v;v=v->next) { struct typemanager *tm=tm_of(v->type); void *p; ufixnum k; for (p=pagetochar(page(v)),k=0;ktm_nppage;k++,p+=tm->tm_size) { object o=p; void *d=NULL; ufixnum s=0; if (!is_free(o)) { switch (type_of(o)) { case t_array: case t_vector: d=o->a.a_self; s=o->a.a_dim*sizeof(object); break; case t_hashtable: d=o->ht.ht_self; s=o->ht.ht_size*sizeof(object)*2; break; case t_symbol: d=o->s.s_self; s=o->s.s_fillp; break; case t_string: case t_bitvector: d=o->a.a_self; s=o->a.a_dim; break; case t_package: d=o->p.p_external; s=(o->p.p_external_size+o->p.p_internal_size)*sizeof(object); break; case t_bignum: d=o->big.big_mpz_t._mp_d; s=o->big.big_mpz_t._mp_alloc*MP_LIMB_SIZE; break; case t_structure: d=o->str.str_self; s=S_DATA(o->str.str_def)->length*sizeof(object); break; case t_random: d=o->rnd.rnd_state._mp_seed->_mp_d; s=o->rnd.rnd_state._mp_seed->_mp_alloc*MP_LIMB_SIZE; break; case t_cclosure: d=o->cc.cc_turbo; s=fix(o->cc.cc_turbo[-1]); break; case t_cfdata: d=o->cfd.cfd_start; s=o->cfd.cfd_size; break; case t_readtable: d=o->rt.rt_self; s=RTABSIZE*(sizeof(struct rtent));/*FIXME*/ break; default: break; } if (d>=data_start && d<(void *)heap_end && s) { emsg("%lu %s bytes at %p\n",s,tm_table[type_of(o)].tm_name,d); i+=s; j++; } } } } emsg("\nTotal leaf bytes %lu in %lu pieces\n",i,j); return Cnil; } DEFUN_NEW("GBC",object,fSgbc,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") { if (x0 == Ct) { tm_table[t_contiguous].tm_adjgbccnt--; GBC(t_other); } else if (x0 == Cnil) { tm_table[t_cons].tm_adjgbccnt--; GBC(t_cons); } else if (eql(small_fixnum(0),x0)) { tm_table[t_contiguous].tm_adjgbccnt--; GBC(t_contiguous); } else { x0 = small_fixnum(1); tm_table[t_relocatable].tm_adjgbccnt--; GBC(t_relocatable); } RETURN1(x0); } static void FFN(siLgbc_time)(void) { if (vs_top>vs_base) gc_time=fix(vs_base[0]); else { vs_base[0]=make_fixnum(gc_time); vs_top=vs_base+1; } } #ifdef SGC #include "sgbc.c" #endif DEFVAR("*NOTIFY-GBC*",sSAnotify_gbcA,SI,Cnil,""); #ifdef DEBUG DEFVAR("*GBC-MESSAGE*",sSAgbc_messageA,SI,Cnil,""); #endif void gcl_init_GBC(void) { make_si_function("HEAP-REPORT", siLheap_report); make_si_function("ROOM-REPORT", siLroom_report); make_si_function("RESET-GBC-COUNT", siLreset_gbc_count); make_si_function("GBC-TIME",siLgbc_time); #ifdef SGC make_si_function("SGC-ON",siLsgc_on); #endif } gcl-2.6.14/o/rel_ps2aix.c0000755000175000017500000000505514360276512013455 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c */ print_rel(rel,sym) struct syment *sym; struct reloc *rel; {char tem[10]; printf(" (name = %s)",SYM_NAME(sym)); printf("{r_type=%d",rel->r_type); fflush(stdout); } #ifdef DEBUG #define describe_sym describe_sym1 describe_sym1(n) int n; {char *str; char tem[9]; struct syment *sym; sym= &symbol_table[n]; str = SYM_NAME(sym); if (debug == 0) return 1; printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); printf("symbol is (%s):\nsymbol_table[n]._n._n_name %d\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d " "\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", symbol_table[n]._n._n_name, symbol_table[n]._n._n_n._n_zeroes , symbol_table[n]._n._n_n._n_offset , symbol_table[n]._n._n_nptr[0] , symbol_table[n]._n._n_nptr[1] , symbol_table[n].n_value , symbol_table[n].n_scnum , symbol_table[n].n_type , symbol_table[n].n_sclass , symbol_table[n].n_numaux ); } #endif #define LONG_AT_ADDR(p) LONG_AT_ADDR1(((unsigned char *)p)) #define LONG_AT_ADDR1(p) (p[0] | (p[1] << 8) | (p[2] << 16) |(p[3] << 24)) #define STORE_LONG(p,val) STORE_LONG1(((unsigned char *)p),val) #define STORE_LONG1(p,val) (p[3]=(val >> 24),p[0]=val,p[1]=(val >> 8),p[2]=(val >> 16)) relocate() { char *where; int old_val,new_val; #ifdef DEBUG if (debug) {print_rel(&relocation_info,&symbol_table[relocation_info.r_symndx]); describe_sym(relocation_info.r_symndx);} #endif where = the_start + relocation_info.r_vaddr; dprintf (where has %x , *where); dprintf( at %x -->, where ); if (relocation_info.r_type == R_ABS) { dprintf( r_abs ,0); return; } old_val = LONG_AT_ADDR(where); switch(relocation_info.r_type) { int *q; case R_DIR32: new_val= old_val + symbol_table[relocation_info.r_symndx].n_value; dprintf(new val r_dir32 %x , new_val); STORE_LONG(where,new_val); break; case R_PCRLONG: new_val = old_val - (int) start_address + symbol_table[relocation_info.r_symndx].n_value; dprintf( r_pcrlong new value = %x , new_val) STORE_LONG(where,new_val); break; default: fprintf(stderr, "%d: unsupported relocation type.", relocation_info.r_type); FEerror("The relocation type was unknown",0,0); } } gcl-2.6.14/o/macros.c0000755000175000017500000002021114360276512012660 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* macros.c */ #include "include.h" object sLwarn; object sSAinhibit_macro_specialA; static void FFN(siLdefine_macro)(void) { check_arg(2); if (type_of(vs_base[0]) != t_symbol) not_a_symbol(vs_base[0]); if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) { if (vs_base[0]->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) vs_base[0]->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, vs_base[0]); } clear_compiler_properties(vs_base[0],MMcaddr(vs_base[1])); if (vs_base[0]->s.s_hpack == lisp_package && vs_base[0]->s.s_gfdef != OBJNULL && !raw_image) { vs_push(make_simple_string( "~S is being redefined.")); ifuncall2(sLwarn, vs_head, vs_base[0]); vs_popp; } vs_base[0]->s.s_gfdef = MMcaddr(vs_base[1]); vs_base[0]->s.s_mflag = TRUE; if (MMcar(vs_base[1]) != Cnil) { vs_base[0]->s.s_plist = putf(vs_base[0]->s.s_plist, MMcar(vs_base[1]), sSfunction_documentation); } if (MMcadr(vs_base[1]) != Cnil) { vs_base[0]->s.s_plist = putf(vs_base[0]->s.s_plist, MMcadr(vs_base[1]), sSpretty_print_format); } vs_top = vs_base+1; } static void FFN(Fdefmacro)(object form) { object *top = vs_top; object name; if (endp(form) || endp(MMcdr(form))) FEtoo_few_argumentsF(form); name = MMcar(form); if (type_of(name) != t_symbol) not_a_symbol(name); vs_push(ifuncall3(sSdefmacroA, name, MMcadr(form), MMcddr(form))); if (MMcar(top[0]) != Cnil) name->s.s_plist = putf(name->s.s_plist, MMcar(top[0]), sSfunction_documentation); if (MMcadr(top[0]) != Cnil) name->s.s_plist = putf(name->s.s_plist, MMcadr(top[0]), sSpretty_print_format); if (name->s.s_sfdef != NOT_SPECIAL) { if (name->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) name->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, name); } clear_compiler_properties(name,MMcaddr(top[0])); if (name->s.s_hpack == lisp_package && name->s.s_gfdef != OBJNULL && !raw_image) { vs_push(make_simple_string( "~S is being redefined.")); ifuncall2(sLwarn, vs_head, name); vs_popp; } name->s.s_gfdef = MMcaddr(top[0]); name->s.s_mflag = TRUE; vs_base = vs_top = top; vs_push(name); } /* Macros may well need their functional environment to expand properly. For example setf needs to expand the place which may be a local macro. They are not supposed to need the other parts of the environment */ #define VS_PUSH_ENV vs_push(MACRO_EXPAND_ENV) #define MACRO_EXPAND_ENV \ (lex_env[1]!= sLnil ? \ list(3,lex_env[0],lex_env[1],lex_env[2]) : sLnil) /* MACRO_EXPAND1 is an internal function which simply applies the function EXP_FUN to FORM. On return, the expanded form is stored in VS_BASE[0]. */ object Imacro_expand1(object exp_fun, object form) { return Ifuncall_n(sLAmacroexpand_hookA->s.s_dbind, 3,exp_fun,form,MACRO_EXPAND_ENV); } /* MACRO_DEF is an internal function which, given a form, returns the expansion function if the form is a macro form. Otherwise, MACRO_DEF returns NIL. */ static object macro_def(object form) { object head, fd; if (type_of(form) != t_cons) return(Cnil); head = MMcar(form); if (type_of(head) != t_symbol) return(Cnil); fd = lex_fd_sch(head); if (MMnull(fd)) if (head->s.s_mflag) return(head->s.s_gfdef); else return(Cnil); else if (MMcadr(fd) == sSmacro) return(MMcaddr(fd)); else return(Cnil); } DEFUNOM_NEW("MACROEXPAND",object,fLmacroexpand,LISP ,1,2,NONE,OO,OO,OO,OO,void,Lmacroexpand,(object form,...),"") { int n=VFUN_NARGS; object envir; object exp_fun; object *lex=lex_env; object buf[3]; va_list ap; { va_start(ap,form); if (n>=2) envir=va_arg(ap,object);else goto LDEFAULT2; goto LEND_VARARG; LDEFAULT2: envir = Cnil; LEND_VARARG: va_end(ap);} lex_env = buf; if (n== 1) {buf[0]=sLnil; buf[1]=sLnil; buf[2]=sLnil; } else if (n==2) { buf[0]=car(envir); envir=Mcdr(envir); buf[1]=car(envir); envir=Mcdr(envir); buf[2]=car(envir); } else check_arg_range(1,2); exp_fun = macro_def(form); if (MMnull(exp_fun)) { lex_env = lex; RETURN(2,object,form,(RV(sLnil))); } else { object *top = vs_top; do { form= Imacro_expand1(exp_fun, form); vs_top = top; exp_fun = macro_def(form); } while (!MMnull(exp_fun)); lex_env = lex; RETURN(2,object,form,(RV(sLt))); } } LFD(Lmacroexpand_1)(void) { object exp_fun; object *base=vs_base; object *lex=lex_env; lex_env = vs_top; if (vs_top-vs_base<1) too_few_arguments(); else if (vs_top-vs_base == 1) { vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); } else if (vs_top-vs_base == 2) { vs_push(car(vs_base[1])); vs_push(car(cdr(vs_base[1]))); vs_push(car(cdr(cdr(vs_base[1])))); } else too_many_arguments(); exp_fun = macro_def(base[0]); if (MMnull(exp_fun)) { lex_env = lex; vs_base = base; vs_top = base+1; vs_push(Cnil); } else { base[0]=Imacro_expand1(exp_fun, base[0]); lex_env = lex; vs_base = base; vs_top = base+1; vs_push(Ct); } } /* MACRO_EXPAND is an internal function which, given a form, expands it as many times as possible and returns the finally expanded form. The argument 'form' need not be marked for GBC and the result is not marked. */ object macro_expand(object form) { object exp_fun, head, fd; object *base = vs_base; object *top = vs_top; /* Check if the given form is a macro form. If not, return immediately. Macro definitions are superseded by special- form definitions. */ if (type_of(form) != t_cons) return(form); head = MMcar(form); if (type_of(head) != t_symbol) return(form); if (head->s.s_sfdef != NOT_SPECIAL) return(form); fd = lex_fd_sch(head); if (MMnull(fd)) if (head->s.s_mflag) exp_fun = head->s.s_gfdef; else return(form); else if (MMcadr(fd) == sSmacro) exp_fun = MMcaddr(fd); else return(form); vs_top = top; vs_push(form); /* saves form in top[0] */ vs_push(exp_fun); /* saves exp_fun in top[1] */ LOOP: /* macro_expand1(exp_fun, form); */ vs_base = vs_top; vs_push(exp_fun); vs_push(form); /***/ /* vs_push(Cnil); */ VS_PUSH_ENV ; /***/ super_funcall(symbol_value(sLAmacroexpand_hookA)); if (vs_base == vs_top) vs_push(Cnil); top[0] = form = vs_base[0]; /* Check if the expanded form is again a macro form. If not, reset the stack and return. */ if (type_of(form) != t_cons) goto END; head = MMcar(form); if (type_of(head) != t_symbol) goto END; if (head->s.s_sfdef != NOT_SPECIAL) goto END; fd=lex_fd_sch(head); if (MMnull(fd)) if (head->s.s_mflag) exp_fun = head->s.s_gfdef; else goto END; else if (MMcadr(fd) == sSmacro) exp_fun = MMcaddr(fd); else goto END; /* The expanded form is a macro form. Continue expansion. */ top[1] = exp_fun; vs_top = top + 2; goto LOOP; END: vs_base = base; vs_top = top; return(form); } DEF_ORDINARY("FUNCALL",sLfuncall,LISP,""); DEFVAR("*MACROEXPAND-HOOK*",sLAmacroexpand_hookA,LISP,sLfuncall,""); DEF_ORDINARY("DEFMACRO*",sSdefmacroA,SI,""); DEFVAR("*INHIBIT-MACRO-SPECIAL*",sSAinhibit_macro_specialA,SI,Cnil,""); void gcl_init_macros(void) { make_si_function("DEFINE-MACRO", siLdefine_macro); make_function("MACROEXPAND-1", Lmacroexpand_1); make_special_form("DEFMACRO", Fdefmacro); } gcl-2.6.14/o/earith.c0000755000175000017500000000011514360276512012651 0ustar cammcamm#define NEED_MP_H #include "include.h" #ifdef CMAC #include "cmac.c" #endif gcl-2.6.14/o/save_sgi4.c0000755000175000017500000002313614360276512013271 0ustar cammcamm/* for the 4d */ /* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* unixsave.c */ /* When MACHINE is S3000, use fcntl.h */ #ifdef ATT #include #include #else #include #endif #ifdef BSD #include #endif #ifdef VAX #define PAGSIZ 1024 #define SEGSIZ 1024 #define TXTRELOC 0 #endif #ifdef ISI #endif #ifdef SEQ #endif #ifdef NEWS #define TXTRELOC 0 #endif #ifdef IBMRT #endif #ifdef ATT #include #include #include #include #define exec aouthdr #define a_text tsize #define a_data dsize #define a_bss bsize #endif #ifdef E15 #include extern etext; #define exec bhdr #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #define SEGSIZ (128*1024) #define TXTRELOC (1024*1024) #endif #ifndef mips filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } #endif memory_save(original_file, save_file) char *original_file, *save_file; { #ifdef BSD struct exec header; int stsize; #endif #ifdef ATT #ifdef mips struct { struct filehdr filehdr; struct aouthdr aouthdr; struct scnhdr text_section, init_section, rdata_section, data_section, lit8_section, lit4_section, sdata_section, sbss_section, bss_section; } hdrs; struct filehdr *pfilehdr; struct aouthdr *paouthdr; struct scnhdr *pscnhdr; char buf[BUFSIZ]; HDRR symhdr; int fptr, nbytes, pagesize; #define setbuf(stream,buf) #else struct filehdr fileheader; struct exec header; #endif /* mips */ int diff; #endif #ifdef E15 struct exec header; #endif char *data_begin, *data_end; int original_data; FILE *original, *save; register int n; register char *p; extern void *sbrk(); fclose(stdin); original = fopen(original_file, "r"); if (stdin != original || original->_file != 0) { fprintf(stderr, "Can't open the original file.\n"); exit(1); } setbuf(original, stdin_buf); fclose(stdout); unlink(save_file); n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } setbuf(save, stdout_buf); #ifdef BSD fread(&header, sizeof(header), 1, original); #ifdef VAX data_begin = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); #endif #ifdef SUN data_begin = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); #endif #ifdef SUN2R3 data_begin = (char *)N_DATADDR(header); #endif #ifdef SUN3 data_begin = (char *)N_DATADDR(header); #endif #ifdef NEWS data_begin = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); #endif #ifdef ISI #endif #ifdef SEQ #endif #ifdef IBMRT #endif data_end = core_end; original_data = header.a_data; header.a_data = data_end - data_begin; header.a_bss = 0; fwrite(&header, sizeof(header), 1, save); #ifdef VAX if (header.a_magic == ZMAGIC) filecpy(save, original, PAGSIZ - sizeof(header)); filecpy(save, original, header.a_text); #endif #ifdef SUN if (header.a_magic == ZMAGIC) filecpy(save, original, PAGSIZ - sizeof(header)); filecpy(save, original, header.a_text); #endif #ifdef SUN2R3 filecpy(save, original, header.a_text - sizeof(header)); #endif #ifdef SUN3 filecpy(save, original, header.a_text - sizeof(header)); #endif #ifdef NEWS if (header.a_magic == ZMAGIC) filecpy(save, original, PAGSIZ - sizeof(header)); filecpy(save, original, header.a_text); #endif #ifdef ISI #endif #ifdef SEQ #endif #ifdef IBMRT #endif #endif #ifdef ATT #ifdef mips # define NSCNS 4 read(0, (char*)&hdrs.filehdr, FILHSZ + AOUTHSZ); pfilehdr = (struct filehdr*)hdrs.aouthdr.text_start; paouthdr = (struct aouthdr*)((long)pfilehdr + FILHSZ); pscnhdr = (struct scnhdr*)((long)paouthdr + AOUTHSZ); pagesize = getpagesize(); hdrs.aouthdr.dsize = ((long)core_end - hdrs.aouthdr.data_start + pagesize - 1) & ~(pagesize - 1); hdrs.aouthdr.bss_start = hdrs.aouthdr.data_start + hdrs.aouthdr.dsize; hdrs.aouthdr.bsize = 0; hdrs.filehdr.f_nscns = NSCNS; hdrs.filehdr.f_timdat = time(NULL); hdrs.filehdr.f_symptr = hdrs.aouthdr.tsize + hdrs.aouthdr.dsize; bcopy((char*)pscnhdr, (char*)&hdrs.text_section, NSCNS * SCNHSZ); hdrs.data_section.s_size = hdrs.aouthdr.dsize - hdrs.rdata_section.s_size; bzero((char*)&hdrs.lit8_section, sizeof hdrs - FILHSZ - AOUTHSZ - NSCNS * SCNHSZ); fptr = write(1, &hdrs, AOUTHSZ + FILHSZ + pfilehdr->f_nscns * SCNHSZ); p = (char*)hdrs.aouthdr.text_start + fptr; n = hdrs.aouthdr.tsize - fptr; nbytes = pagesize - fptr; write(1, p, nbytes); p += nbytes; n -= nbytes; while ( n > pagesize ) { write(1, p, pagesize); p += pagesize; n -= pagesize; } if ( n ) write(1, p, n); lseek(1, hdrs.rdata_section.s_scnptr, SEEK_SET); p = (char*)hdrs.aouthdr.data_start; n = hdrs.aouthdr.dsize; while ( n > pagesize ) { write(1, p, pagesize); p += pagesize; n -= pagesize; } if ( n ) write(1, p, n); lseek(0, pfilehdr->f_symptr, SEEK_SET); diff = hdrs.filehdr.f_symptr - pfilehdr->f_symptr; read(0, &symhdr, cbHDRR); #ifndef __STDC__ #define adjust(field)if(symhdr.cb/**/field/**/Offset)symhdr.cb/**/field/**/Offset+= diff #else #define adjust(field)if(symhdr.cb##field##Offset)symhdr.cb##field##Offset+= diff #endif adjust(Line); adjust(Dn); adjust(Pd); adjust(Sym); adjust(Opt); adjust(Aux); adjust(Ss); adjust(SsExt); adjust(Fd); adjust(Rfd); adjust(Ext); #undef adjust write(1, &symhdr, cbHDRR); while ( (n = read(0, buf, sizeof buf)) > 0 ) write(1, buf, n); #else fread(&fileheader, sizeof(fileheader), 1, original); fread(&header, sizeof(header), 1, original); data_begin = (char *)header.data_start; data_end = core_end; original_data = header.a_data; header.a_data = data_end - data_begin; diff = header.a_data - original_data; header.a_bss = sbrk(0) - core_end; fileheader.f_symptr += diff; fwrite(&fileheader, sizeof(fileheader), 1, save); fwrite(&header, sizeof(header), 1, save); fread(§ionheader, sizeof(sectionheader), 1, original); if (sectionheader.s_lnnoptr) sectionheader.s_lnnoptr += diff; fwrite(§ionheader, sizeof(sectionheader), 1, save); fread(§ionheader, sizeof(sectionheader), 1, original); sectionheader.s_size += diff; if (sectionheader.s_lnnoptr) sectionheader.s_lnnoptr += diff; fwrite(§ionheader, sizeof(sectionheader), 1, save); fread(§ionheader, sizeof(sectionheader), 1, original); sectionheader.s_paddr += diff; sectionheader.s_vaddr += diff; sectionheader.s_size = header.a_bss; #ifdef S3000 if (sectionheader.s_scnptr) sectionheader.s_scnptr += diff; #endif if (sectionheader.s_lnnoptr) sectionheader.s_lnnoptr += diff; fwrite(§ionheader, sizeof(sectionheader), 1, save); for (n = 4; n <= fileheader.f_nscns; n++) { fread(§ionheader, sizeof(sectionheader), 1, original); if (sectionheader.s_scnptr) sectionheader.s_scnptr += diff; if (sectionheader.s_lnnoptr) sectionheader.s_lnnoptr += diff; fwrite(§ionheader, sizeof(sectionheader), 1, save); } filecpy(save, original, header.a_text); #endif /* mips */ #endif #ifdef E15 fread(&header, sizeof(header), 1, original); if (header.fmagic != NMAGIC) data_begin = (char *)(TXTRELOC+header.a_text); else data_begin = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); data_end = core_end; original_data = header.a_data; header.a_data = data_end - data_begin; header.a_bss = sbrk(0) - core_end; fwrite(&header, sizeof(header), 1, save); filecpy(save, original, header.a_text); #endif #ifndef mips for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) if (n > BUFSIZ) fwrite(p, BUFSIZ, 1, save); else if (n > 0) { fwrite(p, 1, n, save); break; } else break; fseek(original, original_data, 1); #ifdef BSD filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); fread(&stsize, sizeof(stsize), 1, original); fwrite(&stsize, sizeof(stsize), 1, save); filecpy(save, original, stsize - sizeof(stsize)); #endif #ifdef ATT for (;;) { n = getc(original); if (feof(original)) break; putc(n, save); } #endif #ifdef E15 filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); #endif #endif /* !mips */ fclose(original); fclose(save); } Lsave() { char filename[256]; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); /* _cleanup(); */ { FILE *p; int nfile; #ifdef HAVE_GETDTABLESIZE nfile = getdtablesize(); #else nfile = _NFILE; #endif for (p = &__iob[3]; p < &__iob[nfile]; p++) fclose(p); } memory_save(kcl_self, filename); /* _exit(0); */ exit(0); /* no return */ } #ifdef ISI #endif gcl-2.6.14/o/firstfile.c0000755000175000017500000000230014360276512013362 0ustar cammcamm/* Mark beginning of data space to dump as pure, for GNU Emacs. Copyright (C) 1985 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "config.h" /* See comments in lastfile.c. */ char my_begdata[] = "Beginning of Emacs initialized data"; char my_begbss[1]; /* Do not initialize this variable. */ static char _my_begbss[1]; char * my_begbss_static = _my_begbss; /* Add a dummy reference to ensure emacs.obj is linked in. */ #ifdef emacs extern int initialized; static int * dummy = &initialized; #endif gcl-2.6.14/o/makefile0000644000175000017500000000654014360276512012736 0ustar cammcamm# make .d more important by clearing suffixes. .SUFFIXES: .SUFFIXES: .d .o .c .ini -include ../makedefs HDIR := ../h DEFS := -I../h -I../gcl-tk GCLIB := gcllib.a RANLIB := ranlib AR := ar qc LIBFILES :=$(addsuffix .o,bcmp bcopy bzero user_init user_match) DPP := ../bin/dpp$(EXE) DECL := $(HDIR)/new_decl.h ALIB := ${LIBFILES} ${EXTRA_LIB} OBJS:=$(addsuffix .o,typespec main alloc gbc bitop eval macros lex bds frame predicate reference assignment\ bind let conditional block iteration mapfun prog multival catch symbol cfun cmpaux package big number\ num_pred num_comp num_arith num_sfun num_co num_log num_rand earith character sequence list hash\ array string regexpr structure toplevel file read backq print format pathname unixfsys unixfasl\ error unixtime unixsys unixsave funlink fat_string run_process nfunlink usig usig2 utils makefun\ sockets clxsocket init_pari nsocket sfasl prelink gprof) OBJS:=$(OBJS) $(RL_OBJS) $(EXTRAS) INI_FILES=$(patsubst %.o,%.ini,${OBJS}) INI_FILES:=$(filter-out new_init.ini,$(filter-out boot.ini,$(INI_FILES))) OBJECTS:=$(OBJS) $(LIBFILES) new_init.o $(GCLIB) $(LAST_FILE) $(FIRST_FILE) all: $(OBJECTS) boot.o: boot.c $(DECL) boot.h $(CC) -c $(CFLAGS) $(DEFS) -fPIC $*.c $(AUX_INFO) gprof.o: gprof.c $(DECL) $(CC) -c $(filter-out -fomit-frame-pointer,$(CFLAGS)) $(DEFS) -pg $*.c $(AUX_INFO) prelink.o: prelink.c $(DECL) $(CC) -c $(filter-out -pg,$(CFLAGS)) -fPIE $(DEFS) $*.c $(AUX_INFO) %.o: %.c $(DECL) $(CC) -c $(CFLAGS) $(DEFS) $*.c $(AUX_INFO) %.c: %.d $(DPP) $(DPP) $* %.o: %.d $(DECL) $(DPP) $* $(CC) -c $(CFLAGS) $(DEFS) $*.c $(AUX_INFO) rm $*.c boot.ini: boot.c grab_defs $(CC) -DINICOMP -DNO_DEFUN -DNO_BOOT_H $(CFLAGS) $(DEFS) -E $*.c |\ sed -e 's,DEFUN,\nDEFUN,g' -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $@ boot.h: boot.ini echo '#include "make-init.h"' > $@ echo 'void gcl_init_boot(void){' >> $@ cat $< >> $@ echo '}' >> $@ %.ini: %.c grab_defs $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\ sed -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini %.ini: %.d $(DPP) grab_defs $(DPP) $* $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\ sed -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' | sed -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini rm $*.c $(DPP): ../bin/dpp.c ${CC} ${DEFS} -o $@ $< new_init.c: ${INI_FILES} echo '#include "make-init.h"' > $@ echo 'void NewInit(void){' >> $@ cat ${INI_FILES} >> $@ echo '}' >> $@ ! cat $@ | awk -F, '/DEFUN/ {print $2}' | grep -v object || (rm $@ && false) ifneq ($(NIFLAGS),) new_init.o: new_init.c $(DECL) $(CC) -c $(NIFLAGS) $(DEFS) $< -o $@ endif $(DECL): $(HDIR)/make-decl.h $(INI_FILES) echo '#include "make-decl.h"' > foo.c cat ${INI_FILES} |sed 's,DEFBFUN,DEFUN,g' >> foo.c ${CC} -E -I${HDIR} foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > tmpini ../xbin/move-if-changed mv tmpini $@ rm -f foo.c tmpini grab_defs: grab_defs.c ${CC} $(OFLAGS) -o grab_defs grab_defs.c wpool: wpool.o $(CC) $(LDFLAGS) -o $@ $< $(GCLIB): ${ALIB} rm -f gcllib.a $(AR) gcllib.a ${ALIB} ${RANLIB} gcllib.a clean: rm -f $(OBJS) ${ALIB} new_init.o $(LAST_FILE) $(FIRST_FILE) *.a grab_defs$(EXE) *.ini tmpx foo.c rm -f cmpinclude.h new_init.c $(DECL) def undef udef.h void.h TAGS boot.h wpool .INTERMEDIATE: $(patsubst %.d,%.c,$(shell ls -1 *.d)) gcl-2.6.14/o/fix-structref.el0000755000175000017500000000111714360276512014363 0ustar cammcamm(defun fix-struct-ref () (interactive) (while (re-search-forward "->\\([a-z]+\\)+[.]\\([A-Z][a-zA-Z]+\\)") (sit-for 0) (cond ((y-or-n-p "do it?") (downcase-region (match-beginning 2) (match-end 2)) (let ((xx (buffer-substring (match-beginning 2) (match-end 2))) (tem (buffer-substring (match-beginning 1) (match-end 1)))) (delete-region (match-beginning 2) (match-end 2)) (goto-char (match-beginning 2)) (insert tem "_") (let ((u (assoc xx '(("bind" . "dbind") ("body" . "self") )))) (insert (or (cdr u) xx)))))))) gcl-2.6.14/o/gmp_num_log.c0000644000175000017500000000541614360276512013706 0ustar cammcamm/* x : fixnum or bignum (may be not normalized) y : integer returns fixnum or bignum ( not normalized ) */ object big_log_op(); object normalize_big(object); static fixnum fixnum_log_op2(fixnum op,fixnum x,fixnum y) { return fixnum_boole(op,x,y); } static object integer_log_op2(fixnum op,object x,enum type tx,object y,enum type ty) { object u=big_fixnum1; object ux=tx==t_bignum ? x : (mpz_set_si(MP(big_fixnum2),fix(x)), big_fixnum2); object uy=ty==t_bignum ? y : (mpz_set_si(MP(big_fixnum3),fix(y)), big_fixnum3); switch(op) { case BOOLCLR: mpz_set_si(MP(u),0);break; case BOOLSET: mpz_set_si(MP(u),-1);break; case BOOL1: mpz_set(MP(u),MP(ux));break; case BOOL2: mpz_set(MP(u),MP(uy));break; case BOOLC1: mpz_com(MP(u),MP(ux));break; case BOOLC2: mpz_com(MP(u),MP(uy));break; case BOOLAND: mpz_and(MP(u),MP(ux),MP(uy));break; case BOOLIOR: mpz_ior(MP(u),MP(ux),MP(uy));break; case BOOLXOR: mpz_xor(MP(u),MP(ux),MP(uy));break; case BOOLEQV: mpz_xor(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; case BOOLNAND: mpz_and(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; case BOOLNOR: mpz_ior(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; case BOOLANDC1:mpz_com(MP(u),MP(ux));mpz_and(MP(u),MP(u),MP(uy));break; case BOOLANDC2:mpz_com(MP(u),MP(uy));mpz_and(MP(u),MP(ux),MP(u));break; case BOOLORC1: mpz_com(MP(u),MP(ux));mpz_ior(MP(u),MP(u),MP(uy));break; case BOOLORC2: mpz_com(MP(u),MP(uy));mpz_ior(MP(u),MP(ux),MP(u));break; default:break;/*FIXME error*/ } return u; } object log_op2(fixnum op,object x,object y) { enum type tx=type_of(x),ty=type_of(y); if (tx==t_fixnum && ty==t_fixnum) return make_fixnum(fixnum_log_op2(op,fix(x),fix(y))); else return maybe_replace_big(integer_log_op2(op,x,tx,y,ty)); } static object log_op(fixnum op) { fixnum i,n=vs_top-vs_base,fx=0; enum type tx,ty; object x,y; if ((tx=type_of(x=vs_base[0]))==t_fixnum) {fx=fix(x);x=OBJNULL;} for (i=1;i= 0) { return mpz_popcount(x); } else { object u = new_bignum(); mpz_com(MP(u),x); return mpz_popcount(MP(u)); } } static int mpz_bitlength(__mpz_struct *x) { if (mpz_sgn(x) >= 0) { return mpz_sizeinbase(x,2); } else { object u = new_bignum(); mpz_com(MP(u),x); return mpz_sizeinbase(MP(u),2); } } gcl-2.6.14/o/typespec.c0000755000175000017500000002206414360276512013240 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* typespec.c type specifier routines */ #define NEED_MP_H #include "include.h" object sLkeyword; enum type t_vtype; int vtypep_fn(object x) {return type_of(x)==t_vtype;} LFD(Ltype_of)(void) { int i; check_arg(1); switch (type_of(vs_base[0])) { case t_fixnum: vs_base[0] = sLfixnum; break; case t_bignum: vs_base[0] = sLbignum; break; case t_ratio: vs_base[0] = sLratio; break; case t_shortfloat: vs_base[0] = sLshort_float; break; case t_longfloat: vs_base[0] = sLlong_float; break; case t_complex: vs_base[0] = sLcomplex; break; case t_character: if (char_font(vs_base[0]) != 0 || char_bits(vs_base[0]) != 0) vs_base[0] = sLcharacter; else { i = char_code(vs_base[0]); if ((' ' <= i && i < '\177') || i == '\n') vs_base[0] = sLstandard_char; else vs_base[0] = sLcharacter; } break; case t_symbol: if (vs_base[0]->s.s_hpack == keyword_package) vs_base[0] = sLkeyword; else vs_base[0] = sLsymbol; break; case t_package: vs_base[0] = sLpackage; break; case t_cons: vs_base[0] = sLcons; break; case t_hashtable: vs_base[0] = sLhash_table; break; case t_array: if (vs_base[0]->a.a_adjustable || vs_base[0]->a.a_displaced->c.c_car == Cnil) vs_base[0] = sLarray; else vs_base[0] = sLsimple_array; break; case t_vector: if (vs_base[0]->v.v_adjustable || vs_base[0]->v.v_hasfillp || vs_base[0]->v.v_displaced->c.c_car == Cnil || (enum aelttype)vs_base[0]->v.v_elttype != aet_object) vs_base[0] = sLvector; else vs_base[0] = sLsimple_vector; break; case t_string: if (vs_base[0]->st.st_adjustable || vs_base[0]->st.st_hasfillp || vs_base[0]->st.st_displaced->c.c_car == Cnil) vs_base[0] = sLstring; else vs_base[0] = sLsimple_string; break; case t_bitvector: if (vs_base[0]->bv.bv_adjustable || vs_base[0]->bv.bv_hasfillp || vs_base[0]->bv.bv_displaced->c.c_car == Cnil) vs_base[0] = sLbit_vector; else vs_base[0] = sLsimple_bit_vector; break; case t_structure: vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; break; case t_stream: #ifdef USER_DEFINED_STREAMS if (vs_base[0]->sm.sm_mode == (int)smm_user_defined) vs_base[0]= vs_base[0]->sm.sm_object1->str.str_self[8]; else #endif vs_base[0] = sLstream; break; case t_readtable: vs_base[0] = sLreadtable; break; case t_pathname: vs_base[0] = sLpathname; break; case t_random: vs_base[0] = sLrandom_state; break; case t_sfun: case t_gfun: case t_cfun: case t_vfun: case t_afun: case t_cclosure: case t_closure: vs_base[0] = sLcompiled_function; break; default: error("not a lisp data object"); } } DEF_ORDINARY("PROCLAIMED-ARG-TYPES",sSproclaimed_arg_types,SI,""); DEF_ORDINARY("PROCLAIMED-RETURN-TYPE",sSproclaimed_return_type,SI,""); DEF_ORDINARY("PROCLAIMED-FUNCTION",sSproclaimed_function,SI,""); DEF_ORDINARY("NULL",sLnull,LISP,""); DEF_ORDINARY("CONS",sLcons,LISP,""); DEF_ORDINARY("LIST",sLlist,LISP,""); DEF_ORDINARY("SYMBOL",sLsymbol,LISP,""); DEF_ORDINARY("ARRAY",sLarray,LISP,""); DEF_ORDINARY("VECTOR",sLvector,LISP,""); DEF_ORDINARY("BIT-VECTOR",sLbit_vector,LISP,""); DEF_ORDINARY("STRING",sLstring,LISP,""); DEF_ORDINARY("SEQUENCE",sLsequence,LISP,""); DEF_ORDINARY("SIMPLE-ARRAY",sLsimple_array,LISP,""); DEF_ORDINARY("SIMPLE-VECTOR",sLsimple_vector,LISP,""); DEF_ORDINARY("SIMPLE-BIT-VECTOR",sLsimple_bit_vector,LISP,""); DEF_ORDINARY("SIMPLE-STRING",sLsimple_string,LISP,""); DEF_ORDINARY("FUNCTION",sLfunction,LISP,""); DEF_ORDINARY("COMPILED-FUNCTION",sLcompiled_function,LISP,""); DEF_ORDINARY("PATHNAME",sLpathname,LISP,""); DEF_ORDINARY("CHARACTER",sLcharacter,LISP,""); DEF_ORDINARY("NUMBER",sLnumber,LISP,""); DEF_ORDINARY("RATIONAL",sLrational,LISP,""); DEF_ORDINARY("FLOAT",sLfloat,LISP,""); DEF_ORDINARY("REAL",sLreal,LISP,""); DEF_ORDINARY("INTEGER",sLinteger,LISP,""); DEF_ORDINARY("RATIO",sLratio,LISP,""); DEF_ORDINARY("SHORT-FLOAT",sLshort_float,LISP,""); DEF_ORDINARY("STANDARD-CHAR",sLstandard_char,LISP,""); DEF_ORDINARY("BOOLEAN",sLboolean,LISP,""); DEF_ORDINARY("FIXNUM",sLfixnum,LISP,""); DEF_ORDINARY("COMPLEX",sLcomplex,LISP,""); DEF_ORDINARY("SINGLE-FLOAT",sLsingle_float,LISP,""); DEF_ORDINARY("PACKAGE",sLpackage,LISP,""); DEF_ORDINARY("BIGNUM",sLbignum,LISP,""); DEF_ORDINARY("RANDOM-STATE",sLrandom_state,LISP,""); DEF_ORDINARY("DOUBLE-FLOAT",sLdouble_float,LISP,""); DEF_ORDINARY("STREAM",sLstream,LISP,""); DEF_ORDINARY("BIT",sLbit,LISP,""); DEF_ORDINARY("READTABLE",sLreadtable,LISP,""); DEF_ORDINARY("LONG-FLOAT",sLlong_float,LISP,""); DEF_ORDINARY("HASH-TABLE",sLhash_table,LISP,""); DEF_ORDINARY("KEYWORD",sLkeyword,LISP,""); DEF_ORDINARY("STRUCTURE",sLstructure,LISP,""); DEF_ORDINARY("SATISFIES",sLsatisfies,LISP,""); DEF_ORDINARY("MEMBER",sLmember,LISP,""); DEF_ORDINARY("NOT",sLnot,LISP,""); DEF_ORDINARY("OR",sLor,LISP,""); DEF_ORDINARY("AND",sLand,LISP,""); DEF_ORDINARY("VALUES",sLvalues,LISP,""); DEF_ORDINARY("MOD",sLmod,LISP,""); DEF_ORDINARY("SIGNED-BYTE",sLsigned_byte,LISP,""); DEF_ORDINARY("UNSIGNED-BYTE",sLunsigned_byte,LISP,""); DEF_ORDINARY("SIGNED-CHAR",sSsigned_char,SI,""); DEF_ORDINARY("UNSIGNED-CHAR",sSunsigned_char,SI,""); DEF_ORDINARY("SIGNED-SHORT",sSsigned_short,SI,""); DEF_ORDINARY("UNSIGNED-SHORT",sSunsigned_short,SI,""); DEF_ORDINARY("*",sLA,LISP,""); DEF_ORDINARY("PLUSP",sLplusp,LISP,""); DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,""); DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,""); DEF_ORDINARY("BASE-STRING",sLbase_string,LISP,""); DEF_ORDINARY("BROADCAST-STREAM",sLbroadcast_stream,LISP,""); DEF_ORDINARY("BUILT-IN-CLASS",sLbuilt_in_class,LISP,""); DEF_ORDINARY("CLASS",sLclass,LISP,""); DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,""); DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,""); DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,""); DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,""); DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,""); DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,""); DEF_ORDINARY("METHOD",sLmethod,LISP,""); /* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */ DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,""); DEF_ORDINARY("STANDARD-CLASS",sLstandard_class,LISP,""); DEF_ORDINARY("STANDARD-GENERIC-FUNCTION",sLstandard_generic_function,LISP,""); DEF_ORDINARY("STANDARD-METHOD",sLstandard_method,LISP,""); DEF_ORDINARY("STANDARD-OBJECT",sLstandard_object,LISP,""); DEF_ORDINARY("STRING-STREAM",sLstring_stream,LISP,""); DEF_ORDINARY("STRUCTURE-CLASS",sLstructure_class,LISP,""); DEF_ORDINARY("STRUCTURE-OBJECT",sLstructure_object,LISP,""); DEF_ORDINARY("SYNONYM-STREAM",sLsynonym_stream,LISP,""); DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,""); DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character"); DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer"); void gcl_init_typespec(void) { } void gcl_init_typespec_function(void) { TSor_symbol_string=make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil))); enter_mark_origin(&TSor_symbol_string); TSor_string_symbol=make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil))); enter_mark_origin(&TSor_string_symbol); TSor_symbol_string_package=make_cons(sLor,make_cons(sLsymbol,make_cons(sLstring,make_cons(sLpackage, Cnil)))); enter_mark_origin(&TSor_symbol_string_package); TSnon_negative_integer= make_cons(sLinteger,make_cons(make_fixnum(0), make_cons(sLA, Cnil))); enter_mark_origin(&TSnon_negative_integer); TSpositive_number=make_cons(sLsatisfies, make_cons(sLplusp, Cnil)); enter_mark_origin(&TSpositive_number); TSor_integer_float=make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil))); enter_mark_origin(&TSor_integer_float); TSor_rational_float=make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil))); enter_mark_origin(&TSor_rational_float); #ifdef UNIX TSor_pathname_string_symbol=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,Cnil)))); enter_mark_origin(&TSor_pathname_string_symbol); #endif TSor_pathname_string_symbol_stream=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,make_cons(sLstream,Cnil))))); enter_mark_origin(&TSor_pathname_string_symbol_stream); make_function("TYPE-OF", Ltype_of); } gcl-2.6.14/o/littleXwin.c0000755000175000017500000001520214360276512013543 0ustar cammcamm/**************************************************************/ #include #include /* the X library */ #include /* the X library */ /* a few arbitary constants */ #define START_X 10 #define START_Y 20 #define WINDOW_WIDTH 225 #define WINDOW_HEIGHT 400 #define BORDER_WIDTH 1 #define KEY_STR_LENGTH 20 Display *the_display; /* the display that will be used */ int the_screen; /* the screen that will be used */ Window root_window; /* the root window on the screen */ XSizeHints size_hints; /* size hints for the window manager */ XEvent the_event; /* the structure for the input event */ XSetWindowAttributes attributes;/* the windows attributes */ GC the_solid_GC, the_clear_GC; /* the graphics contexts */ XGCValues the_solid_GC_values, the_clear_GC_values; Colormap cmap; XFontStruct *the_fontstruct; /* the font info to be used */ Window open_window(void) { Window the_window; /* the window that will be opened */ int i, stop; /* Set the display to be the default display (ie, your display as given in the environment variable DISPLAY). */ if ((the_display = XOpenDisplay("")) == NULL) { printf("can't open display\n"); return(-1); } /* A few useful values. */ the_screen = DefaultScreen(the_display); root_window = RootWindow(the_display,the_screen); /* Set the size hints for the window manager. */ size_hints.x = START_X; size_hints.y = START_Y; size_hints.width = WINDOW_WIDTH; size_hints.height = WINDOW_HEIGHT; size_hints.flags = PSize|PPosition; /* Create a window of fixed size, origin, and borderwidth. The window will have a black border and white background. */ the_window = XCreateSimpleWindow(the_display,root_window, size_hints.x,size_hints.y,size_hints.width, size_hints.height,BORDER_WIDTH, BlackPixel(the_display,the_screen), WhitePixel(the_display,the_screen)); XSetStandardProperties(the_display,the_window,"My Window","My Icon", None,NULL,NULL,&size_hints); cmap = DefaultColormap(the_display, the_screen); the_solid_GC = XCreateGC(the_display, the_window, None, &the_solid_GC_values); the_clear_GC = XCreateGC(the_display, the_window, None, &the_clear_GC_values); /* for a sun */ XSetBackground(the_display, the_solid_GC, BlackPixel(the_display,the_screen)); XSetForeground(the_display, the_solid_GC, BlackPixel(the_display,the_screen)); XSetBackground(the_display, the_clear_GC, WhitePixel(the_display,the_screen)); XSetForeground(the_display, the_clear_GC, WhitePixel(the_display,the_screen)); if ((the_fontstruct = XLoadQueryFont(the_display,"8x13")) == NULL) { printf("could not open font\n"); return(-1); } /* Put the font into the graphics context for draw operations. */ XSetFont(the_display, the_solid_GC, the_fontstruct->fid); XSetFont(the_display, the_clear_GC, the_fontstruct->fid); /* Tell the server to make the window visible. */ XMapWindow(the_display,the_window); attributes.bit_gravity = NorthWestGravity; XChangeWindowAttributes(the_display, the_window, CWBitGravity, &attributes); XFlush(the_display); return(the_window); } int close_window(Window the_window) { XDestroyWindow(the_display, the_window); XFlush(the_display); return(1); } int draw_line(Window the_window, int x1, int y1, int x2, int y2) { XDrawLine(the_display, the_window, the_solid_GC, x1, y1, x2, y2); XFlush(the_display); return(1); } int draw_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) { XDrawArc(the_display, the_window, the_solid_GC, x, y, width, height, angle1, angle2); XFlush(the_display); return(1); } int fill_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) { XFillArc(the_display, the_window, the_solid_GC, x, y, width, height, angle1, angle2); XFlush(the_display); return(1); } int clear_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) { XFillArc(the_display, the_window, the_clear_GC, x, y, width, height, angle1, angle2); XFlush(the_display); return(1); } int set_arc_mode (int pie_or_chord) { if (pie_or_chord == 0) { XSetArcMode(the_display, the_solid_GC, ArcChord); XSetArcMode(the_display, the_clear_GC, ArcChord); } else { XSetArcMode(the_display, the_solid_GC, ArcPieSlice); XSetArcMode(the_display, the_clear_GC, ArcPieSlice); } return(1); } int erase_line(Window the_window, int x1, int y1, int x2, int y2) { XDrawLine(the_display, the_window, the_clear_GC, x1, y1, x2, y2); XFlush(the_display); return(1); } int draw_text(Window the_window, char *string, int x, int y) { XDrawString(the_display, the_window, the_solid_GC, x, y, string, strlen(string)); XFlush(the_display); return(1); } int erase_text(Window the_window, char *string, int x, int y) { XDrawString(the_display, the_window, the_clear_GC, x, y, string, strlen(string)); XFlush(the_display); return(1); } int clear_window(Window the_window) { XClearWindow(the_display, the_window); XFlush(the_display); return(1); } int resize_window(Window the_window, int width, int height) { XResizeWindow(the_display, the_window, width, height); XFlush(the_display); return(1); } int raise_window(Window the_window) { XRaiseWindow(the_display, the_window); XFlush(the_display); return(1); } int use_font (char *font_name) { if ((the_fontstruct = XLoadQueryFont(the_display, font_name)) == NULL) return(-1); /* Put the font into the graphics context for draw operations. */ XSetFont(the_display, the_solid_GC, the_fontstruct->fid); XSetFont(the_display, the_clear_GC, the_fontstruct->fid); XFlush(the_display); return(1); } int set_background (Window the_window, char *color_string) { XColor color; int result; if (result = XParseColor(the_display, cmap, color_string, &color)) { if (result = XAllocColor(the_display, cmap, &color)) { XSetWindowBackground(the_display, the_window, color.pixel); XSetBackground(the_display, the_clear_GC, color.pixel); XSetForeground(the_display, the_clear_GC, color.pixel); XFlush(the_display); } } return(result); } int set_foreground (char *color_string) { XColor color; int result; if (result = XParseColor(the_display, cmap, color_string, &color)) { if (result = XAllocColor(the_display, cmap, &color)) { XSetForeground(the_display, the_solid_GC, color.pixel); XSetBackground(the_display, the_solid_GC, color.pixel); XFlush(the_display); return(1); } } } gcl-2.6.14/o/unexnt.c0000755000175000017500000010211614360276512012722 0ustar cammcamm/* unexec for GNU Emacs on Windows NT. Copyright (C) 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Geoff Voelker (voelker@cs.washington.edu) 8-12-94 */ /* #include "gclincl.h" */ #ifndef UNIXSAVE #include #endif /* #include */ /* _fmode */ /* in case the include of config.h defined it */ #undef va_start #include #include #include #include #include /* strrchr */ #ifdef _GNU_H_WINDOWS_H #include "cyglacks.h" #endif /* Include relevant definitions from IMAGEHLP.H, which can be found in \\win32sdk\mstools\samples\image\include\imagehlp.h. */ PIMAGE_NT_HEADERS (__stdcall * pfnCheckSumMappedFile) (LPVOID BaseAddress, DWORD FileLength, LPDWORD HeaderSum, LPDWORD CheckSum); #include #include #include "ntheap.h" /* Info for keeping track of our heap. */ unsigned char *data_region_base = UNINIT_PTR; unsigned char *data_region_end = UNINIT_PTR; unsigned char *real_data_region_end = UNINIT_PTR; unsigned long data_region_size = UNINIT_LONG; unsigned long reserved_heap_size = UNINIT_LONG; extern BOOL ctrl_c_handler (unsigned long type); extern char my_begdata[]; extern char my_edata[]; extern char my_begbss[]; extern char my_endbss[]; extern char *my_begbss_static; extern char *my_endbss_static; #include "ntheap.h" enum { HEAP_UNINITIALIZED = 1, HEAP_UNLOADED, HEAP_LOADED }; /* Basically, our "initialized" flag. */ int heap_state = HEAP_UNINITIALIZED; /* So we can find our heap in the file to recreate it. */ unsigned long heap_index_in_executable = UNINIT_LONG; static void get_section_info (file_data *p_file); static void copy_executable_and_dump_data_section (file_data *, file_data *); static void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile); /* Cached info about the .data section in the executable. */ PUCHAR data_start_va = UNINIT_PTR; DWORD data_start_file = UNINIT_LONG; DWORD data_size = UNINIT_LONG; /* Cached info about the .bss section in the executable. */ PUCHAR bss_start = UNINIT_PTR; DWORD bss_size = UNINIT_LONG; void recreate_heap1() { char executable_path[MAX_PATH]; if (heap_state == HEAP_UNLOADED) { if (GetModuleFileName (NULL, executable_path, MAX_PATH) == 0) { printf ("Failed to find path for executable.\n"); do_gcl_abort(); } recreate_heap (executable_path); } heap_state = HEAP_LOADED; } #ifdef HAVE_NTGUI HINSTANCE hinst = NULL; HINSTANCE hprevinst = NULL; LPSTR lpCmdLine = ""; int nCmdShow = 0; #endif /* HAVE_NTGUI */ #ifndef UNIXSAVE /* Startup code for running on NT. When we are running as the dumped version, we need to bootstrap our heap and .bss section into our address space before we can actually hand off control to the startup code supplied by NT (primarily because that code relies upon malloc ()). */ void _start (void) { extern void mainCRTStartup (void); #if 0 /* Give us a way to debug problems with crashes on startup when running under the MSVC profiler. */ if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0) DebugBreak (); #endif /* Cache system info, e.g., the NT page size. */ cache_system_info (); /* If we're a dumped version of emacs then we need to recreate our heap and play tricks with our .bss section. Do this before start up. (WARNING: Do not put any code before this section that relies upon malloc () and runs in the dumped version. It won't work.) */ if (heap_state == HEAP_UNLOADED) { char executable_path[MAX_PATH]; if (GetModuleFileName (NULL, executable_path, MAX_PATH) == 0) { printf ("Failed to find path for executable.\n"); do_gcl_abort(); } #if 1 /* To allow profiling, make sure executable_path names the .exe file, not the ._xe file created by the profiler which contains extra code that makes the stored exe offsets incorrect. (This will not be necessary when unexec properly extends the .bss (or .data as appropriate) section to include the dumped bss data, and dumps the heap into a proper section of its own.) */ { char * p = strrchr (executable_path, '.'); if (p && p[1] == '_') p[1] = 'e'; } /* Using HiProf profiler, exe name is different still. */ { char * p = strrchr (executable_path, '\\'); strcpy (p, "\\emacs.exe"); } #endif recreate_heap (executable_path); heap_state = HEAP_LOADED; } else { /* Grab our malloc arena space now, before CRT starts up. */ sbrk (0); } /* The default behavior is to treat files as binary and patch up text files appropriately, in accordance with the MSDOS code. */ _fmode = O_BINARY; /* This prevents ctrl-c's in shells running while we're suspended from having us exit. */ SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE); /* Invoke the NT CRT startup routine now that our housecleaning is finished. */ #ifdef HAVE_NTGUI /* determine WinMain args like crt0.c does */ hinst = GetModuleHandle(NULL); lpCmdLine = GetCommandLine(); nCmdShow = SW_SHOWDEFAULT; #endif mainCRTStartup (); } #endif /* UNIXSAVE */ #ifdef __CYGWIN__ #include #endif /* Dump out .data and .bss sections into a new executable. */ void unexec (char *new_name, char *old_name, void *start_data, void *start_bss, void *entry_address) { #ifdef __CYGWIN__ static file_data in_file, out_file; char out_filename[MAX_PATH], in_filename[MAX_PATH]; char filename[MAX_PATH]; unsigned long size; char *ptr; fflush (stdin); /* copy_stdin = *stdin; */ setvbuf(stdin,0,_IONBF,0); setvbuf(stdout,0,_IONBF,0); /* stdin->_data->__sdidinit = 0; */ if (!get_allocation_unit()) cache_system_info (); /* Make sure that the input and output filenames have the ".exe" extension...patch them up if they don't. */ ptr = old_name + strlen (old_name) - 4; strcpy(filename, old_name); strcat(filename, (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE"))?".exe":""); cygwin_conv_path(CCP_POSIX_TO_WIN_A,filename,in_filename,sizeof(in_filename)); ptr = new_name + strlen (new_name) - 4; strcpy(filename, new_name); strcat(filename, (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE"))?".exe":""); cygwin_conv_path(CCP_POSIX_TO_WIN_A,filename,out_filename,sizeof(out_filename)); #else static file_data in_file, out_file; char out_filename[MAX_PATH], in_filename[MAX_PATH]; unsigned long size; char *ptr; fflush (stdin); /* copy_stdin = *stdin; */ setvbuf(stdin,0,_IONBF,0); setvbuf(stdout,0,_IONBF,0); /* stdin->_data->__sdidinit = 0; */ if (!get_allocation_unit()) cache_system_info (); /* Make sure that the input and output filenames have the ".exe" extension...patch them up if they don't. */ strcpy (in_filename, old_name); ptr = in_filename + strlen (in_filename) - 4; if (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE") ) strcat (in_filename, ".exe"); strcpy (out_filename, new_name); ptr = out_filename + strlen (out_filename) - 4; if (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE") ) strcat (out_filename, ".exe"); #endif /* printf ("Dumping from %s\n", in_filename); */ /* printf (" to %s\n", out_filename); */ /* We need to round off our heap to NT's allocation unit (64KB). */ round_heap (get_allocation_unit ()); /* Open the undumped executable file. */ if (!open_input_file (&in_file, in_filename)) { printf ("Failed to open %s (%u)...bailing.\n", in_filename, (unsigned)GetLastError ()); do_gcl_abort(); } /* Get the interesting section info, like start and size of .bss... */ get_section_info (&in_file); /* The size of the dumped executable is the size of the original executable plus the size of the heap and the size of the .bss section. */ if (heap_index_in_executable==UNINIT_LONG) heap_index_in_executable = (unsigned long) round_to_next ((unsigned char *) in_file.size, get_allocation_unit ()); /* from lisp we know what to use */ #ifdef IN_UNIXSAVE data_region_end = round_to_next((unsigned char *)core_end,0x10000); real_data_region_end = data_region_end; #endif size = heap_index_in_executable + get_committed_heap_size () + bss_size; if (!open_output_file (&out_file, out_filename, size)) { printf ("Failed to open %s (%u)...bailing.\n", out_filename, (unsigned)GetLastError ()); do_gcl_abort(); } /* Set the flag (before dumping). */ heap_state = HEAP_UNLOADED; copy_executable_and_dump_data_section (&in_file, &out_file); dump_bss_and_heap (&in_file, &out_file); /* Patch up header fields; profiler is picky about this. */ { PIMAGE_DOS_HEADER dos_header; PIMAGE_NT_HEADERS nt_header; HANDLE hImagehelp = LoadLibrary ("imagehlp.dll"); DWORD headersum; DWORD checksum; dos_header = (PIMAGE_DOS_HEADER) out_file.file_base; nt_header = (PIMAGE_NT_HEADERS) ((char *) dos_header + dos_header->e_lfanew); nt_header->OptionalHeader.SizeOfStackReserve=0x800000; /* nt_header->OptionalHeader.SizeOfHeapReserve=0x80000000; */ /* nt_header->OptionalHeader.SizeOfHeapCommit=0x80000000; */ nt_header->OptionalHeader.CheckSum = 0; // nt_header->FileHeader.TimeDateStamp = time (NULL); // dos_header->e_cp = size / 512; // nt_header->OptionalHeader.SizeOfImage = size; pfnCheckSumMappedFile = (void *) GetProcAddress (hImagehelp, "CheckSumMappedFile"); if (pfnCheckSumMappedFile) { // nt_header->FileHeader.TimeDateStamp = time (NULL); pfnCheckSumMappedFile (out_file.file_base, out_file.size, &headersum, &checksum); nt_header->OptionalHeader.CheckSum = checksum; } FreeLibrary (hImagehelp); } close_file_data (&in_file); close_file_data (&out_file); } /* File handling. */ int open_input_file (file_data *p_file, char *filename) { HANDLE file; HANDLE file_mapping; void *file_base; DWORD size, upper_size; file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) return FALSE; size = GetFileSize (file, &upper_size); file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY, 0, size, NULL); if (!file_mapping) return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size); if (file_base == 0) return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; return TRUE; } int open_output_file (file_data *p_file, char *filename, unsigned long size) { HANDLE file; HANDLE file_mapping; void *file_base; file = CreateFile (filename, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) return FALSE; file_mapping = CreateFileMapping (file, NULL, PAGE_READWRITE, 0, size, NULL); if (!file_mapping) return FALSE; file_base = MapViewOfFile (file_mapping, FILE_MAP_WRITE, 0, 0, size); if (file_base == 0) return FALSE; p_file->name = filename; p_file->size = size; p_file->file = file; p_file->file_mapping = file_mapping; p_file->file_base = file_base; return TRUE; } /* Close the system structures associated with the given file. */ void close_file_data (file_data *p_file) { UnmapViewOfFile (p_file->file_base); CloseHandle (p_file->file_mapping); CloseHandle (p_file->file); } /* Routines to manipulate NT executable file sections. */ #ifdef SEPARATE_BSS_SECTION static void get_bss_info_from_map_file (file_data *p_infile, PUCHAR *p_bss_start, DWORD *p_bss_size) { int n, start, len; char map_filename[MAX_PATH]; char buffer[256]; FILE *map; /* Overwrite the .exe extension on the executable file name with the .map extension. */ strcpy (map_filename, p_infile->name); n = strlen (map_filename) - 3; strcpy (&map_filename[n], "map"); map = fopen (map_filename, "r"); if (!map) { printf ("Failed to open map file %s, error %d...bailing out.\n", map_filename, GetLastError ()); do_gcl_abort(); } while (fgets (buffer, sizeof (buffer), map)) { if (!(strstr (buffer, ".bss") && strstr (buffer, "DATA"))) continue; n = sscanf (buffer, " %*d:%x %x", &start, &len); if (n != 2) { printf ("Failed to scan the .bss section line:\n%s", buffer); do_gcl_abort(); } break; } *p_bss_start = (PUCHAR) start; *p_bss_size = (DWORD) len; } #endif unsigned long get_section_size (PIMAGE_SECTION_HEADER p_section) { /* The true section size, before rounding. Some linkers swap the meaning of these two values. */ return min (p_section->SizeOfRawData, p_section->Misc.VirtualSize); } /* Return pointer to section header for named section. */ IMAGE_SECTION_HEADER * find_section (char * name, IMAGE_NT_HEADERS * nt_header) { PIMAGE_SECTION_HEADER section; int i; section = IMAGE_FIRST_SECTION (nt_header); for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) { if (strcmp ((char *)section->Name, name) == 0) return section; section++; } return NULL; } /* Return pointer to section header for section containing the given relative virtual address. */ IMAGE_SECTION_HEADER * rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header) { PIMAGE_SECTION_HEADER section; int i; section = IMAGE_FIRST_SECTION (nt_header); for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) { if (rva >= section->VirtualAddress && rva < section->VirtualAddress + section->SizeOfRawData) return section; section++; } return NULL; } /* Flip through the executable and cache the info necessary for dumping. */ static void get_section_info (file_data *p_infile) { PIMAGE_DOS_HEADER dos_header; PIMAGE_NT_HEADERS nt_header; PIMAGE_SECTION_HEADER section, data_section; unsigned char *ptr; int i; dos_header = (PIMAGE_DOS_HEADER) p_infile->file_base; if (dos_header->e_magic != IMAGE_DOS_SIGNATURE) { printf ("Unknown EXE header in %s...bailing.\n", p_infile->name); do_gcl_abort(); } nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) dos_header) + dos_header->e_lfanew); if (nt_header == NULL) { printf ("Failed to find IMAGE_NT_HEADER in %s...bailing.\n", p_infile->name); do_gcl_abort(); } /* Check the NT header signature ... */ if (nt_header->Signature != IMAGE_NT_SIGNATURE) { printf ("Invalid IMAGE_NT_SIGNATURE 0x%x in %s...bailing.\n", (int)nt_header->Signature, p_infile->name); } /* Flip through the sections for .data and .bss ... */ section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (nt_header); for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) { #ifdef SEPARATE_BSS_SECTION if (!strcmp (section->Name, ".bss")) { /* The .bss section. */ ptr = (char *) nt_header->OptionalHeader.ImageBase + section->VirtualAddress; bss_start = ptr; bss_size = get_section_size (section); } #endif #if 0 if (!strcmp (section->Name, ".data")) { /* From lastfile.c */ extern char my_edata[]; /* The .data section. */ data_section = section; ptr = (char *) nt_header->OptionalHeader.ImageBase + section->VirtualAddress; data_start_va = ptr; data_start_file = section->PointerToRawData; /* We want to only write Emacs data back to the executable, not any of the library data (if library data is included, then a dumped Emacs won't run on system versions other than the one Emacs was dumped on). */ data_size = my_edata - data_start_va; } #else #ifdef emacs #define DATA_SECTION "EMDATA" #else #define DATA_SECTION ".data" #endif if (!strcmp ((char *)section->Name, DATA_SECTION)) { /* The Emacs initialized data section. */ data_section = section; ptr = (unsigned char *) nt_header->OptionalHeader.ImageBase + section->VirtualAddress; data_start_va = ptr; data_start_file = section->PointerToRawData; /* Write back the full section. */ data_size = get_section_size (section); } #endif section++; } #ifdef SEPARATE_BSS_SECTION if (bss_start == UNINIT_PTR && bss_size == UNINIT_LONG) { /* Starting with MSVC 4.0, the .bss section has been eliminated and appended virtually to the end of the .data section. Our only hint about where the .bss section starts in the address comes from the SizeOfRawData field in the .data section header. Unfortunately, this field is only approximate, as it is a rounded number and is typically rounded just beyond the start of the .bss section. To find the start and size of the .bss section exactly, we have to peek into the map file. */ get_bss_info_from_map_file (p_infile, &ptr, &bss_size); bss_start = ptr + nt_header->OptionalHeader.ImageBase + data_section->VirtualAddress; } #else /* As noted in lastfile.c, the Alpha (but not the Intel) MSVC linker globally segregates all static and public bss data (ie. across all linked modules, not just per module), so we must take both static and public bss areas into account to determine the true extent of the bss area used by Emacs. To be strictly correct, we should dump the static and public bss areas used by Emacs separately if non-overlapping (since otherwise we are dumping bss data belonging to system libraries, eg. the static bss system data on the Alpha). However, in practice this doesn't seem to matter, since presumably the system libraries always reinitialize their bss variables. */ bss_start = (unsigned char *)min (my_begbss, my_begbss_static); bss_size = max ((char *)my_endbss, (char *) my_endbss_static) - (char *) bss_start; #endif } /* The dump routines. */ static void copy_executable_and_dump_data_section (file_data *p_infile, file_data *p_outfile) { unsigned char *data_file, *data_va; unsigned long size, index; /* Get a pointer to where the raw data should go in the executable file. */ data_file = (unsigned char *) p_outfile->file_base + data_start_file; /* Get a pointer to the raw data in our address space. */ data_va = data_start_va; size = (unsigned long) data_file - (unsigned long) p_outfile->file_base; /* printf ("Copying executable up to data section...\n"); */ /* printf ("\t0x%08x Offset in input file.\n", 0); */ /* printf ("\t0x%08x Offset in output file.\n", 0); */ /* printf ("\t0x%08lx Size in bytes.\n", size); */ memcpy (p_outfile->file_base, p_infile->file_base, size); size = data_size; /* printf ("Dumping .data section...\n"); */ /* printf ("\t0x%p Address in process.\n", data_va); */ /* printf ("\t0x%08x Offset in output file.\n", */ /* data_file - p_outfile->file_base); */ /* printf ("\t0x%08lx Size in bytes.\n", size); */ memcpy (data_file, data_va, size); index = (unsigned long) data_file + size - (unsigned long) p_outfile->file_base; size = p_infile->size - index; /* printf ("Copying rest of executable...\n"); */ /* printf ("\t0x%08lx Offset in input file.\n", index); */ /* printf ("\t0x%08lx Offset in output file.\n", index); */ /* printf ("\t0x%08lx Size in bytes.\n", size); */ memcpy ((char *) p_outfile->file_base + index, (char *) p_infile->file_base + index, size); } static void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile) { unsigned char *heap_data, *bss_data; unsigned long size, index; /* printf ("Dumping heap into executable...\n"); */ index = heap_index_in_executable; size = get_committed_heap_size (); heap_data = get_heap_start (); /* printf ("\t0x%p Heap start in process.\n", heap_data); */ /* printf ("\t0x%08lx Heap offset in executable.\n", index); */ /* printf ("\t0x%08lx Heap size in bytes.\n", size); */ memcpy ((PUCHAR) p_outfile->file_base + index, heap_data, size); /* printf ("Dumping .bss into executable...\n"); */ index += size; size = bss_size; bss_data = bss_start; /* printf ("\t0x%p BSS start in process.\n", bss_data); */ /* printf ("\t0x%08lx BSS offset in executable.\n", index); */ /* printf ("\t0x%08lx BSS size in bytes.\n", size); */ memcpy ((char *) p_outfile->file_base + index, bss_data, size); } /* Reload and remap routines. */ /* Load the dumped .bss section into the .bss area of our address space. */ void read_in_bss (char *filename) { HANDLE file; DWORD index, n_read; int i; file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) { i = GetLastError (); do_gcl_abort(); } /* Seek to where the .bss section is tucked away after the heap... */ index = heap_index_in_executable + get_committed_heap_size (); if (SetFilePointer (file, index, NULL, FILE_BEGIN) == 0xFFFFFFFF) { i = GetLastError (); do_gcl_abort(); } /* Ok, read in the saved .bss section and initialize all uninitialized variables. */ if (!ReadFile (file, bss_start, bss_size, &n_read, (void *)NULL)) { i = GetLastError (); do_gcl_abort(); } CloseHandle (file); } /* Map the heap dumped into the executable file into our address space. */ void map_in_heap (char *filename) { HANDLE file; HANDLE file_mapping; void *file_base; DWORD size, upper_size, n_read; int i; file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if (file == INVALID_HANDLE_VALUE) { i = GetLastError (); do_gcl_abort(); } size = GetFileSize (file, &upper_size); file_mapping = CreateFileMapping (file, NULL, PAGE_WRITECOPY, 0, size, NULL); if (!file_mapping) { i = GetLastError (); do_gcl_abort(); } size = get_committed_heap_size (); file_base = MapViewOfFileEx (file_mapping, FILE_MAP_ALL_ACCESS, 0, heap_index_in_executable, size, get_heap_start ()); if (file_base != 0) { return; } /* If we don't succeed with the mapping, then copy from the data into the heap. */ CloseHandle (file_mapping); if (VirtualAlloc (get_heap_start (), get_committed_heap_size (), MEM_COMMIT, PAGE_EXECUTE_READWRITE) == NULL) { i = GetLastError (); do_gcl_abort(); } /* Seek to the location of the heap data in the executable. */ i = heap_index_in_executable; if (SetFilePointer (file, i, NULL, FILE_BEGIN) == 0xFFFFFFFF) { i = GetLastError (); do_gcl_abort(); } /* Read in the data. */ if (!ReadFile (file, get_heap_start (), get_committed_heap_size (), &n_read, (void *)NULL)) { i = GetLastError (); do_gcl_abort(); } CloseHandle (file); } /* ntheap.c */ /* Heap management routines for GNU Emacs on Windows NT. Copyright (C) 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Geoff Voelker (voelker@cs.washington.edu) 7-29-94 */ /* */ /* #include "lisp.h" */ /* for VALMASK */ #define VALMASK -1 /* try for 500 MB of address space */ #define VALBITS 29 /* This gives us the page size and the size of the allocation unit on NT. */ SYSTEM_INFO sysinfo_cache; unsigned long syspage_mask = 0; /* These are defined to get Emacs to compile, but are not used. */ int edata; int etext; /* The major and minor versions of NT. */ int nt_major_version; int nt_minor_version; /* Distinguish between Windows NT and Windows 95. */ int os_subtype; /* Cache information describing the NT system for later use. */ void cache_system_info (void) { union { struct info { char major; char minor; short platform; } info; DWORD data; } version; /* Cache the version of the operating system. */ version.data = GetVersion (); nt_major_version = version.info.major; nt_minor_version = version.info.minor; if (version.info.platform & 0x8000) os_subtype = OS_WIN95; else os_subtype = OS_NT; /* Cache page size, allocation unit, processor type, etc. */ GetSystemInfo (&sysinfo_cache); syspage_mask = sysinfo_cache.dwPageSize - 1; } /* Round ADDRESS up to be aligned with ALIGN. */ unsigned char * round_to_next (unsigned char *address, unsigned long align) { unsigned long tmp; tmp = (unsigned long) address; tmp = (tmp + align - 1) / align; return (unsigned char *) (tmp * align); } /* The start of the data segment. */ unsigned char * get_data_start (void) { return data_region_base; } /* The end of the data segment. */ unsigned char * get_data_end (void) { return data_region_end; } void * probe_base(void *base,unsigned long try,unsigned long inc,unsigned long c) { void *r; if (!(r=VirtualAlloc(base,try,MEM_RESERVE,PAGE_NOACCESS))) return probe_base(base+inc,try,inc,c+1); VirtualFree (r, 0, MEM_RELEASE); return !c || inc<2 ? base : probe_base(base-inc,try,inc>>1,c+1); } unsigned long probe_heap_size(void *base,unsigned long try,unsigned long inc) { void *r; if (!(r=VirtualAlloc(base,try,MEM_RESERVE,PAGE_NOACCESS))) return inc<2 ? try-inc : probe_heap_size(base,try-inc,inc>>1); VirtualFree (r, 0, MEM_RELEASE); return probe_heap_size(base,try+inc,inc); } static char * allocate_heap (void) { /* The base address for our GNU malloc heap is chosen in conjuction with the link settings for temacs.exe which control the stack size, the initial default process heap size and the executable image base address. The link settings and the malloc heap base below must all correspond; the relationship between these values depends on how NT and Win95 arrange the virtual address space for a process (and on the size of the code and data segments in temacs.exe). The most important thing is to make base address for the executable image high enough to leave enough room between it and the 4MB floor of the process address space on Win95 for the primary thread stack, the process default heap, and other assorted odds and ends (eg. environment strings, private system dll memory etc) that are allocated before temacs has a chance to grab its malloc arena. The malloc heap base can then be set several MB higher than the executable image base, leaving enough room for the code and data segments. Because some parts of Emacs can use rather a lot of stack space (for instance, the regular expression routines can potentially allocate several MB of stack space) we allow 8MB for the stack. Allowing 1MB for the default process heap, and 1MB for odds and ends, we can base the executable at 16MB and still have a generous safety margin. At the moment, the executable has about 810KB of code (for x86) and about 550KB of data - on RISC platforms the code size could be roughly double, so if we allow 4MB for the executable we will have plenty of room for expansion. Thus we would like to set the malloc heap base to 20MB. However, Win95 refuses to allocate the heap starting at this address, so we set the base to 27MB to make it happy. Since Emacs now leaves 28 bits available for pointers, this lets us use the remainder of the region below the 256MB line for our malloc arena - 229MB is still a pretty decent arena to play in! */ void *base,*ptr; unsigned long min=PAGESIZE,inc=(1UL<<31); #if defined(__CYGWIN__) ptr=my_endbss; #else ptr=(void *)0x5000000; #endif base=probe_base(ptr,min,(unsigned long)my_endbss,0); reserved_heap_size=probe_heap_size(base,inc+min,inc); ptr = VirtualAlloc ((void *) base,get_reserved_heap_size (),MEM_RESERVE,PAGE_NOACCESS); /* printf("probe results: %lu at %p\n",reserved_heap_size,ptr); */ DBEGIN = (DBEGIN_TY) ptr; return ptr; } /* Emulate Unix sbrk. */ void * sbrk (ptrdiff_t increment) { void *result; long size = (long) increment; /* Allocate our heap if we haven't done so already. */ if (data_region_base == UNINIT_PTR) { data_region_base = (unsigned char *)allocate_heap (); if (!data_region_base) return NULL; /* Ensure that the addresses don't use the upper tag bits since the Lisp type goes there. */ if (((unsigned long) data_region_base & ~VALMASK) != 0) { printf ("Error: The heap was allocated in upper memory.\n"); do_gcl_abort(); } data_region_end = data_region_base; real_data_region_end = data_region_end; data_region_size = get_reserved_heap_size (); } result = data_region_end; /* If size is negative, shrink the heap by decommitting pages. */ if (size < 0) { int new_size; unsigned char *new_data_region_end; size = -size; /* Sanity checks. */ if ((data_region_end - size) < data_region_base) return NULL; /* We can only decommit full pages, so allow for partial deallocation [cga]. */ new_data_region_end = (data_region_end - size); new_data_region_end = (unsigned char *) ((long) (new_data_region_end + syspage_mask) & ~syspage_mask); new_size = real_data_region_end - new_data_region_end; real_data_region_end = new_data_region_end; if (new_size > 0) { /* Decommit size bytes from the end of the heap. */ if (!VirtualFree (real_data_region_end, new_size, MEM_DECOMMIT)) return NULL; } data_region_end -= size; } /* If size is positive, grow the heap by committing reserved pages. */ else if (size > 0) { /* Sanity checks. */ if ((data_region_end + size) > (data_region_base + get_reserved_heap_size ())) return NULL; /* Commit more of our heap. */ if (VirtualAlloc (data_region_end, size, MEM_COMMIT, PAGE_EXECUTE_READWRITE) == NULL) return NULL; data_region_end += size; /* We really only commit full pages, so record where the real end of committed memory is [cga]. */ real_data_region_end = (unsigned char *) ((long) (data_region_end + syspage_mask) & ~syspage_mask); } return result; } #ifdef __CYGWIN__ /* Emulate Unix getpagesize. */ int getpagesize (void) { return 4096; } #endif /* Recreate the heap from the data that was dumped to the executable. EXECUTABLE_PATH tells us where to find the executable. */ void recreate_heap (char *executable_path) { unsigned char *tmp; /* First reserve the upper part of our heap. (We reserve first because there have been problems in the past where doing the mapping first has loaded DLLs into the VA space of our heap.) */ tmp = VirtualAlloc ((void *) get_heap_start (), get_reserved_heap_size (), MEM_RESERVE, PAGE_NOACCESS); if (!tmp) do_gcl_abort(); /* We read in the data for the .bss section from the executable first and map in the heap from the executable second to prevent any funny interactions between file I/O and file mapping. */ read_in_bss (executable_path); map_in_heap (executable_path); /* Update system version information to match current system. */ cache_system_info (); } /* Round the heap up to the given alignment. */ void round_heap (unsigned long align) { unsigned long needs_to_be; unsigned long need_to_alloc; needs_to_be = (unsigned long) round_to_next (get_heap_end (), align); need_to_alloc = needs_to_be - (unsigned long) get_heap_end (); if (need_to_alloc) sbrk (need_to_alloc); } #if (_MSC_VER >= 1000) /* MSVC 4.2 invokes these functions from mainCRTStartup to initialize a heap via HeapCreate. They are normally defined by the runtime, but we override them here so that the unnecessary HeapCreate call is not performed. */ int __cdecl _heap_init (void) { /* Stepping through the assembly indicates that mainCRTStartup is expecting a nonzero success return value. */ return 1; } void __cdecl _heap_term (void) #endif #ifdef UNIXSAVE BOOL ctrl_c_handler (unsigned long type) { extern void sigint(void); sigint(); return 0; } #include "save.c" #endif gcl-2.6.14/o/sfasl.c0000755000175000017500000000374214360276512012516 0ustar cammcamm/* Copyright William Schelter. All rights reserved. There is a companion file rsym.c which is used to build a list of the external symbols in a COFF or A.OUT object file, for example saved_kcl. These are loaded into kcl, and the linking is done directly inside kcl. This saves a good deal of time. For example a tiny file foo.o with one definition can be loaded in .04 seconds. This is much faster than previously possible in kcl. The function fasload from unixfasl.c is replaced by the fasload in this file. this file is included in unixfasl.c via #include "../c/sfasl.c" */ /* for testing in standalone manner define STAND You may then compile this file cc -g -DSTAND -DDEBUG -I../hn a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/ will write a /tmp/sfasltest file which you can use comp to compare with one produced by ld. */ #define IN_SFASL /* #ifdef STAND */ /* #include "config.h" */ /* #include "gclincl.h" */ /* #define OUR_ALLOCA alloca */ /* #include */ /* #include "mdefs.h" */ /* #else */ #include "gclincl.h" #include "include.h" #undef S_DATA /* #endif */ #if defined(SPECIAL_RSYM) && !defined(USE_DLOPEN) #include #include "ptable.h" static int node_compare(const void *v1,const void *v2) { const struct node *a1=v1,*a2=v2; return strcmp(a1->string,a2->string); } static struct node * find_sym_ptable(const char *name) { struct node joe; joe.string=name; return bsearch(&joe,c_table.ptable,c_table.length,sizeof(joe),node_compare); } DEFUN_NEW("FIND-SYM-PTABLE",object,fSfind_sym_ptable,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { char c; struct node *a; check_type_string(&x); c=x->st.st_self[x->st.st_fillp]; x->st.st_self[x->st.st_fillp]=0; a=find_sym_ptable(x->st.st_self); x->st.st_self[x->st.st_fillp]=c; return (object)(a ? a->address : 0); } #endif #ifdef SEPARATE_SFASL_FILE #include SEPARATE_SFASL_FILE #else #error must define SEPARATE_SFASL_FILE #endif /* SEPARATE_SFASL_FILE */ gcl-2.6.14/o/regexp.c0000755000175000017500000011020314360276512012667 0ustar cammcamm/* original regexp.c file written by Henry Spencer. many changes made [see below] made by W. Schelter. These changes Copyright (c) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. Various enhancements made by William Schelter when converting for use by GCL: 1) allow case_fold_search: If this variable is not nil, then 'a' and 'A' are considered equivalent. 2) Various speed ups, useful when searching a long string [eg body of a file etc.] Timings searching a 47k byte file for patterns The following table shows how many times longer it took the original implementation, to search for a given pattern. Comparison is also made with the re-search-forward function of gnu emacs. For example in searching for the pattern 'not_there' the search took 20 times longer in the original implementation, and about the same time in gnu emacs. Pattern: current original gnu emacs not_there 1 20 1 not_there|really_not 1 200 30 not_there|really_not|how is[a-z] 1 115 15 not_there|really_not|how is[a-z]y 1 30 4 [a-u]bcdex 1 194 60 a.bcde 1 10 7.5 of a character. 3). Allow string length to be specified, and string not null terminated. If length specified as zero, string assumed null terminated. If string NOT null terminated, then string area must be writable (commonly strings in non writable area are already null terminated..). To do: 1)Still lots of improvement possible: eg the pattern x[^x]*nice_pattern, should be searched for by doing search for nice_pattern, and then backing up. To do easily requires backward search. eg: "FRONT TAIL" search for TAIL and then search back for "FRONT $" 2) do backward search. */ #include #include "string.h" #include "regexp.h" static int min_initial_branch_length(regexp *, unsigned char *, int); /* * The "internal use only" fields in regexp.h are present to pass info from * compile to execute that permits the execute phase to run lots faster on * simple cases. They are: * * regstart char that must begin a match; '\0' if none obvious * reganch is the match anchored (at beginning-of-line only)? * regmust string (pointer into program) that match must include, or NULL * regmlen length of regmust string * * Regstart and reganch permit very fast decisions on suitable starting points * for a match, cutting down the work a lot. Regmust permits fast rejection * of lines that cannot possibly match. The regmust tests are costly enough * that regcomp() supplies a regmust only if the r.e. contains something * potentially expensive (at present, the only such thing detected is * or + * at the start of the r.e., which can involve a lot of backup). Regmlen is * supplied because the test in regexec() needs it and regcomp() is * computing it anyway. */ /* * Structure for regexp "program". This is essentially a linear encoding * of a nondeterministic finite-state machine (aka syntax charts or * "railroad normal form" in parsing technology). Each node is an opcode * plus a "next" pointer, possibly plus an operand. "Next" pointers of * all nodes except BRANCH implement concatenation; a "next" pointer with * a BRANCH on both ends of it is connecting two alternatives. (Here we * have one of the subtle syntax dependencies: an individual BRANCH (as * opposed to a collection of them) is never concatenated with anything * because of operator precedence.) The operand of some types of node is * a literal string; for others, it is a node leading into a sub-FSM. In * particular, the operand of a BRANCH node is the first node of the branch. * (NB this is *not* a tree structure: the tail of the branch connects * to the thing following the set of BRANCHes.) The opcodes are: */ /* definition number opnd? meaning */ #define END 0 /* no End of program. */ #define BOL 1 /* no Match "" at beginning of line. */ #define EOL 2 /* no Match "" at end of line. */ #define ANY 3 /* no Match any one character. */ #define ANYOF 4 /* str Match any character in this string. */ #define ANYBUT 5 /* str Match any character not in this string. */ #define BRANCH 6 /* node Match this alternative, or the next... */ #define BACK 7 /* no Match "", "next" ptr points backward. */ #define EXACTLY 8 /* str Match this string. */ #define NOTHING 9 /* no Match empty string. */ #define STAR 10 /* node Match this (simple) thing 0 or more times. */ #define PLUS 11 /* node Match this (simple) thing 1 or more times. */ #define OPEN 20 /* no Mark this point in input as start of #n. */ /* OPEN+1 is number 1, etc. */ #define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ /* * Opcode notes: * * BRANCH The set of branches constituting a single choice are hooked * together with their "next" pointers, since precedence prevents * anything being concatenated to any individual branch. The * "next" pointer of the last BRANCH in a choice points to the * thing following the whole choice. This is also where the * final "next" pointer of each individual branch points; each * branch starts with the operand node of a BRANCH node. * * BACK Normal "next" pointers all implicitly point forward; BACK * exists to make loop structures possible. * * STAR,PLUS '?', and complex '*' and '+', are implemented as circular * BRANCH structures using BACK. Simple cases (one character * per match) are implemented with STAR and PLUS for speed * and to minimize recursive plunges. * * OPEN,CLOSE ...are numbered at compile time. */ /* * A node is one char of opcode followed by two chars of "next" pointer. * "Next" pointers are stored as two 8-bit pieces, high order first. The * value is a positive offset from the opcode of the node containing it. * An operand, if any, simply follows the node. (Note that much of the * code generation knows about this implicit relationship.) * * Using two bytes for the "next" pointer is vast overkill for most things, * but allows patterns to get big without disasters. */ #define OP(p) (*(p)) #define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) #define OPERAND(p) ((p) + 3) /* * See regmagic.h for one further detail of program structure. */ /* * Utility definitions. */ #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #else #define UCHARAT(p) ((int)*(p)&CHARBITS) #endif #define FAIL(m) { regerror(m); return(NULL); } #define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') #undef META #define META "^$.[()|?+*\\" /* * Flags to be passed up and down. */ #define HASWIDTH 01 /* Known never to match null string. */ #define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ #define SPSTART 04 /* Starts with * or +. */ #define WORST 0 /* Worst case. */ /* * Global work variables for regcomp(). */ static char *regparse; /* Input-scan pointer. */ static int regnpar; /* () count. */ static char regdummy; static char *regcode; /* Code-emit pointer; ®dummy = don't. */ static long regsize; /* Code size. */ /* * The first byte of the regexp internal "program" is actually this magic * number; the start node begins in the second byte. */ #define MAGIC 0234 /* * Forward declarations for regcomp()'s friends. */ #ifndef STATIC #define STATIC static #endif STATIC char *reg(int paren, int *flagp); STATIC char *regbranch(int *flagp); STATIC char *regpiece(int *flagp); STATIC char *regatom(int *flagp); STATIC char *regnode(char op); STATIC char *regnext(register char *p); STATIC void regc(char b); STATIC void reginsert(char op, char *opnd); STATIC void regtail(char *p, char *val); STATIC void regoptail(char *p, char *val); int case_fold_search = 0; /* - regcomp - compile a regular expression into internal code * * We can't allocate space until we know how big the compiled form will be, * but we can't compile it (and thus know how big it is) until we've got a * place to put the code. So we cheat: we compile it twice, once with code * generation turned off and size counting turned on, and once "for real". * This also means that we don't allocate space until we are sure that the * thing really will compile successfully, and we never have to move the * code and thus invalidate pointers into it. (Note that it has to be in * one piece because free() must be able to free it all.) * * Beware that the optimization-preparation code in here knows about some * of the structure of the compiled regexp. */ static regexp * regcomp(char *exp,ufixnum *sz) { register regexp *r; register char *scan; register char *longest; register int len; int flags; if (exp == NULL) FAIL("NULL argument"); /* First pass: determine size, legality. */ regparse = exp; regnpar = 1; regsize = 0L; regcode = ®dummy; regc(MAGIC); if (reg(0, &flags) == NULL) return(NULL); /* Small enough for pointer-storage convention? */ if (regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); /* Allocate space. */ *sz=sizeof(regexp) + (unsigned)regsize; r = (regexp *)alloc_relblock(*sz); if (r == NULL) FAIL("out of space"); /* Second pass: emit code. */ regparse = exp; regnpar = 1; regcode = r->program; regc(MAGIC); if (reg(0, &flags) == NULL) return(NULL); /* Dig out information for optimizations. */ r->regstart = '\0'; /* Worst-case defaults. */ r->reganch = 0; r->regmust = NULL; r->regmlen = 0; r->regmaybe_boyer =0; scan = r->program+1; /* First BRANCH. */ if (0&& OP(regnext(scan)) == END) { /* Only one top-level choice. */ scan = OPERAND(scan); /* Starting-point info. */ if (OP(scan) == EXACTLY) {r->regstart = *OPERAND(scan); r->regmaybe_boyer = strlen(OPERAND(scan));} else if (OP(scan) == BOL) r->reganch++; /* * If there's something expensive in the r.e., find the * longest literal string that must appear and make it the * regmust. Resolve ties in favor of later strings, since * the regstart check works with the beginning of the r.e. * and avoiding duplication strengthens checking. Not a * strong reason, but sufficient in the absence of others. */ if (flags&SPSTART) { longest = NULL; len = 0; for (; scan != NULL; scan = regnext(scan)) if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { longest = OPERAND(scan); len = strlen(OPERAND(scan)); } r->regmust = longest; r->regmlen = len; } } else { r->regmaybe_boyer = min_initial_branch_length(r,0,0);} return(r); } /* - reg - regular expression, i.e. main body or parenthesized thing * * Caller must absorb opening parenthesis. * * Combining parenthesis handling with the base level of regular expression * is a trifle forced, but the need to tie the tails of the branches to what * follows makes it hard to avoid. */ static char * reg(int paren, int *flagp) /* Parenthesized? */ { register char *ret; register char *br; register char *ender; register int parno = 0; int flags; *flagp = HASWIDTH; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { if (regnpar >= NSUBEXP) FAIL("too many ()"); parno = regnpar; regnpar++; ret = regnode(OPEN+parno); } else ret = NULL; /* Pick up the branches, linking them together. */ br = regbranch(&flags); if (br == NULL) return(NULL); if (ret != NULL) regtail(ret, br); /* OPEN -> first. */ else ret = br; if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; while (*regparse == '|') { regparse++; br = regbranch(&flags); if (br == NULL) return(NULL); regtail(ret, br); /* BRANCH -> BRANCH. */ if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; } /* Make a closing node, and hook it on the end. */ ender = regnode((paren) ? CLOSE+parno : END); regtail(ret, ender); /* Hook the tails of the branches to the closing node. */ for (br = ret; br != NULL; br = regnext(br)) regoptail(br, ender); /* Check for proper termination. */ if (paren && *regparse++ != ')') { FAIL("unmatched ()"); } else if (!paren && *regparse != '\0') { if (*regparse == ')') { FAIL("unmatched ()"); } else FAIL("junk on end"); /* "Can't happen". */ /* NOTREACHED */ } return(ret); } /* - regbranch - one alternative of an | operator * * Implements the concatenation operator. */ static char * regbranch(int *flagp) { register char *ret; register char *chain; register char *latest; int flags; *flagp = WORST; /* Tentatively. */ ret = regnode(BRANCH); chain = NULL; while (*regparse != '\0' && *regparse != '|' && *regparse != ')') { latest = regpiece(&flags); if (latest == NULL) return(NULL); *flagp |= flags&HASWIDTH; if (chain == NULL) /* First piece. */ *flagp |= flags&SPSTART; else regtail(chain, latest); chain = latest; } if (chain == NULL) /* Loop ran zero times. */ (void) regnode(NOTHING); return(ret); } /* - regpiece - something followed by possible [*+?] * * Note that the branching code sequences used for ? and the general cases * of * and + are somewhat optimized: they use the same NOTHING node as * both the endmarker for their branch list and the body of the last branch. * It might seem that this node could be dispensed with entirely, but the * endmarker role is not redundant. */ static char * regpiece(int *flagp) { register char *ret; register char op; register char *next; int flags; ret = regatom(&flags); if (ret == NULL) return(NULL); op = *regparse; if (!ISMULT(op)) { *flagp = flags; return(ret); } if (!(flags&HASWIDTH) && op != '?') FAIL("*+ operand could be empty"); *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) reginsert(STAR, ret); else if (op == '*') { /* Emit x* as (x&|), where & means "self". */ reginsert(BRANCH, ret); /* Either x */ regoptail(ret, regnode(BACK)); /* and loop */ regoptail(ret, ret); /* back */ regtail(ret, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else if (op == '+' && (flags&SIMPLE)) reginsert(PLUS, ret); else if (op == '+') { /* Emit x+ as x(&|), where & means "self". */ next = regnode(BRANCH); /* Either */ regtail(ret, next); regtail(regnode(BACK), ret); /* loop back */ regtail(next, regnode(BRANCH)); /* or */ regtail(ret, regnode(NOTHING)); /* null. */ } else if (op == '?') { /* Emit x? as (x|) */ reginsert(BRANCH, ret); /* Either x */ regtail(ret, regnode(BRANCH)); /* or */ next = regnode(NOTHING); /* null. */ regtail(ret, next); regoptail(ret, next); } regparse++; if (ISMULT(*regparse)) FAIL("nested *?+"); return(ret); } /* - regatom - the lowest level * * Optimization: gobbles an entire sequence of ordinary characters so that * it can turn them into a single node, which is smaller to store and * faster to run. Backslashed characters are exceptions, each becoming a * separate node; the code is simpler that way and it's not worth fixing. */ static char * regatom(int *flagp) { register char *ret; int flags; *flagp = WORST; /* Tentatively. */ switch (*regparse++) { case '^': ret = regnode(BOL); break; case '$': ret = regnode(EOL); break; case '.': ret = regnode(ANY); *flagp |= HASWIDTH|SIMPLE; break; case '[': {char buf[1000]; char result[256]; char *regcp=buf; int matches = 1; #define REGC(x) (*regcp++ = (x)) { register int clss; register int classend; ret = regnode(ANYOF); if (*regparse == '^') { /* Complement of range. */ matches = 0; regparse++;} if (*regparse == ']' || *regparse == '-') REGC(*regparse++); while (*regparse != '\0' && *regparse != ']') { if (*regparse == '-') { regparse++; if (*regparse == ']' || *regparse == '\0') REGC('-'); else { clss = UCHARAT(regparse-2)+1; classend = UCHARAT(regparse); if (clss > classend+1) FAIL("invalid [] range"); for (; clss <= classend; clss++) REGC(clss); regparse++; } } else REGC(*regparse++); } REGC('\0'); if (*regparse != ']') FAIL("unmatched []"); regparse++; *flagp |= HASWIDTH|SIMPLE; } if (regcp - buf > sizeof(buf)) { emsg("wow that is badly defined regexp.."); do_gcl_abort();} regcp --; { char *p=buf; /* set default vals */ p = result; while (p < &result[sizeof(result)]) *p++ = (!matches ); p = buf; while (p < regcp) { result[*(unsigned char *)p] = matches; if (case_fold_search) {result[tolower((int)*p)] = matches; result[toupper((int)*p)] = matches; p++;} else result[*(unsigned char *)p++] = matches; } p = result; while (p < &result[sizeof(result)]) { regc(*p++);}} break; } case '(': ret = reg(1, &flags); if (ret == NULL) return(NULL); *flagp |= flags&(HASWIDTH|SPSTART); break; case '\0': case '|': case ')': FAIL("internal urp"); /* Supposed to be caught earlier. */ /* NOTREACHED */ break; case '?': case '+': case '*': FAIL("?+* follows nothing"); /* NOTREACHED */ break; case '\\': if (*regparse == '\0') FAIL("trailing \\"); ret = regnode(EXACTLY); regc(*regparse++); regc('\0'); *flagp |= HASWIDTH|SIMPLE; break; default: { register int len; register char ender; regparse--; len = strcspn(regparse, META); if (len <= 0) FAIL("internal disaster"); ender = *(regparse+len); if (len > 1 && ISMULT(ender)) len--; /* Back off clear of ?+* operand. */ *flagp |= HASWIDTH; if (len == 1) *flagp |= SIMPLE; ret = regnode(EXACTLY); while (len > 0) { regc(*regparse++); len--; } regc('\0'); } break; } return(ret); } /* - regnode - emit a node */ static char * /* Location. */ regnode(char op) { register char *ret; register char *ptr; ret = regcode; if (ret == ®dummy) { regsize += 3; return(ret); } ptr = ret; *ptr++ = op; *ptr++ = '\0'; /* Null "next" pointer. */ *ptr++ = '\0'; regcode = ptr; return(ret); } /* - regc - emit (if appropriate) a byte of code */ static void regc(char b) { if (regcode != ®dummy) *regcode++ = b; else regsize++; } /* - reginsert - insert an operator in front of already-emitted operand * * Means relocating the operand. */ static void reginsert(char op, char *opnd) { register char *src; register char *dst; register char *place; if (regcode == ®dummy) { regsize += 3; return; } src = regcode; regcode += 3; dst = regcode; while (src > opnd) *--dst = *--src; place = opnd; /* Op node, where operand used to be. */ *place++ = op; *place++ = '\0'; *place++ = '\0'; } /* - regtail - set the next-pointer at the end of a node chain */ static void regtail(char *p, char *val) { register char *scan; register char *temp; register int offset; if (p == ®dummy) return; /* Find last node. */ scan = p; for (;;) { temp = regnext(scan); if (temp == NULL) break; scan = temp; } if (OP(scan) == BACK) offset = scan - val; else offset = val - scan; *(scan+1) = (offset>>8)&0377; *(scan+2) = offset&0377; } /* - regoptail - regtail on operand of first argument; nop if operandless */ static void regoptail(char *p, char *val) { /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || p == ®dummy || OP(p) != BRANCH) return; regtail(OPERAND(p), val); } /* * regexec and friends */ /* * Global work variables for regexec(). */ static char *reginput; /* String-input pointer. */ static char *regbol; /* Beginning of input, for ^ check. */ static char **regstartp; /* Pointer to startp array. */ static char **regendp; /* Ditto for endp. */ /* * Forwards. */ STATIC int regtry(regexp *prog, char *string); STATIC int regmatch(char *prog); STATIC int regrepeat(char *p); #ifdef DEBUG int regnarrate = 0; void regdump(); STATIC char *regprop(); #endif /* - regexec - match a regexp against a string PROG is the compiled regexp and STRING is the string one is searching in and START is a pointer relative to STRING, to tell if a substring of the original STRING is being passed. LENGTH can be 0 or the strlen(STRING). If it is not 0 and is large, then a fast checking will be enabled. */ static int regexec(register regexp *prog, register char *string, char *start, int length) { register char *s; char saved,*savedp=NULL; int value; /* Be paranoid... */ if (prog == NULL || string == NULL) { regerror("NULL parameter"); return(0); } /* Check validity of program. */ if (UCHARAT(prog->program) != MAGIC) { regerror("corrupted program"); return(0); } /* If there is a "must appear" string, look for it. */ /* to do:fix this for case_fold_search, and also to detect x[^x]*MUST pattern, searching for MUST, and then backing up to the 'x'. The regmust thing is bad in case of a long string. */ if (0 && prog->regmust != NULL) { s = string; while ((s = strchr(s, prog->regmust[0])) != NULL) { if (strncmp(s, prog->regmust, prog->regmlen) == 0) break; /* Found it. */ s++; } if (s == NULL) /* Not present. */ return(0); } /* null terminate string */ if (length) { savedp = &string[length]; saved = *savedp; if (saved) *savedp=0; } else saved=0; #define RETURN_VAL(i) do {value=i; goto DO_RETURN;}while(0) /* Mark beginning of line for ^ . */ regbol = start; /* Simplest case: anchored match need be tried only once. */ if (prog->reganch) RETURN_VAL(regtry(prog, string)); /* Messy cases: unanchored match. */ s = string; /* only do if long enough to warrant compile time really length/prog->regmaybe_boyer > 1000 is probably better (and >=2 !) */ if (length > 2 && prog->regmaybe_boyer>= 1) { unsigned char buf[256]; /* int advance= reg_compboyer(prog,buf); */ int advance=prog->regmaybe_boyer; int amt; unsigned char *s = (unsigned char *)string+ advance -1; min_initial_branch_length(prog, buf,advance); switch(advance) { case 1: while (1) { if (buf[*s]==0) { if (*s == 0) RETURN_VAL(0); else if (regtry(prog,(char *)s-(1-1))) RETURN_VAL(1);} s++; } RETURN_VAL(0); case 2: while (length > 0) { amt = (buf[s[0]]); if (amt == 0) { amt = buf[s[-1]]-1; if (amt <=0) { if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); else amt =1; } } s += amt; length -= amt; } RETURN_VAL(0); case 3: while (length > 0) { amt = (buf[s[0]]); if (amt == 0) {amt = buf[s[-1]]-1; if (amt <=0) {amt = buf[s[-2]]-2; if (amt <=0) {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); else amt =1;}}} s += amt; length -= amt;} case 4: while (length > 0) { amt = (buf[s[0]]); if (amt == 0) {amt = buf[s[-1]]-1; if (amt <=0) {amt = buf[s[-2]]-2; if (amt <=0) {amt = buf[s[-3]]-3; if (amt <=0) {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); else amt =1;}}}} s += amt; length -= amt;} default: while (length > 0) { amt = (buf[s[0]]); if (amt == 0) {amt = buf[s[-1]]-1; if (amt <=0) {amt = buf[s[-2]]-2; if (amt <=0) {amt = buf[s[-3]]-3; if (amt <=0) {amt = buf[s[-4]]-4; if (amt <=0) {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); else amt =1;}}}}} s += amt; length -= amt;} } RETURN_VAL(0); } else if (prog->regstart != '\0') /* We know what char it must start with. */ { if (case_fold_search) {char ch = tolower((int)prog->regstart); while (*s) { if (tolower((int)*s)==ch) {if (regtry(prog, s)) RETURN_VAL(1);} s++;}} else while ((s = strchr(s, prog->regstart)) != NULL) { if (regtry(prog, s)) RETURN_VAL(1); s++; } } else /* We don't -- general case. */ do { if (regtry(prog, s)) RETURN_VAL(1); } while (*s++ != '\0'); /* Failure. */ RETURN_VAL(0); DO_RETURN: if(saved) *savedp=saved; return value; } #ifdef OLD_VERSION reg_compboyer(r,buf) regexp *r; char *buf; { char *scan; scan = r->program+1; /* First BRANCH. */ if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ scan = OPERAND(scan); /* Starting-point info. */ #define MIN(n,m) (n > m ? m : n) if (OP(scan) == EXACTLY) { char *op = OPERAND(scan); char *p = buf; int advance = strlen(op); int i = 256; if (advance > 255) advance = 255; if (advance < 1) regerror("Impossible"); while (--i >= 0) *p++ = advance; i = advance; p = op; while (--i >= 0) { if (case_fold_search) { buf[tolower(*p)] = i; buf[toupper(*p)] = i; } else buf[(*p)] = i; p++; } buf[0]=0; return advance; }} regerror("Should be impossible"); return 1; } #endif /* - regtry - try match at specific point */ static int /* 0 failure, 1 success */ regtry(regexp *prog, char *string) { register int i; register char **sp; register char **ep; reginput = string; regstartp = prog->startp; regendp = prog->endp; sp = prog->startp; ep = prog->endp; for (i = NSUBEXP; i > 0; i--) { *sp++ = NULL; *ep++ = NULL; } if (regmatch(prog->program + 1)) { prog->startp[0] = string; prog->endp[0] = reginput; return(1); } else return(0); } /* - regmatch - main matching routine * * Conceptually the strategy is simple: check to see whether the current * node matches, call self recursively to see whether the rest matches, * and then act accordingly. In practice we make some effort to avoid * recursion, in particular by going through "ordinary" nodes (that don't * need to know whether the rest of the match failed) by a loop instead of * by recursion. */ static int /* 0 failure, 1 success */ regmatch(char *prog) { register char *scan; /* Current node. */ char *next; /* Next node. */ scan = prog; #ifdef DEBUG if (scan != NULL && regnarrate) emsg("%s(\n", regprop(scan)); #endif while (scan != NULL) { #ifdef DEBUG if (regnarrate) emsg("%s...\n", regprop(scan)); #endif next = regnext(scan); switch (OP(scan)) { case BOL: if (reginput != regbol) return(0); break; case EOL: if (*reginput != '\0') return(0); break; case ANY: if (*reginput == '\0') return(0); reginput++; break; case EXACTLY: { register char *opnd; char * ch = reginput; opnd = OPERAND(scan); if (case_fold_search) while (*opnd ) { if (tolower((int)*opnd) != tolower((int)*ch)) return 0; else { ch++; opnd++;}} else while (*opnd ) { if (*opnd != *ch) return 0; else { ch++; opnd++;}} /* a match */ reginput += (opnd - OPERAND(scan)); } break; case ANYOF: if (*reginput == '\0' || OPERAND(scan)[*(unsigned char *)reginput] == 0) return(0); reginput++; break; case ANYBUT: if (*reginput == '\0' || OPERAND(scan)[*(unsigned char *)reginput] != 0) return(0); reginput++; break; case NOTHING: break; case BACK: break; case OPEN+1 ... OPEN+NSUBEXP-1: { register int no; register char *save; no = OP(scan) - OPEN; save = reginput; if (regmatch(next)) { /* * Don't set startp if some later * invocation of the same parentheses * already has. */ if (regstartp[no] == NULL) regstartp[no] = save; return(1); } else return(0); } /* NOTREACHED */ break; case CLOSE+1 ... CLOSE+NSUBEXP-1: { register int no; register char *save; no = OP(scan) - CLOSE; save = reginput; if (regmatch(next)) { /* * Don't set endp if some later * invocation of the same parentheses * already has. */ if (regendp[no] == NULL) regendp[no] = save; return(1); } else return(0); } /* NOTREACHED */ break; case BRANCH: { register char *save; if (OP(next) != BRANCH) /* No choice. */ next = OPERAND(scan); /* Avoid recursion. */ else { do { save = reginput; if (regmatch(OPERAND(scan))) return(1); reginput = save; scan = regnext(scan); } while (scan != NULL && OP(scan) == BRANCH); return(0); /* NOTREACHED */ } } /* NOTREACHED */ break; case STAR: case PLUS: { register char nextch; register int no; register char *save; register int min; /* * Lookahead to avoid useless match attempts * when we know what character comes next. */ nextch = '\0'; if (OP(next) == EXACTLY) nextch = *OPERAND(next); if (case_fold_search) nextch = tolower((int)nextch); min = (OP(scan) == STAR) ? 0 : 1; save = reginput; no = regrepeat(OPERAND(scan)); while (no >= min) { /* If it could work, try it. */ if (nextch == '\0' || *reginput == nextch || (case_fold_search && tolower((int)*reginput) == nextch)) if (regmatch(next)) return(1); /* Couldn't or didn't -- back up. */ no--; reginput = save + no; } return(0); } /* NOTREACHED */ break; case END: return(1); /* Success! */ /* NOTREACHED */ break; default: regerror("memory corruption"); return(0); /* NOTREACHED */ break; } scan = next; } /* * We get here only if there's trouble -- normally "case END" is * the terminating point. */ regerror("corrupted pointers"); return(0); } /* - regrepeat - repeatedly match something simple, report how many */ static int regrepeat(char *p) { register int count = 0; register char *scan; register char *opnd; scan = reginput; opnd = OPERAND(p); switch (OP(p)) { case ANY: count = strlen(scan); scan += count; break; case EXACTLY: { char ch = *opnd; if (case_fold_search) { ch = tolower((int)*opnd); while (ch == tolower((int)*scan)) { count++; scan++;}} else while (ch == *scan) { count++; scan++; }} break; case ANYOF: while (*scan != '\0' && opnd[*(unsigned char *)scan] != 0) { count++; scan++; } break; case ANYBUT: while (*scan != '\0' && opnd[*(unsigned char *)scan] == 0) { count++; scan++; } break; default: /* Oh dear. Called inappropriately. */ regerror("internal foulup"); count = 0; /* Best compromise. */ break; } reginput = scan; return(count); } /* - regnext - dig the "next" pointer out of a node */ static char * regnext(register char *p) { register int offset; if (p == ®dummy) return(NULL); offset = NEXT(p); if (offset == 0) return(NULL); if (OP(p) == BACK) return(p-offset); else return(p+offset); } #ifdef DEBUG STATIC char *regprop(); /* - regdump - dump a regexp onto stdout in vaguely comprehensible form */ void regdump(r) regexp *r; { register char *s; register char op = EXACTLY; /* Arbitrary non-END op. */ register char *next; s = r->program + 1; while (op != END) { /* While that wasn't END last time... */ op = OP(s); printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ next = regnext(s); if (next == NULL) /* Next ptr. */ printf("(0)"); else printf("(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF || op == ANYBUT) { int i=-1; while (i++ < 256) if (s[i]) printf("%c",i); s +=256; } else if (op == EXACTLY) { /* Literal string, where present. */ while (*s != '\0') { putchar(*s); s++; } s++; } putchar('\n'); } /* Header fields of interest. */ if (r->regstart != '\0') printf("start `%c' ", r->regstart); if (r->reganch) printf("anchored "); if (r->regmust != NULL) printf("must have \"%s\"", r->regmust); printf("\n"); } /* - regprop - printable representation of opcode */ static char * regprop(op) char *op; { register char *p; static char buf[50]; (void) strcpy(buf, ":"); switch (OP(op)) { case BOL: p = "BOL"; break; case EOL: p = "EOL"; break; case ANY: p = "ANY"; break; case ANYOF: p = "ANYOF"; break; case ANYBUT: p = "ANYBUT"; break; case BRANCH: p = "BRANCH"; break; case EXACTLY: p = "EXACTLY"; break; case NOTHING: p = "NOTHING"; break; case BACK: p = "BACK"; break; case END: p = "END"; break; case OPEN+1 ... OPEN+NSUBEXP-1: sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); p = NULL; break; case CLOSE+1 ... CLOSE+NSUBEXP-1: sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); p = NULL; break; case STAR: p = "STAR"; break; case PLUS: p = "PLUS"; break; default: regerror("corrupted opcode"); break; } if (p != NULL) (void) strcat(buf, p); return(buf); } #endif /* * The following is provided for those people who do not have strcspn() in * their C libraries. They should get off their butts and do something * about it; at least one public-domain implementation of those (highly * useful) string routines has been published on Usenet. */ /* * strcspn - find length of initial segment of s1 consisting entirely * of characters not from s2 */ #ifdef NEVER_WE_PUT_IT_IN_LIB size_t strcspn(s1, s2) char *s1; char *s2; { register char *scan1; register char *scan2; register int count; count = 0; for (scan1 = s1; *scan1 != '\0'; scan1++) { for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ if (*scan1 == *scan2++) return(count); count++; } return(count); } #endif /* if min_initial_branch_length(prog,0,0) > 2 it is possible to have an initial matching routine This means that each toplevel branch has an initial segment of characters which is at least 2 and which */ #define MINIMIZE(loc,val) if (val < loc) loc=val static int min_initial_branch_length(regexp *x, unsigned char *buf, int advance) { char *s = x->program+1; int overall = 10000; int i= -1; char *next ; char op = EXACTLY; int n = advance; if (buf) { buf[0]=0; for (i=256; --i>0 ; ){buf[i]=n;}; } while(op != END) { op = OP(s); next = (s) + NEXT(s); if (op != END && op != BRANCH) do_gcl_abort(); s = s+3; { int this = 0; int anythis =0; int ok = 1; char op ; int i; while (1) { if (ok == 0) goto LEND; AGAIN: if(buf && n <= 0) {break;} op = OP(s); advance = n; s = OPERAND(s); if (op == EXACTLY) { int m = strlen(s); if (buf) { char *ss = s; n--; while(1) { if (case_fold_search) {MINIMIZE(buf[tolower((int)*ss)],n); MINIMIZE(buf[toupper((int)*ss)],n); } else { MINIMIZE(buf[*(unsigned char *)ss],n);} ss++; if (*ss==0 || n ==0) break; --n;}} else { this += m + anythis; anythis = 0;} s += m+1;} else if (op == ANYOF) { if (buf) { --n; for(i=256; --i>0;) {if (s[i]) MINIMIZE(buf[i],n);}} else { anythis += 1; /* if this seems like a random choice of letters they are and they are not */ if (s['f']==0 || s['a']==0 ||s['y']==0 || s['v']==0) { this += anythis; anythis = 0; }} s += 256;} else if (op == ANY) {if (buf) { --n; for(i=256; --i>0;) { MINIMIZE(buf[i],n);}} else anythis += 1; } else if (op == PLUS) { ok = 0; goto AGAIN; } else { LEND: #ifdef DEBUG if (buf==0)printf("[Br=%d]",this); #endif if (overall > this) { overall = this;} break;} }} s = next; op = OP(s); n = advance; } #ifdef DEBUG if (buf==0) printf("[overall=%d]\n",overall); #endif return overall; } #ifndef regerror void regerror(char *s) { emsg("regexp error %s\n", s); } #endif gcl-2.6.14/o/saveaix3.c0000755000175000017500000001634714360276512013136 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (c) Copyright William F. Schelter. */ /* unixsave.c */ #ifndef UNIX #include "include.h" #endif #include #include #include #include filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } #include #include char *__start; memory_save(original_file, save_file) char *original_file, *save_file; { /* MEM_SAVE_LOCALS; */ struct filehdr Eheader; struct aouthdr header; struct scnhdr shdrs[15]; int stsize; int textsize=0; int after_data; int orig_data_scnptr; int orig_debug_scnptr; char *data_begin, *data_end; int original_data; FILE *original, *save; register int n; register char *p; extern char *sbrk(); fclose(stdin); original = fopen(original_file, "r"); if (stdin != original || original->_file != 0) { fprintf(stderr, "Can't open the original file.\n"); exit(1); } setbuf(original, stdin_buf); fclose(stdout); unlink(save_file); n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } setbuf(save, stdout_buf); /* READ_HEADER; */ fread(&Eheader, sizeof(Eheader), 1, original); fread(&header, sizeof(header), 1, original); data_begin= 0x20000800; { char buf[500]; struct ld_info * ld; loadquery(L_GETINFO,buf,sizeof(buf)); ld = (struct ld_info *)buf; data_begin = ld->ldinfo_dataorg ; } /* header.data_start = data_begin; */ data_end = core_end; original_data = header.dsize; header.dsize = data_end - data_begin; header.bsize = 0; { int j,i = Eheader.f_nscns; int diff; fread(shdrs +1 ,i,sizeof(struct scnhdr),original); orig_data_scnptr = shdrs[header.o_sndata].s_scnptr; orig_debug_scnptr = shdrs[8].s_scnptr; diff = header.a_data - original_data - shdrs[header.o_snbss + 1].s_size; after_data = shdrs[header.o_snbss +2].s_scnptr; Eheader.f_symptr += diff; fwrite(&Eheader, sizeof(Eheader), 1, save); fwrite(&header, sizeof(header), 1, save); shdrs[header.o_snbss ].s_size = 0; shdrs[header.o_snbss +1 ].s_size = 0; /* ex**pect no more than 15 sections, and pad after data */ if (strcmp(".pad",shdrs[header.o_snbss + 1].s_name) || i >= 15) perror("unexpected format of object file"); shdrs[header.o_sndata ].s_size = header.a_data; /* shdrs[header.o_sndata].s_paddr = data_begin; shdrs[header.o_sndata].s_vaddr = data_begin; */ for (j=1; j<= i; j++) #define ADJUST(x) if(x) (x) = (x) + diff { ADJUST(shdrs[j].s_lnnoptr); ADJUST(shdrs[j].s_relptr); } for (j= header.o_sndata +1 ; j<= i; j++) { ADJUST(shdrs[j].s_scnptr); ADJUST(shdrs[j].s_vaddr); ADJUST(shdrs[j].s_paddr); } fwrite(shdrs +1 ,i,sizeof(struct scnhdr),save); /* FILECPY_HEADER; */ filecpy(save, original, shdrs[header.o_sndata].s_scnptr - sizeof(header)-sizeof(Eheader) - i*sizeof(struct scnhdr)); j= ftell(save); j= ftell(original); for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) if (n > BUFSIZ) fwrite(p, BUFSIZ, 1, save); else if (n > 0) { fwrite(p, 1, n, save); break; } else break; fseek(original, original_data, 1); fseek(original, after_data, 0); /* now positioned at the loader section */ { struct ldhdr *ldheader; struct ldrel * ldreloc_info,*p; char *space; space = (char *) sbrk(shdrs[header.o_snloader].s_size + 0x2000); ldheader = (struct ldhdr *) space; fread(space,1,shdrs[header.o_snloader].s_size,original); ldreloc_info = (struct ldrel *) (space + sizeof(struct ldhdr) + LDSYMSZ * ldheader->l_nsyms); i = sizeof(struct ldhdr) + LDSYMSZ * (ldheader->l_nsyms); for(p=ldreloc_info,i=0; i< ldheader->l_nreloc ; i++,p++) { if (p->l_rsecnm == header.o_snbss) (p->l_rsecnm = header.o_sndata); if (p->l_symndx == 2) /* make bss be data */ (p->l_symndx = 1); } /* p->l_vaddr += data_begin; */ fwrite(ldheader, 1, shdrs[header.o_snloader].s_size,save); /* unrelocate */ { int j1 = ftell(save); int j2= ftell(original); int off=0; fseek(original,orig_data_scnptr,0); fseek(save,shdrs[header.o_sndata].s_scnptr,0); for(p=ldreloc_info,i=0; i< ldheader->l_nreloc ; i++,p++) if (p->l_rsecnm == header.o_sndata) { int x,pos1,y; int d = p->l_vaddr - off; if (d) { fseek(save,d,1); fseek(original,d,1); off += d; } pos1 = ftell(original); pos1 = ftell(save); fread(&x,1,sizeof(int),original); y = x; if (p->l_symndx ==0) { int w = *((int *)&__start); x = ((*(int *)(data_begin+off))); x = x + header.text_start ; x = x - w ; } if (p->l_symndx ==1 || p->l_symndx ==2) { x = ((*(int *)(data_begin + off)) - (int) data_begin); } fwrite(&x,1,sizeof(int),save); off += sizeof(int); } fseek(save,j1,0); fseek(original,j2,0); } } sbrk(- (shdrs[header.o_snloader].s_size+ 0x2000)); filecpy(save,original,Eheader.f_symptr - ftell(save)); /* now at the beginning of the sym table */ { struct syment symbol; struct syment *sym = &symbol; int naux; int nsyms = Eheader.f_nsyms; while (--nsyms >= 0) { fread(&symbol,1,SYMESZ,original); fwrite(&symbol,1,SYMESZ,save); naux= sym->n_numaux; nsyms = nsyms - naux; if (ISFCN(sym->n_type) && (naux >= 2)) { fread(&symbol,1,SYMESZ,original); (((union auxent *)(sym))->x_sym.x_fcnary.x_fcn.x_lnnoptr) += diff; fwrite(&symbol,1,SYMESZ,save); filecpy(save,original,SYMESZ*(naux -1)); } else filecpy(save,original,SYMESZ*(naux)); } } COPY_TO_SAVE; fclose(original); fclose(save); } } Lsave() { char filename[256]; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); _cleanup(); /* { FILE *p; int nfile; nfile = NUMBER_OPEN_FILES; for (p = &_iob[3]; p < &_iob[nfile]; p++) fclose(p); } */ memory_save(kcl_self, filename); _exit(0); /* exit(0); */ /* no return */ } gcl-2.6.14/o/gnumalloc.c0000755000175000017500000005602114360276512013365 0ustar cammcamm/* dynamic memory allocation for GNU. Copyright (C) 1985, 1987 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELY NO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC, RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M. STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTY WHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THIS PROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source file as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy a valid copyright notice "Copyright (C) 1985 Free Software Foundation, Inc."; and include following the copyright notice a verbatim copy of the above disclaimer of warranty and of this License. You may charge a distribution fee for the physical act of transferring a copy. 2. You may modify your copy or copies of this source file or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another unrelated program with this program (or its derivative) on a volume of a storage or distribution medium does not bring the other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this program except as expressly provided under this License Agreement. Any attempt otherwise to copy, sublicense, distribute or transfer this program is void and your rights to use the program under this License agreement shall be automatically terminated. However, parties who have received computer software programs from you with this License Agreement will not have their licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other free programs whose distribution conditions are different, write to the Free Software Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yet worked out a simple rule that can be stated here, but we will often permit this. We will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * @(#)nmalloc.c 1 (Caltech) 2/21/82 * * U of M Modified: 20 Jun 1983 ACT: strange hacks for Emacs * * Nov 1983, Mike@BRL, Added support for 4.1C/4.2 BSD. * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. In this * implementation, the available sizes are (2^n)-4 (or -16) bytes long. * This is designed for use in a program that uses vast quantities of * memory, but bombs when it runs out. To make it a little better, it * warns the user when he starts to get near the end. * * June 84, ACT: modified rcheck code to check the range given to malloc, * rather than the range determined by the 2-power used. * * Jan 85, RMS: calls malloc_warning to issue warning on nearly full. * No longer Emacs-specific; can serve as all-purpose malloc for GNU. * You should call malloc_init to reinitialize after loading dumped Emacs. * Call malloc_stats to get info on memory stats if MSTATS turned on. * realloc knows how to return same block given, just changing its size, * if the power of 2 is correct. */ /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The * smallest allocatable block is 8 bytes. The overhead information will * go in the first int of the block, and the returned pointer will point * to the second. * #ifdef MSTATS * nmalloc[i] is the difference between the number of mallocs and frees * for a given block size. #endif /* MSTATS */ #ifdef emacs #include "config.h" #endif /* emacs */ /* Determine which kind of system this is. */ #include #ifndef SIGTSTP #ifndef VMS #ifndef USG #define USG #endif #endif /* not VMS */ #else /* SIGTSTP */ #ifdef SIGIO #define BSD42 #endif /* SIGIO */ #endif /* SIGTSTP */ /* Define getpagesize () if the system does not. */ #include "getpagesize.h" #ifndef BSD42 #ifndef USG #include /* warn the user when near the end */ #endif /* not USG */ #else /* if BSD42 */ #include #include #endif /* BSD42 */ extern char *start_of_data (); #ifdef BSD #ifndef DATA_SEG_BITS #define start_of_data() &etext #endif #endif #ifndef emacs #define start_of_data() &etext #endif #define ISALLOC ((char) 0xf7) /* magic byte that implies allocation */ #define ISFREE ((char) 0x54) /* magic byte that implies free block */ /* this is for error checking only */ #define ISMEMALIGN ((char) 0xd6) /* Stored before the value returned by memalign, with the rest of the word being the distance to the true beginning of the block. */ extern char etext; /* These two are for user programs to look at, when they are interested. */ unsigned int malloc_sbrk_used; /* amount of data space used now */ unsigned int malloc_sbrk_unused; /* amount more we can have */ /* start of data space; can be changed by calling init_malloc */ static char *data_space_start; #ifdef MSTATS static int nmalloc[30]; static int nmal, nfre; #endif /* MSTATS */ /* If range checking is not turned on, all we have is a flag indicating whether memory is allocated, an index in nextf[], and a size field; to realloc() memory we copy either size bytes or 1<<(index+3) bytes depending on whether the former can hold the exact size (given the value of 'index'). If range checking is on, we always need to know how much space is allocated, so the 'size' field is never used. */ struct mhead { char mh_alloc; /* ISALLOC or ISFREE */ char mh_index; /* index in nextf[] */ /* Remainder are valid only when block is allocated */ unsigned short mh_size; /* size, if < 0x10000 */ #ifdef rcheck unsigned mh_nbytes; /* number of bytes allocated */ int mh_magic4; /* should be == MAGIC4 */ #endif /* rcheck */ }; /* Access free-list pointer of a block. It is stored at block + 4. This is not a field in the mhead structure because we want sizeof (struct mhead) to describe the overhead for when the block is in use, and we do not want the free-list pointer to count in that. */ #define CHAIN(a) \ (*(struct mhead **) (sizeof (char *) + (char *) (a))) #ifdef rcheck /* To implement range checking, we write magic values in at the beginning and end of each allocated block, and make sure they are undisturbed whenever a free or a realloc occurs. */ /* Written in each of the 4 bytes following the block's real space */ #define MAGIC1 0x55 /* Written in the 4 bytes before the block's real space */ #define MAGIC4 0x55555555 #define ASSERT(p) if (!(p)) botch("p"); else #define EXTRA 4 /* 4 bytes extra for MAGIC1s */ #else #define ASSERT(p) #define EXTRA 0 #endif /* rcheck */ /* nextf[i] is free list of blocks of size 2**(i + 3) */ static struct mhead *nextf[30]; /* busy[i] is nonzero while allocation of block size i is in progress. */ static char busy[30]; /* Number of bytes of writable memory we can expect to be able to get */ static unsigned int lim_data; /* Level number of warnings already issued. 0 -- no warnings issued. 1 -- 75% warning already issued. 2 -- 85% warning already issued. */ static int warnlevel; /* Function to call to issue a warning; 0 means don't issue them. */ static void (*warnfunction) (); /* nonzero once initial bunch of free blocks made */ static int gotpool; char *_malloc_base; static void getpool (void); /* Cause reinitialization based on job parameters; also declare where the end of pure storage is. */ void malloc_init (char *start, void (*warnfun) (/* ??? */)) { if (start) data_space_start = start; lim_data = 0; warnlevel = 0; warnfunction = warnfun; } /* Return the maximum size to which MEM can be realloc'd without actually requiring copying. */ int malloc_usable_size (char *mem) { int blocksize = 8 << (((struct mhead *) mem) - 1) -> mh_index; return blocksize - sizeof (struct mhead) - EXTRA; } static void morecore (register int nu) /* ask system for more memory */ /* size index to get more of */ { char *sbrk (int n); register char *cp; register int nblks; register unsigned int siz; int oldmask; #ifdef BSD #ifndef BSD4_1 #ifdef SGC oldmask = sigsetmask (-1 & ~(sigmask(SIGPROTV))); #else oldmask = sigsetmask (-1); #endif #endif #endif if (!data_space_start) { data_space_start = start_of_data (); } if (lim_data == 0) get_lim_data (); /* On initial startup, get two blocks of each size up to 1k bytes */ if (!gotpool) { getpool (); getpool (); gotpool = 1; } /* Find current end of memory and issue warning if getting near max */ #ifndef VMS /* Maximum virtual memory on VMS is difficult to calculate since it * depends on several dynmacially changing things. Also, alignment * isn't that important. That is why much of the code here is ifdef'ed * out for VMS systems. */ cp = sbrk (0); siz = cp - data_space_start; malloc_sbrk_used = siz; malloc_sbrk_unused = lim_data - siz; if (warnfunction) switch (warnlevel) { case 0: if (siz > (lim_data / 4) * 3) { warnlevel++; (*warnfunction) ("Warning: past 75% of memory limit"); } break; case 1: if (siz > (lim_data / 20) * 17) { warnlevel++; (*warnfunction) ("Warning: past 85% of memory limit"); } break; case 2: if (siz > (lim_data / 20) * 19) { warnlevel++; (*warnfunction) ("Warning: past 95% of memory limit"); } break; } if ((int) cp & 0x3ff) /* land on 1K boundaries */ sbrk (1024 - ((int) cp & 0x3ff)); #endif /* not VMS */ /* Take at least 2k, and figure out how many blocks of the desired size we're about to get */ nblks = 1; if ((siz = nu) < 8) nblks = 1 << ((siz = 8) - nu); if ((cp = sbrk (1 << (siz + 3))) == (char *) -1) return; /* no more room! */ #ifndef VMS if ((int) cp & 7) { /* shouldn't happen, but just in case */ cp = (char *) (((int) cp + 8) & ~7); nblks--; } #endif /* not VMS */ /* save new header and link the nblks blocks together */ nextf[nu] = (struct mhead *) cp; siz = 1 << (nu + 3); while (1) { ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = nu; if (--nblks <= 0) break; CHAIN ((struct mhead *) cp) = (struct mhead *) (cp + siz); cp += siz; } CHAIN ((struct mhead *) cp) = 0; #ifdef BSD #ifndef BSD4_1 sigsetmask (oldmask); #endif #endif } static void getpool (void) { register int nu; char * sbrk (int n); register char *cp = sbrk (0); if ((int) cp & 0x3ff) /* land on 1K boundaries */ sbrk (1024 - ((int) cp & 0x3ff)); /* Record address of start of space allocated by malloc. */ if (_malloc_base == 0) _malloc_base = cp; /* Get 2k of storage */ cp = sbrk (04000); if (cp == (char *) -1) return; /* Divide it into an initial 8-word block plus one block of size 2**nu for nu = 3 ... 10. */ CHAIN (cp) = nextf[0]; nextf[0] = (struct mhead *) cp; ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = 0; cp += 8; for (nu = 0; nu < 7; nu++) { CHAIN (cp) = nextf[nu]; nextf[nu] = (struct mhead *) cp; ((struct mhead *) cp) -> mh_alloc = ISFREE; ((struct mhead *) cp) -> mh_index = nu; cp += 8 << nu; } } voi * malloc(size_t n) /* get a block */ { register struct mhead *p; register unsigned int nbytes; register int nunits = 0; /* Figure out how many bytes are required, rounding up to the nearest multiple of 4, then figure out which nextf[] area to use */ nbytes = (n + sizeof *p + EXTRA + 3) & ~3; { register unsigned int shiftr = (nbytes - 1) >> 2; while (shiftr >>= 1) nunits++; } /* In case this is reentrant use of malloc from signal handler, pick a block size that no other malloc level is currently trying to allocate. That's the easiest harmless way not to interfere with the other level of execution. */ while (busy[nunits]) nunits++; busy[nunits] = 1; /* If there are no blocks of the appropriate size, go get some */ /* COULD SPLIT UP A LARGER BLOCK HERE ... ACT */ if (nextf[nunits] == 0) morecore (nunits); /* Get one block off the list, and set the new list head */ if ((p = nextf[nunits]) == 0) { busy[nunits] = 0; return 0; } nextf[nunits] = CHAIN (p); busy[nunits] = 0; /* Check for free block clobbered */ /* If not for this check, we would gobble a clobbered free chain ptr */ /* and bomb out on the NEXT allocate of this size block */ if (p -> mh_alloc != ISFREE || p -> mh_index != nunits) #ifdef rcheck botch ("block on free list clobbered"); #else /* not rcheck */ abort (); #endif /* not rcheck */ /* Fill in the info, and if range checking, set up the magic numbers */ p -> mh_alloc = ISALLOC; #ifdef rcheck p -> mh_nbytes = n; p -> mh_magic4 = MAGIC4; { register char *m = (char *) (p + 1) + n; *m++ = MAGIC1, *m++ = MAGIC1, *m++ = MAGIC1, *m = MAGIC1; } #else /* not rcheck */ p -> mh_size = n; #endif /* not rcheck */ #ifdef MSTATS nmalloc[nunits]++; nmal++; #endif /* MSTATS */ return (char *) (p + 1); } void free (void *mem) { register struct mhead *p; { register char *ap = mem; if (ap == 0) return; p = (struct mhead *) ap - 1; if (p -> mh_alloc == ISMEMALIGN) { ap -= p->mh_size; p = (struct mhead *) ap - 1; } if (p -> mh_alloc != ISALLOC) abort (); #ifdef rcheck ASSERT (p -> mh_magic4 == MAGIC4); ap += p -> mh_nbytes; ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); ASSERT (*ap == MAGIC1); #endif /* rcheck */ } { register int nunits = p -> mh_index; ASSERT (nunits <= 29); p -> mh_alloc = ISFREE; /* Protect against signal handlers calling malloc. */ busy[nunits] = 1; /* Put this block on the free list. */ CHAIN (p) = nextf[nunits]; nextf[nunits] = p; busy[nunits] = 0; #ifdef MSTATS nmalloc[nunits]--; nfre++; #endif /* MSTATS */ } } void * realloc (void *mem, register size_t n) { register struct mhead *p; register unsigned int tocopy; register unsigned int nbytes; register int nunits; if ((p = (struct mhead *) mem) == 0) return malloc (n); p--; nunits = p -> mh_index; ASSERT (p -> mh_alloc == ISALLOC); #ifdef rcheck ASSERT (p -> mh_magic4 == MAGIC4); { register char *m = mem + (tocopy = p -> mh_nbytes); ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); ASSERT (*m == MAGIC1); } #else /* not rcheck */ if (p -> mh_index >= 13) tocopy = (1 << (p -> mh_index + 3)) - sizeof *p; else tocopy = p -> mh_size; #endif /* not rcheck */ /* See if desired size rounds to same power of 2 as actual size. */ nbytes = (n + sizeof *p + EXTRA + 7) & ~7; /* If ok, use the same block, just marking its size as changed. */ if (nbytes > (4 << nunits) && nbytes <= (8 << nunits)) { #ifdef rcheck register char *m = mem + tocopy; *m++ = 0; *m++ = 0; *m++ = 0; *m++ = 0; p-> mh_nbytes = n; m = mem + n; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; #else /* not rcheck */ p -> mh_size = n; #endif /* not rcheck */ return mem; } if (n < tocopy) tocopy = n; { register char *new; if ((new = malloc (n)) == 0) return 0; bcopy (mem, new, tocopy); free (mem); return new; } } #ifndef VMS void * memalign (long alignment, size_t size) { register char *ptr = malloc (size + alignment); register char *aligned; register struct mhead *p; if (ptr == 0) return 0; /* If entire block has the desired alignment, just accept it. */ if (((int) ptr & (alignment - 1)) == 0) return ptr; /* Otherwise, get address of byte in the block that has that alignment. */ aligned = (char *) (((int) ptr + alignment - 1) & -alignment); /* Store a suitable indication of how to free the block, so that free can find the true beginning of it. */ p = (struct mhead *) aligned - 1; p -> mh_size = aligned - ptr; p -> mh_alloc = ISMEMALIGN; return aligned; } #ifndef HPUX /* This runs into trouble with getpagesize on HPUX. Patching out seems cleaner than the ugly fix needed. */ char * valloc (int size) { return memalign (getpagesize (), size); } #endif /* not HPUX */ #endif /* not VMS */ #ifdef MSTATS /* Return statistics describing allocation of blocks of size 2**n. */ struct mstats_value { int blocksize; int nfree; int nused; }; struct mstats_value malloc_stats (size) int size; { struct mstats_value v; register int i; register struct mhead *p; v.nfree = 0; if (size < 0 || size >= 30) { v.blocksize = 0; v.nused = 0; return v; } v.blocksize = 1 << (size + 3); v.nused = nmalloc[size]; for (p = nextf[size]; p; p = CHAIN (p)) v.nfree++; return v; } #endif /* MSTATS */ /* * This function returns the total number of bytes that the process * will be allowed to allocate via the sbrk(2) system call. On * BSD systems this is the total space allocatable to stack and * data. On USG systems this is the data space only. */ #ifdef USG get_lim_data () { extern long ulimit (); lim_data = ulimit (3, 0); lim_data -= (long) data_space_start; } #else /* not USG */ #ifndef BSD42 get_lim_data () { lim_data = vlimit (LIM_DATA, -1); } #else /* BSD42 */ get_lim_data (void) { struct rlimit XXrlimit; getrlimit (RLIMIT_DATA, &XXrlimit); #ifdef RLIM_INFINITY lim_data = XXrlimit.rlim_cur & RLIM_INFINITY; /* soft limit */ #else lim_data = XXrlimit.rlim_cur; /* soft limit */ #endif } #endif /* BSD42 */ #endif /* not USG */ #ifdef VMS /* There is a problem when dumping and restoring things on VMS. Calls * to SBRK don't necessarily result in contiguous allocation. Dumping * doesn't work when it isn't. Therefore, we make the initial * allocation contiguous by allocating a big chunk, and do SBRKs from * there. Once Emacs has dumped there is no reason to continue * contiguous allocation, malloc doesn't depend on it. * * There is a further problem of using brk and sbrk while using VMS C * run time library routines malloc, calloc, etc. The documentation * says that this is a no-no, although I'm not sure why this would be * a problem. In any case, we remove the necessity to call brk and * sbrk, by calling calloc (to assure zero filled data) rather than * sbrk. * * VMS_ALLOCATION_SIZE is the size of the allocation array. This * should be larger than the malloc size before dumping. Making this * too large will result in the startup procedure slowing down since * it will require more space and time to map it in. * * The value for VMS_ALLOCATION_SIZE in the following define was determined * by running emacs linked (and a large allocation) with the debugger and * looking to see how much storage was used. The allocation was 201 pages, * so I rounded it up to a power of two. */ #ifndef VMS_ALLOCATION_SIZE #define VMS_ALLOCATION_SIZE (512*256) #endif /* Use VMS RTL definitions */ #undef sbrk #undef brk #undef malloc int vms_out_initial = 0; char vms_initial_buffer[VMS_ALLOCATION_SIZE]; static char *vms_current_brk = &vms_initial_buffer; static char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; #include char * sys_sbrk (incr) int incr; { char *sbrk(), *temp, *ptr; if (vms_out_initial) { /* out of initial allocation... */ if (!(temp = malloc (incr))) temp = (char *) -1; } else { /* otherwise, go out of our area */ ptr = vms_current_brk + incr; /* new current_brk */ if (ptr <= vms_end_brk) { temp = vms_current_brk; vms_current_brk = ptr; } else { vms_out_initial = 1; /* mark as out of initial allocation */ if (!(temp = malloc (incr))) temp = (char *) -1; } } return temp; } #endif /* VMS */ gcl-2.6.14/o/regexpr.c0000755000175000017500000001353114360276512013057 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include "include.h" #include "page.h" #undef STATIC #define regerror gcl_regerror static void gcl_regerror(char *s) { FEerror("Regexp Error: ~a",1,make_simple_string(s)); } #undef endp #include "regexp.c" #define check_string(x) \ if (type_of(x) != t_string) \ not_a_string(x) DEFVAR("*MATCH-DATA*",sSAmatch_dataA,SI,sLnil,""); DEFVAR("*CASE-FOLD-SEARCH*",sSAcase_fold_searchA,SI,sLnil, "Non nil means that a string-match should ignore case"); DEFUN_NEW("MATCH-BEGINNING",object,fSmatch_beginning,SI,1,1,NONE,OI,OO,OO,OO,(fixnum i), "Returns the beginning of the I'th match from the previous STRING-MATCH, \ where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* \ vector is not a fixnum array.") { object v = sSAmatch_dataA->s.s_dbind; if (type_of(v)==t_vector && (v->v.v_elttype == aet_fix)) RETURN1(make_fixnum(sSAmatch_dataA->s.s_dbind->fixa.fixa_self[i])); RETURN1(make_fixnum(-1)); } DEFUN_NEW("MATCH-END",object,fSmatch_end,SI,1,1,NONE,OI,OO,OO,OO,(fixnum i), "Returns the end of the I'th match from the previous STRING-MATCH") { object v = sSAmatch_dataA->s.s_dbind; if (type_of(v)==t_vector && (v->v.v_elttype == aet_fix)) RETURN1(make_fixnum(sSAmatch_dataA->s.s_dbind->fixa.fixa_self[i+NSUBEXP])); RETURN1(make_fixnum(-1)); } DEFUN_NEW("COMPILE-REGEXP",object,fScompile_regexp,SI,1,1,NONE,OO,OO,OO,OO,(object p), "Provide handle to export pre-compiled regexp's to string-match") { char *tmp; object res; ufixnum i=0; if (type_of(p)!= t_string && type_of(p)!=t_symbol) not_a_string_or_symbol(p); if (!(tmp=alloca(p->st.st_fillp+1))) FEerror("out of C stack",0); memcpy(tmp,p->st.st_self,p->st.st_fillp); tmp[p->st.st_fillp]=0; res=alloc_object(t_vector); res->v.v_displaced=Cnil; res->v.v_hasfillp=1; res->v.v_elttype=aet_uchar; res->v.v_adjustable=0; res->v.v_offset=0; res->v.v_self=NULL; if (!(res->v.v_self=(void *)regcomp(tmp,&i))) FEerror("regcomp failure",0); res->v.v_fillp=res->v.v_dim=i; RETURN1(res); } DEFUN_NEW("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,OO,OO,OO,OO,(object pattern,object string,...), "Match regexp PATTERN in STRING starting in string starting at START \ and ending at END. Return -1 if match not found, otherwise \ return the start index of the first matchs. The variable \ *MATCH-DATA* will be set to a fixnum array of sufficient size to hold \ the matches, to be obtained with match-beginning and match-end. \ If it already contains such an array, then the contents of it will \ be over written. \ ") { int i,ans,nargs=VFUN_NARGS,len,start,end; static char buf[400],case_fold; static regexp *saved_compiled_regexp; va_list ap; object v = sSAmatch_dataA->s.s_dbind; char **pp,*str,save_c=0; if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol && (type_of(pattern)!=t_vector || pattern->v.v_elttype!=aet_uchar)) FEerror("~S is not a regexp pattern", 1 , pattern); if (type_of(string)!= t_string && type_of(string)!=t_symbol) not_a_string_or_symbol(string); if (type_of(v) != t_vector || v->v.v_elttype != aet_fix || v->v.v_dim < NSUBEXP*2) v=sSAmatch_dataA->s.s_dbind=fSmake_vector1_1((NSUBEXP *2),aet_fix,sLnil); start=0; end=string->st.st_fillp; if (nargs>2) { va_start(ap,string); start=fixint(va_arg(ap,object)); if (nargs>3) end=fixint(va_arg(ap,object)); va_end(ap); } if (start < 0 || end > string->st.st_fillp || start > end) FEerror("Bad start or end",0); len=pattern->ust.ust_fillp; if (len==0) { /* trivial case of empty pattern */ for (i=0;ifixa.fixa_self[i]=i ? -1 : 0; memcpy(v->fixa.fixa_self+NSUBEXP,v->fixa.fixa_self,NSUBEXP*sizeof(*v->fixa.fixa_self)); RETURN1(make_fixnum(0)); } { regexp *compiled_regexp=saved_compiled_regexp; BEGIN_NO_INTERRUPT; case_fold_search = sSAcase_fold_searchA->s.s_dbind != sLnil ? 1 : 0; if (type_of(pattern)==t_vector) compiled_regexp=(void *)pattern->ust.ust_self; else if (case_fold != case_fold_search || len != strlen(buf) || memcmp(pattern->ust.ust_self,buf,len)) compiled_regexp=saved_compiled_regexp=(regexp *)FFN(fScompile_regexp)(pattern)->v.v_self; str=string->st.st_self; if (NULL_OR_ON_C_STACK(str+end) || str+end==(void *)compiled_regexp) { if (!(str=alloca(string->st.st_fillp+1))) FEerror("Cannot allocate memory on C stack",0); memcpy(str,string->st.st_self,string->st.st_fillp); } else save_c=str[end]; str[end]=0; ans = regexec(compiled_regexp,str+start,str,end-start); str[end] = save_c; if (!ans ) { END_NO_INTERRUPT; RETURN1(make_fixnum(-1)); } pp=compiled_regexp->startp; for (i=0;ifixa.fixa_self[i]=*pp ? *pp-str : -1; pp=compiled_regexp->endp; for (;i<2*NSUBEXP;i++,pp++) v->fixa.fixa_self[i]=*pp ? *pp-str : -1; END_NO_INTERRUPT; RETURN1(make_fixnum(v->fixa.fixa_self[0])); } } gcl-2.6.14/o/usig2.c0000755000175000017500000002746314360276512012445 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef IN_UNIXINT #define NEED_MP_H #include #include #include #include "include.h" static void invoke_handler(int,int); #ifndef USIG2 #include #include "usig.h" /* #include "arith.h" */ #endif #endif #ifdef USIG2 #include USIG2 #else /* these sstructure pointers would need their structures provided... so we just call them void */ void * sfaslp; #ifdef CMAC EXTER unsigned long s4_neg_int[4],small_neg_int[3],small_pos_int[3]; #endif /* We have two mechanisms for protecting against interrupts. 1] We have a facility for delaying certain signals during critical regions of code. This facility will involve BEGIN_NO_INTERRUPT and END_NO_INTERRUPT */ handler_function_type our_signal_handler[32]; struct save_for_interrupt{ object free1[32]; object free2[32]; object altfree1[32]; object altfree2[32]; union lispunion buf[32]; struct call_data fcall; object *vs_top,vs_topVAL,*vs_base; struct bds_bd *bds_top,bds_topVAL; struct invocation_history *ihs_top,ihs_topVAL; char *token_bufp; char token_buf [4*INITIAL_TOKEN_LENGTH]; int token_st_dim; /* for storing the XS objects in te usig2_aux.c */ void *save_objects[75]; }; /* note these are the reverse of the ones in unixint.c ... uggghhh*/ #undef SS1 #undef RS1 #define SS1(a,b) a = b ; #define RS1(a,b) b = a ; /* save objects in save_objects list */ char signals_handled [] = {SIGINT,SIGUSR2,SIGUSR1,SIGIO,SIGALRM, #ifdef OTHER_SIGNALS_HANDLED OTHER_SIGNALS_HANDLED #endif 0}; /* * in_signal_handler: if not zero indicates we are running inside a signal handler, which may have been invoked at a random intruction, and so it is not safe to do a relocatable gc. * signals_pending: if (signals_pending & signal_mask(signo)) then this signo 's handler is waiting to be run. * signals_allowed: indicates the state we think we were in when checking to invoke a signal. Values: sig_none: definitely dont run handler sig_normal: In principle `ok', but if desiring maximum safety dont run here. sig_safe: safe point to run a function (eg make_cons,...) sig_at_read: interrupting the getc function in read. Should be safe. unwind (used by throw,return etc) resets this to sig_normal just as it does the longjmp. If we invoke signal handling routines at a storage allocation pt, it is completely safe: we should save some of the globals, but the freelists etc dont need to be saved. pass: sig_safe to raise_pending. If we invoke it at end of a No interrupts region, then it we must look at whether these were nested. We should probably have two endings for END_NO_INTERRUPTS, one for when we want to raise, and one for where we are sure we are at safe place. pass sig_use_signals_allowed_value If we invoke a handler when at signals_allowed == sig_at_read, then we are safe. */ #define XX sig_safe /* min safety level required for invoking a given signal handler */ char safety_required[]={XX,XX,XX,XX,XX,XX,XX,XX, XX,XX,XX,XX,XX,XX,XX,XX, XX,XX,XX,XX,XX,XX,XX,XX, XX,XX,XX,XX,XX,XX,XX,XX}; void gcl_init_safety(void) { safety_required[SIGINT]=sig_try_to_delay; safety_required[SIGALRM]=sig_normal; } DO_INIT(gcl_init_safety();) DEFUN_NEW("SIGNAL-SAFETY-REQUIRED",object,sSsignal_safety_required,SI,2,2, NONE,OI,IO,OO,OO,(fixnum signo,fixnum safety), "Set the safety level required for handling SIGNO to SAFETY, or if \ SAFETY is negative just return the current safety level for that \ signal number. Value of 1 means allow interrupt at any place not \ specifically marked in the code as bad, and value of 2 means allow it \ only in very SAFE places.") { if (signo > sizeof(safety_required)) {FEerror("Illegal signo:~a.",1,make_fixnum(signo));} if (safety >=0) safety_required[signo] = safety; return small_fixnum(safety_required[signo]) ; } void #ifdef __MINGW32__ main_signal_handler(int signo) #else main_signal_handler(int signo, int a, int b) #endif { int allowed = signals_allowed; #ifdef NEED_TO_REINSTALL_SIGNALS signal(signo,main_signal_handler); #endif if (allowed >= safety_required[signo]) { signals_allowed = sig_none; if (signo == SIGUSR1 || signo == SIGIO) { unblock_sigusr_sigio();} invoke_handler(signo,allowed); signals_allowed = allowed; } else { signals_pending |= signal_mask(signo); alarm(1);} return; } static void before_interrupt(struct save_for_interrupt *p, int allowed); static void after_interrupt(struct save_for_interrupt *p, int allowed); /* caller saves and restores the global signals_allowed; */ static void invoke_handler(int signo, int allowed) {struct save_for_interrupt buf; before_interrupt(&buf,allowed); signals_pending &= ~(signal_mask(signo)); {int prev_in_handler = in_signal_handler; in_signal_handler |= (allowed <= sig_normal ? 1 : 0); signals_allowed = allowed; our_signal_handler[signo](signo); signals_allowed = 0; in_signal_handler = prev_in_handler; after_interrupt(&buf,allowed); }} int tok_leng; static void before_interrupt(struct save_for_interrupt *p, int allowed) {int i; /* all this must be run in no interrupts mode */ if ( allowed < sig_safe) { /* save tht tops of the free stacks */ for(i=0; i < t_end ; i++) { struct typemanager *ad = &tm_table[i]; {SS1(p->free1[i],ad->tm_free); if (p->free1[i]) { char *beg = (char *) (p->free1[i]); object x = (object)beg; int amt = ad->tm_size; SS1(p->free2[i],OBJ_LINK(p->free1[i])); ad->tm_nfree --; bcopy(beg ,&(p->buf[i]), amt); bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist)); make_unfree(x); if (p->free2[i]) { x = (object) p->free2[i]; beg = (char *)x; make_unfree(x); bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist)); SS1(ad->tm_free,OBJ_LINK(p->free2[i])); ad->tm_nfree --; } else { SS1(ad->tm_free, OBJ_LINK(p->free1[i])); }} }} } SS1(p->fcall,fcall); SS1(p->vs_top,vs_top); SS1(p->vs_topVAL,*vs_top); SS1(p->vs_base,vs_base); SS1(p->bds_top,bds_top); SS1(p->bds_topVAL,*bds_top); SS1(p->ihs_top,ihs_top); SS1(p->ihs_topVAL,*ihs_top); { void **pp = p->save_objects; #undef XS #undef XSI #define XS(a) *pp++ = (void *) (a); #define XSI(a) *pp++ = (void *)(long)(a); /* #define XS(a) *pp++ = * (void **) (&a); */ #include "usig2_aux.c" if ((pp - (&(p->save_objects)[0])) >= (sizeof(p->save_objects)/sizeof(void *))) do_gcl_abort(); } #define MINN(a,b) (atoken_st_dim = MINN(token->st.st_dim,tok_leng+1); if (p->token_st_dim < sizeof(p->token_buf)) p->token_bufp = p->token_buf; else { p->token_bufp= (void *)alloca(p->token_st_dim);} bcopy(token->st.st_self,p->token_bufp,p->token_st_dim); } static void after_interrupt(struct save_for_interrupt *p, int allowed) {int i; /* all this must be run in no interrupts mode */ if ( allowed < sig_safe) { for(i=0; i < t_end ; i++) { struct typemanager *ad = &tm_table[i]; object current_fl = ad->tm_free; {RS1(p->free1[i],ad->tm_free); if (p->free1[i]) { char *beg = (char *) (p->free1[i]); object x = (object)beg; int amt = ad->tm_size; RS1(p->free2[i],(p->free1[i])); if (is_marked_or_free(x)) error("should not be free"); bcopy(&(p->buf[i]),beg, amt); if (p->free2[i]) { x = (object) p->free2[i]; if (is_marked_or_free(x)) error("should not be free"); make_free(x); F_LINK(F_LINK(ad->tm_free)) = (long )current_fl; ad->tm_nfree += 2; } else ad->tm_nfree =1; } else ad->tm_nfree =0; }} } RS1(p->fcall,fcall); RS1(p->vs_top,vs_top); RS1(p->vs_topVAL,*vs_top); RS1(p->vs_base,vs_base); RS1(p->bds_top,bds_top); RS1(p->bds_topVAL,*bds_top); RS1(p->ihs_top,ihs_top); RS1(p->ihs_topVAL,*ihs_top); { void **pp = p->save_objects; #undef XS #undef XSI /* #define XS(a) a = (void *)(*pp++) We store back in the location 'a' the value we have saved. */ /* #define XS(a) do { void **_p = (void **)(&a); *_p = (void *)(*pp++);}while(0) */ #define XS(a) a = (void *)(*pp++) #define XSI(a) {union {void *v;long l;}u; u.v=*pp++; a = u.l;} #include "usig2_aux.c" } bcopy(p->token_bufp,token->st.st_self,p->token_st_dim); } /* claim the following version of make_cons can be interrupted at any line and is suitable for inlining. */ /* static object */ /* MakeCons(object a, object b) */ /* { struct typemanager*ad = &tm_table[t_cons]; */ /* object new = (object) ad->tm_free; */ /* if (new == 0) */ /* { new = alloc_object(t_cons); */ /* new->c.c_car = a; */ /* goto END; */ /* } */ /* new->c.c_car=a; */ /* interrupt here and before_interrupt will copy new->c into the C stack, so that a will be protected */ /* new->c.t=t_cons; */ /* new->c.m= 0; */ /* Make interrupt copy new out to the stack and then zero new. That way new is certainly gc valid, and its contents are protected. So the above three operations can occur in any order. */ /* { object tem = OBJ_LINK(new); */ /* interrupt here and we see that before_interrupt must save the top of the free list AND the second thing on the Free list. That way we will be ok here and an interrupt here could not affect tem. It is possible that tem == 0, yet a gc happened in between. An interrupt here when tem = 0 would mean the free list needs to be collected again by second gc. */ /* ad->tm_free = tem; */ /* } */ /* Whew: we got it safely off so interrupts can't hurt us now. */ /* ad->tm_nfree --; */ /* interrupt here and the cdr field will point to a f_link which is a 'free' and so gc valid. b is still protected since it is in the stack or a regiseter, and a is protected since it is in new, and new is not free */ /* END: */ /* new->c.c_cdr=b; */ /* return new; */ /* } */ /* COND is the condition where this is raised. Might be sig_safe (eg at cons). */ void raise_pending_signals(int cond) {unsigned int allowed = signals_allowed ; if (cond == sig_use_signals_allowed_value) if (cond == sig_none || interrupt_enable ==0) return ; AGAIN: { unsigned int pending = signals_pending; char *p = signals_handled; if (pending) while(*p) { if (signal_mask(*p) & pending && cond >= safety_required[(unsigned char)*p]) { signals_pending &= ~(signal_mask(*p)); if (*p == SIGALRM && cond >= sig_safe) { alarm(0);} else invoke_handler(*p,cond); goto AGAIN; } p++; } signals_allowed = allowed; return; }} DEFUN_NEW("ALLOW-SIGNAL",object,fSallow_signal,SI,1,1,NONE,OI,OO,OO,OO,(fixnum n), "Install the default signal handler on signal N") { signals_allowed |= signal_mask(n); unblock_signals(n,n); /* sys v ?? just restore the signal ?? */ if (our_signal_handler[n]) {gcl_signal(n,our_signal_handler[n]); return make_fixnum(1); } else return make_fixnum(0); } #endif gcl-2.6.14/o/reference.c0000755000175000017500000001032314360276512013335 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* reference.c Reference in Constants and Variables */ #include "include.h" LFD(Lfboundp)(void) { object sym; check_arg(1); sym = vs_base[0]; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL) vs_base[0] = Ct; else if (sym->s.s_gfdef == OBJNULL) vs_base[0]= Cnil; else vs_base[0]= Ct; } object symbol_function(object sym) { /* if (type_of(sym) != t_symbol) not_a_symbol(sym); */ if (sym->s.s_sfdef != NOT_SPECIAL || sym->s.s_mflag) FEinvalid_function(sym); if (sym->s.s_gfdef == OBJNULL) FEundefined_function(sym); return(sym->s.s_gfdef); } /* Symbol-function returns function-closure for function (macro . function-closure) for macros (special . address) for special forms. */ LFD(Lsymbol_function)(void) { object sym; check_arg(1); sym = vs_base[0]; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL) { vs_base[0]=make_cons(sLspecial,make_fixnum((long)(sym->s.s_sfdef))); return; } if (sym->s.s_gfdef==OBJNULL) FEundefined_function(sym); if (sym->s.s_mflag) { vs_base[0]=make_cons(sSmacro,sym->s.s_gfdef); return; } vs_base[0] = sym->s.s_gfdef; } static void FFN(Fquote)(object form) { if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form))) FEtoo_many_argumentsF(form); vs_base = vs_top; vs_push(MMcar(form)); } static void FFN(Ffunction)(object form) { object fun; object fd; if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form))) FEtoo_many_argumentsF(form); fun = MMcar(form); if (type_of(fun) == t_symbol) { fd = lex_fd_sch(fun); if (MMnull(fd) || MMcadr(fd) != sLfunction) if (fun->s.s_gfdef == OBJNULL || fun->s.s_mflag) FEundefined_function(fun); else { vs_base = vs_top; vs_push(fun->s.s_gfdef); } else { vs_base = vs_top; vs_push(MMcaddr(fd)); } } else if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { vs_base = vs_top; vs_push(MMcdr(fun)); vs_base[0] = MMcons(lex_env[2], vs_base[0]); vs_base[0] = MMcons(lex_env[1], vs_base[0]); vs_base[0] = MMcons(lex_env[0], vs_base[0]); vs_base[0] = MMcons(sSlambda_closure, vs_base[0]); } else FEinvalid_function(fun); } LFD(Lsymbol_value)(void) { object sym; check_arg(1); sym = vs_base[0]; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_dbind == OBJNULL) FEunbound_variable(sym); else vs_base[0] = sym->s.s_dbind; } LFD(Lboundp)(void) { object sym; check_arg(1); sym=vs_base[0]; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_dbind == OBJNULL) vs_base[0] = Cnil; else vs_base[0] = Ct; } LFD(Lmacro_function)(void) { check_arg(1); if (type_of(vs_base[0]) != t_symbol) not_a_symbol(vs_base[0]); if (vs_base[0]->s.s_gfdef != OBJNULL && vs_base[0]->s.s_mflag) vs_base[0] = vs_base[0]->s.s_gfdef; else vs_base[0] = Cnil; } LFD(Lspecial_operator_p)(void) { check_arg(1); if (type_of(vs_base[0]) != t_symbol) not_a_symbol(vs_base[0]); if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) vs_base[0] = Ct; else vs_base[0] = Cnil; } void gcl_init_reference(void) { make_function("SYMBOL-FUNCTION", Lsymbol_function); make_function("FBOUNDP", Lfboundp); sLquote=make_special_form("QUOTE", Fquote); sLfunction = make_special_form("FUNCTION", Ffunction); make_function("SYMBOL-VALUE", Lsymbol_value); make_function("BOUNDP", Lboundp); make_function("MACRO-FUNCTION", Lmacro_function); make_function("SPECIAL-OPERATOR-P", Lspecial_operator_p); } gcl-2.6.14/o/faslhp800.c0000755000175000017500000000753414360276512013116 0ustar cammcamm/* round up i to be a multiple of (n) */ #define ROUND_UP(i,n) ((((int) (i) + n-1)/(n)) *(n)) #define MAXPATHLEN 512 int init_address = 0; #ifdef HPUX_SOM #include #define GET_HEADERS(fp) \ struct header hdr; \ struct som_exec_auxhdr somhdr; \ if (sizeof(hdr) !=fread(&hdr,1,sizeof(hdr),fp)) \ {FEerror("could not read header",0);} \ if (hdr.aux_header_size) \ {fseek(fp,hdr.aux_header_location,0); \ if (sizeof(somhdr) != fread(&somhdr,1,sizeof(somhdr),fp)) \ {FEerror("could not read header",0);}} \ else { somhdr.exec_tsize=0;somhdr.exec_dsize=0;somhdr.exec_bsize=0;} #define SET_TOTAL_SPACE(total,fp) \ total= ROUND_UP(somhdr.exec_tsize,sizeof(double)) \ + somhdr.exec_dsize + somhdr.exec_bsize;\ #define READ_FASL_TO_MEMORY(memory,fp) \ do{ char *p = memory->cfd.cfd_start; \ init_address = ((char *)somhdr.exec_entry - p); \ if (init_address > 1000) printf("entry is offset at %x(%d)",init_address); \ fseek(fp,somhdr.exec_tfile,0) ; \ fread(p,1,somhdr.exec_tsize,fp); \ fseek(fp,somhdr.exec_dfile,0) ; \ if ((int)(p + *data_off) != somhdr.exec_dmem) \ FEerror("bad data offset",0);\ fread(p+ *data_off,1, \ somhdr.exec_dsize,fp); \ }while(0) #define TXT_ALIGN 4096 #undef BSD #endif #ifdef BSD #include #define GET_HEADERS(fp) \ struct exec hdr; fseek(fp,0,0);\ fread(&hdr,1,sizeof(hdr),fp); \ #define SET_TOTAL_SPACE(total,fp) \ total = hdr.a_txtsize + hdr.a_datasize + header.a_bss; #define READ_FASL_TO_MEMORY(memory,fp) \ fseek(fp,sizeof(struct header) ,0); \ fread(memory->cfd.cfd_start,1,memory->cfd.cfd_size,fp); \ #endif read_text_and_data(memory,fp,data_off) object memory; FILE *fp; int *data_off; { int total; GET_HEADERS(fp); SET_TOTAL_SPACE(total,fp); *data_off = ROUND_UP(somhdr.exec_tsize,sizeof(double)); if (total > memory->cfd.cfd_size) { memory->cfd.cfd_size = total; return 0;} READ_FASL_TO_MEMORY(memory,fp); return 1; } #ifndef TXT_ALIGN #define TXT_ALIGN sizeof(double) #endif static fasload_help(faslfile,lib_string) object faslfile; char *lib_string; { char filename[MAXPATHLEN],tmpfile[MAXPATHLEN]; char command [2*MAXPATHLEN]; int total; object memory ; FILE *fp; faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); fp = faslfile->sm.sm_fp; { int data_off = 0; GET_HEADERS(fp); SET_TOTAL_SPACE(total,fp); memory=alloc_object(t_cfdata); memory->cfd.cfd_self = 0; memory->cfd.cfd_start = 0; memory->cfd.cfd_size = total; sprintf(tmpfile,"/tmp/fasl%d",getpid()); AGAIN: memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, memory->cfd.cfd_size,TXT_ALIGN); coerce_to_filename(faslfile, filename); LD_COMMAND(command, kcl_self, memory->cfd.cfd_start, filename, (lib_string ? lib_string : " "), tmpfile); if (system(command) != 0) { FEerror("The linkage editor failed.", 0);} if(symbol_value(sLAload_verboseA)==sLAload_verboseA) { printf("%s\n",command); fflush(stdout);} {FILE *fp1 = fopen(tmpfile,"r"); if (fp1==0) {FEerror("Couldn't open tmpfile",0);} if(read_text_and_data(memory,fp1,&data_off) ==0) {fclose(fp1); goto AGAIN;} fclose(fp1); }} unlink(tmpfile); SEEK_TO_END_OFILE(fp); call_init(init_address,memory,read_fasl_vector(faslfile),0); close_stream (faslfile); if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %x ",memory->cfd.cfd_start); return(memory->cfd.cfd_size); } fasload(faslfile) object faslfile; {return fasload_help(faslfile,0);} #define FASLINK siLfaslink() { object *base = vs_base; check_arg(2); vs_base[0] = make_fixnum(fasload_help(base[0],object_to_string(base[1]))); printf("done link"); fflush(stdout); vs_top = vs_base+1; return ; } int faslink(faslfile, ldargstring) object faslfile, ldargstring; {printf("later");} gcl-2.6.14/o/sfaslmacho.c0000644000175000017500000002573714360276512013533 0ustar cammcamm#include #include #include #include #include #include #include #include #include #include #ifdef _LP64 #define mach_header mach_header_64 #define nlist nlist_64 #define segment_command segment_command_64 #undef LC_SEGMENT #define LC_SEGMENT LC_SEGMENT_64 #define section section_64 #undef MH_MAGIC #define MH_MAGIC MH_MAGIC_64 #endif #ifndef S_16BYTE_LITERALS #define S_16BYTE_LITERALS 0 #endif #define ALLOC_SEC(sec) ({ul _fl=sec->flags&SECTION_TYPE;\ _fl<=S_SYMBOL_STUBS || _fl==S_16BYTE_LITERALS;}) #define LOAD_SEC(sec) ({ul _fl=sec->flags&SECTION_TYPE;\ (_fl<=S_SYMBOL_STUBS || _fl==S_16BYTE_LITERALS) && _fl!=S_ZEROFILL;}) #define MASK(n) (~(~0ULL << (n))) typedef unsigned long ul; #ifdef STATIC_RELOC_VARS STATIC_RELOC_VARS #endif static int ovchk(ul v,ul m) { m|=m>>1; v&=m; return (!v || v==m); } static int store_val(ul *w,ul m,ul v) { massert(ovchk(v,~m)); *w=(v&m)|(*w&~m); return 0; } static int add_val(ul *w,ul m,ul v) { return store_val(w,m,v+(*w&m)); } #ifndef _LP64 /*redirect trampolines gcc-4.0 gives no reloc for stub sections on x86 only*/ static int redirect_trampoline(struct relocation_info *ri,ul o,ul rel, struct section *sec1,ul *io1,struct nlist *n1,ul *a) { struct section *js=sec1+ri->r_symbolnum-1; if (ri->r_extern) return 0; if ((js->flags&SECTION_TYPE)!=S_SYMBOL_STUBS) return 0; if (ri->r_pcrel) o+=rel; o-=js->addr; massert(!(o%js->reserved2)); o/=js->reserved2; massert(o>=0 && osize/js->reserved2); *a=n1[io1[js->reserved1+o]].n_value; ri->r_extern=1; return 0; } #endif static int relocate(struct relocation_info *ri,struct section *sec, struct section *sec1,ul start,ul *io1,struct nlist *n1,ul *got,ul *gote) { struct scattered_relocation_info *sri=(void *)ri; ul *q=(void *)(sec->addr+(sri->r_scattered ? sri->r_address : ri->r_address)); ul a,rel=(ul)(q+1); if (sri->r_scattered) a=sri->r_value; else if (ri->r_extern) a=n1[ri->r_symbolnum].n_value; else a=start; switch(sri->r_scattered ? sri->r_type : ri->r_type) { #include RELOC_H default: FEerror("Unknown reloc type\n",0); break; } return 0; } static int relocate_symbols(struct nlist *n1,struct nlist *ne,char *st1,ul start) { struct nlist *n; struct node *nd; for (n=n1;nn_sect) n->n_value+=start; else if ((nd=find_sym_ptable(st1+n->n_un.n_strx))) n->n_value=nd->address; else if (n->n_type&(N_PEXT|N_EXT)) massert(!emsg("Unrelocated non-local symbol: %s\n",st1+n->n_un.n_strx)); return 0; } static int find_init_address(struct nlist *n1,struct nlist *ne,const char *st1,ul *init) { struct nlist *n; for (n=n1;nn_un.n_strx,5);n++); massert(nn_value; return 0; } static object load_memory(struct section *sec1,struct section *sece,void *v1, ul *p,ul **got,ul **gote,ul *start) { ul sz,gsz,sa,ma,a,fl; struct section *sec; object memory; BEGIN_NO_INTERRUPT; for (*p=sz=ma=0,sa=-1,sec=sec1;secaddraddr; ma=1<align; } a=sec->addr+sec->size; if (szflags&SECTION_TYPE; if (fl==S_NON_LAZY_SYMBOL_POINTERS || fl==S_LAZY_SYMBOL_POINTERS) *p+=sec->size*sizeof(struct relocation_info)/sizeof(void *); } ma=ma>sizeof(struct contblock) ? ma-1 : 0; sz+=ma; gsz=0; if (**got) { gsz=(**got+1)*sizeof(**got)-1; sz+=gsz; } memory=new_cfdata(); memory->cfd.cfd_size=sz; memory->cfd.cfd_start=alloc_code_space(sz,-1UL); a=(ul)memory->cfd.cfd_start; a=(a+ma)&~ma; for (sec=sec1;secaddr+=a; if (LOAD_SEC(sec)) memcpy((void *)sec->addr,v1+sec->offset,sec->size); } if (**got) { sz=**got; *got=(void *)memory->cfd.cfd_start+memory->cfd.cfd_size-gsz; gsz=sizeof(**got)-1; *got=(void *)(((ul)*got+gsz)&~gsz); *gote=*got+sz; } *start=a; END_NO_INTERRUPT; return memory; } static int parse_file(void *v1, struct section **sec1,struct section **sece, struct nlist **n1,struct nlist **ne, char **st1,char **ste,ul **io1) { struct mach_header *mh; struct load_command *lc; struct symtab_command *sym=NULL; struct dysymtab_command *dsym=NULL; struct segment_command *seg; ul i; void *v=v1; mh=v; v+=sizeof(*mh); for (i=0,*sec1=NULL;(lc=v) && incmds;i++,v+=lc->cmdsize) switch(lc->cmd) { case LC_SEGMENT: if (*sec1 && *sece>*sec1) continue; seg=v; *sec1=(void *)(seg+1); *sece=*sec1+seg->nsects; break; case LC_SYMTAB: massert(!sym); sym=v; *n1=v1+sym->symoff; *ne=*n1+sym->nsyms; *st1=v1+sym->stroff; *ste=*st1+sym->strsize; break; case LC_DYSYMTAB: massert(!dsym); dsym=v; *io1=v1+dsym->indirectsymoff; break; } return 0; } static int set_symbol_stubs(void *v1,struct nlist *n1,struct nlist *ne,ul *uio,const char *st1) { struct mach_header *mh; struct load_command *lc; struct segment_command *seg; struct section *sec1,*sec,*sece; ul i,ns; void *v=v1,*vv; int *io1,*io,*ioe; mh=v; v+=sizeof(*mh); for (i=0;(lc=v) && incmds;i++,v+=lc->cmdsize) switch(lc->cmd) { case LC_SEGMENT: for (seg=v,sec1=sec=(void *)(seg+1),sece=sec1+seg->nsects;secflags&SECTION_TYPE; if (ns!=S_SYMBOL_STUBS && ns!=S_LAZY_SYMBOL_POINTERS && ns!=S_NON_LAZY_SYMBOL_POINTERS) continue; io1=(void *)uio; io1+=sec->reserved1; if (!sec->reserved2) sec->reserved2=sizeof(void *); ioe=io1+sec->size/sec->reserved2; for (io=io1,vv=(void *)sec->addr;ioreserved2,io++) if (*io>=0 && *ioflags&SECTION_TYPE,*io; struct relocation_info *ri,*re; struct scattered_relocation_info *sri; if (fl!=S_NON_LAZY_SYMBOL_POINTERS && fl!=S_LAZY_SYMBOL_POINTERS) return 0; sec->nreloc=sec->size/sizeof(void *); sec->reloff=*p-v1; ri=*p; re=ri+sec->nreloc; *p=re; io1+=sec->reserved1; for (io=io1;rir_symbolnum=*io; ri->r_extern=1; ri->r_address=(io-io1)*sizeof(void *); ri->r_type=GENERIC_RELOC_VANILLA; ri->r_pcrel=0; sri=(void *)ri; sri->r_scattered=0; } return 0; } static int relocate_code(void *v1,struct section *sec1,struct section *sece, void **p,ul *io1,struct nlist *n1,ul *got,ul *gote,ul start) { struct section *sec; struct relocation_info *ri,*re; for (sec=sec1;secreloff,re=ri+sec->nreloc;rin_type & N_STAB) continue; ns++; sl+=strlen(sym->n_un.n_strx+strtab)+1; } c_table.alloc_length=ns; assert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); assert(s=malloc(sl)); for (a=c_table.ptable,sym=sym1;symn_type & N_STAB) || !(sym->n_type & N_EXT)) continue; a->address=sym->n_value; a->string=s; strcpy(s,sym->n_un.n_strx+strtab); a++; s+=strlen(s)+1; } c_table.length=a-c_table.ptable; qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); for (c_table.local_ptable=a,sym=sym1;symn_type & N_STAB) || sym->n_type & N_EXT) continue; a->address=sym->n_value; a->string=s; strcpy(s,sym->n_un.n_strx+strtab); a++; s+=strlen(s)+1; } c_table.local_length=a-c_table.local_ptable; qsort(c_table.local_ptable,c_table.local_length,sizeof(*c_table.local_ptable),node_compare); massert(c_table.alloc_length==c_table.length+c_table.local_length); massert(!un_mmap(addr,addre)); massert(!fclose(f)); return 0; } int seek_to_end_ofile(FILE *f) { struct mach_header *mh; struct load_command *lc; struct symtab_command *st=NULL; void *addr,*addre; int i; massert(addr=get_mmap(f,&addre)); mh=addr; lc=addr+sizeof(*mh); for (i=0;incmds;i++,lc=(void *)lc+lc->cmdsize) if (lc->cmd==LC_SYMTAB) { st=(void *) lc; break; } massert(st); fseek(f,st->stroff+st->strsize,SEEK_SET); massert(!un_mmap(addr,addre)); return 0; } #ifndef GOT_RELOC #define GOT_RELOC(a) 0 #endif static int label_got_symbols(void *v1,struct section *sec,struct nlist *n1,struct nlist *ne,ul *gs) { struct relocation_info *ri,*re; struct nlist *n; *gs=0; for (n=n1;nn_desc=0; for (ri=v1+sec->reloff,re=ri+sec->nreloc;rir_extern); n=n1+ri->r_symbolnum; if (!n->n_desc) n->n_desc=++*gs; } return 0; } static int clear_protect_memory(object memory) { void *p,*pe; p=(void *)((unsigned long)memory->cfd.cfd_start & ~(PAGESIZE-1)); pe=(void *)((unsigned long)(memory->cfd.cfd_start+memory->cfd.cfd_size + PAGESIZE-1) & ~(PAGESIZE-1)); return gcl_mprotect(p,pe-p,PROT_READ|PROT_WRITE|PROT_EXEC); } int fasload(object faslfile) { FILE *fp; ul init_address=-1; object memory; void *v1,*ve,*p; struct section *sec1,*sece=NULL; struct nlist *n1=NULL,*ne=NULL; char *st1=NULL,*ste=NULL; ul gs,*got=&gs,*gote,*io1=NULL,rls,start; fp = faslfile->sm.sm_fp; massert(v1=get_mmap(fp,&ve)); parse_file(v1,&sec1,&sece,&n1,&ne,&st1,&ste,&io1); label_got_symbols(v1,sec1,n1,ne,got); massert(memory=load_memory(sec1,sece,v1,&rls,&got,&gote,&start)); massert(p=alloca(rls)); relocate_symbols(n1,ne,st1,start); find_init_address(n1,ne,st1,&init_address); relocate_code(v1,sec1,sece,&p,io1,n1,got,gote,start); fseek(fp,(void *)ste-v1,SEEK_SET); massert(!clear_protect_memory(memory)); #ifdef CLEAR_CACHE CLEAR_CACHE; #endif massert(!un_mmap(v1,ve)); init_address-=(ul)memory->cfd.cfd_start; call_init(init_address,memory,faslfile); if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %p ",memory->cfd.cfd_start); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.6.14/o/regexp.h0000755000175000017500000000142714360276512012703 0ustar cammcamm#ifndef _REGEXP #define _REGEXP 1 #define NSUBEXP 19 typedef struct regexp { char *startp[NSUBEXP]; char *endp[NSUBEXP]; char regstart; /* Internal use only. */ char reganch; /* Internal use only. */ char *regmust; /* Internal use only. */ int regmlen; /* Internal use only. */ unsigned char regmaybe_boyer; char program[1]; /* Unwarranted chumminess with compiler. */ } regexp; #if __STDC__ == 1 #define _ANSI_ARGS_(x) x #else #define _ANSI_ARGS_(x) () #endif /* extern regexp *regcomp _ANSI_ARGS_((char *exp)); */ /* extern int regexec _ANSI_ARGS_((regexp *prog, char *string, char *start,int length )); */ extern void regsub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); #ifndef regerror extern void regerror _ANSI_ARGS_((char *msg)); #endif #endif /* REGEXP */ gcl-2.6.14/o/pathname.d0000755000175000017500000000712414360276512013202 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* pathname.d IMPLEMENTATION-DEPENTENT This file contains those functions that interpret namestrings. */ #include #include "include.h" DEFUN_NEW("C-SET-T-TT",object,fSc_set_t_tt,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum y),"") { x->d.tt=y; RETURN1(x); } DEFUN_NEW("C-T-TT",object,fSc_t_tt,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1((object)(fixnum)x->d.tt); } DEFUN_NEW("C-SET-PATHNAME-NAMESTRING",object,fSc_set_pathname_namestring,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { check_type_pathname(&x); x->pn.pn_namestring=y; RETURN1(x); } DEFUN_NEW("C-PATHNAME-HOST",object,fSc_pathname_host,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_host); } DEFUN_NEW("C-PATHNAME-DEVICE",object,fSc_pathname_device,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_device); } DEFUN_NEW("C-PATHNAME-DIRECTORY",object,fSc_pathname_directory,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_directory); } DEFUN_NEW("C-PATHNAME-NAME",object,fSc_pathname_name,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_name); } DEFUN_NEW("C-PATHNAME-TYPE",object,fSc_pathname_type,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_type); } DEFUN_NEW("C-PATHNAME-VERSION",object,fSc_pathname_version,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_version); } DEFUN_NEW("C-PATHNAME-NAMESTRING",object,fSc_pathname_namestring,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_pathname(&x); RETURN1(x->pn.pn_namestring); } DEFUN_NEW("C-STREAM-OBJECT0",object,fSc_stream_object0,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(x->sm.sm_object0); } DEFUN_NEW("C-STREAM-OBJECT1",object,fSc_stream_object1,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(x->sm.sm_object1); } DEFUN_NEW("C-SET-STREAM-OBJECT0",object,fSc_set_stream_object0,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { x->sm.sm_object0=y; RETURN1(x); } DEFUN_NEW("C-SET-STREAM-OBJECT1",object,fSc_set_stream_object1,SI,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { x->sm.sm_object1=y; RETURN1(x); } DEFUN_NEW("INIT-PATHNAME",object,fSinit_pathname,SI,7,7,NONE,OO,OO,OO,OO, (object host,object device,object directory,object name,object type,object version,object namestring),"") { object x=alloc_object(t_pathname); x->pn.pn_host=host; x->pn.pn_device=device; x->pn.pn_directory=directory; x->pn.pn_name=name; x->pn.pn_type=type; x->pn.pn_version=version; x->pn.pn_namestring=namestring; RETURN1(x); } DEFUN_NEW("PATHNAMEP",object,fLpathnamep,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_pathname ? Ct : Cnil); } void gcl_init_pathname(void) { } void gcl_init_pathname_function(void) { } gcl-2.6.14/o/before_init.c0000755000175000017500000000266014360276512013671 0ustar cammcamm#include "all.h" #include "funlink.h" #define SI 0 #define LISP 1 #define KEYWORD 2 #define NONE 0 void SI_makefun(),LISP_makefun(),error(); #define MAKEFUN(pack,string,fname,argd) \ (pack == SI ? SI_makefun : pack == LISP ? LISP_makefun : error)(string,fname,argd) #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} #undef DEFUNO #define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} #undef DEFCOMP #define DEFCOMP(type, fun) Ineed_in_image(fun); #undef DEFVAR #define DEFVAR(name,cname,pack,val) \ { extern obj cname; \ cname = (pack == LISP ? make_special(name,val) : \ pack == SI ? make_si_special(name,val): \ (error(name,val),(obj)0));} #undef DEFCONST #define DEFCONST(name,cname,pack,val) \ { extern obj cname; \ cname = (pack == LISP ? make_constant(name,val) : \ pack == SI ? make_si_constant(name,val): \ (error(name,val),(obj)0));} #undef DEF_ORDINARY #define DEF_ORDINARY(name,cname,pack) \ { extern obj cname ; cname = (pack == LISP ? make_ordinary(name) : \ pack == SI ? make_si_ordinary(name): \ pack == KEYWORD ? make_keyword(name): \ (error(name),(obj)0));} #undef DEF_INIT #define DEF_INIT(x) x gcl-2.6.14/o/block.c0000755000175000017500000000522514360276512012476 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. sLchelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* block.c blocks and exits */ #include "include.h" static void FFN(Fblock)(VOL object args) { object *oldlex = lex_env; object id; object body; object *top; if(endp(args)) FEtoo_few_argumentsF(args); lex_copy(); id = alloc_frame_id(); vs_push(id); lex_block_bind(MMcar(args), id); vs_popp; frs_push(FRS_CATCH, id); if (nlj_active) nlj_active = FALSE; else { body = MMcdr(args); if (endp(body)) { vs_base = vs_top; vs_push(Cnil); } else { top = vs_top; do { vs_top = top; eval(MMcar(body)); body = MMcdr(body); } while (!endp(body)); } } frs_pop(); lex_env = oldlex; } static void FFN(Freturn_from)(object args) { object lex_block; frame_ptr fr; if (endp(args)) FEtoo_few_argumentsF(args); if (!endp(MMcdr(args)) && !endp(MMcddr(args))) FEtoo_many_argumentsF(args); lex_block = lex_block_sch(MMcar(args)); if (MMnull(lex_block)) FEerror("The block name ~S is undefined.", 1, MMcar(args)); fr = frs_sch(MMcaddr(lex_block)); if(fr == NULL) FEerror("The block ~S is missing.", 1, MMcar(args)); if(endp(MMcdr(args))) { vs_base = vs_top; vs_push(Cnil); } else eval(MMcadr(args)); unwind(fr, MMcaddr(lex_block)); /* never reached */ } static void FFN(Freturn)(object args) { object lex_block; frame_ptr fr; if(!endp(args) && !endp(MMcdr(args))) FEtoo_many_argumentsF(args); lex_block = lex_block_sch(Cnil); if (MMnull(lex_block)) FEerror("The block name ~S is undefined.", 1, Cnil); fr = frs_sch(MMcaddr(lex_block)); if (fr == NULL) FEerror("The block ~S is missing.", 1, Cnil); if(endp(args)) { vs_base = vs_top; vs_push(Cnil); } else eval(MMcar(args)); unwind(fr, MMcaddr(lex_block)); /* never reached */ } void gcl_init_block(void) { sLblock = make_special_form("BLOCK", Fblock); enter_mark_origin(&sLblock); make_special_form("RETURN-FROM", Freturn_from); make_special_form("RETURN", Freturn); } gcl-2.6.14/o/big.c0000755000175000017500000000767314360276512012156 0ustar cammcamm /* Copyright William F. Schelter 1991 Bignum routines. num_arith.c: add_int_big num_arith.c: big_minus num_arith.c: big_plus num_arith.c: big_quotient_remainder num_arith.c: big_sign num_arith.c: big_times num_arith.c: complement_big num_arith.c: copy_big num_arith.c: div_int_big num_arith.c: mul_int_big num_arith.c: normalize_big num_arith.c: normalize_big_to_object num_arith.c: stretch_big num_arith.c: sub_int_big num_comp.c: big_compare num_comp.c: big_sign num_log.c: big_sign num_log.c: copy_to_big num_log.c: normalize_big num_log.c: normalize_big_to_object num_log.c: stretch_big num_pred.c: big_sign number.c: big_to_double predicate.c: big_compare typespec.c: big_sign print.d: big_minus print.d: big_sign print.d: big_zerop print.d: copy_big print.d: div_int_big read.d: add_int_big read.d: big_to_double read.d: complement_big read.d: mul_int_big read.d: normalize_big read.d: normalize_big_to_object */ #define remainder gclremainder #define NEED_MP_H #include #include #include "include.h" #ifdef STATIC_FUNCTION_POINTERS static void* alloc_relblock_static (size_t n) {return alloc_relblock (n);} static void* alloc_contblock_static(size_t n) {return alloc_contblock(n);} #endif void* (*gcl_gmp_allocfun)(size_t)=FFN(alloc_relblock); int gmp_relocatable=1; DEFUN_NEW("SET-GMP-ALLOCATE-RELOCATABLE",object,fSset_gmp_allocate_relocatable,SI,1,1,NONE,OO,OO,OO,OO, (object flag),"Set the allocation to be relocatble ") { if (flag == Ct) { gcl_gmp_allocfun = FFN(alloc_relblock); gmp_relocatable=1; } else { gcl_gmp_allocfun = FFN(alloc_contblock); gmp_relocatable=0; } RETURN1(flag); } #ifndef GMP_USE_MALLOC object big_gcprotect; object big_fixnum1; #include "gmp.c" void gcl_init_big1(void) { mp_set_memory_functions( gcl_gmp_alloc,gcl_gmp_realloc,gcl_gmp_free); jmp_gmp=0; #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) Mersenne_Twister_Generator_Noseed.b=__gmp_randget_mt; Mersenne_Twister_Generator_Noseed.c=__gmp_randclear_mt; Mersenne_Twister_Generator_Noseed.d=__gmp_randiset_mt; #endif } #else gcl_init_big1() { } #endif #ifdef GMP #include "gmp_big.c" #else #include "pari_big.c" #endif int big_sign(object x) { return BIG_SIGN(x); } void set_big_sign(object x, int sign) { SET_BIG_SIGN(x,sign); } void zero_big(object x) { ZERO_BIG(x); } #ifndef HAVE_MP_COERCE_TO_STRING double digitsPerBit[37]={ 0,0, 1.0, /* 2 */ 0.6309297535714574, /* 3 */ 0.5, /* 4 */ 0.4306765580733931, /* 5 */ 0.3868528072345416, /* 6 */ 0.3562071871080222, /* 7 */ 0.3333333333333334, /* 8 */ 0.3154648767857287, /* 9 */ 0.3010299956639811, /* 10 */ 0.2890648263178878, /* 11 */ 0.2789429456511298, /* 12 */ 0.2702381544273197, /* 13 */ 0.2626495350371936, /* 14 */ 0.2559580248098155, /* 15 */ 0.25, /* 16 */ 0.244650542118226, /* 17 */ 0.2398124665681315, /* 18 */ 0.2354089133666382, /* 19 */ 0.2313782131597592, /* 20 */ 0.227670248696953, /* 21 */ 0.2242438242175754, /* 22 */ 0.2210647294575037, /* 23 */ 0.2181042919855316, /* 24 */ 0.2153382790366965, /* 25 */ 0.2127460535533632, /* 26 */ 0.2103099178571525, /* 27 */ 0.2080145976765095, /* 28 */ 0.2058468324604345, /* 29 */ 0.2037950470905062, /* 30 */ 0.2018490865820999, /* 31 */ 0.2, /* 32 */ 0.1982398631705605, /* 33 */ 0.1965616322328226, /* 34 */ 0.1949590218937863, /* 35 */ 0.1934264036172708, /* 36 */ }; object coerce_big_to_string(x,printbase) int printbase; object x; { int i; int sign=big_sign(x); object b; int size = (int)((ceil(MP_SIZE_IN_BASE2(MP(x))* digitsPerBit[printbase]))+.01); char *q,*p = alloca(size+5); q=p; if(sign<=0) { *q++ = '-'; b=big_minus(x); } else { b=copy_big(x); } while (!big_zerop(b)) *q++=digit_weight(div_int_big(printbase, b),printbase); *q++=0; object ans = alloc_simple_string(q-p); ans->ust.ust_self=alloc_relblock(ans->ust.ust_dim); bcopy(ans->ust.ust_self,p,ans->ust.ust_dim); ans->ust.ust_fillp=ans->ust.ust_dim-1; return ans; } #endif gcl-2.6.14/o/prog.c0000755000175000017500000001347614360276512012362 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* prog.c */ #include "include.h" /* use of VS in tagbody: old_top -> | id | | lex0 | | lex1 | | lex2 | tinf_base -> | tag1 | where 'bodyi' is the part of tag-body | body1 | that follows the tag 'tagi'. | : | : i.e. | : | tag-body | tagn | = (...tag1..........tagn.............) | bodyn | | |<- bodyn ->| new_top -> | | | | VS |<-------- body1 -------->| */ FFD(Ftagbody)(object body) { object *old_top = vs_top; object * VOL new_top; object *tinf; object * VOL tinf_base; object *env = lex_env; object id = alloc_frame_id(); VOL object bodysv = body; object label; enum type item_type; vs_push(id); lex_copy(); tinf_base = vs_top; while (!endp(body)) { label = MMcar(body); item_type = type_of(label); if (item_type == t_symbol || item_type == t_fixnum || item_type == t_bignum) { lex_tag_bind(label, id); vs_push(label); vs_push(MMcdr(body)); } body = MMcdr(body); } new_top = vs_top; frs_push(FRS_CATCH, id); body = bodysv; if (nlj_active) { label = cdr(nlj_tag); nlj_active = FALSE; for(tinf = tinf_base; tinf < new_top && !eql(tinf[0],label); tinf += 2) ; if (tinf >= new_top) FEerror("Someone tried to RETURN-FROM a TAGBODY.",0); body = tinf[1]; } while (body != Cnil) { vs_top = new_top; item_type = type_of(MMcar(body)); if (item_type != t_symbol && item_type != t_fixnum && item_type != t_bignum) eval(MMcar(body)); body = MMcdr(body); } frs_pop(); lex_env = env; vs_base = old_top; vs_top = old_top+1; vs_base[0] = Cnil; } static void FFN(Fprog)(VOL object arg) { object *oldlex = lex_env; struct bind_temp *start; object body; bds_ptr old_bds_top = bds_top; if (endp(arg)) FEtoo_few_argumentsF(arg); make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } start = (struct bind_temp *)vs_top; let_var_list(arg->c.c_car); body = let_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top); vs_top = (object *)start; vs_push(body); Ftagbody(body); END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } static void FFN(FprogA)(VOL object arg) { object *oldlex = lex_env; struct bind_temp *start; object body; bds_ptr old_bds_top = bds_top; if (endp(arg)) FEtoo_few_argumentsF(arg); make_nil_block(); if (nlj_active) { nlj_active = FALSE; goto END; } start = (struct bind_temp *) vs_top; let_var_list(arg->c.c_car); body = letA_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top); vs_top = (object *)start; vs_push(body); Ftagbody(body); END: bds_unwind(old_bds_top); frs_pop(); lex_env = oldlex; } static void FFN(Fgo)(object args) { object lex_tag; frame_ptr fr; if (endp(args)) FEtoo_few_argumentsF(args); if (!endp(MMcdr(args))) FEtoo_many_argumentsF(args); lex_tag = lex_tag_sch(MMcar(args)); if (MMnull(lex_tag)) FEerror("~S is an undefined tag.", 1, MMcar(args)); fr = frs_sch(MMcaddr(lex_tag)); if (fr == NULL) FEerror("The tag ~S is missing.", 1, MMcar(args)); vs_push(MMcons(MMcaddr(lex_tag), MMcar(lex_tag))); vs_base = vs_top; unwind(fr,vs_top[-1]); /* never reached */ } static void FFN(Fprogv)(object args) { object *top; object symbols; object values; bds_ptr old_bds_top; object var; if (endp(args) || endp(MMcdr(args))) FEtoo_few_argumentsF(args); old_bds_top=bds_top; top=vs_top; eval(MMcar(args)); vs_top=top; symbols=vs_base[0]; vs_push(symbols); eval(MMcadr(args)); vs_top=top+1; values=vs_base[0]; vs_push(values); while (!endp(symbols)) { var = MMcar(symbols); if (type_of(var)!=t_symbol) not_a_symbol(var); if ((enum stype)var->s.s_stype == stp_constant) FEerror("Cannot bind the constant ~S.", 1, var); if (endp(values)) { bds_bind(var, OBJNULL); } else { bds_bind(var, MMcar(values)); values=MMcdr(values); } symbols=MMcdr(symbols); } Fprogn(MMcddr(args)); bds_unwind(old_bds_top); } FFD(Fprogn)(object body) { if(endp(body)) { vs_base=vs_top; vs_push(Cnil); } else { object *top=vs_top; do { vs_top=top; eval(MMcar(body)); body=MMcdr(body); } while (!endp(body)); } } static void FFN(Fprog1)(object arg) { object *top = vs_top; if(endp(arg)) FEtoo_few_argumentsF(arg); eval(MMcar(arg)); vs_top = top; vs_push(vs_base[0]); for(arg = MMcdr(arg); !endp(arg); vs_top = top+1, arg = MMcdr(arg)) eval(MMcar(arg)); vs_base = top; vs_top = top + 1; } static void FFN(Fprog2)(object arg) { object *top = vs_top; if(endp(arg) || endp(MMcdr(arg))) FEtoo_few_argumentsF(arg); eval(MMcar(arg)); vs_top = top; arg = MMcdr(arg); eval(MMcar(arg)); vs_top = top; vs_push(vs_base[0]); for(arg = MMcdr(arg); !endp(arg); vs_top = top+1, arg = MMcdr(arg)) eval(MMcar(arg)); vs_base = top; vs_top = top+1; } void gcl_init_prog(void) { make_special_form("TAGBODY", Ftagbody); make_special_form("PROG", Fprog); make_special_form("PROG*", FprogA); make_special_form("GO", Fgo); make_special_form("PROGV", Fprogv); sLprogn=make_special_form("PROGN",Fprogn); make_special_form("PROG1",Fprog1); make_special_form("PROG2",Fprog2); } gcl-2.6.14/o/sfaslelf.c0000755000175000017500000003044114360276512013201 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ #include #include #include #include #include #include #include #include #include "gclincl.h" #if SIZEOF_LONG == 4 #define Elfw 32 #else #define Elfw 64 #endif #define Elf Mjoin(Elf,Elfw) #define ELF Mjoin(ELF,Elfw) #define Ehdr Mjoin(Elf,_Ehdr) #define Shdr Mjoin(Elf,_Shdr) #define Sym Mjoin(Elf,_Sym) #define Rel Mjoin(Elf,_Rel) #define Rela Mjoin(Elf,_Rela) #define Word Elf32_Word #define ELF_R_SYM(a) Mjoin(ELF,_R_SYM)(a) #define ELF_R_TYPE(a) Mjoin(ELF,_R_TYPE)(a) #define ELF_R_INFO(a,b) Mjoin(ELF,_R_INFO)(a,b) #define ELF_ST_BIND(a) Mjoin(ELF,_ST_BIND)(a) #define ELF_ST_TYPE(a) Mjoin(ELF,_ST_TYPE)(a) #define ELF_ST_INFO(a,b) Mjoin(ELF,_ST_INFO)(a,b) #define ELF_ST_VISIBILITY(a) Mjoin(ELF,_ST_VISIBILITY)(a) #define ulmax(a_,b_) ({ul _a=a_,_b=b_;_a<_b ? _b : _a;}) #define ALLOC_SEC(sec) (sec->sh_flags&SHF_ALLOC && (sec->sh_type==SHT_PROGBITS || sec->sh_type==SHT_NOBITS)) #define LOAD_SEC(sec) (sec->sh_flags&SHF_ALLOC && sec->sh_type==SHT_PROGBITS) #define LOAD_SYM(sym,st1) (sym->st_value && (EXT_SYM(sym,st1)||LOCAL_SYM(sym))) #define EXT_SYM(sym,st1) (ELF_ST_BIND(sym->st_info)==STB_GLOBAL||ELF_ST_BIND(sym->st_info)==STB_WEAK||LOAD_SYM_BY_NAME(sym,st1)) #define LOCAL_SYM(sym) ELF_ST_BIND(sym->st_info)==STB_LOCAL #define LOAD_SYM_BY_NAME(sym,st1) 0 #define MASK(n) (~(~0ULL << (n))) typedef unsigned long ul; static Shdr * get_section(char *s,Shdr *sec,Shdr *sece,const char *sn) { for (;secsh_name,s);sec++); return sec>1; v&=m; return (!v || v==m); } static int ovchku(ul v,ul m) { return !(v&=m); } static char *init_section_name=".text"; #ifdef SPECIAL_RELOC_H #include SPECIAL_RELOC_H #endif int store_val(ul *w,ul m,ul v) { *w=(v&m)|(*w&~m); return 0; } int store_vals(ul *w,ul m,ul v) { massert(ovchks(v,~m)); return store_val(w,m,v); } int store_valu(ul *w,ul m,ul v) { massert(ovchku(v,~m)); return store_val(w,m,v); } int add_val(ul *w,ul m,ul v) { return store_val(w,m,v+(*w&m)); } int add_valu(ul *w,ul m,ul v) { return store_valu(w,m,v+(*w&m)); } int add_vals(ul *w,ul m,ul v) { ul l=*w&m,mm; mm=~m; mm|=mm>>1; if (l&mm) l|=mm; return store_val(w,m,v+l); } int add_valsc(ul *w,ul m,ul v) { ul l=*w&m,mm; mm=~m; mm|=mm>>1; if (l&mm) l|=mm; return store_vals(w,m,v+l); } static void relocate(Sym *sym1,void *v,ul a,ul start,ul *got,ul *gote) { Rel *r=v; Sym *sym; ul *where,p,s,tp; where=(void *)start+r->r_offset; p=(ul)where; sym=sym1+ELF_R_SYM(r->r_info); s=sym->st_value; switch((tp=ELF_R_TYPE(r->r_info))) { #include RELOC_H default: massert(!emsg("Unknown reloc type %lu\n", tp)); } } static int find_init_address(Sym *sym,Sym *syme,Shdr *sec1,Shdr *sece, const char *sn,const char *st1,ul *init) { Shdr *sec; for (;symst_shndx; if (sec=sece) continue; if (strcmp(sn+sec->sh_name,init_section_name)) continue; if (memcmp("init_",st1+sym->st_name,4)) continue; *init=sym->st_value; return 0; } return -1; } static int relocate_symbols(Sym *sym,Sym *syme,Shdr *sec1,Shdr *sece,const char *st1) { Shdr *sec; struct node *a; for (;symst_shndx; if (secst_value+=sec->sh_addr; else if ((a=find_sym_ptable(st1+sym->st_name))) sym->st_value=a->address; else if (ELF_ST_BIND(sym->st_info)!=STB_LOCAL) massert(!emsg("Unrelocated non-local symbol: %s\n",st1+sym->st_name)); } return 0; } #ifdef LARGE_MEMORY_MODEL DEFUN_NEW("MARK-AS-LARGE-MEMORY-MODEL",object,fSmark_as_large_memory_model,SI,1,1, NONE,OO,OO,OO,OO,(object x),"") { FILE *f; void *ve; Ehdr *fhp; coerce_to_filename(x,FN1); massert(f=fopen(FN1,"r+")); massert(fhp=get_mmap_shared(f,&ve)); fhp->e_flags|=1; massert(!un_mmap(fhp,ve)); massert(!fclose(f)); return Cnil; } #endif static object load_memory(Shdr *sec1,Shdr *sece,void *v1,ul **got,ul **gote) { object memory; Shdr *sec; ul gsz,sz,a,ma; BEGIN_NO_INTERRUPT; for (sec=sec1,ma=sz=0;secsh_addralign; ma=ma ? ma : a; sz=(sz+a-1)&~(a-1); sec->sh_addr=sz; sz+=sec->sh_size; } ma=ma>sizeof(struct contblock) ? ma-1 : 0; sz+=ma; gsz=0; if (**got) { gsz=(**got+1)*sizeof(**got)-1; sz+=gsz; } memory=new_cfdata(); memory->cfd.cfd_size=sz; memory->cfd.cfd_start=alloc_code_space(sz, #ifdef MAX_DEFAULT_MEMORY_MODEL_CODE_ADDRESS #ifdef LARGE_MEMORY_MODEL (((Ehdr *)v1)->e_flags) ? -1UL : MAX_DEFAULT_MEMORY_MODEL_CODE_ADDRESS #else MAX_DEFAULT_MEMORY_MODEL_CODE_ADDRESS #endif #else -1UL #endif ); a=(ul)memory->cfd.cfd_start; a=(a+ma)&~ma; for (sec=sec1;secsh_addr+=a; if (LOAD_SEC(sec)) memcpy((void *)sec->sh_addr,v1+sec->sh_offset,sec->sh_size); } if (**got) { sz=**got; *got=(void *)memory->cfd.cfd_start+memory->cfd.cfd_size-gsz; gsz=sizeof(**got)-1; *got=(void *)(((ul)*got+gsz)&~gsz); *gote=*got+sz; } END_NO_INTERRUPT; return memory; } static int relocate_code(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,ul *got,ul *gote) { Shdr *jsec,*sec; void *v,*ve; Rela *ra; for (sec=sec1;secsh_info; if (jsec=sece) continue; if (!ALLOC_SEC(jsec)) continue; if (sec->sh_type!=SHT_REL && sec->sh_type!=SHT_RELA) continue; for (v=v1+sec->sh_offset,ve=v+sec->sh_size,ra=v;vsh_entsize,ra=v) relocate(sym1,ra,sec->sh_type==SHT_RELA ? ra->r_addend : 0,jsec->sh_addr,got,gote); } return 0; } static int parse_map(void *v1,Shdr **sec1,Shdr **sece, char **sn,Sym **sym1,Sym **syme,char **st1,ul *end, Sym **dsym1,Sym **dsyme,char **dst1) { Ehdr *fhp; Shdr *sec; fhp=v1; *sec1=v1+fhp->e_shoff; *sece=*sec1+fhp->e_shnum; *sn=v1+(*sec1)[fhp->e_shstrndx].sh_offset; massert(sec=get_section(".symtab",*sec1,*sece,*sn)); *sym1=v1+sec->sh_offset; *syme=*sym1+sec->sh_size/sec->sh_entsize; massert(sec=get_section(".strtab",*sec1,*sece,*sn)); *st1=v1+sec->sh_offset; *dsym1=*dsyme=NULL; *dst1=NULL; if ((sec=get_section(".dynsym",*sec1,*sece,*sn))) { *dsym1=v1+sec->sh_offset; *dsyme=*dsym1+sec->sh_size/sec->sh_entsize; massert(sec=get_section(".dynstr",*sec1,*sece,*sn)); *dst1=v1+sec->sh_offset; } for (*end=fhp->e_shoff+fhp->e_shnum*fhp->e_shentsize,sec=*sec1;sec<*sece;sec++) *end=ulmax(*end,sec->sh_offset+sec->sh_size); return 0; } static int set_symbol_stubs(void *v,Shdr *sec1,Shdr *sece,const char *sn, Sym *ds1,Sym *dse,const char *dst1, Sym *sym1,Sym *syme,const char *st1) { Shdr *sec,*psec; Rel *r; ul np,ps,p; void *ve; #ifdef SPECIAL_RELOC_H massert(!find_special_params(v,sec1,sece,sn,st1,ds1,dse,sym1,syme)); #endif if (!(psec=get_section(".plt",sec1,sece,sn))) return 0; massert((sec=get_section( ".rel.plt",sec1,sece,sn)) || (sec=get_section(".rela.plt",sec1,sece,sn))); np=sec->sh_size/sec->sh_entsize; ps=psec->sh_size/np; v+=sec->sh_offset; ve=v+np*sec->sh_entsize; p=psec->sh_addr+psec->sh_size%np; for (r=v;vsh_entsize,p+=ps,r=v) if (!ds1[ELF_R_SYM(r->r_info)].st_value) ds1[ELF_R_SYM(r->r_info)].st_value=p; return 0; } static int calc_space(ul *ns,ul *sl,Sym *sym1,Sym *syme,const char *st1,Sym *d1,Sym *de,const char *ds1) { Sym *sym,*d; for (sym=sym1;symst_name,ds1+d->st_name);d++); if (dst_name)+1; } return 0; } static int load_ptable(struct node **a,char **s,Sym *sym1,Sym *syme,const char *st1, Sym *d1,Sym *de,const char *ds1,ufixnum lp) { Sym *sym,*d; for (sym=sym1;symst_name,ds1+d->st_name);d++); if (daddress=sym->st_value; (*a)->string=(*s); strcpy((*s),st1+sym->st_name); #ifdef FIX_HIDDEN_SYMBOLS FIX_HIDDEN_SYMBOLS(st1,a,sym1,sym,syme); #endif (*a)++; (*s)+=strlen(*s)+1; } return 0; } static int load_self_symbols() { FILE *f; char *sn,*st1,*s,*dst1; Shdr *sec1,*sece; Sym *sym1,*syme,*dsym1,*dsyme; void *v1,*ve; ul ns,sl,end; struct node *a; massert(f=fopen(kcl_self,"r")); massert(v1=get_mmap(f,&ve)); massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); #ifndef STATIC_LINKING massert(!set_symbol_stubs(v1,sec1,sece,sn,dsym1,dsyme,dst1,sym1,syme,st1)); #endif ns=sl=0; massert(!calc_space(&ns,&sl,dsym1,dsyme,dst1,NULL,NULL,NULL)); massert(!calc_space(&ns,&sl,sym1,syme,st1,dsym1,dsyme,dst1)); c_table.alloc_length=ns; massert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); massert(s=malloc(sl)); a=c_table.ptable; massert(!load_ptable(&a,&s,dsym1,dsyme,dst1,NULL,NULL,NULL,0)); massert(!load_ptable(&a,&s,sym1,syme,st1,dsym1,dsyme,dst1,0)); c_table.length=a-c_table.ptable; qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); c_table.local_ptable=a; massert(!load_ptable(&a,&s,sym1,syme,st1,dsym1,dsyme,dst1,1)); c_table.local_length=a-c_table.local_ptable; qsort(c_table.local_ptable,c_table.local_length,sizeof(*c_table.local_ptable),node_compare); massert(c_table.alloc_length==c_table.length+c_table.local_length); massert(!un_mmap(v1,ve)); massert(!fclose(f)); return 0; } int seek_to_end_ofile(FILE *fp) { void *v1,*ve; Shdr *sec1,*sece; Sym *sym1,*syme,*dsym1,*dsyme; char *sn,*st1,*dst1; ul end; massert(v1=get_mmap(fp,&ve)); massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); massert(!fseek(fp,end,SEEK_SET)); massert(!un_mmap(v1,ve)); return 0; } static int clear_protect_memory(object memory) { void *p,*pe; p=(void *)((unsigned long)memory->cfd.cfd_start & ~(PAGESIZE-1)); pe=(void *)((unsigned long)(memory->cfd.cfd_start+memory->cfd.cfd_size + PAGESIZE-1) & ~(PAGESIZE-1)); return gcl_mprotect(p,pe-p,PROT_READ|PROT_WRITE|PROT_EXEC); } int fasload(object faslfile) { FILE *fp; char *sn,*st1,*dst1; ul init_address=0,end,gs=0,*got=&gs,*gote=got+1; object memory; Shdr *sec1,*sece; Sym *sym1,*syme,*dsym1,*dsyme; void *v1,*ve; fp = faslfile->sm.sm_fp; massert(v1=get_mmap(fp,&ve)); massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); #ifdef SPECIAL_RELOC_H massert(!label_got_symbols(v1,sec1,sece,sym1,syme,st1,sn,got)); #endif massert(memory=load_memory(sec1,sece,v1,&got,&gote)); massert(!relocate_symbols(sym1,syme,sec1,sece,st1)); massert(!find_init_address(sym1,syme,sec1,sece,sn,st1,&init_address)); massert(!relocate_code(v1,sec1,sece,sym1,got,gote)); massert(!fseek(fp,end,SEEK_SET)); massert(!un_mmap(v1,ve)); massert(!clear_protect_memory(memory)); #if defined(HAVE_BUILTIN_CLEAR_CACHE) __builtin___clear_cache((void *)memory->cfd.cfd_start,(void *)memory->cfd.cfd_start+memory->cfd.cfd_size); #elif defined(CLEAR_CACHE) CLEAR_CACHE; #endif init_address-=(ul)memory->cfd.cfd_start; call_init(init_address,memory,faslfile); if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %p ",memory->cfd.cfd_start); return(memory->cfd.cfd_size); } #include "sfasli.c" gcl-2.6.14/o/init_pari.c0000755000175000017500000000355514360276512013366 0ustar cammcamm#define IN_INIT_PARI #define NEED_MP_H #ifndef STANDALONE #include "include.h" #endif #ifdef GMP /* static void */ /* init_pari(void) */ /* { */ /* ; */ /* } */ #else GEN gnil,gzero,gun,gdeux,ghalf,gi; plong lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,0,2,2,1,1,1,0,1,1,1,1}; unsigned plong hiremainder,overflow; #ifdef STANDALONE #define FEerror printf #define make_si_sfun(a,b,c) #endif #define INITIAL_PARI_STACK 400 char initial_pari_stack[400]; our_ulong bot= (our_ulong) initial_pari_stack; our_ulong top = (our_ulong)(initial_pari_stack+INITIAL_PARI_STACK); /* not initted */ our_ulong avma= 0; void err(s) int s; { switch (s) { case errpile: FEerror("Out of bignum stack space, (si::MULTIPLY-BIGNUM-STACK n) to grow",0); case dvmer1: case diver4: case diver2: case diver1: FEerror("Divide by zero",0); case muler1: FEerror("Multiply overflow",0); case moder1: FEerror("Mod by 0",0); default: FEerror("Integer Arithmetic error",0); }} multiply_bignum_stack(n) int n; { int parisize = n* (top - bot); in_saved_avma = 0; if (n> 1) { if (bot != (our_ulong)initial_pari_stack) free(bot); set_pari_stack(parisize); } return parisize; } set_pari_stack(parisize) int parisize; { bot=(plong)malloc(parisize); top = avma = bot + parisize; } static init_pari() { if (avma==0) { make_si_sfun("MULTIPLY-BIGNUM-STACK",multiply_bignum_stack, ARGTYPE1(f_fixnum) | RESTYPE(f_fixnum)); avma = top; } /* room for the permanent things */ gnil = cgeti(2);gnil[1]=2; setpere(gnil,255); gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255); gun = stoi(1); setpere(gun, 255); gdeux = stoi(2); setpere(gdeux, 255); ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255); gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255); /* set_pari_stack(BIGNUM_STACK_SIZE);*/ } #endif gcl-2.6.14/o/symbol.d0000755000175000017500000003471314360276512012716 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* symbol.d */ #include #include "include.h" /*FIXME this symbol is needed my maxima MAKE_SPECIAL*/ void check_type_symbol(object *x) { check_type_sym(x); } static void odd_plist(object); object siSpname; void set_up_string_register(char *s) { string_register->st.st_fillp = string_register->st.st_dim = strlen(s); string_register->st.st_self = s; } object make_symbol(st) object st; { object x; int i; {BEGIN_NO_INTERRUPT; x = alloc_object(t_symbol); x->s.s_dbind = OBJNULL; x->s.s_sfdef = NOT_SPECIAL; x->s.s_fillp = st->st.st_fillp; x->s.s_self = NULL; x->s.s_gfdef = OBJNULL; x->s.s_plist = Cnil; x->s.s_hpack = Cnil; x->s.s_stype = (short)stp_ordinary; x->s.s_mflag = FALSE; vs_push(x); if (raw_image && st->st.st_self < heap_end) x->s.s_self = st->st.st_self; else { x->s.s_self = alloc_relblock(x->s.s_fillp); for (i = 0; i < x->s.s_fillp; i++) x->s.s_self[i] = st->st.st_self[i]; } END_NO_INTERRUPT;} return(vs_pop); } /* Make_ordinary(s) makes an ordinary symbol from C string s and interns it in lisp package as an external symbol. */ #define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size]) object make_ordinary(s) char *s; { int j; object x, l, *ep; vs_mark; set_up_string_register(s); j = pack_hash(string_register); ep = &P_EXTERNAL(lisp_package,j); for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) if (string_eq(l->c.c_car, string_register)) return(l->c.c_car); x = make_symbol(string_register); vs_push(x); x->s.s_hpack = lisp_package; *ep = make_cons(x, *ep); lisp_package->p.p_external_fp ++; vs_reset; return(x); } /* Make_special(s, v) makes a special variable from C string s with initial value v in lisp package. */ object make_special(s, v) char *s; object v; { object x; x = make_ordinary(s); x->s.s_stype = (short)stp_special; x->s.s_dbind = v; return(x); } /* Make_constant(s, v) makes a constant from C string s with constant value v in lisp package. */ object make_constant(s, v) char *s; object v; { object x; x = make_ordinary(s); x->s.s_stype = (short)stp_constant; x->s.s_dbind = v; return(x); } /* Make_si_ordinary(s) makes an ordinary symbol from C string s and interns it in system package as an external symbol. It assumes that the (only) package used by system is lisp. */ object make_si_ordinary(s) char *s; { int j; object x, l, *ep; vs_mark; set_up_string_register(s); j = pack_hash(string_register); ep = & P_EXTERNAL(system_package,j); for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) if (string_eq(l->c.c_car, string_register)) return(l->c.c_car); for (l = P_EXTERNAL(lisp_package,j); type_of(l) == t_cons; l = l->c.c_cdr) if (string_eq(l->c.c_car, string_register)) error("name conflict --- can't make_si_ordinary"); x = make_symbol(string_register); vs_push(x); x->s.s_hpack = system_package; system_package->p.p_external_fp ++; *ep = make_cons(x, *ep); vs_reset; return(x); } /* Make_si_special(s, v) makes a special variable from C string s with initial value v in system package. */ object make_si_special(s, v) char *s; object v; { object x; x = make_si_ordinary(s); x->s.s_stype = (short)stp_special; x->s.s_dbind = v; return(x); } /* Make_si_constant(s, v) makes a constant from C string s with constant value v in system package. */ object make_si_constant(s, v) char *s; object v; { object x; x = make_si_ordinary(s); x->s.s_stype = (short)stp_constant; x->s.s_dbind = v; return(x); } /* Make_keyword(s) makes a keyword from C string s. */ object make_keyword(s) char *s; { int j; object x, l, *ep; vs_mark; set_up_string_register(s); j = pack_hash(string_register); ep = &P_EXTERNAL(keyword_package,j); for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) if (string_eq(l->c.c_car, string_register)) return(l->c.c_car); x = make_symbol(string_register); vs_push(x); x->s.s_hpack = keyword_package; x->s.s_stype = (short)stp_constant; x->s.s_dbind = x; *ep = make_cons(x, *ep); keyword_package->p.p_external_fp ++; vs_reset; return(x); } object symbol_value(s) object s; { /* if (type_of(s) != t_symbol) FEinvalid_variable("~S is not a symbol.", s); */ if (s->s.s_dbind == OBJNULL) FEunbound_variable(s); return(s->s.s_dbind); } object getf(place, indicator, deflt) object place, indicator, deflt; { object l; #define cendp(obj) ((type_of(obj)!=t_cons)) for (l = place; !cendp(l); l = l->c.c_cdr->c.c_cdr) { if (cendp(l->c.c_cdr)) break; if (l->c.c_car == indicator) return(l->c.c_cdr->c.c_car); } if(l==Cnil) return deflt; FEerror("Bad plist ~a",1,place); return Cnil; } object get(s, p, d) object s, p, d; { if (type_of(s) != t_symbol) not_a_symbol(s); return(getf(s->s.s_plist, p, d)); } /* Putf(p, v, i) puts value v for property i to property list p and returns the resulting property list. */ object putf(p, v, i) object p, v, i; { object l; for (l = p; !cendp(l); l = l->c.c_cdr->c.c_cdr) { if (cendp(l->c.c_cdr)) break; if (l->c.c_car == i) { l->c.c_cdr->c.c_car = v; return(p); } } if(l!=Cnil) FEerror("Bad plist ~a",1,p); return listA(3,i,v,p); } object putprop(s, v, p) object s, v, p; { if (type_of(s) != t_symbol) not_a_symbol(s); s->s.s_plist = putf(s->s.s_plist, v, p); return(v); } /* done in the right order for efficient setf.. */ STATD object FFN(sputprop)(s, p, v) object s, v, p; { if (type_of(s) != t_symbol) not_a_symbol(s); s->s.s_plist = putf(s->s.s_plist, v, p); return(v); } #ifdef STATIC_FUNCTION_POINTERS object sputprop(object s, object p, object v) { return FFN(sputprop)(s,p,v); } #endif /* Remf(p, i) removes property i from the property list pointed by p, which is a pointer to an object. The returned value of remf(p, i) is: TRUE if the property existed FALSE otherwise. */ bool remf(p, i) object *p, i; { object l0 = *p; for(; !endp(*p); p = &(*p)->c.c_cdr->c.c_cdr) { if (endp((*p)->c.c_cdr)) odd_plist(l0); if ((*p)->c.c_car == i) { *p = (*p)->c.c_cdr->c.c_cdr; return(TRUE); } } return(FALSE); } object remprop(s, p) object s, p; { if (type_of(s) != t_symbol) not_a_symbol(s); if (remf(&s->s.s_plist, p)) return(Ct); else return(Cnil); } bool keywordp(s) object s; { return(type_of(s) == t_symbol && s->s.s_hpack == keyword_package); /* if (type_of(s) != t_symbol) { vs_push(s); check_type_sym(&vs_head); vs_pop; } if (s->s.s_hpack == OBJNULL) return(FALSE); return(s->s.s_hpack == keyword_package); */ } @(defun get (sym indicator &optional deflt) @ check_type_sym(&sym); @(return `getf(sym->s.s_plist, indicator, deflt)`) @) LFD(Lremprop)() { check_arg(2); check_type_sym(&vs_base[0]); if (remf(&vs_base[0]->s.s_plist, vs_base[1])) vs_base[0] = Ct; else vs_base[0] = Cnil; vs_popp; } LFD(Lsymbol_plist)() { check_arg(1); check_type_sym(&vs_base[0]); vs_base[0] = vs_base[0]->s.s_plist; } @(defun getf (place indicator &optional deflt) @ @(return `getf(place, indicator, deflt)`) @) @(defun get_properties (place indicator_list) object l, m; @ for (l = place; !endp(l); l = l->c.c_cdr->c.c_cdr) { if (endp(l->c.c_cdr)) odd_plist(place); for (m = indicator_list; !endp(m); m = m->c.c_cdr) if (l->c.c_car == m->c.c_car) @(return `l->c.c_car` `l->c.c_cdr->c.c_car` l) } @(return Cnil Cnil Cnil) @) object symbol_name(x) object x; { object y; if (type_of(x)!=t_symbol) FEwrong_type_argument(sLsymbol,x); for (y=x->s.s_plist; type_of(y)==t_cons ; y=y->c.c_cdr->c.c_cdr) {if(y->c.c_car==siSpname) return(y->c.c_cdr->c.c_car);} {BEGIN_NO_INTERRUPT; y = alloc_simple_string(x->s.s_fillp); vs_push(y); if (x->s.s_self < heap_end) y->st.st_self = x->s.s_self; else {int i; y->st.st_self = alloc_relblock(x->s.s_fillp); for (i = 0; i < x->s.s_fillp; i++) y->st.st_self[i] = x->s.s_self[i]; } x->s.s_plist = putf(x->s.s_plist, y, siSpname); vs_popp; END_NO_INTERRUPT; } return(y); } LFD(Lsymbol_name)() { check_arg(1); vs_base[0]=symbol_name(vs_base[0]); } LFD(Lmake_symbol)() { check_arg(1); check_type_string(&vs_base[0]); vs_base[0] = make_symbol(vs_base[0]); } @(defun copy_symbol (sym &optional cp &aux x) @ check_type_sym(&sym); x = make_symbol(sym); if (cp == Cnil) @(return x) x->s.s_stype = sym->s.s_stype; x->s.s_dbind = sym->s.s_dbind; x->s.s_mflag = sym->s.s_mflag; x->s.s_gfdef = sym->s.s_gfdef; x->s.s_plist = copy_list(sym->s.s_plist); @(return x) @) DEFVAR("*GENSYM-COUNTER*",sLgensym_counter,LISP,make_fixnum(0),""); @(defun gensym (&optional (x gensym_prefix) &aux sym) int i, j, sign, size; fixnum f; char *q=NULL,*p=NULL; object this_gensym_prefix,big; object this_gensym_counter; @ if (type_of(x) == t_string) { this_gensym_prefix = x; this_gensym_counter=sLgensym_counter->s.s_dbind; sLgensym_counter->s.s_dbind=number_plus(sLgensym_counter->s.s_dbind,small_fixnum(1)); } else { check_type_non_negative_integer(&x); this_gensym_counter=x; this_gensym_prefix=gensym_prefix; } switch (type_of(this_gensym_counter)) { case t_bignum: big=this_gensym_counter; sign=BIG_SIGN(big); size = mpz_sizeinbase(MP(big),10)+2+(sign<0? 1 : 0); if (!(p=alloca(size))) FEerror("Cannot alloca gensym name", 0); mpz_get_str(p,10,MP(big)); j=size-5; j=j<0 ? 0 : j; while (p[j]) j++; q=p+j; break; case t_fixnum: for (size=1,f=fix(this_gensym_counter);f;f/=10,size++); q=p=alloca(size+5); if ((j=snprintf(p,size+5,"%ld",fix(this_gensym_counter)))<=0) FEerror("Cannot write gensym counter",0); q=p+j; break; default: FEerror("Bad gensym counter type", 0); break; } /* FIXME: come up with a better call sequence */ /* this_gensym_counter_string=fLformat_1(Cnil,make_simple_string("~S"),this_gensym_counter); */ /* i=this_gensym_counter_string->st.st_fillp; */ i = (q-p)+this_gensym_prefix->st.st_fillp; set_up_string_register(""); sym = make_symbol(string_register); {BEGIN_NO_INTERRUPT; sym->s.s_self = alloc_relblock(i); sym->s.s_fillp = i; i=this_gensym_prefix->st.st_fillp; for (j = 0; j < i; j++) sym->s.s_self[j] = this_gensym_prefix->st.st_self[j]; for (;js.s_fillp;j++) sym->s.s_self[j] = p[j-i]; END_NO_INTERRUPT;} @(return sym) @) @(defun gentemp (&optional (prefix gentemp_prefix) (pack `current_package()`) &aux smbl) int i, j; @ check_type_string(&prefix); check_type_package(&pack); /* gentemp_counter = 0; */ ONCE_MORE: for (j = gentemp_counter, i = 0; j > 0; j /= 10) i++; if (i == 0) i++; i += prefix->st.st_fillp; set_up_string_register(""); {BEGIN_NO_INTERRUPT; string_register->st.st_fillp = string_register->st.st_dim = i; string_register->st.st_self = alloc_relblock(i); for (j = 0; j < prefix->st.st_fillp; j++) string_register->st.st_self[j] = prefix->st.st_self[j]; if ((j = gentemp_counter) == 0) string_register->st.st_self[--i] = '0'; else for (; j > 0; j /= 10) string_register->st.st_self[--i] = j%10 + '0'; gentemp_counter++; smbl = intern(string_register, pack); if (intern_flag != 0) goto ONCE_MORE; END_NO_INTERRUPT;} @(return smbl) @) LFD(Lsymbol_package)() { check_arg(1); check_type_sym(&vs_base[0]); vs_base[0] = vs_base[0]->s.s_hpack; } LFD(Lkeywordp)() { check_arg(1); if (type_of(vs_base[0]) == t_symbol && keywordp(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } /* (SI:PUT-F plist value indicator) returns the new property list with value for property indicator. It will be used in SETF for GETF. */ LFD(siLput_f)() { check_arg(3); vs_base[0] = putf(vs_base[0], vs_base[1], vs_base[2]); vs_top = vs_base+1; } /* (SI:REM-F plist indicator) returns two values: * the new property list in which property indcator is removed * T if really removed NIL otherwise. It will be used for macro REMF. */ LFD(siLrem_f)() { check_arg(2); if (remf(&vs_base[0], vs_base[1])) vs_base[1] = Ct; else vs_base[1] = Cnil; } LFD(siLset_symbol_plist)(void) { check_arg(2); check_type_sym(&vs_base[0]); vs_base[0]->s.s_plist = vs_base[1]; vs_base[0] = vs_base[1]; vs_popp; } LFD(siLputprop)() { check_arg(3); check_type_sym(&vs_base[0]); vs_base[0]->s.s_plist = putf(vs_base[0]->s.s_plist, vs_base[1], vs_base[2]); vs_base[0] = vs_base[1]; vs_top = vs_base+1; } static void odd_plist(place) object place; { FEerror("The length of the property-list ~S is odd.", 1, place); } void gcl_init_symbol() { string_register = alloc_simple_string(0); gensym_prefix = make_simple_string("G"); /* gensym_counter = 0; */ gentemp_prefix = make_simple_string("T"); gentemp_counter = 0; token = alloc_simple_string(INITIAL_TOKEN_LENGTH); token->st.st_fillp = 0; token->st.st_self = alloc_contblock(INITIAL_TOKEN_LENGTH); token->st.st_hasfillp = TRUE; token->st.st_adjustable = TRUE; enter_mark_origin(&string_register); enter_mark_origin(&gensym_prefix); enter_mark_origin(&gentemp_prefix); enter_mark_origin(&token); } void gcl_init_symbol_function() { make_function("GET", Lget); make_function("REMPROP", Lremprop); make_function("SYMBOL-PLIST", Lsymbol_plist); make_function("GETF", Lgetf); make_function("GET-PROPERTIES", Lget_properties); make_function("SYMBOL-NAME", Lsymbol_name); make_function("MAKE-SYMBOL", Lmake_symbol); make_function("COPY-SYMBOL", Lcopy_symbol); make_function("GENSYM", Lgensym); make_function("GENTEMP", Lgentemp); make_function("SYMBOL-PACKAGE", Lsymbol_package); make_function("KEYWORDP", Lkeywordp); make_si_function("PUT-F", siLput_f); make_si_function("REM-F", siLrem_f); make_si_function("SET-SYMBOL-PLIST", siLset_symbol_plist); make_si_function("PUTPROP", siLputprop); make_si_sfun("SPUTPROP",sputprop,3); siSpname = make_si_ordinary("PNAME"); enter_mark_origin(&siSpname); /* enter_mark_origin(&sLgensym_counter); */ } gcl-2.6.14/o/test_memprotect.c0000755000175000017500000000256614360276512014627 0ustar cammcamm/* sample usage: linux14% cd gcl-2.2 linux14% cd o linux14% gcc -I../h test_memprotect.c linux14% a.out [val=0] Page violation (sig=b,code=2b,scp=2b,addr=2b,fault_adr=804a005) Reading pp[5] (addr=804a005) 10 linux14% */ #define IN_GBC #define NEED_MP_H #include "include.h" #ifdef BSD /* ulong may have been defined in mp.h but the define is no longer needed */ #undef ulong #include #define PROT_READ_WRITE (PROT_READ | PROT_WRITE |PROT_EXEC) #endif #ifdef AIX3 #include #define PROT_READ RDONLY #define PROT_READ_WRITE UDATAKEY int mprotect(); #endif #include char *pp; int psize; char *malloc(); #include #include void handler(sig,code,scp,addr) int sig,code; struct sigcontext *scp; char *addr; { struct sigcontext_struct *bil= (void *) & code; printf("\nPage violation (sig=%x,code=%x,scp=%x,addr=%x,fault_adr=%x)",sig,code,scp,addr,GET_FAULT_ADDR(sig,code,scp,addr)); fflush(stdout); mprotect(pp, psize, PROT_READ | PROT_WRITE); return; } main() { char *p; int a; signal(SIGSEGV, handler); signal(SIGBUS, handler); psize = getpagesize(); p = malloc(3 * psize); a = (int)p; pp = (char *)( ((a / psize)+ 1) * psize); printf("[val=%d]",mprotect(pp, psize, PROT_READ)); pp[5] = 10; printf("\n\nReading pp[5] (addr=%x) %d\n",&pp[5], pp[5]); fflush(stdout); } gcl-2.6.14/o/array.c0000755000175000017500000014615714360276512012534 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include #include #include "include.h" static void displace(object, object, int); static enum aelttype Iarray_element_type(object); /* #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */ DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP, make_fixnum(ARRAY_RANK_LIMIT),""); DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit, LISP, make_fixnum(MOST_POSITIVE_FIX),""); DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit, LISP, make_fixnum(MOST_POSITIVE_FIX),""); DEF_ORDINARY("BIT",sLbit,LISP,""); /* number of bits in unit of storage of x->bv.bv_self[0] */ #define BV_BITS 8 #define BITREF(x,i) \ ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ ? 1 : 0) #define SET_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) #define CLEAR_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) extern short aet_sizes[]; #define ARRAY_BODY_PTR(ar,n) \ (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) #define N_FIXNUM_ARGS 6 DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, NONE, OO, OO, OO, OO,void,Laref,(object x,object oi, ...),"") { int n = VFUN_NARGS; int i1; fixnum i=n>1 ? fix(oi) : 0; va_list ap; if (type_of(x) == t_array) {int m ; unsigned int k; int rank = n - 1; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",1,x); if (rank == 1) return fLrow_major_aref(x,i); if (rank == 0) return fLrow_major_aref(x,0); va_start(ap,oi); m = 0; k = i; /* index into 1 dimensional array */ i1 = 0; rank-- ; while(1) { if ( k >= x->a.a_dims[m]) FEerror("Index ~a to array is too large",1,make_fixnum (m)); i1 += k; m ++; if (m <= rank) { i1 = i1 * x->a.a_dims[m]; if (m < N_FIXNUM_ARGS) { k = fixint(va_arg(ap,object));} else {object x = va_arg(ap,object); check_type(x,t_fixnum); k = Mfix(x);} } else break;} va_end(ap); return fLrow_major_aref(x,i1); } if (n > 2) { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} return fLrow_major_aref(x,i); } static void fScheck_bounds_bounds(object x, int i) { switch (type_of(x)) { case t_array: case t_vector: case t_bitvector: case t_string: if ((unsigned int) i >= x->a.a_dim) FEerror("Array index ~a out of bounds for ~a", 2, make_fixnum(i),x); default: FEerror("not an array",0); } } DEFUNO_NEW("SVREF", object, fLsvref, LISP, 2, 2, ONE_VAL, OO, IO, OO,OO,void,Lsvref,(object x,ufixnum i), "For array X and index I it returns (aref x i) ") { if (type_of(x)==t_vector && (enum aelttype)x->v.v_elttype == aet_object && x->v.v_dim > i) RETURN1(x->v.v_self[i]); if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); FEerror("Bad simple vector ~a",1,x); return(Cnil); } DEFUN_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2, NONE, OO, IO, OO,OO,(object x,fixnum i), "For array X and index I it returns (aref x i) as if x were \ 1 dimensional, even though its rank may be bigger than 1") { switch (type_of(x)) { case t_array: case t_vector: case t_bitvector: if (x->v.v_dim <= (unsigned int)i) /* i = */fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: return x->v.v_self[i]; case aet_ch: return code_char(x->st.st_self[i]); case aet_bit: i += BV_OFFSET(x); return make_fixnum(BITREF(x, i)); case aet_fix: return make_fixnum(x->fixa.fixa_self[i]); case aet_sf: return make_shortfloat(x->sfa.sfa_self[i]); case aet_lf: return make_longfloat(x->lfa.lfa_self[i]); case aet_char: return small_fixnum(x->st.st_self[i]); case aet_uchar: return small_fixnum(x->ust.ust_self[i]); case aet_short: return make_fixnum(SHORT_GCL(x, i)); case aet_ushort: return make_fixnum(USHORT_GCL(x, i)); default: FEerror("unknown array type",0); } case t_string: if (x->v.v_dim <= i) /* i = */fScheck_bounds_bounds(x, i); return code_char(x->st.st_self[i]); default: FEerror("not an array",0); return(Cnil); } } #ifdef STATIC_FUNCTION_POINTERS object fLrow_major_aref(object x,fixnum i) { return FFN(fLrow_major_aref)(x,i); } #endif object aset1(object x,fixnum i,object val) { return fSaset1(x,i,val); } DEFUN_NEW("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,(object x, fixnum i,object val),"") { switch (type_of(x)) { case t_array: case t_vector: case t_bitvector: if (x->v.v_dim <= i) /* i = */fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: x->v.v_self[i] = val; break; case aet_ch: ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; case aet_bit: i += BV_OFFSET(x); ASSURE_TYPE(val,t_fixnum); switch (Mfix(val)) { case 0: CLEAR_BITREF(x,i); break; case 1: SET_BITREF(x,i); break; default: TYPE_ERROR(val,sLbit); } break; case aet_fix: ASSURE_TYPE(val,t_fixnum); (x->fixa.fixa_self[i]) = Mfix(val); break; case aet_sf: ASSURE_TYPE(val,t_shortfloat); (x->sfa.sfa_self[i]) = Msf(val); break; case aet_lf: ASSURE_TYPE(val,t_longfloat); (x->lfa.lfa_self[i]) = Mlf(val); break; case aet_char: ASSURE_TYPE(val,t_fixnum); x->st.st_self[i] = Mfix(val); break; case aet_uchar: ASSURE_TYPE(val,t_fixnum); (x->ust.ust_self[i])= Mfix(val); break; case aet_short: ASSURE_TYPE(val,t_fixnum); SHORT_GCL(x, i) = Mfix(val); break; case aet_ushort: ASSURE_TYPE(val,t_fixnum); USHORT_GCL(x, i) = Mfix(val); break; default: FEerror("unknown array type",0); } break; case t_string: if (x->v.v_dim <= i) /* i = */fScheck_bounds_bounds(x, i); ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; default: FEerror("not an array",0); } return val; } #ifdef STATIC_FUNCTION_POINTERS object fSaset1(object x, fixnum i,object val) { return FFN(fSaset1)(x,i,val); } #endif DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, OO, OO, OO,void,siLaset,(object x,object ii,object y, ...),"") { int i,i1; int n = VFUN_NARGS; va_list ap; if (type_of(x) == t_array) {int m ; unsigned int k; int rank = n - 2; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",1,x); if (rank == 0) return fSaset1(x,0,ii); ASSURE_TYPE(ii,t_fixnum); i = fix(ii); if (rank == 1) return fSaset1(x,i,y); va_start(ap,y); m = 0; k = i; /* index into 1 dimensional array body */ i1 = 0; rank-- ; while(1) { if (k >= x->a.a_dims[m]) { object x,x1; x=make_fixnum(m); x1=make_fixnum(k); FEerror("Index number ~a: ~a to array is out of bounds", 2,x,x1); } i1 += k; if (m < rank) {object u; if (m == 0) { u = y;} else { u = va_arg(ap,object);} check_type(u,t_fixnum); k = Mfix(u); m++ ; i1 = i1 * x->a.a_dims[m]; } else { y = va_arg(ap,object); break ;} } va_end(ap); return fSaset1(x,i1,y); } else { ASSURE_TYPE(ii,t_fixnum); i = fix(ii); return fSaset1(x,i,y); } } DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, OO,void,siLsvset,(object x,fixnum i,object val),"") { if (TYPE_OF(x) != t_vector || DISPLACED_TO(x) != Cnil) Wrong_type_error("simple array",0); if (i > x->v.v_dim) { FEerror("out of bounds",0); } return x->v.v_self[i] = val; } /* (proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) (defun make-vector1 (n elt-type staticp &optional fillp initial-element displaced-to (displaced-index-offset 0)) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OO, OO,OO,OO,(object on,object oelt_type,object staticp,...),"") { int displaced_index_offset=0; int Inargs = VFUN_NARGS - 3; fixnum n=fixint(on),elt_type=fixint(oelt_type); va_list Iap;object fillp;object initial_element;object displaced_to;object V9; Inargs = VFUN_NARGS - 3 ; { object x; BEGIN_NO_INTERRUPT; switch(elt_type) { case aet_ch: x = alloc_object(t_string); x->ust.ust_adjustable=1; goto a_string; break; case aet_bit: x = alloc_object(t_bitvector); x->v.v_elttype = elt_type; x->v.v_adjustable=1; break; default: x = alloc_object(t_vector);} x->v.v_elttype = elt_type; x->v.v_adjustable=1; a_string: x->v.v_dim = n; x->v.v_self = 0; x->v.v_displaced = Cnil; if( --Inargs < 0)goto LA1; else { va_start(Iap,staticp); fillp=va_arg(Iap,object); if (fillp == Cnil) {x->v.v_hasfillp = 0; x->v.v_fillp = n; } else if(type_of(fillp) == t_fixnum) { x->v.v_fillp = Mfix(fillp); if (x->v.v_fillp > n || x->v.v_fillp < 0) FEerror("bad fillp",0); x->v.v_hasfillp = 1; } else { x->v.v_fillp = n; x->v.v_hasfillp = 1; } } if( --Inargs < 0)goto LA2; else { initial_element=va_arg(Iap,object);} if( --Inargs < 0)goto LA4; else { displaced_to=va_arg(Iap,object);} if( --Inargs < 0)goto LA5; else { V9=va_arg(Iap,object); if (displaced_to != Cnil) { ASSURE_TYPE(V9,t_fixnum); displaced_index_offset=Mfix(V9);}} goto LA6; LA1: x->v.v_hasfillp = 0; x->v.v_fillp = n; LA2: initial_element=Cnil; LA4: displaced_to=Cnil; LA5: displaced_index_offset= 0; LA6: va_end(Iap); { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } } } object fSmake_vector1_1(fixnum n,fixnum elt_type,object staticp) { VFUN_NARGS=3; return FFN(fSmake_vector1)(make_fixnum(n),make_fixnum(elt_type),staticp); } object fSmake_vector1_2(fixnum n,fixnum elt_type,object staticp,object fillp) { VFUN_NARGS=4; return FFN(fSmake_vector1)(make_fixnum(n),make_fixnum(elt_type),staticp,fillp); } static object DFLT_aet_object = Cnil; static char DFLT_aet_ch = ' '; static char DFLT_aet_char = 0; static fixnum DFLT_aet_fix = 0 ; static short DFLT_aet_short = 0; static shortfloat DFLT_aet_sf = 0.0; static longfloat DFLT_aet_lf = 0.0; static object Iname_t = sLt; static struct { char * dflt; object *namep;} aet_types[] = { {(char *) &DFLT_aet_object, &Iname_t,}, /* t */ {(char *) &DFLT_aet_ch, &sLcharacter,},/* character */ {(char *) &DFLT_aet_fix, &sLbit,}, /* bit */ {(char *) &DFLT_aet_fix, &sLfixnum,}, /* fixnum */ {(char *) &DFLT_aet_sf, &sLshort_float,}, /* short-float */ {(char *) &DFLT_aet_lf, &sLlong_float,}, /* long-float */ {(char *) &DFLT_aet_char,&sSsigned_char,}, /* signed char */ {(char *) &DFLT_aet_char,&sSunsigned_char,}, /* unsigned char */ {(char *) &DFLT_aet_short,&sSsigned_short,}, /* signed short */ {(char *) &DFLT_aet_short, &sSunsigned_short}, /* unsigned short */ }; DEFUN_NEW("GET-AELTTYPE",object,fSget_aelttype,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { int i; for (i=0 ; i < aet_last ; i++) if (x == * aet_types[i].namep) return make_fixnum((enum aelttype) i); if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) return make_fixnum(aet_lf); return make_fixnum(aet_object); } #ifdef STATIC_FUNCTION_POINTERS object fSget_aelttype(object x) { return FFN(fSget_aelttype)(x); } #endif /* backward compatibility only: (si:make-vector element-type 0 dimension 1 adjustable 2 fill-pointer 3 displaced-to 4 displaced-index-offset 5 static 6 &optional initial-element) */ DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, OO,OO,OO,OO,void,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"") {int narg=VFUN_NARGS; object initial_elt; va_list ap; object x; {va_start(ap,x6); if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; goto LEND_VARARG; LDEFAULT8: initial_elt = Cnil ; LEND_VARARG: va_end(ap);} /* 8 args */ VFUN_NARGS = 8; x = FFN(fSmake_vector1)(x1, /* n */ fSget_aelttype(x0), /*aelt type */ x6, /* staticp */ x3, /* fillp */ initial_elt, /* initial element */ x4, /*displaced to */ x5); /* displaced-index offset */ x0 = x; RETURN1(x0); } /* (proclaim '(ftype (function (fixnum t *)) make-array1)) (defun make-array1 ( elt-type staticp initial-element displaced-to displaced-index-offset &optional dim1 dim2 .. ) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN_NEW("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, NONE,OI,OO,OI,OO, (fixnum elt_type,object staticp,object initial_element,object displaced_to,fixnum displaced_index_offset, object dimensions),"") { int rank = length(dimensions); if (rank > ARRAY_RANK_LIMIT) FEerror("Array rank limit exceeded.",0); { object x,v; char *tmp_alloc; int dim =1,i; BEGIN_NO_INTERRUPT; x = alloc_object(t_array); x->a.a_elttype = elt_type; x->a.a_self = 0; x->a.a_rank = rank; x->a.a_displaced = Cnil; x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); i = 0; v = dimensions; while (i < rank) { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); if (x->a.a_dims[i] < 0) { FEerror("Dimension must be non negative",0);} if (dim && x->a.a_dims[i]>((1UL<<(sizeof(dim)*8-1))-1)/dim) FEerror("Total dimension overflow on dimensions ~s",1,dimensions); dim *= x->a.a_dims[i++]; v = Mcdr(v);} x->a.a_dim = dim; x->a.a_adjustable = 1; { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } }} #ifdef STATIC_FUNCTION_POINTERS object fSmake_array1(fixnum elt_type,object staticp,object initial_element,object displaced_to, fixnum displaced_index_offset,object dimensions) { return FFN(fSmake_array1)(elt_type,staticp,initial_element, displaced_to,displaced_index_offset,dimensions); } #endif /* (proclaim '(ftype (function (object t *)) array-displacement1)) (defun array-displacement1 ( array ) */ /* DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */ /* NONE,OO,OO,OO,OO,void,siLarray_displacement,"") */ /* (object array) { */ /* object a; */ /* int s,n; */ /* BEGIN_NO_INTERRUPT; */ /* if (type_of(array)!=t_array && type_of(array)!=t_vector) */ /* FEerror("Argument is not an array",0); */ /* a=array->a.a_displaced->c.c_car; */ /* if (a==Cnil) { */ /* END_NO_INTERRUPT; */ /* return make_cons(Cnil,make_fixnum(0)); */ /* } */ /* s=aet_sizes[Iarray_element_type(a)]; */ /* n=(void *)array->a.a_self-(void *)a->a.a_self; */ /* if (n%s) */ /* FEerror("Array is displaced by fractional elements",0); */ /* END_NO_INTERRUPT; */ /* return make_cons(a,make_fixnum(n/s)); */ /* } */ static void FFN(Larray_displacement)(void) { object array,a; int s,n; BEGIN_NO_INTERRUPT; n = vs_top - vs_base; if (n < 1) FEtoo_few_arguments(vs_base,vs_top); if (n > 1) FEtoo_many_arguments(vs_base,vs_top); array = vs_base[0]; vs_base=vs_top; /* if (type_of(array)!=t_array && type_of(array)!=t_vector && */ /* type_of(array)!=t_bitvector && type_of(array)!=t_string) */ /* FEwrong_type_argument(sLarray,array); */ IisArray(array); a=array->a.a_displaced->c.c_car; if (a==Cnil) { vs_push(Cnil); vs_push(make_fixnum(0)); END_NO_INTERRUPT; return; } s=aet_sizes[Iarray_element_type(a)]; n=(void *)array->a.a_self-(void *)a->a.a_self; if (n%s) FEerror("Array is displaced by fractional elements",0); vs_push(a); vs_push(make_fixnum(n/s)); END_NO_INTERRUPT; return; } /* For the X->a.a_displaced field, the CAR is an array which X 's body is displaced to (ie body of X is part of Another array) and the (CDR) is the LIST of arrays whose bodies are displaced to X (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) ;{ A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) */ static void displace(object from_array, object dest_array, int offset) { enum aelttype typ; IisArray(from_array); IisArray(dest_array); typ =Iarray_element_type(from_array); if (typ != Iarray_element_type(dest_array)) { Wrong_type_error("same element type",0); } if (offset + from_array->a.a_dim > dest_array->a.a_dim) { FEerror("Destination array too small to hold other array",0); } /* ensure that we have a cons */ if (dest_array->a.a_displaced == Cnil) { dest_array->a.a_displaced = list(2,Cnil,from_array);} else Mcdr(dest_array->a.a_displaced) = make_cons(from_array, Mcdr(dest_array->a.a_displaced)); from_array->a.a_displaced = make_cons(dest_array,sLnil); /* now set the actual body of from_array to be the address of body in dest_array. If it is a bit array, this cannot carry the offset information, since the body is only recorded as multiples of BV_BITS */ if (typ == aet_bit) { offset += BV_OFFSET(dest_array); from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; SET_BV_OFFSET(from_array,offset % BV_BITS); } else from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); } static enum aelttype Iarray_element_type(object x) {enum aelttype t=aet_last; switch(TYPE_OF(x)) { case t_array: t = (enum aelttype) x->a.a_elttype; break; case t_vector: t = (enum aelttype) x->v.v_elttype; break; case t_bitvector: t = aet_bit; break; case t_string: t = aet_ch; break; default: FEerror("Not an array ~a ",1,x); } return t; } /* Make the body of FROM array point to the body of TO at the DISPLACED_INDEX_OFFSET */ /* static void */ /* Idisplace_array(object from, object to, int displaced_index_offset) */ /* { */ /* enum aelttype t1,t2; */ /* t1 = Iarray_element_type(from); */ /* t2 = Iarray_element_type(to); */ /* if (t1 != t2) */ /* FEerror("Attempt to displace arrays of one type to arrays of another type",0); */ /* if (to->a.a_dim > from->a.a_dim - displaced_index_offset) */ /* FEerror("To array not large enough for displacement",0); */ /* {BEGIN_NO_INTERRUPT; */ /* from->a.a_displaced = make_cons(to,Cnil); */ /* if (to->a.a_displaced == Cnil) */ /* to->a.a_displaced = make_cons(Cnil,Cnil); */ /* DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); */ /* if (t1 == aet_bit) { */ /* displaced_index_offset += BV_OFFSET(to); */ /* from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; */ /* SET_BV_OFFSET(from, displaced_index_offset%BV_BITS); */ /* } */ /* else */ /* from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); */ /* END_NO_INTERRUPT; */ /* } */ /* } */ /* add diff to body of x and arrays diisplaced to it */ void adjust_displaced(object x, long diff) { if (x->ust.ust_self != NULL) x->ust.ust_self = (unsigned char *)((long)(x->a.a_self) + diff); for (x = Scdr(x->ust.ust_displaced); x != Cnil; x = Scdr(x)) adjust_displaced(Mcar(x), diff); } /* RAW_AET_PTR returns a pointer to something of raw type obtained from X suitable for using GSET for an array of elt type TYP. If x is the null pointer, return a default for that array element type. */ static char * raw_aet_ptr(object x, short int typ) { /* doubles are the largest raw type */ static union{ object o;char c;fixnum i;shortfloat f;longfloat d; unsigned char uc;short s;unsigned short us;} u; if (x==Cnil) return aet_types[typ].dflt; switch (typ){ /* #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; */ case aet_object: /* STORE_TYPED(&u,object,x); */ u.o=x; break; case aet_ch: /* STORE_TYPED(&u,char, char_code(x)); */ u.c=char_code(x); break; case aet_bit: /* STORE_TYPED(&u,fixnum, -Mfix(x)); */ u.i=-Mfix(x); break; case aet_fix: /* STORE_TYPED(&u,fixnum, Mfix(x)); */ u.i=Mfix(x); break; case aet_sf: /* STORE_TYPED(&u,shortfloat, Msf(x)); */ u.f=Msf(x); break; case aet_lf: /* STORE_TYPED(&u,longfloat, Mlf(x)); */ u.d=Mlf(x); break; case aet_char: /* STORE_TYPED(&u, char, Mfix(x)); */ u.c=(char)Mfix(x); break; case aet_uchar: /* STORE_TYPED(&u, unsigned char, Mfix(x)); */ u.uc=(unsigned char)Mfix(x); break; case aet_short: /* STORE_TYPED(&u, short, Mfix(x)); */ u.s=(short)Mfix(x); break; case aet_ushort: /* STORE_TYPED(&u,unsigned short,Mfix(x)); */ u.us=(unsigned short)Mfix(x); break; default: FEerror("bad elttype",0); break; } return (char *)&u; } /* GSET copies into array ptr P1, the value pointed to by the ptr VAL into the next N slots. The array type is typ. If VAL is the null ptr, use the default for that element type NOTE: for type aet_bit n is the number of Words ie (nbits +WSIZE-1)/WSIZE and the words are set. */ void gset(void *p1, void *val, int n, int typ) { if (val==0) val = aet_types[typ].dflt; switch (typ){ #define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} #define GSET1(p,n,typ,val) while (n-- > 0) \ { *((typ *) p) = val; \ p = p + sizeof(typ); \ } break; case aet_object: GSET(p1,n,object,val); case aet_ch: GSET(p1,n,char,val); /* Note n is number of fixnum WORDS for bit */ case aet_bit: GSET(p1,n,fixnum,val); case aet_fix: GSET(p1,n,fixnum,val); case aet_sf: GSET(p1,n,shortfloat,val); case aet_lf: GSET(p1,n,longfloat,val); case aet_char: GSET(p1,n,char,val); case aet_uchar: GSET(p1,n,unsigned char,val); case aet_short: GSET(p1,n,short,val); case aet_ushort: GSET(p1,n,unsigned short,val); default: FEerror("bad elttype",0); } } #define W_SIZE (BV_BITS*sizeof(fixnum)) /* */ DEFUN_NEW("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, 5,NONE,OO,OO,OO,OO,(object x,object y,object oi1,object oi2,object n1o), "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ elements if N1 is supplied otherwise, doing the length of X - I1 \ elements. If the types of the arrays are not the same, this has \ implementation dependent results.") { fixnum i1=fix(oi1),i2=fix(oi2); enum aelttype typ1=Iarray_element_type(x); enum aelttype typ2=Iarray_element_type(y); int n1=fix(n1o),nc; if (VFUN_NARGS==4) { n1 = x->v.v_dim - i1;} if (typ1==aet_bit) { if (i1 % CHAR_SIZE) badcopy: FEerror("Bit copies only if aligned",0); else { int rest=n1%CHAR_SIZE; if (rest!=0) { if (typ2!=aet_bit) goto badcopy; while(rest> 0) { fSaset1(y,i2+n1-rest,(fLrow_major_aref(x,i1+n1-rest))); rest--; } } i1=i1/CHAR_SIZE ; n1=n1/CHAR_SIZE; typ1=aet_char; } } if (typ2==aet_bit) { if (i2 % CHAR_SIZE) goto badcopy; i2=i2/CHAR_SIZE ; } if ((typ1 ==aet_object || typ2 ==aet_object) && typ1 != typ2) FEerror("Can't copy between different array types",0); nc=n1 * aet_sizes[(int)typ1]; if (i1+n1 > x->a.a_dim || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) FEerror("Copy out of bounds",0); bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), y->ust.ust_self + (i2*aet_sizes[(int)typ2]), nc); return x; } /* X is the header of an array. This supplies the body which will not be relocatable if STATICP. If DFLT is 0, do not initialize (the caller promises to reset these before the next gc!). If DFLT == Cnil then initialize to default type for this array type. Otherwise DFLT is an object and its value is used to init the array */ void array_allocself(object x, int staticp, object dflt) { int n; void *(*fun)(size_t),*tmp_alloc; enum aelttype typ; fun = (staticp ? alloc_contblock : alloc_relblock); { /* this must be called from within no interrupt code */ n = x->a.a_dim; typ = Iarray_element_type(x); switch (typ) { case aet_object: x->a.a_self = AR_ALLOC(*fun,n,object); break; case aet_ch: case aet_char: case aet_uchar: x->st.st_self = AR_ALLOC(*fun,n,char); break; case aet_short: case aet_ushort: x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); break; case aet_bit: n = (n+W_SIZE-1)/W_SIZE; SET_BV_OFFSET(x,0); case aet_fix: x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); break; case aet_sf: x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); break; case aet_lf: x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); break; default: break; } if(dflt!=OBJNULL) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); } } DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2, NONE,OO,IO,OO,OO,void,siLfill_pointer_set,(object x,fixnum i),"") { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} if (i < 0 || i > x->a.a_dim) { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} x->v.v_fillp = i; return make_fixnum(i); no_fillp: FEerror("~a does not have a fill pointer",1,x); return make_fixnum(0); } DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO, OO,OO,OO,void,Lfill_pointer,(object x),"") { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} return make_fixnum(x->v.v_fillp) ; no_fillp: FEwrong_type_argument(sLvector,x); return make_fixnum(0); } DEFUN_NEW("ARRAY-HAS-FILL-POINTER-P",object, fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { if (TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string))) return (x->v.v_hasfillp == 0 ? Cnil : sLt); else if (TYPE_OF(x) == t_array) { return Cnil;} else IisArray(x); return Cnil; } /* DEFUN_NEW("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; */ DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, LISP,1,1,NONE,OO,OO,OO,OO,void,Larray_element_type,(object x),"") { enum aelttype t; t = Iarray_element_type(x); return * aet_types[(int)t].namep; } DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"") { IisArray(x); return sLt; } DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, 1,NONE,OO,OO,OO,OO,void,siLdisplaced_array_p,(object x),"") { IisArray(x); return (x->a.a_displaced == Cnil ? Cnil : sLt); } DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO, OO,void,Larray_rank,(object x),"") { if (type_of(x) == t_array) return make_fixnum(x->a.a_rank); IisArray(x); return make_fixnum(1); } DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2, NONE,OO,IO,OO,OO,void,Larray_dimension,(object x,fixnum i),"") { if (type_of(x) == t_array) { if ((unsigned int)i >= x->a.a_rank) FEerror("Index ~a out of bounds for array-dimension",1 ,make_fixnum(i)); else { return make_fixnum(x->a.a_dims[i]);}} IisArray(x); return make_fixnum(x->v.v_dim); } static void Icheck_displaced(object displaced_list, object ar, int dim) { while (displaced_list!=Cnil) { object u = Mcar(displaced_list); displaced_list = Mcdr(displaced_list); if (u->a.a_self == NULL) continue; if ((Iarray_element_type(u) == aet_bit && (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + BV_OFFSET(u) - BV_OFFSET(ar) > 0) || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) FEerror("Bad displacement",0); Icheck_displaced(DISPLACED_FROM(u),ar,dim); } } /* (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) { A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) Destroy the displacement from AR */ /* static void */ /* Iundisplace(object ar) */ /* { object *p,x; */ /* if ((x = DISPLACED_TO(ar)) == Cnil || */ /* ar->a.a_displaced->d.m == FREE) */ /* return; */ /* {BEGIN_NO_INTERRUPT; */ /* DISPLACED_TO(ar) = Cnil; */ /* p = &(DISPLACED_FROM(x)) ; */ /* walk through the displaced from list and delete AR */ /* while(1) */ /* { if ((*p)->d.m == FREE */ /* || *p == Cnil) */ /* goto retur; */ /* if((Mcar(*p) == ar)) */ /* { *p = Mcdr(*p); */ /* goto retur;} */ /* p = &(Mcdr(*p)); */ /* } */ /* retur: */ /* END_NO_INTERRUPT; */ /* return; */ /* } */ /* } */ DEFUN_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,OO,OO,OO,OO,(object old,object new),"") { struct dummy fw; fw = old->d; old = IisArray(old); if (TYPE_OF(old) != TYPE_OF(new) || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) { FEerror("Cannot do array replacement ~a by ~a",2,old,new); } { int offset = new->ust.ust_self - old->ust.ust_self; object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); adjust_displaced(old,offset); /* Iundisplace(old); */ if (TYPE_OF(old) == t_vector && old->v.v_hasfillp) { new->v.v_hasfillp = 1; new->v.v_fillp = old->v.v_fillp;} if (TYPE_OF(old) == t_string) old->st = new->st; else old->a = new ->a; /* prevent having two arrays with the same body--which are not related that would cause the gc to try to copy both arrays and there might not be enough space. */ new->a.a_dim = 0; new->a.a_self = 0; old->d = fw; old->a.a_displaced = displaced; } return old; } DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,NONE,IO,OO,OO,OO,(object x),"") { x = IisArray(x); return (object)(fixnum)x->a.a_dim; } DEFUN_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, NONE,OO,OO,OO,OO,(object array,object val,object cursor),"") { object x; int i; object ind[ARRAY_RANK_LIMIT]; /* 3 args */ ind[0]=array; if (cursor==sLnil) {fSaset1(array,0,val); RETURN1(array);} ind[1]=MMcar(cursor); ASSURE_TYPE(ind[1],t_fixnum); i = 2; for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) { ind[i++] = MMcar(x);} ind[i]=val; VFUN_NARGS=i+1; /* FIXME do this with C macros */ switch(i+1){ case 3: (*FFN(fSaset))(ind[0],ind[1],ind[2]);break; case 4: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3]);break; case 5: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4]);break; case 6: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5]);break; case 7: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6]);break; case 8: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7]);break; case 9: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8]);break; case 10: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9]);break; case 11: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10]);break; case 12: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11]);break; case 13: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12]);break; case 14: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13]);break; case 15: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14]);break; case 16: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15]);break; case 17: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16]);break; case 18: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17]);break; case 19: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18]);break; case 20: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19]);break; case 21: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20]);break; case 22: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21]);break; case 23: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22]);break; case 24: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23]);break; case 25: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24]);break; case 26: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25]);break; case 27: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26]);break; case 28: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27]);break; case 29: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28]);break; case 30: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29]);break; case 31: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30]);break; case 32: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31]);break; case 33: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32]);break; case 34: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33]);break; case 35: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34]);break; case 36: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35]);break; case 37: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36]);break; case 38: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37]);break; case 39: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38]);break; case 40: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39]);break; case 41: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40]);break; case 42: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41]);break; case 43: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42]);break; case 44: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43]);break; case 45: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44]);break; case 46: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45]);break; case 47: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46]);break; case 48: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47]);break; case 49: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48]);break; case 50: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49]);break; case 51: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50]);break; case 52: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51]);break; case 53: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52]);break; case 54: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53]);break; case 55: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54]);break; case 56: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55]);break; case 57: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56]);break; case 58: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57]);break; case 59: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57],ind[58]);break; case 60: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57],ind[58],ind[59]);break; case 61: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57],ind[58],ind[59],ind[60]);break; case 62: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57],ind[58],ind[59],ind[60],ind[61]);break; case 63: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], ind[57],ind[58],ind[59],ind[60],ind[61],ind[62]);break; /* case 64: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], */ /* ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], */ /* ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], */ /* ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], */ /* ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], */ /* ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], */ /* ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], */ /* ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], */ /* ind[57],ind[58],ind[59],ind[60],ind[61],ind[62],ind[63]);break; */ default: FEerror("Exceeded call-arguments-limit ",0); } RETURN1(array); } void gcl_init_array_function(void) { make_function("ARRAY-DISPLACEMENT", Larray_displacement); } gcl-2.6.14/o/bds.c0000755000175000017500000000173214360276512012153 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* bds.c bind stack routines */ #include "include.h" void bds_unwind(bds_ptr new_bds_top) { for (; bds_top > new_bds_top; bds_top--) (bds_top->bds_sym)->s.s_dbind = bds_top->bds_val; } gcl-2.6.14/o/sfaslbfd.c0000644000175000017500000002263614360276512013172 0ustar cammcamm/* Copyright (C) 1994 W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. */ /* for testing in standalone manner define STAND You may then compile this file cc -g -DSTAND -DDEBUG -I../hn a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/ will write a /tmp/sfasltest file which you can use comp to compare with one produced by ld. */ #if defined(SPECIAL_RSYM) || !defined(HAVE_LIBBFD) #error Cannot use bfd fasloading with SPECIAL_RSYM/without HAVE_LIBBFD defined #endif #ifdef HAVE_LIBBFD #ifdef NEED_CONST #define CONST const #endif #define IN_GCC #include #include #endif #include "ext_sym.h" #include "gclincl.h" #include #if defined(DARWIN) asection * bfd_mach_o_craft_fp_branch_islands PARAMS ((bfd *)); MY_BFD_BOOLEAN bfd_mach_o_inject_fp_branch_islands PARAMS ((bfd *, asection *, asymbol **)); #endif /* align for power of two n */ static void * round_up(void *address, unsigned long n) { return (void *)(((unsigned long)address + n -1) & ~(n-1)) ; } #define ROUND_UP(a,b) round_up(a,b) static MY_BFD_BOOLEAN madd_archive_element (struct bfd_link_info * link_info, bfd *abfd, const char *name) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mmultiple_definition (struct bfd_link_info * link_info, const char *name, bfd *obfd, asection *osec, bfd_vma oval, bfd *nbfd, asection *nsec, bfd_vma nval) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mmultiple_common (struct bfd_link_info * link_info, const char *name, bfd *obfd, enum bfd_link_hash_type otype, bfd_vma osize, bfd *nbfd, enum bfd_link_hash_type ntype, bfd_vma nsize) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN madd_to_set (struct bfd_link_info * link_info, struct bfd_link_hash_entry *entry, bfd_reloc_code_real_type reloc, bfd *abfd, asection *sec, bfd_vma value) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mconstructor (struct bfd_link_info * link_info,MY_BFD_BOOLEAN constructor, const char *name, bfd *abfd, asection *sec, bfd_vma value) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mwarning (struct bfd_link_info * link_info, const char *warning, const char *symbol, bfd *abfd, asection *section, bfd_vma address) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mundefined_symbol (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address, MY_BFD_BOOLEAN fatal) { printf("%s is undefined\n",name); return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mreloc_overflow (struct bfd_link_info * link_info,struct bfd_link_hash_entry *entry, const char *name, const char *reloc_name, bfd_vma addend, bfd *abfd, asection *section, bfd_vma address) { printf("reloc for %s is overflowing\n",name); return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mreloc_dangerous (struct bfd_link_info * link_info, const char *message, bfd *abfd, asection *section, bfd_vma address) { printf("reloc is dangerous %s\n",message); return MY_BFD_FALSE; } static MY_BFD_BOOLEAN munattached_reloc (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { return MY_BFD_FALSE; } static MY_BFD_BOOLEAN mnotice (struct bfd_link_info * link_info, const char *name, bfd *abfd, asection *section, bfd_vma address) { return MY_BFD_FALSE; } static bfd *bself; int fasload(object faslfile) { object data; char filename[256]; int init_address=-1; object memory; int max_align=0; void *current; unsigned long curr_size; object *old_vs_base=vs_base; object *old_vs_top=vs_top; static int nbfd; bfd *b; bfd_error_type myerr; unsigned u,v; asymbol **q; asection *s; void * the_start,*start_address,*m; static union lispunion dum; static struct bfd_link_callbacks link_callbacks; static struct bfd_link_order link_order; char entry_name[7]="_init_",*entry_name_ptr; #if defined(DARWIN) asection *bi; #endif if (!nbfd) { nbfd=1; set_type_of(&dum,t_stream); dum.sm.sm_mode=smm_input; dum.sm.sm_object0=sLcharacter; link_callbacks.add_archive_element=madd_archive_element; link_callbacks.multiple_definition=mmultiple_definition; link_callbacks.multiple_common=mmultiple_common; link_callbacks.add_to_set=madd_to_set; link_callbacks.constructor=mconstructor; link_callbacks.warning=mwarning; link_callbacks.undefined_symbol=mundefined_symbol; link_callbacks.reloc_overflow=mreloc_overflow; link_callbacks.reloc_dangerous=mreloc_dangerous; link_callbacks.unattached_reloc=munattached_reloc; link_callbacks.notice=mnotice; link_info.callbacks=&link_callbacks; link_order.type=bfd_indirect_link_order; } coerce_to_filename(faslfile, filename); if (!(b=bfd_openr(filename,0))) FEerror("Cannot open bfd",0); if ((myerr=bfd_get_error()) && myerr!=3) FEerror("Unknown bfd error code on openr",0); if (!bfd_check_format(b,bfd_object)) FEerror("Unknown bfd format",0); if ((myerr=bfd_get_error()) && myerr!=3) FEerror("Unknown bfd error code on check_format",0); bfd_set_error(0); #if defined(DARWIN) if ((bi = bfd_mach_o_craft_fp_branch_islands (b)) == NULL) FEerror ("Could not craft fp register preservation stubs",0); #endif current=NULL; for (s=b->sections;s;s=s->next) { s->owner=b; s->output_section=(s->flags & SEC_ALLOC) ? s : b->sections; s->output_offset=0; if (!(s->flags & SEC_ALLOC)) continue; if (max_alignalignment_power) max_align=s->alignment_power; current=round_up(current,1<alignment_power); current+=bfd_section_size(b,s); } curr_size=(unsigned long)current; max_align=1<cfd.cfd_size = curr_size + (max_align > sizeof(char *) ? max_align :0); memory->cfd.cfd_start=alloc_contblock(memory->cfd.cfd_size); the_start=start_address=memory->cfd.cfd_start; start_address = ROUND_UP(start_address,max_align); memory->cfd.cfd_size = memory->cfd.cfd_size - (start_address - the_start); memory->cfd.cfd_start = (void *)start_address; for (m=start_address,s=b->sections;s;s=s->next) { if (!(s->flags & SEC_ALLOC)) continue; m=round_up(m,1<alignment_power); s->output_section->vma=(unsigned long)m; m+=bfd_section_size(b,s); } if ((u=bfd_get_symtab_upper_bound(b))<0) FEerror("Cannot get symtab uppoer bound",0); q=(asymbol **)alloca(u); if ((v=bfd_canonicalize_symtab(b,q))<0) FEerror("cannot canonicalize symtab",0); *entry_name=bfd_get_symbol_leading_char(b); entry_name_ptr=*entry_name ? entry_name : entry_name+1; for (u=0;uname,5)) { init_address=q[u]->value+(q[u]->section->output_section->vma-(unsigned long)memory->cfd.cfd_start); continue; } if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_FALSE,MY_BFD_FALSE,MY_BFD_TRUE))) continue; if (h->type!=bfd_link_hash_defined) FEerror("Undefined symbol ~S",1,make_simple_string(q[u]->name)); if (h->u.def.section) { q[u]->value=h->u.def.value+h->u.def.section->vma; q[u]->flags|=BSF_WEAK; } else FEerror("Symbol without section",0); } #if defined(DARWIN) if (!bfd_mach_o_inject_fp_branch_islands (b, bi, q)) FEerror ("Could not inject fp register preservation stubs",0); #endif #ifndef HAVE_ALLOCA #error Cannot use bfd relocations without alloca at present #endif /* We have to do this to avoid the possibility that bfd_get_relocated_section_contents will run GBC via its alloc, thereby write protecting the pages of memory->cfd again and causing bfd reads of the section contents to return an error code after a 'stratified' segfault */ { void *v=alloca(memory->cfd.cfd_size); if (!v) FEerror("Cannot alloca for bfd",0); for (s=b->sections;s;s=s->next) { unsigned long ss=bfd_section_size(b,s); if (!(s->flags & SEC_LOAD)) continue; link_order.u.indirect.section=s; if (!bfd_get_relocated_section_contents(b,&link_info,&link_order, v,0,q)) FEerror("Cannot get relocated section contents\n",0); memcpy((void *)(unsigned long)s->output_section->vma,v,ss); } } dum.sm.sm_object1=faslfile; dum.sm.sm_fp=b->iostream; /* Find a way of doing this in bfd -- use this for now. Unfortunately, we're not always at file end after reading in the sections -- CM */ SEEK_TO_END_OFILE(dum.sm.sm_fp); if (feof(dum.sm.sm_fp)) data=0; else data = read_fasl_vector(&dum); bfd_close(b); #ifdef CLEAR_CACHE CLEAR_CACHE; #endif call_init(init_address,memory,data,0); vs_base=old_vs_base; vs_top=old_vs_top; if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %p ",memory->cfd.cfd_start); return memory->cfd.cfd_size; } #include "sfasli.c" gcl-2.6.14/o/funlink.c0000755000175000017500000003447114360276512013057 0ustar cammcamm/* Copyright William Schelter. All rights reserved. Fast linking method for kcl by W. Schelter University of Texas Note there are also changes to cmpcall.lsp and cmptop.lsp */ #include #include #include "include.h" #include "sfun_argd.h" #include "page.h" static int clean_link_array(object *,object *); object sScdefn; typedef object (*object_func)(); static int vpush_extend(void *,object); object sSAlink_arrayA; int Rset = 0; DEFVAR("*LINK-LIST*",sSAlink_listA,SI,0,""); static inline void append_link_list(object sym,int n) { object x; int i; if (!Rset || !sSAlink_listA->s.s_dbind) return; for (x=sSAlink_listA->s.s_dbind;x!=Cnil && x->c.c_car->c.c_car!=sym;x=x->c.c_cdr); if (x==Cnil) sSAlink_listA->s.s_dbind=MMcons((x=list(7,sym,make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0))),sSAlink_listA->s.s_dbind); else x=x->c.c_car; x=x->c.c_cdr; if (listp(sym->s.s_gfdef)) x->c.c_car=one_plus(x->c.c_car); for (x=x->c.c_cdr,i=0;ic.c_cdr); x->c.c_car=one_plus(x->c.c_car); } /* cleanup link */ void call_or_link(object sym, void **link) { object fun; fun = sym->s.s_gfdef; if (fun == OBJNULL) { FEinvalid_function(sym); return; } if (type_of(fun) == t_cclosure && (fun->cc.cc_turbo)) { if (Rset==0) MMccall(fun); else fun->cf.cf_self(fun); return; } if (Rset==0) funcall(fun); else if (type_of(fun) == t_cfun) { (void) vpush_extend( link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend( *link,sSAlink_arrayA->s.s_dbind); *link = (void *) (fun->cf.cf_self); (*(void (*)())(fun->cf.cf_self))(); } else { append_link_list(sym,0); funcall(fun); } } void call_or_link_closure(object sym, void **link, void **ptr) { object fun; fun = sym->s.s_gfdef; if (fun == OBJNULL) { FEinvalid_function(sym); return; } if (type_of(fun) == t_cclosure && (fun->cc.cc_turbo)) { if (Rset) { (void) vpush_extend( link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend( *link,sSAlink_arrayA->s.s_dbind); *ptr = (void *)fun; *link = (void *) (fun->cf.cf_self); MMccall(fun); } else { append_link_list(sym,1); MMccall(fun); } return; } if (Rset==0) funcall(fun); /* can't do this if invoking foo(a) is illegal when foo is not defined to take any arguments. In the majority of C's this is legal */ else if (type_of(fun) == t_cfun) { (void) vpush_extend(link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend(*link,sSAlink_arrayA->s.s_dbind); *link = (void *)fun->cf.cf_self; (*(void (*)())fun->cf.cf_self)(); } else { append_link_list(sym,2); funcall(fun); } } /* for pushing item into an array, where item is an address if array-type = t or a fixnum if array-type = fixnum */ #define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val static int vpush_extend(void *item, object ar) { register int ind = ar->ust.ust_fillp; AGAIN: if (ind < ar->ust.ust_dim) {SET_ITEM(ar,ind,item); ind += sizeof(void *); return(ar->v.v_fillp = ind);} else { int newdim= CEI((2 + (int) (1.3 * ind)),PTR_ALIGN); unsigned char *newself; newself = (void *)alloc_relblock(newdim); bcopy(ar->ust.ust_self,newself,ind); ar->ust.ust_dim=newdim; ar->ust.ust_self=newself; goto AGAIN; }} /* if we unlink a bunch of functions, this will mean there are some holes in the link array, and we should probably go through it and push them back */ static int number_unlinked=0; static void delete_link(void *address, object link_ar) {object *ar,*ar_end,*p; p=0; ar = link_ar->v.v_self; ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); while (ar < ar_end) { if (*ar && *((void **)*ar)==address) { p = (object *) *ar; *ar=0; *p = *(ar+1); number_unlinked++;} ar=ar+2;} if (number_unlinked > 40) link_ar->v.v_fillp= clean_link_array(link_ar->v.v_self,ar_end); } DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...), "Usage: (use-fast-links {nil,t} &optional fun) turns on or off \ the fast linking depending on FLAG, so that things will either go \ faster, or turns it off so that stack information is kept. If SYMBOL \ is supplied and FLAG is nil, then this function is deleted from the fast links") {int n = VFUN_NARGS; object sym; va_list ap; object *p,*ar,*ar_end; object link_ar; object fun=Cnil; { va_start(ap,flag); if (n>=2) sym=va_arg(ap,object);else goto LDEFAULT2; goto LEND_VARARG; LDEFAULT2: sym = Cnil ; LEND_VARARG: va_end(ap);} if (sSAlink_arrayA ==0) RETURN1(Cnil); link_ar = sSAlink_arrayA->s.s_dbind; if (link_ar==Cnil && flag==Cnil) RETURN1(Cnil); check_type_array(&link_ar); if (type_of(link_ar) != t_string) { FEerror("*LINK-ARRAY* must be a string",0);} ar = link_ar->v.v_self; ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); switch (n) { case 1: if (flag==Cnil) { Rset=0; while ( ar < ar_end) /* set the link variables back to initial state */ { p = (object *) *ar; if (p) *p = (ar++, *ar); else ar++; ar++; } link_ar->v.v_fillp = 0; } else { Rset=1;} break; case 2: if ((type_of(sym)==t_symbol)) fun = sym->s.s_gfdef; else if (type_of(sym)==t_cclosure) fun = sym; else {FEerror("Second arg: ~a must be symbol or closure",0,sym); } if(Rset) { if(!fun) RETURN1(Cnil); switch(type_of(fun)){ case t_cfun: case t_sfun: case t_vfun: case t_gfun: case t_cclosure: case t_closure: case t_afun: delete_link(fun->cf.cf_self,link_ar); /* becoming obsolete y=getf(sym->s.s_plist,sScdefn,Cnil); if (y!=Cnil) delete_link(fix(y),link_ar); */ break; default: /* no link for uncompiled functions*/ break; } } break; default: FEerror("Usage: (use-fast-links {nil,t} &optional fun)",0); } RETURN1(Cnil); } object fSuse_fast_links_2(object flag,object res) { VFUN_NARGS=2; return FFN(fSuse_fast_links)(flag,res); } object clear_compiler_properties(object sym, object code) { object tem; extern object sSclear_compiler_properties; if (sSclear_compiler_properties && sSclear_compiler_properties->s.s_gfdef!=OBJNULL) if ((sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind != Cnil) || sym->s.s_sfdef == NOT_SPECIAL) (void)ifuncall2(sSclear_compiler_properties,sym,code); tem = getf(sym->s.s_plist,sStraced,Cnil); VFUN_NARGS=2; FFN(fSuse_fast_links)(Cnil,sym); return tem!=Cnil ? tem : sym; } static int clean_link_array(object *ar, object *ar_end) {int i=0; object *orig; orig=ar; number_unlinked=0; while( ars.s_gfdef; if (fun && (type_of(fun)==t_sfun || type_of(fun)==t_gfun || type_of(fun)==t_afun || type_of(fun)== t_vfun) && Rset) {/* the && Rset is to allow tracing */ object (*fn)()=fun->sfn.sfn_self; if (type_of(fun)==t_vfun) { /* argd=VFUN_NARGS; */ /*remove this! */ nargs=SFUN_NARGS(argd); if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK))) goto WRONG_ARGS; if ((VFUN_NARG_BIT & argd) == 0) { /* don't link */ VFUN_NARGS = nargs; goto AFTER_LINK; } } else if (type_of(fun)==t_afun) { ufixnum ad=fun->sfn.sfn_argd; ufixnum at=F_TYPES(ad)>>F_TYPE_WIDTH; ufixnum ma=F_MIN_ARGS(ad); ufixnum xa=F_MAX_ARGS(ad); ufixnum rt=F_RESULT_TYPE(ad); nargs=SFUN_NARGS(argd); if (nargs xa || ((argd>>8)&0x3)!=rt || (argd>>12)!=at) goto WRONG_ARGS; } else {/* t_gfun,t_sfun */ nargs= SFUN_NARGS(argd); if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) goto WRONG_ARGS; } (void) vpush_extend(link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend(*link,sSAlink_arrayA->s.s_dbind); *link = (void *)fn; AFTER_LINK: { object *new; COERCE_VA_LIST(new,ll,nargs); return(c_apply_n_fun(fun,nargs,new)); } } else /* there is no cdefn property */ WRONG_ARGS: { /* regular_call: */ object fun; register object *base; enum ftype result_type; int i; /* we check they are valid functions before calling this */ append_link_list(sym,3); fun=type_of(sym)==t_symbol ? symbol_function(sym) : sym; vs_base=base=vs_top; if (fun==OBJNULL) FEinvalid_function(sym); nargs=SFUN_NARGS(argd); result_type=SFUN_RETURN_TYPE(argd); SFUN_START_ARG_TYPES(argd); if (argd==0) for (i=0;is.s_gfdef; if (fun && (type_of(fun)==t_sfun || type_of(fun)==t_gfun || type_of(fun)==t_afun || type_of(fun)== t_vfun) && Rset) {/* the && Rset is to allow tracing */ object (*fn)()=fun->sfn.sfn_self; if (type_of(fun)==t_vfun) { nargs=SFUN_NARGS(argd); if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK))) goto WRONG_ARGS; if ((VFUN_NARG_BIT & argd) == 0) { VFUN_NARGS = nargs; goto AFTER_LINK; } } else if (type_of(fun)==t_afun) { ufixnum at=F_TYPES(fun->sfn.sfn_argd)>>F_TYPE_WIDTH; ufixnum ma=F_MIN_ARGS(fun->sfn.sfn_argd); ufixnum xa=F_MAX_ARGS(fun->sfn.sfn_argd); ufixnum rt=F_RESULT_TYPE(fun->sfn.sfn_argd); nargs=SFUN_NARGS(argd); if (nargs xa || ((argd>>8)&0x3)!=rt || (argd>>12)!=at) goto WRONG_ARGS; } else { /* t_gfun,t_sfun */ nargs= SFUN_NARGS(argd); if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) goto WRONG_ARGS; } (void) vpush_extend(link,sSAlink_arrayA->s.s_dbind); (void) vpush_extend(*link,sSAlink_arrayA->s.s_dbind); *link = (void *)fn; AFTER_LINK: { object *new; COERCE_VA_LIST_NEW(new,first,ll,nargs); return(c_apply_n_fun(fun,nargs,new)); } } else /* there is no cdefn property */ WRONG_ARGS: { /* regular_call: */ object fun; register object *base; enum ftype result_type; int i; append_link_list(sym,4); /* we check they are valid functions before calling this */ fun=type_of(sym)==t_symbol ? symbol_function(sym) : sym; vs_base=base=vs_top; if (fun==OBJNULL) FEinvalid_function(sym); nargs=SFUN_NARGS(argd); result_type=SFUN_RETURN_TYPE(argd); SFUN_START_ARG_TYPES(argd); if (argd==0) for (i=0;is.s_gfdef)==t_cfun) (*(sym->s.s_gfdef)->cf.cf_self)(); else super_funcall(sym); x = vs_base[0]; vs_top = old_vs_top; vs_base = old_vs_base; return(x); } /* static object */ /* imfuncall(object sym,int n,...) */ /* { va_list ap; */ /* int i; */ /* object *old_vs_top; */ /* old_vs_top = vs_top; */ /* vs_base = old_vs_top; */ /* vs_top=old_vs_top+n; */ /* vs_check; */ /* va_start(ap,n); */ /* for(i=0;is.s_gfdef)==t_cfun) */ /* (*(sym->s.s_gfdef)->cf.cf_self)(); */ /* else super_funcall(sym); */ /* return(vs_base[0]); */ /* } */ /* go from beg+1 below limit setting entries equal to 0 until you come to FRESH 0's . */ #define FRESH 40 int clear_stack(object *beg, object *limit) {int i=0; while (++beg < limit) {if (*beg==0) i++; if (i > FRESH) return 0; ;*beg=0;} return 0;} static object FFN(set_mv)(int i, object val) { if (i >= (sizeof(MVloc)/sizeof(object))) FEerror("Bad mv index",0); return(MVloc[i]=val); } static object FFN(mv_ref)(unsigned int i) { object x; if (i >= (sizeof(MVloc)/sizeof(object))) FEerror("Bad mv index",0); x = MVloc[i]; return x; } #include "xdrfuns.c" DEF_ORDINARY("CDEFN",sScdefn,SI,""); DEFVAR("*LINK-ARRAY*",sSAlink_arrayA,SI,Cnil,""); void gcl_init_links(void) { make_si_sfun("SET-MV",set_mv, ARGTYPE2(f_fixnum,f_object) | RESTYPE(f_object)); make_si_sfun("MV-REF",mv_ref, ARGTYPE1(f_fixnum) | RESTYPE(f_object)); gcl_init_xdrfuns(); } gcl-2.6.14/o/pre_init.c0000755000175000017500000000263514360276512013217 0ustar cammcamm#include "all.h" #include "funlink.h" #define SI 0 #define LISP 1 #define KEYWORD 2 #define NONE 0 void SI_makefun(),LISP_makefun(),error(); #define MAKEFUN(pack,string,fname,argd) \ (pack == SI ? SI_makefun : pack == LISP ? LISP_makefun : error)(string,fname,argd) #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} #undef DEFUNO #define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} #undef DEFCOMP #define DEFCOMP(type, fun) Ineed_in_image(fun); #undef DEFVAR #define DEFVAR(name,cname,pack,val) \ { extern obj cname; \ cname = (pack == LISP ? make_special(name,val) : \ pack == SI ? make_si_special(name,val): \ (error(name,val),(obj)0));} #undef DEFCONST #define DEFCONST(name,cname,pack,val) \ { extern obj cname; \ cname = (pack == LISP ? make_constant(name,val) : \ pack == SI ? make_si_constant(name,val): \ (error(name,val),(obj)0));} #undef DEF_ORDINARY #define DEF_ORDINARY(name,cname,pack) \ { extern obj cname ; cname = (pack == LISP ? make_ordinary(name) : \ pack == SI ? make_si_ordinary(name): \ (error(name),(obj)0));} #undef DO_INIT #define DO_INIT(x) x gcl-2.6.14/o/pari_num_log.c0000644000175000017500000001116514360276512014054 0ustar cammcamm/* big_log_op(x, y, op) performs the logical operation op onto x and y, and return the result in x destructively. */ void minimize_lg(x) GEN x; {int j,i,lgx = lgef(x); GEN u = x+2; i = lgx; i -= 2; while (-- i >= 0) { if (*u++) break; } j = lgx -i -3; if (j) { GEN v = x+2; GEN w = v + j; GEN lim = x+lgx; while (w=0) { unsigned int last = MP_NEXT_UP(w); MP_NEXT_UP(v) = next - last ; if (last > next) { next -= 1 ;}} return u;}} object big_log_op(x0,y0,op) object x0,y0; plong (*op)(); { int leadx,leady; int result_length; int lgx,lgy; GEN x,y,u,up,result; save_avma; x = MP(x0); y = (type_of(y0)==t_bignum ? MP(y0) : stoi(fix(y0))); leadx = signe(x); lgx=lgef(x); if (leadx < 0) x = complementi(x); else leadx = 0; lgy = lgef(y); leady = signe(y); if (leady < 0) y=complementi(y); else leady = 0; result_length = (lgx > lgy ? lgx : lgy); u = result = cgeti(result_length); setlgef(result,result_length); MP_START_LOW(u,u,result_length); result_length -= MP_CODE_WORDS; x += lgx; y += lgy; lgx -= MP_CODE_WORDS; lgy -= MP_CODE_WORDS; while (--lgx >= 0) { if (--lgy >= 0) { MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),MP_NEXT_UP(y));} else MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),leady); } /* lgx is now 0 */ while (--lgy >= 0) { MP_NEXT_UP(u) = (*op)(leadx,MP_NEXT_UP(y));} {int leadresult = (*op)(leadx,leady); if (leadresult < 0) { result = complementi(result); setsigne(result,-1);} else setsigne(result,1);} minimize_lg(result); restore_avma; gcopy_to_big(result,x0); return x0; } /* x : fixnum or bignum (may be not normalized) y : integer returns fixnum or bignum ( not normalized ) */ object big_log_op(); /* x : fixnum or bignum (may be not normalized) y : integer returns fixnum or bignum ( not normalized ) */ static object log_op(op,ignore) int (*op)(); void (*ignore)(); { object x; int narg, i, j; narg = vs_top - vs_base; if (narg < 2) too_few_arguments(); i = narg; while(--i >= 0) if (type_of(vs_base[i]) == t_bignum) goto BIG_OP; j = fix(vs_base[0]); i = 1; while (i < narg) { j = (*op)(j, fix(vs_base[i])); i++; } return(make_fixnum(j)); BIG_OP: x = (object)copy_to_big(vs_base[0]); vs_push(x); i = 1; {save_avma; while (i < narg) { x = (object)big_log_op(x, vs_base[i], op); i++; } restore_avma;} x = normalize_big_to_object(x); vs_pop; return(x); } static int big_bitp(x, p) object x; int p; { GEN u = MP(x); int ans ; int i = p /32; if (signe(u) < 0) { save_avma; u = complementi(u); restore_avma; } if (i < lgef(u) -MP_CODE_WORDS) { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} else if (big_sign(x) < 0) ans = 1; else ans = 0; return ans; } /* these done without function call in above code ... */ #define mp_b_clr_op (void *)0 #define mp_b_set_op (void *)0 #define mp_b_1_op (void *)0 #define mp_b_2_op (void *)0 #define mp_b_c1_op (void *)0 #define mp_b_c2_op (void *)0 #define mp_and_op (void *)0 #define mp_ior_op (void *)0 #define mp_xor_op (void *)0 #define mp_eqv_op (void *)0 #define mp_nand_op (void *)0 #define mp_nor_op (void *)0 #define mp_andc1_op (void *)0 #define mp_andc2_op (void *)0 #define mp_orc1_op (void *)0 #define mp_orc2_op (void *)0 /* like integer-length in base 2 */ gen_bitlength(u) GEN u; { GEN w; int l = lg(u); our_ulong high; w = u; MP_START_HIGH(u,u,l); high = MP_NEXT_DOWN(u); count = int_bit_length(high) ; l -= MP_CODE_WORDS; if (signe(w) < 0 && high == (1 << (count -1))) /* in the case of -(1<< n) it is one less */ { int ll = l; int nzero = 0; while (--ll > 0) { if (MP_NEXT_DOWN(u)) {nzero= 1; break;}} if (nzero == 0) --count ;} count += 32* (l - 1); return count; } /* number of 1's in 2's complement notation */ gen_bitcount(u) GEN u; { save_avma; if (signe(u) < 0) { u = subsi(-1,u);} count = 0; {int leng = lgef(u); MP_START_LOW(u,u,leng); leng -= MP_CODE_WORDS; while (--leng >= 0) { count += count_int_bits(MP_NEXT_UP(u));}} restore_avma; return count; } gcl-2.6.14/o/NeXTunixsave.c0000755000175000017500000002432214360276512014004 0ustar cammcamm/* * unexec for the NeXT Mach environment. * * Bradley Taylor (btaylor@NeXT.COM) * February 28, 1990 * * Modified by Noritake YONEZAWA (yonezawa@cs.uiuc.edu) * July 28, 1991 * * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) * February 16, 1992 * * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) * May 1, 1995 */ #undef __STRICT_BSD__ #include #include #include #include #include #include #include #define CEIL(x,quantum) ((((int)(x))+(quantum)-1)&~((quantum)-1)) #ifndef BIG_HEAP_SIZE #define BIG_HEAP_SIZE 0x1000000 #endif int big_heap = BIG_HEAP_SIZE; char *mach_maplimit = 0; char *mach_brkpt = 0; typedef struct region_t { vm_address_t address; vm_size_t size; vm_prot_t protection; vm_prot_t max_protection; vm_inherit_t inheritance; boolean_t shared; port_t object_name; vm_offset_t offset; } region_t; char * my_sbrk(incr) int incr; { char *temp, *ptr; kern_return_t rtn; if (mach_brkpt == 0) { if ((rtn = vm_allocate(task_self(), (vm_address_t *) & mach_brkpt, big_heap, 1)) != KERN_SUCCESS) { mach_error("my_sbrk(): vm_allocate() failed", rtn); return ((char *)-1); } mach_maplimit = mach_brkpt + big_heap; } if (incr == 0) { return (mach_brkpt); } else { ptr = mach_brkpt + incr; if (ptr <= mach_maplimit) { temp = mach_brkpt; mach_brkpt = ptr; return (temp); } else { fprintf(stderr, "my_sbrk(): no more memory\n"); fflush(stderr); return ((char *)-1); } } } static void grow( struct load_command ***the_commands, unsigned *the_commands_len ) { if (*the_commands == NULL) { *the_commands_len = 1; *the_commands = malloc(sizeof(*the_commands)); } else { (*the_commands_len)++; *the_commands = realloc(*the_commands, (*the_commands_len * sizeof(**the_commands))); } } static void save_command( struct load_command *command, struct load_command ***the_commands, unsigned *the_commands_len ) { struct load_command **tmp; grow(the_commands, the_commands_len); tmp = &(*the_commands)[*the_commands_len - 1]; *tmp = malloc(command->cmdsize); bcopy(command, *tmp, command->cmdsize); } static void fatal_unexec(char *format) { fprintf(stderr, "unexec: "); fprintf(stderr, format); fprintf(stderr, "\n"); } static void fatal_unexec2( char *format, char *arg1 ) { fprintf(stderr, "unexec: "); fprintf(stderr, format, arg1); fprintf(stderr, "\n"); } static void fatal_unexec3( char *format, char *arg1, char *arg2 ) { fprintf(stderr, "unexec: "); fprintf(stderr, format, arg1, arg2); fprintf(stderr, "\n"); } static int read_macho( int fd, struct mach_header *the_header, struct load_command ***the_commands, unsigned *the_commands_len ) { struct load_command command; struct load_command *buf; int i; int size; if (read(fd, the_header, sizeof(*the_header)) != sizeof(*the_header)) { fatal_unexec("cannot read macho header"); return (0); } for (i = 0; i < the_header->ncmds; i++) { if (read(fd, &command, sizeof(struct load_command)) != sizeof(struct load_command)) { fatal_unexec("cannot read macho load command header"); return (0); } size = command.cmdsize - sizeof(struct load_command); if (size < 0) { fatal_unexec("bogus load command size"); return (0); } buf = malloc(command.cmdsize); buf->cmd = command.cmd; buf->cmdsize = command.cmdsize; if (read(fd, ((char *)buf + sizeof(struct load_command)), size) != size) { fatal_unexec("cannot read load command data"); return (0); } save_command(buf, the_commands, the_commands_len); } return (1); } static int filldatagap( vm_address_t start_address, vm_size_t *size, vm_address_t end_address ) { vm_address_t address; vm_size_t gapsize; address = (start_address + *size); gapsize = end_address - address; *size += gapsize; if (vm_allocate(task_self(), &address, gapsize, FALSE) != KERN_SUCCESS) { fatal_unexec("cannot vm_allocate"); return (0); } return (1); } static int get_data_region( vm_address_t *address, vm_size_t *size ) { region_t region; kern_return_t ret; struct section *sect; sect = getsectbyname(SEG_DATA, SECT_DATA); region.address = 0; *address = 0; for (;;) { ret = vm_region(task_self(), ®ion.address, ®ion.size, ®ion.protection, ®ion.max_protection, ®ion.inheritance, ®ion.shared, ®ion.object_name, ®ion.offset); if (ret != KERN_SUCCESS || region.address >= mach_maplimit) { break; } if (*address != 0) { if (region.address > *address + *size) { if (!filldatagap(*address, size, region.address)) { return (0); } } *size += region.size; } else { if (region.address == sect->addr) { *address = region.address; *size = region.size; } } region.address += region.size; } return (1); } static char * my_malloc( vm_size_t size ) { vm_address_t address; if (vm_allocate(task_self(), &address, size, TRUE) != KERN_SUCCESS) { return (NULL); } return ((char *)address); } static void my_free( char *buf, vm_size_t size ) { vm_deallocate(task_self(), (vm_address_t)buf, size); } static int unexec_doit( int infd, int outfd ) { int i; struct load_command **the_commands = NULL; unsigned the_commands_len; struct mach_header the_header; int fgrowth; int fdatastart; int fdatasize; int size; int seg; struct stat st; char *buf; vm_address_t data_address; vm_size_t data_size, bss_size; struct segment_command *segment; struct section *section; if (!read_macho(infd, &the_header, &the_commands, &the_commands_len)) { return (0); } if (!get_data_region(&data_address, &data_size)) { return (0); } /* * DO NOT USE MALLOC IN THIS SECTION */ { /* * Fix offsets */ for (i = 0; i < the_commands_len; i++) { switch (the_commands[i]->cmd) { case LC_SEGMENT: segment = ((struct segment_command *) the_commands[i]); if (strcmp(segment->segname, SEG_DATA) == 0) { /* data_address = segment->vmaddr; */ data_size = CEIL(mach_brkpt - data_address, getpagesize()); bss_size = mach_maplimit - mach_brkpt; fdatastart = segment->fileoff; fdatasize = segment->filesize; fgrowth = (data_size - segment->filesize); segment->vmsize = data_size + bss_size; segment->filesize = data_size; section = (struct section *) ((char *) (segment + 1)); for (seg = 0; seg < segment->nsects; ++seg, ++section) { if (strcmp(section->sectname, SECT_DATA) == 0) { section->size = data_size; } else if (strcmp(section->sectname, SECT_BSS) == 0) { section->addr = data_address + data_size; section->size = bss_size; section->flags = S_ZEROFILL; } else if (strcmp(section->sectname, SECT_COMMON) == 0) { section->addr = data_address + data_size + bss_size; } } } if (strcmp(segment->segname, SEG_LINKEDIT) == 0) { segment->vmaddr += CEIL(fgrowth + bss_size, getpagesize()); segment->fileoff += fgrowth; } break; case LC_SYMTAB: ((struct symtab_command *) the_commands[i])->symoff += fgrowth; ((struct symtab_command *) the_commands[i])->stroff += fgrowth; break; case LC_SYMSEG: ((struct symseg_command *) the_commands[i])->offset += fgrowth; break; default: break; } } /* * Write header */ if (write(outfd, &the_header, sizeof(the_header)) != sizeof(the_header)) { fatal_unexec("cannot write header"); return (0); } /* * Write commands */ for (i = 0; i < the_commands_len; i++) { if (write(outfd, the_commands[i], the_commands[i]->cmdsize) != the_commands[i]->cmdsize) { fatal_unexec("cannot write commands"); return (0); } } /* * Write original text */ if (lseek(infd, the_header.sizeofcmds + sizeof(the_header), L_SET) < 0) { fatal_unexec("cannot seek input file"); return (0); } size = fdatastart - (sizeof(the_header) + the_header.sizeofcmds); buf = my_malloc(size); if (read(infd, buf, size) != size) { my_free(buf, size); fatal_unexec("cannot read input file"); } if (write(outfd, buf, size) != size) { my_free(buf, size); fatal_unexec("cannot write original text"); return (0); } my_free(buf, size); /* * Write new data */ if (write(outfd, (char *)data_address, data_size) != data_size) { fatal_unexec("cannot write new data"); return (0); } } /* * OKAY TO USE MALLOC NOW */ /* * Write rest of file */ fstat(infd, &st); if (lseek(infd, fdatasize, L_INCR) < 0) { fatal_unexec("cannot seek input file"); return (0); } size = st.st_size - lseek(infd, 0, L_INCR); buf = malloc(size); if (read(infd, buf, size) != size) { free(buf); fatal_unexec("cannot read input file"); return (0); } if (write(outfd, buf, size) != size) { free(buf); fatal_unexec("cannot write reset of file"); return (0); } free(buf); return (1); } void unexec( char *outfile, char *infile, int dummy1, int dummy2, int dummy3 ) { int infd; int outfd; char tmpbuf[L_tmpnam]; char *tmpfile; infd = open(infile, O_RDONLY, 0); if (infd < 0) { fatal_unexec2("cannot open input file `%s'", infile); exit(1); } tmpnam(tmpbuf); tmpfile = rindex(tmpbuf, '/'); if (tmpfile == NULL) { tmpfile = tmpbuf; } else { tmpfile++; } outfd = open(tmpfile, O_WRONLY|O_TRUNC|O_CREAT, 0755); if (outfd < 0) { close(infd); fatal_unexec2("cannot open tmp file `%s'", tmpfile); exit(1); } if (!unexec_doit(infd, outfd)) { close(infd); close(outfd); unlink(tmpfile); exit(1); } close(infd); close(outfd); if (rename(tmpfile, outfile) < 0) { unlink(tmpfile); fatal_unexec3("cannot rename `%s' to `%s'", tmpfile, outfile); exit(1); } } #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/character.d0000755000175000017500000003366514360276512013352 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* character.d character routines */ #include "include.h" @(defun standard_char_p (c) int i; @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) i = char_code(c); if ((' ' <= i && i < '\177') || i == '\n') @(return Ct) @(return Cnil) @) @(defun graphic_char_p (c) int i; @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) i = char_code(c); if (' ' <= i && i < '\177') @(return Ct) @(return Cnil) @) @(defun alpha_char_p (c) int i; @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) i = char_code(c); if (isalpha(i)) @(return Ct) else @(return Cnil) @) @(defun upper_case_p (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) if (isUpper(char_code(c))) @(return Ct) @(return Cnil) @) @(defun lower_case_p (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) if (isLower(char_code(c))) @(return Ct) @(return Cnil) @) @(defun both_case_p (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) if (isUpper(char_code(c)) || isLower(char_code(c))) @(return Ct) else @(return Cnil) @) /* Digitp(i, r) returns the weight of code i as a digit of radix r. If r > 36 or i is not a digit, -1 is returned. */ int digitp(i, r) int i, r; { if ('0' <= i && i <= '9' && 1 < r && i < '0' + r) return(i - '0'); if ('A' <= i && 10 < r && r <= 36 && i < 'A' + (r - 10)) return(i - 'A' + 10); if ('a' <= i && 10 < r && r <= 36 && i < 'a' + (r - 10)) return(i - 'a' + 10); return(-1); } @(defun digit_char_p (c &optional (r `make_fixnum(10)`)) int d; @ check_type_character(&c); check_type_non_negative_integer(&r); if (type_of(r) == t_bignum) @(return Cnil) if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) d = digitp(char_code(c), fix(r)); if (d < 0) @(return Cnil) @(return `make_fixnum(d)`) @) @(defun alphanumericp (c) int i; @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) i = char_code(c); if (isalphanum(i)) @(return Ct) else @(return Cnil) @) bool char_eq(x, y) object x, y; { return(char_code(x) == char_code(y) && char_bits(x) == char_bits(y) && char_font(x) == char_font(y)); } @(defun char_eq (c &rest) int i; @ check_type_character(&c); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); for (i = 1; i < narg; i++) if (!char_eq(vs_base[i-1], vs_base[i])) @(return Cnil) @(return Ct) @) @(defun char_neq (c &rest) int i, j; @ check_type_character(&c); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); if (narg == 0) @(return Ct) for (i = 1; i < narg; i++) for (j = 0; j < i; j++) if (char_eq(vs_base[j], vs_base[i])) @(return Cnil) @(return Ct) @) static int char_cmp(x, y) object x, y; { if (char_font(x) < char_font(y)) return(-1); if (char_font(x) > char_font(y)) return(1); if (char_bits(x) < char_bits(y)) return(-1); if (char_bits(x) > char_bits(y)) return(1); if (char_code(x) < char_code(y)) return(-1); if (char_code(x) > char_code(y)) return(1); return(0); } static void Lchar_cmp(s, t) int s, t; { int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); for (i = 1; i < narg; i++) if (s*char_cmp(vs_base[i], vs_base[i-1]) < t) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } vs_top = vs_base+1; vs_base[0] = Ct; } LFD(Lchar_l)() { Lchar_cmp( 1, 1); } LFD(Lchar_g)() { Lchar_cmp(-1, 1); } LFD(Lchar_le)() { Lchar_cmp( 1, 0); } LFD(Lchar_ge)() { Lchar_cmp(-1, 0); } bool char_equal(x, y) object x, y; { int i, j; i = char_code(x); j = char_code(y); if (isLower(i)) i -= 'a' - 'A'; if (isLower(j)) j -= 'a' - 'A'; return(i == j); } @(defun char_equal (c &rest) int i; @ check_type_character(&c); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); for (i = 1; i < narg; i++) if (!char_equal(vs_base[i-1], vs_base[i])) @(return Cnil) @(return Ct) @) @(defun char_not_equal (c &rest) int i, j; @ check_type_character(&c); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); for (i = 1; i < narg; i++) for (j = 0; j < i; j++) if (char_equal(vs_base[j], vs_base[i])) @(return Cnil) @(return Ct) @) static int char_compare(x, y) object x, y; { int i, j; i = char_code(x); j = char_code(y); if (isLower(i)) i -= 'a' - 'A'; if (isLower(j)) j -= 'a' - 'A'; if (i < j) return(-1); else if (i == j) return(0); else return(1); } static void Lchar_compare(s, t) int s, t; { int narg, i; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_character(&vs_base[i]); for (i = 1; i < narg; i++) if (s*char_compare(vs_base[i], vs_base[i-1]) < t) { vs_top = vs_base+1; vs_base[0] = Cnil; return; } vs_top = vs_base+1; vs_base[0] = Ct; } LFD(Lchar_lessp)() { Lchar_compare( 1, 1); } LFD(Lchar_greaterp)() { Lchar_compare(-1, 1); } LFD(Lchar_not_greaterp)() { Lchar_compare( 1, 0); } LFD(Lchar_not_lessp)() { Lchar_compare(-1, 0); } object coerce_to_character(x) object x; { BEGIN: switch (type_of(x)) { case t_fixnum: if (0 <= fix(x) && fix(x) < CHCODELIM) return(code_char(fix(x))); break; case t_character: return(x); case t_symbol: case t_string: if (x->st.st_fillp == 1) return(code_char(x->ust.ust_self[0])); break; default: break; } vs_push(x); x = wrong_type_argument(sLcharacter, x); vs_popp; goto BEGIN; } @(defun character (x) @ @(return `coerce_to_character(x)`) @) @(defun char_code (c) @ check_type_character(&c); @(return `make_fixnum(char_code(c))`) @) @(defun code_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`)) object x; @ check_type_non_negative_integer(&c); check_type_non_negative_integer(&b); check_type_non_negative_integer(&f); if (type_of(c) == t_bignum) @(return Cnil) if (type_of(b) == t_bignum) @(return Cnil) if (type_of(f) == t_bignum) @(return Cnil) if (fix(c)>=CHCODELIM || fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM) @(return Cnil) if (fix(b) == 0 && fix(f) == 0) @(return `code_char(fix(c))`) x = alloc_object(t_character); char_code(x) = fix(c); char_bits(x) = fix(b); char_font(x) = fix(f); @(return x) @) @(defun char_upcase (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return c) if (isLower(char_code(c))) @(return `code_char(char_code(c) - ('a' - 'A'))`) else @(return c) @) @(defun char_downcase (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) if (isUpper(char_code(c))) @(return `code_char(char_code(c) + ('a' - 'A'))`) else @(return c) @) int digit_weight(w, r) int w, r; { if (r < 2 || r > 36 || w < 0 || w >= r) return(-1); if (w < 10) return(w + '0'); else return(w - 10 + 'A'); } @(defun digit_char (w &optional (r `make_fixnum(10)`) (f `make_fixnum(0)`)) object x; int dw; @ check_type_non_negative_integer(&w); check_type_non_negative_integer(&r); check_type_non_negative_integer(&f); if (type_of(w) == t_bignum) @(return Cnil) if (type_of(r) == t_bignum) @(return Cnil) if (type_of(f) == t_bignum) @(return Cnil) dw = digit_weight(fix(w), fix(r)); if (dw < 0) @(return Cnil) if (fix(f) >= CHFONTLIM) @(return Cnil) if (fix(f) == 0) @(return `code_char(dw)`) x = alloc_object(t_character); char_code(x) = dw; char_bits(x) = 0; char_font(x) = fix(f); @(return x) @) @(defun char_int (c) int i; @ check_type_character(&c); i = (char_font(c)*CHBITSLIM + char_bits(c))*CHCODELIM + char_code(c); @(return `make_fixnum(i)`) @) @(defun char_name (c) @ check_type_character(&c); if (char_bits(c) != 0 || char_font(c) != 0) @(return Cnil) switch (char_code(c)) { case '\r': @(return STreturn) case ' ': @(return STspace) case '\177': @(return STrubout) case '\f': @(return STpage) case '\t': @(return STtab) case '\b': @(return STbackspace) case '\n': @(return STnewline) } @(return Cnil) @) @(defun name_char (s) @ s = coerce_to_string(s); if (string_equal(s, STreturn)) @(return `code_char('\r')`) if (string_equal(s, STspace)) @(return `code_char(' ')`) if (string_equal(s, STrubout)) @(return `code_char('\177')`) if (string_equal(s, STpage)) @(return `code_char('\f')`) if (string_equal(s, STtab)) @(return `code_char('\t')`) if (string_equal(s, STbackspace)) @(return `code_char('\b')`) if (string_equal(s, STlinefeed) || string_equal(s, STnewline)) @(return `code_char('\n')`) @(return Cnil) @) void gcl_init_character() { int i; for (i = 0; i < CHCODELIM; i++) { object x=(object)(character_table+i); x->fw=0; set_type_of(x,t_character); /* character_table[i].ch.t = (short)t_character; */ character_table[i].ch.ch_code = i; character_table[i].ch.ch_font = 0; character_table[i].ch.ch_bits = 0; } #ifdef AV for (i = -128; i < 0; i++) { character_table[i].ch.t = (short)t_character; character_table[i].ch.ch_code = i+CHCODELIM; character_table[i].ch.ch_font = 0; character_table[i].ch.ch_bits = 0; } #endif make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM)); make_si_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM)); make_si_constant("CHAR-BITS-LIMIT", make_fixnum(CHBITSLIM)); STreturn = make_simple_string("Return"); enter_mark_origin(&STreturn); STspace = make_simple_string("Space"); enter_mark_origin(&STspace); STrubout = make_simple_string("Rubout"); enter_mark_origin(&STrubout); STpage = make_simple_string("Page"); enter_mark_origin(&STpage); STtab = make_simple_string("Tab"); enter_mark_origin(&STtab); STbackspace = make_simple_string("Backspace"); enter_mark_origin(&STbackspace); STlinefeed = make_simple_string("Linefeed"); enter_mark_origin(&STlinefeed); STnewline = make_simple_string("Newline"); enter_mark_origin(&STnewline); make_si_constant("CHAR-CONTROL-BIT", make_fixnum(0)); make_si_constant("CHAR-META-BIT", make_fixnum(0)); make_si_constant("CHAR-SUPER-BIT", make_fixnum(0)); make_si_constant("CHAR-HYPER-BIT", make_fixnum(0)); } @(defun make_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`)) object x; int code; @ check_type_character(&c); code = char_code(c); check_type_non_negative_integer(&b); check_type_non_negative_integer(&f); if (type_of(b) == t_bignum) @(return Cnil) if (type_of(f) == t_bignum) @(return Cnil) if (fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM) @(return Cnil) if (fix(b) == 0 && fix(f) == 0) @(return `code_char(code)`) x = alloc_object(t_character); char_code(x) = code; char_bits(x) = fix(b); char_font(x) = fix(f); @(return x) @) @(defun char_bits (c) @ check_type_character(&c); @(return `small_fixnum(char_bits(c))`) @) @(defun char_font (c) @ check_type_character(&c); @(return `small_fixnum(char_font(c))`) @) @(defun char_bit (c n) @ check_type_character(&c); FEerror("Cannot get char-bit of ~S.", 1, c); @) @(defun set_char_bit (c n v) @ check_type_character(&c); FEerror("Cannot set char-bit of ~S.", 1, c); @) @(defun string_char_p (c) @ check_type_character(&c); if (char_font(c) != 0 || char_bits(c) != 0) @(return Cnil) @(return Ct) @) @(defun int_char (x) int i, c, b, f; @ check_type_non_negative_integer(&x); if (type_of(x) == t_bignum) @(return Cnil) i = fix(x); c = i % CHCODELIM; i /= CHCODELIM; b = i % CHBITSLIM; i /= CHBITSLIM; f = i % CHFONTLIM; i /= CHFONTLIM; if (i > 0) @(return Cnil) if (b == 0 && f == 0) @(return `code_char(c)`) x = alloc_object(t_character); char_code(x) = c; char_bits(x) = b; char_font(x) = f; @(return x) @) void gcl_init_character_function() { make_function("STANDARD-CHAR-P", Lstandard_char_p); make_function("GRAPHIC-CHAR-P", Lgraphic_char_p); make_function("ALPHA-CHAR-P", Lalpha_char_p); make_function("UPPER-CASE-P", Lupper_case_p); make_function("LOWER-CASE-P", Llower_case_p); make_function("BOTH-CASE-P", Lboth_case_p); make_function("DIGIT-CHAR-P", Ldigit_char_p); make_function("ALPHANUMERICP", Lalphanumericp); make_function("CHAR=", Lchar_eq); make_function("CHAR/=", Lchar_neq); make_function("CHAR<", Lchar_l); make_function("CHAR>", Lchar_g); make_function("CHAR<=", Lchar_le); make_function("CHAR>=", Lchar_ge); make_function("CHAR-EQUAL", Lchar_equal); make_function("CHAR-NOT-EQUAL", Lchar_not_equal); make_function("CHAR-LESSP", Lchar_lessp); make_function("CHAR-GREATERP", Lchar_greaterp); make_function("CHAR-NOT-GREATERP", Lchar_not_greaterp); make_function("CHAR-NOT-LESSP", Lchar_not_lessp); make_function("CHARACTER", Lcharacter); make_function("CHAR-CODE", Lchar_code); make_function("CODE-CHAR", Lcode_char); make_function("CHAR-UPCASE", Lchar_upcase); make_function("CHAR-DOWNCASE", Lchar_downcase); make_function("DIGIT-CHAR", Ldigit_char); make_function("CHAR-INT", Lchar_int); make_function("CHAR-NAME", Lchar_name); make_function("NAME-CHAR", Lname_char); make_si_function("INT-CHAR", Lint_char); make_si_function("MAKE-CHAR", Lmake_char); make_si_function("CHAR-BITS", Lchar_bits); make_si_function("CHAR-FONT", Lchar_font); make_si_function("CHAR-BIT", Lchar_bit); make_si_function("SET-CHAR-BIT", Lset_char_bit); make_si_function("STRING-CHAR-P", Lstring_char_p); } gcl-2.6.14/o/plt.c0000644000175000017500000001116714360276512012202 0ustar cammcamm#include #include #include #include #include #include #include #include #include "include.h" typedef struct { const char *n; unsigned long ad; } Plt; #ifdef LEADING_UNDERSCORE #define stn(a_) (*(a_)=='_' ? (a_)+1 : (a_)) #else #define stn(a_) a_ #endif static int pltcomp(const void *v1,const void *v2) { const Plt *p1=v1,*p2=v2; return strcmp(p1->n,p2->n); } extern int mcount(); extern int _mcount(); extern int __divdi3(); extern int __moddi3(); extern int __udivdi3(); extern int __umoddi3(); extern void sincos(double,double *,double *); extern int __divsi3(); extern int __modsi3(); extern int __udivsi3(); extern int __umodsi3(); extern int $$divI(); extern int $$divU(); extern int $$remI(); extern int $$remU(); extern int __divq(); extern int __divqu(); extern int __remq(); extern int __remqu(); #define MY_PLT(a_) {#a_,(unsigned long)(void *)a_} static Plt mplt[]={ /* This is an attempt to at least capture the addresses to which the compiler directly refers in C code. (Some symbols are not explicitly mentioned in the C source but are generated by gcc, usually in a platform specific way). At the time of this writing, these symbols alone are sufficient for compiling maxima,acl2,and axiom on x86. This table is not (currently at least) consulted in actuality -- the mere mention of the symbols here (at present) ensures that the symbols are assigned values by the linker, which are used preferentially to these values in sfasli.c. FIXME -- this should be made synchronous with compiler changes; sort the list automatically. SORT THIS LIST BY HAND FOR THE TIME BEING. */ #ifndef _WIN32 # include "plt.h" #endif }; object sSAplt_tableA; DEFVAR("*PLT-TABLE*",sSAplt_tableA,SI,Cnil,""); static int arsort(const void *v1,const void *v2) { const object *op1=v1,*op2=v2; object o1=*op1,o2=*op2; int j; o1=o1->c.c_car; o2=o2->c.c_car; if ((j=strncmp(o1->st.st_self, o2->st.st_self, o1->st.st_dimst.st_dim ? o1->st.st_dim : o2->st.st_dim))) return j; j=o1->st.st_dim-o2->st.st_dim; return j>0 ? 1 : (!j ? 0 : -1); } static int arsearch(const void *v1,const void *v2) { const char *s=v1; const object *op=v2; int j; if ((j=strncmp(s,(*op)->c.c_car->st.st_self,(*op)->c.c_car->st.st_dim))) return j; j=strlen(s)-(*op)->c.c_car->st.st_dim; return j>0 ? 1 : (!j ? 0 : -1); } int parse_plt() { FILE *f; char b[1024],b1[1024]; unsigned i,n,j; unsigned long u; #ifdef _WIN32 char *exe_start = NULL; /* point to start of .exe */ #endif char *c,*d; object st,fi,li,ar,*op; Plt *p=mplt,*pe=p+sizeof(mplt)/sizeof(*mplt); struct stat ss; if (snprintf(b,sizeof(b),"%s",kcl_self)<=0) FEerror("Cannot write map filename",0); #ifdef _WIN32 exe_start = strstr ( b, ".exe" ); if ( NULL != exe_start ) *exe_start = '\0'; #endif c=b+strlen(b); if (sizeof(b)-(c-b)<5) FEerror("Cannot write map filename",0); strcpy(c,"_map"); strcpy(b1,b); if (stat(b1,&ss)) return 0; if (!(f=fopen(b1,"r"))) FEerror("Cannot open map file", 0); for (i=j=0,li=Cnil;fgets(b,sizeof(b),f);) { if (!memchr(b,10,sizeof(b)-1)) FEerror("plt buffer too small", 0); if (!memcmp(b," .plt",4)) { i=1; continue; } if (*b!=' ' || b[1]!=' ' || !i) { i=0; continue; } if (sscanf(b,"%lx%n",&u,&n)!=1) FEerror("Cannot read address", 0); for (c=b+n;*c==32;c++); for (d=c;*d!='@' && *d!='\r' && *d!='\n';d++); *d=0; st=make_simple_string(c); fi=make_fixnum(u); li=make_cons(make_cons(st,fi),li); j++; } fclose(f); unlink(b1); ar=fSmake_vector1_1(j,aet_object,Cnil); for (;j && !endp(li);li=li->c.c_cdr) ar->v.v_self[--j]=li->c.c_car; if (j || !endp(li)) FEerror("plt list mismatch", 0); qsort(ar->v.v_self,ar->v.v_dim,sizeof(*ar->v.v_self),arsort); for (;pn,ar->v.v_self,ar->v.v_dim,sizeof(*ar->v.v_self),arsearch)) && (*op)->c.c_cdr->FIX.FIXVAL != p->ad) FEerror("plt/ld address mismatch",0); sSAplt_tableA->s.s_dbind=ar; return 0; } int my_plt(const char *s,unsigned long *v) { Plt *p=mplt,*pe=p+sizeof(mplt)/sizeof(*mplt),tp; object *op; if (sSAplt_tableA->s.s_dbind && (op=bsearch(s,sSAplt_tableA->s.s_dbind->v.v_self, sSAplt_tableA->s.s_dbind->v.v_dim, sizeof(*sSAplt_tableA->s.s_dbind->v.v_self), arsearch))) { *v=(*op)->c.c_cdr->FIX.FIXVAL; return 0; } tp.n=stn(s); if ((p=bsearch(&tp,p,pe-p,sizeof(*p),pltcomp))) { *v=p->ad; return 0; } return -1; } gcl-2.6.14/o/eval.c0000755000175000017500000006624414360276512012343 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* eval.c */ #include "include.h" #include "sfun_argd.h" static void call_applyhook(object); struct nil3 { object nil3_self[3]; } three_nils; #ifdef DEBUG_AVMA #undef DEBUG_AVMA unsigned long avma,bot; #define DEBUG_AVMA unsigned long saved_avma = avma; warn_avma() { print(list(2,make_simple_string("avma changed"),ihs_top_function_name(ihs_top)), sLAstandard_outputA->s.s_dbind); } #define CHECK_AVMA if(avma!= saved_avma) warn_avma(); #define DEBUGGING_AVMA #else #define DEBUG_AVMA #define CHECK_AVMA #endif /* object c_apply_n(long int (*fn)(), int n, object *x); */ object sSAbreak_pointsA; object sSAbreak_stepA; #include "apply_n.h" /* for t_sfun,t_gfun with args on vs stack */ static void quick_call_sfun(object fun) { DEBUG_AVMA int i=fun->sfn.sfn_argd,n=SFUN_NARGS(i); enum ftype restype; object *x,*base; if (n!=vs_top-vs_base) check_arg_failed(n); restype = SFUN_RETURN_TYPE(i); SFUN_START_ARG_TYPES(i); #define COERCE_ARG(a,type) (type==f_object ? a : (object)(fix(a))) x=vs_base; if (i) { int j; x=alloca(n*sizeof(object)); for (j=0;jvfn.vfn_minargs) {FEtoo_few_arguments(base,vs_top); return;} if (n > fun->vfn.vfn_maxargs) {FEtoo_many_arguments(base,vs_top); return;} VFUN_NARGS = n; base[0]=c_apply_n_fun(fun,n,base); vs_top=(vs_base=base)+1; CHECK_AVMA; return; } void funcall(object fun) { object temporary; object x; object * VOL top; object *lex; bds_ptr old_bds_top; VOL bool b; bool c; DEBUG_AVMA TOP: if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: MMcall(fun); CHECK_AVMA; return; case t_gfun: case t_sfun: { extern int Rset; int rset=Rset; if (!rset) {ihs_check;ihs_push(fun);} quick_call_sfun(fun); if (!rset) ihs_pop(); } return; case t_vfun: { extern int Rset; int rset=Rset; if (!rset) {ihs_check;ihs_push(fun);} call_vfun(fun); if (!rset) ihs_pop(); } return; case t_afun: case t_closure: { object res,*b = vs_base; int n = vs_top - b; res = (object)IapplyVector(fun,n,b); n = fcall.nvalues; vs_base = b; vs_top = b+ n; while (--n> 0 ) b[n] = fcall.values[n]; b[0] = res; return;} case t_cclosure: MMccall(fun); CHECK_AVMA; return; case t_symbol: {object x = fun->s.s_gfdef; if (x) { fun = x; goto TOP;} else FEundefined_function(fun); } case t_cons: break; default: FEinvalid_function(fun); } /* This part is the same as that of funcall_no_event. */ /* we may have pushed the calling form if this is called invoked from eval. A lambda call requires vs_push's, so we can tell if we pushed by vs_base being the same. */ { VOL int not_pushed = 0; if (vs_base != ihs_top->ihs_base){ ihs_check; ihs_push(fun); } else not_pushed = 1; ihs_top->ihs_base = lex_env; x = MMcar(fun); top = vs_top; lex = lex_env; old_bds_top = bds_top; /* maybe digest this lambda expression (lambda-block-expand name ..) has already been expanded. The value of lambda-block-expand may be a compiled function in which case we say expand with it) */ if (x == sSlambda_block_expanded) { b = TRUE; c = FALSE; fun = fun->c.c_cdr; }else if (x == sSlambda_block) { b = TRUE; c = FALSE; if(sSlambda_block_expanded->s.s_dbind!=OBJNULL) fun = ifuncall1(sSlambda_block_expanded->s.s_dbind,fun); fun = fun->c.c_cdr; } else if (x == sSlambda_closure) { b = FALSE; c = TRUE; fun = fun->c.c_cdr; } else if (x == sLlambda) { b = c = FALSE; fun = fun->c.c_cdr; } else if (x == sSlambda_block_closure) { b = c = TRUE; fun = fun->c.c_cdr; } else b = c = TRUE; if (c) { vs_push(kar(fun)); fun = fun->c.c_cdr; vs_push(kar(fun)); fun = fun->c.c_cdr; vs_push(kar(fun)); fun = fun->c.c_cdr; } else { *(struct nil3 *)vs_top = three_nils; vs_top += 3; } if (b) { x = kar(fun); /* block name */ fun = fun->c.c_cdr; } lex_env = top; vs_push(fun); lambda_bind(top); ihs_top->ihs_base = lex_env; if (b) { fun = temporary = alloc_frame_id(); /* lex_block_bind(x, temporary); */ temporary = MMcons(temporary, Cnil); temporary = MMcons(sLblock, temporary); temporary = MMcons(x, temporary); lex_env[2] = MMcons(temporary, lex_env[2]); frs_push(FRS_CATCH, fun); if (nlj_active) { nlj_active = FALSE; goto END; } } x = top[3]; /* body */ if(endp(x)) { vs_base = vs_top; vs_push(Cnil); } else { top = vs_top; for (;;) { eval(MMcar(x)); x = MMcdr(x); if (endp(x)) break; vs_top = top; } } END: if (b) frs_pop(); bds_unwind(old_bds_top); lex_env = lex; if (not_pushed == 0) {ihs_pop();} CHECK_AVMA; }} void funcall_no_event(object fun) { DEBUG_AVMA if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); break; case t_cclosure: (*fun->cc.cc_self)(fun); break; case t_sfun: /* call_sfun_no_check(fun); return; */ case t_gfun: quick_call_sfun(fun); return; case t_vfun: call_vfun(fun); return; default: funcall(fun); } } void lispcall(object *funp, int narg) { DEBUG_AVMA object fun = *funp; vs_base = funp + 1; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: MMcall(fun); break; case t_cclosure: MMccall(fun); break; default: funcall(fun); } CHECK_AVMA; } void lispcall_no_event(object *funp, int narg) { DEBUG_AVMA object fun = *funp; vs_base = funp + 1; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); break; case t_cclosure: (*fun->cc.cc_self)(fun); break; default: funcall(fun); } CHECK_AVMA; } void symlispcall(object sym, object *base, int narg) { DEBUG_AVMA object fun = symbol_function(sym); vs_base = base; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: MMcall(fun); break; case t_cclosure: MMccall(fun); break; default: funcall(fun); } CHECK_AVMA; } void symlispcall_no_event(object sym, object *base, int narg) { DEBUG_AVMA object fun = symbol_function(sym); vs_base = base; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); break; case t_cclosure: (*fun->cc.cc_self)(fun); break; default: funcall(fun); } CHECK_AVMA; } object simple_lispcall(object *funp, int narg) { DEBUG_AVMA object fun = *funp; object *sup = vs_top; vs_base = funp + 1; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: MMcall(fun); break; case t_cclosure: MMccall(fun); break; default: funcall(fun); } vs_top = sup; CHECK_AVMA; return(vs_base[0]); } /* static object */ /* simple_lispcall_no_event(object *funp, int narg) */ /* { */ /* DEBUG_AVMA */ /* object fun = *funp; */ /* object *sup = vs_top; */ /* vs_base = funp + 1; */ /* vs_top = vs_base + narg; */ /* if (fun == OBJNULL) */ /* FEerror("Undefined function.", 0); */ /* switch (type_of(fun)) { */ /* case t_cfun: */ /* (*fun->cf.cf_self)(); */ /* break; */ /* case t_cclosure: */ /* { */ /* object *top, *base, l; */ /* if (fun->cc.cc_turbo != NULL) { */ /* (*fun->cc.cc_self)(fun->cc.cc_turbo); */ /* break; */ /* } */ /* top = vs_top; */ /* base = vs_base; */ /* for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) */ /* vs_push(l); */ /* vs_base = vs_top; */ /* while (base < top) */ /* vs_push(*base++); */ /* (*fun->cc.cc_self)(top); */ /* break; */ /* } */ /* default: */ /* funcall(fun); */ /* } */ /* vs_top = sup; */ /* CHECK_AVMA; */ /* return(vs_base[0]); */ /* } */ object simple_symlispcall(object sym, object *base, int narg) { DEBUG_AVMA object fun = symbol_function(sym); object *sup = vs_top; vs_base = base; vs_top = vs_base + narg; if (fun == OBJNULL) FEerror("Undefined function.", 0); switch (type_of(fun)) { case t_cfun: MMcall(fun); break; case t_cclosure: MMccall(fun); break; default: funcall(fun); } vs_top = sup; CHECK_AVMA; return(vs_base[0]); } /* static object */ /* simple_symlispcall_no_event(object sym, object *base, int narg) */ /* { */ /* DEBUG_AVMA */ /* object fun = symbol_function(sym); */ /* object *sup = vs_top; */ /* vs_base = base; */ /* vs_top = vs_base + narg; */ /* if (fun == OBJNULL) */ /* FEerror("Undefined function.", 0); */ /* switch (type_of(fun)) { */ /* case t_cfun: */ /* (*fun->cf.cf_self)(); */ /* break; */ /* case t_cclosure: */ /* { */ /* object *top, *base, l; */ /* if (fun->cc.cc_turbo != NULL) { */ /* (*fun->cc.cc_self)(fun->cc.cc_turbo); */ /* break; */ /* } */ /* top = vs_top; */ /* base = vs_base; */ /* for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) */ /* vs_push(l); */ /* vs_base = vs_top; */ /* while (base < top) */ /* vs_push(*base++); */ /* (*fun->cc.cc_self)(top); */ /* break; */ /* } */ /* default: */ /* funcall(fun); */ /* } */ /* vs_top = sup; */ /* CHECK_AVMA; */ /* return(vs_base[0]); */ /* } */ void super_funcall(object fun) { if (type_of(fun) == t_symbol) { if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag) FEinvalid_function(fun); if (fun->s.s_gfdef == OBJNULL) FEundefined_function(fun); fun = fun->s.s_gfdef; } funcall(fun); } void super_funcall_no_event(object fun) { #ifdef DEBUGGING_AVMA funcall_no_event(fun); return; #endif switch(type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); return; case t_cclosure: (*fun->cc.cc_self)(fun); return; case t_sfun: /* call_sfun_no_check(fun); return; */ case t_gfun: quick_call_sfun(fun); return; case t_vfun: call_vfun(fun); return; case t_symbol: if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag) FEinvalid_function(fun); if (fun->s.s_gfdef == OBJNULL) FEundefined_function(fun); super_funcall_no_event(fun->s.s_gfdef); return; default: funcall(fun); } } #ifdef USE_BROKEN_IEVAL object Ieval(form) object form; { DEBUG_AVMA object fun, x; object *top; object *base; object orig_form; cs_check(form); EVAL: vs_check; if (siVevalhook->s.s_dbind != Cnil && eval1 == 0) { bds_ptr old_bds_top = bds_top; object hookfun = symbol_value(siVevalhook); /* check if Vevalhook is unbound */ bds_bind(siVevalhook, Cnil); form = Ifuncall_n(hookfun,2,form,list(3,lex_env[0],lex_env[1],lex_env[2])); bds_unwind(old_bds_top); return form; } else eval1 = 0; if (type_of(form) == t_cons) goto APPLICATION; if (type_of(form) != t_symbol) RETURN1(form); switch (form->s.s_stype) { case stp_constant: RETURN1((form->s.s_dbind)); case stp_special: if(form->s.s_dbind == OBJNULL) FEunbound_variable(form); RETURN1((form->s.s_dbind)); default: /* x = lex_var_sch(form); */ for (x = lex_env[0]; type_of(x) == t_cons; x = x->c.c_cdr) if (x->c.c_car->c.c_car == form) { x = x->c.c_car->c.c_cdr; if (endp(x)) break; RETURN1((x->c.c_car)); } if(form->s.s_dbind == OBJNULL) FEunbound_variable(form); RETURN1((form->s.s_dbind)); } APPLICATION: /* Hook for possibly stopping at forms in the break point list. Also for stepping. We only want to check one form each time round, so we do *breakpoints* */ if (sSAbreak_pointsA->s.s_dbind != Cnil) { if (sSAbreak_stepA->s.s_dbind == Cnil || ifuncall2(sSAbreak_stepA->s.s_dbind,form, list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil) {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self; int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp; while (--i >= 0) { if((*bpts)->c.c_car == form) {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form, list(3,lex_env[0],lex_env[1],lex_env[2])); break;} bpts++;} }} fun = MMcar(form); if (type_of(fun) != t_symbol) goto LAMBDA; if (fun->s.s_sfdef != NOT_SPECIAL) { ihs_check; ihs_push(form); ihs_top->ihs_base = lex_env; (*fun->s.s_sfdef)(MMcdr(form)); CHECK_AVMA; ihs_pop(); return Ivs_values(); } /* x = lex_fd_sch(fun); */ for (x = lex_env[1]; type_of(x) == t_cons; x = x->c.c_cdr) if (x->c.c_car->c.c_car == fun) { x = x->c.c_car; if (MMcadr(x) == sSmacro) { x = MMcaddr(x); goto EVAL_MACRO; } x = MMcaddr(x); goto EVAL_ARGS; } if ((x = fun->s.s_gfdef) == OBJNULL) FEundefined_function(fun); if (fun->s.s_mflag) { EVAL_MACRO: form = Imacro_expand1(x, form); goto EVAL; } EVAL_ARGS: { int n ; ihs_check; ihs_push(form); ihs_top->ihs_base = lex_env; form = form->c.c_cdr; base = vs_top; top = base ; while(!endp(form)) { object ans = Ieval(MMcar(form)); top[0] = ans; vs_top = ++top; form = MMcdr(form);} n =top - base; /* number of args */ if (siVapplyhook->s.s_dbind != Cnil) { base[0]= (object)n; base[0] = c_apply_n(list,n+1,base); x = Ifuncall_n(siVapplyhook->s.s_dbind,3, x, /* the function */ base[0], /* the arg list */ list(3,lex_env[0],lex_env[1],lex_env[2])); vs_top = base; return x; } ihs_top->ihs_function = x; ihs_top->ihs_base = vs_base; x=IapplyVector(x,n,base+1); CHECK_AVMA; ihs_pop(); vs_top = base; return x; } LAMBDA: if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { x = listA(4,sSlambda_closure,lex_env[0],lex_env[1],lex_env[2],Mcdr(fun)); goto EVAL_ARGS; } FEinvalid_function(fun); } #else object Ieval(object form) { eval(form); return Ivs_values(); } #endif void eval(object form) { object temporary; DEBUG_AVMA object fun, x; object *top; object *base; cs_check(form); EVAL: vs_check; if (siVevalhook->s.s_dbind != Cnil && eval1 == 0) { bds_ptr old_bds_top = bds_top; object hookfun = symbol_value(siVevalhook); /* check if siVevalhook is unbound */ bds_bind(siVevalhook, Cnil); vs_base = vs_top; vs_push(form); vs_push(list(3,lex_env[0],lex_env[1],lex_env[2])); super_funcall(hookfun); bds_unwind(old_bds_top); return; } else eval1 = 0; if (type_of(form) == t_cons) goto APPLICATION; if (type_of(form) != t_symbol) { vs_base = vs_top; vs_push(form); return; } switch (form->s.s_stype) { case stp_constant: vs_base = vs_top; vs_push(form->s.s_dbind); return; case stp_special: if(form->s.s_dbind == OBJNULL) FEunbound_variable(form); vs_base = vs_top; vs_push(form->s.s_dbind); return; default: /* x = lex_var_sch(form); */ for (x = lex_env[0]; type_of(x) == t_cons; x = x->c.c_cdr) if (x->c.c_car->c.c_car == form) { x = x->c.c_car->c.c_cdr; if (endp(x)) break; vs_base = vs_top; vs_push(x->c.c_car); return; } if(form->s.s_dbind == OBJNULL) FEunbound_variable(form); vs_base = vs_top; vs_push(form->s.s_dbind); return; } APPLICATION: /* Hook for possibly stopping at forms in the break point list. Also for stepping. We only want to check one form each time round, so we do *breakpoints* */ if (sSAbreak_pointsA->s.s_dbind != Cnil) { if (sSAbreak_stepA->s.s_dbind == Cnil || ifuncall2(sSAbreak_stepA->s.s_dbind,form, list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil) {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self; int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp; while (--i >= 0) { if((*bpts)->c.c_car == form) {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form, list(3,lex_env[0],lex_env[1],lex_env[2])); break;} bpts++;} }} fun = MMcar(form); if (type_of(fun) != t_symbol) goto LAMBDA; if (fun->s.s_sfdef != NOT_SPECIAL) { ihs_check; ihs_push(form); ihs_top->ihs_base = lex_env; (*fun->s.s_sfdef)(MMcdr(form)); CHECK_AVMA; ihs_pop(); return; } /* x = lex_fd_sch(fun); */ for (x = lex_env[1]; type_of(x) == t_cons; x = x->c.c_cdr) if (x->c.c_car->c.c_car == fun) { x = x->c.c_car; if (MMcadr(x) == sSmacro) { x = MMcaddr(x); goto EVAL_MACRO; } x = MMcaddr(x); goto EVAL_ARGS; } if ((x = fun->s.s_gfdef) == OBJNULL) FEundefined_function(fun); if (fun->s.s_mflag) { EVAL_MACRO: top = vs_top; form=Imacro_expand1(x, form); vs_top = top; vs_push(form); goto EVAL; } EVAL_ARGS: vs_push(x); ihs_check; ihs_push(form); ihs_top->ihs_base = lex_env; form = form->c.c_cdr; base = vs_top; top = vs_top; while(!endp(form)) { eval(MMcar(form)); top[0] = vs_base[0]; vs_top = ++top; form = MMcdr(form); } vs_base = base; if (siVapplyhook->s.s_dbind != Cnil) { call_applyhook(fun); return; } ihs_top->ihs_function = x; ihs_top->ihs_base = vs_base; if (type_of(x) == t_cfun) (*(x)->cf.cf_self)(); else funcall_no_event(x); CHECK_AVMA; ihs_pop(); return; LAMBDA: if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { temporary = make_cons(lex_env[2], fun->c.c_cdr); temporary = make_cons(lex_env[1], temporary); temporary = make_cons(lex_env[0], temporary); x = make_cons(sSlambda_closure, temporary); vs_push(x); goto EVAL_ARGS; } FEinvalid_function(fun); } static void call_applyhook(object fun) { object ah; ah = symbol_value(siVapplyhook); Llist(); vs_push(vs_base[0]); vs_base[0] = fun; vs_push(list(3,lex_env[0],lex_env[1],lex_env[2])); super_funcall(ah); } DEFUNOM_NEW("FUNCALL",object,fLfuncall,LISP ,1,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lfuncall,(object fun,...),"") { va_list ap; object *new; int n = VFUN_NARGS; va_start(ap,fun); {COERCE_VA_LIST(new,ap,n); return IapplyVector(fun,n-1,new); va_end(ap); } } DEFUNOM_NEW("APPLY",object,fLapply,LISP ,2,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lapply,(object fun,...),"") { int m,n=VFUN_NARGS; object l; object buf[MAX_ARGS]; object *base=buf; va_list ap; va_start(ap,fun); m = n-1; while (--m >0) {*base++ = va_arg(ap,object); } m = n-2; l = va_arg(ap,object); va_end(ap); while (!endp(l)) { if (m >= MAX_ARGS) FEerror(" Lisps arglist maximum surpassed",0); *base++ = Mcar(l); l = Mcdr(l); m++;} return IapplyVector(fun,m,buf); } DEFUNOM_NEW("EVAL",object,fLeval,LISP ,1,1,NONE,OO,OO,OO,OO,void,Leval,(object x0),"") { object *lex = lex_env; /* 1 args */ lex_new(); /* eval(vs_base[0]); */ eval(x0); lex_env = lex; return Ivs_values(); } LFD(siLevalhook)(void) { object env; bds_ptr old_bds_top = bds_top; object *lex = lex_env; int n = vs_top - vs_base; lex_env = vs_top; if (n < 3) too_few_arguments(); else if (n == 3) { *(struct nil3 *)vs_top = three_nils; vs_top += 3; } else if (n == 4) { env = vs_base[3]; vs_push(car(env)); env = cdr(env); vs_push(car(env)); env = cdr(env); vs_push(car(env)); } else too_many_arguments(); bds_bind(siVevalhook, vs_base[1]); bds_bind(siVapplyhook, vs_base[2]); eval1 = 1; eval(vs_base[0]); lex_env = lex; bds_unwind(old_bds_top); } LFD(siLapplyhook)(void) { object env; bds_ptr old_bds_top = bds_top; object *lex = lex_env; int n = vs_top - vs_base; object l, *z; lex_env = vs_top; if (n < 4) too_few_arguments(); else if (n == 4) { *(struct nil3 *)vs_top = three_nils; vs_top += 3; } else if (n == 5) { env = vs_base[4]; vs_push(car(env)); env = cdr(env); vs_push(car(env)); env = cdr(env); vs_push(car(env)); } else too_many_arguments(); bds_bind(siVevalhook, vs_base[2]); bds_bind(siVapplyhook, vs_base[3]); z = vs_top; for (l = vs_base[1]; !endp(l); l = l->c.c_cdr) vs_push(l->c.c_car); l = vs_base[0]; vs_base = z; super_funcall(l); lex_env = lex; bds_unwind(old_bds_top); } DEFUNO_NEW("CONSTANTP",object,fLconstantp,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lconstantp,(object x0),"") { enum type x; /* 1 args */ x = type_of(x0); if(x == t_cons) if(x0->c.c_car == sLquote) x0 = Ct; else x0 = Cnil; else if(x == t_symbol) if((enum stype)x0->s.s_stype == stp_constant) x0 = Ct; else x0 = Cnil; else x0 = Ct; RETURN1(x0); } object ieval(object x) { object *old_vs_base; object *old_vs_top; old_vs_base = vs_base; old_vs_top = vs_top; eval(x); x = vs_base[0]; vs_base = old_vs_base; vs_top = old_vs_top; return(x); } object ifuncall1(object fun, object arg1) { object *old_vs_base; object *old_vs_top; object x; old_vs_base = vs_base; old_vs_top = vs_top; vs_base = vs_top; vs_push(arg1); super_funcall(fun); x = vs_base[0]; vs_top = old_vs_top; vs_base = old_vs_base; return(x); } object ifuncall2(object fun, object arg1, object arg2) { object *old_vs_base; object *old_vs_top; object x; old_vs_base = vs_base; old_vs_top = vs_top; vs_base = vs_top; vs_push(arg1); vs_push(arg2); super_funcall(fun); x = vs_base[0]; vs_top = old_vs_top; vs_base = old_vs_base; return(x); } object ifuncall3(object fun, object arg1, object arg2, object arg3) { object *old_vs_base; object *old_vs_top; object x; old_vs_base = vs_base; old_vs_top = vs_top; vs_base = vs_top; vs_push(arg1); vs_push(arg2); vs_push(arg3); super_funcall(fun); x = vs_base[0]; vs_top = old_vs_top; vs_base = old_vs_base; return(x); } void funcall_with_catcher(object fname, object fun) { int n = vs_top - vs_base; if (n > 64) n = 64; frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n))); if (nlj_active) nlj_active = FALSE; else funcall(fun); frs_pop(); } static object fcalln_cclosure(object first,va_list ap) { int i=fcall.argd; {object *base=vs_top,*old_base=base; DEBUG_AVMA vs_base=base; if (i) { *(base++)=first; i--; } switch(i){ case 10: *(base++)=va_arg(ap,object); case 9: *(base++)=va_arg(ap,object); case 8: *(base++)=va_arg(ap,object); case 7: *(base++)=va_arg(ap,object); case 6: *(base++)=va_arg(ap,object); case 5: *(base++)=va_arg(ap,object); case 4: *(base++)=va_arg(ap,object); case 3: *(base++)=va_arg(ap,object); case 2: *(base++)=va_arg(ap,object); case 1: *(base++)=va_arg(ap,object); case 0: break; default: FEerror("bad args",0); } vs_top=base; base=old_base; do{object fun=fcall.fun; object *top, *base, l; massert(fun->cc.cc_turbo); if (fun->cc.cc_turbo != NULL) { (*fun->cc.cc_self)(fun); break; } top = vs_top; base = vs_base; for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) vs_push(l); vs_base = vs_top; while (base < top) vs_push(*base++); (*fcall.fun->cc.cc_self)(top); break; }while (0); vs_top=base; CHECK_AVMA; return(vs_base[0]); }} static object fcalln_general(object first,va_list ap) { int i=fcall.argd; { int n= SFUN_NARGS(i); /* object *old_vs_base=vs_base; */ object *old_vs_top=vs_top; object x; enum ftype typ,restype=SFUN_RETURN_TYPE(i); vs_top = vs_base = old_vs_top; SFUN_START_ARG_TYPES(i); if (i==0) { int jj=0; while (n-- > 0) { typ= SFUN_NEXT_TYPE(i); x = (typ==f_object ? (jj ? va_arg(ap,object) : first): typ==f_fixnum ? make_fixnum((jj ? va_arg(ap,fixnum) : (fixnum)first)): (object) (FEerror("bad type",0),Cnil)); *(vs_top++) = x; jj++; } } else { object *base=vs_top; *(base++)=first; n--; while (n-- > 0) *(base++) = va_arg(ap,object); vs_top=base; } funcall(fcall.fun); x= vs_base[0]; vs_top=old_vs_top; /* vs_base=old_vs_base; */ return (restype== f_object ? x : restype== f_fixnum ? (object) (fix(x)): (object) (FEerror("bad type",0),Cnil)); } } static object fcalln_vfun(object first,va_list vl) {object *new,res; DEBUG_AVMA COERCE_VA_LIST_NEW(new,first,vl,fcall.argd); res = c_apply_n_fun(fcall.fun,fcall.argd,new); CHECK_AVMA; return res; } object fcalln1(object first,...) { va_list ap; object fun=fcall.fun; DEBUG_AVMA va_start(ap,first); if(type_of(fun)==t_cfun) {object *base=vs_top,*old_base=base; int i=fcall.argd; vs_base=base; if (i) { *(base++)=first; i--; } switch(i){ case 10: *(base++)=va_arg(ap,object); case 9: *(base++)=va_arg(ap,object); case 8: *(base++)=va_arg(ap,object); case 7: *(base++)=va_arg(ap,object); case 6: *(base++)=va_arg(ap,object); case 5: *(base++)=va_arg(ap,object); case 4: *(base++)=va_arg(ap,object); case 3: *(base++)=va_arg(ap,object); case 2: *(base++)=va_arg(ap,object); case 1: *(base++)=va_arg(ap,object); case 0: break; default: FEerror("bad args",0); } vs_top=base; base=old_base; (*fcall.fun->cf.cf_self)(); vs_top=base; CHECK_AVMA; return(vs_base[0]); } if(type_of(fun)==t_cclosure) return(fcalln_cclosure(first,ap)); if(type_of(fun)==t_vfun) return(fcalln_vfun(first,ap)); return(fcalln_general(first,ap)); va_end(ap); } /* call a cfun eg funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) */ /* typedef void (*funcvoid)(); */ object funcall_cfun(funcvoid fn,int n,...) {object *old_top = vs_top; object *old_base= vs_base; object result; va_list ap; DEBUG_AVMA vs_base=vs_top; va_start(ap,n); while(n-->0) vs_push(va_arg(ap,object)); va_end(ap); (*fn)(); if(vs_top>vs_base) result=vs_base[0]; else result=Cnil; vs_top=old_top; vs_base=old_base; CHECK_AVMA; return result;} DEF_ORDINARY("LAMBDA-BLOCK-EXPANDED",sSlambda_block_expanded,SI,""); DEFVAR("*BREAK-POINTS*",sSAbreak_pointsA,SI,Cnil,""); DEFVAR("*BREAK-STEP*",sSAbreak_stepA,SI,Cnil,""); void gcl_init_eval(void) { make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64)); siVevalhook = make_si_special("*EVALHOOK*", Cnil); siVapplyhook = make_si_special("*APPLYHOOK*", Cnil); three_nils.nil3_self[0] = Cnil; three_nils.nil3_self[1] = Cnil; three_nils.nil3_self[2] = Cnil; make_si_function("EVALHOOK", siLevalhook); make_si_function("APPLYHOOK", siLapplyhook); } gcl-2.6.14/o/u370_emul.s0000755000175000017500000000270514360276512013144 0ustar cammcamm file_ tmp.c entry $oVhc2_1r $oVhc2_1r equ 0 entry $oVO $oVO equ 0 L$$C0 csect ds 0d L00$TEXT equ * entry _extended_mul * -------------| extended_mul |-----------------------# ds 0f dc al2(0) arglength in words dc xl2'FFFF' argument regs unknown dc al4(LE$1-_extended_mul) code size dc xl2'0000' no flags currently defined dc al1(5) parmlength in words dc al1(1) format _extended_mul ds 0h LX$011 equ * using LX$011,12 stm LR$1,15,x'10'+LV$1(13) lr 12,13 la 11,x'60' slr 13,11 st 12,4(,13) lr 12,15 lr 15,1 mr 14,0 alr 15,2 # branch on carry bc 3,Loverflow # store the results Lresult sldl 14,1(0) srl 15,1(0) l 1,x'B8'(,13) # lp st 15,0(,1) st 14,0(,3) lm LR$1,14,x'70'+LV$1(13) br 14 Loverflow ah 14,LC$014 b Lresult LE$1 equ * LR$1 equ 2 LV$1 equ 0 LC$014 equ * dc xl2'0001' end entry _extended_div * -------------| extended_div |-----------------------# ds 0f dc al2(0) arglength in words dc xl2'FFFF' argument regs unknown dc al4(LE$2-_extended_div) code size dc xl2'0000' no flags currently defined dc al1(5) parmlength in words dc al1(1) format _extended_div ds 0h LX$021 equ * using LX$021,12 stm LR$2,15,x'10'+LV$2(13) lr 12,13 la 11,x'60' slr 13,11 st 12,4(,13) lr 12,15 * put h,l in 14,15 lr 14,1 lr 15,2 sll 15,1 srdl 14,1 dr 14,0 * store the quotient st 15,0(,3) l 1,x'B8'(,13) # rp * store the remainder st 14,0(,1) lm LR$2,14,x'70'+LV$2(13) br 14 LE$2 equ * LR$2 equ 2 LV$2 equ 0 end gcl-2.6.14/o/cmac.c0000755000175000017500000001070214360276512012303 0ustar cammcamm#define NEED_MP_H #ifndef FIRSTWORD #include "include.h" #endif #include "num_include.h" /* #include "arith.h" */ /* I believe the instructions used here are ok for 68010.. */ #ifdef MC68K #define MC68020 #endif /* static for gnuwin95 the save routine is not saving statics... */ object *gclModulus; #define FIXNUMP(x) (type_of(x)==t_fixnum) /* Note: the gclModulus is guaranteed > 0 */ #define FIX_MOD(X,MOD) { \ register fixnum MOD_2; \ if (X > (MOD_2=(MOD>>1))) \ X=X-MOD; \ else \ if (X < -MOD_2) \ X=X+MOD; \ else \ if (X == -MOD_2 && (MOD&0x1)==0) \ X=X+MOD; \ } object ctimes(object a, object b),cplus(object a, object b),cdifference(object a, object b),cmod(object x); object make_integer(__mpz_struct *u); #define our_minus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fixnum_sub(fix(a),fix(b)): \ number_minus(a,b)) #define our_plus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fixnum_add(fix(a),fix(b)): \ number_plus(a,b)) #define our_times(a,b) number_times(a,b) /* fix (and check) this on 64 bit machines, where long is the long long */ #ifdef HAVE_LONG_LONG static int dblrem(int a, int b, int mod) { return (int)(((long long int)a*(long long int)b)%(long long int) mod); } #else static int dblrem(a,b,mod) int a,b,mod; {int h,sign; if (a<0) {a= -a; sign= (b<0)? (b= -b,1) :-1;} else { sign= (b<0) ? (b= -b,-1) : 1;} { mp_limb_t ar[2],q[2],aa; aa = a; ar[1]=mpn_mul_1(ar,&aa,1,b); h = mpn_divrem_1(q,0,ar,2,mod); return ((sign<0) ? -h :h); } } #endif /* #if sizeof(fixnum) != sizeof(mp_limb_t) */ /* #error fixnum mp_limb_t size mismatch */ /* #endif */ static fixnum fdblrem(fixnum a,fixnum b,fixnum mod) { fixnum h,sign; mp_limb_t ar[2],q[2],aa; if (a<0) { a= -a; sign= (b<0) ? (b= -b,1) : -1; } else sign= (b<0) ? (b= -b,-1) : 1; aa = a; ar[1]=mpn_mul_1(ar,&aa,1,b); h = mpn_divrem_1(q,0,ar,2,mod); return ((sign<0) ? -h :h); } object cmod(object x) { register object mod = *gclModulus; if (mod==Cnil) return(x); else if ((type_of(mod)==t_fixnum && type_of(x)==t_fixnum)) { register fixnum xx,mm=fix(mod); if (mm==2) return small_fixnum((fix(x)&1)); xx=(fix(x)%mm); FIX_MOD(xx,mm); return make_fixnum(xx); } else { object rp,mod2; int compare; integer_quotient_remainder_1(x,mod,NULL,&rp,0);/*FIXME*/ mod2=integer_fix_shift(mod,-1); compare = number_compare(rp,small_fixnum(0)); if (compare >= 0) { compare=number_compare(rp,mod2); if (compare > 0) rp=number_minus(rp,mod); } else if (number_compare(number_negate(mod2), rp) > 0) rp = number_plus(rp,mod); return rp; } } object ctimes(object a, object b) { object mod = *gclModulus; if (FIXNUMP(mod)) { register fixnum res, m=fix(mod); if (sizeof(fixnum)==sizeof(int) || (m>>(sizeof(int)*8)==(m>>(sizeof(fixnum)*8-1)))) res=dblrem(fix(a),fix(b),m); else res=fdblrem(fix(a),fix(b),m); FIX_MOD(res,m); return make_fixnum(res); } else if (mod==Cnil) return(our_times(a,b)); return cmod(number_times(a,b)); } #define SMALL_MODULUS_P(mod) (FIXNUMP(mod) && (fix(mod) < (MOST_POSITIVE_FIX)/2)) object cdifference(object a, object b) { object mod = *gclModulus; if (SMALL_MODULUS_P(mod)) { register fixnum res,m; res=((fix(a)-fix(b))%(m=fix(mod))); FIX_MOD(res,m); return make_fixnum(res); } else if (mod==Cnil) return (our_minus(a,b)); else return(cmod(number_minus(a,b))); } object cplus(object a, object b) { object mod = *gclModulus; if (SMALL_MODULUS_P(mod)) { register fixnum res,m; res=((fix(a)+fix(b))%(m=fix(mod))); FIX_MOD(res,m); return make_fixnum(res); } else if (mod==Cnil) return (our_plus(a,b)); return(cmod(number_plus(a,b))); } DEFUN_NEW("CMOD",object,fScmod,SI,1,1,NONE,OO,OO,OO,OO,(object num),"") { /* 1 args */ num=cmod(num); RETURN1(num); } DEFUN_NEW("CPLUS",object,fScplus,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { /* 2 args */ x0 = cplus(x0,x1); RETURN1( x0 ); } DEFUN_NEW("CTIMES",object,fSctimes,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { /* 2 args */ x0=ctimes(x0,x1); RETURN1(x0); } DEFUN_NEW("CDIFFERENCE",object,fScdifference,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { /* 2 args */ x0=cdifference(x0,x1); RETURN1(x0); } void gcl_init_cmac(void) { gclModulus = (&((make_si_special("MODULUS",Cnil))->s.s_dbind)); } gcl-2.6.14/o/sequence.d0000755000175000017500000002530214360276512013213 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* sequence.d sequence routines */ #include "include.h" /* I know the following name is not good. */ object alloc_simple_vector(l, aet) int l; enum aelttype aet; { object x; x = alloc_object(t_vector); x->v.v_hasfillp = FALSE; x->v.v_adjustable = FALSE; x->v.v_displaced = Cnil; x->v.v_dim = x->v.v_fillp = l; x->v.v_self = NULL; x->v.v_elttype = (short)aet; return(x); } object alloc_simple_bitvector(l) int l; { object x; x = alloc_object(t_bitvector); x->bv.bv_hasfillp = FALSE; x->bv.bv_adjustable = FALSE; x->bv.bv_displaced = Cnil; x->bv.bv_dim = x->bv.bv_fillp = l; x->bv.bv_offset = 0; x->bv.bv_self = NULL; x->bv.bv_elttype = aet_bit; return(x); } LFD(Lelt)() { check_arg(2); vs_base[0] = elt(vs_base[0], fixint(vs_base[1])); vs_popp; } object elt(seq, index) object seq; int index; { int i; object l; if (index < 0) { vs_push(make_fixnum(index)); FEwrong_type_argument(sLpositive_fixnum, vs_head); } switch (type_of(seq)) { case t_cons: for (i = index, l = seq; i > 0; --i) if (endp(l)) goto E; else l = l->c.c_cdr; if (endp(l)) goto E; return(l->c.c_car); case t_vector: case t_bitvector: if (index >= seq->v.v_fillp) goto E; return(aref(seq, index)); case t_string: if (index >= seq->st.st_fillp) goto E; return(code_char(seq->ust.ust_self[index])); default: if (seq == Cnil) goto E; FEwrong_type_argument(sLsequence, seq); } E: vs_push(make_fixnum(index)); /* FIXME message should indicate out of range */ TYPE_ERROR(make_fixnum(index),MMcons(sLinteger,MMcons(make_fixnum(0),MMcons(make_fixnum(length(seq)),Cnil)))); return(Cnil); } LFD(siLelt_set)() { check_arg(3); vs_base[0] = elt_set(vs_base[0], fixint(vs_base[1]), vs_base[2]); vs_popp; vs_popp; } object elt_set(seq, index, val) object seq; int index; object val; { int i; object l; if (index < 0) { vs_push(make_fixnum(index)); FEwrong_type_argument(sLpositive_fixnum, vs_head); } switch (type_of(seq)) { case t_cons: for (i = index, l = seq; i > 0; --i) if (endp(l)) goto E; else l = l->c.c_cdr; if (endp(l)) goto E; return(l->c.c_car = val); case t_vector: case t_bitvector: if (index >= seq->v.v_fillp) goto E; return(aset(seq, index, val)); case t_string: if (index >= seq->st.st_fillp) goto E; if (type_of(val) != t_character) FEwrong_type_argument(sLcharacter, val); seq->st.st_self[index] = val->ch.ch_code; return(val); default: if (seq == Cnil) goto E; FEwrong_type_argument(sLsequence, seq); } E: vs_push(make_fixnum(index)); /* FIXME error message should indicate value out of range */ FEwrong_type_argument(sLpositive_fixnum, vs_head); return(Cnil); } @(defun subseq (sequence start &optional end &aux x) int s, e; int i, j; @ s = fixnnint(start); if (end == Cnil) e = -1; else e = fixnnint(end); switch (type_of(sequence)) { case t_symbol: if (sequence == Cnil) { if (s > 0) goto ILLEGAL_START_END; if (e > 0) goto ILLEGAL_START_END; @(return Cnil) } FEwrong_type_argument(sLsequence, sequence); case t_cons: if (e >= 0) if ((e -= s) < 0) goto ILLEGAL_START_END; while (s-- > 0) { if (type_of(sequence) != t_cons) goto ILLEGAL_START_END; sequence = sequence->c.c_cdr; } if (e < 0) @(return `copy_list(sequence)`) x=n_cons_from_x(e,sequence); @(return x) case t_vector: if (s > sequence->v.v_fillp) goto ILLEGAL_START_END; if (e < 0) e = sequence->v.v_fillp; else if (e < s || e > sequence->v.v_fillp) goto ILLEGAL_START_END; x = alloc_simple_vector(e - s, sequence->v.v_elttype); array_allocself(x, FALSE,OBJNULL); switch (sequence->v.v_elttype) { case aet_object: case aet_fix: case aet_sf: for (i = s, j = 0; i < e; i++, j++) x->v.v_self[j] = sequence->v.v_self[i]; break; case aet_lf: for (i = s, j = 0; i < e; i++, j++) x->lfa.lfa_self[j] = sequence->lfa.lfa_self[i]; break; case aet_short: case aet_ushort: for (i = s, j = 0; i < e; i++, j++) USHORT_GCL(x, j) = USHORT_GCL(sequence, i); break; case aet_char: case aet_uchar: for (i = s, j = 0; i < e; i++, j++) x->st.st_self[j] = sequence->st.st_self[i]; break; } @(return x) case t_string: if (s > sequence->st.st_fillp) goto ILLEGAL_START_END; if (e < 0) e = sequence->st.st_fillp; else if (e < s || e > sequence->st.st_fillp) goto ILLEGAL_START_END; {BEGIN_NO_INTERRUPT; x = alloc_simple_string(e - s); x->st.st_self = alloc_relblock(e - s); END_NO_INTERRUPT;} for (i = s, j = 0; i < e; i++, j++) x->st.st_self[j] = sequence->st.st_self[i]; @(return x) case t_bitvector: if (s > sequence->bv.bv_fillp) goto ILLEGAL_START_END; if (e < 0) e = sequence->bv.bv_fillp; else if (e < s || e > sequence->bv.bv_fillp) goto ILLEGAL_START_END; {BEGIN_NO_INTERRUPT; x = alloc_simple_bitvector(e - s); x->bv.bv_self = alloc_relblock((e-s+7)/8); s += sequence->bv.bv_offset; e += sequence->bv.bv_offset; for (i = s, j = 0; i < e; i++, j++) if (sequence->bv.bv_self[i/8]&(0200>>i%8)) x->bv.bv_self[j/8] |= 0200>>j%8; else x->bv.bv_self[j/8] &= ~(0200>>j%8); END_NO_INTERRUPT;} @(return x) default: FEwrong_type_argument(sLsequence, vs_base[0]); } ILLEGAL_START_END: FEerror("~S and ~S are illegal as :START and :END~%\ for the sequence ~S.", 3, start, end, sequence); @) LFD(Lcopy_seq)() { check_arg(1); vs_push(small_fixnum(0)); Lsubseq(); } int length(x) object x; { int i; switch (type_of(x)) { case t_symbol: if (x == Cnil) return(0); FEwrong_type_argument(sLsequence, x); return(0); case t_cons: #define cendp(obj) ((type_of(obj)!=t_cons)) for (i = 0; !cendp(x); i++, x = x->c.c_cdr) ; if (x==Cnil) return(i); FEwrong_type_argument(sLlist,x); return(0); case t_vector: case t_string: case t_bitvector: return(x->v.v_fillp); default: FEwrong_type_argument(sLsequence, x); return(0); } } LFD(Llength)() { check_arg(1); vs_base[0] = make_fixnum(length(vs_base[0])); } LFD(Lreverse)() { check_arg(1); vs_base[0] = reverse(vs_base[0]); } object reverse(seq) object seq; { object x, y, *v; int i, j, k; switch (type_of(seq)) { case t_symbol: if (seq == Cnil) return(Cnil); FEwrong_type_argument(sLsequence, seq); case t_cons: v = vs_top; vs_push(Cnil); for (x = seq; !endp(x); x = x->c.c_cdr) *v = make_cons(x->c.c_car, *v); return(vs_pop); case t_vector: x = seq; k = x->v.v_fillp; y = alloc_simple_vector(k, x->v.v_elttype); vs_push(y); array_allocself(y, FALSE,OBJNULL); switch (x->v.v_elttype) { case aet_object: case aet_fix: case aet_sf: for (j = k - 1, i = 0; j >=0; --j, i++) y->v.v_self[j] = x->v.v_self[i]; break; case aet_lf: for (j = k - 1, i = 0; j >=0; --j, i++) y->lfa.lfa_self[j] = x->lfa.lfa_self[i]; break; case aet_short: case aet_ushort: for (j = k - 1, i = 0; j >=0; --j, i++) USHORT_GCL(y, j) = USHORT_GCL(x, i); break; case aet_char: case aet_uchar: goto TYPE_STRING; } return(vs_pop); case t_string: x = seq; y = alloc_simple_string(x->st.st_fillp); TYPE_STRING: {BEGIN_NO_INTERRUPT; vs_push(y); y->st.st_self = alloc_relblock(x->st.st_fillp); for (j = x->st.st_fillp - 1, i = 0; j >=0; --j, i++) y->st.st_self[j] = x->st.st_self[i]; END_NO_INTERRUPT;} return(vs_pop); case t_bitvector: x = seq; {BEGIN_NO_INTERRUPT; y = alloc_simple_bitvector(x->bv.bv_fillp); vs_push(y); y->bv.bv_self = alloc_relblock((x->bv.bv_fillp+7)/8); for (j = x->bv.bv_fillp - 1, i = x->bv.bv_offset; j >=0; --j, i++) if (x->bv.bv_self[i/8]&(0200>>i%8)) y->bv.bv_self[j/8] |= 0200>>j%8; else y->bv.bv_self[j/8] &= ~(0200>>j%8); END_NO_INTERRUPT;} return(vs_pop); default: FEwrong_type_argument(sLsequence, seq); return(Cnil); } } LFD(Lnreverse)() { check_arg(1); vs_base[0] = nreverse(vs_base[0]); } object nreverse(seq) object seq; { object x, y, z; int i, j, k; switch (type_of(seq)) { case t_symbol: if (seq == Cnil) return(Cnil); FEwrong_type_argument(sLsequence, seq); case t_cons: for (x = Cnil, y = seq; !endp(y->c.c_cdr);) { z = y; y = y->c.c_cdr; z->c.c_cdr = x; x = z; } y->c.c_cdr = x; return(y); case t_vector: x = seq; k = x->v.v_fillp; switch (x->v.v_elttype) { case aet_object: case aet_fix: case aet_sf: for (i = 0, j = k - 1; i < j; i++, --j) { y = x->v.v_self[i]; x->v.v_self[i] = x->v.v_self[j]; x->v.v_self[j] = y; } return(seq); case aet_lf: for (i = 0, j = k - 1; i < j; i++, --j) { longfloat y; y = x->lfa.lfa_self[i]; x->lfa.lfa_self[i] = x->lfa.lfa_self[j]; x->lfa.lfa_self[j] = y; } return(seq); case aet_short: case aet_ushort: for (i = 0, j = k - 1; i < j; i++, --j) { unsigned short y; y = USHORT_GCL(x, i); USHORT_GCL(x, i) = USHORT_GCL(x, j); USHORT_GCL(x, y) = y; } return(seq); case aet_char: case aet_uchar: goto TYPE_STRING; } case t_string: x = seq; TYPE_STRING: for (i = 0, j = x->st.st_fillp - 1; i < j; i++, --j) { k = x->st.st_self[i]; x->st.st_self[i] = x->st.st_self[j]; x->st.st_self[j] = k; } return(seq); case t_bitvector: x = seq; for (i = x->bv.bv_offset, j = x->bv.bv_fillp + x->bv.bv_offset - 1; i < j; i++, --j) { k = x->bv.bv_self[i/8]&(0200>>i%8); if (x->bv.bv_self[j/8]&(0200>>j%8)) x->bv.bv_self[i/8] |= 0200>>i%8; else x->bv.bv_self[i/8] &= ~(0200>>i%8); if (k) x->bv.bv_self[j/8] |= 0200>>j%8; else x->bv.bv_self[j/8] &= ~(0200>>j%8); } return(seq); default: FEwrong_type_argument(sLsequence, seq); return(Cnil); } } void gcl_init_sequence_function() { make_function("ELT", Lelt); make_si_function("ELT-SET", siLelt_set); make_function("SUBSEQ", Lsubseq); make_function("COPY-SEQ", Lcopy_seq); make_function("LENGTH", Llength); make_function("REVERSE", Lreverse); make_function("NREVERSE", Lnreverse); } gcl-2.6.14/o/structure.c0000755000175000017500000003012314360276512013437 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* structure.c structure interface */ #include #include "include.h" #define COERCE_DEF(x) if (type_of(x)==t_symbol) \ x=getf(x->s.s_plist,sSs_data,Cnil) #define check_type_structure(x) \ if(type_of((x))!=t_structure) \ FEwrong_type_argument(sLstructure,(x)) static bool structure_subtypep(object x, object y) { if (x==y) return 1; if (type_of(x)!= t_structure || type_of(y)!=t_structure) FEerror("bad call to structure_subtypep",0); {if (S_DATA(y)->included == Cnil) return 0; while ((x=S_DATA(x)->includes) != Cnil) { if (x==y) return 1;} return 0; }} static void bad_raw_type(void) { FEerror("Bad raw struct type",0);} DEFUN_NEW("STRUCTURE-DEF",object,fSstructure_def,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_structure(x); return (x)->str.str_def; } DEFUN_NEW("STRUCTURE-LENGTH",object,fSstructure_length,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { check_type_structure(x); return (object)S_DATA(x)->length; } DEFUN_NEW("STRUCTURE-REF",object,structure_ref,SI,3,3,NONE,OO,OI,OO,OO,(object x,object name,fixnum i),"") { /* object */ /* structure_ref(object x, object name, int i) */ /* { */ unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || (type_of(name)!=t_structure) || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name), x); s_pos = &SLOT_POS(x->str.str_def,0); switch((SLOT_TYPE(x->str.str_def,i))) { case aet_object: return(STREF(object,x,s_pos[i])); case aet_fix: return(make_fixnum((STREF(fixnum,x,s_pos[i])))); case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); case aet_bit: case aet_char: return(small_fixnum(STREF(char,x,s_pos[i]))); case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); case aet_uchar: return(small_fixnum(STREF(unsigned char,x,s_pos[i]))); case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); default: bad_raw_type(); return 0; } } #ifdef STATIC_FUNCTION_POINTERS object structure_ref(object x,object name,fixnum i) { return FFN(structure_ref)(x,name,i); } #endif static void FFN(siLstructure_ref1)(void) {object x=vs_base[0]; int n=fix(vs_base[1]); object def; check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) FEerror("Structure ref out of bounds",0); vs_base[0]=structure_ref(x,x->str.str_def,n); vs_top=vs_base+1; } DEFUN_NEW("STRUCTURE-SET",object,structure_set,SI,4,4,NONE,OO,OI,OO,OO,(object x,object name,fixnum i,object v),"") { /* object */ /* structure_set(object x, object name, int i, object v) */ /* { */ unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || type_of(name) != t_structure || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name) , x); #ifdef SGC /* make sure the structure header is on a writable page */ if (is_marked(x)) FEerror("bad gc field",0); else unmark(x); #endif s_pos= & SLOT_POS(x->str.str_def,0); switch(SLOT_TYPE(x->str.str_def,i)){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(fixnum,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); } return(v); } #ifdef STATIC_FUNCTION_POINTERS object structure_set(object x,object name,fixnum i,object v) { return FFN(structure_set)(x,name,i,v); } #endif static void FFN(siLstructure_subtype_p)(void) {object x,y; check_arg(2); x=vs_base[0]; y=vs_base[1]; if (type_of(x)!=t_structure) {vs_base[0]=Cnil; goto BOTTOM;} x=x->str.str_def; COERCE_DEF(y); if (structure_subtypep(x,y)) vs_base[0]=Ct; else vs_base[0]=Cnil; BOTTOM: vs_top=vs_base+1; } object structure_to_list(object x) { object *p,s,v; struct s_data *def=S_DATA(x->str.str_def); int i,n; s=def->slot_descriptions; for (p=&v,i=0,n=def->length;!endp(s)&&ic.c_cdr,i++) { collect(p,make_cons(car(s->c.c_car),Cnil)); collect(p,make_cons(structure_ref(x,x->str.str_def,i),Cnil)); } *p=Cnil; return make_cons(def->name,v); } LFD(siLmake_structure)(void) { object x,name,*base; struct s_data *def=NULL; int narg, i,size; base=vs_base; if ((narg = vs_top - base) == 0) too_few_arguments(); {BEGIN_NO_INTERRUPT; x = alloc_object(t_structure); name=base[0]; COERCE_DEF(name); if (type_of(name)!=t_structure || (def=S_DATA(name))->length != --narg) FEerror("Bad make_structure args for type ~a",1,base[0]); x->str.str_def = name; x->str.str_self = NULL; size=S_DATA(name)->size; base[0] = x; x->str.str_self = (object *) (def->staticp == Cnil ? alloc_relblock(size) : alloc_contblock(size)); /* There may be holes in the structure. We want them zero, so that equal can work better. */ if (S_DATA(name)->has_holes != Cnil) bzero(x->str.str_self,size); {unsigned char *s_type; unsigned short *s_pos; s_pos= (&SLOT_POS(x->str.str_def,0)); s_type = (&(SLOT_TYPE(x->str.str_def,0))); base=base+1; for (i = 0; i < narg; i++) {object v=base[i]; switch(s_type[i]){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(fixnum,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); }} vs_top = base; vs_base=base-1; END_NO_INTERRUPT;} } } static void FFN(Lcopy_structure)(void) { object x, y; struct s_data *def; check_arg(1); /* if (vs_top-vs_base < 1) too_few_arguments(); */ x = vs_base[0]; check_type_structure(x); {BEGIN_NO_INTERRUPT; vs_base[0] = y = alloc_object(t_structure); def=S_DATA(y->str.str_def = x->str.str_def); y->str.str_self = NULL; y->str.str_self = (object *)alloc_relblock(def->size); bcopy(x->str.str_self,y->str.str_self,def->size); vs_top=vs_base+1; END_NO_INTERRUPT;} } LFD(siLstructure_name)(void) { check_arg(1); check_type_structure(vs_base[0]); vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; } LFD(siLstructure_ref)(void) { check_arg(3); vs_base[0]=structure_ref(vs_base[0],vs_base[1],fix(vs_base[2])); vs_top=vs_base+1; } LFD(siLstructure_set)(void) { check_arg(4); structure_set(vs_base[0],vs_base[1],fix(vs_base[2]),vs_base[3]); vs_base = vs_top-1; } LFD(siLstructurep)(void) { check_arg(1); if (type_of(vs_base[0]) == t_structure) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(siLrplaca_nthcdr)(void) { /* Used in DEFSETF forms generated by DEFSTRUCT. (si:rplaca-nthcdr x i v) is equivalent to (progn (rplaca (nthcdr i x) v) v). */ int i; object l; check_arg(3); if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0) FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]); if (type_of(vs_base[0]) != t_cons) FEerror("~S is not a cons.", 1, vs_base[0]); for (i = fix(vs_base[1]), l = vs_base[0]; i > 0; --i) { l = l->c.c_cdr; if (endp(l)) FEerror("The offset ~S is too big.", 1, vs_base[1]); } take_care(vs_base[2]); l->c.c_car = vs_base[2]; vs_base = vs_base + 2; } LFD(siLlist_nth)(void) { /* Used in structure access functions generated by DEFSTRUCT. si:list-nth is similar to nth except that (si:list-nth i x) is error if the length of the list x is less than i. */ int i; object l; check_arg(2); if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0) FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]); if (type_of(vs_base[1]) != t_cons) FEerror("~S is not a cons.", 1, vs_base[1]); for (i = fix(vs_base[0]), l = vs_base[1]; i > 0; --i) { l = l->c.c_cdr; if (endp(l)) FEerror("The offset ~S is too big.", 1, vs_base[0]); } vs_base[0] = l->c.c_car; vs_popp; } static void FFN(siLmake_s_data_structure)(void) {object x,y,raw,*base; int i; check_arg(5); x=vs_base[0]; base=vs_base; raw=vs_base[1]; y=alloc_object(t_structure); y->str.str_def=y; y->str.str_self = (object *)( x->v.v_self); S_DATA(y)->name =sSs_data; S_DATA(y)->length=(raw->v.v_dim); S_DATA(y)->raw =raw; for(i=3; iv.v_dim; i++) y->str.str_self[i]=Cnil; S_DATA(y)->slot_position=base[2]; S_DATA(y)->slot_descriptions=base[3]; S_DATA(y)->staticp=base[4]; S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); vs_base[0]=y; vs_top=vs_base+1; } /* static void */ /* FFN(siLstructure_def)(void) */ /* {check_arg(1); */ /* check_type_structure(vs_base[0]); */ /* vs_base[0]=vs_base[0]->str.str_def; */ /* } */ short aet_sizes [] = { sizeof(object), /* aet_object t */ sizeof(char), /* aet_ch string-char */ sizeof(char), /* aet_bit bit */ sizeof(fixnum), /* aet_fix fixnum */ sizeof(float), /* aet_sf short-float */ sizeof(double), /* aet_lf long-float */ sizeof(char), /* aet_char signed char */ sizeof(char), /* aet_uchar unsigned char */ sizeof(short), /* aet_short signed short */ sizeof(short) /* aet_ushort unsigned short */ }; static void FFN(siLsize_of)(void) { object x= vs_base[0]; int i; i= aet_sizes[fix(fSget_aelttype(x))]; vs_base[0]=make_fixnum(i); } static void FFN(siLaet_type)(void) {vs_base[0]=fSget_aelttype(vs_base[0]);} /* Return N such that something of type ARG can be aligned on an address which is a multiple of N */ static void FFN(siLalignment)(void) {struct {double x; int y; double z; float x1; int y1; float z1;} joe; joe.z=3.0; if (vs_base[0]==sLlong_float) {vs_base[0]=make_fixnum((long)&joe.z- (long)&joe.y); return;} else if (vs_base[0]==sLshort_float) {vs_base[0]=make_fixnum((long)&(joe.z1)-(long)&(joe.y1)); return;} else {FFN(siLsize_of)();} } DEF_ORDINARY("S-DATA",sSs_data,SI,""); void gcl_init_structure_function(void) { make_si_function("MAKE-STRUCTURE", siLmake_structure); make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); make_function("COPY-STRUCTURE", Lcopy_structure); make_si_function("STRUCTURE-NAME", siLstructure_name); /* make_si_function("STRUCTURE-REF", siLstructure_ref); */ /* make_si_function("STRUCTURE-DEF", siLstructure_def); */ make_si_function("STRUCTURE-REF1", siLstructure_ref1); /* make_si_function("STRUCTURE-SET", siLstructure_set); */ make_si_function("STRUCTUREP", siLstructurep); make_si_function("SIZE-OF", siLsize_of); make_si_function("ALIGNMENT",siLalignment); make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr); make_si_function("LIST-NTH", siLlist_nth); make_si_function("AET-TYPE",siLaet_type); } gcl-2.6.14/o/print.d0000755000175000017500000012615314360276512012545 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* print.d */ #define NEED_ISFINITE #include "include.h" #include #include "num_include.h" #define LINE_LENGTH line_length int line_length = 72; #ifndef WRITEC_NEWLINE #define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) #endif #define READ_TABLE_CASE (Vreadtable->s.s_dbind->rt.rt_case) #define mod(x) ((x)%Q_SIZE) #define queue printStructBufp->p_queue #define indent_stack printStructBufp->p_indent_stack #define qh printStructBufp->p_qh #define qt printStructBufp->p_qt #define qc printStructBufp->p_qc #define isp printStructBufp->p_isp #define iisp printStructBufp->p_iisp object sSAprint_packageA; object sSAprint_structureA; /* bool RPINcircle; ??typo?? */ #define write_ch (*write_ch_fun) #define MARK 0400 #define UNMARK 0401 #define SET_INDENT 0402 #define INDENT 0403 #define INDENT1 0404 #define INDENT2 0405 extern object coerce_stream(object,int); static void flush_queue(int); static void writec_queue(c) int c; { if (qc >= Q_SIZE) flush_queue(FALSE); if (qc >= Q_SIZE) FEerror("Can't pretty-print.", 0); queue[qt] = c; qt = mod(qt+1); qc++; } static void flush_queue(int force) { int c, i, j, k, l, i0; BEGIN: while (qc > 0) { c = queue[qh]; if (c == MARK) goto MDO_MARK; else if (c == UNMARK) isp -= 2; else if (c == SET_INDENT) indent_stack[isp] = file_column(PRINTstream); else if (c == INDENT) { goto MDO_INDENT; } else if (c == INDENT1) { i = file_column(PRINTstream)-indent_stack[isp]; if (i < 8 && indent_stack[isp] < LINE_LENGTH/2) { writec_stream(' ', PRINTstream); indent_stack[isp] = file_column(PRINTstream); } else { if (indent_stack[isp] < LINE_LENGTH/2) { indent_stack[isp] = indent_stack[isp-1] + 4; } goto MDO_INDENT; } } else if (c == INDENT2) { indent_stack[isp] = indent_stack[isp-1] + 2; goto PUT_INDENT; } else if (c < 0400) writec_stream(c, PRINTstream); qh = mod(qh+1); --qc; } return; MDO_MARK: k = LINE_LENGTH - 1 - file_column(PRINTstream); for (i = 1, j = 0, l = 1; l > 0 && i < qc && j < k; i++) { c = queue[mod(qh + i)]; if (c == MARK) l++; else if (c == UNMARK) --l; else if (c == INDENT || c == INDENT1 || c == INDENT2) j++; else if (c < 0400) j++; } if (l == 0) goto FLUSH; if (i == qc && !force) return; qh = mod(qh+1); --qc; if (++isp >= IS_SIZE-1) FEerror("Can't pretty-print.", 0); indent_stack[isp++] = file_column(PRINTstream); indent_stack[isp] = indent_stack[isp-1]; goto BEGIN; MDO_INDENT: if (iisp > isp) goto PUT_INDENT; k = LINE_LENGTH - 1 - file_column(PRINTstream); for (i0 = 0, i = 1, j = 0, l = 1; i < qc && j < k; i++) { c = queue[mod(qh + i)]; if (c == MARK) l++; else if (c == UNMARK) { if (--l == 0) goto FLUSH; } else if (c == SET_INDENT) { if (l == 1) break; } else if (c == INDENT) { if (l == 1) i0 = i; j++; } else if (c == INDENT1) { if (l == 1) break; j++; } else if (c == INDENT2) { if (l == 1) { i0 = i; break; } j++; } else if (c < 0400) j++; } if (i == qc && !force) return; if (i0 == 0) goto PUT_INDENT; i = i0; goto FLUSH; PUT_INDENT: qh = mod(qh+1); --qc; WRITEC_NEWLINE(PRINTstream); for (i = indent_stack[isp]; i > 0; --i) writec_stream(' ', PRINTstream); iisp = isp; goto BEGIN; FLUSH: for (j = 0; j < i; j++) { c = queue[qh]; if (c == INDENT || c == INDENT1 || c == INDENT2) writec_stream(' ', PRINTstream); else if (c < 0400) writec_stream(c, PRINTstream); qh = mod(qh+1); --qc; } goto BEGIN; } void writec_PRINTstream(c) int c; { if (c == INDENT || c == INDENT1) writec_stream(' ', PRINTstream); else if (c < 0400) writec_stream(c, PRINTstream); } void write_str(s) char *s; { while (*s != '\0') write_ch(*s++); } static void write_decimal1(int); static void write_decimal(i) int i; { if (i == 0) { write_ch('0'); return; } write_decimal1(i); } static void write_decimal1(i) int i; { if (i == 0) return; write_decimal1(i/10); write_ch(i%10 + '0'); } static void write_addr(x) object x; { long i; int j, k; i = (long)x; for (j = 8*sizeof(i)-4; j >= 0; j -= 4) { k = (i>>j) & 0xf; if (k < 10) write_ch('0' + k); else write_ch('a' + k - 10); } } static void write_base(void) { if (PRINTbase == 2) write_str("#b"); else if (PRINTbase == 8) write_str("#o"); else if (PRINTbase == 16) write_str("#x"); else if (PRINTbase >= 10) { write_ch('#'); write_ch(PRINTbase/10+'0'); write_ch(PRINTbase%10+'0'); write_ch('r'); } else { write_ch('#'); write_ch(PRINTbase+'0'); write_ch('r'); } } /* The floating point precision required to make the most-positive-long-float printed expression readable. If this is too small, then the rounded off fraction, may be too big to read */ #ifndef FPRC #define FPRC 16 #endif object sSAprint_nansA; #include static int char_inc(char *b,char *p) { if (b==p) { /* if (*p=='-') { */ /* p++; */ /* memmove(p+1,p,strlen(p)+1); */ /* } */ *p='1'; } else if (*p=='9') { *p='0'; char_inc(b,p-1); } else if (*p=='.') char_inc(b,p-1); else (*p)++; return 1; } #define COMP(a_,b_,c_,d_) ((d_) ? strtod((a_),(b_))==(c_) : strtof((a_),(b_))==(float)(c_)) static int truncate_double(char *b,double d,int dp) { char c[FPRC+9],c1[FPRC+9],*p,*pp,*n; int j,k; n=b; k=strlen(n); strcpy(c1,b); for (p=c1;*p && *p!='e';p++); pp=p>c1 && p[-1]!='.' ? p-1 : p; for (;pp>c1 && pp[-1]=='0';pp--); memmove(pp,p,1+strlen(p)); if (pp!=p && COMP(c1,&pp,d,dp)) k=truncate_double(n=c1,d,dp); strcpy(c,n); for (p=c;*p && *p!='e';p++); if (p>c && p[-1]!='.' && char_inc(c,p-1) && COMP(c,&pp,d,dp)) { j=truncate_double(c,d,dp); if (j<=k) { k=j; n=c; } } if (n!=b) strcpy(b,n); return k; } void edit_double(int n,double d,int *sp,char *s,int *ep,int dp) { char *p, b[FPRC+9]; int i; if (!ISFINITE(d)) { if (sSAprint_nansA->s.s_dbind !=Cnil) { sprintf(s, "%e",d); *sp=2; return; } else FEerror("Can't print a non-number.",0);} else sprintf(b, "%*.*e",FPRC+8,FPRC,d); if (b[FPRC+3] != 'e') { sprintf(b, "%*.*e",FPRC+7,FPRC,d); *ep=(b[FPRC+5]-'0')*10+(b[FPRC+6]-'0'); } else *ep=(b[FPRC+5]-'0')*100+(b[FPRC+6]-'0')*10+(b[FPRC+7]-'0'); *sp=1; if (b[0]=='-') { *sp*=-1; b[0]=' '; }if (b[FPRC+4]=='-') *ep*=-1; truncate_double(b,d,dp); if ((p=strchr(b,'e'))) *p=0; if (n+2='5') char_inc(b,b+n+1); if (isdigit((int)b[0])) { b[1]=b[0]; (*ep)++; } b[2]=b[1]; for (i=0,p=b+2;i'); return; } if (sign < 0) write_ch('-'); if (-3 <= exp && exp < 7) { if (exp < 0) { write_ch('0'); write_ch('.'); exp = (-exp) - 1; for (i = 0; i < exp; i++) write_ch('0'); for (; n > 0; --n) if (buff[n-1] != '0' && buff[n-1]) break; if (exp == 0 && n == 0) n = 1; for (i = 0; i < n; i++) write_ch(buff[i]); } else { exp++; for (i = 0; i < exp; i++) if (i < n) write_ch(buff[i]); else write_ch('0'); write_ch('.'); if (i < n) write_ch(buff[i]); else write_ch('0'); i++; for (; n > i; --n) if (buff[n-1] != '0' && buff[n-1]) break; for (; i < n; i++) write_ch(buff[i]); } exp = 0; } else { write_ch(buff[0]); write_ch('.'); write_ch(buff[1]); for (; n > 2; --n) if (buff[n-1] != '0' && buff[n-1]) break; for (i = 2; i < n; i++) write_ch(buff[i]); } if (exp == 0 && e == 0) return; if (e == 0) e = 'E'; write_ch(e); if (exp < 0) { write_ch('-'); exp *= -1; } write_decimal(exp); } static void call_structure_print_function(x, level) object x; int level; { int i; bool eflag; bds_ptr old_bds_top; void (*wf)(int) = write_ch_fun; object *vt = PRINTvs_top; bool e = PRINTescape; bool ra = PRINTreadably; bool r = PRINTradix; int b = PRINTbase; bool c = PRINTcircle; bool p = PRINTpretty; int lv = PRINTlevel; int ln = PRINTlength; bool g = PRINTgensym; bool a = PRINTarray; /* short oq[Q_SIZE]; */ short ois[IS_SIZE]; VOL int oqh; VOL int oqt; VOL int oqc; VOL int oisp; VOL int oiisp; ONCE_MORE: if (interrupt_flag) { interrupt_flag = FALSE; #ifdef UNIX alarm(0); #endif terminal_interrupt(TRUE); goto ONCE_MORE; } if (PRINTpretty) flush_queue(TRUE); oqh = qh; oqt = qt; oqc = qc; oisp = isp; oiisp = iisp; /* No need to save the queue, since it is flushed. for (i = 0; i < Q_SIZE; i++) oq[i] = queue[i]; */ if (PRINTpretty) for (i = 0; i <= isp; i++) ois[i] = indent_stack[i]; vs_push(PRINTstream); vs_push(PRINTcase); vs_push(make_fixnum(level)); old_bds_top = bds_top; bds_bind(sLAprint_escapeA, PRINTescape?Ct:Cnil); bds_bind(sLAprint_readablyA, PRINTreadably?Ct:Cnil); bds_bind(sLAprint_radixA, PRINTradix?Ct:Cnil); bds_bind(sLAprint_baseA, make_fixnum(PRINTbase)); bds_bind(sLAprint_circleA, PRINTcircle?Ct:Cnil); bds_bind(sLAprint_prettyA, PRINTpretty?Ct:Cnil); bds_bind(sLAprint_levelA, PRINTlevel<0?Cnil:make_fixnum(PRINTlevel)); bds_bind(sLAprint_lengthA, PRINTlength<0?Cnil:make_fixnum(PRINTlength)); bds_bind(sLAprint_gensymA, PRINTgensym?Ct:Cnil); bds_bind(sLAprint_arrayA, PRINTarray?Ct:Cnil); bds_bind(sLAprint_caseA, PRINTcase); frs_push(FRS_PROTECT, Cnil); if (nlj_active) { eflag = TRUE; goto L; } ifuncall3(S_DATA(x->str.str_def)->print_function, x, PRINTstream, vs_head); vs_popp; eflag = FALSE; L: frs_pop(); bds_unwind(old_bds_top); /* for (i = 0; i < Q_SIZE; i++) queue[i] = oq[i]; */ if (PRINTpretty) for (i = 0; i <= oisp; i++) indent_stack[i] = ois[i]; iisp = oiisp; isp = oisp; qc = oqc; qt = oqt; qh = oqh; PRINTcase = vs_pop; PRINTstream = vs_pop; PRINTarray = a; PRINTgensym = g; PRINTlength = ln; PRINTlevel = lv; PRINTpretty = p; PRINTcircle = c; PRINTbase = b; PRINTradix = r; PRINTescape = e; PRINTreadably = ra; PRINTvs_top = vt; write_ch_fun = wf; if (eflag) { nlj_active = FALSE; unwind(nlj_fr, nlj_tag); } } object copy_big(); object coerce_big_to_string(object,int); static bool potential_number_p(object,int); #define CASE_OF(x_) ({int _x=(x_);isUpper(_x) ? 1 : (isLower(_x) ? -1 : 0);}) static int constant_case(object x) { fixnum i,j,jj; for (i=j=0;is.s_fillp;i++,j=j ? j : jj) if (j*(jj=CASE_OF(x->s.s_self[i]))==-1) return 0; return j; } static int needs_escape (object x) { fixnum i,all_dots=1; int ch; if (!PRINTescape) return 0; for (i=0;is.s_fillp;i++) switch((ch=x->s.s_self[i])) { case ':': return 1; case '.': break; default: all_dots=0; if (Vreadtable->s.s_dbind->rt.rt_self[ch].rte_chattrib!=cat_constituent) return 1; if ((READ_TABLE_CASE==sKupcase && isLower(ch)) || (READ_TABLE_CASE==sKdowncase && isUpper(ch))) return 1; } if (potential_number_p(x, PRINTbase) || all_dots) return 1; return !x->s.s_fillp; } #define convertible_upper(c) ((READ_TABLE_CASE==sKupcase ||READ_TABLE_CASE==sKinvert)&& isUpper(c)) #define convertible_lower(c) ((READ_TABLE_CASE==sKdowncase||READ_TABLE_CASE==sKinvert)&& isLower(c)) static void print_symbol_name_body(object x) { int i,j,fc,tc,lw,k,cc; cc=constant_case(x); k=needs_escape(x); if (k) write_ch('|'); for (lw=i=0;is.s_fillp;i++) { j = x->s.s_self[i]; if (PRINTescape && (Vreadtable->s.s_dbind->rt.rt_self[j].rte_chattrib==cat_single_escape || Vreadtable->s.s_dbind->rt.rt_self[j].rte_chattrib==cat_multiple_escape)) write_ch('\\'); fc=convertible_upper(j) ? 1 : (convertible_lower(j) ? -1 : 0); tc=(READ_TABLE_CASE==sKinvert ? -cc : (PRINTcase == sKupcase ? 1 : (PRINTcase == sKdowncase ? -1 : (PRINTcase == sKcapitalize ? (i==lw ? 1 : -1) : 0)))); if (ispunct(j)||isspace(j)) lw=i+1; j+=(tc && fc && !k ? (tc-fc)>>1 : 0)*('A'-'a'); write_ch(j); } if (k) write_ch('|'); } #define DONE 1 #define FOUND -1 static int do_write_sharp_eq(struct htent *e,bool dot) { fixnum val=fix(e->hte_value); bool defined=val&1; if (dot) { write_str(" . "); if (!defined) return FOUND; } if (!defined) e->hte_value=make_fixnum(val|1); write_ch('#'); write_decimal(val>>1); write_ch(defined ? '#' : '='); return defined ? DONE : FOUND; } static int write_sharp_eq(object x,bool dot) { struct htent *e; return PRINTvs_top[0]!=Cnil && (e=gethash(x,PRINTvs_top[0]))->hte_key!=OBJNULL ? do_write_sharp_eq(e,dot) : 0; } void write_object(x, level) object x; int level; { object r, y; int i, j, k; cs_check(x); if (x == OBJNULL) { write_str("#"); return; } if (is_free(x)) { write_str("#"); return; } switch (type_of(x)) { case t_fixnum: { object *vsp; /*FIXME 64*/ fixnum i; if (PRINTradix && PRINTbase != 10) write_base(); i = fix(x); if (i == 0) { write_ch('0'); if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } if (i < 0) { write_ch('-'); if (i == MOST_NEGATIVE_FIX) { x = fixnum_add(1,(MOST_POSITIVE_FIX)); vs_push(x); i = PRINTradix; PRINTradix = FALSE; write_object(x, level); PRINTradix = i; vs_popp; if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } i = -i; } vsp = vs_top; for (vsp = vs_top; i != 0; i /= PRINTbase) vs_push(code_char(digit_weight(i%PRINTbase, PRINTbase))); while (vs_top > vsp) write_ch(char_code((vs_pop))); if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } case t_bignum: { if (PRINTradix && PRINTbase != 10) write_base(); i = big_sign(x); if (i == 0) { write_ch('0'); if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } { object s = coerce_big_to_string(x,PRINTbase); int i=0; while (iust.ust_fillp) { write_ch(s->ust.ust_self[i++]); } } if (PRINTradix && PRINTbase == 10) write_ch('.'); break; } case t_ratio: if (PRINTradix) { write_base(); PRINTradix = FALSE; write_object(x->rat.rat_num, level); write_ch('/'); write_object(x->rat.rat_den, level); PRINTradix = TRUE; } else { write_object(x->rat.rat_num, level); write_ch('/'); write_object(x->rat.rat_den, level); } break; case t_shortfloat: r = symbol_value(sLAread_default_float_formatA); if (r == sLshort_float) write_double((double)sf(x), 0, TRUE); else write_double((double)sf(x), 'S', TRUE); break; case t_longfloat: r = symbol_value(sLAread_default_float_formatA); if (r == sLsingle_float || r == sLlong_float || r == sLdouble_float) write_double(lf(x), 0, FALSE); else write_double(lf(x), 'F', FALSE); break; case t_complex: write_str("#C("); write_object(x->cmp.cmp_real, level); write_ch(' '); write_object(x->cmp.cmp_imag, level); write_ch(')'); break; case t_character: if (!PRINTescape) { write_ch(char_code(x)); break; } write_str("#\\"); switch (char_code(x)) { case '\r': write_str("Return"); break; case ' ': write_str("Space"); break; case '\177': write_str("Rubout"); break; case '\f': write_str("Page"); break; case '\t': write_str("Tab"); break; case '\b': write_str("Backspace"); break; case '\n': write_str("Newline"); break; default: if (char_code(x) & 0200) { write_ch('\\'); i = char_code(x); write_ch(((i>>6)&7) + '0'); write_ch(((i>>3)&7) + '0'); write_ch(((i>>0)&7) + '0'); } else if (char_code(x) < 040) { write_ch('^'); write_ch(char_code(x) + 0100); } else write_ch(char_code(x)); break; } break; case t_symbol: { if (PRINTescape) { if (x->s.s_hpack == Cnil) { if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTgensym) write_str("#:"); } else if (x->s.s_hpack == keyword_package) { write_ch(':'); } else if (PRINTpackage||find_symbol(x,current_package())!=x || !intern_flag) { print_symbol_name_body(x->s.s_hpack->p.p_name); if (find_symbol(x, x->s.s_hpack) != x) error("can't print symbol"); if (PRINTpackage || intern_flag == INTERNAL) write_str("::"); else if (intern_flag == EXTERNAL) write_ch(':'); else FEerror("Pathological symbol --- cannot print.", 0); } } print_symbol_name_body(x); break; } case t_array: { int subscripts[ARANKLIM]; int n, m; if (!PRINTarray) { write_str("#"); break; } if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTlevel >= 0 && level >= PRINTlevel) { write_ch('#'); break; } n = x->a.a_rank; write_ch('#'); write_decimal(n); write_ch('A'); if (PRINTlevel >= 0 && level+n >= PRINTlevel) n = PRINTlevel - level; for (i = 0; i < n; i++) subscripts[i] = 0; m = 0; j = 0; for (;;) { for (i = j; i < n; i++) { if (subscripts[i] == 0) { write_ch(MARK); write_ch('('); write_ch(SET_INDENT); if (x->a.a_dims[i] == 0) { write_ch(')'); write_ch(UNMARK); j = i-1; k = 0; goto INC; } } if (subscripts[i] > 0) write_ch(INDENT); if (PRINTlength >= 0 && subscripts[i] >= PRINTlength) { write_str("...)"); write_ch(UNMARK); k=x->a.a_dims[i]-subscripts[i]; subscripts[i] = 0; for (j = i+1; j < n; j++) k *= x->a.a_dims[j]; j = i-1; goto INC; } } if (n == x->a.a_rank) { vs_push(aref(x, m)); write_object(vs_head, level+n); vs_popp; } else write_ch('#'); j = n-1; k = 1; INC: while (j >= 0) { if (++subscripts[j] < x->a.a_dims[j]) break; subscripts[j] = 0; write_ch(')'); write_ch(UNMARK); --j; } if (j < 0) break; m += k; } break; } case t_vector: if (!PRINTarray) { write_str("#"); break; } if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTlevel >= 0 && level >= PRINTlevel) { write_ch('#'); break; } write_ch('#'); write_ch(MARK); write_ch('('); write_ch(SET_INDENT); if (x->v.v_fillp > 0) { if (PRINTlength == 0) { write_str("...)"); write_ch(UNMARK); break; } vs_push(aref(x, 0)); write_object(vs_head, level+1); vs_popp; for (i = 1; i < x->v.v_fillp; i++) { write_ch(INDENT); if (PRINTlength>=0 && i>=PRINTlength){ write_str("..."); break; } vs_push(aref(x, i)); write_object(vs_head, level+1); vs_popp; } } write_ch(')'); write_ch(UNMARK); break; case t_string: if (!PRINTescape) { for (i = 0; i < x->st.st_fillp; i++) write_ch(x->st.st_self[i]); break; } write_ch('"'); for (i = 0; i < x->st.st_fillp; i++) { if (x->st.st_self[i] == '"' || x->st.st_self[i] == '\\') write_ch('\\'); write_ch(x->st.st_self[i]); } write_ch('"'); break; case t_bitvector: if (!PRINTarray) { write_str("#"); break; } write_str("#*"); for (i = x->bv.bv_offset; i < x->bv.bv_fillp + x->bv.bv_offset; i++) if (x->bv.bv_self[i/8] & (0200 >> i%8)) write_ch('1'); else write_ch('0'); break; case t_cons: if (x->c.c_car == siSsharp_comma) { write_str("#."); write_object(x->c.c_cdr, level); break; } if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTpretty) { if (x->c.c_car == sLquote && type_of(x->c.c_cdr) == t_cons && x->c.c_cdr->c.c_cdr == Cnil) { write_ch('\''); write_object(x->c.c_cdr->c.c_car, level); break; } if (x->c.c_car == sLfunction && type_of(x->c.c_cdr) == t_cons && x->c.c_cdr->c.c_cdr == Cnil) { write_ch('#'); write_ch('\''); write_object(x->c.c_cdr->c.c_car, level); break; } } if (PRINTlevel >= 0 && level >= PRINTlevel) { write_ch('#'); break; } write_ch(MARK); write_ch('('); write_ch(SET_INDENT); if (PRINTpretty && x->c.c_car != OBJNULL && type_of(x->c.c_car) == t_symbol && (r = getf(x->c.c_car->s.s_plist, sSpretty_print_format, Cnil)) != Cnil) goto PRETTY_PRINT_FORMAT; for (i = 0; ; i++) { if (PRINTlength >= 0 && i >= PRINTlength) { write_str("..."); break; } y = x->c.c_car; x = x->c.c_cdr; write_object(y, level+1); if (type_of(x) != t_cons) { if (x != Cnil) { write_ch(INDENT); write_str(". "); write_object(x, level); } break; } if (PRINTcircle) switch (write_sharp_eq(x,TRUE)) { case FOUND: write_object(x, level); case DONE: goto RIGHT_PAREN; default: break; } if (i == 0 && y != OBJNULL && type_of(y) == t_symbol) write_ch(INDENT1); else write_ch(INDENT); } RIGHT_PAREN: write_ch(')'); write_ch(UNMARK); break; PRETTY_PRINT_FORMAT: j = fixint(r); for (i = 0; ; i++) { if (PRINTlength >= 0 && i >= PRINTlength) { write_str("..."); break; } y = x->c.c_car; x = x->c.c_cdr; if (i <= j && y == Cnil) write_str("()"); else write_object(y, level+1); if (type_of(x) != t_cons) { if (x != Cnil) { write_ch(INDENT); write_str(". "); write_object(x, level); } break; } if (i >= j) write_ch(INDENT2); else if (i == 0) write_ch(INDENT1); else write_ch(INDENT); } goto RIGHT_PAREN; case t_package: write_str("#<"); write_object(x->p.p_name, level); write_str(" package>"); break; case t_hashtable: write_str("#"); break; case t_stream: switch (x->sm.sm_mode) { case smm_input: write_str("#sm.sm_object1, level); write_ch('>'); break; case smm_output: write_str("#sm.sm_object1, level); write_ch('>'); break; case smm_io: write_str("#sm.sm_object1, level); write_ch('>'); break; case smm_socket: write_str("#sm.sm_object0, level); write_ch('>'); break; case smm_probe: write_str("#sm.sm_object1, level); write_ch('>'); break; case smm_synonym: write_str("#sm.sm_object0, level); write_ch('>'); break; case smm_broadcast: write_str("#"); break; case smm_concatenated: write_str("#"); break; case smm_two_way: write_str("#"); break; case smm_echo: write_str("#"); break; case smm_string_input: write_str("#sm.sm_object0; j = y->st.st_fillp; for (i = 0; i < j && i < 16; i++) write_ch(y->st.st_self[i]); if (j > 16) write_str("..."); write_str("\">"); break; #ifdef USER_DEFINED_STREAMS case smm_user_defined: write_str("#"); break; #endif case smm_string_output: write_str("#"); break; default: error("illegal stream mode"); } break; #define FRESH_COPY(a_,b_) {(b_)->_mp_alloc=(a_)->_mp_alloc;\ (b_)->_mp_d=gcl_gmp_alloc((b_)->_mp_alloc*sizeof(*(b_)->_mp_d));\ (b_)->_mp_size=(a_)->_mp_size;\ memcpy((b_)->_mp_d,(a_)->_mp_d,(b_)->_mp_alloc*sizeof(*(b_)->_mp_d));} case t_random: write_str("#$"); y = new_bignum(); FRESH_COPY(x->rnd.rnd_state._mp_seed,MP(y)); y=normalize_big(y); vs_push(y); write_object(y, level); vs_popp; break; case t_structure: if (PRINTcircle) if (write_sharp_eq(x,FALSE)==DONE) return; if (PRINTlevel >= 0 && level >= PRINTlevel) { write_ch('#'); break; } if (type_of(x->str.str_def) != t_structure) FEwrong_type_argument(sLstructure, x->str.str_def); if (PRINTstructure || S_DATA(x->str.str_def)->print_function == Cnil) { write_str("#S"); x = structure_to_list(x); vs_push(x); write_object(x, level); vs_popp; break; } call_structure_print_function(x, level); break; case t_readtable: write_str("#"); break; case t_pathname: if (1 || PRINTescape) { write_ch('#'); write_ch('p'); vs_push(x->pn.pn_namestring==Cnil ? make_simple_string("") : x->pn.pn_namestring); write_object(vs_head, level); vs_popp; } else { write_str("#"); } break; case t_sfun: case t_gfun: case t_vfun: case t_afun: case t_cfun: write_str("#cf.cf_name != Cnil) write_object(x->cf.cf_name, level); else write_addr(x); write_str(">"); break; case t_closure: case t_cclosure: write_str("#cc.cc_name != Cnil) write_object(x->cc.cc_name, level); else write_addr(x); write_str(">"); break; case t_spice: write_str("#<\100"); for (i = 8*sizeof(long)-4; i >= 0; i -= 4) { j = ((long)x >> i) & 0xf; if (j < 10) write_ch('0' + j); else write_ch('A' + (j - 10)); } write_ch('>'); break; default: error("illegal type --- cannot print"); } } static int dgs,dga; #include "page.h" static void travel_push(object x) { int i; if (is_imm_fixnum(x)) return; if (is_marked(x)) { if (imcdr(x) || !x->d.f) vs_check_push(x); if (!imcdr(x)) x->d.f=1; } else switch (type_of(x)) { case t_symbol: if (dgs && x->s.s_hpack==Cnil) { mark(x); } break; case t_cons: { object y=x->c.c_cdr; mark(x); travel_push(x->c.c_car); travel_push(y); } break; case t_vector: case t_array: mark(x); if (dga && (enum aelttype)x->a.a_elttype==aet_object) for (i=0;ia.a_dim;i++) travel_push(x->a.a_self[i]); break; case t_structure: mark(x); for (i = 0; i < S_DATA(x->str.str_def)->length; i++) travel_push(structure_ref(x,x->str.str_def,i)); break; default: break; } } static void travel_clear(object x) { int i; if (is_imm_fixnum(x)) return; if (!is_marked(x)) return; unmark(x); if (!imcdr(x)) x->d.f=0; switch (type_of(x)) { case t_cons: travel_clear(x->c.c_car); travel_clear(x->c.c_cdr); break; case t_vector: case t_array: if (dga && (enum aelttype)x->a.a_elttype == aet_object) for (i=0;ia.a_dim;i++) travel_clear(x->a.a_self[i]); break; case t_structure: for (i = 0; i < S_DATA(x->str.str_def)->length; i++) travel_clear(structure_ref(x,x->str.str_def,i)); break; default: break; } } static void travel(object x,int mdgs,int mdga) { BEGIN_NO_INTERRUPT; dgs=mdgs; dga=mdga; travel_push(x); travel_clear(x); END_NO_INTERRUPT; } object sLeq; static void setupPRINTcircle(object x,int dogensyms) { object *vp=vs_top,*v=vp,h; fixnum j; travel(x,dogensyms,PRINTarray); h=vs_top>vp ? gcl_make_hash_table(sLeq) : Cnil; for (j=0;vhte_key==OBJNULL) sethash(*v,h,make_fixnum((j++)<<1)); vs_top=vp; vs_push(h); } void travel_find_sharing(object x,object table) { object *vp=vs_top; travel(x,1,1); for (;vs_top>vp;vs_top--) sethash(vs_head,table,make_fixnum(-2)); } void setupPRINTdefault(x) object x; { object y; PRINTvs_top = vs_top; PRINTstream = symbol_value(sLAstandard_outputA); if (type_of(PRINTstream) != t_stream) { sLAstandard_outputA->s.s_dbind = symbol_value(sLAterminal_ioA); vs_push(PRINTstream); FEwrong_type_argument(sLstream, PRINTstream); } PRINTreadably = symbol_value(sLAprint_readablyA) != Cnil; PRINTescape = PRINTreadably || symbol_value(sLAprint_escapeA) != Cnil; PRINTpretty = symbol_value(sLAprint_prettyA) != Cnil; PRINTcircle = symbol_value(sLAprint_circleA) != Cnil; y = symbol_value(sLAprint_baseA); if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) { sLAprint_baseA->s.s_dbind = make_fixnum(10); vs_push(y); FEerror("~S is an illegal PRINT-BASE.", 1, y); } else PRINTbase = fix(y); PRINTradix = symbol_value(sLAprint_radixA) != Cnil; PRINTcase = symbol_value(sLAprint_caseA); if (PRINTcase != sKupcase && PRINTcase != sKdowncase && PRINTcase != sKcapitalize) { sLAprint_caseA->s.s_dbind = sKdowncase; vs_push(PRINTcase); FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase); } PRINTgensym = symbol_value(sLAprint_gensymA) != Cnil; y = symbol_value(sLAprint_levelA); if (y == Cnil) PRINTlevel = -1; else if (type_of(y) != t_fixnum || fix(y) < 0) { sLAprint_levelA->s.s_dbind = Cnil; vs_push(y); FEerror("~S is an illegal PRINT-LEVEL.", 1, y); } else PRINTlevel = fix(y); y = symbol_value(sLAprint_lengthA); if (y == Cnil) PRINTlength = -1; else if (type_of(y) != t_fixnum || fix(y) < 0) { sLAprint_lengthA->s.s_dbind = Cnil; vs_push(y); FEerror("~S is an illegal PRINT-LENGTH.", 1, y); } else PRINTlength = fix(y); PRINTarray = symbol_value(sLAprint_arrayA) != Cnil; if (PRINTcircle) setupPRINTcircle(x,1); if (PRINTpretty) { qh = qt = qc = 0; isp = iisp = 0; indent_stack[0] = 0; write_ch_fun = writec_queue; } else write_ch_fun = writec_PRINTstream; PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; PRINTstructure = symbol_value(sSAprint_structureA) != Cnil; } void cleanupPRINT(void) { vs_top = PRINTvs_top; if (PRINTpretty) flush_queue(TRUE); } /*static void write_object_by_default(x) object x; { SETUP_PRINT_DEFAULT(x); write_object(x, 0); flush_stream(PRINTstream); CLEANUP_PRINT_DEFAULT; }*/ /*static void terpri_by_default() { PRINTstream = symbol_value(sLAstandard_outputA); if (type_of(PRINTstream) != t_stream) FEwrong_type_argument(sLstream, PRINTstream); WRITEC_NEWLINE(PRINTstream); }*/ static bool potential_number_p(strng, base) object strng; int base; { int i, l, c, dc; char *s; l = strng->st.st_fillp; if (l == 0) return(FALSE); s = strng->st.st_self; dc = 0; c = s[0]; if (digitp(c, base) >= 0) dc++; else if (c != '+' && c != '-' && c != '^' && c != '_') return(FALSE); if (s[l-1] == '+' || s[l-1] == '-') return(FALSE); for (i = 1; i < l; i++) { c = s[i]; if (digitp(c, base) >= 0) { dc++; continue; } if (c != '+' && c != '-' && c != '/' && c != '.' && c != '^' && c != '_' && c != 'e' && c != 'E' && c != 's' && c != 'S' && c != 'l' && c != 'L') return(FALSE); } if (dc == 0) return(FALSE); return(TRUE); } @(defun write (x &key ((:stream strm) Cnil) (escape `symbol_value(sLAprint_escapeA)`) (readably `symbol_value(sLAprint_readablyA)`) (radix `symbol_value(sLAprint_radixA)`) (base `symbol_value(sLAprint_baseA)`) (circle `symbol_value(sLAprint_circleA)`) (pretty `symbol_value(sLAprint_prettyA)`) (level `symbol_value(sLAprint_levelA)`) (length `symbol_value(sLAprint_lengthA)`) ((:case cas) `symbol_value(sLAprint_caseA)`) (gensym `symbol_value(sLAprint_gensymA)`) (array `symbol_value(sLAprint_arrayA)`)) struct printStruct printStructBuf; struct printStruct *old_printStructBufp = printStructBufp; @ printStructBufp = &printStructBuf; if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) FEerror("~S is not a stream.", 1, strm); PRINTvs_top = vs_top; PRINTstream = strm; PRINTreadably = readably != Cnil; PRINTescape = PRINTreadably || escape != Cnil; PRINTpretty = pretty != Cnil; PRINTcircle = circle != Cnil; if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36) FEerror("~S is an illegal PRINT-BASE.", 1, base); else PRINTbase = fix((base)); PRINTradix = radix != Cnil; PRINTcase = cas; if (PRINTcase != sKupcase && PRINTcase != sKdowncase && PRINTcase != sKcapitalize) FEerror("~S is an illegal PRINT-CASE.", 1, cas); PRINTgensym = PRINTreadably || gensym != Cnil; if (PRINTreadably || level == Cnil) PRINTlevel = -1; else if (type_of(level) != t_fixnum || fix((level)) < 0) FEerror("~S is an illegal PRINT-LEVEL.", 1, level); else PRINTlevel = fix((level)); if (PRINTreadably || length == Cnil) PRINTlength = -1; else if (type_of(length) != t_fixnum || fix((length)) < 0) FEerror("~S is an illegal PRINT-LENGTH.", 1, length); else PRINTlength = fix((length)); PRINTarray = PRINTreadably || array != Cnil; if (PRINTcircle) setupPRINTcircle(x,1); if (PRINTpretty) { qh = qt = qc = 0; isp = iisp = 0; indent_stack[0] = 0; write_ch_fun = writec_queue; } else write_ch_fun = writec_PRINTstream; PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; PRINTstructure = symbol_value(sSAprint_structureA) != Cnil; write_object(x, 0); CLEANUP_PRINT_DEFAULT; flush_stream(PRINTstream); @(return x) @) @(defun prin1 (obj &optional strm) @ prin1(obj, strm); @(return obj) @) @(defun print (obj &optional strm) @ print(obj, strm); @(return obj) @) @(defun pprint (obj &optional strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); WRITEC_NEWLINE(strm); {SETUP_PRINT_DEFAULT(obj); PRINTstream = strm; PRINTreadably = FALSE; PRINTescape = TRUE; PRINTpretty = TRUE; qh = qt = qc = 0; isp = iisp = 0; indent_stack[0] = 0; write_ch_fun = writec_queue; write_object(obj, 0); CLEANUP_PRINT_DEFAULT; flush_stream(strm);} @(return) @) @(defun princ (obj &optional strm) @ princ(obj, strm); @(return obj) @) @(defun write_char (c &optional strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_character(&c); check_type_stream(&strm); writec_stream(char_code(c), strm); /* flush_stream(strm); */ @(return c) @) @(defun write_string (strng &o strm &k start end) int s, e, i; @ get_string_start_end(strng, start, end, &s, &e); if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_string(&strng); check_type_stream(&strm); for (i = s; i < e; i++) writec_stream(strng->st.st_self[i], strm); flush_stream(strm); @(return strng) @) @(defun write_line (strng &o strm &k start end) int s, e, i; @ get_string_start_end(strng, start, end, &s, &e); if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_string(&strng); check_type_stream(&strm); for (i = s; i < e; i++) writec_stream(strng->st.st_self[i], strm); WRITEC_NEWLINE(strm); flush_stream(strm); @(return strng) @) @(defun terpri (&optional strm) @ terpri(strm); @(return Cnil) @) @(defun fresh_line (&optional strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); /* we need to get the real output stream, if possible */ {object tmp=coerce_stream(strm,1); if(tmp != Cnil) strm = tmp ; else check_type_stream(&strm); } if (file_column(strm) == 0) @(return Cnil) WRITEC_NEWLINE(strm); flush_stream(strm); @(return Ct) @) @(defun finish_output (&o strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); flush_stream(strm); @(return Cnil) @) @(defun force_output (&o strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); flush_stream(strm); @(return Cnil) @) @(defun clear_output (&o strm) @ if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_stream(&strm); @(return Cnil) @) @(defun write_byte (integer binary_output_stream) @ if (type_of(integer) != t_fixnum) FEerror("~S is not a byte.", 1, integer); check_type_stream(&binary_output_stream); writec_stream(fix(integer), binary_output_stream); @(return integer) @) DEF_ORDINARY("UPCASE",sKupcase,KEYWORD,""); DEF_ORDINARY("DOWNCASE",sKdowncase,KEYWORD,""); DEF_ORDINARY("CAPITALIZE",sKcapitalize,KEYWORD,""); DEF_ORDINARY("STREAM",sKstream,KEYWORD,""); DEF_ORDINARY("ESCAPE",sKescape,KEYWORD,""); DEF_ORDINARY("READABLY",sKreadably,KEYWORD,""); DEF_ORDINARY("PRETTY",sKpretty,KEYWORD,""); DEF_ORDINARY("CIRCLE",sKcircle,KEYWORD,""); DEF_ORDINARY("BASE",sKbase,KEYWORD,""); DEF_ORDINARY("RADIX",sKradix,KEYWORD,""); DEF_ORDINARY("CASE",sKcase,KEYWORD,""); DEF_ORDINARY("GENSYM",sKgensym,KEYWORD,""); DEF_ORDINARY("LEVEL",sKlevel,KEYWORD,""); DEF_ORDINARY("LENGTH",sKlength,KEYWORD,""); DEF_ORDINARY("ARRAY",sKarray,KEYWORD,""); DEFVAR("*PRINT-ESCAPE*",sLAprint_escapeA,LISP,Ct,""); DEFVAR("*PRINT-READABLY*",sLAprint_readablyA,LISP,Ct,""); DEFVAR("*PRINT-PRETTY*",sLAprint_prettyA,LISP,Ct,""); DEFVAR("*PRINT-CIRCLE*",sLAprint_circleA,LISP,Cnil,""); DEFVAR("*PRINT-BASE*",sLAprint_baseA,LISP,make_fixnum(10),""); DEFVAR("*PRINT-RADIX*",sLAprint_radixA,LISP,Cnil,""); DEFVAR("*PRINT-CASE*",sLAprint_caseA,LISP,sKupcase,""); DEFVAR("*PRINT-GENSYM*",sLAprint_gensymA,LISP,Ct,""); DEFVAR("*PRINT-LEVEL*",sLAprint_levelA,LISP,Cnil,""); DEFVAR("*PRINT-LENGTH*",sLAprint_lengthA,LISP,Cnil,""); DEFVAR("*PRINT-ARRAY*",sLAprint_arrayA,LISP,Ct,""); DEFVAR("*PRINT-PACKAGE*",sSAprint_packageA,SI,Cnil,""); DEFVAR("*PRINT-STRUCTURE*",sSAprint_structureA,SI,Cnil,""); DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,""); void gcl_init_print() { /* travel_push_type[(int)t_array]=1; */ /* travel_push_type[(int)t_vector]=1; */ /* travel_push_type[(int)t_structure]=1; */ /* travel_push_type[(int) t_cons]=1; */ /* if(sizeof(travel_push_type) < t_other) */ /* error("travel_push_size to small see print.d"); */ PRINTstream = Cnil; enter_mark_origin(&PRINTstream); PRINTreadably = FALSE; PRINTescape = TRUE; PRINTpretty = FALSE; PRINTcircle = FALSE; PRINTbase = 10; PRINTradix = FALSE; PRINTcase = sKupcase; enter_mark_origin(&PRINTcase); PRINTgensym = TRUE; PRINTlevel = -1; PRINTlength = -1; PRINTarray = FALSE; write_ch_fun = writec_PRINTstream; } object princ(obj, strm) object obj, strm; { if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) FEerror("~S is not a stream.", 1, strm); if (obj == OBJNULL) goto SIMPLE_CASE; switch (type_of(obj)) { case t_symbol: PRINTcase = symbol_value(sLAprint_caseA); PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; SIMPLE_CASE: case t_string: case t_character: PRINTstream = strm; PRINTreadably = FALSE; PRINTescape = FALSE; write_ch_fun = writec_PRINTstream; write_object(obj, 0); break; default: {SETUP_PRINT_DEFAULT(obj); PRINTstream = strm; PRINTreadably = FALSE; PRINTescape = FALSE; write_object(obj, 0); CLEANUP_PRINT_DEFAULT;} break; } return(obj); } object prin1(obj, strm) object obj, strm; { if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) FEerror("~S is not a stream.", 1, strm); if (obj == OBJNULL) goto SIMPLE_CASE; switch (type_of(obj)) { SIMPLE_CASE: case t_string: case t_character: PRINTstream = strm; PRINTreadably = FALSE; PRINTescape = TRUE; write_ch_fun = writec_PRINTstream; write_object(obj, 0); break; default: {SETUP_PRINT_DEFAULT(obj); PRINTstream = strm; PRINTreadably = FALSE; PRINTescape = TRUE; write_object(obj, 0); CLEANUP_PRINT_DEFAULT;} break; } flush_stream(strm); return(obj); } object print(obj, strm) object obj, strm; { terpri(strm); prin1(obj,strm); princ(code_char(' '),strm); return(obj); } object terpri(strm) object strm; { if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) FEerror("~S is not a stream.", 1, strm); WRITEC_NEWLINE(strm); flush_stream(strm); return(Cnil); } void write_string(strng, strm) object strng, strm; { int i; if (strm == Cnil) strm = symbol_value(sLAstandard_outputA); else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); check_type_string(&strng); check_type_stream(&strm); for (i = 0; i < strng->st.st_fillp; i++) writec_stream(strng->st.st_self[i], strm); flush_stream(strm); } /* THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION */ void princ_str(s, sym) char *s; object sym; { sym = symbol_value(sym); if (sym == Cnil) sym = symbol_value(sLAstandard_outputA); else if (sym == Ct) sym = symbol_value(sLAterminal_ioA); check_type_stream(&sym); writestr_stream(s, sym); } void princ_char(c, sym) int c; object sym; { sym = symbol_value(sym); if (sym == Cnil) sym = symbol_value(sLAstandard_outputA); else if (sym == Ct) sym = symbol_value(sLAterminal_ioA); check_type_stream(&sym); if (c == '\n') {WRITEC_NEWLINE(sym); flush_stream(sym);} else writec_stream(c, sym); } void pp(x) object x; { princ(x,Cnil); flush_stream(symbol_value(sLAstandard_outputA)); } static object FFN(set_line_length)(n) int n; { line_length=n; return make_fixnum(line_length); } DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,""); void gcl_init_print_function() { make_function("WRITE", Lwrite); make_function("PRIN1", Lprin1); make_function("PRINT", Lprint); make_function("PPRINT", Lpprint); make_function("PRINC", Lprinc); make_function("WRITE-CHAR", Lwrite_char); make_function("WRITE-STRING", Lwrite_string); make_function("WRITE-LINE", Lwrite_line); make_function("TERPRI", Lterpri); make_function("FRESH-LINE", Lfresh_line); make_function("FINISH-OUTPUT", Lfinish_output); make_function("FORCE-OUTPUT", Lforce_output); make_function("CLEAR-OUTPUT", Lclear_output); make_function("WRITE-BYTE", Lwrite_byte); make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum) | RESTYPE(f_fixnum)); } gcl-2.6.14/o/sockets.c0000755000175000017500000003242514360276512013061 0ustar cammcamm/* Copyright (C) 1994 Rami el Charif, W. Schelter This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #define IN_SOCKETS #include #include "include.h" #ifdef HAVE_NSOCKET #include "sheader.h" #include #ifndef __MINGW32__ # include # include # include #else # include # include #endif #ifdef __STDC__ #include #endif #ifndef __MINGW32__ # include #endif #include #ifndef NO_UNISTD_H #include #endif #include /*#include */ #include static void write_timeout_error(); static void connection_failure(); #ifdef __MINGW32__ /* Keep track of socket initialisations */ int w32_socket_initialisations = 0; WSADATA WSAData; int w32_socket_init(void) { int rv = 0; if (w32_socket_initialisations++) { rv = 0; } else { if (WSAStartup(0x0101, &WSAData)) { w32_socket_initialisations = 0; emsg("WSAStartup failed\n" ); WSACleanup(); rv = -1; } } return rv; } int w32_socket_exit(void) { int rv = 0; if ( w32_socket_initialisations == 0 || --w32_socket_initialisations > 0 ) { rv = 0; } else { rv = WSACleanup(); } return rv; } #endif #define BIND_MAX_RETRY 128 #define BIND_ADDRESS_INCREMENT 16 #define BIND_INITIAL_ADDRESS 5000 #define BIND_LAST_ADDRESS 65534 static unsigned int iLastAddressUsed = BIND_INITIAL_ADDRESS; DEFUN_NEW("OPEN-NAMED-SOCKET",object,fSopen_named_socket,SI,1,1,NONE,OI,OO,OO,OO,(fixnum port), "Open a socket on PORT and return (cons fd portname) where file \ descriptor is a small fixnum which is the write file descriptor for \ the socket. If PORT is zero do automatic allocation of port") { #ifdef __MINGW32__ SOCKET s; #else int s; #endif int n, rc; struct sockaddr_in addr; #ifdef __MINGW32__ if ( w32_socket_init() < 0 ) { perror("ERROR !!! Windows socket DLL initialisation failed in sock_connect_to_name\n"); return Cnil; } #endif /* Using TCP layer */ s = socket(PF_INET, SOCK_STREAM, 0); #ifdef __MINGW32__ if ( s == INVALID_SOCKET ) #else if (s < 0) #endif { perror("ERROR !!! socket creation failed in sock_connect_to_name\n"); return Cnil; } addr.sin_family = PF_INET; addr.sin_addr.s_addr = INADDR_ANY; memset(addr.sin_zero, 0, 8); n = sizeof addr; if (port == 0) { #define MY_HTONS(x) htons((unsigned short)((x) & 0xffff)) int cRetry = 0; do { addr.sin_port = MY_HTONS(iLastAddressUsed); rc = bind(s, (struct sockaddr *)&addr, n); cRetry++; iLastAddressUsed += BIND_ADDRESS_INCREMENT; if (iLastAddressUsed > BIND_LAST_ADDRESS) iLastAddressUsed = BIND_INITIAL_ADDRESS; } while ((rc < 0) && #ifdef __MINGW32__ (errno == WSAEADDRINUSE) && #else (errno == EADDRINUSE) && #endif (cRetry < BIND_MAX_RETRY)); if (0) emsg("\nAssigned automatic address to socket : port(%d), errno(%d), bind_rc(%d), iLastAddressUsed(%d), retries(%d)\n" , addr.sin_port, errno, rc, iLastAddressUsed, cRetry ); } else { addr.sin_port = MY_HTONS(port); rc = bind(s, (struct sockaddr *)&addr, n); } if (rc < 0) { perror("ERROR !!! Failed to bind socket in sock_open_named_socket\n"); close(s); return Cnil; } rc = listen(s, 3); if (rc < 0) { perror("ERROR ! listen failed on socket in sock_open_named_socket"); close(s); return Cnil; } return make_cons(make_fixnum(s), make_fixnum(ntohs(addr.sin_port))); } DEFUN_NEW("CLOSE-FD",object,fSclose_fd,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd), "Close the file descriptor FD") {RETURN1(0==close(fd) ? Ct : Cnil);} DEFUN_NEW("CLOSE-SD",object,fSclose_sfd,SI,1,1,NONE,OO,OO,OO,OO,(object sfd), "Close the socket connection sfd") { int res; free(OBJ_TO_CONNECTION_STATE(sfd)->read_buffer); res = close(OBJ_TO_CONNECTION_STATE(sfd)->fd); free (OBJ_TO_CONNECTION_STATE(sfd)); #ifdef __MINGW32__ w32_socket_exit(); #endif RETURN1(res ? Ct : Cnil); } DEFUN_NEW("ACCEPT-SOCKET-CONNECTION",object,fSaccept_socket_connection, SI,1,1,NONE,OO,OO,OO,OO,(object named_socket), "Given a NAMED_SOCKET it waits for a connection on this \ and returns (list* named_socket fd name1) when one is established") { socklen_t n; int fd; struct sockaddr_in addr; object x; n = sizeof addr; fd = accept(fix(car(named_socket)) , (struct sockaddr *)&addr, &n); if (fd < 0) { emsg("ERROR ! accept on socket failed in sock_accept_connection"); return Cnil; } x = alloc_simple_string(sizeof(struct connection_state)); x->ust.ust_self = (void *)setup_connection_state(fd); return make_cons( make_cons(x , make_simple_string( inet_ntoa(addr.sin_addr))), named_socket ); } /* static object */ /* sock_hostname_to_hostid_list(host_name) */ /* char *host_name; */ /* { */ /* struct hostent *h; */ /* object addr_list = Cnil; */ /* int i; */ /* h = gethostbyname(host_name); */ /* for (i = 0; h->h_addr_list[i] != 0; i++) */ /* { */ /* addr_list = make_cons(make_simple_string(inet_ntoa(*(struct in_addr *)h->h_addr_list[i])), addr_list); */ /* } */ /* return addr_list; */ /* } */ DEFUN_NEW("HOSTNAME-TO-HOSTID",object,fShostname_to_hostid,SI,1,1, NONE,OO,OO,OO,OO,(object host),"") { struct hostent *h; char buf[300]; char *p; p = lisp_copy_to_null_terminated(host,buf,sizeof(buf)); h = /* gethostbyname(p); */ #ifdef STATIC_LINKING NULL; #else gethostbyname(p); #endif if (p != buf) free (p); if (h && h->h_addr_list[0]) return make_simple_string(inet_ntoa(*(struct in_addr *)h->h_addr_list[0])); else return Cnil; } DEFUN_NEW("GETHOSTNAME",object,fSgethostname,SI,0,0,NONE,OO,OO,OO,OO,(void), "Returns HOSTNAME of the local host") {char buf[300]; if (0 == gethostname(buf,sizeof(buf))) return make_simple_string(buf); else return Cnil; } DEFUN_NEW("HOSTID-TO-HOSTNAME",object,fShostid_to_hostname,SI, 1,10,NONE,OO,OO,OO,OO,(object host_id),"") {char *hostid; struct in_addr addr; struct hostent *h; char buf[300]; hostid = lisp_copy_to_null_terminated(host_id,buf,sizeof(buf)); addr.s_addr = inet_addr(hostid); h = /* gethostbyaddr((char *)&addr, 4, AF_INET); */ #ifdef STATIC_LINKING NULL; #else gethostbyaddr((char *)&addr, 4, AF_INET); #endif if (h && h->h_name && *h->h_name) return make_simple_string(h->h_name); else return Cnil; } /* static object */ /* sock_get_name(s) */ /* int s; */ /* { */ /* struct sockaddr_in addr; */ /* int m = sizeof(addr); */ /* getsockname(s, (struct sockaddr *)&addr, &m); */ /* return make_cons( */ /* make_cons( */ /* make_fixnum(addr.sin_port) */ /* , make_simple_string(inet_ntoa(addr.sin_addr)) */ /* ) */ /* ,make_cons(make_fixnum(addr.sin_family) */ /* , make_fixnum(s)) */ /* ); */ /* } */ #include "comm.c" DEFUN_NEW("CONNECTION-STATE-FD",object,fSconnection_state_fd,SI,1,1,NONE,OO,OO,OO,OO,(object sfd),"") { return make_fixnum(OBJ_TO_CONNECTION_STATE(sfd)->fd); } DEFUN_NEW("OUR-WRITE",object,fSour_write,SI,3,3,NONE,OO,OI,OO,OO,(object sfd,object buffer,fixnum nbytes),"") { return make_fixnum(write1(OBJ_TO_CONNECTION_STATE(sfd),buffer->st.st_self,nbytes)); } DEFUN_NEW("OUR-READ-WITH-OFFSET",object,fSour_read_with_offset,SI,5,5,NONE, OO,OI,II,OO,(object fd,object buffer,fixnum offset,fixnum nbytes,fixnum timeout), "Read from STATE-FD into string BUFFER putting data at OFFSET and reading NBYTES, waiting for TIMEOUT before failing") { return make_fixnum(read1(OBJ_TO_CONNECTION_STATE(fd),&((buffer)->st.st_self[offset]),nbytes,timeout)); } enum print_arglist_codes { normal, no_leading_space, join_follows, end_join, begin_join, begin_join_no_leading_space, no_quote, no_quote_no_leading_space, no_quote_downcase, no_quotes_and_no_leading_space }; /* push object X into the string with fill pointer STR, according to CODE */ #define PUSH(_c) do{if (--left < 0) goto FAIL; \ *xx++ = _c;}while(0) #define BEGIN_QUOTE '"' #define END_QUOTE '"' static int needs_quoting[256]; DEFUN_NEW("PRINT-TO-STRING1",object,fSprint_to_string1,SI,3,3,NONE,OO,OO,OO,OO,(object str,object x,object the_code), "Print to STRING the object X according to CODE. The string must have \ fill pointer, and this will be advanced.") { enum type t = type_of(x); int fp = str->st.st_fillp; char *xx = &(str->st.st_self[fp]); int left = str->st.st_dim - fp; char buf[30]; char *p; enum print_arglist_codes code = fix(the_code); if (code==no_quote || code == no_quotes_and_no_leading_space) { needs_quoting['"']=0; needs_quoting['$']=0; needs_quoting['\\']=0; needs_quoting['[']=0; /* needs_quoting[']']=0; */ } else { needs_quoting['"']=1; needs_quoting['$']=1; needs_quoting['\\']=1; needs_quoting['[']=1; /* needs_quoting[']']=1; */ } { int downcase ; int do_end_quote = 0; if(type_of(str)!=t_string) FEerror("Must be given string with fill pointer",0); if (t==t_symbol) downcase=1; else downcase=0; switch (code){ case no_quote_downcase: downcase = 1; case no_quote: PUSH(' '); case no_quotes_and_no_leading_space: case no_quote_no_leading_space: break; case normal: PUSH(' '); case no_leading_space: if (t==t_string) { do_end_quote = 1; PUSH(BEGIN_QUOTE); } break; case begin_join: PUSH(' '); case begin_join_no_leading_space: PUSH(BEGIN_QUOTE); break; case end_join: do_end_quote=1; break; case join_follows: break; default: do_gcl_abort(); } switch (t) { case t_symbol: if (x->s.s_hpack == keyword_package) {if (code == normal) PUSH('-');} case t_string: {int len = x->st.st_fillp; p = &x->st.st_self[0]; if (downcase) while (--len>=0) { char c = *p++; c=tolower((int)c); if(needs_quoting[(unsigned char)c]) PUSH('\\'); PUSH(c);} else while (--len>=0) { char c = *p++; if(needs_quoting[(unsigned char)c]) PUSH('\\'); PUSH(c);}} break; case t_fixnum: sprintf(buf,"%ld",fix(x)); p = buf; while(*p) {PUSH(*p);p++;} break; case t_longfloat: sprintf(buf,"%.2f",lf(x)); p = buf; while(*p) {PUSH(*p);p++;} break; case t_shortfloat: sprintf(buf,"%.2f",sf(x)); p = buf; while(*p) {PUSH(*p);p++;} break; case t_bignum: goto FAIL; default: FEerror("Bad type for print_string ~s",1,x); } if(do_end_quote) PUSH('"'); str->st.st_fillp += (xx - &(str->st.st_self[fp])); return Ct; FAIL: /* either ran out of storage or tried to print a bignum. The caller will handle these two cases */ return Cnil; } } static void not_defined_for_os() { FEerror("Function not defined for this operating system",0);} DEFUN_NEW("SET-SIGIO-FOR-FD",object,fSset_sigio_for_fd,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd),"") { /* for the moment we will use SIGUSR1 to notify, instead of depending on SIGIO, since LINUX does not support the latter yet... So right now this does nothing... */ #if !defined(FASYNC) || !defined(SET_FD_TO_GIVE_SIGIO) not_defined_for_os(); #else #ifdef SET_FD_TO_GIVE_SIGIO SET_FD_TO_GIVE_SIGIO(fd); #else /* want something like this... but wont work on all machines. */ flags = fcntl(fd,F_GETFL,0); if (flags == -1 || ( flags |= FASYNC , 0) || -1 == fcntl(fd,F_SETFL,flags) || -1 == fcntl(fd,F_SETOWN,getpid())) {perror("Could not set ASYNC IO for SIGIO:"); return Cnil;} #endif #endif return (Ct); } DEFUN_NEW("CHECK-STATE-INPUT",object,fScheck_state_input,SI,2,2,NONE,OO,IO,OO,OO,(object osfd,fixnum timeout), "") { return fScheck_dsfd_for_input(OBJ_TO_CONNECTION_STATE(osfd),timeout); } DEFUN_NEW("CLEAR-CONNECTION-STATE",object,fSclear_connection_state, SI,1,1,NONE,OO,OO,OO,OO,(object osfd), "Read on FD until nothing left to read. Return number of bytes read") { struct connection_state *sfd = OBJ_TO_CONNECTION_STATE(osfd); int n=fix(FFN(fSclear_connection)(sfd->fd)); sfd->valid_data = sfd->read_buffer; sfd->valid_data_size = 0; sfd->bytes_received_not_confirmed += n; return make_fixnum(n); } #endif static void write_timeout_error(s) char *s; {FEerror("Write timeout: ~s",1,make_simple_string(s)); } static void connection_failure(s) char *s; {FEerror("Connect failure: ~s",1,make_simple_string(s)); } gcl-2.6.14/o/bind.texi0000755000175000017500000000002614360276512013041 0ustar cammcamm@setfilename foo.info gcl-2.6.14/o/savedec31.c0000755000175000017500000001606414360276512013165 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* unixsave.c */ #ifdef HAVE_FCNTL #include #else #include #endif #ifdef HAVE_AOUT #undef BSD #undef ATT #define BSD #endif #ifdef BSD #include #endif #ifdef ATT #include #include #include #include #endif #ifdef E15 #include extern etext; #endif filecpy(to, from, n) FILE *to, *from; register int n; { char buffer[BUFSIZ]; for (;;) if (n > BUFSIZ) { fread(buffer, BUFSIZ, 1, from); fwrite(buffer, BUFSIZ, 1, to); n -= BUFSIZ; } else if (n > 0) { fread(buffer, 1, n, from); fwrite(buffer, 1, n, to); break; } else break; } memory_save(original_file, save_file) char *original_file, *save_file; { /* MEM_SAVE_LOCALS; */ struct filehdr Ehdr; struct aouthdr header; struct scnhdr shdr[10]; HDRR symhdr; struct scnhdr *text_section; struct scnhdr *rdata_section; struct scnhdr *data_section; struct scnhdr *lit8_section; struct scnhdr *lit4_section; struct scnhdr *sdata_section; struct scnhdr *sbss_section; struct scnhdr *bss_section; char *data_begin, *data_end; int original_data; FILE *original, *save; register int n; register char *p; extern char *sbrk(); fclose(stdin); original = fopen(original_file, "r"); if (stdin != original || original->_file != 0) { fprintf(stderr, "Can't open the original file.\n"); exit(1); } setbuf(original, stdin_buf); fclose(stdout); unlink(save_file); n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } setbuf(save, stdout_buf); fread(&Ehdr,sizeof(Ehdr),1,original); fread(&header,Ehdr.f_opthdr, 1,original); {int i=0; int pagesize = getpagesize(); /* core_end = (char *)((int) (core_end + pagesize - 1) & ~(pagesize - 1)); */ #define READ_SCNHDR(name,str) \ name = &shdr[i]; \ fread(name,sizeof(struct scnhdr),1,original); \ if(strcmp(str,(name)->s_name)) printf("got %s not %s sections", \ (name)->s_name,str); i++; READ_SCNHDR(text_section,".text") ; READ_SCNHDR(rdata_section,".rdata"); READ_SCNHDR(data_section,".data"); READ_SCNHDR(lit8_section, ".lit8"); READ_SCNHDR(lit4_section, ".lit4"); READ_SCNHDR(sdata_section, ".sdata"); READ_SCNHDR(sbss_section,".sbss"); READ_SCNHDR(bss_section,".bss"); if(i!= Ehdr.f_nscns) printf("wrong number of sections"); } /* READ_HEADER; FILECPY_HEADER; */ #define ALTER_SCN(name,size,addr,scnptr) (name)->s_size = size; \ (name)->s_paddr = addr; \ (name)->s_vaddr = addr; \ (name)->s_scnptr = scnptr; original_data = header.a_data; data_begin = (char *)rdata_section->s_vaddr; header.a_data = (int) core_end - rdata_section->s_vaddr; header.a_bss = 0; ALTER_SCN(data_section, header.a_data - rdata_section->s_size ,data_section->s_vaddr, data_section->s_scnptr); ALTER_SCN(lit4_section,0,data_section->s_vaddr,data_section->s_scnptr); ALTER_SCN(lit8_section,0,data_section->s_vaddr,data_section->s_scnptr); ALTER_SCN(sbss_section,0,data_section->s_vaddr,data_section->s_scnptr); ALTER_SCN(sdata_section,0,data_section->s_vaddr,data_section->s_scnptr) ; ALTER_SCN(bss_section,0, /* sbrk(0) - core_end,*/ data_section->s_vaddr,data_section->s_scnptr); header.bsize = bss_section->s_size; Ehdr.f_symptr += (header.dsize - original_data); fwrite(&Ehdr,1,sizeof(Ehdr),save); fwrite(&header,1,Ehdr.f_opthdr,save); fwrite(&shdr[0],sizeof(struct scnhdr),Ehdr.f_nscns,save); filecpy(save,original,rdata_section->s_scnptr - ftell(save)); /* p = data_begin; n= header.a_data; while(--n>=0) {putc(*p,save); p++;} */ for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) { {int jj; jj = ftell(save);} if (n > BUFSIZ) fwrite(p, BUFSIZ, 1, save); else if (n > 0) { fwrite(p, 1, n, save); break; } else break;} fseek(original, original_data, 1); COPY_TO_SAVE; {int diff = (header.dsize - original_data); fseek(original,Ehdr.f_symptr - diff,0); fread(&symhdr,sizeof(symhdr),1,original); if(symhdr.cbLineOffset)symhdr.cbLineOffset+= diff; if(symhdr.cbDnOffset)symhdr.cbDnOffset+= diff; if(symhdr.cbPdOffset)symhdr.cbPdOffset+= diff; if(symhdr.cbSymOffset)symhdr.cbSymOffset+= diff; if(symhdr.cbOptOffset)symhdr.cbOptOffset+= diff; if(symhdr.cbAuxOffset)symhdr.cbAuxOffset+= diff; if(symhdr.cbSsOffset)symhdr.cbSsOffset+= diff; if(symhdr.cbSsExtOffset)symhdr.cbSsExtOffset+= diff; if(symhdr.cbFdOffset)symhdr.cbFdOffset+= diff; if(symhdr.cbRfdOffset)symhdr.cbRfdOffset+= diff; if(symhdr.cbExtOffset)symhdr.cbExtOffset+= diff; fseek(save,Ehdr.f_symptr ,0); fwrite(&symhdr,sizeof(symhdr),1,save); } fclose(original); fclose(save); } Lsave() { char filename[256]; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); coerce_to_filename(vs_base[0], filename); _cleanup(); /* { FILE *p; int nfile; nfile = NUMBER_OPEN_FILES; for (p = &_iob[3]; p < &_iob[nfile]; p++) fclose(p); } */ memory_save(kcl_self, filename); /* _exit(0); */ exit(0); /* no return */ } gcl-2.6.14/o/multival.c0000755000175000017500000000532414360276512013241 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* multival.c Multiple Values */ #include "include.h" LFD(Lvalues)(void) { if (vs_base == vs_top) vs_base[0] = Cnil; } LFD(Lvalues_list)(void) { object list; check_arg(1); list = vs_base[0]; vs_top = vs_base; while (!endp_prop(list)) { vs_push(MMcar(list)); list = MMcdr(list); } if (vs_top == vs_base) vs_base[0] = Cnil; } static void FFN(Fmultiple_value_list)(object form) { object *top = vs_top; if (endp(form)) FEtoo_few_argumentsF(form); if (!endp(MMcdr(form))) FEtoo_many_argumentsF(form); vs_push(Cnil); eval(MMcar(form)); while (vs_base < vs_top) { top[0] = MMcons(vs_top[-1],top[0]); vs_top--; } vs_base = top; vs_top = top+1; } static void FFN(Fmultiple_value_call)(object form) { object *top = vs_top; object *top1; object *top2; if (endp(form)) FEtoo_few_argumentsF(form); eval(MMcar(form)); vs_top = top; vs_push(vs_base[0]); form = MMcdr(form); while (!endp(form)) { top1 = vs_top; eval(MMcar(form)); top2 = vs_top; vs_top = top1; while (vs_base < top2) { vs_push(vs_base[0]); vs_base++; } form = MMcdr(form); } vs_base = top+1; super_funcall(top[0]); } static void FFN(Fmultiple_value_prog1)(object forms) { object *top; object *base = vs_top; if (endp(forms)) FEtoo_few_argumentsF(forms); eval(MMcar(forms)); top = vs_top; vs_top=base; while (vs_base < top) { vs_push(vs_base[0]); vs_base++; } top = vs_top; forms = MMcdr(forms); while (!endp(forms)) { eval(MMcar(forms)); vs_top = top; forms = MMcdr(forms); } vs_base = base; vs_top = top; if (vs_base == vs_top) vs_base[0] = Cnil; } void gcl_init_multival(void) { make_constant("MULTIPLE-VALUES-LIMIT",make_fixnum(32)); make_function("VALUES",Lvalues); make_function("VALUES-LIST",Lvalues_list); make_special_form("MULTIPLE-VALUE-CALL",Fmultiple_value_call); make_special_form("MULTIPLE-VALUE-PROG1", Fmultiple_value_prog1); make_special_form("MULTIPLE-VALUE-LIST",Fmultiple_value_list); } gcl-2.6.14/o/file.d0000755000175000017500000015042414360276512012326 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* file.d IMPLEMENTATION-DEPENDENT The specification of printf may be dependent on the C library, especially for read-write access, append access, etc. The file also contains the code to reclaim the I/O buffer by accessing the FILE structure of C. It also contains read_fasl_data. */ #include #include #include #include #include #define IN_FILE #include "include.h" #ifdef USE_READLINE #define kclgetc(FP) rl_getc_em(((FILE *)FP)) #define kclungetc(C, FP) rl_ungetc_em(C, ((FILE *)FP)) #define kclputc(C, FP) rl_putc_em(C, ((FILE *)FP)) #else #define kclgetc(FP) getc(((FILE *)FP)) #define kclungetc(C, FP) ungetc(C, ((FILE *)FP)) #define kclputc(C, FP) putc(C, ((FILE *)FP)) #endif /* USE_READLINE */ #define xkclfeof(c,FP) feof(((FILE *)FP)) #ifdef HAVE_AOUT #undef ATT #undef BSD #ifndef HAVE_ELF #ifndef HAVE_FILEHDR #define BSD #endif #endif #include HAVE_AOUT #endif #ifdef ATT #include #include #define HAVE_FILEHDR #endif #ifdef E15 #include #define exec bhdr #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #endif #if defined(HAVE_ELF_H) #include #elif defined(HAVE_ELF_ABI_H) #include #endif #ifndef __MINGW32__ # include # include # include #else # include # include #endif #include extern void tcpCloseSocket (int fd); object terminal_io; object Vverbose; object LSP_string; object sSAignore_eof_on_terminal_ioA; static bool feof1(fp) FILE *fp; { #ifdef USE_READLINE if (rl_stream_p(fp) && rl_eof_p(fp)) return TRUE; #endif if (!feof(fp)) return(FALSE); if (fp == terminal_io->sm.sm_object0->sm.sm_fp) { if (symbol_value(sSAignore_eof_on_terminal_ioA) == Cnil) return(TRUE); #ifdef UNIX fp = freopen("/dev/tty", "r", fp); #endif #ifdef AOSVS #endif if (fp == NULL) error("can't reopen the console"); return(FALSE); } return(TRUE); } #undef feof #define feof feof1 void end_of_stream(strm) object strm; { END_OF_FILE(strm); } /* Input_stream_p(strm) answers if stream strm is an input stream or not. It does not check if it really is possible to read from the stream, but only checks the mode of the stream (sm_mode). */ static bool input_stream_p(strm) object strm; { BEGIN: switch (strm->sm.sm_mode) { case smm_input: return(TRUE); case smm_output: return(FALSE); case smm_io: case smm_socket: return(TRUE); case smm_probe: return(FALSE); case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_broadcast: return(FALSE); case smm_concatenated: return(TRUE); case smm_two_way: return(TRUE); case smm_echo: return(TRUE); case smm_string_input: return(TRUE); case smm_string_output: return(FALSE); default: error("illegal stream mode"); return(FALSE); } } /* Output_stream_p(strm) answers if stream strm is an output stream. It does not check if it really is possible to write to the stream, but only checks the mode of the stream (sm_mode). */ static bool output_stream_p(strm) object strm; { BEGIN: switch (strm->sm.sm_mode) { case smm_input: return(FALSE); case smm_output: return(TRUE); case smm_io: case smm_socket: return(TRUE); case smm_probe: return(FALSE); case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_broadcast: return(TRUE); case smm_concatenated: return(FALSE); case smm_two_way: return(TRUE); case smm_echo: return(TRUE); case smm_string_input: return(FALSE); case smm_string_output: return(TRUE); default: error("illegal stream mode"); return(FALSE); } } static object stream_element_type(strm) object strm; { object x; BEGIN: switch (strm->sm.sm_mode) { case smm_input: case smm_output: case smm_io: case smm_probe: return(strm->sm.sm_object0); case smm_socket: return (sLcharacter); case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_broadcast: x = strm->sm.sm_object0; if (endp(x)) return(Ct); return(stream_element_type(x->c.c_car)); case smm_concatenated: x = strm->sm.sm_object0; if (endp(x)) return(Ct); return(stream_element_type(x->c.c_car)); case smm_two_way: return(stream_element_type(STREAM_INPUT_STREAM(strm))); case smm_echo: return(stream_element_type(STREAM_INPUT_STREAM(strm))); case smm_string_input: return(sLcharacter); case smm_string_output: return(sLcharacter); default: error("illegal stream mode"); return(FALSE); } } void setup_stream_buffer(object x) { #ifdef NO_SETBUF massert(!setvbuf(x->sm.sm_fp,x->sm.sm_buffer=NULL,_IONBF,0)); #else massert(!setvbuf(x->sm.sm_fp,x->sm.sm_buffer=writable_malloc_wrap(malloc,void *,BUFSIZ),_IOFBF,BUFSIZ)); #endif } static void deallocate_stream_buffer(object strm) { if (strm->sm.sm_buffer==NULL) return; free(strm->sm.sm_buffer); massert(!setvbuf(strm->sm.sm_fp,strm->sm.sm_buffer=NULL,_IONBF,0)); } DEFVAR("*ALLOW-GZIPPED-FILE*",sSAallow_gzipped_fileA,SI,sLnil,""); /* static void */ /* too_long_file_name(object); */ static void cannot_open(object); static void cannot_create(object); /* Open_stream(fn, smm, if_exists, if_does_not_exist) opens file fn with mode smm. Fn is a namestring. */ object open_stream(object fn,enum smmode smm, object if_exists, object if_does_not_exist) { object x; FILE *fp=NULL; vs_mark; coerce_to_filename(fn,FN1); switch(smm) { case smm_input: case smm_probe: if (!(fp=*FN1=='|' ? popen(FN1+1,"r") : fopen_not_dir(FN1,"r")) && sSAallow_gzipped_fileA->s.s_dbind!=Cnil) { struct stat ss; massert(snprintf(FN2,sizeof(FN2),"%s.gz",FN1)>0); if (!stat(FN2,&ss)) { FILE *pp; int n; massert((fp=tmpfile())); massert(snprintf(FN3,sizeof(FN2),"zcat %s",FN2)>0); massert(pp=popen(FN3,"r")); while ((n=fread(FN4,1,sizeof(FN3),pp))) massert(fwrite(FN4,1,n,fp)==n); massert(pclose(pp)>=0); massert(!fseek(fp,0,SEEK_SET)); } } if (!fp) { if (if_does_not_exist==sKerror) cannot_open(fn); else if (if_does_not_exist==sKcreate) { if (!(fp=fopen_not_dir(FN1,"w"))) cannot_create(fn); fclose(fp); if (!(fp=fopen_not_dir(FN1,"r"))) cannot_open(fn); } else if (if_does_not_exist==Cnil) return(Cnil); else FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",1,if_does_not_exist); } break; case smm_output: case smm_io: if ((fp=*FN1=='|' ? NULL : fopen_not_dir(FN1,"r"))) { fclose(fp); if (if_exists==sKerror) FILE_ERROR(fn,"File exists"); else if (if_exists==sKrename) { massert(snprintf(FN2,sizeof(FN2),"%-*.*s~",(int)strlen(FN1)-1,(int)strlen(FN1)-1,FN1)>=0); massert(!unlink(FN2));/*MinGW*/ massert(!rename(FN1,FN2)); if (!(fp=fopen(FN1,smm==smm_output ? "w" : "w+"))) cannot_create(fn); } else if (if_exists==sKrename_and_delete || if_exists==sKnew_version || if_exists==sKsupersede) { if (!(fp=fopen(FN1,smm==smm_output ? "w" : "w+"))) cannot_create(fn); } else if (if_exists==sKoverwrite) { if (!(fp=fopen_not_dir(FN1,"r+"))) cannot_open(fn); } else if (if_exists==sKappend) { if (!(fp = fopen_not_dir(FN1,smm==smm_output ? "a" : "a+"))) FEerror("Cannot append to the file ~A.",1,fn); } else if (if_exists == Cnil) return(Cnil); else FEerror("~S is an illegal IF-EXISTS option.",1,if_exists); } else { if (if_does_not_exist == sKerror) FILE_ERROR(fn,"The file does not exist"); else if (if_does_not_exist == sKcreate) { if (!(fp=smm==smm_output ? (*FN1=='|' ? popen(FN1+1,"w") : fopen_not_dir(FN1, "w")) : fopen_not_dir(FN1, "w+"))) cannot_create(fn); } else if (if_does_not_exist==Cnil) return(Cnil); else FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",1,if_does_not_exist); } break; default: FEerror("Illegal open mode for ~S.",1,fn); break; } vs_push(make_simple_string(FN1)); x = alloc_object(t_stream); x->sm.sm_mode = (short)smm; x->sm.sm_fp = fp; x->sm.sm_buffer = 0; x->sm.sm_object0 = sLcharacter; x->sm.sm_object1 = vs_head; x->sm.sm_int = 0; x->sm.sm_flags=0; vs_push(x); setup_stream_buffer(x); vs_reset; if (smm==smm_probe) close_stream(x); return(x); } static void gclFlushSocket(object); DEFUN_NEW("OPEN-INT",object,fSopen_int,SI,8,8,NONE,OO,OO,OO,OO, (object fn,object direction,object element_type,object if_exists, object iesp,object if_does_not_exist,object idnesp, object external_format),"") { enum smmode smm=0; vs_mark; object strm,filename; filename=fn; if (direction == sKinput) { smm = smm_input; if (idnesp==Cnil) if_does_not_exist = sKerror; } else if (direction == sKoutput) { smm = smm_output; if (iesp==Cnil) if_exists = sKnew_version; if (idnesp==Cnil) { if (if_exists == sKoverwrite || if_exists == sKappend) if_does_not_exist = sKerror; else if_does_not_exist = sKcreate; } } else if (direction == sKio) { smm = smm_io; if (iesp==Cnil) if_exists = sKnew_version; if (idnesp==Cnil) { if (if_exists == sKoverwrite || if_exists == sKappend) if_does_not_exist = sKerror; else if_does_not_exist = sKcreate; } } else if (direction == sKprobe) { smm = smm_probe; if (idnesp==Cnil) if_does_not_exist = Cnil; } else FEerror("~S is an illegal DIRECTION for OPEN.", 1, direction); strm = open_stream(filename, smm, if_exists, if_does_not_exist); if (type_of(strm) == t_stream) { strm->sm.sm_object0 = element_type; strm->sm.sm_object1 = fn; } vs_reset; RETURN1(strm); } DEFUN_NEW("OPEN-STREAM-P",object,fLopen_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") { check_type_stream(&x); return GET_STREAM_FLAG(x,gcl_sm_closed) ? Cnil : Ct; } /* Close_stream(strm) closes stream strm. The abort_flag is not used now. */ static int pipe_designator_p(object x) { if (x==OBJNULL||x==Cnil) return 0; coerce_to_filename(x,FN1); return FN1[0]=='|' ? 1 : 0; } void close_stream(object strm) { if (FFN(fLopen_stream_p)(strm)==Cnil) return; switch (strm->sm.sm_mode) { case smm_output: if (strm->sm.sm_fp == stdout || strm->sm.sm_fp == stderr) FEerror("Cannot close the standard output.", 0); fflush(strm->sm.sm_fp); deallocate_stream_buffer(strm); if (pipe_designator_p(strm->sm.sm_object1)) pclose(strm->sm.sm_fp); else fclose(strm->sm.sm_fp); strm->sm.sm_fp = NULL; strm->sm.sm_fd = -1; break; case smm_socket: if (SOCKET_STREAM_FD(strm) < 2) emsg("tried Closing %d ! as socket \n",SOCKET_STREAM_FD(strm)); else { #ifdef HAVE_NSOCKET if (GET_STREAM_FLAG(strm,gcl_sm_output)) { gclFlushSocket(strm); /* there are two for one fd so close only one */ tcpCloseSocket(SOCKET_STREAM_FD(strm)); } #endif SOCKET_STREAM_FD(strm)=-1; } case smm_input: if (strm->sm.sm_fp == stdin) FEerror("Cannot close the standard input.", 0); case smm_io: case smm_probe: deallocate_stream_buffer(strm); if (pipe_designator_p(strm->sm.sm_object1)) pclose(strm->sm.sm_fp); else fclose(strm->sm.sm_fp); strm->sm.sm_fp = NULL; strm->sm.sm_fd = -1; break; case smm_synonym: break; case smm_broadcast: case smm_concatenated: break; case smm_two_way: case smm_echo: break; case smm_string_input: case smm_string_output: break; default: error("Illegal stream mode"); } SET_STREAM_FLAG(strm,gcl_sm_closed,1); } DEFUN_NEW("INTERACTIVE-STREAM-P",object,fLinteractive_stream_p,LISP,1,1,NONE,OO,OO,OO,OO,(object strm),"") { check_type_stream(&strm); switch (strm->sm.sm_mode) { case smm_output: case smm_input: case smm_io: case smm_probe: if ((strm->sm.sm_fp == stdin) || (strm->sm.sm_fp == stdout) || (strm->sm.sm_fp == stderr)) return Ct; return Cnil; break; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); break; case smm_broadcast: case smm_concatenated: if (( consp(strm->sm.sm_object0) ) && ( type_of(strm->sm.sm_object0->c.c_car) == t_stream )) strm=strm->sm.sm_object0->c.c_car; else return Cnil; break; case smm_two_way: case smm_echo: strm=STREAM_INPUT_STREAM(strm); break; default: return Cnil; } return Cnil; } object make_two_way_stream(istrm, ostrm) object istrm, ostrm; { object strm; strm = alloc_object(t_stream); strm->sm.sm_mode = (short)smm_two_way; strm->sm.sm_fp = NULL; strm->sm.sm_buffer = 0; STREAM_INPUT_STREAM(strm) = istrm; STREAM_OUTPUT_STREAM(strm) = ostrm; strm->sm.sm_int = 0; strm->sm.sm_flags=0; return(strm); } static object make_echo_stream(istrm, ostrm) object istrm, ostrm; { object strm; strm = make_two_way_stream(istrm, ostrm); strm->sm.sm_mode = (short)smm_echo; return(strm); } DEFUN_NEW("MAKE-STRING-INPUT-STREAM-INT",object,fSmake_string_input_stream_int,SI,3,3,NONE,OO,II,OO,OO, (object strng,fixnum istart,fixnum iend),"") { object strm; strm = alloc_object(t_stream); strm->sm.sm_mode = (short)smm_string_input; strm->sm.sm_fp = NULL; strm->sm.sm_buffer = 0; STRING_STREAM_STRING(strm) = strng; strm->sm.sm_object1 = OBJNULL; STRING_INPUT_STREAM_NEXT(strm)= istart; STRING_INPUT_STREAM_END(strm)= iend; strm->sm.sm_flags=0; RETURN1(strm); } #ifdef STATIC_FUNCTION_POINTERS object fSmake_string_input_stream_int(object x,fixnum y,fixnum z) { return FFN(fSmake_string_input_stream_int)(x,y,z); } #endif DEFUN_NEW("STRING-INPUT-STREAM-P",object,fSstring_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_input ? Ct : Cnil; } DEFUN_NEW("STRING-OUTPUT-STREAM-P",object,fSstring_output_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_output ? Ct : Cnil; } object make_string_output_stream(line_length) int line_length; { object strng, strm; vs_mark; strng = alloc_object(t_string); strng->st.st_hasfillp = TRUE; strng->st.st_adjustable = TRUE; strng->st.st_displaced = Cnil; strng->st.st_dim = line_length; strng->st.st_fillp = 0; strng->st.st_self = NULL; /* For GBC not to go mad. */ vs_push(strng); /* Saving for GBC. */ strng->st.st_self = alloc_relblock(line_length); strm = alloc_object(t_stream); strm->sm.sm_mode = (short)smm_string_output; strm->sm.sm_fp = NULL; strm->sm.sm_buffer = 0; STRING_STREAM_STRING(strm) = strng; strm->sm.sm_object1 = OBJNULL; strm->sm.sm_int = 0; strm->sm.sm_flags=0; vs_reset; return(strm); } static object get_output_stream_string(strm) object strm; { object strng; strng = copy_simple_string(STRING_STREAM_STRING(strm)); STRING_STREAM_STRING(strm)->st.st_fillp = 0; return(strng); } static void cannot_read(object); static void closed_stream(object); int readc_stream(strm) object strm; { int c; BEGIN: switch (strm->sm.sm_mode) { #ifdef HAVE_NSOCKET case smm_socket: return (getCharGclSocket(strm,Ct)); #endif case smm_input: case smm_io: if (strm->sm.sm_fp == NULL) closed_stream(strm); #if (1) c = kclgetc(strm->sm.sm_fp); #else c = getOneChar(strm->sm.sm_fp); #endif /* if (c == EOF) { */ /* if (xkclfeof(c,strm->sm.sm_fp)) */ /* end_of_stream(strm); */ /* else c = getOneChar(strm->sm.sm_fp); */ /* if (c == EOF) end_of_stream(strm); */ /* } */ /* c &= 0377; */ /* strm->sm.sm_int0++; */ return(c==EOF ? c : (c&0377)); case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_concatenated: CONCATENATED: if (endp(strm->sm.sm_object0)) { end_of_stream(strm); } if (stream_at_end(strm->sm.sm_object0->c.c_car)) { strm->sm.sm_object0 = strm->sm.sm_object0->c.c_cdr; goto CONCATENATED; } c = readc_stream(strm->sm.sm_object0->c.c_car); return(c); case smm_two_way: #ifdef UNIX if (strm == terminal_io) flush_stream(STREAM_OUTPUT_STREAM(terminal_io)); #endif /* strm->sm.sm_int1 = 0; */ strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_echo: c = readc_stream(STREAM_INPUT_STREAM(strm)); if (ECHO_STREAM_N_UNREAD(strm) == 0) writec_stream(c, STREAM_OUTPUT_STREAM(strm)); else --(ECHO_STREAM_N_UNREAD(strm)); return(c); case smm_string_input: if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm)) end_of_stream(strm); return(STRING_STREAM_STRING(strm)->st.st_self [STRING_INPUT_STREAM_NEXT(strm)++]); case smm_output: case smm_probe: case smm_broadcast: case smm_string_output: cannot_read(strm); #ifdef USER_DEFINED_STREAMS case smm_user_defined: #define STM_DATA_STRUCT 0 #define STM_READ_CHAR 1 #define STM_WRITE_CHAR 2 #define STM_UNREAD_CHAR 7 #define STM_FORCE_OUTPUT 4 #define STM_PEEK_CHAR 3 #define STM_CLOSE 5 #define STM_TYPE 6 #define STM_NAME 8 {object val; object *old_vs_base = vs_base; object *old_vs_top = vs_top; vs_base = vs_top; vs_push(strm); super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]); val = vs_base[0]; vs_base = old_vs_base; vs_top = old_vs_top; if (type_of(val) == t_fixnum) return (fix(val)); if (type_of(val) == t_character) return (char_code(val)); } #endif default: error("illegal stream mode"); return(0); } } int rl_ungetc_em(int, FILE *); void unreadc_stream(int c, object strm) { BEGIN: switch (strm->sm.sm_mode) { case smm_socket: #ifdef HAVE_NSOCKET ungetCharGclSocket(c,strm); return; #endif case smm_input: case smm_io: if (strm->sm.sm_fp == NULL) closed_stream(strm); kclungetc(c, strm->sm.sm_fp); /* --strm->sm.sm_int0; */ /* use ftell now for position */ break; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_concatenated: if (endp(strm->sm.sm_object0)) goto UNREAD_ERROR; strm = strm->sm.sm_object0->c.c_car; goto BEGIN; case smm_two_way: strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_echo: unreadc_stream(c, STREAM_INPUT_STREAM(strm)); ECHO_STREAM_N_UNREAD(strm)++; break; case smm_string_input: if (STRING_INPUT_STREAM_NEXT(strm)<= 0) goto UNREAD_ERROR; --STRING_INPUT_STREAM_NEXT(strm); break; case smm_output: case smm_probe: case smm_broadcast: case smm_string_output: goto UNREAD_ERROR; #ifdef USER_DEFINED_STREAMS case smm_user_defined: {object *old_vs_base = vs_base; object *old_vs_top = vs_top; vs_base = vs_top; vs_push(strm); /* if there is a file pointer and no define unget function, * then call ungetc */ if ((strm->sm.sm_fp != NULL ) && strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil) kclungetc(c, strm->sm.sm_fp); else super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]); vs_top = old_vs_top; vs_base = old_vs_base; } break; #endif default: error("illegal stream mode"); } return; UNREAD_ERROR: FEerror("Cannot unread the stream ~S.", 1, strm); } static void putCharGclSocket(object,int); int rl_putc_em(int, FILE *); static void cannot_write(object); int writec_stream(int c, object strm) { object x; char *p; int i; BEGIN: switch (strm->sm.sm_mode) { case smm_output: case smm_io: case smm_socket: /* strm->sm.sm_int0++; */ if (c == '\n') STREAM_FILE_COLUMN(strm) = 0; else if (c == '\t') STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8; else STREAM_FILE_COLUMN(strm)++; if (strm->sm.sm_fp == NULL) { #ifdef HAVE_NSOCKET if (strm->sm.sm_mode == smm_socket && strm->sm.sm_fd>=0) putCharGclSocket(strm,c); else #endif if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) closed_stream(strm); } else { kclputc(c, strm->sm.sm_fp); } break; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_broadcast: for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) writec_stream(c, x->c.c_car); break; case smm_two_way: /* this should be on the actual streams strm->sm.sm_int0++; if (c == '\n') strm->sm.sm_int1 = 0; else if (c == '\t') strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8; else strm->sm.sm_int1++; */ strm = STREAM_OUTPUT_STREAM(strm); goto BEGIN; case smm_echo: strm = STREAM_OUTPUT_STREAM(strm); goto BEGIN; case smm_string_output: /* strm->sm.sm_int0++; */ if (c == '\n') STREAM_FILE_COLUMN(strm) = 0; else if (c == '\t') STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8; else STREAM_FILE_COLUMN(strm)++; x = STRING_STREAM_STRING(strm); if (x->st.st_fillp >= x->st.st_dim) { if (!x->st.st_adjustable) FEerror("The string ~S is not adjustable.", 1, x); p = (inheap((long)x->st.st_self) ? alloc_contblock : alloc_relblock) (x->st.st_dim * 2 + 16); for (i = 0; i < x->st.st_dim; i++) p[i] = x->st.st_self[i]; i = x->st.st_dim * 2 + 16; #define ADIMLIM 16*1024*1024 if (i >= ADIMLIM) FEerror("Can't extend the string.", 0); x->st.st_dim = i; adjust_displaced(x, p - x->st.st_self); } x->st.st_self[x->st.st_fillp++] = c; break; case smm_input: case smm_probe: case smm_concatenated: case smm_string_input: cannot_write(strm); #ifdef USER_DEFINED_STREAMS case smm_user_defined: {object *old_vs_base = vs_base; object *old_vs_top = vs_top; vs_base = vs_top; vs_push(strm); vs_push(code_char(c)); super_funcall(strm->sm.sm_object1->str.str_self[2]); vs_base = old_vs_base; vs_top = old_vs_top; break; } #endif default: error("illegal stream mode"); } return(c); } void writestr_stream(s, strm) char *s; object strm; { while (*s != '\0') writec_stream(*s++, strm); } void flush_stream(object strm) { object x; BEGIN: switch (strm->sm.sm_mode) { case smm_output: case smm_io: if (strm->sm.sm_fp == NULL) closed_stream(strm); fflush(strm->sm.sm_fp); break; case smm_socket: #ifdef HAVE_NSOCKET if (SOCKET_STREAM_FD(strm) >0) gclFlushSocket(strm); else #endif closed_stream(strm); break; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_broadcast: for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) flush_stream(x->c.c_car); break; case smm_echo: case smm_two_way: strm = STREAM_OUTPUT_STREAM(strm); goto BEGIN; case smm_string_output: break; case smm_input: case smm_probe: case smm_concatenated: case smm_string_input: FEerror("Cannot flush the stream ~S.", 1, strm); #ifdef USER_DEFINED_STREAMS case smm_user_defined: {object *old_vs_base = vs_base; object *old_vs_top = vs_top; vs_base = vs_top; vs_push(strm); super_funcall(strm->sm.sm_object1->str.str_self[4]); vs_base = old_vs_base; vs_top = old_vs_top; break; } #endif default: error("illegal stream mode"); } } bool stream_at_end(object strm) { #define NON_CHAR -1000 VOL int c = NON_CHAR; BEGIN: switch (strm->sm.sm_mode) { case smm_socket: listen_stream(strm); if (SOCKET_STREAM_FD(strm)>=0) return(FALSE); else return(TRUE); case smm_io: case smm_input: if (strm->sm.sm_fp == NULL) closed_stream(strm); if (isatty(fileno((FILE *)strm->sm.sm_fp)) && !listen_stream(strm)) return(feof(strm->sm.sm_fp) ? TRUE : FALSE); {int prev_signals_allowed = signals_allowed; AGAIN: signals_allowed= sig_at_read; c = kclgetc(strm->sm.sm_fp); /* blocking getchar for sockets */ /* if (c==EOF && (strm)->sm.sm_mode ==smm_socket) c = getOneChar(strm->sm.sm_fp); */ if (c == NON_CHAR) goto AGAIN; signals_allowed=prev_signals_allowed;} if (xkclfeof(c,strm->sm.sm_fp)) return(TRUE); else { if (c>=0) kclungetc(c, strm->sm.sm_fp); return(FALSE); } case smm_output: return(FALSE); case smm_probe: return(FALSE); case smm_synonym: strm = symbol_value(strm->sm.sm_object0); check_stream(strm); goto BEGIN; case smm_broadcast: return(FALSE); case smm_concatenated: CONCATENATED: if (endp(strm->sm.sm_object0)) return(TRUE); if (stream_at_end(strm->sm.sm_object0->c.c_car)) { strm->sm.sm_object0 = strm->sm.sm_object0->c.c_cdr; goto CONCATENATED; } else return(FALSE); case smm_two_way: #ifdef UNIX if (strm == terminal_io) /**/ flush_stream(terminal_io->sm.sm_object1); /**/ #endif strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_echo: strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_string_input: if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm)) return(TRUE); else return(FALSE); case smm_string_output: return(FALSE); #ifdef USER_DEFINED_STREAMS case smm_user_defined: return(FALSE); #endif default: error("illegal stream mode"); return(FALSE); } } #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef LISTEN_USE_FCNTL #include #endif bool listen_stream(object strm) { BEGIN: switch (strm->sm.sm_mode) { #ifdef HAVE_NSOCKET case smm_socket: if (SOCKET_STREAM_BUFFER(strm)->ust.ust_fillp>0) return TRUE; /* { */ /* fd_set fds; */ /* struct timeval tv; */ /* FD_ZERO(&fds); */ /* FD_SET(SOCKET_STREAM_FD(strm),&fds); */ /* memset(&tv,0,sizeof(tv)); */ /* return select(SOCKET_STREAM_FD(strm)+1,&fds,NULL,NULL,&tv)>0 ? TRUE : FALSE; */ /* } */ { int ch = getCharGclSocket(strm,Cnil); if (ch == EOF) return FALSE; else unreadc_stream(ch,strm); return TRUE; } #endif case smm_input: case smm_io: #ifdef USE_READLINE if (rl_stream_p(strm->sm.sm_fp)) return rl_pending_buffered_input_p(strm->sm.sm_fp); #endif if (strm->sm.sm_fp == NULL) closed_stream(strm); if (feof(strm->sm.sm_fp)) return(FALSE); #ifdef LISTEN_FOR_INPUT LISTEN_FOR_INPUT(strm->sm.sm_fp); #else #ifdef LISTEN_USE_FCNTL do { int c = 0; FILE *fp = strm->sm.sm_fp; int orig; int res; if (feof(fp)) return TRUE; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK ) ) { res=fcntl(fileno(fp),F_SETFL,orig | O_NONBLOCK); } c = getc(fp); if (! (orig & O_NONBLOCK ) ){ fcntl(fileno(fp),F_SETFL,orig ); } if (c != EOF) { ungetc(c,fp); return TRUE; } return FALSE; } while (0); #endif #endif return TRUE; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_concatenated: if (endp(strm->sm.sm_object0)) return(FALSE); strm = strm->sm.sm_object0->c.c_car; /* Incomplete! */ goto BEGIN; case smm_two_way: case smm_echo: strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_string_input: if (STRING_INPUT_STREAM_NEXT(strm)< STRING_INPUT_STREAM_END(strm)) return(TRUE); else return(FALSE); case smm_output: case smm_probe: case smm_broadcast: case smm_string_output: FEerror("Can't listen to ~S.", 1, strm); return(FALSE); default: error("illegal stream mode"); return(FALSE); } } int file_column(object strm) { int i; object x; BEGIN: switch (strm->sm.sm_mode) { case smm_output: case smm_io: case smm_socket: case smm_string_output: return(STREAM_FILE_COLUMN(strm)); case smm_echo: case smm_two_way: strm=STREAM_OUTPUT_STREAM(strm); goto BEGIN; case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_input: case smm_probe: case smm_string_input: return(-1); case smm_concatenated: if (endp(strm->sm.sm_object0)) return(-1); strm = strm->sm.sm_object0->c.c_car; goto BEGIN; case smm_broadcast: for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) { i = file_column(x->c.c_car); if (i >= 0) return(i); } return(-1); #ifdef USER_DEFINED_STREAMS case smm_user_defined: /* not right but what is? */ return(-1); #endif default: error("illegal stream mode"); return(-1); } } void load(const char *s) { object filename, strm, x; vs_mark; if (user_match(s,strlen(s))) return; filename = make_simple_string(s); vs_push(filename); strm = open_stream(filename, smm_input, Cnil, sKerror); vs_push(strm); for (;;) { preserving_whitespace_flag = FALSE; detect_eos_flag = TRUE; x = read_object_non_recursive(strm); if (x == OBJNULL) break; vs_push(x); ieval(x); vs_popp; } close_stream(strm); vs_reset; } LFD(Lmake_synonym_stream)() { object x; check_arg(1); check_type_sym(&vs_base[0]); x = alloc_object(t_stream); x->sm.sm_mode = (short)smm_synonym; x->sm.sm_fp = NULL; x->sm.sm_buffer = 0; x->sm.sm_object0 = vs_base[0]; x->sm.sm_object1 = OBJNULL; x->sm.sm_int = 0; x->sm.sm_flags=0; vs_base[0] = x; } LFD(Lmake_broadcast_stream)() { object x; int narg, i; narg = vs_top - vs_base; for (i = 0; i < narg; i++) if (type_of(vs_base[i]) != t_stream || !output_stream_p(vs_base[i])) cannot_write(vs_base[i]); Llist(); x = alloc_object(t_stream); x->sm.sm_mode = (short)smm_broadcast; x->sm.sm_fp = NULL; x->sm.sm_buffer = 0; x->sm.sm_object0 = vs_base[0]; x->sm.sm_object1 = OBJNULL; x->sm.sm_int = 0; x->sm.sm_flags=0; vs_base[0] = x; } LFD(Lmake_concatenated_stream)() { object x; int narg, i; narg = vs_top - vs_base; for (i = 0; i < narg; i++) if (type_of(vs_base[i]) != t_stream || !input_stream_p(vs_base[i])) cannot_read(vs_base[i]); Llist(); x = alloc_object(t_stream); x->sm.sm_mode = (short)smm_concatenated; x->sm.sm_fp = NULL; x->sm.sm_buffer = 0; x->sm.sm_object0 = vs_base[0]; x->sm.sm_object1 = OBJNULL; x->sm.sm_int = 0; x->sm.sm_flags=0; vs_base[0] = x; } LFD(Lmake_two_way_stream)() { check_arg(2); if (type_of(vs_base[0]) != t_stream || !input_stream_p(vs_base[0])) cannot_read(vs_base[0]); if (type_of(vs_base[1]) != t_stream || !output_stream_p(vs_base[1])) cannot_write(vs_base[1]); vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]); vs_popp; } LFD(Lmake_echo_stream)() { check_arg(2); if (type_of(vs_base[0]) != t_stream || !input_stream_p(vs_base[0])) cannot_read(vs_base[0]); if (type_of(vs_base[1]) != t_stream || !output_stream_p(vs_base[1])) cannot_write(vs_base[1]); vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]); vs_popp; } @(static defun make_string_output_stream (&k element_type) @ element_type=Cnil;/*FIXME*/ @(return `make_string_output_stream(64)`) @) LFD(Lget_output_stream_string)() { check_arg(1); if (type_of(vs_base[0]) != t_stream || (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) FEerror("~S is not a string-output stream.", 1, vs_base[0]); vs_base[0] = get_output_stream_string(vs_base[0]); } /* (SI:OUTPUT-STREAM-STRING string-output-stream) extracts the string associated with the given string-output-stream. */ LFD(siLoutput_stream_string)() { check_arg(1); if (type_of(vs_base[0]) != t_stream || (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) FEerror("~S is not a string-output stream.", 1, vs_base[0]); vs_base[0] = vs_base[0]->sm.sm_object0; } object file_stream(object x) { if (type_of(x)==t_stream) switch(x->sm.sm_mode) { case smm_input: case smm_output: case smm_io: case smm_probe: return x; case smm_synonym: return file_stream(x->sm.sm_object0->s.s_dbind); default: break; } return Cnil; } DEFUN_NEW("FILE-STREAM-P",object,fSfile_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(file_stream(x)!=Cnil ? Ct : Cnil); } DEFUN_NEW("SYNONYM-STREAM-P",object,fSsynonym_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_synonym ? Ct : Cnil); } DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil); } DEFUN_NEW("BROADCAST-STREAM-P",object,fSbroadcast_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_broadcast ? Ct : Cnil); } DEFUN_NEW("ECHO-STREAM-P",object,fSecho_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_echo ? Ct : Cnil); } DEFUN_NEW("TWO-WAY-STREAM-P",object,fStwo_way_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_two_way ? Ct : Cnil); } DEFUN_NEW("CONCATENATED-STREAM-P",object,fSconcatenated_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_concatenated ? Ct : Cnil); } LFD(Lstreamp)() { check_arg(1); if (type_of(vs_base[0]) == t_stream) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Linput_stream_p)() { check_arg(1); check_type_stream(&vs_base[0]); if (input_stream_p(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Loutput_stream_p)() { check_arg(1); check_type_stream(&vs_base[0]); if (output_stream_p(vs_base[0])) vs_base[0] = Ct; else vs_base[0] = Cnil; } LFD(Lstream_element_type)() { check_arg(1); check_type_stream(&vs_base[0]); vs_base[0] = stream_element_type(vs_base[0]); } @(defun close (strm &key abort) @ check_type_stream(&strm); close_stream(strm); @(return Ct) @) object sLAload_pathnameA; DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,""); DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,""); DEFUN_NEW("LOAD-STREAM",object,fSload_stream,SI,2,2,NONE,OO,OO,OO,OO,(object strm,object print),"") { object x; for (;;) { preserving_whitespace_flag = FALSE; detect_eos_flag = TRUE; if ((x = READ_STREAM_OR_FASD(strm))==OBJNULL) break; { object *base = vs_base, *top = vs_top, *lex = lex_env; object xx; lex_new(); eval(x); xx = vs_base[0]; lex_env = lex; vs_top = top; vs_base = base; x = xx; } if (print != Cnil) { SETUP_PRINT_DEFAULT(x); write_object(x, 0); write_str("\n"); CLEANUP_PRINT_DEFAULT; flush_stream(PRINTstream); } } RETURN1(Ct); } #ifdef STATIC_FUNCTION_POINTERS object fSload_stream(object strm,object print) { return FFN(fSload_stream)(strm,print); } #endif DEFUN_NEW("LOAD-FASL",object,fSload_fasl,SI,2,2,NONE,OO,OO,OO,OO,(object fasl_filename,object print),"") { int i; if (sSAcollect_binary_modulesA->s.s_dbind==Ct) { object _x=sSAbinary_modulesA->s.s_dbind; object _y=Cnil; while (_x!=Cnil) { _y=_x; _x=_x->c.c_cdr; } if (_y==Cnil) sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil); else _y->c.c_cdr=make_cons(fasl_filename,Cnil); } i = fasload(fasl_filename); if (print != Cnil) { SETUP_PRINT_DEFAULT(Cnil); vs_top = PRINTvs_top; if (file_column(PRINTstream) != 0) write_str("\n"); write_str(";; Fasload successfully ended."); write_str("\n"); CLEANUP_PRINT_DEFAULT; flush_stream(PRINTstream); } RETURN1(make_fixnum(i)); } LFD(siLmake_string_output_stream_from_string)() { object strng, strm; check_arg(1); strng = vs_base[0]; if (type_of(strng) != t_string || !strng->st.st_hasfillp) FEerror("~S is not a string with a fill-pointer.", 1, strng); strm = alloc_object(t_stream); strm->sm.sm_mode = (short)smm_string_output; strm->sm.sm_fp = NULL; strm->sm.sm_buffer = 0; STRING_STREAM_STRING(strm) = strng; strm->sm.sm_object1 = OBJNULL; /* strm->sm.sm_int0 = strng->st.st_fillp; */ STREAM_FILE_COLUMN(strm) = 0; strm->sm.sm_flags=0; vs_base[0] = strm; } LFD(siLcopy_stream)() { object in, out; check_arg(2); check_type_stream(&vs_base[0]); check_type_stream(&vs_base[1]); in = vs_base[0]; out = vs_base[1]; while (!stream_at_end(in)) writec_stream(readc_stream(in), out); flush_stream(out); vs_base[0] = Ct; vs_popp; #ifdef AOSVS #endif } /* static void */ /* too_long_file_name(fn) */ /* object fn; */ /* { */ /* FEerror("~S is a too long file name.", 1, fn); */ /* } */ static void cannot_open(fn) object fn; { FILE_ERROR(fn,"Cannot open"); } static void cannot_create(fn) object fn; { FILE_ERROR(fn,"Cannot create"); } static void cannot_read(strm) object strm; { FEerror("Cannot read the stream ~S.", 1, strm); } static void cannot_write(strm) object strm; { FEerror("Cannot write to the stream ~S.", 1, strm); } #ifdef USER_DEFINED_STREAMS /* more support for user defined streams */ static void FFN(siLuser_stream_state)() { check_arg(1); if(vs_base[0]->sm.sm_object1) vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0]; else FEerror("sLtream data NULL ~S", 1, vs_base[0]); } #endif static void closed_stream(strm) object strm; { if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) { SET_STREAM_FLAG(strm,gcl_sm_had_error,1); FEerror("The stream ~S is already closed.", 1, strm); } } /* returns a stream with which one can safely do fwrite to the x->sm.sm_fp or nil. */ /* coerce stream to one so that x->sm.sm_fp is suitable for fread and fwrite, Return nil if this is not possible. */ object coerce_stream(strm,out) object strm; int out; { BEGIN: if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); switch (strm->sm.sm_mode){ case smm_synonym: strm = symbol_value(strm->sm.sm_object0); if (type_of(strm) != t_stream) FEwrong_type_argument(sLstream, strm); goto BEGIN; case smm_two_way: case smm_echo: if (out)strm = STREAM_OUTPUT_STREAM(strm); else strm = STREAM_INPUT_STREAM(strm); goto BEGIN; case smm_output: if (!out) cannot_read(strm); break; case smm_input: if (out) cannot_write(strm); break; case smm_io: /* case smm_socket: */ break; default: strm=Cnil; } if (strm!=Cnil && (strm->sm.sm_fp == NULL)) closed_stream(strm); return(strm); } static void FFN(siLfp_output_stream)() {check_arg(1); vs_base[0]=coerce_stream(vs_base[0],1); } static void FFN(siLfp_input_stream)() {check_arg(1); vs_base[0]=coerce_stream(vs_base[0],0); } @(static defun fwrite (vector start count stream) unsigned char *p; int n,beg; @ stream=coerce_stream(stream,1); if (stream==Cnil) @(return Cnil); p = vector->ust.ust_self; beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg)); if (fwrite(p+beg,1,n,stream->sm.sm_fp)) @(return Ct); @(return Cnil); @) @(static defun fread (vector start count stream) char *p; int n,beg; @ stream=coerce_stream(stream,0); if (stream==Cnil) @(return Cnil); p = vector->st.st_self; beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg)); if ((n=SAFE_FREAD(p+beg,1,n,stream->sm.sm_fp))) @(return `make_fixnum(n)`); @(return Cnil); @) #ifdef HAVE_NSOCKET #ifdef DODEBUG #define dprintf(s,arg) emsg(s,arg) #else #define dprintf(s,arg) #endif /* putCharGclSocket(strm,ch) -- put one character to a socket stream. Results: Side Effects: The buffer may be filled, and the fill pointer of the buffer may be changed. */ static void putCharGclSocket(strm,ch) object strm; int ch; { object bufp = SOCKET_STREAM_BUFFER(strm); AGAIN: if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=ch; return; } else { gclFlushSocket(strm); goto AGAIN; } } static void gclFlushSocket(strm) object strm; { int fd = SOCKET_STREAM_FD(strm); object bufp = SOCKET_STREAM_BUFFER(strm); int i=0; int err; int wrote; if (!GET_STREAM_FLAG(strm,gcl_sm_output) || GET_STREAM_FLAG(strm,gcl_sm_had_error)) return; #define AMT_TO_WRITE 500 while(i< bufp->ust.ust_fillp) { wrote =TcpOutputProc ( fd, &(bufp->st.st_self[i]), bufp->ust.ust_fillp-i > AMT_TO_WRITE ? AMT_TO_WRITE : bufp->ust.ust_fillp-i, &err #ifdef __MINGW32__ , TRUE /* Wild guess as to whether it should block or not */ #endif ); if (wrote < 0) { SET_STREAM_FLAG(strm,gcl_sm_had_error,1); close_stream(strm); FEerror("error writing to socket: errno= ~a",1,make_fixnum(err)); } i+= wrote; } bufp->ust.ust_fillp=0; } static object make_socket_stream(fd,mode,server,host,port,async) int fd; enum gcl_sm_flags mode; object server; object host; object port; object async; { object x; if (fd < 0 ) { FEerror("Could not connect",0); } x = alloc_object(t_stream); x->sm.sm_mode = smm_socket; x->sm.sm_buffer = 0; x->sm.sm_object0 = list(3,server,host,port); x->sm.sm_object1 = 0; x->sm.sm_int = 0; x->sm.sm_flags=0; SOCKET_STREAM_FD(x)= fd; SET_STREAM_FLAG(x,mode,1); SET_STREAM_FLAG(x,gcl_sm_tcp_async,(async!=Cnil)); /* if (mode == gcl_sm_output) { fp=fdopen(fd,(mode==gcl_sm_input ? "r" : "w")); if (fp==NULL) FEerror("Could not connect",0); x->sm.sm_fp = fp; setup_stream_buffer(x); } else */ { object buffer; x->sm.sm_fp = NULL; buffer=alloc_simple_string((BUFSIZ < 4096 ? 4096 : BUFSIZ)); SOCKET_STREAM_BUFFER(x) =buffer; buffer->ust.ust_self = alloc_contblock(buffer->st.st_dim); buffer->ust.ust_fillp = 0; } return x; } static object maccept(object x) { int fd; socklen_t n; struct sockaddr_in addr; object server,host,port; if (type_of(x) != t_stream) FEerror("~S is not a steam~%",1,x); if (x->sm.sm_mode!=smm_two_way) FEerror("~S is not a two-way steam~%",1,x); fd=accept(SOCKET_STREAM_FD(STREAM_INPUT_STREAM(x)),(struct sockaddr *)&addr,&n); if (fd <0) { FEerror("Error ~S on accepting connection to ~S~%",2,make_simple_string(strerror(errno)),x); x=Cnil; } else { server=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_car; host=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_car; port=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_cdr->c.c_car; x = make_two_way_stream (make_socket_stream(fd,gcl_sm_input,server,host,port,Cnil), make_socket_stream(fd,gcl_sm_output,server,host,port,Cnil)); } return x; } #ifdef BSD #include #include #include #if defined(DARWIN) #define on_exit(a,b) #else static void rmc(int e,void *pid) { kill((long)pid,SIGTERM); } #endif #endif @(static defun socket (port &key host server async myaddr myport daemon) /* HOST is a string then connection is made to that ip or domain address. SERVER A function to call if this is to be a server ASYNC socket returned immideiately. read or flush will block till open if in non blocking mode MYADDR client's ip address. Useful if have several net interfaces MYPORT port to use on client side */ int fd; int isServer = 0; int inPort; char buf1[500]; char buf2[500]; char *myaddrPtr=buf1,*hostPtr=buf2; object x=Cnil; @ if (type_of(host) == t_string) { hostPtr=lisp_copy_to_null_terminated(host,hostPtr,sizeof(buf1)); } else { hostPtr = NULL; } if (fLfunctionp(server) == Ct) { isServer=1; } if (myaddr != Cnil) { myaddrPtr=lisp_copy_to_null_terminated(myaddr,myaddrPtr,sizeof(buf2)); } else { myaddrPtr = NULL; } if (isServer == 0 && hostPtr == NULL) { FEerror("You must supply at least one of :host hostname or :server function",0); } Iis_fixnum(port); inPort = (myport == Cnil ? 0 : fix(Iis_fixnum(myport))); #ifdef BSD if (isServer && daemon != Cnil) { long pid,i; struct rlimit r; struct sigaction sa,osa; sa.sa_handler=SIG_IGN; sa.sa_flags=SA_NOCLDWAIT; sigemptyset(&sa.sa_mask); massert(!sigaction(SIGCHLD,&sa,&osa)); switch((pid=pvfork())) { case -1: FEerror("Cannot fork", 0); break; case 0: massert(setsid()>=0); if (daemon == sKpersistent) switch(pvfork()) { case -1: FEerror("daemon fork error", 0); break; case 0: break; default: exit(0); break; } massert(!chdir("/")); memset(&r,0,sizeof(r)); massert(!getrlimit(RLIMIT_NOFILE,&r)); for (i=0;i=0); massert((i=dup(i))>=0); massert((i=dup(i))>=0); umask(0); fd = CreateSocket(fix(port),hostPtr,isServer,myaddrPtr,inPort,(async!=Cnil)); x = make_two_way_stream (make_socket_stream(fd,gcl_sm_input,server,host,port,async), make_socket_stream(fd,gcl_sm_output,server,host,port,async)); for (;;) { fd_set fds; object y; FD_ZERO(&fds); FD_SET(fd,&fds); if (select(fd+1,&fds,NULL,NULL,NULL)>0) { y=maccept(x); switch((pid=pvfork())) { case 0: massert(!sigaction(SIGCHLD,&osa,NULL)); ifuncall1(server,y); exit(0); break; case -1: do_gcl_abort(); break; default: close_stream(y); break; } } } break; default: if (daemon != sKpersistent) { on_exit(rmc,(void *)pid); x=make_fixnum(pid); } else x=Cnil; break; } massert(!sigaction(SIGCHLD,&osa,NULL)); } else #endif { fd = CreateSocket(fix(port),hostPtr,isServer,myaddrPtr,inPort,(async!=Cnil)); x = make_two_way_stream (make_socket_stream(fd,gcl_sm_input,server,host,port,async), make_socket_stream(fd,gcl_sm_output,server,host,port,async)); } @(return `x`); @) DEF_ORDINARY("MYADDR",sKmyaddr,KEYWORD,""); DEF_ORDINARY("MYPORT",sKmyport,KEYWORD,""); DEF_ORDINARY("ASYNC",sKasync,KEYWORD,""); DEF_ORDINARY("HOST",sKhost,KEYWORD,""); DEF_ORDINARY("SERVER",sKserver,KEYWORD,""); DEF_ORDINARY("DAEMON",sKdaemon,KEYWORD,""); DEF_ORDINARY("PERSISTENT",sKpersistent,KEYWORD,""); DEF_ORDINARY("SOCKET",sSsocket,SI,""); @(static defun accept (x) @ x=maccept(x); @(return `x`); @) #endif /* HAVE_NSOCKET */ object standard_io; object standard_error; DEFVAR("*STANDARD-INPUT*",sLAstandard_inputA,LISP,(gcl_init_file(),standard_io),""); DEFVAR("*STANDARD-OUTPUT*",sLAstandard_outputA,LISP,standard_io,""); DEFVAR("*ERROR-OUTPUT*",sLAerror_outputA,LISP,standard_error,""); DEFVAR("*TERMINAL-IO*",sLAterminal_ioA,LISP,terminal_io,""); DEFVAR("*QUERY-IO*",sLAquery_ioA,LISP, (standard_io->sm.sm_object0 = sLAterminal_ioA, standard_io),""); DEFVAR("*DEBUG-IO*",sLAdebug_ioA,LISP,standard_io,""); DEFVAR("*TRACE-OUTPUT*",sLAtrace_outputA,LISP,standard_io,""); void gcl_init_file(void) { object standard_input; object standard_output; object standard; object x; standard_input = alloc_object(t_stream); standard_input->sm.sm_mode = (short)smm_input; standard_input->sm.sm_fp = stdin; standard_input->sm.sm_buffer = 0; standard_input->sm.sm_object0 = sLcharacter; standard_input->sm.sm_object1 #ifdef UNIX = make_simple_string("stdin"); #endif standard_input->sm.sm_int = 0; /* unused */ standard_input->sm.sm_flags=0; standard_output = alloc_object(t_stream); standard_output->sm.sm_mode = (short)smm_output; standard_output->sm.sm_fp = stdout; standard_output->sm.sm_buffer = 0; standard_output->sm.sm_object0 = sLcharacter; standard_output->sm.sm_object1 #ifdef UNIX = make_simple_string("stdout"); #endif standard_output->sm.sm_int = 0; /* unused */ standard_output->sm.sm_flags=0; standard_error = alloc_object(t_stream); standard_error->sm.sm_mode = (short)smm_output; standard_error->sm.sm_fp = stderr; standard_error->sm.sm_buffer = 0; standard_error->sm.sm_object0 = sLcharacter; standard_error->sm.sm_object1 #ifdef UNIX = make_simple_string("stderr"); #endif standard_error->sm.sm_int = 0; /* unused */ standard_error->sm.sm_flags=0; enter_mark_origin(&standard_error); terminal_io = standard = make_two_way_stream(standard_input, standard_output); enter_mark_origin(&terminal_io); x = alloc_object(t_stream); x->sm.sm_mode = (short)smm_synonym; x->sm.sm_fp = NULL; x->sm.sm_buffer = 0; x->sm.sm_object0 = sLAterminal_ioA; x->sm.sm_object1 = OBJNULL; x->sm.sm_int = 0; /* unused */ x->sm.sm_flags=0; standard_io = x; enter_mark_origin(&standard_io); } DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,""); DEFVAR("*LOAD-PATHNAME*",sLAload_pathnameA,LISP,Cnil,""); DEFVAR("*LOAD-TRUENAME*",sSAload_truenameA,LISP,Cnil,""); DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,""); DEFVAR("*LOAD-PRINT*",sLAload_printA,LISP,Cnil,""); DEF_ORDINARY("ABORT",sKabort,KEYWORD,""); DEF_ORDINARY("APPEND",sKappend,KEYWORD,""); DEF_ORDINARY("CREATE",sKcreate,KEYWORD,""); DEF_ORDINARY("DEFAULT",sKdefault,KEYWORD,""); DEF_ORDINARY("DIRECTION",sKdirection,KEYWORD,""); DEF_ORDINARY("ELEMENT-TYPE",sKelement_type,KEYWORD,""); DEF_ORDINARY("ERROR",sKerror,KEYWORD,""); DEF_ORDINARY("IF-DOES-NOT-EXIST",sKif_does_not_exist,KEYWORD,""); DEF_ORDINARY("IF-EXISTS",sKif_exists,KEYWORD,""); DEF_ORDINARY("INPUT",sKinput,KEYWORD,""); DEF_ORDINARY("IO",sKio,KEYWORD,""); DEF_ORDINARY("NEW-VERSION",sKnew_version,KEYWORD,""); DEF_ORDINARY("OUTPUT",sKoutput,KEYWORD,""); DEF_ORDINARY("OVERWRITE",sKoverwrite,KEYWORD,""); DEF_ORDINARY("PRINT",sKprint,KEYWORD,""); DEF_ORDINARY("PROBE",sKprobe,KEYWORD,""); DEF_ORDINARY("RENAME",sKrename,KEYWORD,""); DEF_ORDINARY("RENAME-AND-DELETE",sKrename_and_delete,KEYWORD,""); DEF_ORDINARY("SET-DEFAULT-PATHNAME",sKset_default_pathname,KEYWORD,""); DEF_ORDINARY("SUPERSEDE",sKsupersede,KEYWORD,""); DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,""); DEF_ORDINARY("DELETE-FILE",sLdelete_file,LISP,""); void gcl_init_file_function() { #ifdef UNIX FASL_string = make_simple_string("o"); make_si_constant("*EOF*",make_fixnum(EOF)); #endif #ifdef AOSVS #endif enter_mark_origin(&FASL_string); #ifdef UNIX LSP_string = make_simple_string("lsp"); #endif #ifdef AOSVS #endif enter_mark_origin(&LSP_string); make_si_function("FP-INPUT-STREAM", siLfp_input_stream); make_si_function("FP-OUTPUT-STREAM", siLfp_output_stream); make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream); make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream); make_function("MAKE-CONCATENATED-STREAM", Lmake_concatenated_stream); make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream); make_function("MAKE-ECHO-STREAM", Lmake_echo_stream); make_function("MAKE-STRING-OUTPUT-STREAM", Lmake_string_output_stream); make_function("GET-OUTPUT-STREAM-STRING", Lget_output_stream_string); make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string); make_si_function("FWRITE",Lfwrite); make_si_function("FREAD",Lfread); #ifdef HAVE_NSOCKET make_si_function("SOCKET",Lsocket); make_si_function("ACCEPT",Laccept); #endif make_function("STREAMP", Lstreamp); make_function("INPUT-STREAM-P", Linput_stream_p); make_function("OUTPUT-STREAM-P", Loutput_stream_p); make_function("STREAM-ELEMENT-TYPE", Lstream_element_type); make_function("CLOSE", Lclose); make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING", siLmake_string_output_stream_from_string); make_si_function("COPY-STREAM", siLcopy_stream); #ifdef USER_DEFINED_STREAMS make_si_function("USER-STREAM-STATE", siLuser_stream_state); #endif #ifdef USE_READLINE gcl_init_readline_function(); #endif } gcl-2.6.14/o/num_rand.c0000755000175000017500000001163114360276512013205 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Random numbers */ #include #include #include "include.h" #include "num_include.h" #ifdef AOSVS #endif static object rando(object x, object rs) { enum type tx; object base,out,z; fixnum fbase; double d; tx = type_of(x); if (number_compare(x, small_fixnum(0)) != 1) FEwrong_type_argument(TSpositive_number, x); if (tx==t_bignum) { out=new_bignum(); base=x; fbase=-1; } else { out=big_fixnum1; fbase=tx==t_fixnum ? fix(x) : MOST_POSITIVE_FIX; mpz_set_si(MP(big_fixnum2),fbase); base=big_fixnum2; } mpz_urandomm(MP(out),&rs->rnd.rnd_state,MP(base)); switch (tx) { case t_fixnum: return make_fixnum(mpz_get_si(MP(out))); case t_bignum: return normalize_big(out); case t_shortfloat: case t_longfloat: d=mpz_get_d(MP(out)); d/=(double)fbase; z=alloc_object(tx); if (tx==t_shortfloat) sf(z)=sf(x)*d; else lf(z)=lf(x)*d; return z; default: FEerror("~S is not an integer nor a floating-point number.", 1, x); return(Cnil); } } #ifdef UNIX #define RS_DEF_INIT time(0) #else #define RS_DEF_INIT 0 #endif #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) extern void * (*gcl_gmp_allocfun) (size_t); static void * (*old_gcl_gmp_allocfun) (size_t); static void * trap_result; static size_t trap_size; static void * trap_gcl_gmp_allocfun(size_t size){ size+=size%MP_LIMB_SIZE; if (trap_size) return old_gcl_gmp_allocfun(size); else { trap_size=size/MP_LIMB_SIZE; trap_result=old_gcl_gmp_allocfun(size); return trap_result; } } #endif void init_gmp_rnd_state(__gmp_randstate_struct *x) { static int n; bzero(x,sizeof(*x)); #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) /* if (!trap_size) { */ old_gcl_gmp_allocfun=gcl_gmp_allocfun; gcl_gmp_allocfun=trap_gcl_gmp_allocfun; /* } */ #endif gmp_randinit_default(x); #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) if (!n) { if (x->_mp_seed->_mp_d!=trap_result) FEerror("Unknown pointer in rnd_state!",0); /* #ifndef __hppa__ /\*FIXME*\/ */ /* if (((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->b!=Mersenne_Twister_Generator_Noseed.b || */ /* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->c!=Mersenne_Twister_Generator_Noseed.c || */ /* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->d!=Mersenne_Twister_Generator_Noseed.d) */ /* FEerror("Unknown pointer data in rnd_state!",0); */ /* #endif */ n=1; } gcl_gmp_allocfun=old_gcl_gmp_allocfun; x->_mp_seed->_mp_alloc=x->_mp_seed->_mp_size=trap_size; #endif } static object make_random_state(object rs) { object z; if (rs==Cnil) rs=symbol_value(Vrandom_state); if (rs!=Ct && type_of(rs) != t_random) { FEwrong_type_argument(sLrandom_state, rs); return(Cnil); } z = alloc_object(t_random); init_gmp_rnd_state(&z->rnd.rnd_state); if (rs == Ct) gmp_randseed_ui(&z->rnd.rnd_state,RS_DEF_INIT); else memcpy(z->rnd.rnd_state._mp_seed->_mp_d,rs->rnd.rnd_state._mp_seed->_mp_d, rs->rnd.rnd_state._mp_seed->_mp_alloc*sizeof(*z->rnd.rnd_state._mp_seed->_mp_d)); #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) z->rnd.rnd_state._mp_algdata._mp_lc=&Mersenne_Twister_Generator_Noseed; #endif return(z); } LFD(Lrandom)(void) { int j; object x; j = vs_top - vs_base; if (j == 1) vs_push(symbol_value(Vrandom_state)); check_arg(2); check_type_random_state(&vs_base[1]); x = rando(vs_base[0], vs_base[1]); vs_top = vs_base; vs_push(x); } LFD(Lmake_random_state)(void) { int j; object x; j = vs_top - vs_base; if (j == 0) vs_push(Cnil); check_arg(1); x = make_random_state(vs_head); vs_top = vs_base; vs_push(x); } LFD(Lrandom_state_p)(void) { check_arg(1); if (type_of(vs_pop) == t_random) vs_push(Ct); else vs_push(Cnil); } void gcl_init_num_rand(void) { Vrandom_state = make_special("*RANDOM-STATE*", make_random_state(Ct)); make_function("RANDOM", Lrandom); make_function("MAKE-RANDOM-STATE", Lmake_random_state); make_function("RANDOM-STATE-P", Lrandom_state_p); } gcl-2.6.14/o/unexelfsgi.c0000755000175000017500000007610714360276512013564 0ustar cammcamm/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. * ELF support added. * * Basic theory: the data space of the running process needs to be * dumped to the output file. Normally we would just enlarge the size * of .data, scooting everything down. But we can't do that in ELF, * because there is often something between the .data space and the * .bss space. * * In the temacs dump below, notice that the Global Offset Table * (.got) and the Dynamic link data (.dynamic) come between .data1 and * .bss. It does not work to overlap .data with these fields. * * The solution is to create a new .data segment. This segment is * filled with data from the current process. Since the contents of * various sections refer to sections by index, the new .data segment * is made the last in the table to avoid changing any existing index. * This is an example of how the section headers are changed. "Addr" * is a process virtual address. "Offset" is a file offset. raid:/nfs/raid/src/dist-18.56/src> dump -h temacs temacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80a98f4 0x608f4 0x449c .bss 0 0 0x4 0 [17] 2 0 0 0x608f4 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x6a484 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x729aa 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x72a3d 0x68b7 .comment 0 0 0x1 0 raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs xemacs: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [17] 2 0 0 0x7d800 0x9b90 .symtab 18 371 0x4 0x10 [18] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [19] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [20] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 [21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 * This is an example of how the file header is changed. "Shoff" is * the section header offset within the file. Since that table is * after the new .data section, it is moved. "Shnum" is the number of * sections, which we increment. * * "Phoff" is the file offset to the program header. "Phentsize" and * "Shentsz" are the program and section header entries sizes respectively. * These can be larger than the apparent struct sizes. raid:/nfs/raid/src/dist-18.56/src> dump -f temacs temacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x792f4 0 0x34 0x20 5 0x28 21 19 raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs xemacs: **** ELF HEADER **** Class Data Type Machine Version Entry Phoff Shoff Flags Ehsize Phentsize Phnum Shentsz Shnum Shstrndx 1 1 2 3 1 0x80499cc 0x34 0x96200 0 0x34 0x20 5 0x28 22 19 * These are the program headers. "Offset" is the file offset to the * segment. "Vaddr" is the memory load address. "Filesz" is the * segment size as it appears in the file, and "Memsz" is the size in * memory. Below, the third segment is the code and the fourth is the * data: the difference between Filesz and Memsz is .bss raid:/nfs/raid/src/dist-18.56/src> dump -o temacs temacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x215c4 0x25a60 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs xemacs: ***** PROGRAM EXECUTION HEADER ***** Type Offset Vaddr Paddr Filesz Memsz Flags Align 6 0x34 0x8048034 0 0xa0 0xa0 5 0 3 0xd4 0 0 0x13 0 4 0 1 0x34 0x8048034 0 0x3f2f9 0x3f2f9 5 0x1000 1 0x3f330 0x8088330 0 0x3e4d0 0x3e4d0 7 0x1000 2 0x60874 0x80a9874 0 0x80 0 7 0 */ /* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. * * The above mechanism does not work if the unexeced ELF file is being * re-layout by other applications (such as `strip'). All the applications * that re-layout the internal of ELF will layout all sections in ascending * order of their file offsets. After the re-layout, the data2 section will * still be the LAST section in the section header vector, but its file offset * is now being pushed far away down, and causes part of it not to be mapped * in (ie. not covered by the load segment entry in PHDR vector), therefore * causes the new binary to fail. * * The solution is to modify the unexec algorithm to insert the new data2 * section header right before the new bss section header, so their file * offsets will be in the ascending order. Since some of the section's (all * sections AFTER the bss section) indexes are now changed, we also need to * modify some fields to make them point to the right sections. This is done * by macro PATCH_INDEX. All the fields that need to be patched are: * * 1. ELF header e_shstrndx field. * 2. section header sh_link and sh_info field. * 3. symbol table entry st_shndx field. * * The above example now should look like: **** SECTION HEADER TABLE **** [No] Type Flags Addr Offset Size Name Link Info Adralgn Entsize [1] 1 2 0x80480d4 0xd4 0x13 .interp 0 0 0x1 0 [2] 5 2 0x80480e8 0xe8 0x388 .hash 3 0 0x4 0x4 [3] 11 2 0x8048470 0x470 0x7f0 .dynsym 4 1 0x4 0x10 [4] 3 2 0x8048c60 0xc60 0x3ad .dynstr 0 0 0x1 0 [5] 9 2 0x8049010 0x1010 0x338 .rel.plt 3 7 0x4 0x8 [6] 1 6 0x8049348 0x1348 0x3 .init 0 0 0x4 0 [7] 1 6 0x804934c 0x134c 0x680 .plt 0 0 0x4 0x4 [8] 1 6 0x80499cc 0x19cc 0x3c56f .text 0 0 0x4 0 [9] 1 6 0x8085f3c 0x3df3c 0x3 .fini 0 0 0x4 0 [10] 1 2 0x8085f40 0x3df40 0x69c .rodata 0 0 0x4 0 [11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 0 0 0x4 0 [12] 1 3 0x8088330 0x3f330 0x20afc .data 0 0 0x4 0 [13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 0 0 0x4 0 [14] 1 3 0x80a96cc 0x606cc 0x1a8 .got 0 0 0x4 0x4 [15] 6 3 0x80a9874 0x60874 0x80 .dynamic 4 0 0x4 0x8 [16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data 0 0 0x4 0 [17] 8 3 0x80c6800 0x7d800 0 .bss 0 0 0x4 0 [18] 2 0 0 0x7d800 0x9b90 .symtab 19 371 0x4 0x10 [19] 3 0 0 0x87390 0x8526 .strtab 0 0 0x1 0 [20] 3 0 0 0x8f8b6 0x93 .shstrtab 0 0 0x1 0 [21] 1 0 0 0x8f949 0x68b7 .comment 0 0 0x1 0 */ #include #include #include #include #include #include #include #include #include #include /* for HDRR declaration */ #include #ifndef emacs #define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) #else fatal() {exit(1);} #endif /* Get the address of a particular section or program header entry, * accounting for the size of the entries. */ #define OLD_SECTION_H(n) \ (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) #define NEW_SECTION_H(n) \ (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) #define OLD_PROGRAM_H(n) \ (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) #define NEW_PROGRAM_H(n) \ (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) #define PATCH_INDEX(n) \ do { \ if ((n) >= old_bss_index) \ (n)++; } while (0) typedef unsigned char byte; /* Round X up to a multiple of Y. */ int round_up (x, y) int x, y; { int rem = x % y; if (rem == 0) return x; return x - rem + y; } /* **************************************************************** * unexec * * driving logic. * * In ELF, this works by replacing the old .bss section with a new * .data section, and inserting an empty .bss immediately afterwards. * */ void unexec (new_name, old_name, data_start, bss_start, entry_address) char *new_name, *old_name; unsigned data_start, bss_start, entry_address; { /* extern unsigned int bss_end; */ int new_file, old_file, new_file_size; /* Pointers to the base of the image of the two files. */ caddr_t old_base, new_base; /* Pointers to the file, program and section headers for the old and new files. */ Elf32_Ehdr *old_file_h, *new_file_h; Elf32_Phdr *old_program_h, *new_program_h; Elf32_Shdr *old_section_h, *new_section_h; /* Point to the section name table in the old file. */ char *old_section_names; Elf32_Addr old_bss_addr, new_bss_addr; Elf32_Word old_bss_size, new_data2_size; Elf32_Off new_data2_offset; Elf32_Addr new_data2_addr; int n, nn, old_bss_index, old_data_index, new_data2_index; int old_mdebug_index; struct stat stat_buf; /* Open the old file & map it into the address space. */ old_file = open (old_name, O_RDONLY); if (old_file < 0) fatal ("Can't open %s for reading: errno %d\n", old_name, errno); if (fstat (old_file, &stat_buf) == -1) fatal ("Can't fstat(%s): errno %d\n", old_name, errno); old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); if (old_base == (caddr_t) -1) fatal ("Can't mmap(%s): errno %d\n", old_name, errno); #ifdef DEBUG fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, old_base); #endif /* Get pointers to headers & section names. */ old_file_h = (Elf32_Ehdr *) old_base; old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); old_section_names = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; /* Find the mdebug section, if any. */ for (old_mdebug_index = 1; old_mdebug_index < old_file_h->e_shnum; old_mdebug_index++) { #ifdef DEBUG fprintf (stderr, "Looking for .mdebug - found %s\n", old_section_names + OLD_SECTION_H(old_mdebug_index).sh_name); #endif if (!strcmp (old_section_names + OLD_SECTION_H(old_mdebug_index).sh_name, ".mdebug")) break; } if (old_mdebug_index == old_file_h->e_shnum) old_mdebug_index = -1; /* just means no such section was present */ /* Find the old .bss section. Figure out parameters of the new data2 and bss sections. */ for (old_bss_index = 1; old_bss_index < old_file_h->e_shnum; old_bss_index++) { #ifdef DEBUG fprintf (stderr, "Looking for .bss - found %s\n", old_section_names + OLD_SECTION_H(old_bss_index).sh_name); #endif if (!strcmp (old_section_names + OLD_SECTION_H(old_bss_index).sh_name, ".bss")) break; } if (old_bss_index == old_file_h->e_shnum) fatal ("Can't find .bss in %s.\n", old_name, 0); old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; #if defined(emacs) || !defined(DEBUG) bss_end = (unsigned int) sbrk (0); new_bss_addr = (Elf32_Addr) bss_end; #else new_bss_addr = old_bss_addr + old_bss_size + 0x1234; #endif new_data2_addr = old_bss_addr; new_data2_size = new_bss_addr - old_bss_addr; new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset; #ifdef DEBUG fprintf (stderr, "old_bss_index %d\n", old_bss_index); fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); fprintf (stderr, "old_bss_size %x\n", old_bss_size); fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); fprintf (stderr, "new_data2_size %x\n", new_data2_size); fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); #endif if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) fatal (".bss shrank when undumping???\n", 0, 0); /* Set the output file to the right size and mmap it. Set pointers to various interesting objects. stat_buf still has old_file data. */ new_file = open (new_name, O_RDWR | O_CREAT, 0666); if (new_file < 0) fatal ("Can't creat (%s): errno %d\n", new_name, errno); new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size; if (ftruncate (new_file, new_file_size)) fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, new_file, 0); if (new_base == (caddr_t) -1) fatal ("Can't mmap (%s): errno %d\n", new_name, errno); new_file_h = (Elf32_Ehdr *) new_base; new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); new_section_h = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff + new_data2_size); /* Make our new file, program and section headers as copies of the originals. */ memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); memcpy (new_program_h, old_program_h, old_file_h->e_phnum * old_file_h->e_phentsize); /* Modify the e_shstrndx if necessary. */ PATCH_INDEX (new_file_h->e_shstrndx); /* Fix up file header. We'll add one section. Section header is further away now. */ new_file_h->e_shoff += new_data2_size; new_file_h->e_shnum += 1; #ifdef DEBUG fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); #endif /* Fix up a new program header. Extend the writable data segment so that the bss area is covered too. Find that segment by looking for a segment that ends just before the .bss area. Make sure that no segments are above the new .data2. Put a loop at the end to adjust the offset and address of any segment that is above data2, just in case we decide to allow this later. */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { /* Compute maximum of all requirements for alignment of section. */ int alignment = (NEW_PROGRAM_H (n)).p_align; if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) alignment = OLD_SECTION_H (old_bss_index).sh_addralign; /* Supposedly this condition is okay for the SGI. */ #if 0 if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) fatal ("Program segment above .bss in %s\n", old_name, 0); #endif if (NEW_PROGRAM_H (n).p_type == PT_LOAD && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + (NEW_PROGRAM_H (n)).p_filesz, alignment) == round_up (old_bss_addr, alignment))) break; } if (n < 0) fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); NEW_PROGRAM_H (n).p_filesz += new_data2_size; NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; #if 1 /* Maybe allow section after data2 - does this ever happen? */ for (n = new_file_h->e_phnum - 1; n >= 0; n--) { if (NEW_PROGRAM_H (n).p_vaddr && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) NEW_PROGRAM_H (n).p_offset += new_data2_size; } #endif /* Fix up section headers based on new .data2 section. Any section whose offset or virtual address is after the new .data2 section gets its value adjusted. .bss size becomes zero and new address is set. data2 section header gets added by copying the existing .data header and modifying the offset, address and size. */ for (old_data_index = 1; old_data_index < old_file_h->e_shnum; old_data_index++) if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, ".data")) break; if (old_data_index == old_file_h->e_shnum) fatal ("Can't find .data in %s.\n", old_name, 0); /* Walk through all section headers, insert the new data2 section right before the new bss section. */ for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) { caddr_t src; /* If it is bss section, insert the new data2 section before it. */ if (n == old_bss_index) { /* Steal the data section header for this data2 section. */ memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), new_file_h->e_shentsize); NEW_SECTION_H (nn).sh_addr = new_data2_addr; NEW_SECTION_H (nn).sh_offset = new_data2_offset; NEW_SECTION_H (nn).sh_size = new_data2_size; /* Use the bss section's alignment. This will assure that the new data2 section always be placed in the same spot as the old bss section by any other application. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; /* Now copy over what we have in the memory now. */ memcpy (NEW_SECTION_H (nn).sh_offset + new_base, (caddr_t) OLD_SECTION_H (n).sh_addr, new_data2_size); nn++; } memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), old_file_h->e_shentsize); /* The new bss section's size is zero, and its file offset and virtual address should be off by NEW_DATA2_SIZE. */ if (n == old_bss_index) { /* NN should be `old_bss_index + 1' at this point. */ NEW_SECTION_H (nn).sh_offset += new_data2_size; NEW_SECTION_H (nn).sh_addr += new_data2_size; /* Let the new bss section address alignment be the same as the section address alignment followed the old bss section, so this section will be placed in exactly the same place. */ NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; NEW_SECTION_H (nn).sh_size = 0; } /* Any section that was original placed AFTER the bss section should now be off by NEW_DATA2_SIZE. */ else if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) NEW_SECTION_H (nn).sh_offset += new_data2_size; /* If any section hdr refers to the section after the new .data section, make it refer to next one because we have inserted a new section in between. */ PATCH_INDEX (NEW_SECTION_H (nn).sh_link); /* For symbol tables, info is a symbol table index, so don't change it. */ if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) PATCH_INDEX (NEW_SECTION_H (nn).sh_info); /* Now, start to copy the content of sections. */ if (NEW_SECTION_H (nn).sh_type == SHT_NULL || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) continue; /* Write out the sections. .data and .data1 (and data2, called ".data" in the strings table) get copied from the current process instead of the old file. */ if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name), ".data1")) src = (caddr_t) OLD_SECTION_H (n).sh_addr; else src = old_base + OLD_SECTION_H (n).sh_offset; memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, NEW_SECTION_H (nn).sh_size); /* Adjust the HDRR offsets in .mdebug and copy the line data if it's in its usual 'hole' in the object. Makes the new file debuggable with dbx. patches up two problems: the absolute file offsets in the HDRR record of .mdebug (see /usr/include/syms.h), and the ld bug that gets the line table in a hole in the elf file rather than in the .mdebug section proper. David Anderson. davea@sgi.com Jan 16,1994. */ if (n == old_mdebug_index) { #define MDEBUGADJUST(__ct,__fileaddr) \ if (n_phdrr->__ct > 0) \ { \ n_phdrr->__fileaddr += movement; \ } HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); unsigned movement = new_data2_size; MDEBUGADJUST (idnMax, cbDnOffset); MDEBUGADJUST (ipdMax, cbPdOffset); MDEBUGADJUST (isymMax, cbSymOffset); MDEBUGADJUST (ioptMax, cbOptOffset); MDEBUGADJUST (iauxMax, cbAuxOffset); MDEBUGADJUST (issMax, cbSsOffset); MDEBUGADJUST (issExtMax, cbSsExtOffset); MDEBUGADJUST (ifdMax, cbFdOffset); MDEBUGADJUST (crfd, cbRfdOffset); MDEBUGADJUST (iextMax, cbExtOffset); /* The Line Section, being possible off in a hole of the object, requires special handling. */ if (n_phdrr->cbLine > 0) { if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + OLD_SECTION_H (n).sh_size)) { /* line data is in a hole in elf. do special copy and adjust for this ld mistake. */ n_phdrr->cbLineOffset += movement; memcpy (n_phdrr->cbLineOffset + new_base, o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); } else { /* somehow line data is in .mdebug as it is supposed to be. */ MDEBUGADJUST (cbLine, cbLineOffset); } } } /* If it is the symbol table, its st_shndx field needs to be patched. */ if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) { Elf32_Shdr *spt = &NEW_SECTION_H (nn); unsigned int num = spt->sh_size / spt->sh_entsize; Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + new_base); for (; num--; sym++) { if (sym->st_shndx == SHN_UNDEF || sym->st_shndx == SHN_ABS || sym->st_shndx == SHN_COMMON) continue; PATCH_INDEX (sym->st_shndx); } } } /* Close the files and make the new file executable. */ if (close (old_file)) fatal ("Can't close (%s): errno %d\n", old_name, errno); if (close (new_file)) fatal ("Can't close (%s): errno %d\n", new_name, errno); if (stat (new_name, &stat_buf) == -1) fatal ("Can't stat (%s): errno %d\n", new_name, errno); n = umask (777); umask (n); stat_buf.st_mode |= 0111 & ~n; if (chmod (new_name, stat_buf.st_mode) == -1) fatal ("Can't chmod (%s): errno %d\n", new_name, errno); } #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/toplevel.c0000755000175000017500000001427314360276512013241 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* toplevel.c Top-Level Forms and Declarations */ #include "include.h" object sLcompile, sLload, sLeval, sKcompile_toplevel, sKload_toplevel, sKexecute; object sLprogn; object sLwarn; object sSAinhibit_macro_specialA; object sLtypep; static void FFN(Fdefun)(object args) { object name; object body, form; if (endp(args) || endp(MMcdr(args))) FEtoo_few_argumentsF(args); if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons) FEerror("~S is an illegal lambda-list.", 1, MMcadr(args)); name = MMcar(args); if (type_of(name) != t_symbol) not_a_symbol(name); if (name->s.s_sfdef != NOT_SPECIAL) { if (name->s.s_mflag) { if (symbol_value(sSAinhibit_macro_specialA) != Cnil) name->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) FEerror("~S, a special form, cannot be redefined.", 1, name); } if (name->s.s_hpack == lisp_package && name->s.s_gfdef != OBJNULL && !raw_image) { vs_push(make_simple_string( "~S is being redefined.")); ifuncall2(sLwarn, vs_head, name); vs_popp; } vs_base = vs_top; if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) { vs_push(MMcons(sSlambda_block, args)); } else { vs_push(MMcons(lex_env[2], args)); vs_base[0] = MMcons(lex_env[1], vs_base[0]); vs_base[0] = MMcons(lex_env[0], vs_base[0]); vs_base[0] = MMcons(sSlambda_block_closure, vs_base[0]); } {object fname = clear_compiler_properties(name,vs_base[0]); fname->s.s_gfdef = vs_base[0]; fname->s.s_mflag = FALSE;} vs_base[0] = name; for (body = MMcddr(args); !endp(body); body = body->c.c_cdr) { form = macro_expand(body->c.c_car); if (type_of(form) == t_string) { if (endp(body->c.c_cdr)) break; vs_push(form); name->s.s_plist = putf(name->s.s_plist, form, sSfunction_documentation); vs_popp; break; } if (type_of(form) != t_cons || form->c.c_car != sLdeclare) break; } } static void FFN(siLAmake_special)(void) { check_arg(1); check_type_sym(&vs_base[0]); if ((enum stype)vs_base[0]->s.s_stype == stp_constant) FEerror("~S is a constant.", 1, vs_base[0]); vs_base[0]->s.s_stype = (short)stp_special; } static void FFN(siLAmake_constant)(void) { check_arg(2); check_type_sym(&vs_base[0]); if ((enum stype)vs_base[0]->s.s_stype == stp_special) FEerror( "The argument ~S to DEFCONSTANT is a special variable.", 1, vs_base[0]); vs_base[0]->s.s_stype = (short)stp_constant; vs_base[0]->s.s_dbind = vs_base[1]; vs_popp; } static void FFN(Feval_when)(object arg) { object *base = vs_base; object ss; bool flag = FALSE; if(endp(arg)) FEtoo_few_argumentsF(arg); for (ss = MMcar(arg); !endp(ss); ss = MMcdr(ss)) if(MMcar(ss) == sLeval || (MMcar(ss) == sKexecute) ) flag = TRUE; else if(MMcar(ss) != sLload && MMcar(ss) != sLcompile && MMcar(ss) != sKload_toplevel && MMcar(ss) != sKcompile_toplevel ) FEinvalid_form("~S is an undefined situation for EVAL-WHEN.", MMcar(ss)); if(flag) { vs_push(make_cons(sLprogn, MMcdr(arg))); eval(vs_head); } else { vs_base = base; vs_top = base+1; vs_base[0] = Cnil; } } static void FFN(Fload_time_value)(object arg) { if(endp(arg)) FEtoo_few_argumentsF(arg); if(!endp(MMcdr(arg)) && !endp(MMcddr(arg))) FEtoo_many_argumentsF(arg); vs_push(MMcar(arg)); eval(vs_head); } static void FFN(Fdeclare)(object arg) { FEerror("DECLARE appeared in an invalid position.", 0); } static void FFN(Flocally)(object body) { object *oldlex = lex_env; lex_copy(); body = find_special(body, NULL, NULL,NULL); vs_push(body); Fprogn(body); lex_env = oldlex; } static void FFN(Fthe)(object args) { object *vs; if(endp(args) || endp(MMcdr(args))) FEtoo_few_argumentsF(args); if(!endp(MMcddr(args))) FEtoo_many_argumentsF(args); eval(MMcadr(args)); args = MMcar(args); if (type_of(args) == t_cons && MMcar(args) == sLvalues) { vs = vs_base; for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){ if (vs >= vs_top) FEerror("Too many return values.", 0); if (ifuncall2(sLtypep, *vs, MMcar(args)) == Cnil) FEwrong_type_argument(MMcar(args), *vs); } if (vs < vs_top) FEerror("Too few return values.", 0); } else { if (ifuncall2(sLtypep, vs_base[0], args) == Cnil) FEwrong_type_argument(args, vs_base[0]); } } DEF_ORDINARY("LDB",sLldb,LISP,""); DEF_ORDINARY("LDB-TEST",sLldb_test,LISP,""); DEF_ORDINARY("DPB",sLdpb,LISP,""); DEF_ORDINARY("DEPOSIT-FIELD",sLdeposit_field,LISP,""); DEF_ORDINARY("COMPILE",sLcompile,LISP,""); DEF_ORDINARY("COMPILE-TOPLEVEL",sKcompile_toplevel,KEYWORD,""); DEF_ORDINARY("DECLARE",sLdeclare,LISP,""); DEF_ORDINARY("EVAL",sLeval,LISP,""); DEF_ORDINARY("EXECUTE",sKexecute,KEYWORD,""); DEF_ORDINARY("FUNCTION-DOCUMENTATION",sSfunction_documentation,SI,""); DEF_ORDINARY("LOAD",sLload,LISP,""); DEF_ORDINARY("LOAD-TOPLEVEL",sKload_toplevel,KEYWORD,""); DEF_ORDINARY("PROGN",sLprogn,LISP,""); DEF_ORDINARY("TYPEP",sLtypep,LISP,""); DEF_ORDINARY("VALUES",sLvalues,LISP,""); DEF_ORDINARY("VARIABLE-DOCUMENTATION",sSvariable_documentation,SI,""); DEF_ORDINARY("WARN",sLwarn,LISP,""); void gcl_init_toplevel(void) { make_special_form("DEFUN",Fdefun); make_si_function("*MAKE-SPECIAL", siLAmake_special); make_si_function("*MAKE-CONSTANT", siLAmake_constant); make_special_form("EVAL-WHEN", Feval_when); make_special_form("LOAD-TIME-VALUE", Fload_time_value); make_special_form("THE", Fthe); sLdeclare=make_special_form("DECLARE",Fdeclare); make_special_form("LOCALLY",Flocally); } gcl-2.6.14/o/usig2_aux.c0000755000175000017500000000262014360276512013306 0ustar cammcammXSI(string_register->st.st_fillp); XSI(string_register->st.st_fillp); XSI(string_register->st.st_dim); XS(string_register->st.st_self); XSI(token->st.st_fillp); XSI(in_signal_handler); XSI(nlj_active); XS(nlj_fr); XS(nlj_tag); XSI(PRINTarray); XSI(PRINTbase); XS(PRINTcase); XSI(PRINTcircle); XSI(PRINTescape); XSI(PRINTgensym); XSI(PRINTlength); XSI(PRINTlevel); XSI(PRINTpackage); XSI(PRINTpretty); XSI(PRINTradix); XS(PRINTstream); XSI(PRINTstructure); XS(PRINTvs_limit); XS(PRINTvs_top); XSI(READbase); XSI(READdefault_float_format); XSI(READsuppress); XS(READtable); XSI(ctl_end); XSI(ctl_index); XSI(ctl_origin); XS(endp_temp); XSI(eval1); XSI(line_length); XSI(in_list_flag); XS(kf); XS(tf); XSI(left_trim); XSI(right_trim); XS(lex_env); XS(key_function); XS(test_function); XS(item_compared); XSI(intern_flag); XS(printStructBufp); XS(sfaslp); XSI(preserving_whitespace_flag); XS(sharing_table); XSI(string_sign); XSI(string_boundary); XS(car_or_cdr); XS(casefun); XS(tmp_alloc); #ifndef GMP #ifdef CMAC XS(s4_neg_int[3]); XS(small_neg_int[2]); XS(small_pos_int[2]); #endif XS(overflow); XS(top); XS(hiremainder); XS(in_saved_avma); XS(avma ); #endif /* put in NO_INTERRUPT YS(fmt_base); YS(fmt_end); YS(fmt_indents); YS(fmt_index); YS(fmt_jmp_buf); YS(fmt_line_length); YS(fmt_nparam); YS(fmt_paramp); YS(fmt_spare_spaces); YS(fmt_stream); YS(fmt_string); YS(fmt_temporary_stream); YS(fmt_temporary_string); */ gcl-2.6.14/o/fat_string.c0000755000175000017500000002220614360276512013542 0ustar cammcamm/* (c) Copyright W. Schelter 1988, All rights reserved. */ #include #include #include #include "include.h" #include "page.h" #ifdef HAVE_LIBBFD #ifdef NEED_CONST #define CONST const #endif #define IN_GCC #include #include #endif #define FAT_STRING enum type what_to_collect; /* start fasdump stuff */ #include "fasdump.c" object sSAprofile_arrayA; #ifdef NO_PROFILE #ifdef DARWIN/*FIXME macosx10.8 has a prototype (which must match here) but unlinkable function in 64bit*/ int profil(char *buf, size_t bufsiz, unsigned long offset, unsigned int scale){return 0;} #else void profil(void){;} #endif #endif #ifndef NO_PROFILE DEFUN_NEW("PROFILE",object,fSprofile,SI ,2,2,NONE,OO,OO,OO,OO,(object start_address,object scale), "Sets up profiling with START-ADDRESS and SCALE where scale is \ between 0 and 256") { /* 2 args */ object ar=sSAprofile_arrayA->s.s_dbind; void *x; fixnum a,s; if (type_of(ar)!=t_string) FEerror("si:*Profile-array* not a string",0); if( type_of(start_address)!=t_fixnum || type_of(scale)!=t_fixnum) FEerror("Needs start address and scale as args",0); massert((a=fix(start_address))>=0); massert((s=fix(scale))>=0); x=a&&s ? (void *) (ar->ust.ust_self) : NULL; profil(x, (ar->ust.ust_dim),fix(start_address),fix(scale) << 8); RETURN1(start_address); } #endif DEFUN_NEW("FUNCTION-START",object,fSfunction_start,SI,1,1,NONE,OO,OO,OO,OO,(object funobj),"") { switch (type_of(funobj)) { case t_cfun:case t_sfun:case t_vfun:case t_afun:case t_gfun:case t_closure:case t_cclosure: return make_fixnum((long) (funobj->cf.cf_self)); default: TYPE_ERROR(funobj,sLcompiled_function); return Cnil; } } /* begin fasl stuff*/ /* this is for windows to not include all of windows.h for this..*/ #include "ptable.h" #ifdef AIX3 #include char *data_load_addr =0; #endif #define CFUN_LIM 10000 int maxpage; object sScdefn; #define CF_FLAG ((unsigned long)1 << (sizeof(long)*8-1)) static void cfuns_to_combined_table(unsigned int n) /* non zero n will ensure new table length */ {int ii=0; STATIC int j; STATIC object x; STATIC char *p,*cf_addr; STATIC struct typemanager *tm; if (! (n || combined_table.ptable)) n=CFUN_LIM; if (n && combined_table.alloc_length < n) { (combined_table.ptable)=NULL; (combined_table.ptable)= (struct node *)malloc(n* sizeof(struct node)); if(!combined_table.ptable) FEerror("unable to allocate",0); combined_table.alloc_length=n;} { struct pageinfo *v; for (v=cell_list_head;v;v=v->next) { enum type tp=v->type; if (tp!=tm_table[(short)t_cfun].tm_type && tp!=tm_table[(short)t_gfun].tm_type && tp!=tm_table[(short)t_sfun].tm_type && tp!=tm_table[(short)t_vfun].tm_type ) continue; tm = tm_of(tp); p = pagetochar(page(v)); for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { x = (object)p; if (type_of(x)!=t_cfun && type_of(x)!=t_sfun && type_of(x)!=t_vfun && type_of(x)!=t_gfun ) continue; if (is_free(x) || x->cf.cf_self == NULL) continue; /* the cdefn things are the proclaimed call types. */ cf_addr=(char * ) ((unsigned long)(x->cf.cf_self)); SYM_ADDRESS(combined_table,ii)=(unsigned long)cf_addr; SYM_STRING(combined_table,ii)= (char *)(CF_FLAG | (unsigned long)x) ; /* (x->cf.cf_name ? x->cf.cf_name->s.st_self : NULL) ; */ combined_table.length = ++ii; if (ii >= combined_table.alloc_length) FEerror("Need a larger combined_table",0); } } } } static int address_node_compare(const void *node1, const void *node2) {unsigned int a1,a2; a1=((struct node *)node1)->address; a2=((struct node *)node2)->address; if (a1> a2) return 1; if (a1< a2) return -1; return 0; } #if defined(HAVE_LIBBFD) && ! defined(SPECIAL_RSYM) static int bfd_update; static MY_BFD_BOOLEAN bfd_combined_table_update(struct bfd_link_hash_entry *h,PTR ct) { if (ct!=&combined_table) return MY_BFD_FALSE; if (h->type!=bfd_link_hash_defined) return MY_BFD_TRUE; if (!h->u.def.section) { FEerror("Symbol without section",0); return MY_BFD_FALSE; } if (bfd_update) { if (combined_table.length>=combined_table.alloc_length) FEerror("combined table overflow", 0); SYM_ADDRESS(combined_table,combined_table.length)=h->u.def.value+h->u.def.section->vma; SYM_STRING(combined_table,combined_table.length)=(char *)h->root.string; } combined_table.length++; return MY_BFD_TRUE; } #endif DEFUN_NEW("SET-UP-COMBINED",object,fSset_up_combined,SI ,0,1,NONE,OO,OO,OO,OO,(object first,...),"") { int nargs=VFUN_NARGS; unsigned int n; object siz; if (nargs>=1) siz=first; else siz = small_fixnum(0); CHECK_ARG_RANGE(0,1); n = (unsigned int) fix(siz); cfuns_to_combined_table(n); #if !defined(HAVE_LIBBFD) && !defined(SPECIAL_RSYM) #error Need either BFD or SPECIAL_RSYM #endif #if defined(SPECIAL_RSYM) if (c_table.ptable) { int j,k; if((k=combined_table.length)+c_table.length >= combined_table.alloc_length) cfuns_to_combined_table(combined_table.length+c_table.length+20); for(j = 0; j < c_table.length;) { SYM_ADDRESS(combined_table,k) =SYM_ADDRESS(c_table,j); SYM_STRING(combined_table,k) =SYM_STRING(c_table,j); k++; j++; } combined_table.length += c_table.length ; } #else #if defined(HAVE_LIBBFD) if (link_info.hash) { bfd_update=0; bfd_link_hash_traverse(link_info.hash, bfd_combined_table_update,&combined_table); if (combined_table.length >=combined_table.alloc_length) cfuns_to_combined_table(combined_table.length); bfd_update=1; bfd_link_hash_traverse(link_info.hash, bfd_combined_table_update,&combined_table); bfd_update=0; } #endif #endif qsort(combined_table.ptable,combined_table.length,sizeof(*combined_table.ptable),address_node_compare); RETURN1(siz); } static int prof_start; static int prof_ind(unsigned int address, int scale) {address = address - prof_start ; if (address > 0) return ((address * scale) >> 8) ; return 0; } /* sum entries AAR up to DIM entries */ static int string_sum(register unsigned char *aar, unsigned int dim) {register unsigned char *endar; register unsigned int count = 0; endar=aar+dim; for ( ; aar< endar; aar++) count += *aar; return count; } DEFUN_NEW("DISPLAY-PROFILE",object,fSdisplay_profile,SI ,2,2,NONE,OO,OO,OO,OO,(object start_addr,object scal),"") { if (!combined_table.ptable) FEerror("must symbols first",0); /* 2 args */ { unsigned int prev,next,upto,dim,total; int j,scale,count; unsigned char *ar; object obj_ar; obj_ar=sSAprofile_arrayA->s.s_dbind; if (type_of(obj_ar)!=t_string) FEerror("si:*Profile-array* not a string",0); ar=obj_ar->ust.ust_self; scale=fix(scal); prof_start=fix(start_addr); vs_top=vs_base; dim= (obj_ar->ust.ust_dim); total=string_sum(ar,dim); j=0; { int i, finish = combined_table.length-1; for(i =0,prev=SYM_ADDRESS(combined_table,i); i< finish;prev=next) { ++i; next=SYM_ADDRESS(combined_table,i); if (prev= dim) upto=dim; { const char *name; unsigned long uname; count=0; for(;j 0) { name=SYM_STRING(combined_table,i-1); uname = (unsigned long) name; printf("\n%6.2f%% (%5d): ",(100.0*count)/total, count); fflush(stdout); if (CF_FLAG & uname) { if (~CF_FLAG & uname) prin1( ((object) (~CF_FLAG & uname))->cf.cf_name,Cnil); } else if (name ) printf("%s",name);}; if (upto==dim) goto TOTALS ; } } } TOTALS: printf("\nTotal ticks %d",total);fflush(stdout); } RETURN1(start_addr); } /* end fasl stuff*/ /* These are some low level hacks to allow determining the address of an array body, and to allow jumping to inside the body of the array */ DEFUN_NEW("ARRAY-ADRESS",object,fSarray_adress,SI ,1,1,NONE,OO,OO,OO,OO,(object array),"") {/* 1 args */ array=make_fixnum((long) (&(array->st.st_self[0]))); RETURN1(array); } /* This is some very low level code for hacking invokation of m68k instructions in a lisp array. The index used should be a byte index. So invoke(ar,3) jmps to byte ar+3. */ #ifdef CLI invoke(ar) char *ar; {asm("movel a6@(8),a0"); asm("jmp a0@"); } /* save regs (2 3 4 5 6 7 10 11 12 13 14) and invoke restoring them */ save_regs_invoke(ar) char *ar; {asm("moveml #0x3f3e,sp@-"); invoke(ar); asm("moveml a6@(-44),#0x7cfc"); } /* DEFUNO_NEW("SAVE-REGS-INVOKE",object,fSsave_regs_invoke,SI ,2,2,NONE,OO,OO,OO,OO,void,siLsave_regs_invoke,"",(x0,x1)) object x0,x1; {int x; check_type_integer(&x1); x=save_regs_invoke((x0->st.st_self)+fix(x1)); x0=make_fixnum(x); RETURN1(x0); } */ #endif DEFVAR("*PROFILE-ARRAY*",sSAprofile_arrayA,SI,Cnil,""); void gcl_init_fat_string(void) { make_si_constant("*ASH->>*",(-1==(((int)-1) >> 20))? Ct :Cnil); /* #ifdef SFASL */ /* make_si_function("BUILD-SYMBOL-TABLE",build_symbol_table); */ /* #endif */ init_fasdump(); } gcl-2.6.14/o/unexmips.c0000755000175000017500000002365514360276512013263 0ustar cammcamm/* Unexec for MIPS (including IRIS4D). Note that the GNU project considers support for MIPS operation a peripheral activity which should not be allowed to divert effort from development of the GNU system. Changes in this code will be installed when users send them in, but aside from that we don't plan to think about it, or about whether other Emacs maintenance might break it. Copyright (C) 1988, 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "config.h" #include #include #include #include #include #include #include #include #if defined (IRIS_4D) || defined (sony) #include "getpagesize.h" #include #endif static void fatal_unexec (); static void mark_x (); #define READ(_fd, _buffer, _size, _error_message, _error_arg) \ errno = EEOF; \ if (read (_fd, _buffer, _size) != _size) \ fatal_unexec (_error_message, _error_arg); #define WRITE(_fd, _buffer, _size, _error_message, _error_arg) \ if (write (_fd, _buffer, _size) != _size) \ fatal_unexec (_error_message, _error_arg); #define SEEK(_fd, _position, _error_message, _error_arg) \ errno = EEOF; \ if (lseek (_fd, _position, L_SET) != _position) \ fatal_unexec (_error_message, _error_arg); extern int errno; extern char *strerror (); #define EEOF -1 static struct scnhdr *text_section; static struct scnhdr *init_section; static struct scnhdr *finit_section; static struct scnhdr *rdata_section; static struct scnhdr *xdata_section; static struct scnhdr *pdata_section; static struct scnhdr *data_section; static struct scnhdr *lit8_section; static struct scnhdr *lit4_section; static struct scnhdr *sdata_section; static struct scnhdr *sbss_section; static struct scnhdr *bss_section; struct headers { struct filehdr fhdr; struct aouthdr aout; struct scnhdr section[16]; }; /* Define name of label for entry point for the dumped executable. */ #ifndef DEFAULT_ENTRY_ADDRESS #define DEFAULT_ENTRY_ADDRESS __start #endif unexec (new_name, a_name, data_start, bss_start, entry_address) char *new_name, *a_name; unsigned long data_start, bss_start, entry_address; { int new, old; long pagesize, brk; long newsyms, symrel; int nread; struct headers hdr; int i; long vaddr, scnptr; #define BUFSIZE 8192 char buffer[BUFSIZE]; old = open (a_name, O_RDONLY, 0); if (old < 0) fatal_unexec ("opening %s", a_name); new = creat (new_name, 0666); if (new < 0) fatal_unexec ("creating %s", new_name); hdr = *((struct headers *)TEXT_START); #ifdef MIPS2 if (hdr.fhdr.f_magic != MIPSELMAGIC && hdr.fhdr.f_magic != MIPSEBMAGIC && hdr.fhdr.f_magic != (MIPSELMAGIC | 1) && hdr.fhdr.f_magic != (MIPSEBMAGIC | 1)) { fprintf (stderr, "unexec: input file magic number is %x, not %x, %x, %x or %x.\n", hdr.fhdr.f_magic, MIPSELMAGIC, MIPSEBMAGIC, MIPSELMAGIC | 1, MIPSEBMAGIC | 1); exit(1); } #else /* not MIPS2 */ #ifdef __alpha if (hdr.fhdr.f_magic != ALPHAMAGIC && hdr.fhdr.f_magic != ALPHAUMAGIC) { fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n", hdr.fhdr.f_magic, ALPHAMAGIC, ALPHAUMAGIC); exit(1); } #else /* not alpha */ if (hdr.fhdr.f_magic != MIPSELMAGIC && hdr.fhdr.f_magic != MIPSEBMAGIC) { fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n", hdr.fhdr.f_magic, MIPSELMAGIC, MIPSEBMAGIC); exit(1); } #endif /* not alpha */ #endif /* not MIPS2 */ if (hdr.fhdr.f_opthdr != sizeof (hdr.aout)) { fprintf (stderr, "unexec: input a.out header is %d bytes, not %d.\n", hdr.fhdr.f_opthdr, sizeof (hdr.aout)); exit (1); } if (hdr.aout.magic != ZMAGIC) { fprintf (stderr, "unexec: input file a.out magic number is %o, not %o.\n", hdr.aout.magic, ZMAGIC); exit (1); } #define CHECK_SCNHDR(ptr, name, flags) \ for( i = 0, ptr = NULL; i < hdr.fhdr.f_nscns && !ptr; i++){ \ if (hdr.section[i].s_name && strcmp (hdr.section[i].s_name, name) == 0){ \ if (hdr.section[i].s_flags != flags) { \ fprintf(stderr, "unexec: %x flags (%x expected) in %s section.\n", \ hdr.section[i].s_flags, flags, name); \ } \ ptr = hdr.section + i; \ } \ if(ptr) \ break;\ } CHECK_SCNHDR (text_section, _TEXT, STYP_TEXT); CHECK_SCNHDR (init_section, _INIT, STYP_INIT); CHECK_SCNHDR (rdata_section, _RDATA, STYP_RDATA); #ifdef _RCONST if (!rdata_section) /* OSF/1 V3 adds this */ CHECK_SCNHDR (rdata_section, _RCONST, STYP_RCONST); #endif #ifdef _XDATA CHECK_SCNHDR(xdata_section, _XDATA, STYP_XDATA); CHECK_SCNHDR(pdata_section, _PDATA, STYP_PDATA); #endif CHECK_SCNHDR (data_section, _DATA, STYP_DATA); #ifdef _LIT8 CHECK_SCNHDR (lit8_section, _LIT8, STYP_LIT8); CHECK_SCNHDR (lit4_section, _LIT4, STYP_LIT4); #endif /* _LIT8 */ CHECK_SCNHDR (sdata_section, _SDATA, STYP_SDATA); CHECK_SCNHDR (sbss_section, _SBSS, STYP_SBSS); CHECK_SCNHDR (bss_section, _BSS, STYP_BSS); #if 0 /* Apparently this error check goes off on irix 3.3, but it doesn't indicate a real problem. */ if (i != hdr.fhdr.f_nscns) fprintf (stderr, "unexec: %d sections found instead of %d.\n", i, hdr.fhdr.f_nscns); #endif text_section->s_scnptr = 0; pagesize = getpagesize (); /* Casting to int avoids compiler error on NEWS-OS 5.0.2. */ brk = (((int) (sbrk (0))) + pagesize - 1) & (-pagesize); hdr.aout.dsize = brk - DATA_START; hdr.aout.bsize = 0; if (entry_address == 0) { extern DEFAULT_ENTRY_ADDRESS (); hdr.aout.entry = (unsigned long)DEFAULT_ENTRY_ADDRESS; } else hdr.aout.entry = entry_address; hdr.aout.bss_start = hdr.aout.data_start + hdr.aout.dsize; rdata_section->s_size = data_start - DATA_START; /* Adjust start and virtual addresses of rdata_section, too. */ rdata_section->s_vaddr = DATA_START; rdata_section->s_paddr = DATA_START; rdata_section->s_scnptr = text_section->s_scnptr + hdr.aout.tsize; data_section->s_vaddr = data_start; data_section->s_paddr = data_start; data_section->s_size = brk - data_start; data_section->s_scnptr = rdata_section->s_scnptr + rdata_section->s_size; vaddr = data_section->s_vaddr + data_section->s_size; scnptr = data_section->s_scnptr + data_section->s_size; if (lit8_section != NULL) { lit8_section->s_vaddr = vaddr; lit8_section->s_paddr = vaddr; lit8_section->s_size = 0; lit8_section->s_scnptr = scnptr; } if (lit4_section != NULL) { lit4_section->s_vaddr = vaddr; lit4_section->s_paddr = vaddr; lit4_section->s_size = 0; lit4_section->s_scnptr = scnptr; } if (sdata_section != NULL) { sdata_section->s_vaddr = vaddr; sdata_section->s_paddr = vaddr; sdata_section->s_size = 0; sdata_section->s_scnptr = scnptr; } if (sbss_section != NULL) { sbss_section->s_vaddr = vaddr; sbss_section->s_paddr = vaddr; sbss_section->s_size = 0; sbss_section->s_scnptr = scnptr; } if (bss_section != NULL) { bss_section->s_vaddr = vaddr; bss_section->s_paddr = vaddr; bss_section->s_size = 0; bss_section->s_scnptr = scnptr; } WRITE (new, (char *)TEXT_START, hdr.aout.tsize, "writing text section to %s", new_name); WRITE (new, (char *)DATA_START, hdr.aout.dsize, "writing data section to %s", new_name); SEEK (old, hdr.fhdr.f_symptr, "seeking to start of symbols in %s", a_name); errno = EEOF; nread = read (old, buffer, BUFSIZE); if (nread < sizeof (HDRR)) fatal_unexec ("reading symbols from %s", a_name); #define symhdr ((pHDRR)buffer) newsyms = hdr.aout.tsize + hdr.aout.dsize; symrel = newsyms - hdr.fhdr.f_symptr; hdr.fhdr.f_symptr = newsyms; symhdr->cbLineOffset += symrel; symhdr->cbDnOffset += symrel; symhdr->cbPdOffset += symrel; symhdr->cbSymOffset += symrel; symhdr->cbOptOffset += symrel; symhdr->cbAuxOffset += symrel; symhdr->cbSsOffset += symrel; symhdr->cbSsExtOffset += symrel; symhdr->cbFdOffset += symrel; symhdr->cbRfdOffset += symrel; symhdr->cbExtOffset += symrel; #undef symhdr do { if (write (new, buffer, nread) != nread) fatal_unexec ("writing symbols to %s", new_name); nread = read (old, buffer, BUFSIZE); if (nread < 0) fatal_unexec ("reading symbols from %s", a_name); #undef BUFSIZE } while (nread != 0); SEEK (new, 0, "seeking to start of header in %s", new_name); WRITE (new, &hdr, sizeof (hdr), "writing header of %s", new_name); close (old); close (new); mark_x (new_name); } /* * mark_x * * After successfully building the new a.out, mark it executable */ static void mark_x (name) char *name; { struct stat sbuf; int um = umask (777); umask (um); if (stat (name, &sbuf) < 0) fatal_unexec ("getting protection on %s", name); sbuf.st_mode |= 0111 & ~um; if (chmod (name, sbuf.st_mode) < 0) fatal_unexec ("setting protection on %s", name); } static void fatal_unexec (const char *s, ...) { va_list ap; if (errno == EEOF) fputs ("unexec: unexpected end of file, ", stderr); else fprintf (stderr, "unexec: %s, ", strerror (errno)); va_start (ap,s); _doprnt (s, ap, stderr); fputs (".\n", stderr); exit (1); } #ifdef UNIXSAVE #include "save.c" #endif gcl-2.6.14/o/NeXTunixfasl.c0000755000175000017500000003155214360276512013776 0ustar cammcamm/* * FASL loader using rld() for NeXT * * Written by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) * February 14, 1992 * * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) * May 1, 1995 * June 5, 1995 * June 6, 1995 */ #include #include #include #include #include #include #include #include static unsigned long object_size, object_start; static unsigned long my_address_func(size, headers_size) unsigned long size; unsigned long headers_size; { return (object_start = (unsigned long)alloc_contblock(object_size = size + headers_size)); } static void load_mach_o(filename) char *filename; { FILE *fp; struct mach_header header; char *hdrbuf; struct load_command *load_command; struct segment_command *segment_command; struct section *section; int len, cmd, seg; if ((fp = fopen(filename, "r")) == NULL) FEerror("Can't read Mach-O object file", 0); len = fread((char *)&header, sizeof(struct mach_header), 1, fp); if (len == 1 && header.magic == MH_MAGIC) { hdrbuf = (char *)malloc(header.sizeofcmds); len = fread(hdrbuf, header.sizeofcmds, 1, fp); if (len != 1) FEerror("failure reading Mach-O load commands", 0); load_command = (struct load_command *) hdrbuf; for (cmd = 0; cmd < header.ncmds; ++cmd) { if (load_command->cmd == LC_SEGMENT) { segment_command = (struct segment_command *) load_command; section = (struct section *) ((char *)(segment_command + 1)); for (seg = 0; seg < segment_command->nsects; ++seg, ++section) { if (section->size != 0 && section->offset != 0) { #ifdef DEBUG fprintf(stderr, "section: %s, addr: 0x%08x, size: %d\n", section->sectname, section->addr, section->size); fflush(stderr); #endif fseek(fp, section->offset, 0); fread((char *)section->addr, section->size, 1, fp); } } } load_command = (struct load_command *) ((char *)load_command + load_command->cmdsize); } free(hdrbuf); } (void)fclose(fp); } int seek_to_end_ofile(fp) FILE *fp; { struct mach_header mach_header; char *hdrbuf; struct load_command *load_command; struct segment_command *segment_command; struct section *section; struct symtab_command *symtab_command; struct symseg_command *symseg_command; int len, cmd, seg; int end_sec, end_ofile; end_ofile = 0; fseek(fp, 0L, 0); len = fread((char *)&mach_header, sizeof(struct mach_header), 1, fp); if (len == 1 && mach_header.magic == MH_MAGIC) { hdrbuf = (char *)malloc(mach_header.sizeofcmds); len = fread(hdrbuf, mach_header.sizeofcmds, 1, fp); if (len != 1) { fprintf(stderr, "seek_to_end_ofile(): failure reading Mach-O load commands\n"); return 0; } load_command = (struct load_command *) hdrbuf; for (cmd = 0; cmd < mach_header.ncmds; ++cmd) { switch (load_command->cmd) { case LC_SEGMENT: segment_command = (struct segment_command *) load_command; section = (struct section *) ((char *)(segment_command + 1)); for (seg = 0; seg < segment_command->nsects; ++seg, ++section) { end_sec = section->offset + section->size; if (end_sec > end_ofile) end_ofile = end_sec; } break; case LC_SYMTAB: symtab_command = (struct symtab_command *) load_command; end_sec = symtab_command->symoff + symtab_command->nsyms * sizeof(struct nlist); if (end_sec > end_ofile) end_ofile = end_sec; end_sec = symtab_command->stroff + symtab_command->strsize; if (end_sec > end_ofile) end_ofile = end_sec; break; case LC_SYMSEG: symseg_command = (struct symseg_command *) load_command; end_sec = symseg_command->offset + symseg_command->size; if (end_sec > end_ofile) end_ofile = end_sec; break; } load_command = (struct load_command *) ((char *)load_command + load_command->cmdsize); } free(hdrbuf); fseek(fp, end_ofile, 0); return 1; } return 0; } static char *library_search_path[] = {"/lib", "/usr/lib", "/usr/local/lib", NULL}; #define strdup(string) strcpy((char *)malloc(strlen(string)+1),(string)) static char * expand_library_filename(filename) char *filename; { int fd; char **dir; char libname[256]; char fullname[256]; if (filename[0] == '-' && filename[1] == 'l') { filename++; filename++; strcpy(libname, "lib"); strcat(libname, filename); strcat(libname, ".a"); for (dir = library_search_path; *dir; dir++) { strcpy(fullname, *dir); strcat(fullname, "/"); strcat(fullname, libname); #ifdef DEBUG fprintf(stderr, "%s\n", fullname); fflush(stderr); #endif if ((fd = open(fullname, O_RDONLY, 0)) > 0) { close(fd); return (strdup(fullname)); } } return (strdup(libname)); } return (strdup(filename)); } static char ** make_ofile_list(faslfile, argstr) char *faslfile, *argstr; { char filename[256]; char *dst; int i; char **ofile_list; ofile_list = (char **)calloc(1, sizeof(char *)); ofile_list[0] = strdup(faslfile); i = 1; if (argstr != NULL) { for (;; i++) { while ((*argstr == ' ') && (*argstr != '\0')) argstr++; if (*argstr == '\0') break; dst = filename; while ((*argstr != ' ') && (*argstr != '\0')) *dst++ = *argstr++; *dst = '\0'; ofile_list = (char **)realloc((void *)ofile_list, (i + 1) * sizeof(char *)); ofile_list[i] = expand_library_filename(filename); } } ofile_list = (char **)realloc((void *)ofile_list, (i + 1) * sizeof(char *)); ofile_list[i] = NULL; return (ofile_list); } static void free_ofile_list(ofile_list) char **ofile_list; { int i; for (i = 1;; i++) { if (ofile_list[i] == NULL) break; (void)free(ofile_list[i]); } (void)free(ofile_list); } #ifdef DEBUG static void print_ofile_list(ofile_list) char **ofile_list; { int i; if (ofile_list == NULL) return; fprintf(stderr, "ofiles: "); for (i = 0;; i++) { if (ofile_list[i] == NULL) break; fprintf(stderr, "(%s)", ofile_list[i]); } fprintf(stderr, "\n"); fflush(stderr); } #endif int fasload(pathname) object pathname; { FILE *fp; object *old_vs_base = vs_base; object *old_vs_top = vs_top; object memory; object fasl_data; object stream; char entryname[100]; char filename[256]; char tempfilename[40]; char **ofiles; NXStream *err_stream; void (*entry) (); struct mach_header *hdr; stream = open_stream(pathname, smm_input, Cnil, sKerror); fp = stream->sm.sm_fp; seek_to_end_ofile(fp); fasl_data = read_fasl_vector(stream); vs_push(fasl_data); pathname = coerce_to_pathname(stream); coerce_to_filename(stream, filename); if ((err_stream = NXOpenFile(fileno(stderr), NX_WRITEONLY)) == 0) FEerror("NXOpenFile() failed", 0); sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); rld_address_func(my_address_func); ofiles = make_ofile_list(filename, NULL); #ifdef DEBUG print_ofile_list(ofiles); #endif if (!rld_load(err_stream, &hdr, ofiles, tempfilename)) { free_ofile_list(ofiles); NXFlush(err_stream); NXClose(err_stream); FEerror("rld_load() failed", 0); } free_ofile_list(ofiles); load_mach_o(tempfilename); unlink(tempfilename); strcpy(entryname, "_init_code"); if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { strcpy(entryname, "_init_"); bcopy(pathname->pn.pn_name->st.st_self, entryname + 6, pathname->pn.pn_name->st.st_fillp); entryname[6 + pathname->pn.pn_name->st.st_fillp] = 0; if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { NXFlush(err_stream); NXClose(err_stream); FEerror("Can't find init code", 0); } } (void)rld_unload_all(err_stream, 0); NXFlush(err_stream); NXClose(err_stream); #ifdef DEBUG { extern char *mach_brkpt, *mach_maplimit, *core_end; fprintf(stderr, "mach_brkpt : 0x%08x\n", mach_brkpt); fprintf(stderr, "mach_maplimit : 0x%08x\n", mach_maplimit); fprintf(stderr, "core_end : 0x%08x\n", core_end); fprintf(stderr, "hdr : 0x%08x\n", hdr); fprintf(stderr, "object_start : 0x%08x\n", object_start); fprintf(stderr, "object_size : %d\n", object_size); fprintf(stderr, "&%s : 0x%08x\n", entryname, entry); fflush(stderr); } #endif memory = alloc_object(t_cfdata); memory->cfd.cfd_self = 0; memory->cfd.cfd_fillp = 0; memory->cfd.cfd_size = object_size; memory->cfd.cfd_start = (char *)object_start; vs_push(memory); #ifdef CLEAR_CACHE CLEAR_CACHE; #endif call_init(entry - object_start, memory, fasl_data,0); if (symbol_value(sLAload_verboseA) != Cnil) printf("start address -T 0x%08x ", entry); vs_base = old_vs_base; vs_top = old_vs_top; close_stream(stream); return object_size; } int faslink(pathname, ldargstring) object pathname, ldargstring; { FILE *fp; object *old_vs_base = vs_base; object *old_vs_top = vs_top; object memory; object fasl_data; object stream; char entryname[100]; char filename[256]; char ldargstr[256]; char tempfilename[40]; char **ofiles; NXStream *err_stream; void (*entry) (); struct mach_header *hdr; stream = open_stream(pathname, smm_input, Cnil, sKerror); fp = stream->sm.sm_fp; seek_to_end_ofile(fp); fasl_data = read_fasl_vector(stream); vs_push(fasl_data); pathname = coerce_to_pathname(stream); coerce_to_filename(stream, filename); coerce_to_filename(ldargstring, ldargstr); if ((err_stream = NXOpenFile(fileno(stderr), NX_WRITEONLY)) == 0) FEerror("NXOpenFile() failed", 0); sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); rld_address_func(my_address_func); ofiles = make_ofile_list(filename, ldargstr); #ifdef DEBUG print_ofile_list(ofiles); #endif if (!rld_load(err_stream, &hdr, ofiles, tempfilename)) { free_ofile_list(ofiles); NXFlush(err_stream); NXClose(err_stream); FEerror("rld_load() failed", 0); } free_ofile_list(ofiles); load_mach_o(tempfilename); unlink(tempfilename); strcpy(entryname, "_init_code"); if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { strcpy(entryname, "_init_"); bcopy(pathname->pn.pn_name->st.st_self, entryname + 6, pathname->pn.pn_name->st.st_fillp); entryname[6 + pathname->pn.pn_name->st.st_fillp] = 0; if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { NXFlush(err_stream); NXClose(err_stream); FEerror("Can't find init code", 0); } } (void)rld_unload_all(err_stream, 0); NXFlush(err_stream); NXClose(err_stream); #ifdef DEBUG { extern char *mach_brkpt, *mach_maplimit, *core_end; fprintf(stderr, "mach_brkpt : 0x%08x\n", mach_brkpt); fprintf(stderr, "mach_maplimit : 0x%08x\n", mach_maplimit); fprintf(stderr, "core_end : 0x%08x\n", core_end); fprintf(stderr, "hdr : 0x%08x\n", hdr); fprintf(stderr, "object_start : 0x%08x\n", object_start); fprintf(stderr, "object_size : %d\n", object_size); fprintf(stderr, "&%s : 0x%08x\n", entryname, entry); fflush(stderr); } #endif memory = alloc_object(t_cfdata); memory->cfd.cfd_self = 0; memory->cfd.cfd_fillp = 0; memory->cfd.cfd_size = object_size; memory->cfd.cfd_start = (char *)object_start; vs_push(memory); #ifdef CLEAR_CACHE CLEAR_CACHE; #endif call_init(entry - object_start, memory, fasl_data,0); if (symbol_value(sLAload_verboseA) != Cnil) printf("start address -T 0x%08x \n", entry); vs_base = old_vs_base; vs_top = old_vs_top; close_stream(stream); return object_size; } siLfaslink() { bds_ptr old_bds_top; int i; object package; check_arg(2); check_type_or_pathname_string_symbol_stream(&vs_base[0]); check_type_string(&vs_base[1]); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_base[0]->pn.pn_type = FASL_string; vs_base[0] = namestring(vs_base[0]); package = symbol_value(sLApackageA); old_bds_top = bds_top; bds_bind(sLApackageA, package); i = faslink(vs_base[0], vs_base[1]); bds_unwind(old_bds_top); vs_top = vs_base; vs_push(make_fixnum(i)); } #define FASLINK gcl-2.6.14/o/num_co.c0000755000175000017500000005644614360276512012677 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* num_co.c IMPLEMENTATION-DEPENDENT This file contains those functions that know the representation of floating-point numbers. */ #define IN_NUM_CO #define NEED_MP_H #define NEED_ISFINITE #include "include.h" #include "num_include.h" object plus_half, minus_half; extern void zero_divisor(void); #ifdef CONVEX #define VAX #endif /* A number is normal when: * it is finite, * it is not zero, and * its exponent is non-zero. */ #ifndef IEEEFLOAT #error this file needs IEEEFLOAT #endif int gcl_isnormal_double(double d) { union {double d;int i[2];} u; if (!ISFINITE(d) || !d) return 0; u.d = d; return (u.i[HIND] & 0x7ff00000) != 0; } int gcl_isnormal_float(float f) { union {float f;int i;} u; if (!ISFINITE(f) || !f) return 0; u.f = f; return (u.i & 0x7f800000) != 0; } static inline int gcl_isnan_double(double d) { if (ISFINITE(d)) return 0; if (d==d) return 0; return 1; } static inline int gcl_isnan_float(float f) { if (ISFINITE(f)) return 0; if (f==f) return 0; return 1; } int gcl_isnan(object x) { switch(type_of(x)) { case t_shortfloat: return gcl_isnan_float(sf(x)); case t_longfloat: return gcl_isnan_double(lf(x)); default: return 0; } } int gcl_is_not_finite(object x) { switch(type_of(x)) { case t_shortfloat: return !ISFINITE(sf(x)); case t_longfloat: return !ISFINITE(lf(x)); default: return 0; } } static void integer_decode_double(double d, int *hp, int *lp, int *ep, int *sp) { int h, l; union {double d;int i[2];} u; if (d == 0.0) { *hp = *lp = 0; *ep = 0; *sp = 1; return; } u.d=d; h=u.i[HIND]; l=u.i[LIND]; if (ISNORMAL(d)) { *ep = ((h & 0x7ff00000) >> 20) - 1022 - 53; h = ((h & 0x000fffff) | 0x00100000); } else { *ep = ((h & 0x7fe00000) >> 20) - 1022 - 53 + 1; h = (h & 0x001fffff); } if (32-BIG_RADIX) /* shift for making bignum */ { h = h << (32-BIG_RADIX) ; h |= ((l & (-1 << (32-BIG_RADIX))) >> (32-BIG_RADIX)); l &= ~(-1 << (32-BIG_RADIX)); } *hp = h; *lp = l; *sp = (d > 0.0 ? 1 : -1); } static void integer_decode_float(double d, int *mp, int *ep, int *sp) { float f; int m; union {float f;int i;} u; f = d; if (f == 0.0) { *mp = 0; *ep = 0; *sp = 1; return; } u.f=f; m=u.i; /* m = *(int *)(&f); */ if (ISNORMAL(f)) { *ep = ((m & 0x7f800000) >> 23) - 126 - 24; *mp = (m & 0x007fffff) | 0x00800000; } else { *ep = ((m & 0x7f000000) >> 23) - 126 - 24 + 1; *mp = m & 0x00ffffff; } *sp = (f > 0.0 ? 1 : -1); } static int double_exponent(double d) { union {double d;int i[2];} u; if (d == 0.0) return(0); u.d=d; return (((u.i[HIND] & 0x7ff00000) >> 20) - 1022); } static double set_exponent(double d, int e) { union {double d;int i[2];} u; if (d == 0.0) return(0.0); u.d=d; u.i[HIND]= (u.i[HIND] & 0x800fffff) | (((e + 1022) << 20) & 0x7ff00000); return(u.d); } object double_to_integer(double d) { int h, l, e, s; object x; vs_mark; if (d == 0.0) return(small_fixnum(0)); integer_decode_double(d, &h, &l, &e, &s); if (e <= -BIG_RADIX) { e = (-e) - BIG_RADIX; if (e >= BIG_RADIX) return(small_fixnum(0)); h >>= e; return(make_fixnum(s*h)); } if (h != 0 || l<0) x = bignum2(h, l); else x = make_fixnum(l); vs_push(x); x = integer_fix_shift(x, e); if (s < 0) { vs_push(x); x = number_negate(x); } vs_reset; return(x); } static object num_remainder(object x, object y, object q) { object z; z = number_times(q, y); vs_push(z); z = number_minus(x, z); vs_popp; return(z); } /* Coerce X to single-float if one arg, otherwise coerce to same float type as second arg */ LFD(Lfloat)(void) { double d; int narg; object x; enum type t=t_longfloat; narg = vs_top - vs_base; if (narg < 1) too_few_arguments(); else if (narg > 2) too_many_arguments(); if (narg == 2) { check_type_float(&vs_base[1]); t = type_of(vs_base[1]); } x = vs_base[0]; switch (type_of(x)) { case t_fixnum: if (narg > 1 && t == t_shortfloat) x = make_shortfloat((shortfloat)(fix(x))); else x = make_longfloat((double)(fix(x))); break; case t_bignum: case t_ratio: d = number_to_double(x); if (narg > 1 && t == t_shortfloat) x = make_shortfloat((shortfloat)d); else x = make_longfloat(d); break; case t_shortfloat: if (narg > 1 && t == t_shortfloat); else x = make_longfloat((double)(sf(x))); break; case t_longfloat: if (narg > 1 && t == t_shortfloat) x = make_shortfloat((shortfloat)(lf(x))); break; default: FEwrong_type_argument(TSor_rational_float, x); } vs_base = vs_top; vs_push(x); } LFD(Lnumerator)(void) { check_arg(1); check_type_rational(&vs_base[0]); if (type_of(vs_base[0]) == t_ratio) vs_base[0] = vs_base[0]->rat.rat_num; } LFD(Ldenominator)(void) { check_arg(1); check_type_rational(&vs_base[0]); if (type_of(vs_base[0]) == t_ratio) vs_base[0] = vs_base[0]->rat.rat_den; else vs_base[0] = small_fixnum(1); } void intdivrem(object x,object y,fixnum d,object *q,object *r) { enum type tx=type_of(x),ty=type_of(y); object z,q2,q1; if (number_zerop(y)==TRUE) zero_divisor(); switch(tx) { case t_fixnum: case t_bignum: switch (ty) { case t_fixnum: case t_bignum: integer_quotient_remainder_1(x,y,q,r,d); return; case t_ratio: z=integer_divide1(number_times(y->rat.rat_den,x),y->rat.rat_num,d); if (q) *q=z; if (r) *r=num_remainder(x,y,z); return; default: break; } break; case t_ratio: switch (ty) { case t_fixnum: case t_bignum: z=integer_divide1(x->rat.rat_num,number_times(x->rat.rat_den,y),d); if (q) *q=z; if (r) *r=num_remainder(x,y,z); return; case t_ratio: z=integer_divide1(number_times(x->rat.rat_num,y->rat.rat_den),number_times(x->rat.rat_den,y->rat.rat_num),d); if (q) *q=z; if (r) *r=num_remainder(x,y,z); return; default: break; } break; default: break; } q2=number_divide(x,y); q1=double_to_integer(number_to_double(q2)); if (d && (d<0 ? number_minusp(q2) : number_plusp(q2)) && number_compare(q2, q1)) q1 = d<0 ? one_minus(q1) : one_plus(q1); if (q) *q=q1; if (r) *r=num_remainder(x,y,q1); return; } object number_ldb(object x,object y) { return ifuncall2(sLldb,x,y); } object number_ldbt(object x,object y) { return ifuncall2(sLldb_test,x,y); } object number_dpb(object x,object y,object z) { return ifuncall3(sLdpb,x,y,z); } object number_dpf(object x,object y,object z) { return ifuncall3(sLdeposit_field,x,y,z); } LFD(Lfloor)(void) { object x, y; int n = vs_top - vs_base; if (n == 0) too_few_arguments(); if (n > 2) too_many_arguments(); x = vs_base[0]; y = n>1 ? vs_base[1] : small_fixnum(1); intdivrem(x,y,-1,&x,&y); vs_top=vs_base; vs_push(x); vs_push(y); } LFD(Lceiling)(void) { object x, y; int n = vs_top - vs_base; if (n == 0) too_few_arguments(); if (n > 2) too_many_arguments(); x = vs_base[0]; y = n>1 ? vs_base[1] : small_fixnum(1); intdivrem(x,y,1,&x,&y); vs_top=vs_base; vs_push(x); vs_push(y); } LFD(Ltruncate)(void) { object x, y; int n = vs_top - vs_base; if (n == 0) too_few_arguments(); if (n > 2) too_many_arguments(); x = vs_base[0]; y = n>1 ? vs_base[1] : small_fixnum(1); intdivrem(x,y,0,&x,&y); vs_top=vs_base; vs_push(x); vs_push(y); } LFD(Lround)(void) { object x, y, q, q1, r; double d; int n, c; object one_plus(object x), one_minus(object x); n = vs_top - vs_base; if (n == 0) too_few_arguments(); if (n > 1) goto TWO_ARG; x = vs_base[0]; switch (type_of(x)) { case t_fixnum: case t_bignum: vs_push(small_fixnum(0)); return; case t_ratio: q = x; y = small_fixnum(1); goto RATIO; case t_shortfloat: d = (double)(sf(x)); if (d >= 0.0) q = double_to_integer(d + 0.5); else q = double_to_integer(d - 0.5); d -= number_to_double(q); if (d == 0.5 && number_oddp(q)) { vs_push(q); q = one_plus(q); d = -0.5; } if (d == -0.5 && number_oddp(q)) { vs_push(q); q = one_minus(q); d = 0.5; } vs_base = vs_top; vs_push(q); vs_push(make_shortfloat((shortfloat)d)); return; case t_longfloat: d = lf(x); if (d >= 0.0) q = double_to_integer(d + 0.5); else q = double_to_integer(d - 0.5); d -= number_to_double(q); if (d == 0.5 && number_oddp(q)) { vs_push(q); q = one_plus(q); d = -0.5; } if (d == -0.5 && number_oddp(q)) { vs_push(q); q = one_minus(q); d = 0.5; } vs_base = vs_top; vs_push(q); vs_push(make_longfloat(d)); return; default: FEwrong_type_argument(TSor_rational_float, x); } TWO_ARG: if (n > 2) too_many_arguments(); x = vs_base[0]; y = vs_base[1]; check_type_or_rational_float(&vs_base[0]); check_type_or_rational_float(&vs_base[1]); q = number_divide(x, y); vs_push(q); switch (type_of(q)) { case t_fixnum: case t_bignum: vs_base = vs_top; vs_push(q); vs_push(small_fixnum(0)); break; case t_ratio: RATIO: q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den,0);/*FIXME*/ vs_push(q1); r = number_minus(q, q1); vs_push(r); if ((c = number_compare(r, plus_half)) > 0 || (c == 0 && number_oddp(q1))) q1 = one_plus(q1); if ((c = number_compare(r, minus_half)) < 0 || (c == 0 && number_oddp(q1))) q1 = one_minus(q1); vs_base = vs_top; vs_push(q1); vs_push(num_remainder(x, y, q1)); return; case t_shortfloat: case t_longfloat: d = number_to_double(q); if (d >= 0.0) q1 = double_to_integer(d + 0.5); else q1 = double_to_integer(d - 0.5); d -= number_to_double(q1); if (d == 0.5 && number_oddp(q1)) { vs_push(q1); q1 = one_plus(q1); } if (d == -0.5 && number_oddp(q1)) { vs_push(q1); q1 = one_minus(q1); } vs_base = vs_top; vs_push(q1); vs_push(num_remainder(x, y, q1)); return; default: break; } } LFD(Lmod)(void) { check_arg(2); intdivrem(vs_base[0],vs_base[1],-1,NULL,vs_base); vs_top=vs_base+1; } LFD(Lrem)(void) { check_arg(2); intdivrem(vs_base[0],vs_base[1],0,NULL,vs_base); vs_top=vs_base+1; } LFD(Ldecode_float)(void) { object x; double d; int e, s; check_arg(1); check_type_float(&vs_base[0]); x = vs_base[0]; if (type_of(x) == t_shortfloat) d = sf(x); else d = lf(x); if (d >= 0.0) s = 1; else { d = -d; s = -1; } e=0; if (!ISNORMAL(d)) { int hp,lp,sp; integer_decode_double(d,&hp,&lp,&e,&sp); if (hp!=0 || lp<0) d=number_to_double(bignum2(hp, lp)); else d=lp; } e += double_exponent(d); d = set_exponent(d, 0); vs_top = vs_base; if (type_of(x) == t_shortfloat) { vs_push(make_shortfloat((shortfloat)d)); vs_push(make_fixnum(e)); vs_push(make_shortfloat((shortfloat)s)); } else { vs_push(make_longfloat(d)); vs_push(make_fixnum(e)); vs_push(make_longfloat((double)s)); } } LFD(Lscale_float)(void) { object x; double d; int e, k=0; check_arg(2); check_type_float(&vs_base[0]); x = vs_base[0]; if (type_of(vs_base[1]) == t_fixnum) k = fix(vs_base[1]); else FEerror("~S is an illegal exponent.", 1, vs_base[1]); if (type_of(x) == t_shortfloat) d = sf(x); else d = lf(x); e = double_exponent(d) + k; #ifdef VAX if (e <= -128 || e >= 128) #endif #ifdef IBMRT #endif #ifdef IEEEFLOAT /* Upper bound not needed, handled by floating point overflow */ /* this checks if we're in the denormalized range */ if (!ISNORMAL(d) || (type_of(x) == t_shortfloat && e <= -126/* || e >= 130 */) || (type_of(x) == t_longfloat && (e <= -1022 /* || e >= 1026 */))) #endif #ifdef MV #endif #ifdef S3000 if (e < -64 || e >= 64) #endif /* FEerror("~S is an illegal exponent.", 1, vs_base[1]); */ { for (;k>0;d*=2.0,k--); for (;k<0;d*=0.5,k++); } else d = set_exponent(d, e); vs_popp; if (type_of(x) == t_shortfloat) vs_base[0] = make_shortfloat((shortfloat)d); else vs_base[0] = make_longfloat(d); } LFD(Lfloat_radix)(void) { check_arg(1); check_type_float(&vs_base[0]); #ifdef VAX vs_base[0] = small_fixnum(2); #endif #ifdef IBMRT #endif #ifdef IEEEFLOAT vs_base[0] = small_fixnum(2); #endif #ifdef MV #endif #ifdef S3000 vs_base[0] = small_fixnum(16); #endif } LFD(Lfloat_sign)(void) { object x; int narg; double d, f; narg = vs_top - vs_base; if (narg < 1) too_few_arguments(); else if (narg > 2) too_many_arguments(); check_type_float(&vs_base[0]); x = vs_base[0]; if (type_of(x) == t_shortfloat) d = sf(x); else d = lf(x); if (narg == 1) f = 1.0; else { check_type_float(&vs_base[1]); x = vs_base[1]; if (type_of(x) == t_shortfloat) f = sf(x); else f = lf(x); if (f < 0.0) f = -f; } if (d < 0.0) f = -f; vs_top = vs_base; if (type_of(x) == t_shortfloat) vs_push(make_shortfloat((shortfloat)f)); else vs_push(make_longfloat(f)); } LFD(Lfloat_digits)(void) { check_arg(1); check_type_float(&vs_base[0]); if (type_of(vs_base[0]) == t_shortfloat) vs_base[0] = small_fixnum(24); else vs_base[0] = small_fixnum(53); } LFD(Lfloat_precision)(void) { object x; check_arg(1); check_type_float(&vs_base[0]); x = vs_base[0]; if (type_of(x) == t_shortfloat) if (sf(x) == 0.0) vs_base[0] = small_fixnum(0); else vs_base[0] = small_fixnum(24); else if (lf(x) == 0.0) vs_base[0] = small_fixnum(0); else #ifdef VAX vs_base[0] = small_fixnum(53); #endif #ifdef IBMRT #endif #ifdef IEEEFLOAT vs_base[0] = small_fixnum(53); #endif #ifdef MV #endif #ifdef S3000 vs_base[0] = small_fixnum(53); #endif } LFD(Linteger_decode_float)(void) { object x; int h, l, e, s; check_arg(1); check_type_float(&vs_base[0]); x = vs_base[0]; vs_base = vs_top; if (type_of(x) == t_longfloat) { integer_decode_double(lf(x), &h, &l, &e, &s); if (h != 0 || l<0) vs_push(bignum2(h, l)); else vs_push(make_fixnum(l)); vs_push(make_fixnum(e)); vs_push(make_fixnum(s)); } else { integer_decode_float((double)(sf(x)), &h, &e, &s); vs_push(make_fixnum(h)); vs_push(make_fixnum(e)); vs_push(make_fixnum(s)); } } LFD(Lcomplex)(void) { object r, i; int narg; narg = vs_top - vs_base; if (narg < 1) too_few_arguments(); if (narg > 2) too_many_arguments(); check_type_or_rational_float(&vs_base[0]); r = vs_base[0]; if (narg == 1) i = small_fixnum(0); else { check_type_or_rational_float(&vs_base[1]); i = vs_base[1]; } vs_top = vs_base; vs_push(make_complex(r, i)); } LFD(Lrealpart)(void) { object x; check_arg(1); check_type_number(&vs_base[0]); x = vs_base[0]; if (type_of(x) == t_complex) vs_base[0] = x->cmp.cmp_real; } LFD(Limagpart)(void) { object x; check_arg(1); check_type_number(&vs_base[0]); x = vs_base[0]; switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: vs_base[0] = small_fixnum(0); break; case t_shortfloat: vs_base[0] = shortfloat_zero; break; case t_longfloat: vs_base[0] = longfloat_zero; break; case t_complex: vs_base[0] = x->cmp.cmp_imag; break; default: break; } } void gcl_init_num_co(void) { float smallest_float, smallest_norm_float, biggest_float; double smallest_double, smallest_norm_double, biggest_double; float float_epsilon, float_negative_epsilon; double double_epsilon, double_negative_epsilon; union {double d;int i[2];} u; union {float f;int i;} uf; #ifdef VAX l[0] = 0x80; l[1] = 0; smallest_float = *(float *)l; smallest_double = *(double *)l; #endif #ifdef IEEEFLOAT #ifdef NS32K #else uf.i=1; u.i[HIND]=0; u.i[LIND]=1; smallest_float=uf.f; smallest_double=u.d; /* ((int *) &smallest_float)[0]= 1; */ /* ((int *) &smallest_double)[HIND] = 0; */ /* ((int *) &smallest_double)[LIND] = 1; */ #endif #endif #ifdef MV #endif #ifdef S3000 l[0] = 0x00100000; l[1] = 0; smallest_float = *(float *)l; smallest_double = *(double *)l; #endif #ifdef VAX l[0] = 0xffff7fff; l[1] = 0xffffffff; biggest_float = *(float *)l; biggest_double = *(double *)l; #endif #ifdef IBMRT #endif #ifdef IEEEFLOAT #ifdef NS32K #else uf.i=0x7f7fffff; u.i[HIND]=0x7fefffff; u.i[LIND]=0xffffffff; biggest_float=uf.f; biggest_double=u.d; /* ((int *) &biggest_float)[0]= 0x7f7fffff; */ /* ((int *) &biggest_double)[HIND] = 0x7fefffff; */ /* ((int *) &biggest_double)[LIND] = 0xffffffff; */ #ifdef BAD_FPCHIP /* &&&& I am adding junk values to get past debugging */ biggest_float = 1.0e37; smallest_float = 1.0e-37; biggest_double = 1.0e308; smallest_double = 1.0e-308; printf("\n Used fake values for float max and mins "); #endif #endif #endif #if defined(S3000) && ~defined(DBL_MAX_10_EXP) l[0] = 0x7fffffff; l[1] = 0xffffffff; l[0] = 0x7fffffff; l[1] = 0xffffffff; biggest_float = *(float *)l; biggest_float = *(float *)l; biggest_float = *(float *)l; biggest_float = 0.0; biggest_float = biggest_float + 1.0; biggest_float = biggest_float + 2.0; biggest_float = *(float *)l; biggest_float = *(float *)l; strcmp("I don't like", "DATA GENERAL."); biggest_float = *(float *)l; biggest_double = *(double *)l; biggest_double = *(double *)l; biggest_double = *(double *)l; biggest_double = 0.0; biggest_double = biggest_double + 1.0; biggest_double = biggest_double + 2.0; biggest_double = *(double *)l; biggest_double = *(double *)l; strcmp("I don't like", "DATA GENERAL."); biggest_double = *(double *)l; #endif #ifdef DBL_MAX_10_EXP biggest_double = DBL_MAX; smallest_norm_double = DBL_MIN; smallest_norm_float = FLT_MIN; biggest_float = FLT_MAX; #endif { volatile double rd,dd,td,td1; volatile float rf,df,tf,tf1; int i,j; #define MAX 500 for (rf=1.0f,df=0.5f,i=j=0;ibv.bv_self[0] */ #define BV_BITS 8 #define BITREF(x,i) \ ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ ? 1 : 0) #define SET_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) #define CLEAR_BITREF(x,i) \ (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) extern short aet_sizes[]; #define ARRAY_BODY_PTR(ar,n) \ (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) #define N_FIXNUM_ARGS 6 DEFUNO("AREF", object, fLaref, LISP, 2, ARRAY_RANK_LIMIT, NONE, OO, II, II, II,Laref,"") (x, i, va_alist) object x; int i; { int n = VFUN_NARGS; int i1; va_list ap; if (type_of(x) == t_array) {int m,k ; int rank = n - 1; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",x); if (rank == 1) return fSaref1(x,i); va_start(ap); m = 0; k = i; /* index into 1 dimensional array */ i1 = 0; rank-- ; while(1) { if (k > x->a.a_dims[m]) FEerror("Index ~a to array is too large",1,make_fixnum (m)); i1 += k; if (m < rank) { i1 = i1 * x->a.a_dims[m]; if (m < N_FIXNUM_ARGS) { k = va_arg(ap,int);} else {object x = va_arg(ap,object); check_type(x,t_fixnum); k = Mfix(x);} m++;} else break;} va_end(ap); return fSaref1(x,i); } if (n > 2) { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} return fSaref1(x,i); } int fScheck_bounds_bounds(x, i) object x; int i; { switch (type_of(x)) { case t_array: case t_vector: case t_string: if ((unsigned int) i >= x->a.a_dim) FEerror("Array ref out of bounds ~a ~a", 2, x, make_fixnum(i)); default: FEerror("not an array"); } } DEFUN("SVREF", object, fLsvref, LISP, 2, 2, ONE_VAL, OO, IO, OO,OO, "For array X and index I it returns (aref x i) ") (x, i) object x; unsigned int i; { if (type_of(x)==t_vector && (enum aelttype)x->v.v_elttype == aet_object && x->v.v_dim > i) RETURN1(x->v.v_self[i]); if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); FEerror("Bad simple vector ~a",1,x); } DEFUN("AREF1", object, fSaref1, SI, 2, 2, ONE_VAL, OO, IO, OO,OO, "For array X and index I it returns (aref x i) as if x were \ 1 dimensional, even though its rank may be bigger than 1") (x, i) object x; int i; { switch (type_of(x)) { case t_array: case t_vector: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: return x->v.v_self[i]; case aet_ch: return code_char(x->st.st_self[i]); case aet_bit: i += x->bv.bv_offset; return make_fixnum(BITREF(x, i)); case aet_fix: return make_fixnum(x->fixa.fixa_self[i]); case aet_sf: return make_longfloat(x->sfa.sfa_self[i]); case aet_lf: return make_longfloat(x->lfa.lfa_self[i]); case aet_char: return make_fixnum(x->st.st_self[i]); case aet_uchar: return make_fixnum(x->ust.ust_self[i]); case aet_short: return make_fixnum(SHORT(x, i)); case aet_ushort: return make_fixnum(USHORT(x, i)); default: FEerror("unknown array type"); } case t_string: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); return code_char(x->st.st_self[i]); default: FEerror("not an array"); ; } } DEFUN("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,"") (x, i,val) object x; int i; object val; { switch (type_of(x)) { case t_array: case t_vector: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); switch (x->v.v_elttype) { case aet_object: x->v.v_self[i] = val; break; case aet_ch: ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; case aet_bit: i += x->bv.bv_offset; AGAIN_BIT: ASSURE_TYPE(val,t_fixnum); {int v = Mfix(val); if (v == 0) CLEAR_BITREF(x,i); else if (v == 1) SET_BITREF(x,i); else {val= fSincorrect_type(val,sLbit); goto AGAIN_BIT;} break;} case aet_fix: ASSURE_TYPE(val,t_fixnum); (x->fixa.fixa_self[i]) = Mfix(val); break; case aet_sf: ASSURE_TYPE(val,t_shortfloat); (x->sfa.sfa_self[i]) = Msf(val); break; case aet_lf: ASSURE_TYPE(val,t_longfloat); (x->lfa.lfa_self[i]) = Mlf(val); break; case aet_char: ASSURE_TYPE(val,t_fixnum); x->st.st_self[i] = Mfix(val); break; case aet_uchar: ASSURE_TYPE(val,t_fixnum); (x->ust.ust_self[i])= Mfix(val); break; case aet_short: ASSURE_TYPE(val,t_fixnum); SHORT(x, i) = Mfix(val); break; case aet_ushort: ASSURE_TYPE(val,t_fixnum); USHORT(x, i) = Mfix(val); break; default: FEerror("unknown array type"); } break; case t_string: if (x->v.v_dim <= i) i = fScheck_bounds_bounds(x, i); ASSURE_TYPE(val,t_character); x->st.st_self[i] = char_code(val); break; default: FEerror("not an array",0); } return val; } DEFUNO("ASET", object, fSaset, SI, 3, ARG_LIMIT, NONE, OO, IO, OO, OO,siLaset,"") (x,i,y, va_alist) object x,y; int i; va_dcl { int i1; int n = VFUN_NARGS; va_list ap; if (type_of(x) == t_array) {int m,k ; int rank = n - 2; if (x->a.a_rank != rank) FEerror(" ~a has wrong rank",x); if (rank == 1) return fSaset1(x,i,y); va_start(ap); m = 0; k = i; /* index into 1 dimensional array body */ i1 = 0; rank-- ; while(1) { if (k >= x->a.a_dims[m]) FEerror("Index ~a to array is too large",1,make_fixnum (m)); i1 += k; if (m < rank) {object u; if (m == 0) { u = y;} else { u = va_arg(ap,object);} check_type(u,t_fixnum); k = Mfix(u); m++ ; i1 = i1 * x->a.a_dims[m]; } else { y = va_arg(ap,object); break ;} } va_end(ap); } else { i1 = i ;} return fSaset1(x,i1,y); } DEFUNO("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, OO,siLsvset,"") (x,i,val) object x,val; int i; { if (TYPE_OF(x) != t_vector || DISPLACED_TO(x) != Cnil) Wrong_type_error("simple array",0); if (i > x->v.v_dim) { FEerror("out of bounds",0); } return x->v.v_self[i] = val; } /* (proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) (defun make-vector1 (n elt-type staticp &optional fillp initial-element displaced-to (displaced-index-offset 0)) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, IO,OO,OO,"") (n,elt_type,staticp,va_alist) int n;int elt_type;object staticp;va_dcl { int displaced_index_offset; int Inargs = VFUN_NARGS - 3; va_list Iap;object fillp;object initial_element;object displaced_to;object V9; object V10,V11,V12,V13,V14; Inargs = VFUN_NARGS - 3 ; { object x; BEGIN_NO_INTERRUPT; switch(elt_type) { case aet_ch: x = alloc_object(t_string); goto a_string; break; case aet_bit: x = alloc_object(t_bitvector); break; default: x = alloc_object(t_vector);} x->v.v_elttype = elt_type; a_string: x->v.v_dim = n; x->v.v_self = 0; x->v.v_displaced = Cnil; if( --Inargs < 0)goto LA1; else { va_start(Iap); fillp=va_arg(Iap,object); if (fillp == Cnil) {x->v.v_hasfillp = 0; x->v.v_fillp = n; } else { ASSURE_TYPE(fillp,t_fixnum); x->v.v_fillp = Mfix(fillp); x->v.v_hasfillp = 1; if (x->v.v_fillp > n) FEerror("bad fillp",0); } va_end(Iap); } if( --Inargs < 0)goto LA2; else { initial_element=va_arg(Iap,object);} if( --Inargs < 0)goto LA4; else { displaced_to=va_arg(Iap,object);} if( --Inargs < 0)goto LA5; else { V9=va_arg(Iap,object); if (displaced_to != Cnil) { ASSURE_TYPE(V9,t_fixnum); displaced_index_offset=Mfix(V9);}} goto LA6; LA1: x->v.v_hasfillp = 0; x->v.v_fillp = n; LA2: initial_element=Cnil; LA4: displaced_to=Cnil; LA5: displaced_index_offset= 0; LA6: x->v.v_adjustable = 1; { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } } } static object DFLT_aet_object = Cnil; static char DFLT_aet_ch = ' '; static char DFLT_aet_char = 0; static int DFLT_aet_fix = 0 ; static short DFLT_aet_short = 0; static shortfloat DFLT_aet_sf = 0.0; static longfloat DFLT_aet_lf = 0.0; static object Iname_t = sLt; struct { char * dflt; object *namep;} aet_types[] = { (char *) &DFLT_aet_object, &Iname_t, /* t */ (char *) &DFLT_aet_ch, &sLstring_char,/* string-char */ (char *) &DFLT_aet_fix, &sLbit, /* bit */ (char *) &DFLT_aet_fix, &sLfixnum, /* fixnum */ (char *) &DFLT_aet_sf, &sLshort_float, /* short-float */ (char *) &DFLT_aet_lf, &sLlong_float, /* long-float */ (char *) &DFLT_aet_char,&sLsigned_char, /* signed char */ (char *) &DFLT_aet_char,&sLunsigned_char, /* unsigned char */ (char *) &DFLT_aet_short,&sLsigned_short, /* signed short */ (char *) &DFLT_aet_short, &sLunsigned_short /* unsigned short */ }; DEFUN("GET-AELTTYPE",enum aelttype,fSget_aelttype,SI,1,1,NONE,IO,OO,OO,OO,"") (x) object x; { int i; for (i=0 ; i < aet_last ; i++) if (x == * aet_types[i].namep) return (enum aelttype) i; if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) return aet_lf; return aet_object; } /* backward compatibility only: (si:make-vector element-type 0 dimension 1 adjustable 2 fill-pointer 3 displaced-to 4 displaced-index-offset 5 static 6 &optional initial-element) */ DEFUNO("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, OO,OO,OO,OO,siLmake_vector,"")(x0,x1,x2,x3,x4,x5,x6,va_alist) object x0,x1,x2,x3,x4,x5,x6; va_dcl {int narg=VFUN_NARGS; object initial_elt; va_list ap; object x; {va_start(ap); if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; goto LEND_VARARG; LDEFAULT8: initial_elt = Cnil ; LEND_VARARG: va_end(ap);} /* 8 args */ VFUN_NARGS = 8; x = fSmake_vector1(Mfix(x1), /* n */ fSget_aelttype(x0), /*aelt type */ x6, /* staticp */ x3, /* fillp */ initial_elt, /* initial element */ x4, /*displaced to */ x5); /* displaced-index offset */ x0 = x; RETURN1(x0); } /* (proclaim '(ftype (function (fixnum t *)) make-array1)) (defun make-array1 ( elt-type staticp initial-element displaced-to displaced-index-offset &optional dim1 dim2 .. ) (declare (fixnum n elt-type displaced-index-offset)) */ DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, NONE,OI,OO,OI,OO,"") (elt_type,staticp,initial_element,displaced_to, displaced_index_offset, dimensions) int elt_type; object staticp,initial_element,displaced_to; int displaced_index_offset; object dimensions; { int rank = length(dimensions); { object x,v; char *tmp_alloc; int dim =1,i; BEGIN_NO_INTERRUPT; x = alloc_object(t_array); x->a.a_elttype = elt_type; x->a.a_self = 0; x->a.a_rank = rank; x->a.a_displaced = Cnil; x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); i = 0; v = dimensions; while (i < rank) { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); dim *= x->a.a_dims[i++]; v = Mcdr(v);} x->a.a_dim = dim; x->a.a_adjustable = 1; { if (displaced_to == Cnil) array_allocself(x,staticp!=Cnil,initial_element); else { displace(x,displaced_to,displaced_index_offset);} END_NO_INTERRUPT; return x; } }} /* (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) ;{ A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) */ displace(from_array,dest_array,offset) object from_array,dest_array; int offset; { enum aelttype typ; IisArray(from_array); IisArray(dest_array); typ =Iarray_element_type(from_array); if (typ != Iarray_element_type(dest_array)) { Wrong_type_error("same element type",0); } if (offset + from_array->a.a_dim > dest_array->a.a_dim) { FEerror("Destination array too small to hold other array",0); } /* ensure that we have a cons */ if (dest_array->a.a_displaced == Cnil) { dest_array->a.a_displaced = list(2,Cnil,from_array);} else Mcdr(dest_array->a.a_displaced) = make_cons(from_array, Mcdr(dest_array->a.a_displaced)); from_array->a.a_displaced = make_cons(dest_array,sLnil); /* now set the actual body of from_array to be the address of body in dest_array. If it is a bit array, this cannot carry the offset information, since the body is only recorded as multiples of BV_BITS */ if (typ == aet_bit) { offset += dest_array->bv.bv_offset; from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; from_array->bv.bv_offset = offset % BV_BITS; } else from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); } enum aelttype Iarray_element_type(x) object x; {enum aelttype t; switch(TYPE_OF(x)) { case t_array: t = (enum aelttype) x->a.a_elttype; break; case t_vector: t = (enum aelttype) x->v.v_elttype; break; case t_bitvector: t = aet_bit; break; case t_string: t = aet_ch; break; default: FEerror("Not an array ~a ",1,x); } return t; } /* Make the body of FROM array point to the body of TO at the DISPLACED_INDEX_OFFSET */ Idisplace_array(from,to,displaced_index_offset) object from,to; int displaced_index_offset; { enum aelttype t1,t2; object tail; t1 = Iarray_element_type(from); t2 = Iarray_element_type(to); if (t1 != t2) FEerror("Attempt to displace arrays of one type to arrays of another type",0); if (to->a.a_dim > from->a.a_dim - displaced_index_offset) FEerror("To array not large enough for displacement",0); {BEGIN_NO_INTERRUPT; from->a.a_displaced = make_cons(to,Cnil); if (to->a.a_displaced == Cnil) to->a.a_displaced = make_cons(Cnil,Cnil); DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); if (t1 == aet_bit) { displaced_index_offset += to->bv.bv_offset; from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; from->bv.bv_offset = displaced_index_offset%BV_BITS; } else from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); END_NO_INTERRUPT; } } /* add diff to body of x and arrays diisplaced to it */ adjust_displaced(x, diff) object x; int diff; { if (x->ust.ust_self != NULL) x->ust.ust_self = (char *)((int)(x->a.a_self) + diff); for (x = Mcdr(x->ust.ust_displaced); x != Cnil; x = Mcdr(x)) adjust_displaced(Mcar(x), diff); } /* RAW_AET_PTR returns a pointer to something of raw type obtained from X suitable for using GSET for an array of elt type TYP. If x is the null pointer, return a default for that array element type. */ char * raw_aet_ptr(x,typ) short typ; object x; { /* doubles are the largest raw type */ static double u; if (x==Cnil) return aet_types[typ].dflt; switch (typ){ #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; case aet_object: STORE_TYPED(&u,object,x); case aet_ch: STORE_TYPED(&u,char, char_code(x)); case aet_bit: STORE_TYPED(&u,fixnum, -Mfix(x)); case aet_fix: STORE_TYPED(&u,fixnum, Mfix(x)); case aet_sf: STORE_TYPED(&u,shortfloat, Msf(x)); case aet_lf: STORE_TYPED(&u,longfloat, Mlf(x)); case aet_char: STORE_TYPED(&u, char, Mfix(x)); case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x)); case aet_short: STORE_TYPED(&u, short, Mfix(x)); case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x)); default: FEerror("bad elttype",0); } return (char *)&u; } /* GSET copies into array ptr P1, the value pointed to by the ptr VAL into the next N slots. The array type is typ. If VAL is the null ptr, use the default for that element type NOTE: for type aet_bit n is the number of Words ie (nbits +WSIZE-1)/WSIZE and the words are set. */ gset(p1,val,n,typ) char *p1,*val; int n; int typ; { if (val==0) val = aet_types[typ].dflt; switch (typ){ #define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} #define GSET1(p,n,typ,val) while (n-- > 0) \ { *((typ *) p) = val; \ p = p + sizeof(typ); \ } break; case aet_object: GSET(p1,n,object,val); case aet_ch: GSET(p1,n,char,val); /* Note n is number of fixnum WORDS for bit */ case aet_bit: GSET(p1,n,fixnum,val); case aet_fix: GSET(p1,n,fixnum,val); case aet_sf: GSET(p1,n,shortfloat,val); case aet_lf: GSET(p1,n,longfloat,val); case aet_char: GSET(p1,n,char,val); case aet_uchar: GSET(p1,n,unsigned char,val); case aet_short: GSET(p1,n,short,val); case aet_ushort: GSET(p1,n,unsigned short,val); default: FEerror("bad elttype",0); } } #define W_SIZE (BV_BITS*sizeof(fixnum)) /* */ DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, 5,NONE,OO,OI,II,OO, "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ elements if N1 is supplied otherwise, doing the length of X - I1 \ elements. If the types of the arrays are not the same, this has \ implementation dependent results.") (x,y,i1,i2,n1) object x,y; int i1,i2,n1; { enum aelttype typ1=Iarray_element_type(x); enum aelttype typ2=Iarray_element_type(y); int nc; if (VFUN_NARGS==4) { n1 = x->v.v_dim - i1;} if (typ1==aet_bit) {if (i1 % CHAR_SIZE) badcopy: FEerror("Bit copies only if aligned"); else {int rest=n1%CHAR_SIZE; if (rest!=0 ) {if (typ2!=aet_bit) goto badcopy; {while(rest> 0) { fSaset1(y,i2+n1-rest,(fSaref1(x,i1+n1-rest))); rest--;} }} i1=i1/CHAR_SIZE ; n1=n1/CHAR_SIZE; typ1=aet_char; }}; if (typ2==aet_bit) {if (i2 % CHAR_SIZE) goto badcopy; i2=i2/CHAR_SIZE ;} if ((typ1 ==aet_object || typ2 ==aet_object) && typ1 != typ2) FEerror("Can't copy between different array types"); nc=n1 * aet_sizes[(int)typ1]; if (i1+n1 > x->a.a_dim || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) FEerror("Copy out of bounds"); bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), y->ust.ust_self + (i2*aet_sizes[(int)typ2]), nc); return x; } /* X is the header of an array. This supplies the body which will not be relocatable if STATICP. If DFLT is 0, do not initialize (the caller promises to reset these before the next gc!). If DFLT == Cnil then initialize to default type for this array type. Otherwise DFLT is an object and its value is used to init the array */ array_allocself(x, staticp, dflt) object x,dflt; int staticp; { int i, d,n; char *(*fun)(),*tmp_alloc; enum aelttype typ; fun = (staticp ? alloc_contblock : alloc_relblock); { /* this must be called from within no interrupt code */ n = x->a.a_dim; typ = Iarray_element_type(x); switch (typ) { case aet_object: x->a.a_self = AR_ALLOC(*fun,n,object); break; case aet_ch: case aet_char: case aet_uchar: x->st.st_self = AR_ALLOC(*fun,n,char); break; case aet_short: case aet_ushort: x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); break; case aet_bit: n = (n+W_SIZE-1)/W_SIZE; x->bv.bv_offset = 0; case aet_fix: x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); break; case aet_sf: x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); break; case aet_lf: x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); break; } if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); } } DEFUNO("FILL-POINTER-SET",int,fSfill_pointer_set,SI,2,2, NONE,IO,IO,OO,OO,siLfill_pointer_set,"") (x,i) object x; int i; { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} if (i < 0 || i > x->a.a_dim) { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} x->v.v_fillp = i; return i; no_fillp: FEerror("~a does not have a fill pointer",1,x); return 0; } DEFUNO("FILL-POINTER",int,fLfill_pointer,LISP,1,1,NONE,IO, OO,OO,OO,Lfill_pointer,"") (x) object x; { if (!(TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string)))) goto no_fillp; if (x->v.v_hasfillp == 0) { goto no_fillp;} return x->v.v_fillp ; no_fillp: FEerror("~a does not have a fill pointer",1,x); return 0; } DEFUN("ARRAY-HAS-FILL-POINTER-P",object, fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,"") (x) object x; { if (TS_MEMBER(type_of(x),TS(t_vector)| TS(t_bitvector)| TS(t_string))) return (x->v.v_hasfillp == 0 ? Cnil : sLt); else if (TYPE_OF(x) == t_array) { return Cnil;} else IisArray(x); return Cnil; } /* DEFUN("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; */ DEFUNO("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,"") (x) object x; { enum aelttype t; t = Iarray_element_type(x); return * aet_types[(int)t].namep; } DEFUNO("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,"") (x) object x; { return sLt; } DEFUNO("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, 1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,"") (x) object x; { IisArray(x); return (x->a.a_displaced == Cnil ? Cnil : sLt); } DEFUNO("ARRAY-RANK",int,fLarray_rank,LISP,1,1,NONE,IO,OO,OO, OO,Larray_rank,"") (x) object x; { if (type_of(x) == t_array) return x->a.a_rank; IisArray(x); return 1; } DEFUNO("ARRAY-DIMENSION",int,fLarray_dimension,LISP,2,2, NONE,IO,IO,OO,OO,Larray_dimension,"") (x,i) object x; int i; { if (type_of(x) == t_array) { if (i >= x->a.a_rank) FEerror("Index to large for array-dimension"); else { return x->a.a_dims[i];}} IisArray(x); return x->v.v_dim; } Icheck_displaced(displaced_list,ar,dim) object displaced_list,ar; int dim; { while (displaced_list!=Cnil) { object u = Mcar(displaced_list); if (u->a.a_self == NULL) continue; if ((Iarray_element_type(u) == aet_bit && (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + u->bv.bv_offset - ar->bv.bv_offset > 0) || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) FEerror("Bad displacement",0); Icheck_displaced(DISPLACED_FROM(u),ar,dim); displaced_list = Mcdr(displaced_list); } } /* (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) { A->displ = (B), B->displ=(nil A)} (setq w (make-array 3)) ;; w->displaced= (nil y u) (setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) (setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) (setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) (setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) Destroy the displacement from AR */ Iundisplace(ar) object ar; { object *p,x; if ((x = DISPLACED_TO(ar)) == Cnil || ar->a.a_displaced->d.m == FREE) return; {BEGIN_NO_INTERRUPT; DISPLACED_TO(ar) = Cnil; p = &(DISPLACED_FROM(x)) ; /* walk through the displaced from list and delete AR */ while(1) { if ((*p)->d.m == FREE || *p == Cnil) goto retur; if((Mcar(*p) == ar)) { *p = Mcdr(*p); goto retur;} p = &(Mcdr(*p)); } retur: END_NO_INTERRUPT; return; } } DEFUNO("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, OO,OO,OO,OO,siLreplace_array,"") (old,new) object old,new; { struct dummy fw ; fw = old->d; old = IisArray(old); if (TYPE_OF(old) != TYPE_OF(new) || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) { FAIL: FEerror("Cannot do array replacement ~a by ~a",2,old,new); } { int offset = new->ust.ust_self - old->ust.ust_self; object old_list = DISPLACED_FROM(old); object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); adjust_displaced(old,offset); /* Iundisplace(old); */ if (old->v.v_hasfillp) { new->v.v_hasfillp = 1; new->v.v_fillp = old->v.v_fillp;} if (TYPE_OF(old) == t_string) old->st = new->st; else old->a = new ->a; /* prevent having two arrays with the same body--which are not related that would cause the gc to try to copy both arrays and there might not be enough space. */ new->a.a_dim = 0; new->a.a_self = 0; old->d = fw; old->a.a_displaced = displaced; } return old; } DEFUNO("ARRAY-TOTAL-SIZE",int,fLarray_total_size,LISP,1,1, NONE,IO,OO,OO,OO,Larray_total_size,"") (x) object x; { x = IisArray(x); return x->a.a_dim; } DEFUNO("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, NONE,OO,OO,OO,OO,siLaset_by_cursor,"")(array,val,cursor) object array,val,cursor; { object endp_temp; object x; int i; object ind[ARRAY_RANK_LIMIT]; /* 3 args */ ind[0]=array; ind[1]=(object) Mfix(MMcar(cursor)); i = 2; for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) { ind[i++] = MMcar(x);} ind[i]=val; VFUN_NARGS=i+1; c_apply_n(fSaset,i+1,ind); RETURN1(array); } init_array_function(){;} gcl-2.6.14/o/rel_mac2.c0000755000175000017500000000474114360276512013072 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c */ relocate() { char *where; describe_sym(relocation_info.r_symndx); where = the_start + relocation_info.r_vaddr; dprintf (where has %x , *where); dprintf( at %x -->, where ); if (relocation_info.r_type == R_ABS) { dprintf( r_abs ,0) return; } switch(relocation_info.r_type) { int *q; case R_RELLONG: dprintf(new val r_rellong %x , *((int *)where) + symbol_table[relocation_info.r_symndx].n_value); *(int *)where= *((int *)where) + symbol_table[relocation_info.r_symndx].n_value; break; case R_RELWORD: dprintf(new val r_relword %x , *((short *)where) + symbol_table[relocation_info.r_symndx].n_value); *(short *)where= *((short *)where) + symbol_table[relocation_info.r_symndx].n_value; break; case R_PCRLONG: dprintf( r_pcrlong new value = %x , *((int *)where) - (int)start_address + symbol_table[relocation_info.r_symndx].n_value ); *(int *)where= *((int *)where) - (int)start_address + symbol_table[relocation_info.r_symndx].n_value; break; default: fprintf(stdout, "%d: unsupported relocation type.", relocation_info.r_type); FEerror("The relocation type was unknown",0,0); } } #ifdef DEBUG #define describe_sym describe_sym1 describe_sym1(n) int n; {char *str; char tem[9]; struct syment *sym; sym= &symbol_table[n]; str= sym->n_zeroes == 0 ? &my_string_table[sym->n_offset] : (sym->n_name[SYMNMLEN -1] ? /* MAKE IT NULL TERMINATED */ (strncpy(tem,sym->n_name, SYMNMLEN),tem): sym->n_name ); printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d \nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, symbol_table[n]._n._n_name, symbol_table[n]._n._n_n._n_zeroes , symbol_table[n]._n._n_n._n_offset , symbol_table[n]._n._n_nptr[0] , symbol_table[n]._n._n_nptr[1] , symbol_table[n].n_value , symbol_table[n].n_scnum , symbol_table[n].n_type , symbol_table[n].n_sclass , symbol_table[n].n_numaux ); } #endif gcl-2.6.14/o/gprof.c0000644000175000017500000000451314360276512012515 0ustar cammcamm#include #include "include.h" #include "page.h" #include "ptable.h" static unsigned long gprof_on; #ifdef DARWIN void _mcleanup() {} #endif DEFUN_NEW("MCLEANUP",object,fSmcleanup,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { extern void _mcleanup(void); if (!gprof_on) return Cnil; massert((_mcleanup(),1)); gprof_on=0; return make_simple_string("gmon.out"); } static inline int my_monstartup(unsigned long start,unsigned long end) { extern void monstartup(unsigned long,unsigned long); monstartup(start,end); return 0; } DEFUN_NEW("MONSTARTUP",object,fSmonstartup,SI,2,2,NONE,OI,IO,OO,OO,(ufixnum start,ufixnum end),"") { if (gprof_on) return Cnil; writable_malloc_wrap(my_monstartup,int,start,end); gprof_on=1; return Ct; } void gprof_cleanup(void) { FFN(fSmcleanup)(); } DEFUN_NEW("GPROF-ADDRESSES",object,fSgprof_addresses,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { void *min=heap_end,*max=data_start,*c; static void *mintext; struct pageinfo *v; object x; fixnum i; struct typemanager *tm=tm_of(t_cfdata); for (v=cell_list_head;v;v=v->next) if (v->type==tm->tm_type) for (c=pagetochar(page(v)),i=0;itm_nppage;i++,c+=tm->tm_size) if (!is_free((x=c)) && type_of(x)==t_cfdata && x->cfd.cfd_prof) { min=(void *)x->cfd.cfd_startcfd.cfd_start : min; max=(void *)x->cfd.cfd_start+x->cfd.cfd_size>max ? x->cfd.cfd_start+x->cfd.cfd_size : max; } if (maxst.st_self=(void *)c_table.ptable[i].string; s->st.st_fillp=s->st.st_dim=strlen(s->st.st_self); RETURN2(make_fixnum(c_table.ptable[i].address),s); } gcl-2.6.14/o/cfun.c0000755000175000017500000002130214360276512012331 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* cfun.c */ #include "include.h" #define dcheck_vs do{if (vs_base < vs_org || vs_top < vs_org) error("bad vs");} while (0) #define dcheck_type(a,b) check_type(a,b) ; dcheck_vs #define PADDR(i) ((void *)(long)(sSPinit->s.s_dbind->v.v_self[fix(i)])) object sSPinit,sSPmemory; object make_cfun(void (*self)(), object name, object data, char *start, int size) { object cf; cf = alloc_object(t_cfun); cf->cf.cf_self = self; cf->cf.cf_name = name; cf->cf.cf_data = data; if(data && type_of(data)==t_cfdata) { data->cfd.cfd_start=start; data->cfd.cfd_size=size;} else if(size) FEerror("Bad call to make_cfun",0); return(cf); } object make_sfun(object name, object (*self)(), int argd, object data) /* object (*self)(); */ {object sfn; sfn = alloc_object(t_sfun); if(argd >15) sfn->d.t = (int)t_gfun; sfn->sfn.sfn_self = self; sfn->sfn.sfn_name = name; sfn->sfn.sfn_data = data; sfn->sfn.sfn_argd = argd; return(sfn); } #define VFUN_MIN_ARGS(argd) (argd & 0xff) #define VFUN_MAX_ARGS(argd) ((argd) >> 8) static object make_vfun(object name, object (*self)(), int argd, object data) {object vfn; vfn = alloc_object(t_vfun); vfn->vfn.vfn_self = self; vfn->vfn.vfn_name = name; vfn->vfn.vfn_minargs = VFUN_MIN_ARGS(argd); vfn->vfn.vfn_maxargs = VFUN_MAX_ARGS(argd); vfn->vfn.vfn_data = data; return(vfn); } object make_cclosure_new(void (*self)(), object name, object env, object data) { object cc; cc = alloc_object(t_cclosure); cc->cc.cc_self = self; cc->cc.cc_name = name; cc->cc.cc_env = env; cc->cc.cc_data = data; cc->cc.cc_turbo = NULL; turbo_closure(cc); return(cc); } object make_cclosure(void (*self)(), object name, object env, object data, char *start, int size) { if(data && type_of(data)==t_cfdata) { data->cfd.cfd_start=start; data->cfd.cfd_size=size;} else if(size) FEerror("Bad call to make_cclosure",0); return make_cclosure_new(self,name,env,data); } DEFUN_NEW("MC",object,fSmc,SI ,2,2,NONE,OO,OO,OO,OO,(object name,object address),"") { /* 2 args */ dcheck_type(name,t_symbol); dcheck_type(address,t_fixnum); dcheck_type(sSPmemory->s.s_dbind,t_cfdata); name=make_cclosure_new(PADDR(address),name,Cnil, sSPmemory->s.s_dbind); RETURN1(name); } static object MFsfun(object sym, object (*self)(), int argd, object data) {object sfn; if (type_of(sym)!=t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) sym->s.s_sfdef = NOT_SPECIAL; sfn = make_sfun(sym,self,argd,data); sym = clear_compiler_properties(sym,sfn); sym->s.s_gfdef = sfn; sym->s.s_mflag = FALSE; return sym; } DEFUN_NEW("MFSFUN",object,fSmfsfun,SI ,3,3,NONE,OO,OO,OO,OO,(object name,object address,object argd),"") { /* 3 args */ dcheck_type(address,t_fixnum); return MFsfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind);RETURN1(name); } static object MFvfun(object sym, object (*self)(), int argd, object data) {object vfn; if (type_of(sym)!=t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) sym->s.s_sfdef = NOT_SPECIAL; dcheck_type(data,t_cfdata); vfn = make_vfun(sym,self,argd,data); sym = clear_compiler_properties(sym,vfn); sym->s.s_gfdef = vfn; sym->s.s_mflag = FALSE; return sym; } DEFUN_NEW("MFVFUN",object,fSmfvfun,SI ,3,3,NONE,OO,OO,OO,OO,(object name,object address,object argd),"") { /* 3 args */ MFvfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind); RETURN1(name); } static object MFvfun_key(object sym, object (*self)(), int argd, object data, struct key *keys) {if (data) set_key_struct(keys,data); return MFvfun(sym,self,argd,data); } DEFUN_NEW("MFVFUN-KEY",object,fSmfvfun_key,SI ,4,4,NONE,OO,OO,OO,OO,(object symbol,object address,object argd,object keys),"") { /* 4 args */ MFvfun_key(symbol,PADDR(address),fix(argd),sSPmemory->s.s_dbind,PADDR(keys)); RETURN1(symbol); } static object MFnew(object sym, void (*self)(), object data) { object cf; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) sym->s.s_sfdef = NOT_SPECIAL; cf = alloc_object(t_cfun); cf->cf.cf_self = self; cf->cf.cf_name = sym; cf->cf.cf_data = data; sym = clear_compiler_properties(sym,cf); sym->s.s_gfdef = cf; sym->s.s_mflag = FALSE; return sym; } DEFUN_NEW("MF",object,fSmf,SI ,2,2,NONE,OO,OO,OO,OO,(object name,object addr),"") { /* 2 args */ MFnew(name,PADDR(addr),sSPmemory->s.s_dbind); RETURN1(name); } /* static object */ /* MF(object sym, void (*self)(), char *start, int size, object data) */ /* { if(data && type_of(data)==t_cfdata) */ /* { data->cfd.cfd_start=start; */ /* data->cfd.cfd_size=size;} */ /* else if(size) FEerror("Bad call to make_cfun",0); */ /* return(MFnew(sym,self,data)); */ /* } */ static object MM(object sym, void (*self)(), char *start, int size, object data) { object sfn; if (type_of(sym) != t_symbol) not_a_symbol(sym); if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) sym->s.s_sfdef = NOT_SPECIAL; sfn = alloc_object(t_sfun); sfn->sfn.sfn_self = (void *)self;/*FIXME*/ sfn->sfn.sfn_name = sym; sfn->sfn.sfn_data = data; sfn->sfn.sfn_argd=2; data->cfd.cfd_start=start; data->cfd.cfd_size=size; sym = clear_compiler_properties(sym,sfn); sym->s.s_gfdef = sfn; sym->s.s_mflag = TRUE; return sym; } DEFUN_NEW("MM",object,fSmm,SI ,2,2,NONE,OO,OO,OO,OO,(object name,object addr),"") { /* 2 args */ MM(name,PADDR(addr), /* bit wasteful to pass these in just to be reset to themselves..*/ sSPmemory->s.s_dbind->cfd.cfd_start, sSPmemory->s.s_dbind->cfd.cfd_size, sSPmemory->s.s_dbind );RETURN1(name); } object make_function_internal(char *s, void (*f)()) { object x; vs_mark; x = make_ordinary(s); vs_push(x); x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0); x->s.s_mflag = FALSE; vs_reset; return(x); } object make_si_sfun_internal(char *s, object (*f) (), int argd) { object x= make_si_ordinary(s); x->s.s_gfdef = make_sfun( x,f,argd, Cnil); x->s.s_mflag = FALSE; return(x); } /* static object */ /* make_si_vfun1(char *s, object (*f)(), int argd) */ /* { object x= make_si_ordinary(s); */ /* x->s.s_gfdef = make_vfun( x,f,argd, Cnil); */ /* x->s.s_mflag = FALSE; */ /* return(x); */ /* } */ object make_si_function_internal(char *s, void (*f)()) { object x; vs_mark; x = make_si_ordinary(s); vs_push(x); x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0); x->s.s_mflag = FALSE; vs_reset; return(x); } object make_special_form_internal(char *s, void (*f)()) { object x; x = make_ordinary(s); x->s.s_sfdef = f; return(x); } object make_si_special_form_internal(char *s, void (*f)()) { object x; x = make_si_ordinary(s); x->s.s_sfdef = f; return(x); } object make_macro_internal(char *s, void (*f)()) { object x; x = make_ordinary(s); x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0); x->s.s_mflag=TRUE; return(x); } DEFUN_NEW("COMPILED-FUNCTION-NAME",object,fScompiled_function_name,SI ,1,1,NONE,OO,OO,OO,OO,(object fun),"") { /* 1 args */ switch(type_of(fun)) { case t_cfun: case t_afun: case t_closure: case t_sfun: case t_vfun: case t_cclosure: case t_gfun: fun = fun->cf.cf_name; break; default: FEerror("~S is not a compiled-function.", 1, fun); }RETURN1(fun); } void turbo_closure(object fun) { object l,*block; int n; if(1)/*(fun->cc.cc_turbo==NULL)*/ {BEGIN_NO_INTERRUPT; for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) ; { block= AR_ALLOC(alloc_relblock,(1+n),object); *block=make_fixnum(n); fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) fun->cc.cc_turbo[n] = l;} END_NO_INTERRUPT; } } DEFUN_NEW("TURBO-CLOSURE",object,fSturbo_closure,SI ,1,1,NONE,OO,OO,OO,OO,(object funobj),"") { /* 1 args */ if (type_of(funobj) == t_cclosure) turbo_closure(funobj); RETURN1(funobj); } void gcl_init_cfun(void) { } gcl-2.6.14/o/unexaix.c0000644000175000017500000006135014360276512013063 0ustar cammcamm/* Modified by Andrew.Vignaux@comp.vuw.ac.nz to get it to work :-) */ /* Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */ /* * unexec.c - Convert a running program into an a.out file. * * Author: Spencer W. Thomas * Computer Science Dept. * University of Utah * Date: Tue Mar 2 1982 * Modified heavily since then. * * Updated for AIX 4.1.3 by Bill_Mann @ PraxisInt.com, Feb 1996 * As of AIX 4.1, text, data, and bss are pre-relocated by the binder in * such a way that the file can be mapped with code in one segment and * data/bss in another segment, without reading or copying the file, by * the AIX exec loader. Padding sections are omitted, nevertheless * small amounts of 'padding' still occurs between sections in the file. * As modified, this code handles both 3.2 and 4.1 conventions. * * Synopsis: * unexec (new_name, a_name, data_start, bss_start, entry_address) * char *new_name, *a_name; * unsigned data_start, bss_start, entry_address; * * Takes a snapshot of the program and makes an a.out format file in the * file named by the string argument new_name. * If a_name is non-NULL, the symbol table will be taken from the given file. * On some machines, an existing a_name file is required. * * The boundaries within the a.out file may be adjusted with the data_start * and bss_start arguments. Either or both may be given as 0 for defaults. * * Data_start gives the boundary between the text segment and the data * segment of the program. The text segment can contain shared, read-only * program code and literal data, while the data segment is always unshared * and unprotected. Data_start gives the lowest unprotected address. * The value you specify may be rounded down to a suitable boundary * as required by the machine you are using. * * Specifying zero for data_start means the boundary between text and data * should not be the same as when the program was loaded. * If NO_REMAP is defined, the argument data_start is ignored and the * segment boundaries are never changed. * * Bss_start indicates how much of the data segment is to be saved in the * a.out file and restored when the program is executed. It gives the lowest * unsaved address, and is rounded up to a page boundary. The default when 0 * is given assumes that the entire data segment is to be stored, including * the previous data and bss as well as any additional storage allocated with * break (2). * * The new file is set up to start at entry_address. * * If you make improvements I'd like to get them too. * harpo!utah-cs!thomas, thomas@Utah-20 * */ /* There are several compilation parameters affecting unexec: * COFF Define this if your system uses COFF for executables. Otherwise we assume you use Berkeley format. * NO_REMAP Define this if you do not want to try to save Emacs's pure data areas as part of the text segment. Saving them as text is good because it allows users to share more. However, on machines that locate the text area far from the data area, the boundary cannot feasibly be moved. Such machines require NO_REMAP. Also, remapping can cause trouble with the built-in startup routine /lib/crt0.o, which defines `environ' as an initialized variable. Dumping `environ' as pure does not work! So, to use remapping, you must write a startup routine for your machine in Emacs's crt0.c. If NO_REMAP is defined, Emacs uses the system's crt0.o. * SECTION_ALIGNMENT Some machines that use COFF executables require that each section start on a certain boundary *in the COFF file*. Such machines should define SECTION_ALIGNMENT to a mask of the low-order bits that must be zero on such a boundary. This mask is used to control padding between segments in the COFF file. If SECTION_ALIGNMENT is not defined, the segments are written consecutively with no attempt at alignment. This is right for unmodified system V. * SEGMENT_MASK Some machines require that the beginnings and ends of segments *in core* be on certain boundaries. For most machines, a page boundary is sufficient. That is the default. When a larger boundary is needed, define SEGMENT_MASK to a mask of the bits that must be zero on such a boundary. * A_TEXT_OFFSET(HDR) Some machines count the a.out header as part of the size of the text segment (a_text); they may actually load the header into core as the first data in the text segment. Some have additional padding between the header and the real text of the program that is counted in a_text. For these machines, define A_TEXT_OFFSET(HDR) to examine the header structure HDR and return the number of bytes to add to `a_text' before writing it (above and beyond the number of bytes of actual program text). HDR's standard fields are already correct, except that this adjustment to the `a_text' field has not yet been made; thus, the amount of offset can depend on the data in the file. * A_TEXT_SEEK(HDR) If defined, this macro specifies the number of bytes to seek into the a.out file before starting to write the text segment.a * EXEC_MAGIC For machines using COFF, this macro, if defined, is a value stored into the magic number field of the output file. * ADJUST_EXEC_HEADER This macro can be used to generate statements to adjust or initialize nonstandard fields in the file header * ADDR_CORRECT(ADDR) Macro to correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This macro has a default definition which is usually right. This default definition is a no-op on most machines (where a pointer looks like an int) but not on all machines. */ #define XCOFF #define COFF #define NO_REMAP #ifndef emacs #define PERROR(arg) perror (arg); return -1 #else #include "config.h" #define PERROR(file) report_error (file, new) #endif #include /* Define getpagesize () if the system does not. Note that this may depend on symbols defined in a.out.h */ #include "getpagesize.h" #ifndef makedev /* Try to detect types.h already loaded */ #include #endif #include #include #include extern char *start_of_text (); /* Start of text */ extern char *start_of_data (); /* Start of initialized data */ extern int _data; extern int _edata; extern int _text; extern int _etext; extern int _end; #ifdef COFF #ifndef USG #ifndef STRIDE #ifndef UMAX #ifndef sun386 /* I have a suspicion that these are turned off on all systems and can be deleted. Try it in version 19. */ #include #include #include #include #endif /* not sun386 */ #endif /* not UMAX */ #endif /* Not STRIDE */ #endif /* not USG */ static struct filehdr f_hdr; /* File header */ static struct aouthdr f_ohdr; /* Optional file header (a.out) */ long bias; /* Bias to add for growth */ long lnnoptr; /* Pointer to line-number info within file */ static long text_scnptr; static long data_scnptr; #ifdef XCOFF #define ALIGN(val, pwr) (((val) + ((1L<<(pwr))-1)) & ~((1L<<(pwr))-1)) static long load_scnptr; static long orig_load_scnptr; static long orig_data_scnptr; #endif static ulong data_st; /* start of data area written out */ #ifndef MAX_SECTIONS #define MAX_SECTIONS 10 #endif #endif /* COFF */ static int pagemask; /* Correct an int which is the bit pattern of a pointer to a byte into an int which is the number of a byte. This is a no-op on ordinary machines, but not on all. */ #ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ #define ADDR_CORRECT(x) ((char *)(x) - (char*)0) #endif #ifdef emacs #include "lisp.h" static report_error (file, fd) char *file; int fd; { if (fd) close (fd); report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); } #endif /* emacs */ #define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 #define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 #define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 static report_error_1 (fd, msg, a1, a2) int fd; char *msg; int a1, a2; { close (fd); #ifdef emacs error (msg, a1, a2); #else fprintf (stderr, msg, a1, a2); fprintf (stderr, "\n"); #endif } static int make_hdr (); static int mark_x (); static int copy_text_and_data (); static int copy_sym (); /* **************************************************************** * unexec * * driving logic. */ unexec (new_name, a_name, data_start, bss_start, entry_address) char *new_name, *a_name; unsigned data_start, bss_start, entry_address; { int new, a_out = -1; if (a_name && (a_out = open (a_name, 0)) < 0) { PERROR (a_name); } if ((new = creat (new_name, 0666)) < 0) { PERROR (new_name); } if (make_hdr (new,a_out,data_start,bss_start,entry_address,a_name,new_name) < 0 || copy_text_and_data (new) < 0 || copy_sym (new, a_out, a_name, new_name) < 0 #ifdef COFF || adjust_lnnoptrs (new, a_out, new_name) < 0 #endif #ifdef XCOFF || unrelocate_symbols (new, a_out, a_name, new_name) < 0 #endif ) { close (new); return -1; } close (new); if (a_out >= 0) close (a_out); mark_x (new_name); return 0; } /* **************************************************************** * make_hdr * * Make the header in the new a.out from the header in core. * Modify the text and data sizes. */ static int make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) int new, a_out; unsigned data_start, bss_start, entry_address; char *a_name; char *new_name; { register int scns; unsigned int bss_end; struct scnhdr section[MAX_SECTIONS]; struct scnhdr * f_thdr; /* Text section header */ struct scnhdr * f_dhdr; /* Data section header */ struct scnhdr * f_bhdr; /* Bss section header */ struct scnhdr * f_lhdr; /* Loader section header */ struct scnhdr * f_tchdr; /* Typechk section header */ struct scnhdr * f_dbhdr; /* Debug section header */ struct scnhdr * f_xhdr; /* Except section header */ load_scnptr = orig_load_scnptr = lnnoptr = 0; pagemask = getpagesize () - 1; /* Adjust text/data boundary. */ #ifdef NO_REMAP data_start = (long) start_of_data (); #endif /* NO_REMAP */ data_start = ADDR_CORRECT (data_start); #ifdef SEGMENT_MASK data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ #else data_start = data_start & ~pagemask; /* (Down) to page boundary. */ #endif bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; bss_end &= ~ pagemask; /* Adjust data/bss boundary. */ if (bss_start != 0) { bss_start = (ADDR_CORRECT (bss_start) + pagemask); /* (Up) to page bdry. */ bss_start &= ~ pagemask; if (bss_start > bss_end) { ERROR1 ("unexec: Specified bss_start (%u) is past end of program", bss_start); } } else bss_start = bss_end; if (data_start > bss_start) /* Can't have negative data size. */ { ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", data_start, bss_start); } #ifdef COFF /* Salvage as much info from the existing file as possible */ f_thdr = NULL; f_dhdr = NULL; f_bhdr = NULL; f_lhdr = NULL; f_tchdr = NULL; f_dbhdr = NULL; f_xhdr = NULL; if (a_out >= 0) { if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (a_name); } if (f_hdr.f_opthdr > 0) { if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (a_name); } } if (f_hdr.f_nscns > MAX_SECTIONS) { ERROR0 ("unexec: too many section headers -- increase MAX_SECTIONS"); } /* Loop through section headers */ for (scns = 0; scns < f_hdr.f_nscns; scns++) { struct scnhdr *s = §ion[scns]; if (read (a_out, s, sizeof (*s)) != sizeof (*s)) { PERROR (a_name); } #define CHECK_SCNHDR(ptr, name, flags) \ if (strcmp(s->s_name, name) == 0) { \ if (s->s_flags != flags) { \ fprintf(stderr, "unexec: %lx flags where %x expected in %s section.\n", \ (unsigned long)s->s_flags, flags, name); \ } \ if (ptr) { \ fprintf(stderr, "unexec: duplicate section header for section %s.\n", \ name); \ } \ ptr = s; \ } CHECK_SCNHDR(f_thdr, _TEXT, STYP_TEXT); CHECK_SCNHDR(f_dhdr, _DATA, STYP_DATA); CHECK_SCNHDR(f_bhdr, _BSS, STYP_BSS); CHECK_SCNHDR(f_lhdr, _LOADER, STYP_LOADER); CHECK_SCNHDR(f_dbhdr, _DEBUG, STYP_DEBUG); CHECK_SCNHDR(f_tchdr, _TYPCHK, STYP_TYPCHK); CHECK_SCNHDR(f_xhdr, _EXCEPT, STYP_EXCEPT); } if (f_thdr == 0) { ERROR1 ("unexec: couldn't find \"%s\" section", _TEXT); } if (f_dhdr == 0) { ERROR1 ("unexec: couldn't find \"%s\" section", _DATA); } if (f_bhdr == 0) { ERROR1 ("unexec: couldn't find \"%s\" section", _BSS); } } else { ERROR0 ("can't build a COFF file from scratch yet"); } orig_data_scnptr = f_dhdr->s_scnptr; orig_load_scnptr = f_lhdr ? f_lhdr->s_scnptr : 0; /* Now we alter the contents of all the f_*hdr variables to correspond to what we want to dump. */ /* Indicate that the reloc information is no longer valid for ld (bind); we only update it enough to fake out the exec-time loader. */ f_hdr.f_flags |= (F_RELFLG | F_EXEC); #ifdef EXEC_MAGIC f_ohdr.magic = EXEC_MAGIC; #endif #ifndef NO_REMAP f_ohdr.tsize = data_start - f_ohdr.text_start; f_ohdr.text_start = (long) start_of_text (); #endif data_st = f_ohdr.data_start ? f_ohdr.data_start : (ulong) &_data; f_ohdr.dsize = bss_start - data_st; f_ohdr.bsize = bss_end - bss_start; f_dhdr->s_size = f_ohdr.dsize; f_bhdr->s_size = f_ohdr.bsize; f_bhdr->s_paddr = f_ohdr.data_start + f_ohdr.dsize; f_bhdr->s_vaddr = f_ohdr.data_start + f_ohdr.dsize; /* fix scnptr's */ { ulong ptr = section[0].s_scnptr; bias = -1; for (scns = 0; scns < f_hdr.f_nscns; scns++) { struct scnhdr *s = §ion[scns]; if (s->s_flags & STYP_PAD) /* .pad sections omitted in AIX 4.1 */ { /* * the text_start should probably be o_algntext but that doesn't * seem to change */ if (f_ohdr.text_start != 0) /* && scns != 0 */ { s->s_size = 512 - (ptr % 512); if (s->s_size == 512) s->s_size = 0; } s->s_scnptr = ptr; } else if (s->s_flags & STYP_DATA) s->s_scnptr = ptr; else if (!(s->s_flags & (STYP_TEXT | STYP_BSS))) { if (bias == -1) /* if first section after bss */ bias = ptr - s->s_scnptr; s->s_scnptr += bias; ptr = s->s_scnptr; } ptr = ptr + s->s_size; } } /* fix other pointers */ for (scns = 0; scns < f_hdr.f_nscns; scns++) { struct scnhdr *s = §ion[scns]; if (s->s_relptr != 0) { s->s_relptr += bias; } if (s->s_lnnoptr != 0) { if (lnnoptr == 0) lnnoptr = s->s_lnnoptr; s->s_lnnoptr += bias; } } if (f_hdr.f_symptr > 0L) { f_hdr.f_symptr += bias; } text_scnptr = f_thdr->s_scnptr; data_scnptr = f_dhdr->s_scnptr; load_scnptr = f_lhdr ? f_lhdr->s_scnptr : 0; #ifdef ADJUST_EXEC_HEADER ADJUST_EXEC_HEADER #endif /* ADJUST_EXEC_HEADER */ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) { PERROR (new_name); } if (f_hdr.f_opthdr > 0) { if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) { PERROR (new_name); } } for (scns = 0; scns < f_hdr.f_nscns; scns++) { struct scnhdr *s = §ion[scns]; if (write (new, s, sizeof (*s)) != sizeof (*s)) { PERROR (new_name); } } return (0); #endif /* COFF */ } /* **************************************************************** * * Copy the text and data segments from memory to the new a.out */ static int copy_text_and_data (new) int new; { register char *end; register char *ptr; lseek (new, (long) text_scnptr, 0); ptr = start_of_text () + text_scnptr; end = ptr + f_ohdr.tsize; write_segment (new, ptr, end); lseek (new, (long) data_scnptr, 0); ptr = (char *) data_st; end = ptr + f_ohdr.dsize; write_segment (new, ptr, end); return 0; } #define UnexBlockSz (1<<12) /* read/write block size */ write_segment (new, ptr, end) int new; register char *ptr, *end; { register int i, nwrite, ret; char buf[80]; extern int errno; char zeros[UnexBlockSz]; for (i = 0; ptr < end;) { /* distance to next block. */ nwrite = (((int) ptr + UnexBlockSz) & -UnexBlockSz) - (int) ptr; /* But not beyond specified end. */ if (nwrite > end - ptr) nwrite = end - ptr; ret = write (new, ptr, nwrite); /* If write gets a page fault, it means we reached a gap between the old text segment and the old data segment. This gap has probably been remapped into part of the text segment. So write zeros for it. */ if (ret == -1 && errno == EFAULT) { bzero (zeros, nwrite); write (new, zeros, nwrite); } else if (nwrite != ret) { sprintf (buf, "unexec write failure: addr 0x%lx, fileno %d, size 0x%x, wrote 0x%x, errno %d", (unsigned long)ptr, new, nwrite, ret, errno); PERROR (buf); } i += nwrite; ptr += nwrite; } } /* **************************************************************** * copy_sym * * Copy the relocation information and symbol table from the a.out to the new */ static int copy_sym (new, a_out, a_name, new_name) int new, a_out; char *a_name, *new_name; { char page[UnexBlockSz]; int n; if (a_out < 0) return 0; if (orig_load_scnptr == 0L) return 0; if (lnnoptr && lnnoptr < orig_load_scnptr) /* if there is line number info */ lseek (a_out, lnnoptr, 0); /* start copying from there */ else lseek (a_out, orig_load_scnptr, 0); /* Position a.out to symtab. */ while ((n = read (a_out, page, sizeof page)) > 0) { if (write (new, page, n) != n) { PERROR (new_name); } } if (n < 0) { PERROR (a_name); } return 0; } /* **************************************************************** * mark_x * * After successfully building the new a.out, mark it executable */ static int mark_x (name) char *name; { struct stat sbuf; int um; int new = 0; /* for PERROR */ um = umask (777); umask (um); if (stat (name, &sbuf) == -1) { PERROR (name); } sbuf.st_mode |= 0111 & ~um; if (chmod (name, sbuf.st_mode) == -1) PERROR (name); } /* * If the COFF file contains a symbol table and a line number section, * then any auxiliary entries that have values for x_lnnoptr must * be adjusted by the amount that the line number section has moved * in the file (bias computed in make_hdr). The #@$%&* designers of * the auxiliary entry structures used the absolute file offsets for * the line number entry rather than an offset from the start of the * line number section! * * When I figure out how to scan through the symbol table and pick out * the auxiliary entries that need adjustment, this routine will * be fixed. As it is now, all such entries are wrong and sdb * will complain. Fred Fish, UniSoft Systems Inc. * * I believe this is now fixed correctly. Bill Mann */ #ifdef COFF /* This function is probably very slow. Instead of reopening the new file for input and output it should copy from the old to the new using the two descriptors already open (WRITEDESC and READDESC). Instead of reading one small structure at a time it should use a reasonable size buffer. But I don't have time to work on such things, so I am installing it as submitted to me. -- RMS. */ adjust_lnnoptrs (writedesc, readdesc, new_name) int writedesc; int readdesc; char *new_name; { register int nsyms; register int naux; register int new; #ifdef amdahl_uts SYMENT symentry; AUXENT auxentry; #else struct syment symentry; union auxent auxentry; #endif if (!lnnoptr || !f_hdr.f_symptr) return 0; if ((new = open (new_name, 2)) < 0) { PERROR (new_name); return -1; } lseek (new, f_hdr.f_symptr, 0); for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) { read (new, &symentry, SYMESZ); if (symentry.n_sclass == C_BINCL || symentry.n_sclass == C_EINCL) { symentry.n_value += bias; lseek (new, -SYMESZ, 1); write (new, &symentry, SYMESZ); } for (naux = symentry.n_numaux; naux-- != 0; ) { read (new, &auxentry, AUXESZ); nsyms++; if (naux != 0 /* skip csect auxentry (last entry) */ && (symentry.n_sclass == C_EXT || symentry.n_sclass == C_HIDEXT)) { auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; lseek (new, -AUXESZ, 1); write (new, &auxentry, AUXESZ); } } } close (new); } #endif /* COFF */ #ifdef XCOFF /* It is probably a false economy to optimise this routine (it used to read one LDREL and do do two lseeks per iteration) but the wrath of RMS (see above :-) would be too much to bear */ unrelocate_symbols (new, a_out, a_name, new_name) int new, a_out; char *a_name, *new_name; { register int i; register int l; register LDREL *ldrel; LDHDR ldhdr; LDREL ldrel_buf [20]; ulong t_reloc = (ulong) &_text - f_ohdr.text_start; ulong d_reloc = (ulong) &_data - ALIGN(f_ohdr.data_start, 2); int * p; if (load_scnptr == 0) return 0; lseek (a_out, orig_load_scnptr, 0); if (read (a_out, &ldhdr, sizeof (ldhdr)) != sizeof (ldhdr)) { PERROR (new_name); } #define SYMNDX_TEXT 0 #define SYMNDX_DATA 1 #define SYMNDX_BSS 2 l = 0; for (i = 0; i < ldhdr.l_nreloc; i++, l--, ldrel++) { if (l == 0) { lseek (a_out, orig_load_scnptr + LDHDRSZ + LDSYMSZ*ldhdr.l_nsyms + LDRELSZ*i, 0); l = ldhdr.l_nreloc - i; if (l > sizeof (ldrel_buf) / LDRELSZ) l = sizeof (ldrel_buf) / LDRELSZ; if (read (a_out, ldrel_buf, l * LDRELSZ) != l * LDRELSZ) { PERROR (a_name); } ldrel = ldrel_buf; } /* move the BSS loader symbols to the DATA segment */ if (ldrel->l_symndx == SYMNDX_BSS) { ldrel->l_symndx = SYMNDX_DATA; lseek (new, load_scnptr + LDHDRSZ + LDSYMSZ*ldhdr.l_nsyms + LDRELSZ*i, 0); if (write (new, ldrel, LDRELSZ) != LDRELSZ) { PERROR (new_name); } } if (ldrel->l_rsecnm == f_ohdr.o_sndata) { int orig_int; lseek (a_out, orig_data_scnptr + (ldrel->l_vaddr - f_ohdr.data_start), 0); if (read (a_out, (void *) &orig_int, sizeof (orig_int)) != sizeof (orig_int)) { PERROR (a_name); } p = (int *) (ldrel->l_vaddr + d_reloc); switch (ldrel->l_symndx) { case SYMNDX_TEXT: orig_int = * p - t_reloc; break; case SYMNDX_DATA: case SYMNDX_BSS: orig_int = * p - d_reloc; break; } if (orig_int != * p) { lseek (new, data_scnptr + (ldrel->l_vaddr - f_ohdr.data_start), 0); if (write (new, (void *) &orig_int, sizeof (orig_int)) != sizeof (orig_int)) { PERROR (new_name); } } } } } #endif /* XCOFF */ #include "save.c" #include #define DATA_START DBEGIN char * start_of_data () { char buf[500]; struct ld_info * ld; loadquery(L_GETINFO,buf,sizeof(buf)); ld = (struct ld_info *)buf; return ld->ldinfo_dataorg; #ifdef DATA_START return ((char *) DATA_START); #else #ifdef ORDINARY_LINK /* * This is a hack. Since we're not linking crt0.c or pre_crt0.c, * data_start isn't defined. We take the address of environ, which * is known to live at or near the start of the system crt0.c, and * we don't sweat the handful of bytes that might lose. */ extern char **environ; return((char *) &environ); #else extern int data_start; return ((char *) &data_start); #endif /* ORDINARY_LINK */ #endif /* DATA_START */ } #define TEXT_START 0x10000000 char *start_of_text () { #ifdef TEXT_START return ((char *) TEXT_START); #else #ifdef GOULD extern csrt (); return ((char *) csrt); #else /* not GOULD */ extern int _start (); return ((char *) _start); #endif /* GOULD */ #endif /* TEXT_START */ } gcl-2.6.14/o/rel_rios.c0000755000175000017500000002023614360276512013221 0ustar cammcamm/* Copyright William Schelter. All rights reserved. This file does the low level relocation which tends to be very system dependent. It is included by the file sfasl.c */ typedef int (*FUNC)(); extern int akcltoc; extern int toc_start; static int current_toc; static int ptrgl_offset = 0; static int ptrgl_text; static int akcltoc_used=0; /* This is an alternating list of addresses x1,y1,x2,y2,... where relocation entries for changing value in address x1 shold be read as changing it in y1 */ static int toc_addresses_to_relocate [10]; static int *next_toc_addresses_to_relocate = toc_addresses_to_relocate ; static int akcltoc_thisload; static int begun_relocate = 0; static int set_rel_bits(address,bits,val) char *address; int val; int bits; { bits += 1; if ( bits <= 16) {unsigned short y = *(unsigned short *)address ; y = y & (~0 << bits) ; y |= (val & ~(~0 << bits)); *(unsigned short *)address = val; } else {unsigned int y = *(unsigned int *)address ; y = y & (~0 << bits) ; y |= (val & ~(~0 << bits)); *(unsigned int *)address = y; } } #ifdef AIX3 struct syment * get_symbol(name,scnum,sym_table,length) char *name; int scnum,length; struct syment *sym_table; { struct syment *end,*sym; char tem[SYMNMLEN +1]; char *na; end =sym_table + length; for(sym=sym_table; sym < end; sym += (NUM_AUX(sym) +1)) {if ((sym)->n_scnum == scnum) { na=SYM_NAME(sym); if (strcmp(name,na) == 0) {return sym;}}} return 0;} #endif /* aix3 */ /* 800b0000 l r0,0x0(r11) 90410014 st r2,0x14(r1) 7c0903a6 mtctr r0 804b0004 l r2,0x4(r11) 816b0008 l r11,0x8(r11) 4e800420 bctr */ int myptrgl[6] = { 0x800b0000, 0x90410014, 0x7c0903a6, 0x804b0004, 0x816b0008, 0x4e800420}; /* 7d8903a6 mtctr r12 4e800420 bctr */ static int jmp_r12[2] = { 0x7d8903a6, 0x4e800420}; #define SYM_SMC(sym) (((union auxent *)(sym+1))->x_csect.x_smclas) #define SYM_TOC_ADDR(sym) (((union auxent *)(sym+1))->x_csect.x_parmhash) /* #define SYM_USED(sym) (((union auxent *)(&sym[1]))->x_csect.x_snhash) */ #define TC_SYMBOL_P(sym) ((sym)->n_scnum == DATA_NSCN && NUM_AUX((sym)) && \ (SYM_SMC(sym) == XMC_TC0 || SYM_SMC(sym) == XMC_TC)) int FIXtemp ; static int intcmp2(x,y) int *x,*y; { return (*x - *y); } #define TOP6 (~0 << 26) #define BR_IN_DATA_P(x) (((x) & TOP6) == (DBEGIN & TOP6)) relocate() { struct syment *sym = &symbol_table[relocation_info.r_symndx]; char *where; describe_sym(relocation_info.r_symndx); where = the_start + relocation_info.r_vaddr; dprintf (where has %x , *(int *)where); dprintf( at %x -->, where ); if(begun_relocate == 0) {int n = next_toc_addresses_to_relocate - toc_addresses_to_relocate; begun_relocate = 1; FIXtemp = 0; /* dummy reference for export problem */ qsort((char *)toc_addresses_to_relocate, n/2 , 2*sizeof(int), intcmp2); next_toc_addresses_to_relocate = toc_addresses_to_relocate;} switch(RELOC_RTYPE(relocation_info)) { int *q; case R_TOC: /* TOC_ILodx */ set_rel_bits(where,RELOC_RLEN(relocation_info), sym->n_value - toc_start) ; break; case R_POS: /* Pos_Rel */ if (where == *next_toc_addresses_to_relocate) {where = next_toc_addresses_to_relocate [1]; next_toc_addresses_to_relocate += 2;} if ( sym->n_scnum == N_UNDEF || TC_SYMBOL_P(sym)) set_rel_bits(where,RELOC_RLEN(relocation_info), sym->n_value); else set_rel_bits(where,RELOC_RLEN(relocation_info), (*(int *)where)+ sym->n_value); break; case R_BR: /* Brn_Sel */ case R_RBR: /* Brn_Selx */ {int link_bit = ((((int *)where)[0]) & 1); if (((((int *)where)[0]) & TOP6 ) == 0x48000000) /* bl or b relative */ { if (((int *)where)[1] == 0x80410014) /* l r2,0x14(r1) */ {int x = SYM_TOC_ADDR(sym); if (x) { ((int *)where)[0] = 0x81820000 ; /* l r12,0x0(r2) */ set_rel_bits(where+2,15,x - toc_start); (((int *)where)[1] = 0x48000000); /* b relative */ set_rel_bits(where+4, 0x19, ((int) jmp_r12) - ((int) where + 4 )); ((int *)where)[1] |= link_bit; /* link bit */ break; } else /* must be ptrgl */ if (BR_IN_DATA_P(sym->n_value)) {set_rel_bits(where, 0x19, sym->n_value - (int) where); ((int *)where)[0] |= link_bit; /* link bit */ break;} } else if (BR_IN_DATA_P(sym->n_value)) {set_rel_bits(where, 0x19, sym->n_value - (int) where); ((int *)where)[0] |= link_bit; /* link bit */ break;}} else FEerror("The type of Br_sel was new ",0,0); } default: fprintf(stdout, "%d: unsupported relocation type.", RELOC_RTYPE(relocation_info) ); FEerror("The relocation type was unknown",0,0); } dprintf( %x,*(int *)where); } fix_undef_toc_address(answ,sym,str) char *str; struct syment *sym; struct node *answ; /* undefined sym */ { if (BR_IN_DATA_P(answ->address)) return; if (answ->tc_offset == 0) { answ->tc_offset = ( akcltoc + akcltoc_used - toc_start); * ((int *)( akcltoc + akcltoc_used)) = answ->address; akcltoc_used += sizeof(char *); } if (NUM_AUX(sym)) SYM_TOC_ADDR(sym) = (toc_start + answ->tc_offset); else printf("symbol should have aux entry"); return; } #ifdef DEBUG #undef describe_sym #define describe_sym(x) do{if(sfasldebug) describe_sym1(x);} while (0) describe_sym1(n) int n; {char *str; char tem[9]; struct syment *sym; sym= &symbol_table[n]; str= sym->n_zeroes == 0 ? &my_string_table[sym->n_offset] : (sym->n_name[SYMNMLEN -1] ? /* MAKE IT NULL TERMINATED */ (strncpy(tem,sym->n_name, SYMNMLEN),tem): sym->n_name ); printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, symbol_table[n]._n._n_name, symbol_table[n]._n._n_n._n_zeroes , symbol_table[n]._n._n_n._n_offset , symbol_table[n]._n._n_nptr[0] , symbol_table[n]._n._n_nptr[1] , symbol_table[n].n_value , symbol_table[n].n_scnum , symbol_table[n].n_type , symbol_table[n].n_sclass , symbol_table[n].n_numaux ); } #endif /* allocate toc space in the preallocated region starting at akcltoc. If a symbol already has a toc entry, use that instead */ setup_for_aix_load() { bzero(toc_addresses_to_relocate,sizeof(toc_addresses_to_relocate)); next_toc_addresses_to_relocate= toc_addresses_to_relocate; akcltoc_thisload = akcltoc + akcltoc_used; begun_relocate=0; } char * sym_name(sym) struct syment *sym; {static char tem[SYMNMLEN +1]; char *name; tem[SYMNMLEN] = '0'; name = SYM_NAME(sym); return name;} allocate_toc(sym) struct syment *sym; /* sym is a symbol in the data section with an aux entry */ { if (SYM_SMC(sym) == XMC_TC0) { sym->n_value = toc_start; return 1;} if (SYM_SMC(sym) == XMC_TC) {struct node *answ = find_sym(sym,0); if (answ && answ->tc_offset) { sym->n_value = toc_start + answ->tc_offset; return 1;} {char *na = sym_name(sym); #ifdef SYM_USED if (TC_SYMBOL_P(sym) && SYM_USED(sym) == 0) return 0; #endif if (answ == 0 && *na && *na != '_') printf("(strange TC synbol %s[%d])",na,sym - symbol_table);} {int old_value; (*next_toc_addresses_to_relocate++) = sym->n_value + start_address; sym->n_value = akcltoc + akcltoc_used; if (answ) answ->tc_offset = sym->n_value - toc_start; (*next_toc_addresses_to_relocate++) = sym->n_value; *((int *)(next_toc_addresses_to_relocate[-1])) = *((int *)(next_toc_addresses_to_relocate[-2])); akcltoc_used += sizeof(long int); if (next_toc_addresses_to_relocate - toc_addresses_to_relocate >= (sizeof(toc_addresses_to_relocate)/sizeof(int))) FEerror("ran out",0,0); if (akcltoc_used > 24000) FEerror("toc exhausted",0,0); return 1; }} return 0; } gcl-2.6.14/o/alloc.c0000644000175000017500000012452114360276512012474 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* alloc.c IMPLEMENTATION-DEPENDENT */ #include #include #include #include "include.h" #include "page.h" #ifdef HAVE_MPROTECT #include #endif static int t_from_type(object); #include "pool.h" DEFVAR("*AFTER-GBC-HOOK*",sSAafter_gbc_hookA,SI,sLnil,""); DEFVAR("*IGNORE-MAXIMUM-PAGES*",sSAignore_maximum_pagesA,SI,sLt,""); #define IGNORE_MAX_PAGES (sSAignore_maximum_pagesA ==0 || sSAignore_maximum_pagesA->s.s_dbind !=sLnil) static void call_after_gbc_hook(int t); #ifdef DEBUG_SBRK int debug; char * sbrk1(n) int n; {char *ans; if (debug){ printf("\n{sbrk(%d)",n); fflush(stdout);} ans= (char *)sbrk(n); if (debug){ printf("->[0x%x]", ans); fflush(stdout); printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0)); fflush(stdout);} return ans; } #define sbrk sbrk1 #endif /* DEBUG_SBRK */ long starting_hole_div=10; long starting_relb_heap_mult=2; long resv_pages=0; #ifdef BSD #include #include #ifdef RLIMIT_STACK struct rlimit data_rlimit; #endif #endif static inline void * bsearchleq(void *i,void *v1,size_t n,size_t s,int (*c)(const void *,const void *)) { ufixnum nn=n>>1; void *v=v1+nn*s; int j=c(i,v); if (nn) return !j ? v : (j>0 ? bsearchleq(i,v,n-nn,s,c) : bsearchleq(i,v1,nn,s,c)); else return j<=0 ? v : v+s; } object contblock_array=Cnil; static inline void expand_contblock_array(void) { if (contblock_array==Cnil) { contblock_array=fSmake_vector1_2(16,aet_fix,Cnil,make_fixnum(0)); contblock_array->v.v_self[0]=(object)&cb_pointer; enter_mark_origin(&contblock_array); } if (contblock_array->v.v_fillp==contblock_array->v.v_dim) { void *v=alloc_relblock(2*contblock_array->v.v_dim*sizeof(fixnum)); memcpy(v,contblock_array->v.v_self,contblock_array->v.v_dim*sizeof(fixnum)); contblock_array->v.v_self=v; contblock_array->v.v_dim*=2; } } static void contblock_array_push(void *p) { expand_contblock_array(); contblock_array->v.v_self[contblock_array->v.v_fillp]=p; contblock_array->v.v_fillp++; } static inline int acomp(const void *v1,const void *v2) { void *p1=*(void * const *)v1,*p2=*(void * const *)v2; return p1v.v_self,contblock_array->v.v_fillp,sizeof(*contblock_array->v.v_self),acomp); struct pageinfo *p=(void *)pp>(void *)contblock_array->v.v_self ? pp[-1] : NULL; return p && (void *)p+p->in_use*PAGESIZE>x ? p : NULL; } static inline void add_page_to_contblock_list(void *p,fixnum m) { struct pageinfo *pp=pageinfo(p); bzero(pp,sizeof(*pp)); pp->type=t_contiguous; pp->in_use=m; massert(pp->in_use==m); pp->magic=PAGE_MAGIC; contblock_array_push(p); bzero(pagetochar(page(pp)),CB_DATA_START(pp)-(void *)pagetochar(page(pp))); #ifdef SGC if (sgc_enabled && tm_table[t_contiguous].tm_sgc) { memset(CB_SGCF_START(pp),-1,CB_DATA_START(pp)-CB_SGCF_START(pp)); pp->sgc_flags=SGC_PAGE_FLAG; } #endif ncbpage+=m; insert_contblock(CB_DATA_START(pp),CB_DATA_END(pp)-CB_DATA_START(pp)); } int icomp(const void *v1,const void *v2) { const fixnum *f1=v1,*f2=v2; return *f1<*f2 ? -1 : *f1==*f2 ? 0 : +1; } void add_page_to_freelist(char *p, struct typemanager *tm) { short t,size; long fw; object x,xe,f; struct pageinfo *pp; t=tm->tm_type; size=tm->tm_size; pp=pageinfo(p); bzero(pp,sizeof(*pp)); pp->type=t; pp->magic=PAGE_MAGIC; if (cell_list_head==NULL) cell_list_tail=cell_list_head=pp; else if (pp > cell_list_tail) { cell_list_tail->next=pp; cell_list_tail=pp; } x= (object)pagetochar(page(p)); /* set_type_of(x,t); */ make_free(x); #ifdef SGC if (sgc_enabled && tm->tm_sgc) pp->sgc_flags=SGC_PAGE_FLAG; #ifndef SGC_WHOLE_PAGE if (TYPEWORD_TYPE_P(pp->type)) x->d.s=(sgc_enabled && tm->tm_sgc) ? SGC_RECENT : SGC_NORMAL; #endif /* array headers must be always writable, since a write to the body does not touch the header. It may be desirable if there are many arrays in a system to make the headers not writable, but just SGC_TOUCH the header each time you write to it. this is what is done with t_structure */ if (t==(tm_of(t_array)->tm_type)) pp->sgc_flags|=SGC_PERM_WRITABLE; #endif f=FREELIST_TAIL(tm); fw=x->fw; xe=(object)((void *)x+tm->tm_nppage*size); for (;xfw=fw; SET_LINK(f,x); } SET_LINK(f,OBJNULL); tm->tm_tail=f; tm->tm_nfree+=tm->tm_nppage; tm->tm_npage++; } static inline void maybe_reallocate_page(struct typemanager *ntm,ufixnum count) { void **y,**n; fixnum *pp,*pp1,*ppe,yp; struct typemanager *tm; fixnum i,j,e[t_end]; struct pageinfo *v; massert(pp1=pp=alloca(count*sizeof(*pp1))); ppe=pp1+count; for (v=cell_list_head;v && ppnext) { if (v->type>=t_end || (tm=tm_of(v->type))==ntm || #ifdef SGC (sgc_enabled && tm->tm_sgc && v->sgc_flags!=SGC_PAGE_FLAG) || #endif v->in_use) continue; count--; *pp++=page(v); } #define NEXT_LINK(a_) (void *)&((struct freelist *)*(a_))->f_link #define FREE_PAGE_P(yp_) bsearch(&(yp_),pp1,ppe-pp1,sizeof(*pp1),icomp) ppe=pp; bzero(e,sizeof(e)); for (pp=pp1;pptype]++; for (i=0;itm_nfree-=(j=tm->tm_nppage*e[i]); tm->tm_npage-=e[i]; set_tm_maxpage(tm,tm->tm_maxpage-e[i]); set_tm_maxpage(ntm,ntm->tm_maxpage+e[i]); for (y=(void *)&tm->tm_free;*y!=OBJNULL && j;) { for (;*y!=OBJNULL && (yp=page(*y)) && !FREE_PAGE_P(yp);y=NEXT_LINK(y)); if (*y!=OBJNULL) { for (n=NEXT_LINK(y),j--;*n!=OBJNULL && (yp=page(*n)) && FREE_PAGE_P(yp);n=NEXT_LINK(n),j--); *y=*n; } } massert(!j); } for (pp=pp1;ppnext; add_page_to_freelist(pagetochar(*pp),ntm); pagetoinfo(*pp)->next=pn; } } int reserve_pages_for_signal_handler=30; /* If (n >= 0 ) return pointer to n pages starting at heap end, These must come from the hole, so if that is exhausted you have to gc and move the hole. if (n < 0) return pointer to n pages starting at heap end, but don't worry about the hole. Basically just make sure the space is available from the Operating system. If not in_signal_handler then try to keep a minimum of reserve_pages_for_signal_handler pages on hand in the hole */ void empty_relblock(void) { object o=sSAleaf_collection_thresholdA->s.s_dbind; sSAleaf_collection_thresholdA->s.s_dbind=make_fixnum(0); for (;!rb_emptyp();) { tm_table[t_relocatable].tm_adjgbccnt--; GBC(t_relocatable); } sSAleaf_collection_thresholdA->s.s_dbind=o; } void setup_rb(bool preserve_rb_pointerp) { int lowp=rb_high(); update_pool(2*(nrbpage-page(rb_size()))); rb_start=new_rb_start; rb_end=rb_start+(nrbpage<>PAGEWIDTH))); } void resize_hole(ufixnum hp,enum type tp,bool in_placep) { char *start=rb_begin(),*new_start=heap_end+hp*PAGESIZE; ufixnum size=rb_pointer-start; #define OVERLAP(c_,t_,s_) ((t_)<(c_)+(s_) && (c_)<(t_)+(s_)) if (!in_placep && (rb_high() ? OVERLAP(start,new_start,size) : OVERLAP(start,new_start+(nrbpage<s.s_dbind != Cnil) emsg("[GC Toggling relblock when resizing hole to %lu]\n",hp); tm_table[t_relocatable].tm_adjgbccnt--; GBC(t_relocatable); return resize_hole(hp,tp,in_placep); } new_rb_start=new_start; if (!size || in_placep) setup_rb(in_placep); else { tm_of(tp)->tm_adjgbccnt--; GBC(tp); } } void * alloc_page(long n) { bool s=n<0; ufixnum nn=s ? -n : n; void *v,*e; if (!s) { if (nn>((rb_start-heap_end)>>PAGEWIDTH)) { fixnum d=available_pages-nn; d*=0.2; d=d<0.01*real_maxpage ? available_pages-nn : d; d=d<0 ? 0 : d; d=(available_pages/3)s.s_dbind != Cnil) emsg("[GC Hole overrun]\n"); resize_hole(d+nn,t_relocatable,0); } } e=heap_end; v=e+nn*PAGESIZE; if (!s) { heap_end=v; update_pool(nn); pool_check(); } else if (v>(void *)core_end) { massert(!mbrk(v)); core_end=v; } return(e); } #define MAX(a_,b_) ({fixnum _a=(a_),_b=(b_);_a<_b ? _b : _a;}) #define MIN(a_,b_) ({fixnum _a=(a_),_b=(b_);_a<_b ? _a : _b;}) struct pageinfo *cell_list_head=NULL,*cell_list_tail=NULL;; ufixnum sum_maxpages(void) { ufixnum i,j; for (i=t_start,j=0;itm_type==t_relocatable,j=tm->tm_maxpage,z=(n-j)*(r ? 2 : 1); if (z>available_pages) return 0; available_pages-=z; tm->tm_adjgbccnt*=((double)j+1)/(n+1); tm->tm_maxpage=n; /* massert(!check_avail_pages()); */ return 1; } object type_name(int t) { return make_simple_string(tm_table[(int)t].tm_name+1); } static void call_after_gbc_hook(int t) { if (sSAafter_gbc_hookA && sSAafter_gbc_hookA->s.s_dbind!= Cnil) { set_up_string_register(tm_table[(int)t].tm_name+1); ifuncall1(sSAafter_gbc_hookA->s.s_dbind,intern(string_register,system_package)); } } static fixnum grow_linear(fixnum old, fixnum fract, fixnum grow_min, fixnum grow_max,fixnum max_delt) { fixnum delt; delt=(old*(fract ? fract : 50))/100; delt= (grow_min && delt < grow_min ? grow_min: grow_max && delt > grow_max ? grow_max: delt); delt=delt>max_delt ? max_delt : delt; return old + delt; } /* GCL's traditional garbage collecting algorithm placed heavy emphasis on conserving memory. Maximum page allocations of each object type were only increased when the objects in use after GBC exceeded a certain percentage threshold of the current maximum. This allowed a situation in which a growing heap would experience significant performance degradation due to GBC runs triggered by types making only temporary allocations -- the rate of GBC calls would be constant while the cost for each GBC would grow with the size of the heap. We implement here a strategy designed to approximately optimize the product of the total GBC call rate times the cost or time taken for each GBC. The rate is approximated from the actual gbccounts so far experienced, while the cost is taken to be simply proportional to the heap size at present. This can be further tuned by taking into account the number of pointers in each object type in the future, but at present objects of several different types but having the same size are grouped together in the type manager table, so this step becomes more involved. After each GBC, we calculate the maximum of the function (gbc_rate_other_types + gbc_rate_this_type * current_maxpage/new_maxpage)*(sum_all_maxpages-current_maxpage+new_maxpage). If the benefit in the product from adopting the new_maxpage is greater than 5%, we adopt it, and adjust the gbccount for the new basis. Corrections are put in place for small GBC counts, and the possibility that GBC calls of only a single type are ever triggered, in which case the optimum new_maxpage would diverge in the simple analysis above. 20040403 CM */ DEFVAR("*OPTIMIZE-MAXIMUM-PAGES*",sSAoptimize_maximum_pagesA,SI,sLnil,""); #define OPTIMIZE_MAX_PAGES (sSAoptimize_maximum_pagesA ==0 || sSAoptimize_maximum_pagesA->s.s_dbind !=sLnil) DEFVAR("*NOTIFY-OPTIMIZE-MAXIMUM-PAGES*",sSAnotify_optimize_maximum_pagesA,SI,sLnil,""); static object exhausted_report(enum type t,struct typemanager *tm) { available_pages+=resv_pages; resv_pages=0; CEerror("Continues execution.", "The storage for ~A is exhausted. ~D pages allocated. Use ALLOCATE to expand the space.", 2, type_name(t), make_fixnum(tm->tm_npage)); call_after_gbc_hook(t); return alloc_object(t); } #ifdef SGC #define TOTAL_THIS_TYPE(tm) (tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage)) #else #define TOTAL_THIS_TYPE(tm) (tm->tm_nppage * tm->tm_npage) #endif static object cbv=Cnil; #define cbsrch1 ((struct contblock ***)cbv->v.v_self) #define cbsrche (cbsrch1+cbv->v.v_fillp) static inline void expand_contblock_index_space(void) { if (cbv==Cnil) { cbv=fSmake_vector1_2(16,aet_fix,Cnil,make_fixnum(0)); cbv->v.v_self[0]=(object)&cb_pointer; enter_mark_origin(&cbv); } if (cbv->v.v_fillp+1==cbv->v.v_dim) { void *v; object o=sSAleaf_collection_thresholdA->s.s_dbind; sSAleaf_collection_thresholdA->s.s_dbind=make_fixnum(-1); v=alloc_relblock(2*cbv->v.v_dim*sizeof(fixnum)); sSAleaf_collection_thresholdA->s.s_dbind=o; memcpy(v,cbv->v.v_self,cbv->v.v_dim*sizeof(fixnum)); cbv->v.v_self=v; cbv->v.v_dim*=2; } } static inline void * expand_contblock_index(struct contblock ***cbppp) { ufixnum i=cbppp-cbsrch1; expand_contblock_index_space(); cbppp=cbsrch1+i; memmove(cbppp+1,cbppp,(cbsrche-cbppp+1)*sizeof(*cbppp)); cbv->v.v_fillp++; return cbppp; } static inline void contract_contblock_index(struct contblock ***cbppp) { memmove(cbppp+1,cbppp+2,(cbsrche-cbppp-1)*sizeof(*cbppp)); cbv->v.v_fillp--; } static inline int cbcomp(const void *v1,const void *v2) { ufixnum u1=(**(struct contblock ** const *)v1)->cb_size; ufixnum u2=(**(struct contblock ** const *)v2)->cb_size; return u1cb_size==(**cbppp)->cb_size;cbpp=&cbp->cb_link,cbp=cbp->cb_link,k++); if (print) emsg("%lu %p %p %lu %lu\n",(unsigned long)(cbppp-cbsrch1),*cbppp,**cbppp,(**cbppp)->cb_size,k); } massert(cbppp==cbsrche); massert(*cbppp==cbpp); massert(!**cbppp); } void insert_contblock(void *p,ufixnum s) { struct contblock *cbp=p,**cbpp,***cbppp; cbpp=find_contblock(s,(void **)&cbppp); cbp->cb_size=s; cbp->cb_link=*cbpp; if ((!cbp->cb_link || cbp->cb_link->cb_size!=s)) { cbppp=expand_contblock_index(cbppp); cbppp[1]=&cbp->cb_link; } *cbpp=cbp; } static inline void delete_contblock(void *p,struct contblock **cbpp) { struct contblock ***cbppp=p; ufixnum s=(*cbpp)->cb_size; (*cbpp)=(*cbpp)->cb_link; if ((!(*cbpp) || (*cbpp)->cb_size!=s)) contract_contblock_index(cbppp); } void reset_contblock_freelist(void) { cb_pointer=NULL; cbv->v.v_fillp=0; } static inline void * alloc_from_freelist(struct typemanager *tm,fixnum n) { void *p; switch (tm->tm_type) { case t_contiguous: { void *pp; struct contblock **cbpp=find_contblock(n,&pp); if ((p=*cbpp)) { ufixnum s=(*cbpp)->cb_size; delete_contblock(pp,cbpp); if (nrb_end && rb_pointer+n>rb_limit && rb_pointer+nn) return ((rb_pointer+=n)-n); break; default: if ((p=tm->tm_free)!=OBJNULL) { tm->tm_free = OBJ_LINK(p); tm->tm_nfree--; return(p); } break; } return NULL; } static inline void grow_linear1(struct typemanager *tm) { if (!sSAoptimize_maximum_pagesA || sSAoptimize_maximum_pagesA->s.s_dbind==Cnil) { fixnum maxgro=resv_pages ? available_pages : 0; if (tm->tm_type==t_relocatable) maxgro>>=1; set_tm_maxpage(tm,grow_linear(tm->tm_npage,tm->tm_growth_percent,tm->tm_min_grow, tm->tm_max_grow,maxgro)); } } static inline int too_full_p(struct typemanager *tm) { fixnum i,j,k,pf=tm->tm_percent_free ? tm->tm_percent_free : 30; struct contblock *cbp; struct pageinfo *pi; switch (tm->tm_type) { case t_relocatable: return 100*(rb_limit-rb_pointer)cb_link) k+=cbp->cb_size; for (i=j=0;iv.v_fillp;i++) { pi=(void *)contblock_array->v.v_self[i]; #ifdef SGC if (!sgc_enabled || pi->sgc_flags&SGC_PAGE_FLAG) #endif j+=pi->in_use; } return 100*ktm_nfrees.s_dbind==Cnil) return tm->tm_npage+tpage(tm,n)>tm->tm_maxpage; if ((cpool=get_pool())<=gc_page_min*phys_pages) return FALSE; pp=gc_page_max*phys_pages; return page(recent_allocation)>(1.0+gc_alloc_min-(double)ufmin(cpool,pp)/pp)*data_pages() || 2*tpage(tm,n)>available_pages; } static inline void * alloc_after_gc(struct typemanager *tm,fixnum n) { if (do_gc_p(tm,n)) { switch (jmp_gmp) { case 0: /* not in gmp call*/ GBC(tm->tm_type); break; case 1: /* non-in-place gmp call*/ longjmp(gmp_jmp,tm->tm_type); break; case -1: /* in-place gmp call */ jmp_gmp=-tm->tm_type; break; default: break; } if (IGNORE_MAX_PAGES && too_full_p(tm)) grow_linear1(tm); call_after_gbc_hook(tm->tm_type); return alloc_from_freelist(tm,n); } else return NULL; } void add_pages(struct typemanager *tm,fixnum m) { switch (tm->tm_type) { case t_contiguous: add_page_to_contblock_list(alloc_page(m),m); break; case t_relocatable: if (rb_high() && m>((rb_start-heap_end)>>PAGEWIDTH)) { if (sSAnotify_gbcA->s.s_dbind != Cnil) emsg("[GC Moving relblock low before expanding relblock pages]\n"); tm_table[t_relocatable].tm_adjgbccnt--; GBC(t_relocatable); } nrbpage+=m; resize_hole(page(rb_start-heap_end)-(rb_high() ? m : 0),t_relocatable,1); break; default: { void *p=alloc_page(m),*pe=p+m*PAGESIZE; for (;ptm_npage+m>tm->tm_maxpage) { if (!IGNORE_MAX_PAGES) return NULL; grow_linear1(tm); if (tm->tm_npage+m>tm->tm_maxpage && !set_tm_maxpage(tm,tm->tm_npage+m)) return NULL; } add_pages(tm,m); return alloc_from_freelist(tm,n); } static inline void * alloc_after_reclaiming_pages(struct typemanager *tm,fixnum n) { fixnum m=tpage(tm,n),reloc_min; if (tm->tm_type>t_end) return NULL; reloc_min=npage(rb_pointer-rb_start); if (m<2*(nrbpage-reloc_min)) { set_tm_maxpage(tm_table+t_relocatable,reloc_min); nrbpage=reloc_min; tm_table[t_relocatable].tm_adjgbccnt--; GBC(t_relocatable); return alloc_after_adding_pages(tm,n); } if (tm->tm_type>=t_end) return NULL; maybe_reallocate_page(tm,tm->tm_percent_free*tm->tm_npage); return alloc_from_freelist(tm,n); } static inline void *alloc_mem(struct typemanager *,fixnum); #ifdef SGC static inline void * alloc_after_turning_off_sgc(struct typemanager *tm,fixnum n) { if (!sgc_enabled) return NULL; sgc_quit(); return alloc_mem(tm,n); } #endif static inline void * alloc_mem(struct typemanager *tm,fixnum n) { void *p; CHECK_INTERRUPT; recent_allocation+=n; if ((p=alloc_from_freelist(tm,n))) return p; if ((p=alloc_after_gc(tm,n))) return p; if ((p=alloc_after_adding_pages(tm,n))) return p; #ifdef SGC if ((p=alloc_after_turning_off_sgc(tm,n))) return p; #endif if ((p=alloc_after_reclaiming_pages(tm,n))) return p; return exhausted_report(tm->tm_type,tm); } object alloc_object(enum type t) { object obj; struct typemanager *tm=tm_of(t); obj=alloc_mem(tm,tm->tm_size); set_type_of(obj,t); pageinfo(obj)->in_use++; return(obj); } void * alloc_contblock(size_t n) { return alloc_mem(tm_of(t_contiguous),CEI(n,CPTR_SIZE)); } void * alloc_contblock_no_gc(size_t n,char *limit) { struct typemanager *tm=tm_of(t_contiguous); void *p; n=CEI(n,CPTR_SIZE); if ((p=alloc_from_freelist(tm,n))) return p; if (tpage(tm,n)<(limit-heap_end)>>PAGEWIDTH && (p=alloc_after_adding_pages(tm,n))) return p; return NULL; } void * alloc_code_space(size_t sz,ufixnum max_code_address) { void *v; sz=CEI(sz,CPTR_SIZE); if (sSAcode_block_reserveA && sSAcode_block_reserveA->s.s_dbind!=Cnil && sSAcode_block_reserveA->s.s_dbind->st.st_dim>=sz) { v=sSAcode_block_reserveA->s.s_dbind->st.st_self; sSAcode_block_reserveA->s.s_dbind->st.st_self+=sz; sSAcode_block_reserveA->s.s_dbind->st.st_dim-=sz; sSAcode_block_reserveA->s.s_dbind->st.st_fillp=sSAcode_block_reserveA->s.s_dbind->st.st_dim; } else v=alloc_contblock(sz); if (v && (unsigned long)(v+sz)s.s_dbind); return v; } void * alloc_relblock(size_t n) { return alloc_mem(tm_of(t_relocatable),CEI(n,PTR_ALIGN)); } static inline void load_cons(object p,object a,object d) { #ifdef WIDE_CONS set_type_of(p,t_cons); #endif p->c.c_cdr=SAFE_CDR(d); p->c.c_car=a; } object make_cons(object a,object d) { static struct typemanager *tm=tm_table+t_cons;/*FIXME*/ object obj=alloc_mem(tm,tm->tm_size); load_cons(obj,a,d); pageinfo(obj)->in_use++; return(obj); } object on_stack_cons(object x, object y) { object p = (object) alloca_val; load_cons(p,x,y); return p; } DEFUNM_NEW("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ),"") { struct typemanager *tm=(&tm_table[t_from_type(typ)]); tm = & tm_table[tm->tm_type]; if (tm->tm_type == t_relocatable) { tm->tm_npage = page(rb_size()); tm->tm_nfree = rb_limit -rb_pointer; } else if (tm->tm_type == t_contiguous) { int cbfree =0; struct contblock **cbpp; for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link) cbfree += (*cbpp)->cb_size ; tm->tm_nfree = cbfree; } RETURN(6,object,make_fixnum(tm->tm_nfree), (RV(make_fixnum(tm->tm_npage)), RV(make_fixnum(tm->tm_maxpage)), RV(make_fixnum(tm->tm_nppage)), RV(make_fixnum(tm->tm_gbccount)), RV(make_fixnum(tm->tm_npage*tm->tm_nppage-tm->tm_nfree)))); } #ifdef SGC_CONT_DEBUG extern void overlap_check(struct contblock *,struct contblock *); #endif DEFUN_NEW("PRINT-FREE-CONTBLOCK-LIST",object,fSprint_free_contblock_list,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { struct contblock *cbp,*cbp1; for (cbp=cb_pointer;cbp;cbp=cbp->cb_link) { printf("%p %lu\n",cbp,cbp->cb_size); for (cbp1=cbp;cbp1;cbp1=cbp1->cb_link) if ((void *)cbp+cbp->cb_size==(void *)cbp1 || (void *)cbp1+cbp1->cb_size==(void *)cbp) printf(" adjacent to %p %lu\n",cbp1,cbp1->cb_size); } return Cnil; } /* Add a tm_distinct field to prevent page type sharing if desired. Not used now, as its never desirable from an efficiency point of view, and as the only known place one must separate is cons and fixnum, which are of different sizes unless PTR_ALIGN is set too high (e.g. 16 on a 32bit machine). See the ordering of init_tm calls for these types below -- reversing would wind up merging the types with the current algorithm. CM 20030827 */ static void init_tm(enum type t, char *name, int elsize, int nelts, int sgc,int distinct) { int i, j; int maxpage; /* round up to next number of pages */ maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE); tm_table[(int)t].tm_name = name; j=-1; if (!distinct) for (i = 0; i < t_end; i++) if (tm_table[i].tm_size != 0 && tm_table[i].tm_size >= elsize && !tm_table[i].tm_distinct && (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size)) j = i; if (j >= 0) { tm_table[(int)t].tm_type = (enum type)j; set_tm_maxpage(tm_table+j,tm_table[j].tm_maxpage+maxpage); #ifdef SGC tm_table[j].tm_sgc += sgc; #endif return; } tm_table[(int)t].tm_type = t; tm_table[(int)t].tm_size = elsize ? CEI(elsize,PTR_ALIGN) : 1; tm_table[(int)t].tm_nppage = (PAGESIZE-sizeof(struct pageinfo))/tm_table[(int)t].tm_size; tm_table[(int)t].tm_free = OBJNULL; tm_table[(int)t].tm_nfree = 0; /* tm_table[(int)t].tm_nused = 0; */ /*tm_table[(int)t].tm_npage = 0; */ /* dont zero nrbpage.. */ set_tm_maxpage(tm_table+t,maxpage); tm_table[(int)t].tm_gbccount = 0; tm_table[(int)t].tm_adjgbccnt = 0; tm_table[(int)t].tm_opt_maxpage = 0; tm_table[(int)t].tm_distinct=distinct; #ifdef SGC tm_table[(int)t].tm_sgc = sgc; tm_table[(int)t].tm_sgc_max = 3000; tm_table[(int)t].tm_sgc_minfree = (0.4 * tm_table[(int)t].tm_nppage); #endif } /* FIXME this is a work-around for the special MacOSX memory initialization sequence, which sets heap_end, traditionally initialized in gcl_init_alloc. Mac and windows have non-std sbrk-emulating memory subsystems, and their internals need to be homogenized and integrated into the traditional unix sequence for simplicity. set_maxpage is overloaded, and the positioning of its call is too fragile. 20050115 CM*/ static int gcl_alloc_initialized; object malloc_list=Cnil; #include void maybe_set_hole_from_maxpages(void) { if (rb_pointer==rb_begin()) resize_hole(ufmin(phys_pages,available_pages/3),t_relocatable,0); } void gcl_init_alloc(void *cs_start) { fixnum cssize=(1L<<23); prelink_init(); #ifdef RECREATE_HEAP if (!raw_image) RECREATE_HEAP; #endif #if defined(DARWIN) init_darwin_zone_compat (); #endif #if defined(BSD) && defined(RLIMIT_STACK) { struct rlimit rl; /* Maybe the soft limit for data segment size is lower than the * hard limit. In that case, we want as much as possible. */ massert(!getrlimit(RLIMIT_DATA, &rl)); if (rl.rlim_cur != RLIM_INFINITY && (rl.rlim_max == RLIM_INFINITY || rl.rlim_max > rl.rlim_cur)) { rl.rlim_cur = rl.rlim_max; massert(!setrlimit(RLIMIT_DATA, &rl)); } massert(!getrlimit(RLIMIT_STACK, &rl)); if (rl.rlim_cur!=RLIM_INFINITY && (rl.rlim_max == RLIM_INFINITY || rl.rlim_max > rl.rlim_cur)) { rl.rlim_cur = rl.rlim_max; massert(!setrlimit(RLIMIT_STACK,&rl)); } cssize = rl.rlim_cur/sizeof(*cs_org) - sizeof(*cs_org)*CSGETA; } #endif cs_org = cs_base = cs_start; cs_limit = cs_org + CSTACK_DIRECTION*cssize; #ifdef __ia64__ { extern void * __libc_ia64_register_backing_store_base; cs_org2=cs_base2=__libc_ia64_register_backing_store_base; } #endif #ifdef HAVE_SIGALTSTACK { /* make sure the stack is 8 byte aligned */ static double estack_buf[32*SIGSTKSZ]; static stack_t estack; estack.ss_sp = estack_buf; estack.ss_flags = 0; estack.ss_size = sizeof(estack_buf); massert(sigaltstack(&estack, 0)>=0); } #endif install_segmentation_catcher(); #ifdef HAVE_MPROTECT if (data_start) massert(!gcl_mprotect(data_start,(void *)core_end-data_start,PROT_READ|PROT_WRITE|PROT_EXEC)); #endif #ifdef SGC massert(getpagesize()<=PAGESIZE); memprotect_test_reset(); if (sgc_enabled) if (memory_protect(1)) sgc_quit(); #endif update_real_maxpage(); if (gcl_alloc_initialized) { maybe_set_hole_from_maxpages(); return; } #ifdef INIT_ALLOC INIT_ALLOC; #endif initial_sbrk=data_start=heap_end; first_data_page=page(data_start); /* Unused (at present) tm_distinct flag added. Note that if cons and fixnum share page types, errors will be introduced. Gave each page type at least some sgc pages by default. Of course changeable by allocate-sgc. CM 20030827 */ init_tm(t_cons, ".CONS", sizeof(struct cons), 0 ,50,0 ); init_tm(t_fixnum, "NFIXNUM",sizeof(struct fixnum_struct), 0,20,0); init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure),0,1,0 ); init_tm(t_cfun, "fCFUN", sizeof(struct cfun),0,1,0 ); init_tm(t_sfun, "gSFUN", sizeof(struct sfun),0,1,0 ); init_tm(t_string, "\"STRING", sizeof(struct string),0,1,0 ); init_tm(t_array, "aARRAY", sizeof(struct array),0,1,0 ); init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol),0,1,0 ); init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum),0,1,0 ); init_tm(t_ratio, "RRATIONAL", sizeof(struct ratio),0,1,0 ); init_tm(t_shortfloat, "FSHORT-FLOAT",sizeof(struct shortfloat_struct),0 ,1,0); init_tm(t_longfloat, "LLONG-FLOAT",sizeof(struct longfloat_struct),0 ,1,0); init_tm(t_complex, "CCOMPLEX", sizeof(struct ocomplex),0 ,1,0); init_tm(t_character,"#CHARACTER",sizeof(struct character),0 ,1,0); init_tm(t_package, ":PACKAGE", sizeof(struct package),0,1,0); init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable),0,1,0 ); init_tm(t_vector, "vVECTOR", sizeof(struct vector),0 ,1,0); init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct bitvector),0 ,1,0); init_tm(t_stream, "sSTREAM", sizeof(struct stream),0 ,1,0); init_tm(t_random, "$RANDOM-STATE", sizeof(struct random),0 ,1,0); init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable),0 ,1,0); init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname),0 ,1,0); init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure),0 ,1,0); init_tm(t_closure, "cCLOSURE", sizeof(struct closure),0 ,1,0); init_tm(t_vfun, "VVFUN", sizeof(struct vfun),0 ,1,0); init_tm(t_gfun, "gGFUN", sizeof(struct sfun), 0 ,1,0); init_tm(t_afun, "AAFUN", sizeof(struct sfun), 0 ,1,0); init_tm(t_cfdata, "cCFDATA", sizeof(struct cfdata),0 ,1,0); init_tm(t_spice, "!SPICE", sizeof(struct spice),0 ,1,0); init_tm(t_relocatable, "%RELOCATABLE-BLOCKS", 0,0,20,1); init_tm(t_contiguous, "_CONTIGUOUS-BLOCKS", 0,0,20,1); ncbpage = 0; tm_table[t_contiguous].tm_min_grow=256; set_tm_maxpage(tm_table+t_contiguous,1); set_tm_maxpage(tm_table+t_relocatable,1); nrbpage=0; maybe_set_hole_from_maxpages(); #ifdef SGC tm_table[(int)t_relocatable].tm_sgc = 50; #endif expand_contblock_index_space(); gcl_alloc_initialized=1; } DEFUN_NEW("STATICP",object,fSstaticp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"Tell if the string or vector is static") { RETURN1((inheap(x->ust.ust_self) ? sLt : sLnil)); } /* static void */ /* cant_get_a_type(void) { */ /* FEerror("Can't get a type.", 0); */ /* } */ static int t_from_type(object type) { int i; check_type_or_symbol_string(&type); for (i= t_start ; i < t_other ; i++) {struct typemanager *tm = &tm_table[i]; if(tm->tm_name && 0==strncmp((tm->tm_name)+1,type->st.st_self,type->st.st_fillp) ) return i;} FEerror("Unrecognized type",0); return i; } /* When sgc is enabled the TYPE should have at least MIN pages of sgc type, and at most MAX of them. Each page should be FREE_PERCENT free when the sgc is turned on. FREE_PERCENT is an integer between 0 and 100. */ DEFUN_NEW("ALLOCATE-SGC",object,fSallocate_sgc,SI ,4,4,NONE,OO,II,II,OO,(object type,fixnum min,fixnum max,fixnum free_percent),"") { int t=t_from_type(type); struct typemanager *tm; object res,x,x1,x2; tm=tm_of(t); x=make_fixnum(tm->tm_sgc); x1=make_fixnum(tm->tm_sgc_max); x2=make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage); res= list(3,x,x1,x2); if(min<0 || max< min || free_percent < 0 || free_percent > 100) goto END; tm->tm_sgc_max=max; tm->tm_sgc=min; tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100; END: RETURN1(res); } /* Growth of TYPE will be by at least MIN pages and at most MAX pages. It will try to grow PERCENT of the current pages. */ DEFUN_NEW("ALLOCATE-GROWTH",object,fSallocate_growth,SI,5,5,NONE,OO,II,II,OO, (object type,fixnum min,fixnum max,fixnum percent,fixnum percent_free),"") {int t=t_from_type(type); struct typemanager *tm=tm_of(t); object res,x,x1,x2,x3; x=make_fixnum(tm->tm_min_grow); x1=make_fixnum(tm->tm_max_grow); x2=make_fixnum(tm->tm_growth_percent); x3=make_fixnum(tm->tm_percent_free); res= list(4,x,x1,x2,x3); if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500 || percent_free <0 || percent_free > 100 ) goto END; tm->tm_max_grow=max; tm->tm_min_grow=min; tm->tm_growth_percent=percent; tm->tm_percent_free=percent_free; END: RETURN1(res); } DEFUN_NEW("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { int nargs=VFUN_NARGS; object really_do; va_list ap; fixnum npages=fixint(onpages); really_do=Cnil; if (nargs>=2) { va_start(ap,onpages); really_do=va_arg(ap,object); va_end(ap); } CHECK_ARG_RANGE(1,2); if (npages < 0) FEerror("Allocate requires positive argument.", 0); if (ncbpage > npages) npages=ncbpage; if (!set_tm_maxpage(tm_table+t_contiguous,npages)) FEerror("Can't allocate ~D pages for contiguous blocks.", 1, make_fixnum(npages)); if (really_do == Cnil) RETURN1(Ct); add_pages(tm_of(t_contiguous),npages - ncbpage); RETURN1(make_fixnum(npages)); } DEFUN_NEW("ALLOCATED-CONTIGUOUS-PAGES",object,fSallocated_contiguous_pages,SI ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(ncbpage))); } DEFUN_NEW("MAXIMUM-CONTIGUOUS-PAGES",object,fSmaximum_contiguous_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_fixnum(maxcbpage))); } DEFUN_NEW("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { int nargs=VFUN_NARGS; object really_do; va_list ap; fixnum npages=fixint(onpages); really_do=Cnil; if (nargs>=2) { va_start(ap,onpages); really_do=va_arg(ap,object); va_end(ap); } CHECK_ARG_RANGE(1,2); if (npages <= 0) FEerror("Requires positive arg",0); if (npages=3) { va_start(ap,onpages); really_do=va_arg(ap,object); va_end(ap); } CHECK_ARG_RANGE(2,3); t= t_from_type(type); if (t == t_contiguous) RETURN1(FUNCALL(2,FFN(fSallocate_contiguous_pages)(make_fixnum(npages),really_do))); else if (t==t_relocatable) RETURN1(FUNCALL(2,FFN(fSallocate_relocatable_pages)(make_fixnum(npages),really_do))); if (npages <= 0) FEerror("Allocate takes positive argument.", 1,make_fixnum(npages)); tm = tm_of(t); if (tm->tm_npage > npages) {npages=tm->tm_npage;} if (!set_tm_maxpage(tm,npages)) FEerror("Can't allocate ~D pages for ~A.", 2, make_fixnum(npages), (make_simple_string(tm->tm_name+1))); if (really_do == Cnil) RETURN1(Ct); add_pages(tm,npages - tm->tm_npage); RETURN1(make_fixnum(npages)); } DEFUN_NEW("ALLOCATED-RELOCATABLE-PAGES",object,fSallocated_relocatable_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1(make_fixnum(nrbpage)); } DEFUN_NEW("GET-HOLE-SIZE",object,fSget_hole_size,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1(make_fixnum((rb_start-heap_end)>>PAGEWIDTH)); } DEFUN_NEW("SET-STARTING-HOLE-DIVISOR",object,fSset_starting_hole_divisor,SI,1,1,NONE,II,OO,OO,OO,(fixnum div),"") { if (div>0 && div <100) starting_hole_div=div; return (object)starting_hole_div; } DEFUN_NEW("SET-STARTING-RELBLOCK-HEAP-MULTIPLE",object,fSset_starting_relb_heap_multiple,SI,1,1,NONE,II,OO,OO,OO,(fixnum mult),"") { if (mult>=0) starting_relb_heap_mult=mult; return (object)starting_relb_heap_mult; } DEFUNM_NEW("SET-HOLE-SIZE",object,fSset_hole_size,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { RETURN2(make_fixnum((rb_start-heap_end)>>PAGEWIDTH),make_fixnum(reserve_pages_for_signal_handler)); } void gcl_init_alloc_function(void) { enter_mark_origin(&malloc_list); } #ifndef DONT_NEED_MALLOC /* UNIX malloc simulator. Used by getwd, popen, etc. */ /* If this is defined, substitute the fast gnu malloc for the slower version below. If you have many calls to malloc this is worth your while. I have only tested it slightly under 4.3Bsd. There the difference in a test run with 120K mallocs and frees, was 29 seconds to 1.9 seconds */ #ifdef GNU_MALLOC #include "malloc.c" #else /* a very young malloc may use this simple baby malloc, for the init code before we even get to main.c. If this is not defined, then malloc will try to run the init code which will work on many machines but some such as WindowsNT under cygwin need this. */ #ifdef BABY_MALLOC_SIZE /* by giving an initialization, make it not be in bss, since bss may not get loaded until main is reached. We may not even know our own name at this stage. */ static char baby_malloc_data[BABY_MALLOC_SIZE]={1,0}; static char *last_baby= baby_malloc_data; static char *baby_malloc(n) int n; { char *res= last_baby; int m; n = CEI(n,PTR_ALIGN); m = n+ sizeof(int); if ((res +m-baby_malloc_data) > sizeof(baby_malloc_data)) { printf("failed in baby malloc"); do_gcl_abort(); } last_baby += m; *((int *)res)=n; return res+sizeof(int); } #endif /* #ifdef HAVE_LIBBFD */ /* int in_bfd_init=0; */ /* configure size, static init ? */ /* static char bfd_buf[32768]; */ /* static char *bfd_buf_p=bfd_buf; */ /* static void * */ /* bfd_malloc(int n) { */ /* char *c; */ /* c=bfd_buf_p; */ /* n+=7; */ /* n>>=3; */ /* n<<=3; */ /* if (c+n>bfd_buf+sizeof(bfd_buf)) { */ /* fprintf(stderr,"Not enough space in bfd_buf %d %d\n",n,sizeof(bfd_buf)-(bfd_buf_p-bfd_buf)); */ /* exit(1); */ /* } */ /* bfd_buf_p+=n; */ /* return (void *)c; */ /* } */ /* #endif */ bool writable_malloc=0; static void * malloc_internal(size_t size) { #ifdef CAN_UNRANDOMIZE_SBRK if (core_end && core_end!=sbrk(0))/*malloc before main in saved_image*/ return sbrk(size);/*will never get to gcl_init_alloc, so brk point irrelevant*/ #endif if (!gcl_alloc_initialized) { static bool recursive_malloc; if (recursive_malloc) error("Bad malloc"); recursive_malloc=1; gcl_init_alloc(&size); recursive_malloc=0; } CHECK_INTERRUPT; malloc_list = make_cons(alloc_simple_string(size), malloc_list); malloc_list->c.c_car->st.st_self = alloc_contblock(size); malloc_list->c.c_car->st.st_adjustable=writable_malloc; return(malloc_list->c.c_car->st.st_self); } void * malloc(size_t size) { return malloc_internal(size); } void free(void *ptr) { object *p,pp; if (ptr == 0) return; for (p = &malloc_list,pp=*p; pp && !endp(pp); p = &((pp)->c.c_cdr),pp=pp->c.c_cdr) if ((pp)->c.c_car->st.st_self == ptr) { (pp)->c.c_car->st.st_self = NULL; *p = pp->c.c_cdr; return; } { static void *old_ptr; if (old_ptr==ptr) return; old_ptr=ptr; #ifndef NOFREE_ERR FEerror("free(3) error.",0); #endif } return; } void * realloc(void *ptr, size_t size) { object x; int i; /* was allocated by baby_malloc */ #ifdef BABY_MALLOC_SIZE if (ptr >= (void*)baby_malloc_data && ptr - (void*)baby_malloc_data size) return ptr; else { char *new= malloc(size); bcopy(ptr,new,dim); return new; } } #endif /* BABY_MALLOC_SIZE */ if(ptr == NULL) return malloc(size); for (x = malloc_list; !endp(x); x = x->c.c_cdr) if (x->c.c_car->st.st_self == ptr) { x = x->c.c_car; if (x->st.st_dim >= size) { x->st.st_fillp = size; return(ptr); } else { x->st.st_self = alloc_contblock(size); x->st.st_fillp = x->st.st_dim = size; for (i = 0; i < size; i++) x->st.st_self[i] = ((char *)ptr)[i]; return(x->st.st_self); } } FEerror("realloc(3) error.", 0); return NULL; } #endif /* gnumalloc */ void * calloc(size_t nelem, size_t elsize) { char *ptr; long i; ptr = malloc(i = nelem*elsize); while (--i >= 0) ptr[i] = 0; return(ptr); } void cfree(void *ptr) { free(ptr); } #endif #ifndef GNUMALLOC #ifdef WANT_VALLOC static void * memalign(size_t align,size_t size) { object x = alloc_simple_string(size); x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align); malloc_list = make_cons(x, malloc_list); return x->st.st_self; } void * valloc(size_t size) { return memalign(getpagesize(),size);} #endif #endif gcl-2.6.14/o/sgi4d_emul.s0000755000175000017500000000241314360276512013454 0ustar cammcamm#include /* earith.s for MIPS R2000 processor by Doug Katzman version 2.1.d dated 7/13/89 15:31 EDT */ # mods 7/13/89: # emul: never conditionally branch # ediv: improved code ordering allows jmp delay slot optimization by 'as' # .text .align 2 .globl extended_mul # extended_mul(d, q, r, hp, lp) # unsigned int d, q, r, *hp, *lp; # { .ent extended_mul extended_mul: .frame sp, 0, ra mult a0, a1 # [hi:lo] = d * q mfhi a1 sll a1, 1 mflo a0 srl t7, a0, 31 and a0, 0x7fffffff or a1, t7 addu a0, a2 # [a1:a0] += r srl t7, a0, 31 and a0, 0x7fffffff addu a1, t7 sw a1, 0(a3) # *hp = a1 lw a3, 16(sp) # fetch fifth actual argument from stack sw a0, 0(a3) # *lp = a0 # } j ra .end extended_mul .globl extended_div # extended_div(d, h, l, qp, rp) # unsigned int d, h, l, *qp, *rp; # { .ent extended_div extended_div: .frame sp, 0, ra sll a2, 1 li v0, 31 # v0 holds number of shifts loop: srl t7, a2, 31 sll a1, 1 or a1, t7 sll a2, 1 subu t7, a1, a0 # t = h - d bltz t7, underflow move a1, t7 or a2, 1 underflow: subu v0, 1 bnez v0, loop sw a2, 0(a3) # *qp = l lw a3, 16(sp) # fetch fifth actual argument from stack sw a1, 0(a3) # *rp = h # } j ra .end extended_div gcl-2.6.14/o/readme0000755000175000017500000000073614360276512012422 0ustar cammcammCurrent scheme: All functions which used to start with siL or L have been replaced by ones which pass arguments on the C stack. The special forms (eg Fprogn, Fsetq are still the same as before). Functions in the Lisp (resp Si package) are named fL... (respectively fS...) and they all pass arguments on the C stack and return multiple values, and have DEFUN's which specify their argd. eval still passes on the value stack All functions beginning with I pass on C stack. ` gcl-2.6.14/o/let.c0000755000175000017500000001544214360276512012172 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* let.c */ #include "include.h" void let_var_list(object var_list) { object x, y; for (x = var_list; !endp(x); x = x->c.c_cdr) { y = x->c.c_car; if (type_of(y) == t_symbol) { check_var(y); vs_push(y); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); } else { endp(y); check_var(y->c.c_car); vs_push(y->c.c_car); vs_push(Cnil); y = y->c.c_cdr; if (endp(y)) /* FEerror("No initial form to the variable ~S.", 1, vs_top[-2]) */ ; else if (!endp(y->c.c_cdr)) FEerror("Too many initial forms to the variable ~S.", 1, vs_top[-2]); vs_push(y->c.c_car); vs_push(Cnil); } } } static void FFN(Flet)(object form) { object body; struct bind_temp *start; object *old_lex; bds_ptr old_bds_top; if (endp(form)) FEerror("No argument to LET.", 0); old_lex = lex_env; lex_copy(); old_bds_top = bds_top; start = (struct bind_temp *)vs_top; let_var_list(form->c.c_car); body = let_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top); vs_top = (object *)start; vs_push(body); Fprogn(body); lex_env = old_lex; bds_unwind(old_bds_top); } static void FFN(FletA)(object form) { object body; struct bind_temp *start; object *old_lex; bds_ptr old_bds_top; if (endp(form)) FEerror("No argument to LET*.", 0); old_lex = lex_env; lex_copy(); old_bds_top = bds_top; start = (struct bind_temp *)vs_top; let_var_list(form->c.c_car); body = letA_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top); vs_top = (object *)start; vs_push(body); Fprogn(body); lex_env = old_lex; bds_unwind(old_bds_top); } static void FFN(Fmultiple_value_bind)(object form) { object body, values_form, x, y; int n, m, i; object *base; object *old_lex; bds_ptr old_bds_top; struct bind_temp *start; if (endp(form)) FEerror("No argument to MULTIPLE-VALUE-BIND.", 0); body = form->c.c_cdr; if (endp(body)) FEerror("No values-form to MULTIPLE-VALUE-BIND.", 0); values_form = body->c.c_car; body = body->c.c_cdr; old_lex = lex_env; lex_copy(); old_bds_top = bds_top; eval(values_form); base = vs_base; m = vs_top - vs_base; start = (struct bind_temp *)vs_top; for (n = 0, x = form->c.c_car; !endp(x); n++, x = x->c.c_cdr) { y = x->c.c_car; check_var(y); vs_push(y); vs_push(Cnil); vs_push(Cnil); vs_push(Cnil); } { object *vt = vs_top; vs_push(find_special(body, start, (struct bind_temp *)vt,NULL)); /*?*/ } for (i = 0; i < n; i++) bind_var(start[i].bt_var, (i < m ? base[i] : Cnil), start[i].bt_spp); body = vs_pop; vs_top = vs_base = base; vs_push(body); Fprogn(body); lex_env = old_lex; bds_unwind(old_bds_top); } static void FFN(Fcompiler_let)(object form) { object body; object *old_lex; bds_ptr old_bds_top; struct bind_temp *start, *end, *bt; if (endp(form)) FEerror("No argument to COMPILER-LET.", 0); body = form->c.c_cdr; old_lex = lex_env; lex_copy(); old_bds_top = bds_top; start = (struct bind_temp *)vs_top; let_var_list(form->c.c_car); end = (struct bind_temp *)vs_top; for (bt = start; bt < end; bt++) { eval_assign(bt->bt_init, bt->bt_init); } for (bt = start; bt < end; bt++) bind_var(bt->bt_var, bt->bt_init, Ct); vs_top = (object *)start; Fprogn(body); lex_env = old_lex; bds_unwind(old_bds_top); } static void FFN(Fflet)(object args) { object def_list; object def; object *lex = lex_env; object *top = vs_top; vs_push(Cnil); /* space for each closure */ if (endp(args)) FEtoo_few_argumentsF(args); def_list = MMcar(args); lex_copy(); while (!endp(def_list)) { def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) FEerror("~S~%\ is an illegal function definition in FLET.", 1, def); top[0] = MMcons(lex[2], def); top[0] = MMcons(lex[1], top[0]); top[0] = MMcons(lex[0], top[0]); top[0] = MMcons(sSlambda_block_closure, top[0]); lex_fun_bind(MMcar(def), top[0]); def_list = MMcdr(def_list); } vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } static void FFN(Flabels)(object args) { object def_list; object def; object closure_list; object *lex = lex_env; object *top = vs_top; vs_push(Cnil); /* space for each closure */ vs_push(Cnil); /* space for closure-list */ if (endp(args)) FEtoo_few_argumentsF(args); def_list = MMcar(args); lex_copy(); while (!endp(def_list)) { def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) FEerror("~S~%\ is an illegal function definition in LABELS.", 1, def); top[0] = MMcons(lex[2], def); top[0] = MMcons(Cnil, top[0]); top[1] = MMcons(top[0], top[1]); top[0] = MMcons(lex[0], top[0]); top[0] = MMcons(sSlambda_block_closure, top[0]); lex_fun_bind(MMcar(def), top[0]); def_list = MMcdr(def_list); } closure_list = top[1]; while (!endp(closure_list)) { MMcaar(closure_list) = lex_env[1]; closure_list = MMcdr(closure_list); } vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } static void FFN(Fmacrolet)(object args) { object def_list; object def; object *lex = lex_env; object *top = vs_top; vs_push(Cnil); /* space for each macrodef */ if (endp(args)) FEtoo_few_argumentsF(args); def_list = MMcar(args); lex_copy(); while (!endp(def_list)) { def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) FEerror("~S~%\ is an illegal macro definition in MACROFLET.", 1, def); top[0] = ifuncall3(sSdefmacroA, MMcar(def), MMcadr(def), MMcddr(def)); lex_macro_bind(MMcar(def), MMcaddr(top[0])); def_list = MMcdr(def_list); } vs_push(find_special(MMcdr(args), NULL, NULL,NULL)); Fprogn(vs_head); lex_env = lex; } void gcl_init_let(void) { make_special_form("LET", Flet); make_special_form("LET*", FletA); make_special_form("MULTIPLE-VALUE-BIND", Fmultiple_value_bind); make_special_form("FLET",Fflet); make_special_form("LABELS",Flabels); make_special_form("MACROLET",Fmacrolet); make_si_special_form("COMPILER-LET", Fcompiler_let); } gcl-2.6.14/o/main.c0000755000175000017500000006755014360276512012341 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* main.c IMPLEMENTATION-DEPENDENT */ #include #include #include #include #include #include static void init_main(void); static void initlisp(void); static int multiply_stacks(int); #ifdef KCLOVM #include void change_contexts(); int ovm_process_created; void initialize_process(); #endif #define EXTER #define INLINE #include "include.h" #include #include "page.h" bool saving_system=FALSE; #ifdef BSD #include #ifndef SGI #include #endif #endif #ifdef AOSVS #endif #ifdef _WIN32 #include #endif #define LISP_IMPLEMENTATION_VERSION "April 1994" char *system_directory; #define EXTRA_BUFSIZE 8 char stdin_buf[BUFSIZ + EXTRA_BUFSIZE]; char stdout_buf[BUFSIZ + EXTRA_BUFSIZE]; char stderr_buf[BUFSIZ + EXTRA_BUFSIZE]; #include "stacks.h" int debug; /* debug switch */ int raw_image = TRUE; /* raw or saved image -- CYGWIN will only place this in .data and not in .bss if initialized to non-zero */ bool GBC_enable=FALSE; long real_maxpage; object sSAlisp_maxpagesA; object siClisp_pagesize; object sStop_level; object sSAmultiply_stacksA; int stack_multiple=1; static object stack_space; #ifdef _WIN32 unsigned int _dbegin = 0x10100000; #endif #ifdef __CYGWIN__ unsigned long _dbegin = 0; #endif #ifdef SGC int sgc_enabled; #endif void install_segmentation_catcher(void); int cstack_dir(fixnum j) { static fixnum n; if (!n) { n=1; return cstack_dir((fixnum)&j); } return (fixnum)&jMAX_BRK) return -1; #endif if (uv static ufixnum get_phys_pages_no_malloc(char n) { MEMORYSTATUS m; m.dwLength=sizeof(m); GlobalMemoryStatus(&m); return m.dwTotalPhys>>PAGEWIDTH; } #elif defined (DARWIN) #include static ufixnum get_phys_pages_no_malloc(char n) { uint64_t s; size_t z=sizeof(s); int m[2]={CTL_HW,HW_MEMSIZE}; if (sysctl(m,2,&s,&z,NULL,0)==0) return s>>PAGEWIDTH; return 0; } #elif defined(__sun__) || defined(__GNU__) static ufixnum get_phys_pages_no_malloc(char n) { return sysconf(_SC_PHYS_PAGES); } #elif defined(FREEBSD) #include #include static ufixnum get_phys_pages_no_malloc(char n) { size_t i,len=sizeof(i); return (sysctlbyname("hw.physmem",&i,&len,NULL,0) ? 0 : i)>>PAGEWIDTH; } #else /*Linux*/ #include static ufixnum get_phys_pages_no_malloc(char freep) { struct sysinfo s; return sysinfo(&s) ? 0 : ((freep ? s.freeram : s.totalram)>>PAGEWIDTH)*s.mem_unit; } #endif static ufixnum get_phys_pages1(char freep) { return get_phys_pages_no_malloc(freep); } static void get_gc_environ(void) { const char *e; mem_multiple=1.0; if ((e=getenv("GCL_MEM_MULTIPLE"))) { massert(sscanf(e,"%lf",&mem_multiple)==1); massert(mem_multiple>=0.0); } gc_alloc_min=0.05; if ((e=getenv("GCL_GC_ALLOC_MIN"))) { massert(sscanf(e,"%lf",&gc_alloc_min)==1); massert(gc_alloc_min>=0.0); } gc_page_min=0.5; if ((e=getenv("GCL_GC_PAGE_MIN"))||(e=getenv("GCL_GC_PAGE_THRESH"))) {/*legacy support*/ massert(sscanf(e,"%lf",&gc_page_min)==1); massert(gc_page_min>=0.0); } gc_page_max=0.75; if ((e=getenv("GCL_GC_PAGE_MAX"))) { massert(sscanf(e,"%lf",&gc_page_max)==1); massert(gc_page_max>=0.0); } multiprocess_memory_pool= (e=getenv("GCL_MULTIPROCESS_MEMORY_POOL")) && (*e=='t' || *e=='T'); wait_on_abort=0; if ((e=getenv("GCL_WAIT_ON_ABORT"))) massert(sscanf(e,"%lu",&wait_on_abort)==1); } static void setup_maxpages(double scale) { void *beg=data_start ? data_start : sbrk(0); ufixnum maxpages=real_maxpage-page(beg),npages,i; for (npages=0,i=t_start;i=npages); maxpages*=scale; phys_pages*=scale; real_maxpage=maxpages+page(beg); resv_pages=available_pages=0; available_pages=check_avail_pages(); resv_pages=available_pages/100; available_pages-=resv_pages; recent_allocation=0; } void *initial_sbrk=NULL; int update_real_maxpage(void) { ufixnum i,j; void *end,*cur,*beg; #ifdef __MINGW32__ static fixnum n; if (!n) { init_shared_memory(); n=1; } #endif #ifdef DEFINED_REAL_MAXPAGE real_maxpage=DEFINED_REAL_MAXPAGE; #else massert(cur=sbrk(0)); beg=data_start ? data_start : cur; for (i=0,j=(1L<PAGESIZE;j>>=1) if ((end=beg+i+j-PAGESIZE)>cur) if (!mbrk(end)) { real_maxpage=page(end); i+=j; } massert(!mbrk(cur)); #endif phys_pages=ufmin(get_phys_pages1(0)+page(beg),real_maxpage)-page(beg); get_gc_environ(); setup_maxpages(mem_multiple); return 0; } static int minimize_image(void) { fixnum i; empty_relblock(); nrbpage=0; resize_hole(0,t_relocatable,0); gprof_cleanup(); #if defined(BSD) || defined(ATT) mbrk(core_end=heap_end); #endif cbgbccount = tm_table[t_contiguous].tm_adjgbccnt = tm_table[t_contiguous].tm_opt_maxpage = 0; rbgbccount = tm_table[t_relocatable].tm_adjgbccnt = tm_table[t_relocatable].tm_opt_maxpage = 0; for (i = 0; i < (int)t_end; i++) tm_table[i].tm_gbccount = tm_table[i].tm_adjgbccnt = tm_table[i].tm_opt_maxpage = 0; return 0; } DEFUN_NEW("SET-LOG-MAXPAGE-BOUND",object,fSset_log_maxpage_bound,SI,1,1,NONE,II,OO,OO,OO,(fixnum l),"") { void *end,*dend; fixnum def=sizeof(fixnum)*8-1; l=l= dend) { minimize_image(); log_maxpage_bound=l;/*FIXME maybe this should be under mem_multiple, not over*/ update_real_maxpage(); maybe_set_hole_from_maxpages(); } return (object)log_maxpage_bound; } #ifdef NEED_STACK_CHK_GUARD unsigned long __stack_chk_guard=0; static unsigned long random_ulong() { object y; vs_top=vs_base; vs_push(Ct); Lmake_random_state(); y=vs_pop; vs_push(number_negate(find_symbol(make_simple_string("MOST-NEGATIVE-FIXNUM"),system_package)->s.s_dbind)); vs_push(y); Lrandom(); return fixint(vs_pop); } #endif #ifdef HAVE_MPROTECT #include int gcl_mprotect(void *v,unsigned long l,int p) { int i; char b[80]; if ((i=mprotect(v,l,p))) { snprintf(b,sizeof(b),"mprotect failure: %p %lu %d\b",v,l,p); perror(b); } return i; } #endif DEFVAR("*CODE-BLOCK-RESERVE*",sSAcode_block_reserveA,SI,Cnil,""); #define HAVE_GCL_CLEANUP void gcl_cleanup(int gc) { if (getenv("GCL_WAIT")) sleep(30); #if defined(USE_CLEANUP) {extern void _cleanup(void);_cleanup();} #endif gprof_cleanup(); if (gc) { saving_system=TRUE; GBC(t_other); saving_system=FALSE; minimize_image(); raw_image=FALSE; cs_org=0; initial_sbrk=core_end; } close_pool(); } /*gcc boolean expression tail position bug*/ static char *stack_to_be_allocated; int stack_ret(char *s,unsigned long size) { int r,i; for (i=r=0;i1); for (s=NULL;(s=strtok(s ? NULL : FN1,":"));) { massert(snprintf(FN2,sizeof(FN2),"%s/%s",s,n)); if (mbin(FN2,o)) return 1; } return 0; } #endif static int ARGC; static char **ARGV; int main(int argc, char **argv, char **envp) { GET_FULL_PATH_SELF(kcl_self); *argv=kcl_self; #ifdef CAN_UNRANDOMIZE_SBRK #include #include #include "unrandomize.h" #endif gcl_init_alloc(alloca(1)); setbuf(stdin, stdin_buf); setbuf(stdout, stdout_buf); setbuf(stderr, stderr_buf); #ifdef _WIN32 _fmode = _O_BINARY; _setmode( _fileno( stdin ), _O_BINARY ); _setmode( _fileno( stdout ), _O_BINARY ); _setmode( _fileno( stderr ), _O_BINARY ); #endif ARGC = argc; ARGV = argv; vs_top = vs_base = vs_org; ihs_top = ihs_org-1; bds_top = bds_org-1; frs_top = frs_org-1; if (raw_image) { printf("GCL (GNU Common Lisp) %s %ld pages\n",LISP_IMPLEMENTATION_VERSION,real_maxpage); fflush(stdout); if (ARGC>1) { massert(ARGV[1][strlen(ARGV[1])-1]=='/'); system_directory=ARGV[1]; } initlisp(); lex_new(); GBC_enable = TRUE; gcl_init_init(); sLApackageA->s.s_dbind = user_package; } else { terminal_io->sm.sm_object0->sm.sm_fp = stdin; terminal_io->sm.sm_object1->sm.sm_fp = stdout; standard_error->sm.sm_fp = stderr; gcl_init_big1(); #ifdef USE_READLINE gcl_init_readline_function(); #endif #ifdef NEED_STACK_CHK_GUARD __stack_chk_guard=random_ulong();/*Cannot be safely set inside a function which returns*/ #endif } sSAlisp_maxpagesA->s.s_dbind = make_fixnum(real_maxpage); ihs_push(Cnil); lex_new(); vs_base = vs_top; interrupt_enable = TRUE; install_default_signals(); do super_funcall(sStop_level); while (type_of(sSAmultiply_stacksA->s.s_dbind)==t_fixnum && multiply_stacks(fix(sSAmultiply_stacksA->s.s_dbind))); return 0; } /* catch certain signals */ void install_segmentation_catcher(void) { unblock_signals(SIGSEGV,SIGSEGV); unblock_signals(SIGBUS,SIGBUS); (void) gcl_signal(SIGSEGV,segmentation_catcher); (void) gcl_signal(SIGBUS,segmentation_catcher); } void do_gcl_abort(void) { if (wait_on_abort) sleep(wait_on_abort); gcl_cleanup(0); abort(); } int catch_fatal=1; void error(char *s) { if (catch_fatal>0 && interrupt_enable ) {catch_fatal = -1; #ifdef SGC if (sgc_enabled) { sgc_quit();} if (sgc_enabled==0) #endif { install_segmentation_catcher() ;} FEerror("Caught fatal error [memory may be damaged]",0); } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); do_gcl_abort(); } static void initlisp(void) { void *v=&v; if (NULL_OR_ON_C_STACK(v) == 0 #if defined(IM_FIX_BASE) || NULL_OR_ON_C_STACK(IM_FIX_BASE) == 0 || NULL_OR_ON_C_STACK((IM_FIX_BASE|IM_FIX_LIM)) == 0 #endif /* || NULL_OR_ON_C_STACK(vv) */ || NULL_OR_ON_C_STACK(pagetoinfo(first_data_page)) || NULL_OR_ON_C_STACK(core_end-1)) { /* check person has correct definition of above */ emsg("%p %d " #if defined(IM_FIX_BASE) "%p %d %p %d " #endif "%p %d %p %d\n", v,NULL_OR_ON_C_STACK(v), #if defined(IM_FIX_BASE) (void *)IM_FIX_BASE,NULL_OR_ON_C_STACK(IM_FIX_BASE), (void *)(IM_FIX_BASE|IM_FIX_LIM),NULL_OR_ON_C_STACK(IM_FIX_BASE|IM_FIX_LIM), #endif pagetoinfo(first_data_page),NULL_OR_ON_C_STACK(pagetoinfo(first_data_page)), core_end-1,NULL_OR_ON_C_STACK(core_end-1)); error("NULL_OR_ON_C_STACK macro invalid"); } Cnil->fw=0; set_type_of(Cnil,t_symbol); Cnil->c.c_cdr=Cnil; Cnil_body.s.s_dbind = Cnil; Cnil_body.s.s_sfdef = NOT_SPECIAL; Cnil_body.s.s_fillp = 3; Cnil_body.s.s_self = "NIL"; Cnil_body.s.s_gfdef = OBJNULL; Cnil_body.s.s_plist = Cnil; Cnil_body.s.s_hpack = Cnil; Cnil_body.s.s_stype = (short)stp_constant; Cnil_body.s.s_mflag = FALSE; Ct->fw=0; set_type_of(Ct,t_symbol); Ct_body.s.s_dbind = Ct; Ct_body.s.s_sfdef = NOT_SPECIAL; Ct_body.s.s_fillp = 1; Ct_body.s.s_self = "T"; Ct_body.s.s_gfdef = OBJNULL; Ct_body.s.s_plist = Cnil; Ct_body.s.s_hpack = Cnil; Ct_body.s.s_stype = (short)stp_constant; Ct_body.s.s_mflag = FALSE; gcl_init_symbol(); gcl_init_package(); Cnil->s.s_hpack = lisp_package; import(Cnil, lisp_package); export(Cnil, lisp_package); Ct->s.s_hpack = lisp_package; import(Ct, lisp_package); export(Ct, lisp_package); sLlambda = make_ordinary("LAMBDA"); sSlambda_block = make_si_ordinary("LAMBDA-BLOCK"); sSlambda_closure = make_si_ordinary("LAMBDA-CLOSURE"); sSlambda_block_closure = make_si_ordinary("LAMBDA-BLOCK-CLOSURE"); sLspecial = make_ordinary("SPECIAL"); NewInit(); gcl_init_typespec(); gcl_init_number(); gcl_init_character(); gcl_init_read(); gcl_init_bind(); gcl_init_pathname(); gcl_init_print(); gcl_init_GBC(); gcl_init_unixfasl(); gcl_init_unixsys(); gcl_init_unixsave(); gcl_init_alloc_function(); gcl_init_array_function(); gcl_init_character_function(); gcl_init_file_function(); gcl_init_list_function(); gcl_init_package_function(); gcl_init_pathname_function(); gcl_init_predicate_function(); gcl_init_print_function(); gcl_init_read_function(); gcl_init_sequence_function(); #if defined(KCLOVM) || defined(RUN_PROCESS) gcl_init_socket_function(); #endif gcl_init_structure_function(); gcl_init_string_function(); gcl_init_symbol_function(); gcl_init_typespec_function(); gcl_init_hash(); gcl_init_cfun(); gcl_init_unixfsys(); gcl_init_unixtime(); gcl_init_eval(); gcl_init_lex(); gcl_init_prog(); gcl_init_catch(); gcl_init_block(); gcl_init_macros(); gcl_init_conditional(); gcl_init_reference(); gcl_init_assignment(); gcl_init_multival(); gcl_init_error(); gcl_init_let(); gcl_init_mapfun(); gcl_init_iteration(); gcl_init_toplevel(); gcl_init_cmpaux(); init_main(); gcl_init_format(); gcl_init_links(); gcl_init_fat_string(); gcl_init_sfasl(); #ifdef CMAC gcl_init_cmac(); #endif #ifdef USE_READLINE gcl_init_readline(); #endif } object vs_overflow(void) { if (vs_limit > vs_org + stack_multiple * VSSIZE) error("value stack overflow"); vs_limit += STACK_OVER*VSGETA; FEerror("Value stack overflow.", 0); return Cnil; } void bds_overflow(void) { --bds_top; if (bds_limit > bds_org + stack_multiple * BDSSIZE) { error("bind stack overflow"); } bds_limit += STACK_OVER *BDSGETA; FEerror("Bind stack overflow.", 0); } void frs_overflow(void) { --frs_top; if (frs_limit > frs_org + stack_multiple * FRSSIZE) error("frame stack overflow"); frs_limit += STACK_OVER* FRSGETA; FEerror("Frame stack overflow.", 0); } void ihs_overflow(void) { --ihs_top; if (ihs_limit > ihs_org + stack_multiple * IHSSIZE) error("invocation history stack overflow"); ihs_limit += STACK_OVER*IHSGETA; FEerror("Invocation history stack overflow.", 0); } void segmentation_catcher(int i) { error("Segmentation violation."); } /* static void */ /* cs_overflow(void) { */ /* #ifdef AV */ /* if (cs_limit < cs_org - cssize) */ /* error("control stack overflow"); */ /* cs_limit -= CSGETA; */ /* #endif */ /* #ifdef MV */ /* #endif */ /* FEerror("Control stack overflow.", 0); */ /* } */ /* static void */ /* end_of_file(void) { */ /* error("end of file"); */ /* } */ DEFUNO_NEW("BYE",object,fSbye,SI ,0,1,NONE,OO,OO,OO,OO,void,Lby,(object exitc),"") { int n=VFUN_NARGS; int exit_code; if (n>=1) exit_code=fix(exitc);else exit_code=0; /* printf("Bye.\n"); */ exit(exit_code); } DEFUN_NEW("QUIT",object,fSquit,SI ,0,1,NONE,OO,OO,OO,OO,(object exitc),"") { return FFN(fSbye)(exitc); } /* DEFUN_NEW("EXIT",object,fLexit,LISP */ /* ,0,1,NONE,OI,OO,OO,OO,(fixnum exitc),"") */ /* { return fLbye(exitc); } */ /* c_trace(void) */ /* { */ /* #ifdef AOSVS */ /* #endif */ /* } */ static void FFN(siLargc)(void) { check_arg(0); vs_push(make_fixnum(ARGC)); } static void FFN(siLargv)(void) { int i=0; check_arg(1); if (type_of(vs_base[0]) != t_fixnum || (i = fix(vs_base[0])) < 0 || i >= ARGC) FEerror("Illegal argument index: ~S.", 1, vs_base[0]); vs_base[0] = make_simple_string(ARGV[i]); } static void FFN(siLgetenv)(void) { char name[256]; int i; char *value; extern char *getenv(const char *); check_arg(1); check_type_string(&vs_base[0]); if (vs_base[0]->st.st_fillp >= 256) FEerror("Too long name: ~S.", 1, vs_base[0]); for (i = 0; i < vs_base[0]->st.st_fillp; i++) name[i] = vs_base[0]->st.st_self[i]; name[i] = '\0'; if ((value = getenv(name)) != NULL) {vs_base[0] = make_simple_string(value); #ifdef FREE_GETENV_RESULT free(value); #endif } else vs_base[0] = Cnil; } object *vs_marker; static void FFN(siLmark_vs)(void) { check_arg(0); vs_marker = vs_base; vs_base[0] = Cnil; } static void FFN(siLcheck_vs)(void) { check_arg(0); if (vs_base != vs_marker) FEerror("Value stack is flawed.", 0); vs_base[0] = Cnil; } static object FFN(siLcatch_fatal)(int i) { catch_fatal=i; return Cnil; } LFD(siLreset_stack_limits)(void) { long i=0; check_arg(0); if(catch_fatal <0) catch_fatal=1; #ifdef SGC {extern int fault_count ; fault_count = 0;} #endif if (vs_top < vs_org + stack_multiple * VSSIZE) vs_limit = vs_org + stack_multiple * VSSIZE; else error("can't reset vs_limit"); if (bds_top < bds_org + stack_multiple * BDSSIZE) bds_limit = bds_org + stack_multiple * BDSSIZE; else error("can't reset bds_limit"); if (frs_top < frs_org + stack_multiple * FRSSIZE) frs_limit = frs_org + stack_multiple * FRSSIZE; else error("can't reset frs_limit"); if (ihs_top < ihs_org + stack_multiple * IHSSIZE) ihs_limit = ihs_org + stack_multiple * IHSSIZE; else error("can't reset ihs_limit"); if (cs_base==cs_org) cs_org=(void *)&i; #ifdef __ia64__ { extern void * GC_save_regs_in_stack(); if (cs_base2==cs_org2) cs_org2=GC_save_regs_in_stack(); } #endif /* reset_cstack_limit(i); */ vs_base[0] = Cnil; } #define COPYSTACK(org,p,typ,lim,top,geta,size) \ {unsigned long topl=top-org;\ bcopy(org,p,(lim-org)*sizeof(typ));\ org=p;\ top=org+topl;\ lim=org+stack_multiple*size;\ p=lim+(STACK_OVER+1)*geta;\ } static int multiply_stacks(int m) { void *p; int vs,bd,frs,ihs; stack_multiple=stack_multiple*m; #define ELTSIZE(x) (((char *)((x)+1)) - ((char *) x)) vs = (stack_multiple*VSSIZE + (STACK_OVER+1)*VSGETA)* ELTSIZE(vs_org); bd = (stack_multiple*BDSSIZE + (STACK_OVER+1)*BDSGETA)*ELTSIZE(bds_org); frs = (stack_multiple*FRSSIZE + (STACK_OVER+1)*FRSGETA)*ELTSIZE(frs_org); ihs = (stack_multiple*IHSSIZE + (STACK_OVER+1)*IHSGETA)*ELTSIZE(ihs_org); if (stack_space==0) {enter_mark_origin(&stack_space);} stack_space = alloc_simple_string(vs+bd+frs+ihs); array_allocself(stack_space,1,code_char(0)); p=stack_space->st.st_self; COPYSTACK(vs_org,p,object,vs_limit,vs_top,VSGETA,VSSIZE); COPYSTACK(bds_org,p,struct bds_bd,bds_limit,bds_top,BDSGETA,BDSSIZE); COPYSTACK(frs_org,p,struct frame,frs_limit,frs_top,FRSGETA,FRSSIZE); COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top, IHSGETA,IHSSIZE); vs_base=vs_top; return stack_multiple; } DEFVAR("*NO-INIT*",sSAno_initA,SI,Cnil,""); LFD(siLinit_system)(void) { check_arg(0); gcl_init_system(sSAno_initA); vs_base[0] = Cnil; } static void FFN(siLuser_init)(void) { check_arg(0); sLApackageA->s.s_dbind = user_package; user_init(); vs_base[0] = Cnil; } /* static void */ /* FFN(siLaddress)(void) { */ /* check_arg(1); */ /* vs_base[0] = make_fixnum((long)vs_base[0]); */ /* } */ DEFUN_NEW("NANI",object,fSnani,SI,1,1,NONE,OI,OO,OO,OO,(fixnum address),"") { RETURN1((object)address); } DEFUN_NEW("ADDRESS",object,fSaddress,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { RETURN1(x); } /* static void */ /* FFN(siLnani)(void) { */ /* check_arg(1); */ /* switch (type_of(vs_base[0])) { */ /* case t_fixnum: */ /* vs_base[0]=(object)fix(vs_base[0]); */ /* break; */ /* default: */ /* FEerror("Cannot coerce ~s to an address",1,vs_base[0]); */ /* } */ /* } */ static void FFN(siLinitialization_failure)(void) { check_arg(0); printf("lisp initialization failed\n"); do_gcl_abort(); } DEFUNO_NEW("IDENTITY",object,fLidentity,LISP ,1,1,NONE,OO,OO,OO,OO,void,Lidentity,(object x0),"") { /* 1 args */ RETURN1 (x0); } DEFUNO_NEW("LDB1",object,fSldb1,SI ,3,3,NONE,OI,II,OO,OO,void,Lldb1,(fixnum a,fixnum b, fixnum c),"") { RETURN1 (make_fixnum(((((~(-1 << (a))) << (b)) & (c)) >> (b)))); } DEFUN_NEW("LISP-IMPLEMENTATION-VERSION",object,fLlisp_implementation_version,LISP ,0,0,NONE,OO,OO,OO,OO,(void),"") { /* 0 args */ RETURN1((make_simple_string(LISP_IMPLEMENTATION_VERSION))); } static void FFN(siLsave_system)(void) { #ifdef HAVE_YP_UNBIND extern object truename(),namestring(); check_arg(1); /* prevent subsequent consultation of yp by getting truename now*/ vs_base[0]=namestring(truename(vs_base[0])); {char name[200]; char *dom = name; if (0== getdomainname(dom,sizeof(name))) yp_unbind(dom);} #endif #ifdef DO_BEFORE_SAVE DO_BEFORE_SAVE #endif siLsave(); } DEFVAR("*LISP-MAXPAGES*",sSAlisp_maxpagesA,SI,make_fixnum(real_maxpage),""); DEFVAR("*SYSTEM-DIRECTORY*",sSAsystem_directoryA,SI,make_simple_string(system_directory),""); DEFVAR("*MULTIPLY-STACKS*",sSAmultiply_stacksA,SI,Cnil,""); DEF_ORDINARY("TOP-LEVEL",sStop_level,SI,""); DEFVAR("*COMMAND-ARGS*",sSAcommand_argsA,SI,sLnil,""); static void init_main(void) { make_si_function("BY", Lby); make_si_function("ARGC", siLargc); make_si_function("ARGV", siLargv); make_si_function("GETENV", siLgetenv); make_si_function("MARK-VS", siLmark_vs); make_si_function("CHECK-VS", siLcheck_vs); make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits); make_si_function("INIT-SYSTEM", siLinit_system); make_si_function("USER-INIT", siLuser_init); /* make_si_function("ADDRESS", siLaddress); */ /* make_si_function("NANI", siLnani); */ make_si_function("INITIALIZATION-FAILURE", siLinitialization_failure); siClisp_pagesize = make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE)); {object features; #define ADD_FEATURE(name) \ features= make_cons(make_keyword(name),features) features= make_cons(make_keyword("COMMON"), make_cons(make_keyword("KCL"), Cnil)); ADD_FEATURE("AKCL"); ADD_FEATURE("GCL"); #ifdef BROKEN_O4_OPT ADD_FEATURE("BROKEN_O4_OPT"); #endif #ifdef GMP ADD_FEATURE("GMP"); #endif #ifdef GCL_GPROF ADD_FEATURE("GPROF"); #endif #ifndef _WIN32 ADD_FEATURE("UNIX"); #endif #ifdef _WIN32 ADD_FEATURE("WINNT"); ADD_FEATURE("WIN32"); #endif #if defined(__CYGWIN__) ADD_FEATURE("CYGWIN"); #endif #ifdef IEEEFLOAT ADD_FEATURE("IEEE-FLOATING-POINT"); #endif #ifdef SGC ADD_FEATURE("SGC"); #endif /* #ifdef ADDITIONAL_FEATURES */ /* ADDITIONAL_FEATURES; */ /* #endif */ ADD_FEATURE(HOST_CPU); ADD_FEATURE(HOST_KERNEL); #ifdef HOST_SYSTEM ADD_FEATURE(HOST_SYSTEM); #endif #ifdef BSD ADD_FEATURE("BSD"); #endif #if !defined(DOUBLE_BIGENDIAN) ADD_FEATURE("CLX-LITTLE-ENDIAN"); #endif #ifndef PECULIAR_MACHINE #define BIGM (int)((((unsigned int)(-1))/2)) { /* int ONEM = -1; */ int Bigm = BIGM; int Smallm = -BIGM-1; int Seven = 7; int Three = 3; if ( (Smallm / Seven) < 0 && (Smallm / (-Seven)) > 0 && (Bigm / (-Seven)) < 0 && ((-Seven) / Three) == -2 && (Seven / (-Three)) == -2 && ((-Seven)/ (-Three)) == 2) { ADD_FEATURE("TRUNCATE_USE_C"); } } #endif #ifdef USE_READLINE #ifdef READLINE_IS_EDITLINE ADD_FEATURE("EDITLINE"); #else ADD_FEATURE("READLINE"); #endif #endif #if !defined(USE_DLOPEN) ADD_FEATURE("NATIVE-RELOC"); #if defined(HAVE_LIBBFD) ADD_FEATURE("BFD"); #endif #endif ADD_FEATURE("UNEXEC"); #ifdef HAVE_XGCL ADD_FEATURE("XGCL"); #endif #ifdef HAVE_GNU_LD ADD_FEATURE("GNU-LD"); #endif #ifdef STATIC_LINKING ADD_FEATURE("STATIC"); #endif #ifdef LARGE_MEMORY_MODEL ADD_FEATURE("LARGE-MEMORY-MODEL"); #endif make_special("*FEATURES*",features);} make_si_function("SAVE-SYSTEM", siLsave_system); make_si_sfun("CATCH-FATAL",siLcatch_fatal,ARGTYPE1(f_fixnum)); make_si_function("WARN-VERSION",Lidentity); } #ifdef HAVE_DIS_ASM_H #include "dis-asm.h" static char b[4096],*bp; static int my_fprintf(void *v,const char *f,...) { va_list va; int r; va_start(va,f); bp+=(r=vsnprintf(bp,sizeof(b)-(bp-b),f,va)); va_end(va); return r; } static int my_fprintf_styled(void *v,enum disassembler_style,const char *f,...) { va_list va; int r; va_start(va,f); bp+=(r=vsnprintf(bp,sizeof(b)-(bp-b),f,va)); va_end(va); return r; } static int my_read(bfd_vma memaddr, bfd_byte *myaddr, unsigned int length, struct disassemble_info *dinfo) { memcpy(myaddr,(void *)(long)memaddr,length); return 0; } static void my_pa(bfd_vma addr,struct disassemble_info *dinfo) { dinfo->fprintf_func(dinfo->stream,"%p",(void *)(long)addr); } #endif DEFUN_NEW("DISASSEMBLE-INSTRUCTION",object,fSdisassemble_instruction,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { #if defined(HAVE_DIS_ASM_H) && defined(OUTPUT_ARCH) static disassemble_info i; void *v; void * (*s)(); fixnum j,j1,k; object x; if ((v=dlopen("libopcodes.so",RTLD_NOW))) { if ((s=dlsym(v,"init_disassemble_info"))) { s(&i, stdout,(fprintf_ftype) my_fprintf,my_fprintf_styled); i.read_memory_func=my_read; i.print_address_func=my_pa; if ((s=dlsym(v,"disassembler"))) { disassembler_ftype disasm=(disassembler_ftype)(ufixnum)s(OUTPUT_ARCH,false,0,NULL);/*bfd_mach_x86_64*/ bp=b; disasm(addr,&i); my_fprintf(NULL," ;"); x=make_simple_string(b); j1=j=(addr-16)&(~16UL); bp=b; for (k=0;k<16;k++) { j+=disasm(j,&i); my_fprintf(NULL," ;"); } return MMcons(x,MMcons(make_simple_string(b),make_fixnum(j-j1))); } } massert(!dlclose(v)); } #endif return MMcons(make_simple_string("fnop ;"),make_fixnum(0)); } typedef struct { enum type tt; struct typemanager *tp; } Tbl; #define Tblof(a_) {(a_),tm_of(a_)} #define tblookup(a_,b_) ({Tbl *tb=tb1;(b_)=(a_);for (;tb->tt && tb->b_!=(b_);tb++);tb->tt;}) #define mtm_of(a_) (a_)>=t_other ? NULL : tm_of(a_) DEFUN_NEW("FUNCTION-BY-ADDRESS",object,fSfunction_by_address,SI,1,1,NONE,OI,OO,OO,OO,(fixnum ad),"") { ufixnum m=-1,mm,j; void *o; object x,xx=Cnil; Tbl tb1[]={Tblof(t_sfun),Tblof(t_cfun),Tblof(t_vfun),Tblof(t_afun),Tblof(t_gfun),Tblof(t_closure),Tblof(t_cclosure),{0}}; struct typemanager *tp; enum type tt; struct pageinfo *v; if (VALID_DATA_ADDRESS_P(ad)) for (v=cell_list_head;v;v=v->next) if (tblookup(mtm_of(v->type),tp)) for (o=pagetochar(page(v)),j=tp->tm_nppage;j--;o+=tp->tm_size) if (tblookup(type_of((x=o)),tt)) if (!is_free(x) && (mm=ad-(ufixnum)x->sfn.sfn_self)=0) { if (j<= (MOST_POSITIVE_FIX-i)) { return make_fixnum(i+j); } MPOP(return,addss,i,j); } else { /* i < 0 */ if ((MOST_NEGATIVE_FIX -i) <= j) { return make_fixnum(i+j); } MPOP(return,addss,i,j); } } /* return i - j */ object fixnum_sub(fixnum i, fixnum j) { if (i>=0) { if (j >= (i - MOST_POSITIVE_FIX)) { return make_fixnum(i-j); } MPOP(return,subss,i,j); } else { /* i < 0 */ if ((MOST_NEGATIVE_FIX -i) <= -j) { return make_fixnum(i-j); } MPOP(return,subss,i,j); } } object fixnum_times(fixnum i, fixnum j) { #ifdef HAVE_CLZL if (i!=MOST_NEGATIVE_FIX && j!=MOST_NEGATIVE_FIX && fixnum_mul_safe(i,j)) #else if (i>=0 ? (j>=0 ? (!i || j<= (MOST_POSITIVE_FIX/i)) : (j==-1 || i<= (MOST_NEGATIVE_FIX/j))) : (j>=0 ? (i==-1 || j<= (MOST_NEGATIVE_FIX/i)) : (i>MOST_NEGATIVE_FIX && -i<= (MOST_POSITIVE_FIX/-j)))) #endif return make_fixnum(i*j); else MPOP(return,mulss,i,j); } static object number_to_complex(object x) { object z; switch (type_of(x)) { case t_fixnum: case t_bignum: case t_ratio: case t_shortfloat: case t_longfloat: z = alloc_object(t_complex); z->cmp.cmp_real = x; z->cmp.cmp_imag = small_fixnum(0); return(z); case t_complex: return(x); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object number_plus(object x, object y) { double dx, dy; object z; switch (type_of(x)) { case t_fixnum: switch(type_of(y)) { case t_fixnum: return fixnum_add(fix(x),fix(y)); case t_bignum: MPOP(return, addsi,fix(x),MP(y)); case t_ratio: z = number_plus(number_times(x, y->rat.rat_den), y->rat.rat_num); return make_ratio(z, y->rat.rat_den); case t_shortfloat: dx = (double)(fix(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(fix(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_bignum: switch (type_of(y)) { case t_fixnum: MPOP(return,addsi,fix(y),MP(x)); case t_bignum: MPOP(return,addii,MP(y),MP(x)); case t_ratio: z = number_plus(number_times(x, y->rat.rat_den), y->rat.rat_num); return make_ratio(z, y->rat.rat_den); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_ratio: switch (type_of(y)) { case t_fixnum: case t_bignum: z = number_plus(x->rat.rat_num, number_times(x->rat.rat_den, y)); z = make_ratio(z, x->rat.rat_den); return(z); case t_ratio: z = number_plus(number_times(x->rat.rat_num,y->rat.rat_den), number_times(x->rat.rat_den,y->rat.rat_num)); z = make_ratio(z,number_times(x->rat.rat_den,y->rat.rat_den)); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_shortfloat: switch (type_of(y)) { case t_fixnum: dx = (double)(sf(x)); dy = (double)(fix(y)); goto SHORTFLOAT; case t_shortfloat: dx = (double)(sf(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(sf(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dx = (double)(sf(x)); dy = number_to_double(y); goto SHORTFLOAT; } SHORTFLOAT: z = alloc_object(t_shortfloat); sf(z) = (shortfloat)(dx + dy); return(z); case t_longfloat: dx = lf(x); switch (type_of(y)) { case t_fixnum: dy = (double)(fix(y)); goto LONGFLOAT; case t_shortfloat: dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dy = number_to_double(y); goto LONGFLOAT; } LONGFLOAT: z = alloc_object(t_longfloat); lf(z) = dx + dy; return(z); case t_complex: COMPLEX: x = number_to_complex(x); y = number_to_complex(y); z = make_complex(number_plus(x->cmp.cmp_real, y->cmp.cmp_real), number_plus(x->cmp.cmp_imag, y->cmp.cmp_imag)); return(z); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object one_plus(object x) { double dx; object z; switch (type_of(x)) { case t_fixnum: return fixnum_add(fix(x),1); case t_bignum: MPOP(return,addsi,1,MP(x)); case t_ratio: z = number_plus(x->rat.rat_num, x->rat.rat_den); z = make_ratio(z, x->rat.rat_den); return(z); case t_shortfloat: dx = (double)(sf(x)); z = alloc_object(t_shortfloat); sf(z) = (shortfloat)(dx + 1.0); return(z); case t_longfloat: dx = lf(x); z = alloc_object(t_longfloat); lf(z) = dx + 1.0; return(z); case t_complex: z = make_complex(one_plus(x->cmp.cmp_real), x->cmp.cmp_imag); return(z); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object number_minus(object x, object y) { double dx, dy; object z; switch (type_of(x)) { case t_fixnum: switch(type_of(y)) { case t_fixnum: return fixnum_sub(fix(x),fix(y)); /* MPOP(return,subss,fix(x),fix(y)); */ case t_bignum: MPOP(return, subsi,fix(x),MP(y)); case t_ratio: z = number_minus(number_times(x, y->rat.rat_den), y->rat.rat_num); z = make_ratio(z, y->rat.rat_den); return(z); case t_shortfloat: dx = (double)(fix(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(fix(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_bignum: switch (type_of(y)) { case t_fixnum: MPOP(return,subis,MP(x),fix(y)); case t_bignum: MPOP(return,subii,MP(x),MP(y)); case t_ratio: z = number_minus(number_times(x, y->rat.rat_den), y->rat.rat_num); z = make_ratio(z, y->rat.rat_den); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_ratio: switch (type_of(y)) { case t_fixnum: case t_bignum: z = number_minus(x->rat.rat_num, number_times(x->rat.rat_den, y)); z = make_ratio(z, x->rat.rat_den); return(z); case t_ratio: z = number_minus(number_times(x->rat.rat_num,y->rat.rat_den), (number_times(x->rat.rat_den,y->rat.rat_num))); z = make_ratio(z,number_times(x->rat.rat_den,y->rat.rat_den)); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_shortfloat: switch (type_of(y)) { case t_fixnum: dx = (double)(sf(x)); dy = (double)(fix(y)); goto SHORTFLOAT; case t_shortfloat: dx = (double)(sf(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(sf(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dx = (double)(sf(x)); dy = number_to_double(y); goto SHORTFLOAT; } SHORTFLOAT: z = alloc_object(t_shortfloat); sf(z) = (shortfloat)(dx - dy); return(z); case t_longfloat: dx = lf(x); switch (type_of(y)) { case t_fixnum: dy = (double)(fix(y)); goto LONGFLOAT; case t_shortfloat: dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dy = number_to_double(y); } LONGFLOAT: z = alloc_object(t_longfloat); lf(z) = dx - dy; return(z); case t_complex: COMPLEX: x = number_to_complex(x); y = number_to_complex(y); z = make_complex(number_minus(x->cmp.cmp_real, y->cmp.cmp_real), number_minus(x->cmp.cmp_imag, y->cmp.cmp_imag)); return(z); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object one_minus(object x) { double dx; object z; switch (type_of(x)) { case t_fixnum: return fixnum_sub(fix(x),1); case t_bignum: MPOP(return,addsi,-1,MP(x)); case t_ratio: z = number_minus(x->rat.rat_num, x->rat.rat_den); z = make_ratio(z, x->rat.rat_den); return(z); case t_shortfloat: dx = (double)(sf(x)); z = alloc_object(t_shortfloat); sf(z) = (shortfloat)(dx - 1.0); return(z); case t_longfloat: dx = lf(x); z = alloc_object(t_longfloat); lf(z) = dx - 1.0; return(z); case t_complex: z = make_complex(one_minus(x->cmp.cmp_real), x->cmp.cmp_imag); return(z); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object number_negate(object x) { object z, z1; switch (type_of(x)) { case t_fixnum: if(fix(x) == MOST_NEGATIVE_FIX) return fixnum_add(1,MOST_POSITIVE_FIX); else return(make_fixnum(-fix(x))); case t_bignum: return big_minus(x); case t_ratio: z1 = number_negate(x->rat.rat_num); z = alloc_object(t_ratio); z->rat.rat_num = z1; z->rat.rat_den = x->rat.rat_den; return(z); case t_shortfloat: z = alloc_object(t_shortfloat); sf(z) = -sf(x); return(z); case t_longfloat: z = alloc_object(t_longfloat); lf(z) = -lf(x); return(z); case t_complex: z = make_complex(number_negate(x->cmp.cmp_real), number_negate(x->cmp.cmp_imag)); return(z); default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object number_times(object x, object y) { object z; double dx, dy; switch (type_of(x)) { case t_fixnum: switch (type_of(y)) { case t_fixnum: return fixnum_times(fix(x),fix(y)); /* MPOP(return,mulss,fix(x),fix(y)); */ case t_bignum: MPOP(return,mulsi,fix(x),MP(y)); case t_ratio: z = make_ratio(number_times(x, y->rat.rat_num), y->rat.rat_den); return(z); case t_shortfloat: dx = (double)(fix(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(fix(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_bignum: switch (type_of(y)) { case t_fixnum: MPOP(return,mulsi,fix(y),MP(x)); case t_bignum: MPOP(return,mulii,MP(y),MP(x)); case t_ratio: z = make_ratio(number_times(x, y->rat.rat_num), y->rat.rat_den); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_ratio: switch (type_of(y)) { case t_fixnum: case t_bignum: z = make_ratio(number_times(x->rat.rat_num, y), x->rat.rat_den); return(z); case t_ratio: z = make_ratio(number_times(x->rat.rat_num,y->rat.rat_num), number_times(x->rat.rat_den,y->rat.rat_den)); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_shortfloat: switch (type_of(y)) { case t_fixnum: dx = (double)(sf(x)); dy = (double)(fix(y)); goto SHORTFLOAT; case t_shortfloat: dx = (double)(sf(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(sf(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dx = (double)(sf(x)); dy = number_to_double(y); break; } SHORTFLOAT: z = alloc_object(t_shortfloat); sf(z) = (shortfloat)(dx * dy); return(z); case t_longfloat: dx = lf(x); switch (type_of(y)) { case t_fixnum: dy = (double)(fix(y)); goto LONGFLOAT; case t_shortfloat: dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dy = number_to_double(y); } LONGFLOAT: z = alloc_object(t_longfloat); lf(z) = dx * dy; return(z); case t_complex: COMPLEX: { object z1, z2, z11, z12, z21, z22; x = number_to_complex(x); y = number_to_complex(y); z11 = number_times(x->cmp.cmp_real, y->cmp.cmp_real); z12 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag); z21 = number_times(x->cmp.cmp_imag, y->cmp.cmp_real); z22 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag); z1 = number_minus(z11, z12); z2 = number_plus(z21, z22); z = make_complex(z1, z2); return(z); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object number_divide(object x, object y) { object z; double dx, dy; switch (type_of(x)) { case t_fixnum: case t_bignum: switch (type_of(y)) { case t_fixnum: case t_bignum: if(number_zerop(y) == TRUE) zero_divisor(); if (number_minusp(y) == TRUE) { x = number_negate(x); y = number_negate(y); } z = make_ratio(x, y); return(z); case t_ratio: if(number_zerop(y->rat.rat_num)) zero_divisor(); z = make_ratio(number_times(x, y->rat.rat_den), y->rat.rat_num); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_ratio: switch (type_of(y)) { case t_fixnum: case t_bignum: if (number_zerop(y)) zero_divisor(); z = make_ratio(x->rat.rat_num, number_times(x->rat.rat_den, y)); return(z); case t_ratio: z = make_ratio(number_times(x->rat.rat_num,y->rat.rat_den), number_times(x->rat.rat_den,y->rat.rat_num)); return(z); case t_shortfloat: dx = number_to_double(x); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = number_to_double(x); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: FEwrong_type_argument(sLnumber, y); } case t_shortfloat: switch (type_of(y)) { case t_fixnum: dx = (double)(sf(x)); dy = (double)(fix(y)); goto SHORTFLOAT; case t_shortfloat: dx = (double)(sf(x)); dy = (double)(sf(y)); goto SHORTFLOAT; case t_longfloat: dx = (double)(sf(x)); dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dx = (double)(sf(x)); dy = number_to_double(y); goto LONGFLOAT; } SHORTFLOAT: z = alloc_object(t_shortfloat); if (dy == 0.0) zero_divisor(); sf(z) = (shortfloat)(dx / dy); return(z); case t_longfloat: dx = lf(x); switch (type_of(y)) { case t_fixnum: dy = (double)(fix(y)); goto LONGFLOAT; case t_shortfloat: dy = (double)(sf(y)); goto LONGFLOAT; case t_longfloat: dy = lf(y); goto LONGFLOAT; case t_complex: goto COMPLEX; default: dy = number_to_double(y); } LONGFLOAT: z = alloc_object(t_longfloat); if (dy == 0.0) zero_divisor(); lf(z) = dx / dy; return(z); case t_complex: COMPLEX: { object z1, z2, z3; x = number_to_complex(x); y = number_to_complex(y); z1 = number_times(y->cmp.cmp_real, y->cmp.cmp_real); z2 = number_times(y->cmp.cmp_imag, y->cmp.cmp_imag); if (number_zerop(z3 = number_plus(z1, z2))) zero_divisor(); z1 = number_times(x->cmp.cmp_real, y->cmp.cmp_real); z2 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag); z1 = number_plus(z1, z2); z = number_times(x->cmp.cmp_imag, y->cmp.cmp_real); z2 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag); z2 = number_minus(z, z2); z1 = number_divide(z1, z3); z2 = number_divide(z2, z3); z = make_complex(z1, z2); return(z); } default: FEwrong_type_argument(sLnumber, x); return(Cnil); } } object integer_divide1(object x, object y,fixnum d) { object q; integer_quotient_remainder_1(x, y, &q, NULL,d); return(q); } object integer_divide2(object x, object y,fixnum d,object *r) { object q; integer_quotient_remainder_1(x, y, &q, r,d); return(q); } object get_gcd_abs(object x,object y) { object r; for (;;) { if (type_of(x) == t_fixnum && type_of(y) == t_fixnum) return make_fixnum(fixnum_gcd(fix(x),fix(y))); if (number_compare(x, y) < 0) { r = x; x = y; y = r; } if (type_of(y) == t_fixnum && fix(y) == 0) return(x); integer_quotient_remainder_1(x, y, NULL, &r,0); x = y; y = r; } } object get_gcd(object x, object y) { return get_gcd_abs(number_abs(x),number_abs(y)); } LFD(Lplus)(void) { fixnum i, j; j = vs_top - vs_base; if (j == 0) { vs_push(small_fixnum(0)); return; } for (i = 0; i < j; i++) check_type_number(&vs_base[i]); for (i = 1; i < j; i++) vs_base[0] = number_plus(vs_base[0], vs_base[i]); vs_top = vs_base+1; } LFD(Lminus)(void) { fixnum i, j; j = vs_top - vs_base; if (j == 0) too_few_arguments(); for (i = 0; i < j ; i++) check_type_number(&vs_base[i]); if (j == 1) { vs_base[0] = number_negate(vs_base[0]); return; } for (i = 1; i < j; i++) vs_base[0] = number_minus(vs_base[0], vs_base[i]); vs_top = vs_base+1; } LFD(Ltimes)(void) { fixnum i, j; j = vs_top - vs_base; if (j == 0) { vs_push(small_fixnum(1)); return; } for (i = 0; i < j; i++) check_type_number(&vs_base[i]); for (i = 1; i < j; i++) vs_base[0] = number_times(vs_base[0], vs_base[i]); vs_top = vs_base+1; } LFD(Ldivide)(void) { fixnum i, j; j = vs_top - vs_base; if (j == 0) too_few_arguments(); for(i = 0; i < j; i++) check_type_number(&vs_base[i]); if (j == 1) { vs_base[0] = number_divide(small_fixnum(1), vs_base[0]); return; } for (i = 1; i < j; i++) vs_base[0] = number_divide(vs_base[0], vs_base[i]); vs_top = vs_base+1; } LFD(Lone_plus)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = one_plus(vs_base[0]); } LFD(Lone_minus)(void) { check_arg(1); check_type_number(&vs_base[0]); vs_base[0] = one_minus(vs_base[0]); } LFD(Lconjugate)(void) { object c, i; check_arg(1); check_type_number(&vs_base[0]); c = vs_base[0]; if (type_of(c) == t_complex) { i = number_negate(c->cmp.cmp_imag); vs_push(i); vs_base[0] = make_complex(c->cmp.cmp_real, i); vs_popp; } } LFD(Lgcd)(void) { fixnum i, narg=vs_top-vs_base; if (narg == 0) { vs_push(small_fixnum(0)); return; } for (i = 0; i < narg; i++) check_type_integer(&vs_base[i]); vs_top=vs_base; vs_push(number_abs(vs_base[0])); for (i = 1; i < narg; i++) vs_base[0] = get_gcd_abs(vs_base[0], number_abs(vs_base[i])); } object get_lcm_abs(object x,object y) { object g=get_gcd_abs(x,y); return number_zerop(g) ? g : number_times(x,integer_divide1(y,g,0)); } object get_lcm(object x,object y) { return get_lcm_abs(number_abs(x),number_abs(y)); } LFD(Llcm)(void) { fixnum i, narg; narg = vs_top - vs_base; if (narg == 0) too_few_arguments(); for (i = 0; i < narg; i++) check_type_integer(&vs_base[i]); vs_top=vs_base; vs_push(number_abs(vs_base[0])); for (i=1;is.s_dbind=make_cons(make_keyword("PCL"),features->s.s_dbind); build_symbol_table(); lsp_init("../lsp/gcl_export.lsp"); ar_init(gcl_defmacro); ar_init(gcl_evalmacros); ar_init(gcl_top); ar_init(gcl_module); lsp_init("../lsp/gcl_autoload.lsp"); } void gcl_init_system(object no_init) { if (type_of(no_init)!=t_symbol) error("Supplied no_init is not of type symbol\n"); ar_check_init(gcl_predlib,no_init); ar_check_init(gcl_setf,no_init); ar_check_init(gcl_arraylib,no_init); ar_check_init(gcl_assert,no_init); ar_check_init(gcl_defstruct,no_init); ar_check_init(gcl_restart,no_init); ar_check_init(gcl_describe,no_init); #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); ar_check_init(gcl_packlib,no_init); ar_check_init(gcl_seq,no_init); ar_check_init(gcl_seqlib,no_init); ar_check_init(gcl_trace,no_init); ar_check_init(gcl_sloop,no_init); ar_check_init(gcl_serror,no_init); ar_check_init(gcl_destructuring_bind,no_init); ar_check_init(gcl_loop,no_init); ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); ar_check_init(gcl_sharp_uv,no_init); ar_check_init(gcl_namestring,no_init); ar_check_init(gcl_logical_pathname_translations,no_init); ar_check_init(gcl_make_pathname,no_init); ar_check_init(gcl_parse_namestring,no_init); ar_check_init(gcl_translate_pathname,no_init); ar_check_init(gcl_directory,no_init); ar_check_init(gcl_merge_pathnames,no_init); ar_check_init(gcl_truename,no_init); ar_check_init(gcl_rename_file,no_init); ar_check_init(gcl_wild_pathname_p,no_init); ar_check_init(gcl_pathname_match_p,no_init); ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_fpe,no_init); ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); ar_check_init(gcl_debug,no_init); ar_check_init(gcl_info,no_init); ar_check_init(gcl_cmptype,no_init); ar_check_init(gcl_cmpbind,no_init); ar_check_init(gcl_cmpblock,no_init); ar_check_init(gcl_cmpcall,no_init); ar_check_init(gcl_cmpcatch,no_init); ar_check_init(gcl_cmpenv,no_init); ar_check_init(gcl_cmpeval,no_init); ar_check_init(gcl_cmpflet,no_init); ar_check_init(gcl_cmpfun,no_init); ar_check_init(gcl_cmpif,no_init); ar_check_init(gcl_cmplabel,no_init); ar_check_init(gcl_cmplam,no_init); ar_check_init(gcl_cmplet,no_init); ar_check_init(gcl_cmploc,no_init); ar_check_init(gcl_cmpmap,no_init); ar_check_init(gcl_cmpmulti,no_init); ar_check_init(gcl_cmpspecial,no_init); ar_check_init(gcl_cmptag,no_init); ar_check_init(gcl_cmptop,no_init); ar_check_init(gcl_cmpvar,no_init); ar_check_init(gcl_cmpvs,no_init); ar_check_init(gcl_cmpwt,no_init); ar_check_init(gcl_cmpmain,no_init); #ifdef HAVE_XGCL lsp_init("../xgcl-2/package.lisp"); ar_check_init(gcl_Xlib,no_init); ar_check_init(gcl_Xutil,no_init); ar_check_init(gcl_X,no_init); ar_check_init(gcl_XAtom,no_init); ar_check_init(gcl_defentry_events,no_init); ar_check_init(gcl_Xstruct,no_init); ar_check_init(gcl_XStruct_l_3,no_init); ar_check_init(gcl_general,no_init); ar_check_init(gcl_keysymdef,no_init); ar_check_init(gcl_X10,no_init); ar_check_init(gcl_Xinit,no_init); ar_check_init(gcl_dwtrans,no_init); ar_check_init(gcl_tohtml,no_init); ar_check_init(gcl_index,no_init); #endif lsp_init("../pcl/package.lisp"); ar_check_init(gcl_pcl_pkg,no_init); ar_check_init(gcl_pcl_walk,no_init); ar_check_init(gcl_pcl_iterate,no_init); ar_check_init(gcl_pcl_macros,no_init); ar_check_init(gcl_pcl_low,no_init); ar_check_init(gcl_pcl_impl_low,no_init); ar_check_init(gcl_pcl_fin,no_init); ar_check_init(gcl_pcl_defclass,no_init); ar_check_init(gcl_pcl_defs,no_init); ar_check_init(gcl_pcl_fngen,no_init); ar_check_init(gcl_pcl_cache,no_init); ar_check_init(gcl_pcl_dlisp,no_init); ar_check_init(gcl_pcl_dlisp2,no_init); ar_check_init(gcl_pcl_boot,no_init); ar_check_init(gcl_pcl_vector,no_init); ar_check_init(gcl_pcl_slots_boot,no_init); ar_check_init(gcl_pcl_combin,no_init); ar_check_init(gcl_pcl_dfun,no_init); ar_check_init(gcl_pcl_fast_init,no_init); ar_check_init(gcl_pcl_braid,no_init); ar_check_init(gcl_pcl_generic_functions,no_init); ar_check_init(gcl_pcl_slots,no_init); ar_check_init(gcl_pcl_init,no_init); ar_check_init(gcl_pcl_std_class,no_init); ar_check_init(gcl_pcl_cpl,no_init); ar_check_init(gcl_pcl_fsc,no_init); ar_check_init(gcl_pcl_methods,no_init); ar_check_init(gcl_pcl_fixup,no_init); ar_check_init(gcl_pcl_defcombin,no_init); ar_check_init(gcl_pcl_ctypes,no_init); ar_check_init(gcl_pcl_env,no_init); ar_check_init(gcl_pcl_compat,no_init); ar_check_init(gcl_pcl_precom1,no_init); ar_check_init(gcl_pcl_precom2,no_init); } static int ngazonk; int gcl_init_cmp_anon(void) { int i=0; switch(ngazonk++) { case 0: ar_check_init(gcl_pcl_gazonk0,Cnil); break; case 1: ar_check_init(gcl_pcl_gazonk1,Cnil); break; case 2: ar_check_init(gcl_pcl_gazonk2,Cnil); break; case 3: ar_check_init(gcl_pcl_gazonk3,Cnil); break; case 4: ar_check_init(gcl_pcl_gazonk4,Cnil); break; case 5: ar_check_init(gcl_pcl_gazonk5,Cnil); break; case 6: ar_check_init(gcl_pcl_gazonk6,Cnil); break; case 7: ar_check_init(gcl_pcl_gazonk7,Cnil); i=1; break; default: i=-1; break; } return i; } gcl-2.6.14/unixport/bsd_rsym.c0000755000175000017500000000663614360276512014667 0ustar cammcamm/* Use this to build an executable rsym, which will grab only the external symbols from an object file, and put them in a simple format: (cf ext_sym.h) This information will be used for relocation. to compile use cc -g rsym.c -o rsym -I../h */ #define BSD #include #include #include "ext_sym.h" /* our defs */ #define TABLE_SIZE 3 #ifdef DEBUG int debug =1; #define dprintf(s,ar) if(debug) { printf(" ( s )",ar) ; fflush(stdout);} #else int debug =0; #define dprintf(s,ar) #endif struct exec my_header; struct syment *my_symbol_table; char *my_string_table; char *start_address; /* this program will get the external symbols from a file writing them out to a file together with their addresses */ void get_myself(); main(argc,argv) int argc ; char *argv[]; { if (argc!=3) {perror("bad arg count");fflush(stdout);exit(1);} get_myself(argv[1]); output_externals(argv[2]); } void get_myself(filename) char *filename; { int i; LDFILE *ldptr; extern char *malloc(); ldptr = ldopen(filename, RDONLY); if (ldptr == NULL) { fprintf(stderr, "Can't open %s\n", filename); exit(1); } ftell(ldptr); fread(&my_header,sizeof(struct exec),1,ldptr); if(N_BADMAG(my_header)){fprintf(stderr,"Bad magic %s",filename); exit(1);}; if(fseek(ldptr,(int)N_SYMOFF(my_header),0)) {fprintf(stderr,"seek error"); exit(1);} my_symbol_table = (struct syment *)malloc(sizeof(struct syment) * NSYMS(my_header)); /* sizeof(struct syment) and SYMESZ are not always the same. */ for (i = 0; i < NSYMS(my_header); i++) FREAD(&my_symbol_table[i], SYMESZ, 1, ldptr); /* If the string table is not empty, its length is stored after the symbol table, This is not described in the manual, and may change in the future. */ /* fseek(ldptr,N_STROFF(my_header),0); strings follow symbol table! */ if (FREAD(&i, 4, 1, ldptr) > 0) { my_string_table = malloc(i); if(debug) {printf(" i is %d Fseek %d ",i,FSEEK(ldptr,i-1,1)); printf(" Fseek back %d ",FSEEK(ldptr,1-i,1));}; FSEEK(ldptr, -4, 1); if(i!=(FREAD(my_string_table, 1, i, ldptr))) {dprintf( i was %d ,i); perror("rsym could not read bad string table") ; exit(1);} } else {fprintf(stderr,"Error: There is no string table \n"); exit(1);} ldclose(ldptr); } int output_externals(outfile) char *outfile; {FILE *symout; char *name; struct lsymbol_table tab; char out[4]; char tem[SYMNMLEN+1]; struct syment *p, *end; tem[SYMNMLEN]=0; tab.n_symbols=0;tab.tot_leng=0; symout=fopen(outfile,"w"); if (!symout) {perror(outfile); exit(1);}; fseek(symout,sizeof(struct lsymbol_table),0); end = my_symbol_table + NSYMS(my_header); for (p = my_symbol_table; p < end; p++) { /* Is the following check enough? */ if EXT_and_TEXT_BSS_DAT(p) { name= SYM_NAME(p); {int i=0; dprintf(tab.n_symbols %d , tab.n_symbols); tab.n_symbols++; fwrite(&(p->n_value),sizeof(int),1,symout); dprintf( p->n_value %d , p->n_value); dprintf( name %s , name); while(tab.tot_leng++,*name) putc(*name++,symout); putc(0,symout); /* fprintf(symout,name); fprintf(symout," %d ", p->n_value); */ }; dprintf( NUM_AUX(p) %d , NUM_AUX(p)); dprintf( index , (int) (p - my_symbol_table) / sizeof(struct syment)); p = p + NUM_AUX(p); } } fseek(symout,0,0); fwrite(&tab,sizeof(tab),1,symout); fclose(symout); return 0; } gcl-2.6.14/unixport/tryserv.tcl0000755000175000017500000000074114360276512015112 0ustar cammcammcatch { close $server } proc jany { args } { global me ; set me [lindex $args 0] ; fconfigure $me -blocking 0 ; fileevent $me readable "joke $me" } proc joke { sock } { if { [eof $sock] } { puts "at end" close $sock return "" } set it [read $sock] puts "<$it>" return } set server [socket -server jany 4008] proc send { s } { global me ; puts $me $s ; flush $me } proc r { } {global me ; read $me } gcl-2.6.14/unixport/makefile.dos0000755000175000017500000001302414360276512015152 0ustar cammcamm HDIR = ../h ODIR = ../o LSPDIR = ../lsp CMPDIR = ../cmpnew PORTDIR = ../unixport MPDIR = ../mp CFLAGS = -c $(DEFS) -I$(HDIR) LDCC = $(CC) -v ISDOS=dos LIBS = -lm # -lpixrect -lc OLDDATE = "DATE" AKCLIB = $(ODIR)/akcllib.a MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a EXE_PREFIX=./ # begin makedefs AKCLDIR=/akcl SHELL=/bin/sh MACHINE=dos-go32 LBINDIR=d:/unix OFLAG = -O # -O LIBS = -lm -lg CAT=cat -B EXE_PREFIX= #gcc 2.1 compiles akcl correctly as far as I have been able to determine. CC = gcc -I${AKCLDIR}/dos -I${AKCLDIR}/o -DVOL=volatile -W ODIR_DEBUG= -O # -O -g # using gcc so dont need this and dont have cc. MYGCC=gcc RANLIB1_O=ranlib akcllib.a RANLIB2_O= RANLIB1_MP=ranlib libmport.a RANLIB2_MP= GNULIB1= ${MPDIR}/gnulib1.o PORTDIR = ..\unixport LSP2C_1=..\xbin\if-exists $(PORTDIR)\saved_kcl rm -f $*.c $*.h $*.data $*.o LSP2C_2=..\xbin\if-exists makefile $(PORTDIR)\saved_kcl $(PORTDIR)/ $* $* S0111 .lsp.c: $(LSP2C_1) $(LSP2C_2) LSP2O_1=..\xbin\if-exists $(PORTDIR)\saved_kcl rm -f $*.c $*.h $*.data $*.o LSP2O_2=..\xbin\if-exists $(PORTDIR)\saved_kcl $(PORTDIR)\saved_kcl $(PORTDIR)/ $* $* S0111 LSP2O_3=..\xbin\if-exists $(PORTDIR)\saved_kcl $(CC) $(OFLAG) $(CFLAGS) $*.c LSP2O_4=..\xbin\if-exists $(PORTDIR)\saved_kcl ..\xbin\append ${NULLFILE} $*.data $*.o .lsp.o: $(LSP2O_1) $(LSP2O_2) $(LSP2O_3) $(LSP2O_4) AS=as MAINDIR = /akcl CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o MPFILES=${MPDIR}/mpi-386d.o ${MPDIR}/libmport.a # objs for libmport.a MPOBJS= mp_divul3.o mp_bfffo.o mp_mulul3.o mp2.o mp_dblrsl3.o mp_dblremul3.o ${MPDIR}/gnulib1.o NATIVE_CC=gcc RSYM = rsym SFASL = $(ODIR)/sfasl.o EXTRA_OTARGETS= # extras for dos (in dos directory) DOS_ODIR=../dos EXX_DOS=${DOS_ODIR}/dostimes.o ${DOS_ODIR}/read.o ${DOS_ODIR}/signal.o ${DOS_ODIR}/sigman.o ${DOS_ODIR}/dum_dos.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) NULLFILE= DPP = ..\bin\dpp # end makedefs LIBS1= $(LIBS) $(AKCLIB) OBJS = $(ODIR)/main.o $(ODIR)/alloc.o $(ODIR)/gbc.o \ $(ODIR)/bitop.o $(ODIR)/typespec.o $(ODIR)/eval.o \ $(ODIR)/macros.o $(ODIR)/lex.o $(ODIR)/bds.o \ $(ODIR)/frame.o $(ODIR)/predicate.o $(ODIR)/reference.o \ $(ODIR)/assignment.o $(ODIR)/bind.o $(ODIR)/let.o \ $(ODIR)/conditional.o $(ODIR)/block.o $(ODIR)/iteration.o \ $(ODIR)/mapfun.o $(ODIR)/prog.o $(ODIR)/multival.o \ $(ODIR)/catch.o $(ODIR)/symbol.o $(ODIR)/cfun.o \ $(ODIR)/cmpaux.o $(ODIR)/package.o $(ODIR)/big.o \ $(ODIR)/number.o $(ODIR)/num_pred.o $(ODIR)/num_comp.o \ $(ODIR)/num_arith.o $(ODIR)/num_sfun.o $(ODIR)/num_co.o \ $(ODIR)/num_log.o $(ODIR)/num_rand.o $(ODIR)/earith.o \ $(ODIR)/character.o $(ODIR)/sequence.o \ $(ODIR)/list.o $(ODIR)/hash.o $(ODIR)/array.o \ $(ODIR)/string.o $(ODIR)/structure.o $(ODIR)/toplevel.o \ $(ODIR)/file.o $(ODIR)/read.o $(ODIR)/backq.o \ $(ODIR)/print.o $(ODIR)/format.o $(ODIR)/pathname.o \ $(ODIR)/unixfsys.o $(ODIR)/unixfasl.o $(ODIR)/error.o \ $(ODIR)/unixtime.o $(ODIR)/unixsys.o $(ODIR)/unixsave.o \ $(ODIR)/unixint.o $(ODIR)/funlink.o \ $(ODIR)/fat_string.o ${ODIR}/run_process.o \ $(ODIR)/init_pari.o ../mp/gnulib1.o $(MPFILES) $(SFASL) $(EXTRA_OTARGETS) LSPOBJS = $(LSPDIR)/defmacro.o $(LSPDIR)/evalmacros.o $(LSPDIR)/top.o \ $(LSPDIR)/module.o $(LSPDIR)/predlib.o $(LSPDIR)/setf.o \ $(LSPDIR)/arraylib.o $(LSPDIR)/assert.o $(LSPDIR)/defstruct.o \ $(LSPDIR)/describe.o $(LSPDIR)/iolib.o $(LSPDIR)/listlib.o \ $(LSPDIR)/mislib.o $(LSPDIR)/numlib.o $(LSPDIR)/packlib.o \ $(LSPDIR)/seq.o $(LSPDIR)/seqlib.o $(LSPDIR)/trace.o \ $(LSPDIR)/sloop.o $(LSPDIR)/debug.o CMPOBJS = $(CMPDIR)/cmpinline.o $(CMPDIR)/cmputil.o $(CMPDIR)/cmptype.o \ $(CMPDIR)/cmpbind.o $(CMPDIR)/cmpblock.o $(CMPDIR)/cmpcall.o \ $(CMPDIR)/cmpcatch.o $(CMPDIR)/cmpenv.o $(CMPDIR)/cmpeval.o \ $(CMPDIR)/cmpflet.o $(CMPDIR)/cmpfun.o $(CMPDIR)/cmpif.o \ $(CMPDIR)/cmplabel.o $(CMPDIR)/cmplam.o $(CMPDIR)/cmplet.o \ $(CMPDIR)/cmploc.o $(CMPDIR)/cmpmap.o $(CMPDIR)/cmpmulti.o \ $(CMPDIR)/cmpspecial.o $(CMPDIR)/cmptag.o $(CMPDIR)/cmptop.o \ $(CMPDIR)/cmpvar.o $(CMPDIR)/cmpvs.o $(CMPDIR)/cmpwt.o KCL=kcl xxxxsaved_$(KCL): raw_$(KCL) $(RSYM) init_kcl.lsp \ $(LSPDIR)/setdoc.lsp \ $(CMPDIR)/cmpmain.lsp \ $(CMPDIR)/lfun_list.lsp \ $(CMPDIR)/cmpopt.lsp akcl${ISDOS}.lsp saved_kcl: raw_kcl # go32 ${EXE_PREFIX}raw_kcl ${PORDIR}/ < akcl${ISDOS}.lsp copy saved_kcl.exe raw_kcl.exe raw_kcl.exe ${PORDIR}/ < akcl${ISDOS}.lsp del raw_kcl.exe akcldos.lsp: cat init_kcl.lsp | \ sed -e "s$(OLDDATE)Version(`cat ../majvers`.`cat ../minvers`) `date`g" \ -e 'ssaved_kclsaved_$(KCL)g' \ -e 'slinks t)links t)(setq compiler::*cc* "$(CC)")$(INITFORM)g' \ -e "sAKCLDIR${AKCLDIR}g" \ -e "s(defun lisp-imp(setq si::*akcl-version* '`cat ../minvers`)(defun lisp-imp'g" > akcldos.lsp rsym: rsym.c $(HDIR)/mdefs.h $(LDCC) $(DEFS) -I../h -o rsym rsym.c $(HDIR)/mdefs.h: $(HDIR)/include.h cat $(HDIR)/include.h | sed -e "/include/d" > $(HDIR)/mdefs.h FOR_RAW=$(OBJS) $(LSPOBJS) $(CMPOBJS) SYS_KCL=sys_kcl.o raw_${KCL}: $(EXX_DOS) ${SYS_KCL} ${FOR_RAW} >raw.$$$$$$ ${OBJS} >>raw.$$$$$$ ${LSPOBJS} >>raw.$$$$$$ ${CMPOBJS} >>raw.$$$$$$ ${EXX_DOS} >>raw.$$$$$$ sys_kcl.o -lm ${ODIR}/akcllib.a ${LDCC} @raw.$$$$$$ -o raw_kcl # copy raw_kcl raw_kcl2 # strip -x raw_kcl2 HFILES = $(HDIR)/include.h \ $(HDIR)/object.h $(HDIR)/vs.h $(HDIR)/symbol.h $(HDIR)/bds.h \ $(HDIR)/frame.h $(HDIR)/lex.h $(HDIR)/eval.h $(HDIR)/external.h \ $(HDIR)/rgbc.h sys_kcl.o: sys_kcl.c $(HFILES) $(CC) $(CFLAGS) sys_kcl.c clean: rm -f saved_$(KCL) raw_$(KCL) *.o core a.out all: raw_kcl gcl-2.6.14/unixport/sys_gcl.c0000755000175000017500000000670714360276512014507 0ustar cammcamm#define FLAVOR "" #include "sys.c" void gcl_init_init() { build_symbol_table(); lsp_init("../lsp/gcl_export.lsp"); ar_init(gcl_defmacro); ar_init(gcl_evalmacros); ar_init(gcl_top); ar_init(gcl_module); lsp_init("../lsp/gcl_autoload.lsp"); } void gcl_init_system(object no_init) { if (type_of(no_init)!=t_symbol) error("Supplied no_init is not of type symbol\n"); ar_check_init(gcl_arraylib,no_init); ar_check_init(gcl_predlib,no_init); ar_check_init(gcl_setf,no_init); ar_check_init(gcl_assert,no_init); ar_check_init(gcl_defstruct,no_init); ar_check_init(gcl_restart,no_init); ar_check_init(gcl_describe,no_init); #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); ar_check_init(gcl_packlib,no_init); ar_check_init(gcl_seq,no_init); ar_check_init(gcl_seqlib,no_init); ar_check_init(gcl_trace,no_init); ar_check_init(gcl_sloop,no_init); ar_check_init(gcl_serror,no_init); ar_check_init(gcl_destructuring_bind,no_init); ar_check_init(gcl_loop,no_init); ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); ar_check_init(gcl_sharp_uv,no_init); ar_check_init(gcl_namestring,no_init); ar_check_init(gcl_logical_pathname_translations,no_init); ar_check_init(gcl_make_pathname,no_init); ar_check_init(gcl_parse_namestring,no_init); ar_check_init(gcl_translate_pathname,no_init); ar_check_init(gcl_directory,no_init); ar_check_init(gcl_merge_pathnames,no_init); ar_check_init(gcl_truename,no_init); ar_check_init(gcl_rename_file,no_init); ar_check_init(gcl_wild_pathname_p,no_init); ar_check_init(gcl_pathname_match_p,no_init); ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_fpe,no_init); ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); ar_check_init(gcl_debug,no_init); ar_check_init(gcl_info,no_init); ar_check_init(gcl_cmptype,no_init); ar_check_init(gcl_cmpbind,no_init); ar_check_init(gcl_cmpblock,no_init); ar_check_init(gcl_cmpcall,no_init); ar_check_init(gcl_cmpcatch,no_init); ar_check_init(gcl_cmpenv,no_init); ar_check_init(gcl_cmpeval,no_init); ar_check_init(gcl_cmpflet,no_init); ar_check_init(gcl_cmpfun,no_init); ar_check_init(gcl_cmpif,no_init); ar_check_init(gcl_cmplabel,no_init); ar_check_init(gcl_cmplam,no_init); ar_check_init(gcl_cmplet,no_init); ar_check_init(gcl_cmploc,no_init); ar_check_init(gcl_cmpmap,no_init); ar_check_init(gcl_cmpmulti,no_init); ar_check_init(gcl_cmpspecial,no_init); ar_check_init(gcl_cmptag,no_init); ar_check_init(gcl_cmptop,no_init); ar_check_init(gcl_cmpvar,no_init); ar_check_init(gcl_cmpvs,no_init); ar_check_init(gcl_cmpwt,no_init); ar_check_init(gcl_cmpmain,no_init); #ifdef HAVE_XGCL lsp_init("../xgcl-2/package.lisp"); ar_check_init(gcl_Xlib,no_init); ar_check_init(gcl_Xutil,no_init); ar_check_init(gcl_X,no_init); ar_check_init(gcl_XAtom,no_init); ar_check_init(gcl_defentry_events,no_init); ar_check_init(gcl_Xstruct,no_init); ar_check_init(gcl_XStruct_l_3,no_init); ar_check_init(gcl_general,no_init); ar_check_init(gcl_keysymdef,no_init); ar_check_init(gcl_X10,no_init); ar_check_init(gcl_Xinit,no_init); ar_check_init(gcl_dwtrans,no_init); ar_check_init(gcl_tohtml,no_init); ar_check_init(gcl_index,no_init); #endif } int gcl_init_cmp_anon(void) { return 1; } gcl-2.6.14/unixport/aix_exports0000755000175000017500000005416314360276512015167 0ustar cammcammconnect_to_server myptrgl setjmp longjmp FIXtemp start main init merge_system_directory vs_overflow bds_overflow frs_overflow ihs_overflow segmentation_catcher cs_overflow end_of_file error Lby c_trace siLargc siLargv siLgetenv siLmark_vs siLcheck_vs siLcatch_fatal siLreset_stack_limits multiply_stacks siLinit_system siLaddress siLnani siLinitialization_failure Lidentity Llisp_implementation_version siLsave_system init_main sbrk1 alloc_page add_page_to_freelist alloc_object grow_linear make_cons on_stack_cons alloc_contblock insert_contblock alloc_relblock init_tm set_maxpage init_alloc cant_get_a_type siLallocate t_from_type siSallocate_sgc siSallocate_growth siLallocated_pages siLmaxpage siLalloc_contpage siLncbpage siLmaxcbpage siLalloc_relpage siLnrbpage siLget_hole_size siLset_hole_size init_alloc_function malloc free realloc calloc cfree enter_mark_origin enter_mark_origin_block mark_cons mark_object mark_stack_carefully mark_phase sweep_phase contblock_sweep_phase GBC siLroom_report siLreset_gbc_count copy_relblock mark_contblock Lgbc siLgbc_time init_GBC check_type_integer check_type_non_negative_integer check_type_rational check_type_float check_type_or_integer_float check_type_or_rational_float check_type_number check_type_bit check_type_character check_type_string_char check_type_symbol check_type_or_symbol_string check_type_or_string_symbol check_type_or_sym_str_pack check_type_package check_type_string check_type_bit_vector check_type_cons check_type_stream check_type_readtable check_type_or_path_sym check_type_or_path_or_strm check_type_random_state check_type_hash_table check_type_array check_type_vector check_type Ltype_of init_typespec init_typespec_function quick_call_sfun call_sfun_no_check call_vfun funcall funcall_no_event lispcall lispcall_no_event symlispcall symlispcall_no_event simple_lispcall simple_lispcall_no_event simple_symlispcall simple_symlispcall_no_event super_funcall super_funcall_no_event eval call_applyhook Lfuncall Lapply Leval Levalhook Lapplyhook Lconstantp ieval ifuncall1 ifuncall2 ifuncall3 funcall_with_catcher fcalln_cclosure fcalln_general fcalln_vfun fcalln funcall_cfun init_eval siLdefine_macro Fdefmacro macro_expand1 macro_def Lmacroexpand Lmacroexpand_1 macro_expand init_macros assoc_eq lex_fun_bind lex_macro_bind lex_tag_bind lex_block_bind lex_tag_sch lex_block_sch init_lex bds_unwind unwind frs_sch frs_sch_catch Lnull Lsymbolp Latom Lconsp Llistp Lnumberp Lintegerp Lrationalp Lfloatp Lcomplexp Lcharacterp Lstringp Lbit_vector_p Lvectorp Lsimple_string_p Lsimple_bit_vector_p Lsimple_vector_p Larrayp Lpackagep Lfunctionp Lcompiled_function_p Lcommonp Leq eql Leql equal Lequal equalp Lequalp Fand For contains_sharp_comma siLcontains_sharp_comma siLspicep siLfixnump init_predicate_function Lfboundp symbol_function Lsymbol_function Fquote Ffunction Lsymbol_value Lboundp Lmacro_function Lspecial_form_p init_reference setq Fsetq Fpsetq Lset siLfset Fmultiple_value_setq Lmakunbound Lfmakunbound Fsetf setf Fpush Fpop Fincf Fdecf clear_compiler_properties siLclear_compiler_properties init_assignment lambda_bind bind_var illegal_lambda find_special let_bind letA_bind parse_key check_other_key parse_key_new parse_key_rest set_key_struct init_bind let_var_list Flet FletA Fmultiple_value_bind Fcompiler_let Fflet Flabels Fmacrolet init_let Fif Fcond Fcase Fwhen Funless init_conditional Fblock Freturn_from Freturn init_block Floop do_var_list Fdo FdoA Fdolist Fdotimes init_iteration Lmapcar Lmaplist Lmapc Lmapl Lmapcan Lmapcon init_mapfun Ftagbody Fprog FprogA Fgo Fprogv Fprogn Fprog1 Fprog2 init_prog Lvalues Lvalues_list Fmultiple_value_list Fmultiple_value_call Fmultiple_value_prog1 init_multival Fcatch siLerror_set Funwind_protect Fthrow init_catch set_up_string_register make_symbol make_ordinary make_special make_constant make_si_ordinary make_si_special make_si_constant make_keyword symbol_value getf get putf putprop sputprop remf remprop keywordp Lget Lremprop Lsymbol_plist Lgetf Lget_properties symbol_name Lsymbol_name Lmake_symbol Lcopy_symbol Lgensym Lgentemp Lsymbol_package Lkeywordp siLput_f siLrem_f siLset_symbol_plist siLputprop odd_plist init_symbol init_symbol_function make_cfun make_sfun make_vfun make_cclosure_new make_cclosure siLmc MFsfun siLmfsfun MFvfun siLmfvfun MFvfun_key siLmfvfun_key MFnew siLmf MF MM siLmm make_function make_si_sfun make_si_vfun1 make_si_function make_special_form siLcompiled_function_name turbo_closure siLturbo_closure init_cfun siLspecialp siLdefvar1 siLdebug siLsetvv init_cmpaux ifloor imod set_VV_data set_VV object_to_char object_to_int object_to_float object_to_double object_to_string call_init do_init init_or_load1 member_string_equal rehash_pack suitable_package_size make_package in_package rename_package find_package coerce_to_package current_package pack_hash intern find_symbol unintern export unexport import shadowing_import shadow use_package unuse_package Lmake_package Lin_package Lfind_package Lpackage_name Lpackage_nicknames Lrename_package Lpackage_use_list Lpackage_used_by_list Lpackage_shadowing_symbols Llist_all_packages Lintern Lfind_symbol Lunintern Lexport Lunexport Limport Lshadowing_import Lshadow Luse_package Lunuse_package siLpackage_internal siLpackage_external no_package package_already siLpackage_size init_package init_package_function extended_div extended_mul stretch_big copy_big copy_to_big big_zerop big_sign big_compare complement_big big_minus add_int_big sub_int_big mul_int_big div_int_big big_plus big_times sub_int_big_big get_standardizing_factor_and_normalize div_big_big big_length big_quotient_remainder_auxiliary big_quotient_remainder normalize_big normalize_big_to_object big_to_double fixint fixnnint make_fixnum make_ratio make_shortfloat make_longfloat make_complex number_to_double init_number number_zerop number_plusp number_minusp number_oddp number_evenp Lzerop Lplusp Lminusp Loddp Levenp init_num_pred number_compare Lall_the_same Lall_different Lnumber_compare Lmonotonically_increasing Lmonotonically_decreasing Lmonotonically_nondecreasing Lmonotonically_nonincreasing Lmax Lmin init_num_comp bignum2 bignum3 fixnum_times fix_big_times big_big_times number_to_complex number_plus one_plus number_minus one_minus number_negate number_times number_divide integer_quotient_remainder_1 integer_divide1 get_gcd Lplus Lminus Ltimes Ldivide Lone_plus Lone_minus Lconjugate Lgcd Llcm zero_divisor init_num_arith fixnum_expt number_exp number_expt number_nlog number_log number_sqrt number_atan2 number_atan number_sin number_cos number_tan Lexp Lexpt Llog Lsqrt Lsin Lcos Ltan Latan init_num_sfun integer_decode_double integer_decode_float double_exponent set_exponent double_to_integer remainder Lfloat Lnumerator Ldenominator Lfloor Lceiling Ltruncate Lround Lmod Lrem Ldecode_float Lscale_float Lfloat_radix Lfloat_sign Lfloat_digits Lfloat_precision Linteger_decode_float Lcomplex Lrealpart Limagpart init_num_co log_op big_log_op ior_op xor_op and_op eqv_op nand_op nor_op andc1_op andc2_op orc1_op orc2_op b_clr_op b_set_op b_1_op b_2_op b_c1_op b_c2_op big_bitp fix_bitp count_int_bits count_bits double_shift shift_integer int_bit_length Llogior Llogxor Llogand Llogeqv Lboole Llogbitp Lash Llogcount Linteger_length bitand bitior bvequal init_num_log siLbit_array_op rando make_random_state advance_random_state Lrandom Lmake_random_state Lrandom_state_p init_num_rand Lstandard_char_p Lgraphic_char_p Lstring_char_p Lalpha_char_p Lupper_case_p Llower_case_p Lboth_case_p digitp Ldigit_char_p Lalphanumericp char_eq Lchar_eq Lchar_neq char_cmp Lchar_cmp Lchar_l Lchar_g Lchar_le Lchar_ge char_equal Lchar_equal Lchar_not_equal char_compare Lchar_compare Lchar_lessp Lchar_greaterp Lchar_not_greaterp Lchar_not_lessp coerce_to_character Lcharacter Lchar_code Lchar_bits Lchar_font Lcode_char Lmake_char Lchar_upcase Lchar_downcase digit_weight Ldigit_char Lchar_int Lint_char Lchar_name Lname_char Lchar_bit Lset_char_bit init_character init_character_function alloc_simple_vector alloc_simple_bitvector Lelt elt siLelt_set elt_set Lsubseq Lcopy_seq length Llength Lreverse reverse Lnreverse nreverse init_sequence_function test_compare test_compare_not test_eql apply_key_function identity setupTEST endp1 car cdr kar kdr stack_cons on_stack_list_vector list_vector on_stack_list list listA tree_equal append copy_list copy_alist copy_tree subst nsubst sublis nsublis Lcar Lcdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr Lcaar Lcadr Lcdar Lcddr Lcaaar Lcaadr Lcadar Lcaddr Lcdaar Lcdadr Lcddar Lcdddr Lcaaaar Lcaaadr Lcaadar Lcaaddr Lcadaar Lcadadr Lcaddar Lcadddr Lcdaaar Lcdaadr Lcdadar Lcdaddr Lcddaar Lcddadr Lcdddar Lcddddr Lenth Lsecond Lthird Lfourth Lfifth Lsixth Lseventh Leighth Lninth Ltenth Lcons Ltree_equal Lendp Llist_length Lnth nth Lnthcdr nthcdr Llast Llist LlistA copy_off_stack_tree on_stack_make_list make_list Lmake_list Lappend Lcopy_list Lcopy_alist Lcopy_tree Lrevappend nconc Lnconc Lreconc Lbutlast Lnbutlast Lldiff Lrplaca Lrplacd Lsubst Lsubst_if Lsubst_if_not Lnsubst Lnsubst_if Lnsubst_if_not sublis1 eq check_alist Lsublis Lnsublis Lmember Lmember_if Lmember_if_not Lmember1 Ltailp Ladjoin Lacons Lpairlis Lassoc_or_rassoc Lassoc Lrassoc Lassoc_or_rassoc_predicate Lassoc_if Lassoc_if_not Lrassoc_if Lrassoc_if_not member_eq siLmemq delete_eq init_list_function hash_eql hash_equal gethash sethash extend_hashtable Lmake_hash_table Lhash_table_p Lgethash siLhash_set Lremhash Lclrhash Lhash_table_count Lsxhash Lmaphash init_hash get_aelttype array_elttype array_address raw_aet_ptr gset copy_array_portion siLcopy_array_portion array_allocself aref aset aref1 aset1 displace undisplace check_displaced adjust_displaced setup_fillp siLmake_pure_array siLmake_vector Laref siLaset Larray_element_type Larray_rank Larray_dimension Larray_total_size Ladjustable_array_p siLdisplaced_array_p Lsvref siLsvset Larray_has_fill_pointer_p Lfill_pointer siLfill_pointer_set siLreplace_array siLaset_by_cursor init_array_function alloc_simple_string make_simple_string string_eq string_equal copy_simple_string coerce_to_string Lchar siLchar_set get_string_start_end Lstring_eq Lstring_equal Lstring_cmp Lstring_l Lstring_g Lstring_le Lstring_ge Lstring_neq Lstring_compare Lstring_lessp Lstring_greaterp Lstring_not_greaterp Lstring_not_lessp Lstring_not_equal Lmake_string member_char Lstring_trim Lstring_left_trim Lstring_right_trim Lstring_trim0 Lstring_case Lstring_upcase Lstring_downcase Lstring_capitalize Lnstring_case Lnstring_upcase Lnstring_downcase Lnstring_capitalize Lstring siLstring_concatenate init_string_function structure_subtypep structure_ref siLstructure_ref1 structure_set siLstructure_subtype_p structure_to_list siLmake_structure siLcopy_structure siLstructure_name siLstructure_ref siLstructure_set siLstructurep siLrplaca_nthcdr siLlist_nth siLmake_s_data_structure siLstructure_def siLsize_of siLaet_type siLalignment init_structure_function Fdefun siLAmake_special siLAmake_constant Feval_when Fdeclare Flocally Fthe init_toplevel feof1 end_of_stream input_stream_p output_stream_p stream_element_type open_stream close_stream make_two_way_stream make_echo_stream make_string_input_stream make_string_output_stream get_output_stream_string readc_stream unreadc_stream writec_stream writestr_stream flush_stream stream_at_end listen_stream file_position file_position_set file_length file_column load Lmake_synonym_stream Lmake_broadcast_stream Lmake_concatenated_stream Lmake_two_way_stream Lmake_echo_stream Lmake_string_input_stream Lmake_string_output_stream Lget_output_stream_string siLoutput_stream_string Lstreamp Linput_stream_p Loutput_stream_p Lstream_element_type Lclose Lopen Lfile_position Lfile_length Lload siLget_string_input_stream_index siLmake_string_output_stream_from_string siLcopy_stream too_long_file_name cannot_open cannot_create cannot_read cannot_write siLuser_stream_state closed_stream coerce_stream siLfp_output_stream siLfp_input_stream Lfwrite Lfread init_file init_file_function read_fasl_data setup_READtable setup_READ setup_standard_READ read_char unread_char peek_char read_object_recursive read_object_non_recursive standard_read_object_non_recursive read_object Lleft_parenthesis_reader parse_number parse_integer read_string read_constituent Ldouble_quote_reader Ldispatch_reader Lsingle_quote_reader Lright_parenthesis_reader Lsemicolon_reader Lsharp_C_reader Lsharp_backslash_reader Lsharp_single_quote_reader Lsharp_left_parenthesis_reader Lsharp_asterisk_reader Lsharp_colon_reader Lsharp_dot_reader Lsharp_comma_reader siLsharp_comma_reader_for_compiler Lsharp_exclamation_reader Lsharp_B_reader Lsharp_O_reader Lsharp_X_reader Lsharp_R_reader Lsharp_A_reader Lsharp_S_reader Lsharp_eq_reader Lsharp_sharp_reader patch_sharp_cons patch_sharp Lsharp_plus_reader Lsharp_minus_reader Lsharp_less_than_reader Lsharp_whitespace_reader Lsharp_right_parenthesis_reader Lsharp_vertical_bar_reader Ldefault_dispatch_macro Lsharp_double_quote_reader Lsharp_dollar_reader copy_readtable current_readtable Lread Lread_preserving_whitespace Lread_delimited_list Lread_line Lread_char Lunread_char Lpeek_char Llisten Lread_char_no_hang Lclear_input Lparse_integer Lread_byte read_byte1 read_char1 Lcopy_readtable Lreadtablep Lset_syntax_from_char Lset_macro_character Lget_macro_character Lmake_dispatch_macro_character Lset_dispatch_macro_character Lget_dispatch_macro_character string_to_object siLstring_to_object siLstandard_readtable too_long_token too_long_string extra_argument init_read init_read_function read_fasl_vector1 kwote_cdr kwote_car backq_cdr backq_car backq Lcomma_reader Lbackquote_reader init_backq writec_queue flush_queue writec_PRINTstream write_str write_decimal write_decimal1 write_addr write_base edit_double write_double call_structure_print_function write_object travel_push_object setupPRINTcircle setupPRINTdefault cleanupPRINT write_object_by_default terpri_by_default potential_number_p Lwrite Lprin1 Lprint Lpprint Lprinc Lwrite_char Lwrite_string Lwrite_line Lterpri Lfresh_line Lfinish_output Lforce_output Lclear_output Lwrite_byte init_print princ prin1 print terpri write_string princ_str princ_char pp init_print_function fmt_tempstr ctl_advance fmt_advance format fmt_skip fmt_max_param fmt_not_colon fmt_not_atsign fmt_not_colon_atsign fmt_set_param fmt_ascii fmt_S_expression fmt_decimal fmt_binary fmt_octal fmt_hexadecimal fmt_radix fmt_integer fmt_nonillion fmt_thousand fmt_write_numeral fmt_write_ordinal fmt_roman fmt_plural fmt_character fmt_fix_float fmt_exponent_length fmt_exponent fmt_exponent1 fmt_exponential_float fmt_general_float fmt_dollars_float fmt_percent fmt_ampersand fmt_bar fmt_tilde fmt_newline fmt_tabulate fmt_asterisk fmt_indirection fmt_case fmt_conditional fmt_iteration fmt_justification fmt_up_and_out fmt_semicolon LVformat Lformat fmt_error init_format make_pathname parse_namestring coerce_to_pathname default_device merge_pathnames namestring coerce_to_namestring Lpathname Lparse_namestring Lmerge_pathnames Lmake_pathname Lpathnamep Lpathname_host Lpathname_device Lpathname_directory Lpathname_name Lpathname_type Lpathname_version Lnamestring Lfile_namestring Ldirectory_namestring Lhost_namestring Lenough_namestring init_pathname init_pathname_function ourgetwd coerce_to_filename truename file_exists backup_fopen file_len Ltruename Lrename_file Ldelete_file Lprobe_file Lfile_write_date Lfile_author Luser_homedir_pathname Ldirectory siLchdir init_unixfsys init_unixfasl terminal_interrupt ihs_function_name ihs_top_function_name call_error_handler FEerror FEwrong_type_argument FEtoo_few_arguments FEtoo_few_argumentsF FEtoo_many_arguments FEtoo_many_argumentsF FEinvalid_macro_call FEunexpected_keyword FEinvalid_form FEunbound_variable FEinvalid_variable FEundefined_function FEinvalid_function CEerror get_ihs_ptr siLihs_top siLihs_fun siLihs_vs get_frame_ptr siLfrs_top siLfrs_vs siLfrs_bds siLfrs_class siLfrs_tag siLfrs_ihs get_bds_ptr siLbds_top siLbds_var siLbds_val get_vs_ptr siLvs_top siLvs siLsch_frs_base siLinternal_super_go siLuniversal_error_handler check_arg_failed too_few_arguments too_many_arguments ck_larg_at_least ck_larg_exactly invalid_macro_call keyword_value_mismatch not_a_keyword unexpected_keyword wrong_type_argument illegal_declare not_a_symbol not_a_variable illegal_index Lerror LVerror Lcerror vfun_wrong_number_of_args init_error runtime unix_time_to_universal_time Lget_universal_time Lsleep Lget_internal_run_time Lget_internal_real_time init_unixtime Lsystem init_unixsys filecpy memory_save Lsave init_unixsave sigalrm sigint sigfpe init_interrupt init_interrupt1 call_or_link vpush_extend Luse_fast_links delete_link use_fast_links clean_link_array c_apply_n call_proc call_vproc call_proc0 call_proc1 call_proc2 ifuncall imfuncall clear_stack set_mv mv_ref init_links do_hash write_fasd_top read_fasd_top open_fasd close_fasd write_fasd circular_not_first fasd_patch_sharp_cons fasd_patch_sharp is_it_there find_sharing_top find_sharing make_bignum read_fasd lisp_eval grow_vector bad_eof read_fasd1 clrhash read_fasl_vector init_fasdump check_type_fat_string siLfsref siLfsset fs_leader_ref check_raw siLfs_leader_ref siLfixnum_fs_leader_ref fs_leader_set siLfs_leader_set siLfixnum_fs_leader_set mark_fat_string siLfs_array_total_size siLfs_fill_pointer siLset_fs_fill_pointer make_fat_string siLmake_fat_string alloc_fs siLprofile siLfunction_start read_special_symbols node_compare siLread_externals cfuns_to_combined_table address_node_compare siLset_up_combined prof_ind string_sum siLdisplay_profile siLarray_adress init_fat_string temp_malloc relocate fasload get_extra_bss relocate_symbols set_symbol_address build_symbol_table add_symbol init_defmacro init_evalmacros init_top init_module init_predlib init_setf init_arraylib init_assert init_defstruct init_describe init_iolib init_listlib init_mislib init_numlib init_packlib init_seq init_seqlib init_trace init_sloop init_debug init_cmpinline init_cmputil init_cmptype init_cmpbind init_cmpblock init_cmpcall init_cmpcatch init_cmpenv init_cmpeval init_cmpflet init_cmpfun init_cmpif init_cmplabel init_cmplam init_cmplet init_cmploc init_cmpmap init_cmpmulti init_cmpspecial init_cmptag init_cmptop init_cmpvar init_cmpvs init_cmpwt init_init init_system fsav $SAVEF14 Ssavef14 _savef14 $SAVEF15 Ssavef15 _savef15 $SAVEF16 Ssavef16 _savef16 $SAVEF17 Ssavef17 _savef17 $SAVEF18 Ssavef18 _savef18 $SAVEF19 Ssavef19 _savef19 $SAVEF20 Ssavef20 _savef20 $SAVEF21 Ssavef21 _savef21 $SAVEF22 Ssavef22 _savef22 $SAVEF23 Ssavef23 _savef23 $SAVEF24 Ssavef24 _savef24 $SAVEF25 Ssavef25 _savef25 $SAVEF26 Ssavef26 _savef26 $SAVEF27 Ssavef27 _savef27 $SAVEF28 Ssavef28 _savef28 $SAVEF29 Ssavef29 _savef29 $SAVEF30 Ssavef30 _savef30 $SAVEF31 Ssavef31 _savef31 _savef3 fres $RESTF14 Srestf14 _restf14 $RESTF15 Srestf15 _restf15 $RESTF16 Srestf16 _restf16 $RESTF17 Srestf17 _restf17 $RESTF18 Srestf18 _restf18 $RESTF19 Srestf19 _restf19 $RESTF20 Srestf20 _restf20 $RESTF21 Srestf21 _restf21 $RESTF22 Srestf22 _restf22 $RESTF23 Srestf23 _restf23 $RESTF24 Srestf24 _restf24 $RESTF25 Srestf25 _restf25 $RESTF26 Srestf26 _restf26 $RESTF27 Srestf27 _restf27 $RESTF28 Srestf28 _restf28 $RESTF29 Srestf29 _restf29 $RESTF30 Srestf30 _restf30 $RESTF31 Srestf31 _restf31 _restf3 $PTRGL fp_set_xcp itrunc uitrunc bcopy ovbcopy _moveeq memcpy memmove cvtloop imul_dbl mf2x2 mf2x1 copysign ecvt fcvt cvt pwr10 rint strtol fcntl lockfx ioctl ioctlx read readv readx readvx stat lstat fstat fullstat ffullstat write writev writex writevx bzero abort bcmp bsearch atexit exit getcwd getenv getwd isupper memccpy memchr memcmp memset moncontrol monstartup monitor perror qsort raise setlocale get_ctab get_locinfo get_infoptr signal sigset sigignore sigemptyset sigfillset sigaddset sigdelset sigismember sleep tolower closedir fdopen fgets _filbuf _findiop _cleanup fclose fflush _flsbuf _xflsbuf _wrtchk _findbuf _bufsync fopen freopen fread fseek ftell fwrite getdtablesize opendir popen pclose _readdir readdir rewind setbuf system ungetc NLcatgets NLgetamsg catopen NLcatopen _do_open catclose _do_read_msg dbm_open dbm_close dbm_forder dbm_fetch dbm_delete dbm_store dbm_firstkey dbm_nextkey innetgr bindresvport setnetgrent endnetgrent getnetgrent _NLinit NLfprintf _doprnt fprintf printf sprintf authnone_create clntudp_bufcreate clntudp_create _rpc_dtablesize pmap_getport xdr_pmap xdr_opaque_auth xdr_des_block xdr_accepted_reply xdr_rejected_reply xdr_replymsg xdr_callhdr _seterr_reply xdr_free xdr_void xdr_int xdr_u_int xdr_long xdr_u_long xdr_short xdr_u_short xdr_char xdr_u_char xdr_bool xdr_enum xdr_opaque xdr_bytes xdr_netobj xdr_union xdr_string xdr_wrapstring xdrmem_create isatty geteuid setgrjunk getgrgid getgrnam setgrent endgrent fgetgrent getgrent getpwnam getpwuid setpwent endpwent setpwfile getpwent getuid NLstrlen NCstrlen NLstrdlen index strcat strchr strcmp strcpy strlen strncmp strncpy strpbrk strspn strtok exec_args exec_argv execl execv wait3 wait waitpid alarm gettimeofday time _yp_dobind yp_bind yp_unbind yp_get_default_domain usingypmap yp_first v1prot_dofirst yp_next v1prot_donext yp_match ypprot_err _xdr_yprequest _xdr_ypresponse _xdr_ypbind_oldsetdom xdr_datum xdr_ypdomain_wrap_string xdr_ypmap_wrap_string xdr_ypreq_key xdr_ypreq_nokey xdr_ypresp_val xdr_ypresp_key_val xdr_yp_inaddr xdr_yp_binding xdr_ypbind_resp xdr_ypowner_wrap_string xdr_ypmap_parms acl_get acl_fget acl_put acl_fput getgroupattr putgroupattr endgroups IDtogroup grouptoID nextgroup getuserpw putuserpw neweval findattr addeval setuserdb setpwdb setattr endattr getuattr putattr rmufile enduserdb endpwdb getableinfo afclose afgetatr afgetrec afnxtrec afopen afread afrewind aflookup afsave getlibsmsg endlibsmsg opst clst opgroup clgroup oppwd clpwd opbase clbase rdbase rdpwd rdgrps rdgroup rdaudit rdst readattr setintattr nextentry nextattr nextrec freeval chgstanza chgcolon getint getstr getquotes getlist cpybool getbool putstr putbool putquotes putlist putint rmaudit rmrecord wrpass wrgrps wraudit wrname commit updatefile deletefile atan cos exp expm1 expinner log loginner pow sin sqrt brk chdir chacl close creat execve _exit fchacl fchown fork fstatacl fstatfs fstatx ftruncate getdirent getpid getuidx kfcntl kill kioctl kreadv kwaitpid kwritev loadquery lockf lseek open pipe privcheck profil rename gettimer gettimerid incinterval nsleep sbrk select sigaction sigcleanup sigprocmask statacl statx times ulimit unlink socket bind connect sendto recvfrom getsockname getdomainname gcl-2.6.14/unixport/gcrt0.el0000755000175000017500000000031314360276512014224 0ustar cammcamm(setq case-replace nil) (setq case-fold-search nil) (find-file "gcrt0.o") (replace-string "start" "Start") (goto-char (point-min)) (replace-string "_environ" "_Environ") (write-file "gcrt0-mod.o") gcl-2.6.14/unixport/rsym_macosx.c0000644000175000017500000000405714360276512015401 0ustar cammcamm/* File rsym_macosx.c Build an executable rsym for Mac OS X (31 July 2003). Grab only the external symbols from a Mach-O object file, and put them in a simple format. This information will be used for relocation. To compile in standalone mode: gcc -DDEBUG -DSTANDALONE -I../h -o rsym_macosx rsym_macosx.c Aurelien Chanudet (aurelienDOTchanudetATm4xDOTorg) */ #include #include #include #include #include #include #include #include #include #include #define IN_RSYM 1 #include "ext_sym.h" #define massert(a_) if (!(a_)) {fprintf(stderr,"The assertion %s on line %d of %s in function %s failed", \ #a_,__LINE__,__FILE__,__FUNCTION__);exit(-1);} int main(int argc,char * argv[],char **envp) { struct stat ss; struct mach_header *mh; struct load_command *lc; struct symtab_command *st=NULL; struct nlist *sym1,*sym,*syme; struct lsymbol_table tab; char *strtab; void *addr; int i,l; FILE *f; massert(!stat(argv[1],&ss)); massert((l=open(argv[1],O_RDONLY,0))>0); massert((addr=mmap(0,ss.st_size,PROT_READ|PROT_WRITE,MAP_PRIVATE,l,0))!=(void *)-1); mh=addr; lc=addr+sizeof(*mh); for (i=0;incmds;i++,lc=(void *)lc+lc->cmdsize) if (lc->cmd==LC_SYMTAB) { st=(void *) lc; break; } massert(st); sym1=addr+st->symoff; syme=sym1+st->nsyms; strtab=addr+st->stroff; tab.n_symbols=0; tab.tot_leng=0; massert(f=fopen (argv[2], "wb")); fseek(f,sizeof(tab),0); for (sym=sym1;symn_un.n_strx + strtab; if (sym->n_type & N_STAB) continue; if (!(sym->n_type & N_EXT)) continue; fwrite (&sym->n_value,sizeof(sym->n_value),1,f); tab.n_symbols++; fprintf(f,"%s",name); putc (0, f); tab.tot_leng+=strlen(name)+1; } fseek (f, 0, 0); fwrite (&tab, sizeof(tab), 1, f); fclose (f); munmap(addr,ss.st_size); close (l); return 0; } gcl-2.6.14/unixport/lspboots0000755000175000017500000000020314360276512014451 0ustar cammcammarraylib assert debug defmacro defstruct describe dummy iolib listlib mislib module numlib packlib seq seqlib setf sloop top trace gcl-2.6.14/unixport/sys_ansi_gcl.c0000644000175000017500000001355314360276512015513 0ustar cammcamm#define FLAVOR "ansi_" #include "sys.c" void gcl_init_init() { object features; features=find_symbol(make_simple_string("*FEATURES*"),system_package); features->s.s_dbind=make_cons(make_keyword("ANSI-CL"),make_cons(make_keyword("COMMON-LISP"),features->s.s_dbind)); build_symbol_table(); lsp_init("../lsp/gcl_export.lsp"); ar_init(gcl_defmacro); ar_init(gcl_evalmacros); ar_init(gcl_top); ar_init(gcl_module); lsp_init("../lsp/gcl_autoload.lsp"); } void gcl_init_system(object no_init) { if (type_of(no_init)!=t_symbol) error("Supplied no_init is not of type symbol\n"); ar_check_init(gcl_predlib,no_init); ar_check_init(gcl_setf,no_init); ar_check_init(gcl_arraylib,no_init); ar_check_init(gcl_assert,no_init); ar_check_init(gcl_defstruct,no_init); ar_check_init(gcl_restart,no_init); ar_check_init(gcl_describe,no_init); #ifdef HAVE_JAPI_H ar_check_init(gcl_japi,no_init); #endif ar_check_init(gcl_listlib,no_init); ar_check_init(gcl_mislib,no_init); ar_check_init(gcl_numlib,no_init); ar_check_init(gcl_packlib,no_init); ar_check_init(gcl_seq,no_init); ar_check_init(gcl_seqlib,no_init); ar_check_init(gcl_trace,no_init); ar_check_init(gcl_sloop,no_init); ar_check_init(gcl_serror,no_init); ar_check_init(gcl_destructuring_bind,no_init); ar_check_init(gcl_loop,no_init); ar_check_init(gcl_defpackage,no_init); ar_check_init(gcl_make_defpackage,no_init); ar_check_init(gcl_sharp,no_init); ar_check_init(gcl_sharp_uv,no_init); ar_check_init(gcl_namestring,no_init); ar_check_init(gcl_logical_pathname_translations,no_init); ar_check_init(gcl_make_pathname,no_init); ar_check_init(gcl_parse_namestring,no_init); ar_check_init(gcl_translate_pathname,no_init); ar_check_init(gcl_directory,no_init); ar_check_init(gcl_merge_pathnames,no_init); ar_check_init(gcl_truename,no_init); ar_check_init(gcl_rename_file,no_init); ar_check_init(gcl_wild_pathname_p,no_init); ar_check_init(gcl_pathname_match_p,no_init); ar_check_init(gcl_iolib,no_init); ar_check_init(gcl_fpe,no_init); ar_check_init(gcl_cmpinline,no_init); ar_check_init(gcl_cmputil,no_init); ar_check_init(gcl_debug,no_init); ar_check_init(gcl_info,no_init); ar_check_init(gcl_cmptype,no_init); ar_check_init(gcl_cmpbind,no_init); ar_check_init(gcl_cmpblock,no_init); ar_check_init(gcl_cmpcall,no_init); ar_check_init(gcl_cmpcatch,no_init); ar_check_init(gcl_cmpenv,no_init); ar_check_init(gcl_cmpeval,no_init); ar_check_init(gcl_cmpflet,no_init); ar_check_init(gcl_cmpfun,no_init); ar_check_init(gcl_cmpif,no_init); ar_check_init(gcl_cmplabel,no_init); ar_check_init(gcl_cmplam,no_init); ar_check_init(gcl_cmplet,no_init); ar_check_init(gcl_cmploc,no_init); ar_check_init(gcl_cmpmap,no_init); ar_check_init(gcl_cmpmulti,no_init); ar_check_init(gcl_cmpspecial,no_init); ar_check_init(gcl_cmptag,no_init); ar_check_init(gcl_cmptop,no_init); ar_check_init(gcl_cmpvar,no_init); ar_check_init(gcl_cmpvs,no_init); ar_check_init(gcl_cmpwt,no_init); ar_check_init(gcl_cmpmain,no_init); #ifdef HAVE_XGCL lsp_init("../xgcl-2/package.lisp"); ar_check_init(gcl_Xlib,no_init); ar_check_init(gcl_Xutil,no_init); ar_check_init(gcl_X,no_init); ar_check_init(gcl_XAtom,no_init); ar_check_init(gcl_defentry_events,no_init); ar_check_init(gcl_Xstruct,no_init); ar_check_init(gcl_XStruct_l_3,no_init); ar_check_init(gcl_general,no_init); ar_check_init(gcl_keysymdef,no_init); ar_check_init(gcl_X10,no_init); ar_check_init(gcl_Xinit,no_init); ar_check_init(gcl_dwtrans,no_init); ar_check_init(gcl_tohtml,no_init); ar_check_init(gcl_index,no_init); #endif lsp_init("../pcl/package.lisp"); ar_check_init(gcl_pcl_pkg,no_init); ar_check_init(gcl_pcl_walk,no_init); ar_check_init(gcl_pcl_iterate,no_init); ar_check_init(gcl_pcl_macros,no_init); ar_check_init(gcl_pcl_low,no_init); ar_check_init(gcl_pcl_impl_low,no_init); ar_check_init(gcl_pcl_fin,no_init); ar_check_init(gcl_pcl_defclass,no_init); ar_check_init(gcl_pcl_defs,no_init); ar_check_init(gcl_pcl_fngen,no_init); ar_check_init(gcl_pcl_cache,no_init); ar_check_init(gcl_pcl_dlisp,no_init); ar_check_init(gcl_pcl_dlisp2,no_init); ar_check_init(gcl_pcl_boot,no_init); ar_check_init(gcl_pcl_vector,no_init); ar_check_init(gcl_pcl_slots_boot,no_init); ar_check_init(gcl_pcl_combin,no_init); ar_check_init(gcl_pcl_dfun,no_init); ar_check_init(gcl_pcl_fast_init,no_init); ar_check_init(gcl_pcl_braid,no_init); ar_check_init(gcl_pcl_generic_functions,no_init); ar_check_init(gcl_pcl_slots,no_init); ar_check_init(gcl_pcl_init,no_init); ar_check_init(gcl_pcl_std_class,no_init); ar_check_init(gcl_pcl_cpl,no_init); ar_check_init(gcl_pcl_fsc,no_init); ar_check_init(gcl_pcl_methods,no_init); ar_check_init(gcl_pcl_fixup,no_init); ar_check_init(gcl_pcl_defcombin,no_init); ar_check_init(gcl_pcl_ctypes,no_init); ar_check_init(gcl_pcl_env,no_init); ar_check_init(gcl_pcl_compat,no_init); ar_check_init(gcl_pcl_precom1,no_init); ar_check_init(gcl_pcl_precom2,no_init); lsp_init("../clcs/package.lisp"); ar_check_init(gcl_clcs_precom,no_init); ar_check_init(gcl_clcs_handler,no_init); ar_check_init(gcl_clcs_conditions,no_init); ar_check_init(gcl_clcs_condition_definitions,no_init); } static int ngazonk; int gcl_init_cmp_anon(void) { int i=0; switch(ngazonk++) { case 0: ar_check_init(gcl_pcl_gazonk0,Cnil); break; case 1: ar_check_init(gcl_pcl_gazonk1,Cnil); break; case 2: ar_check_init(gcl_pcl_gazonk2,Cnil); break; case 3: ar_check_init(gcl_pcl_gazonk3,Cnil); break; case 4: ar_check_init(gcl_pcl_gazonk4,Cnil); break; case 5: ar_check_init(gcl_pcl_gazonk5,Cnil); break; case 6: ar_check_init(gcl_pcl_gazonk6,Cnil); break; case 7: ar_check_init(gcl_pcl_gazonk7,Cnil); i=1; break; default: i=-1; break; } return i; } gcl-2.6.14/unixport/cmpboots0000755000175000017500000000020714360276512014436 0ustar cammcammcmpbind cmpblock cmpcatch cmpenv cmpflet cmpfun cmplabel cmplam cmploc cmpmap cmpmulti cmpspecial cmptag cmptop cmptype cmputil cmpvs gcl-2.6.14/unixport/rsym.c0000755000175000017500000001767614360276512014045 0ustar cammcamm/* Copyright William Schelter. All rights reserved. Use this to build an executable rsym, which will grab only the external symbols from an object file, and put them in a simple format: (cf ext_sym.h) This information will be used for relocation. to compile use cc rsym.c -o rsym -I../h */ #define IN_RSYM 1 #include #include "include.h" #ifdef SPECIAL_RSYM #include SPECIAL_RSYM #else /* #include "mdefs.h" */ #include "ext_sym.h" #ifdef ATT /* #include */ #endif struct filehdr my_header; int nsyms; struct syment *symbol_table; char *my_string_table; char *start_address; #ifdef RSYM_AUX #include RSYM_AUX #endif /* our defs */ #define TABLE_SIZE 3 #ifdef DEBUG int debug =1; #undef dprintf #define dprintf(s,ar) if(debug) { printf(" ( s )",ar) ; fflush(stdout);} #else int debug =0; #define dprintf(s,ar) #endif /* this program will get the external symbols from a file writing them out to a file together with their addresses */ static char *outfile; main(argc,argv) int argc ; char *argv[]; { if (argc!=3) {perror("bad arg count"); fflush(stdout); exit(1);} #ifdef SET_BINARY_MODE SET_BINARY_MODE #endif get_myself(argv[1]); output_externals(outfile=argv[2]); exit(0); } get_myself(filename) char *filename; { unsigned int i; FILE *fp; int string_size=0; extern char *malloc(); fp = fopen(filename, RDONLY); if (fp == NULL) { fprintf(stderr, "Can't open %s\n", filename); exit(1); } HEADER_SEEK(fp); fread((char *)&my_header,sizeof(struct filehdr),1,fp); if(N_BADMAG(my_header)){ fprintf(stderr,"Bad magic %s",filename); exit(1);}; nsyms=NSYMS(my_header); symbol_table = (struct syment *)malloc(sizeof(struct syment) * nsyms); /* sizeof(struct syment) and SYMESZ are not always the same. */ if(fseek(fp,(int)(N_SYMOFF(my_header)),0)) {fprintf(stderr,"seek error"); exit(1);} for (i = 0; i < nsyms; i++) #ifdef HPUX { fread((char *)&symbol_table[i], SYMESZ, 1, fp); dprintf(string_size %d,string_size); symbol_table[i].n_un.n_strx = string_size; string_size += symbol_table[i].n_length + 1; fseek(fp,symbol_table[i].n_length,1); } #else fread((char *)&symbol_table[i], SYMESZ, 1, fp); #endif /* If the string table is not empty, its length is stored after the symbol table, This is not described in the manual, and may change in the future. */ /* fseek(fp,N_STROFF(my_header),0); strings follow symbol table! */ #ifndef HPUX #ifdef N_STROFF fseek(fp,N_STROFF(my_header),0); #endif if (fread((char *)&string_size, 4, 1, fp) > 0) { my_string_table = malloc(string_size); if(debug) {printf(" string_size is %d fseek %d ",string_size,fseek(fp,string_size-1,1)); printf(" fseek back %d ",fseek(fp,1-string_size,1));}; fseek(fp, -4, 1); if(string_size!=(fread(my_string_table, 1, string_size, fp))) {dprintf( string_size was %d ,string_size); perror("rsym could not read bad string table") ; exit(1);} } else {fprintf(stderr,"Error: There is no string table \n"); exit(1);} #else { char *p; int slen; p = my_string_table=malloc((unsigned int)string_size); dprintf( string table leng = %d, string_size); fseek(fp,(int)( LESYM_OFFSET(my_header)), 0); for (i = 0; i < nsyms; i++) { fseek(fp,SYMESZ, 1); slen = symbol_table[i].n_length; dprintf( slen = %d,slen); fread(p,slen,1,fp); *((p)+slen) = '\0'; dprintf( p = %s,p ); dprintf(symbol_table[i].n_type %d, symbol_table[i].n_type); p += symbol_table[i].n_length + 1; } } #endif fclose(fp); } struct lsymbol_table tab; output_externals(out) char *out; {FILE *symout; char *name; char tem[SYMNMLEN+1]; struct syment *p, *end; tem[SYMNMLEN]=0; tab.n_symbols=0; tab.tot_leng=0; symout=fopen(out,"wr"); if (!symout) {perror(out); exit(1);}; fseek(symout,sizeof(struct lsymbol_table),0); end = symbol_table + nsyms; for (p = symbol_table; p < end; p++) { /* Is the following check enough? */ if (EXT_and_TEXT_BSS_DAT(p)) { name= SYM_NAME(p); { dprintf(tab.n_symbols %d , tab.n_symbols); tab.n_symbols++; {int i = (p->n_value); #ifdef AIX3 if (p->n_scnum == TEXT_NSCN) i = i + 0x10000e00; else i += DBEGIN; /* leave space for the toc entry. */ #endif fwrite((char *)&i,sizeof(int),1,symout);} #ifdef AIX3 {short j=0; fwrite((char *)&j,sizeof(short),1,symout);} #endif dprintf( p->n_value %d , p->n_value); dprintf( name %s , name); while(tab.tot_leng++,*name) putc(*name++,symout); putc(0,symout); /* fprintf(symout,name); fprintf(symout," %d ", p->n_value); */ }; dprintf( NUM_AUX(p) %d , NUM_AUX(p)); dprintf( index , (int) (p - symbol_table) / sizeof(struct syment)); p = p + NUM_AUX(p); } } fseek(symout,0,0); fwrite(&tab,sizeof(tab),1,symout); fclose(symout); #ifdef AIX3 add_tc_offsets(outfile); #endif return 0; } #ifdef AIX3 int node_compare(); struct node * find_sym(sym,name) struct syment *sym; char *name; { char tem[SYMNMLEN +1]; tem [SYMNMLEN] = 0; if (name==0) name = SYM_NAME(sym); {struct node joe; joe.string=name; return (struct node *) bsearch((char *)(&joe),(char*) (c_table.ptable), c_table.length, sizeof(struct node), node_compare); }} add_tc_offsets(out) char *out; {FILE *symin; char *symbols; char *name; int i,jj; symin=fopen(out ,"r"); if(!symin) perror("can't open"); if(!fread((char *)&tab,sizeof(tab),1,symin)) perror("No header"); symbols=malloc(tab.tot_leng); c_table.alloc_length=( (PTABLE_EXTRA+ tab.n_symbols)); (c_table.ptable) = (TABL *) malloc(sizeof(struct node) * c_table.alloc_length); if (!(c_table.ptable)) {perror("could not allocate"); exit(1);}; i=0; c_table.length=tab.n_symbols; while(i < tab.n_symbols) {unsigned short tc_off; fread((char *)&jj,sizeof(int),1,symin); fread((char *)&tc_off,sizeof(short),1,symin); SYM_TC_OFF(c_table,i) = tc_off; (SYM_ADDRESS(c_table,i))=jj; SYM_STRING(c_table,i)=symbols; while( *(symbols++) = getc(symin)) {;} dprintf( "(name %s ", SYM_STRING(c_table,i)); dprintf( "addr %x )" , jj); i++; } qsort((char*)(c_table.ptable),(int)(c_table.length), sizeof(struct node),node_compare); {struct syment *sym, *end = symbol_table + nsyms; char tem[SYMNMLEN+1]; int toc_anchor =0; tem[SYMNMLEN]=0; for (sym=symbol_table ; sym < end ; sym = sym +1+ NUM_AUX(sym)) {if( sym->n_scnum != DATA_NSCN || NUM_AUX(sym) == 0) continue; if (toc_anchor == 0 && ((union auxent *)(sym+1))->x_csect.x_smclas == XMC_TC0) {toc_anchor = sym->n_value; continue;} if (((union auxent *)(sym+1))->x_csect.x_smclas == XMC_TC) { struct node joe; struct node *answ; name = SYM_NAME(sym); joe.string = name; answ = (struct node *) bsearch((char *)(&joe),(char*) (c_table.ptable), c_table.length, sizeof(struct node), node_compare); if (answ == 0) continue; if(toc_anchor ==0) {printf("TC symbol before tco: %s,",name); continue;} answ->tc_offset = (sym->n_value - toc_anchor); }} /* fix ptrgl to point to the one in the data section for shorter branches */ {struct node *a=find_sym(0,"myptrgl"); if (a == 0 ) printf("couldn't find ptrgl"); else {a->string[0]= '.'; a->string[1]= '_'; a->tc_offset = 0;} } fclose(symin); symin=fopen(out,"w"); if(symin==0) perror("can't open"); fwrite(&tab,sizeof(tab),1,symin); fseek(symin,sizeof(tab),0); {int i,j; unsigned short k; for (i=0 ; i < tab.n_symbols ; i++) {k = SYM_TC_OFF(c_table,i); j= SYM_ADDRESS(c_table,i); fwrite((char *)&j,sizeof(int),1,symin); fwrite((char *)&k,sizeof(short),1,symin); name = SYM_STRING(c_table,i); while(*name) {putc(*name,symin); *name++;} putc(0,symin); }}} fclose(symin); } node_compare(node1,node2) struct node *node1, *node2; { return(strcmp(node1->string, node2->string));} #endif /*aix3 */ #endif /* SPECIAL_RSYM */ gcl-2.6.14/unixport/sys_init.lsp.in0000644000175000017500000000616214360276512015656 0ustar cammcamm(make-package :compiler :use '(:lisp :si)) (make-package :sloop :use '(:lisp)) (make-package :ansi-loop :use'(:lisp)) (make-package :defpackage :use '(:lisp)) (make-package :tk :use '(:lisp :sloop)) (make-package :fpe :use '(:lisp)) (make-package :cltl1-compat) (in-package :system) (use-package :fpe) (init-system) (in-package :si) (gbc t) (unless *link-array* (setq *link-array* (make-array (ash 1 11) :element-type 'character :fill-pointer 0))) (use-fast-links t) (let* ((x (append (pathname-directory *system-directory*) (list :back))) (lsp (append x (list "lsp"))) (cmpnew (append x (list "cmpnew"))) (h (append x (list "h"))) (xgcl-2 (append x (list "xgcl-2"))) (pcl (append x (list "pcl"))) (clcs (append x (list "clcs"))) (gtk (append x (list "gcl-tk")))) (dolist (d (list lsp cmpnew #+(and xgcl (not pre-gcl)) xgcl-2 #+(or pcl ansi-cl) pcl #+ansi-cl clcs)) (load (make-pathname :name "sys-proclaim" :type "lisp" :directory d))) (load (make-pathname :name "tk-package" :type "lsp" :directory gtk)) (load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew)) (load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew)) (load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp)) (gbc t)) (setf (symbol-function 'clear-compiler-properties) (symbol-function 'compiler::compiler-clear-compiler-properties)) (terpri) (setq *inhibit-macro-special* t) (gbc t) (reset-gbc-count) (defun top-level nil (gcl-top-level)) (set-up-top-level) (setq *gcl-extra-version* @LI-EXTVERS@ *gcl-minor-version* @LI-MINVERS@ *gcl-major-version* @LI-MAJVERS@ *gcl-git-tag* @LI-GITTAG@ *gcl-release-date* "@LI-RELEASE@") (defvar *system-banner* (default-system-banner)) (setq *optimize-maximum-pages* t) (fmakunbound 'init-cmp-anon) (when (fboundp 'user-init) (user-init)) (in-package :compiler) (setq *cc* @LI-CC@ *default-prof-p* (> (length @LI-DFP@) 0) *ld* @LI-LD@ *ld-libs* @LI-LD-LIBS@ *ld-libs* (concatenate 'string "-l" #+ansi-cl "ansi_" "gcl " *ld-libs*) *opt-three* @LI-OPT-THREE@ *opt-two* @LI-OPT-TWO@ *init-lsp* @LI-INIT-LSP@) (import 'si::(clines defentry defcfun object void int double quit bye gbc system commonp *break-on-warnings* make-char char-bits char-font char-bit set-char-bit string-char-p int-char char-font-limit char-bits-limit char-control-bit char-meta-bit char-super-bit char-hyper-bit compiler-let) :cltl1-compat) (deftype cltl1-compat::string-char nil 'character) (do-symbols (s :cltl1-compat) (export s :cltl1-compat)) #-ansi-cl(use-package :cltl1-compat :lisp) #-ansi-cl(do-symbols (s :cltl1-compat) (export s :lisp))) #+ansi-cl (use-package :pcl :user) (import 'si::(clines defentry defcfun object void int double quit bye gbc system *lib-directory* *system-directory* while help) :user) (let* ((i 4096)(j (si::equal-tail-recursion-check i))) (unless (<= (ash i -1) j) (warn "equal is not tail recursive ~s ~s" i j))) (format t "~s heap words available~%" (multiple-value-bind (a b c d) (si::heap-report) (/ (- d c) (/ a 8)))) gcl-2.6.14/unixport/make_kcn0000644000175000017500000000007214360276512014355 0ustar cammcammPORTDIR = ../unixport LDCC = ${CC} -include ../makedefs gcl-2.6.14/unixport/ncrt0.el0000755000175000017500000000032614360276512014237 0ustar cammcamm(setq case-replace nil) (setq case-fold-search nil) (insert-file "/lib/crt0.o") (replace-string "_moncontrol" "_Moncontrol") (goto-char (point-min)) (replace-string "mcount" "Mcount") (write-file "ncrt0.o") gcl-2.6.14/unixport/makefile0000644000175000017500000001275514360276512014375 0ustar cammcammSPECIAL_RSYM = rsym.c LIBC = -lc -include ../makedefs RSYM= HDIR = ../h ODIR = ../o MDIR = ../mod LSPDIR = ../lsp CMPDIR = ../cmpnew XDIR = ../xgcl-2 CLCSDIR = ../clcs PCLDIR = ../pcl PORTDIR = $(shell pwd) LD_FLAGS:=$(LDFLAGS) ifneq ($(FIRST_FILE),) LD_FLAGS:=$(LD_FLAGS) $(ODIR)/$(FIRST_FILE) endif LD_LIBS_PRE:=$(addprefix -u ,$(PATCHED_SYMBOLS)) LD_LIBS_POST:=$(LIBS) $(LIBC) -lgclp ifneq ($(LAST_FILE),) LD_LIBS_POST:=$(LD_LIBS_POST) $(ODIR)/$(LAST_FILE) endif ifeq ($(ARRS),) ARRS:=ar rs endif libgclp.a: $(ODIR)/gcllib.a cp $< $@ ranlib $@ gmpfiles: $(shell [ -z "$(GMPDIR)" ] || find ../$(GMPDIR) -name "*.o" |grep -v '\.lib') rm -rf gmp mkdir gmp a="$^" ; \ for i in $$a ; do \ cp $$i gmp/$$(echo $$i | sed -e 's,\.\./,,1' -e 's,/,_,g') ; \ done touch $@ bfdfiles: $(shell ! [ -d ../binutils ] || find ../binutils -name "*.o") rm -rf bfd mkdir bfd a="$^" ; \ for i in $$a ; do \ cp $$i bfd/$$(echo $$i | sed -e 's,\.\./,,1' -e 's,/,_,g') ; \ done touch $@ OOBJS:=$(shell j=$$(ar t $(ODIR)/gcllib.a) ; for i in $$(find $(ODIR) -name "*.o") ; do if ! echo $$j |grep $$(basename $$i) >/dev/null 2>&1 ; then echo $$i ; fi ; done) OOBJS:=$(filter-out $(ODIR)/$(FIRST_FILE),$(OOBJS)) OOBJS:=$(filter-out $(ODIR)/$(LAST_FILE),$(OOBJS)) OOBJS:=$(filter-out $(ODIR)/plttest.o,$(OOBJS)) OBJS:=$(OOBJS) $(shell find $(LSPDIR) -name "*.o") OBJS:=$(OBJS) $(shell find $(XDIR) -name "*.o") OBJS:=$(OBJS) $(shell find $(CMPDIR) -name "*.o" | grep -v collectfn.o) #MODOBJS:=$(shell find $(MDIR) -name "*.o") PCLOBJS:=$(shell find $(PCLDIR) -name "*.o") ANSIOBJS:=$(PCLOBJS) $(shell find $(CLCSDIR) -name "*.o") $(LSPDIR)/auto_new.lsp: $(LSPDIR)/auto.lsp cp $< $@ [ "$(RL_OBJS)" = "" ] || \ echo "(AUTOLOAD 'init-readline '|readline|)" >>$@ sys_init.lsp: sys_init.lsp.in cat $< | sed \ -e "s#@LI-VERS@#(`cat ../majvers`.`cat ../minvers`) `cat ../release`#1" \ -e "s#@LI-EXTVERS@#`cat ../minvers | cut -f2 -d.`#1" \ -e "s#@LI-MINVERS@#`cat ../minvers | cut -f1 -d.`#1" \ -e "s#@LI-MAJVERS@#`cat ../majvers`#1" \ -e "s#@LI-GITTAG@#`cat ../git.tag`#1" \ -e "s#@LI-RELEASE@#`cat ../release`#1" \ -e "s#@LI-CC@#\"$(GCL_CC) -c $(filter-out -pg,$(FINAL_CFLAGS))\"#1" \ -e "s#@LI-DFP@#\"$(filter -pg,$(FINAL_CFLAGS))\"#1" \ -e "s#@LI-LD@#\"$(GCL_CC) $(LD_FLAGS) -o \"#1" \ -e "s#@LI-LD-LIBS@#\" $(LD_LIBS_POST)\"#1" \ -e "s#@LI-OPT-THREE@#\"$(O3FLAGS)\"#1" \ -e "s#@LI-OPT-TWO@#\"$(O2FLAGS)\"#1" \ -e "s#@LI-INIT-LSP@#\"$@\"#1" >$@ saved_%:raw_% $(RSYM) sys_init.lsp raw_%_map msys \ $(CMPDIR)/gcl_cmpmain.lsp \ $(CMPDIR)/gcl_lfun_list.lsp \ $(CMPDIR)/gcl_cmpopt.lsp $(HDIR)/cmpinclude.h \ $(LSPDIR)/gcl_auto_new.lsp cp sys_init.lsp foo # [ "$(@F)" != "$(FLISP)" ] || echo "#+large-memory-model (setq compiler::*default-large-memory-model-p* t)" >>foo echo "(unless si::*quit-tags* (in-package \"USER\")(system:save-system \"$@\"))" >>foo j=$$(ar t lib$*.a |grep ^gcl_);[ "$$j" = "" ] || ar x lib$*.a $$j #accelerator $(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/ -libdir $(GCLDIR)/ < foo # check that saved image can be prelinked [ "$(PRELINK_CHECK)" = "" ] || \ ! [ -x /usr/bin/objdump ] || \ ! /usr/bin/objdump -f $@ | grep "file format" | grep "elf" || \ ! /usr/bin/objdump -R $@ |grep R_.*_COPY || \ ! echo "$@ cannot be prelinked" $(RSYM): $(SPECIAL_RSYM) $(HDIR)/mdefs.h $(CC) $(LD_FLAGS) $(CFLAGS) -I$(HDIR) -I$(ODIR) -o $(RSYM) $(SPECIAL_RSYM) msys: msys.c PATH=/usr/bin:$$PATH gcc $< -o $@ # Unix binary if running wine $(HDIR)/mdefs.h: $(HDIR)/include.h cat $(HDIR)/include.h | sed -e "/include/d" > $(HDIR)/mdefs.h libgcl.a: $(OBJS) sys_gcl.o gmpfiles bfdfiles # plt_gcl.o rm -rf $@ $(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o") libpre_gcl.a: $(OOBJS) sys_pre_gcl.o gmpfiles bfdfiles # plt_pre_gcl.o rm -rf $@ $(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o") #libmod_gcl.a: $(OBJS) $(MODOBJS) sys_mod_gcl.o gmpfiles bfdfiles # plt_mod_gcl.o # rm -rf $@ # $(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o") libxgcl.a: libgcl.a ln -snf $< $@ libansi_gcl.a: $(OBJS) $(ANSIOBJS) sys_ansi_gcl.o gmpfiles bfdfiles # plt_ansi_gcl.o rm -rf $@ $(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o") libpcl_gcl.a: $(OBJS) $(PCLOBJS) sys_pcl_gcl.o gmpfiles bfdfiles # plt_pcl_gcl.o rm -rf $@ $(ARRS) $@ $(filter %.o,$^) $(shell find gmp bfd -name "*.o") raw_%_map raw_%: lib%.a libgclp.a $(SYSTEM_OBJS) #$(EXTRAS) touch raw_$*_map ifeq ($(GNU_LD),1) $(CC) $(LD_FLAGS) -o raw_$*$(EXE) $(filter %.o,$^) -L. $(EXTRA_LD_LIBS) -Wl,-Map raw_$*_map $(LD_LIBS_PRE) -l$* $(LD_LIBS_POST) else $(CC) $(LD_FLAGS) -o raw_$*$(EXE) $(filter %.o,$^) -L. $(EXTRA_LD_LIBS) $(LD_LIBS_PRE) -l$* $(LD_LIBS_POST) endif # diff map_$* map_$*.old >/dev/null || (cp map_$* map_$*.old && rm -f $@ && $(MAKE) $@) # cp map_$*.old map_$* map_%: touch $@ #plt_%.h: map_% # cat $< | awk '/^ .plt/ {if (NF==4) i=1;next;} \ # {if (!NF) i=0; if (!i) next; } \ # {b=$$2; sub("@.*$$","",b);print "{\"" b "\"," $$1 "}"}' | \ # sort | awk '{A[++k]=$$0} END {for (i=1;i<=k;i++) \ printf("%s%s\n",A[i],i==k ? "" : ",")}' >$@ #plt_%.o: plt_%.h plt.c # ln -snf $< plt.h # $(CC) $(LD_FLAGS) -c -o $@ plt.c $(CFLAGS) -I$(HDIR) -I$(ODIR) clean: rm -rf saved_*$(EXE) raw_*$(EXE) *.o core a.out $(RSYM) sys_init.lsp \ $(LSPDIR)/auto_new.lsp foo *maxima* init_*.lsp lib*.a gmp* bfd* *.lsp.tmp \ gazonk*.lsp plt*h *_map saved_* lib* raw_* msys out* log* tmp* gcl.script .INTERMEDIATE: init_ansi_gcl.lsp.tmp init_gcl.lsp.tmp raw_gcl raw_ansi_gcl .PRECIOUS: init_pre_gcl.lsp init_gcl.lsp init_ansi_gcl.lsp gcl-2.6.14/unixport/boots0000755000175000017500000000324714360276512013745 0ustar cammcamm# edit lspboots or cmpboots s:setf.o:setf.lsp:g s:init_or_load(init_setf,:load(:g s:defstruct.o:defstruct.lsp:g s:init_or_load(init_defstruct,:load(:g s:predlib.o:predlib.lsp:g s:init_or_load(init_predlib,:load(:g s:packlib.o:packlib.lsp:g s:init_or_load(init_packlib,:load(:g s:arraylib.o:arraylib.lsp:g s:init_or_load(init_arraylib,:load(:g s:sloop.o:sloop.lsp:g s:init_or_load(init_sloop,:load(:g s:debug.o:debug.lsp:g s:init_or_load(init_debug,:load(:g s:cmpvar.o:cmpvar.lsp:g s:init_or_load(init_cmpvar,:load(:g s:cmpwt.o:cmpwt.lsp:g s:init_or_load(init_cmpwt,:load(:g s:cmputil.o:cmputil.lsp:g s:init_or_load(init_cmputil,:load(:g s:cmplam.o:cmplam.lsp:g s:init_or_load(init_cmplam,:load(:g s:cmplabel.o:cmplabel.lsp:g s:init_or_load(init_cmplabel,:load(:g s:cmpeval.o:cmpeval.lsp:g s:init_or_load(init_cmpeval,:load(:g s:cmptag.o:cmptag.lsp:g s:init_or_load(init_cmptag,:load(:g s:cmptop.o:cmptop.lsp:g s:init_or_load(init_cmptop,:load(:g s:cmpcall.o:cmpcall.lsp:g s:init_or_load(init_cmpcall,:load(:g s:cmpinline.o:cmpinline.lsp:g s:init_or_load(init_cmpinline,:load(:g s:cmptag.o:cmptag.lsp:g s:init_or_load(init_cmptag,:load(:g s:cmptype.o:cmptype.lsp:g s:init_or_load(init_cmptype,:load(:g s:cmpblock.o:cmpblock.lsp:g s:init_or_load(init_cmpblock,:load(:g s:cmpflet.o:cmpflet.lsp:g s:init_or_load(init_cmpflet,:load(:g s:cmploc.o:cmploc.lsp:g s:init_or_load(init_cmploc,:load(:g s:cmpvs.o:cmpvs.lsp:g s:init_or_load(init_cmpvs,:load(:g s:cmpenv.o:cmpenv.lsp:g s:init_or_load(init_cmpenv,:load(:g s:cmpflet.o:cmpflet.lsp:g s:init_or_load(init_cmpflet,:load(:g s:cmpspecial.o:cmpspecial.lsp:g s:init_or_load(init_cmpspecial,:load(:g s:cmpfun.o:cmpfun.lsp:g s:init_or_load(init_cmpfun,:load(:g gcl-2.6.14/unixport/rsym_elf.c0000755000175000017500000001533714360276512014663 0ustar cammcamm/* Copyright William Schelter. All rights reserved. Use this to build an executable rsym, which will grab only the external symbols from an object file, and put them in a simple format: (cf ext_sym.h) This information will be used for relocation. to compile use cc rsym.c -o rsym -I../h */ #include #include #ifdef __linux__ /* Needed these to get it working with Linux. Bill Metzenthen 23 May 95 */ #define IN_RSYM 1 #include #define SYMNMLEN 0 #ifndef NUM_AUX #define NUM_AUX(p) 0 #endif #endif #include "ext_sym.h" #if defined(HAVE_ELF_H) #include #elif defined(HAVE_ELF_ABI_H) #include #else #error Neither elf.h nor elf_abi.h found #endif /* For OpenBSD */ #ifndef ElfW /* ElfW(type) becomes Elf32_type or Elf64_type, respectively. * Defined in link.h on Linux. OpenBSD does this in another way: * by defining Elf_Ehdr etc to the correct type in exec_elf.h. */ #ifdef Elf_Ehdr #define ElfW(type) Elf_##type #else #error Neither ElfW nor Elf_Ehdr defined #endif #endif ElfW(Phdr) pheader; ElfW(Ehdr) eheader; ElfW(Sym) *symbol_table; int text_index,data_index,bss_index,sbss_index; #undef SYM_NAME #undef EXT_and_TEXT_BSS_DAT /* #define mjoin(a,b) a ## b */ /* #define Mjoin(a,b) mjoin(a,b) */ #if defined(__ELF_NATIVE_CLASS) #define ELFW(a) Mjoin(ELF,Mjoin(__ELF_NATIVE_CLASS,Mjoin(_,a))) #elif defined(ELFSIZE) #define ELFW(a) Mjoin(ELF,Mjoin(ELFSIZE,Mjoin(_,a))) #else #error Neither __ELF_NATIVE_CLASS nor ELFSIZE defined #endif int nsyms; char *my_string_table; char *start_address; int symbol_index; static void get_myself(char *); #ifdef RSYM_AUX #include RSYM_AUX #endif /* our defs */ #define TABLE_SIZE 3 #ifdef DEBUG int debug =1; #undef dprintf #define dprintf(s,ar) if(debug) { printf(" ( s )",ar) ; fflush(stdout);} #else int debug =0; #define dprintf(s,ar) #endif /* this program will get the external symbols from a file writing them out to a file together with their addresses */ static char *outfile; int output_externals(char *); int main(argc,argv,envp) int argc ; char *argv[],*envp[]; { if (argc!=3) {perror("bad arg count"); fflush(stdout); exit(1);} #ifdef SET_BINARY_MODE SET_BINARY_MODE #endif get_myself(argv[1]); output_externals(outfile=argv[2]); return 0; } #define SECTION_H(k) section_headers[k] char *section_names; ElfW(Shdr) *section_headers; int get_section_number(name) char *name; {int k ; for (k = 1; k < eheader.e_shnum; k++) { if (!strcmp (section_names + SECTION_H(k).sh_name, name)) return k; } if (strcmp(".sbss",name)) fprintf(stderr,"could not find section %s\n", name); return -1; } char * get_section(fp,name) FILE *fp; char *name; { int shndx; char *ans; if (strcmp(name,".shstrtab") == 0) shndx = eheader.e_shstrndx; else shndx = get_section_number(name); { fseek(fp,SECTION_H(shndx).sh_offset,SEEK_SET); ans = malloc(SECTION_H(shndx).sh_size); fread(ans,SECTION_H(shndx).sh_size,1,fp); return ans; } } static void get_myself(filename) char *filename; { unsigned int i; FILE *fp; int symsize; fp = fopen(filename, RDONLY); if (fp == NULL) { fprintf(stderr, "Can't open %s\n", filename); exit(1); } fread(&eheader,sizeof(eheader),1,fp); fseek(fp,eheader.e_ehsize,SEEK_SET); fread(&pheader,sizeof(pheader),1,fp); if(ELFMAG0 != eheader.e_ident[0]){ fprintf(stderr,"Bad magic %s",filename); exit(1);}; section_headers = (void *)malloc(sizeof(ElfW(Shdr))* (1+ eheader.e_shnum)); fseek(fp,eheader.e_shoff,0); for (i=0 ; i< eheader.e_shnum ; i++) fread(§ion_headers[i],eheader.e_shentsize,1,fp); section_names = get_section(fp,".shstrtab"); symbol_index = get_section_number(".symtab"); symsize = SECTION_H(symbol_index).sh_entsize; nsyms= SECTION_H(symbol_index).sh_size/symsize; symbol_table = (void *) malloc(sizeof(ElfW(Sym)) * nsyms); /* sizeof(struct syment) and SYMESZ are not always the same. */ if(fseek(fp,(int)SECTION_H(symbol_index).sh_offset,0)) {fprintf(stderr,"seek error"); exit(1);} for (i = 0; i < nsyms; i++) fread((char *)&symbol_table[i], symsize, 1, fp); my_string_table = get_section(fp,".strtab"); text_index = get_section_number(".text"); bss_index = get_section_number(".bss"); sbss_index = get_section_number(".sbss"); data_index = get_section_number(".data"); fclose(fp); } struct lsymbol_table tab; #define EXT_and_TEXT_BSS_DAT(p) (((ELFW(ST_BIND)(p->st_info) == STB_GLOBAL) \ || (ELFW(ST_BIND)(p->st_info) == STB_WEAK) \ ) \ && \ (p->st_shndx == text_index \ || p->st_shndx == data_index\ || p->st_shndx == bss_index \ || p->st_shndx == sbss_index \ || p->st_shndx == SHN_UNDEF \ )) #define SYM_NAME(p) my_string_table+(p->st_name) #define STRUCT_SYMENT ElfW(Sym) #define n_value st_value int output_externals(out) char *out; {FILE *symout; char *name; char tem[SYMNMLEN+1]; STRUCT_SYMENT *p, *end; tem[SYMNMLEN]=0; tab.n_symbols=0; tab.tot_leng=0; symout=fopen(out,"wr"); if (!symout) {perror(out); exit(1);}; fseek(symout,sizeof(struct lsymbol_table),0); end = symbol_table + nsyms; for (p = symbol_table; p < end; p++) { /* Is the following check enough? */ if (EXT_and_TEXT_BSS_DAT(p)) { name= SYM_NAME(p); /* turn __setjmp@@GLIB* to __setjmp since GLIB2.0 likes to tack on the @@GLIB to certain symbols .. but the names in the .o files to be loaded do NOT have this tacked on. */ if (name ) { char *tmp; tmp=index(name,'@') ; if (name && tmp && tmp[1]=='@' /* also do translation for similar libc, like solaris, where symbol is */ /* e.g. setjmp@@SYSVABI_1.3 */ /* && tmp[2]=='G' */ /* && tmp[3]=='L' */ /* && tmp[4]=='I' */ ) *tmp=0; } { dprintf(tab.n_symbols %d , tab.n_symbols); tab.n_symbols++; {unsigned long i = (p->n_value); #ifdef AIX3 if (p->n_scnum == TEXT_NSCN) i = i + 0x10000e00; else i += DBEGIN; /* leave space for the toc entry. */ #endif fwrite((char *)&i,sizeof(i),1,symout);} #ifdef AIX3 {short j=0; fwrite((char *)&j,sizeof(short),1,symout);} #endif dprintf( p->n_value %d , p->n_value); dprintf( name %s , name); while(tab.tot_leng++,*name) putc(*name++,symout); putc(0,symout); /* fprintf(symout,name); fprintf(symout," %d ", p->n_value); */ }; dprintf( NUM_AUX(p) %d , NUM_AUX(p)); dprintf( index , (int) (p - symbol_table) / sizeof(STRUCT_SYMENT)); p = p + NUM_AUX(p); } } fseek(symout,0,0); fwrite(&tab,sizeof(tab),1,symout); fclose(symout); #ifdef AIX3 add_tc_offsets(outfile); #endif return 0; } gcl-2.6.14/unixport/sys-init.lsp0000755000175000017500000000024014360276512015161 0ustar cammcamm(in-package 'si) (let ((mss (si::string-concatenate *system-directory* "message"))) (if (probe-file mss) (system (format nil "cat ~a " mss)))) gcl-2.6.14/unixport/so_locations0000755000175000017500000000017614360276512015311 0ustar cammcammufas0xaapfla \ :st = .text 0x000003ffbfff0000, 0x0000000000010000:\ :st = .data 0x000003ffffff0000, 0x0000000000010000:\ gcl-2.6.14/unixport/sys_kcn.c0000755000175000017500000000077214360276512014511 0ustar cammcamm#include "../h/include.h" extern void user_init(); void init_or_load1 (); #define init_or_load(fn,file) do {extern int fn(); init_or_load1(fn,file);} \ while(0) init_init() { load("../lsp/export.lsp"); init_or_load(init_defmacro,"../lsp/defmacro.o"); init_or_load(init_evalmacros,"../lsp/evalmacros.o"); init_or_load(init_top,"../lsp/top.o"); init_or_load(init_module,"../lsp/module.o"); load("../lsp/autoload.lsp"); load("../lsp/auto.lsp"); } init_system() { user_init(); } gcl-2.6.14/unixport/msys.c0000644000175000017500000000247214360276512014027 0ustar cammcamm#include #include #include #define massert(a_) if (!(a_)) msys_err(l,#a_,__LINE__,__FILE__,__FUNCTION__) static int msys_err(FILE *l,const char *a,unsigned n,const char *f,const char *fn) { if (l) { fprintf(l,"The assertion %s on line %d of %s in function %s failed", a,n,f,fn); fflush(l); fclose(l); } exit(-1); } int main(int argc,char * argv[]) { #ifdef _WIN32 return 0; #else char b[4096]; FILE *f,*l=NULL; char *n=argv[2],*t=argv[3],*ln=argc>4 ? argv[4] : NULL,c,c1; int r=0; if (fork()) return 0; if (chdir(argv[1])) exit(-1); if (ln) l=fopen(ln,"w"); massert(f=fopen(n,"w")); massert(fprintf(f,"%c\n",c=c1='0')==2); massert(!fclose(f)); for (;;usleep(10000)) { massert(f=fopen(n,"r")); c=fgetc(f); massert(!fclose(f)); if (c==EOF) { if (l) fclose(l); exit(0); } if (c==c1) continue; massert(f=fopen(n,"r")); massert(fgets(b,sizeof(b),f)==b); massert(!fclose(f)); r=system(b); if (l) { fprintf(l,"%d %s\n",r,b); fflush(l); } massert(f=fopen(t,"w")); massert(fprintf(f,"%d\n",r)>0); massert(!fclose(f)); massert(f=fopen(t,"r")); c1=fgetc(f); massert(!fclose(f)); massert(!rename(t,n)); } return 0; #endif } gcl-2.6.14/unixport/sys_boot.c0000755000175000017500000000373414360276512014702 0ustar cammcamm#include "../h/include.h" void init_or_load1 (); #define init_or_load(fn,file) do {extern int fn(); init_or_load1(fn,file);} \ while(0) void init_init() { load("../lsp/export.lsp"); init_or_load(init_defmacro,"../lsp/defmacro.o"); init_or_load(init_evalmacros,"../lsp/evalmacros.o"); init_or_load(init_top,"../lsp/top.o"); init_or_load(init_module,"../lsp/module.o"); load("../lsp/autoload.lsp"); } void init_system() { load("../lsp/predlib.lsp"); load("../lsp/setf.lsp"); load("../lsp/arraylib.lsp"); init_or_load(init_assert,"../lsp/assert.o"); load("../lsp/defstruct.lsp"); init_or_load(init_describe,"../lsp/describe.o"); init_or_load(init_iolib,"../lsp/iolib.o"); init_or_load(init_listlib,"../lsp/listlib.o"); init_or_load(init_mislib,"../lsp/mislib.o"); init_or_load(init_numlib,"../lsp/numlib.o"); load("../lsp/packlib.lsp"); init_or_load(init_seq,"../lsp/seq.o"); init_or_load(init_seqlib,"../lsp/seqlib.o"); init_or_load(init_trace,"../lsp/trace.o"); load("../lsp/sloop.lsp"); load("../cmpnew/cmpinline.lsp"); load("../cmpnew/cmputil.lsp"); load("../lsp/debug.lsp"); load("../cmpnew/cmptype.lsp"); init_or_load(init_cmpbind,"../cmpnew/cmpbind.o"); load("../cmpnew/cmpblock.lsp"); load("../cmpnew/cmpcall.lsp"); init_or_load(init_cmpcatch,"../cmpnew/cmpcatch.o"); load("../cmpnew/cmpenv.lsp"); load("../cmpnew/cmpeval.lsp"); load("../cmpnew/cmpflet.lsp"); load("../cmpnew/cmpfun.lsp"); init_or_load(init_cmpif,"../cmpnew/cmpif.o"); load("../cmpnew/cmplabel.lsp"); load("../cmpnew/cmplam.lsp"); init_or_load(init_cmplet,"../cmpnew/cmplet.o"); load("../cmpnew/cmploc.lsp"); init_or_load(init_cmpmap,"../cmpnew/cmpmap.o"); init_or_load(init_cmpmulti,"../cmpnew/cmpmulti.o"); load("../cmpnew/cmpspecial.lsp"); load("../cmpnew/cmptag.lsp"); load("../cmpnew/cmptop.lsp"); load("../cmpnew/cmpvar.lsp"); load("../cmpnew/cmpvs.lsp"); load("../cmpnew/cmpwt.lsp"); Vpackage->s.s_dbind = user_package; } gcl-2.6.14/unixport/rsym_nt.c0000755000175000017500000000323614360276512014531 0ustar cammcamm/* defining IN_SFASL gets us fopen_binary */ #define IN_RSYM #include "config.h" #include #include "ext_sym.h" struct lsymbol_table tab; int main(int argc,char *argv[]) { char buf[1000]; char *in = argv[1]; char *out = argv[2]; if ( argc != 3 ) { perror("bad arg count"); fflush(stdout); exit(1); } fprintf ( stderr, "rsym_nt: %s %s\n", in, out ); sprintf ( buf, "nm -g %s > _rsym1", argv[1] ); if ( system ( buf ) ) { printf("failed: %s", buf); exit(1); } { FILE *fp = fopen("_rsym1","rb"); FILE *symout; char buf1[1000]; symout = fopen ( out, "wb" ); if ( !symout ) { perror ( out ); exit ( 1 ); }; tab.n_symbols=0; tab.tot_leng=0; fseek( symout, sizeof ( struct lsymbol_table ), 0 ); { int addr; char ch; char *name; char name1[1000]; while (1) { name = name1; fgets(buf1,sizeof(buf1),fp); if ( 3 == sscanf ( buf1, "%x %c %s", &addr, &ch, name ) && ch != '?' ) { tab.n_symbols++; fwrite ( (char *)&addr, sizeof ( int ), 1, symout ); while ( tab.tot_leng++, *name ) putc ( *name++, symout ); putc ( 0, symout ); } if ( feof ( fp ) ) break; } fseek ( symout, 0, 0 ); fwrite ( &tab, sizeof ( tab ), 1, symout ); fclose ( symout ); } } exit ( 0 ); } gcl-2.6.14/unixport/gcldos.lsp0000755000175000017500000000671414360276512014671 0ustar cammcamm(in-package "COMPILER") (in-package "SYSTEM") (in-package "USER") (in-package "LISP") (lisp::in-package "SLOOP") ;;Appropriate for Austin (setq SYSTEM:*DEFAULT-TIME-ZONE* 6) (in-package "USER") (progn (allocate 'cons 100) (allocate 'string 40) (system:init-system) (gbc t) (si::multiply-bignum-stack 25) (or lisp::*link-array* (setq lisp::*link-array* (make-array 500 :element-type 'fixnum :fill-pointer 0))) (use-fast-links t)(setq compiler::*cc* "gcc -DVOL=volatile")(si::build-symbol-table) (setq compiler::*cmpinclude* "") (load #"../cmpnew/cmpmain.lsp") (gbc t) (load #"../cmpnew/lfun_list.lsp") (gbc t) (load #"../cmpnew/cmpopt.lsp") (gbc t) (load #"../lsp/auto.lsp") (gbc t) (defun si::src-path (x) (si::string-concatenate "/gcl/" x)) (when compiler::*cmpinclude-string* (with-open-file (st "../h/cmpinclude.h") (let ((tem (make-array (file-length st) :element-type 'standard-char :static t))) (if (si::fread tem 0 (length tem) st) (setq compiler::*cmpinclude-string* tem))))) ;;compile-file is in cmpmain.lsp (setf (symbol-function 'si:clear-compiler-properties) (symbol-function 'compiler::compiler-clear-compiler-properties)) ; (load "../lsp/setdoc.lsp") (setq system::*old-top-level* (symbol-function 'system:top-level)) (defun system::gcl-top-level nil (when (> (system:argc) 1) (setq system:*system-directory* (system:argv 1))) (when (>= (system:argc) 5) (let ((system::*quit-tag* (cons nil nil)) (system::*quit-tags* nil) (system::*break-level* '()) (system::*break-env* nil) (system::*ihs-base* 1) (system::*ihs-top* 1) (system::*current-ihs* 1) (*break-enable* nil)) (system:error-set '(let ((system::flags (system:argv 4))) (setq system:*system-directory* (pathname (system:argv 1))) (compile-file (system:argv 2) :output-file (system:argv 3) :o-file (case (schar system::flags 1) (#\0 nil) (#\1 t) (t (system:argv 5))) :c-file (case (schar system::flags 2) (#\0 nil) (#\1 t) (t (system:argv 6))) :h-file (case (schar system::flags 3) (#\0 nil) (#\1 t) (t (system:argv 7))) :data-file (case (schar system::flags 4) (#\0 nil) (#\1 t) (t (system:argv 8))) :system-p (if (char-equal (schar system::flags 0) #\S) t nil)))) (bye (if compiler::*error-p* 1 0)))) (format t "GCL (GNU Common Lisp) ~A~%~a~%" "Version(1.617) Tue Nov 24 11:34:34 CST 1992" "Contains Enhancements by W. Schelter") (setq si::*ihs-top* 1) (in-package 'system::user) (incf system::*ihs-top* 2) (funcall system::*old-top-level*)) (setq si::*gcl-version* 600) (setq si::*gcl-version* '617)(defun lisp-imp'lementation-version nil (format nil "1-~a" si::*gcl-version*)) (setq si:*inhibit-macro-special* t) ;(setq *modules* nil) (gbc t) (system:reset-gbc-count) (allocate 'cons 200) (defun system:top-level nil (system::gcl-top-level)) (unintern 'system) (unintern 'lisp) (unintern 'compiler) (unintern 'user) (system:save-system "saved_gcl") (bye) (defun system:top-level nil (system::gcl-top-level)) (save "saved_gcl") (bye)) gcl-2.6.14/unixport/sys_pre_gcl.c0000755000175000017500000000630314360276512015345 0ustar cammcamm#include "sys.c" void gcl_init_init() { object features; features=find_symbol(make_simple_string("*FEATURES*"),system_package); features->s.s_dbind=make_cons(make_keyword("PRE-GCL"),features->s.s_dbind); build_symbol_table(); lsp_init("../lsp/gcl_export.lsp"); lsp_init("../lsp/gcl_defmacro.lsp"); lsp_init("../lsp/gcl_evalmacros.lsp"); lsp_init("../lsp/gcl_top.lsp"); lsp_init("../lsp/gcl_module.lsp"); lsp_init("../lsp/gcl_autoload.lsp"); } void gcl_init_system(object no_init) { if (type_of(no_init)!=t_symbol) error("Supplied no_init is not of type symbol\n"); lsp_init("../lsp/gcl_listlib.lsp"); lsp_init("../lsp/gcl_predlib.lsp"); lsp_init("../lsp/gcl_setf.lsp"); lsp_init("../lsp/gcl_arraylib.lsp"); lsp_init("../lsp/gcl_assert.lsp"); lsp_init("../lsp/gcl_defstruct.lsp"); lsp_init("../lsp/gcl_restart.lsp"); lsp_init("../lsp/gcl_describe.lsp"); #ifdef HAVE_JAPI_H lsp_init("../lsp/gcl_japi.lsp"); #endif /* lsp_init("../lsp/gcl_listlib.lsp"); */ lsp_init("../lsp/gcl_mislib.lsp"); lsp_init("../lsp/gcl_numlib.lsp"); lsp_init("../lsp/gcl_packlib.lsp"); lsp_init("../lsp/gcl_seq.lsp"); lsp_init("../lsp/gcl_seqlib.lsp"); lsp_init("../lsp/gcl_trace.lsp"); lsp_init("../lsp/gcl_sloop.lsp"); lsp_init("../lsp/gcl_serror.lsp"); lsp_init("../lsp/gcl_destructuring_bind.lsp"); lsp_init("../lsp/gcl_loop.lsp"); lsp_init("../lsp/gcl_defpackage.lsp"); lsp_init("../lsp/gcl_make_defpackage.lsp"); lsp_init("../lsp/gcl_sharp.lsp"); lsp_init("../lsp/gcl_sharp_uv.lsp"); lsp_init("../lsp/gcl_logical_pathname_translations.lsp"); lsp_init("../lsp/gcl_make_pathname.lsp"); lsp_init("../lsp/gcl_parse_namestring.lsp"); lsp_init("../lsp/gcl_namestring.lsp"); lsp_init("../lsp/gcl_translate_pathname.lsp"); lsp_init("../lsp/gcl_directory.lsp"); lsp_init("../lsp/gcl_merge_pathnames.lsp"); lsp_init("../lsp/gcl_truename.lsp"); lsp_init("../lsp/gcl_rename_file.lsp"); lsp_init("../lsp/gcl_wild_pathname_p.lsp"); lsp_init("../lsp/gcl_pathname_match_p.lsp"); lsp_init("../lsp/gcl_iolib.lsp"); lsp_init("../lsp/gcl_fpe.lsp"); lsp_init("../cmpnew/gcl_cmpinline.lsp"); lsp_init("../cmpnew/gcl_cmputil.lsp"); lsp_init("../lsp/gcl_debug.lsp"); lsp_init("../lsp/gcl_info.lsp"); lsp_init("../cmpnew/gcl_cmptype.lsp"); lsp_init("../cmpnew/gcl_cmpbind.lsp"); lsp_init("../cmpnew/gcl_cmpblock.lsp"); lsp_init("../cmpnew/gcl_cmpcall.lsp"); lsp_init("../cmpnew/gcl_cmpcatch.lsp"); lsp_init("../cmpnew/gcl_cmpenv.lsp"); lsp_init("../cmpnew/gcl_cmpeval.lsp"); lsp_init("../cmpnew/gcl_cmpflet.lsp"); lsp_init("../cmpnew/gcl_cmpfun.lsp"); lsp_init("../cmpnew/gcl_cmpif.lsp"); lsp_init("../cmpnew/gcl_cmplabel.lsp"); lsp_init("../cmpnew/gcl_cmplam.lsp"); lsp_init("../cmpnew/gcl_cmplet.lsp"); lsp_init("../cmpnew/gcl_cmploc.lsp"); lsp_init("../cmpnew/gcl_cmpmap.lsp"); lsp_init("../cmpnew/gcl_cmpmulti.lsp"); lsp_init("../cmpnew/gcl_cmpspecial.lsp"); lsp_init("../cmpnew/gcl_cmptag.lsp"); lsp_init("../cmpnew/gcl_cmptop.lsp"); lsp_init("../cmpnew/gcl_cmpvar.lsp"); lsp_init("../cmpnew/gcl_cmpvs.lsp"); lsp_init("../cmpnew/gcl_cmpwt.lsp"); lsp_init("../cmpnew/gcl_cmpmain.lsp"); } int gcl_init_cmp_anon(void) { return 1; } gcl-2.6.14/unixport/ansi_cl.lisp0000644000175000017500000001147114360276512015170 0ustar cammcamm(setq clcs_shadow '(CONDITIONS::BREAK CONDITIONS::ERROR CONDITIONS::CERROR CONDITIONS::WARN CONDITIONS::CHECK-TYPE CONDITIONS::ASSERT CONDITIONS::ETYPECASE CONDITIONS::CTYPECASE CONDITIONS::ECASE CONDITIONS::CCASE )) (setq lisp_unexport '(LISP::LAMBDA-BLOCK-CLOSURE LISP::BYE LISP::QUIT LISP::EXIT LISP::IEEE-FLOATING-POINT LISP::DEFENTRY LISP::VOID LISP::ALLOCATE-CONTIGUOUS-PAGES LISP::UNSIGNED-SHORT LISP::DOUBLE LISP::BY LISP::GBC LISP::DEFCFUN LISP::SAVE LISP::MAXIMUM-CONTIGUOUS-PAGES LISP::SPICE LISP::DEFLA LISP::ALLOCATED-PAGES LISP::SUN LISP::INT LISP::USE-FAST-LINKS LISP::CFUN LISP::UNSIGNED-CHAR LISP::HELP LISP::HELP* LISP::MACRO LISP::*BREAK-ENABLE* LISP::CLINES LISP::LAMBDA-CLOSURE LISP::OBJECT LISP::FAT-STRING LISP::SIGNED-SHORT LISP::MC68020 LISP::LAMBDA-BLOCK LISP::TAG LISP::PROCLAMATION LISP::ALLOCATED-CONTIGUOUS-PAGES LISP::*EVAL-WHEN-COMPILE* LISP::SIGNED-CHAR LISP::*IGNORE-MAXIMUM-PAGES* LISP::*LINK-ARRAY* LISP::KCL LISP::BSD LISP::ALLOCATE-RELOCATABLE-PAGES LISP::ALLOCATE LISP::UNIX LISP::MAXIMUM-ALLOCATABLE-PAGES LISP::ALLOCATED-RELOCATABLE-PAGES LISP::SYSTEM LISP::KYOTO LISP::CCLOSURE)) ;(dolist (s '(*compile-file-pathname* *compile-file-truename* ;*compile-print* *compile-verbose* *load-pathname* *load-print* ;*load-truename* *print-lines* *print-miser-width* ;*print-pprint-dispatch* *print-right-margin* *read-eval*)) ; (import (list s) "COMMON-LISP")) ;anything in "SYSTEM" which should go in "COMMON-LISP" ;can be added to shadow-system (setf shadow-system '(system::copy-structure)) (do-external-symbols (s "SYSTEM") (when (member s shadow-system) (shadowing-import (list s) "COMMON-LISP") (shadowing-import (list s) "USER"))) (do-external-symbols (s "LISP") (if (not(member s lisp_unexport)) (progn (import (list s) "COMMON-LISP") (import (list s) "USER")) )) (do-external-symbols (s "PCL") (import (list s) "COMMON-LISP") (import (list s) "USER")) ;(shadowing-import (list 'pcl::classp) "SYSTEM") (setf (symbol-function 'si::classp) (symbol-function 'pcl::classp)) (setf (symbol-function 'si::class-of) (symbol-function 'pcl::class-of)) (setf (symbol-function 'si::class-precedence-list) (symbol-function 'pcl::class-precedence-list)) (setf (symbol-function 'si::find-class) (symbol-function 'pcl::find-class)) (do-external-symbols (s "CONDITIONS") (if (member s clcs_shadow) (progn (shadowing-import (list s) "COMMON-LISP") (shadowing-import (list s) "USER")) (progn (import (list s) "COMMON-LISP") (import (list s) "USER")))) (dolist (s '(*compile-file-pathname* *compile-file-truename* *compile-print* *compile-verbose* *load-pathname* *load-print* *load-truename* *print-lines* *print-miser-width* *print-pprint-dispatch* *print-right-margin* *read-eval* lisp::arithmetic-error broadcast-stream-streams cell-error cell-error-name compile compile-file compiler-macro compiler-macro-function complement concatenated-stream-streams condition control-error copy-pprint-dispatch copy-structure count debug define-compiler-macro define-setf-expander define-symbol-macro defpackage describe describe-object division-by-zero dynamic-extent echo-stream-input-stream echo-stream-output-stream ensure-directories-exist fdefinition file-string-length formatter function-lambda-expression get-setf-expansion hash-table-rehash-size hash-table-rehash-threshold ignorable interactive-stream-p load-logical-pathname-translations load-time-value logical-pathname-translations make-load-form make-load-form-saving-slots make-method open-stream-p pathname-match-p pprint-dispatch pprint-exit-if-list-exhausted pprint-fill pprint-indent pprint-linear pprint-logical-block pprint-newline pprint-pop pprint-tab pprint-tabular print-not-readable-object print-unreadable-object readtable-case row-major-aref set-pprint-dispatch simple-condition-format-control stream-external-format synonym-stream-symbol translate-logical-pathname translate-pathname two-way-stream-input-stream two-way-stream-output-stream unbound-slot-instance upgraded-complex-part-type wild-pathname-p with-compilation-unit with-condition-restarts with-package-iterator with-standard-io-syntax )) (shadowing-import (list s) "COMMON-LISP")) (use-package "ANSI-LOOP" "COMMON-LISP") (use-package "ANSI-LOOP" "USER") (do-symbols (s "COMMON-LISP") (export (list s) "COMMON-LISP")) (makunbound 'clcs_shadow) (makunbound 'lisp_unexport) (makunbound 'shadow-system) (unintern 'clcs_shadow) (unintern 'lisp_unexport) (unintern 'int) (unintern 'shadow-system) (push :common-lisp *features*) (push :ansi-cl *features*) (rename-package 'common-lisp 'common-lisp '(cl)) (rename-package 'user 'common-lisp-user '(cl-user user)) gcl-2.6.14/unixport/sys.c0000644000175000017500000000226114360276512013646 0ustar cammcamm#include #include #include #include #include "../h/include.h" #ifdef FLAVOR static void ar_init_fn(void (fn)(void),const char *s) { char b[200]; struct stat ss; object sysd=sSAsystem_directoryA->s.s_dbind; if (stat(s,&ss)) { assert(snprintf(b,sizeof(b),"ar x %-.*slib%sgcl.a %s",sysd->st.st_fillp,sysd->st.st_self,FLAVOR,s)>0); assert(!msystem(b)); } gcl_init_or_load1(fn,s); assert(!unlink(s)); } static void ar_check_init_fn(void (fn)(void),char *s,object b,char *o) { object t; for (t=b->s.s_dbind; !endp(t) && type_of(t->c.c_car)==t_string && strcmp(s,t->c.c_car->st.st_self);t=t->c.c_cdr); if (endp(t)) ar_init_fn(fn,o); } #endif #define proc(init,fn,args...) {extern void init(void);fn(init,##args);} #define ar_init(a) proc(Mjoin(init_,a),ar_init_fn,#a ".o") #define ar_check_init(a,b) proc(Mjoin(init_,a),ar_check_init_fn,#a,b,#a ".o") static void lsp_init(const char *a) { char b[200]; object sysd=sSAsystem_directoryA->s.s_dbind; assert(snprintf(b,sizeof(b),"%-.*s%s",sysd->st.st_fillp,sysd->st.st_self,a)>0) printf("loading %s\n",b); fflush(stdout); load(b); } gcl-2.6.14/unixport/aix-crt0.el0000755000175000017500000000027114360276512014637 0ustar cammcamm(setq case-replace nil) (setq case-fold-search nil) (insert-file "/lib/crt0.o") (if buffer-read-only (toggle-read-only)) (replace-string "mcount" "Mcount") (write-file "./aix_crt0.o") gcl-2.6.14/unixport/.gitignore0000644000175000017500000000007214360276512014652 0ustar cammcammbfdfiles gmpfiles init_raw.lsp *.a *.so raw_* saved_* foo gcl-2.6.14/RELEASE-2.6.2.html0000644000175000017500000016325514360276512013420 0ustar cammcamm GCL 2.6.2 tests

    GCL 2.6.2 RELEASE NOTES

    The GCL team is happy to announce the release of version 2.6.2, the latest achievement in the 'stable' series.  While strictly speaking a bug-fix only release, 2.6.2 incorporates several major improvements over the last stable release, 2.5.3.  Some highlights:

    • The development of a 'lisp compiler torture tester' by GCL developer Paul Dietz which repeatedly compiles randomly generated forms of specifiable length to test the compiler for correctness.
    • The application of several significant corrections to the GCL lisp compiler to remove every known instance of miscompilation uncovered by this tester.  To our knowledge, GCL is alone with CLISP in passing this torture test for runs of effectively indefinite length.
    • Major performance improvements were applied to the lisp compiler to enable it to complete random tests of great length in a reasonable amount of time. 
    • Corrections to the GCL core files to enable very large image sizes in 64 bits, in which more than a billion cons cells can be allocated.  Current 64bit options include amd64, ia64, and alpha running most flavors of GNU/Linux.
    • Corrections to the heap scaling behavior of the garbage collector, resulting in significant performance gains in many instances.
    • Support for the latest gcc and binutils versions on all platforms but mingw
    • The elimination of many instances of unnecessary internal garbage generation bringing the associated performance gains
    • Native support for execstack protected linux kernels, such as on Fedora core systems
    • Native support for FreeBSD, OpenBSD, and MacOSX
    • Static function pointer support to stabilize dynamic library usage on Itanium systems
    • Transparent readline initialization when compiled in
    • Support for profiling via gprof
    • Automatic disabling of SGC (stratified garbage collection) if the image is executed on a kernel not supporting fault address recovery
    • Remove a memory leak associated with heavy bignum usage via the introduction of SGC contiguous pages
    • Several significant internal bug fixes, epecially in the mingw port.
    • Alter the build process to perform a full self compile with full function proclamation at build time.
    • GCL now compiles Axiom from scratch and carries it to all supported platforms with the current exception of mingw
    • GCL's ANSI build now in use for its first end-user application -- maxima (current cvs)
    • New 64bit platform support -- amd64, with full native object relocation
    The full changelog can be found in the source tree in the file 'debian/changelog'.

     
    The GCL team has subjected this release to a wide variety of tests and benchmarks.  While all such results are necessarily incomplete, one can nevertheless usefully summarize the approximate state of affairs as follows:
    • GCL is about as portable as CLISP
    • The GCL lisp compiler is about as robust/correct as that of CLISP, at least as measured by the random tester, which at present only covers a mostly integer subset of lisp.
    • GCL is about as fast as CMUCL
    • GCL plays a major role in carrying the primary large open source lisp end user applications to a wide variety of systems
    • GCL is still the least ANSI compliant of the freely available lisp systems,  though a modest level of compliance has been achieved in this release.  Much greater compliance has been achieved in the 2.7.x (cvs unstable) series yet to be officially released.

    The specific test results are arranged in the following table.  Some terms need defining:

    BFD
    		 the method of relocating compiled lisp object modules into the running executable using the BFD library
    custreloc
    		 the method of relocating compiled lisp object modules into the running executable using the native GCL code.  This method as well as the BFD method preserve the module loading across image saving and re-execution
    dlopen
    		 the method of dynamically linking in compiled lisp object modules into the existing session only via the system dynamic linker loader, ld.so.
    SGC
    		 Stratified Garbage Collection -- an optional accelerated generational garbage collection algorithm employing read-only memory
    CLtL1
    		 Common Lisp, the Language vol I, referring to the book of the same name by Steele defining a widely used lisp language standard prior to the ANSI standardization process in 1994.
    ANSI
    		 the work in progress image build attempting to eventually extend traditional GCL into full ANSI complaince
    Ansi tests
    		 the results of the work in progress ansi compliance test suite written by GCL developer Paul Dietz presented as the number of failures divided by the total number of tests run
    Random tests
    		 the results of the random 'compiler torture tester' presented as the number of tests/the size of the random forms/the number of variables passed to the random function


    In the table below, green denotes a pass, yellow denotes an as yet unimplemented option, and red indicates failure.  Blank cells indicate tests that have not been run.

    System
    		 CPU
    		 Self Build
    		 BFD
    		 dlopen
    		 custreloc
    		 Preferred
    Linking
    		 SGC
    		 CLtL1
    		 ANSI
    		 ANSI tests
    		 Random tests
    		 Maxima 5.9.0/CLtL1
    (4)
    		 Maxima CVS/ANSI
    (4)
    		 ACL2 2.8/CLtL1
    (5)
    		 Axiom CVS/CLtL1
    (6)
    		 nqthm
    CLtL1
    		 pc-nqthm
    CLtL1
    Debian GNU/Linux (sid)
    		 i386



    		bfd
    or
    custreloc


    		303/
    10697
    		 50000/10000/8
    500000/1000/8




    		(setq si::*multiply-stacks* 16)
    Debian GNU/Linux (sid)
    		 sparc



    		bfd
    or
    custreloc


    		303/
    10697






    Debian GNU/Linux (sid)
    		 powerpc



    		bfd


    		303/
    10697






    Debian GNU/Linux (sid)
    		 amd64



    		bfd


    		303/
    10697






    Debian GNU/Linux (sid)
    		 arm



    		bfd


    		303/
    10697






    Debian GNU/Linux (sid)
    		 m68k



    		bfd


    		303/
    10697






    Debian GNU/Linux (sid)
    		 s390



    		bfd


    		303/
    10697






    Debian GNU/Linux (sid)
    		 ia64



    		dlopen


    		303/
    10697



    		(1)

    Debian GNU/Linux (sid)
    		 hppa
    		 -O0


    		dlopen


    		303/
    10697



    		(1)

    Debian GNU/Linux (sid)
    		 mips



    		dlopen


    		303/
    10697



    		(1)

    Debian GNU/Linux (sid)
    		 mipsel



    		dlopen


    		303/
    10697



    		(1)

    Debian GNU/Linux (sid)
    		 alpha



    		dlopen


    		303/
    10697



    		(1)

    Fedora FC1
    		 i386



    		bfd or
    custreloc


    		303/
    10697
    		 12000/1000/8





    Solaris
    		 sparc



    		bfd or
    custreloc


    		303/
    10697
    		 4000/1000/8
    (4)





    Windows MINGW(a)
    		 i386



    		custreloc



    		303/
    10697
    		 57000/1000/8


    		(2)

    MacOSX
    		 powerpc



    		bfd
    		 (3)

    		303/
    10697






    OpenBSD
    		 i386



    		bfd


    		303/
    10697






    FreeBSD
    		 i386



    		custreloc


    		303/
    10697

























    Notes:

    (1) dlopen builds use file descriptors for each object load.  The step in the Axiom build process which regenerates its databases consumes more than the conventional maximum of 1024 file descriptors available by default on most UNIX systems.
    (2) An AXIOMsys executable can be produced, and is basically functional, but experiences sporadic errors of a type as yet unknown.
    (3) This is known to work on at least some versions of the OS, but others report a hang (infinite loop) when enabling SGC.  It is possible that this is due to a mprotect bug in older versions of the Darwin system shared libraries.  'compatibility version of user 6.0.0' appears to work.
    (4) On this machine, the underlying gcc was old (3.0) and segfaulted outside of GCL when attempting to compile its produced C code after a few thousand        iterations.

    (a) The preferred build environment for Mingw/Windows is gcc 3.3.1, binutils 2.14.90, and the latest msys release.



    The following table presents the results of the popular gabriel benchmarks of three freely available lisp systems, GCL, CLISP and CMUCL.  Times are presented as multiples of the time GCL took in completing the tests.  Green  indicates tests on which GCL is the fastest, while red indicates tests on which GCLwas not the fastest.   The benchmark code can be found in ftp://ftp.ma.utexas.edu/gcl/gabriel.tgz.  The number of test iterations has been increased by a factor of 400 to overcome granularity issues on modern machines.  The '(print (time ...))' statements around each test iteration were removed, again due to granularity and relative i/o load.  Likewise the special init.lsp file conventionally used to preallocate GCL memory in such cases was removed as it is now mostly obsolete.  Finally the tests were modified slightly to place the optimization declamations at the top of each file being compiled as suggested by a CMUCL expert.

    As with any benchmark, results can vary somewhat with the details of the executing machine.  With lisp in particular, the ratios of the cache sizes, cpu speed, and memory bandwidths can impact such tests significantly.  We present the results for two popular configurations below.  While the precise details of the differences are as yet known, it is speculated that the first result is more dominated by in-cache cpu performance, while the latter is more dominated by memory access efficiency.

    Dual Intel Xeon 2.4Ghz, 512 Mb, Linux 2.4.20
    		 Athlon XP 3000+ (2.1Ghz), 512 Mb, Linux 2.4.26
    Benchmark
    		 GCL
    2.6.2
    		 CMUCL 18e-9
    		 CLISP
    2.33-2

    BOYER
    1.000
    2.200
    9.869

    BROWSE
    1.000
    2.240
    NA

    CTAK
    1.000
    0.230
    1.890

    DDERIV
    1.000
    2.148
    2.909

    DERIV
    1.000
    2.083
    3.640

    DESTRU-MOD
    1.000
    2.043
    9.880

    DESTRU
    1.000
    1.168
    5.743

    DIV2
    1.000
    2.222
    3.911

    FFT-MOD
    1.000
    1.585
    206.057

    FFT
    1.000
    1.544
    176.088

    FPRINT
    1.000
    2.136
    3.742

    FREAD
    1.000
    1.746
    2.111

    FRPOLY
    1.000
    1.524
    5.112

    PUZZLE-MOD
    1.000
    10.824
    41.618

    PUZZLE
    1.000
    11.324
    37.671

    STAK
    1.000
    1.536
    9.836

    TAK-MOD
    1.000
    1.465
    15.053

    TAK
    1.000
    1.486
    14.629

    TAKL
    1.000
    1.419
    14.965

    TAKR
    1.000
    1.933
    12.327

    TPRINT
    1.000
    0.937
    1.263

    TRAVERSE
    1.000
    0.875
    8.378

    TRIANG-MOD
    1.000
    7.067
    26.814

    TRIANG
    1.000
    1.281
    18.565
    GEOMETRIC
    AVERAGE
    1.00
    1.86
    10.33
    MEDIAN
    		 1.00
    		 1.67
    		 9.87
    Benchmark
    		 GCL
    2.6.2
    		 CMUCL 18e
    		 CLISP
    2.33

    BOYER
    1.000
    0.892
    6.316

    BROWSE
    1.000
    0.965
    NA

    CTAK
    1.000
    0.435
    3.489

    DDERIV
    1.000
    0.822
    1.579

    DERIV
    1.000
    0.651
    1.639

    DESTRU-MOD
    1.000
    0.812
    4.779

    DESTRU
    1.000
    0.550
    3.239

    DIV2
    1.000
    0.599
    1.525

    FFT-MOD
    1.000
    2.655
    337.207

    FFT
    1.000
    1.923
    251.026

    FPRINT
    1.000
    2.322
    3.508

    FREAD
    1.000
    1.890
    1.900

    FRPOLY
    1.000
    1.013
    3.606

    PUZZLE-MOD
    1.000
    5.976
    20.350

    PUZZLE
    1.000
    5.472
    19.387

    STAK
    1.000
    1.655
    8.064

    TAK-MOD
    1.000
    1.382
    14.775

    TAK
    1.000
    1.399
    14.514

    TAKL
    1.000
    1.281
    12.877

    TAKR
    1.000
    1.735
    15.500

    TPRINT
    1.000
    2.008
    1.674

    TRAVERSE
    1.000
    0.770
    8.013

    TRIANG-MOD
    1.000
    6.639
    25.182

    TRIANG
    1.000
    1.186
    16.948
    GEOMETRIC
    AVERAGE
    1.00
    1.40
    8.46
    MEDIAN
    		 1.00
    		 1.33
    		 8.01


    Many improvements are planned for the 2.7.x development series time permitting, the most important of which is to complete the task of building an ANSI compliant GCL image. 







    gcl-2.6.14/doc/0000755000175000017500000000000014360276512011540 5ustar cammcammgcl-2.6.14/doc/fast-link0000644000175000017500000001224614360276512013360 0ustar cammcamm Description of Fast Link option for KCL Author: Bill Schelter When we refer to times of function calls, without other qualification, we will be referring to the simplest possible function of no args returning nil: (defun foo () nil). This provides a good general indication of the timing of all functions. The original KCL function calling system, distinguishes between functions defined in the same file, proclaimed functions, as well as having different calling mechanisms for different safety levels. Some disadvantages were that calling across files always took at least 50mu, in spite of proclamations or safety. Function calls inside a file either were fast (10 mu (or 3mu for proclaimed)) at safety 0 but incapable of being traced or redefined, or else as slow as cross file compilation. We wished to have a scheme which would allow tracing and redefinition, of all calls, as well very fast calling. In order to do this we set up links in the calls, and these are modified at the first call to the function, if the function is compiled. Recompiling tracing, or redefining, undoes the link. (use-fast-links t) turns this feature on, and it is on by default. An argument of nil turns it off, so that all calls go through the function symbol. Some timings on the fast link compiling provided in this version of kcl. FILEA: (proclaim '(optimize (safety 0))) (proclaim '(function blue() t)) (proclaim '(function blue1 (t) t)) (proclaim '(function blue2 (t t) t)) (proclaim '(function blue-same-file() t)) (defun test-blue (n) (sloop for i below n do (blue))) (defun test-blue1 (n) (sloop for i below n do (blue1 nil))) (defun test-blue2 (n) (sloop for i below n do (blue2 nil nil))) (defun test-blue-same-file (n) (sloop for i below n do (blue-same-file))) FILEB: (defun blue () nil) (defun blue1 (x)x nil) (defun blue2 (x y) x y Compile and load FILEA then FILEB. Timings: We timed the invocation of blue,blue1, and blue2 by executing the loops in fileA. We subtracted the time for one empty loop iteration (2.7mu). Call New Old (blue) 3.03 60.5 (blue1 x) 4.1 62.2 (blue2 x y) 5.1 64.3 (blue-same-file) 3.03 2.73 As can be seen all calls of blue are substantially speeded up, except for the calls in the same file, which are slightly slowed down. There is however the advantage, that the calls in the same file can now be traced or redefined. Also it is conceivable that the program might want to change a definition dynamically. It is no longer necessary to recompile the whole file. They are handled in exactly the same manner as the non local calls. Since most software projects consist of more than one file, and since it is customary to move key routines to a basic files at the beginning of the system, we feel the importance of having fast calls across files is important. For example in MAXIMA, there are 380 calls to ptimes, with naturally the large majority being in files other than the basic definition. It is useful if the other calls can be made faster too. Also when debugging some chunk of MAXIMA code, it is useful to be able to trace ptimes, without having to load in new definitions and recompile. Disadvantages: The link table data takes up approximately 10 words, independent of the number of calls in a file to that function. Space: I made a file with (defun try (a b) a b (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) ) I compared the size with various settings of *fast-link-compile* and with proclaiming foos. DIFF means the size above the case with all calls to FOOS removed. text data bss dec DIFF FLC proclaimed Case SAMEFILE 1076 0 28 1104 836 nil nil I nil 1308 0 32 1340 892 nil nil Ia t 1296 4 28 1328 1060 t nil II nil 1436 4 32 1472 1056 t nil IIa t 684 4 28 716 448 t t III nil 244 0 24 268 0 t ; calls removed. IV nil 384 0 32 416 0 nil ;cals removed V t The reason II is bigger than I is that the vs_top and vs_base settings are being performed in the file, in exactly the same manner as if the definition for foos were in the file. FLC=nil with definition of foos in the same file would also be higher. Should probably have a type of proclamation which would favor the case I call in cases where speed is irrelevant. But then why not go with III.. Appendix: Notes: 1)Empty loop takes 2.70 seconds for 1,000,000 iterations. 2)blue-same-file or blue >(time (test-blue 1000000)) real time : 5.750 secs run time : 5.733 secs NIL >(trace blue) (BLUE) >(test-blue 2) 1> (BLUE) <1 (BLUE NIL) 1> (BLUE) <1 (BLUE NIL) NIL >(trace blue-same-file) (BLUE-SAME-FILE) >(test-blue-same-file 2) 1> (BLUE-SAME-FILE) <1 (BLUE-SAME-FILE NIL) 1> (BLUE-SAME-FILE) <1 (BLUE-SAME-FILE NIL) NIL gcl-2.6.14/doc/contributors0000644000175000017500000000256614360276512014231 0ustar cammcamm sgi port was done by Eric Raible raible@orville.nas.nasa.gov thanks to Blewett (blewett@cinnamon.att.com) for help in the initial stage of the sun4 port. Thanks to gabor@vuse.vanderbilt.edu for a good deal of work on the hp port. Thanks to riley@att.com for several suggestions, fixes and bug reports. Thanks to andrew@COMP.VUW.AC.NZ for several suggestions and help with hp bsd. Thanks to Doug Katzman for parts of the Iris 4D port. Thanks to pierson@encore.com for an encore port [which I unfortunately did not integrate yet]. Thanks for Mike Sundt at washington, for updates on the vax port. Thanks to Richard Harris harrisr@turing.cs.rpi.edu for many bug reports and fixes, as well as error handling code (available from him), and for work on pcl. Thanks to BABECOOL for the gpari code. gene@corwin.CCS.Northeastern.EDU (gene cooperman) several bugs and bug fixes. Thanks to luke tierney luke@umnstat.stat.umn.edu for a bug fix. tomwe@comm.mot.com (Thomas Weigert) for the mac2 port to aux. Thanks to Noritake Yonezawa for NeXT port (yone@vcdew25.lsi.tmg.nec.CO.JP) Thanks to Rami Charif rcharif@math.utexas.edu for much of the work on the dos port Thanks to Bob Boyer boyer@cs.utexas.edu for innumerable suggestions and encouragement Thanks to Matteo Frigo who did work on an early linux port. Thanks to Bill Metzenthen for linux elf work (billm@jacobi.maths.monash.edu.au) gcl-2.6.14/doc/enhancements0000644000175000017500000001434314360276512014140 0ustar cammcamm @chapter Loading Object Code We will outline some of the features of the object loader, by William Schelter. When you do @code{(load "foo.o")} the output from the C compiler, must be loaded into static space in the running KCL, and references to external symbols must be resolved. Originally KCL used the loader from the underlying lisp system, calling it in a subshell, to produce yet another file, which had the correct references to externals. This was then read into kcl. The data vector (a lisp readable vector at the end of the object file) was also read into KCL. Unfortunately some operating systems (such as System V) do not supply a loader capable of doing this relocation, and in any event it is fairly slow. Also there was no possiblity of incrementally adding new external C symbols to an already running lisp, and then having future files refer to them. For example you might have a function @code{search1} written in C, which you wished to access directly in subsequently loaded files. This was not possible since the loader only knew about the addresses of the external symbols in the original saved image. The new scheme builds a list of the external symbols into a table called @code{c_table}. This table is built by examining the current image. It will be built automatically with the first call to load. Subsequent calls just use this table. Of course there is the additional benefit, that it is easy to add additional symbols to the table. For example if you have a file @file{try.c} which looks like @code@{init_code() add_symbols(joe,&joe,pete,&pete,NULL); @} joe(x) object x @{...@} pete() @{...@} } then joe and pete will be added to the symbol table of the current kcl. You may refer to them as external variables in subsequent files, and these files will load correctly, referencing these variables. It is an error apply add_symbol twice, to the same variable. The loading of files has speeded up considerably, so that a small file with only a few small functions in it, can be loaded in less than .05 seconds. @chapter Metering and Profiling KCL utilities have been added, by W. Schelter, to allow one to determine the percentage of time spent in individual functions. Usage involves deciding which block of code one wishes to profile, that is to say what address range, and then allocating an appropriate size @code{*profile-array*}. For example in the Sun version, if you have loaded a few object files, then if you wish to meter all of kcl and the files which you loaded you could allocate a 1 megabyte array. This would give a roughly 2 to one reduction relative to the code address range. Note that the loader prints out the address at which code is loaded. There is also a function @code{si@:function-start (fun)} which returns the start address of a compiled function. In the above example after loading the file lsp/profile.o you could do @code{(si:set-up-profile 1000000)} This allocates the 1 megabyte array, and also reads in the c symbol table, if this has not already been done. It also gets the addresses of all compiled function objects currently in the image, and keeps them in a table. This table is called @code{combined_table} at the C level. The function @code{si:set-up-combined (size-of-table)} sets up a combined table for the lisp and C functions. This function is called by the previous @code{si:set-up-profile} function, with a default size-of-table of 6000. Now to turn profiling on you do @code{(si::prof 0 90)}. This will start metering all addresses in the range of 0 (the first arg) to 1,000,000 * (256/90), where 90 is the second arg. To display the data collected so far you can invoke @code{si::display-profile} with no arguments. In order to clear the profile array you run @code{(si::clear)}. A call of @(si::prof 500000 256) would profile the code in the address range of 500,000 to 1,500,000. You may switch the profiler off by specifying a 0 mapping, ie @code{si::prof 0 0)}. It can then be restarted by supplying a nonzero second argument. Of course if you start up again with a scale different from the previous one, without clearing the profile array, you will have gibberish. The argument list to the last call of @{si::prof} is stored in the variable @code{si::*current-profile*}. Unless one is using a one to one mapping of the profile array to the code, there is a possibility of quantization errors. There is also the possibility of overflowing a slot in the profile array, if the mapping is very coarse, or if the interval being measured is very long. @code{ 0.08% ( 9): _eql 15.26% ( 1822): _equal 0.01% ( 1): _Fquote 0.01% ( 1): SET 0.04% ( 5): _parse_key 0.01% ( 1): _Fcond ... 0.50% ( 60): RELIEVE-HYPS1 0.03% ( 4): REMAINDER 0.01% ( 1): REMOVE-*2*IFS 0.03% ( 3): REMOVE-TRIVIAL-EQUATIONS 4.35% ( 520): REWRITE 0.47% ( 56): REWRITE-CAR-V&C-APPLY$ ...} is a sample of the output. The first column represents percentage of total time spent with the program counter in the range starting at this function, up to the next named function. The second column is the actual number of times that a profile interrupt landed in this section of the code. Note the default display is by address, and as mentioned before, one should beware of overlaps, in a coarse mapping. Functions for which there were no ticks, are not displayed. Note we did not sort the output, since we wished to leave it in address order. It is possible (because of roundoff if the second arg to prof is small) that some calls could be credited to the adjacent function. This could be spotted more easily if the order is by address. It is trivial to sort the table by ticks in gnu emacs using the command sort-columns. Have the point set at the beginning of column, in the first line and the mark at the end of the column in the last line. Unfortunately the System V loader likes to separate the original C functions of KCL, from those incrementally loaded, by about 2 megabytes. This makes it awkward to meter both ranges simultaneously without using a very large profile array. It is probably reasonable to rewrite the basic interrupt call, to handle such an address configuration. This has not yet been done. Of course you can always make two runs, and combine the information for the two ranges. gcl-2.6.14/doc/compile-file-handling-of-top-level-forms0000644000175000017500000002363114360276512021252 0ustar cammcammForum: Compiler Issue: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS References: CLtL pages 66-70, 143 Category: CLARIFICATION Edit history: V1, 07 Oct 1987 Sandra Loosemore V2, 15 Oct 1987 Sandra Loosemore V3, 15 Jan 1988 Sandra Loosemore V4, 06 May 1988 Sandra Loosemore V5, 20 May 1988 Sandra Loosemore V6, 09 Jun 1988 Sandra Loosemore V7, 16 Dec 1988 Sandra Loosemore (Comments from Pitman, change DEFCONSTANT, etc.) V8, 31 Dec 1988 Sandra Loosemore (CLOS additions, etc.) V9, 23 Jan 1989 Sandra Loosemore (remove the CLOS additions again) Status: Proposal CLARIFY passed Jan 89 Problem Description: Standard programming practices assume that, when calls to defining macros such as DEFMACRO and DEFVAR are processed by COMPILE-FILE, certain side-effects occur that affect how subsequent forms in the file are compiled. However, these side-effects are not mentioned in CLtL, except for a passing mention that macro definitions must be ``seen'' by the compiler before it can compile calls to those macros correctly. In order to write portable programs, users must know exactly which defining macros have compile-time side-effects and what those side-effects are. Inter-file compilation dependencies are distinct from, and not addressed by, this issue. Proposal: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS:CLARIFY (1) Clarify that defining macros such as DEFMACRO or DEFVAR, appearing within a file being processed by COMPILE-FILE, normally have compile-time side effects which affect how subsequent forms in the same file are compiled. A convenient model for explaining how these side effects happen is that the defining macro expands into one or more EVAL-WHEN forms, and that the calls which cause the compile-time side effects to happen appear in the body of an (EVAL-WHEN (COMPILE) ...) form. (2) The affected defining macros and their specific side effects are as follows. In each case, it is identified what users must do to ensure that their programs are conforming, and what compilers must do in order to correctly process a conforming program. DEFTYPE: Users must ensure that the body of a DEFTYPE form is evaluable at compile time if the type is referenced in subsequent type declarations. The compiler must ensure that the DEFTYPE'd type specifier is recognized in subsequent type declarations. If the expansion of a type specifier is not defined fully at compile time (perhaps because it expands into an unknown type specifier or a SATISFIES of a named function that isn't defined in the compile-time environment), an implementation may ignore any references to this type in declarations and/or signal a warning. DEFMACRO, DEFINE-MODIFY-MACRO: The compiler must store macro definitions at compile time, so that occurrences of the macro later on in the file can be expanded correctly. Users must ensure that the body of the macro is evaluable at compile time if it is referenced within the file being compiled. DEFUN: DEFUN is not required to perform any compile-time side effects. In particular, DEFUN does not make the function definition available at compile time. An implementation may choose to store information about the function for the purposes of compile-time error-checking (such as checking the number of arguments on calls), or to enable the function to be expanded inline. DEFVAR, DEFPARAMETER: The compiler must recognize that the variables named by these forms have been proclaimed special. However, it must not evaluate the initial value form or SETQ the variable at compile time. DEFCONSTANT: The compiler must recognize that the symbol names a constant. An implementation may choose to evaluate the value-form at compile time, load time, or both. Therefore users must ensure that the value-form is evaluable at compile time (regardless of whether or not references to the constant appear in the file) and that it always evaluates to the same value. DEFSETF, DEFINE-SETF-METHOD: The compiler must make SETF methods available so that it may be used to expand calls to SETF later on in the file. Users must ensure that the body of DEFINE-SETF-METHOD and the complex form of DEFSETF are evaluable at compile time if the corresponding place is referred to in a subsequent SETF in the same file. The compiler must make these SETF methods available to compile-time calls to GET-SETF-METHOD when its environment argument is a value received as the &ENVIRONMENT parameter of a macro. DEFSTRUCT: The compiler must make the structure type name recognized as a valid type name in subsequent declarations (as for DEFTYPE) and make the structure slot accessors known to SETF. In addition, the compiler must save enough information about the structure type so that further DEFSTRUCT definitions can :INCLUDE a structure type defined earlier in the file being compiled. The functions which DEFSTRUCT generates are not defined in the compile time environment, although the compiler may save enough information about the functions to code subsequent calls inline. The #S reader syntax may or may not be available at compile time. DEFINE-CONDITION: The rules are essentially the same as those for DEFSTRUCT; the compiler must make the condition type recognizable as a valid type name, and it must be possible to reference the condition type as the parent-type of another condition type in a subsequent DEFINE-CONDITION in the file being compiled. DEFPACKAGE: All of the actions normally performed by this macro at load time must also be performed at compile time. (3) The compile-time side effects may cause information about the definition to be stored differently than if the defining macro had been processed in the "normal" way (either interpretively or by loading the compiled file). In particular, the information stored by the defining macros at compile time may or may not be available to the interpreter (either during or after compilation), or during subsequent calls to COMPILE or COMPILE-FILE. For example, the following code is nonportable because it assumes that the compiler stores the macro definition of FOO where it is available to the interpreter: (defmacro foo (x) `(car ,x)) (eval-when (eval compile load) (print (foo '(a b c)))) A portable way to do the same thing would be to include the macro definition inside the EVAL-WHEN: (eval-when (eval compile load) (defmacro foo (x) `(car ,x)) (print (foo '(a b c)))) Rationale: The proposal generally reflects standard programming practices. The primary purpose of the proposal is to make an explicit statement that CL supports the behavior that most programmers expect and many implementations already provide. The primary point of controversy on this issue has been the treatment of the initial value form by DEFCONSTANT, where there is considerable variance between implementations. The effect of the current wording is to legitimize all of the variants. Current Practice: Many (probably most) Common Lisp implementations, including VaxLisp and Lucid Lisp, are already largely in conformance. In VaxLisp, macro definitions that occur as a side effect of compiling a DEFMACRO form are available to the compiler (even on subsequent calls to COMPILE or COMPILE-FILE), but are not available to the interpreter (even within the file being compiled). By default, Kyoto Common Lisp evaluates *all* top level forms as they are compiled, which is clearly in violation of the behavior specified on p 69-70 of CLtL. There is a flag to disable the compile-time evaluation, but then macros such as DEFMACRO, DEFVAR, etc. do not make their definitions available at compile-time either. Cost to implementors: The intent of the proposal is specifically not to require the compiler to have special knowledge about each of these macros. In implementations whose compilers do not treat these macros as special forms, it should be fairly straightforward to use EVAL-WHENs in their expansions to obtain the desired compile-time side effects. Cost to users: Since CLtL does not specify whether and what compile-time side-effects happen, any user code which relies on them is, strictly speaking, nonportable. In practice, however, most programmers already expect most of the behavior described in this proposal and will not find it to be an incompatible change. Benefits: Adoption of the proposal will provide more definite guidelines on how to write programs that will compile correctly under all CL implementations. Discussion: Reaction to a preliminary version of this proposal on the common-lisp mailing list was overwhelmingly positive. More than one person responded with comments to the effect of "but doesn't CLtL already *say* that somewhere?!?" Others have since expressed a more lukewarm approval. It has been suggested that this proposal should also include PROCLAIM. However, since PROCLAIM is not a macro, its compile-time side effects cannot be handled using the EVAL-WHEN mechanism. A separate proposal seems more appropriate. Item (3) allows for significant deviations between implementations. While there is some sentiment to the effect that the compiler should store definitions in a manner identical to that of the interpreter, other people believe strongly that compiler side-effects should be completely invisible to the interpreter. The author is of the opinion that since this is a controversial issue, further attempts to restrict this behavior should be considered as separate proposals. It should be noted that user-written code-analysis programs must generally treat these defining macros as special forms and perform similar "compile-time" actions in order to correctly process conforming programs. gcl-2.6.14/doc/multiple-values0000644000175000017500000000515314360276512014617 0ustar cammcamm Proclaimed functions of a fixed number of args are much more efficient. It is still possible to pass multiple values efficiently (but not quite with the CL semantics) Here are two examples, one using ordinary multiple-value-setq and the other our-multiple-value-setq. For 1,000,000 calls: Type : CL 2 values our 2 values 1 value Time : 7.9 sec 3.5 2.35 name : foo-mv foo-our-mv foo Uses : multiple-value-setq our-multiple-value-setq Only 1 value passed. (defun foo-mv (n) (let (x y) (sloop for i below n do (multiple-value-setq(x y) (goo-mv))))) (defun goo-mv () (values 1 2)) And then an equivalent one: (proclaim '(function foo-our-mv (t) t)) (proclaim '(function goo-our-mv () t)) (defun foo-our-mv (n) (let (x y) (sloop for i below n do (our-multiple-value-setq (x y) (goo-our-mv))) (list x y))) (defun goo-our-mv () (our-values 1 2)) The times: >(time (foo-our-mv 1000000)) real time : 3.617 secs run time : 3.583 secs (1 2) >(time (foo-mv 1000000)) real time : 8.033 secs run time : 7.800 secs (1 2) Here are the our-mv macros: (use-package "SLOOP") (defmacro our-values (a &rest l) (or (< (length l) (length *vals*)) (error "too many values")) `(prog1 ,a ,@ (sloop for v in l for u in *vals* collect `(setq ,u ,v)))) (defmacro our-multiple-value-setq ((x &rest l) form) (or (< (length l) (length *vals*)) (error "too many values")) `(prog1 (setq ,x ,form) ,@ (sloop for w in *vals* for v in l collect `(setq ,v ,w)))) (defvar *vals* '(*val1* *val2* *val3* *val4* *val5* *val6* *val7* *val8* *val9* *val10*)) (defvar *val1* nil) (defvar *val2* nil) (defvar *val3* nil) (defvar *val4* nil) (defvar *val5* nil) (defvar *val6* nil) (defvar *val7* nil) (defvar *val8* nil) (defvar *val9* nil) (defvar *val10* nil) ;; Note that this method does not penalize ordinary calls at all. ;; It is not the same as the common lisp multiple values in general: ;; 1) The information on how many values are being passed is not ;; recorded [ unless of course that number is one of the values ! ] ;; 2) If you ask for more values than were specified you will get ;; a random value. Common lisp values would say you get nil. ;; Now it is true that it would be possible to make AKCL pass multiple ;; values more efficiently, but this is really a large overhaul of the ;; system. There are lots of system functions, hand coded using the ;; old scheme. I have been thinking about ways to do this for the ;; last little while, but have not settled on anything. Bill gcl-2.6.14/doc/c-gc.doc0000644000175000017500000000216414360276512013043 0ustar cammcamm We have implemented garbage collection of the c stack. Thus any new cons or other data type, may be safely left on the c stack or in a register, without fear of lossage due to garbage collection. This enables us to write smaller faster code. We have implemented a scheme for putting frequently used variables, and those inside loops, into registers. For example the compiled sloop.lsp file now has text size 48704, but had text size 53120 or 1.09 times larger. If functions are proclaimed to be of fixed number of args, the code is also substantially better. For example if you have the code: (proclaim '(function memb (t t) t)) (defun memb (a b) (sloop for v on b when (eq (car v) a) do (return v))) If we consider calls where a is the 4'th element of b, then memb runs two times faster than before: On a sun 3-50 19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds without the new modifications to c-gc and the compiler. (defun try (n a b) (sloop for i below n do (memb a b))) Currently if the variable compiler::*c-gc* is not nil, the compiler outputs code under the assumption that c-gc is working. gcl-2.6.14/doc/funcall-comp0000644000175000017500000000167414360276512014053 0ustar cammcamm In AKCL version 1.78 I observe the following times (defun joe () nil) (setq cfun #'joe) (setq symbol 'joe) after compilation (on a sun3/280) Form AKCL 1.78 KCL (joe) 6.1 7.7 (funcall cfun) 9.5 14.0 (funcall symbol) 13.7 17.8 (joe1) 2.1 2.5 times are in microseconds per call. joe1 is the same as joe but with (proclaim '(function joe1 () t)) The functions were in the same file, although this would not make a difference for AKCL. A typical timing loop is (defun foo1 (x n) (sloop for i below n do (funcall x))) (defun foo2 ( n) (sloop for i below n do (joe))) (defun foo3 ( n) (sloop for i below n do (joe1))) (time (foo1 #'joe 100000)) (time (foo1 'joe 100000)) (time (foo2 100000)) Note: An AKCL version >= 1.78 will be released in a few days when I finish checking over the 8 and 16 bit arrays which have been added. gcl-2.6.14/doc/makefile0000644000175000017500000000034614360276512013243 0ustar cammcamm# a facility for displaying DOC files and completing on them # requires gnu emacs, to be in the search path # A directory on peoples search path. ELISP=gcl.el dbl.el ansi-doc.el lisp-complete.el sshell.el -include ../makedefs gcl-2.6.14/doc/c-gc0000644000175000017500000000252514360276512012300 0ustar cammcamm We have implemented garbage collection of the c stack. Thus any new cons or other data type, may be safely left on the c stack or in a register, without fear of lossage due to garbage collection. This enables us to write smaller faster code. We have implemented a scheme for putting frequently used variables, and those inside loops, into registers. For example the compiled sloop.lsp file now has text size 48704, but had text size 53120 or 1.09 times larger. If functions are proclaimed to be of fixed number of args, the code is also substantially better. For example if you have the code: (proclaim '(function memb (t t) t)) (defun memb (a b) (sloop for v on b when (eq (car v) a) do (return v))) If we consider calls where a is the 4'th element of b, then memb runs two times faster than before: On a sun 3-50 19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds without the new modifications to c-gc and the compiler. (defun try (n a b) (sloop for i below n do (memb a b))) Currently if the variable compiler::*c-gc* is not nil, the compiler outputs code under the assumption that c-gc is working. Very bad results would occur if such object code were loaded into a kcl which did not examine the c stack. Also if you are wishing to produce C code for use in an implementation without c-gc you should set *c-gc* to nil. gcl-2.6.14/doc/format0000644000175000017500000000260514360276512012756 0ustar cammcamm We have added a user extensible feature to the common lisp function format. For some applications, for example in maxima, it is very desirable to be able to define a new control character, so that (format t "~%The polynomial ~m is not zero" polynomial) would work. It is desirable to extend format itself, since then calls to the error and other functions which use format will work correctly. For example: (error "~%The polynomial ~m is not zero" polynomial) For an application to do this we would evaluate the following: (setf (get 'si::*indent-formatted-output* (char-code #\m)) 'maxima-print) (defun maxima-print (item stream colon atsign &rest l) colon atsign l ;ignoring these (internal-maxima-print item stream)) Note this extension is case sensitive, so that to have this apply to capital M as well, the property for (char-code #\M) must be added as well. A call with "~:m" would make colon=1 and atsign=0. A call with "~@m" would make colon=0 and atsign=1. To Do: The &rest l is currently unused, a future addition will probably store into l the current column of the format output stream. This also implies that new print functions should return what they think is the new column. Since I believe that 98% of the current calls to format do not use column information in an important way, this is probably not worth the additional hair involved. Numeric args are not passed. gcl-2.6.14/doc/bignum0000644000175000017500000000466614360276512012760 0ustar cammcamm A directory mp was added to hold the new multi precision arithmetic code. The layout and a fair amount of code in the mp directory is an enhanced version of gpari version 34. The gpari c code was rewritten to be more efficient, and gcc assembler macros were added to allow inlining of operations not possible to do in C. On a 68K machine, this allows the C version to be as efficient as the very carefully written assembler in the gpari distribution. For the main machines, an assembler file (produced by gcc) based on this new method, is included. This is for sites which do not have gcc, or do not wish to compile the whole system with gcc. Bignum arithmetic is much faster now. Many changes were made to cmpnew also, to add 'integer' as a new type. It differs from variables of other types, in that storage is associated to each such variable, and assignments mean copying the storage. This allows a function which does a good deal of bignum arithmetic, to do very little consing in the heap. An example is the computation of PI-INV in scratchpad, which calculates the inverse of pi to a prescribed number of bits accuracy. That function is now about 20 times faster, and no longer causes garbage collection. In versions of AKCL where HAVE_ALLOCA is defined, the temporary storage growth is on the C stack, although this often not so critical (for example it makes virtually no difference in the PI-INV example, since in spite of the many operations, only one storage allocation takes place. Below is the actual code for PI-INV On a sun3/280 (cli.com) Here is the comparison of lucid and akcl before and after on that pi-inv. Times are in seconds with multiples of the akcl time in parentheses. On a sun3/280 (cli.com) pi-inv akcl-566 franz lucid old kcl/akcl ---------------------------------------- 10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) 20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) (defun pi-inv (bits &aux (m 0)) (declare (integer bits m)) (let* ((n (+ bits (integer-length bits) 11)) (tt (truncate (ash 1 n) 882)) (d (* 4 882 882)) (s 0)) (declare (integer s d tt n)) (do ((i 2 (+ i 2)) (j 1123 (+ j 21460))) ((zerop tt) (cons s (- (+ n 2)))) (declare (integer i j)) (setq s (+ s (* j tt)) m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) gcl-2.6.14/doc/funcall.lsp0000644000175000017500000000645014360276512013711 0ustar cammcamm I have been trying to improve funcall so that functions of a fixed number of args can be funcalled with almost the same speed as they can be called if the name is laid down in the file. Basically I have made functions with a fixed number of args, first class compiled-function objects, and removed the si::cdefn property stuff. It is no longer necessary to have a global version of the function, since one can now use the C stack version anywhere. I have made compiled function objects slightly smaller, but with more information. So the number of args and there types is encoded in these C functions. It will soon be possible to do fast cross file calling of functions with mixed fixnum and general args and one return value. After these changes: A comparison of calling a fixed arg function of 1 argument: (the second time for KCL is for when the function is in a separate file). LUCID AKCL KCL funcall 8.3 3.54 18.8 (funcall x nil) where x = #'foo Direct call 7.44 2.78 3.16(23.4) (foo nil) (proclaim '(function foo (t) t)) (defun line1 (x n) (sloop for i below n with y do (setq y (funcall x nil)))) (defun line2 (n) (sloop for i below n with y do (setq y (foo nil)))) (defun foo (x) x nil) It is able to detect that only one value from the funcall is desired, because of the setq. In general the following macro can be used to inform the compiler of this. (defmacro vfuncall (x &rest args) `(the (values t) (funcall ,x ,@ args))) We can not lay down the new funcall code if multiple values might be desired: (defun joe (x) (funcall x nil)) will have its number of values returned depend on x. (defun joe (x) (the (values t) (funcall x nil))) or (defun joe (x) (setq x (funcall x nil))) would allow it however. Unfortunately GCL is much slower if the function to be funcalled does not happen to be a compiled function which was compiled while proclaimed with a fixed number of args and one value. Still there are a number of critical applications where it is useful to have a very fast funcall. I have no useful heuristic at the moment for 'guessing' which kind of funcall I should lay down: One optimized for C stack or one optimized for Lisp stack. I can only detect when it is safe to lay down a C stack one. However if the function in question uses the lisp stack, and is called via the C stack, the call will be twice as slow as it used to be. This is very unfortunate! At the cost of space I could avoid this, but the new funcall takes up less space than the old one and I hate to lay down two types in the code just in case.... The check as to type is being laid down, but a trick is used to keep space different minimal. SPACE: I have also noted some size differences (as reported by size *.o) where the amounts are the 'dec' = decimal representation of text+data+bss in the object file. This is what gets loaded. There is still room for improvement here. Most of the difference is due to the fact that functions of fixed args only need one entry now. Before: After: 31340 basis.o 28348 76584 code-1-a.o 63212 94136 code-b-d.o 79136 93372 code-e-m.o 75384 125172 code-n-r.o 10524 77148 code-s-z.o 61840 15620 events.o 14504 4036 genfact.o 3464 27908 io.o 24544 9132 ppr.o 8340 42668 sloop.o 40484 gcl-2.6.14/doc/profile0000644000175000017500000000245014360276512013124 0ustar cammcamm We have added a facility for determining the proportional amount of time spent executing compiled lisp defined functions, as well as internal c defined functions. This system works under Unix BSD or System V. To use this code load the file lsp/profile.o. SET-UP-PROFILE &optional (array-size 100000)(max-funs 6000) must be called to allocate space for storing the profile information as it is collected, and also to build a list of the functions from the symbol table of the executable (defaults to "saved_kcl"). Once this has been done a call to PROF (start scale) START will correspond to the beginning of the profile array, and the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the profile array. Thus if the profile array is 1,000,000 bytes long and the code segment is 5 megabytes long you can profile the whole thing using a scale of 50 Note that long runs may result in overflow, and so an understating of the time in a function. With a scale of 128 a sample loop overflowed some slots at 6,000,000 times through the loop. There is very little slowdown in execution during profiling. No special compilation is necessary. To display the result do (si::display-profile) To turn off profiling use (si::prof 0 0). (si::clear-profile) clears the profile array for a new run. gcl-2.6.14/doc/debug0000644000175000017500000000171214360276512012552 0ustar cammcammNew Debugging Features: Search-stack: (:s "cal") or (:s 'cal) searches the stack for a frame whose function or special form has a name containing "cal", moves there to display the local data. Break-locals: :bl displays the args and locals of the current function. (:bl 4) does this for 4 functions. (si:loc i) accesses the local(i): slot. the *print-level* and *print-depth* are bound to si::*debug-print-level* Recall that kcl permits movement to previous frame (:p) and next frame (:n). These also take numeric args eg. (:p 7) moves up 7 frames. If functions are interpreted, the arg values are displayed together with their names. If the functions are using the C stack (ie proclaimed functions), very little information is available. Note you must have space < 3 in your optimize proclamation, in order for the local variable names to be saved by the compiler. To Do: add setf method for si:loc. add restart capability from various spots on the stack. gcl-2.6.14/add-defs0000755000175000017500000000777414360276512012407 0ustar cammcamm#!/bin/sh if [ $# -le 0 ] ; then echo usage: ./add-defs machine-type; echo or ' ' ./add-defs machine-type directory echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs echo see echo h/*.defs exit 1 ; fi if [ -f h/$1.defs ] ; then echo using $1.defs ; else echo h/$1.defs does not exist echo Build one or use one of `ls h/*.defs` exit 1 fi echo $1 > machine rm -f makedefs echo > makedefs echo "# begin makedefs" >> makedefs echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs if [ -d ${PWD}/unixport ] ; then echo "GCLDIR=${PWD}" >> makedefs ; else echo "GCLDIR=`pwd`" >> makedefs ; fi echo "SHELL=/bin/sh" >> makedefs echo "MACHINE=$1" >> makedefs # a place where you keep local things. Changing this may help to # find things, otherwise edit the "LIST-OF-DIRECTORIES" for the # given item. if [ "$2x" != "x" ] ; then PUBLIC=$2 ; else PUBLIC=/public fi export PUBLIC TK_XINCLUDES=-Iunknown # `add-dir' searches for ITEM in LIST-OF-DIRECTORIES and then sets the # directory in VARIABLE-SETTING-TEMPLATE #Usage: ./xbin/add-dir ITEM LIST-OF-DIRECTORIES VARIABLE-SETTING-TEMPLATE ./xbin/add-dir tkConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TK_CONFIG_PREFIX="$v"' ./xbin/add-dir tclConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TCL_CONFIG_PREFIX="$v"' ./xbin/add-dir dir "/usr/local/lib/info ${PUBLIC}/lib/info /usr/lib/info" 'INFO_DIR="$v"' SOURCE=. ${SOURCE} makedefs if [ -f ${TK_CONFIG_PREFIX}/tkConfig.sh -a \ -f ${TCL_CONFIG_PREFIX}/tclConfig.sh ] ; then ${SOURCE} ${TK_CONFIG_PREFIX}/tkConfig.sh ; ${SOURCE} ${TK_CONFIG_PREFIX}/tclConfig.sh ; ./xbin/add-dir tk.h "${PUBLIC}/include /usr/include /usr/local/include" 'TK_INCLUDE="-I$v"' echo "TK_VERSION=${TK_VERSION}" >> makedefs echo "TCL_VERSION=${TCL_VERSION}" >> makedefs echo "TK_LIB_SPEC=${TK_LIB_SPEC}" >> makedefs echo "TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION}" >> makedefs echo "TCL_LIBRARY=${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION}" >> makedefs echo "TK_BUILD_LIB_SPEC=${TK_BUILD_LIB_SPEC}" >> makedefs echo "TK_XLIBSW=${TK_XLIBSW}" >> makedefs TK_XLIB_DIR=`echo ${TK_XLIBSW} | sed "s:-L\\([^ ]*\\) .*:\\1:g"` echo "TK_XLIB_DIR=${TK_XLIB_DIR}" >> makedefs echo "TK_XINCLUDES=${TK_XINCLUDES}" >> makedefs echo "TCL_LIB_SPEC=${TCL_LIB_SPEC}" >> makedefs echo "TCL_DL_LIBS=${TCL_DL_LIBS}" >> makedefs echo "TCL_LIBS=${TCL_LIBS}" >> makedefs echo "HAVE_X11=-DHAVE_X11" >> makedefs else echo "TK_CONFIG_PREFIX=unknown" >> makedefs ./xbin/add-dir X11/Xos.h "${PUBLIC}/include /usr/include /usr/local/X11R6/include /usr/local/X11/include " 'TK_XINCLUDES="-I$v"' . makedefs if [ "$TK_XINCLUDES" = "-Iunknown" ] ; then echo "cant find X11 includes so not defining HAVE_X11" else echo HAVE_X11=-DHAVE_X11 >> makedefs fi echo unable to find tkConfig.sh and tclConfig.sh so not configuring tcl/tk fi ####machine specific .defs files may over ride the above#### ####### insert the h/machine.defs file ############ cat h/$1.defs >> makedefs if [ -f ${HOME}/local_gcl.defs ] ; then cat ${HOME}/local_gcl.defs >> makedefs fi echo "# end makedefs" >> makedefs echo inserting h/$1.defs in .. for v in makefile unixport/make_kcn */makefile ; do echo " $v," ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx mv tmpx $v done echo "" # Copy the config.h over. cat h/$1.h > tmpx if [ -f ${HOME}/local_gcl.h ] ; then cat ${HOME}/local_gcl.h >> tmpx fi if fgrep =unknown makedefs > /dev/null ; then echo " if the 'unknown' directories exist you may provide a second argument to ./add-defs of a local directory where things might be, or edit ./add-defs so that it can find them. Otherwise just continue and the portions with unknown will not be compiled." fi if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; else rm -f h/config.h cp tmpx h/config.h fi rm -f tmpx # machine specific stuff that cant be handled normally... if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi gcl-2.6.14/ansi-tests/0000755000175000017500000000000014360276512013065 5ustar cammcammgcl-2.6.14/ansi-tests/multiple-value-bind.lsp0000644000175000017500000000267014360276512017471 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:16:23 2002 ;;;; Contains: Tests for MULTIPLE-VALUE-BIND (in-package :cl-test) (deftest multiple-value-bind.1 (multiple-value-bind (x y z) (values 1 2 3) (declare (type integer x)) (declare (type integer y)) (declare (type integer z)) (list z y x)) (3 2 1)) (deftest multiple-value-bind.2 (multiple-value-bind (x y z) (values 1 2 3) (let ((x 4)) (list x y z))) (4 2 3)) (deftest multiple-value-bind.3 (multiple-value-bind (x y z) (values 1 2 3 4 5 6) (list x y z)) (1 2 3)) (deftest multiple-value-bind.4 (multiple-value-bind (x y z) (values 1 2) (list x y z)) (1 2 nil)) (deftest multiple-value-bind.5 (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) a b c) (deftest multiple-value-bind.6 (multiple-value-bind (x y z) (values) (list x y z)) (nil nil nil)) (deftest multiple-value-bind.7 (let ((z 0) x y) (declare (special z)) (values (flet ((%x () (symbol-value 'x)) (%y () (symbol-value 'y)) (%z () (symbol-value 'z))) (multiple-value-bind (x y z) (values 1 2 3) (declare (special x y)) (list (%x) (%y) (%z)))) x y z)) (1 2 0) nil nil 0) ;;; (deftest multiple-value-bind.error.1 ;;; (classify-error (multiple-value-bind)) ;;; program-error) ;;; ;;; (deftest multiple-value-bind.error.2 ;;; (classify-error (multiple-value-bind (a b c))) ;;; program-error) gcl-2.6.14/ansi-tests/bit-nand.lsp0000644000175000017500000001434214360276512015305 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:16:15 2003 ;;;; Contains: Tests for BIT-NAND (in-package :cl-test) (deftest bit-nand.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-nand.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-nand.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-nand.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-nand.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-nand.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-nand.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nand s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-nand.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2)) a1 a2)) #*1110 #*0011 #*0101) (deftest bit-nand.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-nand a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1110 #*1110 #*0101 t) (deftest bit-nand.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-nand a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1110 #*0011 #*0101 #*1110 t) (deftest bit-nand.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2 nil)) a1 a2)) #*1110 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-nand.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2 t))) (values a1 a2 result)) #2a((1 1)(1 0)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nand a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-nand a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0)) #2a((1 1)(1 0))) ;;; Adjustable arrays (deftest bit-nand.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) ;;; Displaced arrays (deftest bit-nand.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nand a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nand a1 a2 t))) (values a0 a1 a2 result)) #*11100011 #2a((1 1)(1 0)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-nand a1 a2 a3))) (values a0 a1 a2 result)) #*010100111110 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(1 0))) (deftest bit-nand.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-nand (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-nand.error.1 (classify-error (bit-nand)) program-error) (deftest bit-nand.error.2 (classify-error (bit-nand #*000)) program-error) (deftest bit-nand.error.3 (classify-error (bit-nand #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/load.lsp0000644000175000017500000001434114360276512014527 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Apr 12 21:51:49 2005 ;;;; Contains: Tests of LOAD (in-package :cl-test) (defun load-file-test (file funname &rest args &key if-does-not-exist (print nil print-p) (verbose nil verbose-p) (*load-print* nil) (*load-verbose* nil) external-format) (declare (ignorable external-format if-does-not-exist print print-p verbose verbose-p)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) (vals (multiple-value-list (with-output-to-string (*standard-output* str) (apply #'load file :allow-other-keys t args)))) (print? (if print-p print *load-print*)) (verbose? (if verbose-p verbose *load-verbose*))) (values (let ((v1 (car vals)) (v2 (or (and verbose-p (not verbose)) (and (not verbose-p) (not *load-verbose*)) (position #\; str))) (v3 (or (and print-p (not print)) (and (not print-p) (not *load-print*)) (> (length str) 0))) (v4 (if (or print? verbose?) (> (length str) 0) t))) (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str))) (funcall funname)))) (deftest load.1 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest load.2 (load-file-test #p"compile-file-test-file.lsp" 'compile-file-test-fun.1) t nil) (deftest load.3 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2)) t good) (deftest load.4 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :external-format :default) t nil) (deftest load.5 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :verbose t) t nil) (deftest load.6 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-verbose* t) t nil) (deftest load.7 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-verbose* t :verbose nil) t nil) (deftest load.8 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2 :verbose t)) t good) (deftest load.9 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :print t) t nil) (deftest load.10 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* t) t nil) (deftest load.11 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* t :print nil) t nil) (deftest load.12 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 :*load-print* nil :print t) t nil) (deftest load.13 (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") (load-file-test s 'load-file-test-fun.2 :print t)) t good) (deftest load.14 (load "nonexistent-file.lsp" :if-does-not-exist nil) nil) (defpackage LOAD-TEST-PACKAGE (:use "COMMON-LISP")) (deftest load.15 (let ((*package* (find-package "LOAD-TEST-PACKAGE"))) (with-input-from-string (s "(defun f () 'good)") (load-file-test s 'load-test-package::f))) t load-test-package::good) (deftest load.15a (let ((*package* (find-package "CL-TEST"))) (values (with-input-from-string (s "(eval-when (:load-toplevel :execute) (setq *package* (find-package \"LOAD-TEST-PACKAGE\"))) (defun f () 'good)") (multiple-value-list (load-file-test s 'load-test-package::f))) (read-from-string "GOOD"))) (t load-test-package::good) good) (deftest load.16 (let ((*readtable* (copy-readtable nil))) (set-macro-character #\! (get-macro-character #\')) (with-input-from-string (s "(in-package :cl-test) (defun load-file-test-fun.3 () !good)") (load-file-test s 'load-file-test-fun.3))) t good) (deftest load.16a (let ((*readtable* *readtable*) (*package* (find-package "CL-TEST"))) (values (with-input-from-string (s "(in-package :cl-test) (eval-when (:load-toplevel :execute) (setq *readtable* (copy-readtable nil)) (set-macro-character #\\! (get-macro-character #\\'))) (defun load-file-test-fun.3 () !good)") (multiple-value-list (load-file-test s 'load-file-test-fun.3))) (read-from-string "!FOO"))) (t good) !FOO) (deftest load.17 (let ((file #p"load-test-file.lsp")) (fmakunbound 'load-file-test-fun.1) (fmakunbound 'load-file-test-fun.2) (values (notnot (load file)) (let ((p1 (pathname (merge-pathnames file))) (p2 (funcall 'load-file-test-fun.1))) (equalpt-or-report p1 p2)) (let ((p1 (truename file)) (p2 (funcall 'load-file-test-fun.2))) (equalpt-or-report p1 p2)))) t t t) ;;; Test that the load pathname/truename variables are bound ;;; properly when loading compiled files (deftest load.18 (let* ((file "load-test-file-2.lsp") (target (enough-namestring (compile-file-pathname file)))) (declare (special *load-test-var.1* *load-test-var.2*)) (compile-file file) (makunbound '*load-test-var.1*) (makunbound '*load-test-var.2*) (load target) (values (let ((p1 (pathname (merge-pathnames target))) (p2 *load-test-var.1*)) (equalpt-or-report p1 p2)) (let ((p1 (truename target)) (p2 *load-test-var.2*)) (equalpt-or-report p1 p2)))) t t) (deftest load.19 (let ((file (logical-pathname "CLTEST:LDTEST.LSP")) (fn 'load-test-fun-3) (*package* (find-package "CL-TEST"))) (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create) (format s "(in-package :cl-test) (defun ~a () :foo)" fn)) (fmakunbound fn) (values (notnot (load file)) (funcall fn))) t :foo) ;;; Defaults of the load variables (deftest load-pathname.1 *load-pathname* nil) (deftest load-truename.1 *load-truename* nil) (deftest load-print.1 *load-print* nil) ;;; Error tests (deftest load.error.1 (signals-error (load "nonexistent-file.lsp") file-error) t) (deftest load.error.2 (signals-error (load) program-error) t) (deftest load.error.3 (signals-error (load "compile-file-test-file.lsp" :bad-key-arg t) program-error) t) gcl-2.6.14/ansi-tests/array-dimension.lsp0000644000175000017500000000243214360276512016707 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:55:14 2003 ;;;; Contains: Tests of ARRAY-DIMENSION (in-package :cl-test) ;;; array-dimension is also tested by the tests in make-array.lsp (deftest array-dimension.1 (array-dimension #(0 1 2 3) 0) 4) (deftest array-dimension.2 (array-dimension "abcdef" 0) 6) (deftest array-dimension.3 (array-dimension #2a((1 2 3 4)(5 6 7 8)) 0) 2) (deftest array-dimension.4 (array-dimension #2a((1 2 3 4)(5 6 7 8)) 1) 4) (deftest array-dimension.5 (let ((a (make-array '(10) :fill-pointer 5))) (array-dimension a 0)) 10) (deftest array-dimension.6 (let ((a (make-array '(10) :adjustable t))) (values (array-dimension a 0) (progn (adjust-array a '(20)) (array-dimension a 0)))) 10 20) (deftest array-dimension.order.1 (let ((i 0) a b) (values (array-dimension (progn (setf a (incf i)) #(a b c d)) (progn (setf b (incf i)) 0)) i a b)) 4 2 1 2) ;;; Error tests (deftest array-dimension.error.1 (classify-error (array-dimension)) program-error) (deftest array-dimension.error.2 (classify-error (array-dimension #(a b c))) program-error) (deftest array-dimension.error.3 (classify-error (array-dimension #(a b c) 0 nil)) program-error) gcl-2.6.14/ansi-tests/subseq-aux.lsp0000644000175000017500000001547714360276512015720 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Nov 26 20:01:27 2002 ;;;; Contains: Aux. functions for subseq tests (in-package :cl-test) (defun subseq-list.4-body () (block done (let ((x (loop for i from 0 to 19 collect i))) (loop for i from 0 to 20 do (loop for j from i to 20 do (let ((y (subseq x i j))) (loop for e in y and k from i to (1- j) do (unless (eqlt e k) (return-from done nil))))))) t)) (defun subseq-list.5-body () (block done (let ((x (loop for i from 0 to 29 collect i))) (loop for i from 0 to 30 do (unless (equalt (subseq x i) (loop for j from i to 29 collect j)) (return-from done nil)))) t)) (defun subseq-list.6-body () (let* ((x (make-list 100)) (z (loop for e on x collect e)) (y (subseq x 0))) (loop for e on x and f on y and g in z do (when (or (not (eqt g e)) (not (eqlt (car e) (car f))) (car e) (eqt e f)) (return nil)) finally (return t)))) (defun subseq-vector.1-body () (block nil (let* ((x (make-sequence 'vector 10 :initial-element 'a)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqt e 'a)) x) (return 1)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 'b)) (unless (every #'(lambda (e) (eqt e 'a)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 'c)) (or (not (not (every #'(lambda (e) (eqt e 'b)) x))) 6)))) (defun subseq-vector.2-body () (block nil (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqlt e 1)) x) (return 1)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2)) (unless (every #'(lambda (e) (eqlt e 1)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3)) (or (not (not (every #'(lambda (e) (eqlt e 2)) x))) 6)))) (defun subseq-vector.3-body () (block nil (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.4-body () (block nil (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0d0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0d0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.5-body () (block nil (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0s0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0s0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-vector.6-body () (block nil (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 2)) (unless (eqlt (length x) 10) (return 3)) (unless (eqlt (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 2.0l0)) (unless (every #'(lambda (e) (= e 1.0)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 3.0l0)) (or (not (not (every #'(lambda (e) (= e 2.0)) x))) 6)))) (defun subseq-string.1-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len always (string= (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'string))))) (defun subseq-string.2-body () (let* ((s1 "abcdefgh") (len (length s1))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (string= (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'string)))))) (defun subseq-string.3-body () (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 8 :element-type 'character)) (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len always (string= (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'string))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (string= (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'string))))))) (defun subseq-bit-vector.1-body () (let* ((s1 #*11001000) (len (length s1))) (loop for start from 0 below len always (equalp (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'bit-vector))))) (defun subseq-bit-vector.2-body () (let* ((s1 #*01101011) (len (length s1))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (equalp (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'bit-vector)))))) (defun subseq-bit-vector.3-body () (let* ((s1 (make-array '(10) :initial-contents #*1101100110 :fill-pointer 8 :element-type 'bit)) (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len always (equalp (subseq s1 start) (coerce (loop for i from start to (1- len) collect (aref s1 i)) 'bit-vector))) (loop for start from 0 below len always (loop for end from (1+ start) to len always (equalp (subseq s1 start end) (coerce (loop for i from start below end collect (aref s1 i)) 'bit-vector))))))) gcl-2.6.14/ansi-tests/load-data-and-control-flow.lsp0000644000175000017500000000307314360276512020621 0ustar cammcamm;;; Tests of data and control flow (load "data-and-control-flow.lsp") (load "places.lsp") (load "and.lsp") (load "apply.lsp") (load "block.lsp") (load "call-arguments-limit.lsp") (load "case.lsp") (load "catch.lsp") (load "ccase.lsp") (load "compiled-function-p.lsp") (load "complement.lsp") (load "cond.lsp") (load "constantly.lsp") (load "ctypecase.lsp") (load "defconstant.lsp") (load "define-modify-macro.lsp") (load "defparameter.lsp") (load "defun.lsp") (load "defvar.lsp") (load "destructuring-bind.lsp") (load "ecase.lsp") (load "eql.lsp") (load "equal.lsp") (load "equalp.lsp") (load "etypecase.lsp") (load "every.lsp") (load "fboundp.lsp") (load "fdefinition.lsp") (load "flet.lsp") (load "fmakunbound.lsp") (load "funcall.lsp") (load "function-lambda-expression.lsp") (load "function.lsp") (load "functionp.lsp") (load "get-setf-expansion.lsp") (load "identity.lsp") (load "if.lsp") (load "labels.lsp") (load "lambda-list-keywords.lsp") (load "lambda-parameters-limit.lsp") (load "let.lsp") (load "macrolet.lsp") (load "multiple-value-bind.lsp") (load "multiple-value-call.lsp") ;; include multiple-value-list (load "multiple-value-prog1.lsp") (load "multiple-value-setq.lsp") (load "nil.lsp") (load "not-and-null.lsp") (load "notany.lsp") (load "notevery.lsp") (load "nth-value.lsp") (load "or.lsp") (load "prog.lsp") (load "prog1.lsp") (load "prog2.lsp") (load "progn.lsp") (load "progv.lsp") (load "some.lsp") (load "t.lsp") (load "tagbody.lsp") (load "typecase.lsp") (load "unless.lsp") (load "unwind-protect.lsp") (load "values-list.lsp") (load "values.lsp") (load "when.lsp") gcl-2.6.14/ansi-tests/char-compare.lsp0000644000175000017500000003660714360276512016162 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 19:36:00 2002 ;;;; Contains: Tests of character comparison functions (in-package :cl-test) ;;; The character comparisons should throw a PROGRAM-ERROR when ;;; safe-called with no arguments (deftest char-compare-no-args (loop for f in '(char= char/= char< char> char<= char>= char-lessp char-greaterp char-equal char-not-lessp char-not-greaterp char-not-equal) collect (eval `(classify-error (funcall ',f)))) (program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error program-error )) (deftest char=.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) t) (deftest char=.2 (loop for c across +code-chars+ always (char= c c)) t) (deftest char=.3 (every #'char= +code-chars+) t) (deftest char=.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) t) (deftest char=.order.1 (let ((i 0)) (values (not (char= (progn (incf i) #\a))) i)) nil 1) (deftest char=.order.2 (let ((i 0) a b) (values (char= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b)) i a b)) nil 2 1 2) (deftest char=.order.3 (let ((i 0) a b c) (values (char= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char/=.1 (is-ordered-by +code-chars+ #'char/=) t) (deftest char/=.2 (loop for c across +code-chars+ never (char/= c c)) t) (deftest char/=.3 (every #'char/= +code-chars+) t) (deftest char/=.4 (is-ordered-by +rev-code-chars+ #'char/=) t) (deftest char/=.order.1 (let ((i 0)) (values (not (char/= (progn (incf i) #\a))) i)) nil 1) (deftest char/=.order.2 (let ((i 0) a b) (values (not (char/= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char/=.order.3 (let ((i 0) a b c) (values (char/= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char<=.1 (loop for c across +code-chars+ always (char<= c c)) t) (deftest char<=.2 (every #'char<= +code-chars+) t) (deftest char<=.3 (is-antisymmetrically-ordered-by +code-chars+ #'char<=) t) (deftest char<=.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<=) t) (deftest char<=.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<=) t) (deftest char<=.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char<=) t) (deftest char<=.7 (notnot-mv (or (char<= #\9 #\A) (char<= #\Z #\0))) t) (deftest char<=.8 (notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0))) t) (deftest char<=.order.1 (let ((i 0)) (values (not (char<= (progn (incf i) #\a))) i)) nil 1) (deftest char<=.order.2 (let ((i 0) a b) (values (not (char<= (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char<=.order.3 (let ((i 0) a b c) (values (char<= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char<.1 (loop for c across +code-chars+ never (char< c c)) t) (deftest char<.2 (every #'char< +code-chars+) t) (deftest char<.3 (is-antisymmetrically-ordered-by +code-chars+ #'char<) t) (deftest char<.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<) t) (deftest char<.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<) t) (deftest char<.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char<) t) (deftest char<.7 (notnot-mv (or (char< #\9 #\A) (char< #\Z #\0))) t) (deftest char<.8 (notnot-mv (or (char< #\9 #\a) (char< #\z #\0))) t) (deftest char<.order.1 (let ((i 0)) (values (not (char< (progn (incf i) #\a))) i)) nil 1) (deftest char<.order.2 (let ((i 0) a b) (values (not (char< (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char<.order.3 (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char<.order.4 (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char>=.1 (loop for c across +code-chars+ always (char>= c c)) t) (deftest char>=.2 (every #'char>= +code-chars+) t) (deftest char>=.3 (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>=) t) (deftest char>=.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>=) t) (deftest char>=.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>=) t) (deftest char>=.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>=) t) (deftest char>=.7 (notnot-mv (or (char>= #\A #\9) (char>= #\0 #\Z))) t) (deftest char>=.8 (notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z))) t) (deftest char>=.order.1 (let ((i 0)) (values (not (char>= (progn (incf i) #\a))) i)) nil 1) (deftest char>=.order.2 (let ((i 0) a b) (values (not (char>= (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char>=.order.3 (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char>=.order.4 (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char>.1 (loop for c across +code-chars+ never (char> c c)) t) (deftest char>.2 (every #'char> +code-chars+) t) (deftest char>.3 (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>) t) (deftest char>.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>) t) (deftest char>.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>) t) (deftest char>.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>) t) (deftest char>.7 (notnot-mv (or (char> #\A #\9) (char> #\0 #\Z))) t) (deftest char>.8 (notnot-mv (or (char> #\a #\9) (char> #\0 #\z))) t) (deftest char>.order.1 (let ((i 0)) (values (not (char> (progn (incf i) #\a))) i)) nil 1) (deftest char>.order.2 (let ((i 0) a b) (values (not (char> (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char>.order.3 (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char>.order.4 (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; Case-insensitive comparisons (deftest char-equal.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (not (char-equal c1 c2))))) t) (deftest char-equal.2 (loop for c across +code-chars+ always (char-equal c c)) t) (deftest char-equal.3 (loop for c across +code-chars+ always (char-equal c)) t) (deftest char-equal.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (not (char-equal c1 c2))))) t) (deftest char-equal.order.1 (let ((i 0)) (values (not (char-equal (progn (incf i) #\a))) i)) nil 1) (deftest char-equal.order.2 (let ((i 0) a b) (values (char-equal (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a)) i a b)) nil 2 1 2) (deftest char-equal.order.3 (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-equal.order.4 (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-equal.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (char-not-equal c1 c2)))) t) (deftest char-not-equal.2 (loop for c across +code-chars+ never (char-not-equal c c)) t) (deftest char-not-equal.3 (every #'char-not-equal +code-chars+) t) (deftest char-not-equal.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) (or (char= (char-downcase c1) (char-downcase c2)) (char-not-equal c1 c2)))) t) (deftest char-not-equal.order.1 (let ((i 0)) (values (not (char-not-equal (progn (incf i) #\a))) i)) nil 1) (deftest char-not-equal.order.2 (let ((i 0) a b) (values (not (char-not-equal (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-not-equal.order.3 (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-not-equal.order.4 (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-greaterp.1 (loop for c across +code-chars+ always (char-not-greaterp c c)) t) (deftest char-not-greaterp.2 (every #'char-not-greaterp +code-chars+) t) (deftest char-not-greaterp.3 (is-case-insensitive #'char-not-greaterp) t) (deftest char-not-greaterp.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char-not-greaterp) t) (deftest char-not-greaterp.7 (notnot-mv (or (char-not-greaterp #\9 #\A) (char-not-greaterp #\Z #\0))) t) (deftest char-not-greaterp.8 (notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0))) t) (deftest char-not-greaterp.order.1 (let ((i 0)) (values (not (char-not-greaterp (progn (incf i) #\a))) i)) nil 1) (deftest char-not-greaterp.order.2 (let ((i 0) a b) (values (not (char-not-greaterp (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char-not-greaterp.order.3 (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char-not-greaterp.order.4 (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-lessp.1 (loop for c across +code-chars+ never (char-lessp c c)) t) (deftest char-lessp.2 (every #'char-lessp +code-chars+) t) (deftest char-lessp.3 (is-case-insensitive #'char-lessp) t) (deftest char-lessp.4 (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-lessp) t) (deftest char-lessp.5 (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-lessp) t) (deftest char-lessp.6 (is-antisymmetrically-ordered-by +digit-chars+ #'char-lessp) t) (deftest char-lessp.7 (notnot-mv (or (char-lessp #\9 #\A) (char-lessp #\Z #\0))) t) (deftest char-lessp.8 (notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0))) t) (deftest char-lessp.order.1 (let ((i 0)) (values (not (char-lessp (progn (incf i) #\a))) i)) nil 1) (deftest char-lessp.order.2 (let ((i 0) a b) (values (not (char-lessp (progn (setf a (incf i)) #\a) (progn (setf b (incf i)) #\b))) i a b)) nil 2 1 2) (deftest char-lessp.order.3 (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) (deftest char-lessp.order.4 (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) ;;; (deftest char-not-lessp.1 (loop for c across +code-chars+ always (char-not-lessp c c)) t) (deftest char-not-lessp.2 (every #'char-not-lessp +code-chars+) t) (deftest char-not-lessp.3 (is-case-insensitive #'char-not-lessp) t) (deftest char-not-lessp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char-not-lessp) t) (deftest char-not-lessp.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-not-lessp) t) (deftest char-not-lessp.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-not-lessp) t) (deftest char-not-lessp.7 (notnot-mv (or (char-not-lessp #\A #\9) (char-not-lessp #\0 #\Z))) t) (deftest char-not-lessp.8 (notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z))) t) (deftest char-not-lessp.order.1 (let ((i 0)) (values (not (char-not-lessp (progn (incf i) #\a))) i)) nil 1) (deftest char-not-lessp.order.2 (let ((i 0) a b) (values (not (char-not-lessp (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-not-lessp.order.3 (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-not-lessp.order.4 (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; (deftest char-greaterp.1 (loop for c across +code-chars+ never (char-greaterp c c)) t) (deftest char-greaterp.2 (every #'char-greaterp +code-chars+) t) (deftest char-greaterp.3 (is-case-insensitive #'char-greaterp) t) (deftest char-greaterp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char-greaterp) t) (deftest char-greaterp.5 (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-greaterp) t) (deftest char-greaterp.6 (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-greaterp) t) (deftest char-greaterp.7 (notnot-mv (or (char-greaterp #\A #\9) (char-greaterp #\0 #\Z))) t) (deftest char-greaterp.8 (notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z))) t) (deftest char-greaterp.order.1 (let ((i 0)) (values (not (char-greaterp (progn (incf i) #\a))) i)) nil 1) (deftest char-greaterp.order.2 (let ((i 0) a b) (values (not (char-greaterp (progn (setf a (incf i)) #\b) (progn (setf b (incf i)) #\a))) i a b)) nil 2 1 2) (deftest char-greaterp.order.3 (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\b) (progn (setq b (incf i)) #\a) (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) (deftest char-greaterp.order.4 (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\a) (progn (setq b (incf i)) #\b) (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) gcl-2.6.14/ansi-tests/array-t.lsp0000644000175000017500000001076114360276512015171 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 11:55:48 2003 ;;;; Contains: Tests of (array t ...) type specifiers (in-package :cl-test) ;;; Tests of (array t) (deftest array-t.2.1 (notnot-mv (typep #() '(array t))) t) (deftest array-t.2.2 (notnot-mv (typep #0aX '(array t))) t) (deftest array-t.2.3 (notnot-mv (typep #2a(()) '(array t))) t) (deftest array-t.2.4 (notnot-mv (typep #(1 2 3) '(array t))) t) (deftest array-t.2.5 (typep "abcd" '(array t)) nil) (deftest array-t.2.6 (typep #*010101 '(array t)) nil) ;;; Tests of (array t ()) (deftest array-t.3.1 (notnot-mv (typep #() '(array t nil))) nil) (deftest array-t.3.2 (notnot-mv (typep #0aX '(array t nil))) t) (deftest array-t.3.3 (typep #2a(()) '(array t nil)) nil) (deftest array-t.3.4 (typep #(1 2 3) '(array t nil)) nil) (deftest array-t.3.5 (typep "abcd" '(array t nil)) nil) (deftest array-t.3.6 (typep #*010101 '(array t nil)) nil) ;;; Tests of (array t 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest array-t.4.1 (notnot-mv (typep #() '(array t 1))) t) (deftest array-t.4.2 (typep #0aX '(array t 1)) nil) (deftest array-t.4.3 (typep #2a(()) '(array t 1)) nil) (deftest array-t.4.4 (notnot-mv (typep #(1 2 3) '(array t 1))) t) (deftest array-t.4.5 (typep "abcd" '(array t 1)) nil) (deftest array-t.4.6 (typep #*010101 '(array t 1)) nil) ;;; Tests of (array t 0) (deftest array-t.5.1 (typep #() '(array t 0)) nil) (deftest array-t.5.2 (notnot-mv (typep #0aX '(array t 0))) t) (deftest array-t.5.3 (typep #2a(()) '(array t 0)) nil) (deftest array-t.5.4 (typep #(1 2 3) '(array t 0)) nil) (deftest array-t.5.5 (typep "abcd" '(array t 0)) nil) (deftest array-t.5.6 (typep #*010101 '(array t 0)) nil) ;;; Tests of (array t *) (deftest array-t.6.1 (notnot-mv (typep #() '(array t *))) t) (deftest array-t.6.2 (notnot-mv (typep #0aX '(array t *))) t) (deftest array-t.6.3 (notnot-mv (typep #2a(()) '(array t *))) t) (deftest array-t.6.4 (notnot-mv (typep #(1 2 3) '(array t *))) t) (deftest array-t.6.5 (typep "abcd" '(array t *)) nil) (deftest array-t.6.6 (typep #*010101 '(array t *)) nil) ;;; Tests of (array t 2) (deftest array-t.7.1 (typep #() '(array t 2)) nil) (deftest array-t.7.2 (typep #0aX '(array t 2)) nil) (deftest array-t.7.3 (notnot-mv (typep #2a(()) '(array t 2))) t) (deftest array-t.7.4 (typep #(1 2 3) '(array t 2)) nil) (deftest array-t.7.5 (typep "abcd" '(array t 2)) nil) (deftest array-t.7.6 (typep #*010101 '(array t 2)) nil) ;;; Testing '(array t (--)) (deftest array-t.8.1 (typep #() '(array t (1))) nil) (deftest array-t.8.2 (notnot-mv (typep #() '(array t (0)))) t) (deftest array-t.8.3 (notnot-mv (typep #() '(array t (*)))) t) (deftest array-t.8.4 (typep #(a b c) '(array t (2))) nil) (deftest array-t.8.5 (notnot-mv (typep #(a b c) '(array t (3)))) t) (deftest array-t.8.6 (notnot-mv (typep #(a b c) '(array t (*)))) t) (deftest array-t.8.7 (typep #(a b c) '(array t (4))) nil) (deftest array-t.8.8 (typep #2a((a b c)) '(array t (*))) nil) (deftest array-t.8.9 (typep #2a((a b c)) '(array t (3))) nil) (deftest array-t.8.10 (typep #2a((a b c)) '(array t (1))) nil) (deftest array-t.8.11 (typep "abc" '(array t (2))) nil) (deftest array-t.8.12 (typep "abc" '(array t (3))) nil) (deftest array-t.8.13 (typep "abc" '(array t (*))) nil) (deftest array-t.8.14 (typep "abc" '(array t (4))) nil) ;;; Two dimensional array type tests (deftest array-t.9.1 (typep #() '(array t (* *))) nil) (deftest array-t.9.2 (typep "abc" '(array t (* *))) nil) (deftest array-t.9.3 (typep #(a b c) '(array t (3 *))) nil) (deftest array-t.9.4 (typep #(a b c) '(array t (* 3))) nil) (deftest array-t.9.5 (typep "abc" '(array t (3 *))) nil) (deftest array-t.9.6 (typep "abc" '(array t (* 3))) nil) (deftest array-t.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* *)))) t) (deftest array-t.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 *)))) t) (deftest array-t.9.9 (typep #2a((a b)(c d)(e f)) '(array t (2 *))) nil) (deftest array-t.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* 2)))) t) (deftest array-t.9.11 (typep #2a((a b)(c d)(e f)) '(array t (* 3))) nil) (deftest array-t.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 2)))) t) (deftest array-t.9.13 (typep #2a((a b)(c d)(e f)) '(array t (2 3))) nil) gcl-2.6.14/ansi-tests/probe-file.lsp0000644000175000017500000000244514360276512015636 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 5 20:46:29 2004 ;;;; Contains: Tests of PROBE-FILE (in-package :cl-test) (deftest probe-file.1 (probe-file #p"nonexistent") nil) (deftest probe-file.2 (let ((s (open #p"probe-file.lsp" :direction :input))) (prog1 (equalpt (truename #p"probe-file.lsp") (probe-file s)) (close s))) t) (deftest probe-file.3 (let ((s (open #p"probe-file.lsp" :direction :input))) (close s) (equalpt (truename #p"probe-file.lsp") (probe-file s))) t) (deftest probe-file.4 (equalpt (truename #p"probe-file.lsp") (probe-file "CLTEST:PROBE-FILE.LSP")) t) ;;; Specialized string tests (deftest probe-file.5 (do-special-strings (str "probe-file.lsp" nil) (let ((s (open str :direction :input))) (assert (equalpt (truename #p"probe-file.lsp") (probe-file s))) (close s))) nil) ;;; Error tests (deftest probe-file.error.1 (signals-error (probe-file) program-error) t) (deftest probe-file.error.2 (signals-error (probe-file #p"probe-file.lsp" nil) program-error) t) (deftest probe-file.error.3 (signals-error-always (probe-file (make-pathname :name :wild)) file-error) t t) (deftest probe-file.error.4 (signals-error-always (probe-file "CLTEST:*.FOO") file-error) t t) gcl-2.6.14/ansi-tests/string-downcase.lsp0000644000175000017500000000645514360276512016726 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 30 21:41:59 2002 ;;;; Contains: Tests for STRING-DOWNCASE (in-package :cl-test) (deftest string-downcase.1 (let ((s "A")) (values (string-downcase s) s)) "a" "A") (deftest string-downcase.2 (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (values (string-downcase s) s)) "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (deftest string-downcase.3 (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (values (string-downcase s) s)) "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest string-downcase.4 (string-downcase #\A) "a") (deftest string-downcase.5 (let ((sym '|A|)) (values (string-downcase sym) sym)) "a" |A|) (deftest string-downcase.6 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\A #\B #\C #\D #\E #\F)))) (values (string-downcase s) s)) "abcdef" "ABCDEF") (deftest string-downcase.7 (let ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) (values (string-downcase s) s)) "ab7def" "AB7DEF") ;; Tests with :start, :end (deftest string-downcase.8 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-downcase s :start i)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-downcase.9 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-downcase s :start i :end nil)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-downcase.10 (let ((s "ABCDE")) (values (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-invertcase (string-downcase s :start i :end j)))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE")) "ABCDE") (deftest string-downcase.order.1 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (string-downcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "AbcdEF" 3 1 2 3) (deftest string-downcase.order.2 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (string-downcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "AbcdEF" 3 1 2 3) ;;; Error cases (deftest string-downcase.error.1 (classify-error (string-downcase)) program-error) (deftest string-downcase.error.2 (classify-error (string-downcase (copy-seq "abc") :bad t)) program-error) (deftest string-downcase.error.3 (classify-error (string-downcase (copy-seq "abc") :start)) program-error) (deftest string-downcase.error.4 (classify-error (string-downcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-downcase.error.5 (classify-error (string-downcase (copy-seq "abc") :end)) program-error) (deftest string-downcase.error.6 (classify-error (string-downcase (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/nil.lsp0000644000175000017500000000116514360276512014372 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:32:46 2002 ;;;; Contains: Tests for NIL (in-package :cl-test) (deftest nil.1 (loop for x in *universe* thereis (subtypep (type-of x) nil)) nil) (deftest nil.2 (loop for x in *universe* unless (subtypep nil (type-of x)) collect (type-of x)) nil) (deftest nil.3 (not-mv (constantp nil)) nil) (deftest nil.4 (car nil) nil) (deftest nil.5 (cdr nil) nil) (deftest nil.6 (eval nil) nil) (deftest nil.7 (symbol-value nil) nil) (deftest nil.8 (eqt nil 'nil) t) ;;; NIL is, of course, present in many other files gcl-2.6.14/ansi-tests/packages-17.lsp0000644000175000017500000000621314360276512015612 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 19:20:29 1998 ;;;; Contains: Package test code, part 17 (in-package :cl-test) (declaim (optimize (safety 3))) (deftest do-symbols.1 (equalt (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x "B" all) (push x all))))) (list (find-symbol "BAR" "B") (find-symbol "FOO" "A"))) t) ;; ;; Test up some test packages ;; (defun collect-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-symbols (x pkg all) (push x all)))))) (defun collect-external-symbols (pkg) (remove-duplicates (sort-symbols (let ((all nil)) (do-external-symbols (x pkg all) (push x all)))))) (deftest do-symbols.2 (collect-symbols "DS1") (DS1:A DS1:B DS1::C DS1::D)) (deftest do-symbols.3 (collect-symbols "DS2") (DS2:A DS2::E DS2::F DS2:G DS2:H)) (deftest do-symbols.4 (collect-symbols "DS3") (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M)) (deftest do-symbols.5 (remove-duplicates (collect-symbols "DS4") :test #'(lambda (x y) (and (eqt x y) (not (eqt x 'DS4::B))))) (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) (deftest do-external-symbols.1 (collect-external-symbols "DS1") (DS1:A DS1:B)) (deftest do-external-symbols.2 (collect-external-symbols "DS2") (DS2:A DS2:G DS2:H)) (deftest do-external-symbols.3 (collect-external-symbols "DS3") (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K)) (deftest do-external-symbols.4 (collect-external-symbols "DS4") ()) (deftest do-external-symbols.5 (equalt (collect-external-symbols "KEYWORD") (collect-symbols "KEYWORD")) t) ;; Test that do-symbols, do-external-symbols work without ;; a return value (and that the default return value is nil) (deftest do-symbols.6 (do-symbols (s "DS1") (declare (ignore s)) t) nil) (deftest do-external-symbols.6 (do-external-symbols (s "DS1") (declare (ignore s)) t) nil) ;; Test that do-symbols, do-external-symbols work without ;; a package being specified (deftest do-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) (list (do-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B DS1::C DS1::D))) (deftest do-external-symbols.7 (let ((x nil) (*package* (find-package "DS1"))) (declare (special *package*)) (list (do-external-symbols (s) (push s x)) (sort-symbols x))) (nil (DS1:A DS1:B))) ;; Test that the tags work in the tagbody, ;; and that multiple statements work (deftest do-symbols.8 (handler-case (let ((x nil)) (list (do-symbols (s "DS1") (when (equalt (symbol-name s) "C") (go bar)) (push s x) (go foo) bar (push t x) foo) (sort-symbols x))) (error (c) c)) (NIL (DS1:A DS1:B DS1::D T))) (deftest do-external-symbols.8 (handler-case (let ((x nil)) (list (do-external-symbols (s "DS1") (when (equalt (symbol-name s) "A") (go bar)) (push s x) (go foo) bar (push t x) foo) (sort-symbols x))) (error (c) c)) (NIL (DS1:B T))) gcl-2.6.14/ansi-tests/with-output-to-string.lsp0000644000175000017500000000627214360276512020051 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:33:51 2004 ;;;; Contains: Tests of WITH-OUTPUT-TO-STRING (in-package :cl-test) (deftest with-output-to-string.1 (with-output-to-string (s)) "") (deftest with-output-to-string.2 (with-output-to-string (s) (write-char #\3 s)) "3") (deftest with-output-to-string.3 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character))) nil) (deftest with-output-to-string.4 :notes (:allow-nil-arrays :nil-vectors-are-strings) (let ((str (make-array 10 :fill-pointer 0 :element-type 'character))) (values (with-output-to-string (s str :element-type nil) (write-string "abcdef" s)) str)) "abcdef" "abcdef") (deftest with-output-to-string.5 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character)) (values))) (deftest with-output-to-string.6 (with-output-to-string (s (make-array 10 :fill-pointer 0 :element-type 'character)) (values 'a 'b 'c 'd)) a b c d) (deftest with-output-to-string.7 (with-output-to-string (s nil :element-type 'character) (write-char #\& s)) "&") (deftest with-output-to-string.8 (let ((str (with-output-to-string (s nil :element-type 'base-char) (write-char #\8 s)))) (assert (typep str 'simple-base-string)) str) "8") (deftest with-output-to-string.9 :notes (:allow-nil-arrays :nil-vectors-are-strings) (with-output-to-string (s nil :element-type nil)) "") (deftest with-output-to-string.10 (let* ((s1 (make-array 20 :element-type 'character :initial-element #\.)) (s2 (make-array 10 :element-type 'character :displaced-to s1 :displaced-index-offset 5 :fill-pointer 0))) (values (with-output-to-string (s s2) (write-string "0123456789" s)) s1 s2)) "0123456789" ".....0123456789....." "0123456789") (deftest with-output-to-string.11 (with-output-to-string (s) (declare (optimize safety))) "") (deftest with-output-to-string.12 (with-output-to-string (s) (declare (optimize safety)) (declare (optimize (speed 0)))) "") (deftest with-output-to-string.13 (with-output-to-string (s) (write-char #\0 s) (write-char #\4 s) (write-char #\9 s)) "049") (deftest with-output-to-string.14 (let* ((str1 (make-array '(256) :element-type 'base-char :fill-pointer 0)) (str2 (with-output-to-string (s nil :element-type 'base-char) (loop for i below 256 for c = (code-char i) when (typep c 'base-char) do (progn (write-char c s) (vector-push c str1)))))) (if (string= str1 str2) :good (list str1 str2))) :good) ;;; Free declaration scope (deftest with-output-to-string.15 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-output-to-string (s (return-from done x)) (declare (special x)))))) :good) (deftest with-output-to-string.16 (block done (let ((x :bad)) (declare (special x)) (let ((x :good) (str (make-array '(10) :element-type 'character :fill-pointer 0))) (with-output-to-string (s str :element-type (return-from done x)) (declare (special x)))))) :good) gcl-2.6.14/ansi-tests/cltest.system0000644000175000017500000000505314360276512015634 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Mar 27 09:57:28 1998 ;;;; Contains: MK portable system file for CL test suite ;;; NOTE!! This file is not being maintained right now. ;;; To run the test suite, load "gclload.lsp" (mk::defsystem "cltest" :source-pathname #.(directory-namestring *LOAD-TRUENAME*) :source-extension "lsp" :binary-pathname #.(mk::append-directories (directory-namestring *LOAD-TRUENAME*) "binary/") :binary-extension #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) #+ALLEGRO "fasl" #+(OR AKCL GCL) "o" #+CLISP "fas" #-(OR CMU ALLEGRO AKCL GCL CLISP) #.(pathname-type (compile-file-pathname "foo.lisp")) :initially-do (progn (load "rt/rt.system") (mk::compile-system "rt")) :components ("cl-test-package" (:subsystem "cl-test-code" :source-pathname "" :binary-pathname "" :depends-on ("cl-test-package") :components ( "ansi-aux" "universe" "cons-test-01" "cons-test-02" "cons-test-03" "cons-test-04" "cons-test-05" "cons-test-06" "cons-test-07" "cons-test-08" "cons-test-09" "cons-test-10" "cons-test-11" "cons-test-12" "cons-test-13" "cons-test-14" "cons-test-15" "cons-test-16" "cons-test-17" "cons-test-18" "cons-test-19" "cons-test-20" "cons-test-21" "cons-test-22" "cons-test-23" "cons-test-24" "types-and-class" "cl-symbols" "cases-14-1-arrays" "cases-14-1-list" "reader-test" "packages-00" "packages-01" "packages-02" "packages-03" "packages-04" "packages-05" "packages-06" "packages-07" "packages-08" "packages-09" "packages-10" "packages-11" "packages-12" "packages-13" "packages-14" "packages-15" "packages-16" "packages-17" "packages-18" "fill-strings" "make-sequence" "map" "map-into" "reduce" "count" "count-if" "count-if-not" "reverse" "nreverse" "sort" "find" "find-if" "find-if-not" "position" "search-aux" "search-list" "search-vector" "search-bitvector" "search-string" "mismatch" "replace" "substitute" "substitute-if" "substitute-if-not" "nsubstitute" "nsubstitute-if" "nsubstitute-if-not" "concatenate" "merge" "remove" ;; need to extend these tests "structure-00" "structures-01" "structures-02" )))) gcl-2.6.14/ansi-tests/bit-eqv.lsp0000644000175000017500000001426214360276512015161 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:07:23 2003 ;;;; Contains: Tests of BIT-EQV (in-package :cl-test) (deftest bit-eqv.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-eqv.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-eqv.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-eqv.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-eqv.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-eqv.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-eqv.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-eqv s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-eqv.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2)) a1 a2)) #*1001 #*0011 #*0101) (deftest bit-eqv.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-eqv a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1001 #*1001 #*0101 t) (deftest bit-eqv.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*0000)) (result (check-values (bit-eqv a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1001 #*0011 #*0101 #*1001 t) (deftest bit-eqv.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2 nil)) a1 a2)) #*1001 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-eqv.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-eqv a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-eqv a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1)) #2a((1 0)(0 1))) ;;; Adjustable arrays (deftest bit-eqv.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) ;;; Displaced arrays (deftest bit-eqv.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-eqv a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-eqv a1 a2 t))) (values a0 a1 a2 result)) #*10010011 #2a((1 0)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-eqv a1 a2 a3))) (values a0 a1 a2 result)) #*010100111001 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 1))) (deftest bit-eqv.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-eqv (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-eqv.error.1 (classify-error (bit-eqv)) program-error) (deftest bit-eqv.error.2 (classify-error (bit-eqv #*000)) program-error) (deftest bit-eqv.error.3 (classify-error (bit-eqv #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/subtypep-rational.lsp0000644000175000017500000001027114360276512017270 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:56:19 2003 ;;;; Contains: Tests for subtype relationships on rational types (in-package :cl-test) ;;; SUBTYPEP on rational types (deftest subtypep.rational.1 (loop for tp1 in '((rational 10) (rational 10 *) (rational 10 20) (rational (10) 20) (rational 10 (20)) (rational (10) (20)) (rational 10 1000000000000000) (rational (10)) (rational (10) *)) append (loop for tp2 in '(rational (rational) (rational *) (rational * *) (rational 10) (rational 10 *) (rational 0) (rational 0 *) (rational 19/2) (rational 19/2 *) (rational -1000000000000000) real (real) (real *) (real * *) (real 10) (real 10 *) (real 0) (real 0 *) (real 19/2) (real 19/2 *) (real -1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.2 (loop for tp1 in '((rational * 10) (rational 0 10) (rational 0 (10)) (rational (0) 10) (rational (0) (10)) (rational -1000000000000000 10) (rational * (10))) append (loop for tp2 in '(rational (rational) (rational *) (rational * *) (rational * 10) (rational * 21/2) (rational * 1000000000000000) real (real) (real *) (real * *) (real * 10) (real * 21/2) (real * 1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.3 (loop for tp1 in '((rational 10) (rational 10 *) (rational 10 20) (rational 10 (21)) (rational 10 1000000000000000)) append (loop for tp2 in '((rational 11) (rational 11 *) (rational (10)) (rational (10) *) (integer 10) (integer 10 *) (real 11) (real (10)) (real 11 *) (real (10) *) (rational * (20)) (rational * 19) (real * (20)) (real * 19)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.4 (loop for tp1 in '((rational * 10) (rational 0 10) (rational (0) 10) (rational -1000000000000000 10)) append (loop for tp2 in '((rational * 9) (rational * (10)) (integer * 10) (real * 9) (real * (10))) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.rational.5 (check-equivalence '(or (rational 0 0) (rational (0))) '(rational 0)) nil) (deftest subtypep.rational.6 (check-equivalence '(and (rational 0 10) (rational 5 15)) '(rational 5 10)) nil) (deftest subtypep.rational.7 (check-equivalence '(and (rational (0) 10) (rational 5 15)) '(rational 5 10)) nil) (deftest subtypep.rational.8 (check-equivalence '(and (rational 0 (10)) (rational 5 15)) '(rational 5 (10))) nil) (deftest subtypep.rational.9 (check-equivalence '(and (rational (0) (10)) (rational 5 15)) '(rational 5 (10))) nil) (deftest subtypep.rational.10 (check-equivalence '(and (rational 0 10) (rational (5) 15)) '(rational (5) 10)) nil) (deftest subtypep.rational.11 (check-equivalence '(and (rational 0 (10)) (rational (5) 15)) '(rational (5) (10))) nil) (deftest subtypep.rational.12 (check-equivalence '(and integer (rational 0 10) (not (rational (0) (10)))) '(member 0 10)) nil) (deftest subtypep.rational.13 (check-equivalence '(and integer (rational -1/2 1/2)) '(integer 0 0)) nil) (deftest subtypep.rational.14 (check-equivalence '(and integer (rational -1/2 1/2)) '(eql 0)) nil) (deftest subtypep.rational.15 (check-equivalence '(and integer (rational (-1/2) 1/2)) '(integer 0 0)) nil) (deftest subtypep.rational.16 (check-equivalence '(and integer (rational (-1/2) (1/2))) '(integer 0 0)) nil) (deftest subtypep.rational.17 (check-all-subtypep '(not (rational -1/2 1/2)) '(not (integer 0 0))) nil) (deftest subtypep.rational.18 (check-all-subtypep '(not (rational -1/2 1/2)) '(not (eql 0))) nil) gcl-2.6.14/ansi-tests/ldtest.lsp0000644000175000017500000000006514360276512015105 0ustar cammcamm(in-package :cl-test) (defun LOAD-TEST-FUN-3 () :foo)gcl-2.6.14/ansi-tests/call-arguments-limit.lsp0000644000175000017500000000123414360276512017637 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 22:39:25 2002 ;;;; Contains: Tests for CALL-ARGUMENTS-LIMIT (in-package :cl-test) (deftest call-arguments-limit.1 (notnot-mv (constantp 'call-arguments-limit)) t) (deftest call-arguments-limit.2 (notnot-mv (typep call-arguments-limit 'integer)) t) (deftest call-arguments-limit.3 (< call-arguments-limit 50) nil) (deftest call-arguments-limit.4 (let* ((m (min 65536 (1- call-arguments-limit))) (args (make-list m :initial-element 'a))) (equal (apply #'list args) args)) t) (deftest call-arguments-limit.5 (< call-arguments-limit lambda-parameters-limit) nil) gcl-2.6.14/ansi-tests/packages-02.lsp0000644000175000017500000000345514360276512015611 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:50:39 1998 ;;;; Contains: Package test code, aprt 02 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; find-package (deftest find-package.1 (let ((p (find-package "CL")) (p2 (find-package "COMMON-LISP"))) (and p p2 (eqt p p2))) t) (deftest find-package.2 (let ((p (find-package "CL-USER")) (p2 (find-package "COMMON-LISP-USER"))) (and p p2 (eqt p p2))) t) (deftest find-package.3 (let ((p (find-package "KEYWORD"))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.4 (let ((p (ignore-errors (find-package "A")))) (if (packagep p) t p)) t) (deftest find-package.5 (let ((p (ignore-errors (find-package #\A)))) (if (packagep p) t p)) t) (deftest find-package.6 (let ((p (ignore-errors (find-package "B")))) (if (packagep p) t p)) t) (deftest find-package.7 (let ((p (ignore-errors (find-package #\B)))) (if (packagep p) t p)) t) (deftest find-package.8 (let ((p (ignore-errors (find-package "Q"))) (p2 (ignore-errors (find-package "A")))) (and (packagep p) (packagep p2) (eqt p p2))) t) (deftest find-package.9 (let ((p (ignore-errors (find-package "A"))) (p2 (ignore-errors (find-package "B")))) (eqt p p2)) nil) (deftest find-package.10 (let ((p (ignore-errors (find-package #\Q))) (p2 (ignore-errors (find-package "Q")))) (and (packagep p) (eqt p p2))) t) (deftest find-package.11 (let* ((cl (find-package "CL")) (cl2 (find-package cl))) (and (packagep cl) (eqt cl cl2))) t) (deftest find-package.error.1 (classify-error (find-package)) program-error) (deftest find-package.error.2 (classify-error (find-package "CL" nil)) program-error) gcl-2.6.14/ansi-tests/packages-03.lsp0000644000175000017500000001167114360276512015611 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:51:26 1998 ;;;; Contains: Package test code, part 03 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list-all-packages ;; list-all-packages returns a list (deftest list-all-packages.1 (numberp (ignore-errors (list-length (list-all-packages)))) t) ;; The required packages are present (deftest list-all-packages.2 (subsetp (list (find-package "CL") (find-package "CL-USER") (find-package "KEYWORD") (find-package "A") (find-package "RT") (find-package "CL-TEST") (find-package "B")) (list-all-packages)) t) ;; The list returned has only packages in it (deftest list-all-packages.3 (notnot-mv (every #'packagep (list-all-packages))) t) ;; It returns a list of the same packages each time it is called (deftest list-all-packages.4 (let ((p1 (list-all-packages)) (p2 (list-all-packages))) (and (subsetp p1 p2) (subsetp p2 p1))) t) (deftest list-all-packages.error.1 (classify-error (list-all-packages nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-name (deftest package-name.1 (ignore-errors (package-name "A")) "A") (deftest package-name.2 (ignore-errors (package-name #\A)) "A") (deftest package-name.3 (ignore-errors (package-name "Q")) "A") (deftest package-name.4 (ignore-errors (package-name #\Q)) "A") (deftest package-name.5 (notnot-mv (member (classify-error (package-name "NOT-THERE")) '(type-error package-error))) t) (deftest package-name.6 (notnot-mv (member (classify-error (package-name #\*)) '(type-error package-error))) t) (deftest package-name.6a (notnot-mv (member (classify-error (locally (package-name #\*) t)) '(type-error package-error))) t) (deftest package-name.7 (package-name "CL") #.(string '#:common-lisp)) (deftest package-name.8 (package-name "COMMON-LISP") #.(string '#:common-lisp)) (deftest package-name.9 (package-name "COMMON-LISP-USER") #.(string '#:common-lisp-user)) (deftest package-name.10 (package-name "CL-USER") #.(string '#:common-lisp-user)) (deftest package-name.11 (package-name "KEYWORD") #.(string '#:keyword)) (deftest package-name.12 (package-name (find-package "CL")) #.(string '#:common-lisp)) (deftest package-name.13 (let* ((p (make-package "TEMP1")) (pname1 (package-name p))) (rename-package "TEMP1" "TEMP2") (let ((pname2 (package-name p))) (safely-delete-package p) (list pname1 pname2 (package-name p)))) ("TEMP1" "TEMP2" nil)) ;; (find-package (package-name p)) == p for any package p (deftest package-name.14 (loop for p in (list-all-packages) count (not (let ((name (package-name p))) (and (stringp name) (eqt (find-package name) p))))) 0) ;; package-name applied to a package's name ;; should return an equal string (deftest package-name.15 (loop for p in (list-all-packages) count (not (equal (package-name p) (ignore-errors (package-name (package-name p)))))) 0) (deftest package-name.error.1 (classify-error (package-name)) program-error) (deftest package-name.error.2 (classify-error (package-name "CL" nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-nicknames (deftest package-nicknames.1 (ignore-errors (package-nicknames "A")) ("Q")) (deftest package-nicknames.2 (ignore-errors (package-nicknames #\A)) ("Q")) (deftest package-nicknames.3 (ignore-errors (package-nicknames ':|A|)) ("Q")) (deftest package-nicknames.4 (ignore-errors (package-nicknames "B")) nil) (deftest package-nicknames.5 (ignore-errors (package-nicknames #\B)) nil) (deftest package-nicknames.6 (ignore-errors (package-nicknames '#:|B|)) nil) (deftest package-nicknames.7 (ignore-errors (subsetp '(#.(string '#:cl)) (package-nicknames "COMMON-LISP") :test #'string=)) t) (deftest package-nicknames.8 (ignore-errors (notnot (subsetp '(#.(string '#:cl-user)) (package-nicknames "COMMON-LISP-USER") :test #'string=))) t) (deftest package-nicknames.9 (classify-error (package-nicknames 10)) type-error) (deftest package-nicknames.9a (classify-error (locally (package-nicknames 10) t)) type-error) (deftest package-nicknames.10 (ignore-errors (package-nicknames (find-package "A"))) ("Q")) (deftest package-nicknames.11 (notnot-mv (member (classify-error (package-nicknames "NOT-A-PACKAGE-NAME")) '(type-error package-error))) t) ;; (find-package n) == p for each n in (package-nicknames p), ;; for any package p (deftest package-nicknames.12 (loop for p in (list-all-packages) sum (loop for nk in (package-nicknames p) count (not (and (stringp nk) (eqt p (find-package nk)))))) 0) (deftest package-nicknames.error.1 (classify-error (package-nicknames)) program-error) (deftest package-nicknames.error.2 (classify-error (package-nicknames "CL" nil)) program-error) gcl-2.6.14/ansi-tests/ansi-aux.lsp0000644000175000017500000014323014360276512015335 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 17:10:18 1998 ;;;; Contains: Aux. functions for CL-TEST (in-package :cl-test) (declaim (optimize (safety 3))) ;;; A function for coercing truth values to BOOLEAN (defun notnot (x) (not (not x))) (defmacro notnot-mv (form) `(notnot-mv-fn (multiple-value-list ,form))) (defun notnot-mv-fn (results) (if (null results) (values) (apply #'values (not (not (first results))) (rest results)))) (defmacro not-mv (form) `(not-mv-fn (multiple-value-list ,form))) (defun not-mv-fn (results) (if (null results) (values) (apply #'values (not (first results)) (rest results)))) ;;; Macro to check that a function is returning a specified number of values ;;; (defaults to 1) (defmacro check-values (form &optional (num 1)) (let ((v (gensym)) (n (gensym))) `(let ((,v (multiple-value-list ,form)) (,n ,num)) (check-values-length ,v ,n ',form) (car ,v)))) (defun check-values-length (results expected-number form) (declare (type fixnum expected-number)) (let ((n expected-number)) (declare (type fixnum n)) (dolist (e results) (declare (ignore e)) (decf n)) (unless (= n 0) (error "Expected ~A results from ~A, got ~A results instead.~%~ Results: ~A~%" expected-number form n results)))) ;;; Do multiple-value-bind, but check # of arguments (defmacro multiple-value-bind* ((&rest vars) form &body body) (let ((len (length vars)) (v (gensym))) `(let ((,v (multiple-value-list ,form))) (check-values-length ,v ,len ',form) (destructuring-bind ,vars ,v ,@body)))) ;;; Comparison functions that are like various builtins, ;;; but are guaranteed to return T for true. (defun eqt (x y) "Like EQ, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) (defun eqlt (x y) "Like EQL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) (defun equalt (x y) "Like EQUAL, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) (defun equalpt (x y) "Like EQUALP, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) (defun equalpt-or-report (x y) "Like EQUALPT, but return either T or a list of the arguments." (or (equalpt x y) (list x y))) (defun =t (x &rest args) "Like =, but guaranteed to return T for true." (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) (defun make-int-list (n) (loop for i from 0 below n collect i)) (defun make-int-array (n &optional (fn #'make-array)) (let ((a (funcall fn n))) (loop for i from 0 below n do (setf (aref a i) i)) a)) ;;; Return true if A1 and A2 are arrays with the same rank ;;; and dimensions whose elements are EQUAL (defun equal-array (a1 a2) (and (typep a1 'array) (typep a2 'array) (= (array-rank a1) (array-rank a2)) (if (= (array-rank a1) 0) (equal (aref a1) (aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (if (= (array-rank a1) 1) (let ((as (first ad))) (loop for i from 0 below as always (equal (aref a1 i) (aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as always (equal (row-major-aref a1 i) (row-major-aref a2 i))))))))))) ;;; *universe* is defined elsewhere -- it is a list of various ;;; lisp objects used when stimulating things in various tests. (declaim (special *universe*)) ;;; The function EMPIRICAL-SUBTYPEP checks two types ;;; for subtypeness, first using SUBTYPEP*, then (if that ;;; fails) empirically against all the elements of *universe*, ;;; checking if all that are in the first are also in the second. ;;; Return T if this is the case, NIL otherwise. This will ;;; always return T if type1 is truly a subtype of type2, ;;; but may return T even if this is not the case. (defun empirical-subtypep (type1 type2) (multiple-value-bind (sub good) (subtypep* type1 type2) (if good sub (loop for e in *universe* always (or (not (typep e type1)) (typep e type2)))))) ;;; Check that the subtype relationships implied ;;; by disjointness are not contradicted. Return NIL ;;; if ok, or a list of error messages if not. ;;; Assumes the types are nonempty. (defun check-disjointness (type1 type2) (append (check-subtypep type1 type2 nil) (check-subtypep type2 type1 nil) (check-subtypep type1 `(not ,type2) t) (check-subtypep type2 `(not ,type1) t) (check-subtypep `(and ,type1 ,type2) nil t) (check-subtypep `(and ,type2 ,type1) nil t) (check-subtypep `(and ,type1 (not ,type2)) type1 t) (check-subtypep `(and (not ,type2) ,type1) type1 t) (check-subtypep `(and ,type2 (not ,type1)) type2 t) (check-subtypep `(and (not ,type1) ,type2) type2 t) ;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t) ;;; (check-subtypep type1 `(or (not ,type2) ,type1) t) ;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t) ;;; (check-subtypep type2 `(or (not ,type1) ,type2) t) (check-subtypep t `(or (not ,type1) (not ,type2)) t) (check-subtypep t `(or (not ,type2) (not ,type1)) t) )) (defun check-equivalence (type1 type2) (append (check-subtypep type1 type2 t) (check-subtypep type2 type1 t) (check-subtypep `(not ,type1) `(not ,type2) t) (check-subtypep `(not ,type2) `(not ,type1) t) (check-subtypep `(and ,type1 (not ,type2)) nil t) (check-subtypep `(and ,type2 (not ,type1)) nil t) (check-subtypep `(and (not ,type2) ,type1) nil t) (check-subtypep `(and (not ,type1) ,type2) nil t) (check-subtypep t `(or ,type1 (not ,type2)) t) (check-subtypep t `(or ,type2 (not ,type1)) t) (check-subtypep t `(or (not ,type2) ,type1) t) (check-subtypep t `(or (not ,type1) ,type2) t))) (defun check-all-subtypep (type1 type2) (append (check-subtypep type1 type2 t) (check-subtypep `(not ,type2) `(not ,type1) t) (check-subtypep `(and ,type1 (not ,type2)) nil t) (check-subtypep t `(or (not ,type1) ,type2) t))) (defun check-all-not-subtypep (type1 type2) (append (check-subtypep type1 type2 nil) (check-subtypep `(not ,type2) `(not ,type1) nil))) (defun check-subtypep (type1 type2 is-sub &optional should-be-valid) (multiple-value-bind (sub valid) (subtypep type1 type2) (unless (constantp type1) (setq type1 (list 'quote type1))) (unless (constantp type2) (setq type2 (list 'quote type2))) (if (or (and valid sub (not is-sub)) (and valid (not sub) is-sub) (and (not valid) should-be-valid)) `(((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid)) nil))) (defun check-type-predicate (P TYPE) "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) by applying both to all elements of *UNIVERSE*. Print message when a mismatch is found, and return number of mistakes." (loop for x in *universe* count (block failed (let ((p1 (handler-case (funcall P x) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case (typep x TYPE) (error () (format t "(TYPEP ~S '~S) failed~%" x TYPE) (return-from failed t))))) (when (or (and p1 (not p2)) (and (not p1) p2)) (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" P x p1 x TYPE p2) t))))) (defun check-predicate (predicate &optional guard (universe *universe*)) "Return all elements of UNIVERSE for which the guard (if present) is false and for which PREDICATE is false." (remove-if #'(lambda (e) (or (and guard (funcall guard e)) (funcall predicate e))) universe)) (declaim (special *catch-error-type*)) (defun catch-continue-debugger-hook (condition dbh) "Function that when used as *debugger-hook*, causes continuable errors to be continued without user intervention." (declare (ignore dbh)) (let ((r (find-restart 'continue condition))) (cond ((and *catch-error-type* (not (typep condition *catch-error-type*))) (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) (cond (r (format t "Its continue restart is ~S~%" r)) (t (format t "It has no continue restart~%"))) (throw 'continue-failed nil)) (r (invoke-restart r)) (t (throw 'continue-failed nil))))) #| (defun safe (fn &rest args) "Apply fn to args, trapping errors. Convert type-errors to the symbol type-error." (declare (optimize (safety 3))) (handler-case (apply fn args) (type-error () 'type-error) (error (c) c))) |# ;;; Use the next macro in place of SAFE (defmacro catch-type-error (form) "Evaluate form in safe mode, returning its value if there is no error. If an error does occur, return type-error on TYPE-ERRORs, or the error condition itself on other errors." `(locally (declare (optimize (safety 3))) (handler-case ,form (type-error () 'type-error) (error (c) c)))) (defmacro classify-error* (form) "Evaluate form in safe mode, returning its value if there is no error. If an error does occur, return a symbol classify the error, or allow the condition to go uncaught if it cannot be classified." `(locally (declare (optimize (safety 3))) (handler-case ,form (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) (type-error () 'type-error) (control-error () 'control-error) (stream-error () 'stream-error) (reader-error () 'reader-error) (file-error () 'file-error) (control-error () 'control-error) (cell-error () 'cell-error) (error () 'error) ))) (defun classify-error** (form) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (classify-error* (if regression-test::*compile-tests* (funcall (compile nil `(lambda () (declare (optimize (safety 3))) ,form))) (eval form)) ))) (defmacro classify-error (form) `(classify-error** ',form)) (defun sequencep (x) (typep x 'sequence)) ;;; (defun typef (type) #'(lambda (x) (typep x type))) (defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) `(handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list ,(cond (inline form) (regression-test::*compile-tests* `(funcall (compile nil '(lambda () (declare (optimize (safety ,safety))) ,form)))) (t `(eval ',form))))) (,error-name (c) (cond ,@(case error-name (type-error `(((typep (type-error-datum c) (type-error-expected-type c)) (values nil (list (list 'typep (list 'quote (type-error-datum c)) (list 'quote (type-error-expected-type c))) "==> true"))))) ((undefined-function unbound-variable) (and name-p `(((not (eq (cell-error-name c) ',name)) (values nil (list 'cell-error-name "==>" (cell-error-name c))))))) ((stream-error end-of-file reader-error) `(((not (streamp (stream-error-stream c))) (values nil (list 'stream-error-stream "==>" (stream-error-stream c)))))) (file-error `(((not (pathnamep (pathname (file-error-pathname c)))) (values nil (list 'file-error-pathname "==>" (file-error-pathname c)))))) (t nil)) (t (printable-p c))))))) (defmacro signals-error-always (form error-name) `(values (signals-error ,form ,error-name) (signals-error ,form ,error-name :safety 0))) (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) (let ((lambda-form `(lambda (,var) (declare (optimize (safety ,safety))) ,form))) `(let ((,var ,datum-form)) (declare (optimize safety)) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) ; (proclaim '(optimize (safety 3))) (handler-case (apply #'values nil (multiple-value-list (funcall ,(cond (inline `(function ,lambda-form)) (regression-test::*compile-tests* `(compile nil ',lambda-form)) (t `(eval ',lambda-form))) ,var))) (type-error (c) (let ((datum (type-error-datum c)) (expected-type (type-error-expected-type c))) (cond ((not (eql ,var datum)) (list :datum-mismatch ,var datum)) ((typep datum expected-type) (list :is-typep datum expected-type)) (t (printable-p c)))))))))) (declaim (special *mini-universe*)) (defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) "Check that for all elements in some set, either guard-fn is true or pred-fn signals a type error." (let (val) (loop for e in universe unless (or (funcall guard-fn e) (equal (setf val (multiple-value-list (signals-type-error x e (funcall pred-fn x) :inline t))) '(t))) collect (list e val)))) (defmacro check-type-error (&body args) `(locally (declare (optimize safety)) (check-type-error* ,@args))) (defun printable-p (obj) "Returns T iff obj can be printed to a string." (with-standard-io-syntax (let ((*print-readably* nil) (*print-escape* nil)) (declare (optimize safety)) (handler-case (and (stringp (write-to-string obj)) t) (condition (c) (declare (ignore c)) nil))))) (defun make-special-string (string &key fill adjust displace base) (let* ((len (length string)) (len2 (if fill (+ len 4) len)) (etype (if base 'base-char 'character))) (if displace (let ((s0 (make-array (+ len2 5) :initial-contents (concatenate 'string (make-string 2 :initial-element #\X) string (make-string (if fill 7 3) :initial-element #\Y)) :element-type etype))) (make-array len2 :element-type etype :adjustable adjust :fill-pointer (if fill len nil) :displaced-to s0 :displaced-index-offset 2)) (make-array len2 :element-type etype :initial-contents (if fill (concatenate 'string string "ZZZZ") string) :fill-pointer (if fill len nil) :adjustable adjust)))) (defmacro do-special-strings ((var string-form &optional ret-form) &body forms) (let ((string (gensym)) (fill (gensym "FILL")) (adjust (gensym "ADJUST")) (base (gensym "BASE")) (displace (gensym "DISPLACE"))) `(let ((,string ,string-form)) (dolist (,fill '(nil t) ,ret-form) (dolist (,adjust '(nil t)) (dolist (,base '(nil t)) (dolist (,displace '(nil t)) (let ((,var (make-special-string ,string :fill ,fill :adjust ,adjust :base ,base :displace ,displace))) ,@forms)))))))) ;;; A scaffold is a structure that is used to remember the object ;;; identities of the cons cells in a (noncircular) data structure. ;;; This lets us check if the data structure has been changed by ;;; an operation. ;;; (defstruct scaffold node car cdr) (defun make-scaffold-copy (x) "Make a tree that will be used to check if a tree has been changed." (if (consp x) (make-scaffold :node x :car (make-scaffold-copy (car x)) :cdr (make-scaffold-copy (cdr x))) (make-scaffold :node x :car nil :cdr nil))) (defun check-scaffold-copy (x xcopy) "Return t if xcopy were produced from x by make-scaffold-copy, and none of the cons cells in the tree rooted at x have been changed." (and (eq x (scaffold-node xcopy)) (or (not (consp x)) (and (check-scaffold-copy (car x) (scaffold-car xcopy)) (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) (defun create-c*r-test (n) (cond ((<= n 0) 'none) (t (cons (create-c*r-test (1- n)) (create-c*r-test (1- n)))))) (defun nth-1-body (x) (loop for e in x and i from 0 count (not (eqt e (nth i x))))) ;;; ;;; The function SUBTYPEP should return two generalized booleans. ;;; This auxiliary function returns booleans instead ;;; (which makes it easier to write tests). ;;; (defun subtypep* (type1 type2) (apply #'values (mapcar #'notnot (multiple-value-list (subtypep type1 type2))))) (defun subtypep*-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) (or (not (second results)) (notnot (first results)))))) (defun subtypep*-not-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) (or (not (second results)) (not (first results)))))) ;;; (eval-when (load eval compile) ;;; (unless (fboundp 'complement) ;;; (defun complement (fn) ;;; #'(lambda (&rest args) (not (apply fn args)))))) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) (defun evendigitp (c) (notnot (find c "02468"))) (defun odddigitp (c) (notnot (find c "13579"))) (defun nextdigit (c) (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) (defun is-eq-p (x) #'(lambda (y) (eqt x y))) (defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) (defun is-eql-p (x) #'(lambda (y) (eqlt x y))) (defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) (defun onep (x) (eql x 1)) (defun char-invertcase (c) (if (upper-case-p c) (char-downcase c) (char-upcase c))) (defun string-invertcase (s) (map 'string #'char-invertcase s)) (defun symbol< (x &rest args) (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) (defun random-from-seq (seq) "Generate a random member of a sequence." (let ((len (length seq))) (assert (> len 0)) (elt seq (random len)))) (defmacro random-case (&body cases) (let ((len (length cases))) (assert (> len 0)) `(case (random ,len) ,@(loop for i from 0 for e in cases collect `(,i ,e)) (t (error "Can't happen?! (in random-case~%"))))) (defun coin (&optional (n 2)) "Flip an n-sided coin." (eql (random n) 0)) ;;; Randomly permute a sequence (defun random-permute (seq) (setq seq (copy-seq seq)) (let ((len (length seq))) (loop for i from len downto 2 do (let ((r (random i))) (rotatef (elt seq r) (elt seq (1- i)))))) seq) (defun make-list-expr (args) "Build an expression for computing (LIST . args), but that evades CALL-ARGUMENTS-LIMIT." (if (cddddr args) (list 'list* (first args) (second args) (third args) (fourth args) (make-list-expr (cddddr args))) (cons 'list args))) (defparameter +standard-chars+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ ") (defparameter +base-chars+ #.(concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) (defparameter +num-base-chars+ (length +base-chars+)) (defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) (defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) (defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) (defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) (defparameter +digit-chars+ "0123456789") (defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") (defparameter +code-chars+ (coerce (loop for i from 0 below 256 for c = (code-char i) when c collect c) 'string)) (defparameter +rev-code-chars+ (reverse +code-chars+)) ;;; Used in checking for continuable errors (defun has-non-abort-restart (c) (throw 'handled (if (position 'abort (compute-restarts c) :key #'restart-name :test-not #'eq) 'success 'fail))) (defmacro handle-non-abort-restart (&body body) `(catch 'handled (handler-bind ((error #'has-non-abort-restart)) ,@body))) ;;; used in elt.lsp (defun elt-v-6-body () (let ((x (make-int-list 1000))) (let ((a (make-array '(1000) :initial-contents x))) (loop for i from 0 to 999 do (unless (eql i (elt a i)) (return nil)) finally (return t))))) (defun make-adj-array (n &key initial-contents) (if initial-contents (make-array n :adjustable t :initial-contents initial-contents) (make-array n :adjustable t))) ;;; used in elt.lsp (defun elt-adj-array-6-body () (let ((x (make-int-list 1000))) (let ((a (make-adj-array '(1000) :initial-contents x))) (loop for i from 0 to 999 do (unless (eql i (elt a i)) (return nil)) finally (return t))))) (defparameter *displaced* (make-int-array 100000)) (defun make-displaced-array (n displacement) (make-array n :displaced-to *displaced* :displaced-index-offset displacement)) ;;; used in fill.lsp (defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) :initial-contents '(1 2 3 4 5))) (b (apply #'fill a fill-args))) (values (eqt a b) (map 'list #'identity a)))) ;;; used in fill-strings.lsp (defun array-string-fill-test-fn (a &rest fill-args) (setq a (copy-seq a)) (let ((b (apply #'fill a fill-args))) (values (eqt a b) b))) ;;; From types-and-class.lsp (defparameter +float-types+ '(long-float double-float short-float single-float)) (defparameter *subtype-table* (let ((table '( (null symbol) (symbol t) (boolean symbol) (standard-object t) (function t) (compiled-function function) (generic-function function) (standard-generic-function generic-function) (class standard-object) (built-in-class class) (structure-class class) (standard-class class) (method standard-object) (standard-method method) (structure-object t) (method-combination t) (condition t) (serious-condition condition) (error serious-condition) (type-error error) (simple-type-error type-error) (simple-condition condition) (simple-type-error simple-condition) (parse-error error) (hash-table t) (cell-error error) (unbound-slot cell-error) (warning condition) (style-warning warning) (storage-condition serious-condition) (simple-warning warning) (simple-warning simple-condition) (keyword symbol) (unbound-variable cell-error) (control-error error) (program-error error) (undefined-function cell-error) (package t) (package-error error) (random-state t) (number t) (real number) (complex number) (float real) (short-float float) (single-float float) (double-float float) (long-float float) (rational real) (integer rational) (ratio rational) (signed-byte integer) (integer signed-byte) (unsigned-byte signed-byte) (bit unsigned-byte) (fixnum integer) (bignum integer) (bit fixnum) (arithmetic-error error) (division-by-zero arithmetic-error) (floating-point-invalid-operation arithmetic-error) (floating-point-inexact arithmetic-error) (floating-point-overflow arithmetic-error) (floating-point-underflow arithmetic-error) (character t) (base-char character) (standard-char base-char) (extended-char character) (sequence t) (list sequence) (null list) (null boolean) (cons list) (array t) (simple-array array) (vector sequence) (vector array) (string vector) (bit-vector vector) (simple-vector vector) (simple-vector simple-array) (simple-bit-vector bit-vector) (simple-bit-vector simple-array) (base-string string) (simple-string string) (simple-string simple-array) (simple-base-string base-string) (simple-base-string simple-string) (pathname t) (logical-pathname pathname) (file-error error) (stream t) (broadcast-stream stream) (concatenated-stream stream) (echo-stream stream) (file-stream stream) (string-stream stream) (synonym-stream stream) (two-way-stream stream) (stream-error error) (end-of-file stream-error) (print-not-readable error) (readtable t) (reader-error parse-error) (reader-error stream-error) ))) (when (subtypep* 'character 'base-char) (setq table (append '((character base-char) (string base-string) (simple-string simple-base-string)) table))) table)) (defparameter *disjoint-types-list* '(cons symbol array number character hash-table function readtable package pathname stream random-state condition restart)) (defparameter *disjoint-types-list2* `((cons (cons t t) (cons t (cons t t)) (eql (nil))) (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) (array vector simple-array simple-vector string simple-string base-string simple-base-string (eql #())) (character base-char standard-char (eql #\a) ,@(if (subtypep 'character 'base-char) nil (list 'extended-char))) (function compiled-function generic-function standard-generic-function (eql ,#'car)) (package (eql ,(find-package "COMMON-LISP"))) (pathname logical-pathname (eql #p"")) (stream broadcast-stream concatenated-stream echo-stream file-stream string-stream synonym-stream two-way-stream) (number real complex float integer rational ratio fixnum bit (integer 0 100) (float 0.0 100.0) (integer 0 *) (rational 0 *) (mod 10) (eql 0) ,@(and (not (subtypep 'bignum nil)) (list 'bignum))) (random-state) ,*condition-types* (restart) (readtable))) (defparameter *types-list3* (reduce #'append *disjoint-types-list2* :from-end t)) (defun trim-list (list n) (let ((len (length list))) (if (<= len n) list (append (subseq list 0 n) (format nil "And ~A more omitted." (- len n)))))) (defun is-t-or-nil (e) (or (eqt e t) (eqt e nil))) (defun is-builtin-class (type) (when (symbolp type) (setq type (find-class type nil))) (typep type 'built-in-class)) (defun classes-are-disjoint (c1 c2) "If either c1 or c2 is a builtin class or the name of a builtin class, then check for disjointness. Return a non-NIL list of failed subtypep relationships, if any." (and (or (is-builtin-class c1) (is-builtin-class c2)) (check-disjointness c1 c2))) (declaim (special *subtype-table*)) (defun types.6-body () (loop for p in *subtype-table* for tp = (car p) append (and (not (member tp '(sequence cons list t))) (let ((message (check-subtypep tp 'atom t t))) (if message (list message)))))) (defparameter *type-list* nil) (defparameter *supertype-table* nil) (declaim (special *subtype-table*)) (defun types.9-body () (let ((tp-list (append '(keyword atom list) (loop for p in *subtype-table* collect (car p)))) (result-list)) (setf tp-list (remove-duplicates tp-list)) ;; TP-LIST is now a list of unique CL type names ;; Store it in *TYPE-LIST* so we can inspect it later if this test ;; fails. The variable is also used in test TYPES.9A (setf *type-list* tp-list) ;; Compute all pairwise SUBTYPEP relationships among ;; the elements of *TYPE-LIST*. (let ((subs (make-hash-table :test #'eq)) (sups (make-hash-table :test #'eq))) (loop for x in tp-list do (loop for y in tp-list do (multiple-value-bind (result good) (subtypep* x y) (declare (ignore good)) (when result (pushnew x (gethash y subs)) (pushnew y (gethash x sups)))))) ;; Store the supertype relations for later inspection ;; and use in test TYPES.9A (setf *supertype-table* sups) ;; Check that the relation we just computed is transitive. ;; Return a list of triples on which transitivity fails. (loop for x in tp-list do (let ((sub-list (gethash x subs)) (sup-list (gethash x sups))) (loop for t1 in sub-list do (loop for t2 in sup-list do (multiple-value-bind (result good) (subtypep* t1 t2) (when (and good (not result)) (pushnew (list t1 x t2) result-list :test #'equal))))))) result-list))) ;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) ;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) ;;; (and where SUBTYPEP succeeds in each case, returning true as its ;;; second return value.) (defun types.9a-body () (cond ((not (and *type-list* *supertype-table*)) (format nil "Run test type.9 first~%") nil) (t (loop for tp in *type-list* sum (let ((sups (gethash tp *supertype-table*))) (loop for x in *universe* sum (handler-case (cond ((not (typep x tp)) 0) (t (loop for tp2 in sups count (handler-case (and (not (typep x tp2)) (progn (format t "Found element of ~S not in ~S: ~S~%" tp tp2 x) t)) (condition (c) (format t "Error ~S occurred: ~S~%" c tp2) t))))) (condition (c) (format t "Error ~S occurred: ~S~%" c tp) 1)))))))) (defun even-size-p (a) (some #'evenp (array-dimensions a))) (defun check-cons-copy (x y) "Check that the tree x is a copy of the tree y, returning t if it is, nil if not." (cond ((consp x) (and (consp y) (not (eqt x y)) (check-cons-copy (car x) (car y)) (check-cons-copy (cdr x) (cdr y)))) ((eqt x y) t) (t nil))) (defun check-sublis (a al &key (key 'no-key) test test-not) "Apply sublis al a with various keys. Check that the arguments are not themselves changed. Return nil if the arguments do get changed." (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((acopy (make-scaffold-copy a)) (alcopy (make-scaffold-copy al))) (let ((as (apply #'sublis al a `(,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)) ,@(unless (eqt key 'no-key) `(:key ,key)))))) (and (check-scaffold-copy a acopy) (check-scaffold-copy al alcopy) as)))) (defun check-nsublis (a al &key (key 'no-key) test test-not) "Apply nsublis al a, copying these arguments first." (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((as (apply #'sublis (copy-tree al) (copy-tree a) `(,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)) ,@(unless (eqt key 'no-key) `(:key ,key)))))) as)) (defun check-subst (new old tree &key (key 'no-key) test test-not) "Call subst new old tree, with keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf old (copy-tree old)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (oldcopy (make-scaffold-copy old)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst new old tree `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy old oldcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-subst-if (new pred tree &key (key 'no-key)) "Call subst-if new pred tree, with various keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (predcopy (make-scaffold-copy pred)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst-if new pred tree (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy pred predcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-subst-if-not (new pred tree &key (key 'no-key)) "Call subst-if-not new pred tree, with various keyword arguments if present. Check that the arguments are not changed." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) (predcopy (make-scaffold-copy pred)) (treecopy (make-scaffold-copy tree))) (let ((result (apply #'subst-if-not new pred tree (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) (check-scaffold-copy pred predcopy) (check-scaffold-copy tree treecopy) result)))) (defun check-nsubst (new old tree &key (key 'no-key) test test-not) "Call nsubst new old tree, with keyword arguments if present." (setf new (copy-tree new)) (setf old (copy-tree old)) (setf tree (copy-tree tree)) (apply #'nsubst new old tree `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun check-nsubst-if (new pred tree &key (key 'no-key)) "Call nsubst-if new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if new pred tree (unless (eqt key 'no-key) `(:key ,key)))) (defun check-nsubst-if-not (new pred tree &key (key 'no-key)) "Call nsubst-if-not new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if-not new pred tree (unless (eqt key 'no-key) `(:key ,key)))) (defun check-copy-list-copy (x y) "Check that y is a copy of the list x." (if (consp x) (and (consp y) (not (eqt x y)) (eqt (car x) (car y)) (check-copy-list-copy (cdr x) (cdr y))) (and (eqt x y) t))) (defun check-copy-list (x) "Apply copy-list, checking that it properly copies, and checking that it does not change its argument." (let ((xcopy (make-scaffold-copy x))) (let ((y (copy-list x))) (and (check-scaffold-copy x xcopy) (check-copy-list-copy x y) y)))) (defun append-6-body () (let* ((cal (min 2048 call-arguments-limit)) (step (max 1 (floor (/ cal) 64)))) (loop for n from 0 below cal by step count (not (equal (apply #'append (loop for i from 1 to n collect '(a))) (make-list n :initial-element 'a)))))) (defun is-intersection (x y z) "Check that z is the intersection of x and y." (and (listp x) (listp y) (listp z) (loop for e in x always (or (not (member e y)) (member e z))) (loop for e in y always (or (not (member e x)) (member e z))) (loop for e in z always (and (member e x) (member e y))) t)) (defun shuffle (x) (cond ((null x) nil) ((null (cdr x)) x) (t (multiple-value-bind (y z) (split-list x) (append (shuffle y) (shuffle z)))))) (defun split-list (x) (cond ((null x) (values nil nil)) ((null (cdr x)) (values x nil)) (t (multiple-value-bind (y z) (split-list (cddr x)) (values (cons (car x) y) (cons (cadr x) z)))))) (defun intersection-12-body (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (intersection x y))) (let ((is-good (is-intersection x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nintersection-with-check (x y &key test) (let ((ycopy (make-scaffold-copy y))) (let ((result (if test (nintersection x y :test test) (nintersection x y)))) (if (check-scaffold-copy y ycopy) result 'failed)))) (defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state t))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nintersection-with-check (copy-list x) y))) (when (eqt z 'failed) (return (values x y z))) (let ((is-good (is-intersection x y z))) (unless is-good (return (values x y z))))))) nil)) (defun union-with-check (x y &key test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (cond (test (union x y :test test)) (test-not (union x y :test-not test-not)) (t (union x y))))) (if (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result 'failed)))) (defun union-with-check-and-key (x y key &key test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (cond (test (union x y :key key :test test)) (test-not (union x y :key key :test-not test-not)) (t (union x y :key key))))) (if (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result 'failed)))) (defun check-union (x y z) (and (listp x) (listp y) (listp z) (loop for e in z always (or (member e x) (member e y))) (loop for e in x always (member e z)) (loop for e in y always (member e z)) t)) (defun do-random-unions (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (union x y))) (let ((is-good (check-union x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nunion-with-copy (x y &key test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (cond (test (nunion x y :test test)) (test-not (nunion x y :test-not test-not)) (t (nunion x y)))) (defun nunion-with-copy-and-key (x y key &key test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (cond (test (nunion x y :key key :test test)) (test-not (nunion x y :key key :test-not test-not)) (t (nunion x y :key key)))) (defun do-random-nunions (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nunion-with-copy x y))) (let ((is-good (check-union x y z))) (unless is-good (return (values x y z))))))) nil)) (defun set-difference-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-difference x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result) (t 'failed))))) (defun check-set-difference (x y z &key (key #'identity) (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) (listp y) (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) (defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (set-difference-with-check x y))) (let ((is-good (check-set-difference x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nset-difference-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-difference x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun check-nset-difference (x y z &key (key #'identity) (test #'eql)) (and (listp x) (listp y) (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) (defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nset-difference-with-check x y))) (let ((is-good (check-nset-difference x y z))) (unless is-good (return (values x y z))))))) nil)) (defun set-exclusive-or-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-exclusive-or x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) result) (t 'failed))))) (defun check-set-exclusive-or (x y z &key (key #'identity) (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) (listp y) (listp z) (loop for e in z always (or (member e x :key key :test test) (member e y :key key :test test))) (loop for e in x always (if (member e y :key key :test test) (not (member e z :key key :test test)) (member e z :key key :test test))) (loop for e in y always (if (member e x :key key :test test) (not (member e z :key key :test test)) (member e z :key key :test test))) t)) (defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (set-exclusive-or-with-check x y))) (let ((is-good (check-set-exclusive-or x y z))) (unless is-good (return (values x y z))))))) nil)) (defun nset-exclusive-or-with-check (x y &key (key 'no-key) test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-exclusive-or x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not))))) (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nset-exclusive-or-with-check x y))) (let ((is-good (check-set-exclusive-or x y z))) (unless is-good (return (values x y z))))))) nil)) (defun subsetp-with-check (x y &key (key 'no-key) test test-not) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (apply #'subsetp x y `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)) (not (not result))) (t 'failed))))) (defun safe-elt (x n) (classify-error* (elt x n))) (defmacro defstruct* (&body args) `(eval-when (load eval compile) (ignore-errors (defstruct ,@args)))) (defun sort-package-list (x) (sort (copy-list x) #'string< :key #'package-name)) (defun sort-symbols (sl) (sort (copy-list sl) #'(lambda (x y) (or (string< (symbol-name x) (symbol-name y)) (and (string= (symbol-name x) (symbol-name y)) (string< (package-name (symbol-package x)) (package-name (symbol-package y)))))))) (defun num-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) (incf num)))) (defun num-external-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) (incf num)))) (defun safely-delete-package (package-designator) (let ((package (find-package package-designator))) (when package (let ((used-by (package-used-by-list package))) (dolist (using-package used-by) (unuse-package package using-package))) (delete-package package)))) (defun delete-all-versions (pathspec) "Replace the versions field of the pathname specified by pathspec with :wild, and delete all the files this refers to." (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) (truenames (directory wild-pathname))) (mapc #'delete-file truenames))) (defconstant +fail-count-limit+ 20) (defmacro test-with-package-iterator (package-list-expr &rest symbol-types) "Build an expression that tests the with-package-iterator form." (let ((name (gensym)) (cht-var (gensym)) (pkg-list-var (gensym))) `(let ((,cht-var (make-hash-table)) (,pkg-list-var ,package-list-expr) (fail-count 0)) (with-package-iterator (,name ,pkg-list-var ,@(copy-list symbol-types)) ;; For each symbol, check that name is returning appropriate ;; things (loop (block fail (multiple-value-bind (more sym access pkg) (,name) (unless more (return nil)) (setf (gethash sym ,cht-var) t) ;; note presence of symbol ;; Check that its access status is in the list, ;; that pkg is a package, ;; that the symbol is in the package, ;; and that (in the package) it has the correct access type (unless (member access (quote ,(copy-list symbol-types))) (unless (> fail-count +fail-count-limit+) (format t "Bad access type: ~S ==> ~A~%" sym access)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (packagep pkg) (unless (> fail-count +fail-count-limit+) (format t "Not a package: ~S ==> ~S~%" sym pkg)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (multiple-value-bind (sym2 access2) (find-symbol (symbol-name sym) pkg) (unless (or (eqt sym sym2) (member sym2 (package-shadowing-symbols pkg))) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol: ~S ~S~%" sym sym2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (eqt access access2) (unless (> fail-count +fail-count-limit+) (format t "Not same access type: ~S ~S ~S~%" sym access access2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil))))))) ;; now, check that each symbol in each package has ;; been properly found (loop for p in ,pkg-list-var do (block fail (do-symbols (sym p) (multiple-value-bind (sym2 access) (find-symbol (symbol-name sym) p) (unless (eqt sym sym2) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol (2): ~S ~S~%" sym sym2)) (when (= fail-count +fail-count-limit+) (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) (unless (or (not (member access (quote ,(copy-list symbol-types)))) (gethash sym ,cht-var)) (format t "Symbol not found: ~S~%" sym) (incf fail-count) (return-from fail nil)))))) (or (zerop fail-count) fail-count)))) (defun with-package-iterator-internal (packages) (test-with-package-iterator packages :internal)) (defun with-package-iterator-external (packages) (test-with-package-iterator packages :external)) (defun with-package-iterator-inherited (packages) (test-with-package-iterator packages :inherited)) (defun with-package-iterator-all (packages) (test-with-package-iterator packages :internal :external :inherited)) (defun frob-simple-condition (c expected-fmt &rest expected-args) "Try out the format control and format arguments of a simple-condition C, but make no assumptions about what they print as, only that they do print." (declare (ignore expected-fmt expected-args)) (and (typep c 'simple-condition) (let ((fc (simple-condition-format-control c)) (args (simple-condition-format-arguments c))) (and (stringp (apply #'format nil fc args)) t)))) (defun frob-simple-error (c expected-fmt &rest expected-args) (and (typep c 'simple-error) (apply #'frob-simple-condition c expected-fmt expected-args))) (defun frob-simple-warning (c expected-fmt &rest expected-args) (and (typep c 'simple-warning) (apply #'frob-simple-condition c expected-fmt expected-args))) (defparameter *array-element-types* '(t (integer 0 0) bit (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) float short-float single-float double-float long-float nil character base-char symbol boolean null)) (defun random-partition (n p) "Partition n into p numbers, each >= 1. Return list of numbers." (assert (<= 1 p)) #| (cond ((= p 1) (list n)) ((< n p) (make-list p :initial-element 1)) (t (let ((n1 (1+ (random (floor n p))))) (cons n1 (random-partition (- n n1) (1- p))))))) |# (cond ((= p 1) (list n)) ((= n 0) (make-list p :initial-element 0)) (t (let* ((r (random p)) (n1 (random (1+ n)))) (cond ((= r 0) (cons n1 (random-partition (- n n1) (1- p)))) ((= r (1- p)) (append (random-partition (- n n1) (1- p)) (list n1))) (t (let* ((n2 (random (1+ (- n n1)))) (n3 (- n n1 n2))) (append (random-partition n2 r) (list n1) (random-partition n3 (- p 1 r)))))))))) (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env)) (defun typep* (element type) (not (not (typep element type)))) gcl-2.6.14/ansi-tests/bit-vector-p.lsp0000644000175000017500000000254714360276512016130 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 20:16:50 2003 ;;;; Contains: Tests of BIT-VECTOR-P (in-package :cl-test) (deftest bit-vector-p.2 (notnot-mv (bit-vector-p #*)) t) (deftest bit-vector-p.3 (notnot-mv (bit-vector-p #*00101)) t) (deftest bit-vector-p.4 (bit-vector-p #(0 1 1 1 0 0)) nil) (deftest bit-vector-p.5 (bit-vector-p "011100") nil) (deftest bit-vector-p.6 (bit-vector-p 0) nil) (deftest bit-vector-p.7 (bit-vector-p 1) nil) (deftest bit-vector-p.8 (bit-vector-p nil) nil) (deftest bit-vector-p.9 (bit-vector-p 'x) nil) (deftest bit-vector-p.10 (bit-vector-p '(0 1 1 0)) nil) (deftest bit-vector-p.11 (bit-vector-p (make-array '(2 2) :element-type 'bit :initial-element 0)) nil) (deftest bit-vector-p.12 (loop for e in *universe* for p1 = (typep e 'bit-vector) for p2 = (bit-vector-p e) always (if p1 p2 (not p2))) t) (deftest bit-vector-p.order.1 (let ((i 0) x) (values (notnot (bit-vector-p (progn (setf x (incf i)) #*0010))) i x)) t 1 1) (deftest bit-vector-p.order.2 (let ((i 0) x) (values (bit-vector-p (progn (setf x (incf i)) 'a)) i x)) nil 1 1) (deftest bit-vector-p.error.1 (classify-error (bit-vector-p)) program-error) (deftest bit-vector-p.error.2 (classify-error (bit-vector-p #* #*)) program-error) gcl-2.6.14/ansi-tests/file-write-date.lsp0000644000175000017500000000400614360276512016567 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 06:01:35 2004 ;;;; Contains: Tests for FILE-WRITE-DATE (in-package :cl-test) (deftest file-write-date.1 (let* ((pn "file-write-date.lsp") (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.2 (let* ((pn #p"file-write-date.lsp") (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.3 (let* ((pn (truename "file-write-date.lsp")) (date (file-write-date pn)) (time (get-universal-time))) (or (null date) (and (integerp date) (<= 0 date time) t))) t) (deftest file-write-date.4 (loop for pn in (directory (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) for date = (file-write-date pn) for time = (get-universal-time) unless (or (null date) (<= 0 date time)) collect (list pn date time)) nil) (deftest file-write-date.5 (length (multiple-value-list (file-write-date "file-write-date.lsp"))) 1) ;;; Specialized string tests (deftest file-write-date.6 (let* ((str "file-write-date.lsp") (date (file-write-date str))) (do-special-strings (s str nil) (assert (equal (file-write-date s) date)))) nil) ;;; FIXME ;;; Add LPN test ;;; Error tests (deftest file-write-date.error.1 (signals-error (file-write-date) program-error) t) (deftest file-write-date.error.2 (signals-error (file-write-date "file-write-date.lsp" nil) program-error) t) (deftest file-write-date.error.3 (signals-error-always (file-write-date (make-pathname :name :wild :type "lsp" :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-write-date.error.4 (signals-error-always (file-write-date (make-pathname :name "file-write-date" :type :wild :defaults *default-pathname-defaults*)) file-error) t t) gcl-2.6.14/ansi-tests/read-char-no-hang.lsp0000644000175000017500000000475014360276512016766 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:32:38 2004 ;;;; Contains: Tests of READ-CHAR-NO-HANG (in-package :cl-test) (deftest read-char-no-hang.1 (with-input-from-string (*standard-input* "a") (read-char-no-hang)) #\a) (deftest read-char-no-hang.2 (with-input-from-string (*standard-input* "abc") (values (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) #\a #\b #\c) (when (code-char 0) (deftest read-char-no-hang.3 (with-input-from-string (*standard-input* (concatenate 'string "a" (string (code-char 0)) "b")) (values (read-char-no-hang) (read-char-no-hang) (read-char-no-hang))) #\a #.(code-char 0) #\b)) (deftest read-char-no-hang.4 (with-input-from-string (s "abc") (values (read-char-no-hang s) (read-char-no-hang s) (read-char-no-hang s))) #\a #\b #\c) (deftest read-char-no-hang.5 (with-input-from-string (s "") (read-char-no-hang s nil)) nil) (deftest read-char-no-hang.6 (with-input-from-string (s "") (read-char-no-hang s nil 'foo)) foo) (deftest read-char-no-hang.7 (with-input-from-string (s "abc") (values (read-char-no-hang s nil nil) (read-char-no-hang s nil nil) (read-char-no-hang s nil nil))) #\a #\b #\c) (deftest read-char-no-hang.8 (with-input-from-string (s "abc") (values (read-char-no-hang s nil t) (read-char-no-hang s nil t) (read-char-no-hang s nil t))) #\a #\b #\c) (deftest read-char-no-hang.9 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (read-char-no-hang t))) #\!) (deftest read-char-no-hang.10 (with-input-from-string (*standard-input* "345") (read-char-no-hang nil)) #\3) ;;; Need a test of the non-hanging. ;;; This is hard to do portably. ;;; Error tests (deftest read-char-no-hang.error.1 (signals-error (with-input-from-string (s "abc") (read-char-no-hang s nil nil nil nil)) program-error) t) (deftest read-char-no-hang.error.2 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s)) end-of-file) t t) (deftest read-char-no-hang.error.3 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s t)) end-of-file) t t) (deftest read-char-no-hang.error.4 (signals-error-always (with-input-from-string (s "") (read-char-no-hang s t t)) end-of-file) t t) gcl-2.6.14/ansi-tests/or.lsp0000644000175000017500000000105614360276512014227 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:29:27 2002 ;;;; Contains: Tests of OR (in-package :cl-test) (deftest or.1 (or) nil) (deftest or.2 (or nil) nil) (deftest or.3 (or 'a) a) (deftest or.4 (or (values 'a 'b 'c)) a b c) (deftest or.5 (or (values))) (deftest or.6 (or (values t nil) 'a) t) (deftest or.7 (or nil (values 'a 'b 'c)) a b c) (deftest or.8 (let ((x 0)) (values (or t (incf x)) x)) t 0) (deftest or.9 (or (values nil 1 2) (values 1 nil 2)) 1 nil 2) gcl-2.6.14/ansi-tests/count.lsp0000644000175000017500000003143514360276512014743 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 19 07:31:55 2002 ;;;; Contains: Tests for COUNT (in-package :cl-test) (deftest count-list.1 (count 'a '(a b c d e a e f)) 2) (deftest count-list.2 (count 'a '(a b c d e a e f) :test #'eql) 2) (deftest count-list.3 (count 'a '(a b c d e a e f) :test 'eql) 2) (deftest count-list.4 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1-) 5) (deftest count-list.5 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key '1-) 5) (deftest count-list.6 (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) 5) (deftest count-list.7 (count 1 '(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) 5) (deftest count-list.8 (let ((c 0)) (count 1 '(1 2 3 1 4 1 7 6 1 8) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-list.9 (let ((c 0)) (count 1 '(1 2 3 7 4 5 7 6 2 8) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-list.10 (count 1 '(1 1 1 1 1 2 1 1) :start 3) 4) (deftest count-list.11 (count 1 '(1 1 1 1 1 2 1 1) :end 6) 5) (deftest count-list.12 (count 1 '(1 1 1 1 1 2 1 1) :start 2 :end 7) 4) (deftest count-list.13 (count 1 '(1 1 1 1 1 2 1 1) :start 3 :end nil) 4) (deftest count-list.14 (count 1 '(1 1 1 1 1 2 1 1) :end nil) 7) (deftest count-list.15 (count 1 '(1 1 1 1 1 2 1 1) :test-not #'eql) 1) (deftest count-list.16 (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) ;;; On vectors (deftest count-vector.1 (count 'a #(a b c d e a e f)) 2) (deftest count-vector.2 (count 'a #(a b c d e a e f) :test #'eql) 2) (deftest count-vector.3 (count 'a #(a b c d e a e f) :test 'eql) 2) (deftest count-vector.4 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1-) 5) (deftest count-vector.5 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key '1-) 5) (deftest count-vector.6 (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) 5) (deftest count-vector.7 (count 1 #(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) 5) (deftest count-vector.8 (let ((c 0)) (count 1 #(1 2 3 1 4 1 7 6 1 8) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-vector.9 (let ((c 0)) (count 1 #(1 2 3 7 4 5 7 6 2 8) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-vector.10 (count 1 #(1 1 1 1 1 2 1 1) :start 3) 4) (deftest count-vector.11 (count 1 #(1 1 1 1 1 2 1 1) :end 6) 5) (deftest count-vector.12 (count 1 #(1 1 1 1 1 2 1 1) :start 2 :end 7) 4) (deftest count-vector.13 (count 1 #(1 1 1 1 1 2 1 1) :start 3 :end nil) 4) (deftest count-vector.14 (count 1 #(1 1 1 1 1 2 1 1) :end nil) 7) (deftest count-vector.15 (count 1 #(1 1 1 1 1 2 1 1) :test-not #'eql) 1) (deftest count-vector16 (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) ;;; Non-simple vectors (deftest count-filled-vector.1 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t)) 2) (deftest count-filled-vector.2 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t) :test #'eql) 2) (deftest count-filled-vector.3 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) :fill-pointer t) :test 'eql) 2) (deftest count-filled-vector.4 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key #'1-) 5) (deftest count-filled-vector.5 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key '1-) 5) (deftest count-filled-vector.6 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) :fill-pointer t) :key #'1- :test #'equal) 5) (deftest count-filled-vector.7 (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) :fill-pointer t) :from-end t) 5) (deftest count-filled-vector.8 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) :fill-pointer t) :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 4) (deftest count-filled-vector.9 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) :fill-pointer t) :from-end t :key #'(lambda (x) ;; (format t "~%~A ~A" x c) (prog1 (- x c) (incf c))))) 3) (deftest count-filled-vector.10 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 3) 4) (deftest count-filled-vector.11 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :end 6) 5) (deftest count-filled-vector.12 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 2 :end 7) 4) (deftest count-filled-vector.13 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :start 3 :end nil) 4) (deftest count-filled-vector.14 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :end nil) 7) (deftest count-filled-vector.15 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) :fill-pointer t) :test-not #'eql) 1) (deftest count-filled-vector.16 (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) :fill-pointer t) :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-filled-vector.17 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6)) 6) (deftest count-filled-vector.18 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :start 2) 4) (deftest count-filled-vector.19 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :from-end 'foo) 6) (deftest count-filled-vector.20 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6) :start 2 :from-end 'yes) 4) ;;; Tests on bit vectors (deftest count-bit-vector.1 (count 1 #*00101100011011000) 7) (deftest count-bit-vector.2 (count 1 #*00101100011011000 :test #'eql) 7) (deftest count-bit-vector.3 (count 1 #*00101100011011000 :test 'eql) 7) (deftest count-bit-vector.4 (count 1 #*00101100011011000 :key #'1+) 10) (deftest count-bit-vector.5 (count 0 #*00101100011011000 :key '1-) 7) (deftest count-bit-vector.6 (count 0 #*00101100011011000 :key #'1- :test #'equal) 7) (deftest count-bit-vector.7 (count 1 #*00101100011011000 :from-end t) 7) (deftest count-bit-vector.8 (let ((c 1)) (count 0 #*0000110101001 :key #'(lambda (x) (setf c (- c)) (+ c x)))) 2) (deftest count-bit-vector.9 (let ((c 1)) (count 0 #*0000011010101 :from-end t :key #'(lambda (x) (setf c (- c)) (+ c x)))) 4) (deftest count-bit-vector.10 (count 1 #*11000110110 :start 3) 4) (deftest count-bit-vector.11 (count 1 '#*110111110111 :end 6) 5) (deftest count-bit-vector.12 (count 1 #*11111011 :start 2 :end 7) 4) (deftest count-bit-vector.13 (count 1 #*11111011 :start 3 :end nil) 4) (deftest count-bit-vector.14 (count 1 #*11111011 :end nil) 7) (deftest count-bit-vector.15 (count 1 #*11111011 :test-not #'eql) 1) (deftest count-bit-vector.16 (count 1 #*11101101 :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-bit-vector.17 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5)) 4) (deftest count-bit-vector.18 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5) :start 1) 3) (deftest count-bit-vector.19 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 5) :end nil) 4) (deftest count-bit-vector.20 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) :element-type 'bit :fill-pointer 6) :end 4) 3) ;;; Tests on strings (deftest count-string.1 (count #\1 "00101100011011000") 7) (deftest count-string.2 (count #\1 "00101100011011000" :test #'eql) 7) (deftest count-string.3 (count #\1 "00101100011011000" :test 'eql) 7) (deftest count-string.4 (count #\1 "00101100011011000" :key #'(lambda (x) (if (eql x #\0) #\1 #\2))) 10) (deftest count-string.5 (count #\1 "00101100011011000" :key 'identity) 7) (deftest count-string.6 (count #\1 "00101100011011000" :key #'identity :test #'equal) 7) (deftest count-string.7 (count #\1 "00101100011011000" :from-end t) 7) (deftest count-string.8 (let ((c nil)) (count #\0 "0000110101001" :key #'(lambda (x) (setf c (not c)) (and c x)))) 5) (deftest count-string.9 (let ((c nil)) (count #\0 "0000011010101" :from-end t :key #'(lambda (x) (setf c (not c)) (and c x)))) 3) (deftest count-string.10 (count #\1 "11000110110" :start 3) 4) (deftest count-string.11 (count #\1 '"110111110111" :end 6) 5) (deftest count-string.12 (count #\1 "11111011" :start 2 :end 7) 4) (deftest count-string.13 (count #\1 "11111011" :start 3 :end nil) 4) (deftest count-string.14 (count #\1 "11111011" :end nil) 7) (deftest count-string.15 (count #\1 "11111011" :test-not #'eql) 1) (deftest count-string.16 (count #\1 "11101101" :start 2 :end 7 :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-string.17 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character)) 5) (deftest count-string.18 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :start 1) 4) (deftest count-string.19 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :end nil) 5) (deftest count-string.20 (count #\a (make-array 10 :initial-contents "abaaacaaaa" :fill-pointer 7 :element-type 'character) :start 2 :end 5) 3) ;;; Argument order tests (deftest count.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'identity) :from-end (progn (setf c6 (incf i)) nil) :test (progn (setf c7 (incf i)) #'eql) ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) (deftest count.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :test (progn (setf c3 (incf i)) #'eql) :from-end (progn (setf c4 (incf i)) nil) :key (progn (setf c5 (incf i)) #'identity) :end (progn (setf c6 (incf i)) 3) :start (progn (setf c7 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest count.allow-other-keys.1 (count 'a '(b a d a c) :bad t :allow-other-keys t) 2) (deftest count.allow-other-keys.2 (count 'a '(b a d a c) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count.allow-other-keys.3 (count 'a '(b a d a c) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count.keywords.4 (count 2 '(1 2 3 2 5) :key #'identity :key #'1+) 2) (deftest count.allow-other-keys.5 (count 'a '(a b c a) :allow-other-keys nil) 2) ;;; Error tests (deftest count.error.1 (classify-error (count 'a 1)) type-error) (deftest count.error.2 (classify-error (count 'a 'a)) type-error) (deftest count.error.3 (classify-error (count 'a #\a)) type-error) (deftest count.error.4 (classify-error (count)) program-error) (deftest count.error.5 (classify-error (count nil)) program-error) (deftest count.error.6 (classify-error (count nil nil :bad t)) program-error) (deftest count.error.7 (classify-error (count nil nil :bad t :allow-other-keys nil)) program-error) (deftest count.error.8 (classify-error (count nil nil :key)) program-error) (deftest count.error.9 (classify-error (count nil nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count.error.10 (classify-error (count 'a nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count.error.11 (classify-error (locally (count 'a 1) t)) type-error) (deftest count.error.12 (classify-error (count 'b '(a b c) :test #'identity)) program-error) (deftest count.error.13 (classify-error (count 'b '(a b c) :key #'car)) type-error) (deftest count.error.14 (classify-error (count 'b '(a b c) :test-not #'identity)) program-error) (deftest count.error.15 (classify-error (count 'b '(a b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/string-capitalize.lsp0000644000175000017500000000622214360276512017240 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 20:08:26 2002 ;;;; Contains: Tests for STRING-CAPITALIZE (in-package :cl-test) (deftest string-capitalize.1 (let ((s "abCd")) (values (string-capitalize s) s)) "Abcd" "abCd") (deftest string-capitalize.2 (let ((s "0adA2Cdd3wXy")) (values (string-capitalize s) s)) "0ada2cdd3wxy" "0adA2Cdd3wXy") (deftest string-capitalize.3 (let ((s "1a")) (values (string-capitalize s) s)) "1a" "1a") (deftest string-capitalize.4 (let ((s "a1a")) (values (string-capitalize s) s)) "A1a" "a1a") (deftest string-capitalize.5 (let ((s #\a)) (values (string-capitalize s) s)) "A" #\a) (deftest string-capitalize.6 (let ((s '|abcDe|)) (values (string-capitalize s) (symbol-name s))) "Abcde" "abcDe") (deftest string-capitalize.7 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (string-capitalize s :start i)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-capitalize.8 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (string-capitalize s :start i :end nil)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") (deftest string-capitalize.9 (let ((s "ABCDEF")) (values (loop for i from 0 to 6 collect (string-capitalize s :end i)) s)) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") "ABCDEF") (deftest string-capitalize.10 (let ((s "ABCDEF")) (values (loop for i from 0 to 5 collect (loop for j from i to 6 collect (string-capitalize s :start i :end j))) s)) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") ("ABCDEF" "ABCDEF" "ABCDEf") ("ABCDEF" "ABCDEF")) "ABCDEF") (deftest string-capitalize.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-capitalize (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBcdef" 3 1 2 3) (deftest string-capitalize.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-capitalize (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBcdef" 3 1 2 3) ;;; Error cases (deftest string-capitalize.error.1 (classify-error (string-capitalize)) program-error) (deftest string-capitalize.error.2 (classify-error (string-capitalize (copy-seq "abc") :bad t)) program-error) (deftest string-capitalize.error.3 (classify-error (string-capitalize (copy-seq "abc") :start)) program-error) (deftest string-capitalize.error.4 (classify-error (string-capitalize (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-capitalize.error.5 (classify-error (string-capitalize (copy-seq "abc") :end)) program-error) (deftest string-capitalize.error.6 (classify-error (string-capitalize (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/subseq.lsp0000644000175000017500000001103714360276512015111 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:41:14 2002 ;;;; Contains: Tests on SUBSEQ (in-package :cl-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; subseq, on lists (deftest subseq-list.1 (subseq '(a b c d e) 0 0) nil) (deftest subseq-list.2 (subseq '(a b c) 0) (a b c)) (deftest subseq-list.3 (subseq '(a b c) 1) (b c)) (deftest subseq-list.4 (subseq-list.4-body) t) (deftest subseq-list.5 (subseq-list.5-body) t) (deftest subseq-list.6 ;; check that no structure is shared (subseq-list.6-body) t) (deftest subseq-list.7 (let ((x (loop for i from 0 to 9 collect i))) (setf (subseq x 0 3) (list 'a 'b 'c)) x) (a b c 3 4 5 6 7 8 9)) (deftest subseq-list.8 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 0) '(f g h)) (list x y)) ((a b c d e) (f g h d e))) (deftest subseq-list.9 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 1 3) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a 1 2 d e))) (deftest subseq-list.10 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 5) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a b c d e))) (deftest subseq-list.11 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 2 5) '(1)) (list x y)) ((a b c d e) (a b 1 d e))) (deftest subseq-list.12 (let* ((x '(a b c d e)) (y (copy-seq x))) (setf (subseq y 0 0) '(1 2)) (list x y)) ((a b c d e) (a b c d e))) ;; subseq on vectors (deftest subseq-vector.1 (subseq-vector.1-body) t) (deftest subseq-vector.2 (subseq-vector.2-body) t) (deftest subseq-vector.3 (subseq-vector.3-body) t) (deftest subseq-vector.4 (subseq-vector.4-body) t) (deftest subseq-vector.5 (subseq-vector.5-body) t) (deftest subseq-vector.6 (subseq-vector.6-body) t) (deftest subseq-vector.7 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) (y (subseq x 2 8))) (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) t) (deftest subseq-vector.8 (let* ((x (make-array '(200) :initial-element 107 :element-type 'fixnum)) (y (subseq x 17 95))) (and (eqlt (length y) (- 95 17)) (equal-array y (make-array (list (- 95 17)) :initial-element 107 :element-type 'fixnum)))) t) (deftest subseq-vector.9 (let* ((x (make-array '(1000) :initial-element 17.6e-1 :element-type 'single-float)) (lo 164) (hi 873) (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) (equal-array y (make-array (list (- hi lo)) :initial-element 17.6e-1 :element-type 'single-float)))) t) (deftest subseq-vector.10 (let* ((x (make-array '(2000) :initial-element 3.1415927d4 :element-type 'double-float)) (lo 731) (hi 1942) (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) (equal-array y (make-array (list (- hi lo)) :initial-element 3.1415927d4 :element-type 'double-float)))) t) ;;; subseq on strings (deftest subseq-string.1 (subseq-string.1-body) t) (deftest subseq-string.2 (subseq-string.2-body) t) (deftest subseq-string.3 (subseq-string.3-body) t) ;;; Tests on bit vectors (deftest subseq-bit-vector.1 (subseq-bit-vector.1-body) t) (deftest subseq-bit-vector.2 (subseq-bit-vector.2-body) t) (deftest subseq-bit-vector.3 (subseq-bit-vector.3-body) t) ;;; Order of evaluation (deftest subseq.order.1 (let ((i 0) a b c) (values (subseq (progn (setf a (incf i)) "abcdefgh") (progn (setf b (incf i)) 1) (progn (setf c (incf i)) 4)) i a b c)) "bcd" 3 1 2 3) (deftest subseq.order.2 (let ((i 0) a b) (values (subseq (progn (setf a (incf i)) "abcdefgh") (progn (setf b (incf i)) 1)) i a b)) "bcdefgh" 2 1 2) (deftest subseq.order.3 (let ((i 0) a b c d (s (copy-seq "abcdefgh"))) (values (setf (subseq (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1) (progn (setf c (incf i)) 4)) (progn (setf d (incf i)) "xyz")) s i a b c d)) "xyz" "axyzefgh" 4 1 2 3 4) (deftest subseq.order.4 (let ((i 0) a b c (s (copy-seq "abcd"))) (values (setf (subseq (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) "xyz")) s i a b c)) "xyz" "axyz" 3 1 2 3) ;;; Error cases (deftest subseq.error.1 (classify-error (subseq)) program-error) (deftest subseq.error.2 (classify-error (subseq nil)) program-error) (deftest subseq.error.3 (classify-error (subseq nil 0 0 0)) program-error) gcl-2.6.14/ansi-tests/rename-file.lsp0000644000175000017500000001516014360276512015774 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 8 06:22:53 2004 ;;;; Contains: Tests for RENAME-FILE (in-package :cl-test) (deftest rename-file.1 (let ((pn1 #p"file-to-be-renamed.txt") (pn2 #p"file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.2 (let ((pn1 "file-to-be-renamed.txt") (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.3 (let* ((pn1 (make-pathname :name "file-to-be-renamed" :type "txt" :version :newest :defaults *default-pathname-defaults*)) (pn2 (make-pathname :name "file-that-was-renamed")) (pn3 (make-pathname :name "file-that-was-renamed" :defaults pn1))) (delete-all-versions pn1) (delete-all-versions pn3) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (equalpt (pathname-type pn1) (pathname-type defaulted-new-name)) (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn3)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) t t nil t (t t t nil nil) t nil t) (deftest rename-file.4 (let ((pn1 "file-to-be-renamed.txt") (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (let ((s (open pn1 :direction :output))) (format s "Whatever~%") (close s) (let ((results (multiple-value-list (rename-file s pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.5 (let ((pn1 "CLTEST:FILE-TO-BE-RENAMED.TXT") (pn2 "CLTEST:FILE-THAT-WAS-RENAMED.TXT")) (delete-all-versions pn1) (delete-all-versions pn2) (assert (typep (pathname pn1) 'logical-pathname)) (assert (typep (pathname pn2) 'logical-pathname)) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (values (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)) (notnot (typep defaulted-new-name 'logical-pathname)) )))) t nil t (t t t nil nil) t nil t t) ;;; Specialized string tests (deftest rename-file.6 (do-special-strings (s "file-to-be-renamed.txt" nil) (let ((pn1 s) (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (assert (equal (list (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))) '(t nil t (t t t nil nil) t nil t))))))) nil) (deftest rename-file.7 (do-special-strings (s "file-that-was-renamed.txt" nil) (let ((pn1 "file-to-be-renamed.txt") (pn2 s)) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) results (assert (equal (list (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) (list (notnot (pathnamep defaulted-new-name)) (notnot (pathnamep old-truename)) (notnot (pathnamep new-truename)) (typep old-truename 'logical-pathname) (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))) '(t nil t (t t t nil nil) t nil t))))))) nil) ;;; Error tests (deftest rename-file.error.1 (signals-error (rename-file) program-error) t) gcl-2.6.14/ansi-tests/with-open-file.lsp0000644000175000017500000000447614360276512016447 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 20:57:05 2004 ;;;; Contains: Tests of WITH-OPEN-FILE (in-package :cl-test) ;;; For now, omit most of the options combinations, assuming they will ;;; be tested in OPEN. The tests of OPEN should be ported to here at some ;;; point. (deftest with-open-file.1 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output))) nil) (deftest with-open-file.2 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (notnot-mv (output-stream-p s)))) t) (deftest with-open-file.3 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (values)))) (deftest with-open-file.4 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (values 1 2 3 4 5 6 7 8))) 1 2 3 4 5 6 7 8) (deftest with-open-file.5 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output) (declare (ignore s)) (declare (optimize)))) nil) (deftest with-open-file.6 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn (cdr '(nil . :direction)) (car '(:output))) (format s "foo!~%")) (with-open-file (s pn) (read-line s))) "foo!" nil) ;;; Free declaration scope tests (deftest with-open-file.7 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s (return-from done x)) (declare (special x)))))) :good) (deftest with-open-file.8 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s "with-open-file.lsp" (return-from done x) :input) (declare (special x)))))) :good) (deftest with-open-file.9 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-file (s "with-open-file.lsp" :direction (return-from done x)) (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-open-file.10 (macrolet ((%m (z) z)) (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s (expand-in-current-env (%m pn)) :direction :output)))) nil) gcl-2.6.14/ansi-tests/assert.lsp0000644000175000017500000000315614360276512015113 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 28 06:48:19 2003 ;;;; Contains: Tests of ASSERT (in-package :cl-test) (deftest assert.1 (assert t) nil) (deftest assert.2 (assert t ()) nil) ;;; I am assuming that when no places are given to ASSERT, ;;; it doesn't invoke any interactive handler. (deftest assert.3 (let ((x nil)) (handler-bind ((error #'(lambda (c) (setq x 17) (let ((r (find-restart 'continue c))) (when r (invoke-restart r)))))) (assert x) x)) 17) (deftest assert.3a (let ((x nil)) (handler-bind ((error #'(lambda (c) (setq x 17) (continue c)))) (assert x) x)) 17) ;;; I don't yet know how to test the interactive version of ASSERT ;;; that is normally invoked when places are given. ;;; Tests of the syntax (at least) (deftest assert.4 (let (x) (assert t (x))) nil) (deftest assert.5 (let ((x (cons 'a 'b))) (assert t ((car x) (cdr x)))) nil) (deftest assert.6 (let ((x (vector 'a 'b 'c))) (assert t ((aref x 0) (aref x 1) (aref x 2)) "Vector x has value: ~A." x)) nil) (deftest assert.7 (let ((x nil)) (handler-bind ((simple-error #'(lambda (c) (setq x 17) (continue c)))) (assert x () 'simple-error) x)) 17) (deftest assert.8 (let ((x 0)) (handler-bind ((type-error #'(lambda (c) (incf x) (continue c)))) (assert (> x 5) () 'type-error) x)) 6) (deftest assert.9 (let ((x 0)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (incf x) (continue)))) (assert (> x 5) () 'type-error) x)) 6) gcl-2.6.14/ansi-tests/pathname-device.lsp0000644000175000017500000000363614360276512016647 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:23:54 2003 ;;;; Contains: Tests for PATHNAME-DEVICE (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-device.1 (loop for p in *pathnames* for device = (pathname-device p) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.2 (loop for p in *pathnames* for device = (pathname-device p :case :local) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.3 (loop for p in *pathnames* for device = (pathname-device p :case :common) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.4 (loop for p in *pathnames* for device = (pathname-device p :allow-other-keys nil) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.5 (loop for p in *pathnames* for device = (pathname-device p :foo 'bar :allow-other-keys t) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) (deftest pathname-device.6 (loop for p in *pathnames* for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp device) (member device '(nil :wild :unspecific))) collect (list p device)) nil) ;;; section 19.3.2.1 (deftest pathname-device.7 (loop for p in *logical-pathnames* always (eq (pathname-device p) :unspecific)) t) (deftest pathname-device.8 (do-special-strings (s "" nil) (pathname-device s)) nil) (deftest pathname-device.error.1 (signals-error (pathname-device) program-error) t) (deftest pathname-device.error.2 (check-type-error #'pathname-device #'could-be-pathname-designator) nil)gcl-2.6.14/ansi-tests/multiple-value-call.lsp0000644000175000017500000000161714360276512017470 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:35:07 2002 ;;;; Contains: Tests of MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-LIST (in-package :cl-test) (deftest multiple-value-call.1 (multiple-value-call #'+ (values 1 2) (values) 3 (values 4 5 6)) 21) (deftest multiple-value-call.2 (multiple-value-call 'list) nil) (deftest multiple-value-call.3 (multiple-value-call 'list (floor 13 4)) (3 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (deftest multiple-value-list.1 (multiple-value-list (values)) nil) (deftest multiple-value-list.2 (multiple-value-list (values 'a)) (a)) (deftest multiple-value-list.3 (multiple-value-list (values 'a 'b)) (a b)) (deftest multiple-value-list.4 (not (loop for i from 0 below (min multiple-values-limit 100) for x = (make-list i :initial-element 'a) always (equal x (multiple-value-list (values-list x))))) nil) gcl-2.6.14/ansi-tests/nstring-capitalize.lsp0000644000175000017500000000574114360276512017423 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:38:49 2002 ;;;; Contains: Tests for NSTRING-CAPITALIZE (in-package :cl-test) (deftest nstring-capitalize.1 (let* ((s (copy-seq "abCd")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "Abcd") (deftest nstring-capitalize.2 (let* ((s (copy-seq "0adA2Cdd3wXy")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "0ada2cdd3wxy") (deftest nstring-capitalize.3 (let* ((s (copy-seq "1a")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "1a") (deftest nstring-capitalize.4 (let* ((s (copy-seq "a1a")) (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "A1a") (deftest nstring-capitalize.7 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (nstring-capitalize (copy-seq s) :start i))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.8 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (nstring-capitalize (copy-seq s) :start i :end nil))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-capitalize (copy-seq s) :end i))) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef")) (deftest nstring-capitalize.10 (let ((s "ABCDEF")) (loop for i from 0 to 5 collect (loop for j from i to 6 collect (nstring-capitalize (copy-seq s) :start i :end j)))) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") ("ABCDEF" "ABCDEF" "ABCDEf") ("ABCDEF" "ABCDEF"))) (deftest nstring-capitalize.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-capitalize (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBcdef" 3 1 2 3) (deftest nstring-capitalize.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-capitalize (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBcdef" 3 1 2 3) ;;; Error cases (deftest nstring-capitalize.error.1 (classify-error (nstring-capitalize)) program-error) (deftest nstring-capitalize.error.2 (classify-error (nstring-capitalize (copy-seq "abc") :bad t)) program-error) (deftest nstring-capitalize.error.3 (classify-error (nstring-capitalize (copy-seq "abc") :start)) program-error) (deftest nstring-capitalize.error.4 (classify-error (nstring-capitalize (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-capitalize.error.5 (classify-error (nstring-capitalize (copy-seq "abc") :end)) program-error) (deftest nstring-capitalize.error.6 (classify-error (nstring-capitalize (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/pathname-directory.lsp0000644000175000017500000000504314360276512017406 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:24:39 2003 ;;;; Contains: Tests for PATHNAME-DIRECTORY (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-directory.1 (loop for p in *pathnames* for directory = (pathname-directory p) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.2 (loop for p in *pathnames* for directory = (pathname-directory p :case :local) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.3 (loop for p in *pathnames* for directory = (pathname-directory p :case :common) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.4 (loop for p in *pathnames* for directory = (pathname-directory p :allow-other-keys nil) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.5 (loop for p in *pathnames* for directory = (pathname-directory p :foo 'bar :allow-other-keys t) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) (deftest pathname-directory.6 (loop for p in *pathnames* for directory = (pathname-directory p :allow-other-keys t :allow-other-keys nil 'foo 'bar) unless (or (stringp directory) (member directory '(nil :wild :unspecific)) (and (consp directory) (member (car directory) '(:absolute :relative)))) collect (list p directory)) nil) ;;; section 19.3.2.1 (deftest pathname-directory.7 (loop for p in *logical-pathnames* when (eq (pathname-directory p) :unspecific) collect p) nil) (deftest pathname-directory.8 (do-special-strings (s "" nil) (pathname-directory s)) nil) (deftest pathname-directory.error.1 (signals-error (pathname-directory) program-error) t) (deftest pathname-directory.error.2 (check-type-error #'pathname-directory #'could-be-pathname-designator) nil) gcl-2.6.14/ansi-tests/equal.lsp0000644000175000017500000000307114360276512014715 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 21:38:16 2002 ;;;; Contains: Tests for EQUAL (in-package :cl-test) (deftest equal.1 (loop for x in *symbols* always (loop for y in *symbols* always (if (eq x y) (equal x y) (not (equal x y))))) t) (deftest equal.2 (equalt (cons 'a 'b) (cons 'a 'b)) t) (deftest equal.3 (equalt (cons 'a 'c) (cons 'a 'b)) nil) (deftest equal.4 (equalt (vector 1 2 3) (vector 1 2 3)) nil) (deftest equal.5 (loop for c in *characters* always (loop for d in *characters* always (if (eql c d) (equalt c d) (not (equalt c d))))) t) (deftest equal.6 (equalt (make-pathname :name (copy-seq "foo")) (make-pathname :name (copy-seq "foo"))) t) (deftest equal.7 (equalt (make-pathname :name (copy-seq "foo")) (make-pathname :name (copy-seq "bar"))) nil) (deftest equal.8 (equalt (copy-seq "abcd") (copy-seq "abcd")) t) (deftest equal.9 (equalt (copy-seq "abcd") (copy-seq "abc")) nil) (deftest equal.10 (equalt (copy-seq "abcd") (copy-seq "ABCD")) nil) (deftest equal.11 (equalt (copy-seq #*000110) (copy-seq #*000110)) t) (deftest equal.12 (equalt (copy-seq #*000110) (copy-seq #*000111)) nil) (deftest equal.order.1 (let ((i 0) x y) (values (equal (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest equal.error.1 (classify-error (equal)) program-error) (deftest equal.error.2 (classify-error (equal nil)) program-error) (deftest equal.error.3 (classify-error (equal nil nil nil)) program-error) gcl-2.6.14/ansi-tests/pathnamep.lsp0000644000175000017500000000130114360276512015555 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 10:26:45 2003 ;;;; Contains: Tests of PATHNAMEP (in-package :cl-test) (deftest pathnamep.1 (check-type-predicate #'pathnamep 'pathname) 0) (deftest pathnamep.2 (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1))) nil) (deftest pathnamep.3 (check-predicate (typef '(not logical-pathname)) #'pathnamep) nil) (deftest pathnamep.error.1 (signals-error (pathnamep) program-error) t) (deftest pathnamep.error.2 (signals-error (pathnamep nil nil) program-error) t) (deftest pathnamep.error.3 (signals-error (pathnamep *default-pathname-defaults* nil) program-error) t) gcl-2.6.14/ansi-tests/file-position.lsp0000644000175000017500000001016614360276512016372 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 22 03:02:31 2004 ;;;; Contains: Tests of FILE-POSITION (in-package :cl-test) (deftest file-position.1 (with-open-file (is "file-position.lsp":direction :input) (file-position is)) 0) (deftest file-position.2 (with-open-file (is "file-position.lsp":direction :input) (values (multiple-value-list (notnot-mv (file-position is :start))) (file-position is))) (t) 0) (deftest file-position.3 (with-open-file (is "file-position.lsp":direction :input) (values (multiple-value-list (notnot-mv (file-position is :end))) (notnot (> (file-position is) 0)))) (t) t) (deftest file-position.4 (with-open-file (is "file-position.lsp":direction :input) (values (file-position is) (read-char is) (notnot (> (file-position is) 0)))) 0 #\; t) (deftest file-position.5 (with-open-file (os "tmp.dat":direction :output :if-exists :supersede) (values (file-position os) (write-char #\x os) (notnot (> (file-position os) 0)))) 0 #\x t) (deftest file-position.6 (with-open-file (os "tmp.dat":direction :output :if-exists :supersede) (let ((p1 (file-position os)) (delta (file-string-length os #\x))) (write-char #\x os) (let ((p2 (file-position os))) (or (null p1) (null p2) (null delta) (=t (+ p1 delta) p2))))) t) ;;; Byte streams (deftest file-position.7 (loop for len from 1 to 32 for n = (ash 1 len) do (with-open-file (os "tmp.dat" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for r = (logand (1- n) i) for pos = (file-position os) do (assert (or (not pos) (eql pos i))) do (write-byte r os))) do (with-open-file (is "tmp.dat" :direction :input :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for pos = (file-position is) do (assert (or (not pos) (eql pos i))) do (let ((byte (read-byte is))) (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.8 (loop for len from 33 to 100 for n = (ash 1 len) do (with-open-file (os "tmp.dat" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for r = (logand (1- n) i) for pos = (file-position os) do (assert (or (not pos) (eql pos i))) do (write-byte r os))) do (with-open-file (is "tmp.dat" :direction :input :element-type `(unsigned-byte ,len)) (loop for i from 0 below 100 for pos = (file-position is) do (assert (or (not pos) (eql pos i))) do (let ((byte (read-byte is))) (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.9 (with-input-from-string (s "abcdefghijklmnopqrstuvwxyz") (loop repeat 26 for p = (file-position s) unless (or (not p) (progn (file-position s p) (eql (file-position s) p))) collect p do (read-char s))) nil) (deftest file-position.10 (with-output-to-string (s) (loop repeat 26 for p = (file-position s) unless (or (not p) (progn (file-position s p) (eql (file-position s) p))) collect p do (write-char #\x s))) "xxxxxxxxxxxxxxxxxxxxxxxxxx") ;;; Error tests (deftest file-position.error.1 (signals-error (file-position) program-error) t) (deftest file-position.error.2 (signals-error (file-position (make-string-input-stream "abc") :start nil) program-error) t) ;;; It's not clear what 'too large' means -- can we set the ;;; file position to a point where the file may later be extended ;;; by some other writer? #| (deftest file-position.error.3 (signals-error (with-open-file (is "file-position.lsp" :direction :input) (flet ((%fail () (error 'type-error))) (unless (file-position is :end) (%fail)) (let ((fp (file-position is))) (unless fp (%fail)) (file-position is (+ 1000000 fp))))) error) t) (deftest file-position.error.4 (signals-error (with-open-file (is "file-position.lsp" :direction :input) (file-position is 1000000000000000000000)) error) t) |# gcl-2.6.14/ansi-tests/iteration.lsp0000644000175000017500000002037614360276512015613 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:58:00 2002 ;;;; Contains: Tests for iteration forms other than LOOP (in-package :cl-test) ;;; Confirm that most macros exist (defparameter *iteration-macros* '(do do* dotimes dolist loop)) (deftest iteration-macros (remove-if #'macro-function *iteration-macros*) nil) ;;; Tests of DO (deftest do.1 (do ((i 0 (1+ i))) ((>= i 10) i)) 10) (deftest do.2 (do ((i 0 (1+ j)) (j 0 (1+ i))) ((>= i 10) (+ i j))) 20) (deftest do.3 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do.4 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do.5 (do ((i 0 (1+ i))) (nil) (when (> i 10) (return i))) 11) ;;; Zero iterations (deftest do.6 (do ((i 0 (+ i 10))) ((> i -1) i) (return 'bad)) 0) ;;; Tests of go tags (deftest do.7 (let ((x nil)) (do ((i 0 (1+ i))) ((>= i 10) x) (go around) small (push 'a x) (go done) big (push 'b x) (go done) around (if (> i 4) (go big) (go small)) done)) (b b b b b a a a a a)) ;;; No increment form (deftest do.8 (do ((i 0 (1+ i)) (x nil)) ((>= i 10) x) (push 'a x)) (a a a a a a a a a a)) ;;; No do locals (deftest do.9 (let ((i 0)) (do () ((>= i 10) i) (incf i))) 10) ;;; Return of no values (deftest do.10 (do ((i 0 (1+ i))) ((> i 10) (values)))) ;;; Return of two values (deftest do.11 (do ((i 0 (1+ i))) ((> i 10) (values i (1+ i)))) 11 12) ;;; The results* list is an implicit progn (deftest do.12 (do ((i 0 (1+ i))) ((> i 10) (incf i) (incf i) i)) 13) (deftest do.13 (do ((i 0 (1+ i))) ((> i 10))) nil) ;; Special var (deftest do.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) (incf x i)))) (do ((i 0 (1+ i))) ((>= i 10) x) (declare (special i)) (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do.15 (mapcar #'funcall (let ((x nil)) (do ((i 0 (1+ i))) ((= i 5) x) (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Tests of DO* (deftest do*.1 (do* ((i 0 (1+ i))) ((>= i 10) i)) 10) (deftest do*.2 (do* ((i 0 (1+ j)) (j 0 (1+ i))) ((>= i 10) (+ i j))) 23) (deftest do*.3 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do*.4 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do*.5 (do* ((i 0 (1+ i))) (nil) (when (> i 10) (return i))) 11) ;;; Zero iterations (deftest do*.6 (do* ((i 0 (+ i 10))) ((> i -1) i) (return 'bad)) 0) ;;; Tests of go tags (deftest do*.7 (let ((x nil)) (do* ((i 0 (1+ i))) ((>= i 10) x) (go around) small (push 'a x) (go done) big (push 'b x) (go done) around (if (> i 4) (go big) (go small)) done)) (b b b b b a a a a a)) ;;; No increment form (deftest do*.8 (do* ((i 0 (1+ i)) (x nil)) ((>= i 10) x) (push 'a x)) (a a a a a a a a a a)) ;;; No do* locals (deftest do*.9 (let ((i 0)) (do* () ((>= i 10) i) (incf i))) 10) ;;; Return of no values (deftest do*.10 (do* ((i 0 (1+ i))) ((> i 10) (values)))) ;;; Return of two values (deftest do*.11 (do* ((i 0 (1+ i))) ((> i 10) (values i (1+ i)))) 11 12) ;;; The results* list is an implicit progn (deftest do*.12 (do* ((i 0 (1+ i))) ((> i 10) (incf i) (incf i) i)) 13) (deftest do*.13 (do* ((i 0 (1+ i))) ((> i 10))) nil) ;; Special var (deftest do*.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) (incf x i)))) (do* ((i 0 (1+ i))) ((>= i 10) x) (declare (special i)) (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do*.15 (mapcar #'funcall (let ((x nil)) (do* ((i 0 (1+ i))) ((= i 5) x) (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Tests for DOLIST (deftest dolist.1 (let ((count 0)) (dolist (x '(a b nil d)) (incf count)) count) 4) (deftest dolist.2 (let ((count 0)) (dolist (x '(a nil c d) count) (incf count))) 4) (deftest dolist.3 (let ((count 0)) (dolist (x nil count) (incf count))) 0) (deftest dolist.4 (let ((y nil)) (flet ((%f () (locally (declare (special e)) (push e y)))) (dolist (e '(a b c) (reverse y)) (declare (special e)) (%f)))) (a b c)) ;;; Tests that it's a tagbody (deftest dolist.5 (let ((even nil) (odd nil)) (dolist (i '(1 2 3 4 5 6 7 8) (values (reverse even) (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) even (push i even) done)) (2 4 6 8) (1 3 5 7)) ;;; Test that bindings are not normally special (deftest dolist.6 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dolist (i '(1 2 3 4)) (push (%f) y))) y) (0 0 0 0)) ;;; Test multiple return values (deftest dolist..7 (dolist (x '(a b) (values)))) (deftest dolist.8 (let ((count 0)) (dolist (x '(a b c) (values count count)) (incf count))) 3 3) ;;; Test ability to return, and the scope of the implicit ;;; nil block (deftest dolist.9 (block nil (eqlt (dolist (x '(a b c)) (return 1)) 1)) t) (deftest dolist.10 (block nil (eqlt (dolist (x '(a b c)) (return-from nil 1)) 1)) t) (deftest dolist.11 (block nil (dolist (x (return 1))) 2) 2) (deftest dolist.12 (block nil (dolist (x '(a b) (return 1))) 2) 2) ;;; Check that binding of element var is visible in the result form (deftest dolist.13 (dolist (e '(a b c) e)) nil) (deftest dolist.14 (let ((e 1)) (dolist (e '(a b c) (setf e 2))) e) 1) (deftest dolist.15 (let ((x nil)) (dolist (e '(a b c d e f)) (push e x) (when (eq e 'c) (return x)))) (c b a)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Tests for DOTIMES (deftest dotimes.1 (dotimes (i 10)) nil) (deftest dotimes.2 (dotimes (i 10 'a)) a) (deftest dotimes.3 (dotimes (i 10 (values)))) (deftest dotimes.3a (dotimes (i 10 (values 'a 'b 'c))) a b c) (deftest dotimes.4 (let ((x nil)) (dotimes (i 5 x) (push i x))) (4 3 2 1 0)) (deftest dotimes.5 (let ((x nil)) (dotimes (i 0 x) (push i x))) nil) (deftest dotimes.6 (let ((x nil)) (dotimes (i -1 x) (push i x))) nil) (deftest dotimes.7 (let ((x nil)) (dotimes (i (1- most-negative-fixnum) x) (push i x))) nil) ;;; Implicit nil block has the right scope (deftest dotimes.8 (block nil (dotimes (i (return 1))) 2) 2) (deftest dotimes.9 (block nil (dotimes (i 10 (return 1))) 2) 2) (deftest dotimes.10 (block nil (dotimes (i 10) (return 1)) 2) 2) (deftest dotimes.11 (let ((x nil)) (dotimes (i 10) (push i x) (when (= i 5) (return x)))) (5 4 3 2 1 0)) ;;; Check there's an implicit tagbody (deftest dotimes.12 (let ((even nil) (odd nil)) (dotimes (i 8 (values (reverse even) (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) even (push i even) done)) (0 2 4 6) (1 3 5 7)) ;;; Check that at the time the result form is evaluated, ;;; the index variable is set to the number of times the loop ;;; was executed. (deftest dotimes.13 (let ((i 100)) (dotimes (i 10 i))) 10) (deftest dotimes.14 (let ((i 100)) (dotimes (i 0 i))) 0) (deftest dotimes.15 (let ((i 100)) (dotimes (i -1 i))) 0) ;;; Check that the variable is not bound in the count form (deftest dotimes.16 (let ((i nil)) (values i (dotimes (i (progn (setf i 'a) 10) i)) i)) nil 10 a) ;;; Check special variable decls (deftest dotimes.17 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dotimes (i 4) (push (%f) y))) y) (0 0 0 0)) (deftest dotimes.18 (let ((i 0) (y nil)) (declare (special i)) (flet ((%f () i)) (dotimes (i 4) (declare (special i)) (push (%f) y))) y) (3 2 1 0)) gcl-2.6.14/ansi-tests/translate-logical-pathname.lsp0000644000175000017500000000226714360276512021014 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 29 14:45:50 2003 ;;;; Contains: Tests for TRANSLATE-LOGICAL-PATHNAME (in-package :cl-test) ;; On physical pathnames, t-l-p returns the pathname itself ;;; Every physical pathname is converted to itself (deftest translate-logical-pathname.1 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p))) collect p) nil) ;;; &key arguments are allowed (deftest translate-logical-pathname.2 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :allow-other-keys t))) collect p) nil) (deftest translate-logical-pathname.3 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :allow-other-keys nil))) collect p) nil) (deftest translate-logical-pathname.4 (loop for p in *pathnames* unless (or (typep p 'logical-pathname) (eq p (translate-logical-pathname p :foo 1 :allow-other-keys t :bar 2))) collect p) nil) ;;; errors (deftest translate-logical-pathname.error.1 (signals-error (translate-logical-pathname) program-error) t) gcl-2.6.14/ansi-tests/find-if.lsp0000644000175000017500000003467314360276512015136 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 18:37:52 2002 ;;;; Contains: Tests for FIND-IF (in-package :cl-test) (deftest find-if-list.1 (find-if #'identity ()) nil) (deftest find-if-list.2 (find-if #'identity '(a)) a) (deftest find-if-list.2a (find-if 'identity '(a)) a) (deftest find-if-list.3 (find-if #'evenp '(1 2 4 8 3 1 6 7)) 2) (deftest find-if-list.4 (find-if #'evenp '(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-list.5 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.6 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.7 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.8 (loop for i from 0 to 7 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.9 (loop for i from 0 to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-list.10 (loop for i from 0 to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-list.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.13 (loop for i from 0 to 6 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-list.14 (loop for i from 0 to 6 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-list.15 (loop for i from 0 to 7 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-list.16 (loop for i from 0 to 7 collect (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-list.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-list.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; tests for vectors (deftest find-if-vector.1 (find-if #'identity #()) nil) (deftest find-if-vector.2 (find-if #'identity #(a)) a) (deftest find-if-vector.2a (find-if 'identity #(a)) a) (deftest find-if-vector.3 (find-if #'evenp #(1 2 4 8 3 1 6 7)) 2) (deftest find-if-vector.4 (find-if #'evenp #(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-vector.5 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.6 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.7 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.8 (loop for i from 0 to 7 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.9 (loop for i from 0 to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-vector.10 (loop for i from 0 to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-vector.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.13 (loop for i from 0 to 6 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-vector.14 (loop for i from 0 to 6 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-vector.15 (loop for i from 0 to 7 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-vector.16 (loop for i from 0 to 7 collect (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-vector.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-vector.19 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5))) (values (find-if #'evenp a) (find-if #'evenp a :from-end t) (find-if #'oddp a) (find-if #'oddp a :from-end t) )) 2 4 1 5) ;;; Tests for bit vectors (deftest find-if-bit-vector.1 (find-if #'identity #*) nil) (deftest find-if-bit-vector.2 (find-if #'identity #*1) 1) (deftest find-if-bit-vector.3 (find-if #'identity #*0) 0) (deftest find-if-bit-vector.4 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'evenp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.5 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'evenp #*0110110 :start i :end j :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.6 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'oddp #*0110110 :start i :end j :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-bit-vector.7 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if #'oddp #*0110110 :start i :end j :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) ;;; Tests for strings (deftest find-if-string.1 (find-if #'identity "") nil) (deftest find-if-string.2 (find-if #'identity "a") #\a) (deftest find-if-string.2a (find-if 'identity "a") #\a) (deftest find-if-string.3 (find-if #'evendigitp "12483167") #\2) (deftest find-if-string.3a (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) (deftest find-if-string.4 (find-if #'evendigitp "12483167" :from-end t) #\6) (deftest find-if-string.5 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.6 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.7 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.8 (loop for i from 0 to 7 collect (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.9 (loop for i from 0 to 8 collect (find-if #'evendigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-string.10 (loop for i from 0 to 8 collect (find-if #'evendigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evendigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) (#\8 #\8 #\8 #\8 #\8) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-string.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if #'evendigitp "12483167" :start j :end i :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) (#\8 #\8 #\8 #\6 #\6) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-string.13 (loop for i from 0 to 6 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.14 (loop for i from 0 to 6 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-string.15 (loop for i from 0 to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-string.16 (loop for i from 0 to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-string.17 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) (#\6))) (deftest find-if-string.18 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if #'evenp "1473816" :key (compose #'read-from-string #'string) :start j :end i :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) (nil #\8 #\8 #\6) (#\8 #\8 #\6) (nil #\6) (#\6))) (deftest find-if-string.19 (let ((a (make-array '(10) :initial-contents "123456789a" :fill-pointer 5 :element-type 'character))) (values (find-if #'evendigitp a) (find-if #'evendigitp a :from-end t) (find-if #'odddigitp a) (find-if #'odddigitp a :from-end t) )) #\2 #\4 #\1 #\5) ;;; Keyword tests (deftest find-if.allow-other-keys.1 (find-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest find-if.allow-other-keys.2 (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if.allow-other-keys.3 (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find-if.keywords.4 (find-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find-if.allow-other-keys.5 (find-if #'identity '(nil a b c nil) :allow-other-keys nil) a) ;;; Error tests (deftest find-if.error.1 (classify-error (find-if #'null 'b)) type-error) (deftest find-if.error.2 (classify-error (find-if #'identity 10)) type-error) (deftest find-if.error.3 (classify-error (find-if '1+ 1.4)) type-error) (deftest find-if.error.4 (classify-error (find-if 'null '(a b c . d))) type-error) (deftest find-if.error.5 (classify-error (find-if)) program-error) (deftest find-if.error.6 (classify-error (find-if #'null)) program-error) (deftest find-if.error.7 (classify-error (find-if #'null nil :bad t)) program-error) (deftest find-if.error.8 (classify-error (find-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest find-if.error.9 (classify-error (find-if #'null nil 1 1)) program-error) (deftest find-if.error.10 (classify-error (find-if #'null nil :key)) program-error) (deftest find-if.error.11 (classify-error (locally (find-if #'null 'b) t)) type-error) (deftest find-if.error.12 (classify-error (find-if #'cons '(a b c))) program-error) (deftest find-if.error.13 (classify-error (find-if #'car '(a b c))) type-error) (deftest find-if.error.14 (classify-error (find-if #'identity '(a b c) :key #'cons)) program-error) (deftest find-if.error.15 (classify-error (find-if #'identity '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find-if.order.1 (let ((i 0) x y) (values (find-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find-if.order.2 (let ((i 0) a b c d e f g) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find-if.order.3 (let ((i 0) a b c d e f g) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl-2.6.14/ansi-tests/features.lsp0000644000175000017500000000077114360276512015430 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 2 07:44:40 2002 ;;;; Contains: Tests of *FEATURES* (in-package :cl-test) (deftest features.1 (let ((f *features*)) (or (not (member :draft-ansi-cl f)) (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) t) (deftest features.2 (let ((f *features*)) (or (not (intersection '(:x3j13 :draft-ansi-cl :ansi-cl) f)) (notnot (member :common-lisp f)))) t) (deftest features.3 (not (member :cltl2 *features*)) t) gcl-2.6.14/ansi-tests/flet.lsp0000644000175000017500000002574014360276512014547 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 8 22:55:02 2002 ;;;; Contains: Tests of FLET (in-package :cl-test) (deftest flet.1 (flet ((%f () 1)) (%f)) 1) (deftest flet.2 (flet ((%f (x) x)) (%f 2)) 2) (deftest flet.3 (flet ((%f (&rest args) args)) (%f 'a 'b 'c)) (a b c)) ;;; The optional arguments are not in the block defined by ;;; the local function declaration (deftest flet.4 (block %f (flet ((%f (&optional (x (return-from %f 10))) 20)) (%f))) 10) (deftest flet.5 (flet ((%f () (return-from %f 15) 35)) (%f)) 15) ;;; The aux parameters are not in the block defined by ;;; the local function declaration (deftest flet.6 (block %f (flet ((%f (&aux (x (return-from %f 10))) 20)) (%f))) 10) ;;; The function is not visible inside itself (deftest flet.7 (flet ((%f (x) (+ x 5))) (flet ((%f (y) (cond ((eql y 20) 30) (t (%f 20))))) (%f 15))) 25) ;;; Keyword arguments (deftest flet.8 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f)) nil 0 nil) (deftest flet.9 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a 1)) 1 0 nil) (deftest flet.10 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2)) nil 2 t) (deftest flet.11 (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2 :a 3)) 3 2 t) ;;; Unknown keyword parameter should throw a program-error in safe code ;;; (section 3.5.1.4) (deftest flet.12 (classify-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) program-error) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest flet.13 (classify-error (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) program-error) ;;; Too few arguments (section 3.5.1.2) (deftest flet.14 (classify-error (flet ((%f (a) a)) (%f))) program-error) ;;; Too many arguments (section 3.5.1.3) (deftest flet.15 (classify-error (flet ((%f (a) a)) (%f 1 2))) program-error) ;;; Invalid keyword argument (section 3.5.1.5) (deftest flet.16 (classify-error (flet ((%f (&key a) a)) (%f '(foo)))) program-error) ;;; Definition of a (setf ...) function (deftest flet.17 (flet (((setf %f) (x y) (setf (car y) x))) (let ((z (list 1 2))) (setf (%f z) 'a) z)) (a 2)) ;;; Body is an implicit progn (deftest flet.18 (flet ((%f (x) (incf x) (+ x x))) (%f 10)) 22) ;;; Can handle at least 50 lambda parameters (deftest flet.19 (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; flet works with a large (maximal?) number of arguments (deftest flet.20 (let* ((n (min lambda-parameters-limit 1024)) (vars (loop for i from 1 to n collect (gensym)))) (eval `(eql ,n (flet ((%f ,vars (+ ,@ vars))) (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest flet.21 (flet ((%f (x) (declare (type fixnum x)) "Add one to the fixnum x." (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) (deftest flet.22 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) (list x y (not (not y-p)) z (not (not z-p))))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) (10 1 nil 2 nil) (20 40 t 2 nil) (a b t c t)) (deftest flet.23 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) (list x y (not (not y-p)) z (not (not z-p)) r))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) (10 1 nil 2 nil nil) (20 40 t 2 nil nil) (a b t c t nil) (d e t f t (g h))) (deftest flet.24 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h) (%f 'd 'e 'f :bar 'i) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h) h nil) (d e t f t (:bar i) nil i)) (deftest flet.25 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar &allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :whatever nil) h nil) (d e t f t (:bar i :illegal t :foo z) z i)) (deftest flet.26 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :whatever nil :allow-other-keys t) h nil) (d e t f t (:bar i :illegal t :foo z :allow-other-keys t) z i)) ;;; Section 3.4.1.4.1: "The :allow-other-keys argument is permissible ;;; in all situations involving keyword[2] arguments, even when its ;;; associated value is false." (deftest flet.27 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :allow-other-keys nil) (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) (d e t f t (:foo h :allow-other-keys nil) h nil) (d e t f t (:bar i :allow-other-keys nil) nil i)) (deftest flet.28 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) (d e t f t 100 (:foo h :whatever nil :allow-other-keys 100) h nil) (d e t f t 200 (:bar i :illegal t :foo z :allow-other-keys 200) z i)) (deftest flet.29 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar allow-other-keys &allow-other-keys) (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys nil :zzz 10) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) (d e t f t nil (:foo h :whatever nil :allow-other-keys nil :blah t) h nil) (d e t f t nil (:bar i :illegal t :foo z :allow-other-keys nil :zzz 10) z i)) ;;; Tests of non-keyword keywords (see section 3.4.1.4, paragrph 2). (deftest flet.30 (flet ((%f (&key ((foo bar) nil)) bar)) (values (%f) (%f 'foo 10))) nil 10) (deftest flet.31 (flet ((%f (&key ((:foo bar) nil)) bar)) (values (%f) (%f :foo 10))) nil 10) ;;; Multiple keyword actual parameters (deftest flet.32 (flet ((%f (&key a b c) (list a b c))) (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) (10 20 30)) ;;; More aux parameters (deftest flet.33 (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) c)) (%f 5 9)) (5 9 6 20)) (deftest flet.34 (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) c)) (values (%f 1 2) (%f 1 2 :foo 'a) (%f 1 2 :bar 'b) (%f 1 2 :foo 'a :bar 'b) (%f 1 2 :bar 'b :foo 'a))) (1 2 nil nil nil) (1 2 (:foo a) a nil) (1 2 (:bar b) nil b) (1 2 (:foo a :bar b) a b) (1 2 (:bar b :foo a) a b)) ;;; Binding of formal parameters that are also special variables (deftest flet.35 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (x) (declare (special x)) (%f))) (%g 'good)))) good) (deftest flet.36 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&aux (x 'good)) (declare (special x)) (%f))) (%g)))) good) (deftest flet.37 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&rest x) (declare (special x)) (%f))) (%g 'good)))) (good)) (deftest flet.38 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'good)) (declare (special x)) (%f))) (%g)))) good) (deftest flet.39 (let ((x 'bad)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) (declare (special x)) (%f))) (%g :x 'good)))) good) (deftest flet.40 (let ((x 'good)) (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) (%f))) (%g :x 'worse)))) good) ;;; Test that [:&]allow-other-keys suppress errors for illegal keywords ;;; or odd numbers of keyword arguments ;;; Note -- These are apparently bad tests! -- PFD ;;;(deftest flet.41 ;;; (classify-error ;;; (flet ((%f (&key (a :good)) a)) ;;; (%f :allow-other-keys t :b))) ;;; :good) ;;; ;;;(deftest flet.42 ;;; (classify-error ;;; (flet ((%f (&key (a :good)) a)) ;;; (%f :allow-other-keys t 10 20))) ;;; :good) ;;; ;;;(deftest flet.43 ;;; (classify-error ;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) ;;; (%f :b))) ;;; :good) ;;; ;;;(deftest flet.44 ;;; (classify-error ;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) ;;; (%f 10 20))) ;;; :good) (deftest flet.45 (flet ((nil () 'a)) (nil)) a) (deftest flet.46 (flet ((t () 'b)) (t)) b) ;;; Keywords can be function names (deftest flet.47 (flet ((:foo () 'bar)) (:foo)) bar) (deftest flet.48 (flet ((:foo () 'bar)) (funcall #':foo)) bar) (deftest flet.49 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet ((,s () 'a)) (,s))) unless (eq (eval form) 'a) collect s) nil) (deftest flet.50 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet ((,s () 'a)) (declare (ftype (function () symbol) ,s)) (,s))) unless (eq (eval form) 'a) collect s) nil) ;;; Binding SETF functions of certain COMMON-LISP symbols (deftest flet.51 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (flet (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) gcl-2.6.14/ansi-tests/vector.lsp0000644000175000017500000001451214360276512015112 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 23 06:32:02 2003 ;;;; Contains: Tests of VECTOR (type and function) (in-package :cl-test) ;;; More tests of type vector in make-array.lsp (deftest vector.type.1 (notnot-mv (typep #(a b c) 'vector)) t) (deftest vector.type.2 (notnot-mv (typep #() 'vector)) t) (deftest vector.type.3 (notnot-mv (typep "" 'vector)) t) (deftest vector.type.4 (notnot-mv (typep "abcdef" 'vector)) t) (deftest vector.type.5 (notnot-mv (typep #* 'vector)) t) (deftest vector.type.6 (notnot-mv (typep #*011011101011 'vector)) t) (deftest vector.type.7 (typep #0aNIL 'vector) nil) (deftest vector.type.8 (typep #2a((a b c d)) 'vector) nil) (deftest vector.type.9 (subtypep* 'vector 'array) t t) (deftest vector.type.10 (notnot-mv (typep #(a b c) '(vector *))) t) (deftest vector.type.11 (notnot-mv (typep #(a b c) '(vector t))) t) (deftest vector.type.12 (notnot-mv (typep "abcde" '(vector *))) t) (deftest vector.type.13 (typep "abcdef" '(vector t)) nil) (deftest vector.type.14 (notnot-mv (typep #*00110 '(vector *))) t) (deftest vector.type.15 (typep #*00110 '(vector t)) nil) (deftest vector.type.16 (notnot-mv (typep #(a b c) '(vector * 3))) t) (deftest vector.type.17 (typep #(a b c) '(vector * 2)) nil) (deftest vector.type.18 (typep #(a b c) '(vector * 4)) nil) (deftest vector.type.19 (notnot-mv (typep #(a b c) '(vector t 3))) t) (deftest vector.type.20 (typep #(a b c) '(vector t 2)) nil) (deftest vector.type.21 (typep #(a b c) '(vector t 4)) nil) (deftest vector.type.23 (notnot-mv (typep #(a b c) '(vector t *))) t) (deftest vector.type.23a (notnot-mv (typep "abcde" '(vector * 5))) t) (deftest vector.type.24 (typep "abcde" '(vector * 4)) nil) (deftest vector.type.25 (typep "abcde" '(vector * 6)) nil) (deftest vector.type.26 (notnot-mv (typep "abcde" '(vector * *))) t) (deftest vector.type.27 (typep "abcde" '(vector t 5)) nil) (deftest vector.type.28 (typep "abcde" '(vector t 4)) nil) (deftest vector.type.29 (typep "abcde" '(vector t 6)) nil) (deftest vector.type.30 (typep "abcde" '(vector t *)) nil) (deftest vector.type.31 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector base-char)))) t) (deftest vector.type.32 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector base-char 3)))) t) (deftest vector.type.33 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector base-char 2))) nil) (deftest vector.type.34 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector base-char 4))) nil) (deftest vector.type.35 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s 'vector))) t) (deftest vector.type.36 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector *)))) t) (deftest vector.type.37 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector * 3)))) t) (deftest vector.type.38 (let ((s (coerce "abc" 'simple-base-string))) (notnot-mv (typep s '(vector * *)))) t) (deftest vector.type.39 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector t))) nil) (deftest vector.type.40 (let ((s (coerce "abc" 'simple-base-string))) (typep s '(vector t *))) nil) (deftest vector.type.41 (notnot-mv (typep (make-array '10 :element-type 'short-float) 'vector)) t) (deftest vector.type.42 (notnot-mv (typep (make-array '10 :element-type 'single-float) 'vector)) t) (deftest vector.type.43 (notnot-mv (typep (make-array '10 :element-type 'double-float) 'vector)) t) (deftest vector.type.44 (notnot-mv (typep (make-array '10 :element-type 'long-float) 'vector)) t) ;;; Tests of vector as class (deftest vector-as-class.1 (notnot-mv (find-class 'vector)) t) (deftest vector-as-class.2 (notnot-mv (typep #() (find-class 'vector))) t) (deftest vector-as-class.3 (notnot-mv (typep #(a b c) (find-class 'vector))) t) (deftest vector-as-class.4 (notnot-mv (typep "" (find-class 'vector))) t) (deftest vector-as-class.5 (notnot-mv (typep "abcd" (find-class 'vector))) t) (deftest vector-as-class.6 (notnot-mv (typep #* (find-class 'vector))) t) (deftest vector-as-class.7 (notnot-mv (typep #*01101010100 (find-class 'vector))) t) (deftest vector-as-class.8 (typep #0aNIL (find-class 'vector)) nil) (deftest vector-as-class.9 (typep #2a((a b)(c d)) (find-class 'vector)) nil) (deftest vector-as-class.10 (typep (make-array '(1 0)) (find-class 'vector)) nil) (deftest vector-as-class.11 (typep (make-array '(0 1)) (find-class 'vector)) nil) (deftest vector-as-class.12 (typep 1 (find-class 'vector)) nil) (deftest vector-as-class.13 (typep nil (find-class 'vector)) nil) (deftest vector-as-class.14 (typep 'x (find-class 'vector)) nil) (deftest vector-as-class.15 (typep '(a b c) (find-class 'vector)) nil) (deftest vector-as-class.16 (typep 10.0 (find-class 'vector)) nil) (deftest vector-as-class.17 (typep 3/5 (find-class 'vector)) nil) (deftest vector-as-class.18 (typep (1+ most-positive-fixnum) (find-class 'vector)) nil) ;;;; Tests of the function VECTOR (deftest vector.1 (vector) #()) (deftest vector.2 (vector 1 2 3) #(1 2 3)) (deftest vector.3 (let* ((len (min 1000 (1- call-arguments-limit))) (args (make-int-list len)) (v (apply #'vector args))) (and (typep v '(vector t)) (typep v '(vector t *)) (typep v `(vector t ,len)) (typep v 'simple-vector) (typep v `(simple-vector ,len)) (eql (length v) len) (loop for i from 0 for e across v always (eql i e)) t)) t) (deftest vector.4 (notnot-mv (typep (vector) '(vector t 0))) t) (deftest vector.5 (notnot-mv (typep (vector) 'simple-vector)) t) (deftest vector.6 (notnot-mv (typep (vector) '(simple-vector 0))) t) (deftest vector.7 (notnot-mv (typep (vector 1 2 3) 'simple-vector)) t) (deftest vector.8 (notnot-mv (typep (vector 1 2 3) '(simple-vector 3))) t) (deftest vector.9 (typep (vector #\a #\b #\c) 'string) nil) (deftest vector.10 (notnot-mv (typep (vector 1 2 3) '(simple-vector *))) t) (deftest vector.order.1 (let ((i 0) a b c) (values (vector (setf a (incf i)) (setf b (incf i)) (setf c (incf i))) i a b c)) #(1 2 3) 3 1 2 3) gcl-2.6.14/ansi-tests/packages-18.lsp0000644000175000017500000000447214360276512015620 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:07:31 1998 ;;;; Contains: Package test code, part 18 (in-package :cl-test) (declaim (optimize (safety 3))) (declaim (special *universe*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; packagep, typep * 'package (deftest packagep.1 (loop for x in *universe* count (unless (eqt (not (packagep x)) (not (typep x 'package))) (format t "(packagep ~S) = ~S, (typep x 'package) = ~S~%" x (packagep x) x (typep x 'package)) t)) 0) ;;; *package* is always a package (deftest packagep.2 (not-mv (packagep *package*)) nil) (deftest packagep.error.1 (classify-error (packagep)) program-error) (deftest packagep.error.2 (classify-error (packagep nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error (deftest package-error.1 (not (typep (make-condition 'package-error :package "CL") 'package-error)) nil) (deftest package-error.2 (not (typep (make-condition 'package-error :package (find-package "CL")) 'package-error)) nil) (deftest package-error.3 (subtypep* 'package-error 'error) t t) (deftest package-error.4 (not (typep (make-condition 'package-error :package (find-package '#:|CL|)) 'package-error)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error-package (deftest package-error-package.1 (eqt (find-package (package-error-package (make-condition 'package-error :package "CL"))) (find-package "CL")) t) (deftest package-error-package.2 (eqt (find-package (package-error-package (make-condition 'package-error :package (find-package "CL")))) (find-package "CL")) t) (deftest package-error-package.3 (eqt (find-package (package-error-package (make-condition 'package-error :package '#:|CL|))) (find-package "CL")) t) (deftest package-error-package.4 (eqt (find-package (package-error-package (make-condition 'package-error :package #\A))) (find-package "A")) t) (deftest package-error-package.error.1 (classify-error (package-error-package)) program-error) (deftest package-error-package.error.2 (classify-error (package-error-package (make-condition 'package-error :package #\A) nil)) program-error) gcl-2.6.14/ansi-tests/warn.lsp0000644000175000017500000000703714360276512014563 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 23 20:48:12 2003 ;;;; Contains: Tests for WARN (in-package :cl-test) (deftest warn.1 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.2 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.3 (with-output-to-string (*error-output*) (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (warn "Foo!")))) "") (deftest warn.4 (let ((str (with-output-to-string (*error-output*) (warn "Foo!")))) (not (string= str ""))) t) (deftest warn.5 (let ((warned nil)) (handler-bind ((simple-warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.6 (let ((warned nil)) (handler-bind ((simple-condition #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.7 (let ((warned nil)) (handler-bind ((condition #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) (nil) t) (deftest warn.8 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn 'simple-warning :format-control "Foo!")) warned))) (nil) t) (deftest warn.9 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn 'warning)) warned))) (nil) t) (deftest warn.10 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'simple-warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'simple-warning :format-control "Foo!"))) warned))) (nil) t) (deftest warn.11 (let ((warned nil)) (handler-bind ((warning #'(lambda (c) (assert (typep c 'warning)) (setf warned t) (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'warning))) warned))) (nil) t) (deftest warn.12 (classify-error (warn 'condition)) type-error) (deftest warn.13 (classify-error (warn 'simple-condition)) type-error) (deftest warn.14 (classify-error (warn (make-condition 'simple-warning) :format-control "Foo")) type-error) (deftest warn.15 (classify-error (warn)) program-error) (deftest warn.16 (classify-error (warn (make-condition 'condition))) type-error) (deftest warn.17 (classify-error (warn (make-condition 'simple-condition))) type-error) (deftest warn.18 (classify-error (warn (make-condition 'simple-error))) type-error) gcl-2.6.14/ansi-tests/structures-02.lsp0000644000175000017500000002625514360276512016261 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun May 3 22:46:54 1998 ;;;; Contains: Test code for structures, part 02 (in-package :cl-test) (declaim (optimize (safety 3))) ;; Test initializers for fields (defvar *s-2-f6-counter* 0) (defstruct s-2 (f1 0) (f2 'a) (f3 1.21) (f4 #\d) (f5 (list 'a 'b)) (f6 (incf *s-2-f6-counter*))) ;; Standard structure tests ;; Fields have appropriate values (deftest structure-2-1 (let ((*s-2-f6-counter* 0)) (let ((s (make-s-2))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1)))) t) ;; Two successive invocations of make-s-2 return different objects (deftest structure-2-2 (let ((*s-2-f6-counter* 0)) (eqt (s-2-f5 (make-s-2)) (s-2-f5 (make-s-2)))) nil) ;; Creation with various fields does the right thing (deftest structure-2-3 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f1 17))) (and (eqlt (s-2-f1 s) 17) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-4 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f2 'z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'z) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-5 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f3 1.0))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.0) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-6 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f4 #\z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\z) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-7 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f5 '(c d e)))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(c d e)) (eqlt (s-2-f6 s) *s-2-f6-counter*) (eqlt *s-2-f6-counter* 1))) t) (deftest structure-2-8 (let* ((*s-2-f6-counter* 0) (s (make-s-2 :f6 10))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) (= (s-2-f3 s) 1.21) (eqlt (s-2-f4 s) #\d) (equalt (s-2-f5 s) '(a b)) (eqlt (s-2-f6 s) 10) (eqlt *s-2-f6-counter* 0))) t) ;;; Tests using the defstruct-with-tests infrastructure (defstruct-with-tests struct-test-03 a b c d) (defstruct-with-tests (struct-test-04) a b c) (defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05) (defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06) (defstruct-with-tests (struct-test-07 :conc-name) a07 b07) (defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08) (defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09) (defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10) (defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11) (defstruct-with-tests (struct-test-12 (:conc-name BLAH-)) a12 b12) (defstruct-with-tests (struct-test-13 (:conc-name #\X)) foo-a13 foo-b13) (defstruct-with-tests (struct-test-14 (:predicate)) a14 b14) (defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15) (defstruct-with-tests (struct-test-16 :predicate) a16 b16) (defstruct-with-tests (struct-test-17 (:predicate struct-test-17-alternate-pred)) a17 b17) (defstruct-with-tests (struct-test-18 :copier) a18 b18) (defstruct-with-tests (struct-test-19 (:copier)) a19 b19) (defstruct-with-tests (struct-test-20 (:copier nil)) a20 b20) (defstruct-with-tests (struct-test-21 (:copier struct-test-21-alt-copier)) a21 b21) (defstruct-with-tests struct-test-22 (a22) (b22)) (defstruct-with-tests struct-test-23 (a23 1) (b23 2)) (defstruct-with-tests struct-test-24 (a24 1 :type fixnum) (b24 2 :type integer)) (defstruct-with-tests struct-test-25) (defstruct-with-tests struct-test-26 (a26 nil :read-only nil) (b26 'a :read-only nil)) (defstruct-with-tests struct-test-27 (a27 1 :read-only t) (b27 1.4 :read-only a)) (defstruct-with-tests struct-test-28 (a28 1 :type integer :read-only t) (b28 'xx :read-only a :type symbol)) (defstruct-with-tests struct-test-29 a29 (b29 'xx :read-only 1) c29) (defstruct-with-tests struct-test-30 #:a30 #:b30) (defstruct-with-tests #:struct-test-31 a31 b31) (defpackage struct-test-package (:use)) (defstruct-with-tests struct-test-32 struct-test-package::a32 struct-test-package::b32) ;;; If the :conc-name option is given no argument or ;;; a nil argument, the accessor names are the same as ;;; slot names. Note that this is different from prepending ;;; an empty string, since that may get you a name in ;;; a different package. (defstruct-with-tests (struct-test-33 (:conc-name)) struct-test-package::a33 struct-test-package::b33) (defstruct-with-tests (struct-test-34 :conc-name) struct-test-package::a34 struct-test-package::b34) (defstruct-with-tests (struct-test-35 (:conc-name nil)) struct-test-package::a35 struct-test-package::b35) (defstruct-with-tests (struct-test-36 (:conc-name "")) struct-test-package::st36-a36 struct-test-package::st26-b36) ;;; List and vector structures (defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) (deftest structure-37-1 (make-struct-test-37 :a37 1 :b37 2 :c37 4) (1 2 4)) (defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) (deftest structure-38-1 (make-struct-test-38 :a38 11 :b38 12 :c38 4) (struct-test-38 11 12 4)) (defstruct-with-tests (struct-test-39 (:predicate nil) (:type list) :named) a39 b39 c39) (deftest structure-39-1 (make-struct-test-39 :a39 11 :b39 12 :c39 4) (struct-test-39 11 12 4)) (defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) (defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) (defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42) (defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43) (defstruct-with-tests (struct-test-44 (:type list)) (a44 0 :type integer) (b44 'a :type symbol)) ;;; Confirm that the defined structure types are all disjoint (deftest structs-are-disjoint (loop for s1 in *defstruct-with-tests-names* sum (loop for s2 in *defstruct-with-tests-names* unless (eq s1 s2) count (not (equalt (multiple-value-list (subtypep* s1 s2)) '(nil t))))) 0) (defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2)) a45 b45) (deftest structure-45-1 (cddr (make-struct-test-45 :a45 1 :b45 2)) (1 2)) (defstruct-with-tests (struct-test-46 (:type list) (:include struct-test-45)) c46 d46) (deftest structure-46-1 (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4)) (1 2 3 4)) (defstruct-with-tests (struct-test-47 (:type list) (:initial-offset 3) (:include struct-test-45)) c47 d47) (deftest structure-47-1 (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4))) (values (third s) (fourth s) (eighth s) (ninth s))) 1 2 3 4) (defstruct-with-tests (struct-test-48 (:type list) (:initial-offset 0) (:include struct-test-45)) c48 d48) (deftest structure-48-1 (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4)) (1 2 3 4)) (defstruct-with-tests (struct-test-49 (:type (vector bit))) (a49 0 :type bit) (b49 0 :type bit)) (defstruct-with-tests (struct-test-50 (:type (vector character))) (a50 #\g :type character) (b50 #\k :type character)) (defstruct-with-tests (struct-test-51 (:type (vector (integer 0 255)))) (a51 17 :type (integer 0 255)) (b51 25 :type (integer 0 255))) (defstruct-with-tests (struct-test-52 (:type vector) (:initial-offset 0)) a52 b52) (defstruct-with-tests (struct-test-53 (:type vector) (:initial-offset 5)) "This is struct-test-53" a53 b53) (deftest structure-53-1 (let ((s (make-struct-test-53 :a53 10 :b53 'a))) (values (aref s 5) (aref s 6))) 10 a) (defstruct-with-tests (struct-test-54 (:type vector) (:initial-offset 2) (:include struct-test-53)) "This is struct-test-54" a54 b54) (deftest structure-54-1 (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a))) (values (aref s 5) (aref s 6) (aref s 9) (aref s 10))) 8 g 10 a) (defstruct-with-tests (struct-test-55 (:type list) (:initial-offset 2) :named) a55 b55 c55) (deftest structure-55-1 (let ((s (make-struct-test-55 :a55 'p :c55 'q))) (values (third s) (fourth s) (sixth s))) struct-test-55 p q) (defstruct-with-tests (struct-test-56 (:type list) (:initial-offset 3) (:include struct-test-55) :named) d56 e56) (deftest structure-56-1 (let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y))) (mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11))) (struct-test-55 3 7 struct-test-56 x y)) (defstruct-with-tests (struct-test-57 (:include struct-test-22)) c57 d57) (defstruct-with-tests struct-test-58 "This is struct-test-58" a-58 b-58) (defstruct-with-tests (struct-test-59 (:include struct-test-58)) "This is struct-test-59" a-59 b-59) ;;; When a field name of a structure is also a special variable, ;;; the constructor must not bind that name. (defvar *st-60* 100) (defstruct-with-tests struct-test-60 (a60 *st-60* :type integer) (*st-60* 0 :type integer) (b60 *st-60* :type integer)) (deftest structure-60-1 (let ((*st-60* 10)) (let ((s (make-struct-test-60 :*st-60* 200))) (values (struct-test-60-a60 s) (struct-test-60-*st-60* s) (struct-test-60-b60 s)))) 10 200 10) ;;; When default initializers of the wrong type are given, they do not ;;; cause an error unless actually invoked (defstruct struct-test-61 (a nil :type integer) (b 0 :type symbol)) (deftest structure-61-1 (let ((s (make-struct-test-61 :a 10 :b 'c))) (values (struct-test-61-a s) (struct-test-61-b s))) 10 c) ;;; Initializer forms are evaluated only when needed, and are ;;; evaluated in the lexical environment in which they were defined (eval-when (load eval) (let ((x nil)) (flet ((%f () x) (%g (y) (setf x y))) (defstruct struct-test-62 (a (progn (setf x 'a) nil)) (f #'%f) (g #'%g))))) (deftest structure-62-1 (let* ((s (make-struct-test-62 :a 1)) (f (struct-test-62-f s))) (values (struct-test-62-a s) (funcall f))) 1 nil) (deftest structure-62-2 (let* ((s (make-struct-test-62)) (f (struct-test-62-f s)) (g (struct-test-62-g s))) (values (struct-test-62-a s) (funcall f) (funcall g nil) (funcall f))) nil a nil nil) ;;; Keywords are allowed in defstruct (defstruct-with-tests :struct-test-63 a63 b63 c63) (defstruct-with-tests struct-test-64 :a63 :b63 :c63) ;;; Error tests (deftest copy-structure.error.1 (classify-error (copy-structure)) program-error) (deftest copy-structure.error.2 (classify-error (copy-structure (make-s-2) nil)) program-error) gcl-2.6.14/ansi-tests/cons-test-15.lsp0000644000175000017500000003274614360276512015763 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:40:12 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 15 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapc (deftest mapc.1 (mapc #'list nil) nil) (deftest mapc.2 (let ((x 0)) (let ((result (mapc #'(lambda (y) (incf x y)) '(1 2 3 4)))) (list result x))) ((1 2 3 4) 10)) (deftest mapc.3 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 5 )) x)) ((a a a a a) 5)) (deftest mapc.4 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 10)) x)) ((a a a a a) 5)) (deftest mapc.5 (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) (make-list 5 :initial-element 'a) (make-list 3)) x)) ((a a a a a) 3)) (defvar *mapc.6-var* nil) (defun mapc.6-fun (x) (push x *mapc.6-var*) x) (deftest mapc.6 (let* ((x (copy-list '(a b c d e f g h))) (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapc 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) (eqt result x) *mapc.6-var*))) (h g f e d c b a)) (deftest mapc.order.1 (let ((i 0) x y z) (values (mapc (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a b c) 3 1 2 3) (deftest mapc.error.1 (classify-error (mapc #'identity 1)) type-error) (deftest mapc.error.2 (classify-error (mapc)) program-error) (deftest mapc.error.3 (classify-error (mapc #'append)) program-error) (deftest mapc.error.4 (classify-error (locally (mapc #'identity 1) t)) type-error) (deftest mapc.error.5 (classify-error (mapc #'cons '(a b c))) program-error) (deftest mapc.error.6 (classify-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest mapc.error.7 (classify-error (mapc #'car '(a b c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcar (deftest mapcar.1 (mapcar #'1+ nil) nil) (deftest mapcar.2 (let* ((x (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x))) (let ((result (mapcar #'1+ x))) (and (check-scaffold-copy x xcopy) result))) (2 3 4 5)) (deftest mapcar.3 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x))) (let ((result (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) x))) (and (check-scaffold-copy x xcopy) result))) (1 2 3 4)) (deftest mapcar.4 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x)) (x2 (copy-list '(a b c d e f))) (x2copy (make-scaffold-copy x2)) (result (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) x x2))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy x2 x2copy) (list result n))) ((1 2 3 4) 4)) (deftest mapcar.5 (let* ((n 0) (x (copy-list '(a b c d))) (xcopy (make-scaffold-copy x)) (x2 (copy-list '(a b c d e f))) (x2copy (make-scaffold-copy x2)) (result (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) x2 x))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy x2 x2copy) (list result n))) ((1 2 3 4) 4)) (deftest mapcar.6 (let* ((x (copy-list '(a b c d e f g h))) (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapcar 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) (list *mapc.6-var* result)))) ((h g f e d c b a) (a b c d e f g h))) (deftest mapcar.order.1 (let ((i 0) x y z) (values (mapcar (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) ((a 1) (b 2) (c 3)) 3 1 2 3) (deftest mapcar.error.1 (classify-error (mapcar #'identity 1)) type-error) (deftest mapcar.error.2 (classify-error (mapcar)) program-error) (deftest mapcar.error.3 (classify-error (mapcar #'append)) program-error) (deftest mapcar.error.4 (classify-error (locally (mapcar #'identity 1) t)) type-error) (deftest mapcar.error.5 (classify-error (mapcar #'car '(a b c))) type-error) (deftest mapcar.error.6 (classify-error (mapcar #'cons '(a b c))) program-error) (deftest mapcar.error.7 (classify-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcan (deftest mapcan.1 (mapcan #'list nil) nil) (deftest mapcan.2 (mapcan #'list (copy-list '(a b c d e f))) (a b c d e f)) (deftest mapcan.3 (let* ((x (list 'a 'b 'c 'd)) (xcopy (make-scaffold-copy x)) (result (mapcan #'list x))) (and (= (length x) (length result)) (check-scaffold-copy x xcopy) (loop for e1 on x and e2 on result count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) 0) (deftest mapcan.4 (mapcan #'list (copy-list '(1 2 3 4)) (copy-list '(a b c d))) (1 a 2 b 3 c 4 d)) (deftest mapcan.5 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d)) (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (defvar *mapcan.6-var* nil) (defun mapcan.6-fun (x) (push x *mapcan.6-var*) (copy-list *mapcan.6-var*)) (deftest mapcan.6 (progn (setf *mapcan.6-var* nil) (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) (a b a c b a d c b a)) (deftest mapcan.order.1 (let ((i 0) x y z) (values (mapcan (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) (deftest mapcan.8 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d)) (copy-list '(1 2 3 4 5 6))) (a b b c c c d d d d)) (deftest mapcan.9 (mapcan #'(lambda (x y) (make-list y :initial-element x)) (copy-list '(a b c d e f)) (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (deftest mapcan.10 (mapcan #'list (copy-list '(a b c d)) (copy-list '(1 2 3 4)) nil) nil) (deftest mapcan.11 (mapcan (constantly 1) (list 'a)) 1) (deftest mapcan.error.1 (classify-error (mapcan #'identity 1)) type-error) (deftest mapcan.error.2 (classify-error (mapcan)) program-error) (deftest mapcan.error.3 (classify-error (mapcan #'append)) program-error) (deftest mapcan.error.4 (classify-error (locally (mapcan #'identity 1) t)) type-error) (deftest mapcan.error.5 (classify-error (mapcan #'car '(a b c))) type-error) (deftest mapcan.error.6 (classify-error (mapcan #'cons '(a b c))) program-error) (deftest mapcan.error.7 (classify-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapl (deftest mapl.1 (mapl #'list nil) nil) (deftest mapl.2 (let* ((a nil) (x (copy-list '(a b c))) (xcopy (make-scaffold-copy x)) (result (mapl #'(lambda (y) (push y a)) x))) (and (check-scaffold-copy x xcopy) (eqt result x) a)) ((c) (b c) (a b c))) (deftest mapl.3 (let* ((a nil) (x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.4 (let* ((a nil) (x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4 5 6 7 8))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.5 (let* ((a nil) (x (copy-list '(a b c d e f g))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapl #'(lambda (xtail ytail) (setf a (append (mapcar #'list xtail ytail) a))) x y))) (and (eqt result x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) a)) ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) (a 1) (b 2) (c 3) (d 4))) (deftest mapl.order.1 (let ((i 0) x y z) (values (mapl (progn (setf x (incf i)) (constantly nil)) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a b c) 3 1 2 3) (deftest mapl.error.1 (classify-error (mapl #'identity 1)) type-error) (deftest mapl.error.2 (classify-error (mapl)) program-error) (deftest mapl.error.3 (classify-error (mapl #'append)) program-error) (deftest mapl.error.4 (classify-error (locally (mapl #'identity 1) t)) type-error) (deftest mapl.error.5 (classify-error (mapl #'cons '(a b c))) program-error) (deftest mapl.error.6 (classify-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest mapl.error.7 (classify-error (mapl #'caar '(a b c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; maplist (deftest maplist.1 (maplist #'list nil) nil) (deftest maplist.2 (let* ((x (copy-list '(a b c))) (xcopy (make-scaffold-copy x)) (result (maplist #'identity x))) (and (check-scaffold-copy x xcopy) result)) ((a b c) (b c) (c))) (deftest maplist.3 (let* ((x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d 1 2 3 4) (b c d 2 3 4) (c d 3 4) (d 4))) (deftest maplist.4 (let* ((x (copy-list '(a b c d))) (y (copy-list '(1 2 3 4 5))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d 1 2 3 4 5) (b c d 2 3 4 5) (c d 3 4 5) (d 4 5))) (deftest maplist.5 (let* ((x (copy-list '(a b c d e))) (y (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) ((a b c d e 1 2 3 4) (b c d e 2 3 4) (c d e 3 4) (d e 4))) (deftest maplist.6 (maplist 'append '(a b c) '(1 2 3)) ((a b c 1 2 3) (b c 2 3) (c 3))) (deftest maplist.7 (maplist #'(lambda (x y) (nth (car x) y)) '(0 1 0 1 0 1 0) '(a b c d e f g) ) (a c c e e g g)) (deftest maplist.order.1 (let ((i 0) x y z) (values (maplist (progn (setf x (incf i)) #'(lambda (x y) (declare (ignore x)) (car y))) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (1 2 3) 3 1 2 3) (deftest maplist.error.1 (classify-error (maplist #'identity 'a)) type-error) (deftest maplist.error.2 (classify-error (maplist #'identity 1)) type-error) (deftest maplist.error.3 (classify-error (maplist #'identity 1.1323)) type-error) (deftest maplist.error.4 (classify-error (maplist #'identity "abcde")) type-error) (deftest maplist.error.5 (classify-error (maplist)) program-error) (deftest maplist.error.6 (classify-error (maplist #'append)) program-error) (deftest maplist.error.7 (classify-error (locally (maplist #'identity 'a) t)) type-error) (deftest maplist.error.8 (classify-error (maplist #'caar '(a b c))) type-error) (deftest maplist.error.9 (classify-error (maplist #'cons '(a b c))) program-error) (deftest maplist.error.10 (classify-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mapcon (deftest mapcon.1 (mapcon #'(lambda (x) (append '(a) x nil)) nil) nil) (deftest mapcon.2 (let* ((x (copy-list '(1 2 3 4))) (xcopy (make-scaffold-copy x)) (result (mapcon #'(lambda (y) (append '(a) y nil)) x))) (and (check-scaffold-copy x xcopy) result)) (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) (deftest mapcon.3 (let* ((x (copy-list '(4 2 3 2 2))) (y (copy-list '(a b c d e f g h i j k l))) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) (result (mapcon #'(lambda (xt yt) (subseq yt 0 (car xt))) x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)) (a b c d b c c d e d e e f)) (deftest mapcon.4 (mapcon (constantly 1) (list 'a)) 1) (deftest mapcon.order.1 (let ((i 0) x y z) (values (mapcon (progn (setf x (incf i)) #'(lambda (x y) (list (car x) (car y)))) (progn (setf y (incf i)) '(a b c)) (progn (setf z (incf i)) '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) (deftest mapcon.error.1 (classify-error (mapcon #'identity 1)) type-error) (deftest mapcon.error.2 (classify-error (mapcon)) program-error) (deftest mapcon.error.3 (classify-error (mapcon #'append)) program-error) (deftest mapcon.error.4 (classify-error (locally (mapcon #'identity 1) t)) type-error) (deftest mapcon.error.5 (classify-error (mapcon #'caar '(a b c))) type-error) (deftest mapcon.error.6 (classify-error (mapcon #'cons '(a b c))) program-error) (deftest mapcon.error.7 (classify-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) gcl-2.6.14/ansi-tests/find-if-not.lsp0000644000175000017500000003465214360276512015731 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 20:53:24 2002 ;;;; Contains: Tests for FIND-IF-NOT (in-package :cl-test) (deftest find-if-not-list.1 (find-if-not #'identity ()) nil) (deftest find-if-not-list.2 (find-if-not #'null '(a)) a) (deftest find-if-not-list.2a (find-if-not 'null '(a)) a) (deftest find-if-not-list.3 (find-if-not #'oddp '(1 2 4 8 3 1 6 7)) 2) (deftest find-if-not-list.4 (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-not-list.5 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.6 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.7 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.8 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.9 (loop for i from 0 to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-list.10 (loop for i from 0 to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-list.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.13 (loop for i from 0 to 6 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-list.14 (loop for i from 0 to 6 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-list.15 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-list.16 (loop for i from 0 to 7 collect (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-list.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-list.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; tests for vectors (deftest find-if-not-vector.1 (find-if-not #'identity #()) nil) (deftest find-if-not-vector.2 (find-if-not #'not #(a)) a) (deftest find-if-not-vector.2a (find-if-not 'null #(a)) a) (deftest find-if-not-vector.3 (find-if-not #'oddp #(1 2 4 8 3 1 6 7)) 2) (deftest find-if-not-vector.4 (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :from-end t) 6) (deftest find-if-not-vector.5 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.6 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.7 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.8 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.9 (loop for i from 0 to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-vector.10 (loop for i from 0 to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-vector.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.13 (loop for i from 0 to 6 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-vector.14 (loop for i from 0 to 6 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-vector.15 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-vector.16 (loop for i from 0 to 7 collect (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-vector.17 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) (8 8 8 8 8) (nil nil 6 6) (nil 6 6) (6 6) (nil))) (deftest find-if-not-vector.18 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) (8 8 8 6 6) (nil nil 6 6) (nil 6 6) (6 6) (nil))) ;;; Tests for bit vectors (deftest find-if-not-bit-vector.1 (find-if-not #'identity #*) nil) (deftest find-if-not-bit-vector.2 (find-if-not #'null #*1) 1) (deftest find-if-not-bit-vector.3 (find-if-not #'not #*0) 0) (deftest find-if-not-bit-vector.4 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'oddp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.5 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'oddp #*0110110 :start i :end j :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.6 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'evenp #*0110110 :start i :end j :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) (deftest find-if-not-bit-vector.7 (loop for i from 0 to 6 collect (loop for j from i to 7 collect (find-if-not #'evenp #*0110110 :start i :end j :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) (nil 0 0 0 0) (nil nil nil 0) (nil nil 0) (nil 0))) ;;; Tests for strings (deftest find-if-not-string.1 (find-if-not #'identity "") nil) (deftest find-if-not-string.2 (find-if-not #'null "a") #\a) (deftest find-if-not-string.2a (find-if-not 'null "a") #\a) (deftest find-if-not-string.3 (find-if-not #'odddigitp "12483167") #\2) (deftest find-if-not-string.3a (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) (deftest find-if-not-string.4 (find-if-not #'odddigitp "12483167" :from-end t) #\6) (deftest find-if-not-string.5 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.6 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.7 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.8 (loop for i from 0 to 7 collect (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.9 (loop for i from 0 to 8 collect (find-if-not #'odddigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-not-string.10 (loop for i from 0 to 8 collect (find-if-not #'odddigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.11 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'odddigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) (#\8 #\8 #\8 #\8 #\8) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-not-string.12 (loop for j from 0 to 7 collect (loop for i from (1+ j) to 8 collect (find-if-not #'odddigitp "12483167" :start j :end i :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) (#\8 #\8 #\8 #\6 #\6) (nil nil #\6 #\6) (nil #\6 #\6) (#\6 #\6) (nil))) (deftest find-if-not-string.13 (loop for i from 0 to 6 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.14 (loop for i from 0 to 6 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-not-string.15 (loop for i from 0 to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-not-string.16 (loop for i from 0 to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-not-string.17 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) (#\6))) (deftest find-if-not-string.18 (loop for j from 0 to 6 collect (loop for i from (1+ j) to 7 collect (find-if-not #'oddp "1473816" :key (compose #'read-from-string #'string) :start j :end i :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) (nil #\8 #\8 #\6) (#\8 #\8 #\6) (nil #\6) (#\6))) ;;; Keyword tests (deftest find-if-not.allow-other-keys.1 (find-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest find-if-not.allow-other-keys.2 (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if-not.allow-other-keys.3 (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find-if-not.keywords.4 (find-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find-if-not.allow-other-keys.5 (find-if-not #'null '(nil a b c nil) :allow-other-keys nil) a) ;;; Error tests (deftest find-if-not.error.1 (classify-error (find-if-not #'null 'b)) type-error) (deftest find-if-not.error.2 (classify-error (find-if-not #'identity 10)) type-error) (deftest find-if-not.error.3 (classify-error (find-if-not '1+ 1.4)) type-error) (deftest find-if-not.error.4 (classify-error (find-if-not 'identity '(a b c . d))) type-error) (deftest find-if-not.error.5 (classify-error (find-if-not)) program-error) (deftest find-if-not.error.6 (classify-error (find-if-not #'null)) program-error) (deftest find-if-not.error.7 (classify-error (find-if-not #'null nil :bad t)) program-error) (deftest find-if-not.error.8 (classify-error (find-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest find-if-not.error.9 (classify-error (find-if-not #'null nil 1 1)) program-error) (deftest find-if-not.error.10 (classify-error (find-if-not #'null nil :key)) program-error) (deftest find-if-not.error.11 (classify-error (locally (find-if-not #'null 'b) t)) type-error) (deftest find-if-not.error.12 (classify-error (find-if-not #'cons '(a b c))) program-error) (deftest find-if-not.error.13 (classify-error (find-if-not #'car '(a b c))) type-error) (deftest find-if-not.error.14 (classify-error (find-if-not #'identity '(a b c) :key #'cons)) program-error) (deftest find-if-not.error.15 (classify-error (find-if-not #'identity '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find-if-not.order.1 (let ((i 0) x y) (values (find-if-not (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find-if-not.order.2 (let ((i 0) a b c d e f g) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find-if-not.order.3 (let ((i 0) a b c d e f g) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl-2.6.14/ansi-tests/unless.lsp0000644000175000017500000000130114360276512015111 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:39:34 2002 ;;;; Contains: Tests of UNLESS (in-package :cl-test) (deftest unless.1 (unless t) nil) (deftest unless.2 (unless nil) nil) (deftest unless.3 (unless 'b 'a) nil) (deftest unless.4 (unless nil 'a) a) (deftest unless.5 (unless nil (values))) (deftest unless.6 (unless nil (values 1 2 3 4)) 1 2 3 4) (deftest unless.7 (unless 1 (values)) nil) (deftest unless.8 (unless #() (values 1 2 3 4)) nil) (deftest unless.9 (let ((x 0)) (values (unless nil (incf x) 'a) x)) a 1) ;;; (deftest unless.error.1 ;;; (classify-error (unless)) ;;; program-error) gcl-2.6.14/ansi-tests/packages-16.lsp0000644000175000017500000004167014360276512015617 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:09:18 1998 ;;;; Contains: Package test code, part 16 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; defpackage ;; Test basic defpackage call, with no options ;; The use-list is implementation dependent, so ;; we don't examine it here. ;; Try several ways of specifying the package name. (deftest defpackage.1 (loop for n in '("H" #:|H| #\H) count (not (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage ,n))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (null (documentation p t)) ))))) 0) ;; Test :nicknames option ;; Do not check use-list, because it is implementation dependent ;; Try several ways of specifying a nickname. (deftest defpackage.2 (loop for n in '("I" #:|I| #\I) count (not (ignore-errors (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:nicknames ,n "J")))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (sort (copy-list (package-nicknames p)) #'string<) '("I" "J")) (equal (package-shadowing-symbols p) nil) (null (documentation p t)) )))))) 0) ;; Test defpackage with documentation option ;; Do not check use-list, because it is implementation dependent (deftest defpackage.3 (progn (safely-delete-package "H") (ignore-errors (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) (and (packagep p) (equal (package-name p) "H") ;; (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) ;; The spec says implementations are free to discard ;; documentations, so this next form was wrong. ;; Instead, we'll just computation DOCUMENTATION ;; and throw away the value. ;; (equal (documentation p t) "This is a doc string") (progn (documentation p t) t) )))) t) ;; Check use argument ;; Try several ways of specifying the package to be used (deftest defpackage.4 (loop for n in '("A" :|A| #\A) count (not (ignore-errors (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) (and (packagep p) (equal (package-name p) "H") (equal (package-use-list p) (list (find-package "A"))) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) (num-external-symbols-in-package "A")) (equal (documentation p t) nil) )))))) 0) ;; Test defpackage shadow option, and null use (deftest defpackage.5 (progn (safely-delete-package "H") (ignore-errors (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadow "foo")))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "foo" p) (and (eqt access :internal) (equal (symbol-name sym) "foo") (equal (symbol-package sym) p) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))) (t t t t t t t t)) ;; Test defpackage shadow and null use, with several ways ;; of specifying the name of the shadowed symbol (deftest defpackage.6 (loop for s in '(:|f| #\f) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadow ,s)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "f" p) (and (eqt access :internal) (equal (symbol-name sym) "f") (equal (symbol-package sym) p) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))) ((t t t t t t t t) (t t t t t t t t))) ;; Testing defpackage with shadowing-import-from. ;; Test several ways of specifying the symbol name (deftest defpackage.7 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (make-package "G" :use nil))) ;; Populate package G with several symbols (export (intern "A" pg) pg) (export (intern "foo" pg) pg) (intern "bar" pg) ;; Do test with several ways of specifying the ;; shadowing-imported symbol (loop for n in '("A" :|A| #\A) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:shadowing-import-from "G" ,n)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind* (sym access) (find-symbol "A" p) (and (eqt access :internal) (equal (symbol-name sym) "A") (equal (symbol-package sym) pg) (equal (package-shadowing-symbols p) (list sym)))) (equal (documentation p t) nil) ))))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test import-from option ;; Test for each way of specifying the imported symbol name, ;; and for each way of specifying the package name from which ;; the symbol is imported (deftest defpackage.8 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) (loop for pn in '("G" #:|G| #\G) collect (loop for n in '("B" #:|B| #\B) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:use) (:import-from ,pn ,n "A")))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 2) (multiple-value-bind* (sym access) (find-symbol "A" p) (and (eqt access :internal) (equal (symbol-name sym) "A") (equal (symbol-package sym) pg))) (multiple-value-bind* (sym access) (find-symbol "B" p) (and (eqt access :internal) (equal (symbol-name sym) "B") (equal (symbol-package sym) pg))) (equal (documentation p t) nil) )))))))) (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) ;; Test defpackage with export option (deftest defpackage.9 (progn (loop for n in '("Z" #:|Z| #\Z) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:export "Q" ,n "R") (:use)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 3) (loop for s in '("Q" "Z" "R") do (unless (multiple-value-bind* (sym access) (find-symbol s p) (and (eqt access :external) (equal (symbol-name sym) s) (equal (symbol-package sym) p))) (return nil)) finally (return t)) )))))) ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) ;; Test defpackage with the intern option (deftest defpackage.10 (progn (loop for n in '("Z" #:|Z| #\Z) collect (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage "H" (:intern "Q" ,n "R") (:use)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (eql (num-symbols-in-package p) 3) (loop for s in '("Q" "Z" "R") do (unless (multiple-value-bind* (sym access) (find-symbol s p) (and (eqt access :internal) (equal (symbol-name sym) s) (equal (symbol-package sym) p))) (return nil)) finally (return t)) )))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test defpackage with size (deftest defpackage.11 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 0)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (zerop (num-symbols-in-package p)))))) (t t t t t t t)) (deftest defpackage.12 (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 10000)))))) (mapcar #'notnot (list (packagep p) (equal (package-name p) "H") (equal (package-use-list p) nil) (equal (package-used-by-list p) nil) (equal (package-nicknames p) nil) (equal (package-shadowing-symbols p) nil) (zerop (num-symbols-in-package p)))))) (t t t t t t t)) ;; defpackage error handling ;; Repeated size field should cause a program-error (deftest defpackage.13 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:size 10) (:size 20))))) program-error) ;; Repeated documentation field should cause a program-error (deftest defpackage.14 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:documentation "foo") (:documentation "bar"))))) program-error) ;; When a nickname refers to an existing package or nickname, ;; signal a package-error (deftest defpackage.15 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:nicknames "A"))))) package-error) (deftest defpackage.16 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:nicknames "Q"))))) package-error) ;; Names in :shadow, :shadowing-import-from, :import-from, and :intern ;; must be disjoint, or a package-error is signalled. ;; :shadow and :shadowing-import-from (deftest defpackage.17 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:shadowing-import-from "G" "A"))))) program-error) ;; :shadow and :import-from (deftest defpackage.18 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:import-from "G" "A"))))) program-error) ;; :shadow and :intern (deftest defpackage.19 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:shadow "A") (:intern "A"))))) program-error) ;; :shadowing-import-from and :import-from (deftest defpackage.20 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadowing-import-from "G" "A") (:import-from "G" "A"))))) program-error) ;; :shadowing-import-from and :intern (deftest defpackage.21 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:shadowing-import-from "G" "A") (:intern "A"))))) program-error) ;; :import-from and :intern (deftest defpackage.22 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use) (:export "A"))) (classify-error (eval '(defpackage "H" (:use) (:import-from "G" "A") (:intern "A"))))) program-error) ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error (deftest defpackage.23 (progn (safely-delete-package "H") (classify-error (eval '(defpackage "H" (:use) (:export "A") (:intern "A"))))) program-error) ;; :shadowing-import-from signals a correctable package-error ;; if the symbol is not accessible in the named package (deftest defpackage.24 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use))) (handle-non-abort-restart (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE"))))) success) ;; :import-from signals a correctable package-error if a symbol with ;; the indicated name is not accessible in the package indicated (deftest defpackage.25 (progn (safely-delete-package "H") (safely-delete-package "G") (eval '(defpackage "G" (:use))) (handle-non-abort-restart (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))))) success) ;; A big test that combines all the options to defpackage (deftest defpackage.26 (ignore-errors (flet ((%do-it% (args) (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (safely-delete-package "G3") (let ((pg1 (progn (format t "Making G1...~%") (eval '(defpackage "G1" (:use) (:export "A" "B" "C") (:intern "D" "E" "F"))))) (pg2 (progn (format t "Making G2...~%") (eval '(defpackage "G2" (:use) (:export "A" "D" "G") (:intern "E" "H" "I"))))) (pg3 (progn (format t "Making G3...~%") (eval '(defpackage "G3" (:use) (:export "J" "K" "L") (:intern "M" "N" "O")))))) (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) (prog () (unless (packagep p) (return 1)) (unless (equal (package-name p) "H") (return 2)) (unless (equal (package-name pg1) "G1") (return 3)) (unless (equal (package-name pg2) "G2") (return 4)) (unless (equal (package-name pg3) "G3") (return 5)) (unless (equal (sort (copy-list (package-nicknames p)) #'string<) '("H1" "H2")) (return 6)) (unless (or (equal (package-use-list p) (list pg1 pg2)) (equal (package-use-list p) (list pg2 pg1))) (return 7)) (unless (equal (package-used-by-list pg1) (list p)) (return 8)) (unless (equal (package-used-by-list pg2) (list p)) (return 9)) (when (package-used-by-list pg3) (return 10)) (unless (equal (sort (mapcar #'symbol-name (package-shadowing-symbols p)) #'string<) '("A" "B")) (return 10)) (let ((num 11)) (unless (every #'(lambda (str acc pkg) (multiple-value-bind* (sym access) (find-symbol str p) (or (and (or (not acc) (equal (symbol-name sym) str)) (or (not acc) (equal (symbol-package sym) pkg)) (equal access acc) (incf num)) (progn (format t "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" str acc pkg sym access) nil)))) (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O") (list :internal :internal :external :inherited nil nil :inherited :internal nil nil nil :external nil nil :internal) (list pg2 p pg1 pg2 nil nil pg2 p nil nil nil pg3 nil nil pg3)) (return num))) (return 'success)))))) (let ((args '((:nicknames "H1" "H2") (:use "G1" "G2") (:shadow "B") (:shadowing-import-from "G2" "A") (:import-from "G3" "L" "O") (:intern "D" "H") (:export "L" "C") (:size 20) (:documentation "A test package")))) (list (%do-it% args) (%do-it% (reverse args)))))) (success success)) gcl-2.6.14/ansi-tests/cons-test-22.lsp0000644000175000017500000003261114360276512015750 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Mar 30 22:10:34 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 22 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set-difference (deftest set-difference.1 (set-difference nil nil) nil) (deftest set-difference.2 (let ((result (set-difference-with-check '(a b c) nil))) (check-set-difference '(a b c) nil result)) t) (deftest set-difference.3 (let ((result (set-difference-with-check '(a b c d e f) '(f b d)))) (check-set-difference '(a b c d e f) '(f b d) result)) t) (deftest set-difference.4 (sort (copy-list (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) (deftest set-difference.5 (set-difference-with-check nil '(a b c d e f g h)) nil) (deftest set-difference.6 (set-difference-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest set-difference.7 (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest set-difference.8 (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest set-difference.9 (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest set-difference.10 (set-difference-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest set-difference.11 (set-difference-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest set-difference.12 (set-difference-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest set-difference.13 (do-random-set-differences 100 100) nil) (deftest set-difference.14 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key 'car) ((b . 2))) (deftest set-difference.15 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key #'car) ((b . 2))) ;; ;; Verify that the :test argument is called with the arguments ;; in the correct order ;; (deftest set-difference.16 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest set-difference.17 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest set-difference.18 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) (deftest set-difference.19 (block fail (sort (copy-list (set-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) ;;; Order of argument evaluation tests (deftest set-difference.order.1 (let ((i 0) x y) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) (deftest set-difference.order.2 (let ((i 0) x y z) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) (deftest set-difference.order.3 (let ((i 0) x y z w) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y)))) :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) ;;; Keyword tests (deftest set-difference.allow-other-keys.1 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :bad t :allow-other-keys t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.2 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.3 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) #'<) (4 5)) (deftest set-difference.allow-other-keys.4 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t)) #'<) (1 5)) (deftest set-difference.allow-other-keys.5 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys nil)) #'<) (1 5)) (deftest set-difference.allow-other-keys.6 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil)) #'<) (1 5)) (deftest set-difference.allow-other-keys.7 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil '#:x 1)) #'<) (1 5)) (deftest set-difference.keywords.8 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :test #'eql :test (complement #'eql))) #'<) (1 5)) (deftest set-difference.keywords.9 (sort (copy-list (set-difference (list 1 2 3 4 5) (list 2 3 4) :test (complement #'eql) :test #'eql)) #'<) nil) ;;; Error tests (deftest set-difference.error.1 (classify-error (set-difference)) program-error) (deftest set-difference.error.2 (classify-error (set-difference nil)) program-error) (deftest set-difference.error.3 (classify-error (set-difference nil nil :bad t)) program-error) (deftest set-difference.error.4 (classify-error (set-difference nil nil :key)) program-error) (deftest set-difference.error.5 (classify-error (set-difference nil nil 1 2)) program-error) (deftest set-difference.error.6 (classify-error (set-difference nil nil :bad t :allow-other-keys nil)) program-error) (deftest set-difference.error.7 (classify-error (set-difference (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest set-difference.error.8 (classify-error (set-difference (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest set-difference.error.9 (classify-error (set-difference (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest set-difference.error.10 (classify-error (set-difference (list 1 2) (list 3 4) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nset-difference (deftest nset-difference.1 (nset-difference nil nil) nil) (deftest nset-difference.2 (let ((result (nset-difference-with-check '(a b c) nil))) (check-nset-difference '(a b c) nil result)) t) (deftest nset-difference.3 (let ((result (nset-difference-with-check '(a b c d e f) '(f b d)))) (check-nset-difference '(a b c d e f) '(f b d) result)) t) (deftest nset-difference.4 (sort (copy-list (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) (deftest nset-difference.5 (nset-difference-with-check nil '(a b c d e f g h)) nil) (deftest nset-difference.6 (nset-difference-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest nset-difference.7 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest nset-difference.8 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest nset-difference.9 (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest nset-difference.10 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest nset-difference.11 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest nset-difference.12 (nset-difference-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest nset-difference.13 (do-random-nset-differences 100 100) nil) (deftest nset-difference.14 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key 'car) ((b . 2))) (deftest nset-difference.15 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) '((a . 1) (c . 3)) :key #'car) ((b . 2))) ;; ;; Verify that the :test argument is called with the arguments ;; in the correct order ;; (deftest nset-difference.16 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest nset-difference.17 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (eqt x y)))) #'<)) (1 2 3 4)) (deftest nset-difference.18 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) (deftest nset-difference.19 (block fail (sort (copy-list (nset-difference-with-check '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) (not (eqt x y))))) #'<)) (1 2 3 4)) ;;; Order of argument evaluation tests (deftest nset-difference.order.1 (let ((i 0) x y) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) (deftest nset-difference.order.2 (let ((i 0) x y z) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) (deftest nset-difference.order.3 (let ((i 0) x y z w) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 2 3 4)) :test (progn (setf z (incf i)) #'(lambda (x y) (= x (1- y)))) :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) ;;; Keyword tests (deftest nset-difference.allow-other-keys.1 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :bad t :allow-other-keys t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.2 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.3 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) #'<) (4 5)) (deftest nset-difference.allow-other-keys.4 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.5 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys nil)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.6 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil)) #'<) (1 5)) (deftest nset-difference.allow-other-keys.7 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :allow-other-keys t :allow-other-keys nil '#:x 1)) #'<) (1 5)) (deftest nset-difference.keywords.8 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :test #'eql :test (complement #'eql))) #'<) (1 5)) (deftest nset-difference.keywords.9 (sort (copy-list (nset-difference (list 1 2 3 4 5) (list 2 3 4) :test (complement #'eql) :test #'eql)) #'<) nil) ;;; Error tests (deftest nset-difference.error.1 (classify-error (nset-difference)) program-error) (deftest nset-difference.error.2 (classify-error (nset-difference nil)) program-error) (deftest nset-difference.error.3 (classify-error (nset-difference nil nil :bad t)) program-error) (deftest nset-difference.error.4 (classify-error (nset-difference nil nil :key)) program-error) (deftest nset-difference.error.5 (classify-error (nset-difference nil nil 1 2)) program-error) (deftest nset-difference.error.6 (classify-error (nset-difference nil nil :bad t :allow-other-keys nil)) program-error) (deftest nset-difference.error.7 (classify-error (nset-difference (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nset-difference.error.8 (classify-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nset-difference.error.9 (classify-error (nset-difference (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nset-difference.error.10 (classify-error (nset-difference (list 1 2) (list 3 4) :key #'car)) type-error) gcl-2.6.14/ansi-tests/loop1.lsp0000644000175000017500000001117214360276512014641 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 25 19:07:19 2002 ;;;; Contains: Tests of extended loop, part 1 (in-package :cl-test) ;;; Tests of variable initialization and stepping clauses ;;; for-as-arithmetic (deftest loop.1.1 (loop for x from 1 to 10 collect x) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.1.2 (loop for x from 6 downto 1 collect x) (6 5 4 3 2 1)) (deftest loop.1.3 (loop for x from 1 to 1 collect x) (1)) (deftest loop.1.4 (loop for x from 1 to 0 collect x) nil) (deftest loop.1.5 (loop for x to 5 collect x) (0 1 2 3 4 5)) (deftest loop.1.6 (loop for x downfrom 5 to 0 collect x) (5 4 3 2 1 0)) (deftest loop.1.7 (loop for x upfrom 1 to 5 collect x) (1 2 3 4 5)) (deftest loop.1.8 (loop for x from 1.0 to 5.0 count x) 5) (deftest loop.1.9 (loop for x from 1 to 9 by 2 collect x) (1 3 5 7 9)) (deftest loop.1.10 (loop for x from 1 to 10 by 2 collect x) (1 3 5 7 9)) (deftest loop.1.11 (loop for x to 10 from 1 collect x) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.1.12 (loop for x to 10 by 2 from 1 collect x) (1 3 5 7 9)) (deftest loop.1.13 (loop for x by 2 to 10 from 1 collect x) (1 3 5 7 9)) (deftest loop.1.14 (loop for x by 2 to 10 collect x) (0 2 4 6 8 10)) (deftest loop.1.15 (loop for x to 10 by 2 collect x) (0 2 4 6 8 10)) (deftest loop.1.16 (let ((n 0)) (loop for x from (incf n) to (+ n 5) collect x)) (1 2 3 4 5 6)) (deftest loop.1.17 (let ((n 0)) (loop for x to (+ n 5) from (incf n) collect x)) (1 2 3 4 5)) (deftest loop.1.18 (let ((n 0)) (loop for x from (incf n) to (+ n 9) by (incf n) collect x)) (1 3 5 7 9)) (deftest loop.1.19 (let ((n 0)) (loop for x from (incf n) by (incf n) to (+ n 9) collect x)) (1 3 5 7 9 11)) (deftest loop.1.20 (let ((a 0) (b 5) (c 1)) (loop for x from a to b by c collect (progn (incf a) (incf b 2) (incf c 3) x))) (0 1 2 3 4 5)) (deftest loop.1.21 (loop for x from 0 to 5 by 1/2 collect x) (0 1/2 1 3/2 2 5/2 3 7/2 4 9/2 5)) (deftest loop.1.22 (loop for x from 1 below 5 collect x) (1 2 3 4)) (deftest loop.1.23 (loop for x from 1 below 5.01 collect x) (1 2 3 4 5)) (deftest loop.1.24 (loop for x below 5 from 2 collect x) (2 3 4)) (deftest loop.1.25 (loop for x from 10 above 4 collect x) (10 9 8 7 6 5)) (deftest loop.1.26 (loop for x from 14 above 6 by 2 collect x) (14 12 10 8)) (deftest loop.1.27 (loop for x above 6 from 14 by 2 collect x) (14 12 10 8)) (deftest loop.1.28 (loop for x downfrom 16 above 7 by 3 collect x) (16 13 10)) (deftest loop.1.29 (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) below (progn (setq b (incf i)) 9) by (progn (setq c (incf i)) 2) collect x) a b c i)) (0 2 4 6 8) 1 2 3 3) (deftest loop.1.30 (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) by (progn (setq c (incf i)) 2) below (progn (setq b (incf i)) 9) collect x) a b c i)) (0 2 4 6 8) 1 3 2 3) (deftest loop.1.31 (let (a b c (i 0)) (values (loop for x below (progn (setq b (incf i)) 9) by (progn (setq c (incf i)) 2) from (progn (setq a (incf i)) 0) collect x) a b c i)) (0 2 4 6 8) 3 1 2 3) (deftest loop.1.32 (let (a b c (i 0)) (values (loop for x by (progn (setq c (incf i)) 2) below (progn (setq b (incf i)) 9) from (progn (setq a (incf i)) 0) collect x) a b c i)) (0 2 4 6 8) 3 2 1 3) (deftest loop.1.33 (loop for x from 1 upto 5 collect x) (1 2 3 4 5)) (deftest loop.1.34 (loop for x from 1 to 4.0 collect x) (1 2 3 4)) (deftest loop.1.35 (loop for x below 5 collect x) (0 1 2 3 4)) (deftest loop.1.36 (loop for x below 20 by 3 collect x) (0 3 6 9 12 15 18)) (deftest loop.1.37 (loop for x by 3 below 20 collect x) (0 3 6 9 12 15 18)) (deftest loop.1.38 (loop for x of-type fixnum from 1 to 5 collect x) (1 2 3 4 5)) #| ;;; The following provides an example where an incorrect ;;; implementation will assign X an out-of-range value ;;; at the end. (deftest loop.1.39 (loop for x of-type (integer 1 5) from 1 to 5 collect x) (1 2 3 4 5)) ;;; Test that the index variable achieves the inclusive ;;; upper bound, but does not exceed it. (deftest loop.1.40 (loop for x from 1 to 5 do nil finally (return x)) 5) ;;; Test that the index variable acheives the exclusive ;;; upper bound, but does not exceed it. (deftest loop.1.41 (loop for x from 1 below 5 do nil finally (return x)) 4) (deftest loop.1.42 (loop for x from 10 downto 0 do nil finally (return x)) 0) (deftest loop.1.43 (loop for x from 10 above 0 do nil finally (return x)) 1) |#gcl-2.6.14/ansi-tests/packages-08.lsp0000644000175000017500000000726014360276512015615 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:58 1998 ;;;; Contains: Package test code, part 08 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; delete-package ;; check return value of delete-package, and check ;; that package-name is nil on the deleted package object (deftest delete-package.1 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (package-name p)))) (t t nil)) (deftest delete-package.2 (progn (safely-delete-package :test1) (let ((p (make-package :test1 :use nil))) (list (notnot (delete-package :test1)) (notnot (packagep p)) (delete-package p)))) (t t nil)) ;; Check that deletion of different package designators works (deftest delete-package.3 (progn (safely-delete-package "X") (make-package "X") (handler-case (notnot (delete-package "X")) (error (c) c))) t) (deftest delete-package.4 (progn (safely-delete-package "X") (make-package "X") (handler-case (notnot (delete-package #\X)) (error (c) c))) t) ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. ;;; PFD 01.18.03 This test is working, but suspicious. (deftest delete-package.5 (prog (P1 S1 P2 S2 P3) (safely-delete-package "P3") (safely-delete-package "P2") (safely-delete-package "P1") (setq P1 (make-package "P1" :use ())) (setq S1 (intern "S1" P1)) (export S1 "P1") (setq P2 (make-package "P2" :use '("P1"))) (setq S2 (intern "S2" P2)) (export S1 P2) (export S2 "P2") (setf P3 (make-package "P3" :use '("P2"))) ;; Delete the P2 package, catching the continuable ;; error and deleting the package (handler-bind ((package-error #'(lambda (c) (let ((r (find-restart 'continue c))) (and r (invoke-restart r)))))) (delete-package P2)) (unless (and (equal (package-name P1) "P1") (null (package-name P2)) (equal (package-name P3) "P3")) (return 'fail1)) (unless (eqt (symbol-package S1) P1) (return 'fail2)) (unless (equal (prin1-to-string S1) "P1:S1") (return 'fail3)) (unless (equal (multiple-value-list (find-symbol "S1" P3)) '(nil nil)) (return 'fail4)) (unless (equal (multiple-value-list (find-symbol "S2" P3)) '(nil nil)) (return 'fail5)) (unless (and (null (package-used-by-list P1)) (null (package-used-by-list P3))) (return 'fail6)) (unless (and (packagep P1) (packagep P2) (packagep P3)) (return 'fail7)) (unless (and (null (package-use-list P1)) (null (package-use-list P3))) (return 'fail8)) (safely-delete-package P3) (safely-delete-package P1) (return t)) t) ;; deletion of a nonexistent package should cause a continuable ;; package-error (same comments for delete-package.5 apply ;; here as well) ;;; PFD 10/14/02 -- These tests are broken again. I suspect ;;; some sort of interaction with the test harness. ;;; PFD 01.18.03 This test is working, but suspicious. (deftest delete-package.6 (progn (safely-delete-package "TEST-20)") (handler-bind ((package-error #'(lambda (c) (let ((r (find-restart 'continue c))) (and r (invoke-restart r)))))) (and (not (delete-package "TEST-20")) t))) t) (deftest delete-package.error.1 (classify-error (delete-package)) program-error) (deftest delete-package.error.2 (progn (unless (find-package "TEST-DPE2") (make-package "TEST-DPE2" :use nil)) (classify-error (delete-package "TEST-DPE2" nil))) program-error) gcl-2.6.14/ansi-tests/input-stream-p.lsp0000644000175000017500000000156014360276512016474 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:39:27 2004 ;;;; Contains: Tests for INPUT-STREAM-P (in-package :cl-test) (deftest input-stream-p.1 (notnot-mv (input-stream-p *standard-input*)) t) (deftest input-stream-p.2 (notnot-mv (input-stream-p *terminal-io*)) t) (deftest input-stream-p.3 (with-open-file (s "input-stream-p.lsp" :direction :input) (notnot-mv (input-stream-p s))) t) (deftest input-stream-p.4 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (input-stream-p s)) nil) ;;; Error tests (deftest input-stream-p.error.1 (signals-error (input-stream-p) program-error) t) (deftest input-stream-p.error.2 (signals-error (input-stream-p *standard-input* nil) program-error) t) (deftest input-stream-p.error.3 (check-type-error #'input-stream-p #'streamp) nil) gcl-2.6.14/ansi-tests/loop14.lsp0000644000175000017500000001477114360276512014735 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Nov 20 06:33:21 2002 ;;;; Contains: Tests of LOOP conditional execution clauses (in-package :cl-test) (deftest loop.14.1 (loop for x from 1 to 6 when (evenp x) collect x) (2 4 6)) (deftest loop.14.2 (loop for x from 1 to 6 unless (evenp x) collect x) (1 3 5)) (deftest loop.14.3 (loop for x from 1 to 10 when (evenp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.4 (loop for x from 1 to 10 when (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.5 (loop for x from 1 to 10 when (evenp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.6 (loop for x from 1 to 10 unless (oddp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.7 (loop for x from 1 to 10 unless (oddp x) collect x end) (2 4 6 8 10)) (deftest loop.14.8 (loop for x from 1 to 10 unless (oddp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.9 (loop for x from 1 to 6 if (evenp x) collect x) (2 4 6)) (deftest loop.14.10 (loop for x from 1 to 10 if (evenp x) collect x into foo and count t into bar finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.11 (loop for x from 1 to 10 if (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.12 (loop for x from 1 to 10 if (evenp x) collect x into evens else collect x into odds end finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) ;;; Test that else associates with the nearest conditional unclosed ;;; by end (deftest loop.14.13 (loop for i from 1 to 20 if (evenp i) if (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.14 (loop for i from 1 to 20 when (evenp i) if (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.15 (loop for i from 1 to 20 if (evenp i) when (= (mod i 3) 0) collect i into list1 else collect i into list2 finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.16 (loop for i from 1 to 20 if (evenp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.17 (loop for i from 1 to 20 when (evenp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.18 (loop for i from 1 to 20 if (evenp i) when (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.19 (loop for i from 1 to 20 when (evenp i) when (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.20 (loop for i from 1 to 20 unless (oddp i) if (= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.21 (loop for i from 1 to 20 if (evenp i) unless (/= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.22 (loop for i from 1 to 20 unless (oddp i) unless (/= (mod i 3) 0) collect i into list1 end else collect i into list2 finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) ;;; More tests conditionals (deftest loop.14.23 (loop for i from 1 to 20 if (evenp i) collect i into list1 else if (= (mod i 3) 0) collect i into list2 else collect i into list3 finally (return (values list1 list2 list3))) (2 4 6 8 10 12 14 16 18 20) (3 9 15) (1 5 7 11 13 17 19)) ;;; Tests of 'IT' (deftest loop.14.24 (loop for x in '((a) nil (b) (c) (nil) (d)) when (car x) collect it) (a b c d)) (deftest loop.14.25 (loop for x in '((a) nil (b) (c) (nil) (d)) if (car x) collect it) (a b c d)) (deftest loop.14.26 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) when (car x) return it) a) (deftest loop.14.27 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) if (car x) return it) a) (deftest loop.14.28 (loop for x in '((a) nil (b) (c) (nil) (d)) when (car x) collect it and collect 'foo) (a foo b foo c foo d foo)) (deftest loop.14.29 (let ((it 'z)) (loop for x in '(a b c d) when x collect it and collect it)) (a z b z c z d z)) (deftest loop.14.30 (let ((it 'z)) (loop for x in '(a b c d) if x collect it end collect it)) (a z b z c z d z)) (deftest loop.14.31 (loop for it on '(a b c d) when (car it) collect it) (a b c d)) (deftest loop.14.32 (loop for x in '(a b nil c d nil e) when x collecting it) (a b c d e)) (deftest loop.14.33 (loop for x in '(a b nil c d nil e) when x append (list x)) (a b c d e)) (deftest loop.14.34 (loop for x in '(a b nil c d nil e) when x appending (list x)) (a b c d e)) (deftest loop.14.35 (loop for x in '(a b nil c d nil e) when x nconc (list x)) (a b c d e)) (deftest loop.14.36 (loop for x in '(a b nil c d nil e) when x nconcing (list x)) (a b c d e)) (deftest loop.14.37 (loop for it on '(a b c d) when (car it) collect it into foo finally (return foo)) (a b c d)) (deftest loop.14.38 (loop for x in '(1 2 nil 3 4 nil 5 nil) when x count it) 5) (deftest loop.14.39 (loop for x in '(1 2 nil 3 4 nil 5 nil) when x counting it) 5) (deftest loop.14.40 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x maximize it) 6) (deftest loop.14.41 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x maximizing it) 6) (deftest loop.14.42 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x minimize it) 1) (deftest loop.14.43 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x minimizing it) 1) (deftest loop.14.44 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x sum it) 16) (deftest loop.14.45 (loop for x in '(1 2 nil 3 4 nil 6 nil) when x summing it) 16) gcl-2.6.14/ansi-tests/substitute-if.lsp0000644000175000017500000005764314360276512016433 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 17:42:04 2002 ;;;; Contains: Tests for SUBSTITUTE-IF (in-package :cl-test) (deftest substitute-if-list.1 (let ((x '())) (values (substitute-if 'b #'identity x) x)) nil nil) (deftest substitute-if-list.2 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) (b b b c) (a b a c)) (deftest substitute-if-list.3 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-list.4 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-if-list.5 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-if-list.6 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-if-list.7 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-if-list.8 (let ((x '())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) nil nil) (deftest substitute-if-list.9 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-list.10 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-list.11 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-list.12 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-if-list.13 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-list.14 (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) ;;; Tests on vectors (deftest substitute-if-vector.1 (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x) x)) #() #()) (deftest substitute-if-vector.2 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.3 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.4 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.5 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-if-vector.6 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.7 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.8 (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-vector.9 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.10 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.11 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-vector.12 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-if-vector.13 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.14 (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-if-string.1 (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x) x)) "" "") (deftest substitute-if-string.2 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-string.3 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.4 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-string.5 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-string.6 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-string.7 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-string.8 (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-string.9 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.10 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-string.11 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-string.12 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-string.13 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.14 (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-if-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-if-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest substitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if 1 'zerop x))) (and (equalp orig x) result)) #*) (deftest substitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-if-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-if-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-if-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-if-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 0 (is-eq-p 1) x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-if-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-if-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-if-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-if-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if 1 #'zerop x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute-if 1 #'zerop x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eq-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x))) result) #*11111) (deftest substitute-if-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest substitute-if-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest substitute-if-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) (deftest substitute-if.order.1 (let ((i 0) a b c d e f g h) (values (substitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute-if.order.2 (let ((i 0) a b c d e f g h) (values (substitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute-if.allow-other-keys.1 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.2 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.3 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.4 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.5 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute-if.keywords.6 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest substitute-if.allow-other-keys.7 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.8 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest substitute-if.error.1 (classify-error (substitute-if)) program-error) (deftest substitute-if.error.2 (classify-error (substitute-if 'a)) program-error) (deftest substitute-if.error.3 (classify-error (substitute-if 'a #'null)) program-error) (deftest substitute-if.error.4 (classify-error (substitute-if 'a #'null nil 'bad t)) program-error) (deftest substitute-if.error.5 (classify-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute-if.error.6 (classify-error (substitute-if 'a #'null nil :key)) program-error) (deftest substitute-if.error.7 (classify-error (substitute-if 'a #'null nil 1 2)) program-error) (deftest substitute-if.error.8 (classify-error (substitute-if 'a #'cons (list 'a 'b 'c))) program-error) (deftest substitute-if.error.9 (classify-error (substitute-if 'a #'car (list 'a 'b 'c))) type-error) (deftest substitute-if.error.10 (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest substitute-if.error.11 (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/compile-and-load.lsp0000644000175000017500000000163014360276512016712 0ustar cammcamm(in-package :common-lisp-user) #+allegro (progn (setq *ignore-package-name-case* t) (when (eq excl:*current-case-mode* :case-sensitive-lower) (push :lower-case *features*))) (eval-when (load eval compile) (intern "==>" "CL-USER") (unless (fboundp 'compile-file-pathname) (defun compile-file-pathname (pathname) (make-pathname :defaults pathname :type "o")))) (defun compile-and-load (pathspec) "Find the file indicated by PATHSPEC, compiling it first if the associated compiled file is out of date." (let* ((pathname (pathname pathspec)) (compile-pathname (compile-file-pathname pathname)) (source-write-time (file-write-date pathname)) (target-write-time (and (probe-file compile-pathname) (file-write-date compile-pathname)))) (when (or (not target-write-time) (<= target-write-time source-write-time)) (compile-file pathname)) (load compile-pathname))) gcl-2.6.14/ansi-tests/string-trim.lsp0000644000175000017500000000651514360276512016073 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:53:38 2002 ;;;; Contains: Tests for STRING-TRIM (in-package :cl-test) (deftest string-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") ;;; Test that trimming is case sensitive (deftest string-trim.13 (let* ((s (copy-seq "Aa")) (s2 (string-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-trim.14 (let* ((s '|abcdaba|) (s2 (string-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cd") (deftest string-trim.15 (string-trim "abc" "") "") (deftest string-trim.16 (string-trim "a" #\a) "") (deftest string-trim.17 (string-trim "b" #\a) "a") (deftest string-trim.18 (string-trim "" (copy-seq "abcde")) "abcde") (deftest string-trim.19 (string-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-trim.order.1 (let ((i 0) x y) (values (string-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) "abc d e f" 2 1 2) ;;; Error cases (deftest string-trim.error.1 (classify-error (string-trim)) program-error) (deftest string-trim.error.2 (classify-error (string-trim "abc")) program-error) (deftest string-trim.error.3 (classify-error (string-trim "abc" "abcdddabc" nil)) program-error) gcl-2.6.14/ansi-tests/open.lsp0000644000175000017500000010723214360276512014553 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 23 05:36:55 2004 ;;;; Contains: Tests of OPEN (in-package :cl-test) ;;; Input streams (defun generator-for-element-type (type) (etypecase type ((member character base-char) #'(lambda (i) (aref "abcdefghijklmnopqrstuvwxyz" (mod i 26)))) ((member signed-byte unsigned-byte bit) #'(lambda (i) (logand i 1))) (cons (let ((op (car type)) (arg1 (cadr type)) (arg2 (caddr type))) (ecase op (unsigned-byte (let ((mask (1- (ash 1 arg1)))) #'(lambda (i) (logand i mask)))) (signed-byte (let ((mask (1- (ash 1 (1- arg1))))) #'(lambda (i) (logand i mask)))) (integer (let* ((lo arg1) (hi arg2) (lower-bound (etypecase lo (integer lo) (cons (1+ (car lo))))) (upper-bound (etypecase hi (integer hi) (cons (1- (car hi))))) (range (1+ (- upper-bound lower-bound)))) #'(lambda (i) (+ lower-bound (mod i range)))))))))) (compile 'generator-for-element-type) (defmacro def-open-test (name args form expected &key (notes nil notes-p) (build-form nil build-form-p) (element-type 'character element-type-p) (pathname #p"tmp.dat")) (when element-type-p (setf args (append args (list :element-type `',element-type)))) (unless build-form-p (let ((write-element-form (cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) os)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) os))))) (setq build-form `(with-open-file (os pn :direction :output ,@(if element-type-p `(:element-type ',element-type)) :if-exists :supersede) (assert (open-stream-p os)) (dotimes (i 10) ,write-element-form) (finish-output os) )))) `(deftest ,name ,@(when notes-p `(:notes ,notes)) (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn ,@args))) (unwind-protect (progn (assert (open-stream-p s)) (assert (typep s 'file-stream)) ,@ (unless (member element-type '(signed-byte unsigned-byte)) #-allegro `((assert (subtypep ',element-type (stream-element-type s)))) #+allegro nil ) ,form) (close s)))) ,@expected)) ;; (compile 'def-open-test) (def-open-test open.1 () (values (read-line s nil)) ("abcdefghij")) (def-open-test open.2 (:direction :input) (values (read-line s nil)) ("abcdefghij") :element-type character) (def-open-test open.3 (:direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.4 (:direction :input) (values (read-line s nil)) ("abcdefghij") :element-type base-char) (def-open-test open.5 (:if-exists :error) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.6 (:if-exists :error :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.7 (:if-exists :new-version) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.8 (:if-exists :new-version :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.9 (:if-exists :rename) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.10 (:if-exists :rename :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.11 (:if-exists :rename-and-delete) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.12 (:if-exists :rename-and-delete :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.13 (:if-exists :overwrite) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.14 (:if-exists :overwrite :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.15 (:if-exists :append) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.16 (:if-exists :append :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.17 (:if-exists :supersede) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.18 (:if-exists :supersede :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.19 (:if-exists nil) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.20 (:if-exists nil :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.21 (:if-does-not-exist nil) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.22 (:if-does-not-exist nil :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.23 (:if-does-not-exist :error) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.24 (:if-does-not-exist :error :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.25 (:if-does-not-exist :create) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.26 (:if-does-not-exist :create :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.27 (:external-format :default) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.28 (:external-format :default :direction :input) (values (read-line s nil)) ("abcdefghij")) (def-open-test open.29 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-test open.30 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-test open.31 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-test open.32 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-test open.33 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-test open.34 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-test open.35 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-test open.36 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-test open.37 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) (def-open-test open.38 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) (def-open-test open.39 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-test open.40 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-test open.41 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) (def-open-test open.42 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) (def-open-test open.43 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-test open.44 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-test open.45 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) (def-open-test open.46 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) (def-open-test open.47 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) (def-open-test open.48 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) (def-open-test open.49 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) (def-open-test open.50 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) (def-open-test open.51 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) (def-open-test open.52 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) (def-open-test open.53 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) (def-open-test open.54 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) (def-open-test open.55 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-test open.56 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-test open.57 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) (def-open-test open.58 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) (def-open-test open.59 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) (def-open-test open.60 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) (def-open-test open.61 () (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) (def-open-test open.62 (:direction :input) (let ((seq (make-array 10))) (read-sequence seq s) seq) (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) (def-open-test open.63 () (values (read-line s nil)) ("abcdefghij") :pathname "tmp.dat") (def-open-test open.64 () (values (read-line s nil)) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) ;;; It works on recognizable subtypes. (deftest open.65 (let ((type '(or (integer 0 1) (integer 100 200))) (pn #p"tmp.dat") (vals '(0 1 100 120 130 190 200 1 0 150))) (or (not (subtypep type 'integer)) (progn (with-open-file (os pn :direction :output :element-type type :if-exists :supersede) (dolist (e vals) (write-byte e os))) (let ((s (open pn :direction :input :element-type type)) (seq (make-array 10))) (unwind-protect (progn (read-sequence seq s) seq) (close s)) (notnot (every #'eql seq vals)))))) t) ;;; FIXME: Add -- tests for when the filespec is a stream (deftest open.66 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :io :if-exists :rename-and-delete :if-does-not-exist :create) (format s "some stuff~%") (finish-output s) (let ((is (open s :direction :input))) (unwind-protect (values (read-char is) (notnot (file-position s :start)) (read-line is) (read-line s)) (close is))))) #\s t "ome stuff" "some stuff") (deftest open.67 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :output))) (unwind-protect (progn (format s "some stuff~%") (finish-output s) (close s) (let ((is (open s :direction :input))) (unwind-protect (values (read-line is)) (close is)))) (when (open-stream-p s) (close s))))) "some stuff") ;;; FIXME: Add -- tests for when element-type is :default ;;; Tests of file creation (defmacro def-open-output-test (name args form expected &rest keyargs &key (element-type 'character) (build-form `(dotimes (i 10) ,(cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) s)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) s))))) &allow-other-keys) `(def-open-test ,name (:direction :output ,@args) (progn ,build-form (assert (output-stream-p s)) ,form) ,expected :build-form nil ,@keyargs)) ;; (compile 'def-open-output-test) (def-open-output-test open.output.1 () (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.2 () (progn (close s) (with-open-file (is "tmp.dat") (values (read-line is nil)))) ("abcdefghij") :pathname "tmp.dat") (def-open-output-test open.output.3 () (progn (close s) (with-open-file (is (logical-pathname "CLTEST:TMP.DAT")) (values (read-line is nil)))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-output-test open.output.4 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'character) (values (read-line is nil)))) ("abcdefghij") :element-type character) (def-open-output-test open.output.5 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'base-char) (values (read-line is nil)))) ("abcdefghij") :element-type base-char) (def-open-output-test open.output.6 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(integer 0 1)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-output-test open.output.7 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type 'bit) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-output-test open.output.8 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 1)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-output-test open.output.9 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 2)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-output-test open.output.10 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 3)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-output-test open.output.11 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 4)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-output-test open.output.12 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 6)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-output-test open.output.13 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 8)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-output-test open.output.14 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 12)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-output-test open.output.15 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 16)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-output-test open.output.16 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 24)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-output-test open.output.17 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 32)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-output-test open.output.18 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 64)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-output-test open.output.19 () (progn (close s) (with-open-file (is #p"tmp.dat" :element-type '(unsigned-byte 100)) (let ((seq (make-array 10))) (read-sequence seq is) seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) (deftest open.output.20 (let ((pn #p"tmp.dat")) (with-open-file (s pn :direction :output :if-exists :supersede)) (open pn :direction :output :if-exists nil)) nil) (def-open-test open.output.21 (:if-exists :new-version :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.output.22 (:if-exists :rename :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.23 (:if-exists :rename-and-delete :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.24 (:if-exists :overwrite :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyzefghij")) (def-open-test open.output.25 (:if-exists :append :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("abcdefghijwxyz")) (def-open-test open.output.26 (:if-exists :supersede :direction :output) (progn (write-sequence "wxyz" s) (close s) (with-open-file (s pn :direction :input) (values (read-line s nil)))) ("wxyz")) (def-open-output-test open.output.27 (:if-does-not-exist :create :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (deftest open.output.28 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-does-not-exist nil)) nil) (def-open-output-test open.output.28a (:external-format :default) (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.29 (:external-format (prog1 (with-open-file (s "foo.dat" :direction :output :if-exists :supersede) (stream-external-format s)) (delete-all-versions "foo.dat") )) (progn (close s) (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version ;;; of the filespec is :newest (deftest open.output.30 :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) (progn ;; Create file (let ((s1 (open pn :direction :output :if-exists :overwrite :if-does-not-exist :create))) (unwind-protect ;; Now try again (let ((s2 (open pn :direction :output))) (unwind-protect (write-line "abcdef" s2) (close s2)) (unwind-protect (progn (setq s2 (open s1 :direction :input)) (equalt (read-line s2 nil) "abcdef")) (close s2))) (close s1) (delete-all-versions pn) ))))) t) (def-open-output-test open.output.31 (:if-exists :rename :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.32 (:if-exists :rename-and-delete :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.33 (:if-exists :new-version :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.34 (:if-exists :supersede :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.35 (:if-exists nil :direction :output) (progn (close s) (with-open-file (is pn :direction :input) (values (read-line is nil)))) ("abcdefghij")) ;;; Add -- tests for when the filespec is a stream ;;; Tests of bidirectional IO (defmacro def-open-io-test (name args form expected &rest keyargs &key (element-type 'character) (build-form `(dotimes (i 10) ,(cond ((subtypep element-type 'integer) `(write-byte (funcall (the function (generator-for-element-type ',element-type)) i) s)) ((subtypep element-type 'character) `(write-char (funcall (the function (generator-for-element-type ',element-type)) i) s))))) &allow-other-keys) `(def-open-test ,name (:direction :io ,@args) (progn ,build-form (assert (input-stream-p s)) (assert (output-stream-p s)) ,form) ,expected :build-form nil ,@keyargs)) ;; (compile 'def-open-io-test) (def-open-io-test open.io.1 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.2 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :pathname "tmp.dat") (def-open-io-test open.io.3 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-io-test open.io.4 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :element-type character) (def-open-io-test open.io.5 () (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij") :element-type base-char) (def-open-io-test open.io.6 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-io-test open.io.7 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-io-test open.io.8 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-io-test open.io.9 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-io-test open.io.10 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-io-test open.io.11 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-io-test open.io.12 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-io-test open.io.13 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-io-test open.io.14 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-io-test open.io.15 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-io-test open.io.16 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-io-test open.io.17 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-io-test open.io.18 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-io-test open.io.19 () (progn (file-position s :start) (let ((seq (make-array 10))) (read-sequence seq s) seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) (deftest open.io.20 (let ((pn #p"tmp.dat")) (with-open-file (s pn :direction :io :if-exists :supersede)) (open pn :direction :io :if-exists nil)) nil) (def-open-test open.io.21 (:if-exists :new-version :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.io.22 (:if-exists :rename :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-test open.io.23 (:if-exists :rename-and-delete :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-test open.io.24 (:if-exists :overwrite :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyzefghij")) (def-open-test open.io.25 (:if-exists :append :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("abcdefghijwxyz")) (def-open-test open.io.26 (:if-exists :supersede :direction :io) (progn (write-sequence "wxyz" s) (file-position s :start) (values (read-line s nil))) ("wxyz")) (def-open-io-test open.io.27 (:if-does-not-exist :create :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (deftest open.io.28 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-does-not-exist nil)) nil) (def-open-io-test open.io.28a (:external-format :default) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.29 (:external-format (prog1 (with-open-file (s "foo.dat" :direction :io :if-exists :supersede) (stream-external-format s)) (delete-all-versions "foo.dat") )) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version ;;; of the filespec is :newest (deftest open.io.30 :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) (progn ;; Create file (let ((s1 (open pn :direction :io :if-exists :overwrite :if-does-not-exist :create))) (unwind-protect ;; Now try again (let ((s2 (open pn :direction :io))) (unwind-protect (write-line "abcdef" s2) (close s2)) (unwind-protect (progn (setq s2 (open s1 :direction :input)) (equalt (read-line s2 nil) "abcdef")) (close s2))) (close s1) (delete-all-versions pn) ))))) t) (def-open-io-test open.io.31 (:if-exists :rename :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.32 (:if-exists :rename-and-delete :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.33 (:if-exists :new-version :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.34 (:if-exists :supersede :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.35 (:if-exists nil :direction :io) (progn (file-position s :start) (values (read-line s nil))) ("abcdefghij")) ;;;; :PROBE tests (defmacro def-open-probe-test (name args form &key (build-form nil build-form-p) (pathname #p"tmp.dat")) (unless build-form-p (setf build-form `(with-open-file (s pn :direction :output :if-exists :supersede)))) `(deftest ,name (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn :direction :probe ,@args))) (values ,(if build-form `(and (typep s 'file-stream) (not (open-stream-p s)) ) `(not s)) ,form))) t t)) (def-open-probe-test open.probe.1 () t) (def-open-probe-test open.probe.2 (:if-exists :error) t) (def-open-probe-test open.probe.3 (:if-exists :new-version) t) (def-open-probe-test open.probe.4 (:if-exists :rename) t) (def-open-probe-test open.probe.5 (:if-exists :rename-and-delete) t) (def-open-probe-test open.probe.6 (:if-exists :overwrite) t) (def-open-probe-test open.probe.7 (:if-exists :append) t) (def-open-probe-test open.probe.8 (:if-exists :supersede) t) (def-open-probe-test open.probe.9 (:if-does-not-exist :error) t) (def-open-probe-test open.probe.10 (:if-does-not-exist nil) t) (def-open-probe-test open.probe.11 (:if-does-not-exist :create) t) (def-open-probe-test open.probe.12 () t :build-form nil) (def-open-probe-test open.probe.13 (:if-exists :error) t :build-form nil) (def-open-probe-test open.probe.14 (:if-exists :new-version) t :build-form nil) (def-open-probe-test open.probe.15 (:if-exists :rename) t :build-form nil) (def-open-probe-test open.probe.16 (:if-exists :rename-and-delete) t :build-form nil) (def-open-probe-test open.probe.17 (:if-exists :overwrite) t :build-form nil) (def-open-probe-test open.probe.18 (:if-exists :append) t :build-form nil) (def-open-probe-test open.probe.19 (:if-exists :supersede) t :build-form nil) (def-open-probe-test open.probe.20 (:if-does-not-exist nil) t :build-form nil) (deftest open.probe.21 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :probe :if-does-not-exist :create))) (values (notnot s) (notnot (probe-file pn))))) t t) (deftest open.probe.22 (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :probe :if-does-not-exist :create :if-exists :error))) (values (notnot s) (notnot (probe-file pn))))) t t) (def-open-probe-test open.probe.23 (:external-format :default) t) (def-open-probe-test open.probe.24 (:element-type 'character) t) (def-open-probe-test open.probe.25 (:element-type 'bit) t) (def-open-probe-test open.probe.26 (:element-type '(unsigned-byte 2)) t) (def-open-probe-test open.probe.27 (:element-type '(unsigned-byte 4)) t) (def-open-probe-test open.probe.28 (:element-type '(unsigned-byte 8)) t) (def-open-probe-test open.probe.29 (:element-type '(unsigned-byte 9)) t) (def-open-probe-test open.probe.30 (:element-type '(unsigned-byte 15)) t) (def-open-probe-test open.probe.31 (:element-type '(unsigned-byte 16)) t) (def-open-probe-test open.probe.32 (:element-type '(unsigned-byte 17)) t) (def-open-probe-test open.probe.33 (:element-type '(unsigned-byte 31)) t) (def-open-probe-test open.probe.34 (:element-type '(unsigned-byte 32)) t) (def-open-probe-test open.probe.35 (:element-type '(unsigned-byte 33)) t) (def-open-probe-test open.probe.36 (:element-type '(integer -1002 13112)) t) ;;;; Error tests (deftest open.error.1 (signals-error (open) program-error) t) (deftest open.error.2 (signals-error-always (let ((pn #p"tmp.dat")) (close (open pn :direction :output :if-does-not-exist :create)) (open pn :if-exists :error :direction :output)) file-error) t t) (deftest open.error.3 (signals-error-always (let ((pn #p"tmp.dat")) (close (open pn :direction :output :if-does-not-exist :create)) (open pn :if-exists :error :direction :io)) file-error) t t) (deftest open.error.4 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn)) file-error) t t) (deftest open.error.5 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :if-does-not-exist :error)) file-error) t t) (deftest open.error.6 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :input)) file-error) t t) (deftest open.error.7 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :if-does-not-exist :error :direction :input)) file-error) t t) (deftest open.error.8 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-does-not-exist :error)) file-error) t t) (deftest open.error.9 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-does-not-exist :error)) file-error) t t) (deftest open.error.10 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :probe :if-does-not-exist :error)) file-error) t t) (deftest open.error.11 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-exists :overwrite)) file-error) t t) (deftest open.error.12 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :output :if-exists :append)) file-error) t t) (deftest open.error.13 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-exists :overwrite)) file-error) t t) (deftest open.error.14 (signals-error-always (let ((pn #p"tmp.dat")) (delete-all-versions pn) (open pn :direction :io :if-exists :append)) file-error) t t) (deftest open.error.15 (signals-error-always (open (make-pathname :name :wild :type "lsp")) file-error) t t) (deftest open.error.16 (signals-error-always (open (make-pathname :name "open" :type :wild)) file-error) t t) (deftest open.error.17 (signals-error-always (let ((pn (make-pathname :name "open" :type "lsp" :version :wild))) (if (wild-pathname-p pn) (open pn) (error 'file-error))) file-error) t t) (deftest open.error.18 (signals-error-always (open #p"tmp.dat" :direction :output :if-exists :supersede :external-form (gensym)) error) t t) ;;; FIXME -- add tests for :element-type :default ;;; FIXME -- add tests for filespec being a specialized string gcl-2.6.14/ansi-tests/ecase.lsp0000644000175000017500000000514314360276512014670 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 20:17:30 2002 ;;;; Contains: Tests for ECASE (in-package :cl-test) (deftest ecase.1 (ecase 'b (a 1) (b 2) (c 3)) 2) (deftest ecase.2 (classify-error (ecase 1)) type-error) (deftest ecase.3 (classify-error (ecase 1 (a 1) (b 2) (c 3))) type-error) ;;; It is legal to use T or OTHERWISE as key designators ;;; in ECASE forms. They have no special meaning here. (deftest ecase.4 (classify-error (ecase 1 (t nil))) type-error) (deftest ecase.5 (classify-error (ecase 1 (otherwise nil))) type-error) (deftest ecase.6 (ecase 'b ((a z) 1) ((y b w) 2) ((b c) 3)) 2) (deftest ecase.7 (ecase 'z ((a b c) 1) ((d e) 2) ((f z g) 3)) 3) (deftest ecase.8 (ecase (1+ most-positive-fixnum) (#.(1+ most-positive-fixnum) 'a)) a) (deftest ecase.9 (classify-error (ecase nil (nil 'a))) type-error) (deftest ecase.10 (ecase nil ((nil) 'a)) a) (deftest ecase.11 (ecase 'a (b 0) (a (values 1 2 3)) (c nil)) 1 2 3) (deftest ecase.12 (classify-error (ecase t (a 10))) type-error) (deftest ecase.13 (ecase t ((t) 10) (t 20)) 10) (deftest ecase.14 (let ((x (list 'a 'b))) (eval `(ecase (quote ,x) ((,x) 1) (a 2)))) 1) (deftest ecase.15 (classify-error (ecase 'otherwise ((t) 10))) type-error) (deftest ecase.16 (classify-error (ecase t ((otherwise) 10))) type-error) (deftest ecase.17 (classify-error (ecase 'a (b 0) (c 1) (otherwise 2))) type-error) (deftest ecase.18 (classify-error (ecase 'a (b 0) (c 1) ((otherwise) 2))) type-error) (deftest ecase.19 (classify-error (ecase 'a (b 0) (c 1) ((t) 2))) type-error) (deftest ecase.20 (ecase #\a ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40)) 40) (deftest ecase.21 (ecase 1 (1 (values)) (2 'a))) (deftest ecase.23 (ecase 1 (1 (values 'a 'b 'c))) a b c) ;;; Show that the key expression is evaluated only once. (deftest ecase.25 (let ((x 0)) (values (ecase (progn (incf x) 'c) (a 1) (b 2) (c 3) (d 4)) x)) 3 1) ;;; Repeated keys are allowed (all but the first are ignored) (deftest ecase.26 (ecase 'b ((a b c) 10) (b 20)) 10) (deftest ecase.27 (ecase 'b (b 20) ((a b c) 10)) 20) (deftest ecase.28 (ecase 'b (b 20) (b 10) (d 0)) 20) ;;; There are implicit progns (deftest ecase.29 (let ((x nil)) (values (ecase 2 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (3 (setq x 'c) 'z)) x)) y b) (deftest ecase.31 (ecase (values 'b 'c) (c 0) ((a b) 10) (d 20)) 10) (deftest ecase.32 (ecase 'a (a) (b 'b)) nil) gcl-2.6.14/ansi-tests/defun.lsp0000644000175000017500000000061014360276512014703 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Feb 16 23:40:32 2003 ;;;; Contains: Tests of DEFUN (in-package :cl-test) ;;; DEFUN is used extensively elsewhere, so I'm just putting error ;;; case tests here #| (deftest defun.error.1 (classify-error (defun)) program-error) (deftest defun.error.2 (classify-error (defun ignored-defun-name)) program-error) |# gcl-2.6.14/ansi-tests/pathnames-aux.lsp0000644000175000017500000000117714360276512016366 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 15:05:05 2003 ;;;; Contains: Functions associated with pathname tests (in-package :cl-test) (defun could-be-pathname-designator (x) (or (stringp x) (pathnamep x) (typep x 'file-stream) (and (typep x 'synonym-stream) (could-be-pathname-designator (symbol-value (synonym-stream-symbol x)))))) (defun explode-pathname (pn) (list :host (pathname-host pn) :device (pathname-device pn) :directory (pathname-directory pn) :name (pathname-name pn) :type (pathname-type pn) :version (pathname-version pn))) gcl-2.6.14/ansi-tests/load-strings.lsp0000644000175000017500000000071714360276512016220 0ustar cammcamm;;; Tests of strings (load "char-schar.lsp") (load "string.lsp") (load "string-upcase.lsp") (load "string-downcase.lsp") (load "string-capitalize.lsp") (load "nstring-upcase.lsp") (load "nstring-downcase.lsp") (load "nstring-capitalize.lsp") (load "string-trim.lsp") (load "string-left-trim.lsp") (load "string-right-trim.lsp") ;;; Tests of string comparison functions (compile-and-load "string-aux.lsp") (load "string-comparisons.lsp") (load "make-string.lsp")gcl-2.6.14/ansi-tests/loop16.lsp0000644000175000017500000001225614360276512014733 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 09:46:27 2002 ;;;; Contains: Tests that uninterned symbols can be loop keywords (in-package :cl-test) (deftest loop.16.30 (loop #:for i #:from 1 #:to 10 #:collect i) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.16.31 (loop #:for i #:upfrom 1 #:below 10 #:by 2 #:collect i) (1 3 5 7 9)) (deftest loop.16.32 (loop #:with x = 1 #:and y = 2 #:return (values x y)) 1 2) (deftest loop.16.33 (loop #:named foo #:doing (return-from foo 1)) 1) (deftest loop.16.34 (let ((x 0)) (loop #:initially (setq x 2) #:until t #:finally (return x))) 2) (deftest loop.16.35 (loop #:for x #:in '(a b c) #:collecting x) (a b c)) (deftest loop.16.36 (loop #:for x #:in '(a b c) #:append (list x)) (a b c)) (deftest loop.16.37 (loop #:for x #:in '(a b c) #:appending (list x)) (a b c)) (deftest loop.16.38 (loop #:for x #:in '(a b c) #:nconc (list x)) (a b c)) (deftest loop.16.39 (loop #:for x #:in '(a b c) #:nconcing (list x)) (a b c)) (deftest loop.16.40 (loop #:for x #:in '(1 2 3) #:count x) 3) (deftest loop.16.41 (loop #:for x #:in '(1 2 3) #:counting x) 3) (deftest loop.16.42 (loop #:for x #:in '(1 2 3) #:sum x) 6) (deftest loop.16.43 (loop #:for x #:in '(1 2 3) #:summing x) 6) (deftest loop.16.44 (loop #:for x #:in '(10 20 30) #:maximize x) 30) (deftest loop.16.45 (loop #:for x #:in '(10 20 30) #:maximizing x) 30) (deftest loop.16.46 (loop #:for x #:in '(10 20 30) #:minimize x) 10) (deftest loop.16.47 (loop #:for x #:in '(10 20 30) #:minimizing x) 10) (deftest loop.16.48 (loop #:for x #:in '(1 2 3 4) #:sum x #:into foo #:of-type fixnum #:finally (return foo)) 10) (deftest loop.16.49 (loop #:for x #:upfrom 1 #:to 10 #:if (evenp x) #:sum x #:into foo #:else #:sum x #:into bar #:end #:finally (return (values foo bar))) 30 25) (deftest loop.16.50 (loop #:for x #:downfrom 10 #:above 0 #:when (evenp x) #:sum x #:into foo #:else #:sum x #:into bar #:end #:finally (return (values foo bar))) 30 25) (deftest loop.16.51 (loop #:for x #:in '(a b nil c d nil) #:unless x #:count t) 2) (deftest loop.16.52 (loop #:for x #:in '(a b nil c d nil) #:unless x #:collect x #:into bar #:and #:count t #:into foo #:end finally (return (values bar foo))) (nil nil) 2) (deftest loop.16.53 (loop #:for x #:in '(nil nil a b nil c nil) #:collect x #:until x) (nil nil a)) (deftest loop.16.54 (loop #:for x #:in '(a b nil c nil) #:while x #:collect x) (a b)) (deftest loop.16.55 (loop #:for x #:in '(nil nil a b nil c nil) #:thereis x) a) (deftest loop.16.56 (loop #:for x #:in '(nil nil a b nil c nil) #:never x) nil) (deftest loop.16.57 (loop #:for x #:in '(a b c d e) #:always x) t) (deftest loop.16.58 (loop #:as x #:in '(a b c) #:count t) 3) (deftest loop.16.59 (loop #:for i #:from 10 #:downto 5 #:collect i) (10 9 8 7 6 5)) (deftest loop.16.60 (loop #:for i #:from 0 #:upto 5 #:collect i) (0 1 2 3 4 5)) (deftest loop.16.61 (loop #:for x #:on '(a b c) #:collecting (car x)) (a b c)) (deftest loop.16.62 (loop #:for x = '(a b c) #:then (cdr x) #:while x #:collect (car x)) (a b c)) (deftest loop.16.63 (loop #:for x #:across #(a b c) #:collect x) (a b c)) (deftest loop.16.64 (loop #:for x #:being #:the #:hash-keys #:of (make-hash-table) #:count t) 0) (deftest loop.16.65 (loop #:for x #:being #:each #:hash-key #:in (make-hash-table) #:count t) 0) (deftest loop.16.66 (loop #:for x #:being #:each #:hash-value #:of (make-hash-table) #:count t) 0) (deftest loop.16.67 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) #:count t) 0) (deftest loop.16.68 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) #:using (#:hash-key k) #:count t) 0) (deftest loop.16.69 (loop #:for x #:being #:the #:hash-keys #:in (make-hash-table) #:using (#:hash-value v) #:count t) 0) (deftest loop.16.70 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:symbols #:of p #:count t))) 0) (deftest loop.16.71 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:symbol #:of p #:count t))) 0) (deftest loop.16.72 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:external-symbols #:of p #:count t))) 0) (deftest loop.16.73 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:external-symbol #:of p #:count t))) 0) (deftest loop.16.74 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:present-symbols #:of p #:count t))) 0) (deftest loop.16.75 (progn (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:present-symbol #:of p #:count t))) 0) gcl-2.6.14/ansi-tests/broadcast-stream-streams.lsp0000644000175000017500000000122614360276512020515 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 22:06:28 2004 ;;;; Contains: Tests of BROADCAST-STREAM-STREAMS (in-package :cl-test) (deftest broadcast-stream-streams.1 (broadcast-stream-streams (make-broadcast-stream)) nil) (deftest broadcast-stream-streams.2 (equalt (broadcast-stream-streams (make-broadcast-stream *standard-output*)) (list *standard-output*)) t) (deftest broadcast-stream-streams.error.1 (signals-error (broadcast-stream-streams) program-error) t) (deftest broadcast-stream-streams.error.2 (signals-error (broadcast-stream-streams (make-broadcast-stream) nil) program-error) t) gcl-2.6.14/ansi-tests/rt-doc.txt0000644000175000017500000002077314360276512015027 0ustar cammcamm #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# (This is the December 19, 1990 version of brief documentation for the RT regression tester. A more complete discussion can be found in the article in Lisp Pointers.) The functions, macros, and variables that make up the RT regression tester are in a package called "RT". The ten exported symbols are documented below. If you want to refer to these symbols without a package prefix, you have to `use' the package. The basic unit of concern of RT is the test. Each test has an identifying name and a body that specifies the action of the test. Functions are provided for defining, redefining, removing, and performing individual tests and the test suite as a whole. In addition, information is maintained about which tests have succeeded and which have failed. <> deftest NAME FORM &rest VALUES Individual tests are defined using the macro DEFTEST. The identifying NAME is typically a number or symbol, but can be any Lisp form. If the test suite already contains a test with the same (EQUAL) NAME, then this test is redefined and a warning message printed. (This warning is important to alert the user when a test suite definition file contains two tests with the same name.) When the test is a new one, it is added to the end of the suite. In either case, NAME is returned as the value of DEFTEST and stored in the variable *TEST*. (deftest t-1 (floor 15/7) 2 1/7) => t-1 (deftest (t 2) (list 1) (1)) => (t 2) (deftest bad (1+ 1) 1) => bad (deftest good (1+ 1) 2) => good The FORM can be any kind of Lisp form. The zero or more VALUES can be any kind of Lisp objects. The test is performed by evaluating FORM and comparing the results with the VALUES. The test succeeds if and only if FORM produces the correct number of results and each one is EQUAL to the corresponding VALUE. <> *test* NAME-OF-CURRENT-TEST The variable *TEST* contains the name of the test most recently defined or performed. It is set by DEFTEST and DO-TEST. <> do-test &optional (NAME *TEST*) The function DO-TEST performs the test identified by NAME, which defaults to *TEST*. Before running the test, DO-TEST stores NAME in the variable *TEST*. If the test succeeds, DO-TEST returns NAME as its value. If the test fails, DO-TEST returns NIL, after printing an error report on *STANDARD-OUTPUT*. The following examples show the results of performing two of the tests defined above. (do-test '(t 2)) => (t 2) (do-test 'bad) => nil ; after printing: Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. <> *do-tests-when-defined* default value NIL If the value of this variable is non-null, each test is performed at the moment that it is defined. This is helpful when interactively constructing a suite of tests. However, when loading a test suite for later use, performing tests as they are defined is not liable to be helpful. <> get-test &optional (NAME *TEST*) This function returns the NAME, FORM, and VALUES of the specified test. (get-test '(t 2)) => ((t 2) (list 1) (1)) <> rem-test &optional (NAME *TEST*) If the indicated test is in the test suite, this function removes it and returns NAME. Otherwise, NIL is returned. <> rem-all-tests This function reinitializes RT by removing every test from the test suite and returns NIL. Generally, it is advisable for the whole test suite to apply to some one system. When switching from testing one system to testing another, it is wise to remove all the old tests before beginning to define new ones. <> do-tests &optional (OUT *STANDARD-OUTPUT*) This function uses DO-TEST to run each of the tests in the test suite and prints a report of the results on OUT, which can either be an output stream or the name of a file. If OUT is omitted, it defaults to *STANDARD-OUTPUT*. DO-TESTS returns T if every test succeeded and NIL if any test failed. As illustrated below, the first line of the report produced by DO-TEST shows how many tests need to be performed. The last line shows how many tests failed and lists their names. While the tests are being performed, DO-TESTS prints the names of the successful tests and the error reports from the unsuccessful tests. (do-tests "report.txt") => nil ; the file "report.txt" contains: Doing 4 pending tests of 4 tests total. T-1 (T 2) Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. GOOD 1 out of 4 total tests failed: BAD. It is best if the individual tests in the suite are totally independent of each other. However, should the need arise for some interdependence, you can rely on the fact that DO-TESTS will run tests in the order they were originally defined. <> pending-tests When a test is defined or redefined, it is marked as pending. In addition, DO-TEST marks the test to be run as pending before running it and DO-TESTS marks every test as pending before running any of them. The only time a test is marked as not pending is when it completes successfully. The function PENDING-TESTS returns a list of the names of the currently pending tests. (pending-tests) => (bad) <> continue-testing This function is identical to DO-TESTS except that it only runs the tests that are pending and always writes its output on *STANDARD-OUTPUT*. (continue-testing) => nil ; after printing: Doing 1 pending test out of 4 total tests. Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. 1 out of 4 total tests failed: BAD. CONTINUE-TESTING has a special meaning if called at a breakpoint generated while a test is being performed. The failure of a test to return the correct value does not trigger an error break. However, there are many kinds of things that can go wrong while a test is being performed (e.g., dividing by zero) that will cause breaks. If CONTINUE-TESTING is evaluated in a break generated during testing, it aborts the current test (which remains pending) and forces the processing of tests to continue. Note that in such a breakpoint, *TEST* is bound to the name of the test being performed and (GET-TEST) can be used to look at the test. When building a system, it is advisable to start constructing a test suite for it as soon as possible. Since individual tests are rather weak, a comprehensive test suite requires large numbers of tests. However, these can be accumulated over time. In particular, whenever a bug is found by some means other than testing, it is wise to add a test that would have found the bug and therefore will ensure that the bug will not reappear. Every time the system is changed, the entire test suite should be run to make sure that no unintended changes have occurred. Typically, some tests will fail. Sometimes, this merely means that tests have to be changed to reflect changes in the system's specification. Other times, it indicates bugs that have to be tracked down and fixed. During this phase, CONTINUE-TESTING is useful for focusing on the tests that are failing. However, for safety sake, it is always wise to reinitialize RT, redefine the entire test suite, and run DO-TESTS one more time after you think all of the tests are working. gcl-2.6.14/ansi-tests/vector-push.lsp0000644000175000017500000001662114360276512016072 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 00:55:43 2003 ;;;; Contains: Tests for VECTOR-PUSH (in-package :cl-test) (deftest vector-push.1 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(a b c d e))) (i 0) x y) (values (fill-pointer a) (vector-push (progn (setf x (incf i)) 'x) (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) 2 2 3 #(a b x) 2 1 2) (deftest vector-push.2 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push 'x a) (fill-pointer a) a)) 5 nil 5 #(a b c d e)) (deftest vector-push.3 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push.4 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 5 nil 5 "abcde") (deftest vector-push.5 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push.6 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) (fill-pointer a) a)) 5 nil 5 "abcde") (deftest vector-push.7 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(0 1 1 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #*010) (deftest vector-push.8 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(0 0 0 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push 1 a) (fill-pointer a) a)) 5 nil 5 #*00000) (deftest vector-push.9 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push.10 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 5 nil 5 #(1 2 3 4 5)) (deftest vector-push.11 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push.12 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) (fill-pointer a) a)) 5 nil 5 #(1 2 3 4 5)) (deftest vector-push.13 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) (fill-pointer a) a)) 2 2 3 #(1.0s0 2.0s0 0.0s0)) (deftest vector-push.14 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) (fill-pointer a) a)) 5 nil 5 #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (deftest vector-push.15 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) (fill-pointer a) a)) 2 2 3 #(1.0f0 2.0f0 0.0f0)) (deftest vector-push.16 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) (fill-pointer a) a)) 5 nil 5 #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (deftest vector-push.17 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) (fill-pointer a) a)) 2 2 3 #(1.0d0 2.0d0 0.0d0)) (deftest vector-push.18 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) (fill-pointer a) a)) 5 nil 5 #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (deftest vector-push.19 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) (fill-pointer a) a)) 2 2 3 #(1.0l0 2.0l0 0.0l0)) (deftest vector-push.20 (let ((a (make-array '(5) :fill-pointer 5 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) (fill-pointer a) a)) 5 nil 5 #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ;;; Error tests (defun vector-push-error-test (seq val) (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) (declare (optimize (safety 3))) (or (notnot (array-has-fill-pointer-p a)) (vector-push ',val a)))) (error () t))) (deftest vector-push.error.1 (vector-push-error-test #(a b c d) 'x) t) (deftest vector-push.error.2 (vector-push-error-test #*00000 1) t) (deftest vector-push.error.3 (vector-push-error-test "abcde" #\x) t) (deftest vector-push.error.4 (vector-push-error-test #() 'x) t) (deftest vector-push.error.5 (vector-push-error-test #* 1) t) (deftest vector-push.error.6 (vector-push-error-test "" #\x) t) (deftest vector-push.error.7 (vector-push-error-test (make-array '5 :element-type 'base-char :initial-element #\a) #\x) t) (deftest vector-push.error.8 (vector-push-error-test (make-array '5 :element-type '(integer 0 (256)) :initial-element 0) 17) t) (deftest vector-push.error.9 (vector-push-error-test (make-array '5 :element-type 'float :initial-element 1.0) 2.0) t) (deftest vector-push.error.10 (vector-push-error-test (make-array '5 :element-type 'short-float :initial-element 1.0s0) 2.0s0) t) (deftest vector-push.error.11 (vector-push-error-test (make-array '5 :element-type 'long-float :initial-element 1.0l0) 2.0l0) t) (deftest vector-push.error.12 (vector-push-error-test (make-array '5 :element-type 'single-float :initial-element 1.0f0) 2.0f0) t) (deftest vector-push.error.13 (vector-push-error-test (make-array '5 :element-type 'double-float :initial-element 1.0d0) 2.0d0) t) (deftest vector-push.error.14 (classify-error (vector-push)) program-error) (deftest vector-push.error.15 (classify-error (vector-push (vector 1 2 3))) program-error) (deftest vector-push.error.16 (classify-error (vector-push (vector 1 2 3) 4 nil)) program-error) gcl-2.6.14/ansi-tests/vector-pop.lsp0000644000175000017500000000176414360276512015713 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 24 07:46:29 2003 ;;;; Contains: Tests for VECTOR-POP (in-package :cl-test) (deftest vector-pop.1 (let ((v (make-array '(5) :initial-contents '(a b c d e) :fill-pointer 3))) (values (length v) (check-values (vector-pop v)) (fill-pointer v) (length v) v)) 3 c 2 2 #(a b)) ;;; Error cases (deftest vector-pop.error.1 (classify-error (vector-pop (vector 1 2 3))) type-error) (deftest vector-pop.error.2 (let ((v (make-array '(5) :initial-element 'x :fill-pointer 0))) (handler-case (vector-pop v) (error () 'error))) error) (deftest vector-pop.error.3 (classify-error (vector-pop)) program-error) (deftest vector-pop.error.4 (classify-error (let ((v (make-array '(5) :fill-pointer t :initial-element 'x))) (vector-pop v nil))) program-error) (deftest vector-pop.error.5 (classify-error (locally (vector-pop (vector 1 2 3)) t)) type-error) gcl-2.6.14/ansi-tests/let.lsp0000644000175000017500000000755414360276512014404 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 09:24:36 2002 ;;;; Contains: Tests for LET, LET* (in-package :cl-test) ;;; LET and LET* are also heavily exercised in the many other tests. ;;; NOTE! Some of these tests bind a variable with the same name ;;; more than once. This apparently has underdetermined semantics that ;;; varies in different Lisps. (deftest let.1 (let ((x 0)) x) 0) (deftest let.2 (let ((x 0) (y 1)) (values x y)) 0 1) (deftest let.3 (let ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let.4 (let ((x 0)) (let ((x 1)) x)) 1) (deftest let.5 (let ((x 0)) (let ((#:x 1)) x)) 0) (deftest let.6 (let ((x 0)) (declare (special x)) (let ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let.7 (let ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) ;;;(deftest let.8 ;;; (let ((x 0) (x 1)) x) ;;; 1) (deftest let.9 (let (x y z) (values x y z)) nil nil nil) ;;; (deftest let.10 ;;; (let ((x 1) x) x) ;;; nil) (deftest let.11 (let ((x 1)) (list x (let (x) (declare (special x)) x) x)) (1 nil 1)) ;;; (deftest let.12 ;;; (let ((x 0)) ;;; (values ;;; (let ((x 20) ;;; (x (1+ x))) ;;; x) ;;; x)) ;;; 1 0) ;;; (deftest let.13 ;;; (flet ((%f () (declare (special x)) ;;; (if (boundp 'x) x 10))) ;;; (let ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 11) ;;; Tests of large number of LET variables (deftest let.14 (let* ((n 1000) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET forms. (deftest let.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (let ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) ;;; Tests for LET* (deftest let*.1 (let* ((x 0)) x) 0) (deftest let*.2 (let* ((x 0) (y 1)) (values x y)) 0 1) (deftest let*.3 (let* ((x 0) (y 1)) (declare (special x y)) (values x y)) 0 1) (deftest let*.4 (let* ((x 0)) (let* ((x 1)) x)) 1) (deftest let*.5 (let* ((x 0)) (let* ((#:x 1)) x)) 0) (deftest let*.6 (let* ((x 0)) (declare (special x)) (let* ((x 1)) (values x (locally (declare (special x)) x)))) 1 0) (deftest let*.7 (let* ((x '(a b c))) (declare (dynamic-extent x)) x) (a b c)) (deftest let*.8 (let* ((x 0) (x 1)) x) 1) (deftest let*.9 (let* (x y z) (values x y z)) nil nil nil) (deftest let*.10 (let* ((x 1) x) x) nil) (deftest let*.11 (let* ((x 1)) (list x (let* (x x x) (declare (special x)) x) x)) (1 nil 1)) (deftest let*.12 (let* ((x 1) (y (1+ x)) (x (1+ y)) (z (+ x y))) (values x y z)) 3 2 5) ;;; (deftest let*.13 ;;; (flet ((%f () (declare (special x)) x)) ;;; (let* ((x 1) ;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 2) ;;; Tests of large number of LET* variables (deftest let*.14 (let* ((n 1000) (vars (mapcar #'gensym (make-list n :initial-element "G"))) (expr `(let* ,(let ((i 0)) (mapcar #'(lambda (v) (list v (incf i))) vars)) ,(let ((sumexpr 0)) (dolist (v vars) (setq sumexpr `(+ ,v ,sumexpr))) sumexpr))) (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) ;;; Test that all non-variables exported from COMMON-LISP can be bound ;;; in LET* forms. (deftest let*.15 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (let* ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) gcl-2.6.14/ansi-tests/notany.lsp0000644000175000017500000000533314360276512015121 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:14:14 2002 ;;;; Contains: Tests for NOTANY (in-package :cl-test) (deftest notany.1 (not-mv (notany #'identity nil)) nil) (deftest notany.2 (not-mv (notany #'identity #())) nil) (deftest notany.3 (let ((count 0)) (values (notany #'(lambda (x) (incf count) (if (>= x 10) x nil)) '(1 2 4 13 5 1)) count)) nil 4) (deftest notany.4 (not-mv (notany #'/= '(1 2 3 4) '(1 2 3 4 5))) nil) (deftest notany.5 (not-mv (notany #'/= '(1 2 3 4 5) '(1 2 3 4))) nil) (deftest notany.6 (notany #'/= '(1 2 3 4 5) '(1 2 3 4 6)) nil) (deftest notany.7 (not-mv (notany #'(lambda (x y) (and x y)) '(nil t t nil t) #(t nil nil t nil nil))) nil) (deftest notany.8 (let* ((x '(1)) (args (list x))) (not (loop for i from 2 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'notany #'/= args)))) nil) (deftest notany.9 (not-mv (notany #'zerop #*11111111111111)) nil) (deftest notany.10 (not-mv (notany #'zerop #*)) nil) (deftest notany.11 (notany #'zerop #*1111111011111) nil) (deftest notany.12 (not-mv (notany #'(lambda (x) (not (eql x #\a))) "aaaaaaaa")) nil) (deftest notany.13 (not-mv (notany #'(lambda (x) (eql x #\a)) "")) nil) (deftest notany.14 (notany #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa") nil) (deftest notany.15 (not-mv (notany 'null '(1 2 3 4))) nil) (deftest notany.16 (notany 'null '(1 2 3 nil 5)) nil) (deftest notany.order.1 (let ((i 0) a b) (values (not (notany (progn (setf a (incf i)) 'null) (progn (setf b (incf i)) '(a b c)))) i a b)) nil 2 1 2) ;;; Error cases (deftest notany.error.1 (classify-error (notany 1 '(a b c))) type-error) (deftest notany.error.2 (classify-error (notany #\a '(a b c))) type-error) (deftest notany.error.3 (classify-error (notany #() '(a b c))) type-error) (deftest notany.error.4 (classify-error (notany #'null 'a)) type-error) (deftest notany.error.5 (classify-error (notany #'null 100)) type-error) (deftest notany.error.6 (classify-error (notany #'null 'a)) type-error) (deftest notany.error.7 (classify-error (notany #'eq () 'a)) type-error) (deftest notany.error.8 (classify-error (notany)) program-error) (deftest notany.error.9 (classify-error (notany #'null)) program-error) (deftest notany.error.10 (classify-error (locally (notany 1 '(a b c)) t)) type-error) (deftest notany.error.11 (classify-error (notany #'cons '(a b c))) program-error) (deftest notany.error.12 (classify-error (notany #'cons '(a b c) '(1 2 4) '(g h j))) program-error) (deftest notany.error.13 (classify-error (notany #'car '(a b c))) type-error)gcl-2.6.14/ansi-tests/nsubstitute.lsp0000644000175000017500000006460714360276512016213 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 16:56:48 2002 ;;;; Contains: Tests for NSUBSTITUTE (in-package :cl-test) (deftest nsubstitute-list.1 (nsubstitute 'b 'a nil) nil) (deftest nsubstitute-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x) x) (b b b c)) (deftest nsubstitute-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count nil)) (b b b c)) (deftest nsubstitute-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2)) (b b b c)) (deftest nsubstitute-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1)) (b b a c)) (deftest nsubstitute-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0)) (a b a c)) (deftest nsubstitute-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1)) (a b a c)) (deftest nsubstitute-list.8 (nsubstitute 'b 'a nil :from-end t) nil) (deftest nsubstitute-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t)) (b b b c)) (deftest nsubstitute-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) (1 2 x x x x x 8 9)) (deftest nsubstitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) result) (1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) result) (1 2 3 4 5 6 7 x 9)) ;;; Tests on vectors (deftest nsubstitute-vector.1 (let ((x #())) (values (nsubstitute 'b 'a x) x)) #() #()) (deftest nsubstitute-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x)) #(b b b c)) (deftest nsubstitute-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count nil) x) #(b b b c)) (deftest nsubstitute-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2)) #(b b b c)) (deftest nsubstitute-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1)) #(b b a c)) (deftest nsubstitute-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0)) #(a b a c)) (deftest nsubstitute-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1)) #(a b a c)) (deftest nsubstitute-vector.8 (let ((x #())) (nsubstitute 'b 'a x :from-end t)) #()) (deftest nsubstitute-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t)) #(b b b c)) (deftest nsubstitute-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) #(1 2 x x x x x 8 9)) (deftest nsubstitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x))) result) #(z b z c b)) (deftest nsubstitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest nsubstitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-string.1 (let ((x "")) (nsubstitute #\b #\a x)) "") (deftest nsubstitute-string.2 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x)) "bbbc") (deftest nsubstitute-string.3 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count nil)) "bbbc") (deftest nsubstitute-string.4 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2)) "bbbc") (deftest nsubstitute-string.5 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1)) "bbac") (deftest nsubstitute-string.6 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0)) "abac") (deftest nsubstitute-string.7 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1)) "abac") (deftest nsubstitute-string.8 (let ((x "")) (nsubstitute #\b #\a x :from-end t)) "") (deftest nsubstitute-string.9 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t)) "bbbc") (deftest nsubstitute-string.10 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t :count nil)) "bbbc") (deftest nsubstitute-string.11 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-string.12 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1 :from-end t)) "abbc") (deftest nsubstitute-string.13 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0 :from-end t)) "abac") (deftest nsubstitute-string.14 (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1 :from-end t)) "abac") (deftest nsubstitute-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-string.19 (let* ((orig "123456789") (x (copy-seq orig)) (result (nsubstitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (<= (abs (- a b)) 2))))) result) "12xxxxx89") (deftest nsubstitute-string.20 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (nsubstitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.21 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (nsubstitute #\x #\9 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (= (+ b c) a)) :from-end t))) result) "1234567x9") (deftest nsubstitute-string.22 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (/= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.23 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (/= (+ b c) a)) :from-end t))) result) "1234567x9") (deftest nsubstitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x))) result) "zbzcb") (deftest nsubstitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :from-end t))) result) "zbzcb") (deftest nsubstitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :count 1))) result) "zbacb") (deftest nsubstitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute #\z #\a x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute 0 1 x))) result) #*) (deftest nsubstitute-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute 1 0 x))) result) #*) (deftest nsubstitute-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x))) result) #*000000) (deftest nsubstitute-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x))) result) #*111111) (deftest nsubstitute-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :start 1))) result) #*011111) (deftest nsubstitute-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :end 4))) result) #*111101) (deftest nsubstitute-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :end nil))) result) #*000000) (deftest nsubstitute-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :end 3))) result) #*000101) (deftest nsubstitute-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 0 1 x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 1))) result) #*110101) (deftest nsubstitute-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 0))) result) #*010101) (deftest nsubstitute-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count -1))) result) #*010101) (deftest nsubstitute-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count nil))) result) #*111111) (deftest nsubstitute-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute 1 0 x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute 1 0 x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) (deftest nsubstitute-bit-vector.22 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) result) #*0111110101) (deftest nsubstitute-bit-vector.23 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b))))))) result) #*0111110101) (deftest nsubstitute-bit-vector.24 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) :from-end t))) result) #*0101011111) (deftest nsubstitute-bit-vector.25 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b)))) :from-end t))) result) #*0101011111) ;;;; additional tests (deftest nsubstitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-string.26 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) result) "0a0aaaa0aa") (deftest nsubstitute-string.27 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) result) "0a0aaaa0aa") (deftest nsubstitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x))) result) #*11111) (deftest nsubstitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :from-end t))) result) #*11111) (deftest nsubstitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :count 1))) result) #*11011) (deftest nsubstitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute 1 0 x :from-end t :count 1))) result) #*01111) (deftest nsubstitute.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute.allow-other-keys.1 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.2 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.3 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.4 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.5 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute.keywords.6 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest nsubstitute.allow-other-keys.7 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.8 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest nsubstitute.error.1 (classify-error (nsubstitute)) program-error) (deftest nsubstitute.error.2 (classify-error (nsubstitute 'a)) program-error) (deftest nsubstitute.error.3 (classify-error (nsubstitute 'a 'b)) program-error) (deftest nsubstitute.error.4 (classify-error (nsubstitute 'a 'b nil 'bad t)) program-error) (deftest nsubstitute.error.5 (classify-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute.error.6 (classify-error (nsubstitute 'a 'b nil :key)) program-error) (deftest nsubstitute.error.7 (classify-error (nsubstitute 'a 'b nil 1 2)) program-error) (deftest nsubstitute.error.8 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity)) program-error) (deftest nsubstitute.error.9 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest nsubstitute.error.10 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons)) program-error) (deftest nsubstitute.error.11 (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car)) type-error) gcl-2.6.14/ansi-tests/position-if.lsp0000644000175000017500000003113414360276512016047 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 22:08:57 2002 ;;;; Contains: Tests for POSITION-IF (in-package :cl-test) (deftest position-if-list.1 (position-if #'evenp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-list.2 (position-if 'evenp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-list.3 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-list.4 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-list.5 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-list.6 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-list.7 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-list.8 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-list.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-list.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-list.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-list.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) ;;; Vector tests (deftest position-if-vector.1 (position-if #'evenp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-vector.2 (position-if 'evenp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-vector.3 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-vector.4 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-vector.5 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-vector.6 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-vector.7 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-vector.8 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-vector.13 (let ((a (make-array '(10) :initial-contents '(1 3 1 4 3 1 2 1 8 9) :fill-pointer 5))) (flet ((%f (x) (eql x 1))) (values (position-if #'%f a) (position-if #'%f a :from-end t)))) 0 2) ;;; Bit vector tests (deftest position-if-bit-vector.1 (position-if #'evenp #*111010101) 3) (deftest position-if-bit-vector.2 (position-if 'evenp #*111010101) 3) (deftest position-if-bit-vector.3 (position-if #'evenp #*111010101 :start 4) 5) (deftest position-if-bit-vector.4 (position-if #'evenp #*111010101 :from-end t) 7) (deftest position-if-bit-vector.5 (position-if #'evenp #*111010101 :from-end nil) 3) (deftest position-if-bit-vector.6 (position-if #'evenp #*111010101 :start 4 :from-end t) 7) (deftest position-if-bit-vector.7 (position-if #'evenp #*111010101 :end nil) 3) (deftest position-if-bit-vector.8 (position-if #'evenp #*111010101 :end 3) nil) (deftest position-if-bit-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evenp #*111010101 :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #*111010101 :start i :end j :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'oddp #*111010101 :start i :end j :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :fill-pointer 5 :element-type 'bit))) (values (position-if #'evenp a) (position-if #'evenp a :from-end 'foo) (position-if #'oddp a) (position-if #'oddp a :from-end 'foo))) nil nil 0 4) ;;; string tests (deftest position-if-string.1 (position-if #'evendigitp "131432189") 3) (deftest position-if-string.2 (position-if 'evendigitp "131432189") 3) (deftest position-if-string.3 (position-if #'evendigitp "131432189" :start 4) 5) (deftest position-if-string.4 (position-if #'evendigitp "131432189" :from-end t) 7) (deftest position-if-string.5 (position-if #'evendigitp "131432189" :from-end nil) 3) (deftest position-if-string.6 (position-if #'evendigitp "131432189" :start 4 :from-end t) 7) (deftest position-if-string.7 (position-if #'evendigitp "131432189" :end nil) 3) (deftest position-if-string.8 (position-if #'evendigitp "131432189" :end 3) nil) (deftest position-if-string.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evendigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-string.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'evendigitp "131432189" :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-string.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'odddigitp "131432189" :start i :end j :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-string.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if #'odddigitp "131432189" :start i :end j :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-string.13 (flet ((%f (c) (eql c #\0)) (%g (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "1111100000" :fill-pointer 5 :element-type 'character))) (values (position-if #'%f a) (position-if #'%f a :from-end 'foo) (position-if #'%g a) (position-if #'%g a :from-end 'foo)))) nil nil 0 4) (deftest position-if.order.1 (let ((i 0) a b c d e f) (values (position-if (progn (setf a (incf i)) #'zerop) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-)) i a b c d e f)) 4 6 1 2 3 4 5 6) (deftest position-if.order.2 (let ((i 0) a b c d e f) (values (position-if (progn (setf a (incf i)) #'zerop) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :key (progn (setf c (incf i)) #'1-) :end (progn (setf d (incf i)) 6) :start (progn (setf e (incf i)) 1) :from-end (setf f (incf i))) i a b c d e f)) 4 6 1 2 3 4 5 6) ;;; Keyword tests (deftest position-if.allow-other-keys.1 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t) 2) (deftest position-if.allow-other-keys.2 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.3 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t) 2) (deftest position-if.allow-other-keys.4 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t) 2) (deftest position-if.allow-other-keys.5 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) 0) (deftest position-if.keywords.6 (position-if #'zerop '(1 2 0 3 2 1) :key #'1- :key #'identity) 0) (deftest position-if.allow-other-keys.7 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.8 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.9 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position-if.error.1 (classify-error (position-if #'identity 'b)) type-error) (deftest position-if.error.2 (classify-error (position-if #'identity 10)) type-error) (deftest position-if.error.3 (classify-error (position-if 'null 1.4)) type-error) (deftest position-if.error.4 (classify-error (position-if 'null '(a b c . d))) type-error) (deftest position-if.error.5 (classify-error (position-if)) program-error) (deftest position-if.error.6 (classify-error (position-if #'null)) program-error) (deftest position-if.error.7 (classify-error (position-if #'null nil :key)) program-error) (deftest position-if.error.8 (classify-error (position-if #'null nil 'bad t)) program-error) (deftest position-if.error.9 (classify-error (position-if #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest position-if.error.10 (classify-error (position-if #'null nil 1 2)) program-error) (deftest position-if.error.11 (classify-error (locally (position-if #'identity 'b) t)) type-error) (deftest position-if.error.12 (classify-error (position-if #'cons '(a b c d))) program-error) (deftest position-if.error.13 (classify-error (position-if #'car '(a b c d))) type-error) (deftest position-if.error.14 (classify-error (position-if #'identity '(a b c d) :key #'cdr)) type-error) (deftest position-if.error.15 (classify-error (position-if #'identity '(a b c d) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/nth-value.lsp0000644000175000017500000000132614360276512015512 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 08:24:14 2002 ;;;; Contains: Tests of NTH-VALUE (in-package :cl-test) (deftest nth-value.1 (nth-value 0 'a) a) (deftest nth-value.2 (nth-value 1 'a) nil) (deftest nth-value.3 (nth-value 0 (values)) nil) (deftest nth-value.4 (loop for i from 0 to 19 collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p 'q 'r 's))) (a b c d e f g h i j k l m n o p q r s nil)) (deftest nth-value.5 (nth-value 100 'a) nil) (deftest nth-value.order.1 (let ((i 0) x y) (values (nth-value (progn (setf x (incf i)) 3) (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) i x y)) d 2 1 2) gcl-2.6.14/ansi-tests/array-aux.lsp0000644000175000017500000001516014360276512015521 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 05:11:31 2003 ;;;; Contains: Auxiliary functions for array tests (in-package :cl-test) (defun make-array-check-upgrading (type) (subtypep* type (array-element-type (make-array 0 :element-type type)))) (defun subtypep-or-unknown (subtype supertype) (multiple-value-bind* (is-subtype is-known) (subtypep subtype supertype) (or (not is-known) (notnot is-subtype)))) (defun make-array-with-checks (dimensions &rest options &key (element-type t element-type-p) (initial-contents nil initial-contents-p) (initial-element nil initial-element-p) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0 dio-p) &aux (dimensions-list (if (listp dimensions) dimensions (list dimensions)))) "Call MAKE-ARRAY and do sanity tests on the output." (declare (ignore element-type-p initial-contents initial-contents-p initial-element initial-element-p dio-p)) (let ((a (check-values (apply #'make-array dimensions options))) (rank (length dimensions-list))) (cond ((not (typep a 'array)) :fail-not-array) ((not (typep a (find-class 'array))) :fail-not-array-class) ((not (typep a '(array *))) :fail-not-array2) ((not (typep a `(array * ,dimensions-list))) :fail-not-array3) ((not (typep a `(array * *))) :fail-not-array4) ((not (typep a `(array ,element-type))) :fail-not-array5) ((not (typep a `(array ,element-type *))) :fail-not-array6) #-gcl ((not (typep a `(array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(array ,element-type ,dimensions-list))) :fail-not-array8) ((not (typep a `(array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-array9) ((loop for i from 0 below (min 10 rank) thereis (let ((x (append (subseq dimensions-list 0 i) (list '*) (subseq dimensions-list (1+ i))))) (or (not (typep a `(array * ,x))) (not (typep a `(array ,element-type ,x)))))) :fail-not-array10) ((not (check-values (arrayp a))) :fail-not-arrayp) ((and ;; (eq t element-type) (not adjustable) (not fill-pointer) (not displaced-to) (cond ((not (typep a 'simple-array)) :fail-not-simple-array) ((not (typep a '(simple-array *))) :fail-not-simple-array2) ((not (typep a `(simple-array * ,dimensions-list))) :fail-not-simple-array3) ((not (typep a `(simple-array * *))) :fail-not-simple-array4) ((not (typep a `(simple-array ,element-type))) :fail-not-simple-array5) ((not (typep a `(simple-array ,element-type *))) :fail-not-simple-array6) #-gcl ((not (typep a `(simple-array ,element-type ,rank))) :fail-not-array7) ((not (typep a `(simple-array ,element-type ,dimensions-list))) :fail-not-simple-array8) ((not (typep a `(simple-array ,element-type ,(mapcar (constantly '*) dimensions-list)))) :fail-not-simple-array9) ))) ;; If the array is a vector, check that... ((and (eql rank 1) (cond ;; ...It's in type vector ((not (typep a 'vector)) :fail-not-vector) ;; ...If the element type is a subtype of BIT, then it's a ;; bit vector... ((and (subtypep 'bit element-type) (subtypep element-type 'bit) (or (not (bit-vector-p a)) (not (typep a 'bit-vector)))) :fail-not-bit-vector) ;; ...If not adjustable, fill pointered, or displaced, ;; then it's a simple vector or simple bit vector ;; (if the element-type is appropriate) ((and (not adjustable) (not fill-pointer) (not displaced-to) (cond ((and (eq t element-type) (or (not (simple-vector-p a)) (not (typep a 'simple-vector)))) :fail-not-simple-vector) ((and (subtypep 'bit element-type) (subtypep element-type 'bit) (or (not (simple-bit-vector-p a)) (not (typep a 'simple-bit-vector)))) :fail-not-simple-bit-vector) ))) ))) ;; The dimensions of the array must be initialized properly ((not (equal (array-dimensions a) dimensions-list)) :fail-array-dimensions) ;; The rank of the array must equal the number of dimensions ((not (equal (array-rank a) rank)) :fail-array-rank) ;; Arrays other than vectors cannot have fill pointers ((and (not (equal (array-rank a) 1)) (array-has-fill-pointer-p a)) :fail-non-vector-fill-pointer) ;; The actual element type must be a supertype of the element-type ;; argument ((not (subtypep-or-unknown element-type (array-element-type a))) :failed-array-element-type) ;; If :adjustable is given, the array must be adjustable. ((and adjustable (not (check-values (adjustable-array-p a))) :fail-adjustable)) ;; If :fill-pointer is given, the array must have a fill pointer ((and fill-pointer (not (check-values (array-has-fill-pointer-p a))) :fail-has-fill-pointer)) ;; If the fill pointer is given as an integer, it must be the value ;; of the fill pointer of the new array ((and (check-values (integerp fill-pointer)) (not (eql fill-pointer (check-values (fill-pointer a)))) :fail-fill-pointer-1)) ;; If the fill-pointer argument is t, the fill pointer must be ;; set to the vector size. ((and (eq fill-pointer t) (not (eql (first dimensions-list) (fill-pointer a))) :fail-fill-pointer-2)) ;; If displaced-to another array, check that this is proper ((and displaced-to (multiple-value-bind* (actual-dt actual-dio) (array-displacement a) (cond ((not (eq actual-dt displaced-to)) :fail-displacement-1) ((not (eql actual-dio displaced-index-offset)) :fail-displaced-index-offset))))) ;; Test of array-total-size ((not (eql (check-values (array-total-size a)) (reduce #'* dimensions-list :initial-value 1))) :fail-array-total-size) ;; Test array-row-major-index on all zeros ((and (> (array-total-size a) 0) (not (eql (check-values (apply #'array-row-major-index a (make-list (array-rank a) :initial-element 0))) 0))) :fail-array-row-major-index-0) ;; For the last entry ((and (> (array-total-size a) 0) (not (eql (apply #'array-row-major-index a (mapcar #'1- dimensions-list)) (1- (reduce #'* dimensions-list :initial-value 1))))) :fail-array-row-major-index-last) ;; No problems -- return the array (t a)))) gcl-2.6.14/ansi-tests/structures-01.lsp0000644000175000017500000000440714360276512016253 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 2 21:45:32 1998 ;;;; Contains: Test code for structures, part 01 (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Tests for structures ;;; ;;; The CL Spec leaves undefined just what will happen when a structure is ;;; redefined. These tests don't redefine structures, but reloading a file ;;; with structure definition will do so. I assume that this leaves the ;;; structure type unchanged. ;; Test simple defstruct (fields, no options) (defstruct s-1 foo bar) ;; Test that make-s-1 produces objects ;; of the correct type (deftest structure-1-1 (notnot-mv (typep (make-s-1) 's-1)) t) ;; Test that the -p predicate exists (deftest structure-1-2 (notnot-mv (s-1-p (make-s-1))) t) ;; Test that all the objects in the universe are ;; not of this type (deftest structure-1-3 (count-if #'s-1-p *universe*) 0) (deftest structure-1-4 (count-if #'(lambda (x) (typep x 's-1)) *universe*) 0) ;; Check that the fields can be read after being initialized (deftest structure-1-5 (s-1-foo (make-s-1 :foo 'a)) a) (deftest structure-1-6 (s-1-bar (make-s-1 :bar 'b)) b) (deftest structure-1-7 (let ((s (make-s-1 :foo 'c :bar 'd))) (list (s-1-foo s) (s-1-bar s))) (c d)) ;; Can setf the fields (deftest structure-1-8 (let ((s (make-s-1))) (setf (s-1-foo s) 'e) (setf (s-1-bar s) 'f) (list (s-1-foo s) (s-1-bar s))) (e f)) (deftest structure-1-9 (let ((s (make-s-1 :foo 'a :bar 'b))) (setf (s-1-foo s) 'e) (setf (s-1-bar s) 'f) (list (s-1-foo s) (s-1-bar s))) (e f)) ;; copier function defined (deftest structure-1-10 (let ((s (make-s-1 :foo 'a :bar 'b))) (let ((s2 (copy-s-1 s))) (setf (s-1-foo s) nil) (setf (s-1-bar s) nil) (list (s-1-foo s2) (s-1-bar s2)))) (a b)) ;; Make produces unique items (deftest structure-1-11 (eqt (make-s-1) (make-s-1)) nil) (deftest structure-1-12 (eqt (make-s-1 :foo 'a :bar 'b) (make-s-1 :foo 'a :bar 'b)) nil) ;; More type and class checks (deftest structure-1-13 (notnot-mv (typep (class-of (make-s-1)) 'structure-class)) t) (deftest structure-1-14 (notnot-mv (typep (make-s-1) 'structure-object)) t) (deftest structure-1-15 (subtypep* 's-1 'structure-object) t t) gcl-2.6.14/ansi-tests/make-two-way-stream.lsp0000644000175000017500000001565614360276512017435 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Jan 30 05:39:56 2004 ;;;; Contains: Tests for MAKE-TWO-WAY-STREAM (in-package :cl-test) (deftest make-two-way-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (assert (typep s 'stream)) (assert (typep s 'two-way-stream)) (assert (streamp s)) (assert (open-stream-p s)) (assert (input-stream-p s)) (assert (output-stream-p s)) (assert (stream-element-type s)) (values (read-char s) (write-char #\b s) (read-char s) (write-char #\a s) (read-char s) (write-char #\r s) (get-output-stream-string os))) #\f #\b #\o #\a #\o #\r "bar") (deftest make-two-way-stream.2 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (close s) (open-stream-p s) (notnot (open-stream-p is)) (notnot (open-stream-p os)) (write-char #\8 os) (get-output-stream-string os))) t nil t t #\8 "8") (deftest make-two-way-stream.3 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (peek-char nil s) (read-char s) (get-output-stream-string os))) #\f #\f "") (deftest make-two-way-stream.4 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-char-no-hang s) (read-char-no-hang s nil) (read-char-no-hang s t :eof) (read-char-no-hang s nil :eof) (get-output-stream-string os))) #\f #\o #\o :eof "") (deftest make-two-way-stream.5 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (terpri s) (get-output-stream-string os))) nil #.(string #\Newline)) (deftest make-two-way-stream.6 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-char #\+ s) (notnot (fresh-line s)) (read-char s) (get-output-stream-string os))) #\+ t #\f #.(coerce (list #\+ #\Newline) 'string)) (deftest make-two-way-stream.7 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-char s) (unread-char #\f s) (read-char s) (read-char s) (unread-char #\o s) (get-output-stream-string os))) #\f nil #\f #\o nil "") (deftest make-two-way-stream.8 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (read-line s) (get-output-stream-string os))) "foo" "") (deftest make-two-way-stream.9 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-string "bar" s) (get-output-stream-string os))) "bar" "bar") (deftest make-two-way-stream.10 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-line "bar" s) (get-output-stream-string os))) "bar" #.(concatenate 'string "bar" '(#\Newline))) (deftest make-two-way-stream.11 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (let ((x (vector nil nil nil))) (values (read-sequence x s) x (get-output-stream-string os)))) 3 #(#\f #\o #\o) "") (deftest make-two-way-stream.12 (let ((pn1 #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn1 :direction :output :if-exists :supersede :element-type element-type) (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type :if-exists :supersede) (let ((s (make-two-way-stream is os)) (x (vector nil nil nil nil))) (assert (eql (read-sequence x s) 4)) (assert (equalp x #(3 8 19 41))) (let ((y #(100 5 18 211 0 178))) (assert (eql (write-sequence y s) y)) (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values (read-sequence x s) x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.13 (let ((pn1 #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 32))) (with-open-file (s pn1 :direction :output :if-exists :supersede :element-type element-type) (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type :if-exists :supersede) (let ((s (make-two-way-stream is os)) (x (vector nil nil nil nil))) (assert (eql (read-sequence x s) 4)) (assert (equalp x #(3 8 19 41))) (let ((y #(100 5 18 211 0 178))) (assert (eql (write-sequence y s) y)) (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values (read-sequence x s) x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.14 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (values (write-string "abc" s) (clear-input s) (write-string "def" s) (get-output-stream-string os))) "abc" nil "def" "abcdef") ;;; Error tests (deftest make-two-way-stream.error.1 (signals-error (make-two-way-stream) program-error) t) (deftest make-two-way-stream.error.2 (signals-error (make-two-way-stream (make-string-input-stream "foo")) program-error) t) (deftest make-two-way-stream.error.3 (signals-error (let ((os (make-string-output-stream))) (make-two-way-stream (make-string-input-stream "foo") os nil)) program-error) t) (deftest make-two-way-stream.error.4 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) #'(lambda (x) (and (streamp x) (input-stream-p x)))) nil) (deftest make-two-way-stream.error.5 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) #'(lambda (x) (and (streamp x) (input-stream-p x))) *streams*) nil) (deftest make-two-way-stream.error.6 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-two-way-stream.error.7 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) #'(lambda (x) (and (streamp x) (output-stream-p x))) *streams*) nil) gcl-2.6.14/ansi-tests/replace.lsp0000644000175000017500000003772514360276512015236 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 27 16:11:38 2002 ;;;; Contains: Tests for REPLACE (in-package :cl-test) (deftest replace-list.1 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z)))) (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.2 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 1))) (values (eqt x result) result)) t (a x y z e f g)) (deftest replace-list.3 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4))) (values (eqt x result) result)) t (a b c d x y z)) (deftest replace-list.4 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 5))) (values (eqt x result) result)) t (a b c d e x y)) (deftest replace-list.5 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 6))) (values (eqt x result) result)) t (a b c d e f x)) (deftest replace-list.6 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x #(x y z) :start1 2))) (values (eqt x result) result)) t (a b x y z f g)) (deftest replace-list.7 (replace nil #(x y z)) nil) (deftest replace-list.8 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :end1 1))) (values (eqt x result) result)) t (x b c d e f g)) (deftest replace-list.9 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t (a b c x e f g)) (deftest replace-list.10 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.11 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.12 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.13 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.14 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t (y b c d e f g)) (deftest replace-list.15 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t (a b c d y f g)) (deftest replace-list.16 (let* ((x (copy-seq '(a b c d e f))) (y #(1 2 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.17 (let* ((x (copy-seq '(a b c d e f))) (y (make-array '(3) :initial-contents '(1 2 3) :fill-pointer t)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.18 (let* ((x (copy-seq '(a b c d e f))) (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.19 (let* ((x (copy-seq '(a b c d e f))) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t (b c d d e f)) (deftest replace-list.20 (let* ((x (copy-seq '(a b c d e f))) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t (a a b c e f)) ;;; Tests of vectors (deftest replace-vector.1 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z)))) (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.2 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 1))) (values (eqt x result) result)) t #(a x y z e f g)) (deftest replace-vector.3 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4))) (values (eqt x result) result)) t #(a b c d x y z)) (deftest replace-vector.4 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 5))) (values (eqt x result) result)) t #(a b c d e x y)) (deftest replace-vector.5 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 6))) (values (eqt x result) result)) t #(a b c d e f x)) (deftest replace-vector.6 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x '(x y z) :start1 2))) (values (eqt x result) result)) t #(a b x y z f g)) (deftest replace-vector.7 (replace #() #(x y z)) #()) (deftest replace-vector.8 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :end1 1))) (values (eqt x result) result)) t #(x b c d e f g)) (deftest replace-vector.9 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t #(a b c x e f g)) (deftest replace-vector.10 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.11 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.12 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.13 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.14 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t #(y b c d e f g)) (deftest replace-vector.15 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #(a b c d y f g)) (deftest replace-vector.16 (let* ((x (copy-seq #(a b c d e f))) (y '(1 2 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.17 (let* ((x (copy-seq #(a b c d e f))) (y (make-array '(3) :initial-contents '(1 2 3) :fill-pointer t)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.18 (let* ((x (copy-seq #(a b c d e f))) (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 3)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.19 (let* ((x (copy-seq #(a b c d e f))) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #(b c d d e f)) (deftest replace-vector.21 (let* ((x (copy-seq #(a b c d e f))) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #(a a b c e f)) ;;; tests on bit vectors (deftest replace-bit-vector.1 (let* ((x (copy-seq #*1101001)) (result (replace x #*011))) (values (eqt x result) result)) t #*0111001) (deftest replace-bit-vector.2 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 1))) (values (eqt x result) result)) t #*1011001) (deftest replace-bit-vector.3 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 4))) (values (eqt x result) result)) t #*1101011) (deftest replace-bit-vector.4 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 5))) (values (eqt x result) result)) t #*0000011) (deftest replace-bit-vector.5 (let* ((x (copy-seq #*0000000)) (result (replace x #*100 :start1 6))) (values (eqt x result) result)) t #*0000001) (deftest replace-bit-vector.6 (let* ((x (copy-seq #*0000000)) (result (replace x '(1 1 1) :start1 2))) (values (eqt x result) result)) t #*0011100) (deftest replace-bit-vector.7 (replace #* #*111) #*) (deftest replace-bit-vector.8 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :end1 1))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.9 (let* ((x (copy-seq #*0000000)) (result (replace x #*110 :start1 3 :end1 4))) (values (eqt x result) result)) t #*0001000) (deftest replace-bit-vector.10 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 0 :end1 5))) (values (eqt x result) result)) t #*1110000) (deftest replace-bit-vector.11 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.12 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end1 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.13 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.14 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 2))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.15 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #*0000100) (deftest replace-bit-vector.16 (let* ((x (copy-seq #*001011)) (y '(1 0 1)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.17 (let* ((x (copy-seq #*001011)) (y (make-array '(3) :initial-contents '(1 0 1) :fill-pointer t :element-type 'bit)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.18 (let* ((x (copy-seq #*001011)) (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) :fill-pointer 3 :element-type 'bit)) (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.19 (let* ((x (copy-seq #*001011)) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #*010011) (deftest replace-bit-vector.21 (let* ((x (copy-seq #*001011)) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #*000111) ;;; Tests on strings (deftest replace-string.1 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz"))) (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.2 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 1))) (values (eqt x result) result)) t "axyzefg") (deftest replace-string.3 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4))) (values (eqt x result) result)) t "abcdxyz") (deftest replace-string.4 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 5))) (values (eqt x result) result)) t "abcdexy") (deftest replace-string.5 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 6))) (values (eqt x result) result)) t "abcdefx") (deftest replace-string.6 (let* ((x (copy-seq "abcdefg")) (result (replace x '(#\x #\y #\z) :start1 2))) (values (eqt x result) result)) t "abxyzfg") (deftest replace-string.7 (replace "" "xyz") "") (deftest replace-string.8 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :end1 1))) (values (eqt x result) result)) t "xbcdefg") (deftest replace-string.9 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 3 :end1 4))) (values (eqt x result) result)) t "abcxefg") (deftest replace-string.10 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 0 :end1 5))) (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.11 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.12 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end1 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.13 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.14 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 2))) (values (eqt x result) result)) t "ybcdefg") (deftest replace-string.15 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t "abcdyfg") (deftest replace-string.16 (let* ((x (copy-seq "abcdef")) (y (coerce "123" 'list)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.17 (let* ((x (copy-seq "abcdef")) (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) :fill-pointer t :element-type 'character)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.18 (let* ((x (copy-seq "abcdef")) (y (make-array '(6) :initial-contents "123456" :fill-pointer 3 :element-type 'character)) (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.19 (let* ((x (copy-seq "abcdef")) (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t "bcddef") (deftest replace-string.21 (let* ((x (copy-seq "abcdef")) (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t "aabcef") ;;; Order of evaluation tests (deftest replace.order.1 (let ((i 0) a b) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f))) i a b)) (e f c) 2 1 2) (deftest replace.order.2 (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f)) :start1 (progn (setf c (incf i)) 1) :end1 (progn (setf d (incf i)) 3) :start2 (progn (setf e (incf i)) 0) :end2 (progn (setf f (incf i)) 2) ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) (deftest replace.order.3 (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) (progn (setf b (incf i)) (list 'e 'f)) :end2 (progn (setf c (incf i)) 2) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) 3) :start1 (progn (setf f (incf i)) 1) ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) ;;; Keyword tests (deftest replace.allow-other-keys.1 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t) "xyzdefg") (deftest replace.allow-other-keys.2 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys nil) "xyzdefg") (deftest replace.allow-other-keys.3 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :bad t) "xyzdefg") (deftest replace.allow-other-keys.4 (replace (copy-seq "abcdefg") "xyz" :bad t :allow-other-keys t) "xyzdefg") (deftest replace.allow-other-keys.5 (replace (copy-seq "abcdefg") "xyz" :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 nil) "xyzdefg") (deftest replace.allow-other-keys.6 (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :start1 1) "axyzefg") (deftest replace.keywords.7 (replace (copy-seq "abcdefg") "xyz" :start1 0 :start2 0 :end1 3 :end2 3 :start1 1 :start2 1 :end1 2 :end1 2) "xyzdefg") ;;; Error cases (deftest replace.error.1 (classify-error (replace)) program-error) (deftest replace.error.2 (classify-error (replace nil)) program-error) (deftest replace.error.3 (classify-error (replace nil nil :start)) program-error) (deftest replace.error.4 (classify-error (replace nil nil 'bad t)) program-error) (deftest replace.error.5 (classify-error (replace nil nil :allow-other-keys nil 'bad t)) program-error) (deftest replace.error.6 (classify-error (replace nil nil 1 2)) program-error) gcl-2.6.14/ansi-tests/read-sequence.lsp0000644000175000017500000002205314360276512016330 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 19 06:55:04 2004 ;;;; Contains: Tests of READ-SEQUENCE (in-package :cl-test) ;;; Read into a string (defmacro def-read-sequence-test (name init args input &rest expected) `(deftest ,name (let ((s ,init)) (with-input-from-string (is ,input) (values (read-sequence s is ,@args) s))) ,@expected)) (def-read-sequence-test read-sequence.string.1 (copy-seq " ") () "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.2 (copy-seq " ") () "abc" 3 "abc ") (def-read-sequence-test read-sequence.string.3 (copy-seq " ") (:start 1) "abcdefghijk" 5 " abcd") (def-read-sequence-test read-sequence.string.4 (copy-seq " ") (:end 3) "abcdefghijk" 3 "abc ") (def-read-sequence-test read-sequence.string.5 (copy-seq " ") (:start 1 :end 4) "abcdefghijk" 4 " abc ") (def-read-sequence-test read-sequence.string.6 (copy-seq " ") (:start 0 :end 0) "abcdefghijk" 0 " ") (def-read-sequence-test read-sequence.string.7 (copy-seq " ") (:end nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.8 (copy-seq " ") (:allow-other-keys nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.9 (copy-seq " ") (:allow-other-keys t :foo 'bar) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.10 (copy-seq " ") (:foo 'bar :allow-other-keys 'x) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.11 (copy-seq " ") (:foo 'bar :allow-other-keys 'x :allow-other-keys nil) "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.string.12 (copy-seq " ") (:end 5 :end 3 :start 0 :start 1) "abcdefghijk" 5 "abcde") ;;; Read into a base string (def-read-sequence-test read-sequence.base-string.1 (make-array 5 :element-type 'base-char) () "abcdefghijk" 5 "abcde") (def-read-sequence-test read-sequence.base-string.2 (make-array 5 :element-type 'base-char :initial-element #\Space) () "abc" 3 "abc ") (def-read-sequence-test read-sequence.base-string.3 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 1) "abcdefghijk" 5 " abcd") (def-read-sequence-test read-sequence.base-string.4 (make-array 5 :element-type 'base-char :initial-element #\Space) (:end 3) "abcdefghijk" 3 "abc ") (def-read-sequence-test read-sequence.base-string.5 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 1 :end 4) "abcdefghijk" 4 " abc ") (def-read-sequence-test read-sequence.base-string.6 (make-array 5 :element-type 'base-char :initial-element #\Space) (:start 0 :end 0) "abcdefghijk" 0 " ") (def-read-sequence-test read-sequence.base-string.7 (make-array 5 :element-type 'base-char :initial-element #\Space) (:end nil) "abcdefghijk" 5 "abcde") ;;; Read into a list (def-read-sequence-test read-sequence.list.1 (make-list 5) () "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.list.2 (make-list 5) () "abc" 3 (#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.list.3 (make-list 5) (:start 1) "abcdefghijk" 5 (nil #\a #\b #\c #\d)) (def-read-sequence-test read-sequence.list.4 (make-list 5) (:end 3) "abcdefghijk" 3 (#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.list.5 (make-list 5) (:end 4 :start 1) "abcdefghijk" 4 (nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.list.6 (make-list 5) (:start 0 :end 0) "abcdefghijk" 0 (nil nil nil nil nil)) (def-read-sequence-test read-sequence.list.7 (make-list 5) (:end nil) "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) ;;; Read into a vector (def-read-sequence-test read-sequence.vector.1 (vector nil nil nil nil nil) () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.vector.2 (vector nil nil nil nil nil) () "abc" 3 #(#\a #\b #\c nil nil)) (def-read-sequence-test read-sequence.vector.3 (vector nil nil nil nil nil) (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) (def-read-sequence-test read-sequence.vector.4 (vector nil nil nil nil nil) (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.vector.5 (vector nil nil nil nil nil) (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.vector.6 (vector nil nil nil nil nil) (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.vector.7 (vector nil nil nil nil nil) (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) ;;; Read into a vector with a fill pointer (def-read-sequence-test read-sequence.fill-vector.1 (make-array 10 :initial-element nil :fill-pointer 5) () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) (def-read-sequence-test read-sequence.fill-vector.2 (make-array 10 :initial-element nil :fill-pointer 5) () "ab" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.3 (make-array 10 :initial-element nil :fill-pointer 5) () "" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.4 (make-array 10 :initial-element nil :fill-pointer 5) (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) (def-read-sequence-test read-sequence.fill-vector.5 (make-array 10 :initial-element nil :fill-pointer 5) (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) (def-read-sequence-test read-sequence.fill-vector.6 (make-array 10 :initial-element nil :fill-pointer 5) (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.7 (make-array 10 :initial-element nil :fill-pointer 5) (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) (def-read-sequence-test read-sequence.fill-vector.8 (make-array 10 :initial-element nil :fill-pointer 5) (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) ;;; Nil vectors (deftest read-sequence.nil-vector.1 :notes (:nil-vectors-are-strings) (let ((s (make-array 0 :element-type nil))) (with-input-from-string (is "abcde") (values (read-sequence s is) s))) 0 "") ;;; Read into a bit vector (defmacro def-read-sequence-bv-test (name init args &rest expected) `(deftest ,name ;; Create output file (progn (let (os) (unwind-protect (progn (setq os (open "temp.dat" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede)) (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0) do (write-byte i os))) (when os (close os)))) (let (is (bv (copy-seq ,init))) (unwind-protect (progn (setq is (open "temp.dat" :direction :input :element-type '(unsigned-byte 8))) (values (read-sequence bv is ,@args) bv)) (when is (close is))))) ,@expected)) (def-read-sequence-bv-test read-sequence.bv.1 #*00000000000000 () 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.2 #*00000000000000 (:start 0) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.3 #*00000000000000 (:end 14) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.4 #*00000000000000 (:end nil) 14 #*01100110101110) (def-read-sequence-bv-test read-sequence.bv.5 #*00000000000000 (:start 2) 14 #*00011001101011) (def-read-sequence-bv-test read-sequence.bv.6 #*00000000000000 (:start 2 :end 13) 13 #*00011001101010) (def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6) 6 #*01100100000000) ;;; Error cases (deftest read-sequence.error.1 (signals-error (read-sequence) program-error) t) (deftest read-sequence.error.2 (signals-error (read-sequence (make-string 10)) program-error) t) (deftest read-sequence.error.3 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :start) program-error) t) (deftest read-sequence.error.4 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :foo 1) program-error) t) (deftest read-sequence.error.5 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") :allow-other-keys nil :bar 2) program-error) t) (deftest read-sequence.error.6 (check-type-error #'(lambda (x) (read-sequence x (make-string-input-stream "abc"))) #'sequencep) nil) (deftest read-sequence.error.7 (signals-error (read-sequence (cons 'a 'b) (make-string-input-stream "abc")) type-error) t) ;;; This test appears to cause Allegro CL to crash (deftest read-sequence.error.8 (signals-type-error x -1 (read-sequence (make-string 3) (make-string-input-stream "abc") :start x)) t) (deftest read-sequence.error.9 (check-type-error #'(lambda (s) (read-sequence (make-string 3) (make-string-input-stream "abc") :start s)) (typef 'unsigned-byte)) nil) (deftest read-sequence.error.10 (signals-type-error x -1 (read-sequence (make-string 3) (make-string-input-stream "abc") :end x)) t) (deftest read-sequence.error.11 (check-type-error #'(lambda (e) (read-sequence (make-string 3) (make-string-input-stream "abc") :end e)) (typef '(or unsigned-byte null))) nil) gcl-2.6.14/ansi-tests/not-and-null.lsp0000644000175000017500000000167314360276512016124 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:38:33 2002 ;;;; Contains: Tests of NOT and NULL (in-package :cl-test) (deftest null.1 (null nil) t) (deftest null.2 (null t) nil) (deftest null.3 (some #'(lambda (x) (and x (null x))) *universe*) nil) (deftest null.4 (not (some #'null `(1 a 1.2 "a" #\w (a) ,*terminal-io* #'car (make-array '(10))))) t) (deftest null.error.1 (classify-error (null)) program-error) (deftest null.error.2 (classify-error (null nil nil)) program-error) (deftest not.1 (not nil) t) (deftest not.2 (not t) nil) (deftest not.3 (some #'(lambda (x) (and x (not x))) *universe*) nil) (deftest not.4 (not (some #'not `(1 a 1.2 "a" #\w (a) ,*terminal-io* #'car (make-array '(10))))) t) (deftest not.error.1 (classify-error (not)) program-error) (deftest not.error.2 (classify-error (not nil nil)) program-error) gcl-2.6.14/ansi-tests/loop3.lsp0000644000175000017500000000527314360276512014650 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 27 08:36:36 2002 ;;;; Contains: Tests of FOR-ON-AS-LIST iteration control in LOOP (in-package :cl-test) (deftest loop.3.1 (loop for x on '(1 2 3) sum (car x)) 6) (deftest loop.3.2 (loop for x on '(1 2 3 4) do (when (evenp (car x)) (return x))) (2 3 4)) (deftest loop.3.3 (loop for x on '(a b c . d) collect (car x)) (a b c)) (deftest loop.3.4 (let ((x nil)) (loop for e on '(a b c d) do (push (car e) x)) x) (d c b a)) (deftest loop.3.5 (loop for e on '(a b c d e f) by #'cddr collect (car e)) (a c e)) (deftest loop.3.6 (loop for e on '(a b c d e f g) by #'cddr collect (car e)) (a c e g)) (deftest loop.3.7 (loop for e on '(a b c d e f) by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) collect (car e)) (a a a a a a)) (deftest loop.3.8 (loop for ((x . y)) on '((a . b) (c . d) (e . f)) collect (list x y)) ((a b) (c d) (e f))) (deftest loop.3.9 (loop for ((x nil y)) on '((a b c) (d e f) (g h i)) collect (list x y)) ((a c) (d f) (g i))) (deftest loop.3.10 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.11 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.12 (loop for ((x y)) of-type ((fixnum fixnum)) on '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.13 (loop for ((x . y)) of-type ((fixnum . fixnum)) on '((1 . 2) (3 . 4) (5 . 6)) collect (+ x y)) (3 7 11)) (deftest loop.3.14 (classify-error (loop for x on '(a b c) for x on '(d e f) collect x)) program-error) (deftest loop.3.15 (classify-error (loop for (x . x) on '((a b) (c d)) collect x)) program-error) (deftest loop.3.16 (loop for nil on nil do (return t)) nil) (deftest loop.3.17 (let ((x '(a b c))) (values x (loop for x on '(d e f) collect x) x)) (a b c) ((d e f) (e f) (f)) (a b c)) (deftest loop.3.18 (loop for (x) of-type ((integer 0 10)) on '(2 4 6 7) sum x) 19) ;;; Tests of the 'AS' form (deftest loop.3.19 (loop as x on '(1 2 3) sum (car x)) 6) (deftest loop.3.20 (loop as x on '(a b c) as y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.21 (loop as x on '(a b c) for y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.22 (loop for x on '(a b c) as y on '(1 2 3) collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.23 (let (a b (i 0)) (values (loop for e on (progn (setf a (incf i)) '(a b c d e f g)) by (progn (setf b (incf i)) #'cddr) collect (car e)) a b i)) (a c e g) 1 2 2) gcl-2.6.14/ansi-tests/char-aux.lsp0000644000175000017500000001773614360276512015333 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 20:15:55 2002 ;;;; Contains: Auxiliary functions for character tests (in-package :cl-test) (defun is-ordered-by (seq fn) (let ((n (length seq))) (loop for i from 0 below (1- n) for e = (elt seq i) always (loop for j from (1+ i) below n always (funcall fn e (elt seq j)))))) (defun is-antisymmetrically-ordered-by (seq fn) (and (is-ordered-by seq fn) (is-ordered-by (reverse seq) (complement fn)))) (defun is-case-insensitive (fn) (loop for c across +code-chars+ for c1 = (char-upcase c) for c2 = (if (eql c c1) (char-downcase c) c1) always (loop for d across +code-chars+ for d1 = (char-upcase d) for d2 = (if (eql d d1) (char-downcase d) d1) always (equiv (funcall fn c d) (funcall fn c2 d) (funcall fn c d2) (funcall fn c2 d2))))) (defun equiv (&rest args) (declare (dynamic-extent args)) (cond ((null args) t) ((car args) (loop for e in (cdr args) always e)) (t (loop for e in (cdr args) never e)))) ;;; From character.lsp (defun char-type-error-check (fn) (loop for x in *universe* always (or (characterp x) (eqt (catch-type-error (funcall fn x)) 'type-error)))) (defun standard-char.5.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (not (and (typep c 'standard-char) (not (standard-char-p c))))))) (defun extended-char.3.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (not (and (typep c 'extended-char) (typep c 'base-char)))))) (defun character.1.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (or (null c) (let ((s (string c))) (and (eqlt (character c) c) (eqlt (character s) c) (eqlt (character (make-symbol s)) c))))))) (defun character.2.body () (loop for x in *universe* when (not (or (characterp x) (and (stringp x) (eqlt (length x) 1)) (and (symbolp x) (eqlt (length (symbol-name x)) 1)) (let ((c (catch-type-error (character x)))) (or (eqlt c 'type-error) (let ((s (catch-type-error (string x)))) (and (stringp s) (eqlt (char s 0) c))))))) do (return x))) (defun characterp.2.body () (loop for i from 0 below (min 65536 char-code-limit) always (let ((c (code-char i))) (or (null c) (characterp c))))) (defun characterp.3.body () (loop for x in *universe* always (let ((p (characterp x)) (q (typep x 'character))) (if p (notnot q) (not q))))) (defun alphanumericp.4.body () (loop for x in *universe* always (or (not (characterp x)) (if (or (digit-char-p x) (alpha-char-p x)) (alphanumericp x) ;; The hyperspec has an example that claims alphanumeric == ;; digit-char-p or alpha-char-p, but the text seems to suggest ;; that there can be numeric characters for which digit-char-p ;; returns NIL. Therefore, I've weakened the next line ;; (not (alphanumericp x)) t )))) (defun alphanumericp.5.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (if (or (digit-char-p x) (alpha-char-p x)) (alphanumericp x) ;; The hyperspec has an example that claims alphanumeric == ;; digit-char-p or alpha-char-p, but the text seems to suggest ;; that there can be numeric characters for which digit-char-p ;; returns NIL. Therefore, I've weakened the next line ;; (not (alphanumericp x)) t )))) (defun digit-char.1.body () (loop for r from 2 to 36 always (loop for i from 0 to 36 always (let ((c (digit-char i r))) (if (>= i r) (null c) (eqlt c (char +extended-digit-chars+ i))))))) (defun digit-char-p.1.body () (loop for x in *universe* always (not (and (characterp x) (not (alphanumericp x)) (digit-char-p x))))) (defun digit-char-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (not (and (not (alphanumericp x)) (digit-char-p x)))))) (defun digit-char-p.3.body () (loop for r from 2 to 35 always (loop for i from r to 35 for c = (char +extended-digit-chars+ i) never (or (digit-char-p c r) (digit-char-p (char-downcase c) r))))) (defun digit-char-p.4.body () (loop for r from 2 to 35 always (loop for i from 0 below r for c = (char +extended-digit-chars+ i) always (and (eqlt (digit-char-p c r) i) (eqlt (digit-char-p (char-downcase c) r) i))))) (defun standard-char-p.2.body () (loop for x in *universe* always (or (not (characterp x)) (find x +standard-chars+) (not (standard-char-p x))))) (defun standard-char-p.2a.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (find x +standard-chars+) (not (standard-char-p x))))) (defun char-upcase.1.body () (loop for x in *universe* always (or (not (characterp x)) (let ((u (char-upcase x))) (and (or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u))))))) (defun char-upcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (let ((u (char-upcase x))) (and (or (lower-case-p x) (eqlt u x)) (eqlt u (char-upcase u))))))) (defun char-downcase.1.body () (loop for x in *universe* always (or (not (characterp x)) (let ((u (char-downcase x))) (and (or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u))))))) (defun char-downcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not x) (let ((u (char-downcase x))) (and (or (upper-case-p x) (eqlt u x)) (eqlt u (char-downcase u))))))) (defun both-case-p.1.body () (loop for x in *universe* always (or (not (characterp x)) (if (both-case-p x) (and (graphic-char-p x) (or (upper-case-p x) (lower-case-p x))) (not (or (upper-case-p x) (lower-case-p x))))))) (defun both-case-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) for x = (code-char i) always (or (not (characterp x)) (if (both-case-p x) (and (graphic-char-p x) (or (upper-case-p x) (lower-case-p x))) (not (or (upper-case-p x) (lower-case-p x))))))) (defun char-code.2.body () (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) always (or (not c) (eqlt (char-code c) i)))) (defun char-int.2.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (let ((c->i (make-hash-table :test #'equal)) (i->c (make-hash-table :test #'eql))) (flet ((%insert (c) (or (not (characterp c)) (let* ((i (char-int c)) (j (gethash c c->i)) (d (gethash i i->c))) (and (or (null j) (eqlt j i)) (or (null d) (char= c d)) (progn (setf (gethash c c->i) i) (setf (gethash i i->c) c) t)))))) (and (loop for i from 0 below char-code-limit always (%insert (code-char i))) (every #'%insert +standard-chars+) (every #'%insert *universe*) t)))) (defun char-name.1.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (flet ((%check (c) (or (not (characterp c)) (let ((name (char-name c))) (or (null name) (and (stringp name) (eqlt c (name-char name)))))))) (and (loop for i from 0 below char-code-limit always (%check (code-char i))) (every #'%check +standard-chars+) (every #'%check *universe*) t))) (defun name-char.1.body () (declare (optimize (safety 3))) (loop for x in *universe* for s = (catch-type-error (string x)) always (or (eqlt s 'type-error) (let ((c (name-char x))) (or (not c) (characterp c) (let ((name (char-name c))) (declare (type (or null string) name)) (and name (string-equal name s)))))))) gcl-2.6.14/ansi-tests/two-way-stream-output-stream.lsp0000644000175000017500000000141014360276512021330 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:25:59 2004 ;;;; Contains: Tests off TWO-WAY-STREAM-OUTPUT-STREAM (in-package :cl-test) (deftest two-way-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-output-stream s)) (list os))) t) (deftest two-way-stream-output-stream.error.1 (signals-error (two-way-stream-output-stream) program-error) t) (deftest two-way-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (two-way-stream-output-stream s nil)) program-error) t) gcl-2.6.14/ansi-tests/cl-symbols.lsp0000644000175000017500000025622114360276512015701 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Mar 15 13:19:57 1998 ;;;; Contains: Test presence of symbols in the CL package, ;;;; and symbol-related functions (in-package :cl-test) (declaim (optimize (safety 3))) ;;; Test for the presence of every darned symbol ;;; the standard says should be in the CL package. ;;; Also, test that they have no prohibited plist indicators (section 11.1.2.1.1) (deftest symbol-&allow-other-keys (test-if-not-in-cl-package "&allow-other-keys") nil) (deftest symbol-&aux (test-if-not-in-cl-package "&aux") nil) (deftest symbol-&body (test-if-not-in-cl-package "&body") nil) (deftest symbol-&environment (test-if-not-in-cl-package "&environment") nil) (deftest symbol-&key (test-if-not-in-cl-package "&key") nil) (deftest symbol-&optional (test-if-not-in-cl-package "&optional") nil) (deftest symbol-&rest (test-if-not-in-cl-package "&rest") nil) (deftest symbol-&whole (test-if-not-in-cl-package "&whole") nil) (deftest symbol-* (test-if-not-in-cl-package "*") nil) (deftest symbol-** (test-if-not-in-cl-package "**") nil) (deftest symbol-*** (test-if-not-in-cl-package "***") nil) (deftest symbol-*break-on-signals* (test-if-not-in-cl-package "*break-on-signals*") nil) (deftest symbol-*compile-file-pathname* (test-if-not-in-cl-package "*compile-file-pathname*") nil) (deftest symbol-*compile-file-truename* (test-if-not-in-cl-package "*compile-file-truename*") nil) (deftest symbol-*compile-print* (test-if-not-in-cl-package "*compile-print*") nil) (deftest symbol-*compile-verbose* (test-if-not-in-cl-package "*compile-verbose*") nil) (deftest symbol-*debug-io* (test-if-not-in-cl-package "*debug-io*") nil) (deftest symbol-*debugger-hook* (test-if-not-in-cl-package "*debugger-hook*") nil) (deftest symbol-*default-pathname-defaults* (test-if-not-in-cl-package "*default-pathname-defaults*") nil) (deftest symbol-*error-output* (test-if-not-in-cl-package "*error-output*") nil) (deftest symbol-*features* (test-if-not-in-cl-package "*features*") nil) (deftest symbol-*gensym-counter* (test-if-not-in-cl-package "*gensym-counter*") nil) (deftest symbol-*load-pathname* (test-if-not-in-cl-package "*load-pathname*") nil) (deftest symbol-*load-print* (test-if-not-in-cl-package "*load-print*") nil) (deftest symbol-*load-truename* (test-if-not-in-cl-package "*load-truename*") nil) (deftest symbol-*load-verbose* (test-if-not-in-cl-package "*load-verbose*") nil) (deftest symbol-*macroexpand-hook* (test-if-not-in-cl-package "*macroexpand-hook*") nil) (deftest symbol-*modules* (test-if-not-in-cl-package "*modules*") nil) (deftest symbol-*package* (test-if-not-in-cl-package "*package*") nil) (deftest symbol-*print-array* (test-if-not-in-cl-package "*print-array*") nil) (deftest symbol-*print-base* (test-if-not-in-cl-package "*print-base*") nil) (deftest symbol-*print-case* (test-if-not-in-cl-package "*print-case*") nil) (deftest symbol-*print-circle* (test-if-not-in-cl-package "*print-circle*") nil) (deftest symbol-*print-escape* (test-if-not-in-cl-package "*print-escape*") nil) (deftest symbol-*print-gensym* (test-if-not-in-cl-package "*print-gensym*") nil) (deftest symbol-*print-length* (test-if-not-in-cl-package "*print-length*") nil) (deftest symbol-*print-level* (test-if-not-in-cl-package "*print-level*") nil) (deftest symbol-*print-lines* (test-if-not-in-cl-package "*print-lines*") nil) (deftest symbol-*print-miser-width* (test-if-not-in-cl-package "*print-miser-width*") nil) (deftest symbol-*print-pprint-dispatch* (test-if-not-in-cl-package "*print-pprint-dispatch*") nil) (deftest symbol-*print-pretty* (test-if-not-in-cl-package "*print-pretty*") nil) (deftest symbol-*print-radix* (test-if-not-in-cl-package "*print-radix*") nil) (deftest symbol-*print-readably* (test-if-not-in-cl-package "*print-readably*") nil) (deftest symbol-*print-right-margin* (test-if-not-in-cl-package "*print-right-margin*") nil) (deftest symbol-*query-io* (test-if-not-in-cl-package "*query-io*") nil) (deftest symbol-*random-state* (test-if-not-in-cl-package "*random-state*") nil) (deftest symbol-*read-base* (test-if-not-in-cl-package "*read-base*") nil) (deftest symbol-*read-default-float-format* (test-if-not-in-cl-package "*read-default-float-format*") nil) (deftest symbol-*read-eval* (test-if-not-in-cl-package "*read-eval*") nil) (deftest symbol-*read-suppress* (test-if-not-in-cl-package "*read-suppress*") nil) (deftest symbol-*readtable* (test-if-not-in-cl-package "*readtable*") nil) (deftest symbol-*standard-input* (test-if-not-in-cl-package "*standard-input*") nil) (deftest symbol-*standard-output* (test-if-not-in-cl-package "*standard-output*") nil) (deftest symbol-*terminal-io* (test-if-not-in-cl-package "*terminal-io*") nil) (deftest symbol-*trace-output* (test-if-not-in-cl-package "*trace-output*") nil) (deftest symbol-+ (test-if-not-in-cl-package "+") nil) (deftest symbol-++ (test-if-not-in-cl-package "++") nil) (deftest symbol-+++ (test-if-not-in-cl-package "+++") nil) (deftest symbol-- (test-if-not-in-cl-package "-") nil) (deftest symbol-/ (test-if-not-in-cl-package "/") nil) (deftest symbol-// (test-if-not-in-cl-package "//") nil) (deftest symbol-/// (test-if-not-in-cl-package "///") nil) (deftest symbol-/= (test-if-not-in-cl-package "/=") nil) (deftest symbol-1+ (test-if-not-in-cl-package "1+") nil) (deftest symbol-1- (test-if-not-in-cl-package "1-") nil) (deftest symbol-< (test-if-not-in-cl-package "<") nil) (deftest symbol-<= (test-if-not-in-cl-package "<=") nil) (deftest symbol-= (test-if-not-in-cl-package "=") nil) (deftest symbol-> (test-if-not-in-cl-package ">") nil) (deftest symbol->= (test-if-not-in-cl-package ">=") nil) (deftest symbol-abort (test-if-not-in-cl-package "abort") nil) (deftest symbol-abs (test-if-not-in-cl-package "abs") nil) (deftest symbol-acons (test-if-not-in-cl-package "acons") nil) (deftest symbol-acos (test-if-not-in-cl-package "acos") nil) (deftest symbol-acosh (test-if-not-in-cl-package "acosh") nil) (deftest symbol-add-method (test-if-not-in-cl-package "add-method") nil) (deftest symbol-adjoin (test-if-not-in-cl-package "adjoin") nil) (deftest symbol-adjust-array (test-if-not-in-cl-package "adjust-array") nil) (deftest symbol-adjustable-array-p (test-if-not-in-cl-package "adjustable-array-p") nil) (deftest symbol-allocate-instance (test-if-not-in-cl-package "allocate-instance") nil) (deftest symbol-alpha-char-p (test-if-not-in-cl-package "alpha-char-p") nil) (deftest symbol-alphanumericp (test-if-not-in-cl-package "alphanumericp") nil) (deftest symbol-and (test-if-not-in-cl-package "and") nil) (deftest symbol-append (test-if-not-in-cl-package "append") nil) (deftest symbol-apply (test-if-not-in-cl-package "apply") nil) (deftest symbol-apropos (test-if-not-in-cl-package "apropos") nil) (deftest symbol-apropos-list (test-if-not-in-cl-package "apropos-list") nil) (deftest symbol-aref (test-if-not-in-cl-package "aref") nil) (deftest symbol-arithmetic-error (test-if-not-in-cl-package "arithmetic-error") nil) (deftest symbol-arithmetic-error-operands (test-if-not-in-cl-package "arithmetic-error-operands") nil) (deftest symbol-arithmetic-error-operation (test-if-not-in-cl-package "arithmetic-error-operation") nil) (deftest symbol-array (test-if-not-in-cl-package "array") nil) (deftest symbol-array-dimension (test-if-not-in-cl-package "array-dimension") nil) (deftest symbol-array-dimension-limit (test-if-not-in-cl-package "array-dimension-limit") nil) (deftest symbol-array-dimensions (test-if-not-in-cl-package "array-dimensions") nil) (deftest symbol-array-displacement (test-if-not-in-cl-package "array-displacement") nil) (deftest symbol-array-element-type (test-if-not-in-cl-package "array-element-type") nil) (deftest symbol-array-has-fill-pointer-p (test-if-not-in-cl-package "array-has-fill-pointer-p") nil) (deftest symbol-array-in-bounds-p (test-if-not-in-cl-package "array-in-bounds-p") nil) (deftest symbol-array-rank (test-if-not-in-cl-package "array-rank") nil) (deftest symbol-array-rank-limit (test-if-not-in-cl-package "array-rank-limit") nil) (deftest symbol-array-row-major-index (test-if-not-in-cl-package "array-row-major-index") nil) (deftest symbol-array-total-size (test-if-not-in-cl-package "array-total-size") nil) (deftest symbol-array-total-size-limit (test-if-not-in-cl-package "array-total-size-limit") nil) (deftest symbol-arrayp (test-if-not-in-cl-package "arrayp") nil) (deftest symbol-ash (test-if-not-in-cl-package "ash") nil) (deftest symbol-asin (test-if-not-in-cl-package "asin") nil) (deftest symbol-asinh (test-if-not-in-cl-package "asinh") nil) (deftest symbol-assert (test-if-not-in-cl-package "assert") nil) (deftest symbol-assoc (test-if-not-in-cl-package "assoc") nil) (deftest symbol-assoc-if (test-if-not-in-cl-package "assoc-if") nil) (deftest symbol-assoc-if-not (test-if-not-in-cl-package "assoc-if-not") nil) (deftest symbol-atan (test-if-not-in-cl-package "atan") nil) (deftest symbol-atanh (test-if-not-in-cl-package "atanh") nil) (deftest symbol-atom (test-if-not-in-cl-package "atom") nil) (deftest symbol-base-char (test-if-not-in-cl-package "base-char") nil) (deftest symbol-base-string (test-if-not-in-cl-package "base-string") nil) (deftest symbol-bignum (test-if-not-in-cl-package "bignum") nil) (deftest symbol-bit (test-if-not-in-cl-package "bit") nil) (deftest symbol-bit-and (test-if-not-in-cl-package "bit-and") nil) (deftest symbol-bit-andc1 (test-if-not-in-cl-package "bit-andc1") nil) (deftest symbol-bit-andc2 (test-if-not-in-cl-package "bit-andc2") nil) (deftest symbol-bit-eqv (test-if-not-in-cl-package "bit-eqv") nil) (deftest symbol-bit-ior (test-if-not-in-cl-package "bit-ior") nil) (deftest symbol-bit-nand (test-if-not-in-cl-package "bit-nand") nil) (deftest symbol-bit-nor (test-if-not-in-cl-package "bit-nor") nil) (deftest symbol-bit-not (test-if-not-in-cl-package "bit-not") nil) (deftest symbol-bit-orc1 (test-if-not-in-cl-package "bit-orc1") nil) (deftest symbol-bit-orc2 (test-if-not-in-cl-package "bit-orc2") nil) (deftest symbol-bit-vector (test-if-not-in-cl-package "bit-vector") nil) (deftest symbol-bit-vector-p (test-if-not-in-cl-package "bit-vector-p") nil) (deftest symbol-bit-xor (test-if-not-in-cl-package "bit-xor") nil) (deftest symbol-block (test-if-not-in-cl-package "block") nil) (deftest symbol-boole (test-if-not-in-cl-package "boole") nil) (deftest symbol-boole-1 (test-if-not-in-cl-package "boole-1") nil) (deftest symbol-boole-2 (test-if-not-in-cl-package "boole-2") nil) (deftest symbol-boole-and (test-if-not-in-cl-package "boole-and") nil) (deftest symbol-boole-andc1 (test-if-not-in-cl-package "boole-andc1") nil) (deftest symbol-boole-andc2 (test-if-not-in-cl-package "boole-andc2") nil) (deftest symbol-boole-c1 (test-if-not-in-cl-package "boole-c1") nil) (deftest symbol-boole-c2 (test-if-not-in-cl-package "boole-c2") nil) (deftest symbol-boole-clr (test-if-not-in-cl-package "boole-clr") nil) (deftest symbol-boole-eqv (test-if-not-in-cl-package "boole-eqv") nil) (deftest symbol-boole-ior (test-if-not-in-cl-package "boole-ior") nil) (deftest symbol-boole-nand (test-if-not-in-cl-package "boole-nand") nil) (deftest symbol-boole-nor (test-if-not-in-cl-package "boole-nor") nil) (deftest symbol-boole-orc1 (test-if-not-in-cl-package "boole-orc1") nil) (deftest symbol-boole-orc2 (test-if-not-in-cl-package "boole-orc2") nil) (deftest symbol-boole-set (test-if-not-in-cl-package "boole-set") nil) (deftest symbol-boole-xor (test-if-not-in-cl-package "boole-xor") nil) (deftest symbol-boolean (test-if-not-in-cl-package "boolean") nil) (deftest symbol-both-case-p (test-if-not-in-cl-package "both-case-p") nil) (deftest symbol-boundp (test-if-not-in-cl-package "boundp") nil) (deftest symbol-break (test-if-not-in-cl-package "break") nil) (deftest symbol-broadcast-stream (test-if-not-in-cl-package "broadcast-stream") nil) (deftest symbol-broadcast-stream-streams (test-if-not-in-cl-package "broadcast-stream-streams") nil) (deftest symbol-built-in-class (test-if-not-in-cl-package "built-in-class") nil) (deftest symbol-butlast (test-if-not-in-cl-package "butlast") nil) (deftest symbol-byte (test-if-not-in-cl-package "byte") nil) (deftest symbol-byte-position (test-if-not-in-cl-package "byte-position") nil) (deftest symbol-byte-size (test-if-not-in-cl-package "byte-size") nil) (deftest symbol-caaaar (test-if-not-in-cl-package "caaaar") nil) (deftest symbol-caaadr (test-if-not-in-cl-package "caaadr") nil) (deftest symbol-caaar (test-if-not-in-cl-package "caaar") nil) (deftest symbol-caadar (test-if-not-in-cl-package "caadar") nil) (deftest symbol-caaddr (test-if-not-in-cl-package "caaddr") nil) (deftest symbol-caadr (test-if-not-in-cl-package "caadr") nil) (deftest symbol-caar (test-if-not-in-cl-package "caar") nil) (deftest symbol-cadaar (test-if-not-in-cl-package "cadaar") nil) (deftest symbol-cadadr (test-if-not-in-cl-package "cadadr") nil) (deftest symbol-cadar (test-if-not-in-cl-package "cadar") nil) (deftest symbol-caddar (test-if-not-in-cl-package "caddar") nil) (deftest symbol-cadddr (test-if-not-in-cl-package "cadddr") nil) (deftest symbol-caddr (test-if-not-in-cl-package "caddr") nil) (deftest symbol-cadr (test-if-not-in-cl-package "cadr") nil) (deftest symbol-call-arguments-limit (test-if-not-in-cl-package "call-arguments-limit") nil) (deftest symbol-call-method (test-if-not-in-cl-package "call-method") nil) (deftest symbol-call-next-method (test-if-not-in-cl-package "call-next-method") nil) (deftest symbol-car (test-if-not-in-cl-package "car") nil) (deftest symbol-case (test-if-not-in-cl-package "case") nil) (deftest symbol-catch (test-if-not-in-cl-package "catch") nil) (deftest symbol-ccase (test-if-not-in-cl-package "ccase") nil) (deftest symbol-cdaaar (test-if-not-in-cl-package "cdaaar") nil) (deftest symbol-cdaadr (test-if-not-in-cl-package "cdaadr") nil) (deftest symbol-cdaar (test-if-not-in-cl-package "cdaar") nil) (deftest symbol-cdadar (test-if-not-in-cl-package "cdadar") nil) (deftest symbol-cdaddr (test-if-not-in-cl-package "cdaddr") nil) (deftest symbol-cdadr (test-if-not-in-cl-package "cdadr") nil) (deftest symbol-cdar (test-if-not-in-cl-package "cdar") nil) (deftest symbol-cddaar (test-if-not-in-cl-package "cddaar") nil) (deftest symbol-cddadr (test-if-not-in-cl-package "cddadr") nil) (deftest symbol-cddar (test-if-not-in-cl-package "cddar") nil) (deftest symbol-cdddar (test-if-not-in-cl-package "cdddar") nil) (deftest symbol-cddddr (test-if-not-in-cl-package "cddddr") nil) (deftest symbol-cdddr (test-if-not-in-cl-package "cdddr") nil) (deftest symbol-cddr (test-if-not-in-cl-package "cddr") nil) (deftest symbol-cdr (test-if-not-in-cl-package "cdr") nil) (deftest symbol-ceiling (test-if-not-in-cl-package "ceiling") nil) (deftest symbol-cell-error (test-if-not-in-cl-package "cell-error") nil) (deftest symbol-cell-error-name (test-if-not-in-cl-package "cell-error-name") nil) (deftest symbol-cerror (test-if-not-in-cl-package "cerror") nil) (deftest symbol-change-class (test-if-not-in-cl-package "change-class") nil) (deftest symbol-char (test-if-not-in-cl-package "char") nil) (deftest symbol-char-code (test-if-not-in-cl-package "char-code") nil) (deftest symbol-char-code-limit (test-if-not-in-cl-package "char-code-limit") nil) (deftest symbol-char-downcase (test-if-not-in-cl-package "char-downcase") nil) (deftest symbol-char-equal (test-if-not-in-cl-package "char-equal") nil) (deftest symbol-char-greaterp (test-if-not-in-cl-package "char-greaterp") nil) (deftest symbol-char-int (test-if-not-in-cl-package "char-int") nil) (deftest symbol-char-lessp (test-if-not-in-cl-package "char-lessp") nil) (deftest symbol-char-name (test-if-not-in-cl-package "char-name") nil) (deftest symbol-char-not-equal (test-if-not-in-cl-package "char-not-equal") nil) (deftest symbol-char-not-greaterp (test-if-not-in-cl-package "char-not-greaterp") nil) (deftest symbol-char-not-lessp (test-if-not-in-cl-package "char-not-lessp") nil) (deftest symbol-char-upcase (test-if-not-in-cl-package "char-upcase") nil) (deftest symbol-char/= (test-if-not-in-cl-package "char/=") nil) (deftest symbol-char< (test-if-not-in-cl-package "char<") nil) (deftest symbol-char<= (test-if-not-in-cl-package "char<=") nil) (deftest symbol-char= (test-if-not-in-cl-package "char=") nil) (deftest symbol-char> (test-if-not-in-cl-package "char>") nil) (deftest symbol-char>= (test-if-not-in-cl-package "char>=") nil) (deftest symbol-character (test-if-not-in-cl-package "character") nil) (deftest symbol-characterp (test-if-not-in-cl-package "characterp") nil) (deftest symbol-check-type (test-if-not-in-cl-package "check-type") nil) (deftest symbol-cis (test-if-not-in-cl-package "cis") nil) (deftest symbol-class (test-if-not-in-cl-package "class") nil) (deftest symbol-class-name (test-if-not-in-cl-package "class-name") nil) (deftest symbol-class-of (test-if-not-in-cl-package "class-of") nil) (deftest symbol-clear-input (test-if-not-in-cl-package "clear-input") nil) (deftest symbol-clear-output (test-if-not-in-cl-package "clear-output") nil) (deftest symbol-close (test-if-not-in-cl-package "close") nil) (deftest symbol-clrhash (test-if-not-in-cl-package "clrhash") nil) (deftest symbol-code-char (test-if-not-in-cl-package "code-char") nil) (deftest symbol-coerce (test-if-not-in-cl-package "coerce") nil) (deftest symbol-compilation-speed (test-if-not-in-cl-package "compilation-speed") nil) (deftest symbol-compile (test-if-not-in-cl-package "compile") nil) (deftest symbol-compile-file (test-if-not-in-cl-package "compile-file") nil) (deftest symbol-compile-file-pathname (test-if-not-in-cl-package "compile-file-pathname") nil) (deftest symbol-compiled-function (test-if-not-in-cl-package "compiled-function") nil) (deftest symbol-compiled-function-p (test-if-not-in-cl-package "compiled-function-p") nil) (deftest symbol-compiler-macro (test-if-not-in-cl-package "compiler-macro") nil) (deftest symbol-compiler-macro-function (test-if-not-in-cl-package "compiler-macro-function") nil) (deftest symbol-complement (test-if-not-in-cl-package "complement") nil) (deftest symbol-complex (test-if-not-in-cl-package "complex") nil) (deftest symbol-complexp (test-if-not-in-cl-package "complexp") nil) (deftest symbol-compute-applicable-methods (test-if-not-in-cl-package "compute-applicable-methods") nil) (deftest symbol-compute-restarts (test-if-not-in-cl-package "compute-restarts") nil) (deftest symbol-concatenate (test-if-not-in-cl-package "concatenate") nil) (deftest symbol-concatenated-stream (test-if-not-in-cl-package "concatenated-stream") nil) (deftest symbol-concatenated-stream-streams (test-if-not-in-cl-package "concatenated-stream-streams") nil) (deftest symbol-cond (test-if-not-in-cl-package "cond") nil) (deftest symbol-condition (test-if-not-in-cl-package "condition") nil) (deftest symbol-conjugate (test-if-not-in-cl-package "conjugate") nil) (deftest symbol-cons (test-if-not-in-cl-package "cons") nil) (deftest symbol-consp (test-if-not-in-cl-package "consp") nil) (deftest symbol-constantly (test-if-not-in-cl-package "constantly") nil) (deftest symbol-constantp (test-if-not-in-cl-package "constantp") nil) (deftest symbol-continue (test-if-not-in-cl-package "continue") nil) (deftest symbol-control-error (test-if-not-in-cl-package "control-error") nil) (deftest symbol-copy-alist (test-if-not-in-cl-package "copy-alist") nil) (deftest symbol-copy-list (test-if-not-in-cl-package "copy-list") nil) (deftest symbol-copy-pprint-dispatch (test-if-not-in-cl-package "copy-pprint-dispatch") nil) (deftest symbol-copy-readtable (test-if-not-in-cl-package "copy-readtable") nil) (deftest symbol-copy-seq (test-if-not-in-cl-package "copy-seq") nil) (deftest symbol-copy-structure (test-if-not-in-cl-package "copy-structure") nil) (deftest symbol-copy-symbol (test-if-not-in-cl-package "copy-symbol") nil) (deftest symbol-copy-tree (test-if-not-in-cl-package "copy-tree") nil) (deftest symbol-cos (test-if-not-in-cl-package "cos") nil) (deftest symbol-cosh (test-if-not-in-cl-package "cosh") nil) (deftest symbol-count (test-if-not-in-cl-package "count") nil) (deftest symbol-count-if (test-if-not-in-cl-package "count-if") nil) (deftest symbol-count-if-not (test-if-not-in-cl-package "count-if-not") nil) (deftest symbol-ctypecase (test-if-not-in-cl-package "ctypecase") nil) (deftest symbol-debug (test-if-not-in-cl-package "debug") nil) (deftest symbol-decf (test-if-not-in-cl-package "decf") nil) (deftest symbol-declaim (test-if-not-in-cl-package "declaim") nil) (deftest symbol-declaration (test-if-not-in-cl-package "declaration") nil) (deftest symbol-declare (test-if-not-in-cl-package "declare") nil) (deftest symbol-decode-float (test-if-not-in-cl-package "decode-float") nil) (deftest symbol-decode-universal-time (test-if-not-in-cl-package "decode-universal-time") nil) (deftest symbol-defclass (test-if-not-in-cl-package "defclass") nil) (deftest symbol-defconstant (test-if-not-in-cl-package "defconstant") nil) (deftest symbol-defgeneric (test-if-not-in-cl-package "defgeneric") nil) (deftest symbol-define-compiler-macro (test-if-not-in-cl-package "define-compiler-macro") nil) (deftest symbol-define-condition (test-if-not-in-cl-package "define-condition") nil) (deftest symbol-define-method-combination (test-if-not-in-cl-package "define-method-combination") nil) (deftest symbol-define-modify-macro (test-if-not-in-cl-package "define-modify-macro") nil) (deftest symbol-define-setf-expander (test-if-not-in-cl-package "define-setf-expander") nil) (deftest symbol-define-symbol-macro (test-if-not-in-cl-package "define-symbol-macro") nil) (deftest symbol-defmacro (test-if-not-in-cl-package "defmacro") nil) (deftest symbol-defmethod (test-if-not-in-cl-package "defmethod") nil) (deftest symbol-defpackage (test-if-not-in-cl-package "defpackage") nil) (deftest symbol-defparameter (test-if-not-in-cl-package "defparameter") nil) (deftest symbol-defsetf (test-if-not-in-cl-package "defsetf") nil) (deftest symbol-defstruct (test-if-not-in-cl-package "defstruct") nil) (deftest symbol-deftype (test-if-not-in-cl-package "deftype") nil) (deftest symbol-defun (test-if-not-in-cl-package "defun") nil) (deftest symbol-defvar (test-if-not-in-cl-package "defvar") nil) (deftest symbol-delete (test-if-not-in-cl-package "delete") nil) (deftest symbol-delete-duplicates (test-if-not-in-cl-package "delete-duplicates") nil) (deftest symbol-delete-file (test-if-not-in-cl-package "delete-file") nil) (deftest symbol-delete-if (test-if-not-in-cl-package "delete-if") nil) (deftest symbol-delete-if-not (test-if-not-in-cl-package "delete-if-not") nil) (deftest symbol-delete-package (test-if-not-in-cl-package "delete-package") nil) (deftest symbol-denominator (test-if-not-in-cl-package "denominator") nil) (deftest symbol-deposit-field (test-if-not-in-cl-package "deposit-field") nil) (deftest symbol-describe (test-if-not-in-cl-package "describe") nil) (deftest symbol-describe-object (test-if-not-in-cl-package "describe-object") nil) (deftest symbol-destructuring-bind (test-if-not-in-cl-package "destructuring-bind") nil) (deftest symbol-digit-char (test-if-not-in-cl-package "digit-char") nil) (deftest symbol-digit-char-p (test-if-not-in-cl-package "digit-char-p") nil) (deftest symbol-directory (test-if-not-in-cl-package "directory") nil) (deftest symbol-directory-namestring (test-if-not-in-cl-package "directory-namestring") nil) (deftest symbol-disassemble (test-if-not-in-cl-package "disassemble") nil) (deftest symbol-division-by-zero (test-if-not-in-cl-package "division-by-zero") nil) (deftest symbol-do (test-if-not-in-cl-package "do") nil) (deftest symbol-do* (test-if-not-in-cl-package "do*") nil) (deftest symbol-do-all-symbols (test-if-not-in-cl-package "do-all-symbols") nil) (deftest symbol-do-external-symbols (test-if-not-in-cl-package "do-external-symbols") nil) (deftest symbol-do-symbols (test-if-not-in-cl-package "do-symbols") nil) (deftest symbol-documentation (test-if-not-in-cl-package "documentation") nil) (deftest symbol-dolist (test-if-not-in-cl-package "dolist") nil) (deftest symbol-dotimes (test-if-not-in-cl-package "dotimes") nil) (deftest symbol-double-float (test-if-not-in-cl-package "double-float") nil) (deftest symbol-double-float-epsilon (test-if-not-in-cl-package "double-float-epsilon") nil) (deftest symbol-double-float-negative-epsilon (test-if-not-in-cl-package "double-float-negative-epsilon") nil) (deftest symbol-dpb (test-if-not-in-cl-package "dpb") nil) (deftest symbol-dribble (test-if-not-in-cl-package "dribble") nil) (deftest symbol-dynamic-extent (test-if-not-in-cl-package "dynamic-extent") nil) (deftest symbol-ecase (test-if-not-in-cl-package "ecase") nil) (deftest symbol-echo-stream (test-if-not-in-cl-package "echo-stream") nil) (deftest symbol-echo-stream-input-stream (test-if-not-in-cl-package "echo-stream-input-stream") nil) (deftest symbol-echo-stream-output-stream (test-if-not-in-cl-package "echo-stream-output-stream") nil) (deftest symbol-ed (test-if-not-in-cl-package "ed") nil) (deftest symbol-eighth (test-if-not-in-cl-package "eighth") nil) (deftest symbol-elt (test-if-not-in-cl-package "elt") nil) (deftest symbol-encode-universal-time (test-if-not-in-cl-package "encode-universal-time") nil) (deftest symbol-end-of-file (test-if-not-in-cl-package "end-of-file") nil) (deftest symbol-endp (test-if-not-in-cl-package "endp") nil) (deftest symbol-enough-namestring (test-if-not-in-cl-package "enough-namestring") nil) (deftest symbol-ensure-directories-exist (test-if-not-in-cl-package "ensure-directories-exist") nil) (deftest symbol-ensure-generic-function (test-if-not-in-cl-package "ensure-generic-function") nil) (deftest symbol-eq (test-if-not-in-cl-package "eq") nil) (deftest symbol-eql (test-if-not-in-cl-package "eql") nil) (deftest symbol-equal (test-if-not-in-cl-package "equal") nil) (deftest symbol-equalp (test-if-not-in-cl-package "equalp") nil) (deftest symbol-error (test-if-not-in-cl-package "error") nil) (deftest symbol-etypecase (test-if-not-in-cl-package "etypecase") nil) (deftest symbol-eval (test-if-not-in-cl-package "eval") nil) (deftest symbol-eval-when (test-if-not-in-cl-package "eval-when") nil) (deftest symbol-evenp (test-if-not-in-cl-package "evenp") nil) (deftest symbol-every (test-if-not-in-cl-package "every") nil) (deftest symbol-exp (test-if-not-in-cl-package "exp") nil) (deftest symbol-export (test-if-not-in-cl-package "export") nil) (deftest symbol-expt (test-if-not-in-cl-package "expt") nil) (deftest symbol-extended-char (test-if-not-in-cl-package "extended-char") nil) (deftest symbol-fboundp (test-if-not-in-cl-package "fboundp") nil) (deftest symbol-fceiling (test-if-not-in-cl-package "fceiling") nil) (deftest symbol-fdefinition (test-if-not-in-cl-package "fdefinition") nil) (deftest symbol-ffloor (test-if-not-in-cl-package "ffloor") nil) (deftest symbol-fifth (test-if-not-in-cl-package "fifth") nil) (deftest symbol-file-author (test-if-not-in-cl-package "file-author") nil) (deftest symbol-file-error (test-if-not-in-cl-package "file-error") nil) (deftest symbol-file-error-pathname (test-if-not-in-cl-package "file-error-pathname") nil) (deftest symbol-file-length (test-if-not-in-cl-package "file-length") nil) (deftest symbol-file-namestring (test-if-not-in-cl-package "file-namestring") nil) (deftest symbol-file-position (test-if-not-in-cl-package "file-position") nil) (deftest symbol-file-stream (test-if-not-in-cl-package "file-stream") nil) (deftest symbol-file-string-length (test-if-not-in-cl-package "file-string-length") nil) (deftest symbol-file-write-date (test-if-not-in-cl-package "file-write-date") nil) (deftest symbol-fill (test-if-not-in-cl-package "fill") nil) (deftest symbol-fill-pointer (test-if-not-in-cl-package "fill-pointer") nil) (deftest symbol-find (test-if-not-in-cl-package "find") nil) (deftest symbol-find-all-symbols (test-if-not-in-cl-package "find-all-symbols") nil) (deftest symbol-find-class (test-if-not-in-cl-package "find-class") nil) (deftest symbol-find-if (test-if-not-in-cl-package "find-if") nil) (deftest symbol-find-if-not (test-if-not-in-cl-package "find-if-not") nil) (deftest symbol-find-method (test-if-not-in-cl-package "find-method") nil) (deftest symbol-find-package (test-if-not-in-cl-package "find-package") nil) (deftest symbol-find-restart (test-if-not-in-cl-package "find-restart") nil) (deftest symbol-find-symbol (test-if-not-in-cl-package "find-symbol") nil) (deftest symbol-finish-output (test-if-not-in-cl-package "finish-output") nil) (deftest symbol-first (test-if-not-in-cl-package "first") nil) (deftest symbol-fixnum (test-if-not-in-cl-package "fixnum") nil) (deftest symbol-flet (test-if-not-in-cl-package "flet") nil) (deftest symbol-float (test-if-not-in-cl-package "float") nil) (deftest symbol-float-digits (test-if-not-in-cl-package "float-digits") nil) (deftest symbol-float-precision (test-if-not-in-cl-package "float-precision") nil) (deftest symbol-float-radix (test-if-not-in-cl-package "float-radix") nil) (deftest symbol-float-sign (test-if-not-in-cl-package "float-sign") nil) (deftest symbol-floating-point-inexact (test-if-not-in-cl-package "floating-point-inexact") nil) (deftest symbol-floating-point-invalid-operation (test-if-not-in-cl-package "floating-point-invalid-operation") nil) (deftest symbol-floating-point-overflow (test-if-not-in-cl-package "floating-point-overflow") nil) (deftest symbol-floating-point-underflow (test-if-not-in-cl-package "floating-point-underflow") nil) (deftest symbol-floatp (test-if-not-in-cl-package "floatp") nil) (deftest symbol-floor (test-if-not-in-cl-package "floor") nil) (deftest symbol-fmakunbound (test-if-not-in-cl-package "fmakunbound") nil) (deftest symbol-force-output (test-if-not-in-cl-package "force-output") nil) (deftest symbol-format (test-if-not-in-cl-package "format") nil) (deftest symbol-formatter (test-if-not-in-cl-package "formatter") nil) (deftest symbol-fourth (test-if-not-in-cl-package "fourth") nil) (deftest symbol-fresh-line (test-if-not-in-cl-package "fresh-line") nil) (deftest symbol-fround (test-if-not-in-cl-package "fround") nil) (deftest symbol-ftruncate (test-if-not-in-cl-package "ftruncate") nil) (deftest symbol-ftype (test-if-not-in-cl-package "ftype") nil) (deftest symbol-funcall (test-if-not-in-cl-package "funcall") nil) (deftest symbol-function (test-if-not-in-cl-package "function") nil) (deftest symbol-function-keywords (test-if-not-in-cl-package "function-keywords") nil) (deftest symbol-function-lambda-expression (test-if-not-in-cl-package "function-lambda-expression") nil) (deftest symbol-functionp (test-if-not-in-cl-package "functionp") nil) (deftest symbol-gcd (test-if-not-in-cl-package "gcd") nil) (deftest symbol-generic-function (test-if-not-in-cl-package "generic-function") nil) (deftest symbol-gensym (test-if-not-in-cl-package "gensym") nil) (deftest symbol-gentemp (test-if-not-in-cl-package "gentemp") nil) (deftest symbol-get (test-if-not-in-cl-package "get") nil) (deftest symbol-get-decoded-time (test-if-not-in-cl-package "get-decoded-time") nil) (deftest symbol-get-dispatch-macro-character (test-if-not-in-cl-package "get-dispatch-macro-character") nil) (deftest symbol-get-internal-real-time (test-if-not-in-cl-package "get-internal-real-time") nil) (deftest symbol-get-internal-run-time (test-if-not-in-cl-package "get-internal-run-time") nil) (deftest symbol-get-macro-character (test-if-not-in-cl-package "get-macro-character") nil) (deftest symbol-get-output-stream-string (test-if-not-in-cl-package "get-output-stream-string") nil) (deftest symbol-get-properties (test-if-not-in-cl-package "get-properties") nil) (deftest symbol-get-setf-expansion (test-if-not-in-cl-package "get-setf-expansion") nil) (deftest symbol-get-universal-time (test-if-not-in-cl-package "get-universal-time") nil) (deftest symbol-getf (test-if-not-in-cl-package "getf") nil) (deftest symbol-gethash (test-if-not-in-cl-package "gethash") nil) (deftest symbol-go (test-if-not-in-cl-package "go") nil) (deftest symbol-graphic-char-p (test-if-not-in-cl-package "graphic-char-p") nil) (deftest symbol-handler-bind (test-if-not-in-cl-package "handler-bind") nil) (deftest symbol-handler-case (test-if-not-in-cl-package "handler-case") nil) (deftest symbol-hash-table (test-if-not-in-cl-package "hash-table") nil) (deftest symbol-hash-table-count (test-if-not-in-cl-package "hash-table-count") nil) (deftest symbol-hash-table-p (test-if-not-in-cl-package "hash-table-p") nil) (deftest symbol-hash-table-rehash-size (test-if-not-in-cl-package "hash-table-rehash-size") nil) (deftest symbol-hash-table-rehash-threshold (test-if-not-in-cl-package "hash-table-rehash-threshold") nil) (deftest symbol-hash-table-size (test-if-not-in-cl-package "hash-table-size") nil) (deftest symbol-hash-table-test (test-if-not-in-cl-package "hash-table-test") nil) (deftest symbol-host-namestring (test-if-not-in-cl-package "host-namestring") nil) (deftest symbol-identity (test-if-not-in-cl-package "identity") nil) (deftest symbol-if (test-if-not-in-cl-package "if") nil) (deftest symbol-ignorable (test-if-not-in-cl-package "ignorable") nil) (deftest symbol-ignore (test-if-not-in-cl-package "ignore") nil) (deftest symbol-ignore-errors (test-if-not-in-cl-package "ignore-errors") nil) (deftest symbol-imagpart (test-if-not-in-cl-package "imagpart") nil) (deftest symbol-import (test-if-not-in-cl-package "import") nil) (deftest symbol-in-package (test-if-not-in-cl-package "in-package") nil) (deftest symbol-incf (test-if-not-in-cl-package "incf") nil) (deftest symbol-initialize-instance (test-if-not-in-cl-package "initialize-instance") nil) (deftest symbol-inline (test-if-not-in-cl-package "inline") nil) (deftest symbol-input-stream-p (test-if-not-in-cl-package "input-stream-p") nil) (deftest symbol-inspect (test-if-not-in-cl-package "inspect") nil) (deftest symbol-integer (test-if-not-in-cl-package "integer") nil) (deftest symbol-integer-decode-float (test-if-not-in-cl-package "integer-decode-float") nil) (deftest symbol-integer-length (test-if-not-in-cl-package "integer-length") nil) (deftest symbol-integerp (test-if-not-in-cl-package "integerp") nil) (deftest symbol-interactive-stream-p (test-if-not-in-cl-package "interactive-stream-p") nil) (deftest symbol-intern (test-if-not-in-cl-package "intern") nil) (deftest symbol-internal-time-units-per-second (test-if-not-in-cl-package "internal-time-units-per-second") nil) (deftest symbol-intersection (test-if-not-in-cl-package "intersection") nil) (deftest symbol-invalid-method-error (test-if-not-in-cl-package "invalid-method-error") nil) (deftest symbol-invoke-debugger (test-if-not-in-cl-package "invoke-debugger") nil) (deftest symbol-invoke-restart (test-if-not-in-cl-package "invoke-restart") nil) (deftest symbol-invoke-restart-interactively (test-if-not-in-cl-package "invoke-restart-interactively") nil) (deftest symbol-isqrt (test-if-not-in-cl-package "isqrt") nil) (deftest symbol-keyword (test-if-not-in-cl-package "keyword") nil) (deftest symbol-keywordp (test-if-not-in-cl-package "keywordp") nil) (deftest symbol-labels (test-if-not-in-cl-package "labels") nil) (deftest symbol-lambda (test-if-not-in-cl-package "lambda") nil) (deftest symbol-lambda-list-keywords (test-if-not-in-cl-package "lambda-list-keywords") nil) (deftest symbol-lambda-parameters-limit (test-if-not-in-cl-package "lambda-parameters-limit") nil) (deftest symbol-last (test-if-not-in-cl-package "last") nil) (deftest symbol-lcm (test-if-not-in-cl-package "lcm") nil) (deftest symbol-ldb (test-if-not-in-cl-package "ldb") nil) (deftest symbol-ldb-test (test-if-not-in-cl-package "ldb-test") nil) (deftest symbol-ldiff (test-if-not-in-cl-package "ldiff") nil) (deftest symbol-least-negative-double-float (test-if-not-in-cl-package "least-negative-double-float") nil) (deftest symbol-least-negative-long-float (test-if-not-in-cl-package "least-negative-long-float") nil) (deftest symbol-least-negative-normalized-double-float (test-if-not-in-cl-package "least-negative-normalized-double-float") nil) (deftest symbol-least-negative-normalized-long-float (test-if-not-in-cl-package "least-negative-normalized-long-float") nil) (deftest symbol-least-negative-normalized-short-float (test-if-not-in-cl-package "least-negative-normalized-short-float") nil) (deftest symbol-least-negative-normalized-single-float (test-if-not-in-cl-package "least-negative-normalized-single-float") nil) (deftest symbol-least-negative-short-float (test-if-not-in-cl-package "least-negative-short-float") nil) (deftest symbol-least-negative-single-float (test-if-not-in-cl-package "least-negative-single-float") nil) (deftest symbol-least-positive-double-float (test-if-not-in-cl-package "least-positive-double-float") nil) (deftest symbol-least-positive-long-float (test-if-not-in-cl-package "least-positive-long-float") nil) (deftest symbol-least-positive-normalized-double-float (test-if-not-in-cl-package "least-positive-normalized-double-float") nil) (deftest symbol-least-positive-normalized-long-float (test-if-not-in-cl-package "least-positive-normalized-long-float") nil) (deftest symbol-least-positive-normalized-short-float (test-if-not-in-cl-package "least-positive-normalized-short-float") nil) (deftest symbol-least-positive-normalized-single-float (test-if-not-in-cl-package "least-positive-normalized-single-float") nil) (deftest symbol-least-positive-short-float (test-if-not-in-cl-package "least-positive-short-float") nil) (deftest symbol-least-positive-single-float (test-if-not-in-cl-package "least-positive-single-float") nil) (deftest symbol-length (test-if-not-in-cl-package "length") nil) (deftest symbol-let (test-if-not-in-cl-package "let") nil) (deftest symbol-let* (test-if-not-in-cl-package "let*") nil) (deftest symbol-lisp-implementation-type (test-if-not-in-cl-package "lisp-implementation-type") nil) (deftest symbol-lisp-implementation-version (test-if-not-in-cl-package "lisp-implementation-version") nil) (deftest symbol-list (test-if-not-in-cl-package "list") nil) (deftest symbol-list* (test-if-not-in-cl-package "list*") nil) (deftest symbol-list-all-packages (test-if-not-in-cl-package "list-all-packages") nil) (deftest symbol-list-length (test-if-not-in-cl-package "list-length") nil) (deftest symbol-listen (test-if-not-in-cl-package "listen") nil) (deftest symbol-listp (test-if-not-in-cl-package "listp") nil) (deftest symbol-load (test-if-not-in-cl-package "load") nil) (deftest symbol-load-logical-pathname-translations (test-if-not-in-cl-package "load-logical-pathname-translations") nil) (deftest symbol-load-time-value (test-if-not-in-cl-package "load-time-value") nil) (deftest symbol-locally (test-if-not-in-cl-package "locally") nil) (deftest symbol-log (test-if-not-in-cl-package "log") nil) (deftest symbol-logand (test-if-not-in-cl-package "logand") nil) (deftest symbol-logandc1 (test-if-not-in-cl-package "logandc1") nil) (deftest symbol-logandc2 (test-if-not-in-cl-package "logandc2") nil) (deftest symbol-logbitp (test-if-not-in-cl-package "logbitp") nil) (deftest symbol-logcount (test-if-not-in-cl-package "logcount") nil) (deftest symbol-logeqv (test-if-not-in-cl-package "logeqv") nil) (deftest symbol-logical-pathname (test-if-not-in-cl-package "logical-pathname") nil) (deftest symbol-logical-pathname-translations (test-if-not-in-cl-package "logical-pathname-translations") nil) (deftest symbol-logior (test-if-not-in-cl-package "logior") nil) (deftest symbol-lognand (test-if-not-in-cl-package "lognand") nil) (deftest symbol-lognor (test-if-not-in-cl-package "lognor") nil) (deftest symbol-lognot (test-if-not-in-cl-package "lognot") nil) (deftest symbol-logorc1 (test-if-not-in-cl-package "logorc1") nil) (deftest symbol-logorc2 (test-if-not-in-cl-package "logorc2") nil) (deftest symbol-logtest (test-if-not-in-cl-package "logtest") nil) (deftest symbol-logxor (test-if-not-in-cl-package "logxor") nil) (deftest symbol-long-float (test-if-not-in-cl-package "long-float") nil) (deftest symbol-long-float-epsilon (test-if-not-in-cl-package "long-float-epsilon") nil) (deftest symbol-long-float-negative-epsilon (test-if-not-in-cl-package "long-float-negative-epsilon") nil) (deftest symbol-long-site-name (test-if-not-in-cl-package "long-site-name") nil) (deftest symbol-loop (test-if-not-in-cl-package "loop") nil) (deftest symbol-loop-finish (test-if-not-in-cl-package "loop-finish") nil) (deftest symbol-lower-case-p (test-if-not-in-cl-package "lower-case-p") nil) (deftest symbol-machine-instance (test-if-not-in-cl-package "machine-instance") nil) (deftest symbol-machine-type (test-if-not-in-cl-package "machine-type") nil) (deftest symbol-machine-version (test-if-not-in-cl-package "machine-version") nil) (deftest symbol-macro-function (test-if-not-in-cl-package "macro-function") nil) (deftest symbol-macroexpand (test-if-not-in-cl-package "macroexpand") nil) (deftest symbol-macroexpand-1 (test-if-not-in-cl-package "macroexpand-1") nil) (deftest symbol-macrolet (test-if-not-in-cl-package "macrolet") nil) (deftest symbol-make-array (test-if-not-in-cl-package "make-array") nil) (deftest symbol-make-broadcast-stream (test-if-not-in-cl-package "make-broadcast-stream") nil) (deftest symbol-make-concatenated-stream (test-if-not-in-cl-package "make-concatenated-stream") nil) (deftest symbol-make-condition (test-if-not-in-cl-package "make-condition") nil) (deftest symbol-make-dispatch-macro-character (test-if-not-in-cl-package "make-dispatch-macro-character") nil) (deftest symbol-make-echo-stream (test-if-not-in-cl-package "make-echo-stream") nil) (deftest symbol-make-hash-table (test-if-not-in-cl-package "make-hash-table") nil) (deftest symbol-make-instance (test-if-not-in-cl-package "make-instance") nil) (deftest symbol-make-instances-obsolete (test-if-not-in-cl-package "make-instances-obsolete") nil) (deftest symbol-make-list (test-if-not-in-cl-package "make-list") nil) (deftest symbol-make-load-form (test-if-not-in-cl-package "make-load-form") nil) (deftest symbol-make-load-form-saving-slots (test-if-not-in-cl-package "make-load-form-saving-slots") nil) (deftest symbol-make-method (test-if-not-in-cl-package "make-method") nil) (deftest symbol-make-package (test-if-not-in-cl-package "make-package") nil) (deftest symbol-make-pathname (test-if-not-in-cl-package "make-pathname") nil) (deftest symbol-make-random-state (test-if-not-in-cl-package "make-random-state") nil) (deftest symbol-make-sequence (test-if-not-in-cl-package "make-sequence") nil) (deftest symbol-make-string (test-if-not-in-cl-package "make-string") nil) (deftest symbol-make-string-input-stream (test-if-not-in-cl-package "make-string-input-stream") nil) (deftest symbol-make-string-output-stream (test-if-not-in-cl-package "make-string-output-stream") nil) (deftest symbol-make-symbol (test-if-not-in-cl-package "make-symbol") nil) (deftest symbol-make-synonym-stream (test-if-not-in-cl-package "make-synonym-stream") nil) (deftest symbol-make-two-way-stream (test-if-not-in-cl-package "make-two-way-stream") nil) (deftest symbol-makunbound (test-if-not-in-cl-package "makunbound") nil) (deftest symbol-map (test-if-not-in-cl-package "map") nil) (deftest symbol-map-into (test-if-not-in-cl-package "map-into") nil) (deftest symbol-mapc (test-if-not-in-cl-package "mapc") nil) (deftest symbol-mapcan (test-if-not-in-cl-package "mapcan") nil) (deftest symbol-mapcar (test-if-not-in-cl-package "mapcar") nil) (deftest symbol-mapcon (test-if-not-in-cl-package "mapcon") nil) (deftest symbol-maphash (test-if-not-in-cl-package "maphash") nil) (deftest symbol-mapl (test-if-not-in-cl-package "mapl") nil) (deftest symbol-maplist (test-if-not-in-cl-package "maplist") nil) (deftest symbol-mask-field (test-if-not-in-cl-package "mask-field") nil) (deftest symbol-max (test-if-not-in-cl-package "max") nil) (deftest symbol-member (test-if-not-in-cl-package "member") nil) (deftest symbol-member-if (test-if-not-in-cl-package "member-if") nil) (deftest symbol-member-if-not (test-if-not-in-cl-package "member-if-not") nil) (deftest symbol-merge (test-if-not-in-cl-package "merge") nil) (deftest symbol-merge-pathnames (test-if-not-in-cl-package "merge-pathnames") nil) (deftest symbol-method (test-if-not-in-cl-package "method") nil) (deftest symbol-method-combination (test-if-not-in-cl-package "method-combination") nil) (deftest symbol-method-combination-error (test-if-not-in-cl-package "method-combination-error") nil) (deftest symbol-method-qualifiers (test-if-not-in-cl-package "method-qualifiers") nil) (deftest symbol-min (test-if-not-in-cl-package "min") nil) (deftest symbol-minusp (test-if-not-in-cl-package "minusp") nil) (deftest symbol-mismatch (test-if-not-in-cl-package "mismatch") nil) (deftest symbol-mod (test-if-not-in-cl-package "mod") nil) (deftest symbol-most-negative-double-float (test-if-not-in-cl-package "most-negative-double-float") nil) (deftest symbol-most-negative-fixnum (test-if-not-in-cl-package "most-negative-fixnum") nil) (deftest symbol-most-negative-long-float (test-if-not-in-cl-package "most-negative-long-float") nil) (deftest symbol-most-negative-short-float (test-if-not-in-cl-package "most-negative-short-float") nil) (deftest symbol-most-negative-single-float (test-if-not-in-cl-package "most-negative-single-float") nil) (deftest symbol-most-positive-double-float (test-if-not-in-cl-package "most-positive-double-float") nil) (deftest symbol-most-positive-fixnum (test-if-not-in-cl-package "most-positive-fixnum") nil) (deftest symbol-most-positive-long-float (test-if-not-in-cl-package "most-positive-long-float") nil) (deftest symbol-most-positive-short-float (test-if-not-in-cl-package "most-positive-short-float") nil) (deftest symbol-most-positive-single-float (test-if-not-in-cl-package "most-positive-single-float") nil) (deftest symbol-muffle-warning (test-if-not-in-cl-package "muffle-warning") nil) (deftest symbol-multiple-value-bind (test-if-not-in-cl-package "multiple-value-bind") nil) (deftest symbol-multiple-value-call (test-if-not-in-cl-package "multiple-value-call") nil) (deftest symbol-multiple-value-list (test-if-not-in-cl-package "multiple-value-list") nil) (deftest symbol-multiple-value-prog1 (test-if-not-in-cl-package "multiple-value-prog1") nil) (deftest symbol-multiple-value-setq (test-if-not-in-cl-package "multiple-value-setq") nil) (deftest symbol-multiple-values-limit (test-if-not-in-cl-package "multiple-values-limit") nil) (deftest symbol-name-char (test-if-not-in-cl-package "name-char") nil) (deftest symbol-namestring (test-if-not-in-cl-package "namestring") nil) (deftest symbol-nbutlast (test-if-not-in-cl-package "nbutlast") nil) (deftest symbol-nconc (test-if-not-in-cl-package "nconc") nil) (deftest symbol-next-method-p (test-if-not-in-cl-package "next-method-p") nil) (deftest symbol-nil (test-if-not-in-cl-package "nil") nil) (deftest symbol-nintersection (test-if-not-in-cl-package "nintersection") nil) (deftest symbol-ninth (test-if-not-in-cl-package "ninth") nil) (deftest symbol-no-applicable-method (test-if-not-in-cl-package "no-applicable-method") nil) (deftest symbol-no-next-method (test-if-not-in-cl-package "no-next-method") nil) (deftest symbol-not (test-if-not-in-cl-package "not") nil) (deftest symbol-notany (test-if-not-in-cl-package "notany") nil) (deftest symbol-notevery (test-if-not-in-cl-package "notevery") nil) (deftest symbol-notinline (test-if-not-in-cl-package "notinline") nil) (deftest symbol-nreconc (test-if-not-in-cl-package "nreconc") nil) (deftest symbol-nreverse (test-if-not-in-cl-package "nreverse") nil) (deftest symbol-nset-difference (test-if-not-in-cl-package "nset-difference") nil) (deftest symbol-nset-exclusive-or (test-if-not-in-cl-package "nset-exclusive-or") nil) (deftest symbol-nstring-capitalize (test-if-not-in-cl-package "nstring-capitalize") nil) (deftest symbol-nstring-downcase (test-if-not-in-cl-package "nstring-downcase") nil) (deftest symbol-nstring-upcase (test-if-not-in-cl-package "nstring-upcase") nil) (deftest symbol-nsublis (test-if-not-in-cl-package "nsublis") nil) (deftest symbol-nsubst (test-if-not-in-cl-package "nsubst") nil) (deftest symbol-nsubst-if (test-if-not-in-cl-package "nsubst-if") nil) (deftest symbol-nsubst-if-not (test-if-not-in-cl-package "nsubst-if-not") nil) (deftest symbol-nsubstitute (test-if-not-in-cl-package "nsubstitute") nil) (deftest symbol-nsubstitute-if (test-if-not-in-cl-package "nsubstitute-if") nil) (deftest symbol-nsubstitute-if-not (test-if-not-in-cl-package "nsubstitute-if-not") nil) (deftest symbol-nth (test-if-not-in-cl-package "nth") nil) (deftest symbol-nth-value (test-if-not-in-cl-package "nth-value") nil) (deftest symbol-nthcdr (test-if-not-in-cl-package "nthcdr") nil) (deftest symbol-null (test-if-not-in-cl-package "null") nil) (deftest symbol-number (test-if-not-in-cl-package "number") nil) (deftest symbol-numberp (test-if-not-in-cl-package "numberp") nil) (deftest symbol-numerator (test-if-not-in-cl-package "numerator") nil) (deftest symbol-nunion (test-if-not-in-cl-package "nunion") nil) (deftest symbol-oddp (test-if-not-in-cl-package "oddp") nil) (deftest symbol-open (test-if-not-in-cl-package "open") nil) (deftest symbol-open-stream-p (test-if-not-in-cl-package "open-stream-p") nil) (deftest symbol-optimize (test-if-not-in-cl-package "optimize") nil) (deftest symbol-or (test-if-not-in-cl-package "or") nil) (deftest symbol-otherwise (test-if-not-in-cl-package "otherwise") nil) (deftest symbol-output-stream-p (test-if-not-in-cl-package "output-stream-p") nil) (deftest symbol-package (test-if-not-in-cl-package "package") nil) (deftest symbol-package-error (test-if-not-in-cl-package "package-error") nil) (deftest symbol-package-error-package (test-if-not-in-cl-package "package-error-package") nil) (deftest symbol-package-name (test-if-not-in-cl-package "package-name") nil) (deftest symbol-package-nicknames (test-if-not-in-cl-package "package-nicknames") nil) (deftest symbol-package-shadowing-symbols (test-if-not-in-cl-package "package-shadowing-symbols") nil) (deftest symbol-package-use-list (test-if-not-in-cl-package "package-use-list") nil) (deftest symbol-package-used-by-list (test-if-not-in-cl-package "package-used-by-list") nil) (deftest symbol-packagep (test-if-not-in-cl-package "packagep") nil) (deftest symbol-pairlis (test-if-not-in-cl-package "pairlis") nil) (deftest symbol-parse-error (test-if-not-in-cl-package "parse-error") nil) (deftest symbol-parse-integer (test-if-not-in-cl-package "parse-integer") nil) (deftest symbol-parse-namestring (test-if-not-in-cl-package "parse-namestring") nil) (deftest symbol-pathname (test-if-not-in-cl-package "pathname") nil) (deftest symbol-pathname-device (test-if-not-in-cl-package "pathname-device") nil) (deftest symbol-pathname-directory (test-if-not-in-cl-package "pathname-directory") nil) (deftest symbol-pathname-host (test-if-not-in-cl-package "pathname-host") nil) (deftest symbol-pathname-match-p (test-if-not-in-cl-package "pathname-match-p") nil) (deftest symbol-pathname-name (test-if-not-in-cl-package "pathname-name") nil) (deftest symbol-pathname-type (test-if-not-in-cl-package "pathname-type") nil) (deftest symbol-pathname-version (test-if-not-in-cl-package "pathname-version") nil) (deftest symbol-pathnamep (test-if-not-in-cl-package "pathnamep") nil) (deftest symbol-peek-char (test-if-not-in-cl-package "peek-char") nil) (deftest symbol-phase (test-if-not-in-cl-package "phase") nil) (deftest symbol-pi (test-if-not-in-cl-package "pi") nil) (deftest symbol-plusp (test-if-not-in-cl-package "plusp") nil) (deftest symbol-pop (test-if-not-in-cl-package "pop") nil) (deftest symbol-position (test-if-not-in-cl-package "position") nil) (deftest symbol-position-if (test-if-not-in-cl-package "position-if") nil) (deftest symbol-position-if-not (test-if-not-in-cl-package "position-if-not") nil) (deftest symbol-pprint (test-if-not-in-cl-package "pprint") nil) (deftest symbol-pprint-dispatch (test-if-not-in-cl-package "pprint-dispatch") nil) (deftest symbol-pprint-exit-if-list-exhausted (test-if-not-in-cl-package "pprint-exit-if-list-exhausted") nil) (deftest symbol-pprint-fill (test-if-not-in-cl-package "pprint-fill") nil) (deftest symbol-pprint-indent (test-if-not-in-cl-package "pprint-indent") nil) (deftest symbol-pprint-linear (test-if-not-in-cl-package "pprint-linear") nil) (deftest symbol-pprint-logical-block (test-if-not-in-cl-package "pprint-logical-block") nil) (deftest symbol-pprint-newline (test-if-not-in-cl-package "pprint-newline") nil) (deftest symbol-pprint-pop (test-if-not-in-cl-package "pprint-pop") nil) (deftest symbol-pprint-tab (test-if-not-in-cl-package "pprint-tab") nil) (deftest symbol-pprint-tabular (test-if-not-in-cl-package "pprint-tabular") nil) (deftest symbol-prin1 (test-if-not-in-cl-package "prin1") nil) (deftest symbol-prin1-to-string (test-if-not-in-cl-package "prin1-to-string") nil) (deftest symbol-princ (test-if-not-in-cl-package "princ") nil) (deftest symbol-princ-to-string (test-if-not-in-cl-package "princ-to-string") nil) (deftest symbol-print (test-if-not-in-cl-package "print") nil) (deftest symbol-print-not-readable (test-if-not-in-cl-package "print-not-readable") nil) (deftest symbol-print-not-readable-object (test-if-not-in-cl-package "print-not-readable-object") nil) (deftest symbol-print-object (test-if-not-in-cl-package "print-object") nil) (deftest symbol-print-unreadable-object (test-if-not-in-cl-package "print-unreadable-object") nil) (deftest symbol-probe-file (test-if-not-in-cl-package "probe-file") nil) (deftest symbol-proclaim (test-if-not-in-cl-package "proclaim") nil) (deftest symbol-prog (test-if-not-in-cl-package "prog") nil) (deftest symbol-prog* (test-if-not-in-cl-package "prog*") nil) (deftest symbol-prog1 (test-if-not-in-cl-package "prog1") nil) (deftest symbol-prog2 (test-if-not-in-cl-package "prog2") nil) (deftest symbol-progn (test-if-not-in-cl-package "progn") nil) (deftest symbol-program-error (test-if-not-in-cl-package "program-error") nil) (deftest symbol-progv (test-if-not-in-cl-package "progv") nil) (deftest symbol-provide (test-if-not-in-cl-package "provide") nil) (deftest symbol-psetf (test-if-not-in-cl-package "psetf") nil) (deftest symbol-psetq (test-if-not-in-cl-package "psetq") nil) (deftest symbol-push (test-if-not-in-cl-package "push") nil) (deftest symbol-pushnew (test-if-not-in-cl-package "pushnew") nil) (deftest symbol-quote (test-if-not-in-cl-package "quote") nil) (deftest symbol-random (test-if-not-in-cl-package "random") nil) (deftest symbol-random-state (test-if-not-in-cl-package "random-state") nil) (deftest symbol-random-state-p (test-if-not-in-cl-package "random-state-p") nil) (deftest symbol-rassoc (test-if-not-in-cl-package "rassoc") nil) (deftest symbol-rassoc-if (test-if-not-in-cl-package "rassoc-if") nil) (deftest symbol-rassoc-if-not (test-if-not-in-cl-package "rassoc-if-not") nil) (deftest symbol-ratio (test-if-not-in-cl-package "ratio") nil) (deftest symbol-rational (test-if-not-in-cl-package "rational") nil) (deftest symbol-rationalize (test-if-not-in-cl-package "rationalize") nil) (deftest symbol-rationalp (test-if-not-in-cl-package "rationalp") nil) (deftest symbol-read (test-if-not-in-cl-package "read") nil) (deftest symbol-read-byte (test-if-not-in-cl-package "read-byte") nil) (deftest symbol-read-char (test-if-not-in-cl-package "read-char") nil) (deftest symbol-read-char-no-hang (test-if-not-in-cl-package "read-char-no-hang") nil) (deftest symbol-read-delimited-list (test-if-not-in-cl-package "read-delimited-list") nil) (deftest symbol-read-from-string (test-if-not-in-cl-package "read-from-string") nil) (deftest symbol-read-line (test-if-not-in-cl-package "read-line") nil) (deftest symbol-read-preserving-whitespace (test-if-not-in-cl-package "read-preserving-whitespace") nil) (deftest symbol-read-sequence (test-if-not-in-cl-package "read-sequence") nil) (deftest symbol-reader-error (test-if-not-in-cl-package "reader-error") nil) (deftest symbol-readtable (test-if-not-in-cl-package "readtable") nil) (deftest symbol-readtable-case (test-if-not-in-cl-package "readtable-case") nil) (deftest symbol-readtablep (test-if-not-in-cl-package "readtablep") nil) (deftest symbol-real (test-if-not-in-cl-package "real") nil) (deftest symbol-realp (test-if-not-in-cl-package "realp") nil) (deftest symbol-realpart (test-if-not-in-cl-package "realpart") nil) (deftest symbol-reduce (test-if-not-in-cl-package "reduce") nil) (deftest symbol-reinitialize-instance (test-if-not-in-cl-package "reinitialize-instance") nil) (deftest symbol-rem (test-if-not-in-cl-package "rem") nil) (deftest symbol-remf (test-if-not-in-cl-package "remf") nil) (deftest symbol-remhash (test-if-not-in-cl-package "remhash") nil) (deftest symbol-remove (test-if-not-in-cl-package "remove") nil) (deftest symbol-remove-duplicates (test-if-not-in-cl-package "remove-duplicates") nil) (deftest symbol-remove-if (test-if-not-in-cl-package "remove-if") nil) (deftest symbol-remove-if-not (test-if-not-in-cl-package "remove-if-not") nil) (deftest symbol-remove-method (test-if-not-in-cl-package "remove-method") nil) (deftest symbol-remprop (test-if-not-in-cl-package "remprop") nil) (deftest symbol-rename-file (test-if-not-in-cl-package "rename-file") nil) (deftest symbol-rename-package (test-if-not-in-cl-package "rename-package") nil) (deftest symbol-replace (test-if-not-in-cl-package "replace") nil) (deftest symbol-require (test-if-not-in-cl-package "require") nil) (deftest symbol-rest (test-if-not-in-cl-package "rest") nil) (deftest symbol-restart (test-if-not-in-cl-package "restart") nil) (deftest symbol-restart-bind (test-if-not-in-cl-package "restart-bind") nil) (deftest symbol-restart-case (test-if-not-in-cl-package "restart-case") nil) (deftest symbol-restart-name (test-if-not-in-cl-package "restart-name") nil) (deftest symbol-return (test-if-not-in-cl-package "return") nil) (deftest symbol-return-from (test-if-not-in-cl-package "return-from") nil) (deftest symbol-revappend (test-if-not-in-cl-package "revappend") nil) (deftest symbol-reverse (test-if-not-in-cl-package "reverse") nil) (deftest symbol-room (test-if-not-in-cl-package "room") nil) (deftest symbol-rotatef (test-if-not-in-cl-package "rotatef") nil) (deftest symbol-round (test-if-not-in-cl-package "round") nil) (deftest symbol-row-major-aref (test-if-not-in-cl-package "row-major-aref") nil) (deftest symbol-rplaca (test-if-not-in-cl-package "rplaca") nil) (deftest symbol-rplacd (test-if-not-in-cl-package "rplacd") nil) (deftest symbol-safety (test-if-not-in-cl-package "safety") nil) (deftest symbol-satisfies (test-if-not-in-cl-package "satisfies") nil) (deftest symbol-sbit (test-if-not-in-cl-package "sbit") nil) (deftest symbol-scale-float (test-if-not-in-cl-package "scale-float") nil) (deftest symbol-schar (test-if-not-in-cl-package "schar") nil) (deftest symbol-search (test-if-not-in-cl-package "search") nil) (deftest symbol-second (test-if-not-in-cl-package "second") nil) (deftest symbol-sequence (test-if-not-in-cl-package "sequence") nil) (deftest symbol-serious-condition (test-if-not-in-cl-package "serious-condition") nil) (deftest symbol-set (test-if-not-in-cl-package "set") nil) (deftest symbol-set-difference (test-if-not-in-cl-package "set-difference") nil) (deftest symbol-set-dispatch-macro-character (test-if-not-in-cl-package "set-dispatch-macro-character") nil) (deftest symbol-set-exclusive-or (test-if-not-in-cl-package "set-exclusive-or") nil) (deftest symbol-set-macro-character (test-if-not-in-cl-package "set-macro-character") nil) (deftest symbol-set-pprint-dispatch (test-if-not-in-cl-package "set-pprint-dispatch") nil) (deftest symbol-set-syntax-from-char (test-if-not-in-cl-package "set-syntax-from-char") nil) (deftest symbol-setf (test-if-not-in-cl-package "setf") nil) (deftest symbol-setq (test-if-not-in-cl-package "setq") nil) (deftest symbol-seventh (test-if-not-in-cl-package "seventh") nil) (deftest symbol-shadow (test-if-not-in-cl-package "shadow") nil) (deftest symbol-shadowing-import (test-if-not-in-cl-package "shadowing-import") nil) (deftest symbol-shared-initialize (test-if-not-in-cl-package "shared-initialize") nil) (deftest symbol-shiftf (test-if-not-in-cl-package "shiftf") nil) (deftest symbol-short-float (test-if-not-in-cl-package "short-float") nil) (deftest symbol-short-float-epsilon (test-if-not-in-cl-package "short-float-epsilon") nil) (deftest symbol-short-float-negative-epsilon (test-if-not-in-cl-package "short-float-negative-epsilon") nil) (deftest symbol-short-site-name (test-if-not-in-cl-package "short-site-name") nil) (deftest symbol-signal (test-if-not-in-cl-package "signal") nil) (deftest symbol-signed-byte (test-if-not-in-cl-package "signed-byte") nil) (deftest symbol-signum (test-if-not-in-cl-package "signum") nil) (deftest symbol-simple-array (test-if-not-in-cl-package "simple-array") nil) (deftest symbol-simple-base-string (test-if-not-in-cl-package "simple-base-string") nil) (deftest symbol-simple-bit-vector (test-if-not-in-cl-package "simple-bit-vector") nil) (deftest symbol-simple-bit-vector-p (test-if-not-in-cl-package "simple-bit-vector-p") nil) (deftest symbol-simple-condition (test-if-not-in-cl-package "simple-condition") nil) (deftest symbol-simple-condition-format-arguments (test-if-not-in-cl-package "simple-condition-format-arguments") nil) (deftest symbol-simple-condition-format-control (test-if-not-in-cl-package "simple-condition-format-control") nil) (deftest symbol-simple-error (test-if-not-in-cl-package "simple-error") nil) (deftest symbol-simple-string (test-if-not-in-cl-package "simple-string") nil) (deftest symbol-simple-string-p (test-if-not-in-cl-package "simple-string-p") nil) (deftest symbol-simple-type-error (test-if-not-in-cl-package "simple-type-error") nil) (deftest symbol-simple-vector (test-if-not-in-cl-package "simple-vector") nil) (deftest symbol-simple-vector-p (test-if-not-in-cl-package "simple-vector-p") nil) (deftest symbol-simple-warning (test-if-not-in-cl-package "simple-warning") nil) (deftest symbol-sin (test-if-not-in-cl-package "sin") nil) (deftest symbol-single-float (test-if-not-in-cl-package "single-float") nil) (deftest symbol-single-float-epsilon (test-if-not-in-cl-package "single-float-epsilon") nil) (deftest symbol-single-float-negative-epsilon (test-if-not-in-cl-package "single-float-negative-epsilon") nil) (deftest symbol-sinh (test-if-not-in-cl-package "sinh") nil) (deftest symbol-sixth (test-if-not-in-cl-package "sixth") nil) (deftest symbol-sleep (test-if-not-in-cl-package "sleep") nil) (deftest symbol-slot-boundp (test-if-not-in-cl-package "slot-boundp") nil) (deftest symbol-slot-exists-p (test-if-not-in-cl-package "slot-exists-p") nil) (deftest symbol-slot-makunbound (test-if-not-in-cl-package "slot-makunbound") nil) (deftest symbol-slot-missing (test-if-not-in-cl-package "slot-missing") nil) (deftest symbol-slot-unbound (test-if-not-in-cl-package "slot-unbound") nil) (deftest symbol-slot-value (test-if-not-in-cl-package "slot-value") nil) (deftest symbol-software-type (test-if-not-in-cl-package "software-type") nil) (deftest symbol-software-version (test-if-not-in-cl-package "software-version") nil) (deftest symbol-some (test-if-not-in-cl-package "some") nil) (deftest symbol-sort (test-if-not-in-cl-package "sort") nil) (deftest symbol-space (test-if-not-in-cl-package "space") nil) (deftest symbol-special (test-if-not-in-cl-package "special") nil) (deftest symbol-special-operator-p (test-if-not-in-cl-package "special-operator-p") nil) (deftest symbol-speed (test-if-not-in-cl-package "speed") nil) (deftest symbol-sqrt (test-if-not-in-cl-package "sqrt") nil) (deftest symbol-stable-sort (test-if-not-in-cl-package "stable-sort") nil) (deftest symbol-standard (test-if-not-in-cl-package "standard") nil) (deftest symbol-standard-char (test-if-not-in-cl-package "standard-char") nil) (deftest symbol-standard-char-p (test-if-not-in-cl-package "standard-char-p") nil) (deftest symbol-standard-class (test-if-not-in-cl-package "standard-class") nil) (deftest symbol-standard-generic-function (test-if-not-in-cl-package "standard-generic-function") nil) (deftest symbol-standard-method (test-if-not-in-cl-package "standard-method") nil) (deftest symbol-standard-object (test-if-not-in-cl-package "standard-object") nil) (deftest symbol-step (test-if-not-in-cl-package "step") nil) (deftest symbol-storage-condition (test-if-not-in-cl-package "storage-condition") nil) (deftest symbol-store-value (test-if-not-in-cl-package "store-value") nil) (deftest symbol-stream (test-if-not-in-cl-package "stream") nil) (deftest symbol-stream-element-type (test-if-not-in-cl-package "stream-element-type") nil) (deftest symbol-stream-error (test-if-not-in-cl-package "stream-error") nil) (deftest symbol-stream-error-stream (test-if-not-in-cl-package "stream-error-stream") nil) (deftest symbol-stream-external-format (test-if-not-in-cl-package "stream-external-format") nil) (deftest symbol-streamp (test-if-not-in-cl-package "streamp") nil) (deftest symbol-string (test-if-not-in-cl-package "string") nil) (deftest symbol-string-capitalize (test-if-not-in-cl-package "string-capitalize") nil) (deftest symbol-string-downcase (test-if-not-in-cl-package "string-downcase") nil) (deftest symbol-string-equal (test-if-not-in-cl-package "string-equal") nil) (deftest symbol-string-greaterp (test-if-not-in-cl-package "string-greaterp") nil) (deftest symbol-string-left-trim (test-if-not-in-cl-package "string-left-trim") nil) (deftest symbol-string-lessp (test-if-not-in-cl-package "string-lessp") nil) (deftest symbol-string-not-equal (test-if-not-in-cl-package "string-not-equal") nil) (deftest symbol-string-not-greaterp (test-if-not-in-cl-package "string-not-greaterp") nil) (deftest symbol-string-not-lessp (test-if-not-in-cl-package "string-not-lessp") nil) (deftest symbol-string-right-trim (test-if-not-in-cl-package "string-right-trim") nil) (deftest symbol-string-stream (test-if-not-in-cl-package "string-stream") nil) (deftest symbol-string-trim (test-if-not-in-cl-package "string-trim") nil) (deftest symbol-string-upcase (test-if-not-in-cl-package "string-upcase") nil) (deftest symbol-string/= (test-if-not-in-cl-package "string/=") nil) (deftest symbol-string< (test-if-not-in-cl-package "string<") nil) (deftest symbol-string<= (test-if-not-in-cl-package "string<=") nil) (deftest symbol-string= (test-if-not-in-cl-package "string=") nil) (deftest symbol-string> (test-if-not-in-cl-package "string>") nil) (deftest symbol-string>= (test-if-not-in-cl-package "string>=") nil) (deftest symbol-stringp (test-if-not-in-cl-package "stringp") nil) (deftest symbol-structure (test-if-not-in-cl-package "structure") nil) (deftest symbol-structure-class (test-if-not-in-cl-package "structure-class") nil) (deftest symbol-structure-object (test-if-not-in-cl-package "structure-object") nil) (deftest symbol-style-warning (test-if-not-in-cl-package "style-warning") nil) (deftest symbol-sublis (test-if-not-in-cl-package "sublis") nil) (deftest symbol-subseq (test-if-not-in-cl-package "subseq") nil) (deftest symbol-subsetp (test-if-not-in-cl-package "subsetp") nil) (deftest symbol-subst (test-if-not-in-cl-package "subst") nil) (deftest symbol-subst-if (test-if-not-in-cl-package "subst-if") nil) (deftest symbol-subst-if-not (test-if-not-in-cl-package "subst-if-not") nil) (deftest symbol-substitute (test-if-not-in-cl-package "substitute") nil) (deftest symbol-substitute-if (test-if-not-in-cl-package "substitute-if") nil) (deftest symbol-substitute-if-not (test-if-not-in-cl-package "substitute-if-not") nil) (deftest symbol-subtypep (test-if-not-in-cl-package "subtypep") nil) (deftest symbol-svref (test-if-not-in-cl-package "svref") nil) (deftest symbol-sxhash (test-if-not-in-cl-package "sxhash") nil) (deftest symbol-symbol (test-if-not-in-cl-package "symbol") nil) (deftest symbol-symbol-function (test-if-not-in-cl-package "symbol-function") nil) (deftest symbol-symbol-macrolet (test-if-not-in-cl-package "symbol-macrolet") nil) (deftest symbol-symbol-name (test-if-not-in-cl-package "symbol-name") nil) (deftest symbol-symbol-package (test-if-not-in-cl-package "symbol-package") nil) (deftest symbol-symbol-plist (test-if-not-in-cl-package "symbol-plist") nil) (deftest symbol-symbol-value (test-if-not-in-cl-package "symbol-value") nil) (deftest symbol-symbolp (test-if-not-in-cl-package "symbolp") nil) (deftest symbol-synonym-stream (test-if-not-in-cl-package "synonym-stream") nil) (deftest symbol-synonym-stream-symbol (test-if-not-in-cl-package "synonym-stream-symbol") nil) (deftest symbol-t (test-if-not-in-cl-package "t") nil) (deftest symbol-tagbody (test-if-not-in-cl-package "tagbody") nil) (deftest symbol-tailp (test-if-not-in-cl-package "tailp") nil) (deftest symbol-tan (test-if-not-in-cl-package "tan") nil) (deftest symbol-tanh (test-if-not-in-cl-package "tanh") nil) (deftest symbol-tenth (test-if-not-in-cl-package "tenth") nil) (deftest symbol-terpri (test-if-not-in-cl-package "terpri") nil) (deftest symbol-the (test-if-not-in-cl-package "the") nil) (deftest symbol-third (test-if-not-in-cl-package "third") nil) (deftest symbol-throw (test-if-not-in-cl-package "throw") nil) (deftest symbol-time (test-if-not-in-cl-package "time") nil) (deftest symbol-trace (test-if-not-in-cl-package "trace") nil) (deftest symbol-translate-logical-pathname (test-if-not-in-cl-package "translate-logical-pathname") nil) (deftest symbol-translate-pathname (test-if-not-in-cl-package "translate-pathname") nil) (deftest symbol-tree-equal (test-if-not-in-cl-package "tree-equal") nil) (deftest symbol-truename (test-if-not-in-cl-package "truename") nil) (deftest symbol-truncate (test-if-not-in-cl-package "truncate") nil) (deftest symbol-two-way-stream (test-if-not-in-cl-package "two-way-stream") nil) (deftest symbol-two-way-stream-input-stream (test-if-not-in-cl-package "two-way-stream-input-stream") nil) (deftest symbol-two-way-stream-output-stream (test-if-not-in-cl-package "two-way-stream-output-stream") nil) (deftest symbol-type (test-if-not-in-cl-package "type") nil) (deftest symbol-type-error (test-if-not-in-cl-package "type-error") nil) (deftest symbol-type-error-datum (test-if-not-in-cl-package "type-error-datum") nil) (deftest symbol-type-error-expected-type (test-if-not-in-cl-package "type-error-expected-type") nil) (deftest symbol-type-of (test-if-not-in-cl-package "type-of") nil) (deftest symbol-typecase (test-if-not-in-cl-package "typecase") nil) (deftest symbol-typep (test-if-not-in-cl-package "typep") nil) (deftest symbol-unbound-slot (test-if-not-in-cl-package "unbound-slot") nil) (deftest symbol-unbound-slot-instance (test-if-not-in-cl-package "unbound-slot-instance") nil) (deftest symbol-unbound-variable (test-if-not-in-cl-package "unbound-variable") nil) (deftest symbol-undefined-function (test-if-not-in-cl-package "undefined-function") nil) (deftest symbol-unexport (test-if-not-in-cl-package "unexport") nil) (deftest symbol-unintern (test-if-not-in-cl-package "unintern") nil) (deftest symbol-union (test-if-not-in-cl-package "union") nil) (deftest symbol-unless (test-if-not-in-cl-package "unless") nil) (deftest symbol-unread-char (test-if-not-in-cl-package "unread-char") nil) (deftest symbol-unsigned-byte (test-if-not-in-cl-package "unsigned-byte") nil) (deftest symbol-untrace (test-if-not-in-cl-package "untrace") nil) (deftest symbol-unuse-package (test-if-not-in-cl-package "unuse-package") nil) (deftest symbol-unwind-protect (test-if-not-in-cl-package "unwind-protect") nil) (deftest symbol-update-instance-for-different-class (test-if-not-in-cl-package "update-instance-for-different-class") nil) (deftest symbol-update-instance-for-redefined-class (test-if-not-in-cl-package "update-instance-for-redefined-class") nil) (deftest symbol-upgraded-array-element-type (test-if-not-in-cl-package "upgraded-array-element-type") nil) (deftest symbol-upgraded-complex-part-type (test-if-not-in-cl-package "upgraded-complex-part-type") nil) (deftest symbol-upper-case-p (test-if-not-in-cl-package "upper-case-p") nil) (deftest symbol-use-package (test-if-not-in-cl-package "use-package") nil) (deftest symbol-use-value (test-if-not-in-cl-package "use-value") nil) (deftest symbol-user-homedir-pathname (test-if-not-in-cl-package "user-homedir-pathname") nil) (deftest symbol-values (test-if-not-in-cl-package "values") nil) (deftest symbol-values-list (test-if-not-in-cl-package "values-list") nil) (deftest symbol-variable (test-if-not-in-cl-package "variable") nil) (deftest symbol-vector (test-if-not-in-cl-package "vector") nil) (deftest symbol-vector-pop (test-if-not-in-cl-package "vector-pop") nil) (deftest symbol-vector-push (test-if-not-in-cl-package "vector-push") nil) (deftest symbol-vector-push-extend (test-if-not-in-cl-package "vector-push-extend") nil) (deftest symbol-vectorp (test-if-not-in-cl-package "vectorp") nil) (deftest symbol-warn (test-if-not-in-cl-package "warn") nil) (deftest symbol-warning (test-if-not-in-cl-package "warning") nil) (deftest symbol-when (test-if-not-in-cl-package "when") nil) (deftest symbol-wild-pathname-p (test-if-not-in-cl-package "wild-pathname-p") nil) (deftest symbol-with-accessors (test-if-not-in-cl-package "with-accessors") nil) (deftest symbol-with-compilation-unit (test-if-not-in-cl-package "with-compilation-unit") nil) (deftest symbol-with-condition-restarts (test-if-not-in-cl-package "with-condition-restarts") nil) (deftest symbol-with-hash-table-iterator (test-if-not-in-cl-package "with-hash-table-iterator") nil) (deftest symbol-with-input-from-string (test-if-not-in-cl-package "with-input-from-string") nil) (deftest symbol-with-open-file (test-if-not-in-cl-package "with-open-file") nil) (deftest symbol-with-open-stream (test-if-not-in-cl-package "with-open-stream") nil) (deftest symbol-with-output-to-string (test-if-not-in-cl-package "with-output-to-string") nil) (deftest symbol-with-package-iterator (test-if-not-in-cl-package "with-package-iterator") nil) (deftest symbol-with-simple-restart (test-if-not-in-cl-package "with-simple-restart") nil) (deftest symbol-with-slots (test-if-not-in-cl-package "with-slots") nil) (deftest symbol-with-standard-io-syntax (test-if-not-in-cl-package "with-standard-io-syntax") nil) (deftest symbol-write (test-if-not-in-cl-package "write") nil) (deftest symbol-write-byte (test-if-not-in-cl-package "write-byte") nil) (deftest symbol-write-char (test-if-not-in-cl-package "write-char") nil) (deftest symbol-write-line (test-if-not-in-cl-package "write-line") nil) (deftest symbol-write-sequence (test-if-not-in-cl-package "write-sequence") nil) (deftest symbol-write-string (test-if-not-in-cl-package "write-string") nil) (deftest symbol-write-to-string (test-if-not-in-cl-package "write-to-string") nil) (deftest symbol-y-or-n-p (test-if-not-in-cl-package "y-or-n-p") nil) (deftest symbol-yes-or-no-p (test-if-not-in-cl-package "yes-or-no-p") nil) (deftest symbol-zerop (test-if-not-in-cl-package "zerop") nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Test that all keywords have themselves as their value, ;;; are external if present in KEYWORD, and have themselves ;;; as their values (and are constant). Symbols that are ;;; merely used in KEYWORD but not present there are exempt. (deftest keyword-behavior (let ((result nil) (keyword-package (find-package "KEYWORD"))) (do-symbols (s keyword-package result) (multiple-value-bind (sym status) (find-symbol (symbol-name s) keyword-package) (cond ((not (eqt s sym)) (push (list s sym) result)) ((eqt status :internal) (push (list s status) result)) ((eqt status :external) (unless (and (eqt (symbol-value s) s) (constantp s)) (push (list s sym 'not-constant) result))))))) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; special-operator-p ;;; See section 3.1.2.1.2.1 (defparameter +special-operators+ '(block let* return-from catch load-time-value setq eval-when locally symbol-macrolet flet macrolet tagbody function multiple-value-call the go multiple-value-prog1 throw if progn unwind-protect labels progv let quote)) ;;; All the symbols in +special-operators+ are special operators (deftest special-operator-p.1 (loop for s in +special-operators+ unless (special-operator-p s) collect s) nil) ;;; None of the standard symbols except those in +special-operators+ ;;; are special operators, unless they have a macro function ;;; (See the page for MACRO-FUNCTION) (deftest special-operator-p.2 (let ((p (find-package "CL"))) (loop for name in *cl-symbol-names* unless (or (member name +special-operators+ :test #'string=) (let ((sym (find-symbol name p))) (or (not (special-operator-p sym)) (macro-function sym)))) collect name)) nil) (deftest special-operator-p.order.1 (let ((i 0)) (values (notnot (special-operator-p (progn (incf i) 'catch))) i)) t 1) (deftest special-operator-p.error.1 (classify-error (special-operator-p 1)) type-error) (deftest special-operator-p.error.2 (classify-error (special-operator-p)) program-error) (deftest special-operator-p.error.3 (classify-error (special-operator-p 'cons 'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; keywordp (deftest keywordp.1 (keywordp 'hefalump) nil) (deftest keywordp.2 (keywordp 17) nil) (deftest keywordp.3 (notnot-mv (keywordp :stream)) t) (deftest keywordp.4 (notnot-mv (keywordp ':stream)) t) (deftest keywordp.5 (keywordp nil) nil) (deftest keywordp.6 (notnot-mv (keywordp :nil)) t) (deftest keywordp.7 (keywordp '(:stream)) nil) (deftest keywordp.8 (keywordp "rest") nil) (deftest keywordp.9 (keywordp ":rest") nil) (deftest keywordp.10 (keywordp '&body) nil) ;;; This next test was busted. ::foo is not portable syntax ;;(deftest keywordp.11 (notnot-mv (keywordp ::foo)) t) (deftest keywordp.12 (keywordp t) nil) (deftest keywordp.order.1 (let ((i 0)) (values (keywordp (progn (incf i) nil)) i)) nil 1) (deftest keywordp.error.1 (classify-error (keywordp)) program-error) (deftest keywordp.error.2 (classify-error (keywordp :x :x)) program-error) (deftest keywordp.error.3 (classify-error (keywordp)) program-error) (deftest keywordp.error.4 (classify-error (keywordp nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; symbol-name (deftest symbol-name.1 (symbol-name '|ABCD|) "ABCD") (deftest symbol-name.2 (symbol-name '|1234abcdABCD|) "1234abcdABCD") (deftest symbol-name.3 (classify-error (symbol-name 1)) type-error) (deftest symbol-name.4 (classify-error (symbol-name '(a))) type-error) (deftest symbol-name.5 (classify-error (symbol-name "ABCDE")) type-error) (deftest symbol-name.6 (classify-error (symbol-name 12913.0213)) type-error) (deftest symbol-name.7 (symbol-name :|abcdefg|) "abcdefg") (deftest symbol-name.error.1 (classify-error (symbol-name)) program-error) (deftest symbol-name.error.2 (classify-error (symbol-name 'a 'b)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-symbol (deftest make-symbol.1 (notnot-mv (symbolp (make-symbol "FOO"))) t) (deftest make-symbol.2 (symbol-package (make-symbol "BAR")) nil) (deftest make-symbol.3 (symbol-package (make-symbol "CL::FOO")) nil) (deftest make-symbol.4 (symbol-package (make-symbol "CL:FOO")) nil) (deftest make-symbol.5 (symbol-name (make-symbol "xyz")) "xyz") (deftest make-symbol.6 (eqt (make-symbol "A") (make-symbol "A")) nil) (deftest make-symbol.7 (boundp (make-symbol "B")) nil) (deftest make-symbol.8 (symbol-plist (make-symbol "C")) nil) (deftest make-symbol.9 (fboundp (make-symbol "D")) nil) (deftest make-symbol.10 (symbol-name (make-symbol "")) "") (deftest make-symbol.order.1 (let ((i 0)) (values (symbol-name (make-symbol (progn (incf i) "ABC"))) i)) "ABC" 1) (deftest make-symbol.error.1 (classify-error (make-symbol nil)) type-error) (deftest make-symbol.error.2 (classify-error (make-symbol 'a)) type-error) (deftest make-symbol.error.3 (classify-error (make-symbol 1)) type-error) (deftest make-symbol.error.4 (classify-error (make-symbol -1)) type-error) (deftest make-symbol.error.5 (classify-error (make-symbol 1.213)) type-error) (deftest make-symbol.error.6 (classify-error (make-symbol -1312.2)) type-error) (deftest make-symbol.error.7 (classify-error (make-symbol #\w)) type-error) (deftest make-symbol.error.8 (classify-error (make-symbol '(a))) type-error) (deftest make-symbol.error.9 (classify-error (make-symbol)) program-error) (deftest make-symbol.error.10 (classify-error (make-symbol "a" "a")) program-error) (deftest make-symbol.error.11 (classify-error (make-symbol '(#\a #\b #\c))) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-symbol (deftest copy-symbol.1 (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x))) (and (null (symbol-plist y)) (symbolp y) (not (boundp y)) (not (fboundp y)) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) (symbolp (copy-symbol y)) ))) '(nil t a b |a| |123|))) t) (deftest copy-symbol.2 (progn (setf (symbol-plist '|foo|) '(a b c d)) (makunbound '|foo|) (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x t))) (and (equal (symbol-plist y) (symbol-plist x)) (symbolp y) (if (boundp x) (boundp y) (not (boundp y))) (if (fboundp x) (fboundp y) (not (fboundp y))) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) ))) '(nil t a b |foo| |a| |123|)))) t) (deftest copy-symbol.3 (progn (setf (symbol-plist '|foo|) '(a b c d)) (setf (symbol-value '|a|) 12345) (notnot-mv (every #'(lambda (x) (let ((y (copy-symbol x t))) (and (eql (length (symbol-plist y)) (length (symbol-plist x))) ;; Is a list copy (every #'eq (symbol-plist y) (symbol-plist x)) (symbolp y) (if (boundp x) (eqt (symbol-value x) (symbol-value y)) (not (boundp y))) (if (fboundp x) (fboundp y) (not (fboundp y))) (null (symbol-package y)) (string= (symbol-name x) (symbol-name y)) (eql (length (symbol-plist x)) (length (symbol-plist y))) ))) '(nil t a b |foo| |a| |123|)))) t) (deftest copy-symbol.4 (eqt (copy-symbol 'a) (copy-symbol 'a)) nil) (deftest copy-symbol.5 (let ((i 0) x y (s '#:|x|)) (let ((s2 (copy-symbol (progn (setf x (incf i)) s) (progn (setf y (incf i)) nil)))) (values (symbol-name s2) (eq s s2) i x y))) "x" nil 2 1 2) (deftest copy-symbol.error.1 (classify-error (copy-symbol)) program-error) (deftest copy-symbol.error.2 (classify-error (copy-symbol 'a t 'foo)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; gensym ;;; Gensym returns unique symbols (deftest gensym.1 (equal (gensym) (gensym)) nil) ;;; Gensym returns symbols with distinct print names (deftest gensym.2 (string= (symbol-name (gensym)) (symbol-name (gensym))) nil) ;;; Gensym uses the *gensym-counter* special variable, ;;; but does not increment it until after the symbol ;;; has been created. (deftest gensym.3 (let ((*gensym-counter* 1)) (declare (special *gensym-counter*)) (symbol-name (gensym))) #.(string '#:g1)) ;;; Gensym uses the string argument instead of the default (deftest gensym.4 (let ((*gensym-counter* 1327)) (declare (special *gensym-counter*)) (symbol-name (gensym "FOO"))) "FOO1327") ;;; The symbol returned by gensym should be unbound (deftest gensym.5 (boundp (gensym)) nil) ;;; The symbol returned by gensym should have no function binding (deftest gensym.6 (fboundp (gensym)) nil) ;;; The symbol returned by gensym should have no property list (deftest gensym.7 (symbol-plist (gensym)) nil) ;;; The symbol returned by gensym should be uninterned (deftest gensym.8 (symbol-package (gensym)) nil) ;;; *gensym-counter* is incremented by gensym (deftest gensym.9 (let ((*gensym-counter* 12345)) (declare (special *gensym-counter*)) (gensym) *gensym-counter*) 12346) ;;; Gensym works when *gensym-counter* is Really Big ;;; (and does not increment the counter until after creating ;;; the symbol.) (deftest gensym.10 (let ((*gensym-counter* 1234567890123456789012345678901234567890)) (declare (special *gensym-counter*)) (symbol-name (gensym))) #.(string '#:g1234567890123456789012345678901234567890)) ;;; gensym increments Really Big values of *gensym-counter* (deftest gensym.11 (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) (declare (special *gensym-counter*)) (gensym) *gensym-counter*) 12345678901234567890123456789012345678901234567891) ;;; Gensym uses an integer argument instead of the counter (deftest gensym.12 (let ((*gensym-counter* 10)) (declare (special *gensym-counter*)) (symbol-name (gensym 123))) #.(string '#:g123)) ;;; When given an integer argument, gensym does not increment the ;;; *gensym-counter* (deftest gensym.13 (let ((*gensym-counter* 10)) (declare (special *gensym-counter*)) (gensym 123) *gensym-counter*) 10) ;;; Check response to erroneous arguments ;;; Note! NIL is not the same as no argument ;;; gensym should be implemented so that its only ;;; argument defaults to "G", with NIL causing an error. (deftest gensym.error.1 (classify-error (gensym 'aaa)) type-error) (deftest gensym.error.2 (classify-error (gensym 12.3)) type-error) (deftest gensym.error.3 (classify-error (gensym t)) type-error) (deftest gensym.error.4 (classify-error (gensym nil)) type-error) ;; NIL /= no argument! (deftest gensym.error.5 (classify-error (gensym '(a))) type-error) (deftest gensym.error.6 (classify-error (gensym #\x)) type-error) (deftest gensym.error.7 (classify-error (gensym 10 'foo)) program-error) (deftest gensym.error.8 (classify-error (locally (gensym t) t)) type-error) ;;;;;;;;;;;;;;;;;;;; ;;; Tests of CL package constraints from section 11.1.2.1.1 ;;; Check that all symbols listed as 'functions' or 'accessors' ;;; are indeed functions. (deftest cl-function-symbols.1 (loop for s in (append *cl-function-symbols* *cl-accessor-symbols*) when (or (not (fboundp s)) (macro-function s) (special-operator-p s) (not (symbol-function s))) collect s) nil) ;;; Check that all symols listed as 'macros' are macros. (deftest cl-macro-symbols.1 (loop for s in *cl-macro-symbols* when (or (not (fboundp s)) (not (macro-function s))) collect s) nil) ;;; Check that all constants are indeed constant (deftest cl-constant-symbols.1 (loop for s in *cl-constant-symbols* when (or (not (boundp s)) (not (constantp s))) collect s) nil) ;;; Check that all global variables have values (deftest cl-variable-symbols.1 (loop for s in *cl-variable-symbols* when (not (boundp s)) collect s) nil) ;;; Check that all types that are classes name classes. ;;; "Many but not all of the predefined type specifiers have ;;; a corresponding class with the same proper name as the type. ;;; These type specifiers are listed in Figure 4-8." -- section 4.3.7 (deftest cl-types-that-are-classes.1 ;; Collect class names that violate the condition in the ;; above quotation. (loop for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) (deftest cl-types-that-are-classes.2 ;; The same as cl-types-that-are-classes.1 ;; with an environment argument (loop for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil nil) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) (deftest cl-types-that-are-classes.3 ;; The same as cl-types-that-are-classes.1, ;; with an environment argument (loop for s in *cl-types-that-are-classes-symbols* for c = (eval `(macrolet ((%foo (&environment env) (list 'quote (find-class ',s nil env)))) (%foo))) unless (and c (eq (class-name c) s) (typep c 'class)) collect s) nil) ;;; Various error cases for symbol-related functions (deftest symbolp.error.1 (classify-error (symbolp)) program-error) (deftest symbolp.error.2 (classify-error (symbolp nil nil)) program-error) (deftest symbol-function.error.1 (classify-error (symbol-function)) program-error) (deftest symbol-function.error.2 (classify-error (symbol-function 'cons nil)) program-error) (deftest symbol-package.error.1 (classify-error (symbol-package)) program-error) (deftest symbol-package.error.2 (classify-error (symbol-package 'cons nil)) program-error) (deftest symbol-plist.error.1 (classify-error (symbol-plist)) program-error) (deftest symbol-plist.error.2 (classify-error (symbol-plist 'cons nil)) program-error) (deftest symbol-value.error.1 (classify-error (symbol-value)) program-error) (deftest symbol-value.error.2 (classify-error (symbol-value '*package* nil)) program-error) gcl-2.6.14/ansi-tests/pathname-type.lsp0000644000175000017500000000352014360276512016361 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-TYPE (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-type.1 (loop for p in *pathnames* for type = (pathname-type p) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.2 (loop for p in *pathnames* for type = (pathname-type p :case :local) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.3 (loop for p in *pathnames* for type = (pathname-type p :case :common) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.4 (loop for p in *pathnames* for type = (pathname-type p :allow-other-keys nil) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.5 (loop for p in *pathnames* for type = (pathname-type p :foo 'bar :allow-other-keys t) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) (deftest pathname-type.6 (loop for p in *pathnames* for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp type) (member type '(nil :wild :unspecific))) collect (list p type)) nil) ;;; section 19.3.2.1 (deftest pathname-type.7 (loop for p in *logical-pathnames* when (eq (pathname-type p) :unspecific) collect p) nil) (deftest pathname-type.8 (do-special-strings (s "" nil) (pathname-type s)) nil) (deftest pathname-type.error.1 (signals-error (pathname-type) program-error) t) (deftest pathname-type.error.2 (check-type-error #'pathname-type #'could-be-pathname-designator) nil) gcl-2.6.14/ansi-tests/row-major-aref.lsp0000644000175000017500000000525714360276512016446 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 20:16:38 2003 ;;;; Contains: Tests of ROW-MAJOR-AREF (in-package :cl-test) ;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp) (deftest row-major-aref.1 (loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i)) (a b c d e f)) (deftest row-major-aref.2 (loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i)) (a b c d e f)) (deftest row-major-aref.3 (row-major-aref #0a100 0) 100) (deftest row-major-aref.4 (loop for i from 0 to 5 collect (row-major-aref #*011100 i)) (0 1 1 1 0 0)) (deftest row-major-aref.5 (loop for i from 0 to 5 collect (row-major-aref "abcdef" i)) (#\a #\b #\c #\d #\e #\f)) (deftest row-major-aref.6 (let ((a (make-array nil :initial-element 'x))) (values (aref a) (setf (row-major-aref a 0) 'y) (aref a) a)) x y y #0ay) (deftest row-major-aref.7 (let ((a (make-array '(4) :initial-element 'x))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) 'a) (setf (row-major-aref a 1) 'b) (setf (row-major-aref a 2) 'c) a)) x x x x a b c #(a b c x)) (deftest row-major-aref.8 (let ((a (make-array '(4) :element-type 'base-char :initial-element #\x))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) #\a) (setf (row-major-aref a 1) #\b) (setf (row-major-aref a 2) #\c) a)) #\x #\x #\x #\x #\a #\b #\c "abcx") (deftest row-major-aref.9 (let ((a (make-array '(4) :initial-element 0 :element-type 'bit))) (values (aref a 0) (aref a 1) (aref a 2) (aref a 3) (setf (row-major-aref a 0) 1) (setf (row-major-aref a 1) 1) (setf (row-major-aref a 3) 1) a)) 0 0 0 0 1 1 1 #*1101) (deftest row-major-aref.10 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d)(e f g h)(i j k l)) ((m n o p)(q r s t)(u v w x)))))) (loop for i from 0 to 23 collect (row-major-aref a i))) (a b c d e f g h i j k l m n o p q r s t u v w x)) (deftest row-major-aref.order.1 (let ((i 0) x y) (values (row-major-aref (progn (setf x (incf i)) #(a b c d e f)) (progn (setf y (incf i)) 2)) i x y)) c 2 1 2) (deftest row-major-aref.order.2 (let ((i 0) x y z (a (copy-seq #(a b c d e f)))) (values (setf (row-major-aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) (progn (setf z (incf i)) 'w)) a i x y z)) w #(a b w d e f) 3 1 2 3) ;;; Error tests (deftest row-major-aref.error.1 (classify-error (row-major-aref)) program-error) gcl-2.6.14/ansi-tests/constantp.lsp0000644000175000017500000000263314360276512015622 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 19:12:17 2003 ;;;; Contains: Tests for CONSTANTP ;;; See also defconstant.lsp (in-package :cl-test) (deftest constantp.error.1 (classify-error (constantp)) program-error) (deftest constantp.error.2 (classify-error (constantp nil nil nil)) program-error) (deftest constantp.1 (loop for e in *universe* when (and (not (symbolp e)) (not (consp e)) (not (constantp e))) collect e) nil) (deftest constantp.2 (notnot-mv (constantp t)) t) (deftest constantp.3 (notnot-mv (constantp nil)) t) (deftest constantp.4 (notnot-mv (constantp :foo)) t) (deftest constantp.5 (constantp (gensym)) nil) (defconstant constantp-test-symbol 1) (defmacro constantp-macro (form &environment env) (notnot-mv (constantp form env))) (deftest constantp.6 (constantp-macro constantp-test-symbol) t) (deftest constantp.7 (constantp '(incf x)) nil) (deftest constantp.8 (notnot-mv (constantp 1 nil)) t) (deftest constantp.9 (notnot-mv (constantp ''(((foo))))) t) (deftest constantp.10 (notnot-mv (constantp 'pi)) t) (deftest constantp.order.1 (let ((i 0)) (values (notnot (constantp (progn (incf i) 1))) i)) t 1) (deftest constantp.order.2 (let ((i 0) x y) (values (notnot (constantp (progn (setf x (incf i)) 1) (progn (setf y (incf i)) nil))) i x y)) t 2 1 2) gcl-2.6.14/ansi-tests/notevery.lsp0000644000175000017500000000541514360276512015465 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:20:12 2002 ;;;; Contains: Tests for NOTEVERY (in-package :cl-test) (deftest notevery.1 (notevery #'identity nil) nil) (deftest notevery.2 (notevery #'identity #()) nil) (deftest notevery.3 (let ((count 0)) (values (not (notevery #'(lambda (x) (incf count) (< x 10)) '(1 2 4 13 5 1))) count)) nil 4) (deftest notevery.4 (notevery #'= '(1 2 3 4) '(1 2 3 4 5)) nil) (deftest notevery.5 (notevery #'= '(1 2 3 4 5) '(1 2 3 4)) nil) (deftest notevery.6 (not-mv (notevery #'= '(1 2 3 4 5) '(1 2 3 4 6))) nil) (deftest notevery.7 (notevery #'(lambda (x y) (or x y)) '(nil t t nil t) #(t nil t t nil nil)) nil) (deftest notevery.8 (let ((x '(1)) (args nil)) (not (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (not (apply #'notevery #'= args))))) nil) (deftest notevery.9 (notevery #'zerop #*000000000000) nil) (deftest notevery.10 (notevery #'zerop #*) nil) (deftest notevery.11 (not-mv (notevery #'zerop #*0000010000)) nil) (deftest notevery.12 (notevery #'(lambda (x) (eql x #\a)) "aaaaaaaa") nil) (deftest notevery.13 (notevery #'(lambda (x) (eql x #\a)) "") nil) (deftest notevery.14 (not-mv (notevery #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")) nil) (deftest notevery.15 (not-mv (notevery 'null '(nil nil t nil))) nil) (deftest notevery.16 (notevery 'null '(nil nil nil nil)) nil) (deftest notevery.order.1 (let ((i 0) a b) (values (notevery (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(a b c d))) i a b)) nil 2 1 2) ;;; Error cases (deftest notevery.error.1 (classify-error (notevery 1 '(a b c))) type-error) (deftest notevery.error.2 (classify-error (notevery #\a '(a b c))) type-error) (deftest notevery.error.3 (classify-error (notevery #() '(a b c))) type-error) (deftest notevery.error.4 (classify-error (notevery #'null 'a)) type-error) (deftest notevery.error.5 (classify-error (notevery #'null 100)) type-error) (deftest notevery.error.6 (classify-error (notevery #'null 'a)) type-error) (deftest notevery.error.7 (classify-error (notevery #'eq () 'a)) type-error) (deftest notevery.error.8 (classify-error (notevery)) program-error) (deftest notevery.error.9 (classify-error (notevery #'null)) program-error) (deftest notevery.error.10 (classify-error (locally (notevery 1 '(a b c)) t)) type-error) (deftest notevery.error.11 (classify-error (notevery #'cons '(a b c))) program-error) (deftest notevery.error.12 (classify-error (notevery #'cons '(a b c) '(1 2 4) '(g h j))) program-error) (deftest notevery.error.13 (classify-error (notevery #'car '(a b c))) type-error)gcl-2.6.14/ansi-tests/rt-test.lsp0000644000175000017500000001553014360276512015213 0ustar cammcamm;-*-syntax:COMMON-LISP-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# ;This is the December 19, 1990 version of a set of tests that use the ;RT regression tester to test itself. See the documentation of RT for ;a discusion of how to use this file. (in-package :user) ;; (require "RT") (use-package :regression-test) (defmacro setup (&rest body) `(do-setup '(progn ., body))) (defun do-setup (form) (let ((*test* nil) (*do-tests-when-defined* nil) (regression-test::*entries* (list nil)) (regression-test::*in-test* nil) (regression-test::*debug* t) result) (deftest t1 4 4) (deftest (t 2) 4 3) (values-list (cons (normalize (with-output-to-string (*standard-output*) (setq result (multiple-value-list (catch 'regression-test::*debug* (eval form)))))) result)))) (defun normalize (string) (with-input-from-string (s string) (normalize-stream s))) (defvar *file-name* nil) (defun get-file-name () (loop (if *file-name* (return *file-name*)) (format *error-output* "~%Type a string representing naming of a scratch disk file: ") (setq *file-name* (read)) (if (not (stringp *file-name*)) (setq *file-name* nil)))) (get-file-name) (defmacro with-temporary-file (f &body forms) `(let ((,f *file-name*)) ,@ forms (get-file-output ,f))) (defun get-file-output (f) (prog1 (with-open-file (in f) (normalize-stream in)) (delete-file f))) (defun normalize-stream (s) (let ((l nil)) (loop (push (read-line s nil s) l) (when (eq (car l) s) (setq l (nreverse (cdr l))) (return nil))) (delete "" l :test #'equal))) (rem-all-tests) (deftest deftest-1 (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests))) ("Redefining test T1") (t1 3 3) t1 (t1 (t 2))) (deftest deftest-2 (setup (deftest (t 2) 3 3) (get-test '(t 2))) ("Redefining test (T 2)") ((t 2) 3 3)) (deftest deftest-3 (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests))) () (2 3 3) 2 (t1 (t 2) 2)) (deftest deftest-4 (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3))) ("Test (TEMP) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") (temp)) (deftest do-test-1 (setup (values (do-test 't1) *test* (pending-tests))) () t1 t1 ((t 2))) (deftest do-test-2 (setup (values (do-test '(t 2)) (pending-tests))) ("Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") nil (t1 (t 2))) (deftest do-test-3 (setup (let ((*test* 't1)) (do-test))) () t1) (deftest get-test-1 (setup (values (get-test 't1) *test*)) () (t1 4 4) (t 2)) (deftest get-test-2 (setup (get-test '(t 2))) () ((t 2) 4 3)) (deftest get-test-3 (setup (let ((*test* 't1)) (get-test))) () (t1 4 4)) (deftest get-test-4 (setup (deftest t3 1 1) (get-test)) () (t3 1 1)) (deftest get-test-5 (setup (get-test 't0)) ("No test with name T0.") nil) (deftest rem-test-1 (setup (values (rem-test 't1) (pending-tests))) () t1 ((t 2))) (deftest rem-test-2 (setup (values (rem-test '(t 2)) (pending-tests))) () (t 2) (t1)) (deftest rem-test-3 (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) () (t1)) (deftest rem-test-4 (setup (values (rem-test 't0) (pending-tests))) () nil (t1 (t 2))) (deftest rem-test-5 (setup (rem-all-tests) (rem-test 't0) (pending-tests)) () ()) (deftest rem-all-tests-1 (setup (values (rem-all-tests) (pending-tests))) () nil nil) (deftest rem-all-tests-2 (setup (rem-all-tests) (rem-all-tests) (pending-tests)) () nil) (deftest do-tests-1 (setup (let ((*print-case* :downcase)) (values (do-tests) (continue-testing) (do-tests)))) ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 1 pending test of 2 tests total." "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).") nil nil nil) (deftest do-tests-2 (setup (rem-test '(t 2)) (deftest (t 2) 3 3) (values (do-tests) (continue-testing) (do-tests))) ("Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed." "Doing 0 pending tests of 2 tests total." "No tests failed." "Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed.") t t t) (deftest do-tests-3 (setup (rem-all-tests) (values (do-tests) (continue-testing))) ("Doing 0 pending tests of 0 tests total." "No tests failed." "Doing 0 pending tests of 0 tests total." "No tests failed.") t t) (deftest do-tests-4 (setup (normalize (with-output-to-string (s) (do-tests s)))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest do-tests-5 (setup (with-temporary-file s (do-tests s))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest continue-testing-1 (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests)) () (t1 (t 2) temp)) gcl-2.6.14/ansi-tests/remove-duplicates-aux.lsp0000644000175000017500000000565114360276512020037 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 23 20:59:10 2002 ;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES (in-package :cl-test) (defun my-remove-duplicates (orig-sequence &key from-end test test-not (start 0) end key) (assert (typep orig-sequence 'sequence)) (let* ((sequence orig-sequence) (len (length sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (cond (test (assert (not test-not))) (test-not (setq test #'(lambda (x y) (not (funcall test x y))))) (t (setq test #'eql))) (assert (integerp start)) (assert (integerp end)) (assert (<= 0 start end len)) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (if from-end (psetq start (- len end) end (- len start) sequence (reverse sequence)) (setq sequence (copy-seq sequence))) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (assert (<= 0 start end len) (start end len)) (let ((result nil)) (loop for i from 0 below start do (push (elt sequence i) result)) (loop for i from start below end for x = (elt sequence i) for kx = (if key (funcall key x) x) unless (position kx sequence :start (1+ i) :end end :test test :key key) do (push x result)) (loop for i from end below len do (push (elt sequence i) result)) (unless from-end (setq result (reverse result))) (cond ((listp orig-sequence) result) ((arrayp orig-sequence) (make-array (length result) :initial-contents result :element-type (array-element-type orig-sequence))) (t (assert nil)))))) (defun make-random-rdup-params (maxlen) "Make random input parameters for REMOVE-DUPLICATES." (multiple-value-bind (element-type type len start end from-end count seq key test test-not) (make-random-rd-params maxlen) (declare (ignore count element-type)) (let ((arg-list (reduce #'nconc (random-permute (list (when start (list :start start)) (cond (end (list :end end)) ((coin) (list :end nil))) (cond (from-end (list :from-end from-end)) ((coin) (list :from-end nil))) (cond (key (list :key key)) ;; ((coin) (list :key nil)) ) (when test (list :test test)) (when test-not (list :test test-not))))))) (values seq arg-list)))) (defun random-test-remove-dups (maxlen &optional (pure t)) (multiple-value-bind (seq arg-list) (make-random-rdup-params maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if pure #'remove-duplicates #'delete-duplicates) seq1 arg-list)) (seq2r (apply #'my-remove-duplicates seq2 arg-list))) (cond ((and pure (not (equalp seq seq1))) :fail1) ((and pure (not (equalp seq seq2))) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t))))) gcl-2.6.14/ansi-tests/loop5.lsp0000644000175000017500000001001714360276512014642 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 2 13:52:50 2002 ;;;; Contains: Tests of LOOP clause FOR-AS-ACROSS (in-package :cl-test) (deftest loop.5.1 (let ((x "abcd")) (loop for e across x collect e)) (#\a #\b #\c #\d)) (deftest loop.5.2 (let ((x "abcd")) (loop for e across (the string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.3 (let ((x "abcd")) (loop for e across (the simple-string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.4 (loop for e across "abcd" collect e) (#\a #\b #\c #\d)) (deftest loop.5.5 (loop for e across "abcd" for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.6 (loop for e of-type base-char across "abcd" for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.7 (let ((x "abcd")) (loop for e across (the base-string x) collect e)) (#\a #\b #\c #\d)) (deftest loop.5.8 (let ((x "abcd")) (loop for e of-type character across x collect e)) (#\a #\b #\c #\d)) (deftest loop.5.10 (let ((x #*00010110)) (loop for e across x collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.11 (let ((x #*00010110)) (loop for e across (the bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.12 (let ((x #*00010110)) (loop for e across (the simple-bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.13 (let ((x #*00010110)) (loop for e of-type bit across (the simple-bit-vector x) collect e)) (0 0 0 1 0 1 1 0)) (deftest loop.5.14 (let ((x #*00010110)) (loop for e of-type bit across x for i from 1 to 4 collect e)) (0 0 0 1)) (deftest loop.5.20 (let ((x (vector 'a 'b 'c 'd))) (loop for e across x collect e)) (a b c d)) (deftest loop.5.21 (let ((x (vector 'a 'b 'c 'd))) (loop for e across (the vector x) collect e)) (a b c d)) (deftest loop.5.22 (let ((x (vector 'a 'b 'c 'd))) (loop for e across (the simple-vector x) collect e)) (a b c d)) (deftest loop.5.23 (let ((x (vector '(a) '(b) '(c) '(d)))) (loop for (e) across x collect e)) (a b c d)) (deftest loop.5.30 (let ((x (make-array '(5) :initial-contents '(a b c d e) :adjustable t))) (loop for e across x collect e)) (a b c d e)) (deftest loop.5.32 (let* ((x (make-array '(5) :initial-contents '(a b c d e))) (y (make-array '(3) :displaced-to x :displaced-index-offset 1))) (loop for e across y collect e)) (b c d)) ;;; tests of 'as' form (deftest loop.5.33 (loop as e across "abc" collect e) (#\a #\b #\c)) (deftest loop.5.34 (loop as e of-type character across "abc" collect e) (#\a #\b #\c)) (deftest loop.5.35 (loop as e of-type integer across (the simple-vector (coerce '(1 2 3) 'simple-vector)) sum e) 6) ;;; Loop across displaced vectors (deftest loop.5.36 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) (da (make-array '(5) :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (c d e f g)) (deftest loop.5.37 (let* ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij")) (da (make-array '(5) :element-type 'base-char :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (#\c #\d #\e #\f #\g)) (deftest loop.5.38 (let* ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 0 1 0 1 1 1))) (da (make-array '(5) :element-type 'bit :displaced-to a :displaced-index-offset 2))) (loop for e across da collect e)) (1 0 0 1 0)) ;;; Error cases (deftest loop.5.error.1 (classify-error (loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) program-error) (deftest loop.5.error.2 (classify-error (loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e)) program-error) (deftest loop.5.error.3 (classify-error* (macroexpand '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e))) program-error) (deftest loop.5.error.4 (classify-error* (macroexpand '(loop for e across (vector '(x . y) '(u . v)) for e from 1 to 5 collect e))) program-error) gcl-2.6.14/ansi-tests/some.lsp0000644000175000017500000000532214360276512014552 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:07:07 2002 ;;;; Contains: Tests for SOME (in-package :cl-test) (deftest some.1 (some #'identity nil) nil) (deftest some.2 (some #'identity #()) nil) (deftest some.3 (let ((count 0)) (values (some #'(lambda (x) (incf count) (if (>= x 10) x nil)) '(1 2 4 13 5 1)) count)) 13 4) (deftest some.4 (some #'/= '(1 2 3 4) '(1 2 3 4 5)) nil) (deftest some.5 (some #'/= '(1 2 3 4 5) '(1 2 3 4)) nil) (deftest some.6 (not-mv (some #'/= '(1 2 3 4 5) '(1 2 3 4 6))) nil) (deftest some.7 (some #'(lambda (x y) (and x y)) '(nil t t nil t) #(t nil nil t nil nil)) nil) (deftest some.8 (let ((x '(1)) (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'some #'/= args))) nil) (deftest some.9 (some #'zerop #*11111111111111) nil) (deftest some.10 (some #'zerop #*) nil) (deftest some.11 (not-mv (some #'zerop #*1111111011111)) nil) (deftest some.12 (some #'(lambda (x) (not (eql x #\a))) "aaaaaaaa") nil) (deftest some.13 (some #'(lambda (x) (eql x #\a)) "") nil) (deftest some.14 (not-mv (some #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa")) nil) (deftest some.15 (some 'null '(1 2 3 4)) nil) (deftest some.16 (not-mv (some 'null '(1 2 3 nil 5))) nil) (deftest some.order.1 (let ((i 0) x y) (values (some (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(a b c d))) i x y)) nil 2 1 2) (deftest some.order.2 (let ((i 0) x y z) (values (some (progn (setf x (incf i)) #'eq) (progn (setf y (incf i)) '(a b c d)) (progn (setf z (incf i)) '(e f g h))) i x y z)) nil 3 1 2 3) (deftest some.error.1 (classify-error (some 1 '(a b c))) type-error) (deftest some.error.2 (classify-error (some #\a '(a b c))) type-error) (deftest some.error.3 (classify-error (some #() '(a b c))) type-error) (deftest some.error.4 (classify-error (some #'null 'a)) type-error) (deftest some.error.5 (classify-error (some #'null 100)) type-error) (deftest some.error.6 (classify-error (some #'null 'a)) type-error) (deftest some.error.7 (classify-error (some #'eq () 'a)) type-error) (deftest some.error.8 (classify-error (some)) program-error) (deftest some.error.9 (classify-error (some #'null)) program-error) (deftest some.error.10 (classify-error (locally (some 1 '(a b c)) t)) type-error) (deftest some.error.11 (classify-error (some #'cons '(a b c))) program-error) (deftest some.error.12 (classify-error (some #'car '(a b c))) type-error) (deftest some.error.13 (classify-error (some #'cons '(a b c) '(b c d) '(c d e))) program-error) gcl-2.6.14/ansi-tests/subtypep.lsp0000644000175000017500000001075614360276512015471 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 29 17:28:19 2003 ;;;; Contains: Tests of SUBTYPEP (in-package :cl-test) ;;; More subtypep tests are in types-and-class.lsp (deftest subtypep.order.1 (let ((i 0) x y) (values (notnot (subtypep (progn (setf x (incf i)) t) (progn (setf y (incf i)) t))) i x y)) t 2 1 2) (deftest simple-base-string-is-sequence (subtypep* 'simple-base-string 'sequence) t t) (deftest subtype.env.1 (mapcar #'notnot (multiple-value-list (subtypep 'bit 'integer nil))) (t t)) (deftest subtype.env.2 (macrolet ((%foo (&environment env) (list 'quote (mapcar #'notnot (multiple-value-list (subtypep 'bit 'integer env)))))) (%foo)) (t t)) (deftest subtype.env.3 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep nil (type-of env)) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.4 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep (type-of env) (type-of env)) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.5 (macrolet ((%foo (&environment env) (multiple-value-bind (sub good) (subtypep (type-of env) t) (or (not good) (notnot sub))))) (%foo)) t) (deftest subtypep.error.1 (classify-error (subtypep)) program-error) (deftest subtypep.error.2 (classify-error (subtypep t)) program-error) (deftest subtypep.error.3 (classify-error (subtypep t t nil nil)) program-error) ;;; Special cases of types-6 that are/were causing problems in CMU CL (deftest keyword-is-subtype-of-atom (subtypep* 'keyword 'atom) t t) (deftest ratio-is-subtype-of-atom (subtypep* 'ratio 'atom) t t) (deftest extended-char-is-subtype-of-atom (subtypep* 'extended-char 'atom) t t) (deftest string-is-not-simple-vector (subtypep* 'string 'simple-vector) nil t) (deftest base-string-is-not-simple-vector (subtypep* 'base-string 'simple-vector) nil t) (deftest simple-string-is-not-simple-vector (subtypep* 'simple-string 'simple-vector) nil t) (deftest simple-base-string-is-not-simple-vector (subtypep* 'simple-base-string 'simple-vector) nil t) (deftest bit-vector-is-not-simple-vector (subtypep* 'bit-vector 'simple-vector) nil t) (deftest simple-bit-vector-is-not-simple-vector (subtypep* 'simple-bit-vector 'simple-vector) nil t) (deftest subtypep.extended-char.1 (if (subtypep* 'character 'base-char) (subtypep* 'extended-char nil) (values t t)) t t) (deftest subtypep.and/or.1 (check-equivalence '(and (or symbol (integer 0 15)) (or symbol (integer 10 25))) '(or symbol (integer 10 15))) nil) (deftest subtypep.and/or.2 (check-equivalence '(and (or (not symbol) (integer 0 10)) (or symbol (integer 11 25))) '(integer 11 25)) nil) (deftest subtypep.and.1 (loop for type in *types-list3* append (check-equivalence `(and ,type ,type) type)) nil) (deftest subtypep.or.1 (loop for type in *types-list3* append (check-equivalence `(or ,type ,type) type)) nil) (deftest subtypep.and.2 (check-equivalence t '(and)) nil) (deftest subtypep.or.2 (check-equivalence nil '(or)) nil) (deftest subtypep.and.3 (loop for type in *types-list3* append (check-equivalence `(and ,type) type)) nil) (deftest subtypep.or.3 (loop for type in *types-list3* append (check-equivalence `(or ,type) type)) nil) (deftest subtypep.and.4 (let* ((n (length *types-list3*)) (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 for tp1 = (aref a (random n)) for tp2 = (aref a (random n)) append (check-equivalence `(and ,tp1 ,tp2) `(and ,tp2 ,tp1))) 100)) nil) (deftest subtypep.or.4 (let* ((n (length *types-list3*)) (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 for tp1 = (aref a (random n)) for tp2 = (aref a (random n)) append (check-equivalence `(or ,tp1 ,tp2) `(or ,tp2 ,tp1))) 100)) nil) ;;; Check that types that are supposed to be nonempty are ;;; not subtypes of NIL (deftest subtypep.nil.1 (loop for (type) in *subtype-table* unless (member type '(nil extended-char)) append (check-all-not-subtypep type nil)) nil) (deftest subtypep.nil.2 (loop for (type) in *subtype-table* for class = (find-class type nil) unless (or (not class) (member type '(nil extended-char))) append (check-all-not-subtypep class nil)) nil) gcl-2.6.14/ansi-tests/cons-test-16.lsp0000644000175000017500000003761414360276512015763 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:41:13 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 16 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; acons (deftest acons.1 (let* ((x (copy-tree '((c . d) (e . f)))) (xcopy (make-scaffold-copy x)) (result (acons 'a 'b x))) (and (check-scaffold-copy x xcopy) (eqt (cdr result) x) result)) ((a . b) (c . d) (e . f))) (deftest acons.2 (acons 'a 'b nil) ((a . b))) (deftest acons.3 (acons 'a 'b 'c) ((a . b) . c)) (deftest acons.4 (acons '((a b)) '(((c d) e) f) '((1 . 2))) (( ((a b)) . (((c d) e) f)) (1 . 2))) (deftest acons.5 (acons "ancd" 1.143 nil) (("ancd" . 1.143))) (deftest acons.6 (acons #\R :foo :bar) ((#\R . :foo) . :bar)) (deftest acons.order.1 (let ((i 0) x y z) (values (acons (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) 'b) (progn (setf z (incf i)) '((c . d)))) i x y z)) ((a . b)(c . d)) 3 1 2 3) (deftest acons.error.1 (classify-error (acons)) program-error) (deftest acons.error.2 (classify-error (acons 'a)) program-error) (deftest acons.error.3 (classify-error (acons 'a 'b)) program-error) (deftest acons.error.4 (classify-error (acons 'a 'b 'c 'd)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc (deftest assoc.1 (assoc nil nil) nil) (deftest assoc.2 (assoc nil '(nil)) nil) (deftest assoc.3 (assoc nil '(nil (nil . 2) (a . b))) (nil . 2)) (deftest assoc.4 (assoc nil '((a . b) (c . d))) nil) (deftest assoc.5 (assoc 'a '((a . b))) (a . b)) (deftest assoc.6 (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) (a . d)) (deftest assoc.7 (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) (xcopy (make-scaffold-copy x)) (result (assoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) t) (deftest assoc.8 (assoc 1 '((0 . a) (1 . b) (2 . c))) (1 . b)) (deftest assoc.9 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3))) nil) (deftest assoc.10 (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) nil) (deftest assoc.11 (let ((x (list 'a 'b))) (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) ((a b) . d)) (deftest assoc.12 (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) :key #'(lambda (x) (char x 1))) ("aevgd" . 2)) (deftest assoc.13 (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) :key #'car) (nil . c)) (deftest assoc.14 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3)) :test #'equal) ("abc" . 2)) (deftest assoc.15 (assoc (copy-seq "abc") '((abc . 1) ("abc" . 2) ("abc" . 3)) :test #'equalp) ("abc" . 2)) (deftest assoc.16 (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) :test #'equal) ((a) b)) (deftest assoc.17 (assoc (copy-seq "abc") '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) :test-not (complement #'equalp)) ("abc" . 2)) (deftest assoc.18 (assoc 'a '((a . d)(b . c)) :test-not #'eq) (b . c)) (deftest assoc.19 (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) (b . c)) (deftest assoc.20 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test #'equal) ("A" . 6)) (deftest assoc.21 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) x)) :test #'equal) ("a" . 3)) (deftest assoc.22 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test-not (complement #'equal)) ("A" . 6)) (deftest assoc.23 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) :key #'(lambda (x) (and (stringp x) x)) :test-not (complement #'equal)) ("a" . 3)) ;; Check that it works when test returns a true value ;; other than T (deftest assoc.24 (assoc 'a '((b . 1) (a . 2) (c . 3)) :test #'(lambda (x y) (and (eqt x y) 'matched))) (a . 2)) ;; Check that the order of the arguments to test is correct (deftest assoc.25 (block fail (assoc 'a '((b . 1) (c . 2) (a . 3)) :test #'(lambda (x y) (unless (eqt x 'a) (return-from fail 'fail)) (eqt x y)))) (a . 3)) ;;; Order of argument evaluation (deftest assoc.order.1 (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) i x y)) (c . 3) 2 1 2) (deftest assoc.order.2 (let ((i 0) x y z) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :test (progn (setf z (incf i)) #'eq)) i x y z)) (c . 3) 3 1 2 3) (deftest assoc.order.3 (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :test #'eq) i x y)) (c . 3) 2 1 2) (deftest assoc.order.4 (let ((i 0) x y z w) (values (assoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (c . 3) 4 1 2 3 4) ;;; Keyword tests (deftest assoc.allow-other-keys.1 (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) (b . 2)) (deftest assoc.allow-other-keys.2 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) (b . 2)) (deftest assoc.allow-other-keys.3 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t :test-not #'eql) (a . 1)) (deftest assoc.allow-other-keys.4 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) (b . 2)) (deftest assoc.allow-other-keys.5 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) (b . 2)) (deftest assoc.keywords.6 (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) (b . 2)) (deftest assoc.keywords.7 (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) (b . 2)) (deftest assoc.error.1 (classify-error (assoc)) program-error) (deftest assoc.error.2 (classify-error (assoc nil)) program-error) (deftest assoc.error.3 (classify-error (assoc nil nil :bad t)) program-error) (deftest assoc.error.4 (classify-error (assoc nil nil :key)) program-error) (deftest assoc.error.5 (classify-error (assoc nil nil 1 1)) program-error) (deftest assoc.error.6 (classify-error (assoc nil nil :bad t :allow-other-keys nil)) program-error) (deftest assoc.error.7 (classify-error (assoc 'a '((a . b)) :test #'identity)) program-error) (deftest assoc.error.8 (classify-error (assoc 'a '((a . b)) :test-not #'identity)) program-error) (deftest assoc.error.9 (classify-error (assoc 'a '((a . b)) :key #'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc-if (deftest assoc-if.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (6 . c)) (deftest assoc-if.4 (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) (nil . e)) ;;; Order of argument evaluation (deftest assoc-if.order.1 (let ((i 0) x y) (values (assoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) (deftest assoc-if.order.2 (let ((i 0) x y z) (values (assoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4))) :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) ;;; Keyword tests (deftest assoc-if.allow-other-keys.1 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) (nil . 2)) (deftest assoc-if.allow-other-keys.2 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if.allow-other-keys.3 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if.allow-other-keys.4 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) (nil . 2)) (deftest assoc-if.allow-other-keys.5 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) (nil . 2)) (deftest assoc-if.keywords.6 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) (nil . 2)) (deftest assoc-if.keywords.7 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) (nil . 2)) ;;; Error cases (deftest assoc-if.error.1 (classify-error (assoc-if)) program-error) (deftest assoc-if.error.2 (classify-error (assoc-if #'null)) program-error) (deftest assoc-if.error.3 (classify-error (assoc-if #'null nil :bad t)) program-error) (deftest assoc-if.error.4 (classify-error (assoc-if #'null nil :key)) program-error) (deftest assoc-if.error.5 (classify-error (assoc-if #'null nil 1 1)) program-error) (deftest assoc-if.error.6 (classify-error (assoc-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest assoc-if.error.7 (classify-error (assoc-if #'cons '((a b)(c d)))) program-error) (deftest assoc-if.error.8 (classify-error (assoc-if #'identity '((a b)(c d)) :key #'cons)) program-error) (deftest assoc-if.error.9 (classify-error (assoc-if #'car '((a b)(c d)))) type-error) (deftest assoc-if.error.10 (classify-error (assoc-if #'identity '((a b)(c d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; assoc-if-not (deftest assoc-if-not.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if-not.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (6 . c)) (deftest assoc-if-not.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (6 . c)) (deftest assoc-if-not.4 (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) (nil . e)) ;;; Order of argument evaluation tests (deftest assoc-if-not.order.1 (let ((i 0) x y) (values (assoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) (deftest assoc-if-not.order.2 (let ((i 0) x y z) (values (assoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((a . 1) (b . 2) (nil . 17) (d . 4))) :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) ;;; Keyword tests (deftest assoc-if-not.allow-other-keys.1 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.2 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.3 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if-not.allow-other-keys.4 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.5 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) (nil . 2)) (deftest assoc-if-not.keywords.6 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) (nil . 2)) (deftest assoc-if-not.keywords.7 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) (nil . 2)) ;;; Error tests (deftest assoc-if-not.error.1 (classify-error (assoc-if-not)) program-error) (deftest assoc-if-not.error.2 (classify-error (assoc-if-not #'null)) program-error) (deftest assoc-if-not.error.3 (classify-error (assoc-if-not #'null nil :bad t)) program-error) (deftest assoc-if-not.error.4 (classify-error (assoc-if-not #'null nil :key)) program-error) (deftest assoc-if-not.error.5 (classify-error (assoc-if-not #'null nil 1 1)) program-error) (deftest assoc-if-not.error.6 (classify-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest assoc-if-not.error.7 (classify-error (assoc-if-not #'cons '((a b)(c d)))) program-error) (deftest assoc-if-not.error.8 (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)) program-error) (deftest assoc-if-not.error.9 (classify-error (assoc-if-not #'car '((a b)(c d)))) type-error) (deftest assoc-if-not.error.10 (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-alist (deftest copy-alist-1 (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) ("foo" . "bar") (#\w . 1.234) (1/3 . 4123.4d5)))) (xcopy (make-scaffold-copy x)) (result (copy-alist x))) (and (check-scaffold-copy x xcopy) (= (length x) (length result)) (every #'(lambda (p1 p2) (or (and (null p1) (null p2)) (and (not (eqt p1 p2)) (eqt (car p1) (car p2)) (eqt (cdr p1) (cdr p2))))) x result) t)) t) (deftest copy-alist.error.1 (classify-error (copy-alist)) program-error) (deftest copy-alist.error.2 (classify-error (copy-alist nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pairlis ;; Pairlis has two legal behaviors: the pairs ;; can be prepended in the same order, or in the ;; reverse order, that they appear in the first ;; two arguments (defun my-pairlis (x y &optional alist) (if (null x) alist (acons (car x) (car y) (my-pairlis (cdr x) (cdr y) alist)))) (deftest pairlis-1 (pairlis nil nil nil) nil) (deftest pairlis-2 (pairlis '(a) '(b) nil) ((a . b))) (deftest pairlis-3 (let* ((x (copy-list '(a b c d e))) (xcopy (make-scaffold-copy x)) (y (copy-list '(1 2 3 4 5))) (ycopy (make-scaffold-copy y)) (result (pairlis x y)) (expected (my-pairlis x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (or (equal result expected) (equal result (reverse expected))) t)) t) (deftest pairlis-4 (let* ((x (copy-list '(a b c d e))) (xcopy (make-scaffold-copy x)) (y (copy-list '(1 2 3 4 5))) (ycopy (make-scaffold-copy y)) (z '((x . 10) (y . 20))) (zcopy (make-scaffold-copy z)) (result (pairlis x y z)) (expected (my-pairlis x y z))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (check-scaffold-copy z zcopy) (eqt (cdr (cddr (cddr result))) z) (or (equal result expected) (equal result (append (reverse (subseq expected 0 5)) (subseq expected 5)))) t)) t) (deftest pairlis.error.1 (classify-error (pairlis)) program-error) (deftest pairlis.error.2 (classify-error (pairlis nil)) program-error) (deftest pairlis.error.3 (classify-error (pairlis nil nil nil nil)) program-error) gcl-2.6.14/ansi-tests/cons-test-13.lsp0000644000175000017500000001470714360276512015756 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:57 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 13 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member (deftest member.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) (result (member 'c x))) (and (eqt result (cddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.2 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) (result (member 'e x))) (and (eqt result (cddddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7))) (xcopy (make-scaffold-copy x)) (result (member 4 x))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.4 (let* ((x (copy-tree '(2 4 6 8 10 12))) (xcopy (make-scaffold-copy x)) (result (member 9 x :key #'1+))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) t) (deftest member.5 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member '(c d) x :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.6 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.7 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test #'eq))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.8 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test-not (complement #'eq)))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.9 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member 'c x :key #'car :test #'eql))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.10 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) (xcopy (make-scaffold-copy x)) (result (member (list 'd) x :key #'cdr :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) t) (deftest member.11 (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))) nil) (deftest member.12 (member 1 (copy-tree '(3 4 1 31 423))) (1 31 423)) (deftest member.13 (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) :test #'equal) ("cc" "dd" "ee")) (deftest member.14 (member 'a nil) nil) (deftest member.15 (member nil nil) nil) (deftest member.16 (member nil nil :test #'equal) nil) (deftest member.16-a (member nil nil :test #'(lambda (x y) (error "Should not call this function"))) nil) (deftest member.17 (member 'a nil :test #'(lambda (x y) (error "Should not call this function"))) nil) ;; Check that a null key argument is ignored (deftest member.18 (member 'a '(c d a b e) :key nil) (a b e)) (deftest member.19 (member 'z '(a b c d) :key nil) nil) ;;; Order of evaluation (deftest member.order.1 (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d))) i x y)) (c d) 2 1 2) (deftest member.order.2 (let ((i 0) x y z p) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf p (incf i)) #'eq)) i x y z p)) (c d) 4 1 2 3 4) (deftest member.order.3 (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :test #'eq) i x y)) (c d) 2 1 2) (deftest member.order.4 (let ((i 0) x y z p q) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf p (incf i)) #'eq) :key (progn (setf q (incf i)) (constantly 'z))) i x y z p q)) (c d) 5 1 2 3 4 5) (deftest member.order.5 (let ((i 0) x y z q) (values (member (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '(a b c d)) :test #'eq :key (progn (setf z (incf i)) #'identity) :key (progn (setf q (incf i)) (constantly 'z))) i x y z q)) (c d) 4 1 2 3 4) ;;; Keyword tests (deftest member.allow-other-keys.1 (member 'b '(a b c) :bad t :allow-other-keys t) (b c)) (deftest member.allow-other-keys.2 (member 'b '(a b c) :allow-other-keys t :bad t) (b c)) (deftest member.allow-other-keys.3 (member 'b '(a b c) :allow-other-keys t) (b c)) (deftest member.allow-other-keys.4 (member 'b '(a b c) :allow-other-keys nil) (b c)) (deftest member.allow-other-keys.5 (member 'b '(a b c) :allow-other-keys 17 :allow-other-keys nil '#:x t) (b c)) (deftest member.keywords.6 (member 'b '(a b c) :test #'eq :test (complement #'eq)) (b c)) ;;; Error cases (deftest member.error.1 (classify-error (member 'a 'b)) type-error) (deftest member.error.2 (classify-error (member 'a 1.3)) type-error) (deftest member.error.3 (classify-error (member 'a 1)) type-error) (deftest member.error.4 (classify-error (member 'a 0)) type-error) (deftest member.error.5 (classify-error (member 'a "abcde")) type-error) (deftest member.error.6 (classify-error (member 'a #\w)) type-error) (deftest member.error.7 (classify-error (member 'a t)) type-error) (deftest member.error.8 (classify-error (member)) program-error) (deftest member.error.9 (classify-error (member nil)) program-error) (deftest member.error.10 (classify-error (member nil nil :bad t)) program-error) (deftest member.error.11 (classify-error (member nil nil :test)) program-error) (deftest member.error.12 (classify-error (member nil nil :bad t :allow-other-keys nil)) program-error) (deftest member.error.13 (classify-error (member nil nil nil)) program-error) (deftest member.error.14 (classify-error (locally (member 'a t) t)) type-error) (deftest member.error.15 (classify-error (member 'a '(a b c) :test #'identity)) program-error) (deftest member.error.16 (classify-error (member 'a '(a b c) :test-not #'identity)) program-error) (deftest member.error.17 (classify-error (member 'a '(a b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/array-in-bounds-p.lsp0000644000175000017500000001007214360276512017054 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 19:57:29 2003 ;;;; Contains: Tests for ARRAY-IN-BOUNDS-P (in-package :cl-test) (deftest array-in-bounds-p.1 (array-in-bounds-p #() 0) nil) (deftest array-in-bounds-p.2 (array-in-bounds-p #() -1) nil) (deftest array-in-bounds-p.3 (let ((a #(a b c d))) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) (deftest array-in-bounds-p.4 (notnot (array-in-bounds-p #0aNIL)) t) (deftest array-in-bounds-p.5 (array-in-bounds-p "" 0) nil) (deftest array-in-bounds-p.6 (array-in-bounds-p "" -1) nil) (deftest array-in-bounds-p.7 (let ((a "abcd")) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) (deftest array-in-bounds-p.8 (array-in-bounds-p #* 0) nil) (deftest array-in-bounds-p.9 (array-in-bounds-p #* -1) nil) (deftest array-in-bounds-p.10 (let ((a #*0110)) (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) (t t t t nil)) ;; Fill pointer tests (deftest array-in-bounds-p.11 (let ((a (make-array '(10) :fill-pointer 5))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.12 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.13 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.14 (let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) (nil t t t t t t t t t t nil)) ;;; Displaced arrays (deftest array-in-bounds-p.15 (let* ((a1 (make-array '(20))) (a2 (make-array '(10) :displaced-to a1))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.16 (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.17 (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) ;;; Multidimensional arrays (deftest array-in-bounds-p.18 (let ((a (make-array '(3 4)))) (loop for i from -1 to 3 collect (loop for j from -1 to 4 collect (notnot (array-in-bounds-p a i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) (nil t t t t nil) (nil nil nil nil nil nil))) (deftest array-in-bounds-p.19 (let ((a (make-array '(1 3 4) :adjustable t))) (loop for i from -1 to 3 collect (loop for j from -1 to 4 collect (notnot (array-in-bounds-p a 0 i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) (nil t t t t nil) (nil nil nil nil nil nil))) ;;; Very large indices (deftest array-in-bounds-p.20 (array-in-bounds-p #(a b c) (1+ most-positive-fixnum)) nil) (deftest array-in-bounds-p.21 (array-in-bounds-p #(a b c) (1- most-negative-fixnum)) nil) (deftest array-in-bounds-p.22 (array-in-bounds-p #(a b c) 1000000000000000000) nil) (deftest array-in-bounds-p.23 (array-in-bounds-p #(a b c) -1000000000000000000) nil) ;;; Order of evaluation tests (deftest array-in-bounds-p.order.1 (let ((x 0) y z) (values (array-in-bounds-p (progn (setf y (incf x)) #()) (progn (setf z (incf x)) 10)) x y z)) nil 2 1 2) ;;; Error tests (deftest array-in-bounds-p.error.1 (classify-error (array-in-bounds-p)) program-error) gcl-2.6.14/ansi-tests/copy-seq.lsp0000644000175000017500000000763214360276512015355 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 2 21:38:08 2002 ;;;; Contains: Tests for COPY-SEQ (in-package :cl-test) ;;; This function is extensively used elsewhere, but is tested again ;;; here for completeness. (deftest copy-seq.1 (copy-seq nil) nil) (deftest copy-seq.2 (let* ((s1 '(a b c)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (equalt s1 s2))) t) (deftest copy-seq.3 (let* ((s1 #(a b c)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) s2)) #(a b c)) (deftest copy-seq.4 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-vector-p s2) s2)) #(a b c d)) (deftest copy-seq.5 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-vector-p s2) s2)) #(a b c)) (deftest copy-seq.6 (let* ((a1 (make-array '(6) :initial-contents '(a b c d e f))) (a2 (make-array '(4) :displaced-to a1 :displaced-index-offset 1)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-vector-p s2) s2)) #(b c d e)) (deftest copy-seq.7 (let* ((s1 (make-array '(4) :element-type 'base-char :initial-contents '(#\a #\b #\c #\d) :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-string-p s2) s2)) "abcd") (deftest copy-seq.8 (let* ((s1 (make-array '(4) :element-type 'base-char :initial-contents '(#\a #\b #\c #\d) :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-string-p s2) s2)) "abc") (deftest copy-seq.9 (let* ((a1 (make-array '(6) :initial-contents '(#\a #\b #\c #\d #\e #\f) :element-type 'base-char)) (a2 (make-array '(4) :displaced-to a1 :element-type 'base-char :displaced-index-offset 1)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-string-p s2) s2)) "bcde") (deftest copy-seq.10 (let*((s1 "abcd") (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) s2)) "abcd") (deftest copy-seq.11 (let* ((s1 #*0010110) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*0010110) (deftest copy-seq.12 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit :adjustable t)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*0010) (deftest copy-seq.13 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) :element-type 'bit :fill-pointer 3)) (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) (simple-bit-vector-p s2) s2)) #*001) (deftest copy-seq.14 (let* ((a1 (make-array '(6) :initial-contents '(0 0 1 0 1 1) :element-type 'bit)) (a2 (make-array '(4) :displaced-to a1 :displaced-index-offset 1 :element-type 'bit)) (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) (simple-bit-vector-p s2) s2)) #*0101) (deftest copy-seq.15 (copy-seq "") "") (deftest copy-seq.16 (copy-seq #*) #*) (deftest copy-seq.17 (copy-seq #()) #()) (deftest copy-seq.18 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) (y (check-values (copy-seq x)))) (equal-array x y)) t) (deftest copy-seq.order.1 (let ((i 0)) (values (copy-seq (progn (incf i) "abc")) i)) "abc" 1) ;;; Error tests (deftest copy-seq.error.1 (classify-error (copy-seq 10)) type-error) (deftest copy-seq.error.2 (classify-error (copy-seq 'a)) type-error) (deftest copy-seq.error.3 (classify-error (copy-seq 13.21)) type-error) (deftest copy-seq.error.4 (classify-error (copy-seq)) program-error) (deftest copy-seq.error.5 (classify-error (copy-seq "abc" 2 nil)) program-error) (deftest copy-seq.error.6 (classify-error (locally (copy-seq 10) t)) type-error) gcl-2.6.14/ansi-tests/cons-test-09.lsp0000644000175000017500000000733114360276512015756 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:36:30 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 9 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; butlast, nbutlast (deftest butlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 2))) (and (check-scaffold-copy x xcopy) result)))) (a b c)) (deftest butlast.2 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 0))) (and (check-scaffold-copy x xcopy) result)))) (a b c d e)) (deftest butlast.3 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 5))) (and (check-scaffold-copy x xcopy) result)))) nil) (deftest butlast.4 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 6))) (and (check-scaffold-copy x xcopy) result)))) nil) (deftest butlast.5 (butlast (copy-tree '(a b c . d)) 1) (a b)) (deftest butlast.order.1 (let ((i 0) x y) (values (butlast (progn (setf x (incf i)) (list 'a 'b 'c 'd 'e)) (progn (setf y (incf i)) 2)) i x y)) (a b c) 2 1 2) (deftest butlast.order.2 (let ((i 0)) (values (butlast (progn (incf i) '(a b c d))) i)) (a b c) 1) (deftest butlast.error.1 (classify-error (butlast (copy-tree '(a b c d)) 'a)) type-error) (deftest butlast.error.2 (classify-error (butlast 'a 0)) type-error) (deftest butlast.error.3 (classify-error (butlast)) program-error) (deftest butlast.error.4 (classify-error (butlast '(a b c) 3 3)) program-error) (deftest butlast.error.5 (classify-error (locally (butlast 'a 0) t)) type-error) ;;; Tests of NBUTLAST (deftest nbutlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (cdr x)) (z (cddr x))) (let ((result (nbutlast x 2))) (and (eqt x result) (eqt (cdr x) y) (eqt (cddr x) z) result)))) (a b c)) (deftest nbutlast.2 (let ((x (list 'a 'b 'c 'd 'e))) (let ((result (nbutlast x 5))) (list x result))) ((a b c d e) nil)) (deftest nbutlast.3 (let ((x (list 'a 'b 'c 'd 'e))) (let ((result (nbutlast x 500))) (list x result))) ((a b c d e) nil)) (deftest nbutlast.4 (let ((x (list* 'a 'b 'c 'd))) (let ((result (nbutlast x 1))) (and (eqt result x) result))) (a b)) (deftest nbutlast.5 (nbutlast nil) nil) (deftest nbutlast.6 (nbutlast (list 'a)) nil) (deftest nbutlast.order.1 (let ((i 0) x y) (values (nbutlast (progn (setf x (incf i)) (list 'a 'b 'c 'd 'e)) (progn (setf y (incf i)) 2)) i x y)) (a b c) 2 1 2) (deftest nbutlast.order.2 (let ((i 0)) (values (nbutlast (progn (incf i) (list 'a 'b 'c 'd))) i)) (a b c) 1) (deftest nbutlast.error.1 (classify-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a))) type-error) (deftest nbutlast.error.2 (classify-error (nbutlast 'a 10)) type-error) (deftest nbutlast.error.3 (classify-error (nbutlast 2 10)) type-error) (deftest nbutlast.error.4 (classify-error (nbutlast #\w 10)) type-error) (deftest nbutlast.error.5 (classify-error (nbutlast (list 'a 'b 'c 'd) -3)) type-error) (deftest nbutlast.error.6 (classify-error (nbutlast (list 'a) 20.0)) type-error) (deftest nbutlast.error.7 (classify-error (nbutlast (list 'a) -100.0)) type-error) (deftest nbutlast.error.8 (classify-error (nbutlast)) program-error) (deftest nbutlast.error.9 (classify-error (nbutlast (list 'a 'b 'c) 3 3)) program-error) (deftest nbutlast.error.10 (classify-error (locally (nbutlast 'a 10) t)) type-error) gcl-2.6.14/ansi-tests/cond.lsp0000644000175000017500000000172714360276512014537 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:37:58 2002 ;;;; Contains: Tests of COND (in-package :cl-test) (deftest cond.1 (cond) nil) (deftest cond.2 (cond ('a)) a) (deftest cond.3 (cond (nil)) nil) (deftest cond.4 (cond (nil 'a) (nil 'b)) nil) (deftest cond.5 (cond (nil 'a) ('b)) b) (deftest cond.6 (cond (t 'a) (t 'b)) a) (deftest cond.7 (let ((x 0)) (values (cond ((progn (incf x) nil) 'a) (t 'b) ((incf x) 'c)) x)) b 1) (deftest cond.8 (let ((x 0)) (values (cond (nil (incf x) 'a) (nil (incf x 10) 'b) (t (incf x 2) 'c) (t (incf x 100) 'd)) x)) c 2) (deftest cond.9 (cond ((values 'a 'b 'c))) a) (deftest cond.10 (cond (t (values 'a 'b 'c))) a b c) (deftest cond.11 (cond ((values nil t) 'a) (t 'b)) b) (deftest cond.12 (cond ((values))) nil) (deftest cond.13 (cond ((values)) (t 'a)) a) (deftest cond.14 (cond (t (values)))) gcl-2.6.14/ansi-tests/macrolet.lsp0000644000175000017500000000663114360276512015421 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 19:41:24 2002 ;;;; Contains: Tests of MACROLET (in-package :cl-test) (deftest macrolet.1 (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (%m y) (%m z))))) 1 3) (deftest macrolet.2 (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (setf (%m y) 6) (setf (%m z) 'a) y z)))) 6 a (6 2) (a 4)) ;;; Inner definitions shadow outer ones (deftest macrolet.3 (macrolet ((%m (w) `(cadr ,w))) (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) (values (%m y) (%m z) (setf (%m y) 6) (setf (%m z) 'a) y z))))) 1 3 6 a (6 2) (a 4)) ;;; &whole parameter (deftest macrolet.4 (let ((x nil)) (macrolet ((%m (&whole w arg) `(progn (setq x (quote ,w)) ,arg))) (values (%m 1) x))) 1 (%m 1)) ;;; &whole parameter (nested, destructuring; see section 3.4.4) (deftest macrolet.5 (let ((x nil)) (macrolet ((%m ((&whole w arg)) `(progn (setq x (quote ,w)) ,arg))) (values (%m (1)) x))) 1 (1)) ;;; key parameter (deftest macrolet.6 (let ((x nil)) (macrolet ((%m (&key (a 'xxx) b) `(setq x (quote ,a)))) (values (%m :a foo) x (%m :b bar) x))) foo foo xxx xxx) ;;; nested key parameters (deftest macrolet.7 (let ((x nil)) (macrolet ((%m ((&key a b)) `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) foo foo nil nil) ;;; nested key parameters (deftest macrolet.8 (let ((x nil)) (macrolet ((%m ((&key (a 10) b)) `(setq x (quote ,a)))) (values (%m (:a foo)) x (%m (:b bar)) x))) foo foo 10 10) ;;; keyword parameter with supplied-p parameter (deftest macrolet.9 (let ((x nil)) (macrolet ((%m (&key (a 'xxx a-p) b) `(setq x (quote ,(list a (not (not a-p))))))) (values (%m :a foo) x (%m :b bar) x))) (foo t) (foo t) (xxx nil) (xxx nil)) ;;; rest parameter (deftest macrolet.10 (let ((x nil)) (macrolet ((%m (b &rest a) `(setq x (quote ,a)))) (values (%m a1 a2) x))) (a2) (a2)) ;;; rest parameter w. destructuring (deftest macrolet.11 (let ((x nil)) (macrolet ((%m ((b &rest a)) `(setq x (quote ,a)))) (values (%m (a1 a2)) x))) (a2) (a2)) ;;; rest parameter w. whole (deftest macrolet.12 (let ((x nil)) (macrolet ((%m (&whole w b &rest a) `(setq x (quote ,(list a w))))) (values (%m a1 a2) x))) ((a2) (%m a1 a2)) ((a2) (%m a1 a2))) ;;; Interaction with symbol-macrolet (deftest macrolet.13 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) (let ((y (macroexpand x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) (deftest macrolet.14 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) (let ((y (macroexpand-1 x env))) (if (eq y 'a) 1 2)))) (foo a))) 2) (deftest macrolet.15 (macrolet ((nil () ''a)) (nil)) a) (deftest macrolet.16 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (macrolet ((,s () ''a)) (,s))) unless (eq (eval form) 'a) collect s) nil) ;;; Symbol-macrolet tests (deftest symbol-macrolet.1 (loop for s in *cl-non-variable-constant-symbols* for form = `(classify-error (symbol-macrolet ((,s 17)) ,s)) unless (eql (eval form) 17) collect s) nil) gcl-2.6.14/ansi-tests/apply.lsp0000644000175000017500000000212314360276512014730 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 15:13:07 2003 ;;;; Contains: Tests of APPLY (in-package :cl-test) ;;; Error cases (deftest apply.error.1 (classify-error (apply)) program-error) (deftest apply.error.2 (classify-error (apply #'cons)) program-error) (deftest apply.error.3 (classify-error (apply #'cons nil)) program-error) (deftest apply.error.4 (classify-error (apply #'cons (list 1 2 3))) program-error) ;;; Non-error cases (deftest apply.1 (apply #'cons 'a 'b nil) (a . b)) (deftest apply.2 (apply #'cons 'a '(b)) (a . b)) (deftest apply.3 (apply #'cons '(a b)) (a . b)) (deftest apply.4 (let ((zeros (make-list (min 10000 (1- call-arguments-limit)) :initial-element 1))) (apply #'+ zeros)) #.(min 10000 (1- call-arguments-limit))) (deftest apply.5 (apply 'cons '(a b)) (a . b)) (deftest apply.order.1 (let ((i 0) x y z) (values (apply (progn (setf x (incf i)) #'list) (progn (setf y (incf i)) 'b) (progn (setf z (incf i)) (list 'a))) i x y z)) (b a) 3 1 2 3) gcl-2.6.14/ansi-tests/compile.lsp0000644000175000017500000000404714360276512015242 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 20:54:20 2002 ;;;; Contains: Tests for COMPILE, COMPILED-FUNCTION-P, COMPILED-FUNCTION (in-package :cl-test) (deftest compile.1 (progn (fmakunbound 'compile.1-fn) (values (defun compile.1-fn (x) x) (compiled-function-p 'compile.1-fn) (let ((x (compile 'compile.1-fn))) (or (eqt x 'compile.1-fn) (notnot (compiled-function-p x)))) (compiled-function-p 'compile.1-fn) (not (compiled-function-p #'compile.1-fn)) (fmakunbound 'compile.1-fn))) compile.1-fn nil t nil nil compile.1-fn) ;;; COMPILE returns three values (function, warnings-p, failure-p) (deftest compile.2 (let* ((results (multiple-value-list (compile nil '(lambda (x y) (cons y x))))) (fn (car results))) (values (length results) (funcall fn 'a 'b) (second results) (third results))) 3 (b . a) nil nil) ;;; Compile does not coalesce literal constants (deftest compile.3 (let ((x (list 'a 'b)) (y (list 'a 'b))) (and (not (eqt x y)) (funcall (compile nil `(lambda () (eqt ',x ',y)))))) nil) (deftest compile.4 (let ((x (copy-seq "abc")) (y (copy-seq "abc"))) (and (not (eqt x y)) (funcall (compile nil `(lambda () (eqt ,x ,y)))))) nil) (deftest compile.5 (let ((x (copy-seq "abc"))) (funcall (compile nil `(lambda () (eqt ,x ,x))))) t) (deftest compile.6 (let ((x (copy-seq "abc"))) (funcall (compile nil `(lambda () (eqt ',x ',x))))) t) (deftest compile.7 (let ((x (copy-seq "abc"))) (eqt x (funcall (compile nil `(lambda () ,x))))) t) (deftest compile.8 (let ((x (list 'a 'b))) (eqt x (funcall (compile nil `(lambda () ',x))))) t) (deftest compile.9 (let ((i 0) a b) (values (funcall (compile (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(lambda () 'z)))) i a b)) z 2 1 2) (deftest compile.error.1 (classify-error (compile)) program-error) (deftest compile.error.2 (classify-error (compile nil '(lambda () nil) 'garbage)) program-error) gcl-2.6.14/ansi-tests/every.lsp0000644000175000017500000000553714360276512014751 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:25:58 2002 ;;;; Contains: Tests of EVERY (in-package :cl-test) (deftest every.1 (notnot-mv (every #'identity nil)) t) (deftest every.2 (notnot-mv (every #'identity #())) t) (deftest every.3 (let ((count 0)) (values (every #'(lambda (x) (incf count) (< x 10)) '(1 2 4 13 5 1)) count)) nil 4) (deftest every.4 (notnot-mv (every #'= '(1 2 3 4) '(1 2 3 4 5))) t) (deftest every.5 (notnot-mv (every #'= '(1 2 3 4 5) '(1 2 3 4))) t) (deftest every.6 (every #'= '(1 2 3 4 5) '(1 2 3 4 6)) nil) (deftest every.7 (notnot-mv (every #'(lambda (x y) (or x y)) '(nil t t nil t) #(t nil t t nil nil))) t) (deftest every.8 (let ((x '(1)) (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) do (push x args) always (apply #'every #'= args))) t) (deftest every.9 (notnot-mv (every #'zerop #*000000000000)) t) (deftest every.10 (notnot-mv (every #'zerop #*)) t) (deftest every.11 (every #'zerop #*0000010000) nil) (deftest every.12 (notnot-mv (every #'(lambda (x) (eql x #\a)) "aaaaaaaa")) t) (deftest every.13 (notnot-mv (every #'(lambda (x) (eql x #\a)) "")) t) (deftest every.14 (every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa") nil) (deftest every.15 (every 'null '(nil nil t nil)) nil) (deftest every.16 (notnot-mv (every 'null '(nil nil nil nil))) t) (deftest every.order.1 (let ((i 0) x y) (values (every (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '(nil nil a nil))) i x y)) nil 2 1 2) (deftest every.order.2 (let ((i 0) x y z) (values (every (progn (setf x (incf i)) #'equal) (progn (setf y (incf i)) '(nil nil a nil)) (progn (setf z (incf i)) '(nil nil a b))) i x y z)) nil 3 1 2 3) ;;; Error cases (deftest every.error.1 (classify-error (every 1 '(a b c))) type-error) (deftest every.error.2 (classify-error (every #\a '(a b c))) type-error) (deftest every.error.3 (classify-error (every #() '(a b c))) type-error) (deftest every.error.4 (classify-error (every #'null 'a)) type-error) (deftest every.error.5 (classify-error (every #'null 100)) type-error) (deftest every.error.6 (classify-error (every #'null 'a)) type-error) (deftest every.error.7 (classify-error (every #'eq () 'a)) type-error) ` (deftest every.error.8 (classify-error (every)) program-error) (deftest every.error.9 (classify-error (every #'null)) program-error) (deftest every.error.10 (classify-error (locally (every 1 '(a b c)) t)) type-error) (deftest every.error.11 (classify-error (every #'cons '(a b c))) program-error) (deftest every.error.12 (classify-error (every #'cons '(a b c) '(1 2 3) '(4 5 6))) program-error) (deftest every.error.13 (classify-error (every #'car '(a b c))) type-error) gcl-2.6.14/ansi-tests/cons-test-03.lsp0000644000175000017500000001465714360276512015761 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:32:20 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 3 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-list (deftest copy-list.1 (check-copy-list '(a b c d)) (a b c d)) ;; Check that copy-list works on dotted lists (deftest copy-list.2 (check-copy-list '(a . b)) (a . b)) (deftest copy-list.3 (check-copy-list '(a b c . d)) (a b c . d)) (deftest copy-list.4 (let ((i 0)) (values (copy-list (progn (incf i) '(a b c))) i)) (a b c) 1) (deftest copy-list.error.1 (classify-error (copy-list)) program-error) (deftest copy-list.error.2 (classify-error (copy-list nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list, list* (deftest list.1 (list 'a 'b 'c) (a b c)) (deftest list.2 (list) nil) (deftest list.order.1 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i))) (1 2 3 4)) (deftest list.order.2 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8)) (deftest list.order.3 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) (deftest list*.1 (list* 1 2 3) (1 2 . 3)) (deftest list*.2 (list* 'a) a) (deftest list-list*.1 (list* 'a 'b 'c (list 'd 'e 'f)) (a b c d e f)) (deftest list*.3 (list* 1) 1) (deftest list*.order.1 (let ((i 0)) (list* (incf i) (incf i) (incf i) (incf i))) (1 2 3 . 4)) (deftest list*.order.2 (let ((i 0)) (list* (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list-length (deftest list-length-nil (list-length nil) 0) (deftest list-length-list (list-length '(a b c d e f)) 6) ;; check that list-length returns nil ;; on a circular list (deftest list-length-circular-list (let ((x (cons nil nil))) (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) (setf (cdr x) y) (let ((z (list* 'a 'b 'c 'd 'e y))) (list-length z)))) nil) (deftest list-length.order.1 (let ((i 0)) (values (list-length (progn (incf i) '(a b c))) i)) 3 1) ;; Check that list-length produces a type-error ;; on arguments that are not proper lists or circular lists (deftest list-length.error.1 (loop for x in (list 'a 1 1.0 #\w (make-array '(10)) '(a b . c) (symbol-package 'cons)) count (not (eqt (catch-type-error (list-length x)) 'type-error))) 0) (deftest list-length.error.2 (classify-error (list-length)) program-error) (deftest list-length.error.3 (classify-error (list-length nil nil)) program-error) (deftest list-length.error.4 (classify-error (list-length 'a)) type-error) (deftest list-length.error.5 (classify-error (locally (list-length 'a) t)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; listp ;; Check listp against various simple cases (deftest listp-nil (notnot-mv (listp nil)) t) (deftest listp-symbol (listp 'a) nil) (deftest listp-singleton-list (notnot-mv (listp '(a))) t) (deftest listp-circular-list (let ((x (cons nil nil))) (setf (cdr x) x) (notnot-mv (listp x))) t) (deftest listp-longer-list (notnot-mv (listp '(a b c d e f g h))) t) ;;; Check that (listp x) == (typep x 'list) (deftest listp-universe (check-type-predicate 'listp 'list) 0) (deftest listp.order.1 (let ((i 0)) (values (listp (incf i)) i)) nil 1) (deftest listp.error.1 (classify-error (listp)) program-error) (deftest listp.error.2 (classify-error (listp nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (typep 'list) ;;; These tests are now somewhat redundant (deftest typep-nil-list (notnot-mv (typep nil 'list)) t) (deftest typep-symbol-list (typep 'a 'list) nil) (deftest typep-singleton-list-list (notnot-mv (typep '(a) 'list)) t) (deftest typep-circular-list-list (let ((x (cons nil nil))) (setf (cdr x) x) (notnot-mv (typep x 'list))) t) (deftest typep-longer-list-list (notnot-mv (typep '(a b c d e f g h) 'list)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-list (deftest make-list-empty.1 (make-list 0) nil) (deftest make-list-empty.2 (make-list 0 :initial-element 'a) nil) (deftest make-list-no-initial-element (make-list 6) (nil nil nil nil nil nil)) (deftest make-list-with-initial-element (make-list 6 :initial-element 'a) (a a a a a a)) (deftest make-list.allow-other-keys.1 (make-list 5 :allow-other-keys t :foo 'a) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.2 (make-list 5 :bar nil :allow-other-keys t) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.3 (make-list 5 :allow-other-keys nil) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.4 (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) (nil nil nil nil nil)) (deftest make-list.allow-other-keys.5 (make-list 5 :allow-other-keys t) (nil nil nil nil nil)) (deftest make-list-repeated-keyword (make-list 5 :initial-element 'a :initial-element 'b) (a a a a a)) (deftest make-list.order.1 (let ((i 0) x y) (values (make-list (progn (setf x (incf i)) 5) :initial-element (progn (setf y (incf i)) 'a)) i x y)) (a a a a a) 2 1 2) (deftest make-list.order.2 (let ((i 0) x y z) (values (make-list (progn (setf x (incf i)) 5) :initial-element (progn (setf y (incf i)) 'a) :initial-element (progn (setf z (incf i)) 'b)) i x y z)) (a a a a a) 3 1 2 3) (deftest make-list.error.1 (catch-type-error (make-list -1)) type-error) (deftest make-list.error.2 (classify-error (make-list 'a)) type-error) (deftest make-list.error.3 (classify-error (make-list)) program-error) (deftest make-list.error.4 (classify-error (make-list 5 :bad t)) program-error) (deftest make-list.error.5 (classify-error (make-list 5 :initial-element)) program-error) (deftest make-list.error.6 (classify-error (make-list 5 1 2)) program-error) (deftest make-list.error.7 (classify-error (make-list 5 :bad t :allow-other-keys nil)) program-error) (deftest make-list.error.8 (classify-error (locally (make-list 'a) t)) type-error) gcl-2.6.14/ansi-tests/write-string.lsp0000644000175000017500000000666414360276512016257 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 21:13:32 2004 ;;;; Contains: Tests of WRITE-STRING (in-package :cl-test) (deftest write-string.1 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "")))) result)) "" ("")) (deftest write-string.2 :notes (:nil-vectors-are-strings) (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string (make-array '(0) :element-type nil))))) result)) "" ("")) (deftest write-string.3 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "abcde")))) result)) "abcde" ("abcde")) (deftest write-string.4 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1)))) result)) "bcde" ("abcde")) (deftest write-string.5 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1 :end 3)))) result)) "bc" ("abcde")) (deftest write-string.6 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :start 1 :end nil)))) result)) "bcde" ("abcde")) (deftest write-string.7 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3)))) result)) "abc" ("abcde")) (deftest write-string.8 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :allow-other-keys nil)))) result)) "abc" ("abcde")) (deftest write-string.9 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) "abc" ("abcde")) (deftest write-string.10 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-string "abcde" s :end 3 :end 2)))) result)) "abc" ("abcde")) (deftest write-string.11 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-string "951" t) (close *terminal-io*)))) "951") (deftest write-string.12 (with-output-to-string (*standard-output*) (write-string "-=|!" nil)) "-=|!") ;;; Specialized string tests (deftest write-string.13 (let (result) (do-special-strings (s "abcde" nil) (assert (equal (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-string "abcde")))) "abcde")) (assert (equal result '("abcde"))))) nil) ;;; Error tests (deftest write-string.error.1 (signals-error (write-string) program-error) t) (deftest write-string.error.2 (signals-error (write-string "" *standard-output* :start) program-error) t) (deftest write-string.error.3 (signals-error (write-string "" *standard-output* :foo nil) program-error) t) (deftest write-string.error.4 (signals-error (write-string "" *standard-output* :allow-other-keys nil :foo nil) program-error) t) gcl-2.6.14/ansi-tests/progn.lsp0000644000175000017500000000106114360276512014730 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:33:51 2002 ;;;; Contains: Tests of PROGN (in-package :cl-test) (deftest progn.1 (progn) nil) (deftest progn.2 (progn 'a) a) (deftest progn.3 (progn 'b 'a) a) (deftest progn.4 (let ((x 0)) (values (progn (incf x) x) x)) 1 1) (deftest progn.5 (progn (values))) (deftest progn.6 (progn (values 1 2) (values 'a 'b 'c 'd 'e)) a b c d e) (deftest progn.7 (let ((x 0)) (prog () (progn (go x) x 'a) (return 'bad) x (return 'good))) good) gcl-2.6.14/ansi-tests/packages-14.lsp0000644000175000017500000001340314360276512015606 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:48 1998 ;;;; Contains: Package test code, part 14 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unuse-package (deftest unuse-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G"))) (i 0) x y) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (progn (setf x (incf i)) pg) (progn (setf y (incf i)) ph)) (eql i 2) (eql x 1) (eql y 2) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package "G" ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package :|G| ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package #\G ph)) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.5 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list pg) ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list "G") ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.7 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (unuse-package (list :|G|) ph) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) (deftest unuse-package.8 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use '("G")))) (prog1 (and (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package (list #\G) ph)) (equal (package-use-list ph) nil) (null (package-used-by-list pg))) (safely-delete-package "H") (safely-delete-package "G")))) t) ;; Now test with multiple packages (deftest unuse-package.9 (progn (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)) (let* ((pg1 (make-package "G1" :use nil)) (pg2 (make-package "G2" :use nil)) (pg3 (make-package "G3" :use nil)) (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) (let ((pubg1 (sort-package-list (package-used-by-list pg1))) (pubg2 (sort-package-list (package-used-by-list pg2))) (pubg3 (sort-package-list (package-used-by-list pg3))) (puh1 (sort-package-list (package-use-list ph1))) (puh2 (sort-package-list (package-use-list ph2)))) (prog1 (and (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) 5) (equal (list ph1 ph2) pubg1) (equal (list ph1 ph2) pubg2) (equal (list ph1 ph2) pubg3) (equal (list pg1 pg2 pg3) puh1) (equal (list pg1 pg2 pg3) puh2) (unuse-package (list pg1 pg3) ph1) (equal (package-use-list ph1) (list pg2)) (equal (package-used-by-list pg1) (list ph2)) (equal (package-used-by-list pg3) (list ph2)) (equal (sort-package-list (package-use-list ph2)) (list pg1 pg2 pg3)) (equal (sort-package-list (package-used-by-list pg2)) (list ph1 ph2)) t) (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)))))) t) (deftest unuse-package.error.1 (classify-error (unuse-package)) program-error) (deftest unuse-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use '("UPE2")) (classify-error (unuse-package "UPE2" "UPE2A" nil))) program-error) gcl-2.6.14/ansi-tests/simple-bit-vector.lsp0000644000175000017500000000267414360276512017163 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:12:07 2003 ;;;; Contains: Tests for type SIMPLE-BIT-VECTOR (in-package :cl-test) (deftest simple-bit-vector.2 (notnot-mv (typep #* 'simple-bit-vector)) t) (deftest simple-bit-vector.3 (notnot-mv (typep #*00101 'simple-bit-vector)) t) (deftest simple-bit-vector.4 (typep #(0 1 1 1 0 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.5 (typep "011100" 'simple-bit-vector) nil) (deftest simple-bit-vector.6 (typep 0 'simple-bit-vector) nil) (deftest simple-bit-vector.7 (typep 1 'simple-bit-vector) nil) (deftest simple-bit-vector.8 (typep nil 'simple-bit-vector) nil) (deftest simple-bit-vector.9 (typep 'x 'simple-bit-vector) nil) (deftest simple-bit-vector.10 (typep '(0 1 1 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) 'simple-bit-vector) nil) (deftest simple-bit-vector.12 (notnot-mv (typep #* '(simple-bit-vector *))) t) (deftest simple-bit-vector.13 (notnot-mv (typep #*01101 '(simple-bit-vector *))) t) (deftest simple-bit-vector.14 (notnot-mv (typep #* '(simple-bit-vector 0))) t) (deftest simple-bit-vector.15 (typep #*01101 '(simple-bit-vector 0)) nil) (deftest simple-bit-vector.16 (typep #* '(simple-bit-vector 5)) nil) (deftest simple-bit-vector.17 (notnot-mv (typep #*01101 '(simple-bit-vector 5))) t) gcl-2.6.14/ansi-tests/random-int-form.lsp0000644000175000017500000017712414360276512016632 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 10 18:03:52 2003 ;;;; Contains: Simple randon form generator/tester (in-package :cl-test) (compile-and-load "random-aux.lsp") ;;; ;;; This file contains a routine for generating random legal Common Lisp functions ;;; for differential testing. ;;; ;;; To run the random tests by themselves, start a lisp in the ansi-tests directory ;;; and do the following: ;;; (load "gclload1.lsp") ;;; (compile-and-load "random-int-form.lsp") ;;; (in-package :cl-test) ;;; (let ((*random-state* (make-random-state t))) ;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters ;;; ;;; If a test breaks during testing the variables *optimized-fn-src*, ;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source ;;; of the optimized/unoptimized lambda forms being compiled, and the arguments ;;; on which they are called. ;;; ;;; If a difference is found between optimized/unoptimized functions the forms, ;;; values, and results are collected. A list of all these discrepancies is returned ;;; after testing finishes (assuming nothing breaks). ;;; ;;; The variable *compile-unoptimized-form* controls whether the low optimization ;;; form is compiled, or if a form funcalling it is EVALed. The latter is often ;;; faster, and may find more problems since an interpreter and compiler may evaluate ;;; forms in very different ways. ;;; ;;; The rctest/ subdirectory contains fragments of a more OO random form generator ;;; that will eventually replace this preliminary effort. ;;; ;;; The file misc.lsp contains tests that were mostly for bugs found by this ;;; random tester in various Common Lisp implementations. ;;; (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* *opt-result* *unopt-result* $x $y $z *compile-unoptimized-form*)) ;;; Little functions used to run collected tests. ;;; (f i) runs the ith collected optimized test ;;; (g i) runs the ith collected unoptimized test ;;; (p i) prints the ith test (forms, input values, and other information) (defun f (i) (let ((plist (elt $y i))) (apply (compile nil (getf plist :optimized-lambda-form)) (getf plist :vals)))) (defun g (i) (let ((plist (elt $y i))) (if *compile-unoptimized-form* (apply (compile nil (getf plist :unoptimized-lambda-form)) (getf plist :vals)) (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) (getf plist :vals))))) (defun p (i) (write (elt $y i) :pretty t :escape t) (values)) (defun tn (n &optional (size 100)) (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) (declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) (defparameter *loop-random-int-form-period* 2000) ;;; Run the random tester, collecting failures into the special ;;; variable $y. (defun loop-random-int-forms (&optional (size 200) (nvars 3)) (unless (boundp '$x) (setq $x nil)) (unless (boundp '$y) (setq $y nil)) (loop for i from 1 do (format t "~6D | " i) (finish-output *standard-output*) (let ((x (test-random-integer-forms size nvars *loop-random-int-form-period* :index (* (1- i) *loop-random-int-form-period*)))) (when x (setq $x (append $x x)) (setq x (prune-results x)) (terpri) (print x) (finish-output *standard-output*) (setq $y (append $y x))) (terpri)))) (defvar *random-int-form-blocks* nil) (defvar *random-int-form-catch-tags* nil) (defvar *go-tags* nil) (defvar *maximum-random-int-bits* 45) (defvar *random-vals-list-bound* 10) (defvar *max-compile-time* 0) (defvar *max-compile-term* nil) (defvar *print-immediately* nil) (defvar *compile-unoptimized-form* #+(or allegro sbcl) t #-(or allegro sbcl) nil) (declaim (special *vars*)) (defstruct var-desc (name nil :type symbol) (type t)) (defun test-random-integer-forms (size nvars n &key ((:random-state *random-state*) (make-random-state t)) (file-prefix "b") (index 0) (random-size nil) (random-nvars nil) ) "Generate random integer forms of size SIZE with NVARS variables. Do this N times, returning all those on which a discrepancy is found between optimized and nonoptimize, notinlined code." (assert (integerp nvars)) (assert (<= 1 nvars 26)) (assert (and (integerp n) (plusp n))) (assert (and (integerp n) (plusp size))) ;;; #+sbcl ;;; (loop for x in (reverse sb-ext:*before-gc-hooks*) ;;; do (pushnew x sb-ext:*after-gc-hooks*)) (loop for i from 1 to n do (when (= (mod i 100) 0) ;; #+sbcl (print "Do gc...") ;; #+sbcl (sb-ext::gc :full t) (prin1 i) (princ " ") (finish-output *standard-output*)) nconc (let ((result (test-random-integer-form (if random-size (1+ (random size)) size) (if random-nvars (1+ (random nvars)) nvars) :index (+ index i) :file-prefix file-prefix))) (when result (let ((*print-readably* t)) (format t "~%~A~%" (format nil "~S" (car result))) (finish-output *standard-output*))) result))) (defun test-random-integer-form (size nvars &key (index 0) (file-prefix "b")) (let* ((vars (subseq '(a b c d e f g h i j k l m n o p q r s u v w x y z) 0 nvars)) (var-ranges (mapcar #'make-random-integer-range vars)) (var-types (mapcar #'(lambda (range) (let ((lo (car range)) (hi (cadr range))) (assert (>= hi lo)) `(integer ,lo ,hi))) var-ranges)) (form (let ((*vars* (loop for v in vars for tp in var-types collect (make-var-desc :name v :type tp))) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil) (*go-tags* nil) ) (make-random-integer-form (1+ (random size))))) (vals-list (loop repeat *random-vals-list-bound* collect (mapcar #'(lambda (range) (let ((lo (car range)) (hi (cadr range))) (random-from-interval (1+ hi) lo))) var-ranges))) (opt-decls-1 (make-random-optimize-settings)) (opt-decls-2 (make-random-optimize-settings))) (when *print-immediately* (with-open-file (s (format nil "~A~A.lsp" file-prefix index) :direction :output :if-exists :error) (print `(defparameter *x* '(:vars ,vars :var-types ,var-types :vals-list ,vals-list :decls1 ,opt-decls-1 :decls2 ,opt-decls-2 :form ,form)) s) (print '(load "c.lsp") s) (finish-output s)) ;; (cl-user::gc) (make-list 1000000) ;; try to trigger a gc ) (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) (defun make-random-optimize-settings () (loop for settings = (cons (list 'speed (1+ (random 3))) (loop for s in '(space safety debug compilation-speed) for n = (random 4) collect (list s n))) while #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) #-allegro nil finally (return settings))) (defun fn-symbols-in-form (form) "Return a list of the distinct standardized lisp function symbols occuring ing FORM. These are used to generate a NOTINLINE declaration for the unoptimized form." (intersection (remove-duplicates (fn-symbols-in-form* form) :test #'eq) *cl-function-or-accessor-symbols*)) (defun fn-symbols-in-form* (form) (when (consp form) (if (symbolp (car form)) (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) (mapcan #'fn-symbols-in-form* form)))) (defun make-random-integer-range (&optional var) "Generate a list (LO HI) of integers, LO <= HI. This is used for generating integer types." (declare (ignore var)) (rcase (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) (- (random r) (floor (/ r 2)))))) (let ((x (%r)) (y (%r))) (list (min x y) (max x y))))) (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) (b2 (floor (/ b 2)))) (let ((x (- (random b) b2)) (y (- (random b) b2))) (list (min x y) (max x y))))))) (defun fn-arg-name (fn-name arg-index) (intern (concatenate 'string (subseq (symbol-name fn-name) 1) (format nil "-~D" arg-index)) (symbol-package fn-name))) (declaim (special *flet-names*)) (defparameter *flet-names* nil) (defun make-random-integer () (let ((r (ash 1 (1+ (random 32))))) (- (random r) (floor (/ r 2))))) (defun random-var-desc () (loop (let* ((pos (random (length *vars*))) (desc (elt *vars* pos))) (when (= pos (position (var-desc-name desc) (the list *vars*) :key #'var-desc-name)) (return desc))))) (defun make-random-integer-form (size) "Generate a random legal lisp form of size SIZE (roughly)." (if (<= size 1) ;; Leaf node -- generate a variable, constant, or flet function call (loop when (rcase (10 (make-random-integer)) (9 (if *vars* (let* ((desc (random-var-desc)) (type (var-desc-type desc)) (name (var-desc-name desc))) (cond ((subtypep type 'integer) name) ((subtypep type '(array integer nil)) `(aref ,name)) ((subtypep type '(cons integer integer)) (rcase (1 `(car ,name)) (1 `(cdr ,name)))) (t nil))) nil)) (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) (2 (if *flet-names* (let* ((flet-entry (random-from-seq *flet-names*)) (flet-name (car flet-entry)) (flet-minargs (cadr flet-entry)) (flet-maxargs (caddr flet-entry)) (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) (args (loop repeat nargs collect (make-random-integer-form 1)))) `(,flet-name ,@args)) nil))) return it) ;; (> size 1) (rcase ;; flet call #-(or armedbear) (30 ;; 5 (make-random-integer-flet-call-form size)) ;; Unary ops (40 (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate rational rationalize numerator denominator identity progn floor #-(or armedbear) ignore-errors cl:handler-case restart-case ceiling truncate round realpart imagpart integer-length logcount values locally)))) `(,op ,(make-random-integer-form (1- size))))) #-(or armedbear) (4 (make-random-integer-unwind-protect-form size)) (5 (make-random-integer-mapping-form size)) ;; prog1, multiple-value-prog1 #-(or armedbear) (4 (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) (nforms (random 4)) (sizes (random-partition (1- size) (1+ nforms))) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args))) ;; prog2 (2 (let* ((nforms (random 4)) (sizes (random-partition (1- size) (+ nforms 2))) (args (mapcar #'make-random-integer-form sizes))) `(prog2 ,@args))) (2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) (2 `(the integer ,(make-random-integer-form (1- size)))) (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) (1 `(restart-bind nil ,(make-random-integer-form (1- size)))) (1 `(macrolet () ,(make-random-integer-form (1- size)))) ;; dotimes #-allegro (5 (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) (count (random 4)) (sizes (random-partition (1- size) 2)) (body (let ((*vars* (cons (make-var-desc :name var :type nil) *vars*))) (make-random-integer-form (first sizes)))) (ret-form (make-random-integer-form (second sizes)))) (unless (consp body) (setq body `(progn ,body))) `(dotimes (,var ,count ,ret-form) ,body))) ;; loop (5 (make-random-loop-form (1- size))) #-(or gcl ecl armedbear) ;; load-time-value (2 (let ((arg (let ((*flet-names* nil) (*vars* nil) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil) (*go-tags* nil)) (make-random-integer-form (1- size))))) (rcase (4 `(load-time-value ,arg t)) (2 `(load-time-value ,arg)) (2 `(load-time-value ,arg nil))))) ;; eval (2 (make-random-integer-eval-form size)) #-(or cmu allegro) (2 (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(ash ,(make-random-integer-form s1) (min ,(random 100) ,(make-random-integer-form s2))))) ;; binary floor, ceiling, truncate, round (4 (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) (op2 (random-from-seq #(max min)))) (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(,op ,(make-random-integer-form s1) (,op2 ,(if (eq op2 'max) (1+ (random 100)) (- (1+ (random 100)))) ,(make-random-integer-form s2)))))) ;; Binary op (30 (let* ((op (random-from-seq '(+ - * logand min max gcd lcm #-:allegro logandc1 logandc2 logeqv logior lognand lognor #-:allegro logorc1 logorc2 logxor )))) (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) (let ((e1 (make-random-integer-form leftsize)) (e2 (make-random-integer-form rightsize))) `(,op ,e1 ,e2))))) ;; boole (4 (let* ((op (random-from-seq #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) (destructuring-bind (leftsize rightsize) (random-partition (- size 2) 2) (let ((e1 (make-random-integer-form leftsize)) (e2 (make-random-integer-form rightsize))) `(boole ,op ,e1 ,e2))))) ;; n-ary ops (30 (let* ((op (random-from-seq #(+ - * logand min max logior lcm gcd logxor))) (nargs (1+ (min (random 10) (random 10) (random 10)))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form sizes))) `(,op ,@args))) ;; expt (3 `(expt ,(make-random-integer-form (1- size)) ,(random 3))) ;; coerce (2 `(coerce ,(make-random-integer-form (1- size)) 'integer)) ;; complex (degenerate case) (2 `(complex ,(make-random-integer-form (1- size)) 0)) ;; quotient (degenerate cases) (1 `(/ ,(make-random-integer-form (1- size)) 1)) (1 `(/ ,(make-random-integer-form (1- size)) -1)) ;; tagbody (5 (make-random-tagbody-and-progn size)) ;; conditionals (20 (let* ((cond-size (random (max 1 (floor size 2)))) (then-size (random (- size cond-size))) (else-size (- size 1 cond-size then-size)) (pred (make-random-pred-form cond-size)) (then-part (make-random-integer-form then-size)) (else-part (make-random-integer-form else-size))) `(if ,pred ,then-part ,else-part))) (5 (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) `(,(random-from-seq '(deposit-field dpb)) ,(make-random-integer-form s1) ,(make-random-byte-spec-form s2) ,(make-random-integer-form s3)))) #-:allegro (10 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(,(random-from-seq '(ldb mask-field)) ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (20 (make-random-integer-binding-form size)) ;; progv #-(or armedbear) (4 (make-random-integer-progv-form size)) (4 `(let () ,(make-random-integer-form (1- size)))) (10 (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) `(block ,name ,(make-random-integer-form (1- size))))) #-(or armedbear) (20 (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) `(catch ,tag ,(make-random-integer-form (1- size))))) (4 ;; setq and similar (make-random-integer-setq-form size)) (10 (make-random-integer-case-form size)) (3 (if *random-int-form-blocks* (let ((name (random-from-seq *random-int-form-blocks*)) (form (make-random-integer-form (1- size)))) `(return-from ,name ,form)) ;; No blocks -- try again (make-random-integer-form size))) (20 (if *random-int-form-catch-tags* (let ((tag (random-from-seq *random-int-form-catch-tags*)) (form (make-random-integer-form (1- size)))) `(throw ,tag ,form)) ;; No catch tags -- try again (make-random-integer-form size))) (5 (if *random-int-form-blocks* (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) (let ((name (random-from-seq *random-int-form-blocks*)) (pred (make-random-pred-form s1)) (then (make-random-integer-form s2)) (else (make-random-integer-form s3))) `(if ,pred (return-from ,name ,then) ,else))) ;; No blocks -- try again (make-random-integer-form size))) #-(or armedbear) (20 (make-random-flet-form size)) (2 (let* ((nbits (1+ (min (random 20) (random 20)))) (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) (op (random-from-seq #(bit sbit)))) `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))) (2 (let* ((nvals (1+ (min (random 20) (random 20)))) (lim (ash 1 (+ 3 (random 40)))) (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) (op (random-from-seq #(aref svref elt)))) `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) (2 (let* ((nvals (1+ (min (random 20) (random 20)))) (lim (ash 1 (+ 3 (random 40)))) (vals (loop repeat nvals collect (random lim))) (op 'elt)) `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) ))) (defun make-random-integer-flet-call-form (size) (if *flet-names* (let* ((flet-entry (random-from-seq *flet-names*)) (flet-name (car flet-entry)) (flet-minargs (cadr flet-entry)) (flet-maxargs (caddr flet-entry)) (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) ) (cond ((> nargs 0) (let* ((arg-sizes (random-partition (1- size) nargs)) (args (mapcar #'make-random-integer-form arg-sizes))) (rcase (1 `(,flet-name ,@args)) (1 `(multiple-value-call #',flet-name (values ,@args))) (1 `(funcall (function ,flet-name) ,@args)) (1 (let ((r (random (1+ (length args))))) `(apply (function ,flet-name) ,@(subseq args 0 r) (list ,@(subseq args r)))))))) (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-unwind-protect-form (size) (let* ((op 'unwind-protect) (nforms (random 4)) (sizes (random-partition (1- size) (1+ nforms))) (arg (make-random-integer-form (first sizes))) (unwind-forms ;; We have to be careful not to generate code that will ;; illegally transfer control to a dead location (let ((*flet-names* nil) (*go-tags* nil) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil)) (mapcar #'make-random-integer-form (rest sizes))))) `(,op ,arg ,@unwind-forms))) (defun make-random-integer-eval-form (size) (flet ((%arg (size) (let ((*flet-names* nil) (*vars* (remove-if-not #'(lambda (s) (member (var-desc-name s) '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*) :test #'eq)) *vars*)) (*random-int-form-blocks* nil) (*go-tags* nil)) (make-random-integer-form size)))) (rcase (2 `(eval ',(%arg (1- size)))) (2 (let* ((nargs (1+ (random 4))) (sizes (random-partition (1- size) nargs)) (args (mapcar #'%arg sizes))) `(eval (values ,@args)))) ))) (defun make-random-type-for-var (var e1) (let (desc) (values (cond ((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq) (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase (4 '(integer * *)) (2 (setq e1 `(make-array nil :initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) '(array integer nil)) (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) '(cons integer integer)) (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) '(cons integer integer))))) e1))) (defun make-random-integer-binding-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var (rcase (2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) (2 (random-from-seq #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))))) (e1 (make-random-integer-form s1)) (type (multiple-value-bind (type2 e) (make-random-type-for-var var e1) (setq e1 e) type2)) (e2 (let ((*vars* (cons (make-var-desc :name var :type type) *vars*))) (make-random-integer-form s2))) (op (random-from-seq #(let let*)))) ;; for now, avoid shadowing (if (member var *vars* :key #'var-desc-name) (make-random-integer-form size) (rcase (8 `(,op ((,var ,e1)) ,@(rcase (1 `((declare (dynamic-extent ,var)))) (1 nil)) ,e2)) (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (defun make-random-integer-progv-form (size) (let* ((num-vars (random 4)) (possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) (vars nil)) (loop repeat num-vars do (loop for r = (elt possible-vars (random (length possible-vars))) while (member r vars) finally (push r vars))) (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) (and desc (not (subtypep (var-desc-type desc) 'integer))))) vars) num-vars (length vars)) (if (null vars) `(progv nil nil ,(make-random-integer-form (1- size))) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var-sizes (random-partition s1 num-vars)) (var-forms (mapcar #'make-random-integer-form var-sizes)) (*vars* (append (loop for v in vars collect (make-var-desc :name v :type '(integer * *))) *vars*)) (body-form (make-random-integer-form s2))) `(progv ',vars (list ,@var-forms) ,body-form)))))) (defun make-random-integer-mapping-form (size) ;; reduce (let ((keyargs nil) (nargs (1+ (random (min 10 (max 1 size))))) (sequence-op (random-from-seq '(vector list)))) (when (coin 2) (setq keyargs '(:from-end t))) (cond ((coin 2) (let ((start (random nargs))) (setq keyargs `(:start ,start ,@keyargs)) (when (coin 2) (let ((end (+ start 1 (random (- nargs start))))) (setq keyargs `(:end ,end ,@keyargs)))))) (t (when (coin 2) (let ((end (1+ (random nargs)))) (setq keyargs `(:end ,end ,@keyargs)))))) (rcase (1 (let ((sizes (random-partition (1- size) nargs)) (op (random-from-seq #(+ - * logand logxor logior max min)))) `(reduce ,(rcase (1 `(function ,op)) (1 `(quote ,op))) (,sequence-op ,@(mapcar #'make-random-integer-form sizes)) ,@keyargs))) #-(or armedbear) (1 (destructuring-bind (size1 size2) (random-partition (1- size) 2) (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) (var1 (random-from-seq vars)) (var2 (random-from-seq (remove var1 vars))) (form (let ((*vars* (list* (make-var-desc :name var1 :type '(integer * *)) (make-var-desc :name var2 :type '(integer * *)) *vars*))) (make-random-integer-form size1))) (sizes (random-partition size2 nargs)) (args (mapcar #'make-random-integer-form sizes))) `(reduce (function (lambda (,var1 ,var2) ,form)) (,sequence-op ,@args) ,@keyargs))))))) (defun make-random-integer-setq-form (size) (if *vars* (let* ((vdesc (random-from-seq *vars*)) (var (var-desc-name vdesc)) (type (var-desc-type vdesc)) (op (random-from-seq #(setq setf #-(or armedbear)shiftf)))) (cond ((subtypep '(integer * *) type) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (coin 4) (setq op 'multiple-value-setq) (setq var (list var))) `(,op ,var ,(make-random-integer-form (1- size)))) ((and (consp type) (eq (car type) 'integer) (integerp (second type)) (integerp (third type))) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (coin 4) (setq op 'multiple-value-setq) (setq var (list var))) `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) ((and (subtypep '(array integer nil) type)) (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) (when (eq op 'setq) (setq op (random-from-seq #(setf shiftf)))) `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) ;; Abort -- can't assign (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-case-form (size) (let ((ncases (1+ (random 10)))) (if (< (+ size size) (+ ncases 2)) ;; Too small, give up (make-random-integer-form size) (let* ((sizes (random-partition (1- size) (+ ncases 2))) (bound (ash 1 (+ 2 (random 16)))) (lower-bound (if (coin 3) 0 (- bound))) (upper-bound (if (and (< lower-bound 0) (coin 3)) 1 (1+ bound))) (cases (loop for case-size in (cddr sizes) for vals = (loop repeat (1+ (min (random 10) (random 10))) collect (random-from-interval upper-bound lower-bound)) for result = (make-random-integer-form case-size) repeat ncases collect `(,vals ,result))) (expr (make-random-integer-form (first sizes)))) `(case ,expr ,@cases (t ,(make-random-integer-form (second sizes)))))))) (defun make-random-flet-form (size) "Generate random flet, labels forms, for now with no arguments and a single binding per form." (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) (if (assoc fname *flet-names*) ;; Fail if the name is in use (make-random-integer-form size) (let* ((op (random-from-seq #(flet labels))) (minargs (random 4)) (maxargs #+:allegro minargs #-:allegro (rcase (1 minargs) (1 (+ minargs (random 4))))) (keyarg-p (coin 2)) (keyarg-n (if keyarg-p (random 3) 0)) (arg-names (loop for i from 1 to maxargs collect (fn-arg-name fname i))) (key-arg-names (loop for i from 1 to keyarg-n collect (intern (format nil "KEY~A" i) (find-package "CL-TEST")))) (allow-other-keys (and keyarg-p (coin 3))) ) (destructuring-bind (s1 s2 . opt-sizes) (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))) (let* ((form1 ;; Allow return-from of the flet/labels function (let ((*random-int-form-blocks* (cons fname *random-int-form-blocks*)) (*vars* (nconc (loop for var in (append arg-names key-arg-names) collect (make-var-desc :name var :type '(integer * *))) *vars*))) (make-random-integer-form s1))) (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) *flet-names*))) (make-random-integer-form s2))) (opt-forms (mapcar #'make-random-integer-form opt-sizes))) (if opt-forms `(,op ((,fname (,@(subseq arg-names 0 minargs) &optional ,@(mapcar #'list (subseq arg-names minargs) opt-forms) ,@(when keyarg-p (append '(&key) (mapcar #'list key-arg-names (subseq opt-forms (- maxargs minargs))) (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) ,form2) `(,op ((,fname (,@arg-names ,@(when keyarg-p (append '(&key) (mapcar #'list key-arg-names opt-forms ) (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) ,form2)))))))) (defun make-random-tagbody (size) (let* ((num-forms (random 6)) (tags nil)) (loop for i below num-forms do (loop for tag = (rcase #-allegro (1 (random 8)) (1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8)))) while (member tag tags) finally (push tag tags))) (assert (= (length (remove-duplicates tags)) (length tags))) (let* ((*go-tags* (set-difference *go-tags* tags)) (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) (forms (loop for tag-list on tags for i below num-forms for size in sizes collect (let ((*go-tags* (append tag-list *go-tags*))) (make-random-integer-form size))))) `(tagbody ,@(loop for tag in tags for form in forms when (atom form) do (setq form `(progn ,form)) append `(,form ,tag)))))) (defun make-random-tagbody-and-progn (size) (let* ((final-size (random (max 1 (floor size 5)))) (tagbody-size (- size final-size))) (let ((final-form (make-random-integer-form final-size)) (tagbody-form (make-random-tagbody tagbody-size))) `(progn ,tagbody-form ,final-form)))) (defun make-random-pred-form (size) "Make a random form whose value is to be used as a generalized boolean." (if (<= size 1) (rcase (1 (if (coin) t nil)) (2 `(,(random-from-seq '(< <= = > >= /= eql equal)) ,(make-random-integer-form size) ,(make-random-integer-form size)))) (rcase (1 (if (coin) t nil)) (3 `(not ,(make-random-pred-form (1- size)))) (6 (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) `(,(random-from-seq '(and or)) ,(make-random-pred-form leftsize) ,(make-random-pred-form rightsize)))) (1 (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) `(,(random-from-seq '(< <= > >= = /= eql equal)) ,(make-random-integer-form leftsize) ,(make-random-integer-form rightsize)))) (3 (let* ((cond-size (random (max 1 (floor size 2)))) (then-size (random (- size cond-size))) (else-size (- size 1 cond-size then-size)) (pred (make-random-pred-form cond-size)) (then-part (make-random-pred-form then-size)) (else-part (make-random-pred-form else-size))) `(if ,pred ,then-part ,else-part))) (1 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(ldb-test ,(make-random-byte-spec-form s1) ,(make-random-integer-form s2)))) (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) (form (make-random-integer-form (1- size)))) `(logbitp ,index ,form))) (1 ;; typep form (let ((subform (make-random-integer-form (- size 2))) (type (rcase (1 `(integer ,@(make-random-integer-range))) (1 `(integer ,(make-random-integer))) (1 `(integer * ,(make-random-integer))) (1 `(integer))))) `(typep ,subform ',type))) ))) (defun make-random-loop-form (size) (if (<= size 2) (make-random-integer-form size) (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) (count (random 4)) (*vars* (cons (make-var-desc :name var :type nil) *vars*))) (rcase (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) )))) (defun make-random-byte-spec-form (size) (declare (ignore size)) (let* ((pform (random 33)) (sform (1+ (random 33)))) `(byte ,sform ,pform))) (defun make-random-element-of-type (type) "Create a random element of a lisp type." (cond ((consp type) (let ((type-op (first type))) (ecase type-op (integer (let ((lo (let ((lo (cadr type))) (cond ((consp lo) (1+ (car lo))) ((eq lo nil) '*) (t lo)))) (hi (let ((hi (caddr type))) (cond ((consp hi) (1- (car hi))) ((eq hi nil) '*) (t hi))))) (if (eq lo '*) (if (eq hi '*) (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval x (- x))) (random-from-interval (1+ hi) (- hi (random (ash 1 *maximum-random-int-bits*))))) (if (eq hi '*) (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) lo) ;; May generalize the next case to increase odds ;; of certain integers (near 0, near endpoints, near ;; powers of 2...) (random-from-interval (1+ hi) lo))))) (mod (let ((modulus (second type))) (assert (and (integerp modulus) (plusp modulus))) (make-random-element-of-type `(integer 0 (,modulus))))) (unsigned-byte (if (null (cdr type)) (make-random-element-of-type '(integer 0 *)) (let ((bits (second type))) (if (eq bits'*) (make-random-element-of-type '(integer 0 *)) (progn (assert (and (integerp bits) (>= bits 1))) (make-random-element-of-type `(integer 0 ,(1- (ash 1 bits))))))))) ))) (t (ecase type (bit (random 2)) (boolean (random-from-seq #(nil t))) (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car))) (unsigned-byte (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval (1+ x) (- x)))) )))) (defun make-optimized-lambda-form (form vars var-types opt-decls) `(lambda ,vars ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) var-types vars) (declare (ignorable ,@vars)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize ,@opt-decls)) ,form)) (defun make-unoptimized-lambda-form (form vars var-types opt-decls) (declare (ignore var-types)) `(lambda ,vars (declare (notinline ,@(fn-symbols-in-form form))) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize ,@opt-decls)) ,form)) (defvar *compile-using-defun* #-(or allegro lispworks) nil #+(or allegro lispworks) t) (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) (defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) ;; Try to compile FORM with associated VARS, and if it compiles ;; check for equality of the two compiled forms. ;; Return a non-nil list of details if a problem is found, ;; NIL otherwise. (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) (setq *int-form-vals* nil *optimized-fn-src* optimized-fn-src *unoptimized-fn-src* unoptimized-fn-src) (flet ((%compile (lambda-form opt-defun-name) (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning) (error #'(lambda (c) (format t "Compilation failure~%~A~%" (format nil "~S" form)) (finish-output *standard-output*) (return-from test-int-form (list (list :vars vars :form form :var-types var-types :vals (first vals-list) :lambda-form lambda-form :decls1 opt-decls-1 :decls2 opt-decls-2 :compiler-condition (with-output-to-string (s) (prin1 c s)))))))) (let ((start-time (get-universal-time))) (prog1 (if *compile-using-defun* (progn (eval `(defun ,opt-defun-name ,@(cdr lambda-form))) (compile opt-defun-name) (symbol-function opt-defun-name)) (compile nil lambda-form)) (let* ((stop-time (get-universal-time)) (total-time (- stop-time start-time))) (when (> total-time *max-compile-time*) (setf *max-compile-time* total-time) (setf *max-compile-term* lambda-form))) ;; #+:ecl (si:gc t) ))))) (let ((optimized-compiled-fn (%compile optimized-fn-src *name-to-use-in-optimized-defun*)) (unoptimized-compiled-fn (if *compile-unoptimized-form* (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) (eval `(function ,unoptimized-fn-src))))) (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) (dolist (vals vals-list) (setq *int-form-vals* vals) (flet ((%eval-error (kind) (let ((*print-circle* t)) (format t "~A~%" (format nil "~S" form))) (finish-output *standard-output*) (return (list (list :vars vars :vals vals :form form :var-types var-types :decls1 opt-decls-1 :decls2 opt-decls-2 :optimized-lambda-form optimized-fn-src :unoptimized-lambda-form unoptimized-fn-src :kind kind))))) (let ((unopt-result (cl:handler-case (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list (apply unoptimized-compiled-fn vals))) ((or error serious-condition) (c) (%eval-error (list :unoptimized-form-error (with-output-to-string (s) (prin1 c s))))))) (opt-result (cl:handler-case (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list (apply optimized-compiled-fn vals))) ((or error serious-condition) (c) (%eval-error (list :optimized-form-error (with-output-to-string (s) (prin1 c s)))))))) (if (equal opt-result unopt-result) nil (progn (format t "Different results: ~A, ~A~%" opt-result unopt-result) (setq *opt-result* opt-result *unopt-result* unopt-result) (%eval-error (list :different-results opt-result unopt-result))))))))))) ;;; Interface to the form pruner (declaim (special *prune-table*)) (defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) "Conduct tests on selected simplified versions of INPUT-FORM. Return the minimal form that still causes some kind of failure." (loop do (let ((form input-form)) (flet ((%try-fn (new-form) (when (test-int-form new-form vars var-types vals-list opt-decls-1 opt-decls-2) (setf form new-form) (throw 'success nil)))) (let ((*prune-table* (make-hash-table :test #'eq))) (loop (catch 'success (prune form #'%try-fn) (return form))))) (when (equal form input-form) (return form)) (setq input-form form)))) (defun prune-results (result-list) "Given a list of test results, prune their forms down to a minimal set." (loop for result in result-list collect (let* ((form (getf result :form)) (vars (getf result :vars)) (var-types (getf result :var-types)) (vals-list (list (getf result :vals))) (opt-decl-1 (getf result :decls1)) (opt-decl-2 (getf result :decls2)) (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) (optimized-lambda-form (make-optimized-lambda-form pruned-form vars var-types opt-decl-1)) (unoptimized-lambda-form (make-unoptimized-lambda-form pruned-form vars var-types opt-decl-2))) `(:vars ,vars :var-types ,var-types :vals ,(first vals-list) :form ,pruned-form :decls1 ,opt-decl-1 :decls2 ,opt-decl-2 :optimized-lambda-form ,optimized-lambda-form :unoptimized-lambda-form ,unoptimized-lambda-form)))) ;;; ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form ;;; so that it still satisfies TRY-FN. The function TRY-FN should ;;; return if the substitution is a failure. Otherwise, it should ;;; transfer control elsewhere via GO, THROW, etc. ;;; ;;; The return value of PRUNE should be ignored. ;;; (defun prune (form try-fn) (declare (type function try-fn)) (when (gethash form *prune-table*) (return-from prune nil)) (flet ((try (x) (funcall try-fn x))) (cond ((keywordp form) nil) ((integerp form) (unless (zerop form) (try 0))) ((consp form) (let* ((op (car form)) (args (cdr form)) (nargs (length args))) (case op ((quote) nil) ((go) (try 0)) ((signum integer-length logcount logandc1 logandc2 lognand lognor logorc1 logorc2 realpart imagpart) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((make-array) (when (and (eq (car args) nil) (eq (cadr args) ':initial-element) ; (null (cdddr args)) ) (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) (when (cdddr args) (try `(make-array nil :initial-element ,(caddr args)))) )) ((cons) (prune-fn form try-fn)) ((dotimes) (try 0) (let* ((binding-form (first args)) (body (rest args)) (var (first binding-form)) (count-form (second binding-form)) (result (third binding-form))) (try result) (unless (eql count-form 0) (try `(dotimes (,var 0 ,result) ,@body))) (prune result #'(lambda (form) (try `(dotimes (,var ,count-form ,form) ,@body)))) (when (= (length body) 1) (prune (first body) #'(lambda (form) (when (consp form) (try `(dotimes (,var ,count-form ,result) ,form)))))))) ((abs 1+ 1-) (try 0) (mapc try-fn args) (prune-fn form try-fn)) ((identity values ignore-errors cl:handler-case restart-case locally) (unless (and (consp args) (consp (car args)) (eql (caar args) 'tagbody)) (mapc try-fn args)) (prune-fn form try-fn)) ((boole) (try (second args)) (try (third args)) (prune (second args) #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) (prune (third args) #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) ((unwind-protect prog1 multiple-value-prog1) (try (first args)) (let ((val (first args)) (rest (rest args))) (when rest (try `(unwind-protect ,val)) (when (cdr rest) (loop for i from 0 below (length rest) do (try `(unwind-protect ,val ,@(subseq rest 0 i) ,@(subseq rest (1+ i)))))))) (prune-fn form try-fn)) ((prog2) (assert (>= (length args) 2)) (let ((val1 (first args)) (arg2 (second args)) (rest (cddr args))) (try arg2) (prune-fn form try-fn) (when rest (try `(prog2 ,val1 ,arg2)) (when (cdr rest) (loop for i from 0 below (length rest) do (try `(prog2 ,val1 ,arg2 ,@(subseq rest 0 i) ,@(subseq rest (1+ i))))))))) ((typep) (try (car args)) (prune (car args) #'(lambda (form) `(,op ,form ,@(cdr args))))) ((load-time-value) (let ((arg (first args))) (try arg) (cond ((cdr args) (try `(load-time-value ,arg)) (prune arg #'(lambda (form) (try `(load-time-value ,form ,(second args)))))) (t (prune arg #'(lambda (form) (try `(load-time-value ,form)))))))) ((eval) (try 0) (let ((arg (first args))) (cond ((consp arg) (cond ((eql (car arg) 'quote) (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) (t (try arg) (prune arg #'(lambda (form) `(eval ,form)))))) (t (try arg))))) ((the macrolet cl:handler-bind restart-bind) (assert (= (length args) 2)) (try (second args)) (prune (second args) try-fn)) ((not eq eql equal) (when (every #'constantp args) (try (eval form))) (try t) (try nil) (mapc try-fn args) (prune-fn form try-fn) ) ((and or = < > <= >= /=) (when (every #'constantp args) (try (eval form))) (try t) (try nil) (mapc try-fn args) (prune-nary-fn form try-fn) (prune-fn form try-fn)) ((- + * min max logand logior logxor logeqv gcd lcm) (when (every #'constantp args) (try (eval form))) (try 0) (mapc try-fn args) (prune-nary-fn form try-fn) (prune-fn form try-fn)) ((/) (when (every #'constantp args) (try (eval form))) (try 0) (try (car args)) (when (cddr args) (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) ((multiple-value-call) ;; Simplify usual case (when (= nargs 2) (destructuring-bind (arg1 arg2) args (when (and (consp arg1) (consp arg2) (eql (first arg1) 'function) (eql (first arg2) 'values)) (mapc try-fn (rest arg2)) (let ((fn (second arg1))) (when (symbolp fn) (try `(,fn ,@(rest arg2))))) ;; Prune the VALUES form (prune-list (rest arg2) #'prune #'(lambda (args) (try `(multiple-value-call ,arg1 (values ,@args))))) ))) (mapc try-fn (rest args))) ((bit sbit elt aref svref) (try 0) (when (= (length args) 2) (let ((arg1 (car args)) (arg2 (cadr args))) (when (and (consp arg2) (eql (car arg2) 'min) (integerp (cadr arg2))) (let ((arg2.2 (caddr arg2))) (when (and (consp arg2.2) (eql (car arg2.2) 'max) (integerp (cadr arg2.2))) (prune (caddr arg2.2) #'(lambda (form) (try `(,op ,arg1 (min ,(cadr arg2) (max ,(cadr arg2.2) ,form)))))))))))) ((car cdr) (try 0) (try 1)) ((if) (let (;; (pred (first args)) (then (second args)) (else (third args))) (try then) (try else) (when (every #'constantp args) (try (eval form))) (prune-fn form try-fn))) ((setq setf shiftf) (try 0) ;; Assumes only one assignment (assert (= (length form) 3)) (try (second args)) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((multiple-value-setq) (try 0) ;; Assumes only one assignment, and one variable (assert (= (length form) 3)) (assert (= (length (first args)) 1)) (try `(setq ,(caar args) ,(cadr args))) (unless (integerp (second args)) (prune (second args) #'(lambda (form) (try `(,op ,(first args) ,form)))))) ((byte) (prune-fn form try-fn)) ((deposit-field dpb) (try 0) (destructuring-bind (a1 a2 a3) args (try a1) (try a3) (when (and (integerp a1) (integerp a3) (and (consp a2) (eq (first a2) 'byte) (integerp (second a2)) (integerp (third a2)))) (try (eval form)))) (prune-fn form try-fn)) ((ldb mask-field) (try 0) (try (second args)) (when (and (consp (first args)) (eq 'byte (first (first args))) (every #'numberp (cdr (first args))) (numberp (second args))) (try (eval form))) (prune-fn form try-fn)) ((ldb-test) (try t) (try nil) (prune-fn form try-fn)) ((let let*) (prune-let form try-fn)) ((multiple-value-bind) (assert (= (length args) 3)) (let ((arg1 (first args)) (arg2 (second args)) (body (caddr args))) (when (= (length arg1) 1) (try `(let ((,(first arg1) ,arg2)) ,body))) (prune arg2 #'(lambda (form) (try `(multiple-value-bind ,arg1 ,form ,body)))) (prune body #'(lambda (form) (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) ((block) (let ((name (second form)) (body (cddr form))) (when (and body (null (cdr body))) (let ((form1 (first body))) ;; Try removing the block entirely if it is not in use (when (not (find-in-tree name body)) (try form1)) ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block (return-from )) (when (and (consp form1) (eq (first form1) 'return-from) (eq (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) (try `(block ,name ,x)))))))) ((catch) (let* ((tag (second form)) (name (if (consp tag) (cadr tag) tag)) (body (cddr form))) (when (and body (null (cdr body))) (let ((form1 (first body))) ;; Try removing the catch entirely if it is not in use ;; We make assumptions here about what throws can ;; be present. (when (or (not (find-in-tree 'throw body)) (not (find-in-tree name body))) (try form1)) ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block (return-from )) (when (and (consp form1) (eq (first form1) 'throw) (equal (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) (try `(catch ,tag ,x)))))))) ((throw) (try (second args)) (prune (second args) #'(lambda (x) (try `(throw ,(first args) ,x))))) ((flet labels) (try 0) (prune-flet form try-fn)) ((case) (prune-case form try-fn)) ((isqrt) (let ((arg (second form))) (assert (null (cddr form))) (assert (consp arg)) (assert (eq (first arg) 'abs)) (let ((arg2 (second arg))) (try arg2) ;; Try to fold (when (integerp arg2) (try (isqrt (abs arg2)))) ;; Otherwise, simplify arg2 (prune arg2 #'(lambda (form) (try `(isqrt (abs ,form)))))))) ((ash) (try 0) (let ((form1 (second form)) (form2 (third form))) (try form1) (try form2) (prune form1 #'(lambda (form) (try `(ash ,form ,form2)))) (when (and (consp form2) (= (length form2) 3)) (when (and (integerp form1) (eq (first form2) 'min) (every #'integerp (cdr form2))) (try (eval form))) (let ((form3 (third form2))) (prune form3 #'(lambda (form) (try `(ash ,form1 (,(first form2) ,(second form2) ,form))))))))) ((floor ceiling truncate round mod rem) (try 0) (let ((form1 (second form)) (form2 (third form))) (try form1) (when (cddr form) (try form2)) (prune form1 (if (cddr form) #'(lambda (form) (try `(,op ,form ,form2))) #'(lambda (form) (try `(,op ,form))))) (when (and (consp form2) (= (length form2) 3)) (when (and (integerp form1) (member (first form2) '(max min)) (every #'integerp (cdr form2))) (try (eval form))) (let ((form3 (third form2))) (prune form3 #'(lambda (form) (try `(,op ,form1 (,(first form2) ,(second form2) ,form))))))))) ((constantly) (unless (eql (car args) 0) (prune (car args) #'(lambda (arg) (try `(constantly ,arg)))))) ((funcall) (try 0) (let ((fn (second form)) (fn-args (cddr form))) (mapc try-fn fn-args) (unless (equal fn '(constantly 0)) (try `(funcall (constantly 0) ,@fn-args))) (when (and (consp fn) (eql (car fn) 'function) (symbolp (cadr fn))) (try `(,(cadr fn) ,@fn-args))) (prune-list fn-args #'prune #'(lambda (args) (try `(funcall ,fn ,@args)))))) ((reduce) (try 0) (let ((arg1 (car args)) (arg2 (cadr args)) (rest (cddr args))) (when (and ;; (null (cddr args)) (consp arg1) (eql (car arg1) 'function)) (let ((arg1.2 (cadr arg1))) (when (and (consp arg1.2) (eql (car arg1.2) 'lambda)) (let ((largs (cadr arg1.2)) (body (cddr arg1.2))) (when (null (cdr body)) (prune (car body) #'(lambda (bform) (try `(reduce (function (lambda ,largs ,bform)) ,arg2 ,@rest))))))))) (when (consp arg2) (case (car arg2) ((list vector) (let ((arg2.rest (cdr arg2))) (mapc try-fn arg2.rest) (prune-list arg2.rest #'prune #'(lambda (args) (try `(reduce ,arg1 (,(car arg2) ,@args) ,@rest)))))))))) ((apply) (try 0) (let ((fn (second form)) (fn-args (butlast (cddr form))) (list-arg (car (last form)))) (mapc try-fn fn-args) (unless (equal fn '(constantly 0)) (try `(apply (constantly 0) ,@(cddr form)))) (when (and (consp list-arg) (eq (car list-arg) 'list)) (mapc try-fn (cdr list-arg))) (prune-list fn-args #'prune #'(lambda (args) (try `(apply ,fn ,@args ,list-arg)))) (when (and (consp list-arg) (eq (car list-arg) 'list)) (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) (prune-list (cdr list-arg) #'prune #'(lambda (args) (try `(apply ,fn ,@fn-args (list ,@args)))))))) ((progv) (try 0) (prune-progv form try-fn)) ((tagbody) (try 0) (prune-tagbody form try-fn)) ((progn) (when (null args) (try nil)) (try (car (last args))) (loop for i from 0 below (1- (length args)) for a in args do (try `(progn ,@(subseq args 0 i) ,@(subseq args (1+ i)))) do (when (and (consp a) (or (eq (car a) 'progn) (and (eq (car a) 'tagbody) (every #'consp (cdr a))))) (try `(progn ,@(subseq args 0 i) ,@(copy-list (cdr a)) ,@(subseq args (1+ i)))))) (prune-fn form try-fn)) ((loop) (try 0) (when (and (eql (length args) 6) (eql (elt args 0) 'for) (eql (elt args 2) 'below)) (let ((var (elt args 1)) (count (elt args 3)) (form (elt args 5))) (unless (eql count 0) (try count)) (case (elt args 4) (sum (try `(let ((,(elt args 1) 0)) ,(elt args 5))) (prune form #'(lambda (form) (try `(loop for ,var below ,count sum ,form))))) (count (unless (or (eql form t) (eql form nil)) (try `(loop for ,var below ,count count t)) (try `(loop for ,var below ,count count nil)) (prune form #'(lambda (form) (try `(loop for ,var below ,count count ,form)))))) )))) (otherwise (try 0) (prune-fn form try-fn)) ))))) (setf (gethash form *prune-table*) t) nil) (defun find-in-tree (value tree) "Return true if VALUE is eql to a node in TREE." (or (eql value tree) (and (consp tree) (or (find-in-tree value (car tree)) (find-in-tree value (cdr tree)))))) (defun prune-list (list element-prune-fn list-try-fn) (declare (type function element-prune-fn list-try-fn)) "Utility function for pruning in a list." (loop for i from 0 for e in list do (funcall element-prune-fn e #'(lambda (form) (funcall list-try-fn (append (subseq list 0 i) (list form) (subseq list (1+ i)))))))) (defun prune-case (form try-fn) (declare (type function try-fn)) (flet ((try (e) (funcall try-fn e))) (let* ((op (first form)) (expr (second form)) (cases (cddr form))) ;; Try just the top expression (try expr) ;; Try simplifying the expr (prune expr #'(lambda (form) (try `(,op ,form ,@cases)))) ;; Try individual cases (loop for case in cases do (try (first (last (rest case))))) ;; Try deleting individual cases (loop for i from 0 below (1- (length cases)) do (try `(,op ,expr ,@(subseq cases 0 i) ,@(subseq cases (1+ i))))) ;; Try simplifying the cases ;; Assume each case has a single form (prune-list cases #'(lambda (case try-fn) (declare (type function try-fn)) (when (eql (length case) 2) (prune (cadr case) #'(lambda (form) (funcall try-fn (list (car case) form)))))) #'(lambda (cases) (try `(,op ,expr ,@cases))))))) (defun prune-tagbody (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) (body (cdr form))) (loop for i from 0 for e in body do (cond ((atom e) ;; A tag (unless (find-in-tree e (subseq body 0 i)) (funcall try-fn `(tagbody ,@(subseq body 0 i) ,@(subseq body (1+ i)))))) (t (funcall try-fn `(tagbody ,@(subseq body 0 i) ,@(subseq body (1+ i)))) (prune e #'(lambda (form) ;; Don't put an atom here. (when (consp form) (funcall try-fn `(tagbody ,@(subseq body 0 i) ,form ,@(subseq body (1+ i)))))))))))) (defun prune-progv (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) (vars-form (cadr form)) (vals-form (caddr form)) (body-list (cdddr form))) (when (and (null vars-form) (null vals-form)) (funcall try-fn `(let () ,@body-list))) (when (and (consp vals-form) (eql (car vals-form) 'list)) (when (and (consp vars-form) (eql (car vars-form) 'quote)) (let ((vars (cadr vars-form)) (vals (cdr vals-form))) (when (eql (length vars) (length vals)) (let ((let-form `(let () ,@body-list))) (mapc #'(lambda (var val) (setq let-form `(let ((,var ,val)) ,let-form))) vars vals) (funcall try-fn let-form))) ;; Try simplifying the vals forms (prune-list vals #'prune #'(lambda (vals) (funcall try-fn `(progv ,vars-form (list ,@vals) ,@body-list))))))) ;; Try simplifying the body (when (eql (length body-list) 1) (prune (car body-list) #'(lambda (form) (funcall try-fn `(progv ,vars-form ,vals-form ,form))))))) (defun prune-nary-fn (form try-fn) ;; Attempt to reduce the number of arguments to the fn ;; Do not reduce below 1 (declare (type function try-fn)) (let* ((op (car form)) (args (cdr form)) (nargs (length args))) (when (> nargs 1) (loop for i from 1 to nargs do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) ,@(subseq args i))))))) (defun prune-fn (form try-fn) "Attempt to simplify a function call form. It is considered acceptable to replace the call by one of its argument forms." (declare (type function try-fn)) (prune-list (cdr form) #'prune #'(lambda (args) (funcall try-fn (cons (car form) args))))) (defun prune-let (form try-fn) "Attempt to simplify a LET form." (declare (type function try-fn)) (let* ((op (car form)) (binding-list (cadr form)) (body (cddr form)) ;; (body-len (length body)) ;; (len (length binding-list)) ) ;; Try to simplify (let (( )) ...) to #| (when (and (>= len 1) ;; (eql body-len 1) ;; (eql (caar binding-list) (car body)) ) (let ((val-form (cadar binding-list))) (unless (and (consp val-form) (eql (car val-form) 'make-array)) (funcall try-fn val-form)))) |# ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) (prune (cadr binding) #'(lambda (form) (funcall try-fn (list (car binding) form))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; Try to simplify the body of the LET form (when body (unless binding-list (funcall try-fn (car (last body)))) (when (and (first binding-list) (not (rest binding-list)) (not (rest body))) (let ((binding (first binding-list))) (unless (or (consp (second binding)) (has-binding-to-var (first binding) body) (has-assignment-to-var (first binding) body) ) (funcall try-fn `(let () ,@(subst (second binding) (first binding) (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) body) )))))) (prune (car (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) (defun has-assignment-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) (or (and (member (car form) '(setq setf shiftf) :test #'eq) (eq (cadr form) var)) (and (eql (car form) 'multiple-value-setq) (member var (cadr form)))))) form)) (defun has-binding-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) (case (car form) ((let let*) (loop for binding in (cadr form) thereis (eq (car binding) var))) ((progv) (and (consp (cadr form)) (eq (caadr form) 'quote) (consp (second (cadr form))) (member var (second (cadr form))))) (t nil)))) form)) (defun find-if-subtree (pred tree) (declare (type function pred)) (cond ((funcall pred tree) tree) ((consp tree) (or (find-if-subtree pred (car tree)) (find-if-subtree pred (cdr tree)))) (t nil))) (defun prune-flet (form try-fn) "Attempt to simplify a FLET form." (declare (type function try-fn)) (let* ((op (car form)) (binding-list (cadr form)) (body (cddr form))) ;; Remove a declaration, if any (when (and (consp body) (consp (car body)) (eq (caar body) 'declare)) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) ;; Try to prune optional arguments (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) (let* ((name (car binding)) (args (cadr binding)) (body (cddr binding)) (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) (the list args)))) (when opt-pos (incf opt-pos) (let ((normal-args (subseq args 0 (1- opt-pos))) (optionals (subseq args opt-pos))) (prune-list optionals #'(lambda (opt-lambda-arg try-fn) (declare (type function try-fn)) (when (consp opt-lambda-arg) (let ((name (first opt-lambda-arg)) (form (second opt-lambda-arg))) (prune form #'(lambda (form) (funcall try-fn (list name form))))))) #'(lambda (opt-args) (funcall try-fn `(,name (,@normal-args &optional ,@opt-args) ,@body)))))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) ;; Prune body of a binding (prune (third binding) #'(lambda (form) (funcall try-fn (list (first binding) (second binding) form))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) ;; ;; Try to simplify the body of the FLET form (when body ;; No bindings -- try to simplify to the last form in the body (unless binding-list (funcall try-fn (first (last body)))) (when (and (consp binding-list) (null (rest binding-list))) (let ((binding (first binding-list))) ;; One binding -- match on (flet (( () )) ()) (when (and (symbolp (first binding)) (not (find-in-tree (first binding) (rest binding))) (null (second binding)) (equal body (list (list (first binding))))) (funcall try-fn `(,op () ,@(cddr binding)))) ;; One binding -- try to remove it if not used (when (and (symbolp (first binding)) (not (find-in-tree (first binding) body))) (funcall try-fn (first (last body)))) )) ;; Try to simplify (the last form in) the body. (prune (first (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) ;;; Routine to walk form, applying a function at each form ;;; The fn is applied in preorder. When it returns :stop, do ;;; not descend into subforms #| (defun walk (form fn) (declare (type function fn)) (unless (eq (funcall fn form) :stop) (when (consp form) (let ((op (car form))) (case op ((let let*) (walk-let form fn)) ((cond) (dolist (clause (cdr form)) (walk-implicit-progn clause fn))) ((multiple-value-bind) (walk (third form) fn) (walk-body (cdddr form) fn)) ((function quote declare) nil) ((block the return-from) (walk-implicit-progn (cddr form) fn)) ((case typecase) (walk (cadr form) fn) (dolist (clause (cddr form)) (walk-implicit-progn (cdr clause) fn))) ((flet labels) |# ;;;;;;;;;;;;;;;;;;;;;; ;;; Convert pruned results to test cases (defun produce-test-cases (instances &key (stream *standard-output*) (prefix "MISC.") (index 1)) (dolist (inst instances) (let* (;; (vars (getf inst :vars)) (vals (getf inst :vals)) (optimized-lambda-form (getf inst :optimized-lambda-form)) (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) (name (intern (concatenate 'string prefix (format nil "~D" index)) "CL-TEST")) (test-form `(deftest ,name (let* ((fn1 ',optimized-lambda-form) (fn2 ',unoptimized-lambda-form) (vals ',vals) (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) :good))) (print test-form stream) (terpri stream) (incf index))) (values)) gcl-2.6.14/ansi-tests/types-and-class.lsp0000644000175000017500000002345714360276512016627 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Mar 19 21:48:39 1998 ;;;; Contains: Data for testing type and class inclusions ;; We should check for every type that NIL is a subtype, and T a supertype (in-package :cl-test) (declaim (optimize (safety 3))) (deftest boolean-type.1 (notnot-mv (typep nil 'boolean)) t) (deftest boolean-type.2 (notnot-mv (typep t 'boolean)) t) (deftest boolean-type.3 (check-type-predicate 'is-t-or-nil 'boolean) 0) ;; Two type inclusions on booleans ;; have been conditionalized to prevent ;; some tests from doing too badly on CMU CL on x86 ;; These should get removed when I get a more up to date ;; image for that platform -- pfd (deftest types.3 (loop for (t1 t2) in *subtype-table* for m1 = (check-subtypep t1 t2 t t) for m2 = (check-subtypep `(and ,t1 ,t2) t1 t) for m3 = (check-subtypep `(and ,t2 ,t1) t1 t) for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t) for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t) when m1 collect m1 when m2 collect m2 when m3 collect m3 when m4 collect m4 when m5 collect m5) nil) (declaim (special +float-types+ *subtype-table*)) ;;; This next test is all screwed up. Basically, it assumes ;;; incorrectly that certain subtype relationships that are ;;; not specified in the spec cannot occur. #| (defun types.4-body () (let ((parent-table (make-hash-table :test #'equal)) (types nil)) (loop for p in *subtype-table* do (let ((tp (first p)) (parent (second p))) (pushnew tp types) (pushnew parent types) (let ((parents (gethash tp parent-table))) (pushnew parent parents) ;; (format t "~S ==> ~S~%" tp parent) (loop for pp in (gethash parent parent-table) do ;; (format t "~S ==> ~S~%" tp pp) (pushnew pp parents)) (setf (gethash tp parent-table) parents)))) ;; parent-table now contains lists of ancestors (loop for tp in types sum (let ((parents (gethash tp parent-table))) (loop for tp2 in types sum (cond ((and (not (eqt tp tp2)) (not (eqt tp2 'standard-object)) (not (eqt tp2 'structure-object)) (not (member tp2 parents)) (subtypep* tp tp2) (not (and (member tp +float-types+) (member tp2 +float-types+))) (not (and (eqt tp2 'structure-object) (member 'standard-object parents)))) (format t "~%Improper subtype: ~S of ~S" tp tp2) 1) (t 0))))) )) (deftest types.4 (types.4-body) 0) |# (deftest types.6 (types.6-body) nil) (declaim (special *disjoint-types-list*)) ;;; Check that the disjoint types really are disjoint (deftest types.7b (loop for e on *disjoint-types-list* for tp1 = (first e) append (loop for tp2 in (rest e) append (classes-are-disjoint tp1 tp2))) nil) (deftest types.7c (loop for e on *disjoint-types-list2* for list1 = (first e) append (loop for tp1 in list1 append (loop for list2 in (rest e) append (loop for tp2 in list2 append (classes-are-disjoint tp1 tp2))))) nil) (deftest types.8 (loop for tp in *disjoint-types-list* count (cond ((and (not (eqt tp 'cons)) (not (subtypep* tp 'atom))) (format t "~%Should be atomic, but isn't: ~S" tp) t))) 0) (declaim (special *type-list* *supertype-table*)) ;;; ;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used ;;; here.) ;;; (deftest types.9 (types.9-body) nil) ;;; ;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). ;;; ;;; The function prints error messages when this fails, and returns the ;;; number of occurences of failure. ;;; ;;; Test TYPES.9 must be run before this test. ;;; (deftest types.9a (types.9a-body) 0) ;;; All class names in CL denote classes that are subtypep ;;; equivalent to themselves (deftest all-classes-are-type-equivalent-to-their-names (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when class append (check-equivalence sym class)) nil) ;;; Check that all class names in CL that name standard-classes or ;;; structure-classes are subtypes of standard-object and structure-object, ;;; respectively (deftest all-standard-classes-are-subtypes-of-standard-object (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when (and class (typep class 'standard-class) (or (not (subtypep sym 'standard-object)) (not (subtypep class 'standard-object)))) collect sym) nil) (deftest all-structure-classes-are-subtypes-of-structure-object (loop for sym being the external-symbols of "COMMON-LISP" for class = (find-class sym nil) when (and class (typep class 'structure-class) (or (not (subtypep sym 'structure-object)) (not (subtypep class 'structure-object)))) collect sym) nil) ;;; Confirm that only the symbols exported from CL that are supposed ;;; to be types are actually classes (see section 11.1.2.1.1) (deftest all-exported-cl-class-names-are-valid (loop for sym being the external-symbols of "COMMON-LISP" when (and (find-class sym nil) (not (member sym *cl-all-type-symbols* :test #'eq))) collect sym) nil) ;;; Confirm that all standard generic functions are instances of ;;; the class standard-generic-function. (deftest all-standard-generic-functions-are-instances-of-that-class (loop for sym in *cl-standard-generic-function-symbols* for fun = (and (fboundp sym) (symbol-function sym)) unless (and (typep fun 'generic-function) (typep fun 'standard-generic-function)) collect (list sym fun)) nil) ;;; Canonical metaobjects are in the right classes (deftest structure-object-is-in-structure-class (notnot-mv (typep (find-class 'structure-object) 'structure-class)) t) (deftest standard-object-is-in-standard-class (notnot-mv (typep (find-class 'standard-object) 'standard-class)) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; deftype (deftype even-array (&optional type size) `(and (array ,type ,size) (satisfies even-size-p))) (deftest deftype.1 (typep 1 '(even-array integer (10))) nil) (deftest deftype.2 (typep nil '(even-array t (*))) nil) (deftest deftype.3 (notnot-mv (typep (make-array '(10)) '(even-array t (*)))) t) (deftest deftype.4 (typep (make-array '(5)) '(even-array t (*))) nil) (deftest deftype.5 (notnot-mv (typep (make-string 10) '(even-array character (*)))) t) (deftest deftype.6 (notnot-mv (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) '(even-array (unsigned-byte 8)))) t) ;; This should be greatly expanded (defparameter *type-and-class-fns* '(coerce subtypep type-of typep type-error-datum type-error-expected-type)) (deftest type-and-class-fns (remove-if #'fboundp *type-and-class-fns*) nil) (deftest type-and-class-macros (notnot-mv (macro-function 'deftype)) t) (deftest typep-nil-null (notnot-mv (typep nil 'null)) t) (deftest typep-t-null (typep t 'null) nil) ;;; Error checking of type-related functions (deftest type-of.error.1 (classify-error (type-of)) program-error) (deftest type-of.error.2 (classify-error (type-of nil nil)) program-error) (deftest typep.error.1 (classify-error (typep)) program-error) (deftest typep.error.2 (classify-error (typep nil)) program-error) (deftest typep.error.3 (classify-error (typep nil t nil nil)) program-error) (deftest type-error-datum.error.1 (classify-error (type-error-datum)) program-error) (deftest type-error-datum.error.2 (classify-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-datum c nil))) program-error) (deftest type-error-expected-type.error.1 (classify-error (type-error-expected-type)) program-error) (deftest type-error-expected-type.error.2 (classify-error (let ((c (make-condition 'type-error :datum nil :expected-type t))) (type-error-expected-type c nil))) program-error) ;;; Tests of env arguments to typep (deftest typep.env.1 (notnot-mv (typep 0 'bit nil)) t) (deftest typep.env.2 (macrolet ((%foo (&environment env) (notnot-mv (typep 0 'bit env)))) (%foo)) t) (deftest typep.env.3 (macrolet ((%foo (&environment env) (notnot-mv (typep env (type-of env))))) (%foo)) t) ;;; Other typep tests (deftest typep.1 (notnot-mv (typep 'a '(eql a))) t) (deftest typep.2 (notnot-mv (typep 'a '(and (eql a)))) t) (deftest typep.3 (notnot-mv (typep 'a '(or (eql a)))) t) (deftest typep.4 (typep 'a '(eql b)) nil) (deftest typep.5 (typep 'a '(and (eql b))) nil) (deftest typep.6 (typep 'a '(or (eql b))) nil) (deftest typep.7 (notnot-mv (typep 'a '(satisfies symbolp))) t) (deftest typep.8 (typep 10 '(satisfies symbolp)) nil) (deftest typep.9 (let ((class (find-class 'symbol))) (notnot-mv (typep 'a class))) t) (deftest typep.10 (let ((class (find-class 'symbol))) (notnot-mv (typep 'a `(and ,class)))) t) (deftest typep.11 (let ((class (find-class 'symbol))) (typep 10 class)) nil) (deftest typep.12 (let ((class (find-class 'symbol))) (typep 10 `(and ,class))) nil) (deftest typep.13 (typep 'a '(and symbol integer)) nil) (deftest typep.14 (notnot-mv (typep 'a '(or symbol integer))) t) (deftest typep.15 (notnot-mv (typep 'a '(or integer symbol))) t) (deftest typep.16 (let ((c1 (find-class 'number)) (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c1 ,c2)))) t) (deftest typep.17 (let ((c1 (find-class 'number)) (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c2 ,c1)))) t) gcl-2.6.14/ansi-tests/subtypep-float.lsp0000644000175000017500000001176114360276512016571 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:55:37 2003 ;;;; Contains: Tests for subtype relationships on float types (in-package :cl-test) ;;;;;;; (deftest subtypep.float.1 (loop for tp in +float-types+ append (check-subtypep tp 'float t t)) nil) (deftest subtypep.float.2 (if (subtypep 'short-float 'long-float) (loop for tp in +float-types+ append (loop for tp2 in +float-types+ append (check-subtypep tp tp2 t t))) nil) nil) (deftest subtypep.float.3 (if (and (not (subtypep 'short-float 'single-float)) (subtypep 'single-float 'long-float)) (append (check-equivalence 'single-float 'double-float) (check-equivalence 'single-float 'long-float) (check-equivalence 'double-float 'long-float) (classes-are-disjoint 'short-float 'single-float) (classes-are-disjoint 'short-float 'double-float) (classes-are-disjoint 'short-float 'long-float)) nil) nil) (deftest subtypep.float.4 (if (and (subtypep 'single-float 'short-float) (subtypep 'double-float 'long-float) (not (subtypep 'short-float 'double-float))) (append (check-equivalence 'short-float 'single-float) (check-equivalence 'double-float 'long-float) (loop for tp in '(short-float single-float) append (loop for tp2 in '(double-float long-float) append (classes-are-disjoint tp tp2)))) nil) nil) (deftest subtypep.float.5 (if (and (not (subtypep 'single-float 'short-float)) (not (subtypep 'single-float 'double-float)) (subtypep 'double-float 'long-float)) (append (classes-are-disjoint 'short-float 'single-float) (classes-are-disjoint 'short-float 'double-float) (classes-are-disjoint 'short-float 'long-float) (classes-are-disjoint 'single-float 'double-float) (classes-are-disjoint 'single-float 'long-float) (check-equivalence 'double-float 'long-float)) nil) nil) (deftest subtypep.float.6 (if (and (subtypep 'single-float 'short-float) (not (subtypep 'single-float 'double-float)) (not (subtypep 'double-float 'long-float))) (append (check-equivalence 'short-float 'single-float) (classes-are-disjoint 'single-float 'double-float) (classes-are-disjoint 'single-float 'long-float) (classes-are-disjoint 'double-float 'long-float)) nil) nil) (deftest subtypep.float.7 (if (and (not (subtypep 'single-float 'short-float)) (not (subtypep 'single-float 'double-float)) (not (subtypep 'double-float 'long-float))) (loop for tp in +float-types+ append (loop for tp2 in +float-types+ unless (eq tp tp2) append (classes-are-disjoint tp tp2))) nil) nil) (deftest subtypep.float.8 (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0)) t t) (deftest subtypep.float.9 (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0)) t t) (deftest subtypep.float.10 (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0)) t t) (deftest subtypep.float.11 (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0)) t t) (deftest subtypep.float.12 (subtypep* '(short-float 0.0s0 11.0s0) '(short-float 0.0s0 10.0s0)) nil t) (deftest subtypep.float.13 (subtypep* '(single-float 0.0f0 11.0f0) '(single-float 0.0f0 10.0f0)) nil t) (deftest subtypep.float.14 (subtypep* '(double-float 0.0d0 11.0d0) '(double-float 0.0d0 10.0d0)) nil t) (deftest subtypep.float.15 (subtypep* '(long-float 0.0l0 11.0l0) '(long-float 0.0l0 10.0l0)) nil t) (deftest subtypep.float.16 (subtypep* '(short-float 0.0s0 (10.0s0)) '(short-float 0.0s0 10.0s0)) t t) (deftest subtypep.float.17 (subtypep* '(single-float 0.0f0 (10.0f0)) '(single-float 0.0f0 10.0f0)) t t) (deftest subtypep.float.18 (subtypep* '(double-float 0.0d0 (10.0d0)) '(double-float 0.0d0 10.0d0)) t t) (deftest subtypep.float.19 (subtypep* '(long-float 0.0l0 (10.0l0)) '(long-float 0.0l0 10.0l0)) t t) (deftest subtypep.float.20 (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 (10.0s0))) nil t) (deftest subtypep.float.21 (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 (10.0f0))) nil t) (deftest subtypep.float.22 (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 (10.0d0))) nil t) (deftest subtypep.float.23 (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 (10.0l0))) nil t) (deftest subtypep.float.24 (check-equivalence '(and (short-float 0.0s0 2.0s0) (short-float 1.0s0 3.0s0)) '(short-float 1.0s0 2.0s0)) nil) (deftest subtypep.float.25 (check-equivalence '(and (single-float 0.0f0 2.0f0) (single-float 1.0f0 3.0f0)) '(single-float 1.0f0 2.0f0)) nil) (deftest subtypep.float.26 (check-equivalence '(and (double-float 0.0d0 2.0d0) (double-float 1.0d0 3.0d0)) '(double-float 1.0d0 2.0d0)) nil) (deftest subtypep.float.27 (check-equivalence '(and (long-float 0.0l0 2.0l0) (long-float 1.0l0 3.0l0)) '(long-float 1.0l0 2.0l0)) nil) gcl-2.6.14/ansi-tests/aref.lsp0000644000175000017500000000550314360276512014525 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 11 17:33:24 2003 ;;;; Contains: Tests for AREF (in-package :cl-test) ;;; AREF is also tested in many other places (deftest aref.1 (aref #0aT) T) (deftest aref.2 (aref #(1 2 3 4) 2) 3) (deftest aref.3 (aref #2a((a b c d)(e f g h)) 1 2) g) (deftest aref.4 (loop for i from 0 below 6 collect (aref "abcdef" i)) (#\a #\b #\c #\d #\e #\f)) (deftest aref.5 (let ((a (make-array '(2 3) :element-type 'base-char :initial-contents '("abc" "def")))) (loop for i below 2 collect (loop for j below 3 collect (aref a i j)))) ((#\a #\b #\c) (#\d #\e #\f))) (deftest aref.6 (loop for i below 10 collect (aref #*1101100010 i)) (1 1 0 1 1 0 0 0 1 0)) (deftest aref.7 (let ((a (make-array '(2 5) :element-type 'bit :initial-contents '((1 1 0 0 1) (0 1 0 1 0))))) (loop for i below 2 collect (loop for j below 5 collect (aref a i j)))) ((1 1 0 0 1) (0 1 0 1 0))) ;;; Order of argument evaluation (deftest aref.order.1 (let ((i 0) x y (a #(a b c d))) (values (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) i x y)) c 2 1 2) (deftest aref.order.2 (let ((i 0) x y z (a #2a((a b c)(d e f)))) (values (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 1) (progn (setf z (incf i)) 2)) i x y z)) f 3 1 2 3) ;;; Setf of aref (deftest setf-aref.1 (let ((a (copy-seq #(1 2 3 4)))) (values (setf (aref a 2) 'z) a)) z #(1 2 z 4)) (deftest setf-aref.2 (let ((a (make-array nil :initial-element 1))) (values (setf (aref a) 'z) a)) z #0az) (deftest setf-aref.3 (let ((a (make-array '(2 3) :initial-element 'a))) (values (setf (aref a 0 1) 'z) a)) z #2a((a z a)(a a a))) (deftest setf-aref.4 (let ((a (copy-seq "abcd"))) (values (setf (aref a 0) #\z) a)) #\z "zbcd") (deftest setf-aref.5 (let ((a (copy-seq #*0011))) (values (setf (aref a 0) 1) a)) 1 #*1011) (deftest setf-aref.6 (let ((a (make-array '(2 3) :initial-element #\a :element-type 'base-char))) (values (setf (aref a 0 1) #\z) a)) #\z #2a((#\a #\z #\a)(#\a #\a #\a))) (deftest setf-aref.7 (let ((a (make-array '(2 3) :initial-element 1 :element-type 'bit))) (values (setf (aref a 0 1) 0) a)) 0 #2a((1 0 1)(1 1 1))) (deftest setf-aref.order.1 (let ((i 0) x y z (a (copy-seq #(a b c d)))) (values (setf (aref (progn (setf x (incf i)) a) (progn (setf y (incf i)) 2)) (progn (setf z (incf i)) 'z)) a i x y z)) z #(a b z d) 3 1 2 3) ;;; To add: aref on displaced arrays, arrays with fill pointers, etc. (deftest aref.error.1 (classify-error (aref)) program-error) (deftest aref.error.2 (classify-error (funcall #'aref)) program-error) gcl-2.6.14/ansi-tests/nstring-downcase.lsp0000644000175000017500000000617614360276512017104 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:33:16 2002 ;;;; Contains: Tests for NSTRING-DOWNCASE (in-package :cl-test) (deftest nstring-downcase.1 (let* ((s (copy-seq "A")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "a") (deftest nstring-downcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest nstring-downcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-downcase.6 (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\A #\B #\C #\D #\E #\F))) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdef") (deftest nstring-downcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\A #\B #\7 #\D #\E #\F))) (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "ab7def") ;; Tests with :start, :end (deftest nstring-downcase.8 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-downcase (copy-seq s) :start i))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 collect (nstring-downcase (copy-seq s) :start i :end nil))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.10 (let ((s "ABCDE")) (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-invertcase (nstring-downcase (copy-seq s) :start i :end j))))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE"))) (deftest nstring-downcase.order.1 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (nstring-downcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "AbcdEF" 3 1 2 3) (deftest nstring-downcase.order.2 (let ((i 0) a b c (s (copy-seq "ABCDEF"))) (values (nstring-downcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "AbcdEF" 3 1 2 3) ;;; Error cases (deftest nstring-downcase.error.1 (classify-error (nstring-downcase)) program-error) (deftest nstring-downcase.error.2 (classify-error (nstring-downcase (copy-seq "abc") :bad t)) program-error) (deftest nstring-downcase.error.3 (classify-error (nstring-downcase (copy-seq "abc") :start)) program-error) (deftest nstring-downcase.error.4 (classify-error (nstring-downcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-downcase.error.5 (classify-error (nstring-downcase (copy-seq "abc") :end)) program-error) (deftest nstring-downcase.error.6 (classify-error (nstring-downcase (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/load-iteration.lsp0000644000175000017500000000062114360276512016517 0ustar cammcamm;;; Tests of iteration forms (load "iteration.lsp") (load "loop.lsp") (load "loop1.lsp") (load "loop2.lsp") (load "loop3.lsp") (load "loop4.lsp") (load "loop5.lsp") (load "loop6.lsp") (load "loop7.lsp") (load "loop8.lsp") (load "loop9.lsp") (load "loop10.lsp") (load "loop11.lsp") (load "loop12.lsp") (load "loop13.lsp") (load "loop14.lsp") (load "loop15.lsp") (load "loop16.lsp") (load "loop17.lsp") gcl-2.6.14/ansi-tests/two-way-stream-input-stream.lsp0000644000175000017500000000140014360276512021126 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:22:50 2004 ;;;; Contains: Tests of TWO-WAY-STREAM-INPUT-STREAM (in-package :cl-test) (deftest two-way-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-input-stream s)) (list is))) t) (deftest two-way-stream-input-stream.error.1 (signals-error (two-way-stream-input-stream) program-error) t) (deftest two-way-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-two-way-stream is os))) (two-way-stream-input-stream s nil)) program-error) t) gcl-2.6.14/ansi-tests/random-intern.lsp0000644000175000017500000000324514360276512016366 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Contains: Code to randomly intern and unintern random strings ;;;; in a package. Exercises package and hash table routines (in-package :cl-test) (defconstant +max-len-random-symbol+ 63) (defun make-random-symbol (package) (declare (optimize (speed 3) (safety 3))) (loop (let* ((len (random (1+ +max-len-random-symbol+))) (str (make-string len))) (declare (type (integer 0 #.+max-len-random-symbol+) len)) (loop for i from 0 to (1- len) do (setf (schar str i) (schar +base-chars+ (random +num-base-chars+)))) (multiple-value-bind (symbol status) (intern (copy-seq str) package) (unless (equal str (symbol-name symbol)) (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) (unless status (return symbol)))))) (defun queue-insert (q x) (declare (type cons q)) (push x (cdr q))) (defun queue-remove (q) (declare (type cons q)) (when (null (car q)) (when (null (cdr q)) (error "Attempty to remove from empty queue.~%")) (setf (car q) (nreverse (cdr q))) (setf (cdr q) nil)) (pop (car q))) (defun queue-empty (q) (and (null (car q)) (null (cdr q)))) (defun random-intern (n) (declare (fixnum n)) (let ((q (list nil)) (xp (defpackage "X" (:use)))) (declare (type cons q)) (loop for i from 1 to n do (if (and (= (random 2) 0) (not (queue-empty q))) (unintern (queue-remove q) xp) (queue-insert q (make-random-symbol xp)))))) (defun fill-intern (n) (declare (fixnum n)) (let ((xp (defpackage "X" (:use)))) (loop for i from 1 to n do (make-random-symbol xp)))) gcl-2.6.14/ansi-tests/nsubstitute-if.lsp0000644000175000017500000005470214360276512016602 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 18:56:41 2002 ;;;; Contains: Tests for NSUBSTITUTE-IF (in-package :cl-test) (deftest nsubstitute-if-list.1 (nsubstitute-if 'b 'identity nil) nil) (deftest nsubstitute-if-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x) x) (b b b c)) (deftest nsubstitute-if-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil)) (b b b c)) (deftest nsubstitute-if-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) (b b b c)) (deftest nsubstitute-if-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) (b b a c)) (deftest nsubstitute-if-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) (a b a c)) (deftest nsubstitute-if-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-list.8 (nsubstitute-if 'b (is-eq-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) (b b b c)) (deftest nsubstitute-if-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-if-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-if-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-if-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-if-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-if-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors (deftest nsubstitute-if-vector.1 (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x)) #()) (deftest nsubstitute-if-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil) x) #(b b b c)) (deftest nsubstitute-if-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) #(b b b c)) (deftest nsubstitute-if-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) #(b b a c)) (deftest nsubstitute-if-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) #(a b a c)) (deftest nsubstitute-if-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-vector.8 (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) #(b b b c)) (deftest nsubstitute-if-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-if-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-if-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-if-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-if-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-if-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-if-string.1 (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x)) "") (deftest nsubstitute-if-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x)) "bbbc") (deftest nsubstitute-if-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-string.8 (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) "") (deftest nsubstitute-if-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1 :from-end t)) "abac") (deftest nsubstitute-if-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-if-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x))) result) #*) (deftest nsubstitute-if-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x))) result) #*) (deftest nsubstitute-if-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x))) result) #*000000) (deftest nsubstitute-if-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x))) result) #*111111) (deftest nsubstitute-if-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :start 1))) result) #*011111) (deftest nsubstitute-if-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :end 4))) result) #*111101) (deftest nsubstitute-if-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute-if 1 (is-eq-p 0) x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) ;;; More tests (deftest nsubstitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+))) result) #*11111111111111111) (deftest nsubstitute-if-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x))) result) #*11111) (deftest nsubstitute-if-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest nsubstitute-if-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest nsubstitute-if-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) (deftest nsubstitute-if.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute-if.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute-if (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'null) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute-if.allow-other-keys.1 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.2 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.3 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.4 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.5 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute-if.keywords.6 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest nsubstitute-if.allow-other-keys.7 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.8 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest nsubstitute-if.error.1 (classify-error (nsubstitute-if)) program-error) (deftest nsubstitute-if.error.2 (classify-error (nsubstitute-if 'a)) program-error) (deftest nsubstitute-if.error.3 (classify-error (nsubstitute-if 'a #'null)) program-error) (deftest nsubstitute-if.error.4 (classify-error (nsubstitute-if 'a #'null nil 'bad t)) program-error) (deftest nsubstitute-if.error.5 (classify-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute-if.error.6 (classify-error (nsubstitute-if 'a #'null nil :key)) program-error) (deftest nsubstitute-if.error.7 (classify-error (nsubstitute-if 'a #'null nil 1 2)) program-error) (deftest nsubstitute-if.error.8 (classify-error (nsubstitute-if 'a #'cons (list 'a 'b 'c))) program-error) (deftest nsubstitute-if.error.9 (classify-error (nsubstitute-if 'a #'car (list 'a 'b 'c))) type-error) (deftest nsubstitute-if.error.10 (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest nsubstitute-if.error.11 (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/packages-05.lsp0000644000175000017500000000503314360276512015606 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:45 1998 ;;;; Contains: Package test code, part 05 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; export (deftest export.1 (let ((return-value nil)) (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p)) (i 0) x y) (setf return-value (export (progn (setf x (incf i)) sym) (progn (setf y (incf i)) p))) (multiple-value-bind* (sym2 status) (find-symbol "FOO" p) (prog1 (and sym2 (eql i 2) (eql x 1) (eql y 2) (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") (eqt sym sym2) (eqt status :external)) (delete-package p))))) return-value) t) (deftest export.2 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p))) (export (list sym) p) (multiple-value-bind* (sym2 status) (find-symbol "FOO" p) (prog1 (and sym2 (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") (eqt sym sym2) (eqt status :external)) (delete-package p)))))) t) (deftest export.3 (handler-case (progn (safely-delete-package "F") (make-package "F") (let ((sym (intern "FOO" "F"))) (export sym #\F) (delete-package "F") t)) (error (c) (safely-delete-package "F") c)) t) ;; ;; When a symbol not in a package is exported, export ;; should signal a correctable package-error asking the ;; user whether the symbol should be imported. ;; (deftest export.4 (handler-case (export 'b::bar "A") (package-error () 'package-error) (error (c) c)) package-error) ;; ;; Test that it catches an attempt to export a symbol ;; from a package that is used by another package that ;; is exporting a symbol with the same name. ;; (deftest export.5 (progn (safely-delete-package "TEST1") (safely-delete-package "TEST2") (make-package "TEST1") (make-package "TEST2" :use '("TEST1")) (export (intern "X" "TEST2") "TEST2") (prog1 (handler-case (let ((sym (intern "X" "TEST1"))) (handler-case (export sym "TEST1") (error (c) (format t "Caught error in EXPORT.5: ~A~%" c) 'caught))) (error (c) c)) (delete-package "TEST2") (delete-package "TEST1"))) caught) (deftest export.error.1 (classify-error (export)) program-error) (deftest export.error.2 (classify-error (export 'X "CL-TEST" NIL)) program-error) gcl-2.6.14/ansi-tests/array-displacement.lsp0000644000175000017500000000714014360276512017373 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:20:51 2003 ;;;; Contains: Tests for ARRAY-DISPLACEMENT (in-package :cl-test) ;;; The tests in make-array.lsp also test array-displacement ;;; The standard is contradictory about whether arrays created with ;;; :displaced-to NIL should return NIL as their primary value or ;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) ;;; that an implementation is free to implement all arrays as actually ;;; displaced. Therefore, I've omitted all the tests of not-expressly ;;; displaced arrays. ;;; Behavior on expressly displaced arrays (deftest array-displacement.7 (let* ((a (make-array '(10))) (b (make-array '(10) :displaced-to a))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.8 (let* ((a (make-array '(10))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.9 (let* ((a (make-array '(10) :element-type 'base-char)) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type 'base-char))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.10 (let* ((a (make-array '(10) :element-type 'base-char)) (b (make-array '(5) :displaced-to a :element-type 'base-char))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.11 (let* ((a (make-array '(10) :element-type 'bit)) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type 'bit))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.12 (let* ((a (make-array '(10) :element-type 'bit)) (b (make-array '(5) :displaced-to a :element-type 'bit))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.13 (let* ((a (make-array '(10) :element-type '(integer 0 255))) (b (make-array '(5) :displaced-to a :displaced-index-offset 2 :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 2)))) t) (deftest array-displacement.14 (let* ((a (make-array '(10) :element-type '(integer 0 255))) (b (make-array '(5) :displaced-to a :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) (array-displacement b) (and (eqt a dt) (eqlt disp 0)))) t) (deftest array-displacement.order.1 (let* ((a (make-array '(10))) (b (make-array '(10) :displaced-to a)) (i 0)) (multiple-value-bind* (dt disp) (array-displacement (progn (incf i) b)) (and (eql i 1) (eqt a dt) (eqlt disp 0)))) t) ;;; Error tests (deftest array-displacement.error.1 (classify-error (array-displacement)) program-error) (deftest array-displacement.error.2 (classify-error (array-displacement #(a b c) nil)) program-error) (deftest array-displacement.error.3 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(array-displacement ',e))))) collect (list e why))) nil) (deftest array-displacement.error.4 (classify-error (array-displacement nil)) type-error) (deftest array-displacement.error.5 (classify-error (let ((x nil)) (array-displacement x))) type-error) gcl-2.6.14/ansi-tests/loop6.lsp0000644000175000017500000001607614360276512014656 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 10 21:13:04 2002 ;;;; Contains: Tests for LOOP-AS-HASH forms (in-package :cl-test) (defparameter *loop.6.alist* '((a . 1) (b . 2) (c . 3))) (defparameter *loop.6.alist.2* '(("a" . 1) ("b" . 2) ("c" . 3))) (defparameter *loop.6.alist.3* '(((a1 . a2) . 1) ((b1 . b2) . 2) ((c1 . c2) . 3))) (defparameter *loop.6.hash.1* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.2* (let ((table (make-hash-table :test #'eql))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.3* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.3* do (setf (gethash key table) val)) table)) ;;; (defparameter *loop.6.hash.4* ;;; (let ((table (make-hash-table :test #'equalp))) ;;; (loop for (key . val) in *loop.6.alist.2* ;;; do (setf (gethash key table) val)) ;;; table)) (defparameter *loop.6.hash.5* (let ((table (make-hash-table :test #'eql))) (loop for (val . key) in *loop.6.alist.3* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.6* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* do (setf (gethash key table) (coerce val 'float))) table)) (defparameter *loop.6.hash.7* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.3* do (setf (gethash (coerce key 'float) table) val)) table)) (defparameter *loop.6.alist.8* '(((1 . 2) . 1) ((3 . 4) . b) ((5 . 6) . c))) (defparameter *loop.6.hash.8* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.8* do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.9* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.8* do (setf (gethash key table) val)) table)) ;;; being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of } (deftest loop.6.1 (loop for x being the hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.2 (loop for x being the hash-values of *loop.6.hash.1* sum x) 6) (deftest loop.6.3 (loop for x being each hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.4 (loop for x being each hash-values of *loop.6.hash.1* sum x) 6) (deftest loop.6.5 (loop for x being the hash-values in *loop.6.hash.1* sum x) 6) (deftest loop.6.6 (sort (loop for x being the hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.7 (sort (loop for x being the hash-keys of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.8 (sort (loop for x being each hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.9 (sort (loop for x being each hash-keys of *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.10 (sort (loop for x being each hash-keys in *loop.6.hash.1* collect x) #'symbol<) (a b c)) (deftest loop.6.11 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.12 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.13 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.14 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.15 (sort (loop for k being the hash-keys of *loop.6.hash.1* using (hash-value v) collect (list k v)) #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.16 (sort (loop for v being the hash-values of *loop.6.hash.1* using (hash-key k) collect (list k v)) #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.17 (sort (loop for (u . nil) being the hash-values of *loop.6.hash.5* collect u) #'symbol<) (a1 b1 c1)) (deftest loop.6.18 (sort (loop for (nil . v) being the hash-values of *loop.6.hash.5* collect v) #'symbol<) (a2 b2 c2)) (deftest loop.6.19 (loop for nil being the hash-values of *loop.6.hash.5* count t) 3) (deftest loop.6.20 (loop for nil being the hash-keys of *loop.6.hash.5* count t) 3) (deftest loop.6.21 (loop for v being the hash-values of *loop.6.hash.5* using (hash-key nil) count t) 3) (deftest loop.6.22 (loop for k being the hash-keys of *loop.6.hash.5* using (hash-value nil) count t) 3) (deftest loop.6.23 (loop for v fixnum being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.24 (loop for v of-type fixnum being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.25 (loop for k fixnum being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.26 (loop for k of-type fixnum being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.27 (loop for k t being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.28 (loop for k of-type t being the hash-keys of *loop.6.hash.5* sum k) 6) (deftest loop.6.29 (loop for v t being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.30 (loop for v of-type t being the hash-values of *loop.6.hash.1* sum v) 6) (deftest loop.6.31 (loop for v float being the hash-values of *loop.6.hash.6* sum v) 6.0) (deftest loop.6.32 (loop for v of-type float being the hash-values of *loop.6.hash.6* sum v) 6.0) (deftest loop.6.33 (loop for k float being the hash-keys of *loop.6.hash.7* sum k) 6.0) (deftest loop.6.34 (loop for k of-type float being the hash-keys of *loop.6.hash.7* sum k) 6.0) (deftest loop.6.35 (loop for (k1 . k2) of-type (integer . integer) being the hash-keys of *loop.6.hash.8* sum (+ k1 k2)) 21) (deftest loop.6.36 (loop for (v1 . v2) of-type (integer . integer) being the hash-values of *loop.6.hash.9* sum (+ v1 v2)) 21) (deftest loop.6.37 (loop for v being the hash-values of *loop.6.hash.8* using (hash-key (k1 . k2)) sum (+ k1 k2)) 21) (deftest loop.6.38 (loop for k being the hash-keys of *loop.6.hash.9* using (hash-value (v1 . v2)) sum (+ v1 v2)) 21) (deftest loop.6.39 (loop as x being the hash-value of *loop.6.hash.1* sum x) 6) (deftest loop.6.40 (sort (loop as x being the hash-key of *loop.6.hash.1* collect x) #'symbol<) (a b c)) ;;; Error tests (deftest loop.6.error.1 (classify-error (loop for k from 1 to 10 for k being the hash-keys of *loop.6.hash.1* count t)) program-error) (deftest loop.6.error.2 (classify-error (loop for k being the hash-keys of *loop.6.hash.1* for k from 1 to 10 count t)) program-error) (deftest loop.6.error.3 (classify-error (loop for (k . k) being the hash-keys of *loop.6.hash.3* count t)) program-error) (deftest loop.6.error.4 (classify-error (loop for k being the hash-keys of *loop.6.hash.3* using (hash-value k) count t)) program-error) (deftest loop.6.error.5 (classify-error (loop for k being the hash-values of *loop.6.hash.3* using (hash-key k) count t)) program-error) gcl-2.6.14/ansi-tests/make-string-output-stream.lsp0000644000175000017500000000732714360276512020666 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 19:42:07 2004 ;;;; Contains: Tests of MAKE-STRING-OUTPUT-STREAM (in-package :cl-test) (deftest make-string-output-stream.1 (let ((s (make-string-output-stream))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.2 (let ((s (make-string-output-stream :element-type 'character))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.3 (let ((s (make-string-output-stream :element-type 'base-char))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.4 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.5 (let ((s (make-string-output-stream :allow-other-keys nil))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.6 (let ((s (make-string-output-stream :allow-other-keys t :foo 'bar))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.7 (let ((s (make-string-output-stream :foo 'bar :allow-other-keys t :allow-other-keys nil :foo2 'x))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (input-stream-p s) (notnot (output-stream-p s)) (notnot (open-stream-p s)))) t t nil t t) (deftest make-string-output-stream.8 (let ((s (make-string-output-stream))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.9 (let ((s (make-string-output-stream :element-type 'character))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.10 (let ((s (make-string-output-stream :element-type 'base-char))) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s)) "abcdef") (deftest make-string-output-stream.11 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (get-output-stream-string s)) "") (deftest make-string-output-stream.12 :notes (:nil-vectors-are-strings) (let ((s (make-string-output-stream :element-type nil))) (typep #\a (array-element-type (get-output-stream-string s)))) nil) (deftest make-string-output-stream.13 (let ((s (make-string-output-stream))) (values (close s) (open-stream-p s))) t nil) ;;; Error tests (deftest make-string-output-stream.error.1 (signals-error (make-string-output-stream nil) program-error) t) (deftest make-string-output-stream.error.2 (signals-error (make-string-output-stream :foo nil) program-error) t) (deftest make-string-output-stream.error.3 (signals-error (make-string-output-stream :allow-other-keys nil :foo 'bar) program-error) t) gcl-2.6.14/ansi-tests/data-and-control-flow.lsp0000644000175000017500000000165514360276512017710 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:21:48 2002 ;;;; Contains: Overall tests for section 5 of spec, "Data and Control Flow" (in-package :cl-test) ;;; Functions from section 5 (defparameter *dcf-fns* '(apply fboundp fmakunbound funcall function-lambda-expression functionp compiled-function-p not eq eql equal equalp identity complement constantly every some notevery notany values-list get-setf-expansion)) ;;; Macros from section 5 (defparameter *dcf-macros* '(defun defconstant defparameter defvar destructuring-bind psetq return and cond or when unless case ccase ecase multiple-value-list multiple-value-setq nth-value prog prog* prog1 prog2 define-modify-macro defsetf define-setf-expander setf psetf shiftf rotatef)) (deftest dcf-funs (remove-if #'fboundp *dcf-fns*) nil) (deftest dcf-macros (remove-if #'macro-function *dcf-macros*) nil) gcl-2.6.14/ansi-tests/load-cons.lsp0000644000175000017500000000123714360276512015467 0ustar cammcamm;;; Tests of conses (load "cons-test-01.lsp") (load "cons-test-02.lsp") (load "cons-test-03.lsp") (load "cons-test-04.lsp") (load "cons-test-05.lsp") (load "cons-test-06.lsp") (load "cons-test-07.lsp") (load "cons-test-08.lsp") (load "cons-test-09.lsp") (load "cons-test-10.lsp") (load "cons-test-11.lsp") (load "cons-test-12.lsp") (load "cons-test-13.lsp") (load "cons-test-14.lsp") (load "cons-test-15.lsp") (load "cons-test-16.lsp") (load "cons-test-17.lsp") (load "cons-test-18.lsp") (load "cons-test-19.lsp") (load "cons-test-20.lsp") (load "cons-test-21.lsp") (load "cons-test-22.lsp") (load "cons-test-23.lsp") (load "cons-test-24.lsp") (load "cons-test-25.lsp") gcl-2.6.14/ansi-tests/cons-test-10.lsp0000644000175000017500000000327614360276512015752 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:37:21 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 10 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; last (deftest last.1 (last nil) nil) (deftest last.2 (last (copy-tree '(a b))) (b)) (deftest last.3 (last (copy-tree '(a b . c))) (b . c)) (deftest last.4 (last (copy-tree '(a b c d)) 0) nil) (deftest last.5 (last (copy-tree '(a b c d)) 1) (d)) (deftest last.6 (last (copy-tree '(a b c d)) 2) (c d)) (deftest last.7 (last (copy-tree '(a b c d)) 5) (a b c d)) (deftest last.8 (last (cons 'a 'b) 0) b) (deftest last.9 (last (cons 'a 'b) 1) (a . b)) (deftest last.10 (last (cons 'a 'b) 2) (a . b)) (deftest last.order.1 (let ((i 0) x y) (values (last (progn (setf x (incf i)) (list 'a 'b 'c 'd)) (setf y (incf i))) i x y)) (c d) 2 1 2) (deftest last.order.2 (let ((i 0)) (values (last (progn (incf i) (list 'a 'b 'c 'd))) i)) (d) 1) (deftest last.error.1 (classify-error (last (list 'a 'b 'c) -1)) type-error) (deftest last.error.2 (classify-error (last (list 'a 'b 'c) 'a)) type-error) (deftest last.error.3 (classify-error (last (list 'a 'b 'c) 10.0)) type-error) (deftest last.error.4 (classify-error (last (list 'a 'b 'c) -10.0)) type-error) (deftest last.error.5 (classify-error (last (list 'a 'b 'c) #\w)) type-error) (deftest last.error.6 (classify-error (last)) program-error) (deftest last.error.7 (classify-error (last '(a b c) 2 nil)) program-error) (deftest last.error.8 (classify-error (locally (last (list 'a 'b 'c) 'a) t)) type-error) gcl-2.6.14/ansi-tests/vector-push-extend.lsp0000644000175000017500000002201414360276512017350 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 08:04:35 2003 ;;;; Contains: Tests for VECTOR-PUSH-EXTEND (in-package :cl-test) (deftest vector-push-extend.1 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(a b c d e))) (i 0) x y) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) 'x) (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) 2 2 3 #(a b x) 2 1 2) (deftest vector-push-extend.2 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push-extend 'x a) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(a b c d e x)) (deftest vector-push-extend.3 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'base-char))) (values (fill-pointer a) (vector-push-extend #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push-extend.4 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents "abcde" :element-type 'base-char)) (i 0) x y z) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) #\x) (progn (setf y (incf i)) a) (progn (setf z (incf i)) 1)) (fill-pointer a) (<= (array-total-size a) 5) a i x y z)) 5 5 6 nil "abcdex" 3 1 2 3) (deftest vector-push-extend.5 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a) (fill-pointer a) a)) 2 2 3 "abx") (deftest vector-push-extend.6 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents "abcde" :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a 10) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil "abcdex") (deftest vector-push-extend.7 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(0 1 1 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #*010) (deftest vector-push-extend.8 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(0 0 0 0 0) :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 1 a 100) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #*000001) (deftest vector-push-extend.9 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push-extend.10 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1 2 3 4 5) :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1 2 3 4 5 0)) (deftest vector-push-extend.11 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a) (fill-pointer a) a)) 2 2 3 #(1 2 0)) (deftest vector-push-extend.12 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1 2 3 4 5) :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1 2 3 4 5 0)) (deftest vector-push-extend.13 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a) (fill-pointer a) a)) 2 2 3 #(1.0s0 2.0s0 0.0s0)) (deftest vector-push-extend.14 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0 0.0s0)) (deftest vector-push-extend.15 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a) (fill-pointer a) a)) 2 2 3 #(1.0f0 2.0f0 0.0f0)) (deftest vector-push-extend.16 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0 0.0f0)) (deftest vector-push-extend.17 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a) (fill-pointer a) a)) 2 2 3 #(1.0d0 2.0d0 0.0d0)) (deftest vector-push-extend.18 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 0.0d0)) (deftest vector-push-extend.19 (let ((a (make-array '(5) :fill-pointer 2 :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a) (fill-pointer a) a)) 2 2 3 #(1.0l0 2.0l0 0.0l0)) (deftest vector-push-extend.20 (let ((a (make-array '(5) :fill-pointer 5 :adjustable t :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a 1) (fill-pointer a) (<= (array-total-size a) 5) a)) 5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0)) ;;; Error tests (defun vector-push-extend-error-test (seq val) (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) (declare (optimize (safety 3))) (or (notnot (array-has-fill-pointer-p a)) (vector-push-extend ',val a 1)))) (error () t))) (deftest vector-push-extend.error.1 (vector-push-extend-error-test #(a b c d) 'x) t) (deftest vector-push-extend.error.2 (vector-push-extend-error-test #*00000 1) t) (deftest vector-push-extend.error.3 (vector-push-extend-error-test "abcde" #\x) t) (deftest vector-push-extend.error.4 (vector-push-extend-error-test #() 'x) t) (deftest vector-push-extend.error.5 (vector-push-extend-error-test #* 1) t) (deftest vector-push-extend.error.6 (vector-push-extend-error-test "" #\x) t) (deftest vector-push-extend.error.7 (vector-push-extend-error-test (make-array '5 :element-type 'base-char :initial-element #\a) #\x) t) (deftest vector-push-extend.error.8 (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256)) :initial-element 0) 17) t) (deftest vector-push-extend.error.9 (vector-push-extend-error-test (make-array '5 :element-type 'float :initial-element 1.0) 2.0) t) (deftest vector-push-extend.error.10 (vector-push-extend-error-test (make-array '5 :element-type 'short-float :initial-element 1.0s0) 2.0s0) t) (deftest vector-push-extend.error.11 (vector-push-extend-error-test (make-array '5 :element-type 'long-float :initial-element 1.0l0) 2.0l0) t) (deftest vector-push-extend.error.12 (vector-push-extend-error-test (make-array '5 :element-type 'single-float :initial-element 1.0f0) 2.0f0) t) (deftest vector-push-extend.error.13 (vector-push-extend-error-test (make-array '5 :element-type 'double-float :initial-element 1.0d0) 2.0d0) t) (deftest vector-push-extend.error.14 (classify-error (vector-push-extend)) program-error) (deftest vector-push-extend.error.15 (classify-error (vector-push-extend (vector 1 2 3))) program-error) (deftest vector-push-extend.error.16 (classify-error (vector-push-extend (vector 1 2 3) 4 1 nil)) program-error) (deftest vector-push-extend.error.17 (handler-case (eval `(locally (declare (optimize (safety 3))) (let ((a (make-array '5 :fill-pointer t :adjustable nil :initial-element nil))) (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... (vector-push-extend a 'x) ; ... this fails )))) (error () t)) t) gcl-2.6.14/ansi-tests/packages.lsp0000644000175000017500000000121114360276512015356 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 00:32:56 2002 ;;;; Contains: Loader for files containing package tests (load "packages-00.lsp") (load "packages-01.lsp") (load "packages-02.lsp") (load "packages-03.lsp") (load "packages-04.lsp") (load "packages-05.lsp") (load "packages-06.lsp") (load "packages-07.lsp") (load "packages-08.lsp") (load "packages-09.lsp") (load "packages-10.lsp") (load "packages-11.lsp") (load "packages-12.lsp") (load "packages-13.lsp") (load "packages-14.lsp") (load "packages-15.lsp") (load "packages-16.lsp") (load "packages-17.lsp") (load "packages-18.lsp") (load "packages-19.lsp") gcl-2.6.14/ansi-tests/load-test-file.lsp0000644000175000017500000000020414360276512016412 0ustar cammcamm(in-package :cl-test) (defun load-file-test-fun.1 () '#.*load-pathname*) (defun load-file-test-fun.2 () '#.*load-truename*) gcl-2.6.14/ansi-tests/cons-test-25.lsp0000644000175000017500000000263514360276512015756 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Apr 5 22:26:59 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 25 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; setting of C*R accessors (loop for fn in '(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET-ALT") :cl-test) (let ((x (create-c*r-test ,level))) (and (setf (,fn x) 'a) (eql (,fn x) 'a) (setf (,fn x) 'none) (equal x (create-c*r-test ,level)) )) t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) (fifth 5) (sixth 6) (seventh 7) (eighth 8) (ninth 9) (tenth 10)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET-ALT") :cl-test) (let ((x (make-list 20 :initial-element nil))) (and (setf (,fn x) 'a) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) x)) (return nil)) finally (return t)) (eql (,fn x) 'a) (nth ,(1- len) x))) a))) gcl-2.6.14/ansi-tests/handler-bind.lsp0000644000175000017500000000602214360276512016134 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Feb 28 22:07:25 2003 ;;;; Contains: Tests of HANDLER-BIND (in-package :cl-test) (deftest handler-bind.1 (handler-bind ()) nil) (deftest handler-bind.2 (handler-bind () (values))) (deftest handler-bind.3 (handler-bind () (values 1 2 3)) 1 2 3) (deftest handler-bind.4 (let ((x 0)) (values (handler-bind () (incf x) (+ x 10)) x)) 11 1) (deftest handler-bind.5 (block foo (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) (error "an error"))) good) (deftest handler-bind.6 (block foo (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) (handler-bind ((error #'(lambda (c) (error c))) (error #'(lambda (c) (return-from foo 'bad)))) (error "an error")))) good) (defun handler-bind.7-handler-fn (c) (declare (ignore c)) (throw 'foo 'good)) (deftest handler-bind.7 (catch 'foo (handler-bind ((simple-error #'handler-bind.7-handler-fn)) (error "simple error"))) good) (deftest handler-bind.8 (catch 'foo (handler-bind ((simple-error 'handler-bind.7-handler-fn)) (error "simple error"))) good) (deftest handler-bind.9 (catch 'foo (handler-bind ((simple-error #.(symbol-function 'handler-bind.7-handler-fn))) (error "simple error"))) good) (deftest handler-bind.10 (block done (flet ((%foo () (signal "A simple condition")) (%succeed (c) (declare (ignore c)) (return-from done 'good)) (%fail (c) (declare (ignore c)) (return-from done 'bad))) (handler-bind ((error #'%fail) (simple-condition #'%succeed)) (%foo)))) good) (deftest handler-bind.11 (block done (handler-bind ((error #'(lambda (c) c)) (error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) (error "an error"))) good) (deftest handler-bind.12 (block done (handler-bind ((error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) (handler-bind ((error #'(lambda (c) c))) (error "an error")))) good) (deftest handler-bind.13 (handler-bind ((error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (catch 'done (error "an error"))) good) (deftest handler-bind.14 (catch 'done (handler-bind ((symbol #'identity) ;; can never succeed (error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.15 (catch 'done (handler-bind ((t #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.16 (catch 'done (handler-bind (((not error) #'identity) (error #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) (deftest handler-bind.17 (catch 'done (handler-bind ((#.(find-class 'error) #'(lambda (c) (declare (ignore c)) (throw 'done 'good)))) (error "an error"))) good) ;;; More handler-bind tests elsewhere gcl-2.6.14/ansi-tests/host-namestring.lsp0000644000175000017500000000216514360276512016733 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:22:40 2004 ;;;; Contains: Tests of HOST-NAMESTRING (in-package :cl-test) (deftest host-namestring.1 (let* ((vals (multiple-value-list (host-namestring "host-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (or (null s) (stringp s) ;; (equal (host-namestring s) s) )) :good vals)) :good) (deftest host-namestring.2 (do-special-strings (s "host-namestring.lsp" nil) (let ((ns (host-namestring s))) (when ns (assert (stringp ns)) ;; (assert (string= (host-namestring ns) ns)) ))) nil) (deftest host-namestring.3 (let* ((name "host-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (host-namestring s))) (name3 (host-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest host-namestring.error.1 (signals-error (host-namestring) program-error) t) (deftest host-namestring.error.2 (signals-error (host-namestring "host-namestring.lsp" nil) program-error) t) gcl-2.6.14/ansi-tests/substitute.lsp0000644000175000017500000007166114360276512016033 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 21:15:33 2002 ;;;; Contains: Tests for SUBSTITUTE (in-package :cl-test) (deftest substitute-list.1 (let ((x '())) (values (substitute 'b 'a x) x)) nil nil) (deftest substitute-list.2 (let ((x '(a b a c))) (values (substitute 'b 'a x) x)) (b b b c) (a b a c)) (deftest substitute-list.3 (let ((x '(a b a c))) (values (substitute 'b 'a x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-list.4 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-list.5 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-list.6 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-list.7 (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-list.8 (let ((x '())) (values (substitute 'b 'a x :from-end t) x)) nil nil) (deftest substitute-list.9 (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-list.10 (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-list.11 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-list.12 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-list.13 (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-list.14 (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equal orig x) result)) (1 2 x x x x x 8 9)) (deftest substitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equal orig x) result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equal orig x) result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equal orig x) result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equal orig x) result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equal orig x) result)) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equal orig x) result)) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) ;;; Tests on vectors (deftest substitute-vector.1 (let ((x #())) (values (substitute 'b 'a x) x)) #() #()) (deftest substitute-vector.2 (let ((x #(a b a c))) (values (substitute 'b 'a x) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.3 (let ((x #(a b a c))) (values (substitute 'b 'a x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.4 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.5 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-vector.6 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.7 (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.8 (let ((x #())) (values (substitute 'b 'a x :from-end t) x)) #() #()) (deftest substitute-vector.9 (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.10 (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.11 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-vector.12 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-vector.13 (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.14 (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute 'x 'a x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equalp orig x) result)) #(1 2 x x x x x 8 9)) (deftest substitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equalp orig x) result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c -4) (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) (x (copy-seq orig)) (c 5) (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equalp orig x) result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equalp orig x) result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x))) result) #(z b z c b)) (deftest substitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest substitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest substitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-string.1 (let ((x "")) (values (substitute #\b #\a x) x)) "" "") (deftest substitute-string.2 (let ((x "abac")) (values (substitute #\b #\a x) x)) "bbbc" "abac") (deftest substitute-string.3 (let ((x "abac")) (values (substitute #\b #\a x :count nil) x)) "bbbc" "abac") (deftest substitute-string.4 (let ((x "abac")) (values (substitute #\b #\a x :count 2) x)) "bbbc" "abac") (deftest substitute-string.5 (let ((x "abac")) (values (substitute #\b #\a x :count 1) x)) "bbac" "abac") (deftest substitute-string.6 (let ((x "abac")) (values (substitute #\b #\a x :count 0) x)) "abac" "abac") (deftest substitute-string.7 (let ((x "abac")) (values (substitute #\b #\a x :count -1) x)) "abac" "abac") (deftest substitute-string.8 (let ((x "")) (values (substitute #\b #\a x :from-end t) x)) "" "") (deftest substitute-string.9 (let ((x "abac")) (values (substitute #\b #\a x :from-end t) x)) "bbbc" "abac") (deftest substitute-string.10 (let ((x "abac")) (values (substitute #\b #\a x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-string.11 (let ((x "abac")) (values (substitute #\b #\a x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-string.12 (let ((x "abac")) (values (substitute #\b #\a x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-string.13 (let ((x "abac")) (values (substitute #\b #\a x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-string.14 (let ((x "abac")) (values (substitute #\b #\a x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute #\x #\a x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-string.19 (let* ((orig "123456789") (x (copy-seq orig)) (result (substitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (<= (abs (- a b)) 2))))) (and (equalp orig x) result)) "12xxxxx89") (deftest substitute-string.20 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (substitute #\x #\5 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (= (+ b c) a))))) (and (equalp orig x) result)) "12x456789") (deftest substitute-string.21 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (substitute #\x #\9 x :test #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) "1234567x9") (deftest substitute-string.22 (let* ((orig "123456789") (x (copy-seq orig)) (c -4) (result (substitute #\x #\5 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) result)) "12x456789") (deftest substitute-string.23 (let* ((orig "123456789") (x (copy-seq orig)) (c 5) (result (substitute #\x #\9 x :test-not #'(lambda (a b) (setq a (read-from-string (string a))) (setq b (read-from-string (string b))) (incf c -2) (/= (+ b c) a)) :from-end t))) (and (equalp orig x) result)) "1234567x9") (deftest substitute-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-string.26 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) (and (equalp orig x) result)) "0a0aaaa0aa") (deftest substitute-string.27 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) (and (equalp orig x) result)) "0a0aaaa0aa") (deftest substitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x))) result) "zbzcb") (deftest substitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :from-end t))) result) "zbzcb") (deftest substitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :count 1))) result) "zbacb") (deftest substitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute #\z #\a x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest substitute-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute 0 1 x))) (and (equalp orig x) result)) #*) (deftest substitute-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute 1 0 x))) (and (equalp orig x) result)) #*) (deftest substitute-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x))) (and (equalp orig x) result)) #*000000) (deftest substitute-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 0 1 x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute 1 0 x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute 1 0 x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute 0 1 x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) (deftest substitute-bit-vector.22 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) (and (equalp orig x) result)) #*0111110101) (deftest substitute-bit-vector.23 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b))))))) (and (equalp orig x) result)) #*0111110101) (deftest substitute-bit-vector.24 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) :from-end t))) (and (equalp orig x) result)) #*0101011111) (deftest substitute-bit-vector.25 (let* ((orig #*0101010101) (x (copy-seq orig)) (c 0) (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) (not (and (<= 2 c 5) (= a b)))) :from-end t))) (and (equalp orig x) result)) #*0101011111) (deftest substitute-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 1 1 x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-bit-vector.28 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) (and (equalp orig x) result)) #*00000000000000000) (deftest substitute-bit-vector.29 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute 0 1 x :key #'1+ :test-not #'eql))) (and (equalp orig x) result)) #*00000000000000000) (deftest substitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x))) result) #*11111) (deftest substitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :from-end t))) result) #*11111) (deftest substitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :count 1))) result) #*11011) (deftest substitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute 1 0 x :from-end t :count 1))) result) #*01111) (deftest substitute.order.1 (let ((i 0) a b c d e f g h) (values (substitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute.order.2 (let ((i 0) a b c d e f g h) (values (substitute (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) nil) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute.allow-other-keys.1 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.2 (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.3 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.4 (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.5 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute.keywords.6 (substitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (a 2 0 3 a 0 3)) (deftest substitute.allow-other-keys.7 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.8 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) (1 2 a 3 1 a 3)) ;;; Error cases (deftest substitute.error.1 (classify-error (substitute)) program-error) (deftest substitute.error.2 (classify-error (substitute 'a)) program-error) (deftest substitute.error.3 (classify-error (substitute 'a 'b)) program-error) (deftest substitute.error.4 (classify-error (substitute 'a 'b nil 'bad t)) program-error) (deftest substitute.error.5 (classify-error (substitute 'a 'b nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute.error.6 (classify-error (substitute 'a 'b nil :key)) program-error) (deftest substitute.error.7 (classify-error (substitute 'a 'b nil 1 2)) program-error) (deftest substitute.error.8 (classify-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity)) program-error) (deftest substitute.error.9 (classify-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest substitute.error.10 (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons)) program-error) (deftest substitute.error.11 (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'car)) type-error) gcl-2.6.14/ansi-tests/array-row-major-index.lsp0000644000175000017500000000161514360276512017746 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 21:37:03 2003 ;;;; Contains: Tests of ARRAY-ROW-MAJOR-INDEX (in-package :cl-test) ;;; More array-row-major-index tests are in make-array.lsp (deftest array-row-major-index.1 (array-row-major-index #0aNIL) 0) (deftest array-row-major-index.2 (loop for i from 0 to 4 collect (array-row-major-index #(a b c d e) i)) (0 1 2 3 4)) (deftest array-row-major-index.3 (let ((a (make-array '(5) :fill-pointer 1))) (loop for i from 0 to 4 collect (array-row-major-index a i))) (0 1 2 3 4)) (deftest array-row-major-index.order.1 (let ((x 0) y z (a #(a b c d e f))) (values (array-row-major-index (progn (setf y (incf x)) a) (progn (setf z (incf x)) 0)) x y z)) 0 2 1 2) ;;; Error tests (deftest array-row-major-index.error.1 (classify-error (array-row-major-index)) program-error) gcl-2.6.14/ansi-tests/subtypep-real.lsp0000644000175000017500000001033414360276512016402 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Feb 18 18:38:55 2003 ;;;; Contains: Tests of SUBTYPEP on REAL types. (in-package :cl-test) ;;; SUBTYPEP on real types (deftest subtypep.real.1 (loop for tp1 in '((real 10) (real 10 *) (real 10 20) (real (10) 20) (real 10 (20)) (real (10) (20)) (real 10 1000000000000000) (real (10)) (real (10) *)) append (loop for tp2 in '(real (real) (real *) (real * *) (real 10) (real 10 *) (real 0) (real 0 *) (real 19/2) (real 19/2 *) (real 9.5) (real 9.5 *) (real -1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.2 (loop for tp1 in '((real * 10) (real 0 10) (real 0 (10)) (real (0) 10) (real (0) (10)) (real -1000000000000000 10) (real * (10))) append (loop for tp2 in '(real (real) (real *) (real * *) (real * 10) (real * 21/2) (real * 10.5) (real * 1000000000000000)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(t t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.3 (loop for tp1 in '((real 10) (real 10 *) (real 10 20) (real 10 (21)) (real 10 1000000000000000)) append (loop for tp2 in '((real 11) (real 11 *) (real (10)) (real (10) *) (integer 10) (integer 10 *) (real 11) (real (10)) (real 11 *) (real (10) *) (real * (20)) (real * 19) (real * (20)) (real * 19)) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.4 (loop for tp1 in '((real * 10) (real 0 10) (real (0) 10) (real -1000000000000000 10)) append (loop for tp2 in '((real * 9) (real * (10)) (integer * 10) (real * 9) (real * (10))) unless (equal (multiple-value-list (subtypep* tp1 tp2)) '(nil t)) collect (list tp1 tp2))) nil) (deftest subtypep.real.5 (check-equivalence '(or (real 0 0) (real (0))) '(real 0)) nil) (deftest subtypep.real.6 (check-equivalence '(and (real 0 10) (real 5 15)) '(real 5 10)) nil) (deftest subtypep.real.7 (check-equivalence '(and (real (0) 10) (real 5 15)) '(real 5 10)) nil) (deftest subtypep.real.8 (check-equivalence '(and (real 0 (10)) (real 5 15)) '(real 5 (10))) nil) (deftest subtypep.real.9 (check-equivalence '(and (real (0) (10)) (real 5 15)) '(real 5 (10))) nil) (deftest subtypep.real.10 (check-equivalence '(and (real 0 10) (real (5) 15)) '(real (5) 10)) nil) (deftest subtypep.real.11 (check-equivalence '(and (real 0 (10)) (real (5) 15)) '(real (5) (10))) nil) (deftest subtypep.real.12 (check-equivalence '(and integer (real 0 10) (not (real (0) (10)))) '(member 0 10)) nil) (deftest subtypep.real.13 (check-equivalence '(and integer (real -1/2 1/2)) '(integer 0 0)) nil) (deftest subtypep.real.14 (check-equivalence '(and integer (real -1/2 1/2)) '(eql 0)) nil) (deftest subtypep.real.15 (check-equivalence '(and integer (real (-1/2) 1/2)) '(integer 0 0)) nil) (deftest subtypep.real.16 (check-equivalence '(and integer (real (-1/2) (1/2))) '(integer 0 0)) nil) (deftest subtypep.real.17 (check-equivalence '(real 0 10) '(real 0.0 10.0)) nil) (deftest subtypep.real.18 (check-equivalence '(and rational (real 0 10)) '(rational 0 10)) nil) (deftest subtypep.real.19 (check-equivalence '(and rational (real 0 (10))) '(rational 0 (10))) nil) (deftest subtypep.real.20 (check-equivalence '(and rational (real (0) (10))) '(rational (0) (10))) nil) (deftest subtypep.real.21 (check-equivalence '(and rational (real 1/2 7/3)) '(rational 1/2 7/3)) nil) (deftest subtypep.real.22 (check-equivalence '(and rational (real (1/11) (8/37))) '(rational (1/11) (8/37))) nil) (deftest subtypep.real.23 (check-all-subtypep '(not (real -1/2 1/2)) '(not (integer 0 0))) nil) (deftest subtypep.real.24 (check-all-subtypep '(not (real -1/2 1/2)) '(not (eql 0))) nil) gcl-2.6.14/ansi-tests/cons-test-02.lsp0000644000175000017500000006376714360276512015766 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:30:50 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 2 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; copy-tree ;; Try copy-tree on a tree containing elements of various kinds (deftest copy-tree.1 (let ((x (cons 'a (list (cons 'b 'c) (cons 1 1.2) (list (list "abcde" (make-array '(10) :initial-element (cons 'e 'f))) 'g))))) (let ((y (copy-tree x))) (check-cons-copy x y))) t) ;; Try copy-tree on *universe* (deftest copy-tree.2 (let* ((x (copy-list *universe*)) (y (copy-tree x))) (check-cons-copy x y)) t) (deftest copy-tree.order.1 (let ((i 0)) (values (copy-tree (progn (incf i) '(a b c))) i)) (a b c) 1) (deftest copy-tree.error.1 (classify-error (copy-tree)) program-error) (deftest copy-tree.error.2 (classify-error (copy-tree 'a 'b)) program-error) ;;; (deftest sublis.1 (check-sublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest sublis.2 (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest sublis.3 (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest sublis.4 (check-sublis (sublis (copy-tree '((a . 2) (b . 4) (c . 1))) (copy-tree '(a b c d e (a b c a d b) f))) '((t . "yes")) :key #'(lambda (x) (and (typep x 'integer) (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest sublis.5 (check-sublis '("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")) `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest sublis.6 (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) ("fee" "fie")) `((,(copy-seq "fie") . #\f)) :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest sublis.7 (check-sublis '(("aa" a b) (z "bb" d) ((x . "aa"))) `((,(copy-seq "aa") . 1) (,(copy-seq "bb") . 2)) :test 'equal :key #'(lambda (x) (if (consp x) (car x) '*not-present*))) (1 (z . 2) ((x . "aa")))) ;; Check that a null key arg is ignored. (deftest sublis.8 (check-sublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) (2 2 b b)) ;;; Order of argument evaluation (deftest sublis.order.1 (let ((i 0) w x y z) (values (sublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (z b c d) 4 1 2 3 4) (deftest sublis.order.2 (let ((i 0) w x y z) (values (sublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) i w x y z)) (z b c d) 4 1 2 3 4) ;;; Keyword tests (deftest sublis.allow-other-keys.1 (sublis nil 'a :bad t :allow-other-keys t) a) (deftest sublis.allow-other-keys.2 (sublis nil 'a :allow-other-keys t :bad t) a) (deftest sublis.allow-other-keys.3 (sublis nil 'a :allow-other-keys t) a) (deftest sublis.allow-other-keys.4 (sublis nil 'a :allow-other-keys nil) a) (deftest sublis.allow-other-keys.5 (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) a) (deftest sublis.keywords.6 (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) :key #'identity) (a 1 2)) ;; Argument error cases (deftest sublis.error.1 (classify-error (sublis)) program-error) (deftest sublis.error.2 (classify-error (sublis nil)) program-error) (deftest sublis.error.3 (classify-error (sublis nil 'a :test)) program-error) (deftest sublis.error.4 (classify-error (sublis nil 'a :bad-keyword t)) program-error) (deftest sublis.error.5 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity)) program-error) (deftest sublis.error.6 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons)) program-error) (deftest sublis.error.7 (classify-error (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity)) program-error) ;; nsublis (deftest nsublis.1 (check-nsublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest nsublis.2 (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest nsublis.3 (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest nsublis.4 (check-nsublis (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) (copy-tree '(a b c d e (a b c a d b) f))) '((t . "yes")) :key #'(lambda (x) (and (typep x 'integer) (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest nsublis.5 (check-nsublis '("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")) `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest nsublis.6 (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) ("fee" "fie")) `((,(copy-seq "fie") . #\f)) :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest nsublis.7 (check-nsublis '(("aa" a b) (z "bb" d) ((x . "aa"))) `((,(copy-seq "aa") . 1) (,(copy-seq "bb") . 2)) :test 'equal :key #'(lambda (x) (if (consp x) (car x) '*not-present*))) (1 (z . 2) ((x . "aa")))) (deftest nsublis.8 (nsublis nil 'a :bad-keyword t :allow-other-keys t) a) ;; Check that a null key arg is ignored. (deftest nsublis.9 (check-nsublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) (2 2 b b)) ;;; Order of argument evaluation (deftest nsublis.order.1 (let ((i 0) w x y z) (values (nsublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (z b c d) 4 1 2 3 4) (deftest nsublis.order.2 (let ((i 0) w x y z) (values (nsublis (progn (setf w (incf i)) '((a . z))) (progn (setf x (incf i)) (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) i w x y z)) (z b c d) 4 1 2 3 4) ;;; Keyword tests (deftest nsublis.allow-other-keys.1 (nsublis nil 'a :bad t :allow-other-keys t) a) (deftest nsublis.allow-other-keys.2 (nsublis nil 'a :allow-other-keys t :bad t) a) (deftest nsublis.allow-other-keys.3 (nsublis nil 'a :allow-other-keys t) a) (deftest nsublis.allow-other-keys.4 (nsublis nil 'a :allow-other-keys nil) a) (deftest nsublis.allow-other-keys.5 (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) a) (deftest nsublis.keywords.6 (nsublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) :key #'identity) (a 1 2)) ;; Argument error cases (deftest nsublis.error.1 (classify-error (nsublis)) program-error) (deftest nsublis.error.2 (classify-error (nsublis nil)) program-error) (deftest nsublis.error.3 (classify-error (nsublis nil 'a :test)) program-error) (deftest nsublis.error.4 (classify-error (nsublis nil 'a :bad-keyword t)) program-error) (deftest nsublis.error.5 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test #'identity)) program-error) (deftest nsublis.error.6 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :key #'cons)) program-error) (deftest nsublis.error.7 (classify-error (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) :test-not #'identity)) program-error) ;;;;;; (deftest sublis.shared (let* ((shared-piece (list 'a 'b)) (a (list shared-piece shared-piece))) (check-sublis a '((a . b) (b . a)))) ((b a) (b a))) (defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) (deftest subst.1 (check-subst "Z" 30 (copy-tree *subst-tree-1*)) (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) (deftest subst.2 (check-subst "A" 0 (copy-tree *subst-tree-1*)) (10 (30 20 10) (20 10) (10 20 30 40))) (deftest subst.3 (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) "Z") (deftest subst.4 (check-subst 'grape 'dick '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest subst.5 (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) (deftest subst.6 (check-subst '(1 2) '(foo . bar) '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) :test #'equal) ((foo . baz) (1 2) (bar . foo) (baz 1 2))) (deftest subst.7 (check-subst 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) "aaa" nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest subst.8 (check-subst 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) (copy-seq "aaa") nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest subst.9 (check-subst 'a 'b (copy-tree '(a b c d a b)) :key nil) (a a c d a a)) ;;; Order of argument evaluation (deftest subst.order.1 (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) (deftest subst.order.2 (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) ;;; Keyword tests for subst (deftest subst.allow-other-keys.1 (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) (a a c)) (deftest subst.allow-other-keys.2 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) (a a c)) (deftest subst.allow-other-keys.3 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) (a a c)) (deftest subst.allow-other-keys.4 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) (a a c)) (deftest subst.allow-other-keys.5 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil :bad t) (a a c)) (deftest subst.keywords.6 (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) (a a c)) ;;; Tests for subst-if, subst-if-not (deftest subst-if.1 (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest subst-if-not.1 (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) ((x) (x) x) ((x) (x) (x) x) ((x) (x) (x) (x) x) x)) (deftest subst-if.2 (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) (17 (17 17) (17 17 17) (17 nil 17 17 17))) (deftest subst-if.3 (check-subst-if '(z) (complement #'consp) '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) ((z) (z) (z) (z) z) z)) (deftest subst-if-not.2 (check-subst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest subst-if.4 (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (deftest subst-if-not.3 (check-subst-if-not 'c #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key (complement #'listp)) c) (deftest subst-if.5 (check-subst-if 4 #'(lambda (x) (eql x 1)) '((1 3) (1) (1 10 20 30) (1 3 x y)) :key #'(lambda (x) (and (consp x) (car x)))) (4 4 4 4)) (deftest subst-if-not.4 (check-subst-if-not 40 #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) (and (consp x) (car x)))) (40 40 40 40)) (deftest subst-if.6 (check-subst-if 'a #'(lambda (x) (eql x 'b)) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest subst-if-not.5 (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest subst-if.7 (let ((i 0) w x y z) (values (subst-if (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) (deftest subst-if-not.7 (let ((i 0) w x y z) (values (subst-if-not (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) ;;; Keyword tests for subst-if (deftest subst-if.allow-other-keys.1 (subst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest subst-if.allow-other-keys.2 (subst-if 'a #'null nil :allow-other-keys t) a) (deftest subst-if.allow-other-keys.3 (subst-if 'a #'null nil :allow-other-keys nil) a) (deftest subst-if.allow-other-keys.4 (subst-if 'a #'null nil :allow-other-keys t :bad t) a) (deftest subst-if.allow-other-keys.5 (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest subst-if.keywords.6 (subst-if 'a #'null nil :key nil :key (constantly 'b)) a) ;;; Keywords tests for subst-if-not (deftest subst-if-not.allow-other-keys.1 (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) a) (deftest subst-if-not.allow-other-keys.2 (subst-if-not 'a #'identity nil :allow-other-keys t) a) (deftest subst-if-not.allow-other-keys.3 (subst-if-not 'a #'identity nil :allow-other-keys nil) a) (deftest subst-if-not.allow-other-keys.4 (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) a) (deftest subst-if-not.allow-other-keys.5 (subst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest subst-if-not.keywords.6 (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) a) (defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) (deftest nsubst.1 (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) (deftest nsubst.2 (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) (10 (30 20 10) (20 10) (10 20 30 40))) (deftest nsubst.3 (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) "Z") (deftest nsubst.4 (check-nsubst 'grape 'dick '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest nsubst.5 (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) (deftest nsubst.6 (check-nsubst '(1 2) '(foo . bar) '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) :test #'equal) ((foo . baz) (1 2) (bar . foo) (baz 1 2))) (deftest nsubst.7 (check-nsubst 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) "aaa" nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest nsubst.8 (check-nsubst 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) (copy-seq "aaa") nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest nsubst.9 (check-nsubst 'a 'b (copy-tree '(a b c d a b)) :key nil) (a a c d a a)) ;;; Order of argument evaluation (deftest nsubst.order.1 (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) (deftest nsubst.order.2 (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) ;;; Keyword tests for nsubst (deftest nsubst.allow-other-keys.1 (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) (a a c)) (deftest nsubst.allow-other-keys.2 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) (a a c)) (deftest nsubst.allow-other-keys.3 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) (a a c)) (deftest nsubst.allow-other-keys.4 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) (a a c)) (deftest nsubst.allow-other-keys.5 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil :bad t) (a a c)) (deftest nsubst.keywords.6 (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) (a a c)) ;;; Tests for nsubst-if, nsubst-if-not (deftest nsubst-if.1 (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest nsubst-if-not.1 (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) ((x) (x) x) ((x) (x) (x) x) ((x) (x) (x) (x) x) x)) (deftest nsubst-if.2 (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) (17 (17 17) (17 17 17) (17 nil 17 17 17))) (deftest nsubst-if.3 (check-nsubst-if '(z) (complement #'consp) '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) ((z) (z) (z) (z) z) z)) (deftest nsubst-if-not.2 (check-nsubst-if-not 'a (complement #'listp) '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest nsubst-if.4 (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key #'listp) b) (deftest nsubst-if-not.3 (check-nsubst-if-not 'c #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) :key (complement #'listp)) c) (deftest nsubst-if.5 (check-nsubst-if 4 #'(lambda (x) (eql x 1)) '((1 3) (1) (1 10 20 30) (1 3 x y)) :key #'(lambda (x) (and (consp x) (car x)))) (4 4 4 4)) (deftest nsubst-if-not.4 (check-nsubst-if-not 40 #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) (and (consp x) (car x)))) (40 40 40 40)) (deftest nsubst-if.6 (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest nsubst-if-not.5 (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) '((a) (b) (c) (d)) :key nil) ((a) (a) (c) (d))) (deftest nsubst-if.7 (nsubst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest nsubst-if-not.6 (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) nil) (deftest nsubst-if.8 (let ((i 0) w x y z) (values (nsubst-if (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) (deftest nsubst-if-not.7 (let ((i 0) w x y z) (values (nsubst-if-not (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) (progn (setf y (incf i)) (copy-list '(1 2 a b c))) :key (progn (setf z (incf i)) #'identity)) i w x y z)) (1 2 a a c) 4 1 2 3 4) ;;; Keyword tests for nsubst-if (deftest nsubst-if.allow-other-keys.1 (nsubst-if 'a #'null nil :bad t :allow-other-keys t) a) (deftest nsubst-if.allow-other-keys.2 (nsubst-if 'a #'null nil :allow-other-keys t) a) (deftest nsubst-if.allow-other-keys.3 (nsubst-if 'a #'null nil :allow-other-keys nil) a) (deftest nsubst-if.allow-other-keys.4 (nsubst-if 'a #'null nil :allow-other-keys t :bad t) a) (deftest nsubst-if.allow-other-keys.5 (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest nsubst-if.keywords.6 (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) a) ;;; Keywords tests for nsubst-if-not (deftest nsubst-if-not.allow-other-keys.1 (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) a) (deftest nsubst-if-not.allow-other-keys.2 (nsubst-if-not 'a #'identity nil :allow-other-keys t) a) (deftest nsubst-if-not.allow-other-keys.3 (nsubst-if-not 'a #'identity nil :allow-other-keys nil) a) (deftest nsubst-if-not.allow-other-keys.4 (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) a) (deftest nsubst-if-not.allow-other-keys.5 (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) a) (deftest nsubst-if-not.keywords.6 (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) a) ;;; Error cases ;;; subst (deftest subst.error.1 (classify-error (subst)) program-error) (deftest subst.error.2 (classify-error (subst 'a)) program-error) (deftest subst.error.3 (classify-error (subst 'a 'b)) program-error) (deftest subst.error.4 (classify-error (subst 'a 'b nil :foo nil)) program-error) (deftest subst.error.5 (classify-error (subst 'a 'b nil :test)) program-error) (deftest subst.error.6 (classify-error (subst 'a 'b nil 1)) program-error) (deftest subst.error.7 (classify-error (subst 'a 'b nil :bad t :allow-other-keys nil)) program-error) (deftest subst.error.8 (classify-error (subst 'a 'b (list 'a 'b) :test #'identity)) program-error) (deftest subst.error.9 (classify-error (subst 'a 'b (list 'a 'b) :test-not #'identity)) program-error) (deftest subst.error.10 (classify-error (subst 'a 'b (list 'a 'b) :key #'equal)) program-error) ;;; nsubst (deftest nsubst.error.1 (classify-error (nsubst)) program-error) (deftest nsubst.error.2 (classify-error (nsubst 'a)) program-error) (deftest nsubst.error.3 (classify-error (nsubst 'a 'b)) program-error) (deftest nsubst.error.4 (classify-error (nsubst 'a 'b nil :foo nil)) program-error) (deftest nsubst.error.5 (classify-error (nsubst 'a 'b nil :test)) program-error) (deftest nsubst.error.6 (classify-error (nsubst 'a 'b nil 1)) program-error) (deftest nsubst.error.7 (classify-error (nsubst 'a 'b nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst.error.8 (classify-error (nsubst 'a 'b (list 'a 'b) :test #'identity)) program-error) (deftest nsubst.error.9 (classify-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity)) program-error) (deftest nsubst.error.10 (classify-error (nsubst 'a 'b (list 'a 'b) :key #'equal)) program-error) ;;; subst-if (deftest subst-if.error.1 (classify-error (subst-if)) program-error) (deftest subst-if.error.2 (classify-error (subst-if 'a)) program-error) (deftest subst-if.error.3 (classify-error (subst-if 'a #'null)) program-error) (deftest subst-if.error.4 (classify-error (subst-if 'a #'null nil :foo nil)) program-error) (deftest subst-if.error.5 (classify-error (subst-if 'a #'null nil :test)) program-error) (deftest subst-if.error.6 (classify-error (subst-if 'a #'null nil 1)) program-error) (deftest subst-if.error.7 (classify-error (subst-if 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest subst-if.error.8 (classify-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; subst-if-not (deftest subst-if-not.error.1 (classify-error (subst-if-not)) program-error) (deftest subst-if-not.error.2 (classify-error (subst-if-not 'a)) program-error) (deftest subst-if-not.error.3 (classify-error (subst-if-not 'a #'null)) program-error) (deftest subst-if-not.error.4 (classify-error (subst-if-not 'a #'null nil :foo nil)) program-error) (deftest subst-if-not.error.5 (classify-error (subst-if-not 'a #'null nil :test)) program-error) (deftest subst-if-not.error.6 (classify-error (subst-if-not 'a #'null nil 1)) program-error) (deftest subst-if-not.error.7 (classify-error (subst-if-not 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest subst-if-not.error.8 (classify-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; nsubst-if (deftest nsubst-if.error.1 (classify-error (nsubst-if)) program-error) (deftest nsubst-if.error.2 (classify-error (nsubst-if 'a)) program-error) (deftest nsubst-if.error.3 (classify-error (nsubst-if 'a #'null)) program-error) (deftest nsubst-if.error.4 (classify-error (nsubst-if 'a #'null nil :foo nil)) program-error) (deftest nsubst-if.error.5 (classify-error (nsubst-if 'a #'null nil :test)) program-error) (deftest nsubst-if.error.6 (classify-error (nsubst-if 'a #'null nil 1)) program-error) (deftest nsubst-if.error.7 (classify-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst-if.error.8 (classify-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons)) program-error) ;;; nsubst-if-not (deftest nsubst-if-not.error.1 (classify-error (nsubst-if-not)) program-error) (deftest nsubst-if-not.error.2 (classify-error (nsubst-if-not 'a)) program-error) (deftest nsubst-if-not.error.3 (classify-error (nsubst-if-not 'a #'null)) program-error) (deftest nsubst-if-not.error.4 (classify-error (nsubst-if-not 'a #'null nil :foo nil)) program-error) (deftest nsubst-if-not.error.5 (classify-error (nsubst-if-not 'a #'null nil :test)) program-error) (deftest nsubst-if-not.error.6 (classify-error (nsubst-if-not 'a #'null nil 1)) program-error) (deftest nsubst-if-not.error.7 (classify-error (nsubst-if-not 'a #'null nil :bad t :allow-other-keys nil)) program-error) (deftest nsubst-if-not.error.8 (classify-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/cons-test-23.lsp0000644000175000017500000004006614360276512015754 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 21:49:43 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 23 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; set-exclusive-or (deftest set-exclusive-or.1 (set-exclusive-or nil nil) nil) (deftest set-exclusive-or.2 (let ((result (set-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest set-exclusive-or.3 (let ((result (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) (deftest set-exclusive-or.4 (sort (copy-list (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) (deftest set-exclusive-or.5 (check-set-exclusive-or nil '(a b c d e f g h) (set-exclusive-or-with-check nil '(a b c d e f g h))) t) (deftest set-exclusive-or.6 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest set-exclusive-or.7 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest set-exclusive-or.7-a (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) (c)) (deftest set-exclusive-or.8 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest set-exclusive-or.8-a (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) (c)) (deftest set-exclusive-or.8-b (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test-not (complement #'eql)) (c)) (deftest set-exclusive-or.9 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest set-exclusive-or.10 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest set-exclusive-or.11 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest set-exclusive-or.12 (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest set-exclusive-or.13 (do-random-set-exclusive-ors 100 100) nil) (deftest set-exclusive-or.14 (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) '((a . 10) (c . 3)) :key 'car) ((b . 2))) (deftest set-exclusive-or.15 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car) ((b . 2))) (deftest set-exclusive-or.16 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car :test-not (complement #'eql)) ((b . 2))) ;; ;; Check that set-exclusive-or does not invert ;; the order of the arguments to the test function ;; (deftest set-exclusive-or.17 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest set-exclusive-or.17-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :key #'identity :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest set-exclusive-or.18 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) (deftest set-exclusive-or.18-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check list1 list2 :key #'identity :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) ;;; Order of argument evaluation tests (deftest set-exclusive-or.order.1 (let ((i 0) x y) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) (deftest set-exclusive-or.order.2 (let ((i 0) x y z) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) (deftest set-exclusive-or.order.3 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest set-exclusive-or.order.4 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest set-exclusive-or.order.5 (let ((i 0) x y z w) (values (sort (set-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :key (progn (setf w (incf i)) (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) ;;; Keyword tests (deftest set-exclusive.allow-other-keys.1 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :bad t :allow-other-keys t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.2 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.3 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y)))) #'<) (1 6)) (deftest set-exclusive.allow-other-keys.4 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.5 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys nil) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.6 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.7 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 6)) (deftest set-exclusive.keywords.8 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'eql :test #'/=) #'<) (1 2 5 6)) (deftest set-exclusive.keywords.9 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'/= :test #'eql) #'<) nil) (deftest set-exclusive-or.error.1 (classify-error (set-exclusive-or)) program-error) (deftest set-exclusive-or.error.2 (classify-error (set-exclusive-or nil)) program-error) (deftest set-exclusive-or.error.3 (classify-error (set-exclusive-or nil nil :bad t)) program-error) (deftest set-exclusive-or.error.4 (classify-error (set-exclusive-or nil nil :key)) program-error) (deftest set-exclusive-or.error.5 (classify-error (set-exclusive-or nil nil 1 2)) program-error) (deftest set-exclusive-or.error.6 (classify-error (set-exclusive-or nil nil :bad t :allow-other-keys nil)) program-error) (deftest set-exclusive-or.error.7 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest set-exclusive-or.error.8 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest set-exclusive-or.error.9 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest set-exclusive-or.error.10 (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nset-exclusive-or (deftest nset-exclusive-or.1 (nset-exclusive-or nil nil) nil) (deftest nset-exclusive-or.2 (let ((result (nset-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest nset-exclusive-or.3 (let ((result (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) (deftest nset-exclusive-or.4 (sort (copy-list (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) (deftest nset-exclusive-or.5 (check-set-exclusive-or nil '(a b c d e f g h) (nset-exclusive-or-with-check nil '(a b c d e f g h))) t) (deftest nset-exclusive-or.6 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :key nil) (c)) (deftest nset-exclusive-or.7 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) (c)) (deftest nset-exclusive-or.7-a (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) (c)) (deftest nset-exclusive-or.8 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) (c)) (deftest nset-exclusive-or.8-a (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) (c)) (deftest nset-exclusive-or.8-b (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test-not (complement #'eql)) (c)) (deftest nset-exclusive-or.9 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) (c)) (deftest nset-exclusive-or.10 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eq) (c)) (deftest nset-exclusive-or.11 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'eql) (c)) (deftest nset-exclusive-or.12 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test 'equal) (c)) (deftest nset-exclusive-or.13 (do-random-nset-exclusive-ors 100 100) nil) (deftest nset-exclusive-or.14 (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) '((a . 10) (c . 3)) :key 'car) ((b . 2))) (deftest nset-exclusive-or.15 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car) ((b . 2))) (deftest nset-exclusive-or.16 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) '((a . 1) (c . 3313)) :key #'car :test-not (complement #'eql)) ((b . 2))) ;; ;; Check that nset-exclusive-or does not invert ;; the order of the arguments to the test function ;; (deftest nset-exclusive-or.17 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.17-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :key #'identity :test #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.18 (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) (deftest nset-exclusive-or.18-a (let ((list1 '(a b c d)) (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check list1 list2 :key #'identity :test-not #'(lambda (s1 s2) (when (or (member s1 list2) (member s2 list1)) (return-from fail 'failed)) t))))) t) ;;; Order of argument evaluation tests (deftest nset-exclusive-or.order.1 (let ((i 0) x y) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) (deftest nset-exclusive-or.order.2 (let ((i 0) x y z) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) (deftest nset-exclusive-or.order.3 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest nset-exclusive-or.order.4 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) (deftest nset-exclusive-or.order.5 (let ((i 0) x y z w) (values (sort (nset-exclusive-or (progn (setf x (incf i)) (list 1 2 3 4)) (progn (setf y (incf i)) (list 1 3 6 10)) :key (progn (setf z (incf i)) nil) :key (progn (setf w (incf i)) (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) ;;; Keyword tests (deftest nset-exclusive.allow-other-keys.1 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :bad t :allow-other-keys t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.2 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.3 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y)))) #'<) (1 6)) (deftest nset-exclusive.allow-other-keys.4 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.5 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys nil) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.6 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.7 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.8 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'eql :test #'/=) #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.9 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) :test #'/= :test #'eql) #'<) nil) ;;; Error tests (deftest nset-exclusive-or.error.1 (classify-error (nset-exclusive-or)) program-error) (deftest nset-exclusive-or.error.2 (classify-error (nset-exclusive-or nil)) program-error) (deftest nset-exclusive-or.error.3 (classify-error (nset-exclusive-or nil nil :bad t)) program-error) (deftest nset-exclusive-or.error.4 (classify-error (nset-exclusive-or nil nil :key)) program-error) (deftest nset-exclusive-or.error.5 (classify-error (nset-exclusive-or nil nil 1 2)) program-error) (deftest nset-exclusive-or.error.6 (classify-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil)) program-error) (deftest nset-exclusive-or.error.7 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nset-exclusive-or.error.8 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nset-exclusive-or.error.9 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nset-exclusive-or.error.10 (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car)) type-error) gcl-2.6.14/ansi-tests/cons-test-20.lsp0000644000175000017500000002250214360276512015744 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 22:11:27 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 20 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; union (deftest union.1 (union nil nil) nil) (deftest union.2 (union-with-check (list 'a) nil) (a)) (deftest union.3 (union-with-check (list 'a) (list 'a)) (a)) (deftest union-4 (union-with-check (list 1) (list 1)) (1)) (deftest union.5 (let ((x (list 'a 'b))) (union-with-check (list x) (list x))) ((a b))) (deftest union.6 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.6-a (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eq))) (check-union x y result))) t) (deftest union.7 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.8 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.9 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.10 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.11 (let ((x (copy-list '(a b c d e f))) (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eq)))) (check-union x y result))) t) (deftest union.12 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.13 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.14 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.15 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.16 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.17 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+))) (check-union x y result))) t) (deftest union.18 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) (check-union x y result))) t) (deftest union.19 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) (check-union x y result))) t) (deftest union.20 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.21 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.22 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y nil))) (check-union x y result))) t) (deftest union.23 (let ((x (copy-list '(1 2 3 4 5 6 7))) (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y '1+))) (check-union x y result))) t) ;; Do large numbers of random units (deftest union.24 (do-random-unions 100 100 200) nil) (deftest union.25 (let ((x (shuffle '(1 4 6 10 45 101))) (y (copy-list '(102 5 2 11 44 6)))) (let ((result (union-with-check x y :test #'(lambda (a b) (<= (abs (- a b)) 1))))) (and (not (eqt result 'failed)) (sort (sublis '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) (copy-list result)) #'<)))) (1 4 6 10 44 101)) ;;; Check that union uses eql, not equal or eq (deftest union.26 (let ((x 1000) (y 1000)) (loop while (not (typep x 'bignum)) do (progn (setf x (* x x)) (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (union-with-check (list x) (list x))) 1)))) t) (deftest union.27 (union-with-check (list (copy-seq "aa")) (list (copy-seq "aa"))) ("aa" "aa")) ;; Check that union does not reverse the arguments to :test, :test-not (deftest union.28 (block fail (sort (union-with-check (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest union.29 (block fail (sort (union-with-check-and-key (list 1 2 3) (list 4 5 6) #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest union.30 (block fail (sort (union-with-check (list 1 2 3) (list 4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) (deftest union.31 (block fail (sort (union-with-check-and-key (list 1 2 3) (list 4 5 6) #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) ;;; Order of evaluation tests (deftest union.order.1 (let ((i 0) x y) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) 2 1 2) (deftest union.order.2 (let ((i 0) x y z w) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) (deftest union.order.3 (let ((i 0) x y z w) (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) ;;; Keyword tests (deftest union.allow-other-keys.1 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t :allow-other-keys "yes") #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.2 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :also-bad t) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.3 (sort (union (list 1 2 3) (list 1 2 3) :allow-other-keys t :also-bad t :test #'(lambda (x y) (= x (+ y 100)))) #'<) (1 1 2 2 3 3)) (deftest union.allow-other-keys.4 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.5 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.6 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.7 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 7 9 10 11 20)) (deftest union.keywords.9 (sort (union (list 1 2 3) (list 1 2 3) :test #'(lambda (x y) (= x (+ y 100))) :test #'eql) #'<) (1 1 2 2 3 3)) ;;; Error tests (deftest union.error.1 (classify-error (union)) program-error) (deftest union.error.2 (classify-error (union nil)) program-error) (deftest union.error.3 (classify-error (union nil nil :bad t)) program-error) (deftest union.error.4 (classify-error (union nil nil :key)) program-error) (deftest union.error.5 (classify-error (union nil nil 1 2)) program-error) (deftest union.error.6 (classify-error (union nil nil :bad t :allow-other-keys nil)) program-error) (deftest union.error.7 (classify-error (union (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest union.error.8 (classify-error (union (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest union.error.9 (classify-error (union (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest union.error.10 (classify-error (union (list 1 2) (list 3 4) :key #'car)) type-error) gcl-2.6.14/ansi-tests/svref.lsp0000644000175000017500000000223214360276512014731 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:39:30 2003 ;;;; Contains: Tests of SVREF (in-package :cl-test) (deftest svref.1 (let ((a (vector 1 2 3 4))) (loop for i below 4 collect (svref a i))) (1 2 3 4)) (deftest svref.2 (let ((a (vector 1 2 3 4))) (values (loop for i below 4 collect (setf (svref a i) (+ i 10))) a)) (10 11 12 13) #(10 11 12 13)) (deftest svref.order.1 (let ((v (vector 'a 'b 'c 'd)) (i 0) a b) (values (svref (progn (setf a (incf i)) v) (progn (setf b (incf i)) 2)) i a b)) c 2 1 2) (deftest svref.order.2 (let ((v (vector 'a 'b 'c 'd)) (i 0) a b c) (values (setf (svref (progn (setf a (incf i)) v) (progn (setf b (incf i)) 2)) (progn (setf c (incf i)) 'w)) v i a b c)) w #(a b w d) 3 1 2 3) ;;; Error tests (deftest svref.error.1 (classify-error (svref)) program-error) (deftest svref.error.2 (classify-error (svref (vector 1))) program-error) (deftest svref.error.3 (classify-error (svref (vector 1) 0 0)) program-error) (deftest svref.error.4 (classify-error (svref (vector 1) 0 nil)) program-error) gcl-2.6.14/ansi-tests/handler-case.lsp0000644000175000017500000000031214360276512016127 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 14:08:07 2003 ;;;; Contains: Tests of HANDLER-CASE (in-package :cl-test) ;;; (deftest handler-case.1 ;;; (handler-case (( gcl-2.6.14/ansi-tests/cl-symbol-names.lsp0000644000175000017500000010237014360276512016612 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 21:49:33 2002 ;;;; Contains: Names of standard CL symbols (in-package :cl-test) ;;; ;;; These are the names of the 978 symbols that can and must be external to ;;; the COMMON-LISP package. ;;; (defparameter *cl-symbol-names* (mapcar #'string '( #:&allow-other-keys #:&aux #:&body #:&environment #:&key #:&optional #:&rest #:&whole #:* #:** #:*** #:*break-on-signals* #:*compile-file-pathname* #:*compile-file-truename* #:*compile-print* #:*compile-verbose* #:*debug-io* #:*debugger-hook* #:*default-pathname-defaults* #:*error-output* #:*features* #:*gensym-counter* #:*load-pathname* #:*load-print* #:*load-truename* #:*load-verbose* #:*macroexpand-hook* #:*modules* #:*package* #:*print-array* #:*print-base* #:*print-case* #:*print-circle* #:*print-escape* #:*print-gensym* #:*print-length* #:*print-level* #:*print-lines* #:*print-miser-width* #:*print-pprint-dispatch* #:*print-pretty* #:*print-radix* #:*print-readably* #:*print-right-margin* #:*query-io* #:*random-state* #:*read-base* #:*read-default-float-format* #:*read-eval* #:*read-suppress* #:*readtable* #:*standard-input* #:*standard-output* #:*terminal-io* #:*trace-output* #:+ #:++ #:+++ #:- #:/ #:// #:/// #:/= #:1+ #:1- #:< #:<= #:= #:> #:>= #:abort #:abs #:acons #:acos #:acosh #:add-method #:adjoin #:adjust-array #:adjustable-array-p #:allocate-instance #:alpha-char-p #:alphanumericp #:and #:append #:apply #:apropos #:apropos-list #:aref #:arithmetic-error #:arithmetic-error-operands #:arithmetic-error-operation #:array #:array-dimension #:array-dimension-limit #:array-dimensions #:array-displacement #:array-element-type #:array-has-fill-pointer-p #:array-in-bounds-p #:array-rank #:array-rank-limit #:array-row-major-index #:array-total-size #:array-total-size-limit #:arrayp #:ash #:asin #:asinh #:assert #:assoc #:assoc-if #:assoc-if-not #:atan #:atanh #:atom #:base-char #:base-string #:bignum #:bit #:bit-and #:bit-andc1 #:bit-andc2 #:bit-eqv #:bit-ior #:bit-nand #:bit-nor #:bit-not #:bit-orc1 #:bit-orc2 #:bit-vector #:bit-vector-p #:bit-xor #:block #:boole #:boole-1 #:boole-2 #:boole-and #:boole-andc1 #:boole-andc2 #:boole-c1 #:boole-c2 #:boole-clr #:boole-eqv #:boole-ior #:boole-nand #:boole-nor #:boole-orc1 #:boole-orc2 #:boole-set #:boole-xor #:boolean #:both-case-p #:boundp #:break #:broadcast-stream #:broadcast-stream-streams #:built-in-class #:butlast #:byte #:byte-position #:byte-size #:caaaar #:caaadr #:caaar #:caadar #:caaddr #:caadr #:caar #:cadaar #:cadadr #:cadar #:caddar #:cadddr #:caddr #:cadr #:call-arguments-limit #:call-method #:call-next-method #:car #:case #:catch #:ccase #:cdaaar #:cdaadr #:cdaar #:cdadar #:cdaddr #:cdadr #:cdar #:cddaar #:cddadr #:cddar #:cdddar #:cddddr #:cdddr #:cddr #:cdr #:ceiling #:cell-error #:cell-error-name #:cerror #:change-class #:char #:char-code #:char-code-limit #:char-downcase #:char-equal #:char-greaterp #:char-int #:char-lessp #:char-name #:char-not-equal #:char-not-greaterp #:char-not-lessp #:char-upcase #:char/= #:char< #:char<= #:char= #:char> #:char>= #:character #:characterp #:check-type #:cis #:class #:class-name #:class-of #:clear-input #:clear-output #:close #:clrhash #:code-char #:coerce #:compilation-speed #:compile #:compile-file #:compile-file-pathname #:compiled-function #:compiled-function-p #:compiler-macro #:compiler-macro-function #:complement #:complex #:complexp #:compute-applicable-methods #:compute-restarts #:concatenate #:concatenated-stream #:concatenated-stream-streams #:cond #:condition #:conjugate #:cons #:consp #:constantly #:constantp #:continue #:control-error #:copy-alist #:copy-list #:copy-pprint-dispatch #:copy-readtable #:copy-seq #:copy-structure #:copy-symbol #:copy-tree #:cos #:cosh #:count #:count-if #:count-if-not #:ctypecase #:debug #:decf #:declaim #:declaration #:declare #:decode-float #:decode-universal-time #:defclass #:defconstant #:defgeneric #:define-compiler-macro #:define-condition #:define-method-combination #:define-modify-macro #:define-setf-expander #:define-symbol-macro #:defmacro #:defmethod #:defpackage #:defparameter #:defsetf #:defstruct #:deftype #:defun #:defvar #:delete #:delete-duplicates #:delete-file #:delete-if #:delete-if-not #:delete-package #:denominator #:deposit-field #:describe #:describe-object #:destructuring-bind #:digit-char #:digit-char-p #:directory #:directory-namestring #:disassemble #:division-by-zero #:do #:do* #:do-all-symbols #:do-external-symbols #:do-symbols #:documentation #:dolist #:dotimes #:double-float #:double-float-epsilon #:double-float-negative-epsilon #:dpb #:dribble #:dynamic-extent #:ecase #:echo-stream #:echo-stream-input-stream #:echo-stream-output-stream #:ed #:eighth #:elt #:encode-universal-time #:end-of-file #:endp #:enough-namestring #:ensure-directories-exist #:ensure-generic-function #:eq #:eql #:equal #:equalp #:error #:etypecase #:eval #:eval-when #:evenp #:every #:exp #:export #:expt #:extended-char #:fboundp #:fceiling #:fdefinition #:ffloor #:fifth #:file-author #:file-error #:file-error-pathname #:file-length #:file-namestring #:file-position #:file-stream #:file-string-length #:file-write-date #:fill #:fill-pointer #:find #:find-all-symbols #:find-class #:find-if #:find-if-not #:find-method #:find-package #:find-restart #:find-symbol #:finish-output #:first #:fixnum #:flet #:float #:float-digits #:float-precision #:float-radix #:float-sign #:floating-point-inexact #:floating-point-invalid-operation #:floating-point-overflow #:floating-point-underflow #:floatp #:floor #:fmakunbound #:force-output #:format #:formatter #:fourth #:fresh-line #:fround #:ftruncate #:ftype #:funcall #:function #:function-keywords #:function-lambda-expression #:functionp #:gcd #:generic-function #:gensym #:gentemp #:get #:get-decoded-time #:get-dispatch-macro-character #:get-internal-real-time #:get-internal-run-time #:get-macro-character #:get-output-stream-string #:get-properties #:get-setf-expansion #:get-universal-time #:getf #:gethash #:go #:graphic-char-p #:handler-bind #:handler-case #:hash-table #:hash-table-count #:hash-table-p #:hash-table-rehash-size #:hash-table-rehash-threshold #:hash-table-size #:hash-table-test #:host-namestring #:identity #:if #:ignorable #:ignore #:ignore-errors #:imagpart #:import #:in-package #:incf #:initialize-instance #:inline #:input-stream-p #:inspect #:integer #:integer-decode-float #:integer-length #:integerp #:interactive-stream-p #:intern #:internal-time-units-per-second #:intersection #:invalid-method-error #:invoke-debugger #:invoke-restart #:invoke-restart-interactively #:isqrt #:keyword #:keywordp #:labels #:lambda #:lambda-list-keywords #:lambda-parameters-limit #:last #:lcm #:ldb #:ldb-test #:ldiff #:least-negative-double-float #:least-negative-long-float #:least-negative-normalized-double-float #:least-negative-normalized-long-float #:least-negative-normalized-short-float #:least-negative-normalized-single-float #:least-negative-short-float #:least-negative-single-float #:least-positive-double-float #:least-positive-long-float #:least-positive-normalized-double-float #:least-positive-normalized-long-float #:least-positive-normalized-short-float #:least-positive-normalized-single-float #:least-positive-short-float #:least-positive-single-float #:length #:let #:let* #:lisp-implementation-type #:lisp-implementation-version #:list #:list* #:list-all-packages #:list-length #:listen #:listp #:load #:load-logical-pathname-translations #:load-time-value #:locally #:log #:logand #:logandc1 #:logandc2 #:logbitp #:logcount #:logeqv #:logical-pathname #:logical-pathname-translations #:logior #:lognand #:lognor #:lognot #:logorc1 #:logorc2 #:logtest #:logxor #:long-float #:long-float-epsilon #:long-float-negative-epsilon #:long-site-name #:loop #:loop-finish #:lower-case-p #:machine-instance #:machine-type #:machine-version #:macro-function #:macroexpand #:macroexpand-1 #:macrolet #:make-array #:make-broadcast-stream #:make-concatenated-stream #:make-condition #:make-dispatch-macro-character #:make-echo-stream #:make-hash-table #:make-instance #:make-instances-obsolete #:make-list #:make-load-form #:make-load-form-saving-slots #:make-method #:make-package #:make-pathname #:make-random-state #:make-sequence #:make-string #:make-string-input-stream #:make-string-output-stream #:make-symbol #:make-synonym-stream #:make-two-way-stream #:makunbound #:map #:map-into #:mapc #:mapcan #:mapcar #:mapcon #:maphash #:mapl #:maplist #:mask-field #:max #:member #:member-if #:member-if-not #:merge #:merge-pathnames #:method #:method-combination #:method-combination-error #:method-qualifiers #:min #:minusp #:mismatch #:mod #:most-negative-double-float #:most-negative-fixnum #:most-negative-long-float #:most-negative-short-float #:most-negative-single-float #:most-positive-double-float #:most-positive-fixnum #:most-positive-long-float #:most-positive-short-float #:most-positive-single-float #:muffle-warning #:multiple-value-bind #:multiple-value-call #:multiple-value-list #:multiple-value-prog1 #:multiple-value-setq #:multiple-values-limit #:name-char #:namestring #:nbutlast #:nconc #:next-method-p #:nil #:nintersection #:ninth #:no-applicable-method #:no-next-method #:not #:notany #:notevery #:notinline #:nreconc #:nreverse #:nset-difference #:nset-exclusive-or #:nstring-capitalize #:nstring-downcase #:nstring-upcase #:nsublis #:nsubst #:nsubst-if #:nsubst-if-not #:nsubstitute #:nsubstitute-if #:nsubstitute-if-not #:nth #:nth-value #:nthcdr #:null #:number #:numberp #:numerator #:nunion #:oddp #:open #:open-stream-p #:optimize #:or #:otherwise #:output-stream-p #:package #:package-error #:package-error-package #:package-name #:package-nicknames #:package-shadowing-symbols #:package-use-list #:package-used-by-list #:packagep #:pairlis #:parse-error #:parse-integer #:parse-namestring #:pathname #:pathname-device #:pathname-directory #:pathname-host #:pathname-match-p #:pathname-name #:pathname-type #:pathname-version #:pathnamep #:peek-char #:phase #:pi #:plusp #:pop #:position #:position-if #:position-if-not #:pprint #:pprint-dispatch #:pprint-exit-if-list-exhausted #:pprint-fill #:pprint-indent #:pprint-linear #:pprint-logical-block #:pprint-newline #:pprint-pop #:pprint-tab #:pprint-tabular #:prin1 #:prin1-to-string #:princ #:princ-to-string #:print #:print-not-readable #:print-not-readable-object #:print-object #:print-unreadable-object #:probe-file #:proclaim #:prog #:prog* #:prog1 #:prog2 #:progn #:program-error #:progv #:provide #:psetf #:psetq #:push #:pushnew #:quote #:random #:random-state #:random-state-p #:rassoc #:rassoc-if #:rassoc-if-not #:ratio #:rational #:rationalize #:rationalp #:read #:read-byte #:read-char #:read-char-no-hang #:read-delimited-list #:read-from-string #:read-line #:read-preserving-whitespace #:read-sequence #:reader-error #:readtable #:readtable-case #:readtablep #:real #:realp #:realpart #:reduce #:reinitialize-instance #:rem #:remf #:remhash #:remove #:remove-duplicates #:remove-if #:remove-if-not #:remove-method #:remprop #:rename-file #:rename-package #:replace #:require #:rest #:restart #:restart-bind #:restart-case #:restart-name #:return #:return-from #:revappend #:reverse #:room #:rotatef #:round #:row-major-aref #:rplaca #:rplacd #:safety #:satisfies #:sbit #:scale-float #:schar #:search #:second #:sequence #:serious-condition #:set #:set-difference #:set-dispatch-macro-character #:set-exclusive-or #:set-macro-character #:set-pprint-dispatch #:set-syntax-from-char #:setf #:setq #:seventh #:shadow #:shadowing-import #:shared-initialize #:shiftf #:short-float #:short-float-epsilon #:short-float-negative-epsilon #:short-site-name #:signal #:signed-byte #:signum #:simple-array #:simple-base-string #:simple-bit-vector #:simple-bit-vector-p #:simple-condition #:simple-condition-format-arguments #:simple-condition-format-control #:simple-error #:simple-string #:simple-string-p #:simple-type-error #:simple-vector #:simple-vector-p #:simple-warning #:sin #:single-float #:single-float-epsilon #:single-float-negative-epsilon #:sinh #:sixth #:sleep #:slot-boundp #:slot-exists-p #:slot-makunbound #:slot-missing #:slot-unbound #:slot-value #:software-type #:software-version #:some #:sort #:space #:special #:special-operator-p #:speed #:sqrt #:stable-sort #:standard #:standard-char #:standard-char-p #:standard-class #:standard-generic-function #:standard-method #:standard-object #:step #:storage-condition #:store-value #:stream #:stream-element-type #:stream-error #:stream-error-stream #:stream-external-format #:streamp #:string #:string-capitalize #:string-downcase #:string-equal #:string-greaterp #:string-left-trim #:string-lessp #:string-not-equal #:string-not-greaterp #:string-not-lessp #:string-right-trim #:string-stream #:string-trim #:string-upcase #:string/= #:string< #:string<= #:string= #:string> #:string>= #:stringp #:structure #:structure-class #:structure-object #:style-warning #:sublis #:subseq #:subsetp #:subst #:subst-if #:subst-if-not #:substitute #:substitute-if #:substitute-if-not #:subtypep #:svref #:sxhash #:symbol #:symbol-function #:symbol-macrolet #:symbol-name #:symbol-package #:symbol-plist #:symbol-value #:symbolp #:synonym-stream #:synonym-stream-symbol #:t #:tagbody #:tailp #:tan #:tanh #:tenth #:terpri #:the #:third #:throw #:time #:trace #:translate-logical-pathname #:translate-pathname #:tree-equal #:truename #:truncate #:two-way-stream #:two-way-stream-input-stream #:two-way-stream-output-stream #:type #:type-error #:type-error-datum #:type-error-expected-type #:type-of #:typecase #:typep #:unbound-slot #:unbound-slot-instance #:unbound-variable #:undefined-function #:unexport #:unintern #:union #:unless #:unread-char #:unsigned-byte #:untrace #:unuse-package #:unwind-protect #:update-instance-for-different-class #:update-instance-for-redefined-class #:upgraded-array-element-type #:upgraded-complex-part-type #:upper-case-p #:use-package #:use-value #:user-homedir-pathname #:values #:values-list #:variable #:vector #:vector-pop #:vector-push #:vector-push-extend #:vectorp #:warn #:warning #:when #:wild-pathname-p #:with-accessors #:with-compilation-unit #:with-condition-restarts #:with-hash-table-iterator #:with-input-from-string #:with-open-file #:with-open-stream #:with-output-to-string #:with-package-iterator #:with-simple-restart #:with-slots #:with-standard-io-syntax #:write #:write-byte #:write-char #:write-line #:write-sequence #:write-string #:write-to-string #:y-or-n-p #:yes-or-no-p #:zerop))) (defparameter *cl-symbols* (let ((pkg (find-package :common-lisp))) (mapcar #'(lambda (str) (intern str pkg)) *cl-symbol-names*))) ;;; Symbols classified by their kind in the spec (defparameter *cl-function-symbols* '( * + - / /= 1+ 1- < <= = > >= abort abs acons acos acosh adjoin adjust-array adjustable-array-p alpha-char-p alphanumericp append apply apropos apropos-list arithmetic-error-operands arithmetic-error-operation array-dimension array-dimensions array-displacement array-element-type array-has-fill-pointer-p array-in-bounds-p array-rank array-row-major-index array-total-size arrayp ash asin asinh assoc-if-not assoc assoc-if atan atanh atom bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2 bit-vector-p bit-xor boole both-case-p boundp break broadcast-stream-streams butlast byte byte-position byte-size ceiling cell-error-name cerror char-code char-downcase char-equal char-greaterp char-int char-lessp char-name char-not-equal char-not-greaterp char-not-lessp char-upcase char/= char< char<= char= char> char>= character characterp cis class-of clear-input clear-output close clrhash code-char coerce compile compile-file compile-file-pathname compiled-function-p complement complex complexp compute-restarts concatenate concatenated-stream-streams conjugate cons consp constantly constantp continue copy-alist copy-list copy-pprint-dispatch copy-readtable copy-seq copy-structure copy-symbol copy-tree cos cosh count count-if count-if-not decode-float decode-universal-time delete delete-duplicates delete-file delete-if delete-if-not delete-package denominator deposit-field describe digit-char digit-char-p directory directory-namestring disassemble dpb dribble echo-stream-input-stream echo-stream-output-stream ;;; The function ED is commented out because an implementation ;;; needn't provide this function. ;; ed encode-universal-time endp enough-namestring ensure-directories-exist ensure-generic-function eq eql equal equalp error eval evenp every exp export expt fboundp fceiling ffloor file-author file-error-pathname file-length file-namestring file-position file-write-date find find-all-symbols find-if find-if-not find-package find-restart find-symbol finish-output float float-digits float-precision float-radix float-sign floatp floor fmakunbound force-output format fresh-line fround funcall function-lambda-expression functionp gcd gensym gentemp get-decoded-time get-dispatch-macro-character get-internal-real-time get-internal-run-time get-macro-character get-output-stream-string get-properties get-setf-expansion get-universal-time graphic-char-p hash-table-count hash-table-p hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test host-namestring identity imagpart import input-stream-p inspect integer-decode-float integer-length integerp interactive-stream-p intern intersection invalid-method-error invoke-debugger invoke-restart invoke-restart-interactively isqrt keywordp last lcm ldb-test ldiff length lisp-implementation-type lisp-implementation-version list list* list-all-packages list-length listen listp load load-logical-pathname-translations log logand logandc1 logandc2 logbitp logcount logeqv logical-pathname logior lognand lognor lognot logorc1 logorc2 logtest logxor long-site-name lower-case-p machine-instance machine-type machine-version macroexpand macroexpand-1 make-array make-broadcast-stream make-concatenated-stream make-condition make-dispatch-macro-character make-echo-stream make-hash-table make-list make-load-form-saving-slots make-package make-pathname make-random-state make-sequence make-string make-string-input-stream make-string-output-stream make-symbol make-synonym-stream make-two-way-stream makunbound map map-into mapc mapcan mapcar mapcon maphash mapl maplist max member member-if member-if-not merge merge-pathnames method-combination-error min minusp mismatch mod muffle-warning name-char namestring nbutlast nconc nintersection not notany notevery nreconc nreverse nset-difference nset-exclusive-or nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nthcdr null numberp numerator nunion oddp open open-stream-p output-stream-p package-error-package package-name package-nicknames package-shadowing-symbols package-use-list package-used-by-list packagep pairlis parse-integer parse-namestring pathname pathname-device pathname-directory pathname-host pathname-match-p pathname-name pathname-type pathname-version pathnamep peek-char phase plusp position position-if position-if-not pprint pprint-dispatch pprint-fill pprint-indent pprint-linear pprint-newline pprint-tab pprint-tabular prin1 prin1-to-string princ princ-to-string print print-not-readable-object probe-file proclaim provide random-state-p rassoc rassoc-if rassoc-if-not rational rationalize rationalp read read-byte read-char read-char-no-hang read-delimited-list read-from-string read-line read-preserving-whitespace read-sequence readtablep realp realpart reduce rem remhash remove remove-duplicates remove-if remove-if-not remprop rename-file rename-package replace require restart-name revappend reverse room round rplaca rplacd scale-float search set set-difference set-dispatch-macro-character set-exclusive-or set-macro-character set-pprint-dispatch set-syntax-from-char shadow shadowing-import short-site-name signal signum simple-bit-vector-p simple-condition-format-arguments simple-condition-format-control simple-string-p simple-vector-p sin sinh slot-exists-p sleep slot-boundp slot-makunbound slot-value software-type software-version some sort special-operator-p sqrt stable-sort standard-char-p store-value stream-element-type stream-error-stream stream-external-format streamp string string-capitalize string-downcase string-equal string-greaterp string-left-trim string-lessp string-not-equal string-not-greaterp string-not-lessp string-right-trim string-trim string-upcase string/= string< string<= string= string> string>= stringp sublis subsetp subst subst-if subst-if-not substitute substitute-if substitute-if-not subtypep sxhash symbol-name symbol-package symbolp synonym-stream-symbol tailp tan tanh terpri translate-logical-pathname translate-pathname tree-equal truename truncate ftruncate two-way-stream-input-stream two-way-stream-output-stream type-error-datum type-error-expected-type type-of typep unbound-slot-instance unexport unintern union unread-char unuse-package upgraded-array-element-type upgraded-complex-part-type upper-case-p use-package use-value user-homedir-pathname values-list vector vector-pop vector-push vector-push-extend vectorp warn wild-pathname-p write write-byte write-char write-line write-sequence write-string write-to-string y-or-n-p yes-or-no-p zerop )) (defparameter *cl-variable-symbols* '( * ** *** *break-on-signals* *compile-file-pathname* *compile-file-truename* *compile-print* *compile-verbose* *debug-io* *debugger-hook* *default-pathname-defaults* *error-output* *features* *gensym-counter* *load-pathname* *load-print* *load-truename* *load-verbose* *macroexpand-hook* *modules* *package* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-lines* *print-miser-width* *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably* *print-right-margin* *query-io* *random-state* *read-base* *read-default-float-format* *read-eval* *read-suppress* *readtable* *standard-input* *standard-output* *terminal-io* *trace-output* + ++ +++ / // /// - )) (defparameter *cl-constant-symbols* '( array-dimension-limit array-rank-limit array-total-size-limit boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor call-arguments-limit char-code-limit double-float-epsilon double-float-negative-epsilon internal-time-units-per-second lambda-list-keywords lambda-parameters-limit least-negative-double-float least-negative-long-float least-negative-normalized-double-float least-negative-normalized-long-float least-negative-normalized-short-float least-negative-normalized-single-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-normalized-double-float least-positive-normalized-long-float least-positive-normalized-short-float least-positive-normalized-single-float least-positive-short-float least-positive-single-float long-float-epsilon long-float-negative-epsilon most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float multiple-values-limit nil pi short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon t )) (defparameter *cl-macro-symbols* '( and assert case ccase ecase check-type cond declaim defclass defconstant defgeneric define-compiler-macro define-condition define-method-combination define-modify-macro define-setf-expander define-symbol-macro defmacro defmethod defpackage defparameter defvar defsetf defstruct deftype defun destructuring-bind do do* do-symbols do-external-symbols do-all-symbols dolist dotimes formatter handler-bind handler-case ignore-errors in-package incf decf lambda loop multiple-value-bind multiple-value-list multiple-value-setq nth-value or pop pprint-logical-block print-unreadable-object prog prog* prog1 prog2 psetq push pushnew remf restart-bind restart-case return rotatef setf psetf shiftf step time trace untrace typecase ctypecase etypecase when unless with-accessors with-compilation-unit with-condition-restarts with-hash-table-iterator with-input-from-string with-open-file with-open-stream with-output-to-string with-package-iterator with-simple-restart with-slots with-standard-io-syntax )) (defparameter *cl-accessor-symbols* '( aref bit caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr char compiler-macro-function eighth elt fdefinition fifth fill-pointer find-class first fourth get getf gethash ldb logical-pathname-translations macro-function mask-field ninth nth readtable-case rest row-major-aref sbit schar second seventh sixth subseq svref symbol-function symbol-plist symbol-value tenth third values )) (defparameter *cl-condition-type-symbols* '( arithmetic-error cell-error condition control-error division-by-zero end-of-file error file-error floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow package-error parse-error print-not-readable program-error reader-error serious-condition simple-condition simple-error simple-type-error simple-warning storage-condition stream-error style-warning type-error unbound-slot unbound-variable undefined-function warning )) (defparameter *cl-class-symbols* '(standard-object structure-object)) (defparameter *cl-declaration-symbols* '( declaration dynamic-extent ftype ignore ignorable inline notinline optimize special type)) (defparameter *cl-local-function-symbols* '(call-next-method next-method-p)) (defparameter *cl-local-macro-symbols* '( call-method make-method loop-finish pprint-exit-if-list-exhausted pprint-pop )) (defparameter *cl-special-operator-symbols* '( block catch eval-when flet function go if labels let let* load-time-value locally macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq symbol-macrolet tagbody the throw unwind-protect )) (defparameter *cl-standard-generic-function-symbols* '( add-method allocate-instance change-class class-name compute-applicable-methods describe-object documentation find-method function-keywords initialize-instance make-instance make-instances-obsolete make-load-form method-qualifiers no-applicable-method no-next-method print-object reinitialize-instance remove-method shared-initialize slot-missing slot-unbound update-instance-for-different-class update-instance-for-redefined-class )) (defparameter *cl-system-class-symbols* '( array bit-vector broadcast-stream built-in-class character class complex concatenated-stream cons echo-stream file-stream float function generic-function hash-table integer list logical-pathname method method-combination null number package pathname random-state ratio rational readtable real restart sequence standard-class standard-generic-function standard-method stream string string-stream structure-class symbol synonym-stream t two-way-stream vector )) (defparameter *cl-type-symbols* '( atom base-char base-string bignum bit boolean compiled-function extended-char fixnum keyword nil short-float single-float double-float long-float signed-byte simple-array simple-base-string simple-bit-vector simple-string simple-vector standard-char unsigned-byte )) (defparameter *cl-type-specifier-symbols* '( and eql member mod not or satisfies values )) (defparameter *cl-restart-symbols* '( abort continue muffle-warning store-value use-value )) ;;; Symbols that are names of types that are also classes ;;; See figure 4-8 in section 4.3.7 (defparameter *cl-types-that-are-classes-symbols* '( arithmetic-error array bit-vector broadcast-stream built-in-class cell-error character class complex concatenated-stream condition cons control-error division-by-zero echo-stream end-of-file error file-error file-stream float floating-point-inexact floating-point-invalid-operation floating-point-overflow floating-point-underflow function generic-function hash-table integer list logical-pathname method method-combination null number package package-error parse-error pathname print-not-readable program-error random-state ratio rational reader-error readtable real restart sequence serious-condition simple-condition simple-error simple-type-error simple-warning standard-class standard-generic-function standard-method standard-object storage-condition stream stream-error string string-stream structure-class structure-object style-warning symbol synonym-stream t two-way-stream type-error unbound-slot unbound-variable undefined-function vector warning )) (defparameter *cl-all-type-symbols* (reduce #'union (list *cl-type-symbols* *cl-types-that-are-classes-symbols* *cl-system-class-symbols* *cl-class-symbols* *cl-condition-type-symbols*))) (defparameter *cl-non-function-macro-special-operator-symbols* (set-difference *cl-symbols* (reduce #'union (list *cl-function-symbols* *cl-macro-symbols* *cl-accessor-symbols* *cl-local-function-symbols* *cl-local-macro-symbols* *cl-special-operator-symbols* *cl-standard-generic-function-symbols* '(declare))))) (defparameter *cl-function-or-accessor-symbols* (append *cl-function-symbols* *cl-accessor-symbols*)) (defparameter *cl-non-variable-constant-symbols* (set-difference *cl-symbols* (union *cl-variable-symbols* *cl-constant-symbols*))) gcl-2.6.14/ansi-tests/loop12.lsp0000644000175000017500000000723114360276512014724 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 17 08:47:43 2002 ;;;; Contains: Tests for ALWAYS, NEVER, THEREIS (in-package :cl-test) ;;; Tests of ALWAYS clauses (deftest loop.12.1 (loop for i in '(1 2 3 4) always (< i 10)) t) (deftest loop.12.2 (loop for i in nil always nil) t) (deftest loop.12.3 (loop for i in '(a) always nil) nil) (deftest loop.12.4 (loop for i in '(1 2 3 4 5 6 7) always t until (> i 5)) t) (deftest loop.12.5 (loop for i in '(1 2 3 4 5 6 7) always (< i 6) until (>= i 5)) t) (deftest loop.12.6 (loop for x in '(a b c d e) always x) t) (deftest loop.12.7 (loop for x in '(1 2 3 4 5 6) always (< x 20) never (> x 10)) t) (deftest loop.12.8 (loop for x in '(1 2 3 4 5 6) always (< x 20) never (> x 5)) nil) (deftest loop.12.9 (loop for x in '(1 2 3 4 5 6) never (> x 5) always (< x 20)) nil) (deftest loop.12.10 (loop for x in '(1 2 3 4 5) always (< x 10) finally (return 'good)) good) (deftest loop.12.11 (loop for x in '(1 2 3 4 5) always (< x 3) finally (return 'bad)) nil) (deftest loop.12.12 (loop for x in '(1 2 3 4 5 6) always t when (= x 4) do (loop-finish)) t) (deftest loop.12.13 (loop for x in '(1 2 3 4 5 6) do (loop-finish) always nil) t) ;;; Tests of NEVER (deftest loop.12.21 (loop for i in '(1 2 3 4) never (> i 10)) t) (deftest loop.12.22 (loop for i in nil never t) t) (deftest loop.12.23 (loop for i in '(a) never t) nil) (deftest loop.12.24 (loop for i in '(1 2 3 4 5 6 7) never nil until (> i 5)) t) (deftest loop.12.25 (loop for i in '(1 2 3 4 5 6 7) never (>= i 6) until (>= i 5)) t) (deftest loop.12.26 (loop for x in '(a b c d e) never (not x)) t) (deftest loop.12.30 (loop for x in '(1 2 3 4 5) never (>= x 10) finally (return 'good)) good) (deftest loop.12.31 (loop for x in '(1 2 3 4 5) never (>= x 3) finally (return 'bad)) nil) (deftest loop.12.32 (loop for x in '(1 2 3 4 5 6) never nil when (= x 4) do (loop-finish)) t) (deftest loop.12.33 (loop for x in '(1 2 3 4 5 6) do (loop-finish) never t) t) ;;; Tests of THEREIS (deftest loop.12.41 (loop for x in '(1 2 3 4 5) thereis (and (eqlt x 3) 'good)) good) (deftest loop.12.42 (loop for x in '(nil nil a nil nil) thereis x) a) (deftest loop.12.43 (loop for x in '(1 2 3 4 5) thereis (eql x 4) when (eql x 2) do (loop-finish)) nil) ;;; Error cases (deftest loop.12.error.50 (classify-error (loop for i from 1 to 10 collect i always (< i 20))) program-error) (deftest loop.12.error.50a (classify-error (loop for i from 1 to 10 always (< i 20) collect i)) program-error) (deftest loop.12.error.51 (classify-error (loop for i from 1 to 10 collect i never (> i 20))) program-error) (deftest loop.12.error.51a (classify-error (loop for i from 1 to 10 never (> i 20) collect i)) program-error) (deftest loop.12.error.52 (classify-error (loop for i from 1 to 10 collect i thereis (> i 20))) program-error) (deftest loop.12.error.52a (classify-error (loop for i from 1 to 10 thereis (> i 20) collect i)) program-error) ;;; Non-error cases (deftest loop.12.53 (loop for i from 1 to 10 collect i into foo always (< i 20)) t) (deftest loop.12.53a (loop for i from 1 to 10 always (< i 20) collect i into foo) t) (deftest loop.12.54 (loop for i from 1 to 10 collect i into foo never (> i 20)) t) (deftest loop.12.54a (loop for i from 1 to 10 never (> i 20) collect i into foo) t) (deftest loop.12.55 (loop for i from 1 to 10 collect i into foo thereis i) 1) (deftest loop.12.55a (loop for i from 1 to 10 thereis i collect i into foo) 1) gcl-2.6.14/ansi-tests/array-rank.lsp0000644000175000017500000000204014360276512015650 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 20:32:57 2003 ;;;; Contains: Tests for ARRAY-RANK (in-package :cl-test) ;;; Most tests for ARRAY-RANK are in make-array.lsp (deftest array-rank.1 (array-rank #0aNIL) 0) (deftest array-rank.2 (loop for e in *universe* when (and (typep e 'vector) (not (eql (array-rank e) 1))) collect e) nil) (deftest array-rank.order.1 (let ((i 0) a) (values (array-rank (progn (setf a (incf i)) "abcd")) i a)) 1 1 1) ;;; Error tests (deftest array-rank.error.1 (classify-error (array-rank)) program-error) (deftest array-rank.error.2 (classify-error (array-rank #(a b c) nil)) program-error) (deftest array-rank.error.3 (loop for e in *mini-universe* when (and (not (typep e 'array)) (not (eq (classify-error** `(array-rank ',e)) 'type-error))) collect e) nil) (deftest array-rank.error.4 (classify-error (array-rank nil)) type-error) (deftest array-rank.error.5 (classify-error (locally (array-rank nil) t)) type-error) gcl-2.6.14/ansi-tests/load-arrays.lsp0000644000175000017500000000220614360276512016023 0ustar cammcamm;;; Tests on arrays (compile-and-load "array-aux.lsp") (load "aref.lsp") (load "array.lsp") (load "array-t.lsp") (load "array-as-class.lsp") (load "simple-array.lsp") (load "simple-array-t.lsp") (load "bit-vector.lsp") (load "simple-bit-vector.lsp") (load "make-array.lsp") (load "adjustable-array-p.lsp") (load "array-displacement.lsp") (load "array-dimension.lsp") (load "array-dimensions.lsp") (load "array-in-bounds-p.lsp") (load "array-misc.lsp") (load "array-rank.lsp") (load "array-row-major-index.lsp") (load "array-total-size.lsp") (load "arrayp.lsp") (load "fill-pointer.lsp") (load "row-major-aref.lsp") (load "simple-vector-p.lsp") (load "svref.lsp") (load "upgraded-array-element-type.lsp") (load "vector.lsp") (load "vector-pop.lsp") (load "vector-push.lsp") (load "vector-push-extend.lsp") (load "vectorp.lsp") (load "bit.lsp") (load "sbit.lsp") (load "bit-and.lsp") (load "bit-andc1.lsp") (load "bit-andc2.lsp") (load "bit-eqv.lsp") (load "bit-ior.lsp") (load "bit-nand.lsp") (load "bit-nor.lsp") (load "bit-orc1.lsp") (load "bit-orc2.lsp") (load "bit-xor.lsp") (load "bit-not.lsp") (load "bit-vector-p.lsp") (load "simple-bit-vector-p.lsp") gcl-2.6.14/ansi-tests/unread-char.lsp0000644000175000017500000000342214360276512015777 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:05:36 2004 ;;;; Contains: Tests of UNREAD-CHAR (in-package :cl-test) (deftest unread-char.1 (with-input-from-string (*standard-input* "abc") (values (read-char) (unread-char #\a) (read-char) (read-char) (unread-char #\b) (read-char) (read-char))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.2 (with-input-from-string (s "abc") (values (read-char s) (unread-char #\a s) (read-char s) (read-char s) (unread-char #\b s) (read-char s) (read-char s))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.3 (with-input-from-string (is "abc") (with-output-to-string (os) (let ((s (make-echo-stream is os))) (read-char s) (unread-char #\a s) (read-char s) (read-char s) (read-char s) (unread-char #\c s) (read-char s)))) "abc") (deftest unread-char.4 (with-input-from-string (*standard-input* "abc") (values (read-char) (unread-char #\a nil) (read-char) (read-char) (unread-char #\b nil) (read-char) (read-char))) #\a nil #\a #\b nil #\b #\c) (deftest unread-char.5 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (values (read-char t) (unread-char #\a t) (read-char t) (read-char t) (unread-char #\b t) (read-char t) (read-char t)))) #\a nil #\a #\b nil #\b #\c) ;;; Error tests (deftest unread-char.error.1 (signals-error (unread-char) program-error) t) (deftest unread-char.error.2 (signals-error (with-input-from-string (s "abc") (read-char s) (unread-char #\a s nil)) program-error) t) gcl-2.6.14/ansi-tests/structure-00.lsp0000644000175000017500000004155114360276512016070 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat May 9 11:21:25 1998 ;;;; Contains: Common code for creating structure tests (in-package :cl-test) (declaim (optimize (safety 3))) (defun make-struct-test-name (structure-name n) ;; (declare (type (or string symbol character) structure-name) ;; (type fixnum n)) (assert (typep structure-name '(or string symbol character))) ;; (assert (typep n 'fixnum)) (setf structure-name (string structure-name)) (intern (concatenate 'string structure-name "/" (princ-to-string n)))) (defun make-struct-p-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string structure-name (string '#:-p)))) (defun make-struct-copy-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string (string '#:copy-) structure-name))) (defun make-struct-field-fn (conc-name field-name) "Make field accessor for a field in a structure" (cond ((null conc-name) field-name) (t (assert (typep conc-name '(or string symbol character))) (assert (typep field-name '(or string symbol character))) (setf conc-name (string conc-name)) (setf field-name (string field-name)) (intern (concatenate 'string conc-name field-name))))) (defun make-struct-make-fn (structure-name) "Make the make- function for a structure" (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string (string '#:make-) structure-name))) (defun create-instance-of-type (type) "Return an instance of a type. Signal an error if it can't figure out a value for the type." (cond ((eqt type t) ;; anything 'a) ((eqt type 'symbol) 'b) ((eqt type 'null) nil) ((eqt type 'boolean) t) ((eqt type 'keyword) :foo) ((eqt type nil) (error "Cannot obtain element of type ~S~%" type)) ((eqt type 'cons) (cons 'a 'b)) ((eqt type 'list) (list 1 2 3)) ((eqt type 'fixnum) 17) ((eqt type 'bignum) (let ((x 1)) (loop until (typep x 'bignum) do (setq x (* 2 x))) x)) ((and (symbolp type) (typep type 'structure-class)) (let ((make-fn (intern (concatenate 'string (string '#:make-) (symbol-name type)) (symbol-package type)))) (eval (list make-fn)))) ((eqt type 'character) #\w) ((eqt type 'base-char) #\z) ((member type '(integer unsigned-byte signed-byte)) 35) ((eqt type 'bit) 1) ((and (consp type) (consp (cdr type)) (consp (cddr type)) (null (cdddr type)) (eqt (car type) 'integer) (integerp (second type))) (second type)) ((member type '(float single-float long-float double-float short-float)) 0.0) ((and (consp type) (eqt (car type) 'member) (consp (cdr type))) (second type)) ((and (consp type) (eqt (car type) 'or) (consp (second type))) (create-instance-of-type (second type))) (t (error "Cannot generate element for type ~S~%" type)))) (defun find-option (option-list option &optional default) (loop for opt in option-list when (or (eq opt option) (and (consp opt) (eq (car opt) option))) return opt finally (return default))) (defvar *defstruct-with-tests-names* nil "Names of structure types defined with DEFSRUCT-WITH-TESTS.") #| (defvar *subtypep-works-with-classes* t "Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid repeated test failures that cause GCL to bomb.") (deftest subtypep-works-with-classes (let ((c1 (find-class 'vector))) ;; (setq *subtypep-works-with-classes* nil) (subtypep c1 'vector) (subtypep 'vector c1) ;; (setq *subtypep-works-with-classes* t)) t) (defvar *typep-works-with-classes* t "Becomes NIL if TYPEP doesn't work with classes. We test this first to avoid repeated test failures that cause GCL to bomb.") (deftest typep-works-with-classes (let ((c1 (find-class 'vector))) ;; (setq *typep-works-with-classes* nil) (typep #(0 0) c1) ;; (setq *typep-works-with-classes* t)) t) |# ;; ;; There are a number of standardized tests for ;; structures. The following macro generates the ;; structure definition and the tests. ;; (defmacro defstruct-with-tests (name-and-options &body slot-descriptions-and-documentation) "Construct standardized tests for a defstruct, and also do the defstruct." (defstruct-with-tests-fun name-and-options slot-descriptions-and-documentation)) (defun defstruct-with-tests-fun (name-and-options slot-descriptions-and-documentation) ;; Function called from macro defstruct-with-tests (let* ( ;; Either NIL or the documentation string for the structure (doc-string (when (and (consp slot-descriptions-and-documentation) (stringp (car slot-descriptions-and-documentation))) (car slot-descriptions-and-documentation))) ;; The list of slot descriptions that follows either the ;; name and options or the doc string (slot-descriptions (if doc-string (cdr slot-descriptions-and-documentation) slot-descriptions-and-documentation)) ;; The name of the structure (should be a symbol) (name (if (consp name-and-options) (car name-and-options) name-and-options)) ;; The options list, or NIL if there were no options (options (if (consp name-and-options) (cdr name-and-options) nil)) ;; List of symbols that are the names of the slots (slot-names (loop for x in slot-descriptions collect (if (consp x) (car x) x))) ;; List of slot types, if any (slot-types (loop for x in slot-descriptions collect (if (consp x) (getf (cddr x) :type :none) :none))) ;; read-only flags for slots (slot-read-only (loop for x in slot-descriptions collect (and (consp x) (getf (cddr x) :read-only)))) ;; Symbol obtained by prepending MAKE- to the name symbol (make-fn (make-struct-make-fn name)) ;; The type option, if specified (type-option (find-option options :type)) (struct-type (second type-option)) (named-option (find-option options :named)) (include-option (find-option options :include)) ;; The :predicate option entry from OPTIONS, or NIL if none (predicate-option (find-option options :predicate)) ;; The name of the -P function, either the default or the ;; one specified in the :predicate option (p-fn-default (make-struct-p-fn name)) (p-fn (cond ((and type-option (not named-option)) nil) ((or (eq predicate-option :predicate) (null (cdr predicate-option))) p-fn-default) ((cadr predicate-option) (cadr predicate-option)) (t nil))) ;; The :copier option, or NIL if no such option specified (copier-option (find-option options :copier)) ;; The name of the copier function, either the default or ;; one speciefied in the :copier option (copy-fn-default (make-struct-copy-fn name)) (copy-fn (cond ((or (eq copier-option :copier) (null (cdr copier-option))) copy-fn-default) ((cadr copier-option) (cadr copier-option)) (t nil))) ;; The :conc-name option, or NIL if none specified (conc-option (find-option options :conc-name)) ;; String to be prepended to slot names to get the ;; slot accessor function (conc-prefix-default (concatenate 'string (string name) "-")) (conc-prefix (cond ((null conc-option) conc-prefix-default) ((or (eq conc-option :conc-name) (null (cadr conc-option))) nil) (t (string (cadr conc-option))))) (initial-offset-option (find-option options :initial-offset)) (initial-offset (second initial-offset-option)) ;; Accessor names (field-fns (loop for slot-name in slot-names collect (make-struct-field-fn conc-prefix slot-name))) ;; a list of initial values (initial-value-alist (loop for slot-desc in slot-descriptions for slot-name in slot-names for type in slot-types for i from 1 collect (if (not (eq type :none)) (cons slot-name (create-instance-of-type type)) (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) ) ;; Build the tests in an eval-when form `(eval-when (compile load eval) (ignore-errors (eval '(defstruct ,name-and-options ,@slot-descriptions-and-documentation)) ,(unless (or type-option include-option) `(pushnew ',name *defstruct-with-tests-names*)) nil) ;; Test that structure is of the correct type (deftest ,(make-struct-test-name name 1) (and (fboundp (quote ,make-fn)) (functionp (function ,make-fn)) (symbol-function (quote ,make-fn)) (typep (,make-fn) (quote ,(if type-option struct-type name))) t) t) ;; Test that the predicate exists ,@(when p-fn `((deftest ,(make-struct-test-name name 2) (let ((s (,make-fn))) (and (fboundp (quote ,p-fn)) (functionp (function ,p-fn)) (symbol-function (quote ,p-fn)) (notnot (funcall #',p-fn s)) (notnot-mv (,p-fn s)) )) t) (deftest ,(make-struct-test-name name "ERROR.1") (classify-error (,p-fn)) program-error) (deftest ,(make-struct-test-name name "ERROR.2") (classify-error (,p-fn (,make-fn) nil)) program-error) )) ;; Test that the elements of *universe* are not ;; of this type ,@(when p-fn `((deftest ,(make-struct-test-name name 3) (count-if (function ,p-fn) *universe*) 0))) ,@(unless type-option `((deftest ,(make-struct-test-name name 4) (count-if (function (lambda (x) (typep x (quote ,name)))) *universe*) 0))) ;; Check that the fields can be read after being initialized (deftest ,(make-struct-test-name name 5) ,(let ((inits nil) (tests nil) (var (defstruct-maketemp name "TEMP-5"))) (loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns do (setf inits (list* (intern (string slot-name) "KEYWORD") (list 'quote initval) inits)) (push `(and (eqlt (quote ,initval) (,field-fn ,var)) (eqlt (quote ,initval) (funcall #',field-fn ,var))) tests)) `(let ((,var (,make-fn . ,inits))) (and ,@tests t))) t) (deftest ,(make-struct-test-name name "ERROR.3") (remove nil (list ,@(loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns collect `(let ((x (classify-error (,field-fn)))) (unless (eqt x 'program-error) (list ',slot-name ',field-fn x)))))) nil) (deftest ,(make-struct-test-name name "ERROR.4") (remove nil (list ,@(loop for (slot-name . initval) in initial-value-alist for field-fn in field-fns collect `(let ((x (classify-error (,field-fn (,make-fn) nil)))) (unless (eqt x 'program-error) (list ',slot-name ',field-fn x)))))) nil) ;; Check that two invocations return different structures (deftest ,(make-struct-test-name name 6) (eqt (,make-fn) (,make-fn)) nil) ;; Check that we can setf the fields (deftest ,(make-struct-test-name name 7) ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) (var2 (defstruct-maketemp name "TEMP-7-2")) (tests (loop for (slot-name . initval) in initial-value-alist for read-only-p in slot-read-only for slot-desc in slot-descriptions for field-fn in field-fns unless read-only-p collect `(let ((,var2 (quote ,initval))) (setf (,field-fn ,var) ,var2) (eqlt (,field-fn ,var) ,var2))))) `(let ((,var (,make-fn))) (and ,@tests t))) t) ;; Check that the copy function exists ,@(when copy-fn `((deftest ,(make-struct-test-name name 8) (and (fboundp (quote ,copy-fn)) (functionp (function ,copy-fn)) (symbol-function (quote ,copy-fn)) t) t) (deftest ,(make-struct-test-name name "ERROR.5") (classify-error (,copy-fn)) program-error) (deftest ,(make-struct-test-name name "ERROR.6") (classify-error (,copy-fn (,make-fn) nil)) program-error) )) ;; Check that the copy function properly copies fields ,@(when copy-fn `((deftest ,(make-struct-test-name name 9) ,(let* ((var 'XTEMP-9) (var2 'YTEMP-9) (var3 'ZTEMP-9)) `(let ((,var (,make-fn ,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") `(quote ,initval)))))) (let ((,var2 (,copy-fn ,var)) (,var3 (funcall #',copy-fn ,var))) (and (not (eqlt ,var ,var2)) (not (eqlt ,var ,var3)) (not (eqlt ,var2 ,var3)) ,@(loop for (slot-name . nil) in initial-value-alist for fn in field-fns collect `(and (eqlt (,fn ,var) (,fn ,var2)) (eqlt (,fn ,var) (,fn ,var3)))) t)))) t))) ;; When the predicate is not the default, check ;; that the default is not defined. Tests should ;; be designed so that this function name doesn't ;; collide with anything else. ,@(unless (eq p-fn p-fn-default) `((deftest ,(make-struct-test-name name 10) (fboundp (quote ,p-fn-default)) nil))) ;; When the copy function name is not the default, check ;; that the default function is not defined. Tests should ;; be designed so that this name is not accidently defined ;; for something else. ,@(unless (eq copy-fn copy-fn-default) `((deftest ,(make-struct-test-name name 11) (fboundp (quote ,copy-fn-default)) nil))) ;; When there are read-only slots, test that the SETF ;; form for them is not FBOUNDP ,@(when (loop for x in slot-read-only thereis x) `((deftest ,(make-struct-test-name name 12) (and ,@(loop for slot-name in slot-names for read-only in slot-read-only for field-fn in field-fns when read-only collect `(not-mv (fboundp '(setf ,field-fn)))) t) t))) ;; When the structure is a true structure type, check that ;; the various class relationships hold ,@(unless type-option `( (deftest ,(make-struct-test-name name 13) (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) t) (deftest ,(make-struct-test-name name 14) (let ((class (find-class (quote ,name)))) (notnot-mv (typep class 'structure-class))) t) (deftest ,(make-struct-test-name name 15) (notnot-mv (typep (,make-fn) 'structure-object)) t) (deftest ,(make-struct-test-name name 16) (loop for type in *disjoint-types-list* unless (and (equalt (multiple-value-list (subtypep* type (quote ,name))) '(nil t)) (equalt (multiple-value-list (subtypep* (quote ,name) type)) '(nil t))) collect type) nil) (deftest ,(make-struct-test-name name 17) (let ((class (find-class (quote ,name)))) (loop for type in *disjoint-types-list* unless (and (equalt (multiple-value-list (subtypep* type class)) '(nil t)) (equalt (multiple-value-list (subtypep* class type)) '(nil t))) collect type)) nil) (deftest ,(make-struct-test-name name "15A") (let ((class (find-class (quote ,name)))) (notnot-mv (subtypep class 'structure-object))) t t) (deftest ,(make-struct-test-name name "15B") (notnot-mv (subtypep (quote ,name) 'structure-object)) t t) )) ;;; Documentation tests ,(when doc-string `(deftest ,(make-struct-test-name name 18) (let ((doc (documentation ',name 'structure))) (or (null doc) (equalt doc ',doc-string))) t)) ,(when (and doc-string (not type-option)) `(deftest ,(make-struct-test-name name 19) (let ((doc (documentation ',name 'type))) (or (null doc) (equalt doc ',doc-string))) t)) ;; Test that COPY-STRUCTURE works, if this is a structure ;; type ,@(unless type-option `((deftest ,(make-struct-test-name name 20) ,(let* ((var 'XTEMP-20) (var2 'YTEMP-20)) `(let ((,var (,make-fn ,@(loop for (slot-name . initval) in initial-value-alist nconc (list (intern (string slot-name) "KEYWORD") `(quote ,initval)))))) (let ((,var2 (copy-structure ,var))) (and (not (eqlt ,var ,var2)) ,@(loop for (slot-name . nil) in initial-value-alist for fn in field-fns collect `(eqlt (,fn ,var) (,fn ,var2))) t)))) t))) nil ))) (defun defstruct-maketemp (stem suffix1 &optional suffix2) "Make a temporary variable for DEFSTRUCT-WITH-TESTS." (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) (format nil "~A-~A" stem suffix1)))) gcl-2.6.14/ansi-tests/fill-strings.lsp0000644000175000017500000000117014360276512016221 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 17 08:04:27 2002 ;;;; Contains: Test cases for FILL on strings (in-package :cl-test) (deftest array-string-fill.1 (array-string-fill-test-fn "abcde" #\Z) t "ZZZZZ") (deftest array-string-fill.2 (array-string-fill-test-fn "abcde" #\Z :start 2) t "abZZZ") (deftest array-string-fill.3 (array-string-fill-test-fn "abcde" #\Z :end 3) t "ZZZde") (deftest array-string-fill.4 (array-string-fill-test-fn "abcde" #\Z :start 1 :end 4) t "aZZZe") (deftest array-string-fill.5 (array-string-fill-test-fn "abcde" #\Z :start 2 :end 3) t "abZde") gcl-2.6.14/ansi-tests/t.lsp0000644000175000017500000000060214360276512014046 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 06:44:45 2002 ;;;; Contains: Tests of T (in-package :cl-test) (deftest t.1 t t) (deftest t.2 (not-mv (constantp t)) nil) (deftest t.3 (eqt t 't) t) (deftest t.4 (symbol-value t) t) ;;; Tests for use of T in case forms, as a stream designator, or as a class ;;; designator will be elsewhere gcl-2.6.14/ansi-tests/simple-array.lsp0000644000175000017500000001445214360276512016220 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:20:31 2003 ;;;; Contains: Tests of SIMPLE-ARRAY (in-package :cl-test) ;;; Tests of simple-array by itself (deftest simple-array.1.1 (notnot-mv (typep #() 'simple-array)) t) (deftest simple-array.1.2 (notnot-mv (typep #0aX 'simple-array)) t) (deftest simple-array.1.3 (notnot-mv (typep #2a(()) 'simple-array)) t) (deftest simple-array.1.4 (notnot-mv (typep #(1 2 3) 'simple-array)) t) (deftest simple-array.1.5 (notnot-mv (typep "abcd" 'simple-array)) t) (deftest simple-array.1.6 (notnot-mv (typep #*010101 'simple-array)) t) (deftest simple-array.1.7 (typep nil 'simple-array) nil) (deftest simple-array.1.8 (typep 'x 'simple-array) nil) (deftest simple-array.1.9 (typep '(a b c) 'simple-array) nil) (deftest simple-array.1.10 (typep 10.0 'simple-array) nil) (deftest simple-array.1.11 (typep #'(lambda (x) (cons x nil)) 'simple-array) nil) (deftest simple-array.1.12 (typep 1 'simple-array) nil) (deftest simple-array.1.13 (typep (1+ most-positive-fixnum) 'simple-array) nil) ;;; Tests of (simple-array *) (deftest simple-array.2.1 (notnot-mv (typep #() '(simple-array *))) t) (deftest simple-array.2.2 (notnot-mv (typep #0aX '(simple-array *))) t) (deftest simple-array.2.3 (notnot-mv (typep #2a(()) '(simple-array *))) t) (deftest simple-array.2.4 (notnot-mv (typep #(1 2 3) '(simple-array *))) t) (deftest simple-array.2.5 (notnot-mv (typep "abcd" '(simple-array *))) t) (deftest simple-array.2.6 (notnot-mv (typep #*010101 '(simple-array *))) t) ;;; Tests of (simple-array * ()) (deftest simple-array.3.1 (notnot-mv (typep #() '(simple-array * nil))) nil) (deftest simple-array.3.2 (notnot-mv (typep #0aX '(simple-array * nil))) t) (deftest simple-array.3.3 (typep #2a(()) '(simple-array * nil)) nil) (deftest simple-array.3.4 (typep #(1 2 3) '(simple-array * nil)) nil) (deftest simple-array.3.5 (typep "abcd" '(simple-array * nil)) nil) (deftest simple-array.3.6 (typep #*010101 '(simple-array * nil)) nil) ;;; Tests of (simple-array * 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest simple-array.4.1 (notnot-mv (typep #() '(simple-array * 1))) t) (deftest simple-array.4.2 (typep #0aX '(simple-array * 1)) nil) (deftest simple-array.4.3 (typep #2a(()) '(simple-array * 1)) nil) (deftest simple-array.4.4 (notnot-mv (typep #(1 2 3) '(simple-array * 1))) t) (deftest simple-array.4.5 (notnot-mv (typep "abcd" '(simple-array * 1))) t) (deftest simple-array.4.6 (notnot-mv (typep #*010101 '(simple-array * 1))) t) ;;; Tests of (simple-array * 0) (deftest simple-array.5.1 (typep #() '(simple-array * 0)) nil) (deftest simple-array.5.2 (notnot-mv (typep #0aX '(simple-array * 0))) t) (deftest simple-array.5.3 (typep #2a(()) '(simple-array * 0)) nil) (deftest simple-array.5.4 (typep #(1 2 3) '(simple-array * 0)) nil) (deftest simple-array.5.5 (typep "abcd" '(simple-array * 0)) nil) (deftest simple-array.5.6 (typep #*010101 '(simple-array * 0)) nil) ;;; Tests of (simple-array * *) (deftest simple-array.6.1 (notnot-mv (typep #() '(simple-array * *))) t) (deftest simple-array.6.2 (notnot-mv (typep #0aX '(simple-array * *))) t) (deftest simple-array.6.3 (notnot-mv (typep #2a(()) '(simple-array * *))) t) (deftest simple-array.6.4 (notnot-mv (typep #(1 2 3) '(simple-array * *))) t) (deftest simple-array.6.5 (notnot-mv (typep "abcd" '(simple-array * *))) t) (deftest simple-array.6.6 (notnot-mv (typep #*010101 '(simple-array * *))) t) ;;; Tests of (simple-array * 2) (deftest simple-array.7.1 (typep #() '(simple-array * 2)) nil) (deftest simple-array.7.2 (typep #0aX '(simple-array * 2)) nil) (deftest simple-array.7.3 (notnot-mv (typep #2a(()) '(simple-array * 2))) t) (deftest simple-array.7.4 (typep #(1 2 3) '(simple-array * 2)) nil) (deftest simple-array.7.5 (typep "abcd" '(simple-array * 2)) nil) (deftest simple-array.7.6 (typep #*010101 '(simple-array * 2)) nil) ;;; Testing '(simple-array * (--)) (deftest simple-array.8.1 (typep #() '(simple-array * (1))) nil) (deftest simple-array.8.2 (notnot-mv (typep #() '(simple-array * (0)))) t) (deftest simple-array.8.3 (notnot-mv (typep #() '(simple-array * (*)))) t) (deftest simple-array.8.4 (typep #(a b c) '(simple-array * (2))) nil) (deftest simple-array.8.5 (notnot-mv (typep #(a b c) '(simple-array * (3)))) t) (deftest simple-array.8.6 (notnot-mv (typep #(a b c) '(simple-array * (*)))) t) (deftest simple-array.8.7 (typep #(a b c) '(simple-array * (4))) nil) (deftest simple-array.8.8 (typep #2a((a b c)) '(simple-array * (*))) nil) (deftest simple-array.8.9 (typep #2a((a b c)) '(simple-array * (3))) nil) (deftest simple-array.8.10 (typep #2a((a b c)) '(simple-array * (1))) nil) (deftest simple-array.8.11 (typep "abc" '(simple-array * (2))) nil) (deftest simple-array.8.12 (notnot-mv (typep "abc" '(simple-array * (3)))) t) (deftest simple-array.8.13 (notnot-mv (typep "abc" '(simple-array * (*)))) t) (deftest simple-array.8.14 (typep "abc" '(simple-array * (4))) nil) ;;; Two dimensional simple-array type tests (deftest simple-array.9.1 (typep #() '(simple-array * (* *))) nil) (deftest simple-array.9.2 (typep "abc" '(simple-array * (* *))) nil) (deftest simple-array.9.3 (typep #(a b c) '(simple-array * (3 *))) nil) (deftest simple-array.9.4 (typep #(a b c) '(simple-array * (* 3))) nil) (deftest simple-array.9.5 (typep "abc" '(simple-array * (3 *))) nil) (deftest simple-array.9.6 (typep "abc" '(simple-array * (* 3))) nil) (deftest simple-array.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* *)))) t) (deftest simple-array.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 *)))) t) (deftest simple-array.9.9 (typep #2a((a b)(c d)(e f)) '(simple-array * (2 *))) nil) (deftest simple-array.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* 2)))) t) (deftest simple-array.9.11 (typep #2a((a b)(c d)(e f)) '(simple-array * (* 3))) nil) (deftest simple-array.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 2)))) t) (deftest simple-array.9.13 (typep #2a((a b)(c d)(e f)) '(simple-array * (2 3))) nil) gcl-2.6.14/ansi-tests/rt-acl.system0000644000175000017500000000047714360276512015525 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 7 23:30:22 1998 ;;;; Contains: Allegro CL defsystem for RT testing system (defsystem :rt-acl (:default-pathname #.(directory-namestring (truename *LOAD-PATHNAME*)) :default-file-type "lsp") (:definitions "rt-package" "rt")) gcl-2.6.14/ansi-tests/mismatch.lsp0000644000175000017500000004014014360276512015411 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Aug 26 23:55:29 2002 ;;;; Contains: Tests for MISMATCH (in-package :cl-test) (deftest mismatch-list.1 (mismatch '() '(a b c)) 0) (deftest mismatch-list.2 (mismatch '(a b c d) '()) 0) (deftest mismatch-list.3 (mismatch '(a b c) '(a b c)) nil) (deftest mismatch-list.4 (mismatch '(a b c) '(a b d)) 2) (deftest mismatch-list.5 (mismatch '(a b c) '(b c) :start1 1) nil) (deftest mismatch-list.6 (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1) 3) (deftest mismatch-list.7 (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-list.8 (mismatch '(1 2 3 4) '(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-list.9 (mismatch '(1 2 3 4) '(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-list.10 (mismatch '(1 2 3 4) '(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-list.11 (mismatch '(1 2 3 4) '(5 6 17 8) :key #'evenp) nil) (deftest mismatch-list.12 (mismatch '(1 2 3 4) '(5 6 12 8) :key 'oddp) 2) (deftest mismatch-list.13 (mismatch '(1 2 3 4) '(1 2 3 4) :test 'eql) nil) (deftest mismatch-list.14 (mismatch '(1 2 3 4) '(5 6 7 8) :test-not 'eql) nil) (deftest mismatch-list.15 (mismatch '(a b c d e f g h i j k) '(a b c c e f g h z j k)) 3) (deftest mismatch-list.16 (mismatch '(a b c d e f g h i j k) '(a b c c y f g h z j k) :from-end t) 9) (deftest mismatch-list.17 (mismatch '(a b c) '(a b c a b c d) :from-end t) 3) (deftest mismatch-list.18 (mismatch '(a b c a b c d) '(a b c) :from-end t) 7) (deftest mismatch-list.19 (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) 1) (deftest mismatch-list.20 (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-list.21 (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) 1) (deftest mismatch-list.22 (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key 'evenp) 5) ;;; tests on vectors (deftest mismatch-vector.1 (mismatch #() #(a b c)) 0) (deftest mismatch-vector.2 (mismatch #(a b c d) #()) 0) (deftest mismatch-vector.3 (mismatch #(a b c) #(a b c)) nil) (deftest mismatch-vector.4 (mismatch #(a b c) #(a b d)) 2) (deftest mismatch-vector.5 (mismatch #(a b c) #(b c) :start1 1) nil) (deftest mismatch-vector.6 (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1) 3) (deftest mismatch-vector.7 (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-vector.8 (mismatch #(1 2 3 4) #(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-vector.9 (mismatch #(1 2 3 4) #(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-vector.10 (mismatch #(1 2 3 4) #(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-vector.11 (mismatch #(1 2 3 4) #(5 6 17 8) :key #'evenp) nil) (deftest mismatch-vector.12 (mismatch #(1 2 3 4) #(5 6 12 8) :key 'oddp) 2) (deftest mismatch-vector.13 (mismatch #(1 2 3 4) #(1 2 3 4) :test 'eql) nil) (deftest mismatch-vector.14 (mismatch #(1 2 3 4) #(5 6 7 8) :test-not 'eql) nil) (deftest mismatch-vector.15 (mismatch #(a b c d e f g h i j k) #(a b c c e f g h z j k)) 3) (deftest mismatch-vector.16 (mismatch #(a b c d e f g h i j k) #(a b c c y f g h z j k) :from-end t) 9) (deftest mismatch-vector.17 (mismatch #(a b c) #(a b c a b c d) :from-end t) 3) (deftest mismatch-vector.18 (mismatch #(a b c a b c d) #(a b c) :from-end t) 7) (deftest mismatch-vector.19 (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) 1) (deftest mismatch-vector.20 (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-vector.21 (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) 1) (deftest mismatch-vector.22 (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key 'evenp) 5) (deftest mismatch-vector.23 (let ((a (make-array '(9) :initial-contents '(1 2 3 4 5 6 7 8 9) :fill-pointer 5))) (values (mismatch '(1 2 3 4 5) a) (mismatch '(1 2 3 4 5) a :from-end t) (mismatch '(1 2 3 4) a) (mismatch '(1 2 3 4 5 6) a) (mismatch '(6 7 8 9) a :from-end t) (mismatch '(2 3 4 5) a :from-end t))) nil nil 4 5 4 0) (deftest mismatch-vector.24 (let ((m (make-array '(6) :initial-contents '(1 2 3 4 5 6) :fill-pointer 4)) (a '(1 2 3 4 5))) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 6)) ;;; tests on bit vectors (deftest mismatch-bit-vector.1 (mismatch "" #*111) 0) (deftest mismatch-bit-vector.1a (mismatch '() #*111) 0) (deftest mismatch-bit-vector.1b (mismatch "" '(1 1 1)) 0) (deftest mismatch-bit-vector.2 (mismatch #*1010 #*) 0) (deftest mismatch-bit-vector.2a (mismatch #*1010 '()) 0) (deftest mismatch-bit-vector.2b (mismatch '(1 0 1 0) #*) 0) (deftest mismatch-bit-vector.3 (mismatch #*101 #*101) nil) (deftest mismatch-bit-vector.4 (mismatch #*101 #*100) 2) (deftest mismatch-bit-vector.5 (mismatch #*101 #*01 :start1 1) nil) (deftest mismatch-bit-vector.6 (mismatch #*0110 #*0111 :start1 1 :start2 1) 3) (deftest mismatch-bit-vector.7 (mismatch #*0110 #*0111 :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.7a (mismatch '(0 1 1 0) #*0111 :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.7b (mismatch #*0110 '(0 1 1 1) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-bit-vector.8 (mismatch #*1001 #*0110 :test #'(lambda (x y) (= x (- 1 y)))) nil) (deftest mismatch-bit-vector.8a (mismatch #*1001 '(5 4 4 5) :test #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-bit-vector.9 (mismatch #*1001 '(5 4 17 5) :test #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-bit-vector.9a (mismatch '(5 4 17 5) #*1001 :test #'(lambda (x y) (= y (- x 4)))) 2) (deftest mismatch-bit-vector.9b (mismatch #*0100 #*1001 :test #'(lambda (x y) (= x (- 1 y)))) 2) (deftest mismatch-bit-vector.10 (mismatch #*1001 '(10 11 4 123) :test-not #'(lambda (x y) (= x (- y 4)))) 2) (deftest mismatch-bit-vector.10a (mismatch #*1001 '(10 11 100 123) :test-not #'(lambda (x y) (= x (- y 4)))) nil) (deftest mismatch-bit-vector.11 (mismatch #*1010 '(5 6 17 8) :key #'evenp) nil) (deftest mismatch-bit-vector.11a (mismatch '(5 6 17 8) #*1010 :key #'evenp) nil) (deftest mismatch-bit-vector.11b (mismatch #*0101 #*1010 :key #'evenp :test-not 'eql) nil) (deftest mismatch-bit-vector.11c (mismatch '(5 6 17 8) #*10101 :key #'evenp) 4) (deftest mismatch-bit-vector.11d (mismatch '(5 6 17 8 100) #*1010 :key #'evenp) 4) (deftest mismatch-bit-vector.12 (mismatch #*1010 #*1000 :key 'oddp) 2) (deftest mismatch-bit-vector.12a (mismatch #*1010 '(5 6 8 8) :key 'oddp) 2) (deftest mismatch-bit-vector.12b (mismatch '(5 6 8 8) #*1010 :key 'oddp) 2) (deftest mismatch-bit-vector.13 (mismatch #*0001 #*0001 :test 'eql) nil) (deftest mismatch-bit-vector.14 (mismatch '#*10001 #*01110 :test-not 'eql) nil) (deftest mismatch-bit-vector.15 (mismatch #*00100010100 #*00110010000) 3) (deftest mismatch-bit-vector.16 (mismatch #*00100010100 #*00110010000 :from-end t) 9) (deftest mismatch-bit-vector.17 (mismatch #*001 #*0010010 :from-end t) 3) (deftest mismatch-bit-vector.18 (mismatch #*0010010 #*001 :from-end t) 7) (deftest mismatch-bit-vector.19 (mismatch #*000 #*11111011 :from-end t :test-not 'eql) 1) (deftest mismatch-bit-vector.20 (mismatch #*1111111 '(2 3 3) :from-end t :key #'evenp) 5) (deftest mismatch-bit-vector.21 (mismatch #*111 #*00000100 :from-end t :test-not #'equal) 1) (deftest mismatch-bit-vector.22 (mismatch #*1111111 '(2 3 3) :from-end t :key 'evenp) 5) (deftest mismatch-bit-vector.23 (let ((a (make-array '(9) :initial-contents #*001011000 :fill-pointer 5 :element-type 'bit))) (values (mismatch #*00101 a) (mismatch #*00101 a :from-end t) (mismatch #*0010 a) (mismatch #*001011 a) (mismatch #*1000 a :from-end t) (mismatch #*0010 a :from-end t))) nil nil 4 5 4 4) (deftest mismatch-bit-vector.24 (let ((m (make-array '(6) :initial-contents #*001011 :fill-pointer 4 :element-type 'bit)) (a #*00101)) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 5)) ;;; tests on strings (deftest mismatch-string.1 (mismatch "" "111") 0) (deftest mismatch-string.1a (mismatch '() "111") 0) (deftest mismatch-string.1b (mismatch "" '(1 1 1)) 0) (deftest mismatch-string.2 (mismatch "1010" "") 0) (deftest mismatch-string.2a (mismatch "1010" '()) 0) (deftest mismatch-string.2b (mismatch '(1 0 1 0) "") 0) (deftest mismatch-string.3 (mismatch "101" "101") nil) (deftest mismatch-string.4 (mismatch "101" "100") 2) (deftest mismatch-string.5 (mismatch "101" "01" :start1 1) nil) (deftest mismatch-string.6 (mismatch "0110" "0111" :start1 1 :start2 1) 3) (deftest mismatch-string.7 (mismatch "0110" "0111" :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.7a (mismatch '(#\0 #\1 #\1 #\0) "0111" :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.7b (mismatch "0110" '(#\0 #\1 #\1 #\1) :start1 1 :start2 1 :end1 3 :end2 3) nil) (deftest mismatch-string.8 (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) nil) (deftest mismatch-string.8a (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) (setq x (read-from-string (string x))) (= x (- y 4)))) nil) (deftest mismatch-string.9 (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) (setq x (read-from-string (string x))) (= x (- y 4)))) 2) (deftest mismatch-string.9a (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) (setq y (read-from-string (string y))) (= y (- x 4)))) 2) (deftest mismatch-string.9b (mismatch "0100" "1001" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) 2) (deftest mismatch-string.10 (mismatch "1001" "0049" :test-not #'(lambda (x y) (setq x (read-from-string (string x))) (setq y (read-from-string (string y))) (eql x (- y 4)))) 2) (deftest mismatch-string.10a (mismatch "1001" "3333" :test-not #'(lambda (x y) (setq x (read-from-string (string x))) (setq y (read-from-string (string y))) (eql x (- y 4)))) nil) (deftest mismatch-string.11 (mismatch "1010" "5678" :key #'evendigitp) nil) (deftest mismatch-string.11a (mismatch "5678" "1010" :key #'odddigitp) nil) (deftest mismatch-string.11b (mismatch "0101" "1010" :key #'evendigitp :test-not 'eql) nil) (deftest mismatch-string.11c (mismatch "5678" "10101" :key #'evendigitp) 4) (deftest mismatch-string.11d (mismatch "56122" "1010" :key #'evendigitp) 4) (deftest mismatch-string.11e (mismatch "0101" '(#\1 #\0 #\1 #\0) :key #'evendigitp :test-not 'eql) nil) (deftest mismatch-string.12 (mismatch "1010" "1000" :key 'odddigitp) 2) (deftest mismatch-string.12a (mismatch "1010" "5688" :key 'odddigitp) 2) (deftest mismatch-string.12b (mismatch '(#\5 #\6 #\8 #\8) "1010" :key 'odddigitp) 2) (deftest mismatch-string.13 (mismatch "0001" "0001" :test 'eql) nil) (deftest mismatch-string.14 (mismatch "10001" "01110" :test-not 'eql) nil) (deftest mismatch-string.15 (mismatch "00100010100" "00110010000") 3) (deftest mismatch-string.16 (mismatch "00100010100" "00110010000" :from-end t) 9) (deftest mismatch-string.17 (mismatch "001" "0010010" :from-end t) 3) (deftest mismatch-string.18 (mismatch "0010010" "001" :from-end t) 7) (deftest mismatch-string.19 (mismatch "000" "11111011" :from-end t :test-not 'eql) 1) (deftest mismatch-string.20 (mismatch "1111111" "233" :from-end t :key #'evendigitp) 5) (deftest mismatch-string.20a (mismatch "1111111" '(#\2 #\3 #\3) :from-end t :key #'evendigitp) 5) (deftest mismatch-string.21 (mismatch "111" "00000100" :from-end t :test-not #'equal) 1) (deftest mismatch-string.22 (mismatch "1111111" "233" :from-end t :key 'evendigitp) 5) (deftest mismatch-string.23 (let ((a (make-array '(9) :initial-contents "123456789" :fill-pointer 5 :element-type 'character))) (values (mismatch "12345" a) (mismatch "12345" a :from-end t) (mismatch "1234" a) (mismatch "123456" a) (mismatch "6789" a :from-end t) (mismatch "2345" a :from-end t))) nil nil 4 5 4 0) (deftest mismatch-string.24 (let ((m (make-array '(6) :initial-contents "123456" :fill-pointer 4 :element-type 'character)) (a "12345")) (list (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 5) (mismatch m a) (mismatch m a :from-end t) (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) (4 4 5 nil nil 6 5 6)) ;;; Keyword tests (deftest mismatch.allow-other-keys.1 (mismatch "1234" "1244" :allow-other-keys t :bad t) 2) (deftest mismatch.allow-other-keys.2 (mismatch "1234" "1244" :bad t :allow-other-keys t) 2) (deftest mismatch.allow-other-keys.3 (mismatch "1234" "1244" :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest mismatch.allow-other-keys.4 (mismatch "1234" "1244" :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest mismatch.allow-other-keys.5 (mismatch "1234" "1244" :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest mismatch.keywords.6 (mismatch "1234" "1244" :test #'equal :test (complement #'equal)) 2) (deftest mismatch.allow-other-keys.7 (mismatch "1234" "1244" :bad t :allow-other-keys t :test (complement #'equal)) 0) ;;; Order of evaluation (deftest mismatch.order.1 (let ((i 0) a b) (values (mismatch (progn (setf a (incf i)) "abcd") (progn (setf b (incf i)) "abzd")) i a b)) 2 2 1 2) (deftest mismatch.order.2 (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") (progn (setf b (incf i)) "abcdef") :key (progn (setf c (incf i)) #'identity) :test (progn (setf d (incf i)) #'equal) :start1 (progn (setf e (incf i)) 1) :start2 (progn (setf f (incf i)) 1) :end1 (progn (setf g (incf i)) 4) :end2 (progn (setf h (incf i)) 4) :from-end (setf j (incf i))) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) (deftest mismatch.order.3 (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") (progn (setf b (incf i)) "abcdef") :from-end (setf c (incf i)) :end2 (progn (setf d (incf i)) 4) :end1 (progn (setf e (incf i)) 4) :start2 (progn (setf f (incf i)) 1) :start1 (progn (setf g (incf i)) 1) :test (progn (setf h (incf i)) #'equal) :key (progn (setf j (incf i)) #'identity)) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) ;;; Error cases (deftest mismatch.error.1 (classify-error (mismatch)) program-error) (deftest mismatch.error.2 (classify-error (mismatch nil)) program-error) (deftest mismatch.error.3 (classify-error (mismatch nil nil :bad t)) program-error) (deftest mismatch.error.4 (classify-error (mismatch nil nil :bad t :allow-other-keys nil)) program-error) (deftest mismatch.error.5 (classify-error (mismatch nil nil :key)) program-error) (deftest mismatch.error.6 (classify-error (mismatch nil nil 1 2)) program-error) (deftest mismatch.error.7 (classify-error (mismatch '(a b) '(a b) :test #'identity)) program-error) (deftest mismatch.error.8 (classify-error (mismatch '(a b) '(a b) :test-not #'identity)) program-error) (deftest mismatch.error.9 (classify-error (mismatch '(a b) '(a b) :key #'car)) type-error) (deftest mismatch.error.10 (classify-error (mismatch '(a b) '(a b) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/make-tar0000755000175000017500000000017614360276512014520 0ustar cammcammrm -f binary/* rt/binary/* tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ gcl-2.6.14/ansi-tests/remove.lsp0000644000175000017500000005010714360276512015105 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 11:46:05 2002 ;;;; Contains: Tests for REMOVE (in-package :cl-test) (deftest remove-list.1 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.3 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.4 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 100))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.5 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 0))) (and (equalp orig x) y)) (a b c a b d a c b a e)) (deftest remove-list.6 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :count 1))) (and (equalp orig x) y)) (b c a b d a c b a e)) (deftest remove-list.7 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'c x :count 1))) (and (equalp orig x) y)) (a b a b d a c b a e)) (deftest remove-list.8 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.9 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t :count 1))) (and (equalp orig x) y)) (a b c a b d a c b e)) (deftest remove-list.10 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :from-end t :count 4))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.11 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.12 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end nil)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.13 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end 11)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.14 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove 'a x :end nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.15 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 9 collect (remove 'a x :start i :end 9)) (equalp orig x))) ((b c b d c b a e) (a b c b d c b a e) (a b c b d c b a e) (a b c b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e)) t) (deftest remove-list.16 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end 11 :count 1)) (equalp orig x))) ((b c a b d a c b a e) (a b c b d a c b a e) (a b c b d a c b a e) (a b c b d a c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d c b a e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) (deftest remove-list.17 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig))) (values (loop for i from 0 to 10 collect (remove 'a x :start i :end (1+ i))) (equalp orig x))) (( b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d c b a e) (a b c a b d a c b a e) (a b c a b d a c b a e) (a b c a b d a c b e) (a b c a b d a c b a e)) t) ;;; Show that it tests using EQL, not EQ (deftest remove-list.18 (let* ((i (1+ most-positive-fixnum)) (orig (list i 0 i 1 i 2 3)) (x (copy-seq orig)) (y (remove (1+ most-positive-fixnum) x))) (and (equalp orig x) y)) (0 1 2 3)) (deftest remove-list.19 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 1 x :key #'1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.20 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test #'>))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.21 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test '> :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.22 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 2 x :key nil))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.23 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 1 x :key '1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.24 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test-not #'<=))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.25 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :test-not '<= :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.26 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :from-end t :start 1 :end 5))) (and (equalp orig x) y)) (1 2 2 6 1 2 4 1 3 2 7)) (deftest remove-list.27 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count -1))) (and (equalp orig x) (equalpt x y))) t) (deftest remove-list.28 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count -1000000000000))) (and (equalp orig x) (equalpt x y))) t) (deftest remove-list.29 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove 3 x :count 1000000000000))) (and (equalp orig x) y)) (1 2 2 6 1 2 4 1 2 7)) ;;; Assorted tests of remove and delete on vectors, strings, ;;; and bit vectors. These are mostly to exercise bugs previously ;;; detected by the randomized tests (deftest remove-vector.1 (remove 'a (vector 'b 'c 'd)) #(b c d)) (deftest remove-vector.2 (remove 'a (vector 'b 'c 'd) :count -1) #(b c d)) (deftest remove-vector.3 (remove 'a (vector 'a 'b 'c 'd) :count -1) #(a b c d)) (deftest remove-string.1 (remove #\a (copy-seq "abcad")) "bcd") (deftest remove-string.2 (remove #\a (copy-seq "abcad") :count -1) "abcad") (deftest remove-string.3 (remove #\a (copy-seq "bcd") :count -1) "bcd") (deftest delete-vector.1 (delete 'a (vector 'b 'c 'd)) #(b c d)) (deftest delete-vector.2 (delete 'a (vector 'b 'c 'd) :count -1) #(b c d)) (deftest delete-vector.3 (delete 'a (vector 'a 'b 'c 'd) :count -1) #(a b c d)) (deftest delete-string.1 (delete #\a (copy-seq "abcad")) "bcd") (deftest delete-string.2 (delete #\a (copy-seq "abcad") :count -1) "abcad") (deftest delete-string.3 (delete #\a (copy-seq "bcd") :count -1) "bcd") (deftest remove-bit-vector.1 (remove 0 (copy-seq #*00011101101)) #*111111) (deftest remove-bit-vector.2 (remove 0 (copy-seq #*00011101101) :count -1) #*00011101101) (deftest remove-bit-vector.3 (remove 0 (copy-seq #*11111) :count -1) #*11111) (deftest delete-bit-vector.1 (delete 0 (copy-seq #*00011101101)) #*111111) (deftest delete-bit-vector.2 (delete 0 (copy-seq #*00011101101) :count -1) #*00011101101) (deftest delete-bit-vector.3 (delete 0 (copy-seq #*11111) :count -1) #*11111) ;;; Order of evaluation tests (deftest remove.order.1 (let ((i 0) a b c d e f g h) (values (remove (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'eq) :start (progn (setf g (incf i)) 0) :end (progn (setf h (incf i)) nil)) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest remove.order.2 (let ((i 0) a b c d e f g h) (values (remove (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :test-not (progn (setf e (incf i)) (complement #'eq)) :key (progn (setf f (incf i)) #'identity) :count (progn (setf g (incf i)) 1) :from-end (progn (setf h (incf i)) t) ) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest delete.order.1 (let ((i 0) a b c d e f g h) (values (delete (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'eq) :start (progn (setf g (incf i)) 0) :end (progn (setf h (incf i)) nil)) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest delete.order.2 (let ((i 0) a b c d e f g h) (values (delete (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :test-not (progn (setf e (incf i)) (complement #'eq)) :key (progn (setf f (incf i)) #'identity) :count (progn (setf g (incf i)) 1) :from-end (progn (setf h (incf i)) t) ) i a b c d e f g h)) (a b c d f) 8 1 2 3 4 5 6 7 8) (deftest remove-if.order.1 (let ((i 0) a b c d e f g) (values (remove-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if.order.2 (let ((i 0) a b c d e f g) (values (remove-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if.order.1 (let ((i 0) a b c d e f g) (values (delete-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if.order.2 (let ((i 0) a b c d e f g) (values (delete-if (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if-not.order.1 (let ((i 0) a b c d e f g) (values (remove-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest remove-if-not.order.2 (let ((i 0) a b c d e f g) (values (remove-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if-not.order.1 (let ((i 0) a b c d e f g) (values (delete-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :from-end (progn (setf c (incf i)) t) :count (progn (setf d (incf i)) 1) :key (progn (setf e (incf i)) #'identity) :start (progn (setf f (incf i)) 0) :end (progn (setf g (incf i)) nil)) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) (deftest delete-if-not.order.2 (let ((i 0) a b c d e f g) (values (delete-if-not (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) :end (progn (setf c (incf i)) nil) :start (progn (setf d (incf i)) 0) :key (progn (setf e (incf i)) #'identity) :count (progn (setf f (incf i)) 1) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (a b c d f) 7 1 2 3 4 5 6 7) ;;; Randomized tests (deftest remove-random (loop for i from 1 to 2500 unless (eq (random-test-remove 20) t) do (return *remove-fail-args*)) nil) (deftest remove-if-random (loop for i from 1 to 2500 unless (eq (random-test-remove-if 20) t) do (return *remove-fail-args*)) nil) (deftest remove-if-not-random (loop for i from 1 to 2500 unless (eq (random-test-remove-if 20 t) t) do (return *remove-fail-args*)) nil) (deftest delete-random (loop for i from 1 to 2500 unless (eq (random-test-delete 20) t) do (return *remove-fail-args*)) nil) (deftest delete-if-random (loop for i from 1 to 2500 unless (eq (random-test-delete-if 20) t) do (return *remove-fail-args*)) nil) (deftest delete-if-not-random (loop for i from 1 to 2500 unless (eq (random-test-delete-if 20 t) t) do (return *remove-fail-args*)) nil) ;;; Additional tests with KEY = NIL (deftest remove-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove-if #'evenp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (remove-if-not #'oddp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest delete-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete-if #'evenp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) y) (b c b d c b e)) (deftest delete-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete-if-not #'oddp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) y) (b c b d c b e)) (deftest delete-list.1 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) (y (delete 'a x :key nil))) y) (b c b d c b e)) (deftest delete-list.2 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) (x (copy-seq orig)) (y (delete 2 x :key nil))) y) (1 3 6 1 4 1 3 7)) ;;; Keyword tests (deftest remove.allow-other-keys.1 (remove 'a '(a b c a d) :allow-other-keys t) (b c d)) (deftest remove.allow-other-keys.2 (remove 'a '(a b c a d) :allow-other-keys nil) (b c d)) (deftest remove.allow-other-keys.3 (remove 'a '(a b c a d) :bad t :allow-other-keys t) (b c d)) (deftest remove.allow-other-keys.4 (remove 'a '(a b c a d) :allow-other-keys t :bad t :bad nil) (b c d)) (deftest remove.allow-other-keys.5 (remove 'a '(a b c a d) :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 t) (b c d)) (deftest remove.allow-other-keys.6 (remove 'a '(a b c a d) :allow-other-keys t :from-end t :count 1) (a b c d)) (deftest remove.keywords.7 (remove 'a '(a b c a d) :from-end t :count 1 :from-end nil :count 10) (a b c d)) (deftest delete.allow-other-keys.1 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t) (b c d)) (deftest delete.allow-other-keys.2 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys nil) (b c d)) (deftest delete.allow-other-keys.3 (delete 'a (copy-seq '(a b c a d)) :bad t :allow-other-keys t) (b c d)) (deftest delete.allow-other-keys.4 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :bad t :bad nil) (b c d)) (deftest delete.allow-other-keys.5 (delete 'a (copy-seq '(a b c a d)) :bad1 t :allow-other-keys t :bad2 t :allow-other-keys nil :bad3 t) (b c d)) (deftest delete.allow-other-keys.6 (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :from-end t :count 1) (a b c d)) (deftest delete.keywords.7 (delete 'a (copy-seq '(a b c a d)) :from-end t :count 1 :from-end nil :count 10) (a b c d)) ;;; Error cases (deftest remove.error.1 (classify-error (remove)) program-error) (deftest remove.error.2 (classify-error (remove 'a)) program-error) (deftest remove.error.3 (classify-error (remove 'a nil :key)) program-error) (deftest remove.error.4 (classify-error (remove 'a nil 'bad t)) program-error) (deftest remove.error.5 (classify-error (remove 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest remove.error.6 (classify-error (remove 'a nil 1 2)) program-error) (deftest remove.error.7 (classify-error (remove 'a (list 'a 'b 'c) :test #'identity)) program-error) (deftest remove.error.8 (classify-error (remove 'a (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest remove.error.9 (classify-error (remove 'a (list 'a 'b 'c) :key #'cons)) program-error) (deftest remove.error.10 (classify-error (remove 'a (list 'a 'b 'c) :key #'car)) type-error) ;;; (deftest delete.error.1 (classify-error (delete)) program-error) (deftest delete.error.2 (classify-error (delete 'a)) program-error) (deftest delete.error.3 (classify-error (delete 'a nil :key)) program-error) (deftest delete.error.4 (classify-error (delete 'a nil 'bad t)) program-error) (deftest delete.error.5 (classify-error (delete 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest delete.error.6 (classify-error (delete 'a nil 1 2)) program-error) (deftest delete.error.7 (classify-error (delete 'a (list 'a 'b 'c) :test #'identity)) program-error) (deftest delete.error.8 (classify-error (delete 'a (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest delete.error.9 (classify-error (delete 'a (list 'a 'b 'c) :key #'cons)) program-error) (deftest delete.error.10 (classify-error (delete 'a (list 'a 'b 'c) :key #'car)) type-error) gcl-2.6.14/ansi-tests/error.lsp0000644000175000017500000000262214360276512014740 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 28 21:37:43 2003 ;;;; Contains: Tests of ERROR (in-package :cl-test) (deftest error.1 (let ((fmt "Error")) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.2 (let* ((fmt "Error") (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.3 (let ((fmt "Error")) (handler-case (error 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.4 (let ((fmt "Error: ~A")) (handler-case (error fmt 10) (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest error.5 (let ((fmt (formatter "Error"))) (handler-case (error fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest error.6 (handler-case (error 'simple-condition) (error (c) :wrong) (simple-condition (c) :right)) :right) (deftest error.7 (handler-case (error 'simple-warning) (error (c) :wrong) (simple-warning (c) :right) (condition (c) :wrong2)) :right) (deftest error.8 (let ((fmt "Boo!")) (handler-case (error 'simple-warning :format-control fmt) (simple-warning (c) (frob-simple-warning c fmt)))) t) ;;; Tests for other conditions will in their own files. gcl-2.6.14/ansi-tests/nreverse.lsp0000644000175000017500000000502414360276512015437 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 21 00:04:57 2002 ;;;; Contains: Tests for NREVERSE (in-package :cl-test) (deftest nreverse-list.1 (nreverse nil) nil) (deftest nreverse-list.2 (let ((x (copy-seq '(a b c)))) (nreverse x)) (c b a)) (deftest nreverse-vector.1 (nreverse #()) #()) (deftest nreverse-vector.2 (let ((x (copy-seq #(a b c d e)))) (nreverse x)) #(e d c b a)) (deftest nreverse-nonsimple-vector.1 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (nreverse x)) #()) (deftest nreverse-nonsimple-vector.2 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) :fill-pointer t :adjustable t)) (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) (deftest nreverse-nonsimple-vector.3 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5)) (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) (deftest nreverse-bit-vector.1 (nreverse #*) #*) (deftest nreverse-bit-vector.2 (let ((x (copy-seq #*000110110110))) (nreverse x)) #*011011011000) (deftest nreverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) :fill-pointer 5 :element-type 'bit)) (y (nreverse x))) y) #*11000) (deftest nreverse-string.1 (nreverse "") "") (deftest nreverse-string.2 (let ((x (copy-seq "000110110110"))) (nreverse x)) "011011011000") (deftest nreverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character)) (y (nreverse x))) y) "edcba") (deftest nreverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char)) (y (nreverse x))) y) "edcba") (deftest nreverse.order.1 (let ((i 0)) (values (nreverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) (deftest nreverse.error.1 (classify-error (nreverse 'a)) type-error) (deftest nreverse.error.2 (classify-error (nreverse #\a)) type-error) (deftest nreverse.error.3 (classify-error (nreverse 10)) type-error) (deftest nreverse.error.4 (classify-error (nreverse 0.3)) type-error) (deftest nreverse.error.5 (classify-error (nreverse 10/3)) type-error) (deftest nreverse.error.6 (classify-error (nreverse)) program-error) (deftest nreverse.error.7 (classify-error (nreverse nil nil)) program-error) (deftest nreverse.error.8 (classify-error (locally (nreverse 'a) t)) type-error) gcl-2.6.14/ansi-tests/make-string-input-stream.lsp0000644000175000017500000000510614360276512020456 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 18:36:48 2004 ;;;; Contains: Tests for MAKE-STRING-INPUT-STREAM (in-package :cl-test) (deftest make-string-input-stream.1 (let ((s (make-string-input-stream ""))) (values (notnot (typep s 'stream)) (notnot (streamp s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t nil) (deftest make-string-input-stream.2 (let ((s (make-string-input-stream "abcd"))) (values (notnot (typep s 'stream)) (notnot (streamp s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t nil) (deftest make-string-input-stream.3 (let ((s (make-string-input-stream "abcd" 1))) (values (read-line s))) "bcd") (deftest make-string-input-stream.4 (let ((s (make-string-input-stream "abcd" 0 2))) (values (read-line s))) "ab") (deftest make-string-input-stream.5 (let ((s (make-string-input-stream "abcd" 1 nil))) (values (read-line s))) "bcd") (deftest make-string-input-stream.6 (let ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef" :fill-pointer 4))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.7 (let* ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef")) (str2 (make-array 4 :element-type 'character :displaced-to str1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.8 (let* ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef")) (str2 (make-array 4 :element-type 'character :displaced-to str1 :displaced-index-offset 1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "bcde" :eof) (deftest make-string-input-stream.9 (let ((str1 (make-array 6 :element-type 'character :initial-contents "abcdef" :adjustable t))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcdef" :eof) (deftest make-string-input-stream.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (let ((s (make-string-input-stream (make-array 0 :element-type nil)))) (read-char s nil :eof)) :eof) ;;; Error tests (deftest make-string-input-stream.error.1 (signals-error (make-string-input-stream) program-error) t) (deftest make-string-input-stream.error.2 (signals-error (make-string-input-stream "abc" 1 2 nil) program-error) t) gcl-2.6.14/ansi-tests/get-output-stream-string.lsp0000644000175000017500000000136414360276512020523 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 09:48:46 2004 ;;;; Contains: Tests of GET-OUTPUT-STREAM-STRING (in-package :cl-test) ;; this function is used extensively elsewhere in the test suite (deftest get-output-stream-string.1 (let ((s (make-string-output-stream))) (values (get-output-stream-string s) (write-string "abc" s) (write-string "def" s) (get-output-stream-string s) (get-output-stream-string s))) "" "abc" "def" "abcdef" "") ;;; Error cases (deftest get-output-stream-string.error.1 (signals-error (get-output-stream-string) t) t) (deftest get-output-stream-string.error.2 (signals-error (get-output-stream-string (make-string-output-stream) nil) t) t) gcl-2.6.14/ansi-tests/interactive-stream-p.lsp0000644000175000017500000000134614360276512017654 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:47:59 2004 ;;;; Contains: Tests of INTERACTIVE-STREAM-P (in-package :cl-test) (deftest interactive-stream-p.1 (let ((streams (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*))) (mapc #'interactive-stream-p streams) ;; no error should occur nil) nil) (deftest interactive-stream-p.error.1 (check-type-error #'interactive-stream-p #'streamp) nil) (deftest interactive-stream-p.error.2 (signals-error (interactive-stream-p) program-error) t) (deftest interactive-stream-p.error.3 (signals-error (interactive-stream-p *terminal-io* nil) program-error) t) gcl-2.6.14/ansi-tests/multiple-value-setq.lsp0000644000175000017500000000467514360276512017540 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 07:00:57 2002 ;;;; Contains: Tests of MULTIPLE-VALUE-SETQ (in-package :cl-test) (deftest multiple-value-setq.1 (let ((x 1) (y 2)) (values (multiple-value-list (multiple-value-setq (x y) (values 3 4))) x y)) (3) 3 4) (deftest multiple-value-setq.2 (let (x) (multiple-value-setq (x) (values 1 2)) x) 1) (deftest multiple-value-setq.3 (let (x) (symbol-macrolet ((y x)) (multiple-value-setq (y) (values 1 2)) x)) 1) (deftest multiple-value-setq.4 (let ((x (list nil))) (symbol-macrolet ((y (car x))) (multiple-value-setq (y) (values 1 2)) x)) (1)) ;;; test of order of evaluation ;;; The (INCF I) should be evaluated before the assigned form I. (deftest multiple-value-setq.5 (let ((i 0) (x (list nil))) (symbol-macrolet ((y (car (progn (incf i) x)))) (multiple-value-setq (y) i)) x) (1)) (deftest multiple-value-setq.6 (let ((x (list nil)) z) (symbol-macrolet ((y (car x))) (multiple-value-setq (y z) (values 1 2))) (values x z)) (1) 2) (deftest multiple-value-setq.7 (let ((x (list nil)) (z (list nil))) (symbol-macrolet ((y (car x)) (w (car z))) (multiple-value-setq (y w) (values 1 2))) (values x z)) (1) (2)) ;;; Another order of evaluation tests, this time with two ;;; symbol macro arguments (deftest multiple-value-setq.8 (let ((x (list nil)) (z (list nil)) (i 0)) (symbol-macrolet ((y (car (progn (incf i 3) x))) (w (car (progn (incf i i) z)))) (multiple-value-setq (y w) (values i 10))) (values x z)) (6) (10)) (deftest multiple-value-setq.9 (let (x) (values (multiple-value-setq (x x) (values 1 2)) x)) 1 2) (deftest multiple-value-setq.10 (let (x) (values (multiple-value-setq (x x) (values 1)) x)) 1 nil) (deftest multiple-value-setq.11 (let ((x 1) (y 2) (z 3)) (multiple-value-setq (x y z) (values)) (values x y z)) nil nil nil) (deftest multiple-value-setq.12 (let ((n (min 100 multiple-values-limit)) (vars nil) (result nil)) (loop for i from 1 below n for form = (progn (push (gensym) vars) (push i result) `(let ,vars (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) ,(car result)) (equal ,(make-list-expr vars) (quote ,result))))) unless (eval form) collect (list i form))) nil) gcl-2.6.14/ansi-tests/synonym-stream-symbol.lsp0000644000175000017500000000102714360276512020115 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 21:21:06 2004 ;;;; Contains: Tests of SYNONYM-STREAM-SYMBOL (in-package :cl-test) (deftest synonym-stream-symbol.1 (synonym-stream-symbol (make-synonym-stream '*standard-input*)) *standard-input*) (deftest synonym-stream-symbol.error.1 (signals-error (synonym-stream-symbol) program-error) t) (deftest synonym-stream-symbol.error.2 (signals-error (synonym-stream-symbol (make-synonym-stream '*terminal-io*) nil) program-error) t) gcl-2.6.14/ansi-tests/bit-andc2.lsp0000644000175000017500000001441214360276512015352 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:01:38 2003 ;;;; Contains: Tests of BIT-ANDC2 (in-package :cl-test) (deftest bit-andc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-andc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-andc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-andc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-andc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-andc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a0 #0a1 #0a1 t) (deftest bit-andc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a1 #0a0 t) ;;; Tests on bit vectors (deftest bit-andc2.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2)) a1 a2)) #*0010 #*0011 #*0101) (deftest bit-andc2.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-andc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0010 #*0010 #*0101 t) (deftest bit-andc2.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-andc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0010 #*0011 #*0101 #*0010 t) (deftest bit-andc2.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2 nil)) a1 a2)) #*0010 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-andc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2 t))) (values a1 a2 result)) #2a((0 1)(0 0)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-andc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0)) #2a((0 1)(0 0))) ;;; Adjustable arrays (deftest bit-andc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) ;;; Displaced arrays (deftest bit-andc2.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc2 a1 a2 t))) (values a0 a1 a2 result)) #*01000011 #2a((0 1)(0 0)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-andc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110100 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(0 0))) (deftest bit-andc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-andc2 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-andc2.error.1 (classify-error (bit-andc2)) program-error) (deftest bit-andc2.error.2 (classify-error (bit-andc2 #*000)) program-error) (deftest bit-andc2.error.3 (classify-error (bit-andc2 #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/cons-test-11.lsp0000644000175000017500000001353314360276512015750 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:37:56 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 11 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ldiff, tailp (deftest ldiff.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (cdddr x)))) (and (check-scaffold-copy x xcopy) result))) (a b c)) (deftest ldiff.2 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) (zerop (loop for a on x and b on result count (eqt a b))) result))) (a b c d e f)) ;; Works when the end of the dotted list is a symbol (deftest ldiff.3 (let* ((x (copy-tree '(a b c d e . f))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) result))) (a b c d e . f)) ;; Works when the end of the dotted list is a fixnum (deftest ldiff.4 (let* ((n 18) (x (list* 'a 'b 'c 18)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) result))) (a b c)) ;; Works when the end of the dotted list is a larger ;; integer (that is eql, but probably not eq). (deftest ldiff.5 (let* ((n 18000000000000) (x (list* 'a 'b 'c (1- 18000000000001))) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) result))) (a b c)) ;; Test works when the end of a dotted list is a string (deftest ldiff.6 (let* ((n (copy-seq "abcde")) (x (list* 'a 'b 'c n)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (if (equal result (list 'a 'b 'c)) (check-scaffold-copy x xcopy) result))) t) ;; Check that having the cdr of a dotted list be string-equal, but ;; not eql, does not result in success (deftest ldiff.7 (let* ((n (copy-seq "abcde")) (x (list* 'a 'b 'c n)) (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (copy-seq n)))) (if (equal result x) (check-scaffold-copy x xcopy) result))) t) ;; Check that on failure, the list returned by ldiff is ;; a copy of the list, not the list itself. (deftest ldiff.8 (let ((x (list 'a 'b 'c 'd))) (let ((result (ldiff x '(e)))) (and (equal x result) (loop for c1 on x for c2 on result count (eqt c1 c2))))) 0) (deftest ldiff.order.1 (let ((i 0) x y) (values (ldiff (progn (setf x (incf i)) (list* 'a 'b 'c 'd)) (progn (setf y (incf i)) 'd)) i x y)) (a b c) 2 1 2) ;; Error checking (deftest ldiff.error.1 (classify-error (ldiff 10 'a)) type-error) ;; Single atoms are not dotted lists, so the next ;; case should be a type-error (deftest ldiff.error.2 (classify-error (ldiff 'a 'a)) type-error) (deftest ldiff.error.3 (classify-error (ldiff (make-array '(10) :initial-element 'a) '(a))) type-error) (deftest ldiff.error.4 (classify-error (ldiff 1.23 t)) type-error) (deftest ldiff.error.5 (classify-error (ldiff #\w 'a)) type-error) (deftest ldiff.error.6 (classify-error (ldiff)) program-error) (deftest ldiff.error.7 (classify-error (ldiff nil)) program-error) (deftest ldiff.error.8 (classify-error (ldiff nil nil nil)) program-error) ;; Note! The spec is ambiguous on whether this next test ;; is correct. The spec says that ldiff should be prepared ;; to signal an error if the list argument is not a proper ;; list or dotted list. If listp is false, the list argument ;; is neither (atoms are not dotted lists). ;; ;; However, the sample implementation *does* work even if ;; the list argument is an atom. ;; #| (defun ldiff-12-body () (loop for x in *universe* count (and (not (listp x)) (not (eqt 'type-error (catch-type-error (ldiff x x))))))) (deftest ldiff-12 (ldiff-12-body) 0) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; tailp (deftest tailp.1 (let ((x (copy-tree '(a b c d e . f)))) (and (tailp x x) (tailp (cdr x) x) (tailp (cddr x) x) (tailp (cdddr x) x) (tailp (cddddr x) x) t)) t) ;; The next four tests test that tailp handles dotted lists. See ;; TAILP-NIL:T in the X3J13 documentation. (deftest tailp.2 (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) t) (deftest tailp.3 (tailp 'z (copy-tree '(a b c d . e))) nil) (deftest tailp.4 (notnot-mv (tailp 10203040506070 (list* 'a 'b (1- 10203040506071)))) t) (deftest tailp.5 (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) nil) (deftest tailp.error.5 (classify-error (tailp)) program-error) (deftest tailp.error.6 (classify-error (tailp nil)) program-error) (deftest tailp.error.7 (classify-error (tailp nil nil nil)) program-error) ;; Test that tailp does not modify its arguments (deftest tailp.6 (let* ((x (copy-list '(a b c d e))) (y (cddr x))) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (and (tailp y x) (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy)))) t) ;; Note! The spec is ambiguous on whether this next test ;; is correct. The spec says that tailp should be prepared ;; to signal an error if the list argument is not a proper ;; list or dotted list. If listp is false, the list argument ;; is neither (atoms are not dotted lists). ;; ;; However, the sample implementation *does* work even if ;; the list argument is an atom. ;; #| (defun tailp.7-body () (loop for x in *universe* count (and (not (listp x)) (eqt 'type-error (catch-type-error (tailp x x)))))) (deftest tailp.7 (tailp.7-body) 0) |# (deftest tailp.order.1 (let ((i 0) x y) (values (notnot (tailp (progn (setf x (incf i)) 'd) (progn (setf y (incf i)) '(a b c . d)))) i x y)) t 2 1 2) gcl-2.6.14/ansi-tests/subtypep-member.lsp0000644000175000017500000001254614360276512016735 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:58:06 2003 ;;;; Contains: Tests for subtype relationships on member types (in-package :cl-test) ;;; SUBTYPEP on MEMBER types (deftest subtypep.member.1 (check-all-subtypep '(member a b c) '(member a b c d)) nil) (deftest subtypep.member.2 (check-all-not-subtypep '(member a b c) '(member a b)) nil) (deftest subtypep.member.3 (check-equivalence '(member) nil) nil) (deftest subtypep.member.4 (check-all-subtypep '(eql b) '(member a b c)) nil) (deftest subtypep.member.5 (check-all-subtypep '(member a b c d e) 'symbol) nil) (deftest subtypep.member.6 (check-all-not-subtypep '(member a b 10 d e) 'symbol) nil) (deftest subtypep.member.7 (check-all-subtypep 'null '(member a b nil c d e)) nil) (deftest subtypep.member.8 (check-all-not-subtypep 'null '(member a b c d e)) nil) (deftest subtypep.member.9 (let ((b1 (1+ most-positive-fixnum)) (b2 (1+ most-positive-fixnum))) (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) (deftest subtypep.member.10 (check-all-subtypep '(member :a :b :c) 'keyword) nil) (deftest subtypep.member.11 (let ((b1 (copy-list '(a))) (b2 (copy-list '(a)))) (check-all-not-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) (deftest subtypep.member.12 (let ((b1 '(a))) (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b1))) nil) (deftest subtypep.member.13 (check-all-subtypep '(member 10 20 30) '(integer 0 100)) nil) (deftest subtypep.member.14 (check-all-subtypep '(integer 3 6) '(member 0 1 2 3 4 5 6 7 8 100)) nil) (deftest subtypep.member.15 (check-all-not-subtypep '(integer 3 6) '(member 0 1 2 3 5 6 7 8)) nil) (deftest subtypep.member.16 (check-equivalence '(integer 2 5) '(member 2 5 4 3)) nil) (deftest subtypep.member.17 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abc"))) (let ((t1 `(member ,s1)) (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.member.18 (let ((s1 (copy-seq '(a b c))) (s2 (copy-seq '(a b c)))) (let ((t1 `(member ,s1)) (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.member.19 (let ((i1 (1+ most-positive-fixnum)) (i2 (1+ most-positive-fixnum))) (check-equivalence `(member 0 ,i1) `(member 0 ,i2))) nil) (deftest subtypep.member.20 (check-equivalence '(and (member a b c d) (member e d b f g)) '(member b d)) nil) (deftest subtypep.member.21 (check-equivalence '(and (member a b c d) (member e d f g)) '(eql d)) nil) (deftest subtypep.member.22 (check-equivalence '(and (member a b c d) (member e f g)) nil) nil) (deftest subtypep.member.23 (check-equivalence '(or (member a b c) (member z b w)) '(member z a b w c)) nil) (deftest subtypep.member.24 (check-equivalence '(or (member a b c) (eql d)) '(member d c b a)) nil) (deftest subtypep.member.25 (check-equivalence 'boolean '(member nil t)) nil) (deftest subtypep.member.26 (check-equivalence '(or (eql a) (eql b)) '(member a b)) nil) (deftest subtypep.member.27 (check-all-subtypep '(member a b c d) '(satisfies symbolp)) nil) (deftest subtypep.member.28 (check-all-subtypep '(member a b c d) t) nil) (deftest subtypep.member.29 (check-all-not-subtypep '(member a b 10 z) '(satisfies symbolp)) nil) (deftest subtypep.member.30 (check-disjointness '(member 1 6 10) '(satisfies symbolp)) nil) (deftest subtypep.member.31 (check-equivalence '(member a b c d) '(member c d b a)) nil) (deftest subtypep.member.32 (check-all-not-subtypep '(not (member a b 10 z)) '(satisfies symbolp)) nil) (deftest subtypep.member.33 (check-all-not-subtypep '(satisfies symbolp) '(member a b 10 z)) nil) (deftest subtypep.member.34 (check-all-not-subtypep '(member a b 10 z) '(not (satisfies symbolp))) nil) (deftest subtypep.member.35 (check-all-not-subtypep '(satisfies symbolp) '(member a b c d)) nil) (deftest subtypep.member.36 (check-disjointness '(eql a) '(or (member b c d) (eql e))) nil) (deftest subtypep.member.37 (check-equivalence '(and (member a b c d) (not (eql c))) '(member a b d)) nil) (deftest subtypep.member.38 (check-equivalence '(and (member a b c d e f g) (not (member b f))) '(member a c d e g)) nil) (deftest subtypep.member.39 (check-equivalence '(and (not (member b d e f g)) (not (member x y b z d))) '(not (member b d e f g x y z))) nil) (deftest subtypep.member.40 (check-equivalence '(and (not (eql a)) (not (eql b))) '(not (member a b))) nil) (deftest subtypep.member.41 (check-equivalence '(and (not (eql a)) (not (eql b)) (not (eql c))) '(not (member c b a))) nil) (deftest subtypep.member.42 (check-equivalence '(and (not (member a b)) (not (member b c))) '(not (member c b a))) nil) (deftest subtypep.member.43 (check-equivalence '(and (not (member a g b k e)) (not (member b h k c f))) '(not (member c b k a e f g h))) nil) (deftest subtypep.member.44 (check-equivalence '(and (integer 0 30) (not (member 3 4 5 9 10 11 17 18 19))) '(or (integer 0 2) (integer 6 8) (integer 12 16) (integer 20 30))) nil) gcl-2.6.14/ansi-tests/string-upcase.lsp0000644000175000017500000000632514360276512016377 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 1 07:51:00 2002 ;;;; Contains: Tests for STRING-UPCASE (in-package :cl-test) (deftest string-upcase.1 (let ((s "a")) (values (string-upcase s) s)) "A" "a") (deftest string-upcase.2 (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (values (string-upcase s) s)) "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (deftest string-upcase.3 (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (values (string-upcase s) s)) "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest string-upcase.4 (string-upcase #\a) "A") (deftest string-upcase.5 (let ((sym '|a|)) (values (string-upcase sym) sym)) "A" |a|) (deftest string-upcase.6 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (values (string-upcase s) s)) "ABCDEF" "abcdef") (deftest string-upcase.7 (let ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) (values (string-upcase s) s)) "AB7DEF" "ab7def") ;; Tests with :start, :end (deftest string-upcase.8 (let ((s "abcdef")) (values (loop for i from 0 to 6 collect (string-upcase s :start i)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") (deftest string-upcase.9 (let ((s "abcdef")) (values (loop for i from 0 to 6 collect (string-upcase s :start i :end nil)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") (deftest string-upcase.10 (let ((s "abcde")) (values (loop for i from 0 to 4 collect (loop for j from i to 5 collect (string-upcase s :start i :end j))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE")) "abcde") (deftest string-upcase.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-upcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBCDef" 3 1 2 3) (deftest string-upcase.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (string-upcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBCDef" 3 1 2 3) ;;; Error cases (deftest string-upcase.error.1 (classify-error (string-upcase)) program-error) (deftest string-upcase.error.2 (classify-error (string-upcase (copy-seq "abc") :bad t)) program-error) (deftest string-upcase.error.3 (classify-error (string-upcase (copy-seq "abc") :start)) program-error) (deftest string-upcase.error.4 (classify-error (string-upcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest string-upcase.error.5 (classify-error (string-upcase (copy-seq "abc") :end)) program-error) (deftest string-upcase.error.6 (classify-error (string-upcase (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/prog1.lsp0000644000175000017500000000061014360276512014632 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:37:14 2002 ;;;; Contains: Tests for PROG1 (in-package :cl-test) (deftest prog1.1 (prog1 'a) a) (deftest prog1.2 (prog1 'a 'b) a) (deftest prog1.3 (prog1 (values 'a 'b) 'c) a) (deftest prog1.4 (prog1 (values) 'c) nil) (deftest prog1.5 (let ((x 0)) (values (prog1 x (incf x)) x)) 0 1) gcl-2.6.14/ansi-tests/pathname.lsp0000644000175000017500000000405414360276512015405 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 05:06:57 2003 ;;;; Contains: Tests of the function PATHNAME (in-package :cl-test) (deftest pathname.1 (loop for x in *pathnames* always (eq x (pathname x))) t) (deftest pathname.2 (equalt #p"ansi-aux.lsp" (pathname "ansi-aux.lsp")) t) (deftest pathname.3 (let ((s (open "ansi-aux.lsp" :direction :input))) (prog1 (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp")) (close s))) t) (deftest pathname.4 (let ((s (open "ansi-aux.lsp" :direction :input))) (close s) (equalt (truename (pathname s)) (truename #p"ansi-aux.lsp"))) t) (deftest pathname.5 (loop for x in *logical-pathnames* always (eq x (pathname x))) t) (deftest pathname.6 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'base-char))) t) (deftest pathname.7 (equalt #p"ansi-aux.lsp" (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" :element-type 'base-char :fill-pointer 12))) t) (deftest pathname.8 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'base-char :adjustable t))) t) (deftest pathname.9 (equalt #p"ansi-aux.lsp" (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" :element-type 'character :fill-pointer 12))) t) (deftest pathname.10 (equalt #p"ansi-aux.lsp" (pathname (make-array 12 :initial-contents "ansi-aux.lsp" :element-type 'character :adjustable t))) t) (deftest pathname.11 (loop for etype in '(standard-char base-char character) collect (equalt #p"ansi-aux.lsp" (pathname (let* ((s (make-array 15 :initial-contents "XXansi-aux.lspX" :element-type etype))) (make-array 12 :element-type etype :displaced-to s :displaced-index-offset 2))))) (t t t)) ;;; Error tests (deftest pathname.error.1 (signals-error (pathname) program-error) t) (deftest pathname.error.2 (signals-error (pathname (first *pathnames*) nil) program-error) t) gcl-2.6.14/ansi-tests/fill.lsp0000644000175000017500000003054514360276512014542 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:44:45 2002 ;;;; Contains: Tests on FILL (in-package :cl-test) (deftest fill.error.1 (classify-error (fill 'a 'b)) type-error) (deftest fill.error.2 (classify-error (fill)) program-error) (deftest fill.error.3 (classify-error (fill (list 'a 'b))) program-error) (deftest fill.error.4 (classify-error (fill (list 'a 'b) 'c :bad t)) program-error) (deftest fill.error.5 (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil)) program-error) (deftest fill.error.6 (classify-error (fill (list 'a 'b) 'c :start)) program-error) (deftest fill.error.7 (classify-error (fill (list 'a 'b) 'c :end)) program-error) (deftest fill.error.8 (classify-error (fill (list 'a 'b) 'c 1 2)) program-error) (deftest fill.error.10 (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest fill.error.11 (classify-error (locally (fill 'a 'b) t)) type-error) ;;; Fill on arrays (deftest array-fill-1 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x))) (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-2 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 2))) (values (eqt a b) (map 'list #'identity a))) t (a b x x x)) (deftest array-fill-3 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end 2))) (values (eqt a b) (map 'list #'identity a))) t (x x c d e)) (deftest array-fill-4 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end 3))) (values (eqt a b) (map 'list #'identity a))) t (a x x d e)) (deftest array-fill-5 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (a x x x x)) (deftest array-fill-6 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end nil))) (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-7 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :start -1))) type-error) (deftest array-fill-8 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :start 'a))) type-error) (deftest array-fill-9 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :end -1))) type-error) (deftest array-fill-10 (classify-error (let* ((a (make-array '(5)))) (fill a 'x :end 'a))) type-error) ;;; fill on arrays of fixnums (deftest array-fixnum-fill-1 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6))) (values (eqt a b) (map 'list #'identity a))) t (6 6 6 6 6)) (deftest array-fixnum-fill-2 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6 :start 2))) (values (eqt a b) (map 'list #'identity a))) t (1 2 6 6 6)) (deftest array-fixnum-fill-3 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 7 :end 2))) (values (eqt a b) (map 'list #'identity a))) t (7 7 3 4 5)) (deftest array-fixnum-fill-4 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 8 :start 1 :end 3))) (values (eqt a b) (map 'list #'identity a))) t (1 8 8 4 5)) (deftest array-fixnum-fill-5 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 0 :start 1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (1 0 0 0 0)) (deftest array-fixnum-fill-6 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a -1 :end nil))) (values (eqt a b) (map 'list #'identity a))) t (-1 -1 -1 -1 -1)) (deftest array-fixnum-fill-7 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 10 :start -1))) type-error) (deftest array-fixnum-fill-8 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 100 :start 'a))) type-error) (deftest array-fixnum-fill-9 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a -5 :end -1))) type-error) (deftest array-fixnum-fill-10 (classify-error (let* ((a (make-array '(5) :element-type 'fixnum))) (fill a 17 :end 'a))) type-error) ;;; fill on arrays of unsigned eight bit bytes (deftest array-unsigned-byte8-fill-1 (array-unsigned-byte-fill-test-fn 8 6) t (6 6 6 6 6)) (deftest array-unsigned-byte8-fill-2 (array-unsigned-byte-fill-test-fn 8 6 :start 2) t (1 2 6 6 6)) (deftest array-unsigned-byte8-fill-3 (array-unsigned-byte-fill-test-fn 8 7 :end 2) t (7 7 3 4 5)) (deftest array-unsigned-byte8-fill-4 (array-unsigned-byte-fill-test-fn 8 8 :start 1 :end 3) t (1 8 8 4 5)) (deftest array-unsigned-byte8-fill-5 (array-unsigned-byte-fill-test-fn 8 9 :start 1 :end nil) t (1 9 9 9 9)) (deftest array-unsigned-byte8-fill-6 (array-unsigned-byte-fill-test-fn 8 0 :end nil) t (0 0 0 0 0)) (deftest array-unsigned-byte8-fill-7 (classify-error (array-unsigned-byte-fill-test-fn 8 0 :start -1)) type-error) (deftest array-unsigned-byte8-fill-8 (classify-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a)) type-error) (deftest array-unsigned-byte8-fill-9 (classify-error (array-unsigned-byte-fill-test-fn 8 19 :end -1)) type-error) (deftest array-unsigned-byte8-fill-10 (classify-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a)) type-error) ;;; Tests on arrays with fill pointers (deftest array-fill-pointer-fill.1 (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) (fill s1 'a) (loop for i from 0 to 9 collect (aref s1 i))) (a a a a a nil nil nil nil nil)) (deftest array-fill-pointer-fill.2 (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) (fill s1 'a :end nil) (loop for i from 0 to 9 collect (aref s1 i))) (a a a a a nil nil nil nil nil)) ;;; Tests on strings (deftest fill.string.1 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.2 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :start 0 :end 1))) (values (eqt s1 s2) s2)) t "zbcde") (deftest fill.string.3 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :end 2))) (values (eqt s1 s2) s2)) t "zzcde") (deftest fill.string.4 (let* ((s1 (copy-seq "abcde")) (s2 (fill s1 #\z :end nil))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.5 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (loop for end from (1+ start) to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :start start :end end))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :start start :end end)) t))))) t) (deftest fill.string.6 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :start start))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :start start)) t)))) t) (deftest fill.string.7 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :end nil :start start))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :end nil :start start)) t)))) t) (deftest fill.string.8 (let* ((s1 "aaaaaaaa") (len (length s1))) (loop for end from 1 to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 #\z :end end))) (and (eqt s2 s3) (string= s3 (substitute-if #\z (constantly t) s1 :end end)) t)))) t) (deftest fill.string.9 (let* ((s1 (make-array '(8) :element-type 'character :initial-element #\z :fill-pointer 4)) (s2 (fill s1 #\a))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'string))) "aaaazzzz") (deftest fill.string.10 (let* ((s1 (make-array '(8) :element-type 'base-char :initial-element #\z :fill-pointer 4)) (s2 (fill s1 #\a))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'base-string))) "aaaazzzz") ;;; Tests for bit vectors (deftest fill.bit-vector.1 (let* ((s1 (copy-seq #*01100)) (s2 (fill s1 0))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.2 (let* ((s1 (copy-seq #*00100)) (s2 (fill s1 1 :start 0 :end 1))) (values (eqt s1 s2) s2)) t #*10100) (deftest fill.bit-vector.3 (let* ((s1 (copy-seq #*00010)) (s2 (fill s1 1 :end 2))) (values (eqt s1 s2) s2)) t #*11010) (deftest fill.bit-vector.4 (let* ((s1 (copy-seq #*00111)) (s2 (fill s1 0 :end nil))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.5 (let* ((s1 #*00000000) (len (length s1))) (loop for start from 0 to (1- len) always (loop for end from (1+ start) to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 1 :start start :end end))) (and (eqt s2 s3) (equalp s3 (substitute-if 1 (constantly t) s1 :start start :end end)) t))))) t) (deftest fill.bit-vector.6 (let* ((s1 #*11111111) (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 0 :start start))) (and (eqt s2 s3) (equalp s3 (substitute-if 0 (constantly t) s1 :start start)) t)))) t) (deftest fill.bit-vector.7 (let* ((s1 #*00000000) (len (length s1))) (loop for start from 0 to (1- len) always (let* ((s2 (copy-seq s1)) (s3 (fill s2 1 :end nil :start start))) (and (eqt s2 s3) (equalp s3 (substitute-if 1 (constantly t) s1 :end nil :start start)) t)))) t) (deftest fill.bit-vector.8 (let* ((s1 #*11111111) (len (length s1))) (loop for end from 1 to len always (let* ((s2 (copy-seq s1)) (s3 (fill s2 0 :end end))) (and (eqt s2 s3) (equalp s3 (substitute-if 0 (constantly t) s1 :end end)) t)))) t) (deftest fill.bit-vector.9 (let* ((s1 (make-array '(8) :element-type 'bit :initial-element 0 :fill-pointer 4)) (s2 (fill s1 1))) (and (eqt s1 s2) (coerce (loop for i from 0 to 7 collect (aref s2 i)) 'bit-vector))) #*11110000) ;;; Test of :allow-other-keys (deftest fill.allow-other-keys.1 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.2 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys nil) (a a a a a)) (deftest fill.allow-other-keys.3 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :bad t) (a a a a a)) (deftest fill.allow-other-keys.4 (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.5 (fill (list 'a 'b 'c 'd 'e) 'a 'bad t :allow-other-keys t) (a a a a a)) (deftest fill.allow-other-keys.6 (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t :allow-other-keys nil) (a a a a a)) (deftest fill.allow-other-keys.7 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :allow-other-keys nil :bad t) (a a a a a)) ;;; Tests of evaluation order (deftest fill.order.1 (let ((i 0) x y (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z)) i x y)) #(z z z z) 2 1 2) (deftest fill.order.2 (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :start (progn (setf z (incf i)) 1) :end (progn (setf w (incf i)) 3)) i x y z w)) #(a z z a) 4 1 2 3 4) (deftest fill.order.3 (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :end (progn (setf z (incf i)) 3) :start (progn (setf w (incf i)) 1)) i x y z w)) #(a z z a) 4 1 2 3 4) (deftest fill.order.4 (let ((i 0) x y z p q r s w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) (progn (setf y (incf i)) 'z) :end (progn (setf z (incf i)) 3) :end (progn (setf p (incf i)) 1) :end (progn (setf q (incf i)) 1) :end (progn (setf r (incf i)) 1) :start (progn (setf s (incf i)) 1) :start (progn (setf w (incf i)) 0)) i x y z p q r s w)) #(a z z a) 8 1 2 3 4 5 6 7 8) gcl-2.6.14/ansi-tests/packages-19.lsp0000644000175000017500000000272514360276512015620 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue May 5 17:22:49 1998 ;;;; Contains: Packages test code, part 19. Tests of the keyword package. ;;;; See also cl-symbols.lsp (for keywordp test cases) (in-package :cl-test) (declaim (optimize (safety 3))) ;; Check that each keyword satisfies keywordp (deftest keyword.1 (do-symbols (s "KEYWORD" t) (unless (keywordp s) (return (list s nil)))) t) ;; Every keyword is external (deftest keyword.2 (do-symbols (s "KEYWORD" t) (multiple-value-bind (s2 access) (find-symbol (symbol-name s) "KEYWORD") (unless (and (eqt s s2) (eqt access :external)) (return (list s2 access))))) t) ;; Every keyword evaluates to itself (deftest keyword.3 (do-symbols (s "KEYWORD" t) (unless (eqt s (eval s)) (return (list s (eval s))))) t) ;;; Other error tests (deftest package-shadowing-symbols.error.1 (classify-error (package-shadowing-symbols)) program-error) (deftest package-shadowing-symbols.error.2 (classify-error (package-shadowing-symbols "CL" nil)) program-error) (deftest package-use-list.error.1 (classify-error (package-use-list)) program-error) (deftest package-use-list.error.2 (classify-error (package-use-list "CL" nil)) program-error) (deftest package-used-by-list.error.1 (classify-error (package-used-by-list)) program-error) (deftest package-used-by-list.error.2 (classify-error (package-used-by-list "CL" nil)) program-error) gcl-2.6.14/ansi-tests/random-aux.lsp0000644000175000017500000000474114360276512015666 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jun 8 06:56:15 2003 ;;;; Contains: Aux. functions and macros used for randomization (in-package :cl-test) (defun random-from-seq (seq) "Generate a random member of a sequence." (let ((len (length seq))) (assert (> len 0)) (elt seq (random len)))) (defmacro random-case (&body cases) (let ((len (length cases))) (assert (> len 0)) `(case (random ,len) ,@(loop for i from 0 for e in cases collect `(,i ,e)) (t (error "Can't happen?! (in random-case)~%"))))) (defmacro rcase (&body cases) "Usage: (RCASE ( +)+), where is a positive real indicating the relative probability of executing the associated implicit progn." (assert cases) (let* ((weights (mapcar #'car cases)) (cumulative-weights (let ((sum 0)) (loop for w in weights collect (incf sum w)))) (total (car (last cumulative-weights))) (r (gensym))) (assert (every #'plusp weights)) `(let ((,r (random ,total))) (cond ,@(loop for case in (butlast cases) for cw in cumulative-weights collect `((< ,r ,cw) ,@(cdr case))) (t ,@(cdar (last cases))))))) (defun random-nonnegative-real () (if (coin 3) (random-case (/ (random 10000) (1+ (random 1000))) (/ (random 1000000) (1+ (random 100000))) (/ (random 100000000) (1+ (random 10000000))) (/ (random 1000000000000) (1+ (random 10000000)))) (random (random-case 1000 100000 10000000 1000000000 (expt 2.0s0 (random 15)) (expt 2.0f0 (random 32)) (expt 2.0d0 (random 32)) (expt 2.0l0 (random 32)))))) (defun random-real () (if (coin) (random-nonnegative-real) (- (random-nonnegative-real)))) (defun random-fixnum () (+ (random (1+ (- most-positive-fixnum most-negative-fixnum))) most-negative-fixnum)) (defun random-from-interval (upper &optional (lower (- upper))) (+ (random (- upper lower)) lower)) (defun coin (&optional (n 2)) "Flip an n-sided coin." (eql (random n) 0)) ;;; Randomly permute a sequence (defun random-permute (seq) (setq seq (copy-seq seq)) (let ((len (length seq))) (loop for i from len downto 2 do (let ((r (random i))) (rotatef (elt seq r) (elt seq (1- i)))))) seq) (defun binomial-distribution-test (n fn) (let* ((count (loop repeat n count (funcall fn))) (sigma (/ (sqrt n) 2.0)) (bound (* sigma 6)) (expected (/ n 2.0))) (<= (- expected bound) count (+ expected bound)))) gcl-2.6.14/ansi-tests/stream-error-stream.lsp0000644000175000017500000000121514360276512017517 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:51:33 2004 ;;;; Contains: Tests of STREAM-ERROR-STREAM (in-package :cl-test) (deftest stream-error-stream.1 (with-input-from-string (s "") (handler-case (read-char s) (stream-error (c) (eqlt (stream-error-stream c) s)))) t) ;;; Error tests (deftest stream-error-stream.error.1 (signals-error (stream-error-stream) program-error) t) (deftest stream-error-stream.error.2 (signals-error (with-input-from-string (s "") (handler-case (read-char s) (stream-error (c) (stream-error-stream c nil)))) program-error) t) gcl-2.6.14/ansi-tests/load-eval-and-compile.lsp0000644000175000017500000000026514360276512017642 0ustar cammcamm;;; Tests of evaluation and compilation (load "eval.lsp") (load "eval-and-compile.lsp") (load "compile.lsp") (load "compiler-macros.lsp") (load "constantp.lsp") (load "lambda.lsp") gcl-2.6.14/ansi-tests/multiple-value-list.lsp0000644000175000017500000000143714360276512017530 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Feb 17 06:38:07 2003 ;;;; Contains: Tests of MULTIPLE-VALUE-LIST (in-package :cl-test) (deftest multiple-value-list.1 (multiple-value-list 'a) (a)) (deftest multiple-value-list.2 (multiple-value-list (values)) nil) (deftest multiple-value-list.3 (multiple-value-list (values 'a 'b 'c 'd 'e)) (a b c d e)) (deftest multiple-value-list.4 (multiple-value-list (values (values 'a 'b 'c 'd 'e))) (a)) (deftest multiple-value-list.order.1 (let ((i 0)) (values (multiple-value-list (incf i)) i)) (1) 1) #| (deftest multiple-value-list.error.1 (classify-error (multiple-value-list)) program-error) (deftest multiple-value-list.error.2 (classify-error (multiple-value-list 'a 'b)) program-error) |# gcl-2.6.14/ansi-tests/defconstant.lsp0000644000175000017500000000204714360276512016120 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:05:39 2002 ;;;; Contains: Tests of DEFCONSTANT (in-package :cl-test) (defconstant test-constant-1 17) (deftest defconstant.1 (symbol-value 'test-constant-1) 17) (deftest defconstant.2 (notnot-mv (constantp 'test-constant-1)) t) (deftest defconstant.3 (documentation 'test-constant-1 'variable) nil) (defconstant test-constant-2 'a "This is the documentation.") (deftest defconstant.4 (documentation 'test-constant-2 'variable) "This is the documentation.") (deftest defconstant.5 (defconstant test-constant-3 0) test-constant-3) ;;; (deftest defconstant.error.1 ;;; (classify-error (defconstant)) ;;; program-error) ;;; ;;; (deftest defconstant.error.2 ;;; (classify-error (defconstant +ignorable-constant-name+)) ;;; program-error) ;;; ;;; (deftest defconstant.error.3 ;;; (classify-error (defconstant +ignorable-constant-name2+ nil ;;; "This is a docstring" ;;; "This is an unnecessary extra argument.")) ;;; program-error) gcl-2.6.14/ansi-tests/unwind-protect.lsp0000644000175000017500000000322414360276512016570 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 14:41:16 2002 ;;;; Contains: Tests of UNWIND-PROTECT (in-package :cl-test) (deftest unwind-protect.1 (let ((x nil)) (unwind-protect (push 1 x) (incf (car x)))) (2)) (deftest unwind-protect.2 (let ((x nil)) (block foo (unwind-protect (progn (push 1 x) (return-from foo x)) (incf (car x))))) (2)) (deftest unwind-protect.3 (let ((x nil)) (tagbody (unwind-protect (progn (push 1 x) (go done)) (incf (car x))) done) x) (2)) (deftest unwind-protect.4 (let ((x nil)) (catch 'done (unwind-protect (progn (push 1 x) (throw 'done x)) (incf (car x))))) (2)) (deftest unwind-protect.5 (let ((x nil)) (ignore-errors (unwind-protect (progn (push 1 x) (error "Boo!")) (incf (car x)))) x) (2)) (deftest unwind-protect.6 (let ((x nil)) (block done (flet ((%f () (return-from done nil))) (unwind-protect (%f) (push 'a x)))) x) (a)) (deftest unwind-protect.7 (let ((x nil)) (block done (flet ((%f () (return-from done nil))) (unwind-protect (unwind-protect (%f) (push 'b x)) (push 'a x)))) x) (a b)) (deftest unwind-protect.8 (let ((x nil)) (block done (unwind-protect (flet ((%f () (return-from done nil))) (unwind-protect (unwind-protect (%f) (push 'b x)) (push 'a x))) (push 'c x))) x) (c a b)) (deftest unwind-protect.9 (let ((x nil)) (handler-case (flet ((%f () (error 'type-error :datum 'foo :expected-type nil))) (unwind-protect (handler-case (%f)) (push 'a x))) (type-error () x))) (a)) gcl-2.6.14/ansi-tests/complement.lsp0000644000175000017500000000234014360276512015747 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 20:04:33 2002 ;;;; Contains: Tests for COMPLEMENT (in-package :cl-test) (deftest complement.1 (notnot-mv (funcall (complement #'identity) nil)) t) (deftest complement.2 (funcall (complement #'identity) t) nil) (deftest complement.3 (every #'(lambda (x) (eql (funcall (cl::complement #'not) x) (not (not x)))) *universe*) t) (deftest complement.4 (let ((x '(#\b))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) always (progn (push #\a x) (apply (complement #'char=) x)))) t) (deftest complement.5 (notnot-mv (complement #'identity)) t) (deftest complement.order.1 (let ((i 0)) (let ((fn (complement (progn (incf i) #'null)))) (values i (mapcar fn '(a b nil c 1 nil t nil)) i))) 1 (t t nil t t nil t nil) 1) (deftest complement.error.1 (classify-error (complement)) program-error) (deftest complement.error.2 (classify-error (complement #'not t)) program-error) (deftest complement.error.3 (classify-error (funcall (complement #'identity))) program-error) (deftest complement.error.4 (classify-error (funcall (complement #'identity) t t)) program-error) gcl-2.6.14/ansi-tests/progv.lsp0000644000175000017500000000242214360276512014742 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 10:00:50 2002 ;;;; Contains: Tests for PROGV (in-package :cl-test) (deftest progv.1 (progv () () t) t) (deftest progv.2 (progv '(x) '(1) (not (not (boundp 'x)))) t) (deftest progv.3 (progv '(x) '(1) (symbol-value 'x)) 1) (deftest progv.4 (progv '(x) '(1) (locally (declare (special x)) x)) 1) (deftest progv.5 (let ((x 0)) (progv '(x) '(1) x)) 0) (deftest progv.6 (let ((x 0)) (declare (special x)) (progv '(x) () (boundp 'x))) nil) (deftest progv.6a (let ((x 0)) (declare (special x)) (progv '(x) () (setq x 1)) x) 0) (deftest progv.7 (progv '(x y z) '(1 2 3) (locally (declare (special x y z)) (values x y z))) 1 2 3) (deftest progv.8 (progv '(x y z) '(1 2 3 4 5 6 7 8) (locally (declare (special x y z)) (values x y z))) 1 2 3) (deftest progv.9 (let ((x 0)) (declare (special x)) (progv '(x y z w) '(1) (values (not (not (boundp 'x))) (boundp 'y) (boundp 'z) (boundp 'w)))) t nil nil nil) ;; forms are evaluated in order (deftest progv.10 (let ((x 0) (y 0) (c 0)) (progv (progn (setf x (incf c)) nil) (progn (setf y (incf c)) nil) (values x y c))) 1 2 2) gcl-2.6.14/ansi-tests/map.lsp0000644000175000017500000001370114360276512014364 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 17 20:54:48 2002 ;;;; Contains: Tests for the MAP function (in-package :cl-test) (deftest map-array.1 (map 'list #'1+ #(1 2 3 4)) (2 3 4 5)) (deftest map-array.2 (map 'vector #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.3 (map 'vector #'+ #(1 2 3 4 5) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.4 (map 'vector #'+ #(1 2 3 4) #(6 6 6 6 6)) #(7 8 9 10)) (deftest map-array.5 (map '(vector *) #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) (deftest map-array.6 (map '(vector * 4) #'+ #(1 2 3 4) #(6 6 6 6)) #(7 8 9 10)) ;;; (deftest map-array.7 ;;; (map 'array #'identity '(a b c d e f)) ;;; #(a b c d e f)) ;;; (deftest map-array.8 ;;; (map 'simple-array #'identity '(a b c d e f)) ;;; #(a b c d e f)) (deftest map-array.9 (map 'simple-vector #'identity '(a b c d e f)) #(a b c d e f)) (deftest map-array.10 (map 'simple-vector #'cons '(a b c d e f) #(1 2 3 4 5 6)) #((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) (deftest map-array.11 (map 'vector #'identity '(#\a #\b #\c #\d #\e)) #(#\a #\b #\c #\d #\e)) (deftest map-array.12 (map 'vector #'identity "abcde") #(#\a #\b #\c #\d #\e)) (deftest map-array.13 (map 'vector #'identity #*000001) #(0 0 0 0 0 1)) (deftest map-array.14 (map 'list #'identity #*000001) (0 0 0 0 0 1)) (deftest map-bit-vector.15 (map 'bit-vector #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.16 (map 'simple-bit-vector #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.17 (map '(vector bit) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.18 (map '(simple-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.19 (map '(bit-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.20 (map '(bit-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.21 (map '(simple-bit-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.22 (map '(simple-bit-vector *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.23 (map '(vector bit 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.24 (map '(vector bit *) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-bit-vector.25 (map '(simple-vector 6) #'identity '(0 0 0 0 0 1)) #*000001) (deftest map-string.26 (map 'string #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.27 (map 'string #'identity "abcde") "abcde") (deftest map-string.28 (map '(vector character) #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.29 (map '(vector character 5) #'identity '(#\a #\b #\c #\d #\e)) "abcde") (deftest map-string.30 (map '(simple-vector 5) #'identity '(#\a #\b #\c #\d #\e)) "abcde") ;;; Use a more elaborate form of the simple-array type specifier ;;; (deftest map-string.31 ;;; (map '(simple-array character *) #'identity "abcde") ;;; "abcde") ;;; Use a more elaborate form of the simple-array type specifier ;;; (deftest map-string.32 ;;; (map '(simple-array character 5) #'identity "abcde") ;;; "abcde") (deftest map-nil.33 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) "abcdef") a)) nil (#\f #\e #\d #\c #\b #\a)) (deftest map-nil.34 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) '(a b c d e)) a)) nil (e d c b a)) (deftest map-nil.35 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) #(a b c d e)) a)) nil (e d c b a)) (deftest map-nil.36 (let ((a nil)) (values (map nil #'(lambda (x) (push x a)) #*001011110) a)) nil (0 1 1 1 1 0 1 0 0)) (deftest map-null.1 (map 'null #'identity nil) nil) (deftest map-cons.1 (map 'cons #'identity '(a b c)) (a b c)) (deftest map.error.1 (handler-case (progn (proclaim '(optimize (safety 3))) (eval '(map 'symbol #'identity '(a b c)))) (error () :caught)) :caught) (deftest map.error.2 (classify-error (map '(vector * 8) #'identity '(a b c))) type-error) (deftest map.error.3 (classify-error (map 'list #'identity '(a b . c))) type-error) (deftest map.error.4 (classify-error (map)) program-error) (deftest map.error.5 (classify-error (map 'list)) program-error) (deftest map.error.6 (classify-error (map 'list #'null)) program-error) (deftest map.error.7 (classify-error (map 'list #'cons '(a b c d))) program-error) (deftest map.error.8 (classify-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8))) program-error) (deftest map.error.9 (classify-error (map 'list #'car '(a b c d))) type-error) ;;; Test mapping on arrays with fill pointers (deftest map.fill.1 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 8))) (map 'list #'identity s1)) (a b c d e f g h)) (deftest map.fill.2 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.3 (let ((s1 (make-array '(10) :initial-element #\a :element-type 'character :fill-pointer 8))) (map 'string #'identity s1)) "aaaaaaaa") (deftest map.fill.4 (let ((s1 (make-array '(10) :initial-element #\a :element-type 'base-char :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.5 (let ((s1 (make-array '(10) :initial-element 0 :element-type 'bit :fill-pointer 8))) (map 'bit-vector #'identity s1)) #*00000000) (deftest map.fill.6 (let ((s1 (make-array '(10) :initial-element 1 :element-type 'bit :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) ;;; Order of evaluation tests (deftest map.order.1 (let ((i 0) a b c d) (values (map (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) #'list) (progn (setf c (incf i)) '(a b c)) (progn (setf d (incf i)) '(b c d))) i a b c d)) ((a b)(b c)(c d)) 4 1 2 3 4) gcl-2.6.14/ansi-tests/sbit.lsp0000644000175000017500000000340514360276512014550 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 15:30:31 2003 ;;;; Contains: Tests for SBIT (in-package :cl-test) (deftest sbit.1 (sbit #*0010 2) 1) (deftest sbit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (sbit b i) 1) b))) (#*10000000 #*01000000 #*00100000 #*00010000 #*00001000 #*00000100 #*00000010 #*00000001)) (deftest sbit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (sbit b i) 0) b))) (#*01111111 #*10111111 #*11011111 #*11101111 #*11110111 #*11111011 #*11111101 #*11111110)) (deftest sbit.4 (let ((a (make-array nil :element-type 'bit :initial-element 0))) (values (aref a) (sbit a) (setf (sbit a) 1) (aref a) (sbit a))) 0 0 1 1 1) (deftest sbit.5 (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) (values (aref a 0 0) (sbit a 0 0) (setf (sbit a 0 0) 1) (aref a 0 0) (sbit a 0 0))) 0 0 1 1 1) (deftest sbit.6 (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) (values (aref a 5 5) (sbit a 5 5) (setf (sbit a 5 5) 1) (aref a 5 5) (sbit a 5 5))) 0 0 1 1 1) (deftest sbit.order.1 (let ((i 0) a b) (values (sbit (progn (setf a (incf i)) #*001001) (progn (setf b (incf i)) 1)) i a b)) 0 2 1 2) (deftest sbit.order.2 (let ((i 0) a b c (v (copy-seq #*001001))) (values (setf (sbit (progn (setf a (incf i)) v) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) 1)) v i a b c)) 1 #*011001 3 1 2 3) (deftest sbit.error.1 (classify-error (sbit)) program-error) gcl-2.6.14/ansi-tests/simple-vector-p.lsp0000644000175000017500000000303214360276512016631 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:23:45 2003 ;;;; Contains: Tests for SIMPLE-VECTOR-P (in-package :cl-test) ;;; More tests for this are in make-array.lsp (deftest simple-vector-p.1 (loop for e in *universe* unless (if (typep e 'simple-vector) (simple-vector-p e) (not (simple-vector-p e))) collect e) nil) (deftest simple-vector-p.2 (notnot-mv (simple-vector-p (make-array '(10)))) t) ;; (deftest simple-vector-p.3 ;; (simple-vector-p (make-array '(5) :fill-pointer t)) ;; nil) (deftest simple-vector-p.4 (notnot-mv (simple-vector-p (vector 'a 'b 'c))) t) ;;; (deftest simple-vector-p.5 ;;; (simple-vector-p (make-array '(5) :adjustable t)) ;;; nil) ;;; (deftest simple-vector-p.6 ;;; (let ((a #(a b c d e g h))) ;;; (simple-vector-p (make-array '(5) :displaced-to a))) ;;; nil) (deftest simple-vector-p.7 (simple-vector-p #*001101) nil) (deftest simple-vector-p.8 (simple-vector-p "abcdef") nil) (deftest simple-vector-p.9 (simple-vector-p (make-array nil)) nil) (deftest simple-vector-p.10 (simple-vector-p (make-array '(10) :element-type 'base-char)) nil) (deftest simple-vector-p.11 (simple-vector-p (make-array '(10) :element-type 'character)) nil) (deftest simple-vector-p.12 (simple-vector-p (make-array '(10) :element-type 'bit)) nil) ;;; Error tests (deftest simple-vector-p.error.1 (classify-error (simple-vector-p)) program-error) (deftest simple-vector-p.error.2 (classify-error (simple-vector-p #(a b) nil)) program-error) gcl-2.6.14/ansi-tests/multiple-value-prog1.lsp0000644000175000017500000000267014360276512017605 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 06:48:02 2002 ;;;; Contains: Tests for MULTIPLE-VALUE-PROG1 (in-package :cl-test) (deftest multiple-value-prog1.1 (multiple-value-prog1 nil) nil) (deftest multiple-value-prog1.2 (multiple-value-prog1 '(a b c)) (a b c)) (deftest multiple-value-prog1.3 (multiple-value-prog1 (values-list '(a b c))) a b c) (deftest multiple-value-prog1.4 (multiple-value-prog1 (values))) (deftest multiple-value-prog1.5 (let ((x 0) (y 0)) (multiple-value-prog1 (values x y) (incf x) (incf y 2))) 0 0) (deftest multiple-value-prog1.6 (let ((x 0) (y 0)) (multiple-value-call #'list (multiple-value-prog1 (values x y) (incf x) (incf y 2)) x y)) (0 0 1 2)) (deftest multiple-value-prog1.7 (let ((x 0) (y 0)) (multiple-value-call #'list (multiple-value-prog1 (values (incf x) y) (incf x x) (incf y 10)) x y)) (1 0 2 10)) (deftest multiple-value-prog1.8 (let* ((n (min 100 multiple-values-limit))) (not-mv (loop for i from 0 below n for x = (make-int-list i) always (equalt (multiple-value-list (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) nil))) x)))) nil) (deftest multiple-value-prog1.9 (let ((x 0) (y 0)) (values (block foo (multiple-value-prog1 (values (incf x) (incf y 2)) (return-from foo 'a))) x y)) a 1 2) gcl-2.6.14/ansi-tests/file-string-length.lsp0000644000175000017500000000343114360276512017310 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 22 21:34:04 2004 ;;;; Contains: Tests of FILE-STRING-LENGTH (in-package :cl-test) (deftest file-string-length.1 (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ for len = (file-string-length s x) do (assert (typep len '(or null (integer 0)))) do (let ((pos1 (file-position s))) (write-char x s) (let ((pos2 (file-position s))) (when (and pos1 pos2 len) (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.2 (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ for len = (file-string-length s (string x)) do (assert (typep len '(or null (integer 0)))) do (let ((pos1 (file-position s))) (write-sequence (string x) s) (let ((pos2 (file-position s))) (when (and pos1 pos2 len) (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.3 (with-open-file (stream "tmp.dat" :direction :output :if-exists :supersede) (let* ((s1 "abcde") (n (file-string-length stream s1))) (do-special-strings (s2 s1 nil) (assert (= (file-string-length stream s2) n))))) nil) ;;; Error tests (deftest file-string-length.error.1 (signals-error (file-string-length) program-error) t) (deftest file-string-length.error.2 (signals-error (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s)) program-error) t) (deftest file-string-length.error.3 (signals-error (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s #\x nil)) program-error) t) gcl-2.6.14/ansi-tests/loop7.lsp0000644000175000017500000001263514360276512014654 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Nov 11 21:40:05 2002 ;;;; Contains: Tests for FOR-AS-PACKAGE clause for LOOP (in-package :cl-test) (defpackage "LOOP.CL-TEST.1" (:use) (:intern "FOO" "BAR" "BAZ") (:export "A" "B" "C")) (defpackage "LOOP.CL-TEST.2" (:use "LOOP.CL-TEST.1") (:intern "X" "Y" "Z")) (deftest loop.7.1 (sort (mapcar #'symbol-name (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.2 (sort (mapcar #'symbol-name (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.3 (sort (mapcar #'symbol-name (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.4 (sort (mapcar #'symbol-name (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.5 (sort (mapcar #'symbol-name (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.6 (sort (mapcar #'symbol-name (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.7 (sort (mapcar #'symbol-name (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.8 (sort (mapcar #'symbol-name (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.9 (sort (mapcar #'symbol-name (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.10 (sort (mapcar #'symbol-name (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.11 (sort (mapcar #'symbol-name (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.12 (sort (mapcar #'symbol-name (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) #'string<) ("A" "B" "C")) (deftest loop.7.13 (sort (mapcar #'symbol-name (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) #'string<) ("A" "B" "C" "X" "Y" "Z")) (deftest loop.7.14 (sort (mapcar #'symbol-name (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) #'string<) ("X" "Y" "Z")) ;;; According to the ANSI CL spec, "If the package for the iteration is not supplied, ;;; the current package is used." Thse next tests are of the cases that the package ;;; is not supplied in the loop form. (deftest loop.7.15 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each symbol collect x)) #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.16 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each external-symbol collect x)) #'string<)) ("A" "B" "C")) (deftest loop.7.17 (let ((*package* (find-package "LOOP.CL-TEST.2"))) (sort (mapcar #'symbol-name (loop for x being each present-symbol collect x)) #'string<)) ("X" "Y" "Z")) ;;; Cases where the package doesn't exist. According to the standard, ;;; (section 6.1.2.1.7), this should cause a pacakge-error. (deftest loop.7.18 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.19 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.20 (progn (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) ;;; NIL d-var-specs (deftest loop.7.21 (loop for nil being the symbols of "LOOP.CL-TEST.1" count t) 6) (deftest loop.7.22 (loop for nil being the external-symbols of "LOOP.CL-TEST.1" count t) 3) (deftest loop.7.23 (loop for nil being the present-symbols of "LOOP.CL-TEST.2" count t) 3) ;;; Type specs (deftest loop.7.24 (loop for x t being the symbols of "LOOP.CL-TEST.1" count x) 6) (deftest loop.7.25 (loop for x t being the external-symbols of "LOOP.CL-TEST.1" count x) 3) (deftest loop.7.26 (loop for x t being the present-symbols of "LOOP.CL-TEST.2" count x) 3) (deftest loop.7.27 (loop for x of-type symbol being the symbols of "LOOP.CL-TEST.1" count x) 6) (deftest loop.7.28 (loop for x of-type symbol being the external-symbols of "LOOP.CL-TEST.1" count x) 3) (deftest loop.7.29 (loop for x of-type symbol being the present-symbols of "LOOP.CL-TEST.2" count x) 3) ;;; Tests of the 'as' form (deftest loop.7.30 (sort (mapcar #'symbol-name (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.31 (sort (mapcar #'symbol-name (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.32 (sort (mapcar #'symbol-name (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) gcl-2.6.14/ansi-tests/file-author.lsp0000644000175000017500000000374114360276512016031 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 05:41:06 2004 ;;;; Contains: Tests of FILE-AUTHOR (in-package :cl-test) (deftest file-author.1 (loop for pn in (directory (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) for author = (file-author pn) unless (or (null author) (stringp author)) collect (list pn author)) nil) (deftest file-author.2 (let ((author (file-author "file-author.lsp"))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.3 (let ((author (file-author #p"file-author.lsp"))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.4 (let ((author (file-author (truename "file-author.lsp")))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.5 (let ((author (with-open-file (s "file-author.lsp" :direction :input) (file-author s)))) (if (or (null author) (stringp author)) nil author)) nil) (deftest file-author.6 (let ((author (let ((s (open "file-author.lsp" :direction :input))) (close s) (file-author s)))) (if (or (null author) (stringp author)) nil author)) nil) ;;; Specialized string tests (deftest file-author.7 (do-special-strings (s "file-author.lsp" nil) (assert (equal (file-author s) (file-author "file-author.lsp")))) nil) ;;; FIXME ;;; Add LPN test ;;; Error tests (deftest file-author.error.1 (signals-error (file-author) program-error) t) (deftest file-author.error.2 (signals-error (file-author "file-author.lsp" nil) program-error) t) (deftest file-author.error.3 (signals-error-always (file-author (make-pathname :name :wild :type "lsp" :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-author.error.4 (signals-error-always (file-author (make-pathname :name "file-author" :type :wild :defaults *default-pathname-defaults*)) file-error) t t) gcl-2.6.14/ansi-tests/peek-char.lsp0000644000175000017500000001511214360276512015444 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 21:02:13 2004 ;;;; Contains: Tests of PEEK-CHAR (in-package :cl-test) (deftest peek-char.1 (with-input-from-string (*standard-input* "abc") (values (peek-char) (read-char) (read-char) (peek-char) (read-char))) #\a #\a #\b #\c #\c) (deftest peek-char.2 (with-input-from-string (*standard-input* " ab") (values (peek-char) (read-char) (peek-char t) (read-char) (peek-char t) (read-char))) #\Space #\Space #\a #\a #\b #\b) (deftest peek-char.3 (with-input-from-string (*standard-input* (concatenate 'string (string #\Newline) (string #\Newline) " " (string #\Newline) "ab")) (values (peek-char) (read-char) (peek-char t) (read-char) (peek-char t) (read-char))) #\Newline #\Newline #\a #\a #\b #\b) (when (name-char "Linefeed") (deftest peek-char.4 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Linefeed")) (string (name-char "Linefeed")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Linefeed") #.(name-char "Linefeed") #\a #\a)) (when (name-char "Page") (deftest peek-char.5 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Page")) (string (name-char "Page")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Page") #.(name-char "Page") #\a #\a)) (when (name-char "Tab") (deftest peek-char.6 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Tab")) (string (name-char "Tab")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Tab") #.(name-char "Tab") #\a #\a)) (when (name-char "Return") (deftest peek-char.7 (with-input-from-string (*standard-input* (concatenate 'string (string (name-char "Return")) (string (name-char "Return")) "abc")) (values (peek-char) (read-char) (peek-char t) (read-char))) #.(name-char "Return") #.(name-char "Return") #\a #\a)) (deftest peek-char.8 (with-input-from-string (s "a bcd") (values (peek-char nil s) (read-char s) (peek-char t s) (read-char s) (peek-char t s) (read-char s))) #\a #\a #\b #\b #\c #\c) (deftest peek-char.9 (with-input-from-string (*standard-input* " a bCcde") (values (peek-char #\c) (read-char) (read-char))) #\c #\c #\d) (deftest peek-char.10 (with-input-from-string (*standard-input* " ; foo") (values (peek-char t) (read-char))) #\; #\;) (deftest peek-char.11 (with-input-from-string (s "") (peek-char nil s nil)) nil) (deftest peek-char.12 (with-input-from-string (s "") (peek-char nil s nil 'foo)) foo) (deftest peek-char.13 (with-input-from-string (s " ") (peek-char t s nil)) nil) (deftest peek-char.14 (with-input-from-string (s " ") (peek-char t s nil 'foo)) foo) (deftest peek-char.15 (with-input-from-string (s "ab c d") (peek-char #\z s nil)) nil) (deftest peek-char.16 (with-input-from-string (s "ab c d") (peek-char #\z s nil 'foo)) foo) ;;; Interaction with echo streams (deftest peek-char.17 (block done (with-input-from-string (is "ab") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char nil es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) :good (list pos1 pos2))))))))) :good) (deftest peek-char.18 (block done (with-input-from-string (is " ab") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char t es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) pos1 :good)))))))) :good) (deftest peek-char.19 (block done (with-input-from-string (is "abcde") (with-output-to-string (os) (let ((es (make-echo-stream is os))) (let ((pos1 (file-position os))) (unless (zerop pos1) (return-from done :good)) (peek-char #\c es nil) (let ((pos2 (file-position os))) (return-from done (if (eql pos1 pos2) pos1 :good)))))))) :good) ;;; Interactions with the readtable (deftest peek-char.20 (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\Space #\a) (with-input-from-string (*standard-input* " x") (values (peek-char) (read-char) (peek-char t) (read-char)))) #\Space #\Space #\Space #\Space ; *not* #\x #\x ) (deftest peek-char.21 (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\x #\Space) (with-input-from-string (*standard-input* "xxa") (values (peek-char) (read-char) (peek-char t) (read-char)))) #\x #\x #\a #\a ; *not* #\x #\x ) ;;; Stream designators are accepted for the stream argument (deftest peek-char.22 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (peek-char nil t))) #\!) (deftest peek-char.23 (with-input-from-string (*standard-input* "345") (peek-char nil nil)) #\3) ;;; Error tests (deftest peek-char.error.1 (signals-error (with-input-from-string (s "abc") (peek-char s nil nil nil nil 'nonsense)) program-error) t) (deftest peek-char.error.2 (signals-error-always (with-input-from-string (*standard-input* "") (peek-char)) end-of-file) t t) (deftest peek-char.error.3 (signals-error-always (with-input-from-string (s "") (peek-char nil s)) end-of-file) t t) (deftest peek-char.error.4 (signals-error-always (with-input-from-string (s " ") (peek-char t s)) end-of-file) t t) (deftest peek-char.error.5 (signals-error-always (with-input-from-string (s "abcd") (peek-char #\z s)) end-of-file) t t) ;;; There was a consensus on comp.lang.lisp that the requirement ;;; that an end-of-file error be thrown in the following case ;;; is a spec bug #| (deftest peek-char.error.6 (signals-error (with-input-from-string (s "") (peek-char nil s nil nil t)) end-of-file) t) |# gcl-2.6.14/ansi-tests/structures-03.lsp0000644000175000017500000002345214360276512016256 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 20 05:58:06 2002 ;;;; Contains: BOA Constructor Tests (in-package :cl-test) (defun sbt-slots (sname s &rest slots) (loop for slotname in slots collect (let ((fun (intern (concatenate 'string (string sname) "-" (string slotname)) :cl-test))) (funcall (symbol-function fun) s)))) ;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) (defstruct* (sbt-01 (:constructor sbt-01-con (b a c))) a b c) (deftest structure-boa-test-01/1 (let ((s (sbt-01-con 1 2 3))) (values (sbt-01-a s) (sbt-01-b s) (sbt-01-c s))) 2 1 3) (defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) (:constructor sbt-02-con-2 (a b)) (:constructor sbt-02-con-3 ())) (a 'x) (b 'y) (c 'z)) (deftest structure-boa-test-02/1 (let ((s (sbt-02-con 1 2 3))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) 1 2 3) (deftest structure-boa-test-02/2 (let ((s (sbt-02-con-2 'p 'q))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) p q z) (deftest structure-boa-test-02/3 (let ((s (sbt-02-con-3))) (values (sbt-02-a s) (sbt-02-b s) (sbt-02-c s))) x y z) ;;; &optional in BOA LL (defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c))) c b a) (deftest structure-boa-test-03/1 (let ((s (sbt-03-con 1 2))) (values (sbt-03-a s) (sbt-03-b s))) 1 2) (deftest structure-boa-test-03/2 (let ((s (sbt-03-con 1 2 3))) (values (sbt-03-a s) (sbt-03-b s) (sbt-03-c s))) 1 2 3) (defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c))) (c nil) b (a nil)) (deftest structure-boa-test-04/1 (let ((s (sbt-04-con 1 2))) (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) 1 2 nil) (deftest structure-boa-test-04/2 (let ((s (sbt-04-con 1 2 4))) (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) 1 2 4) (defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c))) (c 1) (b 2) (a 3)) (deftest structure-boa-test-05/1 (let ((s (sbt-05-con))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) 3 2 1) (deftest structure-boa-test-05/2 (let ((s (sbt-05-con 'x))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x 2 1) (deftest structure-boa-test-05/3 (let ((s (sbt-05-con 'x 'y))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x y 1) (deftest structure-boa-test-05/4 (let ((s (sbt-05-con 'x 'y 'z))) (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) x y z) (defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) (c 1) (b 2) (a 3)) (deftest structure-boa-test-06/1 (let ((s (sbt-06-con))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) p q r) (deftest structure-boa-test-06/2 (let ((s (sbt-06-con 'x))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x q r) (deftest structure-boa-test-06/3 (let ((s (sbt-06-con 'x 'y))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x y r) (deftest structure-boa-test-06/4 (let ((s (sbt-06-con 'x 'y 'z))) (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) x y z) ;;; Test presence flag in optional parameters (defstruct* (sbt-07 (:constructor sbt-07-con (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) &aux (d (list (notnot a-p) (notnot b-p) (notnot c-p)))))) a b c d) (deftest structure-boa-test-07/1 (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d) (p q r (nil nil nil))) (deftest structure-boa-test-07/2 (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d) (x q r (t nil nil))) (deftest structure-boa-test-07/3 (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d) (x y r (t t nil))) (deftest structure-boa-test-07/4 (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d) (x y z (t t t))) ;;; Keyword arguments (defstruct* (sbt-08 (:constructor sbt-08-con (&key ((:foo a))))) a) (deftest structure-boa-test-08/1 (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) (10)) (defstruct* (sbt-09 (:constructor sbt-09-con (&key (a 'p a-p) ((:x b) 'q) (c 'r) d ((:y e)) ((:z f) 's z-p) &aux (g (list (notnot a-p) (notnot z-p)))))) a b c d e f g) (deftest structure-boa-test-09/1 (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) (p q r s (nil nil))) (deftest structure-boa-test-09/2 (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g) (p q r 1 s (nil nil))) (deftest structure-boa-test-09/3 (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g) (1 q r s (t nil))) (deftest structure-boa-test-09/4 (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g) (p 1 r s (nil nil))) (deftest structure-boa-test-09/5 (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g) (p q 1 s (nil nil))) (deftest structure-boa-test-09/6 (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g) (p q r 1 s (nil nil))) (deftest structure-boa-test-09/7 (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) (p q r 1 (nil t))) ;;; Aux variable overriding a default value (defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) (b (1+ a))))) (a 1) (b 2)) (deftest structure-boa-test-10/1 (sbt-slots 'sbt-10 (sbt-10-con) :a :b) (10 11)) ;;; Aux variables with no value (defstruct* (sbt-11 (:constructor sbt-11-con (&aux a b))) a (b 0 :type integer)) (deftest structure-boa-test-11/1 (let ((s (sbt-11-con))) (setf (sbt-11-a s) 'p) (setf (sbt-11-b s) 10) (sbt-slots 'sbt-11 s :a :b)) (p 10)) ;;; Arguments that correspond to no slots (defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) &rest c &aux (d (list a b c))))) d) (deftest structure-boa-12/1 (sbt-12-d (sbt-12-con 'x)) (x 1 nil)) (deftest structure-boa-12/2 (sbt-12-d (sbt-12-con 'x 'y)) (x y nil)) (deftest structure-boa-12/3 (sbt-12-d (sbt-12-con 'x 'y 1 2 3)) (x y (1 2 3))) (defstruct* (sbt-13 (:constructor sbt-13-con (&key (a 1) (b 2) c &aux (d (list a b c))))) d) (deftest structure-boa-test-13/1 (sbt-13-d (sbt-13-con)) (1 2 nil)) (deftest structure-boa-test-13/2 (sbt-13-d (sbt-13-con :a 10)) (10 2 nil)) (deftest structure-boa-test-13/3 (sbt-13-d (sbt-13-con :b 10)) (1 10 nil)) (deftest structure-boa-test-13/4 (sbt-13-d (sbt-13-con :c 10)) (1 2 10)) (deftest structure-boa-test-13/5 (sbt-13-d (sbt-13-con :c 10 :a 3)) (3 2 10)) (deftest structure-boa-test-13/6 (sbt-13-d (sbt-13-con :c 10 :b 3)) (1 3 10)) (deftest structure-boa-test-13/7 (sbt-13-d (sbt-13-con :a 10 :b 3)) (10 3 nil)) (deftest structure-boa-test-13/8 (sbt-13-d (sbt-13-con :a 10 :c 'a :b 3)) (10 3 a)) ;;; Allow other keywords (defstruct* (sbt-14 (:constructor sbt-14-con (&key a b c &allow-other-keys))) (a 1) (b 2) (c 3)) (deftest structure-boa-test-14/1 (sbt-slots 'sbt-14 (sbt-14-con) :a :b :c) (1 2 3)) (deftest structure-boa-test-14/2 (sbt-slots 'sbt-14 (sbt-14-con :a 9) :a :b :c) (9 2 3)) (deftest structure-boa-test-14/3 (sbt-slots 'sbt-14 (sbt-14-con :b 9) :a :b :c) (1 9 3)) (deftest structure-boa-test-14/4 (sbt-slots 'sbt-14 (sbt-14-con :c 9) :a :b :c) (1 2 9)) (deftest structure-boa-test-14/5 (sbt-slots 'sbt-14 (sbt-14-con :d 9) :a :b :c) (1 2 3)) ;;; Keywords are in the correct package, and slot names are not ;;; keyword parameters if not specified. (defstruct* (sbt-15 (:constructor sbt-15-con (&key ((:x a) nil) ((y b) nil) (c nil)))) a b c) (deftest structure-boa-test-15/1 (sbt-slots 'sbt-15 (sbt-15-con :x 1 'y 2 :c 3) :a :b :c) (1 2 3)) (deftest structure-boa-test-15/2 (classify-error (sbt-15-con :a 1)) program-error) (deftest structure-boa-test-15/3 (classify-error (sbt-15-con :b 1)) program-error) (deftest structure-boa-test-15/4 (classify-error (sbt-15-con 'x 1)) program-error) (deftest structure-boa-test-15/5 (classify-error (sbt-15-con :y 1)) program-error) (deftest structure-boa-test-15/6 (classify-error (sbt-15-con 'c 1)) program-error) (deftest structure-boa-test-15/7 (classify-error (sbt-15-con 'a 1)) program-error) (deftest structure-boa-test-15/8 (classify-error (sbt-15-con 'b 1)) program-error) ;;; Default constructor w. BOA constructor, and error cases (defstruct* (sbt-16 (:constructor) (:constructor sbt-16-con (a b c))) a b c) (deftest structure-boa-test-16/1 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3) :a :b :c) (1 2 3)) (deftest structure-boa-test-16/2 (sbt-slots 'sbt-16 (sbt-16-con 4 5 6) :a :b :c) (4 5 6)) (deftest structure-boa-test-16/3 (classify-error (make-sbt-16 :d 1)) program-error) (deftest structure-boa-test-16/4 (classify-error (make-sbt-16 :a)) program-error) (deftest structure-boa-test-16/5 (classify-error (make-sbt-16 'a)) program-error) (deftest structure-boa-test-16/6 (classify-error (make-sbt-16 1 1)) program-error) (deftest structure-boa-test-16/7 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t) :a :b :c) (1 2 3)) (deftest structure-boa-test-16/8 (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5) :a :b :c) (1 2 3)) ;;; :allow-other-keys turns off keyword error checking, including ;;; invalid (nonsymbol) keyword arguments ;;;(deftest structure-boa-test-16/9 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t ;;; :a 3 :b 6 :c 9 1000 1000) ;;; :a :b :c) ;;; (3 6 9)) ;;; Repeated keyword arguments are allowed; the leftmost one is used (deftest structure-boa-test-16/10 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :a 2 :b 3 :b 4 :c 5 :c 6) :a :b :c) (1 3 5)) (deftest structure-boa-test-16/11 (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :allow-other-keys nil :a 1 :b 2 :c 3 :d 5) :a :b :c) (1 2 3)) ;; Checking of # of keywords is suppressed when :allow-other-keys is true ;;;(deftest structure-boa-test-16/12 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a) ;;; :a :b :c) ;;; (3 6 9)) gcl-2.6.14/ansi-tests/subtypep-array.lsp0000644000175000017500000000516514360276512016603 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 1 16:23:57 2003 ;;;; Contains: Tests of SUBTYPEP on array types (in-package :cl-test) ;;; *array-element-types* is defined in ansi-aux.lsp (deftest subtypep.array.1 (let ((array-types (cons (find-class 'array) '(array (array) (array *) (array * *))))) (loop for tp1 in array-types append (loop for tp2 in array-types unless (subtypep tp1 tp2) collect (list tp1 tp2)))) nil) (deftest subtypep.array.2 (and (subtypep* '(array t) '(array t *)) (subtypep* '(array t *) '(array t)) t) t) (deftest subtypep.array.3 (loop for i from 0 below (min 16 array-rank-limit) for type = `(array * ,i) for type2 = `(array * ,(make-list i :initial-element '*)) unless (and (subtypep type 'array) (subtypep type '(array)) (subtypep type '(array *)) (subtypep type '(array * *)) (subtypep type type2)) collect type) nil) (deftest subtypep.array.4 (loop for i from 0 below (min 16 array-rank-limit) for type = `(array t ,i) for type2 = `(array t ,(make-list i :initial-element '*)) unless (and (subtypep type '(array t)) (subtypep type '(array t *)) (subtypep type type2)) collect type) nil) (deftest subtypep.array.5 (loop for element-type in (cons '* *array-element-types*) nconc (loop for i from 0 below (min 16 array-rank-limit) for type = `(array ,element-type ,i) for type2 = `(array ,element-type ,(make-list i :initial-element '0)) for type3 = `(array ,element-type ,(make-list i :initial-element '1)) unless (and (subtypep type2 type) (subtypep type3 type) (loop for j from 0 to i always (and (subtypep `(array ,element-type (,@(make-list j :initial-element '*) ,@(make-list (- i j) :initial-element 2))) type) (subtypep `(array ,element-type (,@(make-list j :initial-element 2) ,@(make-list (- i j) :initial-element '*))) type)))) collect type)) nil) (deftest subtypep.aray.6 (loop for etype in (cons '* *array-element-types*) append (check-equivalence `(and (array ,etype (* 10 * * *)) (array ,etype (* * * 29 *))) `(array ,etype (* 10 * 29 *)))) nil) (deftest subtypep.aray.7 (let ((etypes *array-element-types*)) (loop for etp1 in etypes for uaetp1 = (upgraded-array-element-type etp1) append (loop for etp2 in etypes for uaetp2 = (upgraded-array-element-type etp2) when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) '(nil t)) append (check-disjointness `(array ,etp1) `(array ,etp2))))) nil) gcl-2.6.14/ansi-tests/lambda.lsp0000644000175000017500000000177614360276512015040 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Nov 27 06:43:21 2002 ;;;; Contains: Tests of LAMBDA forms (in-package :cl-test) (deftest lambda.1 ((lambda (x) x) 'a) a) (deftest lambda.2 ((lambda () 'a)) a) (deftest lambda.3 ((lambda () "documentation" 'a)) a) (deftest lambda.4 ((lambda (x) (declare (type symbol x)) x) 'z) z) (deftest lambda.5 ((lambda (&aux (x 'a)) x)) a) (deftest lambda.6 ((lambda (&aux (x 'a)) (declare (type symbol x)) x)) a) (deftest lambda.7 ((lambda () "foo")) "foo") (deftest lambda.8 ((lambda () "foo" "bar")) "bar") (deftest lambda.9 ((lambda (x y) (declare (ignore x)) "foo" (declare (ignore y)) "bar") 1 2) "bar") (deftest lambda.10 ((lambda (x) (declare (type symbol x))) 'z) nil) ;;; Should test lambda argument lists more fully here ;;; Tests of lambda as a macro (deftest lambda.macro.1 (notnot (macro-function 'lambda)) t) (deftest lambda.macro.2 (funcall (eval (macroexpand '(lambda () 10)))) 10) gcl-2.6.14/ansi-tests/.cvsignore0000644000175000017500000000004114360276512015060 0ustar cammcamm*.fn *.x86f *.fasl *.ufsl binary gcl-2.6.14/ansi-tests/loop10.lsp0000644000175000017500000002160714360276512014725 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 16 09:07:02 2002 ;;;; Contains: Tests of LOOP numeric value accumulation clauses (in-package :cl-test) ;; Tests of COUNT, COUNTING (deftest loop.10.1 (loop for x from 1 to 10 count (< x 5)) 4) (deftest loop.10.2 (loop for x from 1 to 10 counting (< x 7)) 6) (deftest loop.10.3 (loop for x from 1 to 10 count (< x 5) fixnum) 4) (deftest loop.10.4 (loop for x from 1 to 10 count (< x 5) of-type integer) 4) (deftest loop.10.5 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo finally (setq z foo)) z)) nil 4) (deftest loop.10.6 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo fixnum finally (setq z foo)) z)) nil 4) (deftest loop.10.7 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo of-type (integer 0 100) finally (setq z foo)) z)) nil 4) (deftest loop.10.8 (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo float finally (setq z foo)) z)) nil 4.0) (deftest loop.10.9 (classify-error (loop with foo = 10 for x in '(a b c) count x into foo finally (return foo))) program-error) (deftest loop.10.10 (classify-error (loop with foo = 10 for x in '(a b c) counting x into foo finally (return foo))) program-error) (declaim (special *loop-count-var*)) (deftest loop.10.11 (let ((*loop-count-var* 100)) (values (loop for x in '(a b c d) count x into *loop-count-var* finally (return *loop-count-var*)) *loop-count-var*)) 4 100) (deftest loop.10.12 (loop for x in '(a b nil d nil e) count x into foo collect foo) (1 2 2 3 3 4)) (deftest loop.10.13 (loop for x in '(a b nil d nil e) counting x into foo collect foo) (1 2 2 3 3 4)) (deftest loop.10.14 (loop for x in '(a b c) count (return 10)) 10) ;;; Tests of MAXIMIZE, MAXIMIZING (deftest loop.10.20 (loop for x in '(1 4 10 5 7 9) maximize x) 10) (deftest loop.10.21 (loop for x in '(1 4 10 5 7 9) maximizing x) 10) (deftest loop.10.22 (loop for x in '(1000000000000) maximizing x) 1000000000000) (deftest loop.10.23 (loop for x in '(-1000000000000) maximize x) -1000000000000) (deftest loop.10.24 (loop for x in '(1.0 2.0 3.0 -1.0) maximize x) 3.0) (deftest loop.10.25 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x fixnum) 24) (deftest loop.10.26 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type integer) 24) (deftest loop.10.27 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type rational) 24) (deftest loop.10.28 (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (return foo)) 10) (deftest loop.10.29 (let (z) (values (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (setq z foo)) z)) nil 10) (deftest loop.10.30 (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type real) 24) (deftest loop.10.31 (loop for x in '(0.08 0.20 0.05 0.03 0.24 0.01 0.19 0.04 0.20 0.03) maximize x of-type float) 0.24) (deftest loop.10.32 (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) maximize x of-type rational) -1/24) (deftest loop.10.33 (loop for x in '(1 4 10 5 7 9) maximize x into foo fixnum finally (return foo)) 10) (deftest loop.10.34 (loop for x in '(1 4 10 5 7 9) maximize x into foo of-type integer finally (return foo)) 10) (deftest loop.10.35 (let ((foo 20)) (values (loop for x in '(3 5 8 3 7) maximize x into foo finally (return foo)) foo)) 8 20) (declaim (special *loop-max-var*)) (deftest loop.10.36 (let ((*loop-max-var* 100)) (values (loop for x in '(1 10 4 8) maximize x into *loop-max-var* finally (return *loop-max-var*)) *loop-max-var*)) 10 100) (deftest loop.10.37 (classify-error (loop with foo = 100 for i from 1 to 10 maximize i into foo finally (return foo))) program-error) (deftest loop.10.38 (classify-error (loop with foo = 100 for i from 1 to 10 maximizing i into foo finally (return foo))) program-error) (deftest loop.10.39 (loop for x in '(1 2 3) maximize (return 10)) 10) ;;; Tests of MINIMIZE, MINIMIZING (deftest loop.10.40 (loop for x in '(4 10 1 5 7 9) minimize x) 1) (deftest loop.10.41 (loop for x in '(4 10 5 7 1 9) minimizing x) 1) (deftest loop.10.42 (loop for x in '(1000000000000) minimizing x) 1000000000000) (deftest loop.10.43 (loop for x in '(-1000000000000) minimize x) -1000000000000) (deftest loop.10.44 (loop for x in '(1.0 2.0 -1.0 3.0) minimize x) -1.0) (deftest loop.10.45 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x fixnum) 1) (deftest loop.10.46 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type integer) 1) (deftest loop.10.47 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type rational) 1) (deftest loop.10.48 (loop for x in '(1 4 10 5 7 9) minimize x into foo finally (return foo)) 1) (deftest loop.10.49 (let (z) (values (loop for x in '(4 1 10 1 5 7 9) minimize x into foo finally (setq z foo)) z)) nil 1) (deftest loop.10.50 (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type real) 1) (deftest loop.10.51 (loop for x in '(0.08 0.40 0.05 0.03 0.44 0.01 0.19 0.04 0.40 0.03) minimize x of-type float) 0.01) (deftest loop.10.52 (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) minimize x of-type rational) -1/1) (deftest loop.10.53 (loop for x in '(4 10 5 1 7 9) minimize x into foo fixnum finally (return foo)) 1) (deftest loop.10.54 (loop for x in '(1 4 10 5 7 9) minimize x into foo of-type integer finally (return foo)) 1) (deftest loop.10.55 (let ((foo 20)) (values (loop for x in '(4 5 8 3 7) minimize x into foo finally (return foo)) foo)) 3 20) (declaim (special *loop-min-var*)) (deftest loop.10.56 (let ((*loop-min-var* 100)) (values (loop for x in '(10 4 8) minimize x into *loop-min-var* finally (return *loop-min-var*)) *loop-min-var*)) 4 100) (deftest loop.10.57 (classify-error (loop with foo = 100 for i from 1 to 10 minimize i into foo finally (return foo))) program-error) (deftest loop.10.58 (classify-error (loop with foo = 100 for i from 1 to 10 minimizing i into foo finally (return foo))) program-error) (deftest loop.10.58a (loop for x in '(1 2 3) minimize (return 10)) 10) ;;; Tests combining MINIMIZE, MAXIMIZE (deftest loop.10.59 (loop for i from 1 to 10 minimize i maximize (- i)) 1) (deftest loop.10.60 (loop for i from 1 to 10 maximize (- i) minimize i) -1) (deftest loop.10.61 (loop for i from 5 downto 1 maximize i minimize (- i)) -1) ;;; Tests for SUM, SUMMING (deftest loop.10.70 (loop for i from 1 to 4 sum i) 10) (deftest loop.10.71 (loop for i from 1 to 4 summing i) 10) (deftest loop.10.72 (loop for i from 1 to 4 sum (float i)) 10.0) (deftest loop.10.73 (loop for i from 1 to 4 sum (complex i i)) #c(10 10)) (deftest loop.10.74 (loop for i from 1 to 4 sum i fixnum) 10) (deftest loop.10.75 (loop for i from 1 to 4 sum i of-type integer) 10) (deftest loop.10.76 (loop for i from 1 to 4 sum i of-type rational) 10) (deftest loop.10.77 (loop for i from 1 to 4 sum (float i) float) 10.0) (deftest loop.10.78 (loop for i from 1 to 4 sum i of-type number) 10) (deftest loop.10.79 (loop for i from 1 to 4 sum i into foo finally (return foo)) 10) (deftest loop.10.80 (loop for i from 1 to 4 sum i into foo fixnum finally (return foo)) 10) (deftest loop.10.81 (let (z) (values (loop for i from 1 to 4 sum i into foo of-type (integer 0 10) finally (setq z foo)) z)) nil 10) (deftest loop.10.82 (loop for i from 1 to 4 sum i fixnum count t) 14) (deftest loop.10.83 (loop for i from 1 to 4 sum i fixnum count t fixnum) 14) (deftest loop.10.84 (let ((foo 100)) (values (loop for i from 1 to 4 sum i into foo of-type integer finally (return foo)) foo)) 10 100) (deftest loop.10.85 (classify-error (loop with foo = 100 for i from 1 to 4 sum i into foo finally (return foo))) program-error) (deftest loop.10.86 (classify-error (loop with foo = 100 for i from 1 to 4 summing i into foo finally (return foo))) program-error) (deftest loop.10.87 (loop for i from 1 to 4 sum (complex i (1+ i)) of-type complex) #c(10 14)) (deftest loop.10.88 (loop for i from 1 to 4 sum (/ i 17) of-type rational) 10/17) (deftest loop.10.89 (loop for i from 1 to 4 summing (/ i 17)) 10/17) (deftest loop.10.90 (loop for i from 1 to 4 sum i into foo sum (1+ i) into bar finally (return (values foo bar))) 10 14) (deftest loop.10.91 (loop for i from 1 to 4 sum i into foo fixnum sum (float (1+ i)) into bar float finally (return (values foo bar))) 10 14.0) (deftest loop.10.92 (loop for i from 1 to 4 sum (return 100)) 100) (deftest loop.10.93 (loop for i from 1 to 4 summing (return 100)) 100) gcl-2.6.14/ansi-tests/cl-symbols-aux.lsp0000644000175000017500000000251414360276512016466 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 28 06:43:51 2002 ;;;; Contains: Aux. functions for cl-symbols.lsp (in-package :cl-test) (declaim (optimize (safety 3))) (defun is-external-symbol-of (sym package) (multiple-value-bind (sym2 status) (find-symbol (symbol-name sym) package) (and (eqt sym sym2) (eqt status :external)))) (defun test-if-not-in-cl-package (str) (multiple-value-bind (sym status) (find-symbol #+lower-case str #-lower-case (string-upcase str) 'common-lisp) (or ;; Symbol not present in the common lisp package (not status) ;; Check if it has any properties whose indicators are ;; external in any of the standard packages or are accessible ;; in CL-USER (and (eqt status :external) (let ((plist (symbol-plist sym))) (loop for e = plist then (cddr e) while e for indicator = (car e) when (and (symbolp indicator) (or (is-external-symbol-of indicator "COMMON-LISP") (is-external-symbol-of indicator "KEYWORD") (eqt indicator (find-symbol (symbol-name indicator) "COMMON-LISP-USER")))) collect indicator)))))) (defun safe-symbol-name (sym) (catch-type-error (symbol-name sym))) (defun safe-make-symbol (name) (catch-type-error (make-symbol name))) gcl-2.6.14/ansi-tests/sort.lsp0000644000175000017500000000601314360276512014574 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 21 00:11:24 2002 ;;;; Contains: Tests for SORT (in-package :cl-test) (deftest sort-list.1 (let ((a (list 1 4 2 5 3))) (sort a #'<)) (1 2 3 4 5)) (deftest sort-list.2 (let ((a (list 1 4 2 5 3))) (sort a #'< :key #'-)) (5 4 3 2 1)) (deftest sort-list.3 (let ((a (list 1 4 2 5 3))) (sort a #'(lambda (x y) nil)) (sort a #'<)) (1 2 3 4 5)) (deftest sort-vector.1 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'<)) #(1 2 3 4 5)) (deftest sort-vector.2 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'< :key #'-)) #(5 4 3 2 1)) (deftest sort-vector.3 (let ((a (copy-seq #(1 4 2 5 3)))) (sort a #'(lambda (x y) nil)) (sort a #'<)) #(1 2 3 4 5)) (deftest sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) :fill-pointer 5))) (sort a #'<)) #(10 20 30 40 50)) (deftest sort-bit-vector.1 (let ((a (copy-seq #*10011101))) (sort a #'<)) #*00011111) (deftest sort-bit-vector.2 (let ((a (copy-seq #*10011101))) (values (sort a #'< :key #'-) a)) #*11111000 #*11111000) (deftest sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) :element-type 'bit :fill-pointer 5))) (sort a #'<)) #*00111) (deftest sort-string.1 (let ((a (copy-seq "10011101"))) (values (sort a #'char<) a)) "00011111" "00011111") (deftest sort-string.2 (let ((a (copy-seq "10011101"))) (values (sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) "11111000" "11111000") (deftest sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" :element-type 'character :fill-pointer 5))) (sort a #'char<)) "00111") ;;; Order of evaluation tests (deftest sort.order.1 (let ((i 0) x y) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) (deftest sort.order.2 (let ((i 0) x y z) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<) :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) ;;; Error cases (deftest sort.error.1 (classify-error (sort)) program-error) (deftest sort.error.2 (classify-error (sort nil)) program-error) (deftest sort.error.3 (classify-error (sort nil #'< :key)) program-error) (deftest sort.error.4 (classify-error (sort nil #'< 'bad t)) program-error) (deftest sort.error.5 (classify-error (sort nil #'< 'bad t :allow-other-keys nil)) program-error) (deftest sort.error.6 (classify-error (sort nil #'< 1 2)) program-error) (deftest sort.error.7 (classify-error (sort (list 1 2 3 4) #'identity)) program-error) (deftest sort.error.8 (classify-error (sort (list 1 2 3 4) #'< :key #'cons)) program-error) (deftest sort.error.9 (classify-error (sort (list 1 2 3 4) #'< :key #'car)) type-error) (deftest sort.error.10 (classify-error (sort (list 1 2 3 4) #'elt)) type-error) gcl-2.6.14/ansi-tests/bit.lsp0000644000175000017500000000555614360276512014376 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:22:59 2003 ;;;; Contains: Tests for accessor BIT (in-package :cl-test) (deftest bit.1 (bit #*0010 2) 1) (deftest bit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (bit b i) 1) b))) (#*10000000 #*01000000 #*00100000 #*00010000 #*00001000 #*00000100 #*00000010 #*00000001)) (deftest bit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) collect (let ((b (copy-seq a))) (setf (bit b i) 0) b))) (#*01111111 #*10111111 #*11011111 #*11101111 #*11110111 #*11111011 #*11111101 #*11111110)) (deftest bit.4 (let ((a (make-array nil :element-type 'bit :initial-element 0))) (values (aref a) (bit a) (setf (bit a) 1) (aref a) (bit a))) 0 0 1 1 1) (deftest bit.5 (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) (values (aref a 0 0) (bit a 0 0) (setf (bit a 0 0) 1) (aref a 0 0) (bit a 0 0))) 0 0 1 1 1) (deftest bit.6 (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) (values (aref a 5 5) (bit a 5 5) (setf (bit a 5 5) 1) (aref a 5 5) (bit a 5 5))) 0 0 1 1 1) ;;; Check that the fill pointer is ignored (deftest bit.7 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) :element-type 'bit :fill-pointer 5))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (fill-pointer a))) (0 1 1 0 0) (0 1 1 0 0 1 1 1 0 0) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1) (1 0 0 1 1 0 0 0 1 1) 5) ;;; Check that adjustability is not relevant (deftest bit.8 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) :element-type 'bit :adjustable t))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)))) (0 1 1 0 0 1 1 1 0 0) (0 1 1 0 0 1 1 1 0 0) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1 0 0 0 1 1) (1 0 0 1 1 0 0 0 1 1)) ;;; Order of evaluation tests (deftest bit.order.1 (let ((x 0) y z (b (copy-seq #*01010))) (values (bit (progn (setf y (incf x)) b) (progn (setf z (incf x)) 1)) x y z)) 1 2 1 2) (deftest bit.order.2 (let ((x 0) y z w (b (copy-seq #*01010))) (values (setf (bit (progn (setf y (incf x)) b) (progn (setf z (incf x)) 1)) (progn (setf w (incf x)) 0)) b x y z w)) 0 #*00010 3 1 2 3) (deftest bit.error.1 (classify-error (bit)) program-error) gcl-2.6.14/ansi-tests/position-if-not.lsp0000644000175000017500000003252314360276512016650 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:10:05 2002 ;;;; Contains: Tests for POSITION-IF-NOT-NOT (in-package :cl-test) (deftest position-if-not-list.1 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-list.2 (position-if-not 'oddp '(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-list.3 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-not-list.4 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-not-list.5 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-not-list.6 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-not-list.7 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-not-list.8 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-not-list.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-list.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) ;;; Vector tests (deftest position-if-not-vector.1 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-vector.2 (position-if-not 'oddp #(1 3 1 4 3 2 1 8 9)) 3) (deftest position-if-not-vector.3 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4) 5) (deftest position-if-not-vector.4 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end t) 7) (deftest position-if-not-vector.5 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end nil) 3) (deftest position-if-not-vector.6 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 :from-end t) 7) (deftest position-if-not-vector.7 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end nil) 3) (deftest position-if-not-vector.8 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end 3) nil) (deftest position-if-not-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-vector.13 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 a b c d e) :fill-pointer 5))) (values (position-if-not #'numberp a) (position-if-not #'symbolp a) (position-if-not #'numberp a :from-end t) (position-if-not #'symbolp a :from-end t))) nil 0 nil 4) ;;; Bit vector tests (deftest position-if-not-bit-vector.1 (position-if-not #'oddp #*111010101) 3) (deftest position-if-not-bit-vector.2 (position-if-not 'oddp #*111010101) 3) (deftest position-if-not-bit-vector.3 (position-if-not #'oddp #*111010101 :start 4) 5) (deftest position-if-not-bit-vector.4 (position-if-not #'oddp #*111010101 :from-end t) 7) (deftest position-if-not-bit-vector.5 (position-if-not #'oddp #*111010101 :from-end nil) 3) (deftest position-if-not-bit-vector.6 (position-if-not #'oddp #*111010101 :start 4 :from-end t) 7) (deftest position-if-not-bit-vector.7 (position-if-not #'oddp #*111010101 :end nil) 3) (deftest position-if-not-bit-vector.8 (position-if-not #'oddp #*111010101 :end 3) nil) (deftest position-if-not-bit-vector.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'oddp #*111010101 :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #*111010101 :start i :end j :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evenp #*111010101 :start i :end j :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :fill-pointer 5 :element-type 'bit))) (values (position-if-not #'zerop a) (position-if-not (complement #'zerop) a) (position-if-not #'zerop a :from-end t) (position-if-not (complement #'zerop) a :from-end t))) 0 nil 4 nil) ;;; string tests (deftest position-if-not-string.1 (position-if-not #'odddigitp "131432189") 3) (deftest position-if-not-string.2 (position-if-not 'odddigitp "131432189") 3) (deftest position-if-not-string.3 (position-if-not #'odddigitp "131432189" :start 4) 5) (deftest position-if-not-string.4 (position-if-not #'odddigitp "131432189" :from-end t) 7) (deftest position-if-not-string.5 (position-if-not #'odddigitp "131432189" :from-end nil) 3) (deftest position-if-not-string.6 (position-if-not #'odddigitp "131432189" :start 4 :from-end t) 7) (deftest position-if-not-string.7 (position-if-not #'odddigitp "131432189" :end nil) 3) (deftest position-if-not-string.8 (position-if-not #'odddigitp "131432189" :end 3) nil) (deftest position-if-not-string.9 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'odddigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.10 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'odddigitp "131432189" :start i :end j :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.11 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evendigitp "131432183" :start i :end j :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) (3 3 3 3 3 3) (nil 5 5 5 5) (5 5 5 5) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.12 (loop for i from 0 to 8 collect (loop for j from (1+ i) to 9 collect (position-if-not #'evendigitp "131432183" :start i :end j :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) (3 3 5 5 7 7) (nil 5 5 7 7) (5 5 7 7) (nil 7 7) (7 7) (nil))) (deftest position-if-not-string.13 (let ((a (make-array '(10) :initial-contents "55555aaaaa" :fill-pointer 5 :element-type 'character))) (and (stringp a) (values (position-if-not #'digit-char-p a) (position-if-not (complement #'digit-char-p) a) (position-if-not #'digit-char-p a :from-end t) (position-if-not (complement #'digit-char-p) a :from-end t)))) nil 0 nil 4) (deftest position-if-not.order.1 (let ((i 0) a b c d e f) (values (position-if-not (progn (setf a (incf i)) (complement #'zerop)) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-)) i a b c d e f)) 4 6 1 2 3 4 5 6) (deftest position-if-not.order.2 (let ((i 0) a b c d e f) (values (position-if-not (progn (setf a (incf i)) (complement #'zerop)) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :key (progn (setf c (incf i)) #'1-) :end (progn (setf d (incf i)) 6) :start (progn (setf e (incf i)) 1) :from-end (setf f (incf i))) i a b c d e f)) 4 6 1 2 3 4 5 6) ;;; Keyword tests (deftest position-if-not.allow-other-keys.1 (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys t) 2) (deftest position-if-not.allow-other-keys.2 (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.3 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t) 2) (deftest position-if-not.allow-other-keys.4 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t) 2) (deftest position-if-not.allow-other-keys.5 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :key #'1-) 0) (deftest position-if-not.keywords.6 (position-if-not #'zerop '(0 0 1 2 3 0) :key #'1- :key #'identity) 0) (deftest position-if-not.allow-other-keys.7 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.8 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.9 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position-if-not.error.1 (classify-error (position-if-not #'identity 'b)) type-error) (deftest position-if-not.error.2 (classify-error (position-if-not #'identity 10)) type-error) (deftest position-if-not.error.3 (classify-error (position-if-not 'null 1.4)) type-error) (deftest position-if-not.error.4 (classify-error (position-if-not 'identity '(a b c . d))) type-error) (deftest position-if-not.error.5 (classify-error (position-if-not)) program-error) (deftest position-if-not.error.6 (classify-error (position-if-not #'null)) program-error) (deftest position-if-not.error.7 (classify-error (position-if-not #'null nil :key)) program-error) (deftest position-if-not.error.8 (classify-error (position-if-not #'null nil 'bad t)) program-error) (deftest position-if-not.error.9 (classify-error (position-if-not #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest position-if-not.error.10 (classify-error (position-if-not #'null nil 1 2)) program-error) (deftest position-if-not.error.11 (classify-error (locally (position-if-not #'identity 'b) t)) type-error) (deftest position-if-not.error.12 (classify-error (position-if-not #'cons '(a b c d))) program-error) (deftest position-if-not.error.13 (classify-error (position-if-not #'car '(a b c d))) type-error) (deftest position-if-not.error.14 (classify-error (position-if-not #'identity '(a b c d) :key #'cdr)) type-error) (deftest position-if-not.error.15 (classify-error (position-if-not #'identity '(a b c d) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/subtypep-cons.lsp0000644000175000017500000001205714360276512016425 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:57:03 2003 ;;;; Contains: Tests for subtype relationships on cons types (in-package :cl-test) ;;; SUBTYPEP on CONS types (defvar *cons-types* '(cons (cons) (cons *) (cons * *) (cons t) (cons t t) (cons t *) (cons * t))) (deftest subtypep.cons.1 (loop for t1 in *cons-types* append (loop for t2 in *cons-types* unless (equal (mapcar #'notnot (multiple-value-list (subtypep t1 t2))) '(t t)) collect (list t1 t2))) nil) (deftest subtypep.cons.2 (loop for t1 in '((cons nil) (cons nil *) (cons nil t) (cons * nil) (cons t nil) (cons nil nil)) unless (subtypep t1 nil) collect t1) nil) (deftest subtypep.cons.3 (check-equivalence '(and (cons symbol *) (cons * symbol)) '(cons symbol symbol)) nil) (deftest subtypep.cons.4 (check-equivalence '(and (cons (integer 0 10) *) (cons (integer 5 15) (integer 10 20)) (cons * (integer 15 25))) '(cons (integer 5 10) (integer 15 20))) nil) (deftest subtypep.cons.5 (check-equivalence '(and cons (not (cons symbol symbol))) '(or (cons (not symbol) *) (cons * (not symbol)))) nil) (deftest subtypep.cons.6 (check-equivalence '(or (cons integer symbol) (cons integer integer) (cons symbol integer) (cons symbol symbol)) '(cons (or integer symbol) (or integer symbol))) nil) (deftest subtypep.cons.7 (check-equivalence '(or (cons (integer 0 8) (integer 5 15)) (cons (integer 0 7) (integer 0 6)) (cons (integer 6 15) (integer 0 9)) (cons (integer 3 15) (integer 4 15))) '(cons (integer 0 15) (integer 0 15))) nil) (deftest subtypep.cons.8 (check-equivalence '(or (cons integer (cons symbol integer)) (cons symbol (cons integer symbol)) (cons symbol (cons symbol integer)) (cons symbol (cons integer integer)) (cons integer (cons integer symbol)) (cons symbol (cons symbol symbol)) (cons integer (cons integer integer)) (cons integer (cons symbol symbol))) '(cons (or symbol integer) (cons (or symbol integer) (or symbol integer)))) nil) (deftest subtypep.cons.9 (check-equivalence '(or (cons (integer 0 (3)) (integer 0 (6))) (cons (integer 3 (9)) (integer 0 (3))) (cons (integer 0 (6)) (integer 6 (9))) (cons (integer 6 (9)) (integer 3 (9))) (cons (integer 3 (6)) (integer 3 (6)))) '(cons (integer 0 (9)) (integer 0 (9)))) nil) (deftest subtypep.cons.10 (check-equivalence '(or (cons (rational 0 (3)) (rational 0 (6))) (cons (rational 3 (9)) (rational 0 (3))) (cons (rational 0 (6)) (rational 6 (9))) (cons (rational 6 (9)) (rational 3 (9))) (cons (rational 3 (6)) (rational 3 (6)))) '(cons (rational 0 (9)) (rational 0 (9)))) nil) (deftest subtypep.cons.11 (check-equivalence '(or (cons (real 0 (3)) (real 0 (6))) (cons (real 3 (9)) (real 0 (3))) (cons (real 0 (6)) (real 6 (9))) (cons (real 6 (9)) (real 3 (9))) (cons (real 3 (6)) (real 3 (6)))) '(cons (real 0 (9)) (real 0 (9)))) nil) ;;; Test suggested by C.R. (deftest subtypep.cons.12 (check-all-not-subtypep '(cons (or integer symbol) (or integer symbol)) '(or (cons integer symbol) (cons symbol integer))) nil) (deftest subtypep.cons.13 (check-all-not-subtypep '(not list) 'cons) nil) ;;; a -> b, a ==> b (deftest subtypep.cons.14 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) (cons symbol)) '(cons * integer)) nil) ;;; a -> b, not b ==> not a (deftest subtypep.cons.15 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) (cons * (not integer))) '(cons (not symbol))) nil) ;;; (and (or a b) (or (not b) c)) ==> (or a c) (deftest subtypep.cons.16 (check-all-subtypep '(and (or (cons symbol (cons * *)) (cons * (cons integer *))) (or (cons * (cons (not integer) *)) (cons * (cons * float)))) '(or (cons symbol (cons * *)) (cons * (cons * float)))) nil) (deftest subtypep.cons.17 (check-all-subtypep '(and (or (cons symbol (cons * *)) (cons * (cons integer *))) (or (cons * (cons (not integer))) (cons * (cons * float))) (or (cons * (cons * (not float))) (cons symbol (cons * *)))) '(cons symbol)) nil) (deftest subtypep.cons.18 (check-all-subtypep '(cons symbol) '(or (cons symbol (not integer)) (cons * integer))) nil) (deftest subtypep.cons.19 (check-equivalence '(or (cons (eql a) (eql x)) (cons (eql b) (eql y)) (cons (eql c) (eql z)) (cons (eql a) (eql y)) (cons (eql b) (eql z)) (cons (eql c) (eql x)) (cons (eql a) (eql z)) (cons (eql b) (eql x)) (cons (eql c) (eql y))) '(cons (member a b c) (member x y z))) nil) (deftest subtypep.cons.20 (check-equivalence '(or (cons (eql a) (eql x)) (cons (eql b) (eql y)) (cons (eql a) (eql y)) (cons (eql b) (eql z)) (cons (eql c) (eql x)) (cons (eql a) (eql z)) (cons (eql b) (eql x)) (cons (eql c) (eql y))) '(and (cons (member a b c) (member x y z)) (not (cons (eql c) (eql z))))) nil) gcl-2.6.14/ansi-tests/array.lsp0000644000175000017500000001232014360276512014721 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 25 08:46:58 2003 ;;;; Contains: Tests of the ARRAY type specifier (in-package :cl-test) ;;; Tests of array by itself (deftest array.1.1 (notnot-mv (typep #() 'array)) t) (deftest array.1.2 (notnot-mv (typep #0aX 'array)) t) (deftest array.1.3 (notnot-mv (typep #2a(()) 'array)) t) (deftest array.1.4 (notnot-mv (typep #(1 2 3) 'array)) t) (deftest array.1.5 (notnot-mv (typep "abcd" 'array)) t) (deftest array.1.6 (notnot-mv (typep #*010101 'array)) t) (deftest array.1.7 (typep nil 'array) nil) (deftest array.1.8 (typep 'x 'array) nil) (deftest array.1.9 (typep '(a b c) 'array) nil) (deftest array.1.10 (typep 10.0 'array) nil) (deftest array.1.11 (typep #'(lambda (x) (cons x nil)) 'array) nil) (deftest array.1.12 (typep 1 'array) nil) (deftest array.1.13 (typep (1+ most-positive-fixnum) 'array) nil) ;;; Tests of (array *) (deftest array.2.1 (notnot-mv (typep #() '(array *))) t) (deftest array.2.2 (notnot-mv (typep #0aX '(array *))) t) (deftest array.2.3 (notnot-mv (typep #2a(()) '(array *))) t) (deftest array.2.4 (notnot-mv (typep #(1 2 3) '(array *))) t) (deftest array.2.5 (notnot-mv (typep "abcd" '(array *))) t) (deftest array.2.6 (notnot-mv (typep #*010101 '(array *))) t) ;;; Tests of (array * ()) (deftest array.3.1 (notnot-mv (typep #() '(array * nil))) nil) (deftest array.3.2 (notnot-mv (typep #0aX '(array * nil))) t) (deftest array.3.3 (typep #2a(()) '(array * nil)) nil) (deftest array.3.4 (typep #(1 2 3) '(array * nil)) nil) (deftest array.3.5 (typep "abcd" '(array * nil)) nil) (deftest array.3.6 (typep #*010101 '(array * nil)) nil) ;;; Tests of (array * 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest array.4.1 (notnot-mv (typep #() '(array * 1))) t) (deftest array.4.2 (typep #0aX '(array * 1)) nil) (deftest array.4.3 (typep #2a(()) '(array * 1)) nil) (deftest array.4.4 (notnot-mv (typep #(1 2 3) '(array * 1))) t) (deftest array.4.5 (notnot-mv (typep "abcd" '(array * 1))) t) (deftest array.4.6 (notnot-mv (typep #*010101 '(array * 1))) t) ;;; Tests of (array * 0) (deftest array.5.1 (typep #() '(array * 0)) nil) (deftest array.5.2 (notnot-mv (typep #0aX '(array * 0))) t) (deftest array.5.3 (typep #2a(()) '(array * 0)) nil) (deftest array.5.4 (typep #(1 2 3) '(array * 0)) nil) (deftest array.5.5 (typep "abcd" '(array * 0)) nil) (deftest array.5.6 (typep #*010101 '(array * 0)) nil) ;;; Tests of (array * *) (deftest array.6.1 (notnot-mv (typep #() '(array * *))) t) (deftest array.6.2 (notnot-mv (typep #0aX '(array * *))) t) (deftest array.6.3 (notnot-mv (typep #2a(()) '(array * *))) t) (deftest array.6.4 (notnot-mv (typep #(1 2 3) '(array * *))) t) (deftest array.6.5 (notnot-mv (typep "abcd" '(array * *))) t) (deftest array.6.6 (notnot-mv (typep #*010101 '(array * *))) t) ;;; Tests of (array * 2) (deftest array.7.1 (typep #() '(array * 2)) nil) (deftest array.7.2 (typep #0aX '(array * 2)) nil) (deftest array.7.3 (notnot-mv (typep #2a(()) '(array * 2))) t) (deftest array.7.4 (typep #(1 2 3) '(array * 2)) nil) (deftest array.7.5 (typep "abcd" '(array * 2)) nil) (deftest array.7.6 (typep #*010101 '(array * 2)) nil) ;;; Testing '(array * (--)) (deftest array.8.1 (typep #() '(array * (1))) nil) (deftest array.8.2 (notnot-mv (typep #() '(array * (0)))) t) (deftest array.8.3 (notnot-mv (typep #() '(array * (*)))) t) (deftest array.8.4 (typep #(a b c) '(array * (2))) nil) (deftest array.8.5 (notnot-mv (typep #(a b c) '(array * (3)))) t) (deftest array.8.6 (notnot-mv (typep #(a b c) '(array * (*)))) t) (deftest array.8.7 (typep #(a b c) '(array * (4))) nil) (deftest array.8.8 (typep #2a((a b c)) '(array * (*))) nil) (deftest array.8.9 (typep #2a((a b c)) '(array * (3))) nil) (deftest array.8.10 (typep #2a((a b c)) '(array * (1))) nil) (deftest array.8.11 (typep "abc" '(array * (2))) nil) (deftest array.8.12 (notnot-mv (typep "abc" '(array * (3)))) t) (deftest array.8.13 (notnot-mv (typep "abc" '(array * (*)))) t) (deftest array.8.14 (typep "abc" '(array * (4))) nil) ;;; Two dimensional array type tests (deftest array.9.1 (typep #() '(array * (* *))) nil) (deftest array.9.2 (typep "abc" '(array * (* *))) nil) (deftest array.9.3 (typep #(a b c) '(array * (3 *))) nil) (deftest array.9.4 (typep #(a b c) '(array * (* 3))) nil) (deftest array.9.5 (typep "abc" '(array * (3 *))) nil) (deftest array.9.6 (typep "abc" '(array * (* 3))) nil) (deftest array.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* *)))) t) (deftest array.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 *)))) t) (deftest array.9.9 (typep #2a((a b)(c d)(e f)) '(array * (2 *))) nil) (deftest array.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* 2)))) t) (deftest array.9.11 (typep #2a((a b)(c d)(e f)) '(array * (* 3))) nil) (deftest array.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 2)))) t) (deftest array.9.13 (typep #2a((a b)(c d)(e f)) '(array * (2 3))) nil) gcl-2.6.14/ansi-tests/open-stream-p.lsp0000644000175000017500000000241314360276512016274 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:52:30 2004 ;;;; Contains: Tests of OPEN-STREAM-P (in-package :cl-test) (deftest open-stream-p.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (open-stream-p s)) unless (and (eql (length results) 1) (car results)) collect s) nil) (deftest open-stream-p.2 (with-open-file (s "open-stream-p.lsp" :direction :input) (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.3 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.4 (let ((s (open "open-stream-p.lsp" :direction :input))) (close s) (open-stream-p s)) nil) (deftest open-stream-p.5 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s) (open-stream-p s)) nil) ;;; error tests (deftest open-stream-p.error.1 (signals-error (open-stream-p) program-error) t) (deftest open-stream-p.error.2 (signals-error (open-stream-p *standard-input* nil) program-error) t) (deftest open-stream-p.error.3 (check-type-error #'open-stream-p #'streamp) nil) gcl-2.6.14/ansi-tests/with-open-stream.lsp0000644000175000017500000000352014360276512017010 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Dec 13 01:42:59 2004 ;;;; Contains: Tests of WITH-OPEN-STREAM (in-package :cl-test) (deftest with-open-stream.1 (with-open-stream (os (make-string-output-stream))) nil) (deftest with-open-stream.2 (with-open-stream (os (make-string-output-stream)) (declare (ignore os))) nil) (deftest with-open-stream.3 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (declare (type string-stream os))) nil) (deftest with-open-stream.4 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (values))) (deftest with-open-stream.5 (with-open-stream (os (make-string-output-stream)) (declare (ignore os)) (values 'a 'b)) a b) (deftest with-open-stream.6 (let ((s (make-string-output-stream))) (values (with-open-stream (os s)) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) (deftest with-open-stream.7 (let ((s (make-string-input-stream "123"))) (values (with-open-stream (is s) (read-char s)) (notnot (typep s 'string-stream)) (open-stream-p s))) #\1 t nil) (deftest with-open-stream.8 (let ((s (make-string-output-stream))) (values (block done (with-open-stream (os s) (return-from done nil))) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) (deftest with-open-stream.9 (let ((s (make-string-output-stream))) (values (catch 'done (with-open-stream (os s) (throw 'done nil))) (notnot (typep s 'string-stream)) (open-stream-p s))) nil t nil) ;;; Free declaration scope (deftest with-open-stream.10 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-open-stream (s (return-from done x)) (declare (special x)))))) :good) gcl-2.6.14/ansi-tests/string.lsp0000644000175000017500000000774214360276512015125 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Sep 30 19:16:59 2002 ;;;; Contains: Tests for string related functions and classes (in-package :cl-test) (deftest string.1 (subtypep* 'string 'array) t t) (deftest string.2 (subtypep* 'string 'vector) t t) (deftest string.3 (subtypep* 'string 'sequence) t t) (deftest string.4 (let ((s (string #\a))) (values (notnot (stringp s)) s)) t "a") (deftest string.5 (let ((s (string ""))) (values (notnot (stringp s)) s)) t "") (deftest string.6 (let ((s (string '|FOO|))) (values (notnot (stringp s)) s)) t "FOO") (deftest string.7 (loop for x in *universe* always (handler-case (stringp (string x)) (type-error () :caught))) t) ;;; Tests of base-string (deftest base-string.1 (subtypep* 'base-string 'string) t t) (deftest base-string.2 (subtypep* 'base-string 'vector) t t) (deftest base-string.3 (subtypep* 'base-string 'array) t t) (deftest base-string.4 (subtypep* 'base-string 'sequence) t t) ;;; Tests of simple-string (deftest simple-string.1 (subtypep* 'simple-string 'string) t t) (deftest simple-string.2 (subtypep* 'simple-string 'vector) t t) (deftest simple-string.3 (subtypep* 'simple-string 'simple-array) t t) (deftest simple-string.4 (subtypep* 'simple-string 'array) t t) (deftest simple-string.5 (subtypep* 'simple-string 'sequence) t t) ;;; Tests for simple-base-string (deftest simple-base-string.1 (subtypep* 'simple-base-string 'string) t t) (deftest simple-base-string.2 (subtypep* 'simple-base-string 'vector) t t) (deftest simple-base-string.3 (subtypep* 'simple-base-string 'simple-array) t t) (deftest simple-base-string.4 (subtypep* 'simple-base-string 'array) t t) (deftest simple-base-string.5 (subtypep* 'simple-base-string 'sequence) t t) (deftest simple-base-string.6 (subtypep* 'simple-base-string 'base-string) t t) (deftest simple-base-string.7 (subtypep* 'simple-base-string 'simple-string) t t) (deftest simple-base-string.8 (subtypep* 'simple-base-string 'simple-vector) nil t) ;;; Tests for simple-string-p (deftest simple-string-p.1 (loop for x in *universe* always (if (typep x 'simple-string) (simple-string-p x) (not (simple-string-p x)))) t) (deftest simple-string-p.2 (notnot (simple-string-p "ancd")) t) (deftest simple-string-p.3 (simple-string-p 0) nil) (deftest simple-string-p.4 (simple-string-p (make-array 4 :element-type 'character :initial-contents '(#\a #\a #\a #\b) :fill-pointer t)) nil) (deftest simple-string-p.5 (notnot (simple-string-p (make-array 4 :element-type 'base-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.6 (notnot (simple-string-p (make-array 4 :element-type 'standard-char :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.7 (let* ((s (make-array 10 :element-type 'character :initial-element #\a)) (s2 (make-array 4 :element-type 'character :displaced-to s :displaced-index-offset 2))) (simple-string-p s2)) nil) ;;; Tests of stringp (deftest stringp.1 (loop for x in *universe* always (if (typep x 'string) (stringp x) (not (stringp x)))) t) (deftest stringp.2 (notnot (stringp "abcd")) t) (deftest stringp.3 (notnot (stringp (make-array 4 :element-type 'character :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.4 (notnot (stringp (make-array 4 :element-type 'base-char :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.5 (notnot (stringp (make-array 4 :element-type 'standard-char :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.6 (stringp 0) nil) (deftest stringp.7 (stringp #\a) nil) (deftest stringp.8 (let* ((s (make-array 10 :element-type 'character :initial-element #\a)) (s2 (make-array 4 :element-type 'character :displaced-to s :displaced-index-offset 2))) (notnot (stringp s2))) t) gcl-2.6.14/ansi-tests/string-right-trim.lsp0000644000175000017500000000721514360276512017204 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 04:59:46 2002 ;;;; Contains: Tests of STRING-RIGHT-TRIM (in-package :cl-test) (deftest string-right-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") ;;; Test that trimming is case sensitive (deftest string-right-trim.13 (let* ((s (copy-seq "Aa")) (s2 (string-right-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-right-trim.14 (let* ((s '|abcdaba|) (s2 (string-right-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "abcd") (deftest string-right-trim.15 (string-right-trim "abc" "") "") (deftest string-right-trim.16 (string-right-trim "a" #\a) "") (deftest string-right-trim.17 (string-right-trim "b" #\a) "a") (deftest string-right-trim.18 (string-right-trim "" (copy-seq "abcde")) "abcde") (deftest string-right-trim.19 (string-right-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-right-trim.order.1 (let ((i 0) x y) (values (string-right-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) " abc d e f" 2 1 2) ;;; Error cases (deftest string-right-trim.error.1 (classify-error (string-right-trim)) program-error) (deftest string-right-trim.error.2 (classify-error (string-right-trim "abc")) program-error) (deftest string-right-trim.error.3 (classify-error (string-right-trim "abc" "abcdddabc" nil)) program-error) gcl-2.6.14/ansi-tests/compiler-macros.lsp0000644000175000017500000000030114360276512016673 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 18:51:30 2003 ;;;; Contains: Tests for compiler macros (in-package :cl-test) ;;; Compiler macro tests will go here gcl-2.6.14/ansi-tests/load-streams.lsp0000644000175000017500000000317214360276512016203 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:38:10 2004 ;;;; Contains: Load files containing tests for section 21 (streams) (in-package :cl-test) (load "input-stream-p.lsp") (load "output-stream-p.lsp") (load "interactive-stream-p.lsp") (load "open-stream-p.lsp") (load "stream-element-type.lsp") (load "streamp.lsp") (load "read-byte.lsp") (load "peek-char.lsp") (load "read-char.lsp") (load "read-char-no-hang.lsp") (load "terpri.lsp") (load "fresh-line.lsp") (load "unread-char.lsp") (load "write-char.lsp") (load "read-line.lsp") (load "write-string.lsp") (load "write-line.lsp") (load "read-sequence.lsp") (load "write-sequence.lsp") (load "file-length.lsp") (load "file-position.lsp") (load "file-string-length.lsp") (load "open.lsp") (load "stream-external-format.lsp") (load "with-open-file.lsp") (load "with-open-stream.lsp") (load "listen.lsp") (load "clear-input.lsp") (load "finish-output.lsp") (load "force-output.lsp") (load "clear-output.lsp") (load "make-synonym-stream.lsp") (load "synonym-stream-symbol.lsp") (load "make-broadcast-stream.lsp") (load "broadcast-stream-streams.lsp") (load "make-two-way-stream.lsp") (load "two-way-stream-input-stream.lsp") (load "two-way-stream-output-stream.lsp") (load "echo-stream-input-stream.lsp") (load "echo-stream-output-stream.lsp") (load "make-echo-stream.lsp") (load "concatenated-stream-streams.lsp") (load "make-concatenated-stream.lsp") (load "get-output-stream-string.lsp") (load "make-string-input-stream.lsp") (load "make-string-output-stream.lsp") (load "with-input-from-string.lsp") (load "with-output-to-string.lsp") (load "stream-error-stream.lsp") gcl-2.6.14/ansi-tests/packages-01.lsp0000644000175000017500000000365214360276512015607 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:49:34 1998 ;;;; Contains: Package test code, part 01 (in-package :cl-test) (declaim (optimize (safety 3))) ;; Test find-symbol, with the various combinations of ;; package designators (deftest find-symbol.1 (find-symbol "aBmAchb1c") nil nil) (deftest find-symbol.2 (find-symbol "aBmAchb1c" "CL") nil nil) (deftest find-symbol.3 (find-symbol "aBmAchb1c" "COMMON-LISP") nil nil) (deftest find-symbol.4 (find-symbol "aBmAchb1c" "KEYWORD") nil nil) (deftest find-symbol.5 (find-symbol "aBmAchb1c" "COMMON-LISP-USER") nil nil) (deftest find-symbol.6 (find-symbol (string '#:car) "CL") car :external) (deftest find-symbol.7 (find-symbol (string '#:car) "COMMON-LISP") car :external) (deftest find-symbol.8 (values (find-symbol (string '#:car) "COMMON-LISP-USER")) car #| :inherited |# ) (deftest find-symbol.9 (find-symbol (string '#:car) "CL-TEST") car :inherited) (deftest find-symbol.10 (find-symbol (string '#:test) "KEYWORD") :test :external) (deftest find-symbol.11 (find-symbol (string '#:find-symbol.11) "CL-TEST") find-symbol.11 :internal) (deftest find-symbol.12 (find-symbol "FOO" #\A) A::FOO :external) (deftest find-symbol.13 (progn (intern "X" (find-package "A")) (find-symbol "X" #\A)) A::X :internal) (deftest find-symbol.14 (find-symbol "FOO" #\B) A::FOO :inherited) (deftest find-symbol.15 (find-symbol "FOO" "B") A::FOO :inherited) (deftest find-symbol.16 (find-symbol "FOO" (find-package "B")) A::FOO :inherited) (deftest find-symbol.order.1 (let ((i 0) x y) (values (find-symbol (progn (setf x (incf i)) (string '#:car)) (progn (setf y (incf i)) "COMMON-LISP")) i x y)) car 2 1 2) (deftest find-symbol.error.1 (classify-error (find-symbol)) program-error) (deftest find-symbol.error.2 (classify-error (find-symbol "CAR" "CL" nil)) program-error)gcl-2.6.14/ansi-tests/types-and-class-2.lsp0000644000175000017500000001011414360276512016750 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Feb 5 21:20:05 2003 ;;;; Contains: More tests of types and classes (in-package :cl-test) ;;; Union of a type with its complement is universal (deftest type-or-not-type-is-everything (loop for l in *disjoint-types-list2* append (loop for type in l append (check-subtypep t `(or ,type (not ,type)) t) append (check-subtypep t `(or (not ,type) ,type) t))) nil) (defclass tac-1-class () (a b c)) (defclass tac-1a-class (tac-1-class) (d e)) (defclass tac-1b-class (tac-1-class) (f g)) (deftest user-class-disjointness (loop for l in *disjoint-types-list2* append (loop for type in l append (classes-are-disjoint type 'tac-1-class))) nil) (deftest user-class-disjointness-2 (check-disjointness 'tac-1a-class 'tac-1b-class) nil) (defstruct tac-2-struct a b c) (defstruct (tac-2a-struct (:include tac-2-struct)) d e) (defstruct (tac-2b-struct (:include tac-2-struct)) f g) (deftest user-struct-disjointness (loop for l in *disjoint-types-list2* append (loop for type in l append (check-disjointness type 'tac-2-struct))) nil) (deftest user-struct-disjointness-2 (check-disjointness 'tac-2a-struct 'tac-2b-struct) nil) (defclass tac-3-a () (x)) (defclass tac-3-b () (y)) (defclass tac-3-c () (z)) (defclass tac-3-ab (tac-3-a tac-3-b) ()) (defclass tac-3-ac (tac-3-a tac-3-c) ()) (defclass tac-3-bc (tac-3-b tac-3-c) ()) (defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ()) (deftest tac-3.1 (subtypep* 'tac-3-ab 'tac-3-a) t t) (deftest tac-3.2 (subtypep* 'tac-3-ab 'tac-3-b) t t) (deftest tac-3.3 (subtypep* 'tac-3-ab 'tac-3-c) nil t) (deftest tac-3.4 (subtypep* 'tac-3-a 'tac-3-ab) nil t) (deftest tac-3.5 (subtypep* 'tac-3-b 'tac-3-ab) nil t) (deftest tac-3.6 (subtypep* 'tac-3-c 'tac-3-ab) nil t) (deftest tac-3.7 (subtypep* 'tac-3-abc 'tac-3-a) t t) (deftest tac-3.8 (subtypep* 'tac-3-abc 'tac-3-b) t t) (deftest tac-3.9 (subtypep* 'tac-3-abc 'tac-3-c) t t) (deftest tac-3.10 (subtypep* 'tac-3-abc 'tac-3-ab) t t) (deftest tac-3.11 (subtypep* 'tac-3-abc 'tac-3-ac) t t) (deftest tac-3.12 (subtypep* 'tac-3-abc 'tac-3-bc) t t) (deftest tac-3.13 (subtypep* 'tac-3-ab 'tac-3-abc) nil t) (deftest tac-3.14 (subtypep* 'tac-3-ac 'tac-3-abc) nil t) (deftest tac-3.15 (subtypep* 'tac-3-bc 'tac-3-abc) nil t) (deftest tac-3.16 (check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab) nil) (deftest tac-3.17 (check-equivalence '(and (or tac-3-a tac-3-b) (or (not tac-3-a) (not tac-3-b)) (or tac-3-a tac-3-c) (or (not tac-3-a) (not tac-3-c)) (or tac-3-b tac-3-c) (or (not tac-3-b) (not tac-3-c))) nil) nil) ;;; ;;; Check that disjointness of types in *disjoint-types-list* ;;; is respected by all the elements of *universe* ;;; (deftest universe-elements-in-at-most-one-disjoint-type (loop for e in *universe* for types = (remove-if-not #'(lambda (x) (typep e x)) *disjoint-types-list*) when (> (length types) 1) collect (list e types)) nil) ;;;;; (deftest integer-and-ratio-are-disjoint (classes-are-disjoint 'integer 'ratio) nil) (deftest bignum-and-ratio-are-disjoint (classes-are-disjoint 'bignum 'ratio) nil) (deftest bignum-and-fixnum-are-disjoint (classes-are-disjoint 'bignum 'fixnum) nil) (deftest fixnum-and-ratio-are-disjoint (classes-are-disjoint 'fixnum 'ratio) nil) (deftest byte8-and-ratio-are-disjoint (classes-are-disjoint '(unsigned-byte 8) 'ratio) nil) (deftest bit-and-ratio-are-disjoint (classes-are-disjoint 'bit 'ratio) nil) (deftest integer-and-float-are-disjoint (classes-are-disjoint 'integer 'float) nil) (deftest ratio-and-float-are-disjoint (classes-are-disjoint 'ratio 'float) nil) (deftest complex-and-float-are-disjoint (classes-are-disjoint 'complex 'float) nil) (deftest integer-subranges-are-disjoint (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20))) nil) (deftest keyword-and-null-are-disjoint (classes-are-disjoint 'keyword 'null) nil) (deftest keyword-and-boolean-are-disjoint (classes-are-disjoint 'keyword 'boolean) nil) gcl-2.6.14/ansi-tests/bit-orc2.lsp0000644000175000017500000001434214360276512015232 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:31:35 2003 ;;;; Contains: Tests of BIT-ORC2 (in-package :cl-test) (deftest bit-orc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-orc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-orc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-orc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-orc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-orc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-orc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-orc2.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2)) a1 a2)) #*1011 #*0011 #*0101) (deftest bit-orc2.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-orc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1011 #*1011 #*0101 t) (deftest bit-orc2.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-orc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1011 #*0011 #*0101 #*1011 t) (deftest bit-orc2.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2 nil)) a1 a2)) #*1011 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-orc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2 t))) (values a1 a2 result)) #2a((1 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-orc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1)) #2a((1 1)(0 1))) ;;; Adjustable arrays (deftest bit-orc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) ;;; Displaced arrays (deftest bit-orc2.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc2 a1 a2 t))) (values a0 a1 a2 result)) #*11010011 #2a((1 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-orc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111101 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 1)(0 1))) (deftest bit-orc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-orc2 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-orc2.error.1 (classify-error (bit-orc2)) program-error) (deftest bit-orc2.error.2 (classify-error (bit-orc2 #*000)) program-error) (deftest bit-orc2.error.3 (classify-error (bit-orc2 #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/rt.system0000644000175000017500000000125014360276512014756 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 7 23:30:22 1998 ;;;; Contains: Portable defsystem for RT testing system (mk::defsystem "rt" :source-pathname #.(directory-namestring *LOAD-TRUENAME*) :binary-pathname #.(mk::append-directories (directory-namestring *LOAD-TRUENAME*) "binary/") :source-extension "lsp" :binary-extension #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) #+ALLEGRO "fasl" #+(OR AKCL GCL) "o" #+CLISP "fas" #-(OR CMU ALLEGRO AKCL GCL CLISP) #.(pathname-type (compile-file-pathname "foo.lisp")) :components ( "rt-package" ("rt" :depends-on ("rt-package")))) gcl-2.6.14/ansi-tests/places.lsp0000644000175000017500000002255314360276512015063 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 19:20:17 2002 ;;;; Contains: Tests of various kinds of places (section 5.1) (in-package :cl-test) ;;; Section 5.1.1.1 (deftest setf-order (let ((x (vector nil nil nil nil)) (i 0)) (setf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest setf-order.2 (let ((x (vector nil nil nil nil)) (i 0)) (setf (aref x (incf i)) (incf i) (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) (deftest push-order (let ((x (vector nil nil nil nil)) (y (vector 'a 'b 'c 'd)) (i 1)) (push (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) #(a b c d) 3) (deftest pushnew-order (let ((x (vector nil nil nil nil)) (y (vector 'a 'b 'c 'd)) (i 1)) (pushnew (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) #(a b c d) 3) (deftest pushnew-order.2 (let ((x (vector nil nil nil nil nil)) (y (vector 'a 'b 'c 'd 'e)) (i 1)) (pushnew (aref y (incf i)) (aref x (incf i)) :test (progn (incf i) #'eql)) (values x y i)) #(nil nil nil (c) nil) #(a b c d e) 4) (deftest remf-order (let ((x (copy-seq #(nil :a :b))) (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) (i 0)) (values (not (remf (aref pa (incf i)) (aref x (incf i)))) pa)) nil #((:a 1) nil (:c 3) (:d 4))) (deftest incf-order (let ((x (copy-seq #(0 0 0 0 0))) (i 1)) (values (incf (aref x (incf i)) (incf i)) x i)) 3 #(0 0 3 0 0) 3) (deftest decf-order (let ((x (copy-seq #(0 0 0 0 0))) (i 1)) (values (decf (aref x (incf i)) (incf i)) x i)) -3 #(0 0 -3 0 0) 3) (deftest shiftf-order.1 (let ((x (vector 'a 'b 'c 'd 'e)) (i 2)) (values (shiftf (aref x (incf i)) (incf i)) x i)) d #(a b c 4 e) 4) (deftest shiftf-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f 'g 'h)) (i 2)) (values (shiftf (aref x (incf i)) (aref x (incf i)) (incf i)) x i)) d #(a b c e 5 f g h) 5) (deftest rotatef-order.1 (let ((x (vector 'a 'b 'c 'd 'e 'f)) (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i))) x i)) nil #(a b c e d f) 4) (deftest rotatef-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f)) (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i)) (aref x (incf i))) x i)) nil #(a b c e f d) 5) (deftest psetf-order (let ((x (vector nil nil nil nil)) (i 0)) (psetf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest psetf-order.2 (let ((x (vector nil nil nil nil)) (i 0)) (psetf (aref x (incf i)) (incf i) (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) (deftest pop-order (let ((x (vector '(a b) '(c d) '(e f))) (i 0)) (values (pop (aref x (incf i))) x i)) c #((a b) (d) (e f)) 1) ;;; Section 5.1.2.1 (deftest setf-var (let ((x nil)) (setf x 'a) x) a) ;;; Section 5.1.2.2 ;;; See SETF forms at various accessor functions ;;; Section 5.1.2.3 (deftest setf-values.1 (let ((x nil) (y nil) (z nil)) (setf (values x y z) (values 1 2 3))) 1 2 3) (deftest setf-values.2 (let ((x nil) (y nil) (z nil)) (setf (values x y z) (values 1 2 3)) (values z y x)) 3 2 1) (deftest setf-values.3 (let ((x nil) (y nil) (z nil)) (setf (values x x x) (values 1 2 3)) x) 3) ;;; Test that the subplaces of a VALUES place can be ;;; complex, and that the various places' subforms are ;;; evaluated in the correct (left-to-right) order. (deftest setf-values.4 (let ((x (list 'a 'b))) (setf (values (car x) (cadr x)) (values 1 2)) x) (1 2)) (deftest setf-values.5 (let ((a (vector nil nil)) (i 0) x y z) (setf (values (aref a (progn (setf x (incf i)) 0)) (aref a (progn (setf y (incf i)) 1))) (progn (setf z (incf i)) (values 'foo 'bar))) (values a i x y z)) #(foo bar) 3 1 2 3) (deftest setf-values.6 (setf (values) (values))) ;;; Section 5.1.2.4 (deftest setf-the.1 (let ((x 1)) (setf (the integer x) 2) x) 2) (deftest setf-the.2 (let ((x (list 'a))) (values (setf (the symbol (car x)) 'b) x)) b (b)) ;;; Section 5.1.2.5 (deftest setf-apply.1 (let ((x (vector 0 1 2 3 4 5))) (setf (apply #'aref x '(0)) 10) x) #(10 1 2 3 4 5)) (deftest setf-apply.2 (let ((a (make-array '(2 2) :initial-contents '((0 0)(0 0))))) (setf (apply #'aref a 1 1 nil) 'a) (equalp a (make-array '(2 2) :initial-contents '((0 0)(0 a))))) t) (deftest setf-apply.3 (let ((bv (copy-seq #*0000000000))) (setf (apply #'bit bv 4 nil) 1) bv) #*0000100000) (deftest setf-apply.4 (let ((bv (copy-seq #*0000000000))) (setf (apply #'sbit bv 4 nil) 1) bv) #*0000100000) ;;; Section 5.1.2.6 (defun accessor-5-1-2-6-update-fn (x y) (setf (car x) y) y) (defsetf accessor-5-1-2-6 accessor-5-1-2-6-update-fn) (deftest setf-expander.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-6 x) 2) (1+ (car x)))) 2 3) ;;; Section 5.1.2.7 (defmacro accessor-5-1-2-7 (x) `(car ,x)) (deftest setf-macro.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-7 x) 2) (1+ (car x)))) 2 3) (defun accessor-5-1-2-7a-update-fn (x y) (declare (special *x*)) (setf (car x) y) (setf *x* 'boo) y) (defmacro accessor-5-1-2-7a (x) `(car ,x)) (defsetf accessor-5-1-2-7a accessor-5-1-2-7a-update-fn) ;; Test that the defsetf override the macro expansion (deftest setf-macro.2 (let ((x (list 1)) (*x* nil)) (declare (special *x*)) (values (setf (accessor-5-1-2-7a x) 2) *x* (1+ (car x)))) 2 boo 3) (defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x)) ;; Test that the macroexpansion occurs more than once (deftest setf-macro.3 (let ((x (list 1))) (values (setf (accessor-5-1-2-7b x) 2) (1+ (car x)))) 2 3) ;; Macroexpansion from a macrolet (deftest setf-macro.4 (macrolet ((%m (y) `(car ,y))) (let ((x (list 1))) (values (setf (%m x) 2) (1+ (car x))))) 2 3) ;;; section 5.1.2.8 -- symbol macros (deftest setf-symbol-macro.1 (symbol-macrolet ((x y)) (let ((y nil)) (values (setf x 1) x y))) 1 1 1) ;;; Symbol macros in SETQs are treated as if the form were a SETF (deftest setf-symbol-macro.2 (symbol-macrolet ((x y)) (let ((y nil)) (values (setq x 1) x y))) 1 1 1) ;;; Tests that, being treated like SETF, this causes multiple values ;;; to be assigned to (values y z) (deftest setf-symbol-macro.3 (symbol-macrolet ((x (values y z))) (let ((y nil) (z nil)) (values (setq x (values 1 2)) x y z))) 1 1 1 2) (deftest setq.1 (setq) nil) (deftest setq.2 (let ((x 0) (y 0)) (values (setq x 1 y 2) x y)) 2 1 2) (deftest setq.3 (let ((x 0) (y 0)) (values (setq x (values 1 3) y (values 2 4)) x y)) 2 1 2) (deftest setq.4 (let (x) (setq x (values 1 2))) 1) (deftest setf.1 (setf) nil) (deftest setf.2 (let ((x 0) (y 0)) (values (setf x 1 y 2) x y)) 2 1 2) (deftest setf.3 (let ((x 0) (y 0)) (values (setf x (values 1 3) y (values 2 4)) x y)) 2 1 2) (deftest setf.4 (let (x) (setf x (values 1 2))) 1) ;;; Tests of PSETQ (deftest psetq.1 (psetq) nil) (deftest psetq.2 (let ((x 0)) (values (psetq x 1) x)) nil 1) (deftest psetq.3 (let ((x 0) (y 1)) (values (psetq x y y x) x y)) nil 1 0) (deftest psetq.4 (let ((x 0)) (values (symbol-macrolet ((x y)) (let ((y 1)) (psetq x 2) y)) x)) 2 0) (deftest psetq.5 (let ((w (list nil))) (values (symbol-macrolet ((x (car w))) (psetq x 2)) w)) nil (2)) (deftest psetq.6 (let ((c 0) x y) (psetq x (incf c) y (incf c)) (values c x y)) 2 1 2) ;;; The next test is a PSETQ that is equivalent to a PSETF ;;; See PSETF.7 for comments related to this test. (deftest psetq.7 (symbol-macrolet ((x (aref a (incf i))) (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetq x (aref a (incf i)) y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) ;;; Tests of PSETF (deftest psetf.1 (psetf) nil) (deftest psetf.2 (let ((x 0)) (values (psetf x 1) x)) nil 1) (deftest psetf.3 (let ((x 0) (y 1)) (values (psetf x y y x) x y)) nil 1 0) (deftest psetf.4 (let ((x 0)) (values (symbol-macrolet ((x y)) (let ((y 1)) (psetf x 2) y)) x)) 2 0) (deftest psetf.5 (let ((w (list nil))) (values (symbol-macrolet ((x (car w))) (psetf x 2)) w)) nil (2)) (deftest psetf.6 (let ((c 0) x y) (psetf x (incf c) y (incf c)) (values c x y)) 2 1 2) ;;; According to the standard, the forms to be assigned and ;;; the subforms in the places to be assigned to are evaluated ;;; from left to right. Therefore, PSETF.7 and PSETF.8 should ;;; do the same thing to A as PSETF.9 does. ;;; (See the page for PSETF) (deftest psetf.7 (symbol-macrolet ((x (aref a (incf i))) (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetf x (aref a (incf i)) y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) (deftest psetf.8 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) (i 0)) (psetf (aref a (incf i)) (aref a (incf i)) (aref a (incf i)) (aref a (incf i))) (values a i)) #(0 2 2 4 4 5 6 7 8 9) 4) (deftest psetf.9 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))) (psetf (aref a 1) (aref a 2) (aref a 3) (aref a 4)) a) #(0 2 2 4 4 5 6 7 8 9)) gcl-2.6.14/ansi-tests/find.lsp0000644000175000017500000004406614360276512014537 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 07:49:49 2002 ;;;; Contains: Tests for FIND (in-package :cl-test) (deftest find-list.1 (find 'c '(a b c d e c a)) c) (deftest find-list.2 (find 'c '(a b c d e c a) :from-end t) c) (deftest find-list.3 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-list.4 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-list.5 (loop for i from 7 downto 0 collect (find 'c '(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-list.6 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-list.7 (loop for i from 0 to 7 collect (find 'c '(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-list.8 (loop for i from 7 downto 0 collect (find 'c '(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-list.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c '(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-list.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-list.11 (find 5 '(1 2 3 4 5 6 4 8) :key #'1+) 4) (deftest find-list.12 (find 5 '(1 2 3 4 5 6 4 8) :key '1+) 4) (deftest find-list.13 (find 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 4) (deftest find-list.14 (find 'a '(a a b a c e d a f a) :test (complement #'eql)) b) (deftest find-list.15 (find 'a '(a a b a c e d a f a) :test (complement #'eql) :from-end t) f) (deftest find-list.16 (find 'a '(a a b a c e d a f a) :test-not #'eql) b) (deftest find-list.17 (find 'a '(a a b a c e d a f a) :test-not 'eql :from-end t) f) (deftest find-list.18 (find 'a '(a a b a c e d a f a) :test-not 'eql) b) (deftest find-list.19 (find 'a '(a a b a c e d a f a) :test-not #'eql :from-end t) f) (deftest find-list.20 (find 'a '(a a b a c e d a f a) :test-not #'eql) b) (deftest find-list.21 (find 'a '(a a b a c e d a f a) :test #'eql :start 2) a) (deftest find-list.22 (find 'a '(a a b a c e d a f a) :test #'eql :start 2 :end nil) a) (deftest find-list.23 (find 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) b) (deftest find-list.24 (find 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) c) (deftest find-list.25 (find "ab" '("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) #(#\a #\b)) (deftest find-list.26 (find 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) (a b c)) (deftest find-list.27 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) (a b)) (deftest find-list.28 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) (a b)) ;;; Tests on vectors (deftest find-vector.1 (find 'c #(a b c d e c a)) c) (deftest find-vector.1a (find 'z #(a b c d e c a)) nil) (deftest find-vector.2 (find 'c #(a b c d e c a) :from-end t) c) (deftest find-vector.2a (find 'z #(a b c d e c a) :from-end t) nil) (deftest find-vector.3 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-vector.4 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-vector.5 (loop for i from 7 downto 0 collect (find 'c #(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-vector.6 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-vector.7 (loop for i from 0 to 7 collect (find 'c #(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-vector.8 (loop for i from 7 downto 0 collect (find 'c #(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c #(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) (nil nil c c) (nil c c) (c c) (nil))) (deftest find-vector.11 (find 5 #(1 2 3 4 5 6 4 8) :key #'1+) 4) (deftest find-vector.12 (find 5 #(1 2 3 4 5 6 4 8) :key '1+) 4) (deftest find-vector.13 (find 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 4) (deftest find-vector.14 (find 'a #(a a b a c e d a f a) :test (complement #'eql)) b) (deftest find-vector.15 (find 'a #(a a b a c e d a f a) :test (complement #'eql) :from-end t) f) (deftest find-vector.16 (find 'a #(a a b a c e d a f a) :test-not #'eql) b) (deftest find-vector.17 (find 'a #(a a b a c e d a f a) :test-not 'eql :from-end t) f) (deftest find-vector.18 (find 'a #(a a b a c e d a f a) :test-not 'eql) b) (deftest find-vector.19 (find 'a #(a a b a c e d a f a) :test-not #'eql :from-end t) f) (deftest find-vector.20 (find 'a #(a a b a c e d a f a) :test-not #'eql) b) (deftest find-vector.21 (find 'a #(a a b a c e d a f a) :test #'eql :start 2) a) (deftest find-vector.22 (find 'a #(a a b a c e d a f a) :test #'eql :start 2 :end nil) a) (deftest find-vector.23 (find 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) b) (deftest find-vector.24 (find 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) c) (deftest find-vector.25 (find "ab" #("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) #(#\a #\b)) (deftest find-vector.26 (find 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) (a b c)) (deftest find-vector.27 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) (a b)) (deftest find-vector.28 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) (a b)) (deftest find-vector.29 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5))) (loop for i from 1 to 10 collect (find i a))) (1 2 3 4 5 nil nil nil nil nil)) (deftest find-vector.30 (let ((a (make-array '(10) :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) collect (list e i)) :fill-pointer 5))) (loop for i from 1 to 5 collect (find i a :from-end t :key #'car))) ((1 1) (2 2) (3 3) (4 4) (5 5))) ;;; tests on bit vectors (deftest find-bit-vector.1 (find 1 #*001001010100) 1) (deftest find-bit-vector.1a (find 0 #*001001010100) 0) (deftest find-bit-vector.1b (find 2 #*001001010100) nil) (deftest find-bit-vector.1c (find 'a #*001001010100) nil) (deftest find-bit-vector.1d (find 1 #*000000) nil) (deftest find-bit-vector.2 (find 1 #*001001010100 :from-end t) 1) (deftest find-bit-vector.2a (find 1 #*00000 :from-end t) nil) (deftest find-bit-vector.2b (find 0 #*00000 :from-end t) 0) (deftest find-bit-vector.2c (find 0 #*11111 :from-end t) nil) (deftest find-bit-vector.2d (find 2 #*11111 :from-end t) nil) (deftest find-bit-vector.2e (find 'a #*11111 :from-end t) nil) (deftest find-bit-vector.3 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.4 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i :end nil)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.5 (loop for i from 7 downto 0 collect (find 1 #*0010010 :end i)) (1 1 1 1 1 nil nil nil)) (deftest find-bit-vector.6 (loop for i from 0 to 7 collect (find 1 #*0010010 :start i :from-end t)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.7 (loop for i from 0 to 7 collect (find 0 #*1101101 :start i :end nil :from-end t)) (0 0 0 0 0 0 nil nil)) (deftest find-bit-vector.8 (loop for i from 7 downto 0 collect (find 0 #*1101101 :end i :from-end t)) (0 0 0 0 0 nil nil nil)) (deftest find-bit-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 1 #*0010010 :start i :end j))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) (nil nil 1 1) (nil 1 1) (1 1) (nil))) (deftest find-bit-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find 1 #*0010010 :start i :end j :from-end t))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) (nil nil 1 1) (nil 1 1) (1 1) (nil))) (deftest find-bit-vector.11 (find 2 #*00010001010 :key #'1+) 1) (deftest find-bit-vector.12 (find 2 #*00010001010 :key '1+) 1) (deftest find-bit-vector.13 (find 2 #*0010001000 :key #'1+ :from-end t) 1) (deftest find-bit-vector.14 (find 0 #*0010111010 :test (complement #'eql)) 1) (deftest find-bit-vector.15 (find 0 #*0010111010 :test (complement #'eql) :from-end t) 1) (deftest find-bit-vector.16 (find 0 #*0010111010 :test-not #'eql) 1) (deftest find-bit-vector.16a (find 1 #*111111111111 :test-not #'eql) nil) (deftest find-bit-vector.16b (find 0 #*0000000 :test-not #'eql) nil) (deftest find-bit-vector.17 (find 0 #*001011101 :test-not 'eql :from-end t) 1) (deftest find-bit-vector.17a (find 0 #*0000000 :test-not 'eql :from-end t) nil) (deftest find-bit-vector.17b (find 1 #*111111111111 :test-not 'eql :from-end t) nil) (deftest find-bit-vector.18 (find 0 #*00101110 :test-not 'eql) 1) (deftest find-bit-vector.18a (find 0 #*00000000 :test-not 'eql) nil) (deftest find-bit-vector.19 (find 0 #*00101110 :test-not #'eql :from-end t) 1) (deftest find-bit-vector.19a (find 0 #*00000000 :test-not #'eql :from-end t) nil) (deftest find-bit-vector.20 (find 0 #*00101110 :test-not #'eql) 1) (deftest find-bit-vector.21 (find 0 #*00101110 :test #'eql :start 2) 0) (deftest find-bit-vector.21a (find 0 #*00111111 :test #'eql :start 2) nil) (deftest find-bit-vector.21b (find 1 #*00111111 :test #'eql :start 2) 1) (deftest find-bit-vector.22 (find 0 #*00101110 :test #'eql :start 2 :end nil) 0) (deftest find-bit-vector.22a (find 0 #*001111111 :test #'eql :start 2 :end nil) nil) (deftest find-bit-vector.22b (find 1 #*001111111 :test #'eql :start 2 :end nil) 1) (deftest find-bit-vector.23 (find 0 #*00101110 :test-not #'eql :start 0 :end 5) 1) (deftest find-bit-vector.23a (find 0 #*00000111 :test-not #'eql :start 0 :end 5) nil) (deftest find-bit-vector.23b (find 0 #*00001000 :test-not #'eql :start 0 :end 5) 1) (deftest find-bit-vector.24 (find 0 #*00101110 :test-not #'eql :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.24a (find 0 #*0000001111 :test-not #'eql :start 0 :end 5 :from-end t) nil) (deftest find-bit-vector.24b (find 0 #*0000100 :test-not #'eql :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.25 (find 2 #*1100001010 :key #'1+ :start 3) 1) (deftest find-bit-vector.26 (find 2 #*11100000 :key #'1+ :start 3) nil) (deftest find-bit-vector.26a (find 2 #*11110000 :key #'1+ :start 3) 1) (deftest find-bit-vector.27 (find 2 #*1100001010 :key #'1+ :start 2 :from-end t) 1) (deftest find-bit-vector.28 (find 2 #*1100000000 :key #'1+ :start 2 :from-end t) nil) (deftest find-bit-vector.29 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5))) (values (find 0 a) (find 0 a :from-end t))) nil nil) (deftest find-bit-vector.30 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5))) (values (find 0 a) (find 0 a :from-end t))) 0 0) ;;; strings (deftest find-string.1 (find #\c "abcdeca") #\c) (deftest find-string.1a (find #\c "abCa") nil) (deftest find-string.2 (find #\c "abcdeca" :from-end t) #\c) (deftest find-string.2a (find #\c "abCCCa" :from-end t) nil) (deftest find-string.3 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.4 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :end nil)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.5 (loop for i from 7 downto 0 collect (find #\c "abcdeca" :end i)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.6 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.7 (loop for i from 0 to 7 collect (find #\c "abcdeca" :start i :end nil :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.8 (loop for i from 7 downto 0 collect (find #\c "abcdeca" :end i :from-end t)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find #\c "abcdeca" :start i :end j))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) (nil nil #\c #\c) (nil #\c #\c) (#\c #\c) (nil))) (deftest find-string.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (find #\c "abcdeca" :start i :end j :from-end t))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) (nil nil #\c #\c) (nil #\c #\c) (#\c #\c) (nil))) (deftest find-string.11 (find 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c))))) #\4) (deftest find-string.13 (find 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c)))) :from-end t) #\4) (deftest find-string.14 (find #\a "aabacedafa" :test (complement #'eql)) #\b) (deftest find-string.15 (find #\a "aabacedafa" :test (complement #'eql) :from-end t) #\f) (deftest find-string.16 (find #\a "aabacedafa" :test-not #'eql) #\b) (deftest find-string.17 (find #\a "aabacedafa" :test-not 'eql :from-end t) #\f) (deftest find-string.18 (find #\a "aabacedafa" :test-not 'eql) #\b) (deftest find-string.19 (find #\a "aabacedafa" :test-not #'eql :from-end t) #\f) (deftest find-string.20 (find #\a "aabacedafa" :test-not #'eql) #\b) (deftest find-string.21 (find #\a "aabAcedafa" :test #'char-equal :start 2) #\A) (deftest find-string.22 (find #\a "aabAcedafa" :test #'char-equal :start 2 :end nil) #\A) (deftest find-string.23 (find #\a "aAbAcedafa" :test-not #'char-equal :start 0 :end 5) #\b) (deftest find-string.24 (find #\a "aabacedafa" :test-not #'char-equal :start 0 :end 5 :from-end t) #\c) (deftest find-string.25 (let ((s (make-array '(10) :initial-contents "abcdefghij" :element-type 'character :fill-pointer 5))) (values (loop for e across "abcdefghij" collect (find e s)) (loop for e across "abcdefghij" collect (find e s :from-end t)))) (#\a #\b #\c #\d #\e nil nil nil nil nil) (#\a #\b #\c #\d #\e nil nil nil nil nil)) ;;; Keyword tests (deftest find.allow-other-keys.1 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :bad t :allow-other-keys t) 2) (deftest find.allow-other-keys.2 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find.allow-other-keys.3 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest find.keywords.4 (find 2 '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest find.allow-other-keys.5 (find 'b '(nil a b c nil) :allow-other-keys nil) b) ;;; Error tests (deftest find.error.1 (classify-error (find 'a 'b)) type-error) (deftest find.error.2 (classify-error (find 'a 10)) type-error) (deftest find.error.3 (classify-error (find 'a 1.4)) type-error) (deftest find.error.4 (classify-error (find 'e '(a b c . d))) type-error) (deftest find.error.5 (classify-error (find)) program-error) (deftest find.error.6 (classify-error (find 'a)) program-error) (deftest find.error.7 (classify-error (find 'a nil :bad t)) program-error) (deftest find.error.8 (classify-error (find 'a nil :bad t :allow-other-keys nil)) program-error) (deftest find.error.9 (classify-error (find 'a nil 1 1)) program-error) (deftest find.error.10 (classify-error (find 'a nil :key)) program-error) (deftest find.error.11 (classify-error (locally (find 'a 'b) t)) type-error) (deftest find.error.12 (classify-error (find 'b '(a b c) :test #'identity)) program-error) (deftest find.error.13 (classify-error (find 'b '(a b c) :test-not #'identity)) program-error) (deftest find.error.14 (classify-error (find 'c '(a b c) :key #'cons)) program-error) (deftest find.error.15 (classify-error (find 'c '(a b c) :key #'car)) type-error) ;;; Order of evaluation tests (deftest find.order.1 (let ((i 0) x y) (values (find (progn (setf x (incf i)) 'a) (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) (deftest find.order.2 (let ((i 0) a b c d e f g) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :start (progn (setf c (incf i)) 1) :end (progn (setf d (incf i)) 4) :from-end (setf e (incf i)) :key (progn (setf f (incf i)) #'null) ) i a b c d e f)) a 6 1 2 3 4 5 6) (deftest find.order.3 (let ((i 0) a b c d e f g) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) :key (progn (setf c (incf i)) #'null) :from-end (setf d (incf i)) :end (progn (setf e (incf i)) 4) :start (progn (setf f (incf i)) 1) ) i a b c d e f)) a 6 1 2 3 4 5 6) gcl-2.6.14/ansi-tests/search-aux.lsp0000644000175000017500000000566514360276512015661 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Aux. functions for testing SEARCH (in-package :cl-test) (defparameter *searched-list* '(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b)) (defparameter *pattern-sublists* (remove-duplicates (let* ((s *searched-list*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equal)) (defparameter *searched-vector* (make-array (length *searched-list*) :initial-contents *searched-list*)) (defparameter *pattern-subvectors* (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) (defparameter *searched-bitvector* #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101) (defparameter *pattern-subbitvectors* (remove-duplicates (let* ((s *searched-bitvector*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equalp)) (defparameter *searched-string* "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101") (defparameter *pattern-substrings* (remove-duplicates (let* ((s *searched-string*) (len (length s))) (loop for x from 0 to 8 nconc (loop for y from 0 to (- len x) collect (subseq s y (+ y x))))) :test #'equalp)) (defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) (assert (and (>= start1 0) (>= start2 0) (<= (+ start1 len) (length seq1)) (<= (+ start2 len) (length seq2)))) (if (and (listp seq1) (listp seq2)) (loop for i from 0 to (1- len) for e1 in (nthcdr start1 seq1) for e2 in (nthcdr start2 seq2) always (funcall test e1 e2)) (loop for i from 0 to (1- len) always (funcall test (elt seq1 (+ start1 i)) (elt seq2 (+ start2 i)))))) (defun search-check (pattern searched pos &key (start1 0) (end1 nil) (start2 0) (end2 nil) key from-end (test #'equalp)) (unless end1 (setq end1 (length pattern))) (unless end2 (setq end2 (length searched))) (assert (<= start1 end1)) (assert (<= start2 end2)) (let* ((plen (- end1 start1))) (when key (setq pattern (map 'list key pattern)) (setq searched (map 'list key searched))) (if pos (and (subseq-equalp searched pattern pos start1 plen :test test) (if from-end (loop for i from (1+ pos) to (- end2 plen) never (subseq-equalp searched pattern i start1 plen :test test)) (loop for i from start2 to (1- pos) never (subseq-equalp searched pattern i start1 plen :test test)))) (loop for i from start2 to (- end2 plen) never (subseq-equalp searched pattern i start1 plen :test test))))) gcl-2.6.14/ansi-tests/make-concatenated-stream.lsp0000644000175000017500000002015514360276512020444 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 08:41:18 2004 ;;;; Contains: Tests of MAKE-CONCATENATED-STREAM (in-package :cl-test) (deftest make-concatenated-stream.1 (let ((s (make-concatenated-stream))) (read s nil :eof)) :eof) (deftest make-concatenated-stream.2 (let ((s (make-concatenated-stream))) (notnot-mv (input-stream-p s))) t) (deftest make-concatenated-stream.3 (let ((s (make-concatenated-stream))) (output-stream-p s)) nil) (deftest make-concatenated-stream.4 (let ((s (make-concatenated-stream))) (notnot-mv (streamp s))) t) (deftest make-concatenated-stream.5 (let ((s (make-concatenated-stream))) (notnot-mv (typep s 'stream))) t) (deftest make-concatenated-stream.6 (let ((s (make-concatenated-stream))) (notnot-mv (typep s 'concatenated-stream))) t) (deftest make-concatenated-stream.7 (let ((s (make-concatenated-stream))) (notnot-mv (open-stream-p s))) t) (deftest make-concatenated-stream.8 (let ((s (make-concatenated-stream *standard-input*))) (notnot-mv (stream-element-type s))) t) (deftest make-concatenated-stream.9 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2))) (loop repeat 8 collect (read-byte s)))))) (1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.10 (let ((s (make-concatenated-stream))) (read-byte s nil :eof)) :eof) (deftest make-concatenated-stream.11 (let ((s (make-concatenated-stream))) (peek-char nil s nil :eof)) :eof) (deftest make-concatenated-stream.12 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (peek-char nil s) (read-char s) (peek-char nil s) (read-char s) (peek-char nil s nil :eof))))) #\a #\a #\b #\b :eof) (deftest make-concatenated-stream.13 (with-input-from-string (s1 " a ") (with-input-from-string (s2 " b ") (let ((s (make-concatenated-stream s1 s2))) (values (peek-char t s) (read-char s) (peek-char t s) (read-char s) (peek-char t s nil :eof))))) #\a #\a #\b #\b :eof) (deftest make-concatenated-stream.14 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (read-char s) (unread-char #\a s) (read-char s) (read-char s) (unread-char #\b s) (read-char s) (read-char s nil :eof))))) #\a nil #\a #\b nil #\b :eof) (deftest make-concatenated-stream.15 (let ((s (make-concatenated-stream))) (read-char-no-hang s nil :eof)) :eof) (deftest make-concatenated-stream.16 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (values (read-char-no-hang s) (read-char-no-hang s) (read-char-no-hang s nil :eof))))) #\a #\b :eof) (deftest make-concatenated-stream.17 (with-input-from-string (s1 "a") (with-input-from-string (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.18 (with-input-from-string (s1 "ab") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.19 (with-input-from-string (s1 "") (with-input-from-string (s2 "ab") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s) (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.20 (with-input-from-string (s1 "ab") (with-input-from-string (s2 (concatenate 'string (string #\Newline) "def")) (let ((s (make-concatenated-stream s1 s2))) (read-line s)))) "ab" nil) (deftest make-concatenated-stream.21 (with-input-from-string (s1 "") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) (read-line s nil :eof) (values str (notnot mnp)))))) :eof t) (deftest make-concatenated-stream.22 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 8 #(1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.23 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 6 #(1 5 9 13 1 5)) (deftest make-concatenated-stream.24 (let ((pn #p"tmp.dat") (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type :if-exists :supersede) (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) (x (vector nil nil nil nil nil nil nil nil nil nil))) (values (read-sequence x s) x))))) 8 #(1 5 9 13 1 5 9 13 nil nil)) (deftest make-concatenated-stream.25 (close (make-concatenated-stream)) t) (deftest make-concatenated-stream.26 (let ((s (make-concatenated-stream))) (values (prog1 (close s) (close s)) (open-stream-p s))) t nil) (deftest make-concatenated-stream.27 (with-input-from-string (s1 "abc") (let ((s (make-concatenated-stream s1))) (values (notnot (open-stream-p s1)) (notnot (open-stream-p s)) (close s) (notnot (open-stream-p s1)) (open-stream-p s)))) t t t t nil) (deftest make-concatenated-stream.28 (with-input-from-string (s1 "a") (let ((s (make-concatenated-stream s1))) (notnot-mv (listen s)))) t) (deftest make-concatenated-stream.28a (listen (make-concatenated-stream)) nil) (deftest make-concatenated-stream.29 (with-input-from-string (s1 "") (let ((s (make-concatenated-stream s1))) (listen s))) nil) (deftest make-concatenated-stream.30 (with-input-from-string (s1 "") (with-input-from-string (s2 "a") (let ((s (make-concatenated-stream s1 s2))) (notnot-mv (listen s))))) t) (deftest make-concatenated-stream.31 (with-input-from-string (s1 "") (with-input-from-string (s2 "") (let ((s (make-concatenated-stream s1 s2))) (listen s)))) nil) (deftest make-concatenated-stream.32 (clear-input (make-concatenated-stream)) nil) (deftest make-concatenated-stream.33 (with-input-from-string (s1 "abc") (clear-input (make-concatenated-stream s1))) nil) ;;; Error cases (deftest make-concatenated-stream.error.1 (loop for x in *mini-universe* unless (or (and (streamp x) (input-stream-p x)) (eval `(signals-error (make-concatenated-stream ',x) t))) collect x) nil) (deftest make-concatenated-stream.error.2 (loop for x in *streams* unless (or (and (streamp x) (input-stream-p x)) (eval `(signals-error (make-concatenated-stream ',x) t))) collect x) nil) gcl-2.6.14/ansi-tests/packages-11.lsp0000644000175000017500000000652214360276512015607 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:19 1998 ;;;; Contains: Package test code, part 11 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unexport (deftest unexport.1 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p)) (i 0) x y) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (progn (setf x (incf i)) sym1) (progn (setf y (incf i)) p)) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt r t) (eql i 2) (eql x 1) (eql y 2) (eqt sym1 sym2) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) (deftest unexport.2 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) "X") (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt sym1 sym2) (eqt r t) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) (deftest unexport.3 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r1 (export (intern "X" p) p)) (r2 (export (intern "Y" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (multiple-value-bind* (sym1a access1a) (find-symbol "Y" p) (unexport (list sym1 sym1a) '#:|X|) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (multiple-value-bind* (sym2a access2a) (find-symbol "Y" p) (and (eqt sym1 sym2) (eqt sym1a sym2a) (eqt r1 t) (eqt r2 t) (eqt access1 :external) (eqt access2 :internal) (eqt access1a :external) (eqt access2a :internal) (equal (symbol-name sym1) "X") (equal (symbol-name sym1a) "Y") t))))))) t) (deftest unexport.4 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) #\X) (multiple-value-bind* (sym2 access2) (find-symbol "X" p) (and (eqt sym1 sym2) (eqt r t) (eqt access1 :external) (eqt access2 :internal) (equal (symbol-name sym1) "X") t))))) t) ;; Check that it signals a package error when unexporting ;; an inaccessible symbol (deftest unexport.5 (classify-error (progn (when (find-package "X") (delete-package "X")) (unexport 'a (make-package "X" :use nil)) nil)) package-error) ;; Check that internal symbols are left alone (deftest unexport.6 (progn (when (find-package "X") (delete-package "X")) (let ((p (make-package "X" :use nil))) (let* ((sym (intern "FOO" p)) (r (unexport sym p))) (multiple-value-bind* (sym2 access) (find-symbol "FOO" p) (and (eqt r t) (eqt access :internal) (eqt sym sym2) (equal (symbol-name sym) "FOO") t))))) t) (deftest unexport.error.1 (classify-error (unexport)) program-error) (deftest unexport.error.2 (classify-error (unexport 'xyz "CL-TEST" nil)) program-error) gcl-2.6.14/ansi-tests/write-sequence.lsp0000644000175000017500000001677314360276512016563 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 21 04:07:58 2004 ;;;; Contains: Tests of WRITE-SEQUENCE (in-package :cl-test) (defmacro def-write-sequence-test (name input args &rest expected) `(deftest ,name (let ((s ,input)) (with-output-to-string (os) (assert (eq (write-sequence s os ,@args) s)))) ,@expected)) ;;; on strings (def-write-sequence-test write-sequence.string.1 "abcde" () "abcde") (def-write-sequence-test write-sequence.string.2 "abcde" (:start 1) "bcde") (def-write-sequence-test write-sequence.string.3 "abcde" (:end 3) "abc") (def-write-sequence-test write-sequence.string.4 "abcde" (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.string.5 "abcde" (:end nil) "abcde") (def-write-sequence-test write-sequence.string.6 "abcde" (:start 3 :end 3) "") (def-write-sequence-test write-sequence.string.7 "abcde" (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.string.8 "abcde" (:allow-other-keys nil) "abcde") (def-write-sequence-test write-sequence.string.9 "abcde" (:allow-other-keys t :foo nil) "abcde") (def-write-sequence-test write-sequence.string.10 "abcde" (:allow-other-keys t :allow-other-keys nil :foo nil) "abcde") (def-write-sequence-test write-sequence.string.11 "abcde" (:bar 'x :allow-other-keys t) "abcde") (def-write-sequence-test write-sequence.string.12 "abcde" (:start 1 :end 4 :start 2 :end 3) "bcd") (def-write-sequence-test write-sequence.string.13 "" () "") (defmacro def-write-sequence-special-test (name string args expected) `(deftest ,name (let ((str ,string) (expected ,expected)) (do-special-strings (s str nil) (let ((out (with-output-to-string (os) (assert (eq (write-sequence s os ,@args) s))))) (assert (equal out expected))))) nil)) (def-write-sequence-special-test write-sequence.string.14 "12345" () "12345") (def-write-sequence-special-test write-sequence.string.15 "12345" (:start 1 :end 3) "23") ;;; on lists (def-write-sequence-test write-sequence.list.1 (coerce "abcde" 'list) () "abcde") (def-write-sequence-test write-sequence.list.2 (coerce "abcde" 'list) (:start 1) "bcde") (def-write-sequence-test write-sequence.list.3 (coerce "abcde" 'list) (:end 3) "abc") (def-write-sequence-test write-sequence.list.4 (coerce "abcde" 'list) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.list.5 (coerce "abcde" 'list) (:end nil) "abcde") (def-write-sequence-test write-sequence.list.6 (coerce "abcde" 'list) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.list.7 (coerce "abcde" 'list) (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.list.8 () () "") ;;; on vectors (def-write-sequence-test write-sequence.simple-vector.1 (coerce "abcde" 'simple-vector) () "abcde") (def-write-sequence-test write-sequence.simple-vector.2 (coerce "abcde" 'simple-vector) (:start 1) "bcde") (def-write-sequence-test write-sequence.simple-vector.3 (coerce "abcde" 'simple-vector) (:end 3) "abc") (def-write-sequence-test write-sequence.simple-vector.4 (coerce "abcde" 'simple-vector) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.simple-vector.5 (coerce "abcde" 'simple-vector) (:end nil) "abcde") (def-write-sequence-test write-sequence.simple-vector.6 (coerce "abcde" 'simple-vector) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.simple-vector.7 (coerce "abcde" 'simple-vector) (:end nil :start 1) "bcde") (def-write-sequence-test write-sequence.simple-vector.8 #() () "") ;;; on vectors with fill pointers (def-write-sequence-test write-sequence.fill-vector.1 (make-array 10 :initial-contents "abcde " :fill-pointer 5) () "abcde") (def-write-sequence-test write-sequence.fill-vector.2 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 1) "bcde") (def-write-sequence-test write-sequence.fill-vector.3 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end 3) "abc") (def-write-sequence-test write-sequence.fill-vector.4 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 1 :end 4) "bcd") (def-write-sequence-test write-sequence.fill-vector.5 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end nil) "abcde") (def-write-sequence-test write-sequence.fill-vector.6 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:start 3 :end 3) "") (def-write-sequence-test write-sequence.fill-vector.7 (make-array 10 :initial-contents "abcde " :fill-pointer 5) (:end nil :start 1) "bcde") ;;; on bit vectors (defmacro def-write-sequence-bv-test (name input args expected) `(deftest ,name (let ((s ,input) (expected ,expected)) (with-open-file (os "tmp.dat" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (assert (eq (write-sequence s os ,@args) s))) (with-open-file (is "tmp.dat" :direction :input :element-type '(unsigned-byte 8)) (loop for i from 0 below (length expected) for e = (elt expected i) always (eql (read-byte is) e)))) t)) (def-write-sequence-bv-test write-sequence.bv.1 #*00111010 () #*00111010) (def-write-sequence-bv-test write-sequence.bv.2 #*00111010 (:start 1) #*0111010) (def-write-sequence-bv-test write-sequence.bv.3 #*00111010 (:end 5) #*00111) (def-write-sequence-bv-test write-sequence.bv.4 #*00111010 (:start 1 :end 6) #*01110) (def-write-sequence-bv-test write-sequence.bv.5 #*00111010 (:start 1 :end nil) #*0111010) (def-write-sequence-bv-test write-sequence.bv.6 #*00111010 (:start 1 :end nil :end 4) #*0111010) ;;; Error tests (deftest write-sequence.error.1 (signals-error (write-sequence) program-error) t) (deftest write-sequence.error.2 (signals-error (write-sequence "abcde") program-error) t) (deftest write-sequence.error.3 (signals-error (write-sequence '(#\a . #\b) *standard-output*) type-error) t) (deftest write-sequence.error.4 (signals-error (write-sequence #\a *standard-output*) type-error) t) (deftest write-sequence.error.5 (signals-error (write-sequence "ABC" *standard-output* :start -1) type-error) t) (deftest write-sequence.error.6 (signals-error (write-sequence "ABC" *standard-output* :start 'x) type-error) t) (deftest write-sequence.error.7 (signals-error (write-sequence "ABC" *standard-output* :start 0.0) type-error) t) (deftest write-sequence.error.8 (signals-error (write-sequence "ABC" *standard-output* :end -1) type-error) t) (deftest write-sequence.error.9 (signals-error (write-sequence "ABC" *standard-output* :end 'x) type-error) t) (deftest write-sequence.error.10 (signals-error (write-sequence "ABC" *standard-output* :end 2.0) type-error) t) (deftest write-sequence.error.11 (signals-error (write-sequence "abcde" *standard-output* :foo nil) program-error) t) (deftest write-sequence.error.12 (signals-error (write-sequence "abcde" *standard-output* :allow-other-keys nil :foo t) program-error) t) (deftest write-sequence.error.13 (signals-error (write-sequence "abcde" *standard-output* :start) program-error) t) (deftest write-sequence.error.14 (check-type-error #'(lambda (x) (write-sequence x *standard-output*)) #'sequencep) nil) (deftest write-sequence.error.15 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* :start x)) (typef 'unsigned-byte)) nil) (deftest write-sequence.error.16 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* :end x)) (typef '(or null unsigned-byte))) nil) gcl-2.6.14/ansi-tests/directory.lsp0000644000175000017500000000311114360276512015605 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 1 12:00:18 2004 ;;;; Contains: Tests of DIRECTORY (in-package :cl-test) (deftest directory.1 (directory "nonexistent") nil) (deftest directory.2 (directory #p"nonexistent") nil) (deftest directory.3 (directory "nonexistent" :allow-other-keys nil) nil) (deftest directory.4 (directory "nonexistent" :allow-other-keys t :foo 'bar) nil) (deftest directory.5 (directory "nonexistent" :foo 0 :allow-other-keys t) nil) (deftest directory.6 (let* ((pattern-pathname (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) (pathnames (directory pattern-pathname))) (values (remove-if #'pathnamep pathnames) (loop for pn in pathnames unless (equal pn (truename pn)) collect pn) ;; (loop for pn in pathnames ;; unless (pathname-match-p pn pattern-pathname) ;; collect pn)) )) nil nil ;; nil ) (deftest directory.7 (let* ((pattern-pathname (make-pathname :name :wild :type :wild :defaults *default-pathname-defaults*)) (pathnames (directory pattern-pathname))) (loop for pn in pathnames unless (equal pn (probe-file pn)) collect pn)) nil) (deftest directory.8 (let* ((pathname-pattern "CLTEST:*.*") (len (length (directory pathname-pattern)))) (if (< len 300) len nil)) nil) ;;; Specialized string tests (deftest directory.9 (do-special-strings (s "nonexistent" nil) (assert (null (directory s)))) nil) ;;; Error tests (deftest directory.error.1 (signals-error (directory) program-error) t) gcl-2.6.14/ansi-tests/prog2.lsp0000644000175000017500000000105014360276512014632 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:40:51 2002 ;;;; Contains: Tests for PROG2 (in-package :cl-test) (deftest prog2.1 (prog2 'a 'b) b) (deftest prog2.2 (prog2 'a 'b 'c) b) (deftest prog2.3 (prog2 'a (values) 'c) nil) (deftest prog2.4 (prog2 'a (values 'b 'd) 'c) b) (deftest prog2.5 (let ((x 0)) (values (prog2 (incf x) (incf x) (incf x)) x)) 2 3) (deftest prog2.6 (let ((x 1)) (values (prog2 (incf x (1+ x)) (incf x (+ 2 x)) (incf x 100)) x)) 8 108) gcl-2.6.14/ansi-tests/make-pathname.lsp0000644000175000017500000001043514360276512016320 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 05:54:30 2003 ;;;; Contains: Tests of MAKE-PATHNAME (in-package :cl-test) (defvar *null-pathname* (make-pathname)) (defun make-pathname-test (&rest args &key (defaults nil) (host (if defaults (pathname-host defaults) (pathname-host *default-pathname-defaults*))) (device (if defaults (pathname-device defaults) (pathname-device *null-pathname*))) (directory (if defaults (pathname-directory defaults) (pathname-directory *null-pathname*))) (name (if defaults (pathname-name defaults) (pathname-name *null-pathname*))) (type (if defaults (pathname-type defaults) (pathname-type *null-pathname*))) (version (if defaults (pathname-version defaults) (pathname-version *null-pathname*))) case) (declare (ignorable case)) (let* ((vals (multiple-value-list (apply #'make-pathname args))) (pn (first vals))) (and (= (length vals) 1) (typep pn 'pathname) (equalp (pathname-host pn) host) (equalp (pathname-device pn) device) ;; (equalp (pathname-directory pn) directory) (let ((pnd (pathname-directory pn))) (if (eq directory :wild) (member pnd '((:absolute :wild-inferiors) (:absolute :wild)) :test #'equal) (equalp pnd directory))) (equalp (pathname-name pn) name) (equalp (pathname-type pn) type) (equalp (pathname-version pn) version) t))) (deftest make-pathname.1 (make-pathname-test) t) (deftest make-pathname.2 (make-pathname-test :name "foo") t) (deftest make-pathname.2a (do-special-strings (s "foo") (assert (make-pathname-test :name s))) nil) (deftest make-pathname.3 (make-pathname-test :name "foo" :type "txt") t) (deftest make-pathname.3a (do-special-strings (s "txt") (assert (make-pathname-test :name "foo" :type s))) nil) (deftest make-pathname.4 (make-pathname-test :type "lsp") t) (deftest make-pathname.5 (make-pathname-test :directory :wild) t) (deftest make-pathname.6 (make-pathname-test :name :wild) t) (deftest make-pathname.7 (make-pathname-test :type :wild) t) (deftest make-pathname.8 (make-pathname-test :version :wild) t) (deftest make-pathname.9 (make-pathname-test :defaults *default-pathname-defaults*) t) (deftest make-pathname.10 (make-pathname-test :defaults (make-pathname :name "foo" :type "bar")) t) (deftest make-pathname.11 (make-pathname-test :version :newest) t) (deftest make-pathname.12 (make-pathname-test :case :local) t) (deftest make-pathname.13 (make-pathname-test :case :common) t) (deftest make-pathname.14 (let ((*default-pathname-defaults* (make-pathname :name "foo" :type "lsp" :version :newest))) (make-pathname-test)) t) ;;; Works on the components of actual pathnames (deftest make-pathname.rebuild (loop for p in *pathnames* for host = (pathname-host p) for device = (pathname-device p) for directory = (pathname-directory p) for name = (pathname-name p) for type = (pathname-type p) for version = (pathname-version p) for p2 = (make-pathname :host host :device device :directory directory :name name :type type :version version) unless (equal p p2) collect (list p p2)) nil) ;;; Various constraints on :directory (deftest make-pathname-error-absolute-up (signals-error (directory (make-pathname :directory '(:absolute :up))) file-error) t) (deftest make-pathname-error-absolute-back (signals-error (directory (make-pathname :directory '(:absolute :back))) file-error) t) ;; The next test is correct, but was causing very large amounts of time to be spent ;; in buggy implementations ;;#| (deftest make-pathname-error-absolute-wild-inferiors-up (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up))) file-error) t) ;;|# (deftest make-pathname-error-relative-wild-inferiors-up (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up)))) file-error) t) (deftest make-pathname-error-absolute-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back))) file-error) t) (deftest make-pathname-error-relative-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back))) file-error) t) gcl-2.6.14/ansi-tests/write-line.lsp0000644000175000017500000000747114360276512015675 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 19 06:49:26 2004 ;;;; Contains: Tests of WRITE-LINE (in-package :cl-test) (deftest write-line.1 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line "")))) result)) #.(string #\Newline) ("")) (deftest write-line.2 :notes (:nil-vectors-are-strings) (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line (make-array '(0) :element-type nil))))) result)) #.(string #\Newline) ("")) (deftest write-line.3 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (write-line "abcde")))) result)) #.(concatenate 'string "abcde" (string #\Newline)) ("abcde")) (deftest write-line.4 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1)))) result)) #.(concatenate 'string "bcde" (string #\Newline)) ("abcde")) (deftest write-line.5 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1 :end 3)))) result)) #.(concatenate 'string "bc" (string #\Newline)) ("abcde")) (deftest write-line.6 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :start 1 :end nil)))) result)) #.(concatenate 'string "bcde" (string #\Newline)) ("abcde")) (deftest write-line.7 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.8 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :allow-other-keys nil)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.9 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.10 (let (result) (values (with-output-to-string (s) (setq result (multiple-value-list (write-line "abcde" s :end 3 :end 2)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) (deftest write-line.11 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-line "951" t) (close *terminal-io*)))) #.(concatenate 'string "951" (string #\Newline))) (deftest write-line.12 (with-output-to-string (*standard-output*) (write-line "-=|!" nil)) #.(concatenate 'string "-=|!" (string #\Newline))) ;;; Specialized string tests (deftest write-line.13 (do-special-strings (s "abcde" nil) (assert (equal (with-output-to-string (*standard-output*) (multiple-value-list (write-line "abcde"))) #.(concatenate 'string "abcde" (string #\Newline))))) nil) ;;; Error tests (deftest write-line.error.1 (signals-error (write-line) program-error) t) (deftest write-line.error.2 (signals-error (write-line "" *standard-output* :start) program-error) t) (deftest write-line.error.3 (signals-error (write-line "" *standard-output* :foo nil) program-error) t) (deftest write-line.error.4 (signals-error (write-line "" *standard-output* :allow-other-keys nil :foo nil) program-error) t) gcl-2.6.14/ansi-tests/length.lsp0000644000175000017500000000462414360276512015074 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 23:25:29 2002 ;;;; Contains: Test cases for LENGTH (in-package :cl-test) (deftest length-list.1 (length nil) 0) (deftest length-list.2 (length '(a b c d e)) 5) (deftest length-list.3 (length (make-list 200000)) 200000) (defun length-list-4-body () (let ((x ())) (loop for i from 0 to 999 do (progn (unless (eql (length x) i) (return nil)) (push i x)) finally (return t)))) (deftest length-list-4 (length-list-4-body) t) (deftest length-vector.1 (length #()) 0) (deftest length-vector.2 (length #(a)) 1) (deftest length-vector.3 (length #(a b)) 2) (deftest length-vector.4 (length #(a b c)) 3) (deftest length-nonsimple-vector.1 (length (make-array 10 :fill-pointer t :adjustable t)) 10) (deftest length-nonsimple-vector.2 (let ((a (make-array 10 :fill-pointer t :adjustable t))) (setf (fill-pointer a) 5) (length a)) 5) (deftest length-bitstring.1 (length #*) 0) (deftest length-bitstring.2 (length #*1) 1) (deftest length-bitstring.3 (length #*0) 1) (deftest length-bitstring.4 (length #*010101) 6) (deftest length-string.1 (length "") 0) (deftest length-string.2 (length "a") 1) (deftest length-string.3 (length "abcdefghijklm") 13) (deftest length-string.4 (length "\") 1) ;;; Error cases (deftest length.error.1 (classify-error (length 'a)) type-error) (deftest length.error.2 (classify-error (length 10)) type-error) (deftest length.error.3 (classify-error (length 1.0)) type-error) (deftest length.error.4 (classify-error (length #\a)) type-error) (deftest length.error.5 (classify-error (length 10/3)) type-error) (deftest length.error.6 (classify-error (length)) program-error) (deftest length.error.7 (classify-error (length nil nil)) program-error) (deftest length.error.8 (classify-error (locally (length 'a) t)) type-error) ;;; Length on vectors created with make-array (deftest array-length-1 (length (make-array '(20))) 20) (deftest array-length-2 (length (make-array '(100001))) 100001) (deftest array-length-3 (length (make-array '(0))) 0) (deftest array-length-4 (let ((x (make-array '(100) :fill-pointer 10))) (length x)) 10) (deftest array-length-5 (let ((x (make-array '(100) :fill-pointer 10))) (setf (fill-pointer x) 20) (length x)) 20) gcl-2.6.14/ansi-tests/bit-vector.lsp0000644000175000017500000000424414360276512015667 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:03:22 2003 ;;;; Contains: Tests of type BIT-VECTOR (in-package :cl-test) (deftest bit-vector.1 (notnot-mv (find-class 'bit-vector)) t) (deftest bit-vector.2 (notnot-mv (typep #* 'bit-vector)) t) (deftest bit-vector.3 (notnot-mv (typep #*00101 'bit-vector)) t) (deftest bit-vector.4 (typep #(0 1 1 1 0 0) 'bit-vector) nil) (deftest bit-vector.5 (typep "011100" 'bit-vector) nil) (deftest bit-vector.6 (typep 0 'bit-vector) nil) (deftest bit-vector.7 (typep 1 'bit-vector) nil) (deftest bit-vector.8 (typep nil 'bit-vector) nil) (deftest bit-vector.9 (typep 'x 'bit-vector) nil) (deftest bit-vector.10 (typep '(0 1 1 0) 'bit-vector) nil) (deftest bit-vector.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) 'bit-vector) nil) (deftest bit-vector.12 (notnot-mv (typep #* '(bit-vector *))) t) (deftest bit-vector.13 (notnot-mv (typep #*01101 '(bit-vector *))) t) (deftest bit-vector.14 (notnot-mv (typep #* '(bit-vector 0))) t) (deftest bit-vector.15 (typep #*01101 '(bit-vector 0)) nil) (deftest bit-vector.16 (typep #* '(bit-vector 5)) nil) (deftest bit-vector.17 (notnot-mv (typep #*01101 '(bit-vector 5))) t) ;;; Tests of typep on the class named bit-vector (deftest bit-vector.class.2 (notnot-mv (typep #* (find-class 'bit-vector))) t) (deftest bit-vector.class.3 (notnot-mv (typep #*00101 (find-class 'bit-vector))) t) (deftest bit-vector.class.4 (typep #(0 1 1 1 0 0) (find-class 'bit-vector)) nil) (deftest bit-vector.class.5 (typep "011100" (find-class 'bit-vector)) nil) (deftest bit-vector.class.6 (typep 0 (find-class 'bit-vector)) nil) (deftest bit-vector.class.7 (typep 1 (find-class 'bit-vector)) nil) (deftest bit-vector.class.8 (typep nil (find-class 'bit-vector)) nil) (deftest bit-vector.class.9 (typep 'x (find-class 'bit-vector)) nil) (deftest bit-vector.class.10 (typep '(0 1 1 0) (find-class 'bit-vector)) nil) (deftest bit-vector.class.11 (typep (make-array '(2 2) :element-type 'bit :initial-element 0) (find-class 'bit-vector)) nil) gcl-2.6.14/ansi-tests/compiled-function-p.lsp0000644000175000017500000000162414360276512017464 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:32:44 2003 ;;;; Contains: Tests of COMPILED-FUNCTION-P (in-package :cl-test) (deftest compiled-function-p.1 (some #'(lambda (obj) (if (check-values (compiled-function-p obj)) (not (typep obj 'compiled-function)) (typep obj 'compiled-function))) *universe*) nil) (deftest compiled-function-p.2 (compiled-function-p '(lambda (x y) (cons y x))) nil) (deftest compiled-function-p.3 (notnot-mv (compiled-function-p (compile nil '(lambda (y x) (cons x y))))) t) (deftest compiled-function-p.order.1 (let ((i 0)) (values (compiled-function-p (progn (incf i) '(lambda () nil))) i)) nil 1) (deftest compiled-function-p.error.1 (classify-error (compiled-function-p)) program-error) (deftest compiled-function-p.error.2 (classify-error (compiled-function-p nil nil)) program-error) gcl-2.6.14/ansi-tests/elt.lsp0000644000175000017500000001762614360276512014405 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 19:38:29 2002 ;;;; Contains: Tests of ELT (in-package :cl-test) (declaim (optimize (safety 3))) ;; elt on lists (deftest elt.1 (classify-error (elt nil 0)) type-error) (deftest elt.1a (classify-error (elt nil -10)) type-error) (deftest elt.1b (classify-error (locally (elt nil 0) t)) type-error) (deftest elt.2 (classify-error (elt nil 1000000)) type-error) (deftest elt.3 (elt '(a b c d e) 0) a) (deftest elt.4 (elt '(a b c d e) 2) c) (deftest elt.5 (elt '(a b c d e) 4) e) (deftest elt.5a (classify-error (elt '(a b c d e) -4)) type-error) (deftest elt.6 (let ((x (make-int-list 1000))) (notnot-mv (every #'(lambda (i) (eql i (elt x i))) x))) t) (deftest elt.7 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 0) 'e))) (list x y)) ((e b c d) e)) (deftest elt.8 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 1) 'e))) (list x y)) ((a e c d) e)) (deftest elt.9 (let* ((x (list 'a 'b 'c 'd)) (y (setf (elt x 3) 'e))) (list x y)) ((a b c e) e)) (deftest elt.10 (classify-error (let ((x (list 'a 'b 'c))) (setf (elt x 4) 'd))) type-error) (deftest elt.11 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (loop for c on x collect c))) (setf (elt x 2) 'f) (notnot-mv (every #'eq y (loop for c on x collect c))))) t) (deftest elt.12 (let ((x (make-int-list 100000))) (elt x 90000)) 90000) (deftest elt.13 (let ((x (make-int-list 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) (deftest elt.14 (classify-error (let ((x (list 'a 'b 'c))) (elt x 10))) type-error) (deftest elt.15 (classify-error (let ((x (list 'a 'b 'c))) (elt x 'a))) type-error) (deftest elt.16 (classify-error (let ((x (list 'a 'b 'c))) (elt x 10.0))) type-error) (deftest elt.17 (classify-error (let ((x (list 'a 'b 'c))) (elt x -1))) type-error) (deftest elt.18 (classify-error (let ((x (list 'a 'b 'c))) (elt x -100000000000000000))) type-error) (deftest elt.19 (classify-error (let ((x (list 'a 'b 'c))) (elt x #\w))) type-error) (deftest elt.order.1 (let ((i 0) x y) (values (elt (progn (setf x (incf i)) '(a b c d e)) (progn (setf y (incf i)) 3)) i x y)) d 2 1 2) (deftest elt.order.2 (let ((i 0) x y z) (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e)))) (values (setf (elt (aref a (progn (setf x (incf i)) 0)) (progn (setf y (incf i)) 3)) (progn (setf z (incf i)) 'k)) (aref a 0) i x y z))) k (a b c k e) 3 1 2 3) (deftest elt-v.1 (classify-error (elt (make-array '(0)) 0)) type-error) ;; (deftest elt-v.2 (elt (make-array '(1)) 0) nil) ;; actually undefined (deftest elt-v.3 (elt (make-array '(5) :initial-contents '(a b c d e)) 0) a) (deftest elt-v.4 (elt (make-array '(5) :initial-contents '(a b c d e)) 2) c) (deftest elt-v.5 (elt (make-array '(5) :initial-contents '(a b c d e)) 4) e) (deftest elt-v.6 (elt-v-6-body) t) (deftest elt-v.7 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-v.8 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-v.9 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) (deftest elt-v.10 (classify-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd))) type-error) (deftest elt-v.11 (classify-error (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd))) type-error) (deftest elt-v.12 (let ((x (make-int-array 100000))) (elt x 90000)) 90000) (deftest elt-v.13 (let ((x (make-int-array 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) ;;; Adjustable arrays (deftest elt-adj-array.1 (classify-error (elt (make-adj-array '(0)) 0)) type-error) ;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined (deftest elt-adj-array.3 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) a) (deftest elt-adj-array.4 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2) c) (deftest elt-adj-array.5 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4) e) (deftest elt-adj-array.6 (elt-adj-array-6-body) t) (deftest elt-adj-array.7 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-adj-array.8 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-adj-array.9 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) (deftest elt-adj-array.10 (classify-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x 4) 'd))) type-error) (deftest elt-adj-array.11 (classify-error (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) (setf (elt x -100) 'd))) type-error) (deftest elt-adj-array.12 (let ((x (make-int-array 100000 #'make-adj-array))) (elt x 90000)) 90000) (deftest elt-adj-array.13 (let ((x (make-int-array 100000 #'make-adj-array))) (setf (elt x 80000) 'foo) (list (elt x 79999) (elt x 80000) (elt x 80001))) (79999 foo 80001)) ;; displaced arrays (deftest elt-displaced-array.1 (classify-error (elt (make-displaced-array '(0) 100) 0)) type-error) (deftest elt-displaced-array.2 (elt (make-displaced-array '(1) 100) 0) 100) (deftest elt-displaced-array.3 (elt (make-displaced-array '(5) 100) 4) 104) ;;; Arrays with fill points (deftest elt-fill-pointer.1 (let ((a (make-array '(5) :initial-contents '(a b c d e) :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) a b c) (deftest elt-fill-pointer.2 (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) 0 0 1) (deftest elt-fill-pointer.3 (classify-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.4 (classify-error (let ((a (make-array '(5) :initial-contents '(0 0 1 0 0) :element-type 'bit :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.5 (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.6 (classify-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'character :fill-pointer 3))) (elt a 4))) type-error) (deftest elt-fill-pointer.7 (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'base-char :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.8 (classify-error (let ((a (make-array '(5) :initial-contents '(#\a #\b #\c #\d #\e) :element-type 'base-char :fill-pointer 3))) (elt a 4))) type-error) (deftest elt.error.1 (classify-error (elt)) program-error) (deftest elt.error.2 (classify-error (elt nil)) program-error) (deftest elt.error.3 (classify-error (elt nil 0 nil)) program-error) gcl-2.6.14/ansi-tests/with-input-from-string.lsp0000644000175000017500000001321514360276512020164 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 20:13:02 2004 ;;;; Contains: Tests of WITH-INPUT-FROM-STRING (in-package :cl-test) (deftest with-input-from-string.1 (with-input-from-string (s "abc") (values (read-char s) (read-char s) (read-char s) (read-char s nil :eof))) #\a #\b #\c :eof) (deftest with-input-from-string.2 (with-input-from-string (s "abc")) nil) (deftest with-input-from-string.3 (with-input-from-string (s "abc") (declare (optimize speed))) nil) (deftest with-input-from-string.3a (with-input-from-string (s "abc") (declare (optimize speed)) (declare (optimize space))) nil) (deftest with-input-from-string.4 (with-input-from-string (s "abc") (declare (optimize safety)) (read-char s) (read-char s)) #\b) (deftest with-input-from-string.5 (let ((i nil)) (values (with-input-from-string (s "abc" :index i)) i)) nil 0) (deftest with-input-from-string.6 (let ((i (list nil))) (values (with-input-from-string (s "abc" :index (car i))) i)) nil (0)) (deftest with-input-from-string.7 (let ((i nil)) (values (with-input-from-string (s "abc" :index i) (list i (read-char s) i (read-char s) i)) i)) (nil #\a nil #\b nil) 2) (deftest with-input-from-string.9 (with-input-from-string (s "abc") (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t t nil) (deftest with-input-from-string.10 :notes (:nil-vectors-are-strings) (with-input-from-string (s (make-array 0 :element-type nil)) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s))) t t t t nil) (deftest with-input-from-string.11 (with-input-from-string (s (make-array 3 :element-type 'character :initial-contents "abc")) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.12 (with-input-from-string (s (make-array 3 :element-type 'base-char :initial-contents "abc")) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.13 (with-input-from-string (s "abcdef" :start 2) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "cdef") (deftest with-input-from-string.14 (with-input-from-string (s "abcdef" :end 3) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "abc") (deftest with-input-from-string.15 (with-input-from-string (s "abcdef" :start 1 :end 5) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "bcde") (deftest with-input-from-string.16 (with-input-from-string (s "abcdef" :start 1 :end nil) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) (notnot (open-stream-p s)) (notnot (input-stream-p s)) (output-stream-p s) (read-line s))) t t t t nil "bcdef") (deftest with-input-from-string.17 (let ((i 2)) (values (with-input-from-string (s "abcdef" :index i :start i) (read-char s)) i)) #\c 3) ;;; Test that there is no implicit tagbody (deftest with-input-from-string.18 (block done (tagbody (with-input-from-string (s "abc") (go 1) 1 (return-from done :bad)) 1 (return-from done :good))) :good) ;;; Free declaration scope (deftest with-input-from-string.19 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s (return-from done x)) (declare (special x)))))) :good) (deftest with-input-from-string.20 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s "abc" :start (return-from done x)) (declare (special x)))))) :good) (deftest with-input-from-string.21 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-input-from-string (s "abc" :end (return-from done x)) (declare (special x)))))) :good) ;;; index is not updated if the form exits abnormally (deftest with-input-from-string.22 (let ((i nil)) (values (block done (with-input-from-string (s "abcde" :index i) (return-from done (read-char s)))) i)) #\a nil) ;;; Test that explicit calls to macroexpand in subforms ;;; are done in the correct environment (deftest with-input-from-string.23 (macrolet ((%m (z) z)) (with-input-from-string (s (expand-in-current-env (%m "123"))) (read-char s))) #\1) (deftest with-input-from-string.24 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start (expand-in-current-env (%m 1))) (read-char s))) #\2) (deftest with-input-from-string.25 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start 0 :end (expand-in-current-env (%m 0))) (read-char s nil nil))) nil) ;;; FIXME: Add more tests on specialized strings. gcl-2.6.14/ansi-tests/makefile0000644000175000017500000000056614360276512014574 0ustar cammcamm-include ../makedefs test-unixport: echo "(load \"gclload.lsp\")" | ../unixport/saved_ansi_gcl$(EXE) | tee test.out test: echo "(load \"gclload.lsp\")" | gcl | tee test.out clean: rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl rm -f foo.txt temp.dat file-that-was-renamed.txt tmp.dat tmp.dat.BAK tmp2.dat rm -rf scratch tmp.txt foo.lsp 'CLTEST:foo.txt' gcl-2.6.14/ansi-tests/load-types-and-class.lsp0000644000175000017500000000056514360276512017537 0ustar cammcamm;;; Tests of types and classes (load "types-and-class.lsp") (load "types-and-class-2.lsp") (load "coerce.lsp") (load "subtypep.lsp") (load "subtypep-integer.lsp") (load "subtypep-float.lsp") (load "subtypep-rational.lsp") (load "subtypep-real.lsp") #-lispworks (load "subtypep-cons.lsp") (load "subtypep-member.lsp") (load "subtypep-eql.lsp") (load "subtypep-array.lsp") gcl-2.6.14/ansi-tests/arrayp.lsp0000644000175000017500000000163014360276512015103 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:08:21 2003 ;;;; Contains: Tests of ARRAYP (in-package :cl-test) ;;; Also tested by make-array.lsp (deftest arrayp.1 (notnot-mv (arrayp #(a b c))) t) (deftest arrayp.2 (notnot-mv (arrayp "abcd")) t) (deftest arrayp.3 (notnot-mv (arrayp #*001110101)) t) (deftest arrayp.4 (notnot-mv (arrayp #0aNIL)) t) (deftest arrayp.5 (notnot-mv (arrayp #2a((1 2 3)(4 5 6)))) t) (deftest arrayp.6 (loop for e in *universe* for a = (arrayp e) for b = (typep e 'array) when (or (and a (not b)) (and b (not a))) collect e) nil) (deftest arrayp.order.1 (let ((i 0) a) (values (arrayp (progn (setf a (incf i)) nil)) i a)) nil 1 1) ;;; Error tests (deftest arrayp.error.1 (classify-error (arrayp)) program-error) (deftest arrayp.error.2 (classify-error (arrayp #(a b c) nil)) program-error) gcl-2.6.14/ansi-tests/stable-sort.lsp0000644000175000017500000000741214360276512016050 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Aug 28 21:00:44 2002 ;;;; Contains: Tests for STABLE-SORT (in-package :cl-test) (deftest stable-sort-list.1 (let ((a (list 1 4 2 5 3))) (stable-sort a #'<)) (1 2 3 4 5)) (deftest stable-sort-list.2 (let ((a (list 1 4 2 5 3))) (stable-sort a #'< :key #'-)) (5 4 3 2 1)) (deftest stable-sort-list.3 (let ((a (list 1 4 2 5 3))) (stable-sort a #'(lambda (x y) nil)) (stable-sort a #'<)) (1 2 3 4 5)) (deftest stable-sort-list.4 (let ((a (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c))))) (stable-sort a #'(lambda (x y) (< (car x) (car y))))) ((1 a) (1 b) (1 c) (2 a) (2 b) (2 c))) (deftest stable-sort-list.5 (let ((a (reverse (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c)))))) (stable-sort a #'(lambda (x y) (< (car x) (car y))))) ((1 c) (1 b) (1 a) (2 c) (2 b) (2 a))) (deftest stable-sort-vector.1 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'<)) #(1 2 3 4 5)) (deftest stable-sort-vector.2 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'< :key #'-)) #(5 4 3 2 1)) (deftest stable-sort-vector.3 (let ((a (copy-seq #(1 4 2 5 3)))) (stable-sort a #'(lambda (x y) nil)) (stable-sort a #'<)) #(1 2 3 4 5)) (deftest stable-sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) :fill-pointer 5))) (stable-sort a #'<)) #(10 20 30 40 50)) (deftest stable-sort-bit-vector.1 (let ((a (copy-seq #*10011101))) (stable-sort a #'<)) #*00011111) (deftest stable-sort-bit-vector.2 (let ((a (copy-seq #*10011101))) (values (stable-sort a #'< :key #'-) a)) #*11111000 #*11111000) (deftest stable-sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) :element-type 'bit :fill-pointer 5))) (stable-sort a #'<)) #*00111) (deftest stable-sort-string.1 (let ((a (copy-seq "10011101"))) (values (stable-sort a #'char<) a)) "00011111" "00011111") (deftest stable-sort-string.2 (let ((a (copy-seq "10011101"))) (values (stable-sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) "11111000" "11111000") (deftest stable-sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" :element-type 'character :fill-pointer 5))) (stable-sort a #'char<)) "00111") ;;; Order of evaluation tests (deftest stable-sort.order.1 (let ((i 0) x y) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) (deftest stable-sort.order.2 (let ((i 0) x y z) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) (progn (setf y (incf i)) #'<) :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) ;;; Error cases (deftest stable-sort.error.1 (classify-error (stable-sort)) program-error) (deftest stable-sort.error.2 (classify-error (stable-sort nil)) program-error) (deftest stable-sort.error.3 (classify-error (stable-sort nil #'< :key)) program-error) (deftest stable-sort.error.4 (classify-error (stable-sort nil #'< 'bad t)) program-error) (deftest stable-sort.error.5 (classify-error (stable-sort nil #'< 'bad t :allow-other-keys nil)) program-error) (deftest stable-sort.error.6 (classify-error (stable-sort nil #'< 1 2)) program-error) (deftest stable-sort.error.7 (classify-error (stable-sort (list 1 2 3 4) #'identity)) program-error) (deftest stable-sort.error.8 (classify-error (stable-sort (list 1 2 3 4) #'< :key #'cons)) program-error) (deftest stable-sort.error.9 (classify-error (stable-sort (list 1 2 3 4) #'< :key #'car)) type-error) (deftest stable-sort.error.10 (classify-error (stable-sort (list 1 2 3 4) #'elt)) type-error) gcl-2.6.14/ansi-tests/define-modify-macro.lsp0000644000175000017500000000346214360276512017430 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 11:42:14 2002 ;;;; Contains: Tests of DEFINE-MODIFY-MACRO (in-package :cl-test) (deftest define-modify-macro.1 (values (eval '(define-modify-macro dmm1-appendf (&rest args) append "Append lists onto a list")) (eval '(let ((u '(p q r)) v) (list (setq v u) (dmm1-appendf u '(a b c d)) (dmm1-appendf u ()) (dmm1-appendf u '(e f g)) u v)))) dmm1-appendf ((p q r) (p q r a b c d) (p q r a b c d) (p q r a b c d e f g) (p q r a b c d e f g) (p q r))) (deftest define-modify-macro.2 (values (eval '(define-modify-macro new-incf (&optional (delta 1)) +)) (eval '(let ((i 10)) (list (new-incf i) (new-incf i 100) i)))) new-incf (11 111 111)) (deftest define-modify-macro.3 (values (eval '(define-modify-macro new-incf1 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) (i 1)) (list (new-incf1 (aref a (incf i))) a i)))) new-incf1 (1 #(0 0 1 0 0) 2)) (deftest define-modify-macro.4 (values (eval '(define-modify-macro new-incf2 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) (i 1)) (list (new-incf2 (aref a (incf i)) (incf i)) a i)))) new-incf2 (3 #(0 0 3 0 0) 3)) ;;; (deftest define-modify-macro.error.1 ;;; (classify-error (define-modify-macro)) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.2 ;;; (classify-error (define-modify-macro dfm-error-1)) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.3 ;;; (classify-error (define-modify-macro dfm-error-2 ())) ;;; program-error) ;;; ;;; (deftest define-modify-macro.error.4 ;;; (classify-error (define-modify-macro dfm-error-2 () nil "Documentation" ;;; "extra illegal argument")) ;;; program-error) gcl-2.6.14/ansi-tests/cons-test-24.lsp0000644000175000017500000001314614360276512015754 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 22:10:54 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 24 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; subsetp (defvar cons-test-24-var '(78 "z" (8 9))) (deftest subsetp.1 (subsetp-with-check (copy-tree '(78)) cons-test-24-var) t) (deftest subsetp.2 (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var) nil) (deftest subsetp.3 (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var :test 'equal) t) (deftest subsetp.4 (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var :test #'equalp) t) (deftest subsetp.5 (subsetp-with-check (list 1) (list 0 2 3 4) :key #'(lambda (i) (floor (/ i 2)))) t) (deftest subsetp.6 (subsetp-with-check (list 1 6) (list 0 2 3 4) :key #'(lambda (i) (floor (/ i 2)))) nil) (deftest subsetp.7 (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo)) :key #'car) t) (deftest subsetp.8 (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) (copy-tree '((z . c) (a . y) (b . 100) (e . f) (c . foo))) :key 'car) t) (deftest subsetp.9 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) (eqt e1 (car e2)))) t) (deftest subsetp.10 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) (eqt e1 (car e2))) :key nil) t) (deftest subsetp.11 (subsetp-with-check (list 'a 'b 'c) (copy-tree (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test-not #'(lambda (e1 e2) (not (eqt e1 (car e2))))) t) ;; Check that it maintains order of arguments (deftest subsetp.12 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) t))) t) (deftest subsetp.13 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) t))) t) (deftest subsetp.14 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) nil))) t) (deftest subsetp.15 (block fail (subsetp-with-check (list 1 2 3) (list 4 5 6) :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) nil))) t) ;;; Order of argument evaluation tests (deftest subsetp.order.1 (let ((i 0) x y) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)))) i x y)) t 2 1 2) (deftest subsetp.order.2 (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) nil))) i x y z w)) t 4 1 2 3 4) (deftest subsetp.order.3 (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) '(a b c)) (progn (setf y (incf i)) '(a b c d)) :key (progn (setf z (incf i)) nil) :test (progn (setf w (incf i)) #'eql))) i x y z w)) t 4 1 2 3 4) ;;; Keyword tests (deftest subsetp.allow-other-keys.1 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67)) t) (deftest subsetp.allow-other-keys.2 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys #'cons :bad t)) t) (deftest subsetp.allow-other-keys.3 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) :allow-other-keys (make-hash-table) :bad t :test #'(lambda (x y) (= (1+ x) y)))) nil) (deftest subsetp.allow-other-keys.4 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t)) t) (deftest subsetp.allow-other-keys.5 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil)) t) (deftest subsetp.allow-other-keys.6 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t :bad1 t :allow-other-keys nil :bad2 t)) t) (deftest subsetp.keywords.7 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) :test #'(lambda (x y) (= (1+ x) y)) :test #'eql)) nil) (deftest subsetp.keywords.8 (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4) :key nil :key #'(lambda (x) (mod x 2)))) nil) ;;; Error tests (deftest subsetp.error.1 (classify-error (subsetp)) program-error) (deftest subsetp.error.2 (classify-error (subsetp nil)) program-error) (deftest subsetp.error.3 (classify-error (subsetp nil nil :bad t)) program-error) (deftest subsetp.error.4 (classify-error (subsetp nil nil :key)) program-error) (deftest subsetp.error.5 (classify-error (subsetp nil nil 1 2)) program-error) (deftest subsetp.error.6 (classify-error (subsetp nil nil :bad t :allow-other-keys nil)) program-error) (deftest subsetp.error.7 (classify-error (subsetp (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest subsetp.error.8 (classify-error (subsetp (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest subsetp.error.9 (classify-error (subsetp (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest subsetp.error.10 (classify-error (subsetp (list 1 2) (list 3 4) :key #'car)) type-error)gcl-2.6.14/ansi-tests/typecase.lsp0000644000175000017500000000232214360276512015421 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 22:51:25 2002 ;;;; Contains: Tests for TYPECASE (in-package :cl-test) (deftest typecase.1 (typecase 1 (integer 'a) (t 'b)) a) (deftest typecase.2 (typecase 1 (symbol 'a)) nil) (deftest typecase.3 (typecase 1 (symbol 'a) (t 'b)) b) (deftest typecase.4 (typecase 1 (t (values)))) (deftest typecase.5 (typecase 1 (integer (values)) (t 'a))) (deftest typecase.6 (typecase 1 (bit 'a) (integer 'b)) a) (deftest typecase.7 (typecase 1 (otherwise 'a)) a) (deftest typecase.8 (typecase 1 (t (values 'a 'b 'c))) a b c) (deftest typecase.9 (typecase 1 (integer (values 'a 'b 'c)) (t nil)) a b c) (deftest typecase.10 (let ((x 0)) (values (typecase 1 (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest typecase.11 (typecase 1 (otherwise 'a)) a) (deftest typecase.12 (typecase 1 (integer) (t 'a)) nil) (deftest typecase.13 (typecase 1 (symbol 'a) (t)) nil) (deftest typecase.14 (typecase 1 (symbol 'a) (otherwise)) nil) (deftest typecase.15 (typecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl-2.6.14/ansi-tests/load-pathnames.lsp0000644000175000017500000000162014360276512016501 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 04:33:05 2003 ;;;; Contains: Load tests for pathnames and logical pathnames (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (load "pathnames.lsp") (load "pathname.lsp") (load "pathnamep.lsp") (load "make-pathname.lsp") (load "pathname-host.lsp") (load "pathname-device.lsp") (load "pathname-directory.lsp") (load "pathname-name.lsp") (load "pathname-type.lsp") (load "pathname-version.lsp") (load "load-logical-pathname-translations.lsp") (load "logical-pathname.lsp") (load "logical-pathname-translations.lsp") (load "translate-logical-pathname.lsp") (load "namestring.lsp") (load "file-namestring.lsp") (load "directory-namestring.lsp") (load "host-namestring.lsp") (load "enough-namestring.lsp") (load "wild-pathname-p.lsp") (load "merge-pathnames.lsp") (load "pathname-match-p.lsp") (load "parse-namestring.lsp")gcl-2.6.14/ansi-tests/fdefinition.lsp0000644000175000017500000000305714360276512016110 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 15:27:51 2003 ;;;; Contains: Tests for FDEFINITION (in-package :cl-test) ;;; Error cases (deftest fdefinition.error.1 (classify-error (fdefinition)) program-error) (deftest fdefinition.error.2 (classify-error (fdefinition 'cons nil)) program-error) (deftest fdefinition.error.3 (classify-error (fdefinition (gensym))) undefined-function) (deftest fdefinition.error.4 (classify-error (fdefinition 10)) type-error) (deftest fdefinition.error.5 (classify-error (fdefinition (list 'setf (gensym)))) undefined-function) (deftest fdefinition.error.6 (classify-error (locally (fdefinition 10) t)) type-error) ;;; Non-error cases (deftest fdefinition.1 (let ((fun (fdefinition 'cons))) (funcall fun 'a 'b)) (a . b)) (deftest fdefinition.2 (progn (fdefinition 'cond) :good) :good) (deftest fdefinition.3 (progn (fdefinition 'setq) :good) :good) (deftest fdefinition.4 (let ((sym (gensym))) (values (fboundp sym) (progn (setf (fdefinition sym) (fdefinition 'cons)) (funcall (symbol-function sym) 'a 'b)) (notnot (fboundp sym)))) nil (a . b) t) (deftest fdefinition.5 (let* ((sym (gensym)) (fname (list 'setf sym))) (values (fboundp fname) (progn (setf (fdefinition fname) (fdefinition 'cons)) (eval `(setf (,sym 'a) 'b))) (notnot (fboundp fname)))) nil (b . a) t) (deftest fdefinition.order.1 (let ((i 0)) (fdefinition (progn (incf i) 'setq)) i) 1) gcl-2.6.14/ansi-tests/concatenate.lsp0000644000175000017500000001222214360276512016070 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Sep 4 22:53:51 2002 ;;;; Contains: Tests for CONCATENATE (in-package :cl-test) (deftest concatenate.1 (concatenate 'list) nil) (deftest concatenate.2 (let* ((orig (list 'a 'b 'c 'd 'e)) (copy (concatenate 'list orig))) (values copy (intersection (loop for e on orig collect e) (loop for e on copy collect e) :test #'eq))) (a b c d e) nil) (deftest concatenate.3 (concatenate 'list "") nil) (deftest concatenate.4 (concatenate 'list "abcd" '(x y z) nil #*1101 #()) (#\a #\b #\c #\d x y z 1 1 0 1)) (deftest concatenate.5 (concatenate 'vector) #()) (deftest concatenate.6 (concatenate 'vector nil "abcd" '(x y z) nil #*1101 #()) #(#\a #\b #\c #\d x y z 1 1 0 1)) (deftest concatenate.7 (let* ((orig (vector 'a 'b 'c 'd 'e)) (copy (concatenate 'vector orig))) (values copy (eqt copy orig))) #(a b c d e) nil) (deftest concatenate.8 (concatenate 'simple-vector '(a b c) #(1 2 3)) #(a b c 1 2 3)) (deftest concatenate.9 (concatenate 'simple-vector) #()) (deftest concatenate.10 (concatenate 'bit-vector nil) #*) (deftest concatenate.11 (concatenate 'bit-vector) #*) (deftest concatenate.12 (concatenate 'bit-vector '(0 1 1) nil #(1 0 1) #()) #*011101) (deftest concatenate.13 (concatenate 'simple-bit-vector nil) #*) (deftest concatenate.14 (concatenate 'simple-bit-vector) #*) (deftest concatenate.15 (concatenate 'simple-bit-vector '(0 1 1) nil #(1 0 1) #()) #*011101) (deftest concatenate.16 (concatenate 'string "abc" '(#\d #\e) nil #() "fg") "abcdefg") (deftest concatenate.17 (concatenate 'simple-string "abc" '(#\d #\e) nil #() "fg") "abcdefg") (deftest concatenate.18 (concatenate '(vector * *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.19 (concatenate '(vector * 8) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.20 (concatenate '(vector symbol 8) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.21 (concatenate '(vector symbol) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.22 (concatenate '(vector symbol *) '(a b c) '(d e f) #(g h)) #(a b c d e f g h)) (deftest concatenate.23 (concatenate 'cons '(a b c) '(d e f)) (a b c d e f)) (deftest concatenate.24 (concatenate 'null nil nil) nil) ;;; Tests on vectors with fill pointers (deftest concatenate.25 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5))) (concatenate 'list x x)) (a b c d e a b c d e)) (deftest concatenate.26 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5))) (concatenate 'list x)) (a b c d e)) (deftest concatenate.27 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) :fill-pointer 5)) (result (concatenate 'vector x))) (values (not (simple-vector-p result)) result)) nil #(a b c d e)) (deftest concatenate.28 (let* ((x (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) (concatenate 'string x x) (concatenate 'string x) (not (simple-string-p (concatenate 'string x))) )) "abcdez" "zabcde" "abcdeabcde" "abcde" nil) (deftest concatenate.29 (let* ((x (make-array '(10) :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) (concatenate 'string x x) (concatenate 'string x) (not (simple-string-p (concatenate 'string x))) )) "abcdez" "zabcde" "abcdeabcde" "abcde" nil) (deftest concatenate.30 (let* ((x (make-array '(10) :initial-contents #*0110010111 :fill-pointer 5 :element-type 'bit))) (values (concatenate 'bit-vector x '(0)) (concatenate 'bit-vector '(0) x) (concatenate 'bit-vector x x) (concatenate 'bit-vector x) (not (simple-bit-vector-p (concatenate 'bit-vector x))) )) #*011000 #*001100 #*0110001100 #*01100 nil) (deftest concatenate.order.1 (let ((i 0) w x y z) (values (concatenate (progn (setf w (incf i)) 'string) (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "def") (progn (setf z (incf i)) "ghi")) i w x y z)) "abcdefghi" 4 1 2 3 4) (deftest concatenate.order.2 (let ((i 0) x y z) (values (concatenate 'string (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "def") (progn (setf z (incf i)) "ghi")) i x y z)) "abcdefghi" 3 1 2 3) ;;; Error tests (deftest concatenate.error.1 (subtypep* (classify-error (concatenate 'sequence '(a b c))) 'error) t t) (deftest concatenate.error.2 (subtypep* (classify-error (concatenate 'fixnum '(a b c d e))) 'error) t t) (deftest concatenate.error.3 (classify-error (concatenate '(vector * 3) '(a b c d e))) type-error) (deftest concatenate.error.4 (classify-error (concatenate)) program-error) (deftest concatenate.error.5 (classify-error (locally (concatenate '(vector * 3) '(a b c d e)) t)) type-error) gcl-2.6.14/ansi-tests/namestring.lsp0000644000175000017500000000361314360276512015757 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Sep 2 07:24:42 2004 ;;;; Contains: Tests for NAMESTRING (in-package :cl-test) (deftest namestring.1 (let* ((vals (multiple-value-list (namestring "namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (namestring s) s)) :good vals)) :good) (deftest namestring.2 (do-special-strings (s "namestring.lsp" nil) (let ((ns (namestring s))) (assert (stringp ns)) (assert (string= (namestring ns) ns)))) nil) ;;; I'm not convinced these tested required behavior, so I'm commenting ;;; them out for now. FIXME: determine if they are bogus #| (deftest namestring.3 (let* ((name "namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (namestring pn)) (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) (pathname-directory pn) (pathname-name pn) (pathname-type pn) (pathname-version pn)) (list pn2 (pathname-host pn2) (pathname-device pn2) (pathname-directory pn2) (pathname-name pn2) (pathname-type pn2) (pathname-version pn2))))) t) (deftest namestring.4 (let* ((name "namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (namestring s))) (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) (pathname-directory pn) (pathname-name pn) (pathname-type pn) (pathname-version pn)) (list pn2 (pathname-host pn2) (pathname-device pn2) (pathname-directory pn2) (pathname-name pn2) (pathname-type pn2) (pathname-version pn2))))) t) |# ;;; Error tests (deftest namestring.error.1 (signals-error (namestring) program-error) t) (deftest namestring.error.2 (signals-error (namestring "namestring.lsp" nil) program-error) t) gcl-2.6.14/ansi-tests/loop.lsp0000644000175000017500000000151714360276512014562 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 25 18:48:59 2002 ;;;; Contains: Tests of LOOP (in-package :cl-test) ;;; Simple loops (deftest sloop.1 (loop (return 'a)) a) (deftest sloop.2 (loop (return (values)))) (deftest sloop.3 (loop (return (values 'a 'b 'c 'd))) a b c d) (deftest sloop.4 (block nil (loop (return 'a)) 'b) b) (deftest sloop.5 (let ((i 0) (x nil)) (loop (when (>= i 4) (return x)) (incf i) (push 'a x))) (a a a a)) (deftest sloop.6 (let ((i 0) (x nil)) (block foo (tagbody (loop (when (>= i 4) (go a)) (incf i) (push 'a x)) a (return-from foo x)))) (a a a a)) (deftest sloop.7 (catch 'foo (let ((i 0) (x nil)) (loop (when (>= i 4) (throw 'foo x)) (incf i) (push 'a x)))) (a a a a)) gcl-2.6.14/ansi-tests/fboundp.lsp0000644000175000017500000000245114360276512015244 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 22:37:22 2002 ;;;; Contains: Tests of FBOUNDP (in-package :cl-test) (deftest fboundp.1 (not-mv (fboundp 'car)) nil) (deftest fboundp.2 (not-mv (fboundp 'cdr)) nil) (deftest fboundp.3 (not-mv (fboundp 'defun)) ; a macro nil) (deftest fboundp.4 ;; fresh symbols are not fbound (let ((g (gensym))) (fboundp g)) nil) (defun fboundp-5-fn (x) x) (deftest fboundp.5 (not-mv (fboundp 'fboundp-5-fn)) nil) (eval-when (eval compile) (ignore-errors (defun (setf fboundp-6-accessor) (y x) (setf (car x) y)))) (deftest fboundp.6 (not-mv (fboundp '(setf fboundp-6-accessor))) nil) (deftest fboundp.7 (let ((g (gensym))) (fboundp (list 'setf g))) nil) (deftest fboundp.order.1 (let ((i 0)) (values (notnot (fboundp (progn (incf i) 'car))) i)) t 1) (deftest fboundp.error.1 (classify-error (fboundp 1)) type-error) (deftest fboundp.error.2 (classify-error (fboundp #\a)) type-error) (deftest fboundp.error.3 (classify-error (fboundp '(foo))) type-error) (deftest fboundp.error.4 (classify-error (fboundp)) program-error) (deftest fboundp.error.5 (classify-error (fboundp 'cons nil)) program-error) (deftest fboundp.error.6 (classify-error (locally (fboundp 1) t)) type-error) gcl-2.6.14/ansi-tests/function-lambda-expression.lsp0000644000175000017500000000157114360276512021051 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:27:12 2003 ;;;; Contains: Tests for FUNCTION-LAMBDA-EXPRESSION (in-package :cl-test) (deftest function-lambda-expression.1 (length (multiple-value-list (function-lambda-expression #'cons))) 3) (deftest function-lambda-expression.2 (let ((x nil)) (flet ((%f () x)) (let ((ret-vals (multiple-value-list (function-lambda-expression #'%f)))) (values (length ret-vals) (notnot (second ret-vals)))))) 3 t) (deftest function-lambda-expression.order.1 (let ((i 0)) (function-lambda-expression (progn (incf i) #'cons)) i) 1) (deftest function-lambda-expression.error.1 (classify-error (function-lambda-expression)) program-error) (deftest function-lambda-expression.error.2 (classify-error (function-lambda-expression #'cons nil)) program-error) gcl-2.6.14/ansi-tests/nstring-upcase.lsp0000644000175000017500000000604414360276512016553 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 3 21:12:40 2002 ;;;; Contains: Tests for NSTRING-UPCASE (in-package :cl-test) (deftest nstring-upcase.1 (let* ((s (copy-seq "a")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "A") (deftest nstring-upcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest nstring-upcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-upcase.6 (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f))) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "ABCDEF") (deftest nstring-upcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\a #\b #\7 #\d #\e #\f))) (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "AB7DEF") ;; Tests with :start, :end (deftest nstring-upcase.8 (let ((s "abcdef")) (loop for i from 0 to 6 collect (nstring-upcase (copy-seq s) :start i))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.9 (let ((s "abcdef")) (loop for i from 0 to 6 collect (nstring-upcase (copy-seq s) :start i :end nil))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.10 (let ((s "abcde")) (loop for i from 0 to 4 collect (loop for j from i to 5 collect (nstring-upcase (copy-seq s) :start i :end j)))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") ("abcde" "abcDe" "abcDE") ("abcde" "abcdE"))) (deftest nstring-upcase.order.1 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-upcase (progn (setf a (incf i)) s) :start (progn (setf b (incf i)) 1) :end (progn (setf c (incf i)) 4)) i a b c)) "aBCDef" 3 1 2 3) (deftest nstring-upcase.order.2 (let ((i 0) a b c (s (copy-seq "abcdef"))) (values (nstring-upcase (progn (setf a (incf i)) s) :end (progn (setf b (incf i)) 4) :start (progn (setf c (incf i)) 1)) i a b c)) "aBCDef" 3 1 2 3) ;;; Error cases (deftest nstring-upcase.error.1 (classify-error (nstring-upcase)) program-error) (deftest nstring-upcase.error.2 (classify-error (nstring-upcase (copy-seq "abc") :bad t)) program-error) (deftest nstring-upcase.error.3 (classify-error (nstring-upcase (copy-seq "abc") :start)) program-error) (deftest nstring-upcase.error.4 (classify-error (nstring-upcase (copy-seq "abc") :bad t :allow-other-keys nil)) program-error) (deftest nstring-upcase.error.5 (classify-error (nstring-upcase (copy-seq "abc") :end)) program-error) (deftest nstring-upcase.error.6 (classify-error (nstring-upcase (copy-seq "abc") 1 2)) program-error) gcl-2.6.14/ansi-tests/load-system-construction.lsp0000644000175000017500000000045314360276512020600 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Dec 12 19:44:29 2004 ;;;; Contains: Load tests for system construction (section 24) (in-package :cl-test) (load "compile-file.lsp") (load "load.lsp") (load "with-compilation-unit.lsp") (load "features.lsp") (load "modules.lsp") gcl-2.6.14/ansi-tests/bit-nor.lsp0000644000175000017500000001426214360276512015164 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:20:40 2003 ;;;; Contains: Tests for BIT-NOR (in-package :cl-test) (deftest bit-nor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-nor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-nor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-nor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-nor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-nor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-nor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-nor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-nor.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2)) a1 a2)) #*1000 #*0011 #*0101) (deftest bit-nor.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-nor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1000 #*1000 #*0101 t) (deftest bit-nor.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-nor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1000 #*0011 #*0101 #*1000 t) (deftest bit-nor.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2 nil)) a1 a2)) #*1000 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-nor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 0)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-nor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-nor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0)) #2a((1 0)(0 0))) ;;; Adjustable arrays (deftest bit-nor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) ;;; Displaced arrays (deftest bit-nor.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-nor a1 a2 t))) (values a0 a1 a2 result)) #*10000011 #2a((1 0)(0 0)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-nor a1 a2 a3))) (values a0 a1 a2 result)) #*010100111000 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(0 0))) (deftest bit-nor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-nor (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-nor.error.1 (classify-error (bit-nor)) program-error) (deftest bit-nor.error.2 (classify-error (bit-nor #*000)) program-error) (deftest bit-nor.error.3 (classify-error (bit-nor #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/search-list.lsp0000644000175000017500000001532014360276512016024 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 24 07:22:10 2002 ;;;; Contains: Tests for SEARCH on lists (in-package :cl-test) (deftest search-list.1 (let ((target *searched-list*) (pat '(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-list.2 (let ((target *searched-list*) (pat '(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-list.3 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-list.4 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-list.5 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-list.6 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-list.7 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-list.8 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-list.9 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-list.10 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-list.11 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-list.12 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-list.13 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-list.14 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) ;;; Keyword tests (deftest search.allow-other-keys.1 (search '(c d) '(a b c d c d e) :allow-other-keys t) 2) (deftest search.allow-other-keys.2 (search '(c d) '(a b c d c d e) :allow-other-keys nil) 2) (deftest search.allow-other-keys.3 (search '(c d) '(a b c d c d e) :bad t :allow-other-keys t) 2) (deftest search.allow-other-keys.4 (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :bad nil) 2) (deftest search.allow-other-keys.5 (search '(c d) '(a b c d c d e) :bad1 1 :allow-other-keys t :bad2 2 :allow-other-keys nil :bad3 3) 2) (deftest search.allow-other-keys.6 (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :from-end t) 4) (deftest search.allow-other-keys.7 (search '(c d) '(a b c d c d e) :from-end t :allow-other-keys t) 4) (deftest search.keywords.8 (search '(c d) '(a b c d c d e) :start1 0 :start2 0 :start1 1 :start2 6 :from-end t :from-end nil) 4) ;;; Error cases (deftest search.error.1 (classify-error (search)) program-error) (deftest search.error.2 (classify-error (search "a")) program-error) (deftest search.error.3 (classify-error (search "a" "a" :key)) program-error) (deftest search.error.4 (classify-error (search "a" "a" 'bad t)) program-error) (deftest search.error.5 (classify-error (search "a" "a" 'bad t :allow-other-keys nil)) program-error) (deftest search.error.6 (classify-error (search "a" "a" 1 2)) program-error) (deftest search.error.7 (classify-error (search "c" "abcde" :test #'identity)) program-error) (deftest search.error.8 (classify-error (search "c" "abcde" :test-not #'identity)) program-error) (deftest search.error.9 (classify-error (search "c" "abcde" :key #'cons)) program-error) (deftest search.error.10 (classify-error (search "c" "abcde" :key #'car)) type-error) ;;; Order of evaluation (deftest search.order.1 (let ((i 0) a b c d e f g h j) (values (search (progn (setf a (incf i)) '(nil a b nil)) (progn (setf b (incf i)) '(z z z a a b b z z z)) :from-end (progn (setf c (incf i)) t) :start1 (progn (setf d (incf i)) 1) :end1 (progn (setf e (incf i)) 3) :start2 (progn (setf f (incf i)) 1) :end2 (progn (setf g (incf i)) 8) :key (progn (setf h (incf i)) #'identity) :test (progn (setf j (incf i)) #'eql) ) i a b c d e f g h j)) 4 9 1 2 3 4 5 6 7 8 9) (deftest search.order.2 (let ((i 0) a b c d e f g h j) (values (search (progn (setf a (incf i)) '(nil a b nil)) (progn (setf b (incf i)) '(z z z a a b b z z z)) :test-not (progn (setf c (incf i)) (complement #'eql)) :key (progn (setf d (incf i)) #'identity) :end2 (progn (setf e (incf i)) 8) :start2 (progn (setf f (incf i)) 1) :end1 (progn (setf g (incf i)) 3) :start1 (progn (setf h (incf i)) 1) :from-end (progn (setf j (incf i)) t) ) i a b c d e f g h j)) 4 9 1 2 3 4 5 6 7 8 9)gcl-2.6.14/ansi-tests/array-misc.lsp0000644000175000017500000000120314360276512015650 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 21:17:25 2003 ;;;; Contains: Misc. tests of array features (in-package :cl-test) (deftest array-dimension-limit.1 (and (<= 1024 array-dimension-limit) t) t) (deftest array-dimension-limit.2 (and (typep array-dimension-limit 'fixnum) t) t) (deftest array-total-size-limit.1 (and (<= 1024 array-total-size-limit) t) t) (deftest array-total-size-limit.2 (and (typep array-total-size-limit 'fixnum) t) t) (deftest array-rank-limit.1 (and (<= 8 array-rank-limit) t) t) (deftest array-rank-limit.2 (and (typep array-rank-limit 'fixnum) t) t) gcl-2.6.14/ansi-tests/load-files.lsp0000644000175000017500000000061614360276512015627 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 1 11:59:35 2004 ;;;; Contains: Load tests of section 20, 'Files' (in-package :cl-test) (load "directory.lsp") (load "probe-file.lsp") (load "ensure-directories-exist.lsp") (load "truename.lsp") (load "file-author.lsp") (load "file-write-date.lsp") (load "rename-file.lsp") (load "delete-file.lsp") (load "file-error.lsp") gcl-2.6.14/ansi-tests/string-comparisons.lsp0000644000175000017500000003223114360276512017447 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:32:41 2002 ;;;; Contains: Tests of string comparison functions (in-package :cl-test) (deftest string=.1 (not (string= "abc" (copy-seq "abc"))) nil) (deftest string=.2 (string= "A" "a") nil) (deftest string=.3 (not (string= #\a "a")) nil) (deftest string=.4 (not (string= '|abc| (copy-seq "abc"))) nil) (deftest string=.5 (not (string= (copy-seq "abc") '#:|abc|)) nil) ;;; Test that it doesn't stop at null characters (deftest string=.6 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abd")) (c (or (code-char 0) #\a))) (setf (char s1 1) c) (setf (char s2 1) c) (values (length s1) (length s2) (string= s1 s2))) 3 3 nil) (deftest string=.7 (loop for i from 0 to 3 collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) (nil nil nil t)) (deftest string=.8 (loop for i from 0 to 3 collect (not (string= "abc" "ab" :end1 i))) (t t nil t)) (deftest string=.9 (loop for i from 0 to 3 collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) (nil nil nil t)) (deftest string=.10 (loop for i from 0 to 3 collect (not (string= "ab" "abc" :end2 i))) (t t nil t)) (deftest string=.11 (loop for i from 0 to 3 collect (not (string= "xyab" "ab" :start1 i))) (t t nil t)) (deftest string=.12 (loop for i from 0 to 3 collect (not (string= "ab" "xyab" :start2 i))) (t t nil t)) (deftest string=.13 (loop for i from 0 to 3 collect (not (string= "xyab" "ab" :start1 i :end1 nil))) (t t nil t)) (deftest string=.14 (loop for i from 0 to 3 collect (not (string= "ab" "xyab" :start2 i :end2 nil))) (t t nil t)) ;;; Order of evaluation (deftest string=.order.1 (let ((i 0) x y) (values (string= (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string=.order.2 (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string=.order.3 (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<=.order.1 (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string<=.order.2 (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<=.order.3 (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<.order.1 (let ((i 0) x y) (values (string< (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string<.order.2 (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string<.order.3 (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string/=.order.1 (let ((i 0) x y) (values (string/= (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) (deftest string/=.order.2 (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string/=.order.3 (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>=.order.1 (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string>=.order.2 (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>=.order.3 (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>.order.1 (let ((i 0) x y) (values (string> (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string>.order.2 (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string>.order.3 (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-equal.order.1 (let ((i 0) x y) (values (string-equal (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-equal.order.2 (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-equal.order.3 (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-greaterp.order.1 (let ((i 0) x y) (values (string-not-greaterp (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-not-greaterp.order.2 (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-greaterp.order.3 (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-lessp.order.1 (let ((i 0) x y) (values (string-lessp (progn (setf x (incf i)) "abf") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-lessp.order.2 (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-lessp.order.3 (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-equal.order.1 (let ((i 0) x y) (values (string-not-equal (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) (deftest string-not-equal.order.2 (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-equal.order.3 (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abc") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-lessp.order.1 (let ((i 0) x y) (values (string-not-lessp (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-not-lessp.order.2 (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-not-lessp.order.3 (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-greaterp.order.1 (let ((i 0) x y) (values (string-greaterp (progn (setf x (incf i)) "abc") (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) (deftest string-greaterp.order.2 (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :start1 (progn (setf c (incf i)) 0) :start2 (progn (setf d (incf i)) 0) :end1 (progn (setf e (incf i)) nil) :end2 (progn (setf f (incf i)) nil) ) i a b c d e f)) nil 6 1 2 3 4 5 6) (deftest string-greaterp.order.3 (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) "abd") :end2 (progn (setf c (incf i)) nil) :end1 (progn (setf d (incf i)) nil) :start2 (progn (setf e (incf i)) 0) :start1 (progn (setf f (incf i)) 0) ) i a b c d e f)) nil 6 1 2 3 4 5 6) ;;; Random tests (of all the string comparson functions) (deftest random-string-comparison-tests (loop for cmp in '(= /= < > <= >=) append (loop for case in '(nil t) collect (list cmp case (random-string-compare-test 10 cmp case 1000)))) ((= nil 0) (= t 0) (/= nil 0) (/= t 0) (< nil 0) (< t 0) (> nil 0) (> t 0) (<= nil 0) (<= t 0) (>= nil 0) (>= t 0))) gcl-2.6.14/ansi-tests/rt.lsp0000644000175000017500000003373414360276512014244 0ustar cammcamm;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# ;This was the December 19, 1990 version of the regression tester, but ;has since been modified. (in-package :regression-test) (declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) (declaim (type list *entries*)) (declaim (ftype (function (t &rest t) t) report-error)) (declaim (ftype (function (t &optional t) t) do-entry)) (defvar *test* nil "Current test name") (defvar *do-tests-when-defined* nil) (defvar *entries* (list nil) "Test database. Has a leading dummy cell that does not contain an entry.") (defvar *entries-tail* *entries* "Tail of the *entries* list") (defvar *entries-table* (make-hash-table :test #'equal) "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") (defvar *in-test* nil "Used by TEST") (defvar *debug* nil "For debugging") (defvar *catch-errors* t "When true, causes errors in a test to be caught.") (defvar *print-circle-on-failure* nil "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") (defvar *compile-tests* nil "When true, compile the tests before running them.") (defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") (defvar *optimization-settings* '((safety 3))) (defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed") (defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed") (defvar *expected-failures* nil "A list of test names that are expected to fail.") (defvar *notes* (make-hash-table :test 'equal) "A mapping from names of notes to note objects.") (defstruct (entry (:conc-name nil)) pend name props form vals) ;;; Note objects are used to attach information to tests. ;;; A typical use is to mark tests that depend on a particular ;;; part of a set of requirements, or a particular interpretation ;;; of the requirements. (defstruct note name contents disabled ;; When true, tests with this note are considered inactive ) ;; (defmacro vals (entry) `(cdddr ,entry)) (defmacro defn (entry) (let ((var (gensym))) `(let ((,var ,entry)) (list* (name ,var) (form ,var) (vals ,var))))) (defun entry-notes (entry) (let* ((props (props entry)) (notes (getf props :notes))) (if (listp notes) notes (list notes)))) (defun has-disabled-note (entry) (let ((notes (entry-notes entry))) (loop for n in notes for note = (if (note-p n) n (gethash n *notes*)) thereis (and note (note-disabled note))))) (defun has-note (entry note) (unless (note-p note) (let ((new-note (gethash note *notes*))) (setf note new-note))) (and note (not (not (member note (entry-notes entry)))))) (defun pending-tests () (loop for entry in (cdr *entries*) when (and (pend entry) (not (has-disabled-note entry))) collect (name entry))) (defun rem-all-tests () (setq *entries* (list nil)) (setq *entries-tail* *entries*) (clrhash *entries-table*) nil) (defun rem-test (&optional (name *test*)) (let ((pred (gethash name *entries-table*))) (when pred (if (null (cddr pred)) (setq *entries-tail* pred) (setf (gethash (name (caddr pred)) *entries-table*) pred)) (setf (cdr pred) (cddr pred)) (remhash name *entries-table*) name))) (defun get-test (&optional (name *test*)) (defn (get-entry name))) (defun get-entry (name) (let ((entry ;; (find name (the list (cdr *entries*)) ;; :key #'name :test #'equal) (cadr (gethash name *entries-table*)) )) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." name)) entry)) (defmacro deftest (name &rest body) (let* ((p body) (properties (loop while (keywordp (first p)) unless (cadr p) do (error "Poorly formed deftest: ~A~%" (list* 'deftest name body)) append (list (pop p) (pop p)))) (form (pop p)) (vals p)) `(add-entry (make-entry :pend t :name ',name :props ',properties :form ',form :vals ',vals)))) (defun add-entry (entry) (setq entry (copy-entry entry)) (let* ((pred (gethash (name entry) *entries-table*))) (cond (pred (setf (cadr pred) entry) (report-error nil "Redefining test ~:@(~S~)" (name entry))) (t (setf (gethash (name entry) *entries-table*) *entries-tail*) (setf (cdr *entries-tail*) (cons entry nil)) (setf *entries-tail* (cdr *entries-tail*)) ))) (when *do-tests-when-defined* (do-entry entry)) (setq *test* (name entry))) (defun report-error (error? &rest args) (cond (*debug* (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) (t (apply #'warn args))) nil) (defun do-test (&optional (name *test*) &rest key-args) (flet ((%parse-key-args (&key ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) (do-entry (get-entry name)))) (apply #'%parse-key-args key-args))) (defun my-aref (a &rest args) (apply #'aref a args)) (defun my-row-major-aref (a index) (row-major-aref a index)) (defun equalp-with-case (x y) "Like EQUALP, but doesn't do case conversion of characters. Currently doesn't work on arrays of dimension > 2." (cond ((eq x y) t) ((consp x) (and (consp y) (equalp-with-case (car x) (car y)) (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) (= (array-rank x) 0)) (equalp-with-case (my-aref x) (my-aref y))) ((typep x 'vector) (and (typep y 'vector) (let ((x-len (length x)) (y-len (length y))) (and (eql x-len y-len) (loop for i from 0 below x-len for e1 = (my-aref x i) for e2 = (my-aref y i) always (equalp-with-case e1 e2)))))) ((and (typep x 'array) (typep y 'array) (not (equal (array-dimensions x) (array-dimensions y)))) nil) ((typep x 'array) (and (typep y 'array) (let ((size (array-total-size x))) (loop for i from 0 below size always (equalp-with-case (my-row-major-aref x i) (my-row-major-aref y i)))))) ((typep x 'pathname) (equal x y)) (t (eql x y)))) (defun do-entry (entry &optional (s *standard-output*)) (catch '*in-test* (setq *test* (name entry)) (setf (pend entry) t) (let* ((*in-test* t) ;; (*break-on-warnings* t) (aborted nil) r) ;; (declare (special *break-on-warnings*)) (block aborted (setf r (flet ((%do () (handler-bind #-sbcl nil #+sbcl ((sb-ext:code-deletion-note #'(lambda (c) (if (has-note entry :do-not-muffle) nil (muffle-warning c))))) (cond (*compile-tests* (multiple-value-list (funcall (compile nil `(lambda () (declare (optimize ,@*optimization-settings*)) ,(form entry)))))) (*expanded-eval* (multiple-value-list (expanded-eval (form entry)))) (t (multiple-value-list (eval (form entry)))))))) (if *catch-errors* (handler-bind (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings) c (muffle-warning c)))) (error #'(lambda (c) (setf aborted t) (setf r (list c)) (return-from aborted nil)))) (%do)) (%do))))) (setf (pend entry) (or aborted (not (equalp-with-case r (vals entry))))) (when (pend entry) (let ((*print-circle* *print-circle-on-failure*)) (format s "~&Test ~:@(~S~) failed~ ~%Form: ~S~ ~%Expected value~P: ~ ~{~S~^~%~17t~}~%" *test* (form entry) (length (vals entry)) (vals entry)) (handler-case (let ((st (format nil "Actual value~P: ~ ~{~S~^~%~15t~}.~%" (length r) r))) (format s "~A" st)) (error () (format s "Actual value: #~%"))) (finish-output s))))) (when (not (pend entry)) *test*)) (defun expanded-eval (form) "Split off top level of a form and eval separately. This reduces the chance that compiler optimizations will fold away runtime computation." (if (not (consp form)) (eval form) (let ((op (car form))) (cond ((eq op 'let) (let* ((bindings (loop for b in (cadr form) collect (if (consp b) b (list b nil)))) (vars (mapcar #'car bindings)) (binding-forms (mapcar #'cadr bindings))) (apply (the function (eval `(lambda ,vars ,@(cddr form)))) (mapcar #'eval binding-forms)))) ((and (eq op 'let*) (cadr form)) (let* ((bindings (loop for b in (cadr form) collect (if (consp b) b (list b nil)))) (vars (mapcar #'car bindings)) (binding-forms (mapcar #'cadr bindings))) (funcall (the function (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) (eval (car binding-forms))))) ((eq op 'progn) (loop for e on (cdr form) do (if (null (cdr e)) (return (eval (car e))) (eval (car e))))) ((and (symbolp op) (fboundp op) (not (macro-function op)) (not (special-operator-p op))) (apply (symbol-function op) (mapcar #'eval (cdr form)))) (t (eval form)))))) (defun continue-testing () (if *in-test* (throw '*in-test* nil) (do-entries *standard-output*))) (defun do-tests (&key (out *standard-output*) ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) (setq *failed-tests* nil *passed-tests* nil) (dolist (entry (cdr *entries*)) (setf (pend entry) t)) (if (streamp out) (do-entries out) (with-open-file (stream out :direction :output) (do-entries stream)))) (defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" (count t (the list (cdr *entries*)) :key #'pend) (length (cdr *entries*))) (finish-output s) (dolist (entry (cdr *entries*)) (when (and (pend entry) (not (has-disabled-note entry))) (let ((success? (do-entry entry s))) (if success? (push (name entry) *passed-tests*) (push (name entry) *failed-tests*)) (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?)) (finish-output s) )) (let ((pending (pending-tests)) (expected-table (make-hash-table :test #'equal))) (dolist (ex *expected-failures*) (setf (gethash ex expected-table) t)) (let ((new-failures (loop for pend in pending unless (gethash pend expected-table) collect pend))) (if (null pending) (format s "~&No tests failed.") (progn (format s "~&~A out of ~A ~ total tests failed: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (length pending) (length (cdr *entries*)) pending) (if (null new-failures) (format s "~&No unexpected failures.") (when *expected-failures* (format s "~&~A unexpected failures: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (length new-failures) new-failures))) )) (finish-output s) (null pending)))) ;;; Note handling functions and macros (defmacro defnote (name contents &optional disabled) `(eval-when (:load-toplevel :execute) (let ((note (make-note :name ',name :contents ',contents :disabled ',disabled))) (setf (gethash (note-name note) *notes*) note) note))) (defun disable-note (n) (let ((note (if (note-p n) n (setf n (gethash n *notes*))))) (unless note (error "~A is not a note or note name." n)) (setf (note-disabled note) t) note)) (defun enable-note (n) (let ((note (if (note-p n) n (setf n (gethash n *notes*))))) (unless note (error "~A is not a note or note name." n)) (setf (note-disabled note) nil) note)) ;;; Extended random regression (defun do-extended-tests (&key (tests *passed-tests*) (count nil) ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) "Execute randomly chosen tests from TESTS until one fails or until COUNT is an integer and that many tests have been executed." (let ((test-vector (coerce tests 'simple-vector))) (let ((n (length test-vector))) (when (= n 0) (error "Must provide at least one test.")) (loop for i from 0 for name = (svref test-vector (random n)) until (eql i count) do (print name) unless (do-test name) return (values name (1+ i)))))) gcl-2.6.14/ansi-tests/cons-test-08.lsp0000644000175000017500000002037214360276512015755 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:36:01 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 8 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Error checking car, cdr, list-length (deftest car.1 (car '(a)) a) (deftest car-nil (car nil) nil) (deftest car-symbol-error (classify-error (car 'a)) type-error) (deftest car-symbol-error.2 (classify-error (locally (car 'a) t)) type-error) (deftest car.order.1 (let ((i 0)) (values (car (progn (incf i) '(a b))) i)) a 1) (deftest cdr.1 (cdr '(a b)) (b)) (deftest cdr-nil (cdr ()) nil) (deftest cdr.order.1 (let ((i 0)) (values (cdr (progn (incf i) '(a b))) i)) (b) 1) (deftest cdr-symbol-error (classify-error (cdr 'a)) type-error) (deftest cdr-symbol-error.2 (classify-error (locally (cdr 'a) t)) type-error) (deftest list-length.4 (list-length (copy-tree '(a b c))) 3) (deftest list-length-symbol (classify-error (list-length 'a)) type-error) (deftest list-length-dotted-list (classify-error (list-length (copy-tree '(a b c d . e)))) type-error) ;;; Error checking of c*r functions (deftest caar.error.1 (classify-error (caar 'a)) type-error) (deftest caar.error.2 (classify-error (caar '(a))) type-error) (deftest cadr.error.1 (classify-error (cadr 'a)) type-error) (deftest cadr.error.2 (classify-error (cadr '(a . b))) type-error) (deftest cdar.error.1 (classify-error (cdar 'a)) type-error) (deftest cdar.error.2 (classify-error (cdar '(a . b))) type-error) (deftest cddr.error.1 (classify-error (cddr 'a)) type-error) (deftest cddr.error.2 (classify-error (cddr '(a . b))) type-error) (deftest caaar.error.1 (classify-error (caaar 'a)) type-error) (deftest caaar.error.2 (classify-error (caaar '(a))) type-error) (deftest caaar.error.3 (classify-error (caaar '((a)))) type-error) (deftest caadr.error.1 (classify-error (caadr 'a)) type-error) (deftest caadr.error.2 (classify-error (caadr '(a . b))) type-error) (deftest caadr.error.3 (classify-error (caadr '(a . (b)))) type-error) (deftest cadar.error.1 (classify-error (cadar 'a)) type-error) (deftest cadar.error.2 (classify-error (cadar '(a . b))) type-error) (deftest cadar.error.3 (classify-error (cadar '((a . c) . b))) type-error) (deftest caddr.error.1 (classify-error (caddr 'a)) type-error) (deftest caddr.error.2 (classify-error (caddr '(a . b))) type-error) (deftest caddr.error.3 (classify-error (caddr '(a c . b))) type-error) (deftest cdaar.error.1 (classify-error (cdaar 'a)) type-error) (deftest cdaar.error.2 (classify-error (cdaar '(a))) type-error) (deftest cdaar.error.3 (classify-error (cdaar '((a . b)))) type-error) (deftest cdadr.error.1 (classify-error (cdadr 'a)) type-error) (deftest cdadr.error.2 (classify-error (cdadr '(a . b))) type-error) (deftest cdadr.error.3 (classify-error (cdadr '(a b . c))) type-error) (deftest cddar.error.1 (classify-error (cddar 'a)) type-error) (deftest cddar.error.2 (classify-error (cddar '(a . b))) type-error) (deftest cddar.error.3 (classify-error (cddar '((a . b) . b))) type-error) (deftest cdddr.error.1 (classify-error (cdddr 'a)) type-error) (deftest cdddr.error.2 (classify-error (cdddr '(a . b))) type-error) (deftest cdddr.error.3 (classify-error (cdddr '(a c . b))) type-error) ;; (deftest caaaar.error.1 (classify-error (caaaar 'a)) type-error) (deftest caaaar.error.2 (classify-error (caaaar '(a))) type-error) (deftest caaaar.error.3 (classify-error (caaaar '((a)))) type-error) (deftest caaaar.error.4 (classify-error (caaaar '(((a))))) type-error) (deftest caaadr.error.1 (classify-error (caaadr 'a)) type-error) (deftest caaadr.error.2 (classify-error (caaadr '(a . b))) type-error) (deftest caaadr.error.3 (classify-error (caaadr '(a . (b)))) type-error) (deftest caaadr.error.4 (classify-error (caaadr '(a . ((b))))) type-error) (deftest caadar.error.1 (classify-error (caadar 'a)) type-error) (deftest caadar.error.2 (classify-error (caadar '(a . b))) type-error) (deftest caadar.error.3 (classify-error (caadar '((a . c) . b))) type-error) (deftest caadar.error.4 (classify-error (caadar '((a . (c)) . b))) type-error) (deftest caaddr.error.1 (classify-error (caaddr 'a)) type-error) (deftest caaddr.error.2 (classify-error (caaddr '(a . b))) type-error) (deftest caaddr.error.3 (classify-error (caaddr '(a c . b))) type-error) (deftest caaddr.error.4 (classify-error (caaddr '(a c . (b)))) type-error) (deftest cadaar.error.1 (classify-error (cadaar 'a)) type-error) (deftest cadaar.error.2 (classify-error (cadaar '(a))) type-error) (deftest cadaar.error.3 (classify-error (cadaar '((a . b)))) type-error) (deftest cadaar.error.4 (classify-error (cadaar '((a . (b))))) type-error) (deftest cadadr.error.1 (classify-error (cadadr 'a)) type-error) (deftest cadadr.error.2 (classify-error (cadadr '(a . b))) type-error) (deftest cadadr.error.3 (classify-error (cadadr '(a b . c))) type-error) (deftest cadadr.error.4 (classify-error (cadadr '(a (b . e) . c))) type-error) (deftest caddar.error.1 (classify-error (caddar 'a)) type-error) (deftest caddar.error.2 (classify-error (caddar '(a . b))) type-error) (deftest caddar.error.3 (classify-error (caddar '((a . b) . b))) type-error) (deftest caddar.error.4 (classify-error (caddar '((a b . c) . b))) type-error) (deftest cadddr.error.1 (classify-error (cadddr 'a)) type-error) (deftest cadddr.error.2 (classify-error (cadddr '(a . b))) type-error) (deftest cadddr.error.3 (classify-error (cadddr '(a c . b))) type-error) (deftest cadddr.error.4 (classify-error (cadddr '(a c e . b))) type-error) (deftest cdaaar.error.1 (classify-error (cdaaar 'a)) type-error) (deftest cdaaar.error.2 (classify-error (cdaaar '(a))) type-error) (deftest cdaaar.error.3 (classify-error (cdaaar '((a)))) type-error) (deftest cdaaar.error.4 (classify-error (cdaaar '(((a . b))))) type-error) (deftest cdaadr.error.1 (classify-error (cdaadr 'a)) type-error) (deftest cdaadr.error.2 (classify-error (cdaadr '(a . b))) type-error) (deftest cdaadr.error.3 (classify-error (cdaadr '(a . (b)))) type-error) (deftest cdaadr.error.4 (classify-error (cdaadr '(a . ((b . c))))) type-error) (deftest cdadar.error.1 (classify-error (cdadar 'a)) type-error) (deftest cdadar.error.2 (classify-error (cdadar '(a . b))) type-error) (deftest cdadar.error.3 (classify-error (cdadar '((a . c) . b))) type-error) (deftest cdadar.error.4 (classify-error (cdadar '((a . (c . d)) . b))) type-error) (deftest cdaddr.error.1 (classify-error (cdaddr 'a)) type-error) (deftest cdaddr.error.2 (classify-error (cdaddr '(a . b))) type-error) (deftest cdaddr.error.3 (classify-error (cdaddr '(a c . b))) type-error) (deftest cdaddr.error.4 (classify-error (cdaddr '(a c b . d))) type-error) (deftest cddaar.error.1 (classify-error (cddaar 'a)) type-error) (deftest cddaar.error.2 (classify-error (cddaar '(a))) type-error) (deftest cddaar.error.3 (classify-error (cddaar '((a . b)))) type-error) (deftest cddaar.error.4 (classify-error (cddaar '((a . (b))))) type-error) (deftest cddadr.error.1 (classify-error (cddadr 'a)) type-error) (deftest cddadr.error.2 (classify-error (cddadr '(a . b))) type-error) (deftest cddadr.error.3 (classify-error (cddadr '(a b . c))) type-error) (deftest cddadr.error.4 (classify-error (cddadr '(a (b . e) . c))) type-error) (deftest cdddar.error.1 (classify-error (cdddar 'a)) type-error) (deftest cdddar.error.2 (classify-error (cdddar '(a . b))) type-error) (deftest cdddar.error.3 (classify-error (cdddar '((a . b) . b))) type-error) (deftest cdddar.error.4 (classify-error (cdddar '((a b . c) . b))) type-error) (deftest cddddr.error.1 (classify-error (cddddr 'a)) type-error) (deftest cddddr.error.2 (classify-error (cddddr '(a . b))) type-error) (deftest cddddr.error.3 (classify-error (cddddr '(a c . b))) type-error) (deftest cddddr.error.4 (classify-error (cddddr '(a c e . b))) type-error) ;;; Need to add 'locally' wrapped forms of these gcl-2.6.14/ansi-tests/pathname-version.lsp0000644000175000017500000000166114360276512017071 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-VERSION (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-version.1 (loop for p in *pathnames* for version = (pathname-version p) unless (or (integerp version) (symbolp version)) collect (list p version)) nil) ;;; section 19.3.2.1 (deftest pathname-version.2 (loop for p in *logical-pathnames* when (eq (pathname-version p) :unspecific) collect p) nil) (deftest pathname-version.3 (do-special-strings (s "" nil) (pathname-version s)) nil) (deftest pathname-version.error.1 (signals-error (pathname-version) program-error) t) (deftest pathname-version.error.2 (signals-error (pathname-version *default-pathname-defaults* nil) program-error) t) (deftest pathname-version.error.3 (check-type-error #'pathname-version #'could-be-pathname-designator) nil) gcl-2.6.14/ansi-tests/make-hash-table.lsp0000644000175000017500000000056614360276512016537 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:36:33 2003 ;;;; Contains: Tests for MAKE-HASH-TABLE (in-package :cl-test) #| (deftest make-hash-table.1 (let ((ht (make-hash-table))) (values (check-values (typep ht 'hash-table)) (notnot (check-values (hash-table-p ht))) (check-values (hash-table-count ht)) |# gcl-2.6.14/ansi-tests/search-string.lsp0000644000175000017500000001072014360276512016356 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on strings (in-package :cl-test) ;;; The next test was busted due to to a stupid cut and paste ;;; error. The loop terminates immediately, doing nothing ;;; useful. -- PFD #| (deftest search-string.1 (let ((target *searched-string*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) |# (deftest search-string.2 (let ((target *searched-string*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-string.3 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-string.4 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-string.5 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-string.6 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-string.7 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-string.8 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-string.9 (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) (let ((target *searched-string*)) (loop for pat in *pattern-sublists* for pos = (search pat target :start2 20 :key #'%f) unless (search-check pat target pos :start2 20 :key #'%f) collect pat))) nil) (deftest search-string.10 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-string.11 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-string.13 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-string.14 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-string.15 (let ((a (make-array '(10) :initial-contents "abbaaababb" :fill-pointer 5 :element-type 'character))) (values (search "a" a) (search "a" a :from-end t) (search "ab" a) (search "ab" a :from-end t) (search "aba" a) (search "aba" a :from-end t))) 0 4 0 0 nil nil) (deftest search-string.16 (let ((pat (make-array '(3) :initial-contents '(#\a #\b #\a) :fill-pointer 1)) (a "abbaa")) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl-2.6.14/ansi-tests/directory-namestring.lsp0000644000175000017500000000270314360276512017760 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:21:42 2004 ;;;; Contains: Tests for DIRECTORY-NAMESTRING (in-package :cl-test) (deftest directory-namestring.1 (let* ((vals (multiple-value-list (directory-namestring "directory-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (directory-namestring s) s)) :good vals)) :good) (deftest directory-namestring.2 (do-special-strings (s "directory-namestring.lsp" nil) (let ((ns (directory-namestring s))) (assert (stringp ns)) (assert (string= (directory-namestring ns) ns)))) nil) ;;; Lispworks makes another assumption about filename normalization ;;; when using file streams as pathname designators, so this test ;;; doesn't work there. ;;; (This is another example of the difficulty of testing a feature ;;; in which so much is left up to the implementation.) #-lispworks (deftest directory-namestring.3 (let* ((name "directory-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (directory-namestring s))) (name3 (directory-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest directory-namestring.error.1 (signals-error (directory-namestring) program-error) t) (deftest directory-namestring.error.2 (signals-error (directory-namestring "directory-namestring.lsp" nil) program-error) t) gcl-2.6.14/ansi-tests/count-if-not.lsp0000644000175000017500000003252414360276512016135 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 22:42:35 2002 ;;;; Contains: Tests for COUNT-IF-NOT (in-package :cl-test) (deftest count-if-not-list.1 (count-if-not #'identity '(a b nil c d nil e)) 2) (deftest count-if-not-list.2 (count-if-not #'not '(a b nil c d nil e)) 5) (deftest count-if-not-list.3 (count-if-not #'(lambda (x) (break)) nil) 0) (deftest count-if-not-list.4 (count-if-not #'identity '(a b nil c d nil e) :key #'identity) 2) (deftest count-if-not-list.5 (count-if-not 'identity '(a b nil c d nil e) :key #'identity) 2) (deftest count-if-not-list.6 (count-if-not #'identity '(a b nil c d nil e) :key 'identity) 2) (deftest count-if-not-list.8 (count-if-not #'identity '(a b nil c d nil e) :key 'not) 5) (deftest count-if-not-list.9 (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-not-list.10 (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-not-list.11 (let ((c 0)) (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-list.12 (let ((c 0)) (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-list.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-list.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-list.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-list.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; tests on vectors (deftest count-if-not-vector.1 (count-if-not #'identity #(a b nil c d nil e)) 2) (deftest count-if-not-vector.2 (count-if-not #'not #(a b nil c d nil e)) 5) (deftest count-if-not-vector.3 (count-if-not #'(lambda (x) (break)) #()) 0) (deftest count-if-not-vector.4 (count-if-not #'not #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-not-vector.5 (count-if-not 'not #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-not-vector.6 (count-if-not #'not #(a b nil c d nil e) :key 'identity) 5) (deftest count-if-not-vector.8 (count-if-not #'not #(a b nil c d nil e) :key 'not) 2) (deftest count-if-not-vector.9 (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-not-vector.10 (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-not-vector.11 (let ((c 0)) (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-vector.12 (let ((c 0)) (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-not-nonsimple-vector.1 (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 2) (deftest count-if-not-nonsimple-vector.2 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.3 (count-if-not #'(lambda (x) (break)) (make-array 0 :fill-pointer t :adjustable t)) 0) (deftest count-if-not-nonsimple-vector.4 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-not-nonsimple-vector.5 (count-if-not 'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-not-nonsimple-vector.6 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'identity) 5) (deftest count-if-not-nonsimple-vector.8 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'not) 2) (deftest count-if-not-nonsimple-vector.9 (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.10 (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'1+) 4) (deftest count-if-not-nonsimple-vector.11 (let ((c 0)) (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-nonsimple-vector.12 (let ((c 0)) (count-if-not #'oddp (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) :fill-pointer t :adjustable t) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-nonsimple-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-not-nonsimple-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-not-nonsimple-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-not-nonsimple-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) 1) (deftest count-if-not-nonsimple-vector.17 (flet ((%a (c) (not (eqt c 'a))) (%f (c) (not (eqt c 'f)))) (let ((a (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer 9))) (values (count-if-not #'%a a) (count-if-not #'%a a :from-end t) (count-if-not #'%f a) (count-if-not #'%f a :from-end t) ))) 3 3 1 1) ;;; tests on bit-vectors (deftest count-if-not-bit-vector.1 (count-if-not #'oddp #*001011101101) 5) (deftest count-if-not-bit-vector.2 (count-if-not #'identity #*001011101101) 0) (deftest count-if-not-bit-vector.3 (count-if-not #'(lambda (x) (break)) #*) 0) (deftest count-if-not-bit-vector.4 (count-if-not #'identity #*001011101101 :key #'zerop) 7) (deftest count-if-not-bit-vector.5 (count-if-not 'not #*001011101101 :key #'zerop) 5) (deftest count-if-not-bit-vector.6 (count-if-not #'not #*001011101101 :key 'zerop) 5) (deftest count-if-not-bit-vector.8 (count-if-not #'identity #*001011101101 :key 'oddp) 5) (deftest count-if-not-bit-vector.10 (count-if-not #'oddp #*001011101101 :key #'1+) 7) (deftest count-if-not-bit-vector.11 (let ((c 0)) (count-if-not #'oddp #*001011101101 :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-not-bit-vector.12 (let ((c 0)) (count-if-not #'oddp #*001011101101 :from-end t :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-not-bit-vector.13 (count-if-not #'zerop #*0111011011100 :start 2) 7) (deftest count-if-not-bit-vector.14 (count-if-not #'zerop #*0111011011100 :end 7) 5) (deftest count-if-not-bit-vector.15 (count-if-not #'zerop #*0111011011100 :end 7 :start 2) 4) (deftest count-if-not-bit-vector.16 (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 4) (deftest count-if-not-bit-vector.17 (let ((a (make-array '(10) :initial-contents '(0 0 0 1 1 1 0 1 0 0) :fill-pointer 5 :element-type 'bit))) (and (bit-vector-p a) (values (count-if-not #'zerop a) (count-if-not #'oddp a) (count-if-not #'zerop a :from-end t) (count-if-not #'oddp a :from-end t)))) 2 3 2 3) ;;; tests on strings (deftest count-if-not-string.1 (count-if-not #'(lambda (x) (eql x #\0)) "001011101101") 7) (deftest count-if-not-string.2 (count-if-not #'identity "001011101101") 0) (deftest count-if-not-string.3 (count-if-not #'(lambda (x) (break)) "") 0) (deftest count-if-not-string.4 (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 7) (deftest count-if-not-string.5 (count-if-not 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 7) (deftest count-if-not-string.6 (count-if-not #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) 7) (deftest count-if-not-string.8 (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) 5) (deftest count-if-not-string.11 (let ((c 0)) (count-if-not #'oddp "001011101101" :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-not-string.12 (let ((c 0)) (count-if-not #'oddp "001011101101" :from-end t :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-not-string.13 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) 7) (deftest count-if-not-string.14 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 5) (deftest count-if-not-string.15 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 4) (deftest count-if-not-string.16 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2 :from-end t) 4) (deftest count-if-not-string.17 (flet ((%zerop (c) (eql c #\0)) (%onep (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "0001110100" :fill-pointer 5 :element-type 'character))) (and (stringp a) (values (count-if-not #'%zerop a) (count-if-not #'%onep a) (count-if-not #'%zerop a :from-end t) (count-if-not #'%onep a :from-end t))))) 2 3 2 3) ;;; Argument order tests (deftest count-if-not.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if-not (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'not) :from-end (progn (setf c6 (incf i)) nil) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) (deftest count-if-not.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if-not (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :from-end (progn (setf c3 (incf i)) nil) :key (progn (setf c4 (incf i)) #'not) :end (progn (setf c5 (incf i)) 3) :start (progn (setf c6 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) ;;; Keyword tests (deftest count-if-not.keywords.1 (count-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest count-if-not.keywords.2 (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if-not.keywords.3 (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count-if-not.keywords.4 (count-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest count-if-not.allow-other-keys.5 (count-if-not #'null '(nil a b c nil) :allow-other-keys nil) 3) ;;; Error tests (deftest count-if-not.error.1 (classify-error (count-if-not #'identity 1)) type-error) (deftest count-if-not.error.2 (classify-error (count-if-not #'identity 'a)) type-error) (deftest count-if-not.error.3 (classify-error (count-if-not #'identity #\a)) type-error) (deftest count-if-not.error.4 (classify-error (count-if-not)) program-error) (deftest count-if-not.error.5 (classify-error (count-if-not #'null)) program-error) (deftest count-if-not.error.6 (classify-error (count-if-not #'null nil :bad t)) program-error) (deftest count-if-not.error.7 (classify-error (count-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest count-if-not.error.8 (classify-error (count-if-not #'null nil :key)) program-error) (deftest count-if-not.error.9 (classify-error (count-if-not #'null nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if-not.error.10 (classify-error (count-if-not #'null nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count-if-not.error.11 (classify-error (locally (count-if-not #'identity 1) t)) type-error) (deftest count-if-not.error.12 (classify-error (count-if-not #'cons '(a b c))) program-error) (deftest count-if-not.error.13 (classify-error (count-if-not #'car '(a b c))) type-error) (deftest count-if-not.error.14 (classify-error (count-if-not #'identity '(a b c) :key #'cdr)) type-error) (deftest count-if-not.error.15 (classify-error (count-if-not #'identity '(a b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/char-schar.lsp0000644000175000017500000000723214360276512015624 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 21:04:44 2002 ;;;; Contains: Tests of CHAR and SCHAR accessors (in-package :cl-test) (deftest char.1 (let ((s "abcd")) (values (char s 0) (char s 1) (char s 2) (char s 3))) #\a #\b #\c #\d) (deftest char.2 (let ((s0 (copy-seq "abcd")) (s1 (copy-seq "abcd")) (s2 (copy-seq "abcd")) (s3 (copy-seq "abcd"))) (setf (char s0 0) #\X) (setf (char s1 1) #\X) (setf (char s2 2) #\X) (setf (char s3 3) #\X) (values s0 s1 s2 s3)) "Xbcd" "aXcd" "abXd" "abcX") (deftest char.3 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (setf (char s 3) #\X) s) "abcXef") (deftest char.4 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f) :fill-pointer 4))) (setf (char s 3) #\X) s) "abcX") (deftest char.5 (let ((s (make-string 5 :initial-element #\a))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.6 (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.7 (let ((s (make-string 5 :initial-element #\a :element-type 'character))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.8 (let ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f) :fill-pointer 4))) (setf (char s 5) #\X) (setf (fill-pointer s) 6) s) "abcdeX") (deftest char.9 (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.10 (let ((s (make-string 5 :initial-element #\a :element-type 'standard-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.order.1 (let ((i 0) a b) (values (char (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) (deftest char.order.2 (let ((i 0) a b c (s (make-string 5 :initial-element #\z))) (values (setf (char (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) ;;; Tests of schar (deftest schar.1 (let ((s "abcd")) (values (schar s 0) (schar s 1) (schar s 2) (schar s 3))) #\a #\b #\c #\d) (deftest schar.2 (let ((s0 (copy-seq "abcd")) (s1 (copy-seq "abcd")) (s2 (copy-seq "abcd")) (s3 (copy-seq "abcd"))) (setf (schar s0 0) #\X) (setf (schar s1 1) #\X) (setf (schar s2 2) #\X) (setf (schar s3 3) #\X) (values s0 s1 s2 s3)) "Xbcd" "aXcd" "abXd" "abcX") (deftest schar.3 (let ((s (make-string 6 :initial-element #\x))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.4 (let ((s (make-string 6 :initial-element #\x :element-type 'character))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.5 (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.6 (let ((s (make-string 6 :initial-element #\x :element-type 'base-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.7 (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) (setf (schar s 2) #\X) s) "xxXxxx") (deftest schar.order.1 (let ((i 0) a b) (values (schar (progn (setf a (incf i)) "abc") (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) (deftest schar.order.2 (let ((i 0) a b c (s (copy-seq "zzzzz"))) (values (setf (schar (progn (setf a (incf i)) s) (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) gcl-2.6.14/ansi-tests/cl-test-package.lsp0000644000175000017500000000053014360276512016547 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 14 10:13:21 1998 ;;;; Contains: CL test case package definition (defpackage :cl-test (:use :cl :regression-test) ;; #+gcl (:use defpackage) (:nicknames) (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") (:export)) #+cmu (import 'cl::quit :cl-test) gcl-2.6.14/ansi-tests/make-array.lsp0000644000175000017500000004534514360276512015651 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 20 06:47:37 2002 ;;;; Contains: Tests for MAKE-ARRAY (in-package :cl-test) ;;; See array-aux.lsp for auxiliary functions (deftest make-array.1 (let ((a (make-array-with-checks 10))) (and (symbolp a) a)) nil) (deftest make-array.1a (let ((a (make-array-with-checks '(10)))) (and (symbolp a) a)) nil) (deftest make-array.2 (make-array-with-checks 3 :initial-element 'z) #(z z z)) (deftest make-array.2a (make-array-with-checks 3 :initial-contents '(a b c)) #(a b c)) (deftest make-array.2b (make-array-with-checks 3 :initial-contents #(a b c)) #(a b c)) (deftest make-array.2c (make-array-with-checks 3 :initial-contents "abc") #(#\a #\b #\c)) (deftest make-array.2d (make-array-with-checks 3 :initial-contents #*010) #(0 1 0)) (deftest make-array.3 (let ((a (make-array-with-checks 5 :element-type 'bit))) (and (symbolp a) a)) nil) (deftest make-array.4 (make-array-with-checks 5 :element-type 'bit :initial-element 1) #*11111) (deftest make-array.4a (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) #*10010) (deftest make-array.4b (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) #*10010) (deftest make-array.4c (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) #*10010) (deftest make-array.5 (let ((a (make-array-with-checks 4 :element-type 'character))) (and (symbolp a) a)) nil) (deftest make-array.5a (let ((a (make-array-with-checks '(4) :element-type 'character))) (and (symbolp a) a)) nil) (deftest make-array.6 (make-array-with-checks 4 :element-type 'character :initial-element #\x) "xxxx") (deftest make-array.6a (make-array-with-checks 4 :element-type 'character :initial-contents '(#\a #\b #\c #\d)) "abcd") (deftest make-array.6b (make-array-with-checks 4 :element-type 'character :initial-contents "abcd") "abcd") (deftest make-array.7 (make-array-with-checks 5 :element-type 'symbol :initial-element 'a) #(a a a a a)) (deftest make-array.7a (make-array-with-checks 5 :element-type 'symbol :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.7b (make-array-with-checks '(5) :element-type 'symbol :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.8 (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) (and (symbolp a) a)) nil) (deftest make-array.8a (make-array-with-checks 8 :element-type '(integer 0 (256)) :initial-element 9) #(9 9 9 9 9 9 9 9)) (deftest make-array.8b (make-array-with-checks '(8) :element-type '(integer 0 (256)) :initial-contents '(4 3 2 1 9 8 7 6)) #(4 3 2 1 9 8 7 6)) ;;; Zero dimensional arrays (deftest make-array.9 (let ((a (make-array-with-checks nil))) (and (symbolp a) a)) nil) (deftest make-array.10 (make-array-with-checks nil :initial-element 1) #0a1) (deftest make-array.11 (make-array-with-checks nil :initial-contents 2) #0a2) (deftest make-array.12 (make-array-with-checks nil :element-type 'bit :initial-contents 1) #0a1) (deftest make-array.13 (make-array-with-checks nil :element-type t :initial-contents 'a) #0aa) ;;; Higher dimensional arrays (deftest make-array.14 (let ((a (make-array-with-checks '(2 3)))) (and (symbolp a) a)) nil) (deftest make-array.15 (make-array-with-checks '(2 3) :initial-element 'x) #2a((x x x) (x x x))) (deftest make-array.16 (equalpt (make-array-with-checks '(0 0)) (read-from-string "#2a()")) t) (deftest make-array.17 (make-array-with-checks '(2 3) :initial-contents '((a b c) (d e f))) #2a((a b c) (d e f))) (deftest make-array.18 (make-array-with-checks '(2 3) :initial-contents '(#(a b c) #(d e f))) #2a((a b c) (d e f))) (deftest make-array.19 (make-array-with-checks '(4) :initial-contents (make-array '(10) :initial-element 1 :fill-pointer 4)) #(1 1 1 1)) (deftest make-array.20 (let ((a (make-array '(10) :initial-element 1 :fill-pointer 4))) (make-array-with-checks '(3 4) :initial-contents (list a a a))) #2a((1 1 1 1) (1 1 1 1) (1 1 1 1))) (deftest make-array.21 (make-array-with-checks '(3 4) :initial-contents (make-array '(10) :initial-element '(1 2 3 4) :fill-pointer 3)) #2a((1 2 3 4) (1 2 3 4) (1 2 3 4))) (deftest make-array.22 (loop for i from 3 below (min array-rank-limit 128) always (equalpt (make-array-with-checks (make-list i :initial-element 0)) (read-from-string (format nil "#~Aa()" i)))) t) (deftest make-array.23 (let ((len (1- array-rank-limit))) (equalpt (make-array-with-checks (make-list len :initial-element 0)) (read-from-string (format nil "#~Aa()" len)))) t) (deftest make-array.24 (make-array-with-checks '(5) :initial-element 'a :displaced-to nil) #(a a a a a)) (deftest make-array.25 (make-array '(4) :initial-element 'x :nonsense-argument t :allow-other-keys t) #(x x x x)) (deftest make-array.26 (make-array '(4) :initial-element 'x :allow-other-keys nil) #(x x x x)) (deftest make-array.27 (make-array '(4) :initial-element 'x :allow-other-keys t :allow-other-keys nil :nonsense-argument t) #(x x x x)) (deftest make-array.28 (let ((*package* (find-package :cl-test))) (let ((len (1- (min 10000 array-rank-limit)))) (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) (read-from-string (concatenate 'string (format nil "#~dA" len) (make-string len :initial-element #\() "x" (make-string len :initial-element #\))))))) t) (deftest make-array.29 (make-array-with-checks '(5) :element-type '(integer 0 (256)) :initial-contents '(0 5 255 119 57)) #(0 5 255 119 57)) (deftest make-array.30 (make-array-with-checks '(5) :element-type '(integer -128 127) :initial-contents '(-10 5 -128 86 127)) #(-10 5 -128 86 127)) (deftest make-array.31 (make-array-with-checks '(5) :element-type '(integer 0 (65536)) :initial-contents '(0 100 65535 7623 13)) #(0 100 65535 7623 13)) (deftest make-array.32 (make-array-with-checks '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5)) #(1 2 3 4 5)) (deftest make-array.33 (make-array-with-checks '(5) :element-type 'short-float :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (deftest make-array.34 (make-array-with-checks '(5) :element-type 'single-float :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (deftest make-array.35 (make-array-with-checks '(5) :element-type 'double-float :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (deftest make-array.36 (make-array-with-checks '(5) :element-type 'long-float :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ;;; Adjustable arrays (deftest make-array.adjustable.1 (let ((a (make-array-with-checks '(10) :adjustable t))) (and (symbolp a) a)) nil) (deftest make-array.adjustable.2 (make-array-with-checks '(4) :adjustable t :initial-element 6) #(6 6 6 6)) (deftest make-array.adjustable.3 (make-array-with-checks nil :adjustable t :initial-element 7) #0a7) (deftest make-array.adjustable.4 (make-array-with-checks '(2 3) :adjustable t :initial-element 7) #2a((7 7 7) (7 7 7))) (deftest make-array.adjustable.5 (make-array-with-checks '(2 3) :adjustable t :initial-contents '((1 2 3) "abc")) #2a((1 2 3) (#\a #\b #\c))) (deftest make-array.adjustable.6 (make-array-with-checks '(4) :adjustable t :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.7 (make-array-with-checks '(4) :adjustable t :fill-pointer t :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.8 (make-array-with-checks '(4) :adjustable t :element-type '(integer 0 (256)) :initial-contents '(1 4 7 9)) #(1 4 7 9)) (deftest make-array.adjustable.9 (make-array-with-checks '(4) :adjustable t :element-type 'base-char :initial-contents "abcd") "abcd") (deftest make-array.adjustable.10 (make-array-with-checks '(4) :adjustable t :element-type 'bit :initial-contents '(0 1 1 0)) #*0110) (deftest make-array.adjustable.11 (make-array-with-checks '(4) :adjustable t :element-type 'symbol :initial-contents '(a b c d)) #(a b c d)) ;;; Displaced arrays (deftest make-array.displaced.1 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a)) #(a b c d e)) (deftest make-array.displaced.2 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a :displaced-index-offset 3)) #(d e f g h)) (deftest make-array.displaced.3 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a :displaced-index-offset 5)) #(f g h i j)) (deftest make-array.displaced.4 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(0) :displaced-to a :displaced-index-offset 10)) #()) (deftest make-array.displaced.5 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(5) :element-type '(integer 0 (256)) :displaced-to a)) #(1 3 5 7 9)) (deftest make-array.displaced.6 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type '(integer 0 (256)) :displaced-to a :displaced-index-offset i))) (#(1 3 5 7 9) #(3 5 7 9 11) #(5 7 9 11 13) #(7 9 11 13 15) #(9 11 13 15 17) #(11 13 15 17 19))) (deftest make-array.displaced.7 (let ((a (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(0) :element-type '(integer 0 (256)) :displaced-to a :displaced-index-offset 10)) #()) (deftest make-array.displaced.8 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(5) :element-type 'bit :displaced-to a)) #*01101) (deftest make-array.displaced.9 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'bit :displaced-to a :displaced-index-offset i))) (#*01101 #*11011 #*10111 #*01110 #*11101 #*11010)) (deftest make-array.displaced.10 (let ((a (make-array '(10) :element-type 'bit :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(0) :element-type 'bit :displaced-to a :displaced-index-offset 10)) #*) (deftest make-array.displaced.11 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'base-char :displaced-to a)) "abcde") (deftest make-array.displaced.12 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'base-char :displaced-to a :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" "defgh" "efghi" "fghij")) (deftest make-array.displaced.13 (let ((a (make-array '(10) :element-type 'base-char :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'base-char :displaced-to a :displaced-index-offset 10)) "") (deftest make-array.displaced.14 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'character :displaced-to a)) "abcde") (deftest make-array.displaced.15 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect (make-array-with-checks '(5) :element-type 'character :displaced-to a :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" "defgh" "efghi" "fghij")) (deftest make-array.displaced.16 (let ((a (make-array '(10) :element-type 'character :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'character :displaced-to a :displaced-index-offset 10)) "") ;;; Multidimensional displaced arrays (deftest make-array.displaced.17 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a)) #(1 2 3 4 5 6 7 8)) (deftest make-array.displaced.18 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a :displaced-index-offset 3)) #(4 5 6 7 8 9 10 11)) (deftest make-array.displaced.19 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) (9 10 11 12))))) (make-array-with-checks '(2 4) :displaced-to a :displaced-index-offset 4)) #2a((5 6 7 8) (9 10 11 12))) (deftest make-array.displaced.20 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(24) :displaced-to a)) #(a b c d e f g h i j k l m n o p q r s t u v w x)) (deftest make-array.displaced.21 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(3 8) :displaced-to a)) #2a((a b c d e f g h) (i j k l m n o p) (q r s t u v w x))) (deftest make-array.displaced.22 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5)) #(f g h i j k l m n o)) (deftest make-array.displaced.23 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer t)) #(f g h i j k l m n o)) (deftest make-array.displaced.24 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer 5)) #(f g h i j)) (deftest make-array.displaced.25 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :adjustable t)) #(f g h i j k l m n o)) (deftest make-array.displaced.26 (let ((a (make-array '(2 3 4) :initial-contents '(((a b c d) (e f g h) (i j k l)) ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a :displaced-index-offset 5 :fill-pointer 8 :adjustable t)) #(f g h i j k l m)) (deftest make-array.displaced.27 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer t))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.28 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 4))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.29 (let ((a (make-array '(10) :initial-element 0))) (prog1 (make-array-with-checks '(2 4) :displaced-to a) (loop for i below 10 do (setf (aref a i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.30 (let* ((a1 (make-array '(10) :initial-element 0)) (a2 (make-array '(10) :displaced-to a1))) (prog1 (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a2 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.31 (let* ((a1 (make-array '(10) :initial-element 0)) (a2 (make-array '(10) :displaced-to a1))) (prog1 (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a1 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) ;;; Keywords tests (deftest make-array.allow-other-keys.1 (make-array '(5) :initial-element 'a :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.2 (make-array '(5) :initial-element 'a :allow-other-keys nil) #(a a a a a)) (deftest make-array.allow-other-keys.3 (make-array '(5) :initial-element 'a :allow-other-keys t '#:bad t) #(a a a a a)) (deftest make-array.allow-other-keys.4 (make-array '(5) :initial-element 'a :bad t :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.5 (make-array '(5) :bad t :initial-element 'a :allow-other-keys t) #(a a a a a)) (deftest make-array.allow-other-keys.6 (make-array '(5) :bad t :initial-element 'a :allow-other-keys t :allow-other-keys nil :also-bad nil) #(a a a a a)) (deftest make-array.allow-other-keys.7 (make-array '(5) :allow-other-keys t :initial-element 'a) #(a a a a a)) (deftest make-array.keywords.8. (make-array '(5) :initial-element 'x :initial-element 'a) #(x x x x x)) ;;; Error tests (deftest make-array.error.1 (classify-error (make-array)) program-error) (deftest make-array.error.2 (classify-error (make-array '(10) :bad t)) program-error) (deftest make-array.error.3 (classify-error (make-array '(10) :allow-other-keys nil :bad t)) program-error) (deftest make-array.error.4 (classify-error (make-array '(10) :allow-other-keys nil :allow-other-keys t :bad t)) program-error) (deftest make-array.error.5 (classify-error (make-array '(10) :bad)) program-error) (deftest make-array.error.6 (classify-error (make-array '(10) 1 2)) program-error) ;;; Order of evaluation tests (deftest make-array.order.1 (let ((i 0) a b c d e) (values (make-array (progn (setf a (incf i)) 5) :initial-element (progn (setf b (incf i)) 'a) :fill-pointer (progn (setf c (incf i)) nil) :displaced-to (progn (setf d (incf i)) nil) :element-type (progn (setf e (incf i)) t) ) i a b c d e)) #(a a a a a) 5 1 2 3 4 5) (deftest make-array.order.2 (let ((i 0) a b c d e) (values (make-array (progn (setf a (incf i)) 5) :element-type (progn (setf b (incf i)) t) :displaced-to (progn (setf c (incf i)) nil) :fill-pointer (progn (setf d (incf i)) nil) :initial-element (progn (setf e (incf i)) 'a) ) i a b c d e)) #(a a a a a) 5 1 2 3 4 5) gcl-2.6.14/ansi-tests/wild-pathname-p.lsp0000644000175000017500000001265014360276512016600 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 16:54:55 2003 ;;;; Contains: Tests of WILD-PATHNAME-P (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest wild-pathname-p.1 (wild-pathname-p (make-pathname)) nil) (deftest wild-pathname-p.2 (loop for key in '(:host :device :directory :name :type :version nil) when (wild-pathname-p (make-pathname) key) collect key) nil) (deftest wild-pathname-p.3 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.4 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.5 (let ((p (make-pathname :directory :wild))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.6 (let ((p (make-pathname :directory :wild))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) (deftest wild-pathname-p.7 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.8 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.9 (let ((p (make-pathname :directory '(:absolute :wild)))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.10 (let ((p (make-pathname :directory '(:absolute :wild)))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) (deftest wild-pathname-p.11 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.12 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.13 (let ((p (make-pathname :directory '(:relative :wild)))) (notnot-mv (wild-pathname-p p :directory))) t) (deftest wild-pathname-p.14 (let ((p (make-pathname :directory '(:relative :wild)))) (loop for key in '(:host :device :name :type :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.15 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.16 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.17 (let ((p (make-pathname :name :wild))) (notnot-mv (wild-pathname-p p :name))) t) (deftest wild-pathname-p.18 (let ((p (make-pathname :name :wild))) (loop for key in '(:host :device :directory :type :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.19 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.20 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.21 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p :type))) t) (deftest wild-pathname-p.22 (let ((p (make-pathname :type :wild))) (loop for key in '(:host :device :directory :name :version) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.23 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p))) t) (deftest wild-pathname-p.24 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p nil))) t) (deftest wild-pathname-p.25 (let ((p (make-pathname :version :wild))) (notnot-mv (wild-pathname-p p :version))) t) (deftest wild-pathname-p.26 (let ((p (make-pathname :version :wild))) (loop for key in '(:host :device :directory :name :type) when (wild-pathname-p p key) collect key)) nil) ;;; (deftest wild-pathname-p.27 (loop for p in (append *pathnames* *logical-pathnames*) unless (if (wild-pathname-p p) (wild-pathname-p p nil) (not (wild-pathname-p p nil))) collect p) nil) (deftest wild-pathname-p.28 (loop for p in (append *pathnames* *logical-pathnames*) when (and (loop for key in '(:host :device :directory :name :type :version) thereis (wild-pathname-p p key)) (not (wild-pathname-p p))) collect p) nil) ;;; On streams associated with files (deftest wild-pathname-p.29 (with-open-file (s "foo.lsp" :direction :output :if-exists :append :if-does-not-exist :create) (wild-pathname-p s)) nil) (deftest wild-pathname-p.30 (let ((s (open "foo.lsp" :direction :output :if-exists :append :if-does-not-exist :create))) (close s) (wild-pathname-p s)) nil) ;;; logical pathname designators (deftest wild-pathname-p.31 (wild-pathname-p "CLTEST:FOO.LISP") nil) ;;; Odd strings (deftest wild-pathname-p.32 (do-special-strings (s "CLTEST:FOO.LISP" nil) (let ((vals (multiple-value-list (wild-pathname-p s)))) (assert (equal vals '(nil))))) nil) ;;; (deftest wild-pathname-p.error.1 (signals-error (wild-pathname-p) program-error) t) (deftest wild-pathname-p.error.2 (signals-error (wild-pathname-p *default-pathname-defaults* nil nil) program-error) t) (deftest wild-pathname-p.error.3 (check-type-error #'wild-pathname-p (typef '(or pathname string file-stream synonym-stream))) nil) (deftest wild-pathname-p.error.4 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (wild-pathname-p x)) (typef '(or pathname string file-stream synonym-stream))) nil) gcl-2.6.14/ansi-tests/output-stream-p.lsp0000644000175000017500000000157614360276512016704 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:46:12 2004 ;;;; Contains: Tests of OUTPUT-STREAM-P (in-package :cl-test) (deftest output-stream-p.1 (notnot-mv (output-stream-p *standard-output*)) t) (deftest output-stream-p.2 (notnot-mv (output-stream-p *terminal-io*)) t) (deftest output-stream-p.3 (with-open-file (s "output-stream-p.lsp" :direction :input) (output-stream-p s)) nil) (deftest output-stream-p.4 (with-open-file (s "foo.txt" :direction :output :if-exists :supersede) (notnot-mv (output-stream-p s))) t) ;;; Error tests (deftest output-stream-p.error.1 (signals-error (output-stream-p) program-error) t) (deftest output-stream-p.error.2 (signals-error (output-stream-p *standard-output* nil) program-error) t) (deftest output-stream-p.error.3 (check-type-error #'output-stream-p #'streamp) nil) gcl-2.6.14/ansi-tests/packages-06.lsp0000644000175000017500000001114214360276512015605 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:00:28 1998 ;;;; Contains: Package test code, part 06 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rename-package (deftest rename-package.1 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) (i 0) x y) (unless (packagep p) (return nil)) (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") (progn (setf y (incf i)) "TEST2")))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (eql i 2) (eql x 1) (eql y 2) (equal (package-name p2) "TEST2")) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.2 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (safely-delete-package "TEST3") (safely-delete-package "TEST4") (safely-delete-package "TEST5") (let ((p (make-package "TEST1")) (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) (unless (packagep p) (return nil)) (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.3 (block nil (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) (nicknames (copy-list '(#\M #\N)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) #'string<) (sort (mapcar #'(lambda (c) (make-string 1 :initial-element c)) nicknames) #'string<))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.4 (block nil (safely-delete-package "G") (safely-delete-package "TEST2") (let ((p (make-package "G")) (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (ignore-errors (safely-delete-package p2)) t))) t) (deftest rename-package.5 (block nil (safely-delete-package "TEST1") (safely-delete-package "G") (let ((p (make-package "TEST1")) (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "G") (null (set-exclusive-or nicknames (package-nicknames p2) :test #'equal))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.6 (block nil (safely-delete-package '|TEST1|) (safely-delete-package '|TEST2|) (safely-delete-package '|M|) (safely-delete-package '|N|) (let ((p (make-package '|TEST1|)) (nicknames (copy-list '(|M| |N|)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package '|TEST1| '|TEST2| nicknames)))) (unless (packagep p2) (safely-delete-package p) (return p2)) (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) #'string<) (sort (mapcar #'symbol-name nicknames) #'string<))) (safely-delete-package p) (safely-delete-package p2) (return nil)) (safely-delete-package p2) t))) t) (deftest rename-package.error.1 (classify-error (rename-package)) program-error) (deftest rename-package.error.2 (classify-error (rename-package "CL")) program-error) (deftest rename-package.error.3 (classify-error (rename-package "A" "XXXXX" NIL NIL)) program-error) gcl-2.6.14/ansi-tests/stream-element-type.lsp0000644000175000017500000000525514360276512017515 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 20:09:50 2004 ;;;; Contains: Tests for STREAM-ELEMENT-TYPE (in-package :cl-test) (deftest stream-element-type.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (stream-element-type s)) unless (and (eql (length results) 1) (car results)) collect s) nil) (deftest stream-element-type.2 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(unsigned-byte ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.3 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(signed-byte ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.4 (let ((pn "foo.txt")) (loop for i from 1 to 100 for etype = `(integer 0 ,i) for s = (progn (delete-all-versions pn) (open pn :direction :output :element-type etype)) unless (multiple-value-bind (sub good) (subtypep etype (stream-element-type s)) (close s) (or sub (not good))) collect i)) nil) (deftest stream-element-type.5 :notes (:assume-no-simple-streams) (let ((pn "foo.txt")) (delete-all-versions pn) (let ((s (open pn :direction :output))) (let ((etype (stream-element-type s))) (unwind-protect (equalt (multiple-value-list (subtypep* 'character etype)) '(nil t)) (close s))))) nil) (deftest stream-element-type.6 :notes (:assume-no-simple-streams) (let ((pn "foo.txt")) (delete-all-versions pn) (let ((s (open pn :direction :output :element-type :default))) (let ((etype (stream-element-type s))) (unwind-protect (multiple-value-bind (sub1 good1) (subtypep* etype 'integer) (multiple-value-bind (sub2 good2) (subtypep* etype 'character) (or (not good1) (not good2) sub1 sub2))) (close s))))) t) (deftest stream-element-type.error.1 (signals-error (stream-element-type) program-error) t) (deftest stream-element-type.error.2 (signals-error (stream-element-type *standard-input* nil) program-error) t) (deftest stream-element-type.error.3 (check-type-error #'stream-element-type #'streamp) nil) gcl-2.6.14/ansi-tests/gclload2.lsp0000644000175000017500000000222114360276512015271 0ustar cammcamm;;; Load test files ;;; Tests of symbols (load "load-symbols.lsp") ;;; Tests of evaluation and compilation (load "load-eval-and-compile.lsp") ;;; Tests of data and control flow (load "load-data-and-control-flow.lsp") ;;; Tests of iteration forms (load "load-iteration.lsp") ;;; Tests of conditions (load "load-conditions.lsp") ;;; Tests of conses (load "load-cons.lsp") ;;; Tests on arrays (load "load-arrays.lsp") ;;; Tests of hash tables (load "hash-table.lsp") (load "make-hash-table.lsp") ; More to come ;;; Tests of packages #-ecl (load "packages.lsp") ;;; Tests of sequences (load "load-sequences.lsp") ;;; Tests of structures (load "load-structures.lsp") ;;; Tests of types and classes (load "load-types-and-class.lsp") ;;; Tests of the reader (load "reader-test.lsp") ;;; Tests of strings (load "load-strings.lsp") ;;; Tests of pathnames (load "load-pathnames.lsp") ;;; Tests of file operations (load "load-files.lsp") ;;; Tests of streams (load "load-streams.lsp") ;;; Tests for character functions (compile-and-load "char-aux.lsp") (load "character.lsp") (load "char-compare.lsp") ;;; Tests of system construction (load "features.lsp") gcl-2.6.14/ansi-tests/force-output.lsp0000644000175000017500000000224314360276512016242 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:41:46 2004 ;;;; Contains: Tests of FORCE-OUTPUT (in-package :cl-test) (deftest force-output.1 (force-output) nil) (deftest force-output.2 (force-output t) nil) (deftest force-output.3 (force-output nil) nil) (deftest force-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (force-output s)) unless (equal results '(nil)) collect s) nil) (deftest force-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (force-output t))) nil) (deftest force-output.6 (let ((*standard-output* (make-string-output-stream))) (force-output nil)) nil) ;;; Error tests (deftest force-output.error.1 (signals-error (force-output nil nil) program-error) t) (deftest force-output.error.2 (signals-error (force-output t nil) program-error) t) (deftest force-output.error.3 (check-type-error #'force-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl-2.6.14/ansi-tests/string-left-trim.lsp0000644000175000017500000000715314360276512017022 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 04:57:41 2002 ;;;; Contains: Tests for STRING-LEFT-TRIM (in-package :cl-test) (deftest string-left-trim.1 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.2 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.3 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.4 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.5 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'character) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.6 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'standard-char) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.7 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) :element-type 'base-char) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.8 (let* ((s (copy-seq "abcdaba")) (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) :element-type 'character :fill-pointer 2) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'character )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type 'character :fill-pointer 7)) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'standard-char )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" :element-type 'base-char )) (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") ;;; Test that trimming is case sensitive (deftest string-left-trim.13 (let* ((s (copy-seq "aA")) (s2 (string-left-trim "a" s))) (values s s2)) "aA" "A") (deftest string-left-trim.14 (let* ((s '|abcdaba|) (s2 (string-left-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cdaba") (deftest string-left-trim.15 (string-left-trim "abc" "") "") (deftest string-left-trim.16 (string-left-trim "a" #\a) "") (deftest string-left-trim.17 (string-left-trim "b" #\a) "a") (deftest string-left-trim.18 (string-left-trim "" (copy-seq "abcde")) "abcde") (deftest string-left-trim.19 (string-left-trim "abc" (copy-seq "abcabcabc")) "") (deftest string-left-trim.order.1 (let ((i 0) x y) (values (string-left-trim (progn (setf x (incf i)) " ") (progn (setf y (incf i)) (copy-seq " abc d e f "))) i x y)) "abc d e f " 2 1 2) ;;; Error cases (deftest string-left-trim.error.1 (classify-error (string-left-trim)) program-error) (deftest string-left-trim.error.2 (classify-error (string-left-trim "abc")) program-error) (deftest string-left-trim.error.3 (classify-error (string-left-trim "abc" "abcdddabc" nil)) program-error) gcl-2.6.14/ansi-tests/functionp.lsp0000644000175000017500000000375714360276512015626 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 06:39:21 2002 ;;;; Contains: Tests for FUNCTIONP (in-package :cl-test) ;;; ;;; Note! FUNCTIONP and FUNCTION behave differently in ANSI CL than ;;; in CLTL1. In particular, symbols and various lists are no longer ;;; in the class FUNCTION in ANSI CL. ;;; (deftest functionp.1 (functionp nil) nil) ;;; In ANSI CL, symbols can no longer be functions (deftest functionp.2 (functionp 'identity) nil) (deftest functionp.3 (not (functionp #'identity)) nil) (deftest functionp.4 (loop for x in *cl-symbol-names* for s = (find-symbol x "CL") for f = (and (fboundp s) (symbol-function s) (not (special-operator-p s)) (not (macro-function s)) (symbol-function s)) unless (or (null f) (functionp f)) collect x) nil) (deftest functionp.5 (functionp '(setf car)) nil) ;;; In ANSI CL, lambda forms are no longer functions (deftest functionp.6 (functionp '(lambda (x) x)) nil) (eval-when (eval compile) (ignore-errors (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y))) (deftest functionp.7 (not-mv (functionp #'(setf functionp-7-accessor))) nil) (deftest functionp.8 (not-mv (functionp #'(lambda (x) x))) nil) (deftest functionp.9 (not-mv (functionp (compile nil '(lambda (x) x)))) nil) ;;; In ANSI CL, symbols and cons can no longer be functions (deftest functionp.10 (loop for x in *universe* when (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (functionp x)) collect x) nil) (deftest functionp.11 (flet ((%f () nil)) (functionp '%f)) nil) (deftest functionp.12 (flet ((%f () nil)) (not-mv (functionp #'%f))) nil) (deftest functionp.order.1 (let ((i 0)) (values (notnot (functionp (progn (incf i) #'cons))) i)) t 1) (deftest functionp.error.1 (classify-error (functionp)) program-error) (deftest functionp.error.2 (classify-error (functionp #'cons nil)) program-error) gcl-2.6.14/ansi-tests/ccase.lsp0000644000175000017500000000624314360276512014670 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 21:06:45 2002 ;;;; Contains: Tests of CCASE (in-package :cl-test) (deftest ccase.1 (let ((x 'b)) (ccase x (a 1) (b 2) (c 3))) 2) (deftest ccase.2 (classify-error (let ((x 1)) (ccase x))) type-error) (deftest ccase.3 (classify-error (let ((x 1)) (ccase x (a 1) (b 2) (c 3)))) type-error) ;;; It is legal to use T or OTHERWISE as key designators ;;; in CCASE forms. They have no special meaning here. (deftest ccase.4 (classify-error (let ((x 1)) (ccase x (t nil)))) type-error) (deftest ccase.5 (classify-error (let ((x 1)) (ccase x (otherwise nil)))) type-error) (deftest ccase.6 (let ((x 'b)) (ccase x ((a z) 1) ((y b w) 2) ((b c) 3))) 2) (deftest ccase.7 (let ((x 'z)) (ccase x ((a b c) 1) ((d e) 2) ((f z g) 3))) 3) (deftest ccase.8 (let ((x (1+ most-positive-fixnum))) (ccase x (#.(1+ most-positive-fixnum) 'a))) a) (deftest ccase.9 (classify-error (let (x) (ccase x (nil 'a)))) type-error) (deftest ccase.10 (let (x) (ccase x ((nil) 'a))) a) (deftest ccase.11 (let ((x 'a)) (ccase x (b 0) (a (values 1 2 3)) (c nil))) 1 2 3) (deftest ccase.12 (classify-error (let ((x t)) (ccase x (a 10)))) type-error) (deftest ccase.13 (let ((x t)) (ccase x ((t) 10) (t 20))) 10) (deftest ccase.14 (let ((x (list 'a 'b))) (eval `(let ((y (quote ,x))) (ccase y ((,x) 1) (a 2))))) 1) (deftest ccase.15 (classify-error (let ((x 'otherwise)) (ccase x ((t) 10)))) type-error) (deftest ccase.16 (classify-error (let ((x t)) (ccase x ((otherwise) 10)))) type-error) (deftest ccase.17 (classify-error (let ((x 'a)) (ccase x (b 0) (c 1) (otherwise 2)))) type-error) (deftest ccase.19 (classify-error (let ((x 'a)) (ccase x (b 0) (c 1) ((t) 2)))) type-error) (deftest ccase.20 (let ((x #\a)) (ccase x ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40))) 40) (deftest ccase.21 (let ((x 1)) (ccase x (1 (values)) (2 'a)))) (deftest ccase.23 (let ((x 1)) (ccase x (1 (values 'a 'b 'c)))) a b c) ;;; Show that the key expression is evaluated only once. (deftest ccase.25 (let ((a (vector 'a 'b 'c 'd 'e)) (i 1)) (values (ccase (aref a (incf i)) (a 1) (b 2) (c 3) (d 4)) i)) 3 2) ;;; Repeated keys are allowed (all but the first are ignored) (deftest ccase.26 (let ((x 'b)) (ccase x ((a b c) 10) (b 20))) 10) (deftest ccase.27 (let ((x 'b)) (ccase x (b 20) ((a b c) 10))) 20) (deftest ccase.28 (let ((x 'b)) (ccase x (b 20) (b 10) (d 0))) 20) ;;; There are implicit progns (deftest ccase.29 (let ((x nil) (y 2)) (values (ccase y (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (3 (setq x 'c) 'z)) x)) y b) (deftest ccase.30 (let ((x 'a)) (ccase x (a))) nil) (deftest ccase.31 (handler-bind ((type-error #'(lambda (c) (store-value 7 c)))) (let ((x 0)) (ccase x (1 :bad) (7 :good) (2 nil)))) :good) ;;; (deftest ccase.error.1 ;;; (classify-error (ccase)) ;;; program-error) gcl-2.6.14/ansi-tests/universe.lsp0000644000175000017500000002646614360276512015463 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Apr 9 19:32:56 1998 ;;;; Contains: A global variable containing a list of ;;;; as many kinds of CL objects as we can think of ;;;; This list is used to test many other CL functions (in-package :cl-test) (defvar *condition-types* '(arithmetic-error cell-error condition control-error division-by-zero end-of-file error file-error floating-point-inexact floating-point-invalid-operation floating-point-underflow floating-point-overflow package-error parse-error print-not-readable program-error reader-error serious-condition simple-condition simple-error simple-type-error simple-warning storage-condition stream-error style-warning type-error unbound-slot unbound-variable undefined-function warning)) (defvar *condition-objects* (loop for tp in *condition-types* append (handler-case (list (make-condition tp)) (error () nil)))) (defvar *standard-package-names* '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) (defvar *package-objects* (loop for pname in *standard-package-names* append (handler-case (let ((pkg (find-package pname))) (and pkg (list pkg))) (error () nil)))) (defvar *integers* (remove-duplicates `( 0 ;; Integers near the fixnum/bignum boundaries ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum)) ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum)) ;; Powers of two, negatives, and off by one. ,@(loop for i from 1 to 64 collect (ash 1 i)) ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) ,@(loop for i from 1 to 64 collect (ash -1 i)) ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) ;; A big integer ,(expt 17 50) ;; Some arbitrarily chosen integers 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) (defvar *floats* (append (loop for sym in '(pi most-positive-short-float least-positive-short-float least-positive-normalized-short-float most-positive-double-float least-positive-double-float least-positive-normalized-double-float most-positive-long-float least-positive-long-float least-positive-normalized-long-float most-positive-single-float least-positive-single-float least-positive-normalized-single-float most-negative-short-float least-negative-short-float least-negative-normalized-short-float most-negative-single-float least-negative-single-float least-negative-normalized-single-float most-negative-double-float least-negative-double-float least-negative-normalized-double-float most-negative-long-float least-negative-long-float least-negative-normalized-long-float short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon double-float-epsilon double-float-negative-epsilon long-float-epsilon long-float-negative-epsilon) when (boundp sym) collect (symbol-value sym)) (list 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 1.31283d2 834.13812D-45 8131238.1E14 -4618926.231e-2 -37818.131F3 81.318231f-19 1.31273s3 12361.12S-7 6124.124l0 13123.1L-23))) (defvar *ratios* '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 189729874978126783786123/1234678123487612347896123467851234671234)) (defvar *complexes* '(#C(0.0 0.0) #C(1.0 0.0) #C(0.0 1.0) #C(1.0 1.0) #C(-1.0 -1.0) #C(1289713.12312 -9.12681271) #C(1.0D100 1.0D100) #C(-1.0D-100 -1.0D-100))) (defvar *numbers* (append *integers* *floats* *ratios* *complexes*)) (defun try-to-read-chars (&rest namelist) (loop for name in namelist append (handler-case (list (read-from-string (concatenate 'string "\#\\" name))) (error () nil)))) (defvar *characters* (remove-duplicates `(#\Newline #\Space ,@(try-to-read-chars "Rubout" "Page" "Tab" "Backspace" "Return" "Linefeed" "Null") #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] ))) (defvar *strings* (append (and (code-char 0) (list (make-string 1 :initial-element (code-char 0)) (make-string 10 :initial-element (code-char 0)))) (list "" "A" "a" "0" "abcdef" "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" (make-string 100000 :initial-element #\g) (let ((s (make-string 256))) (loop for i from 0 to 255 do (let ((c (code-char i))) (when c (setf (elt s i) c)))) s) ))) (defvar *conses* (list (list 'a 'b) (list nil) (list 1 2 3 4 5 6))) (defvar *circular-conses* (list (let ((s (copy-list '(a b c d)))) (nconc s s) s) (let ((s (list nil))) (setf (car s) s) s) (let ((s (list nil))) (setf (car s) s) (setf (cdr s) s)))) (defvar *booleans* '(nil t)) (defvar *keywords* '(:a :b :|| :|a| :|1234|)) (defvar *uninterned-symbols* (list '#:nil '#:t '#:foo '#:||)) (defvar *cl-test-symbols* `(,(intern "a" :cl-test) ,(intern "" :cl-test) ,@(and (code-char 0) (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) ,@(and (code-char 0) (let* ((s (make-string 10 :initial-element (code-char 0))) (s2 (copy-seq s)) (s3 (copy-seq s))) (setf (subseq s 3 4) "a") (setf (subseq s2 4 5) "a") (setf (subseq s3 4 5) "a") (setf (subseq s3 7 8) "b") (list (intern s :cl-test) (intern s2 :cl-test) (intern s3 :cl-test)))) )) (defvar *cl-user-symbols* '(cl-user::foo cl-user::x cl-user::cons cl-user::lambda cl-user::*print-readably* cl-user::push)) (defvar *symbols* (append *booleans* *keywords* *uninterned-symbols* *cl-test-symbols* *cl-user-symbols*)) (defvar *array-dimensions* (loop for i from 0 to 8 collect (loop for j from 1 to i collect 2))) (defvar *default-array-target* (make-array '(300))) (defvar *arrays* (append (list (make-array '10)) (mapcar #'make-array *array-dimensions*) ;; typed arrays (loop for tp in '(fixnum float bit character base-char (signed-byte 8) (unsigned-byte 8)) append (loop for d in *array-dimensions* collect (make-array d :element-type tp))) ;; adjustable arrays (loop for d in *array-dimensions* collect (make-array d :adjustable t)) ;; Displaced arrays (loop for d in *array-dimensions* for i from 1 collect (make-array d :displaced-to *default-array-target* :displaced-index-offset i)) (list #() #* #*00000 #*1010101010101101) ;; Integer arrays (list (make-array '(10) :element-type '(integer 0 (256)) :initial-contents '(8 9 10 11 12 1 2 3 4 5)) (make-array '(10) :element-type '(integer -128 (128)) :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) :initial-contents '(5 9 100 1312 23432 87)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) :initial-contents '(100000 231213 8123712 19)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) (make-array nil :element-type '(integer 0 (256)) :initial-element 14) (make-array '(2 2) :element-type '(integer 0 (256)) :initial-contents '((34 98)(14 119))) ) ;; Float arrays (list (make-array '(5) :element-type 'short-float :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (make-array '(5) :element-type 'single-float :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (make-array '(5) :element-type 'double-float :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (make-array '(5) :element-type 'long-float :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ) ;; more kinds of arrays here later )) (defvar *hash-tables* (list (make-hash-table) (make-hash-table :test #'eq) (make-hash-table :test #'eql) (make-hash-table :test #'equal) #-(or GCL CMU ECL) (make-hash-table :test #'equalp) )) (defparameter *pathnames* (locally (declare (optimize safety)) (loop for form in '((make-pathname :name "foo") (make-pathname :name "FOO" :case :common) (make-pathname :name "bar") (make-pathname :name "foo" :type "txt") (make-pathname :name "bar" :type "txt") (make-pathname :name "XYZ" :type "TXT" :case :common) (make-pathname :name nil) (make-pathname :name :wild) (make-pathname :name nil :type "txt") (make-pathname :name :wild :type "txt") (make-pathname :name :wild :type "TXT" :case :common) (make-pathname :name :wild :type "abc" :case :common) (make-pathname :directory :wild) (make-pathname :type :wild) (make-pathname :version :wild) (make-pathname :version :newest)) append (ignore-errors (eval `(list ,form)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (locally (declare (optimize safety)) (ignore-errors (setf (logical-pathname-translations "CLTESTROOT") `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) :name :wild :type :wild))))) (ignore-errors (setf (logical-pathname-translations "CLTEST") `(("**;*.*.*" ,(make-pathname :directory (append (pathname-directory (truename (make-pathname))) '(:wild-inferiors)) :name :wild :type :wild))))) )) (defparameter *logical-pathnames* (locally (declare (optimize safety)) (append (ignore-errors (list (logical-pathname "CLTESTROOT:"))) ))) (defvar *streams* (remove-duplicates (remove-if #'null (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *terminal-io* *trace-output*)))) (defvar *readtables* (list *readtable* (copy-readtable))) (defstruct foo-structure x y z) (defstruct bar-structure x y z) (defvar *structures* (list (make-foo-structure :x 1 :y 'a :z nil) (make-foo-structure :x 1 :y 'a :z nil) (make-bar-structure :x 1 :y 'a :z nil) )) (defvar *functions* (list #'cons #'car #'append #'values (macro-function 'cond) #'(lambda (x) x))) (defvar *random-states* (list (make-random-state))) (defvar *universe* (remove-duplicates (append *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *streams* *readtables* *structures* *functions* *random-states* nil))) (defvar *mini-universe* (remove-duplicates (mapcar #'first (list *symbols* *numbers* *characters* (mapcar #'copy-seq *strings*) *conses* *condition-objects* *package-objects* *arrays* *hash-tables* *pathnames* *streams* *readtables* *structures* *functions* *random-states*)))) gcl-2.6.14/ansi-tests/rt-package.lsp0000644000175000017500000000103214360276512015617 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 17 21:10:53 2002 ;;;; Contains: Package definition for RT (eval-when ;;(:execute :compile-toplevel :load-toplevel) (load eval compile) (defpackage :regression-test (:use :cl) (:nicknames :rtest #-lispworks :rt) (:export #:*do-tests-when-defined* #:*test* #:continue-testing #:deftest #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test ))) (in-package :regression-test) gcl-2.6.14/ansi-tests/terpri.lsp0000644000175000017500000000231214360276512015110 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:35:57 2004 ;;;; Contains: Tests of TERPRI (in-package :cl-test) (deftest terpri.1 (let (result) (values (with-output-to-string (*standard-output*) (write-char #\a) (setq result (terpri))) result)) #.(concatenate 'string "a" (string #\Newline)) nil) (deftest terpri.2 (let (result) (values (with-output-to-string (s) (write-char #\a s) (setq result (terpri s))) result)) #.(concatenate 'string "a" (string #\Newline)) nil) (deftest terpri.3 (with-output-to-string (s) (write-char #\x s) (terpri s) (terpri s) (write-char #\y s)) #.(concatenate 'string "x" (string #\Newline) (string #\Newline) "y")) (deftest terpri.4 (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream *standard-input* os))) (terpri t) (finish-output t))) #.(string #\Newline)) (deftest terpri.5 (with-output-to-string (*standard-output*) (terpri nil)) #.(string #\Newline)) ;;; Error tests (deftest terpri.error.1 (signals-error (with-output-to-string (s) (terpri s nil)) program-error) t) gcl-2.6.14/ansi-tests/subtypep-eql.lsp0000644000175000017500000000245414360276512016244 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:58:43 2003 ;;;; Contains: Tests for subtype relationships on EQL types (in-package :cl-test) (deftest subtypep.eql.1 (let ((s1 (copy-seq "abc")) (s2 (copy-seq "abc"))) (let ((t1 `(eql ,s1)) (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.eql.2 (let ((s1 (copy-seq '(a b c))) (s2 (copy-seq '(a b c)))) (let ((t1 `(eql ,s1)) (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) (deftest subtypep.eql.3 (let ((i1 (1+ most-positive-fixnum)) (i2 (1+ most-positive-fixnum))) (check-equivalence `(eql ,i1) `(eql ,i2))) nil) (deftest subtypep.eql.4 (check-equivalence '(and (eql a) (eql b)) nil) nil) (deftest subtypep.eql.5 (check-all-subtypep '(eql a) '(satisfies symbolp)) nil) (deftest subtypep.eql.6 (check-disjointness '(eql 17) '(satisfies symbolp)) nil) (deftest subtypep.eql.7 (check-all-subtypep '(eql nil) '(satisfies symbolp)) nil) (deftest subtypep.eql.8 (check-all-not-subtypep '(satisfies symbolp) '(eql a)) nil) gcl-2.6.14/ansi-tests/tagbody.lsp0000644000175000017500000000450414360276512015241 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 13:27:22 2002 ;;;; Contains: Tests of TAGBODY (in-package :cl-test) (deftest tagbody.1 (tagbody) nil) (deftest tagbody.2 (tagbody 'a) nil) (deftest tagbody.3 (tagbody (values)) nil) (deftest tagbody.4 (tagbody (values 1 2 3 4 5)) nil) (deftest tagbody.5 (let ((x 0)) (values (tagbody (setq x 1) (go a) (setq x 2) a) x)) nil 1) (deftest tagbody.6 (let ((x 0)) (tagbody (setq x 1) (go a) b (setq x 2) (go c) a (setq x 3) (go b) c) x) 2) ;;; Macroexpansion occurs after tag determination (deftest tagbody.7 (let ((x 0)) (macrolet ((%m () 'a)) (tagbody (tagbody (go a) (%m) (setq x 1)) a )) x) 0) (deftest tagbody.8 (let ((x 0)) (tagbody (flet ((%f (y) (setq x y) (go a))) (%f 10)) (setq x 1) a) x) 10) ;;; Tag names are in their own name space (deftest tagbody.9 (let (result) (tagbody (flet ((a (x) x)) (setq result (a 10)) (go a)) a) result) 10) (deftest tagbody.10 (let (result) (tagbody (block a (setq result 10) (go a)) (setq result 20) a) result) 10) (deftest tagbody.11 (let (result) (tagbody (catch 'a (setq result 10) (go a)) (setq result 20) a) result) 10) (deftest tagbody.12 (let (result) (tagbody (block a (setq result 10) (return-from a nil)) (setq result 20) a) result) 20) ;;; Test that integers are accepted as go tags (deftest tagbody.13 (block done (tagbody (go around) 10 (return-from done 'good) around (go 10))) good) (deftest tagbody.14 (block done (tagbody (go around) -10 (return-from done 'good) around (go -10))) good) (deftest tagbody.15 (block done (tagbody (go around) #.(1+ most-positive-fixnum) (return-from done 'good) around (go #.(1+ most-positive-fixnum)))) good) (deftest tagbody.16 (let* ((t1 (1+ most-positive-fixnum)) (t2 (1+ most-positive-fixnum)) (form `(block done (tagbody (go around) ,t1 (return-from done 'good) around (go ,t2))))) (eval form)) good) gcl-2.6.14/ansi-tests/if.lsp0000644000175000017500000000100114360276512014173 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 08:21:29 2002 ;;;; Contains: Tests for IF (in-package :cl-test) (deftest if.1 (if t 1 2) 1) (deftest if.2 (if nil 1 2) 2) (deftest if.3 (if t (values) 'a)) (deftest if.4 (if nil 'a) nil) (deftest if.5 (if t (values 'a 'b 'c) 'd) a b c) (deftest if.6 (if nil 'a (values 'b 'c 'd)) b c d) (deftest if.7 (if nil 'a (values))) (deftest if.order.1 (let ((i 0)) (values (if (= (incf i) 1) 't nil) i)) t 1) gcl-2.6.14/ansi-tests/simple-array-t.lsp0000644000175000017500000001263414360276512016461 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:23:45 2003 ;;;; Contains: Tests of SIMPLE-ARRAY on T element type (in-package :cl-test) ;;; Tests of (simple-array t) (deftest simple-array-t.2.1 (notnot-mv (typep #() '(simple-array t))) t) (deftest simple-array-t.2.2 (notnot-mv (typep #0aX '(simple-array t))) t) (deftest simple-array-t.2.3 (notnot-mv (typep #2a(()) '(simple-array t))) t) (deftest simple-array-t.2.4 (notnot-mv (typep #(1 2 3) '(simple-array t))) t) (deftest simple-array-t.2.5 (typep "abcd" '(simple-array t)) nil) (deftest simple-array-t.2.6 (typep #*010101 '(simple-array t)) nil) ;;; Tests of (simple-array t ()) (deftest simple-array-t.3.1 (notnot-mv (typep #() '(simple-array t nil))) nil) (deftest simple-array-t.3.2 (notnot-mv (typep #0aX '(simple-array t nil))) t) (deftest simple-array-t.3.3 (typep #2a(()) '(simple-array t nil)) nil) (deftest simple-array-t.3.4 (typep #(1 2 3) '(simple-array t nil)) nil) (deftest simple-array-t.3.5 (typep "abcd" '(simple-array t nil)) nil) (deftest simple-array-t.3.6 (typep #*010101 '(simple-array t nil)) nil) ;;; Tests of (simple-array t 1) ;;; The '1' indicates rank, so this is equivalent to 'vector' (deftest simple-array-t.4.1 (notnot-mv (typep #() '(simple-array t 1))) t) (deftest simple-array-t.4.2 (typep #0aX '(simple-array t 1)) nil) (deftest simple-array-t.4.3 (typep #2a(()) '(simple-array t 1)) nil) (deftest simple-array-t.4.4 (notnot-mv (typep #(1 2 3) '(simple-array t 1))) t) (deftest simple-array-t.4.5 (typep "abcd" '(simple-array t 1)) nil) (deftest simple-array-t.4.6 (typep #*010101 '(simple-array t 1)) nil) ;;; Tests of (simple-array t 0) (deftest simple-array-t.5.1 (typep #() '(simple-array t 0)) nil) (deftest simple-array-t.5.2 (notnot-mv (typep #0aX '(simple-array t 0))) t) (deftest simple-array-t.5.3 (typep #2a(()) '(simple-array t 0)) nil) (deftest simple-array-t.5.4 (typep #(1 2 3) '(simple-array t 0)) nil) (deftest simple-array-t.5.5 (typep "abcd" '(simple-array t 0)) nil) (deftest simple-array-t.5.6 (typep #*010101 '(simple-array t 0)) nil) ;;; Tests of (simple-array t *) (deftest simple-array-t.6.1 (notnot-mv (typep #() '(simple-array t *))) t) (deftest simple-array-t.6.2 (notnot-mv (typep #0aX '(simple-array t *))) t) (deftest simple-array-t.6.3 (notnot-mv (typep #2a(()) '(simple-array t *))) t) (deftest simple-array-t.6.4 (notnot-mv (typep #(1 2 3) '(simple-array t *))) t) (deftest simple-array-t.6.5 (typep "abcd" '(simple-array t *)) nil) (deftest simple-array-t.6.6 (typep #*010101 '(simple-array t *)) nil) ;;; Tests of (simple-array t 2) (deftest simple-array-t.7.1 (typep #() '(simple-array t 2)) nil) (deftest simple-array-t.7.2 (typep #0aX '(simple-array t 2)) nil) (deftest simple-array-t.7.3 (notnot-mv (typep #2a(()) '(simple-array t 2))) t) (deftest simple-array-t.7.4 (typep #(1 2 3) '(simple-array t 2)) nil) (deftest simple-array-t.7.5 (typep "abcd" '(simple-array t 2)) nil) (deftest simple-array-t.7.6 (typep #*010101 '(simple-array t 2)) nil) ;;; Testing '(simple-array t (--)) (deftest simple-array-t.8.1 (typep #() '(simple-array t (1))) nil) (deftest simple-array-t.8.2 (notnot-mv (typep #() '(simple-array t (0)))) t) (deftest simple-array-t.8.3 (notnot-mv (typep #() '(simple-array t (*)))) t) (deftest simple-array-t.8.4 (typep #(a b c) '(simple-array t (2))) nil) (deftest simple-array-t.8.5 (notnot-mv (typep #(a b c) '(simple-array t (3)))) t) (deftest simple-array-t.8.6 (notnot-mv (typep #(a b c) '(simple-array t (*)))) t) (deftest simple-array-t.8.7 (typep #(a b c) '(simple-array t (4))) nil) (deftest simple-array-t.8.8 (typep #2a((a b c)) '(simple-array t (*))) nil) (deftest simple-array-t.8.9 (typep #2a((a b c)) '(simple-array t (3))) nil) (deftest simple-array-t.8.10 (typep #2a((a b c)) '(simple-array t (1))) nil) (deftest simple-array-t.8.11 (typep "abc" '(simple-array t (2))) nil) (deftest simple-array-t.8.12 (typep "abc" '(simple-array t (3))) nil) (deftest simple-array-t.8.13 (typep "abc" '(simple-array t (*))) nil) (deftest simple-array-t.8.14 (typep "abc" '(simple-array t (4))) nil) ;;; Two dimensional simple-array type tests (deftest simple-array-t.9.1 (typep #() '(simple-array t (* *))) nil) (deftest simple-array-t.9.2 (typep "abc" '(simple-array t (* *))) nil) (deftest simple-array-t.9.3 (typep #(a b c) '(simple-array t (3 *))) nil) (deftest simple-array-t.9.4 (typep #(a b c) '(simple-array t (* 3))) nil) (deftest simple-array-t.9.5 (typep "abc" '(simple-array t (3 *))) nil) (deftest simple-array-t.9.6 (typep "abc" '(simple-array t (* 3))) nil) (deftest simple-array-t.9.7 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* *)))) t) (deftest simple-array-t.9.8 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 *)))) t) (deftest simple-array-t.9.9 (typep #2a((a b)(c d)(e f)) '(simple-array t (2 *))) nil) (deftest simple-array-t.9.10 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* 2)))) t) (deftest simple-array-t.9.11 (typep #2a((a b)(c d)(e f)) '(simple-array t (* 3))) nil) (deftest simple-array-t.9.12 (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 2)))) t) (deftest simple-array-t.9.13 (typep #2a((a b)(c d)(e f)) '(simple-array t (2 3))) nil) gcl-2.6.14/ansi-tests/load-test-file-2.lsp0000644000175000017500000000030314360276512016551 0ustar cammcamm(in-package :cl-test) (declaim (special *load-test-var.1* *load-test-var.2*)) (eval-when (:load-toplevel) (setq *load-test-var.1* *load-pathname*) (setq *load-test-var.2* *load-truename*)) gcl-2.6.14/ansi-tests/echo-stream-output-stream.lsp0000644000175000017500000000135514360276512020647 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:32:33 2004 ;;;; Contains: Tests off ECHO-STREAM-OUTPUT-STREAM (in-package :cl-test) (deftest echo-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-output-stream s)) (list os))) t) (deftest echo-stream-output-stream.error.1 (signals-error (echo-stream-output-stream) program-error) t) (deftest echo-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (echo-stream-output-stream s nil)) program-error) t) gcl-2.6.14/ansi-tests/cons-test-19.lsp0000644000175000017500000004237114360276512015762 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 11:53:33 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 19 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intersection (deftest intersection.1 (intersection nil nil) nil) (deftest intersection.2 (intersection (loop for i from 1 to 100 collect i) nil) nil) (deftest intersection.3 (intersection nil (loop for i from 1 to 100 collect i)) nil) (deftest intersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) (xcopy (make-scaffold-copy x)) (y (copy-list '(3 y c q z a 18))) (ycopy (make-scaffold-copy y)) (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (+ (loop for e in x count (and (member e y) (not (member e result)))) (loop for e in result count (or (not (member e x)) (not (member e y)))) (loop for hd on result count (and (consp hd) (member (car hd) (cdr hd))))))) 0) (deftest intersection.5 (let* ((x (copy-list '(a a a))) (xcopy (make-scaffold-copy x)) (y (copy-list '(a a a b b b))) (ycopy (make-scaffold-copy y)) (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (member 'a result) (not (member 'b result)))) t) (deftest intersection.6 (intersection (list 1000000000000 'a 'b 'c) (list (1+ 999999999999) 'd 'e 'f)) (1000000000000)) (deftest intersection.7 (intersection (list 'a 10 'b 17) (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest intersection.8 (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e)) nil) (deftest intersection.9 (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test #'equal) ("aaa")) ;; Same as 9, but with a symbol function designator for :test (deftest intersection.9-a (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test 'equal) ("aaa")) (deftest intersection.9-b (intersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test-not #'(lambda (p q) (not (equal p q)))) ("aaa")) (deftest intersection.10 (equalt (sort (intersection (loop for i from 0 to 1000 by 3 collect i) (loop for i from 0 to 1000 by 7 collect i)) #'<) (loop for i from 0 to 1000 by 21 collect i)) t) (deftest intersection.11 (equalt (sort (intersection (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test #'(lambda (a b) (and (eql a b) (= (mod a 3) 0)))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) (deftest intersection.11-a (equalt (sort (intersection (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test-not #'(lambda (a b) (not (and (eql a b) (= (mod a 3) 0))))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) ;; ;; Do large numbers of random intersection tests ;; (deftest intersection.12 (intersection-12-body 100 100) nil) ;; ;; :key argument ;; (deftest intersection.13 (let ((x (copy-list '(0 5 8 13 31 42))) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key #'1+)) #'<))) t) ;; Same as 13, but with a symbol function designator for :key (deftest intersection.13-a (let ((x (copy-list '(0 5 8 13 31 42))) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key '1+)) #'<))) t) ;; Test that a nil key argument is ignored (deftest intersection.14 (let ((result (intersection (copy-list '(a b c d)) (copy-list '(e c f b g)) :key nil))) (and (member 'b result) (member 'c result) (every #'(lambda (x) (member x '(b c))) result) t)) t) ;; Test that intersection preserves the order of arguments to :test, :test-not (deftest intersection.15 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest intersection.16 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest intersection.17 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) (deftest intersection.18 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) ;;; Order of argument evaluation tests (deftest intersection.order.1 (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) (deftest intersection.order.2 (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test #'eq) i x y)) nil 2 1 2) (deftest intersection.order.3 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :test (progn (setf w (incf i)) (complement #'eq))) i x y z w)) nil 4 1 2 3 4) (deftest intersection.order.4 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) (deftest intersection.order.5 (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) ;;; Keyword tests (deftest intersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest intersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest intersectionallow-other-keys.3 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest intersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t)) (4)) (deftest intersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys nil)) (4)) (deftest intersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t :allow-other-keys nil :bad t)) (4)) (deftest intersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t :allow-other-keys nil :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest intersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (intersection list1 list2 :test #'(lambda (x y) (eql x (1- y))) :test #'eql)) #'<) (3 4)) ;;; Error tests (deftest intersection.error.1 (classify-error (intersection)) program-error) (deftest intersection.error.2 (classify-error (intersection nil)) program-error) (deftest intersection.error.3 (classify-error (intersection nil nil :bad t)) program-error) (deftest intersection.error.4 (classify-error (intersection nil nil :key)) program-error) (deftest intersection.error.5 (classify-error (intersection nil nil 1 2)) program-error) (deftest intersection.error.6 (classify-error (intersection nil nil :bad t :allow-other-keys nil)) program-error) (deftest intersection.error.7 (classify-error (intersection '(a b c) '(d e f) :test #'identity)) program-error) (deftest intersection.error.8 (classify-error (intersection '(a b c) '(d e f) :test-not #'identity)) program-error) (deftest intersection.error.9 (classify-error (intersection '(a b c) '(d e f) :key #'cons)) program-error) (deftest intersection.error.10 (classify-error (intersection '(a b c) '(d e f) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nintersection (deftest nintersection.1 (nintersection nil nil) nil) (deftest nintersection.2 (nintersection (loop for i from 1 to 100 collect i) nil) nil) (deftest nintersection.3 (nintersection-with-check nil (loop for i from 1 to 100 collect i)) nil) (deftest nintersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) (xc (copy-list x)) (y (copy-list '(3 y c q z a 18))) (result (nintersection-with-check xc y))) (and (not (eqt result 'failed)) (+ (loop for e in x count (and (member e y) (not (member e result)))) (loop for e in result count (or (not (member e x)) (not (member e y)))) (loop for hd on result count (and (consp hd) (member (car hd) (cdr hd))))))) 0) (deftest nintersection.5 (let* ((x (copy-list '(a a a))) (y (copy-list '(a a a b b b))) (result (nintersection-with-check x y))) (and (not (eqt result 'failed)) (member 'a result) (not (member 'b result)))) t) (deftest nintersection.6 (nintersection-with-check (list 1000000000000 'a 'b 'c) (list (1+ 999999999999) 'd 'e 'f)) (1000000000000)) (deftest nintersection.7 (nintersection-with-check (list 'a 10 'b 17) (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest nintersection.8 (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e)) nil) (deftest nintersection.9 (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test #'equal) ("aaa")) (deftest nintersection.9-a (nintersection-with-check (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test 'equal) ("aaa")) (deftest nintersection.9-b (nintersection (list 'a (copy-seq "aaa") 'b) (list 'd (copy-seq "aaa") 'e) :test-not #'(lambda (p q) (not (equal p q)))) ("aaa")) (deftest nintersection.10 (equalt (sort (let ((result (nintersection-with-check (loop for i from 0 to 1000 by 3 collect i) (loop for i from 0 to 1000 by 7 collect i)))) (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 1000 by 21 collect i)) t) (deftest nintersection.11 (equalt (sort (let ((result (nintersection-with-check (loop for i from 0 to 999 by 5 collect i) (loop for i from 0 to 999 by 7 collect i) :test #'(lambda (a b) (and (eql a b) (= (mod a 3) 0)))))) (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) (deftest nintersection.12 (nintersection-12-body 100 100) nil) ;; Key argument (deftest nintersection.13 (let ((x '(0 5 8 13 31 42)) (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (nintersection (copy-list x) y)) #'<) (sort (copy-list (nintersection (copy-list x) y :key #'1+)) #'<))) t) ;; Check that a nil key argument is ignored (deftest nintersection.14 (let ((result (nintersection (copy-list '(a b c d)) (copy-list '(e c f b g)) :key nil))) (and (member 'b result) (member 'c result) (every #'(lambda (x) (member x '(b c))) result) t)) t) ;; Test that nintersection preserves the order of arguments to :test, :test-not (deftest nintersection.15 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest nintersection.16 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))))) (4)) (deftest nintersection.17 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) (deftest nintersection.18 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))))) (4)) ;;; Order of argument evaluation tests (deftest nintersection.order.1 (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) (deftest nintersection.order.2 (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test #'eq) i x y)) nil 2 1 2) (deftest nintersection.order.3 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :test (progn (setf w (incf i)) (complement #'eq))) i x y z w)) nil 4 1 2 3 4) (deftest nintersection.order.4 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :test (progn (setf z (incf i)) #'eq) :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) (deftest nintersection.order.5 (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) (progn (setf y (incf i)) (list 'c 'd)) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) ;;; Keyword tests (deftest nintersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest nintersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest nintersection.allow-other-keys.3 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t)) (4)) (deftest nintersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys nil)) (4)) (deftest nintersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t :allow-other-keys nil :bad t)) (4)) (deftest nintersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t :allow-other-keys nil :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest nintersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :test #'(lambda (x y) (eql x (1- y))) :test #'eql)) #'<) (3 4)) (deftest nintersection.allow-other-keys.9 (let ((list1 (list 1 2 3 4)) (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.error.1 (classify-error (nintersection)) program-error) (deftest nintersection.error.2 (classify-error (nintersection nil)) program-error) (deftest nintersection.error.3 (classify-error (nintersection nil nil :bad t)) program-error) (deftest nintersection.error.4 (classify-error (nintersection nil nil :key)) program-error) (deftest nintersection.error.5 (classify-error (nintersection nil nil 1 2)) program-error) (deftest nintersection.error.6 (classify-error (nintersection nil nil :bad t :allow-other-keys nil)) program-error) (deftest nintersection.error.7 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity)) program-error) (deftest nintersection.error.8 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity)) program-error) (deftest nintersection.error.9 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons)) program-error) (deftest nintersection.error.10 (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car)) type-error) gcl-2.6.14/ansi-tests/get-setf-expansion.lsp0000644000175000017500000000062014360276512017323 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 17:05:17 2003 ;;;; Contains: Tests for GET-SETF-EXPANSION (in-package :cl-test) (deftest get-setf-expansion.error.1 (classify-error (get-setf-expansion)) program-error) (deftest get-setf-expansion.error.2 (classify-error (get-setf-expansion 'x nil nil)) program-error) ;;; Tests for proper behavior will go here gcl-2.6.14/ansi-tests/reverse.lsp0000644000175000017500000000475714360276512015275 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 23:47:28 2002 ;;;; Contains: Tests for REVERSE (in-package :cl-test) (deftest reverse-list.1 (reverse nil) nil) (deftest reverse-list.2 (let ((x '(a b c))) (values (reverse x) x)) (c b a) (a b c)) (deftest reverse-vector.1 (reverse #()) #()) (deftest reverse-vector.2 (let ((x #(a b c d e))) (values (reverse x) x)) #(e d c b a) #(a b c d e)) (deftest reverse-nonsimple-vector.1 (let ((x (make-array 0 :fill-pointer t :adjustable t))) (reverse x)) #()) (deftest reverse-nonsimple-vector.2 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) :fill-pointer t :adjustable t)) (y (reverse x))) (values y x)) #(5 4 3 2 1) #(1 2 3 4 5)) (deftest reverse-nonsimple-vector.3 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) :fill-pointer 5)) (y (reverse x))) y) #(5 4 3 2 1)) (deftest reverse-bit-vector.1 (reverse #*) #*) (deftest reverse-bit-vector.2 (let ((x #*000110110110)) (values (reverse x) x)) #*011011011000 #*000110110110) (deftest reverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) :fill-pointer 5 :element-type 'bit)) (y (reverse x))) y) #*11000) (deftest reverse-string.1 (reverse "") "") (deftest reverse-string.2 (let ((x "000110110110")) (values (reverse x) x)) "011011011000" "000110110110") (deftest reverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'character)) (y (reverse x))) y) "edcba") (deftest reverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" :fill-pointer 5 :element-type 'base-char)) (y (reverse x))) y) "edcba") (deftest reverse.order.1 (let ((i 0)) (values (reverse (progn (incf i) (list 'a 'b 'c 'd))) i)) (d c b a) 1) ;;; Error cases (deftest reverse.error.1 (classify-error (reverse 'a)) type-error) (deftest reverse.error.2 (classify-error (reverse #\a)) type-error) (deftest reverse.error.3 (classify-error (reverse 10)) type-error) (deftest reverse.error.4 (classify-error (reverse 0.3)) type-error) (deftest reverse.error.5 (classify-error (reverse 10/3)) type-error) (deftest reverse.error.6 (classify-error (reverse)) program-error) (deftest reverse.error.7 (classify-error (reverse nil nil)) program-error) (deftest reverse.error.8 (classify-error (locally (reverse 'a) t)) type-error) gcl-2.6.14/ansi-tests/loop2.lsp0000644000175000017500000000521214360276512014640 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 26 13:45:45 2002 ;;;; Contains: Tests of the FOR-AS-IN-LIST loop iteration control form, ;;;; and of destructuring in loop forms (in-package :cl-test) (deftest loop.2.1 (loop for x in '(1 2 3) sum x) 6) (deftest loop.2.2 (loop for x in '(1 2 3 4) do (when (evenp x) (return x))) 2) (deftest loop.2.3 (classify-error (loop for x in '(a . b) collect x)) type-error) (deftest loop.2.4 (let ((x nil)) (loop for e in '(a b c d) do (push e x)) x) (d c b a)) (deftest loop.2.5 (loop for e in '(a b c d e f) by #'cddr collect e) (a c e)) (deftest loop.2.6 (loop for e in '(a b c d e f g) by #'cddr collect e) (a c e g)) (deftest loop.2.7 (loop for e in '(a b c d e f) by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) collect e) (a a a a a a)) (deftest loop.2.8 (loop for (x . y) in '((a . b) (c . d) (e . f)) collect (list x y)) ((a b) (c d) (e f))) (deftest loop.2.9 (loop for (x nil y) in '((a b c) (d e f) (g h i)) collect (list x y)) ((a c) (d f) (g i))) (deftest loop.2.10 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.11 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.12 (loop for (x y) of-type (fixnum fixnum) in '((1 2) (3 4) (5 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.13 (loop for (x . y) of-type (fixnum . fixnum) in '((1 . 2) (3 . 4) (5 . 6)) collect (+ x y)) (3 7 11)) (deftest loop.2.14 (classify-error (loop for x in '(a b c) for x in '(d e f) collect x)) program-error) (deftest loop.2.15 (classify-error (loop for (x . x) in '((a b) (c d)) collect x)) program-error) (deftest loop.2.16 (loop for nil in nil do (return t)) nil) (deftest loop.2.17 (let ((x '(a b c))) (values x (loop for x in '(d e f) collect (list x)) x)) (a b c) ((d) (e) (f)) (a b c)) (deftest loop.2.18 (loop for x of-type (integer 0 10) in '(2 4 6 7) sum x) 19) ;;; Tests of the 'AS' form (deftest loop.2.19 (loop as x in '(1 2 3) sum x) 6) (deftest loop.2.20 (loop as x in '(a b c) as y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.21 (loop as x in '(a b c) for y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.22 (loop for x in '(a b c) as y in '(1 2 3) collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.23 (let (a b (i 0)) (values (loop for e in (progn (setf a (incf i)) '(a b c d e f g)) by (progn (setf b (incf i)) #'cddr) collect e) a b i)) (a c e g) 1 2 2) gcl-2.6.14/ansi-tests/values-list.lsp0000644000175000017500000000141214360276512016053 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 13 16:53:39 2003 ;;;; Contains: Tests for VALUES-LIST (in-package :cl-test) (deftest values-list.error.1 (classify-error (values-list)) program-error) (deftest values-list.error.2 (classify-error (values-list nil nil)) program-error) (deftest values-list.1 (values-list nil)) (deftest values-list.2 (values-list '(1)) 1) (deftest values-list.3 (values-list '(1 2)) 1 2) (deftest values-list.4 (values-list '(a b c d e f g h i j)) a b c d e f g h i j) (deftest values-list.5 (let ((x (loop for i from 1 to (min 1000 (1- call-arguments-limit) (1- multiple-values-limit)) collect i))) (equalt x (multiple-value-list (values-list x)))) t) gcl-2.6.14/ansi-tests/defparameter.lsp0000644000175000017500000000327014360276512016246 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:13:22 2002 ;;;; Contains: Tests of DEFPARAMETER (in-package :cl-test) (defparameter *defparameter-test-var-1* 100) (deftest defparameter.1 *defparameter-test-var-1* 100) (deftest defparameter.2 (documentation '*defparameter-test-var-1* 'variable) nil) ;;; Show that it's declared special. (deftest defparameter.3 (flet ((%f () *defparameter-test-var-1*)) (let ((*defparameter-test-var-1* 29)) (%f))) 29) (deftest defparameter.4 (values (makunbound '*defparameter-test-var-2*) (defparameter *defparameter-test-var-2* 200 "Whatever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2*) *defparameter-test-var-2* *defparameter-test-var-2* "Whatever." 200) (deftest defparameter.5 (values (makunbound '*defparameter-test-var-2*) (defparameter *defparameter-test-var-2* 200 "Whatever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2* (defparameter *defparameter-test-var-2* 300 "And ever.") (documentation '*defparameter-test-var-2* 'variable) *defparameter-test-var-2* ) *defparameter-test-var-2* *defparameter-test-var-2* "Whatever." 200 *defparameter-test-var-2* "And ever." 300) ;;; (deftest defparameter.error.1 ;;; (classify-error (defparameter)) ;;; program-error) ;;; ;;; (deftest defparameter.error.2 ;;; (classify-error (defparameter *ignored-defparameter-name*)) ;;; program-error) ;;; ;;; (deftest defparameter.error.3 ;;; (classify-error (defparameter *ignored-defparameter-name* nil ;;; "documentation" ;;; "illegal extra argument")) ;;; program-error) gcl-2.6.14/ansi-tests/gclload1.lsp0000644000175000017500000000167014360276512015277 0ustar cammcamm(load "compile-and-load.lsp") (load "rt-package.lsp") (compile-and-load "rt.lsp") ;;; (unless (probe-file "rt.o") (compile-file "rt.lsp")) ;;; (load "rt.o") (load "cl-test-package.lsp") (in-package :cl-test) (load "universe.lsp") (compile-and-load "random-aux.lsp") (compile-and-load "ansi-aux.lsp") ;;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp")) ;;; (load "ansi-aux.o") (load "cl-symbol-names.lsp") ;(load "notes.lsp") (setq *compile-verbose* nil *compile-print* nil *load-verbose* nil) #+cmu (setq ext:*gc-verbose* nil) #+gcl (setq compiler:*suppress-compiler-notes* t compiler:*suppress-compiler-warnings* t compiler:*compile-verbose* nil compiler:*compile-print* nil) #+lispworks (setq compiler::*compiler-warnings* nil) #+ecl (setq c:*suppress-compiler-warnings* t c:*suppress-compiler-notes* t) #+clisp (setq custom::*warn-on-floating-point-contagion* nil) gcl-2.6.14/ansi-tests/cons-test-21.lsp0000644000175000017500000002160414360276512015747 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 22:11:27 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 21 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nunion (deftest nunion.1 (nunion nil nil) nil) (deftest nunion.2 (nunion-with-copy (list 'a) nil) (a)) (deftest nunion.3 (nunion-with-copy (list 'a) (list 'a)) (a)) (deftest nunion.4 (nunion-with-copy (list 1) (list 1)) (1)) (deftest nunion.5 (let ((x (list 'a 'b))) (nunion-with-copy (list x) (list x))) ((a b))) (deftest nunion.6 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y))) (check-union x y result))) t) (deftest nunion.6-a (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eq))) (check-union x y result))) t) (deftest nunion.7 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eql))) (check-union x y result))) t) (deftest nunion.8 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'equal))) (check-union x y result))) t) (deftest nunion.9 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest nunion.10 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.11 (let ((x '(a b c d e f)) (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) (check-union x y result))) t) (deftest nunion.12 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y))) (check-union x y result))) t) (deftest nunion.13 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'equal))) (check-union x y result))) t) (deftest nunion.14 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'eql))) (check-union x y result))) t) (deftest nunion.15 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.16 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest nunion.17 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+))) (check-union x y result))) t) (deftest nunion.18 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) (check-union x y result))) t) (deftest nunion.19 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) (check-union x y result))) t) (deftest nunion.20 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.21 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test-not (complement #'equal)))) (check-union x y result))) t) (deftest nunion.22 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y nil))) (check-union x y result))) t) (deftest nunion.23 (let ((x '(1 2 3 4 5 6 7)) (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y '1+))) (check-union x y result))) t) ;; Do large numbers of random nunions (deftest nunion.24 (do-random-nunions 100 100 200) nil) (deftest nunion.25 (let ((x (shuffle '(1 4 6 10 45 101))) (y '(102 5 2 11 44 6))) (let ((result (nunion-with-copy x y :test #'(lambda (a b) (<= (abs (- a b)) 1))))) (sort (sublis '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) (copy-list result)) #'<))) (1 4 6 10 44 101)) ;; Check that nunion uses eql, not equal or eq (deftest nunion.26 (let ((x 1000) (y 1000)) (loop while (not (typep x 'bignum)) do (progn (setf x (* x x)) (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (nunion-with-copy (list x) (list x))) 1)))) t) (deftest nunion.27 (nunion-with-copy (list (copy-seq "aa")) (list (copy-seq "aa"))) ("aa" "aa")) ;; Check that nunion does not reverse the arguments to :test, :test-not (deftest nunion.28 (block fail (sort (nunion-with-copy '(1 2 3) '(4 5 6) :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest nunion.29 (block fail (sort (nunion-with-copy-and-key '(1 2 3) '(4 5 6) #'identity :test #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (eql x y))) #'<)) (1 2 3 4 5 6)) (deftest nunion.30 (block fail (sort (nunion-with-copy '(1 2 3) '(4 5 6) :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) (deftest nunion.31 (block fail (sort (nunion-with-copy-and-key '(1 2 3) '(4 5 6) #'identity :test-not #'(lambda (x y) (when (< y x) (return-from fail 'fail)) (not (eql x y)))) #'<)) (1 2 3 4 5 6)) ;;; Order of evaluation tests (deftest nunion.order.1 (let ((i 0) x y) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) 2 1 2) (deftest nunion.order.2 (let ((i 0) x y z w) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :test (progn (setf z (incf i)) #'eql) :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) (deftest nunion.order.3 (let ((i 0) x y z w) (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) (progn (setf y (incf i)) (copy-list '(2 5 8))) :key (progn (setf z (incf i)) #'identity) :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) 4 1 2 3 4) ;;; Keyword tests (deftest nunion.allow-other-keys.1 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t :allow-other-keys "yes") #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.2 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :also-bad t) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.3 (sort (nunion (list 1 2 3) (list 1 2 3) :allow-other-keys t :also-bad t :test #'(lambda (x y) (= x (+ y 100)))) #'<) (1 1 2 2 3 3)) (deftest nunion.allow-other-keys.4 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.5 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.6 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.7 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :allow-other-keys t :allow-other-keys nil '#:x 1) #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.keywords.9 (sort (nunion (list 1 2 3) (list 1 2 3) :test #'(lambda (x y) (= x (+ y 100))) :test #'eql) #'<) (1 1 2 2 3 3)) ;;; Error tests (deftest nunion.error.1 (classify-error (nunion)) program-error) (deftest nunion.error.2 (classify-error (nunion nil)) program-error) (deftest nunion.error.3 (classify-error (nunion nil nil :bad t)) program-error) (deftest nunion.error.4 (classify-error (nunion nil nil :key)) program-error) (deftest nunion.error.5 (classify-error (nunion nil nil 1 2)) program-error) (deftest nunion.error.6 (classify-error (nunion nil nil :bad t :allow-other-keys nil)) program-error) (deftest nunion.error.7 (classify-error (nunion (list 1 2) (list 3 4) :test #'identity)) program-error) (deftest nunion.error.8 (classify-error (nunion (list 1 2) (list 3 4) :test-not #'identity)) program-error) (deftest nunion.error.9 (classify-error (nunion (list 1 2) (list 3 4) :key #'cons)) program-error) (deftest nunion.error.10 (classify-error (nunion (list 1 2) (list 3 4) :key #'car)) type-error) gcl-2.6.14/ansi-tests/cell-error-name.lsp0000644000175000017500000000226714360276512016600 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 27 22:36:48 2003 ;;;; Contains: Tests of CELL-ERROR-NAME (in-package :cl-test) (deftest cell-error-name.1 (handler-case (eval 'my-unbound-variable) (cell-error (c) (cell-error-name c))) my-unbound-variable) (deftest cell-error-name.2 (handler-case (eval '(my-undefined-function)) ;; (warning (c) (muffle-warning c)) (cell-error (c) (cell-error-name c))) my-undefined-function) (deftest cell-error-name.3 (cell-error-name (make-condition 'unbound-variable :name 'x)) x) (deftest cell-error-name.4 (cell-error-name (make-condition 'undefined-function :name 'f)) f) (deftest cell-error-name.5 (cell-error-name (make-condition 'unbound-slot :name 's)) s) (deftest cell-error-name.6 (let ((i 0)) (values (cell-error-name (progn (incf i) (make-condition 'unbound-slot :name 's))) i)) s 1) ;;; Need test raising condition unbound-slot (deftest cell-error-name.error.1 (classify-error (cell-error-name)) program-error) (deftest cell-error-name.error.2 (classify-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil)) program-error) gcl-2.6.14/ansi-tests/nsubstitute-if-not.lsp0000644000175000017500000005740614360276512017404 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 19:00:55 2002 ;;;; Contains: Tests for NSUBSTITUTE-IF-NOT (in-package :cl-test) (deftest nsubstitute-if-not-list.1 (nsubstitute-if-not 'b 'identity nil) nil) (deftest nsubstitute-if-not-list.2 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x) x) (b b b c)) (deftest nsubstitute-if-not-list.3 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil)) (b b b c)) (deftest nsubstitute-if-not-list.4 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) (b b b c)) (deftest nsubstitute-if-not-list.5 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) (b b a c)) (deftest nsubstitute-if-not-list.6 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) (a b a c)) (deftest nsubstitute-if-not-list.7 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) (a b a c)) (deftest nsubstitute-if-not-list.8 (nsubstitute-if-not 'b (is-not-eq-p 'a) nil :from-end t) nil) (deftest nsubstitute-if-not-list.9 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) (b b b c)) (deftest nsubstitute-if-not-list.10 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) (b b b c)) (deftest nsubstitute-if-not-list.11 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) (b b b c)) (deftest nsubstitute-if-not-list.12 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) (a b b c)) (deftest nsubstitute-if-not-list.13 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) (a b a c)) (deftest nsubstitute-if-not-list.14 (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) (a b a c)) (deftest nsubstitute-if-not-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors (deftest nsubstitute-if-not-vector.1 (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) #()) (deftest nsubstitute-if-not-vector.2 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) #(b b b c)) (deftest nsubstitute-if-not-vector.3 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil) x) #(b b b c)) (deftest nsubstitute-if-not-vector.4 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) #(b b b c)) (deftest nsubstitute-if-not-vector.5 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) #(b b a c)) (deftest nsubstitute-if-not-vector.6 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) #(a b a c)) (deftest nsubstitute-if-not-vector.7 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) #(a b a c)) (deftest nsubstitute-if-not-vector.8 (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) #()) (deftest nsubstitute-if-not-vector.9 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) #(b b b c)) (deftest nsubstitute-if-not-vector.10 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) #(b b b c)) (deftest nsubstitute-if-not-vector.11 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) #(b b b c)) (deftest nsubstitute-if-not-vector.12 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) #(a b b c)) (deftest nsubstitute-if-not-vector.13 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) #(a b a c)) (deftest nsubstitute-if-not-vector.14 (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) #(a b a c)) (deftest nsubstitute-if-not-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest nsubstitute-if-not-string.1 (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) "") (deftest nsubstitute-if-not-string.2 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) "bbbc") (deftest nsubstitute-if-not-string.3 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count nil)) "bbbc") (deftest nsubstitute-if-not-string.4 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2)) "bbbc") (deftest nsubstitute-if-not-string.5 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1)) "bbac") (deftest nsubstitute-if-not-string.6 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0)) "abac") (deftest nsubstitute-if-not-string.7 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1)) "abac") (deftest nsubstitute-if-not-string.8 (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) "") (deftest nsubstitute-if-not-string.9 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.10 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil)) "bbbc") (deftest nsubstitute-if-not-string.11 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t)) "bbbc") (deftest nsubstitute-if-not-string.12 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t)) "abbc") (deftest nsubstitute-if-not-string.13 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t)) "abac") (deftest nsubstitute-if-not-string.14 (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t)) "abac") (deftest nsubstitute-if-not-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bit-vectors (deftest nsubstitute-if-not-bit-vector.1 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.2 (let* ((orig #*) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 1))) result) #*011111) (deftest nsubstitute-if-not-bit-vector.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-not-bit-vector.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :end 4))) result) #*111101) (deftest nsubstitute-if-not-bit-vector.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-not-bit-vector.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-not-bit-vector.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-not-bit-vector.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-not-bit-vector.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-not-bit-vector.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (nsubstitute-if-not 1 (is-not-eq-p 0) x :start i :end j :count c))) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-not-bit-vector.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (nsubstitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1))))))) t) ;;; More tests (deftest nsubstitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) result) "a1a2342a15") (deftest nsubstitute-if-not-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-not-bit-vector.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) result) #*11111111111111111) (deftest nsubstitute-if-not-bit-vector.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest nsubstitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) (deftest nsubstitute-if-not.order.1 (let ((i 0) a b c d e f g h) (values (nsubstitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest nsubstitute-if-not.order.2 (let ((i 0) a b c d e f g h) (values (nsubstitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest nsubstitute-if-not.allow-other-keys.1 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.2 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.3 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.4 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.5 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest nsubstitute-if-not.keywords.6 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest nsubstitute-if-not.allow-other-keys.7 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.8 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (a a 0 a a 0 a)) ;;; Error cases (deftest nsubstitute-if-not.error.1 (classify-error (nsubstitute-if-not)) program-error) (deftest nsubstitute-if-not.error.2 (classify-error (nsubstitute-if-not 'a)) program-error) (deftest nsubstitute-if-not.error.3 (classify-error (nsubstitute-if-not 'a #'null)) program-error) (deftest nsubstitute-if-not.error.4 (classify-error (nsubstitute-if-not 'a #'null nil 'bad t)) program-error) (deftest nsubstitute-if-not.error.5 (classify-error (nsubstitute-if-not 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest nsubstitute-if-not.error.6 (classify-error (nsubstitute-if-not 'a #'null nil :key)) program-error) (deftest nsubstitute-if-not.error.7 (classify-error (nsubstitute-if-not 'a #'null nil 1 2)) program-error) (deftest nsubstitute-if-not.error.8 (classify-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c))) program-error) (deftest nsubstitute-if-not.error.9 (classify-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c))) type-error) (deftest nsubstitute-if-not.error.10 (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest nsubstitute-if-not.error.11 (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/packages-00.lsp0000644000175000017500000000132714360276512015603 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:07:31 1998 ;;;; Contains: Package test code (common code) (in-package :cl-test) (declaim (optimize (safety 3))) (defpackage "A" (:use) (:nicknames "Q") (:export "FOO")) (defpackage "B" (:use "A") (:export "BAR")) (defpackage "DS1" (:use) (:intern "C" "D") (:export "A" "B")) (defpackage "DS2" (:use) (:intern "E" "F") (:export "G" "H" "A")) (defpackage "DS3" (:shadow "B") (:shadowing-import-from "DS1" "A") (:use "DS1" "DS2") (:export "A" "B" "G" "I" "J" "K") (:intern "L" "M")) (defpackage "DS4" (:shadowing-import-from "DS1" "B") (:use "DS1" "DS3") (:intern "X" "Y" "Z") (:import-from "DS2" "F")) gcl-2.6.14/ansi-tests/listen.lsp0000644000175000017500000000276414360276512015114 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 21:16:39 2004 ;;;; Contains: Tests of LISTEN (in-package :cl-test) (deftest listen.1 (with-input-from-string (s "") (listen s)) nil) (deftest listen.2 (with-input-from-string (s "x") (notnot-mv (listen s))) t) (deftest listen.3 (with-input-from-string (*standard-input* "") (listen)) nil) (deftest listen.4 (with-input-from-string (*standard-input* "A") (notnot-mv (listen))) t) ;;; (deftest listen.5 ;;; (when (interactive-stream-p *standard-input*) ;;; (clear-input) (listen)) ;;; nil) (deftest listen.6 (with-input-from-string (s "x") (values (read-char s) (listen s) (unread-char #\x s) (notnot (listen s)) (read-char s))) #\x nil nil t #\x) (deftest listen.7 (with-open-file (s "listen.lsp") (values (notnot (listen s)) (handler-case (locally (declare (optimize safety)) (loop (read-char s))) (end-of-file () (listen s))))) t nil) (deftest listen.8 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) (notnot-mv (listen t)))) t) (deftest listen.9 (with-input-from-string (*standard-input* "345") (notnot-mv (listen nil))) t) ;;; Error tests (deftest listen.error.1 :notes (:assume-no-simple-streams) (signals-error (listen *standard-input* nil) program-error) t) (deftest listen.error.2 (signals-error (listen *standard-input* nil nil) program-error) t) gcl-2.6.14/ansi-tests/boundp.lsp0000644000175000017500000000167514360276512015105 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 14 05:58:01 2003 ;;;; Contains: Tests for BOUNDP (in-package :cl-test) (deftest boundp.error.1 (classify-error (boundp)) program-error) (deftest boundp.error.2 (classify-error (boundp 'a 'a)) program-error) (deftest boundp.error.3 (classify-error (boundp 1)) type-error) (deftest boundp.error.4 (classify-error (boundp '(setf car))) type-error) (deftest boundp.error.5 (classify-error (boundp "abc")) type-error) (deftest boundp.error.6 (classify-error (locally (boundp "abc") t)) type-error) ;;; See other tests in cl-symbols.lsp (deftest boundp.1 (notnot-mv (boundp 't)) t) (deftest boundp.2 (notnot-mv (boundp nil)) t) (deftest boundp.3 (notnot-mv (boundp :foo)) t) (deftest boundp.4 (boundp '#:foo) nil) (deftest boundp.order.1 (let ((i 0) x) (values (boundp (progn (setf x (incf i)) '#:foo)) i x)) nil 1 1) gcl-2.6.14/ansi-tests/check-type.lsp0000644000175000017500000000216114360276512015641 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 20:12:04 2003 ;;;; Contains: Tests of CHECK-TYPE (in-package :cl-test) (deftest check-type.1 (let ((x 'a)) (values (check-type x symbol) x)) nil a) (deftest check-type.2 (classify-error (let ((x 'a)) (check-type x integer))) type-error) (deftest check-type.3 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (store-value 15 c)))) (values (check-type x number) x))) nil 15) (deftest check-type.4 (let ((x 'a)) (values (check-type x symbol "a symbol") x)) nil a) (deftest check-type.5 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (store-value "abc" c)))) (values (check-type x string "a string") x))) nil "abc") (deftest check-type.6 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15 nil)))) (values (check-type x number) x))) nil 15) (deftest check-type.7 (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15)))) (values (check-type x number) x))) nil 15) gcl-2.6.14/ansi-tests/pathnames.lsp0000644000175000017500000000101014360276512015555 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 29 04:21:53 2003 ;;;; Contains: Various tests on pathnames (in-package :cl-test) (deftest pathnames-print-and-read-properly (with-standard-io-syntax (loop for p1 in *pathnames* for s = (handler-case (write-to-string p1 :readably t) (print-not-readable () :unreadable-error)) unless (eql s :unreadable-error) append (let ((p2 (read-from-string s))) (unless (equal p1 p2) (list (list p1 s p2)))))) nil) gcl-2.6.14/ansi-tests/search-bitvector.lsp0000644000175000017500000001160514360276512017054 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on bit vectors (in-package :cl-test) (deftest search-bitvector.1 (let ((target *searched-bitvector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-bitvector.2 (let ((target *searched-bitvector*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-bitvector.3 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-bitvector.4 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-bitvector.5 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-bitvector.6 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-bitvector.7 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-bitvector.8 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-bitvector.9 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 2) (b . 3)) y)) x)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-bitvector.10 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 2) (b . 3)) y)) x)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-bitvector.11 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-bitvector.12 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-bitvector.13 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-bitvector.14 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-bitvector.15 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 0 1 0 1 1) :fill-pointer 5 :element-type 'bit))) (values (search #*0 a) (search #*0 a :from-end t) (search #*01 a) (search #*01 a :from-end t) (search #*010 a) (search #*010 a :from-end t))) 0 4 0 0 nil nil) (deftest search-bitvector.16 (let ((pat (make-array '(3) :initial-contents '(0 1 0) :fill-pointer 1)) (a #*01100)) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl-2.6.14/ansi-tests/loop17.lsp0000644000175000017500000000412214360276512014725 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 09:48:38 2002 ;;;; Contains: Miscellaneous loop tests (in-package :cl-test) ;;; Initially and finally take multiple forms, ;;; and execute them in the right order (deftest loop.17.1 (loop with x = 0 initially (incf x 1) (incf x (+ x x)) initially (incf x (+ x x x)) until t finally (incf x 100) (incf x (+ x x)) finally (return x)) 336) (deftest loop.17.2 (loop with x = 0 until t initially (incf x 1) (incf x (+ x x)) finally (incf x 100) (incf x (+ x x)) initially (incf x (+ x x x)) finally (return x)) 336) (deftest loop.17.3 (let ((x 0)) (loop with y = (incf x 1) initially (incf x 2) until t finally (return (values x y)))) 3 1) (deftest loop.17.4 (loop doing (return 'a) finally (return 'b)) a) (deftest loop.17.5 (loop return 'a finally (return 'b)) a) (deftest loop.17.6 (let ((x 0)) (tagbody (loop do (go done) finally (incf x)) done) x) 0) (deftest loop.17.7 (let ((x 0)) (catch 'done (loop do (throw 'done nil) finally (incf x))) x) 0) (deftest loop.17.8 (loop for x in '(1 2 3) collect x finally (return 'good)) good) (deftest loop.17.9 (loop for x in '(1 2 3) append (list x) finally (return 'good)) good) (deftest loop.17.10 (loop for x in '(1 2 3) nconc (list x) finally (return 'good)) good) (deftest loop.17.11 (loop for x in '(1 2 3) count (> x 1) finally (return 'good)) good) (deftest loop.17.12 (loop for x in '(1 2 3) sum x finally (return 'good)) good) (deftest loop.17.13 (loop for x in '(1 2 3) maximize x finally (return 'good)) good) (deftest loop.17.14 (loop for x in '(1 2 3) minimize x finally (return 'good)) good) ;;; iteration clause grouping (deftest loop.17.20 (loop for i from 1 to 5 for j = 0 then (+ j i) collect j) (0 2 5 9 14)) (deftest loop.17.21 (loop for i from 1 to 5 and j = 0 then (+ j i) collect j) (0 1 3 6 10)) gcl-2.6.14/ansi-tests/eval.lsp0000644000175000017500000000144414360276512014537 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 10:43:15 2002 ;;;; Contains: Tests of EVAL (in-package :cl-test) (deftest eval.1 (eval 1) 1) (deftest eval.2 (loop for x being the symbols of "KEYWORD" always (eq (eval x) x)) t) (deftest eval.3 (let ((s "abcd")) (eqlt (eval s) s)) t) (deftest eval.4 (eval '(car '(a . b))) a) (deftest eval.5 (eval '(let ((x 0)) x)) 0) (deftest eval.6 (funcall #'eval 1) 1) (deftest eval.order.1 (let ((i 0)) (values (eval (progn (incf i) 10)) i)) 10 1) ;;; Error cases (deftest eval.error.1 (classify-error (eval)) program-error) (deftest eval.error.2 (classify-error (eval nil nil)) program-error) (deftest eval.error.3 (classify-error (eval (list (gensym)))) undefined-function) gcl-2.6.14/ansi-tests/reader-test.lsp0000644000175000017500000001004414360276512016023 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 8 20:03:45 1998 ;;;; Contains: Tests on readtables (just started, very incomplete) (in-package :cl-test) (declaim (optimize (safety 3))) (deftest readtable-valid (not (readtablep *readtable*)) nil) (deftest readtablep.1 (and (not (readtablep nil)) (not (readtablep 'a)) (not (readtablep 0)) (not (readtablep 1/2)) (not (readtablep 1.2)) (not (readtablep 1.2s2)) (not (readtablep 1.2f3)) (not (readtablep 1.2e2)) (not (readtablep 1.2d2)) (not (readtablep (list 'a))) (not (readtablep "abcde")) (not (readtablep t)) (not (readtablep '*readtable*)) (not (readtablep (make-array '(10)))) (not (readtablep (make-array '(10) :element-type 'fixnum))) (not (readtablep (make-array '(10) :element-type 'float))) (not (readtablep (make-array '(10) :element-type 'double-float))) (not (readtablep (make-array '(10) :element-type 'string))) (not (readtablep (make-array '(10) :element-type 'character))) (not (readtablep (make-array '(10) :element-type 'bit))) (not (readtablep (make-array '(10) :element-type 'boolean))) (not (not (readtablep (copy-readtable)))) (not (readtablep #'car)) ) t) (deftest read-symbol.1 (let ((*package* (find-package "CL-TEST"))) (ignore-errors (read-from-string "a"))) a 1) (deftest read-symbol.2 (let ((*package* (find-package "CL-TEST"))) (ignore-errors (read-from-string "|a|"))) |a| 3) (deftest read-symbol.3 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:abc")) (not (and (symbolp s) (eql n 5) (not (symbol-package s)) (string-equal (symbol-name s) "abc")))) nil) (deftest read-symbol.4 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:|abc|")) (not (and (symbolp s) (eql n 7) (not (symbol-package s)) (string= (symbol-name s) "abc")))) nil) (deftest read-symbol.5 (multiple-value-bind (s n) (ignore-errors (read-from-string "#:||")) (if (not (symbolp s)) s (not (not (and (eql n 4) (not (symbol-package s)) (string= (symbol-name s) "")))))) t) (deftest read-symbol.6 (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) (ignore-errors (read-from-string str)) (if (not (symbolp s)) s (not (not (and (eql n (length str)) (eqt (symbol-package s) (find-package :cl-test)) (string-equal (symbol-name s) "abcd0123"))))))) t) (deftest read-symbol.7 (multiple-value-bind (s n) (ignore-errors (read-from-string ":ABCD")) (if (not (symbolp s)) s (not (not (and (eql n 5) (eqt (symbol-package s) (find-package "KEYWORD")) (string-equal (symbol-name s) "ABCD")))))) t) (defun read-symbol.9-body (natoms maxlen) (let* ((chars (concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) (nchars (length chars))) (loop for i from 1 to natoms count (let* ((len (random (1+ maxlen))) (actual-len 0) (s (make-string (+ 2 (* 2 len)))) (s2 (make-string len))) (loop for j from 0 to (1- len) do (let ((c (elt chars (random (max 1 (1- nchars)))))) (when (member c '(#\| #\\)) (setf (elt s actual-len) #\\) (incf actual-len)) (setf (elt s actual-len) c) (setf (elt s2 j) c) (incf actual-len))) (let ((actual-string (subseq s 0 actual-len))) (multiple-value-bind (sym nread) (ignore-errors (read-from-string (concatenate 'string "#:|" actual-string "|"))) (unless (and (symbolp sym) (eql nread (+ 4 actual-len)) (string-equal s2 (symbol-name sym))) (format t "Symbol read failed: ~S (~S) read as ~S~%" actual-string s2 sym :readably t) t))))))) (deftest read-symbol.9 (read-symbol.9-body 1000 100) 0) (deftest read-symbol.10 (handler-case (not (not (equal (symbol-name (read-from-string (with-output-to-string (s) (write (make-symbol ":") :readably t :stream s)))) ":"))) (error (c) c)) t) gcl-2.6.14/ansi-tests/cons-test-01.lsp0000644000175000017500000002021714360276512015744 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:29:48 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 1 (in-package :cl-test) (declaim (optimize (safety 3))) ;; ;; Test the subtype relationships between null, list, cons and atom ;; (deftest subtypep-null-list (subtypep* 'null 'list) t t) (deftest subtypep-cons-list (subtypep* 'cons 'list) t t) (deftest subtypep-null-cons (subtypep* 'null 'cons) nil t) (deftest subtypep-cons-null (subtypep* 'cons 'null) nil t) (deftest subtypep-null-atom (subtypep* 'null 'atom) t t) (deftest subtypep-cons-atom (subtypep* 'cons 'atom) nil t) (deftest subtypep-atom-cons (subtypep* 'atom 'cons) nil t) (deftest subtypep-atom-list (subtypep* 'atom 'list) nil t) (deftest subtypep-list-atom (subtypep* 'list 'atom) nil t) ;; ;; Check that the elements of *universe* in type null ;; are those for which the null predice is true. ;; (deftest null-null-universe (check-type-predicate 'null 'null) 0) (defvar *cons-fns* (list 'cons 'consp 'atom 'rplaca 'rplacd 'car 'cdr 'caar 'cadr 'cdar 'cddr 'caaar 'caadr 'cadar 'caddr 'cdaar 'cdadr 'cddar 'cdddr 'caaaar 'caaadr 'caadar 'caaddr 'cadaar 'cadadr 'caddar 'cadddr 'cdaaar 'cdaadr 'cdadar 'cdaddr 'cddaar 'cddadr 'cdddar 'cddddr 'copy-tree 'sublis 'nsublis 'subst 'subst-if 'subst-if-not 'nsubst 'nsubst-if 'nsubst-if-not 'tree-equal 'copy-list 'list 'list* 'list-length 'listp 'make-list 'first 'second 'third 'fourth 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth 'nth 'endp 'null 'nconc 'append 'revappend 'nreconc 'butlast 'nbutlast 'last 'ldiff 'tailp 'nthcdr 'rest 'member 'member-if 'member-if-not 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon 'acons 'assoc 'assoc-if 'assoc-if-not 'copy-alist 'pairlis 'rassoc 'rassoc-if 'rassoc-if-not 'get-properties 'getf 'intersection 'nintersection 'adjoin 'set-difference 'nset-difference 'set-exclusive-or 'nset-exclusive-or 'subsetp 'union 'nunion )) ;; All the cons functions have a function binding (deftest function-bound-cons-fns (loop for x in *cons-fns* count (when (or (not (fboundp x)) (not (functionp (symbol-function x)))) (format t "~%~S not bound to a function" x) t)) 0) ;; All the cons-related macros have a macro binding (deftest macro-bound-cons-macros (notnot-mv (every #'macro-function (list 'push 'pop 'pushnew 'remf))) t) ;; None of the cons-related functions have macro bindings (deftest no-cons-fns-are-macros (some #'macro-function *cons-fns*) nil) ;; Various easy tests of cons (deftest cons-of-symbols (cons 'a 'b) (a . b)) (deftest cons-with-nil (cons 'a nil) (a)) ;; successive calls to cons produces results that are equal, but not eq (deftest cons-eq-equal (let ((x (cons 'a 'b)) (y (cons 'a 'b))) (and (not (eqt x y)) (equalt x y))) t) ;; list can be expressed as a bunch of conses (with nil) (deftest cons-equal-list (equalt (cons 'a (cons 'b (cons 'c nil))) (list 'a 'b 'c)) t) ;;; Order of evaluation of cons arguments (deftest cons.order.1 (let ((i 0)) (values (cons (incf i) (incf i)) i)) (1 . 2) 2) ;; Lists satisfy consp (deftest consp-list (notnot-mv (consp '(a))) t) ;; cons satisfies consp (deftest consp-cons (notnot-mv (consp (cons nil nil))) t) ;; nil is not a consp (deftest consp-nil (consp nil) nil) ;; The empty list is not a cons (deftest consp-empty-list (consp (list)) nil) ;; A single element list is a cons (deftest consp-single-element-list (notnot-mv (consp (list 'a))) t) ;; For everything in *universe*, it is either an atom, or satisfies ;; consp, but not both (deftest consp-xor-atom-universe (notnot-mv (every #'(lambda (x) (or (and (consp x) (not (atom x))) (and (not (consp x)) (atom x)))) *universe*)) t) ;; Everything in type cons satisfies consp, and vice versa (deftest consp-cons-universe (check-type-predicate 'consp 'cons) 0) (deftest consp.order.1 (let ((i 0)) (values (consp (incf i)) i)) nil 1) (deftest consp.error.1 (classify-error (consp)) program-error) (deftest consp.error.2 (classify-error (consp 'a 'b)) program-error) (deftest atom.order.1 (let ((i 0)) (values (atom (progn (incf i) '(a b))) i)) nil 1) (deftest atom.error.1 (classify-error (atom)) program-error) (deftest atom.error.2 (classify-error (atom 'a 'b)) program-error) ;; Tests of car, cdr and compound forms (deftest cons.23 (car '(a)) a) (deftest cons.24 (cdr '(a . b)) b) (deftest cons.25 (caar '((a))) a) (deftest cons.26 (cdar '((a . b))) b) (deftest cons.27 (cadr '(a b)) b) (deftest cons.28 (cddr '(a b . c)) c) (deftest cons.29 (caaar '(((a)))) a) (deftest cons.30 (cdaar '(((a . b)))) b) (deftest cons.31 (cadar (cons (cons 'a (cons 'b 'c)) 'd)) b) (deftest cons.32 (cddar (cons (cons 'a (cons 'b 'c)) 'd)) c) (deftest cons.33 (caadr (cons 'a (cons (cons 'b 'c) 'd))) b) (deftest cons.34 (caddr (cons 'a (cons 'b (cons 'c 'd)))) c) (deftest cons.36 (cdadr (cons 'a (cons (cons 'b 'c) 'd))) c) (deftest cons.37 (cdddr (cons 'a (cons 'b (cons 'c 'd)))) d) (defvar *cons-test-4* (cons (cons (cons (cons 'a 'b) (cons 'c 'd)) (cons (cons 'e 'f) (cons 'g 'h))) (cons (cons (cons 'i 'j) (cons 'k 'l)) (cons (cons 'm 'n) (cons 'o 'p))))) (deftest cons.38 (caaaar *cons-test-4*) a) (deftest cons.39 (cdaaar *cons-test-4*) b) (deftest cons.40 (cadaar *cons-test-4*) c) (deftest cons.41 (cddaar *cons-test-4*) d) (deftest cons.42 (caadar *cons-test-4*) e) (deftest cons.43 (cdadar *cons-test-4*) f) (deftest cons.44 (caddar *cons-test-4*) g) (deftest cons.45 (cdddar *cons-test-4*) h) ;;; (deftest cons.46 (caaadr *cons-test-4*) i) (deftest cons.47 (cdaadr *cons-test-4*) j) (deftest cons.48 (cadadr *cons-test-4*) k) (deftest cons.49 (cddadr *cons-test-4*) l) (deftest cons.50 (caaddr *cons-test-4*) m) (deftest cons.51 (cdaddr *cons-test-4*) n) (deftest cons.52 (cadddr *cons-test-4*) o) (deftest cons.53 (cddddr *cons-test-4*) p) (deftest cons.error.1 (classify-error (cons)) program-error) (deftest cons.error.2 (classify-error (cons 'a)) program-error) (deftest cons.error.3 (classify-error (cons 'a 'b 'c)) program-error) ;; Test rplaca, rplacd (deftest rplaca.1 (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplaca x 'c) y) (eqt x y) (eqt (car x) 'c) (eqt (cdr x) 'b)))) t) (deftest rplaca.order.1 (let ((x (cons 'a 'b)) (i 0) a b) (values (rplaca (progn (setf a (incf i)) x) (progn (setf b (incf i)) 'c)) i a b)) (c . b) 2 1 2) (deftest rplacd.1 (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplacd x 'd) y) (eqt x y) (eqt (car x) 'a) (eqt (cdr x) 'd)))) t) (deftest rplacd.order.1 (let ((x (cons 'a 'b)) (i 0) a b) (values (rplacd (progn (setf a (incf i)) x) (progn (setf b (incf i)) 'c)) i a b)) (a . c) 2 1 2) ;; rplaca on a fixnum is a type error (deftest rplaca.error.1 (loop for x in *universe* thereis (and (not (consp x)) (not (eq (catch-type-error (rplaca x 1)) 'type-error)))) nil) (deftest rplaca.error.2 (classify-error (rplaca)) program-error) (deftest rplaca.error.3 (classify-error (rplaca (cons 'a 'b))) program-error) (deftest rplaca.error.4 (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage)) program-error) (deftest rplaca.error.5 (classify-error (rplaca 'a 1)) type-error) (deftest rplaca.error.6 (classify-error (locally (rplaca 'a 1) t)) type-error) ;; rplacd on a fixnum is a type error (deftest rplacd.error.1 (loop for x in *universe* thereis (and (not (consp x)) (not (eq (catch-type-error (rplacd x 1)) 'type-error)))) nil) (deftest rplacd.error.2 (classify-error (rplacd)) program-error) (deftest rplacd.error.3 (classify-error (rplacd (cons 'a 'b))) program-error) (deftest rplacd.error.4 (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage)) program-error) (deftest rplacd.error.5 (classify-error (rplacd 'a 1)) type-error) (deftest rplacd.error.6 (classify-error (locally (rplacd 'a 1) t)) type-error) gcl-2.6.14/ansi-tests/labels.lsp0000644000175000017500000001165614360276512015060 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 19:06:33 2002 ;;;; Contains: Tests of LABELS (in-package :cl-test) (deftest labels.1 (labels ((%f () 1)) (%f)) 1) (deftest labels.2 (labels ((%f (x) x)) (%f 2)) 2) (deftest labels.3 (labels ((%f (&rest args) args)) (%f 'a 'b 'c)) (a b c)) ;;; The optional arguments are not in the block defined by ;;; the local function declaration (deftest labels.4 (block %f (labels ((%f (&optional (x (return-from %f 10))) 20)) (%f))) 10) (deftest labels.5 (labels ((%f () (return-from %f 15) 35)) (%f)) 15) ;;; The aux parameters are not in the block defined by ;;; the local function declaration (deftest labels.6 (block %f (labels ((%f (&aux (x (return-from %f 10))) 20)) (%f))) 10) ;;; The function is visible inside itself (deftest labels.7 (labels ((%f (x n) (cond ((eql n 0) x) (t (%f (+ x n) (1- n)))))) (%f 0 10)) 55) ;;; Keyword arguments (deftest labels.8 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f)) nil 0 nil) (deftest labels.9 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a 1)) 1 0 nil) (deftest labels.10 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2)) nil 2 t) (deftest labels.11 (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :b 2 :a 3)) 3 2 t) ;;; Unknown keyword parameter should throw a program-error in safe code ;;; (section 3.5.1.4) (deftest labels.12 (classify-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) program-error) ;;; Odd # of keyword args should throw a program-error in safe code ;;; (section 3.5.1.6) (deftest labels.13 (classify-error (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) program-error) ;;; Too few arguments (section 3.5.1.2) (deftest labels.14 (classify-error (labels ((%f (a) a)) (%f))) program-error) ;;; Too many arguments (section 3.5.1.3) (deftest labels.15 (classify-error (labels ((%f (a) a)) (%f 1 2))) program-error) ;;; Invalid keyword argument (section 3.5.1.5) (deftest labels.16 (classify-error (labels ((%f (&key a) a)) (%f '(foo)))) program-error) ;;; Definition of a (setf ...) function (deftest labels.17 (labels (((setf %f) (x y) (setf (car y) x))) (let ((z (list 1 2))) (setf (%f z) 'a) z)) (a 2)) ;;; Scope of defined function names includes &AUX parameters (deftest labels.7b (labels ((%f (x &aux (b (%g x))) b) (%g (y) (+ y y))) (%f 10)) 20) ;;; Body is an implicit progn (deftest labels.18 (labels ((%f (x) (incf x) (+ x x))) (%f 10)) 22) ;;; Can handle at least 50 lambda parameters (deftest labels.19 (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; labels works with the maximum number of arguments (if ;;; not too many.) (deftest labels.20 (let* ((n (min lambda-parameters-limit 1024)) (vars (loop for i from 1 to n collect (gensym)))) (eval `(eql ,n (labels ((%f ,vars (+ ,@ vars))) (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest labels.21 (labels ((%f (x) (declare (type fixnum x)) "Add one to the fixnum x." (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) ;;; Keywords can be function names (deftest labels.22 (labels ((:foo () 10) (:bar () (1+ (:foo)))) (:bar)) 11) (deftest labels.23 (labels ((:foo () 10) (:bar () (1+ (funcall #':foo)))) (funcall #':bar)) 11) (deftest labels.24 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels ((,s (x) (foo (1- x))) (foo (y) (if (<= y 0) 'a (,s (1- y))))) (,s 10))) unless (eq (eval form) 'a) collect s) nil) (deftest labels.25 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels ((,s (x) (foo (1- x))) (foo (y) (if (<= y 0) 'a (,s (1- y))))) (declare (ftype (function (integer) symbol) foo ,s)) (,s 10))) unless (eq (eval form) 'a) collect s) nil) (deftest labels.26 (loop for s in *cl-non-function-macro-special-operator-symbols* for form = `(classify-error (labels (((setf ,s) (&rest args) (declare (ignore args)) 'a)) (setf (,s) 10))) unless (eq (eval form) 'a) collect s) nil) gcl-2.6.14/ansi-tests/delete-file.lsp0000644000175000017500000000466514360276512015777 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 18:42:29 2004 ;;;; Contains: Tests for DELETE-FILE (in-package :cl-test) (deftest delete-file.1 (let ((pn "scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.2 (let ((pn #p"scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.3 (let ((pn "CLTEST:SCRATCHFILE.TXT")) (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) (probe-file pn))) t (t) nil) (deftest delete-file.4 (let ((pn "CLTEST:SCRATCHFILE.TXT")) (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (let ((s (open pn :direction :input))) (close s) (values (notnot (probe-file pn)) (multiple-value-list (delete-file s)) (probe-file pn)))) t (t) nil) ;;; Specialized string tests (deftest delete-file.5 (do-special-strings (pn "scratchfile.txt" nil) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (assert (probe-file pn)) (assert (equal (multiple-value-list (delete-file pn)) '(t))) (assert (not (probe-file pn)))) nil) ;;; Error tests (deftest delete-file.error.1 (signals-error (delete-file) program-error) t) (deftest delete-file.error.2 (let ((pn "scratch.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) (format s "Contents~%"))) (values (notnot (probe-file pn)) (signals-error (delete-file "scratch.txt" nil) program-error) (notnot (probe-file pn)) (delete-file pn) (probe-file pn))) t t t t nil) #| (deftest delete-file.error.3 (let ((pn "nonexistent.txt")) (when (probe-file pn) (delete-file pn)) (signals-error (delete-file "nonexistent.txt") file-error)) t) |# gcl-2.6.14/ansi-tests/string-aux.lsp0000644000175000017500000001162114360276512015707 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 4 06:51:32 2002 ;;;; Contains: Auxiliary functions for string testing (in-package :cl-test) (defun my-string-compare (string1 string2 comparison &key (start1 0) end1 (start2 0) end2 case &aux (len1 (progn (assert (stringp string1)) (length string1))) (len2 (progn (assert (stringp string2)) (length string2))) (compare-fn (case comparison (< (if case #'char-lessp #'char<)) (<= (if case #'char-not-greaterp #'char<=)) (= (if case #'char-equal #'char=)) (/= (if case #'char-not-equal #'char/=)) (> (if case #'char-greaterp #'char>)) (>= (if case #'char-not-lessp #'char>=)) (t (error "Bad comparison arg: ~A~%" comparison)))) (equal-fn (if case #'char-equal #'char=))) (assert (integerp start1)) (assert (integerp start2)) (unless end1 (setq end1 len1)) (unless end2 (setq end2 len2)) (assert (<= 0 start1 end1)) (assert (<= 0 start2 end2)) (loop for i1 from start1 for i2 from start2 do (cond ((= i1 end1) (return (cond ((= i2 end2) ;; Both ended -- equality case (if (member comparison '(= <= >=)) end1 nil)) (t ;; string2 still extending (if (member comparison '(/= < <=)) end1 nil))))) ((= i2 end2) ;; string1 still extending (return (if (member comparison '(/= > >=)) i1 nil))) (t (let ((c1 (char string1 i1)) (c2 (char string2 i2))) (cond ((funcall equal-fn c1 c2)) (t ;; mismatch found -- what kind? (return (if (funcall compare-fn c1 c2) i1 nil))))))))) (defun make-random-string-compare-test (n) (let* ((len (random n)) ;; Lengths of the two strings (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) ;; Lengths of the parts of the strings to be matched (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) ;; Start and end of the substring of the first string (start1 (if (coin 3) 0 (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) (end1 (+ start1 sublen1)) ;; Start and end of the substring of the second string (start2 (if (coin 3) 0 (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) (end2 (+ start2 sublen2)) ;; generate the strings (s1 (make-random-string len1)) (s2 (make-random-string len2))) #| (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" len len1 len2 sublen1 sublen2) (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" start1 end1 start2 end2) (format t "s1 = ~S, s2 = ~S~%" s1 s2) |# ;; Sometimes we want them to have a common prefix (when (coin) (if (<= sublen1 sublen2) (setf (subseq s2 start2 (+ start2 sublen1)) (subseq s1 start1 (+ start1 sublen1))) (setf (subseq s1 start1 (+ start1 sublen2)) (subseq s2 start2 (+ start2 sublen2))))) (values s1 s2 (reduce #'nconc (random-permute (list (if (and (= start1 0) (coin)) nil (list :start1 start1)) (if (and (= end1 len1) (coin)) nil (list :end1 end1)) (if (and (= start2 0) (coin)) nil (list :start2 start2)) (if (and (= end2 len2) (coin)) nil (list :end2 end2)))))))) (defun random-string-compare-test (n comparison case &optional (iterations 1)) (loop for i from 1 to iterations count (multiple-value-bind (s1 s2 args) (make-random-string-compare-test n) ;; (format t "Args = ~S~%" args) (let ((x (apply (case comparison (< (if case #'string-lessp #'string<)) (<= (if case #'string-not-greaterp #'string<=)) (= (if case #'string-equal #'string=)) (/= (if case #'string-not-equal #'string/=)) (> (if case #'string-greaterp #'string>)) (>= (if case #'string-not-lessp #'string>=)) (t (error "Bad comparison arg: ~A~%" comparison))) s1 s2 args)) (y (apply #'my-string-compare s1 s2 comparison :case case args))) (not (or (eql x y) (and x y (eqt comparison '=)))))))) (defun make-random-string (n) (let ((s (random-case (make-string n) (make-array n :element-type 'character :initial-element #\a) (make-array n :element-type 'standard-char :initial-element #\a) (make-array n :element-type 'base-char :initial-element #\a)))) (if (coin) (dotimes (i n) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i n) (dotimes (i n) (setf (char s i) (or (code-char (random 256)) (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (random 62))))))) s)) (defun string-all-the-same (s) (let ((len (length s))) (or (= len 0) (let ((c (char s 0))) (loop for d across s always (eql c d)))))) gcl-2.6.14/ansi-tests/file-length.lsp0000644000175000017500000001106014360276512016001 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 21 06:21:11 2004 ;;;; Contains: Tests of FILE-LENGTH (in-package :cl-test) (deftest file-length.error.1 (signals-error (file-length) program-error) t) (deftest file-length.error.2 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (file-length is nil)) program-error) t) (deftest file-length.error.3 (loop for x in *mini-universe* unless (or (typep x 'file-stream) (typep x 'broadcast-stream) (handler-case (progn (file-length x) nil) (type-error (c) (assert (not (typep x (type-error-expected-type c)))) t) (condition () nil))) collect x) nil) (deftest file-length.error.4 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-error (with-input-from-string (s "abc") (file-length s)) type-error) t) (deftest file-length.error.5 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-two-way-stream is os))) (unwind-protect (file-length s) (close s))))) type-error) t) (deftest file-length.error.6 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-echo-stream is os))) (unwind-protect (file-length s) (close s))))) type-error) t) (deftest file-length.error.8 (with-open-file (os "tmp.txt" :direction :output :if-exists :supersede) (let ((s (make-broadcast-stream os))) (eqlt (file-length s) (file-length os)))) t) (deftest file-length.error.9 (signals-type-error s (make-concatenated-stream) (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.10 (signals-error (with-open-file (is "file-length.lsp" :direction :input) (let ((s (make-concatenated-stream is))) (unwind-protect (file-length s) (close s)))) type-error) t) (deftest file-length.error.11 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-input-stream "abcde") (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.12 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-output-stream) (unwind-protect (file-length s) (close s))) t) ;;; Non-error tests (deftest file-length.1 (let ((results (multiple-value-list (with-open-file (is "file-length.lsp" :direction :input) (file-length is))))) (and (= (length results) 1) (typep (car results) '(integer 1)) t)) t) (deftest file-length.2 (loop for i from 1 to 32 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) do (loop repeat 17 do (write-byte e os)) do (finish-output os) unless (= (file-length os) 17) collect (list i (file-length os)) do (close os)) nil) (deftest file-length.3 (loop for i from 1 to 32 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) for len = 0 do (loop repeat 17 do (write-byte e os)) do (close os) unless (let ((is (open "tmp.dat" :direction :input :element-type etype))) (prog1 (= (file-length is) 17) (close is))) collect i) nil) (deftest file-length.4 (loop for i from 33 to 100 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) do (loop repeat 17 do (write-byte e os)) do (finish-output os) unless (= (file-length os) 17) collect (list i (file-length os)) do (close os)) nil) (deftest file-length.5 (loop for i from 33 to 100 for etype = `(unsigned-byte ,i) for e = (max 0 (- (ash 1 i) 5)) for os = (open "tmp.dat" :direction :output :if-exists :supersede :element-type etype) for len = 0 do (loop repeat 17 do (write-byte e os)) do (close os) unless (let ((is (open "tmp.dat" :direction :input :element-type etype))) (prog1 (= (file-length is) 17) (close is))) collect i) nil) (deftest file-length.6 (with-open-file (*foo* "file-length.lsp" :direction :input) (declare (special *foo*)) (let ((s (make-synonym-stream '*foo*))) (unwind-protect (typep* (file-length s) '(integer 1)) (close s)))) t) gcl-2.6.14/ansi-tests/position.lsp0000644000175000017500000004242014360276512015453 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Aug 23 07:49:49 2002 ;;;; Contains: Tests for POSITION (in-package :cl-test) (deftest position-list.1 (position 'c '(a b c d e c a)) 2) (deftest position-list.2 (position 'c '(a b c d e c a) :from-end t) 5) (deftest position-list.3 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-list.4 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-list.5 (loop for i from 7 downto 0 collect (position 'c '(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-list.6 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.7 (loop for i from 0 to 7 collect (position 'c '(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.8 (loop for i from 7 downto 0 collect (position 'c '(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-list.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c '(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-list.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-list.11 (position 5 '(1 2 3 4 5 6 4 8) :key #'1+) 3) (deftest position-list.12 (position 5 '(1 2 3 4 5 6 4 8) :key '1+) 3) (deftest position-list.13 (position 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 6) (deftest position-list.14 (position 'a '(a a b a c e d a f a) :test (complement #'eql)) 2) (deftest position-list.15 (position 'a '(a a b a c e d a f a) :test (complement #'eql) :from-end t) 8) (deftest position-list.16 (position 'a '(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-list.17 (position 'a '(a a b a c e d a f a) :test-not 'eql :from-end t) 8) (deftest position-list.18 (position 'a '(a a b a c e d a f a) :test-not 'eql) 2) (deftest position-list.19 (position 'a '(a a b a c e d a f a) :test-not #'eql :from-end t) 8) (deftest position-list.20 (position 'a '(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-list.21 (position 'a '(a a b a c e d a f a) :test #'eql :start 2) 3) (deftest position-list.22 (position 'a '(a a b a c e d a f a) :test #'eql :start 2 :end nil) 3) (deftest position-list.23 (position 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) 2) (deftest position-list.24 (position 'a '(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-list.25 (position '(a b) '(a (b a) (a b c) (a b) (d e) f) :test #'equal) 3) (deftest position-list.26 (position 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) 2) (deftest position-list.27 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) 4) (deftest position-list.28 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) 4) ;;; Tests on vectors (deftest position-vector.1 (position 'c #(a b c d e c a)) 2) (deftest position-vector.2 (position 'c #(a b c d e c a) :from-end t) 5) (deftest position-vector.3 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.4 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.5 (loop for i from 7 downto 0 collect (position 'c #(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-vector.6 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.7 (loop for i from 0 to 7 collect (position 'c #(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.8 (loop for i from 7 downto 0 collect (position 'c #(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c #(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-vector.11 (position 5 #(1 2 3 4 5 6 4 8) :key #'1+) 3) (deftest position-vector.12 (position 5 #(1 2 3 4 5 6 4 8) :key '1+) 3) (deftest position-vector.13 (position 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) 6) (deftest position-vector.14 (position 'a #(a a b a c e d a f a) :test (complement #'eql)) 2) (deftest position-vector.15 (position 'a #(a a b a c e d a f a) :test (complement #'eql) :from-end t) 8) (deftest position-vector.16 (position 'a #(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-vector.17 (position 'a #(a a b a c e d a f a) :test-not 'eql :from-end t) 8) (deftest position-vector.18 (position 'a #(a a b a c e d a f a) :test-not 'eql) 2) (deftest position-vector.19 (position 'a #(a a b a c e d a f a) :test-not #'eql :from-end t) 8) (deftest position-vector.20 (position 'a #(a a b a c e d a f a) :test-not #'eql) 2) (deftest position-vector.21 (position 'a #(a a b a c e d a f a) :test #'eql :start 2) 3) (deftest position-vector.22 (position 'a #(a a b a c e d a f a) :test #'eql :start 2 :end nil) 3) (deftest position-vector.23 (position 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5) 2) (deftest position-vector.24 (position 'a #(a a b a c e d a f a) :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-vector.25 (position '(a b) #(a (b a) (a b c) (a b) (d e) f) :test #'equal) 3) (deftest position-vector.26 (position 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) 2) (deftest position-vector.27 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car :start 3) 4) (deftest position-vector.28 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car :start 2 :from-end t) 4) (deftest position-vector.29 (position 'a (make-array '(10) :initial-contents '(b b b b b a a a a a) :fill-pointer 5)) nil) (deftest position-vector.30 (position 'a (make-array '(10) :initial-contents '(b b b b a a a a a a) :fill-pointer 5)) 4) (deftest position-vector.31 (position 'a (make-array '(10) :initial-contents '(b a b b a a a a a a) :fill-pointer 5) :from-end t) 4) ;;; tests on bit vectors (deftest position-bit-vector.1 (position 1 #*001001010100) 2) (deftest position-bit-vector.2 (position 1 #*001001010100 :from-end t) 9) (deftest position-bit-vector.3 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.4 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.5 (loop for i from 7 downto 0 collect (position 1 #*0010010 :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-bit-vector.6 (loop for i from 0 to 7 collect (position 1 #*0010010 :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.7 (loop for i from 0 to 7 collect (position 0 #*1101101 :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.8 (loop for i from 7 downto 0 collect (position 0 #*1101101 :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-bit-vector.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 1 #*0010010 :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-bit-vector.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position 1 #*0010010 :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-bit-vector.11 (position 2 #*00010001010 :key #'1+) 3) (deftest position-bit-vector.12 (position 2 #*00010001010 :key '1+) 3) (deftest position-bit-vector.13 (position 2 #*0010001000 :key #'1+ :from-end t) 6) (deftest position-bit-vector.14 (position 0 #*0010111010 :test (complement #'eql)) 2) (deftest position-bit-vector.15 (position 0 #*0010111010 :test (complement #'eql) :from-end t) 8) (deftest position-bit-vector.16 (position 0 #*0010111010 :test-not #'eql) 2) (deftest position-bit-vector.17 (position 0 #*001011101 :test-not 'eql :from-end t) 8) (deftest position-bit-vector.18 (position 0 #*00101110 :test-not 'eql) 2) (deftest position-bit-vector.19 (position 0 #*00101110 :test-not #'eql :from-end t) 6) (deftest position-bit-vector.20 (position 0 #*00101110 :test-not #'eql) 2) (deftest position-bit-vector.21 (position 0 #*00101110 :test #'eql :start 2) 3) (deftest position-bit-vector.22 (position 0 #*00101110 :test #'eql :start 2 :end nil) 3) (deftest position-bit-vector.23 (position 0 #*00101110 :test-not #'eql :start 0 :end 5) 2) (deftest position-bit-vector.24 (position 0 #*00101110 :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-bit-vector.25 (position 2 #*1100001010 :key #'1+ :start 3) 6) (deftest position-bit-vector.27 (position 2 #*1100001010 :key #'1+ :start 2 :from-end t) 8) (deftest position-bit-vector.28 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) nil) (deftest position-bit-vector.29 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) :element-type 'bit :fill-pointer 5) :from-end t) nil) (deftest position-bit-vector.30 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) 4) (deftest position-bit-vector.31 (position 0 (make-array '(10) :initial-contents '(0 1 0 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5) :from-end t) 4) (deftest position-bit-vector.32 (position 0 (make-array '(10) :initial-contents '(1 0 1 1 0 0 0 0 0 0) :element-type 'bit :fill-pointer 5)) 1) ;;; strings (deftest position-string.1 (position #\c "abcdeca") 2) (deftest position-string.2 (position #\c "abcdeca" :from-end t) 5) (deftest position-string.3 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-string.4 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-string.5 (loop for i from 7 downto 0 collect (position #\c "abcdeca" :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-string.6 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.7 (loop for i from 0 to 7 collect (position #\c "abcdeca" :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.8 (loop for i from 7 downto 0 collect (position #\c "abcdeca" :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-string.9 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position #\c "abcdeca" :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-string.10 (loop for i from 0 to 6 collect (loop for j from (1+ i) to 7 collect (position #\c "abcdeca" :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) (nil nil 5 5) (nil 5 5) (5 5) (nil))) (deftest position-string.11 (position 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c))))) 3) (deftest position-string.13 (position 5 "12345648" :key #'(lambda (c) (1+ (read-from-string (string c)))) :from-end t) 6) (deftest position-string.14 (position #\a "aabacedafa" :test (complement #'eql)) 2) (deftest position-string.15 (position #\a "aabacedafa" :test (complement #'eql) :from-end t) 8) (deftest position-string.16 (position #\a "aabacedafa" :test-not #'eql) 2) (deftest position-string.17 (position #\a "aabacedafa" :test-not 'eql :from-end t) 8) (deftest position-string.18 (position #\a "aabacedafa" :test-not 'eql) 2) (deftest position-string.19 (position #\a "aabacedafa" :test-not #'eql :from-end t) 8) (deftest position-string.20 (position #\a "aabacedafa" :test-not #'eql) 2) (deftest position-string.21 (position #\a "aabacedafa" :test #'eql :start 2) 3) (deftest position-string.22 (position #\a "aabacedafa" :test #'eql :start 2 :end nil) 3) (deftest position-string.23 (position #\a "aabacedafa" :test-not #'eql :start 0 :end 5) 2) (deftest position-string.24 (position #\a "aabacedafa" :test-not #'eql :start 0 :end 5 :from-end t) 4) (deftest position-string.25 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" :element-type 'character :fill-pointer 5)) nil) (deftest position-string.26 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" :element-type 'character :fill-pointer 5) :from-end t) nil) (deftest position-string.27 (position #\a (make-array '(10) :initial-contents "bbbbaaaaaa" :element-type 'character :fill-pointer 5)) 4) (deftest position-string.28 (position #\a (make-array '(10) :initial-contents "babbaaaaaa" :element-type 'character :fill-pointer 5) :from-end t) 4) (deftest position.order.1 (let ((i 0) a b c d e f g) (values (position (progn (setf a (incf i)) 0) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :from-end (setf c (incf i)) :start (progn (setf d (incf i)) 1) :end (progn (setf e (incf i)) 6) :key (progn (setf f (incf i)) #'1-) :test (progn (setf g (incf i)) #'=) ) i a b c d e f g)) 4 7 1 2 3 4 5 6 7) (deftest position.order.2 (let ((i 0) a b c d e f g) (values (position (progn (setf a (incf i)) 0) (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) :test-not (progn (setf c (incf i)) #'/=) :key (progn (setf d (incf i)) #'1-) :end (progn (setf e (incf i)) 6) :start (progn (setf f (incf i)) 1) :from-end (setf g (incf i)) ) i a b c d e f g)) 4 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest position.allow-other-keys.1 (position 0 '(1 2 0 3 2 1) :allow-other-keys t) 2) (deftest position.allow-other-keys.2 (position 0 '(1 2 0 3 2 1) :allow-other-keys nil) 2) (deftest position.allow-other-keys.3 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t) 2) (deftest position.allow-other-keys.4 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t) 2) (deftest position.allow-other-keys.5 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) 0) (deftest position.keywords.6 (position 0 '(1 2 0 3 2 1) :key #'1- :key #'identity) 0) (deftest position.allow-other-keys.7 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :allow-other-keys nil) 2) (deftest position.allow-other-keys.8 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t :allow-other-keys nil) 2) (deftest position.allow-other-keys.9 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :allow-other-keys nil :bad t) 2) ;;; Error tests (deftest position.error.1 (classify-error (position 'a 'b)) type-error) (deftest position.error.2 (classify-error (position 'a 10)) type-error) (deftest position.error.3 (classify-error (position 'a 1.4)) type-error) (deftest position.error.4 (classify-error (position 'e '(a b c . d))) type-error) (deftest position.error.5 (classify-error (position)) program-error) (deftest position.error.6 (classify-error (position 'a)) program-error) (deftest position.error.7 (classify-error (position 'a nil :key)) program-error) (deftest position.error.8 (classify-error (position 'a nil 'bad t)) program-error) (deftest position.error.9 (classify-error (position 'a nil 'bad t :allow-other-keys nil)) program-error) (deftest position.error.10 (classify-error (position 'a nil 1 2)) program-error) (deftest position.error.11 (classify-error (locally (position 'a 'b) t)) type-error) (deftest position.error.12 (classify-error (position 'b '(a b c d) :test #'identity)) program-error) (deftest position.error.13 (classify-error (position 'b '(a b c d) :test-not #'not)) program-error) (deftest position.error.14 (classify-error (position 'b '(a b c d) :key #'cdr)) type-error) (deftest position.error.15 (classify-error (position 'b '(a b c d) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/character.lsp0000644000175000017500000002754414360276512015555 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 12:52:18 2002 ;;;; Contains: Tests associated with the class CHARACTER (in-package :cl-test) (deftest character-class.1 (subtypep* 'character t) t t) (deftest base-char.1 (subtypep* 'base-char 'character) t t) (deftest base-char.2 (subtypep* 'base-char t) t t) (deftest base-char.3 (every #'(lambda (c) (typep c 'base-char)) +standard-chars+) t) (deftest standard-char.1 (subtypep* 'standard-char 'base-char) t t) (deftest standard-char.2 (subtypep* 'standard-char 'character) t t) (deftest standard-char.3 (subtypep* 'standard-char t) t t) (deftest standard-char.4 (every #'(lambda (c) (typep c 'standard-char)) +standard-chars+) t) (deftest standard-char.5 (standard-char.5.body) t) (deftest extended-char.1 (subtypep* 'extended-char 'character) t t) (deftest extended-char.2 (subtypep* 'extended-char t) t t) (deftest extended-char.3 (extended-char.3.body) t) ;;; (deftest character.1 (character.1.body) t) (deftest character.2 (character.2.body) nil) (deftest character.order.1 (let ((i 0)) (values (character (progn (incf i) #\a)) i)) #\a 1) (deftest character.error.1 (classify-error (character)) program-error) (deftest character.error.2 (classify-error (character #\a #\a)) program-error) ;;; (deftest characterp.1 (every #'characterp +standard-chars+) t) (deftest characterp.2 (characterp.2.body) t) (deftest characterp.3 (characterp.3.body) t) (deftest characterp.order.1 (let ((i 0)) (values (characterp (incf i)) i)) nil 1) (deftest characterp.error.1 (classify-error (characterp)) program-error) (deftest characterp.error.2 (classify-error (characterp #\a #\b)) program-error) (deftest alpha-char-p.1 (loop for c across +standard-chars+ always (or (find c +alpha-chars+) (not (alpha-char-p c)))) t) ;;; (deftest alpha-char-p.2 (every #'alpha-char-p +alpha-chars+) t) (deftest alpha-char-p.3 (char-type-error-check #'alpha-char-p) t) (deftest alpha-char-p.order.1 (let ((i 0)) (values (alpha-char-p (progn (incf i) #\8)) i)) nil 1) (deftest alpha-char-p.error.1 (classify-error (alpha-char-p)) program-error) (deftest alpha-char-p.error.2 (classify-error (alpha-char-p #\a #\b)) program-error) ;;; (deftest alphanumericp.1 (loop for c across +standard-chars+ always (or (find c +alphanumeric-chars+) (not (alphanumericp c)))) t) (deftest alphanumericp.2 (every #'alphanumericp +alphanumeric-chars+) t) (deftest alphanumericp.3 (char-type-error-check #'alphanumericp) t) (deftest alphanumericp.4 (alphanumericp.4.body) t) (deftest alphanumericp.5 (alphanumericp.5.body) t) (deftest alphanumericp.order.1 (let ((i 0)) (values (alphanumericp (progn (incf i) #\?)) i)) nil 1) (deftest alphanumericp.error.1 (classify-error (alphanumericp)) program-error) (deftest alphanumericp.error.2 (classify-error (alphanumericp #\a #\b)) program-error) ;;; (deftest digit-char.1 (digit-char.1.body) t) (deftest digit-char.2 (map 'list #'digit-char (loop for i from 0 to 39 collect i)) (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) (deftest digit-char.order.1 (let ((i 0)) (values (digit-char (incf i)) i)) #\1 1) (deftest digit-char.order.2 (let ((i 0) x) (values (digit-char (incf i) (progn (setf x (incf i)) 10)) i x)) #\1 2 2) (deftest digit-char.error.1 (classify-error (digit-char)) program-error) (deftest digit-char.error.2 (classify-error (digit-char 0 10 'foo)) program-error) ;;; (deftest digit-char-p.1 (digit-char-p.1.body) t) (deftest digit-char-p.2 (digit-char-p.2.body) t) (deftest digit-char-p.3 (digit-char-p.3.body) t) (deftest digit-char-p.4 (digit-char-p.4.body) t) (deftest digit-char-p.5 (loop for i from 10 to 35 for c = (char +extended-digit-chars+ i) never (or (digit-char-p c) (digit-char-p (char-downcase c)))) t) (deftest digit-char-p.6 (loop for i from 0 below 10 for c = (char +extended-digit-chars+ i) always (eqlt (digit-char-p c) i)) t) (deftest digit-char-p.order.1 (let ((i 0)) (values (digit-char-p (progn (incf i) #\0)) i)) 0 1) (deftest digit-char-p.order.2 (let ((i 0) x y) (values (digit-char-p (progn (setf x (incf i)) #\0) (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) (deftest digit-char-p.error.1 (classify-error (digit-char-p)) program-error) (deftest digit-char-p.error.2 (classify-error (digit-char-p #\1 10 'foo)) program-error) ;;; (deftest graphic-char-p.1 (loop for c across +standard-chars+ always (if (eqlt c #\Newline) (not (graphic-char-p c)) (graphic-char-p c))) t) (deftest graphic-char-p.2 (loop for name in '("Rubout" "Page" "Backspace" "Tab" "Linefeed" "Return") for c = (name-char name) when (and c (graphic-char-p c)) collect c) nil) (deftest graphic-char-p.3 (char-type-error-check #'graphic-char-p) t) (deftest graphic-char-p.order.1 (let ((i 0)) (values (not (graphic-char-p (progn (incf i) #\a))) i)) nil 1) (deftest graphic-char-p.error.1 (classify-error (graphic-char-p)) program-error) (deftest graphic-char-p.error.2 (classify-error (graphic-char-p #\a #\a)) program-error) ;;; (deftest standard-char-p.1 (every #'standard-char-p +standard-chars+) t) (deftest standard-char-p.2 (standard-char-p.2.body) t) (deftest standard-char-p.2a (standard-char-p.2a.body) t) (deftest standard-char-p.3 (char-type-error-check #'standard-char-p) t) (deftest standard-char-p.order.1 (let ((i 0)) (values (not (standard-char-p (progn (incf i) #\a))) i)) nil 1) (deftest standard-char-p.error.1 (classify-error (standard-char-p)) program-error) (deftest standard-char-p.error.2 (classify-error (standard-char-p #\a #\a)) program-error) ;;; (deftest char-upcase.1 (char-upcase.1.body) t) (deftest char-upcase.2 (char-upcase.2.body) t) (deftest char-upcase.3 (map 'string #'char-upcase +alpha-chars+) "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest char-upcase.4 (char-type-error-check #'char-upcase) t) (deftest char-upcase.order.1 (let ((i 0)) (values (char-upcase (progn (incf i) #\a)) i)) #\A 1) (deftest char-upcase.error.1 (classify-error (char-upcase)) program-error) (deftest char-upcase.error.2 (classify-error (char-upcase #\a #\a)) program-error) ;;; (deftest char-downcase.1 (char-downcase.1.body) t) (deftest char-downcase.2 (char-downcase.2.body) t) (deftest char-downcase.3 (map 'string #'char-downcase +alpha-chars+) "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest char-downcase.4 (char-type-error-check #'char-downcase) t) (deftest char-downcase.order.1 (let ((i 0)) (values (char-downcase (progn (incf i) #\A)) i)) #\a 1) (deftest char-downcase.error.1 (classify-error (char-downcase)) program-error) (deftest char-downcase.error.2 (classify-error (char-downcase #\A #\A)) program-error) ;;; (deftest upper-case-p.1 (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) nil) (deftest upper-case-p.2 (find-if #'upper-case-p +standard-chars+ :end 26) nil) (deftest upper-case-p.3 (find #'upper-case-p +standard-chars+ :start 52) nil) (deftest upper-case-p.4 (char-type-error-check #'upper-case-p) t) (deftest upper-case-p.order.1 (let ((i 0)) (values (upper-case-p (progn (incf i) #\a)) i)) nil 1) (deftest upper-case-p.error.1 (classify-error (upper-case-p)) program-error) (deftest upper-case-p.error.2 (classify-error (upper-case-p #\a #\A)) program-error) ;;; (deftest lower-case-p.1 (find-if-not #'lower-case-p +standard-chars+ :end 26) nil) (deftest lower-case-p.2 (find-if #'lower-case-p +standard-chars+ :start 26) nil) (deftest lower-case-p.3 (char-type-error-check #'lower-case-p) t) (deftest lower-case-p.order.1 (let ((i 0)) (values (lower-case-p (progn (incf i) #\A)) i)) nil 1) (deftest lower-case-p.error.1 (classify-error (lower-case-p)) program-error) (deftest lower-case-p.error.2 (classify-error (lower-case-p #\a #\a)) program-error) ;;; (deftest both-case-p.1 (both-case-p.1.body) t) (deftest both-case-p.2 (both-case-p.2.body) t) (deftest both-case-p.3 (char-type-error-check #'both-case-p) t) (deftest both-case-p.order.1 (let ((i 0)) (values (both-case-p (progn (incf i) #\5)) i)) nil 1) (deftest both-case-p.error.1 (classify-error (both-case-p)) program-error) (deftest both-case-p.error.2 (classify-error (both-case-p #\a #\a)) program-error) ;;; (deftest char-code.1 (char-type-error-check #'char-code) t) (deftest char-code.2 (char-code.2.body) t) (deftest char-code.order.1 (let ((i 0)) (values (not (numberp (char-code (progn (incf i) #\a)))) i)) nil 1) (deftest char-code.error.1 (classify-error (char-code)) program-error) (deftest char-code.error.2 (classify-error (char-code #\a #\a)) program-error) ;;; (deftest code-char.1 (loop for x across +standard-chars+ always (eqlt (code-char (char-code x)) x)) t) (deftest code-char.order.1 (let ((i 0)) (values (code-char (progn (incf i) (char-code #\a))) i)) #\a 1) (deftest code-char.error.1 (classify-error (code-char)) program-error) (deftest code-char.error.2 (classify-error (code-char 1 1)) program-error) ;;; (deftest char-int.1 (loop for x across +standard-chars+ always (eqlt (char-int x) (char-code x))) t) (deftest char-int.2 (char-int.2.fn) t) (deftest char-int.order.1 (let ((i 0)) (values (code-char (char-int (progn (incf i) #\a))) i)) #\a 1) (deftest char-int.error.1 (classify-error (char-int)) program-error) (deftest char-int.error.2 (classify-error (char-int #\a #\a)) program-error) ;;; (deftest char-name.1 (char-name.1.fn) t) (deftest char-name.2 (notnot-mv (string= (char-name #\Space) "Space")) t) (deftest char-name.3 (notnot-mv (string= (char-name #\Newline) "Newline")) t) ;;; Check that the names of various semi-standard characters are ;;; appropriate. This is complicated by the possibility that two different ;;; names may refer to the same character (as is allowed by the standard, ;;; for example in the case of Newline and Linefeed). (deftest char-name.4 (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") for c = (name-char s) unless (or (not c) ;; If the char-name is not even string-equal, ;; assume we're sharing the character with some other ;; name, and assume it's ok (not (string-equal (char-name c) s)) (string= (char-name c) s)) ;; Collect list of cases that failed collect (list s c (char-name c))) nil) (deftest char-name.5 (char-type-error-check #'char-name) t) (deftest char-name.order.1 (let ((i 0)) (values (char-name (progn (incf i) #\Space)) i)) "Space" 1) (deftest char-name.error.1 (classify-error (char-name)) program-error) (deftest char-name.error.2 (classify-error (char-name #\a #\a)) program-error) ;;; (deftest name-char.1 (name-char.1.body) t) (deftest name-char.2 (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" "SpaCE" "NewLine") always (let ((c1 (name-char (string-upcase s))) (c2 (name-char (string-downcase s))) (c3 (name-char (string-capitalize s))) (c4 (name-char s))) (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) t) (deftest name-char.order.1 (let ((i 0)) (values (name-char (progn (incf i) "Space")) i)) #\Space 1) (deftest name-char.error.1 (classify-error (name-char)) program-error) (deftest name-char.error.2 (classify-error (name-char "space" "space")) program-error) gcl-2.6.14/ansi-tests/gclload.lsp0000644000175000017500000000013514360276512015211 0ustar cammcamm(load "gclload1.lsp") (load "gclload2.lsp") (in-package :cl-test) (regression-test:do-tests) gcl-2.6.14/ansi-tests/packages-15.lsp0000644000175000017500000001374014360276512015613 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:08:41 1998 ;;;; Contains: Package test code, part 15 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; use-package (deftest use-package.1 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg)) (i 0) x y) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package (progn (setf x (incf i)) pg) (progn (setf y (incf i)) ph)) t) ;; "H" will use "G" (eql i 2) (eql x 1) (eql y 2) (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.2 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package "G" "H") t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) (deftest use-package.4 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use nil)) (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) (null (package-used-by-list ph)) (null (package-use-list pg)) (null (package-use-list ph)) (eqt (ignore-errors (use-package #\G #\H)) t) ;; "H" will use "G" (multiple-value-bind (sym2 access) (find-symbol "FOO" ph) (and (eqt access :inherited) (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) (null (package-used-by-list ph)) (eqt (unuse-package pg ph) t) (null (find-symbol "FOO" ph))))) t) ;; use lists of packages (deftest use-package.5 (let ((pkgs '("H" "G1" "G2" "G3")) (vars '("FOO1" "FOO2" "FOO3"))) (dolist (p pkgs) (safely-delete-package p) (make-package p :use nil)) (and (every (complement #'package-use-list) pkgs) (every (complement #'package-used-by-list) pkgs) (every #'(lambda (v p) (export (intern v p) p)) vars (cdr pkgs)) (progn (dolist (p (cdr pkgs)) (intern "MINE" p)) (eqt (use-package (cdr pkgs) (car pkgs)) t)) (every #'(lambda (v p) (eqt (find-symbol v p) (find-symbol v (car pkgs)))) vars (cdr pkgs)) (null (find-symbol "MINE" (car pkgs))) (every #'(lambda (p) (equal (package-used-by-list p) (list (find-package (car pkgs))))) (cdr pkgs)) (equal (sort-package-list (package-use-list (car pkgs))) (mapcar #'find-package (cdr pkgs))) (every (complement #'package-use-list) (cdr pkgs)) (null (package-used-by-list (car pkgs))))) t) ;; Circular package use (deftest use-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") (let ((pg (make-package "G")) (ph (make-package "H")) sym1 sym2 sym3 sym4 a1 a2 a3 a4) (prog1 (and (export (intern "X" pg) pg) (export (intern "Y" ph) ph) (use-package pg ph) (use-package ph pg) (progn (multiple-value-setq (sym1 a1) (find-symbol "X" pg)) (multiple-value-setq (sym2 a2) (find-symbol "Y" ph)) (multiple-value-setq (sym3 a3) (find-symbol "Y" pg)) (multiple-value-setq (sym4 a4) (find-symbol "X" ph)) (and (eqt a1 :external) (eqt a2 :external) (eqt a3 :inherited) (eqt a4 :inherited) (eqt sym1 sym4) (eqt sym2 sym3) (eqt (symbol-package sym1) pg) (eqt (symbol-package sym2) ph) (unuse-package pg ph) (unuse-package ph pg)))) (safely-delete-package pg) (safely-delete-package ph)))) t) ;; Also: need to check that *PACKAGE* is used as a default (deftest use-package.error.1 (classify-error (use-package)) program-error) (deftest use-package.error.2 (progn (safely-delete-package "UPE2A") (safely-delete-package "UPE2") (make-package "UPE2" :use ()) (make-package "UPE2A" :use ()) (classify-error (use-package "UPE2" "UPE2A" nil))) program-error) gcl-2.6.14/ansi-tests/loop11.lsp0000644000175000017500000000532314360276512014723 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Nov 16 21:39:33 2002 ;;;; Contains: Tests for loop termination clauses REPEAT, WHILE and UNTIL (in-package :cl-test) ;;; Tests of REPEAT (deftest loop.11.1 (let ((z 0)) (values (loop repeat 10 do (incf z)) z)) nil 10) (deftest loop.11.2 (loop repeat 10 collect 'a) (a a a a a a a a a a)) (deftest loop.11.3 (let ((z 0)) (loop repeat 0 do (incf z)) z) 0) (deftest loop.11.4 (let ((z 0)) (loop repeat -1 do (incf z)) z) 0) (deftest loop.11.5 (let ((z 0)) (loop repeat -1.5 do (incf z)) z) 0) (deftest loop.11.6 (let ((z 0)) (loop repeat -1000000000000 do (incf z)) z) 0) (deftest loop.11.7 (let ((z 0)) (loop repeat 10 do (incf z) (loop-finish)) z) 1) (deftest loop.11.8 (loop repeat 3 for i in '(a b c d e) collect i) (a b c)) (deftest loop.11.9 (loop for i in '(a b c d e) collect i repeat 3) (a b c)) ;;; Tests of WHILE (deftest loop.11.10 (loop with i = 0 while (< i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.11 (loop with i = 0 while (if (< i 10) t (return 'good)) collect (incf i)) good) (deftest loop.11.12 (loop with i = 0 while (< i 10) collect (incf i) while (< i 10) collect (incf i) while (< i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.13 (loop with i = 0 while (< i 10) collect (incf i) finally (return 'done)) done) (deftest loop.11.14 (loop for i in '(a b c) while nil collect i) nil) (deftest loop.11.15 (loop for i in '(a b c) collect i while nil) (a)) (deftest loop.11.16 (loop for i in '(a b c) while t collect i) (a b c)) (deftest loop.11.17 (loop for i in '(a b c) collect i while t) (a b c)) (deftest loop.11.18 (loop for i from 1 to 10 while (< i 6) finally (return i)) 6) ;;; Tests of UNTIL (deftest loop.11.20 (loop with i = 0 until (>= i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.21 (loop with i = 0 while (if (< i 10) t (return 'good)) collect (incf i)) good) (deftest loop.11.22 (loop with i = 0 until (>= i 10) collect (incf i) until (>= i 10) collect (incf i) until (>= i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.23 (loop with i = 0 until (>= i 10) collect (incf i) finally (return 'done)) done) (deftest loop.11.24 (loop for i in '(a b c) until t collect i) nil) (deftest loop.11.25 (loop for i in '(a b c) collect i until t) (a)) (deftest loop.11.26 (loop for i in '(a b c) until nil collect i) (a b c)) (deftest loop.11.27 (loop for i in '(a b c) collect i until nil) (a b c)) (deftest loop.11.28 (loop for i from 1 to 10 until (>= i 6) finally (return i)) 6) gcl-2.6.14/ansi-tests/cons-test-05.lsp0000644000175000017500000001103414360276512015745 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:08 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 5 (in-package :cl-test) (declaim (optimize (safety 3))) (defparameter *cons-accessors* '(first second third fourth fifth sixth seventh eighth ninth tenth car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; first, ..., tenth (deftest first-etc-1 (let ((x (loop for i from 1 to 20 collect i))) (list (first x) (second x) (third x) (fourth x) (fifth x) (sixth x) (seventh x) (eighth x) (ninth x) (tenth x))) (1 2 3 4 5 6 7 8 9 10)) (deftest first-etc-2 (let ((x (make-list 15 :initial-element 'a))) (and (eql (setf (first x) 1) 1) (eql (setf (second x) 2) 2) (eql (setf (third x) 3) 3) (eql (setf (fourth x) 4) 4) (eql (setf (fifth x) 5) 5) (eql (setf (sixth x) 6) 6) (eql (setf (seventh x) 7) 7) (eql (setf (eighth x) 8) 8) (eql (setf (ninth x) 9) 9) (eql (setf (tenth x) 10) 10) x)) (1 2 3 4 5 6 7 8 9 10 a a a a a)) (deftest rest-set-1 (let ((x (list 'a 'b 'c))) (and (eqt (setf (rest x) 'd) 'd) x)) (a . d)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; setting of C*R accessors (loop for fn in '(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET") :cl-test) (let ((x (create-c*r-test ,level)) (y (list (create-c*r-test ,level))) (i 0)) (and (setf (,fn (progn (incf i) x)) 'a) (eqlt (,fn x) 'a) (eqlt i 1) (setf (,fn x) 'none) (equalt x (create-c*r-test ,level)) (setf (,fn (progn (incf i) (car y))) 'a) (eqlt (,fn (car y)) 'a) (eqlt i 2) (setf (,fn (car y)) 'none) (null (cdr y)) (equalt (car y) (create-c*r-test ,level)) )) t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) (fifth 5) (sixth 6) (seventh 7) (eighth 8) (ninth 9) (tenth 10)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name fn) "-SET") :cl-test) (let* ((x (make-list 20 :initial-element nil)) (y (list (copy-list x))) (cnt 0)) (and (setf (,fn (progn (incf cnt) x)) 'a) (eqlt cnt 1) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) x)) (return nil)) finally (return t)) (setf (,fn (car y)) 'a) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) (car y))) (return nil)) finally (return t)) (eqlt (,fn x) 'a) (eqlt (nth ,(1- len) x) 'a) (eqlt (,fn (car y)) 'a) (nth ,(1- len) (car y)))) a))) ;; set up program error tests (loop for name in *cons-accessors* do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.NO-ARGS") :cl-test) (classify-error (,name)) program-error)) do (eval `(deftest ,(intern (concatenate 'string (symbol-name name) ".ERROR.EXCESS-ARGS") :cl-test) (classify-error (,name nil nil)) program-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nth (deftest nth.1 (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) 0) (deftest nth.2 (let ((x (loop for i from 1 to 2000 collect i))) (loop for i from 0 to 1999 do (setf (nth i x) (- 1999 i))) (equalt x (loop for i from 1999 downto 0 collect i))) t) ;;; Test side effects, evaluation order in assignment to NTH (deftest nth.order.1 (let ((i 0) (x (list 'a 'b 'c 'd)) y z) (and (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) 'z) (eqlt y 1) (eqlt z 2) x)) (a z c d)) (deftest nth.order.2 (let ((i 0) x y (z '(a b c d e))) (values (nth (progn (setf x (incf i)) 1) (progn (setf y (incf i)) z)) i x y)) b 2 1 2) (deftest nth.error.1 (classify-error (nth)) program-error) (deftest nth.error.2 (classify-error (nth 0)) program-error) (deftest nth.error.3 (classify-error (nth 1 '(a b c) nil)) program-error) (deftest nth.error.4 (classify-error (nth 0 '(a b c) nil)) program-error) gcl-2.6.14/ansi-tests/make-synonym-stream.lsp0000644000175000017500000000513414360276512017530 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:54:33 2004 ;;;; Contains: Tests of MAKE-SYNONYM-STREAM (in-package :cl-test) (deftest make-synonym-stream.1 (with-input-from-string (*s* "abcde") (declare (special *s*)) (let ((ss (make-synonym-stream '*s*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (input-stream-p ss)) (assert (not (output-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (values (read-char *s*) (read-char ss) (read-char *s*) (read-char ss) (read-char ss)))) #\a #\b #\c #\d #\e) ;;; This test was wrong (section 21.1.4) #| (deftest make-synonym-stream.2 (let ((ss (make-synonym-stream '*s*))) (with-input-from-string (*s* "z") (declare (special *s*)) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (input-stream-p ss)) (assert (not (output-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (read-char ss))) #\z) |# (deftest make-synonym-stream.3 (with-output-to-string (*s*) (declare (special *s*)) (let ((ss (make-synonym-stream '*s*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (output-stream-p ss)) (assert (not (input-stream-p ss))) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) (write-char #\a *s*) (write-char #\b ss) (write-char #\x *s*) (write-char #\y ss))) "abxy") (deftest make-synonym-stream.4 (let ((ss (make-synonym-stream '*terminal-io*))) (assert (typep ss 'stream)) (assert (typep ss 'synonym-stream)) (assert (output-stream-p ss)) (assert (input-stream-p ss)) (assert (open-stream-p ss)) (assert (streamp ss)) (assert (stream-element-type ss)) nil) nil) ;;; FIXME ;;; Add tests for: close, ;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, ;;; read-line, write-line, write-string, read-sequence, write-sequence, ;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, ;;; clear-output, format, print, prin1, princ ;;; Error cases (deftest make-synonym-stream.error.1 (signals-error (make-synonym-stream) program-error) t) (deftest make-synonym-stream.error.2 (signals-error (make-synonym-stream '*standard-input* nil) program-error) t) (deftest make-synonym-stream.error.3 (check-type-error #'make-synonym-stream #'symbolp) nil) gcl-2.6.14/ansi-tests/block.lsp0000644000175000017500000000215314360276512014700 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 12:30:46 2002 ;;;; Contains: Tests of BLOCK (in-package :cl-test) (deftest block.1 (block foo (return-from foo 1)) 1) (deftest block.2 (block nil (block foo (return 'good)) 'bad) good) (deftest block.3 (block done (flet ((%f (x) (return-from done x))) (%f 'good)) 'bad) good) (deftest block.4 (block foo (block foo (return-from foo 'bad)) 'good) good) (deftest block.5 (block done (flet ((%f (x) (return-from done x))) (mapcar #'%f '(good bad bad))) 'bad) good) (deftest block.6 (block b1 (return-from b1 (values)) 1)) (deftest block.7 (block b1 (return-from b1 (values 1 2 3 4)) 1) 1 2 3 4) (deftest block.8 (block foo) nil) (deftest block.9 (block foo (values 'a 'b) (values 'c 'd)) c d) (deftest block.10 (block done (flet ((%f (x) (return-from done x))) (block done (mapcar #'%f '(good bad bad)))) 'bad) good) #| (deftest return.error.1 (classify-error (block nil (return 'a 'b))) program-error) |# gcl-2.6.14/ansi-tests/when.lsp0000644000175000017500000000110114360276512014537 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:36:57 2002 ;;;; Contains: Tests of WHEN (in-package :cl-test) (deftest when.1 (when t) nil) (deftest when.2 (when nil 'a) nil) (deftest when.3 (when t (values))) (deftest when.4 (when t (values 'a 'b 'c 'd)) a b c d) (deftest when.5 (when nil (values)) nil) (deftest when.6 (when nil (values 'a 'b 'c 'd)) nil) (deftest when.7 (let ((x 0)) (values (when t (incf x) 'a) x)) a 1) ;;; (deftest when.error.1 ;;; (classify-error (when)) ;;; program-error) gcl-2.6.14/ansi-tests/write-char.lsp0000644000175000017500000000165214360276512015656 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:50:31 2004 ;;;; Contains: Tests of WRITE-CHAR (in-package :cl-test) (deftest write-char.1 (loop for i from 0 to 255 for c = (code-char i) when c unless (string= (with-output-to-string (*standard-output*) (write-char c)) (string c)) collect c) nil) (deftest write-char.2 (with-input-from-string (is "abcd") (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream is os))) (write-char #\$ t) (close *terminal-io*)))) "$") (deftest write-char.3 (with-output-to-string (*standard-output*) (write-char #\: nil)) ":") ;;; Error tests (deftest write-char.error.1 (signals-error (write-char) program-error) t) (deftest write-char.error.2 (signals-error (with-output-to-string (s) (write-char #\a s nil)) program-error) t) ;;; More tests in other files gcl-2.6.14/ansi-tests/file-namestring.lsp0000644000175000017500000000210214360276512016664 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 11 07:40:47 2004 ;;;; Contains: Tests for FILE-NAMESTRING (in-package :cl-test) (deftest file-namestring.1 (let* ((vals (multiple-value-list (file-namestring "file-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (file-namestring s) s)) :good vals)) :good) (deftest file-namestring.2 (do-special-strings (s "file-namestring.lsp" nil) (let ((ns (file-namestring s))) (assert (stringp ns)) (assert (string= (file-namestring ns) ns)))) nil) (deftest file-namestring.3 (let* ((name "file-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (file-namestring s))) (name3 (file-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) ;;; Error tests (deftest file-namestring.error.1 (signals-error (file-namestring) program-error) t) (deftest file-namestring.error.2 (signals-error (file-namestring "file-namestring.lsp" nil) program-error) t) gcl-2.6.14/ansi-tests/load-logical-pathname-translations.lsp0000644000175000017500000000163714360276512022455 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 09:31:33 2003 ;;;; Contains: Tests (such as they are) for LOAD-LOGICAL-PATHNAME-TRANSLATIONS (in-package :cl-test) ;;; The function LOAD-LOGICAL-PATHNAME-TRANSLATIONS is almost entirely ;;; untestable, since the basic behavior is implementation defined. (deftest load-logical-pathname-translations.1 (load-logical-pathname-translations "CLTESTROOT") nil) ;;; Error cases (deftest load-logical-pathname-translations.error.1 (handler-case (progn (load-logical-pathname-translations "THEREHADBETTERNOTBEAHOSTCALLEDTHIS") nil) (error () :good)) :good) (deftest load-logical-pathname-translations.error.2 (signals-error (load-logical-pathname-translations) program-error) t) (deftest load-logical-pathname-translations.error.3 (signals-error (load-logical-pathname-translations "CLTESTROOT" nil) program-error) t) gcl-2.6.14/ansi-tests/adjustable-array-p.lsp0000644000175000017500000000320614360276512017275 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 20 21:25:22 2003 ;;;; Contains: Tests for ADJUSTABLE-ARRAY-P (in-package :cl-test) (deftest adjustable-array-p.1 (notnot (adjustable-array-p (make-array '(5) :adjustable t))) t) (deftest adjustable-array-p.2 (notnot (adjustable-array-p (make-array nil :adjustable t))) t) (deftest adjustable-array-p.3 (notnot (adjustable-array-p (make-array '(2 3) :adjustable t))) t) (deftest adjustable-array-p.4 (notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t))) t) (deftest adjustable-array-p.5 (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) t) (deftest adjustable-array-p.order.1 (let ((i 0) x) (values (notnot (adjustable-array-p (progn (setf x (incf i)) (make-array '(5) :adjustable t)))) i x)) t 1 1) ;;; Error tests (deftest adjustable-array-p.error.1 (classify-error (adjustable-array-p)) program-error) (deftest adjustable-array-p.error.2 (classify-error (adjustable-array-p "aaa" nil)) program-error) (deftest adjustable-array-p.error.3 (classify-error (adjustable-array-p 10)) type-error) (deftest adjustable-array-p.error.4 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(adjustable-array-p ',e))))) collect (list e why))) nil) (deftest adjustable-array-p.error.5 (classify-error (locally (adjustable-array-p 10))) type-error) (deftest adjustable-array-p.error.6 (classify-error (let ((x 10)) (locally (declare (optimize (safety 3))) (adjustable-array-p x)))) type-error) gcl-2.6.14/ansi-tests/load-conditions.lsp0000644000175000017500000000035014360276512016671 0ustar cammcamm;;; Tests of conditions (load "condition.lsp") (load "cell-error-name.lsp") (load "assert.lsp") (load "error.lsp") (load "cerror.lsp") (load "check-type.lsp") (load "warn.lsp") (load "invoke-debugger.lsp") (load "handler-bind.lsp") gcl-2.6.14/ansi-tests/logical-pathname-translations.lsp0000644000175000017500000000025114360276512021527 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 09:46:08 2003 ;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS (in-package :cl-test) gcl-2.6.14/ansi-tests/parse-namestring.lsp0000644000175000017500000000475314360276512017075 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 14 13:59:18 2004 ;;;; Contains: Tests of PARSE-NAMESTRING (in-package :cl-test) ;;; "Parsing a null string always succeeds, producing a pathname ;;; with all components (except the host) equal to nil." (deftest parse-namestring.1 (let ((vals (multiple-value-list (parse-namestring "")))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.2 (let ((vals (multiple-value-list (parse-namestring (make-array 0 :element-type 'base-char))))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.3 (let ((vals (multiple-value-list (parse-namestring (make-array 4 :element-type 'base-char :initial-element #\X :fill-pointer 0))))) (assert (= (length vals) 2)) (let ((pn (first vals)) (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) nil nil nil nil nil 0) (deftest parse-namestring.4 (loop for etype in '(standard-char base-char character) for s0 = (make-array 4 :element-type etype :initial-element #\X) for s = (make-array 0 :element-type etype :displaced-to s0 :displaced-index-offset 1) for vals = (multiple-value-list (parse-namestring s)) for pn = (first vals) for pos = (second vals) do (assert (= (length vals) 2)) nconc (let ((result (list (pathname-directory pn) (pathname-device pn) (pathname-name pn) (pathname-type pn) (pathname-version pn) pos))) (unless (equal result '(nil nil nil nil nil 0)) (list (list etype result))))) nil) ;;; Error tests (deftest parse-namestring.error.1 (signals-error (parse-namestring) program-error) t) (deftest parse-name-string.error.2 (signals-error (parse-namestring "" nil *default-pathname-defaults* :foo nil) program-error) t) (deftest parse-name-string.error.3 (signals-error (parse-namestring "" nil *default-pathname-defaults* :start) program-error) t) gcl-2.6.14/ansi-tests/array-total-size.lsp0000644000175000017500000000251314360276512017015 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:01:09 2003 ;;;; Contains: Tests of ARRAY-TOTAL-SIZE (in-package :cl-test) ;;; More tests of ARRAY-TOTAL-SIZE are in make-array.lsp (deftest array-total-size.1 (array-total-size #0aNIL) 1) (deftest array-total-size.2 (array-total-size "abcdef") 6) (deftest array-total-size.3 (array-total-size #(a b c)) 3) (deftest array-total-size.4 (array-total-size #*0011010) 7) (deftest array-total-size.5 (array-total-size #2a((1 2 3)(4 5 6)(7 8 9)(a b c))) 12) (deftest array-total-size.order.1 (let ((i 0) a) (values (array-total-size (progn (setf a (incf i)) #(a b c d))) i a)) 4 1 1) ;;; Error tests (deftest array-total-size.error.1 (classify-error (array-total-size)) program-error) (deftest array-total-size.error.2 (classify-error (array-total-size #(a b c) nil)) program-error) (deftest array-total-size.error.3 (let (why) (loop for e in *mini-universe* when (and (not (typep e 'array)) (not (eql (setq why (classify-error** `(array-total-size ',e))) 'type-error))) collect (list e why))) nil) (deftest array-total-size.error.4 (classify-error (array-total-size 0)) type-error) (deftest array-total-size.error.5 (classify-error (locally (array-total-size 0) t)) type-error) gcl-2.6.14/ansi-tests/loop4.lsp0000644000175000017500000000206614360276512014646 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 27 22:46:39 2002 ;;;; Contains: Tests for LOOP FOR-AS-EQUAL-THEN (in-package :cl-test) (deftest loop.4.1 (loop for x = 1 then (1+ x) until (> x 5) collect x) (1 2 3 4 5)) (deftest loop.4.2 (loop for i from 1 to 10 for j = (1+ i) collect j) (2 3 4 5 6 7 8 9 10 11)) (deftest loop.4.3 (loop for i from 1 to 10 for j of-type integer = (1+ i) collect j) (2 3 4 5 6 7 8 9 10 11)) (deftest loop.4.4 (loop for e on '(a b c d e) for (x . y) = e collect x) (a b c d e)) (deftest loop.4.5 (loop for (x . y) = '(a b c d e) then y while x collect x) (a b c d e)) ;;; Error cases (deftest loop.4.6 (classify-error (loop for (x . x) = '(nil nil nil) until x count t)) program-error) (deftest loop.4.7 (classify-error* (macroexpand '(loop for (x . x) = '(nil nil nil) until x count t))) program-error) (deftest loop.4.8 (classify-error* (macroexpand '(loop for x = '(nil nil nil) for x = 1 count x until t))) program-error) gcl-2.6.14/ansi-tests/identity.lsp0000644000175000017500000000123714360276512015441 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 23:21:11 2002 ;;;; Contains: Tests for IDENTITY (in-package :cl-test) (deftest identity.1 (loop for x in *universe* always (eqlt x (check-values (identity x)))) t) (deftest identity.2 (let ((x (ash 1 100))) (eqlt x (check-values (identity x)))) t) (deftest identity.3 (let ((x 1.00000001)) (eqlt x (check-values (identity x)))) t) (deftest identity.order.1 (let ((i 0)) (values (identity (incf i)) i)) 1 1) (deftest identity.error.1 (classify-error (identity)) program-error) (deftest identity.error.2 (classify-error (identity 'a 'a)) program-error) gcl-2.6.14/ansi-tests/clear-input.lsp0000644000175000017500000000256714360276512016042 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:12:39 2004 ;;;; Contains: Tests of CLEAR-INPUT (in-package :cl-test) ;;; These tests are limited, since whether an input stream can be ;;; cleared is not well specified. (deftest clear-input.1 (loop for s in (list *debug-io* *query-io* *standard-input* *terminal-io*) always (eq (clear-input s) nil)) t) (deftest clear-input.2 (clear-input) nil) (deftest clear-input.3 (clear-input nil) nil) (deftest clear-input.4 (clear-input t) nil) (deftest clear-input.5 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) (clear-input t))) nil) (deftest clear-input.6 (with-input-from-string (*standard-input* "345") (clear-input nil)) nil) ;;; Error cases (deftest clear-input.error.1 :notes (:assume-no-simple-streams) (signals-error (clear-input t nil) program-error) t) (deftest clear-input.error.2 :notes (:assume-no-simple-streams) (signals-error (clear-input nil nil) program-error) t) (deftest clear-input.error.3 (signals-error (clear-input t nil nil) program-error) t) (deftest clear-input.error.4 (signals-error (clear-input nil nil nil) program-error) t) (deftest clear-input.error.5 (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl-2.6.14/ansi-tests/destructuring-bind.lsp0000644000175000017500000000552414360276512017427 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:25:50 2002 ;;;; Contains: Tests for DESTRUCTURING-BIND (in-package :cl-test) ;;; See the page for this in section 5.3 ;;; Also, see destructuring lambda lists in section 3.4.5 (deftest destructuring-bind.1 (destructuring-bind (x y z) '(a b c) (values x y z)) a b c) (deftest destructuring-bind.2 (destructuring-bind (x y &rest z) '(a b c d) (values x y z)) a b (c d)) (deftest destructuring-bind.3 (destructuring-bind (x y &optional z) '(a b c) (values x y z)) a b c) (deftest destructuring-bind.4 (destructuring-bind (x y &optional z) '(a b) (values x y z)) a b nil) (deftest destructuring-bind.5 (destructuring-bind (x y &optional (z 'w)) '(a b) (values x y z)) a b w) (deftest destructuring-bind.6 (destructuring-bind (x y &optional (z 'w z-p)) '(a b) (values x y z z-p)) a b w nil) (deftest destructuring-bind.7 (destructuring-bind (x y &optional (z 'w z-p)) '(a b c) (values x y z z-p)) a b c t) (deftest destructuring-bind.8 (destructuring-bind (x y &optional z w) '(a b c) (values x y z w)) a b c nil) (deftest destructuring-bind.9 (destructuring-bind ((x y)) '((a b)) (values x y)) a b) (deftest destructuring-bind.10 (destructuring-bind (&whole w (x y)) '((a b)) (values x y w)) a b ((a b))) (deftest destructuring-bind.11 (destructuring-bind ((x . y) . w) '((a b) c) (values x y w)) a (b) (c)) (deftest destructuring-bind.12 (destructuring-bind (x y &body z) '(a b c d) (values x y z)) a b (c d)) (deftest destructuring-bind.13 (destructuring-bind (&whole x y z) '(a b) (values x y z)) (a b) a b) (deftest destructuring-bind.14 (destructuring-bind (w (&whole x y z)) '(1 (a b)) (values w x y z)) 1 (a b) a b) (deftest destructuring-bind.15 (destructuring-bind (&key a b c) '(:a 1) (values a b c)) 1 nil nil) (deftest destructuring-bind.16 (destructuring-bind (&key a b c) '(:b 1) (values a b c)) nil 1 nil) (deftest destructuring-bind.17 (destructuring-bind (&key a b c) '(:c 1) (values a b c)) nil nil 1) (deftest destructuring-bind.18 (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) nil 2 1) ;;; Error cases #| (deftest destructuring-bind.error.1 (classify-error (destructuring-bind (a b c) nil (list a b c))) program-error) (deftest destructuring-bind.error.2 (classify-error (destructuring-bind ((a b c)) nil (list a b c))) program-error) (deftest destructuring-bind.error.3 (classify-error (destructuring-bind (a b) 'x (list a b))) program-error) (deftest destructuring-bind.error.4 (classify-error (destructuring-bind (a . b) 'x (list a b))) program-error) |# ;;; (deftest destructuring-bind.error.5 ;;; (classify-error (destructuring-bind)) ;;; program-error) ;;; ;;; (deftest destructuring-bind.error.6 ;;; (classify-error (destructuring-bind x)) ;;; program-error) gcl-2.6.14/ansi-tests/fresh-line.lsp0000644000175000017500000000360014360276512015640 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:41:18 2004 ;;;; Contains: Tests of FRESH-LINE (in-package :cl-test) (deftest fresh-line.1 (let (result) (values (with-output-to-string (*standard-output*) (write-char #\a) (setq result (notnot (fresh-line)))) result)) #.(concatenate 'string "a" (string #\Newline)) t) (deftest fresh-line.2 (let (result) (values (with-output-to-string (s) (write-char #\a s) (setq result (notnot (fresh-line s)))) result)) #.(concatenate 'string "a" (string #\Newline)) t) (deftest fresh-line.3 (with-output-to-string (s) (write-char #\x s) (fresh-line s) (fresh-line s) (write-char #\y s)) #.(concatenate 'string "x" (string #\Newline) "y")) (deftest fresh-line.4 (let (result) (values (with-output-to-string (*standard-output*) (setq result (multiple-value-list (fresh-line)))) result)) "" (nil)) (deftest fresh-line.5 (let (result) (values (with-output-to-string (s) (write-char #\Space s) (setq result (list (multiple-value-list (notnot-mv (fresh-line s))) (multiple-value-list (fresh-line s)) (multiple-value-list (fresh-line s))))) result)) " " ((t) (nil) (nil))) (deftest fresh-line.6 (with-output-to-string (os) (let ((*terminal-io* (make-two-way-stream *standard-input* os))) (write-char #\a t) (fresh-line t) (finish-output t))) #.(concatenate 'string (string #\a) (string #\Newline))) (deftest fresh-line.7 (with-output-to-string (*standard-output*) (write-char #\a nil) (terpri nil)) #.(concatenate 'string (string #\a) (string #\Newline))) ;;; Error tests (deftest fresh-line.error.1 (signals-error (with-output-to-string (s) (fresh-line s nil)) program-error) t) gcl-2.6.14/ansi-tests/make-echo-stream.lsp0000644000175000017500000002175014360276512016734 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:34:42 2004 ;;;; Contains: Tests of MAKE-ECHO-STREAM (in-package :cl-test) (deftest make-echo-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (read-char s) (get-output-stream-string os))) #\f "f") (deftest make-echo-stream.2 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (get-output-stream-string os)) "") (deftest make-echo-stream.3 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (read-line s nil) (get-output-stream-string os))) "foo" "foo") ;;; Tests of READ-BYTE on echo streams (deftest make-echo-stream.4 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os))) (loop repeat 6 collect (read-byte s nil :eof1)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil :eof2)))))) (2 3 5 7 11 :eof1) (2 3 5 7 11 :eof2)) (deftest make-echo-stream.5 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os))) (loop repeat 6 collect (read-byte s nil 100)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil 200)))))) (2 3 5 7 11 100) (2 3 5 7 11 200)) (deftest make-echo-stream.6 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (coerce (loop repeat 3 collect (read-char-no-hang s)) 'string) (get-output-stream-string os))) "foo" "foo") (deftest make-echo-stream.7 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (coerce (loop repeat 4 collect (read-char-no-hang s nil '#\z)) 'string) (get-output-stream-string os))) "fooz" "foo") ;;; peek-char + echo streams is tested in peek-char.lsp ;;; unread-char + echo streams is tested in unread-char.lsp (deftest make-echo-stream.8 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os)) (x (copy-seq "xxxxxx"))) (values (read-sequence x s) x (get-output-stream-string os))) 3 "fooxxx" "foo") (deftest make-echo-stream.9 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede) (loop for x in '(2 3 5 7 11) do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (vector 0 0 0 0 0 0 0 0))) (list (read-sequence x s) x))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 8 collect (read-byte s nil nil)))))) (5 #(2 3 5 7 11 0 0 0)) (2 3 5 7 11 nil nil nil)) (deftest make-echo-stream.10 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (open-stream-p s)) (close s) (open-stream-p s) (notnot (open-stream-p is)) (notnot (open-stream-p os)))) t t nil t t) (deftest make-echo-stream.11 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (listen s)) (read-char s) (notnot (listen s)) (read-char s) (notnot (listen s)) (read-char s) (listen s))) t #\f t #\o t #\o nil) (deftest make-echo-stream.12 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (notnot (streamp s)) (notnot (typep s 'stream)) (notnot (typep s 'echo-stream)) (notnot (input-stream-p s)) (notnot (output-stream-p s)) (notnot (stream-element-type s)))) t t t t t t) ;;; FIXME ;;; Add tests for clear-input, file-position(?) ;;; Also, add tests for output operations (since echo-streams are ;;; bidirectional) (deftest make-echo-stream.13 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\0 s) (close s) (get-output-stream-string os))) #\0 t "0") (deftest make-echo-stream.14 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (terpri s) (close s) (get-output-stream-string os))) nil t #.(string #\Newline)) (deftest make-echo-stream.15 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (mapcar #'char-code (coerce "abcdefg" 'list)))) (loop for b in x do (assert (equal (list b) (multiple-value-list (write-byte b s))))) (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values (read-byte is nil :done) (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.16 (let ((pn #p"tmp.dat") (pn2 #p"tmp2.dat") (element-type '(unsigned-byte 8))) (with-open-file (os pn :direction :output :element-type element-type :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede :element-type element-type) (let ((s (make-echo-stream is os)) (x (map 'vector #'char-code "abcdefg"))) (assert (equal (multiple-value-list (write-sequence x s)) (list x))) (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values (read-byte is nil :done) (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.17 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\X s) (notnot (fresh-line s)) (finish-output s) (force-output s) (close s) (get-output-stream-string os))) #\X t nil nil t #.(coerce '(#\X #\Newline) 'string)) (deftest make-echo-stream.18 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-string "159" s) (close s) (get-output-stream-string os))) "159" t "159") (deftest make-echo-stream.20 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-string "0159X" s :start 1 :end 4) (close s) (get-output-stream-string os))) "0159X" t "159") (deftest make-echo-stream.21 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-line "159" s) (close s) (get-output-stream-string os))) "159" t #.(concatenate 'string "159" (string #\Newline))) (deftest make-echo-stream.22 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (values (write-char #\0 s) (clear-output s))) #\0 nil) ;;; Error tests (deftest make-echo-stream.error.1 (signals-error (make-echo-stream) program-error) t) (deftest make-echo-stream.error.2 (signals-error (make-echo-stream *standard-input*) program-error) t) (deftest make-echo-stream.error.3 (signals-error (make-echo-stream *standard-input* *standard-output* nil) program-error) t) gcl-2.6.14/ansi-tests/packages-10.lsp0000644000175000017500000000572414360276512015611 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:03:36 1998 ;;;; Contains: Package test code, part 10 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with-package-iterator (deftest with-package-iterator.1 (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.2 (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.3 (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.4 (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) t) ;;; Should test on some packages containing shadowed symbols, ;;; multiple inheritance (deftest with-package-iterator.5 (with-package-iterator-all '("A")) t) (deftest with-package-iterator.6 (with-package-iterator-all '(#:|A|)) t) (deftest with-package-iterator.7 (with-package-iterator-all '(#\A)) t) (deftest with-package-iterator.8 (with-package-iterator-internal (list (find-package "A"))) t) (deftest with-package-iterator.9 (with-package-iterator-external (list (find-package "A"))) t) (deftest with-package-iterator.10 (with-package-iterator-inherited (list (find-package "A"))) t) ;;; Check that if no access symbols are provided, a program error is ;;; raised #| (deftest with-package-iterator.11 (handler-case (progn (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) nil) (program-error () t) (error (c) c)) t) |# ;;; Paul Werkowski" pointed out that ;;; that test is broken. Here's a version of the replacement ;;; he suggested. ;; ;;; I'm not sure if this is correct either; it depends on ;;; whether with-package-iterator should signal the error ;;; at macro expansion time or at run time. ;; ;;; PFD 01-18-03: I should rewrite this to use CLASSIFY-ERROR, which ;;; uses EVAL to avoid that problem. (deftest with-package-iterator.11 (handler-case (macroexpand-1 '(with-package-iterator (x "COMMON-LISP-USER"))) (program-error () t) (error (c) c)) t) ;;; Apply to all packages (deftest with-package-iterator.12 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-internal (list p)))) (error (c) (format "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.13 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-external (list p)))) (error (c) (format "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.14 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-inherited (list p)))) (error (c) (format t "Error ~S on package ~S~%" c p) t))) 0) gcl-2.6.14/ansi-tests/pathname-name.lsp0000644000175000017500000000352014360276512016320 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:45:16 2003 ;;;; Contains: Tests for PATHNAME-NAME (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-name.1 (loop for p in *pathnames* for name = (pathname-name p) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.2 (loop for p in *pathnames* for name = (pathname-name p :case :local) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.3 (loop for p in *pathnames* for name = (pathname-name p :case :common) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.4 (loop for p in *pathnames* for name = (pathname-name p :allow-other-keys nil) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.5 (loop for p in *pathnames* for name = (pathname-name p :foo 'bar :allow-other-keys t) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) (deftest pathname-name.6 (loop for p in *pathnames* for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar) unless (or (stringp name) (member name '(nil :wild :unspecific))) collect (list p name)) nil) ;;; section 19.3.2.1 (deftest pathname-name.7 (loop for p in *logical-pathnames* when (eq (pathname-name p) :unspecific) collect p) nil) (deftest pathname-name.8 (do-special-strings (s "" nil) (pathname-name s)) nil) (deftest pathname-name.error.1 (signals-error (pathname-name) program-error) t) (deftest pathname-name.error.2 (check-type-error #'pathname-name #'could-be-pathname-designator) nil) gcl-2.6.14/ansi-tests/streamp.lsp0000644000175000017500000000167714360276512015273 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 17:12:38 2004 ;;;; Contains: Tests for STREAMP (in-package :cl-test) (deftest streamp.1 (loop for s in (list *debug-io* *error-output* *query-io* *standard-input* *standard-output* *trace-output* *terminal-io*) unless (equal (multiple-value-list (notnot-mv (streamp s))) '(t)) collect s) nil) (deftest streamp.2 (check-type-predicate #'streamp 'stream) 0) (deftest streamp.3 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s) (notnot-mv (streamp s))) t) (deftest streamp.4 (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (unwind-protect (notnot-mv (streamp s)) (close s))) t) ;;; Error tests (deftest streamp.error.1 (signals-error (streamp) program-error) t) (deftest streamp.error.2 (signals-error (streamp *standard-input* nil) program-error) t) gcl-2.6.14/ansi-tests/pathname-host.lsp0000644000175000017500000000355114360276512016361 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Dec 6 14:23:22 2003 ;;;; Contains: Tests for PATHNAME-HOST (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") (deftest pathname-host.1 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p))) 1)) t) (deftest pathname-host.2 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :case :local))) 1)) t) (deftest pathname-host.3 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :case :common))) 1)) t) (deftest pathname-host.4 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1)) t) (deftest pathname-host.5 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :foo t :allow-other-keys t))) 1)) t) (deftest pathname-host.6 (loop for p in *pathnames* always (eql (length (multiple-value-list (pathname-host p :allow-other-keys t :allow-other-keys nil 'foo t))) 1)) t) ;;; section 19.3.2.1 (deftest pathname-host.7 (loop for p in *logical-pathnames* when (eq (pathname-host p) :unspecific) collect p) nil) (deftest pathname-host.8 (do-special-strings (s "" nil) (pathname-host s)) nil) #| (deftest pathname-host.9 (loop for p in *pathnames* for host = (pathname-host p) unless (or (stringp host) (and (listp host) (every #'stringp host)) (eql host :unspecific)) collect (list p host)) nil) |# ;;; Error cases (deftest pathname-host.error.1 (signals-error (pathname-host) program-error) t) (deftest pathname-host.error.2 (check-type-error #'pathname-host #'could-be-pathname-designator) nil) (deftest pathname-host.error.3 (signals-error (pathname-host *default-pathname-defaults* '#:bogus t) program-error) t) gcl-2.6.14/ansi-tests/concatenated-stream-streams.lsp0000644000175000017500000000313214360276512021201 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 14 08:43:45 2004 ;;;; Contains: Tests of CONCATENATED-STREAM-STREAMS (in-package :cl-test) (deftest concatenated-stream-streams.1 (concatenated-stream-streams (make-concatenated-stream)) nil) (deftest concatenated-stream-streams.2 (equalt (list (list *standard-input*)) (multiple-value-list (concatenated-stream-streams (make-concatenated-stream *standard-input*)))) t) (deftest concatenated-stream-streams.3 (with-input-from-string (s1 "abc") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) (multiple-value-list (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.4 (with-input-from-string (s1 "") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) (multiple-value-list (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.5 (with-input-from-string (s1 "") (with-input-from-string (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (values (read-char s) (equalt (list (list s2)) (multiple-value-list (concatenated-stream-streams s))))))) #\d t) ;;; Error cases (deftest concatenated-stream-streams.error.1 (signals-error (concatenated-stream-streams) program-error) t) (deftest concatenated-stream-streams.error.2 (signals-error (concatenated-stream-streams (make-concatenated-stream) nil) program-error) t) gcl-2.6.14/ansi-tests/cons-test-17.lsp0000644000175000017500000003202214360276512015750 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 09:45:22 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 17 (in-package :cl-test) (declaim (optimize (safety 3))) (defun rev-assoc-list (x) (cond ((null x) nil) ((null (car x)) (cons nil (rev-assoc-list (cdr x)))) (t (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc (deftest rassoc.1 (rassoc nil nil) nil) (deftest rassoc.2 (rassoc nil '(nil)) nil) (deftest rassoc.3 (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) (2 . nil)) (deftest rassoc.4 (rassoc nil '((a . b) (c . d))) nil) (deftest rassoc.5 (rassoc 'a '((b . a))) (b . a)) (deftest rassoc.6 (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) (d . a)) (deftest rassoc.7 (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) (xcopy (make-scaffold-copy x)) (result (rassoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) t) (deftest rassoc.8 (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) (b . 1)) (deftest rassoc.9 (rassoc (copy-seq "abc") (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) nil) (deftest rassoc.10 (rassoc (copy-list '(a)) (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) nil) (deftest rassoc.11 (let ((x (list 'a 'b))) (rassoc x (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) (d a b)) (deftest rassoc.12 (rassoc #\e (copy-tree (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) :key #'(lambda (x) (char x 1))) (2 . "aevgd")) (deftest rassoc.13 (rassoc nil (copy-tree (rev-assoc-list '(((a) . b) ( nil . c ) ((nil) . d)))) :key #'car) (c)) (deftest rassoc.14 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) :test #'equal) (2 . "abc")) (deftest rassoc.15 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) :test #'equalp) (2 . "abc")) (deftest rassoc.16 (rassoc (copy-list '(a)) (copy-tree (rev-assoc-list '(((a) b) ((a) (c))))) :test #'equal) ((b) a)) (deftest rassoc.17 (rassoc (copy-seq "abc") (copy-tree (rev-assoc-list '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) :test-not (complement #'equalp)) (2 . "abc")) (deftest rassoc.18 (rassoc 'a (copy-tree (rev-assoc-list '((a . d)(b . c)))) :test-not #'eq) (c . b)) (deftest rassoc.19 (rassoc 'a (copy-tree (rev-assoc-list '((a . d)(b . c)))) :test (complement #'eq)) (c . b)) (deftest rassoc.20 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test #'equal) (6 . "A")) (deftest rassoc.21 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) x)) :test #'equal) (3 . "a")) (deftest rassoc.22 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) (string-downcase x))) :test-not (complement #'equal)) (6 . "A")) (deftest rassoc.23 (rassoc "a" (copy-tree (rev-assoc-list '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) :key #'(lambda (x) (and (stringp x) x)) :test-not (complement #'equal)) (3 . "a")) ;; Check that it works when test returns a true value ;; other than T (deftest rassoc.24 (rassoc 'a (copy-tree (rev-assoc-list '((b . 1) (a . 2) (c . 3)))) :test #'(lambda (x y) (and (eqt x y) 'matched))) (2 . a)) ;; Check that the order of the arguments to :test is correct (deftest rassoc.25 (block fail (rassoc 'a '((1 . b) (2 . c) (3 . a)) :test #'(lambda (x y) (unless (eqt x 'a) (return-from fail 'fail)) (eqt x y)))) (3 . a)) ;;; Order of argument evaluation (deftest rassoc.order.1 (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) i x y)) (3 . c) 2 1 2) (deftest rassoc.order.2 (let ((i 0) x y z) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :test (progn (setf z (incf i)) #'eql)) i x y z)) (3 . c) 3 1 2 3) (deftest rassoc.order.3 (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :test #'eql) i x y)) (3 . c) 2 1 2) (deftest rassoc.order.4 (let ((i 0) x y z w) (values (rassoc (progn (setf x (incf i)) 'c) (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (3 . c) 4 1 2 3 4) ;;; Keyword tests (deftest rassoc.allow-other-keys.1 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) (2 . b)) (deftest rassoc.allow-other-keys.2 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) (2 . b)) (deftest rassoc.allow-other-keys.3 (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t :test-not #'eql) (2 . b)) (deftest rassoc.allow-other-keys.4 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) (2 . b)) (deftest rassoc.allow-other-keys.5 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) (2 . b)) (deftest rassoc.keywords.6 (rassoc 'b '((1 . a) (2 . b) (3 . c)) :test #'eql :test (complement #'eql)) (2 . b)) ;;; Error tests (deftest rassoc.error.1 (classify-error (rassoc)) program-error) (deftest rassoc.error.2 (classify-error (rassoc nil)) program-error) (deftest rassoc.error.3 (classify-error (rassoc nil nil :bad t)) program-error) (deftest rassoc.error.4 (classify-error (rassoc nil nil :key)) program-error) (deftest rassoc.error.5 (classify-error (rassoc nil nil 1 1)) program-error) (deftest rassoc.error.6 (classify-error (rassoc nil nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc.error.7 (classify-error (rassoc 'a '((b . a)(c . d)) :test #'identity)) program-error) (deftest rassoc.error.8 (classify-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity)) program-error) (deftest rassoc.error.9 (classify-error (rassoc 'a '((b . a)(c . d)) :key #'cons)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc-if (deftest rassoc-if.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (c . 6)) (deftest rassoc-if.4 (rassoc-if #'null (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation (deftest rassoc-if.order.1 (let ((i 0) x y) (values (rassoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) (deftest rassoc-if.order.2 (let ((i 0) x y z) (values (rassoc-if (progn (setf x (incf i)) #'null) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d))) :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) ;;; Keyword tests (deftest rassoc-if.allow-other-keys.1 (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) (2)) (deftest rassoc-if.allow-other-keys.2 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) (2)) (deftest rassoc-if.allow-other-keys.3 (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t :key 'not) (2)) (deftest rassoc-if.allow-other-keys.4 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) (2)) (deftest rassoc-if.allow-other-keys.5 (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) (2)) (deftest rassoc-if.keywords.6 (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) (2)) ;;; Error tests (deftest rassoc-if.error.1 (classify-error (rassoc-if)) program-error) (deftest rassoc-if.error.2 (classify-error (rassoc-if #'null)) program-error) (deftest rassoc-if.error.3 (classify-error (rassoc-if #'null nil :bad t)) program-error) (deftest rassoc-if.error.4 (classify-error (rassoc-if #'null nil :key)) program-error) (deftest rassoc-if.error.5 (classify-error (rassoc-if #'null nil 1 1)) program-error) (deftest rassoc-if.error.6 (classify-error (rassoc-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc-if.error.7 (classify-error (rassoc-if #'cons '((a . b)(c . d)))) program-error) (deftest rassoc-if.error.8 (classify-error (rassoc-if #'car '((a . b)(c . d)))) type-error) (deftest rassoc-if.error.9 (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons)) program-error) (deftest rassoc-if.error.10 (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car)) type-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rassoc-if-not (deftest rassoc-if-not.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if-not.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) result)) (c . 6)) (deftest rassoc-if-not.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) result)) (c . 6)) (deftest rassoc-if-not.4 (rassoc-if-not #'identity (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation (deftest rassoc-if-not.order.1 (let ((i 0) x y) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) (deftest rassoc-if-not.order.2 (let ((i 0) x y z) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '((1 . a) (2 . b) (17) (4 . d))) :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) ;;; Keyword tests (deftest rassoc-if-not.allow-other-keys.1 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) (2)) (deftest rassoc-if-not.allow-other-keys.2 (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) (2)) (deftest rassoc-if-not.allow-other-keys.3 (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t :key 'not) (2)) (deftest rassoc-if-not.allow-other-keys.4 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) (2)) (deftest rassoc-if-not.allow-other-keys.5 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) (2)) (deftest rassoc-if-not.allow-other-keys.6 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :allow-other-keys nil :bad t) (2)) (deftest rassoc-if-not.keywords.7 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) (1 . a)) ;;; Error tests (deftest rassoc-if-not.error.1 (classify-error (rassoc-if-not)) program-error) (deftest rassoc-if-not.error.2 (classify-error (rassoc-if-not #'null)) program-error) (deftest rassoc-if-not.error.3 (classify-error (rassoc-if-not #'null nil :bad t)) program-error) (deftest rassoc-if-not.error.4 (classify-error (rassoc-if-not #'null nil :key)) program-error) (deftest rassoc-if-not.error.5 (classify-error (rassoc-if-not #'null nil 1 1)) program-error) (deftest rassoc-if-not.error.6 (classify-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil)) program-error) (deftest rassoc-if-not.error.7 (classify-error (rassoc-if-not #'cons '((a . b)(c . d)))) program-error) (deftest rassoc-if-not.error.8 (classify-error (rassoc-if-not #'car '((a . b)(c . d)))) type-error) (deftest rassoc-if-not.error.9 (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons)) program-error) (deftest rassoc-if-not.error.10 (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car)) type-error) gcl-2.6.14/ansi-tests/cerror.lsp0000644000175000017500000000240414360276512015101 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 19:45:27 2003 ;;;; Contains: Tests of CERROR (in-package :cl-test) (deftest cerror.1 (let ((fmt "Cerror")) (handler-case (cerror "Keep going." fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.2 (let* ((fmt "Cerror") (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (cerror "Continue on." cnd) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.3 (let ((fmt "Cerror")) (handler-case (cerror "Continue" 'simple-error :format-control fmt) (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.4 (let ((fmt "Cerror: ~A")) (handler-case (cerror "On on" fmt 10) (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest cerror.5 (let ((fmt (formatter "Cerror"))) (handler-case (cerror "Keep going." fmt) (simple-error (c) (frob-simple-error c fmt)))) t) ;;; Continuing from a cerror (deftest cerror.6 (handler-bind ((simple-error #'(lambda (c) (continue c)))) (progn (cerror "Wooo" 'simple-error) 10)) 10) (deftest cerror.error.1 (classify-error (cerror)) program-error) (deftest cerror.error.2 (classify-error (cerror "foo")) program-error) gcl-2.6.14/ansi-tests/clear-output.lsp0000644000175000017500000000240114360276512016226 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:43:17 2004 ;;;; Contains: Tests of CLEAR-OUTPUT (in-package :cl-test) (deftest clear-output.1 (progn (finish-output) (clear-output)) nil) (deftest clear-output.2 (progn (finish-output) (clear-output t)) nil) (deftest clear-output.3 (progn (finish-output) (clear-output nil)) nil) (deftest clear-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for dummy = (finish-output s) for results = (multiple-value-list (clear-output s)) unless (equal results '(nil)) collect s) nil) (deftest clear-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (clear-output t))) nil) (deftest clear-output.6 (let ((*standard-output* (make-string-output-stream))) (clear-output nil)) nil) ;;; Error tests (deftest clear-output.error.1 (signals-error (clear-output nil nil) program-error) t) (deftest clear-output.error.2 (signals-error (clear-output t nil) program-error) t) (deftest clear-output.error.3 (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl-2.6.14/ansi-tests/loop13.lsp0000644000175000017500000002125314360276512014725 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Nov 17 12:37:45 2002 ;;;; Contains: Tests of DO, DOING, RETURN in LOOP. Tests of NAMED loops (in-package :cl-test) (deftest loop.13.1 (loop do (return 10)) 10) (deftest loop.13.2 (loop doing (return 10)) 10) (deftest loop.13.3 (loop for i from 0 below 100 by 7 when (> i 50) return i) 56) (deftest loop.13.4 (let ((x 0)) (loop do (incf x) (when (= x 10) (return x)))) 10) (deftest loop.13.5 (loop return 'a) a) (deftest loop.13.6 (loop return (values))) (deftest loop.13.7 (loop return (values 1 2)) 1 2) (deftest loop.13.8 (let* ((limit (min 1000 (1- multiple-values-limit))) (vals (make-list limit :initial-element :a)) (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) (equalt vals vals2)) t) (deftest loop.13.9 (loop named foo return 'a) a) (deftest loop.13.10 (block nil (return (loop named foo return :good)) :bad) :good) (deftest loop.13.11 (block nil (loop named foo do (return :good)) :bad) :good) (deftest loop.13.12 (loop named foo with a = (return-from foo :good) return :bad) :good) (deftest loop.13.13 (loop named foo with b = 1 and a = (return-from foo :good) return :bad) :good) (deftest loop.13.14 (loop named foo for a = (return-from foo :good) return :bad) :good) (deftest loop.13.15 (loop named foo for a in (return-from foo :good)) :good) (deftest loop.13.16 (loop named foo for a from (return-from foo :good) return :bad) :good) (deftest loop.13.17 (loop named foo for a on (return-from foo :good) return :bad) :good) (deftest loop.13.18 (loop named foo for a across (return-from foo :good) return :bad) :good) (deftest loop.13.19 (loop named foo for a being the hash-keys of (return-from foo :good) return :bad) :good) (deftest loop.13.20 (loop named foo for a being the symbols of (return-from foo :good) return :bad) :good) (deftest loop.13.21 (loop named foo repeat (return-from foo :good) return :bad) :good) (deftest loop.13.22 (loop named foo for i from 0 to (return-from foo :good) return :bad) :good) (deftest loop.13.23 (loop named foo for i from 0 to 10 by (return-from foo :good) return :bad) :good) (deftest loop.13.24 (loop named foo for i from 10 downto (return-from foo :good) return :bad) :good) (deftest loop.13.25 (loop named foo for i from 10 above (return-from foo :good) return :bad) :good) (deftest loop.13.26 (loop named foo for i from 10 below (return-from foo :good) return :bad) :good) (deftest loop.13.27 (loop named foo for i in '(a b c) by (return-from foo :good) return :bad) :good) (deftest loop.13.28 (loop named foo for i on '(a b c) by (return-from foo :good) return :bad) :good) (deftest loop.13.29 (loop named foo for i = 1 then (return-from foo :good)) :good) (deftest loop.13.30 (loop named foo for x in '(a b c) collect (return-from foo :good)) :good) (deftest loop.13.31 (loop named foo for x in '(a b c) append (return-from foo :good)) :good) (deftest loop.13.32 (loop named foo for x in '(a b c) nconc (return-from foo :good)) :good) (deftest loop.13.33 (loop named foo for x in '(a b c) count (return-from foo :good)) :good) (deftest loop.13.34 (loop named foo for x in '(a b c) sum (return-from foo :good)) :good) (deftest loop.13.35 (loop named foo for x in '(a b c) maximize (return-from foo :good)) :good) (deftest loop.13.36 (loop named foo for x in '(a b c) minimize (return-from foo :good)) :good) (deftest loop.13.37 (loop named foo for x in '(a b c) thereis (return-from foo :good)) :good) (deftest loop.13.38 (loop named foo for x in '(a b c) always (return-from foo :good)) :good) (deftest loop.13.39 (loop named foo for x in '(a b c) never (return-from foo :good)) :good) (deftest loop.13.40 (loop named foo for x in '(a b c) until (return-from foo :good)) :good) (deftest loop.13.41 (loop named foo for x in '(a b c) while (return-from foo :good)) :good) (deftest loop.13.42 (loop named foo for x in '(a b c) when (return-from foo :good) return :bad) :good) (deftest loop.13.43 (loop named foo for x in '(a b c) unless (return-from foo :good) return :bad) :good) (deftest loop.13.44 (loop named foo for x in '(a b c) if (return-from foo :good) return :bad) :good) (deftest loop.13.45 (loop named foo for x in '(a b c) return (return-from foo :good)) :good) (deftest loop.13.46 (loop named foo initially (return-from foo :good) return :bad) :good) (deftest loop.13.47 (loop named foo do (loop-finish) finally (return-from foo :good)) :good) (deftest loop.13.52 (block nil (loop named foo with a = (return :good) return :bad) :bad) :good) (deftest loop.13.53 (block nil (loop named foo with b = 1 and a = (return :good) return :bad) :bad) :good) (deftest loop.13.54 (block nil (loop named foo for a = (return :good) return :bad) :bad) :good) (deftest loop.13.55 (block nil (loop named foo for a in (return :good)) :bad) :good) (deftest loop.13.56 (block nil (loop named foo for a from (return :good) return :bad) :bad) :good) (deftest loop.13.57 (block nil (loop named foo for a on (return :good) return :bad) :bad) :good) (deftest loop.13.58 (block nil (loop named foo for a across (return :good) return :bad) :bad) :good) (deftest loop.13.59 (block nil (loop named foo for a being the hash-keys of (return :good) return :bad) :bad) :good) (deftest loop.13.60 (block nil (loop named foo for a being the symbols of (return :good) return :bad) :bad) :good) (deftest loop.13.61 (block nil (loop named foo repeat (return :good) return :bad) :bad) :good) (deftest loop.13.62 (block nil (loop named foo for i from 0 to (return :good) return :bad) :bad) :good) (deftest loop.13.63 (block nil (loop named foo for i from 0 to 10 by (return :good) return :bad) :bad) :good) (deftest loop.13.64 (block nil (loop named foo for i from 10 downto (return :good) return :bad) :bad) :good) (deftest loop.13.65 (block nil (loop named foo for i from 10 above (return :good) return :bad) :bad) :good) (deftest loop.13.66 (block nil (loop named foo for i from 10 below (return :good) return :bad) :bad) :good) (deftest loop.13.67 (block nil (loop named foo for i in '(a b c) by (return :good) return :bad) :bad) :good) (deftest loop.13.68 (block nil (loop named foo for i on '(a b c) by (return :good) return :bad) :bad) :good) (deftest loop.13.69 (block nil (loop named foo for i = 1 then (return :good)) :bad) :good) (deftest loop.13.70 (block nil (loop named foo for x in '(a b c) collect (return :good)) :bad) :good) (deftest loop.13.71 (block nil (loop named foo for x in '(a b c) append (return :good)) :bad) :good) (deftest loop.13.72 (block nil (loop named foo for x in '(a b c) nconc (return :good)) :bad) :good) (deftest loop.13.73 (block nil (loop named foo for x in '(a b c) count (return :good)) :bad) :good) (deftest loop.13.74 (block nil (loop named foo for x in '(a b c) sum (return :good)) :bad) :good) (deftest loop.13.75 (block nil (loop named foo for x in '(a b c) maximize (return :good)) :bad) :good) (deftest loop.13.76 (block nil (loop named foo for x in '(a b c) minimize (return :good)) :bad) :good) (deftest loop.13.77 (block nil (loop named foo for x in '(a b c) thereis (return :good)) :bad) :good) (deftest loop.13.78 (block nil (loop named foo for x in '(a b c) always (return :good)) :bad) :good) (deftest loop.13.79 (block nil (loop named foo for x in '(a b c) never (return :good)) :bad) :good) (deftest loop.13.80 (block nil (loop named foo for x in '(a b c) until (return :good)) :bad) :good) (deftest loop.13.81 (block nil (loop named foo for x in '(a b c) while (return :good)) :bad) :good) (deftest loop.13.82 (block nil (loop named foo for x in '(a b c) when (return :good) return :bad) :bad) :good) (deftest loop.13.83 (block nil (loop named foo for x in '(a b c) unless (return :good) return :bad) :bad) :good) (deftest loop.13.84 (block nil (loop named foo for x in '(a b c) if (return :good) return :bad) :bad) :good) (deftest loop.13.85 (block nil (loop named foo for x in '(a b c) return (return :good)) :bad) :good) (deftest loop.13.86 (block nil (loop named foo initially (return :good) return :bad) :bad) :good) (deftest loop.13.87 (block nil (loop named foo do (loop-finish) finally (return :good)) :bad) :good) gcl-2.6.14/ansi-tests/array-dimensions.lsp0000644000175000017500000000273614360276512017101 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 06:59:37 2003 ;;;; Contains: Tests of ARRAY-DIMENSIONS (in-package :cl-test) ;;; The tests in make-array.lsp also test this function (deftest array-dimensions.1 (array-dimensions #0aX) nil) (deftest array-dimensions.2 (array-dimensions #(a b c d)) (4)) (deftest array-dimensions.3 (array-dimensions #*0011011011) (10)) (deftest array-dimensions.4 (array-dimensions "abcdef") (6)) (deftest array-dimensions.5 (array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12))) (4 3)) (deftest array-dimensions.6 (let ((a (make-array '(2 3 4) :adjustable t))) (values (array-dimension a 0) (array-dimension a 1) (array-dimension a 2))) 2 3 4) (deftest array-dimensions.7 (let ((a (make-array '(10) :fill-pointer 5))) (array-dimension a 0)) 10) ;;; Error tests (deftest array-dimensions.error.1 (classify-error (array-dimensions)) program-error) (deftest array-dimensions.error.2 (classify-error (array-dimensions #(a b c) nil)) program-error) (deftest array-dimensions.error.3 (let (why) (loop for e in *mini-universe* unless (or (typep e 'array) (eq 'type-error (setq why (classify-error** `(array-dimensions ',e))))) collect (list e why))) nil) (deftest array-dimensions.error.4 (classify-error (array-dimensions nil)) type-error) (deftest array-dimensions.error.5 (classify-error (locally (array-dimensions nil))) type-error) gcl-2.6.14/ansi-tests/hash-table.lsp0000644000175000017500000000271514360276512015622 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 21:30:42 2003 ;;;; Contains: Tests of HASH-TABLE and related interface (in-package :cl-test) (deftest hash-table.1 (notnot-mv (find-class 'hash-table)) t) (deftest hash-table.2 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (typep e 'hash-table) collect e) nil) (deftest hash-table.3 (let ((c (find-class 'hash-table))) (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (typep e c) collect e)) nil) (deftest hash-table.4 (notnot-mv (typep (make-hash-table) 'hash-table)) t) (deftest hash-table.5 (notnot-mv (typep (make-hash-table) (find-class 'hash-table))) t) ;;; (deftest hash-table-p.1 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 #0aNIL #2a((a b)(c d)) #p"foo" "bar" #\a 3/5 #c(1.0 2.0)) when (hash-table-p e) collect e) nil) (deftest hash-table-p.2 (loop for e in *universe* for p = (typep e 'hash-table) for q = (hash-table-p e) always (if p q (not q))) t) (deftest hash-table-p.3 (let ((i 0)) (values (hash-table-p (incf i)) i)) nil 1) (deftest hash-table-p.error.1 (classify-error (hash-table-p)) program-error) (deftest hash-table-p.error.2 (classify-error (let ((h (make-hash-table))) (hash-table-p h nil))) program-error) gcl-2.6.14/ansi-tests/map-into.lsp0000644000175000017500000002225614360276512015340 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 18 10:10:04 2002 ;;;; Contains: Tests for the MAP-INTO function (in-package :cl-test) (deftest map-into-list.1 (let ((a (copy-seq '(a b c d e f))) (b nil)) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) (1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-list.2 (let ((a (copy-seq '(a b c d e f g)))) (map-into a #'identity '(1 2 3)) a) (1 2 3 d e f g)) (deftest map-into-list.3 (let ((a (copy-seq '(a b c)))) (map-into a #'identity '(1 2 3 4 5 6)) a) (1 2 3)) (deftest map-into-list.4 (let ((a (copy-seq '(a b c d e f))) (b nil)) (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) '(1 2 3 4 5 6) '(10 11 12 13 14 15)) (values a b)) (11 13 15 17 19 21) (21 19 17 15 13 11)) (deftest map-into-list.5 (let ((a (copy-seq '(a b c d e f)))) (map-into a 'identity '(1 2 3 4 5 6)) a) (1 2 3 4 5 6)) (deftest map-into-list.6 (let ((b nil)) (values (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) '(1 2 3 4 5 6) '(10 11 12 13 14 15)) b)) nil nil) (deftest map-into-list.7 (let ((a (copy-seq '(a b c d e f)))) (map-into a #'(lambda () 1)) a) (1 1 1 1 1 1)) (deftest map-into-list.8 (let ((a (copy-seq '(a b c d e f))) (s2 (make-array '(6) :initial-element 'x :fill-pointer 4))) (map-into a #'identity s2) a) (x x x x e f)) (deftest map-into-array.1 (let ((a (copy-seq #(a b c d e f))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-array.2 (let ((a (copy-seq #(a b c d e f g h))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) (6 5 4 3 2 1)) (deftest map-into-array.3 (let ((a (copy-seq #(a b c d))) b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) (4 3 2 1)) (deftest map-into-array.4 (let ((a (copy-seq #(a b c d e f))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) (6 5 4 3 2 1)) (deftest map-into-array.5 (let ((a (copy-seq #(a b c d e f g h))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) (6 5 4 3 2 1)) (deftest map-into-array.6 (let ((a (copy-seq #(a b c d))) b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) (4 3 2 1)) ;;; Tests of mapping into arrays with fill pointers (deftest map-into-array.7 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2 3)) a) #(1 2 3)) (deftest map-into-array.8 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2)) a) #(1 2)) (deftest map-into-array.9 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'identity '(1 2 3 4 5)) (and (eqlt (fill-pointer a) 5) a)) #(1 2 3 4 5)) (deftest map-into-array.10 (let ((a (make-array 6 :initial-element 'x :fill-pointer 3))) (map-into a #'(lambda () 'y)) (and (eqlt (fill-pointer a) 6) a)) #(y y y y y y)) (deftest map-into-array.11 (let ((a (copy-seq #(a b c d e f))) (s2 (make-array '(6) :initial-element 'x :fill-pointer 4))) (map-into a #'identity s2) a) #(x x x x e f)) ;;; mapping into strings (deftest map-into-string.1 (let ((a (copy-seq "abcdef"))) (map-into a #'identity "123456") (values (not (not (stringp a))) a)) t "123456") (deftest map-into-string.2 (let ((a (copy-seq "abcdef"))) (map-into a #'identity "1234") (values (not (not (stringp a))) a)) t "1234ef") (deftest map-into-string.3 (let ((a (copy-seq "abcd"))) (map-into a #'identity "123456") (values (not (not (stringp a))) a)) t "1234") (deftest map-into-string.4 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) (aref a 5) a)) 5 #\x "abcde") (deftest map-into-string.5 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) a)) 6 "yyyyyy") (deftest map-into-string.6 (let ((a (make-array 6 :initial-element #\x :element-type 'character))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.7 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) (aref a 5) a)) 5 #\x "abcde") (deftest map-into-string.8 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) a)) 6 "yyyyyy") (deftest map-into-string.9 (let ((a (make-array 6 :initial-element #\x :element-type 'base-char))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.10 (let ((a (copy-seq "abcdef")) (s2 (make-array '(6) :initial-element #\x :fill-pointer 4))) (map-into a #'identity s2) a) "xxxxef") (deftest map-into-string.11 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcd") (values (fill-pointer a) (aref a 4) (aref a 5) a)) 4 #\x #\x "abcd") (deftest map-into-string.12 (let ((a (make-array 6 :initial-element #\x :element-type 'character :fill-pointer 3))) (map-into a #'identity "abcdefgh") (values (fill-pointer a) a)) 6 "abcdef") ;;; Tests on bit vectors (deftest map-into.bit-vector.1 (let ((v (copy-seq #*0100110))) (map-into v #'(lambda (x) (- 1 x)) v) (and (bit-vector-p v) v)) #*1011001) (deftest map-into.bit-vector.2 (let ((v (copy-seq #*0100110))) (map-into v #'(lambda () 0)) (and (bit-vector-p v) v)) #*0000000) (deftest map-into.bit-vector.3 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1)) (and (bit-vector-p v) v)) #*0111001) (deftest map-into.bit-vector.4 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1)) (and (bit-vector-p v) v)) #*0111110) (deftest map-into.bit-vector.5 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1 4 5 6 7)) (and (bit-vector-p v) v)) #*0111001) (deftest map-into.bit-vector.6 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'(lambda () 1)) (and (bit-vector-p v) v)) #*11111111) (deftest map-into.bit-vector.7 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity v) (and (bit-vector-p v) v)) #*0100) (deftest map-into.bit-vector.8 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1)) (and (bit-vector-p v) (values (fill-pointer v) v))) 6 #*111111) (deftest map-into.bit-vector.9 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) :fill-pointer 4 :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1 0 0 1 1 1)) (and (bit-vector-p v) (values (fill-pointer v) v))) 8 #*11111100) ;;; Error cases (deftest map-into.error.1 (classify-error (map-into 'a #'(lambda () nil))) type-error) ;;; The next test was changed because if the first argument ;;; is NIL, map-into is said to 'return nil immediately', so ;;; the 'should be prepared' notation for the error checking ;;; means that error checking may be skipped. (deftest map-into.error.2 (case (classify-error (map-into nil #'identity 'a)) ((nil type-error) 'good) (t 'bad)) good) (deftest map-into.error.3 (classify-error (map-into (copy-seq '(a b c)) #'cons '(d e f) 100)) type-error) (deftest map-into.error.4 (classify-error (map-into)) program-error) (deftest map-into.error.5 (classify-error (map-into (list 'a 'b 'c))) program-error) (deftest map-into.error.6 (classify-error (locally (map-into 'a #'(lambda () nil)) t)) type-error) (deftest map-into.error.7 (classify-error (map-into (list 'a 'b 'c) #'cons '(a b c))) program-error) (deftest map-into.error.8 (classify-error (map-into (list 'a 'b 'c) #'car '(a b c))) type-error) ;;; Order of evaluation tests (deftest map-into.order.1 (let ((i 0) a b c) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) '(a b c d))) i a b c)) (a b c d) 3 1 2 3) (deftest map-into.order.2 (let ((i 0) a b c d) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) (progn (setf b (incf i)) #'list) (progn (setf c (incf i)) '(a b c d)) (progn (setf d (incf i)) '(e f g h))) i a b c d)) ((a e) (b f) (c g) (d h)) 4 1 2 3 4) gcl-2.6.14/ansi-tests/eql.lsp0000644000175000017500000000260414360276512014370 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 19:36:33 2002 ;;;; Contains: Tests of EQL (in-package :cl-test) ;;; EQLT is defined in ansi-aux.lsp ;;; It calls EQL, returning NIL when the result is false and T when it ;;; is true. (deftest eql.1 (loop for x in *universe* always (check-values (eql x x))) t) (deftest eql.2 (eqlt 2 (1+ 1)) t) (deftest eql.3 (let ((x "abc")) (eql x (copy-seq x))) nil) (deftest eql.4 (eqlt #\a #\a) t) (deftest eql.5 (eqlt 12345678901234567890 12345678901234567890) t) (deftest eql.7 (eql 12.0 12) nil) (deftest eql.8 (eqlt #c(1 -2) #c(1 -2)) t) (deftest eql.9 (let ((x "abc") (y "abc")) (if (eq x y) (eqlt x y) (not (eql x y)))) t) (deftest eql.10 (eql (list 'a) (list 'b)) nil) (deftest eql.11 (eqlt #c(1 -2) (- #c(-1 2))) t) (deftest eql.order.1 (let ((i 0) x y) (values (eql (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest eql.error.1 (classify-error (eql)) program-error) (deftest eql.error.2 (classify-error (eql nil)) program-error) (deftest eql.error.3 (classify-error (eql nil nil nil)) program-error) ;;; Error tests for EQ (deftest eq.error.1 (classify-error (eq)) program-error) (deftest eq.error.2 (classify-error (eq nil)) program-error) (deftest eq.error.3 (classify-error (eq nil nil nil)) program-error) gcl-2.6.14/ansi-tests/bit-not.lsp0000644000175000017500000000633514360276512015170 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:40:13 2003 ;;;; Contains: Tests of BIT-NOT (in-package :cl-test) (deftest bit-not.1 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1) a1)) #0a1 #0a0) (deftest bit-not.2 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1) a1)) #0a0 #0a1) (deftest bit-not.3 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1 t) a1)) #0a1 #0a1) (deftest bit-not.4 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1 t) a1)) #0a0 #0a0) (deftest bit-not.5 (let* ((a1 (make-array nil :element-type 'bit :initial-element 1)) (a2 (make-array nil :element-type 'bit :initial-element 1)) (result (bit-not a1 a2))) (values a1 a2 (eqt a2 result))) #0a1 #0a0 t) (deftest bit-not.6 (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1 nil) a1)) #0a1 #0a0) ;;; Tests on bit vectors (deftest bit-not.7 (let ((a1 (copy-seq #*0011010110))) (values (bit-not a1) a1)) #*1100101001 #*0011010110) (deftest bit-not.8 (let ((a1 (copy-seq #*0011010110))) (values (bit-not a1 t) a1)) #*1100101001 #*1100101001) (deftest bit-not.9 (let ((a1 (copy-seq #*0011010110)) (a2 (copy-seq #*0000000000))) (values (bit-not a1 a2) a1 a2)) #*1100101001 #*0011010110 #*1100101001) ;;; Arrays (deftest bit-not.10 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.11 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1 nil) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.12 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0))))) (values (bit-not a1 t) a1)) #2a((1 0)(0 1)) #2a((1 0)(0 1))) (deftest bit-not.13 (let ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(1 0)))) (a2 (make-array '(2 2) :element-type 'bit :initial-element 0))) (values (bit-not a1 a2) a1 a2)) #2a((1 0)(0 1)) #2a((0 1)(1 0)) #2a((1 0)(0 1))) ;;; Adjustable array (deftest bit-not.14 (let ((a1 (make-array '(2 2) :element-type 'bit :adjustable t :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) ;;; Displaced arrays (deftest bit-not.15 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 2)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 6))) (values (bit-not a1 a2) a0 a1 a2)) #2a((1 0)(0 1)) #*000110100100 #2a((0 1)(1 0)) #2a((1 0)(0 1))) (deftest bit-not.order.1 (let ((a (copy-seq #*001101)) (i 0) x) (values (bit-not (progn (setf x (incf i)) a)) i x)) #*110010 1 1) ;;; Error tests (deftest bit-not.error.1 (classify-error (bit-not)) program-error) (deftest bit-not.error.2 (classify-error (bit-not #*000 nil nil)) program-error) gcl-2.6.14/ansi-tests/compile-file-test-file.lsp0000644000175000017500000000007714360276512020050 0ustar cammcamm(in-package "CL-TEST") (defun compile-file-test-fun.1 () nil) gcl-2.6.14/ansi-tests/load-sequences.lsp0000644000175000017500000000202514360276512016514 0ustar cammcamm;;; Tests of sequences (load "copy-seq.lsp") (load "elt.lsp") (load "fill.lsp") (load "fill-strings.lsp") (load "make-sequence.lsp") (load "map.lsp") (load "map-into.lsp") (load "reduce.lsp") (load "count.lsp") (load "count-if.lsp") (load "count-if-not.lsp") (load "reverse.lsp") (load "nreverse.lsp") (load "sort.lsp") (load "find.lsp") (load "find-if.lsp") (load "find-if-not.lsp") (load "position.lsp") (compile-and-load "search-aux.lsp") (load "search-list.lsp") (load "search-vector.lsp") (load "search-bitvector.lsp") (load "search-string.lsp") (load "mismatch.lsp") (load "replace.lsp") (compile-and-load "subseq-aux.lsp") (load "subseq.lsp") (load "substitute.lsp") (load "substitute-if.lsp") (load "substitute-if-not.lsp") (load "nsubstitute.lsp") (load "nsubstitute-if.lsp") (load "nsubstitute-if-not.lsp") (load "concatenate.lsp") (load "merge.lsp") (compile-and-load "remove-aux.lsp") (load "remove.lsp") ;; also related funs (compile-and-load "remove-duplicates-aux.lsp") (load "remove-duplicates.lsp") ;; also delete-duplicates gcl-2.6.14/ansi-tests/simple-bit-vector-p.lsp0000644000175000017500000000242314360276512017410 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 20:20:27 2003 ;;;; Contains: Tests of SIMPLE-BIT-VECTOR-P (in-package :cl-test) (deftest simple-bit-vector-p.2 (notnot-mv (simple-bit-vector-p #*)) t) (deftest simple-bit-vector-p.3 (notnot-mv (simple-bit-vector-p #*00101)) t) (deftest simple-bit-vector-p.4 (simple-bit-vector-p #(0 1 1 1 0 0)) nil) (deftest simple-bit-vector-p.5 (simple-bit-vector-p "011100") nil) (deftest simple-bit-vector-p.6 (simple-bit-vector-p 0) nil) (deftest simple-bit-vector-p.7 (simple-bit-vector-p 1) nil) (deftest simple-bit-vector-p.8 (simple-bit-vector-p nil) nil) (deftest simple-bit-vector-p.9 (simple-bit-vector-p 'x) nil) (deftest simple-bit-vector-p.10 (simple-bit-vector-p '(0 1 1 0)) nil) (deftest simple-bit-vector-p.11 (simple-bit-vector-p (make-array '(2 2) :element-type 'bit :initial-element 0)) nil) (deftest simple-bit-vector-p.12 (loop for e in *universe* for p1 = (typep e 'simple-bit-vector) for p2 = (simple-bit-vector-p e) always (if p1 p2 (not p2))) t) (deftest simple-bit-vector-p.error.1 (classify-error (simple-bit-vector-p)) program-error) (deftest simple-bit-vector-p.error.2 (classify-error (simple-bit-vector-p #* #*)) program-error) gcl-2.6.14/ansi-tests/condition.lsp0000644000175000017500000000521214360276512015573 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 27 22:13:25 2003 ;;;; Contains: Tests of class CONDITION (in-package :cl-test) (deftest condition.1 (notnot-mv (find-class 'condition nil)) t) (defparameter *allowed-condition-inclusions* '( (arithmetic-error error serious-condition condition) (cell-error error serious-condition condition) (condition) (control-error error serious-condition condition) (division-by-zero arithmetic-error error serious-condition condition) (end-of-file stream-error error serious-condition condition) (error serious-condition condition) (file-error error serious-condition condition) (floating-point-inexact arithmetic-error error serious-condition condition) (floating-point-invalid-operation arithmetic-error error serious-condition condition) (floating-point-overflow arithmetic-error error serious-condition condition) (floating-point-underflow arithmetic-error error serious-condition condition) (package-error error serious-condition condition) (parse-error error serious-condition condition) (print-not-readable error serious-condition condition) (program-error error serious-condition condition) (reader-error parse-error stream-error error serious-condition condition) (serious-condition condition) (simple-condition condition) (simple-error simple-condition error serious-condition condition) (simple-type-error simple-condition type-error error serious-condition condition) (simple-warning simple-condition warning condition) (storage-condition serious-condition condition) (stream-error error serious-condition condition) (style-warning warning condition) (type-error error serious-condition condition) (unbound-slot cell-error error serious-condition condition) (unbound-variable cell-error error serious-condition condition) (undefined-function cell-error error serious-condition condition) (warning condition) )) ;;; Relationships given in *allowed-condition-inclusions* are the only ;;; subtype relationships allowed on condition types (deftest condition.2 (loop for (cnd . supers) in *allowed-condition-inclusions* append (loop for super in supers unless (subtypep cnd super) collect (list cnd super))) nil) (deftest condition.3 ;; Relationships given in *allowed-condition-inclusions* are the only ;; subtype relationships allowed on condition types (loop for cnds in *allowed-condition-inclusions* for cnd = (first cnds) append (loop for super in (set-difference *condition-types* cnds) when (subtypep cnd super) collect (list cnd super))) nil) gcl-2.6.14/ansi-tests/bit-orc1.lsp0000644000175000017500000001434114360276512015230 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:25:28 2003 ;;;; Contains: Tests of BIT-ORC1 (in-package :cl-test) (deftest bit-orc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 #0a0) (deftest bit-orc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-orc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-orc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-orc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a1 #0a1 t) (deftest bit-orc1.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-orc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-orc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-orc1.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2)) a1 a2)) #*1101 #*0011 #*0101) (deftest bit-orc1.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-orc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1101 #*1101 #*0101 t) (deftest bit-orc1.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-orc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1101 #*0011 #*0101 #*1101 t) (deftest bit-orc1.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2 nil)) a1 a2)) #*1101 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-orc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2 t))) (values a1 a2 result)) #2a((1 0)(1 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-orc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-orc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1)) #2a((1 0)(1 1))) ;;; Adjustable arrays (deftest bit-orc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) ;;; Displaced arrays (deftest bit-orc1.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-orc1 a1 a2 t))) (values a0 a1 a2 result)) #*10110011 #2a((1 0)(1 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-orc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((1 0)(1 1))) (deftest bit-orc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-orc1 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) ;;; Error tests (deftest bit-orc1.error.1 (classify-error (bit-orc1)) program-error) (deftest bit-orc1.error.2 (classify-error (bit-orc1 #*000)) program-error) (deftest bit-orc1.error.3 (classify-error (bit-orc1 #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/packages-09.lsp0000644000175000017500000002154514360276512015620 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:02:43 1998 ;;;; Contains: Package test code, part 09 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; make-package ;; Test basic make-package, using string, symbol and character ;; package-designators (deftest make-package.1 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1")))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.2 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1|)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.3 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X)))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Same, but with a null :use list (deftest make-package.4 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use nil)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.5 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.6 (progn (safely-delete-package #\X) (let ((p (make-package #\X))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) ;; (equalt (package-use-list p) nil) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Same, but use the A package (deftest make-package.7 (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.7a (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.7b (progn (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8 (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8a (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.8b (progn (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9 (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9a (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.9b (progn (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) (prog1 (and (packagep p) (equalt (package-name p) "X") (equalt (package-nicknames p) nil) (equalt (package-use-list p) (list (find-package "A"))) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; make-package with nicknames (deftest make-package.10 (progn (safely-delete-package "TEST1") (let ((p (make-package "TEST1" :nicknames '("F")))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("F")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.11 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.12 (progn (safely-delete-package '#:|TEST1|) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) (prog1 (and (packagep p) (equalt (package-name p) "TEST1") (equalt (package-nicknames p) '("G")) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) (deftest make-package.13 (progn (safely-delete-package #\X) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) (prog1 (and (packagep p) (equalt (package-name p) "X") (null (set-exclusive-or (package-nicknames p) '("F" "G" "H") :test #'equal)) (equalt (package-used-by-list p) nil)) (safely-delete-package p)))) t) ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages (deftest make-package.error.1 (handle-non-abort-restart (make-package "A")) success) (deftest make-package.error.2 (handle-non-abort-restart (make-package "Q")) success) (deftest make-package.error.3 (handle-non-abort-restart (safely-delete-package "TEST1") (make-package "TEST1" :nicknames '("A"))) success) (deftest make-package.error.4 (handle-non-abort-restart (safely-delete-package "TEST1") (make-package "TEST1" :nicknames '("Q"))) success) (deftest make-package.error.5 (classify-error (make-package)) program-error) (deftest make-package.error.6 (progn (safely-delete-package "MPE6") (classify-error (make-package "MPE6" :bad t))) program-error) (deftest make-package.error.7 (progn (safely-delete-package "MPE7") (classify-error (make-package "MPE7" :nicknames))) program-error) (deftest make-package.error.8 (progn (safely-delete-package "MPE8") (classify-error (make-package "MPE8" :use))) program-error) (deftest make-package.error.9 (progn (safely-delete-package "MPE9") (classify-error (make-package "MPE9" 'bad t))) program-error) (deftest make-package.error.10 (progn (safely-delete-package "MPE10") (classify-error (make-package "MPE10" 1 2))) program-error) (deftest make-package.error.11 (progn (safely-delete-package "MPE11") (classify-error (make-package "MPE11" 'bad t :allow-other-keys nil))) program-error) gcl-2.6.14/ansi-tests/subtypep-integer.lsp0000644000175000017500000002402114360276512017112 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Feb 15 11:54:05 2003 ;;;; Contains: Tests for subtype relationships on integer types (in-package :cl-test) (deftest subtypep.fixnum-or-bignum (check-equivalence '(or fixnum bignum) 'integer) nil) (deftest subtypep.fixnum.integer (check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum) 'fixnum) nil) (deftest subtypep.bignum.integer (check-equivalence `(or (integer * (,most-negative-fixnum)) (integer (,most-positive-fixnum) *)) 'bignum) nil) ;;;;;;; (deftest subtypep.integer.1 (subtypep* '(integer 0 10) '(integer 0 20)) t t) (deftest subtypep.integer.2 (subtypep* '(integer 0 10) '(integer 0 (10))) nil t) (deftest subtypep.integer.3 (subtypep* '(integer 10 100) 'integer) t t) (deftest subtypep.integer.3a (subtypep* '(integer 10 100) '(integer)) t t) (deftest subtypep.integer.3b (subtypep* '(integer 10 100) '(integer *)) t t) (deftest subtypep.integer.3c (subtypep* '(integer 10 100) '(integer * *)) t t) (deftest subtypep.integer.4 (subtypep* 'integer '(integer 10 100)) nil t) (deftest subtypep.integer.4a (subtypep* '(integer) '(integer 10 100)) nil t) (deftest subtypep.integer.4b (subtypep* '(integer *) '(integer 10 100)) nil t) (deftest subtypep.integer.4c (subtypep* '(integer * *) '(integer 10 100)) nil t) (deftest subtypep.integer.5 (subtypep* '(integer 10 *) 'integer) t t) (deftest subtypep.integer.5a (subtypep* '(integer 10 *) '(integer)) t t) (deftest subtypep.integer.5b (subtypep* '(integer 10 *) '(integer *)) t t) (deftest subtypep.integer.5c (subtypep* '(integer 10 *) '(integer * *)) t t) (deftest subtypep.integer.6 (subtypep* 'integer '(integer 10 *)) nil t) (deftest subtypep.integer.6a (subtypep* '(integer) '(integer 10 *)) nil t) (deftest subtypep.integer.6b (subtypep* '(integer *) '(integer 10 *)) nil t) (deftest subtypep.integer.6c (subtypep* '(integer * *) '(integer 10 *)) nil t) (deftest subtypep.integer.7 (subtypep* '(integer 10) 'integer) t t) (deftest subtypep.integer.7a (subtypep* '(integer 10) '(integer)) t t) (deftest subtypep.integer.7b (subtypep* '(integer 10) '(integer *)) t t) (deftest subtypep.integer.7c (subtypep* '(integer 10) '(integer * *)) t t) (deftest subtypep.integer.8 (subtypep* 'integer '(integer 10)) nil t) (deftest subtypep.integer.8a (subtypep* '(integer) '(integer 10)) nil t) (deftest subtypep.integer.8b (subtypep* '(integer *) '(integer 10)) nil t) (deftest subtypep.integer.8c (subtypep* '(integer * *) '(integer 10)) nil t) (deftest subtypep.integer.9 (subtypep* '(integer * 10) 'integer) t t) (deftest subtypep.integer.9a (subtypep* '(integer * 10) '(integer)) t t) (deftest subtypep.integer.9b (subtypep* '(integer * 10) '(integer *)) t t) (deftest subtypep.integer.9c (subtypep* '(integer * 10) '(integer * *)) t t) (deftest subtypep.integer.10 (subtypep* 'integer '(integer * 10)) nil t) (deftest subtypep.integer.10a (subtypep* '(integer) '(integer * 10)) nil t) (deftest subtypep.integer.10b (subtypep* '(integer *) '(integer * 10)) nil t) (deftest subtypep.integer.10c (subtypep* '(integer * *) '(integer * 10)) nil t) (deftest subtypep.integer.11 (subtypep* '(integer 10) '(integer 5)) t t) (deftest subtypep.integer.12 (subtypep* '(integer 5) '(integer 10)) nil t) (deftest subtypep.integer.13 (subtypep* '(integer 10 *) '(integer 5)) t t) (deftest subtypep.integer.14 (subtypep* '(integer 5) '(integer 10 *)) nil t) (deftest subtypep.integer.15 (subtypep* '(integer 10) '(integer 5 *)) t t) (deftest subtypep.integer.16 (subtypep* '(integer 5 *) '(integer 10)) nil t) (deftest subtypep.integer.17 (subtypep* '(integer 10 *) '(integer 5 *)) t t) (deftest subtypep.integer.18 (subtypep* '(integer 5 *) '(integer 10 *)) nil t) (deftest subtypep.integer.19 (subtypep* '(integer * 5) '(integer * 10)) t t) (deftest subtypep.integer.20 (subtypep* '(integer * 10) '(integer * 5)) nil t) (deftest subtypep.integer.21 (subtypep* '(integer 10 *) '(integer * 10)) nil t) (deftest subtypep.integer.22 (subtypep* '(integer * 10) '(integer 10 *)) nil t) (deftest subtypep.integer.23 (check-equivalence '(integer (9)) '(integer 10)) nil) (deftest subtypep.integer.24 (check-equivalence '(integer * (11)) '(integer * 10)) nil) (deftest subtypep.integer.25 (check-equivalence '(and (or (integer 0 10) (integer 20 30)) (or (integer 5 15) (integer 25 35))) '(or (integer 5 10) (integer 25 30))) nil) (deftest subtypep.integer.26 (check-equivalence '(and (integer 0 10) (integer 5 15)) '(integer 5 10)) nil) (deftest subtypep.integer.27 (check-equivalence '(or (integer 0 10) (integer 5 15)) '(integer 0 15)) nil) (deftest subtypep.integer.28 (check-equivalence '(and integer (not (eql 10))) '(or (integer * 9) (integer 11 *))) nil) (deftest subtypep.integer.29 (check-equivalence '(and integer (not (integer 1 10))) '(or (integer * 0) (integer 11 *))) nil) (deftest subtypep.integer.30 (check-equivalence '(and (integer -100 100) (not (integer 1 10))) '(or (integer -100 0) (integer 11 100))) nil) ;;; Relations between integer and real types (deftest subtypep.integer.real.1 (check-equivalence '(and integer (real 4 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.2 (check-equivalence '(and (integer 4 *) (real * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.3 (check-equivalence '(and (integer * 10) (real 4)) '(integer 4 10)) nil) (deftest subtypep.integer.real.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) append (loop for real-type in '(real (real) (real *) (real * *)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.5 (loop for int-type in '((integer 10) (integer 10 *)) append (loop for real-type in '(real (real) (real *) (real * *) (real 10.0) (real 10.0 *) (real 10) (real 10 *)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.6 (loop for int-type in '((integer * 10) (integer * 5)) append (loop for real-type in '(real (real) (real *) (real * *) (real * 10.0) (real * 10) (real * 1000000000000)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.7 (loop for int-type in '((integer 0 10) (integer 2 5)) append (loop for real-type in '(real (real) (real *) (real * *) (real * 10) (real * 1000000000000) (real -10) (real -10.0) (real -10 *) (real -10.0 *) (real 0) (real 0.0) (real 0 10) (real * 10) (real 0 *) (real 0 10)) unless (equal (multiple-value-list (subtypep* int-type real-type)) '(t t)) collect (list int-type real-type))) nil) (deftest subtypep.integer.real.8 (check-equivalence '(and (integer 4) (real * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.real.9 (check-equivalence '(and (integer * 10) (real 4)) '(integer 4 10)) nil) (deftest subtypep.integer.real.10 (check-equivalence '(and (integer 4) (real * (10))) '(integer 4 9)) nil) (deftest subtypep.integer.real.11 (check-equivalence '(and (integer * 10) (real (4))) '(integer 5 10)) nil) ;;; Between integer and rational types (deftest subtypep.integer.rational.1 (check-equivalence '(and integer (rational 4 10)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.2 (check-equivalence '(and (integer 4 *) (rational * 10)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.3 (check-equivalence '(and (integer * 10) (rational 4)) '(integer 4 10)) nil) (deftest subtypep.integer.rational.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.5 (loop for int-type in '((integer 10) (integer 10 *)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational 19/2) (rational 19/2 *) (rational 10) (rational 10 *)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.6 (loop for int-type in '((integer * 10) (integer * 5)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational * 21/2) (rational * 10) (rational * 1000000000000)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.7 (loop for int-type in '((integer 0 10) (integer 2 5)) append (loop for rational-type in '(rational (rational) (rational *) (rational * *) (rational * 10) (rational * 1000000000000) (rational -1) (rational -1/2) (rational -1 *) (rational -1/2 *) (rational 0) (rational 0 10) (rational * 10) (rational 0 *) (rational 0 10)) unless (equal (multiple-value-list (subtypep* int-type rational-type)) '(t t)) collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.8 (check-equivalence '(and integer (rational (4) 10)) '(integer 5 10)) nil) (deftest subtypep.integer.rational.9 (check-equivalence '(and (integer 4 *) (rational * (10))) '(integer 4 9)) nil) (deftest subtypep.integer.rational.10 (check-equivalence '(and (integer * 10) (rational (4))) '(integer 5 10)) nil) gcl-2.6.14/ansi-tests/stream-external-format.lsp0000644000175000017500000000106414360276512020207 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 27 20:53:21 2004 ;;;; Contains: Tests of STREAM-EXTERNAL-FORMAT (in-package :cl-test) ;;; This is tested in open.lsp ;;; Error tests (deftest stream-external-format.error.1 (signals-error (stream-external-format) program-error) t) (deftest stream-external-format.error.2 (signals-error (let ((pn #p"tmp.dat")) (delete-all-versions pn) (with-open-file (s pn :direction :output :if-exists :supersede) (stream-external-format s nil))) program-error) t) gcl-2.6.14/ansi-tests/remove-aux.lsp0000644000175000017500000002104414360276512015676 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 15 07:42:36 2002 ;;;; Contains: Auxiliary functions for testing REMOVE and related functions (in-package :cl-test) (defun make-random-element (type) (cond ((subtypep* 'fixnum type) (random most-positive-fixnum)) ((subtypep* '(integer 0 255) type) (random 255)) ((subtypep* '(integer 0 7) type) (random 8)) ((subtypep* 'bit type) (random 2)) ((subtypep* 'symbol type) (elt '(a b c d e f g h) (random 8))) ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) (elt "abcdefgh" (random 8))) (t (error "Can't get random element of type ~A~%." type)))) (defun make-random-remove-input (len type element-type) "Randomly generate a test case for REMOVE. Given a length a sequence type, and an element type, produce a random sequence of length LEN of sequence type TYPE, and either generate a random member of the sequence or a random element of the element type to delete from the sequence." (let* ((seq (if (subtypep* type 'list) (loop for i from 1 to len collect (make-random-element element-type)) (let ((seq (if (and (subtypep type 'vector) (coin 3)) (make-array (list (+ len (random (1+ len)))) :initial-element (make-random-element element-type) :fill-pointer len :element-type element-type) (make-sequence type len)))) (dotimes (i len) (setf (elt seq i) (make-random-element element-type))) seq))) (e (if (and (> len 0) (coin)) (elt seq (random len)) (make-random-element element-type))) ) (values len seq e))) (defun my-remove (element sequence &key (start 0) (end nil) (test #'eql test-p) (test-not nil test-not-p) (key nil) (from-end nil) (count nil)) (assert (not (and test-p test-not-p))) (my-remove-if (cond (test-p #'(lambda (x) (funcall test element x))) (test-not-p #'(lambda (x) (not (funcall test-not element x)))) (t #'(lambda (x) (eql element x)))) sequence :start start :end end :key key :from-end from-end :count count)) (defun my-remove-if (predicate original-sequence &key (from-end nil) (start 0) (end nil) (count nil) (key #'identity)) (let ((len (length original-sequence)) (sequence (copy-seq original-sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (unless count (setq count len)) ;; Check that everything's kosher (assert (<= 0 start end len)) (assert (typep sequence 'sequence)) (assert (integerp count)) (assert (or (symbolp predicate) (functionp predicate))) (assert (or (symbolp key) (functionp key))) ;; If FROM-END, reverse the sequence and flip ;; start, end (when from-end (psetq sequence (nreverse sequence) start (- len end) end (- len start))) ;; Accumulate a list of elements for the result (let ((pos 0) (result nil)) ;; accumulate in reverse order (map nil #'(lambda (e) (if (and (> count 0) (>= pos start) (< pos end) (funcall predicate (funcall key e))) (decf count) (push e result)) (incf pos)) sequence) (unless from-end (setq result (nreverse result))) ;; Convert to the correct type (if (listp sequence) result (let ((element-type (array-element-type original-sequence))) (make-array (length result) :element-type element-type :initial-contents result)))))) (defun my-remove-if-not (pred &rest args) (when (symbolp pred) (setq pred (coerce pred 'function))) (assert (typep pred 'function)) (apply #'my-remove-if (complement pred) args)) (defun make-random-rd-params (maxlen) "Generate random paramaters for remove/delete/etc. functions." (let* ((element-type t) (type-select (random 7)) (type (case type-select (0 'list) (1 'vector) (2 (setq element-type 'character) 'string) (3 (setq element-type 'bit) 'bit-vector) (4 'simple-vector) (5 (setq element-type '(integer 0 255)) '(vector (integer 0 255))) (6 (setq element-type 'fixnum) '(vector fixnum)) (t (error "Can't happen?!~%")))) (len (random maxlen)) (start (and (coin) (> len 0) (random len))) (end (and (coin) (if start (+ start (random (- len start))) (random (1+ len))))) (from-end (coin)) (count (case (random 5) ((0 1) nil) ((2 3) (random (1+ len))) (t (if (coin) -1 -10000000000000)))) (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) (declare (ignore x z)) y)) (key (and (coin) (case type-select (2 (random-case #'char-upcase 'char-upcase #'char-downcase 'char-downcase)) (3 #'(lambda (x) (- 1 x))) ((5 6) (random-case #'1+ '1+ #'1- '1-)) (t (random-case 'identity #'identity))))) (test (and (eql (random 3) 0) (random-case 'eq 'eql 'equal #'eq #'eql #'equal))) (test-not (and (not test) (coin) (random-case 'eq 'eql 'equal #'eq #'eql #'equal))) ) ;; Return parameters (values element-type type len start end from-end count seq key test test-not))) (defun random-test-remove-args (maxlen) (multiple-value-bind (element-type type len start end from-end count seq key test test-not) (make-random-rd-params maxlen) (declare (ignore type)) (let ((element (if (and (coin) (> len 0)) (random-from-seq seq) (make-random-element element-type))) (arg-list (reduce #'nconc (random-permute (list (when start (list :start start)) (cond (end (list :end end)) ((coin) (list :end nil))) (cond (from-end (list :from-end from-end)) ((coin) (list :from-end nil))) (cond (count (list :count count)) ((coin) (list :count nil))) (cond (key (list :key key)) ;; ((coin) (list :key nil)) ) (when test (list :test test)) (when test-not (list :test test-not))))))) (values element seq arg-list)))) (defparameter *remove-fail-args* nil) (defun random-test-remove (maxlen &key (tested-fn #'remove) (check-fn #'my-remove) (pure t)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply tested-fn element seq1 arg-list)) (seq2r (apply check-fn element seq2 arg-list))) (setq *remove-fail-args* (list* element seq1 arg-list)) (cond ((and pure (not (equalp seq seq1))) :fail1) ((and pure (not (equalp seq seq2))) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t))))) (defun random-test-remove-if (maxlen &optional (negate nil)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (if fn (case (random 3) (0 (setf arg-list (list* :key 'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list))) (t nil)) (setf fn (if (coin) 'identity #'(lambda (x) (funcall test element x))))) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if negate #'remove-if-not #'remove-if) fn seq1 arg-list)) (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) fn seq2 arg-list))) (setq *remove-fail-args* (cons seq1 arg-list)) (cond ((not (equalp seq seq1)) :fail1) ((not (equalp seq seq2)) :fail2) ((not (equalp seq1r seq2r)) :fail3) (t t)))))) (defun random-test-delete (maxlen) (random-test-remove maxlen :tested-fn #'delete :pure nil)) (defun random-test-delete-if (maxlen &optional (negate nil)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (if fn (case (random 3) (0 (setf arg-list (list* :key 'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list))) (t nil)) (setf fn (if (coin) 'identity #'(lambda (x) (funcall test element x))))) (setq *remove-fail-args* (list* seq arg-list)) (let* ((seq1 (copy-seq seq)) (seq2 (copy-seq seq)) (seq1r (apply (if negate #'delete-if-not #'delete-if) fn seq1 arg-list)) (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) fn seq2 arg-list))) (cond ((not (equalp seq1r seq2r)) :fail3) (t t)))))) gcl-2.6.14/ansi-tests/funcall.lsp0000644000175000017500000000413614360276512015235 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Oct 9 21:45:07 2002 ;;;; Contains: Tests of FUNCALL (in-package :cl-test) (deftest funcall.1 (let ((fn #'cons)) (funcall fn 'a 'b)) (a . b)) (deftest funcall.2 (funcall (symbol-function 'cons) 'a 'b) (a . b)) (deftest funcall.3 (let ((fn 'cons)) (funcall fn 'a 'b)) (a . b)) (deftest funcall.4 (funcall 'cons 'a 'b) (a . b)) (deftest funcall.5 (let ((fn #'+)) (funcall fn 1 2 3 4)) 10) (deftest funcall.6 (funcall #'(lambda (x y) (cons x y)) 'a 'b) (a . b)) (defun xcons (x y) (cons x y)) (deftest funcall.7 (flet ((xcons (x y) (list y x))) (values (funcall 'xcons 1 2) (funcall #'xcons 1 2))) (1 . 2) (2 1)) (deftest funcall.8 (flet ((foo (x y z) (values x y z))) (funcall #'foo 1 2 3)) 1 2 3) (deftest funcall.9 (flet ((foo () (values))) (funcall #'foo)) ) (deftest funcall.order.1 (let ((i 0) a b) (values (funcall (progn (setf a (incf i)) #'car) (progn (setf b (incf i)) '(x . y))) i a b)) x 2 1 2) (deftest funcall.order.2 (let ((i 0) a b c) (values (funcall (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) 'x) (progn (setf c (incf i)) 'y)) i a b c)) (x . y) 3 1 2 3) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a special ;;; operator (deftest funcall.error.1 (classify-error (funcall 'quote 1)) undefined-function) (deftest funcall.error.2 (classify-error (funcall 'progn 1)) undefined-function) ;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when ;;; called on a symbol with a global definition as a macro (deftest funcall.error.3 (classify-error (funcall 'defconstant '(defconstant x 10))) undefined-function) (deftest funcall.error.4 (classify-error (funcall)) program-error) (deftest funcall.error.5 (classify-error (funcall #'cons)) program-error) (deftest funcall.error.6 (classify-error (funcall #'cons 1)) program-error) (deftest funcall.error.7 (classify-error (funcall #'car 'a)) type-error) gcl-2.6.14/ansi-tests/logical-pathname.lsp0000644000175000017500000000453314360276512017017 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Dec 30 19:05:01 2003 ;;;; Contains: Tests of LOGICAL-PATHNAME (in-package :cl-test) (deftest logical-pathname.1 (loop for x in *logical-pathnames* always (eql x (logical-pathname x))) t) (deftest logical-pathname.2 (notnot-mv (typep (logical-pathname "CLTEST:FOO") 'logical-pathname)) t) (deftest logical-pathname.3 (let ((name "CLTEST:TEMP.DAT.NEWEST")) (with-open-file (s (logical-pathname name) :direction :output :if-exists :supersede :if-does-not-exist :create) (or (equalt (logical-pathname s) (logical-pathname name)) (list (logical-pathname s) (logical-pathname name))))) t) ;;; Error tests (deftest logical-pathname.error.1 (check-type-error #'logical-pathname (typef '(or string stream logical-pathname))) nil) (deftest logical-pathname.error.2 ;; Doesn't specify a host (signals-error (logical-pathname "FOO.TXT") type-error) t) (deftest logical-pathname.error.3 (signals-error (with-open-file (s #p"logical-pathname.lsp" :direction :input) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.4 (signals-error (with-open-stream (is (make-concatenated-stream)) (with-open-stream (os (make-broadcast-stream)) (with-open-stream (s (make-two-way-stream is os)) (logical-pathname s)))) type-error) t) (deftest logical-pathname.error.5 (signals-error (with-open-stream (is (make-concatenated-stream)) (with-open-stream (os (make-broadcast-stream)) (with-open-stream (s (make-echo-stream is os)) (logical-pathname s)))) type-error) t) (deftest logical-pathname.error.6 (signals-error (with-open-stream (s (make-broadcast-stream)) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.7 (signals-error (with-open-stream (s (make-concatenated-stream)) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.8 (signals-error (with-open-stream (s (make-string-input-stream "foo")) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.9 (signals-error (with-output-to-string (s) (logical-pathname s)) type-error) t) (deftest logical-pathname.error.10 (handler-case (progn (eval '(locally (declare (optimize safety)) (logical-pathname "CLROOT:%"))) t) (type-error () t)) t) gcl-2.6.14/ansi-tests/atom-errors.lsp0000644000175000017500000000123114360276512016054 0ustar cammcamm(setf x (loop for tp in '(CONDITION SERIOUS-CONDITION ERROR TYPE-ERROR SIMPLE-TYPE-ERROR SIMPLE-CONDITION PARSE-ERROR CELL-ERROR UNBOUND-SLOT WARNING STYLE-WARNING STORAGE-CONDITION SIMPLE-WARNING UNBOUND-VARIABLE CONTROL-ERROR PROGRAM-ERROR UNDEFINED-FUNCTION PACKAGE-ERROR ARITHMETIC-ERROR DIVISION-BY-ZERO FLOATING-POINT-INVALID-OPERATION FLOATING-POINT-INEXACT FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW FILE-ERROR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM STREAM-ERROR END-OF-FILE PRINT-NOT-READABLE READER-ERROR) collect (list tp (multiple-value-list (subtypep* tp 'atom))))) gcl-2.6.14/ansi-tests/lambda-parameters-limit.lsp0000644000175000017500000000056714360276512020312 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 22:45:44 2002 ;;;; Contains: Tests for LAMBDA-PARAMETERS-LIMIT (in-package :cl-test) (deftest lambda-parameters-limit.1 (not (typep lambda-parameters-limit 'integer)) nil) (deftest lambda-parameters-limit.2 (< lambda-parameters-limit 50) nil) ;;; See also tests is flet.lsp, labels.lsp gcl-2.6.14/ansi-tests/packages-04.lsp0000644000175000017500000000263614360276512015613 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 07:59:10 1998 ;;;; Contains: Package test code, part 04 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; intern (deftest intern.1 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1")) (i 0) x y) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" p) (intern (progn (setf x (incf i)) "FOO") (progn (setf y (incf i)) p)) (multiple-value-bind* (sym2 status2) (find-symbol "FOO" p) (and (eql i 2) (eql x 1) (eql y 2) (null sym1) (null status1) (string= (symbol-name sym2) "FOO") (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t) (deftest intern.2 (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1"))) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" "TEMP1") (intern "FOO" "TEMP1") (multiple-value-bind* (sym2 status2) (find-symbol "FOO" p) (and (null sym1) (null status1) (string= (symbol-name sym2) "FOO") (eqt (symbol-package sym2) p) (eqt status2 :internal) (progn (delete-package p) t)))))) t) (deftest intern.error.1 (classify-error (intern)) program-error) (deftest intern.error.2 (classify-error (intern "X" "CL" nil)) program-error) gcl-2.6.14/ansi-tests/pathname-match-p.lsp0000644000175000017500000000517714360276512016743 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 15 07:46:22 2004 ;;;; Contains: Tests for PATHNAME-MATCH-P (in-package :cl-test) (compile-and-load "pathnames-aux.lsp") ;;; Much of the behavior cannot be tested portably. (deftest pathname-match-p.1 (let ((pn1 (make-pathname :name :wild)) (pn2 (make-pathname :name "foo"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.2 (let ((pn1 (make-pathname :type :wild)) (pn2 (make-pathname :type "txt"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.3 (let ((pn1 (make-pathname :directory '(:absolute :wild))) (pn2 (make-pathname :directory '(:absolute)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.4 (let ((pn1 (make-pathname :directory '(:relative :wild))) (pn2 (make-pathname :directory '(:relative)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.5 (let ((pn1 (make-pathname :directory '(:relative :wild))) (pn2 (make-pathname :directory nil))) (and (wild-pathname-p pn1) (not (pathname-directory pn2)) (not (pathname-match-p pn1 pn2)))) nil) (deftest pathname-match-p.6 (let ((pn1 (make-pathname :version :wild)) (pn2 (make-pathname))) (and (wild-pathname-p pn1) (not (pathname-version pn2)) (not (pathname-match-p pn1 pn2)))) nil) ;;; Specialized string tests (deftest pathname-match-p.7 (let ((wpn (parse-namestring "CLTEST:*.LSP"))) (assert (wild-pathname-p wpn)) (do-special-strings (s "CLTEST:FOO.LSP" nil) (assert (pathname-match-p s wpn)))) nil) (deftest pathname-match-p.8 (do-special-strings (s "CLTEST:*.LSP" nil) (assert (pathname-match-p "CLTEST:FOO.LSP" s))) nil) ;;; Add more tests here ;;; Here are error tests (deftest pathname-match-p.error.1 (signals-error (pathname-match-p) program-error) t) (deftest pathname-match-p.error.2 (signals-error (pathname-match-p #p"") program-error) t) (deftest pathname-match-p.error.3 (signals-error (pathname-match-p #p"" #p"" nil) program-error) t) (deftest pathname-match-p.error.4 (check-type-error #'(lambda (x) (pathname-match-p x #p"")) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.5 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p x #p"")) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.6 (check-type-error #'(lambda (x) (pathname-match-p #p"" x)) #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.7 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p #p"" x)) #'could-be-pathname-designator) nil) gcl-2.6.14/ansi-tests/loop15.lsp0000644000175000017500000001176114360276512014732 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 21 07:08:21 2002 ;;;; Contains: Tests that keywords can be loop keywords (in-package :cl-test) ;;; Tests of loop keywords (deftest loop.15.30 (loop :for i :from 1 :to 10 :collect i) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.15.31 (loop :for i :upfrom 1 :below 10 :by 2 :collect i) (1 3 5 7 9)) (deftest loop.15.32 (loop :with x = 1 :and y = 2 :return (values x y)) 1 2) (deftest loop.15.33 (loop :named foo :doing (return-from foo 1)) 1) (deftest loop.15.34 (let ((x 0)) (loop :initially (setq x 2) :until t :finally (return x))) 2) (deftest loop.15.35 (loop :for x :in '(a b c) :collecting x) (a b c)) (deftest loop.15.36 (loop :for x :in '(a b c) :append (list x)) (a b c)) (deftest loop.15.37 (loop :for x :in '(a b c) :appending (list x)) (a b c)) (deftest loop.15.38 (loop :for x :in '(a b c) :nconc (list x)) (a b c)) (deftest loop.15.39 (loop :for x :in '(a b c) :nconcing (list x)) (a b c)) (deftest loop.15.40 (loop :for x :in '(1 2 3) :count x) 3) (deftest loop.15.41 (loop :for x :in '(1 2 3) :counting x) 3) (deftest loop.15.42 (loop :for x :in '(1 2 3) :sum x) 6) (deftest loop.15.43 (loop :for x :in '(1 2 3) :summing x) 6) (deftest loop.15.44 (loop :for x :in '(10 20 30) :maximize x) 30) (deftest loop.15.45 (loop :for x :in '(10 20 30) :maximizing x) 30) (deftest loop.15.46 (loop :for x :in '(10 20 30) :minimize x) 10) (deftest loop.15.47 (loop :for x :in '(10 20 30) :minimizing x) 10) (deftest loop.15.48 (loop :for x :in '(1 2 3 4) :sum x :into foo :of-type fixnum :finally (return foo)) 10) (deftest loop.15.49 (loop :for x :upfrom 1 :to 10 :if (evenp x) :sum x :into foo :else :sum x :into bar :end :finally (return (values foo bar))) 30 25) (deftest loop.15.50 (loop :for x :downfrom 10 :above 0 :when (evenp x) :sum x :into foo :else :sum x :into bar :end :finally (return (values foo bar))) 30 25) (deftest loop.15.51 (loop :for x :in '(a b nil c d nil) :unless x :count t) 2) (deftest loop.15.52 (loop :for x :in '(a b nil c d nil) :unless x :collect x :into bar :and :count t :into foo :end finally (return (values bar foo))) (nil nil) 2) (deftest loop.15.53 (loop :for x :in '(nil nil a b nil c nil) :collect x :until x) (nil nil a)) (deftest loop.15.54 (loop :for x :in '(a b nil c nil) :while x :collect x) (a b)) (deftest loop.15.55 (loop :for x :in '(nil nil a b nil c nil) :thereis x) a) (deftest loop.15.56 (loop :for x :in '(nil nil a b nil c nil) :never x) nil) (deftest loop.15.57 (loop :for x :in '(a b c d e) :always x) t) (deftest loop.15.58 (loop :as x :in '(a b c) :count t) 3) (deftest loop.15.59 (loop :for i :from 10 :downto 5 :collect i) (10 9 8 7 6 5)) (deftest loop.15.60 (loop :for i :from 0 :upto 5 :collect i) (0 1 2 3 4 5)) (deftest loop.15.61 (loop :for x :on '(a b c) :collecting (car x)) (a b c)) (deftest loop.15.62 (loop :for x = '(a b c) :then (cdr x) :while x :collect (car x)) (a b c)) (deftest loop.15.63 (loop :for x :across #(a b c) :collect x) (a b c)) (deftest loop.15.64 (loop :for x :being :the :hash-keys :of (make-hash-table) :count t) 0) (deftest loop.15.65 (loop :for x :being :each :hash-key :in (make-hash-table) :count t) 0) (deftest loop.15.66 (loop :for x :being :each :hash-value :of (make-hash-table) :count t) 0) (deftest loop.15.67 (loop :for x :being :the :hash-values :in (make-hash-table) :count t) 0) (deftest loop.15.68 (loop :for x :being :the :hash-values :in (make-hash-table) :using (:hash-key k) :count t) 0) (deftest loop.15.69 (loop :for x :being :the :hash-keys :in (make-hash-table) :using (:hash-value v) :count t) 0) (deftest loop.15.70 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :symbols :of p :count t))) 0) (deftest loop.15.71 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :symbol :of p :count t))) 0) (deftest loop.15.72 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :external-symbols :of p :count t))) 0) (deftest loop.15.73 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :external-symbol :of p :count t))) 0) (deftest loop.15.74 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :present-symbols :of p :count t))) 0) (deftest loop.15.75 (progn (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :present-symbol :of p :count t))) 0) gcl-2.6.14/ansi-tests/loop8.lsp0000644000175000017500000000543214360276512014652 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Nov 12 06:30:14 2002 ;;;; Contains: Tests of LOOP local variable initialization (in-package :cl-test) (deftest loop.8.1 (loop with x = 1 do (return x)) 1) (deftest loop.8.2 (loop with x = 1 with y = (1+ x) do (return (list x y))) (1 2)) (deftest loop.8.3 (let ((y 2)) (loop with x = y with y = (1+ x) do (return (list x y)))) (2 3)) (deftest loop.8.4 (let (a b) (loop with a = 1 and b = (list a) and c = (list b) return (list a b c))) (1 (nil) (nil))) ;;; type specs (deftest loop.8.5 (loop with a t = 1 return a) 1) (deftest loop.8.6 (loop with a fixnum = 2 return a) 2) (deftest loop.8.7 (loop with a float = 3.0 return a) 3.0) (deftest loop.8.8 (loop with a of-type string = "abc" return a) "abc") (deftest loop.8.9 (loop with (a b) = '(1 2) return (list b a)) (2 1)) (deftest loop.8.10 (loop with (a b) of-type (fixnum fixnum) = '(3 4) return (+ a b)) 7) (deftest loop.8.11 (loop with a of-type fixnum return a) 0) (deftest loop.8.12 (loop with a of-type float return a) 0.0) (deftest loop.8.13 (loop with a of-type t return a) nil) (deftest loop.8.14 (loop with a t return a) nil) (deftest loop.8.15 (loop with a t and b t return (list a b)) (nil nil)) (deftest loop.8.16 (loop with (a b c) of-type (fixnum float t) return (list a b c)) (0 0.0 nil)) (deftest loop.8.17 (loop with nil = nil return nil) nil) ;;; The NIL block of a loop encloses the entire loop. (deftest loop.8.18 (loop with nil = (return t) return nil) t) (deftest loop.8.19 (loop with (nil a) = '(1 2) return a) 2) (deftest loop.8.20 (loop with (a nil) = '(1 2) return a) 1) (deftest loop.8.21 (loop with b = 3 and (a nil) = '(1 2) return (list a b)) (1 3)) (deftest loop.8.22 (loop with b = 3 and (nil a) = '(1 2) return (list a b)) (2 3)) ;;; The NIL block of a loop encloses the entire loop. (deftest loop.8.23 (loop with a = 1 and b = (return 2) return 3) 2) ;;; Error cases ;;; The spec says (in section 6.1.1.7) that: ;;; "An error of type program-error is signaled (at macro expansion time) ;;; if the same variable is bound twice in any variable-binding clause ;;; of a single loop expression. Such variables include local variables, ;;; iteration control variables, and variables found by destructuring." ;;; ;;; This is somewhat ambiguous. Test loop.8.error.1 binds A twice in ;;; the same clause, but loop.8.error.2 binds A in two different clauses. ;;; I am interpreting the spec as ruling out the latter as well. (deftest loop.8.error.1 (classify-error (loop with a = 1 and a = 2 return a)) program-error) (deftest loop.8.error.2 (classify-error (loop with a = 1 with a = 2 return a)) program-error) gcl-2.6.14/ansi-tests/prog.lsp0000644000175000017500000000375214360276512014563 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 09:21:57 2002 ;;;; Contains: Tests of PROG (in-package :cl-test) (deftest prog.1 (prog ()) nil) (deftest prog.2 (prog () 'a) nil) (deftest prog.3 (prog () (return 'a)) a) (deftest prog.4 (prog () (return (values 1 2 3 4 5))) 1 2 3 4 5) (deftest prog.5 (let ((x 'a)) (prog ((x 'b) (y x)) (declare (type symbol x y)) (return (values x y)))) b a) (deftest prog.6 (let ((x 'a)) (prog (x) (setq x 'b)) x) a) (deftest prog.7 (prog ((i 1) (s 0)) (declare (type fixnum i s)) again (when (> i 10) (return s)) (incf s i) (incf i) (go again)) 55) (deftest prog.8 (let ((x 0)) (prog ((y (incf x)) (z (incf x))) (return (values x y z)))) 2 1 2) (deftest prog.9 (flet ((%f () (locally (declare (special z)) z))) (prog ((z 10)) (declare (special z)) (return (%f)))) 10) (deftest prog.10 (prog () (return (1+ (prog () (go end) done (return 1) end (go done)))) done (return 'bad)) 2) ;;; Tests of PROG* (deftest prog*.1 (prog* ()) nil) (deftest prog*.2 (prog* () 'a) nil) (deftest prog*.3 (prog* () (return 'a)) a) (deftest prog*.4 (prog* () (return (values 1 2 3 4 5))) 1 2 3 4 5) (deftest prog*.5 (let ((x 'a)) (prog* ((z x) (x 'b) (y x)) (declare (type symbol x y)) (return (values x y z)))) b b a) (deftest prog*.6 (let ((x 'a)) (prog* (x) (setq x 'b)) x) a) (deftest prog*.7 (prog* ((i 1) (s 0)) (declare (type fixnum i s)) again (when (> i 10) (return s)) (incf s i) (incf i) (go again)) 55) (deftest prog*.8 (let ((x 0)) (prog* ((y (incf x)) (z (incf x))) (return (values x y z)))) 2 1 2) (deftest prog*.9 (flet ((%f () (locally (declare (special z)) z))) (prog* ((z 10)) (declare (special z)) (return (%f)))) 10) (deftest prog*.10 (prog* () (return (1+ (prog* () (go end) done (return 1) end (go done)))) done (return 'bad)) 2) gcl-2.6.14/ansi-tests/cons-test-18.lsp0000644000175000017500000001556214360276512015763 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 10:23:31 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 18 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; get-properties (deftest get-properties.1 (get-properties nil nil) nil nil nil) (deftest get-properties.2 (get-properties '(a b) nil) nil nil nil) (deftest get-properties.3 (get-properties '(a b c d) '(a)) a b (a b c d)) (deftest get-properties.4 (get-properties '(a b c d) '(c)) c d (c d)) (deftest get-properties.5 (get-properties '(a b c d) '(c a)) a b (a b c d)) (deftest get-properties.6 (get-properties '(a b c d) '(b)) nil nil nil) (deftest get-properties.7 (get-properties '("aa" b c d) (list (copy-seq "aa"))) nil nil nil) (deftest get-properties.8 (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) nil nil nil) (deftest get-properties.9 (let* ((x (copy-list '(a b c d e f g h a c))) (xcopy (make-scaffold-copy x)) (y (copy-list '(x y f g))) (ycopy (make-scaffold-copy y))) (multiple-value-bind (indicator value tail) (get-properties x y) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (eqt tail (nthcdr 6 x)) (values indicator value tail)))) g h (g h a c)) (deftest get-properties.order.1 (let ((i 0) x y) (values (multiple-value-list (get-properties (progn (setf x (incf i)) '(a b c d)) (progn (setf y (incf i)) '(c)))) i x y)) (c d (c d)) 2 1 2) (deftest get-properties.error.1 (classify-error (get-properties)) program-error) (deftest get-properties.error.2 (classify-error (get-properties nil)) program-error) (deftest get-properties.error.3 (classify-error (get-properties nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; getf (deftest getf.1 (getf nil 'a) nil) (deftest getf.2 (getf nil 'a 'b) b) (deftest getf.3 (getf '(a b) 'a) b) (deftest getf.4 (getf '(a b) 'a 'c) b) (deftest getf.5 (let ((x 0)) (values (getf '(a b) 'a (incf x)) x)) b 1) (deftest getf.order.1 (let ((i 0) x y) (values (getf (progn (setf x (incf i)) '(a b)) (progn (setf y (incf i)) 'a)) i x y)) b 2 1 2) (deftest getf.order.2 (let ((i 0) x y z) (values (getf (progn (setf x (incf i)) '(a b)) (progn (setf y (incf i)) 'a) (setf z (incf i))) i x y z)) b 3 1 2 3) (deftest setf-getf.1 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'c) 3) ;; Must check that only a, b, c have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.2 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'a) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest setf-getf.3 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'c 17) 3) ;; Must check that only a, b, c have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.4 (let ((p (copy-list '(a 1 b 2)))) (setf (getf p 'a 17) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest setf-getf.5 (let ((p (copy-list '(a 1 b 2))) (foo nil)) (setf (getf p 'a (progn (setf foo t) 0)) 3) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 3) (eqlt (getf p 'b) 2) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) foo)) t) (deftest setf-getf.order.1 (let ((p (list (copy-list '(a 1 b 2)))) (cnt1 0) (cnt2 0) (cnt3 0)) (setf (getf (car (progn (incf cnt1) p)) 'c (incf cnt3)) (progn (incf cnt2) 3)) ;; Must check that only a, b, c have properties (and (eqlt cnt1 1) (eqlt cnt2 1) (eqlt cnt3 1) (eqlt (getf (car p) 'a) 1) (eqlt (getf (car p) 'b) 2) (eqlt (getf (car p) 'c) 3) (eqlt (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest setf-getf.order.2 (let ((p (list (copy-list '(a 1 b 2)))) (i 0) x y z w) (setf (getf (car (progn (setf x (incf i)) p)) (progn (setf y (incf i)) 'c) (setf z (incf i))) (progn (setf w (incf i)) 3)) ;; Must check that only a, b, c have properties (and (eqlt i 4) (eqlt x 1) (eqlt y 2) (eqlt z 3) (eqlt w 4) (eqlt (getf (car p) 'a) 1) (eqlt (getf (car p) 'b) 2) (eqlt (getf (car p) 'c) 3) (eqlt (loop for ptr on (car p) by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest incf-getf.1 (let ((p (copy-list '(a 1 b 2)))) (incf (getf p 'b)) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 3) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) 0) t)) t) (deftest incf-getf.2 (let ((p (copy-list '(a 1 b 2)))) (incf (getf p 'c 19)) ;; Must check that only a, b have properties (and (eqlt (getf p 'a) 1) (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 20) (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) 0) t)) t) (deftest push-getf.1 (let ((p nil)) (values (push 'x (getf p 'a)) p)) (x) (a (x))) (deftest getf.error.1 (classify-error (getf)) program-error) (deftest getf.error.2 (classify-error (getf nil)) program-error) (deftest getf.error.3 (classify-error (getf nil nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; remf (deftest remf.1 (let ((x nil)) (values (remf x 'a) x)) nil ()) (deftest remf.2 (let ((x (list 'a 'b))) (values (not (null (remf x 'a))) x)) t ()) (deftest remf.3 (let ((x (list 'a 'b 'a 'c))) (values (not (null (remf x 'a))) x)) t (a c)) (deftest remf.4 (let ((x (list 'a 'b 'c 'd))) (values (and (remf x 'c) t) (loop for ptr on x by #'cddr count (not (eqt (car ptr) 'a))))) t 0) (deftest remf.order.1 (let ((i 0) x y (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) (values (notnot (remf (aref p (progn (setf x (incf i)) 0)) (progn (setf y (incf i)) 'c))) (aref p 0) i x y)) t (a b e f) 2 1 2) gcl-2.6.14/ansi-tests/cons-test-06.lsp0000644000175000017500000000167414360276512015757 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:40 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 6 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; endp (deftest endp-nil (notnot-mv (endp nil)) t) (deftest endp-cons (endp (cons 'a 'a)) nil) (deftest endp-singleton-list (endp '(a)) nil) (deftest endp.order.1 (let ((i 0)) (values (endp (progn (incf i) '(a b c))) i)) nil 1) (deftest endp-symbol-error (catch-type-error (endp 'a)) type-error) (deftest endp-fixnum-error (catch-type-error (endp 1)) type-error) (deftest endp-float-error (catch-type-error (endp 0.9212d4)) type-error) (deftest endp.error.4 (classify-error (endp)) program-error) (deftest endp.error.5 (classify-error (endp nil nil)) program-error) (deftest endp.error.6 (catch-type-error (locally (endp 1))) type-error) gcl-2.6.14/ansi-tests/cons-test-07.lsp0000644000175000017500000001027114360276512015751 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:35:15 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 7 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nconc (deftest nconc.1 (nconc) nil) (deftest nconc.2 (nconc (copy-tree '(a b c d e f))) (a b c d e f)) (deftest nconc.3 (nconc 1) 1) (deftest nconc.4 (let ((x (list 'a 'b 'c)) (y (list 'd 'e 'f))) (let ((ycopy (make-scaffold-copy y))) (let ((result (nconc x y))) (and (check-scaffold-copy y ycopy) (eqt (cdddr x) y) result)))) (a b c d e f)) (deftest nconc.5 (let ((x (list 'a 'b 'c))) (nconc x x) (and (eqt (cdddr x) x) (null (list-length x)))) t) (deftest nconc.6 (let ((x (list 'a 'b 'c)) (y (list 'd 'e 'f 'g 'h)) (z (list 'i 'j 'k))) (let ((result (nconc x y z 'foo))) (and (eqt (nthcdr 3 x) y) (eqt (nthcdr 5 y) z) (eqt (nthcdr 3 z) 'foo) result))) (a b c d e f g h i j k . foo)) (deftest nconc.7 (nconc (copy-tree '(a . b)) (copy-tree '(c . d)) (copy-tree '(e . f)) 'foo) (a c e . foo)) (deftest nconc.order.1 (let ((i 0) x y z) (values (nconc (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f))) (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) (deftest nconc.order.2 (let ((i 0)) (values (nconc (incf i)) i)) 1 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; append (deftest append.1 (append) nil) (deftest append.2 (append 'x) x) (deftest append.3 (let ((x (list 'a 'b 'c 'd)) (y (list 'e 'f 'g))) (let ((xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y))) (let ((result (append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) result)))) (a b c d e f g)) (deftest append.4 (append (list 'a) (list 'b) (list 'c) (list 'd) (list 'e) (list 'f) (list 'g) 'h) (a b c d e f g . h)) (deftest append.5 (append nil nil nil nil nil nil nil nil 'a) a) (deftest append.6 (append-6-body) 0) (deftest append.order.1 (let ((i 0) x y z) (values (append (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f))) (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) (deftest append.order.2 (let ((i 0)) (values (append (incf i)) i)) 1 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; revappend (deftest revappend.1 (let* ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)) (xcopy (make-scaffold-copy x)) (ycopy (make-scaffold-copy y)) ) (let ((result (revappend x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (eqt (cdddr result) y) result))) (c b a d e f)) (deftest revappend.2 (revappend (copy-tree '(a b c d e)) 10) (e d c b a . 10)) (deftest revappend.3 (revappend nil 'a) a) (deftest revappend.4 (revappend (copy-tree '(a (b c) d)) nil) (d (b c) a)) (deftest revappend.order.1 (let ((i 0) x y) (values (revappend (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) (deftest revappend.error.1 (classify-error (revappend)) program-error) (deftest revappend.error.2 (classify-error (revappend nil)) program-error) (deftest revappend.error.3 (classify-error (revappend nil nil nil)) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nreconc (deftest nreconc.1 (let* ((x (list 'a 'b 'c)) (y (copy-tree '(d e f))) (result (nreconc x y))) (and (equal y '(d e f)) result)) (c b a d e f)) (deftest nreconc.2 (nreconc nil 'a) a) (deftest nreconc.order.1 (let ((i 0) x y) (values (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) (deftest nreconc.error.1 (classify-error (nreconc)) program-error) (deftest nreconc.error.2 (classify-error (nreconc nil)) program-error) (deftest nreconc.error.3 (classify-error (nreconc nil nil nil)) program-error) gcl-2.6.14/ansi-tests/merge.lsp0000644000175000017500000003137514360276512014715 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Sep 6 07:24:17 2002 ;;;; Contains: Tests for MERGE (in-package :cl-test) (deftest merge-list.1 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.2 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (2 4 5 8 11)) (deftest merge-list.3 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'list y x #'<)) (2 4 5 8 11)) (deftest merge-list.4 (merge 'list nil nil #'<) nil) (deftest merge-list.5 (let ((x (vector 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.6 (let ((x (list 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.7 (let ((x (vector 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.8 (let ((x (sort (list 1 3 7 8 10) #'>)) (y (sort (list 2 4 5 8 11) #'>))) (merge 'list x y #'< :key #'-)) (11 10 8 8 7 5 4 3 2 1)) (deftest merge-list.9 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y #'< :key nil)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.10 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'list x y '<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.11 (let ((x (vector)) (y (vector))) (merge 'list x y #'<)) nil) (deftest merge-list.12 (let ((x nil) (y (vector 1 2 3))) (merge 'list x y #'<)) (1 2 3)) (deftest merge-list.13 (let ((x (vector)) (y (list 1 2 3))) (merge 'list x y #'<)) (1 2 3)) (deftest merge-list.14 (let ((x nil) (y (vector 1 2 3))) (merge 'list y x #'<)) (1 2 3)) (deftest merge-list.15 (let ((x (vector)) (y (list 1 2 3))) (merge 'list y x #'<)) (1 2 3)) ;;; Tests yielding vectors (deftest merge-vector.1 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.2 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(2 4 5 8 11)) (deftest merge-vector.3 (let ((x nil) (y (list 2 4 5 8 11))) (merge 'vector y x #'<)) #(2 4 5 8 11)) (deftest merge-vector.4 (merge 'vector nil nil #'<) #()) (deftest merge-vector.5 (let ((x (vector 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.6 (let ((x (list 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.7 (let ((x (vector 1 3 7 8 10)) (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.8 (let ((x (sort (list 1 3 7 8 10) #'>)) (y (sort (list 2 4 5 8 11) #'>))) (merge 'vector x y #'< :key #'-)) #(11 10 8 8 7 5 4 3 2 1)) (deftest merge-vector.9 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y #'< :key nil)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.10 (let ((x (list 1 3 7 8 10)) (y (list 2 4 5 8 11))) (merge 'vector x y '<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.11 (let ((x (vector)) (y (vector))) (merge 'vector x y #'<)) #()) (deftest merge-vector.12 (let ((x nil) (y (vector 1 2 3))) (merge 'vector x y #'<)) #(1 2 3)) (deftest merge-vector.13 (let ((x (vector)) (y (list 1 2 3))) (merge 'vector x y #'<)) #(1 2 3)) (deftest merge-vector.14 (let ((x nil) (y (vector 1 2 3))) (merge 'vector y x #'<)) #(1 2 3)) (deftest merge-vector.15 (let ((x (vector)) (y (list 1 2 3))) (merge 'vector y x #'<)) #(1 2 3)) (deftest merge-vector.16 (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (y (list 1 6 10))) (merge 'vector x y #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.16a (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (y (list 1 6 10))) (merge 'vector y x #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.17 (let* ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) :fill-pointer 5)) (result (merge 'vector x () #'<))) (values (array-element-type result) result)) t #(2 5 8 9 11)) ;;; Tests on strings (deftest merge-string.1 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1a (let ((x "1378") (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1b (let ((x (list #\1 #\3 #\7 #\8)) (y "2459")) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1c (let ((x "1378") (y "2459")) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1d (let ((x "1378") (y "2459")) (merge 'string y x #'char<)) "12345789") (deftest merge-string.2 (let ((x nil) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "2459") (deftest merge-string.3 (let ((x nil) (y (list #\2 #\4 #\5 #\9))) (merge 'string y x #'char<)) "2459") (deftest merge-string.4 (merge 'string nil nil #'char<) "") (deftest merge-string.8 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5))) (merge 'string x y #'char< :key #'nextdigit)) "1234578") (deftest merge-string.9 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char< :key nil)) "12345789") (deftest merge-string.10 (let ((x (list #\1 #\3 #\7 #\8)) (y (list #\2 #\4 #\5 #\9))) (merge 'string x y 'char<)) "12345789") (deftest merge-string.11 (let ((x (vector)) (y (vector))) (merge 'string x y #'char<)) "") (deftest merge-string.12 (let ((x nil) (y (vector #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.13 (let ((x (vector)) (y (list #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.13a (let ((x (copy-seq "")) (y (list #\1 #\2 #\3))) (merge 'string x y #'char<)) "123") (deftest merge-string.14 (let ((x nil) (y (vector #\1 #\2 #\3))) (merge 'string y x #'char<)) "123") (deftest merge-string.14a (let ((x (copy-seq "")) (y (vector #\1 #\2 #\3))) (merge 'string y x #'char<)) "123") (deftest merge-string.15 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character)) (y (copy-seq "bci"))) (merge 'string x y #'char<)) "abcdgikm") (deftest merge-string.16 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character)) (y (copy-seq "bci"))) (merge 'string y x #'char<)) "abcdgikm") (deftest merge-string.17 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character))) (merge 'string nil x #'char<)) "adgkm") (deftest merge-string.18 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" :fill-pointer 5 :element-type 'character))) (merge 'string x nil #'char<)) "adgkm") ;;; Tests for bit vectors (deftest merge-bit-vector.1 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.2 (let ((x nil) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*00011) (deftest merge-bit-vector.3 (let ((x nil) (y (list 0 0 0 1 1))) (merge 'bit-vector y x #'<)) #*00011) (deftest merge-bit-vector.4 (merge 'bit-vector nil nil #'<) #*) (deftest merge-bit-vector.5 (let ((x (vector 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5a (let ((x (copy-seq #*00111)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5b (let ((x (list 0 0 1 1 1)) (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5c (let ((x (copy-seq #*00111)) (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5d (let ((x (copy-seq #*11111)) (y (copy-seq #*00000))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5e (let ((x (copy-seq #*11111)) (y (copy-seq #*00000))) (merge 'bit-vector y x #'<)) #*0000011111) (deftest merge-bit-vector.6 (let ((x (list 0 0 1 1 1)) (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.7 (let ((x (vector 0 0 1 1 1)) (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.8 (let ((x (list 1 1 1 0 0)) (y (list 1 1 0 0 0))) (merge 'bit-vector x y #'< :key #'-)) #*1111100000) (deftest merge-bit-vector.9 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'< :key nil)) #*0000011111) (deftest merge-bit-vector.10 (let ((x (list 0 0 1 1 1)) (y (list 0 0 0 1 1))) (merge 'bit-vector x y '<)) #*0000011111) (deftest merge-bit-vector.11 (let ((x (copy-seq #*)) (y (copy-seq #*))) (merge 'bit-vector x y #'<)) #*) (deftest merge-bit-vector.12 (let ((x (copy-seq #*)) (y (copy-seq #*011))) (merge 'bit-vector x y #'<)) #*011) (deftest merge-bit-vector.13 (let ((x (copy-seq #*)) (y (list 0 1 1))) (merge 'bit-vector x y #'<)) #*011) (deftest merge-bit-vector.14 (let ((x nil) (y (vector 0 1 1))) (merge 'bit-vector y x #'<)) #*011) (deftest merge-bit-vector.15 (let ((x (copy-seq #*)) (y (list 0 1 1))) (merge 'bit-vector y x #'<)) #*011) (deftest merge-bit-vector.16 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit)) (y (copy-seq #*001))) (merge 'bit-vector x y #'<)) #*00000111) (deftest merge-bit-vector.17 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit)) (y (copy-seq #*001))) (merge 'bit-vector y x #'<)) #*00000111) (deftest merge-bit-vector.18 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector nil x #'<)) #*00011) (deftest merge-bit-vector.19 (let* ((x (make-array '(10) :initial-contents #*0001101010 :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector x nil #'<)) #*00011) ;;; Cons (which is a recognizable subtype of list) (deftest merge-cons.1 (merge 'cons (list 1 2 3) (list 4 5 6) #'<) (1 2 3 4 5 6)) ;;; Null, which is a recognizable subtype of list (deftest merge-null.1 (merge 'null nil nil #'<) nil) ;;; Vectors with length (deftest merge-vector-length.1 (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) #(1 2 3 4 5 6)) (deftest merge-bit-vector-length.1 (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) #*000111) ;;; Order of evaluation (deftest merge.order.1 (let ((i 0) a b c d) (values (merge (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) (list 2 5 6)) (progn (setf c (incf i)) (list 1 3 4)) (progn (setf d (incf i)) #'<)) i a b c d)) (1 2 3 4 5 6) 4 1 2 3 4) ;;; Tests of error situations (deftest merge.error.1 (handler-case (eval '(locally (declare (optimize (safety 3))) (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) (error () :caught)) :caught) (deftest merge.error.2 (classify-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.3 (classify-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<)) type-error) (deftest merge.error.4 (classify-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.5 (classify-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<)) type-error) (deftest merge.error.6 (classify-error (merge 'null (list 1 2 3) (list 4 5 6) #'<)) type-error) (deftest merge.error.7 (classify-error (merge)) program-error) (deftest merge.error.8 (classify-error (merge 'list)) program-error) (deftest merge.error.9 (classify-error (merge 'list (list 2 4 6))) program-error) (deftest merge.error.10 (classify-error (merge 'list (list 2 4 6) (list 1 3 5))) program-error) (deftest merge.error.11 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t)) program-error) (deftest merge.error.12 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key)) program-error) (deftest merge.error.13 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t :allow-other-keys nil)) program-error) (deftest merge.error.14 (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2)) program-error) (deftest merge.error.15 (classify-error (locally (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) t)) type-error) (deftest merge.error.16 (classify-error (merge 'list (list 1 2) (list 3 4) #'car)) program-error) (deftest merge.error.17 (classify-error (merge 'list (list 'a 'b) (list 3 4) #'max)) type-error) gcl-2.6.14/ansi-tests/packages-12.lsp0000644000175000017500000001473214360276512015612 0ustar cammcamm();-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Package test code, part 12 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unintern ;; Simple unintern of an internal symbol, package explicitly ;; given as a package object (deftest unintern.1 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H")) (i 0) x y) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern (progn (setf x (incf i)) sym) (progn (setf y (incf i)) p)) (eql i 2) (eql x 1) (eql y 2) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package taken from the *PACKAGES* ;; special variable (should this have unwind protect?) (deftest unintern.2 (progn (safely-delete-package "H") (prog1 (let ((*PACKAGE* (make-package "H"))) (declare (special *PACKAGE*)) (intern "FOO") (multiple-value-bind* (sym access) (find-symbol "FOO") (and (eqt access :internal) (unintern sym) (null (symbol-package sym)) (not (find-symbol "FOO"))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as string (deftest unintern.3 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym "H") (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as symbol (deftest unintern.4 (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym '#:|H|) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) ;; Simple unintern, package given as character (deftest unintern.5 (handler-case (progn (safely-delete-package "H") (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) (and (eqt access :internal) (unintern sym #\H) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) (error (c) c)) t) ;; Test more complex examples of unintern ;; Unintern an external symbol that is also inherited (deftest unintern.6 (handler-case (progn (safely-delete-package "H") (safely-delete-package "G") (make-package "G") (export (intern "FOO" "G") "G") (make-package "H" :use '("G")) (export (intern "FOO" "H") "H") ;; At this point, G:FOO is also an external ;; symbol of H. (multiple-value-bind* (sym1 access1) (find-symbol "FOO" "H") (and sym1 (eqt access1 :external) (equal "FOO" (symbol-name sym1)) (eqt (find-package "G") (symbol-package sym1)) (unintern sym1 "H") (multiple-value-bind* (sym2 access2) (find-symbol "FOO" "H") (and (eqt sym1 sym2) (eqt (symbol-package sym1) (find-package "G")) (eqt access2 :inherited)))))) (error (c) c)) t) ;; unintern a symbol that is shadowing another symbol (deftest unintern.7 (block failed (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G")) (ph (make-package "H" :use (list pg)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (export (intern "FOO" pg) pg) ;; At this point, H::FOO shadows G:FOO (multiple-value-bind* (sym1 access1) (find-symbol "FOO" ph) (and sym1 (eqt (symbol-package sym1) ph) (eqt access1 :internal) (equal (list sym1) (package-shadowing-symbols ph)) (unintern sym1 ph) (multiple-value-bind* (sym2 access2) (find-symbol "FOO" ph) (and (not (eqt sym1 sym2)) (eqt access2 :inherited) (null (symbol-package sym1)) (eqt (symbol-package sym2) pg))))))) t) ;; Error situation: when the symbol is uninterned, creates ;; a name conflict from two used packages (deftest unintern.8 (block failed (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (let* ((pg1 (make-package "G1")) (pg2 (make-package "G2")) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym1 (intern "FOO" pg1)) (gsym2 (intern "FOO" pg2))) (export gsym1 pg1) (export gsym2 pg2) (multiple-value-bind* (sym1 access1) (find-symbol "FOO" ph) (and (equal (list sym1) (package-shadowing-symbols ph)) (not (eqt sym1 gsym1)) (not (eqt sym1 gsym2)) (eqt (symbol-package sym1) ph) (eqt access1 :internal) (equal (symbol-name sym1) "FOO") (handler-case (progn (unintern sym1 ph) nil) (error (c) (format t "Properly threw an error: ~S~%" c) t))))))) t) ;; Now, inherit the same symbol through two intermediate ;; packages. No error should occur when the shadowing ;; is removed (deftest unintern.9 (block failed (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") (safely-delete-package "G3") (let* ((pg3 (make-package "G3")) (pg1 (make-package "G1" :use (list pg3))) (pg2 (make-package "G2" :use (list pg3))) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym (intern "FOO" pg3))) (export gsym pg3) (export gsym pg1) (export gsym pg2) (multiple-value-bind* (sym access) (find-symbol "FOO" ph) (and (equal (list sym) (package-shadowing-symbols ph)) (not (eqt sym gsym)) (equal (symbol-name sym) "FOO") (equal (symbol-package sym) ph) (eqt access :internal) (handler-case (and (unintern sym ph) (multiple-value-bind* (sym2 access2) (find-symbol "FOO" ph) (and (eqt gsym sym2) (eqt access2 :inherited)))) (error (c) c))))))) t) (deftest unintern.error.1 (classify-error (unintern)) program-error) (deftest unintern.error.2 (classify-error (unintern '#:x "CL-TEST" nil)) program-error) gcl-2.6.14/ansi-tests/function.lsp0000644000175000017500000000464414360276512015442 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 07:34:29 2002 ;;;; Contains: Tests for type FUNCTION and the special form FUNCTION (in-package :cl-test) ;;; ;;; Note! There are significant incompatibilities between CLTL1 and ANSI CL ;;; in the meaning of FUNCTION and FUNCTIONP. ;;; (deftest function.1 (typep nil 'function) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, symbols are no longer of type FUNCTION. (deftest function.2 (typep 'identity 'function) nil) (deftest function.3 (not-mv (typep #'identity 'function)) nil) (deftest function.4 (loop for x in *cl-symbol-names* for s = (find-symbol x "CL") for f = (and (fboundp s) (symbol-function s) (not (special-operator-p s)) (not (macro-function s)) (symbol-function s)) unless (or (null f) (typep f 'function)) collect x) nil) (deftest function.5 (typep '(setf car) 'function) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, lambda forms are no longer of type FUNCTION. (deftest function.6 (typep '(lambda (x) x) 'function) nil) (eval-when (eval compile) (ignore-errors (defun (setf function-7-accessor) (y x) (setf (car x) y) y))) (deftest function.7 (not-mv (typep #'(setf function-7-accessor) 'function)) nil) (deftest function.8 (not-mv (typep #'(lambda (x) x) 'function)) nil) (deftest function.9 (not-mv (typep (compile nil '(lambda (x) x)) 'function)) nil) ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. ;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION. (deftest function.10 (loop for x in *universe* when (and (or (numberp x) (characterp x) (symbolp x) (consp x) (typep x 'array)) (typep x 'function)) collect x) nil) (deftest function.11 (flet ((%f () nil)) (typep '%f 'function)) nil) (deftest function.12 (flet ((%f () nil)) (not-mv (typep #'%f 'function))) nil) (deftest function.13 (labels ((%f () nil)) (not-mv (typep #'%f 'function))) nil) ;;; "If name is a function name, the functional definition of that ;;; name is that established by the innermost lexically enclosing flet, ;;; labels, or macrolet form, if there is one." (page for FUNCTION, sec. 5.3) ;;; ^^^^^^^^ ;;;(deftest function.14 ;;; (macrolet ((%f () nil)) (not-mv (typep #'%f 'function))) ;;; nil) gcl-2.6.14/ansi-tests/reduce.lsp0000644000175000017500000002627414360276512015067 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 18 14:08:57 2002 ;;;; Contains: Tests for function REDUCE (in-package :cl-test) (deftest reduce-list.1 (reduce #'cons '(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.2 (reduce #'cons '(a b c d e f) :from-end t) (a b c d e . f)) (deftest reduce-list.3 (reduce #'cons '(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) (deftest reduce-list.4 (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) (deftest reduce-list.5 (reduce #'cons '(a b c d e f) :from-end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.6 (reduce #'cons '(a b c d e f) :from-end 17) (a b c d e . f)) (deftest reduce-list.7 (reduce #'cons '(a b c d e f) :end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.8 (reduce #'cons '(a b c d e f) :end 3) ((a . b) . c)) (deftest reduce-list.9 (reduce #'cons '(a b c d e f) :start 1 :end 4) ((b . c) . d)) (deftest reduce-list.10 (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t) (b c . d)) (deftest reduce-list.11 (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t :initial-value nil) (b c d)) (deftest reduce-list.12 (reduce 'cons '(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-list.13 (reduce #'+ nil) 0) (deftest reduce-list.14 (reduce #'+ '(1 2 3) :start 0 :end 0) 0) (deftest reduce-list.15 (reduce #'+ '(1 2 3) :key '1+) 9) (deftest reduce-list.16 (reduce #'cons '(1 2 3) :key '1+ :from-end t :initial-value nil) (2 3 4)) (deftest reduce-list.17 (reduce #'+ '(1 2 3 4 5 6 7) :key '1+ :start 2 :end 6) 22) ;;;;;;; (deftest reduce-array.1 (reduce #'cons #(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.2 (reduce #'cons #(a b c d e f) :from-end t) (a b c d e . f)) (deftest reduce-array.3 (reduce #'cons #(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) (deftest reduce-array.4 (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) (deftest reduce-array.5 (reduce #'cons #(a b c d e f) :from-end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.6 (reduce #'cons #(a b c d e f) :from-end 17) (a b c d e . f)) (deftest reduce-array.7 (reduce #'cons #(a b c d e f) :end nil) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.8 (reduce #'cons #(a b c d e f) :end 3) ((a . b) . c)) (deftest reduce-array.9 (reduce #'cons #(a b c d e f) :start 1 :end 4) ((b . c) . d)) (deftest reduce-array.10 (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t) (b c . d)) (deftest reduce-array.11 (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t :initial-value nil) (b c d)) (deftest reduce-array.12 (reduce 'cons #(a b c d e f)) (((((a . b) . c) . d) . e) . f)) (deftest reduce-array.13 (reduce #'+ #(1 2 3) :start 0 :end 0) 0) (deftest reduce-array.14 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a)) 10) (deftest reduce-array.15 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :end nil)) 10) (deftest reduce-array.16 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :from-end t)) 10) (deftest reduce-array.17 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :initial-value 1)) 11) (deftest reduce-array.18 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :initial-value 1 :start 2)) 8) (deftest reduce-array.19 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) :fill-pointer 4))) (reduce #'+ a :end 3)) 6) ;;;;;;;; (deftest reduce.error.1 (classify-error (reduce 'cons 'a)) type-error) (deftest reduce.error.2 (classify-error (reduce)) program-error) (deftest reduce.error.3 (classify-error (reduce #'list nil :start)) program-error) (deftest reduce.error.4 (classify-error (reduce #'list nil 'bad t)) program-error) (deftest reduce.error.5 (classify-error (reduce #'list nil 'bad t :allow-other-keys nil)) program-error) (deftest reduce.error.6 (classify-error (reduce #'list nil 1 2)) program-error) (deftest reduce.error.7 (classify-error (locally (reduce 'cons 'a) t)) type-error) (deftest reduce.error.8 (classify-error (reduce #'identity '(a b c))) program-error) (deftest reduce.error.9 (classify-error (reduce #'cons '(a b c) :key #'cons)) program-error) (deftest reduce.error.10 (classify-error (reduce #'cons '(a b c) :key #'car)) type-error) ;;;;;;;; (deftest reduce-string.1 (reduce #'cons "abcdef") (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.2 (reduce #'cons "abcdef" :from-end t) (#\a #\b #\c #\d #\e . #\f)) (deftest reduce-string.3 (reduce #'cons "abcdef" :initial-value 'z) ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.4 (reduce #'cons "abcdef" :from-end t :initial-value 'g) (#\a #\b #\c #\d #\e #\f . g)) (deftest reduce-string.5 (reduce #'cons "abcdef" :from-end nil) (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.6 (reduce #'cons "abcdef" :from-end 17) (#\a #\b #\c #\d #\e . #\f)) (deftest reduce-string.7 (reduce #'cons "abcdef" :end nil) (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.8 (reduce #'cons "abcdef" :end 3) ((#\a . #\b) . #\c)) (deftest reduce-string.9 (reduce #'cons "abcdef" :start 1 :end 4) ((#\b . #\c) . #\d)) (deftest reduce-string.10 (reduce #'cons "abcdef" :start 1 :end 4 :from-end t) (#\b #\c . #\d)) (deftest reduce-string.11 (reduce #'cons "abcdef" :start 1 :end 4 :from-end t :initial-value nil) (#\b #\c #\d)) (deftest reduce-string.12 (reduce 'cons "abcdef") (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) (deftest reduce-string.13 (reduce #'+ "abc" :start 0 :end 0) 0) (deftest reduce-string.14 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil) 'string)) "fedcba") (deftest reduce-string.15 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil :start 1) 'string)) "fedcb") (deftest reduce-string.16 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil :initial-value nil) 'string)) "fedcba") (deftest reduce-string.17 (let ((s (make-array '(8) :initial-contents "abcdefgh" :fill-pointer 6 :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 :initial-value nil) 'string)) "dcba") ;;;;;;;; (deftest reduce-bitstring.1 (reduce #'cons #*001101) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.2 (reduce #'cons #*001101 :from-end t) (0 0 1 1 0 . 1)) (deftest reduce-bitstring.3 (reduce #'cons #*001101 :initial-value 'z) ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.4 (reduce #'cons #*001101 :from-end t :initial-value 'g) (0 0 1 1 0 1 . g)) (deftest reduce-bitstring.5 (reduce #'cons #*001101 :from-end nil) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.6 (reduce #'cons #*001101 :from-end 17) (0 0 1 1 0 . 1)) (deftest reduce-bitstring.7 (reduce #'cons #*001101 :end nil) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.8 (reduce #'cons #*001101 :end 3) ((0 . 0) . 1)) (deftest reduce-bitstring.9 (reduce #'cons #*001101 :start 1 :end 4) ((0 . 1) . 1)) (deftest reduce-bitstring.10 (reduce #'cons #*001101 :start 1 :end 4 :from-end t) (0 1 . 1)) (deftest reduce-bitstring.11 (reduce #'cons #*001101 :start 1 :end 4 :from-end t :initial-value nil) (0 1 1)) (deftest reduce-bitstring.12 (reduce 'cons #*001101) (((((0 . 0) . 1) . 1) . 0) . 1)) (deftest reduce-bitstring.13 (reduce #'+ #(1 1 1) :start 0 :end 0) 0) (deftest reduce-bitstring.14 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s)) 3) (deftest reduce-bitstring.15 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 3)) 2) (deftest reduce-bitstring.16 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 3 :initial-value 10)) 12) (deftest reduce-bitstring.17 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :end nil)) 3) (deftest reduce-bitstring.18 (let ((s (make-array '(8) :initial-contents '(1 1 1 1 1 1 1 1) :fill-pointer 6 :element-type 'bit))) (reduce #'+ s :start 2 :end 4)) 2) ;;; Order of evaluation tests (deftest reduce.order.1 (let ((i 0) x y) (values (reduce (progn (setf x (incf i)) #'cons) (progn (setf y (incf i)) '(a b c))) i x y)) ((a . b) . c) 2 1 2) (deftest reduce.order.2 (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) '(a b c d e f)) :from-end (progn (setf c (incf i)) t) :initial-value (progn (setf d (incf i)) 'nil) :start (progn (setf e (incf i)) 1) :end (progn (setf f (incf i)) 4) :key (progn (setf g (incf i)) #'identity) ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) (deftest reduce.order.3 (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) (progn (setf b (incf i)) '(a b c d e f)) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) 4) :start (progn (setf e (incf i)) 1) :initial-value (progn (setf f (incf i)) 'nil) :from-end (progn (setf g (incf i)) t) ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) ;;; Keyword tests (deftest reduce.allow-other-keys.1 (reduce #'+ '(1 2 3) :allow-other-keys t) 6) (deftest reduce.allow-other-keys.2 (reduce #'+ '(1 2 3) :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.3 (reduce #'+ '(1 2 3) :bad t :allow-other-keys t) 6) (deftest reduce.allow-other-keys.4 (reduce #'+ '(1 2 3) :allow-other-keys t :bad t) 6) (deftest reduce.allow-other-keys.5 (reduce #'+ '(1 2 3) :allow-other-keys t :allow-other-keys nil :bad t) 6) (deftest reduce.allow-other-keys.6 (reduce #'+ '(1 2 3) :allow-other-keys t :bad t :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.7 (reduce #'+ '(1 2 3) :bad t :allow-other-keys t :allow-other-keys nil) 6) (deftest reduce.allow-other-keys.8 (reduce #'cons '(1 2 3) :allow-other-keys t :from-end t :bad t :initial-value nil) (1 2 3)) (deftest reduce.keywords.9 (reduce #'cons '(1 2 3) :from-end t :from-end nil :initial-value nil :initial-value 'a) (1 2 3)) gcl-2.6.14/ansi-tests/cons-test-14.lsp0000644000175000017500000001511514360276512015751 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:39:29 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 14 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member-if (deftest member-if.1 (member-if #'listp nil) nil) (deftest member-if.2 (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) (a 3 4)) (deftest member-if.3 (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) (11 73 11)) (deftest member-if.4 (let ((test-inputs `(1 a 11.3121 11.31s3 1.123f5 -1 0 13.13122d34 581.131e-10 (a b c . d) ,(make-array '(10)) "ancadas" #\w))) (notnot-mv (every #'(lambda (x) (let ((result (catch-type-error (member-if #'listp x)))) (or (eqt result 'type-error) (progn (format t "~%On ~S: returned ~%~S" x result) nil)))) test-inputs))) t) (deftest member-if.5 (member-if #'identity '(1 2 3 4 5) :key #'evenp) (2 3 4 5)) ;;; Order of argument tests (deftest member-if.order.1 (let ((i 0) x y) (values (member-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) (deftest member-if.order.2 (let ((i 0) x y z w) (values (member-if (progn (setf x (incf i)) #'identity) (progn (setf y (incf i)) '(nil nil a b nil c d)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (a b nil c d) 4 1 2 3 4) ;;; Keyword tests (deftest member-if.keywords.1 (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) (2 3 4 5)) (deftest member-if.allow-other-keys.2 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) (2 3 4 5)) (deftest member-if.allow-other-keys.3 (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) (2 3 4 5)) (deftest member-if.allow-other-keys.4 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) (2 3 4 5)) (deftest member-if.allow-other-keys.5 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) (2 3 4 5)) (deftest member-if.allow-other-keys.6 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil) (2 3 4 5)) (deftest member-if.allow-other-keys.7 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; member-if-not (deftest member-if-not.1 (member-if-not #'listp nil) nil) (deftest member-if-not.2 (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) (1 2 a 3 4)) (deftest member-if-not.3 (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) (11 73 11)) (deftest member-if-not.4 (let ((test-inputs `(1 a 11.3121 11.31s3 1.123f5 -1 0 13.13122d34 581.131e-10 ((a) (b) (c) . d) ,(make-array '(10)) "ancadas" #\w))) (not (every #'(lambda (x) (let ((result (catch-type-error (member-if-not #'listp x)))) (or (eqt result 'type-error) (progn (format t "~%On x = ~S, returns: ~%~S" x result) nil)))) test-inputs))) nil) (deftest member-if-not.5 (member-if-not #'not '(1 2 3 4 5) :key #'evenp) (2 3 4 5)) ;;; Order of evaluation tests (deftest member-if-not.order.1 (let ((i 0) x y) (values (member-if-not (progn (setf x (incf i)) #'not) (progn (setf y (incf i)) '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) (deftest member-if-not.order.2 (let ((i 0) x y z w) (values (member-if-not (progn (setf x (incf i)) #'not) (progn (setf y (incf i)) '(nil nil a b nil c d)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf w (incf i)) #'not)) i x y z w)) (a b nil c d) 4 1 2 3 4) ;;; Keyword tests (deftest member-if-not.keywords.1 (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) (2 3 4 5)) (deftest member-if-not.allow-other-keys.2 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.3 (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.4 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) (2 3 4 5)) (deftest member-if-not.allow-other-keys.5 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) (2 3 4 5)) (deftest member-if-not.allow-other-keys.6 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;; Error cases (deftest member-if.error.1 (classify-error (member-if #'identity 'a)) type-error) (deftest member-if.error.2 (classify-error (member-if)) program-error) (deftest member-if.error.3 (classify-error (member-if #'null)) program-error) (deftest member-if.error.4 (classify-error (member-if #'null '(a b c) :bad t)) program-error) (deftest member-if.error.5 (classify-error (member-if #'null '(a b c) :bad t :allow-other-keys nil)) program-error) (deftest member-if.error.6 (classify-error (member-if #'null '(a b c) :key)) program-error) (deftest member-if.error.7 (classify-error (member-if #'null '(a b c) 1 2)) program-error) (deftest member-if.error.8 (classify-error (locally (member-if #'identity 'a) t)) type-error) (deftest member-if.error.9 (classify-error (member-if #'cons '(a b c))) program-error) (deftest member-if.error.10 (classify-error (member-if #'identity '(a b c) :key #'cons)) program-error) (deftest member-if-not.error.1 (classify-error (member-if-not #'identity 'a)) type-error) (deftest member-if-not.error.2 (classify-error (member-if-not)) program-error) (deftest member-if-not.error.3 (classify-error (member-if-not #'null)) program-error) (deftest member-if-not.error.4 (classify-error (member-if-not #'null '(a b c) :bad t)) program-error) (deftest member-if-not.error.5 (classify-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil)) program-error) (deftest member-if-not.error.6 (classify-error (member-if-not #'null '(a b c) :key)) program-error) (deftest member-if-not.error.7 (classify-error (member-if-not #'null '(a b c) 1 2)) program-error) (deftest member-if-not.error.8 (classify-error (locally (member-if-not #'identity 'a) t)) type-error) (deftest member-if-not.error.9 (classify-error (member-if-not #'cons '(a b c))) program-error) (deftest member-if-not.error.10 (classify-error (member-if-not #'identity '(a b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/count-if.lsp0000644000175000017500000003130314360276512015331 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Aug 20 08:01:30 2002 ;;;; Contains: Tests for COUNT-IF (in-package :cl-test) (deftest count-if-list.1 (count-if #'identity '(a b nil c d nil e)) 5) (deftest count-if-list.2 (count-if #'not '(a b nil c d nil e)) 2) (deftest count-if-list.3 (count-if #'(lambda (x) (break)) nil) 0) (deftest count-if-list.4 (count-if #'identity '(a b nil c d nil e) :key #'identity) 5) (deftest count-if-list.5 (count-if 'identity '(a b nil c d nil e) :key #'identity) 5) (deftest count-if-list.6 (count-if #'identity '(a b nil c d nil e) :key 'identity) 5) (deftest count-if-list.8 (count-if #'identity '(a b nil c d nil e) :key 'not) 2) (deftest count-if-list.9 (count-if #'evenp '(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-list.10 (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-list.11 (let ((c 0)) (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-list.12 (let ((c 0)) (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-list.13 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-list.14 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-list.15 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-list.16 (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; tests on vectors (deftest count-if-vector.1 (count-if #'identity #(a b nil c d nil e)) 5) (deftest count-if-vector.2 (count-if #'not #(a b nil c d nil e)) 2) (deftest count-if-vector.3 (count-if #'(lambda (x) (break)) #()) 0) (deftest count-if-vector.4 (count-if #'identity #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-vector.5 (count-if 'identity #(a b nil c d nil e) :key #'identity) 5) (deftest count-if-vector.6 (count-if #'identity #(a b nil c d nil e) :key 'identity) 5) (deftest count-if-vector.8 (count-if #'identity #(a b nil c d nil e) :key 'not) 2) (deftest count-if-vector.9 (count-if #'evenp #(1 2 3 4 4 1 8 10 1)) 5) (deftest count-if-vector.10 (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'1+) 4) (deftest count-if-vector.11 (let ((c 0)) (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-vector.12 (let ((c 0)) (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-vector.13 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-vector.14 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-vector.15 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-vector.16 (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-nonsimple-vector.1 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 5) (deftest count-if-nonsimple-vector.2 (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t)) 2) (deftest count-if-nonsimple-vector.3 (count-if #'(lambda (x) (break)) (make-array 0 :fill-pointer t :adjustable t)) 0) (deftest count-if-nonsimple-vector.4 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-nonsimple-vector.5 (count-if 'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key #'identity) 5) (deftest count-if-nonsimple-vector.6 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'identity) 5) (deftest count-if-nonsimple-vector.8 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) :fill-pointer t :adjustable t) :key 'not) 2) (deftest count-if-nonsimple-vector.9 (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t)) 5) (deftest count-if-nonsimple-vector.10 (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'1+) 4) (deftest count-if-nonsimple-vector.11 (let ((c 0)) (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) :fill-pointer t :adjustable t) :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-nonsimple-vector.12 (let ((c 0)) (count-if #'evenp (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) :fill-pointer t :adjustable t) :from-end t :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-nonsimple-vector.13 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-nonsimple-vector.14 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-nonsimple-vector.15 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-nonsimple-vector.16 (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) 1) (deftest count-if-nonsimple-vector.17 (flet ((%f (x) (eqt x 'a))) (let ((s (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer 6))) (values (count-if #'%f s) (count-if #'%f s :end nil) (count-if #'%f s :end 4) (count-if #'%f s :start 1) (count-if #'%f s :start 1 :end 4) (count-if #'%f s :start 1 :end 4 :from-end t)))) 2 2 1 1 0 0) ;;; tests on bit-vectors (deftest count-if-bit-vector.1 (count-if #'evenp #*001011101101) 5) (deftest count-if-bit-vector.2 (count-if #'identity #*001011101101) 12) (deftest count-if-bit-vector.3 (count-if #'(lambda (x) (break)) #*) 0) (deftest count-if-bit-vector.4 (count-if #'identity #*001011101101 :key #'zerop) 5) (deftest count-if-bit-vector.5 (count-if 'identity #*001011101101 :key #'zerop) 5) (deftest count-if-bit-vector.6 (count-if #'identity #*001011101101 :key 'zerop) 5) (deftest count-if-bit-vector.8 (count-if #'identity #*001011101101 :key 'oddp) 7) (deftest count-if-bit-vector.10 (count-if #'evenp #*001011101101 :key #'1+) 7) (deftest count-if-bit-vector.11 (let ((c 0)) (count-if #'evenp #*001011101101 :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-bit-vector.12 (let ((c 0)) (count-if #'evenp #*001011101101 :from-end t :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-bit-vector.13 (count-if #'zerop #*0111011011100 :start 2) 4) (deftest count-if-bit-vector.14 (count-if #'zerop #*0111011011100 :end 7) 2) (deftest count-if-bit-vector.15 (count-if #'zerop #*0111011011100 :end 7 :start 2) 1) (deftest count-if-bit-vector.16 (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 1) (deftest count-if-bit-vector.17 (let ((s (make-array '(10) :initial-contents '(0 0 1 0 1 0 0 1 1 0) :element-type 'bit :fill-pointer 6))) (values (count-if #'zerop s) (count-if #'zerop s :end nil) (count-if #'zerop s :end 4) (count-if #'zerop s :start 5) (count-if #'zerop s :start 1 :end 4))) 4 4 3 1 2) ;;; tests on strings (deftest count-if-string.1 (count-if #'(lambda (x) (eql x #\0)) "001011101101") 5) (deftest count-if-string.2 (count-if #'identity "001011101101") 12) (deftest count-if-string.3 (count-if #'(lambda (x) (break)) "") 0) (deftest count-if-string.4 (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 5) (deftest count-if-string.5 (count-if 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) 5) (deftest count-if-string.6 (count-if #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) 5) (deftest count-if-string.8 (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) 7) (deftest count-if-string.11 (let ((c 0)) (count-if #'evenp "001011101101" :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-string.12 (let ((c 0)) (count-if #'evenp "001011101101" :from-end t :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-string.13 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) 4) (deftest count-if-string.14 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 2) (deftest count-if-string.15 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 1) (deftest count-if-string.16 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2 :from-end t) 1) (deftest count-if-string.17 (let ((s (make-array '(10) :initial-contents "00a0aa0a0a" :element-type 'character :fill-pointer 6))) (values (count-if #'digit-char-p s) (count-if #'digit-char-p s :end nil) (count-if #'digit-char-p s :start 1) (count-if #'digit-char-p s :end 2) (count-if #'digit-char-p s :start 1 :end 2))) 3 3 2 2 1) ;;; Argument order tests (deftest count-if.order.1 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :start (progn (setf c3 (incf i)) 0) :end (progn (setf c4 (incf i)) 3) :key (progn (setf c5 (incf i)) #'identity) :from-end (progn (setf c6 (incf i)) nil) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) (deftest count-if.order.2 (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) (progn (setf c2 (incf i)) '(a nil b c nil d e)) :from-end (progn (setf c3 (incf i)) nil) :key (progn (setf c4 (incf i)) #'identity) :end (progn (setf c5 (incf i)) 3) :start (progn (setf c6 (incf i)) 0) ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) ;;; Keyword tests (deftest count-if.allow-other-keys.1 (count-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) 2) (deftest count-if.allow-other-keys.2 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if.allow-other-keys.3 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys t :allow-other-keys nil :bad t) 2) (deftest count-if.keywords.4 (count-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) 2) (deftest count-if.allow-other-keys.5 (count-if #'evenp '(1 2 3 4 5) :allow-other-keys nil) 2) ;;; Error tests (deftest count-if.error.1 (classify-error (count-if #'identity 1)) type-error) (deftest count-if.error.2 (classify-error (count-if #'identity 'a)) type-error) (deftest count-if.error.3 (classify-error (count-if #'identity #\a)) type-error) (deftest count-if.error.4 (classify-error (count-if)) program-error) (deftest count-if.error.5 (classify-error (count-if #'null)) program-error) (deftest count-if.error.6 (classify-error (count-if #'null nil :bad t)) program-error) (deftest count-if.error.7 (classify-error (count-if #'null nil :bad t :allow-other-keys nil)) program-error) (deftest count-if.error.8 (classify-error (count-if #'null nil :key)) program-error) (deftest count-if.error.9 (classify-error (count-if #'null nil 3 3)) program-error) ;;; Only leftmost :allow-other-keys argument matters (deftest count-if.error.10 (classify-error (count-if #'null nil :bad t :allow-other-keys nil :allow-other-keys t)) program-error) (deftest count-if.error.11 (classify-error (locally (count-if #'identity 1) t)) type-error) (deftest count-if.error.12 (classify-error (count-if #'cons '(a b c))) program-error) (deftest count-if.error.13 (classify-error (count-if #'car '(a b c))) type-error) (deftest count-if.error.14 (classify-error (count-if #'identity '(a b c) :key #'cdr)) type-error) (deftest count-if.error.15 (classify-error (count-if #'identity '(a b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/load-structures.lsp0000644000175000017500000000021114360276512016737 0ustar cammcamm;;; Tests of structures (load "structure-00.lsp") (load "structures-01.lsp") (load "structures-02.lsp") #-ecl (load "structures-03.lsp")gcl-2.6.14/ansi-tests/constantly.lsp0000644000175000017500000000150614360276512016005 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Oct 6 19:47:16 2002 ;;;; Contains: Tests for CONSTANTLY (in-package :cl-test) (deftest constantly.1 (let ((fn (cl:constantly 10)) (x nil)) (loop for i from 0 to (min 256 (1- call-arguments-limit)) always (prog1 (eql (apply fn x) 10) (push 'a x)))) t) (deftest constantly.2 (notnot-mv (cl:constantly 1)) t) (deftest constantly.3 (let ((i 0)) (let ((fn (cl:constantly (progn (incf i) 'a)))) (values i (mapcar fn '(1 2 3 4)) i))) 1 (a a a a) 1) (deftest constantly.error.1 (classify-error (cl:constantly)) program-error) ;;; The next test fails in CMUCL, which has non-conformantly extended ;;; the syntax of constantly. (deftest constantly.error.2 (classify-error (cl:constantly 1 1)) program-error) gcl-2.6.14/ansi-tests/packages-07.lsp0000644000175000017500000001366514360276512015622 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:01:20 1998 ;;;; Contains: Package test code, part 07 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; shadow (deftest shadow.1 (prog1 (progn (safely-delete-package "TEST5") (safely-delete-package "TEST4") (handler-case (let* ((p1 (prog1 (make-package "TEST4") (export (intern "A" "TEST4") "TEST4"))) (p2 (make-package "TEST5" :use '("TEST4"))) (r1 (package-shadowing-symbols "TEST4")) (r2 (package-shadowing-symbols "TEST5"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" p2))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3)))))) (error (c) c))) (safely-delete-package "TEST5") (safely-delete-package "TEST4")) ("TEST4" "TEST5" nil nil "A" "TEST4" :external "A" "TEST4" :inherited t "A" "TEST5" :internal)) (deftest shadow.2 (progn (safely-delete-package "H") (safely-delete-package "G") (handler-case (let* ((p1 (prog1 (make-package "G") (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" "H"))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (prog1 (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3) (safely-delete-package p2) (safely-delete-package p1) )))))) (error (c) (safely-delete-package "H") (safely-delete-package "G") c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t "A" "H" :internal)) ;; shadow in which the package is given ;; by a character (deftest shadow.3 (progn (safely-delete-package "H") (safely-delete-package "G") (handler-case (let* ((p1 (prog1 (make-package "G") (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) (find-symbol "A" p1) (multiple-value-bind* (s2 kind2) (find-symbol "A" p2) (let ((r3 (shadow "A" #\H))) (multiple-value-bind* (s3 kind3) (find-symbol "A" p2) (prog1 (list (package-name p1) (package-name p2) r1 r2 (symbol-name s1) (package-name (symbol-package s1)) kind1 (symbol-name s2) (package-name (symbol-package s2)) kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) kind3) (safely-delete-package p2) (safely-delete-package p1) )))))) (error (c) (safely-delete-package "H") (safely-delete-package "G") c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t "A" "H" :internal)) ;; shadow on an existing internal symbol returns the existing symbol (deftest shadow.4 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G) (let ((s1 (intern "X" :G))) (shadow "X" :G) (multiple-value-bind* (s2 kind) (find-symbol "X" :G) (list (eqt s1 s2) (symbol-name s2) (package-name (symbol-package s2)) kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) ;; shadow of an existing shadowed symbol returns the symbol (deftest shadow.5 (prog1 (handler-case (progn (safely-delete-package :H) (safely-delete-package :G) (make-package :G) (export (intern "X" :G) :G) (make-package :H :use '("G")) (shadow "X" :H) (multiple-value-bind* (s1 kind1) (find-symbol "X" :H) (shadow "X" :H) (multiple-value-bind* (s2 kind2) (find-symbol "X" :H) (list (eqt s1 s2) kind1 kind2)))) (error (c) c)) (safely-delete-package :H) (safely-delete-package :G)) (t :internal :internal)) ;; Shadow several names simultaneously (deftest shadow.6 (prog1 (handler-case (progn (safely-delete-package :G) (make-package :G) (shadow '("X" "Y" |Z|) :G) (let ((results (append (multiple-value-list (find-symbol "X" :G)) (multiple-value-list (find-symbol "Y" :G)) (multiple-value-list (find-symbol "Z" :G)) nil))) (list (symbol-name (first results)) (second results) (symbol-name (third results)) (fourth results) (symbol-name (fifth results)) (sixth results) (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) ("X" :internal "Y" :internal "Z" :internal 3)) ;; Same, but shadow character string designators (deftest shadow.7 (prog1 (handler-case (let ((i 0) x y) (safely-delete-package :G) (make-package :G) (shadow (progn (setf x (incf i)) '(#\X #\Y)) (progn (setf y (incf i)) :G)) (let ((results (append (multiple-value-list (find-symbol "X" :G)) (multiple-value-list (find-symbol "Y" :G)) nil))) (list i x y (symbol-name (first results)) (second results) (symbol-name (third results)) (fourth results) (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) (2 1 2 "X" :internal "Y" :internal 2)) (deftest shadow.error.1 (classify-error (shadow)) program-error) (deftest shadow.error.2 (classify-error (shadow "X" "CL-USER" nil)) program-error) gcl-2.6.14/ansi-tests/truename.lsp0000644000175000017500000000524614360276512015434 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 6 05:32:37 2004 ;;;; Contains: Tests of TRUENAME (in-package :cl-test) (deftest truename.1 (let* ((pn #p"truename.lsp") (tn (truename pn))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )) t nil t t) (deftest truename.2 (let* ((name "truename.lsp") (pn (pathname name)) (tn (truename name))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )) t nil t t) (deftest truename.3 (let* ((pn #p"truename.lsp")) (with-open-file (s pn :direction :input) (let ((tn (truename s))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )))) t nil t t) (deftest truename.4 (let* ((pn #p"truename.lsp")) (let ((s (open pn :direction :input))) (close s) (let ((tn (truename s))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) (equalt (pathname-name pn) (pathname-name tn)) (equalt (pathname-type pn) (pathname-type tn)) )))) t nil t t) (deftest truename.5 (let* ((lpn "CLTEST:foo.txt") (pn (translate-logical-pathname lpn))) (unless (probe-file lpn) (with-open-file (s lpn :direction :output) (format s "Stuff~%"))) (let ((tn (truename lpn))) (values (notnot (pathnamep pn)) (if (equalt (pathname-name pn) (pathname-name tn)) t (list (pathname-name pn) (pathname-name tn))) (if (equalt (pathname-type pn) (pathname-type tn)) t (list (pathname-type pn) (pathname-type tn))) ))) t t t) ;;; Specialized string tests (deftest truename.6 (do-special-strings (s "truename.lsp" nil) (assert (equalp (truename s) (truename "truename.lsp")))) nil) ;;; Error tests (deftest truename.error.1 (signals-error (truename) program-error) t) (deftest truename.error.2 (signals-error (truename "truename.lsp" nil) program-error) t) (deftest truename.error.3 (signals-error-always (truename "nonexistent") file-error) t t) (deftest truename.error.4 (signals-error-always (truename #p"nonexistent") file-error) t t) (deftest truename.error.5 (signals-error-always (truename (logical-pathname "CLTESTROOT:NONEXISTENT")) file-error) t t) (deftest truename.error.6 (signals-error-always (let ((pn (make-pathname :name :wild :defaults *default-pathname-defaults*))) (truename pn)) file-error) t t) gcl-2.6.14/ansi-tests/read-line.lsp0000644000175000017500000000453114360276512015450 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 20:53:59 2004 ;;;; Contains: Tests of READ-LINE (in-package :cl-test) (deftest read-line.1 (with-input-from-string (*standard-input* " abcd ") (let ((vals (multiple-value-list (read-line)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) " abcd " t) (deftest read-line.2 (with-input-from-string (*standard-input* (string #\Newline)) (read-line)) "" nil) (deftest read-line.3 (with-input-from-string (s (concatenate 'string "abc" (string #\Newline))) (read-line s)) "abc" nil) (deftest read-line.4 (with-input-from-string (s "") (let ((vals (multiple-value-list (read-line s nil)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) nil t) (deftest read-line.5 (with-input-from-string (s "") (let ((vals (multiple-value-list (read-line s nil 'foo)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) foo t) (deftest read-line.6 (with-input-from-string (s " abcd ") (let ((vals (multiple-value-list (read-line s t nil t)))) (assert (= (length vals) 2)) (values (first vals) (notnot (second vals))))) " abcd " t) (deftest read-line.7 (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream is *standard-output*))) (let ((vals (multiple-value-list (read-line t)))) (assert (= (length vals) 2)) (assert (second vals)) (first vals)))) "abc") (deftest read-line.8 (with-input-from-string (*standard-input* "abc") (let ((vals (multiple-value-list (read-line nil)))) (assert (= (length vals) 2)) (assert (second vals)) (first vals))) "abc") ;;; Error tests (deftest read-line.error.1 (signals-error (with-input-from-string (s (concatenate 'string "abc" (string #\Newline))) (read-line s t nil nil nil)) program-error) t) (deftest read-line.error.2 (signals-error-always (with-input-from-string (s "") (read-line s)) end-of-file) t t) (deftest read-line.error.3 (signals-error-always (with-input-from-string (*standard-input* "") (read-line)) end-of-file) t t) (deftest read-line.error.4 (signals-error-always (with-input-from-string (s "") (read-line s t)) end-of-file) t t) gcl-2.6.14/ansi-tests/eval-and-compile.lsp0000644000175000017500000000114114360276512016717 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 21 22:52:19 2002 ;;;; Contains: Overall tests for section 3, 'Evaluation and Compilation' (in-package :cl-test) (defparameter *eval-and-compile-fns* '(compile eval macroexpand macroexpand-1 proclaim special-operator-p constantp)) (deftest eval-and-compile-fns (remove-if #'fboundp *eval-and-compile-fns*) nil) (defparameter *eval-and-compile-macros* '(lambda define-compiler-macro defmacro define-symbol-macro declaim)) (deftest eval-and-compile-macros (remove-if #'macro-function *eval-and-compile-macros*) nil) gcl-2.6.14/ansi-tests/enough-namestring.lsp0000644000175000017500000000440514360276512017242 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 12 06:23:50 2004 ;;;; Contains: Tests of ENOUGH-NAMESTRING (in-package :cl-test) (deftest enough-namestring.1 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp"))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.2 (do-special-strings (s "enough-namestring.lsp" nil) (let ((ns (enough-namestring s))) (assert (stringp ns)) (assert (string= (enough-namestring ns) ns)))) nil) (deftest enough-namestring.3 (let* ((name "enough-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (enough-namestring pn)) (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.4 (let* ((name "enough-namestring.lsp") (pn (merge-pathnames (pathname name))) (name2 (with-open-file (s pn :direction :input) (enough-namestring s))) (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.5 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" *default-pathname-defaults*))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.6 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" (namestring *default-pathname-defaults*)))) (s (first vals))) (if (and (null (cdr vals)) (stringp s) (equal (enough-namestring s) s)) :good vals)) :good) (deftest enough-namestring.7 (do-special-strings (s (namestring *default-pathname-defaults*) nil) (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" s))) (s2 (first vals))) (assert (null (cdr vals))) (assert (stringp s2)) (assert (equal (enough-namestring s2) s2)))) nil) ;;; Error tests (deftest enough-namestring.error.1 (signals-error (enough-namestring) program-error) t) (deftest enough-namestring.error.2 (signals-error (enough-namestring "enough-namestring.lsp" *default-pathname-defaults* nil) program-error) t) gcl-2.6.14/ansi-tests/make-string.lsp0000644000175000017500000000715714360276512016040 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 5 12:32:20 2002 ;;;; Contains: Tests for MAKE-STRING (in-package :cl-test) (deftest make-string.1 (let ((s (make-string 10))) (and (stringp s) ;; (string-all-the-same s) (eqlt (length s) 10) )) t) (deftest make-string.2 (let ((s (make-string 10 :initial-element #\a))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.3 (let ((s (make-string 10 :initial-element #\a :element-type 'character))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.4 (let ((s (make-string 10 :initial-element #\a :element-type 'standard-char))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.5 (let ((s (make-string 10 :initial-element #\a :element-type 'base-char))) (and (stringp s) (eql (length s) 10) s)) "aaaaaaaaaa") (deftest make-string.6 (make-string 0) "") (deftest make-string.7 (let ((s (make-string 10 :element-type 'character))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) (deftest make-string.8 (let ((s (make-string 10 :element-type 'standard-char))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) (deftest make-string.9 (let ((s (make-string 10 :element-type 'base-char))) (and (stringp s) (eqlt (length s) 10) #| (string-all-the-same s) |# )) t) ;;; Keyword tests ; (deftest make-string.allow-other-keys.1 (make-string 5 :allow-other-keys t :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.2 (make-string 5 :initial-element #\a :allow-other-keys t) "aaaaa") (deftest make-string.allow-other-keys.3 (make-string 5 :initial-element #\a :allow-other-keys t :bad t) "aaaaa") (deftest make-string.allow-other-keys.4 (make-string 5 :bad t :allow-other-keys t :allow-other-keys nil :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.5 (make-string 5 :allow-other-keys t :bad t :allow-other-keys nil :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.6 (make-string 5 :allow-other-keys t :allow-other-keys nil :bad nil :initial-element #\a) "aaaaa") (deftest make-string.keywords.7 (make-string 5 :initial-element #\a :initial-element #\b) "aaaaa") ;; Error cases (deftest make-string.error.1 (classify-error (make-string)) program-error) (deftest make-string.error.2 (classify-error (make-string 10 :bad t)) program-error) (deftest make-string.error.3 (classify-error (make-string 10 :bad t :allow-other-keys nil)) program-error) (deftest make-string.error.4 (classify-error (make-string 10 :initial-element)) program-error) (deftest make-string.error.5 (classify-error (make-string 10 1 1)) program-error) (deftest make-string.error.6 (classify-error (make-string 10 :element-type)) program-error) ;;; Order of evaluation (deftest make-string.order.1 (let ((i 0) a b) (values (make-string (progn (setf a (incf i)) 4) :initial-element (progn (setf b (incf i)) #\a)) i a b)) "aaaa" 2 1 2) (deftest make-string.order.2 (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) :initial-element (progn (setf b (incf i)) #\a) :element-type (progn (setf c (incf i)) 'base-char)) i a b c)) "aaaa" 3 1 2 3) (deftest make-string.order.3 (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) :element-type (progn (setf b (incf i)) 'base-char) :initial-element (progn (setf c (incf i)) #\a)) i a b c)) "aaaa" 3 1 2 3) gcl-2.6.14/ansi-tests/substitute-if-not.lsp0000644000175000017500000006211314360276512017215 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Aug 31 18:17:09 2002 ;;;; Contains: Tests for SUBSTITUTE-IF-NOT (in-package :cl-test) (deftest substitute-if-not-list.1 (let ((x '())) (values (substitute-if-not 'b #'null x) x)) nil nil) (deftest substitute-if-not-list.2 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.3 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.4 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.5 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) (b b a c) (a b a c)) (deftest substitute-if-not-list.6 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.7 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.8 (let ((x '())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) nil nil) (deftest substitute-if-not-list.9 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.10 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.11 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) (b b b c) (a b a c)) (deftest substitute-if-not-list.12 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) (a b b c) (a b a c)) (deftest substitute-if-not-list.13 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.14 (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) (a b a c) (a b a c)) (deftest substitute-if-not-list.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list (- j i) :initial-element 'x) (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (and (equal orig x) (equal y (nconc (make-list i :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-list.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig '(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equal orig x) (equal y (nconc (make-list (- j c) :initial-element 'a) (make-list c :initial-element 'x) (make-list (- 10 j) :initial-element 'a)))))))) t) ;;; Tests on vectors (deftest substitute-if-not-vector.1 (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) #() #()) (deftest substitute-if-not-vector.2 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.3 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.4 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.5 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) #(b b a c) #(a b a c)) (deftest substitute-if-not-vector.6 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.7 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.8 (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) #() #()) (deftest substitute-if-not-vector.9 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.10 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.11 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) #(b b b c) #(a b a c)) (deftest substitute-if-not-vector.12 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) #(a b b c) #(a b a c)) (deftest substitute-if-not-vector.13 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.14 (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) #(a b a c) #(a b a c)) (deftest substitute-if-not-vector.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array (- j i) :initial-element 'x) (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array i :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #(a a a a a a a a a a)) (x (copy-seq orig)) (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-vector (make-array (- j c) :initial-element 'a) (make-array c :initial-element 'x) (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) :fill-pointer 5)) (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) ;;; Tests on strings (deftest substitute-if-not-string.1 (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) "" "") (deftest substitute-if-not-string.2 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) "bbbc" "abac") (deftest substitute-if-not-string.3 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.4 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2) x)) "bbbc" "abac") (deftest substitute-if-not-string.5 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1) x)) "bbac" "abac") (deftest substitute-if-not-string.6 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0) x)) "abac" "abac") (deftest substitute-if-not-string.7 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1) x)) "abac" "abac") (deftest substitute-if-not-string.8 (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) "" "") (deftest substitute-if-not-string.9 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) "bbbc" "abac") (deftest substitute-if-not-string.10 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil) x)) "bbbc" "abac") (deftest substitute-if-not-string.11 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t) x)) "bbbc" "abac") (deftest substitute-if-not-string.12 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t) x)) "abbc" "abac") (deftest substitute-if-not-string.13 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t) x)) "abac" "abac") (deftest substitute-if-not-string.14 (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t) x)) "abac" "abac") (deftest substitute-if-not-string.15 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.16 (loop for i from 0 to 9 always (loop for j from i to 10 always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array (- j i) :initial-element #\x) (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.17 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array i :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.18 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig "aaaaaaaaaa") (x (copy-seq orig)) (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-string (make-array (- j c) :initial-element #\a) (make-array c :initial-element #\x) (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" :fill-pointer 5 :element-type 'character)) (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t :count 1))) result) "abzcb") ;;; Tests on bitstrings (deftest substitute-if-not-bitstring.1 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-not-bitstring.2 (let* ((orig #*) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) result)) #*) (deftest substitute-if-not-bitstring.3 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-not-bitstring.4 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.5 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :start 1))) (and (equalp orig x) result)) #*011111) (deftest substitute-if-not-bitstring.6 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) (and (equalp orig x) result)) #*010000) (deftest substitute-if-not-bitstring.7 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :end 4))) (and (equalp orig x) result)) #*111101) (deftest substitute-if-not-bitstring.8 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :end nil))) (and (equalp orig x) result)) #*000000) (deftest substitute-if-not-bitstring.9 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :end 3))) (and (equalp orig x) result)) #*000101) (deftest substitute-if-not-bitstring.10 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) (and (equalp orig x) result)) #*010001) (deftest substitute-if-not-bitstring.11 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) (and (equalp orig x) result)) #*011101) (deftest substitute-if-not-bitstring.12 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 1))) (and (equalp orig x) result)) #*110101) (deftest substitute-if-not-bitstring.13 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 0))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.14 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count -1))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.15 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) (and (equalp orig x) result)) #*010111) (deftest substitute-if-not-bitstring.16 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.17 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) (and (equalp orig x) result)) #*010101) (deftest substitute-if-not-bitstring.18 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count nil))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.19 (let* ((orig #*010101) (x (copy-seq orig)) (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) (and (equalp orig x) result)) #*111111) (deftest substitute-if-not-bitstring.20 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*0000000000) (x (copy-seq orig)) (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list i :initial-element 0) (make-list c :initial-element 1) (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-not-bitstring.21 (loop for i from 0 to 9 always (loop for j from i to 10 always (loop for c from 0 to (- j i) always (let* ((orig #*1111111111) (x (copy-seq orig)) (y (substitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) (and (equalp orig x) (equalp y (concatenate 'simple-bit-vector (make-list (- j c) :initial-element 1) (make-list c :initial-element 0) (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) (and (equal orig x) result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equal orig x) result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) (and (equalp orig x) result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) (x (copy-seq orig)) (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-string.24 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) (and (equalp orig x) result)) "a1a2342a15") (deftest substitute-if-not-string.25 (let* ((orig "0102342015") (x (copy-seq orig)) (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) result)) "01a2342015") (deftest substitute-if-not-bitstring.26 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) (and (equalp orig x) result)) #*11111111111111111) (deftest substitute-if-not-bitstring.27 (let* ((orig #*00111001011010110) (x (copy-seq orig)) (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) result)) #*01111111111010110) (deftest substitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x))) result) #*11111) (deftest substitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest substitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest substitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) :fill-pointer 5 :element-type 'bit)) (result (substitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) (deftest substitute-if-not.order.1 (let ((i 0) a b c d e f g h) (values (substitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :count (progn (setf d (incf i)) 2) :start (progn (setf e (incf i)) 0) :end (progn (setf f (incf i)) 7) :key (progn (setf g (incf i)) #'identity) :from-end (setf h (incf i)) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 4 5 6 7 8) (deftest substitute-if-not.order.2 (let ((i 0) a b c d e f g h) (values (substitute-if-not (progn (setf a (incf i)) 'a) (progn (setf b (incf i)) #'identity) (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) :from-end (setf h (incf i)) :key (progn (setf g (incf i)) #'identity) :end (progn (setf f (incf i)) 7) :start (progn (setf e (incf i)) 0) :count (progn (setf d (incf i)) 2) ) i a b c d e f g h)) (nil 1 2 a 3 4 a 5) 8 1 2 3 8 7 6 5 4) ;;; Keyword tests (deftest substitute-if-not.allow-other-keys.1 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.2 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.3 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.4 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.5 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest substitute-if-not.keywords.6 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest substitute-if-not.allow-other-keys.7 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.8 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) (a a 0 a a 0 a)) ;;; Error cases (deftest substitute-if-not.error.1 (classify-error (substitute-if-not)) program-error) (deftest substitute-if-not.error.2 (classify-error (substitute-if-not 'a)) program-error) (deftest substitute-if-not.error.3 (classify-error (substitute-if-not 'a #'null)) program-error) (deftest substitute-if-not.error.4 (classify-error (substitute-if-not 'a #'null nil 'bad t)) program-error) (deftest substitute-if-not.error.5 (classify-error (substitute-if-not 'a #'null nil 'bad t :allow-other-keys nil)) program-error) (deftest substitute-if-not.error.6 (classify-error (substitute-if-not 'a #'null nil :key)) program-error) (deftest substitute-if-not.error.7 (classify-error (substitute-if-not 'a #'null nil 1 2)) program-error) (deftest substitute-if-not.error.8 (classify-error (substitute-if-not 'a #'cons (list 'a 'b 'c))) program-error) (deftest substitute-if-not.error.9 (classify-error (substitute-if-not 'a #'car (list 'a 'b 'c))) type-error) (deftest substitute-if-not.error.10 (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'car)) type-error) (deftest substitute-if-not.error.11 (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/read-byte.lsp0000644000175000017500000001013614360276512015462 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Jan 17 17:30:49 2004 ;;;; Contains: Tests of READ-BYTE, WRITE-BYTE (in-package :cl-test) (deftest read-byte.1 (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (values (write-byte 17 s) (close s) (progn (setq s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8))) (read-byte s)) (close s))) 17 t 17 t) (deftest read-byte.2 (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (values (close s) (progn (setq s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8))) (read-byte s nil 'foo)) (read-byte s nil) (close s))) t foo nil t) (deftest read-byte.3 (loop with b1 = 0 and b2 = 0 for i from 1 to 32 do (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,i)))) (write-byte (1- (ash 1 i)) s) (write-byte 1 s) (close s)) unless (let ((s (open "foo.txt" :direction :input :element-type `(unsigned-byte ,i)))) (prog1 (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) (eql (setq b2 (read-byte s)) 1)) (close s))) collect (list i b1 b2)) nil) (deftest read-byte.4 (loop with b1 = 0 and b2 = 0 for i from 33 to 200 by 7 do (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte ,i)))) (write-byte (1- (ash 1 i)) s) (write-byte 1 s) (close s)) unless (let ((s (open "foo.txt" :direction :input :element-type `(unsigned-byte ,i)))) (prog1 (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) (eql (setq b2 (read-byte s)) 1)) (close s))) collect (list i b1 b2)) nil) ;;; Error tests (deftest read-byte.error.1 (signals-error (read-byte) program-error) t) (deftest read-byte.error.2 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type `(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (read-byte s)) end-of-file)) t) (deftest read-byte.error.3 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input))) (unwind-protect (read-byte s) (close s))) error)) t) (deftest read-byte.error.4 (signals-error-always (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (close s)) (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (unwind-protect (read-byte s t) (close s)))) end-of-file) t t) (deftest read-byte.error.5 (check-type-error #'read-byte #'streamp) nil) (deftest read-byte.error.6 (progn (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input :element-type '(unsigned-byte 8)))) (unwind-protect (read-byte s t t nil) (close s))) program-error)) t) (deftest write-byte.error.1 (signals-error (write-byte) program-error) t) (deftest write-byte.error.2 (signals-error (write-byte 0) program-error) t) (deftest write-byte.error.3 (signals-error (let ((s (open "foo.txt" :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)))) (unwind-protect (write 1 s nil) (close s))) program-error) t) (deftest write-byte.error.4 (check-type-error #'(lambda (x) (write-byte 0 x)) #'streamp) nil) (deftest write-byte.error.5 (signals-error (let ((s (open "foo.txt" :direction :output :if-exists :supersede))) (unwind-protect (write 1 s) (close s))) error) t) gcl-2.6.14/ansi-tests/etypecase.lsp0000644000175000017500000000207414360276512015572 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:02:23 2002 ;;;; Contains: Tests of ETYPECASE (in-package :cl-test) (deftest etypecase.1 (etypecase 1 (integer 'a) (t 'b)) a) (deftest etypecase.2 (classify-error (etypecase 1 (symbol 'a))) type-error) (deftest etypecase.3 (etypecase 1 (symbol 'a) (t 'b)) b) (deftest etypecase.4 (etypecase 1 (t (values)))) (deftest etypecase.5 (etypecase 1 (integer (values)) (t 'a))) (deftest etypecase.6 (etypecase 1 (bit 'a) (integer 'b)) a) (deftest etypecase.7 (etypecase 1 (t 'a)) a) (deftest etypecase.8 (etypecase 1 (t (values 'a 'b 'c))) a b c) (deftest etypecase.9 (etypecase 1 (integer (values 'a 'b 'c)) (t nil)) a b c) (deftest etypecase.10 (let ((x 0)) (values (etypecase 1 (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest etypecase.11 (etypecase 1 (integer) (t 'a)) nil) (deftest etypecase.12 (etypecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl-2.6.14/ansi-tests/coerce.lsp0000644000175000017500000000673114360276512015054 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Dec 13 20:48:04 2002 ;;;; Contains: Tests for COERCE (in-package :cl-test) (deftest coerce.1 (loop for x in *universe* for type = (type-of x) unless (and (consp type) (eqt (car type) 'function)) count (not (eq (coerce x type) x))) 0) (deftest coerce.2 (loop for x in *universe* count (not (eq (coerce x t) x))) 0) (deftest coerce.3 (loop for x in *universe* for class = (class-of x) count (and class (not (eq (coerce x class) x)))) 0) (deftest coerce.4 (loop for x in '(() #() #*) never (coerce x 'list)) t) (deftest coerce.5 (loop for x in '((1 0) #(1 0) #*10) always (equal (coerce x 'list) '(1 0))) t) (deftest coerce.6 (loop for x in '(() #() #*) always (equalp (coerce x 'vector) #())) t) (deftest coerce.7 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'vector) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.8 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x '(vector *)) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.9 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x '(vector * 2)) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.10 (values (coerce #\A 'character) (coerce '|A| 'character) (coerce "A" 'character)) #\A #\A #\A) (deftest coerce.11 (loop with class = (find-class 'vector) for x in '((1 0) #(1 0) #*10) for y = (coerce x class) always (and (equalp y #(1 0)) (vectorp y))) t) (deftest coerce.12 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'bit-vector) always (and (equalp y #*10) (bit-vector-p y))) t) (deftest coerce.13 (loop for x in '((#\a #\b #\c) "abc") for y = (coerce x 'string) always (and (stringp y) (string= y "abc"))) t) (deftest coerce.14 (loop for x in '((#\a #\b #\c) "abc") for y = (coerce x 'simple-string) always (and (typep y 'simple-string) (string= y "abc"))) t) (deftest coerce.15 (loop for x in '((1 0) #(1 0) #*10) for y = (coerce x 'simple-vector) always (and (equalp y #(1 0)) (simple-vector-p y))) t) (deftest coerce.16 (coerce 0 'integer) 0) (deftest coerce.17 (coerce 0 'complex) 0) (deftest coerce.18 (coerce 3 'complex) 3) (deftest coerce.19 (coerce 5/3 'complex) 5/3) (deftest coerce.20 (coerce 1.0 'complex) #c(1.0 0.0)) (deftest coerce.21 (eqt (symbol-function 'car) (coerce 'car 'function)) t) (deftest coerce.22 (funcall (coerce '(lambda () 10) 'function)) 10) (deftest coerce.order.1 (let ((i 0) a b) (values (coerce (progn (setf a (incf i)) 10) (progn (setf b (incf i)) 'single-float)) i a b)) 10.0f0 2 1 2) ;;; Error tests ;;; (deftest coerce.error.1 ;;; (classify-error (coerce -1 '(integer 0 100))) ;;; type-error) (deftest coerce.error.2 (classify-error (coerce '(a b c) '(vector * 2))) type-error) (deftest coerce.error.3 (classify-error (coerce '(a b c) '(vector * 4))) type-error) (deftest coerce.error.4 (classify-error (coerce nil 'cons)) type-error) (deftest coerce.error.5 (handler-case (eval '(coerce 'not-a-bound-function 'function)) (error () :caught)) :caught) (deftest coerce.error.6 (classify-error (coerce)) program-error) (deftest coerce.error.7 (classify-error (coerce t)) program-error) (deftest coerce.error.8 (classify-error (coerce 'x t 'foo)) program-error) (deftest coerce.error.9 (classify-error (locally (coerce nil 'cons) t)) type-error) gcl-2.6.14/ansi-tests/invoke-debugger.lsp0000644000175000017500000000113014360276512016655 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Feb 28 21:59:57 2003 ;;;; Contains: Tests of INVOKE-DEBUGGER (in-package :cl-test) ;;; We can't test actual entry into the debugger, but we can test ;;; that the function in *debugger-hook* is properly called. (deftest invoke-debugger.1 (block done (let (fn (cnd (make-condition 'simple-error))) (setq fn #'(lambda (c hook) (return-from done (and (null *debugger-hook*) (eqt hook fn) (eqt cnd c) 'good)))) (let ((*debugger-hook* fn)) (invoke-debugger cnd))) 'bad) good) gcl-2.6.14/ansi-tests/fill-pointer.lsp0000644000175000017500000000362314360276512016215 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 21 22:14:23 2003 ;;;; Contains: Tests of FILL-POINTER (in-package :cl-test) ;;; More tests are in make-array.lsp (deftest fill-pointer.1 (fill-pointer (make-array '(10) :fill-pointer 5)) 5) (deftest fill-pointer.2 (fill-pointer (make-array '(10) :fill-pointer t)) 10) (deftest fill-pointer.3 (let ((a (make-array '(10) :fill-pointer 5 :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values (fill-pointer a) (setf (fill-pointer a) 6) a)) 5 6 #(1 2 3 4 5 6)) (deftest fill-pointer.order.1 (let ((i 0) (a (make-array '(10) :fill-pointer 5))) (values (fill-pointer (progn (incf i) a)) i)) 5 1) (deftest fill-pointer.order.2 (let ((i 0) x y (a (make-array '(10) :fill-pointer 5 :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values i (setf (fill-pointer (progn (setf x (incf i)) a)) (progn (setf y (incf i)) 6)) a i x y)) 0 6 #(1 2 3 4 5 6) 2 1 2) ;;; Error tests (deftest fill-pointer.error.1 (classify-error (fill-pointer)) program-error) (deftest fill-pointer.error.2 (classify-error (fill-pointer (make-array '(10) :fill-pointer 4) nil)) program-error) (deftest fill-pointer.error.3 (classify-error (fill-pointer (make-array '(10) :fill-pointer nil))) type-error) (deftest fill-pointer.error.4 (classify-error (fill-pointer #0aNIL)) type-error) (deftest fill-pointer.error.5 (classify-error (fill-pointer #2a((a b c)(d e f)))) type-error) (deftest fill-pointer.error.6 (let (why) (loop for e in *mini-universe* when (and (or (not (typep e 'vector)) (not (array-has-fill-pointer-p e))) (not (eql (setq why (classify-error** `(fill-pointer ',e))) 'type-error))) collect (list e why))) nil) (deftest fill-pointer.error.7 (classify-error (locally (fill-pointer #2a((a b c)(d e f))) t)) type-error) gcl-2.6.14/ansi-tests/array-as-class.lsp0000644000175000017500000000250014360276512016424 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 07:45:25 2003 ;;;; Contains: Tests for ARRAY as a class (in-package :cl-test) (deftest array-as-class.1 (notnot-mv (typep #() (find-class 'array))) t) (deftest array-as-class.2 (notnot-mv (typep #(a b c) (find-class 'array))) t) (deftest array-as-class.3 (notnot-mv (typep #0aNIL (find-class 'array))) t) (deftest array-as-class.4 (notnot-mv (typep #2a((a b)(c d)) (find-class 'array))) t) (deftest array-as-class.5 (notnot-mv (typep "abcde" (find-class 'array))) t) (deftest array-as-class.6 (notnot-mv (typep #*0011101 (find-class 'array))) t) (deftest array-as-class.7 (subtypep* 'array (find-class 'array)) t t) (deftest array-as-class.8 (subtypep* (find-class 'array) 'array) t t) (deftest array-as-class.9 (typep nil (find-class 'array)) nil) (deftest array-as-class.10 (typep 'x (find-class 'array)) nil) (deftest array-as-class.11 (typep '(a b c) (find-class 'array)) nil) (deftest array-as-class.12 (typep 10.0 (find-class 'array)) nil) (deftest array-as-class.13 (typep #'(lambda (x) (cons x nil)) (find-class 'array)) nil) (deftest array-as-class.14 (typep 1 (find-class 'array)) nil) (deftest array-as-class.15 (typep (1+ most-positive-fixnum) (find-class 'array)) nil) gcl-2.6.14/ansi-tests/load-symbols.lsp0000644000175000017500000000020614360276512016210 0ustar cammcamm;;; Tests of symbols (compile-and-load "cl-symbols-aux.lsp") (load "cl-symbol-names.lsp") (load "cl-symbols.lsp") (load "boundp.lsp") gcl-2.6.14/ansi-tests/upgraded-array-element-type.lsp0000644000175000017500000000566714360276512021140 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 22 20:43:55 2003 ;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE (in-package :cl-test) (deftest upgraded-array-element-type.1 (let ((upgraded-bit (upgraded-array-element-type 'bit))) (and (empirical-subtypep 'bit upgraded-bit) (empirical-subtypep upgraded-bit 'bit))) t) (deftest upgraded-array-element-type.2 (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) (and (empirical-subtypep 'base-char upgraded-base-char) (empirical-subtypep upgraded-base-char 'base-char))) t) (deftest upgraded-array-element-type.3 (let ((upgraded-character (upgraded-array-element-type 'character))) (and (empirical-subtypep 'character upgraded-character) (empirical-subtypep upgraded-character 'character))) t) (defparameter *upgraded-array-types-to-check* `(boolean base-char character t ,@(loop for i from 0 to 32 collect `(integer 0 (,(ash 1 i)))) symbol ,@(loop for i from 0 to 32 collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) (integer -10000000000000000000000000000000000 10000000000000000000000000000000000) float short-float single-float double-float complex rational fixnum function sequence list cons atom symbol)) (deftest upgraded-array-element-type.4 (loop for type in *upgraded-array-types-to-check* for upgraded-type = (upgraded-array-element-type type) always (empirical-subtypep type upgraded-type)) t) ;; Include an environment (NIL, denoting the default null lexical ;; environment) (deftest upgraded-array-element-type.5 (loop for type in *upgraded-array-types-to-check* for upgraded-type = (upgraded-array-element-type type nil) always (empirical-subtypep type upgraded-type)) t) (deftest upgraded-array-element-type.6 (macrolet ((%foo (&environment env) (empirical-subtypep 'bit (upgraded-array-element-type 'bit env)))) (%foo)) t) (deftest upgraded-array-element-type.7 (let ((upgraded-types (mapcar #'upgraded-array-element-type *upgraded-array-types-to-check*))) (loop for type in *upgraded-array-types-to-check* for upgraded-type in upgraded-types append (loop for type2 in *upgraded-array-types-to-check* for upgraded-type2 in upgraded-types when (and (subtypep type type2) (equal (subtypep* upgraded-type upgraded-type) '(nil t))) collect (list type type2)))) nil) ;;; Tests of upgrading NIL (it should be type equivalent to NIL) (deftest upgraded-array-element-type.nil.1 (let ((uaet-nil (upgraded-array-element-type nil))) (loop for e in *universe* when (typep e uaet-nil) collect e)) nil) ;;; Error tests (deftest upgraded-array-element-type.error.1 (classify-error (upgraded-array-element-type)) program-error) (deftest upgraded-array-element-type.error.2 (classify-error (upgraded-array-element-type 'bit nil nil)) program-error) gcl-2.6.14/ansi-tests/packages-13.lsp0000644000175000017500000000234614360276512015611 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:06:03 1998 ;;;; Contains: Package test code, part 13 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in-package (deftest in-package.1 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package "A"))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.2 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package |A|))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.3 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package :|A|))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.4 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package #\A))) (and (eqt p2 (find-package "A")) (eqt *package* p2)))) t) (deftest in-package.5 (let ((*package* *package*)) (declare (special *package*)) (safely-delete-package "H") (handler-case (eval '(in-package "H")) (package-error () 'package-error) (error (c) c))) package-error) gcl-2.6.14/ansi-tests/case.lsp0000644000175000017500000000522314360276512014522 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 19:56:44 2002 ;;;; Contains: Tests of CASE (in-package :cl-test) (deftest case.1 (case 'a) nil) (deftest case.2 (case 10 (10 'a)) a) (deftest case.3 (case (copy-seq "abc") ("abc" 'a)) nil) (deftest case.4 (case 'z ((a b c) 1) ((d e) 2) ((f z g) 3) (t 4)) 3) (deftest case.5 (case (1+ most-positive-fixnum) (#.(1+ most-positive-fixnum) 'a)) a) (deftest case.6 (case nil (nil 'a) (t 'b)) b) (deftest case.7 (case nil ((nil) 'a) (t 'b)) a) (deftest case.8 (case 'a (b 0) (a (values 1 2 3)) (t nil)) 1 2 3) (deftest case.9 (case 'c (b 0) (a (values 1 2 3)) (t (values 'x 'y 'z))) x y z) (deftest case.10 (case 'z (b 1) (a 2) (z (values)) (t nil))) (deftest case.11 (case 'z (b 1) (a 2) (t (values)))) (deftest case.12 (case t (a 10)) nil) (deftest case.13 (case t ((t) 10) (t 20)) 10) (deftest case.14 (let ((x (list 'a 'b))) (eval `(case (quote ,x) ((,x) 1) (t 2)))) 1) (deftest case.15 (case 'otherwise ((t) 10)) nil) (deftest case.16 (case t ((otherwise) 10)) nil) (deftest case.17 (case 'a (b 0) (c 1) (otherwise 2)) 2) (deftest case.18 (case 'a (b 0) (c 1) ((otherwise) 2)) nil) (deftest case.19 (case 'a (b 0) (c 1) ((t) 2)) nil) (deftest case.20 (case #\a ((#\b #\c) 10) ((#\d #\e #\A) 20) (() 30) ((#\z #\a #\y) 40)) 40) (deftest case.21 (case 1 (1 (values)))) (deftest case.22 (case 2 (t (values)))) (deftest case.23 (case 1 (1 (values 'a 'b 'c))) a b c) (deftest case.24 (case 2 (t (values 'a 'b 'c))) a b c) ;;; Show that the key expression is evaluated only once. (deftest case.25 (let ((x 0)) (values (case (progn (incf x) 'c) (a 1) (b 2) (c 3) (t 4)) x)) 3 1) ;;; Repeated keys are allowed (all but the first are ignored) (deftest case.26 (case 'b ((a b c) 10) (b 20)) 10) (deftest case.27 (case 'b (b 20) ((a b c) 10)) 20) (deftest case.28 (case 'b (b 20) (b 10) (t 0)) 20) ;;; There are implicit progns (deftest case.29 (let ((x nil)) (values (case 2 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (t (setq x 'c) 'z)) x)) y b) (deftest case.30 (let ((x nil)) (values (case 10 (1 (setq x 'a) 'w) (2 (setq x 'b) 'y) (t (setq x 'c) 'z)) x)) z c) (deftest case.31 (case (values 'b 'c) (c 0) ((a b) 10) (t 20)) 10) (deftest case.32 (case 'a (a) (t 'b)) nil) (deftest case.33 (case 'a (b 'b) (t)) nil) (deftest case.34 (case 'a (b 'b) (otherwise)) nil) ;;; (deftest case.error.1 ;;; (classify-error (case)) ;;; program-error) gcl-2.6.14/ansi-tests/README0000644000175000017500000000054014360276512013744 0ustar cammcammThis directory contains a partial Common Lisp standards compliance test suite. To run the tests, load gclload.lsp. This will load and run the tests. To just load the tests, load gclload1.lsp and gclload2.lsp. Individual tests may be run by (rt:do-test '). Please tell me when you find incorrect test cases. Paul Dietz dietz@dls.net gcl-2.6.14/ansi-tests/equalp.lsp0000644000175000017500000000165514360276512015103 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 17 22:14:42 2002 ;;;; Contains: Tests for EQUALP (in-package :cl-test) (deftest equalp.1 (loop for c across +base-chars+ always (loop for d across +base-chars+ always (if (char-equal c d) (equalpt c d) (not (equalpt c d))))) t) (deftest equalp.2 (loop for i from 1 to 100 always (loop for j from 1 to 100 always (if (eqlt i j) (equalpt i j) (not (equalpt i j))))) t) (deftest equalp.3 (equalpt "abc" "ABC") t) (deftest equalp.4 (equalpt "abc" "abd") nil) (deftest equalp.order.1 (let ((i 0) x y) (values (equalp (setf x (incf i)) (setf y (incf i))) i x y)) nil 2 1 2) (deftest equalp.error.1 (classify-error (equalp)) program-error) (deftest equalp.error.2 (classify-error (equalp nil)) program-error) (deftest equalp.error.3 (classify-error (equalp nil nil nil)) program-error) gcl-2.6.14/ansi-tests/vectorp.lsp0000644000175000017500000000212214360276512015264 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 13:17:05 2003 ;;;; Contains: Tests for VECTORP (in-package :cl-test) (deftest vectorp.1 (vectorp 1) nil) (deftest vectorp.2 (vectorp (1+ most-positive-fixnum)) nil) (deftest vectorp.3 (vectorp #\a) nil) (deftest vectorp.4 (vectorp 10.0) nil) (deftest vectorp.5 (vectorp #'(lambda (x y) (cons y x))) nil) (deftest vectorp.6 (vectorp '(a b)) nil) (deftest vectorp.7 (vectorp #0aT) nil) (deftest vectorp.8 (vectorp #2a((a b)(c d))) nil) (deftest vectorp.9 (notnot-mv (vectorp "abcd")) t) (deftest vectorp.10 (notnot-mv (vectorp #*)) t) (deftest vectorp.11 (notnot-mv (vectorp #*1101)) t) (deftest vectorp.12 (notnot-mv (vectorp "")) t) (deftest vectorp.13 (notnot-mv (vectorp #(1 2 3))) t) (deftest vectorp.14 (notnot-mv (vectorp #())) t) (deftest vectorp.15 (vectorp #b11010) nil) ;;; Error tests (deftest vectorp.error.1 (classify-error (vectorp)) program-error) (deftest vectorp.error.2 (classify-error (vectorp #() #())) program-error) gcl-2.6.14/ansi-tests/merge-pathnames.lsp0000644000175000017500000001027414360276512016666 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Dec 31 11:25:55 2003 ;;;; Contains: Tests of MERGE-PATHNAMES (in-package :cl-test) #| (defun merge-pathnames-test (&rest args) (assert (<= 1 (length args) 3)) (let* ((p1 (car args)) (p2 (if (cdr args) (cadr args) *default-pathname-defaults*)) (default-version (if (cddr args) (caddr args) :newest)) (results (multiple-value-list (apply #'merge-pathnames args)))) (assert (= (length results) 1)) (let ((p3 (first results))) |# (deftest merge-pathnames.1 (let* ((p1 (make-pathname :name "foo")) (p2 (merge-pathnames p1 p1 nil))) (values (equalpt (pathname-name p1) "foo") (if (equalpt p1 p2) t (list p1 p2)))) t t) (deftest merge-pathnames.2 (let* ((p1 (make-pathname :name "foo")) (p2 (merge-pathnames p1 p1))) (values (equalpt (pathname-host p1) (pathname-host p2)) (equalpt (pathname-device p1) (pathname-device p2)) (equalpt (pathname-directory p1) (pathname-directory p2)) (pathname-name p1) (pathname-name p2) (equalpt (pathname-type p1) (pathname-type p2)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p2)) (equalpt (pathname-version p2) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.3 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :name "bar")) (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-name p3) (equalpt (pathname-type p1) (pathname-type p3)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.4 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :type "lsp")) (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-type p2) (pathname-type p3) (equalpt (pathname-type p2) (pathname-type p3)) (if (pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "lsp" "lsp" t t) (deftest merge-pathnames.5 (let* ((p1 (make-pathname :name "foo")) (p2 (make-pathname :type "lsp" :version :newest)) (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p1) (pathname-name p3) (pathname-type p2) (pathname-type p3) (equalpt (pathname-version p1) (pathname-version p3)))) t t t "foo" "foo" "lsp" "lsp" t) (deftest merge-pathnames.6 (let* ((p1 (make-pathname)) (p2 (make-pathname :name "foo" :version :newest)) (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) (equalpt (pathname-directory p1) (pathname-directory p3)) (pathname-name p2) (pathname-name p3) (equalpt (pathname-type p2) (pathname-type p3)) (pathname-version p2) (pathname-version p3))) t t t "foo" "foo" t :newest :newest) (deftest merge-pathnames.7 (let* ((p1 (make-pathname)) (p2 *default-pathname-defaults*) (p3 (merge-pathnames p1))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-host p2) (pathname-host p3)) (equalpt (pathname-device p2) (pathname-device p3)) (equalpt (pathname-directory p2) (pathname-directory p3)) (equalpt (pathname-name p2) (pathname-name p3)) (equalpt (pathname-type p2) (pathname-type p3)) (cond ((pathname-version p1) (equalpt (pathname-version p1) (pathname-version p3))) ((pathname-version p2) (equalpt (pathname-version p2) (pathname-version p3))) (t (equalpt (pathname-version p3) :newest))))) t t t t t t t) gcl-2.6.14/ansi-tests/ensure-directories-exist.lsp0000644000175000017500000001152014360276512020551 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Jan 5 20:53:03 2004 ;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST (in-package :cl-test) (deftest ensure-directories-exist.1 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.2 (with-open-file (s "ensure-directories-exist.lsp" :direction :input) (let* ((results (multiple-value-list (ensure-directories-exist s)))) (values (length results) (equalt (truename (first results)) (truename s)) (second results)))) 2 t nil) (deftest ensure-directories-exist.3 (let ((s (open "ensure-directories-exist.lsp" :direction :input))) (close s) (let* ((results (multiple-value-list (ensure-directories-exist s)))) (values (length results) (equalt (truename (first results)) (truename s)) (second results)))) 2 t nil) (deftest ensure-directories-exist.4 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :verbose nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.5 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :verbose t)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.6 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :allow-other-keys nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") (deftest ensure-directories-exist.7 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" :defaults *default-pathname-defaults*)) (results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn :allow-other-keys t :nonsense t)))))) (values (length results) (equalt (truename pn) (truename (first results))) (second results) verbosity)) 2 t nil "") ;;; Case where directory shouldn't exist ;; The directort ansi-tests/scratch must not exist before this ;; test is run (deftest ensure-directories-exist.8 (let* ((subdir (make-pathname :directory '(:relative "scratch") :defaults *default-pathname-defaults*)) (pn (make-pathname :name "foo" :type "txt" :defaults subdir))) (ignore-errors (delete-file pn) (delete-file subdir)) (assert (not (probe-file pn)) () "Delete subdirectory scratch and its contents!") (let* ((results nil) (verbosity (with-output-to-string (*standard-output*) (setq results (multiple-value-list (ensure-directories-exist pn))))) (result-pn (first results)) (created (second results))) ;; Create the file and write to it (with-open-file (*standard-output* pn :direction :output :if-exists :error :if-does-not-exist :create) (print nil)) (values (length results) (notnot created) (equalt pn result-pn) (notnot (probe-file pn)) verbosity ))) 2 t t t "") ;;; Specialized string tests (deftest ensure-directories-exist.9 (do-special-strings (str "ensure-directories-exist.lsp" nil) (let* ((results (multiple-value-list (ensure-directories-exist str)))) (assert (eql (length results) 2)) (assert (equalt (truename (first results)) (truename str))) (assert (null (second results))))) nil) ;; FIXME ;; Need to add a LPN test (deftest ensure-directories-exist.error.1 (signals-error-always (ensure-directories-exist (make-pathname :directory '(:relative :wild) :defaults *default-pathname-defaults*)) file-error) t t) (deftest ensure-directories-exist.error.2 (signals-error (ensure-directories-exist) program-error) t) gcl-2.6.14/ansi-tests/read-char.lsp0000644000175000017500000000415314360276512015436 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 18 08:53:56 2004 ;;;; Contains: Tests of READ-CHAR (in-package :cl-test) (deftest read-char.1 (with-input-from-string (*standard-input* "a") (read-char)) #\a) (deftest read-char.2 (with-input-from-string (*standard-input* "abc") (values (read-char) (read-char) (read-char))) #\a #\b #\c) (when (code-char 0) (deftest read-char.3 (with-input-from-string (*standard-input* (concatenate 'string "a" (string (code-char 0)) "b")) (values (read-char) (read-char) (read-char))) #\a #.(code-char 0) #\b)) (deftest read-char.4 (with-input-from-string (s "abc") (values (read-char s) (read-char s) (read-char s))) #\a #\b #\c) (deftest read-char.5 (with-input-from-string (s "") (read-char s nil)) nil) (deftest read-char.6 (with-input-from-string (s "") (read-char s nil 'foo)) foo) (deftest read-char.7 (with-input-from-string (s "abc") (values (read-char s nil nil) (read-char s nil nil) (read-char s nil nil))) #\a #\b #\c) (deftest read-char.8 (with-input-from-string (s "abc") (values (read-char s nil t) (read-char s nil t) (read-char s nil t))) #\a #\b #\c) (deftest read-char.9 (with-input-from-string (is "!?*") (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) (read-char t))) #\!) (deftest read-char.10 (with-input-from-string (*standard-input* "345") (read-char nil)) #\3) ;;; Error tests (deftest read-char.error.1 (signals-error (with-input-from-string (s "abc") (read-char s nil nil nil nil)) program-error) t) (deftest read-char.error.2 (signals-error-always (with-input-from-string (s "") (read-char s)) end-of-file) t t) (deftest read-char.error.3 (signals-error-always (with-input-from-string (s "") (read-char s t)) end-of-file) t t) (deftest read-char.error.4 (signals-error-always (with-input-from-string (s "") (read-char s t t)) end-of-file) t t) gcl-2.6.14/ansi-tests/cons-test-04.lsp0000644000175000017500000002224114360276512015746 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:33:20 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 4 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; push ;;; There will be a separate test suite ;;; for ACCESSORS x SETF-like macros ;;; See also places.lsp (deftest push.1 (let ((x nil)) (push 'a x)) (a)) (deftest push.2 (let ((x 'b)) (push 'a x) (push 'c x)) (c a . b)) (deftest push.3 (let ((x (copy-tree '(a)))) (push x x) (and (eqt (car x) (cdr x)) x)) ((a) a)) (deftest push.order.1 (let ((x (list nil)) (i 0) a b) (values (push (progn (setf a (incf i)) 'z) (car (progn (setf b (incf i)) x))) x i a b)) (z) ((z)) 2 1 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pop (deftest pop.1 (let ((x (copy-tree '(a b c)))) (let ((y (pop x))) (list x y))) ((b c) a)) (deftest pop.2 (let ((x nil)) (let ((y (pop x))) (list x y))) (nil nil)) ;;; Confirm argument is executed just once. (deftest pop.order.1 (let ((i 0) (a (vector (list 'a 'b 'c)))) (pop (aref a (progn (incf i) 0))) (values a i)) #((b c)) 1) (deftest push-and-pop (let* ((x (copy-tree '(a b))) (y x)) (push 'c x) (and (eqt (cdr x) y) (pop x))) c) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pushnew ;;; See also places.lsp (deftest pushnew.1 (let ((x nil)) (let ((y (pushnew 'a x))) (and (eqt x y) (equal x '(a)) t))) t) (deftest pushnew.2 (let* ((x (copy-tree '(b c d a k f q))) (y (pushnew 'a x))) (and (eqt x y) x)) (b c d a k f q)) (deftest pushnew.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) (y (pushnew 7 x))) (and (eqt x y) x)) (1 2 3 4 5 6 7 8)) (deftest pushnew.4 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(c d)) x :test 'equal))) (and (eqt x y) x)) ((c d) (a b) 1 "and" c d e)) (deftest pushnew.5 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(a b)) x :test 'equal))) (and (eqt x y) x)) ((a b) 1 "and" c d e)) (deftest pushnew.6 (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) (y (pushnew (copy-tree '(d i)) x :key #'car)) (z (pushnew (copy-tree '(z 10)) x :key #'car))) (and (eqt y (cdr z)) (eqt z x) x)) ((z 10) (a b) (c e) (d f) (g h))) (deftest pushnew.7 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key #'car :test #'string=)) (z (pushnew (copy-tree '("xyz" 10)) x :key #'car :test #'string=))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) (deftest pushnew.8 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key #'car :test-not (complement #'string=))) (z (pushnew (copy-tree '("xyz" 10)) x :key #'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) (deftest pushnew.9 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) (y (pushnew (copy-tree '("def" 4)) x :key 'car :test-not (complement #'string=))) (z (pushnew (copy-tree '("xyz" 10)) x :key 'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) x)) (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.10 (let* ((x (list 'a 'b 'c 'd)) (result (pushnew 'z x :key nil))) result) (z a b c d)) ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.11 (let* ((x (copy-tree '((a b) 1 "and" c d e))) (y (pushnew (copy-tree '(a b)) x :test 'equal :key nil))) (and (eqt x y) x)) ((a b) 1 "and" c d e)) (deftest pushnew.12 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) d i x y z)) (a b c) (a b c) 3 1 2 3) (deftest pushnew.13 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql))) d i x y z)) (a b c) (a b c) 3 1 2 3) (deftest pushnew.14 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :test (progn (setf z (incf i)) #'eql) :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) (deftest pushnew.15 (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) d :test-not (progn (setf z (incf i)) (complement #'eql)) :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) (deftest pushnew.error.1 (classify-error (let ((x '(a b))) (pushnew 'c x :test #'identity))) program-error) (deftest pushnew.error.2 (classify-error (let ((x '(a b))) (pushnew 'c x :test-not #'identity))) program-error) (deftest pushnew.error.3 (classify-error (let ((x '(a b))) (pushnew 'c x :key #'cons))) program-error) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; adjoin (deftest adjoin.1 (adjoin 'a nil) (a)) (deftest adjoin.2 (adjoin nil nil) (nil)) (deftest adjoin.3 (adjoin 'a '(a)) (a)) ;; Check that a NIL :key argument is the same as no key argument at all (deftest adjoin.4 (adjoin 'a '(a) :key nil) (a)) (deftest adjoin.5 (adjoin 'a '(a) :key #'identity) (a)) (deftest adjoin.6 (adjoin 'a '(a) :key 'identity) (a)) (deftest adjoin.7 (adjoin (1+ 11) '(4 3 12 2 1)) (4 3 12 2 1)) ;; Check that the test is EQL, not EQ (by adjoining a bignum) (deftest adjoin.8 (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) (4 1 1000000000000 3816734 a "aa")) (deftest adjoin.9 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) ("aaa" aaa "AAA" "aaa" #\a)) (deftest adjoin.10 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) (aaa "AAA" "aaa" #\a)) (deftest adjoin.11 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) (aaa "AAA" "aaa" #\a)) (deftest adjoin.12 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test-not (complement #'equal)) (aaa "AAA" "aaa" #\a)) (deftest adjoin.14 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal :key #'identity) (aaa "AAA" "aaa" #\a)) (deftest adjoin.15 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal :key #'identity) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.16 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.17 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.18 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test-not (complement #'equal) :key nil) (aaa "AAA" "aaa" #\a)) (deftest adjoin.order.1 (let ((i 0) w x y z) (values (adjoin (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) '(b c d a e)) :key (progn (setf y (incf i)) #'identity) :test (progn (setf z (incf i)) #'eql)) i w x y z)) (b c d a e) 4 1 2 3 4) (deftest adjoin.order.2 (let ((i 0) w x y z p) (values (adjoin (progn (setf w (incf i)) 'a) (progn (setf x (incf i)) '(b c d e)) :test-not (progn (setf y (incf i)) (complement #'eql)) :key (progn (setf z (incf i)) #'identity) :key (progn (setf p (incf i)) nil)) i w x y z p)) (a b c d e) 5 1 2 3 4 5) (deftest adjoin.allow-other-keys.1 (adjoin 'a '(b c) :bad t :allow-other-keys t) (a b c)) (deftest adjoin.allow-other-keys.2 (adjoin 'a '(b c) :allow-other-keys t :foo t) (a b c)) (deftest adjoin.allow-other-keys.3 (adjoin 'a '(b c) :allow-other-keys t) (a b c)) (deftest adjoin.allow-other-keys.4 (adjoin 'a '(b c) :allow-other-keys nil) (a b c)) (deftest adjoin.allow-other-keys.5 (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) (a b c)) (deftest adjoin.repeat-key (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) (a b c)) (deftest adjoin.error.1 (classify-error (adjoin)) program-error) (deftest adjoin.error.2 (classify-error (adjoin 'a)) program-error) (deftest adjoin.error.3 (classify-error (adjoin 'a '(b c) :bad t)) program-error) (deftest adjoin.error.4 (classify-error (adjoin 'a '(b c) :allow-other-keys nil :bad t)) program-error) (deftest adjoin.error.5 (classify-error (adjoin 'a '(b c) 1 2)) program-error) (deftest adjoin.error.6 (classify-error (adjoin 'a '(b c) :test)) program-error) (deftest adjoin.error.7 (classify-error (adjoin 'a '(b c) :test #'identity)) program-error) (deftest adjoin.error.8 (classify-error (adjoin 'a '(b c) :test-not #'identity)) program-error) (deftest adjoin.error.9 (classify-error (adjoin 'a '(b c) :key #'cons)) program-error) gcl-2.6.14/ansi-tests/bit-xor.lsp0000644000175000017500000001426114360276512015175 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:35:46 2003 ;;;; Contains: Tests of BIT-XOR (in-package :cl-test) (deftest bit-xor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-xor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-xor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-xor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-xor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-xor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a0 #0a0 t) (deftest bit-xor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-xor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 #0a1 t) ;;; Tests on bit vectors (deftest bit-xor.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2)) a1 a2)) #*0110 #*0011 #*0101) (deftest bit-xor.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-xor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0110 #*0110 #*0101 t) (deftest bit-xor.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-xor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0110 #*0011 #*0101 #*0110 t) (deftest bit-xor.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2 nil)) a1 a2)) #*0110 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-xor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 0)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-xor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-xor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0)) #2a((0 1)(1 0))) ;;; Adjustable arrays (deftest bit-xor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) ;;; Displaced arrays (deftest bit-xor.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-xor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-xor a1 a2 t))) (values a0 a1 a2 result)) #*01100011 #2a((0 1)(1 0)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-xor a1 a2 a3))) (values a0 a1 a2 result)) #*010100110110 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 0))) (deftest bit-xor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-xor (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-xor.error.1 (classify-error (bit-xor)) program-error) (deftest bit-xor.error.2 (classify-error (bit-xor #*000)) program-error) (deftest bit-xor.error.3 (classify-error (bit-xor #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/remove-duplicates.lsp0000644000175000017500000001613414360276512017242 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Sep 29 20:49:47 2002 ;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES (in-package :cl-test) (deftest random-remove-duplicates (loop for i from 1 to 5000 always (random-test-remove-dups 20)) t) (deftest random-delete-duplicates (loop for i from 1 to 5000 always (random-test-remove-dups 20 nil)) t) ;;; Look for :KEY NIL bugs (deftest remove-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) (x (copy-seq orig)) (y (remove-duplicates x :key nil))) (and (equalp orig x) y)) (3 4 1 5 6 2 7)) (deftest delete-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) (x (copy-seq orig)) (y (delete-duplicates x :key nil))) y) (3 4 1 5 6 2 7)) ;;; Order of evaluation tests (deftest remove-duplicates.order.1 (let ((i 0) a b c d e f) (values (remove-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :from-end (progn (setf b (incf i)) nil) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) nil) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'=) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) (deftest remove-duplicates.order.2 (let ((i 0) a b c d e f) (values (remove-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :test-not (progn (setf b (incf i)) #'/=) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) nil) :start (progn (setf e (incf i)) 0) :from-end (progn (setf f (incf i)) nil) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) ;;; Keyword tests (deftest remove-duplicates.allow-other-keys.1 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.2 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.3 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.4 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.5 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.6 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.7 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.8 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest remove-duplicates.keywords.1 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) (1 2 3 4 7 8 5)) (deftest delete-duplicates.allow-other-keys.1 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.2 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.3 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.4 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.5 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.6 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.7 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.8 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest delete-duplicates.keywords.1 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) (1 2 3 4 7 8 5)) ;;; Order of evaluation tests (deftest delete-duplicates.order.1 (let ((i 0) a b c d e f) (values (delete-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :from-end (progn (setf b (incf i)) nil) :start (progn (setf c (incf i)) 0) :end (progn (setf d (incf i)) nil) :key (progn (setf e (incf i)) #'identity) :test (progn (setf f (incf i)) #'=) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) (deftest delete-duplicates.order.2 (let ((i 0) a b c d e f) (values (delete-duplicates (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) :test-not (progn (setf b (incf i)) #'/=) :key (progn (setf c (incf i)) #'identity) :end (progn (setf d (incf i)) nil) :start (progn (setf e (incf i)) 0) :from-end (progn (setf f (incf i)) nil) ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) ;;; Error cases (deftest remove-duplicates.error.1 (classify-error (remove-duplicates)) program-error) (deftest remove-duplicates.error.2 (classify-error (remove-duplicates nil :start)) program-error) (deftest remove-duplicates.error.3 (classify-error (remove-duplicates nil 'bad t)) program-error) (deftest remove-duplicates.error.4 (classify-error (remove-duplicates nil 'bad t :allow-other-keys nil)) program-error) (deftest remove-duplicates.error.5 (classify-error (remove-duplicates nil 1 2)) program-error) (deftest remove-duplicates.error.6 (classify-error (remove-duplicates (list 'a 'b 'c) :test #'identity)) program-error) (deftest remove-duplicates.error.7 (classify-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest remove-duplicates.error.8 (classify-error (remove-duplicates (list 'a 'b 'c) :key #'cons)) program-error) (deftest remove-duplicates.error.9 (classify-error (remove-duplicates (list 'a 'b 'c) :key #'car)) type-error) ;;; (deftest delete-duplicates.error.1 (classify-error (delete-duplicates)) program-error) (deftest delete-duplicates.error.2 (classify-error (delete-duplicates nil :start)) program-error) (deftest delete-duplicates.error.3 (classify-error (delete-duplicates nil 'bad t)) program-error) (deftest delete-duplicates.error.4 (classify-error (delete-duplicates nil 'bad t :allow-other-keys nil)) program-error) (deftest delete-duplicates.error.5 (classify-error (delete-duplicates nil 1 2)) program-error) (deftest delete-duplicates.error.6 (classify-error (delete-duplicates (list 'a 'b 'c) :test #'identity)) program-error) (deftest delete-duplicates.error.7 (classify-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity)) program-error) (deftest delete-duplicates.error.8 (classify-error (delete-duplicates (list 'a 'b 'c) :key #'cons)) program-error) (deftest delete-duplicates.error.9 (classify-error (delete-duplicates (list 'a 'b 'c) :key #'car)) type-error)gcl-2.6.14/ansi-tests/translate-pathname.lsp0000644000175000017500000000715414360276512017404 0ustar cammcamm;-*- Mode: Lisp -*- (in-package :cl-test) (deftest translate-pathname.1 (translate-pathname "foobar" "foobar" "foobar") #P"foobar") (deftest translate-pathname.2 (translate-pathname "foobar" "foobar" "foo*") #P"foo") (deftest translate-pathname.3 (translate-pathname "foobar" "foobar" "*") #P"foobar") (deftest translate-pathname.4 (translate-pathname "foobar" "foobar" "") #P"foobar") (deftest translate-pathname.5 (translate-pathname "foobar" "foo*r" "foobar") #P"foobar") (deftest translate-pathname.6 (translate-pathname "foobar" "foo*r" "foo*") #P"fooba") (deftest translate-pathname.7 (translate-pathname "foobar" "foo*r" "*") #P"foobar") (deftest translate-pathname.8 (translate-pathname "foobar" "foo*r" "") #P"foobar") (deftest translate-pathname.9 (translate-pathname "foobar" "*" "foobar") #P"foobar") (deftest translate-pathname.10 (translate-pathname "foobar" "*" "foo*") #P"foofoobar") (deftest translate-pathname.11 (translate-pathname "foobar" "*" "*") #P"foobar") (deftest translate-pathname.12 (translate-pathname "foobar" "*" "") #P"foobar") (deftest translate-pathname.13 (translate-pathname "foobar" "" "foobar") #P"foobar") (deftest translate-pathname.14 (translate-pathname "foobar" "" "foo*") #P"foofoobar") (deftest translate-pathname.15 (translate-pathname "foobar" "" "*") #P"foobar") (deftest translate-pathname.16 (translate-pathname "foobar" "" "") #P"foobar") (deftest translate-pathname.17 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.18 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.19 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/*/c/d/") #P"/a/c/d/") (deftest translate-pathname.20 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "/a/**/d/") #P"/a/d/") (deftest translate-pathname.21 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.22 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/q*c*/c/d/") #P"/a/qbcb/c/d/") (deftest translate-pathname.23 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/*/c/d/") #P"/a/bbfb/c/d/") (deftest translate-pathname.24 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "/a/**/d/") #P"/a/bbfb/d/") (deftest translate-pathname.25 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/qc/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.26 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/q*c*/c/d/") #P"/a/qc/c/d/") (deftest translate-pathname.27 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/*/d/") #P"/a/bbfb/d/") (deftest translate-pathname.28 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "/a/**/d/") #P"/a/bbfb/c/d/") (deftest translate-pathname.29 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/qc/c/d/") #P"a/qc/c/d/") (deftest translate-pathname.30 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/q*c*/c/d/") #P"a/qc/c/d/") (deftest translate-pathname.31 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/*/d/") #P"a/bbfb/d/") (deftest translate-pathname.32 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a/**/d/") #P"a/bbfb/c/d/") (deftest translate-pathname.33 (translate-pathname "/a/bbfb/c/d/" "/a/bbfb/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.34 (translate-pathname "/a/bbfb/c/d/" "/a/b*f*/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.35 (translate-pathname "/a/bbfb/c/d/" "/a/*/c/d/" "a") #P"/a/bbfb/c/d/a") (deftest translate-pathname.36 (translate-pathname "/a/bbfb/c/d/" "/a/**/d/" "a") #P"/a/bbfb/c/d/a") gcl-2.6.14/ansi-tests/file-error.lsp0000644000175000017500000000472114360276512015657 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Jan 13 19:10:02 2004 ;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function (in-package :cl-test) (deftest file-error.1 (let ((pn (make-pathname :name :wild :type "txt" :version :newest :defaults *default-pathname-defaults*))) (handler-case (probe-file pn) (error (c) (values (notnot (typep c 'file-error)) (if (equalp (file-error-pathname c) pn) t (list (file-error-pathname c) pn)))))) t t) (deftest file-error-pathname.1 (let ((c (make-condition 'file-error :pathname "foo.txt"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (file-error-pathname c))) t t "foo.txt") (deftest file-error-pathname.2 (let ((c (make-condition 'file-error :pathname #p"foo.txt"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalt #p"foo.txt" (file-error-pathname c)))) t t t) (deftest file-error-pathname.3 (let ((c (make-condition 'file-error :pathname "CLTEST:FOO.TXT"))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt "CLTEST:FOO.TXT" (file-error-pathname c)))) t t t) (deftest file-error-pathname.4 (let ((c (make-condition 'file-error :pathname (logical-pathname "CLTEST:FOO.TXT")))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt (logical-pathname "CLTEST:FOO.TXT") (file-error-pathname c)))) t t t) (deftest file-error-pathname.5 (with-open-file (s "file-error.lsp" :direction :input) (let ((c (make-condition 'file-error :pathname s))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt s (file-error-pathname c))))) t t t) (deftest file-error-pathname.6 (let ((s (open "file-error.lsp" :direction :input))) (close s) (let ((c (make-condition 'file-error :pathname s))) (values (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt s (file-error-pathname c))))) t t t) (deftest file-error-pathname.error.1 (signals-error (file-error-pathname) program-error) t) (deftest file-error-pathname.error.2 (signals-error (file-error-pathname (make-condition 'file-error :pathname "foo.txt") nil) program-error) t) gcl-2.6.14/ansi-tests/bit-and.lsp0000644000175000017500000001426014360276512015126 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:18:47 2003 ;;;; Contains: Tests of BIT-AND (in-package :cl-test) (deftest bit-and.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-and.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-and.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 #0a1) (deftest bit-and.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-and.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-and.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-and.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-and s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-and.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2)) a1 a2)) #*0001 #*0011 #*0101) (deftest bit-and.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-and a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0001 #*0001 #*0101 t) (deftest bit-and.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-and a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0001 #*0011 #*0101 #*0001 t) (deftest bit-and.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2 nil)) a1 a2)) #*0001 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-and.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2 t))) (values a1 a2 result)) #2a((0 0)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-and a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-and a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1)) #2a((0 0)(0 1))) ;;; Adjustable arrays (deftest bit-and.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) ;;; Displaced arrays (deftest bit-and.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-and a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-and a1 a2 t))) (values a0 a1 a2 result)) #*00010011 #2a((0 0)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-and a1 a2 a3))) (values a0 a1 a2 result)) #*010100110001 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(0 1))) (deftest bit-and.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-and (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-and.error.1 (classify-error (bit-and)) program-error) (deftest bit-and.error.2 (classify-error (bit-and #*000)) program-error) (deftest bit-and.error.3 (classify-error (bit-and #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/finish-output.lsp0000644000175000017500000000226414360276512016427 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Jan 28 06:38:20 2004 ;;;; Contains: Tests of FINISH-OUTPUT (in-package :cl-test) (deftest finish-output.1 (finish-output) nil) (deftest finish-output.2 (finish-output t) nil) (deftest finish-output.3 (finish-output nil) nil) (deftest finish-output.4 (loop for s in (list *debug-io* *error-output* *query-io* *standard-output* *trace-output* *terminal-io*) for results = (multiple-value-list (finish-output s)) unless (equal results '(nil)) collect s) nil) (deftest finish-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") os))) (finish-output t))) nil) (deftest finish-output.6 (let ((*standard-output* (make-string-output-stream))) (finish-output nil)) nil) ;;; Error tests (deftest finish-output.error.1 (signals-error (finish-output nil nil) program-error) t) (deftest finish-output.error.2 (signals-error (finish-output t nil) program-error) t) (deftest finish-output.error.3 (check-type-error #'finish-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) gcl-2.6.14/ansi-tests/make-sequence.lsp0000644000175000017500000001472314360276512016337 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Sep 14 09:58:47 2002 ;;;; Contains: Tests for MAKE-SEQUENCE (in-package :cl-test) (deftest make-sequence.1 (let ((x (make-sequence 'list 4))) (and (eql (length x) 4) (listp x) (loop for e in x always (eql (car x) e)) t)) t) (deftest make-sequence.2 (make-sequence 'list 4 :initial-element 'a) (a a a a)) (deftest make-sequence.3 (let ((x (make-sequence 'cons 4))) (and (eql (length x) 4) (listp x) (loop for e in x always (eql (car x) e)) t)) t) (deftest make-sequence.4 (make-sequence 'cons 4 :initial-element 'a) (a a a a)) (deftest make-sequence.5 (make-sequence 'string 10 :initial-element #\a) "aaaaaaaaaa") (deftest make-sequence.6 (let ((s (make-sequence 'string 10))) (and (eql (length s) 10) (loop for e across s always (eql e (aref s 0))) t)) t) (deftest make-sequence.7 (make-sequence 'simple-string 10 :initial-element #\a) "aaaaaaaaaa") (deftest make-sequence.8 (let ((s (make-sequence 'simple-string 10))) (and (eql (length s) 10) (loop for e across s always (eql e (aref s 0))) t)) t) (deftest make-sequence.9 (make-sequence 'null 0) nil) (deftest make-sequence.10 (let ((x (make-sequence 'vector 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.11 (let* ((u (list 'a)) (x (make-sequence 'vector 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.12 (let ((x (make-sequence 'simple-vector 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.13 (let* ((u (list 'a)) (x (make-sequence 'simple-vector 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.14 (let ((x (make-sequence '(vector *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.15 (let* ((u (list 'a)) (x (make-sequence '(vector *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.16 (let ((x (make-sequence '(simple-vector *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.17 (let* ((u (list 'a)) (x (make-sequence '(simple-vector *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.18 (let ((x (make-sequence '(string *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.19 (let* ((u #\a) (x (make-sequence '(string *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.20 (let ((x (make-sequence '(simple-string *) 10))) (and (eql (length x) 10) (loop for e across x always (eql e (aref x 0))) t)) t) (deftest make-sequence.21 (let* ((u #\a) (x (make-sequence '(simple-string *) 10 :initial-element u))) (and (eql (length x) 10) (loop for e across x always (eql e u)) t)) t) (deftest make-sequence.22 (make-sequence '(vector * 5) 5 :initial-element 'a) #(a a a a a)) (deftest make-sequence.23 (make-sequence '(vector fixnum 5) 5 :initial-element 1) #(1 1 1 1 1)) (deftest make-sequence.24 (make-sequence '(vector (integer 0 255) 5) 5 :initial-element 17) #(17 17 17 17 17)) (deftest make-sequence.25 (make-sequence '(simple-vector 5) 5 :initial-element 'a) #(a a a a a)) (deftest make-sequence.26 (equalp (make-sequence 'string 5) (make-string 5)) t) ;;; Keyword tests (deftest make-sequence.allow-other-keys.1 (make-sequence 'list 5 :allow-other-keys t :initial-element 'a :bad t) (a a a a a)) (deftest make-sequence.allow-other-keys.2 (make-sequence 'list 5 :initial-element 'a :bad t :allow-other-keys t) (a a a a a)) (deftest make-sequence.allow-other-keys.3 (make-sequence 'list 5 :initial-element 'a :allow-other-keys t) (a a a a a)) (deftest make-sequence.allow-other-keys.4 (make-sequence 'list 5 :initial-element 'a :allow-other-keys nil) (a a a a a)) (deftest make-sequence.allow-other-keys.5 (make-sequence 'list 5 :initial-element 'a :allow-other-keys t :allow-other-keys nil :bad t) (a a a a a)) (deftest make-sequence.keywords.6 (make-sequence 'list 5 :initial-element 'a :initial-element 'b) (a a a a a)) ;;; Tests for errors (deftest make-sequence.error.1 (classify-error (make-sequence 'symbol 10)) type-error) (deftest make-sequence.error.2 (classify-error (make-sequence 'null 1)) type-error) (deftest make-sequence.error.3 (classify-error (make-sequence '(vector * 4) 3)) type-error) (deftest make-sequence.error.4 (classify-error (make-sequence '(vector * 2) 3)) type-error) (deftest make-sequence.error.5 (classify-error (make-sequence '(string 4) 3)) type-error) (deftest make-sequence.error.6 (classify-error (make-sequence '(simple-string 2) 3)) type-error) (deftest make-sequence.error.7 (classify-error (make-sequence 'cons 0)) type-error) (deftest make-sequence.error.8 (classify-error (make-sequence)) program-error) (deftest make-sequence.error.9 (classify-error (make-sequence 'list)) program-error) (deftest make-sequence.error.10 (classify-error (make-sequence 'list 10 :bad t)) program-error) (deftest make-sequence.error.11 (classify-error (make-sequence 'list 10 :bad t :allow-other-keys nil)) program-error) (deftest make-sequence.error.12 (classify-error (make-sequence 'list 10 :initial-element)) program-error) (deftest make-sequence.error.13 (classify-error (make-sequence 'list 10 0 0)) program-error) (deftest make-sequence.error.14 (classify-error (locally (make-sequence 'symbol 10) t)) type-error) ;;; Order of execution tests (deftest make-sequence.order.1 (let ((i 0) a b c) (values (make-sequence (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) 5) :initial-element (progn (setf c (incf i)) 'a)) i a b c)) (a a a a a) 3 1 2 3) (deftest make-sequence.order.2 (let ((i 0) a b c d e) (values (make-sequence (progn (setf a (incf i)) 'list) (progn (setf b (incf i)) 5) :allow-other-keys (setf c (incf i)) :initial-element (progn (setf d (incf i)) 'a) :foo (setf e (incf i))) i a b c d e)) (a a a a a) 5 1 2 3 4 5) gcl-2.6.14/ansi-tests/cons-test-12.lsp0000644000175000017500000000375314360276512015754 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:26 1998 ;;;; Contains: Testing of CL Features related to "CONS", part 12 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nthcdr (deftest nthcdr.error.1 (classify-error (nthcdr nil (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.2 (classify-error (nthcdr 'a (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.3 (classify-error (nthcdr 0.1 (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.4 (classify-error (nthcdr #\A (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.5 (classify-error (nthcdr '(a) (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.6 (classify-error (nthcdr -10 (copy-tree '(a b c d)))) type-error) (deftest nthcdr.error.7 (classify-error (nthcdr)) program-error) (deftest nthcdr.error.8 (classify-error (nthcdr 0)) program-error) (deftest nthcdr.error.9 (classify-error (nthcdr 0 nil nil)) program-error) (deftest nthcdr.error.10 (classify-error (nthcdr 3 (cons 'a 'b))) type-error) (deftest nthcdr.error.11 (classify-error (locally (nthcdr 'a (copy-tree '(a b c d))) t)) type-error) (deftest nthcdr.1 (nthcdr 0 (copy-tree '(a b c d . e))) (a b c d . e)) (deftest nthcdr.2 (nthcdr 1 (copy-tree '(a b c d))) (b c d)) (deftest nthcdr.3 (nthcdr 10 nil) nil) (deftest nthcdr.4 (nthcdr 4 (list 'a 'b 'c)) nil) (deftest nthcdr.5 (nthcdr 1 (cons 'a 'b)) b) (deftest nthcdr.order.1 (let ((i 0) x y) (values (nthcdr (setf x (incf i)) (progn (setf y (incf i)) '(a b c d))) i x y)) (b c d) 2 1 2) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; rest (deftest rest.1 (rest (list 'a 'b 'c)) (b c)) (deftest rest.order.1 (let ((i 0)) (values (rest (progn (incf i) '(a b))) i)) (b) 1) (deftest rest.error.1 (classify-error (rest)) program-error) (deftest rest.error.2 (classify-error (rest nil nil)) program-error) gcl-2.6.14/ansi-tests/echo-stream-input-stream.lsp0000644000175000017500000000134614360276512020446 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Feb 12 04:30:40 2004 ;;;; Contains: Tests of ECHO-STREAM-INPUT-STREAM (in-package :cl-test) (deftest echo-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-input-stream s)) (list is))) t) (deftest echo-stream-input-stream.error.1 (signals-error (echo-stream-input-stream) program-error) t) (deftest echo-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) (os (make-string-output-stream)) (s (make-echo-stream is os))) (echo-stream-input-stream s nil)) program-error) t) gcl-2.6.14/ansi-tests/catch.lsp0000644000175000017500000000237114360276512014672 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 12 13:04:02 2002 ;;;; Contains: Tests of CATCH and THROW (in-package :cl-test) (deftest catch.1 (catch 'foo) nil) (deftest catch.2 (catch 'foo 'a) a) (deftest catch.3 (catch 'foo (values))) (deftest catch.4 (catch 'foo (values 1 2 3)) 1 2 3) (deftest catch.5 (catch 'foo 'a (throw 'foo 'b) 'c) b) (deftest catch.6 (let ((tag1 (1+ most-positive-fixnum)) (tag2 (1+ most-positive-fixnum))) (if (eqt tag1 tag2) 'good (catch tag1 (catch tag2 (throw tag1 'good)) 'bad))) good) (deftest catch.7 (catch 'foo 'a (throw 'foo (values)) 'c)) (deftest catch.8 (catch 'foo 'a (throw 'foo (values 1 2 3)) 'c) 1 2 3) (deftest catch.9 (let ((i 0)) (catch (progn (incf i) 'foo) (assert (eql i 1)) (throw (progn (incf i 2) 'foo) i))) 3) (deftest catch.10 (flet ((%f (x) (throw 'foo x))) (catch 'foo (%f 'good) 'bad)) good) (defun catch.11-fn (x) (throw 'foo x)) (deftest catch.11 (catch 'foo (catch.11-fn 'good) 'bad) good) (deftest catch.12 (labels ((%f (x) (throw 'foo x))) (catch 'foo (%f 'good) 'bad)) good) (deftest throw-error (classify-error (throw (gensym) nil)) control-error) gcl-2.6.14/ansi-tests/make-broadcast-stream.lsp0000644000175000017500000000533014360276512017754 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Jan 29 21:28:25 2004 ;;;; Contains: Tests of MAKE-BROADCAST-STREAM (in-package :cl-test) (deftest make-broadcast-stream.1 (let ((s (make-broadcast-stream))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) ;; (assert (eq (stream-element-type s) t)) (values (notnot (typep s 'stream)) (notnot (typep s 'broadcast-stream)) (notnot (output-stream-p s)) (progn (write-char #\x s) nil) )) t t t nil) (deftest make-broadcast-stream.2 (with-output-to-string (s1) (let ((s (make-broadcast-stream s1))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) (stream-element-type s1))) (write-char #\x s))) "x") (deftest make-broadcast-stream.3 (let ((s1 (make-string-output-stream)) (s2 (make-string-output-stream))) (let ((s (make-broadcast-stream s1 s2))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) (assert (output-stream-p s)) ;; (assert (not (input-stream-p s))) (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) (stream-element-type s2))) (format s "This is a test")) (values (get-output-stream-string s1) (get-output-stream-string s2))) "This is a test" "This is a test") (deftest make-broadcast-stream.4 (fresh-line (make-broadcast-stream)) nil) (deftest make-broadcast-stream.5 (file-length (make-broadcast-stream)) 0) (deftest make-broadcast-stream.6 (file-position (make-broadcast-stream)) 0) (deftest make-broadcast-stream.7 (file-string-length (make-broadcast-stream) "antidisestablishmentarianism") 1) (deftest make-broadcast-stream.8 (stream-external-format (make-broadcast-stream)) :default) ;;; FIXME ;;; Add tests for: close, ;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, ;;; read-line, write-line, write-string, read-sequence, write-sequence, ;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, ;;; clear-output, print, prin1 princ ;;; Error tests (deftest make-broadcast-stream.error.1 (check-type-error #'make-broadcast-stream #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-broadcast-stream.error.2 (check-type-error #'make-broadcast-stream #'(lambda (x) (and (streamp x) (output-stream-p x))) *streams*) nil) gcl-2.6.14/ansi-tests/and.lsp0000644000175000017500000000144014360276512014346 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 07:23:48 2002 ;;;; Contains: Tests for AND (in-package :cl-test) (deftest and.1 (and) t) (deftest and.2 (and nil) nil) (deftest and.3 (and 'a) a) (deftest and.4 (and (values 'a 'b 'c)) a b c) (deftest and.5 (and (values))) (deftest and.6 (and (values t nil) 'a) a) (deftest and.7 (and nil (values 'a 'b 'c)) nil) (deftest and.8 (and (values 1 nil) (values nil 2)) nil 2) (deftest and.9 (and (values nil t) t) nil) (deftest and.order.1 (let ((x 0)) (values (and nil (incf x)) x)) nil 0) (deftest and.order.2 (let ((i 0) a b c d) (values (and (setf a (incf i)) (setf b (incf i)) (setf c (incf i)) (setf d (incf i))) i a b c d)) 4 4 1 2 3 4) gcl-2.6.14/ansi-tests/bit-ior.lsp0000644000175000017500000001426114360276512015156 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 19:13:34 2003 ;;;; Contains: Tests of BIT-IOR (in-package :cl-test) (deftest bit-ior.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-ior.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 #0a0) (deftest bit-ior.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-ior.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 #0a1) (deftest bit-ior.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-ior.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 #0a1 #0a1 t) (deftest bit-ior.7 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-ior s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a1 #0a1 t) ;;; Tests on bit vectors (deftest bit-ior.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2)) a1 a2)) #*0111 #*0011 #*0101) (deftest bit-ior.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-ior a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0111 #*0111 #*0101 t) (deftest bit-ior.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*1110)) (result (check-values (bit-ior a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0111 #*0011 #*0101 #*0111 t) (deftest bit-ior.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2 nil)) a1 a2)) #*0111 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-ior.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-ior a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-ior a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1)) #2a((0 1)(1 1))) ;;; Adjustable arrays (deftest bit-ior.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) ;;; Displaced arrays (deftest bit-ior.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-ior a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-ior a1 a2 t))) (values a0 a1 a2 result)) #*01110011 #2a((0 1)(1 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-ior a1 a2 a3))) (values a0 a1 a2 result)) #*010100110111 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 1)(1 1))) (deftest bit-ior.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-ior (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-ior.error.1 (classify-error (bit-ior)) program-error) (deftest bit-ior.error.2 (classify-error (bit-ior #*000)) program-error) (deftest bit-ior.error.3 (classify-error (bit-ior #*000 #*0100 nil nil)) program-error) gcl-2.6.14/ansi-tests/ctypecase.lsp0000644000175000017500000000304414360276512015566 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Fri Oct 18 23:05:10 2002 ;;;; Contains: Tests of CTYPECASE (in-package :cl-test) (deftest ctypecase.1 (let ((x 1)) (ctypecase x (integer 'a) (t 'b))) a) (deftest ctypecase.2 (classify-error (let ((x 1)) (ctypecase x (symbol 'a)))) type-error) (deftest ctypecase.3 (let ((x 1)) (ctypecase x (symbol 'a) (t 'b))) b) (deftest ctypecase.4 (let ((x 1)) (ctypecase x (t (values))))) (deftest ctypecase.5 (let ((x 1)) (ctypecase x (integer (values)) (t 'a)))) (deftest ctypecase.6 (let ((x 1)) (ctypecase x (bit 'a) (integer 'b))) a) (deftest ctypecase.7 (let ((x 1)) (ctypecase x (t 'a))) a) (deftest ctypecase.8 (let ((x 1)) (ctypecase x (t (values 'a 'b 'c)))) a b c) (deftest ctypecase.9 (let ((x 1)) (ctypecase x (integer (values 'a 'b 'c)) (t nil))) a b c) (deftest ctypecase.10 (let ((x 0) (y 1)) (values (ctypecase y (bit (incf x) 'a) (integer (incf x 2) 'b) (t (incf x 4) 'c)) x)) a 1) (deftest ctypecase.11 (let ((x 1)) (ctypecase x (integer) (t 'a))) nil) (deftest ctypecase.12 (let ((x 1)) (values (handler-bind ((type-error #'(lambda (c) (store-value 'a c)))) (ctypecase x (symbol :good) (float :bad))) x)) :good a) ;;; (deftest ctypecase.error.1 ;;; (classify-error (ctypecase)) ;;; program-error) (deftest ctypecase.13 (ctypecase 'a (number 'bad) (#.(find-class 'symbol nil) 'good)) good) gcl-2.6.14/ansi-tests/values.lsp0000644000175000017500000000230014360276512015077 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Oct 19 08:18:50 2002 ;;;; Contains: Tests of VALUES (in-package :cl-test) (deftest values.0 (values)) (deftest values.1 (values 1) 1) (deftest values.2 (values 1 2) 1 2) (deftest values.3 (values 1 2 3) 1 2 3) (deftest values.4 (values 1 2 3 4) 1 2 3 4) (deftest values.10 (values 1 2 3 4 5 6 7 8 9 10) 1 2 3 4 5 6 7 8 9 10) (deftest values.15 (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (deftest values.19 (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) (deftest values.A (values (values 1 2) (values 3 4 5) (values) (values 10)) 1 3 nil 10) (deftest values.B (funcall #'values 1 2 3 4) 1 2 3 4) (deftest values.C (let ((x (loop for i from 1 to (min 1000 (1- call-arguments-limit) (1- multiple-values-limit)) collect i))) (equalt x (multiple-value-list (apply #'values x)))) t) (deftest values.order.1 (let ((i 0) a b c) (values (multiple-value-list (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) i a b c)) (1 2 3) 3 1 2 3) gcl-2.6.14/ansi-tests/defvar.lsp0000644000175000017500000000261314360276512015056 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Oct 10 23:21:50 2002 ;;;; Contains: Tests for DEFVAR (in-package :cl-test) (defvar *defvar-test-var-1* 100) (deftest defvar.1 *defvar-test-var-1* 100) (deftest defvar.2 (documentation '*defvar-test-var-1* 'variable) nil) ;;; Show that it's declared special. (deftest defvar.3 (flet ((%f () *defvar-test-var-1*)) (let ((*defvar-test-var-1* 29)) (%f))) 29) (deftest defvar.4 (values (makunbound '*defvar-test-var-2*) (defvar *defvar-test-var-2* 200 "Whatever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2*) *defvar-test-var-2* *defvar-test-var-2* "Whatever." 200) (deftest defvar.5 (let ((x 0)) (values (makunbound '*defvar-test-var-2*) (defvar *defvar-test-var-2* 200 "Whatever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2* (defvar *defvar-test-var-2* (incf x) "And ever.") (documentation '*defvar-test-var-2* 'variable) *defvar-test-var-2* x )) *defvar-test-var-2* *defvar-test-var-2* "Whatever." 200 *defvar-test-var-2* "And ever." 200 0) ;;; (deftest defvar.error.1 ;;; (classify-error (defvar)) ;;; program-error) ;;; ;;; (deftest defvar.error.2 ;;; (classify-error (defvar *ignored-defvar-name* nil "documentation" ;;; "illegal extra argument")) ;;; program-error) gcl-2.6.14/ansi-tests/fmakunbound.lsp0000644000175000017500000000265214360276512016123 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Tue Oct 8 00:09:14 2002 ;;;; Contains: Tests for FMAKUNBOUND (in-package :cl-test) (deftest fmakunbound.1 (let ((g (gensym))) (and (not (fboundp g)) (setf (symbol-function g) #'car) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.2 (let ((g (gensym))) (and (not (fboundp g)) (eval `(defun ,g () nil)) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.3 (let ((g (gensym))) (and (not (fboundp g)) (eval `(defmacro ,g () nil)) (fboundp g) (values (eqt (check-values (fmakunbound g)) g) (fboundp g)))) t nil) (deftest fmakunbound.4 (let* ((g (gensym)) (n `(setf ,g))) (and (not (fboundp n)) (eval `(defun ,n () nil)) (fboundp n) (values (equal (check-values (fmakunbound n)) n) (fboundp n)))) t nil) (deftest fmakunbound.error.1 (classify-error (fmakunbound 1)) type-error) (deftest fmakunbound.error.2 (classify-error (fmakunbound #\a)) type-error) (deftest fmakunbound.error.3 (classify-error (fmakunbound '(x))) type-error) (deftest fmakunbound.error.4 (classify-error (fmakunbound)) program-error) (deftest fmakunbound.error.5 (classify-error (fmakunbound (gensym) nil)) program-error) (deftest fmakunbound.error.6 (classify-error (locally (fmakunbound 1) t)) type-error) gcl-2.6.14/ansi-tests/loop9.lsp0000644000175000017500000001136414360276512014654 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Thu Nov 14 06:25:21 2002 ;;;; Contains: Tests for loop list accumulation clauses (in-package :cl-test) ;;; Tests of COLLECT, COLLECTING (deftest loop.9.1 (loop for x in '(2 3 4) collect (1+ x)) (3 4 5)) (deftest loop.9.2 (loop for x in '(2 3 4) collecting (1+ x)) (3 4 5)) (deftest loop.9.3 (loop for x in '(0 1 2) when (eql x 2) do (return 'good) collect x) good) (deftest loop.9.4 (loop for x in '(a b c) collect (list x) into foo finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.5 (loop for x in '(a b c) collecting (list x) into foo finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.6 (loop for x from 1 to 10 when (evenp x) collect x into foo when (oddp x) collect x into bar finally (return (list foo bar))) ((2 4 6 8 10) (1 3 5 7 9))) (deftest loop.9.7 (loop for x from 1 to 10 collect (if (> x 5) (loop-finish) x)) (1 2 3 4 5)) (deftest loop.9.8 (loop for x from 1 to 20 when (eql (mod x 5) 0) collect x into foo when (eql (mod x 5) 2) collect x into foo finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.9 (loop for x from 1 to 20 when (eql (mod x 5) 0) collecting x into foo when (eql (mod x 5) 2) collecting x into foo finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.10 (classify-error (loop with foo = '(a b) for x in '(c d) collect x into foo finally (return foo))) program-error) (deftest loop.9.11 (classify-error (loop with foo = '(a b) for x in '(c d) collecting x into foo finally (return foo))) program-error) (deftest loop.9.12 (let ((foo '(a b))) (values (loop for x in '(c d e) collect x into foo finally (return foo)) foo)) (c d e) (a b)) ;;; Tests of APPEND, APPENDING (deftest loop.9.20 (loop for x in '((a b) (c d) (e f g) () (i)) append x) (a b c d e f g i)) (deftest loop.9.21 (loop for x in '((a b) (c d) (e f g) () (i)) appending x) (a b c d e f g i)) (deftest loop.9.22 (loop for x in '((a) (b) (c . whatever)) append x) (a b c . whatever)) (deftest loop.9.23 (loop for x in '((a) (b) (c . whatever)) appending x) (a b c . whatever)) (deftest loop.9.24 (loop for x in '(a b c d) append (list x) when (eq x 'b) append '(1 2 3) when (eq x 'd) appending '(4 5 6)) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.25 (let (z) (values (loop for x in '((a) (b) (c) (d)) append x into foo finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.26 (loop for x in '((a) (b) (c) (d)) for i from 1 append x into foo append x into foo appending (list i) into foo finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.27 (classify-error (loop with foo = '(a b) for x in '(c d) append (list x) into foo finally (return foo))) program-error) (deftest loop.9.28 (classify-error (loop with foo = '(a b) for x in '(c d) appending (list x) into foo finally (return foo))) program-error) ;;; NCONC, NCONCING (deftest loop.9.30 (loop for x in '((a b) (c d) (e f g) () (i)) nconc (copy-seq x)) (a b c d e f g i)) (deftest loop.9.31 (loop for x in '((a b) (c d) (e f g) () (i)) nconcing (copy-seq x)) (a b c d e f g i)) (deftest loop.9.32 (loop for x in '((a) (b) (c . whatever)) nconc (cons (car x) (cdr x))) (a b c . whatever)) (deftest loop.9.33 (loop for x in '((a) (b) (c . whatever)) nconcing (cons (car x) (cdr x))) (a b c . whatever)) (deftest loop.9.34 (loop for x in '(a b c d) nconc (list x) when (eq x 'b) nconc (copy-seq '(1 2 3)) when (eq x 'd) nconcing (copy-seq '(4 5 6))) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.35 (let (z) (values (loop for x in '((a) (b) (c) (d)) nconc (copy-seq x) into foo finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.36 (loop for x in '((a) (b) (c) (d)) for i from 1 nconc (copy-seq x) into foo nconc (copy-seq x) into foo nconcing (list i) into foo finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.37 (classify-error (loop with foo = '(a b) for x in '(c d) nconc (list x) into foo finally (return foo))) program-error) (deftest loop.9.38 (classify-error (loop with foo = '(a b) for x in '(c d) nconcing (list x) into foo finally (return foo))) program-error) ;;; Combinations (deftest loop.9.40 (loop for x in '(1 2 3 4 5 6 7) if (< x 2) append (list x) else if (< x 5) nconc (list (1+ x)) else collect (+ x 2)) (1 3 4 5 7 8 9)) (deftest loop.9.41 (loop for x in '(1 2 3 4 5 6 7) if (< x 2) append (list x) into foo else if (< x 5) nconc (list (1+ x)) into foo else collect (+ x 2) into foo finally (return foo)) (1 3 4 5 7 8 9)) ;;; More nconc tests (deftest loop.9.42 (loop for x in '(a b c d e) nconc (cons x 'foo)) (a b c d e . foo)) gcl-2.6.14/ansi-tests/search-vector.lsp0000644000175000017500000001157514360276512016363 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Aug 25 13:06:54 2002 ;;;; Contains: Tests for SEARCH on vectors (in-package :cl-test) (deftest search-vector.1 (let ((target *searched-vector*) (pat #(a))) (loop for i from 0 to (1- (length target)) for tail on target always (let ((pos (search pat tail))) (search-check pat tail pos)))) t) (deftest search-vector.2 (let ((target *searched-vector*) (pat #(a))) (loop for i from 1 to (length target) always (let ((pos (search pat target :end2 i :from-end t))) (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-vector.3 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target) unless (search-check pat target pos) collect pat)) nil) (deftest search-vector.4 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t) unless (search-check pat target pos :from-end t) collect pat)) nil) (deftest search-vector.5 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 25 :end2 75) unless (search-check pat target pos :start2 25 :end2 75) collect pat)) nil) (deftest search-vector.6 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 25 :end2 75) unless (search-check pat target pos :from-end t :start2 25 :end2 75) collect pat)) nil) (deftest search-vector.7 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 20) unless (search-check pat target pos :start2 20) collect pat)) nil) (deftest search-vector.8 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 20) unless (search-check pat target pos :from-end t :start2 20) collect pat)) nil) (deftest search-vector.9 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) *searched-list*))) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 3) (b . 4)) y)) x)) *pattern-sublists*) for pos = (search pat target :start2 20 :key #'evenp) unless (search-check pat target pos :start2 20 :key #'evenp) collect pat)) nil) (deftest search-vector.10 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) *searched-list*))) (loop for pat in (mapcar #'(lambda (x) (map 'vector #'(lambda (y) (sublis '((a . 3) (b . 4)) y)) x)) *pattern-sublists*) for pos = (search pat target :from-end t :start2 20 :key 'oddp) unless (search-check pat target pos :from-end t :start2 20 :key 'oddp) collect pat)) nil) (deftest search-vector.11 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :start2 20 :test (complement #'eql)) unless (search-check pat target pos :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-vector.12 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* for pos = (search pat target :from-end t :start2 20 :test-not #'eql) unless (search-check pat target pos :from-end t :start2 20 :test (complement #'eql)) collect pat)) nil) (deftest search-vector.13 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* when (and (> (length pat) 0) (let ((pos (search pat target :start1 1 :test (complement #'eql)))) (not (search-check pat target pos :start1 1 :test (complement #'eql))))) collect pat)) nil) (deftest search-vector.14 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* when (let ((len (length pat))) (and (> len 0) (let ((pos (search pat target :end1 (1- len) :test (complement #'eql)))) (not (search-check pat target pos :end1 (1- len) :test (complement #'eql)))))) collect pat)) nil) (deftest search-vector.15 (let ((a (make-array '(10) :initial-contents '(a b b a a a b a b b) :fill-pointer 5))) (values (search '(a) a) (search '(a) a :from-end t) (search '(a b) a) (search '(a b) a :from-end t) (search '(a b a) a) (search '(a b a) a :from-end t))) 0 4 0 0 nil nil) (deftest search-vector.16 (let ((pat (make-array '(3) :initial-contents '(a b a) :fill-pointer 1)) (a #(a b b a a))) (values (search pat a) (search pat a :from-end t) (progn (setf (fill-pointer pat) 2) (search pat a)) (search pat a :from-end t) (progn (setf (fill-pointer pat) 3) (search pat a)) (search pat a :from-end t))) 0 4 0 0 nil nil) gcl-2.6.14/ansi-tests/lambda-list-keywords.lsp0000644000175000017500000000200514360276512017640 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Mon Oct 7 22:11:31 2002 ;;;; Contains: Tests for LAMBDA-LIST-KEYWORDS (in-package :cl-test) ;;; The variable is bound (deftest lambda-list-keywords.1 (not-mv (boundp 'lambda-list-keywords)) nil) ;;; The variable is a constant (deftest lambda-list-keywords.2 (not-mv (constantp 'lambda-list-keywords)) nil) ;;; The standard keywords are present in the list (deftest lambda-list-keywords.3 (and (consp lambda-list-keywords) (not-mv (set-difference '(&allow-other-keys &aux &body &environment &key &optional &rest &whole) lambda-list-keywords))) t) ;;; No lambda list keywords are in the keyword package (deftest lambda-list-keywords.4 (some #'keywordp lambda-list-keywords) nil) ;;; Every keyword starts with an ampersand (deftest lambda-list-keywords.5 (notevery #'(lambda (sym) (let ((name (symbol-name sym))) (and (> (length name) 0) (eql (aref name 0) #\&)))) lambda-list-keywords) nil) gcl-2.6.14/ansi-tests/bit-andc1.lsp0000644000175000017500000001441114360276512015350 0ustar cammcamm;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sun Jan 26 18:56:39 2003 ;;;; Contains: Tests of BIT-ANDC1 (in-package :cl-test) (deftest bit-andc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a0 #0a0) (deftest bit-andc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 #0a0) (deftest bit-andc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a1 #0a0 #0a1) (deftest bit-andc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 #0a1) (deftest bit-andc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (s3 (make-array nil :initial-element 1 :element-type 'bit)) (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 #0a0 #0a0 t) (deftest bit-andc1.6 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) (s2 (make-array nil :initial-element 1 :element-type 'bit)) (s3 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a1 #0a1 #0a1 t) (deftest bit-andc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) (s2 (make-array nil :initial-element 0 :element-type 'bit)) (result (bit-andc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 #0a0 t) ;;; Tests on bit vectors (deftest bit-andc1.8 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2)) a1 a2)) #*0100 #*0011 #*0101) (deftest bit-andc1.9 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (result (check-values (bit-andc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0100 #*0100 #*0101 t) (deftest bit-andc1.10 (let* ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101)) (a3 (copy-seq #*0000)) (result (check-values (bit-andc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0100 #*0011 #*0101 #*0100 t) (deftest bit-andc1.11 (let ((a1 (copy-seq #*0011)) (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2 nil)) a1 a2)) #*0100 #*0011 #*0101) ;;; Tests on bit arrays (deftest bit-andc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2 t))) (values a1 a2 result)) #2a((0 0)(1 0)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (result (bit-andc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)))) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)))) (a3 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(0 0)))) (result (bit-andc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0)) #2a((0 0)(1 0))) ;;; Adjustable arrays (deftest bit-andc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit :initial-contents '((0 1)(0 1)) :adjustable t)) (a2 (make-array '(2 2) :element-type 'bit :initial-contents '((0 0)(1 1)) :adjustable t)) (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) ;;; Displaced arrays (deftest bit-andc1.17 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.18 (let* ((a0 (make-array '(8) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (result (bit-andc1 a1 a2 t))) (values a0 a1 a2 result)) #*00100011 #2a((0 0)(1 0)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.19 (let* ((a0 (make-array '(12) :element-type 'bit :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) (a1 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 0)) (a2 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 4)) (a3 (make-array '(2 2) :element-type 'bit :displaced-to a0 :displaced-index-offset 8)) (result (bit-andc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110010 #2a((0 1)(0 1)) #2a((0 0)(1 1)) #2a((0 0)(1 0))) (deftest bit-andc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) (s2 (make-array 1 :initial-element 0 :element-type 'bit)) (x 0) y z) (values (bit-andc1 (progn (setf y (incf x)) s1) (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) ;;; Error tests (deftest bit-andc1.error.1 (classify-error (bit-andc1)) program-error) (deftest bit-andc1.error.2 (classify-error (bit-andc1 #*000)) program-error) (deftest bit-andc1.error.3 (classify-error (bit-andc1 #*000 #*0100 nil nil)) program-error) gcl-2.6.14/majvers0000755000175000017500000000000214360276512012360 0ustar cammcamm2 gcl-2.6.14/h/0000755000175000017500000000000014360276512011222 5ustar cammcammgcl-2.6.14/h/elf32_s390_reloc.h0000644000175000017500000000031114360276512014243 0ustar cammcamm case R_390_32: add_val(where,~0L,s+a); break; case R_390_PC32: add_val(where,~0L,s+a-p); break; case R_390_PC32DBL: add_val(where,~0L,(s+a-p)>>1); break; gcl-2.6.14/h/irix5.defs0000755000175000017500000000324714360276512013136 0ustar cammcamm# Has been tested on SGI IRIX Version 5 # Machine dependent makefile definitions for SGI Iris LBINDIR=/usr/local/bin OFLAG = LIBS = -lm -lbsd ODIR_DEBUG= -O NULLFILE = ../h/twelve_null SHELL=/bin/sh # .IGNORE: # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # also defined in `machine'.h file # The one here must be >= the one in the .h file. # It must be a multiple of 0x200000 greater that 0x400000 the # default text start. DBEGIN= A00000 # If you don't plan on linking in a lot of other stuff # like maxima, you can increase the -G 8 to -G 800 or so. # That should be a bit faster.. # these were the previous ones... if you have trouble with -common try this.. # why do we need so many flags........... # CC = cc -xansi -D__STDC__ -DVOL=volatile -Olimit 798 -G 8 -I${GCLDIR}/o -I/usr/include/bsd # LDCC = cc -Wl,-D -Wl,${DBEGIN} #CC = cc -xansi -D__STDC__ -DVOL=volatile -Olimit 798 -G 8 -common -I${GCLDIR}/o -I/usr/include/bsd CC = cc -xansi -D__STDC__ -DVOL=volatile -Olimit 1040 -common -I${GCLDIR}/o -I/usr/include/bsd -signed CFLAGS= -c -O -I../h LDCC = cc -Wl,-D -Wl,${DBEGIN} -common # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # incremental loading with -A requires -G 0 INITFORM=(setq compiler::*cc* "cc -DVOL=volatile -G 0 ") # Use symbolic links SYMB=-s EMUL= $(ODIR)/sgi4d_emul.o MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a RANLIB= ar lts gcl-2.6.14/h/mac2.defs0000755000175000017500000000172214360276512012714 0ustar cammcamm# tested on under A/UX 3.0 with gcc 2.5.7, gcl version 1.1 # Machine dependent makefile definitions for mac2 RANLIB=true LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm -lg ODIR_DEBUG= # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # CC = cc -DVOL= -Bstatic -I$(GCLDIR)/o # If you have a good gcc (not version 1.36 it has a bug) 1.35 is ok. CC = gcc $(MCFLAGS) -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o #LIBS = -lm -lg /usr/local/Gnu/lib/gcc-gnulib MCFLAGS=-D_BSD_SOURCE -D_SYSV_SOURCE # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-unix MPFILES= $(MPDIR)/mpi-gcc.o $(MPDIR)/libmport.a gcl-2.6.14/h/elf64_aarch64_reloc.h0000644000175000017500000000366114360276512015015 0ustar cammcamm case R_AARCH64_ABS64: /* .xword: (S+A) */ store_val(where,~0L,s+a); break; case R_AARCH64_ABS32: /* .word: (S+A) */ store_val(where,MASK(32),s+a); break; case R_AARCH64_JUMP26: /* B: ((S+A-P) >> 2) & 0x3ffffff. */ case R_AARCH64_CALL26: /* BL: ((S+A-P) >> 2) & 0x3ffffff. */ { long x=((long)(s+a-p))/4; if (abs(x)&(~MASK(25))) { if (a) { got+=gotp; gotp+=tz; } else got+=(sym->st_size-1)*tz; *got++=s+a; memcpy(got,tramp,sizeof(tramp)); x=((long)got-p)/4; } store_vals(where,MASK(26),x); } break; case R_AARCH64_ADR_PREL_PG_HI21: /* ADRH: ((PG(S+A)-PG(P)) >> 12) & 0x1fffff */ #define PG(x) ((x) & ~0xfff) s = ((long)(PG(s+a)-PG(p))) / 0x1000; store_val(where,MASK(2) << 29, (s & 0x3) << 29); store_val(where,MASK(19) << 5, (s & 0x1ffffc) << 3); #undef PG break; case R_AARCH64_ADD_ABS_LO12_NC: /* ADD: (S+A) & 0xfff */ store_val(where,MASK(12) << 10,(s+a) << 10); break; case R_AARCH64_LDST8_ABS_LO12_NC: /* LD/ST8: (S+A) & 0xfff */ store_val(where,MASK(12) << 10,((s+a) & 0xfff) << 10); break; case R_AARCH64_LDST16_ABS_LO12_NC: /* LD/ST16: (S+A) & 0xffe */ store_val(where,MASK(12) << 10,((s+a) & 0xffe) << 9); break; case R_AARCH64_LDST32_ABS_LO12_NC: /* LD/ST32: (S+A) & 0xffc */ store_val(where,MASK(12) << 10,((s+a) & 0xffc) << 8); break; case R_AARCH64_LDST64_ABS_LO12_NC: /* LD/ST64: (S+A) & 0xff8 */ store_val(where,MASK(12) << 10,((s+a) & 0xff8) << 7); break; case R_AARCH64_LDST128_ABS_LO12_NC: /* LD/ST128: (S+A) & 0xff0 */ store_val(where,MASK(12) << 10,((s+a) & 0xff0) << 6); break; case R_AARCH64_PREL64: store_val(where,~0L,(s+a-p)); break; case R_AARCH64_PREL32: store_val(where,MASK(32),(s+a-p)); break; case R_AARCH64_PREL16: store_val(where,MASK(16),(s+a-p)); break; gcl-2.6.14/h/pool.h0000644000175000017500000000505214360276512012346 0ustar cammcammstatic ufixnum data_pages(void) { return page(2*(rb_end-rb_start)+((void *)heap_end-data_start)); } #ifndef NO_FILE_LOCKING #include #include #include #include #include static int pool=-1; static struct pool { ufixnum pid; ufixnum n; ufixnum s; } *Pool; static struct flock f,pl,*plp=&pl; static char gcl_pool[PATH_MAX]; static int set_lock(void) { errno=0; if (fcntl(pool,F_SETLKW,plp)) { if (errno==EINTR) set_lock(); return -1; } return 0; } static void lock_pool(void) { pl.l_type=F_WRLCK; massert(!set_lock()); } static void unlock_pool(void) { pl.l_type=F_UNLCK; massert(!set_lock()); } static void register_pool(int s) { lock_pool(); Pool->n+=s; Pool->s+=s*data_pages(); unlock_pool(); } static void open_pool(void) { if (pool==-1) { massert(!home_namestring1("~",1,FN1,sizeof(FN1))); massert(snprintf(gcl_pool,sizeof(gcl_pool),"%sgcl_pool",FN1)>=0); massert((pool=open(gcl_pool,O_CREAT|O_RDWR,0644))!=-1); massert(!ftruncate(pool,sizeof(struct pool))); massert((Pool=mmap(NULL,sizeof(struct pool),PROT_READ|PROT_WRITE,MAP_SHARED,pool,0))!=(void *)-1); pl.l_type=F_WRLCK; pl.l_whence=SEEK_SET; pl.l_start=sizeof(Pool->pid);; pl.l_len=0; f=pl; f.l_start=0; f.l_len=sizeof(Pool->pid); if (!fcntl(pool,F_SETLK,&f)) { Pool->pid=getpid(); lock_pool(); Pool->n=0; Pool->s=0; unlock_pool(); } f.l_type=F_RDLCK; plp=&f; massert(!set_lock()); plp=&pl; register_pool(1); massert(!atexit(close_pool)); } } #endif void close_pool(void) { #ifndef NO_FILE_LOCKING if (pool!=-1) { f.l_type=F_WRLCK; if (!fcntl(pool,F_SETLK,&f)) massert(!unlink(gcl_pool)); register_pool(-1); massert(!close(pool)); massert(!munmap(Pool,sizeof(struct pool))); pool=-1; } #endif } static void update_pool(fixnum val) { #ifndef NO_FILE_LOCKING if (multiprocess_memory_pool) { open_pool(); lock_pool(); Pool->s+=val; unlock_pool(); } #endif } static ufixnum get_pool(void) { ufixnum s; #ifndef NO_FILE_LOCKING if (multiprocess_memory_pool) { open_pool(); lock_pool(); s=Pool->s; unlock_pool(); } else #endif s=data_pages(); return s; } static void pool_check(void) { /* if (pool!=-1) */ /* massert(get_pool()==data_pages() */ /* ||!fprintf(stderr,"%lu %lu %lu\n",get_pool(),page((void *)heap_end-data_start),page(((rb_end-rb_start))))); */ } gcl-2.6.14/h/386-bsd.h0000755000175000017500000000603714360276512012472 0ustar cammcamm/* 386-bsd.h Hacked September/93 by Paul F. Werkowsksi for 386BSD. Tested on i486 EISA 16MB hardware/386BSD 0.1 + PatchKit 0.2.4 * gcc-2.3.3 * SGC enabled (big performance win but needs a small kernel hack) * Files in September-16-92-Systems.tar (PCL clcs loop clx) compile & run. CLUE also compiles and runs. 16 MB insufficient memory to compile CLIO. Hacked November/93 by Werkowski for FreeBSD. Essentially no changes except to use 'unexlin.c' instead of 'unixsave.c'. FreeBSD 1.0.2 has (at this time 17-Nov-93) a bug in stdio that needs repair before this will work - otherwise use libc.a from 386bsd pk2.4. The 'bug' is that vfprintf prints out a 0l0 as ' 0e+00' while gcl edit_double in print.d expects something like ' 0.00000000000e+00'. */ #include "bsd.h" /*#include "386.h" /* NOT if you want this to work on 386bsd!!!*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("386BSD"); #define I386 /* ?? this is apparently not used anywhere */ #define IEEEFLOAT /* #undef HAVE_XDR */ #define USE_ATT_TIME /* begin listen for input */ #undef LISTEN_FOR_INPUT /* default in bsd.h is loser in 386bsd */ #if 1 /* Required for CLX to work correctly */ #if defined IN_FILE #include #include #include #include #endif #define LISTEN_FOR_INPUT(fp) \ {\ int fd = ((FILE *)fp)->_file; \ static struct timeval tv = {0,0};\ static fd_set rmask; FD_ZERO(&rmask); FD_SET(fd,&rmask);\ select(fd+1,&rmask,NULL,NULL,&tv);\ return (FD_ISSET(fd,&rmask));\ } #endif /* end listen for input */ #define DATA_BEGIN (char *)N_DATADDR(header); #define UNIXSAVE "unexlin.c" #define RELOC_FILE "rel_sun3.c" /* for SFASL - enabled in bsd.h */ #define LITTLE_END /* also in */ #if 0 /* are these relics? */ #define USE_DIRENT #define GETPATHNAME #define PATHNAME_CACHE 10 /* ??? */ #endif #define HZ 60 /* this for GC */ /* #define PAGEWIDTH 12 /* i386 sees 4096 byte pages */ /* try out the gnu malloc */ #if 1 /* (conflict with PAGEWIDTH != 11) */ #define GNU_MALLOC /* works if PAGEWIDTH==11 */ #define GNUMALLOC #endif #if 0 /* wont work, but need to patch realloc to return something if ptr is null */ #define DONT_NEED_MALLOC #endif /* Begin for cmpinclude */ #define WANT_SGC #ifdef WANT_SGC /* begin defines for SGC */ /* SGC is a performance winner for large applications as it doesn't run the entire image through the pager during collection. SGC requires the 'mprotect' function. Need Jeffrey Hsu's kernel patch for signal handlers. Should be in FreeBSD versions later than 1.0.2. Also need to add #include before #include in c/sgc.c Also - the above handler conflicts with use of '(un)catch-bad-signals' You may want to modify unixint.c to account for SGC use. */ #define SGC #define SIGPROTV SIGBUS #endif /* end of SGC mods */ /* _setjmp and _longjmp exist on bsd and are more efficient and handle the C stack which is all we need. [I think!] */ #define setjmp _setjmp #define longjmp _longjmp gcl-2.6.14/h/sun386i.defs0000755000175000017500000000234414360276512013312 0ustar cammcammLBINDIR=/usr/local/bin OFLAG = -g LIBS = -lm -lg # for sun386i: CHTAB = mp386_chtab.s # -I$(GCLDIR)/o is so that the cc command will be able to find a # cmpinclude.h even if it is not in /usr/include. We do not use the # h directory since there are so many .h files there, one of their # names might conflict with a users name, eg if he has a file vs.lisp #note: -Bstatic will have to be added to the 'ld' command in unixport/makefile #note: maybe '-fomit-frame-pointer' should be added for even more speed?? CC=gcc -O -g -DVOL=volatile -finline-functions -fkeep-inline-functions \ -fstrength-reduce -I$(GCLDIR)/o # if you have use the Sun C compiler, this will work, but i have not tried -O: # CC=/usr/5bin/cc -DVOL= -I$(GCLDIR)/o -Bstatic -temp=. # gcc 1.34 version: ODIR_DEBUG= -O -finline-functions -fkeep-inline-functions -fstrength-reduce # if using the Sun C compiler, this works: (-O may work, i havent tried) # ODIR_DEBUG= -g CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o RSYM = rsym SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) #MON INITFORM=(si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s gcl-2.6.14/h/386-bsd.defs0000755000175000017500000000167714360276512013171 0ustar cammcamm # Machine dependent makefile definitions for intel 386,486 running 386bsd # Hacked September-93 by Paul F. Werkowski for 386BSD 0.1 + Patchkit 0.2.4 LBINDIR=/usr/local/bin OFLAG = -O2 LIBS = -lm # LIBS = -lfpu # alternative math library works if you have it. ODIR_DEBUG= # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC=/usr/bin/gcc -m486 -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a GNULIB1=# disable this troublemaker for 386BSD/gcc # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/irix6.h0000755000175000017500000000022614360276512012437 0ustar cammcamm #include "irix5.h" #undef UNIXSAVE #define UNIXSAVE "unexsgi.c" #ifdef IN_UNIXSAVE #define emacs #define round_up round_up1 #undef bss_end #endif gcl-2.6.14/h/NeXT32-m68k.h0000755000175000017500000000227314360276512013150 0ustar cammcamm#ifndef NeXT #define NeXT #endif #include "bsd.h" #include "mc68k.h" #undef SFASL #undef HAVE_AOUT #define NO_UNISTD_H #define PAGEWIDTH 12 /* The following value determines the running process size. */ #define BIG_HEAP_SIZE 0x1000000 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ { extern int mach_maplimit; sbrk(0); real_maxpage = mach_maplimit/PAGESIZE; } #define sbrk my_sbrk #define ADDITIONAL_FEATURES \ ADD_FEATURE("MACH"); \ ADD_FEATURE("NeXT"); \ ADD_FEATURE("MC68040"); \ ADD_FEATURE("TURBO-CLOSURE"); \ ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE") #define CLEAR_CACHE asm("trap #2") #define UNIXSAVE "NeXTunixsave.c" #define UNIXFASL "NeXTunixfasl.c" #define SEEK_TO_END_OFILE seek_to_end_ofile #define MC68040 #define IEEEFLOAT /* assumption: stack bottom = 0x4000000 ; stack size = 1MB(0x100000) */ #define NULL_OR_ON_C_STACK(x) ((x)==0||(((unsigned int)(x)) >= 0x3f00000 )) /* we can use the system malloc without interference with lisp storage allocation */ #define DONT_NEED_MALLOC #ifdef IN_MAIN #include #include #endif /* Begin for cmpinclude */ #ifdef __GNUC__ #undef __BUILTIN_VA_ARG_INCR #endif /* End for cmpinclude */ gcl-2.6.14/h/symmetry.h0000755000175000017500000000263014360276512013270 0ustar cammcamm/* Machine-specific header declarations for Sequent Symmetry/DYNIX-3.0.12+ */ /* by Marion Hakanson , Oregon Graduate Institute. */ /* $Id$ */ extern char etext; #define SEQ #define SEQUENT #define SYMMETRY #define I386 #include "bsd.h" #undef SFASL /* the symmetry has non standard sigvec. could change main.c or alternately: + #ifdef SEQUENT + vec.sv_onstack = (signo == SIGSEGV || signo == SIGBUS); + #else vec.sv_flags = (signo == SIGSEGV || signo == SIGBUS ? SV_ONSTACK : 0); #endif */ #undef HAVE_SIGVEC /* what would be in h/include.h, and not in h/bsd.h */ #define IEEEFLOAT #define ADDITIONAL_FEATURES \ ADD_FEATURE("SEQ"); \ ADD_FEATURE("SEQUENT"); \ ADD_FEATURE("SYMMETRY"); \ ADD_FEATURE("I386"); #define TXTRELOC N_ADDRADJ(header) /* from a.out.h */ #define DATA_BEGIN (char *)(N_DATAOFF(header) + N_ADDRADJ(header)); /* width of page size that can be memory protected log2(getpagesize()) */ /* Also used in h/object.h to declare PAGESIZE, as used in h/bsd.h, as well as in much of the memory allocation code. This ensures that the sbrk() boundary is on an even page, for creating a proper executable image. */ #define PAGEWIDTH 12 #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text \ - N_ADDRADJ(header) \ - sizeof(header)); /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/m68k-linux.h0000755000175000017500000000453014360276512013322 0ustar cammcamm#include "linux.h" #ifdef IN_GBC /* GET_FAULT_ADDR is a bit complicated to implement on m68k, because the fault address can't be found directly in the sigcontext. One has to look at the CPU frame, and that one is different for each CPU. */ /* the following two files have changed back and forth in recent versions of linux... Include both if they both exist, otherwise include whatever one exists... basically one wants the struct sigcontext_struct { ... } ; so as to get the fault address. */ #if !defined(SIGNAL_H_HAS_SIGCONTEXT) && !defined(HAVE_SIGCONTEXT) #error Need sigcontext on linux, at least in some architectures #else #include #ifndef SIGNAL_H_HAS_SIGCONTEXT #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif #endif #endif #define GET_FAULT_ADDR(sig,code,sv,a) \ ({\ struct sigcontext *scp1 = (struct sigcontext *)(sv); \ int format = (scp1->sc_formatvec >> 12) & 0xf; \ unsigned long *framedata = (unsigned long *)(scp1 + 1); \ unsigned long ea; \ if (format == 0xa || format == 0xb) \ /* 68020/030 */ \ ea = framedata[2]; \ else if (format == 7) \ /* 68040 */ \ ea = framedata[3]; \ else if (format == 4) { \ /* 68060 */ \ ea = framedata[0]; \ if (framedata[1] & 0x08000000) \ /* correct addr on misaligned access */ \ ea = (ea+4095)&(~4095); \ } \ else {\ FEerror("Unknown m68k cpu",0);\ ea=0;\ } \ (char *)ea; }) #endif /* #define NULL_OR_ON_C_STACK(x) ( x == 0 || (((unsigned int) x) >= 0xe0000000 )) */ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define M68K /* #define SGC *//*FIXME: Unknown m68k cpu in modern emulators*/ #include int cacheflush(void *,int,int,int); #define CLEAR_CACHE_LINE_SIZE 32 #define CLEAR_CACHE do {void *v=memory->cfd.cfd_start,*ve=v+memory->cfd.cfd_size; \ v=(void *)((unsigned long)v & ~(CLEAR_CACHE_LINE_SIZE - 1));\ cacheflush(v,FLUSH_SCOPE_PAGE,FLUSH_CACHE_BOTH,ve-v);\ } while(0) #define C_GC_OFFSET 2 #define RELOC_H "elf32_m68k_reloc.h" #define NEED_STACK_CHK_GUARD #define DEFINED_REAL_MAXPAGE (1UL<<18) /*FIXME brk probe broken*/ gcl-2.6.14/h/mipsel-linux.h0000755000175000017500000000032214360276512014021 0ustar cammcamm#include "linux.h" #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #ifdef IN_GBC #define GET_FAULT_ADDR(sig,code,scp,addr) \ ((siginfo_t *)code )->si_addr #endif #define SGC gcl-2.6.14/h/NeXT32-i386.defs0000755000175000017500000000132014360276512013536 0ustar cammcamm# # NeXTSTEP 3.2, 3.3 for Intel # LBINDIR=/usr/local/bin OFLAG= -O LIBS= -lsys_s -lm LIBC= ODIR_DEBUG= # NeXT's cc does not compile gcl correctly. # However gcc-2.6.3 is OK. CC= gcc -DVOL=volatile -I$(GCLDIR)/o -fwritable-strings # The option -seglinkedit is specified so that rld_load() can be used. LDCC= ld -X -seglinkedit -segprot __TEXT rwx rwx /lib/crt0.o # bcmp(), bcopy(), and bzero() are already included in the NeXT C library. LIBFILES= CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o INITFORM=(setq compiler::*cc* "gcc -DVOL=volatile -fwritable-strings") MPFILES=$(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-next gcl-2.6.14/h/elf32_hppa_reloc.h0000644000175000017500000000155014360276512014503 0ustar cammcamm case R_PARISC_PCREL17F: s+=a-pltgot; s=((long)s)>>2; massert(ovchks(s,~MASK(17))); s&=MASK(17); *where=(0x39<<26)|(0x13<<21)|ASM17(s); /* b,l -> be,l */ break; case R_PARISC_PCREL21L: s+=a; s-=p+11; s>>=11; store_valu(where,MASK(21),ASM21(s)); break; case R_PARISC_PCREL14R: s+=a; s-=p+11; s&=MASK(11); store_valu(where,MASK(14),s<<1); break; case R_PARISC_LTOFF21L: s-=pltgot; s>>=11; store_valu(where,MASK(21),ASM21(s)); break; case R_PARISC_LTOFF14R: s-=pltgot; s&=MASK(11); store_valu(where,MASK(14),s<<1); store_valu(where,MASK(6)<<26,0xd<<26); /*ldw -> ldo*/ break; case R_PARISC_PLABEL32: case R_PARISC_SEGREL32: case R_PARISC_DIR32: store_val(where,~0L,s+a); break; gcl-2.6.14/h/mingw.h0000755000175000017500000001217014360276512012520 0ustar cammcamm#include #include "att.h" /* bfd support */ #ifdef HAVE_LIBBFD # undef SPECIAL_RSYM # undef RSYM_COMMAND # define SEPARATE_SFASL_FILE "sfaslbfd.c" #else # define SEPARATE_SFASL_FILE "sfaslcoff.c" # define SPECIAL_RSYM "rsym_nt.c" # define RSYM_COMMAND(command,system_directory,kcl_self,tmpfile1) \ sprintf(command,"rsym %s %s",kcl_self,tmpfile1); #endif /* Stratified garbage collection - need mprotect() (at least) */ /*#define SGC*/ #define MP386 #define GCL /* #define filehdr _IMAGE_FILE_HEADER */ #define RUN_PROCESS #define f_symptr PointerToSymbolTable #define f_nsyms NumberOfSymbols #define NO_PWD_H #define signals_pending *signalsPendingPtr #undef DBEGIN_TY #define DBEGIN_TY unsigned int extern DBEGIN_TY _stacktop, _stackbottom, _dbegin; #define NO_SYS_PARAM_H #define NO_SYS_TIMES_H #ifdef IN_UNIXTIME # undef ATT # undef BSD #endif #undef NEED_GETWD #define GETCWD #define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) #ifdef IN_UNIXFSYS # undef ATT # define HAVE_RENAME #endif #define SIGBUS 7 #ifndef SIGKILL #define SIGKILL 9 #endif #define SIGUSR1 10 #define SIGUSR2 12 #define SIGPIPE 13 #define SIGALRM 14 #if 0 #define SIGIO 23 #endif #define SIGIO 29 #define OTHER_SIGNALS_HANDLED SIGTERM,SIGKILL,SIGABRT, #define SIG_BLOCK 0 /* for blocking signals */ #define SIG_UNBLOCK 1 /* for unblocking signals */ #define SIG_SETMASK 2 /* for setting the signal mask */ #define HAVE_SIGPROCMASK #define NEED_TO_REINSTALL_SIGNALS /*#define HAVE_SIGACTION*/ #define SV_ONSTACK 0 #define SA_RESTART 0 /* on most machines this will test in one instruction if the pointe/r is on the C stack or the 0 pointer in winnt our heap starts at DBEGIN */ /* #define NULL_OR_ON_C_STACK(y) \ */ /* (((unsigned int)(y)) == 0 || \ */ /* (((unsigned int)(y)) > _stacktop && ((unsigned int)(y)) < _stackbottom)) */ /* #define NULL_OR_ON_C_STACK(x) (!(int *)x || ((int *)x>cs_limit && (int *)x<=cs_org)) */ #if defined ( IN_FILE ) || defined ( IN_SOCKETS ) # define HAVE_NSOCKET #endif #define brk(x) ; /* use the slightly older unexec */ #define UNIXSAVE "unexnt.c" #define RECREATE_HEAP { recreate_heap1(); \ terminal_io->sm.sm_object1->sm.sm_fp=stdout; \ terminal_io->sm.sm_object0->sm.sm_fp=stdin; \ init_shared_memory();} #define HAVE_AOUT "wincoff.h" /* we dont need to worry about zeroing fp->_base , to prevent */ /* must use seek to go to beginning of string table */ /* #define MUST_SEEK_TO_STROFF */ /* #define N_STROFF(hdr) ((&hdr)->f_symptr+((&hdr)->f_nsyms)*SYMESZ) */ #define TO_NUMBER(ptr,type) (*((type *)(void *)(ptr))) #define SEEK_TO_END_OFILE(fp) do { struct filehdr fileheader; int i; \ fseek(fp,0,0) ; \ fread(&fileheader, sizeof(fileheader), 1, fp); \ fseek(fp, fileheader.f_symptr+fileheader.f_nsyms*SYMESZ, 0); \ fread(&i, sizeof(i), 1, fp); \ fseek(fp, i - sizeof(i), 1); \ while ((i = getc(fp)) == 0) \ ; \ ungetc(i, fp); \ } while (0) #define IEEEFLOAT #define I386 /* include some low level routines for maxima */ #define CMAC #define RELOC_FILE "rel_coff.c" /* FIONREAD not supported */ #undef LISTEN_FOR_INPUT /* adjust the start to the offset */ #define ADJUST_RELOC_START(j) \ the_start = memory->cfd.cfd_start + \ (j == DATA_NSCN ? textsize : 0); #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {char * e = sbrk(0); \ if (e - core_end < 0x10000 ) { \ int i; \ for (i=page(core_end); i < page(e); i++) { \ \ } \ core_end = e; \ } \ else \ error("Someone allocated my memory!");} \ if (core_end != (sbrk(PAGESIZE*(n - m)))) #define USE_INTERNAL_REAL_TIME_FOR_RUNTIME /* Use this pending test in configure */ #define NO_MKSTEMP #define DOES_CRLF extern char *GCLExeName ( void ); #define GET_FULL_PATH_SELF(a_) do {\ (a_)=GCLExeName();\ } while(0) /* Needed if optimiser moves object initialisation code around. */ #define FIND_INIT \ { if (*ptr==0 && (NTYPE(sym) == TEXT_NSCN) && sym->n_value ) \ { char tem [9]; \ char *str; \ tem[8]='\0'; \ str=SYM_NAME(sym); \ dprintf(find init: %s ,str); \ if ( str[1]=='i' && str[2]=='n' && str[3]=='i' && str[4]=='t' \ && str[5]=='_' && str[0]== '_' ) \ *ptr= sym->n_value ; \ else {/* printf("The first data symbol was not the init");*/} \ } } #if 1 #ifdef getc #undef getc #endif #define getc fgetc #endif /* Begin for cmpinclude */ /* End for cmpinclude */ extern int mingwlisten(FILE *); #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) do {if (mingwlisten(fp)) return 0;} while (0) #define socklen_t int #undef DBEGIN #define DBEGIN _dbegin #define NOFREE_ERR #define FPE_CODE(i_,v_) make_fixnum((long)fSfpe_code((long)FFN(fSfnstsw)(),(long)FFN(fSstmxcsr)())) #define FPE_ADDR(i_,v_) make_fixnum(0) #define FPE_CTXT(v_) Cnil #define FPE_INIT Cnil #ifndef FE_INVALID #define FE_INVALID 1 #define FE_DIVBYZERO 4 #define FE_OVERFLOW 8 #define FE_UNDERFLOW 16 #define FE_INEXACT 32 #endif #define FPE_FLTDIV 3 #define FPE_FLTOVF 4 #define FPE_FLTUND 5 #define FPE_FLTRES 6 #define FPE_FLTINV 7 #include #define NO_FILE_LOCKING /*FIXME*/ gcl-2.6.14/h/riscv64-linux.h0000644000175000017500000000127714360276512014037 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ /* #define ADDITIONAL_FEATURES \ */ /* ADD_FEATURE("BSD386"); \ */ /* ADD_FEATURE("MC68020") */ /* #define I386 */ #define SGC /* Apparently stack pointers can be 4 byte aligned, at least &argc -- CM */ #define C_GC_OFFSET 4 #define RELOC_H "elf64_riscv64_reloc.h" /* #define MAX_CODE_ADDRESS (1L<<31)/\*large memory model broken gcc 4.8*\/ */ #define NEED_STACK_CHK_GUARD gcl-2.6.14/h/NeXT30-m68k.defs0000755000175000017500000000117714360276512013642 0ustar cammcamm# # For NeXTSTEP 3.0 # LBINDIR=/usr/local/bin OFLAG= -O LIBS= -lsys_s -lm LIBC= ODIR_DEBUG= CC= cc -DVOL=volatile -I$(GCLDIR)/o -fwritable-strings # The option -seglinkedit is specified so that rld_load() can be used. LDCC= ld -X -seglinkedit -segprot __TEXT rwx rwx /lib/crt0.o # bcmp(), bcopy(), and bzero() are already included in the NeXT C library. LIBFILES= CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o INITFORM=(setq compiler::*cc* "cc -DVOL=volatile -fwritable-strings") MPFILES=$(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-next gcl-2.6.14/h/sun2r3.h0000755000175000017500000000040514360276512012531 0ustar cammcamm#include "bsd.h" #define SUN2R3 #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("MC68K") #define MC68K #define IEEEFLOAT #define DATA_BEGIN (char *)N_DATADDR(header) /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/amd64-linux.h0000644000175000017500000000142414360276512013444 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC /* Apparently stack pointers can be 4 byte aligned, at least &argc -- CM */ #define C_GC_OFFSET 4 #define RELOC_H "elf64_i386_reloc.h" #define MAX_CODE_ADDRESS (1L<<31)/*large memory model broken gcc 4.8*/ #define MAX_DEFAULT_MEMORY_MODEL_CODE_ADDRESS (1UL<<31) #define LARGE_MEMORY_MODEL /*working -mcmodel=large giving unrestricted code load addresses*/ gcl-2.6.14/h/elf32_sh4_reloc.h0000644000175000017500000000010014360276512014237 0ustar cammcamm case R_SH_DIR32: add_val(where,~0L,s+a); break; gcl-2.6.14/h/NeXT32-m68k.defs0000755000175000017500000000132514360276512013637 0ustar cammcamm# # NeXTSTEP 3.2, 3.3 for Motorola # LBINDIR=/usr/local/bin OFLAG= -O LIBS= -lsys_s -lm LIBC= ODIR_DEBUG= # NeXT's cc does not compile gcl correctly. # However gcc-2.6.3 is OK. CC= gcc -DVOL=volatile -I$(GCLDIR)/o -fwritable-strings # The option -seglinkedit is specified so that rld_load() can be used. LDCC= ld -X -seglinkedit -segprot __TEXT rwx rwx /lib/crt0.o # bcmp(), bcopy(), and bzero() are already included in the NeXT C library. LIBFILES= CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o INITFORM=(setq compiler::*cc* "gcc -DVOL=volatile -fwritable-strings") MPFILES=$(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-next gcl-2.6.14/h/sun3.h0000755000175000017500000000047614360276512012275 0ustar cammcamm#define SUN3 #include "bsd.h" #include "mc68k.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("MC68020") #define MC68020 #define IEEEFLOAT #define DATA_BEGIN (char *)N_DATADDR(header) #define RELOC_FILE "rel_sun3.c" /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/NeXT.h0000755000175000017500000000000014360276512012202 0ustar cammcammgcl-2.6.14/h/coff/0000755000175000017500000000000014360276512012137 5ustar cammcammgcl-2.6.14/h/coff/i386.h0000755000175000017500000001336314360276512013012 0ustar cammcamm/*** coff information for Intel 386/486. */ /********************** FILE HEADER **********************/ struct external_filehdr { char f_magic[2]; /* magic number */ char f_nscns[2]; /* number of sections */ char f_timdat[4]; /* time & date stamp */ char f_symptr[4]; /* file pointer to symtab */ char f_nsyms[4]; /* number of symtab entries */ char f_opthdr[2]; /* sizeof(optional hdr) */ char f_flags[2]; /* flags */ }; /* Bits for f_flags: * F_RELFLG relocation info stripped from file * F_EXEC file is executable (no unresolved external references) * F_LNNO line numbers stripped from file * F_LSYMS local symbols stripped from file * F_AR32WR file has byte ordering of an AR32WR machine (e.g. vax) */ #define F_RELFLG (0x0001) #define F_EXEC (0x0002) #define F_LNNO (0x0004) #define F_LSYMS (0x0008) #define I386MAGIC 0x14c #define I386PTXMAGIC 0x154 #define I386AIXMAGIC 0x175 /* This is Lynx's all-platform magic number for executables. */ #define LYNXCOFFMAGIC 0415 #define I386BADMAG(x) (((x).f_magic != I386MAGIC) \ && (x).f_magic != I386AIXMAGIC \ && (x).f_magic != I386PTXMAGIC \ && (x).f_magic != LYNXCOFFMAGIC) #define FILHDR struct external_filehdr #define FILHSZ 20 /********************** AOUT "OPTIONAL HEADER" **********************/ typedef struct { char magic[2]; /* type of file */ char vstamp[2]; /* version stamp */ char tsize[4]; /* text size in bytes, padded to FW bdry*/ char dsize[4]; /* initialized data " " */ char bsize[4]; /* uninitialized data " " */ char entry[4]; /* entry pt. */ char text_start[4]; /* base of text used for this file */ char data_start[4]; /* base of data used for this file */ } AOUTHDR; #define AOUTSZ 28 #define AOUTHDRSZ 28 #define OMAGIC 0404 /* object files, eg as output */ #define ZMAGIC 0413 /* demand load format, eg normal ld output */ #define STMAGIC 0401 /* target shlib */ #define SHMAGIC 0443 /* host shlib */ /* define some NT default values */ /* #define NT_IMAGE_BASE 0x400000 moved to internal.h */ #define NT_SECTION_ALIGNMENT 0x1000 #define NT_FILE_ALIGNMENT 0x200 #define NT_DEF_RESERVE 0x100000 #define NT_DEF_COMMIT 0x1000 /********************** SECTION HEADER **********************/ struct external_scnhdr { char s_name[8]; /* section name */ char s_paddr[4]; /* physical address, aliased s_nlib */ char s_vaddr[4]; /* virtual address */ char s_size[4]; /* section size */ char s_scnptr[4]; /* file ptr to raw data for section */ char s_relptr[4]; /* file ptr to relocation */ char s_lnnoptr[4]; /* file ptr to line numbers */ char s_nreloc[2]; /* number of relocation entries */ char s_nlnno[2]; /* number of line number entries*/ char s_flags[4]; /* flags */ }; #define SCNHDR struct external_scnhdr #define SCNHSZ 40 /* * names of "special" sections */ #define _TEXT ".text" #define _DATA ".data" #define _BSS ".bss" #define _COMMENT ".comment" #define _LIB ".lib" /********************** LINE NUMBERS **********************/ /* 1 line number entry for every "breakpointable" source line in a section. * Line numbers are grouped on a per function basis; first entry in a function * grouping will have l_lnno = 0 and in place of physical address will be the * symbol table index of the function name. */ struct external_lineno { union { char l_symndx[4]; /* function name symbol index, iff l_lnno == 0*/ char l_paddr[4]; /* (physical) address of line number */ } l_addr; char l_lnno[2]; /* line number */ }; #define LINENO struct external_lineno #define LINESZ 6 /********************** SYMBOLS **********************/ #define E_SYMNMLEN 8 /* # characters in a symbol name */ #define E_FILNMLEN 14 /* # characters in a file name */ #define E_DIMNUM 4 /* # array dimensions in auxiliary entry */ struct external_syment { union { char e_name[E_SYMNMLEN]; struct { char e_zeroes[4]; char e_offset[4]; } e; } e; char e_value[4]; char e_scnum[2]; char e_type[2]; char e_sclass[1]; char e_numaux[1]; }; #if !defined(__MINGW32__) && !defined(__CYGWIN__) #define N_BTMASK (0xf) #define N_TMASK (0x30) #define N_BTSHFT (4) #define N_TSHIFT (2) #endif union external_auxent { struct { char x_tagndx[4]; /* str, un, or enum tag indx */ union { struct { char x_lnno[2]; /* declaration line number */ char x_size[2]; /* str/union/array size */ } x_lnsz; char x_fsize[4]; /* size of function */ } x_misc; union { struct { /* if ISFCN, tag, or .bb */ char x_lnnoptr[4]; /* ptr to fcn line # */ char x_endndx[4]; /* entry ndx past block end */ } x_fcn; struct { /* if ISARY, up to 4 dimen. */ char x_dimen[E_DIMNUM][2]; } x_ary; } x_fcnary; char x_tvndx[2]; /* tv index */ } x_sym; union { char x_fname[E_FILNMLEN]; struct { char x_zeroes[4]; char x_offset[4]; } x_n; } x_file; struct { char x_scnlen[4]; /* section length */ char x_nreloc[2]; /* # relocation entries */ char x_nlinno[2]; /* # line numbers */ char x_checksum[4]; /* section COMDAT checksum */ char x_associated[2]; /* COMDAT associated section index */ char x_comdat[1]; /* COMDAT selection number */ } x_scn; struct { char x_tvfill[4]; /* tv fill value */ char x_tvlen[2]; /* length of .tv */ char x_tvran[2][2]; /* tv range */ } x_tv; /* info about .tv section (in auxent of symbol .tv)) */ }; #define SYMENT struct external_syment #define SYMESZ 18 #define AUXENT union external_auxent #define AUXESZ 18 #define _ETEXT "etext" /********************** RELOCATION DIRECTIVES **********************/ struct external_reloc { char r_vaddr[4]; char r_symndx[4]; char r_type[2]; }; #define RELOC struct external_reloc #define RELSZ 10 gcl-2.6.14/h/mac2.h0000755000175000017500000001074314360276512012225 0ustar cammcamm#define MAC2 #define AV #define UNIX #define SFASL #if defined(IN_FILE) || defined(IN_UNIXFASL) || defined(IN_UNIXSAVE) || defined(IN_UNIXTIME) || defined(IN_SFASL) || defined(IN_RSYM) #define ATT #else #define BSD #endif #ifdef IN_MAIN #undef BSD #include #include /* note that rl does not need to be declared if we do not have RLIMIT_STACK defined */ #undef RLIMIT_STACK #endif #ifdef IN_SFASL #include #include #include #include #include #include #include #include #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("MAC2"); \ ADD_FEATURE("MC68020"); \ ADD_FEATURE("BSD") #define MC68020 #define IEEEFLOAT #define VSSIZE 8152 #define ISCOFF(x) (x == MC68MAGIC) #define MEM_SAVE_LOCALS \ struct filehdr fileheader;\ struct exec header;\ struct scnhdr sectionheader;\ int diff #define COPY_TO_SAVE \ do{for (;;) { \ n = getc(original); \ if (feof(original)) \ break; \ putc(n, save); \ }}while (0) #define READ_HEADER \ do{ fread(&fileheader, sizeof(fileheader), 1, original); \ fread(&header, sizeof(header), 1, original); \ data_begin = (char *)header.data_start; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ diff = header.a_data - original_data; \ header.a_bss = sbrk(0) - core_end; \ fileheader.f_symptr += diff; \ fwrite(&fileheader, sizeof(fileheader), 1, save);\ fwrite(&header, sizeof(header), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_size += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_paddr += diff; \ sectionheader.s_vaddr += diff; \ sectionheader.s_size = header.a_bss; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ for (n = 4; n <= fileheader.f_nscns; n++) { \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_scnptr) \ sectionheader.s_scnptr += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ }}while(0) #define FILECPY_HEADER filecpy(save, original, header.a_text) #define exec aouthdr #define a_text tsize #define a_data dsize #define a_bss bsize /* Include rather than */ #define HAVE_FCNTL #define NUMBER_OPEN_FILES _NFILE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE ; set42sig(); #define ROUND_UP_SBRK(x) \ do {int i; \ if (i = ((int)x & (PAGESIZE - 1))) \ x=sbrk(PAGESIZE - i); } while(0); #define FIX_RANDOM_SBRK \ do {char *x=sbrk(0); \ if (core_end != x) \ { ROUND_UP_SBRK(x); x=sbrk(0);\ while (core_end < x) \ { \ core_end = core_end + PAGESIZE;} \ if (core_end !=x) error("Someone allocated my memory");}} while (0) #define INIT_ALLOC \ heap_end = sbrk(0); ROUND_UP_SBRK(heap_end);\ heap_end = core_end = sbrk(0); #define IF_ALLOCATE_ERR \ FIX_RANDOM_SBRK; \ if (core_end != sbrk(PAGESIZE*(n - m))) #define SYM_EXTERNAL_P(sym) ((sym)->n_type & N_EXT) #define cs_check(x) /* need to define getwd and friends in unixfsys.c Basically as would need to in ATT*/ #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -N -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) #define SYM_UNDEF_P(sym) ((N_SECTION(sym)) == N_UNDEF) #define NUM_AUX(sym) 0 /* the section like N_ABS,N_TEXT,.. */ #undef HAVE_AOUT #undef WANT_VALLOC #undef NEED_GETWD /* We have socket utilities, and can fork off a process and get a stream connection with it */ #define RUN_PROCESS /* #define HAVE_XDR */ /* if there is no input there return false */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_cnt <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0 /* have sys/ioctl.h */ #define HAVE_IOCTL #define HAVE_SIGVEC #define DATA_BEGIN (char *)N_DATADDR(header) #define RELOC_FILE "rel_mac2.c" /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/vs.h0000755000175000017500000000333614360276512012033 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* vs.h value stack */ extern object *vs_org,*vs_limit; /* value stack limit */ EXTER object *vs_base; /* value stack base */ EXTER object *vs_top; /* value stack top */ #define vs_push(obje) (*vs_top++ = (obje)) #define vs_pop (*--vs_top) #define vs_popp (--vs_top) #define vs_head vs_top[-1] #define vs_mark object *old_vs_top = vs_top #define vs_reset vs_top = old_vs_top #define vs_check if (vs_top >= vs_limit) \ vs_overflow() #define vs_check_push(obje) \ (vs_top >= vs_limit ? \ (object)vs_overflow() : (*vs_top++ = (obje))) #define check_arg(n) \ if (vs_top - vs_base != (n)) \ check_arg_failed(n) #define CHECK_ARG_RANGE(n,m) if (VFUN_NARGS < n || VFUN_NARGS >m) \ check_arg_range(n,m) #define MMcheck_arg(n) \ if (vs_top - vs_base < (n)) \ too_few_arguments(); \ else if (vs_top - vs_base > (n)) \ too_many_arguments() #define vs_reserve(x) if(vs_base+(x) >= vs_limit) \ vs_overflow(); gcl-2.6.14/h/NeXT30-m68k.h0000755000175000017500000000227314360276512013146 0ustar cammcamm#ifndef NeXT #define NeXT #endif #include "bsd.h" #include "mc68k.h" #undef SFASL #undef HAVE_AOUT #define NO_UNISTD_H #define PAGEWIDTH 12 /* The following value determines the running process size. */ #define BIG_HEAP_SIZE 0x1000000 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ { extern int mach_maplimit; sbrk(0); real_maxpage = mach_maplimit/PAGESIZE; } #define sbrk my_sbrk #define ADDITIONAL_FEATURES \ ADD_FEATURE("MACH"); \ ADD_FEATURE("NeXT"); \ ADD_FEATURE("MC68040"); \ ADD_FEATURE("TURBO-CLOSURE"); \ ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE") #define CLEAR_CACHE asm("trap #2") #define UNIXSAVE "NeXTunixsave.c" #define UNIXFASL "NeXTunixfasl.c" #define SEEK_TO_END_OFILE seek_to_end_ofile #define MC68040 #define IEEEFLOAT /* assumption: stack bottom = 0x4000000 ; stack size = 1MB(0x100000) */ #define NULL_OR_ON_C_STACK(x) ((x)==0||(((unsigned int)(x)) >= 0x3f00000 )) /* we can use the system malloc without interference with lisp storage allocation */ #define DONT_NEED_MALLOC #ifdef IN_MAIN #include #include #endif /* Begin for cmpinclude */ #ifdef __GNUC__ #undef __BUILTIN_VA_ARG_INCR #endif /* End for cmpinclude */ gcl-2.6.14/h/vax.defs0000755000175000017500000000161214360276512012666 0ustar cammcammLBINDIR=/usr/local/bin #defs for the makefiles # vax OFLAG = LIBS = -lm -lg ODIR_DEBUG= CHTAB = char_table.s CC = cc -DVOL= -I$(GCLDIR)/o # If you don't have gcc use CC = cc -DVOL= # # I have been told (by romine@expres.nsf.gov) # that the following CC works on a vax running 3.1 and 4.0 # it worked also to build maxima and run the test suite # Ultrix V3.1 (Rev. 9), on either a VaxStation 2000 or 3200. akcl 505. # [except for one difference in cpoly] #CC = gcc -DVOL=volatile -I$(GCLDIR)/o # Do not use gnu's ld. It did not work. So probably use #LDCC=cc CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM= SYMB=-s gcl-2.6.14/h/ncr.h0000755000175000017500000000167214360276512012166 0ustar cammcamm#define MP386 #include "att.h" #include "386.h" #undef SFASL #undef LISTEN_FOR_INPUT #undef NEED_GETWD #ifdef IN_UNIXFSYS #undef ATT #define BSD #define GETCWD #endif #define UNIXFASL "dummyfasl.c" /* #define DBEGIN 0x8000000 */ #define IEEEFLOAT #define I386 #define ADDITIONAL_FEATURES \ ADD_FEATURE("I386"); ADD_FEATURE("SYSTEM-V") #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if (real_maxpage > MAXPAGE) \ real_maxpage = MAXPAGE; \ if (sbrk(0) < core_end) brk(core_end); /* include some low level routines for maxima */ #define CMAC #define RELOC_FILE "rel_coff.c" #define HAVE_ELF #define SEEK_TO_END_OFILE(fp) \ do{Elf32_Ehdr bil; \ fseek((fp),0,0); \ fread(&bil,1,sizeof(bil),(fp)); \ fseek((fp),bil.e_shoff+bil.e_shnum*(bil.e_shentsize),0);}while(0) /* Begin for cmpinclude */ /* End for cmpinclude */ #define UNIXSAVE "unexelf.c" gcl-2.6.14/h/make-init.h0000755000175000017500000000523114360276512013255 0ustar cammcamm#include "include.h" #include "num_include.h" #define IN_NEW_INIT #include "funlink.h" #define SI 0 #define LISP 1 #define KEYWORD 2 #define NONE 0 /* void SI_makefun(),LISP_makefun(),error(); */ #define MAKEFUN(pack,string,fname,argd) \ (pack == SI ? SI_makefun(string,fname,argd) : \ pack == LISP ? LISP_makefun(string,fname,argd) : \ error("Bad pack variable in MAKEFUN\n")) #define MAKESYM(pack,string) \ (pack == SI ? make_si_ordinary(string) : \ pack == LISP ? make_ordinary(string) : \ (error("Bad pack variable in MAKESYM\n"),Cnil)) #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} #undef DEFUNO #define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old,doc) \ {extern ret fname(); \ MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} /* FIXME, possibly restore old MAKEFUN in place (in NewInit) here when STATIC_FUNCTION_POINTERS not defined */ #undef DEFUN_NEW #define DEFUN_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) \ {extern void Mjoin(fname,_init)(); Mjoin(fname,_init)();} #undef DEFUNO_NEW #define DEFUNO_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ {extern void Mjoin(fname,_init)();Mjoin(fname,_init)();} #undef DEFUNM_NEW #define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) \ {extern void Mjoin(fname,_init)(); Mjoin(fname,_init)();} #undef DEFUNOM_NEW #define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ {extern void Mjoin(fname,_init)();Mjoin(fname,_init)();} #undef DEFCOMP #define DEFCOMP(type, fun,doc) Ineed_in_image(fun); #undef DEFVAR #define DEFVAR(name,cname,pack,val,doc) \ { extern object cname; \ cname = (pack == LISP ? make_special(name,val) : \ pack == SI ? make_si_special(name,val): \ (error("Bad pack variable in DEFVAR\n"),(object)0));} #undef DEFCONST #define DEFCONST(name,cname,pack,val,doc) \ { extern object cname; \ cname = (pack == LISP ? make_constant(name,val) : \ pack == SI ? make_si_constant(name,val): \ (error("Bad pack variable in DEFCONST\n"),(object)0));} #undef DEF_ORDINARY #define DEF_ORDINARY(name,cname,pack,doc) \ { extern object cname ; cname = (pack == LISP ? make_ordinary(name) : \ pack == SI ? make_si_ordinary(name): \ pack == KEYWORD ? make_keyword(name): \ (error("Bad pack variable in DEF_ORDINARY\n"),(object)0));} #undef DO_INIT #define DO_INIT(x) x #include #include gcl-2.6.14/h/minglacks.h0000644000175000017500000000370714360276512013352 0ustar cammcamm #define SYMNMLEN 8 struct syment { union { char n_name[SYMNMLEN]; struct { int n_zeroes; int n_offset; } n; } n; DWORD n_value; SHORT n_scnum; WORD n_type; BYTE n_sclass; BYTE n_numaux; }; #define n_zeroes n.n.n_zeroes #define n_offset n.n.n_offset #define n_name n.n_name /* storage class */ #define C_EXT 0x0002 /* IMAGE_SYM_CLASS_EXTERNAL */ /* section number */ #define N_UNDEF (SHORT)0 /* Symbol is undefined or is common. */ struct filehdr { WORD f_magic; /* magic number */ WORD f_nscns; /* number of sections */ DWORD f_timdat; /* time & date stamp */ DWORD f_symptr; /* file pointer to symtab */ DWORD f_nsyms; /* number of symtab entries */ WORD f_opthdr; /* sizeof(optional hdr) */ WORD f_flags; /* flags */ }; #define IMAGE_SIZEOF_SHORT_NAME 8 struct scnhdr { BYTE s_name[IMAGE_SIZEOF_SHORT_NAME]; /* section name */ DWORD s_paddr; /* physical address, aliased s_nlib */ DWORD s_vaddr; /* virtual address */ DWORD s_size; /* section size */ DWORD s_scnptr; /* file ptr to raw data for section */ DWORD s_relptr; /* file ptr to relocation */ DWORD s_lnnoptr; /* file ptr to line numbers */ WORD s_nreloc; /* number of relocation entries */ WORD s_nlnno; /* number of line number entries*/ DWORD s_flags; /* flags */ }; /* IMAGE_REL_I386_ABSOLUTE */ #define R_ABS 0x0000 /* absolute, no relocation is necessary */ /* IMAGE_REL_I386_DIR32 */ #define R_DIR32 0x0006 /* Direct 32-bit reference to the symbols virtual address */ /* IMAGE_REL_I386_REL32 */ #define R_PCRLONG 0x0014 /* 32-bit reference pc relative to the symbols virtual address */ /* _IMAGE_RELOCATION */ struct reloc { union { DWORD r_vaddr; DWORD r_count; /* Set to the real count when IMAGE_SCN_LNK_NRELOC_OVFL is set */ } r; DWORD r_symndx; WORD r_type; }; #define r_vaddr r.r_vaddr gcl-2.6.14/h/NetBSD.defs0000755000175000017500000000232214360276512013146 0ustar cammcamm# NetBSD # Machine dependent makefile definitions for intel 386,486 running NetBSD # Hacked from 386-bsd version of # September-93 by Paul F. Werkowski for 386BSD 0.1 + Patchkit 0.2.4 # # 10/19/94 Bill Morgart NetBSD 1.0Beta support LBINDIR=/usr/local/bin OFLAG = -O2 LIBS = -lc -lm # LIBS = -lfpu # alternative math library works if you have it. ODIR_DEBUG= NULLFILE=../h/twelve_null # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC=gcc -m486 -fwritable-strings -DVOL=volatile -I./h -I./o -fsigned-char # NetBSD 1.0 currently requires static linking LDCC = $(CC) -static MAINDIR = /usr/ports/lisp/kcl # Use the mp.s file on 68k machine MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a GNULIB1=/usr/lib/libgcc.a # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) #INITFORM=(si::build-symbol-table)(load "../lsp/setdoc.lsp") INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/elf32_ppc_reloc.h0000644000175000017500000000123514360276512014335 0ustar cammcamm case R_PPC_REL24: /*FIXME, this is just for mcount, why longcall doesn't work is unknown */ s+=a; if (ovchks(s,~MASK(26))) store_val(where,MASK(26),s|0x3); else if (ovchks(s-p,~MASK(26))) store_val(where,MASK(26),(s-p)|0x1); else massert(!"REL24 overflow"); break; case R_PPC_REL32: store_val(where,~0L,s+a-p); break; case R_PPC_ADDR16_HA: s+=a; s+=s&0x8000 ? 1<<16 : 0; store_val(where,~MASK(16),s&0xffff0000); break; case R_PPC_ADDR16_LO: store_val(where,~MASK(16),(s+a)<<16); break; case R_PPC_ADDR32: store_val(where,~0L,s+a); break; gcl-2.6.14/h/att3b2.h0000755000175000017500000000071314360276512012476 0ustar cammcamm#include "att.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("ATT3B2");\ ADD_FEATURE("SYSTEM-V"); #define ATT3B2 #define IEEEFLOAT #define HOLEPAGE 32 #define INIT_ALLOC \ FIXtemp=MAXPAGE; \ if (brk(pagetochar(FIXtemp)) < 0) \ {error("Can't allocate. Good-bye!.");}; #undef IF_ALLOCATE_ERR #define IF_ALLOCATE_ERR \ if (PAGESIZE*(n - m) > pagetochar(MAXPAGE) - core_end) /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/num_include.h0000755000175000017500000000216214360276512013701 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* number routine include file */ #define WSIZ 32 #define MASK 0x7fffffff #ifdef MV #endif object Vrandom_state; #ifndef PI #define PI 3.141592653589793 #endif #define LOG_WORD_SIZE (8*SIZEOF_LONG) #define MOST_POSITIVE_FIX ((long)((((unsigned long)1)<<(LOG_WORD_SIZE-1))-1)) #define MOST_NEGATIVE_FIX ( - MOST_POSITIVE_FIX - 1 ) gcl-2.6.14/h/elf32_hppa_reloc_special.h0000644000175000017500000000225014360276512016201 0ustar cammcammstatic ul pltgot; #define ASM21(x) ((x>>20)|(((x>>9)&0x7ff)<<1)|(((x>>7)&0x3)<<14)|(((x>>2)&0x1f)<<16)|(((x>>0)&0x3)<<12)) /* be,l off(sr4,r19),sr0,r31 ; linux userspace sr4-7 const, sr0-3 used by kernel */ #define ASM17(x) ((x>>16)|(((x>>11)&0x1f)<<16)|((x&0x3ff)<<3)|(((x>>10)&0x1)<<2)|(1<<13)) static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { Rela *r; Shdr *sec; ul *q; void *p,*pe; massert(sec=get_section(".dynamic",sec1,sece,sn)); for (p=(void *)sec->sh_addr,pe=p+sec->sh_size;psh_entsize) { q=p; if (q[0]==DT_PLTGOT) pltgot=q[1]; } massert(pltgot); massert(sec=get_section(".rela.plt",sec1,sece,sn)); p=v+sec->sh_offset; pe=p+sec->sh_size; for (r=p;psh_entsize,r=p) if (!ds1[ELF_R_SYM(r->r_info)].st_value) ds1[ELF_R_SYM(r->r_info)].st_value=r->r_offset|0x2; return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { return 0; } #undef LOAD_SYM_BY_NAME #define LOAD_SYM_BY_NAME(sym,st1) (!strncmp(st1+sym->st_name,"$$",2)) gcl-2.6.14/h/genport.h0000755000175000017500000001336114360276512013060 0ustar cammcamm/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /* */ /* Fichier Include PARI */ /* */ /* declarations specifiques portables */ /* */ /* copyright Babecool */ /* */ /* */ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ extern unsigned plong overflow,hiremainder; /* mp.c */ #ifndef signe #define lg(x) (((GEN)(x))[0]&0xffff) #define setlg(x,s) (((GEN)(x))[0]=(((GEN)(x))[0]&0xffff0000)+s) #define lgef(x) (((GEN)(x))[1]&0xffff) #define setlgef(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffff0000)+s) #define signe(x) (((GEN)(x))[1]>>24) #endif #define setsigne(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffffff)+((s)<<24)) #define typ(x) (((unsigned plong)((GEN)(x))[0])>>24) #define settyp(x,s) (((GEN)(x))[0]=(((GEN)(x))[0]&0xffffff)+((s)<<24)) #define pere(x) ((unsigned plong)(((GEN)(x))[0]&0xffffff)>>16) #define setpere(x,s) (((GEN)(x))[0]=(((GEN)(x))[0]&0xff00ffff)+((s)<<16)) #define expo(x) ((((GEN)(x))[1]&0xffffff)-0x800000) #define setexpo(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xff000000)+(0x800000+s)) #define valp(x) ((((GEN)(x))[1]&0xffff)-0x8000) #define setvalp(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffff0000)+(0x8000+s)) #define precp(x) (((unsigned plong)((GEN)(x))[1])>>16) #define setprecp(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffff)+((s)<<16)) #define varn(x) ((((GEN)(x))[1]&0xff0000)>>16) #define setvarn(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xff00ffff)+((s)<<16)) #define mant(x,i) ((((GEN)(x))[1]&0xff000000)?((GEN)(x))[i+1]:0) #define setmant(x,i,s) (((GEN)(x))[i+1]=s) #define affrs(x,s) (err(affer4)) #define affri(x,y) (err(affer5)) #define mpshift(x,s) ((typ(x)==1)?shifti(x,s):shiftr(x,s)) #define cmpis(x,y) (-cmpsi(y,x)) #define cmprs(x,y) (-cmpsr(y,x)) #define cmpri(x,y) (-cmpir(y,x)) #define subis(x,y) (addsi(-y,x)) #define subrs(x,y) (addsr(-y,x)) #define divii(a,b) (dvmdii(a,b,0)) #define resii(a,b) (dvmdii(a,b,-1)) #define affsz(s,x) ((typ(x)==1)?affsi(s,x):affsr(s,x)) #define mpneg(x) ((typ(x)==1)?negi(x):negr(x)) #define mpabs(x) ((typ(x)==1)?absi(x):absr(x)) #define mpinvz(x,y) ((typ(x)==1)?divsiz(1,x,y):divsrz(1,x,y)) #define mpnegz(x,y) ((typ(x)==1)?gop1z(negi,x,y):gop1z(negr,x,y)) #define mpabsz(x,y) ((typ(x)==1)?gop1z(absi,x,y):gop1z(absr,x,y)) #define mpshiftz(x,s,y) ((typ(x)==1)?gops2gsz(shifti,x,s,y):gops2gsz(shiftr,x,s,y)) #define mptruncz(x,y) (gop1z(mptrunc,x,y)) #define mpentz(x,y) (gop1z(mpent,x,y)) #define mpaddz(x,y,z) (gop2z(mpadd,x,y,z)) #define addsiz(s,y,z) (gops2sgz(addsi,s,y,z)) #define addsrz(s,y,z) (gops2sgz(addsr,s,y,z)) #define addiiz(x,y,z) (gop2z(addii,x,y,z)) #define addirz(x,y,z) (gop2z(addir,x,y,z)) #define addriz(x,y,z) (gop2z(addir,y,x,z)) #define addrrz(x,y,z) (gop2z(addrr,x,y,z)) #define mpsubz(x,y,z) (gop2z(mpsub,x,y,z)) #define subsiz(s,y,z) (gops2sgz(subsi,s,y,z)) #define subsrz(s,y,z) (gops2sgz(subsr,s,y,z)) #define subisz(y,s,z) (gops2sgz(addsi,-s,y,z)) #define subrsz(y,s,z) (gops2sgz(addsr,-s,y,z)) #define subiiz(x,y,z) (gop2z(subii,x,y,z)) #define subirz(x,y,z) (gop2z(subir,x,y,z)) #define subriz(x,y,z) (gop2z(subri,x,y,z)) #define subrrz(x,y,z) (gop2z(subrr,x,y,z)) #define mpmulz(x,y,z) (gop2z(mpmul,x,y,z)) #define mulsiz(s,y,z) (gops2sgz(mulsi,s,y,z)) #define mulsrz(s,y,z) (gops2sgz(mulsr,s,y,z)) #define muliiz(x,y,z) (gop2z(mulii,x,y,z)) #define mulirz(x,y,z) (gop2z(mulir,x,y,z)) #define mulriz(x,y,z) (gop2z(mulir,y,x,z)) #define mulrrz(x,y,z) (gop2z(mulrr,x,y,z)) #define mpinvsr(s,y) (divssz(1,s,y)) #define mpinvir(x,y) (divsiz(1,x,y)) #define mpinvrr(x,y) (divsrz(1,x,y)) #define mpdvmdz(x,y,z,t) (dvmdiiz(x,y,z,t)) #define modssz(s,y,z) (gops2ssz(modss,s,y,z)) #define modsiz(s,y,z) (gops2sgz(modsi,s,y,z)) #define modisz(y,s,z) (gops2gsz(modis,y,s,z)) #define ressiz(s,y,z) (gops2sgz(ressi,s,y,z)) #define resisz(y,s,z) (gops2gsz(resis,y,s,z)) #define resssz(s,y,z) (gops2ssz(resss,s,y,z)) #define mpmodz(x,y,z) (modiiz(x,y,z)) #define mpresz(x,y,z) (resiiz(x,y,z)) #define divirz(x,y,z) (gop2z(divir,x,y,z)) #define divriz(x,y,z) (gop2z(divri,x,y,z)) #define divsrz(s,y,z) (gops2sgz(divsr,s,y,z)) #define divrsz(y,s,z) (gops2gsz(divrs,y,s,z)) GEN cgetr(),cgeti(),gerepile(),stoi(); GEN negi(),negr(),absi(),absr(); GEN mptrunc(),mpent(),shifts(),shifti(),shiftr(); GEN addsi(),addsr(),addii(),addir(),addrr(),mpadd(); GEN subsi(),subsr(),subii(),subir(); GEN subri(),subrr(),mpsub(); GEN mulss(),mulsi(),mulsr(),mulii(),mulir(),mulrr(),mpmul(); GEN divsi(),divis(),divsr(),divrs(),divir(); GEN divri(),divrr(),mpdiv(),convi(),confrac(); GEN modss(),resss(),modsi(),ressi(),modis(),resis(),modii(); GEN dvmdii(),dvmdsi(),dvmdis(); plong itos(),vals(),vali(),divisii(); int expi(); void affii(),affir(),affrr(),mulsii(),addsii(),divsiz(),divisz(),divssz(); void dvmdssz(),dvmdsiz(),dvmdisz(),dvmdiiz(),mpdivz(),modiiz(); void diviiz(),divrrz(),cgiv(); gcl-2.6.14/h/rgbc.h0000755000175000017500000000044114360276512012312 0ustar cammcamm/* (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. Copying of this file is authorized to users who have executed the true and proper "License Agreement for Kyoto Common LISP" with SIGLISP. */ /* macros for realtime garbage collection */ #define take_care(x) ; gcl-2.6.14/h/lu.h0000644000175000017500000001554114360276512012021 0ustar cammcamm#include "pbits.h" #undef bool typedef int bool; typedef long long lfixnum; typedef unsigned long long ulfixnum; typedef long fixnum; typedef unsigned long ufixnum; typedef float shortfloat; typedef double longfloat; typedef union lispunion *object; typedef union typeunion *hobj; #ifndef WORDS_BIGENDIAN #define FIRSTWORD ufixnum e:1,m:1,f:1,s:1,tt:4,t:5,st:3,w:LM(16) #define FSTPWORD ufixnum emfs:4, tp:9, st:3,w:LM(16) #define MARKWORD ufixnum e:1, mf:2,s:1,tt:4,t:5,x:LM(13) #define SGCMWORD ufixnum e:1,mfs:3, tt:4,t:5,x:LM(13) #define TYPEWORD ufixnum emf:3, s:1,tt:4,t:5,x:LM(13) #define FUNWORD ufixnum e:1,m:1,f:1,s:1,tt:4,t:5,fun_minarg:6,fun_maxarg:6,fun_neval:5,fun_vv:1,y:LM(31) #else #define FIRSTWORD ufixnum w:LM(16),st:3,t:5,tt:4,s:1,f:1,m:1,e:1 #define FSTPWORD ufixnum w:LM(16),st:3,tp:9, emfs:4 #define MARKWORD ufixnum x:LM(13), t:5,tt:4,s:1, mf:2,e:1 #define SGCMWORD ufixnum x:LM(13), t:5,tt:4, mfs:3,e:1 #define TYPEWORD ufixnum x:LM(13), t:5,tt:4,s:1, emf:3 #define FUNWORD ufixnum y:LM(31),fun_vv:1,fun_neval:5,fun_maxarg:6,fun_minarg:6,t:5,tt:4,s:1,f:1,m:1,e:1 #endif #if SIZEOF_LONG < 8 #define SPAD object pad #else #define SPAD #endif struct fixnum_struct { FIRSTWORD; fixnum FIXVAL; }; struct shortfloat_struct { FIRSTWORD; shortfloat SFVAL; }; struct longfloat_struct { FIRSTWORD; longfloat LFVAL; SPAD; }; struct bignum { FIRSTWORD; #ifdef GMP __mpz_struct big_mpz_t; #else plong *big_self; int big_length; #endif }; struct ratio { FIRSTWORD; object rat_den; object rat_num; SPAD; }; struct ocomplex { FIRSTWORD; object cmp_real; object cmp_imag; SPAD; }; struct character { FIRSTWORD; unsigned short ch_code; unsigned char ch_font; unsigned char ch_bits; }; struct symbol { FIRSTWORD; object s_dbind; void (*s_sfdef) (); char *s_self; short s_stype; short s_mflag; int s_fillp; object s_gfdef; object s_plist; object s_hpack; SPAD; }; struct package { FIRSTWORD; object p_name; object p_nicknames; object p_shadowings; object p_uselist; object p_usedbylist; object *p_internal; object *p_external; int p_internal_size; int p_external_size; int p_internal_fp; int p_external_fp; struct package *p_link; SPAD; }; struct cons { #ifdef WIDE_CONS FIRSTWORD; #endif object c_cdr; object c_car; }; struct htent { object hte_key; object hte_value; }; struct hashtable { FIRSTWORD; struct htent *ht_self; object ht_rhsize; object ht_rhthresh; int ht_nent; int ht_size; short ht_test; short ht_static; struct htent *ht_cache; }; struct array { FIRSTWORD; object a_displaced; short a_rank; short a_elttype; object *a_self; int a_dim; int *a_dims; short a_adjustable; short a_offset; SPAD; }; struct vector { FIRSTWORD; object v_displaced; short v_hasfillp; short v_elttype; object *v_self; int v_dim; int v_fillp; short v_adjustable; short v_offset; SPAD; }; struct string { FIRSTWORD; object st_displaced; short st_hasfillp; short st_adjustable; char *st_self; int st_dim; int st_fillp; }; struct ustring { FIRSTWORD; object ust_displaced; short ust_hasfillp; short ust_adjustable; unsigned char *ust_self; int ust_dim; int ust_fillp; }; struct bitvector { FIRSTWORD; object bv_displaced; short bv_hasfillp; short bv_elttype; char *bv_self; int bv_dim; int bv_fillp; short bv_adjustable; short bv_offset; SPAD; }; struct fixarray { FIRSTWORD; object fixa_displaced; short fixa_rank; short fixa_elttype; fixnum *fixa_self; int fixa_dim; int *fixa_dims; short fixa_adjustable; short fixa_offset; SPAD; }; struct sfarray { FIRSTWORD; object sfa_displaced; short sfa_rank; short sfa_elttype; shortfloat *sfa_self; int sfa_dim; int *sfa_dims; short sfa_adjustable; short sfa_offset; SPAD; }; struct lfarray { FIRSTWORD; object lfa_displaced; short lfa_rank; short lfa_elttype; longfloat *lfa_self; int lfa_dim; int *lfa_dims; short lfa_adjustable; short lfa_offset; SPAD; }; struct s_data { object name; fixnum length; object raw; object included; object includes; object staticp; object print_function; object slot_descriptions; object slot_position; fixnum size; object has_holes; }; struct structure { FIRSTWORD; object str_def; object *str_self; SPAD; }; struct stream { FIRSTWORD; void *sm_fp; object sm_object0; object sm_object1; char *sm_buffer; ufixnum sm_mode:4; ufixnum sm_flags:6; ufixnum sm_fd:6; ufixnum sm_int:LM(16); }; struct random { FIRSTWORD; __gmp_randstate_struct rnd_state; }; struct readtable { FIRSTWORD; struct rtent *rt_self; object rt_case; SPAD; }; struct pathname { FIRSTWORD; object pn_host; object pn_device; object pn_directory; object pn_name; object pn_type; object pn_version; object pn_namestring; }; struct cfun { FIRSTWORD; object cf_name; void (*cf_self) (); object cf_data; }; struct cclosure { FIRSTWORD; object cc_name; void (*cc_self) (); object cc_env; object cc_data; int cc_envdim; object *cc_turbo; SPAD; }; struct closure { FIRSTWORD; object cl_name; object (*cl_self) (); object cl_data; int cl_argd; int cl_envdim; object *cl_env; }; struct sfun { FIRSTWORD; object sfn_name; object (*sfn_self) (); object sfn_data; int sfn_argd; SPAD; }; struct vfun { FIRSTWORD; object vfn_name; object (*vfn_self) (); object vfn_data; unsigned short vfn_minargs; unsigned short vfn_maxargs; SPAD; }; struct cfdata { FIRSTWORD; char *cfd_start; int cfd_size; int cfd_fillp:31; int cfd_prof:1; object *cfd_self; SPAD; }; struct spice { FIRSTWORD; int spc_dummy; }; struct dummy { FIRSTWORD; }; struct ff { ufixnum ff; }; struct fstpw { FSTPWORD; }; union fstp { ufixnum ff; struct fstpw t; }; struct mark { MARKWORD; }; struct typew { TYPEWORD; }; struct sgcm { SGCMWORD; }; union lispunion { struct fixnum_struct FIX; struct bignum big; struct ratio rat; struct shortfloat_struct SF; struct longfloat_struct LF; struct ocomplex cmp; struct character ch; struct symbol s; struct package p; struct cons c; struct hashtable ht; struct array a; struct vector v; struct string st; struct ustring ust; struct bitvector bv; struct structure str; struct stream sm; struct random rnd; struct readtable rt; struct pathname pn; struct cfun cf; struct cclosure cc; struct closure cl; struct sfun sfn; struct vfun vfn; struct cfdata cfd; struct spice spc; struct dummy d; struct fstpw fstp; struct ff ff; struct mark md; struct sgcm smd; struct typew td; fixnum fw; void *vw; struct fixarray fixa; struct sfarray sfa; struct lfarray lfa; }; union typeunion { struct dummy d; fixnum fw; }; gcl-2.6.14/h/alpha-osf1.h0000755000175000017500000000562214360276512013336 0ustar cammcamm #include "att.h" #define PAGEWIDTH 12 #define HAVE_FLOAT_H #define HAVE_AOUT /* make the default allocated relblock suitable for pointer alignment */ #define USE_PARI_MULLL /* #define PLONG_IS_64BIT */ #undef NUMBER_OPEN_FILES #define NUMBER_OPEN_FILES getdtablesize() #define ADDITIONAL_FEATURES \ ADD_FEATURE("MIPS") ; ADD_FEATURE("DLOPEN"); \ ADD_FEATURE("LD-NOT-ACCEPT-DATA") ; \ ADD_FEATURE("POINTER-BIGGER-INT") ; \ ADD_FEATURE("EXPECT-UNRESOLVED") /* we dont tack on the data file but rather use it */ #define SEEK_TO_END_OFILE(x) fseek(x,0,2) /* #define mips 1 The system defines this */ #define IEEEFLOAT /* The exponent and most signif are in the second word for doubles */ #define LITTLE_END #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text); /* text relocated; data is page-aligned after the text */ #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(PAGSIZ-1)) & ~(PAGSIZ-1)) #define PAGSIZ 4096 #define TXTRELOC 4096 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define RELOC_FILE "rel_coff.c" #undef SFASL #undef NEED_GETWD #ifdef IN_UNIXFSYS #undef ATT #define BSD #endif #ifdef IN_UNIXTIME #undef ATT #define BSD #endif /* #define DBEGIN 0x12000000 */ #define TBEGIN 0x10000000 #define NOFREE_ERR /* #define INT_TO_ADDRESS(x) ((long) x ? (object) (0x100000000 | (long) x) : (object )0) */ #define INT_TO_ADDRESS(x) ((void *)(long)x) #define NULL_OR_ON_C_STACK(x) ((long)x < TBEGIN) #define TEXT_START TBEGIN #define DATA_START DBEGIN #define UNIXSAVE "unexmips.c" /* #define UNIXFASL "faslosf.c" */ #define UNIXFASL "fasldlsym.c" #define USE_DLOPEN #define MAKE_SHARED_LIB /* this is a pretty poor test... */ #define IS_NOT_SHARED_OBJECT(fhdr,faslstream) \ (fhdr.f_nscns < 8) #define LD_SHARED(filename,buf) \ sprintf(com,"ld -shared %s -expect_unresolved '*' -o %s -lc",filename, buf) #define HAVE_GETDTABLESIZE #define SIGPROTV SIGBUS #define GET_FAULT_ADDR(sig,code,sv,a) ((char *) code) #define MPROTECT_FAIL_VALUE -1 /* void * is not accepted by compiler */ #define NO_VOID_STAR #undef IF_ALLOCATE_ERR #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {int ll; \ if ((ll=(int)(sbrk(0) - core_end)) <= PAGESIZE) \ {sbrk(PAGESIZE - ll); \ \ heap_end=core_end = sbrk(0); }\ else \ error("Someone allocated my memory!");} \ if (core_end != (sbrk(PAGESIZE*(n - m)))) #define DO_BEFORE_SAVE setbuf(stdin,0) ; setbuf(stdout,0) ;setbuf(stderr,0) ; #define INIT_CORE_END terminal_io->sm.sm_object0->sm.sm_fp = stdin;terminal_io->sm.sm_object1->sm.sm_fp = stdout; #ifdef IN_NUM_CO #include #endif /* Begin for cmpinclude */ #define SYSTEM_SPECIAL_INIT static init_code(){do_init(VV);} #define plong int /* #define SGC */ /* End for cmpinclude */ gcl-2.6.14/h/386-kfreebsd.h0000644000175000017500000000242114360276512013475 0ustar cammcamm#include "linux.h" #ifdef IN_GBC /* #undef MPROTECT_ACTION_FLAGS */ /* #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO */ /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((siginfo_t *)code)->si_addr */ /* the following two files have changed back and forth in recent versions of linux... Include both if they both exist, otherwise include whatever one exists... basically one wants the struct sigcontext_struct { ... } ; so as to get the fault address. */ #if !defined(SIGNAL_H_HAS_SIGCONTEXT) && !defined(HAVE_SIGCONTEXT) #error Need sigcontext on 386 linux #else #include #ifndef SIGNAL_H_HAS_SIGCONTEXT #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif #endif #endif #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC #define RELOC_H "elf32_i386_reloc.h" #define BRK_DOES_NOT_GUARANTEE_ALLOCATION #define FREEBSD gcl-2.6.14/h/compbas.h0000755000175000017500000000027714360276512013030 0ustar cammcamm#include #define _VA_LIST_DEFINED #ifndef EXTER #define EXTER extern #endif #ifndef INLINE #ifdef OLD_INLINE #define INLINE extern inline #else #define INLINE inline #endif #endif gcl-2.6.14/h/elf32_arm_reloc.h0000644000175000017500000000140514360276512014331 0ustar cammcamm#define R_ARM_MOVW_ABS_NC 43 #define R_ARM_MOVT_ABS 44 #define R_ARM_CALL 28 #define R_ARM_V4BX 40 case R_ARM_MOVW_ABS_NC: s+=a; s&=0xffff; s=(s&0xfff)|((s>>12)<<16); add_vals(where,~0L,s); break; case R_ARM_MOVT_ABS: s+=a; s>>=16; s=(s&0xfff)|((s>>12)<<16); add_vals(where,~0L,s); break; case R_ARM_CALL: case R_ARM_JUMP24: { long x=((long)(s+a-p))/4; if (abs(x)&(~MASK(23))) { got+=(sym->st_size-1)*tz; memcpy(got,tramp,sizeof(tramp)); /*recurse on relocate?*/ got[sizeof(tramp)/sizeof(*got)]=s; x=((long)got-p)/4; } add_vals(where,MASK(24),x); } break; case R_ARM_V4BX: case R_ARM_ABS32: add_vals(where,~0L,s+a); break; gcl-2.6.14/h/NetBSD.h0000755000175000017500000000553314360276512012463 0ustar cammcamm/* NetBSD.h based on original - 386-bsd.h Hacked September/93 by Paul F. Werkowsksi for 386BSD. Tested on i486 EISA 16MB hardware/386BSD 0.1 + PatchKit 0.2.4 * gcc-2.3.3 * SGC enabled (big performance win but needs a small kernel hack) * Files in September-16-92-Systems.tar (PCL clcs loop clx) compile & run. CLUE also compiles and runs. 16 MB insufficient memory to compile CLIO. Hacked November/93 by Werkowski for FreeBSD. Essentially no changes except to use 'unexlin.c' instead of 'unixsave.c'. FreeBSD 1.0.2 has (at this time 17-Nov-93) a bug in stdio that needs repair before this will work - otherwise use libc.a from 386bsd pk2.4. The 'bug' is that vfprintf prints out a 0l0 as ' 0e+00' while akcl edit_double in print.d expects something like ' 0.00000000000e+00'. Richard Tobin ported akcl-1.619 to NetBSD 0.9 Bill Morgart 10/19/94 Ported gcl-1.0 to NetBSD 1.0Beta Modified gcl-1.1 for NetBSD 1.0Beta (static linked) */ #include "bsd.h" /*#include "386.h" /* NOT if you want this to work on 386bsd!!!*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("386BSD");\ ADD_FEATURE("NetBSD"); #define I386 /* ?? this is apparently not used anywhere */ #define IEEEFLOAT /* NetBSD stdio is based on chris torek's work, no setbuf */ #define NO_SETBUF #define setup_stream_buffer(x) #define deallocate_stream_buffer(x) /* #undef HAVE_XDR */ #define USE_ATT_TIME /* begin listen for input */ #undef LISTEN_FOR_INPUT /* default in bsd.h is loser in 386bsd */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_r <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0; /* end listen for input */ /* begin stuff for dumping and reloading */ #define DATA_BEGIN (char *)N_DATADDR(header); #define A_TEXT_OFFSET(x) (sizeof (struct exec)) #define A_TEXT_SEEK(hdr) (N_TXTOFF(hdr) + A_TEXT_OFFSET(hdr)) #define start_of_data() &etext #define start_of_text() ((char *)(sizeof(struct exec) + getpagesize())) #define UNIXSAVE "unexec.c" #ifdef UNIXSAVE extern char etext; #endif #define RELOC_FILE "rel_sun3.c" /* for SFASL - enabled in bsd.h */ /* end stuff for dumping and reloading */ #define HZ 60 /* begin for GC */ #define PAGEWIDTH 12 /* i386 sees 4096 byte pages */ #define HARDWARE_PAGESIZE (1 << PAGEWIDTH) /* end for GC */ /* begin read_header */ #undef READ_HEADER #define READ_HEADER \ fread(&header, sizeof(header), 1, original); \ data_begin=DATA_BEGIN; \ { \ int extra = ((int)sbrk(0) & (HARDWARE_PAGESIZE - 1)); \ if(extra != 0) \ sbrk(HARDWARE_PAGESIZE - extra); \ } \ data_end = sbrk(0); \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ header.a_bss = 0; \ fwrite(&header, sizeof(header), 1, save); \ fflush(save); /* end read header */ gcl-2.6.14/h/apply_n.h0000644000175000017500000003340514360276512013042 0ustar cammcammstatic inline object c_apply_n(object (*f)(), int n, object *x) { switch (n) { case 0: return f(); case 1: return f(x[0]); case 2: return f(x[0],x[1]); case 3: return f(x[0],x[1],x[2]); case 4: return f(x[0],x[1],x[2],x[3]); case 5: return f(x[0],x[1],x[2],x[3],x[4]); case 6: return f(x[0],x[1],x[2],x[3],x[4],x[5]); case 7: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6]); case 8: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7]); case 9: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8]); case 10: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9]); case 11: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10]); case 12: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11]); case 13: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12]); case 14: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13]); case 15: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14]); case 16: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15]); case 17: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16]); case 18: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17]); case 19: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18]); case 20: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19]); case 21: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20]); case 22: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21]); case 23: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22]); case 24: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23]); case 25: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24]); case 26: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25]); case 27: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26]); case 28: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27]); case 29: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28]); case 30: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29]); case 31: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30]); case 32: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31]); case 33: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32]); case 34: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33]); case 35: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34]); case 36: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35]); case 37: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36]); case 38: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37]); case 39: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38]); case 40: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39]); case 41: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40]); case 42: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41]); case 43: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42]); case 44: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43]); case 45: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44]); case 46: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45]); case 47: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46]); case 48: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47]); case 49: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48]); case 50: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49]); case 51: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50]); case 52: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51]); case 53: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52]); case 54: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53]); case 55: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54]); case 56: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55]); case 57: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56]); case 58: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57]); case 59: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58]); case 60: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58],x[59]); case 61: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58],x[59],x[60]); case 62: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58],x[59],x[60],x[61]); case 63: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58],x[59],x[60],x[61],x[62]); case 64: return f(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],x[8],x[9],x[10],x[11],x[12],x[13],x[14],x[15],x[16],x[17],x[18],x[19],x[20],x[21],x[22],x[23],x[24],x[25],x[26],x[27],x[28],x[29],x[30],x[31],x[32],x[33],x[34],x[35],x[36],x[37],x[38],x[39],x[40],x[41],x[42],x[43],x[44],x[45],x[46],x[47],x[48],x[49],x[50],x[51],x[52],x[53],x[54],x[55],x[56],x[57],x[58],x[59],x[60],x[61],x[62],x[63]); default: FEerror("Exceeded call-arguments-limit ",0);return Cnil; } } #include static inline object c_apply_vp1(object (*f)(),int n,object *b) { object *b1=alloca((n+1)*sizeof(object)); memcpy(b1,b,n*sizeof(object)); b1[n]=OBJNULL; return c_apply_n(f,n+1,b1); } static inline object c_apply_n_fun(object fun,int n,object *b) { return !n && type_of(fun)==t_vfun && n==fun->vfn.vfn_minargs && nvfn.vfn_maxargs ? c_apply_vp1(fun->vfn.vfn_self,n,b) : c_apply_n(fun->vfn.vfn_self,n,b); } static inline object c_apply_n_f(object (*f)(),int n,object *b,int min,int max) { return !n && n==min && n b ? a : b) #define SEEK_TO_END_OFILE(fp)\ do{ int m; \ Elf32_Ehdr eheader; \ Elf32_Shdr shdr; \ fseek(fp,0,SEEK_SET); \ fread(&eheader,sizeof(eheader),1,fp); \ fseek(fp,eheader.e_shoff+(eheader.e_shnum -1) \ *eheader.e_shentsize,0); \ fread(&shdr,eheader.e_shentsize,1,fp); \ fseek(fp,OUR_MAX(shdr.sh_offset+ shdr.sh_size, \ eheader.e_shoff+(eheader.e_shnum) \ *eheader.e_shentsize) \ , SEEK_SET);\ }while(0) #ifdef IN_UNIXFSYS #undef ATT #define BSD #endif /* #define DBEGIN 0x600000 */ /* #define UNIXSAVE "save_sgi4.c" */ /* for irix 5... */ #undef UNIXSAVE /* #define UNIXSAVE "unexelf.c" */ #define UNIXSAVE "unexelfsgi.c" #ifdef IN_UNIXSAVE #define round_up round_up1 #define bss_end core_end #endif #define INIT_CORE_END brk(core_end); #ifdef IN_UNIXFASL #include #endif #define UNIXFASL "fasldlsym.c" #define USE_DLOPEN #define IS_NOT_SHARED_OBJECT(fhdr,faslstream) \ (fhdr.f_nscns < 6) #define LD_SHARED(filename,buf) \ sprintf(com,"ld -shared %s -ignore_unresolved -o %s -lc",filename, buf) #define DO_BEFORE_SAVE \ { extern int did_a_dynamic_load; if (did_a_dynamic_load) \ FEerror("Sorry, Cant save an image with dynamically loaded .o files",0);} #define HAVE_GETDTABLESIZE /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/twelve_null0000755000175000017500000000001414360276512013503 0ustar cammcammgcl-2.6.14/h/writable.h0000644000175000017500000000210014360276512013175 0ustar cammcammEXTER fixnum last_page; EXTER int last_result; INLINE int set_writable(fixnum i,bool m) { fixnum j; object v; last_page=last_result=0; if (i=page(heap_end)) error("out of heap in set_writable"); if ((v=sSAwritableA ? sSAwritableA->s.s_dbind : Cnil)==Cnil) error("no wrimap in set_writable"); if ((j=i-first_data_page)<0 || j>=v->v.v_dim)/*FIXME*/ return 0; if ((void *)wrimap!=(void *)v->v.v_self) error("set_writable called in gc"); writable_pages+=m-((wrimap[j/8]>>(j%8))&0x1); if (m) wrimap[j/8]|=(1<<(j%8)); else wrimap[j/8]&=~(1<<(j%8)); return 0; } INLINE int is_writable(fixnum i) { fixnum j; object v; if (i=page(core_end)) return 0; if ((v=sSAwritableA ? sSAwritableA->s.s_dbind : Cnil)==Cnil) return 1; if ((j=i-first_data_page)<0 || j>=v->v.v_dim) return 1; return (wrimap[j/8]>>(j%8))&0x1; } INLINE int is_writable_cached(fixnum i) { if (last_page==i) return last_result; last_page=i; return last_result=is_writable(i); } gcl-2.6.14/h/mips.h0000755000175000017500000000144314360276512012350 0ustar cammcamm /* amazingly the only instructions which the mips seems to have for overflow is add and sub which signal: Integer overflow SIGTRAP BRK_OVERFLOW on overflow. Of course that is much too expensive. Their div instruction does only 32 by 32 bit divide. */ #ifdef __GNUC__ /* so have assembler macros */ /* mulul is a macro: f = mulul(a,b,h) <--> h:f == a*b */ #define mulul(x,y,hiremainder) \ ({ulong __x =(x),__y=(y),__res; \ asm volatile("multu %2,%3\n\tmflo %0\n\tmfhi %1" \ :"=r" (__res),"=r" (hiremainder) \ :"r" (__x),"r"(__y)); \ __res;}) /* add_carry: add X and Y adding 1 to H if there was overflow H is presumed to be small enough not to overflow */ #else /* not gcc */ #endif #define BASE_COUNTER -1 gcl-2.6.14/h/att_ext.h0000755000175000017500000003620014360276512013047 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef COM_LENG #define COM_LENG #endif /* alloc.c */ void *alloc_page(); object alloc_object(); void *malloc(size_t); void *realloc(void *,size_t); /* void * memalign(size_t,size_t); */ void *alloc_contblock(size_t); void *alloc_relblock(size_t); /* object fSallocate_contiguous_pages(); */ /* object fSallocate_relocatable_pages(); */ /* array.c */ /* enum aelttype Iarray_element_type(); */ object fLrow_major_aref(); object fSaset1(); EXTER object sLarray_dimension_limit; EXTER object sLarray_total_size_limit; object fSmake_array1(); /* object fSmake_vector1(); */ /* assignment.c */ /* object setf(); */ /* backq.c */ EXTER int backq_level; EXTER object sLlistA; EXTER object sLappend; EXTER object sLnconc; /* bds.c */ /* big.c */ object make_integer_clear(); object stretch_big(); object copy_big(); object copy_to_big(); object big_minus(); object big_plus(); object big_times(); object normalize_big_to_object(); double big_to_double(); EXTER struct bignum big_fixnum1_body,big_fixnum2_body,big_fixnum3_body,big_fixnum4_body; EXTER object big_fixnum1,big_fixnum2,big_fixnum3,big_fixnum4; object maybe_replace_big(); /* bind.c */ EXTER object ANDoptional; EXTER object ANDrest; EXTER object ANDkey; EXTER object ANDallow_other_keys; EXTER object ANDaux; EXTER object sKallow_other_keys; object find_special(); object let_bind(); object letA_bind(); /* block.c */ /* cfun.c */ object make_cfun(); object MF(); /* object MM(); */ /* object make_function_internal(); */ /* object make_si_function_internal(); */ /* object make_special_form_internal(); */ object make_macro(); object make_cclosure_new(); /* character.d */ EXTER object STreturn; EXTER object STspace; EXTER object STrubout; EXTER object STpage; EXTER object STtab; EXTER object STbackspace; EXTER object STlinefeed; EXTER object STnewline; object coerce_to_character(); /* catch.c */ /* cmpaux.c */ char object_to_char(); char *object_to_string(); float object_to_float(); double object_to_double(); /* error.c */ EXTER object sKcatch; EXTER object sKprotect; EXTER object sKcatchall; EXTER object sKdatum; EXTER object sKexpected_type; EXTER object sKpackage; EXTER object sKformat_control; EXTER object sKformat_arguments; object wrong_type_argument(); EXTER object sSuniversal_error_handler; /* eval.c */ EXTER object sLapply; EXTER object sLfuncall; object simple_lispcall(); object simple_lispcall_no_event(); object simple_symlispcall(); object simple_symlispcall_no_event(); EXTER object siVevalhook; EXTER object siVapplyhook; object ieval(); object ifuncall(object,int,...); object ifuncall1(); object ifuncall2(); object ifuncall3(); object fcalln1(object,...); #define fcalln ((object (*)())fcalln1) object Ieval(); object Imacro_expand1(); /* unixfasl.c fasload.c */ /* file.d */ EXTER object sKabort; EXTER object sKappend; EXTER object sKcreate; EXTER object sKdefault; EXTER object sKdirection; EXTER object sKelement_type; EXTER object sKif_does_not_exist; EXTER object sKif_exists; EXTER object sKinput; EXTER object sKio; EXTER object sKnew_version; EXTER object sKoutput; EXTER object sKoverwrite; EXTER object sKprint; EXTER object sKprobe; EXTER object sKrename; EXTER object sKrename_and_delete; EXTER object sKset_default_pathname; EXTER object sKsupersede; EXTER object sKverbose; EXTER object sLAstandard_inputA; EXTER object sLAstandard_outputA; EXTER object sLAerror_outputA; EXTER object sLAquery_ioA; EXTER object sLAdebug_ioA; EXTER object sLAterminal_ioA; EXTER object sLAtrace_outputA; EXTER object terminal_io; EXTER object standard_io; EXTER object standard_error; EXTER object sLAload_verboseA; EXTER object FASL_string; /* object stream_element_type(); */ object open_stream(); /* object make_two_way_stream(); */ /* object make_echo_stream(); */ object make_string_input_stream(); object make_string_output_stream(); /* object get_output_stream_string(); */ object read_fasl_data(); #ifdef UNIX /* unixfsys.c */ FILE *backup_fopen(); #else /* filesystem.c */ FILE *backup_fopen(); #endif /* frame.c */ frame_ptr frs_sch(); frame_ptr frs_sch_catch(); /* gbc.c */ EXTER bool GBC_enable; #ifdef CAN_UNRANDOMIZE_SBRK EXTER bool gcl_unrandomized; #endif /* let.c */ /* lex.c */ object assoc_eq(); object lex_tag_sch(); object lex_block_sch(); /* list.d */ EXTER object sKtest; EXTER object sKtest_not; EXTER object sKkey; EXTER object sKrev; object car(); object cdr(); object kar(); object kdr(); object caar(); object cadr(); object cdar(); object cddr(); object caaar(); object caadr(); object cadar(); object caddr(); object cdaar(); object cdadr(); object cddar(); object cdddr(); object caaaar(); object caaadr(); object caadar(); object caaddr(); object cadaar(); object cadadr(); object caddar(); object cadddr(); object cdaaar(); object cdaadr(); object cdadar(); object cdaddr(); object cddaar(); object cddadr(); object cdddar(); object cddddr(); object nth(); object nthcdr(); object make_cons(); object list(fixnum,...); object listA(fixnum,...); object append(); object copy_list(); object make_list(); object nconc(); object sublis1(); /* macros.c */ EXTER object sLAmacroexpand_hookA; EXTER object sSdefmacroA; object macro_expand(); /* main.c */ EXTER char* system_directory; void error(); object vs_overflow(void); EXTER object sSAsystem_directoryA; #ifdef UNIX EXTER char *kcl_self; #endif EXTER bool raw_image; char *merge_system_directory(); EXTER object sLquote; EXTER object sLlambda; EXTER object sSlambda_block; EXTER object sSlambda_closure; EXTER object sSlambda_block_closure; EXTER object sLfunction; EXTER object sSmacro; EXTER object sStag; EXTER object sLblock; /* mapfun.c */ /* multival.c */ /* number.c */ EXTER object shortfloat_zero; EXTER object longfloat_zero; /* #define make_fixnum(a) ({fixnum _a=(a);((_a+SMALL_FIXNUM_LIMIT)&(-2*SMALL_FIXNUM_LIMIT))==0?small_fixnum(_a):make_fixnum1(_a);}) */ object make_fixnum1(long); object make_ratio(); object make_shortfloat(); object make_longfloat(); object make_complex(); double number_to_double(); long fixint(object); /* num_pred.c */ /* num_comp.c */ /* num_arith */ object bignum2(); object bignum3(); /* object number_to_complex(); */ object complex_plus(); object number_plus(); object number_negate(); object number_minus(); object number_times(); object number_divide(); object number_expt(); object integer_divide1(); object get_gcd(); object get_lcm(); object one_plus(); object one_minus(); object fixnum_add(); object fixnum_sub(); object new_bignum(); /* num_co.c */ object double_to_integer(); /* num_log.c */ object shift_integer(); /* package.d */ EXTER object lisp_package; EXTER object user_package; EXTER object keyword_package; EXTER object system_package; EXTER object sLApackageA; EXTER object sKinternal; EXTER object sKexternal; EXTER object sKinherited; EXTER object sKnicknames; EXTER object sKuse; EXTER int intern_flag; EXTER object uninterned_list; /* object make_package(); */ /* object in_package(); */ /* object rename_package(); */ object find_package(); /* object coerce_to_package(); */ object current_package(); object intern(); object find_symbol(); /* pathname.d */ EXTER object Vdefault_pathname_defaults; EXTER object sKwild; EXTER object sKnewest; EXTER object sKstart; EXTER object sKend; EXTER object sKjunk_allowed; EXTER object sKhost; EXTER object sKdevice; EXTER object sKdirectory; EXTER object sKname; EXTER object sKtype; EXTER object sKversion; EXTER object sKdefaults; EXTER object sKabsolute; EXTER object sKrelative; EXTER object sKup; /* object parse_namestring(); */ object coerce_to_pathname(); /* object default_device(); */ object merge_pathnames(); object namestring(); object coerce_to_namestring(); /* print.d */ EXTER object sKupcase; EXTER object sKdowncase; EXTER object sKcapitalize; EXTER object sKpreserve; EXTER object sKinvert; EXTER object sKstream; EXTER object sKreadably; EXTER object sKescape; EXTER object sKpretty; EXTER object sKcircle; EXTER object sKbase; EXTER object sKradix; EXTER object sKcase; EXTER object sKgensym; EXTER object sKlevel; EXTER object sKlength; EXTER object sKarray; EXTER object sLAprint_readablyA; EXTER object sLAprint_escapeA; EXTER object sLAprint_prettyA; EXTER object sLAprint_circleA; EXTER object sLAprint_baseA; EXTER object sLAprint_radixA; EXTER object sLAprint_caseA; EXTER object sLAprint_gensymA; EXTER object sLAprint_levelA; EXTER object sLAprint_lengthA; EXTER object sLAprint_arrayA; EXTER object *PRINTvs_top; EXTER object *PRINTvs_limit; EXTER object PRINTstream; EXTER bool PRINTreadably; EXTER bool PRINTescape; EXTER bool PRINTpretty; EXTER bool PRINTcircle; EXTER int PRINTbase; EXTER bool PRINTradix; EXTER object PRINTcase; EXTER bool PRINTgensym; EXTER int PRINTlevel; EXTER int PRINTlength; EXTER bool PRINTarray; EXTER void (*write_ch_fun)(int); object princ(); object prin1(); object print(); object terpri(); EXTER object sSpretty_print_format; EXTER int line_length; /* Read.d */ EXTER object standard_readtable; EXTER object Vreadtable; EXTER object sLAread_default_float_formatA; EXTER object sLAread_baseA; EXTER object sLAread_suppressA; EXTER object READtable; EXTER object read_byte1(); EXTER int READdefault_float_format; EXTER int READbase; EXTER bool READsuppress; EXTER object siSsharp_comma; EXTER bool escape_flag; EXTER object delimiting_char; EXTER bool detect_eos_flag; /* bool in_list_flag; */ EXTER bool dot_flag; EXTER bool preserving_whitespace_flag; EXTER object default_dispatch_macro; EXTER object big_register_0; EXTER int sharp_eq_context_max; object read_char(); object read_char1(object,object); object peek_char(); /* object read_object_recursive(); */ object read_object_non_recursive(); object standard_read_object_non_recursive(); object read_object(); /* object parse_number(); */ /* object parse_integer(); */ /* object copy_readtable(); */ /* object current_readtable(); */ /* object patch_sharp(); */ object read_fasl_vector(); /* fasdump.c */ EXTER object sharing_table; /* reference.c */ object symbol_function(); /* sequence.d */ object alloc_simple_vector(); object alloc_simple_bitvector(); object elt(); object elt_set(); object reverse(); object nreverse(); /* structure.c */ EXTER object sSs_data; object structure_ref(); object structure_set(); object structure_to_list(); /* string.d */ object alloc_simple_string(); object make_simple_string(); object copy_simple_string(); object coerce_to_string(); EXTER int string_sign, string_boundary; /* symbol.d */ EXTER object string_register; EXTER object gensym_prefix; /* EXTER int gensym_counter; */ EXTER object sLgensym_counter; EXTER object gentemp_prefix; EXTER int gentemp_counter; EXTER object token; object make_symbol(); object make_ordinary(); object make_special(); object make_constant(); object make_si_ordinary(); object make_si_special(); object make_si_constant(); object make_keyword(); object symbol_value(); object symbol_name(); object getf(); object get(); object putf(); object putprop(); object sputprop(); object remprop(); object gensym(); /* to be deleted */ #ifdef UNIX /* unixsys.c */ #else /* sys.c */ #endif #ifdef UNIX /* unixtime.c */ object unix_time_to_universal_time(); #else /* time.c */ #endif /* toplevel.c */ EXTER object sLspecial,sLdeclare; EXTER object sSvariable_documentation; EXTER object sSfunction_documentation; /* typespec.c */ EXTER object sLcommon,sLnull,sLcons,sLlist,sLsymbol,sLarray,sLvector,sLbit_vector,sLstring; EXTER object sLsequence,sLsimple_array,sLsimple_vector,sLsimple_bit_vector,sLsimple_string; EXTER object sLcompiled_function,sLpathname,sLcharacter,sLnumber,sLrational,sLfloat; EXTER object sLinteger,sLreal,sLratio,sLshort_float,sLstandard_char,sLfixnum,sLpositive_fixnum, sLcomplex; EXTER object sLsingle_float,sLpackage,sLbignum,sLrandom_state,sLdouble_float,sLstream,sLbit,sLreadtable; EXTER object sLlong_float,sLhash_table,sLstructure,sLboolean; EXTER object sLdivision_by_zero,sLfloating_point_inexact,sLfloating_point_invalid_operation; EXTER object sLfloating_point_overflow,sLfloating_point_underflow; EXTER object sLarithmetic_error,sLbase_char,sLbase_string,sLbroadcast_stream,sLbuilt_in_class; EXTER object sLcell_error,sLclass,sLconcatenated_stream,sLcondition,sLcontrol_error; EXTER object sLecho_stream,sLend_of_file,sLerror,sLextended_char,sLfile_error,sLfile_stream; EXTER object sLgeneric_function,sLlogical_pathname,sLmethod,sLpackage_error; EXTER object sLparse_error,sLprint_not_readable,sLprogram_error,sLreader_error,sLserious_condition; EXTER object sLsimple_base_string,sLsimple_condition,sLsimple_type_error,sLsimple_warning,sLstandard_class; EXTER object sLstandard_generic_function,sLstandard_method,sLstandard_object,sLstorage_condition; EXTER object sLstream_error,sLstring_stream,sLstructure_class,sLstyle_warning,sLsynonym_stream; EXTER object sLtwo_way_stream,sLtype_error,sLunbound_slot,sLunbound_variable,sLundefined_function,sLwarning; EXTER object sLmethod_combination,sLstructure_object; EXTER object sLsatisfies; EXTER object sLmember; EXTER object sLnot; EXTER object sLor; EXTER object sLand; EXTER object sLvalues; EXTER object sLmod; EXTER object sLsigned_byte; EXTER object sLunsigned_byte; EXTER object sSsigned_char; EXTER object sSunsigned_char; EXTER object sSsigned_short; EXTER object sSunsigned_short; EXTER object sLA; EXTER object sLplusp; EXTER object TSor_symbol_string; EXTER object TSor_string_symbol; EXTER object TSor_symbol_string_package; EXTER object TSnon_negative_integer; EXTER object TSpositive_number; EXTER object TSor_integer_float; EXTER object TSor_rational_float; #ifdef UNIX EXTER object TSor_pathname_string_symbol; #endif EXTER object TSor_pathname_string_symbol_stream; EXTER int interrupt_flag; /* console interupt flag */ EXTER int interrupt_enable; /* console interupt enable */ EXTER object sLAlink_arrayA; /* nfunlink.c */ object Icall_proc(); float Icall_proc_float(); /* object Icall_proc(); */ float Icall_proc_float(); object ImakeStructure(); object list_vector(); object list_vector_new(); object Iapply_ap(); object IisFboundp(); object IapplyVector(); EXTER object sSPmemory; EXTER object sSPinit; object sLfset(); object MakeAfun(); extern object call_proc0(); /* extern object call_proc(); */ /* extern object call_vproc(); */ object fLrow_major_aref(); object Icheck_one_type(); /* utils.c */ object Iis_fixnum(); object Iapply_fun_n(object,int,int,...); object Iapply_fun_n1(object (*)(),int,int,...); object Iapply_fun_n2(object,int,int,...); object Ifuncall_n(object,int,...); object Ivs_values(); object Icheck_one_type(); object fSincorrect_type(); gcl-2.6.14/h/symmetry.defs0000755000175000017500000000171114360276512013761 0ustar cammcamm # Machine dependent makefile definitions for Sequent Symmetry/DYNIX-3.0.12+ # by Marion Hakanson , Oregon Graduate Institute. # $Id$ LBINDIR=/usr/local/bin # Put cmplinclude.h in $(RUNDIR)/include, and # put unixport/saved_gcl in $(RUNDIR) as well. # That way we don't have to keep sources online. RUNDIR = /usr/local/gcl #defs for the makefiles # symmetry OFLAG = -O LIBS = -lm -lg ODIR_DEBUG= CHTAB = char_table.s # CC = cc -DVOL= -I$(GCLDIR)/o # If you don't have gcc use above CC = gcc -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -I$(RUNDIR)/include CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s gcl-2.6.14/h/hp300.defs0000755000175000017500000000266514360276512012733 0ustar cammcammLBINDIR=/public/bin #defs for the makefiles # hp900/3XX OFLAG = -O ODIR_DEBUG= -O LIBS= -lm SHELL=/bin/sh .IGNORE: CHTAB = hp_chtab.s SYMTAB = +Ns6000 CC = cc +Ns6000 +Np2000 +Nt40000 -DVOL=volatile -I$(GCLDIR)/o # If you have gcc use # CC = gcc -msoft-float -DVOL=volatile -I$(GCLDIR)/o LIBS = -lm #end gcc # make demand loadable LDFLAG = -q CFLAGS = -c $(DEFS) -I../h $(SYMTAB) # in versions of HP-UX before 6.01, where the ld -A option was not # available, you can use spp to build a file to link with. # SPP=spp # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. RSYM = rsym SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # until rel_hp300.c can handle the new relocation type put out by # the hp c compiler, we do the following. INITFORM=(si::build-symbol-table)(setq compiler::*cc* (si::string-concatenate compiler::*cc* "-O ")) # Use symbolic links SYMB=-s # You should try to compile mpi.c with gcc, since there # are gcc assembler macros which give a large speedup. # The following will do that, but you may not be able to # link a gcc object with ordinary cc objects (depending on # whether 'gas' was used) # MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a # if there is no gcc use: MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a gcl-2.6.14/h/elf32_mips_reloc.h0000644000175000017500000000271414360276512014526 0ustar cammcamm case R_MIPS_JALR: break; case R_MIPS_GPREL32: add_val(where,~0L,s+a-(ul)got); break; case R_MIPS_26: if (((s+a)>>28)!=(((ul)where)>>28)) { gote=got+sym->st_size-1; massert(!write_26_stub(s+a,got,gote)); store_val(where,MASK(26),((ul)gote)>>2); } else add_val(where,MASK(26),(s+a)>>2); break; case R_MIPS_32: add_val(where,~0L,s+a); break; case R_MIPS_GOT16: if (sym->st_shndx) { /* this should be followed by a LO16 */ store_val(where,0xffe00000,0x3c000000); r->r_info=ELF_R_INFO(ELF_R_SYM(r->r_info),R_MIPS_HI16); relocate(sym1,r,a,start,got,gote); break; } case R_MIPS_CALL16: gote=got+sym->st_size-1; store_val(where,MASK(16),((void *)gote-(void *)got)); if (s>=ggot && sst_other) s=gpd=(ul)got-(sym->st_other==2 ? 0 : (ul)where); if (!hr) hr=r; if (a) add_vals(where,MASK(16),(s>>16)+a); break; case R_MIPS_LO16: if (sym->st_other) s=gpd ? gpd : ({massert(sym->st_other==2);(ul)got;}); a=*where&MASK(16); if (a&0x8000) a|=0xffff0000; a+=s&MASK(16); a+=(a&0x8000)<<1; store_val(where,MASK(16),a); a=0x10000|(a>>16); for (hr=hr ? hr : r;--r>=hr;) if (ELF_R_TYPE(r->r_info)==R_MIPS_HI16) relocate(sym1,r,a,start,got,gote); hr=NULL;gpd=0; break; gcl-2.6.14/h/page.h0000755000175000017500000000746414360276512012325 0ustar cammcamm#define MAYBE_DATA_P(pp) ((char *)(pp)>= (char *) data_start)/*DBEGIN*/ #define VALID_DATA_ADDRESS_P(pp) (MAYBE_DATA_P(pp) && ((char *)(pp) < heap_end)) #ifndef page #define page(p) (((unsigned long)(p))>>PAGEWIDTH) #define pagetochar(x) ((char *)((((unsigned long)x) << PAGEWIDTH) + sizeof(struct pageinfo))) #define pageinfo(x) ((struct pageinfo *)(((ufixnum)x)&(-PAGESIZE))) #define pagetoinfo(x) ((struct pageinfo *)((((ufixnum)x)<type) ? pageinfo(x)->sgc_flags&SGC_PAGE_FLAG : ((object)x)->d.s) #endif #define TM_BASE_TYPE_P(i) (tm_table[i].tm_type == i) /* is this an sgc cell? encompasses all free cells. Used where cell cannot yet be marked */ #ifndef SIGPROTV #define SIGPROTV SIGSEGV #endif #ifndef INSTALL_MPROTECT_HANDLER #define INSTALL_MPROTECT_HANDLER gcl_signal(SIGPROTV, memprotect_handler) #endif #else /* END SGC */ #define sgc_quit() #define sgc_start() #define sgc_count_type(x) 0 #endif extern int sgc_enabled; #define TM_NUSED(pt) (((pt).tm_npage*(pt).tm_nppage) - (pt).tm_nfree - (pt).tm_alt_nfree) extern long resv_pages; extern int reserve_pages_for_signal_handler; extern struct pageinfo *cell_list_head,*cell_list_tail; extern object contblock_array; #define PAGE_MAGIC 0x2e extern unsigned char *wrimap; extern fixnum writable_pages; #define CLEAR_WRITABLE(i) set_writable(i,0) #define SET_WRITABLE(i) set_writable(i,1) #define WRITABLE_PAGE_P(i) is_writable(i) #define CACHED_WRITABLE_PAGE_P(i) is_writable_cached(i) #define ON_WRITABLE_PAGE(x) WRITABLE_PAGE_P(page(x)) #define ON_WRITABLE_PAGE_CACHED(x) CACHED_WRITABLE_PAGE_P(page(x)) EXTER long first_data_page,real_maxpage,phys_pages,available_pages; EXTER void *data_start,*initial_sbrk; #if defined(SGC) #include "writable.h" #endif #define CB_BITS CPTR_SIZE*CHAR_SIZE #define ceil(a_,b_) (((a_)+(b_)-1)/(b_)) #define npage(m_) ceil(m_,PAGESIZE) #define cpage(m_) CEI(({ufixnum _m=(m_);ceil(sizeof(struct pageinfo)+_m+2*ceil(_m,(CB_BITS-2)),PAGESIZE);}),256) #define mbytes(p_) ceil((p_)*PAGESIZE-sizeof(struct pageinfo),CB_BITS) #define tpage(tm_,m_) (tm_->tm_type==t_relocatable ? npage(m_-(rb_limit-rb_pointer)+1) : (tm_->tm_type==t_contiguous ? cpage(m_) : npage(m_))) #define CB_DATA_SIZE(z_) ({fixnum _z=(z_);_z*PAGESIZE-2*mbytes(_z)-sizeof(struct pageinfo);}) #define CB_MARK_START(pi_) ((void *)(pi_)+sizeof(struct pageinfo)) #define CB_SGCF_START(pi_) ((void *)(pi_)+sizeof(struct pageinfo)+mbytes(pi_->in_use)) #define CB_DATA_START(pi_) ((void *)(pi_)+sizeof(struct pageinfo)+2*mbytes(pi_->in_use)) #define CB_DATA_END(pi_) ((void *)(pi_)+PAGESIZE*(pi_)->in_use) gcl-2.6.14/h/erreurs.h0000755000175000017500000001012514360276512013064 0ustar cammcammenum { /* PAS D'ERREUR */ noer, /* ERREURS DANS MP.S OU MP.C */ affer1, affer2, affer3, affer4, affer5, exger1, exger2, shier1, shier2,truer1, truer2, adder1, adder2, adder3, adder4, adder5, muler1, muler2, muler3,muler4, muler5, muler6, diver1, diver2, diver3, diver4, diver5, diver6, diver7,diver8, diver9, diver10, diver11, diver12, divzer1, dvmer1, dvmzer1, moder1, modzer1,reser1, reszer1, arier1, arier2, errpile, rtodber, gerper, divller1, /* ERREURS DANS ALGLIN.C */ gtraner, gadmaer, gadsmaer, concater, extracter1, extracter2, extracter3,matextrer, matinv1, matinv2, mattype1, mattype2, mattype3, invmuler1, gausser1, kerer1, /* ERREUR DANS ANAL.C */ matcher1, recter1, vectmater1, unknowner1, caracer1, numvarer, assigner1, referer1, referer2, valencer1, trucer1, paramer1, eolner1, varer1, killer1, arrayer1, nparamer1, /* ERREURS DANS ARITH.C */ arither1, arither2, facter, puissmoder, invmoder, sfconter1, sfconter2, hiler1, hiler2, chiner, funder1, funder2, factorer1, classer1, classer2, qfer1, qfer2, orderer, generer, primer1, issquer1, /* ERREURS DANS BASE.C */ hnfer1, hnfer2, /* ERREURS DANS BIBLI.C */ laper1, laper2, convol1, convol2, convol3, grandoer1, csper1, precer1,discer1, sommeer1, proder1, polrecer1, vecer1, mater1, recer1, recer2, lller1, lllger1, lllger2,linder1, linder2, algder1, recprimer, changer1, changer2, reorder1, reorder2, reorder3, intger2,sorter1, polinter1, polinter2, zbrenter1, zbrenter2, eulsumer1, level, vecer2, initeler1, initeler2, heller1, zeller1, apeller1, forer1, forer2, /* ERREURS DANS ES.C */ nomvar, quader, formater, /* ERREURS DANS GEN1.C */ gadder1, gadder2, gadder4, gadder5, gadder6, gadder7, gadder9, gadder10, gadder11, gadder12, gadder13, gadder15, gmuler1, gmuler2, gmuler4, gmuler5, gmuler7, gmuler8, gmuler9, gmuler10, gmuler11, gmuler12, gmuler14, gdiver1, gdiver2, gdiver3, gdiver4, gdiver6, gdiver7, gdiver8, gdiver9, gdiver10, gdiver11, gdiver12, gdiver13, gdiver15, gdiver16, gdiver17, gdiver18, gdiver19, /* ERREURS DE GEN2.C ET GEN3.C */ grefer1, mneter, gexpoer1, gexpoer2, gcmper, gtolger, gvaler2, gvaler4, gabser, gaffsger1, gaffsger2, gaffer1, gaffer2, gaffer3, gaffer4, gaffer5, gaffer6, gaffer7, gaffer8, gaffer9, gaffer10, gaffer11, gaffer12, gaffer13, gaffer14, gaffer15, gaffer16,gaffer17, gaffer18, gaffer19, gaffer20, gaffer21, gadder14, gpuier1, gpuier2, gpuier3, gpuier4, gdiventer, gdivmoder, bezer1, bezer2, ginvmoder, gmul2ner1, ginver, gnormaler, gmoder1, gmoder3, gmoder5, gsubser1, gsubser2, gsubser3, gsubser4, gsubser5, reciper, derer, inter1, inter2, flooer, rounder, cvtoier, cvtoper1, cvtoper2, rndtoier, ceiler, truncer, compoer1, tdeger, gsigner, iscomplexer1, denomer1, numerer1, /* ERREUR DANS INIT.C */ memer, interrupter, newblocer1, nomer, /* ERREURS DANS POLARIT.C */ poler1, poler2, poler3, poler4, poler5, poler6, poler7, poler8, poler9,poler10, poler15, bezoutpoler, factmoder, gcder1, gcder2, gcder3, gcder4, subrer1, subrer2, discsrer1, polgcder1, poltyper, sturmer2, factpol1, /* ERREURS DANS TRANS.C */ normer1, normer2, conjer1, realer1, imager1, sqrter1, sqrter2, sqrter3,sqrter4, sqrter5, sqrter6, exp1er, exper1, exper2, exper3, loger1, loger2, loger3, loger4,loger5, sc1er1, sc1er2, coser1, coser2, coser3, coser4, siner1, siner2, siner3,siner4, sicoer1, sicoer2, sicoer3, taner1, taner2, taner3, ataner1, ataner2, ataner3,ataner4, asiner1, asiner2, asiner3, asiner4, asiner5, acoser1, acoser2, acoser3,acoser4, acoser5, arger1, arger2, cher1, cher2, cher3, sher1, sher2, sher3, ther1, ther2, ther3, asher1, asher2, asher3, asher4, acher1, acher2, acher3, acher4,ather1, ather2, ather3, ather4, gamer1, gamer2, gamer3, gamer4, gamder1, gamder2,gamder3, psier1, psier2, loger6, teicher1, paexper1, agmer1, transcer1, thetaer1, jbesselher1, zetaer1, zetaer2, zetaer3, /* BARATIN GENERAL */ talker, /* ERREUR PAS ENCORE IMPLEMENTE */ impl }; gcl-2.6.14/h/mp.h0000755000175000017500000001074014360276512012014 0ustar cammcamm #ifdef GMP #include "gmp.h" /* define to show we included mp.h */ #define _MP_H #define MP_ALLOCATED(x) MP(x)->_mp_alloc #define MP_SELF(x) MP(x)->_mp_d #define MP_SIZE(x) MP(x)->_mp_size #define MP_LIMB_SIZE sizeof(mp_limb_t) #define MP(x) (&((x)->big.big_mpz_t)) #define MP_ASSIGN_OBJECT(u,x) (type_of(x) == t_bignum ? mpz_set(u,MP(x)) : mpz_set_si(u,fix(x))) /* temporary holders to put fixnums in ... */ typedef struct { MP_INT mpz; mp_limb_t body; } mpz_int; /* for integers which are in the fixnum range, we allocate a temporary place in the stack which we use to convert this into an MP */ #define SI_TEMP_DECL(w) mpz_int w #define SI_TO_MP(x, temp) (mpz_set_si(MP(temp),(x)), MP(temp)) #define INTEGER_TO_MP(x, temp ) \ (type_of(x) == t_bignum ? MP(x) : SI_TO_MP(fix(x), temp)) #define INTEGER_TO_TEMP_MP(x, temp ) \ (type_of(x) == t_bignum ? (MP_ASSIGN_OBJECT(MP(temp),x),MP(temp)) : SI_TO_MP(fix(x), temp)) #define MPOP(action,function,x1,x2) \ do { \ function(MP(big_fixnum2) ,x1,x2); \ action maybe_replace_big(big_fixnum2); \ } while(0) #define MPOP_DEST(where,function,x1,x2) \ do { extern MP_INT *verify_mp(); \ function(MP(where),x1,x2); \ verify_big_or_zero(where); \ } while(0) /* #define MYmake_fixnum(action,x) \ */ /* do{register int CMPt1; \ */ /* action \ */ /* ((((CMPt1=(x))+1024)&-2048)==0?small_fixnum(CMPt1):make_fixnum1(CMPt1));}while(0) */ #define ineg(a_) (sizeof(a_)==sizeof(unsigned) ? (unsigned)-(a_) : (unsigned long)-(a_)) #define addii mpz_add #define addsi(u,a,b) (a >= 0 ? mpz_add_ui(u,b,a) : mpz_sub_ui(u,b,ineg(a))) #define addss(u,a,b) addsi(u,a,SI_TO_MP(b,big_fixnum1)) #define mulii mpz_mul #define mulsi(u,s,i) mpz_mul_si(u,i,s) #define mulss(u,s1,s2) mpz_mul_si(u,SI_TO_MP(s1,big_fixnum1),s2) #define subii mpz_sub #define subsi(u,a,b) mpz_sub(u,SI_TO_MP(a,big_fixnum1),b) #define subis(u,a,b) (b >= 0 ? mpz_sub_ui(u,a,b) : mpz_add_ui(u,a,ineg(b))) #define subss(u,a,b) subis(u,SI_TO_MP(a,big_fixnum1),b) #define shifti(u,a,w) (w>=0 ? mpz_mul_2exp(u,a,w) : mpz_fdiv_q_2exp(u,a,ineg(w))) #define cmpii(a,b) mpz_cmp(a,b) #define BIG_SIGN(x) mpz_sgn(MP(x)) #define MP_SIGN(x) mpz_sgn(MP(x)) #define signe(u) mpz_sgn(u) #define ZERO_BIG(x) (mpz_set_ui(MP(x),0)) /* force to be positive or negative according to sign. */ #define SET_BIG_SIGN(x,sign) \ do{if (sign < 0) {if (big_sign(x) > 0) mpz_neg(MP(x),MP(x)); } \ else { if (big_sign(x) < 0) mpz_neg(MP(x),MP(x)); } } while(0) #define MP_LOW(u,n) (*(u)->_mp_d) /* the bit length of each word in bignum representation */ #define BIG_RADIX 32 /* #define MP_COUNT_BITS(u) mpz_sizeinbase(u,2) */ #define MP_BITCOUNT(u) mpz_bitcount(u) #define MP_SIZE_IN_BASE2(u) mpz_bitlength(u) #else #include "genpari.h" #undef K #undef subis #define subis(y,x) (x== (1<<31) ? addii(ABS_MOST_NEGS,y) : addsi(-x,y)) GEN subss(); #define SI_TO_MP(x,ignore) stoi(x) #define INT_FLAG 0x1010000 #define MP_ALLOCATED(x) (x)->big.big_length #define MP_SELF(x) (x)->big.big_self #define MP_LIMB_SIZE (sizeof(long)) #define MP_SELF(x) MP(x)._mp_d /* the bit length of each word in bignum representation */ #define BIG_RADIX 32 /* used for gc protecting */ object big_register_1; object big_minus(); object make_bignum(); object make_integer(); #define BIG_SIGN(x) signe(MP(x)) #define SET_BIG_SIGN(x,sign) setsigne(MP(x),sign) #define MP(x) ((GEN)((x)->big.big_self)) #define MP_START_LOW(u,x,l) u = (x)+l #define MP_START_HIGH(u,x,l) u = (x)+2 #define MP_NEXT_UP(u) (*(--(u))) #define MP_NEXT_DOWN(u) (*((u)++)) /* ith word from the least significant */ #define MP_ITH_WORD(u,i,l) (u)[l-i-1] #define MP_CODE_WORDS 2 /* MP_LOW(x,lgef(x)) is the least significant word */ #define MP_LOW(x,l) ((x)[(l)-1]) /* most significant word if l is the lgef(x) */ #define MP_HIGH(x,l) (x)[2] #define MP_ONLY_WORD(u) MP_LOW((u),(MP_CODE_WORDS+1)) #define MP_BITCOUNT(u) gen_bitcount(u) #define MP_SIZE_IN_BASE2(u) gen_bitlength(u) #define MP_FIRST(x) ((MP(x))[2]) #define MP_SIGN(x) (signe(MP(x))) #define ZERO_BIG(x) \ do { (x)->big.big_length = 2; \ (x)->big.big_self = gzero;} while(0) GEN addss(); #define MPOP(dowith, fun,x1,x2) \ do{GEN _xgen ; \ save_avma ; \ _xgen =fun(x1,x2) ;\ restore_avma; \ dowith make_integer(_xgen); }while(0) #define MPOP_DEST(where ,fun,x1,x2) \ do{GEN _xgen ; \ save_avma ; \ _xgen =fun(x1,x2) ;\ restore_avma; \ gcopy_to_big(_xgen,where); }while(0) #endif gcl-2.6.14/h/tsgc.h0000644000175000017500000000010714360276512012331 0ustar cammcamm#include "config.h" #ifdef SGC "#define SGC" #else "#undef SGC" #endif gcl-2.6.14/h/386-gnu.h0000755000175000017500000000342314360276512012507 0ustar cammcamm#include "linux.h" #ifdef IN_GBC /* #undef MPROTECT_ACTION_FLAGS */ /* #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO */ /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((siginfo_t *)code)->si_addr */ /* the following two files have changed back and forth in recent versions of linux... Include both if they both exist, otherwise include whatever one exists... basically one wants the struct sigcontext_struct { ... } ; so as to get the fault address. */ #if !defined(SIGNAL_H_HAS_SIGCONTEXT) && !defined(HAVE_SIGCONTEXT) #error Need sigcontext on 386 linux #else #include #ifndef SIGNAL_H_HAS_SIGCONTEXT #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif #endif #endif #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #ifndef SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) ((char *)code) #define SA_SIGINFO 0 #else #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr #endif /* #define GET_FAULT_ADDR(sig,code,sv,a) ((void *)(((struct sigcontext *)(&code))->cr2)) */ #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC #ifndef SA_NOCLDWAIT #define SA_NOCLDWAIT 0 /*fixme handler does waitpid(-1, ..., WNOHANG)*/ #endif #define PATH_MAX 4096 /*fixme dynamic*/ #define MAXPATHLEN 4096 /*fixme dynamic*/ #define MAX_BRK 0x70000000 /*GNU Hurd fragmentation bug*/ #define RELOC_H "elf32_i386_reloc.h" #define NEED_STACK_CHK_GUARD #undef HAVE_D_TYPE /*FIXME defined, but not implemented in readdir*/ #define NO_FILE_LOCKING /*FIXME*/ gcl-2.6.14/h/usig.h0000755000175000017500000000037714360276512012354 0ustar cammcamm typedef void (*handler_function_type)(); EXTER handler_function_type our_signal_handler[32]; #ifdef __MINGW32__ void main_signal_handler (int signo); #else void main_signal_handler(); #endif #define signal_mask(n) (1 << (n)) gcl-2.6.14/h/elf32_armhf_reloc.h0000644000175000017500000000436214360276512014654 0ustar cammcamm#define R_ARM_THM_CALL 10 #define R_ARM_THM_MOVW_ABS_NC 47 #define R_ARM_THM_MOVW_ABS 48 case R_ARM_THM_JUMP24: { long x=(long)(s+a-p); if (abs(x)&(~MASK(23))) { got+=(sym->st_size-1)*tz; memcpy(got,tramp,sizeof(tramp)); r->r_offset=(void *)got-(void *)start; r->r_info=ELF_R_INFO(ELF_R_SYM(r->r_info),R_ARM_THM_MOVW_ABS_NC); relocate(sym1,r,0,start,got,gote); r->r_offset=(void *)(got+1)-(void *)start; r->r_info=ELF_R_INFO(ELF_R_SYM(r->r_info),R_ARM_THM_MOVW_ABS); relocate(sym1,r,0,start,got,gote); x=((long)got-p); } if (ELF_ST_TYPE(sym->st_info)==STT_FUNC) x|=1; x-=4; /*FIXME maybe drop 4 and add_val below*/ x=((long)x>>1); store_val(where,MASK(11)<<16,(x&0x7ff)<<16); store_val(where,MASK(10),x>>11); store_val(where,MASK(1)<<(16+11),(~((x>>21&0x1)^(x>>23&0x1)))<<(16+11)); store_val(where,MASK(1)<<(16+13),(~((x>>22&0x1)^(x>>23&0x1)))<<(16+13)); store_val(where,MASK(1)<<10,(x>>23&0x1)<<10); } break; case R_ARM_THM_CALL: { long x=(long)(s+a-p); if (abs(x)&(~MASK(22))) { got+=(sym->st_size-1)*tz; memcpy(got,tramp,sizeof(tramp)); r->r_offset=(void *)got-(void *)start; r->r_info=ELF_R_INFO(ELF_R_SYM(r->r_info),R_ARM_THM_MOVW_ABS_NC); relocate(sym1,r,0,start,got,gote); r->r_offset=(void *)(got+1)-(void *)start; r->r_info=ELF_R_INFO(ELF_R_SYM(r->r_info),R_ARM_THM_MOVW_ABS); relocate(sym1,r,0,start,got,gote); x=((long)got-p); } if (ELF_ST_TYPE(sym->st_info)==STT_FUNC) x|=1; x-=4; /*FIXME maybe drop 4 and add_val below*/ x=((long)x>>1); store_val(where,MASK(11),x>>11); store_val(where,MASK(11)<<16,(x&0x7ff)<<16); } break; case R_ARM_THM_MOVW_ABS_NC: s+=a; if (ELF_ST_TYPE(sym->st_info)==STT_FUNC) s|=1; s&=0xffff; s=((s>>12)&0xf)|(((s>>11)&0x1)<<10)|((s&0xff)<<16)|(((s>>8)&0x7)<<28); add_vals(where,~0L,s); break; case R_ARM_THM_MOVW_ABS: s+=a; s>>=16; s=((s>>12)&0xf)|(((s>>11)&0x1)<<10)|((s&0xff)<<16)|(((s>>8)&0x7)<<28); add_vals(where,~0L,s); break; case R_ARM_ABS32: add_vals(where,~0L,s+a); break; gcl-2.6.14/h/prelink.h0000644000175000017500000000207314360276512013041 0ustar cammcamm/* prelink support for gcl images: if GCL references variables (as opposed to functions) defined in external shared libraries, ld will place COPY relocations in .rela.dyn pointing to a location in .bss for these references. Unexec will later incorporate this into a second .data section, causing prelink to fail. While one might prelink the raw images, which would then be inherited by the saved images, this is not convenient as part of the build process, so here we isolate the problematic references and compile as position independent code, changing the COPY reloc to some form of GOT. */ #ifdef NO_PRELINK_UNEXEC_DIVERSION #define PRELINK_EXTER #else #define PRELINK_EXTER extern #undef stdin #define stdin my_stdin #undef stdout #define stdout my_stdout #undef stderr #define stderr my_stderr #endif PRELINK_EXTER FILE *my_stdin; PRELINK_EXTER FILE *my_stdout; PRELINK_EXTER FILE *my_stderr; #ifdef USE_READLINE PRELINK_EXTER rl_compentry_func_t **my_rl_completion_entry_function_ptr; PRELINK_EXTER const char **my_rl_readline_name_ptr; #endif gcl-2.6.14/h/rios.h0000755000175000017500000001371614360276512012362 0ustar cammcamm#define ATT #define RIOS #define AIX #define AIX3 #include "att.h" #define USE_ULONG_ #define ADDITIONAL_FEATURES \ ADD_FEATURE("AIX");\ ADD_FEATURE("AIX3");\ ADD_FEATURE("RIOS");\ ADD_FEATURE("BUGGY-CC"); /* These are supplied in rios_ics.s #define USE_C_EXTENDED_DIV #define USE_C_EXTENDED_MUL */ #define IBMRT #define IEEEFLOAT #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if ((real_maxpage > MAXPAGE) || (ulimit(3) < 0)) \ real_maxpage = MAXPAGE; char *sdebug; #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {int ll; \ if ((ll=(int)(sbrk(0) - core_end)) < PAGESIZE) \ {sbrk(PAGESIZE - ll); \ \ core_end = sbrk(0); }\ else \ error("Someone allocated my memory!");} \ if (core_end != (sdebug=sbrk(PAGESIZE*(n - m)))) #define N_DATADDR(header) #define DATA_BEGIN (char *)header.a_dbase #define PAGEWIDTH 12 /* I don't know why all the bsd versions are subtracting this off I thought the header.a_text was the actual size of the text not including the header */ #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) /* smallest address data can occur */ /* #define DBEGIN 0x20000000 */ #define FIX_ADDRESS(jj) \ do {int del = (int) data_load_addr - DBEGIN; \ if (del && (0x20000000 & jj)) jj += del; \ {unsigned short x ; fread(&x,sizeof(short),1,symin); \ SYM_TC_OFF(c_table,i) = x;} \ } while(0) /* #define SYM_EXTERNAL_P(sym) (((sym)->n_sclass & (~N_SECT)) == C_EXT) #define SYM_UNDEF_P(sym) (((sym)->n_sclass & N_SECT) == N_UNDF) */ #define N_SECTION(sym) (((struct syment *)sym)->n_scnum) #define N_TYPE N_SECT /* the header is regared as part of the text */ #define N_RELOFF(header) A_TRELPOS(header) #define SYMNMLEN 8 /* aix3 #define TEXT_NSCN 2 #define DATA_NSCN 4 #define BSS_NSCN 5 */ /* aix4 */ #define TEXT_NSCN 1 #define DATA_NSCN 2 #define BSS_NSCN 3 /* in aix we must use the pointer to the constant pool for the init_code, not the actual pointer to the code. */ #define CALL_INIT \ { FUNC at=(FUNC)(init_address + memory->cfd.cfd_start ); \ if (at==0 || *(char **)at!= memory->cfd.cfd_start) \ FEerror("init code constant pool bad"); \ (*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, data);} /* find the first symbol in the data section: It should begin with with "_init_" and correspond to the beginning of the pcp pool for the init function..*/ /* #define DATA_NSCN 4 */ /* the section number of the data section : text,pad,data,...*/ #define FIND_INIT \ { if (*ptr==0 && (N_SECTION(sym) == DATA_NSCN ) && \ ((sym)->n_sclass == C_EXT) &&\ sym->n_value ) \ { char tem [9]; \ char *str=SYM_NAME(sym); \ dprintf(find init: %s ,str); \ if (str[0]=='i' && str[1]=='n' && str[2]=='i' && str[3]== 't' \ && str[4]=='_' && str[strlen(str)-1] !='X') \ *ptr= sym->n_value ; \ else {/* printf("The first data symbol was not the init"); */} \ }} #define RELOC_FILE "rel_rios.c" #define GETCWD /* the system defines a different getwd */ #define getwd ourgetwd /* these two symbols are too long for the rt pl8cc compiler */ #define check_type_or_pathname_string_symbol_stream check_type_or_path_or_strm #define check_type_or_Pathname_string_symbol check_type_or_path_sym #define TSor_pathname_string_symbol_stream TSor_path_string_sym_strm #define check_type_or_symbol_string_package check_type_or_sym_str_pack #ifdef IN_UNIXFSYS #define BSD #undef NEED_GETWD #undef ATT #endif #define NOFREE_ERR /* #define UNIXSAVE "saveaix3.c" */ #define UNIXSAVE "unexaix.c" #define ISCOFF(x) (x==479) /* Should really use this */ /* #define TEXT_NSCN (fileheader.f_opthdr > 28 ? header.o_sntext : 1) #define DATA_NSCN (fileheader.f_opthdr > 28 ? header.o_sndata : 2) #define BSS_NSCN (fileheader.f_opthdr > 28 ? header.o_snbss : 3) */ #define SYM_EXTERNAL_P(sym) ((sym)->n_sclass == C_EXT) #define EXT_and_TEXT_BSS_DAT(p) \ ( SYM_EXTERNAL_P(p) && \ ((p)->n_scnum == TEXT_NSCN || (p)->n_scnum == BSS_NSCN || \ (p)->n_scnum == DATA_NSCN )) #define CLEAR_CACHE do{extern system(),myics(); myics();\ system("true"); \ if (*next_toc_addresses_to_relocate) \ printf("did not relocate all toc addresses"); \ }while(0); /* Begin for cmpinclude */ #ifdef __GNUC__ # define alloca __builtin_alloca #else #pragma alloca #endif /* make signals stay installed, not lapse every time the signal is sent */ #define signal sigset /* NOTE: If you don't have the system call mprotect DON'T define this. I have added it to my own kernel. */ /* If you define this you must make available mprotect system call for the kernel. See aix3_mprotect directory. */ /* #define SGC #define GET_FAULT_ADDR(x,y,c,d) getfault() */ #define QUICK_DIV(x,y,h,hi)\ if ((int)y > 0 && y > h << 1) \ {return divsl3(x,y,hi);} /* _setjmp and _longjmp exist on bsd and are more efficient and handle the C stack which is all we need. [I think!] */ /* #define setjmp _setjmp #define longjmp _longjmp */ /* setjmp only lets you jump in one direction upwards in address */ #define SETJMP_ONE_DIRECTION /* End for cmpinclude */ /* if there is no input there return false */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_cnt <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0 /* have sys/ioctl.h */ #define HAVE_IOCTL #define HAVE_SIGACTION /* #define HAVE_XDR */ #define SHARP_EQ_CONTEXT_SIZE 1024 #undef VSSIZE #define VSSIZE 81520 #if defined(IN_SOCKETS) || defined(IN_GUIS) #include #undef bzero #define bzero(b,len) memset(b,0,len) #endif /* test a memory address */ #define NULL_OR_ON_C_STACK(x) ( x == 0 || (((unsigned int) x) >= 0x2f000000 )) gcl-2.6.14/h/sgi.h0000755000175000017500000000121014360276512012152 0ustar cammcamm#define SGI #include "bsd.h" #define USE_ATT_TIME #define ADDITIONAL_FEATURES \ ADD_FEATURE("SGI"); \ ADD_FEATURE("SGI3D"); \ ADD_FEATURE("MC68020") #define MC68020 #define IEEEFLOAT #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text); /* text relocated; data is page-aligned after the text */ #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(PAGSIZ-1)) & ~(PAGSIZ-1)) #define PAGSIZ 4096 #define TXTRELOC 4096 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define RELOC_FILE "rel_sun3.c" /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/hp800.defs0000755000175000017500000000360014360276512012726 0ustar cammcammLBINDIR=/public/bin #defs for the makefiles # hp900/3XX OFLAG = -O ODIR_DEBUG= -O # for rel 7 # ODIR_DEBUG= -O -DDBEGIN=0x40000000 LIBS= -lm SHELL=/bin/sh # .IGNORE: CC = cc -Wl,-B,immediate -DVOL=volatile CC = cc -DVOL=volatile +DA1.1 +DS1.1 #CC = gcc -DVOL=volatile # make ld happy by putting some nulls NULLFILE = ../h/twelve_null # If you have gcc use # CC = gcc -msoft-float -DVOL=volatile -I$(GCLDIR)/o # CC = mygcc -DVOL=volatile -msingle-code-quad LIBS = -lm -lc #end gcc # Use static libraries. # for when we bring the data down to regular space LDCC = cc -Wl,-n -Wl,-a,archive -Wl,-D0x800000 LDCC = cc -Wl,-a,archive #LDCC = gcc -static # LDCC = cc -Wl,-a,archive # in rel 8.01 -a archive uses the regular .a libraries (previous default). # LDCC = ${CC} -Wl,-a,archive # for rel 7 use LDCC = cc CFLAGS = -c $(DEFS) -I../h $(SYMTAB) # in versions of HP-UX before 6.01, where the ld -A option was not # available, you can use spp to build a file to link with. # SPP=spp # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # for our special gcc we want some flags. for cc you can delete this. # INITFORM=(setq compiler::*cc* "$(CC) -mcall-ble") # If using ordinary cc or ordinary gcc use: INITFORM= # Use symbolic links SYMB=-s # You should try to compile mpi.c with gcc, since there # are gcc assembler macros which give a large speedup. # The following will do that, but you may not be able to # link a gcc object with ordinary cc objects (depending on # whether 'gas' was used) # MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a # if there is no gcc use: MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a gcl-2.6.14/h/pbits.h0000644000175000017500000000035514360276512012517 0ustar cammcamm#define mjoin(a_,b_) a_ ## b_ #define Mjoin(a_,b_) mjoin(a_,b_) #include "arth.h" #define LM(a_) AM(AT(SIZEOF_LONG,8),a_) #if SIZEOF_LONG == 4 #define LL 2 #elif SIZEOF_LONG == 8 #define LL 3 #else #error "unknown SIZEOF_LONG" #endif gcl-2.6.14/h/elf32_m68k_reloc.h0000644000175000017500000000017414360276512014341 0ustar cammcamm case R_68K_32: add_val(where,~0L,s+a); break; case R_68K_PC32: add_val(where,~0L,s+a-p); break; gcl-2.6.14/h/rt_aix.defs0000755000175000017500000000171714360276512013364 0ustar cammcammLBINDIR=/usr/bin #defs for the makefiles # for rt OFLAG = -O OFLAG = LIBS = -lm -lg # for plc88 can't have this LIBS = -lm ODIR_DEBUG= SHELL=/bin/sh .IGNORE: # The -a option is necessary because of size limitiations, # for the files alloc.c, main.c, gbc.c. We add it for all! CC = cc -Nn3000 -DNO_VOID_STAR -DVOL= -I$(GCLDIR)/o -Wl,-S0xa000000 -a # Note pl8cc cannot compile c/fat_string.c. # When this fails just repeat the same command manually # using cc. # When using xlc: # CC = xlc -qlanglvl=ext -qnoprint -DCOM_LENG= -DVOL= -I$(GCLDIR)/o -Wl,-S0xa000000 # CC = pl8cc -DCOM_LENG=1 -DVOL= -I$(GCLDIR)/o -Wl,-S0xa000000 CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB= -s gcl-2.6.14/h/386-macosx.h0000644000175000017500000001421514360276512013206 0ustar cammcamm/* GCL config file for Mac OS X. To be used with the following configure switches : --enable-debug (optional) --enable-machine=powerpc-macosx --disable-statsysbfd --enable-custreloc Aurelien Chanudet */ /* For those who are using ACL2, please remember to enlarge your shell stack (ulimit -s 8192). */ #include "bsd.h" #define DARWIN /* Mac OS X has its own executable file format (Mach-O). */ #undef HAVE_AOUT #undef HAVE_ELF /** sbrk(2) emulation */ /* Alternatively, we could use the global variable vm_page_size. */ #define PAGEWIDTH 12 /* The following value determines the running process heap size. */ /* #define BIG_HEAP_SIZE 0x50000000 */ extern char *mach_mapstart; extern char *mach_maplimit; extern char *mach_brkpt; extern char *get_dbegin (); #include /* to get sbrk defined */ extern void *my_sbrk(long incr); #define sbrk my_sbrk /** (si::save-system "...") a.k.a. unexec implementation */ /* The implementation of unexec for GCL is based on Andrew Choi's work for Emacs. Previous pioneering implementation of unexec for Mac OS X by Steve Nygard. */ #define UNIXSAVE "unexmacosx.c" #undef malloc #define malloc my_malloc #undef free #define free my_free #undef realloc #define realloc my_realloc #undef valloc #define valloc my_valloc #undef calloc #define calloc my_calloc /** Dynamic loading implementation */ /* The sfasl{bfd,macosx,macho}.c files are included from sfasl.c. */ #ifdef HAVE_LIBBFD #define SEPARATE_SFASL_FILE "sfaslbfd.c" #else #define SPECIAL_RSYM "rsym_macosx.c" #define SEPARATE_SFASL_FILE "sfaslmacho.c" #endif /* The file has non Mach-O stuff appended. We need to know where the Mach-O stuff ends. */ #include extern int seek_to_end_ofile (FILE *); #define SEEK_TO_END_OFILE(fp) seek_to_end_ofile(fp) /** Stratified garbage collection implementation [ (si::sgc-on t) ] */ /* Mac OS X has sigaction (this is needed in o/usig.c) */ #define HAVE_SIGACTION /* Copied from {Net,Free,Open}BSD.h */ /* Modified according to Camm's instructions on April 15, 2004. */ #define HAVE_SIGPROCMASK /* until the sgc/save problem can be fixed. 20050114 CM*/ /* #define SGC */ #define MPROTECT_ACTION_FLAGS (SA_SIGINFO | SA_RESTART) #define INSTALL_MPROTECT_HANDLER \ do { \ static struct sigaction sact; \ sigfillset (&(sact.sa_mask)); \ sact.sa_flags = MPROTECT_ACTION_FLAGS; \ sact.sa_sigaction = (void (*) ()) memprotect_handler; \ sigaction (SIGBUS, &sact, 0); \ sigaction (SIGSEGV, &sact, 0); \ } while (0); /* si_addr not containing the faulting address is a bug in Darwin. Work around this by looking at the dar field of the exception state. */ #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,scp,addr) ((char *) (((ucontext_t *) scp)->uc_mcontext->es.dar)) */ /* #include #include #include #include void handler (int sig, siginfo_t *info, void *scp) { ucontext_t *uc = (ucontext_t *)scp; fprintf(stderr, "addr = 0x%08lx\n", uc->uc_mcontext->es.dar); _exit(99); } int main(void) { struct sigaction sact; int ret; sigfillset(&(sact.sa_mask)); sact.sa_flags = SA_SIGINFO; sact.sa_sigaction = (void (*)())handler; ret = sigaction (SIGBUS, &sact, 0); return *(int *)0x43; } */ /** Misc stuff */ #define IEEEFLOAT /* Mac OS X does not have _fileno as in linux.h. Nor does it have _cnt as in bsd.h. Let's see what we can do with this declaration found in {Net,Free,Open}BSD.h. */ #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) \ do {int c=0; \ if (((FILE *)fp)->_r <=0 && (c=0, ioctl(((FILE *)fp)->_file, FIONREAD, &c), c<=0)) \ return(FALSE); \ } while (0) #define GET_FULL_PATH_SELF(a_) \ do { \ extern int _NSGetExecutablePath (char *, unsigned long *); \ unsigned long bufsize = 1024; \ static char buf [1024]; \ static char fub [1024]; \ if (_NSGetExecutablePath (buf, &bufsize) != 0) { \ error ("_NSGetExecutablePath failed"); \ } \ if (realpath (buf, fub) == 0) { \ error ("realpath failed"); \ } \ (a_) = fub; \ } while (0) #ifdef _LP64 #define C_GC_OFFSET 4 #include #define RELOC_H "mach64_i386_reloc.h" #else #define RELOC_H "mach32_i386_reloc.h" #endif #define UC(a_) ((ucontext_t *)a_) #define SF(a_) ((siginfo_t *)a_) #define FPE_CODE(i_,v_) make_fixnum(FFN(fSfpe_code)(*(fixnum *)&UC(v_)->uc_mcontext->__fs.__fpu_fsw,UC(v_)->uc_mcontext->__fs.__fpu_mxcsr)) #define FPE_ADDR(i_,v_) make_fixnum(UC(v_)->uc_mcontext->__fs.__fpu_fop ? UC(v_)->uc_mcontext->__fs.__fpu_ip : (fixnum)SF(i_)->si_addr) #define FPE_CTXT(v_) list(3,make_fixnum((fixnum)&UC(v_)->uc_mcontext->__ss), \ make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_stmm0), \ make_fixnum((fixnum)&UC(v_)->uc_mcontext->__fs.__fpu_xmm0)) #define MC(b_) v.uc_mcontext->b_ #define REG_LIST(a_,b_) MMcons(make_fixnum(a_*sizeof(b_)),make_fixnum(sizeof(b_))) #define MCF(b_) ((MC(__fs)).b_) #ifdef __x86_64__ #define FPE_RLST "RAX RBX RCX RDX RDI RSI RBP RSP R8 R9 R10 R11 R12 R13 R14 R15 RIP RFLAGS CS FS GS" #else #error Missing reg list #endif #define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(21,MC(__ss))), \ REG_LIST(8,MCF(__fpu_stmm0)),REG_LIST(16,MCF(__fpu_xmm0)));}) #include /*PATH_MAX MAXPATHLEN*/ #undef MIN #undef MAX gcl-2.6.14/h/bds.h0000755000175000017500000000326614360276512012155 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* bds.h bind stack */ struct bds_bd { object bds_sym; /* symbol */ object bds_val; /* previous value of the symbol */ }; typedef struct bds_bd *bds_ptr; extern bds_ptr bds_org,bds_limit; EXTER bds_ptr bds_top; /* bind stack top */ #ifdef KCLOVM /* for multiprocessing */ EXTER struct bds_bd save_bind_stack[BDSSIZE + BDSGETA + BDSGETA]; EXTER bds_ptr bds_save_org; EXTER bds_ptr bds_save_limit; EXTER bds_ptr bds_save_top; #endif #define bds_check \ if (bds_top >= bds_limit) \ bds_overflow() /* do this so that an interrupt in the middle will leave the VALID part of the bds stack ie (<= bds_top) in a valid state, so that a throw out will be ok */ #define bds_bind(sym, val) \ ({object _sym=(sym),_val=(val);bds_ptr _b=++bds_top;(_b)->bds_sym=_sym;(_b)->bds_val=_sym->s.s_dbind;_sym->s.s_dbind=_val;}) #define bds_unwind1 \ ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top) gcl-2.6.14/h/object.h0000755000175000017500000004317714360276512012660 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* object.h */ /* Some system constants. */ #define TRUE 1 /* boolean true value */ #define FALSE 0 /* boolean false value */ #define NBPP 4 /* number of bytes per pointer */ #ifndef PAGEWIDTH #define PAGEWIDTH 11 /* page width */ #endif /* log2(PAGESIZE) */ #undef PAGESIZE #define PAGESIZE (1L << PAGEWIDTH) /* page size in bytes */ #define CHCODELIM 256 /* character code limit */ /* ASCII character set */ #define CHFONTLIM 1 /* character font limit */ #define CHBITSLIM 1 /* character bits limit */ #define CHCODEFLEN 8 /* character code field length */ #define CHFONTFLEN 0 /* character font field length */ #define CHBITSFLEN 0 /* character bits field length */ #define PHTABSIZE 512 /* number of entries */ /* in the package hash table */ #define ARANKLIM 64 /* array rank limit */ #define RTABSIZE CHCODELIM /* read table size */ #define CBMINSIZE 64 /* contiguous block minimal size */ #ifndef CHAR_SIZE #define CHAR_SIZE 8 /* number of bits in a char */ #endif #ifndef plong #define plong long #endif #define SIGNED_CHAR(x) (((char ) -1) < (char )0 ? (char) x \ : (x >= (1<<(CHAR_SIZE-1)) ? \ x - (((int)(1<<(CHAR_SIZE-1))) << 1) \ : (char ) x)) /* Definition of the type of LISP objects. */ typedef union int_object iobject; union int_object {object *o; fixnum i;}; #define SMALL_FIXNUM_LIMIT 1024 #define Msf(obje) (obje)->SF.SFVAL #define sf(x) Msf(x) #define Mlf(obje) (obje)->LF.LFVAL #define lf(x) Mlf(x) enum stype { /* symbol type */ stp_ordinary, /* ordinary */ stp_constant, /* constant */ stp_special /* special */ }; #define Cnil ((object)&Cnil_body) #define Ct ((object)&Ct_body) #define sLnil Cnil #define sLt Ct #define NOT_SPECIAL ((void (*)())Cnil) #define NOT_OBJECT_ALIGNED(a_) ({union lispunion _t={.vw=(void *)(a_)};_t.td.emf;}) /* The values returned by intern and find_symbol. File_symbol may return 0. */ #define INTERNAL 1 #define EXTERNAL 2 #define INHERITED 3 /* All the packages are linked through p_link. */ EXTER struct package *pack_pointer; /* package pointer */ #ifdef WIDE_CONS #define Scdr(a_) (a_)->c.c_cdr #else #define Scdr(a_) ({union lispunion _t={.vw=(a_)->c.c_cdr};unmark(&_t);_t.vw;}) #endif enum httest { /* hash table key test function */ htt_eq, /* eq */ htt_eql, /* eql */ htt_equal, /* equal */ htt_equalp /* equalp */ }; enum aelttype { /* array element type */ aet_object, /* t */ aet_ch, /* string-char */ aet_bit, /* bit */ aet_fix, /* fixnum */ aet_sf, /* short-float */ aet_lf, /* plong-float */ aet_char, /* signed char */ aet_uchar, /* unsigned char */ aet_short, /* signed short */ aet_ushort, /* unsigned short */ aet_last }; #define USHORT_GCL(x,i) (((unsigned short *)(x)->ust.ust_self)[i]) #define SHORT_GCL(x,i) ((( short *)(x)->ust.ust_self)[i]) #define BV_OFFSET(x) ((type_of(x)==t_bitvector ? x->bv.bv_offset : \ type_of(x)== t_array ? x->a.a_offset : (abort(),0))) #define SET_BV_OFFSET(x,val) ((type_of(x)==t_bitvector ? x->bv.bv_offset = val : \ type_of(x)== t_array ? x->a.a_offset=val : (abort(),0))) #if !defined(DOUBLE_BIGENDIAN) #define BIT_ENDIAN(a_) (7-(a_)) #else #define BIT_ENDIAN(a_) (a_) #endif #define S_DATA(x) ((struct s_data *)((x)->str.str_self)) #define SLOT_TYPE(def,i) (((S_DATA(def))->raw->ust.ust_self[i])) #define SLOT_POS(def,i) USHORT_GCL(S_DATA(def)->slot_position,i) #define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i)))) #define STSET(type,x,i,val) do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0) /* for any stream that takes writec_char, directly (not two_way or echo) ie. smm_output,smm_io, smm_string_output, smm_socket */ #define STREAM_FILE_COLUMN(str) ((str)->sm.sm_int) /* for smm_echo */ #define ECHO_STREAM_N_UNREAD(strm) ((strm)->sm.sm_int) /* file fd for socket */ #define SOCKET_STREAM_FD(strm) ((strm)->sm.sm_fd) #define SOCKET_STREAM_BUFFER(strm) ((strm)->sm.sm_object1) /* for smm_string_input */ #define STRING_INPUT_STREAM_NEXT(strm) ((strm)->sm.sm_object0->st.st_fillp) #define STRING_INPUT_STREAM_END(strm) ((strm)->sm.sm_object0->st.st_dim) /* for smm_two_way and smm_echo */ #define STREAM_OUTPUT_STREAM(strm) ((strm)->sm.sm_object1) #define STREAM_INPUT_STREAM(strm) ((strm)->sm.sm_object0) /* for smm_string_{input,output} */ #define STRING_STREAM_STRING(strm) ((strm)->sm.sm_object0) /* flags */ #define GET_STREAM_FLAG(strm,name) ((strm)->sm.sm_flags & (1<<(name))) #define SET_STREAM_FLAG(strm,name,val) {if (val) (strm)->sm.sm_flags |= (1<<(name)); else (strm)->sm.sm_flags &= ~(1<<(name));} #define GCL_MODE_BLOCKING 1 #define GCL_MODE_NON_BLOCKING 0 #define GCL_TCP_ASYNC 1 enum gcl_sm_flags { gcl_sm_blocking=1, gcl_sm_tcp_async, gcl_sm_input, gcl_sm_output, gcl_sm_closed, gcl_sm_had_error }; enum chattrib { /* character attribute */ cat_whitespace, /* whitespace */ cat_terminating, /* terminating macro */ cat_non_terminating, /* non-terminating macro */ cat_single_escape, /* single-escape */ cat_multiple_escape, /* multiple-escape */ cat_constituent /* constituent */ }; struct rtent { /* read table entry */ enum chattrib rte_chattrib; /* character attribute */ object rte_macro; /* macro function */ object *rte_dtab; /* pointer to the */ /* dispatch table */ /* NULL for */ /* non-dispatching */ /* macro character, or */ /* non-macro character */ }; /* struct character character_table1[256+128]; */ #define character_table (character_table1+128) #define code_char(c) (object)(character_table+((unsigned char)(c))) #define char_code(obje) ((object)obje)->ch.ch_code #define char_font(obje) ((object)obje)->ch.ch_font #define char_bits(obje) ((object)obje)->ch.ch_bits #define address_int unsigned long /* The struct of free lists. */ struct freelist { FIRSTWORD; address_int f_link; }; #ifndef INT_TO_ADDRESS #define INT_TO_ADDRESS(x) ((object )(long )x) #endif #define F_LINK(x) ((struct freelist *)(long) x)->f_link #define FL_LINK F_LINK #define SET_LINK(x,val) F_LINK(x) = (address_int) (val) #define OBJ_LINK(x) ((object) INT_TO_ADDRESS(F_LINK(x))) #define PHANTOM_FREELIST(x) ({struct freelist f;(object)((void *)&x+((void *)&f-(void *)&f.f_link));}) #define FREELIST_TAIL(tm_) ({struct typemanager *_tm=tm_;\ _tm->tm_free==OBJNULL ? PHANTOM_FREELIST(_tm->tm_free) : _tm->tm_tail;}) #define FREE (-1) /* free object */ struct fasd { object stream; /* lisp object of type stream */ object table; /* hash table used in dumping or vector on input*/ object eof; /* lisp object to be returned on coming to eof mark */ object direction; /* holds Cnil or sKinput or sKoutput */ object package; /* the package symbols are in by default */ object index; /* integer. The current_dump index on write */ object filepos; /* nil or the position of the start */ object table_length; /* On read it is set to the size dump array needed or 0 */ object evald_items; /* a list of items which have been eval'd and must not be walked by fasd_patch_sharp */ }; /* Storage manager for each type. */ struct typemanager { enum type tm_type; /* type */ long tm_size; /* element size in bytes */ long tm_nppage; /* number per page */ object tm_free; /* free list */ /* Note that it is of type object. */ object tm_tail; /* free list tail */ /* Note that it is of type object. */ long tm_nfree; /* number of free elements */ long tm_npage; /* number of pages */ long tm_maxpage; /* maximum number of pages */ char *tm_name; /* type name */ long tm_gbccount; /* GBC count */ object tm_alt_free; /* Alternate free list (swap with tm_free) */ long tm_alt_nfree; /* Alternate nfree (length of nfree) */ long tm_alt_npage; /* number of pages */ long tm_sgc; /* this type has at least this many sgc pages */ long tm_sgc_minfree; /* number free on a page to qualify for being an sgc page */ long tm_sgc_max; /* max on sgc pages */ long tm_min_grow; /* min amount to grow when growing */ long tm_max_grow; /* max amount to grow when growing */ long tm_growth_percent; /* percent to increase maxpages */ long tm_percent_free; /* percent which must be free after a gc for this type */ long tm_distinct; /* pages of this type are distinct */ float tm_adjgbccnt; long tm_opt_maxpage; }; /* The table of type managers. */ EXTER struct typemanager tm_table[ 32 /* (int) t_relocatable */]; #define tm_of(t) (&(tm_table[(int)tm_table[(int)(t)].tm_type])) /* Contiguous block header. */ EXTER ufixnum contblock_lim; struct contblock { /* contiguous block header */ ufixnum cb_size; /* size in bytes */ struct contblock *cb_link; /* contiguous block link */ }; /* The pointer to the contiguous blocks. */ EXTER struct contblock *cb_pointer; /* contblock pointer */ /* SGC cont pages: After SGC_start, old_cb_pointer will be a linked list of free blocks on non-SGC pages, and cb_pointer will be likewise for SGC pages. CM 20030827*/ EXTER struct contblock *old_cb_pointer; /* old contblock pointer when in SGC */ /* Variables for memory management. */ #define ncbpage tm_table[t_contiguous].tm_npage #define maxcbpage tm_table[t_contiguous].tm_maxpage #define cbgbccount tm_table[t_contiguous].tm_gbccount EXTER long holepage; /* hole pages */ #define nrbpage tm_table[t_relocatable].tm_npage #define maxrbpage tm_table[t_relocatable].tm_maxpage #define rbgbccount tm_table[t_relocatable].tm_gbccount EXTER long new_holepage,starting_hole_div,starting_relb_heap_mult; EXTER ufixnum recent_allocation,wait_on_abort; EXTER double gc_alloc_min,mem_multiple,gc_page_min,gc_page_max; EXTER bool multiprocess_memory_pool; EXTER char *new_rb_start; /* desired relblock start after next gc */ EXTER char *rb_start; /* relblock start */ EXTER char *rb_end; /* relblock end */ EXTER char *rb_limit; /* relblock limit */ EXTER char *rb_pointer; /* relblock pointer */ INLINE ufixnum rb_size(void) { return rb_end-rb_start; } INLINE bool rb_high(void) { return rb_pointer>=rb_end&&rb_size(); } INLINE char * rb_begin(void) { return rb_high() ? rb_end : rb_start; } INLINE bool rb_emptyp(void) { return rb_pointer == rb_begin(); } INLINE ufixnum ufmin(ufixnum a,ufixnum b) { return a<=b ? a : b; } INLINE ufixnum ufmax(ufixnum a,ufixnum b) { return a>=b ? a : b; } #include #include #include INLINE int emsg(const char *s,...) { va_list args; ufixnum n=0; void *v=NULL; va_start(args,s); n=vsnprintf(v,n,s,args)+1; va_end(args); v=alloca(n); va_start(args,s); vsnprintf(v,n,s,args); va_end(args); return write(2,v,n-1) ? n : -1; } EXTER char *heap_end; /* heap end */ EXTER char *core_end; /* core end */ EXTER char *tmp_alloc; /* make f allocate enough extra, so that we can round up, the address given to an even multiple. Special case of size == 0 , in which case we just want an aligned number in the address range */ #define ALLOC_ALIGNED(f, size,align) \ ({ufixnum _size=size,_align=align;_align <= sizeof(plong) ? (char *)((f)(_size)) : \ (tmp_alloc = (char *)((f)(_size+(_size ?(_align)-1 : 0)))+(_align)-1 , \ (char *)(_align * (((unsigned long)tmp_alloc)/_align)));}) #define AR_ALLOC(f,n,type) (type *) \ (ALLOC_ALIGNED(f,(n)*sizeof(type),sizeof(type))) #define RB_GETA PAGESIZE #ifdef AV #define STATIC register #endif #define TIME_ZONE (-9) /* For IEEEFLOAT, the double may have exponent in the second word (little endian) or first word.*/ #if !defined(DOUBLE_BIGENDIAN) #define HIND 1 /* (int) of double where the exponent and most signif is */ #define LIND 0 /* low part of a double */ #else /* big endian */ #define HIND 0 #define LIND 1 #endif #ifndef VOL #define VOL volatile #endif #define isUpper(xxx) (((xxx)&0200) == 0 && isupper((int)xxx)) #define isLower(xxx) (((xxx)&0200) == 0 && islower((int)xxx)) #define isDigit(xxx) (((xxx)&0200) == 0 && isdigit((int)xxx)) enum ftype {f_object,f_fixnum}; object make_si_sfun(); /* Set new to be an (object *) whose [i]'th elmt is the ith elmnt in a va_list if ((vl[0] == va_arg(ap,object)) || (vl[1] == va_arg(ap,object)) || .. vl[n-1] == va_arg(ap,object)) you may set #define DONT_COPY_VA_LIST In recent versions of gcc, i think the builtin_alist stuff does not allow setting this. */ #ifdef DONT_COPY_VA_LIST #define COERCE_VA_LIST(new,vl,n) new = (object *) (vl) #else #define COERCE_VA_LIST(new,vl,n) \ object Xxvl[65]; \ {int i; \ new=Xxvl; \ if (n >= 65) FEerror("Too plong vl",0); \ for (i=0 ; i < (n); i++) new[i]=va_arg(vl,object);} #endif #ifdef DONT_COPY_VA_LIST #error Cannot set DONT_COPY_VA_LIST in ANSI C #else #define COERCE_VA_LIST_NEW(new,fst,vl,n) \ object Xxvl[65]; \ {int i; \ new=Xxvl; \ if (n >= 65) FEerror("va_list too long",0); \ for (i=0 ; i < (n); i++) new[i]=i ? va_arg(vl,object) : fst;} #define COERCE_VA_LIST_KR_NEW(new,fst,vl,n) \ object Xxvl[65]; \ {int i; \ new=Xxvl; \ if (n >= 65) FEerror("va_list too long",0); \ for (i=0 ; i < (n); i++) new[i]=i||fst==OBJNULL ? va_arg(vl,object) : fst;} #endif #define make_si_vfun(s,f,min,max) \ make_si_vfun1(s,f,min | (max << 8)) /* Number of args supplied to a variable arg t_vfun Used by the C function to set optionals */ #define VFUN_NARGS fcall.argd #define RETURN4(x,y,z,w) do{/* object _x = (void *) x; */ \ fcall.values[1]=y;fcall.values[2]=z;fcall.values[3]=w;fcall.nvalues=4; \ return (x) ;} while(0) #define RETURN2(x,y) do{/* object _x = (void *) x; */\ fcall.values[1]=y;fcall.nvalues=2; \ return (x) ;} while(0) #define RETURN1(x) do{fcall.nvalues=1; return (x) ;} while(0) #define RETURN0 do{fcall.nvalues=0; return Cnil ;} while(0) #define RV(x) (*_p++ = x) #define RETURNI(n,val1,listvals) RETURN(n,int,val1,listvals) #define RETURNO(n,val1,listvals) RETURN(n,object,val1,listvals) /* eg: RETURN(3,object,val1,(RV(val2),RV(val3))) */ #undef RETURN #define RETURN(n,typ,val1,listvals) \ do{typ _val1 = val1; object *_p=&fcall.values[1]; listvals; fcall.nvalues= n; return _val1;}while(0) /* we sometimes have to touch the header of arrays or structures to make sure the page is writable */ #ifdef SGC #define SGC_TOUCH(x) (x)->d.e=1 /*if (is_marked(x)) system_error(); unmark(x)*/ #else #define SGC_TOUCH(x) #endif object funcall_cfun(void(*)(),int,...); object clear_compiler_properties(); EXTER object sSlambda_block_expanded; # ifdef __GNUC__ # define assert(ex)\ {if (!(ex)){(void)fprintf(stderr, \ "Assertion failed: file \"%s\", line %d\n", __FILE__, __LINE__);exit(1);}} # else # define assert(ex) # endif #ifndef FIX_PATH_STRING #define FIX_PATH_STRING(file) file #endif #define CHECK_INTERRUPT /* if (signals_pending) raise_pending_signals(sig_safe) */ #define BEGIN_NO_INTERRUPT \ plong old_signals_allowed = signals_allowed; \ signals_allowed = 0 #define END_NO_INTERRUPT \ ({signals_allowed = old_signals_allowed; if (signals_pending) raise_pending_signals(sig_use_signals_allowed_value);}) /* could add: if (signals_pending) raise_pending_signals(sig_use_signals_allowed_value) */ #define END_NO_INTERRUPT_SAFE \ signals_allowed = old_signals_allowed; \ if (signals_pending) \ do{ if(signals_allowed ==0) /* should not get here*/abort(); \ raise_pending_signals(sig_safe)}while(0) void raise_pending_signals(); EXTER unsigned plong signals_allowed, signals_pending; #define endp_prop(a) (consp(a) ? FALSE : ((a)==Cnil ? TRUE : endp_error(a))) #define endp(a) endp_prop(a) #define proper_list(a) (type_of(a)==t_cons || (a)==Cnil) #define IMMNIL(x) (is_imm_fixnum(x)||x==Cnil) /*gcc boolean expression tail position bug*/ /* #define eql(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b || (!IMMNIL(_a)&&!IMMNIL(_b)&&eql1(_a,_b));}) */ /* #define equal(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b || (!IMMNIL(_a)&&!IMMNIL(_b)&&equal1(_a,_b));}) */ /* #define equalp(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b || (_a!=Cnil&&_b!=Cnil&&equalp1(_a,_b));}) */ #define eql_is_eq(a_) (is_imm_fixnum(a_)||valid_cdr(a_)||(a_->d.t>t_complex)) #define eql(a_,b_) ({register object _a=(a_);register object _b=(b_);\ _a==_b ? TRUE : (eql_is_eq(_a)||eql_is_eq(_b)||_a->d.t!=_b->d.t ? FALSE : eql1(_a,_b));}) #define equal(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b ? TRUE : (IMMNIL(_a)||IMMNIL(_b) ? FALSE : equal1(_a,_b));}) #define equalp(a_,b_) ({register object _a=(a_);register object _b=(b_);_a==_b ? TRUE : (_a==Cnil||_b==Cnil ? FALSE : equalp1(_a,_b));}) gcl-2.6.14/h/u370_aix.defs0000755000175000017500000000225414360276512013432 0ustar cammcamm# /* Copyright William Schelter. All rights reserved. (1990) */ LBINDIR=/usr/local/bin RANLIB=true #defs for the makefiles # see notes at beginning of u370_aix.h # OFLAG = # for plc88 can't have this LIBS = -lm ODIR_DEBUG= SHELL=/bin/sh .IGNORE: # CC = cc -DVOL= -I$(GCLDIR)/o -Wl,-S0xa000000 # Note pl8cc cannot compile c/fat_string.c. # When this fails just repeat the same command manually # using cc. CC = cc -DVOL=volatile -DCOM_LENG= -I$(GCLDIR)/o LDCC = ${CC} -Hxa CFLAGS = -c $(DEFS) -I../h EXTRAS = /usr/local/scratchpad/cur/lib/foreign/cfuns-c.o \ /usr/local/scratchpad/cur/lib/foreign/sockio-c.o EXTRAS = # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. RSYM = rsym SFASL = $(ODIR)/sfasl.o # EMUL= $(ODIR)/sysv_386emul.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-u370_aix.o ${MPDIR}/mp_sl3todivul3.o ${MPDIR}/libmport.a # MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a # Use symbolic links SYMB = -s EXTRAS = /spad/obj/370/lib/sockio-c.o /spad/obj/370/lib/cfuns-c.o gcl-2.6.14/h/vax.h0000755000175000017500000000076414360276512012203 0ustar cammcammextern char etext; #define VAX #include "bsd.h" #undef SFASL #define ADDITIONAL_FEATURES \ ADD_FEATURE("VAX"); #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); #undef FILECPY_HEADER #define FILECPY_HEADER \ if (header.a_magic == ZMAGIC) \ filecpy(save, original, PAGSIZ - sizeof(header)); \ filecpy(save, original, header.a_text); #define PAGSIZ 1024 #define SEGSIZ 1024 #define TXTRELOC 0 /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/wincoff.h0000755000175000017500000000060314360276512013030 0ustar cammcamm#include "coff/i386.h" #undef BSD #define HAVE_FILEHDR #define COFF #define NSYMS(x) (x).f_nsyms #define N_SYMOFF(x) (x).f_symptr #define N_BADMAG(x) ((x).f_magic != 0x5A4D) /* prevent duplicate definition... we wont be using varargs in this */ #include "windows.h" #ifdef __MINGW32__ #include "minglacks.h" #else #include "cyglacks.h" #endif struct aouthdr {AOUTHDR x;}; gcl-2.6.14/h/elf64_riscv64_reloc.h0000644000175000017500000000160114360276512015055 0ustar cammcamm#define riscv_high(a_) ((a_)+(((a_)&0x800) ? (1<<12) : 0)) case R_RISCV_HI20: store_val(where,MASK(20)<<12,riscv_high(s+a)); break; case R_RISCV_RELAX:/*FIXME figure out how to delete instructions efficiently*/ break; case R_RISCV_LO12_I: store_val(where,MASK(12)<<20,(s+a)<<20); break; case R_RISCV_LO12_S: store_val(where,MASK(5)<<7,(s+a)<<7); store_val(where,MASK(7)<<25,(s+a)<<20); break; case R_RISCV_CALL: case R_RISCV_CALL_PLT: store_val(where,MASK(20)<<12,riscv_high(s+a-p)); store_val((void *)where+4,MASK(12)<<20,(s+a-p)<<20); break; case R_RISCV_BRANCH: case R_RISCV_RVC_BRANCH: case R_RISCV_RVC_JUMP: case R_RISCV_JAL: break; case R_RISCV_64: store_val(where,MASK(64),(s+a)); break; case R_RISCV_32: store_val(where,MASK(32),(s+a)); break; gcl-2.6.14/h/386-linux.h0000755000175000017500000000246214360276512013057 0ustar cammcamm#include "linux.h" #ifdef IN_GBC /* #undef MPROTECT_ACTION_FLAGS */ /* #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO */ /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((siginfo_t *)code)->si_addr */ /* the following two files have changed back and forth in recent versions of linux... Include both if they both exist, otherwise include whatever one exists... basically one wants the struct sigcontext_struct { ... } ; so as to get the fault address. */ #if !defined(SIGNAL_H_HAS_SIGCONTEXT) && !defined(HAVE_SIGCONTEXT) #error Need sigcontext on 386 linux #else #include #ifndef SIGNAL_H_HAS_SIGCONTEXT #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif #endif #endif #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) ((void *)(((struct sigcontext *)(&code))->cr2)) */ #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC #define RELOC_H "elf32_i386_reloc.h" gcl-2.6.14/h/sh4-linux.h0000755000175000017500000000323514360276512013234 0ustar cammcamm#include "linux.h" #ifdef IN_GBC /* #undef MPROTECT_ACTION_FLAGS */ /* #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO */ /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((siginfo_t *)code)->si_addr */ /* the following two files have changed back and forth in recent versions of linux... Include both if they both exist, otherwise include whatever one exists... basically one wants the struct sigcontext_struct { ... } ; so as to get the fault address. */ #if !defined(SIGNAL_H_HAS_SIGCONTEXT) && !defined(HAVE_SIGCONTEXT) #error Need sigcontext on 386 linux #else #include #ifndef SIGNAL_H_HAS_SIGCONTEXT #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif #endif #endif #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) ((void *)(((struct sigcontext *)(&code))->cr2)) */ #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("SH4"); \ ADD_FEATURE("") #define SH4 #define SGC #ifdef IN_SFASL #include #define CLEAR_CACHE {\ void *p=memory->cfd.cfd_start,*pe=p+memory->cfd.cfd_size; \ p=(void *)((unsigned long)p & ~(PAGESIZE-1)); \ for (;p>1); break; gcl-2.6.14/h/enum.h0000755000175000017500000000031214360276512012336 0ustar cammcamm#ifndef NEW_LISP #define t_doublefloat t_longfloat #endif enum signals_allowed_values { sig_none, sig_normal, sig_try_to_delay, sig_safe, sig_at_read, sig_use_signals_allowed_value }; gcl-2.6.14/h/stacks.h0000755000175000017500000000134414360276512012670 0ustar cammcamm#ifndef VSSIZE #define VSSIZE 128*1024 #endif #define VSGETA 128 object value_stack[VSSIZE + (STACK_OVER +1) *VSGETA],*vs_org=value_stack,*vs_limit=value_stack+VSSIZE; #ifndef BDSSIZE #define BDSSIZE 2*1024 #endif #define BDSGETA 64 struct bds_bd bind_stack[BDSSIZE + (STACK_OVER +1)* BDSGETA],*bds_org=bind_stack,*bds_limit=bind_stack+BDSSIZE; #ifndef IHSSIZE #define IHSSIZE 4*1024 #endif #define IHSGETA 96 struct invocation_history ihs_stack[IHSSIZE + (STACK_OVER +1) * IHSGETA],*ihs_org=ihs_stack,*ihs_limit=ihs_stack+IHSSIZE; #ifndef FRSSIZE #define FRSSIZE 4*1024 #endif #define FRSGETA 96 struct frame frame_stack[FRSSIZE + (STACK_OVER +1) * FRSGETA],*frs_org=frame_stack,*frs_limit=frame_stack+FRSSIZE; gcl-2.6.14/h/make-decl.h0000755000175000017500000000002514360276512013215 0ustar cammcamm #include "defun.h" gcl-2.6.14/h/options.h0000755000175000017500000000070614360276512013074 0ustar cammcamm/* define the following if you want a type of stream which the user can define */ #define USER_DEFINED_STREAMS /* define to enable multiprocessing: Currently requires mat'l not yet in the distribution */ /* #define KCLOVM */ /* include a couple of constant manipulation routines for maxima */ #define CMAC /* When a stack overflow occurs (STACK_OVER)*..GETA will be added to the stack to handle debugging */ #define STACK_OVER 3 gcl-2.6.14/h/e15.h0000755000175000017500000000313514360276512011772 0ustar cammcamm#define E15 #define AV #define MC68K #define IEEEFLOAT #define UNIX #define VSSIZE 8152 #define ADDITIONAL_FEATURES \ ADD_FEATURE("E15") ;\ ADD_FEATURE("MC68K"); \ ADD_FEATURE("UNIPLUS-SYSTEM-V") #define MEM_SAVE_LOCALS struct exec header #define COPY_TO_SAVE filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); #define READ_HEADER fread(&header, sizeof(header), 1, original); \ if (header.fmagic != NMAGIC) \ data_begin \ = (char *)(TXTRELOC+header.a_text); \ else \ data_begin \ = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ header.a_bss = sbrk(0) - core_end; \ fwrite(&header, sizeof(header), 1, save); #define FILECPY_HEADER filecpy(save, original, header.a_text); #define COPY_TO_SAVE filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize) #define exec bhdr #define a_text tsize #define a_data dsize #define a_bss bsize #define a_syms ssize #define a_trsize rtsize #define a_drsize rdsize #define SEGSIZ (128*1024) #define TXTRELOC (1024*1024) #define NUMBER_OPEN_FILES _NFILE #define ADDITIONAL_FEATURES \ ADD_FEATURE("E15");\ ADD_FEATURE("MC68K"); \ ADD_FEATURE("UNIPLUS-SYSTEM-V") #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define HOLEPAGE 32 #define INIT_ALLOC \ if (brk(pagetochar(MAXPAGE)) < 0) \ error("Can't allocate. Good-bye!."); #define IF_ALLOCATE_ERR \ if (PAGESIZE*(n - m) > pagetochar(MAXPAGE) - core_end) /* have the getcwd command */ #define GETCWD gcl-2.6.14/h/solaris.defs0000755000175000017500000000340114360276512013542 0ustar cammcamm # notes for redhat 6.0 # the configure should select the compiler GCC=/usr/bin/i386-glibc20-linux-gcc # However for the gcl-tk directory, you must use plain 'gcc' since # that must link with the tcl tk libs which have been compiled with it. # so after configure change to GCC=gcc in the gcl-tk/makefile # Machine dependent makefile definitions for intel 386,486 running linux LBINDIR=/usr/local/bin #OFLAG = -g -Wall #OFLAG = -g -Wall -fomit-frame-pointer -Werror #LIBS = -lm #ODIR_DEBUG= -g -Wall -fomit-frame-pointer -Werror #ODIR_DEBUG= -g -Wall # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # (the -pipe is just since our file system is slow..) #CC = ${GCC} -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -Wall $(EXTRA_CFLAGS) -fomit-frame-pointer -Werror -g # under redhat 6.1 and slackware 7.0 we needed to have this # link be static, but should be ok with the fix to unixport/rsym_elf.c LDCC=${CC} -static LDCC=${CC} # note for linuxaout on an elf machine add -b i486-linuxaout # CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif #ifneq ($(findstring -ldl,$(LIBS)),) #RSYM = #endif SFASL = $(ODIR)/sfasl.o #MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd SHELL=/bin/bash gcl-2.6.14/h/dec3100.h0000755000175000017500000000276414360276512012446 0ustar cammcamm#define SGI #include "att.h" #undef NUMBER_OPEN_FILES #define NUMBER_OPEN_FILES getdtablesize() #define ADDITIONAL_FEATURES \ ADD_FEATURE("MIPS") /* #define mips 1 The system defines this */ #define IEEEFLOAT /* The exponent and most signif are in the second word for doubles */ #define LITTLE_END #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text); /* text relocated; data is page-aligned after the text */ #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(PAGSIZ-1)) & ~(PAGSIZ-1)) #define PAGSIZ 4096 #define TXTRELOC 4096 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define RELOC_FILE "rel_mips.c" #undef SFASL #undef NEED_GETWD #define SEEK_TO_END_OFILE \ do{HDRR symhdr; \ fp = faslfile->sm.sm_fp;\ fread(&fileheader, sizeof(fileheader), 1, fp); \ fseek(fp, fileheader.f_symptr, 0); \ fread(&symhdr, cbHDRR, 1, fp); \ fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, 0);} \ while(0); #ifdef IN_UNIXFSYS #undef ATT #define BSD #endif #define NOFREE_ERR #define UNIXSAVE "savedec31.c" #define UNIXFASL "faslsgi4.c" #define HAVE_GETDTABLESIZE #define SIGPROTV SIGBUS #define GET_FAULT_ADDR(sig,code,sv,a) ((char *) code) #define MPROTECT_FAIL_VALUE -1 /* void * is not accepted by compiler */ #define NO_VOID_STAR /* Begin for cmpinclude */ /* #define SGC */ /* End for cmpinclude */ gcl-2.6.14/h/hppa-linux.h0000755000175000017500000000160314360276512013463 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr #endif #define SGC #define STATIC_FUNCTION_POINTERS #ifdef IN_SFASL #include #define CLEAR_CACHE_LINE_SIZE 32 #define CLEAR_CACHE {\ void *v1=memory->cfd.cfd_start,*v,*ve=v1+memory->cfd.cfd_size; \ v1=(void *)((unsigned long)v1 & ~(CLEAR_CACHE_LINE_SIZE - 1));\ for (v=v1;v #include #include #include #include #include #include { errno=0; { /*READ_IMPLIES_EXEC is for selinux, but selinux will reset it in the child*/ long pers = personality(READ_IMPLIES_EXEC|personality(0xffffffffUL)); long flag = ADDR_NO_RANDOMIZE; if (sizeof(long)==4) flag|=ADDR_LIMIT_3GB/* |ADDR_COMPAT_LAYOUT */; if (pers==-1) {printf("personality failure %d\n",errno);exit(-1);} if ((pers & flag)!=flag && !getenv("GCL_UNRANDOMIZE")) { errno=0; if (personality(pers | flag) != -1 && (personality(0xffffffffUL) & flag)==flag) { int i,j,k; char **n,**a; void *v; for (i=j=0;argv[i];i++) j+=strlen(argv[i])+1; for (k=0;envp[k];k++) j+=strlen(envp[k])+1; j+=(i+k+3)*sizeof(char *); if ((v=sbrk(j))==(void *)-1) { printf("Cannot brk environment space\n"); exit(-1); } a=v; v=a+i+1; n=v; v=n+k+2; for (i=0;argv[i];i++) { a[i]=v; strcpy(v,argv[i]); v+=strlen(v)+1; } a[i]=0; for (k=0;envp[k];k++) { n[k]=v; strcpy(v,envp[k]); v+=strlen(v)+1; } n[k]="GCL_UNRANDOMIZE=t"; n[k+1]=0; errno=0; #ifdef HAVE_GCL_CLEANUP gcl_cleanup(0); #endif execve(*a,a,n); printf("execve failure %d\n",errno); exit(-1); } else { printf("personality change failure %d\n",errno); exit(-1); } } #if defined(CSTACKMAX) && CSTACK_DIRECTION < 0 if ((void *)&argc > (void *)CSTACKMAX) { if (mmap((void *)CSTACKMAX-(1L << PAGEWIDTH),(1L << PAGEWIDTH), PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_PRIVATE|MAP_ANON|MAP_STACK|MAP_GROWSDOWN,-1,0)==(void *)-1) { printf("cannot mmap new stack %d\n",errno); exit(-1); } #ifdef SET_STACK_POINTER {void *p=(void *)CSTACKMAX-4*CSTACK_ALIGNMENT;asm volatile (SET_STACK_POINTER::"r" (p):"memory");} #else #error Cannot set stack pointer #endif } #endif } } gcl-2.6.14/h/powerpc-macosx.defs0000644000175000017500000000203514360276512015034 0ustar cammcamm# powerpc-macosx.defs # Disable Apple's custom C preprocessor which gets confused when # preprocessing some of the *.d files in the o/ subdirectory. CC = gcc $(CPPFLAGS) # Set this to avoid warnings when linking against libncurses. # This is due to the requirements of the two level namespace. LIBS := `echo $(LIBS) | sed -e 's/-lncurses/ /'` # Set this for the linker to operate correctly. MACOSX_DEPLOYMENT_TARGET = 10.2 # Define this to build an executable rsym. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif # Define this in order to compile sfasl.c. SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table). # (However, I'm not sure this init form will ever get called.) INITFORM = (si::build-symbol-table) # This is Apple's libtool, completely unrelated to GNU libtool. # Other plateforms define this to be `ar rs`. # This appears to be no longer necessary on Panther. ARRS = libtool -static -o FINAL_CFLAGS := `echo $(FINAL_CFLAGS) | sed -e 's:-g::g'` gcl-2.6.14/h/FreeBSD.defs0000755000175000017500000000224714360276512013307 0ustar cammcamm# Machine dependent makefile definitions for intel 386,486 running 386bsd # Ported to FreeBSD 2.0 by Jeffrey Hsu (hsu@freebsd.org). # Hacked September-93 by Paul F. Werkowski for 386BSD 0.1 + Patchkit 0.2.4 LBINDIR=/usr/local/bin #OFLAG = -pipe -O2 #CFLAGS = -fwritable-strings -fomit-frame-pointer -DVOL=volatile -I$(GCLDIR)/o -I/usr/local/lib/gcl-2.0/h -fsigned-char -I/usr/local/lib #LIBS = -lm -L/usr/local/lib #ODIR_DEBUG= NULLFILE=../h/twelve_null # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. #CC = gcc #LDCC = $(CC) -static # Use the mp.s file on 68k machine MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a GNULIB1=/usr/lib/libgcc.a # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/OpenBSD.h0000755000175000017500000000272614360276512012637 0ustar cammcamm/* * OpenBSD.h for gcl 1.1 * * */ #include "bsd.h" #undef LD_COMMAND #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -dc -N -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) #define ADDITIONAL_FEATURES \ ADD_FEATURE("386BSD");\ ADD_FEATURE("OpenBSD"); #define I386 #define IEEEFLOAT /* #undef HAVE_XDR */ #define USE_ATT_TIME #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) \ if (((FILE *)fp)->_r <=0 && (c=0, ioctl(((FILE *)fp)->_file, FIONREAD, &c), c<=0)) \ return(FALSE) #ifdef IN_GBC #include #endif #define DATA_BEGIN (char *) N_DATADDR(header); #define A_TEXT_OFFSET(x) (sizeof (struct exec)) #define A_TEXT_SEEK(hdr) (N_TXTOFF(hdr) + A_TEXT_OFFSET(hdr)) #define start_of_data() &etext #define start_of_text() ((char *)(sizeof(struct exec) + getpagesize())) #undef UNIXSAVE #ifdef UNIXSAVE extern char etext; #endif #define RELOC_FILE "rel_sun3.c" /* for SFASL - enabled in bsd.h */ #ifdef CLOCKS_PER_SEC #define HZ CLOCKS_PER_SEC #else #define HZ 128 #endif #define ss_base ss_sp /* begin for GC */ #define PAGEWIDTH 12 /* i386 sees 4096 byte pages */ /* end for GC */ /* * The next two defines are for SGC, * one of which needs to go in cmpinclude.h. */ #define SIGPROTV SIGBUS /* Begin for cmpinclude */ #define SGC /* can mprotect pages and so selective gc will work */ /* End for cmpinclude */ #if defined(IN_UNIXTIME) # include #endif gcl-2.6.14/h/arm-linux.h0000755000175000017500000000064314360276512013315 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define SGC #define RELOC_H "elf32_arm_reloc.h" #define SPECIAL_RELOC_H "elf32_arm_reloc_special.h" #define NEED_STACK_CHK_GUARD gcl-2.6.14/h/elf32_armhf_reloc_special.h0000644000175000017500000000366214360276512016356 0ustar cammcammstatic int tramp[]={0x0c00f240, /*movw r12, #0*/ 0x0c00f2c0, /*movt r12, #0*/ 0xbf004760}; /*bx r12 nop*/ static ul tz=sizeof(tramp)/sizeof(ul); static ul * next_plt_entry(ul *p,ul *pe) { /* 4778 bx pc */ /*optional*/ /* e7fd b.n 20dd0 <__fprintf_chk@plt> */ /*optional*/ /* above when stripped becomes undefined instruction*/ /* e28fc601 add ip, pc, #1048576 ; 0x100000 */ /* e28ccab0 add ip, ip, #176, 20 ; 0xb0000 */ /* e5bcf914 ldr pc, [ip, #2324]! ; 0x914 */ for (p=p+2;p>20)!=0xe28;p++); return p; } static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { Shdr *sec,*psec; Rel *r; ul *p,*pe; void *ve; /*plt entries are not of uniform size*/ massert(psec=get_section(".plt",sec1,sece,sn)); p=(void *)psec->sh_addr; pe=(void *)p+psec->sh_size; massert((sec=get_section( ".rel.plt",sec1,sece,sn)) || (sec=get_section(".rela.plt",sec1,sece,sn))); v+=sec->sh_offset; ve=v+sec->sh_size; p=next_plt_entry(p,pe);/*plt0*/ for (r=v;vsh_entsize,r=v,p=next_plt_entry(p,pe)) { if (!ds1[ELF_R_SYM(r->r_info)].st_value) ds1[ELF_R_SYM(r->r_info)].st_value=(ul)p; } massert(p==pe); massert(v==ve); return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rel *r; Sym *sym; Shdr *sec; void *v,*ve; for (sym=sym1;symst_size=0; for (*gs=0,sec=sec1;secsh_type==SHT_REL) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if ( #define R_ARM_THM_CALL 10 ELF_R_TYPE(r->r_info)==R_ARM_THM_CALL || ELF_R_TYPE(r->r_info)==R_ARM_THM_JUMP24 ) { sym=sym1+ELF_R_SYM(r->r_info); if (!sym->st_size) sym->st_size=++*gs; } (*gs)*=tz; return 0; } gcl-2.6.14/h/elf64_ppc_reloc.h0000644000175000017500000000117714360276512014347 0ustar cammcamm#define ha(x_) ((((x_) >> 16) + (((x_) & 0x8000) ? 1 : 0)) & 0xffff) #define lo(x_) ((x_) & 0xffff) #define m(x_) ((void *)((ul)(x_)-6)) case R_PPC64_TOC16_HA: store_val(m(where),MASK(16),ha(s+a-toc)); break; case R_PPC64_TOC16_LO_DS: store_val(m(where),MASK(16),lo(s+a-toc));/*>>2*/ break; case R_PPC64_TOC16_LO: store_val(m(where),MASK(16),lo(s+a-toc)); break; case R_PPC64_ADDR64: store_val(where,~0L,(s+a)); break; case R_PPC64_TOC: store_val(where,~0L,toc); break; case R_PPC64_REL32: store_val(where,MASK(32)<<32,(s+a-p)<<32); break; gcl-2.6.14/h/elf64_sparc_reloc.h0000644000175000017500000000122414360276512014666 0ustar cammcamm case R_SPARC_WDISP30: store_ivals((int *)where,MASK(30),((long)(s+a-p))>>2); break; case R_SPARC_HI22: store_ival((int *)where,MASK(22),(s+a)>>10); break; case R_SPARC_LO10: store_ival((int *)where,MASK(10),s+a); break; case R_SPARC_OLO10: store_ival((int *)where,MASK(10),s+a); add_ival((int *)where,MASK(13),ELF_R_ADDEND(r->r_info)); break; case R_SPARC_13: store_ivalu((int *)where,MASK(13),s+a); break; case R_SPARC_32: case R_SPARC_UA32: store_ivalu((int *)where,MASK(32),s+a); break; case R_SPARC_64: case R_SPARC_UA64: store_valu(where,~0L,s+a); break; gcl-2.6.14/h/news.h0000755000175000017500000000060114360276512012347 0ustar cammcamm#define NEWS #define MC68020 #define IEEEFLOAT #undef FILECPY_HEADER #define FILECPY_HEADER \ if (header.a_magic == ZMAGIC) \ filecpy(save, original, PAGSIZ - sizeof(header)); \ filecpy(save, original, header.a_text); #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)) #define TXTRELOC 0 /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/cmpincl1.h0000755000175000017500000000002314360276512013077 0ustar cammcamm#define CMPINCLUDE gcl-2.6.14/h/u370_aix.h0000755000175000017500000001145114360276512012737 0ustar cammcamm/* Copyright William Schelter. All rights reserved. (1990) */ #define ATT #define U370_AIX /* .. additional piece, which probably belongs in a "README" somewhere, is that AIX/370 installers should use the latest (update U401215) C compiler, which for some inscrutable reason was hidden when installed ("ls /lib/hc*@" is the key to finding it). The symptom for not doing this is that compiling some of the generated .c files may take hours rather than seconds (!). */ /* Possible change necessary to c/sfasl.c mckenney@rpi.edu reports the following change necessary for c/sfasl.c. I (wfs) compiled all of scratchpad (800 files) and ran many tests without it. I don't have a machine here to test on, so I am leaving it out till I get confirmation that it is necessary (I hate to mung up c/sfasl.c any more than it is) *** c/sfasl.c~ Mon Aug 13 21:36:52 1990 --- c/sfasl.c Fri Dec 14 16:25:57 1990 *************** *** 589,594 **** --- 589,599 ---- if(answ) { #ifdef COFF + #ifdef _AIX370 + if (NTYPE(sym) == N_UNDEF) + sym->n_value = answ->address; + else + #endif */ #include "att.h" /* #define HAVE_AOUT */ #define EXTERN_N_VALUE_IS_SIZE #define ADDITIONAL_FEATURES \ ADD_FEATURE("U370_AIX"); \ ADD_FEATURE("AIX");\ ADD_FEATURE("BUGGY-CC"); /* #define USE_C_EXTENDED_DIV #define USE_C_EXTENDED_MUL */ #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if (real_maxpage > MAXPAGE) \ real_maxpage = MAXPAGE; #define N_DATADDR(header) #define DATA_BEGIN (char *)header.a_dbase /* I don't know why all the bsd versions are subtracting this off I thought the header.a_text was the actual size of the text not including the header */ #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) /* smallest address data can occur */ /* #define DBEGIN 0x200000 */ #define SYM_UNDEF_P(sym) (((sym)->n_sclass & N_SECT) == N_UNDF) /* the section like N_ABS,N_TEXT,.. */ /* #define N_TYPE N_SECT */ /* the header is regared as part of the text */ #define N_RELOFF(header) A_TRELPOS(header) #define SYMNMLEN 8 #define BIG_ENDIAN #define USE_C_EXTENDED_DIV #define USE_C_EXTENDED_MUL /* the beginning of the string table: first long will be size of string table */ #define ISCOFF(x) (((x) == I386MAGIC) \ || ((x) == U370ROMAGIC) \ || ((x) == U370WRMAGIC) \ || ((x) == XA370ROMAGIC) \ || ((x) == XA370WRMAGIC) \ ) #define RELOC_FILE "rel_u370aix.c" #define GETCWD /* the system defines a different getwd */ #define getwd ourgetwd #ifdef IN_UNIXFSYS #endif #ifdef IN_NUM_CO #include #define S3000 #endif #undef IEEEFLOAT /* these two symbols are too long for the rt pl8cc compiler */ #define check_type_or_pathname_string_symbol_stream check_type_or_path_or_strm #define check_type_or_Pathname_string_symbol check_type_or_path_sym #define TSor_pathname_string_symbol_stream TSor_path_string_sym_strm #define check_type_or_symbol_string_package check_type_or_sym_str_pack #define siLmake_string_output_stream_from_string siLma_str_from_string #define SYM_EXTERNAL_P(p) ((p)->n_sclass == C_EXT) #undef IF_ALLOCATE_ERR /* the u370 likes to allocate a little extra at startup via its own call to sbrk (not malloc) */ char *sdebug; #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {int ll; \ if ((ll=(int)(sbrk(0) - core_end)) < PAGESIZE) \ {sbrk(PAGESIZE - ll); \ \ core_end = sbrk(0); }\ else \ error("Someone allocated my memory!");} \ if (core_end != (sdebug=sbrk(PAGESIZE*(n - m)))) #define FIND_INIT \ { if (*ptr==0 && (sym->n_scnum == TEXT_NSCN ) && sym->n_value ) \ { char tem [9]; \ char *str=SYM_NAME(sym); \ dprintf(find init: %s ,str); \ if (str[1]=='i' && str[2]=='n' && str[3]=='i' && str[4]== 't' \ && str[5]=='_' && str[0]== '_' && str[strlen(str)-1] !='X') \ *ptr= sym->n_value ; \ else {/* printf("The first data symbol was not the init");*/} \ }} /* The system sbrk is not quite right in that it skips some times. so we define one in rel_u370aix.c */ #define sbrk sbrk1 extern char * sbrk1(); #define UNIXSAVE "saveu370.c" /* fool the metaware compiler bug. This should be removed when they fix it { SAFE_INC(big->c.c_car,l) ; if (big->c.c_car < 0) .. was branching incorrectly in case the two positives added to a negative */ #define SAFE_INC(u,amt) do{volatile unsigned int xTmp = u; xTmp += amt; u = (int) xTmp;}while(0) #define SAFE_DEC(u,amt) do{volatile unsigned int xTmp = u; xTmp -= amt; u = (int) xTmp;}while(0) /* #define HAVE_XDR */ /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/gnuwin95.h0000755000175000017500000000636214360276512013072 0ustar cammcamm#define MP386 #include "att.h" /* #include "386.h" */ /* #include "fcntl.h" */ #define DBEGIN _dbegin #define DBEGIN_TY unsigned long extern DBEGIN_TY _dbegin; /* size to use for mallocs done */ /* #define BABY_MALLOC_SIZE 0x5000 */ #define RECREATE_HEAP recreate_heap1(); #ifdef IN_UNIXTIME #undef ATT #define BSD #endif #define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) #undef NEED_GETWD #ifdef IN_UNIXFSYS #undef ATT #define BSD #endif /* on most machines this will test in one instruction if the pointe/r is on the C stack or the 0 pointer in winnt our heap starts at DBEGIN */ /* #define NULL_OR_ON_C_STACK(y)\ */ /* (((unsigned int)(y)) == 0 || \ */ /* (((unsigned int)(y)) < DBEGIN && ((unsigned int)(y)) &0xf000000)) */ /* #define NULL_OR_ON_C_STACK(y) (((void *)(y)) < ((void *)0x400000)) */ #define HAVE_SIGACTION /* a noop */ #define brk(x) printf("not doing break\n"); #include #include #define UNIXSAVE "unexnt.c" #define MAXPATHLEN 260 #define SEPARATE_SFASL_FILE "sfaslcoff.c" #define SPECIAL_RSYM "rsym_nt.c" #define HAVE_AOUT "wincoff.h" /* we dont need to worry about zeroing fp->_base , to prevent */ /* must use seek to go to beginning of string table */ /* #define MUST_SEEK_TO_STROFF */ /* #define N_STROFF(hdr) ((&hdr)->f_symptr+((&hdr)->f_nsyms)*SYMESZ) */ #define TO_NUMBER(ptr,type) (*((type *)(void *)(ptr))) #define SEEK_TO_END_OFILE(fp) do { struct filehdr fileheader; int i; \ fseek(fp,0,0) ; \ fread(&fileheader, sizeof(fileheader), 1, fp); \ fseek(fp, fileheader.f_symptr+fileheader.f_nsyms*SYMESZ, 0); \ fread(&i, sizeof(i), 1, fp); \ fseek(fp, i - sizeof(i), 1); \ while ((i = getc(fp)) == 0) \ ; \ ungetc(i, fp); \ } while (0) #define RUN_PROCESS #define IEEEFLOAT #define I386 #define ADDITIONAL_FEATURES \ ADD_FEATURE("I386"); ADD_FEATURE("WINNT") /* include some low level routines for maxima */ #define CMAC #define RELOC_FILE "rel_coff.c" #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) do { \ int c = 0; \ if ((((FILE *)fp)->_r <= 0) && (ioctl(((FILE *)fp)->_file, FIONREAD, &c), c<=0)) \ return 0; \ } while (0) /* adjust the start to the offset */ #define ADJUST_RELOC_START(j) \ the_start = memory->cfd.cfd_start + \ (j == DATA_NSCN ? textsize : 0); #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {char * e = sbrk(0); \ if (e - core_end < 0x10000 ) { \ int i; \ for (i=page(core_end); i < page(e); i++) { \ \ } \ core_end = e; \ } \ else \ error("Someone allocated my memory!");} \ if (core_end != (sbrk(PAGESIZE*(n - m)))) #include #include #define GET_FULL_PATH_SELF(a_) do { \ static char q[PATH_MAX]; \ massert(which("/proc/self/exe",q) || which(argv[0],q)); \ (a_)=q; \ } while(0) /* Begin for cmpinclude */ /* End for cmpinclude */ #define SF(a_) ((siginfo_t *)a_) #define FPE_CODE(i_,v_) make_fixnum((long)fSfpe_code((long)FFN(fSfnstsw)(),(long)FFN(fSstmxcsr)())) /* #define FPE_CODE(i_,v_) make_fixnum((fixnum)SF(i_)->si_code) */ #define FPE_ADDR(i_,v_) make_fixnum((fixnum)SF(i_)->si_addr) #define FPE_CTXT(v_) Cnil #define FPE_INIT Cnil #undef HAVE_MPROTECT /*buggy on cygwin and unnecessary*/ gcl-2.6.14/h/getpagesize.h0000755000175000017500000000026314360276512013706 0ustar cammcamm /* this is a dummy for emacs unexec.c i think all the systems we handle which use unexec.c have getpagesize If you need something better look in the emacs/src/ distribution. */ gcl-2.6.14/h/mingw.defs0000755000175000017500000000217314360276512013214 0ustar cammcamm # # Machine dependent makefile definitions for Intel X86 under Microsoft Windows, # using Mingw32 compiler tools. (h/mingw.defs) # LIBS += -lwsock32 LIBC = # Unexec dependency UNIX_SAVE_DEP = unexnt.c # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym.exe SPECIAL_RSYM = rsym_nt.c SFASL = sfasl.o FIRST_FILE = firstfile.o LAST_FILE = lastfile.o LIBFILES = bcmp.o bzero.o bcopy.o EXTRAS = mingwin.o mingfile.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM = (si::build-symbol-table) # Use symbolic links SYMB = -s -f APPEND = ../bin/append # suffixes for executables and batch files EXE = .exe BAT = .bat # Don't do dvi on Windows, just HTML GCL_DVI= # Use MSYS makeinfo HTML_CMD=makeinfo --html # Avoid interference from incompatible tcl-tk configuration. TK_CONFIG_PREFIX= TK_LIBRARY= TCL_LIBRARY= TK_XINCLUDES= TK_INCLUDE= TCL_INCLUDE= TK_LIB_SPEC= TK_BUILD_LIB_SPEC= TK_XLIBSW= TK_XINCLUDES= TCL_LIB_SPEC= TCL_DL_LIBS= TCL_LIBS= #PWD_CMD=pwd -W # # End h/mingw.defs # gcl-2.6.14/h/arth.h0000644000175000017500000046041714360276512012345 0ustar cammcamm#define mjoin(a_,b_) a_ ## b_ #define Mjoin(a_,b_) mjoin(a_,b_) #define P_1_1 2 #define P_1_2 3 #define P_1_3 4 #define P_1_4 5 #define P_1_5 6 #define P_1_6 7 #define P_1_7 8 #define P_1_8 9 #define P_1_9 10 #define P_1_10 11 #define P_1_11 12 #define P_1_12 13 #define P_1_13 14 #define P_1_14 15 #define P_1_15 16 #define P_1_16 17 #define P_1_17 18 #define P_1_18 19 #define P_1_19 20 #define P_1_20 21 #define P_1_21 22 #define P_1_22 23 #define P_1_23 24 #define P_1_24 25 #define P_1_25 26 #define P_1_26 27 #define P_1_27 28 #define P_1_28 29 #define P_1_29 30 #define P_1_30 31 #define P_1_31 32 #define P_1_32 33 #define P_1_33 34 #define P_1_34 35 #define P_1_35 36 #define P_1_36 37 #define P_1_37 38 #define P_1_38 39 #define P_1_39 40 #define P_1_40 41 #define P_1_41 42 #define P_1_42 43 #define P_1_43 44 #define P_1_44 45 #define P_1_45 46 #define P_1_46 47 #define P_1_47 48 #define P_1_48 49 #define P_1_49 50 #define P_1_50 51 #define P_1_51 52 #define P_1_52 53 #define P_1_53 54 #define P_1_54 55 #define P_1_55 56 #define P_1_56 57 #define P_1_57 58 #define P_1_58 59 #define P_1_59 60 #define P_1_60 61 #define P_1_61 62 #define P_1_62 63 #define P_1_63 64 #define P_1_64 65 #define P_2_1 3 #define P_2_2 4 #define P_2_3 5 #define P_2_4 6 #define P_2_5 7 #define P_2_6 8 #define P_2_7 9 #define P_2_8 10 #define P_2_9 11 #define P_2_10 12 #define P_2_11 13 #define P_2_12 14 #define P_2_13 15 #define P_2_14 16 #define P_2_15 17 #define P_2_16 18 #define P_2_17 19 #define P_2_18 20 #define P_2_19 21 #define P_2_20 22 #define P_2_21 23 #define P_2_22 24 #define P_2_23 25 #define P_2_24 26 #define P_2_25 27 #define P_2_26 28 #define P_2_27 29 #define P_2_28 30 #define P_2_29 31 #define P_2_30 32 #define P_2_31 33 #define P_2_32 34 #define P_2_33 35 #define P_2_34 36 #define P_2_35 37 #define P_2_36 38 #define P_2_37 39 #define P_2_38 40 #define P_2_39 41 #define P_2_40 42 #define P_2_41 43 #define P_2_42 44 #define P_2_43 45 #define P_2_44 46 #define P_2_45 47 #define P_2_46 48 #define P_2_47 49 #define P_2_48 50 #define P_2_49 51 #define P_2_50 52 #define P_2_51 53 #define P_2_52 54 #define P_2_53 55 #define P_2_54 56 #define P_2_55 57 #define P_2_56 58 #define P_2_57 59 #define P_2_58 60 #define P_2_59 61 #define P_2_60 62 #define P_2_61 63 #define P_2_62 64 #define P_2_63 65 #define P_2_64 66 #define P_3_1 4 #define P_3_2 5 #define P_3_3 6 #define P_3_4 7 #define P_3_5 8 #define P_3_6 9 #define P_3_7 10 #define P_3_8 11 #define P_3_9 12 #define P_3_10 13 #define P_3_11 14 #define P_3_12 15 #define P_3_13 16 #define P_3_14 17 #define P_3_15 18 #define P_3_16 19 #define P_3_17 20 #define P_3_18 21 #define P_3_19 22 #define P_3_20 23 #define P_3_21 24 #define P_3_22 25 #define P_3_23 26 #define P_3_24 27 #define P_3_25 28 #define P_3_26 29 #define P_3_27 30 #define P_3_28 31 #define P_3_29 32 #define P_3_30 33 #define P_3_31 34 #define P_3_32 35 #define P_3_33 36 #define P_3_34 37 #define P_3_35 38 #define P_3_36 39 #define P_3_37 40 #define P_3_38 41 #define P_3_39 42 #define P_3_40 43 #define P_3_41 44 #define P_3_42 45 #define P_3_43 46 #define P_3_44 47 #define P_3_45 48 #define P_3_46 49 #define P_3_47 50 #define P_3_48 51 #define P_3_49 52 #define P_3_50 53 #define P_3_51 54 #define P_3_52 55 #define P_3_53 56 #define P_3_54 57 #define P_3_55 58 #define P_3_56 59 #define P_3_57 60 #define P_3_58 61 #define P_3_59 62 #define P_3_60 63 #define P_3_61 64 #define P_3_62 65 #define P_3_63 66 #define P_3_64 67 #define P_4_1 5 #define P_4_2 6 #define P_4_3 7 #define P_4_4 8 #define P_4_5 9 #define P_4_6 10 #define P_4_7 11 #define P_4_8 12 #define P_4_9 13 #define P_4_10 14 #define P_4_11 15 #define P_4_12 16 #define P_4_13 17 #define P_4_14 18 #define P_4_15 19 #define P_4_16 20 #define P_4_17 21 #define P_4_18 22 #define P_4_19 23 #define P_4_20 24 #define P_4_21 25 #define P_4_22 26 #define P_4_23 27 #define P_4_24 28 #define P_4_25 29 #define P_4_26 30 #define P_4_27 31 #define P_4_28 32 #define P_4_29 33 #define P_4_30 34 #define P_4_31 35 #define P_4_32 36 #define P_4_33 37 #define P_4_34 38 #define P_4_35 39 #define P_4_36 40 #define P_4_37 41 #define P_4_38 42 #define P_4_39 43 #define P_4_40 44 #define P_4_41 45 #define P_4_42 46 #define P_4_43 47 #define P_4_44 48 #define P_4_45 49 #define P_4_46 50 #define P_4_47 51 #define P_4_48 52 #define P_4_49 53 #define P_4_50 54 #define P_4_51 55 #define P_4_52 56 #define P_4_53 57 #define P_4_54 58 #define P_4_55 59 #define P_4_56 60 #define P_4_57 61 #define P_4_58 62 #define P_4_59 63 #define P_4_60 64 #define P_4_61 65 #define P_4_62 66 #define P_4_63 67 #define P_4_64 68 #define P_5_1 6 #define P_5_2 7 #define P_5_3 8 #define P_5_4 9 #define P_5_5 10 #define P_5_6 11 #define P_5_7 12 #define P_5_8 13 #define P_5_9 14 #define P_5_10 15 #define P_5_11 16 #define P_5_12 17 #define P_5_13 18 #define P_5_14 19 #define P_5_15 20 #define P_5_16 21 #define P_5_17 22 #define P_5_18 23 #define P_5_19 24 #define P_5_20 25 #define P_5_21 26 #define P_5_22 27 #define P_5_23 28 #define P_5_24 29 #define P_5_25 30 #define P_5_26 31 #define P_5_27 32 #define P_5_28 33 #define P_5_29 34 #define P_5_30 35 #define P_5_31 36 #define P_5_32 37 #define P_5_33 38 #define P_5_34 39 #define P_5_35 40 #define P_5_36 41 #define P_5_37 42 #define P_5_38 43 #define P_5_39 44 #define P_5_40 45 #define P_5_41 46 #define P_5_42 47 #define P_5_43 48 #define P_5_44 49 #define P_5_45 50 #define P_5_46 51 #define P_5_47 52 #define P_5_48 53 #define P_5_49 54 #define P_5_50 55 #define P_5_51 56 #define P_5_52 57 #define P_5_53 58 #define P_5_54 59 #define P_5_55 60 #define P_5_56 61 #define P_5_57 62 #define P_5_58 63 #define P_5_59 64 #define P_5_60 65 #define P_5_61 66 #define P_5_62 67 #define P_5_63 68 #define P_5_64 69 #define P_6_1 7 #define P_6_2 8 #define P_6_3 9 #define P_6_4 10 #define P_6_5 11 #define P_6_6 12 #define P_6_7 13 #define P_6_8 14 #define P_6_9 15 #define P_6_10 16 #define P_6_11 17 #define P_6_12 18 #define P_6_13 19 #define P_6_14 20 #define P_6_15 21 #define P_6_16 22 #define P_6_17 23 #define P_6_18 24 #define P_6_19 25 #define P_6_20 26 #define P_6_21 27 #define P_6_22 28 #define P_6_23 29 #define P_6_24 30 #define P_6_25 31 #define P_6_26 32 #define P_6_27 33 #define P_6_28 34 #define P_6_29 35 #define P_6_30 36 #define P_6_31 37 #define P_6_32 38 #define P_6_33 39 #define P_6_34 40 #define P_6_35 41 #define P_6_36 42 #define P_6_37 43 #define P_6_38 44 #define P_6_39 45 #define P_6_40 46 #define P_6_41 47 #define P_6_42 48 #define P_6_43 49 #define P_6_44 50 #define P_6_45 51 #define P_6_46 52 #define P_6_47 53 #define P_6_48 54 #define P_6_49 55 #define P_6_50 56 #define P_6_51 57 #define P_6_52 58 #define P_6_53 59 #define P_6_54 60 #define P_6_55 61 #define P_6_56 62 #define P_6_57 63 #define P_6_58 64 #define P_6_59 65 #define P_6_60 66 #define P_6_61 67 #define P_6_62 68 #define P_6_63 69 #define P_6_64 70 #define P_7_1 8 #define P_7_2 9 #define P_7_3 10 #define P_7_4 11 #define P_7_5 12 #define P_7_6 13 #define P_7_7 14 #define P_7_8 15 #define P_7_9 16 #define P_7_10 17 #define P_7_11 18 #define P_7_12 19 #define P_7_13 20 #define P_7_14 21 #define P_7_15 22 #define P_7_16 23 #define P_7_17 24 #define P_7_18 25 #define P_7_19 26 #define P_7_20 27 #define P_7_21 28 #define P_7_22 29 #define P_7_23 30 #define P_7_24 31 #define P_7_25 32 #define P_7_26 33 #define P_7_27 34 #define P_7_28 35 #define P_7_29 36 #define P_7_30 37 #define P_7_31 38 #define P_7_32 39 #define P_7_33 40 #define P_7_34 41 #define P_7_35 42 #define P_7_36 43 #define P_7_37 44 #define P_7_38 45 #define P_7_39 46 #define P_7_40 47 #define P_7_41 48 #define P_7_42 49 #define P_7_43 50 #define P_7_44 51 #define P_7_45 52 #define P_7_46 53 #define P_7_47 54 #define P_7_48 55 #define P_7_49 56 #define P_7_50 57 #define P_7_51 58 #define P_7_52 59 #define P_7_53 60 #define P_7_54 61 #define P_7_55 62 #define P_7_56 63 #define P_7_57 64 #define P_7_58 65 #define P_7_59 66 #define P_7_60 67 #define P_7_61 68 #define P_7_62 69 #define P_7_63 70 #define P_7_64 71 #define P_8_1 9 #define P_8_2 10 #define P_8_3 11 #define P_8_4 12 #define P_8_5 13 #define P_8_6 14 #define P_8_7 15 #define P_8_8 16 #define P_8_9 17 #define P_8_10 18 #define P_8_11 19 #define P_8_12 20 #define P_8_13 21 #define P_8_14 22 #define P_8_15 23 #define P_8_16 24 #define P_8_17 25 #define P_8_18 26 #define P_8_19 27 #define P_8_20 28 #define P_8_21 29 #define P_8_22 30 #define P_8_23 31 #define P_8_24 32 #define P_8_25 33 #define P_8_26 34 #define P_8_27 35 #define P_8_28 36 #define P_8_29 37 #define P_8_30 38 #define P_8_31 39 #define P_8_32 40 #define P_8_33 41 #define P_8_34 42 #define P_8_35 43 #define P_8_36 44 #define P_8_37 45 #define P_8_38 46 #define P_8_39 47 #define P_8_40 48 #define P_8_41 49 #define P_8_42 50 #define P_8_43 51 #define P_8_44 52 #define P_8_45 53 #define P_8_46 54 #define P_8_47 55 #define P_8_48 56 #define P_8_49 57 #define P_8_50 58 #define P_8_51 59 #define P_8_52 60 #define P_8_53 61 #define P_8_54 62 #define P_8_55 63 #define P_8_56 64 #define P_8_57 65 #define P_8_58 66 #define P_8_59 67 #define P_8_60 68 #define P_8_61 69 #define P_8_62 70 #define P_8_63 71 #define P_8_64 72 #define P_9_1 10 #define P_9_2 11 #define P_9_3 12 #define P_9_4 13 #define P_9_5 14 #define P_9_6 15 #define P_9_7 16 #define P_9_8 17 #define P_9_9 18 #define P_9_10 19 #define P_9_11 20 #define P_9_12 21 #define P_9_13 22 #define P_9_14 23 #define P_9_15 24 #define P_9_16 25 #define P_9_17 26 #define P_9_18 27 #define P_9_19 28 #define P_9_20 29 #define P_9_21 30 #define P_9_22 31 #define P_9_23 32 #define P_9_24 33 #define P_9_25 34 #define P_9_26 35 #define P_9_27 36 #define P_9_28 37 #define P_9_29 38 #define P_9_30 39 #define P_9_31 40 #define P_9_32 41 #define P_9_33 42 #define P_9_34 43 #define P_9_35 44 #define P_9_36 45 #define P_9_37 46 #define P_9_38 47 #define P_9_39 48 #define P_9_40 49 #define P_9_41 50 #define P_9_42 51 #define P_9_43 52 #define P_9_44 53 #define P_9_45 54 #define P_9_46 55 #define P_9_47 56 #define P_9_48 57 #define P_9_49 58 #define P_9_50 59 #define P_9_51 60 #define P_9_52 61 #define P_9_53 62 #define P_9_54 63 #define P_9_55 64 #define P_9_56 65 #define P_9_57 66 #define P_9_58 67 #define P_9_59 68 #define P_9_60 69 #define P_9_61 70 #define P_9_62 71 #define P_9_63 72 #define P_9_64 73 #define P_10_1 11 #define P_10_2 12 #define P_10_3 13 #define P_10_4 14 #define P_10_5 15 #define P_10_6 16 #define P_10_7 17 #define P_10_8 18 #define P_10_9 19 #define P_10_10 20 #define P_10_11 21 #define P_10_12 22 #define P_10_13 23 #define P_10_14 24 #define P_10_15 25 #define P_10_16 26 #define P_10_17 27 #define P_10_18 28 #define P_10_19 29 #define P_10_20 30 #define P_10_21 31 #define P_10_22 32 #define P_10_23 33 #define P_10_24 34 #define P_10_25 35 #define P_10_26 36 #define P_10_27 37 #define P_10_28 38 #define P_10_29 39 #define P_10_30 40 #define P_10_31 41 #define P_10_32 42 #define P_10_33 43 #define P_10_34 44 #define P_10_35 45 #define P_10_36 46 #define P_10_37 47 #define P_10_38 48 #define P_10_39 49 #define P_10_40 50 #define P_10_41 51 #define P_10_42 52 #define P_10_43 53 #define P_10_44 54 #define P_10_45 55 #define P_10_46 56 #define P_10_47 57 #define P_10_48 58 #define P_10_49 59 #define P_10_50 60 #define P_10_51 61 #define P_10_52 62 #define P_10_53 63 #define P_10_54 64 #define P_10_55 65 #define P_10_56 66 #define P_10_57 67 #define P_10_58 68 #define P_10_59 69 #define P_10_60 70 #define P_10_61 71 #define P_10_62 72 #define P_10_63 73 #define P_10_64 74 #define P_11_1 12 #define P_11_2 13 #define P_11_3 14 #define P_11_4 15 #define P_11_5 16 #define P_11_6 17 #define P_11_7 18 #define P_11_8 19 #define P_11_9 20 #define P_11_10 21 #define P_11_11 22 #define P_11_12 23 #define P_11_13 24 #define P_11_14 25 #define P_11_15 26 #define P_11_16 27 #define P_11_17 28 #define P_11_18 29 #define P_11_19 30 #define P_11_20 31 #define P_11_21 32 #define P_11_22 33 #define P_11_23 34 #define P_11_24 35 #define P_11_25 36 #define P_11_26 37 #define P_11_27 38 #define P_11_28 39 #define P_11_29 40 #define P_11_30 41 #define P_11_31 42 #define P_11_32 43 #define P_11_33 44 #define P_11_34 45 #define P_11_35 46 #define P_11_36 47 #define P_11_37 48 #define P_11_38 49 #define P_11_39 50 #define P_11_40 51 #define P_11_41 52 #define P_11_42 53 #define P_11_43 54 #define P_11_44 55 #define P_11_45 56 #define P_11_46 57 #define P_11_47 58 #define P_11_48 59 #define P_11_49 60 #define P_11_50 61 #define P_11_51 62 #define P_11_52 63 #define P_11_53 64 #define P_11_54 65 #define P_11_55 66 #define P_11_56 67 #define P_11_57 68 #define P_11_58 69 #define P_11_59 70 #define P_11_60 71 #define P_11_61 72 #define P_11_62 73 #define P_11_63 74 #define P_11_64 75 #define P_12_1 13 #define P_12_2 14 #define P_12_3 15 #define P_12_4 16 #define P_12_5 17 #define P_12_6 18 #define P_12_7 19 #define P_12_8 20 #define P_12_9 21 #define P_12_10 22 #define P_12_11 23 #define P_12_12 24 #define P_12_13 25 #define P_12_14 26 #define P_12_15 27 #define P_12_16 28 #define P_12_17 29 #define P_12_18 30 #define P_12_19 31 #define P_12_20 32 #define P_12_21 33 #define P_12_22 34 #define P_12_23 35 #define P_12_24 36 #define P_12_25 37 #define P_12_26 38 #define P_12_27 39 #define P_12_28 40 #define P_12_29 41 #define P_12_30 42 #define P_12_31 43 #define P_12_32 44 #define P_12_33 45 #define P_12_34 46 #define P_12_35 47 #define P_12_36 48 #define P_12_37 49 #define P_12_38 50 #define P_12_39 51 #define P_12_40 52 #define P_12_41 53 #define P_12_42 54 #define P_12_43 55 #define P_12_44 56 #define P_12_45 57 #define P_12_46 58 #define P_12_47 59 #define P_12_48 60 #define P_12_49 61 #define P_12_50 62 #define P_12_51 63 #define P_12_52 64 #define P_12_53 65 #define P_12_54 66 #define P_12_55 67 #define P_12_56 68 #define P_12_57 69 #define P_12_58 70 #define P_12_59 71 #define P_12_60 72 #define P_12_61 73 #define P_12_62 74 #define P_12_63 75 #define P_12_64 76 #define P_13_1 14 #define P_13_2 15 #define P_13_3 16 #define P_13_4 17 #define P_13_5 18 #define P_13_6 19 #define P_13_7 20 #define P_13_8 21 #define P_13_9 22 #define P_13_10 23 #define P_13_11 24 #define P_13_12 25 #define P_13_13 26 #define P_13_14 27 #define P_13_15 28 #define P_13_16 29 #define P_13_17 30 #define P_13_18 31 #define P_13_19 32 #define P_13_20 33 #define P_13_21 34 #define P_13_22 35 #define P_13_23 36 #define P_13_24 37 #define P_13_25 38 #define P_13_26 39 #define P_13_27 40 #define P_13_28 41 #define P_13_29 42 #define P_13_30 43 #define P_13_31 44 #define P_13_32 45 #define P_13_33 46 #define P_13_34 47 #define P_13_35 48 #define P_13_36 49 #define P_13_37 50 #define P_13_38 51 #define P_13_39 52 #define P_13_40 53 #define P_13_41 54 #define P_13_42 55 #define P_13_43 56 #define P_13_44 57 #define P_13_45 58 #define P_13_46 59 #define P_13_47 60 #define P_13_48 61 #define P_13_49 62 #define P_13_50 63 #define P_13_51 64 #define P_13_52 65 #define P_13_53 66 #define P_13_54 67 #define P_13_55 68 #define P_13_56 69 #define P_13_57 70 #define P_13_58 71 #define P_13_59 72 #define P_13_60 73 #define P_13_61 74 #define P_13_62 75 #define P_13_63 76 #define P_13_64 77 #define P_14_1 15 #define P_14_2 16 #define P_14_3 17 #define P_14_4 18 #define P_14_5 19 #define P_14_6 20 #define P_14_7 21 #define P_14_8 22 #define P_14_9 23 #define P_14_10 24 #define P_14_11 25 #define P_14_12 26 #define P_14_13 27 #define P_14_14 28 #define P_14_15 29 #define P_14_16 30 #define P_14_17 31 #define P_14_18 32 #define P_14_19 33 #define P_14_20 34 #define P_14_21 35 #define P_14_22 36 #define P_14_23 37 #define P_14_24 38 #define P_14_25 39 #define P_14_26 40 #define P_14_27 41 #define P_14_28 42 #define P_14_29 43 #define P_14_30 44 #define P_14_31 45 #define P_14_32 46 #define P_14_33 47 #define P_14_34 48 #define P_14_35 49 #define P_14_36 50 #define P_14_37 51 #define P_14_38 52 #define P_14_39 53 #define P_14_40 54 #define P_14_41 55 #define P_14_42 56 #define P_14_43 57 #define P_14_44 58 #define P_14_45 59 #define P_14_46 60 #define P_14_47 61 #define P_14_48 62 #define P_14_49 63 #define P_14_50 64 #define P_14_51 65 #define P_14_52 66 #define P_14_53 67 #define P_14_54 68 #define P_14_55 69 #define P_14_56 70 #define P_14_57 71 #define P_14_58 72 #define P_14_59 73 #define P_14_60 74 #define P_14_61 75 #define P_14_62 76 #define P_14_63 77 #define P_14_64 78 #define P_15_1 16 #define P_15_2 17 #define P_15_3 18 #define P_15_4 19 #define P_15_5 20 #define P_15_6 21 #define P_15_7 22 #define P_15_8 23 #define P_15_9 24 #define P_15_10 25 #define P_15_11 26 #define P_15_12 27 #define P_15_13 28 #define P_15_14 29 #define P_15_15 30 #define P_15_16 31 #define P_15_17 32 #define P_15_18 33 #define P_15_19 34 #define P_15_20 35 #define P_15_21 36 #define P_15_22 37 #define P_15_23 38 #define P_15_24 39 #define P_15_25 40 #define P_15_26 41 #define P_15_27 42 #define P_15_28 43 #define P_15_29 44 #define P_15_30 45 #define P_15_31 46 #define P_15_32 47 #define P_15_33 48 #define P_15_34 49 #define P_15_35 50 #define P_15_36 51 #define P_15_37 52 #define P_15_38 53 #define P_15_39 54 #define P_15_40 55 #define P_15_41 56 #define P_15_42 57 #define P_15_43 58 #define P_15_44 59 #define P_15_45 60 #define P_15_46 61 #define P_15_47 62 #define P_15_48 63 #define P_15_49 64 #define P_15_50 65 #define P_15_51 66 #define P_15_52 67 #define P_15_53 68 #define P_15_54 69 #define P_15_55 70 #define P_15_56 71 #define P_15_57 72 #define P_15_58 73 #define P_15_59 74 #define P_15_60 75 #define P_15_61 76 #define P_15_62 77 #define P_15_63 78 #define P_15_64 79 #define P_16_1 17 #define P_16_2 18 #define P_16_3 19 #define P_16_4 20 #define P_16_5 21 #define P_16_6 22 #define P_16_7 23 #define P_16_8 24 #define P_16_9 25 #define P_16_10 26 #define P_16_11 27 #define P_16_12 28 #define P_16_13 29 #define P_16_14 30 #define P_16_15 31 #define P_16_16 32 #define P_16_17 33 #define P_16_18 34 #define P_16_19 35 #define P_16_20 36 #define P_16_21 37 #define P_16_22 38 #define P_16_23 39 #define P_16_24 40 #define P_16_25 41 #define P_16_26 42 #define P_16_27 43 #define P_16_28 44 #define P_16_29 45 #define P_16_30 46 #define P_16_31 47 #define P_16_32 48 #define P_16_33 49 #define P_16_34 50 #define P_16_35 51 #define P_16_36 52 #define P_16_37 53 #define P_16_38 54 #define P_16_39 55 #define P_16_40 56 #define P_16_41 57 #define P_16_42 58 #define P_16_43 59 #define P_16_44 60 #define P_16_45 61 #define P_16_46 62 #define P_16_47 63 #define P_16_48 64 #define P_16_49 65 #define P_16_50 66 #define P_16_51 67 #define P_16_52 68 #define P_16_53 69 #define P_16_54 70 #define P_16_55 71 #define P_16_56 72 #define P_16_57 73 #define P_16_58 74 #define P_16_59 75 #define P_16_60 76 #define P_16_61 77 #define P_16_62 78 #define P_16_63 79 #define P_16_64 80 #define P_17_1 18 #define P_17_2 19 #define P_17_3 20 #define P_17_4 21 #define P_17_5 22 #define P_17_6 23 #define P_17_7 24 #define P_17_8 25 #define P_17_9 26 #define P_17_10 27 #define P_17_11 28 #define P_17_12 29 #define P_17_13 30 #define P_17_14 31 #define P_17_15 32 #define P_17_16 33 #define P_17_17 34 #define P_17_18 35 #define P_17_19 36 #define P_17_20 37 #define P_17_21 38 #define P_17_22 39 #define P_17_23 40 #define P_17_24 41 #define P_17_25 42 #define P_17_26 43 #define P_17_27 44 #define P_17_28 45 #define P_17_29 46 #define P_17_30 47 #define P_17_31 48 #define P_17_32 49 #define P_17_33 50 #define P_17_34 51 #define P_17_35 52 #define P_17_36 53 #define P_17_37 54 #define P_17_38 55 #define P_17_39 56 #define P_17_40 57 #define P_17_41 58 #define P_17_42 59 #define P_17_43 60 #define P_17_44 61 #define P_17_45 62 #define P_17_46 63 #define P_17_47 64 #define P_17_48 65 #define P_17_49 66 #define P_17_50 67 #define P_17_51 68 #define P_17_52 69 #define P_17_53 70 #define P_17_54 71 #define P_17_55 72 #define P_17_56 73 #define P_17_57 74 #define P_17_58 75 #define P_17_59 76 #define P_17_60 77 #define P_17_61 78 #define P_17_62 79 #define P_17_63 80 #define P_17_64 81 #define P_18_1 19 #define P_18_2 20 #define P_18_3 21 #define P_18_4 22 #define P_18_5 23 #define P_18_6 24 #define P_18_7 25 #define P_18_8 26 #define P_18_9 27 #define P_18_10 28 #define P_18_11 29 #define P_18_12 30 #define P_18_13 31 #define P_18_14 32 #define P_18_15 33 #define P_18_16 34 #define P_18_17 35 #define P_18_18 36 #define P_18_19 37 #define P_18_20 38 #define P_18_21 39 #define P_18_22 40 #define P_18_23 41 #define P_18_24 42 #define P_18_25 43 #define P_18_26 44 #define P_18_27 45 #define P_18_28 46 #define P_18_29 47 #define P_18_30 48 #define P_18_31 49 #define P_18_32 50 #define P_18_33 51 #define P_18_34 52 #define P_18_35 53 #define P_18_36 54 #define P_18_37 55 #define P_18_38 56 #define P_18_39 57 #define P_18_40 58 #define P_18_41 59 #define P_18_42 60 #define P_18_43 61 #define P_18_44 62 #define P_18_45 63 #define P_18_46 64 #define P_18_47 65 #define P_18_48 66 #define P_18_49 67 #define P_18_50 68 #define P_18_51 69 #define P_18_52 70 #define P_18_53 71 #define P_18_54 72 #define P_18_55 73 #define P_18_56 74 #define P_18_57 75 #define P_18_58 76 #define P_18_59 77 #define P_18_60 78 #define P_18_61 79 #define P_18_62 80 #define P_18_63 81 #define P_18_64 82 #define P_19_1 20 #define P_19_2 21 #define P_19_3 22 #define P_19_4 23 #define P_19_5 24 #define P_19_6 25 #define P_19_7 26 #define P_19_8 27 #define P_19_9 28 #define P_19_10 29 #define P_19_11 30 #define P_19_12 31 #define P_19_13 32 #define P_19_14 33 #define P_19_15 34 #define P_19_16 35 #define P_19_17 36 #define P_19_18 37 #define P_19_19 38 #define P_19_20 39 #define P_19_21 40 #define P_19_22 41 #define P_19_23 42 #define P_19_24 43 #define P_19_25 44 #define P_19_26 45 #define P_19_27 46 #define P_19_28 47 #define P_19_29 48 #define P_19_30 49 #define P_19_31 50 #define P_19_32 51 #define P_19_33 52 #define P_19_34 53 #define P_19_35 54 #define P_19_36 55 #define P_19_37 56 #define P_19_38 57 #define P_19_39 58 #define P_19_40 59 #define P_19_41 60 #define P_19_42 61 #define P_19_43 62 #define P_19_44 63 #define P_19_45 64 #define P_19_46 65 #define P_19_47 66 #define P_19_48 67 #define P_19_49 68 #define P_19_50 69 #define P_19_51 70 #define P_19_52 71 #define P_19_53 72 #define P_19_54 73 #define P_19_55 74 #define P_19_56 75 #define P_19_57 76 #define P_19_58 77 #define P_19_59 78 #define P_19_60 79 #define P_19_61 80 #define P_19_62 81 #define P_19_63 82 #define P_19_64 83 #define P_20_1 21 #define P_20_2 22 #define P_20_3 23 #define P_20_4 24 #define P_20_5 25 #define P_20_6 26 #define P_20_7 27 #define P_20_8 28 #define P_20_9 29 #define P_20_10 30 #define P_20_11 31 #define P_20_12 32 #define P_20_13 33 #define P_20_14 34 #define P_20_15 35 #define P_20_16 36 #define P_20_17 37 #define P_20_18 38 #define P_20_19 39 #define P_20_20 40 #define P_20_21 41 #define P_20_22 42 #define P_20_23 43 #define P_20_24 44 #define P_20_25 45 #define P_20_26 46 #define P_20_27 47 #define P_20_28 48 #define P_20_29 49 #define P_20_30 50 #define P_20_31 51 #define P_20_32 52 #define P_20_33 53 #define P_20_34 54 #define P_20_35 55 #define P_20_36 56 #define P_20_37 57 #define P_20_38 58 #define P_20_39 59 #define P_20_40 60 #define P_20_41 61 #define P_20_42 62 #define P_20_43 63 #define P_20_44 64 #define P_20_45 65 #define P_20_46 66 #define P_20_47 67 #define P_20_48 68 #define P_20_49 69 #define P_20_50 70 #define P_20_51 71 #define P_20_52 72 #define P_20_53 73 #define P_20_54 74 #define P_20_55 75 #define P_20_56 76 #define P_20_57 77 #define P_20_58 78 #define P_20_59 79 #define P_20_60 80 #define P_20_61 81 #define P_20_62 82 #define P_20_63 83 #define P_20_64 84 #define P_21_1 22 #define P_21_2 23 #define P_21_3 24 #define P_21_4 25 #define P_21_5 26 #define P_21_6 27 #define P_21_7 28 #define P_21_8 29 #define P_21_9 30 #define P_21_10 31 #define P_21_11 32 #define P_21_12 33 #define P_21_13 34 #define P_21_14 35 #define P_21_15 36 #define P_21_16 37 #define P_21_17 38 #define P_21_18 39 #define P_21_19 40 #define P_21_20 41 #define P_21_21 42 #define P_21_22 43 #define P_21_23 44 #define P_21_24 45 #define P_21_25 46 #define P_21_26 47 #define P_21_27 48 #define P_21_28 49 #define P_21_29 50 #define P_21_30 51 #define P_21_31 52 #define P_21_32 53 #define P_21_33 54 #define P_21_34 55 #define P_21_35 56 #define P_21_36 57 #define P_21_37 58 #define P_21_38 59 #define P_21_39 60 #define P_21_40 61 #define P_21_41 62 #define P_21_42 63 #define P_21_43 64 #define P_21_44 65 #define P_21_45 66 #define P_21_46 67 #define P_21_47 68 #define P_21_48 69 #define P_21_49 70 #define P_21_50 71 #define P_21_51 72 #define P_21_52 73 #define P_21_53 74 #define P_21_54 75 #define P_21_55 76 #define P_21_56 77 #define P_21_57 78 #define P_21_58 79 #define P_21_59 80 #define P_21_60 81 #define P_21_61 82 #define P_21_62 83 #define P_21_63 84 #define P_21_64 85 #define P_22_1 23 #define P_22_2 24 #define P_22_3 25 #define P_22_4 26 #define P_22_5 27 #define P_22_6 28 #define P_22_7 29 #define P_22_8 30 #define P_22_9 31 #define P_22_10 32 #define P_22_11 33 #define P_22_12 34 #define P_22_13 35 #define P_22_14 36 #define P_22_15 37 #define P_22_16 38 #define P_22_17 39 #define P_22_18 40 #define P_22_19 41 #define P_22_20 42 #define P_22_21 43 #define P_22_22 44 #define P_22_23 45 #define P_22_24 46 #define P_22_25 47 #define P_22_26 48 #define P_22_27 49 #define P_22_28 50 #define P_22_29 51 #define P_22_30 52 #define P_22_31 53 #define P_22_32 54 #define P_22_33 55 #define P_22_34 56 #define P_22_35 57 #define P_22_36 58 #define P_22_37 59 #define P_22_38 60 #define P_22_39 61 #define P_22_40 62 #define P_22_41 63 #define P_22_42 64 #define P_22_43 65 #define P_22_44 66 #define P_22_45 67 #define P_22_46 68 #define P_22_47 69 #define P_22_48 70 #define P_22_49 71 #define P_22_50 72 #define P_22_51 73 #define P_22_52 74 #define P_22_53 75 #define P_22_54 76 #define P_22_55 77 #define P_22_56 78 #define P_22_57 79 #define P_22_58 80 #define P_22_59 81 #define P_22_60 82 #define P_22_61 83 #define P_22_62 84 #define P_22_63 85 #define P_22_64 86 #define P_23_1 24 #define P_23_2 25 #define P_23_3 26 #define P_23_4 27 #define P_23_5 28 #define P_23_6 29 #define P_23_7 30 #define P_23_8 31 #define P_23_9 32 #define P_23_10 33 #define P_23_11 34 #define P_23_12 35 #define P_23_13 36 #define P_23_14 37 #define P_23_15 38 #define P_23_16 39 #define P_23_17 40 #define P_23_18 41 #define P_23_19 42 #define P_23_20 43 #define P_23_21 44 #define P_23_22 45 #define P_23_23 46 #define P_23_24 47 #define P_23_25 48 #define P_23_26 49 #define P_23_27 50 #define P_23_28 51 #define P_23_29 52 #define P_23_30 53 #define P_23_31 54 #define P_23_32 55 #define P_23_33 56 #define P_23_34 57 #define P_23_35 58 #define P_23_36 59 #define P_23_37 60 #define P_23_38 61 #define P_23_39 62 #define P_23_40 63 #define P_23_41 64 #define P_23_42 65 #define P_23_43 66 #define P_23_44 67 #define P_23_45 68 #define P_23_46 69 #define P_23_47 70 #define P_23_48 71 #define P_23_49 72 #define P_23_50 73 #define P_23_51 74 #define P_23_52 75 #define P_23_53 76 #define P_23_54 77 #define P_23_55 78 #define P_23_56 79 #define P_23_57 80 #define P_23_58 81 #define P_23_59 82 #define P_23_60 83 #define P_23_61 84 #define P_23_62 85 #define P_23_63 86 #define P_23_64 87 #define P_24_1 25 #define P_24_2 26 #define P_24_3 27 #define P_24_4 28 #define P_24_5 29 #define P_24_6 30 #define P_24_7 31 #define P_24_8 32 #define P_24_9 33 #define P_24_10 34 #define P_24_11 35 #define P_24_12 36 #define P_24_13 37 #define P_24_14 38 #define P_24_15 39 #define P_24_16 40 #define P_24_17 41 #define P_24_18 42 #define P_24_19 43 #define P_24_20 44 #define P_24_21 45 #define P_24_22 46 #define P_24_23 47 #define P_24_24 48 #define P_24_25 49 #define P_24_26 50 #define P_24_27 51 #define P_24_28 52 #define P_24_29 53 #define P_24_30 54 #define P_24_31 55 #define P_24_32 56 #define P_24_33 57 #define P_24_34 58 #define P_24_35 59 #define P_24_36 60 #define P_24_37 61 #define P_24_38 62 #define P_24_39 63 #define P_24_40 64 #define P_24_41 65 #define P_24_42 66 #define P_24_43 67 #define P_24_44 68 #define P_24_45 69 #define P_24_46 70 #define P_24_47 71 #define P_24_48 72 #define P_24_49 73 #define P_24_50 74 #define P_24_51 75 #define P_24_52 76 #define P_24_53 77 #define P_24_54 78 #define P_24_55 79 #define P_24_56 80 #define P_24_57 81 #define P_24_58 82 #define P_24_59 83 #define P_24_60 84 #define P_24_61 85 #define P_24_62 86 #define P_24_63 87 #define P_24_64 88 #define P_25_1 26 #define P_25_2 27 #define P_25_3 28 #define P_25_4 29 #define P_25_5 30 #define P_25_6 31 #define P_25_7 32 #define P_25_8 33 #define P_25_9 34 #define P_25_10 35 #define P_25_11 36 #define P_25_12 37 #define P_25_13 38 #define P_25_14 39 #define P_25_15 40 #define P_25_16 41 #define P_25_17 42 #define P_25_18 43 #define P_25_19 44 #define P_25_20 45 #define P_25_21 46 #define P_25_22 47 #define P_25_23 48 #define P_25_24 49 #define P_25_25 50 #define P_25_26 51 #define P_25_27 52 #define P_25_28 53 #define P_25_29 54 #define P_25_30 55 #define P_25_31 56 #define P_25_32 57 #define P_25_33 58 #define P_25_34 59 #define P_25_35 60 #define P_25_36 61 #define P_25_37 62 #define P_25_38 63 #define P_25_39 64 #define P_25_40 65 #define P_25_41 66 #define P_25_42 67 #define P_25_43 68 #define P_25_44 69 #define P_25_45 70 #define P_25_46 71 #define P_25_47 72 #define P_25_48 73 #define P_25_49 74 #define P_25_50 75 #define P_25_51 76 #define P_25_52 77 #define P_25_53 78 #define P_25_54 79 #define P_25_55 80 #define P_25_56 81 #define P_25_57 82 #define P_25_58 83 #define P_25_59 84 #define P_25_60 85 #define P_25_61 86 #define P_25_62 87 #define P_25_63 88 #define P_25_64 89 #define P_26_1 27 #define P_26_2 28 #define P_26_3 29 #define P_26_4 30 #define P_26_5 31 #define P_26_6 32 #define P_26_7 33 #define P_26_8 34 #define P_26_9 35 #define P_26_10 36 #define P_26_11 37 #define P_26_12 38 #define P_26_13 39 #define P_26_14 40 #define P_26_15 41 #define P_26_16 42 #define P_26_17 43 #define P_26_18 44 #define P_26_19 45 #define P_26_20 46 #define P_26_21 47 #define P_26_22 48 #define P_26_23 49 #define P_26_24 50 #define P_26_25 51 #define P_26_26 52 #define P_26_27 53 #define P_26_28 54 #define P_26_29 55 #define P_26_30 56 #define P_26_31 57 #define P_26_32 58 #define P_26_33 59 #define P_26_34 60 #define P_26_35 61 #define P_26_36 62 #define P_26_37 63 #define P_26_38 64 #define P_26_39 65 #define P_26_40 66 #define P_26_41 67 #define P_26_42 68 #define P_26_43 69 #define P_26_44 70 #define P_26_45 71 #define P_26_46 72 #define P_26_47 73 #define P_26_48 74 #define P_26_49 75 #define P_26_50 76 #define P_26_51 77 #define P_26_52 78 #define P_26_53 79 #define P_26_54 80 #define P_26_55 81 #define P_26_56 82 #define P_26_57 83 #define P_26_58 84 #define P_26_59 85 #define P_26_60 86 #define P_26_61 87 #define P_26_62 88 #define P_26_63 89 #define P_26_64 90 #define P_27_1 28 #define P_27_2 29 #define P_27_3 30 #define P_27_4 31 #define P_27_5 32 #define P_27_6 33 #define P_27_7 34 #define P_27_8 35 #define P_27_9 36 #define P_27_10 37 #define P_27_11 38 #define P_27_12 39 #define P_27_13 40 #define P_27_14 41 #define P_27_15 42 #define P_27_16 43 #define P_27_17 44 #define P_27_18 45 #define P_27_19 46 #define P_27_20 47 #define P_27_21 48 #define P_27_22 49 #define P_27_23 50 #define P_27_24 51 #define P_27_25 52 #define P_27_26 53 #define P_27_27 54 #define P_27_28 55 #define P_27_29 56 #define P_27_30 57 #define P_27_31 58 #define P_27_32 59 #define P_27_33 60 #define P_27_34 61 #define P_27_35 62 #define P_27_36 63 #define P_27_37 64 #define P_27_38 65 #define P_27_39 66 #define P_27_40 67 #define P_27_41 68 #define P_27_42 69 #define P_27_43 70 #define P_27_44 71 #define P_27_45 72 #define P_27_46 73 #define P_27_47 74 #define P_27_48 75 #define P_27_49 76 #define P_27_50 77 #define P_27_51 78 #define P_27_52 79 #define P_27_53 80 #define P_27_54 81 #define P_27_55 82 #define P_27_56 83 #define P_27_57 84 #define P_27_58 85 #define P_27_59 86 #define P_27_60 87 #define P_27_61 88 #define P_27_62 89 #define P_27_63 90 #define P_27_64 91 #define P_28_1 29 #define P_28_2 30 #define P_28_3 31 #define P_28_4 32 #define P_28_5 33 #define P_28_6 34 #define P_28_7 35 #define P_28_8 36 #define P_28_9 37 #define P_28_10 38 #define P_28_11 39 #define P_28_12 40 #define P_28_13 41 #define P_28_14 42 #define P_28_15 43 #define P_28_16 44 #define P_28_17 45 #define P_28_18 46 #define P_28_19 47 #define P_28_20 48 #define P_28_21 49 #define P_28_22 50 #define P_28_23 51 #define P_28_24 52 #define P_28_25 53 #define P_28_26 54 #define P_28_27 55 #define P_28_28 56 #define P_28_29 57 #define P_28_30 58 #define P_28_31 59 #define P_28_32 60 #define P_28_33 61 #define P_28_34 62 #define P_28_35 63 #define P_28_36 64 #define P_28_37 65 #define P_28_38 66 #define P_28_39 67 #define P_28_40 68 #define P_28_41 69 #define P_28_42 70 #define P_28_43 71 #define P_28_44 72 #define P_28_45 73 #define P_28_46 74 #define P_28_47 75 #define P_28_48 76 #define P_28_49 77 #define P_28_50 78 #define P_28_51 79 #define P_28_52 80 #define P_28_53 81 #define P_28_54 82 #define P_28_55 83 #define P_28_56 84 #define P_28_57 85 #define P_28_58 86 #define P_28_59 87 #define P_28_60 88 #define P_28_61 89 #define P_28_62 90 #define P_28_63 91 #define P_28_64 92 #define P_29_1 30 #define P_29_2 31 #define P_29_3 32 #define P_29_4 33 #define P_29_5 34 #define P_29_6 35 #define P_29_7 36 #define P_29_8 37 #define P_29_9 38 #define P_29_10 39 #define P_29_11 40 #define P_29_12 41 #define P_29_13 42 #define P_29_14 43 #define P_29_15 44 #define P_29_16 45 #define P_29_17 46 #define P_29_18 47 #define P_29_19 48 #define P_29_20 49 #define P_29_21 50 #define P_29_22 51 #define P_29_23 52 #define P_29_24 53 #define P_29_25 54 #define P_29_26 55 #define P_29_27 56 #define P_29_28 57 #define P_29_29 58 #define P_29_30 59 #define P_29_31 60 #define P_29_32 61 #define P_29_33 62 #define P_29_34 63 #define P_29_35 64 #define P_29_36 65 #define P_29_37 66 #define P_29_38 67 #define P_29_39 68 #define P_29_40 69 #define P_29_41 70 #define P_29_42 71 #define P_29_43 72 #define P_29_44 73 #define P_29_45 74 #define P_29_46 75 #define P_29_47 76 #define P_29_48 77 #define P_29_49 78 #define P_29_50 79 #define P_29_51 80 #define P_29_52 81 #define P_29_53 82 #define P_29_54 83 #define P_29_55 84 #define P_29_56 85 #define P_29_57 86 #define P_29_58 87 #define P_29_59 88 #define P_29_60 89 #define P_29_61 90 #define P_29_62 91 #define P_29_63 92 #define P_29_64 93 #define P_30_1 31 #define P_30_2 32 #define P_30_3 33 #define P_30_4 34 #define P_30_5 35 #define P_30_6 36 #define P_30_7 37 #define P_30_8 38 #define P_30_9 39 #define P_30_10 40 #define P_30_11 41 #define P_30_12 42 #define P_30_13 43 #define P_30_14 44 #define P_30_15 45 #define P_30_16 46 #define P_30_17 47 #define P_30_18 48 #define P_30_19 49 #define P_30_20 50 #define P_30_21 51 #define P_30_22 52 #define P_30_23 53 #define P_30_24 54 #define P_30_25 55 #define P_30_26 56 #define P_30_27 57 #define P_30_28 58 #define P_30_29 59 #define P_30_30 60 #define P_30_31 61 #define P_30_32 62 #define P_30_33 63 #define P_30_34 64 #define P_30_35 65 #define P_30_36 66 #define P_30_37 67 #define P_30_38 68 #define P_30_39 69 #define P_30_40 70 #define P_30_41 71 #define P_30_42 72 #define P_30_43 73 #define P_30_44 74 #define P_30_45 75 #define P_30_46 76 #define P_30_47 77 #define P_30_48 78 #define P_30_49 79 #define P_30_50 80 #define P_30_51 81 #define P_30_52 82 #define P_30_53 83 #define P_30_54 84 #define P_30_55 85 #define P_30_56 86 #define P_30_57 87 #define P_30_58 88 #define P_30_59 89 #define P_30_60 90 #define P_30_61 91 #define P_30_62 92 #define P_30_63 93 #define P_30_64 94 #define P_31_1 32 #define P_31_2 33 #define P_31_3 34 #define P_31_4 35 #define P_31_5 36 #define P_31_6 37 #define P_31_7 38 #define P_31_8 39 #define P_31_9 40 #define P_31_10 41 #define P_31_11 42 #define P_31_12 43 #define P_31_13 44 #define P_31_14 45 #define P_31_15 46 #define P_31_16 47 #define P_31_17 48 #define P_31_18 49 #define P_31_19 50 #define P_31_20 51 #define P_31_21 52 #define P_31_22 53 #define P_31_23 54 #define P_31_24 55 #define P_31_25 56 #define P_31_26 57 #define P_31_27 58 #define P_31_28 59 #define P_31_29 60 #define P_31_30 61 #define P_31_31 62 #define P_31_32 63 #define P_31_33 64 #define P_31_34 65 #define P_31_35 66 #define P_31_36 67 #define P_31_37 68 #define P_31_38 69 #define P_31_39 70 #define P_31_40 71 #define P_31_41 72 #define P_31_42 73 #define P_31_43 74 #define P_31_44 75 #define P_31_45 76 #define P_31_46 77 #define P_31_47 78 #define P_31_48 79 #define P_31_49 80 #define P_31_50 81 #define P_31_51 82 #define P_31_52 83 #define P_31_53 84 #define P_31_54 85 #define P_31_55 86 #define P_31_56 87 #define P_31_57 88 #define P_31_58 89 #define P_31_59 90 #define P_31_60 91 #define P_31_61 92 #define P_31_62 93 #define P_31_63 94 #define P_31_64 95 #define P_32_1 33 #define P_32_2 34 #define P_32_3 35 #define P_32_4 36 #define P_32_5 37 #define P_32_6 38 #define P_32_7 39 #define P_32_8 40 #define P_32_9 41 #define P_32_10 42 #define P_32_11 43 #define P_32_12 44 #define P_32_13 45 #define P_32_14 46 #define P_32_15 47 #define P_32_16 48 #define P_32_17 49 #define P_32_18 50 #define P_32_19 51 #define P_32_20 52 #define P_32_21 53 #define P_32_22 54 #define P_32_23 55 #define P_32_24 56 #define P_32_25 57 #define P_32_26 58 #define P_32_27 59 #define P_32_28 60 #define P_32_29 61 #define P_32_30 62 #define P_32_31 63 #define P_32_32 64 #define P_32_33 65 #define P_32_34 66 #define P_32_35 67 #define P_32_36 68 #define P_32_37 69 #define P_32_38 70 #define P_32_39 71 #define P_32_40 72 #define P_32_41 73 #define P_32_42 74 #define P_32_43 75 #define P_32_44 76 #define P_32_45 77 #define P_32_46 78 #define P_32_47 79 #define P_32_48 80 #define P_32_49 81 #define P_32_50 82 #define P_32_51 83 #define P_32_52 84 #define P_32_53 85 #define P_32_54 86 #define P_32_55 87 #define P_32_56 88 #define P_32_57 89 #define P_32_58 90 #define P_32_59 91 #define P_32_60 92 #define P_32_61 93 #define P_32_62 94 #define P_32_63 95 #define P_32_64 96 #define P_33_1 34 #define P_33_2 35 #define P_33_3 36 #define P_33_4 37 #define P_33_5 38 #define P_33_6 39 #define P_33_7 40 #define P_33_8 41 #define P_33_9 42 #define P_33_10 43 #define P_33_11 44 #define P_33_12 45 #define P_33_13 46 #define P_33_14 47 #define P_33_15 48 #define P_33_16 49 #define P_33_17 50 #define P_33_18 51 #define P_33_19 52 #define P_33_20 53 #define P_33_21 54 #define P_33_22 55 #define P_33_23 56 #define P_33_24 57 #define P_33_25 58 #define P_33_26 59 #define P_33_27 60 #define P_33_28 61 #define P_33_29 62 #define P_33_30 63 #define P_33_31 64 #define P_33_32 65 #define P_33_33 66 #define P_33_34 67 #define P_33_35 68 #define P_33_36 69 #define P_33_37 70 #define P_33_38 71 #define P_33_39 72 #define P_33_40 73 #define P_33_41 74 #define P_33_42 75 #define P_33_43 76 #define P_33_44 77 #define P_33_45 78 #define P_33_46 79 #define P_33_47 80 #define P_33_48 81 #define P_33_49 82 #define P_33_50 83 #define P_33_51 84 #define P_33_52 85 #define P_33_53 86 #define P_33_54 87 #define P_33_55 88 #define P_33_56 89 #define P_33_57 90 #define P_33_58 91 #define P_33_59 92 #define P_33_60 93 #define P_33_61 94 #define P_33_62 95 #define P_33_63 96 #define P_33_64 97 #define P_34_1 35 #define P_34_2 36 #define P_34_3 37 #define P_34_4 38 #define P_34_5 39 #define P_34_6 40 #define P_34_7 41 #define P_34_8 42 #define P_34_9 43 #define P_34_10 44 #define P_34_11 45 #define P_34_12 46 #define P_34_13 47 #define P_34_14 48 #define P_34_15 49 #define P_34_16 50 #define P_34_17 51 #define P_34_18 52 #define P_34_19 53 #define P_34_20 54 #define P_34_21 55 #define P_34_22 56 #define P_34_23 57 #define P_34_24 58 #define P_34_25 59 #define P_34_26 60 #define P_34_27 61 #define P_34_28 62 #define P_34_29 63 #define P_34_30 64 #define P_34_31 65 #define P_34_32 66 #define P_34_33 67 #define P_34_34 68 #define P_34_35 69 #define P_34_36 70 #define P_34_37 71 #define P_34_38 72 #define P_34_39 73 #define P_34_40 74 #define P_34_41 75 #define P_34_42 76 #define P_34_43 77 #define P_34_44 78 #define P_34_45 79 #define P_34_46 80 #define P_34_47 81 #define P_34_48 82 #define P_34_49 83 #define P_34_50 84 #define P_34_51 85 #define P_34_52 86 #define P_34_53 87 #define P_34_54 88 #define P_34_55 89 #define P_34_56 90 #define P_34_57 91 #define P_34_58 92 #define P_34_59 93 #define P_34_60 94 #define P_34_61 95 #define P_34_62 96 #define P_34_63 97 #define P_34_64 98 #define P_35_1 36 #define P_35_2 37 #define P_35_3 38 #define P_35_4 39 #define P_35_5 40 #define P_35_6 41 #define P_35_7 42 #define P_35_8 43 #define P_35_9 44 #define P_35_10 45 #define P_35_11 46 #define P_35_12 47 #define P_35_13 48 #define P_35_14 49 #define P_35_15 50 #define P_35_16 51 #define P_35_17 52 #define P_35_18 53 #define P_35_19 54 #define P_35_20 55 #define P_35_21 56 #define P_35_22 57 #define P_35_23 58 #define P_35_24 59 #define P_35_25 60 #define P_35_26 61 #define P_35_27 62 #define P_35_28 63 #define P_35_29 64 #define P_35_30 65 #define P_35_31 66 #define P_35_32 67 #define P_35_33 68 #define P_35_34 69 #define P_35_35 70 #define P_35_36 71 #define P_35_37 72 #define P_35_38 73 #define P_35_39 74 #define P_35_40 75 #define P_35_41 76 #define P_35_42 77 #define P_35_43 78 #define P_35_44 79 #define P_35_45 80 #define P_35_46 81 #define P_35_47 82 #define P_35_48 83 #define P_35_49 84 #define P_35_50 85 #define P_35_51 86 #define P_35_52 87 #define P_35_53 88 #define P_35_54 89 #define P_35_55 90 #define P_35_56 91 #define P_35_57 92 #define P_35_58 93 #define P_35_59 94 #define P_35_60 95 #define P_35_61 96 #define P_35_62 97 #define P_35_63 98 #define P_35_64 99 #define P_36_1 37 #define P_36_2 38 #define P_36_3 39 #define P_36_4 40 #define P_36_5 41 #define P_36_6 42 #define P_36_7 43 #define P_36_8 44 #define P_36_9 45 #define P_36_10 46 #define P_36_11 47 #define P_36_12 48 #define P_36_13 49 #define P_36_14 50 #define P_36_15 51 #define P_36_16 52 #define P_36_17 53 #define P_36_18 54 #define P_36_19 55 #define P_36_20 56 #define P_36_21 57 #define P_36_22 58 #define P_36_23 59 #define P_36_24 60 #define P_36_25 61 #define P_36_26 62 #define P_36_27 63 #define P_36_28 64 #define P_36_29 65 #define P_36_30 66 #define P_36_31 67 #define P_36_32 68 #define P_36_33 69 #define P_36_34 70 #define P_36_35 71 #define P_36_36 72 #define P_36_37 73 #define P_36_38 74 #define P_36_39 75 #define P_36_40 76 #define P_36_41 77 #define P_36_42 78 #define P_36_43 79 #define P_36_44 80 #define P_36_45 81 #define P_36_46 82 #define P_36_47 83 #define P_36_48 84 #define P_36_49 85 #define P_36_50 86 #define P_36_51 87 #define P_36_52 88 #define P_36_53 89 #define P_36_54 90 #define P_36_55 91 #define P_36_56 92 #define P_36_57 93 #define P_36_58 94 #define P_36_59 95 #define P_36_60 96 #define P_36_61 97 #define P_36_62 98 #define P_36_63 99 #define P_36_64 100 #define P_37_1 38 #define P_37_2 39 #define P_37_3 40 #define P_37_4 41 #define P_37_5 42 #define P_37_6 43 #define P_37_7 44 #define P_37_8 45 #define P_37_9 46 #define P_37_10 47 #define P_37_11 48 #define P_37_12 49 #define P_37_13 50 #define P_37_14 51 #define P_37_15 52 #define P_37_16 53 #define P_37_17 54 #define P_37_18 55 #define P_37_19 56 #define P_37_20 57 #define P_37_21 58 #define P_37_22 59 #define P_37_23 60 #define P_37_24 61 #define P_37_25 62 #define P_37_26 63 #define P_37_27 64 #define P_37_28 65 #define P_37_29 66 #define P_37_30 67 #define P_37_31 68 #define P_37_32 69 #define P_37_33 70 #define P_37_34 71 #define P_37_35 72 #define P_37_36 73 #define P_37_37 74 #define P_37_38 75 #define P_37_39 76 #define P_37_40 77 #define P_37_41 78 #define P_37_42 79 #define P_37_43 80 #define P_37_44 81 #define P_37_45 82 #define P_37_46 83 #define P_37_47 84 #define P_37_48 85 #define P_37_49 86 #define P_37_50 87 #define P_37_51 88 #define P_37_52 89 #define P_37_53 90 #define P_37_54 91 #define P_37_55 92 #define P_37_56 93 #define P_37_57 94 #define P_37_58 95 #define P_37_59 96 #define P_37_60 97 #define P_37_61 98 #define P_37_62 99 #define P_37_63 100 #define P_37_64 101 #define P_38_1 39 #define P_38_2 40 #define P_38_3 41 #define P_38_4 42 #define P_38_5 43 #define P_38_6 44 #define P_38_7 45 #define P_38_8 46 #define P_38_9 47 #define P_38_10 48 #define P_38_11 49 #define P_38_12 50 #define P_38_13 51 #define P_38_14 52 #define P_38_15 53 #define P_38_16 54 #define P_38_17 55 #define P_38_18 56 #define P_38_19 57 #define P_38_20 58 #define P_38_21 59 #define P_38_22 60 #define P_38_23 61 #define P_38_24 62 #define P_38_25 63 #define P_38_26 64 #define P_38_27 65 #define P_38_28 66 #define P_38_29 67 #define P_38_30 68 #define P_38_31 69 #define P_38_32 70 #define P_38_33 71 #define P_38_34 72 #define P_38_35 73 #define P_38_36 74 #define P_38_37 75 #define P_38_38 76 #define P_38_39 77 #define P_38_40 78 #define P_38_41 79 #define P_38_42 80 #define P_38_43 81 #define P_38_44 82 #define P_38_45 83 #define P_38_46 84 #define P_38_47 85 #define P_38_48 86 #define P_38_49 87 #define P_38_50 88 #define P_38_51 89 #define P_38_52 90 #define P_38_53 91 #define P_38_54 92 #define P_38_55 93 #define P_38_56 94 #define P_38_57 95 #define P_38_58 96 #define P_38_59 97 #define P_38_60 98 #define P_38_61 99 #define P_38_62 100 #define P_38_63 101 #define P_38_64 102 #define P_39_1 40 #define P_39_2 41 #define P_39_3 42 #define P_39_4 43 #define P_39_5 44 #define P_39_6 45 #define P_39_7 46 #define P_39_8 47 #define P_39_9 48 #define P_39_10 49 #define P_39_11 50 #define P_39_12 51 #define P_39_13 52 #define P_39_14 53 #define P_39_15 54 #define P_39_16 55 #define P_39_17 56 #define P_39_18 57 #define P_39_19 58 #define P_39_20 59 #define P_39_21 60 #define P_39_22 61 #define P_39_23 62 #define P_39_24 63 #define P_39_25 64 #define P_39_26 65 #define P_39_27 66 #define P_39_28 67 #define P_39_29 68 #define P_39_30 69 #define P_39_31 70 #define P_39_32 71 #define P_39_33 72 #define P_39_34 73 #define P_39_35 74 #define P_39_36 75 #define P_39_37 76 #define P_39_38 77 #define P_39_39 78 #define P_39_40 79 #define P_39_41 80 #define P_39_42 81 #define P_39_43 82 #define P_39_44 83 #define P_39_45 84 #define P_39_46 85 #define P_39_47 86 #define P_39_48 87 #define P_39_49 88 #define P_39_50 89 #define P_39_51 90 #define P_39_52 91 #define P_39_53 92 #define P_39_54 93 #define P_39_55 94 #define P_39_56 95 #define P_39_57 96 #define P_39_58 97 #define P_39_59 98 #define P_39_60 99 #define P_39_61 100 #define P_39_62 101 #define P_39_63 102 #define P_39_64 103 #define P_40_1 41 #define P_40_2 42 #define P_40_3 43 #define P_40_4 44 #define P_40_5 45 #define P_40_6 46 #define P_40_7 47 #define P_40_8 48 #define P_40_9 49 #define P_40_10 50 #define P_40_11 51 #define P_40_12 52 #define P_40_13 53 #define P_40_14 54 #define P_40_15 55 #define P_40_16 56 #define P_40_17 57 #define P_40_18 58 #define P_40_19 59 #define P_40_20 60 #define P_40_21 61 #define P_40_22 62 #define P_40_23 63 #define P_40_24 64 #define P_40_25 65 #define P_40_26 66 #define P_40_27 67 #define P_40_28 68 #define P_40_29 69 #define P_40_30 70 #define P_40_31 71 #define P_40_32 72 #define P_40_33 73 #define P_40_34 74 #define P_40_35 75 #define P_40_36 76 #define P_40_37 77 #define P_40_38 78 #define P_40_39 79 #define P_40_40 80 #define P_40_41 81 #define P_40_42 82 #define P_40_43 83 #define P_40_44 84 #define P_40_45 85 #define P_40_46 86 #define P_40_47 87 #define P_40_48 88 #define P_40_49 89 #define P_40_50 90 #define P_40_51 91 #define P_40_52 92 #define P_40_53 93 #define P_40_54 94 #define P_40_55 95 #define P_40_56 96 #define P_40_57 97 #define P_40_58 98 #define P_40_59 99 #define P_40_60 100 #define P_40_61 101 #define P_40_62 102 #define P_40_63 103 #define P_40_64 104 #define P_41_1 42 #define P_41_2 43 #define P_41_3 44 #define P_41_4 45 #define P_41_5 46 #define P_41_6 47 #define P_41_7 48 #define P_41_8 49 #define P_41_9 50 #define P_41_10 51 #define P_41_11 52 #define P_41_12 53 #define P_41_13 54 #define P_41_14 55 #define P_41_15 56 #define P_41_16 57 #define P_41_17 58 #define P_41_18 59 #define P_41_19 60 #define P_41_20 61 #define P_41_21 62 #define P_41_22 63 #define P_41_23 64 #define P_41_24 65 #define P_41_25 66 #define P_41_26 67 #define P_41_27 68 #define P_41_28 69 #define P_41_29 70 #define P_41_30 71 #define P_41_31 72 #define P_41_32 73 #define P_41_33 74 #define P_41_34 75 #define P_41_35 76 #define P_41_36 77 #define P_41_37 78 #define P_41_38 79 #define P_41_39 80 #define P_41_40 81 #define P_41_41 82 #define P_41_42 83 #define P_41_43 84 #define P_41_44 85 #define P_41_45 86 #define P_41_46 87 #define P_41_47 88 #define P_41_48 89 #define P_41_49 90 #define P_41_50 91 #define P_41_51 92 #define P_41_52 93 #define P_41_53 94 #define P_41_54 95 #define P_41_55 96 #define P_41_56 97 #define P_41_57 98 #define P_41_58 99 #define P_41_59 100 #define P_41_60 101 #define P_41_61 102 #define P_41_62 103 #define P_41_63 104 #define P_41_64 105 #define P_42_1 43 #define P_42_2 44 #define P_42_3 45 #define P_42_4 46 #define P_42_5 47 #define P_42_6 48 #define P_42_7 49 #define P_42_8 50 #define P_42_9 51 #define P_42_10 52 #define P_42_11 53 #define P_42_12 54 #define P_42_13 55 #define P_42_14 56 #define P_42_15 57 #define P_42_16 58 #define P_42_17 59 #define P_42_18 60 #define P_42_19 61 #define P_42_20 62 #define P_42_21 63 #define P_42_22 64 #define P_42_23 65 #define P_42_24 66 #define P_42_25 67 #define P_42_26 68 #define P_42_27 69 #define P_42_28 70 #define P_42_29 71 #define P_42_30 72 #define P_42_31 73 #define P_42_32 74 #define P_42_33 75 #define P_42_34 76 #define P_42_35 77 #define P_42_36 78 #define P_42_37 79 #define P_42_38 80 #define P_42_39 81 #define P_42_40 82 #define P_42_41 83 #define P_42_42 84 #define P_42_43 85 #define P_42_44 86 #define P_42_45 87 #define P_42_46 88 #define P_42_47 89 #define P_42_48 90 #define P_42_49 91 #define P_42_50 92 #define P_42_51 93 #define P_42_52 94 #define P_42_53 95 #define P_42_54 96 #define P_42_55 97 #define P_42_56 98 #define P_42_57 99 #define P_42_58 100 #define P_42_59 101 #define P_42_60 102 #define P_42_61 103 #define P_42_62 104 #define P_42_63 105 #define P_42_64 106 #define P_43_1 44 #define P_43_2 45 #define P_43_3 46 #define P_43_4 47 #define P_43_5 48 #define P_43_6 49 #define P_43_7 50 #define P_43_8 51 #define P_43_9 52 #define P_43_10 53 #define P_43_11 54 #define P_43_12 55 #define P_43_13 56 #define P_43_14 57 #define P_43_15 58 #define P_43_16 59 #define P_43_17 60 #define P_43_18 61 #define P_43_19 62 #define P_43_20 63 #define P_43_21 64 #define P_43_22 65 #define P_43_23 66 #define P_43_24 67 #define P_43_25 68 #define P_43_26 69 #define P_43_27 70 #define P_43_28 71 #define P_43_29 72 #define P_43_30 73 #define P_43_31 74 #define P_43_32 75 #define P_43_33 76 #define P_43_34 77 #define P_43_35 78 #define P_43_36 79 #define P_43_37 80 #define P_43_38 81 #define P_43_39 82 #define P_43_40 83 #define P_43_41 84 #define P_43_42 85 #define P_43_43 86 #define P_43_44 87 #define P_43_45 88 #define P_43_46 89 #define P_43_47 90 #define P_43_48 91 #define P_43_49 92 #define P_43_50 93 #define P_43_51 94 #define P_43_52 95 #define P_43_53 96 #define P_43_54 97 #define P_43_55 98 #define P_43_56 99 #define P_43_57 100 #define P_43_58 101 #define P_43_59 102 #define P_43_60 103 #define P_43_61 104 #define P_43_62 105 #define P_43_63 106 #define P_43_64 107 #define P_44_1 45 #define P_44_2 46 #define P_44_3 47 #define P_44_4 48 #define P_44_5 49 #define P_44_6 50 #define P_44_7 51 #define P_44_8 52 #define P_44_9 53 #define P_44_10 54 #define P_44_11 55 #define P_44_12 56 #define P_44_13 57 #define P_44_14 58 #define P_44_15 59 #define P_44_16 60 #define P_44_17 61 #define P_44_18 62 #define P_44_19 63 #define P_44_20 64 #define P_44_21 65 #define P_44_22 66 #define P_44_23 67 #define P_44_24 68 #define P_44_25 69 #define P_44_26 70 #define P_44_27 71 #define P_44_28 72 #define P_44_29 73 #define P_44_30 74 #define P_44_31 75 #define P_44_32 76 #define P_44_33 77 #define P_44_34 78 #define P_44_35 79 #define P_44_36 80 #define P_44_37 81 #define P_44_38 82 #define P_44_39 83 #define P_44_40 84 #define P_44_41 85 #define P_44_42 86 #define P_44_43 87 #define P_44_44 88 #define P_44_45 89 #define P_44_46 90 #define P_44_47 91 #define P_44_48 92 #define P_44_49 93 #define P_44_50 94 #define P_44_51 95 #define P_44_52 96 #define P_44_53 97 #define P_44_54 98 #define P_44_55 99 #define P_44_56 100 #define P_44_57 101 #define P_44_58 102 #define P_44_59 103 #define P_44_60 104 #define P_44_61 105 #define P_44_62 106 #define P_44_63 107 #define P_44_64 108 #define P_45_1 46 #define P_45_2 47 #define P_45_3 48 #define P_45_4 49 #define P_45_5 50 #define P_45_6 51 #define P_45_7 52 #define P_45_8 53 #define P_45_9 54 #define P_45_10 55 #define P_45_11 56 #define P_45_12 57 #define P_45_13 58 #define P_45_14 59 #define P_45_15 60 #define P_45_16 61 #define P_45_17 62 #define P_45_18 63 #define P_45_19 64 #define P_45_20 65 #define P_45_21 66 #define P_45_22 67 #define P_45_23 68 #define P_45_24 69 #define P_45_25 70 #define P_45_26 71 #define P_45_27 72 #define P_45_28 73 #define P_45_29 74 #define P_45_30 75 #define P_45_31 76 #define P_45_32 77 #define P_45_33 78 #define P_45_34 79 #define P_45_35 80 #define P_45_36 81 #define P_45_37 82 #define P_45_38 83 #define P_45_39 84 #define P_45_40 85 #define P_45_41 86 #define P_45_42 87 #define P_45_43 88 #define P_45_44 89 #define P_45_45 90 #define P_45_46 91 #define P_45_47 92 #define P_45_48 93 #define P_45_49 94 #define P_45_50 95 #define P_45_51 96 #define P_45_52 97 #define P_45_53 98 #define P_45_54 99 #define P_45_55 100 #define P_45_56 101 #define P_45_57 102 #define P_45_58 103 #define P_45_59 104 #define P_45_60 105 #define P_45_61 106 #define P_45_62 107 #define P_45_63 108 #define P_45_64 109 #define P_46_1 47 #define P_46_2 48 #define P_46_3 49 #define P_46_4 50 #define P_46_5 51 #define P_46_6 52 #define P_46_7 53 #define P_46_8 54 #define P_46_9 55 #define P_46_10 56 #define P_46_11 57 #define P_46_12 58 #define P_46_13 59 #define P_46_14 60 #define P_46_15 61 #define P_46_16 62 #define P_46_17 63 #define P_46_18 64 #define P_46_19 65 #define P_46_20 66 #define P_46_21 67 #define P_46_22 68 #define P_46_23 69 #define P_46_24 70 #define P_46_25 71 #define P_46_26 72 #define P_46_27 73 #define P_46_28 74 #define P_46_29 75 #define P_46_30 76 #define P_46_31 77 #define P_46_32 78 #define P_46_33 79 #define P_46_34 80 #define P_46_35 81 #define P_46_36 82 #define P_46_37 83 #define P_46_38 84 #define P_46_39 85 #define P_46_40 86 #define P_46_41 87 #define P_46_42 88 #define P_46_43 89 #define P_46_44 90 #define P_46_45 91 #define P_46_46 92 #define P_46_47 93 #define P_46_48 94 #define P_46_49 95 #define P_46_50 96 #define P_46_51 97 #define P_46_52 98 #define P_46_53 99 #define P_46_54 100 #define P_46_55 101 #define P_46_56 102 #define P_46_57 103 #define P_46_58 104 #define P_46_59 105 #define P_46_60 106 #define P_46_61 107 #define P_46_62 108 #define P_46_63 109 #define P_46_64 110 #define P_47_1 48 #define P_47_2 49 #define P_47_3 50 #define P_47_4 51 #define P_47_5 52 #define P_47_6 53 #define P_47_7 54 #define P_47_8 55 #define P_47_9 56 #define P_47_10 57 #define P_47_11 58 #define P_47_12 59 #define P_47_13 60 #define P_47_14 61 #define P_47_15 62 #define P_47_16 63 #define P_47_17 64 #define P_47_18 65 #define P_47_19 66 #define P_47_20 67 #define P_47_21 68 #define P_47_22 69 #define P_47_23 70 #define P_47_24 71 #define P_47_25 72 #define P_47_26 73 #define P_47_27 74 #define P_47_28 75 #define P_47_29 76 #define P_47_30 77 #define P_47_31 78 #define P_47_32 79 #define P_47_33 80 #define P_47_34 81 #define P_47_35 82 #define P_47_36 83 #define P_47_37 84 #define P_47_38 85 #define P_47_39 86 #define P_47_40 87 #define P_47_41 88 #define P_47_42 89 #define P_47_43 90 #define P_47_44 91 #define P_47_45 92 #define P_47_46 93 #define P_47_47 94 #define P_47_48 95 #define P_47_49 96 #define P_47_50 97 #define P_47_51 98 #define P_47_52 99 #define P_47_53 100 #define P_47_54 101 #define P_47_55 102 #define P_47_56 103 #define P_47_57 104 #define P_47_58 105 #define P_47_59 106 #define P_47_60 107 #define P_47_61 108 #define P_47_62 109 #define P_47_63 110 #define P_47_64 111 #define P_48_1 49 #define P_48_2 50 #define P_48_3 51 #define P_48_4 52 #define P_48_5 53 #define P_48_6 54 #define P_48_7 55 #define P_48_8 56 #define P_48_9 57 #define P_48_10 58 #define P_48_11 59 #define P_48_12 60 #define P_48_13 61 #define P_48_14 62 #define P_48_15 63 #define P_48_16 64 #define P_48_17 65 #define P_48_18 66 #define P_48_19 67 #define P_48_20 68 #define P_48_21 69 #define P_48_22 70 #define P_48_23 71 #define P_48_24 72 #define P_48_25 73 #define P_48_26 74 #define P_48_27 75 #define P_48_28 76 #define P_48_29 77 #define P_48_30 78 #define P_48_31 79 #define P_48_32 80 #define P_48_33 81 #define P_48_34 82 #define P_48_35 83 #define P_48_36 84 #define P_48_37 85 #define P_48_38 86 #define P_48_39 87 #define P_48_40 88 #define P_48_41 89 #define P_48_42 90 #define P_48_43 91 #define P_48_44 92 #define P_48_45 93 #define P_48_46 94 #define P_48_47 95 #define P_48_48 96 #define P_48_49 97 #define P_48_50 98 #define P_48_51 99 #define P_48_52 100 #define P_48_53 101 #define P_48_54 102 #define P_48_55 103 #define P_48_56 104 #define P_48_57 105 #define P_48_58 106 #define P_48_59 107 #define P_48_60 108 #define P_48_61 109 #define P_48_62 110 #define P_48_63 111 #define P_48_64 112 #define P_49_1 50 #define P_49_2 51 #define P_49_3 52 #define P_49_4 53 #define P_49_5 54 #define P_49_6 55 #define P_49_7 56 #define P_49_8 57 #define P_49_9 58 #define P_49_10 59 #define P_49_11 60 #define P_49_12 61 #define P_49_13 62 #define P_49_14 63 #define P_49_15 64 #define P_49_16 65 #define P_49_17 66 #define P_49_18 67 #define P_49_19 68 #define P_49_20 69 #define P_49_21 70 #define P_49_22 71 #define P_49_23 72 #define P_49_24 73 #define P_49_25 74 #define P_49_26 75 #define P_49_27 76 #define P_49_28 77 #define P_49_29 78 #define P_49_30 79 #define P_49_31 80 #define P_49_32 81 #define P_49_33 82 #define P_49_34 83 #define P_49_35 84 #define P_49_36 85 #define P_49_37 86 #define P_49_38 87 #define P_49_39 88 #define P_49_40 89 #define P_49_41 90 #define P_49_42 91 #define P_49_43 92 #define P_49_44 93 #define P_49_45 94 #define P_49_46 95 #define P_49_47 96 #define P_49_48 97 #define P_49_49 98 #define P_49_50 99 #define P_49_51 100 #define P_49_52 101 #define P_49_53 102 #define P_49_54 103 #define P_49_55 104 #define P_49_56 105 #define P_49_57 106 #define P_49_58 107 #define P_49_59 108 #define P_49_60 109 #define P_49_61 110 #define P_49_62 111 #define P_49_63 112 #define P_49_64 113 #define P_50_1 51 #define P_50_2 52 #define P_50_3 53 #define P_50_4 54 #define P_50_5 55 #define P_50_6 56 #define P_50_7 57 #define P_50_8 58 #define P_50_9 59 #define P_50_10 60 #define P_50_11 61 #define P_50_12 62 #define P_50_13 63 #define P_50_14 64 #define P_50_15 65 #define P_50_16 66 #define P_50_17 67 #define P_50_18 68 #define P_50_19 69 #define P_50_20 70 #define P_50_21 71 #define P_50_22 72 #define P_50_23 73 #define P_50_24 74 #define P_50_25 75 #define P_50_26 76 #define P_50_27 77 #define P_50_28 78 #define P_50_29 79 #define P_50_30 80 #define P_50_31 81 #define P_50_32 82 #define P_50_33 83 #define P_50_34 84 #define P_50_35 85 #define P_50_36 86 #define P_50_37 87 #define P_50_38 88 #define P_50_39 89 #define P_50_40 90 #define P_50_41 91 #define P_50_42 92 #define P_50_43 93 #define P_50_44 94 #define P_50_45 95 #define P_50_46 96 #define P_50_47 97 #define P_50_48 98 #define P_50_49 99 #define P_50_50 100 #define P_50_51 101 #define P_50_52 102 #define P_50_53 103 #define P_50_54 104 #define P_50_55 105 #define P_50_56 106 #define P_50_57 107 #define P_50_58 108 #define P_50_59 109 #define P_50_60 110 #define P_50_61 111 #define P_50_62 112 #define P_50_63 113 #define P_50_64 114 #define P_51_1 52 #define P_51_2 53 #define P_51_3 54 #define P_51_4 55 #define P_51_5 56 #define P_51_6 57 #define P_51_7 58 #define P_51_8 59 #define P_51_9 60 #define P_51_10 61 #define P_51_11 62 #define P_51_12 63 #define P_51_13 64 #define P_51_14 65 #define P_51_15 66 #define P_51_16 67 #define P_51_17 68 #define P_51_18 69 #define P_51_19 70 #define P_51_20 71 #define P_51_21 72 #define P_51_22 73 #define P_51_23 74 #define P_51_24 75 #define P_51_25 76 #define P_51_26 77 #define P_51_27 78 #define P_51_28 79 #define P_51_29 80 #define P_51_30 81 #define P_51_31 82 #define P_51_32 83 #define P_51_33 84 #define P_51_34 85 #define P_51_35 86 #define P_51_36 87 #define P_51_37 88 #define P_51_38 89 #define P_51_39 90 #define P_51_40 91 #define P_51_41 92 #define P_51_42 93 #define P_51_43 94 #define P_51_44 95 #define P_51_45 96 #define P_51_46 97 #define P_51_47 98 #define P_51_48 99 #define P_51_49 100 #define P_51_50 101 #define P_51_51 102 #define P_51_52 103 #define P_51_53 104 #define P_51_54 105 #define P_51_55 106 #define P_51_56 107 #define P_51_57 108 #define P_51_58 109 #define P_51_59 110 #define P_51_60 111 #define P_51_61 112 #define P_51_62 113 #define P_51_63 114 #define P_51_64 115 #define P_52_1 53 #define P_52_2 54 #define P_52_3 55 #define P_52_4 56 #define P_52_5 57 #define P_52_6 58 #define P_52_7 59 #define P_52_8 60 #define P_52_9 61 #define P_52_10 62 #define P_52_11 63 #define P_52_12 64 #define P_52_13 65 #define P_52_14 66 #define P_52_15 67 #define P_52_16 68 #define P_52_17 69 #define P_52_18 70 #define P_52_19 71 #define P_52_20 72 #define P_52_21 73 #define P_52_22 74 #define P_52_23 75 #define P_52_24 76 #define P_52_25 77 #define P_52_26 78 #define P_52_27 79 #define P_52_28 80 #define P_52_29 81 #define P_52_30 82 #define P_52_31 83 #define P_52_32 84 #define P_52_33 85 #define P_52_34 86 #define P_52_35 87 #define P_52_36 88 #define P_52_37 89 #define P_52_38 90 #define P_52_39 91 #define P_52_40 92 #define P_52_41 93 #define P_52_42 94 #define P_52_43 95 #define P_52_44 96 #define P_52_45 97 #define P_52_46 98 #define P_52_47 99 #define P_52_48 100 #define P_52_49 101 #define P_52_50 102 #define P_52_51 103 #define P_52_52 104 #define P_52_53 105 #define P_52_54 106 #define P_52_55 107 #define P_52_56 108 #define P_52_57 109 #define P_52_58 110 #define P_52_59 111 #define P_52_60 112 #define P_52_61 113 #define P_52_62 114 #define P_52_63 115 #define P_52_64 116 #define P_53_1 54 #define P_53_2 55 #define P_53_3 56 #define P_53_4 57 #define P_53_5 58 #define P_53_6 59 #define P_53_7 60 #define P_53_8 61 #define P_53_9 62 #define P_53_10 63 #define P_53_11 64 #define P_53_12 65 #define P_53_13 66 #define P_53_14 67 #define P_53_15 68 #define P_53_16 69 #define P_53_17 70 #define P_53_18 71 #define P_53_19 72 #define P_53_20 73 #define P_53_21 74 #define P_53_22 75 #define P_53_23 76 #define P_53_24 77 #define P_53_25 78 #define P_53_26 79 #define P_53_27 80 #define P_53_28 81 #define P_53_29 82 #define P_53_30 83 #define P_53_31 84 #define P_53_32 85 #define P_53_33 86 #define P_53_34 87 #define P_53_35 88 #define P_53_36 89 #define P_53_37 90 #define P_53_38 91 #define P_53_39 92 #define P_53_40 93 #define P_53_41 94 #define P_53_42 95 #define P_53_43 96 #define P_53_44 97 #define P_53_45 98 #define P_53_46 99 #define P_53_47 100 #define P_53_48 101 #define P_53_49 102 #define P_53_50 103 #define P_53_51 104 #define P_53_52 105 #define P_53_53 106 #define P_53_54 107 #define P_53_55 108 #define P_53_56 109 #define P_53_57 110 #define P_53_58 111 #define P_53_59 112 #define P_53_60 113 #define P_53_61 114 #define P_53_62 115 #define P_53_63 116 #define P_53_64 117 #define P_54_1 55 #define P_54_2 56 #define P_54_3 57 #define P_54_4 58 #define P_54_5 59 #define P_54_6 60 #define P_54_7 61 #define P_54_8 62 #define P_54_9 63 #define P_54_10 64 #define P_54_11 65 #define P_54_12 66 #define P_54_13 67 #define P_54_14 68 #define P_54_15 69 #define P_54_16 70 #define P_54_17 71 #define P_54_18 72 #define P_54_19 73 #define P_54_20 74 #define P_54_21 75 #define P_54_22 76 #define P_54_23 77 #define P_54_24 78 #define P_54_25 79 #define P_54_26 80 #define P_54_27 81 #define P_54_28 82 #define P_54_29 83 #define P_54_30 84 #define P_54_31 85 #define P_54_32 86 #define P_54_33 87 #define P_54_34 88 #define P_54_35 89 #define P_54_36 90 #define P_54_37 91 #define P_54_38 92 #define P_54_39 93 #define P_54_40 94 #define P_54_41 95 #define P_54_42 96 #define P_54_43 97 #define P_54_44 98 #define P_54_45 99 #define P_54_46 100 #define P_54_47 101 #define P_54_48 102 #define P_54_49 103 #define P_54_50 104 #define P_54_51 105 #define P_54_52 106 #define P_54_53 107 #define P_54_54 108 #define P_54_55 109 #define P_54_56 110 #define P_54_57 111 #define P_54_58 112 #define P_54_59 113 #define P_54_60 114 #define P_54_61 115 #define P_54_62 116 #define P_54_63 117 #define P_54_64 118 #define P_55_1 56 #define P_55_2 57 #define P_55_3 58 #define P_55_4 59 #define P_55_5 60 #define P_55_6 61 #define P_55_7 62 #define P_55_8 63 #define P_55_9 64 #define P_55_10 65 #define P_55_11 66 #define P_55_12 67 #define P_55_13 68 #define P_55_14 69 #define P_55_15 70 #define P_55_16 71 #define P_55_17 72 #define P_55_18 73 #define P_55_19 74 #define P_55_20 75 #define P_55_21 76 #define P_55_22 77 #define P_55_23 78 #define P_55_24 79 #define P_55_25 80 #define P_55_26 81 #define P_55_27 82 #define P_55_28 83 #define P_55_29 84 #define P_55_30 85 #define P_55_31 86 #define P_55_32 87 #define P_55_33 88 #define P_55_34 89 #define P_55_35 90 #define P_55_36 91 #define P_55_37 92 #define P_55_38 93 #define P_55_39 94 #define P_55_40 95 #define P_55_41 96 #define P_55_42 97 #define P_55_43 98 #define P_55_44 99 #define P_55_45 100 #define P_55_46 101 #define P_55_47 102 #define P_55_48 103 #define P_55_49 104 #define P_55_50 105 #define P_55_51 106 #define P_55_52 107 #define P_55_53 108 #define P_55_54 109 #define P_55_55 110 #define P_55_56 111 #define P_55_57 112 #define P_55_58 113 #define P_55_59 114 #define P_55_60 115 #define P_55_61 116 #define P_55_62 117 #define P_55_63 118 #define P_55_64 119 #define P_56_1 57 #define P_56_2 58 #define P_56_3 59 #define P_56_4 60 #define P_56_5 61 #define P_56_6 62 #define P_56_7 63 #define P_56_8 64 #define P_56_9 65 #define P_56_10 66 #define P_56_11 67 #define P_56_12 68 #define P_56_13 69 #define P_56_14 70 #define P_56_15 71 #define P_56_16 72 #define P_56_17 73 #define P_56_18 74 #define P_56_19 75 #define P_56_20 76 #define P_56_21 77 #define P_56_22 78 #define P_56_23 79 #define P_56_24 80 #define P_56_25 81 #define P_56_26 82 #define P_56_27 83 #define P_56_28 84 #define P_56_29 85 #define P_56_30 86 #define P_56_31 87 #define P_56_32 88 #define P_56_33 89 #define P_56_34 90 #define P_56_35 91 #define P_56_36 92 #define P_56_37 93 #define P_56_38 94 #define P_56_39 95 #define P_56_40 96 #define P_56_41 97 #define P_56_42 98 #define P_56_43 99 #define P_56_44 100 #define P_56_45 101 #define P_56_46 102 #define P_56_47 103 #define P_56_48 104 #define P_56_49 105 #define P_56_50 106 #define P_56_51 107 #define P_56_52 108 #define P_56_53 109 #define P_56_54 110 #define P_56_55 111 #define P_56_56 112 #define P_56_57 113 #define P_56_58 114 #define P_56_59 115 #define P_56_60 116 #define P_56_61 117 #define P_56_62 118 #define P_56_63 119 #define P_56_64 120 #define P_57_1 58 #define P_57_2 59 #define P_57_3 60 #define P_57_4 61 #define P_57_5 62 #define P_57_6 63 #define P_57_7 64 #define P_57_8 65 #define P_57_9 66 #define P_57_10 67 #define P_57_11 68 #define P_57_12 69 #define P_57_13 70 #define P_57_14 71 #define P_57_15 72 #define P_57_16 73 #define P_57_17 74 #define P_57_18 75 #define P_57_19 76 #define P_57_20 77 #define P_57_21 78 #define P_57_22 79 #define P_57_23 80 #define P_57_24 81 #define P_57_25 82 #define P_57_26 83 #define P_57_27 84 #define P_57_28 85 #define P_57_29 86 #define P_57_30 87 #define P_57_31 88 #define P_57_32 89 #define P_57_33 90 #define P_57_34 91 #define P_57_35 92 #define P_57_36 93 #define P_57_37 94 #define P_57_38 95 #define P_57_39 96 #define P_57_40 97 #define P_57_41 98 #define P_57_42 99 #define P_57_43 100 #define P_57_44 101 #define P_57_45 102 #define P_57_46 103 #define P_57_47 104 #define P_57_48 105 #define P_57_49 106 #define P_57_50 107 #define P_57_51 108 #define P_57_52 109 #define P_57_53 110 #define P_57_54 111 #define P_57_55 112 #define P_57_56 113 #define P_57_57 114 #define P_57_58 115 #define P_57_59 116 #define P_57_60 117 #define P_57_61 118 #define P_57_62 119 #define P_57_63 120 #define P_57_64 121 #define P_58_1 59 #define P_58_2 60 #define P_58_3 61 #define P_58_4 62 #define P_58_5 63 #define P_58_6 64 #define P_58_7 65 #define P_58_8 66 #define P_58_9 67 #define P_58_10 68 #define P_58_11 69 #define P_58_12 70 #define P_58_13 71 #define P_58_14 72 #define P_58_15 73 #define P_58_16 74 #define P_58_17 75 #define P_58_18 76 #define P_58_19 77 #define P_58_20 78 #define P_58_21 79 #define P_58_22 80 #define P_58_23 81 #define P_58_24 82 #define P_58_25 83 #define P_58_26 84 #define P_58_27 85 #define P_58_28 86 #define P_58_29 87 #define P_58_30 88 #define P_58_31 89 #define P_58_32 90 #define P_58_33 91 #define P_58_34 92 #define P_58_35 93 #define P_58_36 94 #define P_58_37 95 #define P_58_38 96 #define P_58_39 97 #define P_58_40 98 #define P_58_41 99 #define P_58_42 100 #define P_58_43 101 #define P_58_44 102 #define P_58_45 103 #define P_58_46 104 #define P_58_47 105 #define P_58_48 106 #define P_58_49 107 #define P_58_50 108 #define P_58_51 109 #define P_58_52 110 #define P_58_53 111 #define P_58_54 112 #define P_58_55 113 #define P_58_56 114 #define P_58_57 115 #define P_58_58 116 #define P_58_59 117 #define P_58_60 118 #define P_58_61 119 #define P_58_62 120 #define P_58_63 121 #define P_58_64 122 #define P_59_1 60 #define P_59_2 61 #define P_59_3 62 #define P_59_4 63 #define P_59_5 64 #define P_59_6 65 #define P_59_7 66 #define P_59_8 67 #define P_59_9 68 #define P_59_10 69 #define P_59_11 70 #define P_59_12 71 #define P_59_13 72 #define P_59_14 73 #define P_59_15 74 #define P_59_16 75 #define P_59_17 76 #define P_59_18 77 #define P_59_19 78 #define P_59_20 79 #define P_59_21 80 #define P_59_22 81 #define P_59_23 82 #define P_59_24 83 #define P_59_25 84 #define P_59_26 85 #define P_59_27 86 #define P_59_28 87 #define P_59_29 88 #define P_59_30 89 #define P_59_31 90 #define P_59_32 91 #define P_59_33 92 #define P_59_34 93 #define P_59_35 94 #define P_59_36 95 #define P_59_37 96 #define P_59_38 97 #define P_59_39 98 #define P_59_40 99 #define P_59_41 100 #define P_59_42 101 #define P_59_43 102 #define P_59_44 103 #define P_59_45 104 #define P_59_46 105 #define P_59_47 106 #define P_59_48 107 #define P_59_49 108 #define P_59_50 109 #define P_59_51 110 #define P_59_52 111 #define P_59_53 112 #define P_59_54 113 #define P_59_55 114 #define P_59_56 115 #define P_59_57 116 #define P_59_58 117 #define P_59_59 118 #define P_59_60 119 #define P_59_61 120 #define P_59_62 121 #define P_59_63 122 #define P_59_64 123 #define P_60_1 61 #define P_60_2 62 #define P_60_3 63 #define P_60_4 64 #define P_60_5 65 #define P_60_6 66 #define P_60_7 67 #define P_60_8 68 #define P_60_9 69 #define P_60_10 70 #define P_60_11 71 #define P_60_12 72 #define P_60_13 73 #define P_60_14 74 #define P_60_15 75 #define P_60_16 76 #define P_60_17 77 #define P_60_18 78 #define P_60_19 79 #define P_60_20 80 #define P_60_21 81 #define P_60_22 82 #define P_60_23 83 #define P_60_24 84 #define P_60_25 85 #define P_60_26 86 #define P_60_27 87 #define P_60_28 88 #define P_60_29 89 #define P_60_30 90 #define P_60_31 91 #define P_60_32 92 #define P_60_33 93 #define P_60_34 94 #define P_60_35 95 #define P_60_36 96 #define P_60_37 97 #define P_60_38 98 #define P_60_39 99 #define P_60_40 100 #define P_60_41 101 #define P_60_42 102 #define P_60_43 103 #define P_60_44 104 #define P_60_45 105 #define P_60_46 106 #define P_60_47 107 #define P_60_48 108 #define P_60_49 109 #define P_60_50 110 #define P_60_51 111 #define P_60_52 112 #define P_60_53 113 #define P_60_54 114 #define P_60_55 115 #define P_60_56 116 #define P_60_57 117 #define P_60_58 118 #define P_60_59 119 #define P_60_60 120 #define P_60_61 121 #define P_60_62 122 #define P_60_63 123 #define P_60_64 124 #define P_61_1 62 #define P_61_2 63 #define P_61_3 64 #define P_61_4 65 #define P_61_5 66 #define P_61_6 67 #define P_61_7 68 #define P_61_8 69 #define P_61_9 70 #define P_61_10 71 #define P_61_11 72 #define P_61_12 73 #define P_61_13 74 #define P_61_14 75 #define P_61_15 76 #define P_61_16 77 #define P_61_17 78 #define P_61_18 79 #define P_61_19 80 #define P_61_20 81 #define P_61_21 82 #define P_61_22 83 #define P_61_23 84 #define P_61_24 85 #define P_61_25 86 #define P_61_26 87 #define P_61_27 88 #define P_61_28 89 #define P_61_29 90 #define P_61_30 91 #define P_61_31 92 #define P_61_32 93 #define P_61_33 94 #define P_61_34 95 #define P_61_35 96 #define P_61_36 97 #define P_61_37 98 #define P_61_38 99 #define P_61_39 100 #define P_61_40 101 #define P_61_41 102 #define P_61_42 103 #define P_61_43 104 #define P_61_44 105 #define P_61_45 106 #define P_61_46 107 #define P_61_47 108 #define P_61_48 109 #define P_61_49 110 #define P_61_50 111 #define P_61_51 112 #define P_61_52 113 #define P_61_53 114 #define P_61_54 115 #define P_61_55 116 #define P_61_56 117 #define P_61_57 118 #define P_61_58 119 #define P_61_59 120 #define P_61_60 121 #define P_61_61 122 #define P_61_62 123 #define P_61_63 124 #define P_61_64 125 #define P_62_1 63 #define P_62_2 64 #define P_62_3 65 #define P_62_4 66 #define P_62_5 67 #define P_62_6 68 #define P_62_7 69 #define P_62_8 70 #define P_62_9 71 #define P_62_10 72 #define P_62_11 73 #define P_62_12 74 #define P_62_13 75 #define P_62_14 76 #define P_62_15 77 #define P_62_16 78 #define P_62_17 79 #define P_62_18 80 #define P_62_19 81 #define P_62_20 82 #define P_62_21 83 #define P_62_22 84 #define P_62_23 85 #define P_62_24 86 #define P_62_25 87 #define P_62_26 88 #define P_62_27 89 #define P_62_28 90 #define P_62_29 91 #define P_62_30 92 #define P_62_31 93 #define P_62_32 94 #define P_62_33 95 #define P_62_34 96 #define P_62_35 97 #define P_62_36 98 #define P_62_37 99 #define P_62_38 100 #define P_62_39 101 #define P_62_40 102 #define P_62_41 103 #define P_62_42 104 #define P_62_43 105 #define P_62_44 106 #define P_62_45 107 #define P_62_46 108 #define P_62_47 109 #define P_62_48 110 #define P_62_49 111 #define P_62_50 112 #define P_62_51 113 #define P_62_52 114 #define P_62_53 115 #define P_62_54 116 #define P_62_55 117 #define P_62_56 118 #define P_62_57 119 #define P_62_58 120 #define P_62_59 121 #define P_62_60 122 #define P_62_61 123 #define P_62_62 124 #define P_62_63 125 #define P_62_64 126 #define P_63_1 64 #define P_63_2 65 #define P_63_3 66 #define P_63_4 67 #define P_63_5 68 #define P_63_6 69 #define P_63_7 70 #define P_63_8 71 #define P_63_9 72 #define P_63_10 73 #define P_63_11 74 #define P_63_12 75 #define P_63_13 76 #define P_63_14 77 #define P_63_15 78 #define P_63_16 79 #define P_63_17 80 #define P_63_18 81 #define P_63_19 82 #define P_63_20 83 #define P_63_21 84 #define P_63_22 85 #define P_63_23 86 #define P_63_24 87 #define P_63_25 88 #define P_63_26 89 #define P_63_27 90 #define P_63_28 91 #define P_63_29 92 #define P_63_30 93 #define P_63_31 94 #define P_63_32 95 #define P_63_33 96 #define P_63_34 97 #define P_63_35 98 #define P_63_36 99 #define P_63_37 100 #define P_63_38 101 #define P_63_39 102 #define P_63_40 103 #define P_63_41 104 #define P_63_42 105 #define P_63_43 106 #define P_63_44 107 #define P_63_45 108 #define P_63_46 109 #define P_63_47 110 #define P_63_48 111 #define P_63_49 112 #define P_63_50 113 #define P_63_51 114 #define P_63_52 115 #define P_63_53 116 #define P_63_54 117 #define P_63_55 118 #define P_63_56 119 #define P_63_57 120 #define P_63_58 121 #define P_63_59 122 #define P_63_60 123 #define P_63_61 124 #define P_63_62 125 #define P_63_63 126 #define P_63_64 127 #define P_64_1 65 #define P_64_2 66 #define P_64_3 67 #define P_64_4 68 #define P_64_5 69 #define P_64_6 70 #define P_64_7 71 #define P_64_8 72 #define P_64_9 73 #define P_64_10 74 #define P_64_11 75 #define P_64_12 76 #define P_64_13 77 #define P_64_14 78 #define P_64_15 79 #define P_64_16 80 #define P_64_17 81 #define P_64_18 82 #define P_64_19 83 #define P_64_20 84 #define P_64_21 85 #define P_64_22 86 #define P_64_23 87 #define P_64_24 88 #define P_64_25 89 #define P_64_26 90 #define P_64_27 91 #define P_64_28 92 #define P_64_29 93 #define P_64_30 94 #define P_64_31 95 #define P_64_32 96 #define P_64_33 97 #define P_64_34 98 #define P_64_35 99 #define P_64_36 100 #define P_64_37 101 #define P_64_38 102 #define P_64_39 103 #define P_64_40 104 #define P_64_41 105 #define P_64_42 106 #define P_64_43 107 #define P_64_44 108 #define P_64_45 109 #define P_64_46 110 #define P_64_47 111 #define P_64_48 112 #define P_64_49 113 #define P_64_50 114 #define P_64_51 115 #define P_64_52 116 #define P_64_53 117 #define P_64_54 118 #define P_64_55 119 #define P_64_56 120 #define P_64_57 121 #define P_64_58 122 #define P_64_59 123 #define P_64_60 124 #define P_64_61 125 #define P_64_62 126 #define P_64_63 127 #define P_64_64 128 #define M_1_1 0 #define M_1_2 -1 #define M_1_3 -2 #define M_1_4 -3 #define M_1_5 -4 #define M_1_6 -5 #define M_1_7 -6 #define M_1_8 -7 #define M_1_9 -8 #define M_1_10 -9 #define M_1_11 -10 #define M_1_12 -11 #define M_1_13 -12 #define M_1_14 -13 #define M_1_15 -14 #define M_1_16 -15 #define M_1_17 -16 #define M_1_18 -17 #define M_1_19 -18 #define M_1_20 -19 #define M_1_21 -20 #define M_1_22 -21 #define M_1_23 -22 #define M_1_24 -23 #define M_1_25 -24 #define M_1_26 -25 #define M_1_27 -26 #define M_1_28 -27 #define M_1_29 -28 #define M_1_30 -29 #define M_1_31 -30 #define M_1_32 -31 #define M_1_33 -32 #define M_1_34 -33 #define M_1_35 -34 #define M_1_36 -35 #define M_1_37 -36 #define M_1_38 -37 #define M_1_39 -38 #define M_1_40 -39 #define M_1_41 -40 #define M_1_42 -41 #define M_1_43 -42 #define M_1_44 -43 #define M_1_45 -44 #define M_1_46 -45 #define M_1_47 -46 #define M_1_48 -47 #define M_1_49 -48 #define M_1_50 -49 #define M_1_51 -50 #define M_1_52 -51 #define M_1_53 -52 #define M_1_54 -53 #define M_1_55 -54 #define M_1_56 -55 #define M_1_57 -56 #define M_1_58 -57 #define M_1_59 -58 #define M_1_60 -59 #define M_1_61 -60 #define M_1_62 -61 #define M_1_63 -62 #define M_1_64 -63 #define M_2_1 1 #define M_2_2 0 #define M_2_3 -1 #define M_2_4 -2 #define M_2_5 -3 #define M_2_6 -4 #define M_2_7 -5 #define M_2_8 -6 #define M_2_9 -7 #define M_2_10 -8 #define M_2_11 -9 #define M_2_12 -10 #define M_2_13 -11 #define M_2_14 -12 #define M_2_15 -13 #define M_2_16 -14 #define M_2_17 -15 #define M_2_18 -16 #define M_2_19 -17 #define M_2_20 -18 #define M_2_21 -19 #define M_2_22 -20 #define M_2_23 -21 #define M_2_24 -22 #define M_2_25 -23 #define M_2_26 -24 #define M_2_27 -25 #define M_2_28 -26 #define M_2_29 -27 #define M_2_30 -28 #define M_2_31 -29 #define M_2_32 -30 #define M_2_33 -31 #define M_2_34 -32 #define M_2_35 -33 #define M_2_36 -34 #define M_2_37 -35 #define M_2_38 -36 #define M_2_39 -37 #define M_2_40 -38 #define M_2_41 -39 #define M_2_42 -40 #define M_2_43 -41 #define M_2_44 -42 #define M_2_45 -43 #define M_2_46 -44 #define M_2_47 -45 #define M_2_48 -46 #define M_2_49 -47 #define M_2_50 -48 #define M_2_51 -49 #define M_2_52 -50 #define M_2_53 -51 #define M_2_54 -52 #define M_2_55 -53 #define M_2_56 -54 #define M_2_57 -55 #define M_2_58 -56 #define M_2_59 -57 #define M_2_60 -58 #define M_2_61 -59 #define M_2_62 -60 #define M_2_63 -61 #define M_2_64 -62 #define M_3_1 2 #define M_3_2 1 #define M_3_3 0 #define M_3_4 -1 #define M_3_5 -2 #define M_3_6 -3 #define M_3_7 -4 #define M_3_8 -5 #define M_3_9 -6 #define M_3_10 -7 #define M_3_11 -8 #define M_3_12 -9 #define M_3_13 -10 #define M_3_14 -11 #define M_3_15 -12 #define M_3_16 -13 #define M_3_17 -14 #define M_3_18 -15 #define M_3_19 -16 #define M_3_20 -17 #define M_3_21 -18 #define M_3_22 -19 #define M_3_23 -20 #define M_3_24 -21 #define M_3_25 -22 #define M_3_26 -23 #define M_3_27 -24 #define M_3_28 -25 #define M_3_29 -26 #define M_3_30 -27 #define M_3_31 -28 #define M_3_32 -29 #define M_3_33 -30 #define M_3_34 -31 #define M_3_35 -32 #define M_3_36 -33 #define M_3_37 -34 #define M_3_38 -35 #define M_3_39 -36 #define M_3_40 -37 #define M_3_41 -38 #define M_3_42 -39 #define M_3_43 -40 #define M_3_44 -41 #define M_3_45 -42 #define M_3_46 -43 #define M_3_47 -44 #define M_3_48 -45 #define M_3_49 -46 #define M_3_50 -47 #define M_3_51 -48 #define M_3_52 -49 #define M_3_53 -50 #define M_3_54 -51 #define M_3_55 -52 #define M_3_56 -53 #define M_3_57 -54 #define M_3_58 -55 #define M_3_59 -56 #define M_3_60 -57 #define M_3_61 -58 #define M_3_62 -59 #define M_3_63 -60 #define M_3_64 -61 #define M_4_1 3 #define M_4_2 2 #define M_4_3 1 #define M_4_4 0 #define M_4_5 -1 #define M_4_6 -2 #define M_4_7 -3 #define M_4_8 -4 #define M_4_9 -5 #define M_4_10 -6 #define M_4_11 -7 #define M_4_12 -8 #define M_4_13 -9 #define M_4_14 -10 #define M_4_15 -11 #define M_4_16 -12 #define M_4_17 -13 #define M_4_18 -14 #define M_4_19 -15 #define M_4_20 -16 #define M_4_21 -17 #define M_4_22 -18 #define M_4_23 -19 #define M_4_24 -20 #define M_4_25 -21 #define M_4_26 -22 #define M_4_27 -23 #define M_4_28 -24 #define M_4_29 -25 #define M_4_30 -26 #define M_4_31 -27 #define M_4_32 -28 #define M_4_33 -29 #define M_4_34 -30 #define M_4_35 -31 #define M_4_36 -32 #define M_4_37 -33 #define M_4_38 -34 #define M_4_39 -35 #define M_4_40 -36 #define M_4_41 -37 #define M_4_42 -38 #define M_4_43 -39 #define M_4_44 -40 #define M_4_45 -41 #define M_4_46 -42 #define M_4_47 -43 #define M_4_48 -44 #define M_4_49 -45 #define M_4_50 -46 #define M_4_51 -47 #define M_4_52 -48 #define M_4_53 -49 #define M_4_54 -50 #define M_4_55 -51 #define M_4_56 -52 #define M_4_57 -53 #define M_4_58 -54 #define M_4_59 -55 #define M_4_60 -56 #define M_4_61 -57 #define M_4_62 -58 #define M_4_63 -59 #define M_4_64 -60 #define M_5_1 4 #define M_5_2 3 #define M_5_3 2 #define M_5_4 1 #define M_5_5 0 #define M_5_6 -1 #define M_5_7 -2 #define M_5_8 -3 #define M_5_9 -4 #define M_5_10 -5 #define M_5_11 -6 #define M_5_12 -7 #define M_5_13 -8 #define M_5_14 -9 #define M_5_15 -10 #define M_5_16 -11 #define M_5_17 -12 #define M_5_18 -13 #define M_5_19 -14 #define M_5_20 -15 #define M_5_21 -16 #define M_5_22 -17 #define M_5_23 -18 #define M_5_24 -19 #define M_5_25 -20 #define M_5_26 -21 #define M_5_27 -22 #define M_5_28 -23 #define M_5_29 -24 #define M_5_30 -25 #define M_5_31 -26 #define M_5_32 -27 #define M_5_33 -28 #define M_5_34 -29 #define M_5_35 -30 #define M_5_36 -31 #define M_5_37 -32 #define M_5_38 -33 #define M_5_39 -34 #define M_5_40 -35 #define M_5_41 -36 #define M_5_42 -37 #define M_5_43 -38 #define M_5_44 -39 #define M_5_45 -40 #define M_5_46 -41 #define M_5_47 -42 #define M_5_48 -43 #define M_5_49 -44 #define M_5_50 -45 #define M_5_51 -46 #define M_5_52 -47 #define M_5_53 -48 #define M_5_54 -49 #define M_5_55 -50 #define M_5_56 -51 #define M_5_57 -52 #define M_5_58 -53 #define M_5_59 -54 #define M_5_60 -55 #define M_5_61 -56 #define M_5_62 -57 #define M_5_63 -58 #define M_5_64 -59 #define M_6_1 5 #define M_6_2 4 #define M_6_3 3 #define M_6_4 2 #define M_6_5 1 #define M_6_6 0 #define M_6_7 -1 #define M_6_8 -2 #define M_6_9 -3 #define M_6_10 -4 #define M_6_11 -5 #define M_6_12 -6 #define M_6_13 -7 #define M_6_14 -8 #define M_6_15 -9 #define M_6_16 -10 #define M_6_17 -11 #define M_6_18 -12 #define M_6_19 -13 #define M_6_20 -14 #define M_6_21 -15 #define M_6_22 -16 #define M_6_23 -17 #define M_6_24 -18 #define M_6_25 -19 #define M_6_26 -20 #define M_6_27 -21 #define M_6_28 -22 #define M_6_29 -23 #define M_6_30 -24 #define M_6_31 -25 #define M_6_32 -26 #define M_6_33 -27 #define M_6_34 -28 #define M_6_35 -29 #define M_6_36 -30 #define M_6_37 -31 #define M_6_38 -32 #define M_6_39 -33 #define M_6_40 -34 #define M_6_41 -35 #define M_6_42 -36 #define M_6_43 -37 #define M_6_44 -38 #define M_6_45 -39 #define M_6_46 -40 #define M_6_47 -41 #define M_6_48 -42 #define M_6_49 -43 #define M_6_50 -44 #define M_6_51 -45 #define M_6_52 -46 #define M_6_53 -47 #define M_6_54 -48 #define M_6_55 -49 #define M_6_56 -50 #define M_6_57 -51 #define M_6_58 -52 #define M_6_59 -53 #define M_6_60 -54 #define M_6_61 -55 #define M_6_62 -56 #define M_6_63 -57 #define M_6_64 -58 #define M_7_1 6 #define M_7_2 5 #define M_7_3 4 #define M_7_4 3 #define M_7_5 2 #define M_7_6 1 #define M_7_7 0 #define M_7_8 -1 #define M_7_9 -2 #define M_7_10 -3 #define M_7_11 -4 #define M_7_12 -5 #define M_7_13 -6 #define M_7_14 -7 #define M_7_15 -8 #define M_7_16 -9 #define M_7_17 -10 #define M_7_18 -11 #define M_7_19 -12 #define M_7_20 -13 #define M_7_21 -14 #define M_7_22 -15 #define M_7_23 -16 #define M_7_24 -17 #define M_7_25 -18 #define M_7_26 -19 #define M_7_27 -20 #define M_7_28 -21 #define M_7_29 -22 #define M_7_30 -23 #define M_7_31 -24 #define M_7_32 -25 #define M_7_33 -26 #define M_7_34 -27 #define M_7_35 -28 #define M_7_36 -29 #define M_7_37 -30 #define M_7_38 -31 #define M_7_39 -32 #define M_7_40 -33 #define M_7_41 -34 #define M_7_42 -35 #define M_7_43 -36 #define M_7_44 -37 #define M_7_45 -38 #define M_7_46 -39 #define M_7_47 -40 #define M_7_48 -41 #define M_7_49 -42 #define M_7_50 -43 #define M_7_51 -44 #define M_7_52 -45 #define M_7_53 -46 #define M_7_54 -47 #define M_7_55 -48 #define M_7_56 -49 #define M_7_57 -50 #define M_7_58 -51 #define M_7_59 -52 #define M_7_60 -53 #define M_7_61 -54 #define M_7_62 -55 #define M_7_63 -56 #define M_7_64 -57 #define M_8_1 7 #define M_8_2 6 #define M_8_3 5 #define M_8_4 4 #define M_8_5 3 #define M_8_6 2 #define M_8_7 1 #define M_8_8 0 #define M_8_9 -1 #define M_8_10 -2 #define M_8_11 -3 #define M_8_12 -4 #define M_8_13 -5 #define M_8_14 -6 #define M_8_15 -7 #define M_8_16 -8 #define M_8_17 -9 #define M_8_18 -10 #define M_8_19 -11 #define M_8_20 -12 #define M_8_21 -13 #define M_8_22 -14 #define M_8_23 -15 #define M_8_24 -16 #define M_8_25 -17 #define M_8_26 -18 #define M_8_27 -19 #define M_8_28 -20 #define M_8_29 -21 #define M_8_30 -22 #define M_8_31 -23 #define M_8_32 -24 #define M_8_33 -25 #define M_8_34 -26 #define M_8_35 -27 #define M_8_36 -28 #define M_8_37 -29 #define M_8_38 -30 #define M_8_39 -31 #define M_8_40 -32 #define M_8_41 -33 #define M_8_42 -34 #define M_8_43 -35 #define M_8_44 -36 #define M_8_45 -37 #define M_8_46 -38 #define M_8_47 -39 #define M_8_48 -40 #define M_8_49 -41 #define M_8_50 -42 #define M_8_51 -43 #define M_8_52 -44 #define M_8_53 -45 #define M_8_54 -46 #define M_8_55 -47 #define M_8_56 -48 #define M_8_57 -49 #define M_8_58 -50 #define M_8_59 -51 #define M_8_60 -52 #define M_8_61 -53 #define M_8_62 -54 #define M_8_63 -55 #define M_8_64 -56 #define M_9_1 8 #define M_9_2 7 #define M_9_3 6 #define M_9_4 5 #define M_9_5 4 #define M_9_6 3 #define M_9_7 2 #define M_9_8 1 #define M_9_9 0 #define M_9_10 -1 #define M_9_11 -2 #define M_9_12 -3 #define M_9_13 -4 #define M_9_14 -5 #define M_9_15 -6 #define M_9_16 -7 #define M_9_17 -8 #define M_9_18 -9 #define M_9_19 -10 #define M_9_20 -11 #define M_9_21 -12 #define M_9_22 -13 #define M_9_23 -14 #define M_9_24 -15 #define M_9_25 -16 #define M_9_26 -17 #define M_9_27 -18 #define M_9_28 -19 #define M_9_29 -20 #define M_9_30 -21 #define M_9_31 -22 #define M_9_32 -23 #define M_9_33 -24 #define M_9_34 -25 #define M_9_35 -26 #define M_9_36 -27 #define M_9_37 -28 #define M_9_38 -29 #define M_9_39 -30 #define M_9_40 -31 #define M_9_41 -32 #define M_9_42 -33 #define M_9_43 -34 #define M_9_44 -35 #define M_9_45 -36 #define M_9_46 -37 #define M_9_47 -38 #define M_9_48 -39 #define M_9_49 -40 #define M_9_50 -41 #define M_9_51 -42 #define M_9_52 -43 #define M_9_53 -44 #define M_9_54 -45 #define M_9_55 -46 #define M_9_56 -47 #define M_9_57 -48 #define M_9_58 -49 #define M_9_59 -50 #define M_9_60 -51 #define M_9_61 -52 #define M_9_62 -53 #define M_9_63 -54 #define M_9_64 -55 #define M_10_1 9 #define M_10_2 8 #define M_10_3 7 #define M_10_4 6 #define M_10_5 5 #define M_10_6 4 #define M_10_7 3 #define M_10_8 2 #define M_10_9 1 #define M_10_10 0 #define M_10_11 -1 #define M_10_12 -2 #define M_10_13 -3 #define M_10_14 -4 #define M_10_15 -5 #define M_10_16 -6 #define M_10_17 -7 #define M_10_18 -8 #define M_10_19 -9 #define M_10_20 -10 #define M_10_21 -11 #define M_10_22 -12 #define M_10_23 -13 #define M_10_24 -14 #define M_10_25 -15 #define M_10_26 -16 #define M_10_27 -17 #define M_10_28 -18 #define M_10_29 -19 #define M_10_30 -20 #define M_10_31 -21 #define M_10_32 -22 #define M_10_33 -23 #define M_10_34 -24 #define M_10_35 -25 #define M_10_36 -26 #define M_10_37 -27 #define M_10_38 -28 #define M_10_39 -29 #define M_10_40 -30 #define M_10_41 -31 #define M_10_42 -32 #define M_10_43 -33 #define M_10_44 -34 #define M_10_45 -35 #define M_10_46 -36 #define M_10_47 -37 #define M_10_48 -38 #define M_10_49 -39 #define M_10_50 -40 #define M_10_51 -41 #define M_10_52 -42 #define M_10_53 -43 #define M_10_54 -44 #define M_10_55 -45 #define M_10_56 -46 #define M_10_57 -47 #define M_10_58 -48 #define M_10_59 -49 #define M_10_60 -50 #define M_10_61 -51 #define M_10_62 -52 #define M_10_63 -53 #define M_10_64 -54 #define M_11_1 10 #define M_11_2 9 #define M_11_3 8 #define M_11_4 7 #define M_11_5 6 #define M_11_6 5 #define M_11_7 4 #define M_11_8 3 #define M_11_9 2 #define M_11_10 1 #define M_11_11 0 #define M_11_12 -1 #define M_11_13 -2 #define M_11_14 -3 #define M_11_15 -4 #define M_11_16 -5 #define M_11_17 -6 #define M_11_18 -7 #define M_11_19 -8 #define M_11_20 -9 #define M_11_21 -10 #define M_11_22 -11 #define M_11_23 -12 #define M_11_24 -13 #define M_11_25 -14 #define M_11_26 -15 #define M_11_27 -16 #define M_11_28 -17 #define M_11_29 -18 #define M_11_30 -19 #define M_11_31 -20 #define M_11_32 -21 #define M_11_33 -22 #define M_11_34 -23 #define M_11_35 -24 #define M_11_36 -25 #define M_11_37 -26 #define M_11_38 -27 #define M_11_39 -28 #define M_11_40 -29 #define M_11_41 -30 #define M_11_42 -31 #define M_11_43 -32 #define M_11_44 -33 #define M_11_45 -34 #define M_11_46 -35 #define M_11_47 -36 #define M_11_48 -37 #define M_11_49 -38 #define M_11_50 -39 #define M_11_51 -40 #define M_11_52 -41 #define M_11_53 -42 #define M_11_54 -43 #define M_11_55 -44 #define M_11_56 -45 #define M_11_57 -46 #define M_11_58 -47 #define M_11_59 -48 #define M_11_60 -49 #define M_11_61 -50 #define M_11_62 -51 #define M_11_63 -52 #define M_11_64 -53 #define M_12_1 11 #define M_12_2 10 #define M_12_3 9 #define M_12_4 8 #define M_12_5 7 #define M_12_6 6 #define M_12_7 5 #define M_12_8 4 #define M_12_9 3 #define M_12_10 2 #define M_12_11 1 #define M_12_12 0 #define M_12_13 -1 #define M_12_14 -2 #define M_12_15 -3 #define M_12_16 -4 #define M_12_17 -5 #define M_12_18 -6 #define M_12_19 -7 #define M_12_20 -8 #define M_12_21 -9 #define M_12_22 -10 #define M_12_23 -11 #define M_12_24 -12 #define M_12_25 -13 #define M_12_26 -14 #define M_12_27 -15 #define M_12_28 -16 #define M_12_29 -17 #define M_12_30 -18 #define M_12_31 -19 #define M_12_32 -20 #define M_12_33 -21 #define M_12_34 -22 #define M_12_35 -23 #define M_12_36 -24 #define M_12_37 -25 #define M_12_38 -26 #define M_12_39 -27 #define M_12_40 -28 #define M_12_41 -29 #define M_12_42 -30 #define M_12_43 -31 #define M_12_44 -32 #define M_12_45 -33 #define M_12_46 -34 #define M_12_47 -35 #define M_12_48 -36 #define M_12_49 -37 #define M_12_50 -38 #define M_12_51 -39 #define M_12_52 -40 #define M_12_53 -41 #define M_12_54 -42 #define M_12_55 -43 #define M_12_56 -44 #define M_12_57 -45 #define M_12_58 -46 #define M_12_59 -47 #define M_12_60 -48 #define M_12_61 -49 #define M_12_62 -50 #define M_12_63 -51 #define M_12_64 -52 #define M_13_1 12 #define M_13_2 11 #define M_13_3 10 #define M_13_4 9 #define M_13_5 8 #define M_13_6 7 #define M_13_7 6 #define M_13_8 5 #define M_13_9 4 #define M_13_10 3 #define M_13_11 2 #define M_13_12 1 #define M_13_13 0 #define M_13_14 -1 #define M_13_15 -2 #define M_13_16 -3 #define M_13_17 -4 #define M_13_18 -5 #define M_13_19 -6 #define M_13_20 -7 #define M_13_21 -8 #define M_13_22 -9 #define M_13_23 -10 #define M_13_24 -11 #define M_13_25 -12 #define M_13_26 -13 #define M_13_27 -14 #define M_13_28 -15 #define M_13_29 -16 #define M_13_30 -17 #define M_13_31 -18 #define M_13_32 -19 #define M_13_33 -20 #define M_13_34 -21 #define M_13_35 -22 #define M_13_36 -23 #define M_13_37 -24 #define M_13_38 -25 #define M_13_39 -26 #define M_13_40 -27 #define M_13_41 -28 #define M_13_42 -29 #define M_13_43 -30 #define M_13_44 -31 #define M_13_45 -32 #define M_13_46 -33 #define M_13_47 -34 #define M_13_48 -35 #define M_13_49 -36 #define M_13_50 -37 #define M_13_51 -38 #define M_13_52 -39 #define M_13_53 -40 #define M_13_54 -41 #define M_13_55 -42 #define M_13_56 -43 #define M_13_57 -44 #define M_13_58 -45 #define M_13_59 -46 #define M_13_60 -47 #define M_13_61 -48 #define M_13_62 -49 #define M_13_63 -50 #define M_13_64 -51 #define M_14_1 13 #define M_14_2 12 #define M_14_3 11 #define M_14_4 10 #define M_14_5 9 #define M_14_6 8 #define M_14_7 7 #define M_14_8 6 #define M_14_9 5 #define M_14_10 4 #define M_14_11 3 #define M_14_12 2 #define M_14_13 1 #define M_14_14 0 #define M_14_15 -1 #define M_14_16 -2 #define M_14_17 -3 #define M_14_18 -4 #define M_14_19 -5 #define M_14_20 -6 #define M_14_21 -7 #define M_14_22 -8 #define M_14_23 -9 #define M_14_24 -10 #define M_14_25 -11 #define M_14_26 -12 #define M_14_27 -13 #define M_14_28 -14 #define M_14_29 -15 #define M_14_30 -16 #define M_14_31 -17 #define M_14_32 -18 #define M_14_33 -19 #define M_14_34 -20 #define M_14_35 -21 #define M_14_36 -22 #define M_14_37 -23 #define M_14_38 -24 #define M_14_39 -25 #define M_14_40 -26 #define M_14_41 -27 #define M_14_42 -28 #define M_14_43 -29 #define M_14_44 -30 #define M_14_45 -31 #define M_14_46 -32 #define M_14_47 -33 #define M_14_48 -34 #define M_14_49 -35 #define M_14_50 -36 #define M_14_51 -37 #define M_14_52 -38 #define M_14_53 -39 #define M_14_54 -40 #define M_14_55 -41 #define M_14_56 -42 #define M_14_57 -43 #define M_14_58 -44 #define M_14_59 -45 #define M_14_60 -46 #define M_14_61 -47 #define M_14_62 -48 #define M_14_63 -49 #define M_14_64 -50 #define M_15_1 14 #define M_15_2 13 #define M_15_3 12 #define M_15_4 11 #define M_15_5 10 #define M_15_6 9 #define M_15_7 8 #define M_15_8 7 #define M_15_9 6 #define M_15_10 5 #define M_15_11 4 #define M_15_12 3 #define M_15_13 2 #define M_15_14 1 #define M_15_15 0 #define M_15_16 -1 #define M_15_17 -2 #define M_15_18 -3 #define M_15_19 -4 #define M_15_20 -5 #define M_15_21 -6 #define M_15_22 -7 #define M_15_23 -8 #define M_15_24 -9 #define M_15_25 -10 #define M_15_26 -11 #define M_15_27 -12 #define M_15_28 -13 #define M_15_29 -14 #define M_15_30 -15 #define M_15_31 -16 #define M_15_32 -17 #define M_15_33 -18 #define M_15_34 -19 #define M_15_35 -20 #define M_15_36 -21 #define M_15_37 -22 #define M_15_38 -23 #define M_15_39 -24 #define M_15_40 -25 #define M_15_41 -26 #define M_15_42 -27 #define M_15_43 -28 #define M_15_44 -29 #define M_15_45 -30 #define M_15_46 -31 #define M_15_47 -32 #define M_15_48 -33 #define M_15_49 -34 #define M_15_50 -35 #define M_15_51 -36 #define M_15_52 -37 #define M_15_53 -38 #define M_15_54 -39 #define M_15_55 -40 #define M_15_56 -41 #define M_15_57 -42 #define M_15_58 -43 #define M_15_59 -44 #define M_15_60 -45 #define M_15_61 -46 #define M_15_62 -47 #define M_15_63 -48 #define M_15_64 -49 #define M_16_1 15 #define M_16_2 14 #define M_16_3 13 #define M_16_4 12 #define M_16_5 11 #define M_16_6 10 #define M_16_7 9 #define M_16_8 8 #define M_16_9 7 #define M_16_10 6 #define M_16_11 5 #define M_16_12 4 #define M_16_13 3 #define M_16_14 2 #define M_16_15 1 #define M_16_16 0 #define M_16_17 -1 #define M_16_18 -2 #define M_16_19 -3 #define M_16_20 -4 #define M_16_21 -5 #define M_16_22 -6 #define M_16_23 -7 #define M_16_24 -8 #define M_16_25 -9 #define M_16_26 -10 #define M_16_27 -11 #define M_16_28 -12 #define M_16_29 -13 #define M_16_30 -14 #define M_16_31 -15 #define M_16_32 -16 #define M_16_33 -17 #define M_16_34 -18 #define M_16_35 -19 #define M_16_36 -20 #define M_16_37 -21 #define M_16_38 -22 #define M_16_39 -23 #define M_16_40 -24 #define M_16_41 -25 #define M_16_42 -26 #define M_16_43 -27 #define M_16_44 -28 #define M_16_45 -29 #define M_16_46 -30 #define M_16_47 -31 #define M_16_48 -32 #define M_16_49 -33 #define M_16_50 -34 #define M_16_51 -35 #define M_16_52 -36 #define M_16_53 -37 #define M_16_54 -38 #define M_16_55 -39 #define M_16_56 -40 #define M_16_57 -41 #define M_16_58 -42 #define M_16_59 -43 #define M_16_60 -44 #define M_16_61 -45 #define M_16_62 -46 #define M_16_63 -47 #define M_16_64 -48 #define M_17_1 16 #define M_17_2 15 #define M_17_3 14 #define M_17_4 13 #define M_17_5 12 #define M_17_6 11 #define M_17_7 10 #define M_17_8 9 #define M_17_9 8 #define M_17_10 7 #define M_17_11 6 #define M_17_12 5 #define M_17_13 4 #define M_17_14 3 #define M_17_15 2 #define M_17_16 1 #define M_17_17 0 #define M_17_18 -1 #define M_17_19 -2 #define M_17_20 -3 #define M_17_21 -4 #define M_17_22 -5 #define M_17_23 -6 #define M_17_24 -7 #define M_17_25 -8 #define M_17_26 -9 #define M_17_27 -10 #define M_17_28 -11 #define M_17_29 -12 #define M_17_30 -13 #define M_17_31 -14 #define M_17_32 -15 #define M_17_33 -16 #define M_17_34 -17 #define M_17_35 -18 #define M_17_36 -19 #define M_17_37 -20 #define M_17_38 -21 #define M_17_39 -22 #define M_17_40 -23 #define M_17_41 -24 #define M_17_42 -25 #define M_17_43 -26 #define M_17_44 -27 #define M_17_45 -28 #define M_17_46 -29 #define M_17_47 -30 #define M_17_48 -31 #define M_17_49 -32 #define M_17_50 -33 #define M_17_51 -34 #define M_17_52 -35 #define M_17_53 -36 #define M_17_54 -37 #define M_17_55 -38 #define M_17_56 -39 #define M_17_57 -40 #define M_17_58 -41 #define M_17_59 -42 #define M_17_60 -43 #define M_17_61 -44 #define M_17_62 -45 #define M_17_63 -46 #define M_17_64 -47 #define M_18_1 17 #define M_18_2 16 #define M_18_3 15 #define M_18_4 14 #define M_18_5 13 #define M_18_6 12 #define M_18_7 11 #define M_18_8 10 #define M_18_9 9 #define M_18_10 8 #define M_18_11 7 #define M_18_12 6 #define M_18_13 5 #define M_18_14 4 #define M_18_15 3 #define M_18_16 2 #define M_18_17 1 #define M_18_18 0 #define M_18_19 -1 #define M_18_20 -2 #define M_18_21 -3 #define M_18_22 -4 #define M_18_23 -5 #define M_18_24 -6 #define M_18_25 -7 #define M_18_26 -8 #define M_18_27 -9 #define M_18_28 -10 #define M_18_29 -11 #define M_18_30 -12 #define M_18_31 -13 #define M_18_32 -14 #define M_18_33 -15 #define M_18_34 -16 #define M_18_35 -17 #define M_18_36 -18 #define M_18_37 -19 #define M_18_38 -20 #define M_18_39 -21 #define M_18_40 -22 #define M_18_41 -23 #define M_18_42 -24 #define M_18_43 -25 #define M_18_44 -26 #define M_18_45 -27 #define M_18_46 -28 #define M_18_47 -29 #define M_18_48 -30 #define M_18_49 -31 #define M_18_50 -32 #define M_18_51 -33 #define M_18_52 -34 #define M_18_53 -35 #define M_18_54 -36 #define M_18_55 -37 #define M_18_56 -38 #define M_18_57 -39 #define M_18_58 -40 #define M_18_59 -41 #define M_18_60 -42 #define M_18_61 -43 #define M_18_62 -44 #define M_18_63 -45 #define M_18_64 -46 #define M_19_1 18 #define M_19_2 17 #define M_19_3 16 #define M_19_4 15 #define M_19_5 14 #define M_19_6 13 #define M_19_7 12 #define M_19_8 11 #define M_19_9 10 #define M_19_10 9 #define M_19_11 8 #define M_19_12 7 #define M_19_13 6 #define M_19_14 5 #define M_19_15 4 #define M_19_16 3 #define M_19_17 2 #define M_19_18 1 #define M_19_19 0 #define M_19_20 -1 #define M_19_21 -2 #define M_19_22 -3 #define M_19_23 -4 #define M_19_24 -5 #define M_19_25 -6 #define M_19_26 -7 #define M_19_27 -8 #define M_19_28 -9 #define M_19_29 -10 #define M_19_30 -11 #define M_19_31 -12 #define M_19_32 -13 #define M_19_33 -14 #define M_19_34 -15 #define M_19_35 -16 #define M_19_36 -17 #define M_19_37 -18 #define M_19_38 -19 #define M_19_39 -20 #define M_19_40 -21 #define M_19_41 -22 #define M_19_42 -23 #define M_19_43 -24 #define M_19_44 -25 #define M_19_45 -26 #define M_19_46 -27 #define M_19_47 -28 #define M_19_48 -29 #define M_19_49 -30 #define M_19_50 -31 #define M_19_51 -32 #define M_19_52 -33 #define M_19_53 -34 #define M_19_54 -35 #define M_19_55 -36 #define M_19_56 -37 #define M_19_57 -38 #define M_19_58 -39 #define M_19_59 -40 #define M_19_60 -41 #define M_19_61 -42 #define M_19_62 -43 #define M_19_63 -44 #define M_19_64 -45 #define M_20_1 19 #define M_20_2 18 #define M_20_3 17 #define M_20_4 16 #define M_20_5 15 #define M_20_6 14 #define M_20_7 13 #define M_20_8 12 #define M_20_9 11 #define M_20_10 10 #define M_20_11 9 #define M_20_12 8 #define M_20_13 7 #define M_20_14 6 #define M_20_15 5 #define M_20_16 4 #define M_20_17 3 #define M_20_18 2 #define M_20_19 1 #define M_20_20 0 #define M_20_21 -1 #define M_20_22 -2 #define M_20_23 -3 #define M_20_24 -4 #define M_20_25 -5 #define M_20_26 -6 #define M_20_27 -7 #define M_20_28 -8 #define M_20_29 -9 #define M_20_30 -10 #define M_20_31 -11 #define M_20_32 -12 #define M_20_33 -13 #define M_20_34 -14 #define M_20_35 -15 #define M_20_36 -16 #define M_20_37 -17 #define M_20_38 -18 #define M_20_39 -19 #define M_20_40 -20 #define M_20_41 -21 #define M_20_42 -22 #define M_20_43 -23 #define M_20_44 -24 #define M_20_45 -25 #define M_20_46 -26 #define M_20_47 -27 #define M_20_48 -28 #define M_20_49 -29 #define M_20_50 -30 #define M_20_51 -31 #define M_20_52 -32 #define M_20_53 -33 #define M_20_54 -34 #define M_20_55 -35 #define M_20_56 -36 #define M_20_57 -37 #define M_20_58 -38 #define M_20_59 -39 #define M_20_60 -40 #define M_20_61 -41 #define M_20_62 -42 #define M_20_63 -43 #define M_20_64 -44 #define M_21_1 20 #define M_21_2 19 #define M_21_3 18 #define M_21_4 17 #define M_21_5 16 #define M_21_6 15 #define M_21_7 14 #define M_21_8 13 #define M_21_9 12 #define M_21_10 11 #define M_21_11 10 #define M_21_12 9 #define M_21_13 8 #define M_21_14 7 #define M_21_15 6 #define M_21_16 5 #define M_21_17 4 #define M_21_18 3 #define M_21_19 2 #define M_21_20 1 #define M_21_21 0 #define M_21_22 -1 #define M_21_23 -2 #define M_21_24 -3 #define M_21_25 -4 #define M_21_26 -5 #define M_21_27 -6 #define M_21_28 -7 #define M_21_29 -8 #define M_21_30 -9 #define M_21_31 -10 #define M_21_32 -11 #define M_21_33 -12 #define M_21_34 -13 #define M_21_35 -14 #define M_21_36 -15 #define M_21_37 -16 #define M_21_38 -17 #define M_21_39 -18 #define M_21_40 -19 #define M_21_41 -20 #define M_21_42 -21 #define M_21_43 -22 #define M_21_44 -23 #define M_21_45 -24 #define M_21_46 -25 #define M_21_47 -26 #define M_21_48 -27 #define M_21_49 -28 #define M_21_50 -29 #define M_21_51 -30 #define M_21_52 -31 #define M_21_53 -32 #define M_21_54 -33 #define M_21_55 -34 #define M_21_56 -35 #define M_21_57 -36 #define M_21_58 -37 #define M_21_59 -38 #define M_21_60 -39 #define M_21_61 -40 #define M_21_62 -41 #define M_21_63 -42 #define M_21_64 -43 #define M_22_1 21 #define M_22_2 20 #define M_22_3 19 #define M_22_4 18 #define M_22_5 17 #define M_22_6 16 #define M_22_7 15 #define M_22_8 14 #define M_22_9 13 #define M_22_10 12 #define M_22_11 11 #define M_22_12 10 #define M_22_13 9 #define M_22_14 8 #define M_22_15 7 #define M_22_16 6 #define M_22_17 5 #define M_22_18 4 #define M_22_19 3 #define M_22_20 2 #define M_22_21 1 #define M_22_22 0 #define M_22_23 -1 #define M_22_24 -2 #define M_22_25 -3 #define M_22_26 -4 #define M_22_27 -5 #define M_22_28 -6 #define M_22_29 -7 #define M_22_30 -8 #define M_22_31 -9 #define M_22_32 -10 #define M_22_33 -11 #define M_22_34 -12 #define M_22_35 -13 #define M_22_36 -14 #define M_22_37 -15 #define M_22_38 -16 #define M_22_39 -17 #define M_22_40 -18 #define M_22_41 -19 #define M_22_42 -20 #define M_22_43 -21 #define M_22_44 -22 #define M_22_45 -23 #define M_22_46 -24 #define M_22_47 -25 #define M_22_48 -26 #define M_22_49 -27 #define M_22_50 -28 #define M_22_51 -29 #define M_22_52 -30 #define M_22_53 -31 #define M_22_54 -32 #define M_22_55 -33 #define M_22_56 -34 #define M_22_57 -35 #define M_22_58 -36 #define M_22_59 -37 #define M_22_60 -38 #define M_22_61 -39 #define M_22_62 -40 #define M_22_63 -41 #define M_22_64 -42 #define M_23_1 22 #define M_23_2 21 #define M_23_3 20 #define M_23_4 19 #define M_23_5 18 #define M_23_6 17 #define M_23_7 16 #define M_23_8 15 #define M_23_9 14 #define M_23_10 13 #define M_23_11 12 #define M_23_12 11 #define M_23_13 10 #define M_23_14 9 #define M_23_15 8 #define M_23_16 7 #define M_23_17 6 #define M_23_18 5 #define M_23_19 4 #define M_23_20 3 #define M_23_21 2 #define M_23_22 1 #define M_23_23 0 #define M_23_24 -1 #define M_23_25 -2 #define M_23_26 -3 #define M_23_27 -4 #define M_23_28 -5 #define M_23_29 -6 #define M_23_30 -7 #define M_23_31 -8 #define M_23_32 -9 #define M_23_33 -10 #define M_23_34 -11 #define M_23_35 -12 #define M_23_36 -13 #define M_23_37 -14 #define M_23_38 -15 #define M_23_39 -16 #define M_23_40 -17 #define M_23_41 -18 #define M_23_42 -19 #define M_23_43 -20 #define M_23_44 -21 #define M_23_45 -22 #define M_23_46 -23 #define M_23_47 -24 #define M_23_48 -25 #define M_23_49 -26 #define M_23_50 -27 #define M_23_51 -28 #define M_23_52 -29 #define M_23_53 -30 #define M_23_54 -31 #define M_23_55 -32 #define M_23_56 -33 #define M_23_57 -34 #define M_23_58 -35 #define M_23_59 -36 #define M_23_60 -37 #define M_23_61 -38 #define M_23_62 -39 #define M_23_63 -40 #define M_23_64 -41 #define M_24_1 23 #define M_24_2 22 #define M_24_3 21 #define M_24_4 20 #define M_24_5 19 #define M_24_6 18 #define M_24_7 17 #define M_24_8 16 #define M_24_9 15 #define M_24_10 14 #define M_24_11 13 #define M_24_12 12 #define M_24_13 11 #define M_24_14 10 #define M_24_15 9 #define M_24_16 8 #define M_24_17 7 #define M_24_18 6 #define M_24_19 5 #define M_24_20 4 #define M_24_21 3 #define M_24_22 2 #define M_24_23 1 #define M_24_24 0 #define M_24_25 -1 #define M_24_26 -2 #define M_24_27 -3 #define M_24_28 -4 #define M_24_29 -5 #define M_24_30 -6 #define M_24_31 -7 #define M_24_32 -8 #define M_24_33 -9 #define M_24_34 -10 #define M_24_35 -11 #define M_24_36 -12 #define M_24_37 -13 #define M_24_38 -14 #define M_24_39 -15 #define M_24_40 -16 #define M_24_41 -17 #define M_24_42 -18 #define M_24_43 -19 #define M_24_44 -20 #define M_24_45 -21 #define M_24_46 -22 #define M_24_47 -23 #define M_24_48 -24 #define M_24_49 -25 #define M_24_50 -26 #define M_24_51 -27 #define M_24_52 -28 #define M_24_53 -29 #define M_24_54 -30 #define M_24_55 -31 #define M_24_56 -32 #define M_24_57 -33 #define M_24_58 -34 #define M_24_59 -35 #define M_24_60 -36 #define M_24_61 -37 #define M_24_62 -38 #define M_24_63 -39 #define M_24_64 -40 #define M_25_1 24 #define M_25_2 23 #define M_25_3 22 #define M_25_4 21 #define M_25_5 20 #define M_25_6 19 #define M_25_7 18 #define M_25_8 17 #define M_25_9 16 #define M_25_10 15 #define M_25_11 14 #define M_25_12 13 #define M_25_13 12 #define M_25_14 11 #define M_25_15 10 #define M_25_16 9 #define M_25_17 8 #define M_25_18 7 #define M_25_19 6 #define M_25_20 5 #define M_25_21 4 #define M_25_22 3 #define M_25_23 2 #define M_25_24 1 #define M_25_25 0 #define M_25_26 -1 #define M_25_27 -2 #define M_25_28 -3 #define M_25_29 -4 #define M_25_30 -5 #define M_25_31 -6 #define M_25_32 -7 #define M_25_33 -8 #define M_25_34 -9 #define M_25_35 -10 #define M_25_36 -11 #define M_25_37 -12 #define M_25_38 -13 #define M_25_39 -14 #define M_25_40 -15 #define M_25_41 -16 #define M_25_42 -17 #define M_25_43 -18 #define M_25_44 -19 #define M_25_45 -20 #define M_25_46 -21 #define M_25_47 -22 #define M_25_48 -23 #define M_25_49 -24 #define M_25_50 -25 #define M_25_51 -26 #define M_25_52 -27 #define M_25_53 -28 #define M_25_54 -29 #define M_25_55 -30 #define M_25_56 -31 #define M_25_57 -32 #define M_25_58 -33 #define M_25_59 -34 #define M_25_60 -35 #define M_25_61 -36 #define M_25_62 -37 #define M_25_63 -38 #define M_25_64 -39 #define M_26_1 25 #define M_26_2 24 #define M_26_3 23 #define M_26_4 22 #define M_26_5 21 #define M_26_6 20 #define M_26_7 19 #define M_26_8 18 #define M_26_9 17 #define M_26_10 16 #define M_26_11 15 #define M_26_12 14 #define M_26_13 13 #define M_26_14 12 #define M_26_15 11 #define M_26_16 10 #define M_26_17 9 #define M_26_18 8 #define M_26_19 7 #define M_26_20 6 #define M_26_21 5 #define M_26_22 4 #define M_26_23 3 #define M_26_24 2 #define M_26_25 1 #define M_26_26 0 #define M_26_27 -1 #define M_26_28 -2 #define M_26_29 -3 #define M_26_30 -4 #define M_26_31 -5 #define M_26_32 -6 #define M_26_33 -7 #define M_26_34 -8 #define M_26_35 -9 #define M_26_36 -10 #define M_26_37 -11 #define M_26_38 -12 #define M_26_39 -13 #define M_26_40 -14 #define M_26_41 -15 #define M_26_42 -16 #define M_26_43 -17 #define M_26_44 -18 #define M_26_45 -19 #define M_26_46 -20 #define M_26_47 -21 #define M_26_48 -22 #define M_26_49 -23 #define M_26_50 -24 #define M_26_51 -25 #define M_26_52 -26 #define M_26_53 -27 #define M_26_54 -28 #define M_26_55 -29 #define M_26_56 -30 #define M_26_57 -31 #define M_26_58 -32 #define M_26_59 -33 #define M_26_60 -34 #define M_26_61 -35 #define M_26_62 -36 #define M_26_63 -37 #define M_26_64 -38 #define M_27_1 26 #define M_27_2 25 #define M_27_3 24 #define M_27_4 23 #define M_27_5 22 #define M_27_6 21 #define M_27_7 20 #define M_27_8 19 #define M_27_9 18 #define M_27_10 17 #define M_27_11 16 #define M_27_12 15 #define M_27_13 14 #define M_27_14 13 #define M_27_15 12 #define M_27_16 11 #define M_27_17 10 #define M_27_18 9 #define M_27_19 8 #define M_27_20 7 #define M_27_21 6 #define M_27_22 5 #define M_27_23 4 #define M_27_24 3 #define M_27_25 2 #define M_27_26 1 #define M_27_27 0 #define M_27_28 -1 #define M_27_29 -2 #define M_27_30 -3 #define M_27_31 -4 #define M_27_32 -5 #define M_27_33 -6 #define M_27_34 -7 #define M_27_35 -8 #define M_27_36 -9 #define M_27_37 -10 #define M_27_38 -11 #define M_27_39 -12 #define M_27_40 -13 #define M_27_41 -14 #define M_27_42 -15 #define M_27_43 -16 #define M_27_44 -17 #define M_27_45 -18 #define M_27_46 -19 #define M_27_47 -20 #define M_27_48 -21 #define M_27_49 -22 #define M_27_50 -23 #define M_27_51 -24 #define M_27_52 -25 #define M_27_53 -26 #define M_27_54 -27 #define M_27_55 -28 #define M_27_56 -29 #define M_27_57 -30 #define M_27_58 -31 #define M_27_59 -32 #define M_27_60 -33 #define M_27_61 -34 #define M_27_62 -35 #define M_27_63 -36 #define M_27_64 -37 #define M_28_1 27 #define M_28_2 26 #define M_28_3 25 #define M_28_4 24 #define M_28_5 23 #define M_28_6 22 #define M_28_7 21 #define M_28_8 20 #define M_28_9 19 #define M_28_10 18 #define M_28_11 17 #define M_28_12 16 #define M_28_13 15 #define M_28_14 14 #define M_28_15 13 #define M_28_16 12 #define M_28_17 11 #define M_28_18 10 #define M_28_19 9 #define M_28_20 8 #define M_28_21 7 #define M_28_22 6 #define M_28_23 5 #define M_28_24 4 #define M_28_25 3 #define M_28_26 2 #define M_28_27 1 #define M_28_28 0 #define M_28_29 -1 #define M_28_30 -2 #define M_28_31 -3 #define M_28_32 -4 #define M_28_33 -5 #define M_28_34 -6 #define M_28_35 -7 #define M_28_36 -8 #define M_28_37 -9 #define M_28_38 -10 #define M_28_39 -11 #define M_28_40 -12 #define M_28_41 -13 #define M_28_42 -14 #define M_28_43 -15 #define M_28_44 -16 #define M_28_45 -17 #define M_28_46 -18 #define M_28_47 -19 #define M_28_48 -20 #define M_28_49 -21 #define M_28_50 -22 #define M_28_51 -23 #define M_28_52 -24 #define M_28_53 -25 #define M_28_54 -26 #define M_28_55 -27 #define M_28_56 -28 #define M_28_57 -29 #define M_28_58 -30 #define M_28_59 -31 #define M_28_60 -32 #define M_28_61 -33 #define M_28_62 -34 #define M_28_63 -35 #define M_28_64 -36 #define M_29_1 28 #define M_29_2 27 #define M_29_3 26 #define M_29_4 25 #define M_29_5 24 #define M_29_6 23 #define M_29_7 22 #define M_29_8 21 #define M_29_9 20 #define M_29_10 19 #define M_29_11 18 #define M_29_12 17 #define M_29_13 16 #define M_29_14 15 #define M_29_15 14 #define M_29_16 13 #define M_29_17 12 #define M_29_18 11 #define M_29_19 10 #define M_29_20 9 #define M_29_21 8 #define M_29_22 7 #define M_29_23 6 #define M_29_24 5 #define M_29_25 4 #define M_29_26 3 #define M_29_27 2 #define M_29_28 1 #define M_29_29 0 #define M_29_30 -1 #define M_29_31 -2 #define M_29_32 -3 #define M_29_33 -4 #define M_29_34 -5 #define M_29_35 -6 #define M_29_36 -7 #define M_29_37 -8 #define M_29_38 -9 #define M_29_39 -10 #define M_29_40 -11 #define M_29_41 -12 #define M_29_42 -13 #define M_29_43 -14 #define M_29_44 -15 #define M_29_45 -16 #define M_29_46 -17 #define M_29_47 -18 #define M_29_48 -19 #define M_29_49 -20 #define M_29_50 -21 #define M_29_51 -22 #define M_29_52 -23 #define M_29_53 -24 #define M_29_54 -25 #define M_29_55 -26 #define M_29_56 -27 #define M_29_57 -28 #define M_29_58 -29 #define M_29_59 -30 #define M_29_60 -31 #define M_29_61 -32 #define M_29_62 -33 #define M_29_63 -34 #define M_29_64 -35 #define M_30_1 29 #define M_30_2 28 #define M_30_3 27 #define M_30_4 26 #define M_30_5 25 #define M_30_6 24 #define M_30_7 23 #define M_30_8 22 #define M_30_9 21 #define M_30_10 20 #define M_30_11 19 #define M_30_12 18 #define M_30_13 17 #define M_30_14 16 #define M_30_15 15 #define M_30_16 14 #define M_30_17 13 #define M_30_18 12 #define M_30_19 11 #define M_30_20 10 #define M_30_21 9 #define M_30_22 8 #define M_30_23 7 #define M_30_24 6 #define M_30_25 5 #define M_30_26 4 #define M_30_27 3 #define M_30_28 2 #define M_30_29 1 #define M_30_30 0 #define M_30_31 -1 #define M_30_32 -2 #define M_30_33 -3 #define M_30_34 -4 #define M_30_35 -5 #define M_30_36 -6 #define M_30_37 -7 #define M_30_38 -8 #define M_30_39 -9 #define M_30_40 -10 #define M_30_41 -11 #define M_30_42 -12 #define M_30_43 -13 #define M_30_44 -14 #define M_30_45 -15 #define M_30_46 -16 #define M_30_47 -17 #define M_30_48 -18 #define M_30_49 -19 #define M_30_50 -20 #define M_30_51 -21 #define M_30_52 -22 #define M_30_53 -23 #define M_30_54 -24 #define M_30_55 -25 #define M_30_56 -26 #define M_30_57 -27 #define M_30_58 -28 #define M_30_59 -29 #define M_30_60 -30 #define M_30_61 -31 #define M_30_62 -32 #define M_30_63 -33 #define M_30_64 -34 #define M_31_1 30 #define M_31_2 29 #define M_31_3 28 #define M_31_4 27 #define M_31_5 26 #define M_31_6 25 #define M_31_7 24 #define M_31_8 23 #define M_31_9 22 #define M_31_10 21 #define M_31_11 20 #define M_31_12 19 #define M_31_13 18 #define M_31_14 17 #define M_31_15 16 #define M_31_16 15 #define M_31_17 14 #define M_31_18 13 #define M_31_19 12 #define M_31_20 11 #define M_31_21 10 #define M_31_22 9 #define M_31_23 8 #define M_31_24 7 #define M_31_25 6 #define M_31_26 5 #define M_31_27 4 #define M_31_28 3 #define M_31_29 2 #define M_31_30 1 #define M_31_31 0 #define M_31_32 -1 #define M_31_33 -2 #define M_31_34 -3 #define M_31_35 -4 #define M_31_36 -5 #define M_31_37 -6 #define M_31_38 -7 #define M_31_39 -8 #define M_31_40 -9 #define M_31_41 -10 #define M_31_42 -11 #define M_31_43 -12 #define M_31_44 -13 #define M_31_45 -14 #define M_31_46 -15 #define M_31_47 -16 #define M_31_48 -17 #define M_31_49 -18 #define M_31_50 -19 #define M_31_51 -20 #define M_31_52 -21 #define M_31_53 -22 #define M_31_54 -23 #define M_31_55 -24 #define M_31_56 -25 #define M_31_57 -26 #define M_31_58 -27 #define M_31_59 -28 #define M_31_60 -29 #define M_31_61 -30 #define M_31_62 -31 #define M_31_63 -32 #define M_31_64 -33 #define M_32_1 31 #define M_32_2 30 #define M_32_3 29 #define M_32_4 28 #define M_32_5 27 #define M_32_6 26 #define M_32_7 25 #define M_32_8 24 #define M_32_9 23 #define M_32_10 22 #define M_32_11 21 #define M_32_12 20 #define M_32_13 19 #define M_32_14 18 #define M_32_15 17 #define M_32_16 16 #define M_32_17 15 #define M_32_18 14 #define M_32_19 13 #define M_32_20 12 #define M_32_21 11 #define M_32_22 10 #define M_32_23 9 #define M_32_24 8 #define M_32_25 7 #define M_32_26 6 #define M_32_27 5 #define M_32_28 4 #define M_32_29 3 #define M_32_30 2 #define M_32_31 1 #define M_32_32 0 #define M_32_33 -1 #define M_32_34 -2 #define M_32_35 -3 #define M_32_36 -4 #define M_32_37 -5 #define M_32_38 -6 #define M_32_39 -7 #define M_32_40 -8 #define M_32_41 -9 #define M_32_42 -10 #define M_32_43 -11 #define M_32_44 -12 #define M_32_45 -13 #define M_32_46 -14 #define M_32_47 -15 #define M_32_48 -16 #define M_32_49 -17 #define M_32_50 -18 #define M_32_51 -19 #define M_32_52 -20 #define M_32_53 -21 #define M_32_54 -22 #define M_32_55 -23 #define M_32_56 -24 #define M_32_57 -25 #define M_32_58 -26 #define M_32_59 -27 #define M_32_60 -28 #define M_32_61 -29 #define M_32_62 -30 #define M_32_63 -31 #define M_32_64 -32 #define M_33_1 32 #define M_33_2 31 #define M_33_3 30 #define M_33_4 29 #define M_33_5 28 #define M_33_6 27 #define M_33_7 26 #define M_33_8 25 #define M_33_9 24 #define M_33_10 23 #define M_33_11 22 #define M_33_12 21 #define M_33_13 20 #define M_33_14 19 #define M_33_15 18 #define M_33_16 17 #define M_33_17 16 #define M_33_18 15 #define M_33_19 14 #define M_33_20 13 #define M_33_21 12 #define M_33_22 11 #define M_33_23 10 #define M_33_24 9 #define M_33_25 8 #define M_33_26 7 #define M_33_27 6 #define M_33_28 5 #define M_33_29 4 #define M_33_30 3 #define M_33_31 2 #define M_33_32 1 #define M_33_33 0 #define M_33_34 -1 #define M_33_35 -2 #define M_33_36 -3 #define M_33_37 -4 #define M_33_38 -5 #define M_33_39 -6 #define M_33_40 -7 #define M_33_41 -8 #define M_33_42 -9 #define M_33_43 -10 #define M_33_44 -11 #define M_33_45 -12 #define M_33_46 -13 #define M_33_47 -14 #define M_33_48 -15 #define M_33_49 -16 #define M_33_50 -17 #define M_33_51 -18 #define M_33_52 -19 #define M_33_53 -20 #define M_33_54 -21 #define M_33_55 -22 #define M_33_56 -23 #define M_33_57 -24 #define M_33_58 -25 #define M_33_59 -26 #define M_33_60 -27 #define M_33_61 -28 #define M_33_62 -29 #define M_33_63 -30 #define M_33_64 -31 #define M_34_1 33 #define M_34_2 32 #define M_34_3 31 #define M_34_4 30 #define M_34_5 29 #define M_34_6 28 #define M_34_7 27 #define M_34_8 26 #define M_34_9 25 #define M_34_10 24 #define M_34_11 23 #define M_34_12 22 #define M_34_13 21 #define M_34_14 20 #define M_34_15 19 #define M_34_16 18 #define M_34_17 17 #define M_34_18 16 #define M_34_19 15 #define M_34_20 14 #define M_34_21 13 #define M_34_22 12 #define M_34_23 11 #define M_34_24 10 #define M_34_25 9 #define M_34_26 8 #define M_34_27 7 #define M_34_28 6 #define M_34_29 5 #define M_34_30 4 #define M_34_31 3 #define M_34_32 2 #define M_34_33 1 #define M_34_34 0 #define M_34_35 -1 #define M_34_36 -2 #define M_34_37 -3 #define M_34_38 -4 #define M_34_39 -5 #define M_34_40 -6 #define M_34_41 -7 #define M_34_42 -8 #define M_34_43 -9 #define M_34_44 -10 #define M_34_45 -11 #define M_34_46 -12 #define M_34_47 -13 #define M_34_48 -14 #define M_34_49 -15 #define M_34_50 -16 #define M_34_51 -17 #define M_34_52 -18 #define M_34_53 -19 #define M_34_54 -20 #define M_34_55 -21 #define M_34_56 -22 #define M_34_57 -23 #define M_34_58 -24 #define M_34_59 -25 #define M_34_60 -26 #define M_34_61 -27 #define M_34_62 -28 #define M_34_63 -29 #define M_34_64 -30 #define M_35_1 34 #define M_35_2 33 #define M_35_3 32 #define M_35_4 31 #define M_35_5 30 #define M_35_6 29 #define M_35_7 28 #define M_35_8 27 #define M_35_9 26 #define M_35_10 25 #define M_35_11 24 #define M_35_12 23 #define M_35_13 22 #define M_35_14 21 #define M_35_15 20 #define M_35_16 19 #define M_35_17 18 #define M_35_18 17 #define M_35_19 16 #define M_35_20 15 #define M_35_21 14 #define M_35_22 13 #define M_35_23 12 #define M_35_24 11 #define M_35_25 10 #define M_35_26 9 #define M_35_27 8 #define M_35_28 7 #define M_35_29 6 #define M_35_30 5 #define M_35_31 4 #define M_35_32 3 #define M_35_33 2 #define M_35_34 1 #define M_35_35 0 #define M_35_36 -1 #define M_35_37 -2 #define M_35_38 -3 #define M_35_39 -4 #define M_35_40 -5 #define M_35_41 -6 #define M_35_42 -7 #define M_35_43 -8 #define M_35_44 -9 #define M_35_45 -10 #define M_35_46 -11 #define M_35_47 -12 #define M_35_48 -13 #define M_35_49 -14 #define M_35_50 -15 #define M_35_51 -16 #define M_35_52 -17 #define M_35_53 -18 #define M_35_54 -19 #define M_35_55 -20 #define M_35_56 -21 #define M_35_57 -22 #define M_35_58 -23 #define M_35_59 -24 #define M_35_60 -25 #define M_35_61 -26 #define M_35_62 -27 #define M_35_63 -28 #define M_35_64 -29 #define M_36_1 35 #define M_36_2 34 #define M_36_3 33 #define M_36_4 32 #define M_36_5 31 #define M_36_6 30 #define M_36_7 29 #define M_36_8 28 #define M_36_9 27 #define M_36_10 26 #define M_36_11 25 #define M_36_12 24 #define M_36_13 23 #define M_36_14 22 #define M_36_15 21 #define M_36_16 20 #define M_36_17 19 #define M_36_18 18 #define M_36_19 17 #define M_36_20 16 #define M_36_21 15 #define M_36_22 14 #define M_36_23 13 #define M_36_24 12 #define M_36_25 11 #define M_36_26 10 #define M_36_27 9 #define M_36_28 8 #define M_36_29 7 #define M_36_30 6 #define M_36_31 5 #define M_36_32 4 #define M_36_33 3 #define M_36_34 2 #define M_36_35 1 #define M_36_36 0 #define M_36_37 -1 #define M_36_38 -2 #define M_36_39 -3 #define M_36_40 -4 #define M_36_41 -5 #define M_36_42 -6 #define M_36_43 -7 #define M_36_44 -8 #define M_36_45 -9 #define M_36_46 -10 #define M_36_47 -11 #define M_36_48 -12 #define M_36_49 -13 #define M_36_50 -14 #define M_36_51 -15 #define M_36_52 -16 #define M_36_53 -17 #define M_36_54 -18 #define M_36_55 -19 #define M_36_56 -20 #define M_36_57 -21 #define M_36_58 -22 #define M_36_59 -23 #define M_36_60 -24 #define M_36_61 -25 #define M_36_62 -26 #define M_36_63 -27 #define M_36_64 -28 #define M_37_1 36 #define M_37_2 35 #define M_37_3 34 #define M_37_4 33 #define M_37_5 32 #define M_37_6 31 #define M_37_7 30 #define M_37_8 29 #define M_37_9 28 #define M_37_10 27 #define M_37_11 26 #define M_37_12 25 #define M_37_13 24 #define M_37_14 23 #define M_37_15 22 #define M_37_16 21 #define M_37_17 20 #define M_37_18 19 #define M_37_19 18 #define M_37_20 17 #define M_37_21 16 #define M_37_22 15 #define M_37_23 14 #define M_37_24 13 #define M_37_25 12 #define M_37_26 11 #define M_37_27 10 #define M_37_28 9 #define M_37_29 8 #define M_37_30 7 #define M_37_31 6 #define M_37_32 5 #define M_37_33 4 #define M_37_34 3 #define M_37_35 2 #define M_37_36 1 #define M_37_37 0 #define M_37_38 -1 #define M_37_39 -2 #define M_37_40 -3 #define M_37_41 -4 #define M_37_42 -5 #define M_37_43 -6 #define M_37_44 -7 #define M_37_45 -8 #define M_37_46 -9 #define M_37_47 -10 #define M_37_48 -11 #define M_37_49 -12 #define M_37_50 -13 #define M_37_51 -14 #define M_37_52 -15 #define M_37_53 -16 #define M_37_54 -17 #define M_37_55 -18 #define M_37_56 -19 #define M_37_57 -20 #define M_37_58 -21 #define M_37_59 -22 #define M_37_60 -23 #define M_37_61 -24 #define M_37_62 -25 #define M_37_63 -26 #define M_37_64 -27 #define M_38_1 37 #define M_38_2 36 #define M_38_3 35 #define M_38_4 34 #define M_38_5 33 #define M_38_6 32 #define M_38_7 31 #define M_38_8 30 #define M_38_9 29 #define M_38_10 28 #define M_38_11 27 #define M_38_12 26 #define M_38_13 25 #define M_38_14 24 #define M_38_15 23 #define M_38_16 22 #define M_38_17 21 #define M_38_18 20 #define M_38_19 19 #define M_38_20 18 #define M_38_21 17 #define M_38_22 16 #define M_38_23 15 #define M_38_24 14 #define M_38_25 13 #define M_38_26 12 #define M_38_27 11 #define M_38_28 10 #define M_38_29 9 #define M_38_30 8 #define M_38_31 7 #define M_38_32 6 #define M_38_33 5 #define M_38_34 4 #define M_38_35 3 #define M_38_36 2 #define M_38_37 1 #define M_38_38 0 #define M_38_39 -1 #define M_38_40 -2 #define M_38_41 -3 #define M_38_42 -4 #define M_38_43 -5 #define M_38_44 -6 #define M_38_45 -7 #define M_38_46 -8 #define M_38_47 -9 #define M_38_48 -10 #define M_38_49 -11 #define M_38_50 -12 #define M_38_51 -13 #define M_38_52 -14 #define M_38_53 -15 #define M_38_54 -16 #define M_38_55 -17 #define M_38_56 -18 #define M_38_57 -19 #define M_38_58 -20 #define M_38_59 -21 #define M_38_60 -22 #define M_38_61 -23 #define M_38_62 -24 #define M_38_63 -25 #define M_38_64 -26 #define M_39_1 38 #define M_39_2 37 #define M_39_3 36 #define M_39_4 35 #define M_39_5 34 #define M_39_6 33 #define M_39_7 32 #define M_39_8 31 #define M_39_9 30 #define M_39_10 29 #define M_39_11 28 #define M_39_12 27 #define M_39_13 26 #define M_39_14 25 #define M_39_15 24 #define M_39_16 23 #define M_39_17 22 #define M_39_18 21 #define M_39_19 20 #define M_39_20 19 #define M_39_21 18 #define M_39_22 17 #define M_39_23 16 #define M_39_24 15 #define M_39_25 14 #define M_39_26 13 #define M_39_27 12 #define M_39_28 11 #define M_39_29 10 #define M_39_30 9 #define M_39_31 8 #define M_39_32 7 #define M_39_33 6 #define M_39_34 5 #define M_39_35 4 #define M_39_36 3 #define M_39_37 2 #define M_39_38 1 #define M_39_39 0 #define M_39_40 -1 #define M_39_41 -2 #define M_39_42 -3 #define M_39_43 -4 #define M_39_44 -5 #define M_39_45 -6 #define M_39_46 -7 #define M_39_47 -8 #define M_39_48 -9 #define M_39_49 -10 #define M_39_50 -11 #define M_39_51 -12 #define M_39_52 -13 #define M_39_53 -14 #define M_39_54 -15 #define M_39_55 -16 #define M_39_56 -17 #define M_39_57 -18 #define M_39_58 -19 #define M_39_59 -20 #define M_39_60 -21 #define M_39_61 -22 #define M_39_62 -23 #define M_39_63 -24 #define M_39_64 -25 #define M_40_1 39 #define M_40_2 38 #define M_40_3 37 #define M_40_4 36 #define M_40_5 35 #define M_40_6 34 #define M_40_7 33 #define M_40_8 32 #define M_40_9 31 #define M_40_10 30 #define M_40_11 29 #define M_40_12 28 #define M_40_13 27 #define M_40_14 26 #define M_40_15 25 #define M_40_16 24 #define M_40_17 23 #define M_40_18 22 #define M_40_19 21 #define M_40_20 20 #define M_40_21 19 #define M_40_22 18 #define M_40_23 17 #define M_40_24 16 #define M_40_25 15 #define M_40_26 14 #define M_40_27 13 #define M_40_28 12 #define M_40_29 11 #define M_40_30 10 #define M_40_31 9 #define M_40_32 8 #define M_40_33 7 #define M_40_34 6 #define M_40_35 5 #define M_40_36 4 #define M_40_37 3 #define M_40_38 2 #define M_40_39 1 #define M_40_40 0 #define M_40_41 -1 #define M_40_42 -2 #define M_40_43 -3 #define M_40_44 -4 #define M_40_45 -5 #define M_40_46 -6 #define M_40_47 -7 #define M_40_48 -8 #define M_40_49 -9 #define M_40_50 -10 #define M_40_51 -11 #define M_40_52 -12 #define M_40_53 -13 #define M_40_54 -14 #define M_40_55 -15 #define M_40_56 -16 #define M_40_57 -17 #define M_40_58 -18 #define M_40_59 -19 #define M_40_60 -20 #define M_40_61 -21 #define M_40_62 -22 #define M_40_63 -23 #define M_40_64 -24 #define M_41_1 40 #define M_41_2 39 #define M_41_3 38 #define M_41_4 37 #define M_41_5 36 #define M_41_6 35 #define M_41_7 34 #define M_41_8 33 #define M_41_9 32 #define M_41_10 31 #define M_41_11 30 #define M_41_12 29 #define M_41_13 28 #define M_41_14 27 #define M_41_15 26 #define M_41_16 25 #define M_41_17 24 #define M_41_18 23 #define M_41_19 22 #define M_41_20 21 #define M_41_21 20 #define M_41_22 19 #define M_41_23 18 #define M_41_24 17 #define M_41_25 16 #define M_41_26 15 #define M_41_27 14 #define M_41_28 13 #define M_41_29 12 #define M_41_30 11 #define M_41_31 10 #define M_41_32 9 #define M_41_33 8 #define M_41_34 7 #define M_41_35 6 #define M_41_36 5 #define M_41_37 4 #define M_41_38 3 #define M_41_39 2 #define M_41_40 1 #define M_41_41 0 #define M_41_42 -1 #define M_41_43 -2 #define M_41_44 -3 #define M_41_45 -4 #define M_41_46 -5 #define M_41_47 -6 #define M_41_48 -7 #define M_41_49 -8 #define M_41_50 -9 #define M_41_51 -10 #define M_41_52 -11 #define M_41_53 -12 #define M_41_54 -13 #define M_41_55 -14 #define M_41_56 -15 #define M_41_57 -16 #define M_41_58 -17 #define M_41_59 -18 #define M_41_60 -19 #define M_41_61 -20 #define M_41_62 -21 #define M_41_63 -22 #define M_41_64 -23 #define M_42_1 41 #define M_42_2 40 #define M_42_3 39 #define M_42_4 38 #define M_42_5 37 #define M_42_6 36 #define M_42_7 35 #define M_42_8 34 #define M_42_9 33 #define M_42_10 32 #define M_42_11 31 #define M_42_12 30 #define M_42_13 29 #define M_42_14 28 #define M_42_15 27 #define M_42_16 26 #define M_42_17 25 #define M_42_18 24 #define M_42_19 23 #define M_42_20 22 #define M_42_21 21 #define M_42_22 20 #define M_42_23 19 #define M_42_24 18 #define M_42_25 17 #define M_42_26 16 #define M_42_27 15 #define M_42_28 14 #define M_42_29 13 #define M_42_30 12 #define M_42_31 11 #define M_42_32 10 #define M_42_33 9 #define M_42_34 8 #define M_42_35 7 #define M_42_36 6 #define M_42_37 5 #define M_42_38 4 #define M_42_39 3 #define M_42_40 2 #define M_42_41 1 #define M_42_42 0 #define M_42_43 -1 #define M_42_44 -2 #define M_42_45 -3 #define M_42_46 -4 #define M_42_47 -5 #define M_42_48 -6 #define M_42_49 -7 #define M_42_50 -8 #define M_42_51 -9 #define M_42_52 -10 #define M_42_53 -11 #define M_42_54 -12 #define M_42_55 -13 #define M_42_56 -14 #define M_42_57 -15 #define M_42_58 -16 #define M_42_59 -17 #define M_42_60 -18 #define M_42_61 -19 #define M_42_62 -20 #define M_42_63 -21 #define M_42_64 -22 #define M_43_1 42 #define M_43_2 41 #define M_43_3 40 #define M_43_4 39 #define M_43_5 38 #define M_43_6 37 #define M_43_7 36 #define M_43_8 35 #define M_43_9 34 #define M_43_10 33 #define M_43_11 32 #define M_43_12 31 #define M_43_13 30 #define M_43_14 29 #define M_43_15 28 #define M_43_16 27 #define M_43_17 26 #define M_43_18 25 #define M_43_19 24 #define M_43_20 23 #define M_43_21 22 #define M_43_22 21 #define M_43_23 20 #define M_43_24 19 #define M_43_25 18 #define M_43_26 17 #define M_43_27 16 #define M_43_28 15 #define M_43_29 14 #define M_43_30 13 #define M_43_31 12 #define M_43_32 11 #define M_43_33 10 #define M_43_34 9 #define M_43_35 8 #define M_43_36 7 #define M_43_37 6 #define M_43_38 5 #define M_43_39 4 #define M_43_40 3 #define M_43_41 2 #define M_43_42 1 #define M_43_43 0 #define M_43_44 -1 #define M_43_45 -2 #define M_43_46 -3 #define M_43_47 -4 #define M_43_48 -5 #define M_43_49 -6 #define M_43_50 -7 #define M_43_51 -8 #define M_43_52 -9 #define M_43_53 -10 #define M_43_54 -11 #define M_43_55 -12 #define M_43_56 -13 #define M_43_57 -14 #define M_43_58 -15 #define M_43_59 -16 #define M_43_60 -17 #define M_43_61 -18 #define M_43_62 -19 #define M_43_63 -20 #define M_43_64 -21 #define M_44_1 43 #define M_44_2 42 #define M_44_3 41 #define M_44_4 40 #define M_44_5 39 #define M_44_6 38 #define M_44_7 37 #define M_44_8 36 #define M_44_9 35 #define M_44_10 34 #define M_44_11 33 #define M_44_12 32 #define M_44_13 31 #define M_44_14 30 #define M_44_15 29 #define M_44_16 28 #define M_44_17 27 #define M_44_18 26 #define M_44_19 25 #define M_44_20 24 #define M_44_21 23 #define M_44_22 22 #define M_44_23 21 #define M_44_24 20 #define M_44_25 19 #define M_44_26 18 #define M_44_27 17 #define M_44_28 16 #define M_44_29 15 #define M_44_30 14 #define M_44_31 13 #define M_44_32 12 #define M_44_33 11 #define M_44_34 10 #define M_44_35 9 #define M_44_36 8 #define M_44_37 7 #define M_44_38 6 #define M_44_39 5 #define M_44_40 4 #define M_44_41 3 #define M_44_42 2 #define M_44_43 1 #define M_44_44 0 #define M_44_45 -1 #define M_44_46 -2 #define M_44_47 -3 #define M_44_48 -4 #define M_44_49 -5 #define M_44_50 -6 #define M_44_51 -7 #define M_44_52 -8 #define M_44_53 -9 #define M_44_54 -10 #define M_44_55 -11 #define M_44_56 -12 #define M_44_57 -13 #define M_44_58 -14 #define M_44_59 -15 #define M_44_60 -16 #define M_44_61 -17 #define M_44_62 -18 #define M_44_63 -19 #define M_44_64 -20 #define M_45_1 44 #define M_45_2 43 #define M_45_3 42 #define M_45_4 41 #define M_45_5 40 #define M_45_6 39 #define M_45_7 38 #define M_45_8 37 #define M_45_9 36 #define M_45_10 35 #define M_45_11 34 #define M_45_12 33 #define M_45_13 32 #define M_45_14 31 #define M_45_15 30 #define M_45_16 29 #define M_45_17 28 #define M_45_18 27 #define M_45_19 26 #define M_45_20 25 #define M_45_21 24 #define M_45_22 23 #define M_45_23 22 #define M_45_24 21 #define M_45_25 20 #define M_45_26 19 #define M_45_27 18 #define M_45_28 17 #define M_45_29 16 #define M_45_30 15 #define M_45_31 14 #define M_45_32 13 #define M_45_33 12 #define M_45_34 11 #define M_45_35 10 #define M_45_36 9 #define M_45_37 8 #define M_45_38 7 #define M_45_39 6 #define M_45_40 5 #define M_45_41 4 #define M_45_42 3 #define M_45_43 2 #define M_45_44 1 #define M_45_45 0 #define M_45_46 -1 #define M_45_47 -2 #define M_45_48 -3 #define M_45_49 -4 #define M_45_50 -5 #define M_45_51 -6 #define M_45_52 -7 #define M_45_53 -8 #define M_45_54 -9 #define M_45_55 -10 #define M_45_56 -11 #define M_45_57 -12 #define M_45_58 -13 #define M_45_59 -14 #define M_45_60 -15 #define M_45_61 -16 #define M_45_62 -17 #define M_45_63 -18 #define M_45_64 -19 #define M_46_1 45 #define M_46_2 44 #define M_46_3 43 #define M_46_4 42 #define M_46_5 41 #define M_46_6 40 #define M_46_7 39 #define M_46_8 38 #define M_46_9 37 #define M_46_10 36 #define M_46_11 35 #define M_46_12 34 #define M_46_13 33 #define M_46_14 32 #define M_46_15 31 #define M_46_16 30 #define M_46_17 29 #define M_46_18 28 #define M_46_19 27 #define M_46_20 26 #define M_46_21 25 #define M_46_22 24 #define M_46_23 23 #define M_46_24 22 #define M_46_25 21 #define M_46_26 20 #define M_46_27 19 #define M_46_28 18 #define M_46_29 17 #define M_46_30 16 #define M_46_31 15 #define M_46_32 14 #define M_46_33 13 #define M_46_34 12 #define M_46_35 11 #define M_46_36 10 #define M_46_37 9 #define M_46_38 8 #define M_46_39 7 #define M_46_40 6 #define M_46_41 5 #define M_46_42 4 #define M_46_43 3 #define M_46_44 2 #define M_46_45 1 #define M_46_46 0 #define M_46_47 -1 #define M_46_48 -2 #define M_46_49 -3 #define M_46_50 -4 #define M_46_51 -5 #define M_46_52 -6 #define M_46_53 -7 #define M_46_54 -8 #define M_46_55 -9 #define M_46_56 -10 #define M_46_57 -11 #define M_46_58 -12 #define M_46_59 -13 #define M_46_60 -14 #define M_46_61 -15 #define M_46_62 -16 #define M_46_63 -17 #define M_46_64 -18 #define M_47_1 46 #define M_47_2 45 #define M_47_3 44 #define M_47_4 43 #define M_47_5 42 #define M_47_6 41 #define M_47_7 40 #define M_47_8 39 #define M_47_9 38 #define M_47_10 37 #define M_47_11 36 #define M_47_12 35 #define M_47_13 34 #define M_47_14 33 #define M_47_15 32 #define M_47_16 31 #define M_47_17 30 #define M_47_18 29 #define M_47_19 28 #define M_47_20 27 #define M_47_21 26 #define M_47_22 25 #define M_47_23 24 #define M_47_24 23 #define M_47_25 22 #define M_47_26 21 #define M_47_27 20 #define M_47_28 19 #define M_47_29 18 #define M_47_30 17 #define M_47_31 16 #define M_47_32 15 #define M_47_33 14 #define M_47_34 13 #define M_47_35 12 #define M_47_36 11 #define M_47_37 10 #define M_47_38 9 #define M_47_39 8 #define M_47_40 7 #define M_47_41 6 #define M_47_42 5 #define M_47_43 4 #define M_47_44 3 #define M_47_45 2 #define M_47_46 1 #define M_47_47 0 #define M_47_48 -1 #define M_47_49 -2 #define M_47_50 -3 #define M_47_51 -4 #define M_47_52 -5 #define M_47_53 -6 #define M_47_54 -7 #define M_47_55 -8 #define M_47_56 -9 #define M_47_57 -10 #define M_47_58 -11 #define M_47_59 -12 #define M_47_60 -13 #define M_47_61 -14 #define M_47_62 -15 #define M_47_63 -16 #define M_47_64 -17 #define M_48_1 47 #define M_48_2 46 #define M_48_3 45 #define M_48_4 44 #define M_48_5 43 #define M_48_6 42 #define M_48_7 41 #define M_48_8 40 #define M_48_9 39 #define M_48_10 38 #define M_48_11 37 #define M_48_12 36 #define M_48_13 35 #define M_48_14 34 #define M_48_15 33 #define M_48_16 32 #define M_48_17 31 #define M_48_18 30 #define M_48_19 29 #define M_48_20 28 #define M_48_21 27 #define M_48_22 26 #define M_48_23 25 #define M_48_24 24 #define M_48_25 23 #define M_48_26 22 #define M_48_27 21 #define M_48_28 20 #define M_48_29 19 #define M_48_30 18 #define M_48_31 17 #define M_48_32 16 #define M_48_33 15 #define M_48_34 14 #define M_48_35 13 #define M_48_36 12 #define M_48_37 11 #define M_48_38 10 #define M_48_39 9 #define M_48_40 8 #define M_48_41 7 #define M_48_42 6 #define M_48_43 5 #define M_48_44 4 #define M_48_45 3 #define M_48_46 2 #define M_48_47 1 #define M_48_48 0 #define M_48_49 -1 #define M_48_50 -2 #define M_48_51 -3 #define M_48_52 -4 #define M_48_53 -5 #define M_48_54 -6 #define M_48_55 -7 #define M_48_56 -8 #define M_48_57 -9 #define M_48_58 -10 #define M_48_59 -11 #define M_48_60 -12 #define M_48_61 -13 #define M_48_62 -14 #define M_48_63 -15 #define M_48_64 -16 #define M_49_1 48 #define M_49_2 47 #define M_49_3 46 #define M_49_4 45 #define M_49_5 44 #define M_49_6 43 #define M_49_7 42 #define M_49_8 41 #define M_49_9 40 #define M_49_10 39 #define M_49_11 38 #define M_49_12 37 #define M_49_13 36 #define M_49_14 35 #define M_49_15 34 #define M_49_16 33 #define M_49_17 32 #define M_49_18 31 #define M_49_19 30 #define M_49_20 29 #define M_49_21 28 #define M_49_22 27 #define M_49_23 26 #define M_49_24 25 #define M_49_25 24 #define M_49_26 23 #define M_49_27 22 #define M_49_28 21 #define M_49_29 20 #define M_49_30 19 #define M_49_31 18 #define M_49_32 17 #define M_49_33 16 #define M_49_34 15 #define M_49_35 14 #define M_49_36 13 #define M_49_37 12 #define M_49_38 11 #define M_49_39 10 #define M_49_40 9 #define M_49_41 8 #define M_49_42 7 #define M_49_43 6 #define M_49_44 5 #define M_49_45 4 #define M_49_46 3 #define M_49_47 2 #define M_49_48 1 #define M_49_49 0 #define M_49_50 -1 #define M_49_51 -2 #define M_49_52 -3 #define M_49_53 -4 #define M_49_54 -5 #define M_49_55 -6 #define M_49_56 -7 #define M_49_57 -8 #define M_49_58 -9 #define M_49_59 -10 #define M_49_60 -11 #define M_49_61 -12 #define M_49_62 -13 #define M_49_63 -14 #define M_49_64 -15 #define M_50_1 49 #define M_50_2 48 #define M_50_3 47 #define M_50_4 46 #define M_50_5 45 #define M_50_6 44 #define M_50_7 43 #define M_50_8 42 #define M_50_9 41 #define M_50_10 40 #define M_50_11 39 #define M_50_12 38 #define M_50_13 37 #define M_50_14 36 #define M_50_15 35 #define M_50_16 34 #define M_50_17 33 #define M_50_18 32 #define M_50_19 31 #define M_50_20 30 #define M_50_21 29 #define M_50_22 28 #define M_50_23 27 #define M_50_24 26 #define M_50_25 25 #define M_50_26 24 #define M_50_27 23 #define M_50_28 22 #define M_50_29 21 #define M_50_30 20 #define M_50_31 19 #define M_50_32 18 #define M_50_33 17 #define M_50_34 16 #define M_50_35 15 #define M_50_36 14 #define M_50_37 13 #define M_50_38 12 #define M_50_39 11 #define M_50_40 10 #define M_50_41 9 #define M_50_42 8 #define M_50_43 7 #define M_50_44 6 #define M_50_45 5 #define M_50_46 4 #define M_50_47 3 #define M_50_48 2 #define M_50_49 1 #define M_50_50 0 #define M_50_51 -1 #define M_50_52 -2 #define M_50_53 -3 #define M_50_54 -4 #define M_50_55 -5 #define M_50_56 -6 #define M_50_57 -7 #define M_50_58 -8 #define M_50_59 -9 #define M_50_60 -10 #define M_50_61 -11 #define M_50_62 -12 #define M_50_63 -13 #define M_50_64 -14 #define M_51_1 50 #define M_51_2 49 #define M_51_3 48 #define M_51_4 47 #define M_51_5 46 #define M_51_6 45 #define M_51_7 44 #define M_51_8 43 #define M_51_9 42 #define M_51_10 41 #define M_51_11 40 #define M_51_12 39 #define M_51_13 38 #define M_51_14 37 #define M_51_15 36 #define M_51_16 35 #define M_51_17 34 #define M_51_18 33 #define M_51_19 32 #define M_51_20 31 #define M_51_21 30 #define M_51_22 29 #define M_51_23 28 #define M_51_24 27 #define M_51_25 26 #define M_51_26 25 #define M_51_27 24 #define M_51_28 23 #define M_51_29 22 #define M_51_30 21 #define M_51_31 20 #define M_51_32 19 #define M_51_33 18 #define M_51_34 17 #define M_51_35 16 #define M_51_36 15 #define M_51_37 14 #define M_51_38 13 #define M_51_39 12 #define M_51_40 11 #define M_51_41 10 #define M_51_42 9 #define M_51_43 8 #define M_51_44 7 #define M_51_45 6 #define M_51_46 5 #define M_51_47 4 #define M_51_48 3 #define M_51_49 2 #define M_51_50 1 #define M_51_51 0 #define M_51_52 -1 #define M_51_53 -2 #define M_51_54 -3 #define M_51_55 -4 #define M_51_56 -5 #define M_51_57 -6 #define M_51_58 -7 #define M_51_59 -8 #define M_51_60 -9 #define M_51_61 -10 #define M_51_62 -11 #define M_51_63 -12 #define M_51_64 -13 #define M_52_1 51 #define M_52_2 50 #define M_52_3 49 #define M_52_4 48 #define M_52_5 47 #define M_52_6 46 #define M_52_7 45 #define M_52_8 44 #define M_52_9 43 #define M_52_10 42 #define M_52_11 41 #define M_52_12 40 #define M_52_13 39 #define M_52_14 38 #define M_52_15 37 #define M_52_16 36 #define M_52_17 35 #define M_52_18 34 #define M_52_19 33 #define M_52_20 32 #define M_52_21 31 #define M_52_22 30 #define M_52_23 29 #define M_52_24 28 #define M_52_25 27 #define M_52_26 26 #define M_52_27 25 #define M_52_28 24 #define M_52_29 23 #define M_52_30 22 #define M_52_31 21 #define M_52_32 20 #define M_52_33 19 #define M_52_34 18 #define M_52_35 17 #define M_52_36 16 #define M_52_37 15 #define M_52_38 14 #define M_52_39 13 #define M_52_40 12 #define M_52_41 11 #define M_52_42 10 #define M_52_43 9 #define M_52_44 8 #define M_52_45 7 #define M_52_46 6 #define M_52_47 5 #define M_52_48 4 #define M_52_49 3 #define M_52_50 2 #define M_52_51 1 #define M_52_52 0 #define M_52_53 -1 #define M_52_54 -2 #define M_52_55 -3 #define M_52_56 -4 #define M_52_57 -5 #define M_52_58 -6 #define M_52_59 -7 #define M_52_60 -8 #define M_52_61 -9 #define M_52_62 -10 #define M_52_63 -11 #define M_52_64 -12 #define M_53_1 52 #define M_53_2 51 #define M_53_3 50 #define M_53_4 49 #define M_53_5 48 #define M_53_6 47 #define M_53_7 46 #define M_53_8 45 #define M_53_9 44 #define M_53_10 43 #define M_53_11 42 #define M_53_12 41 #define M_53_13 40 #define M_53_14 39 #define M_53_15 38 #define M_53_16 37 #define M_53_17 36 #define M_53_18 35 #define M_53_19 34 #define M_53_20 33 #define M_53_21 32 #define M_53_22 31 #define M_53_23 30 #define M_53_24 29 #define M_53_25 28 #define M_53_26 27 #define M_53_27 26 #define M_53_28 25 #define M_53_29 24 #define M_53_30 23 #define M_53_31 22 #define M_53_32 21 #define M_53_33 20 #define M_53_34 19 #define M_53_35 18 #define M_53_36 17 #define M_53_37 16 #define M_53_38 15 #define M_53_39 14 #define M_53_40 13 #define M_53_41 12 #define M_53_42 11 #define M_53_43 10 #define M_53_44 9 #define M_53_45 8 #define M_53_46 7 #define M_53_47 6 #define M_53_48 5 #define M_53_49 4 #define M_53_50 3 #define M_53_51 2 #define M_53_52 1 #define M_53_53 0 #define M_53_54 -1 #define M_53_55 -2 #define M_53_56 -3 #define M_53_57 -4 #define M_53_58 -5 #define M_53_59 -6 #define M_53_60 -7 #define M_53_61 -8 #define M_53_62 -9 #define M_53_63 -10 #define M_53_64 -11 #define M_54_1 53 #define M_54_2 52 #define M_54_3 51 #define M_54_4 50 #define M_54_5 49 #define M_54_6 48 #define M_54_7 47 #define M_54_8 46 #define M_54_9 45 #define M_54_10 44 #define M_54_11 43 #define M_54_12 42 #define M_54_13 41 #define M_54_14 40 #define M_54_15 39 #define M_54_16 38 #define M_54_17 37 #define M_54_18 36 #define M_54_19 35 #define M_54_20 34 #define M_54_21 33 #define M_54_22 32 #define M_54_23 31 #define M_54_24 30 #define M_54_25 29 #define M_54_26 28 #define M_54_27 27 #define M_54_28 26 #define M_54_29 25 #define M_54_30 24 #define M_54_31 23 #define M_54_32 22 #define M_54_33 21 #define M_54_34 20 #define M_54_35 19 #define M_54_36 18 #define M_54_37 17 #define M_54_38 16 #define M_54_39 15 #define M_54_40 14 #define M_54_41 13 #define M_54_42 12 #define M_54_43 11 #define M_54_44 10 #define M_54_45 9 #define M_54_46 8 #define M_54_47 7 #define M_54_48 6 #define M_54_49 5 #define M_54_50 4 #define M_54_51 3 #define M_54_52 2 #define M_54_53 1 #define M_54_54 0 #define M_54_55 -1 #define M_54_56 -2 #define M_54_57 -3 #define M_54_58 -4 #define M_54_59 -5 #define M_54_60 -6 #define M_54_61 -7 #define M_54_62 -8 #define M_54_63 -9 #define M_54_64 -10 #define M_55_1 54 #define M_55_2 53 #define M_55_3 52 #define M_55_4 51 #define M_55_5 50 #define M_55_6 49 #define M_55_7 48 #define M_55_8 47 #define M_55_9 46 #define M_55_10 45 #define M_55_11 44 #define M_55_12 43 #define M_55_13 42 #define M_55_14 41 #define M_55_15 40 #define M_55_16 39 #define M_55_17 38 #define M_55_18 37 #define M_55_19 36 #define M_55_20 35 #define M_55_21 34 #define M_55_22 33 #define M_55_23 32 #define M_55_24 31 #define M_55_25 30 #define M_55_26 29 #define M_55_27 28 #define M_55_28 27 #define M_55_29 26 #define M_55_30 25 #define M_55_31 24 #define M_55_32 23 #define M_55_33 22 #define M_55_34 21 #define M_55_35 20 #define M_55_36 19 #define M_55_37 18 #define M_55_38 17 #define M_55_39 16 #define M_55_40 15 #define M_55_41 14 #define M_55_42 13 #define M_55_43 12 #define M_55_44 11 #define M_55_45 10 #define M_55_46 9 #define M_55_47 8 #define M_55_48 7 #define M_55_49 6 #define M_55_50 5 #define M_55_51 4 #define M_55_52 3 #define M_55_53 2 #define M_55_54 1 #define M_55_55 0 #define M_55_56 -1 #define M_55_57 -2 #define M_55_58 -3 #define M_55_59 -4 #define M_55_60 -5 #define M_55_61 -6 #define M_55_62 -7 #define M_55_63 -8 #define M_55_64 -9 #define M_56_1 55 #define M_56_2 54 #define M_56_3 53 #define M_56_4 52 #define M_56_5 51 #define M_56_6 50 #define M_56_7 49 #define M_56_8 48 #define M_56_9 47 #define M_56_10 46 #define M_56_11 45 #define M_56_12 44 #define M_56_13 43 #define M_56_14 42 #define M_56_15 41 #define M_56_16 40 #define M_56_17 39 #define M_56_18 38 #define M_56_19 37 #define M_56_20 36 #define M_56_21 35 #define M_56_22 34 #define M_56_23 33 #define M_56_24 32 #define M_56_25 31 #define M_56_26 30 #define M_56_27 29 #define M_56_28 28 #define M_56_29 27 #define M_56_30 26 #define M_56_31 25 #define M_56_32 24 #define M_56_33 23 #define M_56_34 22 #define M_56_35 21 #define M_56_36 20 #define M_56_37 19 #define M_56_38 18 #define M_56_39 17 #define M_56_40 16 #define M_56_41 15 #define M_56_42 14 #define M_56_43 13 #define M_56_44 12 #define M_56_45 11 #define M_56_46 10 #define M_56_47 9 #define M_56_48 8 #define M_56_49 7 #define M_56_50 6 #define M_56_51 5 #define M_56_52 4 #define M_56_53 3 #define M_56_54 2 #define M_56_55 1 #define M_56_56 0 #define M_56_57 -1 #define M_56_58 -2 #define M_56_59 -3 #define M_56_60 -4 #define M_56_61 -5 #define M_56_62 -6 #define M_56_63 -7 #define M_56_64 -8 #define M_57_1 56 #define M_57_2 55 #define M_57_3 54 #define M_57_4 53 #define M_57_5 52 #define M_57_6 51 #define M_57_7 50 #define M_57_8 49 #define M_57_9 48 #define M_57_10 47 #define M_57_11 46 #define M_57_12 45 #define M_57_13 44 #define M_57_14 43 #define M_57_15 42 #define M_57_16 41 #define M_57_17 40 #define M_57_18 39 #define M_57_19 38 #define M_57_20 37 #define M_57_21 36 #define M_57_22 35 #define M_57_23 34 #define M_57_24 33 #define M_57_25 32 #define M_57_26 31 #define M_57_27 30 #define M_57_28 29 #define M_57_29 28 #define M_57_30 27 #define M_57_31 26 #define M_57_32 25 #define M_57_33 24 #define M_57_34 23 #define M_57_35 22 #define M_57_36 21 #define M_57_37 20 #define M_57_38 19 #define M_57_39 18 #define M_57_40 17 #define M_57_41 16 #define M_57_42 15 #define M_57_43 14 #define M_57_44 13 #define M_57_45 12 #define M_57_46 11 #define M_57_47 10 #define M_57_48 9 #define M_57_49 8 #define M_57_50 7 #define M_57_51 6 #define M_57_52 5 #define M_57_53 4 #define M_57_54 3 #define M_57_55 2 #define M_57_56 1 #define M_57_57 0 #define M_57_58 -1 #define M_57_59 -2 #define M_57_60 -3 #define M_57_61 -4 #define M_57_62 -5 #define M_57_63 -6 #define M_57_64 -7 #define M_58_1 57 #define M_58_2 56 #define M_58_3 55 #define M_58_4 54 #define M_58_5 53 #define M_58_6 52 #define M_58_7 51 #define M_58_8 50 #define M_58_9 49 #define M_58_10 48 #define M_58_11 47 #define M_58_12 46 #define M_58_13 45 #define M_58_14 44 #define M_58_15 43 #define M_58_16 42 #define M_58_17 41 #define M_58_18 40 #define M_58_19 39 #define M_58_20 38 #define M_58_21 37 #define M_58_22 36 #define M_58_23 35 #define M_58_24 34 #define M_58_25 33 #define M_58_26 32 #define M_58_27 31 #define M_58_28 30 #define M_58_29 29 #define M_58_30 28 #define M_58_31 27 #define M_58_32 26 #define M_58_33 25 #define M_58_34 24 #define M_58_35 23 #define M_58_36 22 #define M_58_37 21 #define M_58_38 20 #define M_58_39 19 #define M_58_40 18 #define M_58_41 17 #define M_58_42 16 #define M_58_43 15 #define M_58_44 14 #define M_58_45 13 #define M_58_46 12 #define M_58_47 11 #define M_58_48 10 #define M_58_49 9 #define M_58_50 8 #define M_58_51 7 #define M_58_52 6 #define M_58_53 5 #define M_58_54 4 #define M_58_55 3 #define M_58_56 2 #define M_58_57 1 #define M_58_58 0 #define M_58_59 -1 #define M_58_60 -2 #define M_58_61 -3 #define M_58_62 -4 #define M_58_63 -5 #define M_58_64 -6 #define M_59_1 58 #define M_59_2 57 #define M_59_3 56 #define M_59_4 55 #define M_59_5 54 #define M_59_6 53 #define M_59_7 52 #define M_59_8 51 #define M_59_9 50 #define M_59_10 49 #define M_59_11 48 #define M_59_12 47 #define M_59_13 46 #define M_59_14 45 #define M_59_15 44 #define M_59_16 43 #define M_59_17 42 #define M_59_18 41 #define M_59_19 40 #define M_59_20 39 #define M_59_21 38 #define M_59_22 37 #define M_59_23 36 #define M_59_24 35 #define M_59_25 34 #define M_59_26 33 #define M_59_27 32 #define M_59_28 31 #define M_59_29 30 #define M_59_30 29 #define M_59_31 28 #define M_59_32 27 #define M_59_33 26 #define M_59_34 25 #define M_59_35 24 #define M_59_36 23 #define M_59_37 22 #define M_59_38 21 #define M_59_39 20 #define M_59_40 19 #define M_59_41 18 #define M_59_42 17 #define M_59_43 16 #define M_59_44 15 #define M_59_45 14 #define M_59_46 13 #define M_59_47 12 #define M_59_48 11 #define M_59_49 10 #define M_59_50 9 #define M_59_51 8 #define M_59_52 7 #define M_59_53 6 #define M_59_54 5 #define M_59_55 4 #define M_59_56 3 #define M_59_57 2 #define M_59_58 1 #define M_59_59 0 #define M_59_60 -1 #define M_59_61 -2 #define M_59_62 -3 #define M_59_63 -4 #define M_59_64 -5 #define M_60_1 59 #define M_60_2 58 #define M_60_3 57 #define M_60_4 56 #define M_60_5 55 #define M_60_6 54 #define M_60_7 53 #define M_60_8 52 #define M_60_9 51 #define M_60_10 50 #define M_60_11 49 #define M_60_12 48 #define M_60_13 47 #define M_60_14 46 #define M_60_15 45 #define M_60_16 44 #define M_60_17 43 #define M_60_18 42 #define M_60_19 41 #define M_60_20 40 #define M_60_21 39 #define M_60_22 38 #define M_60_23 37 #define M_60_24 36 #define M_60_25 35 #define M_60_26 34 #define M_60_27 33 #define M_60_28 32 #define M_60_29 31 #define M_60_30 30 #define M_60_31 29 #define M_60_32 28 #define M_60_33 27 #define M_60_34 26 #define M_60_35 25 #define M_60_36 24 #define M_60_37 23 #define M_60_38 22 #define M_60_39 21 #define M_60_40 20 #define M_60_41 19 #define M_60_42 18 #define M_60_43 17 #define M_60_44 16 #define M_60_45 15 #define M_60_46 14 #define M_60_47 13 #define M_60_48 12 #define M_60_49 11 #define M_60_50 10 #define M_60_51 9 #define M_60_52 8 #define M_60_53 7 #define M_60_54 6 #define M_60_55 5 #define M_60_56 4 #define M_60_57 3 #define M_60_58 2 #define M_60_59 1 #define M_60_60 0 #define M_60_61 -1 #define M_60_62 -2 #define M_60_63 -3 #define M_60_64 -4 #define M_61_1 60 #define M_61_2 59 #define M_61_3 58 #define M_61_4 57 #define M_61_5 56 #define M_61_6 55 #define M_61_7 54 #define M_61_8 53 #define M_61_9 52 #define M_61_10 51 #define M_61_11 50 #define M_61_12 49 #define M_61_13 48 #define M_61_14 47 #define M_61_15 46 #define M_61_16 45 #define M_61_17 44 #define M_61_18 43 #define M_61_19 42 #define M_61_20 41 #define M_61_21 40 #define M_61_22 39 #define M_61_23 38 #define M_61_24 37 #define M_61_25 36 #define M_61_26 35 #define M_61_27 34 #define M_61_28 33 #define M_61_29 32 #define M_61_30 31 #define M_61_31 30 #define M_61_32 29 #define M_61_33 28 #define M_61_34 27 #define M_61_35 26 #define M_61_36 25 #define M_61_37 24 #define M_61_38 23 #define M_61_39 22 #define M_61_40 21 #define M_61_41 20 #define M_61_42 19 #define M_61_43 18 #define M_61_44 17 #define M_61_45 16 #define M_61_46 15 #define M_61_47 14 #define M_61_48 13 #define M_61_49 12 #define M_61_50 11 #define M_61_51 10 #define M_61_52 9 #define M_61_53 8 #define M_61_54 7 #define M_61_55 6 #define M_61_56 5 #define M_61_57 4 #define M_61_58 3 #define M_61_59 2 #define M_61_60 1 #define M_61_61 0 #define M_61_62 -1 #define M_61_63 -2 #define M_61_64 -3 #define M_62_1 61 #define M_62_2 60 #define M_62_3 59 #define M_62_4 58 #define M_62_5 57 #define M_62_6 56 #define M_62_7 55 #define M_62_8 54 #define M_62_9 53 #define M_62_10 52 #define M_62_11 51 #define M_62_12 50 #define M_62_13 49 #define M_62_14 48 #define M_62_15 47 #define M_62_16 46 #define M_62_17 45 #define M_62_18 44 #define M_62_19 43 #define M_62_20 42 #define M_62_21 41 #define M_62_22 40 #define M_62_23 39 #define M_62_24 38 #define M_62_25 37 #define M_62_26 36 #define M_62_27 35 #define M_62_28 34 #define M_62_29 33 #define M_62_30 32 #define M_62_31 31 #define M_62_32 30 #define M_62_33 29 #define M_62_34 28 #define M_62_35 27 #define M_62_36 26 #define M_62_37 25 #define M_62_38 24 #define M_62_39 23 #define M_62_40 22 #define M_62_41 21 #define M_62_42 20 #define M_62_43 19 #define M_62_44 18 #define M_62_45 17 #define M_62_46 16 #define M_62_47 15 #define M_62_48 14 #define M_62_49 13 #define M_62_50 12 #define M_62_51 11 #define M_62_52 10 #define M_62_53 9 #define M_62_54 8 #define M_62_55 7 #define M_62_56 6 #define M_62_57 5 #define M_62_58 4 #define M_62_59 3 #define M_62_60 2 #define M_62_61 1 #define M_62_62 0 #define M_62_63 -1 #define M_62_64 -2 #define M_63_1 62 #define M_63_2 61 #define M_63_3 60 #define M_63_4 59 #define M_63_5 58 #define M_63_6 57 #define M_63_7 56 #define M_63_8 55 #define M_63_9 54 #define M_63_10 53 #define M_63_11 52 #define M_63_12 51 #define M_63_13 50 #define M_63_14 49 #define M_63_15 48 #define M_63_16 47 #define M_63_17 46 #define M_63_18 45 #define M_63_19 44 #define M_63_20 43 #define M_63_21 42 #define M_63_22 41 #define M_63_23 40 #define M_63_24 39 #define M_63_25 38 #define M_63_26 37 #define M_63_27 36 #define M_63_28 35 #define M_63_29 34 #define M_63_30 33 #define M_63_31 32 #define M_63_32 31 #define M_63_33 30 #define M_63_34 29 #define M_63_35 28 #define M_63_36 27 #define M_63_37 26 #define M_63_38 25 #define M_63_39 24 #define M_63_40 23 #define M_63_41 22 #define M_63_42 21 #define M_63_43 20 #define M_63_44 19 #define M_63_45 18 #define M_63_46 17 #define M_63_47 16 #define M_63_48 15 #define M_63_49 14 #define M_63_50 13 #define M_63_51 12 #define M_63_52 11 #define M_63_53 10 #define M_63_54 9 #define M_63_55 8 #define M_63_56 7 #define M_63_57 6 #define M_63_58 5 #define M_63_59 4 #define M_63_60 3 #define M_63_61 2 #define M_63_62 1 #define M_63_63 0 #define M_63_64 -1 #define M_64_1 63 #define M_64_2 62 #define M_64_3 61 #define M_64_4 60 #define M_64_5 59 #define M_64_6 58 #define M_64_7 57 #define M_64_8 56 #define M_64_9 55 #define M_64_10 54 #define M_64_11 53 #define M_64_12 52 #define M_64_13 51 #define M_64_14 50 #define M_64_15 49 #define M_64_16 48 #define M_64_17 47 #define M_64_18 46 #define M_64_19 45 #define M_64_20 44 #define M_64_21 43 #define M_64_22 42 #define M_64_23 41 #define M_64_24 40 #define M_64_25 39 #define M_64_26 38 #define M_64_27 37 #define M_64_28 36 #define M_64_29 35 #define M_64_30 34 #define M_64_31 33 #define M_64_32 32 #define M_64_33 31 #define M_64_34 30 #define M_64_35 29 #define M_64_36 28 #define M_64_37 27 #define M_64_38 26 #define M_64_39 25 #define M_64_40 24 #define M_64_41 23 #define M_64_42 22 #define M_64_43 21 #define M_64_44 20 #define M_64_45 19 #define M_64_46 18 #define M_64_47 17 #define M_64_48 16 #define M_64_49 15 #define M_64_50 14 #define M_64_51 13 #define M_64_52 12 #define M_64_53 11 #define M_64_54 10 #define M_64_55 9 #define M_64_56 8 #define M_64_57 7 #define M_64_58 6 #define M_64_59 5 #define M_64_60 4 #define M_64_61 3 #define M_64_62 2 #define M_64_63 1 #define M_64_64 0 #define T_1_1 1 #define T_1_2 2 #define T_1_3 3 #define T_1_4 4 #define T_1_5 5 #define T_1_6 6 #define T_1_7 7 #define T_1_8 8 #define T_2_1 2 #define T_2_2 4 #define T_2_3 6 #define T_2_4 8 #define T_2_5 10 #define T_2_6 12 #define T_2_7 14 #define T_2_8 16 #define T_3_1 3 #define T_3_2 6 #define T_3_3 9 #define T_3_4 12 #define T_3_5 15 #define T_3_6 18 #define T_3_7 21 #define T_3_8 24 #define T_4_1 4 #define T_4_2 8 #define T_4_3 12 #define T_4_4 16 #define T_4_5 20 #define T_4_6 24 #define T_4_7 28 #define T_4_8 32 #define T_5_1 5 #define T_5_2 10 #define T_5_3 15 #define T_5_4 20 #define T_5_5 25 #define T_5_6 30 #define T_5_7 35 #define T_5_8 40 #define T_6_1 6 #define T_6_2 12 #define T_6_3 18 #define T_6_4 24 #define T_6_5 30 #define T_6_6 36 #define T_6_7 42 #define T_6_8 48 #define T_7_1 7 #define T_7_2 14 #define T_7_3 21 #define T_7_4 28 #define T_7_5 35 #define T_7_6 42 #define T_7_7 49 #define T_7_8 56 #define T_8_1 8 #define T_8_2 16 #define T_8_3 24 #define T_8_4 32 #define T_8_5 40 #define T_8_6 48 #define T_8_7 56 #define T_8_8 64 #define AA(c_,a_,b_) Mjoin(Mjoin(c_,_),Mjoin(Mjoin(a_,_),b_)) #define AM(a_,b_) AA(M,a_,b_) #define AP(a_,b_) AA(P,a_,b_) #define AT(a_,b_) AA(T,a_,b_) gcl-2.6.14/h/arith.h0000755000175000017500000001435514360276512012515 0ustar cammcamm#ifndef lsub #ifndef our_ulong #define our_ulong unsigned plong #endif EXTER our_ulong overflow, hiremainder; #endif #define ulong unsigned plong #ifndef WSIZ #define WSIZ 32 /* Notation: if A and B are unsigned 32 bit integers, 1) A:B signifies the 64 bit integer A*2^32 + B 2) S(A:B) the signed 64 bit integer 3) I(x) is a true integer. If (x) were unsigned then I(x) >= 0, otherwise I(x) has the same sign and size as x. */ /* TEMPVARS are variables are used to prevent double evaluation of arguments in macros, and also to make sure of the type. Be careful about the composition of macros */ #define TEMPVARS our_ulong Xtx,Xty,Xtres; #define TEMPVARS2 our_ulong Xtx; /* our_ulong res,x,y; res = addll(x,y); then I(overflow:res) == I(x) + I(y); */ #define addll(x,y) \ (Xtx=(x),Xty=(y), Xtres = Xtx+Xty, \ overflow = \ (Xtres < Xtx ? 1:0), Xtres) /* our_ulong res,x,y; o = overflow; res = addllx(x,y); then I(overflow:res) == I(x) + I(y) +I(o). */ #ifndef addllx #define addllx(x,y) \ (Xtx=(x),Xtres= Xtx + (y), \ (Xtres < Xtx ? (Xtres += overflow ,overflow=1,Xtres) : \ ( Xtres += overflow , \ overflow = (Xtres < overflow ? 1 : 0), \ Xtres))) #endif /* our_ulong x,y,w,o; if we do o = overflow, res = subll(x,y) then I(S(-overflow:res)) == I(x) -I(y); */ #ifndef subll #define subll(x,y) \ (Xtx=(x),Xty=(y),Xtres= Xtx - Xty, \ overflow = (Xtx >= Xty ? 0 : 1), Xtres) #endif /* our_ulong x,y,o,res; o = overflow; res= subllx(x,y); then I(S(-overflow):res) == I(x) - I(y) -I(o) where overflow is in {0,1} at all times. */ #ifndef subblx #define subllx(x,y) \ (Xtx=(x),Xty=(y),Xtres= Xtx - Xty, Xtres -=overflow, \ (Xty > Xtx ? overflow = 1 : \ Xty < Xtx ? overflow = 0 : 0), \ Xtres) #endif #define shiftlr(x,y) \ (Xtx = x, hiremainder=Xtx<<(32-y),Xtx>>y) #define shiftl(x,y) \ (Xtx = x, hiremainder=Xtx>>(32-y),Xtx< (UINT) l) (UINT) h--; \ l= (int)l - (int) l1; \ h=h-h1;\ } while (0) /* x is less than WSIZ and it is shifted n bits into hi and lo */ #define llshift(x,n,hi,lo) \ do { hi = x >> (WSIZ - n) ; \ lo = x << n ; \ }while (0) #define UINT unsigned int #define lladd(h1,l1,h,l) \ do {UINT res; res=(UINT)l1+(UINT)l; \ if ((UINT)res< (UINT)l1 || (UINT)res< (UINT)l) \ /* overflow */ \ (h)++; \ l=res; \ h= (UINT)h+(UINT)h1; \ }while (0) /* x,y unsigned longs. u = x + y if (u > 2^32) h = h+1; */ #ifndef add_carry #define add_carry(x,y,h) \ (Xtx = (x), Xtres = Xtx +(y), (Xtres < Xtx ? (h++,1):0), Xtres) #endif #endif #ifndef BASE_COUNTER #define BASE_COUNTER 0 #endif #define divll(x,y) divul(x,y,hiremainder) /* our_ulong x,y,h, res; hi = rem; res = divul(x,y,rem) then I(hi:x) == I(y) * I(res) + I(rem) and ( 0 = < rem < y) */ #ifndef divul #define divul(x,y,h) divul3(x,y,&h) #endif /* our_ulong x,y,h, res; res = mulul(x,y,h) then I(h:res) == I(x) * I(y); */ #ifndef mulul #define mulul(x,y,h) mulul3(x,y,&h) #endif #ifndef addmul #define addmul(x,y) \ (Xtx = hiremainder, Xtres = mulul(x,y,hiremainder),\ add_carry(Xtx,Xtres,hiremainder)) #endif #ifdef SET_MACHINE_CARRY #define ADDLLX(x,y,z) \ SET_MACHINE_CARRY(overflow); \ (z) = ADDXCC((x),(y)); \ SET_OVERFLOW #define SUBLLX(x,y,z) \ SET_MACHINE_CARRY(overflow); \ (z) = SUBXCC((x),(y)); \ SET_OVERFLOW #ifdef C_SWITCH_DOESNT_AFFECT_CARRY #define CASE(i,op) case i: MP_NEXT_UP(zp) = op(MP_NEXT_UP(xp),(MP_NEXT_UP(yp))) #define QUICK_LOOP(j,op) \ do{SET_MACHINE_CARRY(overflow); \ switch(j){ \ default: \ CASE(16,op); \ CASE(15,op); \ CASE(14,op); \ CASE(13,op); \ CASE(12,op); \ CASE(11,op); \ CASE(10,op); \ CASE(9,op); \ CASE(8,op); \ CASE(7,op); \ CASE(6,op); \ CASE(5,op); \ CASE(4,op); \ CASE(3,op); \ CASE(2,op); \ CASE(1,op); \ case 0: SET_OVERFLOW; j -= 16;}} while (j > 0) #else /* The C switch statement changes the machine carry, so that we must reset it each time we enter */ #define LA(i,op) L ## op ## i: MP_NEXT_UP(zp) = \ op(MP_NEXT_UP(xp),MP_NEXT_UP(yp)) #define CA(i,op) case i: SET_MACHINE_CARRY(overflow);\ goto L ## op ## i #define QUICK_LOOP(j,op) \ do {switch (j) { default: \ CA(16,op);CA(15,op);CA(14,op);CA(13,op);CA(12,op);CA(11,op);CA(10,op); \ CA(9,op);CA(8,op);CA(7,op);CA(6,op);CA(5,op);CA(4,op);CA(3,op); \ CA(2,op);CA(1,op); \ LA(16,op);LA(15,op);LA(14,op);LA(13,op);LA(12,op);LA(11,op);LA(10,op); \ LA(9,op);LA(8,op);LA(7,op);LA(6,op);LA(5,op);LA(4,op);LA(3,op);LA(2,op);\ LA(1,op); \ SET_OVERFLOW; j -= 16;}} while (j > 0) /* end else C_SWITCH_DOESNT_AFFECT_CARRY */ #endif /* endif don't use machine carry in separate ops */ #endif #ifndef ADDLLX #define ADDLLX(x,y,z) (z) = addllx((x),(y)) #endif /* z=x-y-overflow */ #ifndef SUBLLX #define SUBLLX(x,y,z) (z) = subllx((x),(y)) #endif #ifndef mulll #define mulll(x,y) mulul(x,y,hiremainder) #endif #ifndef mulul #define mulul(a,b,h) mulul3(a,b,&h) #endif /* The following macros are for stepping through a bignum , after positioning a pointer at the high or low word. */ #define MP_START_LOW(u,x,l) u = (x)+l #define MP_START_HIGH(u,x,l) u = (x)+2 #define MP_NEXT_UP(u) (*(--(u))) #define MP_NEXT_DOWN(u) (*((u)++)) /* ith word from the least significant */ #define MP_ITH_WORD(u,i,l) (u)[l-i-1] #define MP_CODE_WORDS 2 /* MP_LOW(x,lgef(x)) is the least significant word */ #define MP_LOW(x,l) ((x)[(l)-1]) /* most significant word if l is the lgef(x) */ #define MP_HIGH(x,l) (x)[2] /*Some machines will iterate more efficiently with different bottoms for the iteration. Eg with gcc and mc68k one can generate the dbra instruction which is done when i == -1. The dbra does not alter the condition code which can be important in a tight loop. */ #define MP_COUNT_LG(l) COUNT(l - MP_CODE_WORDS ) /* i should be the number of counts so if i = COUNT(3) WHILE_COUNT(--i) will repeat body 3 times. */ #define COUNT(l) (l +1+BASE_COUNTER) #define WHILE_COUNT(l) while (l!=BASE_COUNTER) extern our_ulong ABS_MOST_NEGS[]; extern our_ulong MOST_NEGS[]; gcl-2.6.14/h/OpenBSD.defs0000755000175000017500000000217614360276512013330 0ustar cammcamm# Machine dependent makefile definitions for intel 386,486 running 386bsd # Ported to OpenBSD 2.7 by Justin Smith # 10/3/2000 LBINDIR=/usr/local/bin OFLAG = -O2 -pipe LIBS = -lm -ltk80 -ltcl80 -lX11 -lXt ODIR_DEBUG= NULLFILE=../h/twelve_null # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC = gcc -pipe -O2 -fwritable-strings -fomit-frame-pointer -DVOL=volatile -I$(GCLDIR)/o -I/usr/local/lib/gcl-2.3/h -I../h -I/usr/local/include -I/usr/local/include/tk8.0 -I/usr/local/include/tcl8.0 -I/usr/X11R6/include -fsigned-char -L/usr/local/lib -L/usr/X11R6/lib LDCC = $(CC) -static -L/usr/local/lib -L/usr/X11R6/lib # Use the mp.s file on 68k machine MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/gnuwin95.defs0000755000175000017500000000230114360276512013551 0ustar cammcamm # Machine dependent makefile definitions for intel 386,486 running linux # note using /bin/sh (ie a copy of ash.exe) will fail if a very LONG command # line is given, eg when linking maxima. bash has more stack. SHELL=bash LBINDIR=/usr/local/bin #OFLAG = -O #LIBS = -lm #LIBC = #ODIR_DEBUG= -O4 #ODIR_DEBUG= # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. #CC = gcc -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char #AS= as #AR= ar q #RANLIB= ranlib LDCC=${CC} # Unexec dependency UNIX_SAVE_DEP = unexnt.c # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = sfasl.o #MPFILES= $(MPDIR)/mpi-386-winnt.o $(MPDIR)/libmport.a #MPFILES= $(MPDIR)/mpi.o $(MPDIR)/libmport.a FIRST_FILE=firstfile.o LAST_FILE=lastfile.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s APPEND=../bin/append # suffix for executables EXE=.exe LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd # using gcc so dont need #GNULIB1= gcl-2.6.14/h/elf32_sparc_reloc.h0000644000175000017500000000060514360276512014663 0ustar cammcamm case R_SPARC_WDISP30: /* v-disp30*/ store_vals(where,MASK(30),((long)(s+a-p))>>2); break; case R_SPARC_HI22: /* t-sim22 */ store_val(where,MASK(22),(s+a)>>10); break; case R_SPARC_LO10: /* val = (s+a) & MASK(10); */ store_val(where,MASK(10),s+a); break; case R_SPARC_32: case R_SPARC_UA32: store_valu(where,~0L,s+a); break; gcl-2.6.14/h/sgi4d.defs0000755000175000017500000000304314360276512013102 0ustar cammcamm# Has been tested on SGI IRIX 4.0.5 # Machine dependent makefile definitions for SGI Iris 3030 LBINDIR=/usr/local/bin OFLAG = LIBS = -lm -lbsd ODIR_DEBUG= NULLFILE = ../h/twelve_null SHELL=/bin/sh # .IGNORE: # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # also defined in `machine'.h file # The one here must be >= the one in the .h file. # It must be a multiple of 0x200000 greater that 0x400000 the # default text start. DBEGIN= A00000 # If you don't plan on linking in a lot of other stuff # like maxima, you can increase the -G 8 to -G 800 or so. # That should be a bit faster.. # these were the previous ones... if you have trouble with -common try this.. # why do we need so many flags........... # CC = cc -xansi -D__STDC__ -DVOL=volatile -Olimit 798 -G 8 -I${GCLDIR}/o -I/usr/include/bsd # LDCC = cc -Wl,-D -Wl,${DBEGIN} CC = cc -xansi -D__STDC__ -DVOL=volatile -Olimit 798 -G 8 -common -I${GCLDIR}/o -I/usr/include/bsd LDCC = cc -Wl,-D -Wl,${DBEGIN} -common # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # incremental loading with -A requires -G 0 INITFORM=(setq compiler::*cc* "cc -DVOL=volatile -G 0 ") # Use symbolic links SYMB=-s EMUL= $(ODIR)/sgi4d_emul.o MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a RANLIB= ar lts gcl-2.6.14/h/FreeBSD.h0000755000175000017500000000405414360276512012613 0ustar cammcamm/* * FreeBSD.h for gcl * * Ported by Mark Murray * Looked at previous versions by Hsu, Werkowsksi, Tobin, and Mogart. * */ #ifndef __ELF__ #error FreeBSD systems use ELF #endif #if defined(__i386__) #define __ELF_NATIVE_CLASS 32 #endif #if defined(__alpha__) || defined(__sparc64__) || defined(__ia64__) #define __ELF_NATIVE_CLASS 64 #endif #if !defined(ElfW) #define ElfW(a) Mjoin(Elf,Mjoin(__ELF_NATIVE_CLASS,Mjoin(_,a))) #endif #define ELFW(a) Mjoin(ELF,Mjoin(__ELF_NATIVE_CLASS,Mjoin(_,a))) /* OpenBSD needs sys/types.h included before link.h, which is included in linux.h */ #include #if defined(HAVE_ELF_H) #include #elif defined(HAVE_ELF_ABI_H) #include #endif #include "linux.h" #if defined(__i386__) #define I386 #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("386BSD"); \ ADD_FEATURE("FreeBSD"); #define USE_ATT_TIME #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) \ do { \ int c = 0; \ \ if ( \ (fp)->_r <= 0 && \ (ioctl(((FILE *)fp)->_file, FIONREAD, &c), c <= 0) \ ) \ return(FALSE); \ } while (0) #ifdef IN_GBC #include #endif #if defined(IN_UNIXTIME) # include #endif /*#define UNEXEC_USE_MAP_PRIVATE*/ #define UNIXSAVE "unexelf.c" #ifdef CLOCKS_PER_SEC #define HZ CLOCKS_PER_SEC #else #define HZ 128 #endif /* #define ss_base ss_sp */ /* begin for GC */ #define PAGEWIDTH 12 /* i386 sees 4096 byte pages */ /* end for GC */ #define HAVE_SIGPROCMASK #define SIG_STACK_SIZE (SIGSTKSZ/sizeof(double)) /* * The next two defines are for SGC, * one of which needs to go in cmpinclude.h. */ #define SIGPROTV SIGBUS #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif /* Begin for cmpinclude */ #define SGC /* can mprotect pages and so selective gc will work */ /* End for cmpinclude */ gcl-2.6.14/h/elf64_alpha_reloc.h0000644000175000017500000000211414360276512014642 0ustar cammcamm case R_ALPHA_GPDISP: gotoff=(ul)(got+HIGH(a)-1); s=gotoff-p; store_val(where,MASK(16),(s-(short)s)>>16); store_val((void *)where+LOW(a),MASK(16),s); break; case R_ALPHA_SREL32: store_val(where,MASK(32),s+a-p); break; case R_ALPHA_GPREL32: store_val(where,MASK(32),s+LOW(a)-(ul)(got+HIGH(a)-1)); break; case R_ALPHA_LITUSE: case R_ALPHA_HINT: break; case R_ALPHA_REFQUAD: store_val(where,~0L,s+a); break; case R_ALPHA_REFLONG: store_val(where,MASK(32),s+a); break; case R_ALPHA_LITERAL: s+=LOW(a); a=HIGH(a)-1; if (s>=ggot1 && s>16); break; case R_ALPHA_GPRELLOW: store_val(where,MASK(16),s+a-gotoff); break; case R_ALPHA_TLS_GD_HI: store_vals(where,MASK(21),((long)(s+a-(p+4)))>>2); break; gcl-2.6.14/h/elf32_i386_reloc.h0000644000175000017500000000020614360276512014241 0ustar cammcamm case R_386_32: add_val(where,~0L,s+a); break; case R_386_PC32: add_val(where,~0L,s+a-p); break; gcl-2.6.14/h/irix6.defs0000755000175000017500000000000014360276512013117 0ustar cammcammgcl-2.6.14/h/error.h0000644000175000017500000002660514360276512012535 0ustar cammcamm#ifndef ERROR_H #define ERROR_H #define Icall_error_handler(a_,b_,c_,d_...) \ Icall_gen_error_handler_noreturn(Cnil,null_string,a_,b_,c_,##d_) #define Icall_continue_error_handler(a_,b_,c_,d_,e_...) \ Icall_gen_error_handler(Ct,a_,b_,c_,d_,##e_) extern enum type t_vtype; extern int vtypep_fn(object); extern void Check_type(object *,int (*)(object),object); #define PFN(a_) INLINE int Join(a_,_fn)(object x) {return a_(x);} PFN(integerp) PFN(non_negative_integerp) PFN(rationalp) PFN(floatp) PFN(realp) PFN(numberp) PFN(characterp) PFN(symbolp) PFN(stringp) PFN(pathnamep) PFN(string_symbolp) PFN(packagep) PFN(consp) PFN(listp) PFN(streamp) PFN(pathname_string_symbolp) PFN(pathname_string_symbol_streamp) PFN(randomp) PFN(hashtablep) PFN(arrayp) PFN(vectorp) PFN(readtablep) PFN(functionp) #define TPE(a_,b_,c_) if (!(b_)(*(a_))) FEwrong_type_argument((c_),*(a_)) #define check_type(a_,b_) ({t_vtype=(b_);TPE(&a_,vtypep_fn,type_name(t_vtype));}) #define check_type_function(a_) TPE(a_,functionp_fn,sLfunction) #define check_type_integer(a_) TPE(a_,integerp_fn,sLinteger) #define check_type_non_negative_integer(a_) TPE(a_,non_negative_integerp_fn,TSnon_negative_integer) #define check_type_rational(a_) TPE(a_,rationalp_fn,sLrational) #define check_type_float(a_) TPE(a_,floatp_fn,sLfloat) #define check_type_real(a_) TPE(a_,realp_fn,sLreal) #define check_type_or_rational_float(a_) TPE(a_,realp_fn,sLreal) #define check_type_number(a_) TPE(a_,numberp_fn,sLnumber) #define check_type_stream(a_) TPE(a_,streamp_fn,sLstream) #define check_type_hash_table(a_) TPE(a_,hashtablep_fn,sLhash_table) #define check_type_character(a_) TPE(a_,characterp_fn,sLcharacter) #define check_type_sym(a_) TPE(a_,symbolp_fn,sLsymbol) #define check_type_string(a_) TPE(a_,stringp_fn,sLstring) #define check_type_pathname(a_) TPE(a_,pathnamep_fn,sLpathname) #define check_type_or_string_symbol(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string) #define check_type_or_symbol_string(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string) #define check_type_or_pathname_string_symbol_stream(a_) TPE(a_,pathname_string_symbol_streamp_fn,TSor_pathname_string_symbol_stream) #define check_type_or_Pathname_string_symbol(a_) TPE(a_,pathname_string_symbolp_fn,TSor_pathname_string_symbol) #define check_type_package(a_) TPE(a_,packagep_fn,sLpackage) #define check_type_cons(a_) TPE(a_,consp_fn,sLcons) #define check_type_list(a_) TPE(a_,listp_fn,sLlist) #define check_type_stream(a_) TPE(a_,streamp_fn,sLstream) #define check_type_array(a_) TPE(a_,arrayp_fn,sLarray) #define check_type_vector(a_) TPE(a_,vectorp_fn,sLvector) #define check_type_readtable_no_default(a_) TPE(a_,readtablep_fn,sLreadtable) #define check_type_readtable(a_) ({if (*(a_)==Cnil) *(a_)=standard_readtable;TPE(a_,readtablep_fn,sLreadtable);}) #define check_type_random_state(a_) TPE(a_,randomp_fn,sLrandom_state) #define stack_string(a_,b_) struct string _s={0};\ object a_=(object)&_s;\ set_type_of((a_),t_string);\ (a_)->st.st_self=(void *)(b_);\ (a_)->st.st_dim=(a_)->st.st_fillp=strlen(b_) #define stack_fixnum(a_,b_) struct fixnum_struct _s={0};\ object a_;\ if (is_imm_fix(b_)) (a_)=make_fixnum(b_); else {\ (a_)=(object)&_s;\ set_type_of((a_),t_fixnum);\ (a_)->FIX.FIXVAL=(b_);} object ihs_top_function_name(ihs_ptr h); #define FEerror(a_,b_...) Icall_error_handler(sLerror,null_string,\ 4,sKformat_control,make_simple_string(a_),sKformat_arguments,list(b_)) #define CEerror(a_,b_,c_...) Icall_continue_error_handler(make_simple_string(a_),sLerror,null_string,\ 4,sKformat_control,make_simple_string(b_),sKformat_arguments,list(c_)) #define TYPE_ERROR(a_,b_) Icall_error_handler(sLtype_error,null_string,\ 4,sKdatum,(a_),sKexpected_type,(b_)) #define FEwrong_type_argument(a_,b_) TYPE_ERROR(b_,a_) #define FEcannot_coerce(a_,b_) TYPE_ERROR(b_,a_) #define FEinvalid_function(a_) TYPE_ERROR(a_,sLfunction) #define CONTROL_ERROR(a_) Icall_error_handler(sLcontrol_error,null_string,4,sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil) #define PROGRAM_ERROR(a_,b_) Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string(a_),sKformat_arguments,list(1,(b_))) #define FEtoo_few_arguments(a_,b_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("~S [or a callee] requires more than ~R argument~:p."),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_)))) #define FEwrong_no_args(a_,b_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string(a_),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(b_))) #define FEtoo_few_argumentsF(a_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("Too few arguments."),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_))) #define FEtoo_many_arguments(a_,b_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("~S [or a callee] requires less than ~R argument~:p."),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_)))) #define FEtoo_many_argumentsF(a_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("Too many arguments."),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_))) #define FEinvalid_macro_call() \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("Invalid macro call to ~S."),\ sKformat_arguments,list(1,ihs_top_function_name(ihs_top))) #define FEunexpected_keyword(a_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string("~S does not allow the keyword ~S."),\ sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_))) #define FEinvalid_form(a_,b_) \ Icall_error_handler(sLprogram_error,null_string,4,\ sKformat_control,make_simple_string(a_),\ sKformat_arguments,list(1,(b_))) #define FEinvalid_variable(a_,b_) FEinvalid_form(a_,b_) #define PARSE_ERROR(a_) Icall_error_handler(sLparse_error,null_string,4,\ sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil) #define STREAM_ERROR(a_,b_) Icall_error_handler(sLstream_error,null_string,6,\ sKstream,a_,\ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil) #define READER_ERROR(a_,b_) Icall_error_handler(sLreader_error,null_string,6,\ sKstream,a_,\ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil) #define FILE_ERROR(a_,b_) Icall_error_handler(sLfile_error,null_string,6,\ sKpathname,a_,\ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil) #define END_OF_FILE(a_) Icall_error_handler(sLend_of_file,null_string,2,sKstream,a_) #define PACKAGE_ERROR(a_,b_) Icall_error_handler(sLpackage_error,null_string,6,\ sKpackage,a_,\ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil) #define FEpackage_error(a_,b_) PACKAGE_ERROR(a_,b_) #define PACKAGE_CERROR(a_,b_,c_,d_...) \ Icall_continue_error_handler(make_simple_string(b_),\ sLpackage_error,null_string,6,\ sKpackage,a_,\ sKformat_control,make_simple_string(c_),sKformat_arguments,list(d_)) #define NEW_INPUT(a_) (a_)=Ieval1(read_object(sLAstandard_inputA->s.s_dbind)) #define CELL_ERROR(a_,b_) Icall_error_handler(sLcell_error,null_string,6,\ sKname,a_,\ sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil) #define UNBOUND_VARIABLE(a_) Icall_error_handler(sLunbound_variable,null_string,2,sKname,a_) #define FEunbound_variable(a_) UNBOUND_VARIABLE(a_) #define UNBOUND_SLOT(a_,b_) Icall_error_handler(sLunbound_slot,null_string,4,sKname,a_,sKinstance,b_) #define UNDEFINED_FUNCTION(a_) Icall_error_handler(sLundefined_function,null_string,2,sKname,a_) #define FEundefined_function(a_) UNDEFINED_FUNCTION(a_) #define ARITHMETIC_ERROR(a_,b_) Icall_error_handler(sLarithmetic_error,null_string,4,sKoperation,a_,sKoperands,b_) #define DIVISION_BY_ZERO(a_,b_) Icall_error_handler(sLdivision_by_zero,null_string,4,sKoperation,a_,sKoperands,b_) #define FLOATING_POINT_OVERFLOW(a_,b_) Icall_error_handler(sLfloating_point_overflow,null_string,4,sKoperation,a_,sKoperands,b_) #define FLOATING_POINT_UNDERFLOW(a_,b_) Icall_error_handler(sLfloating_point_underflow,null_string,4,sKoperation,a_,sKoperands,b_) #define FLOATING_POINT_INEXACT(a_,b_) Icall_error_handler(sLfloating_point_inexact,null_string,4,sKoperation,a_,sKoperands,b_) #define FLOATING_POINT_INVALID_OPERATION(a_,b_) Icall_error_handler(sLfloating_point_invalid_operation,null_string,4,sKoperation,a_,sKoperands,b_) #define PATHNAME_ERROR(a_,b_,c_...) Icall_error_handler(sLfile_error,null_string,6,\ sKpathname,(a_),\ sKformat_control,make_simple_string(b_),\ sKformat_arguments,list(c_)) #define WILD_PATH(a_) ({object _a=(a_);PATHNAME_ERROR(_a,"File ~s is wild",1,_a);}) #define NERROR(a_) ({object fmt=make_simple_string(a_ ": line ~a, file ~a, function ~a");\ {object line=make_fixnum(__LINE__);\ {object file=make_simple_string(__FILE__);\ {object function=make_simple_string(__FUNCTION__);\ Icall_error_handler(sKerror,fmt,3,line,file,function);}}}}) #define ASSERT(a_) do {if (!(a_)) NERROR("The assertion " #a_ " failed");} while (0) #define gcl_abort() ({\ frame_ptr fr=frs_sch_catch(sSPtop_abort_tagP->s.s_dbind);\ vs_base[0]=sSPtop_abort_tagP->s.s_dbind;\ vs_top=vs_base+1;\ if (fr) unwind(fr,sSPtop_abort_tagP->s.s_dbind);\ abort();\ }) #endif /*ERROR_H*/ gcl-2.6.14/h/alpha-linux.h0000755000175000017500000000163414360276512013624 0ustar cammcamm#include "linux.h" #define MUST_COPY_VA_LIST /* #define NULL_OR_ON_C_STACK(x) ((x)==0 || ((((unsigned long)x) > 0x100000000) && ((unsigned long)x) < 0x120000000)) */ #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO /* #ifdef IN_GBC */ /* #include */ /* #define GET_FAULT_ADDR(sig,code,scp,addr) \ no longer working*/ /* (char *)((struct ucontext *)scp )->uc_mcontext.sc_traparg_a0 */ /*#define GET_FAULT_ADDR(sig,code,sv,a) ((siginfo_t *)code)->si_addr perhaps try this when get access*/ /* #endif */ /* #define SGC */ #undef SGC #define RELOC_H "elf64_alpha_reloc.h" #define SPECIAL_RELOC_H "elf64_alpha_reloc_special.h" #define PAL_imb 134 #define imb() __asm__ __volatile__ ("call_pal %0 #imb" : : "i" (PAL_imb) : "memory") #define CLEAR_CACHE imb() /*FIXME probe broken in recent kernels, no access*/ #define DEFINED_REAL_MAXPAGE (1UL<<18) /*FIXME brk probe broken*/ gcl-2.6.14/h/ia64-linux.h0000755000175000017500000000056314360276512013302 0ustar cammcamm#include "linux.h" #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #ifdef IN_GBC #define GET_FAULT_ADDR(sig,code,scp,addr) \ ((siginfo_t *)code )->si_addr #endif /* #define SGC *//*FIXME ia64 specific fread/getc restart failure and hang*/ #define STATIC_FUNCTION_POINTERS #define BRK_DOES_NOT_GUARANTEE_ALLOCATION #define NOFREE_ERR gcl-2.6.14/h/sgi.defs0000755000175000017500000000115314360276512012652 0ustar cammcamm # Machine dependent makefile definitions for SGI Iris 3030 LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm -lbsd ODIR_DEBUG= NULLFILE = ../h/twelve_null # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC = cc -I/usr/include/bsd -DVOL= -I$(GCLDIR)/o # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s gcl-2.6.14/h/hp300.h0000755000175000017500000000622414360276512012234 0ustar cammcamm#define HPUX #define HP #include "bsd.h" #undef RUN_PROCESS #undef WANT_VALLOC /* uses sigvector instead of sigvec. Could alternately link with -lbsd */ #define sigvec sigvector /* does not have getpagesize() */ #include "mc68k.h" /* #define SBRK(n) \ (printf("sbrk(%x)=%x",n,FIXtemp=sbrk(n)),fflush(stdout),FIXtemp) #define BRK(n) \ (printf("brk(%x)=%x",n,FIXtemp=brk(n)),fflush(stdout),FIXtemp) */ /* #undef SFASL */ /* since we do brk of the whole thing we use a smaller number */ #define ADDITIONAL_FEATURES \ ADD_FEATURE("HP9000-300"); \ ADD_FEATURE("MC68020"); \ ADD_FEATURE("HP-UX"); /* #define USE_C_EXTENDED_MUL #define USE_C_EXTENDED_DIV */ #define DATA_BEGIN (char *)N_DATADDR(header) #define RELOC_FILE "rel_hp300.c" #define IEEEFLOAT #define reloc r_info #define N_RELOFF(hdr) RTEXT_OFFSET(hdr) #define N_SYMOFF(hdr) LESYM_OFFSET(hdr) #define N_TXTOFF(hdr) TEXT_OFFSET(hdr) /* #undef cs_check */ #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE /* #undef INIT_ALLOC #define INIT_ALLOC if (BRK(pagetochar(MAXPAGE)) < 0) \ error("Can't allocate. Good-bye!."); */ #define SEEK_TO_END_OFILE(fp) \ do{struct exec header; \ fseek(fp,0,0); \ fread(&header, sizeof(header), 1, fp); \ fseek(fp,RDATA_OFFSET(header)+header.a_drsize,0); \ }while(0) /* have the getcwd command */ #define GETCWD /* note gabor used the att ldirectory... maybe bsd is ok?? */ #undef LD_COMMAND /* This is for pre 6.01 hpux, you need to create .stb file #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command,"ld -o %s -N -x -R %x %s %s.stb %s", \ output,start,input, main,ldarg) */ #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -N -x -A %s -R %x %s %s -o %s", \ main,start,input,ldarg,output) /* #define SIGNED_CHAR #define REGISTER_VAR #define BYTE_ADDRESS #define CORE_STARTS_NEAR_0 #undef DOWN_STACK #undef REVERSE_PARAMETER_ORDER #undef CC_OPTIMIZES_TEST #define UNIX #undef BSD #define HPUX #undef ATT #define ALLOCATE_INCREMENTALLY #define ALLOW_FORK */ #undef DATA_BEGIN #define DATA_BEGIN \ ((char *) (header.a_magic.file_type == SHARE_MAGIC || \ header.a_magic.file_type == DEMAND_MAGIC) ? \ EXEC_ALIGN(header.a_text) : \ header.a_text) #undef FILECPY_HEADER #define FILECPY_HEADER \ if (header.a_magic.file_type == DEMAND_MAGIC) \ {filecpy(save, original, EXEC_PAGESIZE - sizeof(header)); \ filecpy(save, original, EXEC_ALIGN(header.a_text));} \ else \ filecpy(save, original, header.a_text); #undef COPY_TO_SAVE #define COPY_TO_SAVE \ fseek(save, MODCAL_OFFSET(header), 0); \ header.a_data = original_data; \ fseek(original, MODCAL_OFFSET(header), 0); \ filecpy(save, original, \ header.a_pasint+ \ header.a_lesyms+ \ header.a_dnttsize+header.a_sltsize+header.a_vtsize+ \ header.a_trsize+header.a_drsize) /* use #include */ #define HAVE_FCNTL #define RSYM_AUX "../c/rel_hp300.c" #define FIX_BSS sym->n_type = N_BSS; \ val = (val + 3) & ~3; #define PRIVATE_FASLINK /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/ext_sym.h0000755000175000017500000000470314360276512013072 0ustar cammcamm #ifdef HAVE_AOUT #undef BSD #undef ATT #define BSD #include HAVE_AOUT #endif #ifdef _WIN32 #define TEXT_NSCN 1 #define DATA_NSCN 2 #define BSS_NSCN 3 #endif #ifdef AIX3 #include #endif #ifdef COFF_ENCAPSULATE #undef BSD #undef ATT #define BSD #include "a.out.encap.h" #endif #include "ptable.h" #ifdef ATT #define COFF #ifndef TEXT_NSCN #define TEXT_NSCN 1 #define DATA_NSCN 2 #define BSS_NSCN 3 #endif #endif #ifdef ATT #include #include #include /* is aouthdr.h one always here on sysv Interactive systems needs it now at least. I am not sure if the others used to include this... */ #include #define MAXPATHLEN 200 #define N_BADMAG(x) !(ISCOFF(x.f_magic)) #define N_SYMOFF(x) (x).f_symptr #define NSYMS(x) (x).f_nsyms #include #endif #define RDONLY "r" #ifdef BSD #define filehdr exec #ifndef AIX #ifndef reloc #define reloc relocation_info #endif #endif #define NSYMS(f) ((unsigned int )((f).a_syms/(sizeof(struct nlist)))) #ifndef AIX #define syment nlist #endif #ifndef SYMESZ #define SYMESZ (sizeof(struct nlist)) #endif #ifndef SYMNMLEN /* no symbols are directly in the table */ #define SYMNMLEN 0 #endif #ifndef EXT_and_TEXT_BSS_DAT #define EXT_and_TEXT_BSS_DAT(p) (((p)->n_type & N_EXT) && \ ((p)->n_type & (N_TEXT | N_DATA | N_BSS))) #endif #ifndef SYM_NAME #define SYM_NAME(x) (my_string_table+(x)->n_un.n_strx) #endif #ifndef NUM_AUX #define NUM_AUX(p) 0 #endif #ifndef N_RELOFF #define N_RELOFF(p) (N_TXTOFF(p) +(p).a_text+(p).a_data ) #endif #define NTYPE(sym) ((sym)->n_type & N_TYPE) #ifndef N_SECTION #define N_SECTION(sym) (sym->n_type & N_TYPE & ~N_EXT) #endif #define N_UNDEF N_UNDF #endif /*end bsd */ #ifdef HPUX #define nlist nlist_ #undef syment struct syment { long n_value; unsigned char n_type; unsigned char n_length; short n_almod; short n_unused; union { long n_strx;} n_un; }; #endif /* Hp */ #ifdef COFF /* sys v */ #ifndef EXT_and_TEXT_BSS_DAT #define EXT_and_TEXT_BSS_DAT(p) \ ((1 <= (p)->n_scnum) && ((p)->n_scnum <= 3 ) && (p)->n_sclass == C_EXT) #endif #define NUM_AUX(p) (p)->n_numaux #define N_TXTOFF(p) section[1].s_scnptr #define SYM_NAME(p) \ (((p)->n_zeroes == 0) ? \ &my_string_table[(p)->n_offset] : \ ((p)->n_name[SYMNMLEN -1] ? \ (strncpy(tem,(p)->n_name, \ SYMNMLEN), \ (char *)tem) : \ (p)->n_name )) #define NTYPE(sym) (sym)->n_scnum #endif /* COFF */ gcl-2.6.14/h/sun4.h0000755000175000017500000000451414360276512012273 0ustar cammcamm#define SUN4 #include "bsd.h" #include "sparc.h" #ifdef __svr4__ #define UNIXSAVE "unexelf.c" #ifdef IN_UNIXSAVE #define round_up round_up1 #define bss_end core_end #endif #define ULONG_DEFINED #undef HAVE_SIGVEC #define HAVE_SIGACTION #define SV_ONSTACK SA_ONSTACK #ifdef IN_GBC #include #endif #define GET_FAULT_ADDR(sig,code,scp,addr) \ (code ? ((siginfo_t *)code )->si_addr : error("no address info")) #undef HAVE_AOUT #define HAVE_AOUT #define HAVE_ELF #define SEEK_TO_END_OFILE(fp)\ do { Elf32_Ehdr eheader; \ fseek(fp,0,SEEK_SET); \ fread(&eheader,sizeof(eheader),1,fp); \ fseek(fp,eheader.e_shoff+(eheader.e_shnum)*eheader.e_shentsize,\ SEEK_SET); \ } while(0) #define USE_ATT_TIME #define GETCWD #define SPECIAL_RSYM "rsym_elf.c" #define SEPARATE_SFASL_FILE "sfaslelf.c" #ifdef IN_FILE #include #endif #ifdef IN_RUN_PROCESS #include #endif #endif #ifndef __svr4__ /* sun release 4.1,4.2 */ #define SA_RESTART 0 #define SA_SIGINFO 0 #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("SPARC") #define SPARC #define IEEEFLOAT #define USE_C_EXTENDED_DIV /* setjmp does not lay down the other register windows registers, and so we must recurse some to make sure that all registers are forced onto the stack. */ #define N_RECURSION_REQD 8 #define DATA_BEGIN (char *)N_DATADDR(header) #define N_RELOFF N_TRELOFF #define RELOC_FILE "rel_sun4.c" /* width of page size that can be memorprotected log2(getpagesize()) */ #define PAGEWIDTH 12 #define reloc reloc_info_sparc /* in release 4.0 it is SIGSEGV, and release 4.1 it is SIGBUS */ #define INSTALL_MPROTECT_HANDLER \ do {static struct sigaction action; \ action.sa_handler = memprotect_handler; \ action.sa_flags = SA_RESTART | SA_SIGINFO; \ sigemptyset(&action.sa_mask); sigaddset(&action.sa_mask,SIGINT); \ sigaddset(&action.sa_mask,SIGALRM); \ sigaction(SIGSEGV,&action,0); sigaction(SIGBUS,&action,0);} while (0) #include "sparc.h" /* Begin for cmpinclude */ /* #define HAVE_ALLOCA #ifndef __GNUC__ #include #endif */ /* If can mprotect pages and so selective gc will work */ #define SGC /* End for cmpinclude */ /* Sun 4.1 needs to have some cached yp stuff undone at save time */ #define HAVE_YP_UNBIND gcl-2.6.14/h/dec3100.defs0000755000175000017500000000307714360276512013136 0ustar cammcamm# /* copyright W. Schelter 1990 */ # Machine dependent makefile definitions for dec 3100 # gcl 505 worked under Ultrix V3.1C-0 (Rev. 42) with speed=0. -ie no -O # for the lisp files. LBINDIR=/usr/local/bin OFLAG = LIBS = -lm ODIR_DEBUG= NULLFILE = ../h/twelve_null SHELL=/bin/sh # .IGNORE: # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # also defined in `machine'.h file # The one here must be >= the one in the .h file. # It must be a multiple of 0x400000 greater that 0x400000 the # default text start. DBEGIN= c00000 # If you don't plan on linking in a lot of other stuff # like maxima, you can increase the -G 8 to -G 800 or so. # That should be a bit faster.. # We have replaced -DVOL=volatile with -DVOL= since in ultrix 4.2 # the volatile declaration is not correctly implemented. Hopefully # it is not required there. CC = cc -DVOL= -Olimit 798 -G 8 -I${GCLDIR}/o -I/usr/include/bsd LDCC = cc -Wl,-D -Wl,${DBEGIN} # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # incremental loading with -A requires -G 0 # INITFORM=(setq compiler::*cc* "cc -DVOL=volatile -G 0 ") # until volatile works on this machine leave it out. INITFORM=(setq compiler::*cc* "cc -DVOL= -G 0 ") # Use symbolic links SYMB=-s MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a RANLIB= ar lts gcl-2.6.14/h/ld_bind_now.h0000644000175000017500000000065114360276512013653 0ustar cammcamm#include #include #include #include #include if (!getenv("LD_BIND_NOW")) { int i; char **n; for (i=0;envp[i];i++); n=alloca((i+2)*sizeof(*n)); n[i+1]=0; n[i--]="LD_BIND_NOW=t"; for (;i>=0;i--) n[i]=envp[i]; #ifdef GCL_GPROF gprof_cleanup(); #endif errno=0; execve(*argv,argv,n); printf("execve failure %d\n",errno); exit(-1); } gcl-2.6.14/h/eval.h0000755000175000017500000000701514360276512012330 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* eval.h */ /* C control stack */ /* #define CSSIZE 20000 */ #define CSGETA 4000 #ifdef __ia64__ EXTER int *cs_base2; EXTER int *cs_org2; #endif EXTER int *cs_base; EXTER int *cs_org; EXTER int *cs_limit; /* we catch the segmentation fault and check to warn of c stack overflow */ #ifdef AV #ifndef cs_check #define cs_check(something) \ if ((int *)(&something) < cs_limit) \ cs_overflow() #endif #endif #ifdef MV #endif /* bind template */ struct bind_temp { object bt_var; object bt_spp; object bt_init; object bt_aux; }; #define check_symbol(x) \ if (type_of(x) != t_symbol) \ not_a_symbol(x) #define check_var(x) \ if (type_of(x) != t_symbol || \ (enum stype)(x)->s.s_stype == stp_constant) \ not_a_variable(x) #define eval_assign(to, form) \ { \ object *old_top = vs_top; \ \ eval(form); \ to = vs_base[0]; \ vs_top = old_top; \ } #define MMcall(x) ({extern int Rset;int rset=Rset;if (!rset) {ihs_check;ihs_push(x);}(*(x)->cf.cf_self)();if (!rset) ihs_pop();}) #define MMccall(x) ({extern int Rset;int rset=Rset;if (!rset) {ihs_check;ihs_push(x);}(*(x)->cc.cc_self)(x);if (!rset) ihs_pop();}) #define MMcons(a,d) make_cons((a),(d)) #define MMcar(x) (x)->c.c_car #define MMcdr(x) (x)->c.c_cdr #define MMcaar(x) (x)->c.c_car->c.c_car #define MMcadr(x) (x)->c.c_cdr->c.c_car #define MMcdar(x) (x)->c.c_car->c.c_cdr #define MMcddr(x) (x)->c.c_cdr->c.c_cdr #define MMcaaar(x) (x)->c.c_car->c.c_car->c.c_car #define MMcaadr(x) (x)->c.c_cdr->c.c_car->c.c_car #define MMcadar(x) (x)->c.c_car->c.c_cdr->c.c_car #define MMcaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car #define MMcdaar(x) (x)->c.c_car->c.c_car->c.c_cdr #define MMcdadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr #define MMcddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr #define MMcdddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr #define MMcaaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_car #define MMcaaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_car #define MMcaadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_car #define MMcaaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car #define MMcadaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_car #define MMcadadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car #define MMcaddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car #define MMcadddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car #define MMcdaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_cdr #define MMcdaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr #define MMcdadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr #define MMcdaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr #define MMcddaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr #define MMcddadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr #define MMcdddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr #define MMcddddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr #define MMnull(x) ((x)==Cnil) gcl-2.6.14/h/sparc.h0000755000175000017500000000577614360276512012525 0ustar cammcamm #ifdef __GNUC__ /* have assembler macros */ #define add_carry(x,y,h) \ ({ ulong __res,__x =(x),__y=(y); \ asm volatile( \ "addcc %2,%3,%0 \taddx %1,%%g0,%1"\ : "=r" (__res),"=r" (h) \ : "r" (__x) , "rn" (__y),"1" (h) ); \ __res;}) /* SET_MACHINE_CARRY Set the machine carry flag if overflow = 1 otherwise clear it. */ #define SET_MACHINE_CARRY(overflow) \ asm volatile("subcc %%g0,%0,%%g0" \ : :"r" (overflow)) /* SET_OVERFLOW Set the overflow = the current carry code Note that machine loads and mov's should not affect the carry code. */ #define SET_OVERFLOW \ asm volatile("addx %%g0,%%g0,%0" \ : "=r" (overflow)) #define ADDXCC(u,v) \ ({ulong res; asm("addxcc %1,%2,%0" \ : "=r" (res): \ "r" (u),"r" (v)); res;}) #define SUBXCC(u,v) \ ({ulong res; asm("subxcc %1,%2,%0" \ : "=r" (res): \ "r" (u),"r" (v)); res;}) /* get a copy of mulul3 included for when inlining not there */ #define NEED_MULUL3 #define mulul(a,b,__hi) \ ({unsigned plong __x=(a),__y=(b); \ asm(" or %0,%3,%%o4 mov %0,%%y andncc %%o4,0xfff,%%g0 be 2f andcc %%g0,%%g0,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%%g0,%%o4 tst %3 bl,a 1f add %%o4,%0,%%o4 1: mov %%o4,%1 b 3f rd %%y,%0 2: clr %1 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%3,%%o4 mulscc %%o4,%%g0,%%o4 rd %%y,%%o5 sll %%o4,12,%%o4 srl %%o5,20,%%o5 or %%o5,%%o4,%0 3: " \ : "=r" (__x),"=&r" (__hi): \ "0" (__x),"r" (__y): \ "%o4","%o5"); __x;}) /* "y" should be hear in that it is munged */ /* the above '=&r' indicates that the register for _hi may NOT be the same reg as used by __y.*/ #else /* no __GNUC__ */ #endif gcl-2.6.14/h/compbas2.h0000755000175000017500000000000014360276512013072 0ustar cammcammgcl-2.6.14/h/elf64_ppcle_reloc.h0000644000175000017500000000252314360276512014664 0ustar cammcamm#define R_PPC64_PLTSEQ 119 /*FIXME not in elf.h*/ #define R_PPC64_PLTCALL 120 #define ha(x_) ((((x_) >> 16) + (((x_) & 0x8000) ? 1 : 0)) & 0xffff) #define lo(x_) ((x_) & 0xffff) case R_PPC64_REL16_HA: store_val(where,MASK(16),ha(s+a-p)); break; case R_PPC64_PLT16_HA: gote=got+sym->st_size-1; *gote=s+a; massert(toc); store_val(where,MASK(16),ha((ul)gote-toc->st_value)); break; case R_PPC64_PLT16_LO_DS: gote=got+sym->st_size-1; *gote=s+a; massert(toc); store_val(where,MASK(16),lo((ul)gote-toc->st_value));/*>>2*/ break; case R_PPC64_PLTSEQ: case R_PPC64_PLTCALL: break; case R_PPC64_TOC16_HA: massert(toc); store_val(where,MASK(16),ha(s+a-toc->st_value)); break; case R_PPC64_TOC16_LO_DS: massert(toc); store_val(where,MASK(16),lo(s+a-toc->st_value));/*>>2*/ break; case R_PPC64_REL16_LO: store_val(where,MASK(16),lo(s+a-p)); break; case R_PPC64_TOC16_LO: massert(toc); store_val(where,MASK(16),lo(s+a-toc->st_value)); break; case R_PPC64_ADDR64: store_val(where,~0L,(s+a)); break; case R_PPC64_TOC: massert(toc); store_val(where,~0L,toc->st_value); break; case R_PPC64_REL32: store_val(where,MASK(32),(s+a-p)); break; gcl-2.6.14/h/lex.h0000755000175000017500000000261214360276512012167 0ustar cammcamm/* (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. Copying of this file is authorized to users who have executed the true and proper "License Agreement for Kyoto Common LISP" with SIGLISP. */ /* lex.h lexical environment */ EXTER object *lex_env; /* VS | | |---------------| lex_env ------> | lex-var | : lex_env[0] |---------------| | lex-fd | : lex_env[1] |---------------| | lex-tag | : lex_env[2] |---------------| | | | | | | lex-var: (symbol value) ; for local binding (.... or ....) (symbol) ; for special binding lex-fd: (fun-name 'FUNCTION' function) (.... or ...) (macro-name 'MACRO' expansion-function) lex-tag: (tag 'TAG' frame-id) (.... or ....) (block-name 'BLOCK' frame-id) where 'FUN' is the LISP object with pname FUN, etc. */ #define lex_copy() if (ihs_top>=ihs_org) ihs_top->ihs_base = vs_top; \ vs_push(lex_env[0]); \ vs_push(lex_env[1]); \ vs_push(lex_env[2]); \ lex_env = vs_top - 3 #define lex_new() if (ihs_top>=ihs_org) ihs_top->ihs_base = vs_top; \ lex_env = vs_top; \ vs_top[0] = vs_top[1] = vs_top[2] = Cnil; \ vs_top += 3 #define lex_var_sch(name) assoc_eq((name),lex_env[0]) #define lex_fd_sch(name) assoc_eq((name),lex_env[1]) gcl-2.6.14/h/mp386.h0000755000175000017500000000101414360276512012247 0ustar cammcamm#define MP386 #include "att.h" #include "386.h" #define IEEEFLOAT #define I386 #define ADDITIONAL_FEATURES \ ADD_FEATURE("I386"); ADD_FEATURE("SYSTEM-V") #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if (real_maxpage > MAXPAGE) \ real_maxpage = MAXPAGE; /* include some low level routines for maxima */ #define CMAC #define RELOC_FILE "rel_coff.c" /* FIONREAD not supported */ #undef LISTEN_FOR_INPUT /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/solaris-i386.h0000755000175000017500000000157014360276512013544 0ustar cammcamm#define I386 #define LITTLE_END #define ElfW(a) Elf32_ ## a #if !defined(HAVE_LIBBFD) && !defined(USE_DLOPEN) #define __ELF_NATIVE_CLASS 32 #include #endif #include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("SPARC") #define SPARC #define SGC #define PTR_ALIGN 8 #undef LISTEN_FOR_INPUT #undef SIG_UNBLOCK_SIGNALS #define NO_SYSTEM_TIME_ZONE void bcopy (const void *,void *,size_t); void bzero(void *,size_t); int bcmp(const void *,const void *,size_t); #define NULL_OR_ON_C_STACK(x) ((unsigned long)x=(GEN)bot)&&(RAVYZARC<(GEN)top))) #define copyifstack(x) (RAVYZARC=(GEN)(x),((RAVYZARC>=(GEN)bot)&&(RAVYZARC<(GEN)top))?lcopy(RAVYZARC):(plong)RAVYZARC) #define odd(x) (x & 1) #define mpodd(x) (signe(x) && odd(mant(x,lgef(x) - 2))) /* alglin.c */ GEN gtrans(),gscalmat(),gscalsmat(),gaddmat(),gaddsmat(); GEN ker(),keri(),kerreel(),eigen(),hess(),carhess(); GEN gauss(),invmat(),det(),detreel(),det2(),caract(),caradj(),adj(),trace(); GEN assmat(),gnorm(),gnorml2(),gconj(),concat(),idmat(); GEN extract(),matextract(),gtomat(),invmulmat(),invmulmatreel(),invmatreel(); GEN sqred(),sqred1(),signat(),jacobi(); plong rank(); /* anal.c */ GEN lisexpr(),readexpr(),lisseq(),readseq(); /* arith.c */ GEN racine(),mppgcd(),mpfact(),sfcont(),fc(),bezout(),chinois(); GEN mpinvmod(),puissmodulo(),fibo(),bigprem(),prime(),primes(); GEN phi(),decomp(),auxdecomp(),smallfact(),boundfact(),sumdiv(),sumdivk(),numbdiv(); GEN ellfacteur(),classno(),classno2(),classno3(),fundunit(),regula(); GEN compose(),sqcomp(),qf(),compose2(),sqcomp2(),qfred1(),primeform(); GEN binaire(),order(),gener(),divisors(); plong kronecker(),krosg(),krogs(),kross(),kro8(); plong mu(),omega(),bigomega(),hil(),carreparfait(); plong isprime(),ispsp(),issquarefree(),isfundamental(); byteptr initprimes(); /* base.c */ GEN base(),discf(),hnf(),smith(); /* bibli1.c */ GEN tayl(),legendre(),tchebi(),hilb(),pasc(),laplace(); GEN gprec(),convol(),ggrando(),gconvsp(),gaminc(); GEN lll(),lllrat(),lllgram(),binome(),gscal(); GEN lindep(),lindep2(),algdep(),changevar(),ordred(); GEN polrecip(),reorder(),sort(),indexsort(),polred(),polsym(); /* bibli2.c */ GEN somme(),produit(),suminf(),prodinf(),prodinf1(),prodeuler(); GEN vecteur(),vvecteur(),matrice(),divsomme(); GEN qromb(),qromo(),qromi(),rombint(); GEN polint(),plot(),ploth(),ploth2(),zbrent(),sumalt(),sumpos(); GEN forpari(),forstep(),fordiv(),forprime(),ghell(),ghell2(),ghell3(); GEN initell(),zell(),coordch(),pointch(); GEN addell(),subell(),powell(),matell(),ordell(),apell(),apell1(),apell2(); int oncurve(); void eulsum(); /* es.c */ void sor(),brute(),texe(); /* gen1.c */ GEN gadd(),gsub(),gmul(),gdiv(); /* gen2.c gen3.c */ GEN gcopy(),gclone(),cgetg(),cgetp(),gaddpex(); GEN greffe(),gopsg2(),gopgs2(),co8(),cvtop(),compo(),gsqr(); GEN gneg(),gabs(),gmax(),gmin(),ginv(),denom(),numer(),lift(); GEN gmulsg(),gdivgs(),gmodulo(),gmodulcp(); GEN gmod(),gshift(),gmul2n(),gpuigs(),gpui(); GEN gsubst(),deriv(),integ(),recip(),ground(),gcvtoi(),grndtoi(); GEN gceil(),gfloor(),gfrac(),gtrunc(),gdivent(),gdiventres(); GEN gdivmod(),geval(),glt(),gle(),ggt(),gge(),geq(),gne(); GEN gand(),gor(),glength(),truecoeff(); GEN gtopoly(),gtoser(),gtovec(),dbltor(); void gop0z(),gop1z(),gop2z(),gops2gsz(),gops2sgz(),gops2ssz(); void gop3z(),gops1z(),gopsg2z(),gopgs2z(); plong taille(),gexpo(),gsigne(),gcmp(),gtolong(),gegal(); plong polegal(),tdeg(),ismonome(),iscomplex(),gvar(),ggval(); double rtodbl(),gtodouble(); /* init.c */ GEN newbloc(),geni(); plong marklist(); void init(),killbloc(),newvalue(),killvalue(); void err(),recover(),changevalue(); /* polarit.c */ GEN ginvmod(),gred(),gdeuc(),gres(),poldivres(); GEN poleval(),roots(),ggcd(),gbezout(),vecbezout(),glcm(); GEN polgcd(),srgcd(),polgcdnun(),content(),primpart(),psres(); GEN factmod(),rootmod(),decpol(),factor(),factpol(),factpol2(); GEN subres(),discsr(),quadpoly(),quadgen(),bezoutpol(),polinvmod(); plong sturm(); void gredsp(); /* trans.c */ GEN greal(),gimag(),teich(),agm(),palog(); GEN mpsqrt(),gsqrt(),mpexp1(),mpexp(),gexp(),logagm(),glogagm(); GEN mplog(),glog(),mpsc1(),mpcos(),gcos(),mpsin(),gsin(); GEN mpaut(),mptan(),gtan(),mpatan(),gatan(),mpasin(),gasin(); GEN mpacos(),gacos(),mparg(),mpch(),gch(),mpsh(),gsh(); GEN mpth(),gth(),mpath(),gath(),mpash(),gash(); GEN garg(),sarg(),mppsi(),gpsi(),transc(),kbessel(),hyperu(); GEN cxpsi(),jbesselh(),gzeta(); GEN kbessel2(),eint1(),gerfc(),eta(),jell(),wf2(),wf(); GEN incgam(),incgam1(),incgam2(),incgam3(),bernreal(),bernvec(); GEN mpach(),gach(),mpgamma(),cxgamma(),ggamma(),mpgamd(),ggamd(),mppi(); GEN mpeuler(),polylog(),dilog(),polylogd(),polylogp(); GEN theta(),thetanullk(); void constpi(),consteuler(),gsincos(); /* version.c */ GEN gerepilc(); void printversion(); gcl-2.6.14/h/linux.defs0000644000175000017500000000336014360276512013226 0ustar cammcamm # notes for redhat 6.0 # the configure should select the compiler GCC=/usr/bin/i386-glibc20-linux-gcc # However for the gcl-tk directory, you must use plain 'gcc' since # that must link with the tcl tk libs which have been compiled with it. # so after configure change to GCC=gcc in the gcl-tk/makefile # Machine dependent makefile definitions for intel 386,486 running linux LBINDIR=/usr/local/bin #OFLAG = -g -Wall #OFLAG = -g -Wall -fomit-frame-pointer -Werror #LIBS = -lm #ODIR_DEBUG= -g -Wall -fomit-frame-pointer -Werror #ODIR_DEBUG= -g -Wall # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # (the -pipe is just since our file system is slow..) #CC = ${GCC} -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -Wall $(EXTRA_CFLAGS) -fomit-frame-pointer -Werror -g # under redhat 6.1 and slackware 7.0 we needed to have this # link be static, but should be ok with the fix to unixport/rsym_elf.c LDCC=${CC} -static LDCC=${CC} # note for linuxaout on an elf machine add -b i486-linuxaout # CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif #ifneq ($(findstring -ldl,$(LIBS)),) #RSYM = #endif SFASL = $(ODIR)/sfasl.o #MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/att.h0000755000175000017500000000510614360276512012170 0ustar cammcamm#define ATT #define AV #define UNIX #define SFASL #define MEM_SAVE_LOCALS \ struct filehdr fileheader;\ struct exec header;\ struct scnhdr sectionheader;\ int diff #define COPY_TO_SAVE \ do{for (;;) { \ n = getc(original); \ if (feof(original)) \ break; \ putc(n, save); \ }}while (0) #define READ_HEADER \ do{ fread(&fileheader, sizeof(fileheader), 1, original); \ fread(&header, sizeof(header), 1, original); \ data_begin = (char *)header.data_start; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ diff = header.a_data - original_data; \ header.a_bss = sbrk(0) - core_end; \ fileheader.f_symptr += diff; \ fwrite(&fileheader, sizeof(fileheader), 1, save);\ fwrite(&header, sizeof(header), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_size += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_paddr += diff; \ sectionheader.s_vaddr += diff; \ sectionheader.s_size = header.a_bss; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ for (n = 4; n <= fileheader.f_nscns; n++) { \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_scnptr) \ sectionheader.s_scnptr += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ }}while(0) #define FILECPY_HEADER filecpy(save, original, header.a_text) #define exec aouthdr #define a_text tsize #define a_data dsize #define a_bss bsize /* Include rather than */ #define HAVE_FCNTL #define NUMBER_OPEN_FILES _NFILE #define INIT_ALLOC \ heap_end = sbrk(0); \ ({fixnum i;if ((i = ((unsigned long)heap_end & (PAGESIZE - 1)))) \ sbrk(PAGESIZE - i);}); \ heap_end = core_end = sbrk(0); #define cs_check(x) /* need to define getwd and friends in unixfsys.c Basically as would need to in ATT*/ #define NEED_GETWD /* if there is no input there return false */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_cnt <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0 /* have sys/ioctl.h */ #define HAVE_IOCTL gcl-2.6.14/h/fixnum.h0000644000175000017500000000460214360276512012703 0ustar cammcamm#if defined (LOW_SHFT) #define LOW_IM_FIX (1L<<(LOW_SHFT-1)) #define INT_IN_BITS(a_,b_) ({fixnum _a=(fixnum)(a_);_a>>(b_)==_a>>(CHAR_SIZE*SIZEOF_LONG-1);}) #define make_imm_fixnum(a_) ((object)(fixnum)a_) #define fix_imm_fixnum(a_) ((fixnum)a_) #define mark_imm_fixnum(a_) ((a_)=((object)((fixnum)(a_)+(LOW_IM_FIX<<1)))) #define unmark_imm_fixnum(a_) ((a_)=((object)((fixnum)(a_)-(LOW_IM_FIX<<1)))) #define is_imm_fixnum(a_) ((fixnum)(a_)<(fixnum)OBJNULL) #define is_unmrkd_imm_fixnum(a_) ((fixnum)(a_)>1)))) #define fix_imm_fixnum(a_) ((fixnum)(((ufixnum)(a_))-(IM_FIX_BASE+(IM_FIX_LIM>>1)))) #define mark_imm_fixnum(a_) ((a_)=((object)(((ufixnum)(a_)) | IM_FIX_LIM))) #define unmark_imm_fixnum(a_) ((a_)=((object)(((ufixnum)(a_)) &~ IM_FIX_LIM))) #define is_imm_fixnum(a_) (((ufixnum)(a_))>=IM_FIX_BASE) #define is_unmrkd_imm_fixnum(a_) (is_imm_fixnum(a_)&&!is_marked_imm_fixnum(a_)) #define is_marked_imm_fixnum(a_) (((ufixnum)(a_))&IM_FIX_LIM) #define is_imm_fix(a_) (!(((a_)+(IM_FIX_LIM>>1))&-IM_FIX_LIM)) /* #define un_imm_fixnum(a_) ((a_)=((object)(((fixnum)(a_))&~(IM_FIX_BASE)))) */ #else #define make_imm_fixnum(a_) make_fixnum1(a_) #define fix_imm_fixnum(a_) ((a_)->FIX.FIXVAL) #define mark_imm_fixnum(a_) #define unmark_imm_fixnum(a_) #define is_imm_fixnum(a_) 0 #define is_unmrkd_imm_fixnum(a_) 0 #define is_marked_imm_fixnum(a_) 0 #define is_imm_fix(a_) 0 /* #define un_imm_fixnum(a_) */ #endif #define make_fixnum(a_) ({register fixnum _q1=(a_);register object _q4; \ _q4=is_imm_fix(_q1) ? make_imm_fixnum(_q1) : make_fixnum1(_q1);_q4;}) #define fix(a_) ({register object _q2=(a_);register fixnum _q3; \ _q3=is_imm_fixnum(_q2) ? fix_imm_fixnum(_q2) : (_q2)->FIX.FIXVAL;_q3;}) #define Mfix(a_) fix(a_) #define small_fixnum(a_) make_fixnum(a_) /*make_imm_fixnum(a_)*/ #define set_fix(a_,b_) ((a_)->FIX.FIXVAL=(b_)) gcl-2.6.14/h/rios.defs0000755000175000017500000000233714360276512013051 0ustar cammcammLBINDIR=/usr/bin #defs for the makefiles LD_ORDINARY_CC= cc RANLIB=true OFLAG = -O LIBS = -lm -lg # where to find libX11.a and libtcl.a and their include files: #LIBS_X11_TK= -lX11 -L/usr/local/lib -L/p/lib -ltcl -ltk #TK_INCLUDE_DIR=-I/p/include/ #X11_INCLUDE_DIR=-I/usr/openwin/include LIBS = -lm -bexport:${GCLDIR}/unixport/aix_exports ODIR_DEBUG= SHELL=/bin/sh .IGNORE: CC = cc -qlanglvl=ext -qnoprint -DCOM_LENG= -DVOL=volatile -I$(GCLDIR)/o -bnso -bI:/lib/syscalls.exp -Wl,-D0 -H4096 -qchars=signed LDCC = $(CC) -Wl,-bfilelist # if you add to EXTRAS: # Remember you must add the names of any functions you want to reference # in lisp code, to unixport/aix_exports or add your own exports file to # LIBS above EXTRA_LIB = fsavres.o GCLIB = ${ODIR}/gcllib.a CFLAGS = -c $(DEFS) -I../h # fast loading RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios1.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a # version of gcl with -pg profiling. (cd unixport ; make kcp) KCP=kcp-aix gcl-2.6.14/h/hp300-bsd.defs0000755000175000017500000000144114360276512013470 0ustar cammcamm # Machine dependent makefile definitions for hp300 running 4.3bsd(mt xinu) LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm -lg ODIR_DEBUG= # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC = gcc -fwritable-strings -msoft-float -DVOL=volatile -I$(GCLDIR)/o # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # Use the mp.s file on 68k machine MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd gcl-2.6.14/h/ptable.h0000755000175000017500000000241714360276512012651 0ustar cammcamm/* format of a rsyms output file: struct lsymbol_table tab; gives number of symbols, and sum of length of strings addr,char[],addr,char[],... This can be read since the addr is sizeof(int) and the char[] is null terminated, immediately followed by and addr... there are tab.n_symbols pairs occurring. */ #ifndef HEADER_SEEK #define HEADER_SEEK(x) #endif typedef unsigned long addr; struct node{ const char *string; addr address; #ifdef AIX3 unsigned short tc_offset; #endif }; struct lsymbol_table{ unsigned int n_symbols ; unsigned int tot_leng;}; #define SYM_ADDRESS(table,i) table.ptable[i].address #define SYM_STRING(table,i) table.ptable[i].string #define SYM_TC_OFF(table,i) ((*(table).ptable))[i].tc_offset /* typedef struct node *TABL; */ /* gcc does not like typedef struct node TABL[];*/ typedef struct node TABL[]; struct string_address_table { struct node *ptable; unsigned int length; struct node *local_ptable; unsigned int local_length; unsigned int alloc_length; }; #if !defined(HAVE_LIBBFD) && !defined(SPECIAL_RSYM) #error Need either BFD or SPECIAL_RSYM #endif #ifdef SPECIAL_RSYM struct string_address_table c_table; #else struct bfd_link_info link_info; #endif struct string_address_table combined_table; #define PTABLE_EXTRA 20 gcl-2.6.14/h/notcomp.h0000755000175000017500000002745314360276512013070 0ustar cammcamm #define CHAR_CODE_LIMIT 256 #define READ_TABLE_SIZE CHAR_CODE_LIMIT #define ARRAY_RANK_LIMIT 63 void enter_mark_origin() ; EXTER int *cs_org; EXTER int GBC_enable; #define CHAR_SIZE 8 EXTER object sSAnotify_gbcA; /* symbols which are not needed in compiled lisp code */ EXTER int interrupt_flag,interrupt_enable; void install_default_signals(); /* void sigint(),sigalrm(); */ void segmentation_catcher(); EXTER int gc_enabled, saving_system; EXTER object lisp_package,user_package; EXTER char *core_end; EXTER int catch_fatal; EXTER long real_maxpage; char *getenv(); EXTER char *this_lisp; EXTER char stdin_buf[],stdout_buf[]; EXTER object user_package; #define TRUE 1 #define FALSE 0 #define GET_OPT_ARG(min,max) \ va_list ap; \ object opt_arg[max - min]; object *__p= opt_arg ;\ int _i=min, _nargs = VFUN_NARGS ; \ va_start(ap); \ if (_nargs < min || (_nargs > max)) FEerror("wrong number of args"); \ while(_i++ <= max) { if (_i > _nargs) *__p++ = Cnil; \ else *__p++ = va_arg(ap,object);} \ va_end(ap) #ifndef NO_DEFUN #undef DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname /* eg. A function taking from 2 to 8 args returning object the first args is object, the next 6 int, and last defaults to object. note the return type must also be put in the signature. DEFUN("AREF",object,fSaref,SI,2,8,NONE,oo,ii,ii,ii) */ /* for defining old style */ #define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old,doc) \ ret fname (); \ void old(void) \ { Iinvoke_c_function_from_value_stack(fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56))); \ return;} \ ret fname #define MAKEFUN(pack,string,fname,argd) \ (pack == SI ? SI_makefun(string,fname,argd) : \ pack == LISP ? LISP_makefun(string,fname,argd) : \ error("Bad pack variable in MAKEFUN\n")) #define MAKEFUNM(pack,string,fname,argd) \ (pack == SI ? SI_makefunm(string,fname,argd) : \ pack == LISP ? LISP_makefunm(string,fname,argd) : \ error("Bad pack variable in MAKEFUN\n")) #define SI 0 #define LISP 1 #undef FFN #undef LFD #undef FFD #undef STATD #undef make_function #undef make_macro_function #undef make_si_function #undef make_si_sfun #undef make_special_form #ifdef STATIC_FUNCTION_POINTERS #define FFN(a_) Mjoin(a_,_static) #define LFD(a_) static void FFN(a_) (); void a_ () { FFN(a_)();} static void FFN(a_) #define FFD(a_) static void FFN(a_) (object); void a_ (object x) { FFN(a_)(x);} static void FFN(a_) #define make_function(a_,b_) make_function_internal(a_,FFN(b_)) #define make_macro_function(a_,b_) make_macro_internal(a_,FFN(b_)) #define make_si_function(a_,b_) make_si_function_internal(a_,FFN(b_)) #define make_special_form(a_,b_) make_special_form_internal(a_,FFN(b_)) #define make_si_special_form(a_,b_) make_si_special_form_internal(a_,FFN(b_)) #define make_si_sfun(a_,b_,c_) make_si_sfun_internal(a_,FFN(b_),c_) #define STATD static #else #define FFN(a_) (a_) #define LFD(a_) void a_ #define FFD(a_) void a_ #define make_function(a_,b_) make_function_internal(a_,b_) #define make_macro_function(a_,b_) make_macro_internal(a_,b_) #define make_si_function(a_,b_) make_si_function_internal(a_,b_) #define make_special_form(a_,b_) make_special_form_internal(a_,b_) #define make_si_special_form(a_,b_) make_si_special_form_internal(a_,b_) #define make_si_sfun(a_,b_,c_) make_si_sfun_internal(a_,b_,c_) #define STATD #endif #define DEFUN_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) STATD ret FFN(fname) args;\ void Mjoin(fname,_init) () {\ MAKEFUN(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\ }\ STATD ret FFN(fname) args #define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) STATD ret FFN(fname) args;\ void Mjoin(fname,_init) () {\ MAKEFUNM(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\ }\ STATD ret FFN(fname) args /* eg. A function taking from 2 to 8 args returning object the first args is object, the next 6 int, and last defaults to object. note the return type must also be put in the signature. DEFUN("AREF",object,fSaref,SI,2,8,NONE,oo,ii,ii,ii) */ /* for defining old style */ #define DEFUNO_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ STATD ret FFN(fname) args; \ void Mjoin(fname,_init) () {\ MAKEFUN(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\ }\ LFD(old)(void) \ { Iinvoke_c_function_from_value_stack((object (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56))); \ return;} \ STATD ret FFN(fname) args #define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ STATD ret FFN(fname) args; \ void Mjoin(fname,_init) () {\ MAKEFUNM(pack,string,(ret (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));\ }\ LFD(old)(void) \ { Iinvoke_c_function_from_value_stack((object (*)())FFN(fname),F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56))); \ return;} \ STATD ret FFN(fname) args /* these will come later */ #define DEFUNL DEFUN /* these are needed to be linked in to be called by incrementally loaded code */ #define DEFCOMP(type,fun) type fun #define DEFVAR(name,cname,pack,val,doc) object cname #define DEFCONST(name,cname,pack,val,doc) object cname #define DEF_ORDINARY(name,cname,pack,doc) object cname #define DO_INIT(x) #endif /* NO_DEFUN */ object type_name(); object fSincorret_type(); #define TYPE_OF(x) type_of(x) /* For a faster way of checking if t0 is in several types, is t0 a member of types t1 t2 t3 TS_MEMBER(t0,TS(t1)|TS(t2)|TS(t3)...) */ #define TS(s) (1<a.a_displaced) /* List of arrays whose bodies are displaced to X */ #define DISPLACED_FROM(x) Mcdr(x->a.a_displaced) #define FIX_CHECK(x) (Mfix(Iis_fixnum(x))) #define INITIAL_TOKEN_LENGTH 512 /* externals not needed by cmp */ /* print.d */ EXTER bool PRINTpackage; EXTER bool PRINTstructure; /* from format.c */ EXTER VOL object fmt_stream; EXTER VOL int ctl_origin; EXTER VOL int ctl_index; EXTER VOL int ctl_end; EXTER object * VOL fmt_base; EXTER VOL int fmt_index; EXTER VOL int fmt_end; typedef jmp_buf *jmp_bufp; EXTER jmp_bufp VOL fmt_jmp_bufp; EXTER VOL int fmt_indents; EXTER VOL object fmt_string; EXTER object endp_temp; /* eval */ EXTER int eval1 ; /* list.d */ EXTER bool in_list_flag; EXTER object test_function; EXTER object item_compared; bool (*tf)(); EXTER object key_function; object (*kf)(); object (*car_or_cdr)(); /* string.d */ EXTER bool left_trim; EXTER bool right_trim; int (*casefun)(); #define Q_SIZE 256 #define IS_SIZE 256 struct printStruct { short p_queue[Q_SIZE]; short p_indent_stack[IS_SIZE]; int p_qh; int p_qt; int p_qc; int p_isp; int p_iisp;}; EXTER struct printStruct *printStructBufp; #define SETUP_PRINT_DEFAULT(x) \ struct printStruct printStructBuf; \ struct printStruct * old_printStructBufp = printStructBufp; \ printStructBufp = &printStructBuf; \ setupPRINTdefault(x) #define CLEANUP_PRINT_DEFAULT \ cleanupPRINT(); \ printStructBufp = old_printStructBufp /* on most machines this will test in one instruction if the pointer is on the C stack or the 0 pointer but if the CSTACK_ADDRESS is not negative then we can't use this cheap test.. */ #ifndef NULL_OR_ON_C_STACK #define NULL_OR_ON_C_STACK(x) ({\ /* if ((void *)(x)=(void *)core_end));}) #endif /* NULL_OR_ON_C_STACK */ /* more readable name */ #define siScomma sSY EXTER object sSY; #define inheap(pp) ((char *)(pp) < heap_end) char *lisp_copy_to_null_terminated(); int gcl_init_cmp_anon(void); #undef SAFE_READ #undef SAFE_FREAD #ifdef SGC #define SAFE_READ(a_,b_,c_) \ ({int _a=(a_),_c=(c_);char *_b=(b_);extern int sgc_enabled;\ if (sgc_enabled) memset(_b,0,_c); \ read(_a,_b,_c);}) #define SAFE_FREAD(a_,b_,c_,d_) \ ({int _b=(b_),_c=(c_);char *_a=(a_);FILE *_d=(d_);extern int sgc_enabled; \ if (sgc_enabled) memset(_a,0,_b*_c); \ fread(_a,_b,_c,_d);}) #else #define SAFE_READ(a_,b_,c_) read((a_),(b_),(c_)) #define SAFE_FREAD(a_,b_,c_,d_) fread((a_),(b_),(c_),(d_)) #endif #include "gmp_wrappers.h" char FN1[PATH_MAX],FN2[PATH_MAX],FN3[PATH_MAX],FN4[PATH_MAX],FN5[PATH_MAX]; #define coerce_to_filename(a_,b_) coerce_to_filename1(a_,b_,sizeof(b_)) #include #define massert(a_) ({errno=0;if (!(a_)) assert_error(#a_,__LINE__,__FILE__,__FUNCTION__);}) extern bool writable_malloc; #define writable_malloc_wrap(f_,rt_,a_...) ({rt_ v;bool w=writable_malloc;writable_malloc=1;v=f_(a_);writable_malloc=w;v;}) #define fopen(a_,b_) writable_malloc_wrap(fopen,FILE *,a_,b_) #define Mcar(x) (x)->c.c_car #define Mcdr(x) (x)->c.c_cdr #define Mcaar(x) (x)->c.c_car->c.c_car #define Mcadr(x) (x)->c.c_cdr->c.c_car #define Mcdar(x) (x)->c.c_car->c.c_cdr #define Mcddr(x) (x)->c.c_cdr->c.c_cdr #define Mcaaar(x) (x)->c.c_car->c.c_car->c.c_car #define Mcaadr(x) (x)->c.c_cdr->c.c_car->c.c_car #define Mcadar(x) (x)->c.c_car->c.c_cdr->c.c_car #define Mcaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car #define Mcdaar(x) (x)->c.c_car->c.c_car->c.c_cdr #define Mcdadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr #define Mcddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr #define Mcdddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr #define Mcaaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_car #define Mcaaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_car #define Mcaadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_car #define Mcaaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car #define Mcadaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_car #define Mcadadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car #define Mcaddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car #define Mcadddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car #define Mcdaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_cdr #define Mcdaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr #define Mcdadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr #define Mcdaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr #define Mcddaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr #define Mcddadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr #define Mcdddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr #define Mcddddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr #define gethash_with_check(a_,b_) \ ({object _b=(b_);while (type_of(_b)!=t_hashtable) _b=wrong_type_argument(sLhash_table,_b);gethash(a_,_b);}) #define sethash_with_check(a_,b_,c_) \ ({object _b=(b_);while (type_of(_b)!=t_hashtable) _b=wrong_type_argument(sLhash_table,_b);sethash(a_,_b,c_);}) #include "prelink.h" #include #ifdef GCL_GPROF #define prof_block(x) ({\ sigset_t prof,old; \ int r; \ sigemptyset(&prof); \ sigaddset(&prof,SIGPROF); \ sigprocmask(SIG_BLOCK,&prof,&old); \ r=x; \ sigprocmask(SIG_SETMASK,&old,NULL); \ r;}) #else #define prof_block(x) x #endif #define psystem(x) prof_block(vsystem(x)) #define pfork() prof_block(fork()) #define pvfork() prof_block(vfork()) #include "error.h" #if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) extern void __gmp_randget_mt (); extern void __gmp_randclear_mt (); extern void __gmp_randiset_mt (); typedef struct {void *a,*b,*c,*d;} gmp_randfnptr_t; EXTER gmp_randfnptr_t Mersenne_Twister_Generator_Noseed; #endif #define collect(p_,f_) (p_)=&(*(p_)=(f_))->c.c_cdr #define READ_STREAM_OR_FASD(strm_) \ type_of(strm_)==t_stream ? read_object_non_recursive(strm_) : fSread_fasd_top(strm_) gcl-2.6.14/h/powerpc-linux.h0000644000175000017500000000171214360276512014210 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr #endif #define SGC #define CLEAR_CACHE_LINE_SIZE 32 #define CLEAR_CACHE do {void *v=memory->cfd.cfd_start,*ve=v+memory->cfd.cfd_size; \ v=(void *)((unsigned long)v & ~(CLEAR_CACHE_LINE_SIZE - 1));\ for (;v #endif /* #include #include #include #include #include #include #include #include #include */ #ifndef plong #define plong int #endif #ifndef EXTER #define EXTER extern #endif #ifdef AIX3 #define ulong ulong_ #endif #define ulong our_ulong #include "gencom.h" #include "erreurs.h" #include "genport.h" extern ulong ABS_MOST_NEGS[]; extern ulong MOST_NEGS[]; #undef ulong #define our_ulong unsigned plong GEN addii(); GEN icopy(); GEN divss(); GEN rcopy(); /* EXTER int in_saved_avma ; */ gcl-2.6.14/h/rios-aix3.h0000755000175000017500000001356314360276512013224 0ustar cammcamm#define ATT #define RIOS #define AIX #define AIX3 #include "att.h" #define USE_ULONG_ #define ADDITIONAL_FEATURES \ ADD_FEATURE("AIX");\ ADD_FEATURE("AIX3");\ ADD_FEATURE("RIOS");\ ADD_FEATURE("BUGGY-CC"); /* These are supplied in rios_ics.s #define USE_C_EXTENDED_DIV #define USE_C_EXTENDED_MUL */ #define IBMRT #define IEEEFLOAT #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if ((real_maxpage > MAXPAGE) || (ulimit(3) < 0)) \ real_maxpage = MAXPAGE; char *sdebug; #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0))\ {int ll; \ if ((ll=(int)(sbrk(0) - core_end)) < PAGESIZE) \ {sbrk(PAGESIZE - ll); \ \ core_end = sbrk(0); }\ else \ error("Someone allocated my memory!");} \ if (core_end != (sdebug=sbrk(PAGESIZE*(n - m)))) #define N_DATADDR(header) #define DATA_BEGIN (char *)header.a_dbase #define PAGEWIDTH 12 /* I don't know why all the bsd versions are subtracting this off I thought the header.a_text was the actual size of the text not including the header */ #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) /* smallest address data can occur */ /* #define DBEGIN 0x20000000 */ #define FIX_ADDRESS(jj) \ do {int del = (int) data_load_addr - DBEGIN; \ if (del && (0x20000000 & jj)) jj += del; \ {unsigned short x ; fread(&x,sizeof(short),1,symin); \ SYM_TC_OFF(c_table,i) = x;} \ } while(0) /* #define SYM_EXTERNAL_P(sym) (((sym)->n_sclass & (~N_SECT)) == C_EXT) #define SYM_UNDEF_P(sym) (((sym)->n_sclass & N_SECT) == N_UNDF) */ #define N_SECTION(sym) (((struct syment *)sym)->n_scnum) #define N_TYPE N_SECT /* the header is regared as part of the text */ #define N_RELOFF(header) A_TRELPOS(header) #define SYMNMLEN 8 /* in aix we must use the pointer to the constant pool for the init_code, not the actual pointer to the code. */ #define CALL_INIT \ { FUNC at=(FUNC)(init_address + memory->cfd.cfd_start ); \ if (at==0 || *(char **)at!= memory->cfd.cfd_start) \ FEerror("init code constant pool bad"); \ (*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, data);} /* find the first symbol in the data section: It should begin with with "_init_" and correspond to the beginning of the pcp pool for the init function..*/ #define DATA_NSCN 4 /* the section number of the data section : text,pad,data,...*/ #define FIND_INIT \ { if (*ptr==0 && (N_SECTION(sym) == DATA_NSCN ) && \ ((sym)->n_sclass == C_EXT) &&\ sym->n_value ) \ { char tem [9]; \ char *str=SYM_NAME(sym); \ dprintf(find init: %s ,str); \ if (str[0]=='i' && str[1]=='n' && str[2]=='i' && str[3]== 't' \ && str[4]=='_' && str[strlen(str)-1] !='X') \ *ptr= sym->n_value ; \ else {/* printf("The first data symbol was not the init"); */} \ }} #define RELOC_FILE "rel_rios.c" #define GETCWD /* the system defines a different getwd */ #define getwd ourgetwd /* these two symbols are too long for the rt pl8cc compiler */ #define check_type_or_pathname_string_symbol_stream check_type_or_path_or_strm #define check_type_or_Pathname_string_symbol check_type_or_path_sym #define TSor_pathname_string_symbol_stream TSor_path_string_sym_strm #define check_type_or_symbol_string_package check_type_or_sym_str_pack #ifdef IN_UNIXFSYS #define BSD #undef NEED_GETWD #undef ATT #endif #define NOFREE_ERR /* #define UNIXSAVE "saveaix3.c" */ #define UNIXSAVE "unexaix.c" #define ISCOFF(x) (x==479) /* Should really use this */ /* #define TEXT_NSCN (fileheader.f_opthdr > 28 ? header.o_sntext : 1) #define DATA_NSCN (fileheader.f_opthdr > 28 ? header.o_sndata : 2) #define BSS_NSCN (fileheader.f_opthdr > 28 ? header.o_snbss : 3) */ #define TEXT_NSCN 2 #define DATA_NSCN 4 #define BSS_NSCN 5 #define SYM_EXTERNAL_P(sym) ((sym)->n_sclass == C_EXT) #define EXT_and_TEXT_BSS_DAT(p) \ ( SYM_EXTERNAL_P(p) && \ ((p)->n_scnum == TEXT_NSCN || (p)->n_scnum == BSS_NSCN || \ (p)->n_scnum == DATA_NSCN )) #define CLEAR_CACHE do{extern system(),myics(); myics();\ system("true"); \ if (*next_toc_addresses_to_relocate) \ printf("did not relocate all toc addresses"); \ }while(0); /* Begin for cmpinclude */ #ifdef __GNUC__ # define alloca __builtin_alloca #else #pragma alloca #endif /* make signals stay installed, not lapse every time the signal is sent */ #define signal sigset /* NOTE: If you don't have the system call mprotect DON'T define this. I have added it to my own kernel. */ /* If you define this you must make available mprotect system call for the kernel. See aix3_mprotect directory. */ /* #define SGC #define GET_FAULT_ADDR(x,y,c,d) getfault() */ #define QUICK_DIV(x,y,h,hi)\ if ((int)y > 0 && y > h << 1) \ {return divsl3(x,y,hi);} /* _setjmp and _longjmp exist on bsd and are more efficient and handle the C stack which is all we need. [I think!] */ /* #define setjmp _setjmp #define longjmp _longjmp */ /* setjmp only lets you jump in one direction upwards in address */ #define SETJMP_ONE_DIRECTION /* End for cmpinclude */ /* if there is no input there return false */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_cnt <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0 /* have sys/ioctl.h */ #define HAVE_IOCTL #define HAVE_SIGACTION /* #define HAVE_XDR */ #define SHARP_EQ_CONTEXT_SIZE 1024 #undef VSSIZE #define VSSIZE 81520 #if defined(IN_SOCKETS) || defined(IN_GUIS) #include #undef bzero #define bzero(b,len) memset(b,0,len) #endif /* test a memory address */ #define NULL_OR_ON_C_STACK(x) ( x == 0 || (((unsigned int) x) >= 0x2f000000 )) gcl-2.6.14/h/elf32_mips_reloc_special.h0000644000175000017500000000754314360276512016233 0ustar cammcamm#include static ul gpd,ggot,ggote,can_gp; static Rel *hr; typedef struct { ul addr_hi,addr_lo,jr,nop; } mips_26_tramp; static int write_26_stub(ul s,ul *got,ul *gote) { static mips_26_tramp t1={(0xf<<26)|(0x0<<21)|(0x19<<16), /*lui t9*/ (0xe<<26)|(0x19<<21)|(0x19<<16), /*ori t9,t9 */ 0x03200008, /*jr t9*/ 0x00200825}; /*mv at,at */; mips_26_tramp *t=(void *)gote; *t=t1; t->addr_hi|=s>>16; t->addr_lo|=s&0xffff; return 0; } typedef struct { ul entry,addr_hi,addr_lo,lw,jr,lwcan; } call_16_tramp; static int write_stub(ul s,ul *got,ul *gote) { static call_16_tramp t1={0, (0xf<<26)|(0x0<<21)|(0x19<<16), /*lui t9*/ (0xe<<26)|(0x19<<21)|(0x19<<16), /*ori t9,t9 */ (0x23<<26)|(0x19<<21)|(0x19<<16), /*lw t9,(0)t9*/ 0x03200008, /*jr t9*/ /*stub addresses need veneer setting gp to canonical*/ (0x23<<26)|(0x1c<<21)|(0x1c<<16)};/*lw gp,(0)gp*/ call_16_tramp *t=(void *)gote++; *t=t1; *got=can_gp; t->entry=(ul)gote; t->addr_hi|=s>>16; t->addr_lo|=s&0xffff; return 0; } static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { Shdr *sec; ul *q,gotsym=0,locgotno=0,stub,stube; void *p,*pe; massert(sec=get_section(".dynamic",sec1,sece,sn)); for (p=(void *)sec->sh_addr,pe=p+sec->sh_size;psh_entsize) { q=p; if (q[0]==DT_MIPS_GOTSYM) gotsym=q[1]; if (q[0]==DT_MIPS_LOCAL_GOTNO) locgotno=q[1]; if (q[0]==DT_PLTGOT) can_gp=q[1]+0x7ff0; } massert(gotsym && locgotno && can_gp); massert(sec=get_section(".MIPS.stubs",sec1,sece,sn)); stub=sec->sh_addr; stube=sec->sh_addr+sec->sh_size; massert(sec=get_section(".got",sec1,sece,sn)); ggot=sec->sh_addr+locgotno*sec->sh_entsize; ggote=sec->sh_addr+sec->sh_size; for (ds1+=gotsym,sym=ds1;symst_value || (sym->st_value>=stub && sym->st_valuest_value=ggot+(sym-ds1)*sec->sh_entsize; return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rel *r; Sym *sym; Shdr *sec,*ssec; void *v,*ve; ul q; struct node *a; for (q=0,sym=sym1;symst_name; if ((sym->st_other=strcmp(s,"_gp_disp") ? (strcmp(s,"__gnu_local_gp") ? 0 : 2) : 1)) { q++; sym->st_info=ELF_ST_INFO(STB_LOCAL,ELF_ST_TYPE(sym->st_info)); } } massert(q<=1); for (sym=sym1;symst_size=0; for (*gs=1,sec=sec1;secsh_type==SHT_REL)/*no addend*/ for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if (!(sym=sym1+ELF_R_SYM(r->r_info))->st_size) switch(ELF_R_TYPE(r->r_info)) { case R_MIPS_26: if (((ul)(pagetochar(page(heap_end))+r->r_offset))>>28) { sym->st_size=++*gs; (*gs)+=sizeof(mips_26_tramp)/sizeof(ul)-1; } break; case R_MIPS_CALL16: sym->st_size=++*gs; if (((ssec=sec1+sym->st_shndx)>=sece || !ALLOC_SEC(ssec)) && (a=find_sym_ptable(st1+sym->st_name)) && a->address>=ggot && a->addressst_size=++*gs; break; } return 0; } #define FIX_HIDDEN_SYMBOLS(st1_,a_,sym1_,sym_,syme_) \ ({Sym *p;const char *n=(st1_)+(sym_)->st_name,*s=".pic.",*q;ul z=strlen(s); \ if (ELF_ST_VISIBILITY((sym_)->st_other)==STV_HIDDEN) { \ for (p=(sym1_);p<(syme_);p++) \ if (!strncmp(s,(q=(st1_)+p->st_name),z) && !strcmp(n,q+z)) { \ (*(a_))->address=p->st_value; \ break; \ }}}) #undef LOAD_SYM_BY_NAME #define LOAD_SYM_BY_NAME(sym,st1) (!strncmp(st1+sym->st_name,"__moddi3",8)) gcl-2.6.14/h/cmponly.h0000755000175000017500000000523414360276512013063 0ustar cammcamm#define CMPcar(x) (x)->c.c_car #define CMPcdr(x) (x)->c.c_cdr #define CMPcaar(x) (x)->c.c_car->c.c_car #define CMPcadr(x) (x)->c.c_cdr->c.c_car #define CMPcdar(x) (x)->c.c_car->c.c_cdr #define CMPcddr(x) (x)->c.c_cdr->c.c_cdr #define CMPcaaar(x) (x)->c.c_car->c.c_car->c.c_car #define CMPcaadr(x) (x)->c.c_cdr->c.c_car->c.c_car #define CMPcadar(x) (x)->c.c_car->c.c_cdr->c.c_car #define CMPcaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car #define CMPcdaar(x) (x)->c.c_car->c.c_car->c.c_cdr #define CMPcdadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr #define CMPcddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr #define CMPcdddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr #define CMPcaaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_car #define CMPcaaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_car #define CMPcaadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_car #define CMPcaaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car #define CMPcadaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_car #define CMPcadadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car #define CMPcaddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car #define CMPcadddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car #define CMPcdaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_cdr #define CMPcdaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr #define CMPcdadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr #define CMPcdaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr #define CMPcddaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr #define CMPcddadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr #define CMPcdddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr #define CMPcddddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr #define EQ(x,y) ((x)==(y)) #define CMPmake_fixnum(x) make_fixnum(x) #define ALLOCA_CONS(n) (alloca_val=alloca((n)*sizeof(struct cons))) #define ON_STACK_CONS(x,y) (alloca_val=alloca(sizeof(struct cons)), on_stack_cons(x,y)) #define ON_STACK_LIST on_stack_list #define ON_STACK_LIST_VECTOR_NEW on_stack_list_vector_new #define ON_STACK_MAKE_LIST on_stack_make_list #define KEYTYPE void * #define IDECL(a,b,c) mp_limb_t *c=(mp_limb_t *)alloca(1*sizeof(mp_limb_t));MP_INT b={1,1,c}; a = &b #define SETQ_IO(var,alloc,val,af) { object _xx = (val); \ int _n; \ if ((_n=obj_to_mpz(_xx,(var)))) {\ obj_to_mpz1(_xx,(var),af(_n));}} #define SETQ_II(var,alloc,val,af) { MP_INT * _xx = (val); \ int _n; \ if ((_n=mpz_to_mpz(_xx,(var)))) {\ mpz_to_mpz1(_xx,(var),af(_n));}} #define ISETQ_FIX(a,b,c) isetq_fix(a,c) #define save_avma #define restore_avma #define stp_ordinary 0 /*FIXME maxima*/ gcl-2.6.14/h/mdefs.h0000755000175000017500000000217014360276512012474 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /* whether to use prototypes or not */ #ifdef __STDC__ #define P__(x) x #else #define P__(x) #endif #ifdef __GNUC__ #ifndef alloca #define alloca __builtin_alloca #endif #endif #ifdef UNIX #define isalphanum(x) isalnum(x) #endif #ifdef IN_MAIN #define EXTER #else #define EXTER extern #endif #if defined(GMP) || defined(NEED_MP_H) #endif gcl-2.6.14/h/bsd.h0000755000175000017500000000317614360276512012155 0ustar cammcamm#define BSD 1 #define UNIX #define AV #define SFASL /* #define HAVE_AOUT */ #define MEM_SAVE_LOCALS \ struct exec header;\ int stsize #define READ_HEADER fread(&header, sizeof(header), 1, original); \ data_begin=DATA_BEGIN; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ header.a_bss = 0; \ fwrite(&header, sizeof(header), 1, save); #define FILECPY_HEADER \ filecpy(save, original, header.a_text - sizeof(header)); #define COPY_TO_SAVE \ filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); \ fread(&stsize, sizeof(stsize), 1, original); \ fwrite(&stsize, sizeof(stsize), 1, save); \ filecpy(save, original, stsize - sizeof(stsize)) #define NUMBER_OPEN_FILES getdtablesize() extern char etext; #define INIT_ALLOC heap_end = core_end = PCEI(sbrk(0),PAGESIZE); #define SYM_EXTERNAL_P(sym) ((sym)->n_type & N_EXT) #define cs_check(x) #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -N -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) #define SYM_UNDEF_P(sym) ((N_SECTION(sym)) == N_UNDEF) #define NUM_AUX(sym) 0 /* the section like N_ABS,N_TEXT,.. */ /* We have socket utilities, and can fork off a process and get a stream connection with it */ #define RUN_PROCESS /* #define HAVE_XDR */ #define WANT_VALLOC /* if there is no input there return false */ #define LISTEN_FOR_INPUT(fp) \ if(((FILE *)fp)->_cnt <=0 && (c=0,ioctl(((FILE *)fp)->_file, FIONREAD, &c),c<=0)) \ return 0 /* have sys/ioctl.h */ #define HAVE_IOCTL #define HAVE_SIGVEC gcl-2.6.14/h/convex.h0000755000175000017500000000076414360276512012707 0ustar cammcamm#define CONVEX #include "bsd.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("CONVEX"); #undef FILECPY_HEADER #define FILECPY_HEADER \ if (header.a_magic == ZMAGIC) \ filecpy(save, original, PAGSIZ - sizeof(header)); \ filecpy(save, original, header.a_text); #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)) #define PAGSIZ 0x1000 #define SEGSIZ 0x1000 #define TXTRELOC header.a_torigin /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/mp386.defs0000755000175000017500000000113714360276512012747 0ustar cammcammLBINDIR=/usr/local/bin SHELL=/bin/sh OFLAG = -O LIBS = -lm -lg RANLIB=true # define this to be empty if you want to save space ODIR_DEBUG= # For various system V 386 machines. CC = gcc -fwritable-strings -msoft-float -DVOL=volatile -I$(GCLDIR)/o CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. RSYM = rsym SFASL = $(ODIR)/sfasl.o MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) gcl-2.6.14/h/symbol.h0000755000175000017500000000160614360276512012706 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ object sLquote; object sLlambda; object sSlambda_block; object sSlambda_closure; object sSlambda_block_closure; gcl-2.6.14/h/compdefs.h0000644000175000017500000000307614360276512013201 0ustar cammcammchar_code(x) code_char(x) endp(x) eql(x,y) equal(x,y) equalp(x,y) fix(x) lf(x) make_fixnum(x) CMPmake_fixnum(x) small_fixnum(x) type_of(x) STREF(a,b,c) STSET(a,b,c,val) immnum_bool(a,b,c) immnum_ior(x,y) immnum_and(x,y) immnum_xor(x,y) immnum_not(x) immnum_nand(x,y) immnum_nor(x,y) immnum_eqv(x,y) immnum_andc1(x,y) immnum_andc2(x,y) immnum_orc1(x,y) immnum_orc2(x,y) listp(x) sf(x) atom(x) consp(x) OBJNULL Cnil Ct bds_check bds_unwind1 bds_bind(a,b) va_arg(a,b) va_start(a,b) va_end(a) ON_STACK_CONS(x,y) frs_pop() frs_push(a,b) vs_push(x) vs_reserve(x) vs_head vs_pop vs_check ihs_check alloc_frame_id() complex I NOT_SPECIAL VOL mpz_even_p(x) mpz_odd_p(x) mpz_sgn(x) NULL FALSE TRUE is_imm_fixnum(x) is_unmrkd_imm_fixnum(x) aref1 VFUN_NARGS KEYTYPE S_DATA(x) MMcons(x,y) MMcar(x) MMcdr(x) fcalln CMPcar(x) CMPcdr(x) CMPcaar(x) CMPcadr(x) CMPcdar(x) CMPcddr(x) CMPcaaar(x) CMPcaadr(x) CMPcadar(x) CMPcaddr(x) CMPcdaar(x) CMPcdadr(x) CMPcddar(x) CMPcdddr(x) CMPcaaaar(x) CMPcaaadr(x) CMPcaadar(x) CMPcaaddr(x) CMPcadaar(x) CMPcadadr(x) CMPcaddar(x) CMPcadddr(x) CMPcdaaar(x) CMPcdaadr(x) CMPcdadar(x) CMPcdaddr(x) CMPcddaar(x) CMPcddadr(x) CMPcdddar(x) CMPcddddr(x) ALLOCA_CONS(x) check_arg(x) endp_prop(x) fix_imm_fixnum(x) make_imm_fixnum(x) gethash_with_check(x,y) sethash_with_check(x,y,z) ON_STACK_LIST_VECTOR_NEW ON_STACK_MAKE_LIST SAFE_CDR(x) Scons EQ(x,y) aset stp_ordinary SIGNED_CHAR(x) FEerror(x,y...) FEwrong_type_argument(x,y) BIT_ENDIAN(x) integerp(x) rationalp(x) floatp(x) realp(x) numberp(x) vectorp(x) arrayp(x) compiled_function_p(x) pathname_designatorp(x) gcl-2.6.14/h/elf64_i386_reloc.h0000644000175000017500000000053614360276512014254 0ustar cammcamm case R_X86_64_32: add_val(where,MASK(32),s+a); break; case R_X86_64_32S: add_vals(where,MASK(32),s+a); break; case R_X86_64_64: add_val(where,~0L,s+a); break; case R_X86_64_PC32: case R_X86_64_PLT32: massert(ovchks(s+a-p,~MASK(32))); add_val(where,MASK(32),s+a-p); break; gcl-2.6.14/h/solaris-i386.defs0000755000175000017500000000343314360276512014236 0ustar cammcamm # notes for redhat 6.0 # the configure should select the compiler GCC=/usr/bin/i386-glibc20-linux-gcc # However for the gcl-tk directory, you must use plain 'gcc' since # that must link with the tcl tk libs which have been compiled with it. # so after configure change to GCC=gcc in the gcl-tk/makefile # Machine dependent makefile definitions for intel 386,486 running linux LBINDIR=/usr/local/bin #OFLAG = -g -Wall #OFLAG = -g -Wall -fomit-frame-pointer -Werror #LIBS = -lm #ODIR_DEBUG= -g -Wall -fomit-frame-pointer -Werror #ODIR_DEBUG= -g -Wall # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. # (the -pipe is just since our file system is slow..) #CC = ${GCC} -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -Wall $(EXTRA_CFLAGS) -fomit-frame-pointer -Werror -g # under redhat 6.1 and slackware 7.0 we needed to have this # link be static, but should be ok with the fix to unixport/rsym_elf.c LDCC=${CC} -static LDCC=${CC} # note for linuxaout on an elf machine add -b i486-linuxaout # CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif #ifneq ($(findstring -ldl,$(LIBS)),) #RSYM = #endif SFASL = $(ODIR)/sfasl.o #MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s LIBFILES=bsearch.o # the make to use for saved_kcp the profiler. KCP=kcp-bsd SHELL=/bin/bash gcl-2.6.14/h/dos-go32.defs0000755000175000017500000000322714360276512013431 0ustar cammcamm LBINDIR=d:/unix OFLAG = -O # -O LIBS = -lm -lg CAT=cat -B EXE_PREFIX= #gcc 2.1 compiles akcl correctly as far as I have been able to determine. CC = gcc -I${GCLDIR}/dos -I${GCLDIR}/o -DVOL=volatile -W ODIR_DEBUG= -O # -O -g # using gcc so dont need this and dont have cc. MYGCC=gcc RANLIB1_O=ranlib gcllib.a RANLIB2_O= RANLIB1_MP=ranlib libmport.a RANLIB2_MP= GNULIB1= ${MPDIR}/gnulib1.o PORTDIR = ..\unixport LSP2C_1=..\xbin\if-exists $(PORTDIR)\saved_gcl rm -f $*.c $*.h $*.data $*.o LSP2C_2=..\xbin\if-exists makefile $(PORTDIR)\saved_gcl $(PORTDIR)/ $* $* S0111 .lsp.c: $(LSP2C_1) $(LSP2C_2) LSP2O_1=..\xbin\if-exists $(PORTDIR)\saved_gcl rm -f $*.c $*.h $*.data $*.o LSP2O_2=..\xbin\if-exists $(PORTDIR)\saved_gcl $(PORTDIR)\saved_gcl $(PORTDIR)/ $* $* S0111 LSP2O_3=..\xbin\if-exists $(PORTDIR)\saved_gcl $(CC) $(OFLAG) $(CFLAGS) $*.c LSP2O_4=..\xbin\if-exists $(PORTDIR)\saved_gcl ..\xbin\append ${NULLFILE} $*.data $*.o .lsp.o: $(LSP2O_1) $(LSP2O_2) $(LSP2O_3) $(LSP2O_4) AS=as MAINDIR = /gcl CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o MPFILES=${MPDIR}/mpi-386d.o ${MPDIR}/libmport.a # objs for libmport.a MPOBJS= mp_divul3.o mp_bfffo.o mp_mulul3.o mp2.o mp_dblrsl3.o mp_dblremul3.o ${MPDIR}/gnulib1.o NATIVE_CC=gcc RSYM = rsym SFASL = $(ODIR)/sfasl.o EXTRA_OTARGETS= # extras for dos (in dos directory) DOS_ODIR=../dos EXX_DOS=${DOS_ODIR}/dostimes.o ${DOS_ODIR}/read.o ${DOS_ODIR}/signal.o ${DOS_ODIR}/sigman.o ${DOS_ODIR}/dum_dos.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) NULLFILE= DPP = ..\bin\dpp gcl-2.6.14/h/immnum.h0000644000175000017500000002410414360276512012676 0ustar cammcamm#ifndef IMMNUM_H #define IMMNUM_H #if defined (LOW_SHFT) #define is_imm_fixnum2(x_,y_) is_unmrkd_imm_fixnum(x_)&&is_unmrkd_imm_fixnum(y_) #define is_imm_fixnum3(x_,y_,z_) is_unmrkd_imm_fixnum(x_)&&is_unmrkd_imm_fixnum(y_)&&is_unmrkd_imm_fixnum(z_) #define fimoff 0 #else #define is_imm_fixnum2(x_,y_) is_imm_fixnum(((ufixnum)x_)&((ufixnum)y_)) #define is_imm_fixnum3(x_,y_,z_) is_imm_fixnum(((ufixnum)x_)&((ufixnum)y_)&((ufixnum)z_)) #define fimoff (IM_FIX_BASE+(IM_FIX_LIM>>1)) #endif #define mif(x) make_imm_fixnum(x)/*abbreviations*/ #define fif(x) fix_imm_fixnum(x) #define iif(x) is_imm_fixnum(x) #define iif2(x,y) is_imm_fixnum2(x,y) INLINE fixnum lnabs(fixnum x) {return x<0 ? ~x : x;} INLINE char clz(ufixnum x) { #ifdef HAVE_CLZL return x ? __builtin_clzl(x) : sizeof(x)*8; #else {char i;for (i=0;i>(sizeof(x)*8-1-i))&0x1);i++); return i;} #endif } INLINE char ctz(ufixnum x) { #ifdef HAVE_CTZL return __builtin_ctzl(x);/*x ? __builtin_clzl(x) : sizeof(x)*8;*/ #else {char i;for (i=0;i>i)&0x1);i++); return i;} #endif } INLINE char fixnum_length(fixnum x) {return sizeof(x)*8-clz(lnabs(x));} INLINE object immnum_length(object x) {return iif(x) ? mif(fixnum_length(fif(x))) : integer_length(x);} #if SIZEOF_LONG == 8 #define POPA 0x5555555555555555UL #define POPB 0x3333333333333333UL #define POPC 0x0F0F0F0F0F0F0F0FUL #define POPD 0x7F #else #define POPA 0x55555555UL #define POPB 0x33333333UL #define POPC 0x0F0F0F0FUL #define POPD 0x3F #endif INLINE char fixnum_popcount(ufixnum x) { x-=POPA&(x>>1); x=(x&POPB)+((x>>2)&POPB); x=POPC&(x+(x>>4)); x+=x>>8; x+=x>>16; #if SIZEOF_LONG == 8 x+=x>>32; #endif return x&POPD; } INLINE char /* fixnum_count(fixnum x) {return __builtin_popcountl(lnabs(x));} */ fixnum_count(fixnum x) {return fixnum_popcount(lnabs(x));} INLINE object immnum_count(object x) {return iif(x) ? mif(fixnum_count(fif(x))) : integer_count(x);} /*bs=sizeof(long)*8; lb=bs-clz(labs(x));|x*y|=|x|*|y|<2^(lbx+lby)<2^(bs-1); 0 bounded by 2^0, +-1 by 2^1,mpf by 2^(bs-1), which is sign bit protect labs from most negative fix, here all immfix ok*/ INLINE bool fixnum_mul_safe_abs(fixnum x,fixnum y) {return clz(x)+clz(y)>sizeof(x)*8+1;} INLINE object safe_mul_abs(fixnum x,fixnum y) {return fixnum_mul_safe_abs(x,y) ? make_fixnum(x*y) : fixnum_times(x,y);} INLINE bool fixnum_mul_safe(fixnum x,fixnum y) {return fixnum_mul_safe_abs(labs(x),labs(y));} INLINE object safe_mul(fixnum x,fixnum y) {return fixnum_mul_safe(x,y) ? make_fixnum(x*y) : fixnum_times(x,y);} INLINE object immnum_times(object x,object y) {return iif2(x,y) ? safe_mul(fif(x),fif(y)) : number_times(x,y);} INLINE object immnum_plus(object x,object y) {return iif2(x,y) ? make_fixnum(fif(x)+fif(y)) : number_plus(x,y);} INLINE object immnum_minus(object x,object y) {return iif2(x,y) ? make_fixnum(fif(x)-fif(y)) : number_minus(x,y);} INLINE object immnum_negate(object x) {return iif(x) ? make_fixnum(-fif(x)) : number_negate(x);} #define BOOLCLR 0 #define BOOLSET 017 #define BOOL1 03 #define BOOL2 05 #define BOOLC1 014 #define BOOLC2 012 #define BOOLAND 01 #define BOOLIOR 07 #define BOOLXOR 06 #define BOOLEQV 011 #define BOOLNAND 016 #define BOOLNOR 010 #define BOOLANDC1 04 #define BOOLANDC2 02 #define BOOLORC1 015 #define BOOLORC2 013 INLINE fixnum fixnum_boole(fixnum op,fixnum x,fixnum y) { switch(op) { case BOOLCLR: return 0; case BOOLSET: return -1; case BOOL1: return x; case BOOL2: return y; case BOOLC1: return ~x; case BOOLC2: return ~y; case BOOLAND: return x&y; case BOOLIOR: return x|y; case BOOLXOR: return x^y; case BOOLEQV: return ~(x^y); case BOOLNAND: return ~(x&y); case BOOLNOR: return ~(x|y); case BOOLANDC1:return ~x&y; case BOOLANDC2:return x&~y; case BOOLORC1: return ~x|y; case BOOLORC2: return x|~y; } return 0;/*FIXME error*/ } INLINE object immnum_boole(fixnum o,object x,object y) {return iif2(x,y) ? mif(fixnum_boole(o,fif(x),fif(y))) : log_op2(o,x,y);} #define immnum_bool(o,x,y) immnum_boole(fixint(o),x,y) #define immnum_ior(x,y) immnum_boole(BOOLIOR,x,y) #define immnum_and(x,y) immnum_boole(BOOLAND,x,y) #define immnum_xor(x,y) immnum_boole(BOOLXOR,x,y) #define immnum_not(x) immnum_boole(BOOLC1,x,x) #define immnum_nand(x,y) immnum_boole(BOOLNAND,x,y) #define immnum_nor(x,y) immnum_boole(BOOLNOR,x,y) #define immnum_eqv(x,y) immnum_boole(BOOLEQV,x,y) #define immnum_andc1(x,y) immnum_boole(BOOLANDC1,x,y) #define immnum_andc2(x,y) immnum_boole(BOOLANDC2,x,y) #define immnum_orc1(x,y) immnum_boole(BOOLORC1,x,y) #define immnum_orc2(x,y) immnum_boole(BOOLORC2,x,y) INLINE fixnum fixnum_div(fixnum x,fixnum y,fixnum d) { fixnum z=x/y; if (d && x!=y*z && (x*d>0 ? y>0 : y<0)) z+=d; return z; } INLINE fixnum fixnum_rem(fixnum x,fixnum y,fixnum d) { fixnum z=x%y; if (d && z && (x*d>0 ? y>0 : y<0)) z+=y; return z; } INLINE object immnum_truncate(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),0)) : (intdivrem(x,y,0,&x,NULL),x);} INLINE object immnum_floor(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),-1)) : (intdivrem(x,y,-1,&x,NULL),x);} INLINE object immnum_ceiling(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_div(fif(x),fif(y),1)) : (intdivrem(x,y,1,&x,NULL),x);} INLINE object immnum_mod(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_rem(fif(x),fif(y),-1)) : (intdivrem(x,y,-1,NULL,&y),y);} INLINE object immnum_rem(object x,object y) {return iif2(x,y)&&y!=make_fixnum(0) ? mif(fixnum_rem(fif(x),fif(y),0)) : (intdivrem(x,y,0,NULL,&y),y);} INLINE fixnum fixnum_rshft(fixnum x,fixnum y) { return y>=sizeof(x)*8 ? (x<0 ? -1 : 0) : x>>y; } INLINE object fixnum_lshft(fixnum x,fixnum y) { return clz(labs(x))>y ? make_fixnum(x<);} INLINE bool immnum_ge(object x,object y) {return immnum_comp(x,y,>=);} INLINE bool immnum_minusp(object x) {return iif(x) ? ((fixnum)x)<((fixnum)make_fixnum(0)) : number_minusp(x);} INLINE bool immnum_plusp(object x) {return iif(x) ? ((fixnum)x)>((fixnum)make_fixnum(0)) : number_plusp(x);} INLINE bool immnum_zerop(object x) {return iif(x) ? ((fixnum)x)==((fixnum)make_fixnum(0)) : number_zerop(x);} INLINE bool immnum_evenp(object x) {return iif(x) ? !(((fixnum)x)&0x1) : number_evenp(x);} INLINE bool immnum_oddp(object x) {return iif(x) ? (((fixnum)x)&0x1) : number_oddp(x);} INLINE object immnum_signum(object x) { fixnum ux=(fixnum)x,uz=((fixnum)make_fixnum(0)); return iif(x) ? (uxc.c_car,p=x->c.c_cdr; if (iif2(s,p)) { fixnum fs=fif(s),fp=fif(p); if (fs+fpc.c_car,p=x->c.c_cdr; if (iif2(s,p)) { fixnum fs=fif(s),fp=fif(p); if (fs+fpc.c_car,p=x->c.c_cdr; if (iif2(s,p)) { fixnum fs=fif(s),fp=fif(p); if (fs+fpc.c_car,p=x->c.c_cdr; if (iif2(s,p)) { fixnum fs=fif(s),fp=fif(p); if (fs+fp=(fixnum)y ? x : y) : (number_compare(x,y)>=0?x:y);} INLINE object immnum_min(object x,object y) {return iif2(x,y) ? ((fixnum)x<=(fixnum)y ? x : y) : (number_compare(x,y)<=0?x:y);} INLINE bool immnum_logt(object x,object y) {return iif2(x,y) ? fixnum_boole(BOOLAND,fif(x),fif(y))!=0 : !number_zerop(log_op2(BOOLAND,x,y));} INLINE fixnum fixnum_gcd(fixnum x,fixnum y) { fixnum t; char tx,ty; if (!x) return y; if (!y) return x; tx=ctz(x); ty=ctz(y); tx=tx>=tx; y>>=tx; t=x&0x1 ? -y : x>>1; do { t>>=ctz(t); if (t>0) x=t; else y=-t; t=x-y; } while (t); return x< /* include ptimes and so on in the image */ #define CMAC #define SHARP_EQ_CONTEXT_SIZE 1024 #undef FILECPY_HEADER #define FILECPY_HEADER filecpy(save, original, header.a_text) #define IS_DIR_SEPARATOR(x) ((x=='/')||(x=='\\')) #undef SET_REAL_MAXPAGE /* fix this to stat the swap file to give idea of swap space */ #define DEFAULT_BINARY_MODE _fmode = O_BINARY #define SET_BINARY_MODE _fmode = O_BINARY; void binary_file_mode(); #define SET_REAL_MAXPAGE do { binary_file_mode(); real_maxpage = MAXPAGE;} \ while(0) struct rlimit { int i; } ; #undef LISTEN_FOR_INPUT #undef HAVE_IOCTL #define ADDITIONAL_FEATURES \ ADD_FEATURE("DOS"); \ ADD_FEATURE("I386") #define IEEEFLOAT #define DATA_BEGIN (char *)N_DATADDR(header) #define N_RELOFF N_TRELOFF #define RELOC_FILE "rel_sun3.c" #define PAGEWIDTH 12 #define reloc relocation_info /* some regular bsd bells and whistles which aren't here */ #undef HAVE_SIGVEC /* #undef HAVE_XDR */ #undef RUN_PROCESS #ifdef IN_UNIXTIME #undef BSD #define ATT #ifndef EMX #define tms_cutime tms_stime #endif #endif #define FIX_PATH_STRING(x) fix_path_string_dos(x) #ifdef IN_RSYM #define _std_h #include #endif #define RSYM_COMMAND(command,system_directory,kcl_self,tmpfile1) \ sprintf(command,"go32 rsym %s %s",kcl_self,tmpfile1) #define GETWD(x) (bzero(x,MAXPATHLEN),getwd(x)) #define DOES_CRLF #define WRITEC_NEWLINE(strm) (writec_stream('\r',strm),\ writec_stream('\n', strm)) /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/mgmp.h0000644000175000017500000000312714360276512012336 0ustar cammcamm#ifdef __SHORT_LIMB typedef unsigned int mp_limb_t; #else #ifdef __LONG_LONG_LIMB typedef unsigned long long int mp_limb_t; #else typedef unsigned long int mp_limb_t; #endif #endif typedef mp_limb_t * mp_ptr; typedef struct { int _mp_alloc; /* Number of *limbs* allocated and pointed to by the _mp_d field. */ int _mp_size; /* abs(_mp_size) is the number of limbs the last field points to. If _mp_size is negative this is a negative number. */ mp_limb_t *_mp_d; /* Pointer to the limbs. */ } __mpz_struct; typedef __mpz_struct MP_INT; typedef __mpz_struct * mpz_t; /* Available random number generation algorithms. */ typedef enum { GMP_RAND_ALG_DEFAULT = 0, GMP_RAND_ALG_LC = GMP_RAND_ALG_DEFAULT /* Linear congruential. */ } gmp_randalg_t; /* Linear congruential data struct. */ typedef struct { mpz_t _mp_a; /* Multiplier. */ unsigned long int _mp_c; /* Adder. */ mpz_t _mp_m; /* Modulus (valid only if m2exp == 0). */ unsigned long int _mp_m2exp; /* If != 0, modulus is 2 ^ m2exp. */ } __gmp_randata_lc; /* Random state struct. */ typedef struct { mpz_t _mp_seed; /* Current seed. */ gmp_randalg_t _mp_alg; /* Algorithm used. */ union { /* Algorithm specific data. */ __gmp_randata_lc *_mp_lc; /* Linear congruential. */ } _mp_algdata; } __gmp_randstate_struct; typedef __gmp_randstate_struct gmp_randstate_t[1]; #define mpz_sgn(x_) ((x_)->_mp_size < 0 ? -1 : (x_)->_mp_size > 0) #define mpz_odd_p(x_) (((x_)->_mp_size != 0) & ((int) ((x_)->_mp_d[0]))) #define mpz_even_p(x_) (! (((x_)->_mp_size != 0) & ((int) ((x_)->_mp_d[0])))) gcl-2.6.14/h/386-macosx.defs0000644000175000017500000000204614360276512013677 0ustar cammcamm# powerpc-macosx.defs # Disable Apple's custom C preprocessor which gets confused when # preprocessing some of the *.d files in the o/ subdirectory. CC = gcc $(CPPFLAGS) # Set this to avoid warnings when linking against libncurses. # This is due to the requirements of the two level namespace. LIBS := `echo $(LIBS) | sed -e 's/-lncurses/ /'` # Set this for the linker to operate correctly. MACOSX_DEPLOYMENT_TARGET = 10.2 # Define this to build an executable rsym. RSYM = rsym ifneq ($(findstring bfd,$(LIBS)),) RSYM = endif ifneq ($(BUILD_BFD),) RSYM = endif # Define this in order to compile sfasl.c. SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table). # (However, I'm not sure this init form will ever get called.) INITFORM = (si::build-symbol-table) # This is Apple's libtool, completely unrelated to GNU libtool. # Other plateforms define this to be `ar rs`. # This appears to be no longer necessary on Panther. ARRS = /usr/bin/libtool -static -o FINAL_CFLAGS := `echo $(FINAL_CFLAGS) | sed -e 's:-g::g'` gcl-2.6.14/h/sparc-linux.h0000755000175000017500000000132414360276512013643 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("SPARC") #define SPARC #define SGC #define PTR_ALIGN 8 #if SIZEOF_LONG==4 #define RELOC_H "elf32_sparc_reloc.h" #else #define RELOC_H "elf64_sparc_reloc.h" #define SPECIAL_RELOC_H "elf64_sparc_reloc_special.h" void unwind() __attribute__((optimize("O0")));/*FIXME*/ #endif /* #if SIZEOF_LONG == 8 */ /* #define C_GC_OFFSET 4 */ /* #endif */ gcl-2.6.14/h/elf64_aarch64_reloc_special.h0000644000175000017500000000177414360276512016520 0ustar cammcamm/* #define R_AARCH64_TRAMP 1 */ static int tramp[]={0x58ffffd0, /*ldr 19bit pc relative x16*/ 0xd61f0200};/*br x16*/ static ul gotp,tz=1+sizeof(tramp)/sizeof(ul); static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rela *r; Sym *sym; Shdr *sec; void *v,*ve; gotp=0; for (sym=sym1;symst_size=0; for (*gs=0,sec=sec1;secsh_type==SHT_RELA) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info)==R_AARCH64_JUMP26 || ELF_R_TYPE(r->r_info)==R_AARCH64_CALL26) { if (r->r_addend) (*gs)+=tz; else { sym=sym1+ELF_R_SYM(r->r_info); if (!sym->st_size) sym->st_size=++gotp; } } gotp*=tz; (*gs)+=gotp; return 0; } gcl-2.6.14/h/mach64_i386_reloc.h0000644000175000017500000000160414360276512014413 0ustar cammcamm#include #define GOT_RELOC(ri) ri->r_type==X86_64_RELOC_GOT_LOAD||ri->r_type==X86_64_RELOC_GOT case X86_64_RELOC_UNSIGNED: // for absolute addresses if (ri->r_extern || !ri->r_pcrel) add_val(q,~0L,ri->r_pcrel ? a-rel : a); break; case X86_64_RELOC_GOT_LOAD: // a MOVQ load of a GOT entry case X86_64_RELOC_GOT: // a MOVQ load of a GOT entry got+=n1[ri->r_symbolnum].n_desc-1; *got=a; a=(ul)got; case X86_64_RELOC_SIGNED_1: // for signed 32-bit displacement with -1 addend, // apparently already in *q case X86_64_RELOC_SIGNED: // for signed 32-bit displacement case X86_64_RELOC_BRANCH: // a CALL/JMP instruction with 32-bit displacement if (ri->r_extern || !ri->r_pcrel) store_val(q,MASK(32),(ri->r_pcrel ? a-((ul)q+4) : a)+(signed)(*q&MASK(32))); break; gcl-2.6.14/h/elf64_ppc_reloc_special.h0000644000175000017500000000376214360276512016051 0ustar cammcammstatic ul toc; static int tramp[]={0,0,0,0,0,0,0,0, ((0x3a<<10)|(0x9<<5)|0x2)<<16, ((0x3a<<10)|(0x9<<5)|0x9)<<16, ((0x3a<<10)|(0xa<<5)|0x9)<<16, (((0x3a<<10)|(0xb<<5)|0x9)<<16)|0x10, 0x7d4903a6, (((0x3a<<10)|(0x2<<5)|0x9)<<16)|0x8, 0x4e800420,0}; /* static int */ /* make_trampoline(void *v,ul addr) { */ /* ul *u; */ /* int *i; */ /* u=v; */ /* *u++=(ul)(v+4*sizeof(*u)); */ /* *u++=(ul)(v+3*sizeof(*u)); */ /* *u++=0; */ /* *u++=addr; */ /* i=(void *)u; */ /* *i++=((0x3a<<10)|(0x9<<5)|0x2)<<16; */ /* *i++=((0x3a<<10)|(0x9<<5)|0x9)<<16; */ /* *i++=((0x3a<<10)|(0xa<<5)|0x9)<<16; */ /* *i++=(((0x3a<<10)|(0xb<<5)|0x9)<<16)|0x10; */ /* *i++=0x7d4903a6; */ /* *i++=(((0x3a<<10)|(0x2<<5)|0x9)<<16)|0x8; */ /* *i++=0x4e800420; */ /* return 0; */ /* } */ static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { Shdr *sec; Rela *r; void *ve,*u; ul j; massert(sec=get_section(".got",sec1,sece,sn)); toc=sec->sh_addr; init_section_name=".opd"; massert((sec=get_section(".rel.dyn",sec1,sece,sn))|| (sec=get_section(".rela.dyn",sec1,sece,sn))); v+=sec->sh_offset; ve=v+sec->sh_size; for (j=0,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info) && !ds1[ELF_R_SYM(r->r_info)].st_value) j++; massert(u=malloc(j*sizeof(tramp))); v=ve-sec->sh_size; for (r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info) && !ds1[ELF_R_SYM(r->r_info)].st_value) { memcpy(u,tramp,sizeof(tramp)); ((ul *)u)[0]=(ul)(((ul *)u)+4); ((ul *)u)[1]=(ul)(((ul *)u)+3); ((ul *)u)[3]=r->r_offset; ds1[ELF_R_SYM(r->r_info)].st_value=(ul)u; u+=sizeof(tramp); } return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Shdr *sec; massert(sec=get_section(".toc",sec1,sece,sn)); toc=sec->sh_addr; return 0; } gcl-2.6.14/h/hp800.h0000755000175000017500000000763214360276512012245 0ustar cammcamm#define HPUX #define HPUX_SOM #define HP #include "bsd.h" #undef RUN_PROCESS #undef WANT_VALLOC /* uses sigvector instead of sigvec. Could alternately link with -lbsd */ #define sigvec sigvector /* does not have getpagesize() */ /* #define SBRK(n) \ (printf("sbrk(%x)=%x",n,FIXtemp=sbrk(n)),fflush(stdout),FIXtemp) #define BRK(n) \ (printf("brk(%x)=%x",n,FIXtemp=brk(n)),fflush(stdout),FIXtemp) */ #undef SFASL #define UNIXFASL "faslhp800.c" #define ADDITIONAL_FEATURES \ ADD_FEATURE("HP9000-800"); \ ADD_FEATURE("MC68020"); \ ADD_FEATURE("HP-UX"); /* #define USE_C_EXTENDED_MUL #define USE_C_EXTENDED_DIV */ #define DATA_BEGIN (char *)N_DATADDR(header) #define RELOC_FILE "rel_hp300.c" #define IEEEFLOAT #define reloc r_info #define N_RELOFF(hdr) RTEXT_OFFSET(hdr) #define N_SYMOFF(hdr) LESYM_OFFSET(hdr) #define N_TXTOFF(hdr) TEXT_OFFSET(hdr) /* #undef cs_check */ #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE /* #undef INIT_ALLOC #define INIT_ALLOC if (BRK(pagetochar(MAXPAGE)) < 0) \ error("Can't allocate. Good-bye!."); */ #define HAVE_AOUT #define exec header #define SEEK_TO_END_OFILE(fp) \ do{struct header hdr; \ fseek(fp,0,0); \ fread(&hdr, sizeof(hdr), 1, fp); \ fseek(fp,hdr.som_length,0); \ }while(0) /* have the getcwd command */ #define GETCWD /* note gabor used the att ldirectory... maybe bsd is ok?? */ #undef LD_COMMAND #define OBSOLETE_LD_COMMAND(command,main,start,input,ldarg,output) \ { char buf[50]; int i; \ char *b = &buf[sizeof(buf)]; \ char *pp=input; \ *--b = 0; \ for(i=strlen(pp)-3; i >= 0 ; i--) \ if (pp[i]!='/') { *(--b) = pp[i];} \ else break; \ sprintf(command,\ " if ld -d -a archive -s -e init_code -A %s -R %x -D0x%x %s %s -o %s /lib/dyncall.o ; then true; \ else ld -d -a archive -s -e init_%s -A %s -R %x -D0x%x %s %s -o %s /lib/dyncall.o ;fi", \ main,start,start + data_off, input,ldarg,output, \ b, \ main,start,start + data_off, input,ldarg,output);} #define LD_COMMAND(command,main,start,input,ldarg,output) \ { char buf[50]; int i; \ char *b = &buf[sizeof(buf)]; \ char *pp=input; \ *--b = 0; \ for(i=strlen(pp)-3; i >= 0 ; i--) \ if (pp[i]!='/') { *(--b) = pp[i];} \ else break; \ sprintf(command,\ " if nm %s | fgrep init_code > /dev/null ; then ld -d -a archive -s -e init_code -A %s -R %x -D0x%x %s %s -o %s /lib/dyncall.o 2>/dev/null ; exit 0 ; fi; \ if nm %s | fgrep init_%s > /dev/null ; then ld -d -a archive -s -e init_%s -A %s -R %x -D0x%x %s %s -o %s /lib/dyncall.o 2> /dev/null ; exit 0 ;fi ; exit 1 ; ", \ input, \ main,start,start + data_off, input,ldarg,output, \ input,b,b, \ main,start,start + data_off, input,ldarg,output);} /* This is ok but does not do the init_filename case #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command,\ "ld -d -a archive -s -e init_code -A %s -R %x -D0x%x %s %s -o %s", \ main,start,start + data_off, input,ldarg,output) */ /* #define SIGNED_CHAR #define REGISTER_VAR #define BYTE_ADDRESS #define CORE_STARTS_NEAR_0 #undef DOWN_STACK #undef REVERSE_PARAMETER_ORDER #undef CC_OPTIMIZES_TEST #define UNIX #undef BSD #define HPUX #undef ATT #define ALLOCATE_INCREMENTALLY #define ALLOW_FORK */ /* use #include */ #define HAVE_FCNTL #define RSYM_AUX "../c/rel_hp300.c" #define FIX_BSS sym->n_type = N_BSS; \ val = (val + 3) & ~3; /* the following 2 cause duplicate defs so we redefine them.. */ #define calloc xxcalloc #define cfree xxcfree /* Begin for cmpinclude */ /* End for cmpinclude */ /* For listen LISTEN_FOR_INPUT in stdio.h */ #define _file __fileL #define _cnt __cnt /* #define DBEGIN 0x40000000 */ #define NULL_OR_ON_C_STACK(x) (x == 0 || ((unsigned int) x) >=0x70000000) #define UNIXSAVE "unexhp9k800.c" gcl-2.6.14/h/frame.h0000755000175000017500000000665514360276512012504 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* frame.h frame stack and non-local jump */ /* IHS Invocation History Stack */ typedef struct invocation_history { object ihs_function; object *ihs_base; } *ihs_ptr; extern ihs_ptr ihs_org,ihs_limit; EXTER ihs_ptr ihs_top; #define ihs_check \ if (ihs_top >= ihs_limit) \ ihs_overflow() #define ihs_push(function) \ (++ihs_top)->ihs_function = (function); \ ihs_top->ihs_base = vs_base #define ihs_push_base(function,base) \ (++ihs_top)->ihs_function = (function); \ ihs_top->ihs_base = base #define ihs_pop() (ihs_top--) #define make_nil_block() \ { \ object x; \ \ lex_copy(); \ x = alloc_frame_id(); \ vs_push(x); \ lex_block_bind(Cnil, x); \ vs_popp; \ frs_push(FRS_CATCH, x); \ } /* Frame Stack */ enum fr_class { FRS_CATCH, /* for catch,block,tabbody */ FRS_CATCHALL, /* for catchall */ FRS_PROTECT /* for protect-all */ }; EXTER int in_signal_handler; struct frame { char frs_jmpbuf[SIZEOF_JMP_BUF] __attribute__ ((__aligned__ (OBJ_ALIGNMENT*2))); object *frs_lex; bds_ptr frs_bds_top; object frs_val; ihs_ptr frs_ihs; char frs_class; char frs_in_signal_handler; }; typedef struct frame *frame_ptr; #define alloc_frame_id() alloc_object(t_spice) /* frs_class | frs_value | frs_prev ----------+--------------------------------------+-------------- CATCH | frame-id, i.e. | | throw-tag, | | block-id (uninterned symbol), or | value of ihs_top | tagbody-id (uninterned symbol) | when the frame ----------+--------------------------------------| was pushed CATCHALL | NIL | ----------+--------------------------------------| PROTECT | NIL | ---------------------------------------------------------------- */ extern frame_ptr frs_org,frs_limit; EXTER frame_ptr frs_top; /* frame stack top */ #define frs_push(class, val) \ do { frame_ptr _frs_top = frs_top +1; \ if (_frs_top >= frs_limit) \ frs_overflow(); \ _frs_top->frs_lex = lex_env;\ _frs_top->frs_bds_top = bds_top; \ _frs_top->frs_class = (class); \ _frs_top->frs_in_signal_handler = in_signal_handler; \ _frs_top->frs_val = (val); \ _frs_top->frs_ihs = ihs_top; \ frs_top=_frs_top; \ setjmp((void *)_frs_top->frs_jmpbuf); \ } while (0) #define frs_pop() frs_top-- /* global variables used during non-local jump */ EXTER bool nlj_active; /* true during non-local jump */ EXTER frame_ptr nlj_fr; /* frame to return */ EXTER object nlj_tag; /* throw-tag, block-id, or */ /* (tagbody-id . label). */ gcl-2.6.14/h/mc68k.h0000755000175000017500000000406114360276512012327 0ustar cammcamm #ifdef __GNUC__ /* so have assembler macros */ /* divul rem=hl; f=divul(x,y,rem); then hl:x == f*y + rem is true */ #define divul(x,y,hiremainder) \ ({ulong __x =(x),__y=(y); \ asm volatile("divul %3,%1:%0" \ :"=d" (__x),"=d" (hiremainder) \ :"0" (__x),"dmn"(__y),"1" (hiremainder) ); \ __x;}) /* mulul is a macro: f = mulul(a,b,h) <--> h:f == a*b */ #define mulul(x,y,hiremainder) \ ({ulong __x =(x),__y=(y); \ asm volatile("mulul %3,%1:%0" \ :"=d" (__x),"=d" (hiremainder) \ :"0" (__x),"dmn"(__y),"1" (hiremainder) ); \ __x;}) /* add_carry: add X and Y adding 1 to H if there was overflow H is presumed to be small enough not to overflow */ #define ZERO 0 /* note we have to pass the dummy arg (__res) to addxl asm, to force that addition to take first */ #define add_carry(x,y,h) \ ({ulong __res ; \ __res = (x) + (y); \ asm volatile("addxl %2,%0" \ :"=d" (h): "0" (h) , "d" (ZERO),"d" (__res)); \ __res;}) /* SET_MACHINE_CARRYSet the machine carry flag if overflow = 1 other wise clear it. */ #define SET_MACHINE_CARRY(overflow) \ asm volatile("addl #-1,%0" : "=d" (overflow) : "0" (overflow)) /* SET_OVERFLOW Set the overflow = the current carry code Note that machine loads and mov's should not affect the carry code. */ #define SET_OVERFLOW \ asm volatile("clrl %0\n\taddxl %0,%0" \ : "=d" (overflow)) /* x - y */ #define SUBXCC(xp,yp)\ ({unsigned plong _res; asm volatile("subxl %2,%0" \ :"=d" (_res): "0" (xp) , "d" (yp)); _res;}) #define ADDXCC(xp,yp)\ ({unsigned plong _res; asm volatile("addxl %2,%0" \ :"=d" (_res): "0" (xp) , "d" (yp)); _res;}) /* The 'X' bit of the condition code won't be affected by computing the jump label */ #define C_SWITCH_DOESNT_AFFECT_CARRY /* index of the first non zero bit numbering from left */ #define bfffo(x) \ ({ulong _res; asm ("bfffo %1{#0:#0},%0" : "=d" (_res): "rm" (x)); _res;}) #define NEED_MULUL3 #define NEED_DIVUL3 #else /* not gcc */ #endif #define BASE_COUNTER -1 gcl-2.6.14/h/NeXT.defs0000755000175000017500000000000014360276512012674 0ustar cammcammgcl-2.6.14/h/sun3-os4.h0000755000175000017500000000125014360276512012767 0ustar cammcamm#define SUN3 #include "bsd.h" #include "mc68k.h" #define PAGEWIDTH 12 #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("MC68020") #define MC68020 #define IEEEFLOAT #define DATA_BEGIN (char *)N_DATADDR(header) /* in release 4.0 it is SIGSEGV, and release 4.1 it is SIGBUS */ #define INSTALL_MPROTECT_HANDLER (signal(SIGSEGV, memprotect_handler),\ signal(SIGBUS, memprotect_handler)) #define RELOC_FILE "rel_sun3.c" /* Begin for cmpinclude */ #ifdef __GNUC__ #undef __BUILTIN_VA_ARG_INCR #endif #define SGC /* End for cmpinclude */ /* Sun 4.1 needs to have some cached yp stuff undone at save time */ #define HAVE_YP_UNBIND gcl-2.6.14/h/386.h0000755000175000017500000000414514360276512011722 0ustar cammcamm #ifdef __GNUC__ /* so have assembler macros */ /* Normally gcc for the 386 only allows 4 operands to an asm, however we need 5 for divul. You can easily make gcc accept more by changing one line in genconfig.c and then recompiling gcc printf ("\n#define MAX_RECOG_OPERANDS %d\n", max_recog_operands_flag + 3); */ /* divul rem=hl; f=divul(x,y,rem); then hl:x == f*y + rem is true */ #define divul(x,y,hiremainder) \ ({ulong __x =(x),__y=(y); \ asm volatile("divl %3" \ :"=a" (__x),"=d" (hiremainder) \ :"0" (__x),"rm"(__y),"1" (hiremainder) ); \ __x;}) /* mulul is a macro: f = mulul(a,b,h) <--> h:f == a*b */ #define mulul(x,y,hiremainder) \ ({ulong __x =(x),__y=(y); \ asm volatile("mull %3" \ :"=a" (__x),"=d" (hiremainder) \ :"0" (__x),"rm"(__y)); \ __x;}) /* add_carry: add X and Y adding 1 to H if there was overflow H is presumed to be small enough not to overflow */ #define add_carry(x,y,h) \ ({ulong __res ; \ asm volatile("addl %4,%1\n\tadcl $0,%0" \ :"=rm,rm" (h),"=r,m" (__res): "0,0" (h),"1,1" (x),"rmn,r"(y)); \ __res;}) /* SET_MACHINE_CARRYSet the machine carry flag if overflow = 1 other wise clear it. */ #define SET_MACHINE_CARRY(overflow) \ asm volatile("addl $-1,%0" : "=r" (overflow) : "0" (overflow)) /* SET_OVERFLOW Set the overflow = the current carry code Note that machine loads and mov's should not affect the carry code. */ #define SET_OVERFLOW \ asm volatile("movl $0,%0\n\tadcl $0,%0" \ : "=rm" (overflow)) /* x - y */ #define SUBXCC(xp,yp)\ ({unsigned long _res; asm volatile("sbbl %2,%0" \ :"=r,rm" (_res): "0,0" (xp) , "rm,r" (yp)); _res;}) #define ADDXCC(xp,yp)\ ({unsigned long _res; asm volatile("adcl %2,%0" \ :"=r,m" (_res): "0,0" (xp) , "rm,r" (yp)); _res;}) /* index of the first non zero bit numbering from left */ /* don't think there is an instruction. #define bfffo(x) \ ({ulong _res; asm ("bfffo %1{#0:#0},%0" : "=r" (_res): "rm" (x)); _res;}) */ #define NEED_MULUL3 #define NEED_DIVUL3 #else /* not gcc */ #endif #define BASE_COUNTER 0 gcl-2.6.14/h/alpha-osf1.defs0000755000175000017500000000242414360276512014025 0ustar cammcamm# /* copyright W. Schelter 1990 */ # Machine dependent makefile definitions for dec alpha unser OSF1 OFLAG = -O LIBS = -lm -lbsd ODIR_DEBUG= NULLFILE = ../h/twelve_null SHELL=/bin/sh # also defined in `machine'.h file # The one here must be >= the one in the .h file. # It must be a multiple of 0x400000 greater that 0x400000 the # default text start. TBEGIN= 10000000 DBEGIN= 12000000 # We have replaced -DVOL=volatile with -DVOL= since in ultrix 4.2 # the volatile declaration is not correctly implemented. Hopefully # it is not required there. CC = cc -DVOL= -I${GCLDIR}/o LDCC = cc -Wl,-D -Wl,${DBEGIN} -Wl,-T -Wl,${TBEGIN} # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. # RSYM = rsym # SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) # incremental loading with -A requires -G 0 # INITFORM=(setq compiler::*cc* "cc -DVOL=volatile -G 0 ") # until volatile works on this machine leave it out. # INITFORM=(setq compiler::*cc* "cc -DVOL= -G 0 ") # Use symbolic links SYMB=-s #MPFILES= ${MPDIR}/mp.o ${MPDIR}/gen2.o ${MPDIR}/alpha.o MPFILES= ${MPDIR}/alpha.o /usr/local/lib/libpari.a MPFILES= ${MPDIR}/mpi.o ${MPDIR}/libmport.a RANLIB= ar lts gcl-2.6.14/h/defun.h0000755000175000017500000000205114360276512012475 0ustar cammcamm#define ARG_LIMIT 63 #define ARG_LIMIT 63 #ifndef DONT_DEFINE_DEFUN #define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) EXTER ret fname(); #define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old,doc) \ EXTER ret fname (); #define DEFUN_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args; #define DEFUNM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,args,doc) EXTER ret fname args; #define DEFUNO_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ EXTER ret fname args; #define DEFUNOM_NEW(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,oldret,old,args,doc) \ EXTER ret fname args; #define DO_INIT(x) #define DEFUNL DEFUN /* these are needed to be linked in to be called by incrementally loaded code */ #define DEFCOMP(type,fun,doc) type fun(); #define DEFCONST DEFVAR #define DEFVAR(string,name,pack,val,doc) EXTER object name; #define DEF_ORDINARY(string,name,package,doc) EXTER object name; #endif gcl-2.6.14/h/mach32_ppc_reloc.h0000644000175000017500000000117514360276512014502 0ustar cammcamm#include case PPC_RELOC_VANILLA: add_val(q,~0L,ri->r_pcrel ? a-rel : a); break; case PPC_RELOC_JBSR: redirect_trampoline(ri,sec1->addr+ri[1].r_address,rel,sec1,io1,n1,&a); if (!ri->r_extern) return 0; if (ovchk(a,~MASK(26))) store_val(q,MASK(26),a|0x3); else if (ovchk(a-(ul)q,~MASK(26))) store_val(q,MASK(26),(a-(ul)q)|0x1); break; case PPC_RELOC_SECTDIFF: case PPC_RELOC_HI16_SECTDIFF: case PPC_RELOC_LO16_SECTDIFF: case PPC_RELOC_HA16_SECTDIFF: case PPC_RELOC_LO14_SECTDIFF: case PPC_RELOC_LOCAL_SECTDIFF: case PPC_RELOC_PAIR: break; gcl-2.6.14/h/powerpc-macosx.h0000644000175000017500000001317514360276512014351 0ustar cammcamm/* GCL config file for Mac OS X. To be used with the following configure switches : --enable-debug (optional) --enable-machine=powerpc-macosx --disable-statsysbfd --enable-custreloc Aurelien Chanudet */ /* For those who are using ACL2, please remember to enlarge your shell stack (ulimit -s 8192). */ #include "bsd.h" #define DARWIN /* Mac OS X has its own executable file format (Mach-O). */ #undef HAVE_AOUT #undef HAVE_ELF /** sbrk(2) emulation */ /* Alternatively, we could use the global variable vm_page_size. */ #define PAGEWIDTH 12 /* The following value determines the running process heap size. */ /* #define BIG_HEAP_SIZE 0x50000000 */ extern char *mach_mapstart; extern char *mach_maplimit; extern char *mach_brkpt; extern char *get_dbegin (); #include /* to get sbrk defined */ extern void *my_sbrk(long incr); #define sbrk my_sbrk /** (si::save-system "...") a.k.a. unexec implementation */ /* The implementation of unexec for GCL is based on Andrew Choi's work for Emacs. Previous pioneering implementation of unexec for Mac OS X by Steve Nygard. */ #define UNIXSAVE "unexmacosx.c" #undef malloc #define malloc my_malloc #undef free #define free my_free #undef realloc #define realloc my_realloc #undef valloc #define valloc my_valloc #undef calloc #define calloc my_calloc /** Dynamic loading implementation */ /* The sfasl{bfd,macosx,macho}.c files are included from sfasl.c. */ #ifdef HAVE_LIBBFD #define SEPARATE_SFASL_FILE "sfaslbfd.c" #else #define SPECIAL_RSYM "rsym_macosx.c" #define SEPARATE_SFASL_FILE "sfaslmacho.c" #endif /* The file has non Mach-O stuff appended. We need to know where the Mach-O stuff ends. */ #include extern int seek_to_end_ofile (FILE *); #define SEEK_TO_END_OFILE(fp) seek_to_end_ofile(fp) /* Processor cache synchronization code. This is based on powerpc-linux.h (Debian ppc). See equivalent code in dyld. See also vm_msync declared in . */ #define CLEAR_CACHE_LINE_SIZE 32 #define CLEAR_CACHE \ do { \ void *v=memory->cfd.cfd_start,*ve=v+memory->cfd.cfd_size; \ v=(void *)((unsigned long)v & ~(CLEAR_CACHE_LINE_SIZE - 1)); \ for (;vuc_mcontext->es.dar)) /* #include #include #include #include void handler (int sig, siginfo_t *info, void *scp) { ucontext_t *uc = (ucontext_t *)scp; fprintf(stderr, "addr = 0x%08lx\n", uc->uc_mcontext->es.dar); _exit(99); } int main(void) { struct sigaction sact; int ret; sigfillset(&(sact.sa_mask)); sact.sa_flags = SA_SIGINFO; sact.sa_sigaction = (void (*)())handler; ret = sigaction (SIGBUS, &sact, 0); return *(int *)0x43; } */ /** Misc stuff */ #define IEEEFLOAT /* Mac OS X does not have _fileno as in linux.h. Nor does it have _cnt as in bsd.h. Let's see what we can do with this declaration found in {Net,Free,Open}BSD.h. */ #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) \ do {int c=0; \ if (((FILE *)fp)->_r <=0 && (c=0, ioctl(((FILE *)fp)->_file, FIONREAD, &c), c<=0)) \ return(FALSE); \ } while (0) #define GET_FULL_PATH_SELF(a_) \ do { \ extern int _NSGetExecutablePath (char *, unsigned long *); \ unsigned long bufsize = 1024; \ static char buf [1024]; \ static char fub [1024]; \ if (_NSGetExecutablePath (buf, &bufsize) != 0) { \ error ("_NSGetExecutablePath failed"); \ } \ if (realpath (buf, fub) == 0) { \ error ("realpath failed"); \ } \ (a_) = fub; \ } while (0) #define RELOC_H "mach32_ppc_reloc.h" gcl-2.6.14/h/elf64_mips_reloc_special.h0000644000175000017500000001011214360276512016222 0ustar cammcammstatic ul ggot,ggote,la; static Rela *hr,*lr; #undef ELF_R_SYM #define ELF_R_SYM(a_) (a_&0xffffffff) #define ELF_R_TYPE1(a_) ((a_>>56)&0xff) #define ELF_R_TYPE2(a_) ((a_>>48)&0xff) #define ELF_R_TYPE3(a_) ((a_>>40)&0xff) #define recurse(val) ({ \ if (ELF_R_TYPE2(r->r_info)) { \ ul i=r->r_info; \ r->r_info=(((r->r_info>>32)&MASK(24))<<40)|(r->r_info&MASK(32)); \ relocate(sym1,r,(val)-s,start,got,gote); \ r->r_info=i; \ break; \ }}) #undef ELF_R_TYPE #define ELF_R_TYPE(a_) ELF_R_TYPE1(a_) #define MIPS_HIGH(a_) ({ul _a=(a_);(_a-(short)_a)>>16;}) typedef struct { ul entry,gotoff; unsigned int ld_gotoff,lw,jr,lwcan; } call_16_tramp; static int write_stub(ul s,ul *got,ul *gote) { static call_16_tramp t1={0,0, (0x37<<26)|(0x1c<<21)|(0x19<<16), /*ld t9,(0)gp*/ (0x37<<26)|(0x19<<21)|(0x19<<16), /*ld t9,(0)t9*/ 0x03200008, /*jr t9*/ 0 /*nop*/ }; call_16_tramp *t=(void *)gote; *t=t1; t->entry=(ul)(gote+2); t->gotoff=s; t->ld_gotoff|=((void *)(gote+1)-(void *)got); return 0; } static int make_got_room_for_stub(Shdr *sec1,Shdr *sece,Sym *sym,const char *st1,ul *gs) { Shdr *ssec=sec1+sym->st_shndx; struct node *a; if ((ssec>=sece || !ALLOC_SEC(ssec)) && (a=find_sym_ptable(st1+sym->st_name)) && a->address>=ggot && a->addresssh_addr,pe=p+sec->sh_size;psh_entsize) { q=p; if (q[0]==DT_MIPS_GOTSYM) gotsym=q[1]; if (q[0]==DT_MIPS_LOCAL_GOTNO) locgotno=q[1]; } massert(gotsym && locgotno); massert(sec=get_section(".MIPS.stubs",sec1,sece,sn)); stub=sec->sh_addr; stube=sec->sh_addr+sec->sh_size; massert(sec=get_section(".got",sec1,sece,sn)); ggot=sec->sh_addr+locgotno*sec->sh_entsize; ggote=sec->sh_addr+sec->sh_size; for (ds1+=gotsym,sym=ds1;symst_value || (sym->st_value>=stub && sym->st_valuest_value=ggot+(sym-ds1)*sec->sh_entsize; return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rela *r; Sym *sym; Shdr *sec; void *v,*ve; ul a,b; for (sym=sym1;symst_other=sym->st_size=0; for (sec=sec1;secsh_type==SHT_RELA) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info)==R_MIPS_CALL16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_DISP|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_HI16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_LO16|| ELF_R_TYPE(r->r_info)==R_MIPS_CALL_HI16|| ELF_R_TYPE(r->r_info)==R_MIPS_CALL_LO16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_PAGE) { sym=sym1+ELF_R_SYM(r->r_info); /*unlikely to save got space by recording possible holes in addend range*/ if ((a=MIPS_HIGH(r->r_addend)+1)>sym->st_other) sym->st_other=a; } for (*gs=0,sec=sec1;secsh_type==SHT_RELA) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info)==R_MIPS_CALL16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_DISP|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_HI16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_LO16|| ELF_R_TYPE(r->r_info)==R_MIPS_CALL_HI16|| ELF_R_TYPE(r->r_info)==R_MIPS_CALL_LO16|| ELF_R_TYPE(r->r_info)==R_MIPS_GOT_PAGE) { sym=sym1+ELF_R_SYM(r->r_info); if (sym->st_other) { sym->st_size=++*gs; if (sym->st_other>1) (*gs)+=sym->st_other-1; else massert(!make_got_room_for_stub(sec1,sece,sym,st1,gs)); sym->st_other=0; } b=sizeof(r->r_addend)*4; massert(!(r->r_addend>>b)); r->r_addend|=((sym->st_size+MIPS_HIGH(r->r_addend))<si_addr #endif /* Reenable when recent mips kernel bug fixed -- SIGBUS passed on occasion instead of SIGSEGV with no address passed in siginfo_t*/ /* kernel bug now fixed, but likely not everywhere. Add additional memprotect test in sgbc.c to ensure we have a working kernel */ #define SGC #if SIZEOF_LONG==4 #define RELOC_H "elf32_mips_reloc.h" #define SPECIAL_RELOC_H "elf32_mips_reloc_special.h" #else #define RELOC_H "elf64_mips_reloc.h" #define SPECIAL_RELOC_H "elf64_mips_reloc_special.h" #endif #define NEED_STACK_CHK_GUARD gcl-2.6.14/h/compprotos.h0000644000175000017500000001322614360276512013604 0ustar cammcammbool eql1(object,object); bool equal1(object,object); bool equalp1(object,object); bool file_exists(object); bool integer_bitp(object,object); double big_to_double(object); frame_ptr frs_sch_catch(object); frame_ptr frs_sch(object); int length(object); int number_compare(object,object); int number_evenp(object); int number_minusp(object); int number_oddp(object); int number_plusp(object); int number_zerop(object); long int fixint(object); object alloc_object(enum type); object call_proc_new(object,void **,int,object,va_list); object coerce_to_string(); object elt(object,int); object fixnum_big_shift(fixnum,fixnum); object fixnum_times(fixnum,fixnum); object fSsputprop(object,object,object); object get(object,object,object); object get_gcd(object,object); object get_lcm(object,object); object integer_count(object); object integer_length(object); object integer_shift(object,object); object listA(fixnum,...); object list(fixnum,...); object log_op2(fixnum,object,object); object make_cons(object,object); object make_fixnum1(long); object make_list(int); object make_longfloat(longfloat); object make_shortfloat(double); object make_simple_string(const char *); object number_abs(object); object number_divide(object, object); object number_dpb(object,object,object); object number_dpf(object,object,object); object number_ldb(object,object); object number_ldbt(object,object); object number_minus(object,object); object number_negate(object); object number_plus(object,object); object number_signum(object); object number_times(object,object); object princ(object,object); object read_char1(object,object); object structure_ref(object,object,fixnum); object structure_set(object,object,fixnum,object); object symbol_function(object); object symbol_name(object); object symbol_value(object); object terpri(object); object vs_overflow(void); void bds_overflow(void); void bds_unwind(bds_ptr); void do_init(object *); void frs_overflow(void); void intdivrem(object,object,fixnum,object *,object *); void princ_char(int,object); void princ_str(char *,object); void princ_str(char *,object); void sethash(object,object,object); void setq(object,object); void super_funcall_no_event(object); void unwind(frame_ptr,object) NO_RETURN; int object_to_int(object); fixnum object_to_fixnum(object); char object_to_char(object); void not_a_symbol(object); object number_expt(object,object); object fLrow_major_aref(object,fixnum); object car(object); object cdr(object); object caar(object); object cadr(object); object cdar(object); object cddr(object); object caaar(object); object caadr(object); object cadar(object); object caddr(object); object cdaar(object); object cdadr(object); object cddar(object); object cdddr(object); object caaaar(object); object caaadr(object); object caadar(object); object caaddr(object); object cadaar(object); object cadadr(object); object caddar(object); object cadddr(object); object cdaaar(object); object cdaadr(object); object cdadar(object); object cdaddr(object); object cddaar(object); object cddadr(object); object cdddar(object); object cddddr(object); object fcalln1(object,...); object append(object,object); object aset1(object,fixnum,object); void call_or_link(object,void **); object call_proc0(object,void *); object call_vproc_new(object,void *,object,va_list); void check_arg_failed (int); void check_other_key (object,int, ...); object elt_set(object,int,object); void funcall(object); object getf(object,object,object); struct htent * gethash(object,object); void invalid_macro_call(void); long labs(long); object list_vector_new(int,object,va_list); object make_cclosure_new(void (*)(),object,object,object); object nconc(object,object); object nreverse(object); object one_plus(object); object one_minus(object); void parse_key(object *,bool,bool,int,...); int parse_key_new_new();/* (int,object *,void *,object,va_list); */ int parse_key_rest_new(); /* (object,int,object *,void *,object,va_list); */ object prin1(object,object); object print(object,object); object putprop(object,object,object); object remprop(object,object); object reverse(object); object simple_symlispcall(object,object *,int); object sputprop(object,object,object); void symlispcall(object,object *,int); void too_few_arguments(void); void too_many_arguments(void); object wrong_type_argument(object,object); bool oeql(object,object); void call_or_link_closure(object,void **,void **); void check_alist(object); void lispcall(object *,int); object make_cclosure(void (*)(),object,object,object,char *,int); object simple_lispcall(object *,int); object sublis1(object,object,bool(*)()); void turbo_closure(object); char * object_to_string(object); object on_stack_cons(object,object); object on_stack_list(int,...); object on_stack_list_vector_new(int,object,va_list); object on_stack_make_list(int); object read_byte1(object,object); int not_a_variable(object); object cmod(object); object ctimes(object,object); object cdifference(object,object); object cplus(object,object); void funcall_with_catcher(object,object); void check_type_symbol(object *); void ck_larg_exactly(int, object); double cos(double); double sin(double); double sqrt(double); double tan(double); int gcl_feof(void *); int gcl_getc(void *); int gcl_putc(int,void *); #ifdef CMPINCLUDE int setjmp(); int _setjmp(); int _setjmp3(); #endif void vfun_wrong_number_of_args(object); void ihs_overflow (void); double object_to_double(object); void gcl_init_or_load1(void (*)(void),const char *); char *gcl_gets(char *,int); int gcl_puts(const char *); int endp_error(object); object Icall_gen_error_handler(object,object,object,object,ufixnum,...); object Icall_gen_error_handler_noreturn(object,object,object,object,ufixnum,...) __attribute__((noreturn)); object file_stream(object); gcl-2.6.14/h/cyglacks.h0000755000175000017500000000374514360276512013207 0ustar cammcamm #ifndef _CYGLACKS_ #define _CYGLACKS_ extern int _fmode; #define SYMNMLEN 8 struct syment { union { char n_name[SYMNMLEN]; struct { int n_zeroes; int n_offset; } n; } n; DWORD n_value; SHORT n_scnum; WORD n_type; BYTE n_sclass; BYTE n_numaux; }; #define n_zeroes n.n.n_zeroes #define n_offset n.n.n_offset #define n_name n.n_name /* storage class */ #define C_EXT 0x0002 /* IMAGE_SYM_CLASS_EXTERNAL */ /* section number */ #define N_UNDEF (SHORT)0 /* Symbol is undefined or is common. */ struct filehdr { WORD f_magic; /* magic number */ WORD f_nscns; /* number of sections */ DWORD f_timdat; /* time & date stamp */ DWORD f_symptr; /* file pointer to symtab */ DWORD f_nsyms; /* number of symtab entries */ WORD f_opthdr; /* sizeof(optional hdr) */ WORD f_flags; /* flags */ }; struct scnhdr { BYTE s_name[IMAGE_SIZEOF_SHORT_NAME]; /* section name */ DWORD s_paddr; /* physical address, aliased s_nlib */ DWORD s_vaddr; /* virtual address */ DWORD s_size; /* section size */ DWORD s_scnptr; /* file ptr to raw data for section */ DWORD s_relptr; /* file ptr to relocation */ DWORD s_lnnoptr; /* file ptr to line numbers */ WORD s_nreloc; /* number of relocation entries */ WORD s_nlnno; /* number of line number entries*/ DWORD s_flags; /* flags */ }; /* IMAGE_REL_I386_ABSOLUTE */ #define R_ABS 0x0000 /* absolute, no relocation is necessary */ /* IMAGE_REL_I386_DIR32 */ #define R_DIR32 0x0006 /* Direct 32-bit reference to the symbols virtual address */ /* IMAGE_REL_I386_REL32 */ #define R_PCRLONG 0x0014 /* 32-bit reference pc relative to the symbols virtual address */ /* _IMAGE_RELOCATION */ struct reloc { union { DWORD r_vaddr; DWORD r_count; /* Set to the real count when IMAGE_SCN_LNK_NRELOC_OVFL is set */ } r; DWORD r_symndx; WORD r_type; }; #define r_vaddr r.r_vaddr #endif /* _CYGLACKS_ */ gcl-2.6.14/h/funlink.h0000755000175000017500000001077114360276512013052 0ustar cammcamm#ifndef FUNLINK_H #define FUNLINK_H /* the link_desc, is an INT which carries the call information for all uses of that link. It tells whether fcall.nargs is set before the call, whether the VFUN_FUN is set, (to pass in a closure function) or if the number of values is set after the call. It gives the min and max number of args and the result type expected. It describes the arg types. enum F_arg_flags */ /* A link arg descriptor: a6a5a4a3a2a1a0rrmmmmmmfffllllll l = least number of args passed m = max number of args passed f = flags bits set according to F_arg_flags, There are F_end flag bits. r = result type in F_arg_types ai = i'th arg type in F_arg_types */ /* 2^6 is the limit on the number of args */ #define F_NARG_WIDTH 6 #define F_START_TYPES_POS (2* F_NARG_WIDTH + F_end ) enum F_arg_flags { F_requires_nargs, /* if set, then caller must store VFUN_NARGS with number of args passed. F_ARGD is used to set up the argd, and it sets this if minargs < maxargs. */ F_caller_sets_one_val, /* If set, then the CALLER will look after setting the fcall.nvalues to 1, if necessary (eg the call is at the end of a function, or if multiple-values-list invokes the function.) If foo is proclaimed to return exactly one value, then the CALLER might set this flag in the link argd, or it might do it in the case we have (setq x (foo)) or (values (foo)). If this flag is not set, then the CALLED function is responsible for setting the number of values in fcall.nvalues, and also for always returning as C value Cnil, in the case that it sets fcall.nvalues == 0. */ F_requires_fun_passed, /* if set, the caller must set VFUN_FUN to the calling function. This is used by closures, but could be used by other things i suppose. */ F_end /* 1 bigger than the largest flag */ }; enum F_arg_types { F_object, F_int, F_double_ptr, F_shortfloat }; /* Make a mask for bits i < j, masking j-i bits */ #define MASK_RANGE(i,j) ((~(~0UL << (j-i)))<< i) #define F_PLAIN(x) (((x) & MASK_RANGE( F_START_TYPES_POS,31)) == 0) #define ARG_LIMIT 63 /* We allow 2 bits for encoding arg types and return type */ #define F_TYPE_WIDTH 2 #define F_MIN_ARGS(x) (x & MASK_RANGE(0,F_NARG_WIDTH)) #define F_NARGS(x) F_MIN_ARGS(x) #define F_ARG_FLAGS_P(x,flag) (x & (1 << (F_NARG_WIDTH + flag))) #define F_ARG_FLAGS(x) ((x >> F_NARG_WIDTH) & MASK_RANGE(0,F_end)) #define F_MAX_ARGS(x) ((x >> (F_NARG_WIDTH + F_end )) \ & MASK_RANGE(0,F_NARG_WIDTH)) #define BITS_PER_CHAR 8 #define MAX_ARGS 63 #define F_TYPES(x) (((x) >> F_START_TYPES_POS ) \ & MASK_RANGE(0, sizeof(int)*BITS_PER_CHAR - F_START_TYPES_POS)) #define F_RESULT_TYPE(x) (F_TYPES(x) & MASK_RANGE(0,F_TYPE_WIDTH)) #define F_ARG_LIMIT ((1<< F_NARG_WIDTH) -1) /* make an argd slot where flags and argtypes are already set up as fields */ #define F_ARGD(min,max,flags, argtypes) \ (min | ((flags | (max-min ? (1<=sizeof(fcall.values)/sizeof(*fcall.values) \ FEerror("Too many function call values"); \ else fcall.values[nvals++] = (x) #define RETURN_VALS fcall.nvalues= nvals; return result;} 0 #define FUNCALL(n,form) (VFUN_NARGS=n,form) #endif gcl-2.6.14/h/cmplrs/0000755000175000017500000000000014360276512012522 5ustar cammcammgcl-2.6.14/h/cmplrs/stsupport.h0000755000175000017500000001515314360276512014766 0ustar cammcamm/* * |-----------------------------------------------------------| * | Copyright (c) 1991, 1990 MIPS Computer Systems, Inc. | * | All Rights Reserved | * |-----------------------------------------------------------| * | Restricted Rights Legend | * | Use, duplication, or disclosure by the Government is | * | subject to restrictions as set forth in | * | subparagraph (c)(1)(ii) of the Rights in Technical | * | Data and Computer Software Clause of DFARS 252.227-7013. | * | MIPS Computer Systems, Inc. | * | 950 DeGuigne Avenue | * | Sunnyvale, California 94088-3650, USA | * |-----------------------------------------------------------| */ /* $Header$ */ /* * Author Mark I. Himelstein * Date Started 5/15/85 * Purpose provide support to uc to produce mips symbol tables. */ #ifndef __CMPLRS_STSUPPORT_H #define __CMPLRS_STSUPPORT_H #if (defined(_LANGUAGE_C) || (defined(_LANGUAGE_C_PLUS_PLUS))) extern AUXU _auxtemp; #define AUXINT(c) ((_auxtemp.isym = c), _auxtemp) /* the following struct frames the FDR dtructure and is used at runtime * to access the objects in the FDR with pointers (since the FDR * only has indeces. */ typedef struct { pFDR pfd; /* file descriptor for this file */ pSYMR psym; /* symbols for this file */ long csymMax; /* max allocated */ pAUXU paux; /* auxiliaries for this file */ long cauxMax; /* max allocated */ char *pss; /* strings space for this file */ long cbssMax; /* max bytes allowed in ss */ pOPTR popt; /* optimization table for this file */ long coptMax; /* max allocated */ pLINER pline; /* lines for this file */ long clineMax; /* max allocated */ pRFDT prfd; /* file indirect for this file */ long crfdMax; /* max allocated */ pPDR ppd; /* procedure descriptor tables */ long cpdMax; /* max allocated */ long freadin; /* set if read in */ } CFDR, *pCFDR; #define cbCFDR sizeof (CFDR) #define cfdNil ((pCFDR) 0) #define icfdNil -1 /* the following struct embodies the HDRR dtructure and is used at runtime * to access the objects in the HDRR with pointers (since the HDRR * only has indeces. */ typedef struct { long fappend; /* are we appending to this beast ? */ pCFDR pcfd; /* the compile time file descriptors */ pFDR pfd; /* all of the file descriptors in this cu */ long cfd; /* count of file descriptors */ long cfdMax; /* max file descriptors */ pSYMR psym; /* the symbols for this cu */ pEXTR pext; /* externals for this cu */ long cext; /* number of externals */ long cextMax; /* max currently allowed */ char *pssext; /* string space for externals */ long cbssext; /* # of bytes in ss */ long cbssextMax; /* # of bytes allowed in ss */ pAUXU paux; /* auxiliaries for this cu */ char *pss; /* string space for this cu */ pDNR pdn; /* dense number table for this cu */ long cdn; /* number of dn's */ long cdnMax; /* max currently allowed */ pOPTR popt; /* optimization table for this cu */ pLINER pline; /* lines for this cu */ pRFDT prfd; /* file indirect for this cu */ pPDR ppd; /* procedure descriptor tables */ int flags; /* which has been read in already */ int fswap; /* do dubtables need to be swapped */ HDRR hdr; /* header from disk */ } CHDRR, *pCHDRR; #define cbCHDRR sizeof (CHDRR) #define chdrNil ((pCHDRR) 0) #define ichdrNil -1 #endif /* _LANGUAGE_C */ /* constants and macros */ #define ST_FILESINIT 25 /* initial number of files */ #define ST_STRTABINIT 512 /* initial number of bytes in strring space */ #define ST_EXTINIT 32 /* initial number of symbols/file */ #define ST_SYMINIT 64 /* initial number of symbols/file */ #define ST_AUXINIT 64 /* initial number of auxiliaries/file */ #define ST_LINEINIT 512 /* initial number of auxiliaries/file */ #define ST_PDINIT 32 /* initial number of procedures in one file */ #define ST_DNINIT 128 /* initial # of dense numbers */ #define ST_FDISS 1 /* we expect a fd's iss to be this */ #define ST_IDNINIT 2 /* start the dense num tab with this entry */ #define ST_PROCTIROFFSET 1 /* offset from aux of proc's tir */ #define ST_RELOC 1 /* this sym has been reloced already */ #ifdef _LANGUAGE_FORTRAN #define ST_EXTIFD 0x7fffffff /* ifd for externals */ #define ST_RFDESCAPE 0xfff /* rndx.rfd escape says next aux is rfd */ #define ST_ANONINDEX 0xfffff /* rndx.index for anonymous names */ #endif #if (defined(_LANGUAGE_C) || (defined(_LANGUAGE_C_PLUS_PLUS))) #define ST_EXTIFD 0x7fffffff /* ifd for externals */ #define ST_RFDESCAPE 0xfff /* rndx.rfd escape says next aux is rfd */ #define ST_ANONINDEX 0xfffff /* rndx.index for anonymous names */ #define ST_PEXTS 0x01 /* mask, if set externals */ #define ST_PSYMS 0x02 /* mask, if set symbols */ #define ST_PLINES 0x04 /* mask, if set lines */ #define ST_PHEADER 0x08 /* mask, if set headers */ #define ST_PDNS 0x10 /* mask, if set dense numbers */ #define ST_POPTS 0x20 /* mask, if set optimization entries */ #define ST_PRFDS 0x40 /* mask, if set file indirect entries */ #define ST_PSSS 0x80 /* mask, if set string space */ #define ST_PPDS 0x100 /* mask, if set proc descriptors */ #define ST_PFDS 0x200 /* mask, if set file descriptors */ #define ST_PAUXS 0x400 /* mask, if set auxiliaries */ #define ST_PSSEXTS 0x800 /* mask, if set external string space */ #endif /* _LANGUAGE_C */ #ifdef _LANGUAGE_PASCAL #define ST_EXTIFD 16#7fffffff /* ifd for externals */ #define ST_RFDESCAPE 16#fff /* rndx.rfd escape says next aux is rfd */ #define ST_ANONINDEX 16#fffff /* rndx.index for anonymous names */ #define ST_PEXTS 16#01 /* mask, if set externals */ #define ST_PSYMS 16#02 /* mask, if set symbols */ #define ST_PLINES 16#04 /* mask, if set lines */ #define ST_HEADER 16#08 /* mask, if set header */ #define ST_PDNS 16#10 /* mask, if set dense numbers */ #define ST_POPTS 16#20 /* mask, if set optimization entries */ #define ST_PRFDS 16#40 /* mask, if set file indirect entries */ #define ST_PSSS 16#80 /* mask, if set string space */ #define ST_PPDS 16#100 /* mask, if set proc descriptors */ #define ST_PFDS 16#200 /* mask, if set file descriptors */ #define ST_PAUXS 16#400 /* mask, if set auxiliaries */ #define ST_PSSEXTS 16#800 /* mask, if set external string space */ #endif /* _LANGUAGE_PASCAL */ #define ST_FCOMPLEXBT(bt) ((bt == btStruct) || (bt == btUnion) || (bt == btTypedef) || (bt == btEnum)) #define valueNil 0 #define export /* * Constants to describe aux types used in swap_aux( , ,type); */ #define ST_AUX_TIR 0 #define ST_AUX_RNDXR 1 #define ST_AUX_DNLOW 2 #define ST_AUX_DNMAC 3 #define ST_AUX_ISYM 4 #define ST_AUX_ISS 5 #define ST_AUX_WIDTH 6 #endif gcl-2.6.14/h/sun3-os4.defs0000755000175000017500000000277614360276512013477 0ustar cammcammLBINDIR=/usr/local/bin # For sun3 Operating system 4. # (Note OS 4.0 prior to 4.0.3 is flaky and you may have troubles) OFLAG= -O ODIR_DEBUG= LIBS = -lm -lg # -I$(GCLDIR)/o is so that the cc command will be able to find a # cmpinclude.h even if it is not in /usr/include. We do not use the # h directory since there are so many .h files there, one of their # names might conflict with a users name, eg if he has a file vs.lisp CC = cc -DVOL= -I$(GCLDIR)/o -Bstatic -temp=. # Adding "-Qoption as -O" to CC is advised under OS4.0 because of sun bug. # CC = cc -DVOL= -Bstatic -I$(GCLDIR)/o -Qoption as -O # I don't know if that is necessary in 4.0.3 # if using gcc we need the -Bstatic in the loader flag, but also gnulib # gcc 1.36 has a definite bug--dont use it for GCL. gcc 1.35 is ok. # If using regular cc comment out the next 2 lines CC = gcc -DVOL=volatile -I$(GCLDIR)/o -fwritable-strings -msoft-float LIBS = -lm -lg /usr/local/lib/gcc-gnulib LDCC= cc -Bstatic # Currently the result of lisp compilation cannot always be compiled on -O4, # but all files in the ./o directory can. ODIR_DEBUG= CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o RSYM = rsym SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-sun NULLFILE = ../h/secondary_sun_magic gcl-2.6.14/h/bits.h0000644000175000017500000000260414360276512012336 0ustar cammcamm#define mjoin(a_,b_) a_ ## b_ #define Mjoin(a_,b_) mjoin(a_,b_) #include "arth.h" #define LM(a_) AM(AT(SIZEOF_LONG,8),a_) #if SIZEOF_LONG == 4 #define LL 2 #elif SIZEOF_LONG == 8 #define LL 3 #else #error "unknown SIZEOF_LONG" #endif #define POW AM(PAGEWIDTH,AP(LL,1)) struct pageinfo { unsigned long type:6; unsigned long magic:7; unsigned long sgc_flags:2; unsigned long in_use:LM(15); struct pageinfo *next; }; #ifndef WORDS_BIGENDIAN #define FIRSTWORD unsigned long e:1,m:1,f:1,s:1,tt:4,t:5,st:3,w:LM(16) #define FSTPWORD unsigned long emfs:4, tp:9, st:3,w:LM(16) #define MARKWORD unsigned long e:1, mf:2,s:1,tt:4,t:5,x:LM(13) #define SGCMWORD unsigned long e:1,mfs:3, tt:4,t:5,x:LM(13) #define TYPEWORD unsigned long emf:3, s:1,tt:4,t:5,x:LM(13) #define FUNWORD unsigned long e:1,m:1,f:1,s:1,tt:4,t:5,fun_minarg:6,fun_maxarg:6,fun_neval:5,fun_vv:1,y:LM(31) #else #define FIRSTWORD unsigned long w:LM(16),st:3,t:5,tt:4,s:1,f:1,m:1,e:1 #define FSTPWORD unsigned long w:LM(16),st:3,tp:9, emfs:4 #define MARKWORD unsigned long x:LM(13), t:5,tt:4,s:1, mf:2,e:1 #define SGCMWORD unsigned long x:LM(13), t:5,tt:4, mfs:3,e:1 #define TYPEWORD unsigned long x:LM(13), t:5,tt:4,s:1, emf:3 #define FUNWORD unsigned long y:LM(31),fun_vv:1,fun_neval:5,fun_maxarg:6,fun_minarg:6,t:5,tt:4,s:1,f:1,m:1,e:1 #endif gcl-2.6.14/h/solaris.h0000755000175000017500000000200614360276512013050 0ustar cammcamm#ifndef __ELF__ #define __ELF__ #endif #define ElfW(a) Elf32_ ## a #if !defined(HAVE_LIBBFD) && !defined(USE_DLOPEN) #define __ELF_NATIVE_CLASS 32 #include #endif #include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("SPARC") #define SPARC #define SGC #define PTR_ALIGN 8 #undef LISTEN_FOR_INPUT #undef SIG_UNBLOCK_SIGNALS #define NO_SYSTEM_TIME_ZONE void bcopy (const void *,void *,size_t); void bzero(void *,size_t); int bcmp(const void *,const void *,size_t); #if SIZEOF_LONG==4 #define RELOC_H "elf32_sparc_reloc.h" #else #define RELOC_H "elf64_sparc_reloc.h" #define SPECIAL_RELOC_H "elf64_sparc_reloc_special.h" void unwind() __attribute__((optimize("O0")));/*FIXME*/ #endif gcl-2.6.14/h/sfun_argd.h0000755000175000017500000000151414360276512013347 0ustar cammcamm#define VFUN_NARG_BIT (1 <<11) #define SFUN_RETURN_MASK (0xf00 & ~VFUN_NARG_BIT) #define SFUN_ARG_TYPE_MASK (~0xfff) #define SFUN_RETURN_TYPE(s) \ ((enum ftype)(((s) & SFUN_RETURN_MASK) >> 8)) #define SFUN_START_ARG_TYPES(x) (x=(x>>10)) #define SFUN_NEXT_TYPE(x) ((enum ftype)((x=(x>>2))& 3)) #define MAX_C_ARGS 9 /* ...xx|xx|xxxx|xxxx| ret Narg */ /* a9a8a7a6a5a4a3a4a3a2a1a0rrrrnnnnnnnn ai=argtype(i) ret nargs */ #define SFUN_NARGS(x) (x & 0xff) /* 8 bits */ #define RESTYPE(x) (x<<8) /* 2 bits */ /* set if the VFUN_NARGS = m ; has been set correctly */ #define ARGTYPE(i,x) ((x) <<(12+(i*2))) #define ARGTYPE1(x) (1 | ARGTYPE(0,x)) #define ARGTYPE2(x,y) (2 | ARGTYPE(0,x) | ARGTYPE(1,y)) #define ARGTYPE3(x,y,z) (3 | ARGTYPE(0,x) | ARGTYPE(1,y) | ARGTYPE(2,z)) gcl-2.6.14/h/rt_aix.h0000755000175000017500000001067514360276512012675 0ustar cammcamm#define ATT #define RT #ifndef AIX #define AIX #endif #include "att.h" #define HAVE_AOUT #define ADDITIONAL_FEATURES \ ADD_FEATURE("IBMRT"); \ ADD_FEATURE("AIX");\ ADD_FEATURE("BUGGY-CC"); \ ADD_FEATURE("RT") #define USE_C_EXTENDED_DIV #define USE_C_EXTENDED_MUL #define IBMRT #define IEEEFLOAT #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ real_maxpage= ulimit(3)/PAGESIZE; \ if (real_maxpage > MAXPAGE) \ real_maxpage = MAXPAGE; #define N_DATADDR(header) #define DATA_BEGIN (char *)header.a_dbase #undef MEM_SAVE_LOCALS #define MEM_SAVE_LOCALS \ struct exec header;\ int stsize #undef READ_HEADER #define READ_HEADER fread(&header, sizeof(header), 1, original); \ data_begin=DATA_BEGIN; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ header.a_bss = 0; \ if (header.a_flags & A_HDREXT) printf("extended header"); \ fwrite(&header, sizeof(header), 1, save); /* I don't know why all the bsd versions are subtracting this off I thought the header.a_text was the actual size of the text not including the header */ #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text - sizeof(header)); #undef COPY_TO_SAVE #define COPY_TO_SAVE \ filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize +header.a_lnums); \ fread(&stsize, sizeof(stsize), 1, original); \ fwrite(&stsize, sizeof(stsize), 1, save); \ filecpy(save, original, stsize - sizeof(stsize)) #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) /* smallest address data can occur */ /* #define DBEGIN 0x20000000 */ #define SYM_EXTERNAL_P(sym) (((sym)->n_sclass & (~N_SECT)) == C_EXT) #define SYM_UNDEF_P(sym) (((sym)->n_sclass & N_SECT) == N_UNDF) #define NUM_AUX(sym) ((sym)->n_numaux) #define SYM_NAME(p) SYM_NAME1((struct syment *)(p)) #define SYM_NAME1(p) \ (((p)->_n._n_n._n_zeroes == 0) ? \ &my_string_table[(p)->_n._n_n._n_offset] : \ ((p)->_n._n_name[SYMNMLEN -1] ? \ (strncpy(tem,(p)->_n._n_name, \ SYMNMLEN), \ (char *)tem) : \ (p)->_n._n_name )) /* the section like N_ABS,N_TEXT,.. */ #define N_SECTION(sym) (((struct syment *)sym)->n_sclass & N_SECT ) #define N_TYPE N_SECT /* the header is regared as part of the text */ #define N_RELOFF(header) A_TRELPOS(header) #define N_SYMOFF(header) A_SYMPOS(header) #define N_TXTOFF(header) A_TEXTPOS(header) #define SYMNMLEN 8 #define EXT_and_TEXT_BSS_DAT(p) \ ((SYM_EXTERNAL_P(p)) && ((N_SECTION(p) == N_TEXT) || \ (N_SECTION(p) == N_DATA) || \ (N_SECTION(p) == N_BSS))) #define N_BADMAG(x) BADMAG(x) /* the beginning of the string table: first long will be size of string table */ #define N_STROFF(x) A_NAMEPOS(x) #define MUST_SEEK_TO_STROFF /* in aix we must use the pointer to the constant pool for the init_code, not the actual pointer to the code. */ /* this is no longer valid #define VERIFY_INIT \ if (at==0 || *(char **)at!= memory->cfd.cfd_start) \ FEerror("init code constant pool bad"); */ /* find the first symbol in the data section: It should begin with with "_init_" and correspond to the beginning of the pcp pool for the init function..*/ #define FIND_INIT \ { if (*ptr==0 && (N_SECTION(sym) == N_DATA) && sym->n_value ) \ { char tem [9]; \ char *str=SYM_NAME(sym); \ dprintf(find init: %s ,str); \ if (str[1]=='i' && str[2]=='n' && str[3]=='i' && str[4]== 't' \ && str[5]=='_' && str[0]== '_' && str[strlen(str)-1] !='X') \ *ptr= sym->n_value ; \ else {/* printf("The first data symbol was not the init");*/} \ }} #define RELOC_FILE "rel_aix.c" #define GETCWD /* the system defines a different getwd */ #define getwd ourgetwd /* these two symbols are too long for the rt pl8cc compiler */ #define check_type_or_pathname_string_symbol_stream check_type_or_path_or_strm #define check_type_or_Pathname_string_symbol check_type_or_path_sym #define TSor_pathname_string_symbol_stream TSor_path_string_sym_strm #define check_type_or_symbol_string_package check_type_or_sym_str_pack /* If free is likely to be called multiple times on the same block (in contravention of ANSI C) by system functions, don't break on such an error */ #define NOFREE_ERR /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/secondary_sun_magic0000755000175000017500000000001014360276512015153 0ustar cammcammgcl-2.6.14/h/mach32_i386_reloc.h0000644000175000017500000000051314360276512014404 0ustar cammcamm case GENERIC_RELOC_VANILLA: redirect_trampoline(ri,*q,rel,sec1,io1,n1,&a); if (ri->r_extern) store_val(q,~0L,ri->r_pcrel ? a-rel : a); else if (!ri->r_pcrel) add_val(q,~0L,a); break; case GENERIC_RELOC_LOCAL_SECTDIFF: case GENERIC_RELOC_SECTDIFF: case GENERIC_RELOC_PAIR: break; gcl-2.6.14/h/armhf-linux.h0000644000175000017500000000064714360276512013634 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define SGC #define RELOC_H "elf32_armhf_reloc.h" #define SPECIAL_RELOC_H "elf32_armhf_reloc_special.h" #define NEED_STACK_CHK_GUARD gcl-2.6.14/h/sun386i.h0000755000175000017500000000673714360276512012632 0ustar cammcamm/* created 3/14/89 by Michael Newton */ /* %Caltech Submillimeter Observatory */ /* POBox 4339 */ /* Hilo HI 96720 */ /* newton@csvax.caltech.edu */ /* The sun386i is a ss mostly BSD, but uses COFF. There are some bugs, and I was not able to get help through the support number. I _hope_ this code works for you but this code is supplied as is with NO WARRANTIES. */ /* We can't include bsd.h or att.h since neither is accurate (true?) */ #ifdef IN_UNIXFSYS #define BSD #else #define ATT #endif #define UNIX #define AV #define SFASL #define VSSIZE 8152 /* We use a COFF derived MEM_SAVE_LOCALS, READ_HEADER, COPY_TO_SAVE */ /* All of this is from wfs's code... */ #define MEM_SAVE_LOCALS \ struct filehdr fileheader;\ struct exec header;\ struct scnhdr sectionheader;\ int diff #define READ_HEADER \ do{ fread(&fileheader, sizeof(fileheader), 1, original); \ fread(&header, sizeof(header), 1, original); \ data_begin = (char *)header.data_start; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ diff = header.a_data - original_data; \ header.a_bss = sbrk(0) - core_end; \ fileheader.f_symptr += diff; \ fwrite(&fileheader, sizeof(fileheader), 1, save);\ fwrite(&header, sizeof(header), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_size += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ fread(§ionheader, sizeof(sectionheader), 1, original); \ sectionheader.s_paddr += diff; \ sectionheader.s_vaddr += diff; \ sectionheader.s_size = header.a_bss; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ for (n = 4; n <= fileheader.f_nscns; n++) { \ fread(§ionheader, sizeof(sectionheader), 1, original); \ if (sectionheader.s_scnptr) \ sectionheader.s_scnptr += diff; \ if (sectionheader.s_lnnoptr) \ sectionheader.s_lnnoptr += diff; \ fwrite(§ionheader, sizeof(sectionheader), 1, save); \ }}while(0) #define COPY_TO_SAVE \ do{for (;;) { \ n = getc(original); \ if (feof(original)) \ break; \ putc(n, save); \ }}while (0) #define FILECPY_HEADER filecpy(save, original, header.a_text) #define exec aouthdr #define a_text tsize #define a_data dsize #define a_bss bsize /* Include rather than */ /* I'm not sure whether to include this or not -- MON */ /* ???? #define HAVE_FCNTL ???? */ #define NUMBER_OPEN_FILES _NFILE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define INIT_ALLOC \ heap_end = sbrk(0); \ if (i = ((int)heap_end & (PAGESIZE - 1))) \ sbrk(PAGESIZE - i); \ heap_end = core_end = sbrk(0); #define IF_ALLOCATE_ERR \ if (core_end != sbrk(0)) \ error("Someone allocated my memory!"); \ if (core_end != sbrk(PAGESIZE*(n - m))) #define cs_check(x) #define ADDITIONAL_FEATURES \ ADD_FEATURE("SUN"); \ ADD_FEATURE("I386") /* ?? add "SYSTEM-V" to the above???? -- MON */ #define I386 #define IEEEFLOAT #define DATA_BEGIN (char *)N_DATADDR(header) #define N_RELOFF N_TRELOFF #define RELOC_FILE "rel_coff.c" /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/gclincl.h.in0000644000175000017500000002243714360276512013423 0ustar cammcamm/* h/gclincl.h.in. Generated from configure.in by autoheader. */ /* constant to reserve upper 3Gb for C stack */ #undef ADDR_COMPAT_LAYOUT /* only 3Gb of address space */ #undef ADDR_LIMIT_3GB /* punt guess for no randomize value */ #undef ADDR_NO_RANDOMIZE /* ANSI compliant image */ #undef ANSI_COMMON_LISP /* binding stack size */ #undef BDSSIZE /* sscanf terminates prematurely (Windows XP) */ #undef BUGGY_MAXIMUM_SSCANF_LENGTH /* can prevent sbrk from returning random values */ #undef CAN_UNRANDOMIZE_SBRK /* running clang compiler */ #undef CLANG /* cstack max */ #undef CSTACKMAX /* starting C stack address */ #undef CSTACK_ADDRESS /* C stack alignment */ #undef CSTACK_ALIGNMENT /* log starting C stack address */ #undef CSTACK_BITS /* whether C stack grows up or down */ #undef CSTACK_DIRECTION /* Define to 1 if using 'alloca.c'. */ #undef C_ALLOCA /* debug safecdr code */ #undef DEBUG_SAFE_CDR /* big endian word order */ #undef DOUBLE_BIGENDIAN /* frame stack size */ #undef FRSSIZE /* use gprof profiling */ #undef GCL_GPROF /* No gettimeofday call -- fixme */ #undef GETTOD_NOT_DECLARED /* using gmp */ #undef GMP /* Define to 1 if you have 'alloca', as a function or macro. */ #undef HAVE_ALLOCA /* Define to 1 if works. */ #undef HAVE_ALLOCA_H /* Define to 1 if you have the header file. */ #undef HAVE_ASM_SIGCONTEXT_H /* Define to 1 if you have the header file. */ #undef HAVE_ASM_SIGNAL_H /* bfd_boolean defined */ #undef HAVE_BFD_BOOLEAN /* Define to 1 if you have the header file. */ #undef HAVE_BFD_H /* have bsdgettimeofday */ #undef HAVE_BSDGETTIMEOFDAY /* have __builtin__clear_cache instruction */ #undef HAVE_BUILTIN_CLEAR_CACHE /* clzl instruction */ #undef HAVE_CLZL /* Define to 1 if you have the header file. */ #undef HAVE_COMPLEX_H /* ctzl instruction */ #undef HAVE_CTZL /* have readline completion matches */ #undef HAVE_DECL_RL_COMPLETION_MATCHES /* Define to 1 if you have the header file. */ #undef HAVE_DIRENT_H /* Define to 1 if you have the header file. */ #undef HAVE_DIS_ASM_H /* have struct dirent d_type field */ #undef HAVE_D_TYPE /* Define to 1 if you have the header file. */ #undef HAVE_ELF_ABI_H /* Define to 1 if you have the header file. */ #undef HAVE_ELF_H /* Define to 1 if you have the `feenableexcept' function. */ #undef HAVE_FEENABLEEXCEPT /* Have finite function */ #undef HAVE_FINITE /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the `getcwd' function. */ #undef HAVE_GETCWD /* Define to 1 if you have the `getwd' function. */ #undef HAVE_GETWD /* Define to 1 if you have the header file. */ #undef HAVE_GMP_H /* gnu linker present */ #undef HAVE_GNU_LD /* Have ieeefp fpclass function */ #undef HAVE_IEEEFP /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Have isfinite function */ #undef HAVE_ISFINITE /* Have isnormal function */ #undef HAVE_ISNORMAL /* Define to 1 if you have the header file. */ #undef HAVE_JAPI_H /* use libbfd */ #undef HAVE_LIBBFD /* Define to 1 if you have the `dl' library (-ldl). */ #undef HAVE_LIBDL /* Define to 1 if you have the `opcodes' library (-lopcodes). */ #undef HAVE_LIBOPCODES /* long long is available */ #undef HAVE_LONG_LONG /* Define to 1 if you have the header file. */ #undef HAVE_MALLOC_MALLOC_H /* memalign element present */ #undef HAVE_MALLOC_ZONE_MEMALIGN /* Define to 1 if you have the header file. */ #undef HAVE_MATH_H /* Define to 1 if you have the `mprotect' function. */ #undef HAVE_MPROTECT /* can use nsocket library */ #undef HAVE_NSOCKET /* output_bfd element present */ #undef HAVE_OUTPUT_BFD /* have putenv call */ #undef HAVE_PUTENV /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_READLINE_H /* have readline completion matches */ #undef HAVE_RL_COMPENTRY_FUNC_T /* have setenv call */ #undef HAVE_SETENV /* Define to 1 if you have the header file. */ #undef HAVE_SETJMP_H /* Define to 1 if you have the `sigaltstack' function. */ #undef HAVE_SIGALTSTACK /* have sigcontext */ #undef HAVE_SIGCONTEXT /* have SIGEMT signal */ #undef HAVE_SIGEMT /* have SIGSYS signal */ #undef HAVE_SIGSYS /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* have sv_onstack */ #undef HAVE_SV_ONSTACK /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_MMAN_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKIO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the header file. */ #undef HAVE_VALUES_H /* have xdr extensions */ #undef HAVE_XDR /* using xgcl */ #undef HAVE_XGCL /* Host cpu */ #undef HOST_CPU /* Host kernel */ #undef HOST_KERNEL /* Host system */ #undef HOST_SYSTEM /* invocation history stack size */ #undef IHSSIZE /* beginning address for immediate fixnum range */ #undef IM_FIX_BASE /* size of immediate fixnum address space */ #undef IM_FIX_LIM /* symbol name mangling convention */ #undef LEADING_UNDERSCORE /* can use fcntl for listen function */ #undef LISTEN_USE_FCNTL /* upper immediate fixnum bound */ #undef LOW_SHFT /* size of immediate fixnum address space */ #undef MEM_RANGE /* beginning address for immediate fixnum range */ #undef MEM_TOP /* sizeof mp_limb in gmp library */ #undef MP_LIMB_BYTES /* binutils requires CONST definition */ #undef NEED_CONST /* C stack address is negative */ #undef NEG_CSTACK_ADDRESS /* no gettimeofday call */ #undef NO_GETTOD /* no profil system call */ #undef NO_PROFILE /* can use C extension for functions that do not return */ #undef NO_RETURN /* no uname call */ #undef NO_UNAME /* lowest address non-object */ #undef OBJNULL /* can use C extension for object alignment */ #undef OBJ_ALIGN /* needed object alignment bytes */ #undef OBJ_ALIGNMENT /* extern inline semantics */ #undef OLD_INLINE /* bfd output arch */ #undef OUTPUT_ARCH /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* system pagewidth */ #undef PAGEWIDTH /* readline is editline */ #undef READLINE_IS_EDITLINE /* rl_completion_entry_function returns type Function */ #undef RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION /* rl_completion_entry_function returns type rl_compentry_func_t */ #undef RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T /* rl_readline_name returns type char */ #undef RL_READLINE_NAME_TYPE_CHAR /* rl_readline_name returns type const char */ #undef RL_READLINE_NAME_TYPE_CONST_CHAR /* asm string to set the stack pointer */ #undef SET_STACK_POINTER /* have sigcontext of signal.h */ #undef SIGNAL_H_HAS_SIGCONTEXT /* sizeof linked list for contiguous pages */ #undef SIZEOF_CONTBLOCK /* sizeof jmp_buf */ #undef SIZEOF_JMP_BUF /* The size of `long', as computed by sizeof. */ #undef SIZEOF_LONG /* The size of `time_t', as computed by sizeof. */ #undef SIZEOF_TIME_T /* If using the C implementation of alloca, define if you know the direction of stack growth for your system; otherwise it will be automatically deduced at runtime. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown */ #undef STACK_DIRECTION /* staticly linked images */ #undef STATIC_LINKING /* Define to 1 if all of the C90 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #undef STDC_HEADERS /* have _cleanup function */ #undef USE_CLEANUP /* link compiled objects via libdl */ #undef USE_DLOPEN /* use fionbio for non-blocking io */ #undef USE_FIONBIO /* use readline library */ #undef USE_READLINE /* protect cdr from immfix and speed up type processing */ #undef USE_SAFE_CDR /* value stack size */ #undef VSSIZE /* three word cons */ #undef WIDE_CONS /* big endian byte order */ #undef WORDS_BIGENDIAN /* long gmp3 limbs */ #undef __LONG_LONG_LIMB /* short gmp3 limbs */ #undef __SHORT_LIMB /* Define to `unsigned int' if does not define. */ #undef size_t gcl-2.6.14/h/sun4.defs0000755000175000017500000000223214360276512012760 0ustar cammcamm# for sparcs under sun OS 4.x.x OFLAG = -O LIBS = -lm # the commercial (for money) C compiler has never been able # to compile akcl/gcl correctly. Perhaps it does not like the idea # that this is free software. However the standard C compiler is ok. #CC = cc -DVOL= -I$(GCLDIR)/o -Bstatic -temp=. -pipe CC = cc -DVOL= -I$(GCLDIR)/o -Bstatic -pipe ODIR_DEBUG=-O4 #gcc 2.1 and 2.2 compile gcl correctly as far as I have been able to determine. #gcc 2.3.3 does not compile gcl correctly # gcc 2.5.7 is correct as far as I can tell # and gcl compiled with gcc runs our tests 15% faster than with cc.. CC = gcc -I${GCLDIR}/o -DVOL=volatile -pipe -fsigned-char LDCC = gcc -static AS=as -P CFLAGS = -c $(DEFS) -I../h MAIN = ../o/main.o MPFILES=$(MPDIR)/mpi-sparc.o $(MPDIR)/sparcdivul3.o $(MPDIR)/libmport.a #MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a RSYM = rsym SFASL = $(ODIR)/sfasl.o # This function will be run before dumping. # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. GCP=gcp-sun NULLFILE = ../h/secondary_sun_magic gcl-2.6.14/h/amd64-kfreebsd.h0000644000175000017500000000116214360276512014071 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr #endif /*#define NULL_OR_ON_C_STACK(x) ((x)==0 || ((unsigned int)x) > (unsigned int)(pagetochar(MAXPAGE+1)))*/ #define ADDITIONAL_FEATURES \ ADD_FEATURE("BSD386"); \ ADD_FEATURE("MC68020") #define I386 #define SGC /* Apparently stack pointers can be 4 byte aligned, at least &argc -- CM */ #define C_GC_OFFSET 4 #define RELOC_H "elf64_i386_reloc.h" #define BRK_DOES_NOT_GUARANTEE_ALLOCATION #define FREEBSD gcl-2.6.14/h/elf64_alpha_reloc_special.h0000644000175000017500000001043014360276512016342 0ustar cammcammstatic ul ggot1,ggote,gotoff,mcount; static int write_stub_mcount(ul s,ul *gote) { unsigned int *goti; /*mcount calls written using at register, address not available in stub*/ /*mcount guaranteed to be within 32bits*/ *gote=(ul)(goti=(void *)(gote+1)); *goti++=(0x9<<26)|(0x1b<<21)|(0x1f<<16)|((s-(short)s)>>16); /*ldah t12,(symhigh)(zero)*/ *goti++=(0x8<<26)|(0x1b<<21)|(0x1b<<16)|(s&MASK(16)); /*lda t12,(symlow)(t12)*/ *goti++=(0x29<<26)|(0x1b<<21)|(0x1b<<16)|0; /*ldq t12,0(t12)*/ *goti++=(0x1a<<26)|(0x1f<<21)|(0x1b<<16)|0x4000; /*jsr zero,(t12),$pc+4*/ *goti++=0; /*halt*/ *goti++=0; /*halt*/ return 0; } static int write_stub(ul s,ul *gote) { unsigned int *goti; if (s==mcount) return write_stub_mcount(mcount,gote); *gote=(ul)(goti=(void *)(gote+2)); *++gote=s; *goti++=(0x29<<26)|(0x1b<<21)|(0x1b<<16)|0xfff8; /*ldq t12,-8(t12)*/ *goti++=(0x29<<26)|(0x1b<<21)|(0x1b<<16)|0; /*ldq t12,0(t12)*/ *goti++=(0x1a<<26)|(0x1f<<21)|(0x1b<<16)|0x4000; /*jsr zero,(t12),$pc+4*/ *goti++=0; /*halt*/ return 0; } static int make_got_room_for_stub(Shdr *sec1,Shdr *sece,Sym *sym,const char *st1,ul *gs) { Shdr *ssec=sec1+sym->st_shndx; struct node *a; if ((ssec>=sece || !ALLOC_SEC(ssec)) && (a=find_sym_ptable(st1+sym->st_name)) && a->address>=ggot1 && a->addresssh_addr; ggote=ggot1+sec->sh_size; massert(sec=get_section(".dynstr",sec1,sece,sn));/*FIXME pass as parameter*/ dst1=v+sec->sh_offset; massert((sec=get_section(".rel.dyn",sec1,sece,sn))|| (sec=get_section(".rela.dyn",sec1,sece,sn))); v+=sec->sh_offset; ve=v+sec->sh_size; for (r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info) && !(sym=ds1+ELF_R_SYM(r->r_info))->st_value) { sym->st_value=r->r_offset; if (!strncmp("_mcount",dst1+sym->st_name,7)) mcount=sym->st_value; } return 0; } #define HIGH(a_) ((a_)>>32) #define LOW(a_) ((a_)&MASK(32)) #define SET_HIGH(a_,b_) ({ul _a=(a_);(a_)=((b_)<<32)|LOW(_a);}) static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Sym *sym,*fsym=sym1; Rela *r; Shdr *sec; void *v,*ve; ul q,gotp; for (sym=sym1;symst_value)); massert(!HIGH(sym->st_size)); } for (*gs=gotp=0,sec=sec1;secsh_type==SHT_RELA) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) { if (HIGH(r->r_addend)) fprintf(stderr,"zeroing high addend %lx\n",HIGH(r->r_addend));/*never reached fix(Cnil) code, to be eliminated*/ SET_HIGH(r->r_addend,0UL); switch(ELF_R_TYPE(r->r_info)) { case R_ALPHA_LITERAL: if (!r->r_addend) { sym=sym1+ELF_R_SYM(r->r_info); q=(HIGH(sym->st_size)-gotp)*sizeof(*gs); if (!HIGH(sym->st_size) || q!=(short)q) {/*new cached got entry if first or out of range*/ SET_HIGH(sym->st_size,++*gs); massert(!make_got_room_for_stub(sec1,sece,sym,st1,gs)); } q=HIGH(sym->st_size); } else q=++*gs; SET_HIGH(r->r_addend,q); q=(q-gotp)*sizeof(*gs);/*check 16bit range gprel address in range*/ massert(q==(short)q); break; case R_ALPHA_GPDISP: for (sym=fsym;symst_shndx!=1 || LOW(sym->st_value)!=r->r_offset);sym++);/*ordered search*/ if (symst_value,gotp=*gs+1); } SET_HIGH(r->r_addend,gotp); break; case R_ALPHA_GPREL32: q=LOW(sym1[ELF_R_SYM(r->r_info)].st_value)+r->r_addend; /*unordered search*/ for (sym=sym1;symst_shndx!=1 || LOW(sym->st_value)>q || LOW(sym->st_value)+LOW(sym->st_size)r_addend,HIGH(sym->st_value)); break; } } for (sym=sym1;symst_value,0UL); SET_HIGH(sym->st_size,0UL); } return 0; } gcl-2.6.14/h/elf64_ppcle_reloc_special.h0000644000175000017500000000426014360276512016364 0ustar cammcammstatic Sym *toc; static int tramp[]={0,0, (((0x3a<<10)|(0x9<<5)|0xc)<<16)|0xfff8,/*ld r9,-8(r12)*/ ((0x3a<<10)|(0x9<<5)|0x9)<<16, /*ld r9,0(r9)*/ 0x7d2c4b78, /*mr r12,r9 */ 0x7d8903a6, /*mtctr r12*/ 0x4e800420 /*bctrl*/ }; static int load_trampolines(void *v,Shdr *sec,Sym *ds1) { Rela *r; void *ve; ul *u,j; v+=sec->sh_offset; ve=v+sec->sh_size; for (j=0,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info) && !ds1[ELF_R_SYM(r->r_info)].st_value) j++; massert(u=malloc(j*sizeof(tramp))); v=ve-sec->sh_size; for (r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info) && !ds1[ELF_R_SYM(r->r_info)].st_value) { memcpy(u,tramp,sizeof(tramp)); *u++=r->r_offset; ds1[ELF_R_SYM(r->r_info)].st_value=(ul)u; u=((void *)(u-1)+sizeof(tramp)); } return 0; } static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { Shdr *sec; massert((sec=get_section(".rela.dyn",sec1,sece,sn))); massert(!load_trampolines(v,sec,ds1)); if ((sec=get_section(".rela.plt",sec1,sece,sn))) massert(!load_trampolines(v,sec,ds1)); return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rela *r; void *v,*ve; Shdr *sec; Sym *sym; for (toc=NULL,sym=sym1;symst_name; if (!strcmp(s,".TOC.") || !strcmp(s,".toc.")) { toc=sym; toc->st_info=ELF_ST_INFO(STB_LOCAL,ELF_ST_TYPE(sym->st_info)); massert((sec=get_section(".bss",sec1,sece,sn))); toc->st_shndx=sec-sec1; } } for (sym=sym1;symst_size=0; for (*gs=0,sec=sec1;secsh_type==SHT_RELA) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if (ELF_R_TYPE(r->r_info)==R_PPC64_PLT16_HA|| ELF_R_TYPE(r->r_info)==R_PPC64_PLT16_LO_DS) { sym=sym1+ELF_R_SYM(r->r_info); if (!sym->st_size) sym->st_size=++*gs; } return 0; } gcl-2.6.14/h/coff_encap.h0000755000175000017500000000254014360276512013462 0ustar cammcamm/* to be included by machine.h when the gnu coff encapsulation scheme is used */ #define COFF_ENCAPSULATE #define MEM_SAVE_LOCALS \ struct coffheader header1;\ struct coffscn *tp, *dp, *bp;\ struct exec header;\ int stsize #define READ_HEADER \ fread(&header1, sizeof(header1), 1, original); \ tp = &header1.scns[0]; \ dp = &header1.scns[1]; \ bp = &header1.scns[2]; \ fread(&header, sizeof(header), 1, original); \ data_begin=DATA_BEGIN; \ data_end = core_end; \ original_data = header.a_data; \ header.a_data = data_end - data_begin; \ header.a_bss = 0; \ dp->s_size = header.a_data; \ bp->s_paddr = dp->s_vaddr + dp->s_size; \ bp->s_vaddr = bp->s_paddr; \ bp->s_size = 0; \ header1.tsize = tp->s_size; \ header1.dsize = dp->s_size; \ header1.bsize = bp->s_size; \ fwrite(&header1, sizeof(header1), 1, save); \ fwrite(&header, sizeof(header), 1, save); #define FILECPY_HEADER \ filecpy(save, original, header.a_text); #define COPY_TO_SAVE \ filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); \ fread(&stsize, sizeof(stsize), 1, original); \ fwrite(&stsize, sizeof(stsize), 1, save); \ filecpy(save, original, stsize - sizeof(stsize)) gcl-2.6.14/h/elf32_arm_reloc_special.h0000644000175000017500000000163314360276512016034 0ustar cammcammstatic int tramp[]={0xe59fc000, /*ldr r12, [pc]*/ /*FIXME? Can this refer to an earlier address?*/ 0xe12fff1c}; /*br r12*/ static ul tz=1+sizeof(tramp)/sizeof(ul); static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym,Sym *syme) { return 0; } static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { Rel *r; Sym *sym; Shdr *sec; void *v,*ve; for (sym=sym1;symst_size=0; for (*gs=0,sec=sec1;secsh_type==SHT_REL) for (v=v1+sec->sh_offset,ve=v+sec->sh_size,r=v;vsh_entsize,r=v) if ( ELF_R_TYPE(r->r_info)==R_ARM_CALL || ELF_R_TYPE(r->r_info)==R_ARM_JUMP24 ) { sym=sym1+ELF_R_SYM(r->r_info); if (!sym->st_size) sym->st_size=++*gs; } (*gs)*=tz; return 0; } gcl-2.6.14/h/rios-aix3.defs0000755000175000017500000000233714360276512013713 0ustar cammcammLBINDIR=/usr/bin #defs for the makefiles LD_ORDINARY_CC= cc RANLIB=true OFLAG = -O LIBS = -lm -lg # where to find libX11.a and libtcl.a and their include files: #LIBS_X11_TK= -lX11 -L/usr/local/lib -L/p/lib -ltcl -ltk #TK_INCLUDE_DIR=-I/p/include/ #X11_INCLUDE_DIR=-I/usr/openwin/include LIBS = -lm -bexport:${GCLDIR}/unixport/aix_exports ODIR_DEBUG= SHELL=/bin/sh .IGNORE: CC = cc -qlanglvl=ext -qnoprint -DCOM_LENG= -DVOL=volatile -I$(GCLDIR)/o -bnso -bI:/lib/syscalls.exp -Wl,-D0 -H4096 -qchars=signed LDCC = $(CC) -Wl,-bfilelist # if you add to EXTRAS: # Remember you must add the names of any functions you want to reference # in lisp code, to unixport/aix_exports or add your own exports file to # LIBS above EXTRA_LIB = fsavres.o GCLIB = ${ODIR}/gcllib.a CFLAGS = -c $(DEFS) -I../h # fast loading RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios1.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a # version of gcl with -pg profiling. (cd unixport ; make kcp) KCP=kcp-aix gcl-2.6.14/h/elf64_sparc_reloc_special.h0000644000175000017500000000211214360276512016363 0ustar cammcamm#undef ELF_R_TYPE #define ELF_R_TYPE(a) (ELF64_R_TYPE(a)&0xff) #define ELF_R_ADDEND(a) (((ELF64_R_TYPE(a)>>8)^0x800000)-0x800000) static int label_got_symbols(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,Sym *syme,const char *st1,const char *sn,ul *gs) { return 0; } static int find_special_params(void *v,Shdr *sec1,Shdr *sece,const char *sn, const char *st1,Sym *ds1,Sym *dse,Sym *sym1,Sym *syme) { return 0; } int store_ival(int *w,ul m,ul v) { *w=(v&m)|(*w&~m); return 0; } int store_ivals(int *w,ul m,ul v) { massert(ovchks(v,~m)); return store_ival(w,m,v); } int store_ivalu(int *w,ul m,ul v) { massert(ovchku(v,~m)); return store_ival(w,m,v); } int add_ival(int *w,ul m,ul v) { return store_ival(w,m,v+(*w&m)); } int add_ivalu(int *w,ul m,ul v) { return store_ivalu(w,m,v+(*w&m)); } int add_ivals(int *w,ul m,ul v) { ul l=*w&m,mm; mm=~m; mm|=mm>>1; if (l&mm) l|=mm; return store_ival(w,m,v+l); } int add_ivalsc(int *w,ul m,ul v) { ul l=*w&m,mm; mm=~m; mm|=mm>>1; if (l&mm) l|=mm; return store_ivals(w,m,v+l); } gcl-2.6.14/h/sgi4d.h0000755000175000017500000000223114360276512012406 0ustar cammcamm#define SGI #include "att.h" #include "mips.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("SGI"); \ ADD_FEATURE("MIPS") /* #define mips 1 The system defines this */ #define IEEEFLOAT #undef FILECPY_HEADER #define FILECPY_HEADER \ filecpy(save, original, header.a_text); /* text relocated; data is page-aligned after the text */ #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(PAGSIZ-1)) & ~(PAGSIZ-1)) #define PAGSIZ 4096 #define TXTRELOC 4096 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE real_maxpage = MAXPAGE #define RELOC_FILE "rel_mips.c" #undef SFASL #undef NEED_GETWD #define SEEK_TO_END_OFILE \ do{HDRR symhdr; \ fp = faslfile->sm.sm_fp;\ fread(&fileheader, sizeof(fileheader), 1, fp); \ fseek(fp, fileheader.f_symptr, 0); \ fread(&symhdr, cbHDRR, 1, fp); \ fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, 0);} \ while(0); #ifdef IN_UNIXFSYS #undef ATT #define BSD #endif /* #define DBEGIN 0x600000 */ #define UNIXSAVE "save_sgi4.c" #define UNIXFASL "faslsgi4.c" #define HAVE_GETDTABLESIZE /* Begin for cmpinclude */ /* End for cmpinclude */ gcl-2.6.14/h/linux.h0000644000175000017500000001357614360276512012546 0ustar cammcamm#include "bsd.h" #ifndef __ELF__ #error Linux systems use ELF #endif #undef HAVE_AOUT /* #define HAVE_AOUT */ #define HAVE_ELF /* Seeking to the end of ELF data is a little messy... */ #include #define SEEK_TO_END_OFILE(fp)\ do { \ long offset = 0, endofelf; int j; \ ElfW(Ehdr) eheader; ElfW(Shdr) shdr; \ fseek(fp, 0, SEEK_SET); \ massert(1==fread(&eheader, sizeof(eheader), 1, fp)); \ /* in case the headers themselves come AFTER the actual sections */ \ endofelf=offset = eheader.e_shoff+ eheader.e_shentsize *eheader.e_shnum;\ fseek(fp, eheader.e_shoff, SEEK_SET); \ if ( eheader.e_shentsize != sizeof(ElfW(Shdr)) ) \ { FEerror("Bad ELF section header size",0); } \ for ( j = 0; j < eheader.e_shnum; j++ ) \ { massert(1==fread(&shdr,eheader.e_shentsize,1,fp)); \ if ( (shdr.sh_offset > offset) && (shdr.sh_type != SHT_NOBITS) ) \ { offset = shdr.sh_offset; endofelf = offset+shdr.sh_size; } \ } \ if ( fseek(fp, endofelf, SEEK_SET) ) \ FEerror("Bad ELF file",0); \ } while(0) #ifdef IN_GBC /* Based upon sun4.h */ #define MPROTECT_ACTION_FLAGS SA_RESTART #define INSTALL_MPROTECT_HANDLER \ do {static struct sigaction action; \ action.sa_handler = (void *)memprotect_handler; \ action.sa_flags = MPROTECT_ACTION_FLAGS; \ /*action.sa_restorer = 0;*/ \ sigemptyset(&action.sa_mask); \ sigaddset(&action.sa_mask,SIGINT); \ sigaddset(&action.sa_mask,SIGALRM); \ sigaction(SIGSEGV,&action,0); \ sigaction(SIGBUS,&action,0);} while (0) #endif /* #define ELF_TEXT_BASE 0x0/\* DBEGIN *\/ */ /* #undef SET_REAL_MAXPAGE */ /* #define SET_REAL_MAXPAGE do { struct rlimit data_rlimit; \ */ /* extern char etext; \ */ /* real_maxpage = MAXPAGE ;\ */ /* getrlimit(RLIMIT_DATA, &data_rlimit); \ */ /* real_maxpage = ((unsigned long)&etext/PAGESIZE \ */ /* + data_rlimit.rlim_cur/PAGESIZE - ELF_TEXT_BASE/PAGESIZE); \ */ /* if (real_maxpage > MAXPAGE) \ */ /* real_maxpage = MAXPAGE ; } while(0) */ #ifdef USE_DLOPEN #define SPECIAL_RSYM "rsym_elf.c" #define SEPARATE_SFASL_FILE "fasldlsym.c" #else #ifdef HAVE_LIBBFD #define SEPARATE_SFASL_FILE "sfaslbfd.c" #else /* #if !defined(__i386__) && !defined(__sparc__) */ /* #error Can only do non-bfd relocs for i386 and sparc */ /* #endif */ #define SPECIAL_RSYM "rsym_elf.c" #define SEPARATE_SFASL_FILE "sfaslelf.c" #endif #endif #define UNEXEC_USE_MAP_PRIVATE #define UNIXSAVE "unexelf.c" #undef HAVE_SIGVEC #define HAVE_SIGACTION #ifndef HAVE_SV_ONSTACK #define SV_ONSTACK 0 #endif /* unblock signals m and n, and set val to signal_mask(m) | signal_mask(n) if they were set */ /* #define SIG_UNBLOCK_SIGNALS(val,m,n) \ */ /* current_mask = sigblock(0); \ */ /* sigsetmask(~(sigmask(m)) & ~(sigmask(n)) & current_mask); \ */ /* result = (current_mask & sigmask(m) ? signal_mask(m) : 0) \ */ /* | (current_mask & sigmask(n) ? signal_mask(n) : 0); */ #define RUN_PROCESS #define IEEEFLOAT /* #define HAVE_XDR */ #define USE_ULONG_ /* How to check for input */ #undef LISTEN_FOR_INPUT #define LISTEN_FOR_INPUT(fp) \ do { int c = 0; \ if((((FILE *)fp)->_IO_read_ptr >= ((FILE *)fp)->_IO_read_end) \ && (ioctl(((FILE *)fp)->_fileno, FIONREAD, &c),c<=0)) \ return 0;} while (0) /* #define DATA_BEGIN((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); */ #define DATA_BEGIN (char *)(char *)N_DATADDR(header); #define PAGSIZ (NBPG) #define SEGSIZ (NBPG * CLSIZE) #define TXTRELOC 0 #define USE_DIRENT #define GETPATHNAME #define PATHNAME_CACHE 10 /* get the fileno of a FILE* */ #define FILENO(x) fileno(x) #define ULONG_DEFINED #undef LD_COMMAND #define LD_COMMAND(command,main,start,input,ldarg,output) \ sprintf(command, "ld -d -S -N -x -A %s -T %x %s %s -o %s", \ main,start,input,ldarg,output) #define SET_SESSION_ID() (setpgrp() ? -1 : 0) #include #include #define GET_FULL_PATH_SELF(a_) do { \ static char q[PATH_MAX]; \ massert(which("/proc/self/exe",q) || which(argv[0],q)); \ (a_)=q; \ } while(0) #define UC(a_) ((ucontext_t *)a_) #define SF(a_) ((siginfo_t *)a_) #if defined(__linux__) && (defined(__x86_64__) || defined(__i386__)) /* #define FPE_CODE(i_) make_fixnum((fixnum)SF(i_)->si_code) */ #ifdef __i386__ #define FPE_CODE(i_,v_) make_fixnum((long)FFN(fSfpe_code)(UC(v_)->uc_mcontext.fpregs->sw,((struct _fpstate *)UC(v_)->uc_mcontext.fpregs)->mxcsr)) #define FPE_ADDR(i_,v_) make_fixnum((UC(v_)->uc_mcontext.fpregs->tag!=-1) ? UC(v_)->uc_mcontext.fpregs->ipoff : (fixnum)SF(i_)->si_addr) #else #define FPE_CODE(i_,v_) make_fixnum((long)FFN(fSfpe_code)(UC(v_)->uc_mcontext.fpregs->swd,((struct _fpstate *)UC(v_)->uc_mcontext.fpregs)->mxcsr)) #define FPE_ADDR(i_,v_) make_fixnum(UC(v_)->uc_mcontext.fpregs->fop ? UC(v_)->uc_mcontext.fpregs->rip : (fixnum)SF(i_)->si_addr) #endif #define FPE_CTXT(v_) list(3,make_fixnum((fixnum)&UC(v_)->uc_mcontext.gregs), \ make_fixnum((fixnum)&UC(v_)->uc_mcontext.fpregs->_st), \ make_fixnum((fixnum)&((struct _fpstate *)UC(v_)->uc_mcontext.fpregs)->_xmm)) #define MC(b_) v.uc_mcontext.b_ #define REG_LIST(a_) MMcons(make_fixnum(sizeof(a_)),make_fixnum(sizeof(*a_))) #define MCF(b_) (((struct _fpstate *)MC(fpregs))->b_) #ifdef __x86_64__ #define FPE_RLST "R8 R9 R10 R11 R12 R13 R14 R15 RDI RSI RBP RBX RDX RAX RCX RSP RIP EFL CSGSFS ERR TRAPNO OLDMASK CR2" #elif defined(__i386__) #define FPE_RLST "GS FS ES DS EDI ESI EBP ESP EBX EDX ECX EAX TRAPNO ERR EIP CS EFL UESP SS" #else #error Missing reg list #endif #define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(MC(gregs))),\ REG_LIST(MCF(_st)),REG_LIST(MCF(_xmm)));}) #else #define FPE_CODE(i_,v_) make_fixnum((fixnum)SF(i_)->si_code) #define FPE_ADDR(i_,v_) make_fixnum((fixnum)SF(i_)->si_addr) #define FPE_CTXT(v_) Cnil #define FPE_INIT Cnil #endif gcl-2.6.14/h/s390-linux.h0000755000175000017500000000074514360276512013237 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define SGC #if SIZEOF_LONG == 8 #define C_GC_OFFSET 4 #define RELOC_H "elf64_s390_reloc.h" #define SPECIAL_RELOC_H "elf64_sparc_reloc_special.h" #else #define RELOC_H "elf32_s390_reloc.h" #endif gcl-2.6.14/h/elf64_mips_reloc.h0000644000175000017500000000344714360276512014537 0ustar cammcamm case R_MIPS_JALR: break; case R_MIPS_GPREL32: recurse(s+a-(ul)got); add_val(where,MASK(32),s+a-(ul)got); break; case R_MIPS_GPREL16: recurse(s+a-(ul)got); add_val(where,MASK(16),s+a-(ul)got); break; case R_MIPS_SUB: recurse(-(s+a)); break;/*???*/ case R_MIPS_64: recurse(s+a); add_val(where,~0L,s+a); break; case R_MIPS_32: recurse(s+a); add_val(where,MASK(32),s+a); break; case R_MIPS_GOT_DISP: case R_MIPS_CALL16: case R_MIPS_GOT_PAGE: case R_MIPS_GOT_HI16: case R_MIPS_GOT_LO16: case R_MIPS_CALL_HI16: case R_MIPS_CALL_LO16: recurse(s+a); gote=got+(a>>32)-1; a&=MASK(32); if (s>=ggot && s>16); break; case R_MIPS_LO16: recurse(s+a); s+=a; a=(short)*where; a+=s&MASK(16); a+=(a&0x8000)<<1; store_val(where,MASK(16),a); for (la=a&~MASK(16),lr=(Rela *)r,hr=hr ? hr : lr;--lr>=hr;) if (ELF_R_TYPE1(lr->r_info)==R_MIPS_HI16|| ELF_R_TYPE2(lr->r_info)==R_MIPS_HI16|| ELF_R_TYPE3(lr->r_info)==R_MIPS_HI16) relocate(sym1,lr,lr->r_addend,start,got,gote); hr=lr=NULL; break; gcl-2.6.14/h/include.h0000755000175000017500000000517214360276512013026 0ustar cammcamm/* Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa This file is part of GNU Common Lisp, herein referred to as GCL GCL is free software; you can redistribute it and/or modify it under the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by the Free Software Foundation; either version 2, or (at your option) any later version. GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* include.h */ /* whether to use prototypes or not */ #ifdef __STDC__ #define P__(x) x #else #define P__(x) #endif #include "options.h" #include "gclincl.h" #ifdef __GNUC__ #ifndef alloca #define alloca __builtin_alloca #endif #endif #ifdef IN_NUM_CO #ifdef HAVE_ISNORMAL #define _GNU_SOURCE #define ISNORMAL(a) isnormal(a) #else #ifdef HAVE_IEEEFP #include #define ISNORMAL(a) (fpclass(a)>=FP_NZERO) #else #define ISNORMAL(a) ((sizeof (a) == sizeof (float)) ? \ gcl_isnormal_float(a) : \ gcl_isnormal_double(a)) #endif #endif #endif #ifdef NEED_ISFINITE #ifdef HAVE_ISFINITE #define _GNU_SOURCE #define ISFINITE(a) isfinite(a) #else #ifdef HAVE_FINITE #include #define ISFINITE(a) finite(a) #else #error "No isfinite found" #endif #endif #endif #include "config.h" #ifdef IN_NUM_CO #ifdef HAVE_VALUES_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #endif #ifdef UNIX #include #define isalphanum(x) isalnum(x) #endif #if defined(GMP) || defined(NEED_MP_H) #include "../h/mp.h" #endif #include #include #include #include #include #ifdef HAVE_ALLOCA_H #include #endif #ifdef USE_READLINE #include #endif #include "../h/sfun_argd.h" #include "../h/compbas.h" #include "../h/enum.h" #include "../h/pageinfo.h" #include "../h/lu.h" #include "../h/globals.h" #include "../h/fixnum.h" #include "../h/type.h" #include "../h/object.h" #include "../h/vs.h" #include "../h/bds.h" #include "../h/frame.h" #include "../h/lex.h" #include "../h/eval.h" #include "../h/protoize.h" #include "../h/compprotos.h" #include "../h/notcomp.h" #include "../h/funlink.h" #include "../h/att_ext.h" #ifndef INICOMP #include "../h/new_decl.h" #endif #include "compat.h" #include "../h/rgbc.h" #include "../o/regexp.h" #include "../h/immnum.h" gcl-2.6.14/h/protoize.h0000644000175000017500000021616714360276512013263 0ustar cammcamm/* alloc.c:89:OF */ extern void *alloc_page (long n); /* (n) int n; */ /* alloc.c:196:OF */ extern object type_name (int t); /* (t) int t; */ /* alloc.c:213:OF */ object alloc_object (enum type t); /* (t) enum type t; */ /* alloc.c:213:OF */ void add_pages(struct typemanager *,fixnum); /* alloc.c:296:OF */ extern object make_cons (object a, object d); /* (a, d) object a; object d; */ /* alloc.c:364:OF */ extern object on_stack_cons (object x, object y); /* (x, y) object x; object y; */ /* alloc.c:376:OF */ extern object fSallocated (object typ); /* (typ) object typ; */ /* alloc.c:401:OF */ extern object fSreset_number_used (object typ); /* (typ) object typ; */ /* alloc.c:480:OF */ extern void insert_contblock (void *p, ufixnum s); /* (p, s) char *p; int s; */ /* alloc.c:480:OF */ extern void insert_maybe_sgc_contblock (char *p, int s); /* (p, s) char *p; int s; */ /* alloc.c:611:OF */ extern void set_maxpage (void); /* () */ /* alloc.c:635:OF */ extern void gcl_init_alloc (void *); /* () */ /* alloc.c:737:OF */ extern object fSstaticp (object x); /* (x) object x; */ /* alloc.c:822:OF */ extern object fSallocate_sgc (object type,fixnum min,fixnum max,fixnum free_percent); /* (type, min, max, free_percent) object type; int min; int max; int free_percent; */ /* alloc.c:846:OF */ extern object fSallocate_growth (object type,fixnum min,fixnum max,fixnum percent,fixnum percent_free); /* (type, min, max, percent, percent_free) object type; int min; int max; int percent; int percent_free; */ /* alloc.c:911:OF */ extern object fSallocated_contiguous_pages (void); /* () */ /* alloc.c:918:OF */ extern object fSmaximum_contiguous_pages (void); /* () */ /* alloc.c:958:OF */ extern object fSallocated_relocatable_pages (void); /* () */ /* alloc.c:965:OF */ extern object fSget_hole_size (void); /* () */ /* alloc.c:1000:OF */ extern void gcl_init_alloc_function (void); /* () */ /* alloc.c:1126:OF */ extern void free (void *ptr); /* (ptr) void *ptr; */ /* array.c:57:OF */ extern void Laref (void); /* () */ /* array.c:126:OF */ extern object fLsvref (object x, ufixnum i); /* (x, i) object x; unsigned int i; */ /* array.c:142:OF */ extern object fLrow_major_aref (object x,fixnum i); /* (x, i) object x; int i; */ /* array.c:190:OF */ extern object fSaset1 (object x,fixnum i, object val); /* (x, i, val) object x; int i; object val; */ /* array.c:262:OF */ extern void siLaset (void); /* () */ /* array.c:321:OF */ extern void siLsvset (void); /* () */ /* array.c:324:OF */ extern object fSsvset (object x,fixnum i, object val); /* (x, i, val) object x; int i; object val; */ /* array.c:461:OF */ extern object fSget_aelttype (object x); /* (x) object x; */ /* array.c:480:OF */ extern void siLmake_vector (void); /* () */ /* array.c:519:OF */ extern object fSmake_array1 (fixnum elt_type, object staticp, object initial_element, object displaced_to,fixnum displaced_index_offset, object dimensions); /* (elt_type, staticp, initial_element, displaced_to, displaced_index_offset, dimensions) int elt_type; object staticp; object initial_element; object displaced_to; int displaced_index_offset; object dimensions; */ /* array.c::OF */ extern object fSmake_vector1_1 (fixnum n,fixnum elt_type,object staticp); /* array.c:738:OF */ extern void adjust_displaced (object x, long diff); /* (x, diff) object x; int diff; */ /* array.c:790:OF */ extern void gset (void *p1, void *val, int n, int typ); /* (p1, val, n, typ) char *p1; char *val; int n; int typ; */ /* array.c:831:OF */ extern object fScopy_array_portion (object x, object y,object i1,object i2, object n1); /* (x, y, i1, i2, n1) object x; object y; int i1; int i2; int n1; */ /* array.c:879:OF */ extern void array_allocself (object x, int staticp, object dflt); /* (x, staticp, dflt) object x; int staticp; object dflt; */ /* array.c:920:OF */ extern void siLfill_pointer_set (void); /* () */ /* array.c:923:OF */ extern object fSfill_pointer_set (object x,fixnum i); /* (x, i) object x; int i; */ /* array.c:944:OF */ extern void Lfill_pointer (void); /* () */ /* array.c:947:OF */ extern object fLfill_pointer (object x); /* (x) object x; */ /* array.c:965:OF */ extern object fLarray_has_fill_pointer_p (object x); /* (x) object x; */ /* array.c:986:OF */ extern void Larray_element_type (void); /* () */ /* array.c:989:OF */ extern object fLarray_element_type (object x); /* (x) object x; */ /* array.c:995:OF */ extern void Ladjustable_array_p (void); /* () */ /* array.c:998:OF */ extern object fLadjustable_array_p (object x); /* (x) object x; */ /* array.c:1002:OF */ extern void siLdisplaced_array_p (void); /* () */ /* array.c:1005:OF */ extern object fSdisplaced_array_p (object x); /* (x) object x; */ /* array.c:1010:OF */ extern void Larray_rank (void); /* () */ /* array.c:1013:OF */ extern object fLarray_rank (object x); /* (x) object x; */ /* array.c:1020:OF */ extern void Larray_dimension (void); /* () */ /* array.c:1023:OF */ extern object fLarray_dimension (object x,fixnum i); /* (x, i) object x; int i; */ /* array.c:1090:OF */ extern void siLreplace_array (void); /* () */ /* array.c:1093:OF */ extern object fSreplace_array (object old, object new); /* (old, new) object old; object new; */ /* array.c:1140:OF */ extern object fSaset_by_cursor (object array, object val, object cursor); /* (array, val, cursor) object array; object val; object cursor; */ /* array.c:1160:OF */ extern void gcl_init_array_function (void); /* () */ /* assignment.c:62:OF */ extern void setq (object sym, object val); /* (sym, val) object sym; object val; */ /* assignment.c:128:OF */ extern void Lset (void); /* () */ /* assignment.c:130:OF */ extern object fLset (object symbol, object value); /* (symbol, value) object symbol; object value; */ /* assignment.c:142:OF */ extern void siLfset (void); /* () */ /* assignment.c:144:OF */ extern object fSfset (object sym, object function); /* (sym, function) object sym; object function; */ /* assignment.c:214:OF */ extern object fLmakunbound (object sym); /* (sym) object sym; */ /* assignment.c:228:OF */ extern void Lfmakunbound (void); /* () */ /* assignment.c:230:OF */ extern object fLfmakunbound (object sym); /* (sym) object sym; */ /* assignment.c:547:OF */ extern object clear_compiler_properties (object sym, object code); /* (sym, code) object sym; object code; */ /* assignment.c:563:OF */ extern object fSclear_compiler_properties (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* assignment.c:591:OF */ extern void gcl_init_assignment (void); /* () */ /* backq.c:259:OF */ extern int backq_car (object x); /* (x) object x; */ /* backq.c:381:OF */ extern void gcl_init_backq (void); /* () */ /* bds.c:31:OF */ extern void bds_unwind (bds_ptr new_bds_top); /* (new_bds_top) bds_ptr new_bds_top; */ /* big.c:53:OF */ extern object fSset_gmp_allocate_relocatable (object flag); /* (flag) object flag; */ /* gmp_big.c:96:OF */ extern void gcl_init_big1 (void); /* () */ /* gmp_big.c:108:OF */ extern object new_bignum (void); /* () */ /* gmp_big.c:161:OF */ extern object make_integer (__mpz_struct *u); /* (u) __mpz_struct *u; */ /* gmp_big.c:207:OF */ extern int big_compare (object x, object y); /* (x, y) object x; object y; */ /* gmp_big.c:214:OF */ extern object normalize_big_to_object (object x); /* (x) object x; */ /* gmp_big.c:230:OF */ extern void add_int_big (int i, object x); /* (i, x) int i; object x; */ /* gmp_big.c:244:OF */ extern void mul_int_big (int i, object x); /* (i, x) int i; object x; */ /* gmp_big.c:289:OF */ extern object normalize_big (object x); /* (x) object x; */ /* gmp_big.c:302:OF */ extern object big_minus (object x); /* (x) object x; */ /* gmp_big.c:324:OF */ extern double big_to_double (object x); /* (x) object x; */ /* gmp_big.c:454:OF */ extern object maybe_replace_big (object x); /* (x) object x; */ /* gmp_big.c:472:OF */ extern object bignum2 (unsigned int h, unsigned int l); /* (h, l) unsigned int h; unsigned int l; */ /* gmp_big.c:482:OF */ extern void integer_quotient_remainder_1 (object x, object y, object *qp, object *rp,fixnum z); /* (x, y, qp, rp) object x; object y; object *qp; object *rp; */ /* gmp_big.c:502:OF */ extern object coerce_big_to_string (object x, int printbase); /* (x, printbase) object x; int printbase; */ /* gmp_big.c:521:OF */ extern void gcl_init_big (void); /* () */ /* big.c:72:OF */ extern int big_sign (object x); /* (x) object x; */ /* big.c:78:OF */ extern void set_big_sign (object x, int sign); /* (x, sign) object x; int sign; */ /* big.c:85:OF */ extern void zero_big (object x); /* (x) object x; */ /* bind.c:74:OF */ extern void lambda_bind (object *arg_top); /* (arg_top) object *arg_top; */ /* bind.c:564:OF */ extern void bind_var (object var, object val, object spp); /* (var, val, spp) object var; object val; object spp; */ /* bind.c:610:OF */ extern object find_special (object body, struct bind_temp *start, struct bind_temp *end,object *s); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:670:OF */ extern object let_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:688:OF */ extern object letA_bind (object body, struct bind_temp *start, struct bind_temp *end); /* (body, start, end) object body; struct bind_temp *start; struct bind_temp *end; */ /* bind.c:712:OF */ extern void parse_key (object *base, bool rest, bool allow_other_keys, register int n, ... ); /* bind.c:820:OF */ extern void check_other_key (object l, int n, ...); struct key {short n,allow_other_keys; iobject *defaults; iobject keys[1]; }; /* bind.c:866:OF */ extern int parse_key_new_new (int n, object *base, struct key *keys, object first, va_list ap); /* (n, base, keys, ap) int n; object *base; struct key *keys; va_list ap; */ /* bind.c:916:OF */ extern int parse_key_rest_new (object rest, int n, object *base, struct key *keys, object first, va_list ap); /* (rest, n, base, keys, ap) object rest; int n; object *base; struct key *keys; va_list ap; */ /* bind.c:975:OF */ extern void set_key_struct (struct key *ks, object data); /* (ks, data) struct key *ks; object data; */ /* bind.c:995:OF */ extern void gcl_init_bind (void); /* () */ /* block.c:121:OF */ extern void gcl_init_block (void); /* () */ /* bsearch.c:5:OF */ extern void *bsearch (const void *key, const void *base, size_t nel, size_t keysize, int (*compar) (const void *,const void *)); /* (key, base, nel, keysize, compar) char *key; char *base; unsigned int nel; unsigned int keysize; int (*compar)(); */ #if defined (__MINGW32__) /* bzero.c:3:OF */ /* extern void bzero (char *b, size_t length); */ /* (b, length) char *b; int length; */ #endif /* catch.c:61:OF */ extern object fSerror_set (object x0); /* (x0) object x0; */ /* catch.c:166:OF */ extern void gcl_init_catch (void); /* () */ /* cfun.c:37:OF */ extern object make_cfun (void (*self)(), object name, object data, char *start, int size); /* (self, name, data, start, size) int (*self)(); object name; object data; char *start; int size; */ /* cfun.c:56:OF */ extern object make_sfun (object name, object (*self)(), int argd, object data); /* (name, self, argd, data) object name; int (*self)(); int argd; object data; */ /* cfun.c:91:OF */ extern object make_cclosure_new (void (*self)(), object name, object env, object data); /* (self, name, env, data) int (*self)(); object name; object env; object data; */ /* cfun.c:108:OF */ extern object make_cclosure (void (*self)(), object name, object env, object data, char *start, int size); /* (self, name, env, data, start, size) int (*self)(); object name; object env; object data; char *start; int size; */ /* cfun.c:124:OF */ extern object fSmc (object name, object address); /* (name, address) object name; object address; */ /* cfun.c:150:OF */ extern object fSmfsfun (object name, object address, object argd); /* (name, address, argd) object name; object address; object argd; */ /* cfun.c:174:OF */ extern object fSmfvfun (object name, object address, object argd); /* (name, address, argd) object name; object address; object argd; */ /* cfun.c:193:OF */ extern object fSmfvfun_key (object symbol, object address, object argd, object keys); /* (symbol, address, argd, keys) object symbol; object address; object argd; object keys; */ /* cfun.c:221:OF */ extern object fSmf (object name, object addr); /* (name, addr) object name; object addr; */ /* cfun.c:269:OF */ extern object fSmm (object name, object addr); /* (name, addr) object name; object addr; */ /* cfun.c:283:OF */ extern object make_function_internal (char *s, void(*f)()); /* (s, f) char *s; int (*f)(); */ /* cfun.c:283:OF */ extern object make_macro_internal (char *s, void(*f)()); /* (s, f) char *s; int (*f)(); */ /* cfun.c:299:OF */ extern object make_si_sfun_internal (char *s, object (*f)(), int argd); /* (s, f, argd) char *s; int (*f)(); int argd; */ /* cfun.c:322:OF */ extern object make_si_function_internal (char *s, void (*f) ()); /* (s, f) char *s; int (*f)(); */ /* cfun.c:341:OF */ extern object make_special_form_internal (char *s, void (*f)()); /* (s, f) char *s; int (*f)(); */ /* cfun.c:341:OF */ extern object make_si_special_form_internal (char *s, void (*f)()); /* (s, f) char *s; int (*f)(); */ /* cfun.c:352:OF */ extern object fScompiled_function_name (object fun); /* (fun) object fun; */ /* cfun.c:371:OF */ extern void turbo_closure (object fun); /* (fun) object fun; */ /* cfun.c:392:OF */ extern object fSturbo_closure (object funobj); /* (funobj) object funobj; */ /* cfun.c:403:OF */ extern void gcl_init_cfun (void); /* () */ /* cmac.c:147:OF */ extern object fScmod (object num); /* (num) object num; */ /* cmac.c:156:OF */ extern object fScplus (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* cmac.c:165:OF */ extern object fSctimes (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* cmac.c:175:OF */ extern object fScdifference (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* cmac.c:191:OF */ extern void gcl_init_cmac (void); /* () */ /* cmpaux.c:33:OF */ extern void siLspecialp (void); /* () */ /* cmpaux.c:35:OF */ extern object fSspecialp (object sym); /* (sym) object sym; */ /* cmpaux.c:73:OF */ extern object fSdebug (object sym, object val); /* (sym, val) object sym; object val; */ /* cmpaux.c:82:OF */ extern object fSsetvv (object index, object val); /* (index, val) object index; object val; */ /* cmpaux.c:95:OF */ extern void gcl_init_cmpaux (void); /* () */ /* cmpaux.c:106:OF */ /* extern int ifloor (int x, int y); */ /* (x, y) int x; int y; */ /* cmpaux.c:124:OF */ /* extern int imod (int x, int y); */ /* (x, y) int x; int y; */ /* cmpaux.c:185:OF */ extern int object_to_int (object x); /* (x) object x; */ /* cmpaux.c:185:OF */ extern fixnum object_to_fixnum (object x); /* (x) object x; */ /* cmpaux.c:263:OF */ extern char *object_to_string (object x); /* (x) object x; */ typedef int (*FUNC)(); /* cmpaux.c:294:OF */ extern void call_init (int init_address,object memory,object faslfile); /* (init_address, memory, fasl_vec, fptr) int init_address; object memory; object fasl_vec; FUNC fptr; */ /* cmpaux.c:339:OF */ extern void do_init (object *statVV); /* (statVV) object *statVV; */ /* cmpaux.c:416:OF */ extern void gcl_init_or_load1 (void (*fn) (void), const char *file); /* (fn, file) int (*fn)(); char *file; */ /* conditional.c:200:OF */ extern void gcl_init_conditional (void); /* () */ /* error.c:38:OF */ extern void terminal_interrupt (int correctable); /* (correctable) int correctable; */ /* error.c:147:OF */ extern void Lerror (void); /* () */ /* error.c:164:OF */ extern void Lcerror (void); /* () */ /* error.c:184:OF */ extern void FEerror (char *s, int num, ... ); /* (s, num, arg1, arg2, arg3, arg4) char *s; int num; object arg1; object arg2; object arg3; object arg4; */ /* error.c:203:OF */ extern void FEwrong_type_argument (object type, object value); /* (type, value) object type; object value; */ /* error.c:210:OF */ extern void FEtoo_few_arguments (object *base, object *top); /* (base, top) object *base; object *top; */ /* error.c:219:OF */ extern void FEtoo_few_argumentsF (object args); /* (args) object args; */ /* error.c:227:OF */ extern void FEtoo_many_arguments (object *base, object *top); /* (base, top) object *base; object *top; */ /* error.c:234:OF */ extern void FEtoo_many_argumentsF (object args); /* (args) object args; */ /* error.c:247:OF */ extern void FEunexpected_keyword (object key); /* (key) object key; */ /* error.c:258:OF */ extern void FEinvalid_form (char *s, object form); /* (s, form) char *s; object form; */ /* error.c:266:OF */ extern void FEunbound_variable (object sym); /* (sym) object sym; */ /* error.c:273:OF */ extern void FEinvalid_variable (char *s, object obj); /* (s, obj) char *s; object obj; */ /* error.c:280:OF */ extern void FEundefined_function (object fname); /* (fname) object fname; */ /* error.c:287:OF */ extern void FEinvalid_function (object obj); /* (obj) object obj; */ /* error.c:297:OF */ extern object CEerror (char *error_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4); /* (error_str, cont_str, num, arg1, arg2, arg3, arg4) char *error_str; char *cont_str; int num; object arg1; object arg2; object arg3; object arg4; */ /* error.c:330:OF */ extern object fSihs_top (void); /* () */ /* error.c:337:OF */ extern object fSihs_fun (object x0); /* (x0) object x0; */ /* error.c:346:OF */ extern object fSihs_vs (object x0); /* (x0) object x0; */ /* error.c:371:OF */ extern object fSfrs_top (void); /* () */ /* error.c:378:OF */ extern object fSfrs_vs (object x0); /* (x0) object x0; */ /* error.c:387:OF */ extern object fSfrs_bds (object x0); /* (x0) object x0; */ /* error.c:397:OF */ extern object fSfrs_class (object x0); /* (x0) object x0; */ /* error.c:413:OF */ extern object fSfrs_tag (object x0); /* (x0) object x0; */ /* error.c:422:OF */ extern object fSfrs_ihs (object x0); /* (x0) object x0; */ /* error.c:448:OF */ extern object fSbds_top (void); /* () */ /* error.c:455:OF */ extern object fSbds_var (object x0); /* (x0) object x0; */ /* error.c:464:OF */ extern object fSbds_val (object x0); /* (x0) object x0; */ /* error.c:487:OF */ extern object fSvs_top (void); /* () */ /* error.c:496:OF */ extern object fSvs (object x0); /* (x0) object x0; */ /* error.c:505:OF */ extern object fSsch_frs_base (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* error.c:523:OF */ extern object fSinternal_super_go (object tag, object x1, object x2); /* (tag, x1, x2) object tag; object x1; object x2; */ /* error.c:549:OF */ extern object fSuniversal_error_handler (object x0, object x1, object x2, object x3, object error_fmt_string); /* (x0, x1, x2, x3, error_fmt_string) object x0; object x1; object x2; object x3; object error_fmt_string; */ /* error.c:561:OF */ extern void check_arg_failed (int n); /* (n) int n; */ /* error.c:568:OF */ extern void too_few_arguments (void); /* () */ /* error.c:573:OF */ extern void too_many_arguments (void); /* () */ /* error.c:586:OF */ extern void ck_larg_exactly (int n, object x); /* (n, x) int n; object x; */ /* error.c:595:OF */ extern void invalid_macro_call (void); /* () */ /* error.c:618:OF */ extern object wrong_type_argument (object typ, object obj); /* (typ, obj) object typ; object obj; */ /* error.c:625:OF */ extern void illegal_declare (object form); /* (form) int form; */ /* error.c:635:OF */ extern void not_a_string_or_symbol (object x); /* (x) object x; */ /* error.c:641:OF */ extern void not_a_symbol (object obj); /* (obj) object obj; */ /* error.c:647:OF */ extern int not_a_variable (object obj); /* (obj) object obj; */ /* error.c:653:OF */ extern void illegal_index (object x, object i); /* (x, i) object x; object i; */ /* error.c:670:OF */ extern void check_stream (object strm); /* (strm) object strm; */ /* error.c:697:OF */ extern void check_arg_range (int n, int m); /* (n, m) int n; int m; */ /* error.c:727:OF */ extern void gcl_init_error (void); /* () */ /* eval.c:143:OF */ extern void funcall (object fun); /* (fun) object fun; */ /* eval.c:375:OF */ extern void lispcall (object *funp, int narg); /* (funp, narg) object *funp; int narg; */ /* eval.c:461:OF */ extern void symlispcall (object sym, object *base, int narg); /* (sym, base, narg) object sym; object *base; int narg; */ /* eval.c:549:OF */ extern object simple_lispcall (object *funp, int narg); /* (funp, narg) object *funp; int narg; */ /* eval.c:645:OF */ extern object simple_symlispcall (object sym, object *base, int narg); /* (sym, base, narg) object sym; object *base; int narg; */ /* eval.c:739:OF */ extern void super_funcall (object fun); /* (fun) object fun; */ /* eval.c:752:OF */ extern void super_funcall_no_event (object fun); /* (fun) object fun; */ /* eval.c:936:OF */ extern object Ieval (object form); /* (form) object form; */ #define Ieval1(x) Ieval(x) /*FIXME*/ /* eval.c:944:OF */ extern void eval (object form); /* (form) object form; */ /* eval.c:1189:OF */ extern void Leval (void); /* () */ /* eval.c:1191:OF */ extern object fLeval (object x0); /* (x0) object x0; */ /* eval.c:1203:OF */ extern void Levalhook (void); /* () */ /* eval.c:1269:OF */ extern void Lconstantp (void); /* () */ /* eval.c:1271:OF */ extern object fLconstantp (object x0); /* (x0) object x0; */ /* eval.c:1293:OF */ extern object ieval (object x); /* (x) object x; */ /* eval.c:1309:OF */ extern object ifuncall1 (object fun, object arg1); /* (fun, arg1) object fun; object arg1; */ /* eval.c:1328:OF */ extern object ifuncall2 (object fun, object arg1, object arg2); /* (fun, arg1, arg2) object fun; object arg1; object arg2; */ /* eval.c:1348:OF */ extern object ifuncall3 (object fun, object arg1, object arg2, object arg3); /* (fun, arg1, arg2, arg3) object fun; object arg1; object arg2; object arg3; */ typedef void (*funcvoid)(void); /* eval.c:1545:OF */ extern void gcl_init_eval (void); /* () */ /* fasdump.c:1465:OF */ extern object read_fasl_vector (object in); /* (in) object in; */ /* fat_string.c:29:OF */ extern object fSprofile (object start_address, object scale); /* (start_address, scale) object start_address; object scale; */ /* fat_string.c:46:OF */ extern object fSfunction_start (object funobj); /* (funobj) object funobj; */ /* fat_string.c:331:OF */ extern object fSdisplay_profile (object start_addr, object scal); /* (start_addr, scal) object start_addr; object scal; */ /* fat_string.c:394:OF */ extern object fSarray_adress (object array); /* (array) object array; */ /* fat_string.c:435:OF */ extern void gcl_init_fat_string (void); /* () */ /* sfasli.c::OF */ extern void gcl_init_sfasl (void); /* () */ /* format.c::OF */ extern object fLformat_1(object strm, object control,object x); /* format.c:2084:OF */ extern void Lformat (void); /* () */ /* format.c:2171:OF */ extern void gcl_init_format (void); /* () */ /* frame.c:32:OF */ extern void unwind (frame_ptr fr, object tag) NO_RETURN; /* (fr, tag) frame_ptr fr; object tag; */ /* frame.c:58:OF */ extern frame_ptr frs_sch (object frame_id); /* (frame_id) object frame_id; */ /* frame.c:69:OF */ extern frame_ptr frs_sch_catch (object frame_id); /* (frame_id) object frame_id; */ /* funlink.c:19:OF */ extern void call_or_link (object sym, void **link); /* (sym, link) object sym; void **link; */ /* funlink.c:41:OF */ extern void call_or_link_closure (object sym, void **link, void **ptr); /* (sym, link, ptr) object sym; void **link; object *ptr; */ /* funlink.c:696:OF */ extern object call_proc0 (object sym, void *link); /* (sym, link) object sym; void *link; */ /* funlink.c:784:OF */ extern int clear_stack (object *beg, object *limit); /* (beg, limit) object *beg; object *limit; */ /* funlink.c:821:OF */ extern void gcl_init_links (void); /* () */ /* gbc.c:151:OF */ extern void enter_mark_origin (object *p); /* (p) object *p; */ /* gbc.c:938:OF */ extern void GBC (enum type t); /* (t) enum type t; */ /* gbc.c:1326:OF */ extern object fLgbc (object x0); /* (x0) object x0; */ /* sgbc.c:924:OF */ extern fixnum sgc_count_type (int t); /* (t) int t; */ /* sgbc.c:938:OF */ extern int sgc_start (void); /* () */ /* sgbc.c:1068:OF */ extern int sgc_quit (void); /* () */ /* sgbc.c:1131:OF */ extern void make_writable (unsigned long beg, unsigned long i); /* (beg, i) int beg; int i; */ #ifndef __MINGW32__ /* #include */ #endif /* sgbc.c:1246:OF */ extern int memory_protect (int on); /* (on) int on; */ /* sgbc.c:1306:OF */ extern void perm_writable (char *p, long n); /* (p, n) char *p; int n; */ /* sgbc.c:1321:OF */ extern void system_error (void); /* () */ /* gbc.c:1357:OF */ extern void gcl_init_GBC (void); /* () */ /* gnumalloc.c:286:OF */ extern void malloc_init (char *start, void (*warnfun) (/* ??? */)); /* (start, warnfun) char *start; void (*warnfun)(); */ /* gnumalloc.c:301:OF */ extern int malloc_usable_size (char *mem); /* (mem) char *mem; */ /* gnumalloc.c:461:OF */ /* extern void *malloc (size_t n); */ /* (n) unsigned int n; */ /* gnumalloc.c:529:OF */ /* extern int free (char *mem); */ /* (mem) char *mem; */ /* gnumalloc.c:577:OF */ /* extern char *realloc (char *mem, register unsigned int n); */ /* (mem, n) char *mem; register unsigned int n; */ /* gnumalloc.c:639:OF */ /* extern char *memalign (unsigned int alignment, unsigned int size); */ /* (alignment, size) unsigned int alignment; unsigned int size; */ /* gnumalloc.c:737:OF */ extern int get_lim_data (void); /* () */ /* grab_defs.c:35:OF */ extern int read_some (char *buf, int n, int start_ch, int copy); /* (buf, n, start_ch, copy) char *buf; int n; int start_ch; int copy; */ /* grab_defs.c:71:OF */ /* extern int main (void); */ /* () */ /* iteration.c:457:OF */ extern void gcl_init_iteration (void); /* () */ /* let.c:29:OF */ extern void let_var_list (object var_list); /* (var_list) object var_list; */ /* let.c:321:OF */ extern void gcl_init_let (void); /* () */ /* lex.c:34:OF */ extern object assoc_eq (object key, object alist); /* (key, alist) object key; object alist; */ /* lex.c:47:OF */ extern void lex_fun_bind (object name, object fun); /* (name, fun) object name; object fun; */ /* lex.c:59:OF */ extern void lex_macro_bind (object name, object exp_fun); /* (name, exp_fun) object name; object exp_fun; */ /* lex.c:70:OF */ extern void lex_tag_bind (object tag, object id); /* (tag, id) object tag; object id; */ /* lex.c:82:OF */ extern void lex_block_bind (object name, object id); /* (name, id) object name; object id; */ /* lex.c:95:OF */ extern object lex_tag_sch (object tag); /* (tag) object tag; */ /* lex.c:110:OF */ extern object lex_block_sch (object name); /* (name) object name; */ /* lex.c:125:OF */ extern void gcl_init_lex (void); /* () */ /* littleXwin.c:32:OF */ /* extern Window open_window (void); */ /* () */ /* littleXwin.c:102:OF */ /* extern int close_window (Window the_window); */ /* (the_window) Window the_window; */ /* littleXwin.c:110:OF */ /* extern int draw_line (Window the_window, int x1, int y1, int x2, int y2); */ /* (the_window, x1, y1, x2, y2) Window the_window; int x1; int y1; int x2; int y2; */ /* littleXwin.c:119:OF */ /* extern int draw_arc (Window the_window, int x, int y, int width, int height, int angle1, int angle2); *//* (the_window, x, y, width, height, angle1, angle2) Window the_window; int x; int y; int width; int height; int angle1; int angle2; */ /* littleXwin.c:129:OF */ /* extern int fill_arc (Window the_window, int x, int y, int width, int height, int angle1, int angle2); */ /* (the_window, x, y, width, height, angle1, angle2) Window the_window; int x; int y; int width; int height; int angle1; int angle2; */ /* littleXwin.c:139:OF */ /* extern int clear_arc (Window the_window, int x, int y, int width, int height, int angle1, int angle2); *//* (the_window, x, y, width, height, angle1, angle2) Window the_window; int x; int y; int width; int height; int angle1; int angle2; */ /* littleXwin.c:149:OF */ /* extern int set_arc_mode (int pie_or_chord); */ /* (pie_or_chord) int pie_or_chord; */ /* littleXwin.c:162:OF */ /* extern int erase_line (Window the_window, int x1, int y1, int x2, int y2); *//* (the_window, x1, y1, x2, y2) Window the_window; int x1; int y1; int x2; int y2; */ /* littleXwin.c:171:OF */ /* extern int draw_text (Window the_window, char *string, int x, int y); */ /* (the_window, string, x, y) Window the_window; char *string; int x; int y; */ /* littleXwin.c:182:OF */ /* extern int erase_text (Window the_window, char *string, int x, int y); */ /* (the_window, string, x, y) Window the_window; char *string; int x; int y; */ /* littleXwin.c:193:OF */ /* extern int clear_window (Window the_window); */ /* (the_window) Window the_window; */ /* littleXwin.c:201:OF */ /* extern int resize_window (Window the_window, int width, int height); */ /* (the_window, width, height) Window the_window; int width; int height; */ /* littleXwin.c:210:OF */ /* extern int raise_window (Window the_window); */ /* (the_window) Window the_window; */ /* littleXwin.c:218:OF */ /* extern int use_font (char *font_name); */ /* (font_name) char *font_name; */ /* littleXwin.c:233:OF */ /* extern int set_background (Window the_window, char *color_string); */ /* (the_window, color_string) Window the_window; char *color_string; */ /* littleXwin.c:251:OF */ /* extern int set_foreground (char *color_string); */ /* (color_string) char *color_string; */ /* macros.c:139:OF */ extern object Imacro_expand1 (object exp_fun, object form); /* (exp_fun, form) object exp_fun; object form; */ /* macros.c:173:OF */ extern void Lmacroexpand (void); /* () */ /* macros.c:224:OF */ extern void Lmacroexpand_1 (void); /* () */ /* macros.c:265:OF */ extern object macro_expand (object form); /* (form) object form; */ /* macros.c:344:OF */ extern void gcl_init_macros (void); /* () */ /* main.c:111:OF */ extern int main (int argc, char **argv, char **envp); /* (argc, argv, envp) int argc; char **argv; char **envp; */ /* main.c:346:OF */ extern void install_segmentation_catcher (void); /* () */ /* main.c:359:OF */ extern void error (char *s); /* (s) char *s; */ /* main.c:519:OF */ extern object vs_overflow (void); /* () */ /* main.c:528:OF */ extern void bds_overflow (void); /* () */ /* main.c:537:OF */ extern void frs_overflow (void); /* () */ /* main.c:546:OF */ extern void ihs_overflow (void); /* () */ /* main.c:556:OF */ extern void segmentation_catcher (int); /* () */ /* main.c:587:OF */ extern void Lby (void); /* () */ /* main.c:607:OF */ extern void Lquit(void); /* () */ /* main.c:612:OF */ extern void Lexit(void); /* () */ /* main.c:619:OF */ extern int c_trace (void); /* () */ /* main.c:695:OF */ extern void siLreset_stack_limits (void); /* (arg) int arg; */ /* main.c:797:OF */ extern void Lidentity(void); /* () */ /* main.c:799:OF */ extern object fLidentity (object x0); /* (x0) object x0; */ /* main.c:805:OF */ extern void Llisp_implementation_version(void); /* () */ /* main.c:807:OF */ extern object fLlisp_implementation_version (void); /* () */ /* makefun.c:10:OF */ extern object MakeAfun (object (*addr)(object,object), unsigned int argd, object data); /* (addr, argd, data) int (*addr)(); unsigned int argd; object data; */ /* makefun.c:113:OF */ extern object fSset_key_struct (object key_struct_ind); /* (key_struct_ind) object key_struct_ind; */ /* /\* makefun.c:122:OF *\/ extern void SI_makefun (char *strg, object (*fn) (/\* ??? *\/), unsigned int argd); /\* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; *\/ */ /* /\* makefun.c:131:OF *\/ extern void LISP_makefun (char *strg, object (*fn) (/\* ??? *\/), unsigned int argd); /\* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; *\/ */ /* makefun.c:122:OF */ extern void SI_makefun (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:131:OF */ extern void LISP_makefun (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:122:OF */ extern void SI_makefunm (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:131:OF */ extern void LISP_makefunm (char *,void *,unsigned int); /* (strg, fn, argd) char *strg; object (*fn)(); unsigned int argd; */ /* makefun.c:167:OF */ extern object fSinvoke (object x); /* (x) object x; */ /* mapfun.c:324:OF */ extern void gcl_init_mapfun (void); /* () */ /* multival.c:32:OF */ extern void Lvalues (void); /* () */ /* multival.c:37:OF */ extern void Lvalues_list (void); /* () */ /* multival.c:134:OF */ extern void gcl_init_multival (void); /* () */ /* nfunlink.c:190:OF */ extern object IapplyVector (object fun, int nargs, object *base); /* (fun, nargs, base) object fun; int nargs; object *base; */ /* nfunlink.c:269:OF */ extern void Iinvoke_c_function_from_value_stack (object (*f)(), int fargd); /* (f, fargd) object (*f)(); int fargd; */ /* nsocket.c:190:OF */ extern int CreateSocket (int port, char *host, int server, char *myaddr, int myport, int async); /* (port, host, server, myaddr, myport, async) int port; char *host; int server; char *myaddr; int myport; int async; */ /* nsocket.c:329:OF */ extern object fSgetpeername (object sock); /* (sock) object sock; */ /* nsocket.c:353:OF */ extern object fSgetsockname (object sock); /* (sock) object sock; */ /* nsocket.c:385:OF */ extern object fSset_blocking (object sock, object setBlocking); /* (sock, setBlocking) object sock; object setBlocking; */ /* nsocket.c:484:OF */ extern int getOneChar (FILE *fp); /* (fp) FILE *fp; */ /* nsocket.c:539:OF */ extern void ungetCharGclSocket (int c, object strm); /* (c, strm) int c; object strm; */ #ifndef __MINGW32__ /* nsocket.c:592:OF */ extern void tcpCloseSocket (int fd); /* (fd) int fd; */ /* nsocket.c:575:OF */ extern int TcpOutputProc (int fd, char *buf, int toWrite, int *errorCodePtr); /* (fd, buf, toWrite, errorCodePtr) int fd; char *buf; int toWrite; int *errorCodePtr; */ #endif /* nsocket.c:619:OF */ extern int getCharGclSocket (object strm, object block); /* (strm, block) object strm; object block; */ /* num_arith.c:31:OF */ extern object fixnum_add (fixnum i, fixnum j); /* (i, j) int i; int j; */ /* num_arith.c:48:OF */ extern object fixnum_sub (fixnum i, fixnum j); /* (i, j) int i; int j; */ /* num_arith.c:100:OF */ extern object number_plus (object x, object y); /* (x, y) object x; object y; */ /* num_arith.c:246:OF */ extern object one_plus (object x); /* (x) object x; */ /* num_arith.c:292:OF */ extern object number_minus (object x, object y); /* (x, y) object x; object y; */ /* num_arith.c:438:OF */ extern object one_minus (object x); /* (x) object x; */ /* num_arith.c:478:OF */ extern object number_negate (object x); /* (x) object x; */ /* num_arith.c:520:OF */ extern object number_times (object x, object y); /* (x, y) object x; object y; */ /* num_arith.c:670:OF */ extern object number_divide (object x, object y); /* (x, y) object x; object y; */ /* num_arith.c:818:OF */ extern object integer_divide1 (object x, object y,fixnum z); /* (x, y) object x; object y; */ /* num_arith.c:818:OF */ extern object integer_divide2 (object x, object y,fixnum z,object *r); /* (x, y) object x; object y; */ /* num_arith.c:828:OF */ extern object get_gcd (object x, object y); /* (x, y) object x; object y; */ /* num_arith.c:873:OF */ extern void Lplus (void); /* () */ /* num_arith.c:889:OF */ extern void Lminus (void); /* () */ /* num_arith.c:907:OF */ extern void Ltimes (void); /* () */ /* num_arith.c:923:OF */ extern void Ldivide (void); /* () */ /* num_arith.c:1029:OF */ extern void gcl_init_num_arith (void); /* () */ /* num_co.c:292:OF */ extern object double_to_integer (double d); /* (d) double d; */ /* num_co.c:372:OF */ extern void Lfloat (void); /* () */ /* num_co.c:424:OF */ extern void Lnumerator (void); /* () */ /* num_co.c:432:OF */ extern void Ldenominator (void); /* () */ /* num_co.c:442:OF */ extern void Lfloor (void); /* () */ /* num_co.c:563:OF */ extern void Lceiling (void); /* () */ /* num_co.c:684:OF */ extern void Ltruncate (void); /* () */ /* num_co.c:766:OF */ extern void Lround (void); /* () */ /* num_co.c:896:OF */ extern void Lmod (void); /* () */ /* num_co.c:987:OF */ extern void Lfloat_radix (void); /* () */ /* num_co.c:1089:OF */ extern void Linteger_decode_float (void); /* () */ /* num_co.c:1114:OF */ extern void Lcomplex (void); /* () */ /* num_co.c:1136:OF */ extern void Lrealpart (void); /* () */ /* num_co.c:1147:OF */ extern void Limagpart (void); /* () */ /* num_co.c:1185:OF */ extern void gcl_init_num_co (void); /* () */ /* num_comp.c:40:OF */ extern int number_compare (object x, object y); /* (x, y) object x; object y; */ /* num_comp.c:269:OF */ extern void Lmonotonically_increasing (void); /* () */ /* num_comp.c:271:OF */ extern void Lmonotonically_nondecreasing (void); /* () */ /* num_comp.c:272:OF */ extern void Lmonotonically_nonincreasing (void); /* () */ /* num_comp.c:292:OF */ extern void Lmin (void); /* () */ /* num_comp.c:309:OF */ extern void gcl_init_num_comp (void); /* () */ /* num_log.c:224:OF */ extern object integer_fix_shift (object x, fixnum w); /* (x, w) object x; int w; */ /* num_log.c:258:OF */ extern void Llogior (void); /* () */ /* num_log.c:279:OF */ extern void Llogxor (void); /* () */ /* num_log.c:299:OF */ extern void Llogand (void); /* () */ /* num_log.c:339:OF */ extern void Lboole (void); /* () */ /* num_log.c:380:OF */ extern void Llogbitp (void); /* () */ /* num_log.c:420:OF */ extern void Lash (void); /* () */ /* num_log.c:482:OF */ extern void Linteger_length (void); /* () */ /* num_log.c:549:OF */ extern void gcl_init_num_log (void); /* () */ /* num_log.c:585:OF */ extern void siLbit_array_op (void); /* () */ /* num_pred.c:31:OF */ extern int number_zerop (object x); /* (x) object x; */ /* num_pred.c:67:OF */ extern int number_plusp (object x); /* (x) object x; */ /* num_pred.c:107:OF */ extern int number_minusp (object x); /* (x) object x; */ /* num_pred.c:147:OF */ extern int number_oddp (object x); /* (x) object x; */ /* num_pred.c:161:OF */ extern int number_evenp (object x); /* (x) object x; */ /* num_pred.c:240:OF */ extern void gcl_init_num_pred (void); /* () */ /* num_rand.c:111:OF */ extern void Lrandom (void); /* () */ /* num_rand.c:151:OF */ extern void gcl_init_num_rand (void); /* () */ /* num_sfun.c:91:OF */ extern object number_expt (object x, object y); /* (x, y) object x; object y; */ /* num_sfun.c:453:OF */ extern void Lexp (void); /* () */ /* num_sfun.c:469:OF */ extern void Llog (void); /* () */ /* num_sfun.c:488:OF */ extern void Lsqrt (void); /* () */ /* num_sfun.c:495:OF */ extern void Lsin (void); /* () */ /* num_sfun.c:502:OF */ extern void Lcos (void); /* () */ /* num_sfun.c:516:OF */ extern void Latan (void); /* () */ /* num_sfun.c:535:OF */ extern void gcl_init_num_sfun (void); /* () */ /* number.c:35:OF */ extern long int fixint (object x); /* (x) object x; */ /* number.c:44:OF */ extern int fixnnint (object x); /* (x) object x; */ /* number.c:59:OF */ extern object fSallocate_bigger_fixnum_range (fixnum min,fixnum max); /* (min, max) int min; int max; */ /* number.c:81:OF */ extern object make_fixnum1 (long i); /* (i) int i; */ /* number.c:102:OF */ extern object make_ratio (object num, object den); /* (num, den) object num; object den; */ /* number.c:144:OF */ extern object make_shortfloat (double f); /* (f) double f; */ /* number.c:157:OF */ extern object make_longfloat (longfloat f); /* (f) longfloat f; */ /* number.c:170:OF */ extern object make_complex (object r, object i); /* (r, i) object r; object i; */ /* number.c:229:OF */ extern double number_to_double (object x); /* (x) object x; */ /* number.c:254:OF */ extern void gcl_init_number (void); /* () */ /* peculiar.c:14:OF */ /* extern int main (void); */ /* () */ /* predicate.c:35:OF */ extern object fLnot (object x0); /* (x0) object x0; */ /* predicate.c:46:OF */ extern void Lsymbolp (void); /* () */ /* predicate.c:48:OF */ extern object fLsymbolp (object x0); /* (x0) object x0; */ /* predicate.c:61:OF */ extern object fLatom (object x0); /* (x0) object x0; */ /* predicate.c:74:OF */ extern object fLconsp (object x0); /* (x0) object x0; */ /* predicate.c:87:OF */ extern object fLlistp (object x0); /* (x0) object x0; */ /* predicate.c:100:OF */ extern object fLnumberp (object x0); /* (x0) object x0; */ /* predicate.c:117:OF */ extern object fLintegerp (object x0); /* (x0) object x0; */ /* predicate.c:132:OF */ extern object fLrationalp (object x0); /* (x0) object x0; */ /* predicate.c:148:OF */ extern object fLrealp (object x0); /* (x0) object x0; */ /* predicate.c:164:OF */ extern object fLfloatp (object x0); /* (x0) object x0; */ /* predicate.c:176:OF */ extern void Lcomplexp (void); /* () */ /* predicate.c:178:OF */ extern object fLcomplexp (object x0); /* (x0) object x0; */ /* predicate.c:190:OF */ extern object fLcharacterp (object x0); /* (x0) object x0; */ /* predicate.c:202:OF */ extern object fLstringp (object x0); /* (x0) object x0; */ /* predicate.c:214:OF */ extern object fLbit_vector_p (object x0); /* (x0) object x0; */ /* predicate.c:226:OF */ extern object fLvectorp (object x0); /* (x0) object x0; */ /* predicate.c:238:OF */ extern void Lsimple_string_p (void); /* () */ /* predicate.c:240:OF */ extern object fLsimple_string_p (object x0); /* (x0) object x0; */ /* predicate.c:253:OF */ extern void Lsimple_bit_vector_p (void); /* () */ /* predicate.c:255:OF */ extern object fLsimple_bit_vector_p (object x0); /* (x0) object x0; */ /* predicate.c:268:OF */ extern void Lsimple_vector_p (void); /* () */ /* predicate.c:270:OF */ extern object fLsimple_vector_p (object x0); /* (x0) object x0; */ /* predicate.c:288:OF */ extern object fLarrayp (object x0); /* (x0) object x0; */ /* predicate.c:301:OF */ extern void Lpackagep (void); /* () */ /* predicate.c:303:OF */ extern object fLpackagep (object x0); /* (x0) object x0; */ /* predicate.c:313:OF */ extern void Lfunctionp (void); /* () */ /* predicate.c:315:OF */ extern object fLfunctionp (object x0); /* (x0) object x0; */ /* predicate.c:344:OF */ extern void Lcompiled_function_p (void); /* () */ /* predicate.c:346:OF */ extern object fLcompiled_function_p (object x0); /* (x0) object x0; */ /* predicate.c:367:OF */ extern object fLcommonp (object x0); /* (x0) object x0; */ /* predicate.c:379:OF */ extern object fLeq (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* predicate.c:393:OF */ extern bool eql1 (object x, object y); /* (x, y) object x; object y; */ /* predicate.c:393:OF */ extern bool oeql (object x, object y); /* (x, y) object x; object y; */ /* predicate.c:455:OF */ extern object fLeql (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* predicate.c:469:OF */ extern bool equal1 (register object x, register object y); /* (x, y) register object x; register object y; */ /* predicate.c:469:OF */ extern bool oequal (register object x, register object y); /* (x, y) register object x; register object y; */ /* predicate.c:543:OF */ extern object fLequal (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* predicate.c:557:OF */ extern bool equalp1 (object x, object y); /* (x, y) object x; object y; */ /* predicate.c:557:OF */ extern bool oequalp (object x, object y); /* (x, y) object x; object y; */ /* predicate.c:681:OF */ extern object fLequalp (object x0, object x1); /* (x0, x1) object x0; object x1; */ /* predicate.c:750:OF */ extern bool contains_sharp_comma (object x); /* (x) object x; */ /* predicate.c:797:OF */ extern object fScontains_sharp_comma (object x0); /* (x0) object x0; */ /* predicate.c:810:OF */ extern object fSspicep (object x0); /* (x0) object x0; */ /* predicate.c:822:OF */ extern object fSfixnump (object x0); /* (x0) object x0; */ /* predicate.c:833:OF */ extern void gcl_init_predicate_function (void); /* () */ /* prog.c:48:OF */ extern void Ftagbody (object body); /* (body) object body; */ /* prog.c:246:OF */ extern void Fprogn (object body); /* (body) object body; */ /* prog.c:303:OF */ extern void gcl_init_prog (void); /* () */ /* reference.c:32:OF */ extern void Lfboundp (void); /* () */ /* reference.c:49:OF */ extern object symbol_function (object sym); /* (sym) object sym; */ /* reference.c:69:OF */ extern void Lsymbol_function (void); /* () */ /* reference.c:143:OF */ extern void Lsymbol_value (void); /* () */ /* reference.c:156:OF */ extern void Lboundp (void); /* () */ /* reference.c:169:OF */ extern void Lmacro_function (void); /* () */ /* reference.c:180:OF */ extern void Lspecial_form_p (void); /* () */ /* reference.c:191:OF */ extern void gcl_init_reference (void); /* () */ /* #include "regexp.h" */ /* regexp.c:1588:OF */ extern void regerror (char *s); /* (s) char *s; */ /* regexpr.c:48:OF */ extern object fSmatch_beginning (fixnum i); /* (i) int i; */ /* regexpr.c:57:OF */ extern object fSmatch_end (fixnum i); /* (i) int i; */ /* save.c:17:OF */ extern void siLsave (void); /* () */ #include /* sbrk.c:9:OF */ /* extern void * sbrk (int n); */ /* (n) int n; */ /* strcspn.c:3:OF */ /* extern size_t strcspn (const char *s1, const char *s2); */ /* (s1, s2) char *s1; char *s2; */ /* structure.c:59:OF */ extern object structure_ref (object x, object name, fixnum i); /* (x, name, i) object x; object name; int i; */ /* structure.c:107:OF */ extern object structure_set (object x, object name, fixnum i, object v); /* (x, name, i, v) object x; object name; int i; object v; */ /* structure.c:164:OF */ extern object structure_to_list (object x); /* (x) object x; */ /* structure.c:188:OF */ extern void siLmake_structure (void); /* () */ /* structure.c:281:OF */ extern void siLstructure_set (void); /* () */ /* structure.c:326:OF */ extern void siLlist_nth (void); /* () */ /* structure.c:439:OF */ extern void gcl_init_structure_function (void); /* () */ /* toplevel.c:211:OF */ extern void gcl_init_toplevel (void); /* () */ /* typespec.c:38:OF */ extern void check_type_integer (object *p); /* (p) object *p; */ /* typespec.c:47:OF */ extern void check_type_non_negative_integer (object *p); /* (p) object *p; */ /* typespec.c:65:OF */ extern void check_type_rational (object *p); /* (p) object *p; */ /* typespec.c:75:OF */ extern void check_type_float (object *p); /* (p) object *p; */ /* typespec.c:94:OF */ extern void check_type_or_rational_float (object *p); /* (p) object *p; */ /* typespec.c:104:OF */ extern void check_type_number (object *p); /* (p) object *p; */ /* typespec.c:123:OF */ extern void check_type_character (object *p); /* (p) object *p; */ /* typespec.c:139:OF */ extern void check_type_symbol (object *p); /* (p) object *p; */ /* typespec.c:146:OF */ extern void check_type_or_symbol_string (object *p); /* (p) object *p; */ /* typespec.c:153:OF */ extern void check_type_or_string_symbol (object *p); /* (p) object *p; */ /* typespec.c:170:OF */ extern void check_type_package (object *p); /* (p) object *p; */ /* typespec.c:177:OF */ extern void check_type_string (object *p); /* (p) object *p; */ /* typespec.c:191:OF */ extern void check_type_cons (object *p); /* (p) object *p; */ /* typespec.c:198:OF */ extern void check_type_stream (object *p); /* (p) object *p; */ /* typespec.c:205:OF */ extern void check_type_readtable (object *p); /* (p) object *p; */ /* typespec.c:213:OF */ extern void check_type_or_Pathname_string_symbol (object *p); /* (p) object *p; */ /* typespec.c:225:OF */ extern void check_type_or_pathname_string_symbol_stream (object *p); /* (p) object *p; */ /* typespec.c:236:OF */ extern void check_type_random_state (object *p); /* (p) object *p; */ /* typespec.c:243:OF */ extern void check_type_hash_table (object *p); /* (p) object *p; */ /* typespec.c:250:OF */ extern void check_type_array (object *p); /* (p) object *p; */ /* typespec.c:284:OF */ extern void check_type (object x, int t); /* (x, t) object x; int t; */ /* typespec.c:294:OF */ extern void Ltype_of (void); /* () */ /* typespec.c:493:OF */ extern void gcl_init_typespec (void); /* () */ /* typespec.c:497:OF */ extern void gcl_init_typespec_function (void); /* () */ /* unexec-19.29.c:1016:OF */ extern int write_segment (int new, register char *ptr, register char *end); /* (new, ptr, end) int new; register char *ptr; register char *end; */ /* unexec.c:1016:OF */ extern int write_segment (int new, register char *ptr, register char *end); /* (new, ptr, end) int new; register char *ptr; register char *end; */ /* unexlin.c:808:OF */ extern int write_segment (int new, register char *ptr, register char *end); /* (new, ptr, end) int new; register char *ptr; register char *end; */ /* unixfasl.c:409:OF */ extern void gcl_init_unixfasl (void); /* () */ /* unixfsys.c:145:OF */ extern char *getwd (char *buffer); /* (buffer) char *buffer; */ /* unixfsys.c:209:OF */ extern void coerce_to_filename1 (object pathname, char *p,unsigned sz); /* (pathname, p) object pathname; char *p; */ /* unixfsys.c:329:OF */ extern bool file_exists (object file); /* (file) object file; */ /* unixfsys.c:359:OF */ extern FILE *backup_fopen (char *filename, char *option); /* (filename, option) char *filename; char *option; */ /* unixfsys.c:359:OF */ extern FILE *fopen_not_dir (char *filename, char *option); /* (filename, option) char *filename; char *option; */ /* unixfsys.c:372:OF */ extern int file_len (FILE *fp); /* (fp) FILE *fp; */ /* unixfsys.c:382:OF */ extern object truename (object); /* () */ /* unixfsys.c:382:OF */ extern void Ltruename (void); /* () */ /* unixfsys.c:418:OF */ extern object fSsetenv (object variable, object value); /* (variable, value) object variable; object value; */ /* unixfsys.c:442:OF */ extern object fLdelete_file (object path); /* (path) object path; */ /* unixfsys.c:456:OF */ extern void Lprobe_file (void); /* () */ /* unixfsys.c:533:OF */ extern void Ldirectory (void); /* () */ /* unixfsys.c:777:OF */ extern void gcl_init_unixfsys (void); /* () */ /* unixsave.c:173:OF */ extern void gcl_init_unixsave (void); /* () */ /* unixsys.c:83:OF */ extern object fSgetpid (void); /* () */ /* unixsys.c:87:OF */ extern void gcl_init_unixsys (void); /* () */ /* unixtime.c:67:OF */ extern int runtime (void); /* () */ /* unixtime.c:82:OF */ extern object unix_time_to_universal_time (int i); /* (i) int i; */ /* unixtime.c:99:OF */ extern object fLget_universal_time (void); /* () */ /* unixtime.c:144:OF */ extern object fLget_internal_real_time (void); /* () */ /* unixtime.c:173:OF */ extern void gcl_init_unixtime (void); /* () */ /* user_init.c:2:OF */ extern object user_init (void); /* () */ /* user_init.c:2:OF */ extern int user_match (const char *,int n); /* () */ /* usig.c:49:OF */ extern void gcl_signal (int signo, void (*handler) (/* ??? */)); /* (signo, handler) int signo; void (*handler)(); */ /* usig.c:92:OF */ extern int unblock_signals (int n, int m); /* (n, m) int n; int m; */ /* usig.c:119:OF */ extern void unblock_sigusr_sigio (void); /* () */ /* usig.c:182:OF */ extern void install_default_signals (void); /* () */ /* usig2.c:142:OF */ extern void gcl_init_safety (void); /* () */ /* usig2.c:158:OF */ extern object sSsignal_safety_required (fixnum signo,fixnum safety); /* (signo, safety) int signo; int safety; */ #ifdef __MINGW32__ /* usig2.c:167:OF */ extern void main_signal_handler (int signo); /* (signo) int signo */ #else /* usig2.c:167:OF */ extern void main_signal_handler (int signo, int a, int b); /* (signo, a, b) int signo; int a; int b; */ #endif /* usig2.c:375:OF */ extern void raise_pending_signals (int cond); /* (cond) int cond; */ /* usig2.c:407:OF */ extern object fSallow_signal (fixnum n); /* (n) int n; */ /* utils.c:12:OF */ extern object IisSymbol (object f); /* (f) object f; */ /* utils.c:20:OF */ extern object IisFboundp (object f); /* (f) object f; */ /* utils.c:30:OF */ extern object IisArray (object f); /* (f) object f; */ /* utils.c:44:OF */ extern object Iis_fixnum (object f); /* (f) object f; */ /* utils.c:61:OF */ extern object Iapply_ap_new (object (*f) (/* ??? */), object first, va_list ap); /* (f, ap) object (*f)(); va_list ap; */ /* utils.c:178:OF */ extern object Icheck_one_type (object x, enum type t); /* (x, t) object x; enum type t; */ /* utils.c:189:OF */ extern object fSincorrect_type (object val, object type); /* (val, type) object val; object type; */ /* utils.c:202:OF */ extern object Ivs_values (void); /* () */ /* utils.c:227:OF */ extern char *lisp_copy_to_null_terminated (object string, char *buf, int n); /* (string, buf, n) object string; char *buf; int n; */ /* readline.d */ extern int readline_on; void gcl_init_readline(void); void gcl_init_readline_function(void); /* sys_gcl.c */ void gcl_init_init(void); /* misc */ void gcl_init_symbol(void); void gcl_init_package(void); void gcl_init_character(void); void gcl_init_read(void); void gcl_init_pathname(void); void gcl_init_print(void); void gcl_init_character_function(void); void gcl_init_file_function(void); void gcl_init_list_function(void); void gcl_init_package_function(void); void gcl_init_pathname_function(void); void gcl_init_print_function(void); void gcl_init_read_function(void); void gcl_init_sequence_function(void); void gcl_init_string_function(void); void gcl_init_symbol_function(void); void gcl_init_socket_function(void); void gcl_init_hash(void); void import(object,object); void export(object,object); void NewInit(void); void gcl_init_system(object); void set_up_string_register(char *); bool endp1(object); void stack_cons(void); bool char_equal(object,object); bool string_equal(object,object); bool string_eq(object,object); bool remf(object *,object); bool keywordp(object); int pack_hash(object); void load(const char *); bool member_eq(object,object); void delete_eq(object,object *); int length(object); int rl_getc_em(FILE *); void setupPRINTdefault(object); void write_str(char *); void write_object(object,int); void cleanupPRINT(void); int fasload(object); int readc_stream(object); void unreadc_stream(int,object); void end_of_stream(object); bool stream_at_end(object); int digitp(int,int); bool char_eq(object,object); bool listen_stream(object); void get_string_start_end(object,object,object,int *,int *); int file_column(object); int writec_stream(int,object); int digit_weight(int,int); void flush_stream(object); void writestr_stream(char *,object); void write_string(object,object); void edit_double(int, double, int *, char *, int *,int); void sethash(object,object,object); int file_position(object); int file_position_set(object, int); void princ_str(char *s, object); void close_stream(object); void build_symbol_table(void); void gcl_init_file(void); object aset1(object,fixnum,object); void dfprintf(FILE *,char *,...); void Lmake_list(void); void Llast(void); void Lgensym(void); void Lldiff(void); void Lintern(void); void Lgensym(void); void Lldiff(void); void Lgensym(void); void Lintern(void); void Lintern(void); void Lreconc(void); void Lmember(void); void Ladjoin(void); void Llist(void); void Lappend(void); void Lread(void); void Lread_char(void); void Lchar_eq(void); void Lwrite_char(void); void Lforce_output(void); void Lchar_neq(void); void Llist(void); void Lwrite(void); void Lfresh_line(void); void Lsymbol_package(void); void Lfind_package(void); void Lfind_symbol(void); void Lpackage_name(void); void Lsymbol_plist(void); void Lpackage_nicknames(void); void Lpackage_use_list(void); void Lpackage_used_by_list(void); void Lstandard_char_p(void); void Lchar_code(void); void Lchar_bits(void); void Lchar_font(void); void Lread_line(void); void siLpackage_internal(void); void siLpackage_external(void); void Llist_all_packages(void); void Lgensym(void); void Lread(void); void Lwrite(void); void Lstring_equal(void); void Lclose(void); void Lnamestring(void); void Lmake_echo_stream(void); void Lmake_broadcast_stream(void); void Lmake_two_way_stream(void); void Lbutlast(void); void Ladjoin(void); void Lstring_downcase(void); void Lmember(void); void Lgensym(void); void Llist_all_packages(void); void Lfind_symbol(void); void Lstring_equal(void); void Lfind_package(void); void siLpackage_internal(void); void siLpackage_external(void); void Lpackage_use_list(void); void Lreconc(void); void Lstandard_char_p(void); void Lcharacter(void); void Llength(void); void Lreconc(void); void Llength(void); void Lgensym(void); void Llist_length(void); void Lgensym(void); void Lbutlast(void); void Lnconc(void); void Lfind_package(void); void Lpackage_name(void); void Llist(void); void Lfresh_line(void); void Lread_char(void); void Lunread_char(void); void Lread_line(void); void Lread(void); void Lforce_output(void); void Lwrite(void); void Lmember(void); void siLpackage_internal(void); void siLpackage_external(void); void Lmake_pathname(void); void Lnamestring(void); void Lclose(void); void Lgensym(void); void Lfresh_line(void); void Llist(void); void Lread_char(void); void Lchar_eq(void); void Lfinish_output(void); void Lchar_neq(void); void Lwrite(void); void Lgensym(void); void Lmember(void); void Lappend(void); void Lcopy_tree(void); void Ladjoin(void); void Lgetf(void); void Lsubst(void); void Lsymbol_package(void); void Lcopy_list(void); void Lintern(void); void Lfind_package(void); void LlistA(void); void Llist(void); void Lgetf(void); void Lstreamp(void); void Lpeek_char(void); void Lread_char(void); void Lread_line(void); void Lset_macro_character(void); void Lclrhash(void); void siLhash_set(void); void Lgethash(void); void Lremhash(void); void Llist_all_packages(void); void Lintern(void); void Lunintern(void); void Lsubseq(void); void Lsymbol_package(void); void Lfind_package(void); void siLpackage_internal(void); void siLpackage_external(void); void Lread_char(void); void Lfile_length(void); void Lfile_position(void); void Lclose(void); void Lsubseq(void); void Lnamestring(void); void Lmerge_pathnames(void); void Lcopy_list(void); void Lread_line(void); void Lgensym(void); void Lcopy_list(void); void Lintern(void); void Lappend(void); void Lgensym(void); void Lcopy_list(void); void Lmember(void); void Lintern(void); void Lappend(void); void Lfind_package(void); void Lpackage_name(void); void Lpackage_nicknames(void); void Lpackage_use_list(void); void siLpackage_external(void); void siLpackage_internal(void); void Lsymbol_package(void); void Lappend(void); void Lgentemp(void); void Lgensym(void); void Lassoc(void); void Ladjoin(void); void Lstring_eq(void); void Lmember(void); void Lgethash(void); void Lfinish_output(void); void Lread(void); void Lmake_hash_table(void); void siLhash_set(void); void Lrevappend(void); void Lreconc(void); void Lcopy_list(void); void LlistA(void); void Lfind_package(void); void siLpackage_internal(void); void siLpackage_external(void); void princ_char(int,object); void Ldigit_char_p(void); void Lwrite_byte(void); void FEpackage_error(object,const char *s); int system_time_zone_helper(void); object call_proc_new(object,void **,int,object,va_list); object call_vproc_new(object,void *,object,va_list); void funcall_with_catcher(object, object); void siLset_symbol_plist(void); void Lhash_table_p(void); void Lreadtablep(void); int fixnum_expt(int, int); void check_alist(object); void ck_larg_at_least(int,object); void vfun_wrong_number_of_args(object); /* FIXME from lfun_list.lsp -- should be automatically generated */ void Lgensym(void); void Lsubseq(void); void Lminusp(void); void Linteger_decode_float(void); void Lminus(void); void Lint_char(void); void Lchar_int(void); void Lall_different(void); void Lcopy_seq(void); void Lkeywordp(void); void Lname_char(void); void Lchar_name(void); void Lrassoc_if(void); void Lmake_list(void); void Lhost_namestring(void); void Lmake_echo_stream(void); void Lnth(void); void Lsin(void); void Lnumerator(void); void Larray_rank(void); void Lcaar(void); void Lboth_case_p(void); void Lnull(void); void Lrename_file(void); void Lfile_author(void); void Lstring_capitalize(void); void Lmacroexpand(void); void Lnconc(void); void Lboole(void); void Ltailp(void); void Lconsp(void); void Llistp(void); void Lmapcan(void); void Llength(void); void Lrassoc(void); void Lpprint(void); void Lpathname_host(void); void Lnsubst_if_not(void); void Lfile_position(void); void Lstring_l(void); void Lreverse(void); void Lstreamp(void); void siLputprop(void); void Lremprop(void); void Lsymbol_package(void); void Lnstring_upcase(void); void Lstring_ge(void); void Lrealpart(void); void Lnbutlast(void); void Larray_dimension(void); void Lcdr(void); void Leql(void); void Llog(void); void Ldirectory(void); void Lstring_not_equal(void); void Lshadowing_import(void); void Lmapc(void); void Lmapl(void); void Lmakunbound(void); void Lcons(void); void Llist(void); void Luse_package(void); void Lfile_length(void); void Lmake_symbol(void); void Lstring_right_trim(void); void Lenough_namestring(void); void Lprint(void); void Lcddaar(void); void Lcdadar(void); void Lcdaadr(void); void Lcaddar(void); void Lcadadr(void); void Lcaaddr(void); void Lset_macro_character(void); void Lforce_output(void); void Lnthcdr(void); void Llogior(void); void Lchar_downcase(void); void Lstream_element_type(void); void Lpackage_used_by_list(void); void Ldivide(void); void Lmaphash(void); void Lstring_eq(void); void Lpairlis(void); void Lsymbolp(void); void Lchar_not_lessp(void); void Lone_plus(void); void Lby(void); void Lnsubst_if(void); void Lcopy_list(void); void Ltan(void); void Lset(void); void Lfunctionp(void); void Lwrite_byte(void); void Llast(void); void Lmake_string(void); void Lcaaar(void); void Llist_length(void); void Lcdddr(void); void Lprin1(void); void Lprinc(void); void Llower_case_p(void); void Lchar_le(void); void Lstring_equal(void); void Lclear_output(void); void CERROR(void); void Lterpri(void); void Lnsubst(void); void Lunuse_package(void); void Lstring_not_greaterp(void); void Lstring_g(void); void Lfinish_output(void); void Lspecial_form_p(void); void Lstringp(void); void Lget_internal_run_time(void); void Ltruncate(void); void Lcode_char(void); void Lchar_code(void); void Lsimple_string_p(void); void Lrevappend(void); void Lhash_table_count(void); void Lpackage_use_list(void); void Lrem(void); void Lmin(void); void Lapplyhook(void); void Lexp(void); void Lchar_lessp(void); void Lcdar(void); void Lcadr(void); void Llist_all_packages(void); void Lcdr(void); void Lcopy_symbol(void); void Lacons(void); void Ladjustable_array_p(void); void Lsvref(void); void Lapply(void); void Ldecode_float(void); void Lsubst_if_not(void); void Lrplaca(void); void Lsymbol_plist(void); void Lwrite_string(void); void Llogeqv(void); void Lstring(void); void Lstring_upcase(void); void Lceiling(void); void Lgethash(void); void Ltype_of(void); void Lbutlast(void); void Lone_minus(void); void Lmake_hash_table(void); void Lstring_neq(void); void Lmonotonically_nondecreasing(void); void Lmake_broadcast_stream(void); void Limagpart(void); void Lintegerp(void); void Lread_char(void); void Lpeek_char(void); void Lchar_font(void); void Lstring_greaterp(void); void Loutput_stream_p(void); void Lash(void); void Llcm(void); void Lelt(void); void Lcos(void); void Lnstring_downcase(void); void Lcopy_alist(void); void Latan(void); void Ldelete_file(void); void Lfloat_radix(void); void Lsymbol_name(void); void Lclear_input(void); void Lfind_symbol(void); void Lchar_l(void); void Lhash_table_p(void); void Levenp(void); void siLcmod(void); void siLcplus(void); void siLctimes(void); void siLcdifference(void); void Lzerop(void); void Lcaaaar(void); void Lchar_ge(void); void Lcdddar(void); void Lcddadr(void); void Lcdaddr(void); void Lcadddr(void); void Lfill_pointer(void); void Lmapcar(void); void Lfloatp(void); void Lshadow(void); void Lmacroexpand_1(void); void Lsxhash(void); void Llisten(void); void Larrayp(void); void Lmake_pathname(void); void Lpathname_type(void); void Lfuncall(void); void Lclrhash(void); void Lgraphic_char_p(void); void Lfboundp(void); void Lnsublis(void); void Lchar_not_equal(void); void Lmacro_function(void); void Lsubst_if(void); void Lcomplexp(void); void Lread_line(void); void Lpathnamep(void); void Lmax(void); void Lin_package(void); void Lreadtablep(void); void Lfloat_sign(void); void Lcharacterp(void); void Lread(void); void Lnamestring(void); void Lunread_char(void); void Lcdaar(void); void Lcadar(void); void Lcaadr(void); void Lchar_eq(void); void Lalpha_char_p(void); void Lstring_trim(void); void Lmake_package(void); void Lclose(void); void Ldenominator(void); void Lfloat(void); void Lcar(void); void Lround(void); void Lsubst(void); void Lupper_case_p(void); void Larray_element_type(void); void Ladjoin(void); void Llogand(void); void Lmapcon(void); void Lintern(void); void Lvalues(void); void Lexport(void); void Ltimes(void); void Lmonotonically_increasing(void); void Lcomplex(void); void Lset_syntax_from_char(void); void Lchar_bit(void); void Linteger_length(void); void Lpackagep(void); void Linput_stream_p(void); void Lmonotonically_nonincreasing(void); void Lpathname(void); void Leq(void); void Lmake_char(void); void Lfile_namestring(void); void Lcharacter(void); void Lsymbol_function(void); void Lconstantp(void); void Lchar_equal(void); void Ltree_equal(void); void Lcddr(void); void Lgetf(void); void Lsave(void); void Lmake_random_state(void); void Lchar_not_greaterp(void); void Lexpt(void); void Lsqrt(void); void Lscale_float(void); void Lchar_g(void); void Lldiff(void); void Lassoc_if_not(void); void Lbit_vector_p(void); void Lnstring_capitalize(void); void Lsymbol_value(void); void Lrplacd(void); void Lboundp(void); void Lequalp(void); void Lsimple_bit_vector_p(void); void Lmember_if_not(void); void Lmake_two_way_stream(void); void Lparse_integer(void); void Lplus(void); void Lall_the_same(void); void Lgentemp(void); void Lrename_package(void); void Lcommonp(void); void Lnumberp(void); void Lcopy_readtable(void); void Lrandom_state_p(void); void Ldirectory_namestring(void); void Lstandard_char_p(void); void Ltruename(void); void Lidentity(void); void Lnreverse(void); void Lpathname_device(void); void Lunintern(void); void Lunexport(void); void Lfloat_precision(void); void Lstring_downcase(void); void Lcar(void); void Lconjugate(void); void Lnull(void); void Lread_char_no_hang(void); void Lfresh_line(void); void Lwrite_char(void); void Lparse_namestring(void); void Lstring_not_lessp(void); void Lchar(void); void Laref(void); void Lpackage_nicknames(void); void Lendp(void); void Loddp(void); void Lchar_upcase(void); void LlistA(void); void Lvalues_list(void); void Lequal(void); void Ldigit_char_p(void); void Lchar_neq(void); void Lpathname_directory(void); void Lcdaaar(void); void Lcadaar(void); void Lcaadar(void); void Lcaaadr(void); void Lcddddr(void); void Lget_macro_character(void); void Lformat(void); void Lcompiled_function_p(void); void Lsublis(void); void Lpathname_name(void); void Limport(void); void Llogxor(void); void Lrassoc_if_not(void); void Lchar_greaterp(void); void Lmake_synonym_stream(void); void Lalphanumericp(void); void Lremhash(void); void Lreconc(void); void Lmonotonically_decreasing(void); void Llogbitp(void); void Lmaplist(void); void Lvectorp(void); void Lassoc_if(void); void Lget_properties(void); void Lstring_le(void); void Levalhook(void); void Lfile_write_date(void); void Llogcount(void); void Lmerge_pathnames(void); void Lmember_if(void); void Lread_byte(void); void Lsimple_vector_p(void); void Lchar_bits(void); void Lcopy_tree(void); void Lgcd(void); void Lby(void); void Lget(void); void Lmod(void); void Ldigit_char(void); void Lprobe_file(void); void Lstring_left_trim(void); void Lpathname_version(void); void Lwrite_line(void); void Leval(void); void Latom(void); void Lcddar(void); void Lcdadr(void); void Lcaddr(void); void Lfmakunbound(void); void Lsleep(void); void Lpackage_name(void); void Lfind_package(void); void Lassoc(void); void Lset_char_bit(void); void Lfloor(void); void Lwrite(void); void Lplusp(void); void Lfloat_digits(void); void Lread_delimited_list(void); void Lappend(void); void Lmember(void); void Lstring_lessp(void); void Lrandom(void); void siLspecialp(void); void siLoutput_stream_string(void); void siLstructurep(void); void siLcopy_stream(void); void siLinit_system(void); void siLstring_to_object(void); void siLreset_stack_limits(void); void siLdisplaced_array_p(void); void siLrplaca_nthcdr(void); void siLlist_nth(void); void siLmake_vector(void); void siLaset(void); void siLsvset(void); void siLfill_pointer_set(void); void siLreplace_array(void); void siLfset(void); void siLhash_set(void); void Lboole(void); void siLpackage_internal(void); void siLpackage_external(void); void siLelt_set(void); void siLchar_set(void); void siLmake_structure(void); void siLstructure_name(void); void siLstructure_ref(void); void siLstructure_set(void); void siLput_f(void); void siLrem_f(void); void siLset_symbol_plist(void); void siLbit_array_op(void); object cmod(object); object ctimes(object,object); object cdifference(object,object); object cplus(object,object); object Icall_error_handler(object,object,int,...); void * gcl_gmp_alloc(size_t); int my_plt(const char *,unsigned long *); int parse_plt(void); int sgc_count_read_only_type(int); int gcl_isnormal_double(double); int gcl_isnormal_float(float); int gcl_isnan(object); int gcl_is_not_finite(object); object find_init_name1(char *,unsigned); #ifdef SGC void memprotect_test_reset(void); #endif #if defined (__MINGW32__) int bcmp ( const void *s1, const void *s2, size_t n ); void bcopy ( const void *s1, void *s2, size_t n ); void bzero(void *b, size_t length); int TcpOutputProc ( int fd, char *buf, int toWrite, int *errorCodePtr, int block ); void gcl_init_shared_memory ( void ); void fix_filename ( object pathname, char *filename1 ); void alarm ( int n ); void *sbrk ( ptrdiff_t increment ); #define sigset_t int void sigemptyset( sigset_t *set); void sigaddset ( sigset_t *set, int n); int sigismember ( sigset_t *set, int n ); int sigprocmask ( int how, const sigset_t *set, sigset_t *oldset ); #endif #if defined (__MINGW32__) || defined (__CYGWIN__) void recreate_heap1 ( void ); #endif void gprof_cleanup(void); int msystem(const char *); void assert_error(const char *,unsigned,const char *,const char *); #ifdef __MINGW32__ void init_shared_memory(void); object find_init_string(const char *); #endif void * get_mmap(FILE *,void **); void * get_mmap_shared(FILE *,void **); int un_mmap(void *,void *); object fSuse_fast_links_2(object,object); MP_INT * otoi(object); void isetq_fix(MP_INT *,int); int mpz_to_mpz1(MP_INT *,MP_INT *,void *); int mpz_to_mpz(MP_INT *,MP_INT *); int obj_to_mpz1(object,MP_INT *,void *); int obj_to_mpz(object,MP_INT *); struct htent *gethash(object,object); int update_real_maxpage(void); fixnum set_tm_maxpage(struct typemanager *,fixnum); void init_gmp_rnd_state(__gmp_randstate_struct *); void reinit_gmp(void); object mod(object,object); void intdivrem(object,object,fixnum,object *,object *); object integer_count(object); object integer_length(object); bool integer_bitp(object,object); object fixnum_times(fixnum,fixnum); object log_op2(fixnum,object,object); object fixnum_big_shift(fixnum,fixnum); object integer_shift(object,object); object number_abs(object); object number_signum(object); object number_ldb(object,object); object number_ldbt(object,object); object number_dpb(object,object,object); object number_dpf(object,object,object); #if defined(DARWIN) void init_darwin_zone_compat (); #endif void prelink_init(void); int gcl_mprotect(void *,unsigned long,int); int rl_pending_buffered_input_p(FILE *f); int rl_eof_p(FILE *f); int rl_stream_p(FILE *f); void sigint(void); void allocate_code_block_reserve(void); void * alloc_contblock_no_gc(size_t,char *); void reset_contblock_freelist(void); void empty_relblock(void); fixnum check_avail_pages(void); int mbrk(void *); void maybe_set_hole_from_maxpages(void); void * alloc_code_space(size_t,ufixnum); object fSmake_vector1_2(fixnum,fixnum,object,object); struct pageinfo * get_pageinfo(void *); void add_page_to_freelist(char *, struct typemanager *); ufixnum sum_maxpages(void); void resize_hole(ufixnum,enum type,bool); void setup_rb(bool); void close_pool(void); void gcl_cleanup(int); void do_gcl_abort(void); int vsystem(const char *); object n_cons_from_x(fixnum,object); int seek_to_end_ofile(FILE *); void travel_find_sharing(object,object); object new_cfdata(void); int home_namestring1(const char *,int,char *,int); object gcl_make_hash_table(object); gcl-2.6.14/h/sun3.defs0000755000175000017500000000150314360276512012757 0ustar cammcamm # Machine dependent makefile definitions for sun3, sun2r3 LBINDIR=/usr/local/bin OFLAG = -O LIBS = -lm -lg ODIR_DEBUG= # This CC string will be used for compilation of the system, # and also in the compiler::*cc* variable for later compilation of # lisp files. CC = cc -DVOL= -Bstatic -I$(GCLDIR)/o # If you have a good gcc (not version 1.36 it has a bug) 1.35 is ok. CC = gcc -fwritable-strings -msoft-float -DVOL=volatile -I$(GCLDIR)/o # Enable the fastloading mechanism which does not use ld -A # requires c/rel_.. machine dependent code. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s # the make to use for saved_kcp the profiler. KCP=kcp-sun MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a gcl-2.6.14/h/ncr.defs0000755000175000017500000000132414360276512012652 0ustar cammcammLBINDIR=/usr/local/bin SHELL=/bin/sh OFLAG = -g LIBS = -lm RANLIB=true # define this to be empty if you want to save space ODIR_DEBUG= # For various system V 386 machines. # CC = gcc -fwritable-strings -msoft-float -DVOL=volatile -I$(GCLDIR)/o CC = cc -I$(GCLDIR)/o -DVOL= -Bstatic # LDCC= cc /usr/local/lib/gcc-gnulib LDCC= cc /usr/local/lib/gcc-gnulib CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. # RSYM = rsym #SFASL = $(ODIR)/sfasl.o #:MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a # When using SFASL it is good to have (si::build-symbol-table) # INITFORM=(si::build-symbol-table) gcl-2.6.14/h/aarch64-linux.h0000644000175000017500000000065214360276512013763 0ustar cammcamm#include "linux.h" #ifdef IN_GBC #undef MPROTECT_ACTION_FLAGS #define MPROTECT_ACTION_FLAGS SA_RESTART|SA_SIGINFO #define GET_FAULT_ADDR(sig,code,sv,a) \ ((siginfo_t *)code)->si_addr /* #define GET_FAULT_ADDR(sig,code,sv,a) \ */ /* ((void *)(*((char ***)(&code)))[44]) */ #endif #define RELOC_H "elf64_aarch64_reloc.h" #define SPECIAL_RELOC_H "elf64_aarch64_reloc_special.h" #define NEED_STACK_CHK_GUARD #define SGC gcl-2.6.14/h/pageinfo.h0000644000175000017500000000026214360276512013163 0ustar cammcamm#include "pbits.h" struct pageinfo { unsigned long type:6; unsigned long magic:7; unsigned long sgc_flags:2; unsigned long in_use:LM(15); struct pageinfo *next; }; gcl-2.6.14/h/compat.h0000755000175000017500000000100114360276512012651 0ustar cammcamm #define Scons sLcons #define aref1 fLrow_major_aref #define aref fLrow_major_aref /* #define aset1 fSaset1 */ #define aset aset1 #define siSPinit sSPinit #define siSPmemory sSPmemory #define siSdefmacroA sSdefmacroA #define siSfunction_documentation sSfunction_documentation #define siSlambda_block_expanded sSlambda_block_expanded #define siSpretty_print_format sSpretty_print_format #define IdoInit(x,y) do_init(y) /* #define siSsharp_comma */ #define siSvariable_documentation sSvariable_documentation gcl-2.6.14/h/.gitignore0000644000175000017500000000005214360276512013207 0ustar cammcammconfig.h gclincl.h mcompdefs.h new_decl.h gcl-2.6.14/h/type.h0000644000175000017500000001252114360276512012355 0ustar cammcammenum type { t_cons, t_start = 0, t_fixnum, t_bignum, t_ratio, t_shortfloat, t_longfloat, t_complex, t_stream, t_pathname, t_string, t_bitvector, t_vector, t_array, t_hashtable, t_structure, t_character, t_symbol, t_package, t_random, t_readtable, t_cfun, t_cclosure, t_sfun, t_gfun, t_vfun, t_afun, t_closure, t_cfdata, t_spice, t_contiguous, t_end=t_contiguous, t_relocatable, t_other }; enum smmode { /* stream mode */ smm_input, /* input */ smm_output, /* output */ smm_io, /* input-output */ smm_probe, /* probe */ smm_synonym, /* synonym */ smm_broadcast, /* broadcast */ smm_concatenated, /* concatenated */ smm_two_way, /* two way */ smm_echo, /* echo */ smm_string_input, /* string input */ smm_string_output, /* string output */ smm_user_defined, /* for user defined */ smm_socket /* Socket stream */ }; #define Zcdr(a_) (*(object *)(a_))/* ((a_)->c.c_cdr) */ /*FIXME*/ #ifndef WIDE_CONS #ifndef USE_SAFE_CDR #define SAFE_CDR(a_) a_ #define imcdr(a_) is_imm_fixnum(Zcdr(a_)) #else #define SAFE_CDR(a_) ({object _a=(a_);is_imm_fixnum(_a) ? make_fixnum1(fix(_a)) : _a;}) #ifdef DEBUG_SAFE_CDR #define imcdr(a_) (is_imm_fixnum(Zcdr(a_)) && (error("imfix cdr"),1)) #else #define imcdr(a_) 0 #endif #endif #else #define SAFE_CDR(a_) a_ #define imcdr(a_) 0 #endif #define is_marked(a_) (imcdr(a_) ? is_marked_imm_fixnum(Zcdr(a_)) : (a_)->d.m) #define is_marked_or_free(a_) (imcdr(a_) ? is_marked_imm_fixnum(Zcdr(a_)) : (a_)->md.mf) #define mark(a_) if (imcdr(a_)) mark_imm_fixnum(Zcdr(a_)); else (a_)->d.m=1 #define unmark(a_) if (imcdr(a_)) unmark_imm_fixnum(Zcdr(a_)); else (a_)->d.m=0 #define is_free(a_) (!is_imm_fixnum(a_) && !imcdr(a_) && (a_)->d.f) #define make_free(a_) ({(a_)->fw=0;(a_)->d.f=1;(a_)->fw|=(fixnum)OBJNULL;})/*set_type_of(a_,t_other)*/ #define make_unfree(a_) {(a_)->d.f=0;} #ifdef WIDE_CONS #define valid_cdr(a_) 0 #else #define valid_cdr(a_) (!(a_)->d.e || imcdr(a_)) #endif #define type_of(x) ({register object _z=(object)(x);\ (is_imm_fixnum(_z) ? t_fixnum : \ (valid_cdr(_z) ? (_z==Cnil ? t_symbol : t_cons) : _z->d.t));}) #ifdef WIDE_CONS #define TYPEWORD_TYPE_P(y_) 1 #else #define TYPEWORD_TYPE_P(y_) (y_!=t_cons) #endif /*Note preserve sgc flag here VVV*/ #define set_type_of(x,y) ({hobj _x=(hobj)(x);enum type _y=(y);_x->d.f=0; \ if (TYPEWORD_TYPE_P(_y)) {_x->d.e=1;_x->d.t=_y;_x->fw|=(fixnum)OBJNULL;}}) #ifndef WIDE_CONS #define cdr_listp(x) valid_cdr(x) #define consp(x) ({register object _z=(object)(x);\ (!is_imm_fixnum(_z) && valid_cdr(_z) && _z!=Cnil);}) #define listp(x) ({register object _z=(object)(x);\ (!is_imm_fixnum(_z) && valid_cdr(_z));}) #define atom(x) ({register object _z=(object)(x);\ (is_imm_fixnum(_z) || !valid_cdr(_z) || _z==Cnil);}) #else #define cdr_listp(x) listp(x) #define consp(x) (type_of(x)==t_cons) #define listp(x) ({object _x=x;type_of(_x)==t_cons || _x==Cnil;}) #define atom(x) !consp(x) #endif #define SPP(a_,b_) (type_of(a_)==Join(t_,b_)) #define streamp(a_) SPP(a_,stream) #define packagep(a_) SPP(a_,package) #define hashtablep(a_) SPP(a_,hashtable) #define randomp(a_) SPP(a_,random) #define characterp(a_) SPP(a_,character) #define symbolp(a_) SPP(a_,symbol) #define pathnamep(a_) SPP(a_,pathname) #define stringp(a_) SPP(a_,string) #define fixnump(a_) SPP(a_,fixnum) #define readtablep(a_) SPP(a_,readtable) #define functionp(a_) ({enum type _t=type_of(a_);_t>=t_cfun && _t<=t_closure;}) #define compiled_function_p(a_) functionp(a_) #define integerp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_bignum;}) #define non_negative_integerp(a_) ({enum type _tp=type_of(a_); (_tp == t_fixnum && fix(a_)>=0) || (_tp==t_bignum && big_sign(a_)>=0);}) #define rationalp(a_)({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_ratio;}) #define floatp(a_) ({enum type _tp=type_of(a_); _tp == t_shortfloat || _tp == t_longfloat;}) #define realp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp < t_complex;}) #define numberp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_complex;}) #define arrayp(a_) ({enum type _tp=type_of(a_); _tp >= t_string && _tp <= t_array;}) #define vectorp(a_) ({enum type _tp=type_of(a_); _tp >= t_string && _tp < t_array;}) #define string_symbolp(a_) ({enum type _tp=type_of(a_); _tp == t_string || _tp == t_symbol;}) #define pathname_string_symbolp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\ || _tp == t_symbol;}) #define pathname_string_symbol_streamp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\ || _tp == t_symbol || _tp==t_stream;}) #define pathname_designatorp(a_) ({object _a=(a_);enum type _tp=type_of(a_);_tp==t_pathname||_tp==t_string||file_stream(_a)!=Cnil;}) gcl-2.6.14/h/gmp_wrappers.h0000644000175000017500000001652114360276512014106 0ustar cammcamm#ifndef GMP_WRAPPERS_H #define GMP_WRAPPERS_H EXTER jmp_buf gmp_jmp; EXTER int jmp_gmp,gmp_relocatable; #define join(a_,b_) a_ ## b_ #define Join(a_,b_) join(a_,b_) #define P1(bt_) bt_ _b #define P2(bt_,ct_) P1(bt_),ct_ _c #define P3(bt_,ct_,dt_) P2(bt_,ct_),dt_ _d #define P4(bt_,ct_,dt_,et_) P3(bt_,ct_,dt_),et_ _e #define A1 _b #define A2 A1,_c #define A3 A2,_d #define A4 A3,_e /*FIXME : this is slightly excessively conservative as it includes comparisons with possible non mpz_t type arguments*/ #define E21 _b==(void *)_c #define E31 E21||_b==(void *)_d #define E42 _b==_d||_b==_e||_c==_d||_c==_e #define E20 0 #define E11 0 #define E10 0 #define E30 0 /* if (jmp_gmp++>1) \ FEerror("gmp jmp loop in" #a_, 0);\ */ #define GMP_TMP _tmp #define RF_gmp_ulint unsigned long int #define RD_gmp_ulint RF_gmp_ulint GMP_TMP #define RA_gmp_ulint GMP_TMP = #define RR_gmp_ulint GMP_TMP #define RF_gmp_lint long int #define RD_gmp_lint RF_gmp_lint GMP_TMP #define RA_gmp_lint GMP_TMP = #define RR_gmp_lint GMP_TMP #define RF_int int #define RD_int RF_int GMP_TMP #define RA_int GMP_TMP = #define RR_int GMP_TMP #define RF_gmp_char_star char * #define RD_gmp_char_star RF_gmp_char_star GMP_TMP #define RA_gmp_char_star GMP_TMP = #define RR_gmp_char_star GMP_TMP #define RF_double double #define RD_double RF_double GMP_TMP #define RA_double GMP_TMP = #define RR_double GMP_TMP #define RF_size_t size_t #define RD_size_t RF_size_t GMP_TMP #define RA_size_t GMP_TMP = #define RR_size_t GMP_TMP #define RF_void void #define RD_void #define RA_void #define RR_void /* GMP_WRAPPERS: the gmp library uses heap allocation in places for temporary storage. This greatly complicates relocatable bignum allocation in GCL, which is a big winner in terms of performance. The old procedure was to patch gmp to use alloca in such instances. Aside from possible silently introducing bugs as gmp evolves, such a policy also runs the risk of colliding with gmp's stated policy of storing pointers in allocated blocks, a possiblity GCL's conservative garbage collector is not designed to handle. Here we implement a policy of preventing garbage collection inside of gmp calls in any case. In case of non-inplace calls, where source and destination arguments are distinct, we simply longjmp back to the front of the call if a gbc would be needed and try the call again, as any previous partial write into the destination is of no consequence. Just as is the case with the alloc_contblock and alloc_relblock algorithms themselves, on the second pass (as indicated by jmp_gmp) new pages are added if there is still not enough room in lieu of GBC. In case of in-place calls, we schedule a GBC call after the gmp call completes, relying on the allocator to add pages immediately to the type to satisfy the allocation when necessary. jmp_gmp counts the pass for non-in-place calls, and is set to -1 otherwise. 20040815 CM*/ #define MEM_GMP_CALL(n_,rt_,a_,s_,b_...) \ INLINE Join(RF_,rt_) Join(m,a_)(Join(P,n_)(b_)) { \ int j;\ Join(RD_,rt_);\ if (gmp_relocatable) {\ jmp_gmp=0;\ if ((j=setjmp(gmp_jmp))) \ GBC(j);\ if (Join(Join(E,n_),s_)) jmp_gmp=-1 ; else jmp_gmp++;\ }\ Join(RA_,rt_) a_(Join(A,n_));\ if (gmp_relocatable) {\ if (jmp_gmp<-1) GBC(-jmp_gmp);\ jmp_gmp=0;\ }\ return Join(RR_,rt_);\ } MEM_GMP_CALL(3,void,mpz_add,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_add_ui,1,mpz_t,mpz_t,unsigned long int) MEM_GMP_CALL(3,void,mpz_sub,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_sub_ui,1,mpz_t,mpz_t,unsigned long int) MEM_GMP_CALL(3,void,mpz_mul,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_mul_si,1,mpz_t,mpz_t,long int) MEM_GMP_CALL(3,void,mpz_pow_ui,1,mpz_t,mpz_t,unsigned long int) MEM_GMP_CALL(3,void,mpz_ui_pow_ui,1,mpz_t,unsigned long int,unsigned long int) MEM_GMP_CALL(3,void,mpz_mul_2exp,1,mpz_t,mpz_t,unsigned long int) MEM_GMP_CALL(2,void,mpz_neg,1,mpz_t,mpz_t) MEM_GMP_CALL(4,void,mpz_tdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_tdiv_r,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_tdiv_q,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(4,void,mpz_fdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_fdiv_r,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_fdiv_q,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(4,void,mpz_cdiv_qr,2,mpz_t,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_cdiv_r,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_cdiv_q,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_fdiv_q_2exp,1,mpz_t,mpz_t,unsigned long int) MEM_GMP_CALL(2,int,mpz_cmp,0,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_and,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_xor,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(3,void,mpz_ior,1,mpz_t,mpz_t,mpz_t) MEM_GMP_CALL(2,void,mpz_com,1,mpz_t,mpz_t) MEM_GMP_CALL(2,int,mpz_tstbit,0,mpz_t,unsigned long int) MEM_GMP_CALL(1,void,mpz_init,1,mpz_t) MEM_GMP_CALL(2,void,mpz_init_set,1,mpz_t,mpz_t) MEM_GMP_CALL(2,void,mpz_set,1,mpz_t,mpz_t) MEM_GMP_CALL(2,void,mpz_set_ui,1,mpz_t,unsigned long int) MEM_GMP_CALL(2,void,mpz_set_si,1,mpz_t,long int) MEM_GMP_CALL(1,double,mpz_get_d,0,mpz_t) MEM_GMP_CALL(1,gmp_lint,mpz_get_si,0,mpz_t) MEM_GMP_CALL(3,gmp_char_star,mpz_get_str,0,char *,int,mpz_t) MEM_GMP_CALL(3,int,mpz_set_str,0,mpz_t,char *,int)/*arg set, but 0 for check as moot*/ MEM_GMP_CALL(1,int,mpz_fits_sint_p,0,mpz_t) MEM_GMP_CALL(1,gmp_ulint,mpz_popcount,0,mpz_t) /*MEM_GMP_CALL(2,void *,mpz_realloc,mpz_t,mp_size_t)*/ MEM_GMP_CALL(1,size_t,mpz_size,0,mpz_t) MEM_GMP_CALL(2,size_t,mpz_sizeinbase,0,mpz_t,int) MEM_GMP_CALL(1,void,gmp_randinit_default,0,__gmp_randstate_struct *) MEM_GMP_CALL(2,void,gmp_randseed_ui,0,__gmp_randstate_struct *,unsigned long int) /* FIXME: find a way to have this follow the convention in gmp.h*/ #define __gmpz_add m__gmpz_add #define __gmpz_add_ui m__gmpz_add_ui #define __gmpz_sub m__gmpz_sub #define __gmpz_sub_ui m__gmpz_sub_ui #define __gmpz_mul m__gmpz_mul #define __gmpz_mul_si m__gmpz_mul_si #define __gmpz_pow_ui m__gmpz_pow_ui #define __gmpz_ui_pow_ui m__gmpz_ui_pow_ui #define __gmpz_mul_2exp m__gmpz_mul_2exp #define __gmpz_neg m__gmpz_neg #define __gmpz_tdiv_qr m__gmpz_tdiv_qr #define __gmpz_tdiv_q m__gmpz_tdiv_q #define __gmpz_tdiv_r m__gmpz_tdiv_r #define __gmpz_fdiv_qr m__gmpz_fdiv_qr #define __gmpz_fdiv_q m__gmpz_fdiv_q #define __gmpz_fdiv_r m__gmpz_fdiv_r #define __gmpz_cdiv_qr m__gmpz_cdiv_qr #define __gmpz_cdiv_q m__gmpz_cdiv_q #define __gmpz_cdiv_r m__gmpz_cdiv_r #define __gmpz_fdiv_q_2exp m__gmpz_fdiv_q_2exp #define __gmpz_cmp m__gmpz_cmp #define __gmpz_and m__gmpz_and #define __gmpz_xor m__gmpz_xor #define __gmpz_ior m__gmpz_ior #define __gmpz_com m__gmpz_com #define __gmpz_tstbit m__gmpz_tstbit #define __gmpz_init m__gmpz_init #define __gmpz_init_set m__gmpz_init_set #define __gmpz_set m__gmpz_set #define __gmpz_set_ui m__gmpz_set_ui #define __gmpz_set_si m__gmpz_set_si #define __gmpz_get_d m__gmpz_get_d #define __gmpz_get_si m__gmpz_get_si #define __gmpz_get_str m__gmpz_get_str #define __gmpz_set_str m__gmpz_set_str #define __gmpz_fits_sint_p m__gmpz_fits_sint_p #define __gmpz_popcount m__gmpz_popcount /*#define __gmpz_realloc m__gmpz_realloc*/ #define __gmpz_size m__gmpz_size #define __gmpz_sizeinbase m__gmpz_sizeinbase #define __gmp_randinit_default m__gmp_randinit_default #define __gmp_randseed_ui m__gmp_randseed_ui #endif /*GMP_WRAPPERS_H*/ gcl-2.6.14/h/NeXT32-i386.h0000755000175000017500000000224614360276512013054 0ustar cammcamm#ifndef NeXT #define NeXT #endif #include "bsd.h" #undef SFASL #undef HAVE_AOUT #define NO_UNISTD_H #define PAGEWIDTH 12 /* The following value determines the running process size. */ #define BIG_HEAP_SIZE 0x1000000 #undef SET_REAL_MAXPAGE #define SET_REAL_MAXPAGE \ { extern int mach_maplimit; sbrk(0); real_maxpage = mach_maplimit/PAGESIZE; } #define sbrk my_sbrk #define ADDITIONAL_FEATURES \ ADD_FEATURE("MACH"); \ ADD_FEATURE("NeXT"); \ ADD_FEATURE("I386"); \ ADD_FEATURE("TURBO-CLOSURE"); \ ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE") #undef CLEAR_CACHE #define UNIXSAVE "NeXTunixsave.c" #define UNIXFASL "NeXTunixfasl.c" #define SEEK_TO_END_OFILE seek_to_end_ofile #define I386 #define IEEEFLOAT /* assumption: stack bottom = 0xc0000000 ; stack size = 1MB(0x100000) */ #define NULL_OR_ON_C_STACK(x) ((x)==0||(((unsigned int)(x)) >= 0xbff00000)) /* we can use the system malloc without interference with lisp storage allocation */ #define DONT_NEED_MALLOC #ifdef IN_MAIN #include #include #endif #define LITTLE_END /* Begin for cmpinclude */ #ifdef __GNUC__ #undef __BUILTIN_VA_ARG_INCR #endif /* End for cmpinclude */ gcl-2.6.14/h/sun2r3.defs0000755000175000017500000000102714360276512013224 0ustar cammcammLBINDIR=/usr/local/bin # for sun3,sun2r3 OFLAG = -O LIBS = -lm -lg ODIR_DEBUG= CHTAB = sun_chtab.s CC = gcc -fwritable-strings -msoft-float -DVOL=volatile # If you don't have gcc use CC = cc -DVOL= CFLAGS = -c $(DEFS) -I../h # The fast loading currently works for ATT and BSD with 68000 or 386 # architectures. Unless you have these, leave these undefined. RSYM = rsym SFASL = $(ODIR)/sfasl.o # When using SFASL it is good to have (si::build-symbol-table) INITFORM=(si::build-symbol-table) # Use symbolic links SYMB=-s gcl-2.6.14/h/hp300-bsd.h0000755000175000017500000000242314360276512012777 0ustar cammcamm#define HP300_BSD #include "bsd.h" #include "mc68k.h" #define ADDITIONAL_FEATURES \ ADD_FEATURE("HP300"); \ ADD_FEATURE("MC68020") #define MC68020 #define IEEEFLOAT #define DATA_BEGIN (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); #undef FILECPY_HEADER #define FILECPY_HEADER \ if (header.a_magic == ZMAGIC) \ filecpy(save, original, PAGSIZ - sizeof(header)); \ filecpy(save, original, header.a_text); #define RELOC_FILE "rel_sun3.c" #include #undef LITTLE_END #define PAGSIZ (NBPG) #define SEGSIZ (NBPG * CLSIZE) #define TXTRELOC 0 #define USE_DIRENT #define GETPATHNAME #define PATHNAME_CACHE 10 #define HZ 60 /* try out the gnu malloc */ /* #define GNU_MALLOC */ #define SIGPROTV SIGBUS /* In my implementation I have put the address in code Doubtless this will change in Xinu code. */ #define GET_FAULT_ADDR(sig,code,sv,a) ((char *) code) /* Begin for cmpinclude */ /* NOTE: If you don't have the system call mprotect DON'T define this. I have added it to my own kernel. */ #define SGC /* _setjmp and _longjmp exist on bsd and are more efficient and handle the C stack which is all we need. [I think!] */ #define setjmp _setjmp #define longjmp _longjmp /* End for cmpinclude */ gcl-2.6.14/configure-new.ac0000644000175000017500000006350714360276512014063 0ustar cammcammAC_INIT() AC_CONFIG_HEADER(h/gclincl.h) # some parts of this configure script are taken from the tcl configure.in # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. AC_MSG_CHECKING([system version (for dynamic loading)]) if machine=`uname -m` ; then true; else machine=unknown ; fi AC_CHECK_PROGS(AWK,gawk nawk awk,"") AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") AC_SUBST(MAKEINFO) if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_RESULT([unknown (can't find uname command)]) system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system=MP-RAS-`${AWK} '{print $3}' /etc/.relid'` fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi AC_MSG_RESULT($system) fi fi # Find where Data begins. This is used by the storage allocation # mechanism, in the PAGE macro. This offset is subtracted from # addresses, in calculating a page for an address in the heap. AC_PROG_CC # can only test for numbers -- CM # if test "${GCC}" -eq "yes" ; then if [[ "${GCC}" = "yes" ]] ; then # Allog for environment variable overrides on compiler selection -- CM GCC=$CC else GCC="" fi # subst GCC not only under 386-linux, but where available -- CM AC_SUBST(GCC) AC_CHECK_SIZEOF(long *,0) AC_CHECK_HEADERS(endian.h, AC_MSG_CHECKING("endianness") AC_TRY_RUN([#include int main() { return BYTE_ORDER == __LITTLE_ENDIAN ? 0 : 1;}], AC_DEFINE(LITTLE_END) AC_MSG_RESULT(little), AC_MSG_RESULT(big),AC_MSG_RESULT(big))) AC_SUBST(LITTLE_END) AC_MSG_CHECKING("finding DBEGIN") AC_TRY_RUN([#include #include main() { char *b = (void *) malloc(1000); FILE *fp = fopen("conftest1","w"); fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)0xffffff); fclose(fp); return 0; }],dbegin=`cat conftest1`,dbegin=0,dbegin=0) AC_DEFINE_UNQUOTED(DBEGIN,$dbegin \ /* where data begins */ ) AC_MSG_RESULT(got $dbegin) AC_MSG_CHECKING("finding CSTACK_ADDRESS") AC_TRY_RUN([#include main() { char *b ; FILE *fp = fopen("conftest1","w"); fprintf(fp,"%d",((int) &b)); fclose(fp); return 0; }],cstack_address=`cat conftest1`,cstack_address=0,cstack_address=0) AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address \ ) AC_MSG_RESULT(got $cstack_address) AC_MSG_CHECKING("sizeof long long int") AC_TRY_RUN([#include main() { if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; } ],[AC_DEFINE(HAVE_LONG_LONG) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no), AC_MSG_RESULT(no) ) AC_SUBST(HAVE_LONG_LONG) # readline AC_ARG_ENABLE(readline, [--enable-readine enables command line completion via the readline library ],, enable_readline="yes") # ansi lisp AC_ARG_ENABLE(ansi,[--enable-ansi builds a large gcl aiming for ansi compliance, --disable-ansi builds the smaller traditional CLtL1 image],,enable_ansi="no") if test "$enable_ansi" = "yes" ; then FLISP=saved_ansi_gcl; else FLISP=saved_gcl fi AC_SUBST(FLISP) # pagewidth AC_MSG_CHECKING(for pagewidth) AC_TRY_RUN([#include #include int main() {size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); fprintf(fp,"%u",j); return 0;}],PAGEWIDTH=`cat conftest1`,PAGEWIDTH=0,PAGEWIDTH=0) AC_MSG_RESULT($PAGEWIDTH) AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH) AC_SUBST(PAGEWIDTH) # bfd probe AC_ARG_ENABLE(bfd, [ --disable-bfd prevents gcl from using libbfd.a for fast object loading and symbol table lookups ] ,, enable_bfd="yes") # Maximum number of pages help="--enable-maxpage=XXXX will compile in a page table of size XXX (default ${default_maxpage})" AC_ARG_ENABLE(maxpage,[ --enable-maxpage=XXXX will compile in a page table of size XXX (eg '--enable-maxpage=64*1024' would give 64K pages allowing 256 MB if pages are 4K each)] , [AC_DEFINE_UNQUOTED(MAXPAGE,$enable_maxpage)] ) AC_ARG_ENABLE(vssize,[ --enable-vssize=XXXX will compile in a value stack of size XXX] , [AC_DEFINE_UNQUOTED(VSSIZE,$enable_vssize)] ) AC_ARG_ENABLE(machine,[ --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs] , [enable_machine=$enableval],[enable_machine=""]) AC_ARG_ENABLE(gmp,[ --enable-gmp=no will disable use of GMP gnu multiprecision arithmetic, (default is =yes)] , [use_gmp=$enableval],[use_gmp="yes"]) AC_ARG_ENABLE(notify,[ --enable-notify=no will disable the automatic notification of gcl maintainers of successful builds/problems] , [enable_notify=$enableval],[enable_notify="yes"]) AC_ARG_ENABLE(tkconfig,[ --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh ] , [TK_CONFIG_PREFIX=$enableval],[TK_CONFIG_PREFIX="unknown"]) AC_ARG_ENABLE(tclconfig,[ --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh ] , [TCL_CONFIG_PREFIX=$enableval],[TCL_CONFIG_PREFIX="unknown"]) AC_ARG_ENABLE(infodir,[ --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info ] , [INFO_DIR=$enableval],[INFO_DIR="unknown"]) # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd) AC_CHECK_FUNCS(getwd) AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) AC_CHECK_HEADERS(sys/ioctl.h) #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- AC_CHECK_FUNC([BSDgettimeofday], [AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], [AC_CHECK_FUNC([gettimeofday], , [AC_DEFINE([NO_GETTOD])])]) AC_MSG_CHECKING([for gettimeofday declaration]) AC_EGREP_HEADER([gettimeofday], [sys/time.h], [AC_MSG_RESULT([present])], [AC_MSG_RESULT([missing]) AC_DEFINE(GETTOD_NOT_DECLARED)]) AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) # Should really find a way to check for prototypes, but this # basically works for now. CM # AC_CHECK_HEADERS(math.h,AC_DEFINE(NEED_MATH_H)) # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # AC_MSG_CHECKING([for isnormal]) AC_TRY_RUN([#define _GNU_SOURCE #include int main() { float f; return isnormal(f) || !isnormal(f) ? 0 : 1; }], AC_DEFINE(HAVE_ISNORMAL) AC_MSG_RESULT(yes), AC_MSG_CHECKING([for fpclass in ieeefp.h]) AC_TRY_RUN([#include int main() { float f; return fpclass(f)>=FP_NZERO || fpclass(f) int main() { float f; return isfinite(f) || !isfinite(f) ? 0 : 1; }], AC_DEFINE(HAVE_ISFINITE) AC_MSG_RESULT(yes), AC_MSG_CHECKING([for finite()]) AC_TRY_RUN([#include int main() { float f; return finite(f) || !finite(f) ? 0 : 1; }], AC_DEFINE(HAVE_FINITE) AC_MSG_RESULT(yes), HAVE_FINITE=0 AC_MSG_RESULT(no),HAVE_FINITE=0 AC_MSG_RESULT(no)) ,HAVE_ISFINITE=0 AC_MSG_RESULT(no),HAVE_ISFINITE=0 AC_MSG_RESULT(no)) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- AC_MSG_CHECKING([for sockets]) tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) if test "$enable_readline" = "yes" ; then AC_CHECK_LIB([readline], [main], [AC_DEFINE(HAVE_READLINE) LIBS="$LIBS -lreadline -lncurses" RL_OBJS=readline.o RL_LIB=lsp/readline.o],, [-lncurses]) fi if test "$enable_bfd" = "yes" ; then AC_CHECK_HEADER(bfd.h, AC_CHECK_LIB(bfd,bfd_init, if $CC -v 2>&1 | fgrep ming > /dev/null ; then BFDLIB="-lbfd" IBRLIB="-liberty" else echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$GCC [[ -Wl,-M ]] -static -o foo foo.c -lbfd -liberty 2>&1 | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo BFDLIB=`echo $MP | tr ' ' '\012' | grep libbfd.a` IBRLIB=`echo $MP | tr ' ' '\012' | grep libiberty.a` fi # # Old binutils appear to need CONST defined to const # AC_MSG_CHECKING(if need to define CONST for bfd) AC_TRY_RUN([#define IN_GCC #include int main() { symbol_info t; return 0;}], AC_MSG_RESULT(no) AC_DEFINE(HAVE_LIBBFD) LIBS="$LIBS $BFDLIB $IBRLIB", AC_TRY_RUN([#define IN_GCC #include #define CONST const int main() {symbol_info t; return 0;}], AC_MSG_RESULT(yes) AC_DEFINE(NEED_CONST) AC_DEFINE(HAVE_LIBBFD) LIBS="$LIBS $BFDLIB $IBRLIB", AC_MSG_RESULT(cannot use bfd),AC_MSG_RESULT(cannot use bfd)), AC_MSG_RESULT(cannot use bfd)) ,,-liberty)) fi AC_SUBST(LIBS) AC_SUBST(RL_OBJS) AC_SUBST(RL_LIB) AC_MSG_CHECKING(For network code for nsocket.c) AC_TRY_LINK([ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ ],[ connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ], [AC_DEFINE(HAVE_NSOCKET) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for listen using fcntl) AC_TRY_COMPILE([#include #include ], [FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ], [AC_DEFINE(LISTEN_USE_FCNTL) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE)]) AC_SUBST(NO_PROFILE) AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV)],no_setenv=1 ) AC_SUBST(HAVE_SETENV) if test "$no_setenv" = "1" ; then AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV)],) AC_SUBST(HAVE_PUTENV) fi AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP)],) AC_SUBST(USE_CLEANUP) gcl_ok=no AC_HEADER_EGREP(LITTLE_ENDIAN, ctype.h, gcl_ok=yes, gcl_ok=noo) if test $gcl_ok = yes ; then AC_DEFINE(ENDIAN_ALREADY_DEFINED) fi AC_SUBST(ENDIAN_ALREADY_DEFINED) # if test "x$enable_machine" = "x" ; then AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; ULTRIX-4.*) AC_DEFINE(USE_FIONBIO) AC_MSG_RESULT(FIONBIO) ;; *) AC_MSG_RESULT(O_NONBLOCK) ;; esac AC_CANONICAL_HOST canonical=$host ## host=CPU-COMPANY-SYSTEM AC_MSG_RESULT(host=$host) use=unknown case $canonical in older) use=386-bsd;; *86-*-linux*) use=386-linux; ln -snf linux.defs h/$use.defs;; m68k-*-linux*) use=m68k-linux; ln -snf linux.defs h/$use.defs;; alpha*-*-linux*) use=alpha-linux; ln -snf linux.defs h/$use.defs;; mips-*-linux*) use=mips-linux; ln -snf linux.defs h/$use.defs;; mipsel-*-linux*) use=mipsel-linux; ln -snf linux.defs h/$use.defs;; sparc*-*-linux*) use=sparc-linux; ln -snf linux.defs h/$use.defs;; arm*-*-linux*) use=arm-linux; ln -snf linux.defs h/$use.defs;; s390-*-linux*) use=s390-linux; ln -snf linux.defs h/$use.defs;; ia64-*-linux*) use=ia64-linux; ln -snf linux.defs h/$use.defs;; hppa-*-linux*) use=hppa-linux; ln -snf linux.defs h/$use.defs;; powerpc-*-linux*) use=powerpc-linux; ln -snf linux.defs h/$use.defs;; alpha-dec-osf) use=alpha-osf1;; mips-dec-ultrix) use=dec3100;; old) use=dos-go32;; *86*-freebsd) use=FreeBSD;; hp3*-*hpux*) use=hp300;; hp3*-*-*bsd*) use=hp300-bsd;; hppa*-*hpux*) use=hp800;; mips-sgi-irix) case $system in IRIX5*) use=irix5;; IRIX6*) use=irix6;; IRIX3*) use=sgi4d;; esac ;; m68k-apple-aux*) use=mac2;; old) use=mp386;; *86-ncr-sysv4) use=ncr;; *[3-9]86-*netbsd*) use=NetBSD;; old) use=NeXT;; old) use=NeXT30-m68k;; *86-*nextstep*) use=NeXT32-i386;; *m68*-*nextstep*) use=NeXT32-m68k;; *rs6000-*-aix4*) use=rios;; *rs6000-*-aix3*) use=rios-aix3;; old) use=rt_aix;; old) use=sgi;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; sparc-*-linux*) use=sparc-linux;; old) use=sun2r3;; old) use=sun3;; m68*-sunos*) use=sun3-os4;; old) use=sun386i;; sparc*sunos*) use=sun4;; *86-sequent-dynix) use=symmetry;; u370*aix) use=u370_aix;; old) use=vax;; i*cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; esac AC_MSG_CHECKING(check for SV_ONSTACK) AC_TRY_COMPILE([#include int joe=SV_ONSTACK; ], [], [AC_DEFINE(HAVE_SV_ONSTACK) AC_SUBST(HAVE_SV_ONSTACK) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGSYS) AC_TRY_COMPILE([#include int joe=SIGSYS; ], [], [AC_DEFINE(HAVE_SIGSYS) AC_SUBST(HAVE_SIGSYS) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) AC_MSG_CHECKING(check for SIGEMT) AC_TRY_COMPILE([#include int joe=SIGEMT; ], [], [AC_DEFINE(HAVE_SIGEMT) AC_SUBST(HAVE_SIGEMT) AC_MSG_RESULT(yes)], AC_MSG_RESULT(no)) #if test $use = "386-linux" ; then AC_CHECK_HEADERS(asm/sigcontext.h) AC_CHECK_HEADERS(asm/signal.h) AC_TRY_COMPILE([#include long code; ], [ void *p = ((void *)(((struct sigcontext_struct *)(&code)))); ], [ sigcontext_struct_works=1; AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT) AC_MSG_RESULT("sigcontext in signal.h") ], [sigcontext_struct_works=0; AC_MSG_RESULT("sigcontext NOT in signal.h")] ) if test "$sigcontext_struct_works" = 0 ; then AC_TRY_COMPILE([#include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif long code; ], [ void *p = ((void *)(((struct sigcontext *)(&code)))); ], [ sigcontext_works=1 ; AC_DEFINE(HAVE_SIGCONTEXT) AC_MSG_RESULT("use struct sigcontext") ], [ sigcontext_works=0 ; ]) fi # echo 'foo() {}' > conftest1.c # $CC -S conftest1.c # use_underscore=0 # if fgrep _foo conftest1.s ; then use_underscore=1 ; fi # if test $use_underscore = 0 ; then # MPI_FILE=mpi-386_no_under.o # else # MPI_FILE=mpi-386d.o # fi # AC_SUBST(MPI_FILE) # GCC=$CC # if test -x /usr/bin/i386-glibc20-linux-gcc ; then # GCC=/usr/bin/i386-glibc20-linux-gcc # fi # AC_SUBST(GCC) #fi AC_PATH_PROG(EMACS,emacs) # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` else EMACS_SITE_LISP="" fi AC_MSG_RESULT($EMACS_SITE_LISP) AC_SUBST(EMACS_SITE_LISP) # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d "$EMACS_SITE_LISP" ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi AC_MSG_RESULT($EMACS_DEFAULT_EL) AC_SUBST(EMACS_DEFAULT_EL) # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` fi if test -f "${INFO_DIR}dir" ; then true;else if test -f /usr/info/dir ; then INFO_DIR=/usr/info/ else true; fi fi AC_MSG_RESULT($INFO_DIR) AC_SUBST(INFO_DIR) AC_MSG_CHECKING([for tcl/tk]) if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <> conftest.tcl <&1 | ${AWK} '/"source / {if (i++) next;sub("/[[^/]]*$","",$2);print $2}'` fi fi fi #AC_MSG_CHECKING(TK_CONFIG_PREFIX=${TK_CONFIG_PREFIX}) if test -f ${TK_CONFIG_PREFIX}/tkConfig.sh ; then . ${TK_CONFIG_PREFIX}/tkConfig.sh ; fi if test -d ${TK_CONFIG_PREFIX}/tk${TK_VERSION} ; then TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION} else if test -d ${TK_CONFIG_PREFIX}/../tk${TK_VERSION} ; then TK_LIBRARY=${TK_CONFIG_PREFIX}/../tk${TK_VERSION} fi fi if test -d ${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} ; then TCL_LIBRARY=${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} else if test -d ${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} ; then TCL_LIBRARY=${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} fi fi if test -f ${TK_CONFIG_PREFIX}/../include/tk.h ; then TK_INCLUDE=-I${TK_CONFIG_PREFIX}/../include else if test -f /usr/include/tcl${TCL_VERSION}/tk.h ; then TK_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi if test -f ${TCL_CONFIG_PREFIX}/../include/tcl.h ; then TCL_INCLUDE=-I${TCL_CONFIG_PREFIX}/../include else if test -f /usr/include/tcl${TCL_VERSION}/tcl.h ; then TCL_INCLUDE=-I/usr/include/tcl${TCL_VERSION} fi fi AC_CHECK_LIB(lieee,main,have_ieee=1,have_ieee=0) if test "$have_ieee" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` fi AC_CHECK_LIB(dl,dlopen,have_dl=1,have_dl=0) if test "$have_dl" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` fi AC_SUBST(TK_CONFIG_PREFIX) AC_SUBST(TK_LIBRARY) AC_SUBST(TCL_LIBRARY) AC_SUBST(TK_XINCLUDES) AC_SUBST(TK_INCLUDE) AC_SUBST(TCL_INCLUDE) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_BUILD_LIB_SPEC) AC_SUBST(TK_XLIBSW) AC_SUBST(TK_XINCLUDES) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_DL_LIBS) AC_SUBST(TCL_LIBS) if test -d "${TK_CONFIG_PREFIX}" ; then AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}]) else AC_MSG_RESULT([not found]) fi NOTIFY=$enable_notify AC_SUBST(NOTIFY) echo enable_machine=$enable_machine if test "x$enable_machine" != "x" ; then use=$enable_machine fi ## finally warn if we did not find a recognized machine.s ## #if test "$use" = "unknown" ; then #types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` #echo got canonical=$canonical, but was not recognized. #echo Unable to guess type to use. Try one of #exit(1) #fi AC_MSG_RESULT(use=$use) # for sgbc the mprotect capabilities. # the time handling for unixtime, add timezone AC_MSG_CHECKING([alloca]) AC_TRY_RUN([int main() { exit(alloca(500) != NULL ? 0 : 1);}], ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) if test $gcl_ok = yes ; then AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ALLOCA) else AC_TRY_RUN([#include int main() { exit(alloca(500) != NULL ? 0 : 1)}], ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) if test $gcl_ok = yes ; then AC_MSG_RESULT(yes) AC_DEFINE(HAVE_ALLOCA) AC_DEFINE(NEED_ALLOCA_H) fi fi if test $gcl_ok = no ; then AC_MSG_RESULT(no) ; fi # alloca # dlopen etc # idea make it so you do something dlopen(libX.so,RTLD_GLOBAL) # then dlload("foo.o") a lisp file can refer to things in libX.so # # what machine this is, and include then a machine specific hdr. # and machine specific defs. # check bzero, # check getcwd, getwd etc.. # check socket stuff.. # getrlimit # fionread or block rm -f makedefsafter MP_INLCUDE="" if test $use_gmp = yes ; then AC_MSG_CHECKING([use_gmp=yes, doing configure in gmp directory]) case "${canonical}" in # i[[5-9]]86* | pentium* | k6* | athlon*) # (cd gmp ; ./configure --target=i486) ;; *) (cd gmp ; ./configure) ;; esac [[ "`ls -1 gmp/mpn/add_n.* 2>/dev/null`" != "" ]] || cp gmp/mpn/generic/*.c gmp/mpn/ AC_MSG_CHECKING("for size of gmp limbs") AC_TRY_RUN([#include #include "h/gmp.h" int main() { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); return 0; }],mpsize=`cat conftest1`,mpsize=0,mpsize=0) if test "$mpsize" = "0" ; then echo "Cannot determine mpsize" exit 1 fi AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize) AC_MSG_RESULT($mpsize) GMP=1 AC_DEFINE(GMP) AC_SUBST(GMP) MP_INCLUDE=h/gmp.h echo > makedefsafter echo 'MPFILES=${GMP_DIR}libgmp.a' >> makedefsafter echo >> makedefsafter fi AC_SUBST(MP_INCLUDE) # redhat/cygnus released for some reason a buggy version of gcc, # which no one else released. Catch that here. AC_MSG_CHECKING([Checking for buggy gcc version from redhat]) if 2>&1 $CC -v | fgrep "gcc version 2.96" > /dev/null then BROKEN_O4_OPT=1 AC_DEFINE(BROKEN_O4_OPT) AC_SUBST(BROKEN_O4_OPT) echo ODIR_DEBUG=-O >> makedefsafter echo >> makedefsafter AC_MSG_RESULT([yes .. turning off -O4]) else AC_MSG_RESULT([no]) fi if test -f h/$use.defs ; then AC_SUBST(use) AC_OUTPUT(makedefc) echo makedefc cat makedefc echo add-defs1 $use CC=$CC ./add-defs1 $use else echo "Unable to guess machine type" echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs fi gcl-2.6.14/man/0000755000175000017500000000000014360276512011546 5ustar cammcammgcl-2.6.14/man/man1/0000755000175000017500000000000014360276512012402 5ustar cammcammgcl-2.6.14/man/man1/gcl.10000755000175000017500000001323214360276512013235 0ustar cammcamm.TH GCL 1L "17 March 1997" .SH NAME gcl \- GCL Common Lisp interpreter/compiler, CVS snapshot .SH SYNOPSIS .B gcl [ .B options ] .SH DESCRIPTION The program .I gcl is an implementation of a subset of the Common Lisp Ansi standard. It is written in C and in Common Lisp, and is highly portable. It includes those features in the original definition of Common Lisp, (Guy Steele version 1.), as well as some features from the proposed new standard. .LP The best documentation is available in .I texinfo/info form, with there being three groups of information. .I gcl\-si for basic common lisp descriptions, and features unique to .I gcl The .I gcl\-tk info refers to the connection with .I tk window system, allowing all the power of the .I tcl/tk interaction system to be used from lisp. The third info file .I gcl details the Ansi standard for common lisp, to which this subset tries to adhere. It is highly recommended to write programs, which will be in the intersection of gcl and ansi common lisp. Unfortunately the Ansi standard is huge, and will require a substantial effort, and increase in the size of gcl, to include all of it. .LP When .I gcl is invoked from the shell, the variable .I si::*command\-args* is set to the list of command line arguments. Various .I options are understood: .TP .BR \-eval\ command .RB Call read and then eval on the .I command passed in. .TP .B \-\- .RB Stop processing arguments, setting si::*command\-args* to a list containing the arguments after the .BR \-\- . .TP .BR \-load\ pathname .RB Load the file whose .I pathname is specified after .BR \-load . .TP .BR \-f .RB Open the file following .BR \-f for input, skip the first line, and then read and eval the rest of the forms in the file. Replaces si::*command\-args* by the the list starting after .BR \-f . This can be used as with the shells to write small shell programs: .LP .br #!/usr/local/bin/gcl.exe \-f .br (format t "hello world ~a~%" (nth 1 si::*command\-args*)) .BR The value .I si::*command\-args* will have the appropriate value. Thus if the above 2 line file is made executable and called .I foo then .LP .LP .br tutorial% foo billy .br hello world billy .BR NOTE: On many systems (eg SunOs) the first line of an executable script file such as: .BR #!/usr/local/bin/gcl.exe \-f only reads the first 32 characters! So if your pathname where the executable together with the '\-f' amount to more than 32 characters the file will not be recognized. Also the executable must be the actual large binary file, [or a link to it], and not just a .I /bin/sh script. In latter case the .I /bin/sh interpreter would get invoked on the file. Alternately one could invoke the file .I foo without making it executable: .LP .LP .br tutorial% gcl \-f foo "from bill" .br hello world from bill .TP .B \-batch .RB Do not enter the command print loop. Useful if the other command line arguments do something. Do not print the License and acknowledgement information. Note if your program does print any License information, it must print the GCL header information also. .TP .B \-dir .RB Directory where the executable binary that is running is located. Needed by save and friends. This gets set as si::*system\-directory* .TP .B \-libdir .RB .BR \-libdir .I /d/wfs/gcl\-2.0/ .RB would mean that the files like gcl\-tk/tk.o would be found by concatting the path to the libdir path, ie in .RB /d/wfs/gcl\-2.0/gcl\-tk/tk.o .TP .B \-compile .RB Invoke the compiler on the filename following .BR \-compile . Other flags affect compilation. .TP .B \-o\-file .RB If nil follows .BR \-o\-file then do not produce an .I .o file. .TP .B \-c\-file .RB If .BR \-c\-file is specified, leave the intermediate .I .c file there. .TP .B \-h\-file .RB If .BR \-h\-file is specified, leave the intermediate .I .h file there. .TP .B \-data\-file .RB If .BR \-data\-file is specified, leave the intermediate .I .data file there. .TP .B \-system\-p .RB If .BR \-system\-p is specified then invoke .I compile\-file with the .I :system\-p t keyword argument, meaning that the C init function will bear a name based on the name of the file, so that it may be invoked by name by C code. This GNU package should not be confused with the proprietary program distributed by FRANZ, Inc. Nor should it be confused with any public domain or proprietary lisp system. For anything other than program development, use of the lisp compiler is strongly recommended in preference to use of the interpreter, due to much higher speed. .\".LP .\"This program may be used in conjunction with the UCSF .\".I batchqueue .\"system. .\".SH "LOCAL ACCESS" .\"Locally, access to all LISP systems is made through a shared .\"interactive front\-end which assumes that the job is be run in batch mode .\"unless the \fB\-i\fP option is activated, which starts an interactive session. .\"Interactive sessions are limited to 30 cpu minutes. .SH FILES .TP \fI/usr/bin/gcl executable shell script wrapper .TP \fI/usr/lib/gcl\-version/unixport/saved[_flavor]_gcl executable lisp images .SH "SEE ALSO" .sp \fICommon LISP: The Language\fP, Guy L. Steele, Jr., Digital Press, Bedford, MA, 1984. .sp \fICommon LISPcraft\fP, Robert Wilensky, W. W. Norton & Co., New York, 1984. .SH AUTHORS The GCL system contains C and Lisp source files to build a Common Lisp system. CGL is derived from Kyoto Common LISP (\fIkcl\fP), which was written in 1984 by T. Yuasa and M. Hagiya (working under Professor R. Nakajima at the Research Institute for Mathematical Sciences, Kyoto University). The AKCL system work was begun in 1987 by William Schelter at the University of Texas, Austin, and continued through 1994. In 1994 AKCL was released as GCL (GNU Common Lisp) under the GNU public library license. .\" gcl-2.6.14/faq0000755000175000017500000000505214360276512011472 0ustar cammcamm october 22, 1995 =============== Question: On my dec alpha-osf1 and irix 5 can i save an image with compiled functions? Answer: These two systems use the o/fasldlsym.c module, which uses the system call dl_open to do the loading of object files, from dynamic libraries. While this provides fast loading of .o files into a running image we do not know where those objects are located, or how to save an image once they are loaded. So in short the answer is NO, not at the moment.. These unixes no longer support the simple old 'ld -A' option which let one build a .o and read it into memory where one wanted. If you have a large system with a lot of preinitialization code, you COULD build an image in the same manner the actual lisp itself is built. Ie essentially add more files to the main link. si::save-system does work, it just wont work after you dynamically load in .o files. I do this for the build of maxima (in version >= maxima-5.1). Look at the files maxima-5.1/src/{makefile,sysinit.lsp}. Basically you need to compile your files with the :system-p t flag, so that an init function for each file based on the file name is produced. Then you have to arrange for those init functions to be called at startup, then you save as is done in building the lisp. ============= Question: Are tcl 7.4 and tk 4.0 compatible with gcl 2.2. Answer: Not really. Some things will work but others wont. The demos in the demos directory certainly wont all work, they are based on tk 3.6. They presumably could be rewritten based on their newer counterparts. I do not know of what other changes are necessary... In some sense the separation between gcl and tcl/tk is fairly complete so in PRINCIPLE the changes required should only be those to user code, caused by changes to the tk library. One would need to add perhaps some new calls to def-widget, eg in tkl.lisp adding (def-widget listbox) if 'listbox' were a new widget type. (def-control send) (def-control raise) if 'send' or 'control' were new functions.. Also one should update the gcl-tk info stuff from the using gcl-2.2/elisp/man1-to-texi.el you can also use You can use gcl-2.2/gcl-tk/convert.el as a start on using emacs to convert other (tcl/tk 4.0) code to lisp, to have their new demos in lisp for testing purposes. ============ Question: Is there a port to mach 10 on the mac. Answer: Not yet. This would be good.. Emacs is ported there. I dont know if it saves itself however...i had heard it does not. I believe they are using the macintosh native executable format.... =========== gcl-2.6.14/ltmain.sh0000644000175000017500000046150014360276512012621 0ustar cammcamm# ltmain.sh - Provide generalized library-building support services. # NOTE: Changing this file will not affect anything until you rerun ltconfig. # # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 # Free Software Foundation, Inc. # Originally by Gordon Matzigkeit , 1996 # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Check that we have a working $echo. if test "X$1" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test "X$1" = X--fallback-echo; then # Avoid inline document here, it may be left over : elif test "X`($echo '\t') 2>/dev/null`" = 'X\t'; then # Yippee, $echo works! : else # Restart under the correct shell, and then maybe $echo will work. exec $SHELL "$0" --no-reexec ${1+"$@"} fi if test "X$1" = X--fallback-echo; then # used as fallback echo shift cat <&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 fi if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then echo "$modename: not configured to build any kind of library" 1>&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 fi # Global variables. mode=$default_mode nonopt= prev= prevopt= run= show="$echo" show_help= execute_dlfiles= lo2o="s/\\.lo\$/.${objext}/" o2lo="s/\\.${objext}\$/.lo/" taglist= # Parse our command line options once, thoroughly. while test $# -gt 0 do arg="$1" shift case $arg in -*=*) optarg=`$echo "X$arg" | $Xsed -e 's/[-_a-zA-Z0-9]*=//'` ;; *) optarg= ;; esac # If the previous option needs an argument, assign it. if test -n "$prev"; then case $prev in execute_dlfiles) execute_dlfiles="$execute_dlfiles $arg" ;; tag) tagname="$arg" # Check whether tagname contains only valid characters case $tagname in *[!-_A-Za-z0-9,/]*) echo "$progname: invalid tag name: $tagname" 1>&2 exit 1 ;; esac case $tagname in CC) # Don't test for the "default" C tag, as we know, it's there, but # not specially marked. taglist="$taglist $tagname" ;; *) if grep "^### BEGIN LIBTOOL TAG CONFIG: $tagname$" < "$0" > /dev/null; then taglist="$taglist $tagname" # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$tagname'$/,/^### END LIBTOOL TAG CONFIG: '$tagname'$/p' < $0`" else echo "$progname: ignoring unknown tag $tagname" 1>&2 fi ;; esac ;; *) eval "$prev=\$arg" ;; esac prev= prevopt= continue fi # Have we seen a non-optional argument yet? case $arg in --help) show_help=yes ;; --version) echo "$PROGRAM (GNU $PACKAGE) $VERSION$TIMESTAMP" exit 0 ;; --config) sed -n -e '/^### BEGIN LIBTOOL CONFIG/,/^### END LIBTOOL CONFIG/p' < "$0" # Now print the configurations for the tags. for tagname in $taglist; do sed -n -e "/^### BEGIN LIBTOOL TAG CONFIG: $tagname$/,/^### END LIBTOOL TAG CONFIG: $tagname$/p" < "$0" done exit 0 ;; --debug) echo "$progname: enabling shell trace mode" set -x ;; --dry-run | -n) run=: ;; --features) echo "host: $host" if test "$build_libtool_libs" = yes; then echo "enable shared libraries" else echo "disable shared libraries" fi if test "$build_old_libs" = yes; then echo "enable static libraries" else echo "disable static libraries" fi exit 0 ;; --finish) mode="finish" ;; --mode) prevopt="--mode" prev=mode ;; --mode=*) mode="$optarg" ;; --quiet | --silent) show=: ;; --tag) prevopt="--tag" prev=tag ;; --tag=*) set tag "$optarg" ${1+"$@"} shift prev=tag ;; -dlopen) prevopt="-dlopen" prev=execute_dlfiles ;; -*) $echo "$modename: unrecognized option \`$arg'" 1>&2 $echo "$help" 1>&2 exit 1 ;; *) nonopt="$arg" break ;; esac done if test -n "$prevopt"; then $echo "$modename: option \`$prevopt' requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi # If this variable is set in any of the actions, the command in it # will be execed at the end. This prevents here-documents from being # left over by shells. exec_cmd= if test -z "$show_help"; then # Infer the operation mode. if test -z "$mode"; then case $nonopt in *cc | *++ | gcc* | *-gcc*) mode=link for arg do case $arg in -c) mode=compile break ;; esac done ;; *db | *dbx | *strace | *truss) mode=execute ;; *install*|cp|mv) mode=install ;; *rm) mode=uninstall ;; *) # If we have no mode, but dlfiles were specified, then do execute mode. test -n "$execute_dlfiles" && mode=execute # Just use the default operation mode. if test -z "$mode"; then if test -n "$nonopt"; then $echo "$modename: warning: cannot infer operation mode from \`$nonopt'" 1>&2 else $echo "$modename: warning: cannot infer operation mode without MODE-ARGS" 1>&2 fi fi ;; esac fi # Only execute mode is allowed to have -dlopen flags. if test -n "$execute_dlfiles" && test "$mode" != execute; then $echo "$modename: unrecognized option \`-dlopen'" 1>&2 $echo "$help" 1>&2 exit 1 fi # Change the help message to a mode-specific one. generic_help="$help" help="Try \`$modename --help --mode=$mode' for more information." # These modes are in order of execution frequency so that they run quickly. case $mode in # libtool compile mode compile) modename="$modename: compile" # Get the compilation command and the source file. base_compile= prev= lastarg= srcfile="$nonopt" suppress_output= user_target=no for arg do case $prev in "") ;; xcompiler) # Aesthetically quote the previous argument. prev= lastarg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac # Add the previous argument to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi continue ;; esac # Accept any command-line options. case $arg in -o) if test "$user_target" != "no"; then $echo "$modename: you cannot specify \`-o' more than once" 1>&2 exit 1 fi user_target=next ;; -static) build_old_libs=yes continue ;; -prefer-pic) pic_mode=yes continue ;; -prefer-non-pic) pic_mode=no continue ;; -Xcompiler) prev=xcompiler continue ;; -Wc,*) args=`$echo "X$arg" | $Xsed -e "s/^-Wc,//"` lastarg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for arg in $args; do IFS="$save_ifs" # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac lastarg="$lastarg $arg" done IFS="$save_ifs" lastarg=`$echo "X$lastarg" | $Xsed -e "s/^ //"` # Add the arguments to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi continue ;; esac case $user_target in next) # The next one is the -o target name user_target=yes continue ;; yes) # We got the output file user_target=set libobj="$arg" continue ;; esac # Accept the current argument as the source file. lastarg="$srcfile" srcfile="$arg" # Aesthetically quote the previous argument. # Backslashify any backslashes, double quotes, and dollar signs. # These are the only characters that are still specially # interpreted inside of double-quoted scrings. lastarg=`$echo "X$lastarg" | $Xsed -e "$sed_quote_subst"` # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. case $lastarg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") lastarg="\"$lastarg\"" ;; esac # Add the previous argument to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi done case $user_target in set) ;; no) # Get the name of the library object. libobj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%'` ;; *) $echo "$modename: you must specify a target with \`-o'" 1>&2 exit 1 ;; esac # Recognize several different file suffixes. # If the user specifies -o file.o, it is replaced with file.lo xform='[cCFSfmso]' case $libobj in *.ada) xform=ada ;; *.adb) xform=adb ;; *.ads) xform=ads ;; *.asm) xform=asm ;; *.c++) xform=c++ ;; *.cc) xform=cc ;; *.class) xform=class ;; *.cpp) xform=cpp ;; *.cxx) xform=cxx ;; *.f90) xform=f90 ;; *.for) xform=for ;; *.java) xform=java ;; esac libobj=`$echo "X$libobj" | $Xsed -e "s/\.$xform$/.lo/"` case $libobj in *.lo) obj=`$echo "X$libobj" | $Xsed -e "$lo2o"` ;; *) $echo "$modename: cannot determine name of library object from \`$libobj'" 1>&2 exit 1 ;; esac # Infer tagged configuration to use if any are available and # if one wasn't chosen via the "--tag" command line option. # Only attempt this if the compiler in the base compile # command doesn't match the default compiler. if test -n "$available_tags" && test -z "$tagname"; then case $base_compile in "$CC "*) ;; # Blanks in the command may have been stripped by the calling shell, # but not from the CC environment variable when ltconfig was run. "`$echo $CC` "*) ;; *) for z in $available_tags; do if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" case $base_compile in "$CC "*) # The compiler in the base compile command matches # the one in the tagged configuration. # Assume this is the tagged configuration we want. tagname=$z break ;; "`$echo $CC` "*) tagname=$z break ;; esac fi done # If $tagname still isn't set, then no tagged configuration # was found and let the user know that the "--tag" command # line option must be used. if test -z "$tagname"; then echo "$modename: unable to infer tagged configuration" echo "$modename: specify a tag with \`--tag'" 1>&2 exit 1 # else # echo "$modename: using $tagname tagged configuration" fi ;; esac fi objname=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$obj"; then xdir= else xdir=$xdir/ fi lobj=${xdir}$objdir/$objname if test -z "$base_compile"; then $echo "$modename: you must specify a compilation command" 1>&2 $echo "$help" 1>&2 exit 1 fi # Delete any leftover library objects. if test "$build_old_libs" = yes; then removelist="$obj $lobj $libobj ${libobj}T" else removelist="$lobj $libobj ${libobj}T" fi $run $rm $removelist trap "$run $rm $removelist; exit 1" 1 2 15 # On Cygwin there's no "real" PIC flag so we must build both object types case $host_os in cygwin* | mingw* | pw32* | os2*) pic_mode=default ;; esac if test $pic_mode = no && test "$deplibs_check_method" != pass_all; then # non-PIC code in shared libraries is not supported pic_mode=default fi # Calculate the filename of the output object if compiler does # not support -o with -c if test "$compiler_c_o" = no; then output_obj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%' -e 's%\.[^.]*$%%'`.${objext} lockfile="$output_obj.lock" removelist="$removelist $output_obj $lockfile" trap "$run $rm $removelist; exit 1" 1 2 15 else output_obj= need_locks=no lockfile= fi # Lock this critical section if it is needed # We use this script file to make the link, it avoids creating a new file if test "$need_locks" = yes; then until $run ln "$0" "$lockfile" 2>/dev/null; do $show "Waiting for $lockfile to be removed" sleep 2 done elif test "$need_locks" = warn; then if test -f "$lockfile"; then echo "\ *** ERROR, $lockfile exists and contains: `cat $lockfile 2>/dev/null` This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi echo $srcfile > "$lockfile" fi if test -n "$fix_srcfile_path"; then eval srcfile=\"$fix_srcfile_path\" fi $run $rm "$libobj" "${libobj}T" # Create a libtool object file (analogous to a ".la" file), # but don't create it if we're doing a dry run. test -z "$run" && cat > ${libobj}T </dev/null`" != x"$srcfile"; then echo "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi # Just move the object if needed, then go on to compile the next one if test -n "$output_obj" && test "x$output_obj" != "x$lobj"; then $show "$mv $output_obj $lobj" if $run $mv $output_obj $lobj; then : else error=$? $run $rm $removelist exit $error fi fi # Append the name of the PIC object to the libtool object file. test -z "$run" && cat >> ${libobj}T <> ${libobj}T </dev/null`" != x"$srcfile"; then echo "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi # Just move the object if needed if test -n "$output_obj" && test "x$output_obj" != "x$obj"; then $show "$mv $output_obj $obj" if $run $mv $output_obj $obj; then : else error=$? $run $rm $removelist exit $error fi fi # Append the name of the non-PIC object the libtool object file. # Only append if the libtool object file exists. test -z "$run" && cat >> ${libobj}T <> ${libobj}T <&2 fi if test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi else if test -z "$pic_flag" && test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi fi build_libtool_libs=no build_old_libs=yes prefer_static_libs=yes break ;; esac done # See if our shared archives depend on static archives. test -n "$old_archive_from_new_cmds" && build_old_libs=yes # Go through the arguments, transforming them on the way. while test $# -gt 0; do arg="$1" base_compile="$base_compile $arg" shift case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") qarg=\"`$echo "X$arg" | $Xsed -e "$sed_quote_subst"`\" ### testsuite: skip nested quoting test ;; *) qarg=$arg ;; esac libtool_args="$libtool_args $qarg" # If the previous option needs an argument, assign it. if test -n "$prev"; then case $prev in output) compile_command="$compile_command @OUTPUT@" finalize_command="$finalize_command @OUTPUT@" ;; esac case $prev in dlfiles|dlprefiles) if test "$preload" = no; then # Add the symbol object into the linking commands. compile_command="$compile_command @SYMFILE@" finalize_command="$finalize_command @SYMFILE@" preload=yes fi case $arg in *.la | *.lo) ;; # We handle these cases below. force) if test "$dlself" = no; then dlself=needless export_dynamic=yes fi prev= continue ;; self) if test "$prev" = dlprefiles; then dlself=yes elif test "$prev" = dlfiles && test "$dlopen_self" != yes; then dlself=yes else dlself=needless export_dynamic=yes fi prev= continue ;; *) if test "$prev" = dlfiles; then dlfiles="$dlfiles $arg" else dlprefiles="$dlprefiles $arg" fi prev= continue ;; esac ;; expsyms) export_symbols="$arg" if test ! -f "$arg"; then $echo "$modename: symbol file \`$arg' does not exist" exit 1 fi prev= continue ;; expsyms_regex) export_symbols_regex="$arg" prev= continue ;; release) release="-$arg" prev= continue ;; objectlist) if test -f "$arg"; then save_arg=$arg moreargs= for fil in `cat $save_arg` do # moreargs="$moreargs $fil" arg=$fil # A libtool-controlled object. # Check to see that this really is a libtool object. if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then pic_object= non_pic_object= # Read the .lo file # If there is no directory component, then add one. case $arg in */* | *\\*) . $arg ;; *) . ./$arg ;; esac if test -z "$pic_object" || \ test -z "$non_pic_object" || test "$pic_object" = none && \ test "$non_pic_object" = none; then $echo "$modename: cannot find name of object for \`$arg'" 1>&2 exit 1 fi # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. libobjs="$libobjs $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object non_pic_objects="$non_pic_objects $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi fi else # Only an error if not doing a dry-run. if test -z "$run"; then $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 exit 1 else # Dry-run case. # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` libobjs="$libobjs $pic_object" non_pic_objects="$non_pic_objects $non_pic_object" fi fi done else $echo "$modename: link input file \`$save_arg' does not exist" exit 1 fi arg=$save_arg prev= continue ;; rpath | xrpath) # We need an absolute path. case $arg in [\\/]* | [A-Za-z]:[\\/]*) ;; *) $echo "$modename: only absolute run-paths are allowed" 1>&2 exit 1 ;; esac if test "$prev" = rpath; then case "$rpath " in *" $arg "*) ;; *) rpath="$rpath $arg" ;; esac else case "$xrpath " in *" $arg "*) ;; *) xrpath="$xrpath $arg" ;; esac fi prev= continue ;; xcompiler) compiler_flags="$compiler_flags $qarg" prev= compile_command="$compile_command $qarg" finalize_command="$finalize_command $qarg" continue ;; xlinker) linker_flags="$linker_flags $qarg" compiler_flags="$compiler_flags $wl$qarg" prev= compile_command="$compile_command $wl$qarg" finalize_command="$finalize_command $wl$qarg" continue ;; *) eval "$prev=\"\$arg\"" prev= continue ;; esac fi # test -n $prev prevarg="$arg" case $arg in -all-static) if test -n "$link_static_flag"; then compile_command="$compile_command $link_static_flag" finalize_command="$finalize_command $link_static_flag" fi continue ;; -allow-undefined) # FIXME: remove this flag sometime in the future. $echo "$modename: \`-allow-undefined' is deprecated because it is the default" 1>&2 continue ;; -avoid-version) avoid_version=yes continue ;; -dlopen) prev=dlfiles continue ;; -dlpreopen) prev=dlprefiles continue ;; -export-dynamic) export_dynamic=yes continue ;; -export-symbols | -export-symbols-regex) if test -n "$export_symbols" || test -n "$export_symbols_regex"; then $echo "$modename: more than one -exported-symbols argument is not allowed" exit 1 fi if test "X$arg" = "X-export-symbols"; then prev=expsyms else prev=expsyms_regex fi continue ;; # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:* # so, if we see these flags be careful not to treat them like -L -L[A-Z][A-Z]*:*) case $with_gcc/$host in no/*-*-irix*) compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" ;; esac continue ;; -L*) dir=`$echo "X$arg" | $Xsed -e 's/^-L//'` # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) absdir=`cd "$dir" && pwd` if test -z "$absdir"; then $echo "$modename: cannot determine absolute directory name of \`$dir'" 1>&2 exit 1 fi dir="$absdir" ;; esac case "$deplibs " in *" -L$dir "*) ;; *) deplibs="$deplibs -L$dir" lib_search_path="$lib_search_path $dir" ;; esac case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) case :$dllsearchpath: in *":$dir:"*) ;; *) dllsearchpath="$dllsearchpath:$dir";; esac ;; esac continue ;; -l*) if test "X$arg" = "X-lc" || test "X$arg" = "X-lm"; then case $host in *-*-cygwin* | *-*-pw32* | *-*-beos*) # These systems don't actually have a C or math library (as such) continue ;; *-*-mingw* | *-*-os2*) # These systems don't actually have a C library (as such) test "X$arg" = "X-lc" && continue ;; esac fi deplibs="$deplibs $arg" continue ;; -module) module=yes continue ;; -no-fast-install) fast_install=no continue ;; -no-install) case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) # The PATH hackery in wrapper scripts is required on Windows # in order for the loader to find any dlls it needs. $echo "$modename: warning: \`-no-install' is ignored for $host" 1>&2 $echo "$modename: warning: assuming \`-no-fast-install' instead" 1>&2 fast_install=no ;; *) no_install=yes ;; esac continue ;; -no-undefined) allow_undefined=no continue ;; -objectlist) prev=objectlist continue ;; -o) prev=output ;; -release) prev=release continue ;; -rpath) prev=rpath continue ;; -R) prev=xrpath continue ;; -R*) dir=`$echo "X$arg" | $Xsed -e 's/^-R//'` # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) $echo "$modename: only absolute run-paths are allowed" 1>&2 exit 1 ;; esac case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac continue ;; -static) # The effects of -static are defined in a previous loop. # We used to do the same as -all-static on platforms that # didn't have a PIC flag, but the assumption that the effects # would be equivalent was wrong. It would break on at least # Digital Unix and AIX. continue ;; -thread-safe) thread_safe=yes continue ;; -version-info) prev=vinfo continue ;; -Wc,*) args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wc,//'` arg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" case $flag in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") flag="\"$flag\"" ;; esac arg="$arg $wl$flag" compiler_flags="$compiler_flags $flag" done IFS="$save_ifs" arg=`$echo "X$arg" | $Xsed -e "s/^ //"` ;; -Wl,*) args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wl,//'` arg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" case $flag in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") flag="\"$flag\"" ;; esac arg="$arg $wl$flag" compiler_flags="$compiler_flags $wl$flag" linker_flags="$linker_flags $flag" done IFS="$save_ifs" arg=`$echo "X$arg" | $Xsed -e "s/^ //"` ;; -Xcompiler) prev=xcompiler continue ;; -Xlinker) prev=xlinker continue ;; # Some other compiler flag. -* | +*) # Unknown arguments in both finalize_command and compile_command need # to be aesthetically quoted because they are evaled later. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac ;; *.$objext) # A standard object. objs="$objs $arg" ;; *.lo) # A libtool-controlled object. # Check to see that this really is a libtool object. if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then pic_object= non_pic_object= # Read the .lo file # If there is no directory component, then add one. case $arg in */* | *\\*) . $arg ;; *) . ./$arg ;; esac if test -z "$pic_object" || \ test -z "$non_pic_object" || test "$pic_object" = none && \ test "$non_pic_object" = none; then $echo "$modename: cannot find name of object for \`$arg'" 1>&2 exit 1 fi # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. libobjs="$libobjs $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object non_pic_objects="$non_pic_objects $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi fi else # Only an error if not doing a dry-run. if test -z "$run"; then $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 exit 1 else # Dry-run case. # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` libobjs="$libobjs $pic_object" non_pic_objects="$non_pic_objects $non_pic_object" fi fi ;; *.$libext) # An archive. deplibs="$deplibs $arg" old_deplibs="$old_deplibs $arg" continue ;; *.la) # A libtool-controlled library. if test "$prev" = dlfiles; then # This library was specified with -dlopen. dlfiles="$dlfiles $arg" prev= elif test "$prev" = dlprefiles; then # The library was specified with -dlpreopen. dlprefiles="$dlprefiles $arg" prev= else deplibs="$deplibs $arg" fi continue ;; # Some other compiler argument. *) # Unknown arguments in both finalize_command and compile_command need # to be aesthetically quoted because they are evaled later. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac ;; esac # arg # Now actually substitute the argument into the commands. if test -n "$arg"; then compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" fi done # argument parsing loop if test -n "$prev"; then $echo "$modename: the \`$prevarg' option requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi # Infer tagged configuration to use if any are available and # if one wasn't chosen via the "--tag" command line option. # Only attempt this if the compiler in the base link # command doesn't match the default compiler. if test -n "$available_tags" && test -z "$tagname"; then case $base_compile in "$CC "*) ;; # Blanks in the command may have been stripped by the calling shell, # but not from the CC environment variable when ltconfig was run. "`$echo $CC` "*) ;; *) for z in $available_tags; do if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" case $base_compile in "$CC "*) # The compiler in $compile_command matches # the one in the tagged configuration. # Assume this is the tagged configuration we want. tagname=$z break ;; "`$echo $CC` "*) tagname=$z break ;; esac fi done # If $tagname still isn't set, then no tagged configuration # was found and let the user know that the "--tag" command # line option must be used. if test -z "$tagname"; then echo "$modename: unable to infer tagged configuration" echo "$modename: specify a tag with \`--tag'" 1>&2 exit 1 # else # echo "$modename: using $tagname tagged configuration" fi ;; esac fi if test "$export_dynamic" = yes && test -n "$export_dynamic_flag_spec"; then eval arg=\"$export_dynamic_flag_spec\" compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" fi # calculate the name of the file, without its directory outputname=`$echo "X$output" | $Xsed -e 's%^.*/%%'` libobjs_save="$libobjs" if test -n "$shlibpath_var"; then # get the directories listed in $shlibpath_var eval shlib_search_path=\`\$echo \"X\${$shlibpath_var}\" \| \$Xsed -e \'s/:/ /g\'\` else shlib_search_path= fi eval sys_lib_search_path=\"$sys_lib_search_path_spec\" eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\" output_objdir=`$echo "X$output" | $Xsed -e 's%/[^/]*$%%'` if test "X$output_objdir" = "X$output"; then output_objdir="$objdir" else output_objdir="$output_objdir/$objdir" fi # Create the object directory. if test ! -d $output_objdir; then $show "$mkdir $output_objdir" $run $mkdir $output_objdir status=$? if test $status -ne 0 && test ! -d $output_objdir; then exit $status fi fi # Determine the type of output case $output in "") $echo "$modename: you must specify an output file" 1>&2 $echo "$help" 1>&2 exit 1 ;; *.$libext) linkmode=oldlib ;; *.lo | *.$objext) linkmode=obj ;; *.la) linkmode=lib ;; *) linkmode=prog ;; # Anything else should be a program. esac specialdeplibs= libs= # Find all interdependent deplibs by searching for libraries # that are linked more than once (e.g. -la -lb -la) for deplib in $deplibs; do case "$libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac libs="$libs $deplib" done if test $linkmode = lib; then libs="$predeps $libs $compiler_lib_search_path $postdeps" # Compute libraries that are listed more than once in $predeps # $postdeps and mark them as special (i.e., whose duplicates are # not to be eliminated). pre_post_deps= for pre_post_dep in $predeps $postdeps; do case "$pre_post_deps " in *" $pre_post_dep "*) specialdeplibs="$specialdeplibs $pre_post_deps" ;; esac pre_post_deps="$pre_post_deps $pre_post_dep" done pre_post_deps= fi deplibs= newdependency_libs= newlib_search_path= need_relink=no # whether we're linking any uninstalled libtool libraries notinst_deplibs= # not-installed libtool libraries notinst_path= # paths that contain not-installed libtool libraries case $linkmode in lib) passes="conv link" for file in $dlfiles $dlprefiles; do case $file in *.la) ;; *) $echo "$modename: libraries can \`-dlopen' only libtool libraries: $file" 1>&2 exit 1 ;; esac done ;; prog) compile_deplibs= finalize_deplibs= alldeplibs=no newdlfiles= newdlprefiles= passes="conv scan dlopen dlpreopen link" ;; *) passes="conv" ;; esac for pass in $passes; do if test $linkmode = prog; then # Determine which files to process case $pass in dlopen) libs="$dlfiles" save_deplibs="$deplibs" # Collect dlpreopened libraries deplibs= ;; dlpreopen) libs="$dlprefiles" ;; link) libs="$deplibs %DEPLIBS% $dependency_libs" ;; esac fi for deplib in $libs; do lib= found=no case $deplib in -l*) if test $linkmode = oldlib && test $linkmode = obj; then $echo "$modename: warning: \`-l' is ignored for archives/objects: $deplib" 1>&2 continue fi if test $pass = conv; then deplibs="$deplib $deplibs" continue fi name=`$echo "X$deplib" | $Xsed -e 's/^-l//'` for searchdir in $newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path; do # Search the libtool library lib="$searchdir/lib${name}.la" if test -f "$lib"; then found=yes break fi done if test "$found" != yes; then # deplib doesn't seem to be a libtool library if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else deplibs="$deplib $deplibs" test $linkmode = lib && newdependency_libs="$deplib $newdependency_libs" fi continue fi ;; # -l -L*) case $linkmode in lib) deplibs="$deplib $deplibs" test $pass = conv && continue newdependency_libs="$deplib $newdependency_libs" newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` ;; prog) if test $pass = conv; then deplibs="$deplib $deplibs" continue fi if test $pass = scan; then deplibs="$deplib $deplibs" newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi ;; *) $echo "$modename: warning: \`-L' is ignored for archives/objects: $deplib" 1>&2 ;; esac # linkmode continue ;; # -L -R*) if test $pass = link; then dir=`$echo "X$deplib" | $Xsed -e 's/^-R//'` # Make sure the xrpath contains only unique directories. case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac fi deplibs="$deplib $deplibs" continue ;; *.la) lib="$deplib" ;; *.$libext) if test $pass = conv; then deplibs="$deplib $deplibs" continue fi case $linkmode in lib) if test "$deplibs_check_method" != pass_all; then echo echo "*** Warning: This library needs some functionality provided by $deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." else echo echo "*** Warning: Linking the shared library $output against the" echo "*** static library $deplib is not portable!" deplibs="$deplib $deplibs" fi continue ;; prog) if test $pass != link; then deplibs="$deplib $deplibs" else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi continue ;; esac # linkmode ;; # *.$libext *.lo | *.$objext) if test $pass = dlpreopen || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlopen support or we're linking statically, # we need to preload. newdlprefiles="$newdlprefiles $deplib" compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else newdlfiles="$newdlfiles $deplib" fi continue ;; %DEPLIBS%) alldeplibs=yes continue ;; esac # case $deplib if test $found = yes || test -f "$lib"; then : else $echo "$modename: cannot find the library \`$lib'" 1>&2 exit 1 fi # Check to see that this really is a libtool archive. if (sed -e '2q' $lib | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi ladir=`$echo "X$lib" | $Xsed -e 's%/[^/]*$%%'` test "X$ladir" = "X$lib" && ladir="." dlname= dlopen= dlpreopen= libdir= library_names= old_library= # If the library was installed with an old release of libtool, # it will not redefine variable installed. installed=yes # Read the .la file case $lib in */* | *\\*) . $lib ;; *) . ./$lib ;; esac if test "$linkmode,$pass" = "lib,link" || test "$linkmode,$pass" = "prog,scan" || { test $linkmode = oldlib && test $linkmode = obj; }; then # Add dl[pre]opened files of deplib test -n "$dlopen" && dlfiles="$dlfiles $dlopen" test -n "$dlpreopen" && dlprefiles="$dlprefiles $dlpreopen" fi if test $pass = conv; then # Only check for convenience libraries deplibs="$lib $deplibs" if test -z "$libdir"; then if test -z "$old_library"; then $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 exit 1 fi # It is a libtool convenience library, so add in its objects. convenience="$convenience $ladir/$objdir/$old_library" old_convenience="$old_convenience $ladir/$objdir/$old_library" tmp_libs= for deplib in $dependency_libs; do deplibs="$deplib $deplibs" case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done elif test $linkmode != prog && test $linkmode != lib; then $echo "$modename: \`$lib' is not a convenience library" 1>&2 exit 1 fi continue fi # $pass = conv # Get the name of the library we link against. linklib= for l in $old_library $library_names; do linklib="$l" done if test -z "$linklib"; then $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 exit 1 fi # This library was specified with -dlopen. if test $pass = dlopen; then if test -z "$libdir"; then $echo "$modename: cannot -dlopen a convenience library: \`$lib'" 1>&2 exit 1 fi if test -z "$dlname" || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlname, no dlopen support or we're linking # statically, we need to preload. dlprefiles="$dlprefiles $lib" else newdlfiles="$newdlfiles $lib" fi continue fi # $pass = dlopen # We need an absolute path. case $ladir in [\\/]* | [A-Za-z]:[\\/]*) abs_ladir="$ladir" ;; *) abs_ladir=`cd "$ladir" && pwd` if test -z "$abs_ladir"; then $echo "$modename: warning: cannot determine absolute directory name of \`$ladir'" 1>&2 $echo "$modename: passing it literally to the linker, although it might fail" 1>&2 abs_ladir="$ladir" fi ;; esac laname=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` # Find the relevant object directory and library name. if test "X$installed" = Xyes; then if test ! -f "$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then $echo "$modename: warning: library \`$lib' was moved." 1>&2 dir="$ladir" absdir="$abs_ladir" libdir="$abs_ladir" else dir="$libdir" absdir="$libdir" fi else dir="$ladir/$objdir" absdir="$abs_ladir/$objdir" # Remove this search path later notinst_path="$notinst_path $abs_ladir" fi # $installed = yes name=`$echo "X$laname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` # This library was specified with -dlpreopen. if test $pass = dlpreopen; then if test -z "$libdir"; then $echo "$modename: cannot -dlpreopen a convenience library: \`$lib'" 1>&2 exit 1 fi # Prefer using a static library (so that no silly _DYNAMIC symbols # are required to link). if test -n "$old_library"; then newdlprefiles="$newdlprefiles $dir/$old_library" # Otherwise, use the dlname, so that lt_dlopen finds it. elif test -n "$dlname"; then newdlprefiles="$newdlprefiles $dir/$dlname" else newdlprefiles="$newdlprefiles $dir/$linklib" fi fi # $pass = dlpreopen if test -z "$libdir"; then # Link the convenience library if test $linkmode = lib; then deplibs="$dir/$old_library $deplibs" elif test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$dir/$old_library $compile_deplibs" finalize_deplibs="$dir/$old_library $finalize_deplibs" else deplibs="$lib $deplibs" fi continue fi if test $linkmode = prog && test $pass != link; then newlib_search_path="$newlib_search_path $ladir" deplibs="$lib $deplibs" linkalldeplibs=no if test "$link_all_deplibs" != no || test -z "$library_names" || test "$build_libtool_libs" = no; then linkalldeplibs=yes fi tmp_libs= for deplib in $dependency_libs; do case $deplib in -L*) newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'`;; ### testsuite: skip nested quoting test esac # Need to link against all dependency_libs? if test $linkalldeplibs = yes; then deplibs="$deplib $deplibs" else # Need to hardcode shared library paths # or/and link against static libraries newdependency_libs="$deplib $newdependency_libs" fi case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done # for deplib continue fi # $linkmode = prog... link_static=no # Whether the deplib will be linked statically if test -n "$library_names" && { test "$prefer_static_libs" = no || test -z "$old_library"; }; then # Link against this shared library if test "$linkmode,$pass" = "prog,link" || { test $linkmode = lib && test $hardcode_into_libs = yes; }; then # Hardcode the library path. # Skip directories that are in the system default run-time # search path. case " $sys_lib_dlsearch_path " in *" $absdir "*) ;; *) case "$compile_rpath " in *" $absdir "*) ;; *) compile_rpath="$compile_rpath $absdir" esac ;; esac case " $sys_lib_dlsearch_path " in *" $libdir "*) ;; *) case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" esac ;; esac if test $linkmode = prog; then # We need to hardcode the library path if test -n "$shlibpath_var"; then # Make sure the rpath contains only unique directories. case "$temp_rpath " in *" $dir "*) ;; *" $absdir "*) ;; *) temp_rpath="$temp_rpath $dir" ;; esac fi fi fi # $linkmode,$pass = prog,link... if test "$alldeplibs" = yes && { test "$deplibs_check_method" = pass_all || { test "$build_libtool_libs" = yes && test -n "$library_names"; }; }; then # We only need to search for static libraries continue fi if test "$installed" = no; then notinst_deplibs="$notinst_deplibs $lib" need_relink=yes fi if test -n "$old_archive_from_expsyms_cmds"; then # figure out the soname set dummy $library_names realname="$2" shift; shift libname=`eval \\$echo \"$libname_spec\"` # use dlname if we got it. it's perfectly good, no? if test -n "$dlname"; then soname="$dlname" elif test -n "$soname_spec"; then # bleh windows case $host in *cygwin*) major=`expr $current - $age` versuffix="-$major" ;; esac eval soname=\"$soname_spec\" else soname="$realname" fi # Make a new name for the extract_expsyms_cmds to use soroot="$soname" soname=`echo $soroot | sed -e 's/^.*\///'` newlib="libimp-`echo $soname | sed 's/^lib//;s/\.dll$//'`.a" # If the library has no export list, then create one now if test -f "$output_objdir/$soname-def"; then : else $show "extracting exported symbol list from \`$soname'" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' eval cmds=\"$extract_expsyms_cmds\" for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # Create $newlib if test -f "$output_objdir/$newlib"; then :; else $show "generating import library for \`$soname'" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' eval cmds=\"$old_archive_from_expsyms_cmds\" for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # make sure the library variables are pointing to the new library dir=$output_objdir linklib=$newlib fi # test -n $old_archive_from_expsyms_cmds if test $linkmode = prog || test "$mode" != relink; then add_shlibpath= add_dir= add= lib_linked=yes case $hardcode_action in immediate | unsupported) if test "$hardcode_direct" = no; then add="$dir/$linklib" elif test "$hardcode_minus_L" = no; then case $host in *-*-sunos*) add_shlibpath="$dir" ;; esac add_dir="-L$dir" add="-l$name" elif test "$hardcode_shlibpath_var" = no; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; relink) if test "$hardcode_direct" = yes; then add="$dir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$dir" add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; *) lib_linked=no ;; esac if test "$lib_linked" != yes; then $echo "$modename: configuration error: unsupported hardcode properties" exit 1 fi if test -n "$add_shlibpath"; then case :$compile_shlibpath: in *":$add_shlibpath:"*) ;; *) compile_shlibpath="$compile_shlibpath$add_shlibpath:" ;; esac fi if test $linkmode = prog; then test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs" test -n "$add" && compile_deplibs="$add $compile_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" if test "$hardcode_direct" != yes && \ test "$hardcode_minus_L" != yes && \ test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac fi fi fi if test $linkmode = prog || test "$mode" = relink; then add_shlibpath= add_dir= add= # Finalize command for both is simple: just hardcode it. if test "$hardcode_direct" = yes; then add="$libdir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$libdir" add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac add="-l$name" else # We cannot seem to hardcode it, guess we'll fake it. add_dir="-L$libdir" add="-l$name" fi if test $linkmode = prog; then test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs" test -n "$add" && finalize_deplibs="$add $finalize_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" fi fi elif test $linkmode = prog; then if test "$alldeplibs" = yes && { test "$deplibs_check_method" = pass_all || { test "$build_libtool_libs" = yes && test -n "$library_names"; }; }; then # We only need to search for static libraries continue fi # Try to link the static library # Here we assume that one of hardcode_direct or hardcode_minus_L # is not unsupported. This is valid on all known static and # shared platforms. if test "$hardcode_direct" != unsupported; then test -n "$old_library" && linklib="$old_library" compile_deplibs="$dir/$linklib $compile_deplibs" finalize_deplibs="$dir/$linklib $finalize_deplibs" else compile_deplibs="-l$name -L$dir $compile_deplibs" finalize_deplibs="-l$name -L$dir $finalize_deplibs" fi elif test "$build_libtool_libs" = yes; then # Not a shared library if test "$deplibs_check_method" != pass_all; then # We're trying link a shared library against a static one # but the system doesn't support it. # Just print a warning and add the library to dependency_libs so # that the program can be linked against the static library. echo echo "*** Warning: This library needs some functionality provided by $lib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." if test "$module" = yes; then echo "*** Therefore, libtool will create a static module, that should work " echo "*** as long as the dlopening application is linked with the -dlopen flag." if test -z "$global_symbol_pipe"; then echo echo "*** However, this would only work if libtool was able to extract symbol" echo "*** lists from a program, using \`nm' or equivalent, but libtool could" echo "*** not find such a program. So, this module is probably useless." echo "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi else convenience="$convenience $dir/$old_library" old_convenience="$old_convenience $dir/$old_library" deplibs="$dir/$old_library $deplibs" link_static=yes fi fi # link shared/static library? if test $linkmode = lib; then if test -n "$dependency_libs" && { test $hardcode_into_libs != yes || test $build_old_libs = yes || test $link_static = yes; }; then # Extract -R from dependency_libs temp_deplibs= for libdir in $dependency_libs; do case $libdir in -R*) temp_xrpath=`$echo "X$libdir" | $Xsed -e 's/^-R//'` case " $xrpath " in *" $temp_xrpath "*) ;; *) xrpath="$xrpath $temp_xrpath";; esac;; *) temp_deplibs="$temp_deplibs $libdir";; esac done dependency_libs="$temp_deplibs" fi newlib_search_path="$newlib_search_path $absdir" # Link against this library test "$link_static" = no && newdependency_libs="$abs_ladir/$laname $newdependency_libs" # ... and its dependency_libs tmp_libs= for deplib in $dependency_libs; do newdependency_libs="$deplib $newdependency_libs" case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done if test $link_all_deplibs != no; then # Add the search paths of all dependency libraries for deplib in $dependency_libs; do case $deplib in -L*) path="$deplib" ;; *.la) dir=`$echo "X$deplib" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$deplib" && dir="." # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) absdir="$dir" ;; *) absdir=`cd "$dir" && pwd` if test -z "$absdir"; then $echo "$modename: warning: cannot determine absolute directory name of \`$dir'" 1>&2 absdir="$dir" fi ;; esac if grep "^installed=no" $deplib > /dev/null; then path="-L$absdir/$objdir" else eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` if test -z "$libdir"; then $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 exit 1 fi if test "$absdir" != "$libdir"; then $echo "$modename: warning: \`$deplib' seems to be moved" 1>&2 fi path="-L$absdir" fi ;; *) continue ;; esac case " $deplibs " in *" $path "*) ;; *) deplibs="$path $deplibs" ;; esac done fi # link_all_deplibs != no fi # linkmode = lib done # for deplib in $libs if test $pass = dlpreopen; then # Link the dlpreopened libraries before other libraries for deplib in $save_deplibs; do deplibs="$deplib $deplibs" done fi if test $pass != dlopen; then test $pass != scan && dependency_libs="$newdependency_libs" if test $pass != conv; then # Make sure lib_search_path contains only unique directories. lib_search_path= for dir in $newlib_search_path; do case "$lib_search_path " in *" $dir "*) ;; *) lib_search_path="$lib_search_path $dir" ;; esac done newlib_search_path= fi if test "$linkmode,$pass" != "prog,link"; then vars="deplibs" else vars="compile_deplibs finalize_deplibs" fi for var in $vars dependency_libs; do # Add libraries to $var in reverse order eval tmp_libs=\"\$$var\" new_libs= for deplib in $tmp_libs; do case $deplib in -L*) new_libs="$deplib $new_libs" ;; *) case " $specialdeplibs " in *" $deplib "*) new_libs="$deplib $new_libs" ;; *) case " $new_libs " in *" $deplib "*) ;; *) new_libs="$deplib $new_libs" ;; esac ;; esac ;; esac done tmp_libs= for deplib in $new_libs; do case $deplib in -L*) case " $tmp_libs " in *" $deplib "*) ;; *) tmp_libs="$tmp_libs $deplib" ;; esac ;; *) tmp_libs="$tmp_libs $deplib" ;; esac done eval $var=\"$tmp_libs\" done # for var fi if test "$pass" = "conv" && { test "$linkmode" = "lib" || test "$linkmode" = "prog"; }; then libs="$deplibs" # reset libs deplibs= fi done # for pass if test $linkmode = prog; then dlfiles="$newdlfiles" dlprefiles="$newdlprefiles" fi case $linkmode in oldlib) if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then $echo "$modename: warning: \`-dlopen' is ignored for archives" 1>&2 fi if test -n "$rpath"; then $echo "$modename: warning: \`-rpath' is ignored for archives" 1>&2 fi if test -n "$xrpath"; then $echo "$modename: warning: \`-R' is ignored for archives" 1>&2 fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for archives" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for archives" 1>&2 fi if test -n "$export_symbols" || test -n "$export_symbols_regex"; then $echo "$modename: warning: \`-export-symbols' is ignored for archives" 1>&2 fi # Now set the variables for building old libraries. build_libtool_libs=no oldlibs="$output" objs="$objs$old_deplibs" ;; lib) # Make sure we only generate libraries of the form `libNAME.la'. case $outputname in lib*) name=`$echo "X$outputname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` eval libname=\"$libname_spec\" ;; *) if test "$module" = no; then $echo "$modename: libtool library \`$output' must begin with \`lib'" 1>&2 $echo "$help" 1>&2 exit 1 fi if test "$need_lib_prefix" != no; then # Add the "lib" prefix for modules if required name=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` eval libname=\"$libname_spec\" else libname=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` fi ;; esac if test -n "$objs"; then if test "$deplibs_check_method" != pass_all; then $echo "$modename: cannot build libtool library \`$output' from non-libtool objects on this host:$objs" 2>&1 exit 1 else echo echo "*** Warning: Linking the shared library $output against the non-libtool" echo "*** objects $objs is not portable!" libobjs="$libobjs $objs" fi fi if test "$dlself" != no; then $echo "$modename: warning: \`-dlopen self' is ignored for libtool libraries" 1>&2 fi set dummy $rpath if test $# -gt 2; then $echo "$modename: warning: ignoring multiple \`-rpath's for a libtool library" 1>&2 fi install_libdir="$2" oldlibs= if test -z "$rpath"; then if test "$build_libtool_libs" = yes; then # Building a libtool convenience library. # Some compilers have problems with a `.al' extension so # convenience libraries should have the same extension an # archive normally would. oldlibs="$output_objdir/$libname.$libext $oldlibs" build_libtool_libs=convenience build_old_libs=yes fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for convenience libraries" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for convenience libraries" 1>&2 fi else # Parse the version information argument. IFS="${IFS= }"; save_ifs="$IFS"; IFS=':' set dummy $vinfo 0 0 0 IFS="$save_ifs" if test -n "$8"; then $echo "$modename: too many parameters to \`-version-info'" 1>&2 $echo "$help" 1>&2 exit 1 fi current="$2" revision="$3" age="$4" # Check that each of the things are valid numbers. case $current in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: CURRENT \`$current' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac case $revision in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: REVISION \`$revision' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac case $age in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: AGE \`$age' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac if test $age -gt $current; then $echo "$modename: AGE \`$age' is greater than the current interface number \`$current'" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 fi # Calculate the version variables. major= versuffix= verstring= case $version_type in none) ;; darwin) # Like Linux, but with the current version available in # verstring for coding it into the library header major=.`expr $current - $age` versuffix="$major.$age.$revision" # Darwin ld doesn't like 0 for these options... minor_current=`expr $current + 1` verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" ;; freebsd-aout) major=".$current" versuffix=".$current.$revision"; ;; freebsd-elf) major=".$current" versuffix=".$current"; ;; irix) major=`expr $current - $age + 1` verstring="sgi$major.$revision" # Add in all the interfaces that we are compatible with. loop=$revision while test $loop != 0; do iface=`expr $revision - $loop` loop=`expr $loop - 1` verstring="sgi$major.$iface:$verstring" done # Before this point, $major must not contain `.'. major=.$major versuffix="$major.$revision" ;; linux) major=.`expr $current - $age` versuffix="$major.$age.$revision" ;; osf) major=`expr $current - $age` versuffix=".$current.$age.$revision" verstring="$current.$age.$revision" # Add in all the interfaces that we are compatible with. loop=$age while test $loop != 0; do iface=`expr $current - $loop` loop=`expr $loop - 1` verstring="$verstring:${iface}.0" done # Make executables depend on our current version. verstring="$verstring:${current}.0" ;; sunos) major=".$current" versuffix=".$current.$revision" ;; windows) # Use '-' rather than '.', since we only want one # extension on DOS 8.3 filesystems. major=`expr $current - $age` versuffix="-$major" ;; *) $echo "$modename: unknown library version type \`$version_type'" 1>&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 ;; esac # Clear the version info if we defaulted, and they specified a release. if test -z "$vinfo" && test -n "$release"; then major= verstring="0.0" if test "$need_version" = no; then versuffix= else versuffix=".0.0" fi fi # Remove version info from name if versioning should be avoided if test "$avoid_version" = yes && test "$need_version" = no; then major= versuffix= verstring="" fi # Check to see if the archive will have undefined symbols. if test "$allow_undefined" = yes; then if test "$allow_undefined_flag" = unsupported; then $echo "$modename: warning: undefined symbols not allowed in $host shared libraries" 1>&2 build_libtool_libs=no build_old_libs=yes fi else # Don't allow undefined symbols. allow_undefined_flag="$no_undefined_flag" fi fi if test "$mode" != relink; then # Remove our outputs, but don't remove object files since they # may have been created when compiling PIC objects. removelist= tempremovelist=`echo "$output_objdir/*"` for p in $tempremovelist; do case $p in *.$objext) ;; $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/${libname}${release}.*) removelist="$removelist $p" ;; *) ;; esac done if test -n "$removelist"; then $show "${rm}r $removelist" $run ${rm}r $removelist fi fi # Now set the variables for building old libraries. if test "$build_old_libs" = yes && test "$build_libtool_libs" != convenience ; then oldlibs="$oldlibs $output_objdir/$libname.$libext" # Transform .lo files to .o files. oldobjs="$objs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}'$/d' -e "$lo2o" | $NL2SP` fi # Eliminate all temporary directories. for path in $notinst_path; do lib_search_path=`echo "$lib_search_path " | sed -e 's% $path % %g'` deplibs=`echo "$deplibs " | sed -e 's% -L$path % %g'` dependency_libs=`echo "$dependency_libs " | sed -e 's% -L$path % %g'` done if test -n "$xrpath"; then # If the user specified any rpath flags, then add them. temp_xrpath= for libdir in $xrpath; do temp_xrpath="$temp_xrpath -R$libdir" case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done if test $hardcode_into_libs != yes || test $build_old_libs = yes; then dependency_libs="$temp_xrpath $dependency_libs" fi fi # Make sure dlfiles contains only unique files that won't be dlpreopened old_dlfiles="$dlfiles" dlfiles= for lib in $old_dlfiles; do case " $dlprefiles $dlfiles " in *" $lib "*) ;; *) dlfiles="$dlfiles $lib" ;; esac done # Make sure dlprefiles contains only unique files old_dlprefiles="$dlprefiles" dlprefiles= for lib in $old_dlprefiles; do case "$dlprefiles " in *" $lib "*) ;; *) dlprefiles="$dlprefiles $lib" ;; esac done if test "$build_libtool_libs" = yes; then if test -n "$rpath"; then case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos*) # these systems don't actually have a c library (as such)! ;; *-*-rhapsody* | *-*-darwin1.[012]) # Rhapsody C library is in the System framework deplibs="$deplibs -framework System" ;; *-*-netbsd*) # Don't link with libc until the a.out ld.so is fixed. ;; *) # Add libc to deplibs on all other systems if necessary. if test $build_libtool_need_lc = "yes"; then deplibs="$deplibs -lc" fi ;; esac fi # Transform deplibs into only deplibs that can be linked in shared. name_save=$name libname_save=$libname release_save=$release versuffix_save=$versuffix major_save=$major # I'm not sure if I'm treating the release correctly. I think # release should show up in the -l (ie -lgmp5) so we don't want to # add it in twice. Is that correct? release="" versuffix="" major="" newdeplibs= droppeddeps=no case $deplibs_check_method in pass_all) # Don't check for shared/static. Everything works. # This might be a little naive. We might want to check # whether the library exists or not. But this is on # osf3 & osf4 and I'm not really sure... Just # implementing what was already the behaviour. newdeplibs=$deplibs ;; test_compile) # This code stresses the "libraries are programs" paradigm to its # limits. Maybe even breaks it. We compile a program, linking it # against the deplibs as a proxy for the library. Then we can check # whether they linked in statically or dynamically with ldd. $rm conftest.c cat > conftest.c </dev/null` for potent_lib in $potential_libs; do # Follow soft links. if ls -lLd "$potent_lib" 2>/dev/null \ | grep " -> " >/dev/null; then continue fi # The statement above tries to avoid entering an # endless loop below, in case of cyclic links. # We might still enter an endless loop, since a link # loop can be closed while we follow links, # but so what? potlib="$potent_lib" while test -h "$potlib" 2>/dev/null; do potliblink=`ls -ld $potlib | sed 's/.* -> //'` case $potliblink in [\\/]* | [A-Za-z]:[\\/]*) potlib="$potliblink";; *) potlib=`$echo "X$potlib" | $Xsed -e 's,[^/]*$,,'`"$potliblink";; esac done # It is ok to link against an archive when # building a shared library. if $AR -t $potlib > /dev/null 2>&1; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi if eval $file_magic_cmd \"\$potlib\" 2>/dev/null \ | sed 10q \ | egrep "$file_magic_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done if test -n "$a_deplib" ; then droppeddeps=yes echo echo "*** Warning: This library needs some functionality provided by $a_deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." fi else # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" fi done # Gone through all deplibs. ;; match_pattern*) set dummy $deplibs_check_method match_pattern_regex=`expr "$deplibs_check_method" : "$2 \(.*\)"` for a_deplib in $deplibs; do name="`expr $a_deplib : '-l\(.*\)'`" # If $name is empty we are operating on a -L argument. if test -n "$name" && test "$name" != "0"; then libname=`eval \\$echo \"$libname_spec\"` for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do potential_libs=`ls $i/$libname[.-]* 2>/dev/null` for potent_lib in $potential_libs; do if eval echo \"$potent_lib\" 2>/dev/null \ | sed 10q \ | egrep "$match_pattern_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done if test -n "$a_deplib" ; then droppeddeps=yes echo echo "*** Warning: This library needs some functionality provided by $a_deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." fi else # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" fi done # Gone through all deplibs. ;; none | unknown | *) newdeplibs="" if $echo "X $deplibs" | $Xsed -e 's/ -lc$//' \ -e 's/ -[LR][^ ]*//g' -e 's/[ ]//g' | grep . >/dev/null; then echo if test "X$deplibs_check_method" = "Xnone"; then echo "*** Warning: inter-library dependencies are not supported in this platform." else echo "*** Warning: inter-library dependencies are not known to be supported." fi echo "*** All declared inter-library dependencies are being dropped." droppeddeps=yes fi ;; esac versuffix=$versuffix_save major=$major_save release=$release_save libname=$libname_save name=$name_save case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library is the System framework newdeplibs=`$echo "X $newdeplibs" | $Xsed -e 's/ -lc / -framework System /'` ;; esac if test "$droppeddeps" = yes; then if test "$module" = yes; then echo echo "*** Warning: libtool could not satisfy all declared inter-library" echo "*** dependencies of module $libname. Therefore, libtool will create" echo "*** a static module, that should work as long as the dlopening" echo "*** application is linked with the -dlopen flag." if test -z "$global_symbol_pipe"; then echo echo "*** However, this would only work if libtool was able to extract symbol" echo "*** lists from a program, using \`nm' or equivalent, but libtool could" echo "*** not find such a program. So, this module is probably useless." echo "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi else echo "*** The inter-library dependencies that have been dropped here will be" echo "*** automatically added whenever a program is linked with this library" echo "*** or is declared to -dlopen it." if test $allow_undefined = no; then echo echo "*** Since this library must not contain undefined symbols," echo "*** because either the platform does not support them or" echo "*** it was explicitly requested with -no-undefined," echo "*** libtool will only create a static version of it." if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi fi fi # Done checking deplibs! deplibs=$newdeplibs fi # All the library-specific variables (install_libdir is set above). library_names= old_library= dlname= # Test again, we may have decided not to build it any more if test "$build_libtool_libs" = yes; then if test $hardcode_into_libs = yes; then # Hardcode the library paths hardcode_libdirs= dep_rpath= rpath="$finalize_rpath" test "$mode" != relink && rpath="$compile_rpath$rpath" for libdir in $rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" dep_rpath="$dep_rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval dep_rpath=\"$hardcode_libdir_flag_spec\" fi if test -n "$runpath_var" && test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var" fi test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs" fi shlibpath="$finalize_shlibpath" test "$mode" != relink && shlibpath="$compile_shlibpath$shlibpath" if test -n "$shlibpath"; then eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var" fi # Get the real and link names of the library. eval library_names=\"$library_names_spec\" set dummy $library_names realname="$2" shift; shift if test -n "$soname_spec"; then eval soname=\"$soname_spec\" else soname="$realname" fi test -z "$dlname" && dlname=$soname lib="$output_objdir/$realname" for link do linknames="$linknames $link" done # # Ensure that we have .o objects for linkers which dislike .lo # # (e.g. aix) in case we are running --disable-static # for obj in $libobjs; do # xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$obj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` # oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` # if test ! -f $xdir/$oldobj && test "$baseobj" != "$oldobj"; then # $show "(cd $xdir && ${LN_S} $baseobj $oldobj)" # $run eval '(cd $xdir && ${LN_S} $baseobj $oldobj)' || exit $? # fi # done # Use standard objects if they are pic test -z "$pic_flag" && libobjs=`$echo "X$libobjs" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` # Prepare the list of exported symbols if test -z "$export_symbols"; then if test "$always_export_symbols" = yes || test -n "$export_symbols_regex"; then $show "generating symbol list for \`$libname.la'" export_symbols="$output_objdir/$libname.exp" $run $rm $export_symbols eval cmds=\"$export_symbols_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" if test -n "$export_symbols_regex"; then $show "egrep -e \"$export_symbols_regex\" \"$export_symbols\" > \"${export_symbols}T\"" $run eval 'egrep -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' $show "$mv \"${export_symbols}T\" \"$export_symbols\"" $run eval '$mv "${export_symbols}T" "$export_symbols"' fi fi fi if test -n "$export_symbols" && test -n "$include_expsyms"; then $run eval '$echo "X$include_expsyms" | $SP2NL >> "$export_symbols"' fi if test -n "$convenience"; then if test -n "$whole_archive_flag_spec"; then save_libobjs=$libobjs eval libobjs=\"\$libobjs $whole_archive_flag_spec\" else gentop="$output_objdir/${outputname}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" for xlib in $convenience; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? libobjs="$libobjs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` done fi fi if test "$thread_safe" = yes && test -n "$thread_safe_flag_spec"; then eval flag=\"$thread_safe_flag_spec\" linker_flags="$linker_flags $flag" fi # Make a backup of the uninstalled library when relinking if test "$mode" = relink; then $run eval '(cd $output_objdir && $rm ${realname}U && $mv $realname ${realname}U)' || exit $? fi # Do each of the archive commands. if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then eval cmds=\"$archive_expsym_cmds\" else eval cmds=\"$archive_cmds\" fi if len=`expr "X$cmds" : ".*"` && test $len -le $max_cmd_len; then : else # The command line is too long to link in one step, link piecewise. $echo "creating reloadable object files..." # Save the value of $output and $libobjs because we want to # use them later. If we have whole_archive_flag_spec, we # want to use save_libobjs as it was before # whole_archive_flag_spec was expanded, because we can't # assume the linker understands whole_archive_flag_spec. # This may have to be revisited, in case too many # convenience libraries get linked in and end up exceeding # the spec. if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then save_libobjs=$libobjs fi save_output=$output # Clear the reloadable object creation command queue and # initialize k to one. test_cmds= concat_cmds= objlist= delfiles= last_robj= k=1 output=$output_objdir/$save_output-${k}.$objext # Loop over the list of objects to be linked. for obj in $save_libobjs do eval test_cmds=\"$reload_cmds $objlist $last_robj\" if test "X$objlist" = X || { len=`expr "X$test_cmds" : ".*"` && test $len -le $max_cmd_len; }; then objlist="$objlist $obj" else # The command $test_cmds is almost too long, add a # command to the queue. if test $k -eq 1 ; then # The first file doesn't have a previous command to add. eval concat_cmds=\"$reload_cmds $objlist $last_robj\" else # All subsequent reloadable object files will link in # the last one created. eval concat_cmds=\"\$concat_cmds~$reload_cmds $objlist $last_robj\" fi last_robj=$output_objdir/$save_output-${k}.$objext k=`expr $k + 1` output=$output_objdir/$save_output-${k}.$objext objlist=$obj len=1 fi done # Handle the remaining objects by creating one last # reloadable object file. All subsequent reloadable object # files will link in the last one created. test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$reload_cmds $objlist $last_robj\" # Set up a command to remove the reloadale object files # after they are used. i=0 while test $i -lt $k do i=`expr $i + 1` delfiles="$delfiles $output_objdir/$save_output-${i}.$objext" done $echo "creating a temporary reloadable object file: $output" # Loop through the commands generated above and execute them. IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $concat_cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" libobjs=$output # Restore the value of output. output=$save_output if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then eval libobjs=\"\$libobjs $whole_archive_flag_spec\" fi # Expand the library linking commands again to reset the # value of $libobjs for piecewise linking. # Do each of the archive commands. if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then eval cmds=\"$archive_expsym_cmds\" else eval cmds=\"$archive_cmds\" fi # Append the command to remove the reloadable object files # to the just-reset $cmds. eval cmds=\"\$cmds~$rm $delfiles\" fi IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # Restore the uninstalled library and exit if test "$mode" = relink; then $run eval '(cd $output_objdir && $rm ${realname}T && $mv $realname ${realname}T && $mv "$realname"U $realname)' || exit $? exit 0 fi # Create links to the real library. for linkname in $linknames; do if test "$realname" != "$linkname"; then $show "(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)" $run eval '(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)' || exit $? fi done # If -module or -export-dynamic was specified, set the dlname. if test "$module" = yes || test "$export_dynamic" = yes; then # On all known operating systems, these are identical. dlname="$soname" fi fi ;; obj) if test -n "$deplibs"; then $echo "$modename: warning: \`-l' and \`-L' are ignored for objects" 1>&2 fi if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then $echo "$modename: warning: \`-dlopen' is ignored for objects" 1>&2 fi if test -n "$rpath"; then $echo "$modename: warning: \`-rpath' is ignored for objects" 1>&2 fi if test -n "$xrpath"; then $echo "$modename: warning: \`-R' is ignored for objects" 1>&2 fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for objects" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for objects" 1>&2 fi case $output in *.lo) if test -n "$objs$old_deplibs"; then $echo "$modename: cannot build library object \`$output' from non-libtool objects" 1>&2 exit 1 fi libobj="$output" obj=`$echo "X$output" | $Xsed -e "$lo2o"` ;; *) libobj= obj="$output" ;; esac # Delete the old objects. $run $rm $obj $libobj # Objects from convenience libraries. This assumes # single-version convenience libraries. Whenever we create # different ones for PIC/non-PIC, this we'll have to duplicate # the extraction. reload_conv_objs= gentop= # reload_cmds runs $LD directly, so let us get rid of # -Wl from whole_archive_flag_spec wl= if test -n "$convenience"; then if test -n "$whole_archive_flag_spec"; then eval reload_conv_objs=\"\$reload_objs $whole_archive_flag_spec\" else gentop="$output_objdir/${obj}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" for xlib in $convenience; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? reload_conv_objs="$reload_objs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` done fi fi # Create the old-style object. reload_objs="$objs$old_deplibs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}$'/d' -e '/\.lib$/d' -e "$lo2o" | $NL2SP`" $reload_conv_objs" ### testsuite: skip nested quoting test output="$obj" eval cmds=\"$reload_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # Exit if we aren't doing a library object file. if test -z "$libobj"; then if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi exit 0 fi if test "$build_libtool_libs" != yes; then if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi # Create an invalid libtool object if no PIC, so that we don't # accidentally link it into a program. # $show "echo timestamp > $libobj" # $run eval "echo timestamp > $libobj" || exit $? exit 0 fi if test -n "$pic_flag" || test "$pic_mode" != default; then # Only do commands if we really have different PIC objects. reload_objs="$libobjs $reload_conv_objs" output="$libobj" eval cmds=\"$reload_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # else # # Just create a symlink. # $show $rm $libobj # $run $rm $libobj # xdir=`$echo "X$libobj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$libobj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$libobj" | $Xsed -e 's%^.*/%%'` # oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` # $show "(cd $xdir && $LN_S $oldobj $baseobj)" # $run eval '(cd $xdir && $LN_S $oldobj $baseobj)' || exit $? fi if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi exit 0 ;; prog) case $host in *cygwin*) output=`echo $output | sed -e 's,.exe$,,;s,$,.exe,'` ;; esac if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for programs" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for programs" 1>&2 fi if test "$preload" = yes; then if test "$dlopen_support" = unknown && test "$dlopen_self" = unknown && test "$dlopen_self_static" = unknown; then $echo "$modename: warning: \`AC_LIBTOOL_DLOPEN' not used. Assuming no dlopen support." fi fi case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library is the System framework compile_deplibs=`$echo "X $compile_deplibs" | $Xsed -e 's/ -lc / -framework System /'` finalize_deplibs=`$echo "X $finalize_deplibs" | $Xsed -e 's/ -lc / -framework System /'` ;; esac compile_command="$compile_command $compile_deplibs" finalize_command="$finalize_command $finalize_deplibs" if test -n "$rpath$xrpath"; then # If the user specified any rpath flags, then add them. for libdir in $rpath $xrpath; do # This is the magic to use -rpath. case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done fi # Now hardcode the library paths rpath= hardcode_libdirs= for libdir in $compile_rpath $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) case :$dllsearchpath: in *":$libdir:"*) ;; *) dllsearchpath="$dllsearchpath:$libdir";; esac ;; esac done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi compile_rpath="$rpath" rpath= hardcode_libdirs= for libdir in $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$finalize_perm_rpath " in *" $libdir "*) ;; *) finalize_perm_rpath="$finalize_perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi finalize_rpath="$rpath" dlsyms= if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then if test -n "$NM" && test -n "$global_symbol_pipe"; then dlsyms="${outputname}S.c" else $echo "$modename: not configured to extract global symbols from dlpreopened files" 1>&2 fi fi if test -n "$dlsyms"; then case $dlsyms in "") ;; *.c) # Discover the nlist of each of the dlfiles. nlist="$output_objdir/${outputname}.nm" $show "$rm $nlist ${nlist}S ${nlist}T" $run $rm "$nlist" "${nlist}S" "${nlist}T" # Parse the name list into a source file. $show "creating $output_objdir/$dlsyms" test -z "$run" && $echo > "$output_objdir/$dlsyms" "\ /* $dlsyms - symbol resolution table for \`$outputname' dlsym emulation. */ /* Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP */ #ifdef __cplusplus extern \"C\" { #endif /* Prevent the only kind of declaration conflicts we can make. */ #define lt_preloaded_symbols some_other_symbol /* External symbol declarations for the compiler. */\ " if test "$dlself" = yes; then $show "generating symbol list for \`$output'" test -z "$run" && $echo ': @PROGRAM@ ' > "$nlist" # Add our own program objects to the symbol list. progfiles="$objs$old_deplibs" for arg in $progfiles; do $show "extracting global C symbols from \`$arg'" $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" done if test -n "$exclude_expsyms"; then $run eval 'egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T' $run eval '$mv "$nlist"T "$nlist"' fi if test -n "$export_symbols_regex"; then $run eval 'egrep -e "$export_symbols_regex" "$nlist" > "$nlist"T' $run eval '$mv "$nlist"T "$nlist"' fi # Prepare the list of exported symbols if test -z "$export_symbols"; then export_symbols="$output_objdir/$output.exp" $run $rm $export_symbols $run eval "sed -n -e '/^: @PROGRAM@$/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"' else $run eval "sed -e 's/\([][.*^$]\)/\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$output.exp"' $run eval 'grep -f "$output_objdir/$output.exp" < "$nlist" > "$nlist"T' $run eval 'mv "$nlist"T "$nlist"' fi fi for arg in $dlprefiles; do $show "extracting global C symbols from \`$arg'" name=`echo "$arg" | sed -e 's%^.*/%%'` $run eval 'echo ": $name " >> "$nlist"' $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" done if test -z "$run"; then # Make sure we have at least an empty file. test -f "$nlist" || : > "$nlist" if test -n "$exclude_expsyms"; then egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T $mv "$nlist"T "$nlist" fi # Try sorting and uniquifying the output. if grep -v "^: " < "$nlist" | sort +2 | uniq > "$nlist"S; then : else grep -v "^: " < "$nlist" > "$nlist"S fi if test -f "$nlist"S; then eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$dlsyms"' else echo '/* NONE */' >> "$output_objdir/$dlsyms" fi $echo >> "$output_objdir/$dlsyms" "\ #undef lt_preloaded_symbols #if defined (__STDC__) && __STDC__ # define lt_ptr_t void * #else # define lt_ptr_t char * # define const #endif /* The mapping between symbol names and symbols. */ const struct { const char *name; lt_ptr_t address; } lt_preloaded_symbols[] = {\ " sed -n -e 's/^: \([^ ]*\) $/ {\"\1\", (lt_ptr_t) 0},/p' \ -e 's/^. \([^ ]*\) \([^ ]*\)$/ {"\2", (lt_ptr_t) \&\2},/p' \ < "$nlist" >> "$output_objdir/$dlsyms" $echo >> "$output_objdir/$dlsyms" "\ {0, (lt_ptr_t) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt_preloaded_symbols; } #endif #ifdef __cplusplus } #endif\ " fi pic_flag_for_symtable= case $host in # compiling the symbol table file with pic_flag works around # a FreeBSD bug that causes programs to crash when -lm is # linked before any other PIC object. But we must not use # pic_flag when linking with -static. The problem exists in # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1. *-*-freebsd2*|*-*-freebsd3.0*|*-*-freebsdelf3.0*) case "$compile_command " in *" -static "*) ;; *) pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND";; esac;; *-*-hpux*) case "$compile_command " in *" -static "*) ;; *) pic_flag_for_symtable=" $pic_flag";; esac esac # Now compile the dynamic symbol file. $show "(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable \"$dlsyms\")" $run eval '(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable "$dlsyms")' || exit $? # Clean up the generated files. $show "$rm $output_objdir/$dlsyms $nlist ${nlist}S ${nlist}T" $run $rm "$output_objdir/$dlsyms" "$nlist" "${nlist}S" "${nlist}T" # Transform the symbol file into the correct name. compile_command=`$echo "X$compile_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` finalize_command=`$echo "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` ;; *) $echo "$modename: unknown suffix for \`$dlsyms'" 1>&2 exit 1 ;; esac else # We keep going just in case the user didn't refer to # lt_preloaded_symbols. The linker will fail if global_symbol_pipe # really was required. # Nullify the symbol file. compile_command=`$echo "X$compile_command" | $Xsed -e "s% @SYMFILE@%%"` finalize_command=`$echo "X$finalize_command" | $Xsed -e "s% @SYMFILE@%%"` fi if test $need_relink = no || test "$build_libtool_libs" != yes; then # Replace the output file specification. compile_command=`$echo "X$compile_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` link_command="$compile_command$compile_rpath" # We have no uninstalled library dependencies, so finalize right now. $show "$link_command" $run eval "$link_command" status=$? # Delete the generated files. if test -n "$dlsyms"; then $show "$rm $output_objdir/${outputname}S.${objext}" $run $rm "$output_objdir/${outputname}S.${objext}" fi exit $status fi if test -n "$shlibpath_var"; then # We should set the shlibpath_var rpath= for dir in $temp_rpath; do case $dir in [\\/]* | [A-Za-z]:[\\/]*) # Absolute path. rpath="$rpath$dir:" ;; *) # Relative path: add a thisdir entry. rpath="$rpath\$thisdir/$dir:" ;; esac done temp_rpath="$rpath" fi if test -n "$compile_shlibpath$finalize_shlibpath"; then compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command" fi if test -n "$finalize_shlibpath"; then finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command" fi compile_var= finalize_var= if test -n "$runpath_var"; then if test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done compile_var="$runpath_var=\"$rpath\$$runpath_var\" " fi if test -n "$finalize_perm_rpath"; then # We should set the runpath_var. rpath= for dir in $finalize_perm_rpath; do rpath="$rpath$dir:" done finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " fi fi if test "$no_install" = yes; then # We don't need to create a wrapper script. link_command="$compile_var$compile_command$compile_rpath" # Replace the output file specification. link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` # Delete the old output file. $run $rm $output # Link the executable and exit $show "$link_command" $run eval "$link_command" || exit $? exit 0 fi if test "$hardcode_action" = relink; then # Fast installation is not supported link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" $echo "$modename: warning: this platform does not like uninstalled shared libraries" 1>&2 $echo "$modename: \`$output' will be relinked during installation" 1>&2 else if test "$fast_install" != no; then link_command="$finalize_var$compile_command$finalize_rpath" if test "$fast_install" = yes; then relink_command=`$echo "X$compile_var$compile_command$compile_rpath" | $Xsed -e 's%@OUTPUT@%\$progdir/\$file%g'` else # fast_install is set to needless relink_command= fi else link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" fi fi # Replace the output file specification. link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'` # Delete the old output files. $run $rm $output $output_objdir/$outputname $output_objdir/lt-$outputname $show "$link_command" $run eval "$link_command" || exit $? # Now create the wrapper script. $show "creating $output" # Quote the relink command for shipping. if test -n "$relink_command"; then # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` relink_command="$var=\"$var_value\"; export $var; $relink_command" fi done relink_command="cd `pwd`; $relink_command" relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` fi # Quote $echo for shipping. if test "X$echo" = "X$SHELL $0 --fallback-echo"; then case $0 in [\\/]* | [A-Za-z]:[\\/]*) qecho="$SHELL $0 --fallback-echo";; *) qecho="$SHELL `pwd`/$0 --fallback-echo";; esac qecho=`$echo "X$qecho" | $Xsed -e "$sed_quote_subst"` else qecho=`$echo "X$echo" | $Xsed -e "$sed_quote_subst"` fi # Only actually do things if our run command is non-null. if test -z "$run"; then # win32 will think the script is a binary if it has # a .exe suffix, so we strip it off here. case $output in *.exe) output=`echo $output|sed 's,.exe$,,'` ;; esac # test for cygwin because mv fails w/o .exe extensions case $host in *cygwin*) exeext=.exe ;; *) exeext= ;; esac $rm $output trap "$rm $output; exit 1" 1 2 15 $echo > $output "\ #! $SHELL # $output - temporary wrapper script for $objdir/$outputname # Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP # # The $output program cannot be directly executed until all the libtool # libraries that it depends on are installed. # # This wrapper script should never be moved out of the build directory. # If it is, it will not operate correctly. # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. Xsed='sed -e 1s/^X//' sed_quote_subst='$sed_quote_subst' # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. if test \"\${CDPATH+set}\" = set; then CDPATH=:; export CDPATH; fi relink_command=\"$relink_command > /dev/null 2>&1\" # This environment variable determines our operation mode. if test \"\$libtool_install_magic\" = \"$magic\"; then # install mode needs the following variable: notinst_deplibs='$notinst_deplibs' else # When we are sourced in execute mode, \$file and \$echo are already set. if test \"\$libtool_execute_magic\" != \"$magic\"; then echo=\"$qecho\" file=\"\$0\" # Make sure echo works. if test \"X\$1\" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test \"X\`(\$echo '\t') 2>/dev/null\`\" = 'X\t'; then # Yippee, \$echo works! : else # Restart under the correct shell, and then maybe \$echo will work. exec $SHELL \"\$0\" --no-reexec \${1+\"\$@\"} fi fi\ " $echo >> $output "\ # Find the directory that this script lives in. thisdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*$%%'\` test \"x\$thisdir\" = \"x\$file\" && thisdir=. # Follow symbolic links until we get to the real thisdir. file=\`ls -ld \"\$file\" | sed -n 's/.*-> //p'\` while test -n \"\$file\"; do destdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*\$%%'\` # If there was a directory component, then change thisdir. if test \"x\$destdir\" != \"x\$file\"; then case \"\$destdir\" in [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;; *) thisdir=\"\$thisdir/\$destdir\" ;; esac fi file=\`\$echo \"X\$file\" | \$Xsed -e 's%^.*/%%'\` file=\`ls -ld \"\$thisdir/\$file\" | sed -n 's/.*-> //p'\` done # Try to get the absolute directory name. absdir=\`cd \"\$thisdir\" && pwd\` test -n \"\$absdir\" && thisdir=\"\$absdir\" " if test "$fast_install" = yes; then echo >> $output "\ program=lt-'$outputname'$exeext progdir=\"\$thisdir/$objdir\" if test ! -f \"\$progdir/\$program\" || \\ { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | sed 1q\`; \\ test \"X\$file\" != \"X\$progdir/\$program\"; }; then file=\"\$\$-\$program\" if test ! -d \"\$progdir\"; then $mkdir \"\$progdir\" else $rm \"\$progdir/\$file\" fi" echo >> $output "\ # relink executable if necessary if test -n \"\$relink_command\"; then if relink_command_output=\`eval \$relink_command 2>&1\`; then : else $echo \"\$relink_command_output\" >&2 $rm \"\$progdir/\$file\" exit 1 fi fi $mv \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null || { $rm \"\$progdir/\$program\"; $mv \"\$progdir/\$file\" \"\$progdir/\$program\"; } $rm \"\$progdir/\$file\" fi" else echo >> $output "\ program='$outputname' progdir=\"\$thisdir/$objdir\" " fi echo >> $output "\ if test -f \"\$progdir/\$program\"; then" # Export our shlibpath_var if we have one. if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then $echo >> $output "\ # Add our own library path to $shlibpath_var $shlibpath_var=\"$temp_rpath\$$shlibpath_var\" # Some systems cannot cope with colon-terminated $shlibpath_var # The second colon is a workaround for a bug in BeOS R4 sed $shlibpath_var=\`\$echo \"X\$$shlibpath_var\" | \$Xsed -e 's/::*\$//'\` export $shlibpath_var " fi # fixup the dll searchpath if we need to. if test -n "$dllsearchpath"; then $echo >> $output "\ # Add the dll search path components to the executable PATH PATH=$dllsearchpath:\$PATH " fi $echo >> $output "\ if test \"\$libtool_execute_magic\" != \"$magic\"; then # Run the actual program with our arguments. " case $host in # win32 systems need to use the prog path for dll # lookup to work *-*-cygwin* | *-*-pw32*) $echo >> $output "\ exec \$progdir/\$program \${1+\"\$@\"} " ;; # Backslashes separate directories on plain windows *-*-mingw | *-*-os2*) $echo >> $output "\ exec \$progdir\\\\\$program \${1+\"\$@\"} " ;; *) $echo >> $output "\ # Export the path to the program. PATH=\"\$progdir:\$PATH\" export PATH exec \$program \${1+\"\$@\"} " ;; esac $echo >> $output "\ \$echo \"\$0: cannot exec \$program \${1+\"\$@\"}\" exit 1 fi else # The program doesn't exist. \$echo \"\$0: error: \$progdir/\$program does not exist\" 1>&2 \$echo \"This script is just a wrapper for \$program.\" 1>&2 echo \"See the $PACKAGE documentation for more information.\" 1>&2 exit 1 fi fi\ " chmod +x $output fi exit 0 ;; esac # See if we need to build an old-fashioned archive. for oldlib in $oldlibs; do if test "$build_libtool_libs" = convenience; then oldobjs="$libobjs_save" addlibs="$convenience" build_libtool_libs=no else if test "$build_libtool_libs" = module; then oldobjs="$libobjs_save" build_libtool_libs=no else oldobjs="$objs$old_deplibs $non_pic_objects" fi addlibs="$old_convenience" fi if test -n "$addlibs"; then gentop="$output_objdir/${outputname}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" # Add in members from convenience archives. for xlib in $addlibs; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? oldobjs="$oldobjs "`find $xdir -name \*.${objext} -print | $NL2SP` done fi # Do each command in the archive commands. if test -n "$old_archive_from_new_cmds" && test "$build_libtool_libs" = yes; then eval cmds=\"$old_archive_from_new_cmds\" else # # Ensure that we have .o objects in place in case we decided # # not to build a shared library, and have fallen back to building # # static libs even though --disable-static was passed! # for oldobj in $oldobjs; do # if test ! -f $oldobj; then # xdir=`$echo "X$oldobj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$oldobj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$oldobj" | $Xsed -e 's%^.*/%%'` # obj=`$echo "X$baseobj" | $Xsed -e "$o2lo"` # $show "(cd $xdir && ${LN_S} $obj $baseobj)" # $run eval '(cd $xdir && ${LN_S} $obj $baseobj)' || exit $? # fi # done eval cmds=\"$old_archive_cmds\" if len=`expr "X$cmds" : ".*"` && test $len -le $max_cmd_len; then : else # the command line is too long to link in one step, link in parts $echo "using piecewise archive linking..." save_RANLIB=$RANLIB RANLIB=: objlist= concat_cmds= save_oldobjs=$oldobjs for obj in $save_oldobjs do oldobjs="$objlist $obj" objlist="$objlist $obj" eval test_cmds=\"$old_archive_cmds\" if len=`expr "X$test_cmds" : ".*"` && test $len -le $max_cmd_len; then : else # the above command should be used before it gets too long oldobjs=$objlist test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$old_archive_cmds\" objlist= fi done RANLIB=$save_RANLIB oldobjs=$objlist eval cmds=\"\$concat_cmds~$old_archive_cmds\" fi fi IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" done if test -n "$generated"; then $show "${rm}r$generated" $run ${rm}r$generated fi # Now create the libtool archive. case $output in *.la) old_library= test "$build_old_libs" = yes && old_library="$libname.$libext" $show "creating $output" # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` relink_command="$var=\"$var_value\"; export $var; $relink_command" fi done # Quote the link command for shipping. tagopts= for tag in $taglist; do tagopts="$tagopts --tag $tag" done relink_command="(cd `pwd`; $SHELL $0$tagopts --mode=relink $libtool_args)" relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` # Only create the output if not a dry run. if test -z "$run"; then for installed in no yes; do if test "$installed" = yes; then if test -z "$install_libdir"; then break fi output="$output_objdir/$outputname"i # Replace all uninstalled libtool libraries with the installed ones newdependency_libs= for deplib in $dependency_libs; do case $deplib in *.la) name=`$echo "X$deplib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` if test -z "$libdir"; then $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 exit 1 fi newdependency_libs="$newdependency_libs $libdir/$name" ;; *) newdependency_libs="$newdependency_libs $deplib" ;; esac done dependency_libs="$newdependency_libs" newdlfiles= for lib in $dlfiles; do name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` if test -z "$libdir"; then $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi newdlfiles="$newdlfiles $libdir/$name" done dlfiles="$newdlfiles" newdlprefiles= for lib in $dlprefiles; do name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` if test -z "$libdir"; then $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi newdlprefiles="$newdlprefiles $libdir/$name" done dlprefiles="$newdlprefiles" fi $rm $output # place dlname in correct position for cygwin tdlname=$dlname case $host,$output,$installed,$module,$dlname in *cygwin*,*lai,yes,no,*.dll) tdlname=../bin/$dlname ;; esac $echo > $output "\ # $outputname - a libtool library file # Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP # # Please DO NOT delete this file! # It is necessary for linking the library. # The name that we can dlopen(3). dlname='$tdlname' # Names of this library. library_names='$library_names' # The name of the static archive. old_library='$old_library' # Libraries that this one depends upon. dependency_libs='$dependency_libs' # Version information for $libname. current=$current age=$age revision=$revision # Is this an already installed library? installed=$installed # Files to dlopen/dlpreopen dlopen='$dlfiles' dlpreopen='$dlprefiles' # Directory that this library needs to be installed in: libdir='$install_libdir'" if test "$installed" = no && test $need_relink = yes; then $echo >> $output "\ relink_command=\"$relink_command\"" fi done fi # Do a symbolic link so that the libtool archive can be found in # LD_LIBRARY_PATH before the program is installed. $show "(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)" $run eval '(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)' || exit $? ;; esac exit 0 ;; # libtool install mode install) modename="$modename: install" # There may be an optional sh(1) argument at the beginning of # install_prog (especially on Windows NT). if test "$nonopt" = "$SHELL" || test "$nonopt" = /bin/sh || # Allow the use of GNU shtool's install command. $echo "X$nonopt" | $Xsed | grep shtool > /dev/null; then # Aesthetically quote it. arg=`$echo "X$nonopt" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$arg " arg="$1" shift else install_prog= arg="$nonopt" fi # The real first argument should be the name of the installation program. # Aesthetically quote it. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$install_prog$arg" # We need to accept at least all the BSD install flags. dest= files= opts= prev= install_type= isdir=no stripme= for arg do if test -n "$dest"; then files="$files $dest" dest="$arg" continue fi case $arg in -d) isdir=yes ;; -f) prev="-f" ;; -g) prev="-g" ;; -m) prev="-m" ;; -o) prev="-o" ;; -s) stripme=" -s" continue ;; -*) ;; *) # If the previous option needed an argument, then skip it. if test -n "$prev"; then prev= else dest="$arg" continue fi ;; esac # Aesthetically quote the argument. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$install_prog $arg" done if test -z "$install_prog"; then $echo "$modename: you must specify an install program" 1>&2 $echo "$help" 1>&2 exit 1 fi if test -n "$prev"; then $echo "$modename: the \`$prev' option requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi if test -z "$files"; then if test -z "$dest"; then $echo "$modename: no file or destination specified" 1>&2 else $echo "$modename: you must specify a destination" 1>&2 fi $echo "$help" 1>&2 exit 1 fi # Strip any trailing slash from the destination. dest=`$echo "X$dest" | $Xsed -e 's%/$%%'` # Check to see that the destination is a directory. test -d "$dest" && isdir=yes if test "$isdir" = yes; then destdir="$dest" destname= else destdir=`$echo "X$dest" | $Xsed -e 's%/[^/]*$%%'` test "X$destdir" = "X$dest" && destdir=. destname=`$echo "X$dest" | $Xsed -e 's%^.*/%%'` # Not a directory, so check to see that there is only one file specified. set dummy $files if test $# -gt 2; then $echo "$modename: \`$dest' is not a directory" 1>&2 $echo "$help" 1>&2 exit 1 fi fi case $destdir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) for file in $files; do case $file in *.lo) ;; *) $echo "$modename: \`$destdir' must be an absolute directory name" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac done ;; esac # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" staticlibs= future_libdirs= current_libdirs= for file in $files; do # Do each installation. case $file in *.$libext) # Do the static libraries later. staticlibs="$staticlibs $file" ;; *.la) # Check to see that this really is a libtool archive. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$file' is not a valid libtool archive" 1>&2 $echo "$help" 1>&2 exit 1 fi library_names= old_library= relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Add the libdir to current_libdirs if it is the destination. if test "X$destdir" = "X$libdir"; then case "$current_libdirs " in *" $libdir "*) ;; *) current_libdirs="$current_libdirs $libdir" ;; esac else # Note the libdir as a future libdir. case "$future_libdirs " in *" $libdir "*) ;; *) future_libdirs="$future_libdirs $libdir" ;; esac fi dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'`/ test "X$dir" = "X$file/" && dir= dir="$dir$objdir" if test -n "$relink_command"; then $echo "$modename: warning: relinking \`$file'" 1>&2 $show "$relink_command" if $run eval "$relink_command"; then : else $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 exit 1 fi fi # See the names of the shared library. set dummy $library_names if test -n "$2"; then realname="$2" shift shift srcname="$realname" test -n "$relink_command" && srcname="$realname"T # Install the shared library and build the symlinks. $show "$install_prog $dir/$srcname $destdir/$realname" $run eval "$install_prog $dir/$srcname $destdir/$realname" || exit $? if test -n "$stripme" && test -n "$striplib"; then $show "$striplib $destdir/$realname" $run eval "$striplib $destdir/$realname" || exit $? fi if test $# -gt 0; then # Delete the old symlinks, and create new ones. for linkname do if test "$linkname" != "$realname"; then $show "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" $run eval "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" fi done fi # Do each command in the postinstall commands. lib="$destdir/$realname" eval cmds=\"$postinstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # Install the pseudo-library for information purposes. name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` instname="$dir/$name"i $show "$install_prog $instname $destdir/$name" $run eval "$install_prog $instname $destdir/$name" || exit $? # Maybe install the static library, too. test -n "$old_library" && staticlibs="$staticlibs $dir/$old_library" ;; *.lo) # Install (i.e. copy) a libtool object. # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` destfile="$destdir/$destfile" fi # Deduce the name of the destination old-style object file. case $destfile in *.lo) staticdest=`$echo "X$destfile" | $Xsed -e "$lo2o"` ;; *.$objext) staticdest="$destfile" destfile= ;; *) $echo "$modename: cannot copy a libtool object to \`$destfile'" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac # Install the libtool object if requested. if test -n "$destfile"; then $show "$install_prog $file $destfile" $run eval "$install_prog $file $destfile" || exit $? fi # Install the old object if enabled. if test "$build_old_libs" = yes; then # Deduce the name of the old-style object file. staticobj=`$echo "X$file" | $Xsed -e "$lo2o"` $show "$install_prog $staticobj $staticdest" $run eval "$install_prog \$staticobj \$staticdest" || exit $? fi exit 0 ;; *) # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` destfile="$destdir/$destfile" fi # Do a test to see if this is really a libtool program. if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then notinst_deplibs= relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Check the variables that should have been set. if test -z "$notinst_deplibs"; then $echo "$modename: invalid libtool wrapper script \`$file'" 1>&2 exit 1 fi finalize=yes for lib in $notinst_deplibs; do # Check to see that each library is installed. libdir= if test -f "$lib"; then # If there is no directory component, then add one. case $lib in */* | *\\*) . $lib ;; *) . ./$lib ;; esac fi libfile="$libdir/"`$echo "X$lib" | $Xsed -e 's%^.*/%%g'` ### testsuite: skip nested quoting test if test -n "$libdir" && test ! -f "$libfile"; then $echo "$modename: warning: \`$lib' has not been installed in \`$libdir'" 1>&2 finalize=no fi done relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac outputname= if test "$fast_install" = no && test -n "$relink_command"; then if test "$finalize" = yes && test -z "$run"; then tmpdir="/tmp" test -n "$TMPDIR" && tmpdir="$TMPDIR" tmpdir="$tmpdir/libtool-$$" if $mkdir -p "$tmpdir" && chmod 700 "$tmpdir"; then : else $echo "$modename: error: cannot create temporary directory \`$tmpdir'" 1>&2 continue fi file=`$echo "X$file" | $Xsed -e 's%^.*/%%'` outputname="$tmpdir/$file" # Replace the output file specification. relink_command=`$echo "X$relink_command" | $Xsed -e 's%@OUTPUT@%'"$outputname"'%g'` $show "$relink_command" if $run eval "$relink_command"; then : else $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 ${rm}r "$tmpdir" continue fi file="$outputname" else $echo "$modename: warning: cannot relink \`$file'" 1>&2 fi else # Install the binary that we compiled earlier. file=`$echo "X$file" | $Xsed -e "s%\([^/]*\)$%$objdir/\1%"` fi fi # remove .exe since cygwin /usr/bin/install will append another # one anyways case $install_prog,$host in */usr/bin/install*,*cygwin*) case $file:$destfile in *.exe:*.exe) # this is ok ;; *.exe:*) destfile=$destfile.exe ;; *:*.exe) destfile=`echo $destfile | sed -e 's,.exe$,,'` ;; esac ;; esac $show "$install_prog$stripme $file $destfile" $run eval "$install_prog\$stripme \$file \$destfile" || exit $? test -n "$outputname" && ${rm}r "$tmpdir" ;; esac done for file in $staticlibs; do name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` # Set up the ranlib parameters. oldlib="$destdir/$name" $show "$install_prog $file $oldlib" $run eval "$install_prog \$file \$oldlib" || exit $? if test -n "$stripme" && test -n "$striplib"; then $show "$old_striplib $oldlib" $run eval "$old_striplib $oldlib" || exit $? fi # Do each command in the postinstall commands. eval cmds=\"$old_postinstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" done if test -n "$future_libdirs"; then $echo "$modename: warning: remember to run \`$progname --finish$future_libdirs'" 1>&2 fi if test -n "$current_libdirs"; then # Maybe just do a dry run. test -n "$run" && current_libdirs=" -n$current_libdirs" exec_cmd='$SHELL $0 --finish$current_libdirs' else exit 0 fi ;; # libtool finish mode finish) modename="$modename: finish" libdirs="$nonopt" admincmds= if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then for dir do libdirs="$libdirs $dir" done for libdir in $libdirs; do if test -n "$finish_cmds"; then # Do each command in the finish commands. eval cmds=\"$finish_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || admincmds="$admincmds $cmd" done IFS="$save_ifs" fi if test -n "$finish_eval"; then # Do the single finish_eval. eval cmds=\"$finish_eval\" $run eval "$cmds" || admincmds="$admincmds $cmds" fi done fi # Exit here if they wanted silent mode. test "$show" = ":" && exit 0 echo "----------------------------------------------------------------------" echo "Libraries have been installed in:" for libdir in $libdirs; do echo " $libdir" done echo echo "If you ever happen to want to link against installed libraries" echo "in a given directory, LIBDIR, you must either use libtool, and" echo "specify the full pathname of the library, or use the \`-LLIBDIR'" echo "flag during linking and do at least one of the following:" if test -n "$shlibpath_var"; then echo " - add LIBDIR to the \`$shlibpath_var' environment variable" echo " during execution" fi if test -n "$runpath_var"; then echo " - add LIBDIR to the \`$runpath_var' environment variable" echo " during linking" fi if test -n "$hardcode_libdir_flag_spec"; then libdir=LIBDIR eval flag=\"$hardcode_libdir_flag_spec\" echo " - use the \`$flag' linker flag" fi if test -n "$admincmds"; then echo " - have your system administrator run these commands:$admincmds" fi if test -f /etc/ld.so.conf; then echo " - have your system administrator add LIBDIR to \`/etc/ld.so.conf'" fi echo echo "See any operating system documentation about shared libraries for" echo "more information, such as the ld(1) and ld.so(8) manual pages." echo "----------------------------------------------------------------------" exit 0 ;; # libtool execute mode execute) modename="$modename: execute" # The first argument is the command name. cmd="$nonopt" if test -z "$cmd"; then $echo "$modename: you must specify a COMMAND" 1>&2 $echo "$help" exit 1 fi # Handle -dlopen flags immediately. for file in $execute_dlfiles; do if test ! -f "$file"; then $echo "$modename: \`$file' is not a file" 1>&2 $echo "$help" 1>&2 exit 1 fi dir= case $file in *.la) # Check to see that this really is a libtool archive. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 $echo "$help" 1>&2 exit 1 fi # Read the libtool library. dlname= library_names= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Skip this library if it cannot be dlopened. if test -z "$dlname"; then # Warn if it was a shared library. test -n "$library_names" && $echo "$modename: warning: \`$file' was not linked with \`-export-dynamic'" continue fi dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$file" && dir=. if test -f "$dir/$objdir/$dlname"; then dir="$dir/$objdir" else $echo "$modename: cannot find \`$dlname' in \`$dir' or \`$dir/$objdir'" 1>&2 exit 1 fi ;; *.lo) # Just add the directory containing the .lo file. dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$file" && dir=. ;; *) $echo "$modename: warning \`-dlopen' is ignored for non-libtool libraries and objects" 1>&2 continue ;; esac # Get the absolute pathname. absdir=`cd "$dir" && pwd` test -n "$absdir" && dir="$absdir" # Now add the directory to shlibpath_var. if eval "test -z \"\$$shlibpath_var\""; then eval "$shlibpath_var=\"\$dir\"" else eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\"" fi done # This variable tells wrapper scripts just to set shlibpath_var # rather than running their programs. libtool_execute_magic="$magic" # Check if any of the arguments is a wrapper script. args= for file do case $file in -*) ;; *) # Do a test to see if this is really a libtool program. if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Transform arg to wrapped name. file="$progdir/$program" fi ;; esac # Quote arguments (to preserve shell metacharacters). file=`$echo "X$file" | $Xsed -e "$sed_quote_subst"` args="$args \"$file\"" done if test -z "$run"; then if test -n "$shlibpath_var"; then # Export the shlibpath_var. eval "export $shlibpath_var" fi # Restore saved enviroment variables if test "${save_LC_ALL+set}" = set; then LC_ALL="$save_LC_ALL"; export LC_ALL fi if test "${save_LANG+set}" = set; then LANG="$save_LANG"; export LANG fi # Now prepare to actually exec the command. exec_cmd='"$cmd"$args' else # Display what would be done. if test -n "$shlibpath_var"; then eval "\$echo \"\$shlibpath_var=\$$shlibpath_var\"" $echo "export $shlibpath_var" fi $echo "$cmd$args" exit 0 fi ;; # libtool clean and uninstall mode clean | uninstall) modename="$modename: $mode" rm="$nonopt" files= rmforce= exit_status=0 # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" for arg do case $arg in -f) rm="$rm $arg"; rmforce=yes ;; -*) rm="$rm $arg" ;; *) files="$files $arg" ;; esac done if test -z "$rm"; then $echo "$modename: you must specify an RM program" 1>&2 $echo "$help" 1>&2 exit 1 fi rmdirs= for file in $files; do dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` if test "X$dir" = "X$file"; then dir=. objdir="$objdir" else objdir="$dir/$objdir" fi name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` test $mode = uninstall && objdir="$dir" # Remember objdir for removal later, being careful to avoid duplicates if test $mode = clean; then case " $rmdirs " in *" $objdir "*) ;; *) rmdirs="$rmdirs $objdir" ;; esac fi # Don't error if the file doesn't exist and rm -f was used. if (test -L "$file") >/dev/null 2>&1 \ || (test -h "$file") >/dev/null 2>&1 \ || test -f "$file"; then : elif test -d "$file"; then exit_status=1 continue elif test "$rmforce" = yes; then continue fi rmfiles="$file" case $name in *.la) # Possibly a libtool archive, so verify it. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then . $dir/$name # Delete the libtool libraries and symlinks. for n in $library_names; do rmfiles="$rmfiles $objdir/$n" done test -n "$old_library" && rmfiles="$rmfiles $objdir/$old_library" test $mode = clean && rmfiles="$rmfiles $objdir/$name $objdir/${name}i" if test $mode = uninstall; then if test -n "$library_names"; then # Do each command in the postuninstall commands. eval cmds=\"$postuninstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" if test $? != 0 && test "$rmforce" != yes; then exit_status=1 fi done IFS="$save_ifs" fi if test -n "$old_library"; then # Do each command in the old_postuninstall commands. eval cmds=\"$old_postuninstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" if test $? != 0 && test "$rmforce" != yes; then exit_status=1 fi done IFS="$save_ifs" fi # FIXME: should reinstall the best remaining shared library. fi fi ;; *.lo) # Possibly a libtool object, so verify it. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then # Read the .lo file . $dir/$name # Add PIC object to the list of files to remove. if test -n "$pic_object" \ && test "$pic_object" != none; then rmfiles="$rmfiles $dir/$pic_object" fi # Add non-PIC object to the list of files to remove. if test -n "$non_pic_object" \ && test "$non_pic_object" != none; then rmfiles="$rmfiles $dir/$non_pic_object" fi fi ;; *) # Do a test to see if this is a libtool program. if test $mode = clean && (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then relink_command= . $dir/$file rmfiles="$rmfiles $objdir/$name $objdir/${name}S.${objext}" if test "$fast_install" = yes && test -n "$relink_command"; then rmfiles="$rmfiles $objdir/lt-$name" fi fi ;; esac $show "$rm $rmfiles" $run $rm $rmfiles || exit_status=1 done # Try to remove the ${objdir}s in the directories where we deleted files for dir in $rmdirs; do if test -d "$dir"; then $show "rmdir $dir" $run rmdir $dir >/dev/null 2>&1 fi done exit $exit_status ;; "") $echo "$modename: you must specify a MODE" 1>&2 $echo "$generic_help" 1>&2 exit 1 ;; esac if test -z "$exec_cmd"; then $echo "$modename: invalid operation mode \`$mode'" 1>&2 $echo "$generic_help" 1>&2 exit 1 fi fi # test -z "$show_help" if test -n "$exec_cmd"; then eval exec $exec_cmd exit 1 fi # We need to display help for each of the modes. case $mode in "") $echo \ "Usage: $modename [OPTION]... [MODE-ARG]... Provide generalized library-building support services. --config show all configuration variables --debug enable verbose shell tracing -n, --dry-run display commands without modifying any files --features display basic configuration information and exit --finish same as \`--mode=finish' --help display this help message and exit --mode=MODE use operation mode MODE [default=inferred from MODE-ARGS] --quiet same as \`--silent' --silent don't print informational messages --tag=TAG use configuration variables from tag TAG --version print version information MODE must be one of the following: clean remove files from the build directory compile compile a source file into a libtool object execute automatically set library path, then run a program finish complete the installation of libtool libraries install install libraries or executables link create a library or an executable uninstall remove libraries from an installed directory MODE-ARGS vary depending on the MODE. Try \`$modename --help --mode=MODE' for a more detailed description of MODE." exit 0 ;; clean) $echo \ "Usage: $modename [OPTION]... --mode=clean RM [RM-OPTION]... FILE... Remove files from the build directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, object or program, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; compile) $echo \ "Usage: $modename [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE Compile a source file into a libtool library object. This mode accepts the following additional options: -o OUTPUT-FILE set the output file name to OUTPUT-FILE -prefer-pic try to building PIC objects only -prefer-non-pic try to building non-PIC objects only -static always build a \`.o' file suitable for static linking COMPILE-COMMAND is a command to be used in creating a \`standard' object file from the given SOURCEFILE. The output file name is determined by removing the directory component from SOURCEFILE, then substituting the C source code suffix \`.c' with the library object suffix, \`.lo'." ;; execute) $echo \ "Usage: $modename [OPTION]... --mode=execute COMMAND [ARGS]... Automatically set library path, then run a program. This mode accepts the following additional options: -dlopen FILE add the directory containing FILE to the library path This mode sets the library path environment variable according to \`-dlopen' flags. If any of the ARGS are libtool executable wrappers, then they are translated into their corresponding uninstalled binary, and any of their required library directories are added to the library path. Then, COMMAND is executed, with ARGS as arguments." ;; finish) $echo \ "Usage: $modename [OPTION]... --mode=finish [LIBDIR]... Complete the installation of libtool libraries. Each LIBDIR is a directory that contains libtool libraries. The commands that this mode executes may require superuser privileges. Use the \`--dry-run' option if you just want to see what would be executed." ;; install) $echo \ "Usage: $modename [OPTION]... --mode=install INSTALL-COMMAND... Install executables or libraries. INSTALL-COMMAND is the installation command. The first component should be either the \`install' or \`cp' program. The rest of the components are interpreted as arguments to that command (only BSD-compatible install options are recognized)." ;; link) $echo \ "Usage: $modename [OPTION]... --mode=link LINK-COMMAND... Link object files or libraries together to form another library, or to create an executable program. LINK-COMMAND is a command using the C compiler that you would use to create a program from several object files. The following components of LINK-COMMAND are treated specially: -all-static do not do any dynamic linking at all -avoid-version do not add a version suffix if possible -dlopen FILE \`-dlpreopen' FILE if it cannot be dlopened at runtime -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3) -export-symbols SYMFILE try to export only the symbols listed in SYMFILE -export-symbols-regex REGEX try to export only the symbols matching REGEX -LLIBDIR search LIBDIR for required installed libraries -lNAME OUTPUT-FILE requires the installed library libNAME -module build a library that can dlopened -no-fast-install disable the fast-install mode -no-install link a not-installable executable -no-undefined declare that a library does not refer to external symbols -o OUTPUT-FILE create OUTPUT-FILE from the specified objects -objectlist FILE Use a list of object files found in FILE to specify objects -release RELEASE specify package release information -rpath LIBDIR the created library will eventually be installed in LIBDIR -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries -static do not do any dynamic linking of libtool libraries -version-info CURRENT[:REVISION[:AGE]] specify library version info [each variable defaults to 0] All other options (arguments beginning with \`-') are ignored. Every other argument is treated as a filename. Files ending in \`.la' are treated as uninstalled libtool libraries, other files are standard or library object files. If the OUTPUT-FILE ends in \`.la', then a libtool library is created, only library objects (\`.lo' files) may be specified, and \`-rpath' is required, except when creating a convenience library. If OUTPUT-FILE ends in \`.a' or \`.lib', then a standard library is created using \`ar' and \`ranlib', or on Windows using \`lib'. If OUTPUT-FILE ends in \`.lo' or \`.${objext}', then a reloadable object file is created, otherwise an executable program is created." ;; uninstall) $echo \ "Usage: $modename [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE... Remove libraries from an installation directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; *) $echo "$modename: invalid operation mode \`$mode'" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac echo $echo "Try \`$modename --help' for more information about other modes." exit 0 # The TAGs below are defined such that we never get into a situation # in which we disable both kinds of libraries. Given conflicting # choices, we go for a static library, that is the most portable, # since we can't tell whether shared libraries were disabled because # the user asked for that or because the platform doesn't support # them. This is particularly important on AIX, because we don't # support having both static and shared libraries enabled at the same # time on that platform, so we default to a shared-only configuration. # If a disable-shared tag is given, we'll fallback to a static-only # configuration. But we'll never go from static-only to shared-only. ### BEGIN LIBTOOL TAG CONFIG: disable-shared build_libtool_libs=no build_old_libs=yes ### END LIBTOOL TAG CONFIG: disable-shared ### BEGIN LIBTOOL TAG CONFIG: disable-static build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac` ### END LIBTOOL TAG CONFIG: disable-static # Local Variables: # mode:shell-script # sh-indentation:2 # End: gcl-2.6.14/windows/0000755000175000017500000000000014360276512012465 5ustar cammcammgcl-2.6.14/windows/instdos.sh0000755000175000017500000000027014360276512014506 0ustar cammcamm#!/bin/sh -ef # Copy a file so that it ends up with dos line endings so that for example, # batch files will run properly under Windows 98. cat $1 | awk '{sub(/$/,"\r");print}' > $2 gcl-2.6.14/windows/gcl.iss.in0000644000175000017500000000410514360276512014357 0ustar cammcamm; -*-mode: text; fill-column: 75; tab-width: 8; coding: iso-latin-1-dos -*- ; Script originally generated by the Inno Setup Script Wizard. ; -- $Id$ -- [Setup] AppName=GNU Common Lisp (@CLSTANDARD@ build) AppVerName=GNU Common Lisp @VERSION@ (@CLSTANDARD@ build) AppPublisher=The GNU Common Lisp Development Team AppPublisherURL=http://savannah.gnu.org/projects/gcl/ AppSupportURL=http://savannah.gnu.org/projects/gcl/ AppUpdatesURL=http://savannah.gnu.org/projects/gcl/ AppVersion=@VERSION@ OutputBaseFilename=gcl-@VERSION@-@CLSTANDARD@ DefaultDirName={sd}\Progra~1\GCL-@VERSION@-@CLSTANDARD@ DefaultGroupName=GCL-@VERSION@-@CLSTANDARD@ AllowNoIcons=yes ; AlwaysCreateUninstallIcon=yes LicenseFile=@prefix@\COPYING.LIB-2.0 InfoBeforeFile=@prefix@\readme-bin.mingw Uninstallable=yes UninstallFilesDir={app}\uninst ; uncomment the following line if you want your installation to run on NT 3.51 too. ; MinVersion=4,3.51 [Tasks] Name: "desktopicon"; Description: "Create a &desktop icon"; GroupDescription: "Additional icons:"; MinVersion: 4,4 [Files] Source: "@prefix@\*.*"; DestDir: "{app}\"; Flags: recursesubdirs Source: "c:\lang\MinGW32-gcl\*.*"; DestDir: "{app}\mingw"; Flags: recursesubdirs [Icons] Name: "{group}\GNU Common Lisp @VERSION@ @CLSTANDARD@"; Filename: "{app}\bin\gcl.bat"; IconFilename: "{app}\bin\gcl.ico" Name: "{group}\GCL System Manual"; Filename: "{app}\lib\gcl-@VERSION@\doc\gcl-si\index.html" Name: "{group}\Common Lisp HyperSpec"; Filename: "{app}\lib\gcl-@VERSION@\doc\gcl\index.html" Name: "{userdesktop}\GNU Common Lisp"; Filename: "{app}\bin\gcl.bat"; MinVersion: 4,4; Tasks: desktopicon; IconFilename: "{app}\bin\gcl.ico" [Run] Filename: "{app}\bin\sysdir.bat"; Parameters: "{app}\lib\gcl-@VERSION@\unixport\" Filename: "{app}\lib\gcl-@VERSION@\unixport\@FLISP@.exe"; Parameters: -load {app}/install/install.lsp Filename: "{app}\bin\gcl.bat"; Description: "Launch GNU Common Lisp"; Flags: postinstall skipifsilent [UninstallDelete] Type: files; Name: "{app}\bin\gcl.bat" Type: files; Name: "{app}\bin\gcl" Type: files; Name: "{app}\lib\gcl-@VERSION@\unixport\@FLISP@_orig.exe" gcl-2.6.14/windows/install.lsp.in0000644000175000017500000001314214360276512015261 0ustar cammcamm;;; ;;; Help the Windows installer ;;; ;; In the final destination bin directory, make a Bourne shell script ;; to launch GCL. (defun kill-backs ( s ) (let ((pos (search "\\" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (1+ pos)))) (kill-backs (concatenate 'string start "/" finish))) s))) (defun kill-double-forwards ( s ) (let ((pos (search "//" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (+ pos 2)))) (kill-double-forwards (concatenate 'string start "/" finish))) s))) (defun kill-forwards ( s ) (let ((pos (search "/" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (1+ pos)))) (kill-forwards (concatenate 'string start "\\" finish))) s))) (defun kill-double-backs ( s ) (let ((pos (search "\\\\" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (+ pos 2)))) (kill-double-backs (concatenate 'string start "\\" finish))) s))) (defun split-by-one-fs (string) (loop for i = 0 then (1+ j) as j = (position #\/ string :start i) collect (subseq string i j) while j)) ; Remove dos colon for MSYS and \\ (defun msysarise (s) (if (equal (char s 1) #\:) (kill-double-forwards (kill-backs (concatenate 'string "/" (subseq s 0 1) (subseq s 2)))) (kill-double-forwards (kill-backs s)))) (setq *msys-system-directory* (msysarise *system-directory*)) ;; The following few lines remove the lib/gcl-???/unixport string. ;; Can't do this by simple string substitution as W98 paths are shortened. ;; All depends on path format including end separator. ; Canonicalise directory separators (setq *root-directory* (kill-double-forwards (kill-backs *system-directory*))) ; Remove end dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove unixport and dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *root-directory* (subseq *root-directory* 0 (1+ (search "/" *root-directory* :from-end t)))) ; Canonicalise directory separators (setq *msys-root-directory* (kill-double-forwards (kill-backs *msys-system-directory*))) ; Remove end dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove unixport and dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (1+ (search "/" *msys-root-directory* :from-end t)))) (setq *lib-directory* (format nil "~a~a" *root-directory* "lib/gcl-@VERSION@/")) (setq *h-directory* (format nil "~a~a" *msys-root-directory* "/lib/gcl-@VERSION@/h")) (setq *bin-directory* (format nil "~a~a" *root-directory* "bin/")) (setq gclscript (format nil "~a~a" *bin-directory* "gcl")) (with-open-file (s gclscript :direction :output :if-exists :supersede) (format s "#!/bin/sh~%") (format s "# export C_INCLUDE_PATH=~a~%" *h-directory* ) (format s "export PATH=~a/mingw/bin:~a/lib/gcl-@VERSION@/unixport:${PATH}~%" *msys-root-directory* *msys-root-directory* ) (format s "exec ~a@FLISP@.exe -dir ~a -libdir ~a -eval \"(setq si::*allow-gzipped-file* t)\" \"$@\"" *msys-system-directory* (kill-double-forwards *system-directory*) *lib-directory* )) ; Now make a batch file to launch GCL (setq *dos-system-directory* (kill-double-backs (kill-forwards *system-directory*))) ; Now make a batch file to launch GCL (setq *dos-root-directory* (kill-double-backs (kill-forwards *dos-system-directory*))) ; Remove end dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove unixport and dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (1+ (search "\\" *dos-root-directory* :from-end t)))) (setq *dos-h-directory* (format nil "~a~a" *dos-root-directory* "lib\\gcl-@VERSION@\\h")) (setq *dos-bin-directory* (format nil "~a~a" *dos-root-directory* "bin\\")) (setq gclbatch (format nil "~a~a" *bin-directory* "gcl.bat")) ;; Output CRLF line terminated batch file (setf crstr (make-string 1 :initial-element #\Return)) (setf lfstr (make-string 1 :initial-element #\Linefeed)) (defun crlf (s) (format s "~a~a" crstr lfstr)) (with-open-file (s gclbatch :direction :output :if-exists :supersede) (format s "@echo off") (crlf s) (format s "REM set C_INCLUDE_PATH=~a" *dos-h-directory* ) (crlf s) (format s "path ~amingw\\bin;~alib\\gcl-@VERSION@\\unixport;%PATH%" *dos-root-directory* *dos-root-directory* ) (crlf s) (format s "start ~a@FLISP@.exe -dir ~a -libdir ~a -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9" *dos-system-directory* (kill-double-forwards *system-directory*) *lib-directory* ) (crlf s)) (quit) gcl-2.6.14/windows/sysdir.bat.in0000644000175000017500000000033614360276512015101 0ustar cammcammcd %1 echo (setq si::*system-directory* (namestring(truename (make-pathname :name nil :type nil :defaults (si::argv 0))))) (si::save-system "modified.exe") | @FLISP@.exe del @FLISP@.exe ren modified.exe @FLISP@.exe pause gcl-2.6.14/windows/.gitignore0000644000175000017500000000003714360276512014455 0ustar cammcammgcl.iss install.lsp sysdir.bat gcl-2.6.14/RELEASE-2.5.10000644000175000017500000001242514360276512012443 0ustar cammcammRELEASE NOTES FOR 2.5.1: ======================== The GNU Common Lisp (GCL) development team is pleased to release Version 2.5.1, the first major release since the untimely death of the former maintainer Dr William Schelter over a year ago. This release is dedicated to his memory. The project is now hosted on http://savannah.gnu.org/projects/gcl/ and is maintained and developed by a team of thirteen programmers. Our home page lives at http://www.gnu.org/software/gcl/. This release stabilizes the CLtL1 compliant build of GCL on most major Unices including 11 Debian Linux 64 and 32 bit architectures and modern versions of Microsoft Windows (TM). A rapidly progressing, partially ANSI compliant version is also available on the Linux platforms. GCL plays a substantial role in development of the Maxima computer algebra system (http://maxima.sourceforge.net/), ACL2, a computational logic system (http://www.cs.utexas.edu/users/moore/acl2/), and the forthcoming public release of the Axiom computer algebra system.. The compiler is a descendant of the famous KCL and AKCL Common Lisp compilers and is licensed under version two of the GNU Library General Public License. As with any Lisp system GCL is a lot of fun to work with. We welcome all comments and feedback. Developers are particularly welcome too. You will find that the project offers a wide variety of challenges on various platforms to anyone with an interest in compilers, low level C programming or Common Lisp. ----- Features: * Compiles itself, maxima, and acl2, passing all tests, on 11 Debian GNU/Linux platforms (i386, sparc, powerpc, s390, ia64, alpha, mips, mipsel, hppa, arm, and m68k), Sparc Solaris, and recent Windows systems. * Compilation to native object code. Lisp disassembly shows intermediate C source and native assembler. * Native code relocation on all supported platforms except alpha, mips, mipsel, ia64, and hppa. * Can save its running memory image to a file on all systems where native object code relocation is supported, thus producing standalone executables. * Compiles Lisp function calls to C function calls with inlined arguments, when function proclamation/declamations are made. * Quite fast, particularly if one pre-allocates memory to be commensurate with that typically available on modern computer systems. (see below) * A foreign function interface as flexible in principle as the C interface. * Socket support via streams * Support for numbers of arbitrary precision via the GNU Multiprecision Library. If you build GCL on your own system, multiprecision numerical support will make use of ISA extension instructions available on your system for maximum large number performance. * An exact garbage collector with no (known) leaks. * An ANSI mode on Unix systems which passes approximately 97% of the ANSI compliance tests currently developed for the project. On Debian GNU/Linux systems, this mode can be selected by setting the GCL_ANSI environment variable to any non-empty string. See /usr/share/doc/gcl/test_results on Debian GNU/Linux systems. * An MPI extension for cluster computing support. See the website for details. * A long history of leveraging GCC compiler technology for use in production lisp applications. ----- GCL is one of the oldest Lisp systems still in use, and as such has served as the basis for large lisp applications when computers were much more limited than they are today, particularly in terms of available memory. Considerable effort was therefore made in the past to keep the memory image as small as possible. As of the present time, the GCL team has not tuned the default memory allocation scheme to be more in line with modern systems. One can therefore often get significant performance increases by preallocating memory, as in for example (progn (si::allocate 'cons 10000 t) (si::allocate 'fixnum 200 t) (si::allocate 'symbol 100 t) (si::allocate-relocatable-pages 2000 t) (si::allocate 'cfun 1000 t)) Optimal values will no doubt vary by application and machine. One user/developer reports effects of the following magnitude when using preallocation: ######## Take a look on some funny numbers below. This is time and RAM required to compute ratsimp((x+y+z)^300)$ on Linux AthlonXP 2400+. For GCL run time is in the form T - G = N, where T is the total time as shown by showtime:true; G is total GC tome and N is run time without GC. Lisp Time RAM RAM RAM [sec] before max after T - G = N [Mb] [Mb] [Mb] ===================================================== CLISP 4.6 5.5 29 16 CMUCL 1.6 6.5 31 31 GCL class 5.9 - 5.2 = 0.7 8 24 24 GCL ansi 9.5 - 8.9 = 0.6 9.5 29 29 GCL class 1.0 - 0.4 = 0.6 24 31 31 GCL ansi 1.1 - 0.6 = 0.5 25 32 32 GCL class 0.7 - 0.1 = 0.6 48 55 55 GCL ansi 0.5 - 0.0 = 0.5 49 56 56 ==================================================== ######## TO DO: 1) Full ANSI compliance 2) Native optimized blas support 3) Integrate MPI support 4) GCL as a suported GCC front end. 5) Performance/memory optimization gcl-2.6.14/COPYING.LIB-2.00000755000175000017500000006126114360276512012741 0ustar cammcamm GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! gcl-2.6.14/eval.html0000755000175000017500000000515214360276512012616 0ustar cammcamm Tcl Evaluator-In-A-Page

    Tcl Evaluator-in-a-Page

    [Sun Home | Tcl Plugin | Demos]

    Below is a little evaluator for Tcl commands. Type any valid Tcl command in and see the result immediately. Check out our quick tour of the Tcl syntax. For example, to create a new button, type the following: 

    button .b -text hello -background red
pack .b
    When you're done with the button, type: 
    destroy .b
    and it's gone. You may also want to use the puts command to output results from within loops. For example: 
    foreach proc [info procs] {
    puts "$proc [info args $proc]"
}

    To learn more about Tcl, read either Brent Welch'sor John Ousterhout's Tcl books. Many more Tcl and Tk resources are available here.

    Source:

    Here is the source for the evaluator application: 

    
# A frame, scrollbar, and text
frame .eval
set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}]
scrollbar .eval.s -command {.eval.t yview}
pack .eval.s -side left -fill y
pack .eval.t -side right -fill both -expand true
pack .eval -fill both -expand true

# Insert the prompt and initialize the limit mark
.eval.t insert insert "Tcl eval log\n"
set prompt "tcl> "
.eval.t insert insert $prompt
.eval.t mark set limit insert
.eval.t mark gravity limit left
focus .eval.t

# Keybindings that limit input and eval things
bind .eval.t <Return> { _Eval .eval.t ; break }
bind .eval.t <Any-Key> {
	if [%W compare insert < limit] {
		%W mark set insert end
	}
}
bindtags .eval.t {.eval.t Text all}

proc _Eval { t } {
	global prompt
	set command [$t get limit end]
	if [info complete $command] {
		$t insert insert \n
		set err [catch {uplevel #0 $command} result]
		if {[string length $result] > 0} {
		    $t insert insert $result\n
		}
		$t insert insert $prompt
		$t see insert
		$t mark set limit insert
		return
	} else {
		$t insert insert \n
	}
}
proc puts {args} {
    if {[string match -nonewline* $args]} {
	set args [lrange $args 1 end]
	set nonewline 1
    }
    .eval.t insert end [lindex $args end]	;# Ignore file specifier
    if ![info exists nonewline] {
	.eval.t insert end \n
    }
}
    gcl-2.6.14/README.wine0000644000175000017500000000053314360276512012615 0ustar cammcammOn Debian, for example, gcl can be run and tested under wine as follows: (as root) aptitude install mingw32 mingw32-runtime mingw32-binutils wine If necessary, as root update-binfmts --enable wine Then as a normal user, export PATH=/usr/i586-mingw32msvc/bin:$PATH export CC=/usr/bin/i586-mingw32msvc-gcc ./configure --host=mingw32 && make gcl-2.6.14/clcs/0000755000175000017500000000000014360276512011717 5ustar cammcammgcl-2.6.14/clcs/myload.lisp0000644000175000017500000000021414360276512014072 0ustar cammcamm(load "gcl_clcs_precom.lisp") (load "gcl_clcs_handler.lisp") (load "gcl_clcs_conditions.lisp") (load "gcl_clcs_condition_definitions.lisp") gcl-2.6.14/clcs/gcl_clcs_conditions.lisp0000755000175000017500000000577314360276512016631 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- ;(in-package "CONDITIONS" :USE '(:cl #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) (in-package :conditions) (defun slot-sym (base slot) (values (intern (concatenate 'string (string base) "-" (string slot))))) (defun coerce-to-fn (x y) (cond ((stringp x) `(lambda (c s) (declare (ignore c)) (write-string ,x s))) ((symbolp x) x) ((atom x) nil) ((eq (car x) 'lambda) x) ((stringp (car x)) `(lambda (c s) (declare (ignorable c)) (call-next-method) (format s ,(car x) ,@(mapcar (lambda (st) `(if (slot-boundp c ',st) (,(slot-sym y st) c) 'unbound)) (cdr x))))))) (defun default-report (x) `(lambda (c s) (call-next-method) (format s "~s " ',x))) (defmacro define-condition (name parent-list slot-specs &rest options) (unless (or parent-list (eq name 'condition)) (setq parent-list (list 'condition))) (let* ((report-function nil) (default-initargs nil) (documentation nil)) (do ((o options (cdr o))) ((null o)) (let ((option (car o))) (case (car option) (:report (setq report-function (coerce-to-fn (cadr option) name))) (:default-initargs (setq default-initargs option)) (:documentation (setq documentation (cadr option))) (otherwise (cerror "ignore this define-condition option." "invalid define-condition option: ~s" option))))) `(progn (eval-when (compile) (setq pcl::*defclass-times* '(compile load eval))) ,(if default-initargs `(defclass ,name ,parent-list ,slot-specs ,default-initargs) `(defclass ,name ,parent-list ,slot-specs)) (eval-when (compile load eval) ; (setf (get ',name 'documentation) ',documentation) (setf (get ',name 'si::s-data) nil)) ,@(when report-function `((defmethod print-object ((x ,name) stream) (if *print-escape* (call-next-method) (,report-function x stream))))) ',name))) (eval-when (compile load eval) (define-condition condition nil nil)) (defmethod pcl::make-load-form ((object condition) &optional env) (declare (ignore env)) (error "~@" 'pcl::make-load-form object)) (mapc 'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject))) (defun conditionp (object) (typep object 'condition)) (defun is-condition (x) (conditionp x)) (defun is-warning (x) (typep x 'warning)) (defmethod print-object ((x condition) stream) (let ((y (class-name (class-of x)))) (if *print-escape* (format stream "#<~s.~d>" y (unique-id x)) (format stream "~a: " y))));(type-of x) (defun make-condition (type &rest slot-initializations) (when (and (consp type) (eq (car type) 'or)) (return-from make-condition (apply 'make-condition (cadr type) slot-initializations)));FIXME (unless (condition-class-p type) (error 'simple-type-error :datum type :expected-type '(satisfies condition-class-p) :format-control "not a condition type: ~s" :format-arguments (list type))) (apply 'make-instance type slot-initializations)) gcl-2.6.14/clcs/gcl_clcs_handler.lisp0000755000175000017500000000273514360276512016070 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package :conditions) (defmacro handler-bind (bindings &body forms) (declare (optimize (safety 2))) `(let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) *handler-clusters*))) ,@forms)) (defmacro handler-case (form &rest cases) (declare (optimize (safety 2))) (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (gensym)) (error-return (gensym))) `(block ,error-return (multiple-value-call (lambda ,@(cdr no-error-clause)) (block ,normal-return (return-from ,error-return (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) (let ((block (gensym))(var (gensym))(tcases (mapcar (lambda (x) (cons (gensym) x)) cases))) `(block ,block (let (,var) (declare (ignorable ,var)) (tagbody (handler-bind ,(mapcar (lambda (x &aux (tag (pop x))(type (pop x))(ll (car x))) (list type `(lambda (x) ,(if ll `(setq ,var x) `(declare (ignore x))) (go ,tag)))) tcases) (return-from ,block ,form)) ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x)) (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body)))) tcases)))))))) (defmacro ignore-errors (&rest forms) `(handler-case (progn ,@forms) (error (condition) (values nil condition)))) gcl-2.6.14/clcs/loading.lisp0000755000175000017500000000124014360276512014225 0ustar cammcamm(defun jamie-load-clcs (&optional (mode :compiled)) (let ((files (list ;"package" "clcs_precom" "clcs_macros" "clcs_restart" "clcs_handler" "clcs_debugger" "clcs_conditions" "clcs_condition_definitions" "clcs_kcl_cond" "clcs_top_patches" "clcs_install"))) ; (load "package.lisp") (when (eql :compile mode) ; (load "package.lisp") (load "clcs_precom.lisp")) (mapc #'(lambda (file) (ecase mode (:interpreted (load (format nil "~A.lisp" file))) (:compiled (load (format nil "~A.o" file))) (:compile (compile-file (format nil "~A.lisp" file) :c-file t :h-file t :data-file t :system-p t)))) files))) gcl-2.6.14/clcs/makefile0000644000175000017500000000234514360276512013423 0ustar cammcamm-include ../makedefs COMPILE_FILE=./saved_clcs_gcl$(EXE) ./ -system-p -c-file -data-file \ -o-file nil -h-file -compile FILES:=$(shell ls -1 gcl_clcs_*.lisp | sed 's,\.lisp,,1') all: $(addsuffix .c,$(FILES)) $(addsuffix .o,$(FILES)) saved_clcs_gcl: ../unixport/saved_pcl_gcl$(EXE) echo '(load "package.lisp")(load "myload.lisp")(si::save-system "$@")' | $< $(| |top - base| ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." internal-simple-control-error) ; || |args| ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." internal-simple-control-error) ; || |args| ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; || ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." internal-simple-control-error) ; || |key| ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| ("FEundefined_function" :undefined-function "The function ~S is undefined." internal-undefined-function :name) ("FEinvalid_function" :invalid-function "~S is invalid as a function." internal-simple-program-error) ; |obj| ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ but ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("keyword_value_mismatch" :error "Keywords and values do not match." internal-simple-error) ;?? ("not_a_keyword" :error "~S is not a keyword." internal-simple-error) ;?? ("illegal_declare" :invalid-form "~S is an illegal declaration form." internal-simple-program-error) ("not_a_symbol" :invalid-variable "~S is not a symbol." internal-simple-error) ;?? ("not_a_variable" :invalid-variable "~S is not a variable." internal-simple-program-error) ("illegal_index" :error "~S is an illegal index to ~S." internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ("end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ("open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ("open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ("open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ("close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ("close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ("too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ("cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ("cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ("cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ("cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) )) (initialize-internal-error-table) (defun condition-backtrace (condition) (let* ((*debug-io* *error-output*) (si::*ihs-base* (1+ si::*ihs-top*)) (si::*ihs-top* (1- (si::ihs-top))) (si::*current-ihs* si::*ihs-top*) (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) (1+ (si::frs-top)))) (si::*frs-top* (si::frs-top)) (si::*break-env* nil)) (format *error-output* "~%~A~%" condition) (si::simple-backtrace))) (defvar *error-set-break-p* nil) (defun clcs-error-set (form) (let ((cond nil)) (restart-case (handler-bind ((error #'(lambda (condition) (unless (or si::*break-enable* *error-set-break-p*) (condition-backtrace condition) (return-from clcs-error-set condition)) (setq cond condition) nil))) (values-list (cons nil (multiple-value-list (eval form))))) (si::error-set () :report (lambda (stream) (format stream "~S" `(si::error-set ',form))) cond)))) (eval-when (compile load eval) (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties (setf (symbol-function symbol) (symbol-function symbol))) (reset-function 'si::error-set) (reset-function 'load) (reset-function 'open) ) (setq compiler::*compiler-break-enable* t) (defun compiler::cmp-toplevel-eval (form) (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* compiler::*compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) gcl-2.6.14/clcs/unused/test4.lisp0000755000175000017500000000105214360276512015157 0ustar cammcamm(IN-PACKAGE "CONDITIONS") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) gcl-2.6.14/clcs/unused/doload.lisp0000755000175000017500000000071214360276512015360 0ustar cammcamm (defun file-name-directory (path) (let ((pa (pathname path))) (namestring (make-pathname :directory (pathname-directory path) )))) (let ((pa (file-name-directory si::*LOAD-PATHNAME*)) (files '("package" "precom" "macros" "restart" "handler" "debugger" "conditions" "condition-definitions" "kcl-cond" "top-patches" "install"))) (dolist (v files) (setq v (si::file-search v (list pa) '(".o" ".lisp"))) (load v))) gcl-2.6.14/clcs/unused/test2.lisp0000755000175000017500000000305514360276512015162 0ustar cammcamm(in-package "conditions") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-simple-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) gcl-2.6.14/clcs/gcl_clcs_precom.lisp0000755000175000017500000000032414360276512015730 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) #+pcl (pcl::precompile-random-code-segments clcs) gcl-2.6.14/clcs/gcl_cmpinit.lsp0000644000175000017500000000033014360276512014723 0ustar cammcamm;(proclaim '(optimize (safety 2) (space 3))) (setq compiler::*eval-when-defaults* '(compile eval load)) (setq compiler::*compile-ordinaries* t) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ;;;;; gcl-2.6.14/clcs/sys-proclaim.lisp0000644000175000017500000000457614360276512015246 0ustar cammcamm (COMMON-LISP::IN-PACKAGE "CONDITIONS") (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) COMMON-LISP::HANDLER-BIND COMMON-LISP::DEFINE-CONDITION COMMON-LISP::HANDLER-CASE COMMON-LISP::IGNORE-ERRORS CONDITIONS::COERCE-TO-FN CONDITIONS::SLOT-SYM)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::*) COMMON-LISP::*) COMMON-LISP::MAKE-CONDITION)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::*) CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (TYPE-ERROR T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (INTERNAL-CONDITION T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (FILE-ERROR T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (CASE-FAILURE T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (UNBOUND-SLOT T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (ABORT-FAILURE T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (UNDEFINED-FUNCTION T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (UNBOUND-VARIABLE T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (PRINT-NOT-READABLE T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (CELL-ERROR T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (STREAM-ERROR T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (ARITHMETIC-ERROR T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (END-OF-FILE T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (SIMPLE-CONDITION T))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (PACKAGE-ERROR T))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T COMMON-LISP::T) COMMON-LISP::T) CONDITIONS::|(PCL::FAST-METHOD MAKE-LOAD-FORM (CONDITION))| CONDITIONS::|(PCL::FAST-METHOD PRINT-OBJECT (CONDITION T))|)) (COMMON-LISP::PROCLAIM '(COMMON-LISP::FTYPE (COMMON-LISP::FUNCTION (COMMON-LISP::T) COMMON-LISP::T) CONDITIONS::CONDITIONP CONDITIONS::IS-CONDITION CONDITIONS::IS-WARNING CONDITIONS::DEFAULT-REPORT)) gcl-2.6.14/clcs/gcl_clcs_condition_definitions.lisp0000755000175000017500000001235514360276512021033 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE :CONDITIONS) (define-condition warning (condition) nil) (define-condition style-warning (warning) nil) (define-condition serious-condition (condition) nil) (define-condition error (serious-condition) nil) (define-condition simple-condition (condition) ((format-control :type string :initarg :format-control :reader simple-condition-format-control :initform "") (format-arguments :initarg :format-arguments :reader simple-condition-format-arguments :initform nil)) (:report (lambda (c s) (call-next-method) (apply 'format s (simple-condition-format-control c) (simple-condition-format-arguments c))))) (define-condition simple-warning (simple-condition warning) nil) (define-condition simple-error (simple-condition error) nil) (define-condition storage-condition (serious-condition) nil) (define-condition stack-overflow (storage-condition) nil) (define-condition storage-exhausted (storage-condition) nil) (define-condition type-error (error) ((datum :initarg :datum :reader type-error-datum) (expected-type :initarg :expected-type :reader type-error-expected-type)) (:report ("~s is not of type ~s: " datum expected-type))) (define-condition simple-type-error (simple-error type-error) nil) (define-condition program-error (error) nil) (define-condition control-error (error) nil) (define-condition parse-error (error) nil) (define-condition print-not-readable (error) ((object :initarg :object :reader print-not-readable-object)) (:report ("Object ~s is unreadable: " object))) (define-condition stream-error (error) ((stream :initarg :stream :reader stream-error-stream)) (:report ("Stream error on stream ~s: " stream))) (define-condition reader-error (parse-error stream-error) nil) (define-condition end-of-file (stream-error) nil (:report ("Unexpected end of file: "))) (define-condition file-error (error) ((pathname :initarg :pathname :reader file-error-pathname)) (:report ("File error on ~s: " pathname))) (define-condition pathname-error (file-error) nil) (define-condition package-error (error) ((package :initarg :package :reader package-error-package)) (:report ("Package error on ~s: " package))) (define-condition cell-error (error) ((name :initarg :name :reader cell-error-name)) (:report ("Cell error on ~s: " name))) (define-condition unbound-variable (cell-error) nil (:report ("Unbound variable: "))) (define-condition unbound-slot (cell-error) ((instance :initarg :instance :reader unbound-slot-instance)) (:report ("Slot is unbound in ~s: " instance))) (define-condition undefined-function (cell-error) nil (:report ("Undefined function: "))) (define-condition arithmetic-error (ERROR) ((operation :initarg :operation :reader arithmetic-error-operation) (operands :initarg :operands :reader arithmetic-error-operands)) (:report ("~%Arithmetic error when performing ~s on ~s: " operation operands))) (define-condition division-by-zero (arithmetic-error) nil) (define-condition floating-point-overflow (arithmetic-error) nil) (define-condition floating-point-invalid-operation (arithmetic-error) nil) (define-condition floating-point-inexact (arithmetic-error) nil) (define-condition floating-point-underflow (arithmetic-error) nil) (define-condition case-failure (type-error) ((name :initarg :name :reader case-failure-name) (possibilities :initarg :possibilities :reader case-failure-possibilities)) (:report (lambda (condition stream) (format stream "~s fell through ~s expression.~%wanted one of ~:s." (type-error-datum condition) (case-failure-name condition) (case-failure-possibilities condition))))) (define-condition abort-failure (control-error) nil (:report "abort failed.")) (define-condition internal-condition (condition) ((function-name :initarg :function-name :reader internal-condition-function-name :initform nil)) (:report (lambda (condition stream) (when (internal-condition-function-name condition) (format stream "Condition in ~S [or a callee]: " (internal-condition-function-name condition))) (call-next-method)))) (define-condition internal-simple-condition (internal-condition simple-condition) nil) (define-condition internal-simple-error (internal-condition simple-error) nil) (define-condition internal-simple-type-error (internal-condition simple-type-error) nil) (define-condition internal-simple-warning (internal-condition simple-warning) nil) #.`(progn ,@(mapcar (lambda (x) `(define-condition ,(intern (concatenate 'string "INTERNAL-SIMPLE-" (string x))) (internal-condition simple-condition ,x) nil)) `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning unbound-variable unbound-slot undefined-function division-by-zero case-failure abort-failure ,@(mapcar (lambda (x) (intern (concatenate 'string "FLOATING-POINT-" (string x)))) '(overflow underflow invalid-operation inexact)) ,@(mapcar (lambda (x) (intern (concatenate 'string (string x) "-ERROR"))) '(program control parse stream reader file package cell arithmetic pathname))))) gcl-2.6.14/clcs/package.lisp0000755000175000017500000000212414360276512014205 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: ("CONDITIONS" :USE "LISP" :SHADOW ("BREAK" "ERROR" "CERROR" "WARN" "CHECK-TYPE" "ASSERT" "ETYPECASE" "CTYPECASE" "ECASE" "CCASE")); Base: 10 -*- ; From arisia.xerox.com:/cl/conditions/cond18.lisp ;;; ;;; CONDITIONS ;;; ;;; This is a sample implementation. It is not in any way intended as the definition ;;; of any aspect of the condition system. It is simply an existence proof that the ;;; condition system can be implemented. ;;; ;;; While this written to be "portable", this is not a portable condition system ;;; in that loading this file will not redefine your condition system. Loading this ;;; file will define a bunch of functions which work like a condition system. Redefining ;;; existing condition systems is beyond the goal of this implementation attempt. (make-package :conditions :use '(:lisp)) (in-package :conditions :use '(:lisp)) (import '(si::*handler-clusters* si::unique-id si::condition-class-p si::make-condition)) (defvar *this-package* (find-package :conditions)) (import 'si::(clines defentry defcfun object void int double)) gcl-2.6.14/clcs/readme0000755000175000017500000000035114360276512013101 0ustar cammcamm =====Compile the system========= (si::chdir "clcs") (load "loading.lisp") (jamie-load-clcs :compile) ======== load the system ======== (si::chdir "clcs") (load "package.lisp") (load "loading.lisp") (jamie-load-clcs :compiled) gcl-2.6.14/clcs/.gitignore0000644000175000017500000000002714360276512013706 0ustar cammcamm*.c *.h saved_clcs_gcl gcl-2.6.14/utils/0000755000175000017500000000000014360276512012133 5ustar cammcammgcl-2.6.14/utils/repls5.sed0000755000175000017500000000426014360276512014047 0ustar cammcamm s:s[.]Sfdef:s.s_sfdef:g s:s[.]Bind:s.s_dbind:g s:s[.]Fillp:s.s_fillp:g s:s[.]Body:s.s_self:g s:s[.]Gfdef:s.s_gfdef:g s:s[.]Plist:s.s_plist:g s:s[.]Hpack:s.s_hpack:g s:s[.]Type:s.s_type:g s:s[.]Mflag:s.s_mflag:g s:p[.]Name:p.p_name:g s:p[.]NickCames:p.p_nicknames:g s:p[.]Shadowings:p.p_shadowings:g s:p[.]UseList:p.p_uselist:g s:p[.]UsedByList:p.p_usedbylist:g s:p[.]InternalSize:p.p_internal_size:g s:p[.]ExternalSize:p.p_external_size:g s:p[.]InternalFp:p.p_internal_fp:g s:p[.]ExternalFp:p.p_external_fp:g s:p[.]Internal:p.p_internal:g s:p[.]External:p.p_external:g s:p[.]Link:p.p_link:g s:c[.]Cdr:c.c_cdr:g s:c[.]Car:c.c_car:g s:hte[.]Key:hte.hte_key:g s:hte[.]Value:hte.hte_value:g s:ht[.]Body:ht.ht_self:g s:ht[.]RehashSize:ht.ht_rhsize:g s:ht[.]RehashThresh:ht.ht_rhthresh:g s:ht[.]NumberEntries:ht.ht_nent:g s:ht[.]Size:ht.ht_size:g s:ht[.]Test:ht.ht_test:g s:a[.]Rank:a.a_rank:g s:v[.]Hasfillp:v.v_hasfillp:g s:a[.]Adjustable:a.a_adjustable:g s:a[.]Dim:a.a_dim:g s:a[.]Dims:a.a_dims:g s:v[.]Fillp:v.v_fillp:g s:a[.]Body:a.a_self:g s:a[.]Displaced:a.a_displaced:g s:a[.]Elttype:a.a_elttype:g s:a[.]Offset:a.a_offset:g s:ust[.]HasFillp:ust.ust_hasfillp:g s:ust[.]Adjustable:ust.ust_adjustable:g s:ust[.]Dim:ust.ust_dim:g s:ust[.]Fillp:ust.ust_fillp:g s:ust[.]Body:ust.ust_self:g s:ust[.]Displaced:ust.ust_displaced:g s:st[.]HasFillp:st.st_hasfillp:g s:st[.]Adjustable:st.st_adjustable:g s:st[.]Dim:st.st_dim:g s:st[.]Fillp:st.st_fillp:g s:st[.]Body:st.st_self:g s:st[.]Displaced:st.st_displaced:g s:bv[.]HasFillp:bv.bv_hasfillp:g s:bv[.]Adjustable:bv.bv_adjustable:g s:bv[.]Dim:bv.bv_dim:g s:bv[.]Fillp:bv.bv_fillp:g s:bv[.]Body:bv.bv_self:g s:bv[.]Displaced:bv.bv_displaced:g s:bv[.]Elttype:bv.bv_elttype:g s:bv[.]Offset:bv.bv_offset:g s:v[.]Hasfillp:v.v_hasfillp:g s:v[.]Adjustable:v.v_adjustable:g s:v[.]Dim:v.v_dim:g s:v[.]Fillp:v.v_fillp:g s:v[.]Body:v.v_self:g s:v[.]Displaced:v.v_displaced:g s:v[.]Elttype:v.v_elttype:g s:v[.]Offset:v.v_offset:g s:big[.]Body:big.big_self:g s:big[.]Length:big.big_length:g s:rat[.]Den:rat.rat_den:g s:rat[.]Num:rat.rat_num:g s:cmp[.]Real:cmp.cmp_real:g s:cmp[.]Imag:cmp.cmp_imag:g s:ch[.]Code:ch.ch_code:g s:ch[.]Font:ch.ch_font:g s:ch[.]Bits:ch.ch_bits:g gcl-2.6.14/utils/repls4.sed0000755000175000017500000000243414360276512014047 0ustar cammcamm s:CONTROL_STACK_SIZE:FRSSIZE:g s:CONTROL_STACK_EXTRA:FRSGETA:g s:CtlJmpbuf:frs_jmpbuf:g s:CtlLex:frs_lex:g s:CtlBdsTop:frs_bds_top:g s:CtlClass:frs_class:g s:CtlTag:frs_val:g s:CtlTop:frs_top:g s:CtlCallHist:frs_CallHist:g s:CtlPush:frs_push:g s:CtlPop:frs_pop:g s:CtlCallHist:frs_ihs:g s:CurrentJumpTag:nlj_tag:g s:JumpInProgress:nlj_active:g s:FinalDestinationFrame:nlj_fr:g s:CtlTop:frs_top:g s:CtlLimit:frs_limit:g s:CtlStackOrigin:frs_org:g s:ControlPtr:frame_ptr:g s:Control:frame:g s:SpecialBinding:bds_bd:g s:BdTop:bds_top:g s:BdLimit:bds_limit:g s:BdStackOrigin:bds_org:g s:BdSymbol:bds_sym:g s:BdValue:bds_val:g s:SpecialBindingPtr:bds_ptr:g s:BdSp:bds_bind:g s:BdCheck:bds_check:g s:UnBdSp:bds_unwind1:g s:BINDING_STACK_SIZE:BDSSIZE:g s:BINDING_STACK_EXTRA:BDSGETA:g s:CallHistFunction:ihs_function:g s:CallHistBase:ihs_base:g s:CallHistory:invocation_history:g s:CallHistPtr:ihs_ptr:g s:CallHistTop:ihs_top:g s:CallHistLimit:ihs_limit:g s:CallHistOrigin:ihs_org:g s:CallHistPush:ihs_push:g s:CallHistPop:ihs_pop:g s:sLnil:Cnil:g s:ctl_ANY_CATCH:FRS_CATCHALL:g s:ctl_TAGGED_CATCH:FRS_CATCH:g s:ctl_PROTECT:FRS_PROTECT:g s:CtlClass:fr_class:g s:VsLimit:vs_limit:g s:VsTop:vs_top:g s:VsOrigin:vs_org:g s:VsBase:vs_base:g s:VsPush:vs_push:g s:VsCheck:vs_check:g gcl-2.6.14/utils/revstruct.sed0000755000175000017500000001040614360276512014675 0ustar cammcamm s:s[.]Sfdef:s.s_sfdef:g s:s[.]Bind:s.s_dbind:g s:s[.]Fillp:s.s_fillp:g s:s[.]Body:s.s_self:g s:s[.]Gfdef:s.s_gfdef:g s:s[.]Plist:s.s_plist:g s:s[.]Hpack:s.s_hpack:g s:s[.]Type:s.s_type:g s:s[.]Mflag:s.s_mflag:g s:p[.]Name:p.p_name:g s:p[.]NickCames:p.p_nicknames:g s:p[.]Shadowings:p.p_shadowings:g s:p[.]UseList:p.p_uselist:g s:p[.]UsedByList:p.p_usedbylist:g s:p[.]InternalSize:p.p_internal_size:g s:p[.]ExternalSize:p.p_external_size:g s:p[.]InternalFp:p.p_internal_fp:g s:p[.]ExternalFp:p.p_external_fp:g s:p[.]Internal:p.p_internal:g s:p[.]External:p.p_external:g s:p[.]Link:p.p_link:g s:c[.]Cdr:c.c_cdr:g s:c[.]Car:c.c_car:g s:hte[.]Key:hte.hte_key:g s:hte[.]Value:hte.hte_value:g s:ht[.]Body:ht.ht_self:g s:ht[.]RehashSize:ht.ht_rhsize:g s:ht[.]RehashThresh:ht.ht_rhthresh:g s:ht[.]NumberEntries:ht.ht_nent:g s:ht[.]Size:ht.ht_size:g s:ht[.]Test:ht.ht_test:g s:a[.]Rank:a.a_rank:g s:v[.]Hasfillp:v.v_hasfillp:g s:a[.]Adjustable:a.a_adjustable:g s:a[.]Dim:a.a_dim:g s:a[.]Dims:a.a_dims:g s:v[.]Fillp:v.v_fillp:g s:a[.]Body:a.a_self:g s:a[.]Displaced:a.a_displaced:g s:a[.]Elttype:a.a_elttype:g s:a[.]Offset:a.a_offset:g s:ust[.]HasFillp:ust.ust_hasfillp:g s:ust[.]Adjustable:ust.ust_adjustable:g s:ust[.]Dim:ust.ust_dim:g s:ust[.]Fillp:ust.ust_fillp:g s:ust[.]Body:ust.ust_self:g s:ust[.]Displaced:ust.ust_displaced:g s:st[.]HasFillp:st.st_hasfillp:g s:st[.]Adjustable:st.st_adjustable:g s:st[.]Dim:st.st_dim:g s:st[.]Fillp:st.st_fillp:g s:st[.]Body:st.st_self:g s:st[.]Displaced:st.st_displaced:g s:bv[.]HasFillp:bv.bv_hasfillp:g s:bv[.]Adjustable:bv.bv_adjustable:g s:bv[.]Dim:bv.bv_dim:g s:bv[.]Fillp:bv.bv_fillp:g s:bv[.]Body:bv.bv_self:g s:bv[.]Displaced:bv.bv_displaced:g s:bv[.]Elttype:bv.bv_elttype:g s:bv[.]Offset:bv.bv_offset:g s:v[.]Hasfillp:v.v_hasfillp:g s:v[.]Adjustable:v.v_adjustable:g s:v[.]Dim:v.v_dim:g s:v[.]Fillp:v.v_fillp:g s:v[.]Body:v.v_self:g s:v[.]Displaced:v.v_displaced:g s:v[.]Elttype:v.v_elttype:g s:v[.]Offset:v.v_offset:g s:big[.]Body:big.big_self:g s:big[.]Length:big.big_length:g s:rat[.]Den:rat.rat_den:g s:rat[.]Num:rat.rat_num:g s:cmp[.]Real:cmp.cmp_real:g s:cmp[.]Imag:cmp.cmp_imag:g s:ch[.]Code:ch.ch_code:g s:ch[.]Font:ch.ch_font:g s:ch[.]Bits:ch.ch_bits:g s:lfa[.]Displaced:lfa.lfa_displaced:g s:lfa[.]Elttype:lfa.lfa_elttype:g s:lfa[.]Offset:lfa.lfa_offset:g s:str[.]Def:str.str_def:g s:str[.]Body:str.str_self:g s:sm[.]Fp:sm.sm_fp:g s:sm[.]Object0:sm.sm_object0:g s:sm[.]Object1:sm.sm_object1:g s:sm[.]Int0:sm.sm_int0:g s:sm[.]Int1:sm.sm_int1:g s:sm[.]Buffer:sm.sm_buffer:g s:sm[.]Mode:sm.sm_mode:g s:rte[.]rteChattrib:rte.rte_chattrib:g s:rte[.]rteMacro:rte.rte_macro:g s:rte[.]rteDtab:rte.rte_dtab:g s:rt[.]rtBody:rt.rt_self:g s:pn[.]Host:pn.pn_host:g s:pn[.]Device:pn.pn_device:g s:pn[.]Directory:pn.pn_directory:g s:pn[.]Name:pn.pn_name:g s:pn[.]Type:pn.pn_type:g s:pn[.]Version:pn.pn_version:g s:cf[.]Name:cf.cf_name:g s:cf[.]Body:cf.cf_self:g s:cf[.]Data:cf.cf_data:g s:cc[.]Name:cc.cc_name:g s:cc[.]Body:cc.cc_self:g s:cc[.]Env:cc.cc_env:g s:cc[.]Data:cc.cc_data:g s:cc[.]Turbo:cc.cc_turbo:g s:sfn[.]Name:sfn.sfn_name:g s:sfn[.]Body:sfn.sfn_self:g s:sfn[.]Data:sfn.sfn_data:g s:sfn[.]Argd:sfn.sfn_argd:g s:cl[.]Name:cl.cl_name:g s:cl[.]Body:cl.cl_self:g s:cl[.]Data:cl.cl_data:g s:cl[.]Argd:cl.cl_argd:g s:cl[.]EnvDim:cl.cl_envdim:g s:cl[.]Env:cl.cl_env:g s:vfn[.]Name:vfn.vfn_name:g s:vfn[.]Body:vfn.vfn_self:g s:vfn[.]Data:vfn.vfn_data:g s:vfn[.]Minargs:vfn.vfn_minargs:g s:vfn[.]Maxargs:vfn.vfn_maxargs:g s:cfd[.]Start:cfd.cfd_start:g s:cfd[.]Size:cfd.cfd_size:g s:cfd[.]Fillp:cfd.cfd_fillp:g s:cfd[.]Body:cfd.cfd_self:g s:fixa[.]Rank:fixa.fixa_rank:g s:fixa[.]Adjustable:fixa.fixa_adjustable:g s:fixa[.]Dim:fixa.fixa_dim:g s:fixa[.]Dims:fixa.fixa_dims:g s:fixa[.]Body:fixa.fixa_self:g s:fixa[.]Displaced:fixa.fixa_displaced:g s:fixa[.]Elttype:fixa.fixa_elttype:g s:fixa[.]Offset:fixa.fixa_offset:g s:sfa[.]Rank:sfa.sfa_rank:g s:sfa[.]Adjustable:sfa.sfa_adjustable:g s:sfa[.]Dim:sfa.sfa_dim:g s:sfa[.]Dims:sfa.sfa_dims:g s:sfa[.]Body:sfa.sfa_self:g s:sfa[.]Displaced:sfa.sfa_displaced:g s:sfa[.]Elttype:sfa.sfa_elttype:g s:sfa[.]Offset:sfa.sfa_offset:g s:lfa[.]Rank:lfa.lfa_rank:g s:lfa[.]Adjustable:lfa.lfa_adjustable:g s:lfa[.]Dim:lfa.lfa_dim:g s:lfa[.]Dims:lfa.lfa_dims:g s:lfa[.]Body:lfa.lfa_self:g s:spc[.]Dummy:spc.spc_dummy:g s:"all[.]h":"include.h":g gcl-2.6.14/utils/repls2.sed0000755000175000017500000000011514360276512014037 0ustar cammcamm s:aelt_:aet_:g s:htest_e:htt_e:g s:hashTest:httest:g s:hashEntry:htent:g gcl-2.6.14/utils/repls3.sed0000755000175000017500000000107114360276512014042 0ustar cammcamm!s:/\*[--- ,a-zA-Z_;'.[]*\*/::g s:ucharString:ustring:g s:uct bitVector:uct bitvector:g s:fixnumArray:fixarray:g s:shortFloatArray:sfarray:g s:doubleFloatArray:lfarray:g s:stream_mode:smmode:g s:stream_:smm_:g s:CALL_HISTORY_SIZE:IHSSIZE:g s:CONTROL_STACK_SIZE:FRSSIZE:g s:BINDING_STACK_SIZE:BDSSIZE:g s:VALUE_STACK_SIZE:VSSIZE:g s:CALL_HISTORY_EXTRA:IHSGETA:g s:CONTROL_STACK_EXTRA:FRSGETA:g s:BINDING_STACK_EXTRA:BDSGETA:g s:VALUE_STACK_EXTRA:VSGETA:g s:sLt_body:Ct_body:g s:sLlambda:Slambda:g s:sLquote:Squote:g s:sLspecial:Sspecial:g s:sLfunction:Sfunction:g gcl-2.6.14/utils/repls1.sed0000755000175000017500000000117514360276512014045 0ustar cammcamms:LispCategory:lispunion:g s:structFixnum:fixnum_struct:g s:structDoubleFloat:longfloat_struct:g s:structShortFloat:shortfloat_struct:g s:doublefloat:longfloat:g s:Val:FIXVAL:g s:Val:SFVAL:g s:Val:LFVAL:g s:obj\([^e]\):object\1:g s:DFloat(:lf(:g s:SFloat(:sf(:g s:Imake_doublefloat:make_longfloat:g s:Imake_doublefloat:make_longfloat:g s:AllocData:typemanager:g s:AllocTable:tm_table:g s:current.fs.freelist:tm_free:g s:current.fs.nfree:tm_nfree:g s:FreeList:freelist:g s:->nbytes:->tm_size:g s:Fcall:fcall:g s:AllocObj:alloc_object:g s:c.Car:c.c_car:g s:c.Cdr:c.c_cdr:g s:s.Bind:s.s_dbind:g s:s.Gfdef:s_gfdef:g s:s.Sfdef:s_sfdef:g gcl-2.6.14/utils/replace0000755000175000017500000000025314360276512013474 0ustar cammcamm#!/bin/sh cat $1 | sed -f ../utils/revstruct.sed | sed -f ../utils/repls3.sed | sed -f ../utils/repls2.sed | sed -f ../utils/repls1.sed | sed -f ../utils/repls4.sed gcl-2.6.14/configure0000755000175000017500000112752714360276512012721 0ustar cammcamm#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.71. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, # Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="as_nop=: if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else \$as_nop case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : else \$as_nop exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes else $as_nop as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else $as_nop as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi fi if test "x$CONFIG_SHELL" != x then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='' PACKAGE_TARNAME='' PACKAGE_VERSION='' PACKAGE_STRING='' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_STDIO_H # include #endif #ifdef HAVE_STDLIB_H # include #endif #ifdef HAVE_STRING_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_header_c_list= ac_subst_vars='LTLIBOBJS LIBOBJS use GNU_LD LEADING_UNDERSCORE EXTRA_LOBJS O2FLAGS O3FLAGS NIFLAGS FINAL_CFLAGS ALLOCA NOTIFY TCL_LIBS TCL_DL_LIBS TCL_LIB_SPEC TK_XLIBSW TK_BUILD_LIB_SPEC TK_LIB_SPEC TCL_INCLUDE TK_INCLUDE TK_XINCLUDES TCL_LIBRARY TK_LIBRARY TK_CONFIG_PREFIX TCLSH INFO_DIR EMACS_DEFAULT_EL EMACS_SITE_LISP EMACS HAVE_SIGEMT HAVE_SIGSYS HAVE_SV_ONSTACK USE_CLEANUP HAVE_PUTENV HAVE_SETENV NO_PROFILE RL_LIB RL_OBJS EGREP GREP CLSTANDARD SYSTEM FLISP HAVE_LONG_LONG PAGEWIDTH DOUBLE_BIGENDIAN WORDS_BIGENDIAN LIBIBERTY LIBBFD BUILD_BFD HAVE_OUTPUT_BFD X_CFLAGS X_LIBS XMKMF GMPDIR GMP HAVE_MALLOC_ZONE_MEMALIGN MAKEINFO GCL_CC AWK CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC PRELINK_CHECK host_os host_vendor host_cpu host build_os build_vendor build_cpu build VERSION target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_machine enable_widecons enable_safecdr enable_safecdrdbg enable_prelink enable_vssize enable_bdssize enable_ihssize enable_frssize enable_infodir enable_emacsdir enable_xgcl enable_dlopen enable_statsysbfd enable_dynsysbfd enable_custreloc enable_debug enable_static enable_pic enable_gprof enable_dynsysgmp with_x enable_xdr enable_cstackmax enable_immfix enable_fastimmfix enable_ansi enable_japi enable_readline enable_tcltk enable_tkconfig enable_tclconfig enable_notify ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP XMKMF' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF X features: --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs --enable-widecons will use a three word cons with simplified typing --enable-safecdr will protect cdr from immfix and speed up type processing --enable-safecdrdbg will debug safecdr code --enable-prelink will insist that the produced images may be prelinked --enable-vssize=XXXX will compile in a value stack of size XXX --enable-bdssize=XXXX will compile in a binding stack of size XXX --enable-ihssize=XXXX will compile in a invocation history stack of size XXX --enable-frssize=XXXX will compile in a frame stack of size XXX --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info --enable-emacsdir=XXXX will manually specify the location for elisp files --enable-xgcl=yes will compile in support for XGCL --enable-dlopen uses dlopen for loading objects, which can then not be retained in saved images --enable-statsysbfd uses a static system bfd library for loading and relocating object files --enable-dynsysbfd uses a dynamic shared system bfd library for loading and relocating object files --enable-custreloc uses custom gcl code if available for loading and relocationing object files --enable-debug builds gcl with -g in CFLAGS to enable running under gdb --enable-static will link your GCL against static as opposed to shared system libraries --enable-pic builds gcl with -fPIC in CFLAGS --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source --enable-xdr=yes will compile in support for XDR --enable-cstackmax=xxxx will ensure that the cstack begins below xxxx or fail --enable-immfix will enable an immediate fixnum table above the C stack --enable-fastimmfix=XXXX will reject low immediate fixnums unless 2^XXX can be attained --enable-ansi builds a large gcl aiming for ansi compliance --enable-japi=yes will compile in support for the JAPI graphical interface if present on your system --enable-readline enables command line completion via the readline library --enable-tcltk will try to build gcl-tk --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh --enable-notify=no will disable the automatic notification of gcl maintainers of successful builds/problems Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-x use the X Window System Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor XMKMF Path to xmkmf, Makefile generator for X Window System Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_try_run LINENO # ---------------------- # Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that # executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: program exited with status $ac_status" >&5 printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" else $as_nop eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES # ---------------------------------------------------- # Tries to find if the field MEMBER exists in type AGGR, after including # INCLUDES, setting cache variable VAR accordingly. ac_fn_c_check_member () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 printf %s "checking for $2.$3... " >&6; } if eval test \${$4+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main (void) { static $2 ac_aggr; if (ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$4=yes" else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int main (void) { static $2 ac_aggr; if (sizeof ac_aggr.$3) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$4=yes" else $as_nop eval "$4=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$4 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_member # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. */ #include #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main (void) { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : eval "$3=yes" else $as_nop eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid; break else $as_nop as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_lo=$ac_mid; break else $as_nop as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else $as_nop ac_lo= ac_hi= fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid else $as_nop as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval (void) { return $2; } static unsigned long int ulongval (void) { return $2; } #include #include int main (void) { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : echo >>conftest.val; read $3 &5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else $as_nop eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type ac_configure_args_raw= for ac_arg do case $ac_arg in *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_configure_args_raw " '$ac_arg'" done case $ac_configure_args_raw in *$as_nl*) ac_safe_unquote= ;; *) ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. ac_unsafe_a="$ac_unsafe_z#~" ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; esac cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Test code for whether the C compiler supports C89 (global declarations) ac_c_conftest_c89_globals=' /* Does the compiler advertise C89 conformance? Do not test the value of __STDC__, because some compilers set it to 0 while being otherwise adequately conformant. */ #if !defined __STDC__ # error "Compiler does not advertise C89 conformance" #endif #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated as an "x". The following induces an error, until -std is added to get proper ANSI mode. Curiously \x00 != x always comes out true, for an array size at least. It is necessary to write \x00 == 0 to get something that is true only with -std. */ int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) '\''x'\'' int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), int, int);' # Test code for whether the C compiler supports C89 (body of main). ac_c_conftest_c89_main=' ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); ' # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' // Does the compiler advertise C99 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare // FILE and stderr. #define debug(...) dprintf (2, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK #error "your preprocessor is broken" #endif #if BIG_OK #else #error "your preprocessor is broken" #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) continue; return 0; } // Check varargs and va_copy. static bool test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str = ""; int number = 0; float fnumber = 0; while (*format) { switch (*format++) { case '\''s'\'': // string str = va_arg (args_copy, const char *); break; case '\''d'\'': // int number = va_arg (args_copy, int); break; case '\''f'\'': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); return *str && number && fnumber; } ' # Test code for whether the C compiler supports C99 (body of main). ac_c_conftest_c99_main=' // Check bool. _Bool success = false; success |= (argc != 0); // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[0] = argv[0][0]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' || dynamic_array[ni.number - 1] != 543); ' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' // Does the compiler advertise C11 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif // Check _Alignas. char _Alignas (double) aligned_as_double; char _Alignas (0) no_special_alignment; extern char aligned_as_int; char _Alignas (0) _Alignas (int) aligned_as_int; // Check _Alignof. enum { int_alignment = _Alignof (int), int_array_alignment = _Alignof (int[100]), char_alignment = _Alignof (char) }; _Static_assert (0 < -_Alignof (int), "_Alignof is signed"); // Check _Noreturn. int _Noreturn does_not_return (void) { for (;;) continue; } // Check _Static_assert. struct test_static_assert { int x; _Static_assert (sizeof (int) <= sizeof (long int), "_Static_assert does not work in struct"); long int y; }; // Check UTF-8 literals. #define u8 syntax error! char const utf8_literal[] = u8"happens to be ASCII" "another string"; // Check duplicate typedefs. typedef long *long_ptr; typedef long int *long_ptr; typedef long_ptr long_ptr; // Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. struct anonymous { union { struct { int i; int j; }; struct { int k; long int l; } w; }; int m; } v1; ' # Test code for whether the C compiler supports C11 (body of main). ac_c_conftest_c11_main=' _Static_assert ((offsetof (struct anonymous, i) == offsetof (struct anonymous, w.k)), "Anonymous union alignment botch"); v1.i = 2; v1.w.k = 5; ok |= v1.i != 5; ' # Test code for whether the C compiler supports C11 (complete). ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} ${ac_c_conftest_c11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} ${ac_c_conftest_c11_main} return ok; } " # Test code for whether the C compiler supports C99 (complete). ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} return ok; } " # Test code for whether the C compiler supports C89 (complete). ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} return ok; } " as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" # Auxiliary files required by this configure script. ac_aux_files="config.guess config.sub" # Locations in which to look for auxiliary files. ac_aux_dir_candidates="${srcdir}${PATH_SEPARATOR}${srcdir}/..${PATH_SEPARATOR}${srcdir}/../.." # Search for a directory containing all of the required auxiliary files, # $ac_aux_files, from the $PATH-style list $ac_aux_dir_candidates. # If we don't find one directory that contains all the files we need, # we report the set of missing files from the *first* directory in # $ac_aux_dir_candidates and give up. ac_missing_aux_files="" ac_first_candidate=: printf "%s\n" "$as_me:${as_lineno-$LINENO}: looking for aux files: $ac_aux_files" >&5 as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in $ac_aux_dir_candidates do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying $as_dir" >&5 ac_aux_dir_found=yes ac_install_sh= for ac_aux in $ac_aux_files do # As a special case, if "install-sh" is required, that requirement # can be satisfied by any of "install-sh", "install.sh", or "shtool", # and $ac_install_sh is set appropriately for whichever one is found. if test x"$ac_aux" = x"install-sh" then if test -f "${as_dir}install-sh"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install-sh found" >&5 ac_install_sh="${as_dir}install-sh -c" elif test -f "${as_dir}install.sh"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}install.sh found" >&5 ac_install_sh="${as_dir}install.sh -c" elif test -f "${as_dir}shtool"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}shtool found" >&5 ac_install_sh="${as_dir}shtool install -c" else ac_aux_dir_found=no if $ac_first_candidate; then ac_missing_aux_files="${ac_missing_aux_files} install-sh" else break fi fi else if test -f "${as_dir}${ac_aux}"; then printf "%s\n" "$as_me:${as_lineno-$LINENO}: ${as_dir}${ac_aux} found" >&5 else ac_aux_dir_found=no if $ac_first_candidate; then ac_missing_aux_files="${ac_missing_aux_files} ${ac_aux}" else break fi fi fi done if test "$ac_aux_dir_found" = yes; then ac_aux_dir="$as_dir" break fi ac_first_candidate=false as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. if test -f "${ac_aux_dir}config.guess"; then ac_config_guess="$SHELL ${ac_aux_dir}config.guess" fi if test -f "${ac_aux_dir}config.sub"; then ac_config_sub="$SHELL ${ac_aux_dir}config.sub" fi if test -f "$ac_aux_dir/configure"; then ac_configure="$SHELL ${ac_aux_dir}configure" fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers h/gclincl.h" VERSION=`cat majvers`.`cat minvers` # # Host information # # Make sure we can run config.sub. $SHELL "${ac_aux_dir}config.sub" sun4 >/dev/null 2>&1 || as_fn_error $? "cannot run $SHELL ${ac_aux_dir}config.sub" "$LINENO" 5 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 printf %s "checking build system type... " >&6; } if test ${ac_cv_build+y} then : printf %s "(cached) " >&6 else $as_nop ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "${ac_aux_dir}config.guess"` test "x$ac_build_alias" = x && as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "${ac_aux_dir}config.sub" $ac_build_alias` || as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $ac_build_alias failed" "$LINENO" 5 fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 printf "%s\n" "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 printf %s "checking host system type... " >&6; } if test ${ac_cv_host+y} then : printf %s "(cached) " >&6 else $as_nop if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "${ac_aux_dir}config.sub" $host_alias` || as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $host_alias failed" "$LINENO" 5 fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 printf "%s\n" "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac canonical=$host my_host_kernel=`echo $host_os | awk '{j=split($1,A,"-");print A[1]}'` my_host_system=`echo $host_os | awk '{j=split($1,A,"-");if (j>=2) print A[2]}'` cat >>confdefs.h <<_ACEOF #define HOST_CPU "`echo $host_cpu | awk '{print toupper($0)}'`" _ACEOF cat >>confdefs.h <<_ACEOF #define HOST_KERNEL "`echo $my_host_kernel | awk '{print toupper($0)}'`" _ACEOF if test "$my_host_system" != "" ; then cat >>confdefs.h <<_ACEOF #define HOST_SYSTEM "`echo $my_host_system | awk '{print toupper($0)}'`" _ACEOF fi ## host=CPU-COMPANY-SYSTEM { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: host=$host" >&5 printf "%s\n" "host=$host" >&6; } use=unknown case $canonical in sh4*linux*) use=sh4-linux;; *x86_64*linux*) use=amd64-linux;; *x86_64*kfreebsd*) use=amd64-kfreebsd;; *86*linux*) use=386-linux;; *riscv64*linux*) use=riscv64-linux;; *86*kfreebsd*) use=386-kfreebsd;; *86*gnu*) use=386-gnu;; m68k*linux*) use=m68k-linux;; alpha*linux*) use=alpha-linux;; mips*linux*) use=mips-linux;; mipsel*linux*) use=mipsel-linux;; sparc*linux*) use=sparc-linux;; aarch64*linux*) use=aarch64-linux;; arm*linux*hf) use=armhf-linux;; arm*linux*) use=arm-linux;; s390*linux*) use=s390-linux;; ia64*linux*) use=ia64-linux;; hppa*linux*) use=hppa-linux;; powerpc*linux*) use=powerpc-linux;; powerpc-*-darwin*) use=powerpc-macosx;; *86*darwin*) use=386-macosx;; i*mingw*|i*msys*) use=mingw;; *cygwin*) if $CC -v 2>&1 | fgrep ming > /dev/null ; then use=mingw else use=gnuwin95 fi;; *openbsd*) use=FreeBSD;; sparc-sun-solaris*) use=solaris;; i?86-pc-solaris*) use=solaris-i386;; esac # Check whether --enable-machine was given. if test ${enable_machine+y} then : enableval=$enable_machine; echo enable_machine=$enableval ; use=$enableval fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: use=$use" >&5 printf "%s\n" "use=$use" >&6; } def_dlopen="no" def_statsysbfd="no" def_custreloc="yes" def_oldgmp="no" def_pic="no"; def_static="no"; def_debug="no"; case $use in *kfreebsd) ln -snf linux.defs h/$use.defs;; *gnu) ln -snf linux.defs h/$use.defs;; *linux) ln -snf linux.defs h/$use.defs; case $use in ia64*) def_dlopen="yes" ; def_custreloc="no" ;; hppa*) def_pic="yes" ;; esac;; esac # Check whether --enable-widecons was given. if test ${enable_widecons+y} then : enableval=$enable_widecons; if test "$enableval" = "yes" ; then printf "%s\n" "#define WIDE_CONS 1" >>confdefs.h fi fi # Check whether --enable-safecdr was given. if test ${enable_safecdr+y} then : enableval=$enable_safecdr; if test "$enableval" = "yes" ; then printf "%s\n" "#define USE_SAFE_CDR 1" >>confdefs.h # Check whether --enable-safecdrdbg was given. if test ${enable_safecdrdbg+y} then : enableval=$enable_safecdrdbg; if test "$enableval" = "yes" ; then printf "%s\n" "#define DEBUG_SAFE_CDR 1" >>confdefs.h fi fi fi fi # Check whether --enable-prelink was given. if test ${enable_prelink+y} then : enableval=$enable_prelink; if test "$enable_prelink" = "yes" ; then PRELINK_CHECK=t; fi fi # Check whether --enable-vssize was given. if test ${enable_vssize+y} then : enableval=$enable_vssize; printf "%s\n" "#define VSSIZE $enableval" >>confdefs.h fi # Check whether --enable-bdssize was given. if test ${enable_bdssize+y} then : enableval=$enable_bdssize; printf "%s\n" "#define BDSSIZE $enableval" >>confdefs.h fi # Check whether --enable-ihssize was given. if test ${enable_ihssize+y} then : enableval=$enable_ihssize; printf "%s\n" "#define IHSSIZE $enableval" >>confdefs.h fi # Check whether --enable-frssize was given. if test ${enable_frssize+y} then : enableval=$enable_frssize; printf "%s\n" "#define FRSSIZE $enableval" >>confdefs.h fi # Check whether --enable-infodir was given. if test ${enable_infodir+y} then : enableval=$enable_infodir; INFO_DIR=$enableval else $as_nop INFO_DIR=$prefix/share/info fi INFO_DIR=`eval echo $INFO_DIR/` # Check whether --enable-emacsdir was given. if test ${enable_emacsdir+y} then : enableval=$enable_emacsdir; EMACS_SITE_LISP=$enableval else $as_nop EMACS_SITE_LISP=$prefix/share/emacs/site-lisp fi EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` # Check whether --enable-xgcl was given. if test ${enable_xgcl+y} then : enableval=$enable_xgcl; else $as_nop enable_xgcl=yes fi # Check whether --enable-dlopen was given. if test ${enable_dlopen+y} then : enableval=$enable_dlopen; else $as_nop enable_dlopen=$def_dlopen fi # Check whether --enable-statsysbfd was given. if test ${enable_statsysbfd+y} then : enableval=$enable_statsysbfd; else $as_nop enable_statsysbfd=$def_statsysbfd fi # Check whether --enable-dynsysbfd was given. if test ${enable_dynsysbfd+y} then : enableval=$enable_dynsysbfd; else $as_nop enable_dynsysbfd=no fi # Check whether --enable-custreloc was given. if test ${enable_custreloc+y} then : enableval=$enable_custreloc; else $as_nop enable_custreloc=$def_custreloc fi # Check whether --enable-debug was given. if test ${enable_debug+y} then : enableval=$enable_debug; else $as_nop enable_debug=$def_debug fi # Check whether --enable-static was given. if test ${enable_static+y} then : enableval=$enable_static; else $as_nop enable_static=$def_static fi # Check whether --enable-pic was given. if test ${enable_pic+y} then : enableval=$enable_pic; else $as_nop enable_pic=$def_pic fi load_opt=0 if test "$enable_dlopen" = "yes" ; then load_opt=1 fi if test "$enable_statsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; esac fi if test "$enable_dynsysbfd" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; esac fi if test "$enable_custreloc" = "yes" ; then case $load_opt in 0) load_opt=1;; 1) load_opt=2;; 2) load_opt=3;; 3) load_opt=4;; 4) load_opt=5;; esac fi if test "$load_opt" != "1" ; then echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd custreloc=$enable_custreloc" as_fn_error $? "loader option failure" "$LINENO" 5 fi # # System programs # # We set the default CFLAGS below, and don't want the autoconf default # CM 20040106 if test "$CFLAGS" = "" ; then CFLAGS=" " fi if test "$LDFLAGS" = "" ; then LDFLAGS=" " fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion -version; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 printf %s "checking whether the C compiler works... " >&6; } ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else $as_nop ac_file='' fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else $as_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else $as_nop ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else $as_nop CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 printf %s "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 else $as_nop # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else $as_nop # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 printf "%s\n" "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else $as_nop # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : else $as_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu add_arg_to_cflags() { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CFLAG $1" >&5 printf %s "checking for CFLAG $1... " >&6; } CFLAGS_ORI=$CFLAGS CFLAGS="$CFLAGS -Werror $1 `echo $1|sed 's,-Wno-,-W,1'`" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : CFLAGS="$CFLAGS_ORI $1";{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; };return 0 else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi CFLAGS=$CFLAGS_ORI return 1 } assert_arg_to_cflags() { if ! add_arg_to_cflags "$1" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot add $1 to CFLAGS" >&5 printf "%s\n" "cannot add $1 to CFLAGS" >&6; }; exit 1 ; fi return 0 } add_args_to_cflags() { while test "$#" -ge 1 ; do add_arg_to_cflags $1 shift done } add_arg_to_ldflags() { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for LDFLAG $1" >&5 printf %s "checking for LDFLAG $1... " >&6; } LDFLAGS_ORI=$LDFLAGS LDFLAGS="$LDFLAGS -Werror $1" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : LDFLAGS="$LDFLAGS_ORI $1";{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; };return 0 else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi LDFLAGS=$LDFLAGS_ORI return 1 } assert_arg_to_ldflags() { if ! add_arg_to_ldflags $1 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: cannot add $1 to LDFLAGS" >&5 printf "%s\n" "cannot add $1 to LDFLAGS" >&6; }; exit 1 ; fi return 0 } add_args_to_ldflags() { while test "$#" -ge 1 ; do add_arg_to_ldflags $1 shift done } remove_arg_from_ldflags() { NEW_LDFLAGS="" for i in $LDFLAGS; do if ! test "$i" = "$1" ; then NEW_LDFLAGS="$NEW_LDFLAGS $i" else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: removing $1 from LDFLAGS" >&5 printf "%s\n" "removing $1 from LDFLAGS" >&6; } fi done LDFLAGS=$NEW_LDFLAGS return 0 } add_args_to_cflags -fsigned-char -pipe -fcommon \ -fno-builtin-malloc -fno-builtin-free \ -fno-PIE -fno-pie -fno-PIC -fno-pic \ -Wall \ -Wno-builtin-requires-header -Wno-empty-body -Wno-self-assign \ -Wno-unused-but-set-variable add_args_to_ldflags -no-pie # -Wl,-z,lazy { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline semantics" >&5 printf %s "checking for inline semantics... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ inline int foo(int i) {return i;} int bar(int i) {return foo(i);} _ACEOF if ac_fn_c_try_compile "$LINENO" then : if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: new" >&5 printf "%s\n" "new" >&6; } else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ extern inline int foo(int i) {return i;} int bar(int i) {return foo(i);} _ACEOF if ac_fn_c_try_compile "$LINENO" then : if `nm conftest.o |grep foo |awk '{if (NF==3) exit(-1)}'` ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: old" >&5 printf "%s\n" "old" >&6; } printf "%s\n" "#define OLD_INLINE 1" >>confdefs.h else as_fn_error $? "need working inline semantics" "$LINENO" 5 fi else $as_nop as_fn_error $? "need to probe inline semantics" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi else $as_nop as_fn_error $? "need to probe inline semantics" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for clang" >&5 printf %s "checking for clang... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __clang__ #define RET 0 #else #define RET 1 #endif int main (void) { return RET; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } clang="yes" remove_arg_from_ldflags -pie printf "%s\n" "#define CLANG 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi case $use in *mingw*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields for i in makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp h/gclincl.h; do cat $i.in | sed 's,^\r\n$,\r\n,g' >tmp && mv tmp $i.in; done OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; *gnuwin*) assert_arg_to_cflags -fno-zero-initialized-in-bss assert_arg_to_cflags -mms-bitfields assert_arg_to_ldflags -Wl,--stack,8000000 OLD_LDFLAGS=$LDFLAGS assert_arg_to_ldflags -pg GPL_FLAG="-pg" LDFLAGS=$OLD_LDFLAGS;; 386-macosx) # assert_arg_to_cflags -Wno-error=implicit-function-declaration add_arg_to_cflags -Wno-incomplete-setjmp-declaration assert_arg_to_ldflags -Wl,-no_pie if test "$build_cpu" = "x86_64" ; then assert_arg_to_cflags -m64 assert_arg_to_ldflags -m64 assert_arg_to_ldflags -Wl,-headerpad,72 else assert_arg_to_cflags -m32 assert_arg_to_ldflags -m32 assert_arg_to_ldflags -Wl,-headerpad,56 fi;; FreeBSD) assert_arg_to_ldflags -Z;; esac if test "$enable_static" = "yes" ; then assert_arg_to_ldflags -static assert_arg_to_ldflags -Wl,-zmuldefs printf "%s\n" "#define STATIC_LINKING 1" >>confdefs.h fi TO3FLAGS="" TO2FLAGS="" case "$use" in *mingw*) TFPFLAG="";; m68k*)#FIXME gcc 4.x bug workaround TFPFLAG="";; *) TFPFLAG="-fomit-frame-pointer";; esac for ac_prog in gawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AWK+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_AWK="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 printf "%s\n" "$AWK" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$AWK" && break done GCL_CC_ARGS=`echo $CC | ${AWK} '{$1="";print}'` GCL_CC="`basename $CC` $GCL_CC_ARGS" if echo $GCL_CC |grep gcc |grep -q win; then GCL_CC=gcc fi # Check whether --enable-gprof was given. if test ${enable_gprof+y} then : enableval=$enable_gprof; if test "$enableval" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking working gprof" >&5 printf %s "checking working gprof... " >&6; } case $use in powerpc*) if test "$host_cpu" = "powerpc64le" ; then enableval="no"; fi;; s390*) enableval="no";;#mcount smashes float args in make_shortfloat 20180313 sh4*) enableval="no";; m68k*) enableval="no";; ia64*) enableval="no";; hppa*) enableval="no";; # arm*) if echo $canonical |grep -q hf$; then enableval="no"; fi;;#FIXME CALL and JUMP24 veneers needed for thumb 20190201 #FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible aarch64*) enableval="no";;#unreproducible buildd bug 20170824 *gnu) enableval="no";; esac GP_FLAG="" if test "$enableval" != "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 printf "%s\n" "disabled" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ok" >&5 printf "%s\n" "ok" >&6; } OLD_CFLAGS=$CFLAGS # Do not run configure tests with -pg assert_arg_to_cflags -pg GP_FLAG="-pg" CFLAGS=$OLD_CFLAGS TFPFLAG="" printf "%s\n" "#define GCL_GPROF 1" >>confdefs.h fi fi fi if test "$enable_debug" = "yes" ; then assert_arg_to_cflags -g # for subconfigurations CFLAGS="$CFLAGS -g" else TO3FLAGS="-O3 $TFPFLAG" TO2FLAGS="-O" fi # gcc on ppc cannot compile our new_init.c with full opts --CM TONIFLAGS="" case $use in powerpc*macosx) assert_arg_to_cflags -mlongcall;; *linux) case $use in alpha*) assert_arg_to_cflags -mieee # if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 ;; aarch64*) TLIBS="$TLIBS -lgcc_s";; hppa*) assert_arg_to_cflags -mlong-calls TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 ;; mips*) case $canonical in mips64*linux*) # assert_arg_to_cflags -mxgot assert_arg_to_ldflags -Wl,-z,now;; esac ;; ia64*) if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 ;; arm*) printf "%s\n" "#define SET_STACK_POINTER \"mov %%sp,%0\\n\\t\"" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to set stack pointer" >&5 printf %s "checking how to set stack pointer... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 printf "%s\n" "done" >&6; } assert_arg_to_cflags -fdollars-in-identifiers assert_arg_to_cflags -g #? ;; powerpc*) assert_arg_to_cflags -mlongcall if test "$host_cpu" != "powerpc64le" ; then assert_arg_to_cflags -mno-pltseq; fi ;; esac;; esac if test "$enable_pic" = "yes" ; then assert_arg_to_cflags -fPIC fi FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` #CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` FOOPT1="$FOOPT1$TMPF" CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` if test "$FOOPT0" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` else if test "$FOOPT1" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[2-3],-O1,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[2-3],-O1,g'` else if test "$FOOPT2" != "" ; then TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` fi fi fi if test "$FDEBUG" != "" ; then TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` fi if test "$FOMITF" != "" ; then TO3FLAGS="$TO3FLAGS $FOMITF" fi # Step 1: set the variable "system" to hold the name and version number # for the system. This can usually be done via the "uname" command, but # there are a few systems, like Next, where this doesn't work. for ac_prog in makeinfo do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_MAKEINFO+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$MAKEINFO"; then ac_cv_prog_MAKEINFO="$MAKEINFO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_MAKEINFO="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MAKEINFO=$ac_cv_prog_MAKEINFO if test -n "$MAKEINFO"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MAKEINFO" >&5 printf "%s\n" "$MAKEINFO" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$MAKEINFO" && break done test -n "$MAKEINFO" || MAKEINFO=""false"" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version (for dynamic loading)" >&5 printf %s "checking system version (for dynamic loading)... " >&6; } if machine=`uname -m` ; then true; else machine=unknown ; fi if test -f /usr/lib/NextStep/software_version; then system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` else system=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unknown (cannot find uname command)" >&5 printf "%s\n" "unknown (cannot find uname command)" >&6; } system=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" fi if test "`uname -s`" = "AIX" ; then system=AIX-`uname -v`.`uname -r` fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $system" >&5 printf "%s\n" "$system" >&6; } fi fi case $use in *macosx) ac_header= ac_cache= for ac_item in $ac_header_c_list do if test $ac_cache; then ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then printf "%s\n" "#define $ac_item 1" >> confdefs.h fi ac_header= ac_cache= elif test $ac_header; then ac_cache=$ac_item else ac_header=$ac_item fi done if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes then : printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h fi for ac_header in malloc/malloc.h do : ac_fn_c_check_header_compile "$LINENO" "malloc/malloc.h" "ac_cv_header_malloc_malloc_h" "$ac_includes_default" if test "x$ac_cv_header_malloc_malloc_h" = xyes then : printf "%s\n" "#define HAVE_MALLOC_MALLOC_H 1" >>confdefs.h else $as_nop as_fn_error $? "need malloc.h on macosx" "$LINENO" 5 fi done ac_fn_c_check_member "$LINENO" "struct _malloc_zone_t" "memalign" "ac_cv_member_struct__malloc_zone_t_memalign" " #include " if test "x$ac_cv_member_struct__malloc_zone_t_memalign" = xyes then : printf "%s\n" "#define HAVE_MALLOC_ZONE_MEMALIGN 1" >>confdefs.h fi ;; esac for ac_header in setjmp.h do : ac_fn_c_check_header_compile "$LINENO" "setjmp.h" "ac_cv_header_setjmp_h" "$ac_includes_default" if test "x$ac_cv_header_setjmp_h" = xyes then : printf "%s\n" "#define HAVE_SETJMP_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof jmp_buf" >&5 printf %s "checking sizeof jmp_buf... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sizeof(jmp_buf)); fclose(fp); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : sizeof_jmp_buf=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $sizeof_jmp_buf" >&5 printf "%s\n" "$sizeof_jmp_buf" >&6; } printf "%s\n" "#define SIZEOF_JMP_BUF $sizeof_jmp_buf" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi done # sysconf for ac_header in unistd.h do : ac_fn_c_check_header_compile "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$ac_includes_default" if test "x$ac_cv_header_unistd_h" = xyes then : printf "%s\n" "#define HAVE_UNISTD_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sysconf in -lc" >&5 printf %s "checking for sysconf in -lc... " >&6; } if test ${ac_cv_lib_c_sysconf+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char sysconf (); int main (void) { return sysconf (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_c_sysconf=yes else $as_nop ac_cv_lib_c_sysconf=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_sysconf" >&5 printf "%s\n" "$ac_cv_lib_c_sysconf" >&6; } if test "x$ac_cv_lib_c_sysconf" = xyes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _SC_CLK_TCK" >&5 printf %s "checking _SC_CLK_TCK... " >&6; } hz=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); fclose(fp); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $hz" >&5 printf "%s\n" "$hz" >&6; } fi fi done rm -f makedefsafter # Check whether --enable-dynsysgmp was given. if test ${enable_dynsysgmp+y} then : enableval=$enable_dynsysgmp; fi if test "$enable_dynsysgmp" != "no" ; then for ac_header in gmp.h do : ac_fn_c_check_header_compile "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes then : printf "%s\n" "#define HAVE_GMP_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 printf %s "checking for __gmpz_init in -lgmp... " >&6; } if test ${ac_cv_lib_gmp___gmpz_init+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char __gmpz_init (); int main (void) { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_gmp___gmpz_init=yes else $as_nop ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 printf "%s\n" "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for external gmp version" >&5 printf %s "checking for external gmp version... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { #if __GNU_MP_VERSION > 3 return 0; #else return -1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: good" >&5 printf "%s\n" "good" >&6; } TLIBS="$TLIBS -lgmp" echo "#include \"gmp.h\"" >foo.c echo "int main() {return 0;}" >>foo.c MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` rm -f foo.c fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi done if test "$MP_INCLUDE" = "" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Cannot use dynamic gmp lib" >&5 printf "%s\n" "Cannot use dynamic gmp lib" >&6; } fi fi if test "$MP_INCLUDE" = "" ; then GMPDIR=gmp4 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking doing configure in gmp directory" >&5 printf %s "checking doing configure in gmp directory... " >&6; } echo echo "#" echo "#" echo "# -------------------" echo "# Subconfigure of GMP" echo "#" echo "#" if test "$use_common_binary" = "yes"; then cd $GMPDIR && ./configure --build=$host && cd .. else cd $GMPDIR && ./configure --host=$host --build=$build && cd .. fi #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" echo "#" echo "#" echo "#" echo "# Subconfigure of GMP done" echo "# ------------------------" echo "#" if test "$MP_INCLUDE" = "" ; then cp $GMPDIR/gmp.h h/gmp.h MP_INCLUDE=h/gmp.h MPFILES=gmp_all fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for leading underscore in object symbols" >&5 printf %s "checking for leading underscore in object symbols... " >&6; } cat>foo.c < #include int main() {FILE *f;double d=0.0;getc(f);d=cos(d);return 0;} EOFF $CC -c foo.c -o foo.o if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then LEADING_UNDERSCORE=1 printf "%s\n" "#define LEADING_UNDERSCORE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 printf "%s\n" "\"yes\"" >&6; } else LEADING_UNDERSCORE="" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 printf "%s\n" "\"no\"" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking \"for GNU ld option -Map\"" >&5 printf %s "checking \"for GNU ld option -Map\"... " >&6; } touch map $CC -o foo -Wl,-Map map foo.o >/dev/null 2>&1 if test `cat map | wc -l` != "0" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 printf "%s\n" "\"yes\"" >&6; } printf "%s\n" "#define HAVE_GNU_LD 1" >>confdefs.h GNU_LD=1 else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 printf "%s\n" "\"no\"" >&6; } GNU_LD= fi rm -f foo.c foo.o foo map { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for size of gmp limbs" >&5 printf %s "checking for size of gmp limbs... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { FILE *fp=fopen("conftest1","w"); fprintf(fp,"%u",sizeof(mp_limb_t)); fclose(fp); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : mpsize=`cat conftest1` else $as_nop as_fn_error $? "Cannot determine mpsize" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi printf "%s\n" "#define MP_LIMB_BYTES $mpsize" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mpsize" >&5 printf "%s\n" "$mpsize" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _SHORT_LIMB" >&5 printf %s "checking _SHORT_LIMB... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { #ifdef _SHORT_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define __SHORT_LIMB 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking _LONG_LONG_LIMB" >&5 printf %s "checking _LONG_LONG_LIMB... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include "$MP_INCLUDE" int main (void) { #ifdef _LONG_LONG_LIMB return 0; #else return 1; #endif ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define __LONG_LONG_LIMB 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi GMP=1 printf "%s\n" "#define GMP 1" >>confdefs.h echo > makedefsafter echo "MPFILES=$MPFILES" >> makedefsafter echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter echo >> makedefsafter # # X windows # if test "$enable_xgcl" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for X" >&5 printf %s "checking for X... " >&6; } # Check whether --with-x was given. if test ${with_x+y} then : withval=$with_x; fi # $have_x is `yes', `no', `disabled', or empty when we do not yet know. if test "x$with_x" = xno; then # The user explicitly disabled X. have_x=disabled else case $x_includes,$x_libraries in #( *\'*) as_fn_error $? "cannot use X directory names containing '" "$LINENO" 5;; #( *,NONE | NONE,*) if test ${ac_cv_have_x+y} then : printf %s "(cached) " >&6 else $as_nop # One or both of the vars are not set, and there is no cached value. ac_x_includes=no ac_x_libraries=no # Do we need to do anything special at all? ac_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { XrmInitialize () ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : # We can compile and link X programs with no special options. ac_x_includes= ac_x_libraries= fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS="$ac_save_LIBS" # If that didn't work, only try xmkmf and file system searches # for native compilation. if test x"$ac_x_includes" = xno && test "$cross_compiling" = no then : rm -f -r conftest.dir if mkdir conftest.dir; then cd conftest.dir cat >Imakefile <<'_ACEOF' incroot: @echo incroot='${INCROOT}' usrlibdir: @echo usrlibdir='${USRLIBDIR}' libdir: @echo libdir='${LIBDIR}' _ACEOF if (export CC; ${XMKMF-xmkmf}) >/dev/null 2>/dev/null && test -f Makefile; then # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. for ac_var in incroot usrlibdir libdir; do eval "ac_im_$ac_var=\`\${MAKE-make} $ac_var 2>/dev/null | sed -n 's/^$ac_var=//p'\`" done # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. for ac_extension in a so sl dylib la dll; do if test ! -f "$ac_im_usrlibdir/libX11.$ac_extension" && test -f "$ac_im_libdir/libX11.$ac_extension"; then ac_im_usrlibdir=$ac_im_libdir; break fi done # Screen out bogus values from the imake configuration. They are # bogus both because they are the default anyway, and because # using them would break gcc on systems where it needs fixed includes. case $ac_im_incroot in /usr/include) ac_x_includes= ;; *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; esac case $ac_im_usrlibdir in /usr/lib | /usr/lib64 | /lib | /lib64) ;; *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; esac fi cd .. rm -f -r conftest.dir fi # Standard set of common directories for X headers. # Check X11 before X11Rn because it is often a symlink to the current release. ac_x_header_dirs=' /usr/X11/include /usr/X11R7/include /usr/X11R6/include /usr/X11R5/include /usr/X11R4/include /usr/include/X11 /usr/include/X11R7 /usr/include/X11R6 /usr/include/X11R5 /usr/include/X11R4 /usr/local/X11/include /usr/local/X11R7/include /usr/local/X11R6/include /usr/local/X11R5/include /usr/local/X11R4/include /usr/local/include/X11 /usr/local/include/X11R7 /usr/local/include/X11R6 /usr/local/include/X11R5 /usr/local/include/X11R4 /opt/X11/include /usr/X386/include /usr/x386/include /usr/XFree86/include/X11 /usr/include /usr/local/include /usr/unsupported/include /usr/athena/include /usr/local/x11r5/include /usr/lpp/Xamples/include /usr/openwin/include /usr/openwin/share/include' if test "$ac_x_includes" = no; then # Guess where to find include files, by looking for Xlib.h. # First, try using that file with no special directory specified. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # We can compile using X headers with no special include directory. ac_x_includes= else $as_nop for ac_dir in $ac_x_header_dirs; do if test -r "$ac_dir/X11/Xlib.h"; then ac_x_includes=$ac_dir break fi done fi rm -f conftest.err conftest.i conftest.$ac_ext fi # $ac_x_includes = no if test "$ac_x_libraries" = no; then # Check for the libraries. # See if we find them without any special options. # Don't add to $LIBS permanently. ac_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { XrmInitialize () ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : LIBS=$ac_save_LIBS # We can link X programs with no special library path. ac_x_libraries= else $as_nop LIBS=$ac_save_LIBS for ac_dir in `printf "%s\n" "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` do # Don't even attempt the hair of trying to link an X program! for ac_extension in a so sl dylib la dll; do if test -r "$ac_dir/libX11.$ac_extension"; then ac_x_libraries=$ac_dir break 2 fi done done fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi # $ac_x_libraries = no fi # Record the results. case $ac_x_includes,$ac_x_libraries in #( no,* | *,no | *\'*) : # Didn't find X, or a directory has "'" in its name. ac_cv_have_x="have_x=no" ;; #( *) : # Record where we found X for the cache. ac_cv_have_x="have_x=yes\ ac_x_includes='$ac_x_includes'\ ac_x_libraries='$ac_x_libraries'" ;; esac fi ;; #( *) have_x=yes;; esac eval "$ac_cv_have_x" fi # $with_x != no if test "$have_x" != yes; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 printf "%s\n" "$have_x" >&6; } no_x=yes else # If each of the values was on the command line, it overrides each guess. test "x$x_includes" = xNONE && x_includes=$ac_x_includes test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries # Update the cache value to reflect the command line values. ac_cv_have_x="have_x=yes\ ac_x_includes='$x_includes'\ ac_x_libraries='$x_libraries'" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 printf "%s\n" "libraries $x_libraries, headers $x_includes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lX11" >&5 printf %s "checking for main in -lX11... " >&6; } if test ${ac_cv_lib_X11_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_X11_main=yes else $as_nop ac_cv_lib_X11_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_X11_main" >&5 printf "%s\n" "$ac_cv_lib_X11_main" >&6; } if test "x$ac_cv_lib_X11_main" = xyes then : X_LIBS="$X_LIBS -lX11" printf "%s\n" "#define HAVE_XGCL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: missing x libraries -- cannot compile xgcl" >&5 printf "%s\n" "missing x libraries -- cannot compile xgcl" >&6; } fi fi # # Dynamic loading # if test "$enable_dlopen" = "yes" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char dlopen (); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else $as_nop ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : printf "%s\n" "#define HAVE_LIBDL 1" >>confdefs.h LIBS="-ldl $LIBS" else $as_nop as_fn_error $? "Cannot find dlopen" "$LINENO" 5 fi TLIBS="$TLIBS -ldl -rdynamic" assert_arg_to_cflags -fPIC printf "%s\n" "#define USE_DLOPEN 1" >>confdefs.h fi if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then for ac_header in bfd.h do : ac_fn_c_check_header_compile "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" if test "x$ac_cv_header_bfd_h" = xyes then : printf "%s\n" "#define HAVE_BFD_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 printf %s "checking for bfd_init in -lbfd... " >&6; } if test ${ac_cv_lib_bfd_bfd_init+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lbfd -liberty $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char bfd_init (); int main (void) { return bfd_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_bfd_bfd_init=yes else $as_nop ac_cv_lib_bfd_bfd_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 printf "%s\n" "$ac_cv_lib_bfd_bfd_init" >&6; } if test "x$ac_cv_lib_bfd_bfd_init" = xyes then : # # Old binutils appear to need CONST defined to const # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking need to define CONST for bfd" >&5 printf %s "checking need to define CONST for bfd... " >&6; } if test "$cross_compiling" = yes then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include int main (void) { symbol_info t; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop if test "$cross_compiling" = yes then : as_fn_error $? "cannot use bfd" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define CONST const #define IN_GCC #include int main (void) { symbol_info t; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define NEED_CONST 1" >>confdefs.h else $as_nop as_fn_error $? "cannot use bfd" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi done printf "%s\n" "#define HAVE_LIBBFD 1" >>confdefs.h # # BFD boolean syntax # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for useable bfd_boolean" >&5 printf %s "checking for useable bfd_boolean... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define IN_GCC #include bfd_boolean foo() {return FALSE;} int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_BFD_BOOLEAN 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi # # bfd_link_info.output_bfd minimal configure change check # ac_fn_c_check_member "$LINENO" "struct bfd_link_info" "output_bfd" "ac_cv_member_struct_bfd_link_info_output_bfd" " #include #include " if test "x$ac_cv_member_struct_bfd_link_info_output_bfd" = xyes then : printf "%s\n" "#define HAVE_OUTPUT_BFD 1" >>confdefs.h fi # # FIXME: Need to workaround mingw before this point -- CM # if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c MP=`$CC -Wl,-M -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` rm -f foo.c foo if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,\"/\");for (j=1;j<=i;j++) if (j>1 && A[j]==\"..\") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf(\"%s%s\",A[j],j!=i ? \"/\" : \"\")}'`" else as_fn_error $? "cannot locate external libbfd.a" "$LINENO" 5 fi if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,\"/\");for (j=1;j<=i;j++) if (j>1 && A[j]==\"..\") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf(\"%s%s\",A[j],j!=i ? \"/\" : \"\")}'`" else as_fn_error $? "cannot locate external libiberty.a" "$LINENO" 5 fi BUILD_BFD=copy_bfd { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inflate in -lz" >&5 printf %s "checking for inflate in -lz... " >&6; } if test ${ac_cv_lib_z_inflate+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lz $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char inflate (); int main (void) { return inflate (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_z_inflate=yes else $as_nop ac_cv_lib_z_inflate=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflate" >&5 printf "%s\n" "$ac_cv_lib_z_inflate" >&6; } if test "x$ac_cv_lib_z_inflate" = xyes then : TLIBS="$TLIBS -lz" else $as_nop as_fn_error $? "Need zlib for bfd linking" "$LINENO" 5 fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlsym in -ldl" >&5 printf %s "checking for dlsym in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlsym+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char dlsym (); int main (void) { return dlsym (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlsym=yes else $as_nop ac_cv_lib_dl_dlsym=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlsym" >&5 printf "%s\n" "$ac_cv_lib_dl_dlsym" >&6; } if test "x$ac_cv_lib_dl_dlsym" = xyes then : TLIBS="$TLIBS -ldl" else $as_nop as_fn_error $? "Need libdl for bfd linking" "$LINENO" 5 fi else TLIBS="$TLIBS -lbfd -liberty -ldl" fi fi # Check whether --enable-xdr was given. if test ${enable_xdr+y} then : enableval=$enable_xdr; fi if test "$enable_xdr" != "no" ; then XDR_LIB="" ac_fn_c_check_func "$LINENO" "xdr_double" "ac_cv_func_xdr_double" if test "x$ac_cv_func_xdr_double" = xyes then : XDR_LIB=" " else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -ltirpc" >&5 printf %s "checking for xdr_double in -ltirpc... " >&6; } if test ${ac_cv_lib_tirpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-ltirpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_tirpc_xdr_double=yes else $as_nop ac_cv_lib_tirpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tirpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_tirpc_xdr_double" >&6; } if test "x$ac_cv_lib_tirpc_xdr_double" = xyes then : XDR_LIB=tirpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lgssrpc" >&5 printf %s "checking for xdr_double in -lgssrpc... " >&6; } if test ${ac_cv_lib_gssrpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lgssrpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_gssrpc_xdr_double=yes else $as_nop ac_cv_lib_gssrpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gssrpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_gssrpc_xdr_double" >&6; } if test "x$ac_cv_lib_gssrpc_xdr_double" = xyes then : XDR_LIB=gssrpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lrpc" >&5 printf %s "checking for xdr_double in -lrpc... " >&6; } if test ${ac_cv_lib_rpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lrpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_rpc_xdr_double=yes else $as_nop ac_cv_lib_rpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_rpc_xdr_double" >&6; } if test "x$ac_cv_lib_rpc_xdr_double" = xyes then : XDR_LIB=rpc else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -loncrpc" >&5 printf %s "checking for xdr_double in -loncrpc... " >&6; } if test ${ac_cv_lib_oncrpc_xdr_double+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-loncrpc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char xdr_double (); int main (void) { return xdr_double (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_oncrpc_xdr_double=yes else $as_nop ac_cv_lib_oncrpc_xdr_double=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_oncrpc_xdr_double" >&5 printf "%s\n" "$ac_cv_lib_oncrpc_xdr_double" >&6; } if test "x$ac_cv_lib_oncrpc_xdr_double" = xyes then : XDR_LIB=oncrpc fi fi fi fi fi if test "$XDR_LIB" != ""; then printf "%s\n" "#define HAVE_XDR 1" >>confdefs.h if test "$XDR_LIB" != " "; then TLIBS="$TLIBS -l$XDR_LIB" add_arg_to_cflags -I/usr/include/$XDR_LIB fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin_clzl" >&5 printf %s "checking __builtin_clzl... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { unsigned long u; long j; if (__builtin_clzl(0)!=sizeof(long)*8) return -1; for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) if (__builtin_clzl(u)!=j) return -1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_CLZL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin_ctzl" >&5 printf %s "checking __builtin_ctzl... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { unsigned long u; long j; if (__builtin_ctzl(0)!=sizeof(long)*8) return -1; for (u=1,j=0;j&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_CTZL 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi case $use in sh4*) ;; #FIXME, these exceptions needed as of gcc 4.7 hppa*) ;; #FIXME powerpc*) ;; #FIXME alpha*) ;; #FIXME ia64*) ;; #FIXME *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking __builtin___clear_cache" >&5 printf %s "checking __builtin___clear_cache... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { void *v,*ve; __builtin___clear_cache(v,ve); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_BUILTIN_CLEAR_CACHE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi ;; esac #AC_CONFIG_SUBDIRS($MY_SUBDIRS) # Find where Data begins. This is used by the storage allocation # mechanism, in the PAGE macro. This offset is subtracted from # addresses, in calculating a page for an address in the heap. # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 printf %s "checking size of long... " >&6; } if test ${ac_cv_sizeof_long+y} then : printf %s "(cached) " >&6 else $as_nop if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default" then : else $as_nop if test "$ac_cv_type_long" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long=0 fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 printf "%s\n" "$ac_cv_sizeof_long" >&6; } printf "%s\n" "#define SIZEOF_LONG $ac_cv_sizeof_long" >>confdefs.h if test "$ac_cv_sizeof_long" = "4" ; then assert_arg_to_cflags "-D_TIME_BITS=64 -D_FILE_OFFSET_BITS=64" fi ac_fn_c_check_header_compile "$LINENO" "time.h" "ac_cv_header_time_h" "$ac_includes_default" if test "x$ac_cv_header_time_h" = xyes then : printf "%s\n" "#define HAVE_TIME_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "sys/time.h" "ac_cv_header_sys_time_h" "$ac_includes_default" if test "x$ac_cv_header_sys_time_h" = xyes then : printf "%s\n" "#define HAVE_SYS_TIME_H 1" >>confdefs.h fi # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of time_t" >&5 printf %s "checking size of time_t... " >&6; } if test ${ac_cv_sizeof_time_t+y} then : printf %s "(cached) " >&6 else $as_nop if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (time_t))" "ac_cv_sizeof_time_t" "#include " then : else $as_nop if test "$ac_cv_type_time_t" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (time_t) See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_time_t=0 fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_time_t" >&5 printf "%s\n" "$ac_cv_sizeof_time_t" >&6; } printf "%s\n" "#define SIZEOF_TIME_T $ac_cv_sizeof_time_t" >>confdefs.h if test "$use" != "mingw" ; then if test "$ac_cv_sizeof_time_t" != "8" ; then as_fn_error $? "Cannot define a 64 bit time_t" "$LINENO" 5 fi fi #### Memory areas and alignment { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for byte order" >&5 printf %s "checking for byte order... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { /* Are we little or big endian? Adapted from Harbison&Steele. */ union {long l;char c[sizeof(long)];} u; u.l = 1; return u.c[sizeof(long)-1] ? 1 : 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: little" >&5 printf "%s\n" "little" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: big" >&5 printf "%s\n" "big" >&6; } printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for word order" >&5 printf %s "checking for word order... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { /* Are we little or big endian? Adapted from Harbison&Steele. */ union {double d;int l[sizeof(double)/sizeof(int)];} u; u.d = 1.0; return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: little" >&5 printf "%s\n" "little" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: big" >&5 printf "%s\n" "big" >&6; } printf "%s\n" "#define DOUBLE_BIGENDIAN 1" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi # pagewidth { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pagewidth" >&5 printf %s "checking for pagewidth... " >&6; } case $use in mips*) min_pagewidth=14;; *) min_pagewidth=12;; esac if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifdef __CYGWIN__ #define getpagesize() 4096 #endif int main (void) { size_t i=getpagesize(),j; FILE *fp=fopen("conftest1","w"); for (j=0;i>>=1;j++); j=j<$min_pagewidth ? $min_pagewidth : j; fprintf(fp,"%u",j); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : PAGEWIDTH=`cat conftest1` else $as_nop PAGEWIDTH=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $PAGEWIDTH" >&5 printf "%s\n" "$PAGEWIDTH" >&6; } printf "%s\n" "#define PAGEWIDTH $PAGEWIDTH" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required object alignment" >&5 printf %s "checking for required object alignment... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "./h/enum.h" #define OBJ_ALIGN #include "./h/type.h" #include "./h/lu.h" #include "./h/object.h" int main (void) { unsigned long i; FILE *fp=fopen("conftest1","w"); for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); if (!i) return -1; fprintf(fp,"%lu",i); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : obj_align=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 printf "%s\n" "$obj_align" >&6; } printf "%s\n" "#define OBJ_ALIGNMENT $obj_align" >>confdefs.h else $as_nop as_fn_error $? "Cannot find object alignent" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C extension variable alignment" >&5 printf %s "checking for C extension variable alignment... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { char *v __attribute__ ((aligned ($obj_align))); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : obj_align="__attribute__ ((aligned ($obj_align)))" else $as_nop as_fn_error $? "Need alignment attributes" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 printf "%s\n" "$obj_align" >&6; } printf "%s\n" "#define OBJ_ALIGN $obj_align" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C extension noreturn function attribute" >&5 printf %s "checking for C extension noreturn function attribute... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { extern int v() __attribute__ ((noreturn)); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : no_return="__attribute__ ((noreturn))" else $as_nop no_return= fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $no_return" >&5 printf "%s\n" "$no_return" >&6; } printf "%s\n" "#define NO_RETURN $no_return" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof struct contblock" >&5 printf %s "checking sizeof struct contblock... " >&6; } if test "$cross_compiling" = yes then : as_fn_error $? "Cannot find sizeof struct contblock" "$LINENO" 5 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #define EXTER #define INLINE #include "$MP_INCLUDE" #include "h/enum.h" #include "h/type.h" #include "h/lu.h" #include "h/object.h" int main (void) { FILE *f=fopen("conftest1","w"); fprintf(f,"%u",sizeof(struct contblock)); fclose(f); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : sizeof_contblock=`cat conftest1` else $as_nop as_fn_error $? "Cannot find sizeof struct contblock" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $sizeof_contblock" >&5 printf "%s\n" "$sizeof_contblock" >&6; } printf "%s\n" "#define SIZEOF_CONTBLOCK $sizeof_contblock" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sbrk" >&5 printf %s "checking for sbrk... " >&6; } HAVE_SBRK="" if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 printf "%s\n" "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : HAVE_SBRK=1;{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 printf "%s\n" "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$use" = "386-macosx" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: emulating sbrk for mac" >&5 printf "%s\n" "emulating sbrk for mac" >&6; }; HAVE_SBRK=0 fi if test "$HAVE_SBRK" = "1" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_NO_RANDOMIZE constant" >&5 printf %s "checking for ADDR_NO_RANDOMIZE constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_NO_RANDOMIZE); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_NO_RANDOMIZE=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_NO_RANDOMIZE" >&5 printf "%s\n" "yes $ADDR_NO_RANDOMIZE" >&6; } else $as_nop ADDR_NO_RANDOMIZE=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no assuming 0x40000" >&5 printf "%s\n" "no assuming 0x40000" >&6; } printf "%s\n" "#define ADDR_NO_RANDOMIZE 0x40000" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_COMPAT_LAYOUT constant" >&5 printf %s "checking for ADDR_COMPAT_LAYOUT constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_COMPAT_LAYOUT); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_COMPAT_LAYOUT=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_COMPAT_LAYOUT" >&5 printf "%s\n" "yes $ADDR_COMPAT_LAYOUT" >&6; } else $as_nop ADDR_COMPAT_LAYOUT=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "#define ADDR_COMPAT_LAYOUT 0" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ADDR_LIMIT_3GB constant" >&5 printf %s "checking for ADDR_LIMIT_3GB constant... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *f; if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%x",ADDR_LIMIT_3GB); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ADDR_LIMIT_3GB=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_LIMIT_3GB" >&5 printf "%s\n" "yes $ADDR_LIMIT_3GB" >&6; } else $as_nop ADDR_LIMIT_3GB=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "#define ADDR_LIMIT_3GB 0" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for personality(ADDR_NO_RANDOMIZE) support" >&5 printf %s "checking for personality(ADDR_NO_RANDOMIZE) support... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char *argv[],char *envp[]) { #include "h/unrandomize.h" return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define CAN_UNRANDOMIZE_SBRK 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking that sbrk is (now) non-random" >&5 printf %s "checking that sbrk is (now) non-random... " >&6; } SBRK=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : SBRK=`cat conftest1` fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$SBRK" = "0" ; then as_fn_error $? "cannot trap sbrk" "$LINENO" 5 fi SBRK1=0 if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char * argv[],char * envp[]) { FILE *f; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif if (!(f=fopen("conftest1","w"))) return -1; fprintf(f,"%p",sbrk(0)); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : SBRK1=`cat conftest1` fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi if test "$SBRK1" = "0" ; then as_fn_error $? "cannot trap sbrk" "$LINENO" 5 fi if test "$SBRK" = "$SBRK1" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } echo "Cannot build with randomized sbrk. Your options:" echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" echo " - run sysctl kernel.randomize_va_space=0 before using gcl" as_fn_error $? "exiting" "$LINENO" 5 fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_DIRECTION" >&5 printf %s "checking CSTACK_DIRECTION... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif fprintf(fp,"%d",(alloca(sizeof(void *))>alloca(sizeof(void *))) ? -1 : 1); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_direction=`cat conftest1` else $as_nop cstack_direction=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi printf "%s\n" "#define CSTACK_DIRECTION $cstack_direction" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_direction" >&5 printf "%s\n" "$cstack_direction" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding CSTACK_ALIGNMENT" >&5 printf %s "checking finding CSTACK_ALIGNMENT... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { void *b,*c; FILE *fp = fopen("conftest1","w"); long n; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif b=alloca(sizeof(b)); c=alloca(sizeof(c)); n=b>c ? b-c : c-b; n=n>sizeof(c) ? n : 1; fprintf(fp,"%ld",n); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_alignment=`cat conftest1` else $as_nop cstack_alignment=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi printf "%s\n" "#define CSTACK_ALIGNMENT $cstack_alignment" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_alignment" >&5 printf "%s\n" "$cstack_alignment" >&6; } # Check whether --enable-cstackmax was given. if test ${enable_cstackmax+y} then : enableval=$enable_cstackmax; if test "$enableval" != "" ; then printf "%s\n" "#define CSTACKMAX $enableval" >>confdefs.h fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking CSTACK_ADDRESS" >&5 printf %s "checking CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { FILE *fp = fopen("conftest1","w"); unsigned long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(unsigned long)alloca(sizeof(void *)); if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i-1); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_address=`cat conftest1` else $as_nop cstack_address=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi printf "%s\n" "#define CSTACK_ADDRESS $cstack_address" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_address" >&5 printf "%s\n" "$cstack_address" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking cstack bits" >&5 printf %s "checking cstack bits... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { void *v ; FILE *fp = fopen("conftest1","w"); long i,j; #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif j=1; j<<=$PAGEWIDTH; j<<=16; i=(long)&v; if ($cstack_direction==1) i-=j; j--; i+=j; i&=~j; for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); fprintf(fp,"%ld",j); fclose(fp); return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : cstack_bits=`cat conftest1` else $as_nop cstack_bits=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi printf "%s\n" "#define CSTACK_BITS $cstack_bits" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cstack_bits" >&5 printf "%s\n" "$cstack_bits" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking NEG_CSTACK_ADDRESS" >&5 printf %s "checking NEG_CSTACK_ADDRESS... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main(int argc,char **argv,char **envp) { #ifdef CAN_UNRANDOMIZE_SBRK #include "h/unrandomize.h" #endif return (long)$cstack_address<0 ? 0 : -1; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } neg_cstack_address=1 printf "%s\n" "#define NEG_CSTACK_ADDRESS 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } neg_cstack_address=0 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi # Check whether --enable-immfix was given. if test ${enable_immfix+y} then : enableval=$enable_immfix; fi # Check whether --enable-fastimmfix was given. if test ${enable_fastimmfix+y} then : enableval=$enable_fastimmfix; else $as_nop enable_fastimmfix=64 fi if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding default linker script" >&5 printf %s "checking finding default linker script... " >&6; } touch unixport/gcl.script echo "int main() {return 0;}" >foo.c $CC $LDFLAGS -Wl,--verbose foo.c -o foo 2>&1 | \ $AWK '/==================================================/ {i=1-i;next} {if (i) print}' >gcl.script rm -rf foo.c foo if test "`cat gcl.script | wc -l`" != "0" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: got it" >&5 printf "%s\n" "got it" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking output_arch" >&5 printf %s "checking output_arch... " >&6; } output_arch=`cat gcl.script |grep OUTPUT_ARCH|head -n 1|sed 's,.*(\(.*\)).*,\1,1'|cut -f1 -d:`; if test "$output_arch" != "" ; then printf "%s\n" "#define OUTPUT_ARCH bfd_arch_${output_arch}" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: bfd_arch_${output_arch}" >&5 printf "%s\n" "bfd_arch_${output_arch}" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: trying to adjust text start" >&5 printf "%s\n" "$as_me: trying to adjust text start" >&6;} cp gcl.script gcl.script.def n=-1; k=0; lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; max=0; min=$lim; while test $n -lt $lim ; do j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script # diff -u gcl.script.def gcl.script echo "int main() {return 0;}" >foo.c if ( $CC $LDFLAGS -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then if test $n -lt $min ; then min=$n; fi; if test $n -gt $max; then max=$n; fi; elif test $max -gt 0 ; then break; fi; n=`$AWK 'END {print n+1}' n=$n &5 printf "%s\n" "$as_me: min log text start $min" >&6;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: max log text start $max" >&5 printf "%s\n" "$as_me: max log text start $max" >&6;} if test $neg_cstack_address -eq 1 ; then #FIXME test this if test $cstack_bits -lt $max ; then max=$cstack_bits; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: max log text start reduced to $max considering c stack address" >&5 printf "%s\n" "$as_me: max log text start reduced to $max considering c stack address" >&6;} fi fi j=-1; low_shft=""; if test $min -le $max ; then if test $max -ge $enable_fastimmfix && test "$enable_immfix" != "no" ; then j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$max &5 printf "%s\n" "$as_me: raising log text to $j for a $max bit wide low immfix table" >&6;} else j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$min &5 printf "%s\n" "$as_me: lowering log text to $j to maximize data area" >&6;} fi fi if test "$low_shft" != "" ; then printf "%s\n" "#define LOW_SHFT $low_shft" >>confdefs.h printf "%s\n" "#define OBJNULL (object)0x$j" >>confdefs.h else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h fi # echo $j; { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking our linker script" >&5 printf %s "checking our linker script... " >&6; } if test "$j" -ne "-1" ; then cat gcl.script.def | $AWK '/SIZEOF_HEADERS/ {gsub("0x[0-9]*","0x" j,$0);} {print}' j=$j >gcl.script { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: done" >&5 printf "%s\n" "done" >&6; } rm -f gcl.script.def assert_arg_to_ldflags -Wl,-T,gcl.script cp gcl.script unixport else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none found or not needed" >&5 printf "%s\n" "none found or not needed" >&6; } rm -f gcl.script gcl.script.def fi rm -rf foo.c foo else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi else printf "%s\n" "#define OBJNULL NULL" >>confdefs.h fi mem_top=0 mem_range=0 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking mem top" >&5 printf %s "checking mem top... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { unsigned long i,j,k,l; FILE *fp = fopen("conftest1","w"); for (i=2,k=1;i;k=i,i<<=1); l=$cstack_address; l=$cstack_direction==1 ? (l>=1,i|=j); if (j<(k>>3)) i=0; j=1; j<<=$PAGEWIDTH; j<<=4; j--; i+=j; i&=~j; fprintf(fp,"0x%lx",i); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : mem_top=`cat conftest1` else $as_nop mem_top="0x0" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mem_top" >&5 printf "%s\n" "$mem_top" >&6; } if test "$mem_top" != "0x0" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking finding upper mem half range" >&5 printf %s "checking finding upper mem half range... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { unsigned long j; FILE *fp = fopen("conftest1","w"); for (j=1;j && !(j& $mem_top);j<<=1); fprintf(fp,"0x%lx",j>>1); fclose(fp); return 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : mem_range=`cat conftest1` else $as_nop mem_range="0x0" fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $mem_range" >&5 printf "%s\n" "$mem_range" >&6; } if test "$mem_range" != "0x0" ; then printf "%s\n" "#define MEM_TOP $mem_top" >>confdefs.h printf "%s\n" "#define MEM_RANGE $mem_range" >>confdefs.h fi fi if test "$enable_immfix" != "no" ; then if test "$mem_top" != "0x0" ; then if test "$mem_range" != "0x0" ; then printf "%s\n" "#define IM_FIX_BASE ${mem_top}UL" >>confdefs.h printf "%s\n" "#define IM_FIX_LIM ${mem_range}UL" >>confdefs.h fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking sizeof long long int" >&5 printf %s "checking sizeof long long int... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { if (sizeof(long long int) == 2*sizeof(long)) return 0; return 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_LONG_LONG 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi for ac_header in dirent.h do : ac_fn_c_check_header_compile "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "$ac_includes_default" if test "x$ac_cv_header_dirent_h" = xyes then : printf "%s\n" "#define HAVE_DIRENT_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for d_type" >&5 printf %s "checking for d_type... " >&6; } if test "$cross_compiling" = yes then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { struct dirent *d; DIR *r=opendir("./"); for (;(d=readdir(r)) && strcmp("configure",d->d_name);); return d && d->d_type==DT_REG ? 0 : -1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAVE_D_TYPE 1" >>confdefs.h else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi done # ansi lisp SYSTEM=ansi_gcl CLSTANDARD=ANSI # Check whether --enable-ansi was given. if test ${enable_ansi+y} then : enableval=$enable_ansi; if test "$enable_ansi" = "no" ; then SYSTEM=gcl CLSTANDARD=CLtL1 else printf "%s\n" "#define ANSI_COMMON_LISP 1" >>confdefs.h fi else $as_nop printf "%s\n" "#define ANSI_COMMON_LISP 1" >>confdefs.h fi FLISP="saved_$SYSTEM" # Maximum number of pages # Check if Posix compliant getcwd exists, if not we'll use getwd. ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd" if test "x$ac_cv_func_getcwd" = xyes then : printf "%s\n" "#define HAVE_GETCWD 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" if test "x$ac_cv_func_getwd" = xyes then : printf "%s\n" "#define HAVE_GETWD 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname" if test "x$ac_cv_func_uname" = xyes then : else $as_nop printf "%s\n" "#define NO_UNAME 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" if test "x$ac_cv_func_gettimeofday" = xyes then : else $as_nop printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" if test "x$ac_cv_header_sys_ioctl_h" = xyes then : printf "%s\n" "#define HAVE_SYS_IOCTL_H 1" >>confdefs.h fi # OpenBSD has elf_abi.h instead of elf.h ac_fn_c_check_header_compile "$LINENO" "elf.h" "ac_cv_header_elf_h" "$ac_includes_default" if test "x$ac_cv_header_elf_h" = xyes then : printf "%s\n" "#define HAVE_ELF_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "elf_abi.h" "ac_cv_header_elf_abi_h" "$ac_includes_default" if test "x$ac_cv_header_elf_abi_h" = xyes then : printf "%s\n" "#define HAVE_ELF_ABI_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "sys/sockio.h" "ac_cv_header_sys_sockio_h" "$ac_includes_default" if test "x$ac_cv_header_sys_sockio_h" = xyes then : printf "%s\n" "#define HAVE_SYS_SOCKIO_H 1" >>confdefs.h fi #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- ac_fn_c_check_func "$LINENO" "BSDgettimeofday" "ac_cv_func_BSDgettimeofday" if test "x$ac_cv_func_BSDgettimeofday" = xyes then : printf "%s\n" "#define HAVE_BSDGETTIMEOFDAY 1" >>confdefs.h else $as_nop ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" if test "x$ac_cv_func_gettimeofday" = xyes then : else $as_nop printf "%s\n" "#define NO_GETTOD 1" >>confdefs.h fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 printf %s "checking for grep that handles long lines and -e... " >&6; } if test ${ac_cv_path_GREP+y} then : printf %s "(cached) " >&6 else $as_nop if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_prog in grep ggrep do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 printf "%s\n" "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 printf %s "checking for egrep... " >&6; } if test ${ac_cv_path_EGREP+y} then : printf %s "(cached) " >&6 else $as_nop if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_prog in egrep do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 printf %s 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" printf "%s\n" 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 printf "%s\n" "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "gettimeofday" >/dev/null 2>&1 then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 printf %s "checking for gettimeofday declaration... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: present" >&5 printf "%s\n" "present" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 printf %s "checking for gettimeofday declaration... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: missing" >&5 printf "%s\n" "missing" >&6; } printf "%s\n" "#define GETTOD_NOT_DECLARED 1" >>confdefs.h fi rm -rf conftest* { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sin in -lm" >&5 printf %s "checking for sin in -lm... " >&6; } if test ${ac_cv_lib_m_sin+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char sin (); int main (void) { return sin (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_m_sin=yes else $as_nop ac_cv_lib_m_sin=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_sin" >&5 printf "%s\n" "$ac_cv_lib_m_sin" >&6; } if test "x$ac_cv_lib_m_sin" = xyes then : LIBS="${LIBS} -lm" else $as_nop true fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lmingwex" >&5 printf %s "checking for main in -lmingwex... " >&6; } if test ${ac_cv_lib_mingwex_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lmingwex $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_mingwex_main=yes else $as_nop ac_cv_lib_mingwex_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_main" >&5 printf "%s\n" "$ac_cv_lib_mingwex_main" >&6; } if test "x$ac_cv_lib_mingwex_main" = xyes then : LIBS="${LIBS} -lmingwex" else $as_nop true fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for buggy maximum sscanf length" >&5 printf %s "checking for buggy maximum sscanf length... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; int n, m; double f; char *endptr; FILE *fp=fopen("conftest1","w"); n=sscanf(s,"%lf%n",&f,&m); fprintf(fp,"%d",m); fclose(fp); return s[m]; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5 printf "%s\n" "none" >&6; } else $as_nop buggy_maximum_sscanf_length=`cat conftest1` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $buggy_maximum_sscanf_length" >&5 printf "%s\n" "$buggy_maximum_sscanf_length" >&6; } printf "%s\n" "#define BUGGY_MAXIMUM_SSCANF_LENGTH $buggy_maximum_sscanf_length" >>confdefs.h fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi EXTRA_LOBJS= # Check whether --enable-japi was given. if test ${enable_japi+y} then : enableval=$enable_japi; if test "$enable_japi" = "yes" ; then for ac_header in japi.h do : ac_fn_c_check_header_compile "$LINENO" "japi.h" "ac_cv_header_japi_h" "$ac_includes_default" if test "x$ac_cv_header_japi_h" = xyes then : printf "%s\n" "#define HAVE_JAPI_H 1" >>confdefs.h printf "%s\n" "#define HAVE_JAPI_H 1" >>confdefs.h EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" LIBS="${LIBS} -ljapi -lwsock32" fi done fi fi # Should really find a way to check for prototypes, but this # basically works for now. CM # for ac_header in math.h do : ac_fn_c_check_header_compile "$LINENO" "math.h" "ac_cv_header_math_h" "$ac_includes_default" if test "x$ac_cv_header_math_h" = xyes then : printf "%s\n" "#define HAVE_MATH_H 1" >>confdefs.h printf "%s\n" "#define HAVE_MATH_H 1" >>confdefs.h fi done for ac_header in complex.h do : ac_fn_c_check_header_compile "$LINENO" "complex.h" "ac_cv_header_complex_h" "$ac_includes_default" if test "x$ac_cv_header_complex_h" = xyes then : printf "%s\n" "#define HAVE_COMPLEX_H 1" >>confdefs.h printf "%s\n" "#define HAVE_COMPLEX_H 1" >>confdefs.h fi done # # For DBL_MAX et. al. on (only) certain Linux arches, apparently CM # for ac_header in values.h do : ac_fn_c_check_header_compile "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" if test "x$ac_cv_header_values_h" = xyes then : printf "%s\n" "#define HAVE_VALUES_H 1" >>confdefs.h printf "%s\n" "#define HAVE_VALUES_H 1" >>confdefs.h fi done # # Sparc solaris keeps this in float.h, rework either/or with values.h later # for ac_header in float.h do : ac_fn_c_check_header_compile "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" if test "x$ac_cv_header_float_h" = xyes then : printf "%s\n" "#define HAVE_FLOAT_H 1" >>confdefs.h printf "%s\n" "#define HAVE_FLOAT_H 1" >>confdefs.h fi done # # The second alternative is for solaris. This needs to be # a more comprehensive later, i.e. checking that the fpclass # test makes sense. CM # { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for isnormal" >&5 printf %s "checking for isnormal... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main (void) { float f; return isnormal(f) || !isnormal(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_ISNORMAL 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fpclass of ieeefp.h" >&5 printf %s "checking for fpclass of ieeefp.h... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { float f; return fpclass(f)>=FP_NZERO || fpclass(f)>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for isfinite" >&5 printf %s "checking for isfinite... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #define _GNU_SOURCE #include int main (void) { float f; return isfinite(f) || !isfinite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_ISFINITE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for finite()" >&5 printf %s "checking for finite()... " >&6; } if test "$cross_compiling" = yes then : { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run test program while cross compiling See \`config.log' for more details" "$LINENO" 5; } else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { float f; return finite(f) || !finite(f) ? 0 : 1; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : printf "%s\n" "#define HAVE_FINITE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop as_fn_error $? "no" "$LINENO" 5 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sockets" >&5 printf %s "checking for sockets... " >&6; } tcl_checkBoth=0 ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect" if test "x$ac_cv_func_connect" = xyes then : tcl_checkSocket=0 else $as_nop tcl_checkSocket=1 fi if test "$tcl_checkSocket" = 1; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lsocket" >&5 printf %s "checking for main in -lsocket... " >&6; } if test ${ac_cv_lib_socket_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lsocket $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_socket_main=yes else $as_nop ac_cv_lib_socket_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_main" >&5 printf "%s\n" "$ac_cv_lib_socket_main" >&6; } if test "x$ac_cv_lib_socket_main" = xyes then : TLIBS="$TLIBS -lsocket" else $as_nop tcl_checkBoth=1 fi fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$TLIBS TLIBS="$TLIBS -lsocket -lnsl" ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept" if test "x$ac_cv_func_accept" = xyes then : tcl_checkNsl=0 else $as_nop TLIBS=$tk_oldLibs fi fi ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" if test "x$ac_cv_func_gethostbyname" = xyes then : else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -lnsl" >&5 printf %s "checking for main in -lnsl... " >&6; } if test ${ac_cv_lib_nsl_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lnsl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_nsl_main=yes else $as_nop ac_cv_lib_nsl_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_main" >&5 printf "%s\n" "$ac_cv_lib_nsl_main" >&6; } if test "x$ac_cv_lib_nsl_main" = xyes then : TLIBS="$TLIBS -lnsl" fi fi # readline # Check whether --enable-readline was given. if test ${enable_readline+y} then : enableval=$enable_readline; fi if test "$use" = "mingw" ; then enable_readline=no fi if test "$enable_readline" != "no" ; then for ac_header in readline/readline.h do : ac_fn_c_check_header_compile "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "#include " if test "x$ac_cv_header_readline_readline_h" = xyes then : printf "%s\n" "#define HAVE_READLINE_READLINE_H 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rl_initialize in -lreadline" >&5 printf %s "checking for rl_initialize in -lreadline... " >&6; } if test ${ac_cv_lib_readline_rl_initialize+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char rl_initialize (); int main (void) { return rl_initialize (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_rl_initialize=yes else $as_nop ac_cv_lib_readline_rl_initialize=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_initialize" >&5 printf "%s\n" "$ac_cv_lib_readline_rl_initialize" >&6; } if test "x$ac_cv_lib_readline_rl_initialize" = xyes then : printf "%s\n" "#define USE_READLINE 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for el_getc in -lreadline" >&5 printf %s "checking for el_getc in -lreadline... " >&6; } if test ${ac_cv_lib_readline_el_getc+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char el_getc (); int main (void) { return el_getc (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_el_getc=yes else $as_nop ac_cv_lib_readline_el_getc=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_el_getc" >&5 printf "%s\n" "$ac_cv_lib_readline_el_getc" >&6; } if test "x$ac_cv_lib_readline_el_getc" = xyes then : printf "%s\n" "#define READLINE_IS_EDITLINE 1" >>confdefs.h fi # These tests discover differences between readline 4.1 and 4.3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for rl_completion_matches in -lreadline" >&5 printf %s "checking for rl_completion_matches in -lreadline... " >&6; } if test ${ac_cv_lib_readline_rl_completion_matches+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char rl_completion_matches (); int main (void) { return rl_completion_matches (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_readline_rl_completion_matches=yes else $as_nop ac_cv_lib_readline_rl_completion_matches=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_completion_matches" >&5 printf "%s\n" "$ac_cv_lib_readline_rl_completion_matches" >&6; } if test "x$ac_cv_lib_readline_rl_completion_matches" = xyes then : printf "%s\n" "#define HAVE_DECL_RL_COMPLETION_MATCHES 1" >>confdefs.h printf "%s\n" "#define HAVE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION" >&5 printf %s "checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include extern Function *rl_completion_entry_function __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_COMPLETION_ENTRY_FUNCTION_TYPE_FUNCTION 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T" >&5 printf %s "checking RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include extern rl_compentry_func_t *rl_completion_entry_function __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_COMPLETION_ENTRY_FUNCTION_TYPE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? "Unknown rl_completion_entry_function return type" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_READLINE_NAME_TYPE_CHAR" >&5 printf %s "checking RL_READLINE_NAME_TYPE_CHAR... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include extern char *rl_readline_name __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_READLINE_NAME_TYPE_CHAR 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking RL_READLINE_NAME_TYPE_CONST_CHAR" >&5 printf %s "checking RL_READLINE_NAME_TYPE_CONST_CHAR... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include extern const char *rl_readline_name __attribute__((weak)); int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define RL_READLINE_NAME_TYPE_CONST_CHAR 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? "Unknown rl_readline_name return type" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware RL_OBJS=gcl_readline.o fi fi done fi # sockets { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking For network code for nsocket.c" >&5 printf %s "checking For network code for nsocket.c... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include #include #include /************* for the sockets ******************/ #include /* struct sockaddr, SOCK_STREAM, ... */ #ifndef NO_UNAME # include /* uname system call. */ #endif #include /* struct in_addr, struct sockaddr_in */ #include /* inet_ntoa() */ #include /* gethostbyname() */ int main (void) { connect(0,(struct sockaddr *)0,0); gethostbyname("jil"); socket(AF_INET, SOCK_STREAM, 0); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : printf "%s\n" "#define HAVE_NSOCKET 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for listen using fcntl" >&5 printf %s "checking check for listen using fcntl... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include int main (void) { FILE *fp=fopen("configure.in","r"); int orig; orig = fcntl(fileno(fp), F_GETFL); if (! (orig & O_NONBLOCK )) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define LISTEN_USE_FCNTL 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_fn_c_check_func "$LINENO" "profil" "ac_cv_func_profil" if test "x$ac_cv_func_profil" = xyes then : else $as_nop printf "%s\n" "#define NO_PROFILE 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "setenv" "ac_cv_func_setenv" if test "x$ac_cv_func_setenv" = xyes then : printf "%s\n" "#define HAVE_SETENV 1" >>confdefs.h else $as_nop no_setenv=1 fi if test "$no_setenv" = "1" ; then ac_fn_c_check_func "$LINENO" "putenv" "ac_cv_func_putenv" if test "x$ac_cv_func_putenv" = xyes then : printf "%s\n" "#define HAVE_PUTENV 1" >>confdefs.h fi fi ac_fn_c_check_func "$LINENO" "_cleanup" "ac_cv_func__cleanup" if test "x$ac_cv_func__cleanup" = xyes then : printf "%s\n" "#define USE_CLEANUP 1" >>confdefs.h fi gcl_ok=no { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 printf %s "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; } case $system in OSF*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; SunOS-4*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; ULTRIX-4.*) printf "%s\n" "#define USE_FIONBIO 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 printf "%s\n" "FIONBIO" >&6; } ;; *) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5 printf "%s\n" "O_NONBLOCK" >&6; } ;; esac { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SV_ONSTACK" >&5 printf %s "checking check for SV_ONSTACK... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SV_ONSTACK; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SV_ONSTACK 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SIGSYS" >&5 printf %s "checking check for SIGSYS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGSYS; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGSYS 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking check for SIGEMT" >&5 printf %s "checking check for SIGEMT... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int joe=SIGEMT; int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGEMT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_fn_c_check_func "$LINENO" "sigaltstack" "ac_cv_func_sigaltstack" if test "x$ac_cv_func_sigaltstack" = xyes then : printf "%s\n" "#define HAVE_SIGALTSTACK 1" >>confdefs.h fi ac_fn_c_check_func "$LINENO" "feenableexcept" "ac_cv_func_feenableexcept" if test "x$ac_cv_func_feenableexcept" = xyes then : printf "%s\n" "#define HAVE_FEENABLEEXCEPT 1" >>confdefs.h fi for ac_header in dis-asm.h do : ac_fn_c_check_header_compile "$LINENO" "dis-asm.h" "ac_cv_header_dis_asm_h" "$ac_includes_default" if test "x$ac_cv_header_dis_asm_h" = xyes then : printf "%s\n" "#define HAVE_DIS_ASM_H 1" >>confdefs.h MLIBS=$LIBS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for init_disassemble_info in -lopcodes" >&5 printf %s "checking for init_disassemble_info in -lopcodes... " >&6; } if test ${ac_cv_lib_opcodes_init_disassemble_info+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-lopcodes $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char init_disassemble_info (); int main (void) { return init_disassemble_info (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_opcodes_init_disassemble_info=yes else $as_nop ac_cv_lib_opcodes_init_disassemble_info=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_opcodes_init_disassemble_info" >&5 printf "%s\n" "$ac_cv_lib_opcodes_init_disassemble_info" >&6; } if test "x$ac_cv_lib_opcodes_init_disassemble_info" = xyes then : printf "%s\n" "#define HAVE_LIBOPCODES 1" >>confdefs.h LIBS="-lopcodes $LIBS" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ char dlopen (); int main (void) { return dlopen (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes else $as_nop ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : #opcodes changes too quickly to link directly LIBS="$MLIBS -ldl" fi fi done #if test $use = "386-linux" ; then ac_fn_c_check_header_compile "$LINENO" "asm/sigcontext.h" "ac_cv_header_asm_sigcontext_h" "$ac_includes_default" if test "x$ac_cv_header_asm_sigcontext_h" = xyes then : printf "%s\n" "#define HAVE_ASM_SIGCONTEXT_H 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "asm/signal.h" "ac_cv_header_asm_signal_h" "$ac_includes_default" if test "x$ac_cv_header_asm_signal_h" = xyes then : printf "%s\n" "#define HAVE_ASM_SIGNAL_H 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 printf %s "checking for sigcontext...... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define SIGNAL_H_HAS_SIGCONTEXT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext of signal.h" >&5 printf "%s\n" "sigcontext of signal.h" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext NOT of signal.h" >&5 printf "%s\n" "sigcontext NOT of signal.h" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 printf %s "checking for sigcontext...... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #ifdef HAVE_ASM_SIGCONTEXT_H #include #endif #ifdef HAVE_ASM_SIGNAL_H #include #endif int main (void) { struct sigcontext foo; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : printf "%s\n" "#define HAVE_SIGCONTEXT 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: sigcontext asm files" >&5 printf "%s\n" "sigcontext asm files" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no sigcontext found" >&5 printf "%s\n" "no sigcontext found" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # Extract the first word of "emacs", so it can be a program name with args. set dummy emacs; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_EMACS+y} then : printf %s "(cached) " >&6 else $as_nop case $EMACS in [\\/]* | ?:[\\/]*) ac_cv_path_EMACS="$EMACS" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_path_EMACS="$as_dir$ac_word$ac_exec_ext" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS ;; esac fi EMACS=$ac_cv_path_EMACS if test -n "$EMACS"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS" >&5 printf "%s\n" "$EMACS" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi # check for where the emacs site lisp directory is. rm -f conftest.el cat >> conftest.el <&5 printf %s "checking emacs site lisp directory... " >&6; } if [ "$EMACS_SITE_LISP" = "unknown" ] ; then if [ "$EMACS" != "" ] ; then EMACS_SITE_LISP=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_SITE_LISP="" fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS_SITE_LISP" >&5 printf "%s\n" "$EMACS_SITE_LISP" >&6; } # check for where the emacs site lisp default.el is rm -f conftest.el cat >> conftest.el <&5 printf %s "checking emacs default.el... " >&6; } if [ "$EMACS" != "" ] ; then EMACS_DEFAULT_EL=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` else EMACS_DEFAULT_EL="" fi if test -f "${EMACS_DEFAULT_EL}" ; then true;else if test -d $EMACS_SITE_LISP ; then EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $EMACS_DEFAULT_EL" >&5 printf "%s\n" "$EMACS_DEFAULT_EL" >&6; } # check for where the emacs site lisp info/dir is rm -f conftest.el cat >> conftest.el <&5 printf %s "checking emacs info/dir... " >&6; } if test "$use" = "mingw" ; then INFO_DIR=\$\(prefix\)/lib/gcl-$VERSION/info/ else if [ "$EMACS" != "" ] && [ "$INFO_DIR" = "unknown" ] ; then INFO_DIR=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $INFO_DIR" >&5 printf "%s\n" "$INFO_DIR" >&6; } # Check whether --enable-tcltk was given. if test ${enable_tcltk+y} then : enableval=$enable_tcltk; fi # Check whether --enable-tkconfig was given. if test ${enable_tkconfig+y} then : enableval=$enable_tkconfig; TK_CONFIG_PREFIX=$enableval else $as_nop TK_CONFIG_PREFIX=unknown fi # Check whether --enable-tclconfig was given. if test ${enable_tclconfig+y} then : enableval=$enable_tclconfig; TCL_CONFIG_PREFIX=$enableval else $as_nop TCL_CONFIG_PREFIX=unknown fi if test "$enable_tcltk" != "no" ; then if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else # Extract the first word of "tclsh", so it can be a program name with args. set dummy tclsh; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_TCLSH+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$TCLSH"; then ac_cv_prog_TCLSH="$TCLSH" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_TCLSH="tclsh" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_TCLSH" && ac_cv_prog_TCLSH="${TCLSH}" fi fi TCLSH=$ac_cv_prog_TCLSH if test -n "$TCLSH"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH" >&5 printf "%s\n" "$TCLSH" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "${TCLSH}" = "" ; then true ; else rm -f conftest.tcl cat >> conftest.tcl <&5 printf %s "checking for main in -llieee... " >&6; } if test ${ac_cv_lib_lieee_main+y} then : printf %s "(cached) " >&6 else $as_nop ac_check_lib_save_LIBS=$LIBS LIBS="-llieee $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_lieee_main=yes else $as_nop ac_cv_lib_lieee_main=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_lieee_main" >&5 printf "%s\n" "$ac_cv_lib_lieee_main" >&6; } if test "x$ac_cv_lib_lieee_main" = xyes then : have_ieee=1 else $as_nop have_ieee=0 fi if test "$have_ieee" = "0" ; then TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` fi TCL_STUB_LIBS="" fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tcl/tk" >&5 printf %s "checking for tcl/tk... " >&6; } if test -d "${TK_CONFIG_PREFIX}" ; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: using TK_VERSION=${TK_VERSION} of ${TK_CONFIG_PREFIX}" >&5 printf "%s\n" "using TK_VERSION=${TK_VERSION} of ${TK_CONFIG_PREFIX}" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi # Check whether --enable-notify was given. if test ${enable_notify+y} then : enableval=$enable_notify; NOTIFY=$enable_notify fi # for sgbc the mprotect capabilities. # the time handling for unixtime, add timezone for ac_header in sys/mman.h do : ac_fn_c_check_header_compile "$LINENO" "sys/mman.h" "ac_cv_header_sys_mman_h" "$ac_includes_default" if test "x$ac_cv_header_sys_mman_h" = xyes then : printf "%s\n" "#define HAVE_SYS_MMAN_H 1" >>confdefs.h ac_fn_c_check_func "$LINENO" "mprotect" "ac_cv_func_mprotect" if test "x$ac_cv_func_mprotect" = xyes then : printf "%s\n" "#define HAVE_MPROTECT 1" >>confdefs.h fi fi done ac_fn_c_check_header_compile "$LINENO" "alloca.h" "ac_cv_header_alloca_h" "$ac_includes_default" if test "x$ac_cv_header_alloca_h" = xyes then : printf "%s\n" "#define HAVE_ALLOCA_H 1" >>confdefs.h fi ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes then : else $as_nop printf "%s\n" "#define size_t unsigned int" >>confdefs.h fi # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 printf %s "checking for working alloca.h... " >&6; } if test ${ac_cv_working_alloca_h+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { char *p = (char *) alloca (2 * sizeof (int)); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_working_alloca_h=yes else $as_nop ac_cv_working_alloca_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 printf "%s\n" "$ac_cv_working_alloca_h" >&6; } if test $ac_cv_working_alloca_h = yes; then printf "%s\n" "#define HAVE_ALLOCA_H 1" >>confdefs.h fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 printf %s "checking for alloca... " >&6; } if test ${ac_cv_func_alloca_works+y} then : printf %s "(cached) " >&6 else $as_nop if test $ac_cv_working_alloca_h = yes; then ac_cv_func_alloca_works=yes else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #ifndef alloca # ifdef __GNUC__ # define alloca __builtin_alloca # elif defined _MSC_VER # include # define alloca _alloca # else # ifdef __cplusplus extern "C" # endif void *alloca (size_t); # endif #endif int main (void) { char *p = (char *) alloca (1); if (p) return 0; ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_func_alloca_works=yes else $as_nop ac_cv_func_alloca_works=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 printf "%s\n" "$ac_cv_func_alloca_works" >&6; } fi if test $ac_cv_func_alloca_works = yes; then printf "%s\n" "#define HAVE_ALLOCA 1" >>confdefs.h else # The SVR3 libPW and SVR4 libucb both contain incompatible functions # that cause trouble. Some versions do not even contain alloca or # contain a buggy version. If you still want to use their alloca, # use ar to extract alloca.o from them instead of compiling alloca.c. ALLOCA=\${LIBOBJDIR}alloca.$ac_objext printf "%s\n" "#define C_ALLOCA 1" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 printf %s "checking stack direction for C alloca... " >&6; } if test ${ac_cv_c_stack_direction+y} then : printf %s "(cached) " >&6 else $as_nop if test "$cross_compiling" = yes then : ac_cv_c_stack_direction=0 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int find_stack_direction (int *addr, int depth) { int dir, dummy = 0; if (! addr) addr = &dummy; *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; dir = depth ? find_stack_direction (addr, depth - 1) : 0; return dir + dummy; } int main (int argc, char **argv) { return find_stack_direction (0, argc + !argv + 20) < 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : ac_cv_c_stack_direction=1 else $as_nop ac_cv_c_stack_direction=-1 fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 printf "%s\n" "$ac_cv_c_stack_direction" >&6; } printf "%s\n" "#define STACK_DIRECTION $ac_cv_c_stack_direction" >>confdefs.h fi LDFLAGS="`echo $GPL_FLAG $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $LIBS $TLIBS" CFLAGS="$CFLAGS $GP_FLAG" FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS" # Work around bug with gcc on ppc -- CM NIFLAGS="$CFLAGS $CPPFLAGS $TONIFLAGS -I\$(GCLDIR)/o" CFLAGS="$CFLAGS $CPPFLAGS $TO3FLAGS -I\$(GCLDIR)/o" O3FLAGS=$TO3FLAGS O2FLAGS=$TO2FLAGS if test -f h/$use.defs ; then ac_config_files="$ac_config_files makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" Copyright (C) 2021 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX printf "%s\n" "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "h/gclincl.h") CONFIG_HEADERS="$CONFIG_HEADERS h/gclincl.h" ;; "makedefc") CONFIG_FILES="$CONFIG_FILES makedefc" ;; "windows/gcl.iss") CONFIG_FILES="$CONFIG_FILES windows/gcl.iss" ;; "windows/sysdir.bat") CONFIG_FILES="$CONFIG_FILES windows/sysdir.bat" ;; "windows/install.lsp") CONFIG_FILES="$CONFIG_FILES windows/install.lsp" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi echo makedefc cat makedefc echo add-defs1 $use CC=$CC ./add-defs1 $use else echo "Unable to guess machine type" echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs fi gcl-2.6.14/readme0000644000175000017500000002753414360276512012166 0ustar cammcammDescription of GCL (GNU Common Lisp) system. OVERVIEW: The GCL system contains C and Lisp source files to build a Common Lisp system. The original KCL system was written by Taiichi Yuasa and Masami Hagiya in 1984. The AKCL system work was begun in 1987 by William Schelter and continued through 1994. A number of people have contributed ports and pieces. The file doc/contributors lists some of these. In 1994 AKCL was released as GCL (GNU Common Lisp) under the GNU public library license. Version akcl-1-624 was the last version made under the old license and using the old file change mechanism. This readme only applies to versions gcl.1.0 and later. The GNU library license does allow redistribution of executables containing GCL as well as proprietary code, but such redistribution must be accompanied by sufficient material (eg .o files) to allow recipients to rebuild an executable, after possibly modifying GCL. See the GNU file COPYING.LIB-2.0 for a full description of your right to copy this software. Releases of GCL after 2.0 contain a GCL connection with the windowing tools TCL/TK. If 'configure' is able to find the relevant libraries on your system, then a gcl-tk server will be compiled as well by the main make. It is based on TK 8.0 and TCL 8.0 and available from ftp.cs.berkeley.edu and many mirrors. OBTAINING SOURCES: ----------------- * There are source files on ftp.ma.utexas.edu:pub/gcl/gcl.x.x.tgz You probably want the highest XX version number. For example gcl-1.0.tgz would allow you to build the version 1.0 of GCL. In the following this compressed tar file is simply referred to as gcl.tgz. If you do not have gzip it is available in the directory /anyonymous@prep.ai.mit.edu:/u2/emacs . Hopefully sometime, GCL will also be available on prep.ai.mit.edu. MAKING THE SYSTEM: ================== To make the whole system, if you have obtained gcl.tgz. UNCOMPRESS and UNTAR the SOURCES: -------------------------------- Change to a directory in which you wish to build gcl, eg ~/tmp. Copy the file gcl.tgz to this directory. % gzip -dc gcl.tgz | tar xvf - This will create the subdirectory gcl-y.xxx with all the sources in it. ADD MACHINE DEFINITIONS TO MAKEFILES: ------------------------------------ % cd gcl-y.xxx % ./configure This will analyze your system, generate a file called makedefs, insert it into the various makefiles and create a proper h/config.h header file for your system. Some command line options can be used with the configure script; try ./configure --help to find out about them. Note that if you have tcl/tk (version 4.2 tk or 7.6 tcl or later), then a file tclConfig.sh and tkConfig.sh should exist in some place such as /usr/local/lib. RUNNING MAKE: ------------ % make The make should continue without error. There may be occasional warnings from the C compiler, but all files should compile successfully producing .o files. At the end you should see a message at the end "Make of GCL xxx completed", where xxx stands for the version number. Every successful compilation generates an automatic notification email to gcl@math.utexas.edu to help in determininig on which machines and levels of the OS compilation has been successful. If you don't want to assist in the maintenance in this way do % ./configure --enable-notify=no before make. TRY IT OUT: ---------- When it has finally finished you may invoke GCL by using % xbin/gcl GCL (GNU Common Lisp) Version(2.3) Sun May 7 14:11:30 CDT 2000 Licensed under GNU Library General Public License Contains Enhancements by W. Schelter >(+ 2 3) >5 If you had TCL/TK, then you should be able to do >(si::tkconnect) >(load "gcl-tk/demos/widget.lisp") Note there are currently problems with the demos, since they were based on an older version of tcl/tk. (setq si::*tk-library* "/usr/lib/tk") [where /usr/lib/tk/tk.tcl is] INSTALLING: ---------- To install under /usr/local (or under the directory specified with the --prefix= option of the ./configure script) % make install The default installation puts a full executable in /usr/local/lib/gcl-version/unixport/saved_gcl and some documentation in /usr/local/lib/gcl-x.x/info/ and some autoloading files in /usr/local/lib/gcl-x.x/lsp and a shell script in /usr/local/lib/gcl-x.x/xbin/gcl This script is also copied to /usr/local/bin FUTURE DIRECTIONS ================= (and how you may be able to help) Volunteers should contact William Schelter (wfs@math.utexas.edu) a) Upgrading to comply with the forthcoming ANSI standard. Work needs to be done. b) Need work on providing a high level window interface. One possible way would be a good connection with TCL/TK. Another would be to go in the direction of CLIM. A new compiler has been written, which is closer to the ANSI standard and provides some other benefits. It will be in a future release. We will need people willing to beta test and isolate any bugs. Additonal work planned or desired: * Clean up distribution and installation. Make it easier to link in C code such as Novak's window stuff. Faslink is not portable (since many systems don't support ld -A). * Introduce COMMON-LISP and COMMON-LISP-USER packages as per ANSI standard, change the package functions to behave as in the ANSI standard. Any other changes which people can identify which would make life easier, and are compatible with ANSI. * Introduce C level and Lisp level way of signalling errors of the types specified by the ANSI standard. Make it so that when the CLOS is present these become error objects. * Fix the run-process stuff to properly deallocate processes and have listen do the right thing, by using select, which is POSIX. Try to make it compatible with the one in Allegro or Lucid. Done * Turn ANSI documentation into the new Lisp's on-line documentation. This will be useful for development and for users. No sense in basing our work on the CLTL 2. Must go to the ANSI document itself. * Make an appropriate Unix man page. * Add my allocation files and other changes necessary to make INTERRUPTS safe. This probably means adding in all the C files which I have already written. * Change function calls to all refer to C stack and pass return values in a uniform way, the way the new compiler does it. This will greatly improve funcalling, since right now there are generally two types of functions which can be expected, and they expect their arguments in different places. * Change to the new compiler which does things better from the ANSI point of view, and is smaller, and makes all function calls go via the C stack. * Include CLOS support. Possibly take this from PCL or from Attardi, who has written some. Done * Include a windowing interface with TCL/TK which is capable of producing TK (similar to Motif but public) style windows and scrollable menus, etc. This implementation must be done in such a way that it works in at least one additional Lisp, such as Allegro or Lucid. * Loop package: either make sloop satisfy the standard or include another implementation. * Changes to READ for ANSI, (including case sensitivity, etc.). * Byte compiler based on first pass of the new compiler. Ideally provides very small code and extremely rapid compiling for general platform. Notes: I have put the interrupt and run-process stuff early on since it is necessary for window development. * Construct a Common Lisp test suite to help debug new releases. DOCUMENTATION: ============== If you use GNU emacs, a convenient method for viewing documentation of Common Lisp functions (or functions in an extended system), is provided by the doc/find-doc.el file. This will be installed when you do make in the doc directory. Adding the following to your .emacs file will allow you to use C-h d to find documentation. (autoload 'find-doc "find-doc" nil t) (global-set-key "d" 'find-doc) (visit-doc-file "/usr/local/lib/gcl/doc/DOC") See the file find-doc.el for more information. Otherwise you may use the describe command inside Lisp. For example (describe 'print) will print out information about print. It will access the gcl-si.info, gcl-tk.info, and gcl.info if these exist. gcl.info (containing the ansi proposed definitions) is on ftp.ma.utexas.edu:pub/gcl/gcl.info.tgz TROUBLE SHOOTING (some common problems reported): ---------------- 1) Did you extract the files with the original write dates--make depends heavily on this? 2) Did you use -O on a compiler which puts out bad code? Any time you change the settings or use a new c compiler this is a tricky point. 3) If you can't save an image, try doing so on the file server rather than a client. 4) Doing the make on a client with the main files on a server, has sometimes caused random breakage. The large temp files used by the C compiler seem to sometimes get transferred incorrectly. Solution: use the server for the compile. 5) Did you make changes in the .defs or .h files, other than just commenting out a CC=gcc line? 6) Did you read the recommendations in the XXXX.defs file on what C compiler versions work? 7) (si::tkconnect) fails: a) Make sure DISPLAY variable set before starting gcl. b) gcltkaux (subsidiary process) uses shared libraries and you would need LD_LIBRARY_PATH set on say suns, to say where those are if they are not in default places. [make sure "wish" would work] CHANGING THINGS: MAYBE EDIT THREE FILES: -------------------- Normally you should not need to edit ANY files. There may be some parameter sizes you wish to change or if you don't have gcc where we have made that the default, then see CC below. EDIT the ./add-defs script If when you do `add-defs machine` the add-defs script is not able to find directories where things like tk.h, libX11.a etc are, then it will print out a message. You can to have it look in some extra places on your machine, or in a different order. Note that if it fails to find these things the tcl/tk support will not be built, but you will have an ordinary common lisp. EDIT the appropriate h/NAME.defs file. These are definitions to be included in the various makefiles. For example if the `NAME' of your machine is sun3-os4. % emacs h/sun3-os4.defs * CC: set C compiler options. For example, if you are using the GNU C compiler: CC = gcc -msoft-float -DVOL=volatile -I$(GCLDIR)/o Or, if you are using the conventional UNIX C compiler: CC = cc -DVOL= -I. -I$(GCLDIR)/o * ODIR_DEBUG: ODIR_DEBUG= -g If you want files in the main c source compiled with debugging information. Note this is incompatible with OFLAGS= -O on some compilers. Size will be smaller without -g, but you are then helpless in the face of problems. * INITFORM: The normal thing is to just have the one form required for fast loading. INITFORM=(si::build-symbol-table) ----------- EDIT the file h/NAME.h (eg h/sun3-os4.h) (Actually you probably don't need to change it) This file will be included by virtually every compilation of C files, except the translated C produced by kcl. % emacs h/sun3-os4.h if you wish to change a parameter such as MAXPAGE 16384 established in bsd.h (ie. number of 2000 byte pages you want as your absolute max swap space). MAXPAGE must be a power of 2. #undef MAXPAGE #define MAXPAGE (2 * 16384) You may similarly redefine VSSIZE the maximum size for the value stack (running very deep recursion interpreted may well require this). DISCLAIMER: ---------- W. Schelter, the University of Texas, and other parties provide this program on an "as is" basis without warranty of any kind, either expressed or implied, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose. Bill Schelter wfs@math.utexas.edu See the file doc/contributors for a partial list of people who have made helpful contributions to ports etc. gcl-2.6.14/minvers0000755000175000017500000000000514360276512012377 0ustar cammcamm6.14 gcl-2.6.14/.gitignore0000644000175000017500000000015614360276512012765 0ustar cammcammTAGS config.log config.status gcl.script machine makedefc makedefs makedefsafter cmpinclude.h autom4te.cache/ gcl-2.6.14/gmp4/0000755000175000017500000000000014360276512011642 5ustar cammcammgcl-2.6.14/gmp4/config.in0000644000175000017500000004554714360276512013456 0ustar cammcamm/* config.in. Generated from configure.ac by autoheader. */ /* Copyright 1996-2014 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* Define if building universal (internal helper macro) */ #undef AC_APPLE_UNIVERSAL_BUILD /* The gmp-mparam.h file (a string) the tune program should suggest updating. */ #undef GMP_MPARAM_H_SUGGEST /* Define to 1 if you have the `alarm' function. */ #undef HAVE_ALARM /* Define to 1 if alloca() works (via gmp-impl.h). */ #undef HAVE_ALLOCA /* Define to 1 if you have and it should be used (not on Ultrix). */ #undef HAVE_ALLOCA_H /* Define to 1 if the compiler accepts gcc style __attribute__ ((const)) */ #undef HAVE_ATTRIBUTE_CONST /* Define to 1 if the compiler accepts gcc style __attribute__ ((malloc)) */ #undef HAVE_ATTRIBUTE_MALLOC /* Define to 1 if the compiler accepts gcc style __attribute__ ((mode (XX))) */ #undef HAVE_ATTRIBUTE_MODE /* Define to 1 if the compiler accepts gcc style __attribute__ ((noreturn)) */ #undef HAVE_ATTRIBUTE_NORETURN /* Define to 1 if you have the `attr_get' function. */ #undef HAVE_ATTR_GET /* Define to 1 if tests/libtests has calling conventions checking for the CPU */ #undef HAVE_CALLING_CONVENTIONS /* Define to 1 if you have the `clock' function. */ #undef HAVE_CLOCK /* Define to 1 if you have the `clock_gettime' function */ #undef HAVE_CLOCK_GETTIME /* Define to 1 if you have the `cputime' function. */ #undef HAVE_CPUTIME /* Define to 1 if you have the declaration of `fgetc', and to 0 if you don't. */ #undef HAVE_DECL_FGETC /* Define to 1 if you have the declaration of `fscanf', and to 0 if you don't. */ #undef HAVE_DECL_FSCANF /* Define to 1 if you have the declaration of `optarg', and to 0 if you don't. */ #undef HAVE_DECL_OPTARG /* Define to 1 if you have the declaration of `sys_errlist', and to 0 if you don't. */ #undef HAVE_DECL_SYS_ERRLIST /* Define to 1 if you have the declaration of `sys_nerr', and to 0 if you don't. */ #undef HAVE_DECL_SYS_NERR /* Define to 1 if you have the declaration of `ungetc', and to 0 if you don't. */ #undef HAVE_DECL_UNGETC /* Define to 1 if you have the declaration of `vfprintf', and to 0 if you don't. */ #undef HAVE_DECL_VFPRINTF /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H /* Define one of the following to 1 for the format of a `double'. If your format is not among these choices, or you don't know what it is, then leave all undefined. IEEE_LITTLE_SWAPPED means little endian, but with the two 4-byte halves swapped, as used by ARM CPUs in little endian mode. */ #undef HAVE_DOUBLE_IEEE_BIG_ENDIAN #undef HAVE_DOUBLE_IEEE_LITTLE_ENDIAN #undef HAVE_DOUBLE_IEEE_LITTLE_SWAPPED #undef HAVE_DOUBLE_VAX_D #undef HAVE_DOUBLE_VAX_G #undef HAVE_DOUBLE_CRAY_CFP /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the `getpagesize' function. */ #undef HAVE_GETPAGESIZE /* Define to 1 if you have the `getrusage' function. */ #undef HAVE_GETRUSAGE /* Define to 1 if you have the `getsysinfo' function. */ #undef HAVE_GETSYSINFO /* Define to 1 if you have the `gettimeofday' function. */ #undef HAVE_GETTIMEOFDAY /* Define one of these to 1 for the host CPU family. If your CPU is not in any of these families, leave all undefined. For an AMD64 chip, define "x86" in ABI=32, but not in ABI=64. */ #undef HAVE_HOST_CPU_FAMILY_alpha #undef HAVE_HOST_CPU_FAMILY_m68k #undef HAVE_HOST_CPU_FAMILY_power #undef HAVE_HOST_CPU_FAMILY_powerpc #undef HAVE_HOST_CPU_FAMILY_x86 #undef HAVE_HOST_CPU_FAMILY_x86_64 /* Define one of the following to 1 for the host CPU, as per the output of ./config.guess. If your CPU is not listed here, leave all undefined. */ #undef HAVE_HOST_CPU_alphaev67 #undef HAVE_HOST_CPU_alphaev68 #undef HAVE_HOST_CPU_alphaev7 #undef HAVE_HOST_CPU_m68020 #undef HAVE_HOST_CPU_m68030 #undef HAVE_HOST_CPU_m68040 #undef HAVE_HOST_CPU_m68060 #undef HAVE_HOST_CPU_m68360 #undef HAVE_HOST_CPU_powerpc604 #undef HAVE_HOST_CPU_powerpc604e #undef HAVE_HOST_CPU_powerpc750 #undef HAVE_HOST_CPU_powerpc7400 #undef HAVE_HOST_CPU_supersparc #undef HAVE_HOST_CPU_i386 #undef HAVE_HOST_CPU_i586 #undef HAVE_HOST_CPU_i686 #undef HAVE_HOST_CPU_pentium #undef HAVE_HOST_CPU_pentiummmx #undef HAVE_HOST_CPU_pentiumpro #undef HAVE_HOST_CPU_pentium2 #undef HAVE_HOST_CPU_pentium3 #undef HAVE_HOST_CPU_s390_z900 #undef HAVE_HOST_CPU_s390_z990 #undef HAVE_HOST_CPU_s390_z9 #undef HAVE_HOST_CPU_s390_z10 #undef HAVE_HOST_CPU_s390_z196 /* Define to 1 iff we have a s390 with 64-bit registers. */ #undef HAVE_HOST_CPU_s390_zarch /* Define to 1 if the system has the type `intmax_t'. */ #undef HAVE_INTMAX_T /* Define to 1 if the system has the type `intptr_t'. */ #undef HAVE_INTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_INVENT_H /* Define to 1 if you have the header file. */ #undef HAVE_LANGINFO_H /* Define one of these to 1 for the endianness of `mp_limb_t'. If the endianness is not a simple big or little, or you don't know what it is, then leave both undefined. */ #undef HAVE_LIMB_BIG_ENDIAN #undef HAVE_LIMB_LITTLE_ENDIAN /* Define to 1 if you have the `localeconv' function. */ #undef HAVE_LOCALECONV /* Define to 1 if you have the header file. */ #undef HAVE_LOCALE_H /* Define to 1 if the system has the type `long double'. */ #undef HAVE_LONG_DOUBLE /* Define to 1 if the system has the type `long long'. */ #undef HAVE_LONG_LONG /* Define to 1 if you have the header file. */ #undef HAVE_MACHINE_HAL_SYSINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `memset' function. */ #undef HAVE_MEMSET /* Define to 1 if you have the `mmap' function. */ #undef HAVE_MMAP /* Define to 1 if you have the `mprotect' function. */ #undef HAVE_MPROTECT /* Define to 1 each of the following for which a native (ie. CPU specific) implementation of the corresponding routine exists. */ #undef HAVE_NATIVE_mpn_add_n #undef HAVE_NATIVE_mpn_add_n_sub_n #undef HAVE_NATIVE_mpn_add_nc #undef HAVE_NATIVE_mpn_addaddmul_1msb0 #undef HAVE_NATIVE_mpn_addlsh1_n #undef HAVE_NATIVE_mpn_addlsh2_n #undef HAVE_NATIVE_mpn_addlsh_n #undef HAVE_NATIVE_mpn_addlsh1_nc #undef HAVE_NATIVE_mpn_addlsh2_nc #undef HAVE_NATIVE_mpn_addlsh_nc #undef HAVE_NATIVE_mpn_addlsh1_n_ip1 #undef HAVE_NATIVE_mpn_addlsh2_n_ip1 #undef HAVE_NATIVE_mpn_addlsh_n_ip1 #undef HAVE_NATIVE_mpn_addlsh1_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh2_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh1_n_ip2 #undef HAVE_NATIVE_mpn_addlsh2_n_ip2 #undef HAVE_NATIVE_mpn_addlsh_n_ip2 #undef HAVE_NATIVE_mpn_addlsh1_nc_ip2 #undef HAVE_NATIVE_mpn_addlsh2_nc_ip2 #undef HAVE_NATIVE_mpn_addlsh_nc_ip2 #undef HAVE_NATIVE_mpn_addmul_1c #undef HAVE_NATIVE_mpn_addmul_2 #undef HAVE_NATIVE_mpn_addmul_3 #undef HAVE_NATIVE_mpn_addmul_4 #undef HAVE_NATIVE_mpn_addmul_5 #undef HAVE_NATIVE_mpn_addmul_6 #undef HAVE_NATIVE_mpn_addmul_7 #undef HAVE_NATIVE_mpn_addmul_8 #undef HAVE_NATIVE_mpn_addmul_2s #undef HAVE_NATIVE_mpn_and_n #undef HAVE_NATIVE_mpn_andn_n #undef HAVE_NATIVE_mpn_bdiv_dbm1c #undef HAVE_NATIVE_mpn_bdiv_q_1 #undef HAVE_NATIVE_mpn_pi1_bdiv_q_1 #undef HAVE_NATIVE_mpn_cnd_add_n #undef HAVE_NATIVE_mpn_cnd_sub_n #undef HAVE_NATIVE_mpn_com #undef HAVE_NATIVE_mpn_copyd #undef HAVE_NATIVE_mpn_copyi #undef HAVE_NATIVE_mpn_div_qr_1n_pi1 #undef HAVE_NATIVE_mpn_div_qr_2 #undef HAVE_NATIVE_mpn_divexact_1 #undef HAVE_NATIVE_mpn_divexact_by3c #undef HAVE_NATIVE_mpn_divrem_1 #undef HAVE_NATIVE_mpn_divrem_1c #undef HAVE_NATIVE_mpn_divrem_2 #undef HAVE_NATIVE_mpn_gcd_1 #undef HAVE_NATIVE_mpn_hamdist #undef HAVE_NATIVE_mpn_invert_limb #undef HAVE_NATIVE_mpn_ior_n #undef HAVE_NATIVE_mpn_iorn_n #undef HAVE_NATIVE_mpn_lshift #undef HAVE_NATIVE_mpn_lshiftc #undef HAVE_NATIVE_mpn_lshsub_n #undef HAVE_NATIVE_mpn_mod_1 #undef HAVE_NATIVE_mpn_mod_1_1p #undef HAVE_NATIVE_mpn_mod_1c #undef HAVE_NATIVE_mpn_mod_1s_2p #undef HAVE_NATIVE_mpn_mod_1s_4p #undef HAVE_NATIVE_mpn_mod_34lsub1 #undef HAVE_NATIVE_mpn_modexact_1_odd #undef HAVE_NATIVE_mpn_modexact_1c_odd #undef HAVE_NATIVE_mpn_mul_1 #undef HAVE_NATIVE_mpn_mul_1c #undef HAVE_NATIVE_mpn_mul_2 #undef HAVE_NATIVE_mpn_mul_3 #undef HAVE_NATIVE_mpn_mul_4 #undef HAVE_NATIVE_mpn_mul_5 #undef HAVE_NATIVE_mpn_mul_6 #undef HAVE_NATIVE_mpn_mul_basecase #undef HAVE_NATIVE_mpn_nand_n #undef HAVE_NATIVE_mpn_nior_n #undef HAVE_NATIVE_mpn_popcount #undef HAVE_NATIVE_mpn_preinv_divrem_1 #undef HAVE_NATIVE_mpn_preinv_mod_1 #undef HAVE_NATIVE_mpn_redc_1 #undef HAVE_NATIVE_mpn_redc_2 #undef HAVE_NATIVE_mpn_rsblsh1_n #undef HAVE_NATIVE_mpn_rsblsh2_n #undef HAVE_NATIVE_mpn_rsblsh_n #undef HAVE_NATIVE_mpn_rsblsh1_nc #undef HAVE_NATIVE_mpn_rsblsh2_nc #undef HAVE_NATIVE_mpn_rsblsh_nc #undef HAVE_NATIVE_mpn_rsh1add_n #undef HAVE_NATIVE_mpn_rsh1add_nc #undef HAVE_NATIVE_mpn_rsh1sub_n #undef HAVE_NATIVE_mpn_rsh1sub_nc #undef HAVE_NATIVE_mpn_rshift #undef HAVE_NATIVE_mpn_sqr_basecase #undef HAVE_NATIVE_mpn_sqr_diagonal #undef HAVE_NATIVE_mpn_sqr_diag_addlsh1 #undef HAVE_NATIVE_mpn_sub_n #undef HAVE_NATIVE_mpn_sub_nc #undef HAVE_NATIVE_mpn_sublsh1_n #undef HAVE_NATIVE_mpn_sublsh2_n #undef HAVE_NATIVE_mpn_sublsh_n #undef HAVE_NATIVE_mpn_sublsh1_nc #undef HAVE_NATIVE_mpn_sublsh2_nc #undef HAVE_NATIVE_mpn_sublsh_nc #undef HAVE_NATIVE_mpn_sublsh1_n_ip1 #undef HAVE_NATIVE_mpn_sublsh2_n_ip1 #undef HAVE_NATIVE_mpn_sublsh_n_ip1 #undef HAVE_NATIVE_mpn_sublsh1_nc_ip1 #undef HAVE_NATIVE_mpn_sublsh2_nc_ip1 #undef HAVE_NATIVE_mpn_sublsh_nc_ip1 #undef HAVE_NATIVE_mpn_submul_1c #undef HAVE_NATIVE_mpn_tabselect #undef HAVE_NATIVE_mpn_udiv_qrnnd #undef HAVE_NATIVE_mpn_udiv_qrnnd_r #undef HAVE_NATIVE_mpn_umul_ppmm #undef HAVE_NATIVE_mpn_umul_ppmm_r #undef HAVE_NATIVE_mpn_xor_n #undef HAVE_NATIVE_mpn_xnor_n /* Define to 1 if you have the `nl_langinfo' function. */ #undef HAVE_NL_LANGINFO /* Define to 1 if you have the header file. */ #undef HAVE_NL_TYPES_H /* Define to 1 if you have the `obstack_vprintf' function. */ #undef HAVE_OBSTACK_VPRINTF /* Define to 1 if you have the `popen' function. */ #undef HAVE_POPEN /* Define to 1 if you have the `processor_info' function. */ #undef HAVE_PROCESSOR_INFO /* Define to 1 if `struct pst_processor' exists and contains `psp_iticksperclktick'. */ #undef HAVE_PSP_ITICKSPERCLKTICK /* Define to 1 if you have the `pstat_getprocessor' function. */ #undef HAVE_PSTAT_GETPROCESSOR /* Define to 1 if the system has the type `ptrdiff_t'. */ #undef HAVE_PTRDIFF_T /* Define to 1 if the system has the type `quad_t'. */ #undef HAVE_QUAD_T /* Define to 1 if you have the `raise' function. */ #undef HAVE_RAISE /* Define to 1 if you have the `read_real_time' function. */ #undef HAVE_READ_REAL_TIME /* Define to 1 if you have the `sigaction' function. */ #undef HAVE_SIGACTION /* Define to 1 if you have the `sigaltstack' function. */ #undef HAVE_SIGALTSTACK /* Define to 1 if you have the `sigstack' function. */ #undef HAVE_SIGSTACK /* Tune directory speed_cyclecounter, undef=none, 1=32bits, 2=64bits) */ #undef HAVE_SPEED_CYCLECOUNTER /* Define to 1 if you have the header file. */ #undef HAVE_SSTREAM /* Define to 1 if the system has the type `stack_t'. */ #undef HAVE_STACK_T /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if the system has the type `std::locale'. */ #undef HAVE_STD__LOCALE /* Define to 1 if you have the `strchr' function. */ #undef HAVE_STRCHR /* Define to 1 if you have the `strerror' function. */ #undef HAVE_STRERROR /* Define to 1 if cpp supports the ANSI # stringizing operator. */ #undef HAVE_STRINGIZE /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strnlen' function. */ #undef HAVE_STRNLEN /* Define to 1 if you have the `strtol' function. */ #undef HAVE_STRTOL /* Define to 1 if you have the `strtoul' function. */ #undef HAVE_STRTOUL /* Define to 1 if you have the `sysconf' function. */ #undef HAVE_SYSCONF /* Define to 1 if you have the `sysctl' function. */ #undef HAVE_SYSCTL /* Define to 1 if you have the `sysctlbyname' function. */ #undef HAVE_SYSCTLBYNAME /* Define to 1 if you have the `syssgi' function. */ #undef HAVE_SYSSGI /* Define to 1 if you have the header file. */ #undef HAVE_SYS_ATTRIBUTES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOGRAPH_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_MMAN_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PARAM_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PROCESSOR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PSTAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RESOURCE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSCTL_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSINFO_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSSGI_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SYSTEMCFG_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIMES_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the `times' function. */ #undef HAVE_TIMES /* Define to 1 if the system has the type `uint_least32_t'. */ #undef HAVE_UINT_LEAST32_T /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if you have the `vsnprintf' function and it works properly. */ #undef HAVE_VSNPRINTF /* Define to 1 for Windos/64 */ #undef HOST_DOS64 /* Assembler local label prefix */ #undef LSYM_PREFIX /* Define to the sub-directory in which libtool stores uninstalled libraries. */ #undef LT_OBJDIR /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define as the return type of signal handlers (`int' or `void'). */ #undef RETSIGTYPE /* The size of `mp_limb_t', as computed by sizeof. */ #undef SIZEOF_MP_LIMB_T /* The size of `unsigned', as computed by sizeof. */ #undef SIZEOF_UNSIGNED /* The size of `unsigned long', as computed by sizeof. */ #undef SIZEOF_UNSIGNED_LONG /* The size of `unsigned short', as computed by sizeof. */ #undef SIZEOF_UNSIGNED_SHORT /* The size of `void *', as computed by sizeof. */ #undef SIZEOF_VOID_P /* Define to 1 if sscanf requires writable inputs */ #undef SSCANF_WRITABLE_INPUT /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Define to 1 if you can safely include both and . */ #undef TIME_WITH_SYS_TIME /* Maximum size the tune program can test for SQR_TOOM2_THRESHOLD */ #undef TUNE_SQR_TOOM2_MAX /* Version number of package */ #undef VERSION /* Defined to 1 as per --enable-assembly */ #undef WANT_ASSEMBLY /* Define to 1 to enable ASSERT checking, per --enable-assert */ #undef WANT_ASSERT /* Define to 1 to enable GMP_CPU_TYPE faking cpuid, per --enable-fake-cpuid */ #undef WANT_FAKE_CPUID /* Define to 1 when building a fat binary. */ #undef WANT_FAT_BINARY /* Define to 1 to enable FFTs for multiplication, per --enable-fft */ #undef WANT_FFT /* Define to 1 to enable old mpn_mul_fft_full for multiplication, per --enable-old-fft-full */ #undef WANT_OLD_FFT_FULL /* Define to 1 if --enable-profiling=gprof */ #undef WANT_PROFILING_GPROF /* Define to 1 if --enable-profiling=instrument */ #undef WANT_PROFILING_INSTRUMENT /* Define to 1 if --enable-profiling=prof */ #undef WANT_PROFILING_PROF /* Define one of these to 1 for the desired temporary memory allocation method, per --enable-alloca. */ #undef WANT_TMP_ALLOCA #undef WANT_TMP_REENTRANT #undef WANT_TMP_NOTREENTRANT #undef WANT_TMP_DEBUG /* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel). */ #if defined AC_APPLE_UNIVERSAL_BUILD # if defined __BIG_ENDIAN__ # define WORDS_BIGENDIAN 1 # endif #else # ifndef WORDS_BIGENDIAN # undef WORDS_BIGENDIAN # endif #endif /* Define to 1 if `lex' declares `yytext' as a `char *' by default, not a `char[]'. */ #undef YYTEXT_POINTER /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus #undef inline #endif /* Define to the equivalent of the C99 'restrict' keyword, or to nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict /* Work around a bug in Sun C++: it does not support _Restrict or __restrict__, even though the corresponding Sun C compiler ends up with "#define restrict _Restrict" or "#define restrict __restrict__" in the previous line. Perhaps some future version of Sun C++ will work with restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ #if defined __SUNPRO_CC && !defined __RESTRICT # define _Restrict # define __restrict__ #endif /* Define to empty if the keyword `volatile' does not work. Warning: valid code using `volatile' can become incorrect without. Disable with care. */ #undef volatile gcl-2.6.14/gmp4/.pc/0000755000175000017500000000000014360276512012322 5ustar cammcammgcl-2.6.14/gmp4/.pc/.version0000644000175000017500000000000214360276512014000 0ustar cammcamm2 gcl-2.6.14/gmp4/.pc/.quilt_patches0000644000175000017500000000001714360276512015166 0ustar cammcammdebian/patches gcl-2.6.14/gmp4/.pc/arm-asm-nothumb.patch/0000755000175000017500000000000014360276512016427 5ustar cammcammgcl-2.6.14/gmp4/.pc/arm-asm-nothumb.patch/mpn/0000755000175000017500000000000014360276512017221 5ustar cammcammgcl-2.6.14/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/0000755000175000017500000000000014360276512020635 5ustar cammcammgcl-2.6.14/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c0000644000175000017500000001700114360276512023433 0ustar cammcamm/* mpn_div_qr_1n_pi1 Contributed to the GNU project by Niels Möller THIS FILE CONTAINS INTERNAL FUNCTIONS WITH MUTABLE INTERFACES. IT IS ONLY SAFE TO REACH THEM THROUGH DOCUMENTED INTERFACES. IN FACT, IT IS ALMOST GUARANTEED THAT THEY'LL CHANGE OR DISAPPEAR IN A FUTURE GNU MP RELEASE. Copyright 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" #if GMP_NAIL_BITS > 0 #error Nail bits not supported #endif #ifndef DIV_QR_1N_METHOD #define DIV_QR_1N_METHOD 2 #endif /* FIXME: Duplicated in mod_1_1.c. Move to gmp-impl.h */ #if defined (__GNUC__) #if HAVE_HOST_CPU_FAMILY_x86 && W_TYPE_SIZE == 32 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add %6, %k2\n\t" \ "adc %4, %k1\n\t" \ "sbb %k0, %k0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((USItype)(a1)), "g" ((USItype)(b1)), \ "%2" ((USItype)(a0)), "g" ((USItype)(b0))) #endif #if HAVE_HOST_CPU_FAMILY_x86_64 && W_TYPE_SIZE == 64 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add %6, %q2\n\t" \ "adc %4, %q1\n\t" \ "sbb %q0, %q0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((UDItype)(a1)), "rme" ((UDItype)(b1)), \ "%2" ((UDItype)(a0)), "rme" ((UDItype)(b0))) #endif #if defined (__sparc__) && W_TYPE_SIZE == 32 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addxcc %r3, %4, %1\n\t" \ "subx %%g0, %%g0, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ __CLOBBER_CC) #endif #if defined (__sparc__) && W_TYPE_SIZE == 64 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addccc %r7, %8, %%g0\n\t" \ "addccc %r3, %4, %1\n\t" \ "clr %0\n\t" \ "movcs %%xcc, -1, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl), \ "rJ" ((al) >> 32), "rI" ((bl) >> 32) \ __CLOBBER_CC) #if __VIS__ >= 0x300 #undef add_mssaaaa #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "addcc %r5, %6, %2\n\t" \ "addxccc %r3, %4, %1\n\t" \ "clr %0\n\t" \ "movcs %%xcc, -1, %0" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ __CLOBBER_CC) #endif #endif #if HAVE_HOST_CPU_FAMILY_powerpc && !defined (_LONG_LONG_LIMB) /* This works fine for 32-bit and 64-bit limbs, except for 64-bit limbs with a processor running in 32-bit mode, since the carry flag then gets the 32-bit carry. */ #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "add%I6c %2, %5, %6\n\t" \ "adde %1, %3, %4\n\t" \ "subfe %0, %0, %0\n\t" \ "nor %0, %0, %0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "r" (a1), "r" (b1), "%r" (a0), "rI" (b0)) #endif #if defined (__s390x__) && W_TYPE_SIZE == 64 #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ __asm__ ( "algr %2, %6\n\t" \ "alcgr %1, %4\n\t" \ "lghi %0, 0\n\t" \ "alcgr %0, %0\n\t" \ "lcgr %0, %0" \ : "=r" (m), "=r" (s1), "=&r" (s0) \ : "1" ((UDItype)(a1)), "r" ((UDItype)(b1)), \ "%2" ((UDItype)(a0)), "r" ((UDItype)(b0)) __CLOBBER_CC) #endif #if defined (__arm__) && W_TYPE_SIZE == 32 #define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ __asm__ ( "adds %2, %5, %6\n\t" \ "adcs %1, %3, %4\n\t" \ "movcc %0, #0\n\t" \ "movcs %0, #-1" \ : "=r" (m), "=r" (sh), "=&r" (sl) \ : "r" (ah), "rI" (bh), "%r" (al), "rI" (bl) __CLOBBER_CC) #endif #endif /* defined (__GNUC__) */ #ifndef add_mssaaaa #define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ do { \ UWtype __s0, __s1, __c0, __c1; \ __s0 = (a0) + (b0); \ __s1 = (a1) + (b1); \ __c0 = __s0 < (a0); \ __c1 = __s1 < (a1); \ (s0) = __s0; \ __s1 = __s1 + __c0; \ (s1) = __s1; \ (m) = - (__c1 + (__s1 < __c0)); \ } while (0) #endif #if DIV_QR_1N_METHOD == 1 /* Divides (uh B^n + {up, n}) by d, storing the quotient at {qp, n}. Requires that uh < d. */ mp_limb_t mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t uh, mp_limb_t d, mp_limb_t dinv) { ASSERT (n > 0); ASSERT (uh < d); ASSERT (d & GMP_NUMB_HIGHBIT); ASSERT (MPN_SAME_OR_SEPARATE_P (qp, up, n)); do { mp_limb_t q, ul; ul = up[--n]; udiv_qrnnd_preinv (q, uh, uh, ul, d, dinv); qp[n] = q; } while (n > 0); return uh; } #elif DIV_QR_1N_METHOD == 2 mp_limb_t mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t u1, mp_limb_t d, mp_limb_t dinv) { mp_limb_t B2; mp_limb_t u0, u2; mp_limb_t q0, q1; mp_limb_t p0, p1; mp_limb_t t; mp_size_t j; ASSERT (d & GMP_LIMB_HIGHBIT); ASSERT (n > 0); ASSERT (u1 < d); if (n == 1) { udiv_qrnnd_preinv (qp[0], u1, u1, up[0], d, dinv); return u1; } /* FIXME: Could be precomputed */ B2 = -d*dinv; umul_ppmm (q1, q0, dinv, u1); umul_ppmm (p1, p0, B2, u1); q1 += u1; ASSERT (q1 >= u1); u0 = up[n-1]; /* Early read, to allow qp == up. */ qp[n-1] = q1; add_mssaaaa (u2, u1, u0, u0, up[n-2], p1, p0); /* FIXME: Keep q1 in a variable between iterations, to reduce number of memory accesses. */ for (j = n-2; j-- > 0; ) { mp_limb_t q2, cy; /* Additions for the q update: * +-------+ * |u1 * v | * +---+---+ * | u1| * +---+---+ * | 1 | v | (conditional on u2) * +---+---+ * | 1 | (conditional on u0 + u2 B2 carry) * +---+ * + | q0| * -+---+---+---+ * | q2| q1| q0| * +---+---+---+ */ umul_ppmm (p1, t, u1, dinv); add_ssaaaa (q2, q1, -u2, u2 & dinv, CNST_LIMB(0), u1); add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), p1); add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), q0); q0 = t; umul_ppmm (p1, p0, u1, B2); ADDC_LIMB (cy, u0, u0, u2 & B2); u0 -= (-cy) & d; /* Final q update */ add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), cy); qp[j+1] = q1; MPN_INCR_U (qp+j+2, n-j-2, q2); add_mssaaaa (u2, u1, u0, u0, up[j], p1, p0); } q1 = (u2 > 0); u1 -= (-q1) & d; t = (u1 >= d); q1 += t; u1 -= (-t) & d; udiv_qrnnd_preinv (t, u0, u1, u0, d, dinv); add_ssaaaa (q1, q0, q1, q0, CNST_LIMB(0), t); MPN_INCR_U (qp+1, n-1, q1); qp[0] = q0; return u0; } #else #error Unknown DIV_QR_1N_METHOD #endif gcl-2.6.14/gmp4/.pc/.quilt_series0000644000175000017500000000000714360276512015030 0ustar cammcammseries gcl-2.6.14/gmp4/.pc/4a6d258b467f.patch/0000755000175000017500000000000014360276512015166 5ustar cammcammgcl-2.6.14/gmp4/.pc/4a6d258b467f.patch/mpn/0000755000175000017500000000000014360276512015760 5ustar cammcammgcl-2.6.14/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/0000755000175000017500000000000014360276512017611 5ustar cammcammgcl-2.6.14/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/0000755000175000017500000000000014360276512020707 5ustar cammcammgcl-2.6.14/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm0000644000175000017500000000524614360276512022375 0ustar cammcammdnl PowerPC-64 mpn_gcd_1. dnl Copyright 2000-2002, 2005, 2009, 2011-2013 Free Software Foundation, Inc. dnl This file is part of the GNU MP Library. dnl dnl The GNU MP Library is free software; you can redistribute it and/or modify dnl it under the terms of either: dnl dnl * the GNU Lesser General Public License as published by the Free dnl Software Foundation; either version 3 of the License, or (at your dnl option) any later version. dnl dnl or dnl dnl * the GNU General Public License as published by the Free Software dnl Foundation; either version 2 of the License, or (at your option) any dnl later version. dnl dnl or both in parallel, as here. dnl dnl The GNU MP Library is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License dnl for more details. dnl dnl You should have received copies of the GNU General Public License and the dnl GNU Lesser General Public License along with the GNU MP Library. If not, dnl see https://www.gnu.org/licenses/. include(`../config.m4') C cycles/bit (approx) C POWER3/PPC630 ? C POWER4/PPC970 8.5 C POWER5 ? C POWER6 10.1 C POWER7 9.4 C Numbers measured with: speed -CD -s16-64 -t48 mpn_gcd_1 C INPUT PARAMETERS define(`up', `r3') define(`n', `r4') define(`v0', `r5') EXTERN_FUNC(mpn_mod_1) EXTERN_FUNC(mpn_modexact_1c_odd) ASM_START() PROLOGUE(mpn_gcd_1,toc) mflr r0 std r30, -16(r1) std r31, -8(r1) std r0, 16(r1) stdu r1, -128(r1) ld r7, 0(up) C U low limb or r0, r5, r7 C x | y neg r6, r0 and r6, r6, r0 cntlzd r31, r6 C common twos subfic r31, r31, 63 neg r6, r5 and r6, r6, r5 cntlzd r8, r6 subfic r8, r8, 63 srd r5, r5, r8 mr r30, r5 C v0 saved cmpdi r4, BMOD_1_TO_MOD_1_THRESHOLD blt L(bmod) CALL( mpn_mod_1) b L(reduced) L(bmod): li r6, 0 CALL( mpn_modexact_1c_odd) L(reduced): define(`mask', `r0')dnl define(`a1', `r4')dnl define(`a2', `r5')dnl define(`d1', `r6')dnl define(`d2', `r7')dnl define(`cnt', `r9')dnl neg. r6, r3 and r6, r6, r3 cntlzd cnt, r6 subfic cnt, cnt, 63 li r12, 63 bne L(mid) b L(end) ALIGN(16) L(top): and a1, r10, mask C d - a andc a2, r11, mask C a - d and d1, r3, mask C a andc d2, r30, mask C d or r3, a1, a2 C new a subf cnt, cnt, r12 or r30, d1, d2 C new d L(mid): srd r3, r3, cnt sub. r10, r30, r3 C r10 = d - a subc r11, r3, r30 C r11 = a - d neg r8, r10 and r8, r8, r10 subfe mask, mask, mask cntlzd cnt, r8 bne L(top) L(end): sld r3, r30, r31 addi r1, r1, 128 ld r0, 16(r1) ld r30, -16(r1) ld r31, -8(r1) mtlr r0 blr EPILOGUE() gcl-2.6.14/gmp4/.pc/applied-patches0000644000175000017500000000005114360276512015304 0ustar cammcammarm-asm-nothumb.patch 4a6d258b467f.patch gcl-2.6.14/gmp4/COPYINGv30000644000175000017500000010451614360276512013155 0ustar cammcamm GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . gcl-2.6.14/gmp4/errno.c0000644000175000017500000000422714360276512013140 0ustar cammcamm/* gmp_errno, __gmp_exception -- exception handling and reporting. THE FUNCTIONS IN THIS FILE, APART FROM gmp_errno, ARE FOR INTERNAL USE ONLY. THEY'RE ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. Copyright 2000, 2001, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include "gmp.h" #include "gmp-impl.h" int gmp_errno = 0; /* The deliberate divide by zero triggers an exception on most systems. On those where it doesn't, for example power and powerpc, use abort instead. Enhancement: Perhaps raise(SIGFPE) (or the same with kill()) would be better than abort. Perhaps it'd be possible to get the BSD style FPE_INTDIV_TRAP parameter in there too. */ void __gmp_exception (int error_bit) { gmp_errno |= error_bit; __gmp_junk = 10 / __gmp_0; abort (); } /* These functions minimize the amount of code required in functions raising exceptions. Since they're "noreturn" and don't take any parameters, a test and call might even come out as a simple conditional jump. */ void __gmp_sqrt_of_negative (void) { __gmp_exception (GMP_ERROR_SQRT_OF_NEGATIVE); } void __gmp_divide_by_zero (void) { __gmp_exception (GMP_ERROR_DIVISION_BY_ZERO); } gcl-2.6.14/gmp4/extract-dbl.c0000644000175000017500000001637014360276512014226 0ustar cammcamm/* __gmp_extract_double -- convert from double to array of mp_limb_t. Copyright 1996, 1999-2002, 2006, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #ifdef XDEBUG #undef _GMP_IEEE_FLOATS #endif #ifndef _GMP_IEEE_FLOATS #define _GMP_IEEE_FLOATS 0 #endif /* Extract a non-negative double in d. */ int __gmp_extract_double (mp_ptr rp, double d) { long exp; unsigned sc; #ifdef _LONG_LONG_LIMB #define BITS_PER_PART 64 /* somewhat bogus */ unsigned long long int manl; #else #define BITS_PER_PART GMP_LIMB_BITS unsigned long int manh, manl; #endif /* BUGS 1. Should handle Inf and NaN in IEEE specific code. 2. Handle Inf and NaN also in default code, to avoid hangs. 3. Generalize to handle all GMP_LIMB_BITS >= 32. 4. This lits is incomplete and misspelled. */ ASSERT (d >= 0.0); if (d == 0.0) { MPN_ZERO (rp, LIMBS_PER_DOUBLE); return 0; } #if _GMP_IEEE_FLOATS { #if defined (__alpha) && __GNUC__ == 2 && __GNUC_MINOR__ == 8 /* Work around alpha-specific bug in GCC 2.8.x. */ volatile #endif union ieee_double_extract x; x.d = d; exp = x.s.exp; #if BITS_PER_PART == 64 /* generalize this to BITS_PER_PART > BITS_IN_MANTISSA */ manl = (((mp_limb_t) 1 << 63) | ((mp_limb_t) x.s.manh << 43) | ((mp_limb_t) x.s.manl << 11)); if (exp == 0) { /* Denormalized number. Don't try to be clever about this, since it is not an important case to make fast. */ exp = 1; do { manl = manl << 1; exp--; } while ((manl & GMP_LIMB_HIGHBIT) == 0); } #endif #if BITS_PER_PART == 32 manh = ((mp_limb_t) 1 << 31) | (x.s.manh << 11) | (x.s.manl >> 21); manl = x.s.manl << 11; if (exp == 0) { /* Denormalized number. Don't try to be clever about this, since it is not an important case to make fast. */ exp = 1; do { manh = (manh << 1) | (manl >> 31); manl = manl << 1; exp--; } while ((manh & GMP_LIMB_HIGHBIT) == 0); } #endif #if BITS_PER_PART != 32 && BITS_PER_PART != 64 You need to generalize the code above to handle this. #endif exp -= 1022; /* Remove IEEE bias. */ } #else { /* Unknown (or known to be non-IEEE) double format. */ exp = 0; if (d >= 1.0) { ASSERT_ALWAYS (d * 0.5 != d); while (d >= 32768.0) { d *= (1.0 / 65536.0); exp += 16; } while (d >= 1.0) { d *= 0.5; exp += 1; } } else if (d < 0.5) { while (d < (1.0 / 65536.0)) { d *= 65536.0; exp -= 16; } while (d < 0.5) { d *= 2.0; exp -= 1; } } d *= (4.0 * ((unsigned long int) 1 << (BITS_PER_PART - 2))); #if BITS_PER_PART == 64 manl = d; #endif #if BITS_PER_PART == 32 manh = d; manl = (d - manh) * (4.0 * ((unsigned long int) 1 << (BITS_PER_PART - 2))); #endif } #endif /* IEEE */ sc = (unsigned) (exp + 64 * GMP_NUMB_BITS) % GMP_NUMB_BITS; /* We add something here to get rounding right. */ exp = (exp + 64 * GMP_NUMB_BITS) / GMP_NUMB_BITS - 64 * GMP_NUMB_BITS / GMP_NUMB_BITS + 1; #if BITS_PER_PART == 64 && LIMBS_PER_DOUBLE == 2 #if GMP_NAIL_BITS == 0 if (sc != 0) { rp[1] = manl >> (GMP_LIMB_BITS - sc); rp[0] = manl << sc; } else { rp[1] = manl; rp[0] = 0; exp--; } #else if (sc > GMP_NAIL_BITS) { rp[1] = manl >> (GMP_LIMB_BITS - sc); rp[0] = (manl << (sc - GMP_NAIL_BITS)) & GMP_NUMB_MASK; } else { if (sc == 0) { rp[1] = manl >> GMP_NAIL_BITS; rp[0] = (manl << GMP_NUMB_BITS - GMP_NAIL_BITS) & GMP_NUMB_MASK; exp--; } else { rp[1] = manl >> (GMP_LIMB_BITS - sc); rp[0] = (manl >> (GMP_NAIL_BITS - sc)) & GMP_NUMB_MASK; } } #endif #endif #if BITS_PER_PART == 64 && LIMBS_PER_DOUBLE == 3 if (sc > GMP_NAIL_BITS) { rp[2] = manl >> (GMP_LIMB_BITS - sc); rp[1] = (manl << sc - GMP_NAIL_BITS) & GMP_NUMB_MASK; if (sc >= 2 * GMP_NAIL_BITS) rp[0] = 0; else rp[0] = (manl << GMP_NUMB_BITS - GMP_NAIL_BITS + sc) & GMP_NUMB_MASK; } else { if (sc == 0) { rp[2] = manl >> GMP_NAIL_BITS; rp[1] = (manl << GMP_NUMB_BITS - GMP_NAIL_BITS) & GMP_NUMB_MASK; rp[0] = 0; exp--; } else { rp[2] = manl >> (GMP_LIMB_BITS - sc); rp[1] = (manl >> GMP_NAIL_BITS - sc) & GMP_NUMB_MASK; rp[0] = (manl << GMP_NUMB_BITS - GMP_NAIL_BITS + sc) & GMP_NUMB_MASK; } } #endif #if BITS_PER_PART == 32 && LIMBS_PER_DOUBLE == 3 #if GMP_NAIL_BITS == 0 if (sc != 0) { rp[2] = manh >> (GMP_LIMB_BITS - sc); rp[1] = (manh << sc) | (manl >> (GMP_LIMB_BITS - sc)); rp[0] = manl << sc; } else { rp[2] = manh; rp[1] = manl; rp[0] = 0; exp--; } #else if (sc > GMP_NAIL_BITS) { rp[2] = (manh >> (GMP_LIMB_BITS - sc)); rp[1] = ((manh << (sc - GMP_NAIL_BITS)) | (manl >> (GMP_LIMB_BITS - sc + GMP_NAIL_BITS))) & GMP_NUMB_MASK; if (sc >= 2 * GMP_NAIL_BITS) rp[0] = (manl << sc - 2 * GMP_NAIL_BITS) & GMP_NUMB_MASK; else rp[0] = manl >> (2 * GMP_NAIL_BITS - sc) & GMP_NUMB_MASK; } else { if (sc == 0) { rp[2] = manh >> GMP_NAIL_BITS; rp[1] = ((manh << GMP_NUMB_BITS - GMP_NAIL_BITS) | (manl >> 2 * GMP_NAIL_BITS)) & GMP_NUMB_MASK; rp[0] = (manl << GMP_NUMB_BITS - 2 * GMP_NAIL_BITS) & GMP_NUMB_MASK; exp--; } else { rp[2] = (manh >> (GMP_LIMB_BITS - sc)); rp[1] = (manh >> (GMP_NAIL_BITS - sc)) & GMP_NUMB_MASK; rp[0] = ((manh << (GMP_NUMB_BITS - GMP_NAIL_BITS + sc)) | (manl >> (GMP_LIMB_BITS - (GMP_NUMB_BITS - GMP_NAIL_BITS + sc)))) & GMP_NUMB_MASK; } } #endif #endif #if BITS_PER_PART == 32 && LIMBS_PER_DOUBLE > 3 if (sc == 0) { int i; for (i = LIMBS_PER_DOUBLE - 1; i >= 0; i--) { rp[i] = manh >> (BITS_PER_ULONG - GMP_NUMB_BITS); manh = ((manh << GMP_NUMB_BITS) | (manl >> (BITS_PER_ULONG - GMP_NUMB_BITS))); manl = manl << GMP_NUMB_BITS; } exp--; } else { int i; rp[LIMBS_PER_DOUBLE - 1] = (manh >> (GMP_LIMB_BITS - sc)); manh = (manh << sc) | (manl >> (GMP_LIMB_BITS - sc)); manl = (manl << sc); for (i = LIMBS_PER_DOUBLE - 2; i >= 0; i--) { rp[i] = manh >> (BITS_PER_ULONG - GMP_NUMB_BITS); manh = ((manh << GMP_NUMB_BITS) | (manl >> (BITS_PER_ULONG - GMP_NUMB_BITS))); manl = manl << GMP_NUMB_BITS; } } #endif return exp; } gcl-2.6.14/gmp4/bootstrap.c0000644000175000017500000000601414360276512014024 0ustar cammcamm/* Functions needed for bootstrapping the gmp build, based on mini-gmp. Copyright 2001, 2002, 2004, 2011, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "mini-gmp/mini-gmp.c" #define MIN(l,o) ((l) < (o) ? (l) : (o)) #define PTR(x) ((x)->_mp_d) #define SIZ(x) ((x)->_mp_size) #define xmalloc gmp_default_alloc int isprime (unsigned long int t) { unsigned long int q, r, d; if (t < 32) return (0xa08a28acUL >> t) & 1; if ((t & 1) == 0) return 0; if (t % 3 == 0) return 0; if (t % 5 == 0) return 0; if (t % 7 == 0) return 0; for (d = 11;;) { q = t / d; r = t - q * d; if (q < d) return 1; if (r == 0) break; d += 2; q = t / d; r = t - q * d; if (q < d) return 1; if (r == 0) break; d += 4; } return 0; } int log2_ceil (int n) { int e; assert (n >= 1); for (e = 0; ; e++) if ((1 << e) >= n) break; return e; } /* Set inv to the inverse of d, in the style of invert_limb, ie. for udiv_qrnnd_preinv. */ void mpz_preinv_invert (mpz_t inv, mpz_t d, int numb_bits) { mpz_t t; int norm; assert (SIZ(d) > 0); norm = numb_bits - mpz_sizeinbase (d, 2); assert (norm >= 0); mpz_init_set_ui (t, 1L); mpz_mul_2exp (t, t, 2*numb_bits - norm); mpz_tdiv_q (inv, t, d); mpz_set_ui (t, 1L); mpz_mul_2exp (t, t, numb_bits); mpz_sub (inv, inv, t); mpz_clear (t); } /* Calculate r satisfying r*d == 1 mod 2^n. */ void mpz_invert_2exp (mpz_t r, mpz_t a, unsigned long n) { unsigned long i; mpz_t inv, prod; assert (mpz_odd_p (a)); mpz_init_set_ui (inv, 1L); mpz_init (prod); for (i = 1; i < n; i++) { mpz_mul (prod, inv, a); if (mpz_tstbit (prod, i) != 0) mpz_setbit (inv, i); } mpz_mul (prod, inv, a); mpz_tdiv_r_2exp (prod, prod, n); assert (mpz_cmp_ui (prod, 1L) == 0); mpz_set (r, inv); mpz_clear (inv); mpz_clear (prod); } /* Calculate inv satisfying r*a == 1 mod 2^n. */ void mpz_invert_ui_2exp (mpz_t r, unsigned long a, unsigned long n) { mpz_t az; mpz_init_set_ui (az, a); mpz_invert_2exp (r, az, n); mpz_clear (az); } gcl-2.6.14/gmp4/test-driver0000755000175000017500000001027714360276512014047 0ustar cammcamm#! /bin/sh # test-driver - basic testsuite driver script. scriptversion=2013-07-13.22; # UTC # Copyright (C) 2011-2013 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to or send patches to # . # Make unconditional expansion of undefined variables an error. This # helps a lot in preventing typo-related bugs. set -u usage_error () { echo "$0: $*" >&2 print_usage >&2 exit 2 } print_usage () { cat <$log_file 2>&1 estatus=$? if test $enable_hard_errors = no && test $estatus -eq 99; then estatus=1 fi case $estatus:$expect_failure in 0:yes) col=$red res=XPASS recheck=yes gcopy=yes;; 0:*) col=$grn res=PASS recheck=no gcopy=no;; 77:*) col=$blu res=SKIP recheck=no gcopy=yes;; 99:*) col=$mgn res=ERROR recheck=yes gcopy=yes;; *:yes) col=$lgn res=XFAIL recheck=no gcopy=yes;; *:*) col=$red res=FAIL recheck=yes gcopy=yes;; esac # Report outcome to console. echo "${col}${res}${std}: $test_name" # Register the test result, and other relevant metadata. echo ":test-result: $res" > $trs_file echo ":global-test-result: $res" >> $trs_file echo ":recheck: $recheck" >> $trs_file echo ":copy-in-global-log: $gcopy" >> $trs_file # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: gcl-2.6.14/gmp4/mp_set_fns.c0000644000175000017500000000314214360276512014143 0ustar cammcamm/* mp_set_memory_functions -- Set the allocate, reallocate, and free functions for use by the mp package. Copyright 1991, 1993, 1994, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mp_set_memory_functions (void *(*alloc_func) (size_t), void *(*realloc_func) (void *, size_t, size_t), void (*free_func) (void *, size_t)) __GMP_NOTHROW { if (alloc_func == 0) alloc_func = __gmp_default_allocate; if (realloc_func == 0) realloc_func = __gmp_default_reallocate; if (free_func == 0) free_func = __gmp_default_free; __gmp_allocate_func = alloc_func; __gmp_reallocate_func = realloc_func; __gmp_free_func = free_func; } gcl-2.6.14/gmp4/configure.ac0000644000175000017500000040221014360276512014127 0ustar cammcammdnl Process this file with autoconf to produce a configure script. define(GMP_COPYRIGHT,[[ Copyright 1996-2014 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. ]]) AC_COPYRIGHT(GMP_COPYRIGHT) AH_TOP(/*GMP_COPYRIGHT*/) AC_REVISION($Revision$) AC_PREREQ(2.59) AC_INIT(GNU MP, GMP_VERSION, [gmp-bugs@gmplib.org, see https://gmplib.org/manual/Reporting-Bugs.html], gmp) AC_CONFIG_SRCDIR(gmp-impl.h) m4_pattern_forbid([^[ \t]*GMP_]) m4_pattern_allow(GMP_LDFLAGS) m4_pattern_allow(GMP_LIMB_BITS) m4_pattern_allow(GMP_MPARAM_H_SUGGEST) m4_pattern_allow(GMP_NAIL_BITS) m4_pattern_allow(GMP_NUMB_BITS) m4_pattern_allow(GMP_NONSTD_ABI) m4_pattern_allow(GMP_CPU_TYPE) # If --target is not used then $target_alias is empty, but if say # "./configure athlon-pc-freebsd3.5" is used, then all three of # $build_alias, $host_alias and $target_alias are set to # "athlon-pc-freebsd3.5". # if test -n "$target_alias" && test "$target_alias" != "$host_alias"; then AC_MSG_ERROR([--target is not appropriate for GMP Use --build=CPU-VENDOR-OS if you need to specify your CPU and/or system explicitly. Use --host if cross-compiling (see "Installing GMP" in the manual for more on this).]) fi GMP_INIT(config.m4) AC_CANONICAL_HOST dnl Automake "no-dependencies" is used because include file dependencies dnl are not useful to us. Pretty much everything depends just on gmp.h, dnl gmp-impl.h and longlong.h, and yet only rarely does everything need to dnl be rebuilt for changes to those files. dnl dnl "no-dependencies" also helps with the way we're setup to run dnl AC_PROG_CXX only conditionally. If dependencies are used then recent dnl automake (eg 1.7.2) appends an AM_CONDITIONAL to AC_PROG_CXX, and then dnl gets upset if it's not actually executed. dnl dnl Note that there's a copy of these options in the top-level Makefile.am, dnl so update there too if changing anything. dnl AM_INIT_AUTOMAKE([1.8 gnu no-dependencies]) AC_CONFIG_HEADERS(config.h:config.in) AM_MAINTAINER_MODE AC_ARG_ENABLE(assert, AC_HELP_STRING([--enable-assert],[enable ASSERT checking [[default=no]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-assert, need yes or no]) ;; esac], [enable_assert=no]) if test "$enable_assert" = "yes"; then AC_DEFINE(WANT_ASSERT,1, [Define to 1 to enable ASSERT checking, per --enable-assert]) want_assert_01=1 else want_assert_01=0 fi GMP_DEFINE_RAW(["define(,$want_assert_01)"]) AC_ARG_ENABLE(alloca, AC_HELP_STRING([--enable-alloca],[how to get temp memory [[default=reentrant]]]), [case $enableval in alloca|malloc-reentrant|malloc-notreentrant) ;; yes|no|reentrant|notreentrant) ;; debug) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-alloca, need one of: yes no reentrant notreentrant alloca malloc-reentrant malloc-notreentrant debug]) ;; esac], [enable_alloca=reentrant]) # IMPROVE ME: The default for C++ is disabled. The tests currently # performed below for a working C++ compiler are not particularly strong, # and in general can't be expected to get the right setup on their own. The # most significant problem is getting the ABI the same. Defaulting CXXFLAGS # to CFLAGS takes only a small step towards this. It's also probably worth # worrying whether the C and C++ runtimes from say gcc and a vendor C++ can # work together. Some rather broken C++ installations were encountered # during testing, and though such things clearly aren't GMP's problem, if # --enable-cxx=detect were to be the default then some careful checks of # which, if any, C++ compiler on the system is up to scratch would be # wanted. # AC_ARG_ENABLE(cxx, AC_HELP_STRING([--enable-cxx],[enable C++ support [[default=no]]]), [case $enableval in yes|no|detect) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-cxx, need yes/no/detect]) ;; esac], [enable_cxx=no]) AC_ARG_ENABLE(assembly, AC_HELP_STRING([--enable-assembly],[enable the use of assembly loops [[default=yes]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-assembly, need yes or no]) ;; esac], [enable_assembly=yes]) if test "$enable_assembly" = "yes"; then AC_DEFINE(WANT_ASSEMBLY,1, [Defined to 1 as per --enable-assembly]) fi AC_ARG_ENABLE(fft, AC_HELP_STRING([--enable-fft],[enable FFTs for multiplication [[default=yes]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-fft, need yes or no]) ;; esac], [enable_fft=yes]) if test "$enable_fft" = "yes"; then AC_DEFINE(WANT_FFT,1, [Define to 1 to enable FFTs for multiplication, per --enable-fft]) fi AC_ARG_ENABLE(old-fft-full, AC_HELP_STRING([--enable-old-fft-full],[enable old mpn_mul_fft_full for multiplication [[default=no]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-old-fft-full, need yes or no]) ;; esac], [enable_old_fft_full=no]) if test "$enable_old_fft_full" = "yes"; then AC_DEFINE(WANT_OLD_FFT_FULL,1, [Define to 1 to enable old mpn_mul_fft_full for multiplication, per --enable-old-fft-full]) fi AC_ARG_ENABLE(nails, AC_HELP_STRING([--enable-nails],[use nails on limbs [[default=no]]]), [case $enableval in [yes|no|[02468]|[0-9][02468]]) ;; [*[13579]]) AC_MSG_ERROR([bad value $enableval for --enable-nails, only even nail sizes supported]) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-nails, need yes/no/number]) ;; esac], [enable_nails=no]) case $enable_nails in yes) GMP_NAIL_BITS=2 ;; no) GMP_NAIL_BITS=0 ;; *) GMP_NAIL_BITS=$enable_nails ;; esac AC_SUBST(GMP_NAIL_BITS) AC_ARG_ENABLE(profiling, AC_HELP_STRING([--enable-profiling], [build with profiler support [[default=no]]]), [case $enableval in no|prof|gprof|instrument) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-profiling, need no/prof/gprof/instrument]) ;; esac], [enable_profiling=no]) case $enable_profiling in prof) AC_DEFINE(WANT_PROFILING_PROF, 1, [Define to 1 if --enable-profiling=prof]) ;; gprof) AC_DEFINE(WANT_PROFILING_GPROF, 1, [Define to 1 if --enable-profiling=gprof]) ;; instrument) AC_DEFINE(WANT_PROFILING_INSTRUMENT, 1, [Define to 1 if --enable-profiling=instrument]) ;; esac GMP_DEFINE_RAW(["define(,<\`$enable_profiling'>)"]) # -fomit-frame-pointer is incompatible with -pg on some chips if test "$enable_profiling" = gprof; then fomit_frame_pointer= else fomit_frame_pointer="-fomit-frame-pointer" fi AC_ARG_WITH(readline, AC_HELP_STRING([--with-readline], [readline support in calc demo program [[default=detect]]]), [case $withval in yes|no|detect) ;; *) AC_MSG_ERROR([bad value $withval for --with-readline, need yes/no/detect]) ;; esac], [with_readline=detect]) AC_ARG_ENABLE(fat, AC_HELP_STRING([--enable-fat], [build a fat binary on systems that support it [[default=no]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-fat, need yes or no]) ;; esac], [enable_fat=no]) AC_ARG_ENABLE(minithres, AC_HELP_STRING([--enable-minithres], [choose minimal thresholds for testing [[default=no]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-minithres, need yes or no]) ;; esac], [enable_minithres=no]) AC_ARG_ENABLE(fake-cpuid, AC_HELP_STRING([--enable-fake-cpuid],[enable GMP_CPU_TYPE faking cpuid [[default=no]]]), [case $enableval in yes|no) ;; *) AC_MSG_ERROR([bad value $enableval for --enable-fake-cpuid, need yes or no]) ;; esac], [enable_fake_cpuid=no]) if test "$enable_fake_cpuid" = "yes"; then AC_DEFINE(WANT_FAKE_CPUID,1, [Define to 1 to enable GMP_CPU_TYPE faking cpuid, per --enable-fake-cpuid]) fi if test $enable_fat = yes && test $enable_assembly = no ; then AC_MSG_ERROR([when doing a fat build, disabling assembly will not work]) fi if test $enable_fake_cpuid = yes && test $enable_fat = no ; then AC_MSG_ERROR([--enable-fake-cpuid requires --enable-fat]) fi tmp_host=`echo $host_cpu | sed 's/\./_/'` AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_$tmp_host) GMP_DEFINE_RAW("define_not_for_expansion(\`HAVE_HOST_CPU_$tmp_host')", POST) dnl The HAVE_HOST_CPU_ list here only needs to have entries for those which dnl are going to be tested, not everything that can possibly be selected. dnl dnl The HAVE_HOST_CPU_FAMILY_ list similarly, and note that the AC_DEFINEs dnl for these are under the cpu specific setups below. AH_VERBATIM([HAVE_HOST_CPU_1], [/* Define one of these to 1 for the host CPU family. If your CPU is not in any of these families, leave all undefined. For an AMD64 chip, define "x86" in ABI=32, but not in ABI=64. */ #undef HAVE_HOST_CPU_FAMILY_alpha #undef HAVE_HOST_CPU_FAMILY_m68k #undef HAVE_HOST_CPU_FAMILY_power #undef HAVE_HOST_CPU_FAMILY_powerpc #undef HAVE_HOST_CPU_FAMILY_x86 #undef HAVE_HOST_CPU_FAMILY_x86_64 /* Define one of the following to 1 for the host CPU, as per the output of ./config.guess. If your CPU is not listed here, leave all undefined. */ #undef HAVE_HOST_CPU_alphaev67 #undef HAVE_HOST_CPU_alphaev68 #undef HAVE_HOST_CPU_alphaev7 #undef HAVE_HOST_CPU_m68020 #undef HAVE_HOST_CPU_m68030 #undef HAVE_HOST_CPU_m68040 #undef HAVE_HOST_CPU_m68060 #undef HAVE_HOST_CPU_m68360 #undef HAVE_HOST_CPU_powerpc604 #undef HAVE_HOST_CPU_powerpc604e #undef HAVE_HOST_CPU_powerpc750 #undef HAVE_HOST_CPU_powerpc7400 #undef HAVE_HOST_CPU_supersparc #undef HAVE_HOST_CPU_i386 #undef HAVE_HOST_CPU_i586 #undef HAVE_HOST_CPU_i686 #undef HAVE_HOST_CPU_pentium #undef HAVE_HOST_CPU_pentiummmx #undef HAVE_HOST_CPU_pentiumpro #undef HAVE_HOST_CPU_pentium2 #undef HAVE_HOST_CPU_pentium3 #undef HAVE_HOST_CPU_s390_z900 #undef HAVE_HOST_CPU_s390_z990 #undef HAVE_HOST_CPU_s390_z9 #undef HAVE_HOST_CPU_s390_z10 #undef HAVE_HOST_CPU_s390_z196 /* Define to 1 iff we have a s390 with 64-bit registers. */ #undef HAVE_HOST_CPU_s390_zarch]) # Table of compilers, options, and mpn paths. This code has various related # purposes # # - better default CC/CFLAGS selections than autoconf otherwise gives # - default CC/CFLAGS selections for extra CPU types specific to GMP # - a few tests for known bad compilers # - choice of ABIs on suitable systems # - selection of corresponding mpn search path # # After GMP specific searches and tests, the standard autoconf AC_PROG_CC is # called. User selections of CC etc are respected. # # Care is taken not to use macros like AC_TRY_COMPILE during the GMP # pre-testing, since they of course depend on AC_PROG_CC, and also some of # them cache their results, which is not wanted. # # The ABI selection mechanism is unique to GMP. All that reaches autoconf # is a different selection of CC/CFLAGS according to the best ABI the system # supports, and/or what the user selects. Naturally the mpn assembler code # selected is very dependent on the ABI. # # The closest the standard tools come to a notion of ABI is something like # "sparc64" which encodes a CPU and an ABI together. This doesn't seem to # scale well for GMP, where exact CPU types like "ultrasparc2" are wanted, # separate from the ABI used on them. # # # The variables set here are # # cclist the compiler choices # xx_cflags flags for compiler xx # xx_cflags_maybe flags for compiler xx, if they work # xx_cppflags cpp flags for compiler xx # xx_cflags_optlist list of sets of optional flags # xx_cflags_yyy set yyy of optional flags for compiler xx # xx_ldflags -Wc,-foo flags for libtool linking with compiler xx # ar_flags extra flags for $AR # nm_flags extra flags for $NM # limb limb size, can be "longlong" # path mpn search path # extra_functions extra mpn functions # fat_path fat binary mpn search path [if fat binary desired] # fat_functions fat functions # fat_thresholds fat thresholds # # Suppose xx_cflags_optlist="arch", then flags from $xx_cflags_arch are # tried, and the first flag that works will be used. An optlist like "arch # cpu optimize" can be used to get multiple independent sets of flags tried. # The first that works from each will be used. If no flag in a set works # then nothing from that set is added. # # For multiple ABIs, the scheme extends as follows. # # abilist set of ABI choices # cclist_aa compiler choices in ABI aa # xx_aa_cflags flags for xx in ABI aa # xx_aa_cflags_maybe flags for xx in ABI aa, if they work # xx_aa_cppflags cpp flags for xx in ABI aa # xx_aa_cflags_optlist list of sets of optional flags in ABI aa # xx_aa_cflags_yyy set yyy of optional flags for compiler xx in ABI aa # xx_aa_ldflags -Wc,-foo flags for libtool linking # ar_aa_flags extra flags for $AR in ABI aa # nm_aa_flags extra flags for $NM in ABI aa # limb_aa limb size in ABI aa, can be "longlong" # path_aa mpn search path in ABI aa # extra_functions_aa extra mpn functions in ABI aa # # As a convenience, the unadorned xx_cflags (etc) are used for the last ABI # in ablist, if an xx_aa_cflags for that ABI isn't given. For example if # abilist="64 32" then $cc_64_cflags will be used for the 64-bit ABI, but # for the 32-bit either $cc_32_cflags or $cc_cflags is used, whichever is # defined. This makes it easy to add some 64-bit compilers and flags to an # unadorned 32-bit set. # # limb=longlong (or limb_aa=longlong) applies to all compilers within that # ABI. It won't work to have some needing long long and some not, since a # single instantiated gmp.h will be used by both. # # SPEED_CYCLECOUNTER, cyclecounter_size and CALLING_CONVENTIONS_OBJS are # also set here, with an ABI suffix. # # # # A table-driven approach like this to mapping cpu type to good compiler # options is a bit of a maintenance burden, but there's not much uniformity # between options specifications on different compilers. Some sort of # separately updatable tool might be cute. # # The use of lots of variables like this, direct and indirect, tends to # obscure when and how various things are done, but unfortunately it's # pretty much the only way. If shell subroutines were portable then actual # code like "if this .. do that" could be written, but attempting the same # with full copies of GMP_PROG_CC_WORKS etc expanded at every point would # hugely bloat the output. AC_ARG_VAR(ABI, [desired ABI (for processors supporting more than one ABI)]) # abilist needs to be non-empty, "standard" is just a generic name here abilist="standard" # FIXME: We'd like to prefer an ANSI compiler, perhaps by preferring # c89 over cc here. But note that on HP-UX c89 provides a castrated # environment, and would want to be excluded somehow. Maybe # AC_PROG_CC_STDC already does enough to stick cc into ANSI mode and # we don't need to worry. # cclist="gcc cc" gcc_cflags="-O2 -pedantic" gcc_64_cflags="-O2 -pedantic" cc_cflags="-O" cc_64_cflags="-O" SPEED_CYCLECOUNTER_OBJ= cyclecounter_size=2 AC_SUBST(HAVE_HOST_CPU_FAMILY_power, 0) AC_SUBST(HAVE_HOST_CPU_FAMILY_powerpc,0) case $host in alpha*-*-*) AC_DEFINE(HAVE_HOST_CPU_FAMILY_alpha) case $host_cpu in alphaev5* | alphapca5*) path="alpha/ev5 alpha" ;; alphaev67 | alphaev68 | alphaev7*) path="alpha/ev67 alpha/ev6 alpha" ;; alphaev6) path="alpha/ev6 alpha" ;; *) path="alpha" ;; esac if test "$enable_assembly" = "yes" ; then extra_functions="cntlz" fi gcc_cflags_optlist="asm cpu oldas" # need asm ahead of cpu, see below gcc_cflags_maybe="-mieee" gcc_cflags_oldas="-Wa,-oldas" # see GMP_GCC_WA_OLDAS. # gcc 2.7.2.3 doesn't know any -mcpu= for alpha, apparently. # gcc 2.95 knows -mcpu= ev4, ev5, ev56, pca56, ev6. # gcc 3.0 adds nothing. # gcc 3.1 adds ev45, ev67 (but ev45 is the same as ev4). # gcc 3.2 adds nothing. # # gcc version "2.9-gnupro-99r1" under "-O2 -mcpu=ev6" strikes internal # compiler errors too easily and is rejected by GMP_PROG_CC_WORKS. Each # -mcpu=ev6 below has a fallback to -mcpu=ev56 for this reason. # case $host_cpu in alpha) gcc_cflags_cpu="-mcpu=ev4" ;; alphaev5) gcc_cflags_cpu="-mcpu=ev5" ;; alphaev56) gcc_cflags_cpu="-mcpu=ev56" ;; alphapca56 | alphapca57) gcc_cflags_cpu="-mcpu=pca56" ;; alphaev6) gcc_cflags_cpu="-mcpu=ev6 -mcpu=ev56" ;; alphaev67 | alphaev68 | alphaev7*) gcc_cflags_cpu="-mcpu=ev67 -mcpu=ev6 -mcpu=ev56" ;; esac # gcc version "2.9-gnupro-99r1" on alphaev68-dec-osf5.1 has been seen # accepting -mcpu=ev6, but not putting the assembler in the right mode # for what it produces. We need to do this for it, and need to do it # before testing the -mcpu options. # # On old versions of gcc, which don't know -mcpu=, we believe an # explicit -Wa,-mev5 etc will be necessary to put the assembler in # the right mode for our .asm files and longlong.h asm blocks. # # On newer versions of gcc, when -mcpu= is known, we must give a -Wa # which is at least as high as the code gcc will generate. gcc # establishes what it needs with a ".arch" directive, our command line # option seems to override that. # # gas prior to 2.14 doesn't accept -mev67, but -mev6 seems enough for # ctlz and cttz (in 2.10.0 at least). # # OSF `as' accepts ev68 but stupidly treats it as ev4. -arch only seems # to affect insns like ldbu which are expanded as macros when necessary. # Insns like ctlz which were never available as macros are always # accepted and always generate their plain code. # case $host_cpu in alpha) gcc_cflags_asm="-Wa,-arch,ev4 -Wa,-mev4" ;; alphaev5) gcc_cflags_asm="-Wa,-arch,ev5 -Wa,-mev5" ;; alphaev56) gcc_cflags_asm="-Wa,-arch,ev56 -Wa,-mev56" ;; alphapca56 | alphapca57) gcc_cflags_asm="-Wa,-arch,pca56 -Wa,-mpca56" ;; alphaev6) gcc_cflags_asm="-Wa,-arch,ev6 -Wa,-mev6" ;; alphaev67 | alphaev68 | alphaev7*) gcc_cflags_asm="-Wa,-arch,ev67 -Wa,-mev67 -Wa,-arch,ev6 -Wa,-mev6" ;; esac # It might be better to ask "cc" whether it's Cray C or DEC C, # instead of relying on the OS part of $host. But it's hard to # imagine either of those compilers anywhere except their native # systems. # GMP_INCLUDE_MPN(alpha/alpha-defs.m4) case $host in *-cray-unicos*) cc_cflags="-O" # no -g, it silently disables all optimizations GMP_INCLUDE_MPN(alpha/unicos.m4) # Don't perform any assembly syntax tests on this beast. gmp_asm_syntax_testing=no ;; *-*-osf*) GMP_INCLUDE_MPN(alpha/default.m4) cc_cflags="" cc_cflags_optlist="opt cpu" # not sure if -fast works on old versions, so make it optional cc_cflags_opt="-fast -O2" # DEC C V5.9-005 knows ev4, ev5, ev56, pca56, ev6. # Compaq C V6.3-029 adds ev67. # case $host_cpu in alpha) cc_cflags_cpu="-arch~ev4~-tune~ev4" ;; alphaev5) cc_cflags_cpu="-arch~ev5~-tune~ev5" ;; alphaev56) cc_cflags_cpu="-arch~ev56~-tune~ev56" ;; alphapca56 | alphapca57) cc_cflags_cpu="-arch~pca56~-tune~pca56" ;; alphaev6) cc_cflags_cpu="-arch~ev6~-tune~ev6" ;; alphaev67 | alphaev68 | alphaev7*) cc_cflags_cpu="-arch~ev67~-tune~ev67 -arch~ev6~-tune~ev6" ;; esac ;; *) GMP_INCLUDE_MPN(alpha/default.m4) ;; esac case $host in *-*-unicos*) # tune/alpha.asm assumes int==4bytes but unicos uses int==8bytes ;; *) SPEED_CYCLECOUNTER_OBJ=alpha.lo cyclecounter_size=1 ;; esac ;; # Cray vector machines. # This must come after alpha* so that we can recognize present and future # vector processors with a wildcard. *-cray-unicos*) gmp_asm_syntax_testing=no cclist="cc" # We used to have -hscalar0 here as a workaround for miscompilation of # mpz/import.c, but let's hope Cray fixes their bugs instead, since # -hscalar0 causes disastrously poor code to be generated. cc_cflags="-O3 -hnofastmd -htask0 -Wa,-B" path="cray" ;; arm64*-*-* | aarch64*-*-*) path="arm64" ;; arm*-*-*) gcc_cflags="$gcc_cflags $fomit_frame_pointer" gcc_cflags_optlist="arch neon tune" gcc_cflags_maybe="-marm" gcc_testlist="gcc-arm-umodsi" GMP_INCLUDE_MPN(arm/arm-defs.m4) CALLING_CONVENTIONS_OBJS='arm32call.lo arm32check.lo' # FIXME: We make mandatory compiler options optional here. We should # either enforce them, or organise to strip paths as the corresponding # options fail. case $host_cpu in armsa1 | arm9tdmi | armv4*) path="arm" gcc_cflags_arch="-march=armv4" ;; armxscale | arm9te | arm10 | armv5*) path="arm/v5 arm" gcc_cflags_arch="-march=armv5" ;; arm11mpcore | arm1136 | arm1176 | armv6*) path="arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv6" ;; arm1156) path="arm/v6t2 arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv6t2" ;; armcortexa5 | armv7a*) path="arm/v6t2 arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv7-a" ;; armcortexa8) path="arm/v6t2 arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_tune="-mtune=cortex-a8" ;; armcortexa8neon) path="arm/v6t2 arm/v6 arm/v5 arm/neon arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_neon="-mfpu=neon" gcc_cflags_tune="-mtune=cortex-a8" ;; armcortexa9) path="arm/v7a/cora9 arm/v6t2 arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_tune="-mtune=cortex-a9" ;; armcortexa9neon) path="arm/v7a/cora9 arm/v6t2 arm/v6 arm/v5 arm/neon arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_neon="-mfpu=neon" gcc_cflags_tune="-mtune=cortex-a9" ;; armcortexa15) path="arm/v7a/cora15 arm/v6t2 arm/v6 arm/v5 arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_tune="-mtune=cortex-a15 -mtune=cortex-a9" ;; armcortexa15neon) path="arm/v7a/cora15/neon arm/v7a/cora15 arm/v6t2 arm/v6 arm/v5 arm/neon arm" gcc_cflags_arch="-march=armv7-a" gcc_cflags_neon="-mfpu=neon" gcc_cflags_tune="-mtune=cortex-a15 -mtune=cortex-a9" ;; *) path="arm" ;; esac ;; # Fujitsu [f30[01]-fujitsu-sysv*]) cclist="gcc vcc" # FIXME: flags for vcc? vcc_cflags="-g" path="fujitsu" ;; hppa*-*-*) # HP cc (the one sold separately) is K&R by default, but AM_C_PROTOTYPES # will add "-Ae", or "-Aa -D_HPUX_SOURCE", to put it into ansi mode, if # possible. # # gcc for hppa 2.0 can be built either for 2.0n (32-bit) or 2.0w # (64-bit), but not both, so there's no option to choose the desired # mode, we must instead detect which of the two it is. This is done by # checking sizeof(long), either 4 or 8 bytes respectively. Do this in # ABI=1.0 too, in case someone tries to build that with a 2.0w gcc. # gcc_cflags_optlist="arch" gcc_testlist="sizeof-long-4" SPEED_CYCLECOUNTER_OBJ=hppa.lo cyclecounter_size=1 # FIXME: For hppa2.0*, path should be "pa32/hppa2_0 pa32/hppa1_1 pa32". # (Can't remember why this isn't done already, have to check what .asm # files are available in each and how they run on a typical 2.0 cpu.) # case $host_cpu in hppa1.0*) path="pa32" ;; hppa7000*) path="pa32/hppa1_1 pa32" ;; hppa2.0* | hppa64) path="pa32/hppa2_0 pa32/hppa1_1/pa7100 pa32/hppa1_1 pa32" ;; *) # default to 7100 path="pa32/hppa1_1/pa7100 pa32/hppa1_1 pa32" ;; esac # gcc 2.7.2.3 knows -mpa-risc-1-0 and -mpa-risc-1-1 # gcc 2.95 adds -mpa-risc-2-0, plus synonyms -march=1.0, 1.1 and 2.0 # # We don't use -mpa-risc-2-0 in ABI=1.0 because 64-bit registers may not # be saved by the kernel on an old system. Actually gcc (as of 3.2) # only adds a few float instructions with -mpa-risc-2-0, so it would # probably be safe, but let's not take the chance. In any case, a # configuration like --host=hppa2.0 ABI=1.0 is far from optimal. # case $host_cpu in hppa1.0*) gcc_cflags_arch="-mpa-risc-1-0" ;; *) # default to 7100 gcc_cflags_arch="-mpa-risc-1-1" ;; esac case $host_cpu in hppa1.0*) cc_cflags="+O2" ;; *) # default to 7100 cc_cflags="+DA1.1 +O2" ;; esac case $host in hppa2.0*-*-* | hppa64-*-*) cclist_20n="gcc cc" abilist="2.0n 1.0" path_20n="pa64" limb_20n=longlong any_20n_testlist="sizeof-long-4" SPEED_CYCLECOUNTER_OBJ_20n=hppa2.lo cyclecounter_size_20n=2 # -mpa-risc-2-0 is only an optional flag, in case an old gcc is # used. Assembler support for 2.0 is essential though, for our asm # files. gcc_20n_cflags="$gcc_cflags" gcc_20n_cflags_optlist="arch" gcc_20n_cflags_arch="-mpa-risc-2-0 -mpa-risc-1-1" gcc_20n_testlist="sizeof-long-4 hppa-level-2.0" cc_20n_cflags="+DA2.0 +e +O2 -Wl,+vnocompatwarnings" cc_20n_testlist="hpc-hppa-2-0" # ABI=2.0w is available for hppa2.0w and hppa2.0, but not for # hppa2.0n, on the assumption that that the latter indicates a # desire for ABI=2.0n. case $host in hppa2.0n-*-*) ;; *) # HPUX 10 and earlier cannot run 2.0w. Not sure about other # systems (GNU/Linux for instance), but lets assume they're ok. case $host in [*-*-hpux[1-9] | *-*-hpux[1-9].* | *-*-hpux10 | *-*-hpux10.*]) ;; [*-*-linux*]) abilist="1.0" ;; # due to linux permanent kernel bug *) abilist="2.0w $abilist" ;; esac cclist_20w="gcc cc" gcc_20w_cflags="$gcc_cflags -mpa-risc-2-0" cc_20w_cflags="+DD64 +O2" cc_20w_testlist="hpc-hppa-2-0" path_20w="pa64" any_20w_testlist="sizeof-long-8" SPEED_CYCLECOUNTER_OBJ_20w=hppa2w.lo cyclecounter_size_20w=2 ;; esac ;; esac ;; IA64_PATTERN) abilist="64" GMP_INCLUDE_MPN(ia64/ia64-defs.m4) SPEED_CYCLECOUNTER_OBJ=ia64.lo any_32_testlist="sizeof-long-4" case $host_cpu in itanium) path="ia64/itanium ia64" ;; itanium2) path="ia64/itanium2 ia64" ;; *) path="ia64" ;; esac gcc_64_cflags_optlist="tune" gcc_32_cflags_optlist=$gcc_64_cflags_optlist # gcc pre-release 3.4 adds -mtune itanium and itanium2 case $host_cpu in itanium) gcc_cflags_tune="-mtune=itanium" ;; itanium2) gcc_cflags_tune="-mtune=itanium2" ;; esac case $host in *-*-linux*) cclist="gcc icc" icc_cflags="-no-gcc" icc_cflags_optlist="opt" # Don't use -O3, it is for "large data sets" and also miscompiles GMP. # But icc miscompiles GMP at any optimization level, at higher levels # it miscompiles more files... icc_cflags_opt="-O2 -O1" ;; *-*-hpux*) # HP cc sometimes gets internal errors if the optimization level is # too high. GMP_PROG_CC_WORKS detects this, the "_opt" fallbacks # let us use whatever seems to work. # abilist="32 64" any_64_testlist="sizeof-long-8" cclist_32="gcc cc" path_32="ia64" cc_32_cflags="" cc_32_cflags_optlist="opt" cc_32_cflags_opt="+O3 +O2 +O1" gcc_32_cflags="$gcc_cflags -milp32" limb_32=longlong SPEED_CYCLECOUNTER_OBJ_32=ia64.lo cyclecounter_size_32=2 # Must have +DD64 in CPPFLAGS to get the right __LP64__ for headers, # but also need it in CFLAGS for linking programs, since automake # only uses CFLAGS when linking, not CPPFLAGS. # FIXME: Maybe should use cc_64_ldflags for this, but that would # need GMP_LDFLAGS used consistently by all the programs. # cc_64_cflags="+DD64" cc_64_cppflags="+DD64" cc_64_cflags_optlist="opt" cc_64_cflags_opt="+O3 +O2 +O1" gcc_64_cflags="$gcc_cflags -mlp64" ;; esac ;; # Motorola 68k # M68K_PATTERN) AC_DEFINE(HAVE_HOST_CPU_FAMILY_m68k) GMP_INCLUDE_MPN(m68k/m68k-defs.m4) gcc_cflags="$gcc_cflags $fomit_frame_pointer" gcc_cflags_optlist="arch" # gcc 2.7.2 knows -m68000, -m68020, -m68030, -m68040. # gcc 2.95 adds -mcpu32, -m68060. # FIXME: Maybe "-m68020 -mnobitfield" would suit cpu32 on 2.7.2. # case $host_cpu in m68020) gcc_cflags_arch="-m68020" ;; m68030) gcc_cflags_arch="-m68030" ;; m68040) gcc_cflags_arch="-m68040" ;; m68060) gcc_cflags_arch="-m68060 -m68000" ;; m68360) gcc_cflags_arch="-mcpu32 -m68000" ;; *) gcc_cflags_arch="-m68000" ;; esac # FIXME: m68k/mc68020 looks like it's ok for cpu32, but this wants to be # tested. Will need to introduce an m68k/cpu32 if m68k/mc68020 ever uses # the bitfield instructions. case $host_cpu in [m680[234]0 | m68360]) path="m68k/mc68020 m68k" ;; *) path="m68k" ;; esac ;; # Motorola 88k m88k*-*-*) path="m88k" ;; m88110*-*-*) gcc_cflags="$gcc_cflags -m88110" path="m88k/mc88110 m88k" ;; # IRIX 5 and earlier can only run 32-bit o32. # # IRIX 6 and up always has a 64-bit mips CPU can run n32 or 64. n32 is # preferred over 64, but only because that's been the default in past # versions of GMP. The two are equally efficient. # # Linux kernel 2.2.13 arch/mips/kernel/irixelf.c has a comment about not # supporting n32 or 64. # # For reference, libtool (eg. 1.5.6) recognises the n32 ABI and knows the # right options to use when linking (both cc and gcc), so no need for # anything special from us. # mips*-*-*) abilist="o32" gcc_cflags_optlist="abi" gcc_cflags_abi="-mabi=32" gcc_testlist="gcc-mips-o32" path="mips32" cc_cflags="-O2 -o32" # no -g, it disables all optimizations # this suits both mips32 and mips64 GMP_INCLUDE_MPN(mips32/mips-defs.m4) case $host in [mips64*-*-* | mips*-*-irix[6789]*]) abilist="n32 64 o32" cclist_n32="gcc cc" gcc_n32_cflags="$gcc_cflags -mabi=n32" cc_n32_cflags="-O2 -n32" # no -g, it disables all optimizations limb_n32=longlong path_n32="mips64" cclist_64="gcc cc" gcc_64_cflags="$gcc_cflags -mabi=64" gcc_64_ldflags="-Wc,-mabi=64" cc_64_cflags="-O2 -64" # no -g, it disables all optimizations cc_64_ldflags="-Wc,-64" path_64="mips64" ;; esac ;; # Darwin (powerpc-apple-darwin1.3) has it's hacked gcc installed as cc. # Our usual "gcc in disguise" detection means gcc_cflags etc here gets # used. # # The darwin pre-compiling preprocessor is disabled with -no-cpp-precomp # since it doesn't like "__attribute__ ((mode (SI)))" etc in gmp-impl.h, # and so always ends up running the plain preprocessor anyway. This could # be done in CPPFLAGS rather than CFLAGS, but there's not many places # preprocessing is done separately, and this is only a speedup, the normal # preprocessor gets run if there's any problems. # # We used to use -Wa,-mppc with gcc, but can't remember exactly why. # Presumably it was for old versions of gcc where -mpowerpc doesn't put # the assembler in the right mode. In any case -Wa,-mppc is not good, for # instance -mcpu=604 makes recent gcc use -m604 to get access to the # "fsel" instruction, but a -Wa,-mppc overrides that, making code that # comes out with fsel fail. # # (Note also that the darwin assembler doesn't accept "-mppc", so any # -Wa,-mppc was used only if it worked. The right flag on darwin would be # "-arch ppc" or some such, but that's already the default.) # [powerpc*-*-* | power[3-9]-*-*]) AC_DEFINE(HAVE_HOST_CPU_FAMILY_powerpc) HAVE_HOST_CPU_FAMILY_powerpc=1 abilist="32" cclist="gcc cc" cc_cflags="-O2" gcc_32_cflags="$gcc_cflags -mpowerpc" gcc_cflags_optlist="precomp subtype asm cpu" gcc_cflags_precomp="-no-cpp-precomp" gcc_cflags_subtype="-force_cpusubtype_ALL" # for vmx on darwin gcc_cflags_asm="" gcc_cflags_cpu="" vmx_path="" # grab this object, though it's not a true cycle counter routine SPEED_CYCLECOUNTER_OBJ=powerpc.lo cyclecounter_size=0 case $host_cpu in powerpc740 | powerpc750) path="powerpc32/750 powerpc32" ;; powerpc7400 | powerpc7410) path="powerpc32/vmx powerpc32/750 powerpc32" ;; [powerpc74[45]?]) path="powerpc32/vmx powerpc32" ;; *) path="powerpc32" ;; esac case $host_cpu in powerpc401) gcc_cflags_cpu="-mcpu=401" ;; powerpc403) gcc_cflags_cpu="-mcpu=403" xlc_cflags_arch="-qarch=403 -qarch=ppc" ;; powerpc405) gcc_cflags_cpu="-mcpu=405" ;; powerpc505) gcc_cflags_cpu="-mcpu=505" ;; powerpc601) gcc_cflags_cpu="-mcpu=601" xlc_cflags_arch="-qarch=601 -qarch=ppc" ;; powerpc602) gcc_cflags_cpu="-mcpu=602" xlc_cflags_arch="-qarch=602 -qarch=ppc" ;; powerpc603) gcc_cflags_cpu="-mcpu=603" xlc_cflags_arch="-qarch=603 -qarch=ppc" ;; powerpc603e) gcc_cflags_cpu="-mcpu=603e -mcpu=603" xlc_cflags_arch="-qarch=603 -qarch=ppc" ;; powerpc604) gcc_cflags_cpu="-mcpu=604" xlc_cflags_arch="-qarch=604 -qarch=ppc" ;; powerpc604e) gcc_cflags_cpu="-mcpu=604e -mcpu=604" xlc_cflags_arch="-qarch=604 -qarch=ppc" ;; powerpc620) gcc_cflags_cpu="-mcpu=620" ;; powerpc630) gcc_cflags_cpu="-mcpu=630" xlc_cflags_arch="-qarch=pwr3" cpu_path="p3 p3-p7" ;; powerpc740) gcc_cflags_cpu="-mcpu=740" ;; powerpc7400 | powerpc7410) gcc_cflags_asm="-Wa,-maltivec" gcc_cflags_cpu="-mcpu=7400 -mcpu=750" ;; [powerpc74[45]?]) gcc_cflags_asm="-Wa,-maltivec" gcc_cflags_cpu="-mcpu=7450" ;; powerpc750) gcc_cflags_cpu="-mcpu=750" ;; powerpc801) gcc_cflags_cpu="-mcpu=801" ;; powerpc821) gcc_cflags_cpu="-mcpu=821" ;; powerpc823) gcc_cflags_cpu="-mcpu=823" ;; powerpc860) gcc_cflags_cpu="-mcpu=860" ;; powerpc970) gcc_cflags_cpu="-mtune=970" xlc_cflags_arch="-qarch=970 -qarch=pwr3" vmx_path="powerpc64/vmx" cpu_path="p4 p3-p7" ;; power4) gcc_cflags_cpu="-mtune=power4" xlc_cflags_arch="-qarch=pwr4" cpu_path="p4 p3-p7" ;; power5) gcc_cflags_cpu="-mtune=power5 -mtune=power4" xlc_cflags_arch="-qarch=pwr5" cpu_path="p5 p4 p3-p7" ;; power6) gcc_cflags_cpu="-mtune=power6" xlc_cflags_arch="-qarch=pwr6" cpu_path="p6 p3-p7" ;; power7) gcc_cflags_cpu="-mtune=power7 -mtune=power5" xlc_cflags_arch="-qarch=pwr7 -qarch=pwr5" cpu_path="p7 p5 p4 p3-p7" ;; esac case $host in *-*-aix*) cclist="gcc xlc cc" gcc_32_cflags_maybe="-maix32" xlc_cflags="-O2 -qmaxmem=20000" xlc_cflags_optlist="arch" xlc_32_cflags_maybe="-q32" ar_32_flags="-X32" nm_32_flags="-X32" esac case $host in POWERPC64_PATTERN) case $host in *-*-aix*) # On AIX a true 64-bit ABI is available. # Need -Wc to pass object type flags through to the linker. abilist="mode64 $abilist" cclist_mode64="gcc xlc" gcc_mode64_cflags="$gcc_cflags -maix64 -mpowerpc64" gcc_mode64_cflags_optlist="cpu" gcc_mode64_ldflags="-Wc,-maix64" xlc_mode64_cflags="-O2 -q64 -qmaxmem=20000" xlc_mode64_cflags_optlist="arch" xlc_mode64_ldflags="-Wc,-q64" # Must indicate object type to ar and nm ar_mode64_flags="-X64" nm_mode64_flags="-X64" path_mode64="" p="" for i in $cpu_path do path_mode64="${path_mode64}powerpc64/mode64/$i " path_mode64="${path_mode64}powerpc64/$i " p="${p} powerpc32/$i " done path_mode64="${path_mode64}powerpc64/mode64 $vmx_path powerpc64" path="$p $path" # grab this object, though it's not a true cycle counter routine SPEED_CYCLECOUNTER_OBJ_mode64=powerpc64.lo cyclecounter_size_mode64=0 ;; *-*-darwin*) # On Darwin we can use 64-bit instructions with a longlong limb, # but the chip still in 32-bit mode. # In theory this can be used on any OS which knows how to save # 64-bit registers in a context switch. # # Note that we must use -mpowerpc64 with gcc, since the # longlong.h macros expect limb operands in a single 64-bit # register, not two 32-bit registers as would be given for a # long long without -mpowerpc64. In theory we could detect and # accommodate both styles, but the proper 64-bit registers will # be fastest and are what we really want to use. # # One would think -mpowerpc64 would set the assembler in the right # mode to handle 64-bit instructions. But for that, also # -force_cpusubtype_ALL is needed. # # Do not use -fast for Darwin, it actually adds options # incompatible with a shared library. # abilist="mode64 mode32 $abilist" gcc_32_cflags_maybe="-m32" gcc_cflags_opt="-O3 -O2 -O1" # will this become used? cclist_mode32="gcc" gcc_mode32_cflags_maybe="-m32" gcc_mode32_cflags="-mpowerpc64" gcc_mode32_cflags_optlist="subtype cpu opt" gcc_mode32_cflags_subtype="-force_cpusubtype_ALL" gcc_mode32_cflags_opt="-O3 -O2 -O1" limb_mode32=longlong cclist_mode64="gcc" gcc_mode64_cflags="-m64" gcc_mode64_cflags_optlist="cpu opt" gcc_mode64_cflags_opt="-O3 -O2 -O1" path_mode64="" path_mode32="" p="" for i in $cpu_path do path_mode64="${path_mode64}powerpc64/mode64/$i " path_mode64="${path_mode64}powerpc64/$i " path_mode32="${path_mode32}powerpc64/mode32/$i " path_mode32="${path_mode32}powerpc64/$i " p="${p} powerpc32/$i " done path_mode64="${path_mode64}powerpc64/mode64 $vmx_path powerpc64" path_mode32="${path_mode32}powerpc64/mode32 $vmx_path powerpc64" path="$p $path" SPEED_CYCLECOUNTER_OBJ_mode64=powerpc64.lo cyclecounter_size_mode64=0 any_mode64_testlist="sizeof-long-8" ;; *-*-linux* | *-*-*bsd*) # On GNU/Linux, assume the processor is in 64-bit mode. Some # environments have a gcc that is always in 64-bit mode, while # others require -m64, hence the use of cflags_maybe. The # sizeof-long-8 test checks the mode is right (for the no option # case). # # -mpowerpc64 is not used, since it should be the default in # 64-bit mode. (We need its effect for the various longlong.h # asm macros to be right of course.) # # gcc64 was an early port of gcc to 64-bit mode, but should be # obsolete before too long. We prefer plain gcc when it knows # 64-bits. # abilist="mode64 mode32 $abilist" gcc_32_cflags_maybe="-m32" cclist_mode32="gcc" gcc_mode32_cflags_maybe="-m32" gcc_mode32_cflags="-mpowerpc64" gcc_mode32_cflags_optlist="cpu opt" gcc_mode32_cflags_opt="-O3 -O2 -O1" limb_mode32=longlong cclist_mode64="gcc gcc64" gcc_mode64_cflags_maybe="-m64" gcc_mode64_cflags_optlist="cpu opt" gcc_mode64_cflags_opt="-O3 -O2 -O1" path_mode64="" path_mode32="" p="" for i in $cpu_path do path_mode64="${path_mode64}powerpc64/mode64/$i " path_mode64="${path_mode64}powerpc64/$i " path_mode32="${path_mode32}powerpc64/mode32/$i " path_mode32="${path_mode32}powerpc64/$i " p="${p} powerpc32/$i " done path_mode64="${path_mode64}powerpc64/mode64 $vmx_path powerpc64" path_mode32="${path_mode32}powerpc64/mode32 $vmx_path powerpc64" path="$p $path" SPEED_CYCLECOUNTER_OBJ_mode64=powerpc64.lo cyclecounter_size_mode64=0 any_mode64_testlist="sizeof-long-8" ;; esac ;; esac ;; # POWER 32-bit [power-*-* | power[12]-*-* | power2sc-*-*]) AC_DEFINE(HAVE_HOST_CPU_FAMILY_power) HAVE_HOST_CPU_FAMILY_power=1 cclist="gcc" extra_functions="udiv_w_sdiv" path="power" # gcc 2.7.2 knows rios1, rios2, rsc # # -mcpu=rios2 can tickle an AIX assembler bug (see GMP_PROG_CC_WORKS) so # there needs to be a fallback to just -mpower. # gcc_cflags_optlist="cpu" case $host in power-*-*) gcc_cflags_cpu="-mcpu=power -mpower" ;; power1-*-*) gcc_cflags_cpu="-mcpu=rios1 -mpower" ;; power2-*-*) gcc_cflags_cpu="-mcpu=rios2 -mpower" ;; power2sc-*-*) gcc_cflags_cpu="-mcpu=rsc -mpower" ;; esac case $host in *-*-aix*) cclist="gcc xlc" xlc_cflags="-O2 -qarch=pwr -qmaxmem=20000" ;; esac ;; # IBM System/390 and z/Architecture S390_PATTERN | S390X_PATTERN) abilist="32" gcc_cflags="$gcc_cflags $fomit_frame_pointer" gcc_cflags_optlist="arch" path="s390_32" extra_functions="udiv_w_sdiv" gcc_32_cflags_maybe="-m31" case $host_cpu in s390) ;; z900 | z900esa) cpu="z900" gccarch="$cpu" path="s390_32/esame/$cpu s390_32/esame s390_32" gcc_cflags_arch="-march=$gccarch" AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_s390_$cpu) AC_DEFINE(HAVE_HOST_CPU_s390_zarch) extra_functions="" ;; z990 | z990esa) cpu="z990" gccarch="$cpu" path="s390_32/esame/$cpu s390_32/esame s390_32" gcc_cflags_arch="-march=$gccarch" AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_s390_$cpu) AC_DEFINE(HAVE_HOST_CPU_s390_zarch) extra_functions="" ;; z9 | z9esa) cpu="z9" gccarch="z9-109" path="s390_32/esame/$cpu s390_32/esame s390_32" gcc_cflags_arch="-march=$gccarch" AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_s390_$cpu) AC_DEFINE(HAVE_HOST_CPU_s390_zarch) extra_functions="" ;; z10 | z10esa) cpu="z10" gccarch="z10" path="s390_32/esame/$cpu s390_32/esame s390_32" gcc_cflags_arch="-march=$gccarch" AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_s390_$cpu) AC_DEFINE(HAVE_HOST_CPU_s390_zarch) extra_functions="" ;; z196 | z196esa) cpu="z196" gccarch="z196" path="s390_32/esame/$cpu s390_32/esame s390_32" gcc_cflags_arch="-march=$gccarch" AC_DEFINE_UNQUOTED(HAVE_HOST_CPU_s390_$cpu) AC_DEFINE(HAVE_HOST_CPU_s390_zarch) extra_functions="" ;; esac case $host in S390X_PATTERN) abilist="64 32" cclist_64="gcc" gcc_64_cflags_optlist="arch" gcc_64_cflags="$gcc_cflags -m64" path_64="s390_64/$host_cpu s390_64" extra_functions="" ;; esac ;; sh-*-*) path="sh" ;; [sh[2-4]-*-*]) path="sh/sh2 sh" ;; *sparc*-*-*) # sizeof(long)==4 or 8 is tested, to ensure we get the right ABI. We've # had various bug reports where users have set CFLAGS for their desired # mode, but not set our ABI. For some reason it's sparc where this # keeps coming up, presumably users there are accustomed to driving the # compiler mode that way. The effect of our testlist setting is to # reject ABI=64 in favour of ABI=32 if the user has forced the flags to # 32-bit mode. # abilist="32" cclist="gcc acc cc" any_testlist="sizeof-long-4" GMP_INCLUDE_MPN(sparc32/sparc-defs.m4) case $host_cpu in sparcv8 | microsparc | turbosparc) path="sparc32/v8 sparc32" ;; supersparc) path="sparc32/v8/supersparc sparc32/v8 sparc32" ;; [sparc64 | sparcv9* | ultrasparc | ultrasparc[234]*]) path="sparc32/v9 sparc32/v8 sparc32" ;; [ultrasparct[12345]]) path="sparc32/ultrasparct1 sparc32/v8 sparc32" ;; *) path="sparc32" ;; esac # gcc 2.7.2 doesn't know about v9 and doesn't pass -xarch=v8plus to the # assembler. Add it explicitly since the solaris assembler won't accept # our sparc32/v9 asm code without it. gas accepts -xarch=v8plus too, so # it can be in the cflags unconditionally (though gas doesn't need it). # # gcc -m32 is needed to force 32-bit mode on a dual-ABI system, but past # gcc doesn't know that flag, hence cflags_maybe. Note that -m32 cannot # be done through the optlist since the plain cflags would be run first # and we don't want to require the default mode (whatever it is) works. # # Note it's gcc_32_cflags_maybe and not gcc_cflags_maybe because the # latter would be used in the 64-bit ABI on systems like "*bsd" where # abilist="64" only. # gcc_32_cflags_maybe="-m32" gcc_cflags_optlist="cpu asm" # gcc 2.7.2 knows -mcypress, -msupersparc, -mv8, -msparclite. # gcc 2.95 knows -mcpu= v7, hypersparc, sparclite86x, f930, f934, # sparclet, tsc701, v9, ultrasparc. A warning is given that the # plain -m forms will disappear. # gcc 3.3 adds ultrasparc3. # case $host_cpu in supersparc*) gcc_cflags_cpu="-mcpu=supersparc -msupersparc" gcc_cflags_asm="-Wa,-Av8 -Wa,-xarch=v8";; sparcv8 | microsparc* | turbosparc | hypersparc*) gcc_cflags_cpu="-mcpu=v8 -mv8" gcc_cflags_asm="-Wa,-Av8 -Wa,-xarch=v8";; sparc64 | sparcv9*) gcc_cflags_cpu="-mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8 -Wa,-xarch=v8plus" gcc_64_cflags_asm="-Wa,-Av9 -Wa,-xarch=v9";; ultrasparc1 | ultrasparc2*) gcc_cflags_cpu="-mcpu=ultrasparc -mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8plusa -Wa,-xarch=v8plusa" gcc_64_cflags_asm="-Wa,-Av9a -Wa,-xarch=v9a";; [ultrasparc[34]]) gcc_cflags_cpu="-mcpu=ultrasparc3 -mcpu=ultrasparc -mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8plusb -Wa,-xarch=v8plusb" gcc_64_cflags_asm="-Wa,-Av9b -Wa,-xarch=v9b";; [ultrasparct[12]]) gcc_cflags_cpu="-mcpu=niagara -mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8plusc -Wa,-xarch=v8plusc" gcc_64_cflags_asm="-Wa,-Av9c -Wa,-xarch=v9c";; ultrasparct3) gcc_cflags_cpu="-mcpu=niagara3 -mcpu=niagara -mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8plusd -Wa,-xarch=v8plusd" gcc_64_cflags_asm="-Wa,-Av9d -Wa,-xarch=v9d";; ultrasparct4) gcc_cflags_cpu="-mcpu=niagara4 -mcpu=niagara3 -mcpu=niagara -mcpu=v9" gcc_32_cflags_asm="-Wa,-Av8plusd -Wa,-xarch=v8plusd" gcc_64_cflags_asm="-Wa,-Av9d -Wa,-xarch=v9d";; *) gcc_cflags_cpu="-mcpu=v7 -mcypress" gcc_cflags_asm="";; esac # SunPRO cc and acc, and SunOS bundled cc case $host in *-*-solaris* | *-*-sunos*) # Note no -g, it disables all optimizations. cc_cflags= cc_cflags_optlist="opt arch cpu" # SunOS cc doesn't know -xO4, fallback to -O2. cc_cflags_opt="-xO4 -O2" # SunOS cc doesn't know -xarch, apparently always generating v7 # code, so make this optional case $host_cpu in sparcv8 | microsparc* | supersparc* | turbosparc | hypersparc*) cc_cflags_arch="-xarch=v8";; [ultrasparct[345]]) cc_cflags_arch="-xarch=v8plusd" ;; sparc64 | sparcv9* | ultrasparc*) cc_cflags_arch="-xarch=v8plus" ;; *) cc_cflags_arch="-xarch=v7" ;; esac # SunOS cc doesn't know -xchip and doesn't seem to have an equivalent. # SunPRO cc 5 recognises -xchip=generic, old, super, super2, micro, # micro2, hyper, hyper2, powerup, ultra, ultra2, ultra2i. # SunPRO cc 6 adds -xchip=ultra2e, ultra3cu. # case $host_cpu in supersparc*) cc_cflags_cpu="-xchip=super" ;; microsparc*) cc_cflags_cpu="-xchip=micro" ;; turbosparc) cc_cflags_cpu="-xchip=micro2" ;; hypersparc*) cc_cflags_cpu="-xchip=hyper" ;; ultrasparc) cc_cflags_cpu="-xchip=ultra" ;; ultrasparc2) cc_cflags_cpu="-xchip=ultra2 -xchip=ultra" ;; ultrasparc2i) cc_cflags_cpu="-xchip=ultra2i -xchip=ultra2 -xchip=ultra" ;; ultrasparc3) cc_cflags_cpu="-xchip=ultra3 -xchip=ultra" ;; ultrasparc4) cc_cflags_cpu="-xchip=ultra4 -xchip=ultra3 -xchip=ultra" ;; ultrasparct1) cc_cflags_cpu="-xchip=ultraT1" ;; ultrasparct2) cc_cflags_cpu="-xchip=ultraT2 -xchip=ultraT1" ;; ultrasparct3) cc_cflags_cpu="-xchip=ultraT3 -xchip=ultraT2" ;; ultrasparct4) cc_cflags_cpu="-xchip=T4" ;; ultrasparct5) cc_cflags_cpu="-xchip=T5 -xchip=T4" ;; *) cc_cflags_cpu="-xchip=generic" ;; esac esac case $host_cpu in sparc64 | sparcv9* | ultrasparc*) case $host in # Solaris 6 and earlier cannot run ABI=64 since it doesn't save # registers properly, so ABI=32 is left as the only choice. # [*-*-solaris2.[0-6] | *-*-solaris2.[0-6].*]) ;; # BSD sparc64 ports are 64-bit-only systems, so ABI=64 is the only # choice. In fact they need no special compiler flags, gcc -m64 # is the default, but it doesn't hurt to add it. v9 CPUs always # use the sparc64 port, since the plain 32-bit sparc ports don't # run on a v9. # *-*-*bsd*) abilist="64" ;; # For all other systems, we try both 64 and 32. # # GNU/Linux sparc64 has only recently gained a 64-bit user mode. # In the past sparc64 meant a v9 cpu, but there were no 64-bit # operations in user mode. We assume that if "gcc -m64" works # then the system is suitable. Hopefully even if someone attempts # to put a new gcc and/or glibc on an old system it won't run. # *) abilist="64 32" ;; esac case $host_cpu in ultrasparc | ultrasparc2 | ultrasparc2i) path_64="sparc64/ultrasparc1234 sparc64" ;; [ultrasparc[34]]) path_64="sparc64/ultrasparc34 sparc64/ultrasparc1234 sparc64" ;; [ultrasparct[12]]) path_64="sparc64/ultrasparct1 sparc64" ;; [ultrasparct[345]]) path_64="sparc64/ultrasparct3 sparc64" ;; *) path_64="sparc64" esac cclist_64="gcc" any_64_testlist="sizeof-long-8" # gcc -mptr64 is probably implied by -m64, but we're not sure if # this was always so. On Solaris in the past we always used both # "-m64 -mptr64". # # gcc -Wa,-xarch=v9 is thought to be necessary in some cases on # solaris, but it would seem likely that if gcc is going to generate # 64-bit code it will have to add that option itself where needed. # An extra copy of this option should be harmless though, but leave # it until we're sure. (Might want -xarch=v9a or -xarch=v9b for the # higher cpu types instead.) # gcc_64_cflags="$gcc_cflags -m64 -mptr64" gcc_64_ldflags="-Wc,-m64" gcc_64_cflags_optlist="cpu asm" case $host in *-*-solaris*) # Sun cc. # # We used to have -fast and some fixup options here, but it # recurrently caused problems with miscompilation. Of course, # -fast is documented as miscompiling things for the sake of speed. # cclist_64="$cclist_64 cc" cc_64_cflags_optlist="cpu" case $host_cpu in [ultrasparct[345]]) cc_64_cflags="$cc_64_cflags -xO3 -xarch=v9d" ;; *) cc_64_cflags="-xO3 -xarch=v9" ;; esac ;; esac # using the v9 %tick register SPEED_CYCLECOUNTER_OBJ_32=sparcv9.lo SPEED_CYCLECOUNTER_OBJ_64=sparcv9.lo cyclecounter_size_32=2 cyclecounter_size_64=2 ;; esac ;; # VAX vax*-*-*elf*) # Use elf conventions (i.e., '%' register prefix, no global prefix) # GMP_INCLUDE_MPN(vax/elf.m4) gcc_cflags="$gcc_cflags $fomit_frame_pointer" path="vax" extra_functions="udiv_w_sdiv" ;; vax*-*-*) # Default to aout conventions (i.e., no register prefix, '_' global prefix) # gcc_cflags="$gcc_cflags $fomit_frame_pointer" path="vax" extra_functions="udiv_w_sdiv" ;; # AMD and Intel x86 configurations, including AMD64 # # Rumour has it gcc -O2 used to give worse register allocation than just # -O, but lets assume that's no longer true. # # -m32 forces 32-bit mode on a bi-arch 32/64 amd64 build of gcc. -m64 is # the default in such a build (we think), so -m32 is essential for ABI=32. # This is, of course, done for any $host_cpu, not just x86_64, so we can # get such a gcc into the right mode to cross-compile to say i486-*-*. # # -m32 is not available in gcc 2.95 and earlier, hence cflags_maybe to use # it when it works. We check sizeof(long)==4 to ensure we get the right # mode, in case -m32 has failed not because it's an old gcc, but because # it's a dual 32/64-bit gcc without a 32-bit libc, or whatever. # X86_PATTERN | X86_64_PATTERN) abilist="32" cclist="gcc icc cc" gcc_cflags="$gcc_cflags $fomit_frame_pointer" gcc_32_cflags_maybe="-m32" icc_cflags="-no-gcc" icc_cflags_optlist="opt" icc_cflags_opt="-O3 -O2 -O1" any_32_testlist="sizeof-long-4" CALLING_CONVENTIONS_OBJS='x86call.lo x86check$U.lo' # Availability of rdtsc is checked at run-time. SPEED_CYCLECOUNTER_OBJ=pentium.lo # gcc 2.7.2 only knows i386 and i486, using -m386 or -m486. These # represent -mcpu= since -m486 doesn't generate 486 specific insns. # gcc 2.95 adds k6, pentium and pentiumpro, and takes -march= and -mcpu=. # gcc 3.0 adds athlon. # gcc 3.1 adds k6-2, k6-3, pentium-mmx, pentium2, pentium3, pentium4, # athlon-tbird, athlon-4, athlon-xp, athlon-mp. # gcc 3.2 adds winchip2. # gcc 3.3 adds winchip-c6. # gcc 3.3.1 from mandrake adds k8 and knows -mtune. # gcc 3.4 adds c3, c3-2, k8, and deprecates -mcpu in favour of -mtune. # # In gcc 2.95.[0123], -march=pentiumpro provoked a stack slot bug in an # old version of mpz/powm.c. Seems to be fine with the current code, so # no need for any restrictions on that option. # # -march=pentiumpro can fail if the assembler doesn't know "cmov" # (eg. solaris 2.8 native "as"), so always have -march=pentium after # that as a fallback. # # -march=pentium4 and -march=k8 enable SSE2 instructions, which may or # may not be supported by the assembler and/or the OS, and is bad in gcc # prior to 3.3. The tests will reject these if no good, so fallbacks # like "-march=pentium4 -mno-sse2" are given to try also without SSE2. # Note the relevant -march types are listed in the optflags handling # below, be sure to update there if adding new types emitting SSE2. # # -mtune is used at the start of each cpu option list to give something # gcc 3.4 will use, thereby avoiding warnings from -mcpu. -mcpu forms # are retained for use by prior gcc. For example pentium has # "-mtune=pentium -mcpu=pentium ...", the -mtune is for 3.4 and the # -mcpu for prior. If there's a brand new choice in 3.4 for a chip, # like k8 for x86_64, then it can be the -mtune at the start, no need to # duplicate anything. # gcc_cflags_optlist="cpu arch" case $host_cpu in i386*) gcc_cflags_cpu="-mtune=i386 -mcpu=i386 -m386" gcc_cflags_arch="-march=i386" path="x86" ;; i486*) gcc_cflags_cpu="-mtune=i486 -mcpu=i486 -m486" gcc_cflags_arch="-march=i486" path="x86/i486 x86" ;; i586 | pentium) gcc_cflags_cpu="-mtune=pentium -mcpu=pentium -m486" gcc_cflags_arch="-march=pentium" path="x86/pentium x86" ;; pentiummmx) gcc_cflags_cpu="-mtune=pentium-mmx -mcpu=pentium-mmx -mcpu=pentium -m486" gcc_cflags_arch="-march=pentium-mmx -march=pentium" path="x86/pentium/mmx x86/pentium x86/mmx x86" ;; i686 | pentiumpro) gcc_cflags_cpu="-mtune=pentiumpro -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=pentiumpro -march=pentium" path="x86/p6 x86" ;; pentium2) gcc_cflags_cpu="-mtune=pentium2 -mcpu=pentium2 -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=pentium2 -march=pentiumpro -march=pentium" path="x86/p6/mmx x86/p6 x86/mmx x86" ;; pentium3) gcc_cflags_cpu="-mtune=pentium3 -mcpu=pentium3 -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=pentium3 -march=pentiumpro -march=pentium" path="x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" ;; pentiumm) gcc_cflags_cpu="-mtune=pentium3 -mcpu=pentium3 -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=pentium3 -march=pentiumpro -march=pentium" path="x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" ;; k6) gcc_cflags_cpu="-mtune=k6 -mcpu=k6 -mcpu=i486 -m486" gcc_cflags_arch="-march=k6" path="x86/k6/mmx x86/k6 x86/mmx x86" ;; k62) gcc_cflags_cpu="-mtune=k6-2 -mcpu=k6-2 -mcpu=k6 -mcpu=i486 -m486" gcc_cflags_arch="-march=k6-2 -march=k6" path="x86/k6/k62mmx x86/k6/mmx x86/k6 x86/mmx x86" ;; k63) gcc_cflags_cpu="-mtune=k6-3 -mcpu=k6-3 -mcpu=k6 -mcpu=i486 -m486" gcc_cflags_arch="-march=k6-3 -march=k6" path="x86/k6/k62mmx x86/k6/mmx x86/k6 x86/mmx x86" ;; geode) gcc_cflags_cpu="-mtune=k6-3 -mcpu=k6-3 -mcpu=k6 -mcpu=i486 -m486" gcc_cflags_arch="-march=k6-3 -march=k6" path="x86/geode x86/k6/k62mmx x86/k6/mmx x86/k6 x86/mmx x86" ;; athlon) # Athlon instruction costs are close to P6 (3 cycle load latency, # 4-6 cycle mul, 40 cycle div, pairable adc, etc) so if gcc doesn't # know athlon (eg. 2.95.2 doesn't) then fall back on pentiumpro. gcc_cflags_cpu="-mtune=athlon -mcpu=athlon -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=athlon -march=pentiumpro -march=pentium" path="x86/k7/mmx x86/k7 x86/mmx x86" ;; i786 | pentium4) # pentiumpro is the primary fallback when gcc doesn't know pentium4. # This gets us cmov to eliminate branches. Maybe "athlon" would be # a possibility on gcc 3.0. # gcc_cflags_cpu="-mtune=pentium4 -mcpu=pentium4 -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=pentium4 -march=pentium4~-mno-sse2 -march=pentiumpro -march=pentium" gcc_64_cflags_cpu="-mtune=nocona" path="x86/pentium4/sse2 x86/pentium4/mmx x86/pentium4 x86/mmx x86" path_64="x86_64/pentium4 x86_64" ;; viac32) # Not sure of the best fallbacks here for -mcpu. # c3-2 has sse and mmx, so pentium3 is good for -march. gcc_cflags_cpu="-mtune=c3-2 -mcpu=c3-2 -mcpu=i486 -m486" gcc_cflags_arch="-march=c3-2 -march=pentium3 -march=pentiumpro -march=pentium" path="x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" ;; viac3*) # Not sure of the best fallbacks here. gcc_cflags_cpu="-mtune=c3 -mcpu=c3 -mcpu=i486 -m486" gcc_cflags_arch="-march=c3 -march=pentium-mmx -march=pentium" path="x86/pentium/mmx x86/pentium x86/mmx x86" ;; athlon64 | k8 | x86_64) gcc_cflags_cpu="-mtune=k8 -mcpu=athlon -mcpu=pentiumpro -mcpu=i486 -m486" gcc_cflags_arch="-march=k8 -march=k8~-mno-sse2 -march=athlon -march=pentiumpro -march=pentium" path="x86/k8 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/k8 x86_64" ;; k10) gcc_cflags_cpu="-mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/k10 x86/k8 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/k10 x86_64/k8 x86_64" ;; bobcat) gcc_cflags_cpu="-mtune=btver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=btver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/bobcat x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/bobcat x86_64/k10 x86_64/k8 x86_64" ;; jaguar) gcc_cflags_cpu="-mtune=btver2 -mtune=btver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=btver2 -march=btver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/jaguar x86/bobcat x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/jaguar x86_64/bobcat x86_64/k10 x86_64/k8 x86_64" ;; bulldozer | bd1) gcc_cflags_cpu="-mtune=bdver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=bdver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/bd1 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/bd1 x86_64/k10 x86_64/k8 x86_64" ;; piledriver | bd2) gcc_cflags_cpu="-mtune=bdver2 -mtune=bdver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=bdver2 -march=bdver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/bd2 x86/bd1 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/bd2 x86_64/bd1 x86_64/k10 x86_64/k8 x86_64" ;; steamroller | bd3) gcc_cflags_cpu="-mtune=bdver3 -mtune=bdver2 -mtune=bdver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=bdver3 -march=bdver2 -march=bdver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/bd3 x86/bd2 x86/bd1 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/bd3 x86_64/bd2 x86_64/bd1 x86_64/k10 x86_64/k8 x86_64" ;; excavator | bd4) gcc_cflags_cpu="-mtune=bdver4 -mtune=bdver3 -mtune=bdver2 -mtune=bdver1 -mtune=amdfam10 -mtune=k8" gcc_cflags_arch="-march=bdver4 -march=bdver3 -march=bdver2 -march=bdver1 -march=amdfam10 -march=k8 -march=k8~-mno-sse2" path="x86/bd4 x86/bd3 x86/bd2 x86/bd1 x86/k7/mmx x86/k7 x86/mmx x86" path_64="x86_64/bd4 x86_64/bd3 x86_64/bd2 x86_64/bd1 x86_64/k10 x86_64/k8 x86_64" ;; core2) gcc_cflags_cpu="-mtune=core2 -mtune=k8" gcc_cflags_arch="-march=core2 -march=core2~-mno-sse2 -march=k8 -march=k8~-mno-sse2" path="x86/core2 x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" path_64="x86_64/core2 x86_64" ;; corei | coreinhm | coreiwsm) gcc_cflags_cpu="-mtune=corei7 -mtune=core2 -mtune=k8" gcc_cflags_arch="-march=corei7 -march=core2 -march=core2~-mno-sse2 -march=k8 -march=k8~-mno-sse2" path="x86/coreinhm x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" path_64="x86_64/coreinhm x86_64/core2 x86_64" ;; coreisbr) gcc_cflags_cpu="-mtune=corei7 -mtune=core2 -mtune=k8" gcc_cflags_arch="-march=corei7 -march=core2 -march=core2~-mno-sse2 -march=k8 -march=k8~-mno-sse2" path="x86/coreisbr x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" path_64="x86_64/coreisbr x86_64/coreinhm x86_64/core2 x86_64" ;; coreihwl) gcc_cflags_cpu="-mtune=corei7 -mtune=core2 -mtune=k8" gcc_cflags_arch="-march=corei7 -march=core2 -march=core2~-mno-sse2 -march=k8 -march=k8~-mno-sse2" path="x86/coreisbr x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" path_64="x86_64/coreihwl x86_64/coreisbr x86_64/coreinhm x86_64/core2 x86_64" ;; coreibwl) gcc_cflags_cpu="-mtune=corei7 -mtune=core2 -mtune=k8" gcc_cflags_arch="-march=corei7 -march=core2 -march=core2~-mno-sse2 -march=k8 -march=k8~-mno-sse2" path="x86/coreisbr x86/p6/sse2 x86/p6/p3mmx x86/p6/mmx x86/p6 x86/mmx x86" path_64="x86_64/coreihwl x86_64/coreisbr x86_64/coreinhm x86_64/core2 x86_64" # extra_functions_64="missing" # enable for bmi2/adx simulation ;; atom) gcc_cflags_cpu="-mtune=atom -mtune=pentium3" gcc_cflags_arch="-march=atom -march=pentium3" path="x86/atom/sse2 x86/atom/mmx x86/atom x86/mmx x86" path_64="x86_64/atom x86_64" ;; nano) gcc_cflags_cpu="-mtune=nano" gcc_cflags_arch="-march=nano" path="x86/nano x86/mmx x86" path_64="x86_64/nano x86_64" ;; *) gcc_cflags_cpu="-mtune=i486 -mcpu=i486 -m486" gcc_cflags_arch="-march=i486" path="x86" path_64="x86_64" ;; esac case $host in X86_64_PATTERN) cclist_64="gcc cc" gcc_64_cflags="$gcc_cflags -m64" gcc_64_cflags_optlist="cpu arch" CALLING_CONVENTIONS_OBJS_64='amd64call.lo amd64check$U.lo' SPEED_CYCLECOUNTER_OBJ_64=x86_64.lo cyclecounter_size_64=2 cclist_x32="gcc cc" gcc_x32_cflags="$gcc_cflags -mx32" gcc_x32_cflags_optlist="$gcc_64_cflags_optlist" CALLING_CONVENTIONS_OBJS_x32="$CALLING_CONVENTIONS_OBJS_64" SPEED_CYCLECOUNTER_OBJ_x32="$SPEED_CYCLECOUNTER_OBJ_64" cyclecounter_size_x32="$cyclecounter_size_64" path_x32="$path_64" limb_x32=longlong any_x32_testlist="sizeof-long-4" abilist="64 x32 32" if test "$enable_assembly" = "yes" ; then extra_functions_64="$extra_functions_64 invert_limb_table" extra_functions_x32=$extra_functions_64 fi case $host in *-*-solaris*) # Sun cc. cc_64_cflags="-xO3 -m64" ;; *-*-mingw* | *-*-cygwin) limb_64=longlong CALLING_CONVENTIONS_OBJS_64="" AC_DEFINE(HOST_DOS64,1,[Define to 1 for Windos/64]) GMP_NONSTD_ABI_64=DOS64 ;; esac ;; esac ;; # Special CPU "none" used to select generic C, now this is obsolete. none-*-*) enable_assembly=no AC_MSG_WARN([the \"none\" host is obsolete, use --disable-assembly]) ;; esac # mingw can be built by the cygwin gcc if -mno-cygwin is added. For # convenience add this automatically if it works. Actual mingw gcc accepts # -mno-cygwin too, but of course is the default. mingw only runs on the # x86s, but allow any CPU here so as to catch "none" too. # case $host in *-*-mingw*) gcc_cflags_optlist="$gcc_cflags_optlist nocygwin" gcc_cflags_nocygwin="-mno-cygwin" ;; esac CFLAGS_or_unset=${CFLAGS-'(unset)'} CPPFLAGS_or_unset=${CPPFLAGS-'(unset)'} cat >&AC_FD_CC <&AC_FD_CC cxxflags_ac_prog_cxx=$CXXFLAGS cxxflags_list=ac_prog_cxx # If the user didn't specify $CXXFLAGS, then try $CFLAGS, with -g removed # if AC_PROG_CXX thinks that doesn't work. $CFLAGS stands a good chance # of working, eg. on a GNU system where CC=gcc and CXX=g++. # if test "$test_CXXFLAGS" != set; then cxxflags_cflags=$CFLAGS cxxflags_list="cflags $cxxflags_list" if test "$ac_prog_cxx_g" = no; then cxxflags_cflags=`echo "$cxxflags_cflags" | sed -e 's/ -g //' -e 's/^-g //' -e 's/ -g$//'` fi fi # See if the C++ compiler works. If the user specified CXXFLAGS then all # we're doing is checking whether AC_PROG_CXX succeeded, since it doesn't # give a fatal error, just leaves CXX set to a default g++. If on the # other hand the user didn't specify CXXFLAGS then we get to try here our # $cxxflags_list alternatives. # # Automake includes $CPPFLAGS in a C++ compile, so we do the same here. # for cxxflags_choice in $cxxflags_list; do eval CXXFLAGS=\"\$cxxflags_$cxxflags_choice\" GMP_PROG_CXX_WORKS($CXX $CPPFLAGS $CXXFLAGS, [want_cxx=yes break]) done # If --enable-cxx=yes but a C++ compiler can't be found, then abort. if test $want_cxx = no && test $enable_cxx = yes; then AC_MSG_ERROR([C++ compiler not available, see config.log for details]) fi fi AM_CONDITIONAL(WANT_CXX, test $want_cxx = yes) # FIXME: We're not interested in CXXCPP for ourselves, but if we don't do it # here then AC_PROG_LIBTOOL will AC_REQUIRE it (via _LT_AC_TAGCONFIG) and # hence execute it unconditionally, and that will fail if there's no C++ # compiler (and no generic /lib/cpp). # if test $want_cxx = yes; then AC_PROG_CXXCPP fi # Path setups for Cray, according to IEEE or CFP. These must come after # deciding the compiler. # GMP_CRAY_OPTIONS( [add_path="cray/ieee"], [add_path="cray/cfp"; extra_functions="mulwwc90"], [add_path="cray/cfp"; extra_functions="mulwwj90"]) if test -z "$MPN_PATH"; then path="$add_path $path" fi # For a nail build, also look in "nails" subdirectories. # if test $GMP_NAIL_BITS != 0 && test -z "$MPN_PATH"; then new_path= for i in $path; do case $i in generic) new_path="$new_path $i" ;; *) new_path="$new_path $i/nails $i" ;; esac done path=$new_path fi # Put all directories into CPUVEC_list so as to get a full set of # CPUVEC_SETUP_$tmp_suffix defines into config.h, even if some of them are # empty because mmx and/or sse2 had to be dropped. # for i in $fat_path; do GMP_FAT_SUFFIX(tmp_suffix, $i) CPUVEC_list="$CPUVEC_list CPUVEC_SETUP_$tmp_suffix" done # If there's any sse2 or mmx in the path, check whether the assembler # supports it, and remove if not. # # We only need this in ABI=32, for ABI=64 on x86_64 we can assume a new # enough assembler. # case $host in X86_PATTERN | X86_64_PATTERN) if test "$ABI" = 32; then case "$path $fat_path" in *mmx*) GMP_ASM_X86_MMX( , [GMP_STRIP_PATH(*mmx*)]) ;; esac case "$path $fat_path" in *sse2*) GMP_ASM_X86_SSE2( , [GMP_STRIP_PATH(sse2)]) ;; esac fi case "$path $fat_path" in *mulx*) GMP_ASM_X86_MULX( , [GMP_STRIP_PATH(mulx)]) ;; esac case "$path $fat_path" in *adx*) GMP_ASM_X86_ADX( , [GMP_STRIP_PATH(adx)]) ;; esac ;; esac if test "$enable_assembly" = "no"; then path="generic" CFLAGS="$CFLAGS -DNO_ASM" # for abi in $abilist; do # eval unset "path_\$abi" # eval gcc_${abi}_cflags=\"\$gcc_${abi}_cflags -DNO_ASM\" # done fi cat >&AC_FD_CC < # include #else # if HAVE_SYS_TIME_H # include # else # include # endif #endif]) # On NetBSD and OpenBSD, sys/sysctl.h needs sys/param.h for various constants AC_CHECK_HEADERS(sys/sysctl.h,,, [#if HAVE_SYS_PARAM_H # include #endif]) # On OSF 4.0, must have for ulong_t AC_CHECK_HEADERS(machine/hal_sysinfo.h,,, [#if HAVE_SYS_SYSINFO_H # include #endif]) # Reasons for testing: # optarg - not declared in mingw # fgetc, fscanf, ungetc, vfprintf - not declared in SunOS 4 # sys_errlist, sys_nerr - not declared in SunOS 4 # # optarg should be in unistd.h and the rest in stdio.h, both of which are # in the autoconf default includes. # # sys_errlist and sys_nerr are supposed to be in on SunOS according # to the man page (but aren't), in glibc they're in stdio.h. # AC_CHECK_DECLS([fgetc, fscanf, optarg, ungetc, vfprintf]) AC_CHECK_DECLS([sys_errlist, sys_nerr], , , [#include #include ]) AC_TYPE_SIGNAL # Reasons for testing: # intmax_t - C99 # long double - not in the HP bundled K&R cc # long long - only in reasonably recent compilers # ptrdiff_t - seems to be everywhere, maybe don't need to check this # quad_t - BSD specific # uint_least32_t - C99 # # the default includes are sufficient for all these types # AC_CHECK_TYPES([intmax_t, long double, long long, ptrdiff_t, quad_t, uint_least32_t, intptr_t]) AC_C_STRINGIZE # FIXME: Really want #ifndef __cplusplus around the #define volatile # replacement autoconf gives, since volatile is always available in C++. # But we don't use it in C++ currently. AC_C_VOLATILE AC_C_RESTRICT # GMP_C_STDARG GMP_C_ATTRIBUTE_CONST GMP_C_ATTRIBUTE_MALLOC GMP_C_ATTRIBUTE_MODE GMP_C_ATTRIBUTE_NORETURN GMP_H_EXTERN_INLINE # from libtool AC_CHECK_LIBM AC_SUBST(LIBM) GMP_FUNC_ALLOCA GMP_OPTION_ALLOCA GMP_H_HAVE_FILE AC_C_BIGENDIAN( [AC_DEFINE(HAVE_LIMB_BIG_ENDIAN, 1) GMP_DEFINE_RAW("define_not_for_expansion(\`HAVE_LIMB_BIG_ENDIAN')", POST)], [AC_DEFINE(HAVE_LIMB_LITTLE_ENDIAN, 1) GMP_DEFINE_RAW("define_not_for_expansion(\`HAVE_LIMB_LITTLE_ENDIAN')", POST) ], [:]) AH_VERBATIM([HAVE_LIMB], [/* Define one of these to 1 for the endianness of `mp_limb_t'. If the endianness is not a simple big or little, or you don't know what it is, then leave both undefined. */ #undef HAVE_LIMB_BIG_ENDIAN #undef HAVE_LIMB_LITTLE_ENDIAN]) GMP_C_DOUBLE_FORMAT # Reasons for testing: # alarm - not in mingw # attr_get - IRIX specific # clock_gettime - not in glibc 2.2.4, only very recent systems # cputime - not in glibc # getsysinfo - OSF specific # getrusage - not in mingw # gettimeofday - not in mingw # mmap - not in mingw, djgpp # nl_langinfo - X/Open standard only, not in djgpp for instance # obstack_vprintf - glibc specific # processor_info - solaris specific # pstat_getprocessor - HPUX specific (10.x and up) # raise - an ANSI-ism, though probably almost universal by now # read_real_time - AIX specific # sigaction - not in mingw # sigaltstack - not in mingw, or old AIX (reputedly) # sigstack - not in mingw # strerror - not in SunOS # strnlen - glibc extension (some other systems too) # syssgi - IRIX specific # times - not in mingw # # AC_FUNC_STRNLEN is not used because we don't want the AC_LIBOBJ # replacement setups it gives. It detects a faulty strnlen on AIX, but # missing out on that test is ok since our only use of strnlen is in # __gmp_replacement_vsnprintf which is not required on AIX since it has a # vsnprintf. # AC_CHECK_FUNCS(alarm attr_get clock cputime getpagesize getrusage gettimeofday getsysinfo localeconv memset mmap mprotect nl_langinfo obstack_vprintf popen processor_info pstat_getprocessor raise read_real_time sigaction sigaltstack sigstack syssgi strchr strerror strnlen strtol strtoul sysconf sysctl sysctlbyname times) # clock_gettime is in librt on *-*-osf5.1 and on glibc, so att -lrt to # TUNE_LIBS if needed. On linux (tested on x86_32, 2.6.26), # clock_getres reports ns accuracy, while in a quick test on osf # clock_getres said only 1 millisecond. old_LIBS="$LIBS" AC_SEARCH_LIBS(clock_gettime, rt, [ AC_DEFINE([HAVE_CLOCK_GETTIME],1,[Define to 1 if you have the `clock_gettime' function])]) TUNE_LIBS="$LIBS" LIBS="$old_LIBS" AC_SUBST(TUNE_LIBS) GMP_FUNC_VSNPRINTF GMP_FUNC_SSCANF_WRITABLE_INPUT # Reasons for checking: # pst_processor psp_iticksperclktick - not in hpux 9 # AC_CHECK_MEMBER(struct pst_processor.psp_iticksperclktick, [AC_DEFINE(HAVE_PSP_ITICKSPERCLKTICK, 1, [Define to 1 if `struct pst_processor' exists and contains `psp_iticksperclktick'.])],, [#include ]) # C++ tests, when required # if test $enable_cxx = yes; then AC_LANG_PUSH(C++) # Reasons for testing: # - not in g++ 2.95.2 # std::locale - not in g++ 2.95.4 # AC_CHECK_HEADERS([sstream]) AC_CHECK_TYPES([std::locale],,,[#include ]) AC_LANG_POP(C++) fi # Pick the correct source files in $path and link them to mpn/. # $gmp_mpn_functions lists all functions we need. # # The rule is to find a file with the function name and a .asm, .S, # .s, or .c extension. Certain multi-function files with special names # can provide some functions too. (mpn/Makefile.am passes # -DOPERATION_ to get them to generate the right code.) # Note: $gmp_mpn_functions must have mod_1 before pre_mod_1 so the former # can optionally provide the latter as an extra entrypoint. Likewise # divrem_1 and pre_divrem_1. gmp_mpn_functions_optional="umul udiv \ invert_limb sqr_diagonal sqr_diag_addlsh1 \ mul_2 mul_3 mul_4 mul_5 mul_6 \ addmul_2 addmul_3 addmul_4 addmul_5 addmul_6 addmul_7 addmul_8 \ addlsh1_n sublsh1_n rsblsh1_n rsh1add_n rsh1sub_n \ addlsh2_n sublsh2_n rsblsh2_n \ addlsh_n sublsh_n rsblsh_n \ add_n_sub_n addaddmul_1msb0" gmp_mpn_functions="$extra_functions \ add add_1 add_n sub sub_1 sub_n cnd_add_n cnd_sub_n neg com \ mul_1 addmul_1 submul_1 \ add_err1_n add_err2_n add_err3_n sub_err1_n sub_err2_n sub_err3_n \ lshift rshift dive_1 diveby3 divis divrem divrem_1 divrem_2 \ fib2_ui mod_1 mod_34lsub1 mode1o pre_divrem_1 pre_mod_1 dump \ mod_1_1 mod_1_2 mod_1_3 mod_1_4 lshiftc \ mul mul_fft mul_n sqr mul_basecase sqr_basecase nussbaumer_mul \ mulmid_basecase toom42_mulmid mulmid_n mulmid \ random random2 pow_1 \ rootrem sqrtrem sizeinbase get_str set_str \ scan0 scan1 popcount hamdist cmp \ perfsqr perfpow \ gcd_1 gcd gcdext_1 gcdext gcd_subdiv_step \ gcdext_lehmer \ div_q tdiv_qr jacbase jacobi_2 jacobi get_d \ matrix22_mul matrix22_mul1_inverse_vector \ hgcd_matrix hgcd2 hgcd_step hgcd_reduce hgcd hgcd_appr \ hgcd2_jacobi hgcd_jacobi \ mullo_n mullo_basecase \ toom22_mul toom32_mul toom42_mul toom52_mul toom62_mul \ toom33_mul toom43_mul toom53_mul toom54_mul toom63_mul \ toom44_mul \ toom6h_mul toom6_sqr toom8h_mul toom8_sqr \ toom_couple_handling \ toom2_sqr toom3_sqr toom4_sqr \ toom_eval_dgr3_pm1 toom_eval_dgr3_pm2 \ toom_eval_pm1 toom_eval_pm2 toom_eval_pm2exp toom_eval_pm2rexp \ toom_interpolate_5pts toom_interpolate_6pts toom_interpolate_7pts \ toom_interpolate_8pts toom_interpolate_12pts toom_interpolate_16pts \ invertappr invert binvert mulmod_bnm1 sqrmod_bnm1 \ div_qr_1 div_qr_1n_pi1 \ div_qr_2 div_qr_2n_pi1 div_qr_2u_pi1 \ sbpi1_div_q sbpi1_div_qr sbpi1_divappr_q \ dcpi1_div_q dcpi1_div_qr dcpi1_divappr_q \ mu_div_qr mu_divappr_q mu_div_q \ bdiv_q_1 \ sbpi1_bdiv_q sbpi1_bdiv_qr \ dcpi1_bdiv_q dcpi1_bdiv_qr \ mu_bdiv_q mu_bdiv_qr \ bdiv_q bdiv_qr broot brootinv bsqrt bsqrtinv \ divexact bdiv_dbm1c redc_1 redc_2 redc_n powm powlo sec_powm \ sec_mul sec_sqr sec_div_qr sec_div_r sec_pi1_div_qr sec_pi1_div_r \ sec_add_1 sec_sub_1 sec_invert \ trialdiv remove \ and_n andn_n nand_n ior_n iorn_n nior_n xor_n xnor_n \ copyi copyd zero sec_tabselect \ comb_tables \ $gmp_mpn_functions_optional" define(GMP_MULFUNC_CHOICES, [# functions that can be provided by multi-function files tmp_mulfunc= case $tmp_fn in add_n|sub_n) tmp_mulfunc="aors_n" ;; add_err1_n|sub_err1_n) tmp_mulfunc="aors_err1_n" ;; add_err2_n|sub_err2_n) tmp_mulfunc="aors_err2_n" ;; add_err3_n|sub_err3_n) tmp_mulfunc="aors_err3_n" ;; cnd_add_n|cnd_sub_n) tmp_mulfunc="cnd_aors_n" ;; sec_add_1|sec_sub_1) tmp_mulfunc="sec_aors_1" ;; addmul_1|submul_1) tmp_mulfunc="aorsmul_1" ;; mul_2|addmul_2) tmp_mulfunc="aormul_2" ;; mul_3|addmul_3) tmp_mulfunc="aormul_3" ;; mul_4|addmul_4) tmp_mulfunc="aormul_4" ;; popcount|hamdist) tmp_mulfunc="popham" ;; and_n|andn_n|nand_n | ior_n|iorn_n|nior_n | xor_n|xnor_n) tmp_mulfunc="logops_n" ;; lshift|rshift) tmp_mulfunc="lorrshift";; addlsh1_n) tmp_mulfunc="aorslsh1_n aorrlsh1_n aorsorrlsh1_n";; sublsh1_n) tmp_mulfunc="aorslsh1_n sorrlsh1_n aorsorrlsh1_n";; rsblsh1_n) tmp_mulfunc="aorrlsh1_n sorrlsh1_n aorsorrlsh1_n";; addlsh2_n) tmp_mulfunc="aorslsh2_n aorrlsh2_n aorsorrlsh2_n";; sublsh2_n) tmp_mulfunc="aorslsh2_n sorrlsh2_n aorsorrlsh2_n";; rsblsh2_n) tmp_mulfunc="aorrlsh2_n sorrlsh2_n aorsorrlsh2_n";; addlsh_n) tmp_mulfunc="aorslsh_n aorrlsh_n aorsorrlsh_n";; sublsh_n) tmp_mulfunc="aorslsh_n sorrlsh_n aorsorrlsh_n";; rsblsh_n) tmp_mulfunc="aorrlsh_n sorrlsh_n aorsorrlsh_n";; rsh1add_n|rsh1sub_n) tmp_mulfunc="rsh1aors_n";; sec_div_qr|sec_div_r) tmp_mulfunc="sec_div";; sec_pi1_div_qr|sec_pi1_div_r) tmp_mulfunc="sec_pi1_div";; esac ]) # the list of all object files used by mpn/Makefile.in and the # top-level Makefile.in, respectively mpn_objects= mpn_objs_in_libgmp= # links from the sources, to be removed by "make distclean" gmp_srclinks= # mpn_relative_top_srcdir is $top_srcdir, but for use from within the mpn # build directory. If $srcdir is relative then we use a relative path too, # so the two trees can be moved together. case $srcdir in [[\\/]* | ?:[\\/]*]) # absolute, as per autoconf mpn_relative_top_srcdir=$srcdir ;; *) # relative mpn_relative_top_srcdir=../$srcdir ;; esac define(MPN_SUFFIXES,[asm S s c]) dnl Usage: GMP_FILE_TO_FUNCTION_BASE(func,file) dnl dnl Set $func to the function base name for $file, eg. dive_1 gives dnl divexact_1. dnl define(GMP_FILE_TO_FUNCTION, [case $$2 in dive_1) $1=divexact_1 ;; diveby3) $1=divexact_by3c ;; pre_divrem_1) $1=preinv_divrem_1 ;; mode1o) $1=modexact_1c_odd ;; pre_mod_1) $1=preinv_mod_1 ;; mod_1_1) $1=mod_1_1p ;; mod_1_1_cps) $1=mod_1_1p_cps ;; mod_1_2) $1=mod_1s_2p ;; mod_1_2_cps) $1=mod_1s_2p_cps ;; mod_1_3) $1=mod_1s_3p ;; mod_1_3_cps) $1=mod_1s_3p_cps ;; mod_1_4) $1=mod_1s_4p ;; mod_1_4_cps) $1=mod_1s_4p_cps ;; *) $1=$$2 ;; esac ]) # Fat binary setups. # # We proceed through each $fat_path directory, and look for $fat_function # routines there. Those found are incorporated in the build by generating a # little mpn/.asm or mpn/.c file in the build directory, with # suitable function renaming, and adding that to $mpn_objects (the same as a # normal mpn file). # # fat.h is generated with macros to let internal calls to each $fat_function # go directly through __gmpn_cpuvec, plus macros and declarations helping to # setup that structure, on a per-directory basis ready for # mpn//fat/fat.c. # # fat.h includes thresholds listed in $fat_thresholds, extracted from # gmp-mparam.h in each directory. An overall maximum for each threshold is # established, for use in making fixed size arrays of temporary space. # (Eg. MUL_TOOM33_THRESHOLD_LIMIT used by mpn/generic/mul.c.) # # It'd be possible to do some of this manually, but when there's more than a # few functions and a few directories it becomes very tedious, and very # prone to having some routine accidentally omitted. On that basis it seems # best to automate as much as possible, even if the code to do so is a bit # ugly. # if test -n "$fat_path"; then # Usually the mpn build directory is created with mpn/Makefile # instantiation, but we want to write to it sooner. mkdir mpn 2>/dev/null echo "/* fat.h - setups for fat binaries." >fat.h echo " Generated by configure - DO NOT EDIT. */" >>fat.h AC_DEFINE(WANT_FAT_BINARY, 1, [Define to 1 when building a fat binary.]) GMP_DEFINE(WANT_FAT_BINARY, yes) # Don't want normal copies of fat functions for tmp_fn in $fat_functions; do GMP_REMOVE_FROM_LIST(gmp_mpn_functions, $tmp_fn) GMP_REMOVE_FROM_LIST(gmp_mpn_functions_optional, $tmp_fn) done for tmp_fn in $fat_functions; do GMP_FILE_TO_FUNCTION(tmp_fbase,tmp_fn) echo " #ifndef OPERATION_$tmp_fn #undef mpn_$tmp_fbase #define mpn_$tmp_fbase (*__gmpn_cpuvec.$tmp_fbase) #endif DECL_$tmp_fbase (__MPN(${tmp_fbase}_init));" >>fat.h # encourage various macros to use fat functions AC_DEFINE_UNQUOTED(HAVE_NATIVE_mpn_$tmp_fbase) done echo "" >>fat.h echo "/* variable thresholds */" >>fat.h for tmp_tn in $fat_thresholds; do echo "#undef $tmp_tn" >>fat.h echo "#define $tmp_tn CPUVEC_THRESHOLD (`echo $tmp_tn | tr [A-Z] [a-z]`)" >>fat.h done echo " /* Copy all fields into __gmpn_cpuvec. memcpy is not used because it might operate byte-wise (depending on its implementation), and we need the function pointer writes to be atomic. "volatile" discourages the compiler from trying to optimize this. */ #define CPUVEC_INSTALL(vec) \\ do { \\ volatile struct cpuvec_t *p = &__gmpn_cpuvec; \\" >>fat.h for tmp_fn in $fat_functions; do GMP_FILE_TO_FUNCTION(tmp_fbase,tmp_fn) echo " p->$tmp_fbase = vec.$tmp_fbase; \\" >>fat.h done for tmp_tn in $fat_thresholds; do tmp_field_name=`echo $tmp_tn | tr [[A-Z]] [[a-z]]` echo " p->$tmp_field_name = vec.$tmp_field_name; \\" >>fat.h done echo " } while (0)" >>fat.h echo " /* A helper to check all fields are filled. */ #define ASSERT_CPUVEC(vec) \\ do { \\" >>fat.h for tmp_fn in $fat_functions; do GMP_FILE_TO_FUNCTION(tmp_fbase,tmp_fn) echo " ASSERT (vec.$tmp_fbase != NULL); \\" >>fat.h done for tmp_tn in $fat_thresholds; do tmp_field_name=`echo $tmp_tn | tr [[A-Z]] [[a-z]]` echo " ASSERT (vec.$tmp_field_name != 0); \\" >>fat.h done echo " } while (0)" >>fat.h echo " /* Call ITERATE(field) for each fat threshold field. */ #define ITERATE_FAT_THRESHOLDS() \\ do { \\" >>fat.h for tmp_tn in $fat_thresholds; do tmp_field_name=`echo $tmp_tn | tr [[A-Z]] [[a-z]]` echo " ITERATE ($tmp_tn, $tmp_field_name); \\" >>fat.h done echo " } while (0)" >>fat.h for tmp_dir in $fat_path; do CPUVEC_SETUP= THRESH_ASM_SETUP= echo "" >>fat.h GMP_FAT_SUFFIX(tmp_suffix, $tmp_dir) # In order to keep names unique on a DOS 8.3 filesystem, use a prefix # (rather than a suffix) for the generated file names, and abbreviate. case $tmp_suffix in pentium) tmp_prefix=p ;; pentium_mmx) tmp_prefix=pm ;; p6_mmx) tmp_prefix=p2 ;; p6_p3mmx) tmp_prefix=p3 ;; pentium4) tmp_prefix=p4 ;; pentium4_mmx) tmp_prefix=p4m ;; pentium4_sse2) tmp_prefix=p4s ;; k6_mmx) tmp_prefix=k6m ;; k6_k62mmx) tmp_prefix=k62 ;; k7_mmx) tmp_prefix=k7m ;; *) tmp_prefix=$tmp_suffix ;; esac # Extract desired thresholds from gmp-mparam.h file in this directory, # if present. tmp_mparam=$srcdir/mpn/$tmp_dir/gmp-mparam.h if test -f $tmp_mparam; then for tmp_tn in $fat_thresholds; do tmp_thresh=`sed -n "s/^#define $tmp_tn[ ]*\\([0-9][0-9]*\\).*$/\\1/p" $tmp_mparam` if test -n "$tmp_thresh"; then THRESH_ASM_SETUP=["${THRESH_ASM_SETUP}define($tmp_tn,$tmp_thresh) "] CPUVEC_SETUP="$CPUVEC_SETUP decided_cpuvec.`echo $tmp_tn | tr [[A-Z]] [[a-z]]` = $tmp_thresh; \\ " eval tmp_limit=\$${tmp_tn}_LIMIT if test -z "$tmp_limit"; then tmp_limit=0 fi if test $tmp_thresh -gt $tmp_limit; then eval ${tmp_tn}_LIMIT=$tmp_thresh fi fi done fi for tmp_fn in $fat_functions; do GMP_MULFUNC_CHOICES for tmp_base in $tmp_fn $tmp_mulfunc; do for tmp_ext in MPN_SUFFIXES; do tmp_file=$srcdir/mpn/$tmp_dir/$tmp_base.$tmp_ext if test -f $tmp_file; then # If the host uses a non-standard ABI, check if tmp_file supports it # if test -n "$GMP_NONSTD_ABI" && test $tmp_ext != "c"; then abi=[`sed -n 's/^[ ]*ABI_SUPPORT(\(.*\))/\1/p' $tmp_file `] if echo "$abi" | grep -q "\\b${GMP_NONSTD_ABI}\\b"; then true else continue fi fi mpn_objects="$mpn_objects ${tmp_prefix}_$tmp_fn.lo" mpn_objs_in_libgmp="$mpn_objs_in_libgmp mpn/${tmp_prefix}_$tmp_fn.lo" GMP_FILE_TO_FUNCTION(tmp_fbase,tmp_fn) # carry-in variant, eg. divrem_1c or modexact_1c_odd case $tmp_fbase in *_1*) tmp_fbasec=`echo $tmp_fbase | sed 's/_1/_1c/'` ;; *) tmp_fbasec=${tmp_fbase}c ;; esac # Create a little file doing an include from srcdir. The # OPERATION and renamings aren't all needed all the time, but # they don't hurt if unused. # # FIXME: Should generate these via config.status commands. # Would need them all in one AC_CONFIG_COMMANDS though, since # that macro doesn't accept a set of separate commands generated # by shell code. # case $tmp_ext in asm) # hide the d-n-l from autoconf's error checking tmp_d_n_l=d""nl echo ["$tmp_d_n_l mpn_$tmp_fbase - from $tmp_dir directory for fat binary. $tmp_d_n_l Generated by configure - DO NOT EDIT. define(OPERATION_$tmp_fn) define(__gmpn_$tmp_fbase, __gmpn_${tmp_fbase}_$tmp_suffix) define(__gmpn_$tmp_fbasec,__gmpn_${tmp_fbasec}_${tmp_suffix}) define(__gmpn_preinv_${tmp_fbase},__gmpn_preinv_${tmp_fbase}_${tmp_suffix}) define(__gmpn_${tmp_fbase}_cps,__gmpn_${tmp_fbase}_cps_${tmp_suffix}) $tmp_d_n_l For k6 and k7 gcd_1 calling their corresponding mpn_modexact_1_odd ifdef(\`__gmpn_modexact_1_odd',, \`define(__gmpn_modexact_1_odd,__gmpn_modexact_1_odd_${tmp_suffix})') $THRESH_ASM_SETUP include][($mpn_relative_top_srcdir/mpn/$tmp_dir/$tmp_base.asm) "] >mpn/${tmp_prefix}_$tmp_fn.asm ;; c) echo ["/* mpn_$tmp_fbase - from $tmp_dir directory for fat binary. Generated by configure - DO NOT EDIT. */ #define OPERATION_$tmp_fn 1 #define __gmpn_$tmp_fbase __gmpn_${tmp_fbase}_$tmp_suffix #define __gmpn_$tmp_fbasec __gmpn_${tmp_fbasec}_${tmp_suffix} #define __gmpn_preinv_${tmp_fbase} __gmpn_preinv_${tmp_fbase}_${tmp_suffix} #define __gmpn_${tmp_fbase}_cps __gmpn_${tmp_fbase}_cps_${tmp_suffix} #include \"$mpn_relative_top_srcdir/mpn/$tmp_dir/$tmp_base.c\" "] >mpn/${tmp_prefix}_$tmp_fn.c ;; esac # Prototype, and append to CPUVEC_SETUP for this directory. echo "DECL_$tmp_fbase (__gmpn_${tmp_fbase}_$tmp_suffix);" >>fat.h CPUVEC_SETUP="$CPUVEC_SETUP decided_cpuvec.$tmp_fbase = __gmpn_${tmp_fbase}_${tmp_suffix}; \\ " # Ditto for any preinv variant (preinv_divrem_1, preinv_mod_1). if grep "^PROLOGUE(mpn_preinv_$tmp_fn)" $tmp_file >/dev/null; then echo "DECL_preinv_$tmp_fbase (__gmpn_preinv_${tmp_fbase}_$tmp_suffix);" >>fat.h CPUVEC_SETUP="$CPUVEC_SETUP decided_cpuvec.preinv_$tmp_fbase = __gmpn_preinv_${tmp_fbase}_${tmp_suffix}; \\ " fi # Ditto for any mod_1...cps variant if grep "^PROLOGUE(mpn_${tmp_fbase}_cps)" $tmp_file >/dev/null; then echo "DECL_${tmp_fbase}_cps (__gmpn_${tmp_fbase}_cps_$tmp_suffix);" >>fat.h CPUVEC_SETUP="$CPUVEC_SETUP decided_cpuvec.${tmp_fbase}_cps = __gmpn_${tmp_fbase}_cps_${tmp_suffix}; \\ " fi fi done done done # Emit CPUVEC_SETUP for this directory echo "" >>fat.h echo "#define CPUVEC_SETUP_$tmp_suffix \\" >>fat.h echo " do { \\" >>fat.h echo "$CPUVEC_SETUP } while (0)" >>fat.h done # Emit threshold limits echo "" >>fat.h for tmp_tn in $fat_thresholds; do eval tmp_limit=\$${tmp_tn}_LIMIT echo "#define ${tmp_tn}_LIMIT $tmp_limit" >>fat.h done fi # Normal binary setups. # for tmp_ext in MPN_SUFFIXES; do eval found_$tmp_ext=no done for tmp_fn in $gmp_mpn_functions; do for tmp_ext in MPN_SUFFIXES; do test "$no_create" = yes || rm -f mpn/$tmp_fn.$tmp_ext done # mpn_preinv_divrem_1 might have been provided by divrem_1.asm, likewise # mpn_preinv_mod_1 by mod_1.asm. case $tmp_fn in pre_divrem_1) if test "$HAVE_NATIVE_mpn_preinv_divrem_1" = yes; then continue; fi ;; pre_mod_1) if test "$HAVE_NATIVE_mpn_preinv_mod_1" = yes; then continue; fi ;; esac GMP_MULFUNC_CHOICES found=no for tmp_dir in $path; do for tmp_base in $tmp_fn $tmp_mulfunc; do for tmp_ext in MPN_SUFFIXES; do tmp_file=$srcdir/mpn/$tmp_dir/$tmp_base.$tmp_ext if test -f $tmp_file; then # For a nails build, check if the file supports our nail bits. # Generic code always supports all nails. # # FIXME: When a multi-function file is selected to provide one of # the nails-neutral routines, like logops_n for and_n, the # PROLOGUE grepping will create HAVE_NATIVE_mpn_ defines for # all functions in that file, even if they haven't all been # nailified. Not sure what to do about this, it's only really a # problem for logops_n, and it's not too terrible to insist those # get nailified always. # if test $GMP_NAIL_BITS != 0 && test $tmp_dir != generic; then case $tmp_fn in and_n | ior_n | xor_n | andn_n | \ copyi | copyd | \ popcount | hamdist | \ udiv | udiv_w_sdiv | umul | \ cntlz | invert_limb) # these operations are either unaffected by nails or defined # to operate on full limbs ;; *) nails=[`sed -n 's/^[ ]*NAILS_SUPPORT(\(.*\))/\1/p' $tmp_file `] for n in $nails; do case $n in *-*) n_start=`echo "$n" | sed -n 's/\(.*\)-.*/\1/p'` n_end=`echo "$n" | sed -n 's/.*-\(.*\)/\1/p'` ;; *) n_start=$n n_end=$n ;; esac if test $GMP_NAIL_BITS -ge $n_start && test $GMP_NAIL_BITS -le $n_end; then found=yes break fi done if test $found != yes; then continue fi ;; esac fi # If the host uses a non-standard ABI, check if tmp_file supports it # if test -n "$GMP_NONSTD_ABI" && test $tmp_ext != "c"; then abi=[`sed -n 's/^[ ]*ABI_SUPPORT(\(.*\))/\1/p' $tmp_file `] if echo "$abi" | grep -q "\\b${GMP_NONSTD_ABI}\\b"; then true else continue fi fi found=yes eval found_$tmp_ext=yes if test $tmp_ext = c; then tmp_u='$U' else tmp_u= fi mpn_objects="$mpn_objects $tmp_fn$tmp_u.lo" mpn_objs_in_libgmp="$mpn_objs_in_libgmp mpn/$tmp_fn$tmp_u.lo" AC_CONFIG_LINKS(mpn/$tmp_fn.$tmp_ext:mpn/$tmp_dir/$tmp_base.$tmp_ext) gmp_srclinks="$gmp_srclinks mpn/$tmp_fn.$tmp_ext" # Duplicate AC_DEFINEs are harmless, so it doesn't matter # that multi-function files get grepped here repeatedly. # The PROLOGUE pattern excludes the optional second parameter. gmp_ep=[` sed -n 's/^[ ]*MULFUNC_PROLOGUE(\(.*\))/\1/p' $tmp_file ; sed -n 's/^[ ]*PROLOGUE(\([^,]*\).*)/\1/p' $tmp_file `] for gmp_tmp in $gmp_ep; do AC_DEFINE_UNQUOTED(HAVE_NATIVE_$gmp_tmp) eval HAVE_NATIVE_$gmp_tmp=yes done case $tmp_fn in sqr_basecase) sqr_basecase_source=$tmp_file ;; esac break fi done if test $found = yes; then break ; fi done if test $found = yes; then break ; fi done if test $found = no; then for tmp_optional in $gmp_mpn_functions_optional; do if test $tmp_optional = $tmp_fn; then found=yes fi done if test $found = no; then AC_MSG_ERROR([no version of $tmp_fn found in path: $path]) fi fi done # All cycle counters are .asm files currently if test -n "$SPEED_CYCLECOUNTER_OBJ"; then found_asm=yes fi dnl The following list only needs to have templates for those defines which dnl are going to be tested by the code, there's no need to have every dnl possible mpn routine. AH_VERBATIM([HAVE_NATIVE], [/* Define to 1 each of the following for which a native (ie. CPU specific) implementation of the corresponding routine exists. */ #undef HAVE_NATIVE_mpn_add_n #undef HAVE_NATIVE_mpn_add_n_sub_n #undef HAVE_NATIVE_mpn_add_nc #undef HAVE_NATIVE_mpn_addaddmul_1msb0 #undef HAVE_NATIVE_mpn_addlsh1_n #undef HAVE_NATIVE_mpn_addlsh2_n #undef HAVE_NATIVE_mpn_addlsh_n #undef HAVE_NATIVE_mpn_addlsh1_nc #undef HAVE_NATIVE_mpn_addlsh2_nc #undef HAVE_NATIVE_mpn_addlsh_nc #undef HAVE_NATIVE_mpn_addlsh1_n_ip1 #undef HAVE_NATIVE_mpn_addlsh2_n_ip1 #undef HAVE_NATIVE_mpn_addlsh_n_ip1 #undef HAVE_NATIVE_mpn_addlsh1_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh2_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh_nc_ip1 #undef HAVE_NATIVE_mpn_addlsh1_n_ip2 #undef HAVE_NATIVE_mpn_addlsh2_n_ip2 #undef HAVE_NATIVE_mpn_addlsh_n_ip2 #undef HAVE_NATIVE_mpn_addlsh1_nc_ip2 #undef HAVE_NATIVE_mpn_addlsh2_nc_ip2 #undef HAVE_NATIVE_mpn_addlsh_nc_ip2 #undef HAVE_NATIVE_mpn_addmul_1c #undef HAVE_NATIVE_mpn_addmul_2 #undef HAVE_NATIVE_mpn_addmul_3 #undef HAVE_NATIVE_mpn_addmul_4 #undef HAVE_NATIVE_mpn_addmul_5 #undef HAVE_NATIVE_mpn_addmul_6 #undef HAVE_NATIVE_mpn_addmul_7 #undef HAVE_NATIVE_mpn_addmul_8 #undef HAVE_NATIVE_mpn_addmul_2s #undef HAVE_NATIVE_mpn_and_n #undef HAVE_NATIVE_mpn_andn_n #undef HAVE_NATIVE_mpn_bdiv_dbm1c #undef HAVE_NATIVE_mpn_bdiv_q_1 #undef HAVE_NATIVE_mpn_pi1_bdiv_q_1 #undef HAVE_NATIVE_mpn_cnd_add_n #undef HAVE_NATIVE_mpn_cnd_sub_n #undef HAVE_NATIVE_mpn_com #undef HAVE_NATIVE_mpn_copyd #undef HAVE_NATIVE_mpn_copyi #undef HAVE_NATIVE_mpn_div_qr_1n_pi1 #undef HAVE_NATIVE_mpn_div_qr_2 #undef HAVE_NATIVE_mpn_divexact_1 #undef HAVE_NATIVE_mpn_divexact_by3c #undef HAVE_NATIVE_mpn_divrem_1 #undef HAVE_NATIVE_mpn_divrem_1c #undef HAVE_NATIVE_mpn_divrem_2 #undef HAVE_NATIVE_mpn_gcd_1 #undef HAVE_NATIVE_mpn_hamdist #undef HAVE_NATIVE_mpn_invert_limb #undef HAVE_NATIVE_mpn_ior_n #undef HAVE_NATIVE_mpn_iorn_n #undef HAVE_NATIVE_mpn_lshift #undef HAVE_NATIVE_mpn_lshiftc #undef HAVE_NATIVE_mpn_lshsub_n #undef HAVE_NATIVE_mpn_mod_1 #undef HAVE_NATIVE_mpn_mod_1_1p #undef HAVE_NATIVE_mpn_mod_1c #undef HAVE_NATIVE_mpn_mod_1s_2p #undef HAVE_NATIVE_mpn_mod_1s_4p #undef HAVE_NATIVE_mpn_mod_34lsub1 #undef HAVE_NATIVE_mpn_modexact_1_odd #undef HAVE_NATIVE_mpn_modexact_1c_odd #undef HAVE_NATIVE_mpn_mul_1 #undef HAVE_NATIVE_mpn_mul_1c #undef HAVE_NATIVE_mpn_mul_2 #undef HAVE_NATIVE_mpn_mul_3 #undef HAVE_NATIVE_mpn_mul_4 #undef HAVE_NATIVE_mpn_mul_5 #undef HAVE_NATIVE_mpn_mul_6 #undef HAVE_NATIVE_mpn_mul_basecase #undef HAVE_NATIVE_mpn_nand_n #undef HAVE_NATIVE_mpn_nior_n #undef HAVE_NATIVE_mpn_popcount #undef HAVE_NATIVE_mpn_preinv_divrem_1 #undef HAVE_NATIVE_mpn_preinv_mod_1 #undef HAVE_NATIVE_mpn_redc_1 #undef HAVE_NATIVE_mpn_redc_2 #undef HAVE_NATIVE_mpn_rsblsh1_n #undef HAVE_NATIVE_mpn_rsblsh2_n #undef HAVE_NATIVE_mpn_rsblsh_n #undef HAVE_NATIVE_mpn_rsblsh1_nc #undef HAVE_NATIVE_mpn_rsblsh2_nc #undef HAVE_NATIVE_mpn_rsblsh_nc #undef HAVE_NATIVE_mpn_rsh1add_n #undef HAVE_NATIVE_mpn_rsh1add_nc #undef HAVE_NATIVE_mpn_rsh1sub_n #undef HAVE_NATIVE_mpn_rsh1sub_nc #undef HAVE_NATIVE_mpn_rshift #undef HAVE_NATIVE_mpn_sqr_basecase #undef HAVE_NATIVE_mpn_sqr_diagonal #undef HAVE_NATIVE_mpn_sqr_diag_addlsh1 #undef HAVE_NATIVE_mpn_sub_n #undef HAVE_NATIVE_mpn_sub_nc #undef HAVE_NATIVE_mpn_sublsh1_n #undef HAVE_NATIVE_mpn_sublsh2_n #undef HAVE_NATIVE_mpn_sublsh_n #undef HAVE_NATIVE_mpn_sublsh1_nc #undef HAVE_NATIVE_mpn_sublsh2_nc #undef HAVE_NATIVE_mpn_sublsh_nc #undef HAVE_NATIVE_mpn_sublsh1_n_ip1 #undef HAVE_NATIVE_mpn_sublsh2_n_ip1 #undef HAVE_NATIVE_mpn_sublsh_n_ip1 #undef HAVE_NATIVE_mpn_sublsh1_nc_ip1 #undef HAVE_NATIVE_mpn_sublsh2_nc_ip1 #undef HAVE_NATIVE_mpn_sublsh_nc_ip1 #undef HAVE_NATIVE_mpn_submul_1c #undef HAVE_NATIVE_mpn_tabselect #undef HAVE_NATIVE_mpn_udiv_qrnnd #undef HAVE_NATIVE_mpn_udiv_qrnnd_r #undef HAVE_NATIVE_mpn_umul_ppmm #undef HAVE_NATIVE_mpn_umul_ppmm_r #undef HAVE_NATIVE_mpn_xor_n #undef HAVE_NATIVE_mpn_xnor_n]) # Don't demand an m4 unless it's actually needed. if test $found_asm = yes; then GMP_PROG_M4 GMP_M4_M4WRAP_SPURIOUS # else # It's unclear why this m4-not-needed stuff was ever done. # if test -z "$M4" ; then # M4=m4-not-needed # fi fi # Only do the GMP_ASM checks if there's a .S or .asm wanting them. if test $found_asm = no && test $found_S = no; then gmp_asm_syntax_testing=no fi if test "$gmp_asm_syntax_testing" != no; then GMP_ASM_TEXT GMP_ASM_DATA GMP_ASM_LABEL_SUFFIX GMP_ASM_GLOBL GMP_ASM_GLOBL_ATTR GMP_ASM_UNDERSCORE GMP_ASM_RODATA GMP_ASM_TYPE GMP_ASM_SIZE GMP_ASM_LSYM_PREFIX GMP_ASM_W32 GMP_ASM_ALIGN_LOG case $host in hppa*-*-*) # for both pa32 and pa64 GMP_INCLUDE_MPN(pa32/pa-defs.m4) ;; IA64_PATTERN) GMP_ASM_IA64_ALIGN_OK ;; M68K_PATTERN) GMP_ASM_M68K_INSTRUCTION GMP_ASM_M68K_ADDRESSING GMP_ASM_M68K_BRANCHES ;; [powerpc*-*-* | power[3-9]-*-*]) GMP_ASM_POWERPC_PIC_ALWAYS GMP_ASM_POWERPC_R_REGISTERS GMP_INCLUDE_MPN(powerpc32/powerpc-defs.m4) # Check for Linux ELFv2 ABI AC_EGREP_CPP(yes, [#if _CALL_ELF == 2 yes #endif], [GMP_DEFINE_RAW(["define()"])]) case $host in *-*-aix*) case $ABI in mode64) GMP_INCLUDE_MPN(powerpc64/aix.m4) ;; *) GMP_INCLUDE_MPN(powerpc32/aix.m4) ;; esac ;; *-*-linux* | *-*-*bsd*) case $ABI in mode64) GMP_INCLUDE_MPN(powerpc64/elf.m4) ;; mode32 | 32) GMP_INCLUDE_MPN(powerpc32/elf.m4) ;; esac ;; *-*-darwin*) case $ABI in mode64) GMP_INCLUDE_MPN(powerpc64/darwin.m4) ;; mode32 | 32) GMP_INCLUDE_MPN(powerpc32/darwin.m4) ;; esac ;; *) # Assume unrecognized operating system is the powerpc eABI GMP_INCLUDE_MPN(powerpc32/eabi.m4) ;; esac ;; power*-*-aix*) GMP_INCLUDE_MPN(powerpc32/aix.m4) ;; *sparc*-*-*) case $ABI in 64) GMP_ASM_SPARC_REGISTER ;; esac GMP_ASM_SPARC_GOTDATA GMP_ASM_SPARC_SHARED_THUNKS ;; X86_PATTERN | X86_64_PATTERN) GMP_ASM_ALIGN_FILL_0x90 case $ABI in 32) GMP_INCLUDE_MPN(x86/x86-defs.m4) AC_DEFINE(HAVE_HOST_CPU_FAMILY_x86) GMP_ASM_COFF_TYPE GMP_ASM_X86_GOT_UNDERSCORE GMP_ASM_X86_SHLDL_CL case $enable_profiling in prof | gprof) GMP_ASM_X86_MCOUNT ;; esac case $host in *-*-darwin*) GMP_INCLUDE_MPN(x86/darwin.m4) ;; esac ;; 64|x32) GMP_INCLUDE_MPN(x86_64/x86_64-defs.m4) AC_DEFINE(HAVE_HOST_CPU_FAMILY_x86_64) case $host in *-*-darwin*) GMP_INCLUDE_MPN(x86_64/darwin.m4) ;; *-*-mingw* | *-*-cygwin) GMP_INCLUDE_MPN(x86_64/dos64.m4) ;; *-openbsd*) GMP_DEFINE_RAW(["define(,1)"]) ;; esac ;; esac ;; esac fi # For --enable-minithres, prepend "minithres" to path so that its special # gmp-mparam.h will be used. if test $enable_minithres = yes; then path="minithres $path" fi # Create link for gmp-mparam.h. gmp_mparam_source= for gmp_mparam_dir in $path; do test "$no_create" = yes || rm -f gmp-mparam.h tmp_file=$srcdir/mpn/$gmp_mparam_dir/gmp-mparam.h if test -f $tmp_file; then AC_CONFIG_LINKS(gmp-mparam.h:mpn/$gmp_mparam_dir/gmp-mparam.h) gmp_srclinks="$gmp_srclinks gmp-mparam.h" gmp_mparam_source=$tmp_file break fi done if test -z "$gmp_mparam_source"; then AC_MSG_ERROR([no version of gmp-mparam.h found in path: $path]) fi # For a helpful message from tune/tuneup.c gmp_mparam_suggest=$gmp_mparam_source if test "$gmp_mparam_dir" = generic; then for i in $path; do break; done if test "$i" != generic; then gmp_mparam_suggest="new file $srcdir/mpn/$i/gmp-mparam.h" fi fi AC_DEFINE_UNQUOTED(GMP_MPARAM_H_SUGGEST, "$gmp_mparam_source", [The gmp-mparam.h file (a string) the tune program should suggest updating.]) # Copy relevant parameters from gmp-mparam.h to config.m4. # We only do this for parameters that are used by some assembly files. # Fat binaries do this on a per-file basis, so skip in that case. # if test -z "$fat_path"; then for i in SQR_TOOM2_THRESHOLD BMOD_1_TO_MOD_1_THRESHOLD SHLD_SLOW SHRD_SLOW; do value=`sed -n 's/^#define '$i'[ ]*\([0-9][0-9]*\).*$/\1/p' $gmp_mparam_source` if test -n "$value"; then GMP_DEFINE_RAW(["define(<$i>,<$value>)"]) fi done fi # Sizes of some types, needed at preprocessing time. # # FIXME: The assumption that GMP_LIMB_BITS is 8*sizeof(mp_limb_t) might # be slightly rash, but it's true everywhere we know of and ought to be true # of any sensible system. In a generic C build, grepping LONG_BIT out of # might be an alternative, for maximum portability. # AC_CHECK_SIZEOF(void *) AC_CHECK_SIZEOF(unsigned short) AC_CHECK_SIZEOF(unsigned) AC_CHECK_SIZEOF(unsigned long) AC_CHECK_SIZEOF(mp_limb_t, , GMP_INCLUDE_GMP_H) if test "$ac_cv_sizeof_mp_limb_t" = 0; then AC_MSG_ERROR([Oops, mp_limb_t doesn't seem to work]) fi AC_SUBST(GMP_LIMB_BITS, `expr 8 \* $ac_cv_sizeof_mp_limb_t`) GMP_DEFINE_RAW(["define(,<$ac_cv_sizeof_unsigned>)"]) # Check compiler limb size matches gmp-mparam.h # # FIXME: Some of the cycle counter objects in the tune directory depend on # the size of ulong, it'd be possible to check that here, though a mismatch # probably wouldn't want to be fatal, none of the libgmp assembler code # depends on ulong. # mparam_bits=[`sed -n 's/^#define GMP_LIMB_BITS[ ][ ]*\([0-9]*\).*$/\1/p' $gmp_mparam_source`] if test -n "$mparam_bits" && test "$mparam_bits" -ne $GMP_LIMB_BITS; then if test "$test_CFLAGS" = set; then AC_MSG_ERROR([Oops, mp_limb_t is $GMP_LIMB_BITS bits, but the assembler code in this configuration expects $mparam_bits bits. You appear to have set \$CFLAGS, perhaps you also need to tell GMP the intended ABI, see "ABI and ISA" in the manual.]) else AC_MSG_ERROR([Oops, mp_limb_t is $GMP_LIMB_BITS bits, but the assembler code in this configuration expects $mparam_bits bits.]) fi fi GMP_DEFINE_RAW(["define(,$GMP_LIMB_BITS)"]) GMP_DEFINE_RAW(["define(,$GMP_NAIL_BITS)"]) GMP_DEFINE_RAW(["define(,eval(GMP_LIMB_BITS-GMP_NAIL_BITS))"]) AC_SUBST(mpn_objects) AC_SUBST(mpn_objs_in_libgmp) AC_SUBST(gmp_srclinks) # A recompiled sqr_basecase for use in the tune program, if necessary. TUNE_SQR_OBJ= test -d tune || mkdir tune case $sqr_basecase_source in *.asm) sqr_max=[`sed -n 's/^def...(SQR_TOOM2_THRESHOLD_MAX, *\([0-9]*\))/\1/p' $sqr_basecase_source`] if test -n "$sqr_max"; then TUNE_SQR_OBJ=sqr_asm.o AC_DEFINE_UNQUOTED(TUNE_SQR_TOOM2_MAX,$sqr_max, [Maximum size the tune program can test for SQR_TOOM2_THRESHOLD]) fi cat >tune/sqr_basecase.c <tune/sqr_basecase.c <]) AC_SUBST(HAVE_STACK_T_01) # Configs for demos/calc directory # # AC_SUBST+AC_CONFIG_FILES is used for calc-config.h, rather than AC_DEFINE+ # AC_CONFIG_HEADERS, since with the latter automake (1.8) will then put the # directory (ie. demos/calc) into $(DEFAULT_INCLUDES) for every Makefile.in, # which would look very strange. # # -lcurses is required by libreadline. On a typical SVR4 style system this # normally doesn't have to be given explicitly, since libreadline.so will # have a NEEDED record for it. But if someone for some reason is using only # a static libreadline.a then we must give -lcurses. Readline (as of # version 4.3) doesn't use libtool, so we can't rely on a .la to cover # necessary dependencies. # # On a couple of systems we've seen libreadline available, but the headers # not in the default include path, so check for readline/readline.h. We've # also seen readline/history.h missing, not sure if that's just a broken # install or a very old version, but check that too. # AC_CONFIG_FILES(demos/calc/calc-config.h:demos/calc/calc-config-h.in) LIBCURSES= if test $with_readline != no; then AC_CHECK_LIB(ncurses, tputs, [LIBCURSES=-lncurses], [AC_CHECK_LIB(curses, tputs, [LIBCURSES=-lcurses])]) fi AC_SUBST(LIBCURSES) use_readline=$with_readline if test $with_readline = detect; then use_readline=no AC_CHECK_LIB(readline, readline, [AC_CHECK_HEADER(readline/readline.h, [AC_CHECK_HEADER(readline/history.h, use_readline=yes)])], , $LIBCURSES) AC_MSG_CHECKING(readline detected) AC_MSG_RESULT($use_readline) fi if test $use_readline = yes; then AC_SUBST(WITH_READLINE_01, 1) AC_SUBST(LIBREADLINE, -lreadline) else WITH_READLINE_01=0 fi AC_PROG_YACC AM_PROG_LEX # Configs for demos/expr directory # # Libtool already runs an AC_CHECK_TOOL for ranlib, but we give # AC_PROG_RANLIB anyway since automake is supposed to complain if it's not # called. (Automake 1.8.4 doesn't, at least not when the only library is in # an EXTRA_LIBRARIES.) # AC_PROG_RANLIB # Create config.m4. GMP_FINISH # Create Makefiles # FIXME: Upcoming version of autoconf/automake may not like broken lines. # Right now automake isn't accepting the new AC_CONFIG_FILES scheme. AC_OUTPUT(Makefile \ mpf/Makefile mpn/Makefile mpq/Makefile \ mpz/Makefile printf/Makefile scanf/Makefile rand/Makefile cxx/Makefile \ tests/Makefile tests/devel/Makefile \ tests/mpf/Makefile tests/mpn/Makefile tests/mpq/Makefile \ tests/mpz/Makefile tests/rand/Makefile tests/misc/Makefile \ tests/cxx/Makefile \ doc/Makefile tune/Makefile \ demos/Makefile demos/calc/Makefile demos/expr/Makefile \ gmp.h:gmp-h.in) AC_MSG_NOTICE([summary of build options: Version: ${PACKAGE_STRING} Host type: ${host} ABI: ${ABI} Install prefix: ${prefix} Compiler: ${CC} Static libraries: ${enable_static} Shared libraries: ${enable_shared} ]) if test x$cross_compiling = xyes ; then case "$host" in *-*-mingw* | *-*-cygwin) if test x$ABI = x64 ; then AC_MSG_NOTICE([If wine64 is installed, use make check TESTS_ENVIRONMENT=wine64.]) else AC_MSG_NOTICE([If wine is installed, use make check TESTS_ENVIRONMENT=wine.]) fi ;; esac fi gcl-2.6.14/gmp4/cxx/0000755000175000017500000000000014360276512012444 5ustar cammcammgcl-2.6.14/gmp4/cxx/ismpq.cc0000644000175000017500000000317214360276512014107 0ustar cammcamm/* operator>> -- C++-style input of mpq_t. Copyright 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "gmp-impl.h" using namespace std; istream & operator>> (istream &i, mpq_ptr q) { if (! (i >> mpq_numref(q))) return i; char c = 0; i.get(c); // start reading if (c == '/') { // skip slash, read denominator i.get(c); return __gmpz_operator_in_nowhite (i, mpq_denref(q), c); } else { // no denominator, set 1 q->_mp_den._mp_size = 1; q->_mp_den._mp_d[0] = 1; if (i.good()) i.putback(c); else if (i.eof()) i.clear(ios::eofbit); } return i; } gcl-2.6.14/gmp4/cxx/osdoprnti.cc0000644000175000017500000000407114360276512014776 0ustar cammcamm/* __gmp_doprnt_integer_ios -- integer formatted output to an ostream. THE FUNCTIONS IN THIS FILE ARE FOR INTERNAL USE ONLY. THEY'RE ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for va_list and hence doprnt_funs_t */ #include /* for strlen */ #include "gmp.h" #include "gmp-impl.h" using namespace std; /* The gmp_asprintf support routines never give an error, so __gmp_doprnt_integer shouldn't fail and it's return can just be checked with an ASSERT. */ ostream& __gmp_doprnt_integer_ostream (ostream &o, struct doprnt_params_t *p, char *s) { struct gmp_asprintf_t d; char *result; int ret; /* don't show leading zeros the way printf does */ p->prec = -1; GMP_ASPRINTF_T_INIT (d, &result); ret = __gmp_doprnt_integer (&__gmp_asprintf_funs_noformat, &d, p, s); ASSERT (ret != -1); __gmp_asprintf_final (&d); (*__gmp_free_func) (s, strlen(s)+1); gmp_allocated_string t (result); return o.write (t.str, t.len); } gcl-2.6.14/gmp4/cxx/osmpz.cc0000644000175000017500000000267214360276512014132 0ustar cammcamm/* operator<< -- mpz formatted output to an ostream. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for va_list and hence doprnt_funs_t */ #include #include "gmp.h" #include "gmp-impl.h" using namespace std; ostream& operator<< (ostream &o, mpz_srcptr z) { struct doprnt_params_t param; __gmp_doprnt_params_from_ios (¶m, o); return __gmp_doprnt_integer_ostream (o, ¶m, mpz_get_str (NULL, param.base, z)); } gcl-2.6.14/gmp4/cxx/ismpf.cc0000644000175000017500000000701514360276512014074 0ustar cammcamm/* operator>> -- C++-style input of mpf_t. Copyright 2001, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include // for localeconv #include "gmp.h" #include "gmp-impl.h" using namespace std; // For g++ libstdc++ parsing see num_get::_M_extract_float // in include/bits/locale_facets.tcc. // // There are no plans to accept hex or octal floats, not unless the standard // C++ library does so. Although such formats might be of use, it's // considered more important to be compatible with what the normal // operator>> does on "double"s etc. istream & operator>> (istream &i, mpf_ptr f) { int base; char c = 0; string s; bool ok = false; // C decimal point, as expected by mpf_set_str const char *lconv_point = GMP_DECIMAL_POINT; // C++ decimal point #if HAVE_STD__LOCALE const locale& loc = i.getloc(); char point_char = use_facet< numpunct >(loc).decimal_point(); #else const char *point = lconv_point; char point_char = *point; #endif i.get(c); // start reading if (i.flags() & ios::skipws) // skip initial whitespace { // C++ isspace #if HAVE_STD__LOCALE const ctype& ct = use_facet< ctype >(loc); #define cxx_isspace(c) (ct.is(ctype_base::space,(c))) #else #define cxx_isspace(c) isspace(c) #endif while (cxx_isspace(c) && i.get(c)) ; } if (c == '-' || c == '+') // sign { if (c == '-') s = "-"; i.get(c); } base = 10; __gmp_istream_set_digits(s, i, c, ok, base); // read the number // look for the C++ radix point, but put the C one in for mpf_set_str if (c == point_char) { #if HAVE_STD__LOCALE i.get(c); #else // lconv point can be multi-char for (;;) { i.get(c); point++; if (*point == '\0') break; if (c != *point) goto fail; } #endif s += lconv_point; __gmp_istream_set_digits(s, i, c, ok, base); // read the mantissa } if (ok && (c == 'e' || c == 'E')) // exponent { s += c; i.get(c); ok = false; // exponent is mandatory if (c == '-' || c == '+') // sign { s += c; i.get(c); } __gmp_istream_set_digits(s, i, c, ok, base); // read the exponent } if (i.good()) // last character read was non-numeric i.putback(c); else if (i.eof() && ok) // stopped just before eof i.clear(ios::eofbit); if (ok) ASSERT_NOCARRY (mpf_set_str(f, s.c_str(), base)); // extract the number else { fail: i.setstate(ios::failbit); // read failed } return i; } gcl-2.6.14/gmp4/cxx/osfuns.cc0000644000175000017500000000734014360276512014274 0ustar cammcamm/* Support for operator<< routines. THE FUNCTIONS IN THIS FILE ARE FOR INTERNAL USE ONLY. THEY'RE ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for va_list and hence doprnt_funs_t */ #include #include "gmp.h" #include "gmp-impl.h" using namespace std; /* Don't need "format" for operator<< routines, just "memory" and "reps". Omitting gmp_asprintf_format lets us avoid dragging vsnprintf into the link. __gmp_asprintf_final will be called directly and doesn't need to be in the struct. */ const struct doprnt_funs_t __gmp_asprintf_funs_noformat = { NULL, (doprnt_memory_t) __gmp_asprintf_memory, (doprnt_reps_t) __gmp_asprintf_reps, NULL }; void __gmp_doprnt_params_from_ios (struct doprnt_params_t *p, ios &o) { if ((o.flags() & ios::basefield) == ios::hex) { p->expfmt = "@%c%02d"; p->base = (o.flags() & ios::uppercase ? -16 : 16); } else { p->expfmt = (o.flags() & ios::uppercase ? "E%c%02d" : "e%c%02d"); if ((o.flags() & ios::basefield) == ios::oct) p->base = 8; else p->base = 10; } /* "general" if none or more than one bit set */ if ((o.flags() & ios::floatfield) == ios::fixed) p->conv = DOPRNT_CONV_FIXED; else if ((o.flags() & ios::floatfield) == ios::scientific) p->conv = DOPRNT_CONV_SCIENTIFIC; else p->conv = DOPRNT_CONV_GENERAL; p->exptimes4 = 0; p->fill = o.fill(); /* "right" if more than one bit set */ if ((o.flags() & ios::adjustfield) == ios::left) p->justify = DOPRNT_JUSTIFY_LEFT; else if ((o.flags() & ios::adjustfield) == ios::internal) p->justify = DOPRNT_JUSTIFY_INTERNAL; else p->justify = DOPRNT_JUSTIFY_RIGHT; /* ios::fixed allows prec==0, others take 0 as the default 6. Don't allow negatives (they do bad things to __gmp_doprnt_float_cxx). */ p->prec = MAX (0, o.precision()); if (p->prec == 0 && p->conv != DOPRNT_CONV_FIXED) p->prec = 6; /* for hex showbase is always, for octal only non-zero */ if (o.flags() & ios::showbase) p->showbase = ((o.flags() & ios::basefield) == ios::hex ? DOPRNT_SHOWBASE_YES : DOPRNT_SHOWBASE_NONZERO); else p->showbase = DOPRNT_SHOWBASE_NO; p->showpoint = ((o.flags() & ios::showpoint) != 0); /* in fixed and scientific always show trailing zeros, in general format show them if showpoint is set (or so it seems) */ if ((o.flags() & ios::floatfield) == ios::fixed || (o.flags() & ios::floatfield) == ios::scientific) p->showtrailing = 1; else p->showtrailing = p->showpoint; p->sign = (o.flags() & ios::showpos ? '+' : '\0'); p->width = o.width(); /* reset on each output */ o.width (0); } gcl-2.6.14/gmp4/cxx/isfuns.cc0000644000175000017500000000465314360276512014272 0ustar cammcamm/* Auxiliary functions for C++-style input of GMP types. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "gmp-impl.h" using namespace std; int __gmp_istream_set_base (istream &i, char &c, bool &zero, bool &showbase) { int base; zero = showbase = false; switch (i.flags() & ios::basefield) { case ios::dec: base = 10; break; case ios::hex: base = 16; break; case ios::oct: base = 8; break; default: showbase = true; // look for initial "0" or "0x" or "0X" if (c == '0') { if (! i.get(c)) c = 0; // reset or we might loop indefinitely if (c == 'x' || c == 'X') { base = 16; i.get(c); } else { base = 8; zero = true; // if no other digit is read, the "0" counts } } else base = 10; break; } return base; } void __gmp_istream_set_digits (string &s, istream &i, char &c, bool &ok, int base) { switch (base) { case 10: while (isdigit(c)) { ok = true; // at least a valid digit was read s += c; if (! i.get(c)) break; } break; case 8: while (isdigit(c) && c != '8' && c != '9') { ok = true; // at least a valid digit was read s += c; if (! i.get(c)) break; } break; case 16: while (isxdigit(c)) { ok = true; // at least a valid digit was read s += c; if (! i.get(c)) break; } break; } } gcl-2.6.14/gmp4/cxx/Makefile.am0000644000175000017500000000251514360276512014503 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 2001-2003, 2012 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. INCLUDES = -D__GMP_WITHIN_GMPXX -I$(top_srcdir) if WANT_CXX noinst_LTLIBRARIES = libcxx.la endif libcxx_la_SOURCES = \ isfuns.cc ismpf.cc ismpq.cc ismpz.cc ismpznw.cc limits.cc \ osdoprnti.cc osfuns.cc osmpf.cc osmpq.cc osmpz.cc gcl-2.6.14/gmp4/cxx/ismpz.cc0000644000175000017500000000327714360276512014126 0ustar cammcamm/* operator>> -- C++-style input of mpz_t. Copyright 2001, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "gmp-impl.h" using namespace std; // For g++ libstdc++ parsing see num_get::_M_extract_int in // include/bits/locale_facets.tcc. istream & operator>> (istream &i, mpz_ptr z) { char c = 0; i.get(c); // start reading if (i.flags() & ios::skipws) // skip initial whitespace { #if HAVE_STD__LOCALE const ctype& ct = use_facet< ctype >(i.getloc()); #define cxx_isspace(c) (ct.is(ctype_base::space,(c))) #else #define cxx_isspace(c) isspace(c) #endif while (cxx_isspace(c) && i.get(c)) ; } return __gmpz_operator_in_nowhite (i, z, c); } gcl-2.6.14/gmp4/cxx/limits.cc0000644000175000017500000000444314360276512014261 0ustar cammcamm/* instantiation of numeric_limits specializations. Copyright 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmpxx.h" namespace std { #define GMPXX_INSTANTIATE_LIMITS(T) \ const bool numeric_limits::is_specialized; \ const int numeric_limits::digits; \ const int numeric_limits::digits10; \ const int numeric_limits::max_digits10; \ const bool numeric_limits::is_signed; \ const bool numeric_limits::is_integer; \ const bool numeric_limits::is_exact; \ const int numeric_limits::radix; \ const int numeric_limits::min_exponent; \ const int numeric_limits::min_exponent10; \ const int numeric_limits::max_exponent; \ const int numeric_limits::max_exponent10; \ const bool numeric_limits::has_infinity; \ const bool numeric_limits::has_quiet_NaN; \ const bool numeric_limits::has_signaling_NaN; \ const float_denorm_style numeric_limits::has_denorm; \ const bool numeric_limits::has_denorm_loss; \ const bool numeric_limits::is_iec559; \ const bool numeric_limits::is_bounded; \ const bool numeric_limits::is_modulo; \ const bool numeric_limits::traps; \ const bool numeric_limits::tinyness_before; \ const float_round_style numeric_limits::round_style GMPXX_INSTANTIATE_LIMITS(mpz_class); GMPXX_INSTANTIATE_LIMITS(mpq_class); GMPXX_INSTANTIATE_LIMITS(mpf_class); } gcl-2.6.14/gmp4/cxx/ismpznw.cc0000644000175000017500000000403114360276512014460 0ustar cammcamm/* __gmpz_operator_in_nowhite -- C++-style input of mpz_t, no whitespace skip. Copyright 2001, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "gmp-impl.h" using namespace std; // For g++ libstdc++ parsing see num_get::_M_extract_int in // include/bits/locale_facets.tcc. istream & __gmpz_operator_in_nowhite (istream &i, mpz_ptr z, char c) { int base; string s; bool ok = false, zero, showbase; if (c == '-' || c == '+') // sign { if (c == '-') // mpz_set_str doesn't accept '+' s = "-"; i.get(c); } base = __gmp_istream_set_base(i, c, zero, showbase); // select the base __gmp_istream_set_digits(s, i, c, ok, base); // read the number if (i.good()) // last character read was non-numeric i.putback(c); else if (i.eof() && (ok || zero)) // stopped just before eof i.clear(ios::eofbit); if (ok) ASSERT_NOCARRY (mpz_set_str (z, s.c_str(), base)); // extract the number else if (zero) mpz_set_ui(z, 0); else i.setstate(ios::failbit); // read failed return i; } gcl-2.6.14/gmp4/cxx/osmpq.cc0000644000175000017500000000267214360276512014121 0ustar cammcamm/* operator<< -- mpq formatted output to an ostream. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for va_list and hence doprnt_funs_t */ #include #include "gmp.h" #include "gmp-impl.h" using namespace std; ostream& operator<< (ostream &o, mpq_srcptr q) { struct doprnt_params_t param; __gmp_doprnt_params_from_ios (¶m, o); return __gmp_doprnt_integer_ostream (o, ¶m, mpq_get_str (NULL, param.base, q)); } gcl-2.6.14/gmp4/cxx/osmpf.cc0000644000175000017500000000372314360276512014104 0ustar cammcamm/* operator<< -- mpf formatted output to an ostream. Copyright 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include /* for va_list and hence doprnt_funs_t */ #include #include "gmp.h" #include "gmp-impl.h" using namespace std; /* The gmp_asprintf support routines never give an error, so __gmp_doprnt_mpf shouldn't fail and it's return can just be checked with an ASSERT. */ ostream& operator<< (ostream &o, mpf_srcptr f) { struct doprnt_params_t param; struct gmp_asprintf_t d; char *result; int ret; __gmp_doprnt_params_from_ios (¶m, o); #if HAVE_STD__LOCALE char point[2]; point[0] = use_facet< numpunct >(o.getloc()).decimal_point(); point[1] = '\0'; #else const char *point = GMP_DECIMAL_POINT; #endif GMP_ASPRINTF_T_INIT (d, &result); ret = __gmp_doprnt_mpf (&__gmp_asprintf_funs_noformat, &d, ¶m, point, f); ASSERT (ret != -1); __gmp_asprintf_final (&d); gmp_allocated_string t (result); return o.write (t.str, t.len); } gcl-2.6.14/gmp4/cxx/dummy.cc0000644000175000017500000000215114360276512014105 0ustar cammcamm/* Dummy file to make automake treat libgmpxx.la as C++. Copyright 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* some compilers reputedly dislike completely empty files */ typedef int foo; gcl-2.6.14/gmp4/cxx/Makefile.in0000644000175000017500000004421414360276512014516 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 2001-2003, 2012 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = cxx DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LTLIBRARIES = $(noinst_LTLIBRARIES) libcxx_la_LIBADD = am_libcxx_la_OBJECTS = isfuns.lo ismpf.lo ismpq.lo ismpz.lo ismpznw.lo \ limits.lo osdoprnti.lo osfuns.lo osmpf.lo osmpq.lo osmpz.lo libcxx_la_OBJECTS = $(am_libcxx_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = @WANT_CXX_TRUE@am_libcxx_la_rpath = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = CXXCOMPILE = $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) LTCXXCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CXXFLAGS) $(CXXFLAGS) AM_V_CXX = $(am__v_CXX_@AM_V@) am__v_CXX_ = $(am__v_CXX_@AM_DEFAULT_V@) am__v_CXX_0 = @echo " CXX " $@; am__v_CXX_1 = CXXLD = $(CXX) CXXLINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ $(CXXFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CXXLD = $(am__v_CXXLD_@AM_V@) am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@) am__v_CXXLD_0 = @echo " CXXLD " $@; am__v_CXXLD_1 = SOURCES = $(libcxx_la_SOURCES) DIST_SOURCES = $(libcxx_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ INCLUDES = -D__GMP_WITHIN_GMPXX -I$(top_srcdir) @WANT_CXX_TRUE@noinst_LTLIBRARIES = libcxx.la libcxx_la_SOURCES = \ isfuns.cc ismpf.cc ismpq.cc ismpz.cc ismpznw.cc limits.cc \ osdoprnti.cc osfuns.cc osmpf.cc osmpq.cc osmpz.cc all: all-am .SUFFIXES: .SUFFIXES: .cc .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps cxx/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps cxx/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): clean-noinstLTLIBRARIES: -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) @list='$(noinst_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } libcxx.la: $(libcxx_la_OBJECTS) $(libcxx_la_DEPENDENCIES) $(EXTRA_libcxx_la_DEPENDENCIES) $(AM_V_CXXLD)$(CXXLINK) $(am_libcxx_la_rpath) $(libcxx_la_OBJECTS) $(libcxx_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .cc.o: $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ $< .cc.obj: $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .cc.lo: $(AM_V_CXX)$(LTCXXCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(LTLIBRARIES) installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \ mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool clean-noinstLTLIBRARIES cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/mp_clz_tab.c0000644000175000017500000000311414360276512014117 0ustar cammcamm/* __clz_tab -- support for longlong.h THE CONTENTS OF THIS FILE ARE FOR INTERNAL USE AND MAY CHANGE INCOMPATIBLY OR DISAPPEAR IN A FUTURE GNU MP RELEASE. Copyright 1991, 1993, 1994, 1996, 1997, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" #ifdef COUNT_LEADING_ZEROS_NEED_CLZ_TAB const unsigned char __clz_tab[129] = { 1,2,3,3,4,4,4,4,5,5,5,5,5,5,5,5,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, 9 }; #endif gcl-2.6.14/gmp4/mp_get_fns.c0000644000175000017500000000275414360276512014137 0ustar cammcamm/* mp_get_memory_functions -- Get the allocate, reallocate, and free functions. Copyright 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" void mp_get_memory_functions (void *(**alloc_func) (size_t), void *(**realloc_func) (void *, size_t, size_t), void (**free_func) (void *, size_t)) __GMP_NOTHROW { if (alloc_func != NULL) *alloc_func = __gmp_allocate_func; if (realloc_func != NULL) *realloc_func = __gmp_reallocate_func; if (free_func != NULL) *free_func = __gmp_free_func; } gcl-2.6.14/gmp4/gen-psqr.c0000644000175000017500000004216714360276512013554 0ustar cammcamm/* Generate perfect square testing data. Copyright 2002-2004, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "bootstrap.c" /* The aim of this program is to choose either mpn_mod_34lsub1 or mpn_mod_1 (plus a PERFSQR_PP modulus), and generate tables indicating quadratic residues and non-residues modulo small factors of that modulus. For the usual 32 or 64 bit cases mpn_mod_34lsub1 gets used. That function exists specifically because 2^24-1 and 2^48-1 have nice sets of prime factors. For other limb sizes it's considered, but if it doesn't have good factors then mpn_mod_1 will be used instead. When mpn_mod_1 is used, the modulus PERFSQR_PP is created from a selection of small primes, chosen to fill PERFSQR_MOD_BITS of a limb, with that bit count chosen so (2*GMP_LIMB_BITS)*2^PERFSQR_MOD_BITS <= GMP_LIMB_MAX, allowing PERFSQR_MOD_IDX in mpn/generic/perfsqr.c to do its calculation within a single limb. In either case primes can be combined to make divisors. The table data then effectively indicates remainders which are quadratic residues mod all the primes. This sort of combining reduces the number of steps needed after mpn_mod_34lsub1 or mpn_mod_1, saving code size and time. Nothing is gained or lost in terms of detections, the same total fraction of non-residues will be identified. Nothing particularly sophisticated is attempted for combining factors to make divisors. This is probably a kind of knapsack problem so it'd be too hard to attempt anything completely general. For the usual 32 and 64 bit limbs we get a good enough result just pairing the biggest and smallest which fit together, repeatedly. Another aim is to get powerful combinations, ie. divisors which identify biggest fraction of non-residues, and have those run first. Again for the usual 32 and 64 bits it seems good enough just to pair for big divisors then sort according to the resulting fraction of non-residues identified. Also in this program, a table sq_res_0x100 of residues modulo 256 is generated. This simply fills bits into limbs of the appropriate build-time GMP_LIMB_BITS each. */ /* Normally we aren't using const in gen*.c programs, so as not to have to bother figuring out if it works, but using it with f_cmp_divisor and f_cmp_fraction avoids warnings from the qsort calls. */ /* Same tests as gmp.h. */ #if defined (__STDC__) \ || defined (__cplusplus) \ || defined (_AIX) \ || defined (__DECC) \ || (defined (__mips) && defined (_SYSTYPE_SVR4)) \ || defined (_MSC_VER) \ || defined (_WIN32) #define HAVE_CONST 1 #endif #if ! HAVE_CONST #define const #endif mpz_t *sq_res_0x100; /* table of limbs */ int nsq_res_0x100; /* elements in sq_res_0x100 array */ int sq_res_0x100_num; /* squares in sq_res_0x100 */ double sq_res_0x100_fraction; /* sq_res_0x100_num / 256 */ int mod34_bits; /* 3*GMP_NUMB_BITS/4 */ int mod_bits; /* bits from PERFSQR_MOD_34 or MOD_PP */ int max_divisor; /* all divisors <= max_divisor */ int max_divisor_bits; /* ceil(log2(max_divisor)) */ double total_fraction; /* of squares */ mpz_t pp; /* product of primes, or 0 if mod_34lsub1 used */ mpz_t pp_norm; /* pp shifted so NUMB high bit set */ mpz_t pp_inverted; /* invert_limb style inverse */ mpz_t mod_mask; /* 2^mod_bits-1 */ char mod34_excuse[128]; /* why mod_34lsub1 not used (if it's not) */ /* raw list of divisors of 2^mod34_bits-1 or pp, just to show in a comment */ struct rawfactor_t { int divisor; int multiplicity; }; struct rawfactor_t *rawfactor; int nrawfactor; /* factors of 2^mod34_bits-1 or pp and associated data, after combining etc */ struct factor_t { int divisor; mpz_t inverse; /* 1/divisor mod 2^mod_bits */ mpz_t mask; /* indicating squares mod divisor */ double fraction; /* squares/total */ }; struct factor_t *factor; int nfactor; /* entries in use in factor array */ int factor_alloc; /* entries allocated to factor array */ int f_cmp_divisor (const void *parg, const void *qarg) { const struct factor_t *p, *q; p = parg; q = qarg; if (p->divisor > q->divisor) return 1; else if (p->divisor < q->divisor) return -1; else return 0; } int f_cmp_fraction (const void *parg, const void *qarg) { const struct factor_t *p, *q; p = parg; q = qarg; if (p->fraction > q->fraction) return 1; else if (p->fraction < q->fraction) return -1; else return 0; } /* Remove array[idx] by copying the remainder down, and adjust narray accordingly. */ #define COLLAPSE_ELEMENT(array, idx, narray) \ do { \ memmove (&(array)[idx], \ &(array)[idx+1], \ ((narray)-((idx)+1)) * sizeof (array[0])); \ (narray)--; \ } while (0) /* return n*2^p mod m */ int mul_2exp_mod (int n, int p, int m) { int i; for (i = 0; i < p; i++) n = (2 * n) % m; return n; } /* return -n mod m */ int neg_mod (int n, int m) { assert (n >= 0 && n < m); return (n == 0 ? 0 : m-n); } /* Set "mask" to a value such that "mask & (1< max_divisor / i) break; multiplicity++; mpz_set (m, q); mpz_tdiv_qr_ui (q, r, m, (unsigned long) i); } while (mpz_sgn (r) == 0); assert (nrawfactor < factor_alloc); rawfactor[nrawfactor].divisor = i; rawfactor[nrawfactor].multiplicity = multiplicity; nrawfactor++; } mpz_clear (m); mpz_clear (q); mpz_clear (r); } if (nrawfactor <= 2) { mpz_t new_pp; sprintf (mod34_excuse, "only %d small factor%s", nrawfactor, nrawfactor == 1 ? "" : "s"); use_pp: /* reset to two limbs of max_divisor, in case the mpn_mod_34lsub1 code tried with just one */ max_divisor = 2*limb_bits; max_divisor_bits = log2_ceil (max_divisor); mpz_init (new_pp); nrawfactor = 0; mod_bits = MIN (numb_bits, limb_bits - max_divisor_bits); /* one copy of each small prime */ mpz_set_ui (pp, 1L); for (i = 3; i <= max_divisor; i++) { if (! isprime (i)) continue; mpz_mul_ui (new_pp, pp, (unsigned long) i); if (mpz_sizeinbase (new_pp, 2) > mod_bits) break; mpz_set (pp, new_pp); assert (nrawfactor < factor_alloc); rawfactor[nrawfactor].divisor = i; rawfactor[nrawfactor].multiplicity = 1; nrawfactor++; } /* Plus an extra copy of one or more of the primes selected, if that still fits in max_divisor and the total in mod_bits. Usually only 3 or 5 will be candidates */ for (i = nrawfactor-1; i >= 0; i--) { if (rawfactor[i].divisor > max_divisor / rawfactor[i].divisor) continue; mpz_mul_ui (new_pp, pp, (unsigned long) rawfactor[i].divisor); if (mpz_sizeinbase (new_pp, 2) > mod_bits) continue; mpz_set (pp, new_pp); rawfactor[i].multiplicity++; } mod_bits = mpz_sizeinbase (pp, 2); mpz_set (pp_norm, pp); while (mpz_sizeinbase (pp_norm, 2) < numb_bits) mpz_add (pp_norm, pp_norm, pp_norm); mpz_preinv_invert (pp_inverted, pp_norm, numb_bits); mpz_clear (new_pp); } /* start the factor array */ for (i = 0; i < nrawfactor; i++) { int j; assert (nfactor < factor_alloc); factor[nfactor].divisor = 1; for (j = 0; j < rawfactor[i].multiplicity; j++) factor[nfactor].divisor *= rawfactor[i].divisor; nfactor++; } combine: /* Combine entries in the factor array. Combine the smallest entry with the biggest one that will fit with it (ie. under max_divisor), then repeat that with the new smallest entry. */ qsort (factor, nfactor, sizeof (factor[0]), f_cmp_divisor); for (i = nfactor-1; i >= 1; i--) { if (factor[i].divisor <= max_divisor / factor[0].divisor) { factor[0].divisor *= factor[i].divisor; COLLAPSE_ELEMENT (factor, i, nfactor); goto combine; } } total_fraction = 1.0; for (i = 0; i < nfactor; i++) { mpz_init (factor[i].inverse); mpz_invert_ui_2exp (factor[i].inverse, (unsigned long) factor[i].divisor, (unsigned long) mod_bits); mpz_init (factor[i].mask); square_mask (factor[i].mask, factor[i].divisor); /* fraction of possible squares */ factor[i].fraction = (double) mpz_popcount (factor[i].mask) / factor[i].divisor; /* total fraction of possible squares */ total_fraction *= factor[i].fraction; } /* best tests first (ie. smallest fraction) */ qsort (factor, nfactor, sizeof (factor[0]), f_cmp_fraction); } void print (int limb_bits, int nail_bits) { int i; mpz_t mhi, mlo; printf ("/* This file generated by gen-psqr.c - DO NOT EDIT. */\n"); printf ("\n"); printf ("#if GMP_LIMB_BITS != %d || GMP_NAIL_BITS != %d\n", limb_bits, nail_bits); printf ("Error, error, this data is for %d bit limb and %d bit nail\n", limb_bits, nail_bits); printf ("#endif\n"); printf ("\n"); printf ("/* Non-zero bit indicates a quadratic residue mod 0x100.\n"); printf (" This test identifies %.2f%% as non-squares (%d/256). */\n", (1.0 - sq_res_0x100_fraction) * 100.0, 0x100 - sq_res_0x100_num); printf ("static const mp_limb_t\n"); printf ("sq_res_0x100[%d] = {\n", nsq_res_0x100); for (i = 0; i < nsq_res_0x100; i++) { printf (" CNST_LIMB(0x"); mpz_out_str (stdout, 16, sq_res_0x100[i]); printf ("),\n"); } printf ("};\n"); printf ("\n"); if (mpz_sgn (pp) != 0) { printf ("/* mpn_mod_34lsub1 not used due to %s */\n", mod34_excuse); printf ("/* PERFSQR_PP = "); } else printf ("/* 2^%d-1 = ", mod34_bits); for (i = 0; i < nrawfactor; i++) { if (i != 0) printf (" * "); printf ("%d", rawfactor[i].divisor); if (rawfactor[i].multiplicity != 1) printf ("^%d", rawfactor[i].multiplicity); } printf (" %s*/\n", mpz_sgn (pp) == 0 ? "... " : ""); printf ("#define PERFSQR_MOD_BITS %d\n", mod_bits); if (mpz_sgn (pp) != 0) { printf ("#define PERFSQR_PP CNST_LIMB(0x"); mpz_out_str (stdout, 16, pp); printf (")\n"); printf ("#define PERFSQR_PP_NORM CNST_LIMB(0x"); mpz_out_str (stdout, 16, pp_norm); printf (")\n"); printf ("#define PERFSQR_PP_INVERTED CNST_LIMB(0x"); mpz_out_str (stdout, 16, pp_inverted); printf (")\n"); } printf ("\n"); mpz_init (mhi); mpz_init (mlo); printf ("/* This test identifies %.2f%% as non-squares. */\n", (1.0 - total_fraction) * 100.0); printf ("#define PERFSQR_MOD_TEST(up, usize) \\\n"); printf (" do { \\\n"); printf (" mp_limb_t r; \\\n"); if (mpz_sgn (pp) != 0) printf (" PERFSQR_MOD_PP (r, up, usize); \\\n"); else printf (" PERFSQR_MOD_34 (r, up, usize); \\\n"); for (i = 0; i < nfactor; i++) { printf (" \\\n"); printf (" /* %5.2f%% */ \\\n", (1.0 - factor[i].fraction) * 100.0); printf (" PERFSQR_MOD_%d (r, CNST_LIMB(%2d), CNST_LIMB(0x", factor[i].divisor <= limb_bits ? 1 : 2, factor[i].divisor); mpz_out_str (stdout, 16, factor[i].inverse); printf ("), \\\n"); printf (" CNST_LIMB(0x"); if ( factor[i].divisor <= limb_bits) { mpz_out_str (stdout, 16, factor[i].mask); } else { mpz_tdiv_r_2exp (mlo, factor[i].mask, (unsigned long) limb_bits); mpz_tdiv_q_2exp (mhi, factor[i].mask, (unsigned long) limb_bits); mpz_out_str (stdout, 16, mhi); printf ("), CNST_LIMB(0x"); mpz_out_str (stdout, 16, mlo); } printf (")); \\\n"); } printf (" } while (0)\n"); printf ("\n"); printf ("/* Grand total sq_res_0x100 and PERFSQR_MOD_TEST, %.2f%% non-squares. */\n", (1.0 - (total_fraction * 44.0/256.0)) * 100.0); printf ("\n"); printf ("/* helper for tests/mpz/t-perfsqr.c */\n"); printf ("#define PERFSQR_DIVISORS { 256,"); for (i = 0; i < nfactor; i++) printf (" %d,", factor[i].divisor); printf (" }\n"); mpz_clear (mhi); mpz_clear (mlo); } int main (int argc, char *argv[]) { int limb_bits, nail_bits; if (argc != 3) { fprintf (stderr, "Usage: gen-psqr \n"); exit (1); } limb_bits = atoi (argv[1]); nail_bits = atoi (argv[2]); if (limb_bits <= 0 || nail_bits < 0 || nail_bits >= limb_bits) { fprintf (stderr, "Invalid limb/nail bits: %d %d\n", limb_bits, nail_bits); exit (1); } generate_sq_res_0x100 (limb_bits); generate_mod (limb_bits, nail_bits); print (limb_bits, nail_bits); return 0; } gcl-2.6.14/gmp4/gen-fac.c0000644000175000017500000001656414360276512013322 0ustar cammcamm/* Generate data for combinatorics: fac_ui, bin_uiui, ... Copyright 2002, 2011-2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "bootstrap.c" int mpz_remove_twos (mpz_t x) { mp_bitcnt_t r = mpz_scan1(x, 0); mpz_tdiv_q_2exp (x, x, r); return r; } /* returns 0 on success */ int gen_consts (int numb, int nail, int limb) { mpz_t x, mask, y, last; unsigned long a, b; unsigned long ofl, ofe; printf ("/* This file is automatically generated by gen-fac.c */\n\n"); printf ("#if GMP_NUMB_BITS != %d\n", numb); printf ("Error , error this data is for %d GMP_NUMB_BITS only\n", numb); printf ("#endif\n"); #if 0 printf ("#if GMP_LIMB_BITS != %d\n", limb); printf ("Error , error this data is for %d GMP_LIMB_BITS only\n", limb); printf ("#endif\n"); #endif printf ("/* This table is 0!,1!,2!,3!,...,n! where n! has <= GMP_NUMB_BITS bits */\n"); printf ("#define ONE_LIMB_FACTORIAL_TABLE CNST_LIMB(0x1),CNST_LIMB(0x1"); mpz_init_set_ui (x, 1); mpz_init (last); for (b = 2;; b++) { mpz_mul_ui (x, x, b); /* so b!=a */ if (mpz_sizeinbase (x, 2) > numb) break; printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); printf ("\n/* This table is 0!,1!,2!/2,3!/2,...,n!/2^sn where n!/2^sn is an */\n"); printf ("/* odd integer for each n, and n!/2^sn has <= GMP_NUMB_BITS bits */\n"); printf ("#define ONE_LIMB_ODD_FACTORIAL_TABLE CNST_LIMB(0x1),CNST_LIMB(0x1),CNST_LIMB(0x1"); mpz_set_ui (x, 1); for (b = 3;; b++) { for (a = b; (a & 1) == 0; a >>= 1); mpz_swap (last, x); mpz_mul_ui (x, last, a); if (mpz_sizeinbase (x, 2) > numb) break; printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); printf ("#define ODD_FACTORIAL_TABLE_MAX CNST_LIMB(0x"); mpz_out_str (stdout, 16, last); printf (")\n"); ofl = b - 1; printf ("#define ODD_FACTORIAL_TABLE_LIMIT (%lu)\n", ofl); mpz_init2 (mask, numb); mpz_setbit (mask, numb); mpz_sub_ui (mask, mask, 1); printf ("\n/* Previous table, continued, values modulo 2^GMP_NUMB_BITS */\n"); printf ("#define ONE_LIMB_ODD_FACTORIAL_EXTTABLE CNST_LIMB(0x"); mpz_and (x, x, mask); mpz_out_str (stdout, 16, x); mpz_init (y); mpz_bin_uiui (y, b, b/2); b++; for (;; b++) { for (a = b; (a & 1) == 0; a >>= 1); if (a == b) { mpz_divexact_ui (y, y, a/2+1); mpz_mul_ui (y, y, a); } else mpz_mul_2exp (y, y, 1); if (mpz_sizeinbase (y, 2) > numb) break; mpz_mul_ui (x, x, a); mpz_and (x, x, mask); printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); ofe = b - 1; printf ("#define ODD_FACTORIAL_EXTTABLE_LIMIT (%lu)\n", ofe); printf ("\n/* This table is 1!!,3!!,...,(2n+1)!! where (2n+1)!! has <= GMP_NUMB_BITS bits */\n"); printf ("#define ONE_LIMB_ODD_DOUBLEFACTORIAL_TABLE CNST_LIMB(0x1"); mpz_set_ui (x, 1); for (b = 3;; b+=2) { mpz_swap (last, x); mpz_mul_ui (x, last, b); if (mpz_sizeinbase (x, 2) > numb) break; printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); printf ("#define ODD_DOUBLEFACTORIAL_TABLE_MAX CNST_LIMB(0x"); mpz_out_str (stdout, 16, last); printf (")\n"); printf ("#define ODD_DOUBLEFACTORIAL_TABLE_LIMIT (%lu)\n", b - 2); printf ("\n/* This table x_1, x_2,... contains values s.t. x_n^n has <= GMP_NUMB_BITS bits */\n"); printf ("#define NTH_ROOT_NUMB_MASK_TABLE (GMP_NUMB_MASK"); for (b = 2;b <= 8; b++) { mpz_root (x, mask, b); printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); mpz_add_ui (mask, mask, 1); printf ("\n/* This table contains inverses of odd factorials, modulo 2^GMP_NUMB_BITS */\n"); printf ("\n/* It begins with (2!/2)^-1=1 */\n"); printf ("#define ONE_LIMB_ODD_FACTORIAL_INVERSES_TABLE CNST_LIMB(0x1"); mpz_set_ui (x, 1); for (b = 3;b <= ofe - 2; b++) { for (a = b; (a & 1) == 0; a >>= 1); mpz_mul_ui (x, x, a); mpz_invert (y, x, mask); printf ("),CNST_LIMB(0x"); mpz_out_str (stdout, 16, y); } printf (")\n"); ofe = (ofe / 16 + 1) * 16; printf ("\n/* This table contains 2n-popc(2n) for small n */\n"); printf ("\n/* It begins with 2-1=1 (n=1) */\n"); printf ("#define TABLE_2N_MINUS_POPC_2N 1"); for (b = 4; b <= ofe; b += 2) { mpz_set_ui (x, b); printf (",%lu",b - mpz_popcount (x)); } printf ("\n"); printf ("#define TABLE_LIMIT_2N_MINUS_POPC_2N %lu\n", ofe + 1); ofl = (ofl + 1) / 2; printf ("#define ODD_CENTRAL_BINOMIAL_OFFSET (%lu)\n", ofl); printf ("\n/* This table contains binomial(2k,k)/2^t */\n"); printf ("\n/* It begins with ODD_CENTRAL_BINOMIAL_TABLE_MIN */\n"); printf ("#define ONE_LIMB_ODD_CENTRAL_BINOMIAL_TABLE "); for (b = ofl;; b++) { mpz_bin_uiui (x, 2 * b, b); mpz_remove_twos (x); if (mpz_sizeinbase (x, 2) > numb) break; if (b != ofl) printf ("),"); printf("CNST_LIMB(0x"); mpz_out_str (stdout, 16, x); } printf (")\n"); ofe = b - 1; printf ("#define ODD_CENTRAL_BINOMIAL_TABLE_LIMIT (%lu)\n", ofe); printf ("\n/* This table contains the inverses of elements in the previous table. */\n"); printf ("#define ONE_LIMB_ODD_CENTRAL_BINOMIAL_INVERSE_TABLE CNST_LIMB(0x"); for (b = ofl; b <= ofe; b++) { mpz_bin_uiui (x, 2 * b, b); mpz_remove_twos (x); mpz_invert (x, x, mask); mpz_out_str (stdout, 16, x); if (b != ofe) printf ("),CNST_LIMB(0x"); } printf (")\n"); printf ("\n/* This table contains the values t in the formula binomial(2k,k)/2^t */\n"); printf ("#define CENTRAL_BINOMIAL_2FAC_TABLE "); for (b = ofl; b <= ofe; b++) { mpz_bin_uiui (x, 2 * b, b); printf ("%d", mpz_remove_twos (x)); if (b != ofe) printf (","); } printf ("\n"); return 0; } int main (int argc, char *argv[]) { int nail_bits, limb_bits, numb_bits; if (argc != 3) { fprintf (stderr, "Usage: gen-fac_ui limbbits nailbits\n"); exit (1); } limb_bits = atoi (argv[1]); nail_bits = atoi (argv[2]); numb_bits = limb_bits - nail_bits; if (limb_bits < 2 || nail_bits < 0 || numb_bits < 1) { fprintf (stderr, "Invalid limb/nail bits %d,%d\n", limb_bits, nail_bits); exit (1); } gen_consts (numb_bits, nail_bits, limb_bits); return 0; } gcl-2.6.14/gmp4/rand/0000755000175000017500000000000014360276512012566 5ustar cammcammgcl-2.6.14/gmp4/rand/randmt.c0000644000175000017500000003662114360276512014227 0ustar cammcamm/* Mersenne Twister pseudo-random number generator functions. THE FUNCTIONS IN THIS FILE ARE FOR INTERNAL USE ONLY. THEY'RE ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. Copyright 2002, 2003, 2006 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" #include "randmt.h" /* This code implements the Mersenne Twister pseudorandom number generator by Takuji Nishimura and Makoto Matsumoto. The buffer initialization function is different in order to permit seeds greater than 2^32-1. This file contains a special __gmp_randinit_mt_noseed which excludes the seeding function from the gmp_randfnptr_t routines. This is for use by mpn_random and mpn_random2 on the global random generator. MT seeding uses mpz functions, and we don't want mpn routines dragging mpz functions into the link. */ /* Default seed to use when the generator is not initialized. */ #define DEFAULT_SEED 5489 /* was 4357 */ /* Tempering masks. */ #define MASK_1 0x9D2C5680 #define MASK_2 0xEFC60000 /* Initial state of buffer when initialized with default seed. */ static const gmp_uint_least32_t default_state[N] = { 0xD247B233,0x9E5AA8F1,0x0FFA981B,0x9DCB0980,0x74200F2B,0xA576D044, 0xE9F05ADF,0x1538BFF5,0x59818BBF,0xCF9E58D8,0x09FCE032,0x6A1C663F, 0x5116E78A,0x69B3E0FA,0x6D92D665,0xD0A8BE98,0xF669B734,0x41AC1B68, 0x630423F1,0x4B8D6B8A,0xC2C46DD7,0x5680747D,0x43703E8F,0x3B6103D2, 0x49E5EB3F,0xCBDAB4C1,0x9C988E23,0x747BEE0B,0x9111E329,0x9F031B5A, 0xECCA71B9,0x2AFE4EF8,0x8421C7ED,0xAC89AFF1,0xAED90DF3,0x2DD74F01, 0x14906A13,0x75873FA9,0xFF83F877,0x5028A0C9,0x11B4C41D,0x7CAEDBC4, 0x8672D0A7,0x48A7C109,0x8320E59F,0xBC0B3D5F,0x75A30886,0xF9E0D128, 0x41AF7580,0x239BB94D,0xC67A3C81,0x74EEBD6E,0xBC02B53C,0x727EA449, 0x6B8A2806,0x5853B0DA,0xBDE032F4,0xCE234885,0x320D6145,0x48CC053F, 0x00DBC4D2,0xD55A2397,0xE1059B6F,0x1C3E05D1,0x09657C64,0xD07CB661, 0x6E982E34,0x6DD1D777,0xEDED1071,0xD79DFD65,0xF816DDCE,0xB6FAF1E4, 0x1C771074,0x311835BD,0x18F952F7,0xF8F40350,0x4ECED354,0x7C8AC12B, 0x31A9994D,0x4FD47747,0xDC227A23,0x6DFAFDDF,0x6796E748,0x0C6F634F, 0xF992FA1D,0x4CF670C9,0x067DFD31,0xA7A3E1A5,0x8CD7D9DF,0x972CCB34, 0x67C82156,0xD548F6A8,0x045CEC21,0xF3240BFB,0xDEF656A7,0x43DE08C5, 0xDAD1F92F,0x3726C56B,0x1409F19A,0x942FD147,0xB926749C,0xADDC31B8, 0x53D0D869,0xD1BA52FE,0x6722DF8C,0x22D95A74,0x7DC1B52A,0x1DEC6FD5, 0x7262874D,0x0A725DC9,0xE6A8193D,0xA052835A,0xDC9AD928,0xE59EBB90, 0x70DBA9FF,0xD612749D,0x5A5A638C,0x6086EC37,0x2A579709,0x1449EA3A, 0xBC8E3C06,0x2F900666,0xFBE74FD1,0x6B35B911,0xF8335008,0xEF1E979D, 0x738AB29D,0xA2DC0FDC,0x7696305D,0xF5429DAC,0x8C41813B,0x8073E02E, 0xBEF83CCD,0x7B50A95A,0x05EE5862,0x00829ECE,0x8CA1958C,0xBE4EA2E2, 0x4293BB73,0x656F7B23,0x417316D8,0x4467D7CF,0x2200E63B,0x109050C8, 0x814CBE47,0x36B1D4A8,0x36AF9305,0x308327B3,0xEBCD7344,0xA738DE27, 0x5A10C399,0x4142371D,0x64A18528,0x0B31E8B2,0x641057B9,0x6AFC363B, 0x108AD953,0x9D4DA234,0x0C2D9159,0x1C8A1A1F,0x310C66BA,0x87AA1070, 0xDAC832FF,0x0A433422,0x7AF15812,0x2D8D9BD0,0x995A25E9,0x25326CAC, 0xA34384DB,0x4C8421CC,0x4F0315EC,0x29E8649E,0xA7732D6F,0x2E94D3E3, 0x7D98A340,0x397C4D74,0x659DB4DE,0x747D4E9A,0xD9DB8435,0x4659DBE9, 0x313E6DC5,0x29D104DC,0x9F226CBA,0x452F18B0,0xD0BC5068,0x844CA299, 0x782B294E,0x4AE2EB7B,0xA4C475F8,0x70A81311,0x4B3E8BCC,0x7E20D4BA, 0xABCA33C9,0x57BE2960,0x44F9B419,0x2E567746,0x72EB757A,0x102CC0E8, 0xB07F32B9,0xD0DABD59,0xBA85AD6B,0xF3E20667,0x98D77D81,0x197AFA47, 0x518EE9AC,0xE10CE5A2,0x01CF2C2A,0xD3A3AF3D,0x16DDFD65,0x669232F8, 0x1C50A301,0xB93D9151,0x9354D3F4,0x847D79D0,0xD5FE2EC6,0x1F7B0610, 0xFA6B90A5,0xC5879041,0x2E7DC05E,0x423F1F32,0xEF623DDB,0x49C13280, 0x98714E92,0xC7B6E4AD,0xC4318466,0x0737F312,0x4D3C003F,0x9ACC1F1F, 0x5F1C926D,0x085FA771,0x185A83A2,0xF9AA159D,0x0B0B0132,0xF98E7A43, 0xCD9EBDBE,0x0190CB29,0x10D93FB6,0x3B8A4D97,0x66A65A41,0xE43E766F, 0x77BE3C41,0xB9686364,0xCB36994D,0x6846A287,0x567E77F7,0x36178DD8, 0xBDE6B1F2,0xB6EFDC64,0x82950324,0x42053F47,0xC09BE51C,0x0942D762, 0x35F92C7F,0x367DEC61,0x6EE3D983,0xDBAAF78A,0x265D2C47,0x8EB4BF5C, 0x33B232D7,0xB0137E77,0x373C39A7,0x8D2B2E76,0xC7510F01,0x50F9E032, 0x7B1FDDDB,0x724C2AAE,0xB10ECB31,0xCCA3D1B8,0x7F0BCF10,0x4254BBBD, 0xE3F93B97,0x2305039B,0x53120E22,0x1A2F3B9A,0x0FDDBD97,0x0118561E, 0x0A798E13,0x9E0B3ACD,0xDB6C9F15,0xF512D0A2,0x9E8C3A28,0xEE2184AE, 0x0051EC2F,0x2432F74F,0xB0AA66EA,0x55128D88,0xF7D83A38,0x4DAE8E82, 0x3FDC98D6,0x5F0BD341,0x7244BE1D,0xC7B48E78,0x2D473053,0x43892E20, 0xBA0F1F2A,0x524D4895,0x2E10BCB1,0x4C372D81,0x5C3E50CD,0xCF61CC2E, 0x931709AB,0x81B3AEFC,0x39E9405E,0x7FFE108C,0x4FBB3FF8,0x06ABE450, 0x7F5BF51E,0xA4E3CDFD,0xDB0F6C6F,0x159A1227,0x3B9FED55,0xD20B6F7F, 0xFBE9CC83,0x64856619,0xBF52B8AF,0x9D7006B0,0x71165BC6,0xAE324AEE, 0x29D27F2C,0x794C2086,0x74445CE2,0x782915CC,0xD4CE6886,0x3289AE7C, 0x53DEF297,0x4185F7ED,0x88B72400,0x3C09DC11,0xBCE3AAB6,0x6A75934A, 0xB267E399,0x000DF1BF,0x193BA5E2,0xFA3E1977,0x179E14F6,0x1EEDE298, 0x691F0B06,0xB84F78AC,0xC1C15316,0xFFFF3AD6,0x0B457383,0x518CD612, 0x05A00F3E,0xD5B7D275,0x4C5ECCD7,0xE02CD0BE,0x5558E9F2,0x0C89BBF0, 0xA3D96227,0x2832D2B2,0xF667B897,0xD4556554,0xF9D2F01F,0xFA1E3FAE, 0x52C2E1EE,0xE5451F31,0x7E849729,0xDABDB67A,0x54BF5E7E,0xF831C271, 0x5F1A17E3,0x9D140AFE,0x92741C47,0x48CFABCE,0x9CBBE477,0x9C3EE57F, 0xB07D4C39,0xCC21BCE2,0x697708B1,0x58DA2A6B,0x2370DB16,0x6E641948, 0xACC5BD52,0x868F24CC,0xCA1DB0F5,0x4CADA492,0x3F443E54,0xC4A4D5E9, 0xF00AD670,0xE93C86E0,0xFE90651A,0xDDE532A3,0xA66458DF,0xAB7D7151, 0x0E2E775F,0xC9109F99,0x8D96D59F,0x73CEF14C,0xC74E88E9,0x02712DC0, 0x04F41735,0x2E5914A2,0x59F4B2FB,0x0287FC83,0x80BC0343,0xF6B32559, 0xC74178D4,0xF1D99123,0x383CCC07,0xACC0637D,0x0863A548,0xA6FCAC85, 0x2A13EFF0,0xAF2EEDB1,0x41E72750,0xE0C6B342,0x5DA22B46,0x635559E0, 0xD2EA40AC,0x10AA98C0,0x19096497,0x112C542B,0x2C85040C,0xA868E7D0, 0x6E260188,0xF596D390,0xC3BB5D7A,0x7A2AA937,0xDFD15032,0x6780AE3B, 0xDB5F9CD8,0x8BD266B0,0x7744AF12,0xB463B1B0,0x589629C9,0xE30DBC6E, 0x880F5569,0x209E6E16,0x9DECA50C,0x02987A57,0xBED3EA57,0xD3A678AA, 0x70DD030D,0x0CFD9C5D,0x92A18E99,0xF5740619,0x7F6F0A7D,0x134CAF9A, 0x70F5BAE4,0x23DCA7B5,0x4D788FCD,0xC7F07847,0xBCF77DA1,0x9071D568, 0xFC627EA1,0xAE004B77,0x66B54BCB,0x7EF2DAAC,0xDCD5AC30,0xB9BDF730, 0x505A97A7,0x9D881FD3,0xADB796CC,0x94A1D202,0x97535D7F,0x31EC20C0, 0xB1887A98,0xC1475069,0xA6F73AF3,0x71E4E067,0x46A569DE,0xD2ADE430, 0x6F0762C7,0xF50876F4,0x53510542,0x03741C3E,0x53502224,0xD8E54D60, 0x3C44AB1A,0x34972B46,0x74BFA89D,0xD7D768E0,0x37E605DC,0xE13D1BDF, 0x5051C421,0xB9E057BE,0xB717A14C,0xA1730C43,0xB99638BE,0xB5D5F36D, 0xE960D9EA,0x6B1388D3,0xECB6D3B6,0xBDBE8B83,0x2E29AFC5,0x764D71EC, 0x4B8F4F43,0xC21DDC00,0xA63F657F,0x82678130,0xDBF535AC,0xA594FC58, 0x942686BC,0xBD9B657B,0x4A0F9B61,0x44FF184F,0x38E10A2F,0x61910626, 0x5E247636,0x7106D137,0xC62802F0,0xBD1D1F00,0x7CC0DCB2,0xED634909, 0xDC13B24E,0x9799C499,0xD77E3D6A,0x14773B68,0x967A4FB7,0x35EECFB1, 0x2A5110B8,0xE2F0AF94,0x9D09DEA5,0x20255D27,0x5771D34B,0xE1089EE4, 0x246F330B,0x8F7CAEE5,0xD3064712,0x75CAFBEE,0xB94F7028,0xED953666, 0x5D1975B4,0x5AF81271,0x13BE2025,0x85194659,0x30805331,0xEC9D46C0, 0xBC027C36,0x2AF84188,0xC2141B80,0xC02B1E4A,0x04D36177,0xFC50E9D7, 0x39CE79DA,0x917E0A00,0xEF7A0BF4,0xA98BD8D1,0x19424DD2,0x9439DF1F, 0xC42AF746,0xADDBE83E,0x85221F0D,0x45563E90,0x9095EC52,0x77887B25, 0x8AE46064,0xBD43B71A,0xBB541956,0x7366CF9D,0xEE8E1737,0xB5A727C9, 0x5076B3E7,0xFC70BACA,0xCE135B75,0xC4E91AA3,0xF0341911,0x53430C3F, 0x886B0824,0x6BB5B8B7,0x33E21254,0xF193B456,0x5B09617F,0x215FFF50, 0x48D97EF1,0x356479AB,0x6EA9DDC4,0x0D352746,0xA2F5CE43,0xB226A1B3, 0x1329EA3C,0x7A337CC2,0xB5CCE13D,0x563E3B5B,0x534E8E8F,0x561399C9, 0xE1596392,0xB0F03125,0x4586645B,0x1F371847,0x94EAABD1,0x41F97EDD, 0xE3E5A39B,0x71C774E2,0x507296F4,0x5960133B,0x7852C494,0x3F5B2691, 0xA3F87774,0x5A7AF89E,0x17DA3F28,0xE9D9516D,0xFCC1C1D5,0xE4618628, 0x04081047,0xD8E4DB5F,0xDC380416,0x8C4933E2,0x95074D53,0xB1B0032D, 0xCC8102EA,0x71641243,0x98D6EB6A,0x90FEC945,0xA0914345,0x6FAB037D, 0x70F49C4D,0x05BF5B0E,0x927AAF7F,0xA1940F61,0xFEE0756F,0xF815369F, 0x5C00253B,0xF2B9762F,0x4AEB3CCC,0x1069F386,0xFBA4E7B9,0x70332665, 0x6BCA810E,0x85AB8058,0xAE4B2B2F,0x9D120712,0xBEE8EACB,0x776A1112 }; void __gmp_mt_recalc_buffer (gmp_uint_least32_t mt[]) { gmp_uint_least32_t y; int kk; for (kk = 0; kk < N - M; kk++) { y = (mt[kk] & 0x80000000) | (mt[kk + 1] & 0x7FFFFFFF); mt[kk] = mt[kk + M] ^ (y >> 1) ^ ((y & 0x01) != 0 ? MATRIX_A : 0); } for (; kk < N - 1; kk++) { y = (mt[kk] & 0x80000000) | (mt[kk + 1] & 0x7FFFFFFF); mt[kk] = mt[kk - (N - M)] ^ (y >> 1) ^ ((y & 0x01) != 0 ? MATRIX_A : 0); } y = (mt[N - 1] & 0x80000000) | (mt[0] & 0x7FFFFFFF); mt[N - 1] = mt[M - 1] ^ (y >> 1) ^ ((y & 0x01) != 0 ? MATRIX_A : 0); } /* Get nbits bits of output from the generator into dest. Note that Mersenne Twister is designed to produce outputs in 32-bit words. */ void __gmp_randget_mt (gmp_randstate_t rstate, mp_ptr dest, unsigned long int nbits) { gmp_uint_least32_t y; int rbits; mp_size_t i; mp_size_t nlimbs; int *pmti; gmp_uint_least32_t *mt; pmti = &((gmp_rand_mt_struct *) RNG_STATE (rstate))->mti; mt = ((gmp_rand_mt_struct *) RNG_STATE (rstate))->mt; nlimbs = nbits / GMP_NUMB_BITS; rbits = nbits % GMP_NUMB_BITS; #define NEXT_RANDOM \ do \ { \ if (*pmti >= N) \ { \ __gmp_mt_recalc_buffer (mt); \ *pmti = 0; \ } \ y = mt[(*pmti)++]; \ y ^= (y >> 11); \ y ^= (y << 7) & MASK_1; \ y ^= (y << 15) & MASK_2; \ y ^= (y >> 18); \ } \ while (0) /* Handle the common cases of 32- or 64-bit limbs with fast, optimized routines, and the rest of cases with a general routine. In all cases, no more than 31 bits are rejected for the last limb so that every version of the code is consistent with the others. */ #if (GMP_NUMB_BITS == 32) for (i = 0; i < nlimbs; i++) { NEXT_RANDOM; dest[i] = (mp_limb_t) y; } if (rbits) { NEXT_RANDOM; dest[nlimbs] = (mp_limb_t) (y & ~(ULONG_MAX << rbits)); } #else /* GMP_NUMB_BITS != 32 */ #if (GMP_NUMB_BITS == 64) for (i = 0; i < nlimbs; i++) { NEXT_RANDOM; dest[i] = (mp_limb_t) y; NEXT_RANDOM; dest[i] |= (mp_limb_t) y << 32; } if (rbits) { if (rbits < 32) { NEXT_RANDOM; dest[nlimbs] = (mp_limb_t) (y & ~(ULONG_MAX << rbits)); } else { NEXT_RANDOM; dest[nlimbs] = (mp_limb_t) y; if (rbits > 32) { NEXT_RANDOM; dest[nlimbs] |= ((mp_limb_t) (y & ~(ULONG_MAX << (rbits-32)))) << 32; } } } #else /* GMP_NUMB_BITS != 64 */ { /* Fall back to a general algorithm. This algorithm works by keeping a pool of up to 64 bits (2 outputs from MT) acting as a shift register from which bits are consumed as needed. Bits are consumed using the LSB bits of bitpool_l, and inserted via bitpool_h and shifted to the right place. */ gmp_uint_least32_t bitpool_h = 0; gmp_uint_least32_t bitpool_l = 0; int bits_in_pool = 0; /* Holds number of valid bits in the pool. */ int bits_to_fill; /* Holds total number of bits to put in destination. */ int bitidx; /* Holds the destination bit position. */ mp_size_t nlimbs2; /* Number of whole+partial limbs to fill. */ nlimbs2 = nlimbs + (rbits != 0); for (i = 0; i < nlimbs2; i++) { bitidx = 0; if (i < nlimbs) bits_to_fill = GMP_NUMB_BITS; else bits_to_fill = rbits; dest[i] = CNST_LIMB (0); while (bits_to_fill >= 32) /* Process whole 32-bit blocks first. */ { if (bits_in_pool < 32) /* Need more bits. */ { /* 64-bit right shift. */ NEXT_RANDOM; bitpool_h = y; bitpool_l |= (bitpool_h << bits_in_pool) & 0xFFFFFFFF; if (bits_in_pool == 0) bitpool_h = 0; else bitpool_h >>= 32 - bits_in_pool; bits_in_pool += 32; /* We've got 32 more bits. */ } /* Fill a 32-bit chunk. */ dest[i] |= ((mp_limb_t) bitpool_l) << bitidx; bitpool_l = bitpool_h; bits_in_pool -= 32; bits_to_fill -= 32; bitidx += 32; } /* Cover the case where GMP_NUMB_BITS is not a multiple of 32. */ if (bits_to_fill != 0) { if (bits_in_pool < bits_to_fill) { NEXT_RANDOM; bitpool_h = y; bitpool_l |= (bitpool_h << bits_in_pool) & 0xFFFFFFFF; if (bits_in_pool == 0) bitpool_h = 0; else bitpool_h >>= 32 - bits_in_pool; bits_in_pool += 32; } dest[i] |= (((mp_limb_t) bitpool_l & ~(~CNST_LIMB (0) << bits_to_fill)) << bitidx); bitpool_l = ((bitpool_l >> bits_to_fill) | (bitpool_h << (32 - bits_to_fill))) & 0xFFFFFFFF; bitpool_h >>= bits_to_fill; bits_in_pool -= bits_to_fill; } } } #endif /* GMP_NUMB_BITS != 64 */ #endif /* GMP_NUMB_BITS != 32 */ } void __gmp_randclear_mt (gmp_randstate_t rstate) { (*__gmp_free_func) ((void *) RNG_STATE (rstate), ALLOC (rstate->_mp_seed) * GMP_LIMB_BYTES); } void __gmp_randiset_mt (gmp_randstate_ptr, gmp_randstate_srcptr); static const gmp_randfnptr_t Mersenne_Twister_Generator_Noseed = { NULL, __gmp_randget_mt, __gmp_randclear_mt, __gmp_randiset_mt }; void __gmp_randiset_mt (gmp_randstate_ptr dst, gmp_randstate_srcptr src) { const mp_size_t sz = ((sizeof (gmp_rand_mt_struct) - 1) / GMP_LIMB_BYTES) + 1; gmp_rand_mt_struct *dstp, *srcp; mp_size_t i; /* Set the generator functions. */ RNG_FNPTR (dst) = (void *) &Mersenne_Twister_Generator_Noseed; /* Allocate the MT-specific state. */ dstp = (gmp_rand_mt_struct *) __GMP_ALLOCATE_FUNC_LIMBS (sz); RNG_STATE (dst) = (mp_ptr) dstp; ALLOC (dst->_mp_seed) = sz; /* Initialize alloc field to placate Camm. */ /* Copy state. */ srcp = (gmp_rand_mt_struct *) RNG_STATE (src); for (i = 0; i < N; i++) dstp->mt[i] = srcp->mt[i]; dstp->mti = srcp->mti; } void __gmp_randinit_mt_noseed (gmp_randstate_ptr dst) { const mp_size_t sz = ((sizeof (gmp_rand_mt_struct) - 1) / GMP_LIMB_BYTES) + 1; gmp_rand_mt_struct *dstp; mp_size_t i; /* Set the generator functions. */ RNG_FNPTR (dst) = (void *) &Mersenne_Twister_Generator_Noseed; /* Allocate the MT-specific state. */ dstp = (gmp_rand_mt_struct *) __GMP_ALLOCATE_FUNC_LIMBS (sz); RNG_STATE (dst) = (mp_ptr) dstp; ALLOC (dst->_mp_seed) = sz; /* Initialize alloc field to placate Camm. */ /* Set state for default seed. */ for (i = 0; i < N; i++) dstp->mt[i] = default_state[i]; dstp->mti = WARM_UP % N; } gcl-2.6.14/gmp4/rand/randmt.h0000644000175000017500000000317614360276512014233 0ustar cammcamm/* Mersenne Twister pseudo-random number generator defines. Copyright 2002, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* Number of extractions used to warm the buffer up. */ #define WARM_UP 2000 /* Period parameters. */ #define N 624 #define M 397 #define MATRIX_A 0x9908B0DF /* Constant vector a. */ /* State structure for MT. */ typedef struct { gmp_uint_least32_t mt[N]; /* State array. */ int mti; /* Index of current value. */ } gmp_rand_mt_struct; void __gmp_mt_recalc_buffer (gmp_uint_least32_t *); void __gmp_randget_mt (gmp_randstate_t, mp_ptr, unsigned long int); void __gmp_randclear_mt (gmp_randstate_t); void __gmp_randiset_mt (gmp_randstate_ptr, gmp_randstate_srcptr); gcl-2.6.14/gmp4/rand/randmts.c0000644000175000017500000001061514360276512014405 0ustar cammcamm/* Mersenne Twister pseudo-random number generator functions. Copyright 2002, 2003, 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "randmt.h" /* Calculate (b^e) mod (2^n-k) for e=1074888996, n=19937 and k=20023, needed by the seeding function below. */ static void mangle_seed (mpz_ptr r) { mpz_t t, b; unsigned long e = 0x40118124; unsigned long bit = 0x20000000; mpz_init2 (t, 19937L); mpz_init_set (b, r); do { mpz_mul (r, r, r); reduce: for (;;) { mpz_tdiv_q_2exp (t, r, 19937L); if (SIZ (t) == 0) break; mpz_tdiv_r_2exp (r, r, 19937L); mpz_addmul_ui (r, t, 20023L); } if ((e & bit) != 0) { e ^= bit; mpz_mul (r, r, b); goto reduce; } bit >>= 1; } while (bit != 0); mpz_clear (t); mpz_clear (b); } /* Seeding function. Uses powering modulo a non-Mersenne prime to obtain a permutation of the input seed space. The modulus is 2^19937-20023, which is probably prime. The power is 1074888996. In order to avoid seeds 0 and 1 generating invalid or strange output, the input seed is first manipulated as follows: seed1 = seed mod (2^19937-20027) + 2 so that seed1 lies between 2 and 2^19937-20026 inclusive. Then the powering is performed as follows: seed2 = (seed1^1074888996) mod (2^19937-20023) and then seed2 is used to bootstrap the buffer. This method aims to give guarantees that: a) seed2 will never be zero, b) seed2 will very seldom have a very low population of ones in its binary representation, and c) every seed between 0 and 2^19937-20028 (inclusive) will yield a different sequence. CAVEATS: The period of the seeding function is 2^19937-20027. This means that with seeds 2^19937-20027, 2^19937-20026, ... the exact same sequences are obtained as with seeds 0, 1, etc.; it also means that seed -1 produces the same sequence as seed 2^19937-20028, etc. */ static void randseed_mt (gmp_randstate_t rstate, mpz_srcptr seed) { int i; size_t cnt; gmp_rand_mt_struct *p; mpz_t mod; /* Modulus. */ mpz_t seed1; /* Intermediate result. */ p = (gmp_rand_mt_struct *) RNG_STATE (rstate); mpz_init2 (mod, 19937L); mpz_init2 (seed1, 19937L); mpz_setbit (mod, 19937L); mpz_sub_ui (mod, mod, 20027L); mpz_mod (seed1, seed, mod); /* Reduce `seed' modulo `mod'. */ mpz_clear (mod); mpz_add_ui (seed1, seed1, 2L); /* seed1 is now ready. */ mangle_seed (seed1); /* Perform the mangling by powering. */ /* Copy the last bit into bit 31 of mt[0] and clear it. */ p->mt[0] = (mpz_tstbit (seed1, 19936L) != 0) ? 0x80000000 : 0; mpz_clrbit (seed1, 19936L); /* Split seed1 into N-1 32-bit chunks. */ mpz_export (&p->mt[1], &cnt, -1, sizeof (p->mt[1]), 0, 8 * sizeof (p->mt[1]) - 32, seed1); mpz_clear (seed1); cnt++; ASSERT (cnt <= N); while (cnt < N) p->mt[cnt++] = 0; /* Warm the generator up if necessary. */ if (WARM_UP != 0) for (i = 0; i < WARM_UP / N; i++) __gmp_mt_recalc_buffer (p->mt); p->mti = WARM_UP % N; } static const gmp_randfnptr_t Mersenne_Twister_Generator = { randseed_mt, __gmp_randget_mt, __gmp_randclear_mt, __gmp_randiset_mt }; /* Initialize MT-specific data. */ void gmp_randinit_mt (gmp_randstate_t rstate) { __gmp_randinit_mt_noseed (rstate); RNG_FNPTR (rstate) = (void *) &Mersenne_Twister_Generator; } gcl-2.6.14/gmp4/rand/rand.c0000644000175000017500000000273214360276512013662 0ustar cammcamm/* gmp_randinit (state, algorithm, ...) -- Initialize a random state. Copyright 1999-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include "gmp.h" #include "gmp-impl.h" void gmp_randinit (gmp_randstate_t rstate, gmp_randalg_t alg, ...) { va_list ap; va_start (ap, alg); switch (alg) { case GMP_RAND_ALG_LC: if (! gmp_randinit_lc_2exp_size (rstate, va_arg (ap, unsigned long))) gmp_errno |= GMP_ERROR_INVALID_ARGUMENT; break; default: gmp_errno |= GMP_ERROR_UNSUPPORTED_ARGUMENT; break; } va_end (ap); } gcl-2.6.14/gmp4/rand/randsdui.c0000644000175000017500000000246614360276512014553 0ustar cammcamm/* gmp_randseed_ui (state, seed) -- Set initial seed SEED in random state STATE. Copyright 2000, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void gmp_randseed_ui (gmp_randstate_t rstate, unsigned long int seed) { mpz_t zseed; mp_limb_t zlimbs[LIMBS_PER_ULONG]; MPZ_FAKE_UI (zseed, zlimbs, seed); gmp_randseed (rstate, zseed); } gcl-2.6.14/gmp4/rand/randdef.c0000644000175000017500000000225714360276512014343 0ustar cammcamm/* gmp_randinit_default -- initialize a random state with a default algorithm. Copyright 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void gmp_randinit_default (gmp_randstate_t rstate) { gmp_randinit_mt (rstate); } gcl-2.6.14/gmp4/rand/Makefile.am0000644000175000017500000000254114360276512014624 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 2001, 2002, 2010 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. INCLUDES = -D__GMP_WITHIN_GMP -I$(top_srcdir) noinst_LTLIBRARIES = librandom.la librandom_la_SOURCES = randmt.h \ rand.c randclr.c randdef.c randiset.c randlc2s.c randlc2x.c randmt.c \ randmts.c rands.c randsd.c randsdui.c randbui.c randmui.c gcl-2.6.14/gmp4/rand/rands.c0000644000175000017500000000257414360276512014051 0ustar cammcamm/* __gmp_rands -- global random state for old-style random functions. EVERYTHING IN THIS FILE IS FOR INTERNAL USE ONLY. IT'S ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. */ /* Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Use this via the RANDS macro in gmp-impl.h */ char __gmp_rands_initialized = 0; gmp_randstate_t __gmp_rands; gcl-2.6.14/gmp4/rand/randlc2x.c0000644000175000017500000002233214360276512014451 0ustar cammcamm/* Linear Congruential pseudo-random number generator functions. Copyright 1999-2003, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* State structure for LC, the RNG_STATE() pointer in a gmp_randstate_t. _mp_seed holds the current seed value, in the range 0 to 2^m2exp-1. SIZ(_mp_seed) is fixed at BITS_TO_LIMBS(_mp_m2exp) and the value is padded with high zero limbs if necessary. ALLOC(_mp_seed) is the current size of PTR(_mp_seed) in the usual way. There only needs to be BITS_TO_LIMBS(_mp_m2exp) allocated, but the mpz functions in the initialization and seeding end up making it a bit more than this. _mp_a is the "a" multiplier, in the range 0 to 2^m2exp-1. SIZ(_mp_a) is the size of the value in the normal way for an mpz_t, except that a value of zero is held with SIZ(_mp_a)==1 and PTR(_mp_a)[0]==0. This makes it easy to call mpn_mul, and the case of a==0 is highly un-random and not worth any trouble to optimize. {_cp,_cn} is the "c" addend. Normally _cn is 1, but when nails are in use a ulong can be bigger than one limb, and in this case _cn is 2 if necessary. c==0 is stored as _cp[0]==0 and _cn==1, which makes it easy to call __GMPN_ADD. c==0 is fairly un-random so isn't worth optimizing. _mp_m2exp gives the modulus, namely 2^m2exp. We demand m2exp>=1, since m2exp==0 would mean no bits at all out of each iteration, which makes no sense. */ typedef struct { mpz_t _mp_seed; mpz_t _mp_a; mp_size_t _cn; mp_limb_t _cp[LIMBS_PER_ULONG]; unsigned long _mp_m2exp; } gmp_rand_lc_struct; /* lc (rp, state) -- Generate next number in LC sequence. Return the number of valid bits in the result. Discards the lower half of the result. */ static unsigned long int lc (mp_ptr rp, gmp_randstate_t rstate) { mp_ptr tp, seedp, ap; mp_size_t ta; mp_size_t tn, seedn, an; unsigned long int m2exp; unsigned long int bits; int cy; mp_size_t xn; gmp_rand_lc_struct *p; TMP_DECL; p = (gmp_rand_lc_struct *) RNG_STATE (rstate); m2exp = p->_mp_m2exp; seedp = PTR (p->_mp_seed); seedn = SIZ (p->_mp_seed); ap = PTR (p->_mp_a); an = SIZ (p->_mp_a); /* Allocate temporary storage. Let there be room for calculation of (A * seed + C) % M, or M if bigger than that. */ TMP_MARK; ta = an + seedn + 1; tn = BITS_TO_LIMBS (m2exp); if (ta <= tn) /* that is, if (ta < tn + 1) */ { mp_size_t tmp = an + seedn; ta = tn + 1; tp = TMP_ALLOC_LIMBS (ta); MPN_ZERO (&tp[tmp], ta - tmp); /* mpn_mul won't zero it out. */ } else tp = TMP_ALLOC_LIMBS (ta); /* t = a * seed. NOTE: an is always > 0; see initialization. */ ASSERT (seedn >= an && an > 0); mpn_mul (tp, seedp, seedn, ap, an); /* t = t + c. NOTE: tn is always >= p->_cn (precondition for __GMPN_ADD); see initialization. */ ASSERT (tn >= p->_cn); __GMPN_ADD (cy, tp, tp, tn, p->_cp, p->_cn); /* t = t % m */ tp[m2exp / GMP_NUMB_BITS] &= (CNST_LIMB (1) << m2exp % GMP_NUMB_BITS) - 1; /* Save result as next seed. */ MPN_COPY (PTR (p->_mp_seed), tp, tn); /* Discard the lower m2exp/2 of the result. */ bits = m2exp / 2; xn = bits / GMP_NUMB_BITS; tn -= xn; if (tn > 0) { unsigned int cnt = bits % GMP_NUMB_BITS; if (cnt != 0) { mpn_rshift (tp, tp + xn, tn, cnt); MPN_COPY_INCR (rp, tp, xn + 1); } else /* Even limb boundary. */ MPN_COPY_INCR (rp, tp + xn, tn); } TMP_FREE; /* Return number of valid bits in the result. */ return (m2exp + 1) / 2; } /* Obtain a sequence of random numbers. */ static void randget_lc (gmp_randstate_t rstate, mp_ptr rp, unsigned long int nbits) { unsigned long int rbitpos; int chunk_nbits; mp_ptr tp; mp_size_t tn; gmp_rand_lc_struct *p; TMP_DECL; p = (gmp_rand_lc_struct *) RNG_STATE (rstate); TMP_MARK; chunk_nbits = p->_mp_m2exp / 2; tn = BITS_TO_LIMBS (chunk_nbits); tp = TMP_ALLOC_LIMBS (tn); rbitpos = 0; while (rbitpos + chunk_nbits <= nbits) { mp_ptr r2p = rp + rbitpos / GMP_NUMB_BITS; if (rbitpos % GMP_NUMB_BITS != 0) { mp_limb_t savelimb, rcy; /* Target of new chunk is not bit aligned. Use temp space and align things by shifting it up. */ lc (tp, rstate); savelimb = r2p[0]; rcy = mpn_lshift (r2p, tp, tn, rbitpos % GMP_NUMB_BITS); r2p[0] |= savelimb; /* bogus */ if ((chunk_nbits % GMP_NUMB_BITS + rbitpos % GMP_NUMB_BITS) > GMP_NUMB_BITS) r2p[tn] = rcy; } else { /* Target of new chunk is bit aligned. Let `lc' put bits directly into our target variable. */ lc (r2p, rstate); } rbitpos += chunk_nbits; } /* Handle last [0..chunk_nbits) bits. */ if (rbitpos != nbits) { mp_ptr r2p = rp + rbitpos / GMP_NUMB_BITS; int last_nbits = nbits - rbitpos; tn = BITS_TO_LIMBS (last_nbits); lc (tp, rstate); if (rbitpos % GMP_NUMB_BITS != 0) { mp_limb_t savelimb, rcy; /* Target of new chunk is not bit aligned. Use temp space and align things by shifting it up. */ savelimb = r2p[0]; rcy = mpn_lshift (r2p, tp, tn, rbitpos % GMP_NUMB_BITS); r2p[0] |= savelimb; if (rbitpos + tn * GMP_NUMB_BITS - rbitpos % GMP_NUMB_BITS < nbits) r2p[tn] = rcy; } else { MPN_COPY (r2p, tp, tn); } /* Mask off top bits if needed. */ if (nbits % GMP_NUMB_BITS != 0) rp[nbits / GMP_NUMB_BITS] &= ~(~CNST_LIMB (0) << nbits % GMP_NUMB_BITS); } TMP_FREE; } static void randseed_lc (gmp_randstate_t rstate, mpz_srcptr seed) { gmp_rand_lc_struct *p = (gmp_rand_lc_struct *) RNG_STATE (rstate); mpz_ptr seedz = p->_mp_seed; mp_size_t seedn = BITS_TO_LIMBS (p->_mp_m2exp); /* Store p->_mp_seed as an unnormalized integer with size enough for numbers up to 2^m2exp-1. That size can't be zero. */ mpz_fdiv_r_2exp (seedz, seed, p->_mp_m2exp); MPN_ZERO (&PTR (seedz)[SIZ (seedz)], seedn - SIZ (seedz)); SIZ (seedz) = seedn; } static void randclear_lc (gmp_randstate_t rstate) { gmp_rand_lc_struct *p = (gmp_rand_lc_struct *) RNG_STATE (rstate); mpz_clear (p->_mp_seed); mpz_clear (p->_mp_a); (*__gmp_free_func) (p, sizeof (gmp_rand_lc_struct)); } static void randiset_lc (gmp_randstate_ptr, gmp_randstate_srcptr); static const gmp_randfnptr_t Linear_Congruential_Generator = { randseed_lc, randget_lc, randclear_lc, randiset_lc }; static void randiset_lc (gmp_randstate_ptr dst, gmp_randstate_srcptr src) { gmp_rand_lc_struct *dstp, *srcp; srcp = (gmp_rand_lc_struct *) RNG_STATE (src); dstp = (gmp_rand_lc_struct *) (*__gmp_allocate_func) (sizeof (gmp_rand_lc_struct)); RNG_STATE (dst) = (mp_limb_t *) (void *) dstp; RNG_FNPTR (dst) = (void *) &Linear_Congruential_Generator; /* _mp_seed and _mp_a might be unnormalized (high zero limbs), but mpz_init_set won't worry about that */ mpz_init_set (dstp->_mp_seed, srcp->_mp_seed); mpz_init_set (dstp->_mp_a, srcp->_mp_a); dstp->_cn = srcp->_cn; dstp->_cp[0] = srcp->_cp[0]; if (LIMBS_PER_ULONG > 1) dstp->_cp[1] = srcp->_cp[1]; if (LIMBS_PER_ULONG > 2) /* usually there's only 1 or 2 */ MPN_COPY (dstp->_cp + 2, srcp->_cp + 2, LIMBS_PER_ULONG - 2); dstp->_mp_m2exp = srcp->_mp_m2exp; } void gmp_randinit_lc_2exp (gmp_randstate_t rstate, mpz_srcptr a, unsigned long int c, mp_bitcnt_t m2exp) { gmp_rand_lc_struct *p; mp_size_t seedn = BITS_TO_LIMBS (m2exp); ASSERT_ALWAYS (m2exp != 0); p = __GMP_ALLOCATE_FUNC_TYPE (1, gmp_rand_lc_struct); RNG_STATE (rstate) = (mp_limb_t *) (void *) p; RNG_FNPTR (rstate) = (void *) &Linear_Congruential_Generator; /* allocate m2exp bits of space for p->_mp_seed, and initial seed "1" */ mpz_init2 (p->_mp_seed, m2exp); MPN_ZERO (PTR (p->_mp_seed), seedn); SIZ (p->_mp_seed) = seedn; PTR (p->_mp_seed)[0] = 1; /* "a", forced to 0 to 2^m2exp-1 */ mpz_init (p->_mp_a); mpz_fdiv_r_2exp (p->_mp_a, a, m2exp); /* Avoid SIZ(a) == 0 to avoid checking for special case in lc(). */ if (SIZ (p->_mp_a) == 0) { SIZ (p->_mp_a) = 1; PTR (p->_mp_a)[0] = CNST_LIMB (0); } MPN_SET_UI (p->_cp, p->_cn, c); /* Internally we may discard any bits of c above m2exp. The following code ensures that __GMPN_ADD in lc() will always work. */ if (seedn < p->_cn) p->_cn = (p->_cp[0] != 0); p->_mp_m2exp = m2exp; } gcl-2.6.14/gmp4/rand/randmui.c0000644000175000017500000000503014360276512014367 0ustar cammcamm/* gmp_urandomm_ui -- uniform random number 0 to N-1 for ulong N. Copyright 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" /* If n is a power of 2 then the test ret 1 a[1] = 0; #endif count_leading_zeros (leading, (mp_limb_t) n); bits = GMP_LIMB_BITS - leading - (POW2_P(n) != 0); for (i = 0; i < MAX_URANDOMM_ITER; i++) { _gmp_rand (a, rstate, bits); #if LIMBS_PER_ULONG == 1 ret = a[0]; #else ret = a[0] | (a[1] << GMP_NUMB_BITS); #endif if (LIKELY (ret < n)) /* usually one iteration suffices */ goto done; } /* Too many iterations, there must be something degenerate about the rstate algorithm. Return r%n. */ ret -= n; ASSERT (ret < n); done: return ret; } gcl-2.6.14/gmp4/rand/randlc2s.c0000644000175000017500000000563714360276512014455 0ustar cammcamm/* gmp_randinit_lc_2exp_size -- initialize a random state with a linear congruential generator of a requested size. Copyright 1999-2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" /* Array of LC-schemes, ordered in increasing order of the first member (the 'm2exp' value). The end of the array is indicated with an entry containing all zeros. */ /* All multipliers are in the range 0.01*m and 0.99*m, and are congruent to 5 (mod 8). They all pass the spectral test with Vt >= 2^(30/t) and merit >= 1. (Up to and including 196 bits, merit is >= 3.) */ struct __gmp_rand_lc_scheme_struct { unsigned long int m2exp; /* Modulus is 2 ^ m2exp. */ const char *astr; /* Multiplier in string form. */ unsigned long int c; /* Addend. */ }; static const struct __gmp_rand_lc_scheme_struct __gmp_rand_lc_scheme[] = { {32, "29CF535", 1}, {33, "51F666D", 1}, {34, "A3D73AD", 1}, {35, "147E5B85", 1}, {36, "28F725C5", 1}, {37, "51EE3105", 1}, {38, "A3DD5CDD", 1}, {39, "147AF833D", 1}, {40, "28F5DA175", 1}, {56, "AA7D735234C0DD", 1}, {64, "BAECD515DAF0B49D", 1}, {100, "292787EBD3329AD7E7575E2FD", 1}, {128, "48A74F367FA7B5C8ACBB36901308FA85", 1}, {156, "78A7FDDDC43611B527C3F1D760F36E5D7FC7C45", 1}, {196, "41BA2E104EE34C66B3520CE706A56498DE6D44721E5E24F5", 1}, {200, "4E5A24C38B981EAFE84CD9D0BEC48E83911362C114F30072C5", 1}, {256, "AF66BA932AAF58A071FD8F0742A99A0C76982D648509973DB802303128A14CB5", 1}, {0, NULL, 0} /* End of array. */ }; int gmp_randinit_lc_2exp_size (gmp_randstate_t rstate, mp_bitcnt_t size) { const struct __gmp_rand_lc_scheme_struct *sp; mpz_t a; /* Pick a scheme. */ for (sp = __gmp_rand_lc_scheme; sp->m2exp != 0; sp++) if (sp->m2exp / 2 >= size) goto found; return 0; found: /* Install scheme. */ mpz_init_set_str (a, sp->astr, 16); gmp_randinit_lc_2exp (rstate, a, sp->c, sp->m2exp); mpz_clear (a); return 1; } gcl-2.6.14/gmp4/rand/randbui.c0000644000175000017500000000323414360276512014360 0ustar cammcamm/* gmp_urandomb_ui -- random bits returned in a ulong. Copyright 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Currently bits>=BITS_PER_ULONG is quietly truncated to BITS_PER_ULONG, maybe this should raise an exception or something. */ unsigned long gmp_urandomb_ui (gmp_randstate_ptr rstate, unsigned long bits) { mp_limb_t a[LIMBS_PER_ULONG]; /* start with zeros, since if bits==0 then _gmp_rand will store nothing at all, or if bits <= GMP_NUMB_BITS then it will store only a[0] */ a[0] = 0; #if LIMBS_PER_ULONG > 1 a[1] = 0; #endif _gmp_rand (a, rstate, MIN (bits, BITS_PER_ULONG)); #if LIMBS_PER_ULONG == 1 return a[0]; #else return a[0] | (a[1] << GMP_NUMB_BITS); #endif } gcl-2.6.14/gmp4/rand/randiset.c0000644000175000017500000000234214360276512014544 0ustar cammcamm/* gmp_randinit_set -- initialize with a copy of another gmp_randstate_t. Copyright 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void gmp_randinit_set (gmp_randstate_ptr dst, gmp_randstate_srcptr src) { (*((gmp_randfnptr_t *) RNG_FNPTR (src))->randiset_fn) (dst, src); } gcl-2.6.14/gmp4/rand/randclr.c0000644000175000017500000000230714360276512014361 0ustar cammcamm/* gmp_randclear (state) -- Clear and deallocate random state STATE. Copyright 1999-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void gmp_randclear (gmp_randstate_t rstate) { (*((gmp_randfnptr_t *) RNG_FNPTR (rstate))->randclear_fn) (rstate); } gcl-2.6.14/gmp4/rand/Makefile.in0000644000175000017500000004417014360276512014641 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 2001, 2002, 2010 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = rand DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LTLIBRARIES = $(noinst_LTLIBRARIES) librandom_la_LIBADD = am_librandom_la_OBJECTS = rand.lo randclr.lo randdef.lo randiset.lo \ randlc2s.lo randlc2x.lo randmt.lo randmts.lo rands.lo \ randsd.lo randsdui.lo randbui.lo randmui.lo librandom_la_OBJECTS = $(am_librandom_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(librandom_la_SOURCES) DIST_SOURCES = $(librandom_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ INCLUDES = -D__GMP_WITHIN_GMP -I$(top_srcdir) noinst_LTLIBRARIES = librandom.la librandom_la_SOURCES = randmt.h \ rand.c randclr.c randdef.c randiset.c randlc2s.c randlc2x.c randmt.c \ randmts.c rands.c randsd.c randsdui.c randbui.c randmui.c all: all-am .SUFFIXES: .SUFFIXES: .c .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps rand/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps rand/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): clean-noinstLTLIBRARIES: -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) @list='$(noinst_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } librandom.la: $(librandom_la_OBJECTS) $(librandom_la_DEPENDENCIES) $(EXTRA_librandom_la_DEPENDENCIES) $(AM_V_CCLD)$(LINK) $(librandom_la_OBJECTS) $(librandom_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(LTLIBRARIES) installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \ mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool clean-noinstLTLIBRARIES cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/rand/randsd.c0000644000175000017500000000235514360276512014212 0ustar cammcamm/* gmp_randseed (state, seed) -- Set initial seed SEED in random state STATE. Copyright 2000, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void gmp_randseed (gmp_randstate_t rstate, mpz_srcptr seed) { (*((gmp_randfnptr_t *) RNG_FNPTR (rstate))->randseed_fn) (rstate, seed); } gcl-2.6.14/gmp4/demos/0000755000175000017500000000000014360276512012751 5ustar cammcammgcl-2.6.14/gmp4/demos/isprime.c0000644000175000017500000000334314360276512014570 0ustar cammcamm/* Classify numbers as probable primes, primes or composites. With -q return true if the following argument is a (probable) prime. Copyright 1999, 2000, 2002, 2005, 2012 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" char *progname; void print_usage_and_exit () { fprintf (stderr, "usage: %s -q nnn\n", progname); fprintf (stderr, "usage: %s nnn ...\n", progname); exit (-1); } int main (int argc, char **argv) { mpz_t n; int i; progname = argv[0]; if (argc < 2) print_usage_and_exit (); mpz_init (n); if (argc == 3 && strcmp (argv[1], "-q") == 0) { if (mpz_set_str (n, argv[2], 0) != 0) print_usage_and_exit (); exit (mpz_probab_prime_p (n, 25) == 0); } for (i = 1; i < argc; i++) { int class; if (mpz_set_str (n, argv[i], 0) != 0) print_usage_and_exit (); class = mpz_probab_prime_p (n, 25); mpz_out_str (stdout, 10, n); if (class == 0) puts (" is composite"); else if (class == 1) puts (" is a probable prime"); else /* class == 2 */ puts (" is a prime"); } exit (0); } gcl-2.6.14/gmp4/demos/calc/0000755000175000017500000000000014360276512013653 5ustar cammcammgcl-2.6.14/gmp4/demos/calc/calclex.c0000644000175000017500000013734414360276512015446 0ustar cammcamm #line 3 "calclex.c" #define YY_INT_ALIGNED short int /* A lexical scanner generated by flex */ #define FLEX_SCANNER #define YY_FLEX_MAJOR_VERSION 2 #define YY_FLEX_MINOR_VERSION 5 #define YY_FLEX_SUBMINOR_VERSION 37 #if YY_FLEX_SUBMINOR_VERSION > 0 #define FLEX_BETA #endif /* First, we deal with platform-specific or compiler-specific issues. */ /* begin standard C headers. */ #include #include #include #include /* end standard C headers. */ /* flex integer type definitions */ #ifndef FLEXINT_H #define FLEXINT_H /* C99 systems have . Non-C99 systems may or may not. */ #if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L /* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, * if you want the limit (max/min) macros for int types. */ #ifndef __STDC_LIMIT_MACROS #define __STDC_LIMIT_MACROS 1 #endif #include typedef int8_t flex_int8_t; typedef uint8_t flex_uint8_t; typedef int16_t flex_int16_t; typedef uint16_t flex_uint16_t; typedef int32_t flex_int32_t; typedef uint32_t flex_uint32_t; #else typedef signed char flex_int8_t; typedef short int flex_int16_t; typedef int flex_int32_t; typedef unsigned char flex_uint8_t; typedef unsigned short int flex_uint16_t; typedef unsigned int flex_uint32_t; /* Limits of integral types. */ #ifndef INT8_MIN #define INT8_MIN (-128) #endif #ifndef INT16_MIN #define INT16_MIN (-32767-1) #endif #ifndef INT32_MIN #define INT32_MIN (-2147483647-1) #endif #ifndef INT8_MAX #define INT8_MAX (127) #endif #ifndef INT16_MAX #define INT16_MAX (32767) #endif #ifndef INT32_MAX #define INT32_MAX (2147483647) #endif #ifndef UINT8_MAX #define UINT8_MAX (255U) #endif #ifndef UINT16_MAX #define UINT16_MAX (65535U) #endif #ifndef UINT32_MAX #define UINT32_MAX (4294967295U) #endif #endif /* ! C99 */ #endif /* ! FLEXINT_H */ #ifdef __cplusplus /* The "const" storage-class-modifier is valid. */ #define YY_USE_CONST #else /* ! __cplusplus */ /* C99 requires __STDC__ to be defined as 1. */ #if defined (__STDC__) #define YY_USE_CONST #endif /* defined (__STDC__) */ #endif /* ! __cplusplus */ #ifdef YY_USE_CONST #define yyconst const #else #define yyconst #endif /* Returned upon end-of-file. */ #define YY_NULL 0 /* Promotes a possibly negative, possibly signed char to an unsigned * integer for use as an array index. If the signed char is negative, * we want to instead treat it as an 8-bit unsigned char, hence the * double cast. */ #define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) /* Enter a start condition. This macro really ought to take a parameter, * but we do it the disgusting crufty way forced on us by the ()-less * definition of BEGIN. */ #define BEGIN (yy_start) = 1 + 2 * /* Translate the current start state into a value that can be later handed * to BEGIN to return to the state. The YYSTATE alias is for lex * compatibility. */ #define YY_START (((yy_start) - 1) / 2) #define YYSTATE YY_START /* Action number for EOF rule of a given start state. */ #define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) /* Special action meaning "start processing a new file". */ #define YY_NEW_FILE yyrestart(yyin ) #define YY_END_OF_BUFFER_CHAR 0 /* Size of default input buffer. */ #ifndef YY_BUF_SIZE #define YY_BUF_SIZE 16384 #endif /* The state buf must be large enough to hold one state per character in the main buffer. */ #define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) #ifndef YY_TYPEDEF_YY_BUFFER_STATE #define YY_TYPEDEF_YY_BUFFER_STATE typedef struct yy_buffer_state *YY_BUFFER_STATE; #endif #ifndef YY_TYPEDEF_YY_SIZE_T #define YY_TYPEDEF_YY_SIZE_T typedef size_t yy_size_t; #endif extern yy_size_t yyleng; extern FILE *yyin, *yyout; #define EOB_ACT_CONTINUE_SCAN 0 #define EOB_ACT_END_OF_FILE 1 #define EOB_ACT_LAST_MATCH 2 #define YY_LESS_LINENO(n) /* Return all but the first "n" matched characters back to the input stream. */ #define yyless(n) \ do \ { \ /* Undo effects of setting up yytext. */ \ int yyless_macro_arg = (n); \ YY_LESS_LINENO(yyless_macro_arg);\ *yy_cp = (yy_hold_char); \ YY_RESTORE_YY_MORE_OFFSET \ (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ YY_DO_BEFORE_ACTION; /* set up yytext again */ \ } \ while ( 0 ) #define unput(c) yyunput( c, (yytext_ptr) ) #ifndef YY_STRUCT_YY_BUFFER_STATE #define YY_STRUCT_YY_BUFFER_STATE struct yy_buffer_state { FILE *yy_input_file; char *yy_ch_buf; /* input buffer */ char *yy_buf_pos; /* current position in input buffer */ /* Size of input buffer in bytes, not including room for EOB * characters. */ yy_size_t yy_buf_size; /* Number of characters read into yy_ch_buf, not including EOB * characters. */ yy_size_t yy_n_chars; /* Whether we "own" the buffer - i.e., we know we created it, * and can realloc() it to grow it, and should free() it to * delete it. */ int yy_is_our_buffer; /* Whether this is an "interactive" input source; if so, and * if we're using stdio for input, then we want to use getc() * instead of fread(), to make sure we stop fetching input after * each newline. */ int yy_is_interactive; /* Whether we're considered to be at the beginning of a line. * If so, '^' rules will be active on the next match, otherwise * not. */ int yy_at_bol; int yy_bs_lineno; /**< The line count. */ int yy_bs_column; /**< The column count. */ /* Whether to try to fill the input buffer when we reach the * end of it. */ int yy_fill_buffer; int yy_buffer_status; #define YY_BUFFER_NEW 0 #define YY_BUFFER_NORMAL 1 /* When an EOF's been seen but there's still some text to process * then we mark the buffer as YY_EOF_PENDING, to indicate that we * shouldn't try reading from the input source any more. We might * still have a bunch of tokens to match, though, because of * possible backing-up. * * When we actually see the EOF, we change the status to "new" * (via yyrestart()), so that the user can continue scanning by * just pointing yyin at a new input file. */ #define YY_BUFFER_EOF_PENDING 2 }; #endif /* !YY_STRUCT_YY_BUFFER_STATE */ /* Stack of input buffers. */ static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ /* We provide macros for accessing buffer states in case in the * future we want to put the buffer states in a more general * "scanner state". * * Returns the top of the stack, or NULL. */ #define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ : NULL) /* Same as previous macro, but useful when we know that the buffer stack is not * NULL or when we need an lvalue. For internal use only. */ #define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] /* yy_hold_char holds the character lost when yytext is formed. */ static char yy_hold_char; static yy_size_t yy_n_chars; /* number of characters read into yy_ch_buf */ yy_size_t yyleng; /* Points to current character in buffer. */ static char *yy_c_buf_p = (char *) 0; static int yy_init = 0; /* whether we need to initialize */ static int yy_start = 0; /* start state number */ /* Flag which is used to allow yywrap()'s to do buffer switches * instead of setting up a fresh yyin. A bit of a hack ... */ static int yy_did_buffer_switch_on_eof; void yyrestart (FILE *input_file ); void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); YY_BUFFER_STATE yy_create_buffer (FILE *file,int size ); void yy_delete_buffer (YY_BUFFER_STATE b ); void yy_flush_buffer (YY_BUFFER_STATE b ); void yypush_buffer_state (YY_BUFFER_STATE new_buffer ); void yypop_buffer_state (void ); static void yyensure_buffer_stack (void ); static void yy_load_buffer_state (void ); static void yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); #define YY_FLUSH_BUFFER yy_flush_buffer(YY_CURRENT_BUFFER ) YY_BUFFER_STATE yy_scan_buffer (char *base,yy_size_t size ); YY_BUFFER_STATE yy_scan_string (yyconst char *yy_str ); YY_BUFFER_STATE yy_scan_bytes (yyconst char *bytes,yy_size_t len ); void *yyalloc (yy_size_t ); void *yyrealloc (void *,yy_size_t ); void yyfree (void * ); #define yy_new_buffer yy_create_buffer #define yy_set_interactive(is_interactive) \ { \ if ( ! YY_CURRENT_BUFFER ){ \ yyensure_buffer_stack (); \ YY_CURRENT_BUFFER_LVALUE = \ yy_create_buffer(yyin,YY_BUF_SIZE ); \ } \ YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ } #define yy_set_bol(at_bol) \ { \ if ( ! YY_CURRENT_BUFFER ){\ yyensure_buffer_stack (); \ YY_CURRENT_BUFFER_LVALUE = \ yy_create_buffer(yyin,YY_BUF_SIZE ); \ } \ YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ } #define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) /* Begin user sect3 */ typedef unsigned char YY_CHAR; FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; typedef int yy_state_type; extern int yylineno; int yylineno = 1; extern char *yytext; #define yytext_ptr yytext static yy_state_type yy_get_previous_state (void ); static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); static int yy_get_next_buffer (void ); static void yy_fatal_error (yyconst char msg[] ); /* Done after the current pattern has been matched and before the * corresponding action - sets up yytext. */ #define YY_DO_BEFORE_ACTION \ (yytext_ptr) = yy_bp; \ yyleng = (size_t) (yy_cp - yy_bp); \ (yy_hold_char) = *yy_cp; \ *yy_cp = '\0'; \ (yy_c_buf_p) = yy_cp; #define YY_NUM_RULES 19 #define YY_END_OF_BUFFER 20 /* This struct is not used in this scanner, but its presence is necessary. */ struct yy_trans_info { flex_int32_t yy_verify; flex_int32_t yy_nxt; }; static yyconst flex_int16_t yy_accept[39] = { 0, 0, 0, 20, 18, 1, 2, 7, 6, 7, 18, 16, 16, 2, 7, 7, 7, 16, 17, 18, 18, 11, 6, 5, 6, 14, 16, 0, 12, 8, 10, 9, 13, 16, 17, 3, 15, 4, 0 } ; static yyconst flex_int32_t yy_ec[256] = { 0, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, 5, 1, 6, 7, 1, 6, 6, 6, 6, 6, 6, 1, 6, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 1, 10, 11, 12, 13, 1, 1, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 16, 15, 15, 1, 17, 1, 6, 1, 1, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 16, 15, 15, 1, 18, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 } ; static yyconst flex_int32_t yy_meta[19] = { 0, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 2, 3, 2, 1, 1 } ; static yyconst flex_int16_t yy_base[43] = { 0, 0, 0, 39, 49, 49, 49, 26, 16, 49, 30, 20, 19, 49, 9, 22, 10, 9, 0, 29, 13, 49, 23, 49, 24, 49, 0, 0, 49, 49, 49, 49, 49, 13, 0, 49, 49, 49, 49, 41, 28, 43, 45 } ; static yyconst flex_int16_t yy_def[43] = { 0, 38, 1, 38, 38, 38, 38, 38, 39, 38, 38, 40, 40, 38, 38, 38, 38, 41, 42, 38, 38, 38, 39, 38, 39, 38, 12, 12, 38, 38, 38, 38, 38, 41, 42, 38, 38, 38, 0, 38, 38, 38, 38 } ; static yyconst flex_int16_t yy_nxt[68] = { 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 18, 19, 20, 23, 28, 29, 31, 32, 34, 34, 23, 37, 34, 34, 26, 36, 35, 24, 30, 38, 27, 25, 21, 38, 24, 24, 22, 22, 22, 33, 33, 34, 34, 3, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38 } ; static yyconst flex_int16_t yy_chk[68] = { 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 8, 14, 14, 16, 16, 17, 17, 22, 24, 33, 33, 40, 20, 19, 8, 15, 12, 11, 10, 7, 3, 22, 24, 39, 39, 39, 41, 41, 42, 42, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38 } ; static yy_state_type yy_last_accepting_state; static char *yy_last_accepting_cpos; extern int yy_flex_debug; int yy_flex_debug = 0; /* The intent behind this definition is that it'll catch * any uses of REJECT which flex missed. */ #define REJECT reject_used_but_not_detected #define yymore() yymore_used_but_not_detected #define YY_MORE_ADJ 0 #define YY_RESTORE_YY_MORE_OFFSET char *yytext; #line 1 "calclex.l" /* Lexical analyzer for calc program. Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #line 20 "calclex.l" #include #include "calc-common.h" #if WITH_READLINE /* Let GNU flex use readline. See the calcread.c redefined input() for a way that might work for a standard lex too. */ #define YY_INPUT(buf,result,max_size) \ result = calc_input (buf, max_size); #endif /* Non-zero when reading the second or subsequent line of an expression, used to give a different prompt when using readline. */ int calc_more_input = 0; const struct calc_keywords_t calc_keywords[] = { { "abs", ABS }, { "bin", BIN }, { "decimal", DECIMAL }, { "fib", FIB }, { "hex", HEX }, { "help", HELP }, { "gcd", GCD }, { "kron", KRON }, { "lcm", LCM }, { "lucnum", LUCNUM }, { "nextprime", NEXTPRIME }, { "powm", POWM }, { "quit", QUIT }, { "root", ROOT }, { "sqrt", SQRT }, { NULL } }; #line 527 "calclex.c" #define INITIAL 0 #ifndef YY_NO_UNISTD_H /* Special case for "unistd.h", since it is non-ANSI. We include it way * down here because we want the user's section 1 to have been scanned first. * The user has a chance to override it with an option. */ #include #endif #ifndef YY_EXTRA_TYPE #define YY_EXTRA_TYPE void * #endif static int yy_init_globals (void ); /* Accessor methods to globals. These are made visible to non-reentrant scanners for convenience. */ int yylex_destroy (void ); int yyget_debug (void ); void yyset_debug (int debug_flag ); YY_EXTRA_TYPE yyget_extra (void ); void yyset_extra (YY_EXTRA_TYPE user_defined ); FILE *yyget_in (void ); void yyset_in (FILE * in_str ); FILE *yyget_out (void ); void yyset_out (FILE * out_str ); yy_size_t yyget_leng (void ); char *yyget_text (void ); int yyget_lineno (void ); void yyset_lineno (int line_number ); /* Macros after this point can all be overridden by user definitions in * section 1. */ #ifndef YY_SKIP_YYWRAP #ifdef __cplusplus extern "C" int yywrap (void ); #else extern int yywrap (void ); #endif #endif static void yyunput (int c,char *buf_ptr ); #ifndef yytext_ptr static void yy_flex_strncpy (char *,yyconst char *,int ); #endif #ifdef YY_NEED_STRLEN static int yy_flex_strlen (yyconst char * ); #endif #ifndef YY_NO_INPUT #ifdef __cplusplus static int yyinput (void ); #else static int input (void ); #endif #endif /* Amount of stuff to slurp up with each read. */ #ifndef YY_READ_BUF_SIZE #define YY_READ_BUF_SIZE 8192 #endif /* Copy whatever the last rule matched to the standard output. */ #ifndef ECHO /* This used to be an fputs(), but since the string might contain NUL's, * we now use fwrite(). */ #define ECHO do { if (fwrite( yytext, yyleng, 1, yyout )) {} } while (0) #endif /* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, * is returned in "result". */ #ifndef YY_INPUT #define YY_INPUT(buf,result,max_size) \ if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ { \ int c = '*'; \ size_t n; \ for ( n = 0; n < max_size && \ (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ buf[n] = (char) c; \ if ( c == '\n' ) \ buf[n++] = (char) c; \ if ( c == EOF && ferror( yyin ) ) \ YY_FATAL_ERROR( "input in flex scanner failed" ); \ result = n; \ } \ else \ { \ errno=0; \ while ( (result = fread(buf, 1, max_size, yyin))==0 && ferror(yyin)) \ { \ if( errno != EINTR) \ { \ YY_FATAL_ERROR( "input in flex scanner failed" ); \ break; \ } \ errno=0; \ clearerr(yyin); \ } \ }\ \ #endif /* No semi-colon after return; correct usage is to write "yyterminate();" - * we don't want an extra ';' after the "return" because that will cause * some compilers to complain about unreachable statements. */ #ifndef yyterminate #define yyterminate() return YY_NULL #endif /* Number of entries by which start-condition stack grows. */ #ifndef YY_START_STACK_INCR #define YY_START_STACK_INCR 25 #endif /* Report a fatal error. */ #ifndef YY_FATAL_ERROR #define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) #endif /* end tables serialization structures and prototypes */ /* Default declaration of generated scanner - a define so the user can * easily add parameters. */ #ifndef YY_DECL #define YY_DECL_IS_OURS 1 extern int yylex (void); #define YY_DECL int yylex (void) #endif /* !YY_DECL */ /* Code executed at the beginning of each rule, after yytext and yyleng * have been set up. */ #ifndef YY_USER_ACTION #define YY_USER_ACTION #endif /* Code executed at the end of each rule. */ #ifndef YY_BREAK #define YY_BREAK break; #endif #define YY_RULE_SETUP \ YY_USER_ACTION /** The main scanner function which does all the work. */ YY_DECL { register yy_state_type yy_current_state; register char *yy_cp, *yy_bp; register int yy_act; #line 57 "calclex.l" #line 712 "calclex.c" if ( !(yy_init) ) { (yy_init) = 1; #ifdef YY_USER_INIT YY_USER_INIT; #endif if ( ! (yy_start) ) (yy_start) = 1; /* first start state */ if ( ! yyin ) yyin = stdin; if ( ! yyout ) yyout = stdout; if ( ! YY_CURRENT_BUFFER ) { yyensure_buffer_stack (); YY_CURRENT_BUFFER_LVALUE = yy_create_buffer(yyin,YY_BUF_SIZE ); } yy_load_buffer_state( ); } while ( 1 ) /* loops until end-of-file is reached */ { yy_cp = (yy_c_buf_p); /* Support of yytext. */ *yy_cp = (yy_hold_char); /* yy_bp points to the position in yy_ch_buf of the start of * the current run. */ yy_bp = yy_cp; yy_current_state = (yy_start); yy_match: do { register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 39 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; ++yy_cp; } while ( yy_base[yy_current_state] != 49 ); yy_find_action: yy_act = yy_accept[yy_current_state]; if ( yy_act == 0 ) { /* have to back up */ yy_cp = (yy_last_accepting_cpos); yy_current_state = (yy_last_accepting_state); yy_act = yy_accept[yy_current_state]; } YY_DO_BEFORE_ACTION; do_action: /* This label is used only to access EOF actions. */ switch ( yy_act ) { /* beginning of action switch */ case 0: /* must back up */ /* undo the effects of YY_DO_BEFORE_ACTION */ *yy_cp = (yy_hold_char); yy_cp = (yy_last_accepting_cpos); yy_current_state = (yy_last_accepting_state); goto yy_find_action; case 1: YY_RULE_SETUP #line 59 "calclex.l" { /* white space is skipped */ } YY_BREAK case 2: /* rule 2 can match eol */ YY_RULE_SETUP #line 61 "calclex.l" { /* semicolon or newline separates statements */ calc_more_input = 0; return EOS; } YY_BREAK case 3: /* rule 3 can match eol */ YY_RULE_SETUP #line 64 "calclex.l" { /* escaped newlines are skipped */ } YY_BREAK case 4: /* rule 4 can match eol */ YY_RULE_SETUP #line 67 "calclex.l" { /* comment through to escaped newline is skipped */ } YY_BREAK case 5: /* rule 5 can match eol */ YY_RULE_SETUP #line 69 "calclex.l" { /* comment through to newline is a separator */ calc_more_input = 0; return EOS; } YY_BREAK case 6: YY_RULE_SETUP #line 72 "calclex.l" { /* comment through to EOF skipped */ } YY_BREAK case 7: YY_RULE_SETUP #line 75 "calclex.l" { return yytext[0]; } YY_BREAK case 8: YY_RULE_SETUP #line 76 "calclex.l" { return LE; } YY_BREAK case 9: YY_RULE_SETUP #line 77 "calclex.l" { return GE; } YY_BREAK case 10: YY_RULE_SETUP #line 78 "calclex.l" { return EQ; } YY_BREAK case 11: YY_RULE_SETUP #line 79 "calclex.l" { return NE; } YY_BREAK case 12: YY_RULE_SETUP #line 80 "calclex.l" { return LSHIFT; } YY_BREAK case 13: YY_RULE_SETUP #line 81 "calclex.l" { return RSHIFT; } YY_BREAK case 14: YY_RULE_SETUP #line 82 "calclex.l" { return LAND; } YY_BREAK case 15: YY_RULE_SETUP #line 83 "calclex.l" { return LOR; } YY_BREAK case 16: YY_RULE_SETUP #line 85 "calclex.l" { yylval.str = yytext; return NUMBER; } YY_BREAK case 17: YY_RULE_SETUP #line 89 "calclex.l" { int i; for (i = 0; calc_keywords[i].name != NULL; i++) if (strcmp (yytext, calc_keywords[i].name) == 0) return calc_keywords[i].value; if (yytext[0] >= 'a' && yytext[0] <= 'z' && yytext[1] == '\0') { yylval.var = yytext[0] - 'a'; return VARIABLE; } return BAD; } YY_BREAK case 18: YY_RULE_SETUP #line 105 "calclex.l" { return BAD; } YY_BREAK case 19: YY_RULE_SETUP #line 107 "calclex.l" ECHO; YY_BREAK #line 915 "calclex.c" case YY_STATE_EOF(INITIAL): yyterminate(); case YY_END_OF_BUFFER: { /* Amount of text matched not including the EOB char. */ int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; /* Undo the effects of YY_DO_BEFORE_ACTION. */ *yy_cp = (yy_hold_char); YY_RESTORE_YY_MORE_OFFSET if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) { /* We're scanning a new file or input source. It's * possible that this happened because the user * just pointed yyin at a new source and called * yylex(). If so, then we have to assure * consistency between YY_CURRENT_BUFFER and our * globals. Here is the right place to do so, because * this is the first action (other than possibly a * back-up) that will match for the new input source. */ (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; } /* Note that here we test for yy_c_buf_p "<=" to the position * of the first EOB in the buffer, since yy_c_buf_p will * already have been incremented past the NUL character * (since all states make transitions on EOB to the * end-of-buffer state). Contrast this with the test * in input(). */ if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) { /* This was really a NUL. */ yy_state_type yy_next_state; (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; yy_current_state = yy_get_previous_state( ); /* Okay, we're now positioned to make the NUL * transition. We couldn't have * yy_get_previous_state() go ahead and do it * for us because it doesn't know how to deal * with the possibility of jamming (and we don't * want to build jamming into it because then it * will run more slowly). */ yy_next_state = yy_try_NUL_trans( yy_current_state ); yy_bp = (yytext_ptr) + YY_MORE_ADJ; if ( yy_next_state ) { /* Consume the NUL. */ yy_cp = ++(yy_c_buf_p); yy_current_state = yy_next_state; goto yy_match; } else { yy_cp = (yy_c_buf_p); goto yy_find_action; } } else switch ( yy_get_next_buffer( ) ) { case EOB_ACT_END_OF_FILE: { (yy_did_buffer_switch_on_eof) = 0; if ( yywrap( ) ) { /* Note: because we've taken care in * yy_get_next_buffer() to have set up * yytext, we can now set up * yy_c_buf_p so that if some total * hoser (like flex itself) wants to * call the scanner after we return the * YY_NULL, it'll still work - another * YY_NULL will get returned. */ (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; yy_act = YY_STATE_EOF(YY_START); goto do_action; } else { if ( ! (yy_did_buffer_switch_on_eof) ) YY_NEW_FILE; } break; } case EOB_ACT_CONTINUE_SCAN: (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; yy_current_state = yy_get_previous_state( ); yy_cp = (yy_c_buf_p); yy_bp = (yytext_ptr) + YY_MORE_ADJ; goto yy_match; case EOB_ACT_LAST_MATCH: (yy_c_buf_p) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; yy_current_state = yy_get_previous_state( ); yy_cp = (yy_c_buf_p); yy_bp = (yytext_ptr) + YY_MORE_ADJ; goto yy_find_action; } break; } default: YY_FATAL_ERROR( "fatal flex scanner internal error--no action found" ); } /* end of action switch */ } /* end of scanning one token */ } /* end of yylex */ /* yy_get_next_buffer - try to read in a new buffer * * Returns a code representing an action: * EOB_ACT_LAST_MATCH - * EOB_ACT_CONTINUE_SCAN - continue scanning from current position * EOB_ACT_END_OF_FILE - end of file */ static int yy_get_next_buffer (void) { register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; register char *source = (yytext_ptr); register int number_to_move, i; int ret_val; if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) YY_FATAL_ERROR( "fatal flex scanner internal error--end of buffer missed" ); if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) { /* Don't try to fill the buffer, so this is an EOF. */ if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) { /* We matched a single character, the EOB, so * treat this as a final EOF. */ return EOB_ACT_END_OF_FILE; } else { /* We matched some text prior to the EOB, first * process it. */ return EOB_ACT_LAST_MATCH; } } /* Try to read more data. */ /* First move last chars to start of buffer. */ number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; for ( i = 0; i < number_to_move; ++i ) *(dest++) = *(source++); if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) /* don't do the read, it's not guaranteed to return an EOF, * just force an EOF */ YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; else { yy_size_t num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; while ( num_to_read <= 0 ) { /* Not enough room in the buffer - grow it. */ /* just a shorter name for the current buffer */ YY_BUFFER_STATE b = YY_CURRENT_BUFFER_LVALUE; int yy_c_buf_p_offset = (int) ((yy_c_buf_p) - b->yy_ch_buf); if ( b->yy_is_our_buffer ) { yy_size_t new_size = b->yy_buf_size * 2; if ( new_size <= 0 ) b->yy_buf_size += b->yy_buf_size / 8; else b->yy_buf_size *= 2; b->yy_ch_buf = (char *) /* Include room in for 2 EOB chars. */ yyrealloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); } else /* Can't grow it, we don't own it. */ b->yy_ch_buf = 0; if ( ! b->yy_ch_buf ) YY_FATAL_ERROR( "fatal error - scanner input buffer overflow" ); (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; } if ( num_to_read > YY_READ_BUF_SIZE ) num_to_read = YY_READ_BUF_SIZE; /* Read in more data. */ YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), (yy_n_chars), num_to_read ); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } if ( (yy_n_chars) == 0 ) { if ( number_to_move == YY_MORE_ADJ ) { ret_val = EOB_ACT_END_OF_FILE; yyrestart(yyin ); } else { ret_val = EOB_ACT_LAST_MATCH; YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_EOF_PENDING; } } else ret_val = EOB_ACT_CONTINUE_SCAN; if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { /* Extend the array by 50%, plus the number we really need. */ yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); } (yy_n_chars) += number_to_move; YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; return ret_val; } /* yy_get_previous_state - get the state just before the EOB char was reached */ static yy_state_type yy_get_previous_state (void) { register yy_state_type yy_current_state; register char *yy_cp; yy_current_state = (yy_start); for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) { register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 39 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; } return yy_current_state; } /* yy_try_NUL_trans - try to make a transition on the NUL character * * synopsis * next_state = yy_try_NUL_trans( current_state ); */ static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) { register int yy_is_jam; register char *yy_cp = (yy_c_buf_p); register YY_CHAR yy_c = 1; if ( yy_accept[yy_current_state] ) { (yy_last_accepting_state) = yy_current_state; (yy_last_accepting_cpos) = yy_cp; } while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) { yy_current_state = (int) yy_def[yy_current_state]; if ( yy_current_state >= 39 ) yy_c = yy_meta[(unsigned int) yy_c]; } yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; yy_is_jam = (yy_current_state == 38); return yy_is_jam ? 0 : yy_current_state; } static void yyunput (int c, register char * yy_bp ) { register char *yy_cp; yy_cp = (yy_c_buf_p); /* undo effects of setting up yytext */ *yy_cp = (yy_hold_char); if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) { /* need to shift things up to make room */ /* +2 for EOB chars. */ register yy_size_t number_to_move = (yy_n_chars) + 2; register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; register char *source = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) *--dest = *--source; yy_cp += (int) (dest - source); yy_bp += (int) (dest - source); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); } *--yy_cp = (char) c; (yytext_ptr) = yy_bp; (yy_hold_char) = *yy_cp; (yy_c_buf_p) = yy_cp; } #ifndef YY_NO_INPUT #ifdef __cplusplus static int yyinput (void) #else static int input (void) #endif { int c; *(yy_c_buf_p) = (yy_hold_char); if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) { /* yy_c_buf_p now points to the character we want to return. * If this occurs *before* the EOB characters, then it's a * valid NUL; if not, then we've hit the end of the buffer. */ if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) /* This was really a NUL. */ *(yy_c_buf_p) = '\0'; else { /* need more input */ yy_size_t offset = (yy_c_buf_p) - (yytext_ptr); ++(yy_c_buf_p); switch ( yy_get_next_buffer( ) ) { case EOB_ACT_LAST_MATCH: /* This happens because yy_g_n_b() * sees that we've accumulated a * token and flags that we need to * try matching the token before * proceeding. But for input(), * there's no matching to consider. * So convert the EOB_ACT_LAST_MATCH * to EOB_ACT_END_OF_FILE. */ /* Reset buffer status. */ yyrestart(yyin ); /*FALLTHROUGH*/ case EOB_ACT_END_OF_FILE: { if ( yywrap( ) ) return EOF; if ( ! (yy_did_buffer_switch_on_eof) ) YY_NEW_FILE; #ifdef __cplusplus return yyinput(); #else return input(); #endif } case EOB_ACT_CONTINUE_SCAN: (yy_c_buf_p) = (yytext_ptr) + offset; break; } } } c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ *(yy_c_buf_p) = '\0'; /* preserve yytext */ (yy_hold_char) = *++(yy_c_buf_p); return c; } #endif /* ifndef YY_NO_INPUT */ /** Immediately switch to a different input stream. * @param input_file A readable stream. * * @note This function does not reset the start condition to @c INITIAL . */ void yyrestart (FILE * input_file ) { if ( ! YY_CURRENT_BUFFER ){ yyensure_buffer_stack (); YY_CURRENT_BUFFER_LVALUE = yy_create_buffer(yyin,YY_BUF_SIZE ); } yy_init_buffer(YY_CURRENT_BUFFER,input_file ); yy_load_buffer_state( ); } /** Switch to a different input buffer. * @param new_buffer The new input buffer. * */ void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) { /* TODO. We should be able to replace this entire function body * with * yypop_buffer_state(); * yypush_buffer_state(new_buffer); */ yyensure_buffer_stack (); if ( YY_CURRENT_BUFFER == new_buffer ) return; if ( YY_CURRENT_BUFFER ) { /* Flush out information for old buffer. */ *(yy_c_buf_p) = (yy_hold_char); YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } YY_CURRENT_BUFFER_LVALUE = new_buffer; yy_load_buffer_state( ); /* We don't actually know whether we did this switch during * EOF (yywrap()) processing, but the only time this flag * is looked at is after yywrap() is called, so it's safe * to go ahead and always set it. */ (yy_did_buffer_switch_on_eof) = 1; } static void yy_load_buffer_state (void) { (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; (yy_hold_char) = *(yy_c_buf_p); } /** Allocate and initialize an input buffer state. * @param file A readable stream. * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. * * @return the allocated buffer state. */ YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) { YY_BUFFER_STATE b; b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); if ( ! b ) YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); b->yy_buf_size = size; /* yy_ch_buf has to be 2 characters longer than the size given because * we need to put in 2 end-of-buffer characters. */ b->yy_ch_buf = (char *) yyalloc(b->yy_buf_size + 2 ); if ( ! b->yy_ch_buf ) YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); b->yy_is_our_buffer = 1; yy_init_buffer(b,file ); return b; } /** Destroy the buffer. * @param b a buffer created with yy_create_buffer() * */ void yy_delete_buffer (YY_BUFFER_STATE b ) { if ( ! b ) return; if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; if ( b->yy_is_our_buffer ) yyfree((void *) b->yy_ch_buf ); yyfree((void *) b ); } /* Initializes or reinitializes a buffer. * This function is sometimes called more than once on the same buffer, * such as during a yyrestart() or at EOF. */ static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) { int oerrno = errno; yy_flush_buffer(b ); b->yy_input_file = file; b->yy_fill_buffer = 1; /* If b is the current buffer, then yy_init_buffer was _probably_ * called from yyrestart() or through yy_get_next_buffer. * In that case, we don't want to reset the lineno or column. */ if (b != YY_CURRENT_BUFFER){ b->yy_bs_lineno = 1; b->yy_bs_column = 0; } b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; errno = oerrno; } /** Discard all buffered characters. On the next scan, YY_INPUT will be called. * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. * */ void yy_flush_buffer (YY_BUFFER_STATE b ) { if ( ! b ) return; b->yy_n_chars = 0; /* We always need two end-of-buffer characters. The first causes * a transition to the end-of-buffer state. The second causes * a jam in that state. */ b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; b->yy_buf_pos = &b->yy_ch_buf[0]; b->yy_at_bol = 1; b->yy_buffer_status = YY_BUFFER_NEW; if ( b == YY_CURRENT_BUFFER ) yy_load_buffer_state( ); } /** Pushes the new state onto the stack. The new state becomes * the current state. This function will allocate the stack * if necessary. * @param new_buffer The new state. * */ void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) { if (new_buffer == NULL) return; yyensure_buffer_stack(); /* This block is copied from yy_switch_to_buffer. */ if ( YY_CURRENT_BUFFER ) { /* Flush out information for old buffer. */ *(yy_c_buf_p) = (yy_hold_char); YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); } /* Only push if top exists. Otherwise, replace top. */ if (YY_CURRENT_BUFFER) (yy_buffer_stack_top)++; YY_CURRENT_BUFFER_LVALUE = new_buffer; /* copied from yy_switch_to_buffer. */ yy_load_buffer_state( ); (yy_did_buffer_switch_on_eof) = 1; } /** Removes and deletes the top of the stack, if present. * The next element becomes the new top. * */ void yypop_buffer_state (void) { if (!YY_CURRENT_BUFFER) return; yy_delete_buffer(YY_CURRENT_BUFFER ); YY_CURRENT_BUFFER_LVALUE = NULL; if ((yy_buffer_stack_top) > 0) --(yy_buffer_stack_top); if (YY_CURRENT_BUFFER) { yy_load_buffer_state( ); (yy_did_buffer_switch_on_eof) = 1; } } /* Allocates the stack if it does not exist. * Guarantees space for at least one push. */ static void yyensure_buffer_stack (void) { yy_size_t num_to_alloc; if (!(yy_buffer_stack)) { /* First allocation is just for 2 elements, since we don't know if this * scanner will even need a stack. We use 2 instead of 1 to avoid an * immediate realloc on the next call. */ num_to_alloc = 1; (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc (num_to_alloc * sizeof(struct yy_buffer_state*) ); if ( ! (yy_buffer_stack) ) YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); (yy_buffer_stack_max) = num_to_alloc; (yy_buffer_stack_top) = 0; return; } if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ /* Increase the buffer to prepare for a possible push. */ int grow_size = 8 /* arbitrary grow size */; num_to_alloc = (yy_buffer_stack_max) + grow_size; (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc ((yy_buffer_stack), num_to_alloc * sizeof(struct yy_buffer_state*) ); if ( ! (yy_buffer_stack) ) YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); /* zero only the new slots.*/ memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); (yy_buffer_stack_max) = num_to_alloc; } } /** Setup the input buffer state to scan directly from a user-specified character buffer. * @param base the character buffer * @param size the size in bytes of the character buffer * * @return the newly allocated buffer state object. */ YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) { YY_BUFFER_STATE b; if ( size < 2 || base[size-2] != YY_END_OF_BUFFER_CHAR || base[size-1] != YY_END_OF_BUFFER_CHAR ) /* They forgot to leave room for the EOB's. */ return 0; b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); if ( ! b ) YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ b->yy_buf_pos = b->yy_ch_buf = base; b->yy_is_our_buffer = 0; b->yy_input_file = 0; b->yy_n_chars = b->yy_buf_size; b->yy_is_interactive = 0; b->yy_at_bol = 1; b->yy_fill_buffer = 0; b->yy_buffer_status = YY_BUFFER_NEW; yy_switch_to_buffer(b ); return b; } /** Setup the input buffer state to scan a string. The next call to yylex() will * scan from a @e copy of @a str. * @param yystr a NUL-terminated string to scan * * @return the newly allocated buffer state object. * @note If you want to scan bytes that may contain NUL values, then use * yy_scan_bytes() instead. */ YY_BUFFER_STATE yy_scan_string (yyconst char * yystr ) { return yy_scan_bytes(yystr,strlen(yystr) ); } /** Setup the input buffer state to scan the given bytes. The next call to yylex() will * scan from a @e copy of @a bytes. * @param yybytes the byte buffer to scan * @param _yybytes_len the number of bytes in the buffer pointed to by @a bytes. * * @return the newly allocated buffer state object. */ YY_BUFFER_STATE yy_scan_bytes (yyconst char * yybytes, yy_size_t _yybytes_len ) { YY_BUFFER_STATE b; char *buf; yy_size_t n; int i; /* Get memory for full buffer, including space for trailing EOB's. */ n = _yybytes_len + 2; buf = (char *) yyalloc(n ); if ( ! buf ) YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); for ( i = 0; i < _yybytes_len; ++i ) buf[i] = yybytes[i]; buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; b = yy_scan_buffer(buf,n ); if ( ! b ) YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); /* It's okay to grow etc. this buffer, and we should throw it * away when we're done. */ b->yy_is_our_buffer = 1; return b; } #ifndef YY_EXIT_FAILURE #define YY_EXIT_FAILURE 2 #endif static void yy_fatal_error (yyconst char* msg ) { (void) fprintf( stderr, "%s\n", msg ); exit( YY_EXIT_FAILURE ); } /* Redefine yyless() so it works in section 3 code. */ #undef yyless #define yyless(n) \ do \ { \ /* Undo effects of setting up yytext. */ \ int yyless_macro_arg = (n); \ YY_LESS_LINENO(yyless_macro_arg);\ yytext[yyleng] = (yy_hold_char); \ (yy_c_buf_p) = yytext + yyless_macro_arg; \ (yy_hold_char) = *(yy_c_buf_p); \ *(yy_c_buf_p) = '\0'; \ yyleng = yyless_macro_arg; \ } \ while ( 0 ) /* Accessor methods (get/set functions) to struct members. */ /** Get the current line number. * */ int yyget_lineno (void) { return yylineno; } /** Get the input stream. * */ FILE *yyget_in (void) { return yyin; } /** Get the output stream. * */ FILE *yyget_out (void) { return yyout; } /** Get the length of the current token. * */ yy_size_t yyget_leng (void) { return yyleng; } /** Get the current token. * */ char *yyget_text (void) { return yytext; } /** Set the current line number. * @param line_number * */ void yyset_lineno (int line_number ) { yylineno = line_number; } /** Set the input stream. This does not discard the current * input buffer. * @param in_str A readable stream. * * @see yy_switch_to_buffer */ void yyset_in (FILE * in_str ) { yyin = in_str ; } void yyset_out (FILE * out_str ) { yyout = out_str ; } int yyget_debug (void) { return yy_flex_debug; } void yyset_debug (int bdebug ) { yy_flex_debug = bdebug ; } static int yy_init_globals (void) { /* Initialization is the same as for the non-reentrant scanner. * This function is called from yylex_destroy(), so don't allocate here. */ (yy_buffer_stack) = 0; (yy_buffer_stack_top) = 0; (yy_buffer_stack_max) = 0; (yy_c_buf_p) = (char *) 0; (yy_init) = 0; (yy_start) = 0; /* Defined in main.c */ #ifdef YY_STDINIT yyin = stdin; yyout = stdout; #else yyin = (FILE *) 0; yyout = (FILE *) 0; #endif /* For future reference: Set errno on error, since we are called by * yylex_init() */ return 0; } /* yylex_destroy is for both reentrant and non-reentrant scanners. */ int yylex_destroy (void) { /* Pop the buffer stack, destroying each element. */ while(YY_CURRENT_BUFFER){ yy_delete_buffer(YY_CURRENT_BUFFER ); YY_CURRENT_BUFFER_LVALUE = NULL; yypop_buffer_state(); } /* Destroy the stack itself. */ yyfree((yy_buffer_stack) ); (yy_buffer_stack) = NULL; /* Reset the globals. This is important in a non-reentrant scanner so the next time * yylex() is called, initialization will occur. */ yy_init_globals( ); return 0; } /* * Internal utility routines. */ #ifndef yytext_ptr static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) { register int i; for ( i = 0; i < n; ++i ) s1[i] = s2[i]; } #endif #ifdef YY_NEED_STRLEN static int yy_flex_strlen (yyconst char * s ) { register int n; for ( n = 0; s[n]; ++n ) ; return n; } #endif void *yyalloc (yy_size_t size ) { return (void *) malloc( size ); } void *yyrealloc (void * ptr, yy_size_t size ) { /* The cast to (char *) in the following accommodates both * implementations that use char* generic pointers, and those * that use void* generic pointers. It works with the latter * because both ANSI C and C++ allow castless assignment from * any pointer type to void*, and deal with argument conversions * as though doing an assignment. */ return (void *) realloc( (char *) ptr, size ); } void yyfree (void * ptr ) { free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ } #define YYTABLES_NAME "yytables" #line 107 "calclex.l" int yywrap () { return 1; } gcl-2.6.14/gmp4/demos/calc/calc.c0000644000175000017500000021402014360276512014720 0ustar cammcamm/* A Bison parser, made by GNU Bison 2.7.12-4996. */ /* Bison implementation for Yacc-like parsers in C Copyright (C) 1984, 1989-1990, 2000-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ /* C LALR(1) parser skeleton written by Richard Stallman, by simplifying the original so-called "semantic" parser. */ /* All symbols defined below should begin with yy or YY, to avoid infringing on user name space. This should be done even for local variables, as they might otherwise be expanded by user macros. There are some unavoidable exceptions within include files to define necessary library symbols; they are noted "INFRINGES ON USER NAME SPACE" below. */ /* Identify Bison output. */ #define YYBISON 1 /* Bison version. */ #define YYBISON_VERSION "2.7.12-4996" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" /* Pure parsers. */ #define YYPURE 0 /* Push parsers. */ #define YYPUSH 0 /* Pull parsers. */ #define YYPULL 1 /* Copy the first part of user declarations. */ /* Line 371 of yacc.c */ #line 1 "calc.y" /* A simple integer desk calculator using yacc and gmp. Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* This is a simple program, meant only to show one way to use GMP for this sort of thing. There's few features, and error checking is minimal. Standard input is read, calc_help() below shows the inputs accepted. Expressions are evaluated as they're read. If user defined functions were wanted it'd be necessary to build a parse tree like pexpr.c does, or a list of operations for a stack based evaluator. That would also make it possible to detect and optimize evaluations "mod m" like pexpr.c does. A stack is used for intermediate values in the expression evaluation, separate from the yacc parser stack. This is simple, makes error recovery easy, minimizes the junk around mpz calls in the rules, and saves initializing or clearing "mpz_t"s during a calculation. A disadvantage though is that variables must be copied to the stack to be worked on. A more sophisticated calculator or language system might be able to avoid that when executing a compiled or semi-compiled form. Avoiding repeated initializing and clearing of "mpz_t"s is important. In this program the time spent parsing is obviously much greater than any possible saving from this, but a proper calculator or language should take some trouble over it. Don't be surprised if an init/clear takes 3 or more times as long as a 10 limb addition, depending on the system (see the mpz_init_realloc_clear example in tune/README). */ #include #include #include #include "gmp.h" #define NO_CALC_H /* because it conflicts with normal calc.c stuff */ #include "calc-common.h" #define numberof(x) (sizeof (x) / sizeof ((x)[0])) void calc_help (void) { printf ("Examples:\n"); printf (" 2+3*4 expressions are evaluated\n"); printf (" x=5^6 variables a to z can be set and used\n"); printf ("Operators:\n"); printf (" + - * arithmetic\n"); printf (" / %% division and remainder (rounding towards negative infinity)\n"); printf (" ^ exponentiation\n"); printf (" ! factorial\n"); printf (" << >> left and right shifts\n"); printf (" <= >= > \\ comparisons, giving 1 if true, 0 if false\n"); printf (" == != < /\n"); printf (" && || logical and/or, giving 1 if true, 0 if false\n"); printf ("Functions:\n"); printf (" abs(n) absolute value\n"); printf (" bin(n,m) binomial coefficient\n"); printf (" fib(n) fibonacci number\n"); printf (" gcd(a,b,..) greatest common divisor\n"); printf (" kron(a,b) kronecker symbol\n"); printf (" lcm(a,b,..) least common multiple\n"); printf (" lucnum(n) lucas number\n"); printf (" nextprime(n) next prime after n\n"); printf (" powm(b,e,m) modulo powering, b^e%%m\n"); printf (" root(n,r) r-th root\n"); printf (" sqrt(n) square root\n"); printf ("Other:\n"); printf (" hex \\ set hex or decimal for input and output\n"); printf (" decimal / (\"0x\" can be used for hex too)\n"); printf (" quit exit program (EOF works too)\n"); printf (" ; statements are separated with a ; or newline\n"); printf (" \\ continue expressions with \\ before newline\n"); printf (" # xxx comments are # though to newline\n"); printf ("Hex numbers must be entered in upper case, to distinguish them from the\n"); printf ("variables a to f (like in bc).\n"); } int ibase = 0; int obase = 10; /* The stack is a fixed size, which means there's a limit on the nesting allowed in expressions. A more sophisticated program could let it grow dynamically. */ mpz_t stack[100]; mpz_ptr sp = stack[0]; #define CHECK_OVERFLOW() \ if (sp >= stack[numberof(stack)]) /* FIXME */ \ { \ fprintf (stderr, \ "Value stack overflow, too much nesting in expression\n"); \ YYERROR; \ } #define CHECK_EMPTY() \ if (sp != stack[0]) \ { \ fprintf (stderr, "Oops, expected the value stack to be empty\n"); \ sp = stack[0]; \ } mpz_t variable[26]; #define CHECK_VARIABLE(var) \ if ((var) < 0 || (var) >= numberof (variable)) \ { \ fprintf (stderr, "Oops, bad variable somehow: %d\n", var); \ YYERROR; \ } #define CHECK_UI(name,z) \ if (! mpz_fits_ulong_p (z)) \ { \ fprintf (stderr, "%s too big\n", name); \ YYERROR; \ } /* Line 371 of yacc.c */ #line 209 "calc.c" # ifndef YY_NULL # if defined __cplusplus && 201103L <= __cplusplus # define YY_NULL nullptr # else # define YY_NULL 0 # endif # endif /* Enabling verbose error messages. */ #ifdef YYERROR_VERBOSE # undef YYERROR_VERBOSE # define YYERROR_VERBOSE 1 #else # define YYERROR_VERBOSE 0 #endif /* In a future release of Bison, this section will be replaced by #include "y.tab.h". */ #ifndef YY_YY_Y_TAB_H_INCLUDED # define YY_YY_Y_TAB_H_INCLUDED /* Enabling traces. */ #ifndef YYDEBUG # define YYDEBUG 0 #endif #if YYDEBUG extern int yydebug; #endif /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE /* Put the tokens into the symbol table, so that GDB and other debuggers know about them. */ enum yytokentype { EOS = 258, BAD = 259, HELP = 260, HEX = 261, DECIMAL = 262, QUIT = 263, ABS = 264, BIN = 265, FIB = 266, GCD = 267, KRON = 268, LCM = 269, LUCNUM = 270, NEXTPRIME = 271, POWM = 272, ROOT = 273, SQRT = 274, NUMBER = 275, VARIABLE = 276, LOR = 277, LAND = 278, GE = 279, LE = 280, NE = 281, EQ = 282, RSHIFT = 283, LSHIFT = 284, UMINUS = 285 }; #endif /* Tokens. */ #define EOS 258 #define BAD 259 #define HELP 260 #define HEX 261 #define DECIMAL 262 #define QUIT 263 #define ABS 264 #define BIN 265 #define FIB 266 #define GCD 267 #define KRON 268 #define LCM 269 #define LUCNUM 270 #define NEXTPRIME 271 #define POWM 272 #define ROOT 273 #define SQRT 274 #define NUMBER 275 #define VARIABLE 276 #define LOR 277 #define LAND 278 #define GE 279 #define LE 280 #define NE 281 #define EQ 282 #define RSHIFT 283 #define LSHIFT 284 #define UMINUS 285 #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { /* Line 387 of yacc.c */ #line 142 "calc.y" char *str; int var; /* Line 387 of yacc.c */ #line 318 "calc.c" } YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 #endif extern YYSTYPE yylval; #ifdef YYPARSE_PARAM #if defined __STDC__ || defined __cplusplus int yyparse (void *YYPARSE_PARAM); #else int yyparse (); #endif #else /* ! YYPARSE_PARAM */ #if defined __STDC__ || defined __cplusplus int yyparse (void); #else int yyparse (); #endif #endif /* ! YYPARSE_PARAM */ #endif /* !YY_YY_Y_TAB_H_INCLUDED */ /* Copy the second part of user declarations. */ /* Line 390 of yacc.c */ #line 346 "calc.c" #ifdef short # undef short #endif #ifdef YYTYPE_UINT8 typedef YYTYPE_UINT8 yytype_uint8; #else typedef unsigned char yytype_uint8; #endif #ifdef YYTYPE_INT8 typedef YYTYPE_INT8 yytype_int8; #elif (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) typedef signed char yytype_int8; #else typedef short int yytype_int8; #endif #ifdef YYTYPE_UINT16 typedef YYTYPE_UINT16 yytype_uint16; #else typedef unsigned short int yytype_uint16; #endif #ifdef YYTYPE_INT16 typedef YYTYPE_INT16 yytype_int16; #else typedef short int yytype_int16; #endif #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ # elif defined size_t # define YYSIZE_T size_t # elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) # include /* INFRINGES ON USER NAME SPACE */ # define YYSIZE_T size_t # else # define YYSIZE_T unsigned int # endif #endif #define YYSIZE_MAXIMUM ((YYSIZE_T) -1) #ifndef YY_ # if defined YYENABLE_NLS && YYENABLE_NLS # if ENABLE_NLS # include /* INFRINGES ON USER NAME SPACE */ # define YY_(Msgid) dgettext ("bison-runtime", Msgid) # endif # endif # ifndef YY_ # define YY_(Msgid) Msgid # endif #endif #ifndef __attribute__ /* This feature is available in gcc versions 2.5 and later. */ # if (! defined __GNUC__ || __GNUC__ < 2 \ || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)) # define __attribute__(Spec) /* empty */ # endif #endif /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ # define YYUSE(E) ((void) (E)) #else # define YYUSE(E) /* empty */ #endif /* Identity function, used to suppress warnings about constant conditions. */ #ifndef lint # define YYID(N) (N) #else #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static int YYID (int yyi) #else static int YYID (yyi) int yyi; #endif { return yyi; } #endif #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ # ifdef YYSTACK_USE_ALLOCA # if YYSTACK_USE_ALLOCA # ifdef __GNUC__ # define YYSTACK_ALLOC __builtin_alloca # elif defined __BUILTIN_VA_ARG_INCR # include /* INFRINGES ON USER NAME SPACE */ # elif defined _AIX # define YYSTACK_ALLOC __alloca # elif defined _MSC_VER # include /* INFRINGES ON USER NAME SPACE */ # define alloca _alloca # else # define YYSTACK_ALLOC alloca # if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) # include /* INFRINGES ON USER NAME SPACE */ /* Use EXIT_SUCCESS as a witness for stdlib.h. */ # ifndef EXIT_SUCCESS # define EXIT_SUCCESS 0 # endif # endif # endif # endif # endif # ifdef YYSTACK_ALLOC /* Pacify GCC's `empty if-body' warning. */ # define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) # ifndef YYSTACK_ALLOC_MAXIMUM /* The OS might guarantee only one guard page at the bottom of the stack, and a page size can be as small as 4096 bytes. So we cannot safely invoke alloca (N) if N exceeds 4096. Use a slightly smaller number to allow for a few compiler-allocated temporary stack slots. */ # define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ # endif # else # define YYSTACK_ALLOC YYMALLOC # define YYSTACK_FREE YYFREE # ifndef YYSTACK_ALLOC_MAXIMUM # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM # endif # if (defined __cplusplus && ! defined EXIT_SUCCESS \ && ! ((defined YYMALLOC || defined malloc) \ && (defined YYFREE || defined free))) # include /* INFRINGES ON USER NAME SPACE */ # ifndef EXIT_SUCCESS # define EXIT_SUCCESS 0 # endif # endif # ifndef YYMALLOC # define YYMALLOC malloc # if ! defined malloc && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ # endif # endif # ifndef YYFREE # define YYFREE free # if ! defined free && ! defined EXIT_SUCCESS && (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif # endif #endif /* ! defined yyoverflow || YYERROR_VERBOSE */ #if (! defined yyoverflow \ && (! defined __cplusplus \ || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { yytype_int16 yyss_alloc; YYSTYPE yyvs_alloc; }; /* The size of the maximum gap between one aligned stack and the next. */ # define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) /* The size of an array large to enough to hold all stacks, each with N elements. */ # define YYSTACK_BYTES(N) \ ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + YYSTACK_GAP_MAXIMUM) # define YYCOPY_NEEDED 1 /* Relocate STACK from its old location to the new one. The local variables YYSIZE and YYSTACKSIZE give the old and new number of elements in the stack, and YYPTR gives the new location of the stack. Advance YYPTR to a properly aligned location for the next stack. */ # define YYSTACK_RELOCATE(Stack_alloc, Stack) \ do \ { \ YYSIZE_T yynewbytes; \ YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ Stack = &yyptr->Stack_alloc; \ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ yyptr += yynewbytes / sizeof (*yyptr); \ } \ while (YYID (0)) #endif #if defined YYCOPY_NEEDED && YYCOPY_NEEDED /* Copy COUNT objects from SRC to DST. The source and destination do not overlap. */ # ifndef YYCOPY # if defined __GNUC__ && 1 < __GNUC__ # define YYCOPY(Dst, Src, Count) \ __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) # else # define YYCOPY(Dst, Src, Count) \ do \ { \ YYSIZE_T yyi; \ for (yyi = 0; yyi < (Count); yyi++) \ (Dst)[yyi] = (Src)[yyi]; \ } \ while (YYID (0)) # endif # endif #endif /* !YYCOPY_NEEDED */ /* YYFINAL -- State number of the termination state. */ #define YYFINAL 41 /* YYLAST -- Last index in YYTABLE. */ #define YYLAST 552 /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 44 /* YYNNTS -- Number of nonterminals. */ #define YYNNTS 7 /* YYNRULES -- Number of rules. */ #define YYNRULES 49 /* YYNRULES -- Number of states. */ #define YYNSTATES 118 /* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 285 #define YYTRANSLATE(YYX) \ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) /* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ static const yytype_uint8 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 39, 2, 2, 2, 36, 2, 2, 41, 42, 34, 32, 43, 33, 2, 35, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 24, 40, 25, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 38, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 26, 27, 28, 29, 30, 31, 37 }; #if YYDEBUG /* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in YYRHS. */ static const yytype_uint8 yyprhs[] = { 0, 0, 3, 5, 8, 11, 15, 18, 19, 21, 25, 27, 29, 31, 33, 37, 41, 45, 49, 53, 57, 61, 65, 69, 72, 75, 79, 83, 87, 91, 95, 99, 103, 107, 112, 119, 124, 129, 136, 141, 146, 151, 160, 167, 172, 174, 176, 178, 182, 184 }; /* YYRHS -- A `-1'-separated list of the rules' RHS. */ static const yytype_int8 yyrhs[] = { 45, 0, -1, 47, -1, 46, 47, -1, 47, 3, -1, 46, 47, 3, -1, 1, 3, -1, -1, 48, -1, 21, 40, 48, -1, 5, -1, 6, -1, 7, -1, 8, -1, 41, 48, 42, -1, 48, 32, 48, -1, 48, 33, 48, -1, 48, 34, 48, -1, 48, 35, 48, -1, 48, 36, 48, -1, 48, 38, 48, -1, 48, 31, 48, -1, 48, 30, 48, -1, 48, 39, -1, 33, 48, -1, 48, 24, 48, -1, 48, 27, 48, -1, 48, 29, 48, -1, 48, 28, 48, -1, 48, 26, 48, -1, 48, 25, 48, -1, 48, 23, 48, -1, 48, 22, 48, -1, 9, 41, 48, 42, -1, 10, 41, 48, 43, 48, 42, -1, 11, 41, 48, 42, -1, 12, 41, 49, 42, -1, 13, 41, 48, 43, 48, 42, -1, 14, 41, 50, 42, -1, 15, 41, 48, 42, -1, 16, 41, 48, 42, -1, 17, 41, 48, 43, 48, 43, 48, 42, -1, 18, 41, 48, 43, 48, 42, -1, 19, 41, 48, 42, -1, 21, -1, 20, -1, 48, -1, 49, 43, 48, -1, 48, -1, 50, 43, 48, -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { 0, 167, 167, 168, 171, 172, 173, 175, 177, 182, 188, 189, 190, 191, 197, 198, 199, 200, 201, 202, 203, 205, 207, 209, 211, 213, 214, 215, 216, 217, 218, 220, 221, 223, 224, 226, 228, 229, 231, 232, 234, 235, 236, 238, 240, 246, 257, 258, 261, 262 }; #endif #if YYDEBUG || YYERROR_VERBOSE || 0 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = { "$end", "error", "$undefined", "EOS", "BAD", "HELP", "HEX", "DECIMAL", "QUIT", "ABS", "BIN", "FIB", "GCD", "KRON", "LCM", "LUCNUM", "NEXTPRIME", "POWM", "ROOT", "SQRT", "NUMBER", "VARIABLE", "LOR", "LAND", "'<'", "'>'", "GE", "LE", "NE", "EQ", "RSHIFT", "LSHIFT", "'+'", "'-'", "'*'", "'/'", "'%'", "UMINUS", "'^'", "'!'", "'='", "'('", "')'", "','", "$accept", "top", "statements", "statement", "e", "gcdlist", "lcmlist", YY_NULL }; #endif # ifdef YYPRINT /* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to token YYLEX-NUM. */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 60, 62, 279, 280, 281, 282, 283, 284, 43, 45, 42, 47, 37, 285, 94, 33, 61, 40, 41, 44 }; # endif /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint8 yyr1[] = { 0, 44, 45, 45, 46, 46, 46, 47, 47, 47, 47, 47, 47, 47, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 49, 49, 50, 50 }; /* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ static const yytype_uint8 yyr2[] = { 0, 2, 1, 2, 2, 3, 2, 0, 1, 3, 1, 1, 1, 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 4, 6, 4, 4, 6, 4, 4, 4, 8, 6, 4, 1, 1, 1, 3, 1, 3 }; /* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM. Performed when YYTABLE doesn't specify something else to do. Zero means the default is an error. */ static const yytype_uint8 yydefact[] = { 0, 0, 10, 11, 12, 13, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 45, 44, 0, 0, 0, 7, 2, 8, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 44, 24, 0, 1, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 0, 0, 0, 46, 0, 0, 48, 0, 0, 0, 0, 0, 0, 9, 14, 5, 32, 31, 25, 30, 29, 26, 28, 27, 22, 21, 15, 16, 17, 18, 19, 20, 33, 0, 35, 36, 0, 0, 38, 0, 39, 40, 0, 0, 43, 0, 47, 0, 49, 0, 0, 34, 37, 0, 42, 0, 41 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int8 yydefgoto[] = { -1, 21, 22, 23, 24, 65, 68 }; /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ #define YYPACT_NINF -39 static const yytype_int16 yypact[] = { 41, 3, -39, -39, -39, -39, 2, 4, 27, 32, 35, 36, 39, 42, 45, 46, 47, -39, -18, 124, 124, 89, 91, 87, 464, -39, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, -39, -36, 254, -39, 88, -39, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, -39, 275, 144, 296, 464, -38, 166, 464, 29, 317, 338, 188, 210, 359, 464, -39, -39, 481, 497, 513, 513, 513, 513, 513, 513, 31, 31, -15, -15, -36, -36, -36, -36, -39, 124, -39, -39, 124, 124, -39, 124, -39, -39, 124, 124, -39, 380, 464, 401, 464, 232, 422, -39, -39, 124, -39, 443, -39 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { -39, -39, -39, 70, -19, -39, -39 }; /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule which number is the opposite. If YYTABLE_NINF, syntax error. */ #define YYTABLE_NINF -8 static const yytype_int8 yytable[] = { 39, 40, 59, 60, 96, 97, 25, 61, 62, 63, 64, 66, 67, 69, 70, 71, 72, 73, 74, 56, 57, 58, 37, 59, 60, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, -7, 1, 26, -7, 27, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 54, 55, 56, 57, 58, 28, 59, 60, 99, 100, 29, 19, 106, 30, 31, 107, 108, 32, 109, 20, 33, 110, 111, 34, 35, 36, 41, 43, 76, 42, 0, 0, 116, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 19, 0, 0, 0, 0, 0, 0, 0, 20, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 19, 0, 0, 0, 0, 0, 0, 0, 20, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 0, 94, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 0, 98, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 0, 103, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 0, 104, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 0, 114, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 75, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 93, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 95, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 101, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 102, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 105, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 112, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 113, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 115, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 0, 0, 117, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60, -8, -8, -8, -8, -8, -8, 52, 53, 54, 55, 56, 57, 58, 0, 59, 60 }; #define yypact_value_is_default(Yystate) \ (!!((Yystate) == (-39))) #define yytable_value_is_error(Yytable_value) \ (!!((Yytable_value) == (-8))) static const yytype_int8 yycheck[] = { 19, 20, 38, 39, 42, 43, 3, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 34, 35, 36, 40, 38, 39, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 1, 41, 3, 41, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 32, 33, 34, 35, 36, 41, 38, 39, 42, 43, 41, 33, 94, 41, 41, 97, 98, 41, 100, 41, 41, 103, 104, 41, 41, 41, 0, 3, 3, 22, -1, -1, 114, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, -1, -1, 41, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, -1, -1, 41, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, -1, 43, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, -1, 43, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, -1, 43, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, -1, 43, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, -1, 43, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, -1, -1, 42, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, -1, 38, 39 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { 0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 33, 41, 45, 46, 47, 48, 3, 41, 41, 41, 41, 41, 41, 41, 41, 41, 41, 41, 40, 21, 48, 48, 0, 47, 3, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 38, 39, 48, 48, 48, 48, 49, 48, 48, 50, 48, 48, 48, 48, 48, 48, 42, 3, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 48, 42, 43, 42, 42, 43, 43, 42, 43, 42, 42, 43, 43, 42, 48, 48, 48, 48, 48, 48, 42, 42, 43, 42, 48, 42 }; #define yyerrok (yyerrstatus = 0) #define yyclearin (yychar = YYEMPTY) #define YYEMPTY (-2) #define YYEOF 0 #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab #define YYERROR goto yyerrorlab /* Like YYERROR except do call yyerror. This remains here temporarily to ease the transition to the new meaning of YYERROR, for GCC. Once GCC version 2 has supplanted version 1, this can go. However, YYFAIL appears to be in use. Nevertheless, it is formally deprecated in Bison 2.4.2's NEWS entry, where a plan to phase it out is discussed. */ #define YYFAIL goto yyerrlab #if defined YYFAIL /* This is here to suppress warnings from the GCC cpp's -Wunused-macros. Normally we don't worry about that warning, but some users do, and we want to make it easy for users to remove YYFAIL uses, which will produce warnings from Bison 2.5. */ #endif #define YYRECOVERING() (!!yyerrstatus) #define YYBACKUP(Token, Value) \ do \ if (yychar == YYEMPTY) \ { \ yychar = (Token); \ yylval = (Value); \ YYPOPSTACK (yylen); \ yystate = *yyssp; \ goto yybackup; \ } \ else \ { \ yyerror (YY_("syntax error: cannot back up")); \ YYERROR; \ } \ while (YYID (0)) /* Error token number */ #define YYTERROR 1 #define YYERRCODE 256 /* This macro is provided for backward compatibility. */ #ifndef YY_LOCATION_PRINT # define YY_LOCATION_PRINT(File, Loc) ((void) 0) #endif /* YYLEX -- calling `yylex' with the right arguments. */ #ifdef YYLEX_PARAM # define YYLEX yylex (YYLEX_PARAM) #else # define YYLEX yylex () #endif /* Enable debugging if requested. */ #if YYDEBUG # ifndef YYFPRINTF # include /* INFRINGES ON USER NAME SPACE */ # define YYFPRINTF fprintf # endif # define YYDPRINTF(Args) \ do { \ if (yydebug) \ YYFPRINTF Args; \ } while (YYID (0)) # define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ do { \ if (yydebug) \ { \ YYFPRINTF (stderr, "%s ", Title); \ yy_symbol_print (stderr, \ Type, Value); \ YYFPRINTF (stderr, "\n"); \ } \ } while (YYID (0)) /*--------------------------------. | Print this symbol on YYOUTPUT. | `--------------------------------*/ /*ARGSUSED*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) #else static void yy_symbol_value_print (yyoutput, yytype, yyvaluep) FILE *yyoutput; int yytype; YYSTYPE const * const yyvaluep; #endif { FILE *yyo = yyoutput; YYUSE (yyo); if (!yyvaluep) return; # ifdef YYPRINT if (yytype < YYNTOKENS) YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # else YYUSE (yyoutput); # endif YYUSE (yytype); } /*--------------------------------. | Print this symbol on YYOUTPUT. | `--------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep) #else static void yy_symbol_print (yyoutput, yytype, yyvaluep) FILE *yyoutput; int yytype; YYSTYPE const * const yyvaluep; #endif { if (yytype < YYNTOKENS) YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); else YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); yy_symbol_value_print (yyoutput, yytype, yyvaluep); YYFPRINTF (yyoutput, ")"); } /*------------------------------------------------------------------. | yy_stack_print -- Print the state stack from its BOTTOM up to its | | TOP (included). | `------------------------------------------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) #else static void yy_stack_print (yybottom, yytop) yytype_int16 *yybottom; yytype_int16 *yytop; #endif { YYFPRINTF (stderr, "Stack now"); for (; yybottom <= yytop; yybottom++) { int yybot = *yybottom; YYFPRINTF (stderr, " %d", yybot); } YYFPRINTF (stderr, "\n"); } # define YY_STACK_PRINT(Bottom, Top) \ do { \ if (yydebug) \ yy_stack_print ((Bottom), (Top)); \ } while (YYID (0)) /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yy_reduce_print (YYSTYPE *yyvsp, int yyrule) #else static void yy_reduce_print (yyvsp, yyrule) YYSTYPE *yyvsp; int yyrule; #endif { int yynrhs = yyr2[yyrule]; int yyi; unsigned long int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", yyrule - 1, yylno); /* The symbols being reduced. */ for (yyi = 0; yyi < yynrhs; yyi++) { YYFPRINTF (stderr, " $%d = ", yyi + 1); yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], &(yyvsp[(yyi + 1) - (yynrhs)]) ); YYFPRINTF (stderr, "\n"); } } # define YY_REDUCE_PRINT(Rule) \ do { \ if (yydebug) \ yy_reduce_print (yyvsp, Rule); \ } while (YYID (0)) /* Nonzero means print parse trace. It is left uninitialized so that multiple parsers can coexist. */ int yydebug; #else /* !YYDEBUG */ # define YYDPRINTF(Args) # define YY_SYMBOL_PRINT(Title, Type, Value, Location) # define YY_STACK_PRINT(Bottom, Top) # define YY_REDUCE_PRINT(Rule) #endif /* !YYDEBUG */ /* YYINITDEPTH -- initial size of the parser's stacks. */ #ifndef YYINITDEPTH # define YYINITDEPTH 200 #endif /* YYMAXDEPTH -- maximum size the stacks can grow to (effective only if the built-in stack extension method is used). Do not make this value too large; the results are undefined if YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) evaluated with infinite-precision integer arithmetic. */ #ifndef YYMAXDEPTH # define YYMAXDEPTH 10000 #endif #if YYERROR_VERBOSE # ifndef yystrlen # if defined __GLIBC__ && defined _STRING_H # define yystrlen strlen # else /* Return the length of YYSTR. */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static YYSIZE_T yystrlen (const char *yystr) #else static YYSIZE_T yystrlen (yystr) const char *yystr; #endif { YYSIZE_T yylen; for (yylen = 0; yystr[yylen]; yylen++) continue; return yylen; } # endif # endif # ifndef yystpcpy # if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE # define yystpcpy stpcpy # else /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in YYDEST. */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static char * yystpcpy (char *yydest, const char *yysrc) #else static char * yystpcpy (yydest, yysrc) char *yydest; const char *yysrc; #endif { char *yyd = yydest; const char *yys = yysrc; while ((*yyd++ = *yys++) != '\0') continue; return yyd - 1; } # endif # endif # ifndef yytnamerr /* Copy to YYRES the contents of YYSTR after stripping away unnecessary quotes and backslashes, so that it's suitable for yyerror. The heuristic is that double-quoting is unnecessary unless the string contains an apostrophe, a comma, or backslash (other than backslash-backslash). YYSTR is taken from yytname. If YYRES is null, do not copy; instead, return the length of what the result would have been. */ static YYSIZE_T yytnamerr (char *yyres, const char *yystr) { if (*yystr == '"') { YYSIZE_T yyn = 0; char const *yyp = yystr; for (;;) switch (*++yyp) { case '\'': case ',': goto do_not_strip_quotes; case '\\': if (*++yyp != '\\') goto do_not_strip_quotes; /* Fall through. */ default: if (yyres) yyres[yyn] = *yyp; yyn++; break; case '"': if (yyres) yyres[yyn] = '\0'; return yyn; } do_not_strip_quotes: ; } if (! yyres) return yystrlen (yystr); return yystpcpy (yyres, yystr) - yyres; } # endif /* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message about the unexpected token YYTOKEN for the state stack whose top is YYSSP. Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is not large enough to hold the message. In that case, also set *YYMSG_ALLOC to the required number of bytes. Return 2 if the required number of bytes is too large to store. */ static int yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, yytype_int16 *yyssp, int yytoken) { YYSIZE_T yysize0 = yytnamerr (YY_NULL, yytname[yytoken]); YYSIZE_T yysize = yysize0; enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; /* Internationalized format string. */ const char *yyformat = YY_NULL; /* Arguments of yyformat. */ char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; /* Number of reported tokens (one for the "unexpected", one per "expected"). */ int yycount = 0; /* There are many possibilities here to consider: - Assume YYFAIL is not used. It's too flawed to consider. See for details. YYERROR is fine as it does not invoke this function. - If this state is a consistent state with a default action, then the only way this function was invoked is if the default action is an error action. In that case, don't check for expected tokens because there are none. - The only way there can be no lookahead present (in yychar) is if this state is a consistent state with a default action. Thus, detecting the absence of a lookahead is sufficient to determine that there is no unexpected or expected token to report. In that case, just report a simple "syntax error". - Don't assume there isn't a lookahead just because this state is a consistent state with a default action. There might have been a previous inconsistent state, consistent state with a non-default action, or user semantic action that manipulated yychar. - Of course, the expected token list depends on states to have correct lookahead information, and it depends on the parser not to perform extra reductions after fetching a lookahead from the scanner and before detecting a syntax error. Thus, state merging (from LALR or IELR) and default reductions corrupt the expected token list. However, the list is correct for canonical LR with one exception: it will still contain any token that will not be accepted due to an error action in a later state. */ if (yytoken != YYEMPTY) { int yyn = yypact[*yyssp]; yyarg[yycount++] = yytname[yytoken]; if (!yypact_value_is_default (yyn)) { /* Start YYX at -YYN if negative to avoid negative indexes in YYCHECK. In other words, skip the first -YYN actions for this state because they are default actions. */ int yyxbegin = yyn < 0 ? -yyn : 0; /* Stay within bounds of both yycheck and yytname. */ int yychecklim = YYLAST - yyn + 1; int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; int yyx; for (yyx = yyxbegin; yyx < yyxend; ++yyx) if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR && !yytable_value_is_error (yytable[yyx + yyn])) { if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) { yycount = 1; yysize = yysize0; break; } yyarg[yycount++] = yytname[yyx]; { YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULL, yytname[yyx]); if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) return 2; yysize = yysize1; } } } } switch (yycount) { # define YYCASE_(N, S) \ case N: \ yyformat = S; \ break YYCASE_(0, YY_("syntax error")); YYCASE_(1, YY_("syntax error, unexpected %s")); YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); # undef YYCASE_ } { YYSIZE_T yysize1 = yysize + yystrlen (yyformat); if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) return 2; yysize = yysize1; } if (*yymsg_alloc < yysize) { *yymsg_alloc = 2 * yysize; if (! (yysize <= *yymsg_alloc && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; return 1; } /* Avoid sprintf, as that infringes on the user's name space. Don't have undefined behavior even if the translation produced a string with the wrong number of "%s"s. */ { char *yyp = *yymsg; int yyi = 0; while ((*yyp = *yyformat) != '\0') if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) { yyp += yytnamerr (yyp, yyarg[yyi++]); yyformat += 2; } else { yyp++; yyformat++; } } return 0; } #endif /* YYERROR_VERBOSE */ /*-----------------------------------------------. | Release the memory associated to this symbol. | `-----------------------------------------------*/ /*ARGSUSED*/ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) static void yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) #else static void yydestruct (yymsg, yytype, yyvaluep) const char *yymsg; int yytype; YYSTYPE *yyvaluep; #endif { YYUSE (yyvaluep); if (!yymsg) yymsg = "Deleting"; YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); YYUSE (yytype); } /* The lookahead symbol. */ int yychar; #ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN # define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN # define YY_IGNORE_MAYBE_UNINITIALIZED_END #endif #ifndef YY_INITIAL_VALUE # define YY_INITIAL_VALUE(Value) /* Nothing. */ #endif /* The semantic value of the lookahead symbol. */ YYSTYPE yylval YY_INITIAL_VALUE(yyval_default); /* Number of syntax errors so far. */ int yynerrs; /*----------. | yyparse. | `----------*/ #ifdef YYPARSE_PARAM #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) int yyparse (void *YYPARSE_PARAM) #else int yyparse (YYPARSE_PARAM) void *YYPARSE_PARAM; #endif #else /* ! YYPARSE_PARAM */ #if (defined __STDC__ || defined __C99__FUNC__ \ || defined __cplusplus || defined _MSC_VER) int yyparse (void) #else int yyparse () #endif #endif { int yystate; /* Number of tokens to shift before error messages enabled. */ int yyerrstatus; /* The stacks and their tools: `yyss': related to states. `yyvs': related to semantic values. Refer to the stacks through separate pointers, to allow yyoverflow to reallocate them elsewhere. */ /* The state stack. */ yytype_int16 yyssa[YYINITDEPTH]; yytype_int16 *yyss; yytype_int16 *yyssp; /* The semantic value stack. */ YYSTYPE yyvsa[YYINITDEPTH]; YYSTYPE *yyvs; YYSTYPE *yyvsp; YYSIZE_T yystacksize; int yyn; int yyresult; /* Lookahead token as an internal (translated) token number. */ int yytoken = 0; /* The variables used to return semantic value and location from the action routines. */ YYSTYPE yyval; #if YYERROR_VERBOSE /* Buffer for error messages, and its allocated size. */ char yymsgbuf[128]; char *yymsg = yymsgbuf; YYSIZE_T yymsg_alloc = sizeof yymsgbuf; #endif #define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) /* The number of symbols on the RHS of the reduced rule. Keep to zero when no symbol should be popped. */ int yylen = 0; yyssp = yyss = yyssa; yyvsp = yyvs = yyvsa; yystacksize = YYINITDEPTH; YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yynerrs = 0; yychar = YYEMPTY; /* Cause a token to be read. */ goto yysetstate; /*------------------------------------------------------------. | yynewstate -- Push a new state, which is found in yystate. | `------------------------------------------------------------*/ yynewstate: /* In all cases, when you get here, the value and location stacks have just been pushed. So pushing a state here evens the stacks. */ yyssp++; yysetstate: *yyssp = yystate; if (yyss + yystacksize - 1 <= yyssp) { /* Get the current used size of the three stacks, in elements. */ YYSIZE_T yysize = yyssp - yyss + 1; #ifdef yyoverflow { /* Give user a chance to reallocate the stack. Use copies of these so that the &'s don't force the real ones into memory. */ YYSTYPE *yyvs1 = yyvs; yytype_int16 *yyss1 = yyss; /* Each stack pointer address is followed by the size of the data in use in that stack, in bytes. This used to be a conditional around just the two extra args, but that might be undefined if yyoverflow is a macro. */ yyoverflow (YY_("memory exhausted"), &yyss1, yysize * sizeof (*yyssp), &yyvs1, yysize * sizeof (*yyvsp), &yystacksize); yyss = yyss1; yyvs = yyvs1; } #else /* no yyoverflow */ # ifndef YYSTACK_RELOCATE goto yyexhaustedlab; # else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) goto yyexhaustedlab; yystacksize *= 2; if (YYMAXDEPTH < yystacksize) yystacksize = YYMAXDEPTH; { yytype_int16 *yyss1 = yyss; union yyalloc *yyptr = (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); if (! yyptr) goto yyexhaustedlab; YYSTACK_RELOCATE (yyss_alloc, yyss); YYSTACK_RELOCATE (yyvs_alloc, yyvs); # undef YYSTACK_RELOCATE if (yyss1 != yyssa) YYSTACK_FREE (yyss1); } # endif #endif /* no yyoverflow */ yyssp = yyss + yysize - 1; yyvsp = yyvs + yysize - 1; YYDPRINTF ((stderr, "Stack size increased to %lu\n", (unsigned long int) yystacksize)); if (yyss + yystacksize - 1 <= yyssp) YYABORT; } YYDPRINTF ((stderr, "Entering state %d\n", yystate)); if (yystate == YYFINAL) YYACCEPT; goto yybackup; /*-----------. | yybackup. | `-----------*/ yybackup: /* Do appropriate processing given the current state. Read a lookahead token if we need one and don't already have one. */ /* First try to decide what to do without reference to lookahead token. */ yyn = yypact[yystate]; if (yypact_value_is_default (yyn)) goto yydefault; /* Not known => get a lookahead token if don't already have one. */ /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); yychar = YYLEX; } if (yychar <= YYEOF) { yychar = yytoken = YYEOF; YYDPRINTF ((stderr, "Now at end of input.\n")); } else { yytoken = YYTRANSLATE (yychar); YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); } /* If the proper action on seeing token YYTOKEN is to reduce or to detect an error, take that action. */ yyn += yytoken; if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) goto yydefault; yyn = yytable[yyn]; if (yyn <= 0) { if (yytable_value_is_error (yyn)) goto yyerrlab; yyn = -yyn; goto yyreduce; } /* Count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; /* Shift the lookahead token. */ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); /* Discard the shifted token. */ yychar = YYEMPTY; yystate = yyn; YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; YY_IGNORE_MAYBE_UNINITIALIZED_END goto yynewstate; /*-----------------------------------------------------------. | yydefault -- do the default action for the current state. | `-----------------------------------------------------------*/ yydefault: yyn = yydefact[yystate]; if (yyn == 0) goto yyerrlab; goto yyreduce; /*-----------------------------. | yyreduce -- Do a reduction. | `-----------------------------*/ yyreduce: /* yyn is the number of a rule to reduce with. */ yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: `$$ = $1'. Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison users should not rely upon it. Assigning to YYVAL unconditionally makes the parser a bit smaller, and it avoids a GCC warning that YYVAL may be used uninitialized. */ yyval = yyvsp[1-yylen]; YY_REDUCE_PRINT (yyn); switch (yyn) { case 6: /* Line 1787 of yacc.c */ #line 173 "calc.y" { sp = stack[0]; yyerrok; } break; case 8: /* Line 1787 of yacc.c */ #line 177 "calc.y" { mpz_out_str (stdout, obase, sp); putchar ('\n'); sp--; CHECK_EMPTY (); } break; case 9: /* Line 1787 of yacc.c */ #line 182 "calc.y" { CHECK_VARIABLE ((yyvsp[(1) - (3)].var)); mpz_swap (variable[(yyvsp[(1) - (3)].var)], sp); sp--; CHECK_EMPTY (); } break; case 10: /* Line 1787 of yacc.c */ #line 188 "calc.y" { calc_help (); } break; case 11: /* Line 1787 of yacc.c */ #line 189 "calc.y" { ibase = 16; obase = -16; } break; case 12: /* Line 1787 of yacc.c */ #line 190 "calc.y" { ibase = 0; obase = 10; } break; case 13: /* Line 1787 of yacc.c */ #line 191 "calc.y" { exit (0); } break; case 15: /* Line 1787 of yacc.c */ #line 198 "calc.y" { sp--; mpz_add (sp, sp, sp+1); } break; case 16: /* Line 1787 of yacc.c */ #line 199 "calc.y" { sp--; mpz_sub (sp, sp, sp+1); } break; case 17: /* Line 1787 of yacc.c */ #line 200 "calc.y" { sp--; mpz_mul (sp, sp, sp+1); } break; case 18: /* Line 1787 of yacc.c */ #line 201 "calc.y" { sp--; mpz_fdiv_q (sp, sp, sp+1); } break; case 19: /* Line 1787 of yacc.c */ #line 202 "calc.y" { sp--; mpz_fdiv_r (sp, sp, sp+1); } break; case 20: /* Line 1787 of yacc.c */ #line 203 "calc.y" { CHECK_UI ("Exponent", sp); sp--; mpz_pow_ui (sp, sp, mpz_get_ui (sp+1)); } break; case 21: /* Line 1787 of yacc.c */ #line 205 "calc.y" { CHECK_UI ("Shift count", sp); sp--; mpz_mul_2exp (sp, sp, mpz_get_ui (sp+1)); } break; case 22: /* Line 1787 of yacc.c */ #line 207 "calc.y" { CHECK_UI ("Shift count", sp); sp--; mpz_fdiv_q_2exp (sp, sp, mpz_get_ui (sp+1)); } break; case 23: /* Line 1787 of yacc.c */ #line 209 "calc.y" { CHECK_UI ("Factorial", sp); mpz_fac_ui (sp, mpz_get_ui (sp)); } break; case 24: /* Line 1787 of yacc.c */ #line 211 "calc.y" { mpz_neg (sp, sp); } break; case 25: /* Line 1787 of yacc.c */ #line 213 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) < 0); } break; case 26: /* Line 1787 of yacc.c */ #line 214 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) <= 0); } break; case 27: /* Line 1787 of yacc.c */ #line 215 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) == 0); } break; case 28: /* Line 1787 of yacc.c */ #line 216 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) != 0); } break; case 29: /* Line 1787 of yacc.c */ #line 217 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) >= 0); } break; case 30: /* Line 1787 of yacc.c */ #line 218 "calc.y" { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) > 0); } break; case 31: /* Line 1787 of yacc.c */ #line 220 "calc.y" { sp--; mpz_set_ui (sp, mpz_sgn (sp) && mpz_sgn (sp+1)); } break; case 32: /* Line 1787 of yacc.c */ #line 221 "calc.y" { sp--; mpz_set_ui (sp, mpz_sgn (sp) || mpz_sgn (sp+1)); } break; case 33: /* Line 1787 of yacc.c */ #line 223 "calc.y" { mpz_abs (sp, sp); } break; case 34: /* Line 1787 of yacc.c */ #line 224 "calc.y" { sp--; CHECK_UI ("Binomial base", sp+1); mpz_bin_ui (sp, sp, mpz_get_ui (sp+1)); } break; case 35: /* Line 1787 of yacc.c */ #line 226 "calc.y" { CHECK_UI ("Fibonacci", sp); mpz_fib_ui (sp, mpz_get_ui (sp)); } break; case 37: /* Line 1787 of yacc.c */ #line 229 "calc.y" { sp--; mpz_set_si (sp, mpz_kronecker (sp, sp+1)); } break; case 39: /* Line 1787 of yacc.c */ #line 232 "calc.y" { CHECK_UI ("Lucas number", sp); mpz_lucnum_ui (sp, mpz_get_ui (sp)); } break; case 40: /* Line 1787 of yacc.c */ #line 234 "calc.y" { mpz_nextprime (sp, sp); } break; case 41: /* Line 1787 of yacc.c */ #line 235 "calc.y" { sp -= 2; mpz_powm (sp, sp, sp+1, sp+2); } break; case 42: /* Line 1787 of yacc.c */ #line 236 "calc.y" { sp--; CHECK_UI ("Nth-root", sp+1); mpz_root (sp, sp, mpz_get_ui (sp+1)); } break; case 43: /* Line 1787 of yacc.c */ #line 238 "calc.y" { mpz_sqrt (sp, sp); } break; case 44: /* Line 1787 of yacc.c */ #line 240 "calc.y" { sp++; CHECK_OVERFLOW (); CHECK_VARIABLE ((yyvsp[(1) - (1)].var)); mpz_set (sp, variable[(yyvsp[(1) - (1)].var)]); } break; case 45: /* Line 1787 of yacc.c */ #line 246 "calc.y" { sp++; CHECK_OVERFLOW (); if (mpz_set_str (sp, (yyvsp[(1) - (1)].str), ibase) != 0) { fprintf (stderr, "Invalid number: %s\n", (yyvsp[(1) - (1)].str)); YYERROR; } } break; case 47: /* Line 1787 of yacc.c */ #line 258 "calc.y" { sp--; mpz_gcd (sp, sp, sp+1); } break; case 49: /* Line 1787 of yacc.c */ #line 262 "calc.y" { sp--; mpz_lcm (sp, sp, sp+1); } break; /* Line 1787 of yacc.c */ #line 1968 "calc.c" default: break; } /* User semantic actions sometimes alter yychar, and that requires that yytoken be updated with the new translation. We take the approach of translating immediately before every use of yytoken. One alternative is translating here after every semantic action, but that translation would be missed if the semantic action invokes YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an incorrect destructor might then be invoked immediately. In the case of YYERROR or YYBACKUP, subsequent parser actions might lead to an incorrect destructor call or verbose syntax error message before the lookahead is translated. */ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); *++yyvsp = yyval; /* Now `shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ yyn = yyr1[yyn]; yystate = yypgoto[yyn - YYNTOKENS] + *yyssp; if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp) yystate = yytable[yystate]; else yystate = yydefgoto[yyn - YYNTOKENS]; goto yynewstate; /*------------------------------------. | yyerrlab -- here on detecting error | `------------------------------------*/ yyerrlab: /* Make sure we have latest lookahead translation. See comments at user semantic actions for why this is necessary. */ yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { ++yynerrs; #if ! YYERROR_VERBOSE yyerror (YY_("syntax error")); #else # define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ yyssp, yytoken) { char const *yymsgp = YY_("syntax error"); int yysyntax_error_status; yysyntax_error_status = YYSYNTAX_ERROR; if (yysyntax_error_status == 0) yymsgp = yymsg; else if (yysyntax_error_status == 1) { if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); if (!yymsg) { yymsg = yymsgbuf; yymsg_alloc = sizeof yymsgbuf; yysyntax_error_status = 2; } else { yysyntax_error_status = YYSYNTAX_ERROR; yymsgp = yymsg; } } yyerror (yymsgp); if (yysyntax_error_status == 2) goto yyexhaustedlab; } # undef YYSYNTAX_ERROR #endif } if (yyerrstatus == 3) { /* If just tried and failed to reuse lookahead token after an error, discard it. */ if (yychar <= YYEOF) { /* Return failure if at end of input. */ if (yychar == YYEOF) YYABORT; } else { yydestruct ("Error: discarding", yytoken, &yylval); yychar = YYEMPTY; } } /* Else will try to reuse lookahead token after shifting the error token. */ goto yyerrlab1; /*---------------------------------------------------. | yyerrorlab -- error raised explicitly by YYERROR. | `---------------------------------------------------*/ yyerrorlab: /* Pacify compilers like GCC when the user code never invokes YYERROR and the label yyerrorlab therefore never appears in user code. */ if (/*CONSTCOND*/ 0) goto yyerrorlab; /* Do not reclaim the symbols of the rule which action triggered this YYERROR. */ YYPOPSTACK (yylen); yylen = 0; YY_STACK_PRINT (yyss, yyssp); yystate = *yyssp; goto yyerrlab1; /*-------------------------------------------------------------. | yyerrlab1 -- common code for both syntax error and YYERROR. | `-------------------------------------------------------------*/ yyerrlab1: yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; if (!yypact_value_is_default (yyn)) { yyn += YYTERROR; if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) { yyn = yytable[yyn]; if (0 < yyn) break; } } /* Pop the current state because it cannot handle the error token. */ if (yyssp == yyss) YYABORT; yydestruct ("Error: popping", yystos[yystate], yyvsp); YYPOPSTACK (1); yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; YY_IGNORE_MAYBE_UNINITIALIZED_END /* Shift the error token. */ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); yystate = yyn; goto yynewstate; /*-------------------------------------. | yyacceptlab -- YYACCEPT comes here. | `-------------------------------------*/ yyacceptlab: yyresult = 0; goto yyreturn; /*-----------------------------------. | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ yyabortlab: yyresult = 1; goto yyreturn; #if !defined yyoverflow || YYERROR_VERBOSE /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | `-------------------------------------------------*/ yyexhaustedlab: yyerror (YY_("memory exhausted")); yyresult = 2; /* Fall through. */ #endif yyreturn: if (yychar != YYEMPTY) { /* Make sure we have latest lookahead translation. See comments at user semantic actions for why this is necessary. */ yytoken = YYTRANSLATE (yychar); yydestruct ("Cleanup: discarding lookahead", yytoken, &yylval); } /* Do not reclaim the symbols of the rule which action triggered this YYABORT or YYACCEPT. */ YYPOPSTACK (yylen); YY_STACK_PRINT (yyss, yyssp); while (yyssp != yyss) { yydestruct ("Cleanup: popping", yystos[*yyssp], yyvsp); YYPOPSTACK (1); } #ifndef yyoverflow if (yyss != yyssa) YYSTACK_FREE (yyss); #endif #if YYERROR_VERBOSE if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); #endif /* Make sure YYID is used. */ return YYID (yyresult); } /* Line 2050 of yacc.c */ #line 264 "calc.y" yyerror (char *s) { fprintf (stderr, "%s\n", s); } int calc_option_readline = -1; int main (int argc, char *argv[]) { int i; for (i = 1; i < argc; i++) { if (strcmp (argv[i], "--readline") == 0) calc_option_readline = 1; else if (strcmp (argv[i], "--noreadline") == 0) calc_option_readline = 0; else if (strcmp (argv[i], "--help") == 0) { printf ("Usage: calc [--option]...\n"); printf (" --readline use readline\n"); printf (" --noreadline don't use readline\n"); printf (" --help this message\n"); printf ("Readline is only available when compiled in,\n"); printf ("and in that case it's the default on a tty.\n"); exit (0); } else { fprintf (stderr, "Unrecognised option: %s\n", argv[i]); exit (1); } } #if WITH_READLINE calc_init_readline (); #else if (calc_option_readline == 1) { fprintf (stderr, "Readline support not available\n"); exit (1); } #endif for (i = 0; i < numberof (variable); i++) mpz_init (variable[i]); for (i = 0; i < numberof (stack); i++) mpz_init (stack[i]); return yyparse (); } gcl-2.6.14/gmp4/demos/calc/calclex.l0000644000175000017500000000545214360276512015451 0ustar cammcamm/* Lexical analyzer for calc program. Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ %{ #include #include "calc-common.h" #if WITH_READLINE /* Let GNU flex use readline. See the calcread.c redefined input() for a way that might work for a standard lex too. */ #define YY_INPUT(buf,result,max_size) \ result = calc_input (buf, max_size); #endif /* Non-zero when reading the second or subsequent line of an expression, used to give a different prompt when using readline. */ int calc_more_input = 0; const struct calc_keywords_t calc_keywords[] = { { "abs", ABS }, { "bin", BIN }, { "decimal", DECIMAL }, { "fib", FIB }, { "hex", HEX }, { "help", HELP }, { "gcd", GCD }, { "kron", KRON }, { "lcm", LCM }, { "lucnum", LUCNUM }, { "nextprime", NEXTPRIME }, { "powm", POWM }, { "quit", QUIT }, { "root", ROOT }, { "sqrt", SQRT }, { NULL } }; %} %% [ \t\f] { /* white space is skipped */ } [;\n] { /* semicolon or newline separates statements */ calc_more_input = 0; return EOS; } \\\n { /* escaped newlines are skipped */ } #(([^\\\n]*)\\)+\n { /* comment through to escaped newline is skipped */ } #[^\n]*\n { /* comment through to newline is a separator */ calc_more_input = 0; return EOS; } #[^\n]* { /* comment through to EOF skipped */ } [-+*/%()<>^!=,] { return yytext[0]; } "<=" { return LE; } ">=" { return GE; } "==" { return EQ; } "!=" { return NE; } "<<" { return LSHIFT; } ">>" { return RSHIFT; } "&&" { return LAND; } "||" { return LOR; } (0[xX])?[0-9A-F]+ { yylval.str = yytext; return NUMBER; } [a-zA-Z][a-zA-Z0-9]* { int i; for (i = 0; calc_keywords[i].name != NULL; i++) if (strcmp (yytext, calc_keywords[i].name) == 0) return calc_keywords[i].value; if (yytext[0] >= 'a' && yytext[0] <= 'z' && yytext[1] == '\0') { yylval.var = yytext[0] - 'a'; return VARIABLE; } return BAD; } . { return BAD; } %% int yywrap () { return 1; } gcl-2.6.14/gmp4/demos/calc/calc-config-h.in0000644000175000017500000000152714360276512016602 0ustar cammcamm/* Templates for calc program configuration. -*- mode:c -*- Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* Define if GNU readline should be used. */ #define WITH_READLINE @WITH_READLINE_01@ gcl-2.6.14/gmp4/demos/calc/Makefile.am0000644000175000017500000000303714360276512015712 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 2000-2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. INCLUDES = -I$(top_srcdir) # $(LEXLIB) is not actually needed for flex (which means the distributed # calclex.c), but it's included here for the benefit of anyone rebuilding # with some other lex. # LDADD = $(top_builddir)/libgmp.la $(LIBREADLINE) $(LIBCURSES) $(LEXLIB) EXTRA_PROGRAMS = calc AM_YFLAGS = -d calc_SOURCES = calc.y calclex.l calcread.c calc-common.h BUILT_SOURCES = calc.h CLEANFILES = $(EXTRA_PROGRAMS) allprogs: $(EXTRA_PROGRAMS) gcl-2.6.14/gmp4/demos/calc/calcread.c0000644000175000017500000000744014360276512015562 0ustar cammcamm/* Readline support for calc program. Copyright 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #include "calc-common.h" #if WITH_READLINE #include /* for FILE for old versions of readline/readline.h */ #include /* for free */ #include /* for strdup */ #include /* for isatty */ #include #include #include "gmp.h" /* change this to "#define TRACE(x) x" for a few diagnostics */ #define TRACE(x) #define MIN(x,y) ((x) < (y) ? (x) : (y)) char * calc_completion_entry (const char *text, int state) { static int index, len; char *name; if (!state) { index = 0; len = strlen (text); } TRACE (printf ("calc_completion_entry %s %d, index=%d len=%d\n", text, state, index, len)); while ((name = calc_keywords[index].name) != NULL) { index++; if (memcmp (name, text, len) == 0) return (strdup (name)); } return NULL; } void calc_init_readline (void) { /* By default use readline when the input is a tty. It's a bit contrary to the GNU interface conventions to make the behaviour depend on where the input is coming from, but this is pretty convenient. */ if (calc_option_readline == -1) { calc_option_readline = isatty (fileno (stdin)); TRACE (printf ("calc_option_readline %d\n", calc_option_readline)); } if (calc_option_readline) { printf ("GNU MP demo calculator program, gmp version %s\n", gmp_version); printf ("Type \"help\" for help.\n"); rl_readline_name = "gmp-calc"; rl_completion_entry_function = calc_completion_entry; } } /* This function is supposed to return YY_NULL to indicate EOF, but that constant is only in calclex.c and we don't want to clutter calclex.l with this readline stuff, so instead just hard code 0 for YY_NULL. That's it's defined value on unix anyway. */ int calc_input (char *buf, size_t max_size) { if (calc_option_readline) { static char *line = NULL; static size_t line_size = 0; static size_t upto = 0; size_t copy_size; if (upto >= line_size) { if (line != NULL) free (line); line = readline (calc_more_input ? "more> " : "> "); calc_more_input = 1; if (line == NULL) return 0; TRACE (printf ("readline: %s\n", line)); if (line[0] != '\0') add_history (line); line_size = strlen (line); line[line_size] = '\n'; line_size++; upto = 0; } copy_size = MIN (line_size-upto, max_size); memcpy (buf, line+upto, copy_size); upto += copy_size; return copy_size; } else { /* not readline */ return fread (buf, 1, max_size, stdin); } } /* This redefined input() might let a traditional lex use the readline support here. Apparently POSIX doesn't specify whether an override like this will work, so maybe it'll work or maybe it won't. This function is also not particularly efficient, but don't worry about that, since flex is the preferred parser. */ int input (void) { char c; if (calc_input (&c, 1) != 1) return EOF; else return (int) c; } #endif /* WITH_READLINE */ gcl-2.6.14/gmp4/demos/calc/calc-common.h0000644000175000017500000000211714360276512016215 0ustar cammcamm/* Prototypes etc for calc program. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #include /* for size_t */ #ifndef NO_CALC_H #include "calc.h" #endif #include "calc-config.h" struct calc_keywords_t { char *name; int value; }; extern int calc_option_readline; extern int calc_more_input; extern const struct calc_keywords_t calc_keywords[]; int calc_input (char *buf, size_t max_size); void calc_init_readline (void); gcl-2.6.14/gmp4/demos/calc/calc.y0000644000175000017500000002632714360276512014761 0ustar cammcamm%{ /* A simple integer desk calculator using yacc and gmp. Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* This is a simple program, meant only to show one way to use GMP for this sort of thing. There's few features, and error checking is minimal. Standard input is read, calc_help() below shows the inputs accepted. Expressions are evaluated as they're read. If user defined functions were wanted it'd be necessary to build a parse tree like pexpr.c does, or a list of operations for a stack based evaluator. That would also make it possible to detect and optimize evaluations "mod m" like pexpr.c does. A stack is used for intermediate values in the expression evaluation, separate from the yacc parser stack. This is simple, makes error recovery easy, minimizes the junk around mpz calls in the rules, and saves initializing or clearing "mpz_t"s during a calculation. A disadvantage though is that variables must be copied to the stack to be worked on. A more sophisticated calculator or language system might be able to avoid that when executing a compiled or semi-compiled form. Avoiding repeated initializing and clearing of "mpz_t"s is important. In this program the time spent parsing is obviously much greater than any possible saving from this, but a proper calculator or language should take some trouble over it. Don't be surprised if an init/clear takes 3 or more times as long as a 10 limb addition, depending on the system (see the mpz_init_realloc_clear example in tune/README). */ #include #include #include #include "gmp.h" #define NO_CALC_H /* because it conflicts with normal calc.c stuff */ #include "calc-common.h" #define numberof(x) (sizeof (x) / sizeof ((x)[0])) void calc_help (void) { printf ("Examples:\n"); printf (" 2+3*4 expressions are evaluated\n"); printf (" x=5^6 variables a to z can be set and used\n"); printf ("Operators:\n"); printf (" + - * arithmetic\n"); printf (" / %% division and remainder (rounding towards negative infinity)\n"); printf (" ^ exponentiation\n"); printf (" ! factorial\n"); printf (" << >> left and right shifts\n"); printf (" <= >= > \\ comparisons, giving 1 if true, 0 if false\n"); printf (" == != < /\n"); printf (" && || logical and/or, giving 1 if true, 0 if false\n"); printf ("Functions:\n"); printf (" abs(n) absolute value\n"); printf (" bin(n,m) binomial coefficient\n"); printf (" fib(n) fibonacci number\n"); printf (" gcd(a,b,..) greatest common divisor\n"); printf (" kron(a,b) kronecker symbol\n"); printf (" lcm(a,b,..) least common multiple\n"); printf (" lucnum(n) lucas number\n"); printf (" nextprime(n) next prime after n\n"); printf (" powm(b,e,m) modulo powering, b^e%%m\n"); printf (" root(n,r) r-th root\n"); printf (" sqrt(n) square root\n"); printf ("Other:\n"); printf (" hex \\ set hex or decimal for input and output\n"); printf (" decimal / (\"0x\" can be used for hex too)\n"); printf (" quit exit program (EOF works too)\n"); printf (" ; statements are separated with a ; or newline\n"); printf (" \\ continue expressions with \\ before newline\n"); printf (" # xxx comments are # though to newline\n"); printf ("Hex numbers must be entered in upper case, to distinguish them from the\n"); printf ("variables a to f (like in bc).\n"); } int ibase = 0; int obase = 10; /* The stack is a fixed size, which means there's a limit on the nesting allowed in expressions. A more sophisticated program could let it grow dynamically. */ mpz_t stack[100]; mpz_ptr sp = stack[0]; #define CHECK_OVERFLOW() \ if (sp >= stack[numberof(stack)]) /* FIXME */ \ { \ fprintf (stderr, \ "Value stack overflow, too much nesting in expression\n"); \ YYERROR; \ } #define CHECK_EMPTY() \ if (sp != stack[0]) \ { \ fprintf (stderr, "Oops, expected the value stack to be empty\n"); \ sp = stack[0]; \ } mpz_t variable[26]; #define CHECK_VARIABLE(var) \ if ((var) < 0 || (var) >= numberof (variable)) \ { \ fprintf (stderr, "Oops, bad variable somehow: %d\n", var); \ YYERROR; \ } #define CHECK_UI(name,z) \ if (! mpz_fits_ulong_p (z)) \ { \ fprintf (stderr, "%s too big\n", name); \ YYERROR; \ } %} %union { char *str; int var; } %token EOS BAD %token HELP HEX DECIMAL QUIT %token ABS BIN FIB GCD KRON LCM LUCNUM NEXTPRIME POWM ROOT SQRT %token NUMBER %token VARIABLE /* operators, increasing precedence */ %left LOR %left LAND %nonassoc '<' '>' EQ NE LE GE %left LSHIFT RSHIFT %left '+' '-' %left '*' '/' '%' %nonassoc UMINUS %right '^' %nonassoc '!' %% top: statement | statements statement; statements: statement EOS | statements statement EOS | error EOS { sp = stack[0]; yyerrok; }; statement: /* empty */ | e { mpz_out_str (stdout, obase, sp); putchar ('\n'); sp--; CHECK_EMPTY (); } | VARIABLE '=' e { CHECK_VARIABLE ($1); mpz_swap (variable[$1], sp); sp--; CHECK_EMPTY (); } | HELP { calc_help (); } | HEX { ibase = 16; obase = -16; } | DECIMAL { ibase = 0; obase = 10; } | QUIT { exit (0); }; /* "e" leaves it's value on the top of the mpz stack. A rule like "e '+' e" will have done a reduction for the first "e" first and the second "e" second, so the code receives the values in that order on the stack. */ e: '(' e ')' /* value on stack */ | e '+' e { sp--; mpz_add (sp, sp, sp+1); } | e '-' e { sp--; mpz_sub (sp, sp, sp+1); } | e '*' e { sp--; mpz_mul (sp, sp, sp+1); } | e '/' e { sp--; mpz_fdiv_q (sp, sp, sp+1); } | e '%' e { sp--; mpz_fdiv_r (sp, sp, sp+1); } | e '^' e { CHECK_UI ("Exponent", sp); sp--; mpz_pow_ui (sp, sp, mpz_get_ui (sp+1)); } | e LSHIFT e { CHECK_UI ("Shift count", sp); sp--; mpz_mul_2exp (sp, sp, mpz_get_ui (sp+1)); } | e RSHIFT e { CHECK_UI ("Shift count", sp); sp--; mpz_fdiv_q_2exp (sp, sp, mpz_get_ui (sp+1)); } | e '!' { CHECK_UI ("Factorial", sp); mpz_fac_ui (sp, mpz_get_ui (sp)); } | '-' e %prec UMINUS { mpz_neg (sp, sp); } | e '<' e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) < 0); } | e LE e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) <= 0); } | e EQ e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) == 0); } | e NE e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) != 0); } | e GE e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) >= 0); } | e '>' e { sp--; mpz_set_ui (sp, mpz_cmp (sp, sp+1) > 0); } | e LAND e { sp--; mpz_set_ui (sp, mpz_sgn (sp) && mpz_sgn (sp+1)); } | e LOR e { sp--; mpz_set_ui (sp, mpz_sgn (sp) || mpz_sgn (sp+1)); } | ABS '(' e ')' { mpz_abs (sp, sp); } | BIN '(' e ',' e ')' { sp--; CHECK_UI ("Binomial base", sp+1); mpz_bin_ui (sp, sp, mpz_get_ui (sp+1)); } | FIB '(' e ')' { CHECK_UI ("Fibonacci", sp); mpz_fib_ui (sp, mpz_get_ui (sp)); } | GCD '(' gcdlist ')' /* value on stack */ | KRON '(' e ',' e ')' { sp--; mpz_set_si (sp, mpz_kronecker (sp, sp+1)); } | LCM '(' lcmlist ')' /* value on stack */ | LUCNUM '(' e ')' { CHECK_UI ("Lucas number", sp); mpz_lucnum_ui (sp, mpz_get_ui (sp)); } | NEXTPRIME '(' e ')' { mpz_nextprime (sp, sp); } | POWM '(' e ',' e ',' e ')' { sp -= 2; mpz_powm (sp, sp, sp+1, sp+2); } | ROOT '(' e ',' e ')' { sp--; CHECK_UI ("Nth-root", sp+1); mpz_root (sp, sp, mpz_get_ui (sp+1)); } | SQRT '(' e ')' { mpz_sqrt (sp, sp); } | VARIABLE { sp++; CHECK_OVERFLOW (); CHECK_VARIABLE ($1); mpz_set (sp, variable[$1]); } | NUMBER { sp++; CHECK_OVERFLOW (); if (mpz_set_str (sp, $1, ibase) != 0) { fprintf (stderr, "Invalid number: %s\n", $1); YYERROR; } }; gcdlist: e /* value on stack */ | gcdlist ',' e { sp--; mpz_gcd (sp, sp, sp+1); }; lcmlist: e /* value on stack */ | lcmlist ',' e { sp--; mpz_lcm (sp, sp, sp+1); }; %% yyerror (char *s) { fprintf (stderr, "%s\n", s); } int calc_option_readline = -1; int main (int argc, char *argv[]) { int i; for (i = 1; i < argc; i++) { if (strcmp (argv[i], "--readline") == 0) calc_option_readline = 1; else if (strcmp (argv[i], "--noreadline") == 0) calc_option_readline = 0; else if (strcmp (argv[i], "--help") == 0) { printf ("Usage: calc [--option]...\n"); printf (" --readline use readline\n"); printf (" --noreadline don't use readline\n"); printf (" --help this message\n"); printf ("Readline is only available when compiled in,\n"); printf ("and in that case it's the default on a tty.\n"); exit (0); } else { fprintf (stderr, "Unrecognised option: %s\n", argv[i]); exit (1); } } #if WITH_READLINE calc_init_readline (); #else if (calc_option_readline == 1) { fprintf (stderr, "Readline support not available\n"); exit (1); } #endif for (i = 0; i < numberof (variable); i++) mpz_init (variable[i]); for (i = 0; i < numberof (stack); i++) mpz_init (stack[i]); return yyparse (); } gcl-2.6.14/gmp4/demos/calc/calc.h0000644000175000017500000000675214360276512014740 0ustar cammcamm/* A Bison parser, made by GNU Bison 2.7.12-4996. */ /* Bison interface for Yacc-like parsers in C Copyright (C) 1984, 1989-1990, 2000-2013 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work under terms of your choice, so long as that work isn't itself a parser generator using the skeleton or a modified version thereof as a parser skeleton. Alternatively, if you modify or redistribute the parser skeleton itself, you may (at your option) remove this special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ #ifndef YY_YY_CALC_H_INCLUDED # define YY_YY_CALC_H_INCLUDED /* Enabling traces. */ #ifndef YYDEBUG # define YYDEBUG 0 #endif #if YYDEBUG extern int yydebug; #endif /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE /* Put the tokens into the symbol table, so that GDB and other debuggers know about them. */ enum yytokentype { EOS = 258, BAD = 259, HELP = 260, HEX = 261, DECIMAL = 262, QUIT = 263, ABS = 264, BIN = 265, FIB = 266, GCD = 267, KRON = 268, LCM = 269, LUCNUM = 270, NEXTPRIME = 271, POWM = 272, ROOT = 273, SQRT = 274, NUMBER = 275, VARIABLE = 276, LOR = 277, LAND = 278, GE = 279, LE = 280, NE = 281, EQ = 282, RSHIFT = 283, LSHIFT = 284, UMINUS = 285 }; #endif /* Tokens. */ #define EOS 258 #define BAD 259 #define HELP 260 #define HEX 261 #define DECIMAL 262 #define QUIT 263 #define ABS 264 #define BIN 265 #define FIB 266 #define GCD 267 #define KRON 268 #define LCM 269 #define LUCNUM 270 #define NEXTPRIME 271 #define POWM 272 #define ROOT 273 #define SQRT 274 #define NUMBER 275 #define VARIABLE 276 #define LOR 277 #define LAND 278 #define GE 279 #define LE 280 #define NE 281 #define EQ 282 #define RSHIFT 283 #define LSHIFT 284 #define UMINUS 285 #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { /* Line 2053 of yacc.c */ #line 142 "calc.y" char *str; int var; /* Line 2053 of yacc.c */ #line 123 "calc.h" } YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 #endif extern YYSTYPE yylval; #ifdef YYPARSE_PARAM #if defined __STDC__ || defined __cplusplus int yyparse (void *YYPARSE_PARAM); #else int yyparse (); #endif #else /* ! YYPARSE_PARAM */ #if defined __STDC__ || defined __cplusplus int yyparse (void); #else int yyparse (); #endif #endif /* ! YYPARSE_PARAM */ #endif /* !YY_YY_CALC_H_INCLUDED */ gcl-2.6.14/gmp4/demos/calc/README0000644000175000017500000000407614360276512014542 0ustar cammcammCopyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. DEMONSTRATION CALCULATOR PROGRAM This is a simple program, meant only to show one way to use GMP with yacc and lex to make a calculator. Usage and comments on the implementation can be found in calc.y. Within a GMP build tree, the generated Makefile can be used to build the program, make calc (or on a DOS system, "make calc.exe"). Elsewhere, once GMP has been installed, the program can be compiled with for instance gcc calc.c calclex.c -lgmp -o calc Or if GNU readline is used then gcc calc.c calclex.c calcread.c -lgmp -lreadline -o calc (again, on a DOS system "-o calc.exe"). Readline support can be enabled or disabled in calc-config.h. That file is created by the GMP ./configure based on the --with-readline option. The default is --with-readline=detect, which means to use readline if available. "yes" can be used to force it to be used, or "no" to not use it. The supplied calc.c was generated by GNU bison, but a standard yacc should work too. The supplied calclex.c was generated by GNU flex, but a standard lex should work too. The readline support may or may not work with a standard lex (see comments with input() in calcread.c). Note also that a standard lex will require its library "-ll" on the compile command line. "./configure" sets this up in the GMP build tree Makefile. ---------------- Local variables: mode: text fill-column: 76 End: gcl-2.6.14/gmp4/demos/calc/Makefile.in0000644000175000017500000004710314360276512015725 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 2000-2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ EXTRA_PROGRAMS = calc$(EXEEXT) subdir = demos/calc DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am \ $(srcdir)/calc-config-h.in calc.h calc.c calclex.c \ $(top_srcdir)/ylwrap README ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = calc-config.h CONFIG_CLEAN_VPATH_FILES = am_calc_OBJECTS = calc.$(OBJEXT) calclex.$(OBJEXT) calcread.$(OBJEXT) calc_OBJECTS = $(am_calc_OBJECTS) calc_LDADD = $(LDADD) am__DEPENDENCIES_1 = calc_DEPENDENCIES = $(top_builddir)/libgmp.la $(am__DEPENDENCIES_1) \ $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = @MAINTAINER_MODE_FALSE@am__skiplex = test -f $@ || LEXCOMPILE = $(LEX) $(AM_LFLAGS) $(LFLAGS) LTLEXCOMPILE = $(LIBTOOL) $(AM_V_lt) $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(LEX) $(AM_LFLAGS) $(LFLAGS) AM_V_LEX = $(am__v_LEX_@AM_V@) am__v_LEX_ = $(am__v_LEX_@AM_DEFAULT_V@) am__v_LEX_0 = @echo " LEX " $@; am__v_LEX_1 = YLWRAP = $(top_srcdir)/ylwrap @MAINTAINER_MODE_FALSE@am__skipyacc = test -f $@ || am__yacc_c2h = sed -e s/cc$$/hh/ -e s/cpp$$/hpp/ -e s/cxx$$/hxx/ \ -e s/c++$$/h++/ -e s/c$$/h/ YACCCOMPILE = $(YACC) $(AM_YFLAGS) $(YFLAGS) LTYACCCOMPILE = $(LIBTOOL) $(AM_V_lt) $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(YACC) $(AM_YFLAGS) $(YFLAGS) AM_V_YACC = $(am__v_YACC_@AM_V@) am__v_YACC_ = $(am__v_YACC_@AM_DEFAULT_V@) am__v_YACC_0 = @echo " YACC " $@; am__v_YACC_1 = SOURCES = $(calc_SOURCES) DIST_SOURCES = $(calc_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ INCLUDES = -I$(top_srcdir) # $(LEXLIB) is not actually needed for flex (which means the distributed # calclex.c), but it's included here for the benefit of anyone rebuilding # with some other lex. # LDADD = $(top_builddir)/libgmp.la $(LIBREADLINE) $(LIBCURSES) $(LEXLIB) AM_YFLAGS = -d calc_SOURCES = calc.y calclex.l calcread.c calc-common.h BUILT_SOURCES = calc.h CLEANFILES = $(EXTRA_PROGRAMS) all: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) all-am .SUFFIXES: .SUFFIXES: .c .l .lo .o .obj .y $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps demos/calc/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps demos/calc/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): calc-config.h: $(top_builddir)/config.status $(srcdir)/calc-config-h.in cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ calc.h: calc.c @if test ! -f $@; then rm -f calc.c; else :; fi @if test ! -f $@; then $(MAKE) $(AM_MAKEFLAGS) calc.c; else :; fi calc$(EXEEXT): $(calc_OBJECTS) $(calc_DEPENDENCIES) $(EXTRA_calc_DEPENDENCIES) @rm -f calc$(EXEEXT) $(AM_V_CCLD)$(LINK) $(calc_OBJECTS) $(calc_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< .l.c: $(AM_V_LEX)$(am__skiplex) $(SHELL) $(YLWRAP) $< $(LEX_OUTPUT_ROOT).c $@ -- $(LEXCOMPILE) .y.c: $(AM_V_YACC)$(am__skipyacc) $(SHELL) $(YLWRAP) $< y.tab.c $@ y.tab.h `echo $@ | $(am__yacc_c2h)` y.output $*.output -- $(YACCCOMPILE) mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) check-am all-am: Makefile installdirs: install: $(BUILT_SOURCES) $(MAKE) $(AM_MAKEFLAGS) install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." -rm -f calc.c -rm -f calc.h -rm -f calclex.c -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) clean: clean-am clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: all check install install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool cscopelist-am ctags ctags-am distclean \ distclean-compile distclean-generic distclean-libtool \ distclean-tags distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-pdf install-pdf-am install-ps install-ps-am \ install-strip installcheck installcheck-am installdirs \ maintainer-clean maintainer-clean-generic mostlyclean \ mostlyclean-compile mostlyclean-generic mostlyclean-libtool \ pdf pdf-am ps ps-am tags tags-am uninstall uninstall-am allprogs: $(EXTRA_PROGRAMS) # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/demos/pexpr.c0000644000175000017500000007406514360276512014267 0ustar cammcamm/* Program for computing integer expressions using the GNU Multiple Precision Arithmetic Library. Copyright 1997, 1999-2002, 2005, 2008, 2012 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* This expressions evaluator works by building an expression tree (using a recursive descent parser) which is then evaluated. The expression tree is useful since we want to optimize certain expressions (like a^b % c). Usage: pexpr [options] expr ... (Assuming you called the executable `pexpr' of course.) Command line options: -b print output in binary -o print output in octal -d print output in decimal (the default) -x print output in hexadecimal -b print output in base NUM -t print timing information -html output html -wml output wml -split split long lines each 80th digit */ /* Define LIMIT_RESOURCE_USAGE if you want to make sure the program doesn't use up extensive resources (cpu, memory). Useful for the GMP demo on the GMP web site, since we cannot load the server too much. */ #include "pexpr-config.h" #include #include #include #include #include #include #include #include #include #if HAVE_SYS_RESOURCE_H #include #endif #include "gmp.h" /* SunOS 4 and HPUX 9 don't define a canonical SIGSTKSZ, use a default. */ #ifndef SIGSTKSZ #define SIGSTKSZ 4096 #endif #define TIME(t,func) \ do { int __t0, __tmp; \ __t0 = cputime (); \ {func;} \ __tmp = cputime () - __t0; \ (t) = __tmp; \ } while (0) /* GMP version 1.x compatibility. */ #if ! (__GNU_MP_VERSION >= 2) typedef MP_INT __mpz_struct; typedef __mpz_struct mpz_t[1]; typedef __mpz_struct *mpz_ptr; #define mpz_fdiv_q mpz_div #define mpz_fdiv_r mpz_mod #define mpz_tdiv_q_2exp mpz_div_2exp #define mpz_sgn(Z) ((Z)->size < 0 ? -1 : (Z)->size > 0) #endif /* GMP version 2.0 compatibility. */ #if ! (__GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1) #define mpz_swap(a,b) \ do { __mpz_struct __t; __t = *a; *a = *b; *b = __t;} while (0) #endif jmp_buf errjmpbuf; enum op_t {NOP, LIT, NEG, NOT, PLUS, MINUS, MULT, DIV, MOD, REM, INVMOD, POW, AND, IOR, XOR, SLL, SRA, POPCNT, HAMDIST, GCD, LCM, SQRT, ROOT, FAC, LOG, LOG2, FERMAT, MERSENNE, FIBONACCI, RANDOM, NEXTPRIME, BINOM, TIMING}; /* Type for the expression tree. */ struct expr { enum op_t op; union { struct {struct expr *lhs, *rhs;} ops; mpz_t val; } operands; }; typedef struct expr *expr_t; void cleanup_and_exit (int); char *skipspace (char *); void makeexp (expr_t *, enum op_t, expr_t, expr_t); void free_expr (expr_t); char *expr (char *, expr_t *); char *term (char *, expr_t *); char *power (char *, expr_t *); char *factor (char *, expr_t *); int match (char *, char *); int matchp (char *, char *); int cputime (void); void mpz_eval_expr (mpz_ptr, expr_t); void mpz_eval_mod_expr (mpz_ptr, expr_t, mpz_ptr); char *error; int flag_print = 1; int print_timing = 0; int flag_html = 0; int flag_wml = 0; int flag_splitup_output = 0; char *newline = ""; gmp_randstate_t rstate; /* cputime() returns user CPU time measured in milliseconds. */ #if ! HAVE_CPUTIME #if HAVE_GETRUSAGE int cputime (void) { struct rusage rus; getrusage (0, &rus); return rus.ru_utime.tv_sec * 1000 + rus.ru_utime.tv_usec / 1000; } #else #if HAVE_CLOCK int cputime (void) { if (CLOCKS_PER_SEC < 100000) return clock () * 1000 / CLOCKS_PER_SEC; return clock () / (CLOCKS_PER_SEC / 1000); } #else int cputime (void) { return 0; } #endif #endif #endif int stack_downwards_helper (char *xp) { char y; return &y < xp; } int stack_downwards_p (void) { char x; return stack_downwards_helper (&x); } void setup_error_handler (void) { #if HAVE_SIGACTION struct sigaction act; act.sa_handler = cleanup_and_exit; sigemptyset (&(act.sa_mask)); #define SIGNAL(sig) sigaction (sig, &act, NULL) #else struct { int sa_flags; } act; #define SIGNAL(sig) signal (sig, cleanup_and_exit) #endif act.sa_flags = 0; /* Set up a stack for signal handling. A typical cause of error is stack overflow, and in such situation a signal can not be delivered on the overflown stack. */ #if HAVE_SIGALTSTACK { /* AIX uses stack_t, MacOS uses struct sigaltstack, various other systems have both. */ #if HAVE_STACK_T stack_t s; #else struct sigaltstack s; #endif s.ss_sp = malloc (SIGSTKSZ); s.ss_size = SIGSTKSZ; s.ss_flags = 0; if (sigaltstack (&s, NULL) != 0) perror("sigaltstack"); act.sa_flags = SA_ONSTACK; } #else #if HAVE_SIGSTACK { struct sigstack s; s.ss_sp = malloc (SIGSTKSZ); if (stack_downwards_p ()) s.ss_sp += SIGSTKSZ; s.ss_onstack = 0; if (sigstack (&s, NULL) != 0) perror("sigstack"); act.sa_flags = SA_ONSTACK; } #else #endif #endif #ifdef LIMIT_RESOURCE_USAGE { struct rlimit limit; limit.rlim_cur = limit.rlim_max = 0; setrlimit (RLIMIT_CORE, &limit); limit.rlim_cur = 3; limit.rlim_max = 4; setrlimit (RLIMIT_CPU, &limit); limit.rlim_cur = limit.rlim_max = 16 * 1024 * 1024; setrlimit (RLIMIT_DATA, &limit); getrlimit (RLIMIT_STACK, &limit); limit.rlim_cur = 4 * 1024 * 1024; setrlimit (RLIMIT_STACK, &limit); SIGNAL (SIGXCPU); } #endif /* LIMIT_RESOURCE_USAGE */ SIGNAL (SIGILL); SIGNAL (SIGSEGV); #ifdef SIGBUS /* not in mingw */ SIGNAL (SIGBUS); #endif SIGNAL (SIGFPE); SIGNAL (SIGABRT); } int main (int argc, char **argv) { struct expr *e; int i; mpz_t r; int errcode = 0; char *str; int base = 10; setup_error_handler (); gmp_randinit (rstate, GMP_RAND_ALG_LC, 128); { #if HAVE_GETTIMEOFDAY struct timeval tv; gettimeofday (&tv, NULL); gmp_randseed_ui (rstate, tv.tv_sec + tv.tv_usec); #else time_t t; time (&t); gmp_randseed_ui (rstate, t); #endif } mpz_init (r); while (argc > 1 && argv[1][0] == '-') { char *arg = argv[1]; if (arg[1] >= '0' && arg[1] <= '9') break; if (arg[1] == 't') print_timing = 1; else if (arg[1] == 'b' && arg[2] >= '0' && arg[2] <= '9') { base = atoi (arg + 2); if (base < 2 || base > 62) { fprintf (stderr, "error: invalid output base\n"); exit (-1); } } else if (arg[1] == 'b' && arg[2] == 0) base = 2; else if (arg[1] == 'x' && arg[2] == 0) base = 16; else if (arg[1] == 'X' && arg[2] == 0) base = -16; else if (arg[1] == 'o' && arg[2] == 0) base = 8; else if (arg[1] == 'd' && arg[2] == 0) base = 10; else if (arg[1] == 'v' && arg[2] == 0) { printf ("pexpr linked to gmp %s\n", __gmp_version); } else if (strcmp (arg, "-html") == 0) { flag_html = 1; newline = "
    "; } else if (strcmp (arg, "-wml") == 0) { flag_wml = 1; newline = "
    "; } else if (strcmp (arg, "-split") == 0) { flag_splitup_output = 1; } else if (strcmp (arg, "-noprint") == 0) { flag_print = 0; } else { fprintf (stderr, "error: unknown option `%s'\n", arg); exit (-1); } argv++; argc--; } for (i = 1; i < argc; i++) { int s; int jmpval; /* Set up error handler for parsing expression. */ jmpval = setjmp (errjmpbuf); if (jmpval != 0) { fprintf (stderr, "error: %s%s\n", error, newline); fprintf (stderr, " %s%s\n", argv[i], newline); if (! flag_html) { /* ??? Dunno how to align expression position with arrow in HTML ??? */ fprintf (stderr, " "); for (s = jmpval - (long) argv[i]; --s >= 0; ) putc (' ', stderr); fprintf (stderr, "^\n"); } errcode |= 1; continue; } str = expr (argv[i], &e); if (str[0] != 0) { fprintf (stderr, "error: garbage where end of expression expected%s\n", newline); fprintf (stderr, " %s%s\n", argv[i], newline); if (! flag_html) { /* ??? Dunno how to align expression position with arrow in HTML ??? */ fprintf (stderr, " "); for (s = str - argv[i]; --s; ) putc (' ', stderr); fprintf (stderr, "^\n"); } errcode |= 1; free_expr (e); continue; } /* Set up error handler for evaluating expression. */ if (setjmp (errjmpbuf)) { fprintf (stderr, "error: %s%s\n", error, newline); fprintf (stderr, " %s%s\n", argv[i], newline); if (! flag_html) { /* ??? Dunno how to align expression position with arrow in HTML ??? */ fprintf (stderr, " "); for (s = str - argv[i]; --s >= 0; ) putc (' ', stderr); fprintf (stderr, "^\n"); } errcode |= 2; continue; } if (print_timing) { int t; TIME (t, mpz_eval_expr (r, e)); printf ("computation took %d ms%s\n", t, newline); } else mpz_eval_expr (r, e); if (flag_print) { size_t out_len; char *tmp, *s; out_len = mpz_sizeinbase (r, base >= 0 ? base : -base) + 2; #ifdef LIMIT_RESOURCE_USAGE if (out_len > 100000) { printf ("result is about %ld digits, not printing it%s\n", (long) out_len - 3, newline); exit (-2); } #endif tmp = malloc (out_len); if (print_timing) { int t; printf ("output conversion "); TIME (t, mpz_get_str (tmp, base, r)); printf ("took %d ms%s\n", t, newline); } else mpz_get_str (tmp, base, r); out_len = strlen (tmp); if (flag_splitup_output) { for (s = tmp; out_len > 80; s += 80) { fwrite (s, 1, 80, stdout); printf ("%s\n", newline); out_len -= 80; } fwrite (s, 1, out_len, stdout); } else { fwrite (tmp, 1, out_len, stdout); } free (tmp); printf ("%s\n", newline); } else { printf ("result is approximately %ld digits%s\n", (long) mpz_sizeinbase (r, base >= 0 ? base : -base), newline); } free_expr (e); } exit (errcode); } char * expr (char *str, expr_t *e) { expr_t e2; str = skipspace (str); if (str[0] == '+') { str = term (str + 1, e); } else if (str[0] == '-') { str = term (str + 1, e); makeexp (e, NEG, *e, NULL); } else if (str[0] == '~') { str = term (str + 1, e); makeexp (e, NOT, *e, NULL); } else { str = term (str, e); } for (;;) { str = skipspace (str); switch (str[0]) { case 'p': if (match ("plus", str)) { str = term (str + 4, &e2); makeexp (e, PLUS, *e, e2); } else return str; break; case 'm': if (match ("minus", str)) { str = term (str + 5, &e2); makeexp (e, MINUS, *e, e2); } else return str; break; case '+': str = term (str + 1, &e2); makeexp (e, PLUS, *e, e2); break; case '-': str = term (str + 1, &e2); makeexp (e, MINUS, *e, e2); break; default: return str; } } } char * term (char *str, expr_t *e) { expr_t e2; str = power (str, e); for (;;) { str = skipspace (str); switch (str[0]) { case 'm': if (match ("mul", str)) { str = power (str + 3, &e2); makeexp (e, MULT, *e, e2); break; } if (match ("mod", str)) { str = power (str + 3, &e2); makeexp (e, MOD, *e, e2); break; } return str; case 'd': if (match ("div", str)) { str = power (str + 3, &e2); makeexp (e, DIV, *e, e2); break; } return str; case 'r': if (match ("rem", str)) { str = power (str + 3, &e2); makeexp (e, REM, *e, e2); break; } return str; case 'i': if (match ("invmod", str)) { str = power (str + 6, &e2); makeexp (e, REM, *e, e2); break; } return str; case 't': if (match ("times", str)) { str = power (str + 5, &e2); makeexp (e, MULT, *e, e2); break; } if (match ("thru", str)) { str = power (str + 4, &e2); makeexp (e, DIV, *e, e2); break; } if (match ("through", str)) { str = power (str + 7, &e2); makeexp (e, DIV, *e, e2); break; } return str; case '*': str = power (str + 1, &e2); makeexp (e, MULT, *e, e2); break; case '/': str = power (str + 1, &e2); makeexp (e, DIV, *e, e2); break; case '%': str = power (str + 1, &e2); makeexp (e, MOD, *e, e2); break; default: return str; } } } char * power (char *str, expr_t *e) { expr_t e2; str = factor (str, e); while (str[0] == '!') { str++; makeexp (e, FAC, *e, NULL); } str = skipspace (str); if (str[0] == '^') { str = power (str + 1, &e2); makeexp (e, POW, *e, e2); } return str; } int match (char *s, char *str) { char *ostr = str; int i; for (i = 0; s[i] != 0; i++) { if (str[i] != s[i]) return 0; } str = skipspace (str + i); return str - ostr; } int matchp (char *s, char *str) { char *ostr = str; int i; for (i = 0; s[i] != 0; i++) { if (str[i] != s[i]) return 0; } str = skipspace (str + i); if (str[0] == '(') return str - ostr + 1; return 0; } struct functions { char *spelling; enum op_t op; int arity; /* 1 or 2 means real arity; 0 means arbitrary. */ }; struct functions fns[] = { {"sqrt", SQRT, 1}, #if __GNU_MP_VERSION >= 2 {"root", ROOT, 2}, {"popc", POPCNT, 1}, {"hamdist", HAMDIST, 2}, #endif {"gcd", GCD, 0}, #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 {"lcm", LCM, 0}, #endif {"and", AND, 0}, {"ior", IOR, 0}, #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 {"xor", XOR, 0}, #endif {"plus", PLUS, 0}, {"pow", POW, 2}, {"minus", MINUS, 2}, {"mul", MULT, 0}, {"div", DIV, 2}, {"mod", MOD, 2}, {"rem", REM, 2}, #if __GNU_MP_VERSION >= 2 {"invmod", INVMOD, 2}, #endif {"log", LOG, 2}, {"log2", LOG2, 1}, {"F", FERMAT, 1}, {"M", MERSENNE, 1}, {"fib", FIBONACCI, 1}, {"Fib", FIBONACCI, 1}, {"random", RANDOM, 1}, {"nextprime", NEXTPRIME, 1}, {"binom", BINOM, 2}, {"binomial", BINOM, 2}, {"fac", FAC, 1}, {"fact", FAC, 1}, {"factorial", FAC, 1}, {"time", TIMING, 1}, {"", NOP, 0} }; char * factor (char *str, expr_t *e) { expr_t e1, e2; str = skipspace (str); if (isalpha (str[0])) { int i; int cnt; for (i = 0; fns[i].op != NOP; i++) { if (fns[i].arity == 1) { cnt = matchp (fns[i].spelling, str); if (cnt != 0) { str = expr (str + cnt, &e1); str = skipspace (str); if (str[0] != ')') { error = "expected `)'"; longjmp (errjmpbuf, (int) (long) str); } makeexp (e, fns[i].op, e1, NULL); return str + 1; } } } for (i = 0; fns[i].op != NOP; i++) { if (fns[i].arity != 1) { cnt = matchp (fns[i].spelling, str); if (cnt != 0) { str = expr (str + cnt, &e1); str = skipspace (str); if (str[0] != ',') { error = "expected `,' and another operand"; longjmp (errjmpbuf, (int) (long) str); } str = skipspace (str + 1); str = expr (str, &e2); str = skipspace (str); if (fns[i].arity == 0) { while (str[0] == ',') { makeexp (&e1, fns[i].op, e1, e2); str = skipspace (str + 1); str = expr (str, &e2); str = skipspace (str); } } if (str[0] != ')') { error = "expected `)'"; longjmp (errjmpbuf, (int) (long) str); } makeexp (e, fns[i].op, e1, e2); return str + 1; } } } } if (str[0] == '(') { str = expr (str + 1, e); str = skipspace (str); if (str[0] != ')') { error = "expected `)'"; longjmp (errjmpbuf, (int) (long) str); } str++; } else if (str[0] >= '0' && str[0] <= '9') { expr_t res; char *s, *sc; res = malloc (sizeof (struct expr)); res -> op = LIT; mpz_init (res->operands.val); s = str; while (isalnum (str[0])) str++; sc = malloc (str - s + 1); memcpy (sc, s, str - s); sc[str - s] = 0; mpz_set_str (res->operands.val, sc, 0); *e = res; free (sc); } else { error = "operand expected"; longjmp (errjmpbuf, (int) (long) str); } return str; } char * skipspace (char *str) { while (str[0] == ' ') str++; return str; } /* Make a new expression with operation OP and right hand side RHS and left hand side lhs. Put the result in R. */ void makeexp (expr_t *r, enum op_t op, expr_t lhs, expr_t rhs) { expr_t res; res = malloc (sizeof (struct expr)); res -> op = op; res -> operands.ops.lhs = lhs; res -> operands.ops.rhs = rhs; *r = res; return; } /* Free the memory used by expression E. */ void free_expr (expr_t e) { if (e->op != LIT) { free_expr (e->operands.ops.lhs); if (e->operands.ops.rhs != NULL) free_expr (e->operands.ops.rhs); } else { mpz_clear (e->operands.val); } } /* Evaluate the expression E and put the result in R. */ void mpz_eval_expr (mpz_ptr r, expr_t e) { mpz_t lhs, rhs; switch (e->op) { case LIT: mpz_set (r, e->operands.val); return; case PLUS: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_add (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; case MINUS: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_sub (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; case MULT: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_mul (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; case DIV: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_fdiv_q (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; case MOD: mpz_init (rhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_abs (rhs, rhs); mpz_eval_mod_expr (r, e->operands.ops.lhs, rhs); mpz_clear (rhs); return; case REM: /* Check if lhs operand is POW expression and optimize for that case. */ if (e->operands.ops.lhs->op == POW) { mpz_t powlhs, powrhs; mpz_init (powlhs); mpz_init (powrhs); mpz_init (rhs); mpz_eval_expr (powlhs, e->operands.ops.lhs->operands.ops.lhs); mpz_eval_expr (powrhs, e->operands.ops.lhs->operands.ops.rhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_powm (r, powlhs, powrhs, rhs); if (mpz_cmp_si (rhs, 0L) < 0) mpz_neg (r, r); mpz_clear (powlhs); mpz_clear (powrhs); mpz_clear (rhs); return; } mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_fdiv_r (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #if __GNU_MP_VERSION >= 2 case INVMOD: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_invert (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #endif case POW: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); if (mpz_cmpabs_ui (lhs, 1) <= 0) { /* For 0^rhs and 1^rhs, we just need to verify that rhs is well-defined. For (-1)^rhs we need to determine (rhs mod 2). For simplicity, compute (rhs mod 2) for all three cases. */ expr_t two, et; two = malloc (sizeof (struct expr)); two -> op = LIT; mpz_init_set_ui (two->operands.val, 2L); makeexp (&et, MOD, e->operands.ops.rhs, two); e->operands.ops.rhs = et; } mpz_eval_expr (rhs, e->operands.ops.rhs); if (mpz_cmp_si (rhs, 0L) == 0) /* x^0 is 1 */ mpz_set_ui (r, 1L); else if (mpz_cmp_si (lhs, 0L) == 0) /* 0^y (where y != 0) is 0 */ mpz_set_ui (r, 0L); else if (mpz_cmp_ui (lhs, 1L) == 0) /* 1^y is 1 */ mpz_set_ui (r, 1L); else if (mpz_cmp_si (lhs, -1L) == 0) /* (-1)^y just depends on whether y is even or odd */ mpz_set_si (r, (mpz_get_ui (rhs) & 1) ? -1L : 1L); else if (mpz_cmp_si (rhs, 0L) < 0) /* x^(-n) is 0 */ mpz_set_ui (r, 0L); else { unsigned long int cnt; unsigned long int y; /* error if exponent does not fit into an unsigned long int. */ if (mpz_cmp_ui (rhs, ~(unsigned long int) 0) > 0) goto pow_err; y = mpz_get_ui (rhs); /* x^y == (x/(2^c))^y * 2^(c*y) */ #if __GNU_MP_VERSION >= 2 cnt = mpz_scan1 (lhs, 0); #else cnt = 0; #endif if (cnt != 0) { if (y * cnt / cnt != y) goto pow_err; mpz_tdiv_q_2exp (lhs, lhs, cnt); mpz_pow_ui (r, lhs, y); mpz_mul_2exp (r, r, y * cnt); } else mpz_pow_ui (r, lhs, y); } mpz_clear (lhs); mpz_clear (rhs); return; pow_err: error = "result of `pow' operator too large"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); case GCD: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_gcd (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 case LCM: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_lcm (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #endif case AND: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_and (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; case IOR: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_ior (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 case XOR: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_xor (r, lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); return; #endif case NEG: mpz_eval_expr (r, e->operands.ops.lhs); mpz_neg (r, r); return; case NOT: mpz_eval_expr (r, e->operands.ops.lhs); mpz_com (r, r); return; case SQRT: mpz_init (lhs); mpz_eval_expr (lhs, e->operands.ops.lhs); if (mpz_sgn (lhs) < 0) { error = "cannot take square root of negative numbers"; mpz_clear (lhs); longjmp (errjmpbuf, 1); } mpz_sqrt (r, lhs); return; #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 case ROOT: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); if (mpz_sgn (rhs) <= 0) { error = "cannot take non-positive root orders"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); } if (mpz_sgn (lhs) < 0 && (mpz_get_ui (rhs) & 1) == 0) { error = "cannot take even root orders of negative numbers"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); } { unsigned long int nth = mpz_get_ui (rhs); if (mpz_cmp_ui (rhs, ~(unsigned long int) 0) > 0) { /* If we are asked to take an awfully large root order, cheat and ask for the largest order we can pass to mpz_root. This saves some error prone special cases. */ nth = ~(unsigned long int) 0; } mpz_root (r, lhs, nth); } mpz_clear (lhs); mpz_clear (rhs); return; #endif case FAC: mpz_eval_expr (r, e->operands.ops.lhs); if (mpz_size (r) > 1) { error = "result of `!' operator too large"; longjmp (errjmpbuf, 1); } mpz_fac_ui (r, mpz_get_ui (r)); return; #if __GNU_MP_VERSION >= 2 case POPCNT: mpz_eval_expr (r, e->operands.ops.lhs); { long int cnt; cnt = mpz_popcount (r); mpz_set_si (r, cnt); } return; case HAMDIST: { long int cnt; mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); cnt = mpz_hamdist (lhs, rhs); mpz_clear (lhs); mpz_clear (rhs); mpz_set_si (r, cnt); } return; #endif case LOG2: mpz_eval_expr (r, e->operands.ops.lhs); { unsigned long int cnt; if (mpz_sgn (r) <= 0) { error = "logarithm of non-positive number"; longjmp (errjmpbuf, 1); } cnt = mpz_sizeinbase (r, 2); mpz_set_ui (r, cnt - 1); } return; case LOG: { unsigned long int cnt; mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); if (mpz_sgn (lhs) <= 0) { error = "logarithm of non-positive number"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); } if (mpz_cmp_ui (rhs, 256) >= 0) { error = "logarithm base too large"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); } cnt = mpz_sizeinbase (lhs, mpz_get_ui (rhs)); mpz_set_ui (r, cnt - 1); mpz_clear (lhs); mpz_clear (rhs); } return; case FERMAT: { unsigned long int t; mpz_init (lhs); mpz_eval_expr (lhs, e->operands.ops.lhs); t = (unsigned long int) 1 << mpz_get_ui (lhs); if (mpz_cmp_ui (lhs, ~(unsigned long int) 0) > 0 || t == 0) { error = "too large Mersenne number index"; mpz_clear (lhs); longjmp (errjmpbuf, 1); } mpz_set_ui (r, 1); mpz_mul_2exp (r, r, t); mpz_add_ui (r, r, 1); mpz_clear (lhs); } return; case MERSENNE: mpz_init (lhs); mpz_eval_expr (lhs, e->operands.ops.lhs); if (mpz_cmp_ui (lhs, ~(unsigned long int) 0) > 0) { error = "too large Mersenne number index"; mpz_clear (lhs); longjmp (errjmpbuf, 1); } mpz_set_ui (r, 1); mpz_mul_2exp (r, r, mpz_get_ui (lhs)); mpz_sub_ui (r, r, 1); mpz_clear (lhs); return; case FIBONACCI: { mpz_t t; unsigned long int n, i; mpz_init (lhs); mpz_eval_expr (lhs, e->operands.ops.lhs); if (mpz_sgn (lhs) <= 0 || mpz_cmp_si (lhs, 1000000000) > 0) { error = "Fibonacci index out of range"; mpz_clear (lhs); longjmp (errjmpbuf, 1); } n = mpz_get_ui (lhs); mpz_clear (lhs); #if __GNU_MP_VERSION > 2 || __GNU_MP_VERSION_MINOR >= 1 mpz_fib_ui (r, n); #else mpz_init_set_ui (t, 1); mpz_set_ui (r, 1); if (n <= 2) mpz_set_ui (r, 1); else { for (i = 3; i <= n; i++) { mpz_add (t, t, r); mpz_swap (t, r); } } mpz_clear (t); #endif } return; case RANDOM: { unsigned long int n; mpz_init (lhs); mpz_eval_expr (lhs, e->operands.ops.lhs); if (mpz_sgn (lhs) <= 0 || mpz_cmp_si (lhs, 1000000000) > 0) { error = "random number size out of range"; mpz_clear (lhs); longjmp (errjmpbuf, 1); } n = mpz_get_ui (lhs); mpz_clear (lhs); mpz_urandomb (r, rstate, n); } return; case NEXTPRIME: { mpz_eval_expr (r, e->operands.ops.lhs); mpz_nextprime (r, r); } return; case BINOM: mpz_init (lhs); mpz_init (rhs); mpz_eval_expr (lhs, e->operands.ops.lhs); mpz_eval_expr (rhs, e->operands.ops.rhs); { unsigned long int k; if (mpz_cmp_ui (rhs, ~(unsigned long int) 0) > 0) { error = "k too large in (n over k) expression"; mpz_clear (lhs); mpz_clear (rhs); longjmp (errjmpbuf, 1); } k = mpz_get_ui (rhs); mpz_bin_ui (r, lhs, k); } mpz_clear (lhs); mpz_clear (rhs); return; case TIMING: { int t0; t0 = cputime (); mpz_eval_expr (r, e->operands.ops.lhs); printf ("time: %d\n", cputime () - t0); } return; default: abort (); } } /* Evaluate the expression E modulo MOD and put the result in R. */ void mpz_eval_mod_expr (mpz_ptr r, expr_t e, mpz_ptr mod) { mpz_t lhs, rhs; switch (e->op) { case POW: mpz_init (lhs); mpz_init (rhs); mpz_eval_mod_expr (lhs, e->operands.ops.lhs, mod); mpz_eval_expr (rhs, e->operands.ops.rhs); mpz_powm (r, lhs, rhs, mod); mpz_clear (lhs); mpz_clear (rhs); return; case PLUS: mpz_init (lhs); mpz_init (rhs); mpz_eval_mod_expr (lhs, e->operands.ops.lhs, mod); mpz_eval_mod_expr (rhs, e->operands.ops.rhs, mod); mpz_add (r, lhs, rhs); if (mpz_cmp_si (r, 0L) < 0) mpz_add (r, r, mod); else if (mpz_cmp (r, mod) >= 0) mpz_sub (r, r, mod); mpz_clear (lhs); mpz_clear (rhs); return; case MINUS: mpz_init (lhs); mpz_init (rhs); mpz_eval_mod_expr (lhs, e->operands.ops.lhs, mod); mpz_eval_mod_expr (rhs, e->operands.ops.rhs, mod); mpz_sub (r, lhs, rhs); if (mpz_cmp_si (r, 0L) < 0) mpz_add (r, r, mod); else if (mpz_cmp (r, mod) >= 0) mpz_sub (r, r, mod); mpz_clear (lhs); mpz_clear (rhs); return; case MULT: mpz_init (lhs); mpz_init (rhs); mpz_eval_mod_expr (lhs, e->operands.ops.lhs, mod); mpz_eval_mod_expr (rhs, e->operands.ops.rhs, mod); mpz_mul (r, lhs, rhs); mpz_mod (r, r, mod); mpz_clear (lhs); mpz_clear (rhs); return; default: mpz_init (lhs); mpz_eval_expr (lhs, e); mpz_mod (r, lhs, mod); mpz_clear (lhs); return; } } void cleanup_and_exit (int sig) { switch (sig) { #ifdef LIMIT_RESOURCE_USAGE case SIGXCPU: printf ("expression took too long to evaluate%s\n", newline); break; #endif case SIGFPE: printf ("divide by zero%s\n", newline); break; default: printf ("expression required too much memory to evaluate%s\n", newline); break; } exit (-2); } gcl-2.6.14/gmp4/demos/primes.h0000644000175000017500000010111414360276512014417 0ustar cammcammP( 1, 0xaaaaaaaaaaaaaaabUL, 0x5555555555555555UL) /* 3 */ P( 2, 0xcccccccccccccccdUL, 0x3333333333333333UL) /* 5 */ P( 2, 0x6db6db6db6db6db7UL, 0x2492492492492492UL) /* 7 */ P( 4, 0x2e8ba2e8ba2e8ba3UL, 0x1745d1745d1745d1UL) /* 11 */ P( 2, 0x4ec4ec4ec4ec4ec5UL, 0x13b13b13b13b13b1UL) /* 13 */ P( 4, 0xf0f0f0f0f0f0f0f1UL, 0x0f0f0f0f0f0f0f0fUL) /* 17 */ P( 2, 0x86bca1af286bca1bUL, 0x0d79435e50d79435UL) /* 19 */ P( 4, 0xd37a6f4de9bd37a7UL, 0x0b21642c8590b216UL) /* 23 */ P( 6, 0x34f72c234f72c235UL, 0x08d3dcb08d3dcb08UL) /* 29 */ P( 2, 0xef7bdef7bdef7bdfUL, 0x0842108421084210UL) /* 31 */ P( 6, 0x14c1bacf914c1badUL, 0x06eb3e45306eb3e4UL) /* 37 */ P( 4, 0x8f9c18f9c18f9c19UL, 0x063e7063e7063e70UL) /* 41 */ P( 2, 0x82fa0be82fa0be83UL, 0x05f417d05f417d05UL) /* 43 */ P( 4, 0x51b3bea3677d46cfUL, 0x0572620ae4c415c9UL) /* 47 */ P( 6, 0x21cfb2b78c13521dUL, 0x04d4873ecade304dUL) /* 53 */ P( 6, 0xcbeea4e1a08ad8f3UL, 0x0456c797dd49c341UL) /* 59 */ P( 2, 0x4fbcda3ac10c9715UL, 0x04325c53ef368eb0UL) /* 61 */ P( 6, 0xf0b7672a07a44c6bUL, 0x03d226357e16ece5UL) /* 67 */ P( 4, 0x193d4bb7e327a977UL, 0x039b0ad12073615aUL) /* 71 */ P( 2, 0x7e3f1f8fc7e3f1f9UL, 0x0381c0e070381c0eUL) /* 73 */ P( 6, 0x9b8b577e613716afUL, 0x033d91d2a2067b23UL) /* 79 */ P( 4, 0xa3784a062b2e43dbUL, 0x03159721ed7e7534UL) /* 83 */ P( 6, 0xf47e8fd1fa3f47e9UL, 0x02e05c0b81702e05UL) /* 89 */ P( 8, 0xa3a0fd5c5f02a3a1UL, 0x02a3a0fd5c5f02a3UL) /* 97 */ P( 4, 0x3a4c0a237c32b16dUL, 0x0288df0cac5b3f5dUL) /* 101 */ P( 2, 0xdab7ec1dd3431b57UL, 0x027c45979c95204fUL) /* 103 */ P( 4, 0x77a04c8f8d28ac43UL, 0x02647c69456217ecUL) /* 107 */ P( 2, 0xa6c0964fda6c0965UL, 0x02593f69b02593f6UL) /* 109 */ P( 4, 0x90fdbc090fdbc091UL, 0x0243f6f0243f6f02UL) /* 113 */ P(14, 0x7efdfbf7efdfbf7fUL, 0x0204081020408102UL) /* 127 */ P( 4, 0x03e88cb3c9484e2bUL, 0x01f44659e4a42715UL) /* 131 */ P( 6, 0xe21a291c077975b9UL, 0x01de5d6e3f8868a4UL) /* 137 */ P( 2, 0x3aef6ca970586723UL, 0x01d77b654b82c339UL) /* 139 */ P(10, 0xdf5b0f768ce2cabdUL, 0x01b7d6c3dda338b2UL) /* 149 */ P( 2, 0x6fe4dfc9bf937f27UL, 0x01b2036406c80d90UL) /* 151 */ P( 6, 0x5b4fe5e92c0685b5UL, 0x01a16d3f97a4b01aUL) /* 157 */ P( 6, 0x1f693a1c451ab30bUL, 0x01920fb49d0e228dUL) /* 163 */ P( 4, 0x8d07aa27db35a717UL, 0x01886e5f0abb0499UL) /* 167 */ P( 6, 0x882383b30d516325UL, 0x017ad2208e0ecc35UL) /* 173 */ P( 6, 0xed6866f8d962ae7bUL, 0x016e1f76b4337c6cUL) /* 179 */ P( 2, 0x3454dca410f8ed9dUL, 0x016a13cd15372904UL) /* 181 */ P(10, 0x1d7ca632ee936f3fUL, 0x01571ed3c506b39aUL) /* 191 */ P( 2, 0x70bf015390948f41UL, 0x015390948f40feacUL) /* 193 */ P( 4, 0xc96bdb9d3d137e0dUL, 0x014cab88725af6e7UL) /* 197 */ P( 2, 0x2697cc8aef46c0f7UL, 0x0149539e3b2d066eUL) /* 199 */ P(12, 0xc0e8f2a76e68575bUL, 0x013698df3de07479UL) /* 211 */ P(12, 0x687763dfdb43bb1fUL, 0x0125e22708092f11UL) /* 223 */ P( 4, 0x1b10ea929ba144cbUL, 0x0120b470c67c0d88UL) /* 227 */ P( 2, 0x1d10c4c0478bbcedUL, 0x011e2ef3b3fb8744UL) /* 229 */ P( 4, 0x63fb9aeb1fdcd759UL, 0x0119453808ca29c0UL) /* 233 */ P( 6, 0x64afaa4f437b2e0fUL, 0x0112358e75d30336UL) /* 239 */ P( 2, 0xf010fef010fef011UL, 0x010fef010fef010fUL) /* 241 */ P(10, 0x28cbfbeb9a020a33UL, 0x0105197f7d734041UL) /* 251 */ P( 6, 0xff00ff00ff00ff01UL, 0x00ff00ff00ff00ffUL) /* 257 */ P( 6, 0xd624fd1470e99cb7UL, 0x00f92fb2211855a8UL) /* 263 */ P( 6, 0x8fb3ddbd6205b5c5UL, 0x00f3a0d52cba8723UL) /* 269 */ P( 2, 0xd57da36ca27acdefUL, 0x00f1d48bcee0d399UL) /* 271 */ P( 6, 0xee70c03b25e4463dUL, 0x00ec979118f3fc4dUL) /* 277 */ P( 4, 0xc5b1a6b80749cb29UL, 0x00e939651fe2d8d3UL) /* 281 */ P( 2, 0x47768073c9b97113UL, 0x00e79372e225fe30UL) /* 283 */ P(10, 0x2591e94884ce32adUL, 0x00dfac1f74346c57UL) /* 293 */ P(14, 0xf02806abc74be1fbUL, 0x00d578e97c3f5fe5UL) /* 307 */ P( 4, 0x7ec3e8f3a7198487UL, 0x00d2ba083b445250UL) /* 311 */ P( 2, 0x58550f8a39409d09UL, 0x00d161543e28e502UL) /* 313 */ P( 4, 0xec9e48ae6f71de15UL, 0x00cebcf8bb5b4169UL) /* 317 */ P(14, 0x2ff3a018bfce8063UL, 0x00c5fe740317f9d0UL) /* 331 */ P( 6, 0x7f9ec3fcf61fe7b1UL, 0x00c2780613c0309eUL) /* 337 */ P(10, 0x89f5abe570e046d3UL, 0x00bcdd535db1cc5bUL) /* 347 */ P( 2, 0xda971b23f1545af5UL, 0x00bbc8408cd63069UL) /* 349 */ P( 4, 0x79d5f00b9a7862a1UL, 0x00b9a7862a0ff465UL) /* 353 */ P( 6, 0x4dba1df32a128a57UL, 0x00b68d31340e4307UL) /* 359 */ P( 8, 0x87530217b7747d8fUL, 0x00b2927c29da5519UL) /* 367 */ P( 6, 0x30baae53bb5e06ddUL, 0x00afb321a1496fdfUL) /* 373 */ P( 6, 0xee70206c12e9b5b3UL, 0x00aceb0f891e6551UL) /* 379 */ P( 4, 0xcdde9462ec9dbe7fUL, 0x00ab1cbdd3e2970fUL) /* 383 */ P( 6, 0xafb64b05ec41cf4dUL, 0x00a87917088e262bUL) /* 389 */ P( 8, 0x02944ff5aec02945UL, 0x00a513fd6bb00a51UL) /* 397 */ P( 4, 0x2cb033128382df71UL, 0x00a36e71a2cb0331UL) /* 401 */ P( 8, 0x1ccacc0c84b1c2a9UL, 0x00a03c1688732b30UL) /* 409 */ P(10, 0x19a93db575eb3a0bUL, 0x009c69169b30446dUL) /* 419 */ P( 2, 0xcebeef94fa86fe2dUL, 0x009baade8e4a2f6eUL) /* 421 */ P(10, 0x6faa77fb3f8df54fUL, 0x00980e4156201301UL) /* 431 */ P( 2, 0x68a58af00975a751UL, 0x00975a750ff68a58UL) /* 433 */ P( 6, 0xd56e36d0c3efac07UL, 0x009548e4979e0829UL) /* 439 */ P( 4, 0xd8b44c47a8299b73UL, 0x0093efd1c50e726bUL) /* 443 */ P( 6, 0x02d9ccaf9ba70e41UL, 0x0091f5bcb8bb02d9UL) /* 449 */ P( 8, 0x0985e1c023d9e879UL, 0x008f67a1e3fdc261UL) /* 457 */ P( 4, 0x2a343316c494d305UL, 0x008e2917e0e702c6UL) /* 461 */ P( 2, 0x70cb7916ab67652fUL, 0x008d8be33f95d715UL) /* 463 */ P( 4, 0xd398f132fb10fe5bUL, 0x008c55841c815ed5UL) /* 467 */ P(12, 0x6f2a38a6bf54fa1fUL, 0x0088d180cd3a4133UL) /* 479 */ P( 8, 0x211df689b98f81d7UL, 0x00869222b1acf1ceUL) /* 487 */ P( 4, 0x0e994983e90f1ec3UL, 0x0085797b917765abUL) /* 491 */ P( 8, 0xad671e44bed87f3bUL, 0x008355ace3c897dbUL) /* 499 */ P( 4, 0xf9623a0516e70fc7UL, 0x00824a4e60b3262bUL) /* 503 */ P( 6, 0x4b7129be9dece355UL, 0x0080c121b28bd1baUL) /* 509 */ P(12, 0x190f3b7473f62c39UL, 0x007dc9f3397d4c29UL) /* 521 */ P( 2, 0x63dacc9aad46f9a3UL, 0x007d4ece8fe88139UL) /* 523 */ P(18, 0xc1108fda24e8d035UL, 0x0079237d65bcce50UL) /* 541 */ P( 6, 0xb77578472319bd8bUL, 0x0077cf53c5f7936cUL) /* 547 */ P(10, 0x473d20a1c7ed9da5UL, 0x0075a8accfbdd11eUL) /* 557 */ P( 6, 0xfbe85af0fea2c8fbUL, 0x007467ac557c228eUL) /* 563 */ P( 6, 0x58a1f7e6ce0f4c09UL, 0x00732d70ed8db8e9UL) /* 569 */ P( 2, 0x1a00e58c544986f3UL, 0x0072c62a24c3797fUL) /* 571 */ P( 6, 0x7194a17f55a10dc1UL, 0x007194a17f55a10dUL) /* 577 */ P(10, 0x7084944785e33763UL, 0x006fa549b41da7e7UL) /* 587 */ P( 6, 0xba10679bd84886b1UL, 0x006e8419e6f61221UL) /* 593 */ P( 6, 0xebe9c6bb31260967UL, 0x006d68b5356c207bUL) /* 599 */ P( 2, 0x97a3fe4bd1ff25e9UL, 0x006d0b803685c01bUL) /* 601 */ P( 6, 0x6c6388395b84d99fUL, 0x006bf790a8b2d207UL) /* 607 */ P( 6, 0x8c51da6a1335df6dUL, 0x006ae907ef4b96c2UL) /* 613 */ P( 4, 0x46f3234475d5add9UL, 0x006a37991a23aeadUL) /* 617 */ P( 2, 0x905605ca3c619a43UL, 0x0069dfbdd4295b66UL) /* 619 */ P(12, 0xcee8dff304767747UL, 0x0067dc4c45c8033eUL) /* 631 */ P(10, 0xff99c27f00663d81UL, 0x00663d80ff99c27fUL) /* 641 */ P( 2, 0xacca407f671ddc2bUL, 0x0065ec17e3559948UL) /* 643 */ P( 4, 0xe71298bac1e12337UL, 0x00654ac835cfba5cUL) /* 647 */ P( 6, 0xfa1e94309cd09045UL, 0x00645c854ae10772UL) /* 653 */ P( 6, 0xbebccb8e91496b9bUL, 0x006372990e5f901fUL) /* 659 */ P( 2, 0x312fa30cc7d7b8bdUL, 0x006325913c07beefUL) /* 661 */ P(12, 0x6160ff9e9f006161UL, 0x006160ff9e9f0061UL) /* 673 */ P( 4, 0x6b03673b5e28152dUL, 0x0060cdb520e5e88eUL) /* 677 */ P( 6, 0xfe802ffa00bfe803UL, 0x005ff4017fd005ffUL) /* 683 */ P( 8, 0xe66fe25c9e907c7bUL, 0x005ed79e31a4dccdUL) /* 691 */ P(10, 0x3f8b236c76528895UL, 0x005d7d42d48ac5efUL) /* 701 */ P( 8, 0xf6f923bf01ce2c0dUL, 0x005c6f35ccba5028UL) /* 709 */ P(10, 0x6c3d3d98bed7c42fUL, 0x005b2618ec6ad0a5UL) /* 719 */ P( 8, 0x30981efcd4b010e7UL, 0x005a2553748e42e7UL) /* 727 */ P( 6, 0x6f691fc81ebbe575UL, 0x0059686cf744cd5bUL) /* 733 */ P( 6, 0xb10480ddb47b52cbUL, 0x0058ae97bab79976UL) /* 739 */ P( 4, 0x74cd59ed64f3f0d7UL, 0x0058345f1876865fUL) /* 743 */ P( 8, 0x0105cb81316d6c0fUL, 0x005743d5bb24795aUL) /* 751 */ P( 6, 0x9be64c6d91c1195dUL, 0x005692c4d1ab74abUL) /* 757 */ P( 4, 0x71b3f945a27b1f49UL, 0x00561e46a4d5f337UL) /* 761 */ P( 8, 0x77d80d50e508fd01UL, 0x005538ed06533997UL) /* 769 */ P( 4, 0xa5eb778e133551cdUL, 0x0054c807f2c0bec2UL) /* 773 */ P(14, 0x18657d3c2d8a3f1bUL, 0x005345efbc572d36UL) /* 787 */ P(10, 0x2e40e220c34ad735UL, 0x00523a758f941345UL) /* 797 */ P(12, 0xa76593c70a714919UL, 0x005102370f816c89UL) /* 809 */ P( 2, 0x1eef452124eea383UL, 0x0050cf129fb94acfUL) /* 811 */ P(10, 0x38206dc242ba771dUL, 0x004fd31941cafdd1UL) /* 821 */ P( 2, 0x4cd4c35807772287UL, 0x004fa1704aa75945UL) /* 823 */ P( 4, 0x83de917d5e69ddf3UL, 0x004f3ed6d45a63adUL) /* 827 */ P( 2, 0x882ef0403b4a6c15UL, 0x004f0de57154ebedUL) /* 829 */ P(10, 0xf8fb6c51c606b677UL, 0x004e1cae8815f811UL) /* 839 */ P(14, 0xb4abaac446d3e1fdUL, 0x004cd47ba5f6ff19UL) /* 853 */ P( 4, 0xa9f83bbe484a14e9UL, 0x004c78ae734df709UL) /* 857 */ P( 2, 0x0bebbc0d1ce874d3UL, 0x004c4b19ed85cfb8UL) /* 859 */ P( 4, 0xbd418eaf0473189fUL, 0x004bf093221d1218UL) /* 863 */ P(14, 0x44e3af6f372b7e65UL, 0x004aba3c21dc633fUL) /* 877 */ P( 4, 0xc87fdace4f9e5d91UL, 0x004a6360c344de00UL) /* 881 */ P( 2, 0xec93479c446bd9bbUL, 0x004a383e9f74d68aUL) /* 883 */ P( 4, 0xdac4d592e777c647UL, 0x0049e28fbabb9940UL) /* 887 */ P(20, 0xa63ea8c8f61f0c23UL, 0x0048417b57c78cd7UL) /* 907 */ P( 4, 0xe476062ea5cbbb6fUL, 0x0047f043713f3a2bUL) /* 911 */ P( 8, 0xdf68761c69daac27UL, 0x00474ff2a10281cfUL) /* 919 */ P(10, 0xb813d737637aa061UL, 0x00468b6f9a978f91UL) /* 929 */ P( 8, 0xa3a77aac1fb15099UL, 0x0045f13f1caff2e2UL) /* 937 */ P( 4, 0x17f0c3e0712c5825UL, 0x0045a5228cec23e9UL) /* 941 */ P( 6, 0xfd912a70ff30637bUL, 0x0045342c556c66b9UL) /* 947 */ P( 6, 0xfbb3b5dc01131289UL, 0x0044c4a23feeced7UL) /* 953 */ P(14, 0x856d560a0f5acdf7UL, 0x0043c5c20d3c9fe6UL) /* 967 */ P( 4, 0x96472f314d3f89e3UL, 0x00437e494b239798UL) /* 971 */ P( 6, 0xa76f5c7ed2253531UL, 0x0043142d118e47cbUL) /* 977 */ P( 6, 0x816eae7c7bf69fe7UL, 0x0042ab5c73a13458UL) /* 983 */ P( 8, 0xb6a2bea4cfb1781fUL, 0x004221950db0f3dbUL) /* 991 */ P( 6, 0xa3900c53318e81edUL, 0x0041bbb2f80a4553UL) /* 997 */ P(12, 0x60aa7f5d9f148d11UL, 0x0040f391612c6680UL) /* 1009 */ P( 4, 0x6be8c0102c7a505dUL, 0x0040b1e94173fefdUL) /* 1013 */ P( 6, 0x8ff3f0ed28728f33UL, 0x004050647d9d0445UL) /* 1019 */ P( 2, 0x680e0a87e5ec7155UL, 0x004030241b144f3bUL) /* 1021 */ P(10, 0xbbf70fa49fe829b7UL, 0x003f90c2ab542cb1UL) /* 1031 */ P( 2, 0xd69d1e7b6a50ca39UL, 0x003f71412d59f597UL) /* 1033 */ P( 6, 0x1a1e0f46b6d26aefUL, 0x003f137701b98841UL) /* 1039 */ P(10, 0x7429f9a7a8251829UL, 0x003e79886b60e278UL) /* 1049 */ P( 2, 0xd9c2219d1b863613UL, 0x003e5b1916a7181dUL) /* 1051 */ P(10, 0x91406c1820d077adUL, 0x003dc4a50968f524UL) /* 1061 */ P( 2, 0x521f4ec02e3d2b97UL, 0x003da6e4c9550321UL) /* 1063 */ P( 6, 0xbb8283b63dc8eba5UL, 0x003d4e4f06f1def3UL) /* 1069 */ P(18, 0x431eda153229ebbfUL, 0x003c4a6bdd24f9a4UL) /* 1087 */ P( 4, 0xaf0bf78d7e01686bUL, 0x003c11d54b525c73UL) /* 1091 */ P( 2, 0xa9ced0742c086e8dUL, 0x003bf5b1c5721065UL) /* 1093 */ P( 4, 0xc26458ad9f632df9UL, 0x003bbdb9862f23b4UL) /* 1097 */ P( 6, 0xbbff1255dff892afUL, 0x003b6a8801db5440UL) /* 1103 */ P( 6, 0xcbd49a333f04d8fdUL, 0x003b183cf0fed886UL) /* 1109 */ P( 8, 0xec84ed6f9cfdeff5UL, 0x003aabe394bdc3f4UL) /* 1117 */ P( 6, 0x97980cc40bda9d4bUL, 0x003a5ba3e76156daUL) /* 1123 */ P( 6, 0x777f34d524f5cbd9UL, 0x003a0c3e953378dbUL) /* 1129 */ P(22, 0x2797051d94cbbb7fUL, 0x0038f03561320b1eUL) /* 1151 */ P( 2, 0xea769051b4f43b81UL, 0x0038d6ecaef5908aUL) /* 1153 */ P(10, 0xce7910f3034d4323UL, 0x003859cf221e6069UL) /* 1163 */ P( 8, 0x92791d1374f5b99bUL, 0x0037f7415dc9588aUL) /* 1171 */ P(10, 0x89a5645cc68ea1b5UL, 0x00377df0d3902626UL) /* 1181 */ P( 6, 0x5f8aacf796c0cf0bUL, 0x00373622136907faUL) /* 1187 */ P( 6, 0xf2e90a15e33edf99UL, 0x0036ef0c3b39b92fUL) /* 1193 */ P( 8, 0x8e99e5feb897c451UL, 0x0036915f47d55e6dUL) /* 1201 */ P(12, 0xaca2eda38fb91695UL, 0x0036072cf3f866fdUL) /* 1213 */ P( 4, 0x5d9b737be5ea8b41UL, 0x0035d9b737be5ea8UL) /* 1217 */ P( 6, 0x4aefe1db93fd7cf7UL, 0x0035961559cc81c7UL) /* 1223 */ P( 6, 0xa0994ef20b3f8805UL, 0x0035531c897a4592UL) /* 1229 */ P( 2, 0x103890bda912822fUL, 0x00353ceebd3e98a4UL) /* 1231 */ P( 6, 0xb441659d13a9147dUL, 0x0034fad381585e5eUL) /* 1237 */ P(12, 0x1e2134440c4c3f21UL, 0x00347884d1103130UL) /* 1249 */ P(10, 0x263a27727a6883c3UL, 0x00340dd3ac39bf56UL) /* 1259 */ P(18, 0x78e221472ab33855UL, 0x003351fdfecc140cUL) /* 1277 */ P( 2, 0x95eac88e82e6faffUL, 0x00333d72b089b524UL) /* 1279 */ P( 4, 0xf66c258317be8dabUL, 0x0033148d44d6b261UL) /* 1283 */ P( 6, 0x09ee202c7cb91939UL, 0x0032d7aef8412458UL) /* 1289 */ P( 2, 0x8d2fca1042a09ea3UL, 0x0032c3850e79c0f1UL) /* 1291 */ P( 6, 0x82779c856d8b8bf1UL, 0x00328766d59048a2UL) /* 1297 */ P( 4, 0x3879361cba8a223dUL, 0x00325fa18cb11833UL) /* 1301 */ P( 2, 0xf23f43639c3182a7UL, 0x00324bd659327e22UL) /* 1303 */ P( 4, 0xa03868fc474bcd13UL, 0x0032246e784360f4UL) /* 1307 */ P(12, 0x651e78b8c5311a97UL, 0x0031afa5f1a33a08UL) /* 1319 */ P( 2, 0x8ffce639c00c6719UL, 0x00319c63ff398e70UL) /* 1321 */ P( 6, 0xf7b460754b0b61cfUL, 0x003162f7519a86a7UL) /* 1327 */ P(34, 0x7b03f3359b8e63b1UL, 0x0030271fc9d3fc3cUL) /* 1361 */ P( 6, 0xa55c5326041eb667UL, 0x002ff104ae89750bUL) /* 1367 */ P( 6, 0x647f88ab896a76f5UL, 0x002fbb62a236d133UL) /* 1373 */ P( 8, 0x8fd971434a55a46dUL, 0x002f74997d2070b4UL) /* 1381 */ P(18, 0x9fbf969958046447UL, 0x002ed84aa8b6fce3UL) /* 1399 */ P(10, 0x9986feba69be3a81UL, 0x002e832df7a46dbdUL) /* 1409 */ P(14, 0xa668b3e6d053796fUL, 0x002e0e0846857cabUL) /* 1423 */ P( 4, 0x97694e6589f4e09bUL, 0x002decfbdfb55ee6UL) /* 1427 */ P( 2, 0x37890c00b7721dbdUL, 0x002ddc876f3ff488UL) /* 1429 */ P( 4, 0x5ac094a235f37ea9UL, 0x002dbbc1d4c482c4UL) /* 1433 */ P( 6, 0x31cff775f2d5d65fUL, 0x002d8af0e0de0556UL) /* 1439 */ P( 8, 0xddad8e6b36505217UL, 0x002d4a7b7d14b30aUL) /* 1447 */ P( 4, 0x5a27df897062cd03UL, 0x002d2a85073bcf4eUL) /* 1451 */ P( 2, 0xe2396fe0fdb5a625UL, 0x002d1a9ab13e8be4UL) /* 1453 */ P( 6, 0xb352a4957e82317bUL, 0x002ceb1eb4b9fd8bUL) /* 1459 */ P(12, 0xd8ab3f2c60c2ea3fUL, 0x002c8d503a79794cUL) /* 1471 */ P(10, 0x6893f702f0452479UL, 0x002c404d708784edUL) /* 1481 */ P( 2, 0x9686fdc182acf7e3UL, 0x002c31066315ec52UL) /* 1483 */ P( 4, 0x6854037173dce12fUL, 0x002c1297d80f2664UL) /* 1487 */ P( 2, 0x7f0ded1685c27331UL, 0x002c037044c55f6bUL) /* 1489 */ P( 4, 0xeeda72e1fe490b7dUL, 0x002be5404cd13086UL) /* 1493 */ P( 6, 0x9e7bfc959a8e6e53UL, 0x002bb845adaf0cceUL) /* 1499 */ P(12, 0x49b314d6d4753dd7UL, 0x002b5f62c639f16dUL) /* 1511 */ P(12, 0x2e8f8c5ac4aa1b3bUL, 0x002b07e6734f2b88UL) /* 1523 */ P( 8, 0xb8ef723481163d33UL, 0x002ace569d8342b7UL) /* 1531 */ P(12, 0x6a2ec96a594287b7UL, 0x002a791d5dbd4dcfUL) /* 1543 */ P( 6, 0xdba41c6d13aab8c5UL, 0x002a4eff8113017cUL) /* 1549 */ P( 4, 0xc2adbe648dc3aaf1UL, 0x002a3319e156df32UL) /* 1553 */ P( 6, 0x87a2bade565f91a7UL, 0x002a0986286526eaUL) /* 1559 */ P( 8, 0x4d6fe8798c01f5dfUL, 0x0029d29551d91e39UL) /* 1567 */ P( 4, 0x3791310c8c23d98bUL, 0x0029b7529e109f0aUL) /* 1571 */ P( 8, 0xf80e446b01228883UL, 0x00298137491ea465UL) /* 1579 */ P( 4, 0x9aed1436fbf500cfUL, 0x0029665e1eb9f9daUL) /* 1583 */ P(14, 0x7839b54cc8b24115UL, 0x002909752e019a5eUL) /* 1597 */ P( 4, 0xc128c646ad0309c1UL, 0x0028ef35e2e5efb0UL) /* 1601 */ P( 6, 0x14de631624a3c377UL, 0x0028c815aa4b8278UL) /* 1607 */ P( 2, 0x3f7b9fe68b0ecbf9UL, 0x0028bb1b867199daUL) /* 1609 */ P( 4, 0x284ffd75ec00a285UL, 0x0028a13ff5d7b002UL) /* 1613 */ P( 6, 0x37803cb80dea2ddbUL, 0x00287ab3f173e755UL) /* 1619 */ P( 2, 0x86b63f7c9ac4c6fdUL, 0x00286dead67713bdUL) /* 1621 */ P( 6, 0x8b6851d1bd99b9d3UL, 0x002847bfcda6503eUL) /* 1627 */ P(10, 0xb62fda77ca343b6dUL, 0x002808c1ea6b4777UL) /* 1637 */ P(20, 0x1f0dc009e34383c9UL, 0x00278d0e0f23ff61UL) /* 1657 */ P( 6, 0x496dc21ddd35b97fUL, 0x002768863c093c7fUL) /* 1663 */ P( 4, 0xb0e96ce17090f82bUL, 0x0027505115a73ca8UL) /* 1667 */ P( 2, 0xaadf05acdd7d024dUL, 0x00274441a61dc1b9UL) /* 1669 */ P(24, 0xcb138196746eafb5UL, 0x0026b5c166113cf0UL) /* 1693 */ P( 4, 0x347f523736755d61UL, 0x00269e65ad07b18eUL) /* 1697 */ P( 2, 0xd14a48a051f7dd0bUL, 0x002692c25f877560UL) /* 1699 */ P(10, 0x474d71b1ce914d25UL, 0x002658fa7523cd11UL) /* 1709 */ P(12, 0x386063f5e28c1f89UL, 0x0026148710cf0f9eUL) /* 1721 */ P( 2, 0x1db7325e32d04e73UL, 0x002609363b22524fUL) /* 1723 */ P(10, 0xfef748d3893b880dUL, 0x0025d1065a1c1122UL) /* 1733 */ P( 8, 0x2f3351506e935605UL, 0x0025a48a382b863fUL) /* 1741 */ P( 6, 0x7a3637fa2376415bUL, 0x0025837190eccdbcUL) /* 1747 */ P( 6, 0x4ac525d2baa21969UL, 0x00256292e95d510cUL) /* 1753 */ P( 6, 0x3a11c16b42cd351fUL, 0x002541eda98d068cUL) /* 1759 */ P(18, 0x6c7abde0049c2a11UL, 0x0024e15087fed8f5UL) /* 1777 */ P( 6, 0x54dad0303e069ac7UL, 0x0024c18b20979e5dUL) /* 1783 */ P( 4, 0xebf1ac9fdfe91433UL, 0x0024ac7b336de0c5UL) /* 1787 */ P( 2, 0xfafdda8237cec655UL, 0x0024a1fc478c60bbUL) /* 1789 */ P(12, 0xdce3ff6e71ffb739UL, 0x002463801231c009UL) /* 1801 */ P(10, 0xbed5737d6286db1bUL, 0x0024300fd506ed33UL) /* 1811 */ P(12, 0xe479e431fe08b4dfUL, 0x0023f314a494da81UL) /* 1823 */ P( 8, 0x9dd9b0dd7742f897UL, 0x0023cadedd2fad3aUL) /* 1831 */ P(16, 0x8f09d7402c5a5e87UL, 0x00237b7ed2664a03UL) /* 1847 */ P(14, 0x9216d5c4d958738dUL, 0x0023372967dbaf1dUL) /* 1861 */ P( 6, 0xb3139ba11d34ca63UL, 0x00231a308a371f20UL) /* 1867 */ P( 4, 0x47d54f7ed644afafUL, 0x002306fa63e1e600UL) /* 1871 */ P( 2, 0x92a81d85cf11a1b1UL, 0x0022fd6731575684UL) /* 1873 */ P( 4, 0x754b26533253bdfdUL, 0x0022ea507805749cUL) /* 1877 */ P( 2, 0xbbe0efc980bfd467UL, 0x0022e0cce8b3d720UL) /* 1879 */ P(10, 0xc0d8d594f024dca1UL, 0x0022b1887857d161UL) /* 1889 */ P(12, 0x8238d43bcaac1a65UL, 0x00227977fcc49cc0UL) /* 1901 */ P( 6, 0x27779c1fae6175bbUL, 0x00225db37b5e5f4fUL) /* 1907 */ P( 6, 0xa746ca9af708b2c9UL, 0x0022421b91322ed6UL) /* 1913 */ P(18, 0x93f3cd9f389be823UL, 0x0021f05b35f52102UL) /* 1931 */ P( 2, 0x5cb4a4c04c489345UL, 0x0021e75de5c70d60UL) /* 1933 */ P(16, 0xbf6047743e85b6b5UL, 0x0021a01d6c19be96UL) /* 1949 */ P( 2, 0x61c147831563545fUL, 0x0021974a6615c81aUL) /* 1951 */ P(22, 0xedb47c0ae62dee9dUL, 0x00213767697cf36aUL) /* 1973 */ P( 6, 0x0a3824386673a573UL, 0x00211d9f7fad35f1UL) /* 1979 */ P( 8, 0xa4a77d19e575a0ebUL, 0x0020fb7d9dd36c18UL) /* 1987 */ P( 6, 0xa2bee045e066c279UL, 0x0020e2123d661e0eUL) /* 1993 */ P( 4, 0xc23618de8ab43d05UL, 0x0020d135b66ae990UL) /* 1997 */ P( 2, 0x266b515216cb9f2fUL, 0x0020c8cded4d7a8eUL) /* 1999 */ P( 4, 0xe279edd9e9c2e85bUL, 0x0020b80b3f43ddbfUL) /* 2003 */ P( 8, 0xd0c591c221dc9c53UL, 0x002096b9180f46a6UL) /* 2011 */ P( 6, 0x06da8ee9c9ee7c21UL, 0x00207de7e28de5daUL) /* 2017 */ P(10, 0x9dfebcaf4c27e8c3UL, 0x002054dec8cf1fb3UL) /* 2027 */ P( 2, 0x49aeff9f19dd6de5UL, 0x00204cb630b3aab5UL) /* 2029 */ P(10, 0x86976a57a296e9c7UL, 0x00202428adc37bebUL) /* 2039 */ P(14, 0xa3b9abf4872b84cdUL, 0x001fec0c7834def4UL) /* 2053 */ P(10, 0x34fca6483895e6efUL, 0x001fc46fae98a1d0UL) /* 2063 */ P( 6, 0x34b5a333988f873dUL, 0x001facda430ff619UL) /* 2069 */ P(12, 0xd9dd4f19b5f17be1UL, 0x001f7e17dd8e15e5UL) /* 2081 */ P( 2, 0xb935b507fd0ce78bUL, 0x001f765a3556a4eeUL) /* 2083 */ P( 4, 0xb450f5540660e797UL, 0x001f66ea49d802f1UL) /* 2087 */ P( 2, 0x63ff82831ffc1419UL, 0x001f5f3800faf9c0UL) /* 2089 */ P(10, 0x8992f718c22a32fbUL, 0x001f38f4e6c0f1f9UL) /* 2099 */ P(12, 0x5f3253ad0d37e7bfUL, 0x001f0b8546752578UL) /* 2111 */ P( 2, 0x007c0ffe0fc007c1UL, 0x001f03ff83f001f0UL) /* 2113 */ P(16, 0x4d8ebadc0c0640b1UL, 0x001ec853b0a3883cUL) /* 2129 */ P( 2, 0xe2729af831037bdbUL, 0x001ec0ee573723ebUL) /* 2131 */ P( 6, 0xb8f64bf30feebfe9UL, 0x001eaad38e6f6894UL) /* 2137 */ P( 4, 0xda93124b544c0bf5UL, 0x001e9c28a765fe53UL) /* 2141 */ P( 2, 0x9cf7ff0b593c539fUL, 0x001e94d8758c2003UL) /* 2143 */ P(10, 0xd6bd8861fa0e07d9UL, 0x001e707ba8f65e68UL) /* 2153 */ P( 8, 0x5cfe75c0bd8ab891UL, 0x001e53a2a68f574eUL) /* 2161 */ P(18, 0x43e808757c2e862bUL, 0x001e1380a56b438dUL) /* 2179 */ P(24, 0x90caa96d595c9d93UL, 0x001dbf9f513a3802UL) /* 2203 */ P( 4, 0x8fd550625d07135fUL, 0x001db1d1d58bc600UL) /* 2207 */ P( 6, 0x76b010a86e209f2dUL, 0x001d9d358f53de38UL) /* 2213 */ P( 8, 0xecc0426447769b25UL, 0x001d81e6df6165c7UL) /* 2221 */ P(16, 0xe381339caabe3295UL, 0x001d4bdf7fd40e30UL) /* 2237 */ P( 2, 0xd1b190a2d0c7673fUL, 0x001d452c7a1c958dUL) /* 2239 */ P( 4, 0xc3bce3cf26b0e7ebUL, 0x001d37cf9b902659UL) /* 2243 */ P( 8, 0x5f87e76f56c61ce3UL, 0x001d1d3a5791e97bUL) /* 2251 */ P(16, 0xc06c6857a124b353UL, 0x001ce89fe6b47416UL) /* 2267 */ P( 2, 0x38c040fcba630f75UL, 0x001ce219f3235071UL) /* 2269 */ P( 4, 0xd078bc4fbd533b21UL, 0x001cd516dcf92139UL) /* 2273 */ P( 8, 0xde8e15c5dd354f59UL, 0x001cbb33bd1c2b8bUL) /* 2281 */ P( 6, 0xca61d53d7414260fUL, 0x001ca7e7d2546688UL) /* 2287 */ P( 6, 0xb56bf5ba8eae635dUL, 0x001c94b5c1b3dbd3UL) /* 2293 */ P( 4, 0x44a72cb0fb6e3949UL, 0x001c87f7f9c241c1UL) /* 2297 */ P(12, 0x879839a714f45bcdUL, 0x001c6202706c35a9UL) /* 2309 */ P( 2, 0x02a8994fde5314b7UL, 0x001c5bb8a9437632UL) /* 2311 */ P(22, 0xb971920cf2b90135UL, 0x001c174343b4111eUL) /* 2333 */ P( 6, 0x8a8fd0b7df9a6e8bUL, 0x001c04d0d3e46b42UL) /* 2339 */ P( 2, 0xb31f9a84c1c6eaadUL, 0x001bfeb00fbf4308UL) /* 2341 */ P( 6, 0x92293b02823c6d83UL, 0x001bec5dce0b202dUL) /* 2347 */ P( 4, 0xeee77ff20fe5ddcfUL, 0x001be03444620037UL) /* 2351 */ P( 6, 0x0e1ea0f6c496c11dUL, 0x001bce09c66f6fc3UL) /* 2357 */ P(14, 0xfdf2d3d6f88ccb6bUL, 0x001ba40228d02b30UL) /* 2371 */ P( 6, 0xfa9d74a3457738f9UL, 0x001b9225b1cf8919UL) /* 2377 */ P( 4, 0xefc3ca3db71a5785UL, 0x001b864a2ff3f53fUL) /* 2381 */ P( 2, 0x8e2071718d0d6dafUL, 0x001b80604150e49bUL) /* 2383 */ P( 6, 0xbc0fdbfeb6cfabfdUL, 0x001b6eb1aaeaacf3UL) /* 2389 */ P( 4, 0x1eeab613e5e5aee9UL, 0x001b62f48da3c8ccUL) /* 2393 */ P( 6, 0x2d2388e90e9e929fUL, 0x001b516babe96092UL) /* 2399 */ P(12, 0x81dbafba588ddb43UL, 0x001b2e9cef1e0c87UL) /* 2411 */ P( 6, 0x52eebc51c4799791UL, 0x001b1d56bedc849bUL) /* 2417 */ P( 6, 0x1c6bc4693b45a047UL, 0x001b0c267546aec0UL) /* 2423 */ P(14, 0x06eee0974498874dUL, 0x001ae45f62024fa0UL) /* 2437 */ P( 4, 0xd85b7377a9953cb9UL, 0x001ad917631b5f54UL) /* 2441 */ P( 6, 0x4b6df412d4caf56fUL, 0x001ac83d18cb608fUL) /* 2447 */ P(12, 0x6b8afbbb4a053493UL, 0x001aa6c7ad8c063fUL) /* 2459 */ P( 8, 0xcc5299c96ac7720bUL, 0x001a90a7b1228e2aUL) /* 2467 */ P( 6, 0xadce84b5c710aa99UL, 0x001a8027c03ba059UL) /* 2473 */ P( 4, 0x9d673f5aa3804225UL, 0x001a7533289deb89UL) /* 2477 */ P(26, 0xe6541268efbce7f7UL, 0x001a2ed7ce16b49fUL) /* 2503 */ P(18, 0xfcf41e76cf5be669UL, 0x0019fefc0a279a73UL) /* 2521 */ P(10, 0x5c3eb5dc31c383cbUL, 0x0019e4b0cd873b5fUL) /* 2531 */ P( 8, 0x301832d11d8ad6c3UL, 0x0019cfcdfd60e514UL) /* 2539 */ P( 4, 0x2e9c0942f1ce450fUL, 0x0019c56932d66c85UL) /* 2543 */ P( 6, 0x97f3f2be37a39a5dUL, 0x0019b5e1ab6fc7c2UL) /* 2549 */ P( 2, 0xe8b7d8a9654187c7UL, 0x0019b0b8a62f2a73UL) /* 2551 */ P( 6, 0xb5d024d7da5b1b55UL, 0x0019a149fc98942cUL) /* 2557 */ P(22, 0xb8ba9d6e7ae3501bUL, 0x001969517ec25b85UL) /* 2579 */ P(12, 0xf50865f71b90f1dfUL, 0x00194b3083360ba8UL) /* 2591 */ P( 2, 0x739c1682847df9e1UL, 0x00194631f4bebdc1UL) /* 2593 */ P(16, 0xc470a4d842b90ed1UL, 0x00191e84127268fdUL) /* 2609 */ P( 8, 0x1fb1be11698cc409UL, 0x00190adbb543984fUL) /* 2617 */ P( 4, 0xd8d5512a7cd35d15UL, 0x001901130bd18200UL) /* 2621 */ P(12, 0xa5496821723e07f9UL, 0x0018e3e6b889ac94UL) /* 2633 */ P(14, 0xbcc8c6d7abaa8167UL, 0x0018c233420e1ec1UL) /* 2647 */ P(10, 0x52c396c95eb619a1UL, 0x0018aa5872d92bd6UL) /* 2657 */ P( 2, 0x6eb7e380878ec74bUL, 0x0018a5989945ccf9UL) /* 2659 */ P( 4, 0x3d5513b504537157UL, 0x00189c1e60b57f60UL) /* 2663 */ P( 8, 0x314391f8862e948fUL, 0x0018893fbc8690b9UL) /* 2671 */ P( 6, 0xdc0b17cfcd81f5ddUL, 0x00187b2bb3e1041cUL) /* 2677 */ P( 6, 0x2f6bea3ec89044b3UL, 0x00186d27c9cdcfb8UL) /* 2683 */ P( 4, 0xce13a05869f1b57fUL, 0x001863d8bf4f2c1cUL) /* 2687 */ P( 2, 0x7593474e8ace3581UL, 0x00185f33e2ad7593UL) /* 2689 */ P( 4, 0x07fc329295a05e4dUL, 0x001855ef75973e13UL) /* 2693 */ P( 6, 0xb05377cba4908d23UL, 0x001848160153f134UL) /* 2699 */ P( 8, 0xe7b2131a628aa39bUL, 0x001835b72e6f0656UL) /* 2707 */ P( 4, 0x9031dbed7de01527UL, 0x00182c922d83eb39UL) /* 2711 */ P( 2, 0x76844b1c670aa9a9UL, 0x0018280243c0365aUL) /* 2713 */ P( 6, 0x6a03f4533b08915fUL, 0x00181a5cd5898e73UL) /* 2719 */ P(10, 0x1dbca579db0a3999UL, 0x001803c0961773aaUL) /* 2729 */ P( 2, 0x002ffe800bffa003UL, 0x0017ff4005ffd001UL) /* 2731 */ P(10, 0x478ab1a3e936139dUL, 0x0017e8d670433edbUL) /* 2741 */ P( 8, 0x66e722bc4c5cc095UL, 0x0017d7066cf4bb5dUL) /* 2749 */ P( 4, 0x7a8f63c717278541UL, 0x0017ce285b806b1fUL) /* 2753 */ P(14, 0xdf6eee24d292bc2fUL, 0x0017af52cdf27e02UL) /* 2767 */ P(10, 0x9fc20d17237dd569UL, 0x0017997d47d01039UL) /* 2777 */ P(12, 0xcdf9932356bda2edUL, 0x00177f7ec2c6d0baUL) /* 2789 */ P( 2, 0x97b5e332e80f68d7UL, 0x00177b2f3cd00756UL) /* 2791 */ P( 6, 0x46eee26fd875e2e5UL, 0x00176e4a22f692a0UL) /* 2797 */ P( 4, 0x3548a8e65157a611UL, 0x001765b94271e11bUL) /* 2801 */ P( 2, 0xc288d03be9b71e3bUL, 0x001761732b044ae4UL) /* 2803 */ P(16, 0x8151186db38937abUL, 0x00173f7a5300a2bcUL) /* 2819 */ P(14, 0x7800b910895a45f1UL, 0x001722112b48be1fUL) /* 2833 */ P( 4, 0xaee0b024182eec3dUL, 0x001719b7a16eb843UL) /* 2837 */ P( 6, 0x96323eda173b5713UL, 0x00170d3c99cc5052UL) /* 2843 */ P( 8, 0x0ed0dbd03ae77c8bUL, 0x0016fcad7aed3bb6UL) /* 2851 */ P( 6, 0xf73800b7828dc119UL, 0x0016f051b8231ffdUL) /* 2857 */ P( 4, 0x1b61715ec22b7ca5UL, 0x0016e81beae20643UL) /* 2861 */ P(18, 0xa8533a991ead64bfUL, 0x0016c3721584c1d8UL) /* 2879 */ P( 8, 0x7f6c7290e46c2e77UL, 0x0016b34c2ba09663UL) /* 2887 */ P(10, 0x6325e8d907b01db1UL, 0x00169f3ce292ddcdUL) /* 2897 */ P( 6, 0x28909f70152a1067UL, 0x00169344b2220a0dUL) /* 2903 */ P( 6, 0xea7077af0997a0f5UL, 0x001687592593c1b1UL) /* 2909 */ P( 8, 0x7e605cad10c32e6dUL, 0x00167787f1418ec9UL) /* 2917 */ P(10, 0x471b33570635b38fUL, 0x001663e190395ff2UL) /* 2927 */ P(12, 0xab559fa997a61bb3UL, 0x00164c7a4b6eb5b3UL) /* 2939 */ P(14, 0xad4bdae562bddab9UL, 0x0016316a061182fdUL) /* 2953 */ P( 4, 0x055e1b2f2ed62f45UL, 0x001629ba914584e4UL) /* 2957 */ P( 6, 0x03cd328b1a2dca9bUL, 0x00161e3d57de21b2UL) /* 2963 */ P( 6, 0xd28f4e08733218a9UL, 0x001612cc01b977f0UL) /* 2969 */ P( 2, 0xb6800b077f186293UL, 0x00160efe30c525ffUL) /* 2971 */ P(28, 0x6fbd138c3fd9c207UL, 0x0015da45249ec5deUL) /* 2999 */ P( 2, 0xb117ccd12ae88a89UL, 0x0015d68ab4acff92UL) /* 3001 */ P(10, 0x2f1a1a044046bcebUL, 0x0015c3f989d1eb15UL) /* 3011 */ P( 8, 0x548aba0b060541e3UL, 0x0015b535ad11b8f0UL) /* 3019 */ P( 4, 0xcf4e808cea111b2fUL, 0x0015addb3f424ec1UL) /* 3023 */ P(14, 0xdbec1b4fa855a475UL, 0x00159445cb91be6bUL) /* 3037 */ P( 4, 0xe3f794eb600d7821UL, 0x00158d0199771e63UL) /* 3041 */ P( 8, 0x34fae0d9a11f7c59UL, 0x00157e87d9b69e04UL) /* 3049 */ P(12, 0xf006b0ccbbac085dUL, 0x001568f58bc01ac3UL) /* 3061 */ P( 6, 0x3f45076dc3114733UL, 0x00155e3c993fda9bUL) /* 3067 */ P(12, 0xeef49bfa58a1a1b7UL, 0x001548eacc5e1e6eUL) /* 3079 */ P( 4, 0x12c4218bea691fa3UL, 0x001541d8f91ba6a7UL) /* 3083 */ P( 6, 0xbc7504e3bd5e64f1UL, 0x00153747060cc340UL) /* 3089 */ P(20, 0x4ee21c292bb92fadUL, 0x001514569f93f7c4UL) /* 3109 */ P(10, 0x34338b7327a4bacfUL, 0x00150309705d3d79UL) /* 3119 */ P( 2, 0x3fe5c0833d6fccd1UL, 0x0014ff97020cf5bfUL) /* 3121 */ P(16, 0xb1e70743535203c1UL, 0x0014e42c114cf47eUL) /* 3137 */ P(26, 0xefbb5dcdfb4e43d3UL, 0x0014b835bdcb6447UL) /* 3163 */ P( 4, 0xca68467ca5394f9fUL, 0x0014b182b53a9ab7UL) /* 3167 */ P( 2, 0x8c51c081408b97a1UL, 0x0014ae2ad094a3d3UL) /* 3169 */ P(12, 0x3275a899dfa5dd65UL, 0x00149a320ea59f96UL) /* 3181 */ P( 6, 0x9e674cb62e1b78bbUL, 0x001490441de1a2fbUL) /* 3187 */ P( 4, 0xa37ff5bb2a998d47UL, 0x001489aacce57200UL) /* 3191 */ P(12, 0x792a999db131a22bUL, 0x001475f82ad6ff99UL) /* 3203 */ P( 6, 0x1b48841bc30d29b9UL, 0x00146c2cfe53204fUL) /* 3209 */ P( 8, 0xf06721d2011d3471UL, 0x00145f2ca490d4a1UL) /* 3217 */ P( 4, 0x93fd2386dff85ebdUL, 0x001458b2aae0ec87UL) /* 3221 */ P( 8, 0x4ce72f54c07ed9b5UL, 0x00144bcb0a3a3150UL) /* 3229 */ P(22, 0xd6d0fd3e71dd827bUL, 0x001428a1e65441d4UL) /* 3251 */ P( 2, 0x856405fb1eed819dUL, 0x00142575a6c210d7UL) /* 3253 */ P( 4, 0x8ea8aceb7c443989UL, 0x00141f2025ba5c46UL) /* 3257 */ P( 2, 0x34a13026f62e5873UL, 0x00141bf6e35420fdUL) /* 3259 */ P(12, 0x1eea0208ec0af4f7UL, 0x001409141d1d313aUL) /* 3271 */ P(28, 0x63679853cea598cbUL, 0x0013dd8bc19c3513UL) /* 3299 */ P( 2, 0xc30b3ebd61f2d0edUL, 0x0013da76f714dc8fUL) /* 3301 */ P( 6, 0x7eb9037bc7f43bc3UL, 0x0013d13e50f8f49eUL) /* 3307 */ P( 6, 0xa583e6f6ce016411UL, 0x0013c80e37ca3819UL) /* 3313 */ P( 6, 0xf1938d895f1a74c7UL, 0x0013bee69fa99ccfUL) /* 3319 */ P( 4, 0x80cf1491c1e81e33UL, 0x0013b8d0ede55835UL) /* 3323 */ P( 6, 0x3c0f12886ba8f301UL, 0x0013afb7680bb054UL) /* 3329 */ P( 2, 0x0e4b786e0dfcc5abUL, 0x0013acb0c3841c96UL) /* 3331 */ P(12, 0x672684c93f2d41efUL, 0x00139a9c5f434fdeUL) /* 3343 */ P( 4, 0xe00757badb35c51bUL, 0x0013949cf33a0d9dUL) /* 3347 */ P(12, 0xd6d84afe66472edfUL, 0x001382b4a00c31b0UL) /* 3359 */ P( 2, 0xfbbc0eedcbbfb6e1UL, 0x00137fbbc0eedcbbUL) /* 3361 */ P(10, 0x250f43aa08a84983UL, 0x001370ecf047b069UL) /* 3371 */ P( 2, 0x04400e927b1acaa5UL, 0x00136df9790e3155UL) /* 3373 */ P(16, 0x56572be34b9d3215UL, 0x0013567dd8defd5bUL) /* 3389 */ P( 2, 0x87964ef7781c62bfUL, 0x0013539261fdbc34UL) /* 3391 */ P(16, 0x29ed84051c06e9afUL, 0x00133c564292d28aUL) /* 3407 */ P( 6, 0xb00acd11ed3f87fdUL, 0x001333ae178d6388UL) /* 3413 */ P(20, 0x06307881744152d9UL, 0x0013170ad00d1fd7UL) /* 3433 */ P(16, 0x7a786459f5c1ccc9UL, 0x0013005f01db0947UL) /* 3449 */ P( 8, 0x1308125d74563281UL, 0x0012f51d40342210UL) /* 3457 */ P( 4, 0x395310a480b3e34dUL, 0x0012ef815e4ed950UL) /* 3461 */ P( 2, 0x35985baa8b202837UL, 0x0012ecb4abccd827UL) /* 3463 */ P( 4, 0x96304a6e052b3223UL, 0x0012e71dc1d3d820UL) /* 3467 */ P( 2, 0xbd8265fc9af8fd45UL, 0x0012e45389a16495UL) /* 3469 */ P(22, 0x1b6d0b383ec58e0bUL, 0x0012c5d9226476ccUL) /* 3491 */ P( 8, 0xc21a7c3b68b28503UL, 0x0012badc391156fdUL) /* 3499 */ P(12, 0x236fa180fbfd6007UL, 0x0012aa78e412f522UL) /* 3511 */ P( 6, 0xc42accd440ed9595UL, 0x0012a251f5f47fd1UL) /* 3517 */ P(10, 0x7acf7128236ba3f7UL, 0x001294cb85c53534UL) /* 3527 */ P( 2, 0xf909367a987b9c79UL, 0x0012921963beb65eUL) /* 3529 */ P( 4, 0xb64efb252bfba705UL, 0x00128cb777c69ca8UL) /* 3533 */ P( 6, 0x980d4f5a7e4cd25bUL, 0x001284aa6cf07294UL) /* 3539 */ P( 2, 0xe1ecc4ef27b0c37dUL, 0x001281fcf6ac7f87UL) /* 3541 */ P( 6, 0x9111aebb81d72653UL, 0x001279f937367db9UL) /* 3547 */ P(10, 0x8951f985cb2c67edUL, 0x00126cad0488be94UL) /* 3557 */ P( 2, 0xc439d4fc54e0b5d7UL, 0x00126a06794646a2UL) /* 3559 */ P(12, 0xe857bf31896d533bUL, 0x00125a2f2bcd3e95UL) /* 3571 */ P(10, 0xb614bb4cb5023755UL, 0x00124d108389e6b1UL) /* 3581 */ P( 2, 0x938a89e5473bf1ffUL, 0x00124a73083771acUL) /* 3583 */ P(10, 0xeac481aca34de039UL, 0x00123d6acda0620aUL) /* 3593 */ P(14, 0x14b961badf4809a7UL, 0x00122b4b2917eafdUL) /* 3607 */ P( 6, 0x76784fecba352435UL, 0x00122391bfce1e2fUL) /* 3613 */ P( 4, 0xefa689bb58aef5e1UL, 0x00121e6f1ea579f2UL) /* 3617 */ P( 6, 0xb2b2c4db9c3a8197UL, 0x001216c09e471568UL) /* 3623 */ P( 8, 0x2503bc992279f8cfUL, 0x00120c8cb9d93909UL) /* 3631 */ P( 6, 0xd2ab9aec5ca1541dUL, 0x001204ed58e64ef9UL) /* 3637 */ P( 6, 0x3e78ba1460f99af3UL, 0x0011fd546578f00cUL) /* 3643 */ P(16, 0x0a01426572cfcb63UL, 0x0011e9310b8b4c9cUL) /* 3659 */ P(12, 0xbea857968f3cbd67UL, 0x0011da3405db9911UL) /* 3671 */ P( 2, 0x78db213eefe659e9UL, 0x0011d7b6f4eb055dUL) /* 3673 */ P( 4, 0x963e8541a74d35f5UL, 0x0011d2bee748c145UL) /* 3677 */ P(14, 0x9e22d152776f2e43UL, 0x0011c1706ddce7a7UL) /* 3691 */ P( 6, 0x05d10d39d1e1f291UL, 0x0011ba0fed2a4f14UL) /* 3697 */ P( 4, 0x374468dccaced1ddUL, 0x0011b528538ed64aUL) /* 3701 */ P( 8, 0x8d145c7d110c5ad5UL, 0x0011ab61404242acUL) /* 3709 */ P(10, 0x3251a39f5acb5737UL, 0x00119f378ce81d2fUL) /* 3719 */ P( 8, 0xa66e50171443506fUL, 0x001195889ece79daUL) /* 3727 */ P( 6, 0x124f69ad91dd4cbdUL, 0x00118e4c65387077UL) /* 3733 */ P( 6, 0xec24f8f2a61a2793UL, 0x001187161d70e725UL) /* 3739 */ P(22, 0xb472148e656b7a51UL, 0x00116cd6d1c85239UL) /* 3761 */ P( 6, 0x0adf9570e1142f07UL, 0x001165bbe7ce86b1UL) /* 3767 */ P( 2, 0x89bf33b065119789UL, 0x0011635ee344ce36UL) /* 3769 */ P(10, 0x8f0149803cb291ebUL, 0x0011579767b6d679UL) /* 3779 */ P(14, 0x8334b63afd190a31UL, 0x00114734711e2b54UL) /* 3793 */ P( 4, 0x920908d50d6aba7dUL, 0x0011428b90147f05UL) /* 3797 */ P( 6, 0x57d8b018c5a33d53UL, 0x00113b92f3021636UL) /* 3803 */ P(18, 0xea1773092dc27ee5UL, 0x001126cabc886884UL) /* 3821 */ P( 2, 0xcae5f38b7bf2e00fUL, 0x0011247eb1b85976UL) /* 3823 */ P(10, 0x2bd02df34f695349UL, 0x0011190bb01efd65UL) /* 3833 */ P(14, 0xddfecd5be62e2eb7UL, 0x0011091de0fd679cUL) /* 3847 */ P( 4, 0xdbf849ebec96c4a3UL, 0x001104963c7e4e0bUL) /* 3851 */ P( 2, 0xda31d4d0187357c5UL, 0x00110253516420b0UL) /* 3853 */ P(10, 0xe34e21cc2d5418a7UL, 0x0010f70db7c41797UL) /* 3863 */ P(14, 0x68ca5137a9e574adUL, 0x0010e75ee2bf9ecdUL) /* 3877 */ P( 4, 0x3eaa0d0f804bfd19UL, 0x0010e2e91c6e0676UL) /* 3881 */ P( 8, 0x554fb753cc20e9d1UL, 0x0010da049b9d428dUL) /* 3889 */ P(18, 0x797afcca1300756bUL, 0x0010c6248fe3b1a2UL) /* 3907 */ P( 4, 0x8b8d950b52eeea77UL, 0x0010c1c03ed690ebUL) /* 3911 */ P( 6, 0xfb6cd166acabc185UL, 0x0010bb2e1379e3a2UL) /* 3917 */ P( 2, 0x4eb6c5ed9437a7afUL, 0x0010b8fe7f61228eUL) /* 3919 */ P( 4, 0xd1eddbd91b790cdbUL, 0x0010b4a10d60a4f7UL) /* 3923 */ P( 6, 0x93d714ea4d8948e9UL, 0x0010ae192681ec0fUL) /* 3929 */ P( 2, 0x3ca13ed8145188d3UL, 0x0010abecfbe5b0aeUL) /* 3931 */ P(12, 0x829086016da89c57UL, 0x00109eefd568b96dUL) /* 3943 */ P( 4, 0xd7da1f432124a543UL, 0x00109a9ff178b40cUL) /* 3947 */ P(20, 0x7ead5581632fb07fUL, 0x00108531e22f9ff9UL) /* 3967 */ P(22, 0x35443837f63ec3bdUL, 0x00106ddec1af4417UL) /* 3989 */ #undef FIRST_OMITTED_PRIME #define FIRST_OMITTED_PRIME 4001 gcl-2.6.14/gmp4/demos/factorize.c0000644000175000017500000002025114360276512015103 0ustar cammcamm/* Factoring with Pollard's rho method. Copyright 1995, 1997-2003, 2005, 2009, 2012 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include #include "gmp.h" static unsigned char primes_diff[] = { #define P(a,b,c) a, #include "primes.h" #undef P }; #define PRIMES_PTAB_ENTRIES (sizeof(primes_diff) / sizeof(primes_diff[0])) int flag_verbose = 0; /* Prove primality or run probabilistic tests. */ int flag_prove_primality = 1; /* Number of Miller-Rabin tests to run when not proving primality. */ #define MR_REPS 25 struct factors { mpz_t *p; unsigned long *e; long nfactors; }; void factor (mpz_t, struct factors *); void factor_init (struct factors *factors) { factors->p = malloc (1); factors->e = malloc (1); factors->nfactors = 0; } void factor_clear (struct factors *factors) { int i; for (i = 0; i < factors->nfactors; i++) mpz_clear (factors->p[i]); free (factors->p); free (factors->e); } void factor_insert (struct factors *factors, mpz_t prime) { long nfactors = factors->nfactors; mpz_t *p = factors->p; unsigned long *e = factors->e; long i, j; /* Locate position for insert new or increment e. */ for (i = nfactors - 1; i >= 0; i--) { if (mpz_cmp (p[i], prime) <= 0) break; } if (i < 0 || mpz_cmp (p[i], prime) != 0) { p = realloc (p, (nfactors + 1) * sizeof p[0]); e = realloc (e, (nfactors + 1) * sizeof e[0]); mpz_init (p[nfactors]); for (j = nfactors - 1; j > i; j--) { mpz_set (p[j + 1], p[j]); e[j + 1] = e[j]; } mpz_set (p[i + 1], prime); e[i + 1] = 1; factors->p = p; factors->e = e; factors->nfactors = nfactors + 1; } else { e[i] += 1; } } void factor_insert_ui (struct factors *factors, unsigned long prime) { mpz_t pz; mpz_init_set_ui (pz, prime); factor_insert (factors, pz); mpz_clear (pz); } void factor_using_division (mpz_t t, struct factors *factors) { mpz_t q; unsigned long int p; int i; if (flag_verbose > 0) { printf ("[trial division] "); } mpz_init (q); p = mpz_scan1 (t, 0); mpz_div_2exp (t, t, p); while (p) { factor_insert_ui (factors, 2); --p; } p = 3; for (i = 1; i <= PRIMES_PTAB_ENTRIES;) { if (! mpz_divisible_ui_p (t, p)) { p += primes_diff[i++]; if (mpz_cmp_ui (t, p * p) < 0) break; } else { mpz_tdiv_q_ui (t, t, p); factor_insert_ui (factors, p); } } mpz_clear (q); } static int mp_millerrabin (mpz_srcptr n, mpz_srcptr nm1, mpz_ptr x, mpz_ptr y, mpz_srcptr q, unsigned long int k) { unsigned long int i; mpz_powm (y, x, q, n); if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0) return 1; for (i = 1; i < k; i++) { mpz_powm_ui (y, y, 2, n); if (mpz_cmp (y, nm1) == 0) return 1; if (mpz_cmp_ui (y, 1) == 0) return 0; } return 0; } int mp_prime_p (mpz_t n) { int k, r, is_prime; mpz_t q, a, nm1, tmp; struct factors factors; if (mpz_cmp_ui (n, 1) <= 0) return 0; /* We have already casted out small primes. */ if (mpz_cmp_ui (n, (long) FIRST_OMITTED_PRIME * FIRST_OMITTED_PRIME) < 0) return 1; mpz_inits (q, a, nm1, tmp, NULL); /* Precomputation for Miller-Rabin. */ mpz_sub_ui (nm1, n, 1); /* Find q and k, where q is odd and n = 1 + 2**k * q. */ k = mpz_scan1 (nm1, 0); mpz_tdiv_q_2exp (q, nm1, k); mpz_set_ui (a, 2); /* Perform a Miller-Rabin test, finds most composites quickly. */ if (!mp_millerrabin (n, nm1, a, tmp, q, k)) { is_prime = 0; goto ret2; } if (flag_prove_primality) { /* Factor n-1 for Lucas. */ mpz_set (tmp, nm1); factor (tmp, &factors); } /* Loop until Lucas proves our number prime, or Miller-Rabin proves our number composite. */ for (r = 0; r < PRIMES_PTAB_ENTRIES; r++) { int i; if (flag_prove_primality) { is_prime = 1; for (i = 0; i < factors.nfactors && is_prime; i++) { mpz_divexact (tmp, nm1, factors.p[i]); mpz_powm (tmp, a, tmp, n); is_prime = mpz_cmp_ui (tmp, 1) != 0; } } else { /* After enough Miller-Rabin runs, be content. */ is_prime = (r == MR_REPS - 1); } if (is_prime) goto ret1; mpz_add_ui (a, a, primes_diff[r]); /* Establish new base. */ if (!mp_millerrabin (n, nm1, a, tmp, q, k)) { is_prime = 0; goto ret1; } } fprintf (stderr, "Lucas prime test failure. This should not happen\n"); abort (); ret1: if (flag_prove_primality) factor_clear (&factors); ret2: mpz_clears (q, a, nm1, tmp, NULL); return is_prime; } void factor_using_pollard_rho (mpz_t n, unsigned long a, struct factors *factors) { mpz_t x, z, y, P; mpz_t t, t2; unsigned long long k, l, i; if (flag_verbose > 0) { printf ("[pollard-rho (%lu)] ", a); } mpz_inits (t, t2, NULL); mpz_init_set_si (y, 2); mpz_init_set_si (x, 2); mpz_init_set_si (z, 2); mpz_init_set_ui (P, 1); k = 1; l = 1; while (mpz_cmp_ui (n, 1) != 0) { for (;;) { do { mpz_mul (t, x, x); mpz_mod (x, t, n); mpz_add_ui (x, x, a); mpz_sub (t, z, x); mpz_mul (t2, P, t); mpz_mod (P, t2, n); if (k % 32 == 1) { mpz_gcd (t, P, n); if (mpz_cmp_ui (t, 1) != 0) goto factor_found; mpz_set (y, x); } } while (--k != 0); mpz_set (z, x); k = l; l = 2 * l; for (i = 0; i < k; i++) { mpz_mul (t, x, x); mpz_mod (x, t, n); mpz_add_ui (x, x, a); } mpz_set (y, x); } factor_found: do { mpz_mul (t, y, y); mpz_mod (y, t, n); mpz_add_ui (y, y, a); mpz_sub (t, z, y); mpz_gcd (t, t, n); } while (mpz_cmp_ui (t, 1) == 0); mpz_divexact (n, n, t); /* divide by t, before t is overwritten */ if (!mp_prime_p (t)) { if (flag_verbose > 0) { printf ("[composite factor--restarting pollard-rho] "); } factor_using_pollard_rho (t, a + 1, factors); } else { factor_insert (factors, t); } if (mp_prime_p (n)) { factor_insert (factors, n); break; } mpz_mod (x, x, n); mpz_mod (z, z, n); mpz_mod (y, y, n); } mpz_clears (P, t2, t, z, x, y, NULL); } void factor (mpz_t t, struct factors *factors) { factor_init (factors); if (mpz_sgn (t) != 0) { factor_using_division (t, factors); if (mpz_cmp_ui (t, 1) != 0) { if (flag_verbose > 0) { printf ("[is number prime?] "); } if (mp_prime_p (t)) factor_insert (factors, t); else factor_using_pollard_rho (t, 1, factors); } } } int main (int argc, char *argv[]) { mpz_t t; int i, j, k; struct factors factors; while (argc > 1) { if (!strcmp (argv[1], "-v")) flag_verbose = 1; else if (!strcmp (argv[1], "-w")) flag_prove_primality = 0; else break; argv++; argc--; } mpz_init (t); if (argc > 1) { for (i = 1; i < argc; i++) { mpz_set_str (t, argv[i], 0); gmp_printf ("%Zd:", t); factor (t, &factors); for (j = 0; j < factors.nfactors; j++) for (k = 0; k < factors.e[j]; k++) gmp_printf (" %Zd", factors.p[j]); puts (""); factor_clear (&factors); } } else { for (;;) { mpz_inp_str (t, stdin, 0); if (feof (stdin)) break; gmp_printf ("%Zd:", t); factor (t, &factors); for (j = 0; j < factors.nfactors; j++) for (k = 0; k < factors.e[j]; k++) gmp_printf (" %Zd", factors.p[j]); puts (""); factor_clear (&factors); } } exit (0); } gcl-2.6.14/gmp4/demos/qcn.c0000644000175000017500000000771114360276512013704 0ustar cammcamm/* Use mpz_kronecker_ui() to calculate an estimate for the quadratic class number h(d), for a given negative fundamental discriminant, using Dirichlet's analytic formula. Copyright 1999-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* Usage: qcn [-p limit] ... A fundamental discriminant means one of the form D or 4*D with D square-free. Each argument is checked to see it's congruent to 0 or 1 mod 4 (as all discriminants must be), and that it's negative, but there's no check on D being square-free. This program is a bit of a toy, there are better methods for calculating the class number and class group structure. Reference: Daniel Shanks, "Class Number, A Theory of Factorization, and Genera", Proc. Symp. Pure Math., vol 20, 1970, pages 415-440. */ #include #include #include #include #include "gmp.h" #ifndef M_PI #define M_PI 3.14159265358979323846 #endif /* A simple but slow primality test. */ int prime_p (unsigned long n) { unsigned long i, limit; if (n == 2) return 1; if (n < 2 || !(n&1)) return 0; limit = (unsigned long) floor (sqrt ((double) n)); for (i = 3; i <= limit; i+=2) if ((n % i) == 0) return 0; return 1; } /* The formula is as follows, with d < 0. w * sqrt(-d) inf p h(d) = ------------ * product -------- 2 * pi p=2 p - (d/p) (d/p) is the Kronecker symbol and the product is over primes p. w is 6 when d=-3, 4 when d=-4, or 2 otherwise. Calculating the product up to p=infinity would take a long time, so for the estimate primes up to 132,000 are used. Shanks found this giving an accuracy of about 1 part in 1000, in normal cases. */ unsigned long p_limit = 132000; double qcn_estimate (mpz_t d) { double h; unsigned long p; /* p=2 */ h = sqrt (-mpz_get_d (d)) / M_PI * 2.0 / (2.0 - mpz_kronecker_ui (d, 2)); if (mpz_cmp_si (d, -3) == 0) h *= 3; else if (mpz_cmp_si (d, -4) == 0) h *= 2; for (p = 3; p <= p_limit; p += 2) if (prime_p (p)) h *= (double) p / (double) (p - mpz_kronecker_ui (d, p)); return h; } void qcn_str (char *num) { mpz_t z; mpz_init_set_str (z, num, 0); if (mpz_sgn (z) >= 0) { mpz_out_str (stdout, 0, z); printf (" is not supported (negatives only)\n"); } else if (mpz_fdiv_ui (z, 4) != 0 && mpz_fdiv_ui (z, 4) != 1) { mpz_out_str (stdout, 0, z); printf (" is not a discriminant (must == 0 or 1 mod 4)\n"); } else { printf ("h("); mpz_out_str (stdout, 0, z); printf (") approx %.1f\n", qcn_estimate (z)); } mpz_clear (z); } int main (int argc, char *argv[]) { int i; int saw_number = 0; for (i = 1; i < argc; i++) { if (strcmp (argv[i], "-p") == 0) { i++; if (i >= argc) { fprintf (stderr, "Missing argument to -p\n"); exit (1); } p_limit = atoi (argv[i]); } else { qcn_str (argv[i]); saw_number = 1; } } if (! saw_number) { /* some default output */ qcn_str ("-85702502803"); /* is 16259 */ qcn_str ("-328878692999"); /* is 1499699 */ qcn_str ("-928185925902146563"); /* is 52739552 */ qcn_str ("-84148631888752647283"); /* is 496652272 */ return 0; } return 0; } gcl-2.6.14/gmp4/demos/perl/0000755000175000017500000000000014360276512013713 5ustar cammcammgcl-2.6.14/gmp4/demos/perl/Makefile.PL0000644000175000017500000000430314360276512015665 0ustar cammcamm# Makefile for GMP perl module. # Copyright 2001, 2003, 2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # Bugs: # # When the generated Makefile re-runs "perl Makefile.PL" the GMP_BUILDDIR # parameter is lost. use ExtUtils::MakeMaker; # Find and remove our parameters @ARGV = map { if (/^GMP_BUILDDIR=(.*)/) { $GMP_BUILDDIR=$1; (); } else { $_; } } (@ARGV); $INC = ""; $LIBS = "-lgmp"; $OBJECT = "GMP.o"; if (defined $GMP_BUILDDIR) { if (! -f "$GMP_BUILDDIR/libgmp.la") { die "$GMP_BUILDDIR doesn't contain libgmp.la\n" . "if it's really a gmp build directory then go there and run \"make libgmp.la\"\n"; } $INC = "-I$GMP_BUILDDIR $INC"; $LIBS = "-L$GMP_BUILDDIR/.libs $LIBS"; } WriteMakefile( NAME => 'GMP', VERSION => '2.00', LIBS => [$LIBS], OBJECT => $OBJECT, INC => $INC, clean => { FILES => 'test.tmp' }, PM => { 'GMP.pm' => '$(INST_LIBDIR)/GMP.pm', 'GMP/Mpz.pm' => '$(INST_LIBDIR)/GMP/Mpz.pm', 'GMP/Mpq.pm' => '$(INST_LIBDIR)/GMP/Mpq.pm', 'GMP/Mpf.pm' => '$(INST_LIBDIR)/GMP/Mpf.pm', 'GMP/Rand.pm' => '$(INST_LIBDIR)/GMP/Rand.pm', } ); # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/perl/typemap0000644000175000017500000000626614360276512015327 0ustar cammcamm# GMP module external subroutine type mappings. # Copyright 2001, 2003 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. TYPEMAP const_string T_PV const_string_assume CONST_STRING_ASSUME mpz MPZ mpq MPQ mpf MPF mpz_assume MPZ_ASSUME mpq_assume MPQ_ASSUME mpf_assume MPF_ASSUME mpz_coerce MPZ_COERCE mpq_coerce MPQ_COERCE mpf_coerce_st0 MPF_COERCE_ST0 mpf_coerce_def MPF_COERCE_DEF randstate RANDSTATE ulong_coerce ULONG_COERCE malloced_string MALLOCED_STRING order_noswap ORDER_NOSWAP dummy DUMMY # perl 5.005 doesn't have UV in its standard typemap, so use this instead gmp_UV GMP_UV INPUT MPZ class_or_croak ($arg, mpz_class); $var = SvMPZ($arg); MPQ class_or_croak ($arg, mpq_class); $var = SvMPQ($arg); MPF class_or_croak ($arg, mpf_class); $var = SvMPF($arg); MPZ_ASSUME MPZ_ASSUME ($var, $arg) MPQ_ASSUME MPQ_ASSUME ($var, $arg) MPF_ASSUME MPF_ASSUME ($var, $arg) MPZ_COERCE $var = coerce_mpz (tmp_mpz_${(my $stnum=$arg)=~s/[^0-9]//g;\$stnum}, $arg) MPQ_COERCE $var = coerce_mpq (tmp_mpq_${(my $stnum=$arg)=~s/[^0-9]//g;\$stnum}, $arg) MPF_COERCE_ST0 /* precision follows ST(0) */ assert (sv_derived_from (ST(0), mpf_class)); $var = coerce_mpf (tmp_mpf_${(my $stnum=$arg)=~s/[^0-9]//g;\$stnum}, $arg, mpf_get_prec (SvMPF(ST(0)))) MPF_COERCE_DEF /* default precision used */ $var = coerce_mpf (tmp_mpf_${(my $stnum=$arg)=~s/[^0-9]//g;\$stnum}, $arg, mpf_get_default_prec()) RANDSTATE class_or_croak ($arg, rand_class); $var = SvRANDSTATE($arg); ULONG_COERCE $var = coerce_ulong ($arg) ORDER_NOSWAP assert ($arg != &PL_sv_yes); DUMMY /* dummy $var */ CONST_STRING_ASSUME /* No need to check for SvPOKp and use SvPV, this mapping is only used for overload_constant, which always gets literal strings. */ assert (SvPOK ($arg)); $var = SvPVX ($arg); OUTPUT MPZ sv_bless (sv_setref_pv ($arg, NULL, $var), mpz_class_hv); MPQ sv_bless (sv_setref_pv ($arg, NULL, $var), mpq_class_hv); MPF sv_bless (sv_setref_pv ($arg, NULL, $var), mpf_class_hv); RANDSTATE sv_setref_pv ($arg, rand_class, $var); MALLOCED_STRING sv_usepvn_mg ($arg, $var, strlen($var)); GMP_UV sv_setuv ($arg, (UV) ($var)); gcl-2.6.14/gmp4/demos/perl/GMP.pm0000644000175000017500000005306614360276512014706 0ustar cammcamm# GMP perl module # Copyright 2001-2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # [Note: The above copyright notice is repeated in the documentation section # below, in order to get it into man pages etc generated by the various pod # conversions. When changing, be sure to update below too.] # This code is designed to work with perl 5.005, so it and the sub-packages # aren't as modern as they could be. package GMP; require Symbol; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(); @EXPORT_OK = qw(version); %EXPORT_TAGS = ('all' => [qw( get_d get_d_2exp get_si get_str integer_p printf sgn sprintf)], 'constants' => [()]); Exporter::export_ok_tags('all'); $VERSION = '2.00'; bootstrap GMP $VERSION; # The format string is cut up into "%" specifiers so GMP types can be # passed to GMP::sprintf_internal. Any "*"s are interpolated before # calling sprintf_internal, which saves worrying about variable # argument lists there. # # Because sprintf_internal is only called after the conversion and # operand have been checked there won't be any crashes from a bad # format string. # sub sprintf { my $fmt = shift; my $out = ''; my ($pre, $dummy, $pat, $rest); while (($pre, $dummy, $pat, $rest) = ($fmt =~ /^((%%|[^%])*)(%[- +#.*hlLqv\d]*[bcdfeEgGinopsuxX])(.*)$/s)) { $out .= $pre; my $pat2 = $pat; # $pat with "*"s expanded my @params = (); # arguments per "*"s while ($pat2 =~ /[*]/) { my $arg = shift; $pat2 =~ s/[*]/$arg/; push @params, $arg; } if (UNIVERSAL::isa($_[0],"GMP::Mpz")) { if ($pat2 !~ /[dioxX]$/) { die "GMP::sprintf: unsupported output format for mpz: $pat2\n"; } $pat2 =~ s/(.)$/Z$1/; $out .= sprintf_internal ($pat2, shift); } elsif (UNIVERSAL::isa($_[0],"GMP::Mpq")) { if ($pat2 !~ /[dioxX]$/) { die "GMP::sprintf: unsupported output format for mpq: $pat2\n"; } $pat2 =~ s/(.)$/Q$1/; $out .= sprintf_internal ($pat2, shift); } elsif (UNIVERSAL::isa($_[0],"GMP::Mpf")) { if ($pat2 !~ /[eEfgG]$/) { die "GMP::sprintf: unsupported output format for mpf: $pat2\n"; } $pat2 =~ s/(.)$/F$1/; $out .= sprintf_internal ($pat2, shift); } elsif ($pat =~ /n$/) { # do it this way so h, l or V type modifiers are respected, and use a # dummy variable to avoid a warning about discarding the value my $dummy = sprintf "%s$pat", $out, $_[0]; shift; } else { $out .= sprintf $pat, @params, shift; } $fmt = $rest; } $out .= $fmt; return $out; } sub printf { if (ref($_[0]) eq 'GLOB') { my $h = Symbol::qualify_to_ref(shift, caller); print $h GMP::sprintf(@_); } else { print STDOUT GMP::sprintf(@_); } } 1; __END__ =head1 NAME GMP - Perl interface to the GNU Multiple Precision Arithmetic Library =head1 SYNOPSIS use GMP; use GMP::Mpz; use GMP::Mpq; use GMP::Mpf; use GMP::Rand; =head1 DESCRIPTION This module provides access to GNU MP arbitrary precision integers, rationals and floating point. No functions are exported from these packages by default, but can be selected in the usual way, or the tag :all for everything. use GMP::Mpz qw(gcd, lcm); # just these functions use GMP::Mpq qw(:all); # everything in mpq =head2 GMP::Mpz This class provides arbitrary precision integers. A new mpz can be constructed with C. The initial value can be an integer, float, string, mpz, mpq or mpf. Floats, mpq and mpf will be automatically truncated to an integer. use GMP::Mpz qw(:all); my $a = mpz(123); my $b = mpz("0xFFFF"); my $c = mpz(1.5); # truncated The following overloaded operators are available, and corresponding assignment forms like C<+=>, =over 4 =item + - * / % EE EE ** & | ^ ! E E= == != E E= E=E abs not sqrt =back C and C<%> round towards zero (as per the C functions in GMP). The following functions are available, behaving the same as the corresponding GMP mpz functions, =over 4 =item bin, cdiv, cdiv_2exp, clrbit, combit, congruent_p, congruent_2exp_p, divexact, divisible_p, divisible_2exp_p, even_p, fac, fdiv, fdiv_2exp, fib, fib2, gcd, gcdext, hamdist, invert, jacobi, kronecker, lcm, lucnum, lucnum2, mod, mpz_export, mpz_import, nextprime, odd_p, perfect_power_p, perfect_square_p, popcount, powm, probab_prime_p, realloc, remove, root, roote, scan0, scan1, setbit, sizeinbase, sqrtrem, tdiv, tdiv_2exp, tstbit =back C, C and C and their C<2exp> variants return a quotient/remainder pair. C returns a pair F[n] and F[n-1], similarly C. C and C accept a variable number of arguments (one or more). C returns a triplet of gcd and two cofactors, for example use GMP::Mpz qw(:all); $a = 7257; $b = 10701; ($g, $x, $y) = gcdext ($a, $b); print "gcd($a,$b) is $g, and $g == $a*$x + $b*$y\n"; C and C are so named to avoid the C keyword. Their parameters are as follows, $z = mpz_import ($order, $size, $endian, $nails, $string); $string = mpz_export ($order, $size, $endian, $nails, $z); The order, size, endian and nails parameters are as per the corresponding C functions. The string input for C is interpreted as byte data and must be a multiple of $size bytes. C conversely returns a string of byte data, which will be a multiple of $size bytes. C returns the inverse, or undef if it doesn't exist. C returns a remainder/multiplicity pair. C returns the nth root, and C returns a root/bool pair, the bool indicating whether the root is exact. C and C return a root/remainder pair. C, C and C expect a variable which they can modify, it doesn't make sense to pass a literal constant. Only the given variable is modified, if other variables are referencing the same mpz object then a new copy is made of it. If the variable isn't an mpz it will be coerced to one. For instance, use GMP::Mpz qw(setbit); setbit (123, 0); # wrong, don't pass a constant $a = mpz(6); $b = $a; setbit ($a, 0); # $a becomes 7, $b stays at 6 C and C return ~0 if no 0 or 1 bit respectively is found. =head2 GMP::Mpq This class provides rationals with arbitrary precision numerators and denominators. A new mpq can be constructed with C. The initial value can be an integer, float, string, mpz, mpq or mpf, or a pair of integers or mpz's. No precision is lost when converting a float or mpf, the exact value is retained. use GMP::Mpq qw(:all); $a = mpq(); # zero $b = mpq(0.5); # gives 1/2 $b = mpq(14); # integer 14 $b = mpq(3,4); # fraction 3/4 $b = mpq("7/12"); # fraction 7/12 $b = mpq("0xFF/0x100"); # fraction 255/256 When a fraction is given, it should be in the canonical form specified in the GMP manual, which is denominator positive, no common factors, and zero always represented as 0/1. If not then C can be called to put it in that form. For example, use GMP::Mpq qw(:all); $q = mpq(21,15); # eek! common factor 3 canonicalize($q); # get rid of it The following overloaded operators are available, and corresponding assignment forms like C<+=>, =over 4 =item + - * / EE EE ** ! E E= == != E E= E=E abs not =back The following functions are available, =over 4 =item den, inv, num =back C calculates 1/q, as per the corresponding GMP function. C and C return an mpz copy of the numerator or denominator respectively. In the future C and C might give lvalues so the original mpq can be modified through them, but this is not done currently. =head2 GMP::Mpf This class provides arbitrary precision floating point numbers. The mantissa is an arbitrary user-selected precision and the exponent is a fixed size (one machine word). A new mpf can be constructed with C. The initial value can be an integer, float, string, mpz, mpq or mpf. The second argument specifies the desired precision in bits, or if omitted then the default precision is used. use GMP::Mpf qw(:all); $a = mpf(); # zero $b = mpf(-7.5); # default precision $c = mpf(1.5, 500); # 500 bits precision $d = mpf("1.0000000000000001"); The following overloaded operators are available, with the corresponding assignment forms like C<+=>, =over 4 =item + - * / EE EE ** ! E E= == != E E= E=E abs not sqrt =back The following functions are available, behaving the same as the corresponding GMP mpf functions, =over 4 =item ceil, floor, get_default_prec, get_prec, mpf_eq, set_default_prec, set_prec, trunc =back C is so named to avoid clashing with the perl C operator. C expects a variable which it can modify, it doesn't make sense to pass a literal constant. Only the given variable is modified, if other variables are referencing the same mpf object then a new copy is made of it. If the variable isn't an mpf it will be coerced to one. Results are the same precision as inputs, or if two mpf's are given to a binary operator then the precision of the first is used. For example, use GMP::Mpf qw(mpf); $a = mpf(2.0, 100); $b = mpf(2.0, 500); $c = $a + $b; # gives 100 bits precision Mpf to string conversion via "" or the usual string contexts uses C<$#> the same as normal float to string conversions, or defaults to C<%.g> if C<$#> is not defined. C<%.g> means all significant digits in the selected precision. =head2 GMP class The following functions are available in the GMP class, =over 4 =item fits_slong_p, get_d, get_d_2exp, get_si, get_str, integer_p, printf, sgn, sprintf, version =back C accepts any integer, string, float, mpz, mpq or mpf operands and returns a float and an integer exponent, ($dbl, $exp) = get_d_2exp (mpf ("3.0")); # dbl is 0.75, exp is 2 C takes an optional second argument which is the base, defaulting to decimal. A negative base means upper case, as per the C functions. For integer, integer string, mpz or mpq operands a string is returned. use GMP qw(:all); use GMP::Mpq qw(:all); print get_str(mpq(-5,8)),"\n"; # -5/8 print get_str(255,16),"\n"; # ff For float, float strings or mpf operands, C accepts an optional third parameter being how many digits to produce, defaulting to 0 which means all digits. (Only as many digits as can be accurately represented by the float precision are ever produced though.) A string/exponent pair is returned, as per the C mpf_get_str function. For example, use GMP qw(:all); use GMP::Mpf qw(:all); ($s, $e) = get_str(111.111111111, 10, 4); printf ".$se$e\n"; # .1111e3 ($s, $e) = get_str(1.625, 10); print "0.$s*10^$e\n"; # 0.1625*10^1 ($s, $e) = get_str(mpf(2)**20, 16); printf ".%s@%x\n", $s, $e; # .1@14 C and C allow formatted output of GMP types. mpz and mpq values can be used with integer conversions (d, o, x, X) and mpf with float conversions (f, e, E, g, G). All the standard perl printf features are available too. For example, use GMP::Mpz qw(mpz); use GMP::Mpf qw(mpf); GMP::printf ("%d %d %s", 123, mpz(2)**128, 'foo'); GMP::printf STDERR "%.40f", mpf(1.234); In perl 5.6.1 it doesn't seem to work to export C, the plain builtin C is reached unless calls are C<&printf()> style. Explicit use of C is suggested. C doesn't suffer this problem. use GMP qw(sprintf); use GMP::Mpq qw(mpq); $s = sprintf "%x", mpq(15,16); C is not exported by default or by tag :all, calling it as C is recommended. It returns the GMP library version string, which is not to be confused with the module version number. The other GMP module functions behave as per the corresponding GMP routines, and accept any integer, string, float, mpz, mpq or mpf. For example, use GMP qw(:all); use GMP::Mpz qw(mpz); $z = mpz(123); print sgn($z); # gives 1 Because each of GMP::Mpz, GMP::Mpq and GMP::Mpf is a sub-class of GMP, C<-E> style calls work too. use GMP qw(:all); use GMP::Mpq qw(mpf); $q = mpq(-5,7); if ($q->integer_p()) # false ... =head2 GMP::Rand This class provides objects holding an algorithm and state for random number generation. C creates a new object, for example, use GMP::Rand qw(randstate); $r = randstate(); $r = randstate('lc_2exp_size', 64); $r = randstate('lc_2exp', 43840821, 1, 32); $r = randstate('mt'); $r = randstate($another_r); With no parameters this corresponds to the C function C, and is a compromise between speed and randomness. 'lc_2exp_size' corresponds to C, 'lc_2exp' corresponds to C, and 'mt' corresponds to C. Or when passed another randstate object, a copy of that object is made. 'lc_2exp_size' can fail if the requested size is bigger than the internal table provides for, in which case undef is returned. The maximum size currently supported is 128. The other forms always succeed. A randstate can be seeded with an integer or mpz, using the C method. /dev/random might be a good source of randomness, or time() or Time::HiRes::time() might be adequate, depending on the application. $r->seed(time())); Random numbers can be generated with the following functions, =over 4 =item mpf_urandomb, mpz_rrandomb, mpz_urandomb, mpz_urandomm, gmp_urandomb_ui, gmp_urandomm_ui =back Each constructs a new mpz or mpf and with a distribution per the corresponding GMP function. For example, use GMP::Rand (:all); $r = randstate(); $a = mpz_urandomb($r,256); # uniform mpz, 256 bits $b = mpz_urandomm($r,mpz(3)**100); # uniform mpz, 0 to 3**100-1 $c = mpz_rrandomb($r,1024); # special mpz, 1024 bits $f = mpf_urandomb($r,128); # uniform mpf, 128 bits, 0<=$f<1 $f = gmp_urandomm_ui($r,56); # uniform int, 0 to 55 =head2 Coercion Arguments to operators and functions are converted as necessary to the appropriate type. For instance C<**> requires an unsigned integer exponent, and an mpq argument will be converted, so long as it's an integer in the appropriate range. use GMP::Mpz (mpz); use GMP::Mpq (mpq); $p = mpz(3) ** mpq(45); # allowed, 45 is an integer It's an error if a conversion to an integer or mpz would cause any truncation. For example, use GMP::Mpz (mpz); $p = mpz(3) + 1.25; # not allowed $p = mpz(3) + mpz(1.25); # allowed, explicit truncation Comparisons, however, accept any combination of operands and are always done exactly. For example, use GMP::Mpz (mpz); print mpz(3) < 3.1; # true Variables used on the left of an assignment operator like C<+=> are subject to coercion too. An integer, float or string will change type when an mpz, mpq or mpf is applied to it. For example, use GMP::Mpz (mpz); $a = 1; $a += mpz(1234); # $a becomes an mpz =head2 Overloading The rule for binary operators in the C mechanism is that if both operands are class objects then the method from the first is used. This determines the result type when mixing GMP classes. For example, use GMP::Mpz (mpz); use GMP::Mpq (mpq); use GMP::Mpf (mpf); $z = mpz(123); $q = mpq(3,2); $f = mpf(1.375) print $q+$f; # gives an mpq print $f+$z; # gives an mpf print $z+$f; # not allowed, would lose precision =head2 Constants A special tag C<:constants> is recognised in the module exports list. It doesn't select any functions, but indicates that perl constants should be GMP objects. This can only be used on one of GMP::Mpz, GMP::Mpq or GMP::Mpf at any one time, since they apply different rules. GMP::Mpz will treat constants as mpz's if they're integers, or ordinary floats if not. For example, use GMP::Mpz qw(:constants); print 764861287634126387126378128,"\n"; # an mpz print 1.25,"\n"; # a float GMP::Mpq is similar, treating integers as mpq's and leaving floats to the normal perl handling. Something like 3/4 is read as two integer mpq's and a division, but that's fine since it gives the intended fraction. use GMP::Mpq qw(:constants); print 3/4,"\n"; # an mpq print 1.25,"\n"; # a float GMP::Mpf will treat all constants as mpf's using the default precision. BEGIN blocks can be used to set that precision while the code is parsed. For example, use GMP::Mpf qw(:constants); BEGIN { GMP::Mpf::set_default_prec(256); } print 1/3; BEGIN { GMP::Mpf::set_default_prec(64); } print 5/7; A similar special tag :noconstants is recognised to turn off the constants feature. For example, use GMP::Mpz qw(:constants); print 438249738748174928193,"\n"; # an mpz use GMP::Mpz qw(:noconstants); print 438249738748174928193,"\n"; # now a float All three 'integer', 'binary' and 'float' constant methods are captured. 'float' is captured even for GMP::Mpz and GMP::Mpq since perl by default treats integer strings as floats if they don't fit a plain integer. =head1 SEE ALSO GMP manual, L, L. =head1 BUGS In perl 5.005_03 on i386 FreeBSD, the overloaded constants sometimes provoke seg faults. Don't know if that's a perl bug or a GMP module bug, though it does seem to go bad before reaching anything in GMP.xs. There's no way to specify an arbitrary base when converting a string to an mpz (or mpq or mpf), only hex or octal with 0x or 0 (for mpz and mpq, but not for mpf). These modules are not reentrant or thread safe, due to the implementation of the XSUBs. Returning a new object from the various functions is convenient, but assignment versions could avoid creating new objects. Perhaps they could be named after the C language functions, eg. mpq_inv($q,$q); It'd be good if C and C gave lvalues so the underlying mpq could be manipulated. C could usefully accept %b for mpz, mpq and mpf, and perhaps %x for mpf too. C returning different style values for integer versus float is a bit unfortunate. With mpz, mpq and mpf objects there's no doubt what it will do, but on a plain scalar its action depends on whether the scalar was promoted to a float at any stage, and then on the GMP module rules about using the integer or float part. =head1 INTERNALS In usual perl object style, an mpz is a reference to an object blessed into class C. The object holds a pointer to the C language C structure. Similarly for mpq, mpf and randstate. A free list of mpz and mpq values is kept to avoid repeated initializing and clearing when objects are created and destroyed. This aims to help speed, but it's not clear whether it's really needed. mpf doesn't use a free list because the precision of new objects can be different each time. No interface to C is provided. It wouldn't be very useful since there's no way to make an operation store its result in a particular object. The plain C is useful though, for truncating to a lower precision, or as a sort of directive that subsequent calculations involving that variable should use a higher precision. The overheads of perl dynamic typing (operator dispatch, operand type checking or coercion) will mean this interface is slower than using C directly. Some assertion checking is available as a compile-time option. =head1 COPYRIGHT Copyright 2001-2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. =cut # Local variables: # perl-indent-level: 2 # fill-column: 76 # End: gcl-2.6.14/gmp4/demos/perl/GMP.xs0000644000175000017500000021566214360276512014726 0ustar cammcamm/* GMP module external subroutines. Copyright 2001-2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. /* Notes: Routines are grouped with the alias feature and a table of function pointers where possible, since each xsub routine ends up with quite a bit of code size. Different combinations of arguments and return values have to be separate though. The "INTERFACE:" feature isn't available in perl 5.005 and so isn't used. "ALIAS:" requires a table lookup with CvXSUBANY(cv).any_i32 (which is "ix") whereas "INTERFACE:" would have CvXSUBANY(cv).any_dptr as the function pointer immediately. Mixed-type swapped-order assignments like "$a = 123; $a += mpz(456);" invoke the plain overloaded "+", not "+=", which makes life easier. mpz_assume etc types are used with the overloaded operators since such operators are always called with a class object as the first argument, we don't need an sv_derived_from() lookup to check. There's assert()s in MPX_ASSUME() for this though. The overload_constant routines reached via overload::constant get 4 arguments in perl 5.6, not the 3 as documented. This is apparently a bug, using "..." lets us ignore the extra one. There's only a few "si" functions in gmp, so usually SvIV values get handled with an mpz_set_si into a temporary and then a full precision mpz routine. This is reasonably efficient. Argument types are checked, with a view to preserving all bits in the operand. Perl is a bit looser in its arithmetic, allowing rounding or truncation to an intended operand type (IV, UV or NV). Bugs: The memory leak detection attempted in GMP::END() doesn't work when mpz's are created as constants because END() is called before they're destroyed. What's the right place to hook such a check? See the bugs section of GMP.pm too. */ /* Comment this out to get assertion checking. */ #define NDEBUG /* Change this to "#define TRACE(x) x" for some diagnostics. */ #define TRACE(x) #include #include #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "patchlevel.h" #include "gmp.h" /* Perl 5.005 doesn't have SvIsUV, only 5.6 and up. Perl 5.8 has SvUOK, but not 5.6, so we don't use that. */ #ifndef SvIsUV #define SvIsUV(sv) 0 #endif #ifndef SvUVX #define SvUVX(sv) (croak("GMP: oops, shouldn't be using SvUVX"), 0) #endif /* Code which doesn't check anything itself, but exists to support other assert()s. */ #ifdef NDEBUG #define assert_support(x) #else #define assert_support(x) x #endif /* LONG_MAX + 1 and ULONG_MAX + 1, as a doubles */ #define LONG_MAX_P1_AS_DOUBLE ((double) ((unsigned long) LONG_MAX + 1)) #define ULONG_MAX_P1_AS_DOUBLE (2.0 * (double) ((unsigned long) ULONG_MAX/2 + 1)) /* Check for perl version "major.minor". Perl 5.004 doesn't have PERL_REVISION and PERL_VERSION, but that's ok, we're only interested in tests above that. */ #if defined (PERL_REVISION) && defined (PERL_VERSION) #define PERL_GE(major,minor) \ (PERL_REVISION > (major) \ || ((major) == PERL_REVISION && PERL_VERSION >= (minor))) #else #define PERL_GE(major,minor) (0) #endif #define PERL_LT(major,minor) (! PERL_GE(major,minor)) /* sv_derived_from etc in 5.005 took "char *" rather than "const char *". Avoid some compiler warnings by using const only where it works. */ #if PERL_LT (5,6) #define classconst #else #define classconst const #endif /* In a MINGW or Cygwin DLL build of gmp, the various gmp functions are given with dllimport directives, which prevents them being used as initializers for constant data. We give function tables as "static_functable const ...", which is normally "static const", but for mingw expands to just "const" making the table an automatic with a run-time initializer. In gcc 3.3.1, the function tables initialized like this end up getting all the __imp__foo values fetched, even though just one or two will be used. This is wasteful, but probably not too bad. */ #if defined (__MINGW32__) || defined (__CYGWIN__) #define static_functable #else #define static_functable static #endif #define GMP_MALLOC_ID 42 static classconst char mpz_class[] = "GMP::Mpz"; static classconst char mpq_class[] = "GMP::Mpq"; static classconst char mpf_class[] = "GMP::Mpf"; static classconst char rand_class[] = "GMP::Rand"; static HV *mpz_class_hv; static HV *mpq_class_hv; static HV *mpf_class_hv; assert_support (static long mpz_count = 0;) assert_support (static long mpq_count = 0;) assert_support (static long mpf_count = 0;) assert_support (static long rand_count = 0;) #define TRACE_ACTIVE() \ assert_support \ (TRACE (printf (" active %ld mpz, %ld mpq, %ld mpf, %ld randstate\n", \ mpz_count, mpq_count, mpf_count, rand_count))) /* Each "struct mpz_elem" etc is an mpz_t with a link field tacked on the end so they can be held on a linked list. */ #define CREATE_MPX(type) \ \ /* must have mpz_t etc first, for sprintf below */ \ struct type##_elem { \ type##_t m; \ struct type##_elem *next; \ }; \ typedef struct type##_elem *type; \ typedef struct type##_elem *type##_assume; \ typedef type##_ptr type##_coerce; \ \ static type type##_freelist = NULL; \ \ static type \ new_##type (void) \ { \ type p; \ TRACE (printf ("new %s\n", type##_class)); \ if (type##_freelist != NULL) \ { \ p = type##_freelist; \ type##_freelist = type##_freelist->next; \ } \ else \ { \ New (GMP_MALLOC_ID, p, 1, struct type##_elem); \ type##_init (p->m); \ } \ TRACE (printf (" p=%p\n", p)); \ assert_support (type##_count++); \ TRACE_ACTIVE (); \ return p; \ } \ CREATE_MPX (mpz) CREATE_MPX (mpq) typedef mpf_ptr mpf; typedef mpf_ptr mpf_assume; typedef mpf_ptr mpf_coerce_st0; typedef mpf_ptr mpf_coerce_def; static mpf new_mpf (unsigned long prec) { mpf p; New (GMP_MALLOC_ID, p, 1, __mpf_struct); mpf_init2 (p, prec); TRACE (printf (" mpf p=%p\n", p)); assert_support (mpf_count++); TRACE_ACTIVE (); return p; } /* tmp_mpf_t records an allocated precision with an mpf_t so changes of precision can be done with just an mpf_set_prec_raw. */ struct tmp_mpf_struct { mpf_t m; unsigned long allocated_prec; }; typedef const struct tmp_mpf_struct *tmp_mpf_srcptr; typedef struct tmp_mpf_struct *tmp_mpf_ptr; typedef struct tmp_mpf_struct tmp_mpf_t[1]; #define tmp_mpf_init(f) \ do { \ mpf_init (f->m); \ f->allocated_prec = mpf_get_prec (f->m); \ } while (0) static void tmp_mpf_grow (tmp_mpf_ptr f, unsigned long prec) { mpf_set_prec_raw (f->m, f->allocated_prec); mpf_set_prec (f->m, prec); f->allocated_prec = mpf_get_prec (f->m); } #define tmp_mpf_shrink(f) tmp_mpf_grow (f, 1L) #define tmp_mpf_set_prec(f,prec) \ do { \ if (prec > f->allocated_prec) \ tmp_mpf_grow (f, prec); \ else \ mpf_set_prec_raw (f->m, prec); \ } while (0) static mpz_t tmp_mpz_0, tmp_mpz_1, tmp_mpz_2; static mpq_t tmp_mpq_0, tmp_mpq_1; static tmp_mpf_t tmp_mpf_0, tmp_mpf_1; /* for GMP::Mpz::export */ #define tmp_mpz_4 tmp_mpz_2 #define FREE_MPX_FREELIST(p,type) \ do { \ TRACE (printf ("free %s\n", type##_class)); \ p->next = type##_freelist; \ type##_freelist = p; \ assert_support (type##_count--); \ TRACE_ACTIVE (); \ assert (type##_count >= 0); \ } while (0) /* this version for comparison, if desired */ #define FREE_MPX_NOFREELIST(p,type) \ do { \ TRACE (printf ("free %s\n", type##_class)); \ type##_clear (p->m); \ Safefree (p); \ assert_support (type##_count--); \ TRACE_ACTIVE (); \ assert (type##_count >= 0); \ } while (0) #define free_mpz(z) FREE_MPX_FREELIST (z, mpz) #define free_mpq(q) FREE_MPX_FREELIST (q, mpq) /* Return a new mortal SV holding the given mpx_ptr pointer. class_hv should be one of mpz_class_hv etc. */ #define MPX_NEWMORTAL(mpx_ptr, class_hv) \ sv_bless (sv_setref_pv (sv_newmortal(), NULL, mpx_ptr), class_hv) /* Aliases for use in typemaps */ typedef char *malloced_string; typedef const char *const_string; typedef const char *const_string_assume; typedef char *string; typedef SV *order_noswap; typedef SV *dummy; typedef SV *SV_copy_0; typedef unsigned long ulong_coerce; typedef __gmp_randstate_struct *randstate; typedef UV gmp_UV; #define SvMPX(s,type) ((type) SvIV((SV*) SvRV(s))) #define SvMPZ(s) SvMPX(s,mpz) #define SvMPQ(s) SvMPX(s,mpq) #define SvMPF(s) SvMPX(s,mpf) #define SvRANDSTATE(s) SvMPX(s,randstate) #define MPX_ASSUME(x,sv,type) \ do { \ assert (sv_derived_from (sv, type##_class)); \ x = SvMPX(sv,type); \ } while (0) #define MPZ_ASSUME(z,sv) MPX_ASSUME(z,sv,mpz) #define MPQ_ASSUME(q,sv) MPX_ASSUME(q,sv,mpq) #define MPF_ASSUME(f,sv) MPX_ASSUME(f,sv,mpf) #define numberof(x) (sizeof (x) / sizeof ((x)[0])) #define SGN(x) ((x)<0 ? -1 : (x) != 0) #define ABS(x) ((x)>=0 ? (x) : -(x)) #define double_integer_p(d) (floor (d) == (d)) #define x_mpq_integer_p(q) \ (mpz_cmp_ui (mpq_denref(q), 1L) == 0) #define assert_table(ix) assert (ix >= 0 && ix < numberof (table)) #define SV_PTR_SWAP(x,y) \ do { SV *__tmp = (x); (x) = (y); (y) = __tmp; } while (0) #define MPF_PTR_SWAP(x,y) \ do { mpf_ptr __tmp = (x); (x) = (y); (y) = __tmp; } while (0) static void class_or_croak (SV *sv, classconst char *cl) { if (! sv_derived_from (sv, cl)) croak("not type %s", cl); } /* These are macros, wrap them in functions. */ static int x_mpz_odd_p (mpz_srcptr z) { return mpz_odd_p (z); } static int x_mpz_even_p (mpz_srcptr z) { return mpz_even_p (z); } static void x_mpq_pow_ui (mpq_ptr r, mpq_srcptr b, unsigned long e) { mpz_pow_ui (mpq_numref(r), mpq_numref(b), e); mpz_pow_ui (mpq_denref(r), mpq_denref(b), e); } static void * my_gmp_alloc (size_t n) { void *p; TRACE (printf ("my_gmp_alloc %u\n", n)); New (GMP_MALLOC_ID, p, n, char); TRACE (printf (" p=%p\n", p)); return p; } static void * my_gmp_realloc (void *p, size_t oldsize, size_t newsize) { TRACE (printf ("my_gmp_realloc %p, %u to %u\n", p, oldsize, newsize)); Renew (p, newsize, char); TRACE (printf (" p=%p\n", p)); return p; } static void my_gmp_free (void *p, size_t n) { TRACE (printf ("my_gmp_free %p %u\n", p, n)); Safefree (p); } #define my_mpx_set_svstr(type) \ static void \ my_##type##_set_svstr (type##_ptr x, SV *sv) \ { \ const char *str; \ STRLEN len; \ TRACE (printf (" my_" #type "_set_svstr\n")); \ assert (SvPOK(sv) || SvPOKp(sv)); \ str = SvPV (sv, len); \ TRACE (printf (" str \"%s\"\n", str)); \ if (type##_set_str (x, str, 0) != 0) \ croak ("%s: invalid string: %s", type##_class, str); \ } my_mpx_set_svstr(mpz) my_mpx_set_svstr(mpq) my_mpx_set_svstr(mpf) /* very slack */ static int x_mpq_cmp_si (mpq_srcptr x, long yn, unsigned long yd) { mpq y; int ret; y = new_mpq (); mpq_set_si (y->m, yn, yd); ret = mpq_cmp (x, y->m); free_mpq (y); return ret; } static int x_mpq_fits_slong_p (mpq_srcptr q) { return x_mpq_cmp_si (q, LONG_MIN, 1L) >= 0 && mpq_cmp_ui (q, LONG_MAX, 1L) <= 0; } static int x_mpz_cmp_q (mpz_ptr x, mpq_srcptr y) { int ret; mpz_set_ui (mpq_denref(tmp_mpq_0), 1L); mpz_swap (mpq_numref(tmp_mpq_0), x); ret = mpq_cmp (tmp_mpq_0, y); mpz_swap (mpq_numref(tmp_mpq_0), x); return ret; } static int x_mpz_cmp_f (mpz_srcptr x, mpf_srcptr y) { tmp_mpf_set_prec (tmp_mpf_0, mpz_sizeinbase (x, 2)); mpf_set_z (tmp_mpf_0->m, x); return mpf_cmp (tmp_mpf_0->m, y); } #define USE_UNKNOWN 0 #define USE_IVX 1 #define USE_UVX 2 #define USE_NVX 3 #define USE_PVX 4 #define USE_MPZ 5 #define USE_MPQ 6 #define USE_MPF 7 /* mg_get is called every time we get a value, even if the private flags are still set from a previous such call. This is the same as as SvIV and friends do. When POK, we use the PV, even if there's an IV or NV available. This is because it's hard to be sure there wasn't any rounding in establishing the IV and/or NV. Cases of overflow, where the PV should definitely be used, are easy enough to spot, but rounding is hard. So although IV or NV would be more efficient, we must use the PV to be sure of getting all the data. Applications should convert once to mpz, mpq or mpf when using a value repeatedly. Zany dual-type scalars like $! where the IV is an error code and the PV is an error description string won't work with this preference for PV, but that's too bad. Such scalars should be rare, and unlikely to be used in bignum calculations. When IOK and NOK are both set, we would prefer to use the IV since it can be converted more efficiently, and because on a 64-bit system the NV may have less bits than the IV. The following rules are applied, - If the NV is not an integer, then we must use that NV, since clearly the IV was merely established by rounding and is not the full value. - In perl prior to 5.8, an NV too big for an IV leaves an overflow value 0xFFFFFFFF. If the NV is too big to fit an IV then clearly it's the NV which is the true value and must be used. - In perl 5.8 and up, such an overflow doesn't set IOK, so that test is unnecessary. However when coming from get-magic, IOKp _is_ set, and we must check for overflow the same as in older perl. FIXME: We'd like to call mg_get just once, but unfortunately sv_derived_from() will call it for each of our checks. We could do a string compare like sv_isa ourselves, but that only tests the exact class, it doesn't recognise subclassing. There doesn't seem to be a public interface to the subclassing tests (in the internal isa_lookup() function). */ int use_sv (SV *sv) { double d; if (SvGMAGICAL(sv)) { mg_get(sv); if (SvPOKp(sv)) return USE_PVX; if (SvIOKp(sv)) { if (SvIsUV(sv)) { if (SvNOKp(sv)) goto u_or_n; return USE_UVX; } else { if (SvNOKp(sv)) goto i_or_n; return USE_IVX; } } if (SvNOKp(sv)) return USE_NVX; goto rok_or_unknown; } if (SvPOK(sv)) return USE_PVX; if (SvIOK(sv)) { if (SvIsUV(sv)) { if (SvNOK(sv)) { if (PERL_LT (5, 8)) { u_or_n: d = SvNVX(sv); if (d >= ULONG_MAX_P1_AS_DOUBLE || d < 0.0) return USE_NVX; } d = SvNVX(sv); if (d != floor (d)) return USE_NVX; } return USE_UVX; } else { if (SvNOK(sv)) { if (PERL_LT (5, 8)) { i_or_n: d = SvNVX(sv); if (d >= LONG_MAX_P1_AS_DOUBLE || d < (double) LONG_MIN) return USE_NVX; } d = SvNVX(sv); if (d != floor (d)) return USE_NVX; } return USE_IVX; } } if (SvNOK(sv)) return USE_NVX; rok_or_unknown: if (SvROK(sv)) { if (sv_derived_from (sv, mpz_class)) return USE_MPZ; if (sv_derived_from (sv, mpq_class)) return USE_MPQ; if (sv_derived_from (sv, mpf_class)) return USE_MPF; } return USE_UNKNOWN; } /* Coerce sv to an mpz. Use tmp to hold the converted value if sv isn't already an mpz (or an mpq of which the numerator can be used). Return the chosen mpz (tmp or the contents of sv). */ static mpz_ptr coerce_mpz_using (mpz_ptr tmp, SV *sv, int use) { switch (use) { case USE_IVX: mpz_set_si (tmp, SvIVX(sv)); return tmp; case USE_UVX: mpz_set_ui (tmp, SvUVX(sv)); return tmp; case USE_NVX: { double d; d = SvNVX(sv); if (! double_integer_p (d)) croak ("cannot coerce non-integer double to mpz"); mpz_set_d (tmp, d); return tmp; } case USE_PVX: my_mpz_set_svstr (tmp, sv); return tmp; case USE_MPZ: return SvMPZ(sv)->m; case USE_MPQ: { mpq q = SvMPQ(sv); if (! x_mpq_integer_p (q->m)) croak ("cannot coerce non-integer mpq to mpz"); return mpq_numref(q->m); } case USE_MPF: { mpf f = SvMPF(sv); if (! mpf_integer_p (f)) croak ("cannot coerce non-integer mpf to mpz"); mpz_set_f (tmp, f); return tmp; } default: croak ("cannot coerce to mpz"); } } static mpz_ptr coerce_mpz (mpz_ptr tmp, SV *sv) { return coerce_mpz_using (tmp, sv, use_sv (sv)); } /* Coerce sv to an mpq. If sv is an mpq then just return that, otherwise use tmp to hold the converted value and return that. */ static mpq_ptr coerce_mpq_using (mpq_ptr tmp, SV *sv, int use) { TRACE (printf ("coerce_mpq_using %p %d\n", tmp, use)); switch (use) { case USE_IVX: mpq_set_si (tmp, SvIVX(sv), 1L); return tmp; case USE_UVX: mpq_set_ui (tmp, SvUVX(sv), 1L); return tmp; case USE_NVX: mpq_set_d (tmp, SvNVX(sv)); return tmp; case USE_PVX: my_mpq_set_svstr (tmp, sv); return tmp; case USE_MPZ: mpq_set_z (tmp, SvMPZ(sv)->m); return tmp; case USE_MPQ: return SvMPQ(sv)->m; case USE_MPF: mpq_set_f (tmp, SvMPF(sv)); return tmp; default: croak ("cannot coerce to mpq"); } } static mpq_ptr coerce_mpq (mpq_ptr tmp, SV *sv) { return coerce_mpq_using (tmp, sv, use_sv (sv)); } static void my_mpf_set_sv_using (mpf_ptr f, SV *sv, int use) { switch (use) { case USE_IVX: mpf_set_si (f, SvIVX(sv)); break; case USE_UVX: mpf_set_ui (f, SvUVX(sv)); break; case USE_NVX: mpf_set_d (f, SvNVX(sv)); break; case USE_PVX: my_mpf_set_svstr (f, sv); break; case USE_MPZ: mpf_set_z (f, SvMPZ(sv)->m); break; case USE_MPQ: mpf_set_q (f, SvMPQ(sv)->m); break; case USE_MPF: mpf_set (f, SvMPF(sv)); break; default: croak ("cannot coerce to mpf"); } } /* Coerce sv to an mpf. If sv is an mpf then just return that, otherwise use tmp to hold the converted value (with prec precision). */ static mpf_ptr coerce_mpf_using (tmp_mpf_ptr tmp, SV *sv, unsigned long prec, int use) { if (use == USE_MPF) return SvMPF(sv); tmp_mpf_set_prec (tmp, prec); my_mpf_set_sv_using (tmp->m, sv, use); return tmp->m; } static mpf_ptr coerce_mpf (tmp_mpf_ptr tmp, SV *sv, unsigned long prec) { return coerce_mpf_using (tmp, sv, prec, use_sv (sv)); } /* Coerce xv to an mpf and store the pointer in x, ditto for yv to x. If one of xv or yv is an mpf then use it for the precision, otherwise use the default precision. */ unsigned long coerce_mpf_pair (mpf *xp, SV *xv, mpf *yp, SV *yv) { int x_use = use_sv (xv); int y_use = use_sv (yv); unsigned long prec; mpf x, y; if (x_use == USE_MPF) { x = SvMPF(xv); prec = mpf_get_prec (x); y = coerce_mpf_using (tmp_mpf_0, yv, prec, y_use); } else { y = coerce_mpf_using (tmp_mpf_0, yv, mpf_get_default_prec(), y_use); prec = mpf_get_prec (y); x = coerce_mpf_using (tmp_mpf_1, xv, prec, x_use); } *xp = x; *yp = y; return prec; } /* Note that SvUV is not used, since it merely treats the signed IV as if it was unsigned. We get an IV and check its sign. */ static unsigned long coerce_ulong (SV *sv) { long n; switch (use_sv (sv)) { case USE_IVX: n = SvIVX(sv); negative_check: if (n < 0) goto range_error; return n; case USE_UVX: return SvUVX(sv); case USE_NVX: { double d; d = SvNVX(sv); if (! double_integer_p (d)) goto integer_error; n = SvIV(sv); } goto negative_check; case USE_PVX: /* FIXME: Check the string is an integer. */ n = SvIV(sv); goto negative_check; case USE_MPZ: { mpz z = SvMPZ(sv); if (! mpz_fits_ulong_p (z->m)) goto range_error; return mpz_get_ui (z->m); } case USE_MPQ: { mpq q = SvMPQ(sv); if (! x_mpq_integer_p (q->m)) goto integer_error; if (! mpz_fits_ulong_p (mpq_numref (q->m))) goto range_error; return mpz_get_ui (mpq_numref (q->m)); } case USE_MPF: { mpf f = SvMPF(sv); if (! mpf_integer_p (f)) goto integer_error; if (! mpf_fits_ulong_p (f)) goto range_error; return mpf_get_ui (f); } default: croak ("cannot coerce to ulong"); } integer_error: croak ("not an integer"); range_error: croak ("out of range for ulong"); } static long coerce_long (SV *sv) { switch (use_sv (sv)) { case USE_IVX: return SvIVX(sv); case USE_UVX: { UV u = SvUVX(sv); if (u > (UV) LONG_MAX) goto range_error; return u; } case USE_NVX: { double d = SvNVX(sv); if (! double_integer_p (d)) goto integer_error; return SvIV(sv); } case USE_PVX: /* FIXME: Check the string is an integer. */ return SvIV(sv); case USE_MPZ: { mpz z = SvMPZ(sv); if (! mpz_fits_slong_p (z->m)) goto range_error; return mpz_get_si (z->m); } case USE_MPQ: { mpq q = SvMPQ(sv); if (! x_mpq_integer_p (q->m)) goto integer_error; if (! mpz_fits_slong_p (mpq_numref (q->m))) goto range_error; return mpz_get_si (mpq_numref (q->m)); } case USE_MPF: { mpf f = SvMPF(sv); if (! mpf_integer_p (f)) goto integer_error; if (! mpf_fits_slong_p (f)) goto range_error; return mpf_get_si (f); } default: croak ("cannot coerce to long"); } integer_error: croak ("not an integer"); range_error: croak ("out of range for ulong"); } /* ------------------------------------------------------------------------- */ MODULE = GMP PACKAGE = GMP BOOT: TRACE (printf ("GMP boot\n")); mp_set_memory_functions (my_gmp_alloc, my_gmp_realloc, my_gmp_free); mpz_init (tmp_mpz_0); mpz_init (tmp_mpz_1); mpz_init (tmp_mpz_2); mpq_init (tmp_mpq_0); mpq_init (tmp_mpq_1); tmp_mpf_init (tmp_mpf_0); tmp_mpf_init (tmp_mpf_1); mpz_class_hv = gv_stashpv (mpz_class, 1); mpq_class_hv = gv_stashpv (mpq_class, 1); mpf_class_hv = gv_stashpv (mpf_class, 1); void END() CODE: TRACE (printf ("GMP end\n")); TRACE_ACTIVE (); /* These are not always true, see Bugs at the top of the file. */ /* assert (mpz_count == 0); */ /* assert (mpq_count == 0); */ /* assert (mpf_count == 0); */ /* assert (rand_count == 0); */ const_string version() CODE: RETVAL = gmp_version; OUTPUT: RETVAL bool fits_slong_p (sv) SV *sv CODE: switch (use_sv (sv)) { case USE_IVX: RETVAL = 1; break; case USE_UVX: { UV u = SvUVX(sv); RETVAL = (u <= LONG_MAX); } break; case USE_NVX: { double d = SvNVX(sv); RETVAL = (d >= (double) LONG_MIN && d < LONG_MAX_P1_AS_DOUBLE); } break; case USE_PVX: { STRLEN len; const char *str = SvPV (sv, len); if (mpq_set_str (tmp_mpq_0, str, 0) == 0) RETVAL = x_mpq_fits_slong_p (tmp_mpq_0); else { /* enough precision for a long */ tmp_mpf_set_prec (tmp_mpf_0, 2*mp_bits_per_limb); if (mpf_set_str (tmp_mpf_0->m, str, 10) != 0) croak ("GMP::fits_slong_p invalid string format"); RETVAL = mpf_fits_slong_p (tmp_mpf_0->m); } } break; case USE_MPZ: RETVAL = mpz_fits_slong_p (SvMPZ(sv)->m); break; case USE_MPQ: RETVAL = x_mpq_fits_slong_p (SvMPQ(sv)->m); break; case USE_MPF: RETVAL = mpf_fits_slong_p (SvMPF(sv)); break; default: croak ("GMP::fits_slong_p invalid argument"); } OUTPUT: RETVAL double get_d (sv) SV *sv CODE: switch (use_sv (sv)) { case USE_IVX: RETVAL = (double) SvIVX(sv); break; case USE_UVX: RETVAL = (double) SvUVX(sv); break; case USE_NVX: RETVAL = SvNVX(sv); break; case USE_PVX: { STRLEN len; RETVAL = atof(SvPV(sv, len)); } break; case USE_MPZ: RETVAL = mpz_get_d (SvMPZ(sv)->m); break; case USE_MPQ: RETVAL = mpq_get_d (SvMPQ(sv)->m); break; case USE_MPF: RETVAL = mpf_get_d (SvMPF(sv)); break; default: croak ("GMP::get_d invalid argument"); } OUTPUT: RETVAL void get_d_2exp (sv) SV *sv PREINIT: double ret; long exp; PPCODE: switch (use_sv (sv)) { case USE_IVX: ret = (double) SvIVX(sv); goto use_frexp; case USE_UVX: ret = (double) SvUVX(sv); goto use_frexp; case USE_NVX: { int i_exp; ret = SvNVX(sv); use_frexp: ret = frexp (ret, &i_exp); exp = i_exp; } break; case USE_PVX: /* put strings through mpf to give full exp range */ tmp_mpf_set_prec (tmp_mpf_0, DBL_MANT_DIG); my_mpf_set_svstr (tmp_mpf_0->m, sv); ret = mpf_get_d_2exp (&exp, tmp_mpf_0->m); break; case USE_MPZ: ret = mpz_get_d_2exp (&exp, SvMPZ(sv)->m); break; case USE_MPQ: tmp_mpf_set_prec (tmp_mpf_0, DBL_MANT_DIG); mpf_set_q (tmp_mpf_0->m, SvMPQ(sv)->m); ret = mpf_get_d_2exp (&exp, tmp_mpf_0->m); break; case USE_MPF: ret = mpf_get_d_2exp (&exp, SvMPF(sv)); break; default: croak ("GMP::get_d_2exp invalid argument"); } PUSHs (sv_2mortal (newSVnv (ret))); PUSHs (sv_2mortal (newSViv (exp))); long get_si (sv) SV *sv CODE: switch (use_sv (sv)) { case USE_IVX: RETVAL = SvIVX(sv); break; case USE_UVX: RETVAL = SvUVX(sv); break; case USE_NVX: RETVAL = (long) SvNVX(sv); break; case USE_PVX: RETVAL = SvIV(sv); break; case USE_MPZ: RETVAL = mpz_get_si (SvMPZ(sv)->m); break; case USE_MPQ: mpz_set_q (tmp_mpz_0, SvMPQ(sv)->m); RETVAL = mpz_get_si (tmp_mpz_0); break; case USE_MPF: RETVAL = mpf_get_si (SvMPF(sv)); break; default: croak ("GMP::get_si invalid argument"); } OUTPUT: RETVAL void get_str (sv, ...) SV *sv PREINIT: char *str; mp_exp_t exp; mpz_ptr z; mpq_ptr q; mpf f; int base; int ndigits; PPCODE: TRACE (printf ("GMP::get_str\n")); if (items >= 2) base = coerce_long (ST(1)); else base = 10; TRACE (printf (" base=%d\n", base)); if (items >= 3) ndigits = coerce_long (ST(2)); else ndigits = 10; TRACE (printf (" ndigits=%d\n", ndigits)); EXTEND (SP, 2); switch (use_sv (sv)) { case USE_IVX: mpz_set_si (tmp_mpz_0, SvIVX(sv)); get_tmp_mpz_0: z = tmp_mpz_0; goto get_mpz; case USE_UVX: mpz_set_ui (tmp_mpz_0, SvUVX(sv)); goto get_tmp_mpz_0; case USE_NVX: /* only digits in the original double, not in the coerced form */ if (ndigits == 0) ndigits = DBL_DIG; mpf_set_d (tmp_mpf_0->m, SvNVX(sv)); f = tmp_mpf_0->m; goto get_mpf; case USE_PVX: { /* get_str on a string is not much more than a base conversion */ STRLEN len; str = SvPV (sv, len); if (mpz_set_str (tmp_mpz_0, str, 0) == 0) { z = tmp_mpz_0; goto get_mpz; } else if (mpq_set_str (tmp_mpq_0, str, 0) == 0) { q = tmp_mpq_0; goto get_mpq; } else { /* FIXME: Would like perhaps a precision equivalent to the number of significant digits of the string, in its given base. */ tmp_mpf_set_prec (tmp_mpf_0, strlen(str)); if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0) { f = tmp_mpf_0->m; goto get_mpf; } else croak ("GMP::get_str invalid string format"); } } break; case USE_MPZ: z = SvMPZ(sv)->m; get_mpz: str = mpz_get_str (NULL, base, z); push_str: PUSHs (sv_2mortal (newSVpv (str, 0))); break; case USE_MPQ: q = SvMPQ(sv)->m; get_mpq: str = mpq_get_str (NULL, base, q); goto push_str; case USE_MPF: f = SvMPF(sv); get_mpf: str = mpf_get_str (NULL, &exp, base, 0, f); PUSHs (sv_2mortal (newSVpv (str, 0))); PUSHs (sv_2mortal (newSViv (exp))); break; default: croak ("GMP::get_str invalid argument"); } bool integer_p (sv) SV *sv CODE: switch (use_sv (sv)) { case USE_IVX: case USE_UVX: RETVAL = 1; break; case USE_NVX: RETVAL = double_integer_p (SvNVX(sv)); break; case USE_PVX: { /* FIXME: Maybe this should be done by parsing the string, not by an actual conversion. */ STRLEN len; const char *str = SvPV (sv, len); if (mpq_set_str (tmp_mpq_0, str, 0) == 0) RETVAL = x_mpq_integer_p (tmp_mpq_0); else { /* enough for all digits of the string */ tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64); if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0) RETVAL = mpf_integer_p (tmp_mpf_0->m); else croak ("GMP::integer_p invalid string format"); } } break; case USE_MPZ: RETVAL = 1; break; case USE_MPQ: RETVAL = x_mpq_integer_p (SvMPQ(sv)->m); break; case USE_MPF: RETVAL = mpf_integer_p (SvMPF(sv)); break; default: croak ("GMP::integer_p invalid argument"); } OUTPUT: RETVAL int sgn (sv) SV *sv CODE: switch (use_sv (sv)) { case USE_IVX: RETVAL = SGN (SvIVX(sv)); break; case USE_UVX: RETVAL = (SvUVX(sv) > 0); break; case USE_NVX: RETVAL = SGN (SvNVX(sv)); break; case USE_PVX: { /* FIXME: Maybe this should be done by parsing the string, not by an actual conversion. */ STRLEN len; const char *str = SvPV (sv, len); if (mpq_set_str (tmp_mpq_0, str, 0) == 0) RETVAL = mpq_sgn (tmp_mpq_0); else { /* enough for all digits of the string */ tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64); if (mpf_set_str (tmp_mpf_0->m, str, 10) == 0) RETVAL = mpf_sgn (tmp_mpf_0->m); else croak ("GMP::sgn invalid string format"); } } break; case USE_MPZ: RETVAL = mpz_sgn (SvMPZ(sv)->m); break; case USE_MPQ: RETVAL = mpq_sgn (SvMPQ(sv)->m); break; case USE_MPF: RETVAL = mpf_sgn (SvMPF(sv)); break; default: croak ("GMP::sgn invalid argument"); } OUTPUT: RETVAL # currently undocumented void shrink () CODE: #define x_mpz_shrink(z) \ mpz_set_ui (z, 0L); _mpz_realloc (z, 1) #define x_mpq_shrink(q) \ x_mpz_shrink (mpq_numref(q)); x_mpz_shrink (mpq_denref(q)) x_mpz_shrink (tmp_mpz_0); x_mpz_shrink (tmp_mpz_1); x_mpz_shrink (tmp_mpz_2); x_mpq_shrink (tmp_mpq_0); x_mpq_shrink (tmp_mpq_1); tmp_mpf_shrink (tmp_mpf_0); tmp_mpf_shrink (tmp_mpf_1); malloced_string sprintf_internal (fmt, sv) const_string fmt SV *sv CODE: assert (strlen (fmt) >= 3); assert (SvROK(sv)); assert ((sv_derived_from (sv, mpz_class) && fmt[strlen(fmt)-2] == 'Z') || (sv_derived_from (sv, mpq_class) && fmt[strlen(fmt)-2] == 'Q') || (sv_derived_from (sv, mpf_class) && fmt[strlen(fmt)-2] == 'F')); TRACE (printf ("GMP::sprintf_internal\n"); printf (" fmt |%s|\n", fmt); printf (" sv |%p|\n", SvMPZ(sv))); /* cheat a bit here, SvMPZ works for mpq and mpf too */ gmp_asprintf (&RETVAL, fmt, SvMPZ(sv)); TRACE (printf (" result |%s|\n", RETVAL)); OUTPUT: RETVAL #------------------------------------------------------------------------------ MODULE = GMP PACKAGE = GMP::Mpz mpz mpz (...) ALIAS: GMP::Mpz::new = 1 PREINIT: SV *sv; CODE: TRACE (printf ("%s new, ix=%ld, items=%d\n", mpz_class, ix, (int) items)); RETVAL = new_mpz(); switch (items) { case 0: mpz_set_ui (RETVAL->m, 0L); break; case 1: sv = ST(0); TRACE (printf (" use %d\n", use_sv (sv))); switch (use_sv (sv)) { case USE_IVX: mpz_set_si (RETVAL->m, SvIVX(sv)); break; case USE_UVX: mpz_set_ui (RETVAL->m, SvUVX(sv)); break; case USE_NVX: mpz_set_d (RETVAL->m, SvNVX(sv)); break; case USE_PVX: my_mpz_set_svstr (RETVAL->m, sv); break; case USE_MPZ: mpz_set (RETVAL->m, SvMPZ(sv)->m); break; case USE_MPQ: mpz_set_q (RETVAL->m, SvMPQ(sv)->m); break; case USE_MPF: mpz_set_f (RETVAL->m, SvMPF(sv)); break; default: goto invalid; } break; default: invalid: croak ("%s new: invalid arguments", mpz_class); } OUTPUT: RETVAL void overload_constant (str, pv, d1, ...) const_string_assume str SV *pv dummy d1 PREINIT: mpz z; PPCODE: TRACE (printf ("%s constant: %s\n", mpz_class, str)); z = new_mpz(); if (mpz_set_str (z->m, str, 0) == 0) { PUSHs (MPX_NEWMORTAL (z, mpz_class_hv)); } else { free_mpz (z); PUSHs(pv); } mpz overload_copy (z, d1, d2) mpz_assume z dummy d1 dummy d2 CODE: RETVAL = new_mpz(); mpz_set (RETVAL->m, z->m); OUTPUT: RETVAL void DESTROY (z) mpz_assume z CODE: TRACE (printf ("%s DESTROY %p\n", mpz_class, z)); free_mpz (z); malloced_string overload_string (z, d1, d2) mpz_assume z dummy d1 dummy d2 CODE: TRACE (printf ("%s overload_string %p\n", mpz_class, z)); RETVAL = mpz_get_str (NULL, 10, z->m); OUTPUT: RETVAL mpz overload_add (xv, yv, order) SV *xv SV *yv SV *order ALIAS: GMP::Mpz::overload_sub = 1 GMP::Mpz::overload_mul = 2 GMP::Mpz::overload_div = 3 GMP::Mpz::overload_rem = 4 GMP::Mpz::overload_and = 5 GMP::Mpz::overload_ior = 6 GMP::Mpz::overload_xor = 7 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr); } table[] = { { mpz_add }, /* 0 */ { mpz_sub }, /* 1 */ { mpz_mul }, /* 2 */ { mpz_tdiv_q }, /* 3 */ { mpz_tdiv_r }, /* 4 */ { mpz_and }, /* 5 */ { mpz_ior }, /* 6 */ { mpz_xor }, /* 7 */ }; CODE: assert_table (ix); if (order == &PL_sv_yes) SV_PTR_SWAP (xv, yv); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, coerce_mpz (tmp_mpz_0, xv), coerce_mpz (tmp_mpz_1, yv)); OUTPUT: RETVAL void overload_addeq (x, y, o) mpz_assume x mpz_coerce y order_noswap o ALIAS: GMP::Mpz::overload_subeq = 1 GMP::Mpz::overload_muleq = 2 GMP::Mpz::overload_diveq = 3 GMP::Mpz::overload_remeq = 4 GMP::Mpz::overload_andeq = 5 GMP::Mpz::overload_ioreq = 6 GMP::Mpz::overload_xoreq = 7 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr); } table[] = { { mpz_add }, /* 0 */ { mpz_sub }, /* 1 */ { mpz_mul }, /* 2 */ { mpz_tdiv_q }, /* 3 */ { mpz_tdiv_r }, /* 4 */ { mpz_and }, /* 5 */ { mpz_ior }, /* 6 */ { mpz_xor }, /* 7 */ }; PPCODE: assert_table (ix); (*table[ix].op) (x->m, x->m, y); XPUSHs (ST(0)); mpz overload_lshift (zv, nv, order) SV *zv SV *nv SV *order ALIAS: GMP::Mpz::overload_rshift = 1 GMP::Mpz::overload_pow = 2 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, unsigned long); } table[] = { { mpz_mul_2exp }, /* 0 */ { mpz_div_2exp }, /* 1 */ { mpz_pow_ui }, /* 2 */ }; CODE: assert_table (ix); if (order == &PL_sv_yes) SV_PTR_SWAP (zv, nv); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, coerce_mpz (RETVAL->m, zv), coerce_ulong (nv)); OUTPUT: RETVAL void overload_lshifteq (z, n, o) mpz_assume z ulong_coerce n order_noswap o ALIAS: GMP::Mpz::overload_rshifteq = 1 GMP::Mpz::overload_poweq = 2 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, unsigned long); } table[] = { { mpz_mul_2exp }, /* 0 */ { mpz_div_2exp }, /* 1 */ { mpz_pow_ui }, /* 2 */ }; PPCODE: assert_table (ix); (*table[ix].op) (z->m, z->m, n); XPUSHs(ST(0)); mpz overload_abs (z, d1, d2) mpz_assume z dummy d1 dummy d2 ALIAS: GMP::Mpz::overload_neg = 1 GMP::Mpz::overload_com = 2 GMP::Mpz::overload_sqrt = 3 PREINIT: static_functable const struct { void (*op) (mpz_ptr w, mpz_srcptr x); } table[] = { { mpz_abs }, /* 0 */ { mpz_neg }, /* 1 */ { mpz_com }, /* 2 */ { mpz_sqrt }, /* 3 */ }; CODE: assert_table (ix); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, z->m); OUTPUT: RETVAL void overload_inc (z, d1, d2) mpz_assume z dummy d1 dummy d2 ALIAS: GMP::Mpz::overload_dec = 1 PREINIT: static_functable const struct { void (*op) (mpz_ptr w, mpz_srcptr x, unsigned long y); } table[] = { { mpz_add_ui }, /* 0 */ { mpz_sub_ui }, /* 1 */ }; CODE: assert_table (ix); (*table[ix].op) (z->m, z->m, 1L); int overload_spaceship (xv, yv, order) SV *xv SV *yv SV *order PREINIT: mpz x; CODE: TRACE (printf ("%s overload_spaceship\n", mpz_class)); MPZ_ASSUME (x, xv); switch (use_sv (yv)) { case USE_IVX: RETVAL = mpz_cmp_si (x->m, SvIVX(yv)); break; case USE_UVX: RETVAL = mpz_cmp_ui (x->m, SvUVX(yv)); break; case USE_PVX: RETVAL = mpz_cmp (x->m, coerce_mpz (tmp_mpz_0, yv)); break; case USE_NVX: RETVAL = mpz_cmp_d (x->m, SvNVX(yv)); break; case USE_MPZ: RETVAL = mpz_cmp (x->m, SvMPZ(yv)->m); break; case USE_MPQ: RETVAL = x_mpz_cmp_q (x->m, SvMPQ(yv)->m); break; case USE_MPF: RETVAL = x_mpz_cmp_f (x->m, SvMPF(yv)); break; default: croak ("%s <=>: invalid operand", mpz_class); } RETVAL = SGN (RETVAL); if (order == &PL_sv_yes) RETVAL = -RETVAL; OUTPUT: RETVAL bool overload_bool (z, d1, d2) mpz_assume z dummy d1 dummy d2 ALIAS: GMP::Mpz::overload_not = 1 CODE: RETVAL = (mpz_sgn (z->m) != 0) ^ ix; OUTPUT: RETVAL mpz bin (n, k) mpz_coerce n ulong_coerce k ALIAS: GMP::Mpz::root = 1 PREINIT: /* mpz_root returns an int, hence the cast */ static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, unsigned long); } table[] = { { mpz_bin_ui }, /* 0 */ { (void (*)(mpz_ptr, mpz_srcptr, unsigned long)) mpz_root }, /* 1 */ }; CODE: assert_table (ix); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, n, k); OUTPUT: RETVAL void cdiv (a, d) mpz_coerce a mpz_coerce d ALIAS: GMP::Mpz::fdiv = 1 GMP::Mpz::tdiv = 2 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr); } table[] = { { mpz_cdiv_qr }, /* 0 */ { mpz_fdiv_qr }, /* 1 */ { mpz_tdiv_qr }, /* 2 */ }; mpz q, r; PPCODE: assert_table (ix); q = new_mpz(); r = new_mpz(); (*table[ix].op) (q->m, r->m, a, d); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (q, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (r, mpz_class_hv)); void cdiv_2exp (a, d) mpz_coerce a ulong_coerce d ALIAS: GMP::Mpz::fdiv_2exp = 1 GMP::Mpz::tdiv_2exp = 2 PREINIT: static_functable const struct { void (*q) (mpz_ptr, mpz_srcptr, unsigned long); void (*r) (mpz_ptr, mpz_srcptr, unsigned long); } table[] = { { mpz_cdiv_q_2exp, mpz_cdiv_r_2exp }, /* 0 */ { mpz_fdiv_q_2exp, mpz_fdiv_r_2exp }, /* 1 */ { mpz_tdiv_q_2exp, mpz_tdiv_r_2exp }, /* 2 */ }; mpz q, r; PPCODE: assert_table (ix); q = new_mpz(); r = new_mpz(); (*table[ix].q) (q->m, a, d); (*table[ix].r) (r->m, a, d); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (q, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (r, mpz_class_hv)); bool congruent_p (a, c, d) mpz_coerce a mpz_coerce c mpz_coerce d PREINIT: CODE: RETVAL = mpz_congruent_p (a, c, d); OUTPUT: RETVAL bool congruent_2exp_p (a, c, d) mpz_coerce a mpz_coerce c ulong_coerce d PREINIT: CODE: RETVAL = mpz_congruent_2exp_p (a, c, d); OUTPUT: RETVAL mpz divexact (a, d) mpz_coerce a mpz_coerce d ALIAS: GMP::Mpz::mod = 1 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr); } table[] = { { mpz_divexact }, /* 0 */ { mpz_mod }, /* 1 */ }; CODE: assert_table (ix); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, a, d); OUTPUT: RETVAL bool divisible_p (a, d) mpz_coerce a mpz_coerce d CODE: RETVAL = mpz_divisible_p (a, d); OUTPUT: RETVAL bool divisible_2exp_p (a, d) mpz_coerce a ulong_coerce d CODE: RETVAL = mpz_divisible_2exp_p (a, d); OUTPUT: RETVAL bool even_p (z) mpz_coerce z ALIAS: GMP::Mpz::odd_p = 1 GMP::Mpz::perfect_square_p = 2 GMP::Mpz::perfect_power_p = 3 PREINIT: static_functable const struct { int (*op) (mpz_srcptr z); } table[] = { { x_mpz_even_p }, /* 0 */ { x_mpz_odd_p }, /* 1 */ { mpz_perfect_square_p }, /* 2 */ { mpz_perfect_power_p }, /* 3 */ }; CODE: assert_table (ix); RETVAL = (*table[ix].op) (z); OUTPUT: RETVAL mpz fac (n) ulong_coerce n ALIAS: GMP::Mpz::fib = 1 GMP::Mpz::lucnum = 2 PREINIT: static_functable const struct { void (*op) (mpz_ptr r, unsigned long n); } table[] = { { mpz_fac_ui }, /* 0 */ { mpz_fib_ui }, /* 1 */ { mpz_lucnum_ui }, /* 2 */ }; CODE: assert_table (ix); RETVAL = new_mpz(); (*table[ix].op) (RETVAL->m, n); OUTPUT: RETVAL void fib2 (n) ulong_coerce n ALIAS: GMP::Mpz::lucnum2 = 1 PREINIT: static_functable const struct { void (*op) (mpz_ptr r, mpz_ptr r2, unsigned long n); } table[] = { { mpz_fib2_ui }, /* 0 */ { mpz_lucnum2_ui }, /* 1 */ }; mpz r, r2; PPCODE: assert_table (ix); r = new_mpz(); r2 = new_mpz(); (*table[ix].op) (r->m, r2->m, n); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (r, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (r2, mpz_class_hv)); mpz gcd (x, ...) mpz_coerce x ALIAS: GMP::Mpz::lcm = 1 PREINIT: static_functable const struct { void (*op) (mpz_ptr w, mpz_srcptr x, mpz_srcptr y); void (*op_ui) (mpz_ptr w, mpz_srcptr x, unsigned long y); } table[] = { /* cast to ignore ulong return from mpz_gcd_ui */ { mpz_gcd, (void (*) (mpz_ptr, mpz_srcptr, unsigned long)) mpz_gcd_ui }, /* 0 */ { mpz_lcm, mpz_lcm_ui }, /* 1 */ }; int i; SV *yv; CODE: assert_table (ix); RETVAL = new_mpz(); if (items == 1) mpz_set (RETVAL->m, x); else { for (i = 1; i < items; i++) { yv = ST(i); if (SvIOK(yv)) (*table[ix].op_ui) (RETVAL->m, x, ABS(SvIVX(yv))); else (*table[ix].op) (RETVAL->m, x, coerce_mpz (tmp_mpz_1, yv)); x = RETVAL->m; } } OUTPUT: RETVAL void gcdext (a, b) mpz_coerce a mpz_coerce b PREINIT: mpz g, x, y; SV *sv; PPCODE: g = new_mpz(); x = new_mpz(); y = new_mpz(); mpz_gcdext (g->m, x->m, y->m, a, b); EXTEND (SP, 3); PUSHs (MPX_NEWMORTAL (g, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (x, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (y, mpz_class_hv)); unsigned long hamdist (x, y) mpz_coerce x mpz_coerce y CODE: RETVAL = mpz_hamdist (x, y); OUTPUT: RETVAL mpz invert (a, m) mpz_coerce a mpz_coerce m CODE: RETVAL = new_mpz(); if (! mpz_invert (RETVAL->m, a, m)) { free_mpz (RETVAL); XSRETURN_UNDEF; } OUTPUT: RETVAL int jacobi (a, b) mpz_coerce a mpz_coerce b CODE: RETVAL = mpz_jacobi (a, b); OUTPUT: RETVAL int kronecker (a, b) SV *a SV *b CODE: if (SvIOK(b)) RETVAL = mpz_kronecker_si (coerce_mpz(tmp_mpz_0,a), SvIVX(b)); else if (SvIOK(a)) RETVAL = mpz_si_kronecker (SvIVX(a), coerce_mpz(tmp_mpz_0,b)); else RETVAL = mpz_kronecker (coerce_mpz(tmp_mpz_0,a), coerce_mpz(tmp_mpz_1,b)); OUTPUT: RETVAL void mpz_export (order, size, endian, nails, z) int order size_t size int endian size_t nails mpz_coerce z PREINIT: size_t numb, count, bytes, actual_count; char *data; SV *sv; PPCODE: numb = 8*size - nails; count = (mpz_sizeinbase (z, 2) + numb-1) / numb; bytes = count * size; New (GMP_MALLOC_ID, data, bytes+1, char); mpz_export (data, &actual_count, order, size, endian, nails, z); assert (count == actual_count); data[bytes] = '\0'; sv = sv_newmortal(); sv_usepvn_mg (sv, data, bytes); PUSHs(sv); mpz mpz_import (order, size, endian, nails, sv) int order size_t size int endian size_t nails SV *sv PREINIT: size_t count; const char *data; STRLEN len; CODE: data = SvPV (sv, len); if ((len % size) != 0) croak ("%s mpz_import: string not a multiple of the given size", mpz_class); count = len / size; RETVAL = new_mpz(); mpz_import (RETVAL->m, count, order, size, endian, nails, data); OUTPUT: RETVAL mpz nextprime (z) mpz_coerce z CODE: RETVAL = new_mpz(); mpz_nextprime (RETVAL->m, z); OUTPUT: RETVAL unsigned long popcount (x) mpz_coerce x CODE: RETVAL = mpz_popcount (x); OUTPUT: RETVAL mpz powm (b, e, m) mpz_coerce b mpz_coerce e mpz_coerce m CODE: RETVAL = new_mpz(); mpz_powm (RETVAL->m, b, e, m); OUTPUT: RETVAL bool probab_prime_p (z, n) mpz_coerce z ulong_coerce n CODE: RETVAL = mpz_probab_prime_p (z, n); OUTPUT: RETVAL # No attempt to coerce here, only an mpz makes sense. void realloc (z, limbs) mpz z int limbs CODE: _mpz_realloc (z->m, limbs); void remove (z, f) mpz_coerce z mpz_coerce f PREINIT: SV *sv; mpz rem; unsigned long mult; PPCODE: rem = new_mpz(); mult = mpz_remove (rem->m, z, f); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv)); PUSHs (sv_2mortal (newSViv (mult))); void roote (z, n) mpz_coerce z ulong_coerce n PREINIT: SV *sv; mpz root; int exact; PPCODE: root = new_mpz(); exact = mpz_root (root->m, z, n); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (root, mpz_class_hv)); sv = (exact ? &PL_sv_yes : &PL_sv_no); sv_2mortal(sv); PUSHs(sv); void rootrem (z, n) mpz_coerce z ulong_coerce n PREINIT: SV *sv; mpz root; mpz rem; PPCODE: root = new_mpz(); rem = new_mpz(); mpz_rootrem (root->m, rem->m, z, n); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (root, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv)); # In the past scan0 and scan1 were described as returning ULONG_MAX which # could be obtained in perl with ~0. That wasn't true on 64-bit systems # (eg. alpha) with perl 5.005, since in that version IV and UV were still # 32-bits. # # We changed in gmp 4.2 to just say ~0 for the not-found return. It's # likely most people have used ~0 rather than POSIX::ULONG_MAX(), so this # change should match existing usage. It only actually makes a difference # in old perl, since recent versions have gone to 64-bits for IV and UV, the # same as a ulong. # # In perl 5.005 we explicitly mask the mpz return down to 32-bits to get ~0. # UV_MAX is no good, it reflects the size of the UV type (64-bits), rather # than the size of the values one ought to be storing in an SV (32-bits). gmp_UV scan0 (z, start) mpz_coerce z ulong_coerce start ALIAS: GMP::Mpz::scan1 = 1 PREINIT: static_functable const struct { unsigned long (*op) (mpz_srcptr, unsigned long); } table[] = { { mpz_scan0 }, /* 0 */ { mpz_scan1 }, /* 1 */ }; CODE: assert_table (ix); RETVAL = (*table[ix].op) (z, start); if (PERL_LT (5,6)) RETVAL &= 0xFFFFFFFF; OUTPUT: RETVAL void setbit (sv, bit) SV *sv ulong_coerce bit ALIAS: GMP::Mpz::clrbit = 1 GMP::Mpz::combit = 2 PREINIT: static_functable const struct { void (*op) (mpz_ptr, unsigned long); } table[] = { { mpz_setbit }, /* 0 */ { mpz_clrbit }, /* 1 */ { mpz_combit }, /* 2 */ }; int use; mpz z; CODE: use = use_sv (sv); if (use == USE_MPZ && SvREFCNT(SvRV(sv)) == 1 && ! SvSMAGICAL(sv)) { /* our operand is a non-magical mpz with a reference count of 1, so we can just modify it */ (*table[ix].op) (SvMPZ(sv)->m, bit); } else { /* otherwise we need to make a new mpz, from whatever we have, and operate on that, possibly invoking magic when storing back */ SV *new_sv; mpz z = new_mpz (); mpz_ptr coerce_ptr = coerce_mpz_using (z->m, sv, use); if (coerce_ptr != z->m) mpz_set (z->m, coerce_ptr); (*table[ix].op) (z->m, bit); new_sv = sv_bless (sv_setref_pv (sv_newmortal(), NULL, z), mpz_class_hv); SvSetMagicSV (sv, new_sv); } void sqrtrem (z) mpz_coerce z PREINIT: SV *sv; mpz root; mpz rem; PPCODE: root = new_mpz(); rem = new_mpz(); mpz_sqrtrem (root->m, rem->m, z); EXTEND (SP, 2); PUSHs (MPX_NEWMORTAL (root, mpz_class_hv)); PUSHs (MPX_NEWMORTAL (rem, mpz_class_hv)); size_t sizeinbase (z, base) mpz_coerce z int base CODE: RETVAL = mpz_sizeinbase (z, base); OUTPUT: RETVAL int tstbit (z, bit) mpz_coerce z ulong_coerce bit CODE: RETVAL = mpz_tstbit (z, bit); OUTPUT: RETVAL #------------------------------------------------------------------------------ MODULE = GMP PACKAGE = GMP::Mpq mpq mpq (...) ALIAS: GMP::Mpq::new = 1 CODE: TRACE (printf ("%s new, ix=%ld, items=%d\n", mpq_class, ix, (int) items)); RETVAL = new_mpq(); switch (items) { case 0: mpq_set_ui (RETVAL->m, 0L, 1L); break; case 1: { mpq_ptr rp = RETVAL->m; mpq_ptr cp = coerce_mpq (rp, ST(0)); if (cp != rp) mpq_set (rp, cp); } break; case 2: { mpz_ptr rp, cp; rp = mpq_numref (RETVAL->m); cp = coerce_mpz (rp, ST(0)); if (cp != rp) mpz_set (rp, cp); rp = mpq_denref (RETVAL->m); cp = coerce_mpz (rp, ST(1)); if (cp != rp) mpz_set (rp, cp); } break; default: croak ("%s new: invalid arguments", mpq_class); } OUTPUT: RETVAL void overload_constant (str, pv, d1, ...) const_string_assume str SV *pv dummy d1 PREINIT: SV *sv; mpq q; PPCODE: TRACE (printf ("%s constant: %s\n", mpq_class, str)); q = new_mpq(); if (mpq_set_str (q->m, str, 0) == 0) { sv = sv_bless (sv_setref_pv (sv_newmortal(), NULL, q), mpq_class_hv); } else { free_mpq (q); sv = pv; } XPUSHs(sv); mpq overload_copy (q, d1, d2) mpq_assume q dummy d1 dummy d2 CODE: RETVAL = new_mpq(); mpq_set (RETVAL->m, q->m); OUTPUT: RETVAL void DESTROY (q) mpq_assume q CODE: TRACE (printf ("%s DESTROY %p\n", mpq_class, q)); free_mpq (q); malloced_string overload_string (q, d1, d2) mpq_assume q dummy d1 dummy d2 CODE: TRACE (printf ("%s overload_string %p\n", mpq_class, q)); RETVAL = mpq_get_str (NULL, 10, q->m); OUTPUT: RETVAL mpq overload_add (xv, yv, order) SV *xv SV *yv SV *order ALIAS: GMP::Mpq::overload_sub = 1 GMP::Mpq::overload_mul = 2 GMP::Mpq::overload_div = 3 PREINIT: static_functable const struct { void (*op) (mpq_ptr, mpq_srcptr, mpq_srcptr); } table[] = { { mpq_add }, /* 0 */ { mpq_sub }, /* 1 */ { mpq_mul }, /* 2 */ { mpq_div }, /* 3 */ }; CODE: TRACE (printf ("%s binary\n", mpf_class)); assert_table (ix); if (order == &PL_sv_yes) SV_PTR_SWAP (xv, yv); RETVAL = new_mpq(); (*table[ix].op) (RETVAL->m, coerce_mpq (tmp_mpq_0, xv), coerce_mpq (tmp_mpq_1, yv)); OUTPUT: RETVAL void overload_addeq (x, y, o) mpq_assume x mpq_coerce y order_noswap o ALIAS: GMP::Mpq::overload_subeq = 1 GMP::Mpq::overload_muleq = 2 GMP::Mpq::overload_diveq = 3 PREINIT: static_functable const struct { void (*op) (mpq_ptr, mpq_srcptr, mpq_srcptr); } table[] = { { mpq_add }, /* 0 */ { mpq_sub }, /* 1 */ { mpq_mul }, /* 2 */ { mpq_div }, /* 3 */ }; PPCODE: assert_table (ix); (*table[ix].op) (x->m, x->m, y); XPUSHs(ST(0)); mpq overload_lshift (qv, nv, order) SV *qv SV *nv SV *order ALIAS: GMP::Mpq::overload_rshift = 1 GMP::Mpq::overload_pow = 2 PREINIT: static_functable const struct { void (*op) (mpq_ptr, mpq_srcptr, unsigned long); } table[] = { { mpq_mul_2exp }, /* 0 */ { mpq_div_2exp }, /* 1 */ { x_mpq_pow_ui }, /* 2 */ }; CODE: assert_table (ix); if (order == &PL_sv_yes) SV_PTR_SWAP (qv, nv); RETVAL = new_mpq(); (*table[ix].op) (RETVAL->m, coerce_mpq (RETVAL->m, qv), coerce_ulong (nv)); OUTPUT: RETVAL void overload_lshifteq (q, n, o) mpq_assume q ulong_coerce n order_noswap o ALIAS: GMP::Mpq::overload_rshifteq = 1 GMP::Mpq::overload_poweq = 2 PREINIT: static_functable const struct { void (*op) (mpq_ptr, mpq_srcptr, unsigned long); } table[] = { { mpq_mul_2exp }, /* 0 */ { mpq_div_2exp }, /* 1 */ { x_mpq_pow_ui }, /* 2 */ }; PPCODE: assert_table (ix); (*table[ix].op) (q->m, q->m, n); XPUSHs(ST(0)); void overload_inc (q, d1, d2) mpq_assume q dummy d1 dummy d2 ALIAS: GMP::Mpq::overload_dec = 1 PREINIT: static_functable const struct { void (*op) (mpz_ptr, mpz_srcptr, mpz_srcptr); } table[] = { { mpz_add }, /* 0 */ { mpz_sub }, /* 1 */ }; CODE: assert_table (ix); (*table[ix].op) (mpq_numref(q->m), mpq_numref(q->m), mpq_denref(q->m)); mpq overload_abs (q, d1, d2) mpq_assume q dummy d1 dummy d2 ALIAS: GMP::Mpq::overload_neg = 1 PREINIT: static_functable const struct { void (*op) (mpq_ptr w, mpq_srcptr x); } table[] = { { mpq_abs }, /* 0 */ { mpq_neg }, /* 1 */ }; CODE: assert_table (ix); RETVAL = new_mpq(); (*table[ix].op) (RETVAL->m, q->m); OUTPUT: RETVAL int overload_spaceship (x, y, order) mpq_assume x mpq_coerce y SV *order CODE: RETVAL = mpq_cmp (x->m, y); RETVAL = SGN (RETVAL); if (order == &PL_sv_yes) RETVAL = -RETVAL; OUTPUT: RETVAL bool overload_bool (q, d1, d2) mpq_assume q dummy d1 dummy d2 ALIAS: GMP::Mpq::overload_not = 1 CODE: RETVAL = (mpq_sgn (q->m) != 0) ^ ix; OUTPUT: RETVAL bool overload_eq (x, yv, d) mpq_assume x SV *yv dummy d ALIAS: GMP::Mpq::overload_ne = 1 PREINIT: int use; CODE: use = use_sv (yv); switch (use) { case USE_IVX: case USE_UVX: case USE_MPZ: RETVAL = 0; if (x_mpq_integer_p (x->m)) { switch (use) { case USE_IVX: RETVAL = (mpz_cmp_si (mpq_numref(x->m), SvIVX(yv)) == 0); break; case USE_UVX: RETVAL = (mpz_cmp_ui (mpq_numref(x->m), SvUVX(yv)) == 0); break; case USE_MPZ: RETVAL = (mpz_cmp (mpq_numref(x->m), SvMPZ(yv)->m) == 0); break; } } break; case USE_MPQ: RETVAL = (mpq_equal (x->m, SvMPQ(yv)->m) != 0); break; default: RETVAL = (mpq_equal (x->m, coerce_mpq_using (tmp_mpq_0, yv, use)) != 0); break; } RETVAL ^= ix; OUTPUT: RETVAL void canonicalize (q) mpq q CODE: mpq_canonicalize (q->m); mpq inv (q) mpq_coerce q CODE: RETVAL = new_mpq(); mpq_inv (RETVAL->m, q); OUTPUT: RETVAL mpz num (q) mpq q ALIAS: GMP::Mpq::den = 1 CODE: RETVAL = new_mpz(); mpz_set (RETVAL->m, (ix == 0 ? mpq_numref(q->m) : mpq_denref(q->m))); OUTPUT: RETVAL #------------------------------------------------------------------------------ MODULE = GMP PACKAGE = GMP::Mpf mpf mpf (...) ALIAS: GMP::Mpf::new = 1 PREINIT: unsigned long prec; CODE: TRACE (printf ("%s new\n", mpf_class)); if (items > 2) croak ("%s new: invalid arguments", mpf_class); prec = (items == 2 ? coerce_ulong (ST(1)) : mpf_get_default_prec()); RETVAL = new_mpf (prec); if (items >= 1) { SV *sv = ST(0); my_mpf_set_sv_using (RETVAL, sv, use_sv(sv)); } OUTPUT: RETVAL mpf overload_constant (sv, d1, d2, ...) SV *sv dummy d1 dummy d2 CODE: assert (SvPOK (sv)); TRACE (printf ("%s constant: %s\n", mpq_class, SvPVX(sv))); RETVAL = new_mpf (mpf_get_default_prec()); my_mpf_set_svstr (RETVAL, sv); OUTPUT: RETVAL mpf overload_copy (f, d1, d2) mpf_assume f dummy d1 dummy d2 CODE: TRACE (printf ("%s copy\n", mpf_class)); RETVAL = new_mpf (mpf_get_prec (f)); mpf_set (RETVAL, f); OUTPUT: RETVAL void DESTROY (f) mpf_assume f CODE: TRACE (printf ("%s DESTROY %p\n", mpf_class, f)); mpf_clear (f); Safefree (f); assert_support (mpf_count--); TRACE_ACTIVE (); mpf overload_add (x, y, order) mpf_assume x mpf_coerce_st0 y SV *order ALIAS: GMP::Mpf::overload_sub = 1 GMP::Mpf::overload_mul = 2 GMP::Mpf::overload_div = 3 PREINIT: static_functable const struct { void (*op) (mpf_ptr, mpf_srcptr, mpf_srcptr); } table[] = { { mpf_add }, /* 0 */ { mpf_sub }, /* 1 */ { mpf_mul }, /* 2 */ { mpf_div }, /* 3 */ }; CODE: assert_table (ix); RETVAL = new_mpf (mpf_get_prec (x)); if (order == &PL_sv_yes) MPF_PTR_SWAP (x, y); (*table[ix].op) (RETVAL, x, y); OUTPUT: RETVAL void overload_addeq (x, y, o) mpf_assume x mpf_coerce_st0 y order_noswap o ALIAS: GMP::Mpf::overload_subeq = 1 GMP::Mpf::overload_muleq = 2 GMP::Mpf::overload_diveq = 3 PREINIT: static_functable const struct { void (*op) (mpf_ptr, mpf_srcptr, mpf_srcptr); } table[] = { { mpf_add }, /* 0 */ { mpf_sub }, /* 1 */ { mpf_mul }, /* 2 */ { mpf_div }, /* 3 */ }; PPCODE: assert_table (ix); (*table[ix].op) (x, x, y); XPUSHs(ST(0)); mpf overload_lshift (fv, nv, order) SV *fv SV *nv SV *order ALIAS: GMP::Mpf::overload_rshift = 1 GMP::Mpf::overload_pow = 2 PREINIT: static_functable const struct { void (*op) (mpf_ptr, mpf_srcptr, unsigned long); } table[] = { { mpf_mul_2exp }, /* 0 */ { mpf_div_2exp }, /* 1 */ { mpf_pow_ui }, /* 2 */ }; mpf f; unsigned long prec; CODE: assert_table (ix); MPF_ASSUME (f, fv); prec = mpf_get_prec (f); if (order == &PL_sv_yes) SV_PTR_SWAP (fv, nv); f = coerce_mpf (tmp_mpf_0, fv, prec); RETVAL = new_mpf (prec); (*table[ix].op) (RETVAL, f, coerce_ulong (nv)); OUTPUT: RETVAL void overload_lshifteq (f, n, o) mpf_assume f ulong_coerce n order_noswap o ALIAS: GMP::Mpf::overload_rshifteq = 1 GMP::Mpf::overload_poweq = 2 PREINIT: static_functable const struct { void (*op) (mpf_ptr, mpf_srcptr, unsigned long); } table[] = { { mpf_mul_2exp }, /* 0 */ { mpf_div_2exp }, /* 1 */ { mpf_pow_ui }, /* 2 */ }; PPCODE: assert_table (ix); (*table[ix].op) (f, f, n); XPUSHs(ST(0)); mpf overload_abs (f, d1, d2) mpf_assume f dummy d1 dummy d2 ALIAS: GMP::Mpf::overload_neg = 1 GMP::Mpf::overload_sqrt = 2 PREINIT: static_functable const struct { void (*op) (mpf_ptr w, mpf_srcptr x); } table[] = { { mpf_abs }, /* 0 */ { mpf_neg }, /* 1 */ { mpf_sqrt }, /* 2 */ }; CODE: assert_table (ix); RETVAL = new_mpf (mpf_get_prec (f)); (*table[ix].op) (RETVAL, f); OUTPUT: RETVAL void overload_inc (f, d1, d2) mpf_assume f dummy d1 dummy d2 ALIAS: GMP::Mpf::overload_dec = 1 PREINIT: static_functable const struct { void (*op) (mpf_ptr w, mpf_srcptr x, unsigned long y); } table[] = { { mpf_add_ui }, /* 0 */ { mpf_sub_ui }, /* 1 */ }; CODE: assert_table (ix); (*table[ix].op) (f, f, 1L); int overload_spaceship (xv, yv, order) SV *xv SV *yv SV *order PREINIT: mpf x; CODE: MPF_ASSUME (x, xv); switch (use_sv (yv)) { case USE_IVX: RETVAL = mpf_cmp_si (x, SvIVX(yv)); break; case USE_UVX: RETVAL = mpf_cmp_ui (x, SvUVX(yv)); break; case USE_NVX: RETVAL = mpf_cmp_d (x, SvNVX(yv)); break; case USE_PVX: { STRLEN len; const char *str = SvPV (yv, len); /* enough for all digits of the string */ tmp_mpf_set_prec (tmp_mpf_0, strlen(str)+64); if (mpf_set_str (tmp_mpf_0->m, str, 10) != 0) croak ("%s <=>: invalid string format", mpf_class); RETVAL = mpf_cmp (x, tmp_mpf_0->m); } break; case USE_MPZ: RETVAL = - x_mpz_cmp_f (SvMPZ(yv)->m, x); break; case USE_MPF: RETVAL = mpf_cmp (x, SvMPF(yv)); break; default: RETVAL = mpq_cmp (coerce_mpq (tmp_mpq_0, xv), coerce_mpq (tmp_mpq_1, yv)); break; } RETVAL = SGN (RETVAL); if (order == &PL_sv_yes) RETVAL = -RETVAL; OUTPUT: RETVAL bool overload_bool (f, d1, d2) mpf_assume f dummy d1 dummy d2 ALIAS: GMP::Mpf::overload_not = 1 CODE: RETVAL = (mpf_sgn (f) != 0) ^ ix; OUTPUT: RETVAL mpf ceil (f) mpf_coerce_def f ALIAS: GMP::Mpf::floor = 1 GMP::Mpf::trunc = 2 PREINIT: static_functable const struct { void (*op) (mpf_ptr w, mpf_srcptr x); } table[] = { { mpf_ceil }, /* 0 */ { mpf_floor }, /* 1 */ { mpf_trunc }, /* 2 */ }; CODE: assert_table (ix); RETVAL = new_mpf (mpf_get_prec (f)); (*table[ix].op) (RETVAL, f); OUTPUT: RETVAL unsigned long get_default_prec () CODE: RETVAL = mpf_get_default_prec(); OUTPUT: RETVAL unsigned long get_prec (f) mpf_coerce_def f CODE: RETVAL = mpf_get_prec (f); OUTPUT: RETVAL bool mpf_eq (xv, yv, bits) SV *xv SV *yv ulong_coerce bits PREINIT: mpf x, y; CODE: TRACE (printf ("%s eq\n", mpf_class)); coerce_mpf_pair (&x,xv, &y,yv); RETVAL = mpf_eq (x, y, bits); OUTPUT: RETVAL mpf reldiff (xv, yv) SV *xv SV *yv PREINIT: mpf x, y; unsigned long prec; CODE: TRACE (printf ("%s reldiff\n", mpf_class)); prec = coerce_mpf_pair (&x,xv, &y,yv); RETVAL = new_mpf (prec); mpf_reldiff (RETVAL, x, y); OUTPUT: RETVAL void set_default_prec (prec) ulong_coerce prec CODE: TRACE (printf ("%s set_default_prec %lu\n", mpf_class, prec)); mpf_set_default_prec (prec); void set_prec (sv, prec) SV *sv ulong_coerce prec PREINIT: mpf_ptr old_f, new_f; int use; CODE: TRACE (printf ("%s set_prec to %lu\n", mpf_class, prec)); use = use_sv (sv); if (use == USE_MPF) { old_f = SvMPF(sv); if (SvREFCNT(SvRV(sv)) == 1) mpf_set_prec (old_f, prec); else { TRACE (printf (" fork new mpf\n")); new_f = new_mpf (prec); mpf_set (new_f, old_f); goto setref; } } else { TRACE (printf (" coerce to mpf\n")); new_f = new_mpf (prec); my_mpf_set_sv_using (new_f, sv, use); setref: sv_bless (sv_setref_pv (sv, NULL, new_f), mpf_class_hv); } #------------------------------------------------------------------------------ MODULE = GMP PACKAGE = GMP::Rand randstate new (...) ALIAS: GMP::Rand::randstate = 1 CODE: TRACE (printf ("%s new\n", rand_class)); New (GMP_MALLOC_ID, RETVAL, 1, __gmp_randstate_struct); TRACE (printf (" RETVAL %p\n", RETVAL)); assert_support (rand_count++); TRACE_ACTIVE (); if (items == 0) { gmp_randinit_default (RETVAL); } else { if (SvROK (ST(0)) && sv_derived_from (ST(0), rand_class)) { if (items != 1) goto invalid; gmp_randinit_set (RETVAL, SvRANDSTATE (ST(0))); } else { STRLEN len; const char *method = SvPV (ST(0), len); assert (len == strlen (method)); if (strcmp (method, "lc_2exp") == 0) { if (items != 4) goto invalid; gmp_randinit_lc_2exp (RETVAL, coerce_mpz (tmp_mpz_0, ST(1)), coerce_ulong (ST(2)), coerce_ulong (ST(3))); } else if (strcmp (method, "lc_2exp_size") == 0) { if (items != 2) goto invalid; if (! gmp_randinit_lc_2exp_size (RETVAL, coerce_ulong (ST(1)))) { Safefree (RETVAL); XSRETURN_UNDEF; } } else if (strcmp (method, "mt") == 0) { if (items != 1) goto invalid; gmp_randinit_mt (RETVAL); } else { invalid: croak ("%s new: invalid arguments", rand_class); } } } OUTPUT: RETVAL void DESTROY (r) randstate r CODE: TRACE (printf ("%s DESTROY\n", rand_class)); gmp_randclear (r); Safefree (r); assert_support (rand_count--); TRACE_ACTIVE (); void seed (r, z) randstate r mpz_coerce z CODE: gmp_randseed (r, z); mpz mpz_urandomb (r, bits) randstate r ulong_coerce bits ALIAS: GMP::Rand::mpz_rrandomb = 1 PREINIT: static_functable const struct { void (*fun) (mpz_ptr, gmp_randstate_t r, unsigned long bits); } table[] = { { mpz_urandomb }, /* 0 */ { mpz_rrandomb }, /* 1 */ }; CODE: assert_table (ix); RETVAL = new_mpz(); (*table[ix].fun) (RETVAL->m, r, bits); OUTPUT: RETVAL mpz mpz_urandomm (r, m) randstate r mpz_coerce m CODE: RETVAL = new_mpz(); mpz_urandomm (RETVAL->m, r, m); OUTPUT: RETVAL mpf mpf_urandomb (r, bits) randstate r ulong_coerce bits CODE: RETVAL = new_mpf (bits); mpf_urandomb (RETVAL, r, bits); OUTPUT: RETVAL unsigned long gmp_urandomb_ui (r, bits) randstate r ulong_coerce bits ALIAS: GMP::Rand::gmp_urandomm_ui = 1 PREINIT: static_functable const struct { unsigned long (*fun) (gmp_randstate_t r, unsigned long bits); } table[] = { { gmp_urandomb_ui }, /* 0 */ { gmp_urandomm_ui }, /* 1 */ }; CODE: assert_table (ix); RETVAL = (*table[ix].fun) (r, bits); OUTPUT: RETVAL gcl-2.6.14/gmp4/demos/perl/sample.pl0000644000175000017500000000307714360276512015540 0ustar cammcamm#!/usr/bin/perl -w # Some sample GMP module operations # Copyright 2001, 2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. use strict; use GMP; print "using GMP module $GMP::VERSION and GMP library ",GMP::version(),"\n"; use GMP::Mpz qw(:all); print "the 200th fibonacci number is ", fib(200), "\n"; print "next prime after 10**30 is (probably) ", nextprime(mpz(10)**30), "\n"; use GMP::Mpq qw(:constants); print "the 7th harmonic number is ", 1+1/2+1/3+1/4+1/5+1/6+1/7, "\n"; use GMP::Mpq qw(:noconstants); use GMP::Mpf qw(mpf); my $f = mpf(1,180); $f >>= 180; $f += 1; print "a sample mpf is $f\n"; gcl-2.6.14/gmp4/demos/perl/INSTALL0000644000175000017500000000460314360276512014747 0ustar cammcammCopyright 2001, 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. GMP PERL MODULE INSTALLATION This module can be compiled within the GMP source directory or moved elsewhere and compiled. An installed GMP can be used, or a specified GMP build tree. Both static and shared GMP builds will work. The simplest case is when GMP has been installed to a standard system location perl Makefile.PL make If not yet installed then the top-level GMP build directory must be specified perl Makefile.PL GMP_BUILDDIR=/my/gmp/build make In any case, with the module built, the sample program provided can be run perl -Iblib/arch sample.pl If you built a shared version of libgmp but haven't yet installed it, then it might be necessary to add a run-time path to it. For example LD_LIBRARY_PATH=/my/gmp/build/.libs perl -Iblib/arch sample.pl Documentation is provided in pod format in GMP.pm, and will have been "man"-ified in the module build man -l blib/man3/GMP.3pm or man -M`pwd`/blib GMP A test script is provided, running a large number of more or less trivial checks make test The module and its documentation can be installed in the usual way make install This will be into /usr/local or wherever the perl Config module directs, but that can be controlled back at the Makefile.PL stage with the usual ExtUtils::MakeMaker options. Once installed, programs using the GMP module become simply perl sample.pl And the documentation read directly too man GMP gcl-2.6.14/gmp4/demos/perl/GMP/0000755000175000017500000000000014360276512014336 5ustar cammcammgcl-2.6.14/gmp4/demos/perl/GMP/Mpz.pm0000644000175000017500000000642614360276512015452 0ustar cammcamm# GMP mpz module. # Copyright 2001-2003 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. package GMP::Mpz; require GMP; require Exporter; @ISA = qw(GMP Exporter); @EXPORT = qw(); @EXPORT_OK = qw(); %EXPORT_TAGS = ('all' => [qw( bin cdiv cdiv_2exp clrbit combit congruent_p congruent_2exp_p divexact divisible_p divisible_2exp_p even_p fac fdiv fdiv_2exp fib fib2 gcd gcdext hamdist invert jacobi kronecker lcm lucnum lucnum2 mod mpz mpz_export mpz_import nextprime odd_p perfect_power_p perfect_square_p popcount powm probab_prime_p realloc remove root roote rootrem scan0 scan1 setbit sizeinbase sqrtrem tdiv tdiv_2exp tstbit)], 'constants' => [@EXPORT], 'noconstants' => [@EXPORT]); Exporter::export_ok_tags('all'); use overload '+' => \&overload_add, '+=' => \&overload_addeq, '-' => \&overload_sub, '-=' => \&overload_subeq, '*' => \&overload_mul, '*=' => \&overload_muleq, '/' => \&overload_div, '/=' => \&overload_diveq, '%' => \&overload_rem, '%=' => \&overload_remeq, '<<' => \&overload_lshift, '<<=' => \&overload_lshifteq, '>>' => \&overload_rshift, '>>=' => \&overload_rshifteq, '**' => \&overload_pow, '**=' => \&overload_poweq, '&' => \&overload_and, '&=' => \&overload_andeq, '|' => \&overload_ior, '|=' => \&overload_ioreq, '^' => \&overload_xor, '^=' => \&overload_xoreq, 'bool' => \&overload_bool, 'not' => \&overload_not, '!' => \&overload_not, '~' => \&overload_com, '<=>' => \&overload_spaceship, '++' => \&overload_inc, '--' => \&overload_dec, '=' => \&overload_copy, 'abs' => \&overload_abs, 'neg' => \&overload_neg, 'sqrt' => \&overload_sqrt, '""' => \&overload_string; sub import { foreach (@_) { if ($_ eq ':constants') { overload::constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } elsif ($_ eq ':noconstants') { overload::remove_constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } } goto &Exporter::import; } 1; __END__ # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/perl/GMP/Mpq.pm0000644000175000017500000000513414360276512015434 0ustar cammcamm# GMP mpq module. # Copyright 2001 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. package GMP::Mpq; require GMP; require Exporter; @ISA = qw(GMP Exporter); @EXPORT = qw(); @EXPORT_OK = qw(); %EXPORT_TAGS = ('all' => [qw(canonicalize den inv mpq num)], 'constants' => [@EXPORT], 'noconstants' => [@EXPORT] ); Exporter::export_ok_tags('all'); use overload '+' => \&overload_add, '+=' => \&overload_addeq, '-' => \&overload_sub, '-=' => \&overload_subeq, '*' => \&overload_mul, '*=' => \&overload_muleq, '/' => \&overload_div, '/=' => \&overload_diveq, '**' => \&overload_pow, '**=' => \&overload_poweq, '<<' => \&overload_lshift, '<<=' => \&overload_lshifteq, '>>' => \&overload_rshift, '>>=' => \&overload_rshifteq, 'bool' => \&overload_bool, 'not' => \&overload_not, '!' => \&overload_not, '==' => \&overload_eq, '!=' => \&overload_ne, '<=>' => \&overload_spaceship, '++' => \&overload_inc, '--' => \&overload_dec, 'abs' => \&overload_abs, 'neg' => \&overload_neg, '=' => \&overload_copy, '""' => \&overload_string; my $constants = { }; sub import { foreach (@_) { if ($_ eq ':constants') { overload::constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } elsif ($_ eq ':noconstants') { overload::remove_constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } } goto &Exporter::import; } 1; __END__ # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/perl/GMP/Rand.pm0000644000175000017500000000253714360276512015567 0ustar cammcamm# GMP random numbers module. # Copyright 2001, 2003 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. package GMP::Rand; require GMP; require Exporter; @ISA = qw(GMP Exporter); @EXPORT = qw(); %EXPORT_TAGS = ('all' => [qw( randstate mpf_urandomb mpz_rrandomb mpz_urandomb mpz_urandomm gmp_urandomb_ui gmp_urandomm_ui)]); Exporter::export_ok_tags('all'); 1; __END__ gcl-2.6.14/gmp4/demos/perl/GMP/Mpf.pm0000644000175000017500000000601514360276512015420 0ustar cammcamm# GMP mpf module. # Copyright 2001, 2003 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. package GMP::Mpf; require GMP; require Exporter; @ISA = qw(GMP Exporter); @EXPORT = qw(); @EXPORT_OK = qw(); %EXPORT_TAGS = ('all' => [qw( ceil floor get_default_prec get_prec mpf mpf_eq reldiff set_default_prec set_prec trunc)], 'constants' => [@EXPORT], 'noconstants' => [@EXPORT]); Exporter::export_ok_tags('all'); use overload '+' => \&overload_add, '+=' => \&overload_addeq, '-' => \&overload_sub, '-=' => \&overload_subeq, '*' => \&overload_mul, '*=' => \&overload_muleq, '/' => \&overload_div, '/=' => \&overload_diveq, '**' => \&overload_pow, '**=' => \&overload_poweq, '<<' => \&overload_lshift, '<<=' => \&overload_lshifteq, '>>' => \&overload_rshift, '>>=' => \&overload_rshifteq, 'bool' => \&overload_bool, 'not' => \&overload_not, '!' => \&overload_not, '<=>' => \&overload_spaceship, '++' => \&overload_inc, '--' => \&overload_dec, 'abs' => \&overload_abs, 'neg' => \&overload_neg, 'sqrt' => \&overload_sqrt, '=' => \&overload_copy, '""' => \&overload_string; sub import { foreach (@_) { if ($_ eq ':constants') { overload::constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } elsif ($_ eq ':noconstants') { overload::remove_constant ('integer' => \&overload_constant, 'binary' => \&overload_constant, 'float' => \&overload_constant); } } goto &Exporter::import; } sub overload_string { my $fmt; BEGIN { $^W = 0; } if (defined ($#)) { $fmt = $#; BEGIN { $^W = 1; } # protect against calling sprintf_internal with a bad format if ($fmt !~ /^((%%|[^%])*%[-+ .\d]*)([eEfgG](%%|[^%])*)$/) { die "GMP::Mpf: invalid \$# format: $#\n"; } $fmt = $1 . 'F' . $3; } else { $fmt = '%.Fg'; } GMP::sprintf_internal ($fmt, $_[0]); } 1; __END__ # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/perl/test.pl0000644000175000017500000016355214360276512015243 0ustar cammcamm#!/usr/bin/perl -w # GMP perl module tests # Copyright 2001-2003 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # These tests aim to exercise the many possible combinations of operands # etc, and to run all functions at least once, which if nothing else will # check everything intended is in the :all list. # # Use the following in .emacs to match test failure messages. # # ;; perl "Test" module error messages # (eval-after-load "compile" # '(add-to-list # 'compilation-error-regexp-alist # '("^.*Failed test [0-9]+ in \\([^ ]+\\) at line \\([0-9]+\\)" 1 2))) use strict; use Test; BEGIN { plan tests => 123, onfail => sub { print "there were failures\n" }, } use GMP qw(:all); use GMP::Mpz qw(:all); use GMP::Mpq qw(:all); use GMP::Mpf qw(:all); use GMP::Rand qw(:all); use GMP::Mpz qw(:constants); use GMP::Mpz qw(:noconstants); use GMP::Mpq qw(:constants); use GMP::Mpq qw(:noconstants); use GMP::Mpf qw(:constants); use GMP::Mpf qw(:noconstants); package Mytie; use Exporter; use vars qw($val $fetched $stored); $val = 0; $fetched = 0; $stored = 0; sub TIESCALAR { my ($class, $newval) = @_; my $var = 'mytie dummy refed var'; $val = $newval; $fetched = 0; $stored = 0; return bless \$var, $class; } sub FETCH { my ($self) = @_; $fetched++; return $val; } sub STORE { my ($self, $newval) = @_; $val = $newval; $stored++; } package main; # check Mytie does what it should { tie my $t, 'Mytie', 123; ok ($Mytie::val == 123); $Mytie::val = 456; ok ($t == 456); $t = 789; ok ($Mytie::val == 789); } # Usage: str(x) # Return x forced to a string, not a PVIV. # sub str { my $s = "$_[0]" . ""; return $s; } my $ivnv_2p128 = 65536.0 * 65536.0 * 65536.0 * 65536.0 * 65536.0 * 65536.0 * 65536.0 * 65536.0; kill (0, $ivnv_2p128); my $str_2p128 = '340282366920938463463374607431768211456'; my $uv_max = ~ 0; my $uv_max_str = ~ 0; $uv_max_str = "$uv_max_str"; $uv_max_str = "" . "$uv_max_str"; #------------------------------------------------------------------------------ # GMP::version use GMP qw(version); print '$GMP::VERSION ',$GMP::VERSION,' GMP::version() ',version(),"\n"; #------------------------------------------------------------------------------ # GMP::Mpz::new ok (mpz(0) == 0); ok (mpz('0') == 0); ok (mpz(substr('101',1,1)) == 0); ok (mpz(0.0) == 0); ok (mpz(mpz(0)) == 0); ok (mpz(mpq(0)) == 0); ok (mpz(mpf(0)) == 0); { tie my $t, 'Mytie', 0; ok (mpz($t) == 0); ok ($Mytie::fetched > 0); } { tie my $t, 'Mytie', '0'; ok (mpz($t) == 0); ok ($Mytie::fetched > 0); } { tie my $t, 'Mytie', substr('101',1,1); ok (mpz($t) == 0); } { tie my $t, 'Mytie', 0.0; ok (mpz($t) == 0); } { tie my $t, 'Mytie', mpz(0); ok (mpz($t) == 0); } { tie my $t, 'Mytie', mpq(0); ok (mpz($t) == 0); } { tie my $t, 'Mytie', mpf(0); ok (mpz($t) == 0); } ok (mpz(-123) == -123); ok (mpz('-123') == -123); ok (mpz(substr('1-1231',1,4)) == -123); ok (mpz(-123.0) == -123); ok (mpz(mpz(-123)) == -123); ok (mpz(mpq(-123)) == -123); ok (mpz(mpf(-123)) == -123); { tie my $t, 'Mytie', -123; ok (mpz($t) == -123); } { tie my $t, 'Mytie', '-123'; ok (mpz($t) == -123); } { tie my $t, 'Mytie', substr('1-1231',1,4); ok (mpz($t) == -123); } { tie my $t, 'Mytie', -123.0; ok (mpz($t) == -123); } { tie my $t, 'Mytie', mpz(-123); ok (mpz($t) == -123); } { tie my $t, 'Mytie', mpq(-123); ok (mpz($t) == -123); } { tie my $t, 'Mytie', mpf(-123); ok (mpz($t) == -123); } ok (mpz($ivnv_2p128) == $str_2p128); { tie my $t, 'Mytie', $ivnv_2p128; ok (mpz($t) == $str_2p128); } ok (mpz($uv_max) > 0); ok (mpz($uv_max) == mpz($uv_max_str)); { tie my $t, 'Mytie', $uv_max; ok (mpz($t) > 0); } { tie my $t, 'Mytie', $uv_max; ok (mpz($t) == mpz($uv_max_str)); } { my $s = '999999999999999999999999999999'; kill (0, $s); ok (mpz($s) == '999999999999999999999999999999'); tie my $t, 'Mytie', $s; ok (mpz($t) == '999999999999999999999999999999'); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_abs ok (abs(mpz(0)) == 0); ok (abs(mpz(123)) == 123); ok (abs(mpz(-123)) == 123); { my $x = mpz(-123); $x = abs($x); ok ($x == 123); } { my $x = mpz(0); $x = abs($x); ok ($x == 0); } { my $x = mpz(123); $x = abs($x); ok ($x == 123); } { tie my $t, 'Mytie', mpz(0); ok (abs($t) == 0); } { tie my $t, 'Mytie', mpz(123); ok (abs($t) == 123); } { tie my $t, 'Mytie', mpz(-123); ok (abs($t) == 123); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_add ok (mpz(0) + 1 == 1); ok (mpz(-1) + 1 == 0); ok (1 + mpz(0) == 1); ok (1 + mpz(-1) == 0); #------------------------------------------------------------------------------ # GMP::Mpz::overload_addeq { my $a = mpz(7); $a += 1; ok ($a == 8); } { my $a = mpz(7); my $b = $a; $a += 1; ok ($a == 8); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_and ok ((mpz(3) & 1) == 1); ok ((mpz(3) & 4) == 0); { my $a = mpz(3); $a &= 1; ok ($a == 1); } { my $a = mpz(3); $a &= 4; ok ($a == 0); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_bool if (mpz(0)) { ok (0); } else { ok (1); } if (mpz(123)) { ok (1); } else { ok (0); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_com ok (~ mpz(0) == -1); ok (~ mpz(1) == -2); ok (~ mpz(-2) == 1); ok (~ mpz(0xFF) == -0x100); ok (~ mpz(-0x100) == 0xFF); #------------------------------------------------------------------------------ # GMP::Mpz::overload_dec { my $a = mpz(0); ok ($a-- == 0); ok ($a == -1); } { my $a = mpz(0); ok (--$a == -1); } { my $a = mpz(0); my $b = $a; $a--; ok ($a == -1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_div ok (mpz(6) / 2 == 3); ok (mpz(-6) / 2 == -3); ok (mpz(6) / -2 == -3); ok (mpz(-6) / -2 == 3); #------------------------------------------------------------------------------ # GMP::Mpz::overload_diveq { my $a = mpz(21); $a /= 3; ok ($a == 7); } { my $a = mpz(21); my $b = $a; $a /= 3; ok ($a == 7); ok ($b == 21); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_eq { my $a = mpz(0); my $b = $a; $a = mpz(1); ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_inc { my $a = mpz(0); ok ($a++ == 0); ok ($a == 1); } { my $a = mpz(0); ok (++$a == 1); } { my $a = mpz(0); my $b = $a; $a++; ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_ior ok ((mpz(3) | 1) == 3); ok ((mpz(3) | 4) == 7); { my $a = mpz(3); $a |= 1; ok ($a == 3); } { my $a = mpz(3); $a |= 4; ok ($a == 7); } ok ((mpz("0xAA") | mpz("0x55")) == mpz("0xFF")); #------------------------------------------------------------------------------ # GMP::Mpz::overload_lshift { my $a = mpz(7) << 1; ok ($a == 14); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_lshifteq { my $a = mpz(7); $a <<= 1; ok ($a == 14); } { my $a = mpz(7); my $b = $a; $a <<= 1; ok ($a == 14); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_mul ok (mpz(2) * 3 == 6); #------------------------------------------------------------------------------ # GMP::Mpz::overload_muleq { my $a = mpz(7); $a *= 3; ok ($a == 21); } { my $a = mpz(7); my $b = $a; $a *= 3; ok ($a == 21); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_neg ok (- mpz(0) == 0); ok (- mpz(123) == -123); ok (- mpz(-123) == 123); #------------------------------------------------------------------------------ # GMP::Mpz::overload_not if (not mpz(0)) { ok (1); } else { ok (0); } if (not mpz(123)) { ok (0); } else { ok (1); } ok ((! mpz(0)) == 1); ok ((! mpz(123)) == 0); #------------------------------------------------------------------------------ # GMP::Mpz::overload_pow ok (mpz(0) ** 1 == 0); ok (mpz(1) ** 1 == 1); ok (mpz(2) ** 0 == 1); ok (mpz(2) ** 1 == 2); ok (mpz(2) ** 2 == 4); ok (mpz(2) ** 3 == 8); ok (mpz(2) ** 4 == 16); ok (mpz(0) ** mpz(1) == 0); ok (mpz(1) ** mpz(1) == 1); ok (mpz(2) ** mpz(0) == 1); ok (mpz(2) ** mpz(1) == 2); ok (mpz(2) ** mpz(2) == 4); ok (mpz(2) ** mpz(3) == 8); ok (mpz(2) ** mpz(4) == 16); #------------------------------------------------------------------------------ # GMP::Mpz::overload_poweq { my $a = mpz(3); $a **= 4; ok ($a == 81); } { my $a = mpz(3); my $b = $a; $a **= 4; ok ($a == 81); ok ($b == 3); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_rem ok (mpz(-8) % 3 == -2); ok (mpz(-7) % 3 == -1); ok (mpz(-6) % 3 == 0); ok (mpz(6) % 3 == 0); ok (mpz(7) % 3 == 1); ok (mpz(8) % 3 == 2); { my $a = mpz(24); $a %= 7; ok ($a == 3); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_rshift { my $a = mpz(32) >> 1; ok ($a == 16); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_rshifteq { my $a = mpz(32); $a >>= 1; ok ($a == 16); } { my $a = mpz(32); my $b = $a; $a >>= 1; ok ($a == 16); ok ($b == 32); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_spaceship ok (mpz(0) < 1); ok (mpz(0) > -1); ok (mpz(0) != 1); ok (mpz(0) != -1); ok (mpz(1) != 0); ok (mpz(1) != -1); ok (mpz(-1) != 0); ok (mpz(-1) != 1); ok (mpz(0) < 1.0); ok (mpz(0) < '1'); ok (mpz(0) < substr('-1',1,1)); ok (mpz(0) < mpz(1)); ok (mpz(0) < mpq(1)); ok (mpz(0) < mpf(1)); ok (mpz(0) < $uv_max); #------------------------------------------------------------------------------ # GMP::Mpz::overload_sqrt ok (sqrt(mpz(0)) == 0); ok (sqrt(mpz(1)) == 1); ok (sqrt(mpz(4)) == 2); ok (sqrt(mpz(81)) == 9); #------------------------------------------------------------------------------ # GMP::Mpz::overload_string { my $x = mpz(0); ok("$x" eq "0"); } { my $x = mpz(123); ok("$x" eq "123"); } { my $x = mpz(-123); ok("$x" eq "-123"); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_sub ok (mpz(0) - 1 == -1); ok (mpz(1) - 1 == 0); ok (1 - mpz(0) == 1); ok (1 - mpz(1) == 0); #------------------------------------------------------------------------------ # GMP::Mpz::overload_subeq { my $a = mpz(7); $a -= 1; ok ($a == 6); } { my $a = mpz(7); my $b = $a; $a -= 1; ok ($a == 6); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpz::overload_xor ok ((mpz(3) ^ 1) == 2); ok ((mpz(3) ^ 4) == 7); { my $a = mpz(3); $a ^= 1; ok ($a == 2); } { my $a = mpz(3); $a ^= 4; ok ($a == 7); } #------------------------------------------------------------------------------ # GMP::Mpz::bin ok (bin(2,0) == 1); ok (bin(2,1) == 2); ok (bin(2,2) == 1); ok (bin(3,0) == 1); ok (bin(3,1) == 3); ok (bin(3,2) == 3); ok (bin(3,3) == 1); #------------------------------------------------------------------------------ # GMP::Mpz::cdiv { my ($q, $r); ($q, $r) = cdiv (16, 3); ok ($q == 6); ok ($r == -2); ($q, $r) = cdiv (16, -3); ok ($q == -5); ok ($r == 1); ($q, $r) = cdiv (-16, 3); ok ($q == -5); ok ($r == -1); ($q, $r) = cdiv (-16, -3); ok ($q == 6); ok ($r == 2); } #------------------------------------------------------------------------------ # GMP::Mpz::cdiv_2exp { my ($q, $r); ($q, $r) = cdiv_2exp (23, 2); ok ($q == 6); ok ($r == -1); ($q, $r) = cdiv_2exp (-23, 2); ok ($q == -5); ok ($r == -3); } #------------------------------------------------------------------------------ # GMP::Mpz::clrbit { my $a = mpz(3); clrbit ($a, 1); ok ($a == 1); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = mpz(3); clrbit ($a, 2); ok ($a == 3); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = 3; clrbit ($a, 1); ok ($a == 1); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = 3; clrbit ($a, 2); ok ($a == 3); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } # mutate only given variable { my $a = mpz(3); my $b = $a; clrbit ($a, 0); ok ($a == 2); ok ($b == 3); } { my $a = 3; my $b = $a; clrbit ($a, 0); ok ($a == 2); ok ($b == 3); } { tie my $a, 'Mytie', mpz(3); clrbit ($a, 1); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 1); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { tie my $a, 'Mytie', 3; clrbit ($a, 1); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 1); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { my $b = mpz(3); tie my $a, 'Mytie', $b; clrbit ($a, 0); ok ($a == 2); ok ($b == 3); ok (tied($a)); } { my $b = 3; tie my $a, 'Mytie', $b; clrbit ($a, 0); ok ($a == 2); ok ($b == 3); ok (tied($a)); } #------------------------------------------------------------------------------ # GMP::Mpz::combit { my $a = mpz(3); combit ($a, 1); ok ($a == 1); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = mpz(3); combit ($a, 2); ok ($a == 7); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = 3; combit ($a, 1); ok ($a == 1); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } { my $a = 3; combit ($a, 2); ok ($a == 7); ok (UNIVERSAL::isa($a,"GMP::Mpz")); } # mutate only given variable { my $a = mpz(3); my $b = $a; combit ($a, 0); ok ($a == 2); ok ($b == 3); } { my $a = 3; my $b = $a; combit ($a, 0); ok ($a == 2); ok ($b == 3); } { tie my $a, 'Mytie', mpz(3); combit ($a, 2); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 7); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { tie my $a, 'Mytie', 3; combit ($a, 2); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 7); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { my $b = mpz(3); tie my $a, 'Mytie', $b; combit ($a, 0); ok ($a == 2); ok ($b == 3); ok (tied($a)); } { my $b = 3; tie my $a, 'Mytie', $b; combit ($a, 0); ok ($a == 2); ok ($b == 3); ok (tied($a)); } #------------------------------------------------------------------------------ # GMP::Mpz::congruent_p ok ( congruent_p (21, 0, 7)); ok (! congruent_p (21, 1, 7)); ok ( congruent_p (21, 5, 8)); ok (! congruent_p (21, 6, 8)); #------------------------------------------------------------------------------ # GMP::Mpz::congruent_2exp_p ok ( congruent_2exp_p (20, 0, 2)); ok (! congruent_2exp_p (21, 0, 2)); ok (! congruent_2exp_p (20, 1, 2)); #------------------------------------------------------------------------------ # GMP::Mpz::divexact ok (divexact(27,3) == 9); ok (divexact(27,-3) == -9); ok (divexact(-27,3) == -9); ok (divexact(-27,-3) == 9); #------------------------------------------------------------------------------ # GMP::Mpz::divisible_p ok ( divisible_p (21, 7)); ok (! divisible_p (21, 8)); #------------------------------------------------------------------------------ # GMP::Mpz::divisible_2exp_p ok ( divisible_2exp_p (20, 2)); ok (! divisible_2exp_p (21, 2)); #------------------------------------------------------------------------------ # GMP::Mpz::even_p ok (! even_p(mpz(-3))); ok ( even_p(mpz(-2))); ok (! even_p(mpz(-1))); ok ( even_p(mpz(0))); ok (! even_p(mpz(1))); ok ( even_p(mpz(2))); ok (! even_p(mpz(3))); #------------------------------------------------------------------------------ # GMP::Mpz::export { my $s = mpz_export (1, 2, 1, 0, "0x61626364"); ok ($s eq 'abcd'); } { my $s = mpz_export (-1, 2, 1, 0, "0x61626364"); ok ($s eq 'cdab'); } { my $s = mpz_export (1, 2, -1, 0, "0x61626364"); ok ($s eq 'badc'); } { my $s = mpz_export (-1, 2, -1, 0, "0x61626364"); ok ($s eq 'dcba'); } #------------------------------------------------------------------------------ # GMP::Mpz::fac ok (fac(0) == 1); ok (fac(1) == 1); ok (fac(2) == 2); ok (fac(3) == 6); ok (fac(4) == 24); ok (fac(5) == 120); #------------------------------------------------------------------------------ # GMP::Mpz::fdiv { my ($q, $r); ($q, $r) = fdiv (16, 3); ok ($q == 5); ok ($r == 1); ($q, $r) = fdiv (16, -3); ok ($q == -6); ok ($r == -2); ($q, $r) = fdiv (-16, 3); ok ($q == -6); ok ($r == 2); ($q, $r) = fdiv (-16, -3); ok ($q == 5); ok ($r == -1); } #------------------------------------------------------------------------------ # GMP::Mpz::fdiv_2exp { my ($q, $r); ($q, $r) = fdiv_2exp (23, 2); ok ($q == 5); ok ($r == 3); ($q, $r) = fdiv_2exp (-23, 2); ok ($q == -6); ok ($r == 1); } #------------------------------------------------------------------------------ # GMP::Mpz::fib ok (fib(0) == 0); ok (fib(1) == 1); ok (fib(2) == 1); ok (fib(3) == 2); ok (fib(4) == 3); ok (fib(5) == 5); ok (fib(6) == 8); #------------------------------------------------------------------------------ # GMP::Mpz::fib2 { my ($a, $b) = fib2(0); ok($a==0); ok($b==1); } { my ($a, $b) = fib2(1); ok($a==1); ok($b==0); } { my ($a, $b) = fib2(2); ok($a==1); ok($b==1); } { my ($a, $b) = fib2(3); ok($a==2); ok($b==1); } { my ($a, $b) = fib2(4); ok($a==3); ok($b==2); } { my ($a, $b) = fib2(5); ok($a==5); ok($b==3); } { my ($a, $b) = fib2(6); ok($a==8); ok($b==5); } #------------------------------------------------------------------------------ # GMP::Mpz::gcd ok (gcd (21) == 21); ok (gcd (21,15) == 3); ok (gcd (21,15,30,57) == 3); ok (gcd (21,-15) == 3); ok (gcd (-21,15) == 3); ok (gcd (-21,-15) == 3); #------------------------------------------------------------------------------ # GMP::Mpz::gcdext { my ($g, $x, $y) = gcdext (3,5); ok ($g == 1); ok ($x == 2); ok ($y == -1); } #------------------------------------------------------------------------------ # GMP::Mpz::hamdist ok (hamdist(5,7) == 1); #------------------------------------------------------------------------------ # GMP::Mpz::import { my $z = mpz_import (1, 2, 1, 0, 'abcd'); ok ($z == 0x61626364); } { my $z = mpz_import (-1, 2, 1, 0, 'abcd'); ok ($z == 0x63646162); } { my $z = mpz_import (1, 2, -1, 0, 'abcd'); ok ($z == 0x62616463); } { my $z = mpz_import (-1, 2, -1, 0, 'abcd'); ok ($z == 0x64636261); } #------------------------------------------------------------------------------ # GMP::Mpz::invert ok (invert(1,123) == 1); ok (invert(6,7) == 6); ok (! defined invert(2,8)); #------------------------------------------------------------------------------ # GMP::Mpz::jacobi, GMP::Mpz::kronecker foreach my $i ([ 1, 19, 1 ], [ 4, 19, 1 ], [ 5, 19, 1 ], [ 6, 19, 1 ], [ 7, 19, 1 ], [ 9, 19, 1 ], [ 11, 19, 1 ], [ 16, 19, 1 ], [ 17, 19, 1 ], [ 2, 19, -1 ], [ 3, 19, -1 ], [ 8, 19, -1 ], [ 10, 19, -1 ], [ 12, 19, -1 ], [ 13, 19, -1 ], [ 14, 19, -1 ], [ 15, 19, -1 ], [ 18, 19, -1 ]) { foreach my $fun (\&jacobi, \&kronecker) { ok (&$fun ($$i[0], $$i[1]) == $$i[2]); ok (&$fun ($$i[0], str($$i[1])) == $$i[2]); ok (&$fun (str($$i[0]), $$i[1]) == $$i[2]); ok (&$fun (str($$i[0]), str($$i[1])) == $$i[2]); ok (&$fun ($$i[0], mpz($$i[1])) == $$i[2]); ok (&$fun (mpz($$i[0]), $$i[1]) == $$i[2]); ok (&$fun (mpz($$i[0]), mpz($$i[1])) == $$i[2]); } } #------------------------------------------------------------------------------ # GMP::Mpz::lcm ok (lcm (2) == 2); ok (lcm (0) == 0); ok (lcm (0,0) == 0); ok (lcm (0,0,0) == 0); ok (lcm (0,0,0,0) == 0); ok (lcm (2,0) == 0); ok (lcm (-2,0) == 0); ok (lcm (2,3) == 6); ok (lcm (2,3,4) == 12); ok (lcm (2,-3) == 6); ok (lcm (-2,3) == 6); ok (lcm (-2,-3) == 6); ok (lcm (mpz(2)**512,1) == mpz(2)**512); ok (lcm (mpz(2)**512,-1) == mpz(2)**512); ok (lcm (-mpz(2)**512,1) == mpz(2)**512); ok (lcm (-mpz(2)**512,-1) == mpz(2)**512); ok (lcm (mpz(2)**512,mpz(2)**512) == mpz(2)**512); ok (lcm (mpz(2)**512,-mpz(2)**512) == mpz(2)**512); ok (lcm (-mpz(2)**512,mpz(2)**512) == mpz(2)**512); ok (lcm (-mpz(2)**512,-mpz(2)**512) == mpz(2)**512); #------------------------------------------------------------------------------ # GMP::Mpz::lucnum ok (lucnum(0) == 2); ok (lucnum(1) == 1); ok (lucnum(2) == 3); ok (lucnum(3) == 4); ok (lucnum(4) == 7); ok (lucnum(5) == 11); ok (lucnum(6) == 18); #------------------------------------------------------------------------------ # GMP::Mpz::lucnum2 { my ($a, $b) = lucnum2(0); ok($a==2); ok($b==-1); } { my ($a, $b) = lucnum2(1); ok($a==1); ok($b==2); } { my ($a, $b) = lucnum2(2); ok($a==3); ok($b==1); } { my ($a, $b) = lucnum2(3); ok($a==4); ok($b==3); } { my ($a, $b) = lucnum2(4); ok($a==7); ok($b==4); } { my ($a, $b) = lucnum2(5); ok($a==11); ok($b==7); } { my ($a, $b) = lucnum2(6); ok($a==18); ok($b==11); } #------------------------------------------------------------------------------ # GMP::Mpz::nextprime ok (nextprime(2) == 3); ok (nextprime(3) == 5); ok (nextprime(5) == 7); ok (nextprime(7) == 11); ok (nextprime(11) == 13); #------------------------------------------------------------------------------ # GMP::Mpz::perfect_power_p # ok ( perfect_power_p(mpz(-27))); # ok (! perfect_power_p(mpz(-9))); # ok (! perfect_power_p(mpz(-1))); ok ( perfect_power_p(mpz(0))); ok ( perfect_power_p(mpz(1))); ok (! perfect_power_p(mpz(2))); ok (! perfect_power_p(mpz(3))); ok ( perfect_power_p(mpz(4))); ok ( perfect_power_p(mpz(9))); ok ( perfect_power_p(mpz(27))); ok ( perfect_power_p(mpz(81))); #------------------------------------------------------------------------------ # GMP::Mpz::perfect_square_p ok (! perfect_square_p(mpz(-9))); ok (! perfect_square_p(mpz(-1))); ok ( perfect_square_p(mpz(0))); ok ( perfect_square_p(mpz(1))); ok (! perfect_square_p(mpz(2))); ok (! perfect_square_p(mpz(3))); ok ( perfect_square_p(mpz(4))); ok ( perfect_square_p(mpz(9))); ok (! perfect_square_p(mpz(27))); ok ( perfect_square_p(mpz(81))); #------------------------------------------------------------------------------ # GMP::Mpz::popcount ok (popcount(7) == 3); #------------------------------------------------------------------------------ # GMP::Mpz::powm ok (powm (3,2,8) == 1); #------------------------------------------------------------------------------ # GMP::Mpz::probab_prime_p ok ( probab_prime_p(89,1)); ok (! probab_prime_p(81,1)); #------------------------------------------------------------------------------ # GMP::Mpz::realloc { my $z = mpz(123); realloc ($z, 512); } #------------------------------------------------------------------------------ # GMP::Mpz::remove { my ($rem, $mult); ($rem, $mult) = remove(12,3); ok ($rem == 4); ok ($mult == 1); ($rem, $mult) = remove(12,2); ok ($rem == 3); ok ($mult == 2); } #------------------------------------------------------------------------------ # GMP::Mpz::root ok (root(0,2) == 0); ok (root(8,3) == 2); ok (root(-8,3) == -2); ok (root(81,4) == 3); ok (root(243,5) == 3); #------------------------------------------------------------------------------ # GMP::Mpz::roote { my ($r,$e); ($r, $e) = roote(0,2); ok ($r == 0); ok ($e); ($r, $e) = roote(81,4); ok ($r == 3); ok ($e); ($r, $e) = roote(85,4); ok ($r == 3); ok (! $e); } #------------------------------------------------------------------------------ # GMP::Mpz::rootrem { my ($root, $rem) = rootrem (mpz(0), 1); ok ($root == 0); ok ($rem == 0); } { my ($root, $rem) = rootrem (mpz(0), 2); ok ($root == 0); ok ($rem == 0); } { my ($root, $rem) = rootrem (mpz(64), 2); ok ($root == 8); ok ($rem == 0); } { my ($root, $rem) = rootrem (mpz(64), 3); ok ($root == 4); ok ($rem == 0); } { my ($root, $rem) = rootrem (mpz(65), 3); ok ($root == 4); ok ($rem == 1); } #------------------------------------------------------------------------------ # GMP::Mpz::scan0 ok (scan0 (0, 0) == 0); ok (scan0 (1, 0) == 1); ok (scan0 (3, 0) == 2); ok (scan0 (-1, 0) == ~0); ok (scan0 (-2, 1) == ~0); #------------------------------------------------------------------------------ # GMP::Mpz::scan1 ok (scan1 (1, 0) == 0); ok (scan1 (2, 0) == 1); ok (scan1 (4, 0) == 2); ok (scan1 (0, 0) == ~0); ok (scan1 (3, 2) == ~0); #------------------------------------------------------------------------------ # GMP::Mpz::setbit { my $a = mpz(3); setbit ($a, 1); ok ($a == 3); } { my $a = mpz(3); setbit ($a, 2); ok ($a == 7); } { my $a = 3; setbit ($a, 1); ok ($a == 3); } { my $a = 3; setbit ($a, 2); ok ($a == 7); } # mutate only given variable { my $a = mpz(0); my $b = $a; setbit ($a, 0); ok ($a == 1); ok ($b == 0); } { my $a = 0; my $b = $a; setbit ($a, 0); ok ($a == 1); ok ($b == 0); } { tie my $a, 'Mytie', mpz(3); setbit ($a, 2); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 7); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { tie my $a, 'Mytie', 3; setbit ($a, 2); ok ($Mytie::fetched > 0); # used fetch ok ($Mytie::stored > 0); # used store ok ($a == 7); # expected result ok (UNIVERSAL::isa($a,"GMP::Mpz")); ok (tied($a)); # still tied } { my $b = mpz(2); tie my $a, 'Mytie', $b; setbit ($a, 0); ok ($a == 3); ok ($b == 2); ok (tied($a)); } { my $b = 2; tie my $a, 'Mytie', $b; setbit ($a, 0); ok ($a == 3); ok ($b == 2); ok (tied($a)); } #------------------------------------------------------------------------------ # GMP::Mpz::sizeinbase ok (sizeinbase(1,10) == 1); ok (sizeinbase(100,10) == 3); ok (sizeinbase(9999,10) == 5); #------------------------------------------------------------------------------ # GMP::Mpz::sqrtrem { my ($root, $rem) = sqrtrem(mpz(0)); ok ($root == 0); ok ($rem == 0); } { my ($root, $rem) = sqrtrem(mpz(1)); ok ($root == 1); ok ($rem == 0); } { my ($root, $rem) = sqrtrem(mpz(2)); ok ($root == 1); ok ($rem == 1); } { my ($root, $rem) = sqrtrem(mpz(9)); ok ($root == 3); ok ($rem == 0); } { my ($root, $rem) = sqrtrem(mpz(35)); ok ($root == 5); ok ($rem == 10); } { my ($root, $rem) = sqrtrem(mpz(0)); ok ($root == 0); ok ($rem == 0); } #------------------------------------------------------------------------------ # GMP::Mpz::tdiv { my ($q, $r); ($q, $r) = tdiv (16, 3); ok ($q == 5); ok ($r == 1); ($q, $r) = tdiv (16, -3); ok ($q == -5); ok ($r == 1); ($q, $r) = tdiv (-16, 3); ok ($q == -5); ok ($r == -1); ($q, $r) = tdiv (-16, -3); ok ($q == 5); ok ($r == -1); } #------------------------------------------------------------------------------ # GMP::Mpz::tdiv_2exp { my ($q, $r); ($q, $r) = tdiv_2exp (23, 2); ok ($q == 5); ok ($r == 3); ($q, $r) = tdiv_2exp (-23, 2); ok ($q == -5); ok ($r == -3); } #------------------------------------------------------------------------------ # GMP::Mpz::tstbit ok (tstbit (6, 0) == 0); ok (tstbit (6, 1) == 1); ok (tstbit (6, 2) == 1); ok (tstbit (6, 3) == 0); #------------------------------------------------------------------------------ # GMP::Mpq #------------------------------------------------------------------------------ # GMP::Mpq::new ok (mpq(0) == 0); ok (mpq('0') == 0); ok (mpq(substr('101',1,1)) == 0); ok (mpq(0.0) == 0); ok (mpq(mpz(0)) == 0); ok (mpq(mpq(0)) == 0); ok (mpq(mpf(0)) == 0); { tie my $t, 'Mytie', 0; ok (mpq($t) == 0); } { tie my $t, 'Mytie', '0'; ok (mpq($t) == 0); } { tie my $t, 'Mytie', substr('101',1,1); ok (mpq($t) == 0); } { tie my $t, 'Mytie', 0.0; ok (mpq($t) == 0); } { tie my $t, 'Mytie', mpz(0); ok (mpq($t) == 0); } { tie my $t, 'Mytie', mpq(0); ok (mpq($t) == 0); } { tie my $t, 'Mytie', mpf(0); ok (mpq($t) == 0); } ok (mpq(-123) == -123); ok (mpq('-123') == -123); ok (mpq(substr('1-1231',1,4)) == -123); ok (mpq(-123.0) == -123); ok (mpq(mpz(-123)) == -123); ok (mpq(mpq(-123)) == -123); ok (mpq(mpf(-123)) == -123); { tie my $t, 'Mytie', -123; ok (mpq($t) == -123); } { tie my $t, 'Mytie', '-123'; ok (mpq($t) == -123); } { tie my $t, 'Mytie', substr('1-1231',1,4); ok (mpq($t) == -123); } { tie my $t, 'Mytie', -123.0; ok (mpq($t) == -123); } { tie my $t, 'Mytie', mpz(-123); ok (mpq($t) == -123); } { tie my $t, 'Mytie', mpq(-123); ok (mpq($t) == -123); } { tie my $t, 'Mytie', mpf(-123); ok (mpq($t) == -123); } ok (mpq($ivnv_2p128) == $str_2p128); { tie my $t, 'Mytie', $ivnv_2p128; ok (mpq($t) == $str_2p128); } ok (mpq('3/2') == mpq(3,2)); ok (mpq('3/1') == mpq(3,1)); ok (mpq('-3/2') == mpq(-3,2)); ok (mpq('-3/1') == mpq(-3,1)); ok (mpq('0x3') == mpq(3,1)); ok (mpq('0b111') == mpq(7,1)); ok (mpq('0b0') == mpq(0,1)); ok (mpq($uv_max) > 0); ok (mpq($uv_max) == mpq($uv_max_str)); { tie my $t, 'Mytie', $uv_max; ok (mpq($t) > 0); } { tie my $t, 'Mytie', $uv_max; ok (mpq($t) == mpq($uv_max_str)); } { my $x = 123.5; kill (0, $x); ok (mpq($x) == 123.5); tie my $t, 'Mytie', $x; ok (mpq($t) == 123.5); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_abs ok (abs(mpq(0)) == 0); ok (abs(mpq(123)) == 123); ok (abs(mpq(-123)) == 123); { my $x = mpq(-123); $x = abs($x); ok ($x == 123); } { my $x = mpq(0); $x = abs($x); ok ($x == 0); } { my $x = mpq(123); $x = abs($x); ok ($x == 123); } { tie my $t, 'Mytie', mpq(0); ok (abs($t) == 0); } { tie my $t, 'Mytie', mpq(123); ok (abs($t) == 123); } { tie my $t, 'Mytie', mpq(-123); ok (abs($t) == 123); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_add ok (mpq(0) + 1 == 1); ok (mpq(-1) + 1 == 0); ok (1 + mpq(0) == 1); ok (1 + mpq(-1) == 0); ok (mpq(1,2)+mpq(1,3) == mpq(5,6)); ok (mpq(1,2)+mpq(-1,3) == mpq(1,6)); ok (mpq(-1,2)+mpq(1,3) == mpq(-1,6)); ok (mpq(-1,2)+mpq(-1,3) == mpq(-5,6)); #------------------------------------------------------------------------------ # GMP::Mpq::overload_addeq { my $a = mpq(7); $a += 1; ok ($a == 8); } { my $a = mpq(7); my $b = $a; $a += 1; ok ($a == 8); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_bool if (mpq(0)) { ok (0); } else { ok (1); } if (mpq(123)) { ok (1); } else { ok (0); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_dec { my $a = mpq(0); ok ($a-- == 0); ok ($a == -1); } { my $a = mpq(0); ok (--$a == -1); } { my $a = mpq(0); my $b = $a; $a--; ok ($a == -1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_div ok (mpq(6) / 2 == 3); ok (mpq(-6) / 2 == -3); ok (mpq(6) / -2 == -3); ok (mpq(-6) / -2 == 3); #------------------------------------------------------------------------------ # GMP::Mpq::overload_diveq { my $a = mpq(21); $a /= 3; ok ($a == 7); } { my $a = mpq(21); my $b = $a; $a /= 3; ok ($a == 7); ok ($b == 21); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_eq { my $a = mpq(0); my $b = $a; $a = mpq(1); ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_inc { my $a = mpq(0); ok ($a++ == 0); ok ($a == 1); } { my $a = mpq(0); ok (++$a == 1); } { my $a = mpq(0); my $b = $a; $a++; ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_lshift { my $a = mpq(7) << 1; ok ($a == 14); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_lshifteq { my $a = mpq(7); $a <<= 1; ok ($a == 14); } { my $a = mpq(7); my $b = $a; $a <<= 1; ok ($a == 14); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_mul ok (mpq(2) * 3 == 6); #------------------------------------------------------------------------------ # GMP::Mpq::overload_muleq { my $a = mpq(7); $a *= 3; ok ($a == 21); } { my $a = mpq(7); my $b = $a; $a *= 3; ok ($a == 21); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_neg ok (- mpq(0) == 0); ok (- mpq(123) == -123); ok (- mpq(-123) == 123); #------------------------------------------------------------------------------ # GMP::Mpq::overload_not if (not mpq(0)) { ok (1); } else { ok (0); } if (not mpq(123)) { ok (0); } else { ok (1); } ok ((! mpq(0)) == 1); ok ((! mpq(123)) == 0); #------------------------------------------------------------------------------ # GMP::Mpq::overload_pow ok (mpq(0) ** 1 == 0); ok (mpq(1) ** 1 == 1); ok (mpq(2) ** 0 == 1); ok (mpq(2) ** 1 == 2); ok (mpq(2) ** 2 == 4); ok (mpq(2) ** 3 == 8); ok (mpq(2) ** 4 == 16); ok (mpq(0) ** mpq(1) == 0); ok (mpq(1) ** mpq(1) == 1); ok (mpq(2) ** mpq(0) == 1); ok (mpq(2) ** mpq(1) == 2); ok (mpq(2) ** mpq(2) == 4); ok (mpq(2) ** mpq(3) == 8); ok (mpq(2) ** mpq(4) == 16); #------------------------------------------------------------------------------ # GMP::Mpq::overload_poweq { my $a = mpq(3); $a **= 4; ok ($a == 81); } { my $a = mpq(3); my $b = $a; $a **= 4; ok ($a == 81); ok ($b == 3); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_rshift { my $a = mpq(32) >> 1; ok ($a == 16); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_rshifteq { my $a = mpq(32); $a >>= 1; ok ($a == 16); } { my $a = mpq(32); my $b = $a; $a >>= 1; ok ($a == 16); ok ($b == 32); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_spaceship ok (mpq(0) < 1); ok (mpq(0) > -1); ok (mpq(0) != 1); ok (mpq(0) != -1); ok (mpq(1) != 0); ok (mpq(1) != -1); ok (mpq(-1) != 0); ok (mpq(-1) != 1); ok (mpq(3,2) > 1); ok (mpq(3,2) < 2); ok (mpq(0) < 1.0); ok (mpq(0) < '1'); ok (mpq(0) < substr('-1',1,1)); ok (mpq(0) < mpz(1)); ok (mpq(0) < mpq(1)); ok (mpq(0) < mpf(1)); ok (mpq(0) < $uv_max); #------------------------------------------------------------------------------ # GMP::Mpq::overload_string { my $x = mpq(0); ok("$x" eq "0"); } { my $x = mpq(123); ok("$x" eq "123"); } { my $x = mpq(-123); ok("$x" eq "-123"); } { my $q = mpq(5,7); ok("$q" eq "5/7"); } { my $q = mpq(-5,7); ok("$q" eq "-5/7"); } #------------------------------------------------------------------------------ # GMP::Mpq::overload_sub ok (mpq(0) - 1 == -1); ok (mpq(1) - 1 == 0); ok (1 - mpq(0) == 1); ok (1 - mpq(1) == 0); ok (mpq(1,2)-mpq(1,3) == mpq(1,6)); ok (mpq(1,2)-mpq(-1,3) == mpq(5,6)); ok (mpq(-1,2)-mpq(1,3) == mpq(-5,6)); ok (mpq(-1,2)-mpq(-1,3) == mpq(-1,6)); #------------------------------------------------------------------------------ # GMP::Mpq::overload_subeq { my $a = mpq(7); $a -= 1; ok ($a == 6); } { my $a = mpq(7); my $b = $a; $a -= 1; ok ($a == 6); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpq::canonicalize { my $q = mpq(21,15); canonicalize($q); ok (num($q) == 7); ok (den($q) == 5); } #------------------------------------------------------------------------------ # GMP::Mpq::den { my $q = mpq(5,9); ok (den($q) == 9); } #------------------------------------------------------------------------------ # GMP::Mpq::num { my $q = mpq(5,9); ok (num($q) == 5); } #------------------------------------------------------------------------------ # GMP::Mpf #------------------------------------------------------------------------------ # GMP::Mpf::new ok (mpf(0) == 0); ok (mpf('0') == 0); ok (mpf(substr('101',1,1)) == 0); ok (mpf(0.0) == 0); ok (mpf(mpz(0)) == 0); ok (mpf(mpq(0)) == 0); ok (mpf(mpf(0)) == 0); { tie my $t, 'Mytie', 0; ok (mpf($t) == 0); } { tie my $t, 'Mytie', '0'; ok (mpf($t) == 0); } { tie my $t, 'Mytie', substr('101',1,1); ok (mpf($t) == 0); } { tie my $t, 'Mytie', 0.0; ok (mpf($t) == 0); } { tie my $t, 'Mytie', mpz(0); ok (mpf($t) == 0); } { tie my $t, 'Mytie', mpq(0); ok (mpf($t) == 0); } { tie my $t, 'Mytie', mpf(0); ok (mpf($t) == 0); } ok (mpf(-123) == -123); ok (mpf('-123') == -123); ok (mpf(substr('1-1231',1,4)) == -123); ok (mpf(-123.0) == -123); ok (mpf(mpz(-123)) == -123); ok (mpf(mpq(-123)) == -123); ok (mpf(mpf(-123)) == -123); { tie my $t, 'Mytie', -123; ok (mpf($t) == -123); } { tie my $t, 'Mytie', '-123'; ok (mpf($t) == -123); } { tie my $t, 'Mytie', substr('1-1231',1,4); ok (mpf($t) == -123); } { tie my $t, 'Mytie', -123.0; ok (mpf($t) == -123); } { tie my $t, 'Mytie', mpz(-123); ok (mpf($t) == -123); } { tie my $t, 'Mytie', mpq(-123); ok (mpf($t) == -123); } { tie my $t, 'Mytie', mpf(-123); ok (mpf($t) == -123); } ok (mpf($ivnv_2p128) == $str_2p128); { tie my $t, 'Mytie', $ivnv_2p128; ok (mpf($t) == $str_2p128); } ok (mpf(-1.5) == -1.5); ok (mpf(-1.0) == -1.0); ok (mpf(-0.5) == -0.5); ok (mpf(0) == 0); ok (mpf(0.5) == 0.5); ok (mpf(1.0) == 1.0); ok (mpf(1.5) == 1.5); ok (mpf("-1.5") == -1.5); ok (mpf("-1.0") == -1.0); ok (mpf("-0.5") == -0.5); ok (mpf("0") == 0); ok (mpf("0.5") == 0.5); ok (mpf("1.0") == 1.0); ok (mpf("1.5") == 1.5); ok (mpf($uv_max) > 0); ok (mpf($uv_max) == mpf($uv_max_str)); { tie my $t, 'Mytie', $uv_max; ok (mpf($t) > 0); } { tie my $t, 'Mytie', $uv_max; ok (mpf($t) == mpf($uv_max_str)); } { my $x = 123.5; kill (0, $x); ok (mpf($x) == 123.5); tie my $t, 'Mytie', $x; ok (mpf($t) == 123.5); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_abs ok (abs(mpf(0)) == 0); ok (abs(mpf(123)) == 123); ok (abs(mpf(-123)) == 123); { my $x = mpf(-123); $x = abs($x); ok ($x == 123); } { my $x = mpf(0); $x = abs($x); ok ($x == 0); } { my $x = mpf(123); $x = abs($x); ok ($x == 123); } { tie my $t, 'Mytie', mpf(0); ok (abs($t) == 0); } { tie my $t, 'Mytie', mpf(123); ok (abs($t) == 123); } { tie my $t, 'Mytie', mpf(-123); ok (abs($t) == 123); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_add ok (mpf(0) + 1 == 1); ok (mpf(-1) + 1 == 0); ok (1 + mpf(0) == 1); ok (1 + mpf(-1) == 0); #------------------------------------------------------------------------------ # GMP::Mpf::overload_addeq { my $a = mpf(7); $a += 1; ok ($a == 8); } { my $a = mpf(7); my $b = $a; $a += 1; ok ($a == 8); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_bool if (mpf(0)) { ok (0); } else { ok (1); } if (mpf(123)) { ok (1); } else { ok (0); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_dec { my $a = mpf(0); ok ($a-- == 0); ok ($a == -1); } { my $a = mpf(0); ok (--$a == -1); } { my $a = mpf(0); my $b = $a; $a--; ok ($a == -1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_div ok (mpf(6) / 2 == 3); ok (mpf(-6) / 2 == -3); ok (mpf(6) / -2 == -3); ok (mpf(-6) / -2 == 3); #------------------------------------------------------------------------------ # GMP::Mpf::overload_diveq { my $a = mpf(21); $a /= 3; ok ($a == 7); } { my $a = mpf(21); my $b = $a; $a /= 3; ok ($a == 7); ok ($b == 21); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_eq { my $a = mpf(0); my $b = $a; $a = mpf(1); ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_inc { my $a = mpf(0); ok ($a++ == 0); ok ($a == 1); } { my $a = mpf(0); ok (++$a == 1); } { my $a = mpf(0); my $b = $a; $a++; ok ($a == 1); ok ($b == 0); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_lshift { my $a = mpf(7) << 1; ok ($a == 14); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_lshifteq { my $a = mpf(7); $a <<= 1; ok ($a == 14); } { my $a = mpf(7); my $b = $a; $a <<= 1; ok ($a == 14); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_mul ok (mpf(2) * 3 == 6); #------------------------------------------------------------------------------ # GMP::Mpf::overload_muleq { my $a = mpf(7); $a *= 3; ok ($a == 21); } { my $a = mpf(7); my $b = $a; $a *= 3; ok ($a == 21); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_neg ok (- mpf(0) == 0); ok (- mpf(123) == -123); ok (- mpf(-123) == 123); #------------------------------------------------------------------------------ # GMP::Mpf::overload_not if (not mpf(0)) { ok (1); } else { ok (0); } if (not mpf(123)) { ok (0); } else { ok (1); } ok ((! mpf(0)) == 1); ok ((! mpf(123)) == 0); #------------------------------------------------------------------------------ # GMP::Mpf::overload_pow ok (mpf(0) ** 1 == 0); ok (mpf(1) ** 1 == 1); ok (mpf(2) ** 0 == 1); ok (mpf(2) ** 1 == 2); ok (mpf(2) ** 2 == 4); ok (mpf(2) ** 3 == 8); ok (mpf(2) ** 4 == 16); ok (mpf(0) ** mpf(1) == 0); ok (mpf(1) ** mpf(1) == 1); ok (mpf(2) ** mpf(0) == 1); ok (mpf(2) ** mpf(1) == 2); ok (mpf(2) ** mpf(2) == 4); ok (mpf(2) ** mpf(3) == 8); ok (mpf(2) ** mpf(4) == 16); #------------------------------------------------------------------------------ # GMP::Mpf::overload_poweq { my $a = mpf(3); $a **= 4; ok ($a == 81); } { my $a = mpf(3); my $b = $a; $a **= 4; ok ($a == 81); ok ($b == 3); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_rshift { my $a = mpf(32) >> 1; ok ($a == 16); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_rshifteq { my $a = mpf(32); $a >>= 1; ok ($a == 16); } { my $a = mpf(32); my $b = $a; $a >>= 1; ok ($a == 16); ok ($b == 32); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_sqrt ok (sqrt(mpf(0)) == 0); ok (sqrt(mpf(1)) == 1); ok (sqrt(mpf(4)) == 2); ok (sqrt(mpf(81)) == 9); ok (sqrt(mpf(0.25)) == 0.5); #------------------------------------------------------------------------------ # GMP::Mpf::overload_spaceship ok (mpf(0) < 1); ok (mpf(0) > -1); ok (mpf(0) != 1); ok (mpf(0) != -1); ok (mpf(1) != 0); ok (mpf(1) != -1); ok (mpf(-1) != 0); ok (mpf(-1) != 1); ok (mpf(0) < 1.0); ok (mpf(0) < '1'); ok (mpf(0) < substr('-1',1,1)); ok (mpf(0) < mpz(1)); ok (mpf(0) < mpq(1)); ok (mpf(0) < mpf(1)); ok (mpf(0) < $uv_max); #------------------------------------------------------------------------------ # GMP::Mpf::overload_string { my $x = mpf(0); ok ("$x" eq "0"); } { my $x = mpf(123); ok ("$x" eq "123"); } { my $x = mpf(-123); ok ("$x" eq "-123"); } { my $f = mpf(0.25); ok ("$f" eq "0.25"); } { my $f = mpf(-0.25); ok ("$f" eq "-0.25"); } { my $f = mpf(1.25); ok ("$f" eq "1.25"); } { my $f = mpf(-1.25); ok ("$f" eq "-1.25"); } { my $f = mpf(1000000); ok ("$f" eq "1000000"); } { my $f = mpf(-1000000); ok ("$f" eq "-1000000"); } #------------------------------------------------------------------------------ # GMP::Mpf::overload_sub ok (mpf(0) - 1 == -1); ok (mpf(1) - 1 == 0); ok (1 - mpf(0) == 1); ok (1 - mpf(1) == 0); #------------------------------------------------------------------------------ # GMP::Mpf::overload_subeq { my $a = mpf(7); $a -= 1; ok ($a == 6); } { my $a = mpf(7); my $b = $a; $a -= 1; ok ($a == 6); ok ($b == 7); } #------------------------------------------------------------------------------ # GMP::Mpf::ceil ok (ceil (mpf(-7.5)) == -7.0); ok (ceil (mpf(7.5)) == 8.0); #------------------------------------------------------------------------------ # GMP::Mpf::floor ok (floor(mpf(-7.5)) == -8.0); ok (floor(mpf(7.5)) == 7.0); #------------------------------------------------------------------------------ # GMP::Mpf::mpf_eq { my $old_prec = get_default_prec(); set_default_prec(128); ok ( mpf_eq (mpz("0x10000000000000001"), mpz("0x10000000000000002"), 1)); ok (! mpf_eq (mpz("0x11"), mpz("0x12"), 128)); set_default_prec($old_prec); } #------------------------------------------------------------------------------ # GMP::Mpf::get_default_prec get_default_prec(); #------------------------------------------------------------------------------ # GMP::Mpf::get_prec { my $x = mpf(1.0, 512); ok (get_prec ($x) == 512); } #------------------------------------------------------------------------------ # GMP::Mpf::reldiff ok (reldiff (2,4) == 1); ok (reldiff (4,2) == 0.5); #------------------------------------------------------------------------------ # GMP::Mpf::set_default_prec { my $old_prec = get_default_prec(); set_default_prec(512); ok (get_default_prec () == 512); set_default_prec($old_prec); } #------------------------------------------------------------------------------ # GMP::Mpf::set_prec { my $x = mpf(1.0, 512); my $y = $x; set_prec ($x, 1024); ok (get_prec ($x) == 1024); ok (get_prec ($y) == 512); } #------------------------------------------------------------------------------ # GMP::Mpf::trunc ok (trunc(mpf(-7.5)) == -7.0); ok (trunc(mpf(7.5)) == 7.0); #------------------------------------------------------------------------------ # GMP::Rand #------------------------------------------------------------------------------ # GMP::Rand::new { my $r = randstate(); ok (defined $r); } { my $r = randstate('lc_2exp', 1, 2, 3); ok (defined $r); } { my $r = randstate('lc_2exp_size', 64); ok (defined $r); } { my $r = randstate('lc_2exp_size', 999999999); ok (! defined $r); } { my $r = randstate('mt'); ok (defined $r); } { # copying a randstate results in same sequence my $r1 = randstate('lc_2exp_size', 64); $r1->seed(123); my $r2 = randstate($r1); for (1 .. 20) { my $z1 = mpz_urandomb($r1, 20); my $z2 = mpz_urandomb($r2, 20); ok ($z1 == $z2); } } #------------------------------------------------------------------------------ # GMP::Rand::seed { my $r = randstate(); $r->seed(123); $r->seed(time()); } #------------------------------------------------------------------------------ # GMP::Rand::mpf_urandomb { my $r = randstate(); my $f = mpf_urandomb($r,1024); ok (UNIVERSAL::isa($f,"GMP::Mpf")); } #------------------------------------------------------------------------------ # GMP::Rand::mpz_urandomb { my $r = randstate(); my $z = mpz_urandomb($r, 1024); ok (UNIVERSAL::isa($z,"GMP::Mpz")); } #------------------------------------------------------------------------------ # GMP::Rand::mpz_rrandomb { my $r = randstate(); my $z = mpz_rrandomb($r, 1024); ok (UNIVERSAL::isa($z,"GMP::Mpz")); } #------------------------------------------------------------------------------ # GMP::Rand::mpz_urandomm { my $r = randstate(); my $z = mpz_urandomm($r, mpz(3)**100); ok (UNIVERSAL::isa($z,"GMP::Mpz")); } #------------------------------------------------------------------------------ # GMP::Rand::mpz_urandomb_ui { my $r = randstate(); foreach (1 .. 20) { my $u = gmp_urandomb_ui($r,8); ok ($u >= 0); ok ($u < 256); } } #------------------------------------------------------------------------------ # GMP::Rand::mpz_urandomm_ui { my $r = randstate(); foreach (1 .. 20) { my $u = gmp_urandomm_ui($r,8); ok ($u >= 0); ok ($u < 8); } } #------------------------------------------------------------------------------ # GMP module #------------------------------------------------------------------------------ # GMP::fits_slong_p ok (GMP::fits_slong_p(0)); # in perl 5.005 uv_max is only 32-bits on a 64-bit system, so won't exceed a # long # ok (! GMP::fits_slong_p($uv_max)); ok (GMP::fits_slong_p(0.0)); ok (GMP::fits_slong_p('0')); ok (GMP::fits_slong_p(substr('999999999999999999999999999999',1,1))); ok (! mpz("-9999999999999999999999999999999999999999999")->fits_slong_p()); ok ( mpz(-123)->fits_slong_p()); ok ( mpz(0)->fits_slong_p()); ok ( mpz(123)->fits_slong_p()); ok (! mpz("9999999999999999999999999999999999999999999")->fits_slong_p()); ok (! mpq("-9999999999999999999999999999999999999999999")->fits_slong_p()); ok ( mpq(-123)->fits_slong_p()); ok ( mpq(0)->fits_slong_p()); ok ( mpq(123)->fits_slong_p()); ok (! mpq("9999999999999999999999999999999999999999999")->fits_slong_p()); ok (! mpf("-9999999999999999999999999999999999999999999")->fits_slong_p()); ok ( mpf(-123)->fits_slong_p()); ok ( mpf(0)->fits_slong_p()); ok ( mpf(123)->fits_slong_p()); ok (! mpf("9999999999999999999999999999999999999999999")->fits_slong_p()); #------------------------------------------------------------------------------ # GMP::get_d ok (GMP::get_d(123) == 123.0); ok (GMP::get_d($uv_max) > 0); ok (GMP::get_d(123.0) == 123.0); ok (GMP::get_d('123') == 123.0); ok (GMP::get_d(mpz(123)) == 123.0); ok (GMP::get_d(mpq(123)) == 123.0); ok (GMP::get_d(mpf(123)) == 123.0); #------------------------------------------------------------------------------ # GMP::get_d_2exp { my ($dbl, $exp) = get_d_2exp (0); ok ($dbl == 0); ok ($exp == 0); } { my ($dbl, $exp) = get_d_2exp (1); ok ($dbl == 0.5); ok ($exp == 1); } { my ($dbl, $exp) = get_d_2exp ($uv_max); ok ($dbl > 0.0); ok ($exp > 0); } { my ($dbl, $exp) = get_d_2exp (0.5); ok ($dbl == 0.5); ok ($exp == 0); } { my ($dbl, $exp) = get_d_2exp (0.25); ok ($dbl == 0.5); ok ($exp == -1); } { my ($dbl, $exp) = get_d_2exp ("1.0"); ok ($dbl == 0.5); ok ($exp == 1); } { my ($dbl, $exp) = get_d_2exp (mpz ("256")); ok ($dbl == 0.5); ok ($exp == 9); } { my ($dbl, $exp) = get_d_2exp (mpq ("1/16")); ok ($dbl == 0.5); ok ($exp == -3); } { my ($dbl, $exp) = get_d_2exp (mpf ("1.5")); ok ($dbl == 0.75); ok ($exp == 1); } { my ($dbl, $exp) = get_d_2exp (mpf ("3.0")); ok ($dbl == 0.75); ok ($exp == 2); } #------------------------------------------------------------------------------ # GMP::get_str ok (get_str(-123) eq '-123'); ok (get_str('-123') eq '-123'); ok (get_str(substr('x-123x',1,4)) eq '-123'); ok (get_str(mpz(-123)) eq '-123'); ok (get_str(mpq(-123)) eq '-123'); ok (get_str(-123,10) eq '-123'); ok (get_str('-123',10) eq '-123'); ok (get_str(substr('x-123x',1,4),10) eq '-123'); ok (get_str(mpz(-123),10) eq '-123'); ok (get_str(mpq(-123),10) eq '-123'); ok (get_str(-123,16) eq '-7b'); ok (get_str('-123',16) eq '-7b'); ok (get_str(substr('x-123x',1,4),16) eq '-7b'); ok (get_str(mpz(-123),16) eq '-7b'); ok (get_str(mpq(-123),16) eq '-7b'); ok (get_str(-123,-16) eq '-7B'); ok (get_str('-123',-16) eq '-7B'); ok (get_str(substr('x-123x',1,4),-16) eq '-7B'); ok (get_str(mpz(-123),-16) eq '-7B'); ok (get_str(mpq(-123),-16) eq '-7B'); # is a float in past versions of perl without UV type { my ($str, $exp) = get_str($uv_max); ok ($str eq $uv_max_str); } ok (get_str(mpq(5/8)) eq "5/8"); ok (get_str(mpq(-5/8)) eq "-5/8"); ok (get_str(mpq(255/256),16) eq "ff/100"); ok (get_str(mpq(255/256),-16) eq "FF/100"); ok (get_str(mpq(-255/256),16) eq "-ff/100"); ok (get_str(mpq(-255/256),-16) eq "-FF/100"); { my ($s,$e) = get_str(1.5, 10); ok ($s eq '15'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(1.5), 10); ok ($s eq '15'); ok ($e == 1); } { my ($s,$e) = get_str(-1.5, 10); ok ($s eq '-15'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(-1.5), 10); ok ($s eq '-15'); ok ($e == 1); } { my ($s,$e) = get_str(1.5, 16); ok ($s eq '18'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(1.5), 16); ok ($s eq '18'); ok ($e == 1); } { my ($s,$e) = get_str(-1.5, 16); ok ($s eq '-18'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(-1.5), 16); ok ($s eq '-18'); ok ($e == 1); } { my ($s,$e) = get_str(65536.0, 16); ok ($s eq '1'); ok ($e == 5); } { my ($s,$e) = get_str(mpf(65536.0), 16); ok ($s eq '1'); ok ($e == 5); } { my ($s,$e) = get_str(1.625, 16); ok ($s eq '1a'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(1.625), 16); ok ($s eq '1a'); ok ($e == 1); } { my ($s,$e) = get_str(1.625, -16); ok ($s eq '1A'); ok ($e == 1); } { my ($s,$e) = get_str(mpf(1.625), -16); ok ($s eq '1A'); ok ($e == 1); } { my ($s, $e) = get_str(255.0,16,0); ok ($s eq "ff"); ok ($e == 2); } { my ($s, $e) = get_str(mpf(255.0),16,0); ok ($s eq "ff"); ok ($e == 2); } { my ($s, $e) = get_str(255.0,-16,0); ok ($s eq "FF"); ok ($e == 2); } { my ($s, $e) = get_str(mpf(255.0),-16,0); ok ($s eq "FF"); ok ($e == 2); } #------------------------------------------------------------------------------ # GMP::get_si ok (GMP::get_si(123) == 123.0); # better not assume anything about the relatives sizes of long and UV ok (GMP::get_si($uv_max) != 0); ok (GMP::get_si(123.0) == 123.0); ok (GMP::get_si('123') == 123.0); ok (GMP::get_si(mpz(123)) == 123.0); ok (GMP::get_si(mpq(123)) == 123.0); ok (GMP::get_si(mpf(123)) == 123.0); #------------------------------------------------------------------------------ # GMP::integer_p ok ( GMP::integer_p (0)); ok ( GMP::integer_p (123)); ok ( GMP::integer_p (-123)); ok ( GMP::integer_p ($uv_max)); ok ( GMP::integer_p (0.0)); ok ( GMP::integer_p (123.0)); ok ( GMP::integer_p (-123.0)); ok (! GMP::integer_p (0.5)); ok (! GMP::integer_p (123.5)); ok (! GMP::integer_p (-123.5)); ok ( GMP::integer_p ('0')); ok ( GMP::integer_p ('123')); ok ( GMP::integer_p ('-123')); ok (! GMP::integer_p ('0.5')); ok (! GMP::integer_p ('123.5')); ok (! GMP::integer_p ('-123.5')); ok (! GMP::integer_p ('5/8')); ok ( GMP::integer_p (mpz(1))); ok ( GMP::integer_p (mpq(1))); ok (! GMP::integer_p (mpq(1,2))); ok ( GMP::integer_p (mpf(1.0))); ok (! GMP::integer_p (mpf(1.5))); #------------------------------------------------------------------------------ # GMP::odd_p ok (! odd_p(0)); ok ( odd_p(1)); ok (! odd_p(2)); ok ( odd_p($uv_max)); ok ( odd_p(mpz(-3))); ok (! odd_p(mpz(-2))); ok ( odd_p(mpz(-1))); ok (! odd_p(mpz(0))); ok ( odd_p(mpz(1))); ok (! odd_p(mpz(2))); ok ( odd_p(mpz(3))); #------------------------------------------------------------------------------ # GMP::printf GMP::printf ("hello world\n"); sub via_printf { my $s; open TEMP, ">test.tmp" or die; GMP::printf TEMP @_; close TEMP or die; open TEMP, "sgn() == -1); ok (mpz(0) ->sgn() == 0); ok (mpz(123) ->sgn() == 1); ok (mpq(-123)->sgn() == -1); ok (mpq(0) ->sgn() == 0); ok (mpq(123) ->sgn() == 1); ok (mpf(-123)->sgn() == -1); ok (mpf(0) ->sgn() == 0); ok (mpf(123) ->sgn() == 1); #------------------------------------------------------------------------------ # overloaded constants if ($] > 5.00503) { if (! do 'test2.pl') { die "Cannot run test2.pl\n"; } } #------------------------------------------------------------------------------ # $# stuff # # For some reason "local $#" doesn't leave $# back at its default undefined # state when exiting the block. { local $# = 'hi %.0f there'; my $f = mpf(123); ok ("$f" eq 'hi 123 there'); } # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/perl/test2.pl0000644000175000017500000000355014360276512015314 0ustar cammcamm# GMP perl module tests (part 2) # Copyright 2001 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. # The following uses of :constants seem to provoke segvs in perl 5.005_03, # so they're kept separate file to be run only on suitable perl versions. use GMP::Mpz qw(:constants); { my $a = 123; ok (UNIVERSAL::isa ($a, "GMP::Mpz")); } use GMP::Mpz qw(:noconstants); use GMP::Mpq qw(:constants); { my $a = 123; ok (UNIVERSAL::isa ($a, "GMP::Mpq")); } use GMP::Mpq qw(:noconstants); use GMP::Mpf qw(:constants); { my $a = 123; ok (UNIVERSAL::isa ($a, "GMP::Mpf")); } use GMP::Mpf qw(:noconstants); # compiled constants unchanged by clrbit etc when re-executed foreach (0, 1, 2) { use GMP::Mpz qw(:constants); my $a = 15; my $b = 6; use GMP::Mpz qw(:noconstants); clrbit ($a, 0); ok ($a == 14); setbit ($b, 0); ok ($b == 7); } 1; # Local variables: # perl-indent-level: 2 # End: gcl-2.6.14/gmp4/demos/Makefile.am0000644000175000017500000000310714360276512015006 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 2000-2002, 2012 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. SUBDIRS = calc expr EXTRA_DIST = perl primes.h INCLUDES = -I$(top_srcdir) LDADD = $(top_builddir)/libgmp.la qcn_LDADD = $(LDADD) $(LIBM) primes_LDADD = $(LDADD) $(LIBM) # None of these programs are built by default, but "make " will # build them once libgmp.la is built. # EXTRA_PROGRAMS = factorize isprime pexpr primes qcn CLEANFILES = $(EXTRA_PROGRAMS) allprogs: $(EXTRA_PROGRAMS) cd calc; $(MAKE) $(AM_MAKEFLAGS) allprogs cd expr; $(MAKE) $(AM_MAKEFLAGS) allprogs gcl-2.6.14/gmp4/demos/expr/0000755000175000017500000000000014360276512013727 5ustar cammcammgcl-2.6.14/gmp4/demos/expr/exprq.c0000644000175000017500000001176014360276512015237 0ustar cammcamm/* mpq expression evaluation Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "gmp.h" #include "expr-impl.h" /* Change this to "#define TRACE(x) x" to get some traces. */ #define TRACE(x) static void e_mpq_pow_ui (mpq_ptr r, mpq_srcptr b, unsigned long e) { mpz_pow_ui (mpq_numref(r), mpq_numref(b), e); mpz_pow_ui (mpq_denref(r), mpq_denref(b), e); } /* Wrapped because mpq_sgn is a macro. */ static int e_mpq_sgn (mpq_srcptr x) { return mpq_sgn (x); } /* Wrapped because mpq_equal only guarantees a non-zero return, whereas we want 1 or 0 for == and !=. */ static int e_mpq_equal (mpq_srcptr x, mpq_srcptr y) { return mpq_equal (x, y) != 0; } static int e_mpq_notequal (mpq_srcptr x, mpq_srcptr y) { return ! mpq_equal (x, y); } static void e_mpq_num (mpq_ptr w, mpq_srcptr x) { if (w != x) mpz_set (mpq_numref(w), mpq_numref(x)); mpz_set_ui (mpq_denref(w), 1L); } static void e_mpq_den (mpq_ptr w, mpq_srcptr x) { if (w == x) mpz_swap (mpq_numref(w), mpq_denref(w)); else mpz_set (mpq_numref(w), mpq_denref(x)); mpz_set_ui (mpq_denref(w), 1L); } static const struct mpexpr_operator_t _mpq_expr_standard_table[] = { { "**", (mpexpr_fun_t) e_mpq_pow_ui, MPEXPR_TYPE_BINARY_UI | MPEXPR_TYPE_RIGHTASSOC, 220 }, { "!", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_LOGICAL_NOT | MPEXPR_TYPE_PREFIX, 210 }, { "-", (mpexpr_fun_t) mpq_neg, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 210 }, { "*", (mpexpr_fun_t) mpq_mul, MPEXPR_TYPE_BINARY, 200 }, { "/", (mpexpr_fun_t) mpq_div, MPEXPR_TYPE_BINARY, 200 }, { "+", (mpexpr_fun_t) mpq_add, MPEXPR_TYPE_BINARY, 190 }, { "-", (mpexpr_fun_t) mpq_sub, MPEXPR_TYPE_BINARY, 190 }, { "<<", (mpexpr_fun_t) mpq_mul_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { ">>", (mpexpr_fun_t) mpq_div_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { "<=", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_CMP_LE, 170 }, { "<", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_CMP_LT, 170 }, { ">=", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_CMP_GE, 170 }, { ">", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_CMP_GT, 170 }, { "==", (mpexpr_fun_t) e_mpq_equal, MPEXPR_TYPE_I_BINARY, 160 }, { "!=", (mpexpr_fun_t) e_mpq_notequal, MPEXPR_TYPE_I_BINARY, 160 }, { "&&", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_LOGICAL_AND, 120 }, { "||", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_LOGICAL_OR, 110 }, { ":", NULL, MPEXPR_TYPE_COLON, 101 }, { "?", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_QUESTION, 100 }, { ")", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_CLOSEPAREN, 4 }, { "(", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_OPENPAREN, 3 }, { ",", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_ARGSEP, 2 }, { "$", NULL, MPEXPR_TYPE_VARIABLE, 1 }, { "abs", (mpexpr_fun_t) mpq_abs, MPEXPR_TYPE_UNARY }, { "cmp", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_I_BINARY }, { "den", (mpexpr_fun_t) e_mpq_den, MPEXPR_TYPE_UNARY }, { "max", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_MAX | MPEXPR_TYPE_PAIRWISE }, { "min", (mpexpr_fun_t) mpq_cmp, MPEXPR_TYPE_MIN | MPEXPR_TYPE_PAIRWISE }, { "num", (mpexpr_fun_t) e_mpq_num, MPEXPR_TYPE_UNARY }, { "sgn", (mpexpr_fun_t) e_mpq_sgn, MPEXPR_TYPE_I_UNARY }, { NULL } }; const struct mpexpr_operator_t * const mpq_expr_standard_table = _mpq_expr_standard_table; int mpq_expr (mpq_ptr res, int base, const char *e, ...) { mpq_srcptr var[MPEXPR_VARIABLES]; va_list ap; int ret; va_start (ap, e); TRACE (printf ("mpq_expr(): base %d, %s\n", base, e)); ret = mpexpr_va_to_var ((void **) var, ap); va_end (ap); if (ret != MPEXPR_RESULT_OK) return ret; return mpq_expr_a (mpq_expr_standard_table, res, base, e, strlen(e), var); } gcl-2.6.14/gmp4/demos/expr/expr.h0000644000175000017500000001212314360276512015055 0ustar cammcamm/* Header for expression evaluation. Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #ifndef __EXPR_H__ #define __EXPR_H__ #define MPEXPR_RESULT_OK 0 #define MPEXPR_RESULT_BAD_VARIABLE 1 #define MPEXPR_RESULT_BAD_TABLE 2 #define MPEXPR_RESULT_PARSE_ERROR 3 #define MPEXPR_RESULT_NOT_UI 4 /* basic types */ #define MPEXPR_TYPE_NARY(n) ((n) * 0x0100) #define MPEXPR_TYPE_MASK_ARGCOUNT MPEXPR_TYPE_NARY(0xF) #define MPEXPR_TYPE_0ARY MPEXPR_TYPE_NARY(0) #define MPEXPR_TYPE_UNARY MPEXPR_TYPE_NARY(1) #define MPEXPR_TYPE_BINARY MPEXPR_TYPE_NARY(2) #define MPEXPR_TYPE_TERNARY MPEXPR_TYPE_NARY(3) /* options for all */ #define MPEXPR_TYPE_LAST_UI 0x0010 #define MPEXPR_TYPE_RESULT_INT 0x0020 #define MPEXPR_TYPE_MASK_ARGSTYLE 0x0030 #define MPEXPR_TYPE_UNARY_UI (MPEXPR_TYPE_UNARY | MPEXPR_TYPE_LAST_UI) #define MPEXPR_TYPE_I_UNARY (MPEXPR_TYPE_UNARY | MPEXPR_TYPE_RESULT_INT) #define MPEXPR_TYPE_I_UNARY_UI (MPEXPR_TYPE_I_UNARY | MPEXPR_TYPE_LAST_UI) #define MPEXPR_TYPE_BINARY_UI (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_LAST_UI) #define MPEXPR_TYPE_I_BINARY (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_RESULT_INT) #define MPEXPR_TYPE_I_BINARY_UI (MPEXPR_TYPE_I_BINARY| MPEXPR_TYPE_LAST_UI) #define MPEXPR_TYPE_TERNARY_UI (MPEXPR_TYPE_TERNARY | MPEXPR_TYPE_LAST_UI) #define MPEXPR_TYPE_I_TERNARY (MPEXPR_TYPE_TERNARY | MPEXPR_TYPE_RESULT_INT) #define MPEXPR_TYPE_I_TERNARY_UI (MPEXPR_TYPE_I_TERNARY|MPEXPR_TYPE_LAST_UI) /* 0ary with options */ #define MPEXPR_TYPE_CONSTANT (MPEXPR_TYPE_0ARY | 0x0040) /* unary options */ #define MPEXPR_TYPE_PREFIX 0x0040 /* binary options */ #define MPEXPR_TYPE_RIGHTASSOC 0x0040 #define MPEXPR_TYPE_PAIRWISE 0x0080 #define MPEXPR_TYPE_MASK_SPECIAL 0x000F /* unary specials */ #define MPEXPR_TYPE_NEW_TABLE (MPEXPR_TYPE_UNARY | 0x001) #define MPEXPR_TYPE_DONE (MPEXPR_TYPE_UNARY | 0x002) #define MPEXPR_TYPE_VARIABLE (MPEXPR_TYPE_UNARY | 0x003) #define MPEXPR_TYPE_LOGICAL_NOT (MPEXPR_TYPE_UNARY | 0x004) #define MPEXPR_TYPE_CLOSEPAREN (MPEXPR_TYPE_UNARY | 0x005) #define MPEXPR_TYPE_OPENPAREN (MPEXPR_TYPE_CLOSEPAREN | MPEXPR_TYPE_PREFIX) /* binary specials */ #define MPEXPR_TYPE_LOGICAL_AND (MPEXPR_TYPE_BINARY | 0x001) #define MPEXPR_TYPE_LOGICAL_OR (MPEXPR_TYPE_BINARY | 0x002) #define MPEXPR_TYPE_ARGSEP (MPEXPR_TYPE_BINARY | 0x003) #define MPEXPR_TYPE_QUESTION (MPEXPR_TYPE_BINARY | 0x004) #define MPEXPR_TYPE_COLON (MPEXPR_TYPE_BINARY | 0x005) #define MPEXPR_TYPE_MAX (MPEXPR_TYPE_BINARY | 0x006) #define MPEXPR_TYPE_MIN (MPEXPR_TYPE_BINARY | 0x007) #define MPEXPR_TYPE_MASK_CMP 0x008 #define MPEXPR_TYPE_MASK_CMP_LT 0x001 #define MPEXPR_TYPE_MASK_CMP_EQ 0x002 #define MPEXPR_TYPE_MASK_CMP_GT 0x004 #define MPEXPR_TYPE_CMP_LT (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_MASK_CMP \ | MPEXPR_TYPE_MASK_CMP_LT) #define MPEXPR_TYPE_CMP_EQ (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_MASK_CMP \ | MPEXPR_TYPE_MASK_CMP_EQ) #define MPEXPR_TYPE_CMP_GT (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_MASK_CMP \ | MPEXPR_TYPE_MASK_CMP_GT) #define MPEXPR_TYPE_CMP_LE (MPEXPR_TYPE_CMP_LT | MPEXPR_TYPE_MASK_CMP_EQ) #define MPEXPR_TYPE_CMP_NE (MPEXPR_TYPE_CMP_LT | MPEXPR_TYPE_MASK_CMP_GT) #define MPEXPR_TYPE_CMP_GE (MPEXPR_TYPE_CMP_GT | MPEXPR_TYPE_MASK_CMP_EQ) /* parse options */ #define MPEXPR_TYPE_WHOLEWORD 0x1000 #define MPEXPR_TYPE_OPERATOR 0x2000 #ifdef __cplusplus extern "C" { #endif typedef void (*mpexpr_fun_t) (void); struct mpexpr_operator_t { const char *name; mpexpr_fun_t fun; int type; int precedence; }; int mpf_expr_a (const struct mpexpr_operator_t *, mpf_ptr, int, unsigned long, const char *, size_t, mpf_srcptr [26]); int mpf_expr (mpf_ptr, int, const char *, ...); int mpq_expr_a (const struct mpexpr_operator_t *, mpq_ptr, int, const char *, size_t, mpq_srcptr [26]); int mpq_expr (mpq_ptr, int, const char *, ...); int mpz_expr_a (const struct mpexpr_operator_t *, mpz_ptr, int, const char *, size_t, mpz_srcptr [26]); int mpz_expr (mpz_ptr, int, const char *, ...); #ifdef __cplusplus } /* extern "C" */ #endif #endif gcl-2.6.14/gmp4/demos/expr/exprza.c0000644000175000017500000000555414360276512015415 0ustar cammcamm/* mpz expression evaluation Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "expr-impl.h" /* No need to parse '-' since that's handled as an operator. This function also by mpq_expr_a, so it's not static. */ size_t mpexpr_mpz_number (mpz_ptr res, const char *e, size_t elen, int base) { char *edup; size_t i, ret; int base_effective = (base == 0 ? 10 : base); void *(*allocate_func) (size_t); void (*free_func) (void *, size_t); i = 0; if (e[i] == '0') { i++; if (e[i] == 'x' || e[i] == 'b') i++; } for ( ; i < elen; i++) if (! isasciidigit_in_base (e[i], base_effective)) break; mp_get_memory_functions (&allocate_func, NULL, &free_func); edup = (*allocate_func) (i+1); memcpy (edup, e, i); edup[i] = '\0'; if (mpz_set_str (res, edup, base) == 0) ret = i; else ret = 0; (*free_func) (edup, i+1); return ret; } /* ignoring prec */ static void e_mpz_init (mpz_ptr z, unsigned long prec) { mpz_init (z); } int mpz_expr_a (const struct mpexpr_operator_t *table, mpz_ptr res, int base, const char *e, size_t elen, mpz_srcptr var[26]) { struct mpexpr_parse_t p; p.table = table; p.res = (mpX_ptr) res; p.base = base; p.e = e; p.elen = elen; p.var = (mpX_srcptr *) var; p.mpX_clear = (mpexpr_fun_one_t) mpz_clear; p.mpX_ulong_p = (mpexpr_fun_i_unary_t) mpz_fits_ulong_p; p.mpX_get_ui = (mpexpr_fun_get_ui_t) mpz_get_ui; p.mpX_init = (mpexpr_fun_unary_ui_t) e_mpz_init; p.mpX_number = (mpexpr_fun_number_t) mpexpr_mpz_number; p.mpX_set = (mpexpr_fun_unary_t) mpz_set; p.mpX_set_or_swap = (mpexpr_fun_unary_t) mpz_swap; p.mpX_set_si = (mpexpr_fun_set_si_t) mpz_set_si; p.mpX_swap = (mpexpr_fun_swap_t) mpz_swap; return mpexpr_evaluate (&p); } gcl-2.6.14/gmp4/demos/expr/exprfa.c0000644000175000017500000001104214360276512015356 0ustar cammcamm/* mpf expression evaluation Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* Future: Bitwise "&", "|" and "&" could be done, if desired. Not sure those functions would be much value though. */ #include #include #include #include "gmp.h" #include "expr-impl.h" /* Change this to "#define TRACE(x) x" to get some traces. */ #define TRACE(x) static size_t e_mpf_number (mpf_ptr res, const char *e, size_t elen, int base) { char *edup; size_t i, ret, extra=0; int mant_base, exp_base; void *(*allocate_func) (size_t); void (*free_func) (void *, size_t); TRACE (printf ("mpf_number base=%d \"%.*s\"\n", base, (int) elen, e)); /* mpf_set_str doesn't currently accept 0x for hex in base==0, so do it here instead. FIXME: Would prefer to let mpf_set_str handle this. */ if (base == 0 && elen >= 2 && e[0] == '0' && (e[1] == 'x' || e[1] == 'X')) { base = 16; extra = 2; e += extra; elen -= extra; } if (base == 0) mant_base = 10; else if (base < 0) mant_base = -base; else mant_base = base; /* exponent in decimal if base is negative */ if (base < 0) exp_base = 10; else if (base == 0) exp_base = 10; else exp_base = base; #define IS_EXPONENT(c) \ (c == '@' || (base <= 10 && base >= -10 && (e[i] == 'e' || e[i] == 'E'))) i = 0; for (;;) { if (i >= elen) goto parsed; if (e[i] == '.') break; if (IS_EXPONENT (e[i])) goto exponent; if (! isasciidigit_in_base (e[i], mant_base)) goto parsed; i++; } /* fraction */ i++; for (;;) { if (i >= elen) goto parsed; if (IS_EXPONENT (e[i])) goto exponent; if (! isasciidigit_in_base (e[i], mant_base)) goto parsed; i++; } exponent: i++; if (i >= elen) goto parsed; if (e[i] == '-') i++; for (;;) { if (i >= elen) goto parsed; if (! isasciidigit_in_base (e[i], exp_base)) break; i++; } parsed: TRACE (printf (" parsed i=%u \"%.*s\"\n", i, (int) i, e)); mp_get_memory_functions (&allocate_func, NULL, &free_func); edup = (*allocate_func) (i+1); memcpy (edup, e, i); edup[i] = '\0'; if (mpf_set_str (res, edup, base) == 0) ret = i + extra; else ret = 0; (*free_func) (edup, i+1); return ret; } static int e_mpf_ulong_p (mpf_srcptr f) { return mpf_integer_p (f) && mpf_fits_ulong_p (f); } /* Don't want to change the precision of w, can only do an actual swap when w and x have the same precision. */ static void e_mpf_set_or_swap (mpf_ptr w, mpf_ptr x) { if (mpf_get_prec (w) == mpf_get_prec (x)) mpf_swap (w, x); else mpf_set (w, x); } int mpf_expr_a (const struct mpexpr_operator_t *table, mpf_ptr res, int base, unsigned long prec, const char *e, size_t elen, mpf_srcptr var[26]) { struct mpexpr_parse_t p; p.table = table; p.res = (mpX_ptr) res; p.base = base; p.prec = prec; p.e = e; p.elen = elen; p.var = (mpX_srcptr *) var; p.mpX_clear = (mpexpr_fun_one_t) mpf_clear; p.mpX_ulong_p = (mpexpr_fun_i_unary_t) e_mpf_ulong_p; p.mpX_get_ui = (mpexpr_fun_get_ui_t) mpf_get_ui; p.mpX_init = (mpexpr_fun_unary_ui_t) mpf_init2; p.mpX_number = (mpexpr_fun_number_t) e_mpf_number; p.mpX_set = (mpexpr_fun_unary_t) mpf_set; p.mpX_set_or_swap = (mpexpr_fun_unary_t) e_mpf_set_or_swap; p.mpX_set_si = (mpexpr_fun_set_si_t) mpf_set_si; p.mpX_swap = (mpexpr_fun_swap_t) mpf_swap; return mpexpr_evaluate (&p); } gcl-2.6.14/gmp4/demos/expr/expr-impl.h0000644000175000017500000001052214360276512016015 0ustar cammcamm/* Implementation specifics for expression evaluation. Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include "expr.h" #define isasciidigit(c) (isascii (c) && isdigit (c)) #define isasciicsym(c) (isascii (c) && (isalnum(c) || (c) == '_')) #define isasciidigit_in_base(c,base) \ (isascii (c) \ && ((isdigit (c) && (c)-'0' < (base)) \ || (isupper (c) && (c)-'A'+10 < (base)) \ || (islower (c) && (c)-'a'+10 < (base)))) union mpX_t { mpz_t z; mpq_t q; mpf_t f; }; typedef union mpX_t *mpX_ptr; typedef const union mpX_t *mpX_srcptr; typedef void (*mpexpr_fun_one_t) (mpX_ptr); typedef unsigned long (*mpexpr_fun_ui_one_t) (mpX_ptr); typedef void (*mpexpr_fun_0ary_t) (mpX_ptr); typedef int (*mpexpr_fun_i_0ary_t) (void); typedef void (*mpexpr_fun_unary_t) (mpX_ptr, mpX_srcptr); typedef void (*mpexpr_fun_unary_ui_t) (mpX_ptr, unsigned long); typedef int (*mpexpr_fun_i_unary_t) (mpX_srcptr); typedef int (*mpexpr_fun_i_unary_ui_t) (unsigned long); typedef void (*mpexpr_fun_binary_t) (mpX_ptr, mpX_srcptr, mpX_srcptr); typedef void (*mpexpr_fun_binary_ui_t) (mpX_ptr, mpX_srcptr, unsigned long); typedef int (*mpexpr_fun_i_binary_t) (mpX_srcptr, mpX_srcptr); typedef int (*mpexpr_fun_i_binary_ui_t) (mpX_srcptr, unsigned long); typedef void (*mpexpr_fun_ternary_t) (mpX_ptr, mpX_srcptr, mpX_srcptr, mpX_srcptr); typedef void (*mpexpr_fun_ternary_ui_t) (mpX_ptr, mpX_srcptr, mpX_srcptr, unsigned long); typedef int (*mpexpr_fun_i_ternary_t) (mpX_srcptr, mpX_srcptr, mpX_srcptr); typedef int (*mpexpr_fun_i_ternary_ui_t) (mpX_srcptr, mpX_srcptr, unsigned long); typedef size_t (*mpexpr_fun_number_t) (mpX_ptr, const char *str, size_t len, int base); typedef void (*mpexpr_fun_swap_t) (mpX_ptr, mpX_ptr); typedef unsigned long (*mpexpr_fun_get_ui_t) (mpX_srcptr); typedef void (*mpexpr_fun_set_si_t) (mpX_srcptr, long); struct mpexpr_control_t { const struct mpexpr_operator_t *op; int argcount; }; #define MPEXPR_VARIABLES 26 struct mpexpr_parse_t { const struct mpexpr_operator_t *table; mpX_ptr res; int base; unsigned long prec; const char *e; size_t elen; mpX_srcptr *var; int error_code; int token; const struct mpexpr_operator_t *token_op; union mpX_t *data_stack; int data_top; int data_alloc; int data_inited; struct mpexpr_control_t *control_stack; int control_top; int control_alloc; mpexpr_fun_0ary_t mpX_clear; mpexpr_fun_i_unary_t mpX_ulong_p; mpexpr_fun_get_ui_t mpX_get_ui; mpexpr_fun_unary_ui_t mpX_init; mpexpr_fun_number_t mpX_number; mpexpr_fun_unary_t mpX_set; mpexpr_fun_unary_t mpX_set_or_swap; mpexpr_fun_set_si_t mpX_set_si; mpexpr_fun_swap_t mpX_swap; }; int mpexpr_evaluate (struct mpexpr_parse_t *p); int mpexpr_va_to_var (void *var[], va_list ap); size_t mpexpr_mpz_number (mpz_ptr res, const char *e, size_t elen, int base); gcl-2.6.14/gmp4/demos/expr/exprf.c0000644000175000017500000001110514360276512015215 0ustar cammcamm/* mpf expression evaluation Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "gmp.h" #include "expr-impl.h" /* Change this to "#define TRACE(x) x" to get some traces. */ #define TRACE(x) static int e_mpf_sgn (mpf_srcptr x) { return mpf_sgn (x); } static const struct mpexpr_operator_t _mpf_expr_standard_table[] = { { "**", (mpexpr_fun_t) mpf_pow_ui, MPEXPR_TYPE_BINARY_UI | MPEXPR_TYPE_RIGHTASSOC, 220 }, { "!", (mpexpr_fun_t) e_mpf_sgn, MPEXPR_TYPE_LOGICAL_NOT | MPEXPR_TYPE_PREFIX, 210 }, { "-", (mpexpr_fun_t) mpf_neg, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 210 }, { "*", (mpexpr_fun_t) mpf_mul, MPEXPR_TYPE_BINARY, 200 }, { "/", (mpexpr_fun_t) mpf_div, MPEXPR_TYPE_BINARY, 200 }, { "+", (mpexpr_fun_t) mpf_add, MPEXPR_TYPE_BINARY, 190 }, { "-", (mpexpr_fun_t) mpf_sub, MPEXPR_TYPE_BINARY, 190 }, { "<<", (mpexpr_fun_t) mpf_mul_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { ">>", (mpexpr_fun_t) mpf_div_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { "<=", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_LE, 170 }, { "<", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_LT, 170 }, { ">=", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_GE, 170 }, { ">", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_GT, 170 }, { "==", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_EQ, 160 }, { "!=", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_NE, 160 }, { "&&", (mpexpr_fun_t) e_mpf_sgn, MPEXPR_TYPE_LOGICAL_AND, 120 }, { "||", (mpexpr_fun_t) e_mpf_sgn, MPEXPR_TYPE_LOGICAL_OR, 110 }, { ":", NULL, MPEXPR_TYPE_COLON, 101 }, { "?", (mpexpr_fun_t) e_mpf_sgn, MPEXPR_TYPE_QUESTION, 100 }, { ")", NULL, MPEXPR_TYPE_CLOSEPAREN, 4 }, { "(", NULL, MPEXPR_TYPE_OPENPAREN, 3 }, { ",", NULL, MPEXPR_TYPE_ARGSEP, 2 }, { "$", NULL, MPEXPR_TYPE_VARIABLE, 1 }, { "abs", (mpexpr_fun_t) mpf_abs, MPEXPR_TYPE_UNARY }, { "ceil", (mpexpr_fun_t) mpf_ceil, MPEXPR_TYPE_UNARY }, { "cmp", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_I_BINARY }, { "eq", (mpexpr_fun_t) mpf_eq, MPEXPR_TYPE_I_TERNARY_UI }, { "floor", (mpexpr_fun_t) mpf_floor, MPEXPR_TYPE_UNARY }, { "integer_p",(mpexpr_fun_t) mpf_integer_p, MPEXPR_TYPE_I_UNARY }, { "max", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_MAX | MPEXPR_TYPE_PAIRWISE }, { "min", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_MIN | MPEXPR_TYPE_PAIRWISE }, { "reldiff", (mpexpr_fun_t) mpf_reldiff, MPEXPR_TYPE_BINARY }, { "sgn", (mpexpr_fun_t) e_mpf_sgn, MPEXPR_TYPE_I_UNARY }, { "sqrt", (mpexpr_fun_t) mpf_sqrt, MPEXPR_TYPE_UNARY }, { "trunc", (mpexpr_fun_t) mpf_trunc, MPEXPR_TYPE_UNARY }, { NULL } }; const struct mpexpr_operator_t * const mpf_expr_standard_table = _mpf_expr_standard_table; int mpf_expr (mpf_ptr res, int base, const char *e, ...) { mpf_srcptr var[MPEXPR_VARIABLES]; va_list ap; int ret; va_start (ap, e); TRACE (printf ("mpf_expr(): base %d, %s\n", base, e)); ret = mpexpr_va_to_var ((void **) var, ap); va_end (ap); if (ret != MPEXPR_RESULT_OK) return ret; return mpf_expr_a (mpf_expr_standard_table, res, base, mpf_get_prec (res), e, strlen(e), var); } gcl-2.6.14/gmp4/demos/expr/exprz.c0000644000175000017500000001775414360276512015261 0ustar cammcamm/* mpz expression evaluation, simple part Copyright 2000-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "expr-impl.h" /* Change this to "#define TRACE(x) x" to get some traces. */ #define TRACE(x) /* These are macros, so need function wrappers. */ static int e_mpz_sgn (mpz_srcptr x) { return mpz_sgn (x); } static int e_mpz_odd_p (mpz_srcptr x) { return mpz_odd_p (x); } static int e_mpz_even_p (mpz_srcptr x) { return mpz_even_p (x); } /* These wrapped because MPEXPR_TYPE_I_ functions are expected to return "int" whereas these return "unsigned long". */ static void e_mpz_hamdist (mpz_ptr w, mpz_srcptr x, mpz_srcptr y) { mpz_set_ui (w, mpz_hamdist (x, y)); } static void e_mpz_popcount (mpz_ptr w, mpz_srcptr x) { mpz_set_ui (w, mpz_popcount (x)); } static void e_mpz_scan0 (mpz_ptr w, mpz_srcptr x, unsigned long start) { mpz_set_ui (w, mpz_scan0 (x, start)); } static void e_mpz_scan1 (mpz_ptr w, mpz_srcptr x, unsigned long start) { mpz_set_ui (w, mpz_scan1 (x, start)); } /* These wrapped because they're in-place whereas MPEXPR_TYPE_BINARY_UI expects a separate source and destination. Actually the parser will normally pass w==x anyway. */ static void e_mpz_setbit (mpz_ptr w, mpz_srcptr x, unsigned long n) { if (w != x) mpz_set (w, x); mpz_setbit (w, n); } static void e_mpz_clrbit (mpz_ptr w, mpz_srcptr x, unsigned long n) { if (w != x) mpz_set (w, x); mpz_clrbit (w, n); } static const struct mpexpr_operator_t _mpz_expr_standard_table[] = { { "**", (mpexpr_fun_t) mpz_pow_ui, MPEXPR_TYPE_BINARY_UI | MPEXPR_TYPE_RIGHTASSOC, 220 }, { "~", (mpexpr_fun_t) mpz_com, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 210 }, { "!", (mpexpr_fun_t) e_mpz_sgn, MPEXPR_TYPE_LOGICAL_NOT | MPEXPR_TYPE_PREFIX, 210 }, { "-", (mpexpr_fun_t) mpz_neg, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 210 }, { "*", (mpexpr_fun_t) mpz_mul, MPEXPR_TYPE_BINARY, 200 }, { "/", (mpexpr_fun_t) mpz_tdiv_q, MPEXPR_TYPE_BINARY, 200 }, { "%", (mpexpr_fun_t) mpz_tdiv_r, MPEXPR_TYPE_BINARY, 200 }, { "+", (mpexpr_fun_t) mpz_add, MPEXPR_TYPE_BINARY, 190 }, { "-", (mpexpr_fun_t) mpz_sub, MPEXPR_TYPE_BINARY, 190 }, { "<<", (mpexpr_fun_t) mpz_mul_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { ">>", (mpexpr_fun_t) mpz_tdiv_q_2exp, MPEXPR_TYPE_BINARY_UI, 180 }, { "<=", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_LE, 170 }, { "<", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_LT, 170 }, { ">=", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_GE, 170 }, { ">", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_GT, 170 }, { "==", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_EQ, 160 }, { "!=", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_CMP_NE, 160 }, { "&", (mpexpr_fun_t) mpz_and, MPEXPR_TYPE_BINARY, 150 }, { "^", (mpexpr_fun_t) mpz_xor, MPEXPR_TYPE_BINARY, 140 }, { "|", (mpexpr_fun_t) mpz_ior, MPEXPR_TYPE_BINARY, 130 }, { "&&", (mpexpr_fun_t) e_mpz_sgn, MPEXPR_TYPE_LOGICAL_AND, 120 }, { "||", (mpexpr_fun_t) e_mpz_sgn, MPEXPR_TYPE_LOGICAL_OR, 110 }, { ":", NULL, MPEXPR_TYPE_COLON, 101 }, { "?", (mpexpr_fun_t) e_mpz_sgn, MPEXPR_TYPE_QUESTION, 100 }, { ")", NULL, MPEXPR_TYPE_CLOSEPAREN, 4 }, { "(", NULL, MPEXPR_TYPE_OPENPAREN, 3 }, { ",", NULL, MPEXPR_TYPE_ARGSEP, 2 }, { "$", NULL, MPEXPR_TYPE_VARIABLE, 1 }, { "abs", (mpexpr_fun_t) mpz_abs, MPEXPR_TYPE_UNARY }, { "bin", (mpexpr_fun_t) mpz_bin_ui, MPEXPR_TYPE_BINARY_UI }, { "clrbit", (mpexpr_fun_t) e_mpz_clrbit, MPEXPR_TYPE_BINARY_UI }, { "cmp", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_I_BINARY }, { "cmpabs", (mpexpr_fun_t) mpz_cmpabs, MPEXPR_TYPE_I_BINARY }, { "congruent_p",(mpexpr_fun_t)mpz_congruent_p, MPEXPR_TYPE_I_TERNARY }, { "divisible_p",(mpexpr_fun_t)mpz_divisible_p, MPEXPR_TYPE_I_BINARY }, { "even_p", (mpexpr_fun_t) e_mpz_even_p, MPEXPR_TYPE_I_UNARY }, { "fib", (mpexpr_fun_t) mpz_fib_ui, MPEXPR_TYPE_UNARY_UI }, { "fac", (mpexpr_fun_t) mpz_fac_ui, MPEXPR_TYPE_UNARY_UI }, { "gcd", (mpexpr_fun_t) mpz_gcd, MPEXPR_TYPE_BINARY | MPEXPR_TYPE_PAIRWISE }, { "hamdist", (mpexpr_fun_t) e_mpz_hamdist, MPEXPR_TYPE_BINARY }, { "invert", (mpexpr_fun_t) mpz_invert, MPEXPR_TYPE_BINARY }, { "jacobi", (mpexpr_fun_t) mpz_jacobi, MPEXPR_TYPE_I_BINARY }, { "kronecker", (mpexpr_fun_t) mpz_kronecker, MPEXPR_TYPE_I_BINARY }, { "lcm", (mpexpr_fun_t) mpz_lcm, MPEXPR_TYPE_BINARY | MPEXPR_TYPE_PAIRWISE }, { "lucnum", (mpexpr_fun_t) mpz_lucnum_ui, MPEXPR_TYPE_UNARY_UI }, { "max", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_MAX | MPEXPR_TYPE_PAIRWISE }, { "min", (mpexpr_fun_t) mpz_cmp, MPEXPR_TYPE_MIN | MPEXPR_TYPE_PAIRWISE }, { "nextprime", (mpexpr_fun_t) mpz_nextprime, MPEXPR_TYPE_UNARY }, { "odd_p", (mpexpr_fun_t) e_mpz_odd_p, MPEXPR_TYPE_I_UNARY }, { "perfect_power_p", (mpexpr_fun_t)mpz_perfect_power_p, MPEXPR_TYPE_I_UNARY}, { "perfect_square_p",(mpexpr_fun_t)mpz_perfect_square_p,MPEXPR_TYPE_I_UNARY}, { "popcount", (mpexpr_fun_t) e_mpz_popcount, MPEXPR_TYPE_UNARY }, { "powm", (mpexpr_fun_t) mpz_powm, MPEXPR_TYPE_TERNARY }, { "probab_prime_p", (mpexpr_fun_t)mpz_probab_prime_p, MPEXPR_TYPE_I_UNARY}, { "root", (mpexpr_fun_t) mpz_root, MPEXPR_TYPE_BINARY_UI }, { "scan0", (mpexpr_fun_t) e_mpz_scan0, MPEXPR_TYPE_BINARY_UI }, { "scan1", (mpexpr_fun_t) e_mpz_scan1, MPEXPR_TYPE_BINARY_UI }, { "setbit", (mpexpr_fun_t) e_mpz_setbit, MPEXPR_TYPE_BINARY_UI }, { "tstbit", (mpexpr_fun_t) mpz_tstbit, MPEXPR_TYPE_I_BINARY_UI }, { "sgn", (mpexpr_fun_t) e_mpz_sgn, MPEXPR_TYPE_I_UNARY }, { "sqrt", (mpexpr_fun_t) mpz_sqrt, MPEXPR_TYPE_UNARY }, { NULL } }; /* The table is available globally only through a pointer, so the table size can change without breaking binary compatibility. */ const struct mpexpr_operator_t * const mpz_expr_standard_table = _mpz_expr_standard_table; int mpz_expr (mpz_ptr res, int base, const char *e, ...) { mpz_srcptr var[MPEXPR_VARIABLES]; va_list ap; int ret; va_start (ap, e); TRACE (printf ("mpz_expr(): base %d, %s\n", base, e)); ret = mpexpr_va_to_var ((void **) var, ap); va_end (ap); if (ret != MPEXPR_RESULT_OK) return ret; return mpz_expr_a (mpz_expr_standard_table, res, base, e, strlen(e), var); } gcl-2.6.14/gmp4/demos/expr/run-expr.c0000644000175000017500000001355114360276512015660 0ustar cammcamm/* Demo program to run expression evaluation. Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* Usage: ./run-expr [-z] [-q] [-f] [-p prec] [-b base] expression... Evaluate each argument as a simple expression. By default this is in mpz integers, but -q selects mpq or -f selects mpf. For mpf the float precision can be set with -p. In all cases the input base can be set with -b, or the default is "0" meaning decimal with "0x" allowed. This is a pretty trivial program, it's just an easy way to experiment with the evaluation functions. */ #include #include #include "gmp.h" #include "expr.h" void run_expr (int type, int base, unsigned long prec, char *str) { int outbase = (base == 0 ? 10 : base); int ret; switch (type) { case 'z': default: { mpz_t res, var_a, var_b; mpz_init (res); mpz_init_set_ui (var_a, 55L); mpz_init_set_ui (var_b, 99L); ret = mpz_expr (res, base, str, var_a, var_b, NULL); printf ("\"%s\" base %d: ", str, base); if (ret == MPEXPR_RESULT_OK) { printf ("result "); mpz_out_str (stdout, outbase, res); printf ("\n"); } else printf ("invalid (return code %d)\n", ret); mpz_clear (res); mpz_clear (var_a); mpz_clear (var_b); } break; case 'q': { mpq_t res, var_a, var_b; mpq_init (res); mpq_init (var_a); mpq_init (var_b); mpq_set_ui (var_a, 55L, 1); mpq_set_ui (var_b, 99L, 1); ret = mpq_expr (res, base, str, var_a, var_b, NULL); printf ("\"%s\" base %d: ", str, base); if (ret == MPEXPR_RESULT_OK) { printf ("result "); mpq_out_str (stdout, outbase, res); printf ("\n"); } else printf ("invalid (return code %d)\n", ret); mpq_clear (res); mpq_clear (var_a); mpq_clear (var_b); } break; case 'f': { mpf_t res, var_a, var_b; mpf_init2 (res, prec); mpf_init_set_ui (var_a, 55L); mpf_init_set_ui (var_b, 99L); ret = mpf_expr (res, base, str, var_a, var_b, NULL); printf ("\"%s\" base %d: ", str, base); if (ret == MPEXPR_RESULT_OK) { printf ("result "); mpf_out_str (stdout, outbase, (size_t) 0, res); printf ("\n"); } else printf ("invalid (return code %d)\n", ret); mpf_clear (res); mpf_clear (var_a); mpf_clear (var_b); } break; } } int main (int argc, char *argv[]) { int type = 'z'; int base = 0; unsigned long prec = 64; int seen_expr = 0; int opt; char *arg; for (;;) { argv++; arg = argv[0]; if (arg == NULL) break; if (arg[0] == '-') { for (;;) { arg++; opt = arg[0]; switch (opt) { case '\0': goto end_opt; case 'f': case 'q': case 'z': type = opt; break; case 'b': arg++; if (arg[0] == '\0') { argv++; arg = argv[0]; if (arg == NULL) { need_arg: fprintf (stderr, "Need argument for -%c\n", opt); exit (1); } } base = atoi (arg); goto end_opt; case 'p': arg++; if (arg[0] == '\0') { argv++; arg = argv[0]; if (arg == NULL) goto need_arg; } prec = atoi (arg); goto end_opt; case '-': arg++; if (arg[0] != '\0') { /* no "--foo" options */ fprintf (stderr, "Unrecognised option --%s\n", arg); exit (1); } /* stop option interpretation at "--" */ for (;;) { argv++; arg = argv[0]; if (arg == NULL) goto done; run_expr (type, base, prec, arg); seen_expr = 1; } default: fprintf (stderr, "Unrecognised option -%c\n", opt); exit (1); } } end_opt: ; } else { run_expr (type, base, prec, arg); seen_expr = 1; } } done: if (! seen_expr) { printf ("Usage: %s [-z] [-q] [-f] [-p prec] [-b base] expression...\n", argv[0]); exit (1); } return 0; } gcl-2.6.14/gmp4/demos/expr/Makefile.am0000644000175000017500000000357414360276512015774 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 2001-2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. INCLUDES = -I$(top_srcdir) -I$(top_srcdir)/tests # FIXME: This is a workaround for a bug in automake 1.8.4. When the only # library is in EXTRA_LIBRARIES, $(ARFLAGS) is used but no default setting # for that variable is established. We give an explicit ARFLAGS=cru the # same as generated for lib_LIBRARIES or noinst_LIBRARIES. # ARFLAGS = cru EXTRA_LIBRARIES = libexpr.a libexpr_a_SOURCES = expr.h expr-impl.h \ expr.c exprv.c exprz.c exprza.c exprq.c exprqa.c exprf.c exprfa.c EXTRA_PROGRAMS = run-expr t-expr LDADD = libexpr.a $(top_builddir)/libgmp.la t_expr_LDADD = $(top_builddir)/tests/libtests.la $(LDADD) CLEANFILES = $(EXTRA_PROGRAMS) $(EXTRA_LIBRARIES) allprogs: $(EXTRA_PROGRAMS) $(top_builddir)/tests/libtests.la: cd $(top_builddir)/tests; $(MAKE) $(AM_MAKEFLAGS) libtests.la gcl-2.6.14/gmp4/demos/expr/exprv.c0000644000175000017500000000263614360276512015246 0ustar cammcamm/* mpz expression evaluation, simple part */ /* Copyright 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include "gmp.h" #include "expr-impl.h" int mpexpr_va_to_var (void *var[], va_list ap) { int i = 0; void *v; for (;;) { v = va_arg (ap, void *); if (v == NULL) break; if (i >= MPEXPR_VARIABLES) return MPEXPR_RESULT_BAD_VARIABLE; var[i++] = v; } while (i < MPEXPR_VARIABLES) var[i++] = NULL; return MPEXPR_RESULT_OK; } gcl-2.6.14/gmp4/demos/expr/exprqa.c0000644000175000017500000000527314360276512015402 0ustar cammcamm/* mpq expression evaluation Copyright 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include "gmp.h" #include "expr-impl.h" static int e_mpq_ulong_p (mpq_srcptr q) { return mpz_fits_ulong_p (mpq_numref (q)) && mpz_cmp_ui (mpq_denref (q), 1L) == 0; } /* get value as a ui, on the assumption it fits */ static int e_mpq_get_ui_fits (mpq_srcptr q) { return mpz_get_ui (mpq_numref (q)); } static void e_mpq_set_si1 (mpq_ptr q, long num) { mpq_set_si (q, num, 1L); } /* The same as mpz, but putting the result in the numerator. Negatives and fractions aren't parsed here because '-' and '/' are operators. */ static size_t e_mpq_number (mpq_ptr res, const char *e, size_t elen, int base) { mpz_set_ui (mpq_denref (res), 1L); return mpexpr_mpz_number (mpq_numref (res), e, elen, base); } /* ignoring prec */ static void e_mpq_init (mpq_ptr q, unsigned long prec) { mpq_init (q); } int mpq_expr_a (const struct mpexpr_operator_t *table, mpq_ptr res, int base, const char *e, size_t elen, mpq_srcptr var[26]) { struct mpexpr_parse_t p; p.table = table; p.res = (mpX_ptr) res; p.base = base; p.e = e; p.elen = elen; p.var = (mpX_srcptr *) var; p.mpX_clear = (mpexpr_fun_one_t) mpq_clear; p.mpX_ulong_p = (mpexpr_fun_i_unary_t) e_mpq_ulong_p; p.mpX_get_ui = (mpexpr_fun_get_ui_t) e_mpq_get_ui_fits; p.mpX_init = (mpexpr_fun_unary_ui_t) e_mpq_init; p.mpX_number = (mpexpr_fun_number_t) e_mpq_number; p.mpX_set = (mpexpr_fun_unary_t) mpq_set; p.mpX_set_or_swap = (mpexpr_fun_unary_t) mpq_swap; p.mpX_set_si = (mpexpr_fun_set_si_t) e_mpq_set_si1; p.mpX_swap = (mpexpr_fun_swap_t) mpq_swap; return mpexpr_evaluate (&p); } gcl-2.6.14/gmp4/demos/expr/expr.c0000644000175000017500000006476414360276512015072 0ustar cammcamm/* mpexpr_evaluate -- shared code for simple expression evaluation Copyright 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include "gmp.h" #include "expr-impl.h" /* Change this to "#define TRACE(x) x" to get some traces. The trace printfs junk up the code a bit, but it's very hard to tell what's going on without them. Set MPX_TRACE to a suitable output function for the mpz/mpq/mpf being run (if you have the wrong trace function it'll probably segv). */ #define TRACE(x) #define MPX_TRACE mpz_trace /* A few helper macros copied from gmp-impl.h */ #define ALLOCATE_FUNC_TYPE(n,type) \ ((type *) (*allocate_func) ((n) * sizeof (type))) #define ALLOCATE_FUNC_LIMBS(n) ALLOCATE_FUNC_TYPE (n, mp_limb_t) #define REALLOCATE_FUNC_TYPE(p, old_size, new_size, type) \ ((type *) (*reallocate_func) \ (p, (old_size) * sizeof (type), (new_size) * sizeof (type))) #define REALLOCATE_FUNC_LIMBS(p, old_size, new_size) \ REALLOCATE_FUNC_TYPE(p, old_size, new_size, mp_limb_t) #define FREE_FUNC_TYPE(p,n,type) (*free_func) (p, (n) * sizeof (type)) #define FREE_FUNC_LIMBS(p,n) FREE_FUNC_TYPE (p, n, mp_limb_t) #define ASSERT(x) /* All the error strings are just for diagnostic traces. Only the error code is actually returned. */ #define ERROR(str,code) \ { \ TRACE (printf ("%s\n", str)); \ p->error_code = (code); \ goto done; \ } #define REALLOC(ptr, alloc, incr, type) \ do { \ int new_alloc = (alloc) + (incr); \ ptr = REALLOCATE_FUNC_TYPE (ptr, alloc, new_alloc, type); \ (alloc) = new_alloc; \ } while (0) /* data stack top element */ #define SP (p->data_stack + p->data_top) /* Make sure there's room for another data element above current top. reallocate_func is fetched for when this macro is used in lookahead(). */ #define DATA_SPACE() \ do { \ if (p->data_top + 1 >= p->data_alloc) \ { \ void *(*reallocate_func) (void *, size_t, size_t); \ mp_get_memory_functions (NULL, &reallocate_func, NULL); \ TRACE (printf ("grow stack from %d\n", p->data_alloc)); \ REALLOC (p->data_stack, p->data_alloc, 20, union mpX_t); \ } \ ASSERT (p->data_top + 1 <= p->data_inited); \ if (p->data_top + 1 == p->data_inited) \ { \ TRACE (printf ("initialize %d\n", p->data_top + 1)); \ (*p->mpX_init) (&p->data_stack[p->data_top + 1], p->prec); \ p->data_inited++; \ } \ } while (0) #define DATA_PUSH() \ do { \ p->data_top++; \ ASSERT (p->data_top < p->data_alloc); \ ASSERT (p->data_top < p->data_inited); \ } while (0) /* the last stack entry is never popped, so top>=0 will be true */ #define DATA_POP(n) \ do { \ p->data_top -= (n); \ ASSERT (p->data_top >= 0); \ } while (0) /* lookahead() parses the next token. Return 1 if successful, with some extra data. Return 0 if fail, with reason in p->error_code. "prefix" is MPEXPR_TYPE_PREFIX if an operator with that attribute is preferred, or 0 if an operator without is preferred. */ #define TOKEN_EOF -1 /* no extra data */ #define TOKEN_VALUE -2 /* pushed onto data stack */ #define TOKEN_OPERATOR -3 /* stored in p->token_op */ #define TOKEN_FUNCTION -4 /* stored in p->token_op */ #define TOKEN_NAME(n) \ ((n) == TOKEN_EOF ? "TOKEN_EOF" \ : (n) == TOKEN_VALUE ? "TOKEN_VALUE" \ : (n) == TOKEN_OPERATOR ? "TOKEN_OPERATOR" \ : (n) == TOKEN_VALUE ? "TOKEN_FUNCTION" \ : "UNKNOWN TOKEN") /* Functions default to being parsed as whole words, operators to match just at the start of the string. The type flags override this. */ #define WHOLEWORD(op) \ (op->precedence == 0 \ ? (! (op->type & MPEXPR_TYPE_OPERATOR)) \ : (op->type & MPEXPR_TYPE_WHOLEWORD)) #define isasciispace(c) (isascii (c) && isspace (c)) static int lookahead (struct mpexpr_parse_t *p, int prefix) { const struct mpexpr_operator_t *op, *op_found; size_t oplen, oplen_found, wlen; int i; /* skip white space */ while (p->elen > 0 && isasciispace (*p->e)) p->e++, p->elen--; if (p->elen == 0) { TRACE (printf ("lookahead EOF\n")); p->token = TOKEN_EOF; return 1; } DATA_SPACE (); /* Get extent of whole word. */ for (wlen = 0; wlen < p->elen; wlen++) if (! isasciicsym (p->e[wlen])) break; TRACE (printf ("lookahead at: \"%.*s\" length %u, word %u\n", (int) p->elen, p->e, p->elen, wlen)); op_found = NULL; oplen_found = 0; for (op = p->table; op->name != NULL; op++) { if (op->type == MPEXPR_TYPE_NEW_TABLE) { printf ("new\n"); op = (struct mpexpr_operator_t *) op->name - 1; continue; } oplen = strlen (op->name); if (! ((WHOLEWORD (op) ? wlen == oplen : p->elen >= oplen) && memcmp (p->e, op->name, oplen) == 0)) continue; /* Shorter matches don't replace longer previous ones. */ if (op_found && oplen < oplen_found) continue; /* On a match of equal length to a previous one, the old match isn't replaced if it has the preferred prefix, and if it doesn't then it's not replaced if the new one also doesn't. */ if (op_found && oplen == oplen_found && ((op_found->type & MPEXPR_TYPE_PREFIX) == prefix || (op->type & MPEXPR_TYPE_PREFIX) != prefix)) continue; /* This is now either the first match seen, or a longer than previous match, or an equal to previous one but with a preferred prefix. */ op_found = op; oplen_found = oplen; } if (op_found) { p->e += oplen_found, p->elen -= oplen_found; if (op_found->type == MPEXPR_TYPE_VARIABLE) { if (p->elen == 0) ERROR ("end of string expecting a variable", MPEXPR_RESULT_PARSE_ERROR); i = p->e[0] - 'a'; if (i < 0 || i >= MPEXPR_VARIABLES) ERROR ("bad variable name", MPEXPR_RESULT_BAD_VARIABLE); goto variable; } if (op_found->precedence == 0) { TRACE (printf ("lookahead function: %s\n", op_found->name)); p->token = TOKEN_FUNCTION; p->token_op = op_found; return 1; } else { TRACE (printf ("lookahead operator: %s\n", op_found->name)); p->token = TOKEN_OPERATOR; p->token_op = op_found; return 1; } } oplen = (*p->mpX_number) (SP+1, p->e, p->elen, p->base); if (oplen != 0) { p->e += oplen, p->elen -= oplen; p->token = TOKEN_VALUE; DATA_PUSH (); TRACE (MPX_TRACE ("lookahead number", SP)); return 1; } /* Maybe an unprefixed one character variable */ i = p->e[0] - 'a'; if (wlen == 1 && i >= 0 && i < MPEXPR_VARIABLES) { variable: p->e++, p->elen--; if (p->var[i] == NULL) ERROR ("NULL variable", MPEXPR_RESULT_BAD_VARIABLE); TRACE (printf ("lookahead variable: var[%d] = ", i); MPX_TRACE ("", p->var[i])); p->token = TOKEN_VALUE; DATA_PUSH (); (*p->mpX_set) (SP, p->var[i]); return 1; } ERROR ("no token matched", MPEXPR_RESULT_PARSE_ERROR); done: return 0; } /* control stack current top element */ #define CP (p->control_stack + p->control_top) /* make sure there's room for another control element above current top */ #define CONTROL_SPACE() \ do { \ if (p->control_top + 1 >= p->control_alloc) \ { \ TRACE (printf ("grow control stack from %d\n", p->control_alloc)); \ REALLOC (p->control_stack, p->control_alloc, 20, \ struct mpexpr_control_t); \ } \ } while (0) /* Push an operator on the control stack, claiming currently to have the given number of args ready. Local variable "op" is used in case opptr is a reference through CP. */ #define CONTROL_PUSH(opptr,args) \ do { \ const struct mpexpr_operator_t *op = opptr; \ struct mpexpr_control_t *cp; \ CONTROL_SPACE (); \ p->control_top++; \ ASSERT (p->control_top < p->control_alloc); \ cp = CP; \ cp->op = op; \ cp->argcount = (args); \ TRACE_CONTROL("control stack push:"); \ } while (0) /* The special operator_done is never popped, so top>=0 will hold. */ #define CONTROL_POP() \ do { \ p->control_top--; \ ASSERT (p->control_top >= 0); \ TRACE_CONTROL ("control stack pop:"); \ } while (0) #define TRACE_CONTROL(str) \ TRACE ({ \ int i; \ printf ("%s depth %d:", str, p->control_top); \ for (i = 0; i <= p->control_top; i++) \ printf (" \"%s\"(%d)", \ p->control_stack[i].op->name, \ p->control_stack[i].argcount); \ printf ("\n"); \ }); #define LOOKAHEAD(prefix) \ do { \ if (! lookahead (p, prefix)) \ goto done; \ } while (0) #define CHECK_UI(n) \ do { \ if (! (*p->mpX_ulong_p) (n)) \ ERROR ("operand doesn't fit ulong", MPEXPR_RESULT_NOT_UI); \ } while (0) #define CHECK_ARGCOUNT(str,n) \ do { \ if (CP->argcount != (n)) \ { \ TRACE (printf ("wrong number of arguments for %s, got %d want %d", \ str, CP->argcount, n)); \ ERROR ("", MPEXPR_RESULT_PARSE_ERROR); \ } \ } while (0) /* There's two basic states here. In both p->token is the next token. "another_expr" is when a whole expression should be parsed. This means a literal or variable value possibly followed by an operator, or a function or prefix operator followed by a further whole expression. "another_operator" is when an expression has been parsed and its value is on the top of the data stack (SP) and an optional further postfix or infix operator should be parsed. In "another_operator" precedences determine whether to push the operator onto the control stack, or instead go to "apply_control" to reduce the operator currently on top of the control stack. When an operator has both a prefix and postfix/infix form, a LOOKAHEAD() for "another_expr" will seek the prefix form, a LOOKAHEAD() for "another_operator" will seek the postfix/infix form. The grammar is simple enough that the next state is known before reading the next token. Argument count checking guards against functions consuming the wrong number of operands from the data stack. The same checks are applied to operators, but will always pass since a UNARY or BINARY will only ever parse with the correct operands. */ int mpexpr_evaluate (struct mpexpr_parse_t *p) { void *(*allocate_func) (size_t); void *(*reallocate_func) (void *, size_t, size_t); void (*free_func) (void *, size_t); mp_get_memory_functions (&allocate_func, &reallocate_func, &free_func); TRACE (printf ("mpexpr_evaluate() base %d \"%.*s\"\n", p->base, (int) p->elen, p->e)); /* "done" is a special sentinel at the bottom of the control stack, precedence -1 is lower than any normal operator. */ { static const struct mpexpr_operator_t operator_done = { "DONE", NULL, MPEXPR_TYPE_DONE, -1 }; p->control_alloc = 20; p->control_stack = ALLOCATE_FUNC_TYPE (p->control_alloc, struct mpexpr_control_t); p->control_top = 0; CP->op = &operator_done; CP->argcount = 1; } p->data_inited = 0; p->data_alloc = 20; p->data_stack = ALLOCATE_FUNC_TYPE (p->data_alloc, union mpX_t); p->data_top = -1; p->error_code = MPEXPR_RESULT_OK; another_expr_lookahead: LOOKAHEAD (MPEXPR_TYPE_PREFIX); TRACE (printf ("another expr\n")); /*another_expr:*/ switch (p->token) { case TOKEN_VALUE: goto another_operator_lookahead; case TOKEN_OPERATOR: TRACE (printf ("operator %s\n", p->token_op->name)); if (! (p->token_op->type & MPEXPR_TYPE_PREFIX)) ERROR ("expected a prefix operator", MPEXPR_RESULT_PARSE_ERROR); CONTROL_PUSH (p->token_op, 1); goto another_expr_lookahead; case TOKEN_FUNCTION: CONTROL_PUSH (p->token_op, 1); if (p->token_op->type & MPEXPR_TYPE_CONSTANT) goto apply_control_lookahead; LOOKAHEAD (MPEXPR_TYPE_PREFIX); if (! (p->token == TOKEN_OPERATOR && p->token_op->type == MPEXPR_TYPE_OPENPAREN)) ERROR ("expected open paren for function", MPEXPR_RESULT_PARSE_ERROR); TRACE (printf ("open paren for function \"%s\"\n", CP->op->name)); if ((CP->op->type & MPEXPR_TYPE_MASK_ARGCOUNT) == MPEXPR_TYPE_NARY(0)) { LOOKAHEAD (0); if (! (p->token == TOKEN_OPERATOR && p->token_op->type == MPEXPR_TYPE_CLOSEPAREN)) ERROR ("expected close paren for 0ary function", MPEXPR_RESULT_PARSE_ERROR); goto apply_control_lookahead; } goto another_expr_lookahead; } ERROR ("unrecognised start of expression", MPEXPR_RESULT_PARSE_ERROR); another_operator_lookahead: LOOKAHEAD (0); another_operator: TRACE (printf ("another operator maybe: %s\n", TOKEN_NAME(p->token))); switch (p->token) { case TOKEN_EOF: goto apply_control; case TOKEN_OPERATOR: /* The next operator is compared to the one on top of the control stack. If the next is lower precedence, or the same precedence and not right-associative, then reduce using the control stack and look at the next operator again later. */ #define PRECEDENCE_TEST_REDUCE(tprec,cprec,ttype,ctype) \ ((tprec) < (cprec) \ || ((tprec) == (cprec) && ! ((ttype) & MPEXPR_TYPE_RIGHTASSOC))) if (PRECEDENCE_TEST_REDUCE (p->token_op->precedence, CP->op->precedence, p->token_op->type, CP->op->type)) { TRACE (printf ("defer operator: %s (prec %d vs %d, type 0x%X)\n", p->token_op->name, p->token_op->precedence, CP->op->precedence, p->token_op->type)); goto apply_control; } /* An argsep is a binary operator, but is never pushed on the control stack, it just accumulates an extra argument for a function. */ if (p->token_op->type == MPEXPR_TYPE_ARGSEP) { if (CP->op->precedence != 0) ERROR ("ARGSEP not in a function call", MPEXPR_RESULT_PARSE_ERROR); TRACE (printf ("argsep for function \"%s\"(%d)\n", CP->op->name, CP->argcount)); #define IS_PAIRWISE(type) \ (((type) & (MPEXPR_TYPE_MASK_ARGCOUNT | MPEXPR_TYPE_PAIRWISE)) \ == (MPEXPR_TYPE_BINARY | MPEXPR_TYPE_PAIRWISE)) if (IS_PAIRWISE (CP->op->type) && CP->argcount >= 2) { TRACE (printf (" will reduce pairwise now\n")); CP->argcount--; CONTROL_PUSH (CP->op, 2); goto apply_control; } CP->argcount++; goto another_expr_lookahead; } switch (p->token_op->type & MPEXPR_TYPE_MASK_ARGCOUNT) { case MPEXPR_TYPE_NARY(1): /* Postfix unary operators can always be applied immediately. The easiest way to do this is just push it on the control stack and go to the normal control stack reduction code. */ TRACE (printf ("postfix unary operator: %s\n", p->token_op->name)); if (p->token_op->type & MPEXPR_TYPE_PREFIX) ERROR ("prefix unary operator used postfix", MPEXPR_RESULT_PARSE_ERROR); CONTROL_PUSH (p->token_op, 1); goto apply_control_lookahead; case MPEXPR_TYPE_NARY(2): CONTROL_PUSH (p->token_op, 2); goto another_expr_lookahead; case MPEXPR_TYPE_NARY(3): CONTROL_PUSH (p->token_op, 1); goto another_expr_lookahead; } TRACE (printf ("unrecognised operator \"%s\" type: 0x%X", CP->op->name, CP->op->type)); ERROR ("", MPEXPR_RESULT_PARSE_ERROR); break; default: TRACE (printf ("expecting an operator, got token %d", p->token)); ERROR ("", MPEXPR_RESULT_PARSE_ERROR); } apply_control_lookahead: LOOKAHEAD (0); apply_control: /* Apply the top element CP of the control stack. Data values are SP, SP-1, etc. Result is left as stack top SP after popping consumed values. The use of sp as a duplicate of SP will help compilers that can't otherwise recognise the various uses of SP as common subexpressions. */ TRACE (printf ("apply control: nested %d, \"%s\" 0x%X, %d args\n", p->control_top, CP->op->name, CP->op->type, CP->argcount)); TRACE (printf ("apply 0x%X-ary\n", CP->op->type & MPEXPR_TYPE_MASK_ARGCOUNT)); switch (CP->op->type & MPEXPR_TYPE_MASK_ARGCOUNT) { case MPEXPR_TYPE_NARY(0): { mpX_ptr sp; DATA_SPACE (); DATA_PUSH (); sp = SP; switch (CP->op->type & MPEXPR_TYPE_MASK_ARGSTYLE) { case 0: (* (mpexpr_fun_0ary_t) CP->op->fun) (sp); break; case MPEXPR_TYPE_RESULT_INT: (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_0ary_t) CP->op->fun) ()); break; default: ERROR ("unrecognised 0ary argument calling style", MPEXPR_RESULT_BAD_TABLE); } } break; case MPEXPR_TYPE_NARY(1): { mpX_ptr sp = SP; CHECK_ARGCOUNT ("unary", 1); TRACE (MPX_TRACE ("before", sp)); switch (CP->op->type & MPEXPR_TYPE_MASK_SPECIAL) { case 0: /* not a special */ break; case MPEXPR_TYPE_DONE & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special done\n")); goto done; case MPEXPR_TYPE_LOGICAL_NOT & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special logical not\n")); (*p->mpX_set_si) (sp, (long) ((* (mpexpr_fun_i_unary_t) CP->op->fun) (sp) == 0)); goto apply_control_done; case MPEXPR_TYPE_CLOSEPAREN & MPEXPR_TYPE_MASK_SPECIAL: CONTROL_POP (); if (CP->op->type == MPEXPR_TYPE_OPENPAREN) { TRACE (printf ("close paren matching open paren\n")); CONTROL_POP (); goto another_operator; } if (CP->op->precedence == 0) { TRACE (printf ("close paren for function\n")); goto apply_control; } ERROR ("unexpected close paren", MPEXPR_RESULT_PARSE_ERROR); default: TRACE (printf ("unrecognised special unary operator 0x%X", CP->op->type & MPEXPR_TYPE_MASK_SPECIAL)); ERROR ("", MPEXPR_RESULT_BAD_TABLE); } switch (CP->op->type & MPEXPR_TYPE_MASK_ARGSTYLE) { case 0: (* (mpexpr_fun_unary_t) CP->op->fun) (sp, sp); break; case MPEXPR_TYPE_LAST_UI: CHECK_UI (sp); (* (mpexpr_fun_unary_ui_t) CP->op->fun) (sp, (*p->mpX_get_ui) (sp)); break; case MPEXPR_TYPE_RESULT_INT: (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_unary_t) CP->op->fun) (sp)); break; case MPEXPR_TYPE_RESULT_INT | MPEXPR_TYPE_LAST_UI: CHECK_UI (sp); (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_unary_ui_t) CP->op->fun) ((*p->mpX_get_ui) (sp))); break; default: ERROR ("unrecognised unary argument calling style", MPEXPR_RESULT_BAD_TABLE); } } break; case MPEXPR_TYPE_NARY(2): { mpX_ptr sp; /* pairwise functions are allowed to have just one argument */ if ((CP->op->type & MPEXPR_TYPE_PAIRWISE) && CP->op->precedence == 0 && CP->argcount == 1) goto apply_control_done; CHECK_ARGCOUNT ("binary", 2); DATA_POP (1); sp = SP; TRACE (MPX_TRACE ("lhs", sp); MPX_TRACE ("rhs", sp+1)); if (CP->op->type & MPEXPR_TYPE_MASK_CMP) { int type = CP->op->type; int cmp = (* (mpexpr_fun_i_binary_t) CP->op->fun) (sp, sp+1); (*p->mpX_set_si) (sp, (long) (( (cmp < 0) & ((type & MPEXPR_TYPE_MASK_CMP_LT) != 0)) | ((cmp == 0) & ((type & MPEXPR_TYPE_MASK_CMP_EQ) != 0)) | ((cmp > 0) & ((type & MPEXPR_TYPE_MASK_CMP_GT) != 0)))); goto apply_control_done; } switch (CP->op->type & MPEXPR_TYPE_MASK_SPECIAL) { case 0: /* not a special */ break; case MPEXPR_TYPE_QUESTION & MPEXPR_TYPE_MASK_SPECIAL: ERROR ("'?' without ':'", MPEXPR_RESULT_PARSE_ERROR); case MPEXPR_TYPE_COLON & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special colon\n")); CONTROL_POP (); if (CP->op->type != MPEXPR_TYPE_QUESTION) ERROR ("':' without '?'", MPEXPR_RESULT_PARSE_ERROR); CP->argcount--; DATA_POP (1); sp--; TRACE (MPX_TRACE ("query", sp); MPX_TRACE ("true", sp+1); MPX_TRACE ("false", sp+2)); (*p->mpX_set) (sp, (* (mpexpr_fun_i_unary_t) CP->op->fun) (sp) ? sp+1 : sp+2); goto apply_control_done; case MPEXPR_TYPE_LOGICAL_AND & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special logical and\n")); (*p->mpX_set_si) (sp, (long) ((* (mpexpr_fun_i_unary_t) CP->op->fun) (sp) && (* (mpexpr_fun_i_unary_t) CP->op->fun) (sp+1))); goto apply_control_done; case MPEXPR_TYPE_LOGICAL_OR & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special logical and\n")); (*p->mpX_set_si) (sp, (long) ((* (mpexpr_fun_i_unary_t) CP->op->fun) (sp) || (* (mpexpr_fun_i_unary_t) CP->op->fun) (sp+1))); goto apply_control_done; case MPEXPR_TYPE_MAX & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special max\n")); if ((* (mpexpr_fun_i_binary_t) CP->op->fun) (sp, sp+1) < 0) (*p->mpX_swap) (sp, sp+1); goto apply_control_done; case MPEXPR_TYPE_MIN & MPEXPR_TYPE_MASK_SPECIAL: TRACE (printf ("special min\n")); if ((* (mpexpr_fun_i_binary_t) CP->op->fun) (sp, sp+1) > 0) (*p->mpX_swap) (sp, sp+1); goto apply_control_done; default: ERROR ("unrecognised special binary operator", MPEXPR_RESULT_BAD_TABLE); } switch (CP->op->type & MPEXPR_TYPE_MASK_ARGSTYLE) { case 0: (* (mpexpr_fun_binary_t) CP->op->fun) (sp, sp, sp+1); break; case MPEXPR_TYPE_LAST_UI: CHECK_UI (sp+1); (* (mpexpr_fun_binary_ui_t) CP->op->fun) (sp, sp, (*p->mpX_get_ui) (sp+1)); break; case MPEXPR_TYPE_RESULT_INT: (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_binary_t) CP->op->fun) (sp, sp+1)); break; case MPEXPR_TYPE_LAST_UI | MPEXPR_TYPE_RESULT_INT: CHECK_UI (sp+1); (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_binary_ui_t) CP->op->fun) (sp, (*p->mpX_get_ui) (sp+1))); break; default: ERROR ("unrecognised binary argument calling style", MPEXPR_RESULT_BAD_TABLE); } } break; case MPEXPR_TYPE_NARY(3): { mpX_ptr sp; CHECK_ARGCOUNT ("ternary", 3); DATA_POP (2); sp = SP; TRACE (MPX_TRACE ("arg1", sp); MPX_TRACE ("arg2", sp+1); MPX_TRACE ("arg3", sp+1)); switch (CP->op->type & MPEXPR_TYPE_MASK_ARGSTYLE) { case 0: (* (mpexpr_fun_ternary_t) CP->op->fun) (sp, sp, sp+1, sp+2); break; case MPEXPR_TYPE_LAST_UI: CHECK_UI (sp+2); (* (mpexpr_fun_ternary_ui_t) CP->op->fun) (sp, sp, sp+1, (*p->mpX_get_ui) (sp+2)); break; case MPEXPR_TYPE_RESULT_INT: (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_ternary_t) CP->op->fun) (sp, sp+1, sp+2)); break; case MPEXPR_TYPE_LAST_UI | MPEXPR_TYPE_RESULT_INT: CHECK_UI (sp+2); (*p->mpX_set_si) (sp, (long) (* (mpexpr_fun_i_ternary_ui_t) CP->op->fun) (sp, sp+1, (*p->mpX_get_ui) (sp+2))); break; default: ERROR ("unrecognised binary argument calling style", MPEXPR_RESULT_BAD_TABLE); } } break; default: TRACE (printf ("unrecognised operator type: 0x%X\n", CP->op->type)); ERROR ("", MPEXPR_RESULT_PARSE_ERROR); } apply_control_done: TRACE (MPX_TRACE ("result", SP)); CONTROL_POP (); goto another_operator; done: if (p->error_code == MPEXPR_RESULT_OK) { if (p->data_top != 0) { TRACE (printf ("data stack want top at 0, got %d\n", p->data_top)); p->error_code = MPEXPR_RESULT_PARSE_ERROR; } else (*p->mpX_set_or_swap) (p->res, SP); } { int i; for (i = 0; i < p->data_inited; i++) { TRACE (printf ("clear %d\n", i)); (*p->mpX_clear) (p->data_stack+i); } } FREE_FUNC_TYPE (p->data_stack, p->data_alloc, union mpX_t); FREE_FUNC_TYPE (p->control_stack, p->control_alloc, struct mpexpr_control_t); return p->error_code; } gcl-2.6.14/gmp4/demos/expr/t-expr.c0000644000175000017500000003121614360276512015315 0ustar cammcamm/* Test expression evaluation (print nothing and exit 0 if successful). Copyright 2000-2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "gmp.h" #include "tests.h" #include "expr-impl.h" int option_trace = 0; struct data_t { int base; const char *expr; const char *want; }; #define numberof(x) (sizeof (x) / sizeof ((x)[0])) /* These data_xxx[] arrays are tables to be tested with one or more of the mp?_t types. z=mpz_t, q=mpz_t, f=mpf_t. */ struct data_t data_zqf[] = { /* various deliberately wrong expressions */ { 0, "", NULL }, { 0, "1+", NULL }, { 0, "+2", NULL }, { 0, "1,2", NULL }, { 0, "foo(1,2)", NULL }, { 0, "1+foo", NULL }, { 10, "0fff", NULL }, { 0, "!", NULL }, { 0, "10!", NULL }, { 0, "-10!", NULL }, { 0, "gcd((4,6))", NULL }, { 0, "()", NULL }, { 0, "fac(2**1000)", NULL }, { 0, "$", NULL }, { 0, "$-", NULL }, /* some basics */ { 10, "123", "123" }, { 10, "-123", "-123" }, { 10, "1+2", "3" }, { 10, "1+2+3", "6" }, { 10, "1+2*3", "7" }, { 10, "3*2+1", "7" }, { 10, "$a", "55" }, { 10, "b", "99" }, { 16, "b", "11" }, { 10, "4**3 * 2 + 1", "129" }, { 10, "1<2", "1" }, { 10, "1>2", "0" }, { 10, "(123)", "123" }, { 10, "sgn(-123)", "-1" }, { 10, "5-7", "-2" }, { 0, "cmp(0,0)", "0" }, { 0, "cmp(1,0)", "1" }, { 0, "cmp(0,1)", "-1" }, { 0, "cmp(-1,0)", "-1" }, { 0, "cmp(0,-1)", "1" }, { 10, "0 ? 123 : 456", "456" }, { 10, "1 ? 4+5 : 6+7", "9" }, { 10, "(123)", "123" }, { 10, "(2+3)", "5" }, { 10, "(4+5)*(5+6)", "99" }, { 0, "1 << 16", "65536" }, { 0, "256 >> 4", "16" }, { 0, "-256 >> 4", "-16" }, { 0, "!1", "0" }, { 0, "!9", "0" }, { 0, "!0", "1" }, { 0, "2**2**2", "16" }, { 0, "-2**2**2", "-16" }, { 0, "0x100", "256" }, { 10, "0x100", NULL }, { 10, "0x 100", NULL }, { 0, " max ( 1, 2, 3, 4, 5, 6, 7, 8)", "8" }, { 0, " max ( 1, 9, 2, 3, 4, 5, 6, 7, 8)", "9" }, { 0, " min ( 1, 9, 2, 3, 4, 5, 6, 7, 8)", "1" }, { 10, "abs(123)", "123" }, { 10, "abs(-123)", "123" }, { 10, "abs(0)", "0" }, /* filling data stack */ { 0, "1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+1))))))))))))))", "16" }, /* filling control stack */ { 0, "----------------------------------------------------1", "1" }, }; const struct data_t data_z[] = { { 0, "divisible_p(333,3)", "1" }, { 0, "congruent_p(7,1,3)", "1" }, { 0, "cmpabs(0,0)", "0" }, { 0, "cmpabs(1,0)", "1" }, { 0, "cmpabs(0,1)", "-1" }, { 0, "cmpabs(-1,0)", "1" }, { 0, "cmpabs(0,-1)", "-1" }, { 0, "odd_p(1)", "1" }, { 0, "odd_p(0)", "0" }, { 0, "odd_p(-1)", "1" }, { 0, "even_p(1)", "0" }, { 0, "even_p(0)", "1" }, { 0, "even_p(-1)", "0" }, { 0, "fac(0)", "1" }, { 0, "fac(1)", "1" }, { 0, "fac(2)", "2" }, { 0, "fac(3)", "6" }, { 0, "fac(10)", "3628800" }, { 10, "root(81,4)", "3" }, { 10, "gcd(4,6)", "2" }, { 10, "gcd(4,6,9)", "1" }, { 10, "powm(3,2,9)", "0" }, { 10, "powm(3,2,8)", "1" }, /* filling data stack */ { 0, "1 ? 1 : 1 || 1 && 1 | 1 ^ 1 & 1 == 1 >= 1 << 1 - 1 * 1 ** 1", "1" }, /* filling control stack */ { 0, "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~1", "1" }, { 0, "fib(10)", "55" }, { 0, "setbit(0,5)", "32" }, { 0, "clrbit(32,5)", "0" }, { 0, "tstbit(32,5)", "1" }, { 0, "tstbit(32,4)", "0" }, { 0, "scan0(7,0)", "3" }, { 0, "scan1(7,0)", "0" }, }; const struct data_t data_zq[] = { /* expecting failure */ { 0, "1.2", NULL }, }; const struct data_t data_q[] = { { 10, "(1/2 + 1/3 + 1/4 + 1/5 + 1/6)*20", "29" }, { 0, "num(5/9)", "5" }, { 0, "den(5/9)", "9" }, }; const struct data_t data_zf[] = { { 10, "sqrt ( 49 )", "7" }, { 10, "sqrt ( 49 ) + 1", "8" }, { 10, "sqrt((49))", "7" }, { 10, "sqrt((((((((49))))))))", "7" }, }; const struct data_t data_f[] = { { 0, "1@10", "10000000000" }, { 0, "1.5@10", "15000000000" }, { 0, "1000@-1", "100" }, { 0, "10.00@-1", "1" }, { 0, "1e10", "10000000000" }, { 0, "1.5e10", "15000000000" }, { 0, "1000e-1", "100" }, { 0, "10.00e-1", "1" }, { 16, "1@9", "68719476736" }, { 16, "1@10", "18446744073709551616" }, { -16, "1@10", "1099511627776" }, { 0, "ceil(0)", "0" }, { 0, "ceil(0.25)", "1" }, { 0, "ceil(0.5)", "1" }, { 0, "ceil(1.5)", "2" }, { 0, "ceil(-0.5)", "0" }, { 0, "ceil(-1.5)", "-1" }, /* only simple cases because mpf_eq currently only works on whole limbs */ { 0, "eq(0xFFFFFFFFFFFFFFFF1111111111111111,0xFFFFFFFFFFFFFFFF2222222222222222,64)", "1" }, { 0, "eq(0xFFFFFFFFFFFFFFFF1111111111111111,0xFFFFFFFFFFFFFFFF2222222222222222,128)", "0" }, { 0, "floor(0)", "0" }, { 0, "floor(0.25)", "0" }, { 0, "floor(0.5)", "0" }, { 0, "floor(1.5)", "1" }, { 0, "floor(-0.5)", "-1" }, { 0, "floor(-1.5)", "-2" }, { 0, "integer_p(1)", "1" }, { 0, "integer_p(0.5)", "0" }, { 0, "trunc(0)", "0" }, { 0, "trunc(0.25)", "0" }, { 0, "trunc(0.5)", "0" }, { 0, "trunc(1.5)", "1" }, { 0, "trunc(-0.5)", "0" }, { 0, "trunc(-1.5)", "-1" }, }; struct datalist_t { const struct data_t *data; int num; }; #define DATALIST(data) { data, numberof (data) } struct datalist_t list_z[] = { DATALIST (data_z), DATALIST (data_zq), DATALIST (data_zf), DATALIST (data_zqf), }; struct datalist_t list_q[] = { DATALIST (data_q), DATALIST (data_zq), DATALIST (data_zqf), }; struct datalist_t list_f[] = { DATALIST (data_zf), DATALIST (data_zqf), DATALIST (data_f), }; void check_z (void) { const struct data_t *data; mpz_t a, b, got, want; int l, i, ret; mpz_init (got); mpz_init (want); mpz_init_set_ui (a, 55); mpz_init_set_ui (b, 99); for (l = 0; l < numberof (list_z); l++) { data = list_z[l].data; for (i = 0; i < list_z[l].num; i++) { if (option_trace) printf ("mpz_expr \"%s\"\n", data[i].expr); ret = mpz_expr (got, data[i].base, data[i].expr, a, b, NULL); if (data[i].want == NULL) { /* expect to fail */ if (ret == MPEXPR_RESULT_OK) { printf ("mpz_expr wrong return value, got %d, expected failure\n", ret); goto error; } } else { if (mpz_set_str (want, data[i].want, 0) != 0) { printf ("Cannot parse wanted value string\n"); goto error; } if (ret != MPEXPR_RESULT_OK) { printf ("mpz_expr failed unexpectedly\n"); printf (" return value %d\n", ret); goto error; } if (mpz_cmp (got, want) != 0) { printf ("mpz_expr wrong result\n"); printf (" got "); mpz_out_str (stdout, 10, got); printf ("\n"); printf (" want "); mpz_out_str (stdout, 10, want); printf ("\n"); goto error; } } } } mpz_clear (a); mpz_clear (b); mpz_clear (got); mpz_clear (want); return; error: printf (" base %d\n", data[i].base); printf (" expr \"%s\"\n", data[i].expr); if (data[i].want != NULL) printf (" want \"%s\"\n", data[i].want); abort (); } void check_q (void) { const struct data_t *data; mpq_t a, b, got, want; int l, i, ret; mpq_init (got); mpq_init (want); mpq_init (a); mpq_init (b); mpq_set_ui (a, 55, 1); mpq_set_ui (b, 99, 1); for (l = 0; l < numberof (list_q); l++) { data = list_q[l].data; for (i = 0; i < list_q[l].num; i++) { if (option_trace) printf ("mpq_expr \"%s\"\n", data[i].expr); ret = mpq_expr (got, data[i].base, data[i].expr, a, b, NULL); if (data[i].want == NULL) { /* expect to fail */ if (ret == MPEXPR_RESULT_OK) { printf ("mpq_expr wrong return value, got %d, expected failure\n", ret); goto error; } } else { if (mpz_set_str (mpq_numref(want), data[i].want, 0) != 0) { printf ("Cannot parse wanted value string\n"); goto error; } mpz_set_ui (mpq_denref(want), 1); if (ret != MPEXPR_RESULT_OK) { printf ("mpq_expr failed unexpectedly\n"); printf (" return value %d\n", ret); goto error; } if (mpq_cmp (got, want) != 0) { printf ("mpq_expr wrong result\n"); printf (" got "); mpq_out_str (stdout, 10, got); printf ("\n"); printf (" want "); mpq_out_str (stdout, 10, want); printf ("\n"); goto error; } } } } mpq_clear (a); mpq_clear (b); mpq_clear (got); mpq_clear (want); return; error: printf (" base %d\n", data[i].base); printf (" expr \"%s\"\n", data[i].expr); if (data[i].want != NULL) printf (" want \"%s\"\n", data[i].want); abort (); } void check_f (void) { const struct data_t *data; mpf_t a, b, got, want; int l, i, ret; mpf_set_default_prec (200L); mpf_init (got); mpf_init (want); mpf_init_set_ui (a, 55); mpf_init_set_ui (b, 99); for (l = 0; l < numberof (list_f); l++) { data = list_f[l].data; for (i = 0; i < list_f[l].num; i++) { if (option_trace) printf ("mpf_expr \"%s\"\n", data[i].expr); ret = mpf_expr (got, data[i].base, data[i].expr, a, b, NULL); if (data[i].want == NULL) { /* expect to fail */ if (ret == MPEXPR_RESULT_OK) { printf ("mpf_expr wrong return value, got %d, expected failure\n", ret); goto error; } } else { if (mpf_set_str (want, data[i].want, 0) != 0) { printf ("Cannot parse wanted value string\n"); goto error; } if (ret != MPEXPR_RESULT_OK) { printf ("mpf_expr failed unexpectedly\n"); printf (" return value %d\n", ret); goto error; } if (mpf_cmp (got, want) != 0) { printf ("mpf_expr wrong result\n"); printf (" got "); mpf_out_str (stdout, 10, 20, got); printf ("\n"); printf (" want "); mpf_out_str (stdout, 10, 20, want); printf ("\n"); goto error; } } } } mpf_clear (a); mpf_clear (b); mpf_clear (got); mpf_clear (want); return; error: printf (" base %d\n", data[i].base); printf (" expr \"%s\"\n", data[i].expr); if (data[i].want != NULL) printf (" want \"%s\"\n", data[i].want); abort (); } int main (int argc, char *argv[]) { tests_start (); if (argc >= 2) option_trace = 1; check_z (); check_q (); check_f (); tests_end (); exit (0); } gcl-2.6.14/gmp4/demos/expr/README0000644000175000017500000004550514360276512014620 0ustar cammcammCopyright 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. GMP EXPRESSION EVALUATION ------------------------- THIS CODE IS PRELIMINARY AND MAY BE SUBJECT TO INCOMPATIBLE CHANGES IN FUTURE VERSIONS OF GMP. The files in this directory implement a simple scheme of string based expression parsing and evaluation, supporting mpz, mpq and mpf. This will be slower than direct GMP library calls, but may be convenient in various circumstances, such as while prototyping, or for letting a user enter values in symbolic form. "2**5723-7" for example is a lot easier to enter or maintain than the equivalent written out in decimal. BUILDING Nothing in this directory is a normal part of libgmp, and nothing is built or installed, but various Makefile rules are available to compile everything. All the functions are available through a little library (there's no shared library since upward binary compatibility is not guaranteed). make libexpr.a In a program, prototypes are available using #include "expr.h" run-expr.c is a sample program doing evaluations from the command line. make run-expr ./run-expr '1+2*3' t-expr.c is self-test program, it prints nothing if successful. make t-expr ./t-expr The expr*.c sources don't depend on gmp-impl.h and can be compiled with just a standard installed GMP. This isn't true of t-expr though, since it uses some of the internal tests/libtests.la. SIMPLE USAGE int mpz_expr (mpz_t res, int base, const char *e, ...); int mpq_expr (mpq_t res, int base, const char *e, ...); int mpf_expr (mpf_t res, int base, const char *e, ...); These functions evaluate simple arithmetic expressions. For example, mpz_expr (result, 0, "123+456", NULL); Numbers are parsed by mpz_expr and mpq_expr the same as mpz_set_str with the given base. mpf_expr follows mpf_set_str, but supporting an "0x" prefix for hex when base==0. mpz_expr (result, 0, "0xAAAA * 0x5555", NULL); White space, as indicated by isspace(), is ignored except for the purpose of separating tokens. Variables can be included in expressions by putting them in the stdarg list after the string. "a", "b", "c" etc in the expression string designate those values. For example, mpq_t foo, bar; ... mpq_expr (q, 10, "2/3 + 1/a + b/2", foo, bar, NULL); Here "a" will be the value from foo and "b" from bar. Up to 26 variables can be included this way. The NULL must be present to indicate the end of the list. Variables can also be written "$a", "$b" etc. This is necessary when using bases greater than 10 since plain "a", "b" etc will otherwise be interpreted as numbers. For example, mpf_t quux; mpf_expr (f, 16, "F00F@-6 * $a", quux, NULL); All the standard C operators are available, with the usual precedences, plus "**" for exponentiation at the highest precedence (and right associative). Operators Precedence ** 220 ~ ! - (unary) 210 * / % 200 + - 190 << >> 180 <= < >= > 170 == != 160 & 150 ^ 140 | 130 && 120 || 110 ? : 100/101 Currently only mpz_expr has the bitwise ~ % & ^ and | operators. The precedence numbers are of interest in the advanced usage described below. Various functions are available too. For example, mpz_expr (res, 10, "gcd(123,456,789) * abs(a)", var, NULL); The following is the full set of functions, mpz_expr abs bin clrbit cmp cmpabs congruent_p divisible_p even_p fib fac gcd hamdist invert jacobi kronecker lcm lucnum max min nextprime odd_p perfect_power_p perfect_square_p popcount powm probab_prime_p root scan0 scan1 setbit sgn sqrt mpq_expr abs, cmp, den, max, min, num, sgn mpf_expr abs, ceil, cmp, eq, floor, integer_p, max, min, reldiff, sgn, sqrt, trunc All these are the same as the GMP library functions, except that min and max don't exist in the library. Note also that min, max, gcd and lcm take any number of arguments, not just two. mpf_expr does all calculations to the precision of the destination variable. Expression parsing can succeed or fail. The return value indicates this, and will be one of the following MPEXPR_RESULT_OK MPEXPR_RESULT_BAD_VARIABLE MPEXPR_RESULT_BAD_TABLE MPEXPR_RESULT_PARSE_ERROR MPEXPR_RESULT_NOT_UI BAD_VARIABLE is when a variable is referenced that hasn't been provided. For example if "c" is used when only two parameters have been passed. BAD_TABLE is applicable to the advanced usage described below. PARSE_ERROR is a general syntax error, returned for any mal-formed input string. NOT_UI is returned when an attempt is made to use an operand that's bigger than an "unsigned long" with a function that's restricted to that range. For example "fib" is mpz_fib_ui and only accepts an "unsigned long". ADVANCED USAGE int mpz_expr_a (const struct mpexpr_operator_t *table, mpz_ptr res, int base, const char *e, size_t elen, mpz_srcptr var[26]) int mpq_expr_a (const struct mpexpr_operator_t *table, mpq_ptr res, int base, const char *e, size_t elen, mpq_srcptr var[26]) int mpf_expr_a (const struct mpexpr_operator_t *table, mpf_ptr res, int base, unsigned long prec, const char *e, size_t elen, mpf_srcptr var[26]) These functions are an advanced interface to expression parsing. The string is taken as pointer and length. This makes it possible to parse an expression in the middle of somewhere without copying and null terminating it. Variables are an array of 26 pointers to the appropriate operands, or NULL for variables that are not available. Any combination of variables can be given, for example just "x" and "y" (var[23] and var[24]) could be set. Operators and functions are specified with a table. This makes it possible to provide additional operators or functions, or to completely change the syntax. The standard tables used by the simple functions above are available as const struct mpexpr_operator_t * const mpz_expr_standard_table; const struct mpexpr_operator_t * const mpq_expr_standard_table; const struct mpexpr_operator_t * const mpf_expr_standard_table; struct mpexpr_operator_t is the following struct mpexpr_operator_t { const char *name; mpexpr_fun_t fun; int type; int precedence; }; typedef void (*mpexpr_fun_t) (void); As an example, the standard mpz_expr table entry for multiplication is as follows. See the source code for the full set of standard entries. { "*", (mpexpr_fun_t) mpz_mul, MPEXPR_TYPE_BINARY, 200 }, "name" is the string to parse, "fun" is the function to call for it, "type" indicates what parameters the function takes (among other things), and "precedence" sets its operator precedence. A NULL for "name" indicates the end of the table, so for example an mpf table with nothing but addition could be struct mpexpr_operator_t table[] = { { "+", (mpexpr_fun_t) mpf_add, MPEXPR_TYPE_BINARY, 190 }, { NULL } }; A special type MPEXPR_TYPE_NEW_TABLE makes it possible to chain from one table to another. For example the following would add a "mod" operator to the standard mpz table, struct mpexpr_operator_t table[] = { { "mod", (mpexpr_fun_t) mpz_fdiv_r, MPEXPR_TYPE_BINARY, 125 }, { (const char *) mpz_expr_standard_table, NULL, MPEXPR_TYPE_NEW_TABLE } }; Notice the low precedence on "mod", so that for instance "45+26 mod 7" parses as "(45+26)mod7". Functions are designated by a precedence of 0. They always occur as "foo(expr)" and so have no need for a precedence level. mpq_abs in the standard mpq table is { "abs", (mpexpr_fun_t) mpq_abs, MPEXPR_TYPE_UNARY }, Functions expecting no arguments as in "foo()" can be given with MPEXPR_TYPE_0ARY, or actual constants to be parsed as just "foo" are MPEXPR_TYPE_CONSTANT. For example if a "void mpf_const_pi(mpf_t f)" function existed (which it doesn't) it could be, { "pi", (mpexpr_fun_t) mpf_const_pi, MPEXPR_TYPE_CONSTANT }, Parsing of operator names is done by seeking the table entry with the longest matching name. So for instance operators "<" and "<=" exist, and when presented with "x <= y" the parser matches "<=" because it's longer. Parsing of function names, on the other hand, is done by requiring a whole alphanumeric word to match. For example presented with "fib2zz(5)" the parser will attempt to find a function called "fib2zz". A function "fib" wouldn't be used because it doesn't match the whole word. The flag MPEXPR_TYPE_WHOLEWORD can be ORed into an operator type to override the default parsing style. Similarly MPEXPR_TYPE_OPERATOR into a function. Binary operators are left associative by default, meaning they're evaluated from left to right, so for example "1+2+3" is treated as "(1+2)+3". MPEXPR_TYPE_RIGHTASSOC can be ORed into the operator type to work from right to left as in "1+(2+3)". This is generally what's wanted for exponentiation, and for example the standard mpz table has { "**", (mpexpr_fun_t) mpz_pow_ui, MPEXPR_TYPE_BINARY_UI | MPEXPR_TYPE_RIGHTASSOC, 220 } Unary operators are postfix by default. For example a factorial to be used as "123!" might be { "!", (mpexpr_fun_t) mpz_fac_ui, MPEXPR_TYPE_UNARY_UI, 215 } MPEXPR_TYPE_PREFIX can be ORed into the type to get a prefix operator. For instance negation (unary minus) in the standard mpf table is { "-", (mpexpr_fun_t) mpf_neg, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 210 }, The same operator can exist as a prefix unary and a binary, or as a prefix and postfix unary, simply by putting two entries in the table. While parsing the context determines which style is sought. But note that the same operator can't be both a postfix unary and a binary, since the parser doesn't try to look ahead to decide which ought to be used. When there's two entries for an operator, both prefix or both postfix (or binary), then the first in the table will be used. This makes it possible to override an entry in a standard table, for example to change the function it calls, or perhaps its precedence level. The following would change mpz division from tdiv to cdiv, struct mpexpr_operator_t table[] = { { "/", (mpexpr_fun_t) mpz_cdiv_q, MPEXPR_TYPE_BINARY, 200 }, { "%", (mpexpr_fun_t) mpz_cdiv_r, MPEXPR_TYPE_BINARY, 200 }, { (char *) mpz_expr_standard_table, NULL, MPEXPR_TYPE_NEW_TABLE } }; The type field indicates what parameters the given function expects. The following styles of functions are supported. mpz_t is shown, but of course this is mpq_t for mpq_expr_a, mpf_t for mpf_expr_a, etc. MPEXPR_TYPE_CONSTANT void func (mpz_t result); MPEXPR_TYPE_0ARY void func (mpz_t result); MPEXPR_TYPE_I_0ARY int func (void); MPEXPR_TYPE_UNARY void func (mpz_t result, mpz_t op); MPEXPR_TYPE_UNARY_UI void func (mpz_t result, unsigned long op); MPEXPR_TYPE_I_UNARY int func (mpz_t op); MPEXPR_TYPE_I_UNARY_UI int func (unsigned long op); MPEXPR_TYPE_BINARY void func (mpz_t result, mpz_t op1, mpz_t op2); MPEXPR_TYPE_BINARY_UI void func (mpz_t result, mpz_t op1, unsigned long op2); MPEXPR_TYPE_I_BINARY int func (mpz_t op1, mpz_t op2); MPEXPR_TYPE_I_BINARY_UI int func (mpz_t op1, unsigned long op2); MPEXPR_TYPE_TERNARY void func (mpz_t result, mpz_t op1, mpz_t op2, mpz_t op3); MPEXPR_TYPE_TERNARY_UI void func (mpz_t result, mpz_t op1, mpz_t op2, unsigned long op3); MPEXPR_TYPE_I_TERNARY int func (mpz_t op1, mpz_t op2, mpz_t op3); MPEXPR_TYPE_I_TERNARY_UI int func (mpz_t op1, mpz_t op2, unsigned long op3); Notice the pattern of "UI" for the last parameter as an unsigned long, or "I" for the result as an "int" return value. It's important that the declared type for an operator or function matches the function pointer given. Any mismatch will have unpredictable results. For binary functions, a further type attribute is MPEXPR_TYPE_PAIRWISE which indicates that any number of arguments should be accepted, and evaluated by applying the given binary function to them pairwise. This is used by gcd, lcm, min and max. For example the standard mpz gcd is { "gcd", (mpexpr_fun_t) mpz_gcd, MPEXPR_TYPE_BINARY | MPEXPR_TYPE_PAIRWISE }, Some special types exist for comparison operators (or functions). MPEXPR_TYPE_CMP_LT through MPEXPR_TYPE_CMP_GE expect an MPEXPR_TYPE_I_BINARY function, returning positive, negative or zero like mpz_cmp and similar. For example the standard mpf "!=" operator is { "!=", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_CMP_NE, 160 }, But there's no obligation to use these types, for instance the standard mpq table just uses a plain MPEXPR_TYPE_I_BINARY and mpq_equal for "==". Further special types MPEXPR_TYPE_MIN and MPEXPR_TYPE_MAX exist to implement the min and max functions, and they take a function like mpf_cmp similarly. The standard mpf max function is { "max", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_MAX | MPEXPR_TYPE_PAIRWISE }, These can be used as operators too, for instance the following would be the >? operator which is a feature of GNU C++, { ">?", (mpexpr_fun_t) mpf_cmp, MPEXPR_TYPE_MAX, 175 }, Other special types are used to define "(" ")" parentheses, "," function argument separator, "!" through "||" logical booleans, ternary "?" ":", and the "$" which introduces variables. See the sources for how they should be used. User definable operator tables will have various uses. For example, - a subset of the C operators, to be rid of infrequently used things - a more mathematical syntax like "." for multiply, "^" for powering, and "!" for factorial - a boolean evaluator with "^" for AND, "v" for OR - variables introduced with "%" instead of "$" - brackets as "[" and "]" instead of "(" and ")" The only fixed parts of the parsing are the treatment of numbers, whitespace and the two styles of operator/function name recognition. As a final example, the following would be a complete mpz table implementing some operators with a more mathematical syntax. Notice there's no need to preserve the standard precedence values, anything can be used so long as they're in the desired relation to each other. There's also no need to have entries in precedence order, but it's convenient to do so to show what comes where. static const struct mpexpr_operator_t table[] = { { "^", (mpexpr_fun_t) mpz_pow_ui, MPEXPR_TYPE_BINARY_UI | MPEXPR_TYPE_RIGHTASSOC, 9 }, { "!", (mpexpr_fun_t) mpz_fac_ui, MPEXPR_TYPE_UNARY_UI, 8 }, { "-", (mpexpr_fun_t) mpz_neg, MPEXPR_TYPE_UNARY | MPEXPR_TYPE_PREFIX, 7 }, { "*", (mpexpr_fun_t) mpz_mul, MPEXPR_TYPE_BINARY, 6 }, { "/", (mpexpr_fun_t) mpz_fdiv_q, MPEXPR_TYPE_BINARY, 6 }, { "+", (mpexpr_fun_t) mpz_add, MPEXPR_TYPE_BINARY, 5 }, { "-", (mpexpr_fun_t) mpz_sub, MPEXPR_TYPE_BINARY, 5 }, { "mod", (mpexpr_fun_t) mpz_mod, MPEXPR_TYPE_BINARY, 6 }, { ")", NULL, MPEXPR_TYPE_CLOSEPAREN, 4 }, { "(", NULL, MPEXPR_TYPE_OPENPAREN, 3 }, { ",", NULL, MPEXPR_TYPE_ARGSEP, 2 }, { "$", NULL, MPEXPR_TYPE_VARIABLE, 1 }, { NULL } }; INTERNALS Operator precedence is implemented using a control and data stack, there's no C recursion. When an expression like 1+2*3 is read the "+" is held on the control stack and 1 on the data stack until "*" has been parsed and applied to 2 and 3. This happens any time a higher precedence operator follows a lower one, or when a right-associative operator like "**" is repeated. Parentheses are handled by making "(" a special prefix unary with a low precedence so a whole following expression is read. The special operator ")" knows to discard the pending "(". Function arguments are handled similarly, with the function pretending to be a low precedence prefix unary operator, and with "," allowed within functions. The same special ")" operator recognises a pending function and will invoke it appropriately. The ternary "? :" operator is also handled using precedences. ":" is one level higher than "?", so when a valid a?b:c is parsed the ":" finds a "?" on the control stack. It's a parse error for ":" to find anything else. FUTURE The ternary "?:" operator evaluates the "false" side of its pair, which is wasteful, though it ought to be harmless. It'd be better if it could evaluate only the "true" side. Similarly for the logical booleans "&&" and "||" if they know their result already. Functions like MPEXPR_TYPE_BINARY could return a status indicating operand out of range or whatever, to get an error back through mpz_expr etc. That would want to be just an option, since plain mpz_add etc have no such return. Could have assignments like "a = b*c" modifying the input variables. Assignment could be an operator attribute, making it expect an lvalue. There would want to be a standard table without assignments available though, so user input could be safely parsed. The closing parenthesis table entry could specify the type of open paren it expects, so that "(" and ")" could match and "[" and "]" match but not a mixture of the two. Currently "[" and "]" can be added, but there's no error on writing a mixed expression like "2*(3+4]". Maybe also there could be a way to say that functions can only be written with one or the other style of parens. ---------------- Local variables: mode: text fill-column: 76 End: gcl-2.6.14/gmp4/demos/expr/Makefile.in0000644000175000017500000004622014360276512016000 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 2001-2004 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ EXTRA_PROGRAMS = run-expr$(EXEEXT) t-expr$(EXEEXT) subdir = demos/expr DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am README ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = AM_V_AR = $(am__v_AR_@AM_V@) am__v_AR_ = $(am__v_AR_@AM_DEFAULT_V@) am__v_AR_0 = @echo " AR " $@; am__v_AR_1 = libexpr_a_AR = $(AR) $(ARFLAGS) libexpr_a_LIBADD = am_libexpr_a_OBJECTS = expr.$(OBJEXT) exprv.$(OBJEXT) exprz.$(OBJEXT) \ exprza.$(OBJEXT) exprq.$(OBJEXT) exprqa.$(OBJEXT) \ exprf.$(OBJEXT) exprfa.$(OBJEXT) libexpr_a_OBJECTS = $(am_libexpr_a_OBJECTS) run_expr_SOURCES = run-expr.c run_expr_OBJECTS = run-expr.$(OBJEXT) run_expr_LDADD = $(LDADD) run_expr_DEPENDENCIES = libexpr.a $(top_builddir)/libgmp.la AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = t_expr_SOURCES = t-expr.c t_expr_OBJECTS = t-expr.$(OBJEXT) t_expr_DEPENDENCIES = $(top_builddir)/tests/libtests.la $(LDADD) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(libexpr_a_SOURCES) run-expr.c t-expr.c DIST_SOURCES = $(libexpr_a_SOURCES) run-expr.c t-expr.c am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ INCLUDES = -I$(top_srcdir) -I$(top_srcdir)/tests # FIXME: This is a workaround for a bug in automake 1.8.4. When the only # library is in EXTRA_LIBRARIES, $(ARFLAGS) is used but no default setting # for that variable is established. We give an explicit ARFLAGS=cru the # same as generated for lib_LIBRARIES or noinst_LIBRARIES. # ARFLAGS = cru EXTRA_LIBRARIES = libexpr.a libexpr_a_SOURCES = expr.h expr-impl.h \ expr.c exprv.c exprz.c exprza.c exprq.c exprqa.c exprf.c exprfa.c LDADD = libexpr.a $(top_builddir)/libgmp.la t_expr_LDADD = $(top_builddir)/tests/libtests.la $(LDADD) CLEANFILES = $(EXTRA_PROGRAMS) $(EXTRA_LIBRARIES) all: all-am .SUFFIXES: .SUFFIXES: .c .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps demos/expr/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps demos/expr/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): libexpr.a: $(libexpr_a_OBJECTS) $(libexpr_a_DEPENDENCIES) $(EXTRA_libexpr_a_DEPENDENCIES) $(AM_V_at)-rm -f libexpr.a $(AM_V_AR)$(libexpr_a_AR) libexpr.a $(libexpr_a_OBJECTS) $(libexpr_a_LIBADD) $(AM_V_at)$(RANLIB) libexpr.a run-expr$(EXEEXT): $(run_expr_OBJECTS) $(run_expr_DEPENDENCIES) $(EXTRA_run_expr_DEPENDENCIES) @rm -f run-expr$(EXEEXT) $(AM_V_CCLD)$(LINK) $(run_expr_OBJECTS) $(run_expr_LDADD) $(LIBS) t-expr$(EXEEXT): $(t_expr_OBJECTS) $(t_expr_DEPENDENCIES) $(EXTRA_t_expr_DEPENDENCIES) @rm -f t-expr$(EXEEXT) $(AM_V_CCLD)$(LINK) $(t_expr_OBJECTS) $(t_expr_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool cscopelist-am ctags ctags-am distclean \ distclean-compile distclean-generic distclean-libtool \ distclean-tags distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-pdf install-pdf-am install-ps install-ps-am \ install-strip installcheck installcheck-am installdirs \ maintainer-clean maintainer-clean-generic mostlyclean \ mostlyclean-compile mostlyclean-generic mostlyclean-libtool \ pdf pdf-am ps ps-am tags tags-am uninstall uninstall-am allprogs: $(EXTRA_PROGRAMS) $(top_builddir)/tests/libtests.la: cd $(top_builddir)/tests; $(MAKE) $(AM_MAKEFLAGS) libtests.la # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/demos/pexpr-config-h.in0000644000175000017500000000315114360276512016127 0ustar cammcamm/* Templates for pexpr program configuration. -*- mode:c -*- Copyright 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ /* Define if you have the header file. */ #define HAVE_SYS_RESOURCE_H @HAVE_SYS_RESOURCE_H_01@ /* Define if you have the `clock' function. */ #define HAVE_CLOCK @HAVE_CLOCK_01@ /* Define if you have the `cputime' function. */ #define HAVE_CPUTIME @HAVE_CPUTIME_01@ /* Define if you have the `getrusage' function. */ #define HAVE_GETRUSAGE @HAVE_GETRUSAGE_01@ /* Define if you have the `gettimeofday' function. */ #define HAVE_GETTIMEOFDAY @HAVE_GETTIMEOFDAY_01@ /* Define if you have the `sigaction' function. */ #define HAVE_SIGACTION @HAVE_SIGACTION_01@ /* Define if you have the `sigaltstack' function. */ #define HAVE_SIGALTSTACK @HAVE_SIGALTSTACK_01@ /* Define if you have the `sigstack' function. */ #define HAVE_SIGSTACK @HAVE_SIGSTACK_01@ /* Define if the system has the type `stack_t'. */ #define HAVE_STACK_T @HAVE_STACK_T_01@ gcl-2.6.14/gmp4/demos/Makefile.in0000644000175000017500000005665714360276512015041 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 2000-2002, 2012 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ EXTRA_PROGRAMS = factorize$(EXEEXT) isprime$(EXEEXT) pexpr$(EXEEXT) \ primes$(EXEEXT) qcn$(EXEEXT) subdir = demos DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am \ $(srcdir)/pexpr-config-h.in ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = pexpr-config.h CONFIG_CLEAN_VPATH_FILES = factorize_SOURCES = factorize.c factorize_OBJECTS = factorize.$(OBJEXT) factorize_LDADD = $(LDADD) factorize_DEPENDENCIES = $(top_builddir)/libgmp.la AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = isprime_SOURCES = isprime.c isprime_OBJECTS = isprime.$(OBJEXT) isprime_LDADD = $(LDADD) isprime_DEPENDENCIES = $(top_builddir)/libgmp.la pexpr_SOURCES = pexpr.c pexpr_OBJECTS = pexpr.$(OBJEXT) pexpr_LDADD = $(LDADD) pexpr_DEPENDENCIES = $(top_builddir)/libgmp.la primes_SOURCES = primes.c primes_OBJECTS = primes.$(OBJEXT) am__DEPENDENCIES_1 = primes_DEPENDENCIES = $(LDADD) $(am__DEPENDENCIES_1) qcn_SOURCES = qcn.c qcn_OBJECTS = qcn.$(OBJEXT) qcn_DEPENDENCIES = $(LDADD) $(am__DEPENDENCIES_1) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = factorize.c isprime.c pexpr.c primes.c qcn.c DIST_SOURCES = factorize.c isprime.c pexpr.c primes.c qcn.c RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ ctags-recursive dvi-recursive html-recursive info-recursive \ install-data-recursive install-dvi-recursive \ install-exec-recursive install-html-recursive \ install-info-recursive install-pdf-recursive \ install-ps-recursive install-recursive installcheck-recursive \ installdirs-recursive pdf-recursive ps-recursive \ tags-recursive uninstall-recursive am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ distclean-recursive maintainer-clean-recursive am__recursive_targets = \ $(RECURSIVE_TARGETS) \ $(RECURSIVE_CLEAN_TARGETS) \ $(am__extra_recursive_targets) AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ distdir am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DIST_SUBDIRS = $(SUBDIRS) DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) am__relativize = \ dir0=`pwd`; \ sed_first='s,^\([^/]*\)/.*$$,\1,'; \ sed_rest='s,^[^/]*/*,,'; \ sed_last='s,^.*/\([^/]*\)$$,\1,'; \ sed_butlast='s,/*[^/]*$$,,'; \ while test -n "$$dir1"; do \ first=`echo "$$dir1" | sed -e "$$sed_first"`; \ if test "$$first" != "."; then \ if test "$$first" = ".."; then \ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ else \ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ if test "$$first2" = "$$first"; then \ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ else \ dir2="../$$dir2"; \ fi; \ dir0="$$dir0"/"$$first"; \ fi; \ fi; \ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ done; \ reldir="$$dir2" ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ SUBDIRS = calc expr EXTRA_DIST = perl primes.h INCLUDES = -I$(top_srcdir) LDADD = $(top_builddir)/libgmp.la qcn_LDADD = $(LDADD) $(LIBM) primes_LDADD = $(LDADD) $(LIBM) CLEANFILES = $(EXTRA_PROGRAMS) all: all-recursive .SUFFIXES: .SUFFIXES: .c .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps demos/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps demos/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): pexpr-config.h: $(top_builddir)/config.status $(srcdir)/pexpr-config-h.in cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ factorize$(EXEEXT): $(factorize_OBJECTS) $(factorize_DEPENDENCIES) $(EXTRA_factorize_DEPENDENCIES) @rm -f factorize$(EXEEXT) $(AM_V_CCLD)$(LINK) $(factorize_OBJECTS) $(factorize_LDADD) $(LIBS) isprime$(EXEEXT): $(isprime_OBJECTS) $(isprime_DEPENDENCIES) $(EXTRA_isprime_DEPENDENCIES) @rm -f isprime$(EXEEXT) $(AM_V_CCLD)$(LINK) $(isprime_OBJECTS) $(isprime_LDADD) $(LIBS) pexpr$(EXEEXT): $(pexpr_OBJECTS) $(pexpr_DEPENDENCIES) $(EXTRA_pexpr_DEPENDENCIES) @rm -f pexpr$(EXEEXT) $(AM_V_CCLD)$(LINK) $(pexpr_OBJECTS) $(pexpr_LDADD) $(LIBS) primes$(EXEEXT): $(primes_OBJECTS) $(primes_DEPENDENCIES) $(EXTRA_primes_DEPENDENCIES) @rm -f primes$(EXEEXT) $(AM_V_CCLD)$(LINK) $(primes_OBJECTS) $(primes_LDADD) $(LIBS) qcn$(EXEEXT): $(qcn_OBJECTS) $(qcn_DEPENDENCIES) $(EXTRA_qcn_DEPENDENCIES) @rm -f qcn$(EXEEXT) $(AM_V_CCLD)$(LINK) $(qcn_OBJECTS) $(qcn_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs # This directory's subdirectories are mostly independent; you can cd # into them and run 'make' without going through this Makefile. # To change the values of 'make' variables: instead of editing Makefiles, # (1) if the variable is set in 'config.status', edit 'config.status' # (which will cause the Makefiles to be regenerated when you run 'make'); # (2) otherwise, pass the desired values on the 'make' command line. $(am__recursive_targets): @fail=; \ if $(am__make_keepgoing); then \ failcom='fail=yes'; \ else \ failcom='exit 1'; \ fi; \ dot_seen=no; \ target=`echo $@ | sed s/-recursive//`; \ case "$@" in \ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ *) list='$(SUBDIRS)' ;; \ esac; \ for subdir in $$list; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ dot_seen=yes; \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done; \ if test "$$dot_seen" = "no"; then \ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ fi; test -z "$$fail" ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-recursive TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ include_option=--etags-include; \ empty_fix=.; \ else \ include_option=--include; \ empty_fix=; \ fi; \ list='$(SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test ! -f $$subdir/TAGS || \ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ fi; \ done; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-recursive CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-recursive cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ $(am__make_dryrun) \ || test -d "$(distdir)/$$subdir" \ || $(MKDIR_P) "$(distdir)/$$subdir" \ || exit 1; \ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ $(am__relativize); \ new_distdir=$$reldir; \ dir1=$$subdir; dir2="$(top_distdir)"; \ $(am__relativize); \ new_top_distdir=$$reldir; \ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ ($(am__cd) $$subdir && \ $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$$new_top_distdir" \ distdir="$$new_distdir" \ am__remove_distdir=: \ am__skip_length_check=: \ am__skip_mode_fix=: \ distdir) \ || exit 1; \ fi; \ done check-am: all-am check: check-recursive all-am: Makefile installdirs: installdirs-recursive installdirs-am: install: install-recursive install-exec: install-exec-recursive install-data: install-data-recursive uninstall: uninstall-recursive install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-recursive install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-recursive clean-am: clean-generic clean-libtool mostlyclean-am distclean: distclean-recursive -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-recursive dvi-am: html: html-recursive html-am: info: info-recursive info-am: install-data-am: install-dvi: install-dvi-recursive install-dvi-am: install-exec-am: install-html: install-html-recursive install-html-am: install-info: install-info-recursive install-info-am: install-man: install-pdf: install-pdf-recursive install-pdf-am: install-ps: install-ps-recursive install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-recursive -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-recursive mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-recursive pdf-am: ps: ps-recursive ps-am: uninstall-am: .MAKE: $(am__recursive_targets) install-am install-strip .PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am check \ check-am clean clean-generic clean-libtool cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs installdirs-am maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am allprogs: $(EXTRA_PROGRAMS) cd calc; $(MAKE) $(AM_MAKEFLAGS) allprogs cd expr; $(MAKE) $(AM_MAKEFLAGS) allprogs # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/demos/primes.c0000644000175000017500000002326114360276512014420 0ustar cammcamm/* List and count primes. Written by tege while on holiday in Rodupp, August 2001. Between 10 and 500 times faster than previous program. Copyright 2001, 2002, 2006, 2012 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see https://www.gnu.org/licenses/. */ #include #include #include #include #include /* IDEAS: * Do not fill primes[] with real primes when the range [fr,to] is small, when fr,to are relatively large. Fill primes[] with odd numbers instead. [Probably a bad idea, since the primes[] array would become very large.] * Separate small primes and large primes when sieving. Either the Montgomery way (i.e., having a large array a multiple of L1 cache size), or just separate loops for primes <= S and primes > S. The latter primes do not require an inner loop, since they will touch the sieving array at most once. * Pre-fill sieving array with an appropriately aligned ...00100100... pattern, then omit 3 from primes array. (May require similar special handling of 3 as we now have for 2.) * A large SIEVE_LIMIT currently implies very large memory usage, mainly due to the sieving array in make_primelist, but also because of the primes[] array. We might want to stage the program, using sieve_region/find_primes to build primes[]. Make report() a function pointer, as part of achieving this. * Store primes[] as two arrays, one array with primes represented as delta values using just 8 bits (if gaps are too big, store bogus primes!) and one array with "rem" values. The latter needs 32-bit values. * A new entry point, mpz_probab_prime_likely_p, would be useful. * Improve command line syntax and versatility. "primes -f FROM -t TO", allow either to be omitted for open interval. (But disallow "primes -c -f FROM" since that would be infinity.) Allow printing a limited *number* of primes using syntax like "primes -f FROM -n NUMBER". * When looking for maxgaps, we should not perform any primality testing until we find possible record gaps. Should speed up the searches tremendously. */ #include "gmp.h" struct primes { unsigned int prime; int rem; }; struct primes *primes; unsigned long n_primes; void find_primes (unsigned char *, mpz_t, unsigned long, mpz_t); void sieve_region (unsigned char *, mpz_t, unsigned long); void make_primelist (unsigned long); int flag_print = 1; int flag_count = 0; int flag_maxgap = 0; unsigned long maxgap = 0; unsigned long total_primes = 0; void report (mpz_t prime) { total_primes += 1; if (flag_print) { mpz_out_str (stdout, 10, prime); printf ("\n"); } if (flag_maxgap) { static unsigned long prev_prime_low = 0; unsigned long gap; if (prev_prime_low != 0) { gap = mpz_get_ui (prime) - prev_prime_low; if (maxgap < gap) maxgap = gap; } prev_prime_low = mpz_get_ui (prime); } } int main (int argc, char *argv[]) { char *progname = argv[0]; mpz_t fr, to; mpz_t fr2, to2; unsigned long sieve_lim; unsigned long est_n_primes; unsigned char *s; mpz_t tmp; mpz_t siev_sqr_lim; while (argc != 1) { if (strcmp (argv[1], "-c") == 0) { flag_count = 1; argv++; argc--; } else if (strcmp (argv[1], "-p") == 0) { flag_print = 2; argv++; argc--; } else if (strcmp (argv[1], "-g") == 0) { flag_maxgap = 1; argv++; argc--; } else break; } if (flag_count || flag_maxgap) flag_print--; /* clear unless an explicit -p */ mpz_init (fr); mpz_init (to); mpz_init (fr2); mpz_init (to2); if (argc == 3) { mpz_set_str (fr, argv[1], 0); if (argv[2][0] == '+') { mpz_set_str (to, argv[2] + 1, 0); mpz_add (to, to, fr); } else mpz_set_str (to, argv[2], 0); } else if (argc == 2) { mpz_set_ui (fr, 0); mpz_set_str (to, argv[1], 0); } else { fprintf (stderr, "usage: %s [-c] [-p] [-g] [from [+]]to\n", progname); exit (1); } mpz_set (fr2, fr); if (mpz_cmp_ui (fr2, 3) < 0) { mpz_set_ui (fr2, 2); report (fr2); mpz_set_ui (fr2, 3); } mpz_setbit (fr2, 0); /* make odd */ mpz_sub_ui (to2, to, 1); mpz_setbit (to2, 0); /* make odd */ mpz_init (tmp); mpz_init (siev_sqr_lim); mpz_sqrt (tmp, to2); #define SIEVE_LIMIT 10000000 if (mpz_cmp_ui (tmp, SIEVE_LIMIT) < 0) { sieve_lim = mpz_get_ui (tmp); } else { sieve_lim = SIEVE_LIMIT; mpz_sub (tmp, to2, fr2); if (mpz_cmp_ui (tmp, sieve_lim) < 0) sieve_lim = mpz_get_ui (tmp); /* limit sieving for small ranges */ } mpz_set_ui (siev_sqr_lim, sieve_lim + 1); mpz_mul_ui (siev_sqr_lim, siev_sqr_lim, sieve_lim + 1); est_n_primes = (size_t) (sieve_lim / log((double) sieve_lim) * 1.13) + 10; primes = malloc (est_n_primes * sizeof primes[0]); make_primelist (sieve_lim); assert (est_n_primes >= n_primes); #if DEBUG printf ("sieve_lim = %lu\n", sieve_lim); printf ("n_primes = %lu (3..%u)\n", n_primes, primes[n_primes - 1].prime); #endif #define S (1 << 15) /* FIXME: Figure out L1 cache size */ s = malloc (S/2); while (mpz_cmp (fr2, to2) <= 0) { unsigned long rsize; rsize = S; mpz_add_ui (tmp, fr2, rsize); if (mpz_cmp (tmp, to2) > 0) { mpz_sub (tmp, to2, fr2); rsize = mpz_get_ui (tmp) + 2; } #if DEBUG printf ("Sieving region ["); mpz_out_str (stdout, 10, fr2); printf (","); mpz_add_ui (tmp, fr2, rsize - 2); mpz_out_str (stdout, 10, tmp); printf ("]\n"); #endif sieve_region (s, fr2, rsize); find_primes (s, fr2, rsize / 2, siev_sqr_lim); mpz_add_ui (fr2, fr2, S); } free (s); if (flag_count) printf ("Pi(interval) = %lu\n", total_primes); if (flag_maxgap) printf ("max gap: %lu\n", maxgap); return 0; } /* Find primes in region [fr,fr+rsize). Requires that fr is odd and that rsize is even. The sieving array s should be aligned for "long int" and have rsize/2 entries, rounded up to the nearest multiple of "long int". */ void sieve_region (unsigned char *s, mpz_t fr, unsigned long rsize) { unsigned long ssize = rsize / 2; unsigned long start, start2, prime; unsigned long i; mpz_t tmp; mpz_init (tmp); #if 0 /* initialize sieving array */ for (ii = 0; ii < (ssize + sizeof (long) - 1) / sizeof (long); ii++) ((long *) s) [ii] = ~0L; #else { long k; long *se = (long *) (s + ((ssize + sizeof (long) - 1) & -sizeof (long))); for (k = -((ssize + sizeof (long) - 1) / sizeof (long)); k < 0; k++) se[k] = ~0L; } #endif for (i = 0; i < n_primes; i++) { prime = primes[i].prime; if (primes[i].rem >= 0) { start2 = primes[i].rem; } else { mpz_set_ui (tmp, prime); mpz_mul_ui (tmp, tmp, prime); if (mpz_cmp (fr, tmp) <= 0) { mpz_sub (tmp, tmp, fr); if (mpz_cmp_ui (tmp, 2 * ssize) > 0) break; /* avoid overflow at next line, also speedup */ start = mpz_get_ui (tmp); } else { start = (prime - mpz_tdiv_ui (fr, prime)) % prime; if (start % 2 != 0) start += prime; /* adjust if even divisible */ } start2 = start / 2; } #if 0 for (ii = start2; ii < ssize; ii += prime) s[ii] = 0; primes[i].rem = ii - ssize; #else { long k; unsigned char *se = s + ssize; /* point just beyond sieving range */ for (k = start2 - ssize; k < 0; k += prime) se[k] = 0; primes[i].rem = k; } #endif } mpz_clear (tmp); } /* Find primes in region [fr,fr+rsize), using the previously sieved s[]. */ void find_primes (unsigned char *s, mpz_t fr, unsigned long ssize, mpz_t siev_sqr_lim) { unsigned long j, ij; mpz_t tmp; mpz_init (tmp); for (j = 0; j < (ssize + sizeof (long) - 1) / sizeof (long); j++) { if (((long *) s) [j] != 0) { for (ij = 0; ij < sizeof (long); ij++) { if (s[j * sizeof (long) + ij] != 0) { if (j * sizeof (long) + ij >= ssize) goto out; mpz_add_ui (tmp, fr, (j * sizeof (long) + ij) * 2); if (mpz_cmp (tmp, siev_sqr_lim) < 0 || mpz_probab_prime_p (tmp, 10)) report (tmp); } } } } out: mpz_clear (tmp); } /* Generate a list of primes and store in the global array primes[]. */ void make_primelist (unsigned long maxprime) { #if 1 unsigned char *s; unsigned long ssize = maxprime / 2; unsigned long i, ii, j; s = malloc (ssize); memset (s, ~0, ssize); for (i = 3; ; i += 2) { unsigned long isqr = i * i; if (isqr >= maxprime) break; if (s[i * i / 2 - 1] == 0) continue; /* only sieve with primes */ for (ii = i * i / 2 - 1; ii < ssize; ii += i) s[ii] = 0; } n_primes = 0; for (j = 0; j < ssize; j++) { if (s[j] != 0) { primes[n_primes].prime = j * 2 + 3; primes[n_primes].rem = -1; n_primes++; } } /* FIXME: This should not be needed if fencepost errors were fixed... */ if (primes[n_primes - 1].prime > maxprime) n_primes--; free (s); #else unsigned long i; n_primes = 0; for (i = 3; i <= maxprime; i += 2) { if (i < 7 || (i % 3 != 0 && i % 5 != 0 && i % 7 != 0)) { primes[n_primes].prime = i; primes[n_primes].rem = -1; n_primes++; } } #endif } gcl-2.6.14/gmp4/configfsf.guess0000755000175000017500000013135514360276512014671 0ustar cammcamm#! /bin/sh # Attempt to guess a canonical system name. # Copyright 1992-2013 Free Software Foundation, Inc. timestamp='2013-11-29' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that # program. This Exception is an additional permission under section 7 # of the GNU General Public License, version 3 ("GPLv3"). # # Originally written by Per Bothner. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD # # Please send patches with a ChangeLog entry to config-patches@gnu.org. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright 1992-2013 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown case "${UNAME_SYSTEM}" in Linux|GNU|GNU/*) # If the system lacks a compiler, then just pick glibc. # We could probably try harder. LIBC=gnu eval $set_cc_for_build cat <<-EOF > $dummy.c #include #if defined(__UCLIBC__) LIBC=uclibc #elif defined(__dietlibc__) LIBC=dietlibc #else LIBC=gnu #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` ;; esac # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:Bitrig:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm*:riscos:*:*|arm*:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case ${UNAME_PROCESSOR} in amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW64*:*) echo ${UNAME_MACHINE}-pc-mingw64 exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; aarch64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; aarch64_be:Linux:*:*) UNAME_MACHINE=aarch64_be echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="gnulibc1" ; fi echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arc:Linux:*:* | arceb:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-${LIBC} else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi else echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf fi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; cris:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; crisv32:Linux:*:*) echo ${UNAME_MACHINE}-axis-linux-${LIBC} exit ;; frv:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; hexagon:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:Linux:*:*) echo ${UNAME_MACHINE}-pc-linux-${LIBC} exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; or1k:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; or32:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; padre:Linux:*:*) echo sparc-unknown-linux-${LIBC} exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-${LIBC} exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; *) echo hppa-unknown-linux-${LIBC} ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-${LIBC} exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-${LIBC} exit ;; ppc64le:Linux:*:*) echo powerpc64le-unknown-linux-${LIBC} exit ;; ppcle:Linux:*:*) echo powerpcle-unknown-linux-${LIBC} exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux-${LIBC} exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; tile*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-${LIBC} exit ;; x86_64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; x86_64:Haiku:*:*) echo x86_64-unknown-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown eval $set_cc_for_build if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then case $UNAME_PROCESSOR in i386) UNAME_PROCESSOR=x86_64 ;; powerpc) UNAME_PROCESSOR=powerpc64 ;; esac fi fi elif test "$UNAME_PROCESSOR" = i386 ; then # Avoid executing cc on OS X 10.9, as it ships with a stub # that puts up a graphical alert prompting to install # developer tools. Any system running Mac OS X 10.7 or # later (Darwin 11 and later) is required to have a 64-bit # processor. This is not true of the ARM version of Darwin # that Apple uses in portable devices. UNAME_PROCESSOR=x86_64 fi echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NEO-?:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-*:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; x86_64:VMkernel:*:*) echo ${UNAME_MACHINE}-unknown-esx exit ;; esac eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl-2.6.14/gmp4/mpf/0000755000175000017500000000000014360276512012424 5ustar cammcammgcl-2.6.14/gmp4/mpf/div.c0000644000175000017500000000743214360276512013360 0ustar cammcamm/* mpf_div -- Divide two floats. Copyright 1993, 1994, 1996, 2000-2002, 2004, 2005, 2010, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Not done: No attempt is made to identify an overlap u==v. The result will be correct (1.0), but a full actual division is done whereas of course x/x==1 needs no work. Such a call is not a sensible thing to make, and it's left to an application to notice and optimize if it might arise somehow through pointer aliasing or whatever. Enhancements: The high quotient limb is non-zero when high{up,vsize} >= {vp,vsize}. We could make that comparison and use qsize==prec instead of qsize==prec+1, to save one limb in the division. If r==u but the size is enough bigger than prec that there won't be an overlap between quotient and dividend in mpn_div_q, then we can avoid copying up,usize. This would only arise from a prec reduced with mpf_set_prec_raw and will be pretty unusual, but might be worthwhile if it could be worked into the copy_u decision cleanly. */ void mpf_div (mpf_ptr r, mpf_srcptr u, mpf_srcptr v) { mp_srcptr up, vp; mp_ptr rp, tp, new_vp; mp_size_t usize, vsize, rsize, prospective_rsize, tsize, zeros; mp_size_t sign_quotient, prec, high_zero, chop; mp_exp_t rexp; int copy_u; TMP_DECL; usize = SIZ(u); vsize = SIZ(v); if (UNLIKELY (vsize == 0)) DIVIDE_BY_ZERO; if (usize == 0) { SIZ(r) = 0; EXP(r) = 0; return; } sign_quotient = usize ^ vsize; usize = ABS (usize); vsize = ABS (vsize); prec = PREC(r); TMP_MARK; rexp = EXP(u) - EXP(v) + 1; rp = PTR(r); up = PTR(u); vp = PTR(v); prospective_rsize = usize - vsize + 1; /* quot from using given u,v sizes */ rsize = prec + 1; /* desired quot */ zeros = rsize - prospective_rsize; /* padding u to give rsize */ copy_u = (zeros > 0 || rp == up); /* copy u if overlap or padding */ chop = MAX (-zeros, 0); /* negative zeros means shorten u */ up += chop; usize -= chop; zeros += chop; /* now zeros >= 0 */ tsize = usize + zeros; /* size for possible copy of u */ /* copy and possibly extend u if necessary */ if (copy_u) { tp = TMP_ALLOC_LIMBS (tsize + 1); /* +1 for mpn_div_q's scratch needs */ MPN_ZERO (tp, zeros); MPN_COPY (tp+zeros, up, usize); up = tp; usize = tsize; } else { tp = TMP_ALLOC_LIMBS (usize + 1); } /* ensure divisor doesn't overlap quotient */ if (rp == vp) { new_vp = TMP_ALLOC_LIMBS (vsize); MPN_COPY (new_vp, vp, vsize); vp = new_vp; } ASSERT (usize-vsize+1 == rsize); mpn_div_q (rp, up, usize, vp, vsize, tp); /* strip possible zero high limb */ high_zero = (rp[rsize-1] == 0); rsize -= high_zero; rexp -= high_zero; SIZ(r) = sign_quotient >= 0 ? rsize : -rsize; EXP(r) = rexp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/set_ui.c0000644000175000017500000000254714360276512014070 0ustar cammcamm/* mpf_set_ui() -- Assign a float from an unsigned int. Copyright 1993-1995, 2001, 2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_set_ui (mpf_ptr f, unsigned long val) { mp_size_t size; f->_mp_d[0] = val & GMP_NUMB_MASK; size = val != 0; #if BITS_PER_ULONG > GMP_NUMB_BITS val >>= GMP_NUMB_BITS; f->_mp_d[1] = val; size += (val != 0); #endif f->_mp_exp = f->_mp_size = size; } gcl-2.6.14/gmp4/mpf/cmp_ui.c0000644000175000017500000000465514360276512014056 0ustar cammcamm/* mpf_cmp_ui -- Compare a float with an unsigned integer. Copyright 1993-1995, 1999, 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" int mpf_cmp_ui (mpf_srcptr u, unsigned long int vval) __GMP_NOTHROW { mp_srcptr up; mp_size_t usize; mp_exp_t uexp; mp_limb_t ulimb; uexp = u->_mp_exp; usize = u->_mp_size; /* 1. Is U negative? */ if (usize < 0) return -1; /* We rely on usize being non-negative in the code that follows. */ if (vval == 0) return usize != 0; /* 2. Are the exponents different (V's exponent == 1)? */ #if GMP_NAIL_BITS != 0 if (uexp > 1 + (vval > GMP_NUMB_MAX)) return 1; if (uexp < 1 + (vval > GMP_NUMB_MAX)) return -1; #else if (uexp > 1) return 1; if (uexp < 1) return -1; #endif up = u->_mp_d; ulimb = up[usize - 1]; #if GMP_NAIL_BITS != 0 if (usize >= 2 && uexp == 2) { if ((ulimb >> GMP_NAIL_BITS) != 0) return 1; ulimb = (ulimb << GMP_NUMB_BITS) | up[usize - 2]; usize--; } #endif usize--; /* 3. Compare the most significant mantissa limb with V. */ if (ulimb > vval) return 1; else if (ulimb < vval) return -1; /* Ignore zeroes at the low end of U. */ while (*up == 0) { up++; usize--; } /* 4. Now, if the number of limbs are different, we have a difference since we have made sure the trailing limbs are not zero. */ if (usize > 0) return 1; /* Wow, we got zero even if we tried hard to avoid it. */ return 0; } gcl-2.6.14/gmp4/mpf/ui_sub.c0000644000175000017500000001732414360276512014065 0ustar cammcamm/* mpf_ui_sub -- Subtract a float from an unsigned long int. Copyright 1993-1996, 2001, 2002, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_ui_sub (mpf_ptr r, unsigned long int u, mpf_srcptr v) { mp_srcptr up, vp; mp_ptr rp, tp; mp_size_t usize, vsize, rsize; mp_size_t prec; mp_exp_t uexp; mp_size_t ediff; int negate; mp_limb_t ulimb; TMP_DECL; vsize = v->_mp_size; /* Handle special cases that don't work in generic code below. */ if (u == 0) { mpf_neg (r, v); return; } if (vsize == 0) { mpf_set_ui (r, u); return; } /* If signs of U and V are different, perform addition. */ if (vsize < 0) { __mpf_struct v_negated; v_negated._mp_size = -vsize; v_negated._mp_exp = v->_mp_exp; v_negated._mp_d = v->_mp_d; mpf_add_ui (r, &v_negated, u); return; } TMP_MARK; /* Signs are now known to be the same. */ ulimb = u; /* Make U be the operand with the largest exponent. */ if (1 < v->_mp_exp) { negate = 1; usize = ABS (vsize); vsize = 1; up = v->_mp_d; vp = &ulimb; rp = r->_mp_d; prec = r->_mp_prec + 1; uexp = v->_mp_exp; ediff = uexp - 1; } else { negate = 0; usize = 1; vsize = ABS (vsize); up = &ulimb; vp = v->_mp_d; rp = r->_mp_d; prec = r->_mp_prec; uexp = 1; ediff = 1 - v->_mp_exp; } /* Ignore leading limbs in U and V that are equal. Doing this helps increase the precision of the result. */ if (ediff == 0) { /* This loop normally exits immediately. Optimize for that. */ for (;;) { usize--; vsize--; if (up[usize] != vp[vsize]) break; uexp--; if (usize == 0) goto Lu0; if (vsize == 0) goto Lv0; } usize++; vsize++; /* Note that either operand (but not both operands) might now have leading zero limbs. It matters only that U is unnormalized if vsize is now zero, and vice versa. And it is only in that case that we have to adjust uexp. */ if (vsize == 0) Lv0: while (usize != 0 && up[usize - 1] == 0) usize--, uexp--; if (usize == 0) Lu0: while (vsize != 0 && vp[vsize - 1] == 0) vsize--, uexp--; } /* If U extends beyond PREC, ignore the part that does. */ if (usize > prec) { up += usize - prec; usize = prec; } /* If V extends beyond PREC, ignore the part that does. Note that this may make vsize negative. */ if (vsize + ediff > prec) { vp += vsize + ediff - prec; vsize = prec - ediff; } /* Allocate temp space for the result. Allocate just vsize + ediff later??? */ tp = TMP_ALLOC_LIMBS (prec); if (ediff >= prec) { /* V completely cancelled. */ if (tp != up) MPN_COPY (rp, up, usize); rsize = usize; } else { /* Locate the least significant non-zero limb in (the needed parts of) U and V, to simplify the code below. */ for (;;) { if (vsize == 0) { MPN_COPY (rp, up, usize); rsize = usize; goto done; } if (vp[0] != 0) break; vp++, vsize--; } for (;;) { if (usize == 0) { MPN_COPY (rp, vp, vsize); rsize = vsize; negate ^= 1; goto done; } if (up[0] != 0) break; up++, usize--; } /* uuuu | uuuu | uuuu | uuuu | uuuu */ /* vvvvvvv | vv | vvvvv | v | vv */ if (usize > ediff) { /* U and V partially overlaps. */ if (ediff == 0) { /* Have to compare the leading limbs of u and v to determine whether to compute u - v or v - u. */ if (usize > vsize) { /* uuuu */ /* vv */ int cmp; cmp = mpn_cmp (up + usize - vsize, vp, vsize); if (cmp >= 0) { mp_size_t size; size = usize - vsize; MPN_COPY (tp, up, size); mpn_sub_n (tp + size, up + size, vp, vsize); rsize = usize; } else { /* vv */ /* Swap U and V. */ /* uuuu */ mp_size_t size, i; size = usize - vsize; tp[0] = -up[0] & GMP_NUMB_MASK; for (i = 1; i < size; i++) tp[i] = ~up[i] & GMP_NUMB_MASK; mpn_sub_n (tp + size, vp, up + size, vsize); mpn_sub_1 (tp + size, tp + size, vsize, (mp_limb_t) 1); negate ^= 1; rsize = usize; } } else if (usize < vsize) { /* uuuu */ /* vvvvvvv */ int cmp; cmp = mpn_cmp (up, vp + vsize - usize, usize); if (cmp > 0) { mp_size_t size, i; size = vsize - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; mpn_sub_n (tp + size, up, vp + size, usize); mpn_sub_1 (tp + size, tp + size, usize, (mp_limb_t) 1); rsize = vsize; } else { /* vvvvvvv */ /* Swap U and V. */ /* uuuu */ /* This is the only place we can get 0.0. */ mp_size_t size; size = vsize - usize; MPN_COPY (tp, vp, size); mpn_sub_n (tp + size, vp + size, up, usize); negate ^= 1; rsize = vsize; } } else { /* uuuu */ /* vvvv */ int cmp; cmp = mpn_cmp (up, vp + vsize - usize, usize); if (cmp > 0) { mpn_sub_n (tp, up, vp, usize); rsize = usize; } else { mpn_sub_n (tp, vp, up, usize); negate ^= 1; rsize = usize; /* can give zero */ } } } else { if (vsize + ediff <= usize) { /* uuuu */ /* v */ mp_size_t size; size = usize - ediff - vsize; MPN_COPY (tp, up, size); mpn_sub (tp + size, up + size, usize - size, vp, vsize); rsize = usize; } else { /* uuuu */ /* vvvvv */ mp_size_t size, i; size = vsize + ediff - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; mpn_sub (tp + size, up, usize, vp + size, usize - ediff); mpn_sub_1 (tp + size, tp + size, usize, (mp_limb_t) 1); rsize = vsize + ediff; } } } else { /* uuuu */ /* vv */ mp_size_t size, i; size = vsize + ediff - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < vsize; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; for (i = vsize; i < size; i++) tp[i] = GMP_NUMB_MAX; mpn_sub_1 (tp + size, up, usize, (mp_limb_t) 1); rsize = size + usize; } /* Full normalize. Optimize later. */ while (rsize != 0 && tp[rsize - 1] == 0) { rsize--; uexp--; } MPN_COPY (rp, tp, rsize); } done: r->_mp_size = negate ? -rsize : rsize; r->_mp_exp = uexp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/inp_str.c0000644000175000017500000000444214360276512014252 0ustar cammcamm/* mpf_inp_str(dest_float, stream, base) -- Input a number in base BASE from stdio stream STREAM and store the result in DEST_FLOAT. Copyright 1996, 2000-2002, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "gmp.h" #include "gmp-impl.h" size_t mpf_inp_str (mpf_ptr rop, FILE *stream, int base) { char *str; size_t alloc_size, str_size; int c; int res; size_t nread; if (stream == 0) stream = stdin; alloc_size = 100; str = (char *) (*__gmp_allocate_func) (alloc_size); str_size = 0; nread = 0; /* Skip whitespace. */ do { c = getc (stream); nread++; } while (isspace (c)); for (;;) { if (str_size >= alloc_size) { size_t old_alloc_size = alloc_size; alloc_size = alloc_size * 3 / 2; str = (char *) (*__gmp_reallocate_func) (str, old_alloc_size, alloc_size); } if (c == EOF || isspace (c)) break; str[str_size++] = c; c = getc (stream); } ungetc (c, stream); nread--; if (str_size >= alloc_size) { size_t old_alloc_size = alloc_size; alloc_size = alloc_size * 3 / 2; str = (char *) (*__gmp_reallocate_func) (str, old_alloc_size, alloc_size); } str[str_size] = 0; res = mpf_set_str (rop, str, base); (*__gmp_free_func) (str, alloc_size); if (res == -1) return 0; /* error */ return str_size + nread; } gcl-2.6.14/gmp4/mpf/fits_slong.c0000644000175000017500000000221114360276512014733 0ustar cammcamm/* mpf_fits_slong_p -- test whether an mpf fits a long. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_slong_p #define MAXIMUM LONG_MAX #define MINIMUM LONG_MIN #include "fits_s.h" gcl-2.6.14/gmp4/mpf/swap.c0000644000175000017500000000263614360276512013551 0ustar cammcamm/* mpf_swap (U, V) -- Swap U and V. Copyright 1997, 1998, 2000, 2001, 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_swap (mpf_ptr u, mpf_ptr v) __GMP_NOTHROW { mp_ptr tptr; mp_size_t tprec; mp_size_t tsiz; mp_exp_t texp; tprec = PREC(u); PREC(u) = PREC(v); PREC(v) = tprec; tsiz = SIZ(u); SIZ(u) = SIZ(v); SIZ(v) = tsiz; texp = EXP(u); EXP(u) = EXP(v); EXP(v) = texp; tptr = PTR(u); PTR(u) = PTR(v); PTR(v) = tptr; } gcl-2.6.14/gmp4/mpf/set_si.c0000644000175000017500000000271414360276512014062 0ustar cammcamm/* mpf_set_si() -- Assign a float from a signed int. Copyright 1993-1995, 2000-2002, 2004, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_set_si (mpf_ptr dest, long val) { mp_size_t size; mp_limb_t vl; vl = (mp_limb_t) ABS_CAST (unsigned long int, val); dest->_mp_d[0] = vl & GMP_NUMB_MASK; size = vl != 0; #if BITS_PER_ULONG > GMP_NUMB_BITS vl >>= GMP_NUMB_BITS; dest->_mp_d[1] = vl; size += (vl != 0); #endif dest->_mp_exp = size; dest->_mp_size = val >= 0 ? size : -size; } gcl-2.6.14/gmp4/mpf/get_dfl_prec.c0000644000175000017500000000227714360276512015215 0ustar cammcamm/* mpf_get_default_prec -- return default precision in bits. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" mp_bitcnt_t mpf_get_default_prec (void) __GMP_NOTHROW { return __GMPF_PREC_TO_BITS (__gmp_default_fp_limb_precision); } gcl-2.6.14/gmp4/mpf/cmp.c0000644000175000017500000000507714360276512013360 0ustar cammcamm/* mpf_cmp -- Compare two floats. Copyright 1993, 1994, 1996, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" int mpf_cmp (mpf_srcptr u, mpf_srcptr v) __GMP_NOTHROW { mp_srcptr up, vp; mp_size_t usize, vsize; mp_exp_t uexp, vexp; int cmp; int usign; uexp = u->_mp_exp; vexp = v->_mp_exp; usize = u->_mp_size; vsize = v->_mp_size; /* 1. Are the signs different? */ if ((usize ^ vsize) >= 0) { /* U and V are both non-negative or both negative. */ if (usize == 0) /* vsize >= 0 */ return -(vsize != 0); if (vsize == 0) /* usize >= 0 */ return usize != 0; /* Fall out. */ } else { /* Either U or V is negative, but not both. */ return usize >= 0 ? 1 : -1; } /* U and V have the same sign and are both non-zero. */ usign = usize >= 0 ? 1 : -1; /* 2. Are the exponents different? */ if (uexp > vexp) return usign; if (uexp < vexp) return -usign; usize = ABS (usize); vsize = ABS (vsize); up = u->_mp_d; vp = v->_mp_d; #define STRICT_MPF_NORMALIZATION 0 #if ! STRICT_MPF_NORMALIZATION /* Ignore zeroes at the low end of U and V. */ while (up[0] == 0) { up++; usize--; } while (vp[0] == 0) { vp++; vsize--; } #endif if (usize > vsize) { cmp = mpn_cmp (up + usize - vsize, vp, vsize); if (cmp == 0) return usign; } else if (vsize > usize) { cmp = mpn_cmp (up, vp + vsize - usize, usize); if (cmp == 0) return -usign; } else { cmp = mpn_cmp (up, vp, usize); if (cmp == 0) return 0; } return cmp > 0 ? usign : -usign; } gcl-2.6.14/gmp4/mpf/random2.c0000644000175000017500000000333614360276512014137 0ustar cammcamm/* mpf_random2 -- Generate a positive random mpf_t of specified size, with long runs of consecutive ones and zeros in the binary representation. Intended for testing of other MP routines. Copyright 1995, 1996, 2001-2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_random2 (mpf_ptr x, mp_size_t xs, mp_exp_t exp) { mp_size_t xn; mp_size_t prec; mp_limb_t elimb; xn = ABS (xs); prec = PREC(x); if (xn == 0) { EXP(x) = 0; SIZ(x) = 0; return; } if (xn > prec + 1) xn = prec + 1; /* General random mantissa. */ mpn_random2 (PTR(x), xn); /* Generate random exponent. */ _gmp_rand (&elimb, RANDS, GMP_NUMB_BITS); exp = ABS (exp); exp = elimb % (2 * exp + 1) - exp; EXP(x) = exp; SIZ(x) = xs < 0 ? -xn : xn; } gcl-2.6.14/gmp4/mpf/fits_uint.c0000644000175000017500000000216214360276512014575 0ustar cammcamm/* mpf_fits_uint_p -- test whether an mpf fits an unsigned int. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_uint_p #define MAXIMUM UINT_MAX #include "fits_u.h" gcl-2.6.14/gmp4/mpf/fits_sint.c0000644000175000017500000000220514360276512014571 0ustar cammcamm/* mpf_fits_sint_p -- test whether an mpf fits an int. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_sint_p #define MAXIMUM INT_MAX #define MINIMUM INT_MIN #include "fits_s.h" gcl-2.6.14/gmp4/mpf/init.c0000644000175000017500000000250414360276512013534 0ustar cammcamm/* mpf_init() -- Make a new multiple precision number with value 0. Copyright 1993-1995, 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init (mpf_ptr r) { mp_size_t prec = __gmp_default_fp_limb_precision; r->_mp_size = 0; r->_mp_exp = 0; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); } gcl-2.6.14/gmp4/mpf/iset_ui.c0000644000175000017500000000306614360276512014236 0ustar cammcamm/* mpf_init_set_ui() -- Initialize a float and assign it from an unsigned int. Copyright 1993-1995, 2000, 2001, 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init_set_ui (mpf_ptr r, unsigned long int val) { mp_size_t prec = __gmp_default_fp_limb_precision; mp_size_t size; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); r->_mp_d[0] = val & GMP_NUMB_MASK; size = (val != 0); #if BITS_PER_ULONG > GMP_NUMB_BITS val >>= GMP_NUMB_BITS; r->_mp_d[1] = val; size += (val != 0); #endif r->_mp_size = size; r->_mp_exp = size; } gcl-2.6.14/gmp4/mpf/sqrt_ui.c0000644000175000017500000000652114360276512014262 0ustar cammcamm/* mpf_sqrt_ui -- Compute the square root of an unsigned integer. Copyright 1993, 1994, 1996, 2000, 2001, 2004, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" /* As usual the aim is to produce PREC(r) limbs of result with the high limb non-zero. That high limb will end up floor(sqrt(u)), and limbs below are produced by padding the input with zeros, two for each desired result limb, being 2*(prec-1) for a total 2*prec-1 limbs passed to mpn_sqrtrem. The way mpn_sqrtrem calculates floor(sqrt(x)) ensures the root is correct to the intended accuracy, ie. truncated to prec limbs. With nails, u might be two limbs, in which case a total 2*prec limbs is passed to mpn_sqrtrem (still giving a prec limb result). If uhigh is zero we adjust back to 2*prec-1, since mpn_sqrtrem requires the high non-zero. 2*prec limbs are always allocated, even when uhigh is zero, so the store of uhigh can be done without a conditional. u==0 is a special case so the rest of the code can assume the result is non-zero (ie. will have a non-zero high limb on the result). Not done: No attempt is made to identify perfect squares. It's considered this can be left to an application if it might occur with any frequency. As it stands, mpn_sqrtrem does its normal amount of work on a perfect square followed by zero limbs, though of course only an mpn_sqrtrem1 would be actually needed. We also end up leaving our mpf result with lots of low trailing zeros, slowing down subsequent operations. We're not aware of any optimizations that can be made using the fact the input has lots of trailing zeros (apart from the perfect square case). */ /* 1 if we (might) need two limbs for u */ #define U2 (GMP_NUMB_BITS < BITS_PER_ULONG) void mpf_sqrt_ui (mpf_ptr r, unsigned long int u) { mp_size_t rsize, zeros; mp_ptr tp; mp_size_t prec; TMP_DECL; if (UNLIKELY (u == 0)) { r->_mp_size = 0; r->_mp_exp = 0; return; } TMP_MARK; prec = r->_mp_prec; zeros = 2 * prec - 2; rsize = zeros + 1 + U2; tp = TMP_ALLOC_LIMBS (rsize); MPN_ZERO (tp, zeros); tp[zeros] = u & GMP_NUMB_MASK; #if U2 { mp_limb_t uhigh = u >> GMP_NUMB_BITS; tp[zeros + 1] = uhigh; rsize -= (uhigh == 0); } #endif mpn_sqrtrem (r->_mp_d, NULL, tp, rsize); r->_mp_size = prec; r->_mp_exp = 1; TMP_FREE; } gcl-2.6.14/gmp4/mpf/get_d.c0000644000175000017500000000255414360276512013660 0ustar cammcamm/* double mpf_get_d (mpf_t src) -- return SRC truncated to a double. Copyright 1996, 2001-2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" double mpf_get_d (mpf_srcptr src) { mp_size_t size, abs_size; long exp; size = SIZ (src); if (UNLIKELY (size == 0)) return 0.0; abs_size = ABS (size); exp = (EXP (src) - abs_size) * GMP_NUMB_BITS; return mpn_get_d (PTR (src), abs_size, size, exp); } gcl-2.6.14/gmp4/mpf/set_d.c0000644000175000017500000000310614360276512013666 0ustar cammcamm/* mpf_set_d -- Assign a float from a double. Copyright 1993-1996, 2001, 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "config.h" #if HAVE_FLOAT_H #include /* for DBL_MAX */ #endif #include "gmp.h" #include "gmp-impl.h" void mpf_set_d (mpf_ptr r, double d) { int negative; DOUBLE_NAN_INF_ACTION (d, __gmp_invalid_operation (), __gmp_invalid_operation ()); if (UNLIKELY (d == 0)) { SIZ(r) = 0; EXP(r) = 0; return; } negative = d < 0; d = ABS (d); SIZ(r) = negative ? -LIMBS_PER_DOUBLE : LIMBS_PER_DOUBLE; EXP(r) = __gmp_extract_double (PTR(r), d); } gcl-2.6.14/gmp4/mpf/fits_ulong.c0000644000175000017500000000217414360276512014745 0ustar cammcamm/* mpf_fits_ulong_p -- test whether an mpf fits an unsigned long. Copyright 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_ulong_p #define MAXIMUM ULONG_MAX #include "fits_u.h" gcl-2.6.14/gmp4/mpf/div_ui.c0000644000175000017500000000476514360276512014063 0ustar cammcamm/* mpf_div_ui -- Divide a float with an unsigned integer. Copyright 1993, 1994, 1996, 2000-2002, 2004, 2005, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" void mpf_div_ui (mpf_ptr r, mpf_srcptr u, unsigned long int v) { mp_srcptr up; mp_ptr rp, tp, rtp; mp_size_t usize; mp_size_t rsize, tsize; mp_size_t sign_quotient; mp_size_t prec; mp_limb_t q_limb; mp_exp_t rexp; TMP_DECL; #if BITS_PER_ULONG > GMP_NUMB_BITS /* avoid warnings about shift amount */ if (v > GMP_NUMB_MAX) { mpf_t vf; mp_limb_t vl[2]; SIZ(vf) = 2; EXP(vf) = 2; PTR(vf) = vl; vl[0] = v & GMP_NUMB_MASK; vl[1] = v >> GMP_NUMB_BITS; mpf_div (r, u, vf); return; } #endif if (UNLIKELY (v == 0)) DIVIDE_BY_ZERO; usize = u->_mp_size; if (usize == 0) { r->_mp_size = 0; r->_mp_exp = 0; return; } sign_quotient = usize; usize = ABS (usize); prec = r->_mp_prec; TMP_MARK; rp = r->_mp_d; up = u->_mp_d; tsize = 1 + prec; tp = TMP_ALLOC_LIMBS (tsize + 1); if (usize > tsize) { up += usize - tsize; usize = tsize; rtp = tp; } else { MPN_ZERO (tp, tsize - usize); rtp = tp + (tsize - usize); } /* Move the dividend to the remainder. */ MPN_COPY (rtp, up, usize); mpn_divmod_1 (rp, tp, tsize, (mp_limb_t) v); q_limb = rp[tsize - 1]; rsize = tsize - (q_limb == 0); rexp = u->_mp_exp - (q_limb == 0); r->_mp_size = sign_quotient >= 0 ? rsize : -rsize; r->_mp_exp = rexp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/get_prc.c0000644000175000017500000000226214360276512014215 0ustar cammcamm/* mpf_get_prec(x) -- Return the precision in bits of x. Copyright 1996, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" mp_bitcnt_t mpf_get_prec (mpf_srcptr x) __GMP_NOTHROW { return __GMPF_PREC_TO_BITS (x->_mp_prec); } gcl-2.6.14/gmp4/mpf/add.c0000644000175000017500000001040014360276512013313 0ustar cammcamm/* mpf_add -- Add two floats. Copyright 1993, 1994, 1996, 2000, 2001, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_add (mpf_ptr r, mpf_srcptr u, mpf_srcptr v) { mp_srcptr up, vp; mp_ptr rp, tp; mp_size_t usize, vsize, rsize; mp_size_t prec; mp_exp_t uexp; mp_size_t ediff; mp_limb_t cy; int negate; TMP_DECL; usize = u->_mp_size; vsize = v->_mp_size; /* Handle special cases that don't work in generic code below. */ if (usize == 0) { set_r_v_maybe: if (r != v) mpf_set (r, v); return; } if (vsize == 0) { v = u; goto set_r_v_maybe; } /* If signs of U and V are different, perform subtraction. */ if ((usize ^ vsize) < 0) { __mpf_struct v_negated; v_negated._mp_size = -vsize; v_negated._mp_exp = v->_mp_exp; v_negated._mp_d = v->_mp_d; mpf_sub (r, u, &v_negated); return; } TMP_MARK; /* Signs are now known to be the same. */ negate = usize < 0; /* Make U be the operand with the largest exponent. */ if (u->_mp_exp < v->_mp_exp) { mpf_srcptr t; t = u; u = v; v = t; usize = u->_mp_size; vsize = v->_mp_size; } usize = ABS (usize); vsize = ABS (vsize); up = u->_mp_d; vp = v->_mp_d; rp = r->_mp_d; prec = r->_mp_prec; uexp = u->_mp_exp; ediff = u->_mp_exp - v->_mp_exp; /* If U extends beyond PREC, ignore the part that does. */ if (usize > prec) { up += usize - prec; usize = prec; } /* If V extends beyond PREC, ignore the part that does. Note that this may make vsize negative. */ if (vsize + ediff > prec) { vp += vsize + ediff - prec; vsize = prec - ediff; } #if 0 /* Locate the least significant non-zero limb in (the needed parts of) U and V, to simplify the code below. */ while (up[0] == 0) up++, usize--; while (vp[0] == 0) vp++, vsize--; #endif /* Allocate temp space for the result. Allocate just vsize + ediff later??? */ tp = TMP_ALLOC_LIMBS (prec); if (ediff >= prec) { /* V completely cancelled. */ if (rp != up) MPN_COPY_INCR (rp, up, usize); rsize = usize; } else { /* uuuu | uuuu | uuuu | uuuu | uuuu */ /* vvvvvvv | vv | vvvvv | v | vv */ if (usize > ediff) { /* U and V partially overlaps. */ if (vsize + ediff <= usize) { /* uuuu */ /* v */ mp_size_t size; size = usize - ediff - vsize; MPN_COPY (tp, up, size); cy = mpn_add (tp + size, up + size, usize - size, vp, vsize); rsize = usize; } else { /* uuuu */ /* vvvvv */ mp_size_t size; size = vsize + ediff - usize; MPN_COPY (tp, vp, size); cy = mpn_add (tp + size, up, usize, vp + size, usize - ediff); rsize = vsize + ediff; } } else { /* uuuu */ /* vv */ mp_size_t size; size = vsize + ediff - usize; MPN_COPY (tp, vp, vsize); MPN_ZERO (tp + vsize, ediff - usize); MPN_COPY (tp + size, up, usize); cy = 0; rsize = size + usize; } MPN_COPY (rp, tp, rsize); rp[rsize] = cy; rsize += cy; uexp += cy; } r->_mp_size = negate ? -rsize : rsize; r->_mp_exp = uexp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/init2.c0000644000175000017500000000255414360276512013623 0ustar cammcamm/* mpf_init2() -- Make a new multiple precision number with value 0. Copyright 1993-1995, 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init2 (mpf_ptr r, mp_bitcnt_t prec_in_bits) { mp_size_t prec; prec = __GMPF_BITS_TO_PREC (prec_in_bits); r->_mp_size = 0; r->_mp_exp = 0; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); } gcl-2.6.14/gmp4/mpf/iset_str.c0000644000175000017500000000261414360276512014427 0ustar cammcamm/* mpf_init_set_str -- Initialize a float and assign it from a string. Copyright 1995, 1996, 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" int mpf_init_set_str (mpf_ptr r, const char *s, int base) { mp_size_t prec = __gmp_default_fp_limb_precision; r->_mp_size = 0; r->_mp_exp = 0; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); return mpf_set_str (r, s, base); } gcl-2.6.14/gmp4/mpf/clear.c0000644000175000017500000000234114360276512013656 0ustar cammcamm/* mpf_clear -- de-allocate the space occupied by the dynamic digit space of an integer. Copyright 1993-1995, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_clear (mpf_ptr m) { (*__gmp_free_func) (m->_mp_d, (size_t) (m->_mp_prec + 1) * GMP_LIMB_BYTES); } gcl-2.6.14/gmp4/mpf/sub.c0000644000175000017500000002262014360276512013363 0ustar cammcamm/* mpf_sub -- Subtract two floats. Copyright 1993-1996, 1999-2002, 2004, 2005, 2011 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_sub (mpf_ptr r, mpf_srcptr u, mpf_srcptr v) { mp_srcptr up, vp; mp_ptr rp, tp; mp_size_t usize, vsize, rsize; mp_size_t prec; mp_exp_t exp; mp_size_t ediff; int negate; TMP_DECL; usize = u->_mp_size; vsize = v->_mp_size; /* Handle special cases that don't work in generic code below. */ if (usize == 0) { mpf_neg (r, v); return; } if (vsize == 0) { if (r != u) mpf_set (r, u); return; } /* If signs of U and V are different, perform addition. */ if ((usize ^ vsize) < 0) { __mpf_struct v_negated; v_negated._mp_size = -vsize; v_negated._mp_exp = v->_mp_exp; v_negated._mp_d = v->_mp_d; mpf_add (r, u, &v_negated); return; } TMP_MARK; /* Signs are now known to be the same. */ negate = usize < 0; /* Make U be the operand with the largest exponent. */ if (u->_mp_exp < v->_mp_exp) { mpf_srcptr t; t = u; u = v; v = t; negate ^= 1; usize = u->_mp_size; vsize = v->_mp_size; } usize = ABS (usize); vsize = ABS (vsize); up = u->_mp_d; vp = v->_mp_d; rp = r->_mp_d; prec = r->_mp_prec + 1; exp = u->_mp_exp; ediff = u->_mp_exp - v->_mp_exp; /* If ediff is 0 or 1, we might have a situation where the operands are extremely close. We need to scan the operands from the most significant end ignore the initial parts that are equal. */ if (ediff <= 1) { if (ediff == 0) { /* Skip leading limbs in U and V that are equal. */ if (up[usize - 1] == vp[vsize - 1]) { /* This loop normally exits immediately. Optimize for that. */ do { usize--; vsize--; exp--; if (usize == 0) { /* u cancels high limbs of v, result is rest of v */ negate ^= 1; cancellation: /* strip high zeros before truncating to prec */ while (vsize != 0 && vp[vsize - 1] == 0) { vsize--; exp--; } if (vsize > prec) { vp += vsize - prec; vsize = prec; } MPN_COPY_INCR (rp, vp, vsize); rsize = vsize; goto done; } if (vsize == 0) { vp = up; vsize = usize; goto cancellation; } } while (up[usize - 1] == vp[vsize - 1]); } if (up[usize - 1] < vp[vsize - 1]) { /* For simplicity, swap U and V. Note that since the loop above wouldn't have exited unless up[usize - 1] and vp[vsize - 1] were non-equal, this if-statement catches all cases where U is smaller than V. */ MPN_SRCPTR_SWAP (up,usize, vp,vsize); negate ^= 1; /* negating ediff not necessary since it is 0. */ } /* Check for x+1 00000000 ... x ffffffff ... */ if (up[usize - 1] != vp[vsize - 1] + 1) goto general_case; usize--; vsize--; exp--; } else /* ediff == 1 */ { /* Check for 1 00000000 ... 0 ffffffff ... */ if (up[usize - 1] != 1 || vp[vsize - 1] != GMP_NUMB_MAX || (usize >= 2 && up[usize - 2] != 0)) goto general_case; usize--; exp--; } /* Skip sequences of 00000000/ffffffff */ while (vsize != 0 && usize != 0 && up[usize - 1] == 0 && vp[vsize - 1] == GMP_NUMB_MAX) { usize--; vsize--; exp--; } if (usize == 0) { while (vsize != 0 && vp[vsize - 1] == GMP_NUMB_MAX) { vsize--; exp--; } } if (usize > prec - 1) { up += usize - (prec - 1); usize = prec - 1; } if (vsize > prec - 1) { vp += vsize - (prec - 1); vsize = prec - 1; } tp = TMP_ALLOC_LIMBS (prec); { mp_limb_t cy_limb; if (vsize == 0) { mp_size_t size, i; size = usize; for (i = 0; i < size; i++) tp[i] = up[i]; tp[size] = 1; rsize = size + 1; exp++; goto normalize; } if (usize == 0) { mp_size_t size, i; size = vsize; for (i = 0; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; cy_limb = 1 - mpn_add_1 (tp, tp, vsize, (mp_limb_t) 1); rsize = vsize; if (cy_limb == 0) { tp[rsize] = 1; rsize++; exp++; } goto normalize; } if (usize >= vsize) { /* uuuu */ /* vv */ mp_size_t size; size = usize - vsize; MPN_COPY (tp, up, size); cy_limb = mpn_sub_n (tp + size, up + size, vp, vsize); rsize = usize; } else /* (usize < vsize) */ { /* uuuu */ /* vvvvvvv */ mp_size_t size, i; size = vsize - usize; for (i = 0; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; cy_limb = mpn_sub_n (tp + size, up, vp + size, usize); cy_limb+= mpn_sub_1 (tp + size, tp + size, usize, (mp_limb_t) 1); cy_limb-= mpn_add_1 (tp, tp, vsize, (mp_limb_t) 1); rsize = vsize; } if (cy_limb == 0) { tp[rsize] = 1; rsize++; exp++; } goto normalize; } } general_case: /* If U extends beyond PREC, ignore the part that does. */ if (usize > prec) { up += usize - prec; usize = prec; } /* If V extends beyond PREC, ignore the part that does. Note that this may make vsize negative. */ if (vsize + ediff > prec) { vp += vsize + ediff - prec; vsize = prec - ediff; } if (ediff >= prec) { /* V completely cancelled. */ if (rp != up) MPN_COPY (rp, up, usize); rsize = usize; } else { /* Allocate temp space for the result. Allocate just vsize + ediff later??? */ tp = TMP_ALLOC_LIMBS (prec); /* Locate the least significant non-zero limb in (the needed parts of) U and V, to simplify the code below. */ for (;;) { if (vsize == 0) { MPN_COPY (rp, up, usize); rsize = usize; goto done; } if (vp[0] != 0) break; vp++, vsize--; } for (;;) { if (usize == 0) { MPN_COPY (rp, vp, vsize); rsize = vsize; negate ^= 1; goto done; } if (up[0] != 0) break; up++, usize--; } /* uuuu | uuuu | uuuu | uuuu | uuuu */ /* vvvvvvv | vv | vvvvv | v | vv */ if (usize > ediff) { /* U and V partially overlaps. */ if (ediff == 0) { /* Have to compare the leading limbs of u and v to determine whether to compute u - v or v - u. */ if (usize >= vsize) { /* uuuu */ /* vv */ mp_size_t size; size = usize - vsize; MPN_COPY (tp, up, size); mpn_sub_n (tp + size, up + size, vp, vsize); rsize = usize; } else /* (usize < vsize) */ { /* uuuu */ /* vvvvvvv */ mp_size_t size, i; size = vsize - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; mpn_sub_n (tp + size, up, vp + size, usize); mpn_sub_1 (tp + size, tp + size, usize, (mp_limb_t) 1); rsize = vsize; } } else { if (vsize + ediff <= usize) { /* uuuu */ /* v */ mp_size_t size; size = usize - ediff - vsize; MPN_COPY (tp, up, size); mpn_sub (tp + size, up + size, usize - size, vp, vsize); rsize = usize; } else { /* uuuu */ /* vvvvv */ mp_size_t size, i; size = vsize + ediff - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < size; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; mpn_sub (tp + size, up, usize, vp + size, usize - ediff); mpn_sub_1 (tp + size, tp + size, usize, (mp_limb_t) 1); rsize = vsize + ediff; } } } else { /* uuuu */ /* vv */ mp_size_t size, i; size = vsize + ediff - usize; tp[0] = -vp[0] & GMP_NUMB_MASK; for (i = 1; i < vsize; i++) tp[i] = ~vp[i] & GMP_NUMB_MASK; for (i = vsize; i < size; i++) tp[i] = GMP_NUMB_MAX; mpn_sub_1 (tp + size, up, usize, (mp_limb_t) 1); rsize = size + usize; } normalize: /* Full normalize. Optimize later. */ while (rsize != 0 && tp[rsize - 1] == 0) { rsize--; exp--; } MPN_COPY (rp, tp, rsize); } done: r->_mp_size = negate ? -rsize : rsize; if (rsize == 0) exp = 0; r->_mp_exp = exp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/mul_ui.c0000644000175000017500000001377114360276512014073 0ustar cammcamm/* mpf_mul_ui -- Multiply a float and an unsigned integer. Copyright 1993, 1994, 1996, 2001, 2003, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" /* The core operation is a multiply of PREC(r) limbs from u by v, producing either PREC(r) or PREC(r)+1 result limbs. If u is shorter than PREC(r), then we take only as much as it has. If u is longer we incorporate a carry from the lower limbs. If u has just 1 extra limb, then the carry to add is high(up[0]*v). That is of course what mpn_mul_1 would do if it was called with PREC(r)+1 limbs of input. If u has more than 1 extra limb, then there can be a further carry bit out of lower uncalculated limbs (the way the low of one product adds to the high of the product below it). This is of course what an mpn_mul_1 would do if it was called with the full u operand. But we instead work downwards explicitly, until a carry occurs or until a value other than GMP_NUMB_MAX occurs (that being the only value a carry bit can propagate across). The carry determination normally requires two umul_ppmm's, only rarely will GMP_NUMB_MAX occur and require further products. The carry limb is conveniently added into the mul_1 using mpn_mul_1c when that function exists, otherwise a subsequent mpn_add_1 is needed. Clearly when mpn_mul_1c is used the carry must be calculated first. But this is also the case when add_1 is used, since if r==u and ABSIZ(r) > PREC(r) then the mpn_mul_1 overwrites the low part of the input. A reuse r==u with size > prec can occur from a size PREC(r)+1 in the usual way, or it can occur from an mpf_set_prec_raw leaving a bigger sized value. In both cases we can end up calling mpn_mul_1 with overlapping src and dst regions, but this will be with dst < src and such an overlap is permitted. Not done: No attempt is made to determine in advance whether the result will be PREC(r) or PREC(r)+1 limbs. If it's going to be PREC(r)+1 then we could take one less limb from u and generate just PREC(r), that of course satisfying application requested precision. But any test counting bits or forming the high product would almost certainly take longer than the incremental cost of an extra limb in mpn_mul_1. Enhancements: Repeated mpf_mul_ui's with an even v will accumulate low zero bits on the result, leaving low zero limbs after a while, which it might be nice to strip to save work in subsequent operations. Calculating the low limb explicitly would let us direct mpn_mul_1 to put the balance at rp when the low is zero (instead of normally rp+1). But it's not clear whether this would be worthwhile. Explicit code for the low limb will probably be slower than having it done in mpn_mul_1, so we need to consider how often a zero will be stripped and how much that's likely to save later. */ void mpf_mul_ui (mpf_ptr r, mpf_srcptr u, unsigned long int v) { mp_srcptr up; mp_size_t usize; mp_size_t size; mp_size_t prec, excess; mp_limb_t cy_limb, vl, cbit, cin; mp_ptr rp; usize = u->_mp_size; if (UNLIKELY (v == 0) || UNLIKELY (usize == 0)) { r->_mp_size = 0; r->_mp_exp = 0; return; } #if BITS_PER_ULONG > GMP_NUMB_BITS /* avoid warnings about shift amount */ if (v > GMP_NUMB_MAX) { mpf_t vf; mp_limb_t vp[2]; vp[0] = v & GMP_NUMB_MASK; vp[1] = v >> GMP_NUMB_BITS; PTR(vf) = vp; SIZ(vf) = 2; ASSERT_CODE (PREC(vf) = 2); EXP(vf) = 2; mpf_mul (r, u, vf); return; } #endif size = ABS (usize); prec = r->_mp_prec; up = u->_mp_d; vl = v; excess = size - prec; cin = 0; if (excess > 0) { /* up is bigger than desired rp, shorten it to prec limbs and determine a carry-in */ mp_limb_t vl_shifted = vl << GMP_NAIL_BITS; mp_limb_t hi, lo, next_lo, sum; mp_size_t i; /* high limb of top product */ i = excess - 1; umul_ppmm (cin, lo, up[i], vl_shifted); /* and carry bit out of products below that, if any */ for (;;) { i--; if (i < 0) break; umul_ppmm (hi, next_lo, up[i], vl_shifted); lo >>= GMP_NAIL_BITS; ADDC_LIMB (cbit, sum, hi, lo); cin += cbit; lo = next_lo; /* Continue only if the sum is GMP_NUMB_MAX. GMP_NUMB_MAX is the only value a carry from below can propagate across. If we've just seen the carry out (ie. cbit!=0) then sum!=GMP_NUMB_MAX, so this test stops us for that case too. */ if (LIKELY (sum != GMP_NUMB_MAX)) break; } up += excess; size = prec; } rp = r->_mp_d; #if HAVE_NATIVE_mpn_mul_1c cy_limb = mpn_mul_1c (rp, up, size, vl, cin); #else cy_limb = mpn_mul_1 (rp, up, size, vl); __GMPN_ADD_1 (cbit, rp, rp, size, cin); cy_limb += cbit; #endif rp[size] = cy_limb; cy_limb = cy_limb != 0; r->_mp_exp = u->_mp_exp + cy_limb; size += cy_limb; r->_mp_size = usize >= 0 ? size : -size; } gcl-2.6.14/gmp4/mpf/fits_s.h0000644000175000017500000000347114360276512014071 0ustar cammcamm/* mpf_fits_s*_p -- test whether an mpf fits a C signed type. Copyright 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Notice this is equivalent to mpz_set_f + mpz_fits_s*_p. */ int FUNCTION (mpf_srcptr f) __GMP_NOTHROW { mp_size_t fs, fn; mp_srcptr fp; mp_exp_t exp; mp_limb_t fl; fs = SIZ(f); if (fs == 0) return 1; /* zero fits */ exp = EXP(f); if (exp < 1) return 1; /* -1 < f < 1 truncates to zero, so fits */ fp = PTR(f); fn = ABS (fs); if (exp == 1) { fl = fp[fn-1]; } #if GMP_NAIL_BITS != 0 else if (exp == 2 && MAXIMUM > GMP_NUMB_MAX) { fl = fp[fn-1]; if ((fl >> GMP_NAIL_BITS) != 0) return 0; fl = (fl << GMP_NUMB_BITS); if (fn >= 2) fl |= fp[fn-2]; } #endif else return 0; return fl <= (fs >= 0 ? (mp_limb_t) MAXIMUM : - (mp_limb_t) MINIMUM); } gcl-2.6.14/gmp4/mpf/iset_si.c0000644000175000017500000000320414360276512014226 0ustar cammcamm/* mpf_init_set_si() -- Initialize a float and assign it from a signed int. Copyright 1993-1995, 2000, 2001, 2003, 2004, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init_set_si (mpf_ptr r, long int val) { mp_size_t prec = __gmp_default_fp_limb_precision; mp_size_t size; mp_limb_t vl; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); vl = (mp_limb_t) ABS_CAST (unsigned long int, val); r->_mp_d[0] = vl & GMP_NUMB_MASK; size = vl != 0; #if BITS_PER_ULONG > GMP_NUMB_BITS vl >>= GMP_NUMB_BITS; r->_mp_d[1] = vl; size += (vl != 0); #endif r->_mp_exp = size; r->_mp_size = val >= 0 ? size : -size; } gcl-2.6.14/gmp4/mpf/reldiff.c0000644000175000017500000000347714360276512014216 0ustar cammcamm/* mpf_reldiff -- Generate the relative difference of two floats. Copyright 1996, 2001, 2004, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* The precision we use for d = x-y is based on what mpf_div will want from the dividend. It calls mpn_div_q to produce a quotient of rprec+1 limbs. So rprec+1 == dsize - xsize + 1, hence dprec = rprec+xsize. */ void mpf_reldiff (mpf_t rdiff, mpf_srcptr x, mpf_srcptr y) { if (UNLIKELY (SIZ(x) == 0)) { mpf_set_ui (rdiff, (unsigned long int) (mpf_sgn (y) != 0)); } else { mp_size_t dprec; mpf_t d; TMP_DECL; TMP_MARK; dprec = PREC(rdiff) + ABSIZ(x); ASSERT (PREC(rdiff)+1 == dprec - ABSIZ(x) + 1); PREC(d) = dprec; PTR(d) = TMP_ALLOC_LIMBS (dprec + 1); mpf_sub (d, x, y); SIZ(d) = ABSIZ(d); mpf_div (rdiff, d, x); TMP_FREE; } } gcl-2.6.14/gmp4/mpf/Makefile.am0000644000175000017500000000355114360276512014464 0ustar cammcamm## Process this file with automake to generate Makefile.in # Copyright 1996, 1998-2002 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. INCLUDES = -D__GMP_WITHIN_GMP -I$(top_srcdir) noinst_LTLIBRARIES = libmpf.la libmpf_la_SOURCES = \ init.c init2.c inits.c set.c set_ui.c set_si.c set_str.c set_d.c set_z.c \ set_q.c iset.c iset_ui.c iset_si.c iset_str.c iset_d.c clear.c clears.c \ get_str.c dump.c size.c eq.c reldiff.c sqrt.c random2.c inp_str.c out_str.c \ add.c add_ui.c sub.c sub_ui.c ui_sub.c mul.c mul_ui.c div.c div_ui.c \ cmp.c cmp_d.c cmp_si.c cmp_ui.c mul_2exp.c div_2exp.c abs.c neg.c get_d.c \ get_d_2exp.c set_dfl_prec.c set_prc.c set_prc_raw.c get_dfl_prec.c get_prc.c \ ui_div.c sqrt_ui.c \ pow_ui.c urandomb.c swap.c get_si.c get_ui.c int_p.c \ ceilfloor.c trunc.c \ fits_sint.c fits_slong.c fits_sshort.c \ fits_uint.c fits_ulong.c fits_ushort.c \ fits_s.h fits_u.h gcl-2.6.14/gmp4/mpf/iset.c0000644000175000017500000000324114360276512013534 0ustar cammcamm/* mpf_init_set -- Initialize a float and assign it from another float. Copyright 1993-1995, 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init_set (mpf_ptr r, mpf_srcptr s) { mp_ptr rp, sp; mp_size_t ssize, size; mp_size_t prec; prec = __gmp_default_fp_limb_precision; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); r->_mp_prec = prec; prec++; /* lie not to lose precision in assignment */ ssize = s->_mp_size; size = ABS (ssize); rp = r->_mp_d; sp = s->_mp_d; if (size > prec) { sp += size - prec; size = prec; } r->_mp_exp = s->_mp_exp; r->_mp_size = ssize >= 0 ? size : -size; MPN_COPY (rp, sp, size); } gcl-2.6.14/gmp4/mpf/out_str.c0000644000175000017500000000555514360276512014301 0ustar cammcamm/* mpf_out_str (stream, base, n_digits, op) -- Print N_DIGITS digits from the float OP to STREAM in base BASE. Return the number of characters written, or 0 if an error occurred. Copyright 1996, 1997, 2001, 2002, 2005, 2011 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define _GNU_SOURCE /* for DECIMAL_POINT in langinfo.h */ #include "config.h" #include #include #if HAVE_LANGINFO_H #include /* for nl_langinfo */ #endif #if HAVE_LOCALE_H #include /* for localeconv */ #endif #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" size_t mpf_out_str (FILE *stream, int base, size_t n_digits, mpf_srcptr op) { char *str; mp_exp_t exp; size_t written; TMP_DECL; TMP_MARK; if (base == 0) base = 10; if (n_digits == 0) MPF_SIGNIFICANT_DIGITS (n_digits, base, op->_mp_prec); if (stream == 0) stream = stdout; /* Consider these changes: * Don't allocate memory here for huge n_digits; pass NULL to mpf_get_str. * Make mpf_get_str allocate extra space when passed NULL, to avoid allocating two huge string buffers. * Implement more/other allocation reductions tricks. */ str = (char *) TMP_ALLOC (n_digits + 2); /* extra for minus sign and \0 */ mpf_get_str (str, &exp, base, n_digits, op); n_digits = strlen (str); written = 0; /* Write sign */ if (str[0] == '-') { str++; fputc ('-', stream); written = 1; n_digits--; } { const char *point = GMP_DECIMAL_POINT; size_t pointlen = strlen (point); putc ('0', stream); fwrite (point, 1, pointlen, stream); written += pointlen + 1; } /* Write mantissa */ { size_t fwret; fwret = fwrite (str, 1, n_digits, stream); written += fwret; } /* Write exponent */ { int fpret; fpret = fprintf (stream, (base <= 10 ? "e%ld" : "@%ld"), exp); written += fpret; } TMP_FREE; return ferror (stream) ? 0 : written; } gcl-2.6.14/gmp4/mpf/inits.c0000644000175000017500000000246314360276512013723 0ustar cammcamm/* mpf_inits() -- Initialize multiple mpf_t variables and set them to 0. Copyright 2009 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" void mpf_inits (mpf_ptr x, ...) { va_list ap; va_start (ap, x); while (x != NULL) { mpf_init (x); x = va_arg (ap, mpf_ptr); } va_end (ap); } gcl-2.6.14/gmp4/mpf/pow_ui.c0000644000175000017500000000257714360276512014105 0ustar cammcamm/* mpf_pow_ui -- Compute b^e. Copyright 1998, 1999, 2001, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_pow_ui (mpf_ptr r, mpf_srcptr b, unsigned long int e) { mpf_t b2; mpf_init2 (b2, mpf_get_prec (r)); mpf_set (b2, b); if ((e & 1) != 0) mpf_set (r, b); else mpf_set_ui (r, 1); while (e >>= 1) { mpf_mul (b2, b2, b2); if ((e & 1) != 0) mpf_mul (r, r, b2); } mpf_clear (b2); } gcl-2.6.14/gmp4/mpf/sqrt.c0000644000175000017500000000713514360276512013567 0ustar cammcamm/* mpf_sqrt -- Compute the square root of a float. Copyright 1993, 1994, 1996, 2000, 2001, 2004, 2005, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" /* As usual, the aim is to produce PREC(r) limbs of result, with the high limb non-zero. This is accomplished by applying mpn_sqrtrem to either 2*prec or 2*prec-1 limbs, both such sizes resulting in prec limbs. The choice between 2*prec or 2*prec-1 limbs is based on the input exponent. With b=2^GMP_NUMB_BITS the limb base then we can think of effectively taking out a factor b^(2k), for suitable k, to get to an integer input of the desired size ready for mpn_sqrtrem. It must be an even power taken out, ie. an even number of limbs, so the square root gives factor b^k and the radix point is still on a limb boundary. So if EXP(r) is even we'll get an even number of input limbs 2*prec, or if EXP(r) is odd we get an odd number 2*prec-1. Further limbs below the 2*prec or 2*prec-1 used don't affect the result and are simply truncated. This can be seen by considering an integer x, with s=floor(sqrt(x)). s is the unique integer satisfying s^2 <= x < (s+1)^2. Notice that adding a fraction part to x (ie. some further bits) doesn't change the inequality, s remains the unique solution. Working suitable factors of 2 into this argument lets it apply to an intended precision at any position for any x, not just the integer binary point. If the input is smaller than 2*prec or 2*prec-1, then we just pad with zeros, that of course being our usual interpretation of short inputs. The effect is to extend the root beyond the size of the input (for instance into fractional limbs if u is an integer). */ void mpf_sqrt (mpf_ptr r, mpf_srcptr u) { mp_size_t usize; mp_ptr up, tp; mp_size_t prec, tsize; mp_exp_t uexp, expodd; TMP_DECL; usize = u->_mp_size; if (UNLIKELY (usize <= 0)) { if (usize < 0) SQRT_OF_NEGATIVE; r->_mp_size = 0; r->_mp_exp = 0; return; } TMP_MARK; uexp = u->_mp_exp; prec = r->_mp_prec; up = u->_mp_d; expodd = (uexp & 1); tsize = 2 * prec - expodd; r->_mp_size = prec; r->_mp_exp = (uexp + expodd) / 2; /* ceil(uexp/2) */ /* root size is ceil(tsize/2), this will be our desired "prec" limbs */ ASSERT ((tsize + 1) / 2 == prec); tp = TMP_ALLOC_LIMBS (tsize); if (usize > tsize) { up += usize - tsize; usize = tsize; MPN_COPY (tp, up, tsize); } else { MPN_ZERO (tp, tsize - usize); MPN_COPY (tp + (tsize - usize), up, usize); } mpn_sqrtrem (r->_mp_d, NULL, tp, tsize); TMP_FREE; } gcl-2.6.14/gmp4/mpf/iset_d.c0000644000175000017500000000251114360276512014036 0ustar cammcamm/* mpf_init_set_d -- Initialize a float and assign it from a double. Copyright 1993-1995, 2000, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_init_set_d (mpf_ptr r, double val) { mp_size_t prec = __gmp_default_fp_limb_precision; r->_mp_prec = prec; r->_mp_d = (mp_ptr) (*__gmp_allocate_func) ((size_t) (prec + 1) * GMP_LIMB_BYTES); mpf_set_d (r, val); } gcl-2.6.14/gmp4/mpf/get_str.c0000644000175000017500000002120114360276512014233 0ustar cammcamm/* mpf_get_str (digit_ptr, exp, base, n_digits, a) -- Convert the floating point number A to a base BASE number and store N_DIGITS raw digits at DIGIT_PTR, and the base BASE exponent in the word pointed to by EXP. For example, the number 3.1416 would be returned as "31416" in DIGIT_PTR and 1 in EXP. Copyright 1993-1997, 2000-2003, 2005, 2006, 2011 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" /* for count_leading_zeros */ /* Could use some more work. 1. Allocation is excessive. Try to combine areas. Perhaps use result string area for temp limb space? 2. We generate up to two limbs of extra digits. This is because we don't check the exact number of bits in the input operand, and from that compute an accurate exponent (variable e in the code). It would be cleaner and probably somewhat faster to change this. */ /* Compute base^exp and return the most significant prec limbs in rp[]. Put the count of omitted low limbs in *ign. Return the actual size (which might be less than prec). Allocation of rp[] and the temporary tp[] should be 2*prec+2 limbs. */ static mp_size_t mpn_pow_1_highpart (mp_ptr rp, mp_size_t *ignp, mp_limb_t base, unsigned long exp, mp_size_t prec, mp_ptr tp) { mp_size_t ign; /* counts number of ignored low limbs in r */ mp_size_t off; /* keeps track of offset where value starts */ mp_ptr passed_rp = rp; mp_size_t rn; int cnt; int i; if (exp == 0) { rp[0] = 1; *ignp = 0; return 1; } rp[0] = base; rn = 1; off = 0; ign = 0; count_leading_zeros (cnt, exp); for (i = GMP_LIMB_BITS - cnt - 2; i >= 0; i--) { mpn_sqr (tp, rp + off, rn); rn = 2 * rn; rn -= tp[rn - 1] == 0; ign <<= 1; off = 0; if (rn > prec) { ign += rn - prec; off = rn - prec; rn = prec; } MP_PTR_SWAP (rp, tp); if (((exp >> i) & 1) != 0) { mp_limb_t cy; cy = mpn_mul_1 (rp, rp + off, rn, base); rp[rn] = cy; rn += cy != 0; off = 0; } } if (rn > prec) { ASSERT (rn == prec + 1); ign += rn - prec; rp += rn - prec; rn = prec; } /* With somewhat less than 50% probability, we can skip this copy. */ if (passed_rp != rp + off) MPN_COPY_INCR (passed_rp, rp + off, rn); *ignp = ign; return rn; } char * mpf_get_str (char *dbuf, mp_exp_t *exp, int base, size_t n_digits, mpf_srcptr u) { mp_exp_t ue; mp_size_t n_limbs_needed; size_t max_digits; mp_ptr up, pp, tp; mp_size_t un, pn, tn; unsigned char *tstr; mp_exp_t exp_in_base; size_t n_digits_computed; mp_size_t i; const char *num_to_text; size_t alloc_size = 0; char *dp; TMP_DECL; up = PTR(u); un = ABSIZ(u); ue = EXP(u); if (base >= 0) { num_to_text = "0123456789abcdefghijklmnopqrstuvwxyz"; if (base <= 1) base = 10; else if (base > 36) { num_to_text = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; if (base > 62) return NULL; } } else { base = -base; if (base <= 1) base = 10; else if (base > 36) return NULL; num_to_text = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; } MPF_SIGNIFICANT_DIGITS (max_digits, base, PREC(u)); if (n_digits == 0 || n_digits > max_digits) n_digits = max_digits; if (dbuf == 0) { /* We didn't get a string from the user. Allocate one (and return a pointer to it) with space for `-' and terminating null. */ alloc_size = n_digits + 2; dbuf = (char *) (*__gmp_allocate_func) (n_digits + 2); } if (un == 0) { *exp = 0; *dbuf = 0; n_digits = 0; goto done; } TMP_MARK; /* Allocate temporary digit space. We can't put digits directly in the user area, since we generate more digits than requested. (We allocate 2 * GMP_LIMB_BITS extra bytes because of the digit block nature of the conversion.) */ tstr = (unsigned char *) TMP_ALLOC (n_digits + 2 * GMP_LIMB_BITS + 3); LIMBS_PER_DIGIT_IN_BASE (n_limbs_needed, n_digits, base); if (ue <= n_limbs_needed) { /* We need to multiply number by base^n to get an n_digits integer part. */ mp_size_t n_more_limbs_needed, ign, off; unsigned long e; n_more_limbs_needed = n_limbs_needed - ue; DIGITS_IN_BASE_PER_LIMB (e, n_more_limbs_needed, base); if (un > n_limbs_needed) { up += un - n_limbs_needed; un = n_limbs_needed; } pp = TMP_ALLOC_LIMBS (2 * n_limbs_needed + 2); tp = TMP_ALLOC_LIMBS (2 * n_limbs_needed + 2); pn = mpn_pow_1_highpart (pp, &ign, (mp_limb_t) base, e, n_limbs_needed, tp); if (un > pn) mpn_mul (tp, up, un, pp, pn); /* FIXME: mpn_mul_highpart */ else mpn_mul (tp, pp, pn, up, un); /* FIXME: mpn_mul_highpart */ tn = un + pn; tn -= tp[tn - 1] == 0; off = un - ue - ign; if (off < 0) { MPN_COPY_DECR (tp - off, tp, tn); MPN_ZERO (tp, -off); tn -= off; off = 0; } n_digits_computed = mpn_get_str (tstr, base, tp + off, tn - off); exp_in_base = n_digits_computed - e; } else { /* We need to divide number by base^n to get an n_digits integer part. */ mp_size_t n_less_limbs_needed, ign, off, xn; unsigned long e; mp_ptr dummyp, xp; n_less_limbs_needed = ue - n_limbs_needed; DIGITS_IN_BASE_PER_LIMB (e, n_less_limbs_needed, base); if (un > n_limbs_needed) { up += un - n_limbs_needed; un = n_limbs_needed; } pp = TMP_ALLOC_LIMBS (2 * n_limbs_needed + 2); tp = TMP_ALLOC_LIMBS (2 * n_limbs_needed + 2); pn = mpn_pow_1_highpart (pp, &ign, (mp_limb_t) base, e, n_limbs_needed, tp); xn = n_limbs_needed + (n_less_limbs_needed-ign); xp = TMP_ALLOC_LIMBS (xn); off = xn - un; MPN_ZERO (xp, off); MPN_COPY (xp + off, up, un); dummyp = TMP_ALLOC_LIMBS (pn); mpn_tdiv_qr (tp, dummyp, (mp_size_t) 0, xp, xn, pp, pn); tn = xn - pn + 1; tn -= tp[tn - 1] == 0; n_digits_computed = mpn_get_str (tstr, base, tp, tn); exp_in_base = n_digits_computed + e; } /* We should normally have computed too many digits. Round the result at the point indicated by n_digits. */ if (n_digits_computed > n_digits) { size_t i; /* Round the result. */ if (tstr[n_digits] * 2 >= base) { n_digits_computed = n_digits; for (i = n_digits - 1;; i--) { unsigned int x; x = ++(tstr[i]); if (x != base) break; n_digits_computed--; if (i == 0) { /* We had something like `bbbbbbb...bd', where 2*d >= base and `b' denotes digit with significance base - 1. This rounds up to `1', increasing the exponent. */ tstr[0] = 1; n_digits_computed = 1; exp_in_base++; break; } } } } /* We might have fewer digits than requested as a result of rounding above, (i.e. 0.999999 => 1.0) or because we have a number that simply doesn't need many digits in this base (e.g., 0.125 in base 10). */ if (n_digits > n_digits_computed) n_digits = n_digits_computed; /* Remove trailing 0. There can be many zeros. */ while (n_digits != 0 && tstr[n_digits - 1] == 0) n_digits--; dp = dbuf + (SIZ(u) < 0); /* Translate to ASCII and copy to result string. */ for (i = 0; i < n_digits; i++) dp[i] = num_to_text[tstr[i]]; dp[n_digits] = 0; *exp = exp_in_base; if (SIZ(u) < 0) { dbuf[0] = '-'; n_digits++; } TMP_FREE; done: /* If the string was alloced then resize it down to the actual space required. */ if (alloc_size != 0) { __GMP_REALLOCATE_FUNC_MAYBE_TYPE (dbuf, alloc_size, n_digits + 1, char); } return dbuf; } gcl-2.6.14/gmp4/mpf/clears.c0000644000175000017500000000254214360276512014044 0ustar cammcamm/* mpf_clears() -- Clear multiple mpf_t variables. Copyright 2009, 2014 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" void mpf_clears (mpf_ptr x, ...) { va_list ap; va_start (ap, x); while (x != NULL) { (*__gmp_free_func) (x->_mp_d, (size_t) (x->_mp_prec + 1) * GMP_LIMB_BYTES); x = va_arg (ap, mpf_ptr); } va_end (ap); } gcl-2.6.14/gmp4/mpf/size.c0000644000175000017500000000230114360276512013536 0ustar cammcamm/* mpf_size(x) -- return the number of limbs currently used by the value of the float X. Copyright 1993-1995, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" size_t mpf_size (mpf_srcptr f) __GMP_NOTHROW { return __GMP_ABS (f->_mp_size); } gcl-2.6.14/gmp4/mpf/set_prc.c0000644000175000017500000000411414360276512014227 0ustar cammcamm/* mpf_set_prec(x) -- Change the precision of x. Copyright 1993-1995, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* A full new_prec+1 limbs are always retained, even though just new_prec would satisfy the requested precision. If size==new_prec+1 then certainly new_prec+1 should be kept since no copying is needed in that case. If just new_prec was kept for size>new_prec+1 it'd be a bit inconsistent. */ void mpf_set_prec (mpf_ptr x, mp_bitcnt_t new_prec_in_bits) { mp_size_t old_prec, new_prec, new_prec_plus1; mp_size_t size, sign; mp_ptr xp; new_prec = __GMPF_BITS_TO_PREC (new_prec_in_bits); old_prec = PREC(x); /* do nothing if already the right precision */ if (new_prec == old_prec) return; PREC(x) = new_prec; new_prec_plus1 = new_prec + 1; /* retain most significant limbs */ sign = SIZ(x); size = ABS (sign); xp = PTR(x); if (size > new_prec_plus1) { SIZ(x) = (sign >= 0 ? new_prec_plus1 : -new_prec_plus1); MPN_COPY_INCR (xp, xp + size - new_prec_plus1, new_prec_plus1); } PTR(x) = __GMP_REALLOCATE_FUNC_LIMBS (xp, old_prec+1, new_prec_plus1); } gcl-2.6.14/gmp4/mpf/dump.c0000644000175000017500000000312414360276512013535 0ustar cammcamm/* mpf_dump -- Dump a float to stdout. THIS IS AN INTERNAL FUNCTION WITH A MUTABLE INTERFACE. IT IS NOT SAFE TO CALL THIS FUNCTION DIRECTLY. IN FACT, IT IS ALMOST GUARANTEED THAT THIS FUNCTION WILL CHANGE OR DISAPPEAR IN A FUTURE GNU MP RELEASE. Copyright 1993-1995, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include /* for strlen */ #include "gmp.h" #include "gmp-impl.h" void mpf_dump (mpf_srcptr u) { mp_exp_t exp; char *str; str = mpf_get_str (0, &exp, 10, 0, u); if (str[0] == '-') printf ("-0.%se%ld\n", str + 1, exp); else printf ("0.%se%ld\n", str, exp); (*__gmp_free_func) (str, strlen (str) + 1); } gcl-2.6.14/gmp4/mpf/fits_ushort.c0000644000175000017500000000217114360276512015142 0ustar cammcamm/* mpf_fits_ushort_p -- test whether an mpf fits an unsigned short. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_ushort_p #define MAXIMUM USHRT_MAX #include "fits_u.h" gcl-2.6.14/gmp4/mpf/div_2exp.c0000644000175000017500000001116214360276512014311 0ustar cammcamm/* mpf_div_2exp -- Divide a float by 2^n. Copyright 1993, 1994, 1996, 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Multiples of GMP_NUMB_BITS in exp simply mean an amount subtracted from EXP(u) to set EXP(r). The remainder exp%GMP_NUMB_BITS is then a right shift for the limb data. If exp%GMP_NUMB_BITS == 0 then there's no shifting, we effectively just do an mpz_set with changed EXP(r). Like mpz_set we take prec+1 limbs in this case. Although just prec would suffice, it's nice to have mpf_div_2exp with exp==0 come out the same as mpz_set. When shifting we take up to prec many limbs from the input. Our shift is cy = mpn_rshift (PTR(r)+1, PTR(u)+k, ...), where k is the number of low limbs dropped from u, and the carry out is stored to PTR(r)[0]. We don't try to work extra bits from PTR(u)[k-1] (when k>=1 makes it available) into that low carry limb. Just prec limbs (with the high non-zero) from the input is enough bits for the application requested precision, no need to do extra work. If r==u the shift will have overlapping operands. When k>=1 (ie. when usize > prec), the overlap is in the style supported by rshift (ie. dst <= src). But when r==u and k==0 (ie. usize <= prec), we would have an invalid overlap (mpn_rshift (rp+1, rp, ...)). In this case we must instead use mpn_lshift (PTR(r), PTR(u), size, NUMB-shift). An lshift by NUMB-shift bits gives identical data of course, it's just its overlap restrictions which differ. In both shift cases, the resulting data is abs_usize+1 limbs. "adj" is used to add +1 to that size if the high is non-zero (it may of course have become zero by the shifting). EXP(u) is the exponent just above those abs_usize+1 limbs, so it gets -1+adj, which means -1 if the high is zero, or no change if the high is non-zero. Enhancements: The way mpn_lshift is used means successive mpf_div_2exp calls on the same operand will accumulate low zero limbs, until prec+1 limbs is reached. This is wasteful for subsequent operations. When abs_usize <= prec, we should test the low exp%GMP_NUMB_BITS many bits of PTR(u)[0], ie. those which would be shifted out by an mpn_rshift. If they're zero then use that mpn_rshift. */ void mpf_div_2exp (mpf_ptr r, mpf_srcptr u, mp_bitcnt_t exp) { mp_srcptr up; mp_ptr rp = r->_mp_d; mp_size_t usize; mp_size_t abs_usize; mp_size_t prec = r->_mp_prec; mp_exp_t uexp = u->_mp_exp; usize = u->_mp_size; if (UNLIKELY (usize == 0)) { r->_mp_size = 0; r->_mp_exp = 0; return; } abs_usize = ABS (usize); up = u->_mp_d; if (exp % GMP_NUMB_BITS == 0) { prec++; /* retain more precision here as we don't need to account for carry-out here */ if (abs_usize > prec) { up += abs_usize - prec; abs_usize = prec; } if (rp != up) MPN_COPY_INCR (rp, up, abs_usize); r->_mp_exp = uexp - exp / GMP_NUMB_BITS; } else { mp_limb_t cy_limb; mp_size_t adj; if (abs_usize > prec) { up += abs_usize - prec; abs_usize = prec; /* Use mpn_rshift since mpn_lshift operates downwards, and we therefore would clobber part of U before using that part, in case R is the same variable as U. */ cy_limb = mpn_rshift (rp + 1, up, abs_usize, exp % GMP_NUMB_BITS); rp[0] = cy_limb; adj = rp[abs_usize] != 0; } else { cy_limb = mpn_lshift (rp, up, abs_usize, GMP_NUMB_BITS - exp % GMP_NUMB_BITS); rp[abs_usize] = cy_limb; adj = cy_limb != 0; } abs_usize += adj; r->_mp_exp = uexp - exp / GMP_NUMB_BITS - 1 + adj; } r->_mp_size = usize >= 0 ? abs_usize : -abs_usize; } gcl-2.6.14/gmp4/mpf/set_str.c0000644000175000017500000002145514360276512014262 0ustar cammcamm/* mpf_set_str (dest, string, base) -- Convert the string STRING in base BASE to a float in dest. If BASE is zero, the leading characters of STRING is used to figure out the base. Copyright 1993-1997, 2000-2003, 2005, 2007, 2008, 2011, 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* This still needs work, as suggested by some FIXME comments. 1. Don't depend on superfluous mantissa digits. 2. Allocate temp space more cleverly. 3. Use mpn_div_q instead of mpn_lshift+mpn_divrem. */ #define _GNU_SOURCE /* for DECIMAL_POINT in langinfo.h */ #include "config.h" #include #include #include #if HAVE_LANGINFO_H #include /* for nl_langinfo */ #endif #if HAVE_LOCALE_H #include /* for localeconv */ #endif #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" #define digit_value_tab __gmp_digit_value_tab /* Compute base^exp and return the most significant prec limbs in rp[]. Put the count of omitted low limbs in *ign. Return the actual size (which might be less than prec). */ static mp_size_t mpn_pow_1_highpart (mp_ptr rp, mp_size_t *ignp, mp_limb_t base, mp_exp_t exp, mp_size_t prec, mp_ptr tp) { mp_size_t ign; /* counts number of ignored low limbs in r */ mp_size_t off; /* keeps track of offset where value starts */ mp_ptr passed_rp = rp; mp_size_t rn; int cnt; int i; rp[0] = base; rn = 1; off = 0; ign = 0; count_leading_zeros (cnt, exp); for (i = GMP_LIMB_BITS - cnt - 2; i >= 0; i--) { mpn_sqr (tp, rp + off, rn); rn = 2 * rn; rn -= tp[rn - 1] == 0; ign <<= 1; off = 0; if (rn > prec) { ign += rn - prec; off = rn - prec; rn = prec; } MP_PTR_SWAP (rp, tp); if (((exp >> i) & 1) != 0) { mp_limb_t cy; cy = mpn_mul_1 (rp, rp + off, rn, base); rp[rn] = cy; rn += cy != 0; off = 0; } } if (rn > prec) { ign += rn - prec; rp += rn - prec; rn = prec; } MPN_COPY_INCR (passed_rp, rp + off, rn); *ignp = ign; return rn; } int mpf_set_str (mpf_ptr x, const char *str, int base) { size_t str_size; char *s, *begs; size_t i, j; int c; int negative; char *dotpos = 0; const char *expptr; int exp_base; const char *point = GMP_DECIMAL_POINT; size_t pointlen = strlen (point); const unsigned char *digit_value; TMP_DECL; c = (unsigned char) *str; /* Skip whitespace. */ while (isspace (c)) c = (unsigned char) *++str; negative = 0; if (c == '-') { negative = 1; c = (unsigned char) *++str; } /* Default base to decimal. */ if (base == 0) base = 10; exp_base = base; if (base < 0) { exp_base = 10; base = -base; } digit_value = digit_value_tab; if (base > 36) { /* For bases > 36, use the collating sequence 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz. */ digit_value += 208; if (base > 62) return -1; /* too large base */ } /* Require at least one digit, possibly after an initial decimal point. */ if (digit_value[c] >= base) { /* not a digit, must be a decimal point */ for (i = 0; i < pointlen; i++) if (str[i] != point[i]) return -1; if (digit_value[(unsigned char) str[pointlen]] >= base) return -1; } /* Locate exponent part of the input. Look from the right of the string, since the exponent is usually a lot shorter than the mantissa. */ expptr = NULL; str_size = strlen (str); for (i = str_size - 1; i > 0; i--) { c = (unsigned char) str[i]; if (c == '@' || (base <= 10 && (c == 'e' || c == 'E'))) { expptr = str + i + 1; str_size = i; break; } } TMP_MARK; s = begs = (char *) TMP_ALLOC (str_size + 1); /* Loop through mantissa, converting it from ASCII to raw byte values. */ for (i = 0; i < str_size; i++) { c = (unsigned char) *str; if (!isspace (c)) { int dig; for (j = 0; j < pointlen; j++) if (str[j] != point[j]) goto not_point; if (1) { if (dotpos != 0) { /* already saw a decimal point, another is invalid */ TMP_FREE; return -1; } dotpos = s; str += pointlen - 1; i += pointlen - 1; } else { not_point: dig = digit_value[c]; if (dig >= base) { TMP_FREE; return -1; } *s++ = dig; } } c = (unsigned char) *++str; } str_size = s - begs; { long exp_in_base; mp_size_t ra, ma, rn, mn; int cnt; mp_ptr mp, tp, rp; mp_exp_t exp_in_limbs; mp_size_t prec = PREC(x) + 1; int divflag; mp_size_t madj, radj; #if 0 size_t n_chars_needed; /* This breaks things like 0.000...0001. To safely ignore superfluous digits, we need to skip over leading zeros. */ /* Just consider the relevant leading digits of the mantissa. */ LIMBS_PER_DIGIT_IN_BASE (n_chars_needed, prec, base); if (str_size > n_chars_needed) str_size = n_chars_needed; #endif LIMBS_PER_DIGIT_IN_BASE (ma, str_size, base); mp = TMP_ALLOC_LIMBS (ma); mn = mpn_set_str (mp, (unsigned char *) begs, str_size, base); if (mn == 0) { SIZ(x) = 0; EXP(x) = 0; TMP_FREE; return 0; } madj = 0; /* Ignore excess limbs in MP,MSIZE. */ if (mn > prec) { madj = mn - prec; mp += mn - prec; mn = prec; } if (expptr != 0) { /* Scan and convert the exponent, in base exp_base. */ long dig, minus, plusminus; c = (unsigned char) *expptr; minus = -(long) (c == '-'); plusminus = minus | -(long) (c == '+'); expptr -= plusminus; /* conditional increment */ c = (unsigned char) *expptr++; dig = digit_value[c]; if (dig >= exp_base) { TMP_FREE; return -1; } exp_in_base = dig; c = (unsigned char) *expptr++; dig = digit_value[c]; while (dig < exp_base) { exp_in_base = exp_in_base * exp_base; exp_in_base += dig; c = (unsigned char) *expptr++; dig = digit_value[c]; } exp_in_base = (exp_in_base ^ minus) - minus; /* conditional negation */ } else exp_in_base = 0; if (dotpos != 0) exp_in_base -= s - dotpos; divflag = exp_in_base < 0; exp_in_base = ABS (exp_in_base); if (exp_in_base == 0) { MPN_COPY (PTR(x), mp, mn); SIZ(x) = negative ? -mn : mn; EXP(x) = mn + madj; TMP_FREE; return 0; } ra = 2 * (prec + 1); rp = TMP_ALLOC_LIMBS (ra); tp = TMP_ALLOC_LIMBS (ra); rn = mpn_pow_1_highpart (rp, &radj, (mp_limb_t) base, exp_in_base, prec, tp); if (divflag) { #if 0 /* FIXME: Should use mpn_div_q here. */ ... mpn_div_q (tp, mp, mn, rp, rn, scratch); ... #else mp_ptr qp; mp_limb_t qlimb; if (mn < rn) { /* Pad out MP,MSIZE for current divrem semantics. */ mp_ptr tmp = TMP_ALLOC_LIMBS (rn + 1); MPN_ZERO (tmp, rn - mn); MPN_COPY (tmp + rn - mn, mp, mn); mp = tmp; madj -= rn - mn; mn = rn; } if ((rp[rn - 1] & GMP_NUMB_HIGHBIT) == 0) { mp_limb_t cy; count_leading_zeros (cnt, rp[rn - 1]); cnt -= GMP_NAIL_BITS; mpn_lshift (rp, rp, rn, cnt); cy = mpn_lshift (mp, mp, mn, cnt); if (cy) mp[mn++] = cy; } qp = TMP_ALLOC_LIMBS (prec + 1); qlimb = mpn_divrem (qp, prec - (mn - rn), mp, mn, rp, rn); tp = qp; exp_in_limbs = qlimb + (mn - rn) + (madj - radj); rn = prec; if (qlimb != 0) { tp[prec] = qlimb; /* Skip the least significant limb not to overrun the destination variable. */ tp++; } #endif } else { tp = TMP_ALLOC_LIMBS (rn + mn); if (rn > mn) mpn_mul (tp, rp, rn, mp, mn); else mpn_mul (tp, mp, mn, rp, rn); rn += mn; rn -= tp[rn - 1] == 0; exp_in_limbs = rn + madj + radj; if (rn > prec) { tp += rn - prec; rn = prec; exp_in_limbs += 0; } } MPN_COPY (PTR(x), tp, rn); SIZ(x) = negative ? -rn : rn; EXP(x) = exp_in_limbs; TMP_FREE; return 0; } } gcl-2.6.14/gmp4/mpf/cmp_si.c0000644000175000017500000000564514360276512014054 0ustar cammcamm/* mpf_cmp_si -- Compare a float with a signed integer. Copyright 1993-1995, 1999-2002, 2004, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" int mpf_cmp_si (mpf_srcptr u, long int vval) __GMP_NOTHROW { mp_srcptr up; mp_size_t usize; mp_exp_t uexp; mp_limb_t ulimb; int usign; unsigned long abs_vval; uexp = u->_mp_exp; usize = u->_mp_size; /* 1. Are the signs different? */ if ((usize < 0) == (vval < 0)) /* don't use xor, type size may differ */ { /* U and V are both non-negative or both negative. */ if (usize == 0) /* vval >= 0 */ return -(vval != 0); if (vval == 0) /* usize >= 0 */ return usize != 0; /* Fall out. */ } else { /* Either U or V is negative, but not both. */ return usize >= 0 ? 1 : -1; } /* U and V have the same sign and are both non-zero. */ usign = usize >= 0 ? 1 : -1; usize = ABS (usize); abs_vval = ABS_CAST (unsigned long, vval); /* 2. Are the exponents different (V's exponent == 1)? */ #if GMP_NAIL_BITS != 0 if (uexp > 1 + (abs_vval > GMP_NUMB_MAX)) return usign; if (uexp < 1 + (abs_vval > GMP_NUMB_MAX)) return -usign; #else if (uexp > 1) return usign; if (uexp < 1) return -usign; #endif up = u->_mp_d; ulimb = up[usize - 1]; #if GMP_NAIL_BITS != 0 if (usize >= 2 && uexp == 2) { if ((ulimb >> GMP_NAIL_BITS) != 0) return usign; ulimb = (ulimb << GMP_NUMB_BITS) | up[usize - 2]; usize--; } #endif usize--; /* 3. Compare the most significant mantissa limb with V. */ if (ulimb > abs_vval) return usign; else if (ulimb < abs_vval) return -usign; /* Ignore zeroes at the low end of U. */ while (*up == 0) { up++; usize--; } /* 4. Now, if the number of limbs are different, we have a difference since we have made sure the trailing limbs are not zero. */ if (usize > 0) return usign; /* Wow, we got zero even if we tried hard to avoid it. */ return 0; } gcl-2.6.14/gmp4/mpf/add_ui.c0000644000175000017500000000722614360276512014024 0ustar cammcamm/* mpf_add_ui -- Add a float and an unsigned integer. Copyright 1993, 1994, 1996, 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_add_ui (mpf_ptr sum, mpf_srcptr u, unsigned long int v) { mp_srcptr up = u->_mp_d; mp_ptr sump = sum->_mp_d; mp_size_t usize, sumsize; mp_size_t prec = sum->_mp_prec; mp_exp_t uexp = u->_mp_exp; usize = u->_mp_size; if (usize <= 0) { if (usize == 0) { mpf_set_ui (sum, v); return; } else { __mpf_struct u_negated; u_negated._mp_size = -usize; u_negated._mp_exp = u->_mp_exp; u_negated._mp_d = u->_mp_d; mpf_sub_ui (sum, &u_negated, v); sum->_mp_size = -(sum->_mp_size); return; } } if (v == 0) { sum_is_u: if (u != sum) { sumsize = MIN (usize, prec + 1); MPN_COPY (sum->_mp_d, up + usize - sumsize, sumsize); sum->_mp_size = sumsize; sum->_mp_exp = u->_mp_exp; } return; } if (uexp > 0) { /* U >= 1. */ if (uexp > prec) { /* U >> V, V is not part of final result. */ goto sum_is_u; } else { /* U's "limb point" is somewhere between the first limb and the PREC:th limb. Both U and V are part of the final result. */ if (uexp > usize) { /* uuuuuu0000. */ /* + v. */ /* We begin with moving U to the top of SUM, to handle samevar(U,SUM). */ MPN_COPY_DECR (sump + uexp - usize, up, usize); sump[0] = v; MPN_ZERO (sump + 1, uexp - usize - 1); #if 0 /* What is this??? */ if (sum == u) MPN_COPY (sum->_mp_d, sump, uexp); #endif sum->_mp_size = uexp; sum->_mp_exp = uexp; } else { /* uuuuuu.uuuu */ /* + v. */ mp_limb_t cy_limb; if (usize > prec) { /* Ignore excess limbs in U. */ up += usize - prec; usize -= usize - prec; /* Eq. usize = prec */ } if (sump != up) MPN_COPY_INCR (sump, up, usize - uexp); cy_limb = mpn_add_1 (sump + usize - uexp, up + usize - uexp, uexp, (mp_limb_t) v); sump[usize] = cy_limb; sum->_mp_size = usize + cy_limb; sum->_mp_exp = uexp + cy_limb; } } } else { /* U < 1, so V > U for sure. */ /* v. */ /* .0000uuuu */ if ((-uexp) >= prec) { sump[0] = v; sum->_mp_size = 1; sum->_mp_exp = 1; } else { if (usize + (-uexp) + 1 > prec) { /* Ignore excess limbs in U. */ up += usize + (-uexp) + 1 - prec; usize -= usize + (-uexp) + 1 - prec; } if (sump != up) MPN_COPY_INCR (sump, up, usize); MPN_ZERO (sump + usize, -uexp); sump[usize + (-uexp)] = v; sum->_mp_size = usize + (-uexp) + 1; sum->_mp_exp = 1; } } } gcl-2.6.14/gmp4/mpf/fits_sshort.c0000644000175000017500000000221414360276512015136 0ustar cammcamm/* mpf_fits_sshort_p -- test whether an mpf fits a short. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #define FUNCTION mpf_fits_sshort_p #define MAXIMUM SHRT_MAX #define MINIMUM SHRT_MIN #include "fits_s.h" gcl-2.6.14/gmp4/mpf/urandomb.c0000644000175000017500000000363014360276512014401 0ustar cammcamm/* mpf_urandomb (rop, state, nbits) -- Generate a uniform pseudorandom real number between 0 (inclusive) and 1 (exclusive) of size NBITS, using STATE as the random state previously initialized by a call to gmp_randinit(). Copyright 1999-2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_urandomb (mpf_t rop, gmp_randstate_t rstate, mp_bitcnt_t nbits) { mp_ptr rp; mp_size_t nlimbs; mp_exp_t exp; mp_size_t prec; rp = PTR (rop); nlimbs = BITS_TO_LIMBS (nbits); prec = PREC (rop); if (nlimbs > prec + 1 || nlimbs == 0) { nlimbs = prec + 1; nbits = nlimbs * GMP_NUMB_BITS; } _gmp_rand (rp, rstate, nbits); /* If nbits isn't a multiple of GMP_NUMB_BITS, shift up. */ if (nbits % GMP_NUMB_BITS != 0) mpn_lshift (rp, rp, nlimbs, GMP_NUMB_BITS - nbits % GMP_NUMB_BITS); exp = 0; while (nlimbs != 0 && rp[nlimbs - 1] == 0) { nlimbs--; exp--; } EXP (rop) = exp; SIZ (rop) = nlimbs; } gcl-2.6.14/gmp4/mpf/set_z.c0000644000175000017500000000266414360276512013724 0ustar cammcamm/* mpf_set_z -- Assign a float from an integer. Copyright 1996, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_set_z (mpf_ptr r, mpz_srcptr u) { mp_ptr rp, up; mp_size_t size, asize; mp_size_t prec; prec = PREC (r) + 1; size = SIZ (u); asize = ABS (size); rp = PTR (r); up = PTR (u); EXP (r) = asize; if (asize > prec) { up += asize - prec; asize = prec; } SIZ (r) = size >= 0 ? asize : -asize; MPN_COPY (rp, up, asize); } gcl-2.6.14/gmp4/mpf/set_dfl_prec.c0000644000175000017500000000240314360276512015220 0ustar cammcamm/* mpf_set_default_prec -- Copyright 1993-1995, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" mp_size_t __gmp_default_fp_limb_precision = __GMPF_BITS_TO_PREC (53); void mpf_set_default_prec (mp_bitcnt_t prec_in_bits) __GMP_NOTHROW { __gmp_default_fp_limb_precision = __GMPF_BITS_TO_PREC (prec_in_bits); } gcl-2.6.14/gmp4/mpf/get_si.c0000644000175000017500000000462614360276512014052 0ustar cammcamm/* mpf_get_si -- mpf to long conversion Copyright 2001, 2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Any fraction bits are truncated, meaning simply discarded. For values bigger than a long, the low bits are returned, like mpz_get_si, but this isn't documented. Notice this is equivalent to mpz_set_f + mpz_get_si. Implementation: fl is established in basically the same way as for mpf_get_ui, see that code for explanations of the conditions. However unlike mpf_get_ui we need an explicit return 0 for exp<=0. When f is a negative fraction (ie. size<0 and exp<=0) we can't let fl==0 go through to the zany final "~ ((fl - 1) & LONG_MAX)", that would give -0x80000000 instead of the desired 0. */ long mpf_get_si (mpf_srcptr f) __GMP_NOTHROW { mp_exp_t exp; mp_size_t size, abs_size; mp_srcptr fp; mp_limb_t fl; exp = EXP (f); size = SIZ (f); fp = PTR (f); /* fraction alone truncates to zero this also covers zero, since we have exp==0 for zero */ if (exp <= 0) return 0L; /* there are some limbs above the radix point */ fl = 0; abs_size = ABS (size); if (abs_size >= exp) fl = fp[abs_size-exp]; #if BITS_PER_ULONG > GMP_NUMB_BITS if (exp > 1 && abs_size+1 >= exp) fl |= fp[abs_size - exp + 1] << GMP_NUMB_BITS; #endif if (size > 0) return fl & LONG_MAX; else /* this form necessary to correctly handle -0x80..00 */ return -1 - (long) ((fl - 1) & LONG_MAX); } gcl-2.6.14/gmp4/mpf/mul.c0000644000175000017500000000435414360276512013373 0ustar cammcamm/* mpf_mul -- Multiply two floats. Copyright 1993, 1994, 1996, 2001, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_mul (mpf_ptr r, mpf_srcptr u, mpf_srcptr v) { mp_srcptr up, vp; mp_size_t usize, vsize; mp_size_t sign_product; mp_size_t prec = r->_mp_prec; TMP_DECL; TMP_MARK; usize = u->_mp_size; vsize = v->_mp_size; sign_product = usize ^ vsize; usize = ABS (usize); vsize = ABS (vsize); up = u->_mp_d; vp = v->_mp_d; if (usize > prec) { up += usize - prec; usize = prec; } if (vsize > prec) { vp += vsize - prec; vsize = prec; } if (usize == 0 || vsize == 0) { r->_mp_size = 0; r->_mp_exp = 0; /* ??? */ } else { mp_size_t rsize; mp_limb_t cy_limb; mp_ptr rp, tp; mp_size_t adj; rsize = usize + vsize; tp = TMP_ALLOC_LIMBS (rsize); cy_limb = (usize >= vsize ? mpn_mul (tp, up, usize, vp, vsize) : mpn_mul (tp, vp, vsize, up, usize)); adj = cy_limb == 0; rsize -= adj; prec++; if (rsize > prec) { tp += rsize - prec; rsize = prec; } rp = r->_mp_d; MPN_COPY (rp, tp, rsize); r->_mp_exp = u->_mp_exp + v->_mp_exp - adj; r->_mp_size = sign_product >= 0 ? rsize : -rsize; } TMP_FREE; } gcl-2.6.14/gmp4/mpf/mul_2exp.c0000644000175000017500000001052414360276512014325 0ustar cammcamm/* mpf_mul_2exp -- Multiply a float by 2^n. Copyright 1993, 1994, 1996, 2000-2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Multiples of GMP_NUMB_BITS in exp simply mean an amount added to EXP(u) to set EXP(r). The remainder exp%GMP_NUMB_BITS is then a left shift for the limb data. If exp%GMP_NUMB_BITS == 0 then there's no shifting, we effectively just do an mpz_set with changed EXP(r). Like mpz_set we take prec+1 limbs in this case. Although just prec would suffice, it's nice to have mpf_mul_2exp with exp==0 come out the same as mpz_set. When shifting we take up to prec many limbs from the input. Our shift is cy = mpn_lshift (PTR(r), PTR(u)+k, size, ...), where k is the number of low limbs dropped from u, and the carry out is stored to PTR(r)[size]. It may be noted that the low limb PTR(r)[0] doesn't incorporate bits from PTR(u)[k-1] (when k>=1 makes that limb available). Taking just prec limbs from the input (with the high non-zero) is enough bits for the application requested precision, there's no need for extra work. If r==u the shift will have overlapping operands. When k==0 (ie. when usize <= prec), the overlap is supported by lshift (ie. dst == src). But when r==u and k>=1 (ie. usize > prec), we would have an invalid overlap (ie. mpn_lshift (rp, rp+k, ...)). In this case we must instead use mpn_rshift (PTR(r)+1, PTR(u)+k, size, NUMB-shift) with the carry out stored to PTR(r)[0]. An rshift by NUMB-shift bits like this gives identical data, it's just its overlap restrictions which differ. Enhancements: The way mpn_lshift is used means successive mpf_mul_2exp calls on the same operand will accumulate low zero limbs, until prec+1 limbs is reached. This is wasteful for subsequent operations. When abs_usize <= prec, we should test the low exp%GMP_NUMB_BITS many bits of PTR(u)[0], ie. those which would be shifted out by an mpn_rshift. If they're zero then use that mpn_rshift. */ void mpf_mul_2exp (mpf_ptr r, mpf_srcptr u, mp_bitcnt_t exp) { mp_srcptr up; mp_ptr rp = r->_mp_d; mp_size_t usize; mp_size_t abs_usize; mp_size_t prec = r->_mp_prec; mp_exp_t uexp = u->_mp_exp; usize = u->_mp_size; if (UNLIKELY (usize == 0)) { r->_mp_size = 0; r->_mp_exp = 0; return; } abs_usize = ABS (usize); up = u->_mp_d; if (exp % GMP_NUMB_BITS == 0) { prec++; /* retain more precision here as we don't need to account for carry-out here */ if (abs_usize > prec) { up += abs_usize - prec; abs_usize = prec; } if (rp != up) MPN_COPY_INCR (rp, up, abs_usize); r->_mp_exp = uexp + exp / GMP_NUMB_BITS; } else { mp_limb_t cy_limb; mp_size_t adj; if (abs_usize > prec) { up += abs_usize - prec; abs_usize = prec; /* Use mpn_rshift since mpn_lshift operates downwards, and we therefore would clobber part of U before using that part, in case R is the same variable as U. */ cy_limb = mpn_rshift (rp + 1, up, abs_usize, GMP_NUMB_BITS - exp % GMP_NUMB_BITS); rp[0] = cy_limb; adj = rp[abs_usize] != 0; } else { cy_limb = mpn_lshift (rp, up, abs_usize, exp % GMP_NUMB_BITS); rp[abs_usize] = cy_limb; adj = cy_limb != 0; } abs_usize += adj; r->_mp_exp = uexp + exp / GMP_NUMB_BITS + adj; } r->_mp_size = usize >= 0 ? abs_usize : -abs_usize; } gcl-2.6.14/gmp4/mpf/set.c0000644000175000017500000000300014360276512013354 0ustar cammcamm/* mpf_set -- Assign a float from another float. Copyright 1993-1995, 2001, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_set (mpf_ptr r, mpf_srcptr u) { mp_ptr rp, up; mp_size_t size, asize; mp_size_t prec; prec = r->_mp_prec + 1; /* lie not to lose precision in assignment */ size = u->_mp_size; asize = ABS (size); rp = r->_mp_d; up = u->_mp_d; if (asize > prec) { up += asize - prec; asize = prec; } r->_mp_exp = u->_mp_exp; r->_mp_size = size >= 0 ? asize : -asize; MPN_COPY_INCR (rp, up, asize); } gcl-2.6.14/gmp4/mpf/set_q.c0000644000175000017500000001102414360276512013701 0ustar cammcamm/* mpf_set_q (mpf_t rop, mpq_t op) -- Convert the rational op to the float rop. Copyright 1996, 1999, 2001, 2002, 2004, 2005 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" /* As usual the aim is to produce PREC(r) limbs, with the high non-zero. The basic mpn_tdiv_qr produces a quotient of nsize-dsize+1 limbs, with either the high or second highest limb non-zero. We arrange for nsize-dsize+1 to equal prec+1, hence giving either prec or prec+1 result limbs at PTR(r). nsize-dsize+1 == prec+1 is achieved by adjusting num(q), either dropping low limbs if it's too big, or padding with low zeros if it's too small. The full given den(q) is always used. We cannot truncate den(q), because even when it's much bigger than prec the last limbs can still influence the final quotient. Often they don't, but we leave optimization of that to a prospective quotient-only mpn division. Not done: If den(q) is a power of 2 then we may end up with low zero limbs on the result. But nothing is done about this, since it should be unlikely on random data, and can be left to an application to call mpf_div_2exp if it might occur with any frequency. Enhancements: The high quotient limb is non-zero when high{np,dsize} >= {dp,dsize}. We could make that comparison and use qsize==prec instead of qsize==prec+1, to save one limb in the division. Future: If/when mpn_tdiv_qr supports its qxn parameter we can use that instead of padding n with zeros in temporary space. If/when a quotient-only division exists it can be used here immediately. remp is only to satisfy mpn_tdiv_qr, the remainder is not used. */ void mpf_set_q (mpf_t r, mpq_srcptr q) { mp_srcptr np, dp; mp_size_t prec, nsize, dsize, qsize, prospective_qsize, tsize, zeros; mp_size_t sign_quotient, high_zero; mp_ptr qp, tp, remp; mp_exp_t exp; TMP_DECL; ASSERT (SIZ(&q->_mp_den) > 0); /* canonical q */ nsize = SIZ (&q->_mp_num); dsize = SIZ (&q->_mp_den); if (UNLIKELY (nsize == 0)) { SIZ (r) = 0; EXP (r) = 0; return; } TMP_MARK; prec = PREC (r); qp = PTR (r); sign_quotient = nsize; nsize = ABS (nsize); np = PTR (&q->_mp_num); dp = PTR (&q->_mp_den); prospective_qsize = nsize - dsize + 1; /* q from using given n,d sizes */ exp = prospective_qsize; /* ie. number of integer limbs */ qsize = prec + 1; /* desired q */ zeros = qsize - prospective_qsize; /* n zeros to get desired qsize */ tsize = nsize + zeros; /* possible copy of n */ if (WANT_TMP_DEBUG) { /* separate alloc blocks, for malloc debugging */ remp = TMP_ALLOC_LIMBS (dsize); tp = NULL; if (zeros > 0) tp = TMP_ALLOC_LIMBS (tsize); } else { /* one alloc with a conditionalized size, for efficiency */ mp_size_t size = dsize + (zeros > 0 ? tsize : 0); remp = TMP_ALLOC_LIMBS (size); tp = remp + dsize; } if (zeros > 0) { /* pad n with zeros into temporary space */ MPN_ZERO (tp, zeros); MPN_COPY (tp+zeros, np, nsize); np = tp; nsize = tsize; } else { /* shorten n to get desired qsize */ nsize += zeros; np -= zeros; } ASSERT (nsize-dsize+1 == qsize); mpn_tdiv_qr (qp, remp, (mp_size_t) 0, np, nsize, dp, dsize); /* strip possible zero high limb */ high_zero = (qp[qsize-1] == 0); qsize -= high_zero; exp -= high_zero; EXP (r) = exp; SIZ (r) = sign_quotient >= 0 ? qsize : -qsize; TMP_FREE; } gcl-2.6.14/gmp4/mpf/cmp_d.c0000644000175000017500000000325114360276512013653 0ustar cammcamm/* mpf_cmp_d -- compare mpf and double. Copyright 2001, 2003 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "config.h" #if HAVE_FLOAT_H #include /* for DBL_MAX */ #endif #include "gmp.h" #include "gmp-impl.h" int mpf_cmp_d (mpf_srcptr f, double d) { mp_limb_t darray[LIMBS_PER_DOUBLE]; mpf_t df; /* d=NaN has no sensible return value, so raise an exception. d=Inf or -Inf is always bigger than z. */ DOUBLE_NAN_INF_ACTION (d, __gmp_invalid_operation (), return (d < 0.0 ? 1 : -1)); if (d == 0.0) return SIZ(f); PTR(df) = darray; SIZ(df) = (d >= 0.0 ? LIMBS_PER_DOUBLE : -LIMBS_PER_DOUBLE); EXP(df) = __gmp_extract_double (darray, ABS(d)); return mpf_cmp (f, df); } gcl-2.6.14/gmp4/mpf/eq.c0000644000175000017500000000702414360276512013200 0ustar cammcamm/* mpf_eq -- Compare two floats up to a specified bit #. Copyright 1993, 1995, 1996, 2001, 2002, 2008, 2009, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" int mpf_eq (mpf_srcptr u, mpf_srcptr v, mp_bitcnt_t n_bits) { mp_srcptr up, vp, p; mp_size_t usize, vsize, minsize, maxsize, n_limbs, i, size; mp_exp_t uexp, vexp; mp_limb_t diff; int cnt; uexp = u->_mp_exp; vexp = v->_mp_exp; usize = u->_mp_size; vsize = v->_mp_size; /* 1. Are the signs different? */ if ((usize ^ vsize) >= 0) { /* U and V are both non-negative or both negative. */ if (usize == 0) return vsize == 0; if (vsize == 0) return 0; /* Fall out. */ } else { /* Either U or V is negative, but not both. */ return 0; } /* U and V have the same sign and are both non-zero. */ /* 2. Are the exponents different? */ if (uexp != vexp) return 0; usize = ABS (usize); vsize = ABS (vsize); up = u->_mp_d; vp = v->_mp_d; up += usize; /* point just above most significant limb */ vp += vsize; /* point just above most significant limb */ count_leading_zeros (cnt, up[-1]); if ((vp[-1] >> (GMP_LIMB_BITS - 1 - cnt)) != 1) return 0; /* msb positions different */ n_bits += cnt - GMP_NAIL_BITS; n_limbs = (n_bits + GMP_NUMB_BITS - 1) / GMP_NUMB_BITS; usize = MIN (usize, n_limbs); vsize = MIN (vsize, n_limbs); #if 0 /* Ignore zeros at the low end of U and V. */ while (up[0] == 0) up++, usize--; while (vp[0] == 0) vp++, vsize--; #endif minsize = MIN (usize, vsize); maxsize = usize + vsize - minsize; up -= minsize; /* point at most significant common limb */ vp -= minsize; /* point at most significant common limb */ /* Compare the most significant part which has explicit limbs for U and V. */ for (i = minsize - 1; i > 0; i--) { if (up[i] != vp[i]) return 0; } n_bits -= (maxsize - 1) * GMP_NUMB_BITS; size = maxsize - minsize; if (size != 0) { if (up[0] != vp[0]) return 0; /* Now either U or V has its limbs consumed, i.e, continues with an infinite number of implicit zero limbs. Check that the other operand has just zeros in the corresponding, relevant part. */ if (usize > vsize) p = up - size; else p = vp - size; for (i = size - 1; i > 0; i--) { if (p[i] != 0) return 0; } diff = p[0]; } else { /* Both U or V has its limbs consumed. */ diff = up[0] ^ vp[0]; } if (n_bits < GMP_NUMB_BITS) diff >>= GMP_NUMB_BITS - n_bits; return diff == 0; } gcl-2.6.14/gmp4/mpf/set_prc_raw.c0000644000175000017500000000247314360276512015106 0ustar cammcamm/* mpf_set_prec_raw(x,bits) -- Change the precision of x without changing allocation. For proper operation, the original precision need to be reset sooner or later. Copyright 1996, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_set_prec_raw (mpf_ptr x, mp_bitcnt_t prec_in_bits) __GMP_NOTHROW { x->_mp_prec = __GMPF_BITS_TO_PREC (prec_in_bits); } gcl-2.6.14/gmp4/mpf/get_d_2exp.c0000644000175000017500000000314314360276512014611 0ustar cammcamm/* double mpf_get_d_2exp (signed long int *exp, mpf_t src). Copyright 2001-2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" double mpf_get_d_2exp (signed long int *exp2, mpf_srcptr src) { mp_size_t size, abs_size; mp_srcptr ptr; int cnt; long exp; size = SIZ(src); if (UNLIKELY (size == 0)) { *exp2 = 0; return 0.0; } ptr = PTR(src); abs_size = ABS (size); count_leading_zeros (cnt, ptr[abs_size - 1]); cnt -= GMP_NAIL_BITS; exp = EXP(src) * GMP_NUMB_BITS - cnt; *exp2 = exp; return mpn_get_d (ptr, abs_size, (mp_size_t) 0, (long) - (abs_size * GMP_NUMB_BITS - cnt)); } gcl-2.6.14/gmp4/mpf/fits_u.h0000644000175000017500000000342314360276512014070 0ustar cammcamm/* mpf_fits_u*_p -- test whether an mpf fits a C unsigned type. Copyright 2001, 2002, 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Notice this is equivalent to mpz_set_f + mpz_fits_u*_p. */ int FUNCTION (mpf_srcptr f) __GMP_NOTHROW { mp_size_t fn; mp_srcptr fp; mp_exp_t exp; mp_limb_t fl; exp = EXP(f); if (exp < 1) return 1; /* -1 < f < 1 truncates to zero, so fits */ fn = SIZ(f); if (fn <= 0) return fn == 0; /* zero fits, negatives don't */ fp = PTR(f); if (exp == 1) { fl = fp[fn-1]; } #if GMP_NAIL_BITS != 0 else if (exp == 2 && MAXIMUM > GMP_NUMB_MAX) { fl = fp[fn-1]; if ((fl >> GMP_NAIL_BITS) != 0) return 0; fl = (fl << GMP_NUMB_BITS); if (fn >= 2) fl |= fp[fn-2]; } #endif else return 0; return fl <= MAXIMUM; } gcl-2.6.14/gmp4/mpf/abs.c0000644000175000017500000000276614360276512013350 0ustar cammcamm/* mpf_abs -- Compute the absolute value of a float. Copyright 1993-1995, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_abs (mpf_ptr r, mpf_srcptr u) { mp_size_t size; size = ABS (u->_mp_size); if (r != u) { mp_size_t prec; mp_ptr rp, up; prec = r->_mp_prec + 1; /* lie not to lose precision in assignment */ rp = r->_mp_d; up = u->_mp_d; if (size > prec) { up += size - prec; size = prec; } MPN_COPY (rp, up, size); r->_mp_exp = u->_mp_exp; } r->_mp_size = size; } gcl-2.6.14/gmp4/mpf/get_ui.c0000644000175000017500000000617014360276512014050 0ustar cammcamm/* mpf_get_ui -- mpf to ulong conversion Copyright 2001, 2002, 2004 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Any fraction bits are truncated, meaning simply discarded. For values bigger than a ulong, the low bits are returned (the low absolute value bits actually), like mpz_get_ui, but this isn't documented. Notice this is equivalent to mpz_set_f + mpz_get_ui. Implementation: The limb just above the radix point for us to extract is ptr[size-exp]. We need to check that the size-exp index falls in our available data range, 0 to size-1 inclusive. We test this without risk of an overflow involving exp by requiring size>=exp (giving size-exp >= 0) and exp>0 (giving size-exp <= size-1). Notice if size==0 there's no fetch, since of course size>=exp and exp>0 can only be true if size>0. So there's no special handling for size==0, it comes out as 0 the same as any other time we have no data at our target index. For nails, the second limb above the radix point is also required, this is ptr[size-exp+1]. Again we need to check that size-exp+1 falls in our data range, 0 to size-1 inclusive. We test without risk of overflow by requiring size+1>=exp (giving size-exp+1 >= 0) and exp>1 (giving size-exp+1 <= size-1). And again if size==0 these second fetch conditions are not satisfied either since size+1>=exp and exp>1 are only true if size>0. The code is arranged with exp>0 wrapping the exp>1 test since exp>1 is mis-compiled by alpha gcc prior to version 3.4. It re-writes it as exp-1>0, which is incorrect when exp==MP_EXP_T_MIN. By having exp>0 tested first we ensure MP_EXP_T_MIN doesn't reach exp>1. */ unsigned long mpf_get_ui (mpf_srcptr f) __GMP_NOTHROW { mp_size_t size; mp_exp_t exp; mp_srcptr fp; mp_limb_t fl; exp = EXP (f); size = SIZ (f); fp = PTR (f); fl = 0; if (exp > 0) { /* there are some limbs above the radix point */ size = ABS (size); if (size >= exp) fl = fp[size-exp]; #if BITS_PER_ULONG > GMP_NUMB_BITS if (exp > 1 && size+1 >= exp) fl += (fp[size-exp+1] << GMP_NUMB_BITS); #endif } return (unsigned long) fl; } gcl-2.6.14/gmp4/mpf/int_p.c0000644000175000017500000000277014360276512013707 0ustar cammcamm/* mpf_integer_p -- test whether an mpf is an integer */ /* Copyright 2001, 2002 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" int mpf_integer_p (mpf_srcptr f) __GMP_NOTHROW { mp_srcptr ptr; mp_exp_t exp; mp_size_t size, frac, i; size = SIZ (f); if (size == 0) return 1; /* zero is an integer */ exp = EXP (f); if (exp <= 0) return 0; /* has only fraction limbs */ /* any fraction limbs must be zero */ frac = ABS (size) - exp; ptr = PTR (f); for (i = 0; i < frac; i++) if (ptr[i] != 0) return 0; return 1; } gcl-2.6.14/gmp4/mpf/neg.c0000644000175000017500000000307014360276512013341 0ustar cammcamm/* mpf_neg -- Negate a float. Copyright 1993-1995, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_neg (mpf_ptr r, mpf_srcptr u) { mp_size_t size; size = -u->_mp_size; if (r != u) { mp_size_t prec; mp_size_t asize; mp_ptr rp, up; prec = r->_mp_prec + 1; /* lie not to lose precision in assignment */ asize = ABS (size); rp = r->_mp_d; up = u->_mp_d; if (asize > prec) { up += asize - prec; asize = prec; } MPN_COPY (rp, up, asize); r->_mp_exp = u->_mp_exp; size = size >= 0 ? asize : -asize; } r->_mp_size = size; } gcl-2.6.14/gmp4/mpf/trunc.c0000644000175000017500000000350614360276512013727 0ustar cammcamm/* mpf_trunc -- truncate an mpf to an integer. Copyright 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Notice the use of prec+1 ensures mpf_trunc is equivalent to mpf_set if u is already an integer. */ void mpf_trunc (mpf_ptr r, mpf_srcptr u) { mp_ptr rp; mp_srcptr up; mp_size_t size, asize, prec; mp_exp_t exp; exp = EXP(u); size = SIZ(u); if (size == 0 || exp <= 0) { /* u is only a fraction */ SIZ(r) = 0; EXP(r) = 0; return; } up = PTR(u); EXP(r) = exp; asize = ABS (size); up += asize; /* skip fraction part of u */ asize = MIN (asize, exp); /* don't lose precision in the copy */ prec = PREC(r) + 1; /* skip excess over target precision */ asize = MIN (asize, prec); up -= asize; rp = PTR(r); SIZ(r) = (size >= 0 ? asize : -asize); if (rp != up) MPN_COPY_INCR (rp, up, asize); } gcl-2.6.14/gmp4/mpf/ui_div.c0000644000175000017500000000644714360276512014062 0ustar cammcamm/* mpf_ui_div -- Divide an unsigned integer with a float. Copyright 1993-1996, 2000-2002, 2004, 2005, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include /* for NULL */ #include "gmp.h" #include "gmp-impl.h" #include "longlong.h" void mpf_ui_div (mpf_ptr r, unsigned long int u, mpf_srcptr v) { mp_srcptr vp; mp_ptr rp, tp, remp, new_vp; mp_size_t vsize; mp_size_t rsize, prospective_rsize, zeros, tsize, high_zero; mp_size_t sign_quotient; mp_size_t prec; mp_exp_t rexp; TMP_DECL; vsize = v->_mp_size; sign_quotient = vsize; if (UNLIKELY (vsize == 0)) DIVIDE_BY_ZERO; if (UNLIKELY (u == 0)) { r->_mp_size = 0; r->_mp_exp = 0; return; } vsize = ABS (vsize); prec = r->_mp_prec; TMP_MARK; rexp = 1 - v->_mp_exp + 1; rp = r->_mp_d; vp = v->_mp_d; prospective_rsize = 1 - vsize + 1; /* quot from using given u,v sizes */ rsize = prec + 1; /* desired quot size */ zeros = rsize - prospective_rsize; /* padding u to give rsize */ tsize = 1 + zeros; /* u with zeros */ if (WANT_TMP_DEBUG) { /* separate alloc blocks, for malloc debugging */ remp = TMP_ALLOC_LIMBS (vsize); tp = TMP_ALLOC_LIMBS (tsize); new_vp = NULL; if (rp == vp) new_vp = TMP_ALLOC_LIMBS (vsize); } else { /* one alloc with calculated size, for efficiency */ mp_size_t size = vsize + tsize + (rp == vp ? vsize : 0); remp = TMP_ALLOC_LIMBS (size); tp = remp + vsize; new_vp = tp + tsize; } /* ensure divisor doesn't overlap quotient */ if (rp == vp) { MPN_COPY (new_vp, vp, vsize); vp = new_vp; } MPN_ZERO (tp, tsize-1); tp[tsize - 1] = u & GMP_NUMB_MASK; #if BITS_PER_ULONG > GMP_NUMB_BITS if (u > GMP_NUMB_MAX) { /* tsize-vsize+1 == rsize, so tsize >= rsize. rsize == prec+1 >= 2, so tsize >= 2, hence there's room for 2-limb u with nails */ ASSERT (tsize >= 2); tp[tsize - 1] = u >> GMP_NUMB_BITS; tp[tsize - 2] = u & GMP_NUMB_MASK; rexp++; } #endif ASSERT (tsize-vsize+1 == rsize); mpn_tdiv_qr (rp, remp, (mp_size_t) 0, tp, tsize, vp, vsize); /* strip possible zero high limb */ high_zero = (rp[rsize-1] == 0); rsize -= high_zero; rexp -= high_zero; r->_mp_size = sign_quotient >= 0 ? rsize : -rsize; r->_mp_exp = rexp; TMP_FREE; } gcl-2.6.14/gmp4/mpf/sub_ui.c0000644000175000017500000000253114360276512014057 0ustar cammcamm/* mpf_sub_ui -- Subtract an unsigned integer from a float. Copyright 1993, 1994, 1996, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" void mpf_sub_ui (mpf_ptr sum, mpf_srcptr u, unsigned long int v) { __mpf_struct vv; mp_limb_t vl; if (v == 0) { mpf_set (sum, u); return; } vl = v; vv._mp_size = 1; vv._mp_d = &vl; vv._mp_exp = 1; mpf_sub (sum, u, &vv); } gcl-2.6.14/gmp4/mpf/ceilfloor.c0000644000175000017500000000575114360276512014556 0ustar cammcamm/* mpf_ceil, mpf_floor -- round an mpf to an integer. Copyright 2001, 2004, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* dir==1 for ceil, dir==-1 for floor Notice the use of prec+1 ensures mpf_ceil and mpf_floor are equivalent to mpf_set if u is already an integer. */ static void __gmpf_ceil_or_floor (REGPARM_2_1 (mpf_ptr, mpf_srcptr, int)) REGPARM_ATTR (1); #define mpf_ceil_or_floor(r,u,dir) __gmpf_ceil_or_floor (REGPARM_2_1 (r, u, dir)) REGPARM_ATTR (1) static void mpf_ceil_or_floor (mpf_ptr r, mpf_srcptr u, int dir) { mp_ptr rp, up, p; mp_size_t size, asize, prec; mp_exp_t exp; size = SIZ(u); if (size == 0) { zero: SIZ(r) = 0; EXP(r) = 0; return; } rp = PTR(r); exp = EXP(u); if (exp <= 0) { /* u is only a fraction */ if ((size ^ dir) < 0) goto zero; rp[0] = 1; EXP(r) = 1; SIZ(r) = dir; return; } EXP(r) = exp; up = PTR(u); asize = ABS (size); up += asize; /* skip fraction part of u */ asize = MIN (asize, exp); /* don't lose precision in the copy */ prec = PREC (r) + 1; /* skip excess over target precision */ asize = MIN (asize, prec); up -= asize; if ((size ^ dir) >= 0) { /* rounding direction matches sign, must increment if ignored part is non-zero */ for (p = PTR(u); p != up; p++) { if (*p != 0) { if (mpn_add_1 (rp, up, asize, CNST_LIMB(1))) { /* was all 0xFF..FFs, which have become zeros, giving just a carry */ rp[0] = 1; asize = 1; EXP(r)++; } SIZ(r) = (size >= 0 ? asize : -asize); return; } } } SIZ(r) = (size >= 0 ? asize : -asize); if (rp != up) MPN_COPY_INCR (rp, up, asize); } void mpf_ceil (mpf_ptr r, mpf_srcptr u) { mpf_ceil_or_floor (r, u, 1); } void mpf_floor (mpf_ptr r, mpf_srcptr u) { mpf_ceil_or_floor (r, u, -1); } gcl-2.6.14/gmp4/mpf/Makefile.in0000644000175000017500000004621614360276512014502 0ustar cammcamm# Makefile.in generated by automake 1.14.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994-2013 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ # Copyright 1996, 1998-2002 Free Software Foundation, Inc. # # This file is part of the GNU MP Library. # # The GNU MP Library is free software; you can redistribute it and/or modify # it under the terms of either: # # * the GNU Lesser General Public License as published by the Free # Software Foundation; either version 3 of the License, or (at your # option) any later version. # # or # # * the GNU General Public License as published by the Free Software # Foundation; either version 2 of the License, or (at your option) any # later version. # # or both in parallel, as here. # # The GNU MP Library is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License # for more details. # # You should have received copies of the GNU General Public License and the # GNU Lesser General Public License along with the GNU MP Library. If not, # see https://www.gnu.org/licenses/. VPATH = @srcdir@ am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' am__make_running_with_option = \ case $${target_option-} in \ ?) ;; \ *) echo "am__make_running_with_option: internal error: invalid" \ "target option '$${target_option-}' specified" >&2; \ exit 1;; \ esac; \ has_opt=no; \ sane_makeflags=$$MAKEFLAGS; \ if $(am__is_gnu_make); then \ sane_makeflags=$$MFLAGS; \ else \ case $$MAKEFLAGS in \ *\\[\ \ ]*) \ bs=\\; \ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ esac; \ fi; \ skip_next=no; \ strip_trailopt () \ { \ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ }; \ for flg in $$sane_makeflags; do \ test $$skip_next = yes && { skip_next=no; continue; }; \ case $$flg in \ *=*|--*) continue;; \ -*I) strip_trailopt 'I'; skip_next=yes;; \ -*I?*) strip_trailopt 'I';; \ -*O) strip_trailopt 'O'; skip_next=yes;; \ -*O?*) strip_trailopt 'O';; \ -*l) strip_trailopt 'l'; skip_next=yes;; \ -*l?*) strip_trailopt 'l';; \ -[dEDm]) skip_next=yes;; \ -[JT]) skip_next=yes;; \ esac; \ case $$flg in \ *$$target_option*) has_opt=yes; break;; \ esac; \ done; \ test $$has_opt = yes am__make_dryrun = (target_option=n; $(am__make_running_with_option)) am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ subdir = mpf DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/Makefile.am ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LTLIBRARIES = $(noinst_LTLIBRARIES) libmpf_la_LIBADD = am_libmpf_la_OBJECTS = init.lo init2.lo inits.lo set.lo set_ui.lo \ set_si.lo set_str.lo set_d.lo set_z.lo set_q.lo iset.lo \ iset_ui.lo iset_si.lo iset_str.lo iset_d.lo clear.lo clears.lo \ get_str.lo dump.lo size.lo eq.lo reldiff.lo sqrt.lo random2.lo \ inp_str.lo out_str.lo add.lo add_ui.lo sub.lo sub_ui.lo \ ui_sub.lo mul.lo mul_ui.lo div.lo div_ui.lo cmp.lo cmp_d.lo \ cmp_si.lo cmp_ui.lo mul_2exp.lo div_2exp.lo abs.lo neg.lo \ get_d.lo get_d_2exp.lo set_dfl_prec.lo set_prc.lo \ set_prc_raw.lo get_dfl_prec.lo get_prc.lo ui_div.lo sqrt_ui.lo \ pow_ui.lo urandomb.lo swap.lo get_si.lo get_ui.lo int_p.lo \ ceilfloor.lo trunc.lo fits_sint.lo fits_slong.lo \ fits_sshort.lo fits_uint.lo fits_ulong.lo fits_ushort.lo libmpf_la_OBJECTS = $(am_libmpf_la_OBJECTS) AM_V_lt = $(am__v_lt_@AM_V@) am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) am__v_lt_0 = --silent am__v_lt_1 = AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) am__v_P_0 = false am__v_P_1 = : AM_V_GEN = $(am__v_GEN_@AM_V@) am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) am__v_GEN_0 = @echo " GEN " $@; am__v_GEN_1 = AM_V_at = $(am__v_at_@AM_V@) am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) am__v_at_0 = @ am__v_at_1 = DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = am__depfiles_maybe = COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_CFLAGS) $(CFLAGS) AM_V_CC = $(am__v_CC_@AM_V@) am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) am__v_CC_0 = @echo " CC " $@; am__v_CC_1 = CCLD = $(CC) LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ AM_V_CCLD = $(am__v_CCLD_@AM_V@) am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) am__v_CCLD_0 = @echo " CCLD " $@; am__v_CCLD_1 = SOURCES = $(libmpf_la_SOURCES) DIST_SOURCES = $(libmpf_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ *) (install-info --version) >/dev/null 2>&1;; \ esac am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP) # Read a list of newline-separated strings from the standard input, # and print each of them once, without duplicates. Input order is # *not* preserved. am__uniquify_input = $(AWK) '\ BEGIN { nonempty = 0; } \ { items[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in items) print i; }; } \ ' # Make sure the list of sources is unique. This is necessary because, # e.g., the same source file might be shared among _SOURCES variables # for different programs/libraries. am__define_uniq_tagged_files = \ list='$(am__tagged_files)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | $(am__uniquify_input)` ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ABI = @ABI@ ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ AR = @AR@ AS = @AS@ ASMFLAGS = @ASMFLAGS@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ CC = @CC@ CCAS = @CCAS@ CC_FOR_BUILD = @CC_FOR_BUILD@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CPP_FOR_BUILD = @CPP_FOR_BUILD@ CXX = @CXX@ CXXCPP = @CXXCPP@ CXXFLAGS = @CXXFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ DEFS = @DEFS@ DLLTOOL = @DLLTOOL@ DSYMUTIL = @DSYMUTIL@ DUMPBIN = @DUMPBIN@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ FGREP = @FGREP@ GMP_LDFLAGS = @GMP_LDFLAGS@ GMP_LIMB_BITS = @GMP_LIMB_BITS@ GMP_NAIL_BITS = @GMP_NAIL_BITS@ GREP = @GREP@ HAVE_CLOCK_01 = @HAVE_CLOCK_01@ HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ HAVE_STACK_T_01 = @HAVE_STACK_T_01@ HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LD = @LD@ LDFLAGS = @LDFLAGS@ LEX = @LEX@ LEXLIB = @LEXLIB@ LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ LIBCURSES = @LIBCURSES@ LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ LIBGMP_DLL = @LIBGMP_DLL@ LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ LIBM = @LIBM@ LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ LIBOBJS = @LIBOBJS@ LIBREADLINE = @LIBREADLINE@ LIBS = @LIBS@ LIBTOOL = @LIBTOOL@ LIPO = @LIPO@ LN_S = @LN_S@ LTLIBOBJS = @LTLIBOBJS@ M4 = @M4@ MAINT = @MAINT@ MAKEINFO = @MAKEINFO@ MANIFEST_TOOL = @MANIFEST_TOOL@ MKDIR_P = @MKDIR_P@ NM = @NM@ NMEDIT = @NMEDIT@ OBJDUMP = @OBJDUMP@ OBJEXT = @OBJEXT@ OTOOL = @OTOOL@ OTOOL64 = @OTOOL64@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ RANLIB = @RANLIB@ SED = @SED@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ STRIP = @STRIP@ TAL_OBJECT = @TAL_OBJECT@ TUNE_LIBS = @TUNE_LIBS@ TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ U_FOR_BUILD = @U_FOR_BUILD@ VERSION = @VERSION@ WITH_READLINE_01 = @WITH_READLINE_01@ YACC = @YACC@ YFLAGS = @YFLAGS@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_AR = @ac_ct_AR@ ac_ct_CC = @ac_ct_CC@ ac_ct_CXX = @ac_ct_CXX@ ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ gmp_srclinks = @gmp_srclinks@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ mpn_objects = @mpn_objects@ mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ INCLUDES = -D__GMP_WITHIN_GMP -I$(top_srcdir) noinst_LTLIBRARIES = libmpf.la libmpf_la_SOURCES = \ init.c init2.c inits.c set.c set_ui.c set_si.c set_str.c set_d.c set_z.c \ set_q.c iset.c iset_ui.c iset_si.c iset_str.c iset_d.c clear.c clears.c \ get_str.c dump.c size.c eq.c reldiff.c sqrt.c random2.c inp_str.c out_str.c \ add.c add_ui.c sub.c sub_ui.c ui_sub.c mul.c mul_ui.c div.c div_ui.c \ cmp.c cmp_d.c cmp_si.c cmp_ui.c mul_2exp.c div_2exp.c abs.c neg.c get_d.c \ get_d_2exp.c set_dfl_prec.c set_prc.c set_prc_raw.c get_dfl_prec.c get_prc.c \ ui_div.c sqrt_ui.c \ pow_ui.c urandomb.c swap.c get_si.c get_ui.c int_p.c \ ceilfloor.c trunc.c \ fits_sint.c fits_slong.c fits_sshort.c \ fits_uint.c fits_ulong.c fits_ushort.c \ fits_s.h fits_u.h all: all-am .SUFFIXES: .SUFFIXES: .c .lo .o .obj $(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps mpf/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu --ignore-deps mpf/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): clean-noinstLTLIBRARIES: -test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES) @list='$(noinst_LTLIBRARIES)'; \ locs=`for p in $$list; do echo $$p; done | \ sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ sort -u`; \ test -z "$$locs" || { \ echo rm -f $${locs}; \ rm -f $${locs}; \ } libmpf.la: $(libmpf_la_OBJECTS) $(libmpf_la_DEPENDENCIES) $(EXTRA_libmpf_la_DEPENDENCIES) $(AM_V_CCLD)$(LINK) $(libmpf_la_OBJECTS) $(libmpf_la_LIBADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .c.o: $(AM_V_CC)$(COMPILE) -c -o $@ $< .c.obj: $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` .c.lo: $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< mostlyclean-libtool: -rm -f *.lo clean-libtool: -rm -rf .libs _libs ID: $(am__tagged_files) $(am__define_uniq_tagged_files); mkid -fID $$unique tags: tags-am TAGS: tags tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) set x; \ here=`pwd`; \ $(am__define_uniq_tagged_files); \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: ctags-am CTAGS: ctags ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) $(am__define_uniq_tagged_files); \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" cscopelist: cscopelist-am cscopelist-am: $(am__tagged_files) list='$(am__tagged_files)'; \ case "$(srcdir)" in \ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ *) sdir=$(subdir)/$(srcdir) ;; \ esac; \ for i in $$list; do \ if test -f "$$i"; then \ echo "$(subdir)/$$i"; \ else \ echo "$$sdir/$$i"; \ fi; \ done >> $(top_builddir)/cscope.files distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(LTLIBRARIES) installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: if test -z '$(STRIP)'; then \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ install; \ else \ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ fi mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-libtool clean-noinstLTLIBRARIES \ mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic \ mostlyclean-libtool pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS TAGS all all-am check check-am clean clean-generic \ clean-libtool clean-noinstLTLIBRARIES cscopelist-am ctags \ ctags-am distclean distclean-compile distclean-generic \ distclean-libtool distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ tags tags-am uninstall uninstall-am # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: gcl-2.6.14/gmp4/mp_dv_tab.c0000644000175000017500000000577214360276512013754 0ustar cammcamm/* __gmp_digit_value_tab -- support for mp*_set_str THE CONTENTS OF THIS FILE ARE FOR INTERNAL USE AND MAY CHANGE INCOMPATIBLY OR DISAPPEAR IN A FUTURE GNU MP RELEASE. Copyright 2003, 2013 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" /* Table to be indexed by character, to get its numerical value. Assumes ASCII character set. First part of table supports common usages, where 'A' and 'a' have the same value; this supports bases 2..36 At offset 208, values for bases 37..62 start. Here, 'A' has the value 10 (in decimal) and 'a' has the value 36. */ #define X 0xff const unsigned char __gmp_digit_value_tab[] = { X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, X, X, X, X, X, X, X,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24, 25,26,27,28,29,30,31,32,33,34,35,X, X, X, X, X, X,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24, 25,26,27,28,29,30,31,32,33,34,35,X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, X, X, X, X, X, X, X,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24, 25,26,27,28,29,30,31,32,33,34,35,X, X, X, X, X, X,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50, 51,52,53,54,55,56,57,58,59,60,61,X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X, X }; gcl-2.6.14/gmp4/version.c0000644000175000017500000000217014360276512013473 0ustar cammcamm/* gmp_version -- version number compiled into the library. Copyright 1996, 1999-2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "gmp.h" #include "gmp-impl.h" const char * const gmp_version = VERSION; gcl-2.6.14/gmp4/assert.c0000644000175000017500000000330714360276512013312 0ustar cammcamm/* GMP assertion failure handler. THE FUNCTIONS IN THIS FILE ARE FOR INTERNAL USE ONLY. THEY'RE ALMOST CERTAIN TO BE SUBJECT TO INCOMPATIBLE CHANGES OR DISAPPEAR COMPLETELY IN FUTURE GNU MP RELEASES. Copyright 2000, 2001 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include #include #include "gmp.h" #include "gmp-impl.h" void __gmp_assert_header (const char *filename, int linenum) { if (filename != NULL && filename[0] != '\0') { fprintf (stderr, "%s:", filename); if (linenum != -1) fprintf (stderr, "%d: ", linenum); } } void __gmp_assert_fail (const char *filename, int linenum, const char *expr) { __gmp_assert_header (filename, linenum); fprintf (stderr, "GNU MP assertion failed: %s\n", expr); abort(); } gcl-2.6.14/gmp4/gen-jacobitab.c0000644000175000017500000000543514360276512014502 0ustar cammcamm/* gen-jacobi.c Contributed to the GNU project by Niels Möller. Copyright 2010 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* Generate the lookup table needed for fast left-to-right computation of the Jacobi symbol. */ #include #include #include static const struct { unsigned char a; unsigned char b; } decode_table[13] = { /* 0 */ { 0, 1 }, /* 1 */ { 0, 3 }, /* 2 */ { 1, 1 }, /* 3 */ { 1, 3 }, /* 4 */ { 2, 1 }, /* 5 */ { 2, 3 }, /* 6 */ { 3, 1 }, /* 7 */ { 3, 3 }, /* d = 1 */ /* 8 */ { 1, 0 }, /* 9 */ { 1, 2 }, /* 10 */ { 3, 0 }, /* 11 */ { 3, 2 }, /* 12 */ { 3, 3 }, /* d = 0 */ }; #define JACOBI_A(bits) (decode_table[(bits)>>1].a) #define JACOBI_B(bits) (decode_table[(bits)>>1].b) #define JACOBI_E(bits) ((bits) & 1) #define JACOBI_D(bits) (((bits)>>1) == 7) /* Gives 0 for don't care states. */ static unsigned encode (unsigned a, unsigned b, unsigned d) { unsigned i; assert (d < 2); assert (a < 4); assert (b < 4); assert ( (a | b ) & 1); if (a == 3 && b == 3) return d ? 7 : 12; for (i = 0; i < 12; i++) if (decode_table[i].a == a && decode_table[i].b == b) return i; abort (); } int main (int argc, char **argv) { unsigned bits; for (bits = 0; bits < 208; bits++) { unsigned e, a, b, d_old, d, q; if (bits && !(bits & 0xf)) printf("\n"); q = bits & 3; d = (bits >> 2) & 1; e = JACOBI_E (bits >> 3); a = JACOBI_A (bits >> 3); b = JACOBI_B (bits >> 3); d_old = JACOBI_D (bits >> 3); if (d != d_old && a == 3 && b == 3) e ^= 1; if (d == 1) { if (b == 2) e ^= (q & (a >> 1)) ^ (q >> 1); a = (a - q * b) & 3; } else { if (a == 2) e ^= (q & (b >> 1)) ^ (q >> 1); b = (b - q * a) & 3; } printf("%2d,", (encode (a, b, d) << 1) | e); } printf("\n"); return 0; } gcl-2.6.14/gmp4/NEWS0000644000175000017500000010122614360276512012343 0ustar cammcammCopyright 1996, 1999-2014 Free Software Foundation, Inc. Verbatim copying and distribution of this entire article is permitted in any medium, provided this notice is preserved. Changes between GMP version 5.1.* and 5.2.0 BUGS FIXED * The function mpz_invert now considers any number invertible in Z/1Z. * The mpn multiply code now handles operands of more than 2^31 limbs correctly. (Note however that the mpz code is limited to 2^32 bits on 32-bit hosts and 2^37 bits on 64-bit hosts.) * Contains all fixes from release 5.1.3. SPEEDUPS * Plain division of large operands is faster and more monotonous in operand size. * Major speedup for ARM, in particular ARM Cortex-A15, thanks to improved assembly. * Major speedup for SPARC T4/T5 and speedup also for T3, thanks to a lot of new assembly. * Speedup for Intel Sandy Bridge, Ivy Bridge, Haswell, thanks to rewritten and vastly expanded assembly support. Speedup also for the older Core 2 and Nehalem. * Faster mixed arithmetic between mpq_class and double. * With g++, optimise more operations when one argument is a simple constant. FEATURES * Support for new Intel and AMD CPUs. * Support for ARM64 alias Aarch64 alias ARMv8. * New public functions mpn_sec_mul and mpn_sec_sqr, implementing side-channel silent multiplication and squaring. * New public functions mpn_sec_div_qr and mpn_sec_div_r, implementing side-channel silent division. * New public functions mpn_cnd_add_n and mpn_cnd_sub_n. Side-channel silent conditional addition and subtraction. * New public function mpn_sec_powm, implementing side-channel silent modexp. * New public function mpn_sec_invert, implementing side-channel silent modular inversion. * Better support for applications which use the mpz_t type, but nevertheless need to call some of the lower-level mpn functions. See the documentation for mpz_limbs_read and related functions. MISC * This release will not work on NetBSD 5.x, FreeBSD 7.x, 8.x or 9 series before 9.3. The reason is that the m4 command is not correctly implemented. (Workaround: Use an older GMP release, or install GNU m4 from /usr/ports and tell GMP to use it.) * This release will not build properly on FreeBSD/amd64 before version 10 using the 32-bit ABI (once a working m4 is installed). The reason is broken limits.h. (Workaround: Use an older GMP release if using the 32-bit ABI on these FreeBSD releases is important.) * This release will not work reliably on FreeBSD 10.0 for i386 or amd64 using the 32-bit ABI. The reason is bugs in the compiler 'clang'. Depending on CPU-dependent compiler flags, GMP may or may not be miscompiled in a particular build. (Workaround: Compiling gcc from /usr/ports should work, except that gcc circularly depends on GMP; we have not been able to test that workaround due to FreeBSD 10.0 bugs affecting its ability to run under KVM and Xen.) * This release will not compile on FreeBSD before version 10 for i386, targeting any modern AMD processor. The reason is bugs in the old gcc bundled with FreeBSD. (Workaround: install a less obsolete gcc from /usr/ports and tell GMP to use it, or override the -march=amdfam10 GMP configure command line argument.) Changes between GMP version 5.1.2 and 5.1.3 BUGS FIXED * The internal functions mpn_sbpi1_div_qr_sec mpn_sbpi1_div_r_sec could compute garbage with a low probability. They are now rewritten, and the test code has been improved. * A bug in the ia64 implementation of mpn_divrem_2, clobbering some callee-save registers, has been fixed. This is an internal function, with the bug manifesting itself as miscomputation in, e.g., mpn_sqrtrem. * The documentation now correctly says 'const' for input arguments. SPEEDUPS * None. FEATURES * None. MISC * None. Changes between GMP version 5.1.1 and 5.1.2 BUGS FIXED * A bug in mpz_powm_ui triggered by base arguments of at least 15000 decimal digits or mod arguments of at least 7500 decimal digits has been fixed. * An AMD Bulldozer specific bug affecting the 64-bit Windows ABI has been fixed. This bug was in a key function (mpn_mul_1) and made both Bulldozer specific builds and fat builds run on Bulldozer completely non-functional. SPEEDUPS * None. FEATURES * None. MISC * Fixes and generalisations to the test suite. * Minor portability enhancements. Changes between GMP version 5.1.0 and 5.1.1 BUGS FIXED * On Windows 64-bit, an error causing link errors about __gmp_binvert_limb_table has been fixed. * Aarch64 alias ARM64 support now works. * A possible buffer overrun in mpz_ior has been fixed. * A rare sign flip in mpz_remove has been fixed. * A bug causing problems with mpf numbers with absolute value >= 2^31 has been fixed. * Several bugs in mini-gmp have been fixed. * A bug caused by automake, related to the 'distcheck' target, has been fixed by upgrading the automake used for GMP release engineering. SPEEDUPS * None. FEATURES * Preliminary support for the x32 ABI under x86-64. MISC * The mini-gmp testsuite now tests the entire set of functions. * Various improvements of the GMP testsuite. Changes between GMP version 5.0.* and 5.1.0 BUGS FIXED * When reading a C++ number (like mpz_class) in an istream reaches the end of the stream, the eofbit is now set. * The result sign of mpz_rootrem's remainder is now always correct. * The mpz_remove function now handles negative divisors. * Contains all fixes from release 5.0.5. SPEEDUPS * The n-factorial and n-over-k functions have been reimplemented for great speedups for small and large operands. * New subquadratic algorithm for the Kronecker/Jacobi/Legendre symbol. * Major speedup for ARM, in particular ARM Cortex-A9 and A15, thanks to broad assembly support. * Significant speedup for POWER6 and POWER7 thanks to improved assembly. * The performance under M$ Windows' 64-bit ABI has been greatly improved thanks to complete assembly support. * Minor speed improvements of many functions and for many platforms. FEATURES * Many new CPUs recognised. * New functions for multi-factorials, and primorial: mpz_2fac_ui, mpz_mfac_uiui and mpz_primorial_ui. * The mpz_powm_sec function now uses side-channel silent division for converting into Montgomery residues. * The fat binary mechanism is now more robust in its CPU recognition. MISC * Inclusion of assembly code is now controlled by the configure options --enable-assembly and --disable-assembly. The "none" CPU target is gone. * In C++, the conversions mpq_class->mpz_class, mpf_class->mpz_class and mpf_class->mpq_class are now explicit. * Includes "mini-gmp", a small, portable, but less efficient, implementation of a subset of GMP's mpn and mpz interfaces. Used in GMP bootstrap, but it can also be bundled with applications as a fallback when the real GMP library is unavailable. * The ABIs under AIX are no longer called aix32 and aix64, but mode64 and 32. This is more consistent with other powerpc systems. * The coverage of the testsuite has been improved, using the lcov tool. See also https://gmplib.org/devel/lcov/. * It is now possible to compile GMP using a C++ compiler. * K&R C compilers are no longer supported. * The BSD MP compatibility functions have been removed. Changes between GMP version 5.0.4 and 5.0.5 BUGS FIXED * A bug causing AMD 11h processors to be treated like AMD 10h has been fixed. The 11h processors do not correctly handle all 10h (aka K10) instructions, and GMP's use of these instructions results in major miscomputations (not as one would have hoped CPU traps of some 'illegal instruction' sort). * A bug affecting recent Intel Sandy Bridge CPUs resulting in configuration failures has been fixed. SPEEDUPS * None. FEATURES * A couple of tests added to the self-check suite. MISC * None. Changes between GMP version 5.0.3 and 5.0.4 BUGS FIXED * Thresholds in mpn_powm_sec for both fat and non-fat builds are now used safely, plugging a one-word buffer overrun introduced in the 5.0.3 release (for non-fat) and a multi-word buffer overrun that existed since 5.0 (for fat). (We have not been able to provoke malign stack smashing in any of the ~100 configurations explored by the GMP nightly builds, but the bug should be assumed to be exploitable.) * Two bugs in multiplication code causing incorrect computation with extremely low probability have been fixed. * A bug in the test suite causing buffer overruns during "make check", sometimes leading to subsequent malloc crashes, has been fixed. * Two bugs in the gcd code have been fixed. They could lead to incorrect results, but for uniformly distributed random operands, the likelihood for that is infinitesimally small. (There was also a third bug, but that was an incorrect ASSERT, which furthermore was not enabled by default.) * A bug affecting 32-bit PowerPC division has been fixed. The bug caused miscomputation for certain divisors in the range 2^32 ... 2^64-1 (about 1 in 2^30 of these). SPEEDUPS * None, except indirectly through recognition of new CPUs, and through better tuning parameters. FEATURES * Some more tests added to the self-check suite. * The AMD "Bulldozer" CPU is now recognised. MISC * None. Changes between GMP version 5.0.2 and 5.0.3 BUGS FIXED * A few minor bugs related to portability fixed. * A slight timing leak of the powm_sec functions have been sealed. (This leak could possibly be used to extract the most significant few bits of the exponent. "Few" here means at most 10.) * The mpz_nextprime function now runs a safer number of pseudo-random prime tests. * A bug in division code possibly causing incorrect computation was fixed. SPEEDUPS * None, except indirectly through recognition of new CPUs, and through better tuning parameters. FEATURES * New CPUs recognised. * IBM S/390 are now supported in both 31/32-bit and 64-bit mode. (We have not been able to fully test this on any multilib machine, since IBM expired our guest account a few days before our release.) MISC * None. Changes between GMP version 5.0.1 and 5.0.2 BUGS FIXED * Many minor bugs related to portability fixed. * The support for HPPA 2.0N now works, after an assembly bug fix. * A test case type error has been fixed. The symptom of this bug was spurious 'make check' failures. SPEEDUPS * None, except indirectly through recognition of new CPUs. FEATURES * Fat builds are now supported for 64-bit x86 processors also under Darwin. MISC * None. Changes between GMP version 5.0.0 and 5.0.1 BUGS FIXED * Fat builds fixed. * Fixed crash for huge multiplies when old FFT_TABLE2 type of parameter selection tables' sentinel was smaller than multiplied operands. * The solib numbers now reflect the removal of the documented but preliminary mpn_bdivmod function; we correctly flag incompatibility with GMP 4.3. GMP 5.0.0 has this wrong, and should perhaps be uninstalled to avoid confusion. SPEEDUPS * Multiplication of large numbers has indirectly been sped up through better FFT tuning and processor recognition. Since many operations depend on multiplication, there will be a general speedup. FEATURES * More Core i3, i5 an Core i7 processor models are recognised. * Fixes and workarounds for Mac OS quirks should make this GMP version build using many of the different versions of "Xcode". MISC * The amount of scratch memory needed for multiplication of huge numbers has been reduced substantially (but is still larger than in GMP 4.3.) * Likewise, the amount of scratch memory needed for division of large numbers has been reduced substantially. * The FFT tuning code of tune/tuneup.c has been completely rewritten, and new, large FFT parameter selection tables are provided for many machines. * Upgraded to the latest autoconf, automake, libtool. Changes between GMP version 4.3.X and 5.0.0 BUGS FIXED * None (contains the same fixes as release 4.3.2). SPEEDUPS * Multiplication has been overhauled: (1) Multiplication of larger same size operands has been improved with the addition of two new Toom functions and a new internal function mpn_mulmod_bnm1 (computing U * V mod (B^n-1), B being the word base. This latter function is used for the largest products, waiting for a better Schoenhage-Strassen U * V mod (B^n+1) implementation. (2) Likewise for squaring. (3) Multiplication of different size operands has been improved with the addition of many new Toom function, and by selecting underlying functions better from the main multiply functions. * Division and mod have been overhauled: (1) Plain "schoolbook" division is reimplemented using faster quotient approximation. (2) Division Q = N/D, R = N mod D where both the quotient and remainder are needed now runs in time O(M(log(N))). This is an improvement of a factor log(log(N)) (3) Division where just the quotient is needed is now O(M(log(Q))) on average. (4) Modulo operations using Montgomery REDC form now take time O(M(n)). (5) Exact division Q = N/D by means of mpz_divexact has been improved for all sizes, and now runs in time O(M(log(N))). * The function mpz_powm is now faster for all sizes. Its complexity has gone from O(M(n)log(n)m) to O(M(n)m) where n is the size of the modulo argument and m is the size of the exponent. It is also radically faster for even modulus, since it now partially factors such modulus and performs two smaller modexp operations, then uses CRT. * The internal support for multiplication yielding just the lower n limbs has been improved by using Mulders' algorithm. * Computation of inverses, both plain 1/N and 1/N mod B^n have been improved by using well-tuned Newton iterations, and wrap-around multiplication using mpn_mulmod_bnm1. * A new algorithm makes mpz_perfect_power_p asymptotically faster. * The function mpz_remove uses a much faster algorithm, is better tuned, and also benefits from the division improvements. * Intel Atom and VIA Nano specific optimisations. * Plus hundreds of smaller improvements and tweaks! FEATURES * New mpz function: mpz_powm_sec for side-channel quiet modexp computations. * New mpn functions: mpn_sqr, mpn_and_n, mpn_ior_n, mpn_xor_n, mpn_nand_n, mpn_nior_n, mpn_xnor_n, mpn_andn_n, mpn_iorn_n, mpn_com, mpn_neg, mpn_copyi, mpn_copyd, mpn_zero. * The function mpn_tdiv_qr now allows certain argument overlap. * Support for fat binaries for 64-bit x86 processors has been added. * A new type, mp_bitcnt_t for bignum bit counts, has been introduced. * Support for Windows64 through mingw64 has been added. * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly normalised, returning to how GMP 4.2 worked. (Note that also release 4.3.2 has this change.) MISC * The mpn_mul function should no longer be used for squaring, instead use the new mpn_sqr. * The algorithm selection has been improved, the number of thresholds have more than doubled, and the tuning and use of existing thresholds have been improved. * The tune/speed program can measure many of new functions. * The mpn_bdivmod function has been removed. We do not consider this an incompatible change, since the function was marked as preliminary. * The testsuite has been enhanced in various ways. Changes between GMP version 4.3.1 and 4.3.2 Bugs: * Fixed bug in mpf_eq. * Fixed overflow issues in mpz_set_str, mpz_inp_str, mpf_set_str, and mpf_get_str. * Avoid unbounded stack allocation for unbalanced multiplication. * Fixed bug in FFT multiplication. Speedups: * None, except that proper processor recognition helps affected processors. Features: * Recognise more "Core 2" processor variants. * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly normalised, returning to how GMP 4.2 worked. Changes between GMP version 4.3.0 and 4.3.1 Bugs: * Fixed bug in mpn_gcdext, affecting also mpz_gcdext and mpz_invert. The bug could cause a cofactor to have a leading zero limb, which could lead to crashes or miscomputation later on. * Fixed some minor documentation issues. Speedups: * None. Features: * Workarounds for various issues with Mac OS X's build tools. * Recognise more IBM "POWER" processor variants. Changes between GMP version 4.2.X and 4.3.0 Bugs: * Fixed bug in mpz_perfect_power_p with recognition of negative perfect powers that can be written both as an even and odd power. * We might accidentally have added bugs since there is a large amount of new code in this release. Speedups: * Vastly improved assembly code for x86-64 processors from AMD and Intel. * Major improvements also for many other processor families, such as Alpha, PowerPC, and Itanium. * New sub-quadratic mpn_gcd and mpn_gcdext, as well as improved basecase gcd code. * The multiply FFT code has been slightly improved. * Balanced multiplication now uses 4-way Toom in addition to schoolbook, Karatsuba, 3-way Toom, and FFT. * Unbalanced multiplication has been vastly improved. * Improved schoolbook division by means of faster quotient approximation. * Several new algorithms for division and mod by single limbs, giving many-fold speedups. * Improved nth root computations. * The mpz_nextprime function uses sieving and is much faster. * Countless minor tweaks. Features: * Updated support for fat binaries for x86_32 include current processors * Lots of new mpn internal interfaces. Some of them will become public in a future GMP release. * Support for the 32-bit ABI under x86-apple-darwin. * x86 CPU recognition code should now default better for future processors. * The experimental nails feature does not work in this release, but it might be re-enabled in the future. Misc: * The gmp_version variable now always contains three parts. For this release, it is "4.3.0". Changes between GMP version 4.2.3 and 4.2.4 Bugs: * Fix bug with parsing exponent '+' sign in mpf. * Fix an allocation bug in mpf_set_str, also affecting mpf_init_set_str, and mpf_inp_str. Speedups: * None, except that proper processor recognition helps affected processors. Features: * Recognize new AMD processors. Changes between GMP version 4.2.2 and 4.2.3 Bugs: * Fix x86 CPU recognition code to properly identify recent AMD and Intel 64-bit processors. * The >> operator of the C++ wrapper gmpxx.h now does floor rounding, not truncation. * Inline semantics now follow the C99 standard, and works with recent GCC releases. * C++ bitwise logical operations work for more types. * For C++, gmp.h now includes cstdio, improving compiler compatibility. * Bases > 36 now work properly in mpf_set_str. Speedups: * None, except that proper processor recognition helps affected processors. Features: * The allocation functions now detect overflow of the mpz_t type. This means that overflow will now cause an abort, except when the allocation computation itself overflows. (Such overflow can probably only happen in powering functions; we will detect powering overflow in the future.) Changes between GMP version 4.2.1 and 4.2.2 * License is now LGPL version 3. Bugs: * Shared library numbers corrected for libcxx. * Fixed serious bug in gmpxx.h where a=a+b*c would generate garbage. Note that this only affects C++ programs. * Fix crash in mpz_set_d for arguments with large negative exponent. * Fix 32-bit ABI bug with Itanium assembly for popcount and hamdist. * Fix assembly syntax problem for powerpc-ibm-aix with AIX native assembler. * Fix problems with x86 --enable-fat, where the compiler where told to generate code for the build machine, not plain i386 code as it should. * Improved recognition of powerpc systems wrt Altivec/VMX capability. * Misc minor fixes, mainly workarounds for compiler/assembler bugs. Speedups: * "Core 2" and Pentium 4 processors, running in 64-bit mode will get a slight boost as they are now specifically recognized. Features: * New support for x86_64-solaris * New, rudimentary support for x86-apple-darwin and x86_64-apple-darwin. (Please see https://gmplib.org/macos.html for more information.) Changes between GMP version 4.2 and 4.2.1 Bugs: * Shared library numbers corrected. * Broken support for 32-bit AIX fixed. * Misc minor fixes. Speedups: * Exact division (mpz_divexact) now falls back to plain division for large operands. Features: * Support for some new systems. Changes between GMP version 4.1.4 and 4.2 Bugs: * Minor bug fixes and code generalizations. * Expanded and improved test suite. Speedups: * Many minor optimizations, too many to mention here. * Division now always subquadratic. * Computation of n-factorial much faster. * Added basic x86-64 assembly code. * Floating-point output is now subquadratic for all bases. * FFT multiply code now about 25% faster. * Toom3 multiply code faster. Features: * Much improved configure. * Workarounds for many more compiler bugs. * Temporary allocations are now made on the stack only if small. * New systems supported: HPPA-2.0 gcc, IA-64 HP-UX, PowerPC-64 Darwin, Sparc64 GNU/Linux. * New i386 fat binaries, selecting optimised code at runtime (--enable-fat). * New build option: --enable-profiling=instrument. * New memory function: mp_get_memory_functions. * New Mersenne Twister random numbers: gmp_randinit_mt, also now used for gmp_randinit_default. * New random functions: gmp_randinit_set, gmp_urandomb_ui, gmp_urandomm_ui. * New integer functions: mpz_combit, mpz_rootrem. * gmp_printf etc new type "M" for mp_limb_t. * gmp_scanf and friends now accept C99 hex floats. * Numeric input and output can now be in bases up to 62. * Comparisons mpz_cmp_d, mpz_cmpabs_d, mpf_cmp_d recognise infinities. * Conversions mpz_get_d, mpq_get_d, mpf_get_d truncate towards zero, previously their behaviour was unspecified. * Fixes for overflow issues with operands >= 2^31 bits. Caveats: * mpfr is gone, and will from now on be released only separately. Please see www.mpfr.org. Changes between GMP version 4.1.3 and 4.1.4 * Bug fix to FFT multiplication code (crash for huge operands). * Bug fix to mpf_sub (miscomputation). * Support for powerpc64-gnu-linux. * Better support for AMD64 in 32-bit mode. * Upwardly binary compatible with 4.1.3, 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, and 3.x versions. Changes between GMP version 4.1.2 and 4.1.3 * Bug fix for FFT multiplication code (miscomputation). * Bug fix to K6 assembly code for gcd. * Bug fix to IA-64 assembly code for population count. * Portability improvements, most notably functional AMD64 support. * mpz_export allows NULL for countp parameter. * Many minor bug fixes. * mpz_export allows NULL for countp parameter. * Upwardly binary compatible with 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, and 3.x versions. Changes between GMP version 4.1.1 and 4.1.2 * Bug fixes. Changes between GMP version 4.1 and 4.1.1 * Bug fixes. * New systems supported: NetBSD and OpenBSD sparc64. Changes between GMP version 4.0.1 and 4.1 * Bug fixes. * Speed improvements. * Upwardly binary compatible with 4.0, 4.0.1, and 3.x versions. * Asymptotically fast conversion to/from strings (mpz, mpq, mpn levels), but also major speed improvements for tiny operands. * mpn_get_str parameter restrictions relaxed. * Major speed improvements for HPPA 2.0 systems. * Major speed improvements for UltraSPARC systems. * Major speed improvements for IA-64 systems (but still sub-optimal code). * Extended test suite. * mpfr is back, with many bug fixes and portability improvements. * New function: mpz_ui_sub. * New functions: mpz_export, mpz_import. * Optimization for nth root functions (mpz_root, mpz_perfect_power_p). * Optimization for extended gcd (mpz_gcdext, mpz_invert, mpn_gcdext). * Generalized low-level number format, reserving a `nails' part of each limb. (Please note that this is really experimental; some functions are likely to compute garbage when nails are enabled.) * Nails-enabled Alpha 21264 assembly code, allowing up to 75% better performance. (Use --enable-nails=4 to enable it.) Changes between GMP version 4.0 and 4.0.1 * Bug fixes. Changes between GMP version 3.1.1 and 4.0 * Bug fixes. * Speed improvements. * Upwardly binary compatible with 3.x versions. * New CPU support: IA-64, Pentium 4. * Improved CPU support: 21264, Cray vector systems. * Support for all MIPS ABIs: o32, n32, 64. * New systems supported: Darwin, SCO, Windows DLLs. * New divide-and-conquer square root algorithm. * New algorithms chapter in the manual. * New malloc reentrant temporary memory method. * New C++ class interface by Gerardo Ballabio (beta). * Revamped configure, featuring ABI selection. * Speed improvements for mpz_powm and mpz_powm_ui (mainly affecting small operands). * mpz_perfect_power_p now properly recognizes 0, 1, and negative perfect powers. * mpz_hamdist now supports negative operands. * mpz_jacobi now accepts non-positive denominators. * mpz_powm now supports negative exponents. * mpn_mul_1 operand overlap requirements relaxed. * Float input and output uses locale specific decimal point where available. * New gmp_printf, gmp_scanf and related functions. * New division functions: mpz_cdiv_q_2exp, mpz_cdiv_r_2exp, mpz_divexact_ui. * New divisibility tests: mpz_divisible_p, mpz_divisible_ui_p, mpz_divisible_2exp_p, mpz_congruent_p, mpz_congruent_ui_p, mpz_congruent_2exp_p. * New Fibonacci function: mpz_fib2_ui. * New Lucas number functions: mpz_lucnum_ui, mpz_lucnum2_ui. * Other new integer functions: mpz_cmp_d, mpz_cmpabs_d, mpz_get_d_2exp, mpz_init2, mpz_kronecker, mpz_lcm_ui, mpz_realloc2. * New rational I/O: mpq_get_str, mpq_inp_str, mpq_out_str, mpq_set_str. * Other new rational functions: mpq_abs, mpq_cmp_si, mpq_div_2exp, mpq_mul_2exp, mpq_set_f. * New float tests: mpf_integer_p, mpf_fits_sint_p, mpf_fits_slong_p, mpf_fits_sshort_p, mpf_fits_uint_p, mpf_fits_ulong_p, mpf_fits_ushort_p. * Other new float functions: mpf_cmp_d, mpf_get_default_prec, mpf_get_si, mpf_get_ui, mpf_get_d_2exp. * New random functions: gmp_randinit_default, gmp_randinit_lc_2exp_size. * New demo expression string parser (see demos/expr). * New preliminary perl interface (see demos/perl). * Tuned algorithm thresholds for many more CPUs. Changes between GMP version 3.1 and 3.1.1 * Bug fixes for division (rare), mpf_get_str, FFT, and miscellaneous minor things. Changes between GMP version 3.0 and 3.1 * Bug fixes. * Improved `make check' running more tests. * Tuned algorithm cutoff points for many machines. This will improve speed for a lot of operations, in some cases by a large amount. * Major speed improvements: Alpha 21264. * Some speed improvements: Cray vector computers, AMD K6 and Athlon, Intel P5 and Pentium Pro/II/III. * The mpf_get_prec function now works as it did in GMP 2. * New utilities for auto-tuning and speed measuring. * Multiplication now optionally uses FFT for very large operands. (To enable it, pass --enable-fft to configure.) * Support for new systems: Solaris running on x86, FreeBSD 5, HP-UX 11, Cray vector computers, Rhapsody, Nextstep/Openstep, MacOS. * Support for shared libraries on 32-bit HPPA. * New integer functions: mpz_mul_si, mpz_odd_p, mpz_even_p. * New Kronecker symbol functions: mpz_kronecker_si, mpz_kronecker_ui, mpz_si_kronecker, mpz_ui_kronecker. * New rational functions: mpq_out_str, mpq_swap. * New float functions: mpf_swap. * New mpn functions: mpn_divexact_by3c, mpn_tdiv_qr. * New EXPERIMENTAL function layer for accurate floating-point arithmetic, mpfr. To try it, pass --enable-mpfr to configure. See the mpfr subdirectory for more information; it is not documented in the main GMP manual. Changes between GMP version 3.0 and 3.0.1 * Memory leaks in gmp_randinit and mpz_probab_prime_p fixed. * Documentation for gmp_randinit fixed. Misc documentation errors fixed. Changes between GMP version 2.0 and 3.0 * Source level compatibility with past releases (except mpn_gcd). * Bug fixes. * Much improved speed thanks to both host independent and host dependent optimizations. * Switch to autoconf/automake/libtool. * Support for building libgmp as a shared library. * Multiplication and squaring using 3-way Toom-Cook. * Division using the Burnikel-Ziegler method. * New functions computing binomial coefficients: mpz_bin_ui, mpz_bin_uiui. * New function computing Fibonacci numbers: mpz_fib_ui. * New random number generators: mpf_urandomb, mpz_rrandomb, mpz_urandomb, mpz_urandomm, gmp_randclear, gmp_randinit, gmp_randinit_lc_2exp, gmp_randseed, gmp_randseed_ui. * New function for quickly extracting limbs: mpz_getlimbn. * New functions performing integer size tests: mpz_fits_sint_p, mpz_fits_slong_p, mpz_fits_sshort_p, mpz_fits_uint_p, mpz_fits_ulong_p, mpz_fits_ushort_p. * New mpf functions: mpf_ceil, mpf_floor, mpf_pow_ui, mpf_trunc. * New mpq function: mpq_set_d. * New mpz functions: mpz_addmul_ui, mpz_cmpabs, mpz_cmpabs_ui, mpz_lcm, mpz_nextprime, mpz_perfect_power_p, mpz_remove, mpz_root, mpz_swap, mpz_tdiv_ui, mpz_tstbit, mpz_xor. * New mpn function: mpn_divexact_by3. * New CPU support: DEC Alpha 21264, AMD K6 and Athlon, HPPA 2.0 and 64, Intel Pentium Pro and Pentium-II/III, Sparc 64, PowerPC 64. * Almost 10 times faster mpz_invert and mpn_gcdext. * The interface of mpn_gcd has changed. * Better support for MIPS R4x000 and R5000 under Irix 6. * Improved support for SPARCv8 and SPARCv9 processors. Changes between GMP version 2.0 and 2.0.2 * Many bug fixes. Changes between GMP version 1.3.2 and 2.0 * Division routines in the mpz class have changed. There are three classes of functions, that rounds the quotient to -infinity, 0, and +infinity, respectively. The first class of functions have names that begin with mpz_fdiv (f is short for floor), the second class' names begin with mpz_tdiv (t is short for trunc), and the third class' names begin with mpz_cdiv (c is short for ceil). The old division routines beginning with mpz_m are similar to the new mpz_fdiv, with the exception that some of the new functions return useful values. The old function names can still be used. All the old functions names will now do floor division, not trunc division as some of them used to. This was changed to make the functions more compatible with common mathematical practice. The mpz_mod and mpz_mod_ui functions now compute the mathematical mod function. I.e., the sign of the 2nd argument is ignored. * The mpq assignment functions do not canonicalize their results. A new function, mpq_canonicalize must be called by the user if the result is not known to be canonical. * The mpn functions are now documented. These functions are intended for very time critical applications, or applications that need full control over memory allocation. Note that the mpn interface is irregular and hard to use. * New functions for arbitrary precision floating point arithmetic. Names begin with `mpf_'. Associated type mpf_t. * New and improved mpz functions, including much faster GCD, fast exact division (mpz_divexact), bit scan (mpz_scan0 and mpz_scan1), and number theoretical functions like Jacobi (mpz_jacobi) and multiplicative inverse (mpz_invert). * New variable types (mpz_t and mpq_t) are available that makes syntax of mpz and mpq calls nicer (no need for & before variables). The MP_INT and MP_RAT types are still available for compatibility. * Uses GNU configure. This makes it possible to choose target architecture and CPU variant, and to compile into a separate object directory. * Carefully optimized assembly for important inner loops. Support for DEC Alpha, Amd 29000, HPPA 1.0 and 1.1, Intel Pentium and generic x86, Intel i960, Motorola MC68000, MC68020, MC88100, and MC88110, Motorola/IBM PowerPC, National NS32000, IBM POWER, MIPS R3000, R4000, SPARCv7, SuperSPARC, generic SPARCv8, and DEC VAX. Some support also for ARM, Clipper, IBM ROMP (RT), and Pyramid AP/XP. * Faster. Thanks to the assembler code, new algorithms, and general tuning. In particular, the speed on machines without GCC is improved. * Support for machines without alloca. * Now under the LGPL. INCOMPATIBILITIES BETWEEN GMP 1 AND GMP 2 * mpq assignment functions do not canonicalize their results. * mpz division functions round differently. * mpz mod functions now really compute mod. * mpz_powm and mpz_powm_ui now really use mod for reduction. gcl-2.6.14/gmp4/gen-bases.c0000644000175000017500000001401014360276512013646 0ustar cammcamm/* Generate mp_bases data. Copyright 1991, 1993, 1994, 1996, 2000, 2002, 2004, 2011, 2012 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: * the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. or both in parallel, as here. The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the GNU Lesser General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ #include "bootstrap.c" int chars_per_limb; mpz_t big_base; int normalization_steps; mpz_t big_base_inverted; mpz_t t; #define POW2_P(n) (((n) & ((n) - 1)) == 0) unsigned int ulog2 (unsigned int x) { unsigned int i; for (i = 0; x != 0; i++) x >>= 1; return i; } void generate (int limb_bits, int nail_bits, int base) { int numb_bits = limb_bits - nail_bits; mpz_set_ui (t, 1L); mpz_mul_2exp (t, t, numb_bits); mpz_set_ui (big_base, 1L); chars_per_limb = 0; for (;;) { mpz_mul_ui (big_base, big_base, (long) base); if (mpz_cmp (big_base, t) > 0) break; chars_per_limb++; } mpz_ui_pow_ui (big_base, (long) base, (long) chars_per_limb); normalization_steps = limb_bits - mpz_sizeinbase (big_base, 2); mpz_set_ui (t, 1L); mpz_mul_2exp (t, t, 2*limb_bits - normalization_steps); mpz_tdiv_q (big_base_inverted, t, big_base); mpz_set_ui (t, 1L); mpz_mul_2exp (t, t, limb_bits); mpz_sub (big_base_inverted, big_base_inverted, t); } void header (int limb_bits, int nail_bits) { int numb_bits = limb_bits - nail_bits; generate (limb_bits, nail_bits, 10); printf ("/* This file generated by gen-bases.c - DO NOT EDIT. */\n"); printf ("\n"); printf ("#if GMP_NUMB_BITS != %d\n", numb_bits); printf ("Error, error, this data is for %d bits\n", numb_bits); printf ("#endif\n"); printf ("\n"); printf ("/* mp_bases[10] data, as literal values */\n"); printf ("#define MP_BASES_CHARS_PER_LIMB_10 %d\n", chars_per_limb); printf ("#define MP_BASES_BIG_BASE_10 CNST_LIMB(0x"); mpz_out_str (stdout, 16, big_base); printf (")\n"); printf ("#define MP_BASES_BIG_BASE_INVERTED_10 CNST_LIMB(0x"); mpz_out_str (stdout, 16, big_base_inverted); printf (")\n"); printf ("#define MP_BASES_NORMALIZATION_STEPS_10 %d\n", normalization_steps); } #define EXTRA 16 /* Compute log(2)/log(b) as a fixnum. */ void mp_2logb (mpz_t r, int bi, int prec) { mpz_t t, t2, two, b; int i; mpz_init_set_ui (t, 1); mpz_mul_2exp (t, t, prec+EXTRA); mpz_init (t2); mpz_init_set_ui (two, 2); mpz_mul_2exp (two, two, prec+EXTRA); mpz_set_ui (r, 0); mpz_init_set_ui (b, bi); mpz_mul_2exp (b, b, prec+EXTRA); for (i = prec-1; i >= 0; i--) { mpz_mul_2exp (b, b, prec+EXTRA); mpz_sqrt (b, b); mpz_mul (t2, t, b); mpz_tdiv_q_2exp (t2, t2, prec+EXTRA); if (mpz_cmp (t2, two) < 0) /* not too large? */ { mpz_setbit (r, i); /* set next less significant bit */ mpz_set (t, t2); /* new value acceptable */ } } mpz_clear (t); mpz_clear (t2); mpz_clear (two); mpz_clear (b); } void table (int limb_bits, int nail_bits) { int numb_bits = limb_bits - nail_bits; int base; mpz_t r, t, logb2, log2b; mpz_init (r); mpz_init (t); mpz_init (logb2); mpz_init (log2b); printf ("/* This file generated by gen-bases.c - DO NOT EDIT. */\n"); printf ("\n"); printf ("#include \"gmp.h\"\n"); printf ("#include \"gmp-impl.h\"\n"); printf ("\n"); printf ("#if GMP_NUMB_BITS != %d\n", numb_bits); printf ("Error, error, this data is for %d bits\n", numb_bits); printf ("#endif\n"); printf ("\n"); puts ("const struct bases mp_bases[257] =\n{"); puts (" /* 0 */ { 0, 0, 0, 0, 0 },"); puts (" /* 1 */ { 0, 0, 0, 0, 0 },"); for (base = 2; base <= 256; base++) { generate (limb_bits, nail_bits, base); mp_2logb (r, base, limb_bits + 8); mpz_tdiv_q_2exp (logb2, r, 8); mpz_set_ui (t, 1); mpz_mul_2exp (t, t, 2*limb_bits + 5); mpz_sub_ui (t, t, 1); mpz_add_ui (r, r, 1); mpz_tdiv_q (log2b, t, r); printf (" /* %3u */ { ", base); if (POW2_P (base)) { mpz_set_ui (big_base, ulog2 (base) - 1); mpz_set_ui (big_base_inverted, 0); } printf ("%u,", chars_per_limb); printf (" CNST_LIMB(0x"); mpz_out_str (stdout, 16, logb2); printf ("), CNST_LIMB(0x"); mpz_out_str (stdout, 16, log2b); printf ("), CNST_LIMB(0x"); mpz_out_str (stdout, 16, big_base); printf ("), CNST_LIMB(0x"); mpz_out_str (stdout, 16, big_base_inverted); printf (") },\n"); } puts ("};"); mpz_clear (r); mpz_clear (t); mpz_clear (logb2); mpz_clear (log2b); } int main (int argc, char **argv) { int limb_bits, nail_bits; mpz_init (big_base); mpz_init (big_base_inverted); mpz_init (t); if (argc != 4) { fprintf (stderr, "Usage: gen-bases \n"); exit (1); } limb_bits = atoi (argv[2]); nail_bits = atoi (argv[3]); if (limb_bits <= 0 || nail_bits < 0 || nail_bits >= limb_bits) { fprintf (stderr, "Invalid limb/nail bits: %d %d\n", limb_bits, nail_bits); exit (1); } if (strcmp (argv[1], "header") == 0) header (limb_bits, nail_bits); else if (strcmp (argv[1], "table") == 0) table (limb_bits, nail_bits); else { fprintf (stderr, "Invalid header/table choice: %s\n", argv[1]); exit (1); } return 0; } gcl-2.6.14/gmp4/acinclude.m40000644000175000017500000036163714360276512014053 0ustar cammcammdnl GMP specific autoconf macros dnl Copyright 2000-2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. dnl dnl This file is part of the GNU MP Library. dnl dnl The GNU MP Library is free software; you can redistribute it and/or modify dnl it under the terms of either: dnl dnl * the GNU Lesser General Public License as published by the Free dnl Software Foundation; either version 3 of the License, or (at your dnl option) any later version. dnl dnl or dnl dnl * the GNU General Public License as published by the Free Software dnl Foundation; either version 2 of the License, or (at your option) any dnl later version. dnl dnl or both in parallel, as here. dnl dnl The GNU MP Library is distributed in the hope that it will be useful, but dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License dnl for more details. dnl dnl You should have received copies of the GNU General Public License and the dnl GNU Lesser General Public License along with the GNU MP Library. If not, dnl see https://www.gnu.org/licenses/. dnl Some tests use, or must delete, the default compiler output. The dnl possible filenames are based on what autoconf looks for, namely dnl dnl a.out - normal unix style dnl b.out - i960 systems, including gcc there dnl a.exe - djgpp dnl a_out.exe - OpenVMS DEC C called via GNV wrapper (gnv.sourceforge.net) dnl conftest.exe - various DOS compilers define(IA64_PATTERN, [[ia64*-*-* | itanium-*-* | itanium2-*-*]]) dnl Need to be careful not to match m6811, m6812, m68hc11 and m68hc12, all dnl of which config.sub accepts. (Though none of which are likely to work dnl with GMP.) dnl define(M68K_PATTERN, [[m68k-*-* | m68[0-9][0-9][0-9]-*-*]]) define(POWERPC64_PATTERN, [[powerpc64-*-* | powerpc64le-*-* | powerpc620-*-* | powerpc630-*-* | powerpc970-*-* | power[3-9]-*-*]]) define(S390_PATTERN, [[s390-*-* | z900esa-*-* | z990esa-*-* | z9esa-*-* | z10esa-*-* | z196esa-*-*]]) define(S390X_PATTERN, [[s390x-*-* | z900-*-* | z990-*-* | z9-*-* | z10-*-* | z196-*-*]]) define(X86_PATTERN, [[i?86*-*-* | k[5-8]*-*-* | pentium*-*-* | athlon-*-* | viac3*-*-* | geode*-*-* | atom-*-*]]) define(X86_64_PATTERN, [[athlon64-*-* | k8-*-* | k10-*-* | bobcat-*-* | jaguar-*-* | bulldozer-*-* | piledriver-*-* | steamroller-*-* | excavator-*-* | pentium4-*-* | atom-*-* | core2-*-* | corei*-*-* | x86_64-*-* | nano-*-*]]) dnl GMP_FAT_SUFFIX(DSTVAR, DIRECTORY) dnl --------------------------------- dnl Emit code to set shell variable DSTVAR to the suffix for a fat binary dnl routine from DIRECTORY. DIRECTORY can be a shell expression like $foo dnl etc. dnl dnl The suffix is directory separators / or \ changed to underscores, and dnl if there's more than one directory part, then the first is dropped. dnl dnl For instance, dnl dnl x86 -> x86 dnl x86/k6 -> k6 dnl x86/k6/mmx -> k6_mmx define(GMP_FAT_SUFFIX, [[$1=`echo $2 | sed -e '/\//s:^[^/]*/::' -e 's:[\\/]:_:g'`]]) dnl GMP_REMOVE_FROM_LIST(listvar,item) dnl ---------------------------------- dnl Emit code to remove any occurrence of ITEM from $LISTVAR. ITEM can be a dnl shell expression like $foo if desired. define(GMP_REMOVE_FROM_LIST, [remove_from_list_tmp= for remove_from_list_i in $[][$1]; do if test $remove_from_list_i = [$2]; then :; else remove_from_list_tmp="$remove_from_list_tmp $remove_from_list_i" fi done [$1]=$remove_from_list_tmp ]) dnl GMP_STRIP_PATH(subdir) dnl ---------------------- dnl Strip entries */subdir from $path and $fat_path. define(GMP_STRIP_PATH, [GMP_STRIP_PATH_VAR(path, [$1]) GMP_STRIP_PATH_VAR(fat_path, [$1]) ]) define(GMP_STRIP_PATH_VAR, [tmp_path= for i in $[][$1]; do case $i in */[$2]) ;; *) tmp_path="$tmp_path $i" ;; esac done [$1]="$tmp_path" ]) dnl GMP_INCLUDE_GMP_H dnl ----------------- dnl Expand to the right way to #include gmp-h.in. This must be used dnl instead of gmp.h, since that file isn't generated until the end of the dnl configure. dnl dnl Dummy value for GMP_LIMB_BITS is enough dnl for all current configure-time uses of gmp.h. define(GMP_INCLUDE_GMP_H, [[#define __GMP_WITHIN_CONFIGURE 1 /* ignore template stuff */ #define GMP_NAIL_BITS $GMP_NAIL_BITS #define GMP_LIMB_BITS 123 $DEFN_LONG_LONG_LIMB #include "$srcdir/gmp-h.in"] ]) dnl GMP_HEADER_GETVAL(NAME,FILE) dnl ---------------------------- dnl Expand at autoconf time to the value of a "#define NAME" from the given dnl FILE. The regexps here aren't very rugged, but are enough for gmp. dnl /dev/null as a parameter prevents a hang if $2 is accidentally omitted. define(GMP_HEADER_GETVAL, [patsubst(patsubst( esyscmd([grep "^#define $1 " $2 /dev/null 2>/dev/null]), [^.*$1[ ]+],[]), [[ ]*$],[])]) dnl GMP_VERSION dnl ----------- dnl The gmp version number, extracted from the #defines in gmp-h.in at dnl autoconf time. Two digits like 3.0 if patchlevel <= 0, or three digits dnl like 3.0.1 if patchlevel > 0. define(GMP_VERSION, [GMP_HEADER_GETVAL(__GNU_MP_VERSION,gmp-h.in)[]dnl .GMP_HEADER_GETVAL(__GNU_MP_VERSION_MINOR,gmp-h.in)[]dnl .GMP_HEADER_GETVAL(__GNU_MP_VERSION_PATCHLEVEL,gmp-h.in)]) dnl GMP_SUBST_CHECK_FUNCS(func,...) dnl ------------------------------ dnl Setup an AC_SUBST of HAVE_FUNC_01 for each argument. AC_DEFUN([GMP_SUBST_CHECK_FUNCS], [m4_if([$1],,, [_GMP_SUBST_CHECK_FUNCS(ac_cv_func_[$1],HAVE_[]m4_translit([$1],[a-z],[A-Z])_01) GMP_SUBST_CHECK_FUNCS(m4_shift($@))])]) dnl Called: _GMP_SUBST_CHECK_FUNCS(cachevar,substvar) AC_DEFUN([_GMP_SUBST_CHECK_FUNCS], [case $[$1] in yes) AC_SUBST([$2],1) ;; no) [$2]=0 ;; esac ]) dnl GMP_SUBST_CHECK_HEADERS(foo.h,...) dnl ---------------------------------- dnl Setup an AC_SUBST of HAVE_FOO_H_01 for each argument. AC_DEFUN([GMP_SUBST_CHECK_HEADERS], [m4_if([$1],,, [_GMP_SUBST_CHECK_HEADERS(ac_cv_header_[]m4_translit([$1],[./],[__]), HAVE_[]m4_translit([$1],[a-z./],[A-Z__])_01) GMP_SUBST_CHECK_HEADERS(m4_shift($@))])]) dnl Called: _GMP_SUBST_CHECK_HEADERS(cachevar,substvar) AC_DEFUN([_GMP_SUBST_CHECK_HEADERS], [case $[$1] in yes) AC_SUBST([$2],1) ;; no) [$2]=0 ;; esac ]) dnl GMP_COMPARE_GE(A1,B1, A2,B2, ...) dnl --------------------------------- dnl Compare two version numbers A1.A2.etc and B1.B2.etc. Set dnl $gmp_compare_ge to yes or no according to the result. The A parts dnl should be variables, the B parts fixed numbers. As many parts as dnl desired can be included. An empty string in an A part is taken to be dnl zero, the B parts should be non-empty and non-zero. dnl dnl For example, dnl dnl GMP_COMPARE($major,10, $minor,3, $subminor,1) dnl dnl would test whether $major.$minor.$subminor is greater than or equal to dnl 10.3.1. AC_DEFUN([GMP_COMPARE_GE], [gmp_compare_ge=no GMP_COMPARE_GE_INTERNAL($@) ]) AC_DEFUN([GMP_COMPARE_GE_INTERNAL], [ifelse(len([$3]),0, [if test -n "$1" && test "$1" -ge $2; then gmp_compare_ge=yes fi], [if test -n "$1"; then if test "$1" -gt $2; then gmp_compare_ge=yes else if test "$1" -eq $2; then GMP_COMPARE_GE_INTERNAL(m4_shift(m4_shift($@))) fi fi fi]) ]) dnl GMP_PROG_AR dnl ----------- dnl GMP additions to $AR. dnl dnl A cross-"ar" may be necessary when cross-compiling since the build dnl system "ar" might try to interpret the object files to build a symbol dnl table index, hence the use of AC_CHECK_TOOL. dnl dnl A user-selected $AR is always left unchanged. AC_CHECK_TOOL is still dnl run to get the "checking" message printed though. dnl dnl If extra flags are added to AR, then ac_cv_prog_AR and dnl ac_cv_prog_ac_ct_AR are set too, since libtool (cvs 2003-03-31 at dnl least) will do an AC_CHECK_TOOL and that will AR from one of those two dnl cached variables. (ac_cv_prog_AR is used if there's an ac_tool_prefix, dnl or ac_cv_prog_ac_ct_AR is used otherwise.) FIXME: This is highly dnl dependent on autoconf internals, perhaps it'd work to put our extra dnl flags into AR_FLAGS instead. dnl dnl $AR_FLAGS is set to "cq" rather than leaving it to libtool "cru". The dnl latter fails when libtool goes into piecewise mode and is unlucky dnl enough to have two same-named objects in separate pieces, as happens dnl for instance to random.o (and others) on vax-dec-ultrix4.5. Naturally dnl a user-selected $AR_FLAGS is left unchanged. dnl dnl For reference, $ARFLAGS is used by automake (1.8) for its ".a" archive dnl file rules. This doesn't get used by the piecewise linking, so we dnl leave it at the default "cru". dnl dnl FIXME: Libtool 1.5.2 has its own arrangements for "cq", but that version dnl is broken in other ways. When we can upgrade, remove the forcible dnl AR_FLAGS=cq. AC_DEFUN([GMP_PROG_AR], [dnl Want to establish $AR before libtool initialization. AC_BEFORE([$0],[AC_PROG_LIBTOOL]) gmp_user_AR=$AR AC_CHECK_TOOL(AR, ar, ar) if test -z "$gmp_user_AR"; then eval arflags=\"\$ar${abi1}_flags\" test -n "$arflags" || eval arflags=\"\$ar${abi2}_flags\" if test -n "$arflags"; then AC_MSG_CHECKING([for extra ar flags]) AR="$AR $arflags" ac_cv_prog_AR="$AR $arflags" ac_cv_prog_ac_ct_AR="$AR $arflags" AC_MSG_RESULT([$arflags]) fi fi if test -z "$AR_FLAGS"; then AR_FLAGS=cq fi ]) dnl GMP_PROG_M4 dnl ----------- dnl Find a working m4, either in $PATH or likely locations, and setup $M4 dnl and an AC_SUBST accordingly. If $M4 is already set then it's a user dnl choice and is accepted with no checks. GMP_PROG_M4 is like dnl AC_PATH_PROG or AC_CHECK_PROG, but tests each m4 found to see if it's dnl good enough. dnl dnl See mpn/asm-defs.m4 for details on the known bad m4s. AC_DEFUN([GMP_PROG_M4], [AC_ARG_VAR(M4,[m4 macro processor]) AC_CACHE_CHECK([for suitable m4], gmp_cv_prog_m4, [if test -n "$M4"; then gmp_cv_prog_m4="$M4" else cat >conftest.m4 <<\EOF dnl Must protect this against being expanded during autoconf m4! dnl Dont put "dnl"s in this as autoconf will flag an error for unexpanded dnl macros. [define(dollarhash,``$][#'')ifelse(dollarhash(x),1,`define(t1,Y)', ``bad: $][# not supported (SunOS /usr/bin/m4) '')ifelse(eval(89),89,`define(t2,Y)', `bad: eval() doesnt support 8 or 9 in a constant (OpenBSD 2.6 m4) ')ifelse(eval(9,9),10,`define(t3,Y)', `bad: eval() doesnt support radix in eval (FreeBSD 8.x,9.0,9.1,9.2 m4) ')ifelse(t1`'t2`'t3,YYY,`good ')] EOF dnl ' <- balance the quotes for emacs sh-mode echo "trying m4" >&AC_FD_CC gmp_tmp_val=`(m4 conftest.m4) 2>&AC_FD_CC` echo "$gmp_tmp_val" >&AC_FD_CC if test "$gmp_tmp_val" = good; then gmp_cv_prog_m4="m4" else IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" dnl $ac_dummy forces splitting on constant user-supplied paths. dnl POSIX.2 word splitting is done only on the output of word expansions, dnl not every word. This closes a longstanding sh security hole. ac_dummy="$PATH:/usr/5bin" for ac_dir in $ac_dummy; do test -z "$ac_dir" && ac_dir=. echo "trying $ac_dir/m4" >&AC_FD_CC gmp_tmp_val=`($ac_dir/m4 conftest.m4) 2>&AC_FD_CC` echo "$gmp_tmp_val" >&AC_FD_CC if test "$gmp_tmp_val" = good; then gmp_cv_prog_m4="$ac_dir/m4" break fi done IFS="$ac_save_ifs" if test -z "$gmp_cv_prog_m4"; then AC_MSG_ERROR([No usable m4 in \$PATH or /usr/5bin (see config.log for reasons).]) fi fi rm -f conftest.m4 fi]) M4="$gmp_cv_prog_m4" AC_SUBST(M4) ]) dnl GMP_M4_M4WRAP_SPURIOUS dnl ---------------------- dnl Check for spurious output from m4wrap(), as described in mpn/asm-defs.m4. dnl dnl The following systems have been seen with the problem. dnl dnl - Unicos alpha, but its assembler doesn't seem to mind. dnl - MacOS X Darwin, its assembler fails. dnl - NetBSD 1.4.1 m68k, and gas 1.92.3 there gives a warning and ignores dnl the bad last line since it doesn't have a newline. dnl - NetBSD 1.4.2 alpha, but its assembler doesn't seem to mind. dnl - HP-UX ia64. dnl dnl Enhancement: Maybe this could be in GMP_PROG_M4, and attempt to prefer dnl an m4 with a working m4wrap, if it can be found. AC_DEFUN([GMP_M4_M4WRAP_SPURIOUS], [AC_REQUIRE([GMP_PROG_M4]) AC_CACHE_CHECK([if m4wrap produces spurious output], gmp_cv_m4_m4wrap_spurious, [# hide the d-n-l from autoconf's error checking tmp_d_n_l=d""nl cat >conftest.m4 <&AC_FD_CC cat conftest.m4 >&AC_FD_CC tmp_chars=`$M4 conftest.m4 | wc -c` echo produces $tmp_chars chars output >&AC_FD_CC rm -f conftest.m4 if test $tmp_chars = 0; then gmp_cv_m4_m4wrap_spurious=no else gmp_cv_m4_m4wrap_spurious=yes fi ]) GMP_DEFINE_RAW(["define(,<$gmp_cv_m4_m4wrap_spurious>)"]) ]) dnl GMP_PROG_NM dnl ----------- dnl GMP additions to libtool AC_PROG_NM. dnl dnl Note that if AC_PROG_NM can't find a working nm it still leaves dnl $NM set to "nm", so $NM can't be assumed to actually work. dnl dnl A user-selected $NM is always left unchanged. AC_PROG_NM is still run dnl to get the "checking" message printed though. dnl dnl Perhaps it'd be worthwhile checking that nm works, by running it on an dnl actual object file. For instance on sparcv9 solaris old versions of dnl GNU nm don't recognise 64-bit objects. Checking would give a better dnl error message than just a failure in later tests like GMP_ASM_W32 etc. dnl dnl On the other hand it's not really normal autoconf practice to take too dnl much trouble over detecting a broken set of tools. And libtool doesn't dnl do anything at all for say ranlib or strip. So for now we're inclined dnl to just demand that the user provides a coherent environment. AC_DEFUN([GMP_PROG_NM], [dnl Make sure we're the first to call AC_PROG_NM, so our extra flags are dnl used by everyone. AC_BEFORE([$0],[AC_PROG_NM]) gmp_user_NM=$NM AC_PROG_NM # FIXME: When cross compiling (ie. $ac_tool_prefix not empty), libtool # defaults to plain "nm" if a "${ac_tool_prefix}nm" is not found. In this # case run it again to try the native "nm", firstly so that likely locations # are searched, secondly so that -B or -p are added if necessary for BSD # format. This is necessary for instance on OSF with "./configure # --build=alphaev5-dec-osf --host=alphaev6-dec-osf". # if test -z "$gmp_user_NM" && test -n "$ac_tool_prefix" && test "$NM" = nm; then $as_unset lt_cv_path_NM gmp_save_ac_tool_prefix=$ac_tool_prefix ac_tool_prefix= NM= AC_PROG_NM ac_tool_prefix=$gmp_save_ac_tool_prefix fi if test -z "$gmp_user_NM"; then eval nmflags=\"\$nm${abi1}_flags\" test -n "$nmflags" || eval nmflags=\"\$nm${abi2}_flags\" if test -n "$nmflags"; then AC_MSG_CHECKING([for extra nm flags]) NM="$NM $nmflags" AC_MSG_RESULT([$nmflags]) fi fi ]) dnl GMP_PROG_CC_WORKS(cc+cflags,[ACTION-IF-WORKS][,ACTION-IF-NOT-WORKS]) dnl -------------------------------------------------------------------- dnl Check if cc+cflags can compile and link. dnl dnl This test is designed to be run repeatedly with different cc+cflags dnl selections, so the result is not cached. dnl dnl For a native build, meaning $cross_compiling == no, we require that the dnl generated program will run. This is the same as AC_PROG_CC does in dnl _AC_COMPILER_EXEEXT_WORKS, and checking here will ensure we don't pass dnl a CC/CFLAGS combination that it rejects. dnl dnl sparc-*-solaris2.7 can compile ABI=64 but won't run it if the kernel dnl was booted in 32-bit mode. The effect of requiring the compiler output dnl will run is that a plain native "./configure" falls back on ABI=32, but dnl ABI=64 is still available as a cross-compile. dnl dnl The various specific problems we try to detect are done in separate dnl compiles. Although this is probably a bit slower than one test dnl program, it makes it easy to indicate the problem in AC_MSG_RESULT, dnl hence giving the user a clue about why we rejected the compiler. AC_DEFUN([GMP_PROG_CC_WORKS], [AC_MSG_CHECKING([compiler $1]) gmp_prog_cc_works=yes # first see a simple "main()" works, then go on to other checks GMP_PROG_CC_WORKS_PART([$1], []) GMP_PROG_CC_WORKS_PART([$1], [function pointer return], [/* The following provokes an internal error from gcc 2.95.2 -mpowerpc64 (without -maix64), hence detecting an unusable compiler */ void *g() { return (void *) 0; } void *f() { return g(); } ]) GMP_PROG_CC_WORKS_PART([$1], [cmov instruction], [/* The following provokes an invalid instruction syntax from i386 gcc -march=pentiumpro on Solaris 2.8. The native sun assembler requires a non-standard syntax for cmov which gcc (as of 2.95.2 at least) doesn't know. */ int n; int cmov () { return (n >= 0 ? n : 0); } ]) GMP_PROG_CC_WORKS_PART([$1], [double -> ulong conversion], [/* The following provokes a linker invocation problem with gcc 3.0.3 on AIX 4.3 under "-maix64 -mpowerpc64 -mcpu=630". The -mcpu=630 option causes gcc to incorrectly select the 32-bit libgcc.a, not the 64-bit one, and consequently it misses out on the __fixunsdfdi helper (double -> uint64 conversion). */ double d; unsigned long gcc303 () { return (unsigned long) d; } ]) GMP_PROG_CC_WORKS_PART([$1], [double negation], [/* The following provokes an error from hppa gcc 2.95 under -mpa-risc-2-0 if the assembler doesn't know hppa 2.0 instructions. fneg is a 2.0 instruction, and a negation like this comes out using it. */ double fneg_data; unsigned long fneg () { return -fneg_data; } ]) GMP_PROG_CC_WORKS_PART([$1], [double -> float conversion], [/* The following makes gcc 3.3 -march=pentium4 generate an SSE2 xmm insn (cvtsd2ss) which will provoke an error if the assembler doesn't recognise those instructions. Not sure how much of the gmp code will come out wanting sse2, but it's easiest to reject an option we know is bad. */ double ftod_data; float ftod () { return (float) ftod_data; } ]) GMP_PROG_CC_WORKS_PART([$1], [gnupro alpha ev6 char spilling], [/* The following provokes an internal compiler error from gcc version "2.9-gnupro-99r1" under "-O2 -mcpu=ev6", apparently relating to char values being spilled into floating point registers. The problem doesn't show up all the time, but has occurred enough in GMP for us to reject this compiler+flags. */ #include /* for memcpy */ struct try_t { char dst[2]; char size; long d0, d1, d2, d3, d4, d5, d6; char overlap; }; struct try_t param[6]; int param_init () { struct try_t *p; memcpy (p, ¶m[ 2 ], sizeof (*p)); memcpy (p, ¶m[ 2 ], sizeof (*p)); p->size = 2; memcpy (p, ¶m[ 1 ], sizeof (*p)); p->dst[0] = 1; p->overlap = 2; memcpy (p, ¶m[ 3 ], sizeof (*p)); p->dst[0] = 1; p->overlap = 8; memcpy (p, ¶m[ 4 ], sizeof (*p)); memcpy (p, ¶m[ 4 ], sizeof (*p)); p->overlap = 8; memcpy (p, ¶m[ 5 ], sizeof (*p)); memcpy (p, ¶m[ 5 ], sizeof (*p)); memcpy (p, ¶m[ 5 ], sizeof (*p)); return 0; } ]) # __builtin_alloca is not available everywhere, check it exists before # seeing that it works GMP_PROG_CC_WORKS_PART_TEST([$1],[__builtin_alloca availability], [int k; int foo () { __builtin_alloca (k); }], [GMP_PROG_CC_WORKS_PART([$1], [alloca array], [/* The following provokes an internal compiler error from Itanium HP-UX cc under +O2 or higher. We use this sort of code in mpn/generic/mul_fft.c. */ int k; int foo () { int i, **a; a = __builtin_alloca (k); for (i = 0; i <= k; i++) a[i] = __builtin_alloca (1 << i); } ])]) GMP_PROG_CC_WORKS_PART([$1], [abs int -> double conversion], [/* The following provokes an internal error from the assembler on power2-ibm-aix4.3.1.0. gcc -mrios2 compiles to nabs+fcirz, and this results in "Internal error related to the source program domain". For reference it seems to be the combination of nabs+fcirz which is bad, not either alone. This sort of thing occurs in mpz/get_str.c with the way double chars_per_bit_exactly is applied in MPN_SIZEINBASE. Perhaps if that code changes to a scaled-integer style then we won't need this test. */ double fp[1]; int x; int f () { int a; a = (x >= 0 ? x : -x); return a * fp[0]; } ]) GMP_PROG_CC_WORKS_PART([$1], [long long reliability test 1], [/* The following provokes a segfault in the compiler on powerpc-apple-darwin. Extracted from tests/mpn/t-iord_u.c. Causes Apple's gcc 3.3 build 1640 and 1666 to segfault with e.g., -O2 -mpowerpc64. */ #if defined (__GNUC__) && ! defined (__cplusplus) typedef unsigned long long t1;typedef t1*t2; static __inline__ t1 e(t2 rp,t2 up,int n,t1 v0) {t1 c=0,x,r;int i;if(v0){c=1;for(i=1;i> tnc; high_limb = low_limb << cnt; for (i = n - 1; i != 0; i--) { low_limb = *up++; *rp++ = ~(high_limb | (low_limb >> tnc)); high_limb = low_limb << cnt; } return retval; } int main () { unsigned long cy, rp[2], up[2]; up[0] = ~ 0L; up[1] = 0; cy = lshift_com (rp, up, 2L, 1); if (cy != 1L) return 1; return 0; } #else int main () { return 0; } #endif ]) GMP_PROG_CC_WORKS_PART_MAIN([$1], [mpn_lshift_com optimization 2], [/* The following is mis-compiled by Intel ia-64 icc version 1.8 under "icc -O3", After several calls, the function writes partial garbage to the result vector. Perhaps relates to the chk.a.nc insn. This code needs to be run to show the problem, but that's fine, the offending cc is a native-only compiler so we don't have to worry about cross compiling. */ #if ! defined (__cplusplus) #include void lshift_com (rp, up, n, cnt) unsigned long *rp; unsigned long *up; long n; unsigned cnt; { unsigned long high_limb, low_limb; unsigned tnc; long i; up += n; rp += n; tnc = 8 * sizeof (unsigned long) - cnt; low_limb = *--up; high_limb = low_limb << cnt; for (i = n - 1; i != 0; i--) { low_limb = *--up; *--rp = ~(high_limb | (low_limb >> tnc)); high_limb = low_limb << cnt; } *--rp = ~high_limb; } int main () { unsigned long *r, *r2; unsigned long a[88 + 1]; long i; for (i = 0; i < 88 + 1; i++) a[i] = ~0L; r = malloc (10000 * sizeof (unsigned long)); r2 = r; for (i = 0; i < 528; i += 22) { lshift_com (r2, a, i / (8 * sizeof (unsigned long)) + 1, i % (8 * sizeof (unsigned long))); r2 += 88 + 1; } if (r[2048] != 0 || r[2049] != 0 || r[2050] != 0 || r[2051] != 0 || r[2052] != 0 || r[2053] != 0 || r[2054] != 0) abort (); return 0; } #else int main () { return 0; } #endif ]) # A certain _GLOBAL_OFFSET_TABLE_ problem in past versions of gas, tickled # by recent versions of gcc. # if test "$gmp_prog_cc_works" = yes; then case $host in X86_PATTERN) # this problem only arises in PIC code, so don't need to test when # --disable-shared. We don't necessarily have $enable_shared set to # yes at this point, it will still be unset for the default (which is # yes); hence the use of "!= no". if test "$enable_shared" != no; then GMP_PROG_CC_X86_GOT_EAX_EMITTED([$1], [GMP_ASM_X86_GOT_EAX_OK([$1],, [gmp_prog_cc_works="no, bad gas GOT with eax"])]) fi ;; esac fi AC_MSG_RESULT($gmp_prog_cc_works) case $gmp_prog_cc_works in yes) [$2] ;; *) [$3] ;; esac ]) dnl Called: GMP_PROG_CC_WORKS_PART(CC+CFLAGS,FAIL-MESSAGE [,CODE]) dnl A dummy main() is appended to the CODE given. dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART], [GMP_PROG_CC_WORKS_PART_MAIN([$1],[$2], [$3] [int main () { return 0; }]) ]) dnl Called: GMP_PROG_CC_WORKS_PART_MAIN(CC+CFLAGS,FAIL-MESSAGE,CODE) dnl CODE must include a main(). dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART_MAIN], [GMP_PROG_CC_WORKS_PART_TEST([$1],[$2],[$3], [], gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2]", gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2][[, program does not run]]") ]) dnl Called: GMP_PROG_CC_WORKS_PART_TEST(CC+CFLAGS,TITLE,[CODE], dnl [ACTION-GOOD],[ACTION-BAD][ACTION-NORUN]) dnl AC_DEFUN([GMP_PROG_CC_WORKS_PART_TEST], [if test "$gmp_prog_cc_works" = yes; then # remove anything that might look like compiler output to our "||" expression rm -f conftest* a.out b.out a.exe a_out.exe cat >conftest.c <&AC_FD_CC gmp_compile="$1 conftest.c >&AC_FD_CC" if AC_TRY_EVAL(gmp_compile); then cc_works_part=yes if test "$cross_compiling" = no; then if AC_TRY_COMMAND([./a.out || ./b.out || ./a.exe || ./a_out.exe || ./conftest]); then :; else cc_works_part=norun fi fi else cc_works_part=no fi if test "$cc_works_part" != yes; then echo "failed program was:" >&AC_FD_CC cat conftest.c >&AC_FD_CC fi rm -f conftest* a.out b.out a.exe a_out.exe case $cc_works_part in yes) $4 ;; no) $5 ;; norun) $6 ;; esac fi ]) dnl GMP_PROG_CC_WORKS_LONGLONG(cc+cflags,[ACTION-YES][,ACTION-NO]) dnl -------------------------------------------------------------- dnl Check that cc+cflags accepts "long long". dnl dnl This test is designed to be run repeatedly with different cc+cflags dnl selections, so the result is not cached. AC_DEFUN([GMP_PROG_CC_WORKS_LONGLONG], [AC_MSG_CHECKING([compiler $1 has long long]) cat >conftest.c <&AC_FD_CC cat conftest.c >&AC_FD_CC fi rm -f conftest* a.out b.out a.exe a_out.exe AC_MSG_RESULT($gmp_prog_cc_works) if test $gmp_prog_cc_works = yes; then ifelse([$2],,:,[$2]) else ifelse([$3],,:,[$3]) fi ]) dnl GMP_C_TEST_SIZEOF(cc/cflags,test,[ACTION-GOOD][,ACTION-BAD]) dnl ------------------------------------------------------------ dnl The given cc/cflags compiler is run to check the size of a type dnl specified by the "test" argument. "test" can either be a string, or a dnl variable like $foo. The value should be for instance "sizeof-long-4", dnl to test that sizeof(long)==4. dnl dnl This test is designed to be run for different compiler and/or flags dnl combinations, so the result is not cached. dnl dnl The idea for making an array that has a negative size if the desired dnl condition test is false comes from autoconf AC_CHECK_SIZEOF. The cast dnl to "long" in the array dimension also follows autoconf, apparently it's dnl a workaround for a HP compiler bug. AC_DEFUN([GMP_C_TEST_SIZEOF], [echo "configure: testlist $2" >&AC_FD_CC [gmp_sizeof_type=`echo "$2" | sed 's/sizeof-\([a-z]*\).*/\1/'`] [gmp_sizeof_want=`echo "$2" | sed 's/sizeof-[a-z]*-\([0-9]*\).*/\1/'`] AC_MSG_CHECKING([compiler $1 has sizeof($gmp_sizeof_type)==$gmp_sizeof_want]) cat >conftest.c <conftest.c <

    • hmv_˝8=!T` ݄S[Zc c(یbDiH6NvQXI4~[*S4QBu0'd0DBH!F}[?ؒi6.7qłwi9_X/6N!"U[$UHPCRY R03 5b (/\)_6 &)\CVnxP-HP ԁL7sʄ5Jqo}Z{b:w>n&wt}+}o4Ǧ$ ͨ %BP 5hȟ05w+ al jyy4%XB9iN/5"L)) (OK$~ ף{pFh'w.Naw[((Ix"bX)=g˫1-2b˳urP]P&X S?M~3{[]D6efb%* f%0~+FKvJAeVW \ =D86):ʪD t"qyiͱǁhR6D$0 SU{fB cbb݊TΑvFGk(@ ^%j&+MLJ;#Es<vE߉ztU)dL\s"d`!39Q]F]>hf3HNfM{*׹+ >q>6Ĝ hN'u1}#Z73qS:DdJ.^.v_M }-R={I.Cu)# ܳ}cDb܆y'YpVUpj5E^g%i_.kbcH!J~Oơ-' ^z73w V(Jh;](͡zNP7?ҷ}M~~#Pm313>.zwpʤ&ۮi{˝}`xr#+ľˉ1 b`ШdP4&M8iB C'8-LjR3:Ð}}ʙ48$DvYv>TjNꑄ0,$RD ۞ T+a{砊2MAIX']G8UJ\!@`wߙYhl'|OP6XԯjB ѭM*DM*oO:+]~trGruێnhPD?TwC'ʐ4~\8KpɆ'r%3|!axɘ> stream xڵXKoFWȡ$pOizVh[DF|gW^ʲ CÙoͷH8_' FM23:oOզE .Jye*~]q7-D $/ ܷW7z/U ҄;[BE\4Wem!oo }3k{dC8+̹,"r=׺$TMA !:"p$n WZ.yyoYKU$cdYI)RZ9wU.1ټT}Na iF%a|bEDXœzSrVJ 9&fJ](hO׉0PaY3bi G+I/KͶ^t^~]Lnu !ټbI=:"X'=BPf|nӀr &cCY>}y;)(Zҙ"Iד9~VYԇً(/Pt:5AyNӞU"1-aGܣ"ܴlxMI(FTx`@Msq+1'@ eP- ˟uݱ݇nݧXSўͼb›zƇH9֧4TuʫFiu"{S}=ēg` Ę9I@p1{}YQWbUүcLSo)$ƊG? W'Qq`lC^E٣;pVtkuX[+k02!g_9]2&20gI~S Qc!F~šb! ݎ8KQԦ mG@ kT P C?3>"A_r2wBGs_'3 #hTmy;XX_bA.]|?Ԑ .҃Ý*ɨu+8OL7;} h_D]11BF#)oF|tNJtt]9BY!EEyy^e:#o$<.EtcxZ@N!C̩A{K:I7˦c!Avb& R Rb 4s+/:ODbRsX ݼZnm5y1$MM endstream endobj 1797 0 obj <> stream xX[oD~WX+ӹzfx(AAP x8K^{93c{=qB(;;$_mv7Wыs4$C],4_>")mz{yJcqVݸwoqoݮ̙?=}]M˫qg8'ކu2rIFpˋPD׫D4emߝ4ju~ (!Y:UwM̯O 8ͪ~w$Λj]Hj!ʜlU Hp%ӵ9k_a@Lm 1wQ οۗ/CGyX,E$3 x GZ* Jd(NtB=#G%4d#|i!=MS[M(e`)>]TƞFwc}t% D0ɪm9˚nbg?nio.&oMq0p#)=")%X!M~' a19" 0G I::߾pMٷ&VrօѮ9o?vP՝{opvS&mxEoDI< M%,ᘀra4p0&Oj4]J(V ,r#MEqE7+D#Akc#ʐڡ[k R81,!˺Ug K`jEhvm7^C[.BFv&3(B@XD7bۗ="T z%pu!6)@!g AΝA 2|H8J42tql]ÄBBouBbY{D~ȸ6>~ j#^!J-I婾ԉvHb3EWS OdԳ:p\청l1DW.MhN}fa xC&NDHA sŽX΃oɼ&x|—!Dj$n;uY>\`Kę[Mea1Ϲ!%y(<\K`-Ww~crTv?o3 endstream endobj 1800 0 obj <> stream xXM6W(PEbni!@lZ[k%Gl!)ѢC{Mr+eg޼yCB H(jL HcM]B0y,_š/EK }8a*]dl 'I&aCkba0ogӪkn׾l7þ}[)G59`F1"k}9kLSdڲߖ,t̃1XE۝{lb%*#%w;RXʴ=,rqv"UeL+ 3DUE|*jt] IHc(. TBҠbL0&ǾpoE?KT{3F4'`'l"S1@m2X[ /Nyј6X jƾFi@"(asn* @๘R 2!Op̆F'5 {oDOф 9ۇ =j)qS8gLTcL?mzclA5$1vWKfv_Q[TYg=9sH<w_ۇW%XZ7xh0y ̌ܜ%mYuOJK+F9O]1 rq&>C:g43(7$NG4{Ly % UF-b:<ĚsD-d9>jhrT plvͭP)="(f7S4ܓ!!q9U<.OJDzBO''ONd4}ig}Ӎ;7U}C # Ki"2 BsZ@C𗇶FZhLҕӄ<6b/l =f ~pqI UFaG/ 8^fd~~&WDq%ŧ`4dQ=DNϺXh? };Ca7=įx|yg:x f{ '$= ]yp6XZcUn.BHpH߸ذmc~4o̢l ,^7Ļ*)%ׄQB 0M1~+rzBr gaZn%z>^t$. ue čaM{ijÿƃy endstream endobj 1803 0 obj <> stream xڵXMo6W2؞MEݴ8Vr-;$%ŔJP$my|38䏄$~H(dMN4!lHr} &FnL(H)OW?2X,W7WmU N2dmx@?Yu{>$]ue eb3H8\$Y!/Z]nuvg_*g㖖e`HJٯޒ0+YRC.Od+o/G%’Sg3I I(  FD>nq /|/mdpArC^p͂P~EKr; ' hC CBtE\GLW /*j2;dlM[1tDmK/z&#R~i"G3LAT̏-Qj@ ¹LP:׫I99y2o;JFCDzHŜ"U@af 5zc !00kSheH#cdơ[8E GĿ ͛GJPGy}m2ٕȱ)2˾V7r:i6Tb`̀p˦/j[vejY/;1]$/"k@9z#)uچM yU{J#N mN=}:0(#EބKv/62H`tHVfBW=0? `u4II$k|Fj_4şvfȣ Aث;4L[B$]mJ!4s LMm+4:O܌IW˲*<>W„+ -_Fd/$ABC={m*[gwF1AG }GG곃c JmN-`UTKEqH`݅Lф L9kJy pido'Xx1\NWXh"9'WAp#\OMΤ% %gf GH&K B5Om# 4v9dس1iܵ > stream xڽXMoFWHzw6R9&* EvR\y)+)P8pjf޼7̾d$C2Em:zO3QK]eDgz) _׫svخoW6~$~Qʭ^'z1*x4no`_l HPD}U!(5}5t]?kvۦ>O9AD\ Q㙶EP !@(6H%C@ʐN(4p6 JL6dT$8Ç1;|'$ (\ݮRY`%RIq"%o8(Bk!H">tL"aG$#Tjמ?,e0+cb1EID$ R(; ơ٤lAҵSR #?z)=q )!sO%b% \HgfgN (,D` MXQ2Rz#{]k$` ^)/8:PC,{k'xHZJ"& ]G.=.Y8~k7KM~ZjaZ|K5 ^yz3֬FтE\$sp% kw`":1eb \NI.T#Y>"`u**b#]o6'f+!\7ˡ )Ֆ2D >WѨߑUʪFˋ:1\HBVƙfw-汁l)+̈0-qFѰ[ׇ-]ײ8)#}!qWIfכK.-Irn/yZ^{C[9uOih_T/ 6-960b^a_Pw'TUBV|acT({XY2.:Lp,+7z,((aTI6wsAh*!')~Dh$%犜0NR*M%GuB(g&eS1t^ZZ)GQH c3%| U|{+z]Ly.ui[J8%ݔ'1@QKCr%7"#% n>|%/ oj"6%yLq";#oUYi`<>I~|>WHa˼:gJÉ>6YctŀZwڹ}6oMgo@hf:*cPd)IyoʑhdI"r7P 4Cq9aCE#A;I M]j`|ra2S_ x|n]X"7P-% fx蜠\P[fei4EU~[~Չk(ٓ9G`0lq><ߊ}>Б7e4c:6쁖 endstream endobj 1809 0 obj <> stream xڽXےD}+T}H ,ġJk[2%)>d;:!2>}{"aG"EG]MF$HrE77ȳ͏e)k٫?$)c,.կz+sewOIJxy**'(àۨN{-)QFE(H$MѕuUlT%7IC4OzlD!ɘu-B /{Cx)#Hy2g" $ .tX֕nb[~W[! ΍EY[w2wqfSl}4d[4CX)&DX:o*N!̩_BR)gL('|7Qcl645PbЅ/Е r.x&|eS :xyCSpހ9`dT]`L$.DPr[~o񓅜 *W`~uwܗrͼr@Wbۆ]E9Ca0er0&ҋ=P`aR`qF<,'tnFzfǚ)T<1f9[9m16-q[ua|4N?l K9@MMz҇N X0^~nWwcw, "gC}?Y k=}㙓쑊Ix ch-̈́=%<Ѝ?nj~_# endstream endobj 1812 0 obj <> stream xڽXK6WV -Gr(m^6vkK, ߡ(.핍Mv+Y7%$0pc|4I^ 0jd@Vd>y5ծʈ"~)e͸I3]>L~M$(FPY<}Ff"-A6t_eDqWfz_sjM(*,b(7XH \%714Ogcqpuut\瞡`3yB\F벘m)FaZ-2ܮA@Uy,p%3~ ZXΊpuUUV|hթAxM܈] ulIFV 7CJXũa]`b$yjq݇]e}rDT;R?B/ĢK-(qKxʸ~qk{PQ2-Ɗƛ3d+@D6V˕d mTj]^sb MM{oڝpBR \ޯ]+o^dG_1TסEWP3ioX Eq*D~}"Oі}"!1R#kSPcdX78|TOs̊Lvde e̊P}~]=dF9H2A7,+zU| } /ki>ipKЬί. ]\` H(;cank- =3Zfwo_o2O`%o6izGw4{3oJE]THEޓnm{!@6cvq{SsMhũpaɪ3§}Yu7b?M7\+pSpў ic#t٢N9x38Gi6wͺXn.S<úB {ҷ'ʽ$?nb[ endstream endobj 1216 0 obj <> stream x\M7 W>(R=E܂zj9=:'`0il#{r`QGj!CD!JlD ئ -P`QAH - Cvm1Y'E =WiL(؋2-Sgb ]]:I)inI)'^?zg;?ڕC1*,4TT% M9"Pї9aLl$S: QJ 9Ԃ%9JBuSDhaIpQ!G+ 8l,H69ނPs#P%r5Mr$hR=Wr0N|h!dJנZs]&j؂I)hK/,0Lc0T &VL_:Wb"$`^,B\Ir%SZBࣙk9ȡ5k &cHL|/ i11@oVzFL 1)>$c=j#P)$QViX .c#6y!QhL6I6Ƀ(U{F;!SR:Ғ-)52Sc;RR%#z;ti`( UzJdH6Z2d3eR]D6FS\ەT I6vwJӗF%5:ȩ2׉{\)Gy40#ӡ`5;h3m iMM<kr`,>Dkmdn-WJOKtk mpyL!7UXukl,RHk(D6'RE21x6O*Mm"4g ,$gH@UKΖ9M4m4f ֪yv39i6jMuOƠI)s#Zu$5c!]33!(i&RLl. Y$G :. y$G5N؝ $#ґj%!hB<i i*IH8ëW?HU(~yxh>Q8'DA9w}|xϟӿ7<>$Y &%X}//sW=Iv-|sZ~[rVfy{J`|=>Pׯ1fiK}֐\.M]2e-ͷ79$IK`W5>nϔ<8 _Ԃ#7k#@C W5"s?>'foS>4]WS &6%6o70nT $ L!vJ# {Nώ˕ p cMZХ9,SfDž$k/Ȼ̮C ե5AglMF֞q*Yl+9A=$ۺ?.ӌ]B2Z7bcw톜ǮB[S&p؋_P%,@r)kϹ3it*L6fE NԎ[*Xυ^\B %}>ٴqNwpxPrvc^æIWgMK;r/IGp?g} H0NzF뭄Wi&W om{r)}>°e?@}q@|hU3 'gVi/_KBϬk=tE^kEۦYװ3`~[q)V[;yd5k,}Vv*8CsN>bĜ]2K3f9zW@qfp8Gfho׍h3[~ .]Uٳq־Ӌs2> endstream endobj 1815 0 obj <> stream xYK4+|""VN Y3]==ӒDH*[;-[MH$/N䫫Kr6!:! \'WSꏫ(Rvū߯2XZ?կ~u6DzoUFuoM*ݪ^!1H+3P aΝNEVzP{$3mlYD;Пn6wE_25OaV=*Ӳ௕iQq] 7?fךn0xѲ+j? uѾۦNL2D10Dq* !Yz 7?<7妿C76@gE <`yef 5 _9;0p(o :l 6Cat6@ aK!9’L|HE "XG QDfHO|$%Dl-# TQ{mQ$4,-5 éSǒ/W9^eS_fC"0#|аy㐸T@$H"DB!3r$8`35V-o&SɝqrHۼh3`' %߬]lcmqUikZ)}gVTpfV̓nŸM?ZO;WS J(<>uF`8r~bs}c{/ų4 DbÑEzE }G77vLEߴ]t+(G+K1Me^Z+_Ը-X4 Al8d@q=bcрEM"Dϫ e ?؏:zΠPh]YdolsvW/@ ջfG :38ע$u%OL ^!9pC,ԜvHԄ,#G4cTI(D"Kq1k.IQ `9wubhS,&?aFy4i +U&;ǵh ݹأ+?_l@Jŋ{r_zQB߶p xy:ȝ rcr[2/:H)7pJ&*92gS&2BÌQv> stream xYMW!j`E 8l8<>h53J$bQj;`EOU^i_3q#2'/϶웛2}&|&+nv?zco T.Mο?6wa_2- "~A/w/4̖%BǪiqϱ~.또2cЮdv# z=Ϳk`xlqJ}k>6ymnx"#ȔY1)B0mfq![}su+֭:T66]jOpeZ^7+raN6rRp ./8e3^+7فs՞nH7`I2m8ЬL']S]y3= WZ%~SI/죝8aan|:b|>":R3u\HIj|hj_MsOn\%O8$^m۵C3@|lzL3C'w Š.fKJ*|9٪i+I%rAZa' Cs7N`SC %=fWG+Xx9IdD،[m>&5cږ.{ʼf.x+CSFgOُ=ѺR)H%'@Ǫ'4T*.v@yy HN-C,13Ø:XK6o$i⪾O=2!$Z~12+ew74GH=!I.BC[9u̸mOz1mG;hcI{"W4s.BD8FpS\=!΁uR~;%$j{sUxwq`*a8-4iڭi*^$h8A(Mm233㯳3"s8@^8 C]+妄>i9/Ğ=}sh3ti15j1mz(G8Q$や1=0R/]4J⭜eLZ3u {-s[˽6މ%( JpycCAT{b,Oo!rYnD}F,bti5 Ҕ.cu8FbAr{P= % #uM®c2 4]RK8Nhs} u~`phX#E m MU _ xm7ML#<;dWA $Y{Im}DľOx ̟-:5iD;YoD[~ϣg/H|"ob%ᒚgJ/J;6Μ4sk$Y|sˇAT^g\mBn1+ .ʧ!F2ޠ7CՆT 8L 54sM]:-VFyn!(iRϟ#9yj%~QP$}Q&æݢ~I:H:|4%Ykve\%G_Lfd@&$9a.Nxɠo?[8P|R(i\+R7[U$fxjBA`&P.d6?036hgZ)0и[.y0vaB${9Ln~d~܊7Єi1}q/PC|aܚWb=*<\۾ u,R9uaDN>o]6u6tMmvZߵ/K\/s~U7ȩL_2B/5ױW}j$jb,%!L}l'JaD [v2NT,VjY{%b"&Kήw+w1:$`BG& _vv^^)a!%BA:_utͯ8}YD|sx,C%֟~Uô; CpH$ew @ endstream endobj 1822 0 obj <> stream xXn6}W]W]bx-I/.PAvG,:MEH݇DÙ33gt;8 (agv3uF3qH":?\ɟ( _x17ί\eLN<:'4p+գT x>Eϵ꫍^ ._r.xg X@:ָ[Oiuۧru2%AVӃC%]|mDCDBu ;oFO,Y<rFcgK㣟/+zӚHqIA'4isX J iF*瓡f$4 F<{krM'B$_&MٶP(,XcIe1T) 4sYybG{h20sA#߯-Wv(|UdFG"_v||{}/jT"6".Վat#v=͹"j[XhMc3{Z&(W2PIJe^Z@De"튺c!Vy, ]}݅' u炩p}M$.A6b1#F'WY63z蛝O"~#!41A sN_ !P?>9991FgIabnfi2vc(k71Wf6xn'?܉KԘȲLٶFV^dȖЏio_+P/&p$aBrJTFF>}c~l]3v@ff1!͘`y3NB_ڸ̂׳2weUm|\/dffGQ %˃`њS` rihUv:G L0.}f_fuJ?ۙ*/"=՛%sv {tOռ3o%1=3Nwv푙(L݉tlO*O' b&WM+o>ƃ}C z{VT wmxw,Y8)4ь=J 5"kߩDM80ٴ݀6L?/LG  2fFςzy ^R7^߄-QjEFPu3FRX˜ϜFj& endstream endobj 1825 0 obj <> stream xڵXmkH~Bpp$\ͥRkkA]8E^Yr%9i~;ZI;JB}fvQ0(rZD^ӈd$Z#G%sG|[c,&l8a7Y|=CWvmĉHRJ1L>{ͦIBX"Kgְ1VCF/( %S<+Nϭa.V3k=` 09xj9hX֡ȍ]!$%l|ÂmXvD8$ Yxp ^9DŽ#~5E ܑzܡÀ&sNi.g!TSJ(3^^yg刢7 ڤ IQqQJ)j=pc5 ПY#cb 3dqh FY1:|y?(2۫ɮk>Ba̭N6[TCoKLxfRtN6ʮZbMD#%4sVTa`q@mS3Ac{ZS12˽YVeɠG$ z8< ThԄẗ_T k'Êvq븱<ǐ<7a܌&d<$XTM,fRCJQ/s) Q؆6 J6rơR| ˒|(UU޼a;nõHINXS"`ѱ2˜H%uIdGr"#9CbnQŘ(GT̄4xؾWidig* Km* 1GifЛ'D m V,_CAq̽ܤb+MJspnJƽCq]'fRtVPod1hX C'Dփrj 8v=ƎW8Q *j8 ]GHx%%C 25OBr2Q)6c& ld`X.=TGy:w}k* L5Vy'xJϙiەij51 MP9r@ M;tqҶSrǻڲ.9'Kj^|0xvZB2hA+p6CV!-@Wܸ-]A.Ktbl<>]'Iwࠧ0S@l `]XK=Ofp ? y<B~.yc{5JݑgC)q J'+Ա針[ciO#3gfkdUF}s ZJj_uq^^]ᚬT8 }ݯUR9_, L endstream endobj 1828 0 obj <> stream xX[o6~߯ ;žem2l AD-f@|EQNt؊5)>D$DVeF#5wI#i\_2b>=Eb ޔmY1{\$4W)TM+%0趪%nAK$+rc%tbSl1>KcM`@LAc FvQV3jx5EmE:hcYuì2"H$szSu l*{Z*n7&^e(eN'cA\lN_xd08u?اrYwnK{ΐҼGkI2FE-2M=eVSԥbJ\8!a@4YE6 ) JMH<I-q@I8MVoh_Ǖom RzQF EÉ }-h0Bj=neO?#a7  Lnh^;1~&GAi#@c~Td~Q.hDg³?išP+^2YKΚ ($1?eq9_BvĽb04.K0 S(U"&DwstݛtX㦲2u J($-%.?4nҷݔn&O\'=-og}Ndƺ8גpzIKzP2`ΒD3Ėi+se‡3 4E2Y%`2 դE`S7M2tP۽=>poR;$Hqip䁝 uvp `@!]yۮ+%45ztM6vk1xOzW?텇i=eZhh _7SSAS#M)G# ]$ay33V7iv湾̆ T#!j8YVg~Nu`8DN3(+_9n!2ipN٨i=Gڵ# ÝQ/ G'5jKsە·N$<(HJF4Bc~1Nȳm>j$t,6Cb?t=@V/j&y um endstream endobj 1831 0 obj <> stream xڭY[o6~߯X.*}a0šmaJr`~/R$hQR2uKD" HR>zw(Qa(*3e߶^$ЋE9? ׋u귈$|(o\cdFa!E][^otPg4B aI_7(BQ/qIR)a&G4H7sSZbv IDe%,&uͪ.nۢ*/.BR1|1j()4ׇre5~%mBvv&/oV$I-|%QM$%)h_dg_`$8&G<)~x9b)┟ bҳAbJ9r:CÎ=K,T,5I & Ѩ|vw@ >!e>ezӌE6O*߹ʬV:w^nl!I6Ym{]M0v\ ۼuZkk!aL7Fk77[P y@뇅>e9Cn+qSn&$,ʍ{[ݨNv&Ș$i~#LluwqK-l+c,.{̯w16q"#)/7 nz(HpYe8Ņ@9q0'HB@zp[48cP3v=. IŒ:Ө~v71HAKLܓԹB@?L6ɽ<8'{eBV&6^UށF?ZMvW`$pxH$ U* >[T܌113hX}!q`#tbQ3LID\c2T9_BN+_ bJVr;<5lگ', ~O&8`'0lO4OO7gpI_3O W4gHK~)]uθUb^+:83&"}l[t=$)h9eӹ:ݸ,.Y&Uxٜ{g'[ lI@;tڛh{/]@``w-Jxz]$vv} Q3s 'vg>O ||JHS9S6 ZIBNo܇`HJw>7b2M݈ eWAyL bE9E#DD2Y*6Z_F/!lٹ sC"h6'el*K߄B@?M6, -ϲ{铰~虈"_v,'LɱpXd69L˨JigiiM*>!&^g͟K&~@۷onȬvfv^DG2kw91oY|Y]g#fG`u6|Z7Uy#{9{.9(Z? *6/7L>F>%d80a(vkPNawwܥw?R9MTU?1Hv}H#-v<&Tafﯢ>j endstream endobj 1834 0 obj <> stream xYmoF_a_|^kS@(RE/Jeű#wEB;yۙgfgcD" ?$~q4G_҈`D狈da(Yt~.Nq:{:")pէgo_X\W右uSw)%4kUϨ{#K6UAye]f*^ /rpDہɱ9R9b⨻Usx|mR%ϖVצi3/'T*؄9Qƾ};=1> stream xXKoFWf-7;$S@{0PD%PZl2Q@|gwI:cjw曙of@@/ ϋ ,V$p$X| ?e&s;b!DxGLQU}]Dq AE]D ?$aof].$ `&$Y;MgM~j\S]V,кU* ˳:^M~f1;XX RCwaT1P ,I[d3#>?!\4J竫pS^mK&B0UԝW %B0.~b*m[e:A=-4U;$%D@O8 %RJ^sԱyp  79 (7֤s"nZte绲 $z}kC;{UUVr=@,1h5#Cn!$l8vZ<` Tݙ~o)nG ltv!vֺGQqqMP׷#yV'Q=n OFWQ0QH$ ' aԋA`${:!xY`nU veC.lAee H=ֿG>(P:bC b{I\hKX*~BoC[#_͒C ǹ-Ŕ }( *R@W̸|YEĩmb\D)biO: 0j8{N/kU\bAd)\n[qڙ=2ø!۴,}^҇9_:2 ?X+1%:G]54dr !r(Z۪<&żE RBi®2UG$(Wnu]#"+lشJ).m`; k U`2 bW2nřdKY挘-_'z~">,Jcx~%pn=SPc342q~hau4)X6|0Wb ~tqw~HI_X([f8=jSgYzbriġfkÈBǹ#$`A4;'smc'Ċx}h':W\0psU?n;YALtؘut 飭苩}c=l WSB;t 'L\tqH*:58lq-^W ʞ!W!/r~⛆!׽TJׂoQB~?E endstream endobj 1840 0 obj <> stream xX[o6~߯[eby'=uk;l(lH$uË,QàA,Ǐ&%$!me-MF9Iryr͇TbxkBEJ1x<}uEK]|mjswesO_7t-Uiog}cl`%9҄[[M_t/_TdD!ɘo31Lq-|¿*J(S˾K*GS?|c:gnzs!ӶصE/0KD0KYBt[]$HqheU kBӧǦHQ\-9)d. ”f#sh؜@S` A\ MLFJ2ܛ%dGnP\B$FTS.(0Hj@f1D"g^ 1ftH6|r$!ƭDyFPh` D>‘఼mQ/&[e'K`$!;\нj6[3&Ӱ,'+$!;(1J%Kkl>(#CD2-WaOAH!,O369cD>+9bV7\^ݺ-w&OW|Whv_f^A9]ԒiC!B4`6EWne_l/̆g~tuC4)bA" 0=X Tvi|d %H!_/.d`P0~S[LΊM0cH `X%R /{5&A2(EpW!pNG8Yt>̷Cs0OF>4' νLH@2MN{'i< 43,TPeOը&QqcZHJBk$cYM(ЌQN:✁c$\HWf w>QD|C(qXĀGAXűɴimcMy*T [&]#hݤ+s۴v6b:iidH0dՂ]ZNnZc>h Ҟ[jzܣLƅۮN스`j$K c_51{,'2<Ĵw!1˜WOs8`s,1>!C YDʏEzoN~@k(OuϤ㸑 'P'oO]ig\^a%\`sݿ}Z endstream endobj 1843 0 obj <> stream xYmo6_!_$,bN]  u86kulג؏EPvx w]O I0DQu\L7f9c,%Ys7댪"Vه 'I&(vokyk=oF\p7GSͶ.׫g,ń( smzV"`ؚz]URtp.f* 6sFIZm2S &80^Lk\ٴ6+]DZPқ)"x7I# ?<\+/:^L3*?2Z;XMyu@*]&84f]qx-mbc_W1XT.r,Č2 Œd b!OcmHl;`+gZ9 qNza][l݇-ñlMeVnΚRVQDD`,͵Yy&88f51tF"z8(ξ"8h0U/p `2#f3` 6CqDB#ܒeuipdd"#/1pfʑ (]xʆ*i#Oڋ9p^m'Lԟ\Pq!O`(Ɠl8Leb!]~:}[碞M}@?XDbd?zyc]`ȷ-&۝uo[:i?K=;cXZ!cOXD3mAXTx{˘16_/>#621Xbͥ=  ^wI< ޤ7IZ:zLXKZ,8/ (f]?(K N UwV~ǘ0Ofe ԛlSsi5VˈV  #$"ݕ=+G[Yc Y y T4!M'V쀶W Q;8fDwQYuŀ^UU^,wuYϭAڿV8{`%{bkdNeKס5^DcR$l܋@^fBZ2tQyw!4a#0dXy|-@IϙFrV"*?ˠڭfa_`,X\VϯM(҅jEfS wWm.9:ӠAO['fݲν0 Rp=^jʀ2WZf0%lun 1WCALQP.5*fn;+ۃ󞭼 P~]r_ h3 {2c_ шsK臨=Q%ZE .{ģՑ0PL"*u/c]=:of9٦qZ 9)E`V%=dw}GԠMʔNmKv-}#Cl\7_FzZT 2iLB5d#wCE<}U)4UD ̿`wnafYv1c(ęSAI#N5T# IqHU(͈|p/Co&Jsr"Eb.> stream xYYoF~ 57{Li)#EܾXyTT?)("3s|sh0#<.Fߟ#Q32:tDx::]DFQ$ O_}x;cQ^ᇳ_rX̣wEOO㘦tP&Qc>{C0 踕 YgFϟ;zWq$h2I$cz͗חErI^$pwH;I4Se]4UT裣_ xQ!Fp&[XPDRxy"v<:.OS fcJZ $3ݲ7^MxOOG\(9p6ĔGc_ʪVPhL8.% P#r14 b_'aAsD܋V"bM YD&&My#)I뮢,CR( nd׿ G!v`)a0[]PX|d!5& ddE$$Q$SpFј%"x3X.M,?\: Omܻan HL$Xhj%|ϮUBpe‡)O*&⎬"T7@z| ! gF9\+tEVP̔=<]l1Cjjd[l-=D3 .h dfܖFtDX]>ØPa/kV wD:Wn/1Ѝ$re0Wz>?Hĭx)T6HEa=4u_o򳟛A U q.=3jZe{̈UF R RL"*3/OU=O|`%vצvuBj%OҖ-x  [<*!ڒj^]^9EMzpyHQJsjUY[ " 7oMXup8ڵ̈́aҪSjTzEwU+R6WA]Ig=벘a (W=ݻ~Ӯ9 ɭ2ӊ[*͗ZmfaïlyB`jٞ)n4_YpPyey XBmƺ T!ژÙ98b^u4c0+#ɱ׽, J0>c"@ƎԤ,QL]D\Q^Uq}cuݸwv֓fAGef*t(TnyA`H_^ oːKTNڑ6*l'wց@ l %Kz3w dѡ1(lr=kU*ygH{mX~Bm 4sU[<4F1(ޅ )4+z]|>?Ƃçbf(uk10IDR&[b@dqh}ԯwťďE,b 2ƌdl3vU˅rCU\Sn~eOCVZ-ty b y^^uu_Y76"ʸB奝',[ 8BO 磟 endstream endobj 1849 0 obj <> stream xYK۶WTF#V|ITڻHvQ蠛846V-d>GP @5y|M&&8NJdsL~J{M*pru``*&}}e()&Wc,|\2^e)aa Zb~k@^QܮUH`b*U @<}b,!:3O2\%)&>Dr!D׷N+S>6iӎ3OwPL) "Du q:mU"mQ0A7uӕj|CQF%+ sgB%v c9 ".n(2E<5CUuQ kPT3۠#q#(w1۵Y+w}1A.֝4ljC_a7 e7lsJǾh-âoqUJgYE̻bw%阰GVܹ6.Y+9YJqf33g$%܁q{ WG{R EV'wsE$S89mjtbɆˆe/j5fR,9oCㆀ,\8`Eղ u]46l\,ݩHe4ftB K&9xq:ܷکۭJ5bWCߺNdNONe_JƩZ2O|1N$ X5g ,> stream xYKs6WpzfBx)mN:̴q{r%D"L|w&mPG#X|.}h‡F_vgW,)ӜFgf$Yt>ewg?E35q <.77 "lz,^wZ0wVWU'D$j.K] ´J_`vogϼ@9^K%TŹtqGʿ1Y=ψ/"$gvHK-) W0UIHvBSAd`U>YV}9 &WAIV*&F^ āb[~^jSqyJhue9[=RAD$,/Lj뮬i,4_Mo6H7k&$ kofsnj;)ʸ$5^g~,I5;!C`|み iRбeV[U4w`,NOְlf~G2Elbۆ@M5c]oG'`gze]_$nH&ьd2B ?P0rbd3eB01<'KbUE|J #=d'1v7sʾCqLE*oqy F a}6De@$ 3?iť C<}y¼eO{afs@k`hD>:NـfQ6 7u %Kr\UP8g2e4L1gU@N zfǦ|]_zFy2;OLwwh(#aPx*]ѾOlѲʴmݼ Y;e_wCUU9buEV:*&3Sδn5 9J9h/Tqs(y6)qk e* N:z[\ eO>hUenT"Wv99*jٚJS!ORd؀:\]Eb,Ov;]Wt+G绀 98k6uayx}n0G@@+\Ä gg$kƯ;gCYEaXj:)TU9W`{h;{Mԓzo{0!&,)'0oy#ԷB2^O{u5ޫ( _F9ֿ8UFr>bwz=74Qll )WC')\z `N,),!CzwӱsGrs& wmPBvᗙWɰLN]ۮn"AH_t\YKU|9/~h=;ywH+~nf9N}u/Eh(q q۲;kAMկjSցä4oAw@Pٔ67 =ܺ!W87Q:cz\5*Pw}nkPPS(v=*v,Ĵ*L*52]e$*r[{!0wI{sN٣g/ ՋM endstream endobj 1855 0 obj <> stream xXK6WTHS@6 ]%)C2^;H"HFofyPɻ$DRz|xCQ+>$LC/.}X&rXJ,眧??m3*Uj?f?%T6/o=g%AWI+Tndk'Y8T&2af1}=E#3Xl!NA:!p?Vu^kR -M=ߐDb XX-TJ`%+.#Atd1șH%*!#Jm~U&y/c0H@ ǩcSߨ^51m@ N)[iAo4i7*VH{cL+p]׬^ss[' M=,u)'Dzd΅kiZ܈G֒΋<tB,T_<>SED6lt #ȸ<->jv+볜'//VأkXPKo$р"睂a4 c;3S*`i{c#٫Mmȑ{=TZd aݶDU,mԽe,E&բ&ܾ=ؔb7iNmU?ܡ`ODQԗߝ~Pz& ,~niiq$-'c0ov;ꉼLzy5ȡhq X970q^g2-( 80ev23}eZjlU F9ZFю I9) Hj*s6{U/'pOoS^W֒JxaĖb{̓~ӈQ*G@`>s6ɛ,5sv ./)08+c 2iъf_KW j> }f.B5C<9OU0cשqwyi/]a\vP0mb^g7j=ߘ苡L鸮5+Mhml798(ݴZȼ۫u;emj=hQ8׻7,($AdB#lНJRUҭd 0#Ӻb)6F;F?@CrKZ4jSaE|Fm39lAYZa]oSvQ,*jT{,ӅӚ?N^ *>GWo#a2_fR "ED/9 3| /l3nQDKپ g9U+BzHsm .Wb?YWu7G WEÂP ®lOl)Ŋy4hJ?&|_!' endstream endobj 1858 0 obj <> stream xZKW9G|& 69sPn~$.T%ɦlY݀)*UQO+*Ꮾ4rٯhIlieE͊rbY=nVTf9N7DdeB$IǗAnU:!RD>!:KAޫ.G Oz>x+($TxOj[̙u))g471kȾ_f04*TײV ь]qa} FI ߹E](g 80Pe}m7÷߆Ę,@6{D74 ( v-`sܟ}݁Yֵ~~yxT~A}jӃ u8j)5)[`uv}I8R E@φc%R{/ű1 xxOm{~Y)H%Aێ :9#9pH t@D1$ꗷ|mu0ʅ' }[ 8s:;gs>h"e3 5ܻLő/ 6gWwWaX~w1ҩ\j$xX{7]RlQ`*i1h@8:f{8SQzwE@fqvbkW,zFK<5GüIQujjz_ų|=[TN-0sZ1 Ԡޑ(ݛ{_l,@Qu noJaooݶ9N4 غxa'hIR 1]!.""fܠ/TX7׶F!U p'B8|)/!B EH; D+*\9E6hYUpE4"EPdU[ %b˩, wAU7|6KO!w h LIR[)b ( DٝPce9B)e++M;'Hq K@ T{W% q|@L]NI / 5/ YItIp3!:C 6/*Bc睨qt'q~icӠs!]IT?αk0Z.o&-Z( e'67;m{4xYf\<=,US:.h0]'kBMtݰ~yN$L(kA>@D㔎!3]wwi9B6do2`O 0)hjB+R];4A`SM ;xRTX-<dhDƩuLc3Um16^#Вk@ͣսhS'r<"ڸ}c{NM6UhF)_ nj&6#;v!` yy"ԆY'3S2E*s*/k\l!@ylZ3GB`~sOS7P;8{>QvSᴸOg4 '>?wF[{!D;gD}7)jI3 }QFdOnr FjAu?8smAR4XF!)WV9h/Z5 d KpGC6BSF$Md!@JQS +T-64]id`k%m^#\kï*FG8Pey919-N).s[/[7Jr Nc9$`"iɧ<[PbrVVlВ V6fMhn)m.Q MӡL2ۃkJc4kt "8z&L&pe@1X%챼ݥOmTe7YPNOi$q}ǡeQ;*_5P0:rGB-)`pyqFDhT&a:A1 l2%1nBvp"Ka`Z Q$|"3OCHiX_s*T8~䛖~k(tCU)2%q?%TC/sJȆ َo(LE$3W*/YEh;S@۫#S&m<2eGɢ#Sc bvS=w [/`7$RLDoyi::Ft&rhT?ƟFИaPhW2|ZG0t]| S('ndt4uZ(U"/KMT*xL5AdNIPcϨQ3cbjG}}: k$\hˁ4Zrpz8k4Z;j)|/Ʀ_u.>#sz{+NPbP?@LiNt*%Vl3;? la2W0tϱli{"|W endstream endobj 1861 0 obj <> stream xXK6WV%mNMz(fK݃Vw Ȓ#>$Y6"!Ǚ!0#QJG&|}J#Qsݮ#Egb۫v0bBo }Z$W%]u9vvnhè\k^7uQu C}.`adeBWݡ SmTFYTՑRyxwתT]Wzyˣj_Bzڪz?"!XOk~c1+Uj75Ԁx^>pԝzRyExcԃӊ*^/я<#,z(b6SO&DTEߣo3 9%"-.eRɺjxr9*g3$e>L @aP3a$>'AL(C`)L9 $rRσeܕEu;p8/#E\$'Srs~=6څJ?8LC|i}픋ShJ'79cǣy[Y/ aGBN#y$<Kr Jk?S s[l[Ur9TZ@(C:NQ!Q`o8?Ƀӣ^ݫ6&炗 #23xʆ)\h:pU+a-!]ڶW[ڦ63Xߺs#u%CtB4ˎd; ٞPIOM^J&~tQ 8P7dhHtD_,qўO'=e@oOu jDQ^hP> &fP[98W{\:(O.GJ@J2Ke2i9< 88?<> stream xXo6~_A")OkyPl& Kdo?~GErvņ)m;~w<~CF2 ?$S~q6_e]fO^ь`&mFʌ0y].rInj2bwgc,[W]ƮyӲ_o_|2͌|3x}X0 (ר$|"|VIڀO%W3m3,;d IO}ՙRٮnf;D&vm:TDκl7zpߐ7B%V,p$̊:Ҥ#eI\!޲}&,U5ӧ$"20wrG9bF/"Q)(%%$”e>r9䊜Cil Qbd'$HJ‹E),E/L?CJOD8)x 0oV :d4OnH2rQ HەNliFA?٢U(׷4)AZ-c;vfq$w%;f5fa?|so]2_U{?̇-jxhOV@:{˛ 03}[ʯnn5&pWY*%ng!&H\ Sh^J!> "*i7n1.9P[g`IImr.W";;S->Q goewC=>[ksٛ FJ Jo) rg?B燧~O5:PV=!J}p H!$#,Gy*'C/$#/?Vu=RcPTwWs<;)@) D"甂S߷oHI%ȑH. 57n@ cXtGۖpش=0 &?*0F"SD*r 6 BQNۚNP8 ͇8bS f4MQ)QV6֤. mEH3MJ9wy3}pgU/(nvs|[InO3laLjwqgWQNJ8^24TمeO&&}S6%`}cDZJ@> Vq*S A%5'#]=Mq b7y$2Wu?m#2 籡y> $SZ {3|Ůd?Ww 1PA<}-R cQ)Y'c7Ārz}@]L hT/͗/2>] endstream endobj 1867 0 obj <> stream xڝWMs6Wpz)9"cC:@[ŎH"@AIþ*'a ,1hr$ny()iɒ}Š R"쾤q,Bd2dܤYS}HF͌{#C< V,I bFHIrf`pU1TZ nXAZmL" M(g18-Jpu3 VCNܖA\@X,0'Fg_FHQ2CS yQO!~}EaH!U{}$?9 endstream endobj 1870 0 obj <> stream xڵYKo6W=iS$skӤHQ( {e]Y._RklaQ5f8F,"Fׇ觋{1J,, Vb9N|5|OLJM"r|-VCUZƿ{sIy:nZIG6&[Y{J9S>$2Um9G1bS%35 ݭ4e[\^zb %R8j'7j\u zQkٕ,>4uexrdJ ̩> 1%R@HIpnHa*0x#م+86tEh܂#,5*o]4}<諸;k8w*pG+džӺLcg2 m:SLA*k () Ș9%)h773[СrT)PyRcKX `BaM |,蔾9>\1ˈaMXfhH]Aظ+$X|,ҔP-⪬P|ȎEc!wZȪb0M.&! dwf2t9&rno`)gۼJ0V.vnˢ"z_y £ \6JŭpkBȓ,/-]wm Q)JPMw|}uSN j@x{Wݾ}%jI-p$OUϳb"s9K.aoW]R-1D ܰ Yϊ8byCaR?yӵ@  OJ` Fͱ%.3õz ~~+EX)V `]+2zMJkȾbQLW~ˏXű3Cc/UEp,:8=7'/B2N28}O^ g&LsF#._ MٱivkPS`jrƓE:celKc rN(\\*UKt_I*9U'4UIEr Wc\q,ڄC ' (.},'\z~i]ЄmD:=Mɍc4%A7aVVF$w-$q}kϱU|(J7K[*F`p-@1ј9 ף՚NӡcupG d'+?3p*x8 8"ޝo$8N02nBV#_(onQpUb2s/gQ(5_U :< -OSheǡQPr–Ssrj1rRVٙ9ǔ\=H 's' N x n*LӮJ Jn(="#c(0Y(/D NǪ7o:Q`=gF$]]@Z2#怤<L3O<{fg~д& \!->=e XgQ7DOzicE޿gЁ ]vU:wn"5d"Ӄ9 endstream endobj 1873 0 obj <> stream xXKoFWH& ͡(z}`E"U?/W-D9;3;oG)HF}:zD8Eyh,,ۻݮ8]%U:WDV n!b#A 7֗z=R QNuż)Djꐓ@&8oԫ-J-қ!zHO(D"̱H!_t0(ېe4N=-G98c ĥU^Xӕ}QgL9|0\zƃq;a:&̋އH} )%tI;W=<6mKļ;ʤTo<4eR@CU5ZJ?R;E.)?}{T8}ީښW^moCAK0$0aF//-5-J]LlY }ɧ8a_ o/7S"MgҢ& A-^&Qmh %y|eo~W4?A5‡z0tuUEiYܪڪzˮ %K^xHƲ98"xI 3qMT[6. 1 e@5lVclw}03y__0B`jEqK\"AhxӟD!N6Z'?A+&Z%0fXp3j>n>*Ze<./償WAg]6N{{0}Oo:!SuzA 7ӛ}񻝛}! (i@&4LʀP6jY6؀td6g ,"&餖 9ɥb R9ag9!\dZA6 EU|/?:Ls』*@e 44@?ؽP?SСxR![X#ys ce7 ?>91QDl3BC9ATЁh_4v=< fKjRӓ')nK a8 ]8P JG(;[òORse'1wS 3tG")&+}q5o: /FhodI mwd,LH PV8G(J1–L- N)=T+龠s,H \qOs4:ϡd s'/VuS]WhʯϛkGn6:?RM0Ґ+ɡmɩr:KWVI]Oါ񳹵lu4A+~T z%9ܼ)]6C;)ya4٬q(Ԃ撏.njp߂@q"K@GN%Bb]X()Ɖ7Z8͋jsxZE_2Y6_WdG(K*0\| .}6Å"?藯3]= endstream endobj 1876 0 obj <> stream xX[o6~߯УD o"m2t>2S %Ou~琔m%CH,:a\^Qьۀ$i0[|h-k\wQ,j?Wz]W8/eqo(iXlצ;fƭ~Xf$euSw}SDf}8$Q(.ʻ-*GM[ -Wu(p ~FXh>*jfa¸ory-*&J8g5AuB|T/*ySv˵"6MS75D.G"jZӔ]GT%J-$T+joewa"20>¢zɹmPS rhE62. _?(K+Okźs,˪\5TᑞÞNCb=D-$2)zjgS5{_{I3²%L{<^VʗUJ8t]l7ӃzʁvlmCpoAC( e s1?7XU}&ߴH2KV;ٲ=t\oVNP0.t{7/{0_nil?2hv ?׾1>JT "_ĊXT|enbgx j*b9VjcnƀU*8ΫLܖ¸`3vlN> stream xm=o0|dG*qCbƐ wϽ7 R $3`x3(N.{oʔR25yTHYW  OTLvwIOI)su~x0 e*EmȬ!<rizjA%7} 4]8M״T&ij=!^Sp2ײZ8 :)f 085Ӑn>sօq!lrtv+1Lh0:YM?8)XR/u6J endstream endobj 1882 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1885 0 obj <> stream xڝXKD+F<n#@$X^OǞ=Iyw{MUlUlm覀tS2+6q/lC RoDqTBonve7I%aT < *\TDSRͥbC=֍5t*B% w}tkRf1' IL]U3H~ˋ̎)ݹ{vK25JRhN<C h^b\DAҢZ%mszhaz5%X-0A,O+T{j ,b(t\ zVTDuә}}!F(Z}BɅOFK 9L%w(ed/24c{r1 >ZO1<Ӭ$bP>3gWF2H]-Tn.w0M]&pi2&TX׮\G>O} :^.) !oQfx=PUu(H5`PUӶ"}3 P7P% A^" U5rK‰)`_)*8y-_Ww^]P+<G  mQ O?eu4|"SxVq B2_e&3q"LF `".KPl H9k.KK@:wf;K|+"K"\H|z[eoھ !> ȕQ8=muhWȬJ-1hq4iD Q z[0uQtL6Ն7=`(n!d> stream xڭZKW{ 9|bnIvAf:!Vd+뷊/KvOn@L/ ?]l??.>|C [<,X`/Yf\h-m|?Belámp,{vrs:͊`W]sIb- ətþ=̗þ;ӓ}j̷QD 2LgNv5ЌSsVn}`[>Q&jڦp,깪{s_o8ojںݽr|p`"' *,;MD2Y)l F-ñ.AC6΄ vY_NUWnк/ݠh¶XtC9EdQq`t>ň$e7ݶ-)*+>+(!&rCŠu,ܴ`>~N ;l]TYYKl$*"Cv˰.){ŧ>S9a9") FDܪMKU)BU$˃A}[Y6KU_lRDsC$|ݶ, Ǣ+8^fUNl(i\iO) Fa#E]hCZ/?틮 VZ-YbЂs$Na]%‡p݇ۍ]֎R+C4ʌԆN ͂78Wz WQ' W٥he7y0Qib05Oϑ^sePJrB<0:e'ÚkM:%+Gɮlʮ7w G{ 8ږ6}.ˍ{:7 RvpvKISSݠOnK FM %J[A0)&-NRecxt91T4snU7۶? +~۠^8U;޺c1$c^H B]v'q$\E-4N4PGugO~=Dy_L 6`V!)U_$47WV~t`&'e*G,e9J^Pc'gC2gs 0$>7$0#ʧQ`e~ keJ7*-0n&*SCx ΊF?Ala<B gY cH gX2_9B!ZE\hۉa ۄ8Ȍ8uYpjA!bp"' 8J'wFXa9 L!2![05`GNb,Q3u lPRUQi7 \B2J>qs:,^RZ7!F%˕rrD$ʑKgDIq%(Lb)z#k`A%wź IYj6BD(H{}h]P@:֟Vk TeDFI. Z:Wy:"fa?so*N.ܥJ)&IC܁aBb2">vM$%EptdͽuxŹfzP?~NwZSSKX4#g j7jMҥ0+qj~E t7 AlScK>Uu#9m3ZQ=aej@`Ƒ̴<6kIJ"J6=@$3qDhȠlVy߇EAp֍< <: 2Dvxe~4Aۙ ϢH$9WJ- 0t =Tbɼ@~(Bj,hP~EĦއ2 14y QyIlW]W-$p"7 l\o7*`, 23]U?;U ׍$ qߚ&CKqK#Gi+e ؿJBX5VRrVjo+#>CkꞞ؅(܀OYe{.8!H>|{L;=f(v85'Veٹ*X8Xv6}pצ*rGGIZRY=bsypz&tV P`*/~&|Vͦ>mtmfF=Z0}aDgIa瑥=(H>.~YT}hF`;lPk^|^8 D3g5:=vu"9X:Y b༢O JhL(la{8ʺiUmryQFݾ^, aHH* :<6CYCEjׇ Jkȱd30DRLȜknU.>76XV!3ibԾ+կ3e i yoK,0Ȋ|@21+qq\=Z>mF(K%|j'8?/As@n ism,z_n7^IwQ`{$4A9ly.k[Z5( |.PLJy  PS0g>nBiυviPZC&Deo\rAn09PZ?swO)gWF,;K}=oqW_{rhmyW0d~~ endstream endobj 1891 0 obj <> stream xZݓ۶_I_`:}IƱ}ikE Rx>/DAX &P&M*O%)MYr.a6a&WʶM/3&}{of+GeaS2192$O;{1aԺw-t-hmpxɀY5]̆ρBDPm{t]盼 l2;pKywfh9F:<};9Sd zK]cwN󂓩)Ӏ ?U\e0-g8 sϯ >Dǃ> IRƏOu$:e~*/J-/SΛ,3/ NFX|Z][(/q= DcBq׺C1fȅpA*QIj]S5wkN]1{Gc::`L5W1PN*;.O=s (x/(A-PKC=W(~@oQ\Q(g1:B[K(rPGBQ((6(J-(v(j =;Pܣm zR"!Yu5DEKj_)G].6q馔Xň1xm{\9ٲ"}].⩑pH#t|B#힌 @ы9Mݹҥ(k&cp"ZV1s8d֚ieD(7ιbHE$&峢i0duGgn!8a\E,^bQ@n<4u:hHV88;XS`p1jČ }52}j$XgE?*#n<ˌڰGp8%JtYg=H۬g6\e6혍#aSPKS!X)`FaG+xjzHQAW BiA!Q$XUơ{, Cib[ՔRm7|n ~iJXA!D1Ze4bKM>ǤlS8BWsQ< a*ES-­-.6/B\eu5v|ڜGoÂꢉc!TF8 :h,tqYndcr*[a[aXӐ{G^ؑF[PsϨN8)u@XL0qek H• ex_,1n(̾>_+΂a⶚Pr9bqںf<ܝ`c $VN8I8nV41ʜd;e%]gre? އ\^VsA!tC'.l0?0ʱp }EkcnY{#Fe<˜sR1$CqAw 2{T( ?y~sH/ biY :䒭/ x`D, B>!N/Wmq*{tUHԵ6/zUwsDnk#''D 7XUDRW1a8Qi;I톸R]ѕ~4ЩvheLbZ ?eVđL5-hҘBX N 2hQ؋O]4 u΢6.S@3N6_zEl] 9aHlP O]N寴@~ꍎ׽ˎIeSuru{9>Irhʌ&VRr_M7ՄpɶzWYbEn N*=HBV%ےgnM5>ؓpYlk6+v2a|vݻܽIb\ۯ軇]N%9${pt:|Uw endstream endobj 1894 0 obj <> stream xڭZY6~_}"7A/#NÎqyH7)Ǔ_ 4I2(٭}|}@36r;{t5)1J͌$fv=\n'q,k7g"Jy,XF?g7r͊9ƯS6z 1L9#Bi=| *zNtdUݮ6:-XL~u־/qNOc+Mo(~V|Gu"u฼q!D&hoaS|M4h '*zq[Ol)A۲n@+󢳃h$1H4R{4`Z<Ŕѱ*Lr;Jv"xо!o,cH 4Z7)sDE@"($I I΍ ?Q.՞ 6xJ6yY,V;duco&7A2 ũ3ݡY 2Nke/`6,>KbIYC+/2DRZj^@޾l\!NeyZcC%?kAw 현qN1/Hxs nsP䅀'{(0som){(`'|9 Mzӭq~_>-s1vxνH t7Z!b̶0e3@:! _"('Du'=/U\DdHF8kD ,iob$#Zv]%hOۼiuHS$UaߧynVD)dIsU︫l-ʊU3E2ņ!jwL< y %E6 "&T{l7E55tz'@Ց IT\l@ ]2Znun&\54bNCIטFm&e}tf[C!!`$ Ԡg$}Qu6Hj hsֵ9HV>+Q]ҽvԌؘ&vbDIpx|=@u=V]IY?M9Y8QGdܟG.jdMPDe#rh J&"0l zeZ *\d:"[fuV9'{?Qmd6!Vz>v#/nGWuM 1a&O,k>K?}4]7fSbGl3ɳz #!0l++ei0Iӝ&JA Dt.9ڟ´izd᎔D2=W2'7xh* 8JU]0&@wpLc?Rv%n ƃp?>zߏvM0SZ6ܑu5wQsȖEoys]*q8ܞԧ$UE+u#8.˔#AcBT8tEʣJ RaK%(В8uFBt"R큪19'ū_e SwrGϡ2.SS,Ec4(U2}Cշ.`³K#eLM#[B5-7\H l;bmwiշJ7P\ .7g7? [׮o:Rm^/*ƕ3nHdBTL%:*yڦ[nG- RdnTWpFUN}7+Nw)?"jm}s{\_R -zG)hѥxUr5JA@>k흼Iwi4?)5Nt2ױ𗻇E*> \}jv*: U`mUcwωNX}{`CPֈxtnj4* "̓^G}ć}lدS>Gܾ?ٗ}m}kIVjҮlfo]i7vk [ڝ}o+[{g?{W^ D{ endstream endobj 1897 0 obj <> stream xڝY[o~ڇ#ީ_f;.lmL,,y%y^daO1HsJG36GђTeErR lVTQ0e^u}`<©W_?RT-\ u"J[g!5W%Up*L%ߣ6CN0, 786wSxW}~װ O^IB0q^miJ|^c1`pm7SwޖTtY|HXB1944%  TqE4SS2]5DPu߷m}D8<)+C\w/4 ;m$#:ga'"³n۴5sp*;/{R_!Y~޾Ka!6]$H7kCIA0Ь*]}_m{4lrrl;0v2HF/i'^AS'z QJ W1 5P"uЎ<TBZIF*\,}t U en=?6oW~ƍO~eݒ8H v7 b7Oꮭ/~j!O̧gNcMyWp-[w7"%K\D:Õʛ@KB3G4)BČ?#TE?L&1{gO~r6c^B*3aH·7C'# eH뢗#A񘏏i yǻ8]ka n93l0Wܧ6sFGS?h@xl}+n ;zvbכ/>~nu3;=!u?8tvSCz b(x%u gZ~Qt>$^A]$HbI6+Y0DCZ~3~|rL%@ˉErF} BXjfx%UP1N8% p(e.e"j.` x0쫞e"se3!b9}J1FwhMAB Ѣ,H&RG|W/Z"_7Zj0+|YNeeͪB''9ub™+T0;C`tHXTxLe<2NkLL:qPPc)&^fNrLq,_,22I0)Nl¡0v87q>TT1^2ù؆p~:@Hxj> 5&\(MC:Oo(MFgA~8ߏXd  $n!q`+2*쮰殆9Ȭm~Q:m<C[#[ ,U&۠m?N͉PPsCvaԸDz̪*O~~y{)0:(](JF9KP]pw˯=[0g4\!-6uwMhĺW ~G/ص‘DI~ AsնS!9y9Nd*uĭi%#sƗt#v' G"c?x] IAh#D1C:/ypBA]搠j4fVQQO@/-X1BOqH]QR}},uu?pFμQhgᢚ@ nsƩxs?(dA& sm#+3EF1 lU-z{kr]G- fVN)]藺bNa7vۗ> ܷ@cb\,g; ks"765oh> stream xY[۶~#ճq#:O]lONv7/+b%6%T EjA:`00oO364?:[ng^3FIF36}13cdnf3.8Zl|BU/OnUx-f$VsI}bƥ* ä[ 3|*y[ŴLv&Ǝ/;de ?fY *vOg  c1BD,@QՂ&%e1iR *CE%Lڵib뼞,ɗHm(u*՛~NeW /p|ꮣ PM$eQmp8$K9 p0aLA -(Q1[\y[BP)ـ ]aq{7dJ(SJ\縖}n׀[ 6`pB)6`|NK_l6tgO ֣, 3RSڭv7nq9OK[Flׯc&ܵo(O"Leg28\w{5o|bz!SVPtzwP?Dk>(ڵ띀krk$ǓghDM<Sc# ۯr#ww`O~o,o|"aHRzXSc w *>aD&2ut~vk\[w6s竸CY>F@7+hmxG#[퓯 FU{̀sNT+wz*[1BE 1YP0a56u5&?Lya[ra~f6lhb/;;*N9UƮi"X@}MA- A͛>4>oD7GB 7ULB6OF7~{@4:/ar ZHPXaǫ3,A?X.C~uIF\iY,8:$8|;_|s|gc|^-tCm.!z/'Eȅ<+F}62 7R/q*) z.x6 }qNΈ*9c=+Klkim0Y]:qۡI7,9?&hbMA),9 }j,X@^ EF/<Ƀ5S26>J@A?0};Rb(s ͻeS6,HG_u6PX?_y+' endstream endobj 1903 0 obj <> stream xYIWHVMs$109$@nb5$so{PTf;396TWlE[jn{b8q ]>ؗj!DFJmn+xDsW7iy#LuO+:)_sSEӆaYeVaᶨ<ޫLY"^Jg;֊U ]<6Qp6ñ1w;DθWN8D*.W>]٢Rg.OQnWus|?UQs nDڀe OCT(KѪ`WS&YTkNQ%\W>fImP;ί21Vv9A5$md;UL!ysJ8A?N@4e-*ѵ&YQ%s]Xm,áA ~ċNA۾{I9 q{2, Iv˛s"yR /YRTgBZd [eCH혩) E$s&%]cS_xZCC3.GKP!RpEx@ GʻtHcb 6QWƱ E$.kpYqٿ߲^6BA\hBz__߯T5h?h@RBV8 06%:"& UD 1DRt8"ĵw9w7tF&0Uf ,/c k^'?? O2,FicEW+>qba1乜:\9`OTNRLPfx\Yf 2VEv .s`SLH/ﬨ7t,.~d<=]zZ`%F7\N xDfy#9*|6[PmMKqi6HBmۮ: ;"Ar\9Ko<—IpONJ[zc+`1D|z@J|Ŏ]N}FQҷP7B~jo}]uasIY(b\,S""}EF>c Ѯմ[WtߺzEچ^T_Kd tW@NcVП>n.+lf ) ھD6T 1L3yQ-F"e֘`y%4C>k*KDN*5'aJ&y QXDɶڤit?c,vټ' pnn#||=)AgAU6B|Wg:+j%e!zy_SS^T?/kxX~D jY:jt> ) .Uz|@\@J,MɱǵޙFlwN:\bT@A3$j{[a C=71>d! sm N'A Aʼn B# 6.P'! _v]ߴGKl-HZy[K_0D!Ic|,K3/sp'L6Zق bTiQkC ( 6Űd9\ʕmdư"g7aAn||l&c]Vg)l  a@Po 6|?H,>ޭ+Q䯦p 0/p/O۷9o0&s! 2ڊ~5;\?{+~zg- %&cm06봯~Vcqmq~t Ng JY ŵXDwȎH{ x1Ӆgc>$(<23?%LTC7_XuNWW}ֳ|\ vI5APYF.)?ř̩\0/_3{eҤ܏/.riE!= s_ ;f6I`RPd"Tjt+GҎ+nM@CU5y߾tٛ9~65ː}\Rs03[R3*_Ϟعe֥hCHG *B)nUL#fk0HR\z8lu6Co endstream endobj 1906 0 obj <> stream xY[o6~߯ c]tk;tvc3[v%yY"9"tE Gw>F#aG"E?itF# apMob2b{Ig_tqZ3w_b>[Ove UqYz8cl;Ic%i+[{CQBU n$(Ezf"H4但 Q46[E2w! M*3KX$[OYT OҨ*\#MRhQAƲ}^G"!MՎSnD$N ` *]mfeΊ i>]_]9;[.CF 7<&(p'3Dypˬq[Ϻy*948v ##P;#)==8hI9Ǐ`{:pǾN@7>4T;=2 isCu`64W UrG,?Dӯ:ﷳ$[K[w%S7^8pO;*@HXX.^߼(ow!&LB"& .hmn2dRkeНW7G wUkv k]z/.ə~գYpѝ$wF  u'{]ZPB8 :}_7BڄNNbw}?L/{!䠖J.G(pGXt_\(`sS}~Z@46{ {:$ F#Kt`d7ʨ=w-lW|싏^|kU|9yhs4z?Z endstream endobj 1909 0 obj <> stream xXoF~_,.RI[5} x#ِr,,ĎOU("eof#I K/g"## E\y׫_CE 8fX/_q"P$6ԫyn1Fa!Bzocb$d!IeU It!TJUa Vţv٤.jDWkKg718 8bx ݸY^YěsJ'4iR=JiU{ (H`@ HZۻxS (ew7iD@B߁%a2q")Zk{0P2}_mg$(l7+UiRMFoa9< VWU>V bpu`dEfO֩)yīa#ٰ/ߚ<(%wVPKz("=OZ6RY |Wfjm6pkS#۷PPidKK7dS%W Q:2!rg#P= 2}t,qgJט\9<)qajZ(쾝^adB!*'ZIj-@+LdtLImSh-_ a]8 K0zZfJcM6e(w4X٫[!u5eTftuwd'cM/jz99&55z#ַ۵O endstream endobj 1912 0 obj <> stream xY[۸~0Ї@ng,RڙvyȜr$Ydѡ/E-K<;Ǔ/2LxR'w HcM&wMCgŧD2:| e)m{w4e%f?~_Tuklj,)vkRnޱ Q.')(#ɚ'2:MɟscW®~X*O;28H21A1J)2<1DCD1_~%b3uց&QM2ai٨veڼ-M0[Y8P‘$ЏL͗]bsѶ9 :4u+6UzhdU6m;#{8/+4S"MdxHvF^fOUꋫ kaf7gQ_ 2?G8 nRSQIsa=imFw4\ 'jLS>]WSU9Mm'¤MGv*Hҧc(!Nz":_~LE;ˇU+7ݲژ, ݦ" +/Zi{aySu"v*Em˜@ (xcVM5A72 (!@1%’m4ⵑfR&O?~5M64 ªWo* (;"ё{5"][v+v{ ^mQ۶ְxDsg/i0(4Uk.JFmV1h$UY)&1$ԠCdOSNӢc=dgOt^͎ݪ_.Lm|Vz:P?zx!igtG:)|xD"}g} 4bSn*c(!4M ϣœ؂ZС k$j WOvMG|o) )"( HM@1Ga^2T=*p*Zp՟㽈"?_6Q1kXC!7S^.K/-sez;&wT'8(1 /ު!Zf0ߥGʵ-PCEv|OK${n0ŨWWB* G|0>UL̀:&mh(*2pT;R#- õ8%uzM }.|C e`Tnv]0+;b>dvdvDُn26wہ*GePzyoW<[î WKn,R|HEs*CLk|󑩆_Ƞ!Bz3vT31 K>ǰ^1qVh|<[;ߚ1JwBG3W7ɿ:n8=Ɛ<#QL(8i?ՕI}$)*Gg']Hx1Ӹ x%vWo=WM(]6iZEЃwY4*J 7[ژs|ƶTʓ*EsnމCF 1EU(鉻M endstream endobj 1915 0 obj <> stream xڽXMs6WpC7@4b@SŎ,$5I;] M*o诈D~H((~ίiD0JqJ0rݬn_Y՚z0b. >7"NL"랞_1n4AD O&[i7ٛ)[!ʄ۹٠x(].naBGsawYظhr+okxg卓U^~ƾVE]M]5 Vs~Mla R (M6@)*]f4d \l}ZnS<:d#coy\>x819 )nƯ TŰ8IYAQS `uy6Rp6dXNip) ʒ1\E!\tY#{ nxTb n.@{6I|pcT.o)6i݅xLSV?phew;7) 4آ0.fk\*t^Ϧ{3X!"Dqd Fqd[d(Fż23 >QN8r %Rh(=AiB_~_ f\[[:ELɛB`p&4y]tѴzۄބQi UGW[{s9RC8]zԟƜ^@i٦ EF4S!rXk'u|oVM:صBb:?Ud=a6c9g" >2=M53m߮aA$xcZͺXKGwB܇6ͮ 6]ƓoB^݂w LSde Fv bN'Z;Ksv*,~S iJ=J81WC=ds;hg)b;9r4Euw:(mg*<= m0-/gWl\Ʀsf4Ϲx\^اp> stream xXIo6WED)"Ea Cm &>Xsn "}ou5Q ?8~(_F.7$)ҩMU)LEXP69" ))|mwߟ%8~o~c\֕]]ݓz륩fDƝ[f)𶬓K4Ry^ͭkd=SgD(צ}'ǺQ%:J"kfYޙ>QqDu; Q$i|C)mh( #GcwT-]̓/Q?ʪC"q؀EWz/xK-,1CL ='͛bujuS!MF^Y5B7!:x<R|0o4@xGYZdB"!&"kATqΣρX5eC"id7;i-LsWovcA!}m<ְQISx-W((ez+@bN qWWWլ' ` !Bz%' /dsmyL1D|@@8ܕEev幦#(Uz"ٻw^8Nx\ίwjL^ 2ݳw~t:q:cPEK08LOj ss֙k:Ohb}{;KTsx F G*Ԁ*s_l?<ʠY"m?-*k ˬ![J[?;=4EudM(@k$R}q͋0Y H,n= ϙ%/|M/*R:QNvj*; uUVa_~睥@B$,6U7[947[Xϋnܥ|Q˾k[OBoo:\s! 1TatoP;T&\r/YVѯ%=գ.@d)b <7Cl hbw|.a! hj r"D̶{M.]fs{SkHХ@nM0zZZbk " $Gs/c|.pE\/$'\:wx{s;aQTR$,dK0A9@e$]H<ʭ1C4bJ!`Qvp`Ew?GAQ)n+jg#CA~qdgNHP:gDA6ſujċsA^q70=IpLfyĠ8JW/kP[P4׻!>g]Hc); endstream endobj 1921 0 obj <> stream xYKoFW(PP@.ӓ&@{(vDKdJ!);IyEIMbP8rv7SB ?$Qd~t~OQs\%D'jq]ۮlfc,%,㜛M1կ 'I@D2a߾~O$ ,x4vyM]˪E捗2'Q /Wzkvϲi6Vwn81,%Hʠyy;$-N>I℅3R؜)eE*p kLH<kMorą80XFQ2`BJֹAY:]Mo43*z8w"&K% @Ą XoWE67WÚbY%Ca^WQ$S} M]UsP5u3)X Xp 7 _,q|˾&SZ)UE=p i!'ۦ+$p .LpQJwESEN=nh99{1en2$ƌIq?ќ$A?m _K69 s~3Hs@?Ʈ4N_O:藴KZ}C/V e?:0@_{ߙNv]5:7 0Cxlfn_?8D?>NņfwΔD endstream endobj 1924 0 obj <> stream xX[o6~߯@N{JצPauȲ'M:P4ɥ]!AHwn!agD" ?$R~qoF)NI4C)|>L>(H)˛w׳1g ?m7me<~[4;vPfTmXad[I/%)҄;Y[H6D,ʽi^bl dCYgM,޴s!H q0F!DnJBJ&:eԏw!9hpڸ,]/[xR&>! ~v"X HK[nv Nwsj[%YemѲʄdE4(EU8|L!L4Ӯ*J ÁD]V6a>4ֈ¦v3_&][l!]h(]\gŦr6J+ 8CBJ  jE,VE{v̄vnG@ӁH 8UD(2(Hu@uQ{Ĭ@, S$c;bfZpBe)!R2h&iy;ʷ!RءIbGQcTM+tdaWq<#~> -!xS*#j,5CVAQ-a; Fֽd1+|q={.rz*͸0a:|5qn񥒩۲/X͈H󴯕uWBT86j-j( 㡄EGL%L"˲ǃvhѰey54.};UmSzo:w.wr(9-;CSʎ.^ o;IYЗu=|rΒ7a:wM4!ZNO6:`":{H b;I>c8+{r_~SsV3mС*QpG0me*Wu Lnc)]VaQ{?ƦpKT9m"0ţ+Gqet 'YN\OCxȯ]/=X{s=b H ͎]0 [-$[h:D_ߠgR z<}> endstream endobj 1927 0 obj <> stream xXK6WEV nR.zA Gv%E{ʖM[E-Q8_#aGwkV$Czyw c,&"᜛u^fۈRh ݧA$}>ٳ66q$(@2xnUe`C[$7NDyC1G2qؖQ (^LJgBgD6=9igxv} ARVZon>W*6* Eoz `N%RW<3$\nm(tFSdoLS' vUQ1 0?@39$j((د" 4nڼZ2) ]2%B100xjx~?xjT@4Pt?n~VC{^J;wmgs64P\urEa$np,D Qُ. }>j)ꠥxSLOPa`er5QŠ Hb%ry{s(ΏUQ{1Bz[`A 3+KJuИ(.}Ѯu}_6tؔ@;U?ld 2  uggWf͚>oh?4LԄYv?Ǩlބm#Ό"֭ u\ˮv-(Ae= Nk_ͦ v+m6?AXNyN!jX~QzP7aܯg7uF>4EHҾPnڀi OkMe &VtȦ#n4!+xgk`rnQ( *;Dp쾰BϷ03I$Ri9T0>6CHGv,r@/ya#cVWa('FS!]M` 49#Umd6aʃNLyz> stream xY]o6}߯X~KlQYn ]!b+Yr%i]l&tY:)Z$=\: b p0]?h@0RX`|$ )E(Y28%8f0Z"X38˪mϛ}["2+G4[3kDI+n&/Qą YmWeq-պ? gՍ}fcI YdH a:ma*;¡A`DaD^%0zJ7sm_̷ad+Dio5*bZ\Pۦm^% JI}q_ 00 ,H{Zg֝+MV[OP70PQ ?j˗0ȑ0BB2 hf$1fcrk2Gj\k0%J{= aV]@8l v X`8zB=/}xx<ٷ+f/ 0m ^UA v}+ol̾t}>a].m㪪m#ƶwn844TkNf@WߣޞDO=EZeme?/;z91R\(*mac7Wnap2o;n(nI(Џ%0^db\r]±Zjc ,ڣ[;KBbxN#\BrX`鑶΃V1W" i{B15$ m[Ķg9 9mt'>O@bd SD7L.P$z8XneC}׻%zY8|=8Q $Y˻Kv$P* 9N{E!lRZyxk,(RHE.vSϬu&Hu- (AR YiiktX'} j /GZGv_%5 O`~XVmg,Q&G ?_3,;*jpwqD9^}2%’D&T 8x*\7Me d: J*lbHz: B 6i'#&hS=N؎5ً_ycSͰ x'D`H\ߐG`R-[M$s>-*h8'oTRix>UhO[]&|J 7KS0di]'tBupȼG ԓojsd9;A|<mIC{$X7|fR{e#PCh:tP$4w٬*S̍ >QqAC N8?!Ez|aَGP[^ג3)QHhwDb+J݁}Z8p(jSLb}4b8_2_x7R L꣯ 8$l{x)_3(غ›gMimu.Ft ۱3~> stream xXIoFWhPNfLrr6 ڃM%2T}-7 kD?{$$$C/NA҈ @줄#NʐQ5mTw]_5INnLkoui_kδ]8OˢcY}<5u1D 0+Pg5󞺷#%)"fQnfաɬ]p#"nLm62H fkb(E9 4MFD'ۭ& P!w15pít":=l@>y'z՘lqT57 t0ܚ+㨈*pʕ?zM2榪748tT" ׄ`H;,qyUuv𥼭E4Mi@<(RcmFAs3/%)J|tݗią5c !qۚ <7Cwn7h8hpDy?l녹ĄprobrXe3N XM}T|{}~ a f-6v!#cT8p((ٌwذ~PHa_8Ga s#a#O졾xv12 (cZ B;ZA鹻;iuP1"lX˗£e2D$4CI!vTpUMg"*6B[y,L :$#< -YG18Q2ΚFҮY޾"0gT7iZi>5G̭SWGJ4J2|j//8 4\˃K3a]]T.nFtO20rd0+F>~SH'Y,>ܻg۶xvÇ<5KJr'm\m#ϝǏ>/\ՠ~)>kG0lrb24W{x +-\>sv.͓_ endstream endobj 1936 0 obj <> stream xX[o6~߯@~iч] C-^>2k%O؏!)ɦCN CDVscGF2 ?$S~qV74#lHvy ].9^1"|۽={{q(cy,o m3Mx]TvmU>}C2 bRp4^ׅ Bo='MYA/#WQNG^aLIaIƳuJBZʹ*r.|iz]lRCAQQ2z?Oѧq!\fƟSDԢՂaj,{0쫆mޏY*?!U0!@DFV AltZ#-L( WL‘| t['fǁ rPgݍ.#[(ۭgx?*N@1)XGOXE)Y "H"!B_M)OW6K#KJwDIUWod;l%T9bIDO@*_MP8:^HON4T|+m5E! /W6([Mu}\աG: Tr\m̫vv>ۄ2ŐAZty-vTZsGH=cY@{@]~v# `ɂӪ=*Pz:oowif[ve6ۆ' Epa#)el%)14lws+rXPHCBi_ {!)NC4!) ڦFSQR0taD`'KcDڇu=NW(8XævFKB(%Hu(4c偸$Hbfmڢ07@ܟW>/* C &PTMyEW"4SN%-[:A*-hRwi٣5ۮDT\m4PJXu=w'G =t'tdbC&*](F 76<|{uuF УzQ L8]qc > ztG[O4J=ԗ)SU*)bQ`OWipX:9jKJ}7}k ~Ls vB։X!<S<C:ipd!Q7iy{) 2dOxycHjNybrM}̌`MR8.$2 cLOqސ a$aggJA$ )<7#7x H| i Oӆڥ^8Ou?LIW iQ6[An:[k}D!rzN1š5Σ.ұ3} h}-ͭv)Pzs- 017zes|o{7W#+#q;,Rކ{ktL` Nڰކ5ɽ礋kmmf/?b.ӵmi$ߙ[w}HJ/v endstream endobj 1939 0 obj <> stream xYIFϯ 480|DD".^To41LU_}8=Ip" ͓)!%IpûST0<ޤsuF)M1}cm[n}~a l ۷߾FR,XfvkAdc<>ya pKf*3DN?zk0,75)\66댈t>3`"!)~mžE͎ hP$1+lzys} G4 $ n4o;SMem΋ mUnL:wh ;|qУI-/ n7piok=9r%bŒITvKνpH몋i%FAOp>4@carfpk3KDCQ':QJN6|w=ο w$ B1V)DT- +)&# dzX,( p֘cL3O'lsFA!`Cýx/q{Ek]@t;7u0wXI7Ӈ(4^ְr7O3 ~ޚ{l(<,tqSASrf~[IGD0I"1g8 8&$ԮS?lB梐+[R螣e>I GŁy0GDM{gT1$uGPS(FJrϛajh)^lE@򫊠.O>z߼4)X2j;n\lcvB "{: ?&_]C`R/F%Kn\ZZ h,^.o_:4JH?h7l3PΊ+ode`'c`vmy8 ĄOoz0*dETvcB8G__ꫤynaYȪYpjy;# jL'<[a$Gc/$Y)q[M>ߖc5йx¢Ъh*t6L-)QɄLwM=9N0";@E2 %Gj}ZS_}=f{u$DtJ\w MR=O췮3xF!T=glCAOu 9b, }@`#+DvG{84S5X_кr{a X!_@Ƿ1xٷ{6VEE 4Nfb 6Vݟw 1>Q*E`GuL- C+m"*C: " K_T)aXJ?۸D_ &\%2ӧ*#Iy Z?oi=)DHB?]ѹ)$ǫ51Vo>_PW(4/ve8#о:ޙ,f\n υew(QchSQߕߺx 1mc*A|alc0bs}7vnKv/*ɡ}EXzE PTxC$(3u Y=¤O-@XXX-dK;WwЛ1?-EeqIʶbh_@ r^J=B":Nfz[0U|CE9Ӵ-h!?lN@Tqk79Ͱ?Ea"ӣ~5 gic@my|^+7"r5jc<`D!U+XB@)_JIs,t5 UX*ta6fϢuW*fa>.vra0"_cjY"/LJ\쇇 Z_v endstream endobj 1942 0 obj <> stream xX[o6~߯܇@N}RwХmnUTIٖ#I ;$%UrDGW 0@Q|t<{EQ$C Pr:>;5"mNgc, [U6kɫG4ە^ k++W$F p~:[q$(i} اR$Amǯ4@ lLp "حoO| AKY޼czr4Ml v~3 fl&hO0q]!a7M?{פ~(uvՁɏUxr>Āb{qy]/x]γfuV~~ꖦjjSŬ=5FྦྷKVΘ4,ubջ/yQ][@x mveTh+۽5cg WGILXpHBSV&Cwĝy a@)q~teB̄&a Q w1M gy̍F`+xY5D/RN6W 0y#N j$jUy3$N>p!NڱV#ё1V@Ƣy'&Fy6WQ,VX\uO8K,# F 2q)T.ZMU%MOڥW9$mto bz%’ S6o6|4M g p]hXa}veY(pL6{ey0o8"E0S g`ck#91;<ҾҦ Q>.j>.хke>7Epޅ'3a6a@4i3lJ+q6YiFsBY9}X6f.7!)"-3/4N0'ݞ*p䤝eal@/ol0 !F1Z|E^ԋU ( .[h|y ^jN2Fw{߫Ԓex_ؾaCĠ%9E4lan}|5ڮBoعNySB uS42lic#E(YV ,fd@&=3Vjgrp DzݏOmnko(;ؿ,*x s2z7G>FNj'qUnU;?]ߞ6\?88c*|`v`53#եސ`E_g1f#& ;=v^chXn?}d KS[sIe8۴dA-%uorO4I endstream endobj 1945 0 obj <> stream xڕ1o0 Ŏ> dkdV-̀I@%[ t ssR\KFA@d)&$+w)o݅TJ\m S}F"dlжE X7`˥bQ*t;TM͈m5\s[W+Gyp `ؾ=5s9D1y==u5w EmAB29 CFLCil$XDs_!9~cӹfp1e0B]U:RKn8Ƽٽ"l#2z7Д/)o82k]XGCŸy#>X̒8u]a2+/DGc'&WWFyZuFޟ~ endstream endobj 1948 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 1951 0 obj <> stream xڥXKFWrBUa¼S!E9 %ɟO< ===_݆n G7Ŧ>m|mhALa~#8' Ĉrs)!tC5aT N4T8Y*T,F;^ …b&z]͹xWWߘ!y˾ "r)B)XS$J[I3Ԝ$`lqsγ_tKGM5UO-/;SjCN<-C۽A,{W:i /:D6lJI Ր2 )rULj nkC4r!8s(7ۨ]=4cF~$sȐaOlUEޚ_B2[BQqRS0 AfZR dU *kx8:4`b.PT F` ojx/>G8 zri?OUHt_ 2ET`>Ft]M)Ր 2[E墀ba +G$qiD788"(DҧQDx]6MM)Bjwo/ q퇪h- /EpXSȏH(P,mOv8䎰aY׻lY\5K}W=1kQB--y>*PJ'7NECV#\h΁<˒1x8Uc;%B sQN\ЄXO-m4^Ca;:8^:mkymtR|W}x1n9(-or}]w ! ? C}ftCW wf>Oh/8joI5lM[öYATɑYk $rڐ v.[&t<ZY7Hc/[^Ӂ!hc.iiv'+X*?hΰWpe\=5Pɹ@!vHeq#$MW@[~q@ι!PE, TuD0=99 5YlU۪xv-.nqm:+: w 路"aJ\"̾Z5%2s>QQnrtZMkb&v>eiXaZ7)7sHFnrX\ZdzO]ȼRoXi 'B j ܰ[wH>)Oҧ~ ?bأ=.yAagOl]j(asc(OCD@5o ˏq{ֿ _~ll$;}"mHFH !C iy~?~|e"-~UzD/)#ΎizZX2M R$$GusYi h/"*<.W\"[;GhƆ~_> 2l _^DQBI373bZ4 )on M endstream endobj 1954 0 obj <> stream xڝXrD}+Phv3UԆ'A'X[2{.쌒]*XF/stO VPaK͡x֬/- RK}#mn*!Dtpwwx-_~Tܖu7ܔG83dM,^Rnb(̯jF?_7YvAiI UEu~},-pFg[kSkU4$ڳ IZbk0 2 | /t^9@"Mٜ3(D'D̜ɡm( Y2Hį kuxevTB0SO+!RmZ{ )qQ45On8]3C>NJ?lq Gh*\pap>>)lޖJH:.}` `ѱ '8~t?>TBۭ\ԯ @L—:@9Ohu\'\Fd#ׅgyÀ,V=JZE-%REHʐВrq w!59aV){/Ɯ-ۈu} ӛ4pgY3 A+wTTx!&`s6> stream xYK80$mߤrI&,o2;ĖINK@Z*뫯"+ JQWatE0qNVO+W]rW{Ӯ7 <{ԝD $K^+P+s39҄w GQ!iM[AٿM׷UW?ij}f8+`*7=N]?…f.ضX/^m3篥9Wʪ?, ՙ)L~g/UgB0^S=bZoh|E-ڵ ٶqWpөv>MB #苏V 1 I*Wc6Ls$Av2W*pVuښOu_}㯏]G QU%C~;)Pckř $.v]M6mfa?;W&_(C"@лA"3Z"I9l`ݙ%%R.؟LL2H ՚T]HX fSn‘ .B{cC(E0!qy<@+_B @V~<{rf\cS*ĸ$g˗˓~| l#0;28AB,-@<%AW8dP~tKwN=aG`91֪.*n`qY9疧}-r]]18r|4GL}^y*Pt2Zwo;Q[8Y퍅cYŋXh_mIɸ96 >*V 5te[e2s ag%]J]Q9 % d:AQ1 ٗ]x Zl2y|5rɫ0El̏R %!~6|@ٛD#"[g|k:pZoր|۔9Ws`/:Xڜr赁Me ߇\̲|uGE_.Gq^3?D7C"oQ,B1X` b L5wk.3b:G!]'zd4VrWĸ#,Y鏾qñ61TDo(hu4@UO L#mD;Ezlη).5|,A1*V^.˔(vxrq t\}XkbY큮*>(i {!KT Xe#$?P6J)['x+Frg~@_sM8uƿ5ÉoL9σ+)S4#b>U#q<bA[Vȣh gƾ"Jr-'P=,,/Ɇ!V\C8f5Q{YR&+RSڥZdފ٩;{Z=.<_Fʀ!^j<ϸC[ q5]4*Ds(_t6OG-,so\!H#e"z cМ`My>SgUx,|s6OHzY6 .դW/WL/ X4sq/!J!=A>L#suƘC)@,dC}9QsNUxY"?Ie `HJӴܜ7v0-ѓp*v] L2φJx%nwTuƧƦNpѦ㩥1_w@}x@R\!u;+dNvӠʘ3቏&6Odz~lb6EAqR<&LOӻ_SycwvX[gvU+P"&SI̾K&e$fwrpȆcܭ&Z-?|*b貙KxN{F6K Flm mp V/%&xMϊHt)rk[g/a7N} z=cC7:,LJV3(a}~8FꮫxA?CG>,5tο54> stream xXKs6WHvLoNIɸ#Z,v$!w)&:(~H(` ~р`U@0$/BɓfS@EJ1x۬bXK_Eݖyᇼwo(ImuQ6Vw(àۨ;-1OQBE8E4\E fu&+8v^VzXhּ~ZD!ɜb$jq#al7l@O 8')=UJ?IS:OFPU~eGNG"FNRP[͋Hp*H|p{BRΣEAv,oFtFPiYg&?ŝQcKd8^6̕aS/lKYk2UjzVy Ev!Rx e-b] 8󵮵 䪬5p"E$ƐD8>)2N޲lڥ}$p^CFJp÷|Pqp:pnk̖oD*9Ccx.2[mae~[טp]՟byh&kjv8źF(DaLRNcW>a-v;kWE *ncxҵ sJb6#J+<{%7>o_ܜ;2țDAHT=8yΫ;[M}#%ࢪxB]Ake:T-,9ɝLHiAIi֖2t?}n#|vz6QNJ$'2H[̀k`M^v=?ю!)FD}L8_pPE!FEhƮֺq+0cԆt| d_eO IÒe_ R;Lal,/ g^sL"qp'2k]V*6.2%!YbNtx HˮLE=_}Ы&4SVf6u^ߜ[N'}lfϰCYg> ?!Dv!P-r,ܙzqlietSâ] ;'S4&iYSóaOvmmaݯz|M8GOv—7-t?ϑaiG@oB= ]7fmQB=Jģ (eE 㬷dy6P .MNb[fh#1n=3n ݵA$lځn֑LNԄ<¤Jpy{œGG<e0>ojz $zr0c΃_ endstream endobj 1963 0 obj <> stream xXMo6W Xq))[ l%AX#i-,9x?Ap捂 0|H )`\΂W4 iI0 C`߬Ҫ6Q ?by,ꬎnf̚ +b`0jlݬko&,ݪD2fl-\!!;$wH0Wp j.ݺWA|.@\p7ua<I+U W_σ(8Y41"'ا v?7a ț1LIb5c0_C>](My0g Cb"-NQ&RŻi,MJ"`"L)H8-K?8>x52 h2$*AD u V@?ر`O!>o?-P!,8i-,na_G3pyx(Dsؼ:}~P;IXm|̘$I1-ߟ H[b]=m&*ks-3rz[,9&Ȗ>kdEHԖ Ln *cd4WN7ߺ!1'y3̐9}h'nPcW' THզ:K?roY  4m=D  lPJEpzJmTm ^{܋QtI 13W^7atu$ajξE'WDg'A5H tHzu`P7p!X; |7xmA]^eUةWK٢l|azȁd-u > 8n}x{8#9S|lpg.*NR;^Szm t:}A8-ПB\]=kMtd&(L,sTd_lAkYR$JmsC6}w3$VPJHP6a7":|^VZ#-,OL;8u/EPA=ChW5O endstream endobj 1966 0 obj <> stream xXKs6Wf*c"xpt:v!ʁXD*$5n;]$MH,ʴc ‹oe9 ( 8.+4$$Cx>> (H)o_"Xd3.ϗ<3khN4QV5חW ۈZ)(&*>Շ )U"|7aNˋ낃($9KGV7VQ$aIg)9mHY$%Lq"kOiiUsE#,#PcD{ĀA ACVdC Wx j*-|Uz6EV4q!UN.`H6d>>LF"҆tB-?Wior&U![=L{1l&-nC>Y~3pL͑Ҵq)/HE/c1U;'VHPe95e:TKBtdppD cNs0EHNF~dk% AFl0CT)8q6 Ela~mvLC :<=(I֫:]adHQWh&"*ԣtC1h,-gFC?2BàeyOI/J CmS"NjMbAZ(>+0=~Zp=7pàL*E14,Vd~iW[gS|q9w ֝)𦹱w<~"p7܆rJ]ˇNh|zb?‡zAktZ_n=ipx94Q9W "i3Q>M|]koR `nN^d[oތgÞԶJ,%d!evYUOa-zؼo=+m~$XC1MCf>Y1l?IO^gC^@%L=9r/&#)\o=;`ݯn+6=dvݠ;הo>=1x{sK7n#׶O g aVM;)Ճˎ[?)Lʉ|=gTؓԞTLe }ޯ"YUZvE/h1/m{9˳YUyz(v>_C--4P淛snC2sƂGhP^R8XZo7ۧ#JPkLjh s7חF_oŏۆ!ћ:FG!J}w}shh._ʠb}j;.xzx/K~7i_Co[#{{v |a۲ endstream endobj 1969 0 obj <> stream xXR0+gjdv-:͎0B+rh ຓLɜ8^'FEľ(̾ Zܠ3tp%8'9E D  &Gź)7i9O8OU]TbŕM•ݷ'Bl6g62cCEҦ"9ES#2m8fIL61ILseҌQ3ΰV3ezqU\Ū?Mթ%"'e+]Ǻmu`$F9Ă3{(Jd87r o\7IݝU"άRu܋,0yv<ʞ$30Iat\ #q)Lǥ0%wk"iݶ~Å?я.00!Qa$„ cq*Lȩ0„v*N aESSG#3z' endstream endobj 1972 0 obj <> stream xݙ]o0+|7GZNӦ4v5vAT &5@c H}8#}SMѫ!dDS4E4E)8,6gի/>b9^iY8yo(f)ΖӼ‹j֋K:fTA4Wfr{UĬ VAI B)lm**@ b;LVʛ<gk D#/nnsRH-Ѹ.?vWbk6j^?&wy6)S 3<%g6iҚ hɟ^#i~Ҍh,m~+{|(Z"*"JBGDM DM_@2jzQsRFE7}&^ d/ݕiYC;8/@>L3ldӜ˝LjAdf3u3 $X7o^7M MӋ9qٛ{7ZE > stream xڵXMo6WV XqM*m[ L*lɥMw!E( H1̛!d~H(g?4#U"j*~[%c,'(9} f(\q"d`~| ,GWHm?t#q n"X^NfbNg%Q) TK3ģKg? U(%"ִ6YbtJc7ɀ3M6B!Vz{U}OfiPCw;Ȥʟ Ȍ%<ȏ.m׸R |G9Yk }IQ"65O)US6x|6 yL9]η۩kBvʀ5c[7N8B3cI[c4] hX I6"obI lT&H̊#N1?Jg` xCs꜒9~%F)\J\6.ibU!) #|ghϺuVc209)Jޮ7Thʵ")oR(lВc(|+6ׇڹBx݄WW`29[ \cD6=4!hݺ#Ę)o0Mvx?'g_Fk㻕-S fpkv0@aW/Ե endstream endobj 1978 0 obj <> stream xZo6~_@͊um3t( ɞ=>%fKe/-HJ ȶ2b 4}:wy)(?i$-_ח, IF׷5$&?c%"њvͧ) 4M;Exʳp06881|88 qc)SΒr6ۈ8ĝ%`lpcp$u2!D_g݀uuG lpH@8>[2Nrg>``b`llG'nj.z>c53޾S,2*h;bk) Ǖp.Fn{[ Q8\Dټvq]OcuO{Ov]VEU/ޙ>+12WEyggPm]#!,V_&̮/U[iJ{Mc1ee-,^d[y3?@k2 Qml0ϛituowJk.{*F[9ڕ$2hY i>PS$!q!4$EX \ ~A>6~ ~nL/hq1.p bޫF)ٓ8œY y׺P7U(r}bx^ւh!~͘ ᡳcj+D./﫺@l-kE@L}>Yx^4;3);顸];h\o롌9AODvlI.el 4x|j34\mP;(zEͭEIoH5CHU "uO@! ͻ- J aFZEZ϶{7eP Vފ-eErz'U>[][ ӷPJNb& }NT J/.f.\6Ynݣ.W ]6lDb Bmߣ*wb>|1a0N }v+,MLXPoaR;Xsӓtk;S/^j&QpЕBA6g.x!!d endstream endobj 1981 0 obj <> stream xYK6WX D'{6CE{qQsڕ->jg8mjXXU)(8Q)z{}D8EY>*eLE1?%׻14u݇۟"9TX3]pn~e&Ta,JXfv>.r _܌x|>n\+!B G)*^€"-_K}t3.VX02%"%]o>eSXA?A0` r$P=]BTߟ®k|Pј% f2sCR$Gg0(#؜Ӱ+?CcH;"/'X#bmpG-QQƭ.tkC~<ҵw<|=*.;7nzU* ;|J|R@ʮ+&!.ֆTqn8~!0H125lX0&O.$GNR[RD zjH)|n=0f ؒrƣȝέ7݀n]R8ܐ0[M$$qn`O1}.6{yUun7ax>-b_|\qG E%"1ƿgQ]4zSuv:6_\O 1R18iI }{"`!B" kx 0:!m! }5Imm!%" qK6BV{q/nGV};`6͖W3@C`bq2Dؠpl!qb3TQ:=حLT0"cp_ ϝ J9𠲋4A5Y5.AV>XLߜvg tXlI +"[NltId P` )a%8$ClGPh`0RU31!:0uNHHgzR#LPFi4 |&X !1)% o,ge[loF˧910Άu$om _u`WkB 1JT qќv4$};T#2Ch%w~y sM3]uhMPH$3>k ! ^"aDɲz} yu7 A`Gm1P)F Zfb/s:X!9}# dD?P˕E\.,Omi;uװV@} HT *κA8S-+Q=fYSK$:y2MfdaazXxf6 u:Ory%*X\zn,nunVePvN#PX Jd ͩڭ.m՗rB 件 p|Sk7: _6(n0{Q9  YI!# Y*o˾O!twGc6w]ߞ l: X? +8h*tlӾ,}a}|[O/F<ʿ{_*VtApMH |tFKսR^7WԺ\cMVE ^a> lq!PCXFwlz0ˋLݐǢG¶sL,fv20vO n0`E3yƗӺU\9eep]~v?F7 endstream endobj 1984 0 obj <> stream xY[۶~&@''3I\Vh eM IymO|KʠVvǝzL++J2U_}zhB$݊MIz:BˊdY qQlO/~7?}=~}c^7kEy:U\*9Q]H~,u,!.x'"jKfRdBd*VFM1@8l:OenRBȨ΢D ll)bOTN:uˢR᮵R%#Uf7m^"4@dzMNU1KɦTZ|!<1|0gK-`~o/?LĒwz ,;Xq ك`i$k]')fĕR@g$Ҩx4x L2oݐY f7 XjV!aQYFFc{lkȡ r NOQN= ^m6,oqYx|-+svKh)NTn-Htpi\y|Z gp1Vv)~EB!!%> Fň6QI7AYXyʿ:Oaʘ$9|1YJ6w@,D!}rg(wPV%oIxe$!ѐ!M-UvBYsr^_ n( 9@^/$ VMS m$ l1J$SPB" 5`S Cȡ_M=NǮϬ܄3oh\:{mmU5(O$lOL:3WgJ vm)q`ZL^bZFM"2-% /-i&fEq 3“q3ظCda+`΃̳p ڡ|z0VsmwCж-ʜd^1v,p5 K"rqТ;{yؼBm60eT V= ^~R;oT' o!*71?,[enT6:T7lUlD],:FM'IͿjK%r}o˓~:'>Y~q⊝ѦQ& endstream endobj 1987 0 obj <> stream xXo6_!)+KRl@ی-L\n~GAG,A0()xǣu|N,9O3qhЀ5#kqH e$aa1-n0wێ41{4&4YKJJ.mՙ7ǰ LcõGxޢXyu"j?ӊ~W5q4c<(ZUYtZ|<<%uLzܚ|`yCo#yEi[>9:#R;H'Oof%&kOMKM=Dݖ HFωQof 3v̞5;4`[tawPj<\i<rH෇8q1)'|bXY=-?\k9 #1{u1w?]ud0DuVmI㈔#[d+ epOTŅẎ0ƏQn=J "< M -Uʹlá<ȫjRW#u(V952ik$C#2μy9a+M*jLQ#)IF3Y/9k93! wN#tI k}ͦIje^NJ9S@~נuP@_ІJLY~U-rM#spFE&ISFR8區q> stream xZIWP\{ _<>n)Ԍ;ȏϫ%R]س ){OuEV_V_+VDCB +(Riz+znÿ_á=/Quf؞^SUWocclApϋpD덐N]H*7M o(i d ۵ũUSO QF<,(8#X@4f*tѷk  '$q9>T# /x>#Aj&+D29&j^m6N~2j,J$24% ~iLj.eoW4oA`R1, bDf-5"&Z▵x(T '֪PZ. HjL &TsYT|MœM5Zs )~>zHw  6''}uN q9BB e5DXssОQF(4&\&Z MjDv<{mx"nt6++F =f$bzЫ*]㼨˃mA CN8xeѴ*) ^B3$`!6 Yx’nhmjPCP!A ZV0 hkUq*DퟗY C~-Ϯ|h°LOHq#BߦEgv.]?CLILǺ!Z2Na#ʍSi W1^tH/kQ%#MFǮ̸@%LZGk ©-LJLx$3)sa ]\@T^w.`LLU"z54G{;2ؿM5##cS-0RZ=~VL߷۶љ9;wd {82ZV!3'SJn$ F8*l x2?i~5f=,<$ !積fܺh}r\4CJ5A)-pvم 5[SLݞ[ ߖr,۾ڞeP TygශI}!jv @$gvlmy gڶTtjNqtޓ=9@]d|zo?Eڇ\K H>@0prIs.$;k\<*a&)qck* ŗWCW},JFg$?bc{gVU] MndY*$1]-aϿ|K(>L\;3:!AXlRY*KfRyH+>C?eC:0d$tlbaM/e)T*Xrޘ\*PqnK?MZetҤB,lݽ9}x~'}0:U e8EuagȘŃG|$0}dӲۖ\lĤc A~bhC[ |{-~gREx"dm4nx.n.Y( ˣq1C6kyqS/(@~ww endstream endobj 1993 0 obj <> stream xX[oH~_aDim<7_[Xbةb;$eUD33bB 0cf=ȋ5[Z(q#Z}75/G!F|PJ"x54{iQ\!Y>B 6<E miwz\!}5u,pv뛑0s,}6J/|#~G͟T+_ Xڑ Ikg֍E(Dĺh@\1a̍0;5 geXU-T~ROBwq) vV=eї`9 >e촡Q}QC!(a8)_L آOyi; x9N8OԲ1=z9i`o{qG>Bn-a4i@M!sVd/LVy$t~ r h׬饉Oa2mO,P_}bBWADsQ|ewjb81['柤7nbB T|-̤f8B1ٚcɈfK&4K\rY7il4/)/!蔛4?%r@ 2 ^Vq&лmƫ.d [:YD=./\;o⸗^d|8tJޭ]lC1JM\k}*䋸Ȧ%ǃ@ii|ьŕEm!J,\$2@2ՎF뀣I.݂,*imbGapჾ&%"]M\(Up^4Bo"Q,])VJ={ɶnBLOBI.L I7SUqV˔WNQO*CyB@گ{bk;-pzB7n~Mv];T;)3pg{dg=; }wgH} J R@_涘[w&~#?;VPpYwB9 endstream endobj 1996 0 obj <> stream xY[sF~A3f)IN;d(}󀥵M+ PRw{Hhd=\>E8J#I/V2zD8E*U8ZD80Eer!"]|\J6_yPJ|v?~.^m3,nr,^z 2n,էh )afj*S]W^$8w?ǓF;D ,HRj`(bJC%?Z(v(wC$U{lDZ_ 㸴kiF9 B"c%̶-@8Ǎ hq*Ex$(;t,WU7ѥvF>9U#m;iBR54ƼnN;u|o+'3-F.w($1jN #)~4 PWVn ց^ufXo*n"!p aD|I"HN6ZlBE6?:4h7E}s8ГG7R1f+w+F.Δ*>mdSB5azEAyO7 Ѓг> CAd/i?Q#JS#U+_IdrR f 0!}OH7C'd茉S?u3zht _ߘEH \}P1~vF~  EX{sJƦG3KfPVִpH@ٰzT| D|u*$RXWx:"yuAz]Q@@(շ\d4rSû^m(QvtX{O~x}bA7̏xG^af8ntV7*W{Fq*pG|{* ɦoI!x} $^ۼDm&ʎs_w^_. ! endstream endobj 1999 0 obj <> stream xڽXK6W9r1|JOiEE/PdƅVr$,ٔ-o5Wf8F#axHQx(~()n"#Put~m[SXLU9_Vecջ_"NLZ+.%qO&V VgK%K$~Bj B#={! 2"fBlLQM~2M^o*GҐ#}Ha]]6' GIwMHP~.iNfsNS`6ͮh7mh7KOMWW ձ9a#d"F8+{<99葩 jTܴ.[ "i8aٳYsyU\#1̖,krvn#9T[!h /W;So]x+^f'!t(a4䋧|&|Wd\%?@%h?y1&89O܇`c(G1kmcz2ث-'٭ 7(C@2Da`?Ǟ@s00ϑǖǖJDJ{<ʤ'2RU׶6N%A_5,̆Wی5NV4szym'Jn=t# ϸ\2 v,w_UB8!Z <3c * SqjuW涂 Щ欶[ JpY>=I=la)/Ͻw!k*Lyhmt#]Os{1WݭM18/q9QXB9xBǑF![omG^_t3ESL8\AipP^]E?0 endstream endobj 2002 0 obj <> stream xڽYKs6Wf:5A'զL(-RTwHl7Br߻5#3 LQór={~5{F9zFa(j!yFEJ1xܽ|yKz?-^4uS5OVۍ9OiϩJ:kbamDAJsne۲6]ϞPa+]+;14OnJMH u @9y<hA'%Sxt(OhHX.Qt E{D D7~W)S2']ڄ h7߶};-=.|ԵܫX_Y[#8'|:9uŮ>MZLt;/L/x'.h ]N*>E|ꖞ:Db; nm3ulƀ̶.s>jogb2iVHv? ۿ0BpN#JBA>PXctٹ_VXw_(A{!biԥ8 t[Y&RK73Pq[UтT4\ 9PΓeuŢ2ؤXzmVH G ۇZ{5N1֣GZ6m d5{V>3zJ:@a,`ϧs #o) FDs!FN Z1\}{4=Jౕ nqL&ЊRȴfK-`2J鑂[Cn1)Joc.5ĿatFj:)]C&n%">;׵(iTUݓ}]IWS3`_3WЗsuM`י7E\]B$49$-}nQX^@)ϑ,|dKW/FA|<8ijudV]'-c^+wy3;8[1^iOrmz"c-*(fu'`1SC}0yMq$Co ]DMqCGk'6U1}HѾ [j?İ#L70dDLؐt}cH>>D4ǘd2wI[wQ߭4qVHf}BS(a]vG&> stream xڽWn6}WѢë.6P Mc Eїld-׫TIE?ÛVZS@ 6%sf 9׀~HPAqt( IPj)|Av1~8ۦe|K@1L}}ɦ6#DpDT,,>Yr.~#eW쫼K.9w=Jz-,!c6pE%cѴ[#ڞ8r.di1gYf׾_:|uvct?y!fނwŘf&E^^pN#mѝOuYDEX%Q"1 G4F@P6u^!c9s??VfV[!q쫍9Xq^}Zsb!%({ JPڙ|$C07qE&GOF㬀 N]S. "Ȁ5ћfqLLaTDKQ!E(p7.Ħ{2~RRu9=sːHX&Pfj$6IƛoƪbrjF18}&.)|fj3ONy&)F1gC3OO_ J 8QP4 y(o[0^Aü7uTU^M0JU(q;:T5g6&W!vo~M8/6% b&p?6ͦ3cQێ(βr6|n*^?X (> GpM}}g?Gl%NXN\\.o10î,ⰳ@֛33υ"N֮vʶej2KR)|l֑puD&b 7[lNWxɝ-9ģp"tgټ;kşfXVd9)aZ3Ľ7)[J50l e(7c;wOFϱr "2uWV$GG=z j, ;*ys #vВ m^yq*W91gŌ^J?nCNI%AI]"мI`}LuZZEr1h 泯+&&zcsEj2:-#(/H[>Ws*6nd-*ʫ/m~]k%TT#I#3 ٫NHE%t+(Rj?ibq?vַipߣs7ϘKURI?`INp{`z,,1Aꂧl&~}ѕz+H[I0${dn"[zZq*pzvwe/i EJz OIf|w? endstream endobj 2008 0 obj <> stream xYMs6W@3&OtNn餞IbȰŚN|I2Hˉs$spav}hD$-.,$uDuD9N..QNj"VI9GYy~9?\,}]Yi4.L9a USjm]ǍXXS|;[ 9>?]\`TSST J&PIa08M3ݴTwc`6vYޚ8RLlYnD`I%)ba(Xd "5q^g[2 lՁ{ 0O>JVDCBjV:)66{8H|^+)`ul+3%T*dM$$^)UZ/9xklݘ` X2?pg˪Sl8o5 H!u/3ͪ9ƛhP\S2)mmf- dmYόf+˗ rYy Kn+榚u8,Y|׸.0+/nHPwRopm+eqш=\m޴k\m0h~RW%KI{,Ap[|*AMYU,!tǮL$V:Z[! sxVuȎ9/ [3] MDFM'>l0.v?Q&=gj{t{6[/G<'a [2 +Z0Id )CR .cԳD"WZ|Te-. ܒ1Blrԙts_=07((JEf/?bd.8$G( `kmPx€%ӞN>oԡ]m7u] <(EyP^ko&I{ endstream endobj 2011 0 obj <> stream xYKs6WVj&B7[N66^l( ʤBRɏ (%ͣ$3eh_e.Ip" ϒM4y$8C:89LJ0Etu7gsJiٳٜ149TX{\>}[)2Ԝi0sg_fYgϺo%Y2FͶN%ew7D\5i><RuDErDR[D i AuzE6mUUY"!l;'rqjSp牕)?[7"dn*gaq`F  kx^9$ҐagԦeSsv@Lt!kF^!HrO!+LѴ 08{Y7]ASiW+Ȕ=ht? )OV4Ŀ.MML(xY(Ƅbt!hBYк-W<ì40(LT*b*h;;sy: JlF!.ކtEOY34O*&~͡,[)L+f6Mtc q";|ھ9az O<<-|Df# B}tS#ef;, F.ܣ3{;e^GkܤAP GXwH8aG,}|6/hq@¯/|"-±ͻ>1X (C^y«xtl55{+3u~56dj !_)Cch@`"|o< LmSl؇1yRAo &&Kh*~ͻm{QY!yQˡuVeL?ڳop09vAni6mXi_NFT.:4Q~t 5p%LaQ 媟難9Hsve5h&5@:L֔G d! oe-{Y6eP}d ,ql{>@/Jtzkڴu׺z`]s[C[!a98]XV+xXHO+EX.,+| V{1uSxp3E4p7f7p(OA›~sh[ڽ?Ǽv. Bfc6ċyŋOٓo'A endstream endobj 2014 0 obj <> stream xWS6~_*3Xgr7ti/}"<G!&q_ߕ@(Ж~i]E$JDo8zF$:$"Fah<=CR2b~y3P?c\+;ע^ٟQLSof5 5>k,tsS[['7r0~ e (,k7LPmQ,(Guڡ@?NPFOF?SSE"L-L(].a"_.=a(6jm!qˎ]M`^ :BH{ơ&Y~P@Fd.Dܘsn#4a.Bϖ8I(MPUnubBZx 4iS,`ڤOqspS`ƒr̩/@I+N& a&on+s#/J8!KWVRn#D@Y>-p+ʛZ:͙)HJG]<^e<cʩǴYME2ixį-BX"gM=??Ŝ.MP9(fzc'>v}gy`G cme".% ;Ipem7b ~6+Semff*ʍN*_9|P j'JpZ60}3^@%ζtW[U[3A}d|Tc&z|cG˲)Cc-ⶭXtDU^ME瑺ȟ =,t(:&yGy>9=jRrs5Sy֍HȚTnzD%*7}@Dh5-ڛ[椶ػכYY-`]mkpأa۲+6G6 ]ϋv3)|utq[.rD((Zg,gHfz AكMgI[LK3/xVnf_잙}`7~t%͚rnU1\`haaztvlCwL]yzPݳZС-8I|Z[UTi&tjyմP0mmm'hGݦݖ~_ޥz'ZψK)W ­9Dae4q\ >3Мq_B&Oa5\Xm uO'Ka/Hm a=̗LY1yշv7ϘU|)Oa vCƯX%| ߊKj-oH{p2~o$Q% endstream endobj 2017 0 obj <> stream xZ[F~ﯰRGZ7JA*VB21:!vT=sgWT }s܆SD'˻K\&E)RHWŮYF)M1{:cmUzτa B_}s$ FWڏє  qƓ q;lᣞq.[ziưʺONQ\ pD8IdVJɶfGl:جX[qQ IUQRV³NW3ӦajenxvhtiLDJXc6Eig.bH_`AWvDFa|YڰBһvmG<Ș@T0?j4 \1"m7D&As?rY6 hb31(&X3(g$ t S ز~3SxhѭqE 4];eNsrה۪3X2nkmIo|ToXQA[]9fUŀ@Rpj6*Ԭ}T a(b:7þsMp˔Nc ~$&Sq}1Rg"Wc>n=W㩲:!#m+0S_Ȥ9FB *2IX}hu q )gQβ7?̮q}R~đnCǙhs7E Bͨ`3\M4{_NeaFwFt@o ~MߴoKrqobDE8Ooʣ,y_a:Peb`nn{%F KTP!Cb=zr$xTgpsMk/cB1$ < ? t4y蒜 9 PC0ĴxwEC (oFQa i-gdc]}D/! źxc@rPߘ:@Q.xӘ@Mqs#BHyGBHs;02Gnd$ r5YbEo\RvΑb,`mW-VAW墂ltKá+wl~lzRSc>6^k(-[\2WnݷFlJFkYqXԋ; IWK]Fn+Xܷ]&uq觱UcEв䄝J t'm!-҂ x$|r-qV]^1%! !ŌP^?6glxYF>6o;.剹.݋y¶KwRr 3e">d[Pk{}}ꌾ2GBJ떾8.ݕ=%,(7̙s0!őiӺa8?1seܟ>,[g9HV1'a7<~٣E-V2XEo1M7ׯd!%W#pf]\Nf1$d,Pl?_e|lpЧ9кT!hA^U1~m2DXJF^W1ieLDlc;b}q1 6@;|J0U(ojΰc3໯k_U<64=^mz剃*(6Q7H3ϻ׶ܦ̦+FB^3 .=ߏ NQ?"HR#UѲB?3aX u=s{ս2;&cARwF` qsCJ/8 &X``1郉ayFl =BbSKJ<0HwFwkwg*l/oʐtѾm+ue[qJHJ Gz` syǎع߿Dz endstream endobj 2020 0 obj <> stream xYKsHPqY FBآ ٽ988%KF7oόHHvBؽl"|`/"z{u8%Q;_yXzI|y !gxE֟?{; ("_ڇi~+"Vb'۵g$k#)_X"„I]sY g͋"(⑇wB]`DyA?oE3n!j{!(ۘ! }-F̿8IUUEy JC$ڞ<򳴪]Fml6sIqо=V\}V3: vբ\W֣sߥЄIޢ~f#",emP\ٹY%b8.Q0!! ~]YOYGk^tn@hyEi\%Јɵ*]W}Isd26f[8A8tU 9y B @IJuz}c1 ')fYFip b+&a9IZf PIw0}oLDrݓ(w(kZ\B6M8FהT"*.Ɲ䋁$$תJtSE, Xͷ'c@V2&ZU3j^8ZS* b.xX7Tq wd_uE9bZjR&H\d^-'o,gC; 0A(mlHyYȲ$M-1ҼW T(~pw'HK6ݚ4G dYpEg}|'pvH0]Amu쥃#g,L׸v[eJDw$]MeL04M0lU#9DFIš9bF]Ќ2vQV@8~o]0SS$'gt3?ݺ#DPȣ1=PcE8G{aQy5(hR܈udsW3K_W>_ƽZ|Yb@ؚ^0 N_a; (T滨bǡ^|rG+wS 4N "mDƹ5EGa $tna44V==ogcCcB6"[t"ؘq Mx:O-ƆV 3yUEbeu\=+yi/.@9W)㍦%Ay$5};">$M Ms<,as*%T/|7nUũ^.mDO+AMT7x{spYInOr*Wfov\_+3u90Sl_yՙa$oyXed(Ǔ+%x~R+& |R[JmvM{ TqT\֍سj s1`M">_0:)=B^M2ۃOv {Ew endstream endobj 2023 0 obj <> stream xڵYݏ_a3#~K4͡ -r]%$frHY)ۗJ|oƋO H]hfwlAS9]<<-h"[eQ%ck%MVj(t6rSPI ]Ƿ'4:,@@\Z Y= &փWBJz! {#b0̶AyowlMD*k덠KmYF4g<uHq]!7pcҲZ/SUYTr%Z;(G'X,\[ߛ%sle'd5-V0fĻ?{Z5-(+ꗁ+A'Z G!6EUs#hJ Oz7vRS55{?E 'eNZr`"~JvR6RJAjV_GVMɠx~|Ąi9>Vstlւo (8v`7 "MSKUM ְi4(h:teo'Zf}v}7:7l?/m,އ; <~o[{V_+s1:Smp- sX~V_!1gυ}(ƒp1-xxTqf+K3؅CNK7OCx&8(q nf,r7g$U* 0*'VRPɱÇw˜'>Z)BɈPG_hnX)TD38љ*@CNDo8MvB_Eut9:]Hv}:DE= o$b+PHr~?I]uNmgkgi^ic;`i#ըPY^7a~`=s? 4Gr@$ۗ3os;\!P1eАaC&٘.pgnfr3LՑVP;f[>~$;Ο#ުQJ/^p#{c0~[uj>wQLJ~~Dq-gB] G9DIÁYoznlc=OIb^rJ5;4Ju@ݺ~NAtGv͏I64Kk8|"D#?vRd᧠!YO0z? endstream endobj 2026 0 obj <> stream xYKs6WhS!I6n/uD[L%R8w MȠ_N2Xw}O2L$x2[MNƚLO&DMC$x eIm)c,ɫۼ~ۼW2{+7k~=MJfUQMLZK+bamXkwS#Ib{R$O5@Xnӧʂ')(cRZm(@Tt]3pxM]fÒe?̹%V@(!L#g4F!LCG٢Y)͒û̓m[LI=>//yy|C"u A0.NH\rs[Mpec68#5zr#!;Psy$F#sV׳(3*E1b)eZXVP+mQޞPR#ι:pDF. Afb3ku[U4.-mSW$G jĉE:%LfZt,m3I@Q&|~Q\^B3jwܪ6׫ "#.xĝBr!lDŽSCLn9QpK)XAc8Q3']\ՈBFl)/Rl91b)q{cXn>J2ͻVl0#Wk߉ҍ1A6彘NaDnʼ7 mq؁ws-N"S^~W`u AeЩ<@ x.R<)O.~qZ;`F,4 gsE 4y'-'7o3¾1xH.(80yE#-nŨe"VU6``vzT?lzm&R^ 6t vHwMvs/1`>5^U3d^BcȊ0x.ΦEZSJxNHDվBB; :! ⁸VJ;sHhg/I`kFW`p|=c}!=Nk׏t˿Gh[sߠHi x]lkk3P$][~rˁ[޸[v%Cڈ2;Nܾ)|P(v-/p_܈Cwi&=&{ { $?"[Pp3>3ml4 kݵ킀Y$Yb>Faxx;K;M>. # %$Xr\ɻ MMk}wY uN/'| e endstream endobj 2029 0 obj <> stream xYYoF~SC憻3}r)A~`łS ?EʫÉq@Bڝvf|Jp?y2K^^&/Hsr˛HQ\.>,+",VMo X l?}~YXQ$v{Ayݭ^KdXnX%JfrLIUL@R(C^2"R,όh.ouLU o/PU>s9IwO dWͼu=}S1ʏ$Oib0^4Vs Β@Įİ >' 03Uy_k/|`FC]WɊUu]` R0jAaY;cVep {'9oo7w9M2Ocnn?.1s, bM5\l)e/mPΣBńAqC~D}=ʑ@#bI6q:F2`K˪svڽԛ4B!P!(1#T|Zw]Ժ+*#c^~\~Twdl,n\/6h# $AbH ꨣƒ͛ G{cBvbqJ"#D^nVkÞSЃ.8" 7mc)icZr:!.e$H!xA)fu`ͺ]4cw,Bvw'dٲln+!+(Fy|x=n]P?Xfv}Ug,Ou !X#|0.Q'(3p3,o/^XɁx+5{0t=FČ"IU2p|umT}sC6s \ (R:v3Ewb @6+艰Ql߉b[5j M@nB ]ݪu+5arSPh }h5(4h7xTe(}Rrc9a ƎLl$B@R.c܅L>%N%{>:A; ܁xQO~Fkf!S&ǦfpyAg~N}/~#65$ok@,UoTZnTo=8c\"lqT<'Wd5~f;NC2ĆE3$"(i0V$WUX,Dm:0Mv$ڔE1]?M|zQLb( Rǣܔ۟Jx$:/ APaհR d+pU p~یC6n5krzxWn1 ]*0WO6ILͦc"N=.['eh2e.S"(e8_K*X!Pb/˼ endstream endobj 2032 0 obj <> stream xXmo6_OT.ukEާ&Ȓ+($Ӌۦ2Mswϝ| p$$X׋8AY`p`2PH.%HJ wQL) je~ yήK-J vD훢9{Ac[AXbO<8&NsA`nZw_l"_',t, b1|ŕgG  XO#_AA5J#p!A5 `Ҁ2(FAv8`/Jy}6YNZ.I-$zp'cH;Sy />?a&Z f 9Sf&[ Pb.YJmTS6lyLk$>s>WZr9p9?ï߽,>28$V19XARȷ7 j=l"M^"Cnd ܙLTD6Ӫ6G[Pప;;3 PEU9U^ѵVsE!o"Í{Xw4y 3{%OpHq]uje3Ngh/V`?eyq93!,rt[ ь]^^%:zce-Ǭv!>g08*kv4| <+6L؀r8vM^TF0uk-TDl1X"eTf{34JSC]SFֱY8W Wr|;=e͜1Ї_3Gq,'˙ N3usRe l[[kUDCa:i ʤ (Γt$ۗ:X$,1J'e&xjΩ |1L !s:yv$\2 /u&9]wvr.P.:""\T%ZvE]aQ e>7|5G=(K]{ip\qә/yY>G;ZeB1:o;e3/7ug~FY;Z͗ZP=<=n6'OS-9=(lLw a r >9gzg3 {h1 r:ͧZD7~'CIR xO=Q00")#K.MUDeZǫ([Sr=(ʧ'XLo\-yAt\_H|?Lg^z6~3T{(x"^/Y endstream endobj 2035 0 obj <> stream xYɮ6+ЈL)@"@n.[~jK- Џ堁6!yi"d'>F$D_7ыr~," </WŶ-wI eS}'I&^.3 L9H>(#ܬ?uo b,Gcb֮~XD(~ͶX -I@U(0gIHpS&̲]"H\6%K /PUR<7==6e0{YKrC,I Ds (.zbV (@U5OWZ/4T+_!DLr͢iRjxhnER7Vc,Ɛye:?^XF!ð1E䎱̓gK\ 2PNhO!18wڒ؂QDς%!N6q.esbCH9"Xzw>Zx(Zx'QW]cf~kΐR]:)䃬ik6Q+3S2-3TTJ)QIϝ!c/W"vayySAl."~$3b ʤڮtTN.v]'U|J0Y~#&@ck.λ3MlQ*";K(SHHh1E3=D P";"*\8jK4`;܋}y$uCvtvEW0#GWDN>Mc亨fp-J/aa[ z]iDڅaSjM0DII&LR1&%- P`'CylWQ?%FJ~)rE@4I|l1:Ԝ208%Tk^?CD>rzNSr~Kh`$2\Դ+)yfu>C/Y/ۏI*(.݇ *h>Q`C؇e}䳤o=c x̃H)@SA_ŪB" jè3 ݡ%XZg( :&gW}mi "t|T1 PX߽ŁR]>2U&yZn b@ԑK0ul§:d7{b㍑_B[O IzsJXPB.;cn&oZ~a/{qv!%V0}mBh{),/ -]%4Nx@:et>1} /W+>^~9zlf#<&~S/j~|]}=vU@'!m//LoW0tz ~sw7ݮٻCx~ޚ]hzn nD6n>Y᝘|U=8!dvo_ٚccui ݙ-(mqY9?2aȥS;5y ϫuLH(85M7V~ef\]oS嬋$dG wQ-!lp]ןNrwY> stream xڽYMoFWP@~N\ v{rĂ"ml?HzeI$r7;!Ap lo.I#D nS($}= ))|=0SJô\oWETcfsYQȰ1V\b,2g 130Cd6炄EmYBö̚*?;kt(cƌYD θ[W& Lku}Kfnيd[|v`ּ֤y *a@w^)拹ҼEoF$Q$l "g,?)$Htq_mycF&Ƒ TraS۬M>飑=_'HVM[:8lD'!:.ailƣ*jsQO Ǹ Or#FJS-$I0-k8BÌiR~>D7ǯhL~l#( N4:=@& @>jy [GD2<>BEczǜTYQ&/Ӧط`% ˙Z"}ا ;~mZ-`vTzh2a_VbP9y˥&&Z8 tHGN`Uk%Z75RP%a\Zm݉@w3kK 9%^+_}1R=9aa}v"y.m||BiW>m9LG>j"xH.f~ 6N-lnx,$QGa"΁CM!tsyӿ +3~{f @N'̢8.]=J{w,Ic}fKyITygHʼnYsqg[Zrd%)pEZqq( |;?8O_&TC"!s٢$~!;Hn_(Oelc{:EH~G.8AFLu8sΛ6?vdE7(2]>̔{ՖK0/u\W >ja}e]$c4)T<&j ׺+˞ڧkSjU& U:ͷ{ PWB]&enܷ $.gװӄ? KkZS`>S d |\{Vl^bfޮ "}i(X56j>cŲ۶9ᳫӕYޜ)kĜm^-sd/s|`/DzCIi*Rfg(ҫQ%Ի(*M\Y2Ger] tۭrnaiMbst*uu4Ѝ붴Ӯ0C?WecM/Q;}9 endstream endobj 2041 0 obj <> stream xڽXێ6}W-hR$@nۦ( 1q6VI$Eޡ)^,%/"nr6oDX,muEja9݊*!vx3$aPI8mU n !Ů.O dpSnz(GKj[˄c2"<nQ,,$5a3͋ >e<]Ϛ\x)b4hˤ3€oIX^葌Yc7)w azqKR˪o&j%R)讈%"Z}JuT[^Vi GWf(E;5]{cLD2Yu}aS aa!Gx 8x=B|\K¥>,\K`2E #U+a˦AqPDn">X8d\rX'IﳵiĊX*i:p M=֯[뽯;yY \2鴬4#\ۆG"|YoL>;|^{)>vQk<,R{]'{=]ʋ(& Ecݢo0#sȖ ťpW(rxՑts[kQn[h*Ǽ֏=o0kEcEҤm1-jlCb3iF'`goIFe8Dfed(*iF$_31*c]XlUj-CLo a ,;vQ>*`ѨPs.4M5,?S'3YNݽLϵ׿|pB*}hHw cn/W *ܺh^a6T4kovq! $ @<ʋX&T xB0.d60lŧrY umw"w^}6SxL3T8=m ٶ|sy{83{(Yn{κs^8xay8ѱLĔ맇(\yò} v@*b = +//iW3c›]n3P߽$@ӡjGY{}m΃%H!%)+g*)' dH$B_z~Ɉ'*'}9qxg)-׉^v,ܯA,jꁔq uF D mޑt@%n]|)/_97 5\4 endstream endobj 2044 0 obj <> stream xڵXmoF_bذo,DjKګNU} xms"|i $UzyfG^v罾.GC n=I"bfяTt8#Jq8mv//ι+\r'.TwwUi7;}[-N r=cMbD"!1Vַ Ey/d7 x\VKMbg6\, C*Vz}x3*cjqBADGuh(CuNz6ʡ363qPNb݉'7`N%ё3J\_TF)v 2-K޼_.I-8$<# Uq9Q, вUkAP^+ F[Yywvj(@VPF; [CP2ѕM`A8BКB| 5#SzBxWm+.ZA"h`bϹm,(!;)Q†_Um 9\c5OFOgVGb+Yw|Q4ՐK|.mY CD}ҦJrq >Mr3Ebt e?jܥbCI_({J1Wj6UUg{afvf'Oe}@0tg",rپH h&G>Ӏ&`pKϋ5uŃK{r]!R7}|MvI⽝U *Ysnl`vYl ~5G ! hXf<2 (N`bTM(P7>o4T/41eoHؗ6ca{^/HOНp]MW]ӥte lyfDlq.XL/r/Wt$ebκ}gH.)p剄u(x6FϵCг4CG rAg]LzYO!2&a#;Ѭ"~ <v(3_\3K&}9?;\D}Kb˪ JΈs_J/] lre|wÿAh endstream endobj 2047 0 obj <> stream xX[o6~߯d bI)M[`0`M8Zm)uwC2K%N0Ā.9:#?PcAGr |$9 .o,&ȂUx)z.8C&N"#p𑰾H^oJ"l$T2kJ/6*6sȀ-$)`QީljSZH BFb}T;lQ>̒.l`Y[16F,b$gl~aFUfߍGnzmX Pj!̆…)ʪk/Ku c uMUs rNb ~-.B/I2\. B"XIV~gB01<nR!bPZ#%d;@BOqsPC&Wd_ǔDF7{ W2lsWܪb@` T9[QmhX F}6)ʞ|/Y1Ⓛw#@FO'n&T|)R^T/c&ƶqn:f`+#Hڞ{Gxvk wHT"\83;*?D*3ꦷo4WWM3wI[їiY4&l:&J`QuX & `ԣU.fv_C&T|E\I< lJ/"϶]㚣o-/]{杄t 1z ͙=xR l`7'ȹiMf!8VvuFͫҞ~ժ6fE$WmL|9 4o=jԕ 7elt/+`BngJBe󑀤0֕Fڤ* 9vu:Pdi "yd2GN̟it[7n 3`orCU6m ;~9mqyBo4ewQ endstream endobj 2050 0 obj <> stream xYY~ϯ @L-vtg,<ɋZj$/S}jMI3CCͪ:::-#$Slu&{f$dDgf1J/>-"|m߾~ݢ`~o{TwM(Wwf*՗oee] \ ^"M㿪t^OX,-HPD!ɘ`<̉9].@A4F\ Q&|(2+,E n AȀ.RVq(~ bg,5*ќ߿%y߯} B=2ij=2 <Ge 2|鞾f%VWNEs$\J}cCѦ:UtK0,A S8d׻C,qBoպ "P2ȋ+") (~6KLެ)b i h~nMRq*.II[R^sJlVl6ʹ}-eu(y5Ӷ+D̿ꮯWnվyceoڔ,D>`bX$T17}㯟]2>7B俘U_$`Mc8RfB ŠXX#{Yu$#A#]5mi=~[s< m)H|Ai Ar9 CI!J#ľ"@Cwn 5 %Nfbo%7O)䚺&b>\L Ňo6l: KϿ8`bӄV!@mXL`P%Eoh' P)Y)5C'Ι48RRE_W}̓> tk ]|7Jf 6{dM h4cs@J_eJ9Et[5I谄IrM:z:iRךDBBYR\9ILB+z9HKqm*F'Al_.L%(˫mKQ' <:WxUʩ|t4\piG-ϋ[*=x2*K k1jDQV+˜\ꑠ $ݼH$eYӭ`zMk\(-4a%9itj!dzBXO;Y0ꫵq@KQfLm-#wjs}URDD83-)m6>_P;_0;d\0a~2s05SA]םϘ.4|[sHւslOR潟 E!$h]_7JD?EǨRmǪr5 Νr`+󮹳@clצ6 /9g*DO)'Nzz-/P~Hrymu6G{o8MS9H_O_ƣѤ͉칍Ì6b;OP_ ʘ$)WlpVAeMҎO9~Qx()*~1~7-Ǜm[ endstream endobj 2053 0 obj <> stream xZێF}WPfߛM<@!B^<zF)R!›9N] MTuթV*?%|fp$ū (ejپeN7Ravcuvn *@y\ԎS1Q)bb"}ۛcNx$!5a.;`r2U an_zANo> VMn;Л:ٺ -x|+)(xՂ@@ e_+*+cɢ7Ew@{ucPͮ>[g5iwqh!kȢwXVnq;?#rDka$aCÃk"#x8&"ұ%NP+ev!X!^FU՝_hH&佪,v 3Xp8(ĿvV %\FkgWe[˖'GsI0iLD0pwكJھ{'!\LhmotA}yqJF '%t~;DN/'FE^.60y9ªWECVC"ɳNo]?Af2*;V (I^o]hnI}IxǢB,Ogn].LCqE>탪/}OCЃc#<{^gwK$ 9y$^RȜ1HlKa؝EYyMe"`7CVƉBf6[=}("\  3"79GH c-#Htn`C؅' f'OQ3~EU??.dIQw/ѐR9eɛAɚDR9Y~Gi 58it{,;w>4) %z癟пa.z=jwJADn )!=mƄg>t #1P FF1 jo;bf}<`ҶǽKim̍M|r.k=>e˺?6*\b)IzKm v!meSU7+&t^ ڰ' iAV ۚ(7@:kf#x8RNN!N_^S.sJ`y8S"K |m0wAd (Ȧ)``%kP_ „O0 $œSDeNWߜn=Ơb(Ex!F⢾/K7&lhf4Wqa׺Ζ!/bҢ:/ױ瀥);?e$RBpv F:y=H8bS;kz v(* Bw.{LhVK'@'&zDAp򹡻vSeMrz$Yܭ($ׄYH9uMIY|VM% ERrx> j@0W}DX}6H)p?-0/b+y. Gعlfϲ"Lry)Ae R@Auԩn󦰟gc0&e\=cs| ]l/.7%m«f0vN)Ӕ=/S@t{sݶ'"imH|G( (g f1d|gBNɼ3!ն:pu{&3\ *׼x!Z5w,<)$] -o)h ObH'284Smt]q1 O 1,6! ,݉oHz0uSPQm`7ˆDn_0&Ѿ2x1MaГ=].9q7yio a$/(1n CjRoA`𤃝gYqiK<]^Qe_]擦*Jg&~YK* endstream endobj 2056 0 obj <> stream xYYF~ϯ@H7<9>D()䁝a( wS}l3H-@SWU_UF"aGmw7ׯhD0pFa(its%SLj27cޙo~5~jW`h1MW㾨4YZׯTuLIRE1PJֵA|[g.H,B16ns5ۢʀ 9gQU]PDN>(qDȮ.,H&(h*Eb4;۾_CrIJ3CU;O+دLx!1a PbDx` HxJUoU$heH~ t5F6?BZAWlHX>#Ѕn45Z)!WY>< N}YR`fT/0H93H!Vc[GŃ*@N,ʚ ǚրmY\ؙdZ#X`ʫmօe[1CXS2@ KbM:f4d;cvx Q06PhDDV)@(H,IQ"9 G-$BUH6,!k*1{*~pq<$}W NpUcY ` ~jz(6ƚox+!t(aˡ\;r)s&{N!Wx%.)dgӸrq.˜pXPHⅱ|fkKJIx;I).Oi2ϸz.J ^@Y/(C }e6n%YٮYڅlʣ dVz0N:N)D<"uB2ɤ5]+$VRޕPMO ]c[XfLwi{$Ætҁљt 9pI0d@Ow EdNM'QJNmx\gr;&ADƟ4MezFs|61b%qA Iq@D %U=B6Y=S 1:7k+R~%X6M $$]lLiӊ6.){E\T3)ƶP*oGs{״3*}pS+Jk,puO'%.Xio=D9~f*t #_L9J ˇ|oBcPLI 6nv)V_nQqfq;>afU gH#DMu:8oq~S8 ?o;51j^$Iɏ03|Vtn`谂th#;)beeYzCshzf\ȘM^@Ͻ/Fo*IOXBp(T=4zTbֈy-.a,J޻'̊*4OWKRͪ|P0$]X\v x~ȷesf΋lЫ (a,\s+Es }3ve|`^֑7ѻ:ɇ@B58W@؏XfU/8^$9tW8\١*υr"w+tGF,S/>CKQ_vk(VMSӪ~4oe}8 1<[ʇ}[ûs%y64x՝=Rdw-$uY1S*7?EbT_ŀ$j=!:Jx0GaoO8%#mYdYw>˱ fT1A 8pmMrc8- @D)ea3LO|yx&^:j XU3~ގ\=p'19FIofw}^xCKml?/i7M endstream endobj 2059 0 obj <> stream xY[o6~߯:`o"=u]t( t AD-4~/)& !$SԹ|}p4NG$)REe)RLF'UfPJc^Xڢ}:#bf@Vo$6/O3#(a I޳xy5K8ae:_7fm^-j:/mYm7,?#Lj3%+-Gl^0{q\@Q6ҋ M™UiҞPNsƇ #x* wHwUnEfnX|]Ym|Y,}wKyv-zelڲt0_*, p[фS)$8cj)b^D[M[W8ۜzo|p{ŗ룙g?KE`~km| ,>.MWB0 <7Kg[8DΩMΛ=j eY4uc#᪸z1 av2Y\$K@QrNy1Ȧ_ICS}2 %RD݁?! 1˱nT$/&xdžgDᏋSgӦ 2G{S- *zPr!bIуvŸ^8w/ь!RΤ%O " (g1A8HHdZB҉ϋOLҸglkZHf9jaqp-@y+?=5@IR 0(85<>=):S(}5"Wsqcc"6(2νx7RY(Ͳ@' _CUuc!u(1ͪf]kc5+:@:%oWĽ#y1,_]C((yJw<lO/ySZMS 0ЬѾ0%L^0v6ܪ`FBHӔwʹVuFR_XʹWg L#1ǐzkڨ'f)C|RY&NAX!f;F~xBGwȘu\v0+"ܠYw2pyӴ= L!1:gw_lZܩfVAe?{oC&4)xfo`5{M5 J'C&Ŝ<Xwc…y4a(jMu)S{1Όy 2=@)$u5Ʊ%fqюNne<ޱ [Gu7)ll~XCu$Sp?ܺK!J9nVޖe LHDn2ײRD ˲aa:lu9C,ԒftjS6=O!P'mNɣ Tc2lN!mD 4釺*Γ;%߻z6U~n>}}L$73͝Lgߑ!i(mM"C$ >:7`~욈(ZCrܞdnb/^>lbFZbg31v슕H] }q%|6ô@ bLNQ;;wFfAˆE57ODXB Kx!P':^64vjof @]&8d5)8[4cQ MF7;ꛏ? Ygy endstream endobj 2062 0 obj <> stream xZ[oF~_Arʹq8A_&Y(.ڍ@K]TH)=sHy]'-@Iws&ѻG)HFme+T:y),.o,'?F$_߾aPJ^nZ]ۙ/EBxuؖx~ RX[-U&QY?8w L0 leȇQ(Ւ}o4& Y(j$Խ\\p^i|. hYl/.E9]hpUCEgX1A!]V(O>#ɼ[k¾..M r5^«ؽzWBzm$6uISDCZh gze-Ft[mݩ/<d$7e]=>Y_-xk;7}j40C)ɬ}MK+LLIД:x%r$|)))Rܫda ȤjޤA S&U1:פQ~ƤiYTBV4Yi(|n JFQp0JfFiP)sPT_W/`\23$(( ^bAnj$VǦrpOr[5)\n`"; J֤-W-S4<”7_ݪvʗN:=vl } q{<2e|PiYIuMcq}[#|C Ĺs5laL1k{ˍ .(ʪX[eJr sXwдvJRϭPC=/9 ,o|K!W67Ս+nw D:n_-nOG{?T O؟%l,N,wn/Vw^584{]6Ū4u uWTSgoWw(n-ׁԘC:ݒI+^^lwQr\]H8a{yV<~Gkd>p.rߍᣏG?'oU#޿6M`G9>lǃM/2z1ч-.tnqsk]D? =M2sj+_,wn?38d3bo#^:`2R˵%J[=`@a;N/Ox"AG.4_d|{ѷ۶"(@jT c ͅ{i9%1\llR.QPY⌝NRL#Ywgaذ(|xe,ZxSlM16iSmsz'#6taCD{޸֨XsD-QS>pL`}GkUŌSc`+'9T R %8CȅTBpGTngCja!{`uHr<{TN*@#Lslk9o1r5c`}|Ў 4FBCY?;!* %lq9>vVM1rٻR13K|o>^Λ:6hٟ07zL?Ut m *m #->0t 7U<7W9ݩŲN~UطӫR9m}zb9l>s][ ]cN}{gٶfBs[u*㻝9\gjluY\&fQ?@:kO[ڻ&&|0JcS3uN/ҘMƽanwץ_'z7'@(uzi3jI+nJ`u ;APUp?IG:7O k.wZg7P?Oۓz= oV+-l:Z=[.ځ{_LS}l:7]4 "m胔Ip3x-{eۙ2J_4U׶  \+ɠ~@F2//Vr endstream endobj 2065 0 obj <> stream xXKoFW!Tn]4CF/Q ʤBR wvHi)mHQy~ x^H"[px,ptfj)L-nMkM)f˘14ˏ7?/HPjP=}[- (:^*f)̜/UkN~bCP'x1 aנ˪ aE:]Zwfh57dikrTĂ !"@:2ޗY[Te'Ƃ"iT˘(>bBSjbO-^wpQQ4ŧhV!%C Wݑnfy0Jxvc)ijR5"J tacމr"1&]m_ˇN,#-;e  O.Js[;_WoY HLFHEchY :̐'꡵_ 2 MZTd˘q4wG>w߮2dtЛ ̀џ}"KgXUA}ed”6nSM!w&-?/ڍ\ߘl,BcGE  D ^&\[nIE*N}VT}{;/Q5]Zԯ|Q&dlZCJ`%0d Gs纓 1DY* b6}-@(vmGDffKf:Y&]':a:̗A&\+"SE jG ldZk?q>CӤ] 25$(QZp$ƌ( Ȫ`:8U t 1IU$PrٔrTDⶬ,-$S`| "T?dߞCL3)W[ޙ+T~7iҬwIJ'#ǡK#}`AhcL}0VbXm1ClV4cJ}x4Xxٯɠ} &bFc)q4 aVNK 1~roRbG[~ 5̐`O 12S-I8;JqePlj~Lɷ4x&4h.  azT5Tmx>Q{zɓȄH?9oX|Cp:Z+LӌcI=X4`fkM l>zk!B ScRkS 2@,fPIvxS!h{e" 8ĠgUnWK`2zTD$U: Wdz@Z]FB׭M]tґgɋdTޮع*,v^xEIY^ kl$l[$D9]n \ ν{Hv?RHMpnf=z=dwїΉ~τ,q\6xt_U]Iuڟހ# e6/u&VD#;bĤ$ѱFǖ rt尷w~8uZh˜<: g\M0d.wȦ:ϟvGfp5DLpNl/FXn$__v %m:݁/ߗ\ vr|= ?y@[d>`LOv;-0ѽJ5LT16ls}sak3"-cGYv ;z +,~o endstream endobj 2068 0 obj <> stream xڽX[o6~߯@*}v0ؒj3P[rei..e:8i:ܕ|NHCI'mu MFk\$D%!Ur~/>\PF /]]d~˻?z+o~w_ՋtuؚjAe: o: \2""Q"9MwEl=Д"}fYzVmYW:l N2"QΘ"gHRib+)w#Dqwk7|אA#Ir- wq΀̢wRiDHY̑0rVUYX<-Ĉ ˚q;umnæa6[8Hsڇ3 Hy$cāG)( R`Ybٯ>|@aCSYJ 0esprBQtocci DLlLHnGM417I3akkbU7XպnuF5`O! XLjbr竺ڛSEYb+ӕ2 TAʍ'ABpH = kU~x9-ڠ-T]kXU$CC#2RHI|mmJqCZV epP EҭuilFU(B(ܗc wam]YvXD]{ߕ#@TFσQ:E7?mEg F +03+ M[Iii;X'8Uà$xi+cAE޻JAyk54cn įhk `6 KLΈ^.'ZF4QDzm;0N4 SlpG*`FGGOP*ω/z;yDH͞.o_n3+Te7g-iw > stream xY[o8~_!tFjW[] /uIH$'=ɢC%bvh+}\s=d$dmwhF0*qIMFTF*Vۯj?nd_-C_|[=D ,/߾D BeX%R۵ýnCHW<+/PLAlI$HdVR={*: %HIIaI{/$ IiaR%< &[8-W}kP I|NĈ "V $pڕ`u7tJ>jڀ(p"lu_6v)iB%eEJ,%aX] 7NbL#ieU`=3Y.ApW NtCF^HD`[hoNB skvgS Q irE䌃N ,=f:$dj$E8 D);=+ Te(M/HhKlA "eϵ!Ae%Lp2rOd8{)y~8Tt%hs mhzOWy0C]u|?z3uwNVDA><(2P",{oF'B/ '_.&Vی%c5Ub/~;}1;B9˕o~tMYkCW7ף!\$DfSB C@rNdSqNXi]# Ґ/:9CJ0 VT<r*S꼏F-ڟBPO`?;=m[/ӤO `8sNٙmn /N4ٔj_uս}70k࢈en|# ' lZ/m('m3*H{᳝>Q#}No*аcgXzR)ۤa7nPh.kkM4n8?g6=X՝{Z^~UI9 $LVw>/`csN ߽Č^iZ$7XhK 8xMmRYͶUg4ASq!LcA=u=) 1&yӍ1d#8@$, ԋ.iSlp aDNcrl+ۨcרcר ĈF~\(h\܍cI󒣂j>f;\'hg,&O&J#@ό@j[ȿ~2W跔w H.kŹ/'J/Nn$M5u\|pbu>u~/?q5 endstream endobj 2074 0 obj <> stream xYr6}W2&B܉Mq'(LjeR!8wq!Dʀ.Ne1ID's\r")V$WRQ_B ¯o.&4UW痿ۋۺ,}lz"onjBdcXk륳~)T`fj͏(NI<};Qa)'OA>%O2,XZme(_%̈́^Mp,s )  pK*Q6j9 ̺bFTA}3AviYBHo$tV"zcZa*r?SA)FY:˶}HV rUB3B$1CaA`7 ),\`y.`1pKd(Q,(gd`5TK9͖ExoV‡" ߘ$ `eܦ-v\ZiIv 5!Q|ٖ&f*o\"V6Zqh j`uI]K_G6_ǘfmKp)C%E3#E4Ǭin3mpa) ilj"WЇ3L|69ʹd6>5eL=. c1 s&t^^,ti)?Inc_m] TWg$Tk-jary8^5ei*]ƫcU#("LaD.eDtjmT[κ2z9xW-lq"8b'|8PHcpi[׼NKl= MĔ( ĸ^VƇ"[v*$/Lai,Z I[=G=k"Q9o*G@ju18 UmRTJ84[2FAqeG3DE'+mq=X(zu Fq6d,V!QCo/^E*exz5ha8#I5}dӉ3 F5g&{%Ihec//^زT<?y8ZaI_ ~1(֛Rl&@;ZxSvtjk;"yXQꖢI(A{lc Y,o-,pLxQ ԵGNˇĈ0ᡨg l qdz>T!&C1V~I<*eBf1phnخtU.fU#ՔD514sb XUG XmAu ʟWAIc"Gv Xzlʻӄs3!"JDz;Mܷܴ8^CM) k:xAb> stream xZK6-T >*[IvVqKe>HpF3ڲ !Џ 'P/Mu;0J2z00A2iՇjڢͅ)/gs)ezU훢qD2E0-ָ޹CF,0MvS>4v3-;5BE9YB(enC=S,oQe@:3N%sYM}6=5*C$nڭM[oөgx_bN 'Eb4# ɃەW^dI'm͗n uHܼUt2]օ8@V\wN95`(kSٻ6U!@,!{aMFD\#?wnwM?H ȭAt æ CCSyr'N3%w愱GݙPy.t{КdCXS=F-U^XX R&2FebщiɆ) $nL[tDf En C5cJȜFmCn}PgZ>?H ĉ*z)2]Y, {nö]}f t=B2)98_.zHvHZ.mnm5 Y.8"q[4@omN&*^ t5i^S]@/ot<bUxN!%},R Q*,ӮlQڢD'}sWXV`/ofԤvnI{]5h)l|W9QaIς08u"FdfzdO  )'.pd.V% \.!%#dڈ:O΁ /b7̄KЦw$˗1Z;a ]}glT"]0 :!\؏g^,ǟSGVy_eA`.ݽ}>2D\BMX02}m>+tt.q*|٤T\YG8"6(տ>dً%T=K<S6L]1!2 g%8 ΁o rOIX-MMķdBBufVP24ʷ[wXљ+= pV[!\fk!EJᅥkﰲϸu`0`,J r#9Dg*xxY۰cf; 7MP`HF &]v6UiBëJƞ>] 損u6E2P]+Wtw>˛`pl܅lWQ 3Bu{0㱬N l6d endstream endobj 2080 0 obj <> stream xY[O~ϯS-5{y&M4; v_`Lw58qی!ʏϩ/MzVD@lu߹8$HY'J]g(r\LQTrNRWI%HJ o?]~X)iQoϟ~q͚=YJ7WD=^*k#Pǩo̘%qX,vsލ4}1Vۢ/ܪUL>f9Im#0#G;FUL FلS[=9J$Z3;Šp7SڟLrY "dN8]qGke 7 &>>o <5TfNU__#`:o`L籷[ߦrD9>ng\3uiy3B[AyB+{9Zm%V̓6Rtꐥ2d՝[(2NNjH$0j?:cKLWɗ1)ظ o" }B .!*L~Z(p|*{(F2ǯ%.)II9V׽*Zp$A[F%gnV.fAag j|5Մt j*BEUBZ%)}_XKe`Lp:#hɊX36 _cǨ}!D8x@՝`l@y*6pFJƺqסlB׀e<-X]J`>3Gr1!Q._a)@p|ϓyƆ`" "Ay(3]DhM7ύɱ-ͽ Z՝(ne݂ɣʢ*)8d\(=[,WEAkP Näi# XGCEWq=Hi_j0oD(!&F SJo4xt[KQ?3mP\*NJ*m1x"%eH504jEG~"X\ blS820gyژPƋe9jR>dКTB|EtB%Lw~cRc. hv}xPYDs0 8!9IP6)v6iHPv[Swr'uc0 yG9Cd(ۏx0(RC]?q) Oj|2 s@|AʉiF^~9=+ެ᜺9ˤY;wOv7FG*Ya`t=Hna.Gwjf~6Nn,w&;ǹ%%'q+&# n>X}oҟ|UBl.M56-z|WQ7f ._qss7dyp媓dC~LImVUNwU|][1Y.}5bYh|!5]~MFB;0Y'rCL/j> stream xZKWa%jɞ]CEdr% (Tf'ȏOUHj"aA/-؂0iv _0J Zvq{OAacsI+n+nMیNniޟVwgn`(\}*w+l&Q;7_foi ".hSRMso*=RfaNjͨ, YYr"V$yIPV\W&3bg ԜS,7jZ}^L {bYdT~A77mU"krL@؏׻ @p]jU`wzO%DEyxh"y $Q4n6m}@ɦp(sڋjjV ?Vz, 0L1:0DZϖQr1< L]!agYyI%KͮZX(pWA҃@0uV!22Q'(ZBxTg8Kf8J֘f}NސHPܐ{1Q%6]]mbJƨR}t tHә> % ]mΊa3I]JN/g @z/k\j9uF#Wȷho Z>6yǙP]IK,/ qO .H[ {OóO(foڷ&l"8}]-E]<$|y*)"*l z;#H@.kz'))31Y}SvZK]Ns&x `:jrإ!(BLQ<) &³ZR8 x1#/^5ze>z4-?|[*x)RaA.8m 2\}:½Ec/N/5į)C<42 WH} fR-{%v2+m l0NB(z2Iv '_AYi.GMW(S`[F %؉'"}@:G$qs$cuRZY>˶'!Dе-2+';Q7e=ij~H@6l1,ɂdAa uH/< ~^ endstream endobj 2086 0 obj <> stream xZ[~ P sqnc nW2Hޢ?g.PR8)PQC9߹}scp" ˓.Mk\f``4S]*tzcB(ARR]}*EOfkj{ޯЬ2agi~NΰV0dL#6LqqҪzb/9,SfW·5v5& ii0Α$W_'_wU CQ:+ˍ)Y6{"Φ.mٟARzLlYq(uQ5zSn 1Lcmrt/? [!AFwo[7}l;l93`3P 5QC[tc|]G2͡@_ v߈ԁ km_6ۘXKD`Y_q DB aTw)˸9buPOl "`yONХPBx _.1VHH}2#6!=_V]3X 0&aTIHuVMLt|ts&xw!_&&S0𓯯TX*JM }Y֫yRkWM?36iHӯl Qm$?Qa[|U Z?*Nlh46k`k  1%ɕ<}z)},~mC fY;6xo>,A@A;Z6JE,sh_+9zv.4bZJ$LˍqL_r m\\")hȱՂ༭(mcM4 ,c-. ܓ@p$jMh2p6n*k]x9(i]["j\ ).]:9U` Fߗ# 6J&\n?wC6g.*Hޖ (zsۘ x_aަERnp}k>m̾`_Ή|}`_ W(j2>ڠ@s?X7N r'*>Gaenxӟ c endstream endobj 2089 0 obj <> stream xYm_!@M^?pHNh>'KLR쫖R9iE.ggyff54óL/f/7ߑ.,$-ga$fuT7)f71}61QIK|j_3*/nU͍{jP8 x^ 9',뷛~З<{uNH e>C-êVX²won avX=^V OZ \PDKF ,{VI)GzX$isٮ Fs69Ǟ00 ͠vcCX8/ Pw)%BCI0AE%_ݴޏv`ɐ 7a/otKQk_-U7aFI~sLU cqюnʿ"N9p6PG/~شM XvqQ(c[ޭve)eߩ})hh'pn~k;}t;8\saGaᜈ Cpf*$Ȋw6i 8"䓊* 'v5 Mɤ1Uwڤ}^L ɉ{%qU ^pSf۷rursDЬ}Y '%>I i~ I 6^XuJ8j*CT/W49d/:UD#ُ|έlmV.QoACX( ۾O94odA]\_F:SuN>sJ.APj5lWcIfq-.N{v) ̶N-<PΤB'O%e J;.U /$sTg￯]!eoV%z9E(5ebGr)B F-иJ˶Uvb'Ba\`b<tb-Ro*mb7a9۪aa$N7Lx`$)@q!ܒg Y&3T0zRGr.G\ { ݐT2 QCENI`O.כ{K>,w@rS}>dB23橆I QRk&7c۝iâ KRwIS)=qi'?&9H)Jmjrh'Q1k'vj8tMQ@qϓj٨nice|Фd~^%B@ҩHK3✃Ze)u'(5B jhKbT`y5PNP q\"B!yp Xs֏DDVW6])ǿA5DfM:%(B3]<^WIt,uݛJiyzz%TxzƜS]usY.sZ dGlt<,a8W<}q61l/yr߶ʇl8 qq98d!A7DpRDZ F9ۉ}yoä87'E::l0+\t!i7&jzz"41H|E#Xq̿D)eWnWul`vQAk^]oA3T(jH`e)㼛FQ FU=C~Q+~߇J= ㉯_(٫nLJ޳)pG}zx?8 {=v.^`m0  $ϹW(_sڕ"ht8-䷋7Mag endstream endobj 2092 0 obj <> stream xY[۸~P+D*odʹ/a=$2"iJ-Wq"#ˈx 7]jK6/π}ٚ)9C0ԑmٴ!6hNXFl4m}0kD"-2B5=oBD9"Z )J^"Ҝ9 4X?U>,>;TTОR[kx1U;ۡ]Y @)ien) (,,pѪ25~-IQƒ $*miF(~K;i^4:%Ƭ]$yn?{S>ޭh\PwrŶsDLKN&L d~K OMP$U.^ .`[VA?.?fRQ (p24'Ķ6Dc3~SQ3~"v;;D&?u҇a,:8`QWC谬C \ s2w-n*Cu~Gyw[FMN]Ŋ8{b|m(<4 ?:>Y9j7= 2scp`$8S < |`i` M21t˘\v:QnČArt54D6Ǽ)Q`6C9 j!63LͥK[ ws{-wx-pvYH_ֲ[J U~ endstream endobj 2095 0 obj <> stream xڽYKWRwculA$sr$jDD"edT"H36fwkm&NV/_QьM7N L'%+\0y7K)OuH"΄}E y%DgI]v#%&YN;e)Pɼ'[mP]Ę*N' sɒ(s.1z|sV]YW1֒9Է8݌qӤP dL/pfIP;')cSϜH"H{( w \sÓLQ6ϣNS">)CgP [O1L0glΩ}`=8YC9*bҞ9# hadYWXw]PMdx6Ufa:#4U#X1滲F6/ri0mP e0 6(J[?)]  gAl\zhn.)US<e--4;3r+i-ob@Dp'sRֵ{bNL1)mU4 RcCp G l# @q9rKAxmm}l@v;b7ݺi1ƘtbB\۽4;X_=|uZjT)kʈ5V3u. xGR<ÌOPڶ\B[uí!/e6Yn>4>&"58j_krqs30nӠRI+9RqURvnM(&2Ԛ(E)~&;]}jEN CXvST[ y4,ڜJkBx P'kPt(WP|*>A? {BݣNskg t6jTɻGFԔUyr:|pƙ 榔ar)rPeRaPSg0pv넕(Qp ˍ{.k\ƯJ"Gƞ nGٺUHV.JBΕ3Œ+*Ϫvχcޠ|%!4X؆gŭ*PU5K.*XugVƾy!gh:Uo/Wǝ#N ;zrxh2~_6P6f0M"YzemxWn:e$`2;`E|D>@]SOW-$*fǚSe/C'+.8_8_?Z̭ULM}hʼ+ n.7-FT܌.8~2ٵÕ]ko~2,>zYA;@qv,eٽǗm0Bql>|pRDb˿c*㬂KjUW]-0 LRzl07E< ֫zY M-؎e{ D]Dj[aysJ`fhPPbtգ'#1} |uZ )q&>뢲f|TUo7Ox7 oha' 2lYu-?Wsl⧚?? endstream endobj 2098 0 obj <> stream xY[۸~0RWSM,LɃbsBdɑ$S"YPfECQ|~«$?]m?߮~xCV8E:xu{j)LnwB۟V$%wnJ:+w~wTCU5[7GcIZoOSn\o,IwK4R^ߚcWeV)ٍ@e$@JDR}u*,\?rmڄGm_%L]W_VF>LKD ഏ p?Ɇ' EB;KDNyP?RM%Q*)%CB*:ZVm"UBSy K F渿]Rb(jCR{0ƛΫz16c>;sbV]O's#&.s S{W( *Ǐ7~=]1f9Cnb$x/a" DuzՔ~*L3 ^6z ].A IؒU>`mhEi|:/dw@egQx<i'9wD68.:|:sUIAq3llg7I;3BLSHhYQY)o(u$]=*ZҾh:Z4iYoM{2Ë4ebUiS`ҪpYTJQ t.MQH]T+Zevj 3+j!ZZTQbzk;+r!).V.Do".+o g炱 D]2ԜYH-Ugڨ{6 tyK. !1 a'g0 9Jqiu}d 8W=$qMK۵w^s=A~ Mtm|҅T(a~#/K߳m[s /Ͽ|_WxA-Ur}uбj0"dnA'Q4q}Tcs\0jO R7mowހ@u/ZI&kk}Ę 9b?vҷQ,0L&aMn ќ"7;PK:o.ƾyq]!grъ #L)zj#&1]0舦,X;=p00~âuT*o9ނ`ùK<@Ǿk@"gQlk'0Wyž{8t#@eеD,?C`V~fq[' L I"y&aGO  _b0$w3s{gI8ai]AEaE",>l GMK$XOՐD?N˧N& Vʍ↜=22ä LSO v`n?/A@Q+[&Fg3gLQk*۟ݹ׷?Z endstream endobj 2101 0 obj <> stream xXKܸW4`F4؃9zl4ݜR[R[|i` 7%RbWUquEVJQW7`&V!ͫc>_u9/v`盿8H2 br{=,YEzUr*OKfw_L6b7ĎO Q&Z*pW2ᥭsS+W^8x&)HQHzb cģ0js2O;9 qaH2|5" V#9nY2QvB[ylE]&ƾi 3_clegњEs8dF+;#Lj Hp8y+9QKnlQI/JQŕ`ŋw0af3c> ;OI~5U,!4$xqX*Lolwnr=áǫH8Db mւuVTUX7bHh>͋`]Yuc&'UHR>Y)U@7_ \VR BVGNk@3%I*9|of`@H:c aIؽmccӵΣC3k ~t~!G80b”,o$œ{gަa;\0Vx``raM I\zJ~yxm `DyGUuIq'`жLp<򡷦鼁ifb;@P,’$sńr{s1 [ۭ$[I8,'Lj:Ƿb}Kym?_ׇdkb]o Wٺ!Й(V򏰨a_ywxZHLd5t750RP$Mi7̘JU1پ 20) nЛH‚ H*󵷾Vw]_PBV:M}]{ sq\,&sXr72ٴX@= `ă͐~uc7D)Ǚ*%%ǫ˼ c*'s!&IU #T`~ٽiz۸Ju\۹WP0(J7qo5|6Ӻg+# CHYK<1O~ʦ" '$-~2jSCQ`+=R^ָ:r\,BK릥!,gN߉t毖leeSg-0@iEbrʞ@afȻ3PJG9zP%bi]u+TZ\KtZɂkϺǤuk D_[[Ĺvɹg q9*zs!Sy޹1;iJD[vm:x eZR i5Wh]\z>f~Y_FxɎC%#/[2OfV+rRObTi1bm131{yJZM`Dl; -NzXAno]ߕ.^-I$|U@Cնp#0b< wn0*xK.mP 4 `ls?vʶ6&n0{an(NȲ풠7SWT 2ۆpaH6NgVt8 e=w[?;8ZDZBٻ47ɝZH@" N]ݔI&cS,YO$ endstream endobj 2104 0 obj <> stream xY[ۺ~0RM$>=E6۾d]h%Gs!)l/-@2F؊?a՛+bd3+&H)z)SZӊ N5u.Ȫv_oC\;?Cι6ۮF'5$I'`f0=M48D]Տ->9ΒT+*h)WRkaY aXTWn_z~Pd+(s݌uIwkUw1 Gr0+f(#(J4BM*%(K"Mp 8@cKM*Kr"rReBLpBLqJ*cX҆QE6DpyAUoqZ40O$E´.-J&yt~RJOyގX -lt!dZ4*E>O-)ۭLv~Ag3)ayFd}nr JC[ރnk?l2o@M:GvЍ"Nh$y)azQm-Mgh9U %NDQh)ڵ~պY(!?o7x ^ {>OnH`E]6@>EdGS V[͘-Y$@>.]ǼVOĔeLwBl<|$ZYQDb9Y%0[$F4) vVCz11.J*X: Е2?cns:Ns<(&Ej+34?ֺŗ7uAAI4mƫ.MIJ~nҥ#kOa]\fZ処-X0i1yӢsebbWD5f.Ai">e\<Ը:m\ȸ g~ 3v_s׮ iv(!ǒ%c4\A`tb7!I)e/l+銮Ъv?)/b{ɣK ?geqxONNsa|)0WD]xUkhf[;@EEE.9w4μ=rCtWة`[big;n/C]p'!qs.̻ 6|JǷ}.A焾|\ N.DupNK"tϧȜܝ/6sCϟ㪟sxb؃E\ke#,=xhb>Ƿqe0&M4[=+?@j閎銏+>&?_1t(Jg^W# endstream endobj 2107 0 obj <> stream xYK6WPU#xdOa!XK2Im dR2!h4piA1 /^l7ޱIgt[tA9Dx=csQq\ !juBPIX3<ɔ]HJ}qTt6D;>^*Y8vٍ("XwjuQ3$jOcYzvahΛAWKDJ(ctتwWva,'{(P׹,nB[8%< )KNo)̙9(t0F>}3N䠟"f)4j ,ˮ+TY >,B#J'ҚWH,<&(a$TyIhԸ4@'o&2^8f OTo6B+x]^"1 U4/Ą)I2EUU(0Q7.Y0M#]3rU#N/"Եt } )@N]hmS| >OX- L[{Hsf)1v)7kcy3эPEۘ}Q=c^4Ƣ2Jc%H(fg_rF6os0F1ľK#7f4=L"zmR@$ vM}0-D:SUD\w4cI>P Eکv]YX ݛm:\8; vXlMlۼ64474S{b37M;z@/Dd_C /&{yF-mcO xj㒮҈)* l"C l2`ԥv -M]&pw]&6&]H֦L憔p[MoO6w18nू*}f<'=PCw{#(J[{DG3Pzm/Q9f.e*Řc!M@zZI!;\ytȀ/Dp1x{u]ٰ%7LEDqhTQ5ؘOMh]7\ 0=L3GUQ ף - |gMGIaA1 &v/X>X "%xPѩ_BvmBdfa ɄJi2k+3o+[zU^7x;|KQ@LϟClhEӴZaV)njGIAp{}9қzmΜi$f@7U mc[v7E藯Ww_0E{AΝ^G>lm.[l*_e gX{ᾣ xu-psFjpM0N_?ivs<ߞmLQv@ۙyן6  Ux_l텅B!$!'f/hP8.lEM cm;QstLdjŅ6KI *BݞTXQB3(߹{7ѡ$TDڮ9mSJGJ`)-. ~/TѽX83>8/mdkn2Si8#b?vh or-p!@o]ltG3ExO|4޶?L+&қ{+?%Jv,qmrVohjqTbFp{I2f{벭{$9 5JnSYJoCĉ־ipדwcYic39:}a$ñ(gGsokFU!$0!@4T{BwZTև-^*E?{cawAYLbH.uo 7llo6*?;χ2ܢ|%~g endstream endobj 2110 0 obj <> stream xUPN0st$zKlي@j86qUKɁǵ Ҽyf01P<} -,%&5FW3pR"U7ShWo܅a%zqX\nBSVŜ), Lf󝭰56KwĚh \gRPDq]ѷ MgA.Tң=nuk.>̇A۴B8sˆ_eFM PnJrGa6ۃ-$+>z { endstream endobj 2113 0 obj <> stream xڥYs6b7w[Ts%<#$3YOK-x,Ժ V_mv]?nwwlwB- RJ=?0XA8S%S~j.KbsJ]U{A~zU!5wRxBa碐?`A((DpMVd?ٳmeQb  s|3Dg<7꺽bY&(aR"Q /@eCj9#@ B_[V_h"M1.XN)`zfI"70^@`Ur%9#dtǺyBdC /= nlչAWTYK?3YÇ >d"7t0#>CG.e9:%`Dkfh~y^gG̞?nnPZW[/;I5)'OypS93%хnK"xf3m0 #˰uWkF\eFGx@I sƷ(u#؁C:2ə&#2S T?پ}3X:4R  ܡ,;ր۾n$t tiW 9P5djFvPMa6on Rk643J2vU9 CJW0_=(Ii+ Ѭ)"=/Cuq/)(T,|[Xolgg2 L:^9KQl T+o0<0* PZf-Xϭ|w7pHK@/g'DUեknJ[ZPH(ޞCH5< XQv8]B ]̻sg욫SxutP㒅Yr5vDUZH2`1n\@suNB0HW%ۚM}/+7q\#$_W1+:(E7I %#Tm W%+}wbq jB~Ia%fh6O8\r=DkUٷ5Ro_7A\ӭY䱱Dio704#zpS Yʸ=џ%8 mWT]o//WY[{1M] rv5$w +9SPe6hXGQ7+|6ĒcB" B4G5C} ]8m<$bвr5@:C@=cX'F" ieKEԭy*nZ~6-.rG_P\8a&{rº{B- q ّ{m*;jh^G 7FNoSRٯؔ Y^rZ)U8Ѐ~/Z[0-c.pi,-[Chҹ#.ǸcdLO]]8v\!,) N*ՁNŦOXq;IEcSLY:vSDL8]A;uUNn}U&=v#N (~Z4OƏ:|PrjP=#+/bK0jI˼J\+T$dg؅[)CrJ!9_~_(WrPUquu؊/e Bil<_8&KJd֋_E-/ L ~o` endstream endobj 2116 0 obj <> stream xڽZY~ϯ@ Ƙ{&qjE)l)DbI]m=3KŮTuO MrCo_nް&w 5 n<_ hk|{ݷs/~x/߾nV3/iv0dCz~ꍜ24\$$ϩ[P$M}vaL" ??Z[1G&ƏTV7UݗqR̄w{{զUtUS\E"). R%a'f PgLdsd`~*.qFb1Keae-zU].w"Fp%^'G2mF HFx[\:Q ¬ ܾ,rC-tBH]$hBsqib4EH"r9 ށjYQ;ZwKŮ 70*Νhɿ͘}:!eJ!t~MUk۬J3Lc>lMBt ۪{7?QHn we|E4D$J!uZtS U+ ǪzOtJAPVzS~!ѕ}Hg!պoöZ;9z%&ky,ʬo]E /ʕ2l_9V!! O"}92nE `CRS79~c0x7yÜb@Wt;F\,&)󄊨t ؅*?Cr[z:~ t_Օ}(f%BC-?&$F+@r9-* hnX(fx>V'feE̸{j0# ԹCѴ\WŮ / M/-@(뾬KOjʓH*7'CriYQ] F tK1"`Q:z)ܰP=h>| &D h%rT6ȃP&gxϡZχw\rHH\ *?%[HF^|w}Drt-TZ4`4>eDCRɐ ]H-M۶.x4z,23M1M;Hb4,OqI@(1)؋BO|U,5d?zmT׮ٗ= .ik?Gx,|,eq!μ.>8y ?~gfA657 + >{%3u"xo-H+[l+tiىsPcj'0)@.gCģ09K$3=`tE99oǤ1 ?F(Ė|)s&.0zR Un 8Sq;Վ!*FXnB6|S 0UB wp6)i]`Z|>F(N`8vР s,;NW];.1|":WQ|bAPRQ]T`uuû/H3 ka)xy;q {$z<OCOuS Yk=W#UR@og†sböcku hx2LY蓕rO 6NͲa~sM_2WqQN>=bӄe 6@i? v̺. s0cP@N}D* r0>#ل^},^rN@5Py<݀~<pn ,}R`y{)@\a%H?99{8cP}ܜjx'A3AlX؋FNR#]Xu+v|JPV'2Jd0fvɻA lt mSϵ2PW2oy9 09`3ӆxdzawy3VR%Ǒw$]}`߈`BDv*]k^L;R1rg}*=8GYJ [>9JW$/{wo/=&|?Cp7$T_ @6 e'j]Bhjқj"7Rb;?)vHA!FP5ƒ3l000R X.P1bJBP7yS\TbF+=:Q );"!A&"Sx8}?91s endstream endobj 2119 0 obj <> stream xڭY[~У JMEѠ(%̓Jl+;^dʠAP`-Ѽ|<|JG3̶웧ђTeE猚rR =~zS3l yNWBe 韙(`jKj[\*uO; EI4)KjN獤y.@2Ah)bd{)*d%BӬfD >7w TRnF);읲w`JSjRfh׻?v8˼~uͱ95݄/)JHmFH*e^LFv^"Tх%~u6Lq7Tk:e o˧{<DsT1;:6;f\1;HBHjE*h!ڠɩ) ܲfrWg!eJqiקlܮ[K1+eHɴ;BQI+'VBFASAoڇ>S `6݌0`  bBT&aj8z apa%%L(0xa Wa-\X) /Ҕ|3è OKX2Nw+ ;"Xˇ53RP:ۏKھso}w|OϮ{&+(^(C)5$TO.ĸnGUh Ec6KvCdy횳K+x0' ?!`z%8Ih>8j^~ 12B)΅"{ˡ"҃{MYƠbHFs˪%'1Be=͵MyZPA<.(Qv+c =|`wɒF Q~bXj4.jSRlG*t I ;)m9X zLe#FB 4DA=S,ʑ3e]QaX8r`)F,{EUT-Amb$!?BpX=2Pn6PZM`]\ZN}:@JЏiaK{q0!IL^ 8 Ev2di/,c84–hCWh&1#=w-\kLfAaO%cK JJL'hnv8iv7LILBƾF npBHJH]Dvq(o=qا8!v!4v Vn>yv 4(Nb c AXdrYP,TtEg)s8uBq<"k>! nͩ>co1Q=eut/&ˮٹoVBO/g%?|ÉZ;\8q4J7蚐6zبS7ح;ۿv[/Sk [zк~k zBN0Y c㩻 6EMK.$Vr2H9˘6t>zP}Uӏ x2~L2xGS(9.A UU.ߏTbMYs1~Q Yʲ\+_J-C x$Nq u~m}n'GM*86S'8)PjO+\ :`4 #g2o 0|fEbi$l#k@5I }bk("aU)^_o uFث 8-si;J-T(+[T#,oCJ)Q-}7{衶_xke-)"fYݓ|f gsj  BNxXS;%c`XpW_2we[g/F/$qZRcx[0Jz7]zimפ=괴_%V5^ _:5y@`YR酓HV XifgcHXhQ$w|-K ~e50?A[g_$z_-Ɛ ɅD4fcKq1p4M;R+85_ Zk^=?w endstream endobj 2122 0 obj <> stream xڭZKW1=P")')']W+ pB+Ԋ)@Xǵ[ELa)I8<$O$8Cy1*L%Tfdo IImOw?֔Ҵ7?.6CSk՚<t"2 h@er00G՚ m[h`S҇S냹}u ¿Z]ꍮKׯ=+lK$O~Da@kUl3~A\p;؆؅ljE2گSc+".h&.-#(aGm-.1j3LEY6ogm=-ԾP=՚|FDY&\4Omc4hC X_?ztwc BLaK]ٗxڣF-}c#I1xЅx/zx.> &r<'" rBT&D2y~O# EHİQd(ιW`()(p3AnSP5S UL 1p[bb"t*&i:5,T޴GQMDX;myj' 1yHV b'e,!jV"ɿmG S5Ԉx.ajYXfI;ۓfEa \8Kw594) X{x8d*(;9v|\ixk~O1Km22I 2%Q,6+<*D|aY}re>ΥRcQ3dW璬5D'2d % < <3c]_xWaMMA:?Eʏc= X,Ev5!?)<):@hI)AP7.tsoL騻ޕ{~rx ,huض!O( i`}P ӳ"I]|lRG-$R2?=]-O>TPIZp 23y˓5: L̙03&>XfXgC7 ~CnaR&v't{"?KDqj:GDye] xdݣvuW5ֵ&ch 0<^pmɠkG@jwUiys2VN>'^P*/!>6uU$Y3$0t?E}|*&ZB8&䴍ެ RL@e ~~Ad6~k hMh+=սwee UY]y G& ݩ6}~_|Yݻ4 adwP}-8/Z *L(BET ks݂o<'~8%HY1ĀC@f f[X_w3?/[v^1Qr`U]7Ltxz ^.|3psf#h47.ހ~ک'ݐN|: ( Z* D۫$p]ߨ\sϤi2},ǝ{ _gb»CCM lGf϶!ky5*S>0eC] P9 2nz;doNbf#slƃ֞wMG  dJr9T^ʧ1tN\u Q? eC{Fյk;]^EaP+|spi73m!cڦq=9_p!PqΏ39iQQC22ۦ`^t`vmFLklZ/151qm.(t13sic\|( J6~P&E$M*U5t3ch3TOc=ٹQcf3TvhֿyM]DN$$b3]s8ʣ3;c/ LEZh1#BEQͨRB1&kNa*Ez4|x3'~3H޸ Sq41}GǾ"u:-2~"Lfs%F%A(ＰCpCs#,V I.F5&<ڡ܌7CCq 3c O1pNcYB"^R"n.lfa}3WN3(poo157Tgmбd)\1 qS<1Yi>^cuw3 .8s9ǐD m`93T9{_?@R076*,LC^Pkgb<P80gqWbMIh8]WNqnxKy|%˦v2o`MIj'aNH hp=Wyq{pgax> p7Mzz0 [AYAWM q슴 endstream endobj 2125 0 obj <> stream xZKsWYp*g=$U٤DBO`$r6eW36MF3mvO?_o~mhF 7BMcsyEƽySAr=Wnhؖ ZS(D<'-}sXv}Ѐ{"hTd~ʉ 쿇91Z/O~+KM$,l٪&x;"|*PF!M6+UU"h2<^1ow;j Tw&+8#4QwN-RZ2y%Rv T"Ue6躟Hv4Ysb[WN0YFYh)tlW6=Ui%v#\ၻ!z&P~P^r9*_CPr1)Zba# FPķiPD7 W`2U‚ A\{d*l[UƔj a*[>DR'j!bz T?Sf R ]D$2AmD T#EdFɝCywUܜ%Z)8H뽒jBHl;Ü]1 Hum#Uσb J$:{ AC77kݻlivknkIj7U9)3r)1!cS]%.PV 1t~˿S]W-rdr鸬׭DfqR#rى8+hl8[m4ӠSy{kEkY9/==*U@8ZrBb~ mǂR]&z:/wpF\y]T1 <_N%>qd۫89q(CT QpfMax/x!| 9'oo]o ifɰ*ztwd(^"m%O$7#9ўG#x vp3t_,-pLwq&$̗NhT/m)Oc||6{]1U0v; ?HOK?|SW6D\5CV\\E l8%yp4-*[6=cFFr=,l(VV> stream xYs~_GD/Ont\[L%JGR>+? @(f.Nn"}X> d&)ófw?(9>͈rf˻Db>ی2dyz_m0z6ڽz1rSXhU4Z(2fS 3SQlǽu&2avLq'SvE] fyʹj3i[tYBv5vECY[$)Q|q]=Qg3N 2JҔ֊nWz`"yob0OHbzl# \\SNVrN$bdFC<85 ?HzE>u=CqAdRSl"jq@lȜI4^͏g 9)&9Χ+Ka6k   jhhT;L2 PLKCS6py*ԆDzMOP"nj#P^ī8`2%l,Ny ss0%8n#&I{+"=h>{Y-/󶵼,o(QWP]XwĊ GJc3Sl]l pbcI<ɛIE t%)`W9?9ɪP?B3KW19UC)8NGUblעq ^ ᖈ _oWFq8_&r\4u9ali#}):8A,Ej @.S=N( F]8]?{&ƒ`M.L~̽n5cttɓݻ̅M 8sa a]<@YiZ ӂƊM 0Bɟ̺]0eH2x3TCO )/^@v z1ǶO<sۜPqA0ݦ:%0 v'0 OeI!¦q:>]`ၻJn}8Y) +9m?@9<暥,|=h?^Ҝ~X*>#fvo:q= endstream endobj 2131 0 obj <> stream xYKs6WHeBxnsh;v[-A[RHʍ2]|ԓvb]|zi IX-޽' 8nj)Zܭ?7PbRJ̯!c,.dIdp*~Z0̑T%2h@6R!tyuU!Zx_7N%A#H1OzUZPT-!',(}8pq;BhLKC>-9LK}Иח4HPϫc8otp$%> /N4#+X"Q!yeLXCmV~#$Pz6)Xؗ<5;2!^'c[?0訔~~T.cs*=,ˆ:oLB$^%"n[0C௭.jx$HʔLJQ61fS8&WfmR$+W>3$.`tx|* !)ETE?"IIE!a?`FBotaNxNĐVlnxLuzԙij`[/P9e:,zn6*(&g8dD@:~x?`g'fORY c?w#c6U> stream xXrF+pJ)c1ITr%⋬D( "Y%eW (8|=$NJ.n"E"ŲbqT̮.~%HJ _g%8Wժ5+%$ەfDƭ%6RmT')afu<#<ϝݭsk^I1wl iͳg^'F HPj5ſڿuS;J*θC3fL݋OzA4 efqR_eW"BW ANfHe .B7MnSCBq.n>$$^nabc/|NR {Z8dBQ| >zatJ8l,Ek.8w"C.{TsI!8xοy&(d}Lwzx֛&dBB3O0co=pnb=aID2~fP֓$W_ʚqU8YF^9aw 21 @ KmўZT7.Mᇮ?//+8*hr3;d:X@̾jՄEQ9$ zuɝg\:e).mM;|u\t{)6l*\*,AYݼR(8UQQ$<رA4}0ML0BעͦM0 NJwGw(Hއ2cf.E)pd%3d5Ļu /|n lkop7A6%07Ϲ0yOLR<4TuH8Kx\Ug hlZ}nrFK>jT&!O~m=MS\i2_%}e=tPU1"أ&d6AL0kv@fQ%&$rȪ.Ch 2y?RAFOGl)["aNf/M-[15au|1} 4Du#?\Չ5#Z-6!PfNY0f]Ȁ&įDJIsDixjw" AY4humyP]u{='$jD~S>hhV;;8 Ώ3/g57( b Be; 8C3Χo٢ éK BۤGh*ZMt|sn mܓg;G2q 3ƛ[\xՈ"'I AĪX6YSg@k٨?!=r,FGq(Ȼz [}R{ cAaE=Y>5HP$iW2nN ZBY4DKڵ,n`&>`J܎k0Ss]|A-R(UYQX&hƯ}CXxp`:sxC+$}^3"o]> stream xZK6me`)n@X`Ac5%Rg2A~|OQnʖ'X`LrYiC6FR76_|K7#5ټ{! i6_=ק9oKXAm9/v>[*Owp"P*m~"wVrK14Fp&-)i }uy 1?iڔCYc*374+EL {c%ɩfNTYR)'aD~[RU4bwnٿ+>̒f)ZE}g=d MmYa\{7atT2DQܦ#EaޤB\ ؾNzgߘ%7*.^ou^!YpS'䂉9UPneŔ7.`2.\kp+W*@il΍_P]5O0t:Oj,)WLjjZsy`Ȃ]ڮP6tYc&dO֥rOhgXvglD4@3EW5Tw)k!@a$V$Iemlf*02a>"r'ڣ37CD9Ya.?x aKVJK]t~+4Fgq tn^=7զR\@g/ƎsBS@s+`IB4K( ٽ J!%JƔxQhL(KJ+EM~O6esGrIS6WjzSXO@wp,%<@2ۼ`HDUc.xA%IFh&iR!fpoS%$4nSҩvM(}^x}7CptޯPdOf$YKHS&wT YH:J d;LfPUJ P\}(uC&)uX&%4(a #zHxmӜC=nlL>Nl,!* h1;svZTGƚ1\u ^mƉWK{o~bCiDE vm0C\U:kIIf.p\MIJ!Ewꘄ |.`feu?'R) rt$S1r13wE”>al`@C>Si130&`3&EhFs4Uc%׃=JN2flFAlMdH+lFy.H?l :UOC^QBf)6Tyʛ0;*n&Tj+KinGBOIKfRG,O,Ӳ 29&䭝SֻahvkE qaIϘ G"9S]59wl"DI+[u>#`o%y= =Hͼ֒Ǚy}et,ӱ~n,A#`ƅΚ1zUyOz*(T)مDFSȶ@Ѭ'O WUeg [t&5{do9]F=u΋eԾ9 v1oܼA3e x2K^oBI.g2O|n endstream endobj 2140 0 obj <> stream xڭZs6B>52'7tShP#RqsbAAJ:ɘ ,v[iiV%cru]\XYҲ튙fuOVfEU ؍~ !?]c4:&9l~ͫltTsΪpʥ- [TVYHWEY2jfXM>HeJac;,7Hyv)B%3*9_ ^UGz#~_A_VcsfڮCŁM=68Y@0 E0kUfuJ2zg񲨸s.I75srYBh$r[zG|hBHtw c ]J8/0g FIuCWD 夹]?4M 4SG~\L P b$5/J;qQߌ6Biot_ȑ^/(kqTlʇ`Թdiڄ K04~cCP]APV9 Z u^c\h Bf׳1+L:Ͷ@,UJh zeοE.DXya~BhE 2ǒիB*bU0J`I3@gC u C7VE)rA8$x-D? 1 +%x>qmi{vY9z84 ~0E )}D.YVcمWd()8 >]G~IAIoGU ¹$t.Di1ܤ?ғ]CC:d80s4x o^/ z^:3sFXaՄ-E:kY,P*GSS+Qhc6ETj:rQa5 ʆ \/1 kbΎIi܍ m`a0z8{71ft;P0-i{(U}C`J `**|æ ЫFT'G"|w~ <{ّqm'4 et}2*L5pZg9V.R"} 9:FRe&3P-ߜ3ӟCޝÓn9`G&S3RDsy탄T>ˉ;KN|4~УC_Fnal l$3 *: ͐׼PCns87[OKx(QG ;6^ /0 Gu(~TMK`WNgJH܉wyXPMb %:ɆU&=Xd`{|[& .~]Ӿ9Ŕ`,ƍyLU.Q&yR1R `c:c8|%=%) ϓE' U2KJE%bV ƥr@+q<@Q+ mo48 ~K> #SfZhnݵ0EI5XfIc  gC]JP)8bf+Z9pNw3:&̖j6n d >?ksd.u$ϬȄ97{znwi&v5O٥.*vY>gj- 2]"nRϐKC/c~*d GBs'۞yҰAO>׮(RabE q盆zjPua-6tᡱר'幩,s,9nwngJڞ](4n4)Ĺe>hn#sWh͒V8wC/3>_sBa;N9DyO`vg\!g`)z_ O qD}Ş:p/l ٘&sCĚ8~sQa#]N*~ -ѡ/ݴ)I_bޤ8+NP]MzD_ZSPrnDkhx <xYM!OC袬coeDU^Km( ^3O4PBŽ)B;z] 9RQ=Rgg'u(\[(H3 > stream xXQo6~߯JCx$%[lX Àu~PAFl%~(#4 ,L) ?\-g7<FSB0[4I0߅?]gVAyDe]gû&z?5 Be!1K}\ P`i@DJLi!hevsV =k\4Mv϶XTdG$ d9Rظ.j}n%Y,+*)ʍXŪd6i&w`"5r ڛ۠)p`p? `p8QZ Gqi8GPU>r QNęήM2$/B}:"[U7a"jWYQdq"E5 QRrc Ju ДiZ{K]mMUʕ+Tuk=5Q2oU 8ALtON^GPBwٗzǨ`ML"Ӓq.$4nB9qPGj?E[V`VƟU[#Mkz3<Չ5-ͩHMS4GiG1v{7x0WrKc,>ۍ~qA1+鬠;3cf,P,`Om3_6/ӦoG$(m> XMM(8PƆػ,ܴهҊY7ӎ"GsLCμq!U^,10CK^2I)#n}>> stream xZKWV y?|sb+TJT6H:@$v6 uǧ;T ?Rf꛷tE02ؐ݊ap~X+o>uEEJ1?ul__{G?ᦠz9憪uf-i n&M=L2SBCxg9GTS>b›jKy:7AJdXZcT}}zsSn֏}DFB+'ZwiC Q)Smg/rUGXN /wK~mx,նN[wJgOvC>yPY[\/^(2 aq}oM/doc+&l]os v֏>YbnUم&HCDH>a/nY9%),)}z7V|ou>0J~Rn<]yW=̺\UuWUw:6mn58]k"ytSpΣY=$hg{w,؞%g71^庇KUy]˜iw?ZByxB0DP˙)5r"EHҰ~vR|a֧01dҊv&.Q\F"+rwJR̸l>U'4eGRD ^|J""uT1!.wvaۃk@~- eEQiuo]]`*N--ΤDg_ffndٓ!aqB!bVw!@ԝe y! K.-Pp$2Y5RwS IB)͚ʧ(Ϣ==>jK]}gú{!̘d%Y3j C~~抦@=z8% 3%ܯ,0L6R }(W~j[duKfrZ U0YKSy+tڿRp(TkG-# p 6Cur5Y}8纍ajWm!- ̆ aw՗S9YlI$)66zd#0"s $伂gbbM1` ҝ!E[7pC!p錚ўس3j9EM;:")4E8N;s)nPIa($Db$3lW I 4l4Λ2BJ- Bp GeE/5K9נt ,)=1Ů^o6.K("4Aȭ+ wWvWns2lJȤ8LTnl@V E¥7FaGac1;KM|PΘYˢ a +M6/dT5(<;ge Qa_ҋ> d="AjtiN{]*8FLݦhcg0jӈOKxi&\rHFFq[Zh+- {^%5#5V3~qqZ=$ صX=-(-cYF6r U>d JIAͱ~-z~r(^_ͽ%bOZ9i[[)VZ()6>[Ǫu9ʮ.0 *[{UpI-D/k=]JY*"MMhYe}? gOݘNb?Y&p" Z4Փ 3Pt(gvX/,%i(Wl\a\XEl3r'G.ay>X /]R|~@Iw5pkߑ8|G4|ܑy| \u3p^6o9y@uMǞب=ړ&WE#DtP_ e%_qڹr`b*]Ð\HV bOεBy3-Ӑ +½P\O͹ W32EξPcFbJp>Vg6I2ՎUi;Vx$m qruONx"W.Ka`P!%Ҷtpmʋ=4;*%WܫT@tm IzE-'>j9 Ònn;dY, C$esڡdnAbiWu)Wgm[?ܮ endstream endobj 2149 0 obj <> stream xZKW9iUff1'12I}oOU?(Ԕ8^fz|Y +_ھV?V4#&3trbDz~656B}wL(4~)w7"ˈ2 T؇{~QF<)THQ֮ut]vT4UDNHH-HrT1q#|:Ub%lMV=rdmWC#wӾ|ݕ5)c$$U 4j̄u/c_ AP3W#V0-lЄ.cr; oB@ rk3u}A ς% J bE;}F[3R.ގoniPVEոomWUYo_`3ڰ/K9 Nዄ4jpT?f"hyf-j˙`4/_[Mp<1KP'0:2Ό՜q+O0AґM 8ɤEyp%WV~ pZO>a4A}#Dߺ"U,(3܅roRf)DW6'FiOL 9Eյ[ø |]O~ȩ@xo%+_aLO*ٱ@,=h ]E^thAlz"HQŠ+8| !1lK^M]})<~Fs)`lqhP1{^DXIbO|Aו+Cba0࣯6AC& |d@|~Qc8>E U}i뺵7&nywe>5@5ۆ~dZa>!'^E(I(  1"{LY|Lh(D!z~cTn|8Ti"UV f(fpsd):t1ʷYǜM<+_crC'ײk?-" u,!g$Ds+n Ţph tzP*9)EB#}Acg(HCHܴpٔ_yW fWBCϮ&kl|4z<Pm.!1\ ^Oͥ{">no]=5*nغVvhUbܤY_G*Q$zl(\'y zVa9Fbe|4(;;ЧnaD[]V XXXnpS2LDB6ƠW54 3ɜxp9)ə^(N> bϤ ٶ|SS]6:c̘$Yda'&]s3vkB?F}]Ig*%fa2xȳM~h_,mKkũ.d89|NtMFk8R %b]E=ZdMHdBLC䩰YڙB4H1Fe\^2 w cge 2<u˄b- 4ꚡ|lMeƙ$e f2'Y. I#-l-ѱvcRVw,pa$D."S]d &I/ 1ɜ3`ɸyrGLwO4FI7h/i?5 endstream endobj 2152 0 obj <> stream xڭY[6~0Ї@̈)Jy6mEEO;}؜mtq,yɯsxHY B&;2O H_hŦYܮ߉OY|~Xb3Vb'\,Xs!24|reYb-M~o횦kq.ߪ~G+Q$Ccۥਮ׬b%KVpOplWT=Xif[ag:6D_X~ jҔ; ,#a [AE.H~T<113]f`*؇noIjx;;cZ0b&5rX@QPb#Cw)2wK6VLf)+R!6X`>VLQ߱v5tQKdA <Օݾ84s@g}XeC+.8Zd "|+ rfST-9DȖvW< b-/kd(Ӏ"b$#6aU)yʫ$}RM܈b8  gkLxfx'FEҩ tb*A.W2-UtUy%gr06&=S&OtbL BKJB=G]]`k<̐ Vj&}Q1b<'EPB@38*TlGR$%ee>ɝ71 VqY\cqؤB9BP)P4LU\_-X>+/PxXȡ%uRf%$Pi!jvəU(LYu> sZlhd19H[!\v<3/prLpPS ,( ~xpE..J䍐}*by1p0>2ͼf澶Q,4VR^f"gy?T,tIB[0C5RCSf P4zr#n%Hcs4ҾmB zlTj7_uj$׾a]󤵝U %JL'cJ2WyO2ȇnTG!7^_)(֍'8Yw8v`xw-$޾ = yH;k y2* [(z KHX9^[+BHA:KK4P4>>7Vp(BQP)UwIA =D P X?^SB"\3 c쎅 ky1-8l6~⣠'\GT -zuy- jo7CMM'G.vym*KMA;qĎ ?dg={iэz`Y;;3Ăwt5luoS Bcc޾Ck{'1pEnX&m*]Ow,Kt EȂn+?i7*1in xj;vKQwn!XL'G]yvV~e'u 6nmo- oU]QAqWNj}J:!gIe2m\<*w"X7D0\\#|p/#'!|F\[mm(f8y+'dxM+U}>Qn$*'7Ⱥ#1>]Wg5t{R>2|ջ'N^3,~4MC[dׂ/y}-cw}UcǕVɗ?B*(`ç>=< _!Gkc]tORXpN\ன6{Lva FB57\Нj.W2URr3cԘCÉ6ޛ/Dr+! !!Մ[GL c?j endstream endobj 2155 0 obj <> stream xYKs6WR3!769Ӌ-TI*3]nwy셯/~0lnY$Հ}΢7҇P\>-x9q@)t]X= )z197彩;(YUޗ,*HI9(?s brH*9l̹XƸśUWoV.QoHWJmJ3jm u͋.'$HxGipmOˌ96AL {F:byzxݓFLGI {ӭSO߷5l8,۽O2Uۥ}ha|= =p6HSKhWD< 0mZ.M-֑7Qv1CVS_dGT蛅3Ɖ<Z a|I)I-L\a$ )8V "Q V-B}xM?sfgɽÀxλS5=9cCSe1bˁcs@pZszmiO8SnM3 ,zo> stream xYo_Apo?)KW}@kD$DE)-epp&gg~F(cFm2Kٯ<aSR"kQHR.w~ gV X/v7)#a#Sf<#iU48uWu^~~ݽ'樂p)JޅNt+OOew n9Pz d/Lʈh fN .˪RM{!G7t2KBѸ*a~("ՈzbHA\z[4MBn[뾱![d̹SύoTgdZ($IY0C'SRjH51Ws9܀]?|}@:`M[|A+W=A˪%!S DyRow .H,,L}_֓Nm,m_DgwMFp/E]Iu ]7[[\yGc]pw.'3Ʈ+:n ~SX7Uݦ)•wW]$4v֩t*ɩv~Vm $ [$훢.TtLݻ}J i)≈fO[Ľl=-_Xf>p^~t,x_rWL_z E5=CNDl/D=r\Mp# b1D$"\xo OԖ4J SZMn 75C5,D3a07mbU- z+ չW㕏RI!wX;D& <ׁh+κղgI~U=^ܗ 6YZEH'N_/ʢ-M1 b.&6ri E::0R@:,6n!IB[uo. ".F#>sf `4^wlg0USOv1cP{^I ԭvwGE bW Mpeh4Ѕ]C 碾$!ecgHY<=GoVAo\|z]~og`Cg74i:)1_5t8]Q^LDZeϤ;PEOƐEqT*PE$4M ܼ_d"؟B=Ǵ+pGd$K(ߊ&)NiIgB:!R te7m}gh Q7J]ܫ o)Ld;:ӉuvD'(UNn(>,Ob}mcM WUw>MG s .68_Hs$. E1sJ^Q&4A&OSleR-` joI)} wq¤Q }T 9}] 8lI 9=`eN}w=FD2 n-/axk]EqC+䢟:8,#<1HF4%AiS9LP434%C*AR3Mg~qMD͑˳MCaGt;Nqtf9z#??x endstream endobj 2161 0 obj <> stream xX[oF~ ٹyKڍ>KjOlZ.F jڕ̹~o?$`.w4 e8#) i@x,w|ש&c!Q9o&hǀ$ ZI0Abpf SNACۗkwxbbifN}+|:`lWJ)z+}r5[j(ε}V`1^4.-|&Qųڢ+j $EY$jam |{7&a,U鶏μ -! Sݩv@* d L 5FbA]ԯ"7[#-1%>\-ê:J{k24O#I٠"BḤxp8.dfڣi52ϞN@H 4@ '@8x7l{~2$7fg"FyW=܏@"N` ,W^1OKۈ|bIG?6T@}}.ɀf]7cqR:ܨkHA MjWMӸ==l~Vݾ1mPY|9nu[iIPB[!\ C~ɟw?dd9]ţGe:2,rJ-=l"mBþ]Ծ1mH .7  hOEY;Dg-OWZpJ8+ed^w_t\/m/-HwnjdAŔK0Q3C E1.=J~3aL ;6}ۋRf8CFrLiTXZ1CUg_3}alW#sW(PWտ0`8~~rh+=m]:!NܪUo)' ޘg"Xmں6ޡ9޿=@L8PHs7.xf%Xgq'E*oUk? 2 3im> stream xYKoFW (7ޥ{JhQhbHkE$UE|gIy%Kh@ acmG$# IWi4}f*uYw1LPoVGHjʱ\%&2ưl=-l?,p2Jsuz1D9Y/BlwH_\ۺ-ok>w᩶MX"@r"ƨGHgpJx}ѕ:[3 I _QNX2x^̤Sr$4(0_o+*'%:7m1w~1<9ݔ*&jIt1)@^B0O׍_pXwKw&x׿׻e9o1]+; pe +DrdL!>yX̩Fe f東Xx~pp8@ĴޮId*A}s0l W[w4M Pj'| 8aC2+r`Mށ7^kC›z vĔp{_PY"P1*xTN$,p?-}ƕ`9ߩIЂ{{C4eb8dM.c ^K7A/\tSܚ9GC"VL!+N91)G:jmS1K LNL12Ι`(xRxS'fLVbWQwekf_r`i}+)6G/=HO*|0ӛ1}ѝĎOpP='3z 9 !c5-Mgcԭcʺʢ&[sQQ#p`7iZNkr M8l|bEPKXrx'>p_p6M~E_w8)yJA=$m\ o+c^k5AT8x2(@̋ᄽ_AO[ ?,d1c*'I"wB'9,L9kkd4_(}՝]˼v POZᔏMb DFv~'Jo/_Ξ endstream endobj 2167 0 obj <> stream xYoF ~_!` U `AX#6Cte˞,HG~$>GFAJ4.#}2_wE3Kc1Y9&Q?׿GLhezFRįJxF4pQbIHei,vCQ;Tx,we]}u](Jndu;bTEL@?KRP欿r"aYo[?/pKBmJWe(&M - PQBBXWƢq:janD,cqe`"0 *I*;# T*$0)20I4W"(&cU)tQ*|4.B&hN(/dB9_DYU*ʼngy%٥OSєP?0s©0{_nwwSam &L'c.qEqT.W讯/m^CR(u8hLR~Rpk7m WaBƽ73⪳!v˯>;¸ ҹ sXfi>S3@K9:fQBc4$%|>)ܮKw UF luQ!L&vu<_+sE`EsQ:ԥIb[6_tn@lA$\eq}0ޞpQgY7X.&sH SIn|R&t$L%RX f@2C;7A鸴Uy %OkM'ZeLb肬ga³ 8~Q+MJej;ƘCE?=iſunQ+f|Xl<,M@X¾\{j~YNA1qgRy~ hN\`R{trџ)aEpݔy䒫m&zDn+;GHI9;-!HCzݷ.em(lqTBSջxn&`!ɞq3hr|Fc6MrA݉uXWo^Kw@%r=o,Sswg-wkd![O¬*a98TMFeS̻- Ut9Ggbw8^~h1]p/)/i/Ҁy7܍t"Cn|΋xv]x?v oyh^#IrCweu=nYoV YIqY<.'.Xa+vݓ+]bD1o0:צDbᴄZ\ H_`PM4jKޙcժoio-mP t%q3= K.WM Wv}\Կ?i,=X8f/ÜcWOp*ݥqvufN CӺl3O x JֵܺiUBLb%> stream xXn6}W(H@&RJ6I7.mٕ6!)ҚZk)bD9rΜa)4P H?/ްgMq*lu*D3ۓo#9b ~)70c[U!FSacxC3kyA" +]/|ee0 UXrn]Ux8QPY.vgq,l'嗀Ѱ>,1zw>1 —Uk3`a^DIXeYxj}66־yQ X^k`5[N*/:Q "fQ^ 'h;M"D Kā0릩C*96Q@  BgAm$(A@F@q _ $F gaTQ=ĸӔa(Oaz%“u]-}UԙRf+Ն YrĹϘ‰8܄Ш{ʁjK,fW9c BD/t,=0̘8PPn0@c ts]M7M?Ůvy gmF˽t7tR ùpہHDajʐd8qUV|tq&J9њ|!'Cfsi:ge,`K>8/"Д;8S!G8 hkd'Uew\LOVxɷY5f)K)$fz 6AyBUS!zxN'e }5!O`dqrcǰ={s %N(u1^B϶bWS(<1H2׷4O}=!FK G-zGl&> stream xWKoFW(Pi'w77=ha@K+ E*$A|gHy8 p㛙ogw I0DRjr\\ӄ`&&!*! i]Mc)s^m2on~K8(g9H50(zA*)U=L`$;0"yZk_ Ң:2(SGq TBhcLNQLUSDsQiwVmﻘJ.#lt0?WetV qpNj/"-hkY˕0Q_5EX@mPdq%TDO;j>I9i½4] ԣHDZr̼бW˭l}h}f?j|v=g jH>  X6B6 E-3"&Ԭ%&ؚ*uTW($t8#P} TZں/.h ֙>mSbi)+`6nmf ^-%C ʪ4ALY_/rxTRmu wHQE+$RyqlYhMw`uOΕю?3jyZ>Ba25P'1s;c g_~WIZyZ;-k6#L"gA81'|f.q$2{QnMP[,<~2~% gތRmm}vra;8[, O]!A,R3d6\Ģa94q9QD<+<8S@C8۾\ݾ*V j%ڣb.l粇}HD<#sINVz'ȁ~l8 6r976ChaLPw~U7i4}gV[8o^x/QgD7:'/x!>?m 㳟4wy_U],9OP;LWE? sbZ @ޡ|(8yL"1p͞pѣnȩj/+?{}moxze+M,MD $? sM#\9$S>i$ q-;ENJ0?BYmE_tͣaSuxkژ<:#~Jpo\ڥ:HQq?z{9> stream xX[S6~$x3X]V6I'NfZh_+Xz d{tYdX(i Y>ӹ|H_ I0DQ*8y&#5I/'!xq² e)k;YKz?}~lڎyK^7,y:\zFU9/߱Q.ktE7YtE/f adiO!:(eH2 ʄ?AV~YVeQH"|%L ذ°yJ& PRnYueSQm ;~*H*}*g-ѲT!套B?M6"ȧIBw7 +h qM3,a2%VPs)/<[.5n~1D#)3-hphڎJu x 82ƻunzGiG,c9$6 7œbkIr ˑP:,8(9Hܜ2O*.MLɱd1I`obDo;lQBmy3I3!Cg8pD[l>QQl+/|wKK@Fj1`X;"]VCBl.bG}|Y{AdKZv8mʺ3Q="kbOZBiz@D~e# 5ڕH?/ME5TP Kj4@씏S@8a AbR3U*@0-Xz,9&m\yXl束 ԍk Ϧ6y#0:DE>*AjUx^i{G~zoʂQK~<d;>CN܌aش:y7 zn;1?:8(Qu1XB rf9Ze#>rS}46I%CQ:d #.ցs)͠`i V[ox#N!w(J0ȠnPC|5n]WWwwl7f=oKwاfM i 'pv8](%:(G̐ xLQiгJM@Psږ ;m+ EQ"pGZU􋗈OO4}ԥ~bqnD,@׷Ky"Ono&!r/prpDbhj!{`Bp4ah\9wy,űOQQ.V8h4t8 0"}B ȑYӯ%Bf7iF|ɰwRV fH3ꄡ8,<Ӛ喅UnF endstream endobj 2179 0 obj <> stream xڽXo6~_!`O[c/q4V*)Mߑeɥl+͊,Qǻ;~<^1"?I 8Zn_ћw4"e8#."*" e\EM:ht5Kc1s_UU>2~g?"NJY +{;b,a0l&~T3cE0>)&yH\ñ[ju]VqwG `Yw1n菖~3AeSi(c`!ʜËY Hpl?̄Q#l8{gx' dS"usP_ġE\6o x'$iBօ~JPea!H0e1bm.]U[ ne.D,cqye(O0—p[+^,q?wgԃϋ 3ڸlY&桙AEAL'˾"YrˎM]vy:89W;6*d+u(RңpfBn*~0!A$HH_c-A`}7 uo eUYplY5_J:TT2Ȓ ufB{49&Kzϰ-G'rUNC2P<\߇OUNS2%J\i}sUitBU `zvC)2A. z@n5#VOz>g+O;C|TR%۞O=},iׁ[}a9nM@PG1)uݭ}¼!?<'8$LŠf/锜ƅrs2&R8Sm)kK1T 5! >V"3.ڷۗ endstream endobj 2182 0 obj <> stream xYI6WT@rҴ)ZL{䠱93jlɑɂ>.Ed& 2d~uF2 H&)l~ȾJ3ƚdQaHs]l^ˋ_3(Ϟ*cyl7Oݮm=c*ׇiVT惣SbamY#kw~4C6_E Oڦ7Q1?*0eС꺕 y.Ea1OVy"IVXwƒ\m$@)^Y+e~W7usc?Ke7[vF\x(`xѻֲ{SU!D7螷U :3&(=ܚ8B Ab%" > R>(jHg%%X,7ykӼ=\3CNpsS P(Lݘ)@ O*9)$ҝ\ĭ $Oqq18hyV:s1ۛzMI%t4ao$KT+qIbP+N>7mN[.m2xc엘Si$ gB%$8W7&EʡBΉYɈKX/{X0]W*l䪨.9^ɗlJBчH_CP8/>g}f-ŶoSL*q$ |`6v nM45M _O.WIC 9KLIiADN*e>p^b/vE_7{D!Z!u4moհqQnoё7(+Ksrs\@7i>6, W;C7kgqo GOLqy9+X$QDaUpKQ+h`#;p_<]i](eJisė Ѯpvt AY}:XmQsW;d630s #zs,5$1Y1;8oaRy}a8 t,wWYu]mKHvyz6փم 8]XOc 52p㨴lfT +-򃘂`a.?fEZ!Jɡzd\ȗٔΙ ڒd=py<{=j&' , C}Wm `-sq䓊GcPٔRr'ݗavtU4jwIƏL*;go, gH!؞r% rՅ%퀓ht8-'{ FC?2GXy/MzՇ{Ō[m؆klíhm8"Lؒ>2zVVum~_u endstream endobj 2185 0 obj <> stream xVn6+*$ b%4YtQ DPݯ%)Mgt 1<{SB ?H ԇMMFHOH*^&&}W,gD\e9<Q>槄 VjwDRo? b7_Q9PIMzZg~$'0|T~rZܢLǩNjVeZt6 ΎӬmfh Һ]Osl}ؘ:iU8uU,khLG~ xA[ 8^IH5o?E(V&WkrjН)㹇dcgJhmB|ruxinƵTWNJE^PAs@Wκ̛'qҼM_|P:WX}flK T%:Ez2#`;Iٌt}*w̨Vz0T E C;/OSPޗd dK!fQn٩ ?WLV~Rfe{SgHLRn*Їz*ݻyԶya 5L,N%v~G'*1D5 0*5 8C[.h-ӆQ`|Ml$}肕S wSGjy4H G2WeXR2ZBI ߯Znc9$Hm@Xd8r 봐=0P݋9ط)cWE+cgi).sP/& oQ@E|;2F|*dهxL߂ɗ/a|% 98ujOKJO~& endstream endobj 2188 0 obj <> stream xڽXێ6}WyT ҧm-m}Ywږ+{)-y)$ALpfx!?"aK"EMe#FHtCU(O/(H)o>8޸w~qoͦޚ1ڝ{NRb) UqgHb6K*)ϐ&ܮluU}k0RdN+݊.Y6{XmuoVSh꽋mw`-$& aIMO._2HSѿ^ %0J2#7FR懼pES3^WsC4εb7ù#BT5*ƭL5E<Q%@ .ΐC7C]>bpLҀ b,IDϹx(CqK 0_a3q$bk0JY\< Wy[~e~ti  \`·5.G,RJjn)+uIӵA,]~[`8IX"@ sk^]4vig騨}K*JF=̱@  K g>6\u(w}J$ILUtu\ \}L2°uo͗`h0maPXх"g@E2G$؉8Qݖ4ܤKQoL=:.[RpdT&?+[b^< wa5_3:`́8BR)!ir" ^ae!|gmf_ 7Pb ' ^w𣉜 =3T*a"F8my|2|_632B o-'RNcn"8ᄦAds*ch>'"3ϴ "R(9&\&Nd |QvMnLpW{6ޕkDA|Oxjۙ3yͥ֜X2,M ? 3^Pzv\$A5`&Ag 1F)a L( LI(va 9rXsE)W_]EٶusTXt뼃u cPjCG}dΊ>L ";pRv">7PXN=lRae3aFUA c[<Ò<דݜ0=y^ރ5&jּ2IX.#@c }2i=Q AQGLOyO8@1hLdH{mNy "~p%R^ɳcA+g002 2ks;b.7mSw[m0F k[F=ՅHQS^: Np ‘dlg#/2TA}([) -%D< D/ j endstream endobj 2191 0 obj <> stream xXmo6_!`&Wʷ.K h fbmJ ;,ٔ!(so) $_% F NH0 C Wt.<_Z1q68᫲L'TzK@1AyER<}yI& ިxŧtY̽PG "^d N뢌6HPn^f{}:fN'S)I(@;19֢N.gID F !"HkˮԷ %IG 8V4RQBgg=o.z ^Slrq^uGzN___26vOŷ3|ncQdX/w@@1&uPoU] bW-ʥ8GSW|g\/|xpLlSY ebޥM _&>"F k_ɞ d^89>.C?'XdOqkQV2-}(Ugӣc3%bW b9Pq Q*F=MjtXuڡs+J"C׼8Y@jk OM<] o^ұ#(¬4כS/Swk?la4,}ec[VN&-k/[IDU"PtЌ2 .$ +f`SK;a0l1̧bHTL{l>Ôx𗴆l\v>ЄCV9G4 ڠsjH:qP *T 3HM8C7r0ya 0Bev7BjH<SD#GDs:;CK\ #aSW4_n=2ٛ-wlS4aP'(E0R3*?C * z6Oj>!5Ǝ"H}1K Ċ֕h}.;  +9t5/).t7Q@Ys1ʓW L=qL //7#tE!"LBgo+ӞaQ䍟"ň3Z_*G??B4{͊w#6vB-y ^ݷ)vUV?6%'~S`zX)}x !>I/%tX!Ylܷٳl8c_@GL30C1M̻nC>s-)T;ձ`KiglD%x`p0DxCcdpcԹ}/ ܚ endstream endobj 2194 0 obj <> stream xX[oF~a%3@ޜnSUQ+;;kbU|\`Ϯ7MR;߹D"aC"E/nS2|4" e<ΗbELj2by{"ayt߿yoo<]EBjsUqg>?%t[IxR~HܵLqoTE.ݾxq,8JB1N/񲓸i">:kb ǢPT24ÿLx8A;OQH{BAXե< ! ^~G"Bӄ,Đp*l,Fnbu5dڋ_5:o5p4ntkE"3B!\B GFdփޔƒq\uOћ,nt=aQ)=үKwwǢ ˀ\@ RKUi6z666*1<3EeFmߘ'56C@P5fK֛*_PZ}0"^K/h;̾X\,lTI6C'yMj?'M~UQdV{1'UTEWes >ka}irENQ4 b(AztcW7'gw$8snOG2GEq xzkPa%F3'Y#;GM#c4: lZ D=6R,V@6.G%X=4wu [3̀= g;]e>OǺcAPӈ}jRC|BJX:Z&+B}.rF/|/PЩR:^v̰Qٻ'A`:t&œYLhQB.ȕҝxawWf]֡i!r'&oz%x;sx{X McrlU;QBZ^jݴHP z.Mph*0PPʍ) ͊)4o~! endstream endobj 2197 0 obj <> stream xڽYKWa)l1`؈}1!Ɏ=RkDjEjfǿ>/TZ"e{],꯾z,>.?x! -ŗߒ.PYxqY`L-=}g˜Ra~cA/O/HPIJ*@U9+̭iWjUM}wv5"Q*59c6%,uJ(֜ͧFKa[ LXGRUyLݥ$ DX)i Ţ8HOR= eיݾk f]6T T Ns<˙0+NT{6Ed~=AlR @YQM[=պ3k/qdCJ`ţ ̶ުnFR Ԕ1vϪ^nMcD~2lM%-Hˊk D$ # Mm2PϾ/j%H"oj#rdwasG！F)CT/t5d|]MZH.i 6Et%d(sH9AxK2 aMNJU] tNI1theI 58Q`Z$% :GSZ h,KT[t!387e4鎇 |j)di;Wey`$RA]+X4ͯʞ+tނihVH`Dָ!(P$ VrKq5V\~9 ecmtII&o Ob>>([e@$4b$FYm)Dۄ^B7`O 9bֻeǶ]D# bC&c ϕc}i|Ю;_@Al{A=R섁 &QhW>|Ֆp# Xg994qεA^{)y'E]llp{v3NKcr 'o5ٛμ{nR_IW8'.Vdz/v&mlnDH1 qOWNJMj`ũϛW%#\ޔY' &z6iA೺7}i Aodw{{;'2L,epF蝲я[lTw{+sWBٸ<($|x7b3Hdˮ>wka{1=T,Pi~ 6Zx8S6zD(4-}1?7cIฤMPI^;SZי燇y:*M'i햅$2`/qR($'&VW1 hFҜB) Pd )ߙ,ſC:KAIPYVU%G1%|QD[b&p!rrE3P̑<dYPBSPߊM&`_=dM{E+<,r[|뷾ܑ=w}l4tKW]˩ w Dy9ls5ٕC<.}u-_wj{;Bvk{waN9X2".tbУAGKNRSo p6+׭5q8=THA Vdu9jik#IIL/_04׽q&e sdt{JG<5̣!cbP*dS !0$,Y5a qFH4`&@h4/Uus9^&U zĮL"(AhO mӧq9%$%G0I[kNIcb**02fÉ;|~j'soPL:6  :JP*M!'bd:09G"SDi2`kj8CL\p >w /W endstream endobj 2200 0 obj <> stream xX[oD~WX:h=;*fi "~o6x|~xWΛbS~2%D!X+{Aΐp3=Pe)"D8Q˼2RUW+~Ǧjoee5:EE(eFiH6JĿd]^_\9𰵃awo J%sPB( KD"Rﻁ#u?w .|.dϸ$uֽyUlM9ovUY .Dvy0 ኹX̮:I-MP"(e)wFCrޙnmА˥o:m^u];+(uVuYKpHtPەWĠ7@:S"(_d׋axRPo:v 5NA@b?!pbIM1D <ɪ*{0wD,ŲX(V3qS耟4n8ZCpl~:!1O5!a4(MC᳌?c4co28vړe=*!<Ȼ!53]9H%{ [?Ǡ2ocXAOׅY4;bqGi)٫84kUa@-R Xb?NE(FĚRn暈3|څKMV*)v<{1=ѩc" I:_D #姬CflZiE8h[jR:iԞ C)_0 aC C)sK\)&<_a3CfB!*&!Fٰ&Wyj؆ ZXt])7U~^=[1+X;Im_XP&8+[û/u endstream endobj 2203 0 obj <> stream xZo6~_A"ǟRn Â4yPl9jK$ ?~G%6P h uwtCi?4Znחы,J2At L].uEH81ȗDj|t|./HBͲ鋷|,7)Y Wq[tE"0㛲3cZ Uc%R0.EH7c}ɰ U Np n7!&FtdY_3e=8Ţ %W]F7meojT`ѼsK&);ZWDUB҄"T[[i-x7ᇈwm+ɸmHTFw|a{Dz+7.)f[Vv BS{ W>b1ӌHr?hy h5gS6V!A logE?EśdEH,O duP,# ,v=/LN (0hkE#\[V"ai\XEyHׄIojVEU3DpJXߖݦq څ[3$tylwvˮ~N01=y J˱ NLd\f]#gxB!9Cͦ6|)h\3b70R<: >p,|Q2[P阔usaz3r+G?FX ”2k0 .BSu8Ãc})9pS+!$Q!'Q{MHR؉ Qu0 fM&y۔KmoM& Dtp1\KAb. O|T }8}4b2#Zcπ!y)!ptpaߎX29aSGF53"i~WR`V}iώyIn~"g|C V3? 2G.ӉO> _aqگ8[)o&X;cZTD)fnH"R_%/z D>41 L $3yȹ|vf+U Ev3e֡vZU !6ݛ;W$\oeҡѯģTi%$\x&!f)g;RbTY*)BLT3BzFfc/龈&6߆A3o B t< V%`Q\22`!~.3NhxH.{; *f:3αfR˦ba z|[,׮ך)Įެfk >v9ě\Oj:I̔)殧},F8Aݾ|C숇s[j mB<, XSNݝ>u#beeO" endstream endobj 2206 0 obj <> stream xŚMs!`sM֩Ԗ\,( PLr`)gf&'r"#'^?1YM~x3HQG hk1}Ҫ^oOәֺoϛ͚M/LjkS6:SA:H}wlfZܷvjeuߞy}m̆0 j a>}܂qu0U5nәU^Wӱ~GZ?TmiFajgov[ODz쾾_Mw f,v3]-mEӵƝpә(Uk;j5`U/s.Ƚ4&U߀oox1f}p FȎj綣I=ƱXV"f?e!4]V X_-G+N~/%Q1#˽jik&nٶ͋^&uyj;$; .Vf6a$I bLZ;X֝IOu>jy7K]-7;3jsWI]v"W7ۻI}:Ú,R#ZB>wu06QS8R.I iAukiUc((_Kϟ~n6 K흡 D=#YM^O~;"-=CQFhY;ɂg dLNY+0X;9WNXy’ 焅ANsp焅J}Og /{MTBD)m`9GXx3D<#apL#p=CмRX8_06C"1C DB-X$KDe_;p?GPڲC"bx/9.ge ]P2$2$/ 4gHrjbGW0=!(F`UcF @r f, @  !J@3D H @ ˠe<,\qST)axp<!,B'1Ф!^ I!@ ƐZ1Ò!1daXRC|Ē!9dpGr1ruθ'b I"%,CL 9нAC"8Da'b!9!W Â!=dâ>'A)hI26gH9F$"M CX0IsF& ib&r'10,Cr&<C34)B%M,D!MG14`HY41[!xĂO.똁DFt I,H""* !Qaì 5 FJ!9G`IrX0C!9Te< A aVz2` Vq a@YƐ * 3$9d 9q<5,D0GP^89ZX BA7#X&@K?!,vĒ 0g !d+t+H YR"JBz< ,AaOiHI$v[mzѹ=ܒ9S jj֋{|U5_(ٽl]2`i 8 XlWMwھW3Ya%oŜR.ʺDjnz3#;0~; l*3NQ9^\$<,].UFҌ\b羍gvt(Q, 4sƅV۩hjkyפjiƐ~봘Z* .->1J]gpp<7Kz~0C:C'Bqf{.;]^\ 6N&VcE.?k.oFOzAL$=f}^>尵lak߅1~-aI4Yb>_=ݦ_˗c`daVԦ?dIi?ҵ(rFtȡpy1NIznYGmC?O?쳫lbq"k,BbhxA6|MH/Ss{g~YÀwdWB dz)ͽ絈Jnw'fDۑ2pfh8}1avtoouxڴ>큾 l:ؘ&ij;k?sX40= t<~zd>;, Gf, BysBB]VcciY=lU"[E@tX{1:ck7pxٷ[4WBus3qO˱0}oa6]`~~یHоǍ7*5]Z"JiE,vv W8z77"[S+ƞh~(ӮPAhǼY02*!mouӕYS7kؤVz<$GRS~ooad-a\ Jm |;*؜'}pdy}O4 S}AP:4>/xYQ@B`H7"6?'~?T endstream endobj 2209 0 obj <> stream xW]o6}߯JCS򞺭yÀm^<(6hSlOeߥDK9v@\"?i/ѫ+%9!ZEEI.h(s\$"~]Et$7#(."Qd L}[[屡Q .m4PR: m}0!4Ɖw!߻M"!^!$DÈ삈)ioAv(Pee56vW(E\A`Ƽ?ڭ+&,Ȇ=H05H?"S<+ӌ9vH]b:XΚT2?LZ`='2V zN@v2fۦ(c_ `N]`lqWVUߕۮmdJVR)m0i&;eZ oNbgES)Ĭfk6@ ̫_ fkDUL`&vcVlBhkT!0M2St(}qoBJOt 2(94Sڵρ (Nqc~-%HWA=[1l%s0QGG%,QO"dMMieڏ|Nl__%9Ǭ%y"C=`= ).;i@L{lq"jQvuQ ̺='8qۍ}#߬FEu2BP*oG~>g4cXjfE/L:oNEq۠RǸ=c,'\I{,D%l'/o)7NOi'LM/4. G~kqӐj>m][Q(% > stream xS(T0T0BCs# 2PHU4g endstream endobj 2215 0 obj <> stream xYKoFWH֖&ӓ4}Hj=9b!IQ٧Hu)3@ Eѻ>,x& nr9 ig˻ *fe:/x%"3r07K,Gff-$ꚲoL/-h$n-?u @Ӏ!sUQYG+ mMԇe0iRU)'IQc jƷ1@ʤjJRs6>x#PXDQ ]mNUZ&Yc:di͗{-p/8NwF):t"V:R#W&;e?96{i,W+_1jpι{SE( s9tzD9dbe-&!*GVIғAv븁BAf8pO^ Gm!x]}+־1h}3/; 0"GR_pVf @uN0&\.Mf1grw,D[r` 1Nhnw2∏h!5.ף'OKumZT虶a+fRD29|R_Q\N{!hMDfWS;׻n}oo6z K6j已^pqHJXD%዗-nF(z,y{D^(OѠDvҫ{jWM p^$B;.>'FXX׿Ve-6k (<* 8!=mv )I;:*qK r,_b1#F!/N'E3|>$֜q!Iq8h\ )?_)32rb')5?j)*Q&}kDk`ii*Il\ ]4BgmKUUX5QT9F*SEsVA@_pM0G[Tٶ^;c⤆nr_+-8Ҽŵz,=+@CC8nS d3]LXױ̅.dh5E蛨p>H_J4z&5'ġ agvr@jQ{HY9!YcE}Nڱ96f0v^m Xo ؔP)44n@Ww};<+dmb MGz< ޘ7]r'_bObB@]Hf>¼"rz26B $a@QNF]f d qiy.0цB h/g802_{T3\n:C ϓjQ_B"&"dｮ[x{kROsу G=c^(?sD,%'뷍>YIÍ P NVTYNbH-Z\,W+a9{ͿHd endstream endobj 2218 0 obj <> stream xX[o6~߯Уe:C<;DHRQ_Fo>Ј`"&"YDR~w2G (ev:inSE$M߅ĥ(M~ü*G7뢫,u,S4%S\ZyB$q>n!#Δ^ESue] ᤡpTXnvbb'Ez;;HR2ĉx*7e1_[j׻" $`,]Aӡ"H5'3;)|S47f3F5 67QԹ#qaW{טE9-Z$5N@5IrzvJ pDW/U[ͪ욼ypC۷&7Qr6 ȗ7ƫMy Y(RRLH("@uW-J/H.pݸ_j}Ne]V/mP3b*]>T !_Q:UH:N'#v "|].y ui| )1.LSepZ.68p~u7w%TUR['v!ՓQK!}\6=򆱏e? q{Y!R`)u}{*8seˑz|5/D*ݧDDejEn`PbirsÞF%PΒ\GaSM3=N* #ǤHӞ- ph'(rl攊њ+1Ii}4g`öm0t4nsځri,_{L)qv ;}-kⓍP\=3#ӳ_{)Ā)Ë H%"md3d[([+KTͷA=QE H )sߛ sEGՠHLfF&f:`-L\5J6j,RpA2ݯtGd)x>:Gp8逨 8s @Iom [J@k0/d&;^ȎrgsMR<̧\s {J~ 10c#݃QÖ|Jʾgf^։!IBHtʕɀ"ǝĩII3)S<5)$QuT⵮N/& x_%XK6;08л2 #lJ3 HJ U"x|N1CM \3fHJ> stream xڭX]sF}` ^p4~hg2ZmZ @]@ - Zs| HM2tAQ,*>6ZDȳE9/*/$k+&O`@5Q* kDE$$ |MZ먶谥rp{+k ıCܚ/If>;k CYgW("͒>Tpv 0Ar.Xk4'x7CRyZP)+/VŴR-/BA射6N">$N/qDA1D _{戳.UY?6yYELxЙ'FBoΏB@W l(#̻ki!Duaߘ4lbC(\ЀmVj3P){H+s)`ɇbYE$FL,! X8(ŭJܭ*WpKpJ?iEK-&] ÙM<ǰUGS%!GƗ;&PjW)MkXNg;B:.Q~.-{a/ w/k,BCm9^&YӞƷ}ݠl3 A.q͍r*|!9KΫbs=bC|ބcU di\ d8!]a F0&>II߰J3.%6Οbaۯ;oJ$]qLPБR2w!KBK=1c+qJ"DZ,3!$8A ְ @+F3;zlًEmbe; 7k1##H Ęĸx_v h sw}no?JLk 4N״뭞ŒG'az,CDXNȘ#HBg0Ѽ.xC=ǝo3*b]Lf[>$z&U!:mʽ Cd0` 'h35x7utakTz10#ǓΗoC1f#3Z.?zd+2G= @0iȄep3UJ 'sha!,™^k`&k{if^#;uX}mb7u=dB0da &a:͛r(Q}]v_6j\Jw,Hվ2MfqHk`T/O; endstream endobj 2224 0 obj <> stream xXnF}WC) >R-AܾX~P͔"InbY.WK]m=sff2a&<;\Ҍ`d!mFtF2\gW\195"힞}˨`z?wἙϛ}oj^4|0|Z}s[( n&k5,բQpaL`;/K$H!ʼ(ep$ X&e-Atm`wDRzʮo=<1Hsӱ:(Ft#bi|/%q'kѱ\^A ISuy#zrV $Ed*fpa ThX2s&i #ם̒Y**&w! 17A# >;a56R$J5ʙ8Yq>yܓZ CetĶdmRp1Sh1 9Lq0T]g,pnI R0vÇ7 23]Mb]6F|X{P\HɄlDliOUjs(F2J!BPI*BZ6ISq&##c:kngp<zJjXƶck<,fiWIE*WOըU^ W|MFLhU{h4,x}mC䔄H&7,J *~2qE CU)珅Eh۠rX1?IYrR!%ۧߏǧѦ[Y6Aª,z.*q>g\ 0F0=Q7GP'VoD&M|s|uCyj(shzh!gin>ayôY NbgN|]Ϻa$[9|[V@3b^ۤ~z{1tqaamAMr}mY,|D˂^ ,tOfِx`57CπpGbP=`GYS3ADC6E'D#^i MBXOC H~LN);衼؇X*/EhL9Fk e:9dcX ]JO<ѾgjlL}>9"Dvj;KY7)cw,-DR;+$2,6Ⱦ)uVw3wa̿6F kS?μf(+۝Fv9/jJ^4ʶ[c)ԵY5?˕/So>v |3ν}v~B8xE C'%{`.>%/#&ƱN8-vRB||{Z"x%̞['z;6,8aj..ʄ5488.>R5o endstream endobj 2227 0 obj <> stream xYnF}W)J.ݧm6F_<cHwBZ؀Ii9;;sf:z_eF NHt.":" %\G׫7m˘1 rsۺ(#NL]^1e?}~E VѸ[i&m[Tj b1fl+_/Fw4ǐYF/[Y'n1U|enC;H8я!1-l^Yq ;.>A . HLY߄6aLWB(݅KLVq,K209cltmsP8T %O >; eۥ j=4_ڇ Z%H2A{,&NÔ<>Mt]ԅҬ@&mw>/Lg{ZȪҴ6-JlS%@ϔT\}9L+Sgwռ+ C}ܚCm"]}p[bA(JoHFXy#/MգCΣ>ر}ָ\26 rI.Y$tϬ nrh˃"[H|wfp t #f'r_v |ugɺRuenv.آ\VǴ6 )PJ]^f2%t0ȌJ,>$+:ꆆO]PbI\ڂ=U$tU2P'vóύJ賢"?%*Pt$…BgBS,!O5QrP>-ezy?co endstream endobj 2230 0 obj <> stream xYKsWJW--/Q8Z!!.#PH*%Ua0PcA&a|wFIJS,LT&r0˟.8cE$r?޼s7fS/Eu"I6\8l-ԐuYLLI¤մYݝ IJ=x6E2&L wUZNrba+WELYX+-W)ޗY[$G! M=a'Ϧ۔=@ׄ E )mo1 z_J#vs$Z, q/SbcbtT$A4A3u <1]I?q8g\0m٬,&j[vDR'P5hާJtYg6ia?>ԇ;0)1$,iضEU~=e? ߋr?ڡi0G&dт89A)")*rj Kٶhu9i')_L D~VH 6M4- rX,oMmTmd9DS}xugŐ]HE^=W]m{7f_M^4n`]Ieh2%3Ul TXz4,Gu[WVYBZH0n_9,S'H22R1.|Pz]Ҷs8 ')garf$a]/mfH6}ʂ]2)8}h݅fq㠒F*"y:DŽLē }RDoRȗYn0b(W[oWL"$)I<,>]vH &g>Ь-kʽ:z$SdB+fixGIDY`0բ#t1w\kRg`'N)Zw1k?H׾S煩 eL D,D9`LvGGT8 3%ȢS6,ShA/$ ;9oSqk]}:n4 cTZW R${ڣS[}Ei:n|/#J0ПO~/b460b:X+)nj};w/F^wtTѴssAe5- !O**,`Xu)Z[Bb(Jubvb6푾:s*\N]?3ݹJ&ɤ.$inlϙ,3Q_p,%zT&3'L{d.Fo R^7 O1'0?Gb/Q<[cKc, 䩈q|Pg+mzJ9Y/={x|e)J>׮Ou+k)Z s㛥aA` W [V`~ ~qsY8}E?X=/`ee!9B+ș=ON.kHM5jb (WS=(&dJ0 ]:_uPP {pֱ 5 ^(7 1]ӛrÝen :SL2auY'v?&0]*Zn˲/]t?%exW?& L^t 5!m IfFe*WK6.xq<ث\\g>iI.j[_akbl3F(DLHދ;\x|{3f/oz}߸}N׵kl+FOPeȇ?'QW;W!Y@;z!r== 2ъc#S sʱ]:.9a"Mh"MaTmE}$G4<|m`9`6}՟ S H&A扔U] G!?4^6mmnxgSYyqyeJۛN9 ,9lhp WZR6N*y Vf|b}u]H1o/!x endstream endobj 2233 0 obj <> stream xXKs6W!TD' 1cM/QKPLRu%RC&B|~ qw5 pd,q0 p`$KS~6'4b1›e3<5`#A5'Tvw\ӡЈX(Ŭ{w6(SUEUO"NXK],wJ5ѪV+b  B9i'&A7gSp}i0_Mht@qo m`궪Ny.|x4][ML  x[w*X`?YA1&T P ?HJPUyt.^Te}iU-].*ya_w o%ƦdMi(c bTv_ MXacp'7gȆ$m?,!'PE5.)I${HI @d|>鐽}\Wuv^#%Go$j0ljS窵("*Lp谾ժ]]ҮZ̅Ĝ7ahGk@<9H;\M8MO9CBY>iG',Ai" 2C-UEGc>wIm? E̽7dK:Ζq0 ǪՇ<'5]iͶh:o xT [ڶQk*tlWj|T%17K0Pj8# _kw }znr5qhYH LϾ=@xJZp fh-Md1mS$o8aA@" X0$4 $wOP~kSޮthip k)'ˎ3_krm,M*Ooo09?23 ofN V #ќJrm0,|LU1&כB1e4}i6\r҅ ʭQOuE7{[GNśCwfzf¡e͋2eOмƠ1|GGFzʡ5Fyvά`ezӶNWf2wLj_E^j`-Z_s\ N&ݎ 2Y>$XggE^_Z^Ůk߾ [?,e7ǽ7+ e> stream xYo6_!aGXu0b+0[v%k;,9Tlw}hELQ]D" H(tN_ш`d!uDtD2\G7x◈2b0~' c,Nka\ yv/WxYfńnb} 1Q. ot]U]" l/6?^D}/Ǭz endstream endobj 2239 0 obj <> stream xZKܸW4i)` $  wkfH:O_M3`6 bW8lA[b'`Xj~jq/njbJJ4x-$SD tqͮ$D[K*&?[yKA B)s?â)Q,ViU;zzSO .pH#8 sޓm'\ 7˩n 0%z0Yr'UjkX>J-nO`D* ArYЌ;G6xTЗ]ΈΎ7N`aWC;: ]^y5)tNm ABX4eVdv7+fNo^^C/8,$d,VH"΃m7=W2|u?PTLn}e׃8c՞pzIU.글ca~A1T.NȞ+ G3tR4Qb#yV"P{l̞ |3Ji `'(N\]kB1 LjUS. ͪ_:OCC9fz+ am'oJR 4nvx@r0:y݄=8vrf&h?=tlPB1c,r pF0btdKbbtuup2.5VB& O'-S4Q9?5Q ½Quo%YX:pUT*-Մ E}|+E}(ahԅ~3]iJbq}i7%w.zU.f]}x*0SPNP8Q{\hv8@!w9M #uv/t´}^2&@,-O$@2_*HH17J+BnѦl=΄kמqTZTa>m3D.S;7kPoyxecxaeWwA{2<5x~ Ʃ7GMy1Mz"~[ PXaߝst[3,U/W8$q1..AgM9F穀Qiٌ<#F ~s"X5KHv?-o gDa|QV9;4u[{V_цf]X5W8CL7f*5DpSr:sҹyp)at¤^ ]?M%$z+I42"sI8r+="A樁+}@ r5 +;^xG .l"4f6!ܘ4k7t7R4U+s7p&>7`c  xs@FEnvz`R\ss<"p"@" \Mq#]uhef1kr ip~ӷiҹ-mVH4|*?|y€*ְ*\Ce"8-8DC~ӛ,ߵ/mh0M&CߎS=L̿mmP䫸 p7RWL_cBⅮ(<^bP[j^o?-V|& endstream endobj 2242 0 obj <> stream xXoD~篰T)p-Jpnm9Nv8㙵׮])*Uv63|͸LjD~H(hޜш`&MD҈0y].cLj2bm{w~Yr-?[|Y7]vwmf MnmUqZ}sƮSDQJxkMog<>ʮ#&q{C`0wYѧ^#~̧jD&+꾎 [:9@qX ƀ(ϋzsr-I!wn't:Aە+f$no2Pp wUoxݚ]W&܇ol8h4L|Әz0pG_̊1>`A[м?kAm׆{QA8Cbl(P9 CPX'۪YmPl$s*T~\/իhϟf&HlBS(E)|m)MefEWk~\۷Mhoee0*:^TmnzfÒtT1ϳG9(d,o+g;ϡb>v@@> 2/L%/:_L:b8 ?0${(yAt,՝Vl)Z&(^ q=-R=r;S}ks]WӁn #LFl.?՞H t*/U{'gF;כM" OEb8=N璨|@4nHC0WC:68Tvٲ"J:a>ӪC ТḦ́Y&c~QRYO$d$Y ,x|`ܮ/SNcpPEj}1%W`d0tu+`>_|ed2oHLa`"j.86H(}(QBGTH8l㦚lhrta@́87R/9 Lj!0_= > stream xڝUKs0+4"-9(n aUbP~=+Yv>$8o!1D͐n^p()h 1 h{U\dMw=d߶dhy 4Q,e2`?>6&ZɇP3f"G vGUD ƛc7@Z*C4i{h34|6&]ٽ?.9_~pۻu>1dʸƷM'߳X0ifl=8}*KN L91%ʲ) \ &Mb];r ib":ǻCN%Dj]PH+N #9^.bU'I#렇Tӽ-(:wL1H|CgXŬ,n:&Sh=kckܧ m?TxzjIm)C1>5qWϺꦇC_VcRa8̩z][am9]2ۂ¾ᘅz<ޏ0½МwWҰ,G$Ն,\cČ_7;-KUf]zh >4 L<؉Z^'S?qIbjye [Ae:C&萒SM.Kʄ Unџ.vu./~导d.]}~6 endstream endobj 2248 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 2251 0 obj <> stream xڕXKWHU}sRT|c*l\ aB$$>xԀvjIF??ˎ*Gw_;wyhEꪦ(vZr&Jґ& GK;]w …b-TԄ-7Ke^_a%p5v $rIB)(e)&px ALo'ЁsvG!u0C\|g#CٳjX lϯnǞbYL^/v e ,u?ØU$qeԵӜcnf$Ǧe %AU=opqm%޻_<|ޭPFGtnm9ňh+bt}uQ=SuJ5eM FˬJn l n'n_JuNNDD3 "&+KbT$}$ $G&ZǐٌY%%|绬u}g۞h ?Y<:9lj(NQH$bkHbfW)ؽBA 5FhNdzq*!tT_[+Ɵ%@Di\m)u+B@Ew`PU+P͒#SEE 9Š/^,&o|{h+XFcdD%mv$ ކV*@׏f=jn!Sfu] ##liUU8peJ)7}Mp ^T)b{ 4y* mFg@W|Fih}/Sq//c>Go߲Q( a6PGP iRmj"/)Rlm׌00N{ (TD lS)BuucŮoW1`Y.n*= +`TRh@ڦAf5%Ut?/nUTZ=hߨg|lC!Vq4"\EAw,xyڃ |fއⱪ#g ^/^D^VekHVFjy; -e?AbS̊s;+Ik Gwid} `׆/PJC%F ߃ klYʸ-&:U G[sRX-^s5T4%XBa ߗZ.\8ނ!Ls؅-+n+Ataxz9U6,m *,QF Sh. 8/uup#+r:,um)Nx-2R,oӷ23ADL4~iehLa_BCJvn4zs=/J"^׃5p'CM8y8ť"`Te9RWf4G9cb4TG7zsuD惿W6zG։S{{}=ހS l&p b8In%!yB F&}Na_T?QBAtLQ^PY3ߍ NDAʲ;kJh]1gXM4^60>3@]Ok43o!{Դw>mMl iaCBieG@ VNtϙ/G"—֫>M`#kyN\o6n &U9?SQ{ Kt7wEB?ن>_: a8t$xvepXxi c Lw:ܷ?I{zf}$ 4t?APP6S"}4`V!pw~-aS,qpcroau`#`EZs⋋cq+51p[Ak#uHDi endstream endobj 2254 0 obj <> stream xYݓ۶_qBX0 zNk&>D"X"eNvc v]0<j}}/XY<˸˸drUf?eB f_~XJ)Y+=|nm*shb)\:l}6ץli+ n®),Ut_VCW/~& wK8לv*`qvLr|xa SN o .7+OܹR:7cjSb¹kSɣDDGo|Oeκ?Rc9t$D#͔-*%ے t`6eZӹY,9dvu?LoyS~?Op;t NaNْEbUB  ,|\`~8TAaڝ2mfR{mqrOCh1DI.;nSޓl)Kp,SroA~_)mK<#W| vywN;z[bU_w~2c+TP< )y ?:fДַVy޴=_ֺGz ͷAooS菙EHJ.-,9ƃqi~H%R!aTUWjZV<9ȄSC.kXo64Ub; Nj;= z6mZci|SQ4IV3Lx)Xq! ?i/Gkq:,T1_% SB5t!3rTBpvlPί^{9ltx#}dJ9#]VF<IZl fεv=ཱྀrj2 p`xVb4]hQ^c7}:QpL$ZO@Sǹ5mvz뻗cka=U%]SL $лET'l2@ @o>RJ9$%g(*S34%S.\D}7g\ċ"Qmu=Ltv֫r\eر"MR␬>&b~ÞR7% ]4 uQFۣG] O!®&f ܨ͊0cHVᢀW!Z[CI &FTmwp)a5}КFqEs_wQ͢ _KÈ"[Ϗ`-T>[hgZz~~ _#Z/GPmE٫+31& ]k$J\]2!u>㓊ч0 NC_(>ObE|<||⬈'Rb8tbF73G(c*1#%t??>gt endstream endobj 2257 0 obj <> stream xYK6Հ1ؽM29h53Jz$~,ͶY{Y@s(X+1?iyvQDzٌ n?>lWk!Dj-?e)O7$SD F0ZŮel-Ly[>52gGon#ޮp|_V^eׯ릏 za"Rl8qLv8-lM.:Z3CWb W64O]TsD3d2Ie"{Τ6D$ |4(e0>PQZgk"Ms]z7uNus2?9>mn]K2oSltl 0pMۻ 7( q =EM 8oOSwMѧZgh>`ÇWwO/z_uj^_^E7&&[T{"R^ WSi 0 qBtvybw"Jx/sEͻkќ27F p`ƅ8HPѢАZ`^\ *Ca0 ,(GX]Ki1TĕUTy]=ڨ[22ߊ/*ViG`TWCI2ifQ`-ere\7 E/b&/;]Ug|[-"m Tsqm9x=͛2hoB\IضR4VsED@p"-q , qt&Ty~iDI;hޖݦ;k8)Р|%VAr_{L &\#\?5cT)aP尝9}Pͳ?fc8>>Yِ?AfpH}P`žbWxRLvاp\[w-@WCbX͈v&} I"$Cc|(C`uroS.^&-v&rb$eȈ4 ӷE-<`8pX9ď~>˙ɸhn\2圛vS'JlU8ɽGeQH0o򅑧4آN/fS2o#8af4$%39yŧGcXIC+[B5m̮1@ _ Y@!Q?&f,?EaXL$G7v^qSw&hŒQ`Cp Sf%@BDzxi ^,uUPoBݽx7"E2J )OW Umy#v{bB۷hi.[$gaRg*)ٔX3lV&a8ϡo‰J=l@5䳢(l9@o U Q&)(Lcd)ڪkj@V{6S*$ %REA>fW/t I -s2⋞ y}sWJ )+FAEP̴G Q,Fc}^aRo殅ؑjGvntkS"`Wx( bĶYWVPjaTn6)n0iUԽٔoR.>V:J+`AܥFDs#‹sUT]Xbا"ϕAu4$$Q('2z]a4u`(͈_ }*RN"at0. UG:G}#Y]ݟ~*#7V]*yR>٪/K[:Ic R<䈭0:LC}9 PdG̮xK.ow;HSu#HL? ]7m?4q=laG3@.(W!  endstream endobj 2260 0 obj <> stream xY[oF~_Ah:f\-vw^8I>9$\t͙!2XaHfv>D L1lYvw/pu/۪Wzo?}wg`ʻvߎvI"(C-xlU"l j^O;W.]@Њe[Te^?E BAEA"dRN pдn/ެK"->{d-^EUgLC@@ۣ˘,M6݆6\Z0 8uͲ.>FjK7S, FrRYgH^;ɪq uY.dA8ncXjM/-_Q5 AO]Fkq%*_*X/=%lw{ES"yo f*!pU\սa{hk[A:NI)BI锿iQd@vܸcS͠L35*Xi~MVL:X@'Jb1&<Iwy>%3[LI@zpO/)M'1uFs_Vi{ICT-ɋbtv:6*U}cisjKֿVS+\w:ژ K{(LTʸA )V~cpLVeH<)/17Rc,`C8Ѯ6=X}EpReUλ22l b< H>O)c sWP(*()QSls@Z}?V?Jד2S,(k` ,]+zhs)0< PH&ҘGQЀYL<fDfj-g-0"'7a.S8 e"ݕ||C۱ 'C׍MD|ςj[7 EG֫¸`ˆ*Xv<G\ A;ל}\} Vu't}QñHÞ://|yء%̽]ކHCqgo[pbM/P\ax}n߰ "g5[4͇ʾ4&*(}@Ff/v}tt v(Bz'_2 -93Е G-3*zm4:Agw¡->BWh41Wx[cC]hn]ne> Or5 AM^uK3Ī*;:OsguTׇ*@1rF{{K e~B ({|@ӈ#)Tq%v\|~6(>}%b t(;!O2?Fʎfc3!Ov ?dV2qt9A j o&ns\ E"pP@=F4#e/#vTFG-,7r֗i@cɛζ޹7(p"loug0^eFsڭrmk<\$Wf֦ {ykhZ9<0 mK7G-Cz+db6f(=AQ` #@-_:n!z:竨ρ]y\ :2N߹Gď/qlwzR:wﮒ_ endstream endobj 2263 0 obj <> stream xYKo6W1jdnn@a򚶕jWI@|҆Z;= k~3߼8N>$8N$yZ'?'OIssSJί/ҷwŶ3"XYd|ؙʴ9TdC2ힾ>VPrج_1fnug7o <ɰ -<](6 ia?Xz۬vzȈJr 2펃h:M ɰLW1k͇E KSwJ4UAeNpLSX*31"`1_k(e[3ۦm)n_\]g=nUQUѽ}dG\昚M}gph7UњE %[(CTӋT[71N=nxz+ǩsU"6Qv#B=ā g"Ɇe{w̪rRtZx.ӨJ|E'dd.ɨ@Dx 45 igLSBӴv01RY\x1zqۄƊNXbȟ9<>Q OȬ@ɗa/zaZq#EsS7Q"{^Mlq8,B|2&jrÚgI3rh/z?$h^taƖLiWMpx ? *O+$;ң$+ I=m5g)|k| 0m8x*PPJZ. ŧj8W(l,mCm!JW' EP`0K^p(( mr)<.',B%TQq Rhp}.׳3wzWA dlsl/lƄW]m?uږ R4MĽn=na,"aoF}pgX& ŢЈhy~퍭 zǎб5XƂ"IC-'N7p!@L>!D] Ʋ(AyúM[#ھoJvR@o{n1@,.wvKH>*8oYUyE߾;tvYa}dő{~j3( ճ.7vcY3,O1n˝XשAwvάm/7 ^v1/l`MEZy?Ti. .f|ZHCc %edH'ѩ!cRCKsX&\9^ [(ykZoH3 Y(ԃ/h!3DzLbW9߆fVFsؐ޳|*a{1P# <ڕÁPl@2\W6eeiӘe@}w?v endstream endobj 2266 0 obj <> stream xڵYYo~ R.)gOi)@KcD$U'E|,Hz(]ٗFR#Iv7WoHSo#"LQTt~K.>\J6w_zH(q^wsoݾ4gPw~;].K70Ka\!Z׫84ž|ҿ58,>_}+];FWxAbWFo5!ڌ#[!Z F .W KU|i?ku(OSGWWMs2 P"N1]eg:#=&H,Y4z$d!<"A0|ws; q"_ƷvH8apucq DiF~*}+Dŝed奻2Ey-@AY O21SjNlYJo`^{~3jbA%9TiLI7}|F Me]vGV31O":p(.LJ}T7M:IT66tPzs݅+Ce.ǽ 19!@Yt ƣeowb29-N9؆p >!Ӡh^m}W:tK" 3j^uTt6d}+7}p?w:DUbĻE]L9 > F݃32@{훩hsr4=[=MqҒ!xm2%8DS,Hjѓx*b,v!J)Q 2r%YkjhCaU0D(@Eb2Z·\˃;62@zHN.ςSD^3nUi2>5w @%XCfǓ>nUpsu X c@wM%Y6R$2ڟC`rБ6gf I?mr(`l_JϨ q5Dɐ?15Lg*ljk;\L_Hf:G*$;tSlaW@EIy{v=E[eg13(f&>!f(ĠXdx'>tO|EdO2hO*a][KPz.g&nLP:aQ j7nUkjWzḧ́̊`'JkGn T/RaYP3u^oh.Bك 좼s?9K_?.!j(e7yZ0Ee8mh6<R~ !`C00 8þ2HQ70ߦ>X֘+K++NpKvTeKyƶ*!N:B5b *1S*Y=hg/v2aQֶkwO ) endstream endobj 2269 0 obj <> stream xXKsFW*ѦAf8@Uʮ\X KFy ikR`;k[ɻ'9D'E%Ip.*L%oUF)M<]e\f՛?9TdsBrl>{Yؕ)˛ZZB` =Noʷ:U K~0K땗$f>Q$ ")D}6fX  0]\9spUS UYg7>]Qތ#9(#8-{=+Ǐu^osne]ݖ⼳k,01wY bKݧ|;r@Rʣa_zUSn]6Sw0#PUt C99U@*Yn̻>\\\k\#|et9Tm))~3[l/H1l5%_COQk -e"t[٪y5Nˮko̊!~+bV ϵv۱w_`}&̍Ƥ1bt5ZڐkkplRdeוޜHܖW:Z>.CG[;)$>( fV<(ˆ4&}Gvq/Lwf" i4gx4 ;FHJs& }۽Y0OQ.VRSPvn3Ga?u51t8jśDfz̰KS`>sNBx/қcDgˀ9-ʗ@g&fjT3 VJ~n<=z|B(>G0omo]|i!jy09L |> ,^@V8yhrsk㭎Yu XK$ YtmbUp.F]oz~Ôe]nw%4e7ٍ=Lj yr[X ?PRHxCuS$Rs> IxV,G!)[qNt94Ь@}LBp(4!ᶁWfzܗ=uoB`1l`![Ʃ83[°FK^`Y1eф])jb6/LAQLO >"e+[&@*ܻNٚA WH=M]uU-l,q!$pTܔ[oڨOqum_w:? dA/&PWGs0dJG[΅Fjfv7˾EO8 endstream endobj 2272 0 obj <> stream xڵZ[~PPޗiOIʎMn`Zr;sf,/"to_ItqfA9)Y?ɴd˷?-gDk_ۻ_Z8Y<_"[劙l}U͒l~RIİb1TXZ]_'rI8 Ԯ,qr >@W0xˡ gM*'秔!o_-%f*ŋ0SMuU5Շ%SYeҬߔgvs>ƍ++Z@T~N^dd4괁{ɺ9'77rWfL-?|2840ZIr‹ +VDh"h;)m.$Wj/BVG4,݌ 8ہ7GL?=ELX+nnLA[#8*+wX3۶yGHN09X?TT~Ǻ9ٱ;ʡnF(FC 7aCQ !O!ϖ+}䪺 6QlTSD: -ٻrTtuz[ަ$'4x[غsh mjNd.RzDg|=:' `I:zpFg$ NT)u.zAgYuA=H?KΩ g$(}a~؟_WmFVI҆!ž-þS2OJsk@.O/p;wO( A_!e[M(=e]%;S?jέ??\| endstream endobj 2275 0 obj <> stream xڽY[~6@CxCOdHim,?p%.I*3^Chkh49|-(e ]wonQӜ-,[0Ar-6CW6T0vJ)wcYvdha`g|(ag0ʜdLΓp~Gͭ 1J/>p]ډR,#=n g[&sܕ5Nt-dN.Ccdb-%88ɶ.z9)ς<r㦪*&N*'\E b**QT I̻j >X0kχ= >z3sl{?8]z$-aM2kEkss%u jWsi%r,`^#&>>aDK}a^ TݾGNg$Uh [&v yv 6%pXbj͔ShG6#_+8XJ'VI}]` %%/ oX7tWA(;pbMS8; "=kdy=NϘ*h-6C%Ժ²*(*gXo0vt*0;\` `8o15DP1 Nc6X[dc*/&VDME ZZE\^z8?bf .b^+8Tws4 Hlb:.%8Cz}6fg8C!B>u%*`&eu5䫯Wɶo }WKun˻JOE]QƅTd9nnF& zq8@6d>N-ݺ}7zl'#-.fMmUˮϕ' ( 'i-?:!@Sx\_n~ _'jNZ΅uk}>oHM,|zGSWۀ)=vKόW%鍕-ˏ?lFTSnB,+CyPRJC*Qg̦$/èII?* ѓK34KyL5RtJ#*7o6V+֏h` tfձ(!L dR J~s5䛁ak=Ju̦ KڧqIёc!O}>]m0dI¢p1w?ro*Y瓧=9ұbto3;|ڶM7[ s(Th>/ohט5Cȓvޖu~:`]{ Ɉ4r}/Ǽy_ǾgJԛA@8g0oŬġc'*L| ɡ)ESE0}t㜭"5 CMWe[m΅H9qz6TieI?$_ +xUAE?v@iXp4|1K&_YH"!Pf(@SZ=%M^;i[wp`rάpdfK$sWUQ2&mY?vO$ dn*KyF F0ц hܡ$i+KOz>M?ʹ7%: # 7Ul3(Me&3Mh'e;!^,96>AX뭻'CXF ڜHfCވVT>x@l50ꥠyoH :sD<0Hl=փ1MrǦS^J/:/K @h&Ԩ>L4^46y<"{@=h^ JN(-L=g.G%F/!A5+(a'i f\&I-=!#֧˩I“L-5Eν f.hyD3.#L.ϧ-E Ϝ? Ien*y^g9$\>kV7PhD8FSMAaڹOu Ko[7kq ^F3I,!Pu"HYQ'_3ABM׊< Ot ʢp౩6n5q endstream endobj 2278 0 obj <> stream xڭYYoF~_! @B!VO_d7mOv>yE E$קfŮa.n>$9[lL/ ԋͯJ򷛟\pq>\IQoOu7}SX&*[G\q{S/Jz{3E4+ͤ.SXh]wLW)a-~yb5L'2'v8b\.V}  ?řeKͦzU2Kd`A)-<@,XpMMXx_Zc ;/P9ӵ?s}=M1Y6Q٬-űaV8GWs;+e!ZoO"=>C"|4 Ľ7u $h!z^o܄'|<$Kد%/f,2,|6%etѐ'N]s(>zтɡ5•儂J-#[{״}Rb:ɀȳ,-,m畣k;UnN>cQbdU#')Q"pt'r/iaj!6#A3z2NNp å9A;Ea3=3z|Z^o%z Q6k3+wχx6{b폌"Sӏo;@E,ٶ>F!͉HG UYBhc=E@܃ڭM*$$ lCux|C 5+? :aő Gl09{\Ē]Yci MoIC4DzO#+) ,>t4_쑨 7`e@T`Qfdp C (jC) O8XBgG@q`^F]@ڗfV~|woϞy!ۺhGR I0GGl8߆(n LQS#' Eтsނ*w l <+#-41>pb~V }h6.!B42O6V=ά ۔Kr" yMi"7/Qض|/f_3R5 6t[TߋhX\q4'h_,?X= endstream endobj 2281 0 obj <> stream xڭZKW*7IUC\.OɁ#Q3L(JKRW~|C uy@hI>'4!M4$??$}d %!& ygؗj9OZ !ҟϧٔ_KV_h)w).D`]\vfr*ӾlV}{h2Oe_PN$ɚjXەvfWϜÆ*"ͳ\)۲?$ˤ~誌g0e\yKѻ5ˊwl.6kտZeF-ۃk{\wJKxvqRJZ"qz`qN*Tٙ]ZF]fLbĿ>Z9Gvre-2:<.>2O[ f0&Ի0+L-5u-yhJAt]ML1zMUG2E2e2˙ZwΊu ?6>Mi+Wm[OQmNjrq9ËWֶǎH.&*EEݏьݏI2,CD-+ B¬bХ<3Wa|p&~N nsIl5Z%Jm(#=ewt ~[bqu%+BUSUQ|=Q.uFAD2h2L;SB}GF=j?g]uazJj8  P=:,!h1/JM0 RmPtStИ4m;9ye2Ȍ)8 ~vx' ><Dc]lPlQ9Y:'1ǒ嬛!C!Ƞ$UۂŹ}0@ wT+S}GzkhrfQ,X;Kw6hշ9-j =OWV#t+-<`#rk#UYB7ʕ!!IuLL;tè9x&qf6'D511ueN9S?Gb}֬rGɨXJZ&o-14_05? 7uXYgpI ![BCQBlm9hP%(3 up]Px24ij9@y&gw?|)|gDB2=~ ^K&߿6d1܃pvPs@3:24ʈ/\9ù6_9AR{Lv>7L\qézyONڿ?ǃ{~xH>'y O^4d0 d:9?y7i/BL)\Zk5L%ܦg=3u;ϴ~E 0AU=k`"H+ 00-pݮ!!v6;:y |LWLqQB?}_C@N,v`rB }6닙1c2c4/HatD-DeF%"EMnA)bw8F~ endstream endobj 2284 0 obj <> stream xZ[۸~0@##WK&`@i_<(6=VזId=dɠf<]X,ܾglA]?.^ FINs.Y0AriV_\pe !~|[uc|_GzrO[-N:';1:e!\fT0Z%ݜv*.o^˶ñJ^G %W2&) c \(/{[$zsW%?[?ALʴ&JJWM}H-/N XJlS}Ͽد A*Z*ا? /mzF,'Rg? O:Pc~MQ@sL`W71 B]jr0apr~]cWU,2y_vo_)l#.\{$n~}PX_onTd*xBgX2"9;0('YeS:ި=W<٨11$'0ax#MDkL\[0ೢ4 %1FslRHY΅^8#ؾ7E5"bx/u d ݤ&)vUMfrXgtt^A gBI$qӁu`Peu|%>muLdqvӗm(s+ 9'l~P"X™j4.$0t۝ gʺ}oook_D3 qJUʳ'S;GB3*D 2´<\M&-fL`GJ<ww1*Qm5[BEdu4E$ۙE33|aY 4˪_'lO3ezk"Rd$ru-i'`&,i] f \eվ$samN5I`MɰyN/J^LYUz") GA$?/+4P=O' R+/;|<v6zݹV*lᩙ3pe"r(lU.._극2ԏ;y<čaƍ*#\vK;%>. 5sa\(Pp"gPwԅR?\ˆqYr"CtGuf:?s yQj90)ս1H]$G:1"-+pdNl2N/QŻN XeɟYp}m3Ӕ"wGOX3?$XyҜHDwvP9GRG*,Z' #Q //SWE6 fuσ5H3ꌋ]"y&Fp j`N;(I3;г飷1@M{uqэ5ˮ\ ;9K%PTw_{ZޖIoy {.wuSϵhۯNXDcs}]o9VϾ_PT~eȹ}[yg!^5؁mB=HwD.Zs878_xא>y÷]WG߼\͌"qg*"8;Ez% m֦AnWo{{qס/Ap?O M ^*Qqo."]po:: endstream endobj 2287 0 obj <> stream xXKo6W{D\%Rmh1zsPdHD]?ÇC'vm.EXof=F8GoU5plaa &6q]n꒔RcqF=TS>1QNp67562kئU $17JgO:Yb$"xffZe9u@Rn6Z$%2nw}%ĪH|mJm]mR!%p^ .r/ۛdQOpb\ [O Nwe.~JUחqy]TU{zAF^V%ʌ G9j+*փtLDbd0xicJepvAc$\h,ԶSU;)qӈɏ D0E<vטi5є#4=f"4`E')IQJ V:)Pw L#@ʸby/cHyϣtO-8O'Ǻw ,\nv=b40T`dfL'^!|J($"P hׄx_9մMڨUkX!r ugV`D@%({T"jE'W]5x h|Vz5(C݃k\ (.9H!xj h(x_MA`3;E'sX #!VB|"rhOuc?k+GR{Zӏ)g ZXA90ia"=(sQ'jVq]>zTU 齹a|BUJÁ$`>,lAlRW&(M+|NX>qvN6=A;bbQ?:Ç]W~q'c 󥯽T*ZDsfmsLP7MZ~S&j].&XYR=ON 핯!2;O=3 &,^$yH aU9dnpGr1DRD}AdqPXMzW6tnw&ZҶe+ݚ"d}lt)Y|ߥB #f`1uRBS&4k1:iNf!l{|? :4& 8y0"3΀36w'75l>V^[ ^HP*vJ?K0:f(=_^[^:̬GԐ3``/VWGaEzDĈTJD29_Iξ-l9fBY5nѳ\:hwYw03B endstream endobj 2290 0 obj <> stream xZ[~0P@̈w2oi[(3m2yؚam+NsHJG(v)+ѕf𗮶՟W}d+ZZQXaV_-gDko?pΓpJߊWf鐗kGR7Ph7ۺ8EU~}xK NW=^yt 2ِQ ϔol(J=(I&MKxM_SFkS^n"NGn:WOF{*MvҧYֲ&FZ)pi[d[y#fEYH8^ XJ !n&ym3Å5l`Tʛ XRջ&1o$'\S`Bi߄ n]RרL%%kct$VuWfkpd[Y/*84Xnߜ3U F0Cq7ZSDJ\ќv9/>ReriWQf7>^`yxR0+碅$Z\i8zS&`F .C ,:AQ.m{ݶSՙ S$aAR!F9{/Kޫ81@3΋^!W_.c3M#Kw ĕ!@Gv;Z ;8;T&̕^)Ru9ȌI]x˛+oZ_!EoN[|]cJ6l#&/v0S$e?azoA P'A p}2pjIn_9T߾ZR HQ+vw)[WnumCvʱ/VF#HC/dv>>>.XF^ |N2w֭Ez䩳m$sh)KRzr6*PD6f e?vF)5j`Pnc+3l;ATCUF }]؄O ^Y?avXH`ą&両R֢ z:DH1:o>P.ZZ^& i@g?#Ligh6Ort06}^o$x!o7밅\ƽOG܎]Fg4_TnX==rc`emTdy(O/_ΤDO3jڃDG9sN@9=t:Hc0~*3KUfO*T6i&~)SiAꏧHA!/uOS]h,v<↜vUr=R=~:#P=]!]~Tva㔺OB9?Ub0p[@gU1(\2a7_&HΌx2ǔ?^Ti3o͙I! ʌxv .b rpbqbsF<©DCK}M,b5b?%UT\PD?j` c4 ơ? endstream endobj 2293 0 obj <> stream xڥZo_a+%J[;]b+ve+MpHJ$bERp7V_WY}_$ΓnW,[12[laWk_GRcl7$Sq*4P/M?1$]$YI3Dzta{2"3am7Y39HE]Y ThJ?wu)3۹۲f^B)+jm:cnZ6NVq(MmW롵]I 4m 粯rKw8 PE3K: P.23zl6xl 馱S3% gqU+>X$ s;ѐ m0Ys@fIje$@m\ jГjAc- b} K/ţtը%ñ83Wܗ rϳt/UBYK.1"Xߘ |.ֲINNekK|G_͟S̉Bgv-D j^g<̴|M!}ˬ7(</lbV@4|~)yRG9=a`|6-`+AU 4r}f`X:2գA}$ *<<w~d7ӹ!:'O2Tک=S=B:}0-[tG CI!&4#ũuʹĎCY{i'D2D Z[ H}s>9jHޣ[X}|Z4Y*3ϩ"Y: yȦN:qǁqVTZG3D@L'r/|S8#P6G R@@ KPNXXB|h8L$W)s4b|۪S + 8hЗ5-gMxrk23QGǢ+TY1܅C8{aQ/xg %ԄHz# G#:wkZe%MQ׸/ ƔͬsqCz{ |5֌NL\*־U@& (ˀ( K{QbIAgt wBQ59\@ 5Yu24rOX`#@:V^&"lp=9$誤eB A` '{qVI Ka60qVMaJW`~r2Bٕ8m@v(jj*ae@^Sgeg6zK^Be63P|b/nvQ3&60wr{A s[ye_C];i$dK1%9DwF.Sn s.ԁ^L> g^vq.> -mI?Mk_4 E {/y\'K&L]U'F8M ϸf懯l1b^cW1҂W_ nA\ ~UXGt^HL&BAK*w<~'lM/R>W.g,ͮ"yۂv<ɗxJ O4>~{SyIvͨ!`}7"NF42z(!8dįy::X/˖eVp9gLd " lOWO % wjCAdoq()F쎲E V탇+adyz0K$@+ 6{7prD"N bA2n[89o<Sn6Dz9)8gefQ3a3yee/!Ӣ&Fdam13N3o:ci‘3-~m^wP^9]2pƲ-9ch r?w]U#}$[ ^~$Cl+C +Αp\ endstream endobj 2296 0 obj <> stream xX[o6~߯R`/˥hےmM16cs%Ge؏!))6!~On'ey8Fy*Y)Y><'9go&4 ^ *͘YG$"Y8]/e9!< 2xL(̚ I6'f}Uv9Սy`A' bUD z*G}/UjYR՞gz-:Ӫj䲪ZTa Ŏ xѵ*Q!(cŵu(ONL'(TԄ(4r:'R"zϾ'l@9RkqY+Yu-U b+ l[,øKG 8KX d?*= aUBTU~ `x> LUyo_(-,ty ֊9kQ(V q)vOz&k7S*)1S;qWldEΐ7n}̈́v-etFBFMUkƶB77٬ߺg~mX߶|wXxإwMp'6"6El0ሙ"9s\#gJ-͋-H8$)պUB,C JԲJEa֐y&J_uUb2I9Js!}$̸lzx/4GOFΊ< Av:#vE#,C7F!̻ icn3A9Pn˪6Е;&n.(y3 |gRȿ*yꋹS a5.g"Ƭ{Xⴧ{]i)IەKfBtQ4`>o={m8eY!"LkIF!j~W lrg twG(IL"rGeu_L NJŸGjΤ{t >PӠP)쑲٫_zy4>S+w[{;,:fVb~LxXc-\ ̜'$RW-ѧIN視O`[HvuDR&dK(m_`zmdnᕻ򖑴u44="@-ifuoanIʃ^Lh/=斅\jw1cg#A77;M{%Dܫzn8ԍs X;Eܯm{#qq+x1Mʨ%&Zɰv.#w#?#σ kX endstream endobj 2299 0 obj <> stream xZ[۸~06@#5wRS@M-vo<(6=ⱼ=}(ۃ"EXsw,~]?la8oQҔ-ֻ &H*bN++!Dr%Lݯgwܸjqdha@2a4ObWRS)LrXmv#$'2 B)/~b{0 zŪ[uUxꢌ Uh+{;XB'Q\8 8dA`C3;QX:_:P\+1q3!\f~!wmihRgQ[%²^>rX1]Q37i8Q+27[X#,_]eC72ɫ"@5Cb$'Ix&hotϕBj_4K% Y"%7oKn!"B{eXՌҬU$շI8ibyձUhbXRu[h9C%8c- `܇E^ -#7Qpqlt\ .7&VuV3omk՟ g@7R-|flV|VmhKS'(:!б8Q]TޙK,?9Z*VX7l.Ηje-{Pjm40TV }Ƥ\hB)9ِb!lˤMyi\(q?f+gh٥GFSm (-^N jVwpsDNڡ$20a^n{7}h/Ӿƍ @4ſjS'L;]729xHN9|ņ( lShr*t`m6lBOCE<{RAxI/L9>N6NvԉME͡=K cA+op~ Y1ypH^^y!ލ]b]Ig/Uyhgݤ4#J" ")4n-5PϰNG5;Tࢀ&r?r'ш}x%uy zBj >?Kh͐)pɗwj@ >3gcu|((laJ kS|"+tf]U7[ԥ 7;ʷ)Br?06qTyoF;>9vMŜ`k$fw.@<^yg_z,H4u3 $"Ŋp.q6!h+lؕHo4zpÇ2|( т]$RpJ&ުzEA0G[cЦ$riK ף޾yH@7?턆Э>oC^ƍW0i4o3aO?3 D 9<;Lჾ N0I 槢v7t$n258ܹ c ԸtR bPOh=3 ՜ǟ+1¹^/8ܤ0X@94OUkQ̨3hބ|xL; 8FH{2h)̭4>&ڪg_j3өa& !1Kvp>.Hh\_ oc,%x"4HSRzpO7{(XJΓ'a19RΑ40b|^4 endstream endobj 2302 0 obj <> stream xZێ6}W ##ީS.3A`dze<jVIΤ-^D]DTXu5Vx?q7d3g9^WX0E9SD pÊPyw߯SJiRvn7c}0cXGzlO&2/`Xk~HajK'] $Jk I77^ ےR,J*;gM,&I&i.1IDR'.*MB1Y)aA7J[31 #X3f>6FL}v!Y1eثFYv^tqb:k͹my(  +9@2;~ ﷯;A{>mtE~ktwj%0㈊>A[Us+TrgWETSUV1PF$.2S Ysx,j kM82ƒ cũmL)M-V/7VC@$a2N<L="I8z-F%r$^x6^#3q [DŽS]P7+_@fM43D>PG _KdL /J` Z` ڽ$|fזl < k/+n!<>R_p!7vgY+O]y7L%KNCDwC>Ҡ0ltl1xI?6Z%<2m!l[[v6d]"6 z0Gz, `$@ZŤ\L)6[>ceS$p$|BiHM6iRbJb Vg,KG,)6znȹ|*r)>e6r ;Kg(T.cE/%P _gIĝ.Qv۔GiXż!/y2C20EuD7GVz=m6I5"9.x$xSTq%GLۆ{wu)lAeq@#y\rH yTX|FP JxJ.7Phd`Q_I o5`8G-(ȕntwV-CP%O3OK O2L.~`;D3FǛ[B%ͮmtzA5e/~_sf'-Y PHThR#@ĄD#.TWq>en,P_Q<ѹ-nJRlc)',l)̈']q7^Y{ۅDS b|t asO! 3q*wf`Xm2 0dusdZ;նhQ9T9P]LX4#[D{?6b[F8bv㟟Se,{͡b,Fjc,C;&n p8Hf;@ 4LÈ2> (^߮~?4 endstream endobj 2305 0 obj <> stream xY[o6~߯0:`TK l{iXt,̖2I^a?~7]uv谢AE!o ,?X\-|NdqY \/ʗٷ7rˈ\8 k-_]D H_(/+\+vGx4nao%#YgE]چ~Y,+v]^b'^IzadN+0+M>E,Rb)=)y#N<5aӺҏDWxqgnZ+ٯ ː<5oMmbWTX ,7ν/\:GLa W[YMqϪ.Ru}N:ۦt}JPT34]u[}b:jLKHa^USO`6/_R^R $3eph:#JH-z?CkC[w'V,YŇM Q%RJ=tU7IXDyOJ4 AKZ:rrZ`@K4Z L#PbcBSREWSip GLռMD~l!E苪\Mu]a=i2GXٶv}KEJF !֤&5ÈǞC]V-D I.Ks>uj.}_J@ !)M|\_٤@lǷu+X zopEC'(Ē?ЊߋsyJwCgwkfv*fKy"/}S9tձ %6ʹ<bhiI.cŐ)årFߙnVwvC *P][&Y|p>%R7]}3?OlUÿTLLF I%[+egSf4U!UUs_5Tp*4Wv6.ک!'.Z]oL (X330ن@W{ӅfՕNNEilD|Ҿ߼)[k!8{5ur-đ1KLДb(C&%jbˠ]^J9t.qb9AmcW[lͳbxS{Y8rZJ7m};}2>۹ܪzSBh{!i*:P<[Һś׼+O_l %]O&`\/O0H7(~^Sv)W1ɧ)F L_Nم5i6JD|OO+05o0 A0 8b܎vFڌ]h8A$FzxR]? u5{qi?N pB$d'2|I : 'ߧn 䋊} o}"v1$7%K Ɠ8> ̽qZa_L)7f>GuLMx/=h<׌#A,c"(Ϟٓf쪍yr syVQ]0l "b`1Ldk DCCɵ>ڔݑ@`b,DNB-XNzaoz5bxz4o z(u@4Xzd)+[=P;KI|ؙxv. }Ql*{]qkR N<>qGp?3~lE(?E[{GW'7GTkE[K1[MIHUB[Η-`8}Z|d5 .e+t{δ`r1m:FTqӅfoy '|^7`޻cآ)FH{Hs?2eԏ$A >rOw.WqK>]w/s]-~/rF endstream endobj 2308 0 obj <> stream xY[~\r2Wr}rb"pz\i$Hjȏ9sHy7 Pt p49s.߹ lA-rt:,Y|/%-f`z)^ܬ&y&o<g~sLIY௯7CSX&?T;h)t0Io~JN9ˉ"Lڳzi݄ ^EFB/̮eVE:,[eߴ1 $LtR.Y%%ߜU_"%'roq{T%(!QKŒ-*fd`:՚e945`sv(p ΗQ&ggfHIBaY2Ш+l{Ɂ̣1zpSDvEDc~ŭTzLeƒ^OnxT *'f%H˝燓W80iTp$4,HfѦ<fB! -As $aݭzDO5~[o4F "_p%'Gـ&Z <Ҁ7 ?/Ao.ƒW u /?2‹ y,+ CcnEMmE^\*Wha`ŬF(VmuD^]R0dtpe*;vm:/P\[R00u)U; MaatJ⭚~x8B,cA!2HO–+mtަw&a:?WRG8EKy>`cU>Nk-C.rTdpXUV[M~LO U}]UGCMR!'QJ -&lCYuUIS_H#5'qBtVAh6 Ր Y"j[^vYe/B>)ALeD=cXbvޕ0 $|k޴4{ʋ`OA@oͨbQt"G}Hpo]c(Fi\DgCʇZtY+<$F ^k If&!$CZT1R$Rs qܔUN mܔ/Oj:>ݶC*BQMBҰ[&akB\*mOwۄ6K5u]\ ŃcGRxp{ƪuͤS(ͻ-`ZTb,#<0"jY$!!~:_"qkUDbPι(c_xhFW]Ehj.]";='l|զg$^PI /QAI4|r90?\{˘~YqE?Z?rFBrl$l|{2uL^( *J Dn } ̻h \AJj2#4 } :MjK|ʄ/͜LTk^ҽrkb 19!1qq{a'\'>E{4 9WE}Ɔ񷥹Ij֬ʡ:e&$6/m՜e!>&TasO|nf8OY0~^26h"e1b_C`m0V@2\\XȜl wF0[`pV'ܟFT6y`g##ǯeO$?lAQM7ѧoOD;YS endstream endobj 2311 0 obj <> stream xYKۺWY b骏MwEfd5cؒ#ɝ̿9$%K$@(<>G(c+?]V>RVw+fVL+n9&e{ !ooR)e~(nk%" Йr>0DA.MU0슶USކfU4|&}{(?7\'"57)7ɺB 6fNX,ؕ7%)VLOQcזm^T#>ʤߔ1;`Rn]Y]LT*6Q91ٰ;GO`Is:drTDc*9%(_mJpn^c"9#z5l7> ȮX1y c9~fØE!!ظ́WFqND]hF 퀘n姫%jWMI' izH5N1pAgc8 6]H(2#]pVUƫzoC7%Hi0< >@.԰%c4*c.E`}'=RSHˡE\ˡPDSy!SI-ɬ P]Fd B嶒f]"P83XmEjS8UiT\YT֥}OEߝs}|v]x-ݦszQ7epۮȖD%OuS({g~}eL(d Ff<6\۵=58VہYsI N't(~!,~D`"7@uk,Rid~6>)pxA4`\FIFDxFVoq< 85]{lҸCۀǵEQἥpi* PIeraۧe!DX?hCo9X9y_WWm(%f{;v;*})ׂo(/,Rr(:^Yt0qа)qT4"l ZtHx(y- ƈ-]^&τ{w6]" endstream endobj 2314 0 obj <> stream xZ]}Sa׌M%Om)E}֦wȒcf?%yIm^V"Ù3 iW+IW|X}-YEWV+LQaϵb󯇿%HJ o6[Jj]|]kurw6[ֻQ"׃ot-)RD 3;W_.ևmۅWB I v0;yËp;Q O?]tkk?%"LjGf%e Qⳇ;ns΃Tkrn{E-INT5/PG 1v{JBF7L\jqofr &>.DK2ڕ>TfpSH jd O= FS$F-EO/$͐7PֻdCY3Fc5|3C dM$# )gotKCr|)IJf`p̤ ,Zh |kk1*`K@^1Zn k7aM;`q79N9H0a ^OVvvc9Kդl&#ǠY7L *ၖv!ͯE~ygC*_mFPI`W H| "V(v5!!cۺI "DG> 4$'+6bBՃYXsdEKm6t(0})G/Gg-q[cϘRNRή ĸ"3+F6L r]^1Qu^%D3:ön oI*_hi,@<'ɸ=JacO#"WKlI|8@c+5Q˼Y.n8&w3]v` Mb4B3J}s2.2ukIgj)*f5(iP tX`a&GWt*ũvڷ>Cr,BP(joTج-9#@5}3NBZ ix,ANGnX+njKM^+b=uɝX>qIdqLd`&"0_0/CxceN>$X8b]w ߇=j#_2]1RTk|?0]!HI)'XEaZ>h%i<:>?t~6{Wfg diHa=)2V9qˋ.DD"Éb|Jf-R2ImwdA]|M+ƑŮm^>чCZ?Y8wsO ?m?jAR IO"iB Nq(7__D:Xeӵ`\F)3TG`ĹΔѓKy >pO|xH읉5?;(+:!f~ڰlSOuĎ*s QeT(ivUQ4+XIn6|vUo3"H 0 m.lL ENyl&¦0Z<=#iieb! dWc$}Pwݿ1WE+t⏀ iw?oڝpq_K9Y+ RDүPZ AKF(ɵAmWO{?~Ug)P6E2Rc/Cw_k p)i.r=[Jވg"Yg4%<ŠH%ńMyOFstz.v[~ Rڤi Hy}O4pc{ | Bl q&AIDKW'9;{.Cɭ(幢F1WQYv8*;%u~W#fWho @޲sskv ̼(yIng8F*6Lz:u{ ;&N}`PDCڧ ) endstream endobj 2317 0 obj <> stream xYKoFW!0ߤ 8 9,6oQԲHQ~V(Rnl6Usp$ b}x~D8Eya,,wb۫vPJc,og c,W;U/T7׈a@Y!4o&,M)(̬cחW(\ !EE &)i%ú٤\( MY(j-hVjoB$ANA.8G99FdKS6( I$'xPOQi>qql̦ox3[v"!CQʮt$Rm@dK4Ap FH$L[&I((a(q!蛠HnFBmV'RV^-o.zKK~lJll=U۪X%<~)uZ2 CsD!,:/e Uc!6ғ&J2D ^wZށ̵_Izu˶ G1Q{lJ}҉BU!>#9M40w 푱iiӲ%rdN)18, !hܐWVuЉDFž\d| ϑ?>ڧ^0{7(4E1"x H * e7)"!qcVjQ K'$'0qHRN^,,?!bL.9e[d1_[M{shvuV3z.Ҝk.rZsj6DAb0([|!(/+ _} _ D96y: RBM5բQ>BO̍CyLpL[h jU{O* :EmL/<;bvC*BݩY6xS~* ?[@f~]Ow&SuXd w튽{op e/'jݽ`/w?Y:u7]˦^ ZL` %|a\]AK>6N szsy24zTXw$Uh3~ˣ*~tM)HhGz "R[N&{E]T`lI¹I pv}j :['i.:uR7Pk*XmxVXhRƯRo'0o>N<laDq+)F;r!QMd(NsS+$#C '~\pJӣӮ$LLA!3d{^J WPI⚑Da d^~a.VGmQY܃~q هZ]CVm 7D02^U691ȑȇi~;ƀsdNڭmij9J]=u}[})iaƃf,^鸙v-;$~_< d/מ242'^E}[7uڋ/E ] źEXꝙč,w]wv"7vG>s5Uh/%MdhYTeӾ_֥ wV>_'ZeZ3m6nQ6Dܻ峇bȜCB*=Vaw.C endstream endobj 2320 0 obj <> stream xڭY[o:~_a$V."VK=X,YtqPlRAD-4;CRRM\h"73_2[ngW7lF%ݮg4QN2nW#gDkoO71<ʫӿ]E{j@Sbs8O-C$z|(F[;?4 c* @<%Z_PPD83Gceә KD#9b2!_^-d ;@z:T|eyqڟU9ð\n"hf=݃}eSϨ9:{I#;TX b]7!J)ؽ< zZ MnFC2GxJs${6$)t.SO3>b2bxAS7zx}^ݱOk7kg'X LX`>@Y8'\d90tŲT%*#ZzEjqZ^6oI"y[[W_xup̈́xNa GО#K5IL֤M9eR*S%s0ci dR@^5Țs8KSGdth$ zRdPb mo`xN v8@/ހ45d麽`UtE-·f 1O?IyTI~r]M/@(掷F/d,'X`D?Lqz1{0#ԺWto7+7ʄ!; WW7žS\(p . Ƹ0/K+ odB)q}e|t"_XU8p$J G0Vld Ҿr!9BXE6=.e=!]O8*Sz?_#WɍM :37/]}_VUx>RFkpng_Y 5q&4]Iq[nfOBVDf25j{y)j쨰5g#f/|x<t1 0$ Iej^Y/L)"}j(AJpw4!$"fQSY#nyl4cv'=>UǠ,̑Z9&9bM]bHhKd1[ ID-O>I~mUyJ&T$9*,ڜX6!T+ A$M7ѐDk@](DB6& NCS|9?K: <$mB߉(dC.l42 bhC;aLTv"t8Ynk6ds6<6VgCfC5^Сš艧y.tZ9%nO Ā/Te@bS/MrқNoDJ tZ rF}tB ssNV_.AR?Kʱ=/# endstream endobj 2323 0 obj <> stream xZIW@}9e`rJB.sPTU¸,$wW57K*vMtMQ-[QV]W[}%:{X1b8iWw?Tlkflտî7?}%"Z0ޏ?0¼86JG,~,3D6[kXȨO?lXi?ĘJZ?O4 Sa uu`9e}Qt{ϡc5o'ՐSETq?f]H`yK'q "\}ڔfb(Xr{- JP gpOa#zQFr]AITrQ΁H*S}R\81Kq|L(dIƖiF ҸHԔՠS|hيPʦ;UnNG<ٌKee{7JN儉4C5EPXUܭ Jih"2U/n]qhЍfT eW݂a&rCXo(-Ղ043o{?*nCHB,H,9n4פFo & K YyF@lko *%S:=ԇ+3#yhEFnrvDK<dM!ocw6iW5,LVRR>‚3bKj^5q\[⌙k(#CwB(7F.Pk3<"Gxt#㼉nv1`hW_x@ VssgzT5SXpb&7#ڸ('B߄|:"n@84 BO{p[-8\IЌ!3|Ư^C(0_ u^  Ե@<ӺAפ?:{`39wm~Gƥ%7j6~6X=Pˈ#5s&+%ŔW֍xU)Ň<]W 67>aEA/*Ͱngky\3V# ABV$.8+SJ"$ X*qCx*tD̯cR؅Sv@5OP3E->jx 1 `BIV&|o 5_ѹ@NY]/qW5svb4#Қw.UsAEZGr%npC_9jIπ*f&pR3UW)3~}.杓vn\7 ܥknh_ LW/&Vh %Fyiu>,<7n<7 |5% Xhy+ҐpaC?a(vѺM: )}ì/4/εk-2gvN)FVPǸ K4<>&Xߵz\8wQ[9*z|S\I59>m9WZIMȳ] Tlt6X9J;̹ݦ#^M" &66"[!߮-rjlϧ8dU.;'Tp&LaSM($ubP= ~vDo)0~OUW<6{H:W+8 _皝C: JҰX!hA>|fj*lX*Ŕ=G Gh[OYζ"` , Nwq$ѠGӤ6dž,,ƛn?ϗ>f|~w'U Q3tmxpK1Λ!j\MO7v}m+MY%FxdILTA<|;ґ,/, s y8 TBJ[eoܿJ [fT%bSBbWF,2&DPP=9FymKPdMCCB',i#?4-S$7^Gw2]!x7#fX0ix w(h\)1rCa.׋tE0-_/Av Ƃ endstream endobj 2326 0 obj <> stream xYmo6_!*WQ%ْbCbmG,9~/%n6hQx{ݑn`GI?2xxNQS\^$ C)O٫PJa $̺t֪EQuCtS@wՍm.f>bxdNsK?뺄}$;-T5WV잮=<<t$ e1L >k> dDG$@_Nr־>}yE<*z}t'P2[aӛI_=:- :Bjqoc3mA7x`k`>*wtRr}WIt7j9iV ąFw ~܅˳6qٓq[G"xHԃ҅v^v ӬoUXdmO#7z+GmdZ6YiEr2W>"6!œf0n6:E/0lG $To&a ;N,7 % HȊ2/C^"!7&/BZ Q:qMhlzp/롙]g&PL )j/;UQ.{afLX(G "C{uꘚ]OMTq{^Tα3.M+;R]ExPDRBUHkP_%!edB߳FAg86 8A17KkoM/2 Ii4įopX [p 0xιb+Zcn&N~6t/ +ٺ ɺ }/ ]؀**4ݠr`!PAs0w^Ӂw6? ߧ B_ ]_~7,0L_k186I57?5A!3[:J@W0ӛ{$lN /k/^~8 ̇*wC"0auI❞^5^Z\rrxj8Hn*ϔqY%&Jw KHvP׮Dʐ(ͯ~ ,Y61^փ.ͮ/.J5.qo*Yhg ?F2887yI _]|AnW endstream endobj 2329 0 obj <> stream xZKW!j-N $Ɂ+Q3%r,R^~1ZH`lVW*n~MF3_l76 eQqC͆rR ?cS<ԗ|KbcnunDq rJv'EI vr';_"8QmHQP_U4d`f[X^HvM%'NexJmR*մ:x,rA(xJ|LbSw)`K qS$Lo]Y]lGs!Y j|T*Ianm{PnM\;[A| 51-Ou4(RKQft.C! 6D H.31cds |Z`Ô砎F0cn7iA+.ߢldxxΎf=Ou0>IЃdjFt26 $ a Ͷ'RQMfH»s ov ft @3F^:4381էD0wu^;hYUPV-/ j7P /4e1Z~\ c(ByG/ TCpt1*V}{C\&s٘uXF},u?|qocX:7zE10a#">T+H,AƟC'_$N.3++on5^XLSKyi3q7zۧX -= DxC,/{"O6N 8fz*hvOdS+YD"!EFP]b^xc_i=ݭy`Y+o/T!۷m>3{j\3Q$vI Q!'vi.҆>;}V /'<T87dZ#E#IT\70ӓ,g[lhkP8#G kLco5U{:(*p~+dvuP}bHR+:Fԝ?V`kd|-aVl6 ׋Y9 ˡ$ R 1 57&rPg͛ |/ kt_P_g(.m)QL[ & 8@W*V" T1έaI'mj &,ǮfScu( ٫lw~CxW]_c?HH&ah闟 :%&X3t :Q?6;{N5f!Ej"c'szrt^B,$ܦ1\:uv_q&t\* ÖL)>Us<mmPX-ۿn<}UxlSܟ=m9<|STbI7i&qn"\jbLfC+1@]λ7:ʞ|dnS2 (nb} ?jvxe!^@}$[P z`'7onT>ߚT7ɲ._r--p&H-B)'R nK>ijd$]`UxKKViğZ?%%:N\cT U;ȷ{w13nnk__d PoJai]W]vz iUpU yw&@;=H)Y/bucۺMf2ŮhLe_enjufp1Sg2ᨏE03d6DWI.~|wHO߼lzbah;y8&Lgwչն; 7)B!&C+ϘD{^ʷe>5 =.{&I$C}3R[y﷎[*nT>#W kH=%O]@mB*9Innҹ 5CvXO~vc!0lE] cO+^94ѐlຯg]jO.t Z[\[ 1rdմ >۩icw:H~J6=I&ckU/Vmˢ~@=U珇~6m?x|'v;bW6ux o6t%l Te1NB~oǡ endstream endobj 2332 0 obj <> stream xYMo8Cdb)J9,fE۸ǦHr;)۲)v Hgޛ̐ `#<>\Ӏ`I@0$R_eIk3zS/bvv.|"^DpEʰfpM0 訖%Wγ*'lS[Ƒ2D1c0WsK"AyM#³AHlƍ ۤޠl0$DUgZC JA|D׬8^[˩>H)t"8m(G Lb? !*H/{sOo[拢tC\#e֘y,['vk0Cwy,{Rی,/2ohcWۂV~65hi'en{j E*8F\н ?[]^[Y_W_}߬$mzi 1*ԃ}_Z5|?)V} dʙem. 0Y`sٖ %DN gQ`L)S͆h ;y٫H^aF)g $ \1Z>fE#Ŋ[țШJٟB5*@JUQ0# O|64Ԥ+XIÒLe3:(.f^`h>=P hį? endstream endobj 2335 0 obj <> stream xZKWcny i$=hl--{%y:o!rSn{ ДLVUů*{,0# E?^?-D# YSD43n)H|>v(iSg`7ȯYBW#.Iڦ=9}s .D{;Uv>ٌ$HJ9ݔ$R(aqNg%U՗%M CMl~#- $,޽Vn?= DLؘx:u[=G۟!kI4QGrFJa0%OI5iRJ"CòxN؟j"F GqF_Ǹ+3 n:?KF;aU?g(Jow>q}º`LCqD[TRƀ|*oK;gHrzΟmkz[%gW붤KI'.!nkp{.'61f}_4@5ѷDEV^aؾynؕ$ @61&DNS#`N1+A.KMǒp׆t?i2ndCܵ(C*~)9c 8&TኬLD2 o$#s-ܵ׺|#q-CZ'=۷p8HΝ=-REv.8t0'! />ws7pH`^Nng|<}vWM K@:asIE"]gfaO+Z%1klt).Y\9Iv0Gr(PSVI` $ B;x_f_t$RĽ ϭK &tJSe@[ށ,slcڮ#k NikհX}ƪPa-r4x-ҫd؝\+[J0?~5'gB< *:רeV'(ǛL݄k5ȀMDZ 0 Xy;z\ЦYSFؙx/z=3P>R2x c7wo&B0IrB+p`e/`)͡hz==,G]/Qƀq Y5tz2r<7ߒ9 ua|hwcl;V_;LpaE(% 7T7/ӻTRYQVZ{V +Ѝ*ib0T; +{}>E'.PRHʞbkMG[t =pLSJޔs&#B;+8H]}4ʺ^r[@& 4Slߺfv]r6$&Yrbhúawhi35e~!n8 0PG͘GiumƟ\VvobS.O R ;w i3uoL&&髭q!*.m2nƤFI(I:ƽF2*/#:$}*9!`" pFLI8}@'H%~^Qx~cs>|9R2y cF&Dd0uӆ1"N0,Ι`T`ԵH3i)؇C|_պR;05.>GEE$/}u|E7kJԼ:PPn N#p]Rܙ֏*k7H YsM$Ez[qRF[,I8{KX}%1n 5Ny^p{ RI/rwh%_N,AʥkL6}h=CI,_%瘇f.qI,Fd-hHbthi^`jati 8bC{c[~FHR2Qs. 0aC(G}ùO7p$ M),P՚ɳK8S=6P5eulólL/_ EK!~pApQ :(4ɯy/aEǾiEA ;:㗲;!6;!GR[[XJ?=-_k endstream endobj 2338 0 obj <> stream xڽWYoF~ RpýxMKtyuQïWYe{ZPz^.qb|NxI2tkN! t]] [̷]WN4U/Ʉ.:ϗ7g;.ǟǷQ娻6̏f0꽉z) ,8;F:Ku[/V֝%HPnm ', D$/趉ɐ#|k;BT7ēdb:@&yAZgx).\S D|A%}[@x{Nx6H ΃0,MȮQemD e,g/O: r/0ITL>]~5'.1a,$n:8֎'ld~MYFeE#y!Gj|T||@J "CB7VRUoMŅp\$.`TccgI3ҺfbOq͑eEmgD@?:HBy& z/xٷD1nNxJ~2!Ms-h ^ U = ݷt`Nb\B#kԾkU5gp@z$1+?bkҲiɹN6҂=;yvo63LnnUUUY,Snfq2J<7f71[fA\fMrPˌUa 71Cq5B,`;Dނ]O.EZZ_@/"aD2r7Mng1&JNq=3? &]uD}E%O2+?xml_h˖|LÇ#xE> stream xڝYm۸_!NbNEMi[]5l;CR\EL3yLjF fDy~|"4IitDqQNRa߱r󟛿JQMWnvVPaRJwYr-Mn_vg"pI"XDRcnBW㣈OqxO)"Mmg~:/60 A`ŝloS IԍUhkғS24pT6Pn$ DCVuB$~cO6Ȏ};o U<8~z*_ o `i|0?U{|e4r.`p.TRKa>OW N`2(Z-T40sjg$_jQ?H"sFR=h'Cឬ96"&D)Ќ|OBSux<:9:\N~'F#< X bIkjKSF¸^>EHLBH`zD:?A@u<._UFT00CR̬' l:ɇt$oKH{CҐFS3-v5ap3"e?yU^b4S7~.4ϐ%i0e6Q@LåUj^)2Lt|r 5Jk`V(ar5@I|/# *!B:LF f Xte["&5gSz8㗬@O"H[֫VevX!ُ3[ h*!xvcXl XX~|@7YEM>3v&WS׸n<=5O)d>|?. 2ڜq/7^x8N~,qC$WRXonHOМ@M!ՓW{~>4!ʏ-`vh yG8 ˻y:@"M-nG VDwWB\3Tno~7/6>&-HRߧ~d,F,BOPС.B]X.T2z*>"3.twپ[̦j 4l@`X(94k }w65n 0`aꪹ2 54(H@;ר }2/PYŐӱ2eBZ ƆExj %C}T~U ?>;V~|cս{8dWM!z^`m܋/k;{<$uWZ7PxRno(kzQ`lCzck}0_5s@sw Sa:j`ucT@uc*.lpu-`ʕ\MN`\Kbki2'LM1ˢV$_/}8kN;[g|pzNë &/ti)dU}#NZ#CsC`LibmO4cߟPЯ ) Aǁ|ߎ$ U[R*Bny`4^ VANM(n_ǍNdP<PMpҿp3`X{*a;?͢v.=kxwr"Ne;rtO -XTO\g1 42KJْ.MÝa`-0B`e<'X[>*`Cs-D~'g,X1^ udh?WR endstream endobj 2344 0 obj <> stream xYr6}߯RU|t:[.+ySj#;"e#E xAiT\) 4OwѧHF (UD*ȓ\FHf"7Yt9NSw"HS oc˷=hqo7uScU 9ۨ,LqOnLEhcrIÓ4kP+NH$$cyfebZ FQ@ ĿV]uq_2fvՇDrO+ne7,j~5qq(mep=We[7~v\ޮpF$,ƗB 1Y 07-(ZRΞ:φxj \ς FY2am&qYpFDЊ>T^諆*s4CcFԗeː,^e{Hù$fp,,`GfY ,I:>E¸<<*&Sޮ]{9Dw!~H 2P%N]=?/teg d:_P;^cgdA HGN&ly`V$*;)HØg``E&7/jg6upXwvT= Z\[NPxgQ.|Ш4"DIPݘf o Dd! ÝdzVw"," (Kddhn%)$$Ե i*5rq8 }6,-PD [`YoԵ7$69DN=̉<=[aס`HrYT^:S: Ɍ0xf,0Pn41 [ gh&JlFgáAXjV<]"QF`ݎGfTg}Tixq9v&A!l-T.~mOQ\jp* Z) CoB+ʕ nV^e л`>ƛ&D|fYfx.>͵7Ec@G+s>ݕ8K]ۮbW,^j 2[WVRLىJ1y^SFHimVհ hNzbX& B) I^ `jLfD&[6*eRO5<P},dc%ڒ*V(R=;~"$PK넱fATջ(5,mVOf7FREU tVaPcYzA~4im= 2↲kij6'ľBbN՜@K'Al@<#G hYg:+xOAalCڙqCp-4dxК9l՗/Lx| 4 ;|b2:<1_++6j:c4*82lx({^N|jV.R2'RNS|ǺA nնO0!.V(BĞ Z]:XToŦ+Y .n*X(t5.BsP]MS<ܑͣ{6>h:uP1:H$C =>eh$ Œ?`dT¬ ]/ _S2 3qYԗ7Mj [ 2n.rq?6)d7hٜ/Ѹ0͈PæJ, Cm9m 1|,/b2V3b)FfM]( 3וGOgF6-x} +3ʸdu0ӭM[Lΰ0[ӕ3*^g}voX[o箢0Se J>?}'z-YcO\K +'v-AY=F-BUB )ʔ}r"RZSp.= U² 2 Z<~h)@ձnwQ019tH,XnczaCD%+A]Uz 0^x-v g ư كecVqZy?+7eFdy&~֙0"~ ^1l@ʛDߪ@̓@xݵ,&J1|zV endstream endobj 2347 0 obj <> stream xڽXKs8Pa0ċsfd*9$l1# Ie P9}]E ~|5VW|_ޯrXyWw+nW\Ru!{)eF)X [Rʬݹao+5+Mcc G9l;l⪍*ʯq&Yot!_ۡ;xiorjlMtw|ZÀU{;niwFƎwAՆOz{:a9:Y*4?,#rHe8&udE=_;eƔ>EɄKh".[v'C:ϺKs?ڻp6R1Y/M[㜃 "kNb 8"  -e-l8f}E.\I0ڲi4aڥ).K3zVx01!&%*#PY|: #rjkY!b߬Ivg m׻\ >\zLysGgy !^zw_RL-e Wˈ83 dK%`o/a;PޮeD4@P*SLi6T!k3FRgR9X> dѶg{_r2[u  _9\L/0iAw7Ҽ7 ;/q[2k.䇐!c|o{|ׇs(^ "5j(]CKIJ+?}?+B-vr*I"E~#"6`Rc@RnD i..D8*x];WKfwQ`3 7t&x3S=PG0w8ns{\}!y:&pEvFzG @W4} P6x ʧaX.\k@348U"S,H4&N'NBqKs4bY(Xγi!㚦]T{\pM<5wCO 7Zf`1iQEvG/0G;^\W`<&i"⢭?: 1 3#h8bK]|"ps:7@Ƈ1@b,Oz~~rit,gz@n`)/@9a 2O2aC!sp2i;VutN}tYȨ=gFME)Ȧi "d(zHwͅby8qPB:ӘsGp?i%]ӊ\^l؛QTҊ3ɥ~BfSm)9σ筻=!;4:䍯Rԣb.a44F!%njeCѢR{e9c$ ~x0nO?^|8-  ]joxqaiO]%ϊ""˜sЖ 2=&(Mܪ|*,S*vfS:d G+lChG> stream xZmo_qH?TktJ$. ~ X3ɋ?3;|.O!-3Y}ZU /^mշ7?Yg|usKtuژo7^ )1Ʒo޽7?⻦j*zsJuo>a1GGHe,jw#}ČrU,NE#īHi)E珝KlI_yݟEWo%-z {M]-E}7}ԝ۩;Ub9.>Y`Q䁊KK=p_'F}dkpWÔH<@ӟ)sQZ 3[Ѥ[2|[&GvҎkB\J,(ajueTwzd MQE C 9͘|+1R/ _6xhrgLYt*PKg:uՇǡ/rC lGJN1b{:veJVG^a[4 kwE7!09bq8iH|r;0k34h9Xq.3:O}(/ 19/6b2iZ@^*Q$yydWO[*84/G噑0n܅BWB%n2E4({B+ao_#_}M9nC%wVre :oLIV[);ǯj+Z:oL~Q%& C!>D9?7^vs6MG 4E(O}g6WqG4Z+CNfiXr(@^84[U㛔VVoqgM T{ff|> stream xX]o6}߯@R7 HPj%΃б:[N%]]"*Tl,Qs}H?-yFH4_E$COE:mt5Kc1I_y:糔F׳'IyX^}\I*J k?h 6ŋ99D(xdw椞]Njy88z۾S2)$dh~/ ,9;.kW=nщ|I@"g`qbŎLUtf "q-[qy~$i$Al!i1sCA$ڽvx'VX Li#E%SvβrW&ɛ~|zҡ>/NP5 tağ7ؾQ$TBڜqi33Th{vES>*!wØ5b(VǝpJ7av3*0J{K]up0!,]J KesXP{lye1`BP=A_ ʶo&j֪9~Z:2Oj^2i:8#hx+a揜JIJ 0qr~PM1fQd /pi6Bi\9ϋb;@ǓUjZ0JJH5g %#wi㧤ւ5ЖK\J:E]X1Nlk1էFOdfN7o;PAJ?*Ȃw=it,_ݻeS@ %&|hCȴ4T*++:K'_:MW_/?sYp>?c폺 endstream endobj 2356 0 obj <> stream xڵXݏD篈m -U^>±q?mzDu^{~3bO, |-\<-gbqyB(tqy%)_~e!dIk\}ezC7?n~hv{-=,cFî2zGk8F%Kv5}ѽxDX$*6^n MtTULtUޗMm}K6a^㻼պib?ç4ʫ~niϾ᫵q"$cҤnۼ}~Uc0mZ7f*+θ0\ّqmsDi2+]]_ ՔfFHgFe#J r$(6/.SVKIЊK vZEU@x-ޘ6^xoShi'OrLEª0zJS%%`YtPIMWĈL}d]Gi_|wyYO %:@hS+/$CyS71O(5}=QyT  h2. )̀VN3-CW)e"BsJ3+31%IĂI/"x.I1 KƱCp%'ѾA@{ڜcPay&>FN@9,D-"4l [=OP"?ZRMF\: G'PL "BGu_,]p]5y?<Ƈ7_O2v-d%vHJeLejH?ݺ-;ߊq"Ρ[NZPbKT\=aK+;'QUv26%w\Bfί`  5 B .*hgxCAtMAKˑBπD0 \'YɌ4we%]k-Mq5z*y׊#lJ\:n}` &Kf|&PwnuE7eꙛ ^Y r.8Ƃ9RHWE4_~śo_WQiUB=I%T}-kvY\ɒaďZPS;mPZMA[ac|~n{n3:䃂gsf(v(5xwn (4l \$)S!XFN(,3ـmcCQCnAPpסwE;!ə2@W؊KpK,"6tR/JXrMܴt72/f 2 oFK ?zE5輮}'O%&zCDw޺m.νɰx"+֝T )H_Ǒ{\{EcO:ְѤf`:-2;鴮 ݶN0djOv󮬼C<<},p&75v:BjfÝPS'Tc 7 #~*=> stream xWnF+tCx1Nk#(I-tcyJHT&j;Ҥ44NQ p`Ǔ{}9E$C"EѫytqC#ƚD󇈤aH4l,a$%ufYM?G$'?݋blbpa<$kn^5c^l+g,DL.o//A1(Ȭ%N i&<9 P)s"pQZB0F Xh i^ڢެB.Bؙ2M%&~"q}: b/&Xbkh1 4 @S}=t/ʸpKݕΌ}{ص~3qd]{|rKD% >f4 5tqknVuh4We5/j:OZ'aگO+:gYC-xWq]jHGfmmi?fqqc &Dۼ{ηv-K`$ H,fIk m )D: =P)QWի77ŀ IaP~p`IJ&[\S,?TgJ2$!q[2hvhϡۢޙHL+YuVg4u.c m> 3U8/i?e>kLABR뢫·̴Id*Lm)jCAU| U`rHE,%9.@pHfl\\;}.-4D"s^(TbHMI= R1nbP[x E Q1+ܞw7Fc瘟'u .Q P!+Oy[OS\RKct4i: "VJ^[1/tD_ȫL>8,~$G7E3bE?T#>|_E̲޹i0*u\1ۗ-- kB$4R>F:_Y{D푼<c ,se'e!?0=]vZZ#4<_ϣ*\ endstream endobj 2362 0 obj <> stream xY[6~0R`W"WQ.IEiɃƦmmlˑNgCR% qH2uxsfqFf7`"Ռ3f.92dyz}KXpxjwid " bw`#YD\N@˲hڊ+$՝55ym=r T6~N/s%bbbεX~L\M3Yk잠Zp0署s)GxS+bnHP?LW% ?A-C^I4Щ @ѧ߻C23Dzw~3Zn 8ˁvl?Z0yP22f 8(d%6dH)$A;bObBi0Mtױg fp ;()fb?ܺ21/K ao3%vŶg2c| LKX]a[rv_. l7Cge|`a[9;7 ^wș旳4,i\vh6U>Pq# 8VO@ D6))'K5UW#ɲ˷u+U 80_7d#ĄP\]:(yUջs.-̈́#tLa[,hڐ|͸.uct0fߔC9 7a[zSb6ᔮX,ziR9+?w~6ի6m.Xǭn#K]Oы~338r V:ac\úĊl7zu KwŇdvDa`6Ad _]\};o-8WWasz{1)Ľi+d߾~o9[Ʋ qa F9%&d=hX FF-bY>oYSqVAYеѕv0d[v˛ُ_ :aa endstream endobj 2365 0 obj <> stream xX[o6~߯A*R0 REa LX-9$iCQRv6݆DޅG< ē7]yO#E8"x"lKƘOԓQ9ba?)gK]ޏ_z2 FRzsַ0E!^#E'.ZAOE<5J!RQ&?A'z}Q<1˼NI""ar~?˫l}O3'}+TՂy,vܺ>D|I;!()!p)jb`{_ƹ}U)PAoCLpA; J$׿ޞ7 ζa<ˬw7n2p0݃&Y > L#8`;C*晍d]8آ%;-&e`h $7`WpÓ?kᣱwq)¼+GQ„3#zC-S]DvEI&AUjSG$#;?I~Zlc (HL`u/M)(>,[&Eٲu? Mwvl.*| V qݽ Ю|mAm3m鋪`[gۊFv]2RX0%OfOrpYdO|0s&kؘȠB-TLO0ᩞqF6q)Zλ\ {?]:>.R!*YwkyqK7whI`nAY]gFg-CD}źPkgފb ?) .AU^g@5Iz^%fE0"B7X6ܾmtDADjyj6"݉"_ictiFghu2FAS\8HmǑAA +{ - J9bJ D``MU磈e]0DX#YIV6ҿirvNu x|< jD?zY\4vcye/ hq: IcvL Iαas[NP0ؚ g3 /fbX"t9vz[ݦ." ~,BF_36aKE@bd{hb2E> stream xڽXo6~_!`oQ0 ]ӵC$-BmɑN$eɓC-w}w<2X@ bi/W<`$4a|00Ai*$Ưg"!DK;O;n2E܄6+f<VW 77n]"d3f<ܦuZAg«WDbeq/4XL& $nT.*qIԤ-$ʀpa9)9 N70h@B,] `aSҁ}V?>/+9tLnz]6e5Ix(AdT"1Ǩ(Wy0VcꗤL0-%?9lh}}S/ӥȄBqSdPI1ԄXB5"i%ܡq'"r1uxDn$’Z_fw|6o4Y6A"!Ȁ_谩r++¼A`X%=]U+^ [^Y-xէ-II+H'd$̧kXҎ^=&ȔB;1_(h>Oe Yo)Ev\'icGHXF )Mzs>q.ʢY@2 <ڐz2|۽>ُid]cg~ܦK)ݚH(Red9tgxWU-[B'q%&<9HE¨;Q O!yFY DjOhs t Y[A%H3"*e> h_[`)):$!ۺΚ({)@߱N.k&px_hA[]fO Qj{Ҫ:۬ζCO`U9nܧ[GyqgW@mϖClDppbӧwALV)5 6_费wdi9>w16mм hy<8:@r.I C,:dC*c5jخvvvՊ}wًs 7}8C_|(tJÃ:\MjZ.e,qƞO'wkκ-A}u%oЕb)as 4gPӨDܾXfx)3O>j^~rwwc@/y7ԦuOT_HT&/B3VK@͞2K|Rk})gL "#[{$U=#)(cCdpMnD]ͱRl?`ZgU]Mtx&&8'Ò(p>~/MI endstream endobj 2371 0 obj <> stream xڽYKW C8fI( 'FAwg!i=]|2Zhf?z}Uջ{ ѝfv|v4#EViGcsyLO9 S!D}ٟH9OʧT5b\ov 'aV* SҜ0B>%᜞t{@(2k[%lR {s6r-L"hʋ4R'm"JOQ)9"8ΕDH'^P]UH>om*ƶ(k6a0]W81Ŏ0.JHP[::1ӏEHkH 2|2A,̷x1͞dlH?vz<l}_eU"~IA6eܪ*RDFޖBz 5?a"oK19&'x[ 4KN]{WG+zMOW#x淘򞆲hVєrH@R5 tORp@YmSy 0Apt68k#bQz8B#pv>$B%ceRG>I)_@?*P#!1o>B!ɟMc0տ\N=b^xR;QЍR5lްv^c@3D8lN3<𝣗Ը1_=F")§;rk(V6|hPzlӜB pp\'lL}Љ/90|9S$LeL+Z` ;TTIx!R6KI=dU^q;/Km2LS{{ AWU xXm4+( 9TpVJ~F׸V!a\Nvaݢ&kLWNFe|l q*AcLB1 Pơǎ_@GͧG_rgLP˂r?s A)?s$& +Ŋ18vݢzK\t~Ē>Z0jhӵsw>~^^syӭ5LWJx[.RSYZ;*N2zA2kC|4F$XZҘ~ϋpVMdTgD vl]H &y" C:0иѶA ( TPyH.]hGibX!8!+lM,C <TSV]䷘ҩ0T=TƇhCċEoh73xrn~\ܰ5PŢCyr2,vQrr=UalvVu SdwoV Asch+P6]y줳dgḎ˶&S-y6>OFؽo6m戶q{(h ȥ:UU$UF9 cr4P B!pMMRK m rn ~:m{]G(x3PW%~Qo֧: Xن>{-ɏ_G\>0>{ -o3妑Iw e%v[-m&PwN_kHK c,}mycb 3!yslwt霨*<-_6Z v *: 󿊫̟ooer endstream endobj 2374 0 obj <> stream xڽXYo6~h/Q2Nk')}AzXK\'E,lzC}3xwB z{N/C [(aܼE-/%H WR ^ ~*WY7?VPrAZt|u|,A1f]+hvk%E%Iba+i8\Gh]2ٝ1sp_<̓6ϔwi Tz`&'.XzwCI!Fa/HB'+޵j8ePG8˺'/::[^زʧ֒uUײWd<ƈq6qWgA l p",wR[y!1+o AHKs$]uUY6zgz&Xr-}ϴϊ}.;ɍfA"u1aE|.h`I#dJG "P*bl' "^ Ci Qa~zzJ ,)lEjP>lU;\eBM!Z>'f dZCmQfyp6%fԇs&?ĺ.CHduI _g̅ @eH@e#\k:뙴nXo٢AWYPܖ^lԫeZI +Yyo\VɈك7aNNax)|,ڮg):Vt 0Såf 9X4o~NnQ'}f i^¾@NR" RM.@ hi=u21qG(cͺڲpLx+0d ~[4lc<&G2PWql"j*3-'Z'c#Ĭ03a > stream xڽYߏ۸~_aH'}ȥ׻E}IAk]-i#ɛ5?3$EK^m`-p8ˊrGV|W߭HW$t~EԊLs}J>t1nrΓ?xrV,)7ӯqʼn &aTҎ~qVusw4kFْ'ecaybrJJj7 vsgۣ*&&Y^?q29S(2 Pra'~ggbȴbASwMۤy(iMebb+*Q>sNssc+0RQ)3 RN]8Tmǎl./2N_3ñkzK}pmNa`(zv3"zppB$+$GԿD'u46hTx {:s0*EՏq00BUx0 COwf G( e뷸,M673S"vlwC>Jk{M?t [zx*Mu[&˱TRvQhl{Sa,y[@mW$Vkle-\,Ϧ7!-\Yd'9fc!) PbTЂ[9웲A_8yXr"䁷Hoh.evԦxpJ[Vr[)p1i_աKAfŅ%ؒ%2-|_Ae5."]ړ~^A/v J6sR$=8!>I0-.;RS78Vָ>B~_:M_N BT>n 2m>7:(;bԕR`<)JV )2=FY.cPSOypEz_ZHoKYۡz(b6M 2` w!샑@1K$vͯV)tV~K`@>l+hY[Zx&"gK"E"yl69LhKIFC̾5fC_2U1 KSŽVH/)B4a; ޭG7jLZcNZ?<>ŁYS7M-w7:;Y$Tcf\UFm 윇iCw4IP,53ߔovaR+pC}8Qn?Wi 4mQqi0skk8DM%U3MŇ:zoJ(PE"/;߳Ed"2xo+ڭCPɓO!J28_YTWW40 <ӳiI_s6Ǟ|][8͋ƘbN. Gn')ƐaEcVM- DU/.7j9ø٢m*r-fcрd l+B!"œVȉ8G >F>!%61cg3CC_0U#-[>\Nm'<̶cj25NPkW&<:7t6_j&6e>: b5ΌjfkbK:ٝmaҕ P=⬄3-l}xs)!`7.޽+Ow$Le,Ud܋ܕ@2ۭ?!RUgTzbz~9+UʲI&!Q+_Zphw] A!J5RJ=BKZnu>+ 9TW,PF/hprQa iQb4xWW;k7\,;1_z\O39N0s^jqO lC)tXwvqwNJ\JL%vokeUb%. mP\נ1#mqZV *lϒ%y Y#Y}po  endstream endobj 2380 0 obj <> stream xڍUn0+t+TJ:vKѢP=5=2)Dے;P^P(l97d$K d3zJ zu-/Hh3cL/2eGzmB65dIknS_҂h)H@ L0wfi2f\PIM~0bh|a 81.Fb F<,Ñ%zĊ ևh>%-v9蒜2΂2EEu#͔"ơ᫸+b/J}Cp v ycIǘLT!۩}%2gtӟX)*jRB {39 >:uDh)ʟ~$aQIHhZ3޹US,ڨY(+BGT/Z|=F;179G_/ w.ǺyM"CTjv8ܣz)М <;RjEm)EUn2=!ptcZ7Ggpϡ^u]4:G@2!,il= J'wOq߄6TԆ&ubzpF]mSߎ3Gs?sk?=;;CP6^~>uT\P]-\J j> endstream endobj 2383 0 obj <> stream xڽZMsWHWYES6[Ij+Ժ*8m3+ IF)C&L F \mVAx\qdV\2asaГak=׊ku\ݭu%]f<}T/KY`˝,fxi׻4ߍF1 f*ݝ0׶ێƧ|@. 3db|fBk&MN/wZomDSfFs[ [3ݶ]9O3 ޅo~9Sڍeͭ (hU{TDа#mm3HJY{O1i8n08'Q޴vjah_F`O~w~e{lv1c<6D -n]=aܞZǤ^livdZ~H^5MGmpH&Hc}7S4S?8_vŭ .5zh\0Q%ԹzB(s?y oQmȞaz~iGZ1ݶ w6Akgs 3 :e)6/q0V|͇Pz>c`ZFTLId-,> h^T!"b|%+V=ÿSw##%7Hu9u2 )4JЉױT$6~5~ [-\,0k(CstUɔXEW "U MO4΄.ǛRV} f@R*mNs:hF))>JVBYA^ DSo3}MYUsNCYk6%QAmp:%\Orfl蝩 YߙLv*ǴX $Fcr)kz)D=xpq+_f lhuA..=@#i *chv2T?}M5z۠uwNFa֤)©_<ᩌ`7ƒ0˅2Q(t4-@iq-m 4LeL@i=[DW OL,2"4!beSS` r2m${3X{~.Izؿ8O &Š惱DK8x:0z;:H e fL5/;mFB"%F))#@z !kohk=#Tg>%k鎘^sGD<y^Vr*h1ֶfۮw<-y€J Jb_dZe sj>]jy!9|%-trbbqBIiHmwCGPSoZx7 B~jȇ0"H]ySS<䍈*T;/sV/{]F(=#Ev ב }HHFx:O9\n8kj˶jjB%[Ag.:TJ Af (eߺƠp5\>?ix3lM90r#=zS%`랠]*@ycaFO)G$;$%RΊA9@tʝ=uP%K ʘժ %umI[KaV!O{j-=K3 FߜS1oƍ3h>9ϪUm\祪k;Hmi>=7YkdDbÿé@H%P)mA?ƙ!h| y`c N.(WaF|dVڎ't{.Oʢڀqmsא$FMNFPޱEB;||-S8Oځi4p8ju $*UN'y۔~W0,rKYrs?Ã!o8^}Mhy&pJ%gdv1kb l:ģwPP} ()AX0`6qn+Tn`E |Ä ӈtt:1@dZ-!;sp+lql|^^Hm|v7t1D`lg%.\ !L*@p !N!U.q\. y:8Zw] %#U&fUބ=DaA$,-YnR+@27,4+?,[W h)>ϷQ†IZ ~%R.~48-mn3mp~H |-ۆ_~T v_a]q%7zJ4s<(ӘlfJ|EY]8—ebFT^~;=>mƘvQ"3 &K endstream endobj 2386 0 obj <> stream xڝYKWH0$67Tj''."2IT|EJ5SE~[6|SߔMsa囇 6\2笴ׇo,%|?6Rfu}|}*G;h6U֜ۊ2y\6WU\ŧJlNd_dxW3.K}A{7(_.(m6;᳕`|nSȹ# 4O^7M[/s;w-nm^6DbfnnGF%g\ ;76C{Z< 6껰nkYASf>ݧP"L8w;vAΫՔaanZ2S ? %}GNεNSZ(kȅ9XA_rBB~M6,Q0),\+o0ٱ>ЗxOı5&}j>-%ejB2XԀEq'DR)5Dd"9ztuu S U!:)pRRB+wcTг+Dj<yO.B+n%lNY:?\^ $QEKy4#˾ eڑft=]cjZɔ+kkd( lM.m-h)Vkݍ3ЧV{6= j`@%_JG"9tS">4uO~G=8]tu-!&A0coh#u_uN˧: bLL0Xa}0Ղ,,Og8u G4 SD&|6!NRZhN];{Ȧp)i+0"'״D,f@"łlDa` 5 N[TŪ\Wrn^Vt"."[+iqe: Q1k^UVPpA8rRB9X4d7'znևJ4)YaJDa=2/ƍa;C(qC3 gLٵ`aXpZ D5azU ~SɂH_dp"<~v|3ysfu4NWCXklc)*5._`螈5uwCkD,!q1pC:*81ݤȃˠ{%#>5/cb Ȟo2عܰC%ϘQ(}JlGHu;NPj |L%Pi&#`|зMVfvɴP*#B&*C+v1W)>bvO)o,S/ NoH~1-y;L/ N@.?h($<6SJf(zwxly&6 endstream endobj 2389 0 obj <> stream xڵn~P@r6.NQ MtqZM^5#,T}ϙ3C֨J\0g=:9a~$MV7ɗ/EaelLX:a"d:Yy @3 j%0FjPQ!z^7 #u$j$(\X.є(HZvY5UwhܩU]#PEEB=,&! M%G"  BaNN 4 vP*;'zZ"+1ԕѫn>T֮artn.{H tgG +wM};jtwzMB|mGN}\Z.& 3uҎ'r0c->*83n[t{xh!Ý1n:^#e| z%]" @ꢼ3 Z^Na'3vKǍ$%:?vj:5227d`} SR(,]mNdd߆^wzl4,AFN<}W0{ ֬ 셳G@c r%{0.{(Cxuڽ^H1Wm, zA| 2m>`R" Mf<>b#9ޓO4Q( P&Ӈ5>+.3lT%<03댬6t$O&aZu[t]L>hUMEgMHp=B,R3gYαK({*h+0(;|<43p "%_9_Zi_ Kع জO/ ¸gƖA5vx}9䥘^lw [)[+~4*\35ǓG J0/_t$5om˞Q ۈLҦ0eY(ՉR:$ Q(=oh"餐7&ārͮ5Ӱ5bz;F D$y[> U ֑0&*1ş.P(gM&}^ު1`)㴎REf\* ӾwT&\NKB ^ԴEE'MDfX6zA똬9y J]EXacˏO u endstream endobj 2392 0 obj <> stream xYݏ_a%rqfz\)n<򠓵k!JmwC.v. |7?W|_ܯrX݊+.UvSbX|JH6ξz#LvK~; t}X%@tȓڵ0V݄e7ʲ+x_j{\H2KS)O.$`|A8!TRv{6ZLL0//,KX 3{p<G-Qez~u= ]H.2Lsy<#,L_P)t['2ҫTYnW0%ܫoc_5QS@CYؖcݵ~فb)g:5=-ȹ2ŔTqWHk?Qԧs&/W`b׹n,xș59xנ?)sAkswⲩ8Y^.+|I&w݀FkL+JT&F($3UdQϸPG `Jd)q`!q}SYjsP. l)^ـ/>)ȅoC]tˤ g5/W2=6&{"ˑpwQRb%`M*S '͘>>ZR ^C91ԌH Sg"<3 V&v[Mh^{>bT{O<NW(ZutW+gZ+6U]HXC={ݓg^Tp,NWJy׿Vg> stream xڵZKW|R+ol*q$>x|HЈ EjIj'@ZR3U$Al4_1L?[m??}/V+a˴PakPۭ7RʄoTmSm+ujd3㈬ԺQpS9Wm`B%۶[tRҰo4LJ1N3֚'p Wb92{ 3|;$*9uk͒<íHcV[|cY-iBZ"xRջRe&֩Zֵ{ Ұ406k7 "iqo3Pi] Á&]v׹DmʬHPxdN \B[]_ڶ=blIOtܐ# Ӵd^([3Y{ǧPki-AHJ$Tnдz)}+-T~Ǻt} a8jwaNjczҪ吝G̯$W5:muص`ћ6T2ؖk.bХ,KX>qlxrZjٹ&9 .Ma'SinfouԃhnT/WCBs,Q=;K/LdqH,@?OmYuVVC9xjjlM>y{&2;\m9=8F>]8Wz݂H ?}xz) Grg?2k]Hglm@P{n3Gh-~N{朁/ij4kG/{9xa 0zjg;rm 7+?98m<> ip ՟4i-p߸ 5^҉"OE&p-O8_쩳AjZ2 [DTI.lCUP@{-e|۸iUajLaZ lljȓ}$!$BL?(XFM+GL3/ԥ7plqG'd*Upvkzvk|;I hKuujP#!kk;|b,3 ^jb(@; / 0B"Jg#x Zh{w2WΦ`d?mLsx'M@@I PųNv?fAsXm ˯X48,9DCDR 03]z; ݗz p z|b&Z_ɔsc7˼p2ݱL$W@dh喜±Y#${].z|&2ܫsnlQ(Q@1w%crL+t,(76wW 7A5_D WkOnz_]qf;+sةRpp ҩ^9sR!j3sI.R&ef,E ׿ GTfXoou96A.%dK˯Ԉ_4&[P#:Cch/Uۖ=t.`)#NB%-頔a-s!THzFlvZi Y;;;¡;&QYT+/5BOh%Lb[BMǗ"b+|s{y1*\4`b])srVru,>wӬ AqLɝ.m{΍UZc? ĞnBYu62+\+> stream xZK۸WDUY4MNry1EZtApM9%э_\ "cYw?^/^a JRC ]\-^PכIf.giqx{r9Oz~k"fb:YvEdYY_(l RV¤ +?ʖ+XrݗMԙL0S+벾w?/9I~[{jPx}絘,V4KV&$7;f4]WVJNlIx*3XJrL8ƍy䱉NP?v6]A}k;b2N2wCr1ɭu_-y[lܯdQsYv~}m eB)+SbZ|XApÄ1 NWn\Fڡ}XJV%hf(X26,goW$`Ƶa`윴p{RU=h~ZA3c&Ko%< q0c !oNs/ꈹRVwRN'Z-_M'>s0l0E7sl|mkB$<ٕ[1³(jz܆V[)CڢJ);|ֽ@a"[Xƒ]6)Pj_0 Ʈ5xo=8kjPC9*FbI=\PyP2qo40Hl0>u aI1H2̈́(IgY `."AaV3@0zlQ>B af͡ڸ %t\K 5Uw=qoBX}f"&w&\}7>{ZΩR!z,F4aCݕdR0֏ŒXU)et:4Qb:5=psDD{R`|z'mve sO_qġJA~Yu 0x r3CaK(\u8  Ŏ3N..i*g 3japtvUe,9mcŬbٴm8&`;6XOsbe(daNj24CϬH3,A`eT-"a\G|<п0(9o*'p bQǨ-|cDY. fx.b61LMH9qS Iv >L b$luߴ$'<`_R&OЀ|8|3Z|G[3k̲iLCua9[@A5{ EtFSFsϻ[[UsWf0|`''b6j4 ;Z~1V9Ö;0n!w77'=Vۮ}H=`LT0̫z8?1͌ FAvd&)f2;gvX6]܃ 󨀽u6&4eib9yQH8^ `d Po{e 0jVY%p>qϣ`ǭn,} '- ؛e4s%D7=-bS.6P 6zVm!3\56EruW6U|YxPm0[naȑU5PvbVu^^N/Q*z,J/~Oužkk." ac !K*'[+7oi|mFLi*80ejl6l`X& *wuޣHD/GN1&w|jJV wT|H''6H0W1(6]nO 쏓49(xN 9.q&@Hoŋt&]Ag"#bp;  p JZ)j<ë 321aż,jkA5:l꓇'&u>tأ]*.ӣc3$ x?x%XV |݄.̄?%3Jr3xsxr/S`[CƓ^gjЮ \FX) {ph ܗ  /o4'W@(8t 5\|šv]Q=EԱ?԰ {OAGh5ǟrr__(캰R .8 E#p\6&u6D).+7&su6})>^&)yσ7"OwPadO>đ=H2ySܵJǖ 뜳ދBDNNܧ(ek-wyBǠ('ڠ[a0p۟L. endstream endobj 2401 0 obj <> stream xڭYYs~ϯP 1A:O:TV6\-#Pqϧ(R|lRv  _Zb+ le8zfᚯ%%-~Ŋfڏu !2V^]R6u[7^I(7LnsYIpsΎc?(Žkp C WRivw?חeqMcx>i/A!*f,ƧPsAt9#?nzn}-ЍR"92޶j1 =kZm&Z w2}_u<r㶶=nR&0ֻpvuն]XG ~G;n#HwMoR7#T| ͓%vcᤃKIY`+pT+ar ̦LR:$j|1aՄ`,4l)ŔQg+._.jTJRԹXkBɢ D1v#o9dz6ɥQWWzKf2!KyF*%gmIɊg NbL}{)`P)qK$ps p e|L?w7pK@GT}8 f)>?݂dǭmsg9+ 2l|Ox3WSi eڂc'@[c^|BaG(IAd3{Y8Cu_kxk׾483,'AdS [<[)6u# O4U@ ;S=$j6FƘ^ L}fqTt6sK j)}|k y+_2ONnJ[ Uz<3,ڬLMA&g-Z:T?&K÷g(` 咨iNvM5ڇsFt5I: 9*t$1@CP喓'(B2r͙຋371sri^}laqV.84πdW \J7MD@RHyRBݔZ_~8CX-P.0'd]`f6b^ {aG1{OJ9ӗg]Zއi!$ff}rD [$z*{KYcד endstream endobj 2404 0 obj <> stream xڽYKW| `A\6r*qֳGHHt>4hrT A4_Wx=r;1㜯nW<[qrnv?Gi׿c%`i*m})eT;jj9*gٝhoz#h;MiUd荗es&gMEt}[n;X9M"+ ~\˺-燵?n֒G- -YZo JЌ~ Sm7So iܣ(~бHy۽)/ Hg;^`#" 7nLMxPV2-'d} -帐նi,O*GxXofJ(hp pK9O\F`/6j6AѶptEA>x['ifb}h?Qq:YL6lz78j;3_wek}Ӣʉ*ИNT 7eҎkm2X:h|,_0 ;L*aʨ;UEj*cS{8w}jjH//̶nsK=:8g`ޢd:" mz >ٞEg:Μ]u¤^{$/L0y>%kKGI?)p\lˢ)0oQpJ5kE8@Sc>} 1mwO6ТJ[q(Z Q]V"א?f>'.6] q"ѩUc|7_nLCqkf!b,|`U<՞\hN!;-:1wSw'I0/6H78KTtAY1S鴗i3S^w!4э+O:/7ވ(,;lG@rHt%B1wMo-=]Fn˨l ߻¦t^ {WfJ;L@ٚ_~cV0ТM1F0&07UeIXMqp 鑀:8ekYOefgiJc!72U7f_E OE~CxB%7]:,I0H$x"\)-m88XIR[eMM5+y 3~%4KgMk,"R -YDzB(q1B @ ~>K1gh]GJrD^P,|XBes. 0AEٷűcàv93t?8c!Nmpܖ t kd+X8 -v+G-R(kT=(h`g_kX2]E퇢 iF_RHk.ԅ92KتN fTnU7m;`,?r!4ظ# U {0:g|kTo5?Θy‘l`u .8֣CafYDnpν~^^`jf5y'-\zwP|@ /a_z=!Bdf _h +ߘL3RC| 틏VߚDcpE1^ӶK,{ a9)}^ͥr:*_Y*ajJv۴ "KVB"!# ESTzb"2b(kWB!-!=+:vݔwԹi[>}aB >ݑ7iJyBr9mv3M[ H-AmQwJv\X@nk]-]yW!_ l*WE';[IsT3M:B|{;++ kTA(w x-FF%!*H㳏]u\VQEQc1uնph}Re/w w6"zKS5;_f aNO?N`-'E쮔0wGYm ,{Ax2hop\&xd8¢~'4l?Rk})}^P`rooVcϏ endstream endobj 2407 0 obj <> stream xY[o~`R ý4A\@m(R%;{E^>=-@j;373J5Q 8Qy|D8Eyf,,n78T&8$8T_"9Td}BҬkA)b+a903{q Us$?lh~Vrbe%X3Qkz9΂x0Y!5 2_D y'!#2<lYng ŗy.^9W?H$ּ8<~us8܍ĺ@ /Pap<AE  p! [>'@q߁ 2t,_o޽}f= Q# =LG&iK~jfUR{MFv2Tf{i^Pn UrVF6aRB# GDP$^`ᚡy:Er7YI $r(KU\_a|r%!8޷3vرG?}MkcQfIg[e_S[)#m!3l ءI<&l,ԅ85?B޾:VPIv{,tux,3aޥu 𽝝0dޜ)N&bUNB%ye7wWp Eb}: ߒC}C1ʹ7IeqX>@3w6I}&]ُ{ Ia w.؀{8xsk0r$by*Ck"y<[zY KӎA"2q/Ńj#9^ՉjvUڮ_+Np NcĹ)S"zM2P.l͋gꦗ2 &c hm@ I]64S,~yVpwXO ]Xy*&kH_+@UȈ endstream endobj 2410 0 obj <> stream xڽY[۶~쓔 Oix<즞NZHBP^o'?7^v7d|!RssYaCV_VY}=]ra(zuSVte)vwo6cl]4~ph;뷵9MFz{:T͆uV{1:D!MUs w{uAվUV!;UVh$5[![")!^1ա=!(*= \H| ty"lq:B!%`mTZrg3Y~:Sh `S32۪dS{!H A*o+5 K'vbWtŶrmǏay6;h_}6\ff?0g]=R&-DF +_(')^ =f&1:qg19] g`#0$3*sD@% PH#w?YU3,K^L /,XZ &$mL",Ux%"b r$cc `tTٯmcGxJϢ;FbvU>.Uݶ0a}*ƽ! 0}Y<wUcJuݟʺ!9Cc[~h8X"̓3u ! , Am8q( s X!u(զFDm1 S-G0lk h= BГ55Evˤ> Vw]:`B~G̏D !GHbs4uoȇ&-K60*~ܶݡS~W87 i|ik?.V?>9|LMY||| z>oMq,0joPY3lyJVB6+s )%*hצ# 0Fh<C%D{ڝńgme%>b›O ),Lq}:NUrڄCOgp6жhF[rOw2h<ĉ!oS`26C)t߶fشy _s @޷#a8#y+hf[F(jWP_r{!M[5'?@cs?VȰaLɋ;XC`\twoWlxV7OC"rJ\)CnBa_^G9 Jî\}(&/U׆_;}3t/=cw)0Fw]Hr ^ә]2#:HF4e5GuGH`1CmyqcSկoV d endstream endobj 2413 0 obj <> stream xXMoFW9Q~qwSԇH]E ʤBRqw$M0Iqgg߼y3cD'CM$8G*W8KL0Ef.}(Wf4|1ҋzAۛ_9*fP>}yYx+c IX!0$lg4Og^îzzsӺqK粽rnrXҷǡ{ғID/,t㎹*~.92Wm781#Fl1k#IV/畱W:QB "喞9-~ܔ:te/A=K=_VlĊ ̋$#1wC\(4Mc2 :6,يj^\"m/kX2`-ʮ:vas.uc;.#IHIHMDDq ŃhFӌ38ZۦK+5kwOIӰ|(h)CUq(@GZ, p/1rۄ AَkPd弱.v!,n=%ޣَY[xn>3TWڣ*=>y%bT*r:`/xP񤻫XDPcB }xNA.8Z (ʉ;FIL8 TEo d W s!d3 /euƟa@ņʹ]ճFB :/b;`(=ȵV M-=(%cYϟܮsA]hl05tQ8CFB$br½mmPMm$@Co#<}w,P2sǝNWzn'O6͔d@1[p"0DTl7Wht_Ez;\h9>%wEԲXWúUf6UD7,pv͗#vW=#dVcxO!.f(~J1M4tοfޏE?pG[w>bOglta8(>c8) DG+^U xd1 Zł g@-l%w c eA)NN0  nvT|C GJ[w&7EG#$켆/m<vd/ڏY};fI1%hCr G,{:S!{g#/g(| AVCkXsЖ{ 0 m|YD|7wv^ݪ.*tt5Lpa&SP@קu[CG ڪpF`2ӵ۳tpzAQ>"7B 8Ihtʸ)N,|lD6%PgJ8y6vPI~_f^ endstream endobj 1817 0 obj <> stream x\˪F+nWU?E ޙ$E&"sj fAG:]-I4ŏ* , = yP#/$'^Lh,: glA;g}A߿HDA#p+T\GMA5QkP+Dag" nA+Zԃ.RH;ۣSJTR f C3 ut#GFb&B[HR0 I]JVCʎH1dpѩPtajV(EH^Rȉ!U_1j!FD-!9:܉h-FDk9*FXj#Q2xBHHi*2YJ15;B%DZ;ZCۑ1h 8.i롙# ^+BҧA1,LDNaj@܉CbGD)Hv%гQs5!dp !&!0 NTG`xu>f'eJV^dBDDDDLR"tAYz4d u)B Ga&DhCыDh c.8 pNd\DR ȑAdJH@dB0`X4!XXVf 0U BuR$7=!3 H.Q"|}ІC'`0L(ЖJzEEhC-F"4xg'.# @VD.5 "l:!ޥ93aS:KSAp7F'*L $AZ aFҪFni,|ք4}/sLs FD0 LH^ Fl^ `npœa1%Xɺ]h%nΧ5#-ɿg’seAHPl0mj' I6PǢ[ÄT5^i^2TYȋS,BA^FBy‰hȈ.yG 0͛>XOoIZ$q0q拄)"0+.??㇗nu҅%}UY,i4W@2|9 }b1ǽ7#;JV&\#1y1][N/l-m(9Ryңuo}6krݸu5`pIќ#iaGnήqks1\uq#ۮ3sw4stvY'OwR,^;1}lluoM Wڴr}M1N䍻s0㞓dIaWtvs:ovLg#s=0:շ`{}Gڟ> stream xXnF}WC%p%'%qXJ.PZI,(%~|go))̙9gf2n lXˈ˙ 1+la`6 ߘ5}Al(m~ur1=mt.o/>ūlRvFq˫IQTY:&tT `ܵN|H_RdQU1(}!Yyr X,y-,cjU"V'vlW&m&欌iXeEG/_F}M,\}7=f|>[م yT׬8,m }\HVXUi)QXbBıE 4isfSʼzsz@#vcB6& -d9xoӱ܇D{H\J#0,{`X?~̅=q.jH 4:dX y#T(J6! .nGYE*bW+Yɣ8;2|GӲGoh)7`q8;^iĶ,(v6uMR2Z$mءiw}(fE0!Vrkb4|!Հws!%l퓳k#pQ1%QE&*gbXvf%kڌU<ٲ9P!toϱa>s]3xaoZ1t`7sHV ¾gTP4sH5sX;یr B>,%w#=l k(l!_;JX0G-کG6)s'zE h"q-\Ikdw\B;34X8cƗpΏ<,95r9gp5,&NN^Y+A&?vdR/Zi0% eZt(&I -?͂m+iw{0YY"Θ:/+&Xǒ'S C0K(Lv+\yXTqT'aЁG|s16kr&Fx">DqV]Yη '$ PHY6*yX$REK5.Ew5}?u\UmQe]"nE -qTqui$w&RHF^"V~M2Me+ (춎&Q2+ʟU@u?Lf.&OMYϋv(K&uW½ 3-p[XPM )FS7zx:3n > |?QdShaBl׭K0\MQ~0;JtN `|v"N#bp Z"留 l;˫0F @=`/E<|r"2zva 'S ɗ9}d(:?ȷso%u3l@O]NgJӫ_jNHJ^/OߞM.F=U2?TGլ;T( W P'tAPr=K #{3 [aVIrq >).W\0)Cߍ863>0፵*XnkMIp,y])dqCn!6K endstream endobj 2420 0 obj <> stream xZmo_!\:{W.]MZ͵1I>0eIIUq?JK1%ya."xşn?! "+vr)*\ܮ'7r7V2&ZMTmy_ ˏ]0̑9HVo ?S)q)+ =Nө8H\O/߽z߮o__~q5Cm8<2("%$2-]Ur\7Cwue_cS-EsPļ+ǭڱXW1Y &4]*DQD1'qU F}>d:& l1a9pbf{u7㛮]Uq\ʻ*f1ɟR~4z5 K{ $ybaP#I93H3vev o`*U4숤3 [\YR#AG7˂~ڏ1|#T)؁gnFЇɺzWK7W'HLn2؈y6HK-q8 *ᒇ_oR-4Hx2\w]Rh v<:WGJ>rc "s dCkc0/%1(H]7 1{(u{g"2U>-D$uфPYSdR5GI@x!T.>g֘8l&$wM8hDEFS k9ݘqQ͡.+dna0*EovШ::U< Y|!le%.Dمqa 32ʐq6̑#L2d~GI҂kK_H$$>Z n-M^#,sX%HQ4gA!V1GmX)HRةي֥˦*O0vnJӼgEU bi) m7P( l:/ABOΊ ݫx8AKG41PRehg+9b$, J 'eq@$r  XX^V}SdC>~5b0~ո[w7Dw);3d6>+KW)PtepJݮb(U3iT`?R|aFOIȁ)?QyC\4k'|/8 ~좥s퐱|@'d |Au?F=\խJX;Ų~0G@qU-(IUȩn)pnS٨QG=RJnVO^9,0ٴaqTÃEr&&m$DBEVm{7*G%>R; 8A%`FT_e}lV5{:qFv}"! )P+D%V{pU-%u0/r`{CP bp1ZJ9'*xD>ʂ}`sI*е9ZAM43;\ 4 Sg؟ZQ-F㱯lil~ךq>ۨ 4o&oJ]!&h*O$Ͳ)>W\6⭯*#F{âj%y ?Voe B2{g26bWqi0[ m^GV$XH$YOUFZeY>u7@ՊWrWA":S6!J~?m"= u)=E(8SJI5~i9#=oJ./ ٶ7k3YR] >)ng- IۍGdP`)J g9P_dz%4Pe_t+PA)"!V`vL|\h֍H d93}!@UKb~Xr0b[>քY=[rphM[ {~bek\ُν`.=XQq?6ib%NipWm2rDIfͦ.y`oi-ə LCΦPii53xu)'(Ü!A'M> ?ӟ sY|52ܚ=GkvȃѺ3MY |eI5\o'R9 eon endstream endobj 2423 0 obj <> stream xXOFV‘#'!״@9%RM~b|gk'ݵ fvo>l`Æ6\1ȷ}l "yxzez6ތ3%u)̖OFîE)5d. 4cf\==L2If^xc̆2UF<̊XGA> stream xXnF}W R.@Ȉv,@偑h[-%*$E>Kl Xj8;s̍GxOQi=;(!Wa(ڛ.7ѦAI8sdhӟ=NLfƬ<}vB" zڠ x4iZpX[f`/ `*?͊C ,΢Unb~~n봨MrW+gq-ju˫eTHƻ4Gkc]e<]m~ @MV))CZVخ .m\",I-t) 8'L"4I8K|t<>W8ށ:hI`];qf+x'*b !I9bJ$DA $2*nLfL d`׼X.W qx%*,"?[<ğ.WA r Q&J\xA+v!Ak,,/#-$0߅ q^Svg/ 32Á[+lT#N~nnQn9\)3 &B`7. 1V;׎kP| pa/f_<[n /bs'h"[dh2qy$/>(e&:5¥,ew9iuh[,w7qiuC 'Jr7TCw@D&$ hI:gU% tq~!'н'mm*Ph dC)HNTQE5V\P=x}eP(oО-;ܛg#62e*yLU0NfGMWgir|<9_go_kP6=0捦Gh,H3 9J:GvxM5mZ U膸mx9NH$t蔧ذ IzGI#d8OGO1,zz-U A ʪNbxiM) Nh;E_1MUwnM3Ls=-3Hfql(UTӯhlunVXNҞN4/A=[ķys43Qy+z qTMyY1`ؿ30wTߚ/,Ċ4J>8O 5U=IF.(Wm,ʾPS 7&sFԚ(~^uU8k8٥CѺu1_Kt5 etR¢+ SF9փc̑/h;ϑ/Lc. 3%T@:_AACVoa_vuKW/|y 1tXxm4rc ?븷ڣ쿬YI sny=rJ*uTW.h (i5nH) + :Hm,w3n"¾ !Vl/ endstream endobj 2429 0 obj <> stream xڽX[S6~/Nh%Ye [Zn[BgZ8 7l]f{t ve twsu;X~SVY{sF!5_Z$BXť`6fQ"w=9?ODZ|O.bVdY5Tvx>Hܶ %> hhMX¤OKltQ׳D7 N6G4]..fGW;ZF00Pue,L„0H"mh'Y$>('(q;ͺQN7g1qN*+4MDqR-AxQWz[{ͨlQQ_m{^etӮMţFMA\fyu pހe@ G#,TY$HrL&'*Hu&czGEF>hF7;JXj(+S^oꡳU]w]nCJ49x4;=]}4,@LB)}S 6PD3etz^KH(TBqWeb@6n4>ok v(QZ # B5 D ?~TZxk/QTI~[ODSQKY:mzU|2ɟ̢$=Qlpp|[ze/ 󺎪$}ؒ^f,:IxB0 TQYJ:Um`DDb }'1Æ/xɡΛY ]&ƴnxfؾ/{g|1p;fdÀ%y7׍+H|cPpKE~*^*5q1yRSh]A_ofagj ЊYSAvOwt[q8J5 DIZ_!<( v;D0e3 ؽ[C YhΟOUYZxRժs{typz~A{\φ[&LyeOwO.Z-h {GZNmwIqdcomG(p%sQ[-Ow4a_s\?v'zrhѲ(P:连۶H# Pkp,nӋGP@(f#DWyiGi?> )Z( <]'W1?> ȕ__0W?#S4i] endstream endobj 2432 0 obj <> stream xXmo6_!\T _%8Hv; M?6h%ג؏Q9M"O=wIC Pd朌>uF!3vtC!x=Z=ƘKN㜻8Qi4SyÉ@> ^!(Gic BH^NrQq y\=Aۺ2L\UI6veo"(pR;jZ >yqs"mfY \jt#Ylײ G4 { :GApj.áLaqAaM10<3 Rِx!lg&0`K+|v8}Ű[}XMw0al5sqݓNZvƥ~4[UMqʫs<'j"*, $ďUӣtjN.n}gyBl_PIkF%Q\,Kw}Xfˤ*oxR[-Yy)~*ڂ5|y3h~\噯X 8mTѺ6"7-nJmn\MKzC#7JUX ( DQbfLtImq1 0Қ6[~#$IvYfQx`d /ttlRX-5ᱵ 0>/ȑ)4Ku_^э+p :;6M[V"&"nI^"!7Uj4ͼ-;4ڮ # Gt6B!DSa5x"J.Q /.{صN(K}u[ͭ˼HM5SڧxS2: ePI3%Ku[fbN{Gs7UW۪T;1Ɛl@õz"TulDj^ߨT-JI2YvmSYRG͆ dNO@I endstream endobj 2435 0 obj <> stream xڭX[s~(g BiXb'"NL.% `UMsΞDDi/ɿ&$x9Gvr[>#FiY.k?C73,c㲍|{_X&CWh `-֞^ (Ph KN&N)xR#^08,Rq+iM;KgPpPu57^`GG&1&/ İTS7YQQ PCʂ]Iɒ%SlIil\"'E4oOWD/ jez/ OkSX &$Vqrt }FSi Tq# 8QJ|Uym_Qd;:fʅ,K.+MA':u,0`AiQ\Iqd%4T\gwPYUnmc+V@g;`fEPO0dQs$s,nn Zkɻ:y V9ګ 1^_/. G-^͖/ֺ֩I/eJ%RFԽH\BÐ9'PAQ͏gW?pqnv=ϖן]a_ŏљ1pxNu3U*f:2]Ys2X͞|7l%=e񠜸"o#6i[r? ؍ݱi]|P"/t+~[XKƚuٙI7q>)x_6T'}& brX-f!/ Z}&F/+h;Ǿn< Gi" 9D\eU!N}#T.;>z@Դ_WOqlzi{Eo,\t@/T34<;amR~q;?red~}xe$aVtYH բe=j\sGN 'D,uc/ha1Khm~{Ւt R$V8bw|O;.BB:HC䈒 EP[滖{T?YZ04~u 9򔱩a78Wź܎>!J4Q+$zD)aƒ~a$36 ^TBaڲ4Ku}rc~NRtO>_t]k}Z2a3l(>JZv9v"Z~Л~? CnG?P}L1LP$ MM=p/Zs?$NRGo1\(,*=7@.KÇ5.7FHk K6'/SՆ :jɏT Ӳ(} MG'iXU<%S&q77H 8gOݰw{o"zWIB}9 ~٠Sltƺ^='B" mjM^\裻:rif<.X=A)x0 yzOuOU-q&atwv&iA}(s=.F4p$%dU,@ѳh#my=@+ Jc5&aF_s#{ĂFTh#&ʓ-b& pIݩPSZk>`يrq,")v p^gF @;u£m3r~wY endstream endobj 2438 0 obj <> stream xXmOH~bOAq~ 'v3rU3x5c`Vc= t:hv究a/?Ex|( L={,-YR'c?2Ovc#A#ވH?} C$ Ř鹷~-n <(fMܕV *Yӱ 7X9 .nͺ ne\,JP(̚5{R%\a rU@z 9$ b CAf4Qt6+eߚ9B%"#2jv,#i7Jcȡ3;1@[Ud itJb?-˪(,mN>**oc碠QokसiSBZuB:0@y54:լPP0=m. L:]{q{XGD]c#VgH hM,՚pdo(-Zu#[ Ч~0LS98JWey d$>`SUum!jOTش9(wsLO,Y`ɪFFVR?kCWwm04cV6n1뵳$Tdƚ3SEnyL]1հisׇߠ8 ƅh{ۍ N6MT8M lPiێ97E4W=2=+IN4Mkսӊ ܯ.5ÖBSC{N#;|w+>*&h8K@./" `l ; =:@vͧzV#יJK7sQLp.M͏EW_)pj ~fR#z.Atݥ{/X3fg`WkcэƘzZH%#$ s|)C~:iJsa)tV;joեgu*fQ9{W)d7E3؇\m6$Pgw 7l3A˟뎎I^) Cnx̬żk<وgM0K[tD`C#RD%_Pq ЭQp1z;Ӣر="ez^= ss{pvzhU#xwV՟G H yDÎ.;B=:ۤ;y.3YV6]R.Y*x=KCܾ jk*wiuxyX.rN}1s{懓'6}h*KqOk?zkG&xEK˧Qo{6銣+UeD?/PVm1VD3͐w2Yޖ<۞֒W]eQ5N vz!88]^^][@Wzv+z7Idzu>40eݸk)E,q^?m-+Tsih^WaUi,Kik K.eq@r)dǩ{'^FףS/ _wYxN5U= u;yM[/`G7ga3ܟZ(Jיuh/De꿏\~:rķrsE\YjCv'V&d:à۩*Cj)/f##zGY6AP,Pdk'.&L_H endstream endobj 2441 0 obj <> stream xW]o8}_a+m;NHmil@GTH5Ih˿_'mW;;;Rc{9|@?Cp>+ ]E`Ȅ.q9:amlw87u45ybp=8 1{7uhuȢ&nkyں2Cu &6Љ DX3-Oi4gz/9 櫈[h$g!NFY` Ƭ)#ٕH$b"Ki1MNbS,1?wgog_>zpOk8~}_c88r %9؆KN{aDT~eŌ-T WdP<+:cK{@`qZr18ʼ9 ~$SVeW6udX6YL;˕*a$'>l*f"ėKiL^~y[+qzDgWbrwPbTh*;ue,_VW~|)I=@6+8Nbt@AWbiF+ZP#)$6ɎVeuHRN2/RHi~~&EFt%,#<[<=9[lϻs>yߦ/Dt+tv+! UEMce^.;鏆B@_H> stream xڵWYoF~X(Y{񐟚4.K,Hكhiaü曙5( ᇢo=zF ѐaJzh('HкwYӫvp1MW@JOHPI"ey{yO͂IXQ RPad78ku(DHN|u $xf>tۺ7]=r/!*QPe5yZconp*2ъjQa[G4 nvOw*!٣S 8=\Z$ iԭVed!a1YO[f1Ȋ|Um:ʪ*6|x  $/`=jaѺ3U+N!Rc5~(6 . ?!ID7]~Xӿ(ޑrxq,Ɖ';5I7$8YRCW,*t>۱c/3J1A/GZyo-Y][VcgLxퟙH -Xȍ]tu0t.zk.'yV\d Fe;ת~hU|vWoP(+EU/,g*eA n:/(-$cl^zE O e , *|6興XLxݍ%ac8s0N [&{P>TN]kpay䦎FO,8פg1~EErZwH;ZZwAf6)Ujg@R}1#%dz/gd\tڵ=3Ӂ݊Фk׃.ܺraSb/Z[eʱ7j)q'rVŴQDӍn G endstream endobj 2447 0 obj <> stream xY[o6~_!x)"VITZ"4Mc8h;#M%]=8҄iw 2Eܿ ~ h A v|4&Y&*dBˏ?IS_黋7svl "|[[;{V/"bՂagv5Ea1F %QTXYͭӰkaTBSk n_7c[ )I87;myj@?E<#73&e%KlI}YJ3b\o,r+K $.ARcǵJ]]_V/?OLБ _,fb=6mW GZ56lӎΘ+n-!5E seٿ_:#{kOch$A@J/314d^yS]t9TO (ՍHoBJ<=#2UXF;t-Zv͹,rmѕ:?ud~r@'ׅƜtO=+6F#8'M @m}أ͡? =}l<{ ub&E]V1à+>;dxs:@ˡZ3X5ı۳mr@Ϣn]t뇅bs I:NJЃڏ`OyTto|b'+<H&Cmz ۟mݶj"P-\=lkggglU|̶ߡ/2uH8gp]T"?`Wf%}v Eބr}h;!ƀeU/1Obډ G׺׺Yu@ʰh ?L>nP$Sp8\c`}gArH=٦+HAzk@3…r2Op2'9֥.Ba}]-|ep8e}w?}#??KnnӥF^Qk?kmz:}{3Q;xM]*po^k J_@A]|oCQ/gziO.dQV ~=v endstream endobj 2450 0 obj <> stream xX[o6~߯0EŊw)/E5@wÊe{itՖINf`?~7Yt CsG%w NrÉ$'M*y}I2/qrLp`JV$WO7j;nQJS\^2XzYUSmT?|]0GJwחX AU+QY:T$K/.@<ɰZ)OaNz]jj&&SR$bU(ya(d\"  ]ܾak=_v>"髶wT5v5N 0 s?]ΤHw\{E2*$" b"6N$m;8bHq]b"1C$= T('Nib,cw5iҜCaEy,9gC ] 0.O$<9R~nuU\jYCGdgCGmDb$ no T1S5 aJVG1f 3* y׷M5]HrQZŹ#{\Q荃A+1~ÑZ+k`RskK"(.[L(^ZmR/!@=\fX&&Qu+kxt2U篁VE'RqĜCAC t9>Ҁ{sөrxf ȀpI3Wk/nC/tܻ n􄭄/cqx$LµB dکuK1_[ endstream endobj 2453 0 obj <> stream xX[S6~Ύ`a]|>\ ]$0:w.:–  `b}[G.[C Sm7Pj1w;8R;ΆrI1?%T`6YvUk=EAD-E(Ĭ6 8a=M禣V՘xaث7-C b?nCa̳gn=xN'={rq?-s "o|Pܩf1N(Dhl t 8WfZPO[zoQKYIv/m|51V܆k5 L؞Pi PP6>rhq^VoΓ%xeX̒oo`U',OA75@[8+SLL]? wge;xP[JCc!ķmCj@j6UFkʻ\f'&CNC"68*^_@"uT@f2$*3 $GnYդRT=d4$|%1geWYH5+^N˦B\u_Ң=qi^=0%JV2j|ʗPtq(,%Q˨|}m0+~98}^l{/1nt 񣋳ST#6oONaLax(Bgi4`^Zݮ [{H4bXv#eC~bnƠML"H \WŌ t2{sσ+ CK1va>]T(q&n‹(&0ktd2CN QK|![\2ݦhP塈ϣ4OqbBjkWi|pQ>:B7/+><iU`te@y EeF"%~#q p}.n t"bǥWl7%VyP a@B ݤ> dqb8F}[)9 <ND@4EsKTek.@F%J̻|*ǩIr8Вc^`(3@+&"k{s!"T/SiחR^h1 /ԕ'.,Px}xk^~v$zy4mﵒvUʖ@^ϯt˦CV{|QHY>42%63n%cx%yF;ӖgB?L̅ tP?%XI(yC‘m  GQUy1ob΅4Ûp![̬21 Wn^ބG :i4$5K|(=[F~ endstream endobj 2456 0 obj <> stream xڭZKsW(mx?&l2UK*8=f"^ZS )DQ _7iC7F3'y_؆K7Oj6V˗v{ϻb>UMyݿTk0iBY0TꩼNm9~(D==4s}9̧vFJU2htas(Ez㐤(hJOW-$d)}P|(F#*<>_W k:65St:v8 [L^l]%b״p'Sm:cܰ4nji7~E GBu;.Ju8tW (wz&j$`2  e ]y#D6,tI"AmG=hZ9(sy-2ivd ,IcEpWUl 7e<1ӄ\4̇N?Şs5 ]y~UxF̺9ŒLeP6Mu z,ʧx0}ދi؅ftPU5ʆ(V>C4Gs;WgC=\ /¹u޿ )}ػ XXs=D]Uݹnad}|:bЃx# _!p4¡ENg|"J7I;z$QՄ_ڧU16^ӽOtz\`¹LHai0`߽ iݔ1 t1ƃ-nÁ܋*J<l.a'u,Ԃ']/wb'E^Ay z*@DeoVNjLC2;J]8RHM̎AKM8/! endstream endobj 2459 0 obj <> stream xYmo6~BX|DP Mlv(LVEPN- 45gr.$vѹj>k 8 Dp=^UUUv2m ֪sĀl;F;:k 79S ^f^䅲v/ZeWviEhPZ-c$$PI܏=yɑ.h0*V8R7tX0ф4,ɉjR8yw[Uno%8=*z+,&!#;CkupP\+'i A2%ڡhg`Iϒbbё$?`&mV4O,'paPյ2MAͦӕ8&Ijq bڇcgy qLh u Ks#z8AdސC%0_A t,%MXu;\ki:KTnkF5N=/[Yp4: b >2 >6H,Oy 8Tf`|ix k0+Dž40pMlժst\0(=muUA[unb{WۦO}CU1tzGj DMHT^N*mYa؆&7؂s4%rZ2%=Ԩ5 G0ARt(6 c8MV4N͵Pz-F)П(@S*{MU40~hJˇ7q:OvMZw`ذe`{C5!s?Q (UT[w98L''|*9PY~Y7kLrl;0padKؾ@-|$9`ԉ%qW57֘~Kj2j! dAd-,K+CZ':'B)}Ίڳ>z*d GW}.*`VD4a"4cF!4lOƱ'a>]$]rɶRǦUvԬƢa)o3 p(GY# R.\v͢0أ`d.W?L WdQcQ9&"}.j{FƤqaaҞtqi]3qcْ1:F10]\Lz"!&y+]>> stream xYmoH~"Ⓝe_JHPQ~pMcvt?fv׎]6i"Y33l&&lBl5lO%)Ml1aɄ dr6?/ui(Xz< i^2[fzyD2E"f|#a|䔡" zQmI2% Fnfun<>voɡ1t^Fs^u.qp^YHΔV7mP+INO%ڛ&NxQ9,ڥu]̓ Me>ͪz$J]Ny 1[LJs@S"idx,YQ"Hey`D$ר2.>]h)yL8 Zyf!8w]4RFltŚNJ0etW8e&z}P/(&6ϖAUf}~bD}jZ++j֟6ym+?zm 1p/YbN<$8ah8M7(%#f.ruHĻʼ2G>- aQ~pTmV:z*bK"-AU2s;d61툈0նAW0ٟ]8F$?cH1rL.T81U;+B/ޗQR֥ p^HBߗD1x$ 璐T|s_|Q*/~*FS6wev.׼pDGخR6ߝr BB&#r$h~l˿պMOĝ+l'XZqrrr*.aE9/QOYXuUٕ)* x,;>`9zSȃvi Ygu6EV7쪹mZL*Β;O%'$m-[ 3B+n-|5 =y Atl#b F~{͖Щ?kxķ.,lBEc djBPbHCLY$(2J;|HZɷAf7q]<+ȊGEU=}飝y#ma0 YMA+㷻} H/WMbt1Z z93mECcρ.7h2$*mNX:k*`'3t TSlp}<&,c}fe,V/ګ+DwTSx{͙* ;xɅH,#%!:~ uÚ!8V!i ;G:Iڏ(אqUB0OkmAxV4 y0#N> d>@M)n2%`)IiT`;4`whZ7F#f*xpb[03eNyJscfҋ]RYcx<SXV+(Dq}V_o fcPpL8<vӍ:sQҹ68 >!)Q܅ qymT4}Rת8^`b)(%Əy2b'K10t<^[Ȼg?~*gBr endstream endobj 2465 0 obj <> stream xZ[۸~S!#x)nII3*K^ItCRlObxn<zˆnn2'bwlCM76-)n?e8#Ya5>}Ӈۘsmi/şkZD}}j,FCw%YXh0cݵo޸Ub.piFR|ܵX ]|pjjFtJ>}5v@U4^nL5aYVFe (">"UC$U}T7eao"I)s @fEݸzBp9mb[7!&Ðm,w"^}4c.4=Jjyl@Ø *zh*1MSBE[M$LNz9հMioEE0N0 Y ID&br8*Uя0iV ta ,Vл/@2MNWVm/"q߾A! 0i[] R,Js Z pC ~wQ27 P&x4){  .VS& o(}i a'xxp~ُr0Se==zS.&` I|6()I_meu>*kW8xI jEyFT}D9d h xCxJb>cyM*>1>SSP?We1_x::=a r5:u^69GS>c(I ULeBWyI9-']sAg=H0#e+fiǺțE0HBkOFj|PwπhSbjSL(T$mcϘG䟻47YףJ9Cǿsbw>ZAUK"QZ=X zܼH(D'ϡaY/ |HR۫>S_asrФ6mc v= KaL 7K}?Ja"`!X@\ڑ)eeJZA#p4I&M'CZ^d UC9Dgt9l "i\efy g*38F, ]PhuLoQb.8L{͔§$l9Zq>m#go=lfrӰACrذ'K TKLՊⰁܝh)*H`6 fI&-yȾ_ěru汎Nx$ w:ȗ}ApԷe~ʥ6FyDMSpup? ;Ѭ8aD̥}Ƞ|kUtgƷv/vhr̚؉h `uu%!3i!^ eF*EiXeCg,o@(1 mfg Xig}QڛՉ*UDjG඀#]f:jf'JA{D m <] z}!CU ]4 _./|/ЦK}}0|ƿDAKc\uƞ-q`_⒒4Εpx"B-1TNf7\ de"1K륐Y'XE1e.AEu8Vs#FO+Jav 9T -ѵN]<;)lh]Cks/=xd/Ǻ?U0yVbf Juҳ]g{4= v_vT6V'[&!ltdA%LқˠM%fAgSnSUC'䆛 6J6#k͈FXNN_u(X]o: H4]K$4u/'u\Vphꪼ6Q;hp_8`{6Բ,iLKpP<Ţ{27Q+YvɟcyEC;4QzjpRL"ԅLjRN'u Fӛ<]f L%YQ Ef ξy1;鼳s̀Ύ8,|||ѯfHNwgjW ޲C3z A,,y@hdM_벚ݡt4E+kÞ`$чws$pSYkoxdyV 3m=cצ07U80nO@ʔ.3T@gQwq KѺO2pMzo/qh endstream endobj 2468 0 obj <> stream xZ[۸~0P؋WSRL ]e& +K$o2@|yHYsC A$9ϝY{A9 oX^|-hN5 I!zsa[ۭ2LPն)w_}BPI@}aYDA ~rbzڦ-fc~vOe߯2f[űSX)튩ո8^UEa~mWTC6eHueץBEXPy/; xFYkd{SؕMx6-AlmwCOlZ|69JxQ$ւD̋_Eziוnpw}!2 +2#I}.l_[UI" Ày2kF4ӓ{aفkWRmpi cՀO@oq8r *(R:QN5֦߯PE쑊,r U21PNrݏ*AျD_+{gCO(s2f jtv=8Ѓ;+-]צYQ*<76DQ݁jdKwHa }uhM0`f4,*ЀyaN- y*8'cK%as E># S|nރk =_h|o?3v- ]up>@m"Ǵbj%bu\};څ:o$h.lb٤9Ոv91:Sw9A{ڀrFZٝ]H1Ch'9cdPFCd(W%j-JS*V0O0tuX}]m*d,s{<5a0 vy#龀'za2ȁ(t8|yoo'r"g}oF4]bnwl{g>% >O DTq=LdJ8KocqLdi@1~Hgwɸ(@d7묵k' .G .29GFP}99_ |c7H|rW \rR5V.}.p^cX1q4 ղpik>]rw Ypm0C5 羏X{r, ~}ܓ;| Kl !w-5ӣrOt (A˝8?mdo@+g92 O P}; @^eF=: u)CMzig :KGg9"Gl:}{dtLj'Ks mNxMFf]@=bnBON`1c;|o)\C< 2̔Y>om5j> !}?9ш1>'"/=ְ$`W4,ƴF^~4Tkrd~Eu#Zrk^r6miTT<< ~MNyӡb?P[7f/ 'LA@O@.?D! endstream endobj 2471 0 obj <> stream xڽXIs6ϯ`)H"nqg<؝X]8-&\>opv{⤺A-[AuOʵUEQ8fgU EtWry.Cծ⊘DT(]ۅOI)BM#{}ƱCZmU?iuGĘ&|@#wO}-ԬI@BZ6V:+利HG&M:("KD[Hd8 Ev5jt}i`qV[}A|1n3G`H@1c ?03mz ho`(Ŝx7^o!q zWI>YF<D(YU@ ntƣ|=#RSLAƄ BB6tP&K=8T\qV ;C7tWcr?NFfI?fS>$1NFUY1 L%˽"~@Dh,w#W@rYw'7U6_e!g~+ʞ0>(z Gu)Uiѷ:*I}2 {9{YG55sZ'zJ=h ijB8zHy%BC=O"E-@ *LSE-vDԚɰ0nt9TB1LF~c ; 8jOj54zjL8tIAh}лowv i[hb8ܸVYJýlD| hHkGN9<6ȠlnB @|!g(-bC5mU$TԫJ8&[1ekNߟ;L8vvwpWcۃ%JYtTK=#ti'C3Ҵ: |Ӯ<[Q3)|ua6T8xF*:_9;/#Ե?VɠN198;N2g?gL;H kcX+ 3*sLw9t9=oj6գY=*m)~1UKo}k,>I4mCRgh)6YjJ*7+$9Js3$TL3ۤoGv|t|,n&q5j0n.r@te3Prr  -Sz1GB[#qKFb N/ǭy0W?N A0Ed Acp4y!r{)9Y* LnS/2G vo jB% zo\HPGEKY$&aK\OD @!7Hݮ}&yK=p,!nlu\vZlߒR{b?N_}YR$mqPW4LXueeeޭ/Ogcs;ޞ,{){Ó_8;oTNNgﯮϮޝ|{z}qF2cz5Kmywuf?//~:^t 尜}.F{)Hk|U>u~}r&|&f> stream xڽɎ |H(,V=1F&2[*8C궁||ޫ"ۥ^ ;cիoLHh *Ye I4%T'Rj>}W7{pj}^P}^7ih(%B JKdx4Yﺎ\W =Ňŷ@GSq-9-^$Gh3Yo6 d4Շ~/Cfw?AJMyrR)Kgr&yLgcGiMҗ7zAtD.1wKeN@̉. 1)W|ccNsArė(Tx[sS( m b(wKhvIOs뮭9HB+p (? @)Vg|iЄIН3{XIe~B4z7,",dCb:Js임[zpiы)*F?јb$B%QT 9bE/qZΉ>cuC.R0tVu5'"=^eHtfΧʸIAe=U b|\eL&sT!LHP߀+-dZ$ZLs9nџ, Ϝgc\R~cLqR6? `Adgy:'\ZB"9(@qEPNAi`*D0NϲwQX}},!2CPŭq!fbG?O֠Mf& ˫b /֑?NrnL q) -¹ToEeO٫&]YoI֓e7ؾGD8S!4 OBWJ^/I%Ui2ʀw,RƊ{uQYOrTMFMb0KD!^k{;g%{SvyC ]γY$&>IIqjUXeyXFH6L~ERg7'UW03Sg}⺭1E"xJb4W@ס!MBsv{֛0AD\θv]>tC׺B9e,VrW-"bV5v Udtn0; |y2VtkxŚni?@i jyUvm: gK=7E}F oe8̾bz-.0oYA- J'6^nͩޚn d%ָ^\!Kuap8} o NI4VhƇd ]˽{:K'Zy 6G-"}xC }wɩo_nozcQҗ:#ʣkE kt(pz} a_42mtJR`Άhs'ki"ABJ/SVwzd_Qnfyi[f3v,%^rJ^ pixs>nQ $J=Fy !f;N48d52J k0L?Zdϝ ^ڝ2[ۀ)p5mb>Y`6b)K;Ynj @>sC=ԧ{36/]j ,WCA_/.ԙI_~AljD*lW,x=~pv[<a\.|ms,67擃Mdͥc!q.Ix뺗HX(bpE,T词4 w=m?`(5*Cئ^@NyD])?4qTMc_stGkU,PP7"AoyMK~b':(UȅArRɌ%N*x~z9SmאnOz9bGغU1!<0tG#) uLsG+hZN1>>G3x@I]S$dU lNÛ[W?R>WΝpڿ-+-/@+o܇,޲)fJ9aA ێL@972.8 hU򘢼$yK :&1;Xr[|W ) 3CsG3)sh8}1f{k}?>) tF/'1 / /;q0{f9)ZN$GKh(_j;h^"_ZOWɯR endstream endobj 2477 0 obj <> stream xڭZKWN &^{J8TʕTƧL\1Hfv\F|hYi6. @uƬ~]U /]m?ޯQx4݊,WvugbEz _c~Owk)eR4[j_}{8 Uת?RZds:͝0F] njrfrKf[S=Cջ/QΕ5)K3biݷ/XQhe^HυINoG)}SDV2rS-bӈԿXJ3s4P "q&R2ePǏaS̰L҆6Н6C[$rJutu! SgD *+GҽjQF%?uUnymYB+s5Idؓk9s poڮ+0–?iѤp.,9b<ʿ+ fnRg?]HlQɍ*l;=uStWu^P+ ЀѬ͌ rn]hZZwkM͍[˔w~ Z$@arSuBܝjܵun iO-ص]qwþ{?5[5@RnOzkO _ }ʨfZ p.9RI>NO:'窮F}d~U?8S5E˦<Q 8wT&꜎bQ܂3}{'?lW8)^ō<)`cWvtRδ.-lmwnS{/! *c V6,"N%srbl)̨E=\7\ kQJ:䎾`L}rab@p|gd_C (@߂P4Zg,]: Tut+)vVڣBņQzWfy>9Gϼ7C+; /Gt8,g:#(y7P{Y_Aow8*K Чj"T_8R,#Y S09(kؓ:֡•mʾKLpй9IbP=${h,ʕdJB$]&S{xV]Z~d > _(_HvQj0nȋGoK 9tԳ  3Y y \L.+>trX|Lw{P>#=~@yBg-ܨgd*ƪ&uۢeh8\B~pFW_,%gyR`ߣf#MEHt@k0G+f|Yf&LX뙠<#Ekr )5yUDڱ,ȹs"{[BmY^RŽ*b|CXҙ;?.P3n觧lzN왨FF\b3 3 iM3PO!~n[.8zi2vq"-uce3F~g$H1Y2ȳ9@/- ֎¸ry1aGND/Ce6KV~cRFj9kwp?VMOuF5BBoA?[<TEW%3*15y][׎F=;؎[JfrEMq:(R6H 3%\osso{~mĸ7oδGU6n n=tq/h\;_u4˲ D@]@c24B% <ņ([SnY. Un`SBѣ 3էĻsB m8%Aq&y/V}.v Tdiz[)H^k^ϖgK>7:gMW `+&lG=B B+ӗIZb1)YOFr_ƭ&m`=Rf/1kxUpGYF/c᠋Y Q;B7SN)]#f #Y6T+|lͮw=bpJι;%}92RFYZC2!> stream xڽW[o6~߯XNÀ.hdAXly4~ɢ''Y 1""scWp$ h~YD/ISS1-:u%gY/Jong_F s$f"&,M( 20uD`w܏ʕy2n흕 2Pb+*ί !`Q2,\q֜C|J>(oIpeHQ5:n2(,#*&qDX^;]=:`VuUƈQvR؄(X an7ޚ5HDӞm:F_u>KJAfg^i+ĆvFo.,)b] *b-rՔ $$M~|v8v`PFze=0$:J,`xQy\Jv/9۶EEdդ)89^xwkqIQ6zMO qyЫ(N7)h0Ew ֝aDXQ 5x1Ol{NDGpwa|Υ3ƃLu^M{;Ɵ0yH17ʻ^O `0;d1KߜܙZ06~cO8a/JO_J: P^,X ]  &k-̥{&߁?R}՛n_sp';*Eօ^ŝu0[BE.]xDKDvnJȯ)"8?G8 /Oa$'|t;OƉIc7)zvᏋ,ά $0ջO?7 8%6%"Ha ֿD ySΞҳI e]kÖd񛪭M^C'WzL :DdJrWSdd|8ؗR N ]I1bJ d9gӂ3J׏mgZ0d|Qo0?ֻrz]~dR>A0kX2F} dNdIr$`Hɬ$CS?p+rc>0O>Qn_؄.ҝhKi!Yw߳3+7' 7 vU. u~R/C;Ec[x l{ww\*kbdema"^5f@ ڐQP0keY|70mciztJQ<:{i* (CkwӠ]=w 5$EV#vy``t Sc/Km>Ӡ{㚌O[ endstream endobj 2483 0 obj <> stream xS(T0T0BCs# 2PHU4g endstream endobj 2486 0 obj <> stream xYKWHU-I'g=8HLDR&ϧgtqv`Џ{v؎?+8q/|(1԰N A;&sVr/pXA8SO)w4Lsy9$Bj_]. R 3w{xq_^Hi%)Pb0|<5#|#l8ر }efݦOUlQ&щ9}.K v;^{%DiQ'TB9^Ȫq(9>Lj PKS0ZBjTIqN\5]բܔ(dB&x%V,$Yfx8 TxT)$7CUT:qYb6O̺傗\>)!D/{Ųj:9r)T+SJBE.6;t͂5pulcXCM7ĠD*%G$rPqu$5H5 9\kgnh>aIEK଒˕K$d9&|G/NX/Ij&/ʣ FU`ї})~a#ܨ7etp]D2~ݔel#o(L^dm5d1Bm䆋CPusH`z%Rveq%m4",^B2HYĄ4تoR ۋ$]MQ]9^1չ/ǾoHw>?Vj<"".sSW_]#4Xm s:rB?46F7P V EWk8C)Ъ:Pt`7`>4zEYW(9qyhϡd L.dgu:a@}彌q4f:NE[R' . ^͓_tJwM|)Xqpj0@a0~.BϘkO.?B -H:"#, 0O ^8}+8NAlŔ>zhM|)F[W/㚫)xhm ?t}˥dDST G;yJͅ2;.6Cpxw sZͥõ| rv7x7cDIǒekbBc4ȠbE <~ Pp%n0,eĸMJ?=ҳ(7ĐoQDҴp) xx DVu>]?a{$Y@(=<&1ds&˂0vrP#(:m+!.0 _ F S_Gs8)ڠU=]ry\-}pC} pg2$z*dOε~is9nYfC_b߹i-4IP~ygk4V.p`j4 HbiƠG7K9{RnrC6_p]k ;>KM=FoXY0qC=&f`0Uh(?F PaHCE"WbZ@O>p9nCsl:_0}ǡ0HgO@5:>@:?c.);k:W sG'•4 D_:lq[ ^Bmk![m][svښ}"Ʃ@T)=sr3 禞i@I\.Jdɜ+4-d#,r}7g$\<^(\!-.=9RQ2G\.zea8^8}-fg}'pj84!`rG"|s$9s&")vOO^p~כAJŢx2 lBy!Ùy/^ F軂ǫ5BέՀtd1Έs 7_ c2=y3A%"z{s jnʧC}re \\,ZX%]bMW.ٵ7[oRl.炵FX?*P]|3t`UId9ǷDTbOaȢicƆh/q|Ŭ]mF0mox97z?E 9F%J0Yۏ UxO҈ a$^;4O2Jwf/ endstream endobj 2489 0 obj <> stream xڥZ[ܶ~;4o$(8A-AzHI͢=R#R1 X;귕ZIVr=Y+%E! ]|(lڮ~Yfkެ7Ƙlv<Ǐ?U{8 mϺFxΒnٍ-D,C)$]W<=6ۡnq_vW8ڰ:?;OTX'6p^%~_y"KbY}qNd '5+!"Ke /,ۀHU+{3k-^WM3! u L7x% RQIBp2yaSɱU{RTە#5(gmktBzc^癰l$8.3XEau`ٽ%yyOɇJxT#@:I)eZ~ ?Zwqϼ\ 0ɹq{D`iˢlAq[V4j;hRιk6owG2'"#Q!1Ѓ_Im]ş#ջC?d͟?}[BP &A8j--f]%*A8ʄ3Nb0#gFA?K8© KTݡX6LQD1NɜmsMpM9 Ks Lg#G65z!S 7e{eKHg"tr~قs!Ũm=ɕbpXJe/(+iJv-mszぬg||- 'KmNdm۴M-\|Nb~cIɻKQҩrm :Xr["19x}DU(^3$ePDd I +GX3l-Y))>Msfu%Te!Lk++ AfCC+)In!A R i 9#M6 8 ے"2p蹩(şzO+=lx@uaHEDvz"AW6COaՂ sL҂a9>:I_o_r}}Roh(/=og{9/V +W|lT- mz6Ѹr} O_!ipV]VSs-8.Z}0,H2Yf vxxT۪ˮƼQ'W,cSvx&Uj!as3M٥|ѰS eN}sS )X%2E`͐"n7u7I T SC*Wdg/⿛y U0]l k,e__86\P!0m^doz{?oI1dFT33*!˿~߮߾73T-ѝOl*mzSq=j@5LF5>g )pWH^b2U,_Iy [@5Xu"_RFZzA2?3!Ѵg  )8hԤ0>ϰ́g6vܧ;v,Fg;gQ_Pܐ82 $P@ Y J8L'3ǘv8.%I`/eOjAzG0a(?J[KʬTgVEN*sD 3$H!819*3aE 2kI*DϺڌD) Z ZN!̳ P6~0jM[UHy3 rcjHM@MP>!Bkp0XbL+Vb9` |`fa.A<ϧ]zFE zV[LYx?oK- zţa<{is'ixS1$UFc+dRKPSDY.4r-\=²źԙ bx4]h(҈jSXČ$.Wc/,gԔwkT> stream xXKo6W9Z b&@iayE cG ;|H^\{.Pذ)g83LjD~HRѺ^_E҈`DWwQa(**|7n0bV <~[V_\q"dՊ ;-1B04"iU3kϻXfH< ?qf ?Vjٙ(uQBRȬJ8hgZeIU3 ؿd6yA'ƅMm)D\zExki\+*{Xy5e҃IeU6 Eޭ6`QeQHlBD|*S;jJ`f'ڭ*!$(TwATzv߃sh6ð;  HQXJӏ_wn(f auـZ[=2.u/|p.MiD0 mP*2h50CͰ5Z)wݲL"NEg|\3gah4?A C7^/탂9 ӧFYQ0R sK!&2,]Vh`@+]$,-X͢} )tឬ-^Ԃ f.H mXlȤ6Av., q (}8Aa _xC J&SepC q;{׀@1 Z;c2jW)ve8à@4bFz;) Jo&MI,5.7/U{KLv]&#"vЧǓc(ĞZm@g^+ͭ1b?QC ,_)s|iՔR.sk;_ ؜>/-}nNp0 m])MR>ץ)_Pz4yRlz.07HfQ02Eۂrc:fl>Mdk?9V@~HJEnâz<M [evՄ%_xR&-[:gyU )``!5/̞3 ܺ "-<+8b6w霘"uӚ7zsҙ) .cj&!#n1xj(ʹ;Y<%Mwv2uWItyW="jܹlᘜ2fPk3$!,|#HGC&l2Wtlfm A9btrg>M2@2׫`SeSg%(4]ol!=}RݣݩY򎹣ڔUM ~o߿ ^E endstream endobj 2495 0 obj <> stream xYKsW)T0"@7%%yX!$gqǧƫԪD7\ ѕb𗭪ۛيf _QBn6fV3qs ?]۵ E߻utRvY3 vկSl)(UWmƿ% g*snwRIɨlS{Xu9ģ"PAސLLjh\!ODu)>0VSP ,< r&)qmo6zpN1llкʊ(!NLrE[Y[<9c4JL3 Q `zA}N13T&"#S=A܁ `M5XK)|{S"DAocnTa0_I?Euʼ6]*cru\áĉZ.S_5N֧8IK"l}XZP>ԭ@>nyvk|=SGUѢxij8To7Q"ѤjN$L` U0̊øYd]bVAĨf06@g/[u! 1h3ZCIRMNޥv8#P{3Ha66nA}6"qp1|0rh6mЌ9(?shԱ4#6ȏŚC=ز4/t1W(#- Ph^3]NW.ER& $YXQxLQ}cwkЙtSwڮ6}jOX|O̟,NJ=wiW㊱$S.rԾmܦPQyldzVy *,vņVɵt]`AѣEFϸ_L[?gG_z\;" oI:ol伳ź_)wGYy<Bm=_^m.dfE +TPWÞt4p\gU" _2gcY$' jZץ9# L1z(d;\^`Dq:/Xx|,3CyO惽l![㢓SU`ֽN]?(PŪ\< &l?=StjK5pi`c%*~>jsUoIث4gC)p'g[TjBx5/P}&BNݩZypuWHd|}Gj8щ *T= gPJrҴwAw۴؍͉0stdӺ8:W' Ґ!/7g{؞q\[(԰B-CKR)]si H]rz\z`̡ty^HYzp=;_֤8^}Pε/p= ͩѱ]n mi/C^!d jR=ͤщiA!xwb_^a i8:I.C&f愐~xzVnc=J6̈ =iŰcŸ?ԻCb ?lmW48˓ڝ-Nʼn0c7ε[~?.ЕãEPTmGϯ83~mwГ%O# rʦ6sߙǃf)`bdQj8s.K+FTF%eD?1St6d4O%?X#j߬~j}'" endstream endobj 2498 0 obj <> stream xXn6}WCŊ7J%@[A kiv ;$GjõM Y"333L>$4&<ɷXBsR%MίI)tr~vVyQ_u1AMoЪn:~cCْR qD_ٍMUmPM3+7`V Zf!4+\&ɒB%$ϩ_8VùLNyr, Dt4ٽUls v9] 5gE67Mm|G%fsꇻU YCոh+WGˋ` 1Ӥ2LmuL$դ 3A&xDnk3 q]ЫF:c8`umڷgn@.CpCz8nIq^vI/$\A`j&~ UTZ:M1|6כ|]^Di=6C.Π,oC3Vm;_-dt0p|PM唹Yy%}WBm]^YgmFwhQ.H=L,|(D(7Jz~&4m{ya}6NάcҀFb&&LGM ޝU&&_3¡$9֟M. =]; .X3c zejk|*L)WcR1^0 #bIq{EUAڱ;OSż:Bq@WBE.\ۃ0U:BBz0M;RsJ(/t+Nnu@O@0SŞFNe:ⷷRDi9'NݺqKG6w1#9ӏҿ.9@5>q?th\3FsaԌ O { `˒\,^r"0 dm]vӓ vf]h)ɵX^^8mh-&~?8O^#{֬`ZDhO)4Qbs]H*Z?Ƶ?gPBʃZ8ΩHStS ?D~q˺eE.#8? 䠘aX\FfG!T<bX7_0tv*XC\']Q٩$Pg'0z/Pѡ0s~RP"̼uƛ+[b84Fc #S򓃑@4!A ƭBu =Z@ޏܣ΁߯hdUd,<, W7Xa ԆO(5dPJ*PS@h%ۃpW4i7E!nݥ.WDjHG% <ZriZsd<4ɰc^qa) O٦%0th*n٤UyMc!An4v$k$3Y],{Ezˊ J)f:ؽqX_.fNrj,<׿={}gA3B-=\z?.¿a|Iqu{?'_ǧ)B_wSMQ ;1PMw ﮘZlOKUʠGCirk GHG?9~ endstream endobj 2501 0 obj <> stream xڽX[oH~_R2W]E&nWmm}@F6=sw[JU309߹}"B/[zC Ə=LQbo<$~JPQx[ݽ3 (~ZL7\.B]3m^ݫrKY I7Z״: 3k7ZRN_7LBDO$a%C:B fۯw&:odݠF~mP!L6V$W -+0tZHȋM,Ƿw _k&/`*W<"+cK=n|4,҅YL&ϤU- s$KkiO< FU3WDz=o b܊Cu݉%oA 'uĺ|p9)xWߣ? 1FY&&]ۣOU[^-ˌ=@?Co֚rhdrrsM*^x]U@} 3k\ yi5ؗv#YpIBF J$nVT|SկlejU*O‰)\Ҍc̶,-1?d'baS(p@j $poL)Gn҅ D8bw +boT2 mP[SAg/8 anx ʣ# <{TG*r I8jVM*&= ؑ%Ch-#X0==ƃi].UH]'N"_@$݄)m4bQ,gձDl%K ! \$I$ΝR-P֕ 9ubC%,Bq:k]/ ML 3La3A,!@[ދl;&-t?qovPϣDWفФiVoJiOm7Rw2U{]e$ Z+@7fYk~wHqe!oE/qDgd\E0--||ZC0@GJ( ѼHk=$DqiKDnEBPNlN%w\Bδ_/]7qHo!9`GZ[s0$ܡHƆ TnϾ`1rdPأε² ^ zH'}m8*y:&sC7 aA$yN y qtʘ?nyY[erMh[ 'LY&A,4nvl6Ա0 S‰&|Pt$Bh~(A߿Y` endstream endobj 2504 0 obj <> stream xWKo6W)JE)Q{shOn%냲K{hčmo!y_ma`ذ(?|M%"~qDo \h~ .S|.ZuI)%) P ZuEI&bvu)D3f4jpUXd>'H.=i/R'K? )BLR=K x}8Xq΀m?;\ /ƎJQ%@P]U*H [T鲚 U,P  H[8mχ)h|Iwۨ&a$ֽ#Y9205PO~zbcb! eY*e"W(D4w`@/I!F~l k뭾?u՜BXP5\ˆTuSD(98m NxzT*+]?u |[0X #vE\e9n{j eJ 稀2 l+,\l\ zg(<:Ե]'@7s[RpcaC/ZyjxnwBC0H| fUni]v7d|bʌ?2VnJAST)Q.4l=/Σ$V :mI/>qo"~ӴFZ7 |fSY۝vfen^{3+k=%hkȃ[FH~ŷ_ީs/eˣoZA8 >qVeï-y;"/h ;NN9vn.L5 $P?(Gnޜ~> stream xڽYmo_a_d ≤HQY`mb5r6 $'?C)K^ZNmŚ<3:,c/-w-f}`3 >5ؙ)PJK 5|6ΌYTVnn4-aN>b=!Q e*EWIx3z2@a~ć *l"ef :bW>_yȌnt6o:en!e?Mke~v}+4[vQVeuPmOڧr €].݃N]b 48ɣu_GG[dvH_<}`+Uy,Bi k FO)C#(Q}]7.^A|%-l--}0*"Ug8@BQ—$TE،Ǝ-cPv>24W3s1d7Cj<uFLv.\{~ЕY~+g$܃2*hۉz绫iY7Քᔉo_1@Uvm0Q28z[rW4@%Gh>&e1eL^8&ı㘂|4Zq.Rù\@6 dDx#R;  %*h)7չ+3[ G%\B@ݪKJR(1w;0= @)v ZoX%1f-qv 8Q6]vqq:ނ߿NsUFZG6?=t=b8a g&KcK!_r@yO'd S>]:.*ǧ,nno!CӛA9P"0g>E.]1s?< 8\{v't3ġY]CmY^]Ķ}Ij,߽Tm?! z z9S14&#KPcbo e endstream endobj 2510 0 obj <> stream xYMo6WE T%>HpQIc k^Zi-qP$eiMv=-M g̼aG)iTϣ$)&"I&ͶkխJiLғUOZ_"9hRnA!)4"+a ̆9_}{r˦Qslݖ Ff.RIcJ3V!a j "*$VP3q*ifnHHo_1%(/GQ`@R݆ʢN&Q`b~$1[}bv a$la`amD~P6~>/y B<1SYAh3D8xɑ}}z"y7葸-aʖa0)BF i*!-$V V*1Zq[tRi8'bc)eM6aZ{N_q+2d8!#D(LtLm:Qg;լ(uoټh?E}PH|E{fnEH,I=)'sB]H^6 C1${6ˮve;>v頷AGCߥ `iK TYڦוI/3$Dy(C| BtsÙX(b䄥!WaYqk1Del9n<MR&cVP4R> Q7Jv0 =xo+OMY !AӸTs㋸'{YGWCXwvJ+q?n~W}Z`> $e]u5h{Ε xCYTY f pb^jݻ\].TCy A=ť@Љ]!C]M]MPYjڹ%ebCJ(zbMP4}O-nb*(۪^/xU`lwyo wiOh ehF有NҔ[Ff=I6H~*"hŠSѽ cr.wטu>#ZxA'ݫ 'EܛpSH]=YC (m]ۃ{6@Nɐ+7l;n`26b@zav%ac^LeG7iX D!D3{4N48"1vo,{kE+5tѼ#_ '6P+^OB+0j>aK]չmٴ#J k/hbm \A qP$P~٥IϬɨL2> stream xX[o6~߯$;ei3lqAD-y6~)ґ22ls sc"a!r}^_ӈ`Dda(Yqhr1"m|wC2⢩>vnsOu}&)rMBU+{MW+(]DFs=T#(Mq?2g4{g402:qfAo2)'̂@+(cQI?%܍\)c"莟ZrB,Q&s18>aۦFy6.~b!e#ŽoA4+!/g$1(lnYkFq> stream xXKD+ThfSB*\a=^ؒ, ,R0&&$$lɛ䫷4!iIK8cH24WT1=HdΉp9Hd)r!ioMy.8b\R'H"l@-Y ~sG`bO%RZwupڷ (髦 5wyG^1!¢h%I$$W]sӲLTfӺgRT"z78:˩˹3[\{tcӆs+@ikʴv/VNEr6BCD8өmNmU`c4s L?/Y9FoT*BΪd D/UD YVu\uB}O"HנYmtn??H0( *^Pu1TKD僕eٵ~wnl5÷ ю)цD6q Uy8h?f6`K{1{(X$ WidD g0=bCl *7s }޽,°ev]cn++ NnDZfp1uXesnĐj̧ڃ uOߙ 9?`_U=fwaˤ)OC% |:'(j$6j~tzBR@Smn~\iĆ]TL( l*l(F76u3%oElxښ&vm pPQtaq|g]W  *%y:p 7#I#*ոX9R h31<N(>]WY7"la ı+Ci{޻: /0"}Sm8W#9g't73sPpXVG¸|L~o w"Nsv.#k̝NZEg[G*mٗ x"Iau ,[k7x~ޣ*:4Bm3HT x:&[46.TLXH/gd_zGc qG~Cph"آ:Y.K@W|lYJbPcb{5i`{G åSE}1S6ɟ48-vL""KYrTp=bJR1Sym!x&hi_87۠R&@FݡCQ5z:|_ZXM&vjMgO`l t*CG9+ h9TGu"=׷P}ɽD7#~(4'1:򇖻hӋķɏ_ 5 endstream endobj 2519 0 obj <> stream xڭY[۸~\DxDmآآ٧Mtd%9'ᐲCgm (j870ߔf|yNlxƪ⛇ .YaK!+K _웟MIh~۾m*4~ 4t[Q& |Ur?MӴMJ[e Yx%;^2:;gYEQtqG,IPjl%Bf )mPԾ. 5NE ˽Ly8Ū\hVd+3٤y &3,OJEY$.IeT.wi0~G f~in0zrgǨzvCT)L߸U$CȪv?u뗯_L|ڣ׉ѩO{zؖe$ɰS?݋<.R._mJxd8YS&l/`Ovg/4@Q K%~`2Z(7>n) t_V+5˄X:B)=F͓\)8X_uL^$(pjH_HE.`!~o /Y?GgbghJbYs8l`$ӹ]"i\/caR rj~&brj$tMB5\TrɊ*y ^U>ij4> *J,$PԵE -"w;^cudxW4=3,F #gYƲJ|SB*+{F_LP"*+ժ)Uǖh_%k1ժޜ~H;w*h=3ރ@Z~2i^8Ҷ 1l qJQaq0x{]Po3<\ޯ@>y ,a kL4ПYZW_Gd ] V(>ǠCu^1GdJ90UbF,>H.C$Mq?Ѽ·ͭp%-Qpu^`'X*{\/$SaKv@D̏@6`r%6hCm[zfX`;a;@Oi?&ȄLh0_@Y)rY:A罥f X~ ƛq__Tq#ew[/Qʙ7,+B7@ϨCP3@(1jE(JIKK(K /(d:0 S3BpM/uRK+aQ0PytX-R8.?,,\ym!"Gh 27KKCy$ʶD -Ok> >KVLϝp˻*R!*kƾv:Q}5P4pY>9%qQ@.cIcӷց|!`;a ܽ >zu;LJ AnfPg+q7 FNХ\ߨ㪺S͗XhkQ,e(?W}ט5VD͠aXuWLC2R/": ̰!iu U.91xy+HyOA+;JYJ֟p) Ӎj,i\ pF*zID# ;ԝ#2\Xߍ" 2;`xOִ) efqpᰵ;3TD_t'|DR<~> stream xڍXMs6WP91E V*lַ8uϧ[-0]]Iu|IxOiu:{U7-A:p_=MlEZbzЉԛ?fmvlY8P0)@;XT~(](TڃWW;b|ƃ5P2VeY4ڹMA⡵iJVU*<IȿFeX̲b:/w1]?]xI([7֝Ѣ Pw'9 }n>컬5Cc\$x\\y!Z3ѐ"7qzH&pm-O&7x T@BBAs}$7&>5rl:"'1p͋ (ڀ"k0|fgJH Xp1ZQ~u0:c>*S &g\^i}a| >P5b{t, f{,X!sI^T iO@$ GGH9p,iTa~SO; GM5m=ۗ_\h")0_IlbR5*0:O]=QoԥJ&M? *Y{A4֡Zڅ `yw*D%+Pg(f/uǛJ-5b)z9WX !#GWlsղ6@KHdޏ~"+S8AVm xU@e 8(nvZkĆвA]޲ ln@=,㐐{7^^KDo=:2,O횻‹R#&o.3+($+Sgm@ Ĩ}WNX^O4XY>^B?p)X2C(6K w4QEmfrm+F$wqpXas>vu3!_uec;7HdCiL#o3{c T{&Oȼ 540uR6hbV2tJ{QALn4="S ̗ 2f4{(VQ!/#yGaS\O SpP*%ގTŌц<:s4_O-_γ>,E#}>d$e-$P s]dy@i6˩î8FZCl*8@=˵r9=uk(p'?;\BVh6"c ffhL*';]΅t#oxzCه:\1h-G@* endstream endobj 2525 0 obj <> stream xڝWKoFW=QF澗i(Vsiz)&*qwVtP)r7KHKoHSV(c*D$%m݇MB)znnAſV=Iot( qg&pģD fMmk_*0>J+Ӎa$`w5&풶kI">콱+G2S 6gCDW;0ntFqIL4G40T4Y=ѧn!^WP.2yU}(ϣ[^!V榦_jm0&O)$DVmރQ%vFH^rp#QZ./D5T}~| bX7)/SW9Ŭ6?fJJv;ONE[MzM! "D} 0" 5MTmiZmWAO)*0t[cE| &{J1sj;=x3̼׆cjCNQ*{/y\>]ECpQ&@Ko^ nq,r(B (@B8$+.`1]dx= h%x=8ލ%T{=U{40D*3)ݓ96hl!}j R?V?.) {ڭTi*bז^~pn@OADg lG՝l4Ӣ!o6HqtB爈MOy:ĭZB]&aTof#/FB"J q_v&%ʶܙ0셬p:vf~WBPoj%YG#f Gh޴.&{p* iNX}RӖ_Ne]x?cWә4zpwNPa :#BB@ڢ/=OG%E4c5^(ʓZBD- PfdhKز n`%(m( `6ig15쮼?=:p1KÙ=\YW!ˉmE%!pI(GB]n&q$#Qize/'d'Śvs3R‘V?+sU؝טK˧RZl@Uu_-H rի\n6p.GuM^_--|E0ɴOn'#o ɻ7 ُK` u2 }ڠtc@&F6S!ĝ>a?{tAwd=qq}2f=Xwƈ@)$a2xs\b%29e!E@۲8>f& ՗`0VC lB.$21c 7C7ݱ`sհvp58 XJ@`%kĸAP_ zcUXF3Df6o( y% endstream endobj 2528 0 obj <> stream xڕVɒ6+8R!6͞p|q8|.*"S fD/|rZH8w+(-iiqMA9nES_ʏuud !Oj5·_?V5zp!nܴ"yHWk#Q,_jM`JY Bsd7縑MVQc!6);s?u{pL $Pyǜ:e-/@NI GT#D߲e{<=/ XV|.Ɋk]%A~R \ hezn,oSJq@I14PYު֞o.d\W"S.<Z^ަ4Fw30kE \}tȇr (רO SY"$IA^\ƄMːlYi2!r؟/#)5]~CRZr˃Nf==Fk\eϯp\^d )IkkӃvrH؃9'Yм#ΪiO}*blzOkFmw ضm76j67y z/ЭiA{Zl9|Vk,gl2eT0ShT.U_00X^J"?6.p6 igZS|46Cg5DaP0^,Qm6O=DĻ^Diɗ(}fnsxbq-_?`եVS,NKc7Fq endstream endobj 2531 0 obj <> stream xXےD}+\ f4y ()Agbeɑd?O\tʻ ŭZҨ/ϜÊGWdUW_ެb+h]lE9"[lEo[1ΈRƻ~vsΣ޺o~]|M"f,*{Szk5fL*h)2yфusA1XgZlbdw&s^!+҉ gHȂ"c~QB +ȺܚܗUمVF/ +S;Lgf,8<-HOUƧ9I$֧]MW%oc}rKYJtbMLRfP|'3cYoO%,n}-Me9מ|suY#JޛΫiPKATSqaι3&3uܕTMkY`eh(I;-ۯ 41X Z)cs/P.Vfe~C(" ;aXK(C l LS1Ґ ا.>h-t|L#}ԙei/CfP)_xj+yԤv-6=:]D\߆&yQo68M_M7(K/_0_Qù?G|1umpp_d X]3X҉P;xqX@wVff|I-Xz?Ml?r҂7'!PifM^w8d#{.l?NM۹{.]͋}7:Y_\Q 'PA$IrcP"VE?$C-4>cǧw/tfZ]"03.LwT]X7[+,B:lu AQ_ ,Ma7UdA\,w "y/DTvYP鬵1ΉaV8~B@Ŕ,&m!7*[dn0[ɧSKFQ~:5&`J4%RJ\3*K%.9 R ?/hdEʦsܽ~7j) C*}lu/y j'/V}y mU} ,cg#)ImAz_~B3;G8Ͻ @v*ߎ K*˿Wp!ZP}X) b˜Ԏz Jin.6)D$z0A324aÆUw`ҾFDo[S-n /}ⲚO&,U4PŒ%inO-188rGצ+ =m^-'86`~no_բϘhñt˱p"wWa;D˦b m |ra_G5 벐PL!FH\~tͱ->ow vJH&6NCx#Ԑt״92,]؜:ӷ!0Eg,Qf0Zg!W7  '=qt| EsO9j,d$cZ43ކIA$zm%OxDH6 ȱS)2BE&'2eZQPEh_ gOpuè.dp6\6fg !< endstream endobj 2534 0 obj <> stream xZKWH1=OU!.MKb( ZE\U%)`0 ]hzlAsR]<<-YPN aO˟屯U9_2~ !*ÿJuq}*.Y(e0VTlͺkÆZ.?}|+]=_dLш/pXզj֕u׿)C6a $G` #*|KRO_3)w>)N Q)8^u>,ySH[?+I±G*n%ee AZ5Ge٤6eHé?z4]tNLN/zbzr[]%PV3u]ƑR[=q=jImb$؈)` tP>eKr$2)2DŲߖZʾw!|$JCh9mm3"XX;DoNи ;q1K ܜ# 6- n6Ծ{ԑjc2_~^(SqJtqS>Jw 6䮂pf\aj;&5f2#7.%D+ٜ}+H}L6[ڐ+Ւh<@kBy^֢Xڹ`/ _Ǐ0U/+&|thq]HB(}V 8%y ɐǻjYlVPy2hxWP5%0> Am5ڜ"0)1ym ?풴Zq[jPGEpm sN9^a:nyEx/ F}>\wNQJyC58;@ v. !Th5ю`bws )BϥY8K OӘrI#T=wjh-bzdR57rl..b4s  lvx`z(IȧP Q|dVJ-MoY"'b*ܷm<[)֋;dRB E4} 6ݯ+m ҆rš%~Aa?cQ6>m7/~\lL[,7dW3[1uYsp3=*etq6-X4 7-7[RRb=qjn (/[Xk IjnGrȎLM`?Jio;bJNZd6:<9cD27}9q/HDH ?Z!a0*Mt;|#KB.<%vhΑܙ"38D>um ,:DMےg(F+'+{?Inb=d@՝r>4/KgX:8K;-bܴmrDAh@!s*F{XU??C勚Kc E$pY")I>M[/> stream xYݏ6B6&{ǡCbЇ4^Ֆ6|i %/u&i|r7]! D$:+^{(/bk~sB*ɜS6xzZmMhM{8 uD߶tZUO{8FқF iI$S덱rUMCw?wfCׇDԬ. MĔY9襙KJo^厵Z6,sJ0hBRٸUfZ.K}N+ I?8E_qiQa鰺Cg\9)OSDU̩u̙f$Sb&)]݇^3=^7[G11sb\Z0bˆ*^P]VyGh < ʬm3 @.;ѝ_(mDxB [w4{83%7 漚ePi$/N!Ͷ"Ix `n2CzF9$U )-u ./'WmY !Puڱİrcw dQ3iv a3ÎיB. U݋?^厒 _+8\UuQ$4/I$?4TIS_ MPzl' 9t]# ؗҗLW%H< ʌCc B+¶)rFYHİS gZ=%+Rcbtr*'u)Z &!.(K\ɬ~QYW__kJ(Qv0-46U9+Jo{l@Yu8mRE(-/ QRrlHf3%Gy)+Y k cV>>< =jSTqE1E7@)7KBC?c,@PM=M%c&f9 ,v>6[p`)w!iXf,:8| u"R+?f,4IBsх|tS?pE1~z9mgge/ IeA93_2i gF}; ;;sLaKnNiVL8=mh ~;GzƞAbu*a=|淴@#Ģ^+8Xg]ݞΟ"4Q%@J7+RRO6+G# 7: <hirT)?haoQ`:h}?n7˺FT?04ItY"pjb miDםm$$~F̼oU2?&n),³9/- endstream endobj 2540 0 obj <> stream xY[F~Kdi#C6fcT308vJ0 ;߄$DQ.>y&# I:_?o7S[c,"㜧}ŇNL\^s➾zG RЬ[q4noMuNIF|dd/GӠZc«b%’eLFvup&>Ha,| $!73-xUiQy$v"S A}&V8hf#'%%AR~7*ҐJycw^d< Eжt{Ш~7lp,zgxuh5ctrLs# }u4}+,yyJՖGM#R 'm(C lmжZǡT(TnZ0wo9P.N<`  %zR=~;>G更2=vӷ3栁k k~1CŽEmk>>(ȐE)FLw y}X }/Qh=Ůą-i0`~F'@ƍ]xg>^, ?zrXNJ{ M2o|z[0}dH*KHa٨6j &Pnފq C~,p" N՚Q6y}6$Oӹ-?새lDgDgu,;?OS>{_Z}]t> d*m~+rXu`ք9yS?o-|vWlfԤ=D ePC 1t—;5y_3``ziv}A"l9E-“:0r4)(Va"HNEq%q]Yf<Ġv33;b-Zop{ Dٞ>=˨%9ļ'đ8 nGx~N!+0;TQ渄Rz\¼͏t`Na6 F ayBxi>M698RAYo7ڀm\2s(b耶yeݔsm ň`qR+=eWᴜNC;52t2H " 5ry-)u;ykO9rm%@O5|Dߑ~O?& endstream endobj 2543 0 obj <> stream xWKoFW9QFwO2 MR(v{s`V">(;]\e%Ky496DZ㛙of7 MD1':,y%49JN(ǹ<Ղ-^0ΰR>}yqӢZ^nEcng1^kS-J;+ :(#{PF-HXSau"H^67$*qn_Gfyji.YƤ eL„+|]>8dPoK1sa.ZF3\gUzզ8H&*}!v)3,s¼e#"c pߢeEAB sfb $3:(`i m ]YW2EWd^kpp!ijɗbDJҾq K%h:vm*cE/+~^~*T\)ɰ\rms,q1c:& -g>-y>m-Esv]G_޴ ݡnac]D2 EB-lpL 4( yœ`.#jWRE %rnB~3^6f()lȊ IZǎ$֘o68]ӛ0!Q^EsWD^Z;(ѰdNg^ jA ۡ$ƾr:4ek<%xBXqX@V[I`RDk >$xSoT>8zV|齕*̲{Y7}Y3LՊ$IeҍH'S' \<5@[6k8\$$2vؙf]V .딂 S>:B.R𰬮bIX'Ж80!9}k$ ~ށ(#PQCͷx@aBd^vX#nqa1.G5v^g6L> stream xXIoFW9QA8ᛕL Y%΁ TQE{,Eei Pѐ[}T{I Q$//oi9)˛)y\.ߥV~1R <06O A$(/8sOeB3,xI n"T+OF'j?G~}W &+r$ IJ/A\-D9/ YE$YS<}t fӌ憵ۙpq3Z}_~ l8DdA'ZoMӵVscv}0<{dB p^z#54^ ^W_gqk'f@T!n갓奈p`U)npљ1VPR"i^7~T4&(m .Ǥp!$%2$Bk롛&mS8 wR_[IF$b)T6azյ6O1݄o6fד(QBa]vTwUG%W2iNV2gmsͥmpV~32g\_G B+?CWQ&dۡ'k=}9mv};<&M1i8`_f>3YcOX cey&%muMaDY=(y2l'uH|Ӭ߽`K/`g:Vr`ducgVK8 YYLT:0pceW5G>EHpYU*ci.2:Fr2L=2Ŕ}G/&h9Ƥ͛n#O7H:ezoPEat¼yn7 $vQ{==*L1e@^^Tl*9I/1#/\aK4Щmù:EFTy9֓/StUo$)8|!^UN~]2{tfA,2n;4Sjs8X endstream endobj 2549 0 obj <> stream xXnF}W}hpo\yJ;HQh()cB i7R,^_7*՚?μ}U"n+a>JY  i]n# {%)J P?>8auJa{ʾjZ[v8_.m̛# ;,օ\;/k(;tV;A\fy^uUOɪ눀LvFuo^"|LU NGƤmL:yf~Z7: s [VGg"$tV9B("f;EӨ`Ợrߜnf]mlm[#Ewa4[/0FI"l^qJ94A}oUˆ+NQ8¢$ؑ%_0Nӽ^"@AW> stream xX[o6~߯2XIa@%@]P8KզJE/%v!(G&o`!&&y~MQsܬPur|Pl;2XJ,㜧1Ŧp"dZ{ͅ{Zfc$s ii9RJ%c>U'Kd]Y?A{7QDN/갴`գ9*Xs`D,D1,g.rەuuyc~X{`ٛUi*tk*+c<\_4]5&  "k,.b {sIF)E9B_U-^[P[LCquMJށr SlB`Ç7dvS7- x2b׌`,9lr8&唇o6? UX6 8T .AǓ\<GdgD"IxO.Wvm!$e8TMr6}WvY5U*a3A9m@:fVg#! c /ec/]uKohfc.awU[$3ǹBL$hSvƙ&~‡ϯ48 e>l zvq /91Uî{nUl>/GO>qj͒Je4=!9'a#eIrT/Gگb^v¾8kz&=}c$&eJHHHi9a`[,10)H նĪ’"w)JhE䡄o QcJ/@)yK (F0~b|jYNg1Tp,lmc)%#(*9)ʪ߲M!r8g#,5"{piU:k@}v|n[BnaPM%EFx|vy3܅h)đ#a%+vh\LH9N_;!c @A39 ~@; a%{á1jx}=D:pRĨѢJﬣEq~AH2uۆqp1,~-Ɍkۦ87N&|UB7Wo` fWb4\#M~֨CK:o>QFqDNgdC$|=q ̧wnlsCP?B\',]# /}):7Z&yCd endstream endobj 2555 0 obj <> stream xZݏ_BV)2E殸 ܶ}܃'K>I"|$ڵE1עo~3t>I /O䛗$9R}e)RL&7dbo ͷ&esO7K߷Upn2"q )J%6尶Y:WɘB3jAF?ϓ HPj_nqʽ(swTNϽsWZLPTM&;x$)vc;!1¼f`r0Æ穎I:w+P&~(O3 FQ ՇjvVy] |_b׏6<'&iƺ rd) u~lau79'|̭QSDH1P\v9Z$iq,GX^w,dq>XڹqM(O.E5̅:L$lԘe~2)cfmg _1nU`(\=Ş1GSQvMI:\l 8Y@̶̧is$CNJ%uC]a):c̖v<փ+3ET) L\ʝnGM'GrP`(~b)/hvu_=]vG֒ vha]A)bd vc5< ˺2Q<80<}vG}ֺ@!NjQZ[؝B Z6C<tu_P*$}'mm̆3"kvUwZܹ9tW۲s9*_֝{q'>Uc\UNvJc! X[ hrcfKrw0ɗ(j|OBnx8ԕ=,+ҀJu KI(E#Z`[]YCh*`~J?v0 _D< ;-33prc Z-X ?81Ym>1Q@z!gid( :yT5:< v:b:b<_!Bce/83oe|tFxBʙQW)@Ŝc+j*ߣu2)m#Gl}H$u\'Q$/ P6 wo25:L]%HCVOlj-`lM"`"|":6Vϵ0~FƋ7Qr'w܎?kI(ti߆"+1>ebхdಮ <ωy{lwvq- tp¬lmעUAtB]YVe 0Nލ?C}2JS潿Y0 ]js%7f'!;tB Niί/:qp)>qғK-oLㅟe1CuDݠml7GS59<=_8in;pR}jܛn[~̊״ 輠 FQ Ulg-ydCΖrt() azp!- endstream endobj 2558 0 obj <> stream xYK6ڰ)@AC&M7{ZDR۞ oO!Ԧ%{ġbz)%#) pee_HcMuFʌ0yݭ~ʿTOic,[Swe$t5* w/Kk,- 4ĭVrAUڰ`"51q+Bɼگ^]Ukxv0 :?7ُ6%ʟVf vUa٨3j0&xޝԫiY H(PkM $$eHQ|vOpׯ 6#A-?OXͮ?. A9/:;'-qN?p/N؉dr|ݴ~p|1Uܑ_\^[Rۿ\}T06cq!# HREe^} H2;1af;+4A8ॅw_=l@JW)vIˮ]+$ǒ"|=Ctz_mIr p$y{]Ce':Јv Y7´SRi*šc+}{0IGjVPS DLANG+A @ķ~7w/VyF =W;h+HP !$˖:diyrF'^ W<0A^?a|[jF?8`m^dz\QU.-*ijHʉJ%(dCyIRpڜݤ ~ 6HcKŔ&RrVNqsm$H⯇uQs3á<g.*;ukBߘdAGeX[ǡ,gjme[PwM!!Wxi[}w<>uܒKhQI"D6M=l)\1a&oTBm-\n̴M+{d7 7+M |4&)qLoRGlzvŤO; 5TSwNҚoί7h\N8%kk {49m 8Dtͱἠ2 :D)WG?\eتGG C7ݦ0CtK-ٳ gq+?ԚusѢ Yqd'Ʈa;8i)MUѫvprg)9\HE>̘O8˽3X-Vm?6#o}6 (3I_!VC'bWoE\X ;PH&MϐݪCgBsg8lQƎujQղJ9 ֈ$[úLڇ%IQzTfP_~kTHWc ^hĦl(?bHݔ>JJWe>y\#vxT,[?>u{&j<=,᱑&8̽|?70ߏ endstream endobj 2561 0 obj <> stream xY[6~﯈ZʠoI R%(B+!;II\hQ{/$Yf 59>\ pR`^HgH,ܼ3\JPRx[>9x(a^mz+fˢ=g*"YZ44Շ a(LuUݭ"N8,׻םlfg}R\S3 O dۺuZ*_qa(~, |nᘉ𛫫ؼ+Vĭ+(eV>ꄂPVFc Fid,rc*A/) ~xȾWZI 5}v`DEu 2g> JxU^FEPlO#pD ky(.F$r[qhgD`4<Зw"x08'81h'q%A%iƵސb607kD+ح2G;ih72ߜ>+AH6^5_@,GI:kz飃ܝ:x8, k9>҇Thw."QD ʍ)C<^Hilkd;/ 6WG%(vV(K=Z#Vh7FhgtDgtL`q1XMʷVtQK1uQRy/wMhnca9EBHop9AɰB^ Td0qIr'i7!aզnl";mzWkU5-6-n`& X G0"P+@٘Kvfr+AC_8jԘ/ưʓ`!bW1jWO6*5x<t1q4[:USJW_$Ӣ !ٴ`o)ͱN3e478ZpΤtPޢl!4U@Կ*j/D# i6re7 +)Ttx6 Jč0VbVQs'xنܫ|#+e}1)*o#4Iy>5_YZ$M&y\Dw8|׿ړ(v4UEUEUEBTO愎qstyLFdm^^CаN*B.jԣi(u{.0yԑvp2kc#Nݙ;!Fcg]7ΘWlj7]9Y8hd7H~~ᶩޤ$J̔˸͵eNtsL !nW< ̯KA68[j[Bozn)Y ~WGj6ռ< }zKf_lfC1q=0@ň0,/K5uc<v1ف# 6^Ynm6,y81&"*8-{dF\$ƙ9ȅpOէMfۂD OǕ ǕN˸g^P$''!@21 4b$"Ex?VeU6J!z#*o[ĪgCw{nWwyT]YTpxǎ80ȷ}(QGU$O)(&H-u3gvrjkp%!̕~mm-Œ[}ZphO)ȾB}-{՟ endstream endobj 2564 0 obj <> stream xڽX[o6~߯6`o-: {LLLRIo9$%K)s[!MKw}h4ZhJ"yD9)D-7㟶UE9}Hyr->,$(gg|*K % 9v*)d-ۤnmY_%d3 HAŘœݴ2ysx[9Jj߿xH$Uw45>S}VaCejtnz7hi۝^[,iaVjnꮩ4$QLyP Z$4 ^/_~ [)ѳ}Z z8~ [Yoo>ջ8k>~S? d~4'\H?eH& TCO`IƐ-T bLAP3ڙvJ)+~ܯS" ܪ']TĺI@9;iHdFlUbQ?&N?hY9M9ۍz|sJYe$1i,.U`XQ4>]F""BE@*NEEF8=>]Jyr>(,}۹AȊ>zE/$n[;j` R!L}!1W1 o@ l0B:PwA 6M(Ѩݽ3*6W8θJ|FZ:fچ F#i왐0 HVu!d! Y!n4؛C#n y (R| *֟V#+; F]U , |,a+,Rn10o(W66MyzlR$ kjRmznn,N ݠt_UZYˋf;{]#J@ b6(8lh浩qʦn7uiuok`m*;ԗf\*f) Ԍ!-j KIPVw5\lQpH5 Rt4ďеB::p|E(w.ёB,BH1eGKT@e`%0nVPU@?y~VrY?MѶCQ pP*Ĭ<{8,8K1P~8)~P{g_+>ٻ˴|;pV2bHq{XѶMQ e#!GV7W[(Rp~=$ʁ 5p7e L)|=|H/ K6Nh 4Aςgݭ[c3!Ds93I2TP,i|[ h`G2섃Hy $!C TcJLzp5;SAœ0wAӏ6AhqZ`9kl 2 VoFԣ}p(o o,)*/we\ [7ҀQwfS t&u3xta \o-e벶_8>'7@ //!O2̙/|\/r<z?= 'F$)Xp)X|xǂVU> stream xڭX[o6~߯02`ݚ`>4}P$&&jID7 Cʱ2qEDQ~;/"t3-vj8=c 2+bułrRbj'̖V.g$9v/߾Y|'~۶X$q?˔Ikudyb3~:%THYdX,ʰf0VLw O~8=oNL5cDqR)B˘B8j?@ĕYOExF  r$Y\/Ʈ~g;)'iN Xw7 sNīAtc:_F+'E~XKu%p .MoMx.庶a묖\Dr ZH޳]0*+4ODVPmAsCo/.De_pAcσL3JaP,uI%ȥٲv3wI)^<`"WPJC,"']?a2"WRBIu:\i 9WΠBzeyOh^lõo&vĈ _.fwA0$MO;a@ӻ"/=wµkTi.5CSEPL#buK8MȄʫ(Y# w\uR /VZ Q_1 wڅF8?pu7K~靑@'wpl݈Nyhµt}"pG{:bbKUXq(Bc$+T gq$CY8[ =6̏ځ=M6˦pN@Í*<*?6͋C,gW70!}g| ?NyGܒ΁âM0_=-Nº7[kzg V-`Zc8E;c0{<@А]9=̀U@^b:O\T6nTI \WS Hti!c" s7knLm/|v> stream xXnF}W.P;<HH(,M-"T\Ҥ7ذW37_`!AL&x ^() IPʓ`Y\oٶW"bZDoU_NL^?<8H)J7/? _4 e}cv|ϧspB112E2J}:khAL Ś֧p> 5>#ּlʾbfUeV}-{<(rC(2\~+@Cݩ/;U8AP:kLXXxMQ$Ai7='34`6` mد^xx.v+Zvq][~l3Z󴛎X"O ʫ5Ll:e۬)a3P68#2N¢Xg]dNFS7Nn.5(3Bf;6!(V wX՝|&\HG1hȘ@)3DYۗ3f^ O~S>!I ۟WkIwWǂ[;;XV贈AڲIm^rlzHX;dKX{[먬>nM\s+`B ܫV $!{/(B"q0sVN^F<(B<<']ꫪNJS>nMOs{P,ٙ~ZD4V ؿl|wQwGr[! @$f SO zH ֍}seK]!y(wj]vJFxkܨLm|,u [ۨP# nnֵd:jw-Ykq }* qe l!Dxj0}Q6%C-xŠP7Y(AEmk60"խYޗM}+sb9{X+&P(VUy͂Pfҡ7 >m8|v!͹άhovFB=jl Lij7]qq}7C/#h5\L-!>zt 󇍖j`I- fV" Օ7u7^I&c_,PٮxUv>[b% q͡v;|E4p 5{JUΦ!xl( Lz6LIP"^ /Xs8lZ M2>d/3%p`aF8|7563oF7+cžcV?6˕_(0B0 Fj&gu\:1-_,M endstream endobj 2573 0 obj <> stream xY[6~0򰐃]d6Y(ݗLQז'KsHJ<)l5uxx` ?lQpn|(Բf̂ bY\_gF囫\pRƻO_z̅YYſ_'\|5^Ǫ w/sna%/K9([.0zU(d2V]7th!kW..REe4c]vRr-QE|jE`Ѻ[Ak%F Iߥ{]oe.zt][eoR101;\J[/۔m&E+[,% I[TStxVdX*}I +կn[~mf Bu!YB~gdh[RAw{Aj6P^:e:uMYW09)ܜ&5ꟗ8r&# ̈́ 096RˉZ3Ql@`7% 0=\Vwy6xF8-L+/-b8xi/$I˹哎kWM;9/&ĉlwI H?T "&F}ݖ]q 9Ya `&s6,L wu ] 6- ' q޽$we>./E!Әb8 "#*[RY}aqxãAvxkkY5ֽ%]%Nna6},%Cj >1?jWmfC,<{&;䝁:>@mD.I4٘llls:ak]|B6iY՚}2L$c_&acVIv- 'Ƶ` =˸n T>ܪ8eC=}aN+$GӞVG).)'d  b^"bOL5>Da|}N(~D; 3~pBzgі[Жshkr`C3HL& ^wHpOѼ_qtqu@%310>M;S냭ei(p lٓ 7;4uce{HuQ7MjCg> stream xX[k8~_aP]0̑S3-brf~UJ$13k_]昪ՠ `뻳3M5ʓ ]~uխ ʩ4&R ! ` fu&((j.ɲ4+|]P w^JO$fEv V[˧k@)NJz)˶{s|Ie&%C$+ *e쒲@d69O>D8QJDu%Es&ڵt:t`镙PSv'Ezg*Ս;ܸmFjgT׵[k[y!p̭->̱o1`H3}?pyǤn%xOŖN6ϕ4zۑ@b@7"Zi4XD(i_DŽH؏{NmW*&K~vGCMeö3vPMD`: f]7v= xshV:;{涫iG(!0k IEq'CښCǷNO:ϷXlA;eu>^>Frp`6]\Bhy־X+G}N&X Rf" %ܸ,"@7#vKNtu[ƙHf4[> ^>o# E3HN5 ӡ2o0|>1[&ԇ|`.DMa3ȴ 3r}g߮)X]6Vs̲k^ 3L}QKNXA,('>儴1`$va&[ 6l~e:/?%&j>zemoIBKˌsBQzȂX; HjDs(hd)C#iXKc2r ZʣJy{xzA=cץTw Ig?vկڤܲ"=Մ1ZM߃O}su+5úfK핝kԭVuunn54cjNjz9)~Cj# >@9\~73sI#D7߶ݮ?\&w~UEsV0)e1>8@<Ɍ͒\&c)Mh fKwX )ct|ձ^Gω]jQon:ڂC?ppyR"ߧ=yG$*2o&H &g1I6?1'E{LYc{Ȱα endstream endobj 2579 0 obj <> stream xZmo8~Boo{b}JADXYr%iohʥl!L g%$(i&N~|j\'4O('ZfKG8#Jqkջs(?vmůUlL-o) KA6^RVB #};n&+HƹYUCtk'ׂHSGc0]?tUPj[ەþk*p-ܲ͘"4%*kI a)7BL`ضT*@ gD YMP4#Z%nW,jvjd)v6&vј8y3.6Pm%HxA]6ã}ְVvXtq<WK1AgNw2>Kӗz׵t걦 Cʟ8ȅ$:pFȌt 8l1bˏY+y|oC6wP \<[D|QăAobĬ /|Wlc4=vTFC,'N2"10P:!;\FR)dv& U<єs)*~25ĈY.WJ/%l)%YO,)ьF%5Uۃd}YJXO`+zt9$ϥ~=56Q0<`T)?쫇ڮG1"Uy6M(8}>ݷ]Ld\$$gi}ÚLk$VLN5pazwl+jc \x.%G"|je7գj!o 0@xƎZ7P^~Z\]< -XEZϥV"$?J'`hޯiBU1CB]CSz%,}8 |}SݦT}m B@CN#+wu6@ (2!˺zbg4xQr6FLg'x4嘅-،Ӱp#9^B@Ty7;(J\QI$)\wߵؾ2{|'l+A %@FVw8=uvglB~^} fT]a +>MX0^!id9m`+WN_nEXn"CVt3"` `5ěIP T\~ U6cQƐ i2$ّ5)Uۙ >7<]Yjun-$ҿ]ԫѻ,~=I']ŧZ%?2/>Ha;#6u1ض$v(wXTX ]47$#Jkl1|Ӭ UAW;8J?ծX^QG&wD$eaNSNz$E]*a9 D"֚;: :"š\mCBt]vj8qr} ²|dad-20ivK,Kzs 6/i @v<%ӿBam7܅юP\S4Đ@f|a( Ƴ2$Gs<,4eEL4e|vWhpxi[5m><9p⡌ P0q5?z٫nT}U$ƽDv+ cbN!i%Uh.ٱT.TwsSu<S endstream endobj 2582 0 obj <> stream xڽZ[۶~0p +ީ<'y(E-jK$'Y?Ë(K )DSù~3 Wbٯw-YEW7+V}cut)9c,{7tۛV s$fܾ-6d j㪜Hafگg1*>v!l{񨛍g< E< uoY͚l7οj̕dC к5Z u[5Q>jAoc U1s^0ǖ׶<@xG^7CJl *# ئrkwwߵ&"Э9δڧ`?ƽ|@) jAަ6-1rtgvOX FF6_ dvw;5ٓy:72<۷Zlj 2sjiA3K qz+ciyVƯ=vݩ=u.@_~%V~8W7N W'|2ɳz_~pmw /T[0/30,(xZu O$Rp!8lojd⨔'ёS ~:y@Phv(A8QFEIL C:#/\\sG("yl}l6mn=]IGFB0JrVV✸>%]A!ʠƪfҀnD:E3@-#aY{sBas $(l Rr\``QyVNWm(p0&##%y xs[+'聳+' &&$wF{ٺ % w}TM}r+'nĿ>A`Jd7 m}u {9`THqN7l\Su:APIjL5 1N6$i]2_9tpӘF[@cF uA$G$.˲b9#3>jIτLBׁcfV [(Db3L6|,L$ĸcCZ,G%fVB^){-x{mQ(ʠ=?7mZoT:YPgDΜójx׶}n}y@Ͷ궹F ʑ;LkH; T.ι+W J,x>PҦc|fJAQ!:5,{IWd97e8f 1ݧ˨ oh_ɐ4=̾mv Żz8R*1=X50ɴDZ;t,檻tpW%(b@[&O)SaU. y\'( xe% #f^dAƤwnF55=q1S0~#fAJo `0|Ahq V(A4m7o:PJ`]AB>ߵۚ"j}mM["G`2I/^S;n{zHbI1^ҽDEh:L e5%" 2g]xV5I9h3юpI KFa yKԐ2 vi=ɥ85  H$bv:|[i}Jš{;6cxs8OuҒXMgkᛤyfVt^h_ېrfL6jliFDNwc{k?;c)Ef}ݴZP=fX@XdsǴ^%;I+!PH)Ȓ2+-cb#^iygْY{ f\p\R_IQqřآ8:oN{!*VqՇ (cDϻdwa?³y<ϻ05.ͻ8y>9d0yvӼq򸋅~>up~f]RHq%BFWn;Lc';0΁g XgLrqe3&.1YbnʌVGs'1͝{,Bl$s'! n;WPT Gc8mjdNlo_:7u:_@FCԤi: 7u2̓W @*DB)3̀x4s#\ endstream endobj 2585 0 obj <> stream xXKo6W,.`1K|6qѠmq.wM@+mh?×,)w(Y.~_E BK⛛ŋ+)/n ,Rl͂PY|{*.j{{<=W*!rZW$IY~DkA`PrPU{q-"eZIm׬8^*_'Sr1$Ei$&eѶ˵.:bݽa~6ŬT150if qRU;8#"H.JNa"bH Qו3hSljYPevS/Tʁ# ^C#ń2 >^U^ Wٔ3 ^ai1n?]^|S c|%)|_{0p g3iFFZF$'R9ZY-JWkufq^w9)Mp/OR&(kټCN)"vĝcuܐ>= y`bF=Xs9J_m=:{<Ѻipv_mQGLPc"wnPTLnfg*IS:eAgbl@92>#12^֭vkwW+c> %ChpMY l3(Hl66gJ){w_ [I{ޯcv9IfYmv춅xEG4+h9֕Ƨ 02A, dgG=}uQtqm D4ctF=|LA2c*G4G*#hw&| S;bNUʂ(_vg`\: F!h\GG'ZÞkV(8J}Q| \M4+SJewg.v}IJ& hUL)" UyٸoyRy BD-&YL}πlx,x bkΡfi>\}<)r?s><>0OЗ>2Og|n*H~~.c19\?PqR@ҺOHp;iϭP R"3-LCaI+P.eHVߕvbb0 m32 4C}r9%_QVvnݺ&oV5ۺۻ#xk kۗǕ$6`Z3MEƵ^FGp庛^kA9CC36Ϋ8%"R|ʰ:Af$-". Ψ+w «6;7ksPmi%%qs=́e#HcJ{JGl05 O_3G endstream endobj 2588 0 obj <> stream xڭXYoF~ ڇpͽx8OI)m-,¥bwvgI2&Ha\17,g| X Q,Y`X0A3!o{ݭB!vJ)yeV $S41ȵSPF3LŻU*HxInlW ykěrE$ym=W X8*~<~H3T ~W}A\;J7 Q Q?# 2j9K]?ASO<84^ʌ˒w #?39B`NQJ^QJ} ;n 07wc(i4cwξOb>P`M$$lBX zGnHq|go5O&df΢d,.OɄEK_O>@l3[09E8&@6{+QR PWT$6K!~^7*{ÿ\rǞN5h1˼vPƽig(AͻP[}cۖٚ7.8f=Ol\St(k AZmʱi=C+PnLbGٷҵ+)ˣņe%CGysa>:Ŧob3 >g+rOq<7>d4<;]Lq1`~ӿ} endstream endobj 2591 0 obj <> stream xZm۸_aC!O|ဴw9\Q($VkK>IM;䐴Pݠ/HH>^Jqf:7ըݦUkWJk5DR ƕf=;іCǬB&ĩVױDNz6+{iӽnG0d<9V`EIh?]<(A:t/wWxN_50M{L+RԌ})$/PI0pM wE  +%v(R|g oQ?Jǽ ɮ2k;k5a6q s/z}65Qɠ>vql7]_2C5Df3_.L}ܘ ۼm7_i\AUp1T5﭅lџ*cE;|jmeDhڢDHI2 >i{:ٕ>&#/cG.v3!m"P} PQ9G-EDJ2q3ZLq״i\lL":-2Lz'So6?D1BG}$% 'mn$>k6h>V"Y/nn1!0uoÇ#ChN$*N) Wec>\~?:B /p/flMhhMJƙ̖!-؅ \ 0 2ȐX{f|4 N~ixvJsCF"p KîGڈʜ;<7Gz1z=#EwR-:7VYci5n~Ҝo/<9Q̣":\ tOxd\>p"2Q)Pm|fZ(R9yE ֘`Tӄe\hJJ#* 7lB17dmVɒ z2³Sue Hgªŝ=E˔ *E5.`RN0*flf6JPDryg*\RݲguA[VC}X[h)\Za!zc TlftF(YP|M.H|Qd{` o͠6@!!">ј}I<1(₇pu-5;TM4zJ6G˲9;k</ L]t&"ց=)ă>&B)rz'w:J!Bv(xUkYCXqC %[?9EEaT.Gm2=gf<%1t:)+&j\g13wAKn{^CfʆLUdȊ#> ɐȀL+hOwK)[ 98ωwIB])̯mdLGdv٦S3`ǺC .kOsmO(KK#%ͯ19ac˾H@ oϑg^'U5Z %`mC|ټ, X ܗ7@(Cڵ.2p͜YL7Mke&ˉ޼㨱= FM$ J%6Ŀ`C^ wzQuCZiFĈ&V:9ܞ,i  m%g%E}a/#rSq:QLA6X\^܍Bw۶{ɧQ8,<)΋8Wrt< ꫬ]YU?BAce;ft-Ju͢Ω4eTf㵺DAYQ&X s _[~]7/*g3{|cT_)B;Ul?<Pl`'#A |%PE$eQ@rt"g!Ŗ /t4y(@AO)oZ>~Xȓy1D] *ܿ*E6J5@{hfе= 4b<ԄlDrLMuj[' #\6IB.՘Шu6R\F`9jC<3??qU;rX1꺃땷{ʉ@3x"ja^Ns5u=~i4Av< endstream endobj 2594 0 obj <> stream xڵZ[o~0d7Tv[ѼuJ,-y%y2)(c\sW؊?j{\ib`3+&H!i/4T&B9{dR?*_O[I%M^џ񦙤CA vnMU5U?~g$iED"2 틟.R,,xR; I4a h-p?T$% -pOɣڔq86%,bR]RIݧX00zH $b~I)qִ*PMR<9)Hib3%QJ20D{tNZ8_iN \`u$FPF=߫֠`*/)K=SؕF(*ǍgA)a8j9]ȻCbutX3.պ &M M)[MU*I <X"Q_|m_5)IrC?k7$vSQ$}a| IY@ (;)Kt䁍 7L3U=A^Ls]ׯM9ay`dž\ \ 62O+0s]lXl0<&HYZRh4ILN "/B^ uzGLp)ED֙DH mWТSgSX\Ӟ6*i\Gu֍^źsKRLBhKV=̹E9Ѡ-nueLEH2n q*Ĉ|d>6>@y,U6c<7PPϙǤ4OfAgVx:Tc<)'~6i X۹l4ᳫkSr[hyͼJS;#c.!"M=#wwylٷj[^ʾmgGO+( =iVW:1g_u)-_6f#RD# v-&ۢ+J8k>y?:ֿo"Xq^mz{@Q^ g'9tn^at'Tc Ȑ׽Gu!MM"?߹ n Ce 2bAdB-Q!0>ʀj-ׄku2:KCgI3"OgK2!Bfj,:j E[3 $v[ [кb\ }p@}_?&UBWq"B㾤ƣ.)΁͝ {})1 AE &8}:,`\a`YTVJ7]ͷrNLC~<D%0ŽG uܓ0P~͊o]sMzH 63 <[Qj_1s`AO xf\q,6b1uCҳV@naY] ACT̻^PZ]\lGqIh+uz RV,VWz:տ( ,5v}yXR%W~H,ieI82_7Aʰ  "fiEmM`ξTN=5֮M7vZqs )B:;R:`iqk(Z;LY^sp3?)qȕx#w>!F oT>?>)!ĕV{e:T_GM endstream endobj 2597 0 obj <> stream xYKܸW-`)R$7A&!AbO f%dz>U,RnAN&EbꫯJwl?S =vLXw?]wzw-Efxuw)rWVbuʔ i&^zVgD*+wY37hR~ni'̙8Y7dMcGНn<ڞnks'ups싓.$NObm5:ޝTbuvNk{;=Y4}'\ǤD=`Kz^8iΏf\.(2wKd{ɎhZ*T|BOe|vr3t`ǨҾ`K-+O`E}f; ƉU g_c Ş^q29uuƅSVd8 {dH~<.X&Xc y8 ILftX]VaYyݖ ml%Ķh8iEEcR['muAa~X^C4W N5I1o0X)w>5ˏ}e2:՝ +<,[tnh҈KI\K*#SӶNLWH`Hu&qz>=@ح_}u~J~{S'//;Dw07U}U϶74'$9Ba1ZMf8vS}p|.]z腶hN1v?᰽[HJ={ S7*VS%dje<-He`dZ-.];.Kqe`kRr;YioZ٢wO.WPU`#O%LiV&qӥqd|!;;`>sή)_ΦLh#޾koqЩviO.r9@ wPhv̒`Kn K(hQ(,2Q%y"\?_$<À9`i}ƁC̶!/QѸAP $eԴ#FDe*DoUB a(|IY)n\Æe_sD.Q Ԇ adZdk#BY+>3 __8J !ƅPyow_@W~)l)6*cO-]mGo%~2!3v!X)fKt{;Y z !s]ފNoxC ?L3 Q)G5X"ƌٕ& ,˽ST,UljQɶ,DfWYY&~)9'dܧYx kl"땳S4G|.ȕ6?I _K:Bpf:녓UQL/r" v>,\s)x;W=lnF=86vކr^TR[- W׍Ϲ"B%~cR2 ̅7X,bS kq `8NFd~RQ :9t$ 4y\郮,YD-Vኒ+rŴ/t._Z0t#*l?Bbt>\,ɖ:"J$YzBQ LL{t'$7=FWMvNuZLQ"f{{O>Zn2>r<<\M\.!w6G[5ɹ¤> stream xڽZmoF~}8 Yr_Hp@:kFZZ[JLRutfvv)Rl  *rܝgfY:X,%||{|,$gmq.jkvYl:̢4MCf"SoW?X bv4IEgL؇oh넉yQ,YhGE0+әkzԘXwu]w3C0׵]hQ.f);+7P[x"$aVzz= q)cD,\Gf* nEW umGvWP*;i̪"[!Z0EdTcx0"悻 jaTjb5D17Z .nƯ?3B:rf:Rxη<)&5R/S(}BO3\+vDB 8RvbY̽LE,9iky2}09U^ݘԪRx˟-¸ 6M}cgS6`L^uOKЎϷŠ>t\+ q|y x3zk{/{z:\pLco[D¿l }z6e$K9{\}͏Ζvcߝ||ʁL<^rn"{jo|ŧW>2=~Y]9/J2W|mq ğe4xD:1?2˃`H* ~"1VC ~giuQ'9\p"39(_/mjxn93UZO\ô"B#+KleE ad=qńa\ipJK#1E$5p!x $Q-"vHFjXqUt]#myo}KCaYc~Gz &1?Z)d=`쉸ak;$Dyxq%݈}Ue=S33/SB3YSxi`+pLU N1v5JC) Y02T֦ ҏҜCad=], @7O@S쵣吠9wed&e`[mffJcѻP{;Y%Y%:4YJa%Ҋ!q-Ez jH).LAOǹd#nd6bBAFBДv#B"QI!k*ǖS:tZ80eY< :˅k{*,1/6M*Ҟ2qtJ٨M/Zw;ǒ*"@G"zC͞ʈxxe[“@`tsܗSӯ?gQ{wR2ba jǛ-em2 !{MAv!ƽPVtai[T [ϗb!Tdp :6QPF"!8&iJ%00D_GYIA:B;KмwU_CVcڐ4C@̚ka\afe%#6Z]61E 8 (Νeu4MZˊ ۅNQQQ*py"D~FB[UfnڶhvNHLJ#sk ƅAAcH4QO7 Ԕ KP%]Csۦ^IN*-zE>>uV8$niQKa_XI%YB@&o\¡A0iݸBm?$`3B a$sf<^:-\7$bg{V?'38}z'+Z儠[#u*~E8,A%dA}ޢ!h)ʞ||+Pl>6d9b?;!#@HV*PW0~kE&E%+?IR_5A>Zq 5ԱA=o^ЕƀJ3$p>:=Ūi,ZUgC ?C&堳:uoLW$xvOJo3lLi~2_@)?OzB endstream endobj 2603 0 obj <> stream xYmo6_!t_d`bwxm2dH.q7 I?(6L؏Qdɡ[x|LW@u<8:!5VH3̗Wdqk@(ARR>cX4>}2aU&s>$w71bq ov/OE U^6QBnlQX,PI~%k㛋p&D;*K*YTXX ibBXgBU"%uK;'64+*-(%ID)y@I_t+v<0砦[`\p]^+WNYIi2w#KOWMT:l­GZaսqϜO)IbܝVs%raD}`bպoVkU_&^MvܪLj*DLIݎ,77R0n^Ү[,,K"YTR!(ؐ /LZ^sюг&H2{ru֮፣ٔMN@a0TaFG”UezyQ˰ aJN._!Mw$#H24_2 ;k122,ea'mLҬAs r/[ \R140lU01`xS +j&bĈnVz hcɿ'HCE,D,TНѝ.mza!-GUkG(70K·N:xKK{! %nWQ1:rx{餜5/5UmB130 #! I Kˠ59ë),4>6#+ŅOA;B*@ܸx2hn!.Xjؔ7|V[] l*m-j^^$sGTJÑ5C?OT+<Ʋk;Ϋ=hpLORC*1H,?\jSde{ [ ﷖O^2˒*,۶>U利yˢX퇍Hj`ZǟêGARSH# P911YtZ`S^2-L-}6U ~!{w=~^/G a0L}}9>}87p_'#/?amkN~zyG8ZIyE)a.a._pN/ggݗ{`^=N_8=.NNώ󋷳90EǞ F4u,a@&Y{?#Z[zd~z@ 8I,uFmwWݮm@ZM=R\;MOQxX`놣9\p!($zFd{GW'{Ϫb [{lG־*>vHNurގ[#9>Vpc$ذ{I.(Sݚ@CmucMӝefa2)RwFµI2n3/7~@7ַԶVWA ٭NHjBy.]:Aqٺ(nr<~L/ endstream endobj 2606 0 obj <> stream xڥYQ۸~0r@+O(Ql&׬áEճ%GY~C)^j"ADKoӌ"Cgh}hD(zFIγٲwjS{8F/!<[Yq4NAX Uj"ЪV*9(ײW%,&LaR"r`c$IG$,$,N;l΋z;qМ)/N";AQjyۃ솄H| }`$6.ymUl%jEjw՘$46Z|#6uۺ֧;`-vDegkmF2Ɔy4D 8a0dg 'j?^~cEBeL ̽Q.R'}`7T& UAܸY7_4Rgsi6X{(SjU$K4ʡ[3)&쥹އIk$m?딟H%6pw+C[}3g"WcL," Yx|) (4ƀǨݪt^ dŧTyVC G&nJNXf7 q'OZ'K#ح{C_vUcJsn3BeC7MGf$-Q*DEf޳H6ћ 7y`ժCP=ɧ! Ӯ, ='H Nbf94[VJ-9DE*Q69XҴ&' Sᓮ*5~!2j$+8حp aDi47 ѫޛbnS9A>i +gtu \UeJ(FF)nu9mYK6_d-N0ϡ"F2>yP^匒| 5<Ή1o. 6={ a~4*_Qvf@[Ph݂|jM~1;DޔH$z)I|o9r o(d5Ԏ}\)N_sJӔNO h2X}}"A-?dbFuJF6O`ݾ7;T+J3bYJ]t '|; )jY1mY'␳{~Xjv{8Fqrcx۳kuzwJhkMZdO]Mt,fԆRr5_ FWIZ{HN2ܛ_?ΰv=cx뽦Oz_ 5wX:o_-qW O VJY;Fi/?,^-٧6?+òja~R3,'eS>.>\]g~[Z`:;:8>}8. OFҔ@meU_ oe+qX |`Ǎ'y!eczlEnXс/P Z۬hׁ$Xmw_.u}^(3=<YF?>__0:-F<s; *+,zFEr?ܞ endstream endobj 2609 0 obj <> stream xYmo_C5w/$plVMt- X@ˑgE|g:*KiaC\*9Q hO&a9b#Je߾%Ye?].޶Mnk߾kg ~SqouU髶yps\*Q$t$wݶZ}w{y`PwUsg.ΓwϮˏWsWeTe{.[ZhvQ.G !AS,I lt=:^I&~6_O6*A9M:'NS.8(%\RNgzHf MyֺK0@"“g>|ފz>sY#K@]qTm*Q4| oQ$D99XGػZvzi~oGolqR4#R8\n^I-Ѝ|s9ShaxAq2Ө Z?K;SCǸ;"n(Tq C+O@cf+yTR2̶px qf!=ωrW~74܄gx{r4d` eԼ!4'\IG֔vdb,R¥1}!x% *qlp=;7DnB?Re" y3 pQi|B+w&(dʱ6Zcȕ]HԛŔC<Ϗqd>cSݭm`ִ&E\UXQ?3~pYo+W5 Ivʣ AOn0]Մ )ԣ&i))&NCC uBܔ7! K(C7;x:F:_m׻ H^8:eL_=tJGyBomKgŹMcĺN)t ͙3jزh 2"RMz݄7aҠ]exSw. Pƽ6f 82KUYϋO7x[_ 򐙑,GU:v 8b7ݶeъ0V^wբq)IxyIWQ7P濓 ɕo>Ք8Dgatw^Φ97T`oG1B*AQHƠ:Kf,[?ϊ,vzjfNtEgo?N$pBqV"vJhYb\9pĴv>%ȘoL1hw w'NLW# EI>mXWf SX(#NNIiwfd@nVt茱l.G42\9$==ΆwƊe] dBAbkN :t ZUfꂣ"ժ B6i26Wԓ9%XVO7%b+8I9?>t&A2ȅX3NV6nUO8&;g?@O !س! JaDnAhˉ(dˇFH:=;C<|Ů2 z|k#|A$t"C@F<ss˹Otpw#D F0rW{nJ MO UsH0 ˾2,,]H@IG-sYQ N`JE4.]p)Wpa)TR6;!) Fɝլt:wQĽNj ~cp]45wg:M@wv1nhƖQ$8QkTRZkQW+b<ojJ](_yI? :w1:膽rJ ֗.*-:6X+}J`ݍh;gfr6bD  |T_я7v! endstream endobj 2612 0 obj <> stream xڥZm۸_a_"bw*- %@8,K66w-ԖI;|ӊ^/)%J3<3/ _X?." \(aST2]~TAw˜Ra3ƲC]za ׼9+ $J%Rهzфe@E[r:"QYE>]32N%*"q9)yV5dV wSvZu#8u+0իjZ=ͣ:5:/mvMR &DDD!y07 8ʿmSβ06fݰ6QMeMFŸ'݄ujS$}gJ;tV Di9:Zo[5Tx!B)~C}qsN4OЦ^;00:x'+.υQ]oFMj~`~nA $B ᨠr|r:X7MvxWa]3VBX7{& %̿%' 9JoN7C5mҬa(g, #JD( 16MK &!0: k|v{yXY_ *ߴ}.iyUrê@4B"!ʭ;Ț-)!: ~͛9 I*IJ'|,-z~Tڻ[,_)"k&DB&@ V8-V$r,N'x#DR10SΊ I8RZh](P7qsFdi8TdI0.{'+q}f`D096Zreq"@5ܱpdqia8U2/3DUk+[4`jP=\6av VRlaFua+Kn@L Ҭ]5Ar2PEA9僆@s!,"&C#! p7K֔{ȜC2ω6]-RwydtFPj9'sr ).21j̠!mWצ܅U\#Hiv k d}#ΑgVs>UB|Q>S*<j6CeU4VT̎J$I¦ R+` ~=wM3o~|L F:F@tqz |pck55Aew˻* . $PzkhC#?_~|opھ,}7~fp8W T+< !wY 10 ']#JPٶldв l|;ӈ 7:,.9Fwg0n5.wY` @5z^&CIFr9()x v,"fI7KеbP9F.H 6YT>U}o٪k _ ziA׻q㸂m7ݻ8ҡ g2 ]f۷Wy$",lЬ k`͸Hk:I'Hsc_=\a/џ[$b8n&QYlCEl6ٗߪU~M^SlC@85SեXU+lXq;RB&#ҴX۹Vzm.%A|t9!-%Dl9 ?k9P h"!/ΪMwTAkc4Od _mԓGyb0U|x' 5+v9Yf܂#a0 rgV:} ܨ_AocJ夈V98*潗z%Zqi 'D_?=h>R?tqfAb^"n6e 4# v!mm͆|Y/㸶}Ν•=vRx,;=&`6SsDIvײKz#My~ Iȉ4mf%JP\|pzS$l0zyQGcp`fA0}iwJ޹<5^|} tU?7<>@ۃTpsQ!"[<כ%7e!Y爊9/&d]g:;t@*AO8x Hd> yeGƇ݁=]g"^õt Jvpе䩣Z<6+/r6ք; M}ƣJe9Vn~AFSݻQ܏R0 endstream endobj 2615 0 obj <> stream xX[oF~pz)%XՅ[[,Mm,~Q+i3KH/6K]ψ;+5!XQrafkEbE(MvDZ6?ҟXB9<ȹjCq[u2WxIHCgjo!e2޲[0\]}yk IpF6 4DA_.Ml1I[nnxSzbV})OU]ν,* q$9!ڶ<1D~[׫0 oPRTDNo! *O˲;1"Ax喴O2w`)lq G]'KU7iVN 4dO YpX,[mYR֫M7;={P`w {?AN-l +8@zf!/d&)<ι Lp{ Eztu,"NtQ5woV66pu9ԇQjoۓmnCZ2DXEHc +o8L[3)R$G{q[Dij qU-Rl7؝: J'?6+#LUaٗ!? )@ rd|dN ņqdnۙo+HṆ?*wcPH$M#bd}f q׺u`ˠͨ b7YtHFN'xB|A8 t-5ւMPƘk& }6UU{[Ze+qçMb;Q3|;0O?lQ ρk9'ݏߕA|kO%Pm=b],ڧͺAz}!I{XİaP1(#raj@c7˥.J {.fs<}fAeǫxhhe{DJ`n(PNUՆ£1yym`DiM ŎU^ 'Úm9+| :PzDwmbk_`vP諅^u~p0;X8kmIW΅,΂Z9%E"D.K3pD!2ZFpMF'X!> s&'R 0k:f=#hO6 JZ`i6}"X@K,*=\j7D-S>URf0ĒK~ٴ3%b*)\$8D޵1w9TYw\;P>zQ.8aogDeMpȉu߿VY?mj3$ q< v /k]Oggk[GC/O# &(|*?؟I&s!Zsj-<Nt/_.?^7L5kz}V^Z߇,dM!8nZqד!r7tYOs[ǁZHVfL0QNҔɡ͋)SbZMtYaR7ɹ :tۅ-qILY<7A: Q. ;?&1vF endstream endobj 2618 0 obj <> stream xW[o6~ `lsɮFij)x dUP%J }>>/2:Š1&WN4c. `4=4-r\1Nr(Lwz,sA) D6wEQ%oR#)LjLŘ`I56in4#4QRsV(qz,Ţ(TZ4X|X- kc}V;+H@AȃJZl涅,L%%U/y1܀e,e@'@QFg(mnrP+F7c\kH("aoU'&e6wJwi%,ZVe>[jPW&N&۔7ЂW7ݚLl‰\4Wq '/=<@gD3Q,r `@^}{ 4/h[^,-AYTC]Uƀi^;Ro_Me>0^~=@ ndD] 5“iN>\xt23^_j )(@GGBsH>Om2S:ۥlL]*ƗN*5mPd@>%aS4MescQMU"TJc0غeiV 3\}6mRdp Հҋ-TqGø黿 endstream endobj 2621 0 obj <> stream xX[o6~߯PEĊ7Il C4}Pl:*KDCJR&qu@Ѡh\>~BFF4JriF΢oYDSREuDrD>EV,>1Hs?=Y$lV88nƎEw8]$n,-RmU'D(RPtj "r}NLMN$}u%A-1"jF #<[$2cyJESU,u-|j|xP<7KSGDD_>ۇ=O۝[~.<+Q^қn!iMyDEX*2JeMU\K*9 $؂Z!Ka落y`wQYtw.b9MaR95-D/e2ft"_ԊgV|et_]6i:J )e#D|јVz]k٬C9;joҹB6fs`amk/qlyVJ "N OďB"3R[PXKEhFi L@,+_P0e5,W[V%ٸŚҵ5NBw8c6~mKug#lj.k> stream xڭXms_Px5sKKNd&Z,6#8w P J{cbg}Y | gۛbc9lfAdg;hV틎"߹/ak}1mGt8tMȬ2y͡; 9js.T\`C5!sFD8"z"b]6ITOrMQa퀐#`#2i"GM򎴀OЂE->dQ7 ~;4 z~wm{;sz 2ˣ_зvoZcYGW9MǙIcA e.42lPuv|`OC- @VAVecזLV5=ر&$V(j[tj Ts:6{TGE\-2-voo,LX(|7I"؝ѷ_.?ƷF 䣌)<;, ]u jvew%XU}]\4A"ԞHx`5˥S K 9:l]1#!Θ]81hBD minXGm֘L臇$2A\ %NAk΍(B3: )dʲcb2N^8:hH(9]9j)11p(aSlF8#<8bЮ=}&F_ARV21i_X^uKuV톝UMQ)ʺ&5>aGeǟ _:| yfɃAZz>X&/I:CKFb]<tńA?^~A[@ @"'=SXN3B ӋyV%U9!$ g EGW h. UJ@Ɣ ϣ4L, %}eJ\[dߪ5.W*PVn?PB1F EWKȪ -\iu$YLU/lAbMcN%O*(Rty3ǟ u, endstream endobj 2627 0 obj <> stream xXYoF~ ҇ٛdPpHѸhl?P&"2IكhdH/6%w8|36 $~q0/) FH0 H2y&8PFQ0Z=>bXW {{xSe]3,ڕ}bu&ag<%ZZtKyRSWo$H2f7j㺉:^F :# 9g( |CyxVmW2o>ՖQ'oVM]:{vMQ],&L ,3}@Dga -gb[n} j:AM^.̄VuZ[n,aQ͗rܚ/:ugS՚Mh)ETظC(bi IOáM2n|&<R"BI_ /@.sl|Rp /=&1BH@PVke-Q$D!QU)VQuS&c )qo[E'3w!݉p̊[pLKVf{c nPb;'wyZn@MFQ[Al.Zjݍ_/p 95g77 b. !(#ru#CƌmۉkEqbD~:^@Fc?מ1oq%""idz>''+e{}A*վwbzncidǽA59qB@\f/t0)&Lݡ-5|-}O7)z̎U@UflJ:Qt}'rcY+앻cfE<; TPȣ'm=PO8GtB]`+q~)J~9Y*>kAHn룱Sa hH ,] .w^`ua&fֻ{n0n$lȞqA壑( ٳ&њ  $%W<<Ƞ֭A1|Y]۾= o |p^jH5 nSۡ.Ia:!xdBށGL{jPgsΑVO_k:/ endstream endobj 2630 0 obj <> stream xXmk6_!`8pwKe [w)YbCW؏ߑeV*n -JKg$Ċ+k6o?S+T+4v`MEQ̰ X*tH:RDF3ãCn54=*͝Â7Qi?@@8!1ko[!j(D3p!̸jV(`X$64>WmV8&D"J6TUgg!#H:Ib0M1r*`L\IEsޥT1, S'++&2@֝um0PL[%"KBI01|g;Y}P;(d8!9 6J?߈+PeH hM**i,ʢPg{Y0-_tbƒhm1]JaG$]ͱkl6AY+=*\0a8}3mÖ Dʇ!?*X6`"yh,`X4X h,l'Tņ="Y2 F+!"` 9Z@H&Hk[5AE)ԛyO{^~+6jzC*AUP!4bWg톶 mssy~g`!a H Fs䷶)~HtFSP .0@+^m}vܚ&0چop5Q~oJqvBXԪtkݮ7evO-E~1ן~q|^⯢UV)nH 8^l+Һ &ڼȍOXQu tWj_TS`o.C*_9) f}+(oX(iI΍ Sx@dxR4ÒNKXhE#D yZQֽ gz'qxx`ϳ̥*񤮃d"=P,+BE-lHB:F5.]eAR=>` o> stream xX[o6~߯$;uk3tmqpXX,<~IQ]ZV2ap`1|IHEE'M" I a:Y}J e)`͇,g-~?6MS5O'&˩NWMYgTzyE1 [y4ֻ]mj7o]8ɉB1+{u圀w }$ݾ˯ HvLI-U I w윝yZ i׹!#}Nܺ@\6ƃ]hvC<d 2tx"rE ڋTW/7Oe;u2U}E݆t_uwkgUr>ͬ*C4cou5emUՅ@]xUq!ܦeޚZ6?˼o$ctٯzyt#v< ѵeʼn΁+bQQQ,VJ*PAl䡕ϩPH0soily؇_?.r#HG*-,Oon4߬ݣ=m8m8{mu>~$ؙMLDGVAz܍q &GGJʄ3Vɣ,MXPdzp< 1[,C쟉.Q]L%RX?g\5uy(_br& Rohg h2= <2@yBrǡ?pJ(m#^O߇,؋U_W+:j. ρ%ɪ2Jqb .!M5yab@]Cb' $ƨiM wJEf0hi3(A~У\J_7oDH"D@{]_ Uܓ8ϐMd 174hq\yU_""%n&Bӑ3 &@z.}J9N1Wg hem8~ݿ[+ endstream endobj 2636 0 obj <> stream xڵXK6WP>A؇oP` LWzG]%?uA9I?8) ɦI~K^' .*N,Lb2ާowa}SJS_g9c,0jo  */Kjz4*g I_Xw~[R$9.a&#e8 ?; z<2w\ xk$%2^:8/%$Ǿk22+ 1fmo\lZ\!jڇfF14s$98q*HH %^EDc?\H/Zbعe΢87* ċiA[9)=jČ[ d;-as3`DYIꯌB.<%Xz>S$=Si+ gKV"(Ȍ\3K8ryu&Xu(UU S (D1ӐhWkHq^v '݇—\sޜ_dڥ А< LC,j5-ko,G+^& C$LPQ.$$X>wHhjp֜ٛk:#^81CrqQ, ":-UQ즗10ϻ_pK?{ rxg.8Z7)l .]2=!ƋCisKQe w/֦޾l&3ĂMparh[=qw'=HH}ĉ`B4a rPvnvk]G4)9t eV~u7SSS.V Apl?#ز[QmXXr#O/C" O~:NK3QpHh &]:xSzM9HA}>]NR!3P_̿.A vuFbne / =ADSr`#(e 9i.4tzu W]2:7scKPFmL9#torX AI$fݿsE [zk5yrE+X@Ǒ,SP 7*~ x_coU^"=F O$!(Ϣ ®u|c'SЛe$xI/!5)bP >K Bc=G8iouo;h?|-p&q3Rl$Zt^&J4H.d9;]&Fo9b1o`dJ4(_7(ͱpF'~c[Rv MEz7c6]˨rWT 5 3qT۹cgd|¾N_皪n_Ȅ!S. > stream xXKoFW>neni-^j-H4W^ڲCĦWy78$/H:$?oHsTNW V `*YoޥJՇ/ II9}UF)Mf~z{=<׺vUFTZYV7(AQZ2V E0"UISUmSn&NP$Yͪ鱩m>x-t`dX"A04 >whr[us}ǩ6Co-lg<ɦ*#qs2mɩ ;bp6EC"R,yl?ŋqc`٢籠Q|)d"P.]e ϽN5& Ťgb$s8TOlk<:@Ĺ BqI!z A_k#S.r.ñkdҨCL!EكNqJN rpwÑvuMns$IqF#nOX7PWz{VkM=쬠5.MA!̝!ާQB〤IS7lEPNxz/<>{+oXHlJ(-0tA cM+Jۊ..Xܵǽf}5RvRXf} ?tbz8AcE]^6Kȴ'u^k80b`T߇dvbd ę JRkܗ*.f5SҘ~r(-JDfTCݻ2tƲ%;b9\F 9|;*s(<4 'Kt Lq7X@>׼%)a0F TA/bAg 0ޛ,mѝ=3w U(5A۠ڕ6e5.-8E\Ҙ [ehݸ_]yS a?:R  ,Q~v% ټfZp4m挤^|q1 1,hGwI(RC *`AS\ج R KPL Q}sb̛]];m7i͜a5՛1Jc˻þmaK 201KYqf9Y4re h&Lx@L[{\eF`y]n]g6c١IP)YNWo&P#. En(Vr {ApF`N N(sՃN,CHjͳ7> stream xX[o6~߯P@*R}˶t0tXkɃbӱ0[r%yM-ۀ!A~;>F$C"IG}2zF g$Zn""PU\V׋1Szpm}[q"PRk+)WoA!ExqmQK[,4_;)#p bXrZ+xAe+gbU'x0 >>6~X"2 ӳHU:x&C'$Lt):" L([aﵶtk*Gi,mCsDyXq!3 "ÇizweƇA"n}͇®!RA4 vR(")j["32-ΝH K '܂w^V}w zyݚxaKD!d]4ۜuAD_ʱ^ @ض>K R_绣>j1_$OAW`OHH]AhxlG~}O!ӆ'z!HO{ *͘ 5Tݣ}\x(󶪛Q-X;K/$L۷ ǝl 7tp6N1)ʼsr@1G@4-4Po/d$ZI%>9bPⓧ㡵nPTpzb3 :3MruGǧPK\QAZ:zJ;1=/ifU]t(y[yc]Bqj@I$-@oOE $BJ=O5p0AM%|Auݭoum鐯`n `P4'Yz@iOجU{W_.6#9(@8bBӅ1-£~HR9@B; Z 2Ml LdHmA}7hYRq8Cpp刂uf㔏3@Tڧ{ln 8 >UlNSNrwȆ1e@MdTm)(vRPtUt  N, r9p3j f Dް KMRI@2wSwb@ڟ_ݻ&Rޙ3L'PM渁~:g) IY^f 0$jzM]흫29eS&CSLSc&b]XH/l҉w6iP1R> stream xڽYYo~ϯ!adsi A2@2N^FЦ6(RӔ vaâ::z 2o*oVoߓPxusr)*\l?%27_JPSm޾oRz?foj̒TYD&Io} xiI,uWաo*9֝]eҝG՞Y afCN9I׷U}NyqI3p]p(e^]~U!W?ED$k.UNכR&IME^@j4ϝMPcT>ډ)@$(t"^G1%)P,L5jWܾX-q݃힝;!2B$[27q81z!<>8OkdAaS/Tr. 7wg5 NBG8'0 (JXB^GW&?>G q<La:0q~U*KVz#:q<=F De؀IeT0B2vOOjnt&C> Iv`8aI:R{ 0l6?.m`8z|i>tľu!}tL)x؉ L( &(<ڰ{^LaǨ1kX pG#B_M̄ / >4Fqs$lV&bruhR wzaV6ƦnZS7B A,2Ĥd~ļhorADXb]eR>}̾ E*6bAu)7q75V7H $js92y韪lϱI6I zZ̑I9b]-f$b,?Ҫ5ICJ19FOňLǺ:aVzyфꈏ~h(#Q  v#C%FJ ȬĠ)_5:ݰ $ }{9]{oCsu(]PIcF@thHcXTwʤ8>c'̌`*!&W$iHF΁v)SѺ8q(6 Rȱ~I\@7m?TN,6{3Xqo[p!&a5ttv_u&)0 B^n 7'p6uP.Xy8scYºҬF{%lrf戌0|ZwWmNxpFPM[X),9:_jT$qw3g|P*FB&jL"g#K#E7Zu#hE>s+&`tF̍dC7vAץ}@s {4\yȩomJ0#]ClHqS UB-cBEJ7:x?6Q*IOm%Cbbmu ίa!c!{k-hN }.5.jm'{Txˡ9AWz؅`(ŝHkf=hvv*v/WO7] endstream endobj 2648 0 obj <> stream xڽYK80rȻmߤ:lf{ؤfl#n`~V,99"Zb_}U^` pOw FINs_0`.6йfBd.WRC׸b.c!"Zh1~u%)%:ˤyuϿe؂P:;8QѬ횲zXU%T,+QD\b5HjR\/ɶQf]ZM1Ƿ);)ubtf٦d#c$+ޢ>VLa#"-MI*pQo-ԹKI7܎Ŀo쒧pJi>/|.s jӆyܺ*<c@&9SqSEs"J8< R u`YmSDhV?4]VFI춰wܕ1IQj p gN5Ram !^TkJzEIv(y*|z׀1NDқK{:q6 ,r U]V#{ѝÈ0}C;:w`Z;Sʂ,:9W>>B̄Cu w;{M=~ 2[@Q6 ΃TpC>a&,l:YqD 7l]NEY(:\"JP.!s@(|uklW@Z&LɊ;by/]|/6pT.EۖU+PwN&Fƞ gqY۾SI\\=ε3BF$)+%mAe>~#D#^iT6'UƤrq2o=jWLW,VoaXKoxE3驷5BliyXsfm:;8H<<蜰- 9˼* o%U43'LG#?nPT?lڷ߼@w'wqI4 8` :׫4\SH$ J鉡۹χY6زUo7oz)&^?Yп&VB&p,|N ɋ fi'9c, Xʉ\ӛϵ]Vŏj;M?p7y8B,q 2?*Hwɶ zJ6s3j殥A5_4ƭԼbUҰD04z=TO2JՌDR:0X4\`cD"Iq=35y|zv}%_W)OͰH&˜ta2ɠC]D-L$>,ÂLvqiK0D MQ%`3e&xS&uלa:;\e m*1 7ePIYcӟL+RsʤM7ťC ="3Ba Frj. uR30"U;&?r7 >!|î\]weJO4v9W"Ad._#C4'S pu) ]mUVP}+XG%]X~Ng3Ԥeo禒 l\wl`%0v$setC켻[/W endstream endobj 2651 0 obj <> stream xڽY[۶~ϯ%D+AiL:̴>e%Syqv{R$ vcw>`76t?IO6q懟ن&$K2mPN27wN63v>9Q^nor6cSXDLGp4QoOgQJ,2~2]Vjo.1W84%sϪП>۪~ۖv&,*ZFq=]0閡͋޴T9?Uh•?icDzleQ~ Zo`U8v״GM$ f?:VV,kNǦY~c?`p5pՍU2/ "1pBOi%8%gMFš\ΆӄAQ2qa\t׻8o7 Y|rRCA$cњ.#lTs'i; UŹ%!ŋ<:5>Xp.T~yu/ uv+]DEY\z7|U~XIaSwAl>e@"K7;DpVXDg  U$e &Lͥ"LYb\>5겛>gN@Hf +Q"r'|>1S$Q6$Ev!PxVnXP"S-r7PԢ ,c)dEBiN},n~ %}h$e8. o!U]a&Bc첞fɑʂC)_""2+HN5'LhTjL@*`S3uzƤ9V yVd7~~Oy+i\ RE!kf5:bΪf71i0u1='OsPQ;&)&1]O^uK3q8p/xuU'_.q5 $R#-~ ^8B•rnz U,/TοQgO &`$ayn(ߺ5燼3qPBvWj*P^?w.~ jFN$\%i_`ի^ljq*k0W :Q-09z㜠Wd{7Td֋ހr4 x#}Йb MCq&E@:^+}{(^_z%Zܝ򡲵=> 9Y9V|aM[-4`|nF*ʀ-xjjKU?k-X"8XE,{>82m/eՂ٧vy1Yd֕.p@JnpEu|2bί6xM ǒ*Q-l|w)|r!cibN\yDuH{lG^O Œo0<BBoB*BxCqGmcδsjs8L !LMxbX36+oPeq&}f(aDrhEK0U2;52m0n {? endstream endobj 2654 0 obj <> stream xڝYMsW|&+ LnIv6T*aZmV$RCR3 ezkJ$ 4ݯ_/mrf~30J,lsafldx)}nwBO۝2oߖũzdhA.7u?3CA* väo}k.Xa$:X[\gE[fq "+~+Xz>1CаWֈiD9%* P]U5l8"-9J0Ƀd]nʭYqJmcm 舗~. P>cgʮBSv~iq | sscֱK K2Bꕼg|B6o DsAb_!] @ާ19:fH<%Y( Y1v·pJ*u$N.rQ$G™I ~U*9¥`kp]+py$v^f8^|in̠Yr}NcA+=qh T5V RPIhd5r[!(c zDRKPx碭[Pp5#EviD@:qFGʮ+Prg|0 *.."f`7-%n>"2Lvbq#E>%IuBg%oFF)$6F e|YuR`/܅Hו;|-ޏٸψ+fPVpAn`l}0B#tXZ5V;6e;BemY %mN}7A}VF+U{~t3&x,STk` 6q*d3;ʝ6D[ZO7UԞ %vY[+ 7}'2?̛]si!9AxʇvAu2O 3Wȁ~~>Vwp9@y8UŝAM߄wo{,O]p讬L"C\:4F_`Krx#2"a #q K"Z\1-VhGLfg {B+pe+ <&*?Bz;f;!Ėct/L۷(s+n_GbX=&!o[Mpiҥ@RNY$s1q>]$!OQS?!-__؈n9 wE,ޙ"O7I \sР po,8fz?(t2Kx>zȾUKovOir@w9u7MpsWY?l$;aYO?л58&1-8sUzSIxa9yGH"<#_pGʧ. &3ec 8ڱC.G",\8;"[ endstream endobj 2657 0 obj <> stream xYKsF@D1=q-;YkO QemO %n)%Ua zzK p" gzxxK!i\^'X%"TrP*[~9! ))mz2.jx/7x]uelKݟeJbjI䢳R_SEH2fvnyL9a {ዳ󶃕f}wswo`[ ]swi*20m¤BT!7vwg U=ªrSW_[1)3 3'r ȥ"II7vf% Õ"̱} 戮a9Rp_gjjuv[zX Ń"I".ϫ1nB{W6 | {"Ŝț z fbS QuUOtYcoza~ Ro,+5/Z=j6|vjTks &M1nB- FgC L^զ4u 1fHsZ0?|S4FTO2,]\"0 ZMѿxp ]evȁ$xi5".)ۨ"37Kw~ngUg w~q>-bź|w}ӑ@,N '?"_"Ňe2l߶tM_6'h)UCwe^VTmߘ sSBr(õu|w$p1Fk6.S/ކ`pnUYm&(SaRDQh{-ULƩG xp3j[` (0 iƸ0JV5ZEsXrĆw'EFGw p&9fSsbz~wMaugZtyPh̆-V^;)>-\)\#BZ 1lnW1=3LjP%qN,Xz=E٬0Î2Oqbd5Tj3R7Zے9ڡQwM ٓ`; ֊2Dِ*6j'xdioE`]p Xb0;;z[yO yà2WQ=eXCt@<: cDİNƌB nthtPY9}6N'24=-eR.~9Y^5WrL|azoq8;xp#AZ&l c`e3u0lT,k{4ifL"Dʼn1%ac&w PMp2  aO@+,FdmSviF#cňL(#Da~10b4D=cMcN2Soأ,l&w PIӊom ,)Z#7=4jm/ӯ@\䨑"~g_Ď@69@Lo O &,sE[(#ʹPB7Dʯӕn :<,kFaL§Osi~{; aeV#`h\0{[$elϐdpaNle p/mB|f]7E[6oʿO 6% endstream endobj 2660 0 obj <> stream xڵXK6WD^T=HHQ mcA+qDmɕlw%/uYĔ4|^$/dQnVo'(OrX-p,[bvSJ#1c,зvO_ sj,틷XIf{(lDWpV&V'xeNUF~2lEL3b,Z-);xvrLX V‘1Ijs*.9j@@QÇ~(rも P ^PU)Z%А uxHjvn# -h\ɝUH@ PX8 \$K}4vID[MZ ;aRK^R7N`3Ψۼ4+699P7^`slv)9)&y) $Cx߽xG%lc(.h)*q^MQpZk;JB[I {yRaXه'c4-<d!9(Ax9>X0T͝50 ~x y6@ 0\r>z 9wћʟeWj$¨iAK¦~s3Mأ 8RYl6A 5l"<ğfGM[Vm9ķx"5s|I7UMlN2AԵ,yȓb]ǕNiˌju)%C ^S] GwYV>GLR%>ml6)tȄEvbI_e+e54kZK&)tyrL,"@s6[z.[$ "%W$|1ЏqYޞj sFү"Kk!Owչdf]+mES:n_v<};PC뢁 f Еh38ƌppCx6tfm갩AZ#&fc' J2~y 5HHc=q[KҊM`کM2~uoGBPQ4 VD&ý: (Ê94@Xn A:̦P(` @!؈B I0k4a6bo }EthfK(zj踄&zbXx0CjC c4mPwȑ/Eשu (M ǡFeb=]'Dh=[:PaЌIWuf fT5Үnuyӫo@ϑ r_ÉN"[= 1"NzPk)7&g6}C*1`5Q\#1a ǰ =Q8e;dE{? H$ă>HwEr5\x6)y }"m۴$!#3{/ìt(S3I3Yf25\S7 3YCoR?X1q{ԙkؘ]1n պWKz+'{zo,%TRڽķ&R@R ~  2wq92HKYeŠH!;Tũ?o:\lwt{: zҰ1vD͘mY]|}vC-yMfFU,:\zlhx2uN96ruamosD2u-:Ĩ2kV!n,}TAAQ3X xgeKV%yZ[ endstream endobj 2663 0 obj <> stream xWm6_aPlX.(ni9&~018vj;+YkoMZBɲV虙g&oH|}^ܑ#z4*F>NS<%PJjNWoW'Rgu߽-nov_7 iNA;l!cۚL1l "\[nۦ/y|(/+{` ֐"w/2㸩b.RH MT g"o5koc |Pm cq, ̇#{2È;yER0YH#AϠDҘJ6'V)dx5dX QM4 1UóPL1T_EPʟL%>׺`!NNgۺs[46AAL.F 9Y"XP qAKԐ nĿ؃m-A٘Ny6ݻwWc0 g0^A[gv6b(rԤh`[VzLymIe=miFn_g0d@_|mgl}jǫ7|0JkGN?JP?PvR8օ6j]{HUIJo ]GR*(2^Ε]'Mne)B)u~~뾯vxAv .!ܛ*|չ.t{]f/ɏʡ0weOD:mLj^.uJes@3.UTȔg/yb U&YRȟNVS( 7> stream xڍXKWȅZ,7ivH#{,8G-2I#类n9ӳGu뫯fNJ WVb=nnW V`UQJIɌ4+.Y,N nk*Vr εǡֲȦfUL*#leɄtЬsiuv<()I% ÔfIAֿX3<#RYO"߼G,FSAccЯ]3ZM Cspu6uρS?NR_*f֢fy %lɩ ÉF3iv~o4Ҷ>aȅ{ r08N8 /EȔl+m֥.F;^_`Z/ JץE~T/K,_6iWl\w^Uҍʫ9HzBO.yɌ8݆*k'4/+puJ!KV*Ӏ9jO ܴ!f߬LmOz^Z? w.59/++K"ClsM34۬q" `q/OMk=!,--x0?TxgIeDF3]鯍-]m2$gK}L&B5zG&A?6i5,|y}ޱZJ[}s% <89x@/ǩ==hDXDZݮ+QOX7j/o0:&4͍`ee1vSx."=5}N]Cy`Sa3t>c`:ѱ; anhSscUK|H= t )3@ ~ ϭcO;>cۥ˭w9aa< 1'bb}A/hكzMs^W6l6h'vO[27' b=n|Eu:$+/k+?J eLv)HW3z*J`^viђ*|PaI+c (͔ N <JE8GX vo !W410ߣ G+`weNZj8`$g.Wu&/zCԣc `W^ eT3^s~MSV2VWc&0ٽoNh2MpKq*(_כsI#-56ƓSj@':B@J.o ZN\CP 9tFp%NR)a796#<\ /:lM?`=3EQ?FI H|AhA~̀U^!`8jjpQ7w?ˣ89z^C]lc>ze`C-_4L֟CLԿ`[Q$ONx~;%#M>ɩXвs-fXp ]+3|Ns֮;BL#m] B=Q?'xyHLYfJd gKlƷBƭ6Pv[?jGzESA4N ʘȥ\ w)?;s133WzY>PWNMGfwͦK@d2F2WZAVW,L /&=h" h kHͱiwmiw Dxy@,>6~:%2^&Hmܾ%ڮ#6`hmwӗĶѱLIy+4>qm,v . zطKKSQhOoi3efюߛ~#vx: endstream endobj 2669 0 obj <> stream xYKWr %@:)T";II`+鞞 I_7V^bHWa7JpTnW®bcd^xT%8R*_phj|߫F5덴Q~Km Y1΅䡭lpG:QS:QA=fmo7U@f6|'x'}7kiOUšx8I($gƨEy˅K A0/O™z$N[4)>Pw..ʖy CDnHNed&62wP<"Otmg3a%W{?Q'j~3dSa&">Ѐˀ2kϴ8W5_ffA&;j2ם[I/Ǯ, {\:ڶ*<2wzCqkv~.Ǫ8bH{y70I1=J! "M!"q5U,T!t&TbX2&1Ӷmv2cO3Jwkm^eҀ$t4i{kĩ]\ 8􉣣Ya!,X M-'9H,~Im^ꤒY!朘D $"a03w֟t7u,'DZRӼtT|rL!Pk AfUh$_e=ﻸwܭa^%3x|)hde}B%g8NDœ=,Y2Q(΀YZ8kgiOvIZ{6>S9`sxGۢ  HyP@ w|DMOꗔ9K@t^%>TuF-5WsV8++l'WUlB&[,޽D7e)lcp}\cW[ǹBC.'3  LbxiAɏceS'y=zV}N8Ǘgnlup7d Sdv R*>֡QmDpfP_~lK(|XWCP h@+_/a4# tJX0`SSaZyKjJZ!y2RrdhB>E- r.Cޮ]_HĐOݜ 2I|Nu EC|OXO 1c'w"|w"e>Xr`$2`S#'sF\:+'%d)+XA= k-9ej1ywy[21*!܏^\6[Pį #݇CPEЬ끣f. /)Mal3NHۂd4-5З۰LSw͞-#ZA>nAUM#_QgYFO*DRgɃC s k*2rUHi gšuնv7ʳN?]Ϩvҕ m zWۛ$臠2{F]B_Fxq |}ڠxBY(3MZ:>V}L6˗@\ҩ.`GWfxXρp$DKu%ϕ}nNuCj\Zp[b>?i;S3tnK ildz$jK F]9=s1z/iy:N+3>&{][ze^,N譏PПJ }R!'F{gEc.b/\%4O]KВ]l ck7RXN쉙]H-ZKUwBB@Tjqo%Bde^XBUx. H&G9.rfOK(a0k\p9cGߡf?_ endstream endobj 2672 0 obj <> stream xZo8=\*?EWC pM`l9ΖM)Kdq%ÏoF^ WwĂd%_\m.KeWه;wnRfBmRJe?uu&7߮P\,@6V>q@2 ^^+U+W2˕.ɕ,4* uqzNXqRlw's\W.0btzlv-Æ̆^ ᷥV+nۋ? mG}~:y'FNf廓kR^ͬh~Ku+ 8>Qa`Q\f. !e K U G\ Oo6U !]Wg\y4,, nbvS=BWEq~BDnI5ܦf9&5 ޠvm*,Dtcסv/p8iI"r!qZ56ڛM\Z ^\%jJW9?^%8g}٤D+\ w+!`A*WRCWUH(Bv,RK/q^kGn)[ܜ;'`3ϔ, ZbM"/0YE}@<+F`؜Ţ |BP%vBhF6x`#yR93(3G3":\݇_HBYEW97vM_1dP *T\uF@-_.O*jM/ӡ^!ۃQmr4udcfχBvZ/GphkQiQ?&| `ޫaǞiiO5p\ٯ5a=Zɳ hO|Lpz$U3964 KzMJRExî9 tZVӲXFہ5qҚU}Q.'dA,Y<#'*cMS4>GD8j} (>)_0fV]"d2`9+Bb䩧g^1L+fR\?-I>R a\gd^*!yϕ(/=]1MV O3 fRC>w_fc@&p1sɡGd2]nE߼R'2u:ybY0zj@\܍S 8nsB֏ұH~؀l{ 570滄uwmL*Ix3$|0$wZx1$:m/`3gl R)({ori901ӚaM~RI+UooҰd$.,M .}֔ɾ~s݁ϝaY:']Ds;=1x ?($ L#}Ea;St i∏mp: RH{Dp>s4zC՟Qm/~|5sX)p)׏څӄ`a{s!A'#}ss+_QR+"9fNQ7&z&-t]*ڐ違pAӖgĦK$sҟ eƯdޜ;yc]y$5DPɜ|EqѩiȦ@ARKo I"ƽ~_/TٳHy%]UDUH endstream endobj 2675 0 obj <> stream xZێ}WC4U}| <~Hb)J&OOUHjX;Kԩj.~^EхfXo_\/>} tq}fA9,7?.QW?]}8#Zs5>w__8˲}onݵx-jr}V˃uŨ&JXbp`- 1 ) }rsMVi\W,AQزHǾ/r^P_Tu% 4?U`rvwo"XxPvWqBhFZB.냟4O e?h18H=z%XAP`;NnroV0mvw9e&ڰ#ZuwlбFe>)B1nסƀ9礢;!u 8<\7| O,,(g|]K,֪=)(F" bP]SJ "xT技 ]~}ɺ /Wѧ]v?kЅż)i,fc\8*J>m:A+7zpYi@p"fn]5fe`37pxdz05ф 'GuWuz Ћ>?.8(wd"0t}vqI$WU~:Ş)Z-xRo [FLQ*1ÀN = ɧ>e25`#gvN & @aI]ADg!oz)pw~rm nKptK-H;Xef:>Ơ@hp!8lϴ[ȭ$!kO'@ѩ% )"=ڑ%^O I_Η9Mu(7#2}R\;w3!g39ɩ]UFM;D$wvST&7P1(f}ߔOA}y7FirW~C+c9i (F +\խy mF338\ݹTcvuykwqYݎiD" Q^%Wܒ#Z3TWA%>: ِfy,70ևo~_ֱ| ū/bGYcWĠ1ԍ[1^B*6b)Sm&!|mY>Lbn>M]FI<C-?LUC ⴘ*t (_HP|s juW/,;?d1 B]hm7& y# Eht9/XAS@`f4sI4DY{Y!CR (S7+D777g2 }W7ढH#M)4*7huWxqUZ^MfY9)'h/&`C hf%t4xu; /e̕}o>)CXԷE{f"aB쳾h9aIXloh!mW]; <=MH#˟eBr+/-uZ6D샔K@[m0PZ5vog0Ӯpu".f|~Z+쩸eZi|lY!Q'<1زbl=%N/rȺ= o"~_eT)f͋<{Rn*N$fxW3d%=|C%b%~"ó===> stream xZKF eX~? !ڇ, 8RgVKI^‡ꪯ9?flFq|(qԱÌI;[^Ǧ/o )evsS/L2E07>cwRG,e} V׍{7AY"J8jh(Xilu)̾TMmhl?yo{f)q{?~ fH3euu.pr.Oۺ]XCl+`ʛt00|<ĵڵ$Rׇhۼ.KbaxSSz VzzG&.cd׬ 7mm5_0 M[!c,^0X&:/^Ycth!}x!{=fvZ"VT6Q?͛8:>0^!h" XmxFq ':mHæڽ-Ea$' G D} 4UL̃\W]ɕFCv' bC&+EQ&X)QҘ 9sx,rqT U.ئ 1-8L q IOat%tDORDȼ̼eŒ%܈e0iDs(*E~/+A b8` ƽ.48,bp^8՘߅ 4;)A 7&Rhu5euߍe1nL/ [($l/?02GTW ;\"=PfY"X򆄘s"u]waݾiyk1؈f"ްIoJTK&_R$+IeEEj'bW'lŰ0$* 8'h?N!6QW@f[UTiձ5˟&p.cw7!콛""Of-g:"Ơ2+RTH-'JVat1#KuKxM|[5qr6pUC 6>p|mYQ]qG^e26{4I}P9;ăLHMztD4tsxEBa:4k>U0iKOZ K/*Te9y<&Pw~?[=p?O(7M I/Il7ǦBR}MWg&T`9wq 쭲A {:,Gbث cG} n@/7&b/EOX \K0|J~yU:Z-(=T}A6AC d@s7`Ӆϕ`$H^(<;0둨Z-R;Rbj 륛y͂w.h&n#iӆӰMK8o_zxpM"W!"ܭ$MУlܫIC[aI5y5yiJ˛ vyp#.o,-X2Zڅ \1G@ vcX3MŎ $s.]N[ʁmo_™x3{IȻ3/R/*kr7%UA6 ?}fdRܱuቾA?̹.ͺ#D~РIAǿqq ѓ/klI~qʧ \9a7M7QRЎ(@ڍffrlU.-k9w'0EZ9Ud"#*{oPghHfF`9KH<VbG|w7_  endstream endobj 2681 0 obj <> stream xڭVo6~_!aER?$!H3G]{m1 K$oߑdɖIHw}#1,õ2f+20 ba, byF0]= ؆!"MVse9JKW @k//r哞2Mf5ČD^-3/*Cpki&(e:t@9SK*]-޴&"IWa^ߍ`py;DWaa~ts(` vÏ4PD!כYe6`MI &f3ڱ&f{\V]POuU9i%)d70Deqkn3Eh)*r4x󧱘a9٪I4?LW :oiϿτe< wErvbEEZX,'H#5꿶Ԧ# TCLJij\\ܢeOvˁMT\vm_^$y ^W~{qAy?U|"Rb#]/;G!NY-Hgm;@/t&vv!_iӴ~]jp noƀA۝~q4ѣiS0Y|ES%0{[kXeyg\:*_+lv΋'RyJWu?> GAavn`r>RGTa`\ endstream endobj 2684 0 obj <> stream xڽXrH}߯УLa3[*[*.=]XFoEreHaE9t;$DQ2y9M^ (9I0sL_ңeiM=c)s֫>63D $Ķh/^$9҄g>71O:=:aD4I/s^ Ddc$8O2dӧ~ݧ2˳C[a'#!=AҝG'7'&/ Gi&}ۇK~%{0ίgM?P7n߆~U-Ͻ=^|FH/^ۙm'4 Q LHiZ_@ -ܺhBAÐdߘK6eQ3vGja?y"I Z(H62ReEmٶw@U=75&Ih.[.Oh1|NQ:"P&*wq^@jbTG7$}1t] 3Bw[{xwx,:l`doO6"g n%X4fV!!;!y`c8`OW{B_O45\@GE$鲲GB@oVK֖Qn/4bwnzU 뜆u8M,"Duq) ڮf %²'ra}y]uoBkS\s0X-`(~57t^6y"mgGպ16cZ @UӬp\TY? B;w=_XΫ!4 sSwK*eQ^T]^fqfjO~({SYAbS!;3T?YI',l]Y81*0*FjӸaݪQ!9\`|jr'R4dܻFf'6&cNI5|7X8d1~)ݣHDo:v\+w`ag> stream xےF}BUn76aIA{ƪ-#39}%d ڭsK#_wѫkфINf$YtygypqF6|b9.?vze{֋%q @]2Hh)rQacQUۙq2`jqqQMmwek{cVVo~  ŐoƁ"$Д]>?uD90ѿ 19,%'7E$چNE$&1 +蟯f/brFΘsHY2oOʿnLeV.jOTRs1рng\* s3ҕz|PqxLҶx?tAeo!$MUۆaf 19u٬+I'aI@TPnk( NI\OPy?>9*2$9hIFA*.i4,UMؙRM]iRXx >ecW~cNFһ+Y9o-*Y(1X֋* >i|2ݪBX&K͔ _GKw_hi$DƏyL”yZR|Nȹ͇ @wIr>ҹ ~[~*|z@A]|t\.mLU[BaW83{qtzwƯ젰p"qZ0@)QP$|,UDZӖ[a@&!0x*nye!*&rEFq&E5lB|Hخυ8c(b.yoqF~;_M\?eL)PP:,kSfN{ʘ$? ._Ki>d ]2'EsOG8'fkƉ S''3/ˇ h {@pz@ ޏk\'mVͶY>G +pN Y A%%p'#R"~Uvv "{MP cn 3GY W.;pLeSM*|(P">?yC Yƶf#*Xf7KSuP>\a#(<⭀܄0)I +㴐l<''Y.{_g@L9) ͎dK2RD@) #[:>6d8\z<{r(҇? {a.v36žv EU]Ɣ I?ٲ^Y(%^ ղS 49"PR6RTM8}o8[qa"+$M,~[w&w'3+lu,U[m,֩4 pӓ$ikSy}Ee*G: O%rH1y4?A&&#ЭF&K dG5Cj9܈FLVdB|`G!i6CAޓ3n xyn[4,}/[0֥&. <+C`3Cˆ4aj:\E`/.6A3*(,ӋHJb1}w.ʇ 8aL]$P=(v8i|yEtkXb#Ai"MHwv)IIϷ=I!E~"bA&#! 0,njygki?X`tnc3̉mE c!i>cźs]U+R!!hx7KGSb4QAaF|հ>ks,W!6ɡ炅AJ&6B'qB>Ng:7&XF~i=F]7;.%>Y ѷv db)I.+Vl$rݰ:v|)^4mn^Lii1|o!~4' endstream endobj 2690 0 obj <> stream xˎC8EI9l/HlxngčD$קEjƉv1lz?i -V_ |qł˼T~CMun)̄nʾN x:7l|(T(+GaT6lꮦe3wz[jxf n_>{ZIGֽfͰ0WjnfV[+̹vT4`pxx*{u`|VO9pz;3@~D&Udo跨 D+~yĆN)V(>kx8i9*.,TR`'|4C?-reJJ[P"_N[ol/KR9c@I*3L,PJ땈CwL`eem ,'|ȕծy򎹝cn vG '2"^=ї-۪h5~Sw@gLlR"jeB#ӛ)q! >Hjj6U"#&.ٽË' D q.0EJၜK2Pڜ1{kqY~ NѹKPmR hU:Y Rۧa r;tȺ Ixt 2LMz 2I * `-+@YoWѪ?SVvZbH5iCKN {1Iڠ-rV+@ nxȐC%BO\&d!$>T]W8cs+sպzMŽMqW ⒲y\x]o` VԵ@Ӑ_uפ5ݫ2tPòwG.nWGٱGF( 3,YHɗ8]x#&@,bSGL `%^i H }-QoNvNUɹbǑ"ْDk8&S ˙ 6I4J^e r Um[wԧ(4!̙mJ~ԯ-s]i![*ۻBbF ƑA &g5Gb9W4~B+hNfHC0t T$.mn1љ.E[3an!0*cg63AM:~ o7O>~S?oQ[tlzzJ!2 g-bƜ0ZpӐ2 s @`7aB: FO^IJ7W%ϞrfEP .EUJiknZց:~WDNBRA5= GIg3w32ߖ@ 2<9Hp>'4`6c)[}3%S(%N~/ى(ZEɩO `э<nĂx[ \7RFYP¨DPhnCi6N;du31쓮hk@+ xX˶v sKΰ}HԠ;ꌲm-cκīJcՃ1e>#Φ pzq d$"%vgާ4j9./ǮGC[UtFP~BrE. jY'' IG1&r6i|OǁHB/d]V[$SS>Y ~Ѱ:4굄l= 0'A%\WTYUǞ2OG ˆ#Y^w f(*(X1l-}0}=!_nR`KZ![)F1M;)) K\Y3q>w0%"jrp'kWǮol@>I"$5<}WI k'0F*B,o}B}!&Vۧ= t \b.]Ɩ+i"g\KܱPꢺ2lݬ "גّoHfNf$IJ'TUiԥ͙]%oF׃}@_s0Lݱ])~7nL@dh8l\x)_3򖮁O丨a1\{C[5NtMgx>~Wq-t4 fkMGh̺ijz*a͉yv{,䠡FdOu}#N[28<=ymni_UmPBtX-kk EjVsw`0gϞ?;gAV/ZQS#'=5M xLLѽ6gl _e+`Rbl\fS{q#ke3q*g>pW _1:uDࡄ s_ҍ:.TL6U} ~uʫu:) KɌ@agK_1㵱/Oݙ~݆`74b~ eWQm8.k"}lثƁ{6>4.C2Vu䧒Z;ڏJgCmJ mš1Pjs3n4Jt3m+gg"׌fo K3F{_ή_|s endstream endobj 2693 0 obj <> stream xڽY[s۸~82&7@ɌNi6vY-%x$(Cqg";߁PcIMwP eP deC<ȝ/gsN~ "H!1 10)% a0dA(`ƴ!d*/^_|xYԻUVK^JB[R ,3tݞG@fP/jhSe2/`9-b/@mo(K4i Ljs~[-Y]` xjn?U>ȉ)〘/( \5G֡%b+p;w],R"Rl_yܽ0>N |g,QjNP@`DWq'v{@\yǨԮP`mFJ:ke oSA 19m"aVZ%]9g҇_@ZٯAAUڕ[;*FD˝BqE8lV*v ._,wne;޵6`) V݅Zҭ_6{~Tċ )QG:JEz:ZkAǒѭ=js[Ūjrnyb7b0*Psh8#oRsX4701ӜQoLWF| xA/ 7 VG7=I CgQڪ;-A.CZ.벪|tFlk4hrnW;,4uBfνcds]N ^{&C/7Dx;xQyz 2!si,7?mt}S}/BM_]]_\u+tC9R\BCaXB77!.FaIos`(e=xDRU+[UV0-Yb?i&LEَ9v>`V]wը%UX3ڄl[Mg !>i_B׋gh hj@RR2!=fu#^3'5Suûng5a) @D Vƶudα<^GSa0I Nx>斍ƾ"R_|j1!0r01o7#B eg5nW= YOE,43I5d} uȇwVݦ'X  4u?D l@54snEuTR}pbt |d&vl3,4p6qnۗm7<٧N|$(d@5AY -]GdaV1aR悽s ~ZDC>2ˇ]@Bū,T#Yrz^ +*HbB~Z6'9$QC 3'I>'2g0UWÖ(qԣ+G) ^\EYT0d3v?ט~f[{B h&18V-G!YѾ@^lFHًx ff 'U'yЄD"u /DCt۶2㡪̊mVdXmnF^\,Ex2MGh_\]n NnmDut^^TsW}b"2 h:-x;6aа_oKop*&=^ߣm,l^v@Pm~NG$s-L#2+&0d1ݦ鳟Gڧ̨~@) T"Ҡ̀T>DVy]kx5 d[Qv+*(IvEkU#te x[iYc,bih#0>U)0:-g>uBnlLbu<\Tt Q Z {Oy c2TW՛r~`Y"fN 걉>S̨xP& # QO)A8 endstream endobj 2696 0 obj <> stream xXnF}WCVɢд "hZo(jm2HwB6i \/s9sfD HQD6z~=}I#,Htu4" g.LJ2ŀ "|n̅Hx H]*^' a4bpFbd IYGonJ7E 2t 3}rodzg9I0yټ`nۨLD:t`ʱTFou2zg fˡy]Cg ݩU笨o};1M!DzܸM!M"7ʼnp| C, !2 6rdz&)&%qEcnܹYdjp̻ҘafJR^`J::-zO( `6\&kbTME!̀\70 [bbV借xT H1>i R@afSd*nmK554J!P߸}ݢ^:U[]ׅv!(jtG?b-7局D\VFy@)S$ɽtVzW&|3+)%Pn:PJ(t䨒J ]T"7͍{zI(cѿ+xP_m6n9YcD } [3 {/G 2wL}fz ,lw|mwv5C\;>X((l'd!qrji0OE}~Pfi0B1$LTy2)29xCtCq$!јS}j(i3BgCh2򹑊}HDJ7]SBZw]|Uu| bN$`^Rt]ܴ\,nD7xSwVPGenTzI7#cn10wZ'a!t|3j4ArmT[C -v)>RwoBh\By6!?JߟagT_{_x* Y7Cq>^̲+fk>\܉LqcH_\@pˋ9"3y2e*Gts/W@gkbBO %[iȹ UwI endstream endobj 2699 0 obj <> stream xYY~ϯ[l/~D8~桇ӻ]类`A A쮾jφo7ɦ3|8D1nH$1I6w4IQߛϨ%\۷czQUkY~qnm_iO|ϙe&OGL 7|㾉b~p.Nl\a͉&ݪ\ٸ{Vj>F/~w߿y_|*dβ$'2̟Kphwd\128W0wVt/?pb of<˦.µb->c\p$b3_(ڽ[%IawdCہ6z>?-䶩VBNkn|^*f ˦D0cr'KuhXrx(on;(ӄOEJxyjsBym: !gr#,#L@ޓރm3tRjdTp$(L\54UҀ5(i1#?}Xe\,9qM(4O@\Ǯy&T)PL&C|r]%w$bхPkKV l[OB2)Z|LؘY|qǡkCqpCc,MVI]:L 6LuY/A p|.SXP e>F?]Md%ِB֍±;;rLcOh|wBȧ#}. Z] t=O˓lJ4rWBZ*)/PP适@?I0NG׳U!]cvuj|k͈ bEG1~ն,]zd-%B匮EY  #;ǣG ߍ~|?[OvZ/=z :ʡpzy2ǸxW \9'B6-x̼*{PϊkΰN[(Zi-40|ٝ#VքߚZ/i. R}E|/>, VwB|f]S~ +a`gS"U2d@|nQv.!tU:n,bPJkC-ĻKIOTG ;Iۄ.S<61H%"@Bz~*9 endstream endobj 2702 0 obj <> stream xڍXKWDZWv0 YA4C:-%ԋiw"EUX7jڔagQYZg<7(ֶ<|<܌۝1&۝6[]&87Via XTuNԝͲ54RN ,f1Svftm/H0u: y℺"95g7{je)hP9Yf/w9AʼnQbkR.`Ji-[066ׁۏwMt yfU.& KtRyZRzL ^;]%O c?uL/xFYQ(8R-P$á}n  4m߷3nm- v 0L~"LP,0jQҲfiT^kE4~ >f?(x}V6Iپ&RX`rug lMLsrm<;]:5sO3IP֡. 뭷(qาt]ӖwL[e2F,}˴|(=A]% n4@S^}a&ƪ8( Qbx_ƛ.Dƨ*"[ Nb@dW6LJG:98l+$Ei ;9kPcZ6e%&ڇ a Z+i& Ϛ$m23cխ^;zuZBZ b?i {ZfyrhP(>oق}~'>0 ݌=&O˭Ώ[!A[0MV FfsLp2(hki9W&UȶŨ ;upڬbGКAJdn$,F&ixh8Ba*Uw!/;huGa桶w/ݛ1qdg/i@" J(Nl>fcAjɝ%X<>60"GJXF!c].5`SjDj^f5Pu~U&w4J5rq+-= BLйGZSxG8z?y`GGD󞙭$e8sW ltp3vu$8N" } q^@%#e{-=Lzrl&)+<0o' E-Yk;LL1_t|@ypKhyܵ7.AfTP_чH@ J!\ظKp hHZt,@[뼋Y-29zqxrv&HXVYQ1N Zo%n|1ƄY ѡ"7ItX|ڏtGy4sCIkx1{?vI-V/(?rZƇ,_:k7B}~}u됧/o?tnbpSq'9OQռv<<|NXE{NᕙqUx)p_ʆYf>FglTl%]|w+b]!/$#8:Tލ7tun.>cUowzk;Ln{OZfa;n?wBϲCS2եAkA1LUAQɱanSSȳOOaY7~մO󥓴|$g}B8GYC\s`ͨTSKzi򝩫Rr,a̓KP $¡.#)\cHGv4r;O E׼3vAop UXf̂ xԬf>{@YБjfMvyy'Y& ǵ.k]$ڳcpfܹ)I…1ky Qae*t%T_p}֐@g08d*n,iw"t'G4AJgP+"K V6Zh;Hat$1Sޝѩ:Y`}K$~C7n !HTWPى\FBk{O4/ϧKcqWLa8&GǺ:AX_9~P9ӾEv`FǦ[+ Ku&PXe»d$9g!_i*, 2|zݖ endstream endobj 2705 0 obj <> stream xڕYm_a|87Q&פ("EHmwCʒM/É( yfmW+#ooV>X|uŊKVbuWRw[ )1ٯu*LvCO;*{3in"OۮIFk*fz悕r[; HMkwn!+@3<ـjװVJ~ yP)f)5{hۧfܽ[,VfLGPn4||X=8a-)~mqaû3{>vW}0VK}ݑCoMشKT!t? vzXrkABqIb.cZFM]Ӈ=Ij~=G3іR]gTiQ*KpK?5So BW~x0jK)`Y6z*sl~Į5O )xpLazWWJd?,:5yM;JŠLYBKà䡪{$.*B΁#D|tn2 R =2]"ipa*C(r va;*ţ0ҳ ˌj$$J?j)蔆>wΚORt\8f}1W\㳤kG }LP 9 +YpU|5TH|m ]O 9ߊ̉yX96}@)SO5 o(}"$0L..V%3߄%G~qW9BYIEQR,%3gd$P,֗`G3wv}3Ө7-cEϫ- 0,ʉ`y9 : L$8TǣP&yM?a&/#%jz9R>?5V';0 I|W ЏoC]2)Ғd(Hj*9hg,JyPa.,XT0^"*z> stream xڥXݏ _lY}%c߮]^{S=xeclgg}IrlⰃLSIo~ȍr'6qͷQ.rod*u;8 ۆJ ?nCuCW58 whiD%p6QCOueR޽ #M$t\O^Bx0l,xy;g2Rڄ֪e ka;YCwk'*| =)e:PWJ֙"64"߭*D(% f]ڝ(%hC W;^ۭ[e|sBGxCi}M[k*88Vw XƁq?,-N*siҞәh='g-O3-ÿt7v5LKQ_ ,&,Yp$m"(|X9qgiTqT5ߡxB ,(!h!_箳8i]Y4M;LpVIpǪ.N"0TGf-*;-t'hEߟ^[ 4ZΟٍ(B.RKQk뚄)l `U,SBԅ$d5,JfPtf^g\Lkq<OF=.qI΅ŭd D 2KbIe|pIu z}JFәui#TFl72?<ҋ^v-"I-\B4Nj C} s)0n6B0taaJe@c$Ú봈p5(CyC9sfX?N; y(٨\Q&?Nj\E,νP#f1 E73=CW ;]?v -Ih{0w4SRSL״ yťGgKHtϿ~߾(-u໰^Kr)FfߒjqX,JǗp2iQU Cu79Q@y A](R-SF4q􁨣Bj@‡ÇKhS]% P0/ {7 4#W]8#1"+.jT5QaJ FL ~,QRUp>oT^ߢ\"*Gqec[7#X|.gɠ_'ç?#! endstream endobj 2711 0 obj <> stream xڭXm _!\?T*M/Oi9fhQȒ#_rȑ%6G3 |T%A"$'& DI!] @ypw?7?R8o>~Rali𷏿68߫HoU$ps:f%ppFRdq. E 6sk߿3X,D8WǮC.:Wa_ݨc_$l9d8ˆFr*k^lW? KAڲ}y8֖< @][_p*zKfRX侜,EEX҉tpMy-5 WCom-β]vvKT M:sԁeqUcLg3`P5`F@!P;Qnf[jcv]b"Qu_?:ignLk~矫HkZ:|ENʠ]0&Vb4;/ϑEζ4u"=]W[X$o+'pyss9!/׎{2P50iu=9uF.Zi-yO)8(g‘ɒI%{ !E,pF').4,THK"H#YB6e3 pײFdW; ~82H"Ǯ^~#6 }ݝzS'BW}܀L菁4VLӬֽ(H/8ʸ(<&֓cxHL_T|6E\=e-rD:Z7mZ4==#(Bºj5~$qUL]z{$DRʣ2"f_9ÞhS!99!s'Ǡ7`REzu.*9#Xt/OirKyU&ƀL 0&Q9>L[s ʦcR2Rꮈ>sFъ=xC@Q)"Yq%OCw FMݷgsճTrq9ZB׽%p-ozK@ھnk#s Gl;R&8Y2z I*1Q?nWFmLebeyM*+f4"W' v0iSƚ$4VmiyzE:Q@b}z8ok$G Ƴ4$SCrW%}9 U!1B%.x/ F\w:zkh'0`i:RD&Oe J30[1q8i جu:{cZB>1c9|btA[({|,J(򮤪pFN0L=%q" w7s^z9$e9'y:yoP%2! YMjN׍h0pkľPG#-UxV9y9gGCJԡHgdߥ:d34P*vtp(X(H_lLߟBFڐsOƖ$PG;IlH :5MuQ xC?7d QEL?i"ڙkA3 <J/ endstream endobj 2714 0 obj <> stream xڕXs۸_J{JMڌ&=R cdHN.vAsƞr_? /?#oDQ.'0W/tAǾ/+k8կ:Lt,-Tq,^0JUCP[SׁyW5/VU(yV4- 삪c_lyz8Y`%O]9`/:Ru^l91)+SUֆd-/?Ye۴kLJ4; MLkФ4#-A_(R2ZEu(#K횪j_Oe}OcOgjj_J*'oZ2Mu"&IwvM)_ ~Sv"LMsunpSv,ZY(t桉Ygx2tWa,.0Ff[~6hC{hT&;3MӠ#n~8Dē8i(!1Ʌ#A<8bCѯo]DYo/ql+qu1hNҘ*~RGbRv4\ĻLa ~@40|96K2 rq B9H"JFny`ɺL]Qli RtvOW%VrRBjIdUe|TrG\8Dqs6.twp=+:fuowoqyO2ȷrSr(|eDWy>;h0I!ڢ+[U,$3@,KmM|7aK9"f.KlY Ʃ+y ~}/c|،K=ߎxD> 3DvV2+?SѶf|_lR /sW}Xkc~;ÝPlāX?cb([ɒ3?xan3H57^r`$M~XT1!E?gڻˁfᗀO'G+?Q7f(5(f18Spg;t V2cKmCLB ,rlByA-IUJ"r sW%pr~Fc՗vA#SPR$y"Ŏuf&^,_o٪.qPb8t-e,.!)햖FћjǢ]:RPI6]ӳ`8E @J^Upgk ذ 8teK JyuB(4NVlRtlE ӛ'x*bݡX Q =\2(vOKt[0ٍ@aGPjƺ IDF9IK]|&"d2w(`7$-]H-J9`NLpn07nL˭h΀8?Ȥ="X'AS;@5'xwH $Zue_p!;sIjvlUo.v c01Iژ8y M(bS}G^/< j}y |1x/U>uNp<).V})`|Hˊ4K(O^_0?Iubrf@𚏈$"cb7`[&ﮅ3qO endstream endobj 2717 0 obj <> stream xڭXmo_AJ勐I['PrAtL"o.E"(d>\p ?%A}~\~eRf"`"."I_vmT[+:aNHܫq,inHysСUrEZ7p|8_Y*CZmqyҞ C8!6Y5ȘuqW ^`l; =1KÍZ',m*N* #x<1V^".DFG:C} ]+*(Dx=sP{ASq%22 ҙ+\wBjp`ʖLC nl tP)WExFrшQQW/2SO x8/S6B*NA;BUiKT;lLiVLR.拦|. }@hN4GPKbO4;o5)C2'e\|.yK(6/nSBi9mM@d::Zю1lwJlcO'pԮ~ɵŲ =@b:̯,[T ѳʖtj;(u>HIxoV24S&I6$VW?_j퉎IJ?a58n画MYbm, 1oW#-8/]'G, dIT&bX_vM.3eaa> stream xڝXm۸_al>D"EeM E ESE"K$goo %{A  9yyW|rd٭߮>OX|u]bSVbu[+^G_iFB\_RS_"˿o\,@6)nWҹ8ee .-^JH®k4z60~r?92rjs aS\5vi..6Q˧~aZ@';=f?j&Ɗ3%*K?}0cDTļ$xmvf5"a"aB 3i$)@)X^VHҨ53ݾd9 8_.@TMCxsUD!Ct{TӤӦ{wdy.%!ƺkO}c`eڍn5s$?mp6@* ( [eJ?f+E"bHP[@ Kyz.|CV8,t;hJ,@ݹ'Vum *z_L$hI7L˹蚮!R0ȽNV^2=C}4Y3d60thRgm}0COLs8.lJA\hT9bK boi &-?it c`z`Y\N~0PT8ݺJ zMٮC[I8+_<*OӄY~|7 4C:BcڻѥnKmdsBkj6Ը:N5nߨlJhS A'y4{޹ؚPpNJJ=` `*+8T>X,QkcG<>HS8"#1/k RemECKQ* bf<&dxPi3ͣٴZoߍ 'z>gR-j Dz@ν:B_wӟ߼x O?OWHzz[ Vcۈ'[l}BLf~eL.OOxE]R^82}d5մɜfӜS9 @*X)!D]vMj\EyDk 1Qm{m}![G`} 2ElvlWnq7}??`A[>woHp\,y(lhJ16|'3d6A{]p:%tb_ڷB;-lP)+rKXGUǥ,O=+=k1!Ef,kQO|V8&2erpSiQZvi }nSk[J=ޔxJՉ:{S fNw]x`N蝨([.FzХJ" )9M 1ו5 Fw^KH( ,RAƩXB,r5W& at1\m;j ]a0brlfhŷӊ@9S|B%gSMN"dbO&p"?xt(E^p%3`p.,=#{Ca4b?̷e endstream endobj 2723 0 obj <> stream xڝZ[~Ї k^<NiK (sb;!)L6,.7\O+bj{\}~XqVjaVnCXxǕl _cojRQ_ c[~XoD[lGۯESnO^q\ڸ&Qlrk QR7U-oN0aS~y1gzߍvגYslMٮ7pNB` oZJWVø( C?0%u1;~kq/~G{;<Φ;-Oz&Ou OoJ+Yx-OatU/Mx1A[3-l}7+VAi'ù-/?oafzSsረ͊:罙dN#v7ffۅv& iӂ.ՈTK7{{8=( ]i6nړ4*y6z7Sx bG3mvP^DRcDh8^5Fo<i宛\ΰ%A"$(spOq<pqPhJw=w˷@ZgL  㛅HNm~ܷ@>"DϏGk%j*>f޷ݼі?z(`ND`[ʚvTӁJ lKp$4Exw[{xF#;9+(8h<U34З9qT B_ٚkv4j?޷rрêxܪlڰ;6pwfZ*i\Y9DcT$)U ~M,Y Z*e 2~ab/A_PS Uեdo瀈OY]NŒc8šT9r r F<x˦dZ[FOjߵv4OA*?[(da.]ywR¾3>LAzYFoV24?B{X]exv@3U6zْsࣤ\p,o!+IGO4T[|QوIp>!N Q&nz؟qj{"ڇ85&[{R8%$A _#_j@ےk,A,tzM5@``;O݁|t1#D KG{Y?nY-5n gPϱJ0ߺ )yŝ@߅'z!JQyy_@ƑP-vS!ϓ#`8shXn7\ǧ~ll#]Q-!Arl(Y^}=>c}6&{>zw4ú*kQ?ASk m?ԟˬeզf{{5Q/((~C~'Y'i`g0 POt$}6{GԘ5P" J%bH'@9m;T,˯W="w;n7"@~^;Dd O8x;v$BH4uILMA.qb4rD#şu;!bՒNI1/ ,*`c;Bw8t1 >$WH'rrc,@0Ξ. rkCy}890byDz08Ar aS." qK.C?un} -n$` 0wn9E\Pu18G3]ϙe"@a.QHzgі 3VWiu7opF} Af4̏"]AUhGaZ&L#s $}Vi:09Pp?OgՓ05'_|q9pдu8q%F d6FgȲjuzC5>)V6Hq𕎼q`3uLfJT9Ӈ (au ?F3FR/ڧ^J1ovyيe  Z\`$QKJ"Y-^H8yL[~46?d119 wZ$8BX2e-^XxᗔWqIK7lw#clzQ,Ū2\\#>:@yN`M ABQR^2Qqhv;j{H l; ;Xo; ۶T9KE[->P1J넷ӛxp|œ}`d ,U)/cō/";.%+SY(Ѥ!,pWw+@ᝅdP1uGSBzw3I4hބP a[i_5L)lkb\*IHt1XY n8RVTie[\sxʔԨЮ$ -׍&$J ղ"jmomrVMGі ݔ#%CQzbIU F,xLqi%(O{kDb.`8y.@.1W ?&Y\iB˙T@le)TAQEʟv\ ,yrR&uyu;)dOB+'>?U'U'WWHڡ=UH$RpNq䎺YP3m%B ,HfeK "X2y}*\M7*,F|y˯ . endstream endobj 2726 0 obj <> stream xڥZ[o~jr$f E}%&*Zco9s#G2h8:s\sXU*g?[m_nV?b+2+fŊrRbuW:uN9 cTo5|Dq;eϟp*pWbTB.ei yhÂ{V->E|6}oTS,yj̢cWx4޼?{Vی xK[R2ߥCJ)kGF}Zy5][FݘX+A.ma5Q6RKRPLyfpݙd|-u93"YKtJeTc:4QZ\ݮ`_1RI=X炰ou_O~}~Dq'h >ЎQGgͯ=n]|[KTyOYMgc6%3p Q$gNĚ,*%ӯ>5NW^߫q_;v]F3k껽=Xv9#``iҊY@t^7`Ҋ x|d3R;#شč^{P%LϻUZ ì&*]6(00B xBnk+Tc0osګ)DD{u8é`VT ]jHY֎t +h܂ K''WotoϢ`XNh =;% :zܦ!mV-Ҡu 2󹯻F[jcD*f~GLE( Z:=, fl˛!bQL3`ՕdYi Tr 'Wa2UFAi $c!zJj7G-)=iż1I÷nt3 ,ѕ9`ܛ=jY١wBԻu yX޴wTl،G̸t zo!?'OJcHXMg70[,q|aXιg4GPfin{gMBU}SnIDOrJ) e> CM}t`[B05FJH1&/ۘj(]&RWj+nJNKx % zsSϳ-srg o`%;q' <͔,Ք; ZUYeqR9FTSہhgRf7JG^jyv Q~fy$D KƨRU_CW@8q"vN`V _gQB`Qlf0a3p`P Xiͳ׸1 R ;a/S$GR;DQi|}>T}YHQUsӰq^$ 5%9g0R]j5U{]$6Gfgw[`aIMA'5Yg0ThU5"ԩpoZ B mc\dѼ v*#+ 0TݍBed3EJRT^x qxILL| 橥 6cYm`m"YBLnḯL^bq]o`ZJІvַ!֦p^FdO]_k*&7F|p@%:ަ"[VLF( drdb ۣr.au˙ieW\SU. <~dw|T (1o{\ `GU"!DE-ff6zhNKJy.3\w:/4RWA3}{^` +4b *OV~_W}3BWjף|2W+0d'8`1'Œt~ t/jA#U@w(bP7(_aa3$۟o endstream endobj 2729 0 obj <> stream xYms_r*t%o+.{w_|TU[ȃ%7V1駻36 ij={9{sg, f˛fLf鿼8_m6}Kʔ?~*q,fCw?V%vsH}s&K/9~R~ĤY;y'9Inp%}K(+1[=>N]mtcI;ؑ7x 񎕨F Ϣp.yɪj2wJۼZokmIA[nt>-rْk fW3E+05NɇmElgѭ]9wyCn`/aC:U|)'p/O֛"[%5ܨyT|T\ze^@y'CUuU,I6O| p=P${Rs?nI'jCi+,Ϯ'.gYpKc9.]G0mm];/+%3[ɵqUmo`L?h\1a SLes@q?L%mȃK&=ZFi"xirh0G$$d?@ jub`GoUϐ<-+;*nD׶#:&Cm(mA`u'ZAERL42 wAoxG*myviq<,";ǐAa90ydL7ZdQ;rAJ|2@hHj NUbؖ01<+7ˤ@!D w-v׼L`ApRD07奈u˴hV (v3YJl$}+i߃t޺)N7Q_0)XlA L:!>CϼH1~ ph@nOi§ PZ<$ĀEwC1bg(T ".  jpg:/:Q" u4l:ԔFRِqҲ|eI`D2BHNPGLw-%`_\fC+8boqx~r YDTN1d.\mFBY ,@IpA2$[tTZY)a14nLF5id0Y{fYp/}IFh3odm6Lsl=nWFѫaIn E&Ydn֍[H(: &"#! rcυB9uIȈӊPໃ&5@wswP@C:B> :I|Ԗ!}e Jl=/`WM_nr% oï`g>*MmdωWtGNTOhm]iS|Pl'q^_A?=O8ik>l-u7wE:h)q;s|j$9,5}1QfBdд8,.=Ss1Rt̼zˑTHg&D%XL']T_LbcX% 0&mH>:)O$5f넁8kN&5.ɥ5W^4hie7'&с5͡nϦwg:Z`37~x}>63!g(ۢͳݾAEU5^O ̡ZLw+OOv8&IMTc: wH"Q˼\N{9ʷG #||v_B ]7uyo6[ ]<RʮxtTPH`'zt1,!;6k8f5LL~d #FM99#mRs\!Ȟ=[ss>}<ەfGvuzo2gf4t@% nTP9qhԏ&vi^!0-~jtէA=bm}U:!^l4flf]p` ! OAG":`_Z'_Yn? ㄃oh=~$ /l _YP )ӽhHmk+ ń e_ ؉\5V/Mkh P=#CMƔHa@ˣ9iv&w(bge~zqʚAA++6;D M!"¯J}j*Їԓ<zwBZn)* ЬY^)"}ݔBfy:?xW=?N5!=A=IO{Qi}MR4c Mk2F> stream xZK6WV9Y>E*46h AkɶZ[r%9۽oCAb0ER3y|3;;"?I 8ZEkRhC)W"=fc1/fsysSV3*cLjmNsQRHn*7_c Jh0&f۳g1o,nw{iCh޿n!8@~m"D jL٣P(Si~XY#A]m4K$Zߕղކ1X5܆C[`><2]eǷemj z>L G`}}`UVmӵjŪSK[#(ވChl*nKpFdS&&xaZzVucefrݏ sBD!{arjmeggbݰ  t"rg&Ph]yٕuW? p:k2TE^!Ãt?>˗ y8̆84aP>e*09o]j7 .eA(pI'Ey%ȵˠ#rUL0Off%ʓu6eQ',W];C""|:Nzw&RG13W2s`S0ir)l;j~0Iz"4V#Q :XemgpOK?Jm+[YF >At:5yU|9 2i3aʼnpOS(JA09ծ[#uZ[}Ƣց{GD/e(N l`9*n?.29@< N@02O;lv! oi*Q Be2FkhޅhL(e49Nj.-s 18|p.*X sĿm`g(FBk #upcyx-z(d{.FN-Ey_pHJ9Q.:=iK6sXℝ*WƐ$.D{ܵaף;c#tNf%kW.B'#y(ጓSO]8 'r)LH "ul =G@Pczrc-ԥ{tӣh{TG/j&M<1Eո奯L3ْǶ;2:&K #8}D!MďpYR,\K]~וw]Uܝow-6(iF/ZIN5͡lag ٍ،3};Nf='4ӫnEM{𞧺̙BH#MhW]=4(I-'xL᝞+> stream xڥZێ}WQF)e d;`H[Vֶ<=THln@4YbRmk?=6QpivUsr*O*)@Ԛz:xQMVG u~kfVp>wu_quvtX ]:rl:},p.u6A2]9ˌ+H,!`|1_,ɭ,BBFPw|k#6퉜^00( 2(vz@@LtG^-baJ`|zļ_23;t`2qG{ ~Gg }r \*e "m3r5APLhSZw5mvx^z_Q73€j#iJF9`dVPÌW<WS08Nʖ*;lNQcw{j';H$yҤ4Qg4%SyN$&1T9\͙.';ӹ[j~ v4S/ 2W0+=I@Wj-烙 yNT0[ÂMc;92}*"a.VO*FгU*z`( &]d:" 拡@t}v騼/.Ř:tlàJ:_Q\?`p\69c ( [WxGqaъ2Ʌok*npfjCJ*M=ca-iptL;IB"x_BvUp)EL>=ХHyȽQ/ԌFc8B}=0av^Xd|`Ҿ=(d2MbbhtI,. :Dg/P/0/W(3LKnj^{O>Y;LjƱP&UF>u:d?Q ! h̜Д}~›СwXWWf$W5c f^KrEs cȷWjNU"VmLK9gZ|Z˫ 6gR[(檷JMNBGn|117%-.iottFgB_1+stzZKV܎ 7SHM". Cp҉-y:xO}bm{i Z ]dT(I;q88( hX ,*E ␫riD_ = +`)Rc"f1c#&551Ds X n<lF] iGO ۧc )HZJf; Ѹ@w04cl-ꒅGEK12hM/Ƿg`٨C ݆,r)'!V,]ǜ//27VĴ@c!FeY3Wl,4͎-2: {xpBOak;{\ΝkǼ7=C ڡr)XsOW 6IU0lέ ,.Js@!#&7$Es |wgv6ꞽ`93[den 1T,Er<P1.U:dZoN,ৄ AptJ=P& u㕀HB{RRaή_]o:xChgW'ˈO&!|w4'5АB:^`q=s=~+U7Qh^ ?|{ ,l#F*ͱɲNgOA@JH Տ4\[A1mڗ#J5&gW_܆UL 2W>eɑw]0.tx0ţnteCKn]IGjX΢U]O+,!F%L($gohM( @u_-@L^(.C aE@|Y~_mݕ Tq? mEdAՁxb9%E8/nLj6=݃K'1%S8TV"Mv6;%w)2{:^:u~Ĕ46o+w}gˑhȠ}gY gZ;ñY >.!ȃBqi7 `Y7"& ! 9 sQԖD=6$C,%kVkUo⤁/LcMP2QP㑾-hi5,|/~. 5֋O @`l3\ۗrƼLS2S 5 endstream endobj 2738 0 obj <> stream xڭZ[s~УX q!&/3>tL$Q%C~{w IgұgvaX'Vt=\4)B+aWB%ݿy.ϝk6Jm럚t'5o+-(s"}Fib "BhQ\4Web]G4R[HT.&2ɬ&|psk torvx2V󷭏J6*"~!EnvyxRnݳ;њU_>s1;鉊0E"0Yd~}KK>wU]+,2߸GȒ\en_wG<{Dވ~~XSٹmu,)w+ՕX*c7 K*;pj=Sz{ԉf~DDQdD6Z$nxYyn.6,dir/=b,?kXYJeRճl/ DU6?GHim\+oZHiN/GV24AhdF@}sV7'WzV.k7?a} Ur= )x><;B{6MR0sCAoDp .Y8%* esx:(Rx:^өOtň X/FuUZYjo(j½-`?:/Wl&3kf;ty=#t"-3SI ).7Ʒ5hy&c,^ CAJ@*nښ*HV>kG7k UT]07hd"!Մ긛ݜIDHF{QWroIP֔A~kP[Kˣ_U[Kö}H`ꝬN62a#%jf_natwn_^#>mN!_{eRh,I^a۬I6 1\f,hΗ Q]:7ҝ/HEZ5ma&vٹk[+pRjK\nwRAk,[̈hXSfѡk䅚%~̺=[GHSۺ-;+xN؎izp{<\jtˈg7w*h׽Ti~*C$z¤t9҆/~Hn'nI1%IH7ܶiFAooÅt#W΂Ca 6nƂG?#魞cnWyhhd|5OL}Z;mӹQ.@͕R8b aLq$cn珧8ø:虂_7!^06GxOQ{ؓ/;v5ڟQo<ÞLt?@'ERzB Ћ133Xn PLOL/ٓt@kD&Ò$<ܮDU`AxzAN ˁ~[fJ&9*b |k }#LKRPGaKGf'4]Sy<"z0:fGRkI40ط u9o `y݌pz`].Ƭ;FKE1i5D16("vmfD٫n rŇ^CҚ C^AfрBtzb'dssLqAV6: dO|?\?XcMQqrLZ9P 9RS ,U;JіU>In&<\f4w H`I6w J$y/CiQ,`E~A%'4B.ƅ,38 as?}+2Ra=?6`*4U* 9eQ.p1Bk,\ ]ڻNƂ2LUy3kMo(-cL'02d:(p޽.;XCBu J/J R,<&Lc⚅DVn}n"S`D]y 5>A˧ /2 2?CT"uu[r1UyZ-e,h:2aۤjշ܁3gzQ8l &7xnC3Hd9ݫp5QH' oa8#B?yG IshL|1局-M֛vݸsZP``8)0\%I9i4Y1.>bב}?U>RxC;ȚٚhhB-N_H߲q@1d+;/ע@UVGh`(E?YzѼYdjpXkI'I$`7܀ dw]اuu~T"R(2D` Y5j9z&%h?|Vb5>#jQ*MDo̊edZi&SHH| I%_ӷ! 严֊]O"#.LAgo0yefР$(~K٢_ $Q!D})E'YJ9+wy;;.^rV(aWz+xGp?F G܎\4Xct`i34!#RsDijoXSFN/81ҝiGNOxJg1ɇGd=jwdyrrnG2kC,bԮpUZgEҤ`}yz,_f@&6o>ͭMg /]fq*Һ ֐γɛA/{nwɃ *!mĉhU@!E\z+|(ǭŝ9Jm3EQPLS^ʩc{v1 GڀaHz߄MU>R2s6Fy.s(hl%TIex|s($-\ _Ǒf9]{gE\ vQ,}ljy:>\n$b5#,D0`ZS, xgXAehQx ݂5eok@Yx 1bOCj MX@4s)ToQ=1`!!ye&~KG}zm Ǵꎪz|!+%fbYsyg/JsSLV(N/g#SFNh:r->k!&b(pr* Sc;<+(g;y7Sؽo(;;! <Cr~^AyP$*~q s'Vœ endstream endobj 2741 0 obj <> stream xZKW(oW6d, 9@mJd#`1=U,<"ˢ-Qb=zP /2b]a^,x̊͂ .YC?R,6_XQV4xo4cv-Uc=wr%h}v)hoٕ*XΕ!_zD_J;7/ڬ;>e]_b@ΓJ u2M22tv^ %bPu-AvGf^ DݜILZ"ve_n[}2V_INF @{ʕxMfQע :4<8陧1=쉴.AOϊ9n 0иk= e~ ׃2\+*Ll: l六r@ʊLVǐ3&Ta'b(T! KSX$3 %c_9 +{m济IJZs{VVnlAI~z 5|뫺EQ(zkt=B[.Yݾ8wvj"cxqd#rYA8g(&X[C' '1qAqGvB < yp|MmC: dG-xl7('3-cuZ J`&3 kdƘsɄbtm@ cnUW &2g:xrnW=8J Qj?Z>cŮ9XΌȁ-P?4nΦƑIG>|Kw@ǗA pݞ{pcϥ.$KSq1( C>%uP9SH)怪n!hP >@V,͜Ea\s5,$Ѻ3d:Ignf`_rZPBd+GU| 2K&|sy~/ǘ~@jS 8Oh"m*1e$D緿WXo u祌Ms rcPX*ըJҨկ`$c*%6nOi{ nA>2_|&(7TuMIL^uuI>b)'ѨAm2T|H'ۄ2{6'\Dv. ҨBޚOߊw0V .YL`Y9pT'9fi˸O 1.#E6K+i`*S [[dա5"zw땟%T'g:'g‹> Ϥ3TPޒ|BG?؟9!Qo5Dl$}Bk*Ц% Tt'"fv)7 ;0"s" tx fP]@ :,spKi0L UD tqUkdŨ:3윂Snfi;bvfɸY#MMpJ1(۝c&c5aU}x%RXQ芜RE8nk"jڎMq{:X!֮A80L T1a&v="TT>=eػҜd_ݑ7Z&)핂Csgpq5SX}?-Ost=.!A듉+fAj3j} \𱤪pd|&oMddJ?;2 HyOTxqTLH?Il~ ֹIA\žfjZ'H=Zl|>ix˽$ bڜ::IrsW]u 27U^5+/;Uo½%d|Y:ӻa]6\>rFgyf$vv]9 M=b J)LjZbbe.)\=t/yU.,5@ʁI]9f2E}ϝ߿_789P_ 'gRdTɩih]c03}SLR8ҁF53utJ(}V#FI.I„.(*w'*(*G,0 E7^> Bi #wA>zrr!PMOG2ȑz$2 endstream endobj 2744 0 obj <> stream xZKܶWC/>J7qTT́2#roO7 #pgWThtuId%awF$qbsF~OqR* ~Ff_7Z8U)@OwJ;Nsm[)c֤2}Cd&k k?wMWuF%QQ"yzVd0?W457~sE )#Pʹ]=PG'=VȨ/tTFDR]<$t8Z\4J4\K7S>v>eu#ȥkcV,.d4"I=K`)4E, ęĶu7CC~m/zr{.P?:D Q|M~,PMsy u.ȥ8<.ǩo~f+MW'"~髎'd6e thʔd!i(,]}(z8OnDMS3R7 9UV>ܼ ,6R)R b^,;]$2ɢi)(9>U`' ), Iة)΢QH4;,DM@4EoŚh$Υ\F|U1y!f"/JriT{%tTU\՝i+̵HA@R8u ߷B{?[*rRğLM']Ib%ݟjܢT-Ȍʋ%|uIt!\XGZzY͉?`ih#rE6-L2..~ZK5}m5v<+|\{Y'-d4Ǧ)ZVSPk3*X: xzeBg+'A=Wdlr HZgz`IPAK=0~$ 5cGBPP&&Ap) {*.IpZق.i'pf;Vbх %jÞ(;QoJ%]:uo)Wd- u Sřq -MwG|(NAiF'\ 9b,ʧO{~ I".˜Y.~!b}mHNbIJ<{ !yKz.;YvkFی5NJ-t5H/`Y^LOb m%k?._;g$0+6P>PѺm<Ǿ9jwzk&qB_G\Y -8 ֊X}bky5EOu;`h&"V3|@W;K|CF g$Rڼh^ч@Uv?g jcv:#HJ07!z %PMa"B/C=ZnWIv #e+\muFL%VK?FErjY"_d/߬8BepXo1Qa](!HYbג_i>C(%=ل[%WWf@&E^@'1Zi_H&2ʐ6 {a7$ƂAю'YHL0dakx^&ee֡єGg]8G]n$ Hlf6+OgzKuVîdh68Snwoq1$e>P:Y-4s}e_ϵXrh-#ѿ%?G6A82ϯY%; Ŭ 4hp/דO9u*0jzQioI9Mb b'MdV\6.&._@BbNi<@ & H}vIh0K.o F os'-en_g;sh}YK4D*,8 H+Gk|8So+L1>-0/.sCha>-Î~E磗[ )tU3hpnuFCޙW L$_a+XKkie|mz{R)h6|dP~zRpE+;ɕ ev MS+f6:oSCRlB 3 l01ӤH4_wP.@=F*8yS5wߞ}T#U|Zˆns:HQ}ݏϱ\{pvЋ뀓@a) O2_Ĺ;> stream xڕZ[۶~$/TD AbI;֛C$j1%*$e{)x$!sw} L_X.Q,xLbvKfT'2tb2qFZL7jliCO2Љd<~up9mnɖNrP!j?ϣ@W\BmZץ;V}{b/ ,%8セN,_ôӻդLCb.JuD7E{OΣ#脃2YD!wq.[A7}poxl.:_8 .cG>L`&V62t ؓgzʤR_lw~idV}y _#&`1'Op&7LКo%":EjR^8uDOWѬHC>ro" `úڦ!>.SMZ .i0w9 9فM X%g6-+{+{ B5lmu_?c[KoXcU2baAv}+mٕ}o%Yt?8&q;\Tmt`?is8K Q"ѮP*xNϞqOs)F `Fcnf?:1]-m9 #^y[-hm pĩXjr&V*ǫtn2YRJ#ҖRI[k> ?&fF^򨬃1kȜ y?8z :q%x4IQkp s(}Yc \@i{j!7@fλFfKuծ5yoi  03dǹ,ci>`Ǣ7xƲ3 ]\Ke0iwLXD /V3Zқ g6eW\-8fx@TLNpb7?]]duP{nIk)Jҽ_6(l]?d.ĸ×!Dxb)H3 iξ+[6dp c2@?lMʱ!sz;)H!$ RK$\$x4*E-6@ k0hp[/'Y-M][DQux,$-~~6i Ra+4H̹ znµ R~ZyC}5x[~ {w sp#(0j 85;Eˢ ͐ϏswS-ZKXa*)1_gg JMPi˳$712}ecitGWyיDqL;mU3`Ƽ|3zL<>l dnWX J%V1~U5Xqf{K~\ܤL!nYB p*}(;jՍ5%ƧocO7I!R ن1| &F74%ٲwsW1"< Ep%N%< S\Z (ߏ%'#;-dGXے[{[ 90za֤xUS^bB;Ksfs *Oh%X48{cv; {RR>b.'Re`EeA`x@2K/ r\Dp,&u6Tg)u I2oc)š՜%*ة4OI&$T ^+n''b]$ȊP&HE :}Lbr0#T@Pi2ʟpa8GJ ]~@W)wE'B, A+"Ԗ3= )[^jw;#8@12_t.|۩z$0% `nb8**w|$vXUSIriZi{z?mkC>?&+޸-]ʝ'.wƓq?{ۢBl,oW$ [V#ķeb\mUcLǎߖ. O)L'=Oy(QK=YXvx]zbE|ֽ:^ӫo<4u"3?T/űiA9c];KmXwgdBH8tF 3ƽNFݐ <0X$~`Q`/uuR e"y _tyk=X)6{a*!K!C}%4 ֈac]@BV;ȸb%;l6H#!$>2\ZS5a|4{@ߚIiOw:bP  P o@;&An/)d.ϴ$h<}ez婋 ػS!)$۵9#)|AJ6 2~rt%♑n> Yކp,{DHD۶]@apwNP()(uEMj? ~V;7o endstream endobj 2750 0 obj <> stream xڽZ[o~06/c`+%( An:C6-&&sxH4KNkP˹~t2Ϭl;ٛXg\BgVޖRʕk۾nυ]/8S\3# ̍u^\]8X50]sj3]K5n~shʾq\)jt¦jo[:AyuW?%N,mƝggknWkX]$0rJD+sO!s:k-RnƁfn;0a]Rz0@ԢO`2 K4xc9UΔS㉄,V%\Wx+zh*GWHׇ7C 4M)U|2 Nqm4̊HQz{"_ ӏ'/4A?aG;[k ir[vu[(⟁=xoA ˸V%qJʬaJg֜i oi%}UӬѱgtF+VMC#<xڐ$4jbF*iakTЬ -=aOMgE);\¢;H`^X/?6'p`b,eSG,l Ko:`4`!THΑ_WkW `-XaI:9ֱ+hG HU9i{N7}mί]6lr0⠬Á At AlvǏy"E3 Q x#6ȵa^wXFn%-͈&_Jaj<)nۤLl^ 'Ir'ɼTʭo`cĤ`Fw$73s +VdB{ʝc9$W4w/NDv#9bN)LqdNr~16 ErLZI'RNlC@hH=j7n}S Lͥ016dYr\јdt1`^@?8C~HeYi qk:z-ǒzb,RxtaXTG]><\7.RREZ0]H܌ PH<-#Q9Dgmjbͬ+j?$u p9,R,Kís%XUPXܔ~z!U< 4V خ YrʑۮXy%nfZ"GONqj2${[]>‘;!s^{dY{Td#d)-Qhɻn/S  MQZC7))y`f]`z"ޚLb& .{hr@nDVi}}(i)(" 75T-F_* QIAe:'QFl0~.)Ԣ`6k,.<1$Qm+PWCpб+[Q^@}AìTSYTta8=ΆRq3b^3y ,tL_7iɪsg,0)Q!t fAW}AkK##fN2~dU"1QjI N~>;Wt)/BATQېu b&'ʲcf(-K|nCVz ݙc xC}!2ԒMxd@BT .T"3mB, %y5`{.A{v+tNjg##Wiy4F}º@uC8ו` ;0=uiA0^ +I,8ˣyux# o푌/lsp3e\Dp2-AP#i## //fkAe!8ᨑd@^͍j MSaޢB '0NzzI"ɍkY]we/ȩJxkf/ GI.=^Z?<_ y endstream endobj 2753 0 obj <> stream xڽZ[~0 5W)ln Mf>t93jlɑL&{.$%,3h:<<zJRBVY~V2UZJ+Ee?I%7_V(4oFk_<;&t7}Α6 3Dd3;Ψ>^GZ* N'^:˒zx[aOײNҀR 0ęS:g@V~͍!3pi2fXiVYJL,.©Ff,RR(7s:ݮMRXc%[#ge[Q4iB*#tnיL=8~d{\á eFr^ho F qF湖LN)%7r[4?v]]@qi !;< &Ǿ@2aR3($Ӽi; |Eܼqu54ر0nq ٣ZIл75?]pYbOVD=>|pKE:J#s_^&3=Gp,O4Ľ|ۄDw.@/dL{ Ty>i]c$As$ۨ_FyIzKc֢u|yv>K,p=#? 80w2q BUҸI)f2\H+ʘ*(P|f֍3%ѝKus#˼ > 2VS|E BV~)R3ū_j`Z'x|D>*jpB@v@W $` C~oQɐO-036)2[ˎ,.|#S&ۤ$)xŶ,ڎx1cLx Åϱ 8Γ!WryBد A\ʲ& q &eQ  ާ$guOс.cYy2>#H((*n;" @̲va`BB@/{鈖<ɓhv#/u?찌;4\P5g3 .Դߟ +'JNpw.|P!N|b~#NOp;m܃x)q8%1\.+!}m? [AU.-(9ɩ~<8\-N?@>p$ ֱU70@g;xV`B)wgl54BpW9g5Q#R̴,&;*tCmN)ջȴ yn Ln;]Re0 `0O#"+[QaaJyY+CK: 9P{1t ;\rRdF=p.E.%{Fq Ԝ7⍂epu{U҃ o~~sK0X8T4*n`w&ݿ8e4vrߴT&I(3T_ G.Fg͏p΂ϩbQ֩4!PtϊRU6PX#$:L{;rI3܊RYrj-eYS+ ]SKފ2Wz+U[O\SЫ6xf .QxwW@8$C}px T Mk2HG#H(s1 E&UI ٫gxNPT\)Ƈ#R`W UERYN;Fb+)1Ygs0 Dp^^ uq5 ͷ_@ _$z~Du {?;mʤR L2L]{*J}(A(*yMw]FSB%";6I͎ [Sm_ @ ލ h϶ /i疴'ɨžJPTF xKs^i}/lwNywRzj]8Tzފû`B1reJ\J3˲C]Fe]<#V݆" hA%SS= TlHwz[6G4r%/h^RGOE /:S !n1ud?~Zv endstream endobj 2756 0 obj <> stream xڭZm_a(*_όHJtWM\ mf~ȦFs o g/C;5" wJR'WVt=>Y}Fd*ʴ,VR2+V7ouԫ&˲}ݮMw7_2 ߔRMd(d_>T]ed=pw8?<4ZgGoy.W"M%meR,/(uڌ/a2Mj7, )ں8~NT5$Y*aL-dYxWNoun1CuyGmbU 8w*}T1Bl 2WvzCyoٺco~$mM9D:n7 wh܇ PciO'zpUlblYMe`:$5B*$l 0B@n$NWl01iH0xb0w !@'߃\U"UϺ3.9;]9ٚOvӅЅU.#RziJtrJ}i.g!m$iPqn`>9a`.tJƢt{wWʽHxcb wN W/؝OK|0zN|0[>Sͷ4Og =l+45 =@rЬm^_Fs8DcG$ UK ()O ɉ8BI1v>Pu`KX|E/YmVqe̚b /g۠F,R)Px,u@}V H.OAaBH3|u!1w{C o΢!v):|2r<EҶ8$h mhԚ=C_Qz t "5eoֻ ZE]4Bؿ!dvQᇚL`׀(媤O8`o!ة}CVrDtt;0sU B bf5p-0cLSC).\2?U}utSr!C\*5۳Rj,PD`J/ h atDU 3b6&F- s(pPlWR93} $ p`:P3sa;ޅ *Yfd5cGN@ΰaY u?Uʾ|]CtP~n)cLXYܧJ'7)IF5! uEMMT~;4VJC͏!}?zs1j;2wޒ\u͞A,^ؤRçk7t gmK{\5}:%_˹eiE>&ݯ__XhE  .Z_4ϵ= Y뽱z^D6Z,2Bc|u ([l99,tiǼY7 &Poahϊ5D>,Yxx5nJd"m<;E5޺=HNB]S]מ) '>c#"ZkΚCdL$  >@cfcfX|ι KpyalpvChH[(X)9 RgZ"&Rh o_eQfŘR$LrbG/۱):l6ܶn792=C"|f`"p66~$O_E B͎0]CV Ǵ]e(#7Q<9ߑk6Ti)tnFq(CooG,BeHjfy JSP sʘE!|n,Q %ٔGT-B8ETc|;\ucS"vBp;fjrNu dc_BE23Qd/ѥ\Wy(A!U-S]ݟ/('KolШ16{q ^!; -fDj!ױŬ(l8ַ7uczbss7{yخM8Wݾzx?m.ŎQ”}2 D2_+I N06J c!BC4P$!j}N0_g>a`/CB A~m!ĀȪPnJw/fkUjPp\B/{ljϴzF`,˼dnIo:M?YJ4K RY@6o0~ћ#*`-k D zxjܬK(bb[kXzT_FEŬo~ޔ1v59k0Xk.R 9&2kDOQXeŵxmzGu[B.6opBSCx~N+VOoB *\"p4̲S8EUFE{JeeA1?טBqК*cV]!Ăߕc,_  Ye\ z; d\>]kޮ]C3aQh Jج{߽/BըE*ŕ{RSԣnג+!RAA4f1/t|E0aV<@:FI|3e*,39\bE)c\PB ɎÖpC*Ƙ bTmguOXiHQ*BGP ח'&iJhIQQpnVw endstream endobj 2759 0 obj <> stream xYmo_A> ,.%\sqТv 0J"JH%N3;)l pZ33ǀ1 u2x,8g"`YD,_9 Q g~j2BE=y^75eSdʳp]zӰ3TTQƤ!E#vM4&< 5VeM?b$S<첱*JU0W͚6Yw>8 zt-=7*JdtUeѨYXv7^ -適 80@ #@a@˛Mcffm> /8vC,;:24h 1(]FYM8DF|2U /jDR٦MDguwA7DEEk_l)6di2ʮIGF`T:?^QZ{raBE׿҈et2N0;}>:e,ҌM"1K/W脒= |ȰMSGVZph_5,}ϪbǠM YEar6^kkZ l7fsIU;H"8a#6) Y:e<D=ـ{ȰgY0\ _v =5,×͆_JOEGޖZzoE}{wiˢ |n}8m&#MbDx@3Q&$VWz<+m @ɍZL4& -nhAl*W z/h=ҼIt T!6!`vJ!qE볊D%RO/v \;\p=Ae 5Vrd$sKgua_L" Kf"L9iey7ͶMQ/-0AgjT2zNl*;Qp>ћR& ~!u%ZzX'( CN9WdxIN2ĝ=#*#H-|H8}TF>(p|EIǔGlpȓ'yv,qp\MfGF tw]/Uݪzn̍fl:ւV xŌ?6 %+XtOp ' OBN0vWz,@_X[]{SAFF<U~,$#8=C={8*'1:gT cq'@SB3sBXD85ơ(p6h4| 7VWo4((8>g4H05vv?«2霤ӭÒJSoG' -G8sA Ѻ\G79<29(˼pE1D_ΚTk< +Clئ`tLBsocQ}B$gC/vOv|4,Jyrr$%x wK2̟@Odm ͗+y CwAJQɢ,M>`b[a34 .**zY튦m E,8= #,]a\3%a&^UPEӐ}g + Lo#za2Rs.bϩ/3FάLGtG[w<*,A-]@Z+ݟ#O4QO@@P{*"{=w'B}5wvq|˳gh$SG6PR '=wCǎ>n~8~(d Сo޽e1Ș>yAGĀYϨT ]n~!kMzw/r׾0_so~ƍ Isޓ![<ϴ=93/۶?N(;㶞;u`7/e endstream endobj 2762 0 obj <> stream xYYo~ϯ8 }^K%5,&rDvߞ:8;, }TUW}u꧕XEOhٮ^]+IJPawwӵR*ZkX婴~+-L=04ͅ"8^w: дVP6ԧk2/n2˚mvۮ_&{eiW?[VkapE> c"F{^:N5%8ơ3|]ހd 6-6<]N̯?5ZAsWz}.z̘*lhy..t(}yzo-ڎ}Sp/ ^+@"0tdu k֟%UrSg}B del+ύXف"J"bK_AGԠ#yoЗԷ)PEGL6)>y/?B圗#Z( I `bz zOXp+ܚ^7U}͓$~ۦt..3AK/1QkyLPNiQm޸azi(4f*} !@]he=Pn uwHHfܟ*06IZayd-(wd|L0C2ƥ2. 4eT9Y xlJ+YgG1ζ6 I%sQ.Wony 2nwŤ@2#oMs4LơHqȌ ̶od=ù?>!hژJ6/xgLp^4"Қ]]EBNY FX].'B!?8#H$ Dy˪i-۪脦J'R9DZwf49J 1)8Uf5 !):jрzԂe;3")Z'7K B=}|)B_rKjȑtȊ 7+` j㇝I ɱM1h8}!G x}'~(,A1 $4N^urmʼ Q,,AZg!_g옓8FIʻ?qWWxu$nQ <wĉ:RuO˽wȽ߽ wx`M(!uӋ޿xZ)\s#pbaR=g:]3<6xx>Uɂ>œ᳌B&$56/ z4 &ѱc:X#.]Dp*ǜ ]!aMȎ9yO9 Ń/O K Z&($Wp&m%y5H%2`FaۣGJ:u}H"pwGLj96=J2VAKA@IvEEQPݡ` z="*@W=JF^.CoK7 8@+af7'{15:G%n82 hht&q01d'1Kl)b 3ę.=f}G7tŬxbXQI^rmx/ѐ_)=MzdJ?>H2lM!Rŧ׿սEpurH;h٘a >"k me .=P C qq2urH?fy=3Uo>ƞs>$_$VdXol`4`T&\q>l0ԍ_Nt u^fdb`6|:HId_z*t.iyh{kuE_)\Qr l}" E6kL'1Ls@iz=aѣ(ژ5f?431ca%Bz`DLjS}P*j1 @\[g$.'KO V36p#*TBʗOƔV/"2O_GSGsX_8K,x#',j^q(ۻE#mz4[bF<:Gھ :.jR#z2r@5 K&SS'rVd>Pn3.%)>;i=6=)}j)U_+'t[|7WI~;rⶉ7yۗ//p;b^-,yˡz6.ep R@|ÁZ;CVo"7=7x7-_0;DՁwW>H5@,b +( lt?X#$C_v!>hQr q$nToO{2H EoaDh#7snWOatgO߶9~Ok/ώrLSHW endstream endobj 2765 0 obj <> stream xڭYY~ϯ`K*\8dRuXĩdZ8 @VJ*=$Rv0 O, b]<9_|\.DfQ& . 3.7 2/uT2L_^,WJ 6ӫRiuSziomIйUWR$a*Jga*[ha,os55֡P""ᦶ]STyH+ԋU?4=rz\6: .WZKhrwteoqm0Aюe9SYz5l9۶v2mz;&IhNK]'R>$anZ8 a(1 & `uZA4 /)[nho ' [,h?DTNJ!ֈ>221a V1oޣv1`Γ" :7oJ;5|]筥 ["^JLؒ!p*) UEU?TYiF#kmƮ̦dnQ(w (VK꾴ywK}90 A\/tD 7-m sfQ%ܗ^5J]f!Bm4 yDg'21Hh"o21ܠ ﯖ* Փ&_ۇ8@\g0{~]QO$a= HnXl[Tygjd)Kq8cKnu]xb/p+t lk f7^DBWv3m4Nmz7~Hi 03 18Ae?v< $L"狥={x(?&FQϋP F&ֹ}rj?EXQF]/pN$^'Rm7ͿE' R&KҢK lf6Q ދ4q1ts9&W`j`/}9i4x׵;VUpxZ @X4` [Z51` Lɣ#4>I2î'HC|@_aFl66ե')!e iK5>ܜ%>9m M퐝GFK{xk~jMcݕcaҔ.`Ć @(׸{y컾?^gŒ 4hxΐd"kFRB e?;؂w78Uü1 C3=c͎JƐɇ',/ +SHZp -X3 D26nWWj~Ng(+$KX(S)ƻ;wg3;)'9@*p֕Hi#Oɡ&6 @l`Us d9k);FQՐC$c5:%=PG6sC;TY_I&Ctzt7N2 X#]ek4MlZ&9(oni=FS2%q(]CїFڴ|5gr^1GFLf%\sG}RâE5yW}8a$q{T:߷>Lדǀ 塖RN9~*q}t3MG!K2@#LqW+u,0!W7Zc8"U{HKpTVc)nnnc%ailA=9gnc4I0xA: Q;3}6Sm9UE@erBZi^Giy((|yίm}ZQӆ:t M:t^KZ/\ X 00uA:. e JW )ϯN˺tߗ <"`#x !<Tg|Vp endstream endobj 2768 0 obj <> stream xڵYmo_!Pi}!t \wIsj!ieH;KJSb9#&5_LsI3hlZs6[]4W1WY A>2 bh˷+& -X̽bf:DKL*JUݹjV [kn\{DCm r v|`MY"^0-Q>W`|TcM3mؘG10H39:{5 |G%;` tm _bk eqTlEڀsd[4T,0M_z֕hw[Cq bd:NK7+%2+V2ܞW )Io޹K#I@@4S{ˎX'*gU# N{P<ţF:bnjˮtĵ $}iJ9 vf@*7A]YA9Mރt Sh:i2X9Uʬ {I7'ߟ*D"U͓5'?e :Gva621¶fglM, %=0,X h3 bԾ)d*N`VfԖ6 ca鹏2ع@dWƏER"?=I;-+zdzܳ Z,(LGaسXмH9>&8D,n|c( E5KE|F[Pa EyS 5·+|O *mGϙ1ۢ\BCa𦡒k[g /G`[5OnͲ 8m[x`)%\,?)KuzĢf!bk;AEU-](K_ g#ӡdAJkD,$j hʠ޺GZ)h~Zw  ]9=C+YT³Y3K9j֚kg[T)r9/tV~R+x׮JL! @v,{?5m<.n&,k:qa#a1<}$^R2hʿ>=|1~h0e@4enp,fٚAh<}zV|?8%D}{^0 4+'GtLlJ^ L0 +_pcI ,e8Hb*n/o@ 5t-\n30m)Sg]JǰeŮq{Kw%3;G1M[Ǡ=#zX)h-XA݁( ̭]#tX!>}*qeEa/A@w KjN*N+ tb1PFI.\{=býB9.`KiΞ0֯J*Wؑ夅 MG}$YF.v s 5"@#qL y\ \wf[@դnm'sV(7YEXk,i]ap96[:'juC0[. ʆ M[آ +Ez&w4*ݞb9<}~`>A-;B}Jfc k(t/K-ӵzYzJ .pyꎰnNB<.{}0_RcƏri%eiP$'~ׁpMg> stream xڵY{58n/>.Acvs@} Iʪ3K'9vaZcvΡ2;9'SgthPNb9[7/ Cqss&B~|=xQecꍞU E,ŏB"GR6+$|w\Y`ѿ;$Ynڤ:+j ,Ayz߭$ee#,Q{f'{rsg+íQ{VCA`7Pd adzp71ZZ8#Qdkbaz^k&KZ0QonGJfȊcIbiT揄P'Xתs6Cpn gyR7fSǭW'K3\rCE,bxX$9 Y'. 6Tq(x΀†԰†Sp)n I eOe*e<(]n?9 ) y¡&D4XzF}A/*0"c- vKKEiLU: =8QL@`Q:&!ܫ󈹚HdK" SQĸ]瑞d-=@Pwhb5&5ϓ;pݝoc& !25oDmg \}fǡ 82RV燡 :iND esOIwwYRymT9NPKe2#W5Λo6:/3w[,3qI岻fU `l.>o .Dj^Tܢw ɤN.ߧAdY,U*IK 4vnx޳ʻƙEk(zz}`=6*P]rvYCA=iiDB݅w*FKwnX+ Ggf*koƀӑ ^I̱)@Dqbm2E $,CC}i΂rDaa>B^aTc7L AS{Jv"W8PG vc6k1``tuY@alVFjn`T, 򌃾GWO+۝4`0=b28b$cT"6 \Y*jEV ˣãI֣W֕s$" 0vo-?Zbj+\\M: WIUy WyQ"c1 w杆UMp}z޴XϿjɓDAOMW Sʡaû.-^aeVRi,H xJX7<ǓXbiU>ҌSJ#@hP1DB\N[ >!f@c !8'%*moo_ڵH˲li.|WooftT_c~c~o_N`(P50wf˕@%LΘ" lY"]PtCQVo/+A_%py*q^ E@Y}"c"ItFu8 |]ϔx&X#R>v130aQ^1\ 1|I9_}yġsٜ_;!4>έŁH{&'XR%`aK,ACK$Tp9#mPnG1xVW:䀬wVl^E/)pBҡ90b!PAtSjmJFK.7y2[FQgHnm I] lll14^vrRz8~Du-7fɽSB{N2#`dhGvօaGMMڑCV!l_jzH =_MI[maz8^yiUU, MZaTlz\e{WŃ6ŋTOumTR5` wՌVx43h/߶7PBa?nwc aǽ 텍N H^=a;!b#4zswG*݃6e3p^,̀h҇,yS"pSr}iSz(WZN.l;n׳?(T<^j\8O<5v'/_ܐэׯ*TtD֫je^&ͩ_].>ۿyW<];5CO G# endstream endobj 2774 0 obj <> stream xڭXKW JV-ƃy:؊cU*َk}H@I{Z9*m ÞFO?A. U'r& b)r& "7Yp~~P{׮"u*2ƄURi;on؊D' S##Hr\d?5i2 U0TQb2c>lV߯"hie9n^G^V26nMԻJBi zd*Rޔߙm?#<K"F wǖ$mQb"԰sUʾzwsG"TZ n\:mMnƋî@߳Euu]÷؟š#E0FNpi'wP tkm0pD vJ)+D\t%WMTb:iwP`\s~\i܄7H3{Z^5#0L1z+lLY8n|^yX|>o;qa-oS0z>c"bM@Wr JePpZM|b_T@´G&1&7T3F1wRBv;ћv*A4j6\bPj]4S*\2zNdd1e /W8u/p8Q}zaCh9n~ 0v닖UI{8B8 c6)& yGd < zL҈5 Q@^w./ZIS]R7:&$,T&-.lx+݆k9>VV^Ƙͮng$D=~_l_*d6t㻚S.8E,]* T=BW+١_ !7K:Ʌcކ( l_fqʜu]hmtj.ؔ !٭ CƜyӣazЊx/?.:pM뱿\J'w~؎!cdh_p\Dx[լ/xcӀ*t0?%ZrX$ AaGdi"{b/n+BCz2uDSZψPZ I(H;k4Y'CIbt{ my*Zu 3ue[Ʈ.Se4<0ff_%U3}p`1B&D ^b6[!')4vQ6^SFLrn4 _,h<2M J`2w> stream xXko6_*'˧.,k=`ݚ}Xl%>$ $){!uHf byTbk~LE0 p@E|0pߺYŃ/7ZQyLޭZ?|e0v O]D[s{>}4po/p;k7VLGsC8rQ}އ6> [*pyg!` Q\&嗝pa₩df0FџBD-tQ%Y%L) RHM-ƚL 2 y_I,cun'8YE )ȣPNQKLwttk0}kR/݅039 uB( nR}OK`{ۈH-47СVs@]Z&cwo8Ol UPCeƺ W-l">1ˆ$pt!0.7(<Xq&|htq|i8FNDВ՚C04vblWJM.0nrE$y!9vdlI~ӤpƷJHUCBsVȖ5C7Q eij̜$КdpFRL$2v 11@'Otk{ӆ Df JKYh 4NRLRC\ۄ(Ew y%Ю_Q+9;IƆ\d|FrQd+ڊ<:tfK^E_#ᰘg`"  J%>.Qބtf7|>N5-;ЙAجJՎ+컽۳ExH#Ԏ5b-iDKAPX1X dkM0L(<Pyއ H GwRaj=Vf٩&UQt$f\1KڻvHX T<ª(ڇ 0f7o oЦ endstream endobj 2780 0 obj <> stream xڽXko6_!d*5˗̊5Æ6cPw"+E$I#}ْJ'N;/ b=>H98Kv+y~J8 aHؙ?/e՞s)=|ιKFg,lD>?e}`!a WsH"r"I ,`78H1_+p@$J0D!D6&0hP1 bUOܛ `^}zjNLL&Okwl% < SI{h 7y|BҏL~TD65XxJUpiGFW0t &}"#&0Y)\tS4Yw= Y A]M)xtsՈ%YVWEcÑnis< hy0ȧG cZ/| zA3ǐ:Ge!1[f ٧lFlf+]#Q4c;Q $ҽJ4_v?Etdͧ߀ݔ)/ݷI}ݑ"|4GBo֎jW;9 ;J$pO 9|$s{?4FXW[akRdÆJ鯿zI̐6+]k5:W_*HHQ{ư ; L!X!4 `)<R]f `'qUO=])';5胣<]E@R3Wjbp 7o#vZ'ܲjeqX]`ađ:fe xufuW٭څ<q8ߥm^];>C r-Il)u #71d>PCp`nAVe[{h_/,ГfbZzxU%؅aHis"7k`@ne7ղ&28மo2)RS &oU*9.Lt%:L`7U!̙e从A4ֽ Oŝȸ i0(2#p:UZ!.S&CVC ([(Hb!:FgMIrL z!C Qe Ph*䪚>|#(6rTAT!V*Kl ѡɕ2PVfH[cv_b 8{w^6jU̵6ʫRl#\ϼA 6bDc]8߽xXZ$FUT IU͈aVuf t@ֳ~6t,^BV12ʵެ(tvoF)j 73m4GԴPS\5sݗXlrUZ2;~GR˥yLԃnN=\S?t ne(&qW3ʇ–LSɦyN%-y;ʹ2=GYL $RB6FJb5''6Cv(}cUu@ZKm -\4! &xirtWUj5 DbK?Px63ǢHE`/N߾%d 6 endstream endobj 2783 0 obj <> stream xX[o6~߯VU:`@z:d{ILA\INZoMnWCssw}HD?yF9It~," <qNeI`=}wz0^ojz7e/YBxYzFeO^ n:Zpm˦~G (e,ުWh؝7mgfO H7v_*JN%&\-j1VMDgT脔"L[XqZ}V/6zFS6aiVDOJͼu[Z7$k;`o\,OBjAqN#Yp-$`!=jqvN 1/(/*t8V9gDB )z. 8f0L1BBʑ6_~+``Iᔳzl6R 6اj[55?O 2ĉGޤUb+(ʳ{A{PcMCBYYo"D2!2C|igSI=ج;#:KDJ]}/yD^ `vWSyVI]oܶt b/Q&YpFɰzSu4Obb|xِ ,lc[M\}}.lMk]@ Ci󗝈S35 >!0H$!Kҝx͆$Š./}_AQt!\ÊNLFeT\Yl]W!aS'xB`i(%]UZ-ǗIC"i6zӟDU]os m;.˗q^W|ݞ{)j퓛dv#:!Y"q{aOC#$O '[6ȤÉu>N0/(vI#L+\!Aǔx5YĎ@ Hr$f kdJ0w3Ǝ7[UשGӐGao6i ?M UϷfiDՃ\~MEa:A*xRmbV ?׾ _tcƂZq6esyOs endstream endobj 2786 0 obj <> stream xڭYߏ6~r1M)=Ц C. C6Z^%W!%r{-6$gf^b+ le8akb4g݊e+&H.Cj_{ۮS!Du*L~nzMo>s%"Zh\U(8sIƤwfdRMor"[ӴTA]*m׊%Er?S՞Sirn!i,ZUL(qvJx\&7{ ҍLvW?{h.a&XSQ.Fсgѧfp&Yt H8GL nCSӚPe2K޸.Z`GyrhI=m@M0dy2~^we]njZ +5A HhZln9/b"jWPU(_BKʤ==EEN(?1Af Aqf)aXD %H::U2P5aCkg,$9|l[oVD<&]C%5S"TH1bdbط e ZJ91A3>P I*F 0G$|**3EIe&jb? ^5hlDɷm[& fݩ?Xǃ>(-aᙉ5y-}4b2E2e_lļP$ck O g&3jE+].~(f=ψ,hPKV dJ1a;pXH"W %O?ܬ. endstream endobj 2789 0 obj <> stream xZKW) f&um)p`8 Eҁa!$G TC6wGV `6z|Uq7l&F3m˷lC3Rd\64PN o0Έ~zU9Ovn]w8t-Ec=U:L{t2U_Y{i%ɩ{\XwmRZ$T_eqlRMNTiz7doaQurt;DzuO`܃VM+d|<ˈҫxk|ǴޥM=;< #H9bHA{TRk<Jt#pܗ5qU6=޲T >uA#1bPHMwK7UhRϱ#J̓}(?Aյ}ʥ$ɴAUdE|6iۘ4+c/2E͵uwzk;ilPWA1mx ߎIYDJ"'S WHwھe 8_1ezH`} n͇lI4v)D(}g n4*s&;Τ&ֱ4X0UVV4ɱ5(+ʃpŬh .Q&*UEz?zYԘD3i}xLV^|}BN38mzws,<;,m+@a*R#.ͦѥq[@/楩 r!(Љ E1!' cAAc OY.gUU&A,d3= -zexkm)wt E(uKVPMG T_#3P"M`JTwUaoƐuʧ$)=B}[ICm7z9ڇ)߿Us0e< .iwӭd:vd9r #p 7m&9SV2S̡8a2HzO8^eBP'됰rS |1m"AN8}f{IH3H pI0CSiD4dR_ZNH;LYržn~d9 [q9y),[f=o\F[8@8ŗ?k>g=&t#@0b/#y>ϓfP}݂BIw؁VY'2vW[8SYg˕ _FSy` bҮ^ 0 |~W$^a*,.`Aիh2C,jG-&bK] uN6}ED_E~Q'g2VӑtM>%L 'ثqb_q ? *ZzjIkDŔ&.z'EDm ;#ȯ2-ĴspY \ea&9{ĕyng!i1\&$аRS,$̰)G7 Mcܔ\oAMim IҒR]hI%6Ple'/܅N`T~_g}mGKa,KJ_ <Pq[nd Fӡ0Ś !> stream xڥX[D~WXEƒ[x*hUƒL6z&]3'NKQW؞9snL!Q hT0Kf}}E4%UZz2T׿?l뽖"nj-"~;1~HЌ<ٸbyKR?+)0s>ֻ}'rtI۹,P붿AX" ]7NwӷVoⵝӵ/:mOf,%4cΤɢ2#;e?_~N9mjkIhۄ9XnDPMH2&C7~r#`=_ktJ׉U*ΎwuDCa3Է٠\-&WчH[owˎ/ ?H2,E[sA!!KJ%S֫0 [T[6]vP}oZr EM@U>YN2X 1s2(Ԩ` Dù@*/:Y~wq@|ԓtcT2?羳p3oZ"Cd$특[ ӖA@- Rj:3Evw]+ù(G$.(U3Oi/>)[x2/I:rX`9D.Ifo>,St Ag oܠ?]u~U W`ydMY> stream xnܺ_1O\D."m"n_<3XFjR{4OEcDQ7f dn4l=ltW)n.74PN o.w_omgDkqݧ/RyR6;7󧿻ph/Utڋv5,'3jzPi?|M~yvx|t0u=.Lʮ*jWƁn75М.`·ڢn5lQnqM;8`wq3Î!~vNf;8~pQTTK@;X!{M,EF5kww@Ԕ!hF6b;UZ\Գ:r^Iws{=`&6+\;*'e'{7|vlfP$\xMʽ~#*mS?rS3{DŽ]M_$i}f~Z@ZVKCˍA"ֆ:ynyrPex'fYϓB%l\qӾpfl qA~8*"/y|5㊆3iSG>c N}^9efǸ9Ǐa}k]_)7@%@YR=B(×s nY=z=SNrQ`E 텸 é J+{)QҨR9cY׏%)]$va[}V ")4 MX2fn >*SH pxV)ӯ&br֞3Cy j^w79=ݗ\n,O endstream endobj 2798 0 obj <> stream xZo_a/N(WܡWC Ї>(N}ټޙ!)dQ\]2E{~3_1WVW^^8+s|u}©rui8FJF)gtW®ׅͧhoQ xpE~7BJUmq%lMSͼxfmQ̪uyPm3$/|FTM4=7۪.[$Ke֢\m+)_YKtv|s"K^XWr}նO aLK~6C8waCЎ[Ҭs;²t(KV}k2]>tCsۆU lt8UrS܆HtsF*Ys V ݢr2 c"@Rp&T6`PYK\|þ+x4e+<@aejuDEEm+%KYܛF"1BƇje"P\4vsJ@M4/-od'?L%mO)tDGy*OG< o8|J+Gc앎MV|O&+F7.iaN ul ]FEg#x6pex-BYaFrVDa6om + W[Lv ,_ ':η{DsEl _75zK%\BFie9 *!!>}nC_ x|ǶQ9Kvp3?+h* yTZ |ewh=&qC:뷫919u&b0||yґ&&lQЎ4cj CVh݅&Tol-YA$TIբQJ*E+9=Dp0Q}S9s`Ŕ qĄ7s+e_-ဟa) ;? "Z})Fv5xB&9ߍ_=O֕iس/nGAҏx0I,r=aU!`&7B t3K?$F8<&hBZBxu?|) /X ~n.Q#O N9ɉ`\ d,.&"Mܞ=x/3)jc{! CfނyZy ) lp8JQwy<%SŸ$/$CZYa-iu#lLE.2  IJ`<"WY䶅Pf>pWN q"a4!0@1lm4D|["n\KE%N<@2]G{n7Oېmvn RBiZ9ts- \!T}@?6T]e _K{em!?jB AjD!AUN @?;CP F݅_~%4Rzj4"^V*ŰckX> stream xZ[oܸ~hyiKEݾAp Ņ:\dt2ms|bm&qo0IINvp H&LJH籮lV-!~axb!4J(@[9!le崒K-WIY6w${O_ﲇ@=*Gac91x8@Uh#'+7L>'d"d6Na/&|ֆJYοک}婎eхFT;&6vNBgչZC6Ers8}![`S!6ƾHl/ňhk4BQ: FЭC}c_ cS 2WS3$ʴ֐6 5}{{à>ץ+gzOμ*P8unb zHT/49%e-gSYP z0Tm^QgŊ^i%}؋>~B(Y-]Ӹl 6u#5V`m9$CD]3t=S1j2w#k[#a d2c=`McwkDWu/:Dءȗێ~^ QKi"OR/ ڱ=PC nOa|+ĕCx~E.8|pۓ %pXa5;3p74\2( DU@/> AHTQ8y$9÷Dm;Mԝ )>Tbp)N5&_ L3ޢrw@lyk}ۤ|3P9g-w [c$=3UOlD\veť5нBčk{Ld%䈽JPM7_ѕTE]IړDyO2I0Γp 6DpW \$\$ݵ2ܲRgbX־4[g 0pw] _КM2Dfy˰ASӅWг&?#l0,O~+ly8-lul3+LQ,(WC-dS6JLJ<9_#s,u6 (Vѿ( uxA W [C{So4| ?_`:NEx =ֻqc}$9ʦ9;S?[xٷ±aRU%Q;楰U :ya*\@'UfUhg_%LpД6)݋7D1 z!-_yq@=Z$ii eOwN}0||ղ ~E*3j=} ,s1 1Ʋo yQr4vp-4I;&?S,3?9X'3젙-b\`N\B"~[^D{M$XExI.Ч8,> stream xY[o~0$/"x-(]̢-7L>LAG, yMMEEOSnyky 5XEny\7 @w1n֘g"9Yp$d?ego H`c!*c:n\VwlŃ?/p\ 7t6xï  X9bE|.N `E$sT;]x,4f>{6H EBp,KջAG^nB;O}Ժ}u.L؃tJ:fytߑ %3"xA2[ O_k4ܶ;2=L|+fe)t`~0vgAt "W۵9@]n8?>SHi'5{,|SCaX08j^j`(S%Sg~{`6 (§ON"3PJzMSȋV1"^n` K!ءS&9a<-III[零sG}Gks=>eFUю8JSTJ,W"# DPd+ӝd2fuVHc-/Ac]$Hu68hw΁w}\aeDϜG1pr(8waawvr k9  B0jaeBkAvvqN\ zO;* W|P;b"[ƥ% ^J8]|#&$dnɖ(O-ނ3`@'P:Y1C ռI|u&H]u)IڜBiq-A %1sɥGێȾ]'k iChx3d]ΐ Kb[D(F`|RA`hDh4&%g Tf<x*L& "蛋b?z< .14F+zvATfL9 !U%?T&z.ʨ5/۩RM=ۄBvLM - 2ܿsFh;V{8]n%E]aYEU*:)CU*roIKsaY&ۀkrC"tx׼ǔⴘ{~ ?Lc}mtM_(M,JxmY@uH18t|oꆰ_p?l!(G,O=?-"#_U^"~1icAᮢTtde|)KS.LAQ,ufU:h#O` -'4CO;@@Bb|U_V:s@ bu6C7*S(ơvIr8x ~i$JT20PLۺn7b8S\D=Iz8"nj=O@{d74}Fdв |`T~YBI A q5O.yToV!}nKM?oOrm= H.qN3`vl2AمdT$뵭iZΫo΀oVt endstream endobj 2807 0 obj <> stream xڵYێ6}߯06+cFR)fbz0Ht7*IK=t_,1(,OU*.~[E߉YW|q]r%TU2_zυ#kwo+)eVjSpZlf8Rr%l}:v)L6Yb9K*+U+ַvXql/W3ŊVH醿ٻF6Zl+?6@G;~+Jq_k4]\0kApꌥ-0^e@kM,[ E#"((Pq&=$knrbH&ICr'#|8g듧VoD+rƕ|)2 ,y"qY{JQ ]r-ᷦPӾ}ְMٶ\ 9=vm1hY /r0g\N!ׯx"aofخ8٣5?&p?C 65tgIMlgL`NҬ̮HDڅX :jbK%?Ot#Bƥ" r "R2~Yz@dmې h8ARYܑ0:'cO%/$f]x|tO^SoL}ԘuiT{!K"wi#&h-#YC01d!D/䴐:k swܯ %z8[cG5kH=:M"~^VD#4F[DZ SȜYySWhMפ S_t n[B*fy$v{B"(Ԣb!,3 .Y$eBvcQmLuCՌ92DpȪc~cT\(Y\<%J@L0Ĥ7WD &iE-F3Mw{f5pA⬄l/zZ-;l,>-)Wzf3@@xT*5,?O޼{F"^+"XWtI0( K"bOv( YH}A(W.Y@$^AsJ[Kփd)a [= ~dgI,Ջ F)(L͟b1ĠdÔIb&ǜ|;'9^;"ُsi5}Vmz} b$e>:=' MPR`,]U b(t3)fK)!VQ겶q~o~ɥ|P_sYd] %4 tY zXv&uGX~wXCvypw6|k]{Mk,E~=tyeBWS`yXa[إxh6mtACV2Ϥr=F%}`*ҡI_SN*h;.!w)1ணI3/ŋ{i^OX-{G<\->@8x!/ C$?9 , j2 endstream endobj 2810 0 obj <> stream xڽXYoF~SAfOK6)ZE }@K+D*$Eޙ=(^G Iٙo9w(cQ?y5%-X4_E, ̣"%BY"jzƳ߼IH*R__f(dU,HΤY{5dr5ggt|pLtKvK}I2$M̭B ¹7b&c'*T>\7\i''iB)F)My)0/ 9YR+.^ XUSqr22vIj\ZѸ乪A$hovY mӶۙb?6Dr80p_\΂ԐaY]mxsrva"\2Hq zt8#>}jjmެB''nQ2{BY U1BA, JZ)}Piiڐ\` 'EN@'&Df<,@rY"[A'סqp2^6'(N*PƝb)DT5c>= YtŸ:$ˈff$ #xMlZZe` P'0+l\1-ʄy}dQa֝M)t0 0y-䩈DDO%ݝI\.^!\]zme y$`p<&,)ܭtYÖwd#[0`$@ <}QyDG&ܾ1yў3ضD ̵IZR=&#a<8 &6ƳQт38g!PgCܳo/$čdU?TXN?Znu(]'˯/ԍb,bD9U\w L·'@#h Rz!hVw64?lp6Wk ܠf=,9҆e~ B ,QC>HQtJǂ j_ 㷝kY" Z" @qCLqepq5R 1v{PF=e:,\ŵXWV}eJ'!p4)r P^ƶ&|b =?=r86kASdŠfPȎf!(znڐM[ch|PynY!(VLŸ,Irv[CM]nqDU/6+fAjhQPCoA x=9R!g#n$2ˏt {x(?pԛ Rk\O-gM8C!ehmRK ~6nMjVt<}ĄG6rJ,1eM\Dž ϫ~_2?z >A[iJTgͯʳ4C릷M_!AOo輾)ztWe_C.4S<=vYnɘ> stream xZKsW*@%J,8s|q}ve]\ȜW?^RE!m۷oRʬܮo_ͦb[ezlfæ^"Q?d Ʃ,Kr$= V0i]9XBs> ^bɋHGjo4V} oM'L <3\3%£yj1W!&5<.3J36lۻfqrwuHhOh"7̽L:*qR1 *W[\3Ry7S ʦb0ާZhAL4)j_uI-ۜ6>=]Єɷ R|WR *ﾄ+՛]SmQJy;ԝ u׵z]i'/:jТqa"f%.7 zvՔ}AmݚACaK^\-%v.VCW="9:{crQȬ4Xa9֠IУqj3D@d£ Y]@ +;~mh0q *3ܙTY%F-{zGPVE_l>8Jπ%v^M:HPl4gP >&hqIr@,Ž~qQe_9]W,^'Zs.U1HhYe)^,V6.M=^O;ؔ"d>&cc@KdPD`^ % SȱnO͇-?y'@Lyr]CF~sNL)BMk䥡3=^납@a̩a wԣƺ+00!?MJ^7">㊉ '3i0Cү@~`7mN M OZAt Vdo?"{ޕuQu ǃ0t^)3%GˠdV)~@b$56KP#4JS+24jS]zz15`9BbH=y[]iI[J\چ:ߗ]!:)ZTPApʐ8ܵMCh:U\8Z'GwU?I P~z- º()iusSW8EHSiP K7 [;>V{fe9ݪ9IDt ckAˣ(=ڂ3s>x{q>%4j2'I%twnLkqz(+OBI@=Ip^}5œPTbch7d81Dk#D.d=cT1ULdvUQȍi)^oi iYk>Ka @B0hc~NI !]S(}P ~//DFbHP dI]d"oCVIbZS$TD3YuY}}$[*G1Tf1z^Ϟ &礵=؋͞e$g1;m.=&L^"$PpIyxyAa"PEt*a(zu/2joHƨz63HNOTSFZkAgч2".?"ظbx+n `OH1}iOo Fp~Nmݙs"~R?` `=&|!M/;k hSU'@;]m'::?52L8CQG΂Q}J%@ʘ]ސk"<+ K'˩bPS+4]nȗ^_/z endstream endobj 2816 0 obj <> stream xZ[~P s2:Oi-EzXbB*IV37GZoPxa̙swς,0# E/V__}OdqvA0Tp[gݖt˜1QzsγtU*wD $m)sWs&4p9҄n_C6=,.zW8B 1qy~6!<(Jj'wfضKAu>;6Hqvjgkx25]0LAF"WTKXCezX8A`m@qj4+%0J:x.*A0u[~U/s0QX3lp7W)Lx,{DbbcR"o*Ӈak?y3. k$q~݅aRpN c 1eg~yrUխjejq[\_`RRpBަ&qvy\'>\0cҲpOtڼ7fֵ.U?}6Qᗇ~f`Ni&\#G'KBD#XǵDgaQ],nb J?UIi>R0zΫ: `>.cuE0${j9YfuA)'ę.y:  ver)3ťU3ά9C]<(@p-xp+'Nd8~J"aR4yZN8_acHSކSD‚=Cl '9Z n1p1#smw32x%V;c仔Ns!Afԣ?sBRdj^손8[;guFD\01EQ3]rMgyRN^v];ՠw['H`=Xe@5öN>AI^VQh٪r@dE8=poYF ų`.;wYf<:8.q1Az8agpr=act汚Jfwo)i=-N9%+ fmŘҙա+hc|k S0U理&8#T~L{m.雤H 0:w ۝dk޸Y^vC³}ٻh]D EXym Aybt29ߜ#g@Z4ڮTMY' 0QO!6x1$Kﱡ3.+dHMC H=Ђ dNBRA#4 Fh#ڠq0t+ܠZg,#Cr8T)ClO€-G C 8v(_L늙bh[6"%)EJDII}0 Ҹ\Jd?}Hۙ0s:_R@d7Y79W 8L16uɂP|8VVP]pH,%ӄE%O^HtͥUx+1@PsiZH8K1i^RoBoKКײ`r"v?})Яe44l>܍?ևr=ڳ ri!MF~?FH.7([M_mr=)@X>If!ݰWK$n;A];ɣ ֿGGl FDɾ3rOBD/x$ Vb9Ed*f-bۄժ ƣl +G~wM endstream endobj 2819 0 obj <> stream xڥZY~ϯl a}c$560։=I<~H)ԮǧqUKVU\Еf7YmvܭxV4!Y㊦+I&(bV35߯cy[?nԸwewi1KaWkPEf FֱT^ݦ-}77*([FٷeZl퍶طE$ɑ4QșF4%ޛkIMS9Arhu} |@1I{ϠDFFSYedS:$_QJ>s Ɗz;b.GTRb:\ʹMֱ4zSG1/e7AL/5U\B8m[C<%zM}C/MtxUyTyy|rbwIM$D4N H8I:J@Ky!Hfzӝ&cB\RE5eLB[ީys̲xw#8Gk1uRh?-k1SxKM p[Ma+*ziҔ-;^r[}C"J`$rc1p!&.8FFA]A'M=6Uՠn>LХ<& tc&~1۱1+6 >g/;X`=,{qr~ǝ&ھM?V|=ЌEy!&JEd`f1 -лf%S4릷WeEeh{Z(\l'pW]x76ĝJU 2z٫C DuEHV:gV't20C JKx2Sخ1MS;!PC^u_G04f{x($TgC bxb-;_]b/MML)9*S;ƻaUXdT996scC0e-D$Orp+d }Ex[XۂIb!P<D;"=T n3q0Hxq^e_kM|WTb^J;UqB{l) haf3{wQ8nk*tO| \P]hңq)OtaխfN4 `HCv J0n>֑r~7En\%IB\~#{H?a2 KGTw7wZmL%zlCm/pԅ0j^aяe0]'X/N+2o߄Cg) .^W ˈb(,>0F&H-nFPt(Jm۴vd NLX(PB )EI0%MxcБMj;9s@M3x,Wxoޖ͚G?[g,:C?so` o 2A{'hk?6>^l%TkZjZȡd NP@{*hf3ܶOfdj75.CuM:\VYMtM}s-/3~h#F臋7 $=1II8敃uU=l܌caZ 4KY"H0^ Yj f3\[k@<;Fr2ޅX-) ]{R 8&63T/ӝOz{; e^ZڳKS !'2ano[$c\%I[(Y6.~+;W~ 6sKx :wU Q^ 4ĵQN6u6y#13kC#/pAƪ7ƸfϜk?O_R1DxR5{e10<׍IxJMJ0z/\SK"x'%aAADpa6GM Vzȫf!C9u L1uYXx e MGEbNKL3iopn&k37/cP\=*(Y@[U5۞ۥ2Q݌醽H7쌳I}cG5)TȍygX6 Dz#T35.Cn>D_!/thv<Elpk>󚝸 vMGDrߴa <bv:[(ȴburTYB鬥p]{nU( HP|7=w3X/A ,x_8-/&*(q/&7dv{Df:&t ub :L/%ÌʤP)|72q׌|1 Q-i?+'YQ8bC_9G+7C eB-C[> stream xڵYY~ϯГAv$A3W"Y!(Rۜv1":0#+E?^UW_`CVO+W!~c]yl0 J߯7]ݬ*ܓD $1Lѯt IC M +]= 3I8EL˜u(18 Gm0u5%^v_^϶*whqhܰj k D7 CW{A=7T;}_?m}jBhSS ud ǐ4NFEA?o0OS1q~Ssk%q[qZ| A]ҧSzE^>LOͩJC>?U  [\mD\YˆYKS{Lܜ8.Nw\_vfC#RE,y#SXNĸguIQaBpq$ئQVCXI |iK.*=:= t S$ӽ>IC|4Q3pIV3Pe* vT6ev|pyaeB bx]s9hنteEvOCjm L &N_\0Z eYtjI|g@ pqyj zpv`7A0u gݲ߈R)e:%eX̕tIY*nQr@^j$qa0+e4cL4򅦊n.Մ0\^[LOijC$]&i0dEFTW 1نR.hӭz nb]J F.p_?ޭ -byS8ET%?dUgX}֐9OFzx{= eH2qS 9gy;2Wz bfN)r@"9$'$\j8/yEk`H6U9C٫p< 襼:dS0X2bRTxc݊Z9h74xpk}U> stream xڵYݓ6_# FyKڤN'm0$\sJ }wINvW8$qm7w$1R]SXܮ n%HJ _D0-WnjJf~~W-"aacFpăH6_:F@#u 'P\Le3'EǩtYh;>+" slŤu8LV6*9tg8D-P kD,JY dgw dSVE3@1# cg~zQ ągu?nB8 (Qw4Cm ]\ R=(fh>˟#g6*RgN', Pmutf Px8E yL"2!d~ ĝ[&aN1^4Ǚ`'sY tl}w6":UȰ^$A1ܟZ;9|oVcOB0a@L2 CQ'ǻ|}+'^z}*YM#i.3*UlZFmPfM^ȫ &IQ$_;y}gy/|"`d^6 !TXD\( <<Dp,W vη"򦏻Q%}/^%*i7enRqB#w؛gpfnK&Q \8@:NkDl ?/8hm[K ;1y&R, 9!ġ}WWFTb.#p &bʈ#T(9#P(c%,%H2? <;! aޓ`̦-_SЛ%P垐_)?#iQ 9]ɳ tCfzENS>6ip'`ܕSkMM3Ww;eZ~o !'b7˴s+firt_6gq~4x*A}]U@ém<:ua+^_b =yd!hJŜ++tjSw*ڹ9wWunZMw8/ۼqS92h.8 fzuub"t&y9 B|BeI E#ѣ*2/A|pY0{cՇˋ;¦1'?7vQݷveD=ٓOp3YDoQr3T>: I 1=űIPH%A3o^bFB ^Ed~\c@S@gۼL(z.E~k 8?S38c^JόahS( ]+OQgX>k uaܑ̯o ̋V.=Md*C6tԟ)0]ǭo endstream endobj 2828 0 obj <> stream xڽYIoFW(PPE83KhE%ʁFTI*YHȲ7{?~pR&-iB0XdIJCd~~-ic,jqڪ^<;?'$f[}XR([p*)?9O_*ܓSp.2wadrYakQaI*FL\뾸ޙ,:"\Ĉ YQs:;"*BXSEQQB'rGjnzp] tvd6*HA(``,&1`LP6"mg]\oW&2($&;=*V l&,<o/kdT!.xD"ϠS]X|_amnjfep)PܨG{ǢREf⸘m_Vݾ(MT&dr&[^(I"&koAl'i0gXnU}cQ.|BUQ4dw1 ̋ XAP&VZq<{d]L( i|(]>I TCM$ܩ!ԟi= !UXx# 0dN6WI͕-Hn`/#('x9W FҾ].\e&8c0p.xW!%D*F~[CzjqoS ?UP;N՞;Yc lOMf39FR631ɧMs0;I sM.@ e  *=t0NNƯPzע+`qE|;m픭I%4/65N[E3~nڽhH̉c% yU VƶV{> stream xXKoFWх ;wiEڋ-$$jY.Iv.b47o0#6z9^|O#QS͖a(:-.ُe)mw4aY?_*۲p<~;u9M)TŶ{aT'Hz)6>=m_aCkG(! Iƚ]$eR[ZMAy,?Be2By.JAس+'֜OĈI  Agx9X#2+I9:9G fָ*<<s `byѥ26G$S |ƜD`j W" 2Y6R J. c|şm겯yy!Q/ 4.=Jܚ'7vʄdJ8vnJ ijN+x%|@=5pTy4x5WHwsp$Z9~JJyaJ(!) $ɾY]'vLNwS=1ٶOH^EO-@ScB&"C&xZ!$r1LL4ͱ#A!LT#qrWv(JEKL*̟<T%QS)GDTpG:liJzc7u@^l-YͦM=g="nH0j*(4MBS(70 r'q>"yNy !qܡܭAd6/ v6ַ[osݙ|*9%U釡Ԏخ]8Iu>w! gHC4O,4RK$: 6 ifqy [oulk\ih^cÖn}AI Fu> stream xڵXmo6_a4]1|ضmh4 J"\Ydrc,@<"O ?1)$jJ^DPnr=u7͕Ro:kSYd~'ZfRa8Hx*%sBR2D1͍٫xj[z :. XE Y5lYn\& a_e^ <~ (#b{س)/W %H*Ű#`d@Pg"5[6~3"M Z.zNJ8|AK( 'MTKtz5Fw}lHDB;,VdRvwz{2J폒J)fKGԞLtB!6fisԶ˝i͋gYQC͡6Zn=K'$AͶ(@Rsa}3c\m%l4PN\vfNf-%bܣyM\fSLPч)Tҧu</ bw޾1uOK=lpŕt&ӅEs/C:щe3Q^ΤG#^ym^G3GYkϭ}Qn-"$J~ߥ h -=B'F/NB~Y;l,VoWYsf >@VdG L=(NTiÖe"| G7+O]O";h<" *-  E;a % 8S<[Pz }e i_7!ꮎT;%B_~qȋTN&1t%6C,5 {y%a\6.(ѥ0MNR"#f!LTbvFj>aL2Ę@GIŗ/*rF=ؤo>x ˏSBצ^;DBڈ1އO;_R- '!x1d.^OJhBaUffyV`b(?_DXc*oV Fj4B%JnpB¤Ƀ<@=M(~2`̗?<lQQ eu5GkWd 4ZM.,鵋.@3$U×4b0A AIp9}&M?PrkC#mh=QШn:EFG9'1ƫn?Щi|O;Poh$4=g5RXdA\(Mܢ]6!}of7 1ra|ύYYa+T0 A<7Ηf2ރqѼ%&Qg&}ʹN~>7<ۧwX}3q<\DP/Z!Ngcx`g<]O~Y endstream endobj 2837 0 obj <> stream xX[o6~߯IAĊR`@ڦk.fo/U Ȓ'M<;Ir\n@4uxn߹QΟvNL?pfKy88@ibgz,qn|C(AqL=>z>˹ZxZ˪kJ<$lGbxdKѾ%)YY)\ jst(;Z(9 tυXXuح`EF#M &eގpA{gZ8%qIkrCPJؖO(e㷕ߴ(l E1 C3K aG9\u\4xaaF6!X6n`aM+lb 0 9ۘF D5e5;q>}ZO[1 )^b` 26r ϸsc$::0>uBC80" h,oRl/ ~qd@,PŸ,U/MKK+ikgktͫrSQa;jK2 RG|%ڼYnH!*hE^((!vv6hHﬧ9nX@aox3ŪUy֘ԅ'(IgF*:il0bR ]w9 R7s׫yjL!u#{{DXwp)n{lzO^Y+fy_RٔUm~UjUT[7|l$QHpJ8bA8ƖE(9yfr=_yZB{*ܚƊ 1GcA ikĭ@3UX4Vap { OWpzIIr_C4MECR8 T`*V@g10( ғa0(hPl40J뱻x;iDو9V| - w.sF2zy}3#rp! ½jtk}7luUCVY9g݌dvdz+yPjU35EX?BQ-76|p؆x 3w/_H y2T=!P@ \Xv; Ѵ?{϶J!'v #&3m:ww&cRcLʙ 6dxJ|\j}P'E%fz-GW=wa^ ;Wg=K!H/6fqogS *-qw\x%1ZWJжU`.ZޕYcgo&d/yr |TqCxTѾFRӻ: ˼ܨ{1׎7F^t/4꼸ZW+*a"^6dp<خC3`ě;go㩢=.~S-@P[@9i>,YdYe,Yf"DLSNLz"< ׃0[ǫ/~= R8|q79> stream xYݏܶ_hK?%H6EҢx[| V|EpHtˍ}₈K替7ڰMlSp/?n^gU^&J}C}͸M o2[^$_6L J2CV9pFƩJeLZLo8zT$ߤ%M8\fE~u=2N>myqhPGדqĸPrM{?JpBP,JԘw[Œb*\TDU2S w mcFGaZ0֞?:us{$rM'j?].қea_ꌟ1ze%/6ZeaC'6e3l3"*"_$ 6 .P X)wr6j呃;I=sݵvtV06c^LϸVaC{ s3UKA>`J@[U&e)է?:Dz8<fCinla6j~O߶|@8a'" 7X҅cP D0:VO`VWmSѷ(d 43z48V%/1ౖza,=M ̇*YT t~ĕ݊s҂;PZзs[wdȭ uݠX *H|9GLʯqw/gs8.-ll>!b={̆ϩp`>Ld x#VJ6< &Q;1 L\ˋ,\t-kxgcu!vN`g(7D43wYz4u18,@V5=i㱝LxtB/r*_ "ɶaZK ڕ_إɢ"OJ8ŤKvv2}c{[oyThڃA.i?FsuY Ū$,ճCS'-[GQd>bIm؊ob< ϭoWKjLOn e #ԾͳJxNWQ_h1'1C2X~9s(icv9ib(sm5UNtLS2[LG[Dў-\8q!Eu ӕS8DZЮ ^XI)Hr~XPUAR9M. [\y ыAza+e+Kh2JMd])={k|vӀ+hR*{jl/OYzPRQtGGD^SQH\Q84l /;)8Ж/xǬ%{̃d< {qwp]Q8<08ZqqDNXH3(e9Px8f㳙̪X+& s޵=^iU k%^G WxB÷kLX_d qtƥvi!v[ʽ> stream xX[D~WXũ汋-j˦dcpwďN^(lyAɹ|;;z(? iTgKi&y)*X-quD(ABP={"ƲYŷo~voݮm̚U>o rةfAD'/Qn:$@9fVכVS~fj%XRgQ$n uz[V]9ԲsRr*Z٩VB0*Chiz43^y+|hS!qb:F\O­CWͥ G C"V[+Cv»U퐡^4WnW5R+&D0@JX HHxF! 8%n99jj2)!Ⱥ@,=!_D. %%7{2"g^FM^I9"`V)fU2Hִڙz?*]IUmϪOB]r`8݆#Fb*3 7Q c5d[N[T6ON#1 w ]vUޠ~p+'7uڵڭ*-G|,U3a AU5y)Z5pp=ꚯlN`x>RAdH0~oDX}X,'*^n]`h<^ۦ>DˡZjWp?RyVVo 1J au P|V& ď. r)g ikm2]V&KVu61 S2Ga`BXM0i4z$pkl*UFۅ4aj19YN|KHsJQ,&E B`u?q ec*o\Efmf!a,Ci6y$j#Z;~W=^Ofoy!|C2 Ęn_t61ĉ5 t' +GKOI3.qcZ@**͗e9d")+쑐 ZT ˹f1 u͢DOPefԽ30~;ri> {v۳bvd(y 4;6 gԮo3ٴN2jzlZufg>'gER箪KhxEz2M~m޼Rwa,\mT SY@1 '@x+ӷt䋪Y!w`{eךDuP %0 /-.Uv\{~x~O~ endstream endobj 2846 0 obj <> stream xڵY[۸~02@+"xR[l_v%΃jei"in@sx%"(&%< F5X&vՙ"~Q{W44ps=!ݛ与U @U< ]7RmhxjRq?>cL6.6Imp&qd<"izެ-A|2[IV෤=:%9/˜U9e56R@A;hR92ʄ)ѹTƜ~3Š'};MpmFy0CA@DAL2]uI|||zܛMI'}4|Xu@f/!\GD3CùXj󸆴fΐo~8\ZK'{.XswLv͚^gNMۤٗCFB̈́yS̳CΔv1m.)Tյ#>3|BmӺ+>^IFQXk/UR;T>x[Ae̳Uov<L <\㺰UT/ 1/VͮBT6{O$ăsuDѪuh: &rR2VrʰG~ |G&|c3 rpF01K, 2E-e({ \T>(gsK˨& k*D]"rWǘ]BۨO"#Lՙ֊׵&x},)MJspf1k9Kz,F #&1s0i1u &GtfVYxCfޫ`` ڛ\9ҁu@}N[PHZwoál^7y@!&r^}\fY٥6U;u7WIX_ﲘv<\\ B{IЯW ₥5V\>ͩ⛩xg`]qW蜰yN6N5f ~Qԣ,e,XP.oMƺ:ڊr jEuwf[QJ%6:/TI84OA댏I2L { +0fJ=WFp!xrE,NQ\\G~i&)֘a+z fj AF?r)C#ϲhVb#rkܣU]U;ap1">R ΑɶXBn7֮br`MM3b@Q] :6GC,Q]Cg˭ Uxm"cSF({$\Fظ\` Vc!-h ͽ(AqSz9W,_qHRLm5eio8u/ Lrq\߸ ˱.g wLAc{f򖃇s5)0:E$(;>l`d:TԛV5/Uu屠180=LRiO=o63r,A)<Ojyk{p3|_, ~1јim ]߻t?m*4<Ã_JRz5/laN9'xYz(wa_(Xo〘8 X> stream xڽWYo8~ bKW rEb7QIRb+ݶ(KbJ#7mao `! t&`oL(+@B@x&sq\LQLrWOON1|.oNQb>/tyKC8ܡ,kԽ1[(D e}{r]W1$BͅŎҰlXo{05- ?AD !?Yط!yR4EvbChR3DD";=y[ӹ$@$$>b*mE[ku$,@A#~Z*L6Ljt5b8+t. & 4!ҁ܊] 3Qpf楛5*T5#;jBAmN8&ek:~mfg`@4oV6?qS?Tu愺vIY,Mgt6"RmH ˃0ibh̟Mx^TTp6RSuhW$_w:3DAh@4ʓb|`4cem74 Q/ZկVAVl+:;jrO7vptrW*!vsWuhEA/?4LƤZpՓk@9E3!p-W XQXK]>1&<>4#M( "Mp"-K$עӧoRpeI ZQUT-a(gW N$E\f3Udٝa~v_E==&ʑyNS%zVy)k9>{ȭ!q+S16O>,TSO_Ͼ䩬 endstream endobj 2852 0 obj <> stream xڭWo6_aer"% [;tv3dI>HUN4Mŧ\DO.2xZ<{2ETr!ECӡaǁRϗa$j* E"Hx"ѴDVpFơ B2!7MeY,TP'cL%̀CL7vD+!tY9I 6ö:[{`{0\Oɵ)B昂Y8rNg;љ#yyu՘4:ݍj`1[Ki.8w2WiTJџ[tHq 2}l`lw$AHh0Ԓ&!f[`x뚼"ڣA5vkю7; ج)N`%S ,5f>;;}˿7$7fǯYLcxQd̚]: kOJdn4>0cZ&Bd-8(-wpaH`X7&' \98bWm]n&*u=/ :gD[ۺ[,2UVPT~X/Ȧ*{ËmqމcG(ë屫0ÙKbH9!: H̵a_6> stream xX[ܶ~[4JR؅ HM^*k;J4XxE|!5 >kx(";a1bQ,9ˢzp}G,KˬduĊEt}Ro_=₧y.k}M"nKp,xM‹>My<]{ ƣJ"˴`Ҟkja\ƿnJW|@-eϢ~jj.ٚFt[r_52,w:^lx8DvPOCcFA881Zޛ}[u[#04ۛZ.{1Ŭ MirzTQ&ο:Wj04_V46v/c@IIt7rd3gR/?4Lj.J-0FE.8T_pAzlYd_n 2W̳|ٺuJXwz4zF붡SPK)A#42Xa`YZ2_{Ll^2I2;㈖%%HcJi\zV55D^x$Tu3%(s_ɫYy)^\i;\wdUęQ ^måtal9Pr{\TG7S)֠|ʹ ܎!L^\s)AW7@1Ŭlt8 A`#tB]Cgs=`t^OG`3Q=,+g>? :~UGl G;^о VKCAPKI/@g:L[Wtp5D6h(d);j?_@RQ{a 5| Gh]l9864$1ȾU:(!&%0H .-xX{žg[L.x)ažԀ*'eއaYsYg$hIuՎ Tr^uV 3zVTAU3z2ℇ%wPtG" |>*ZJG>o9A}24P T}q},6*ua"F}TZLН[=NK\y]㱿s02~@d薖p)0;|<GA>|Z%l[w]EfŹcZ%.Nt,'6Fsq >f*$Kf3*_b`xQB HϜ1XWjE %!48_*n&wK`H4/xVz|cȰ ?|0KkbP!ls ' ^]YRLJ1HWV*Us?PKSG"8~;ŭkT)_4a$L?sR\a?ݨzT|U~b#-`VM=Yi6A.; R.q7Z7^(䪵Bӑ8W-4EqfU4dp@~i 6?}q_sR8[A¿Iv'Iݓ{> stream xX[oܸ~kWQgxnїLB#M$.ËF9FEaCQwn9T5a ?h4Yɛw~0b)H9XJ)ӿtU:7_N$S$k 웏bR0Z$KYI+?."]W?]/+wnV M&qgBܯXn{a[(V.9-4WʹVD*{qRx<[. N+4Gv0pWa䧶Uׇ þ3}_M&lcآضn9MbXѮ=қulid ,ۘ~]]ٕk7 ?~N&9}"sIxcLVd79ĢHS˂7dF\H˺v9x7`+N`}i7]bfJvQ%3MA 8#\ɓJ*N '|fpb"!像\ňjtxtk6cr+|x#01Y[~݊ȬJ_ݼtp*69Xlʑ*Uyf3F-=acg4m}$4V@8k,"īwz)ҕ [yu[TD@EM r)9_A_x5(痄R@E⛏ Þ`Qc a%?Re۷oc8PS n΋"I ¡٘eڎUfV4a>wPvվ5=3n?8uL+r>54iz/MegMySc@7|P+3_BaPZ>x]/KR3_ET 8pݚ P~-N/qyA yH9eS UY;@EnUQٖuob8< UWhŘh1."0qul<$?q,;t }\Hvu{IgCmz7#䪹QFzcxuN1YnN.r3m Oww)3 =ưg* {:蟏%X>%̉JaTg&mKD:A-]<uZkaŎE;W&KZ77BV&nP1E_U8VBcu6+-#lm%GJ^h驳٘ P6 ]c(HvL :x©*F v\p! JaHʦ endstream endobj 2861 0 obj <> stream xڽWYoF~ PF^<9qa8H@>bKIqً問(dWٙox {17_yGSx8DibopaRxw=B c (Yɇ^JΙ^7z$땨F$;5 8F I(L)- !,l(!Q@eP;N٦1Fay( ұY]fل!~c1>$f-\pxP~oMQ] fb"o33=8]vut&AO+gXQGn! 1 9D>uX##8q':)2,P̝!?F'(6;ɫL)~20Ye~.Eu׆ɡґ߉]u-0 ! BT5.aOKa ~]u͈c.mhP˺Lf<(S15KMlmEW]K UlV[Ҳi #(V7ND(ds͘ .Őa7B &ռ\:|,׭h\z*Ȉg\ )!/XW{(y)͔H&\.-> stream xڵYێF}߯/} L$ hG"^<`?~9iyf6lfuUu_1Wl;٬^+΢e|Ytetٿ ^7:RB\J綨" ?W(15r8i ,J_~PAWı򊞦m떆CUqipgqa[Ҁ}Qۼ7;zkzei]e6§#Udtĉr+ J` [ak}{m5 䗛c} zrY \o໫߅o\s?\: +s7 *Z ^g},L >"9(,".#-aG^D  4D]ɟDnth0Ms@1e84|G!b1FwZh8q(t տ] Zyg K,$*&lZŇDI< 8z`q4?ߡ%i9y1Ϡ¨Kǖ&=_@yչ=v@MĿ8l̎8} eԅ=Px!Vphe"f a j IГ΢}G[E*ϭeH*8!a" ʢr2ݰCG 5k1UfmCl[<]3 2|d 8ܶy5?zǦϾzSpf,~8q4 / j]ЇriýNg@ʧc{ڔ9*-?9 C5y7^hQ]E2+"Z(c;rڽPV] ]}j ӭ;΀h?2H2"u[`K$8\!=akoCN֌0Jٌ٦Qb?ƣnB/0db$f}8bg^9knw־)1Nݻ-4QZ:Ѕ)2>π92XUTMh,8K {ȸtL31 kοjЀ7I~f ' =\@,Kf}HಙE@1ʞ ͩ{q /X~5[Ӏ{w,;]$(QRyw2T~j(K&t9ΐH7D'48뺅۟4Vw#-;q!wC{U/1ڌ۟ꗿ % endstream endobj 2867 0 obj <> stream xYr}W)\&7i/n%YW THj׮彎-HrO]G@%FLY(E1 o%ñArޯ z`j|zasx "clq<0 ޛ%P *n*; 38=0+vM@Arznv}H,CN4ڟ4պ!yo jLwѸX$iOԈ0LքBYQI~s0(G85_Dacmyf:8LZ0VH8o#/&I41 @ͥTaGyсrnxr"^A/E Ǻק hvWT QSy/ux $ t}Nm{]yI9ePve$qBM_pY -v*ƝWsUsZEσ y΢3#EÀ{;n쇔H) z2 2TeFwbr=I"~w%| Q=GU0%DW@ޯ0Q]G춽4Ck܈""Xk+TKM1hcJ)b_ȇe>ȍ7dSx 0ptNh>I{* a9o.QWSv́ji_F詳J W ˽:jY]?_-lH@M] xUU[ !j4T#:moX5?]-lMn'cUof1,7m%WdlHx3&'7x EmJ~ ^]WbRM@ endstream endobj 2870 0 obj <> stream xTn0+xሤ&S HtL@[$ICjBn/E LߌBDpIcrR6Þ\8yd$,WTVHAx`MRD$(ݙ\_GKU$s7/ڢN[wf> stream xS(T0T0BCs# 2PHU4g endstream endobj 2876 0 obj <> stream xڽXKoFW>TPno7'q9r)"**Iq}񡐔\ofa/IC/{/?(c-7 *.̙0ր(L%tpAYΪC ?DRJ*4;4uw,@y'STN-0ܘmf< Dǂ~_DOU(|@J{V54h|%rsr8kkRmD(s *߶\qF(InHLRzfnve7GWcirPu'%kviDUs$W4|,f˲o)NT8($ lqJ`N)H͛g$WR'X#g9ў ҎM]mR2Q ]u A{fQ8!WΪs衂xe8q< J'AZR74mB?Hl'؇Q#)?o)I^F~00ƆP&}OD/oy(R6=Jә qnV`:-hLs5?ߘ*KA1Qe;Vkщ2"N"$N<,SANZW}tP'{+ėv~|!l*XZCeNk_G5@bx؉*˃QQyM0n!sGW LcDb9rpM~Js*c}{sa@0 *2P_̉J$I VŇRk/Z9/bZ:fw'Мz{{zym"!O0 {ߕ?kњ:Yf=h3k`c]ڱa2f}jn5xRy51t~`ʯf3eU>jig}M Wo_~U{_-2]M7X,7aJ;щMp a#uC%/T>0̺a~( X]0G96: ƪ0R_LYYܸ$qݧޖ(>Ov ַΟ"pS^u=Ń׿ucT6jTfYд3yT endstream endobj 2879 0 obj <> stream xڭY[s~TgD{-?8ԪӱIqg\aIВ{. @v31 vOTn73̄Sn{iL*DZqB)*ƒwv[W8?vdz?L~Ws{Q}}G/D" g tw?~woo.Tf~ZtB~W] mP|G"=/n.?Nq2ωHcȧ?7Hsr ^S$rRxwZJBj<@WEImsGp܅Zŕ]QW-/|Myt,ox|9Opp/{KypO21GT8(,bPEYM3W7`a :ua^@(npc緵)k{7Qݛ]lxe@Kc]v E8.sXHI1{0{oZ2r<**[;-gR2h;\5>B+]mtQl퐓^Ch0L5|B /zaK+X٘}-,x#*ctpv(cAwJ`֊_e sJ8Nܴ]e<7u`͕Xs%JdAO()IE]sXeUPi*R~ 9?JEv-nB8{R|knTHJGnŔӎil:b/ {2z fL7(ՔVC?J&aOiDJcm-7 7 n;e朩^JZYwS@Mi!<0V & rdfVi̺4gD839zv$B|g[ڣNġ`8FtCCx8 f,,vE $RH@H Ra;xnYORPˣLo >ԁUjNN-/U=ƥ4C Ū[ Q!KK;䔑@6! u5f[TkU |1!YΧGĩȑ}j?xRɓP (5^δqeNFR}ڮȽH A׸'RrBzJg8>/nyV./vPam견Qi/pv;F/~xaS &$ Eu3i Gi+^l%( BU(TQo)(6$mwC(K;I Sf _!R&3`4f[G omQd8Gp'~>NX_S9,JA H5"0(MҦ]3i~S+Q3ψE}y4}ϠBa%7Rp0Unf?OQC4ڨX9wBmVֵHs8p)pdR\`~EM-T'Jh??.qdBrޝ&1@Ok͊.pێb Сj}@ spj9C%Q(V B0Cbੰh=U #Fd`2ű!Aj~NWN0M*ҁS|r\k0|:NTB"O+8IښJ쮡a++% xlc!c/CTUR.T:@`OK*8|v2)P#MTɗGw\\}nOxޤ!ݞ a  oK~B!\Zc+ B xSw; *pF*P% VRxm 4'E.IL6ް n#XgWD,";eCq2N)M◱{"ązNh!1H;ltBcF8ī+#2NRgƶHY4o1GU:A+=(txWV nSevtVم1+Rhm〸Լ`פ]G (ڛC&.n3#KX ͔ǝS\~$7.^}%ۣ >!QuֵwjjS}0k=_Qq0* Ը ]L+6zVp^7Ko/ vqj=>?r&y{~'sϠ!-}}i$E04$i)z *k):[vCwRv(*n,Ջ=[._P;.kQN T_*3L N 淬<ǪJ߉ 纤?.~j?[X'K[☹@' it8!wx|sv~7>Bt>"1@?Ce< ¶Ie vC#Жg(6w}p^~$~(PTpؖxT!̬=w",S,,&%яEfW*TcܻCi~h[7m 8G]fڀH\mW&GcOU1ɞL/60ب2pѹKuŸ@vΓ1 *_*sjJassŕTb/b/Y}ޤ]DN2wvn??x endstream endobj 2882 0 obj <> stream xڽYmoܸ_xH*WH8l+m$mpHP-6 =n>m&?1wb3Vd\mp e7ՇLJ86R&BަJ䷺`7LK bqzn4e `+Xu&@'i詤KUd\t-1&9笰浟!3Rn5*̛dܥ/wrnn^99+eTI-*Iwn}yJk}])OpZXX33܀v{esvf%afW@M Wt?Hg;~ZX@gVҊa!2ހ $;8$]]Ty@snrԎSjpƞ-Բ)Ǟ jf@~ bچ?>4cofFw8ӆ)]#p_,`H8772Q3KXPZ"@k*$ JVLp\zk}SgXh3B&Oǣsn/o1c4qrc-,!o9}hML \!S2Z] ͝:QJA 53Dt0g'/.LvFI,|~R* C\m@@qP/~Y@lSru_.'JuwaBY]8) ,Q 6]ߓOP&X&=>(3ŃAOѸςYW@ӂӂTcYwv7ا(u\Ŭ5JU0\3ec f-.IU~ìN/&7Ɩ68 !p<ߍx+L2=ĭY@lS٦sE.FE9 s 6G?qDU1͜A~]:>l )e&!(a]-ą&5٨Z>CjL/uz x!(9@ЂV䄑o4JsVfE2}$"h:*Rt}MCWDe6®̓j1CA=6Hfu?|9Hk dErRht&{rݴ(O;еH.`!d~ߖ{TJ=Th>Ư7理G VWw (7Ys\|4/V/8,\hnxiU6!Y02 4 >݃3Ιk YtU@>:4UD &t>'V\}cA{EK?mBsC0ese6w~ri^kփzy:>9`%3d>t5gw7샓сZqjI;72xu_/M umlɤ/d`rՁApBag.-8ZWOgA""+PPCIIX}vi=N1tBTm pׯc7s=!-n){]ńiuP;q l?îoib}oV"Bf/do!  QˡaO]T,5 OX~+a1zX+噻[Uw21H D$S!EA/d&kgJN19a64`,HS)da5dA4v/<قYS,ʄ>m))=my`ys 4#u^7Md|md 4_gù P^^ mdS%%0xrӯFGHOkj!Ӱ SXm!%::2Suh]Iw]{Zi_/j 6_XDp,jW xnD,-8#I[4O>?k`\ɺ?n%s<)w}tAlNyN ~XR: *箭׵" B_")EH3=i wggUa12Sl'ZX}`%~;yV0q}k qd9xufFv-Vm)ܔ㶰 |NUT^/@^+#.22N=6|x ^omsmt&c%Tyj62/ y{ Tԕ{( hx>)Y!Kսtni]sۮ5̮;ne> stream xYmDί:/!4l.lUxf_쳯C(z;3L?#a(b}~F#ĒDMD0$y-ׯcśOeefū狄1z? ~hv6c\v{7Y$4N Ž3bamX'Kxv#q{Y Bu7x,8JHcҦ]$nvZ~ # T<fZwm 18"˭vxFXvnRC뤩{'<d֐ǵ~I")ɅC;ltk஘<[Z!< /eҚ)=sD%#OIJNs{5\a­l7B|A$׳);w_''=(%'3ǫSb}_ַ>llB% BubdL)7ifbة{Wă=r)faed[՚QV OANA`GJqN@gdEHWM :Axj/^dt"A7U:Kwf.X)\φ+ Bd&;Ek~Jw_O^,߾|zdyOWA8ƘfwN\ :LGh>2 Ǎ?ņ J0\(Hp&c0@%g=@*i(}뮫9':y@ >?&7 DP:6w v!ZIV&YQ7>ݫ["Cf?^GeHN 9=U "a3hcM>?-b^1 m0@*z7϶{=$6]c߿v0{܄~kulن2T>F˺KUW1"VYTMYcQ57~5[Ū;9gSA8y ƽQ8~;Cs0i\z|'k[ 6f) 4.{jj3llK OlL[UH;ӌ璛-`J:`Rnv#0Fd 6y:8:3iQl6n;]m˭̴>tzsrgTfn3ST7O6KeS ^NؖWPxBh*l1gC떨 V+S̻7"VNN{@~m7';Ĉ=J0[u(AAW横ϙ7PjyS|k2vnƎQoZO{]ŕ]^,wBo> stream xZIWPfMs$c`Ai$lb$eypjH K[WVdY) jsX~["l~"zE2\?61QfsγmD $uˍPorn&ܯm7Mܕ͛rW9Qůk2o6k}~(617ESlֹP!Jh'ƥbQ+7@4E $4׹tij"EBkA2a_OPc-pv ~_]iuOSq[Z++ `:SHDo~ˮ,eYvUڼ8Q):u|,5’Tp1_eʋ/ 6emx# EDl,.mܱNuFR PCDToKu WmTUn:61:qd]dzv/ grpyU9 amce]t9c $kNI`yPäKCJB7Q}(lֆdP ).ӪÑ!ri:kJ#aD#i)i7Y *eĆx'mG "zb;ĢJ-NmAʉ혔vL퀴@Jh̉rNWt03;O@nse!Y> 4dއv}f.(~u#gAQVv4a~..T2fr!<Ȧ.PobI*}!@X .VD!B܄'R&TYľ_) T'HDYji:0< J8`W* > HקS:3j5}/1˒^!&I!ɦk"./19KFs5W] N0-RuP.5\daJ.k<4IL"+&3w?7GN?΂v66vmX h4d"Ez{Jϧ.oBβ>\苎*q/>ɆG>SӖP5MH42&d->t]:O ZOvQ(YPË^yJP] D]Р/4xVY4<^3umE C,;rN*)a 1k(BS % !U[:2ZUu.CY59zOj<֣,IQp|dk N HMDS{iz#$~H㲽O[+NU:t2+-*J& x7 C CR!йrب~6D]VI@r4,s.Fw8s$-tӗK>S+%RC:xi@ɩ4/."=]z#깭!ިau4(^ .aݭ@6KچF\ܔܛ$^;wE.|6]3D^}xX@RO3<7!sۏڶqÛ 9㡶WAzfb>OlO%Ƒ6&cUN̵ &뤧;\y~'.9nh(E8WVa }Z1)wWxDU_V?%K 9:Me!Ar)q*ΰ>͙sCduz}⽈9V1uW/΍l:YrU*dL932 c?_Jw֙c cJJqDzm>"\NNkiW7^hIV"|mm]*n+}jC7T7(?/ .d`\ 0Q){C"܃Tl>9ئ+܉}U!FpʳmxQܯ.|都 gn"'--D_R=>ZTa@d93Lu;[D0sQ б# sJ{L\&^ Riydn4?AF(GO9!m /djSMi؛v KƦ+73sE Nva!> stream xڭYs۸޿|uc57is}:S,^(R!8],2d;N<>~c^qj}w=ET0jcqXܻZ/|﫿yԛ^ﴐmKqq5qt荏0` ℇE H s×_W|eyN| Ke˅oDo__&NI #V$931 qO~?.A~ Yc9R!c@^$pPRx,i/@XraMBށۧ]Ep{*t&ӥ<iPm'uo֧τc_ꗐ7/ɏGRi{]/azî`%͕e]H~sH,faQ-˿g~t? b1ʮv~HXmmY;$ֲ*x~Pp-<d]c<'}vp0=s[jk{% |rW6vvϵ#ڧ3 hgt7?9^^ :1i?],0fE4U ѭ1q0O-ԔFY<󭆘I){@WA'!a' ?KL}CB90ɺ뉽Ufj)Bքy!3#ײ5б뻛vvB>!C.šŕ7]z"PNrZjK*y4ADiBYuP7TA&DIN9YާDZH!),ȁ|T^}nQqb cW0A Wԝ M]krLBA 1(ywr۟׮O,^w77|,lm]sS;+rPZȕ`{Tm)\tji{IY1J _y : C"s3{E,F UwLU 0pT:`P]E4 9B"J~̮/}EzaDA\6T$L? !.VpZ-zύ kT@EUM =ĘT?HX߀2:q`Kłpb}L}~2 ̔0خnr3 mGZĐxG:᩾\Ğeaٯ%M0ՄNp( }b4 R*zp]:Q Ҝ6"5E> 5DKE}S4`Q2!C2G_``MdfC_.a*&{fXkj8џM`NFuRz D5> stream xZK۸Wp\&xɻYWmnO2#bF)R&)?R 95*8eWAn2G7lo~mhFLfnC Ĉ|s]$`s0*B$E TFT2 4qW* ɩp{_(@]篯^9C&~ݯ^CєEWUs8//"drCUTA$m&y$7|޻{PÝz_@7b^G{juWѣĈ?xY=lH? -5{gO?V*CeG)Mj.݆6* ŻK$3\%{/^j }!?#@J-&dN1g!pͅV. h{<{X~PP{u5Ҁ{b4gb`7B\;LYC6jp,bF7}>ڳr֩[>8qamW9x{^ffaTy h1X{_*qΉGfS賝΅U/KHܮ.<5ߩ0~YK.'ل(0h4|ۙ ǻzo:a^o>n^ &@K= -!~CARy=6(μ/=y*mz˕nȉf<`f$:`kshuu^yk;l,\/ ?kٙkLG7)DOQ'\Қ>9[Ѹ>#|D^Swާr#㮩fd*$O!g ˹N&1ܜ?wY#5a'ft>U0aȂu%ipf4"V!OA vL6T$[Ŕ+)v끧 WAS)KNti!|%ML &%'TT@ُsX@A雍{!zj'IhſN/5"lQC!; ŠAǙad\_u;Xr>4<ۣp~cWl,>;5x_ϊ5 9uw﫺k͉h/ ڇbz{ ̆mn*fS%:¹\⋔0!n\)KT,*n >h% Wϊ:Lf/o d]2H@zL]CMDP,~}n8-Qnj̬*EH0k{,(wI3Tzi O( endstream endobj 2897 0 obj <> stream xYY8~_aFZ5ٝdH8jږIN*MŢQ,"/ZŏW y,N݂ۣnQlK i;Rg_Tm77VzItxv g 1ptG"at"=E!T"c9dJSL%|Ni+0MD̕۞)Wjeȣ82ٱΎoOc#_ȧGk>=Zu9c/t a.q73kT5}ZaP#0)cU҂<eۄ%mQMkjI(x!FI~jsXΌ6E%z x7nGN\0.Bd. MA :wu{;&\Vq=u<騖*leSw}{(yQ ]>$X4pIYF+X35Xl߶5 >cDVgF+PCMŷNY eu:n)$YnV;mݸJtB`W˦u߭m^޽ݕȩ.<:s揆-7vCL?QT Xe8a|f@PFNP\їWX/Wo&lHċ_w:*8pbq"Un 3u!ssFJ8)Wܧ, ī1 ?X8mjb0MV=M޴͎6ۀ]835.L( P)jp۪/vgA4RЌ}^AAлVՍoU]nkV-s氵I5~ Q5&8<$83NHi{BiS3tn- ΟIyH|qXK<էe'Xfĵm9:~Q 7YÂ`VjԘMѬ|"!(4N]!Qƚ<"XD Ĉ=.nI>؈SE `ǹg\KikHD>{.ufN=5QޜE Ul^b)׎ic7R:Dو5n|Xn{LaTEQ:p#l(\t):ġDKoVATW \ UVb5;n`UMN7N`k&Br]mZbmȆwQqL흵Fa . -pLS"~};[R$v`ܜ۶iR)z2P 3EF4A:?P=`dT|?jVo0DK>oP`}qo@<1۰jGc:0I7{l*+4b8?mOg@2fQ˄ 8A<@2t@S(`D&+?tvMb^ ǤΆ+oQ8o^;t[j۪z9˿[ endstream endobj 2900 0 obj <> stream xYK6`吢Lo9Y*[{ج#A3RLRvʏƋ"ePmSqj4@)#H(xf#5)3evTGo XNM9mx$ Nג?#V Vfg\p72DBҼž0u)x,?۱ڏA0+(̜o_0Fb $L;Z&%QDi6ݾ0}F}qJIdR ^ѐwCUnd`XʧTh] l ''0C?Tf8Z=K^"M&iTش@ 7{Yb;W PmEPHI7` #8؈yehC?62)ׯS-cʹD`?( @(%V%ℬJB m*>8aUS2{_J8o%ݓ3ԌCJ9~%mƢ|dZ )';ICIcctťK*ev6_Ѹm$C#.CZxH킠`*1DdN " # vf<8GڝqMݙpgƮK1p'P"[UpBRV.`6Dz2N5P\xaޤj{S2 P V_G }A,ۂQ27P?|ݔl%VAgS(N%h̊Iyi03U" Gn@F"cf`Վi>>bgm:gH / l-`e lN$^42nY OijS68Z^HwO ?7}gsV@=/w/]@ XӘq|JnɋD9|\>*Oa׎O쒦إode3r:;A/mt_zsJKe>V.{[dݖщV .* \mڭ_j,Frؓq)BuؚA V"CflFD^Y)dmT`kB˧`ؼ+UӸPqޭiEOPt8g=4m*Xխgc~7?I/mфۧWml&D(`VB _h B`8nO*e!> )^~& ]-%uPۦw٧  0 a `@U~IpʼDF}LUs|f=~>l ;؊.fMŚ;5;!vE#eha#eut r&'u8mPh,8p2[)?l92C۟CT uk@z )=ǣUHՊ 톊STiURpqshK)U7Zo~bq_``q*;L롮8R쮜:bռboPk3{Lx?D%Թ1M73JE\G"!%B[ ļٮ,m"JYνm*ɚO Pf"N>TSWBl띊Ұhx|iV&/H?__.:ѕkӮÀ_Q x:G>1JijXUb T" _f.(ZK;w .ߪñ]\,N' >q=&(Ͽ`!?ўEvL[R βg.JʛWa%8;+oK+G 6,xT_MPW%=F" mMtPpc: ؁N;. 㱩.9Pw L=ߞ|PG4O[OS6f ?&y,g ۣ~(gwtE{+KDSIݖxT!$Eܡ:i?}h×n%yƒ$jx NBC5|,1'fˆu,8I5K:c/>1M3tSjJB Xe_kv)i|~^',M~a1܄}(g'߫wMثTgl~uu{=l] endstream endobj 2903 0 obj <> stream xY[sD~WQfex e`>(6ؒ0xJl0t˹~;䏄$#'MU  6$z Hx{}BEJ1XF/_n1Ҽ ߾9<<6tvm!L|J#Fzx{ovsSln ~kL]vzKhމ[zXskݜN"4"L3ovxiʠҍ]ykl9=9i[`+[Fc #{Kokmlf+P/x,#d%&ֻ>@2_5 HG}Sܭ؀ |{ɘ m66t}. QGOݶf˼q+\.mTn/cX,{KònXI"Q9$m*Qf$< tu]0upTUPup$'lB5:DC  !t|rQ?Y(ݨP#=[ީ2d2JD˴W΃!1`%ĿPKE!Zc1⊪%P>olsr\MԌN^"nt9gҝ}OAlt(Q/έ4ja^M@CKkxCXzٯ3 E#pBgWPTc1Z1F;P}i6^Đ]= v^@!^. S47]k*pޟ+M%<x0Ha%y;$k-/Q'9xJUX#FR|Ӌ!sDZF_}J3O~YFB@0K m~Z(zld,8 A4aGqǀT- &2CA>ёkP_5Or_p¬04BXAQ 1d=xhzKk^u|#u^Bڡ. :<%>azǷq'" XYN+".FbO(*Č_P>4N!PK=$ءA{C;gdo~uPΙｎGN0QQ $\20w*=9MH_C}34N@9pЛI01"m0 g.>^D y2"2I 0]ny{ѥ6SH159A]Yd#K)nwz>Fß,irhI\4ΥOFJGQ7;v@rk4<hӅx83o2&cO|\,Qcΰޖ)qc'v%*TI=fUܬn[nW.}67ymC\שwV+\g]}0a€Ãm> 7p@)ub;(4:ӋI oJęWcBܸ9}"0<Ҷ.V15:#ǝ٥”[8 V~# phExme08,R2WO endstream endobj 2906 0 obj <> stream xڽY[ۺ~< s}zlɑlwHJoYD$5|MHI?,/wɫ4!lHrJNCn9}w]2XJY9O-%,~K‰@I`kɍdn{b``jyfU ҄;w̷MѾ~oac1G$# 62a6pno,/‹"'p` ԘR/] }*#R" "k.,,g'Sqsu {~ @UUihP, Q*jD4ⰾGNpfd'03`Jb|l@5]\,rT'{>1D26&eJE-vw:拦`Bu 藐Ҋ'II e3j ~d]YW_ɤB[Z <ČDǟ;H'3tPi3ql iΊobG=e3$-Wb1!Of*:5uXFnno6O)9ͪ1;gZdPWOKs2f0bȈh d6G<yoʆvϫ3|D#TyW$@>#B!t.|,V~Ig.bi4/`0 URq]#ߟKa,Φ5H|i2'MaPr^c;AK䎄= uEhJix i1ϨgԔ>X (mF8CB\2hPH\ )%Kq]T'R)z7ښѪp8|F SUq+|9"d>Tjr"[Ya;DT!ofۇINJ5ZhvStQeVn7u }]v=~ MZ|ݗfB@+n?&!`f/h yZFMC`t8zԭWuuE5B'b5@cd=VmoE4B .}uIm lmi`0 ̍rr7]ox+=*xw:NI9q&1VNyӭ=./mh OY1mKpбGx834} ]k§53d@/ IcNA 0}rGP!o$뙃 e9'GF֩ n4ܭ&;tl4L3JLuSQYfmrz~}з47fd/Fw;,LaFWb &c1fPBozKH8h~y靼*hHh/nPc^'PI<43p/,9t01wj2mk2wEȡ[GNjWBSu4 b\ \xu7"Б+n/W}qp%=iu۾lcv8'Wd 0]cMݡgguљ6A ;qnK2lcTS$j6̞6,ms{EȄV'm:_06m k1tu/&JŇiL[nG?C`0pzçҺ gv$GuJwRv{3nCF{l}*{36Xs=|{AO ԰^^Jd;Zb~i|J>߼fE endstream endobj 2909 0 obj <> stream xXێ6}Wؠ+D)Kfmbݾyڴ-T64~|7E\ӗ-PxhzpHѧG)|p$rG7$)*GuST<>Ef?E$_oJi\6+3of}۵窿7?r͌xVou)G(a1ӾeN8iq3ߙAj.t-Ͱ5wuo{9|~oTA[_W*+"n`pN%M=Zr}M72FPx,Jes3]K Hj., QQOF pq T )g\pWϒN+=)?Mm, {1.aҙ6M<gI;9AdXqj38!PyO )C:;?Pd2^m+]Avbqe@=Xæ) 8T t< ~" d67V)Qu߾zjΨ)5P,2H.ZJ.RH#a (f_h:J/}! Am8>)S[/!eވmԿT.~u[B'?݌Xj(jD!h%ܾL rȹFhÖ|Ž ~ EPnPbO|4v?~ڦ jؗj"of9[\XVV1A8ʊ ? 6fZv]kWh,AZfס#E.]*(Ъ<ΊN 6`e:Cp:k+4nͭ F 01Mk  8\Y>hˡz}NrH_~V3Sca7$޷<@u$Kuk#pRv_К뾗!( D ]n\}:5V߸:XB-T=}8=cc)'Buk@^̫G:{Y؄SmUYrcjAX=*dDwv^lL7V> 0'q&fy߶NT,3- 4h+8qTԹUmj`4>ZQJsiDsⰄ Op?ڛsbh[4͎Pj G@ʓimRmﳂeh?G#9PGU/%gc!@pnd# кKʜꝩ0px܆~U}}^zՇ ܺ{yy&@Q$. 2 j;ц6xt# G4k_c ^=QΜ3tf]Fm9-6]E)}`2s/yNW:XrF<s*n'EΠb|qr*{v(k6Z>jP.`k 6F1 =c /ud@,F3>(G~x; endstream endobj 2912 0 obj <> stream xڵY[~P s2z7۾X~%jD*$յQv(is(Ϝw3<#3 LQónٷ`n73gc}f2^Sy8H2 bL 뷯AU)ϐ&ܮhWMʺz?ŇYJoU85c:5EwhLP:gٵI1|R*txpߔ dY|{(bI1 Q͡ZcX0LgIw_$RS\0٠Xm/<+!]Hb!`bo \*XC&<}ԑ+Vlk0Cg!u*&py.ƃ+E2)7FQ՜r%u (mK>M!UN!`2Q^NyL.g26m#p2Y#NYRs1u'H*텣yHni:)׀ rTA@j*4 u 3OĠu *ŗ|mO KگUh"z4o5Oxi&X%;we^ i]yS'!=#dX&۲ܲgNQ7P/5s6rI -Y?"}x6 3Wг'TNw$Dt@}wu16#e|2=?Ǎ5]t/eTfKneP9B93h@hY81CDJQԛY'rfR[fHi ʹϻujp)T.đ'aWT&vvcazsJ B#G1wNPߊiܭ)'f{W{k0>xLD} $Ga9ా\}}c7`>]s㖼*Ca~p_"܇qxnMSTnY붬 4sZ&ݔ[/3_J6_C::VAvw(up7딿enۆw}6x0FƠbjoMUŏ{QS`c Mo';QA fkU:,hjP 1ÊUw ho* O9Y1N 0-4KnOgmr/7>ޤ۶GB;TuLXeE<{th"nɟ"&W;{z+9<>wfA2S%ؒܟ3`9tԻt5iqyF>)xGi}2hPGuȽq]n ]7}woG> stream xڽZKF w399b@0݃#H$S>5lX-Y]絛o MrCo7,9)&w 5 &޼K V0ΈƧ^8ilooump-=]e̤ӾjVL r8)(žSխ[bpdTŹU}=3Oݱg-9#r|뜦KGӒSZ&RR}ppFRǕiU1SnA UieQ6<+3  侳pe^3}N"(M d$($_60X}F3"D`8ɺ̋F3haWw yJ0s@vW*4Ӡb$?7h z kX\KHAl.%|]Lϡ#x6bfYpqhħ]۹?@zm/TZ]Wxz !VB;>^*] d@´'G3 TN~0>(0m̭m^yYG\R`!:rzc+H_/jݏd1'wx# 3AfɁZ衡Оc(DKakHcO(/Bd(lݸ 2ll̗&u{ ZtM `"F<&{f{lVcMPW(U:?HOʕK.Wck0ɆW/LȤsvv%c_UlR ZV$xw?N=j:M^c|<@Ri9ebc9EPaA4m-Cû(g)\4>̠ g9ց.ӏ7߸k-]ce: 24=F_6qmP jC,aoOb>y2C^FkLslBlP9rI4rwؖG:-~1цH ݷU'肍OvUK1R}Fe8w q@ADy61aqˍn#+x ^([*IRcyk؄[!+ 9KEӻIW$y^18Z~c}M$9_^egs73G̒ml<eK/+^Sm|]a8aJ >mFDY?}e?yK*nP>k$TA^<QFЯflyY2 QLܳ<:pa"1Ndq7شP^#rH ڂC롆$񏲉_L=jamӃcv{5HNb3auG}GS-p3tl*{i%ClAeKd(3pJ?(Bb,6Mg*侢pmt~(8l69aecA3)+yy8bRx<;M5RPp<coH想> stream xڭVKo8Б *V$E=[P lKc1QYR%I~ٲ-E|༂ b#AF?:xO".H~ H$#\N>cU%I($㔥k؋4(cIb/O%_C!VKs"ِ{QFst1:NR 6T.D׷⹶#}쥃Pm#K'Y^~p|Oa­ٺ-~ "q:oaΐ蓖@L<1q}OюF^XNlC"7^hy½u5³)85ǧ| <_r;h79Om /'̳; %8/F'Nm92 C#PZ[}l5Wɡs$igI-̻@bыR%#/0yH;$U1ߩ-h@|XM1]Ejm [ ij9ޝ6BFĘ]29EBI^Mđm&-YܛvӜԷVSuv^kǿd0K}1ɨt\I֎ ⛌z6`Q;#3a1&ܽ}\ְs#@2X~AJWQ&zQli{*U/fAw }@0&}T o'6A;Jcل%3 uRc'U7X4*gKHqJ GOdT3H2.d*2F^ep((4[X̀yL1aҳoaq\V@9Nq, ZwXGsrsZ`spٻBTosX`c{?y" endstream endobj 2921 0 obj <> stream xڭXn6}W,jӊb )mݢ@yhMl M]16EQgf833\~B,VŋdN"y!R"]~eL):_e/ͦEonkg_5˘j)%QoPZXKB)fF֛ˬɢDY+=st{DR%Nܚ}1Μ!([,|UteSIHUecl@;QEm>ӀvA;|nH6D~L9S"C$Oݢl(}§0B?)Xr]mgaE Rc` HwbJ /a3rͼ*uE(ozhg@OƗYW< qؠϰBE tQ%g]k{(e۝rpޯ.hˆ't.F0 Q卝+k;\鰺z \SD} NY(m72 bL؛ח:nXtmZJ}XvbkmȘE2C!.cIF6k;JF!zZ;e]i҇[5N!t t($r6)j9"~ +A9KGwqꦷgB0XE>7Gv9Cib^84ɑl%ޗ wFSbRIo07z)B_vU&BRl?j8B̚ I}¸Z@7Zi8V","fhh2 w.QqUۧ]N1{ZIѹ޼=^P,>0^akCX$A>v ,z a>ɻ?>9)[[Dd7Bh>c2W4YYNɋU1%ښ@hJ.x^VT< [ðUzhY|/6!8Mt8^Q.9RX#9Dj2X,bDݛAK&'pG;~Bʅ/Ŕ6iRg/ׅ[2!.UE74\ogSi7P91! $1ճM߼XgMU{T}F.>HԀPL_{8ս2T~hS/Yjb4_ f} ʴO{_RoXDn`4C..<0FT]ރ?;jh195^**A'(WS隍Lr'tri|}N$3åx0$^aMH)J[#ݿuZ^ɑ$bAfxϕis`ۍ鹛* T 24nhwnq,N#(+Aβ]_ۑM~=Ĺv< s#t,d%  TJ\]n>.g1} Khr$j22bCuVGAjߊѽ[q1 o!)A>`TxS?> j\(MӤU9Vrʹk;ɀU u]1=65\KjH$ëTwwUk'!ę/+B'X GjYW27z`k+\9ێ;. c ]#JBC8Zv?`]ECZ{`]͊3]5*j?-g endstream endobj 2924 0 obj <> stream xXKo6WEF&5h%A^qjF㸿Cr]; r*l@9"gf1 e:)q = ;;ffix_\.VNdMdT+Y"¸CLg$N9z]+]]eCm`S5yM[SbU<)ʃ@(΂HR"DPONT :uaHI NJ2wsWv78dX%iF18RIb G 9Hӗ!rzWIS 6G$c(~+D}<8Hĝ yyHl™cИw <; cQL($'N'88ؕbbABMM-zQZ3'P %,<N\8NBx*׶/+jDĈs(4 E͆A%nD\$#fUJzK j3R2 /W23Tv>Sr،8(QA0A@d^ʾ+4 1G-`у҃z8tn˽ zaٛ' Χ0̩ }!`o7}Eߑ&YD;emhEztI$А6ܙ\p/b'4TnoN~< =p_w.H10iN@-nuƧtVV- p"pw<bB .fEEdm |GF# aߛ^w#] p MJKh>(`oda* ՛-\c$q%}Pc>@Ç3CPַ'' 2gg]X:f _"J|fU _ ;Yxc>n+&␺"V k1TxPȊnnqopJQTÜ& MDᴄ#jw^uӬ7>pc?t0b1h ]U챼3u׌Q Fa@lN ج$f[uYY7+hV3h:n=z-MfY33*V\H] \0A]⊉ &3=ΘԶ" .5f)d/kfWFpud3*m|񣗌KYwHwJ6_XQ1tv^NQ`"%X&'v5Vm6n٥- BKpAwҰee}d|;*=sǕ6ħRYpc!bw[0SC`GȺ|<d(څepA[Ⲭkuġ<'intΈOn-F3hYe:G$ngO.e+'D yjtU? HysG'MP6sé $M.%2SSwTvƚD3?C.E3,UeƼ ]^ѾmڼFq,ndykW7VX($˒EWӔDִ P'tCq5\0dћ5 endstream endobj 2927 0 obj <> stream xڵZms6~B݉PLnm474M|~%b# IqbA&A`xhig)3+:[ng^;Ax4糫f\\e/In_3R0k%|o?>K)bWoK7m{=~_E,rw.lҹQ[|6W9˸rKX>arҔ͡(;:o|75Y/g2x_5e)6gژ9E65q1y܎F{RL2F/ 6Ֆjw;[W]e\^29Vث9ˌp\SMvi3{_djT(M|y5gYv Ts;4;)MkE7նhܞƤr}]*C3>wrGܓzߔ]IOa,6oYôկk̻sۼKa`0_t;"]kW$iKEu7MEV_tV}{M]Vk,Аߕ>̿m;?Jͪl<2S4'q"i?VHjV&N_|-ga}bJ 8n$ :[Ҿ%5vjYtQ Ș J*݀M"jE, H0eP.)ϵeGzeSZ^$ZFݽh2`m*U\k(Vn2lZq/ff 8<Y0ZCfasā hOr֭eDwuԓ&-8:-aLjFbK揊-5K@^D.7fC1DNѓ`>W)hSg 8tzv.j79&PbE$&m|OvWŎeӀ0 eZ˧r DTbLeqư'Cx&eV^{Ͼ_(Jk1E, m0a`MYju\)p CH%mĬ7UXg8`iQQa }.&4%=fa{R[cpFULv/-zwؑ w27h<ֈM=õcW2e#)'ʩP([A *~ڠ8@N v`+ [8hpiFH'ؕ 0✴B2r/xg-@'}h?']Hˤ 3xݔ6|`` `<%KK} :C4P[m]X ۶]S*%5`\|00P\xu.p@ɖ3ayiGWQfanAQ]R 5j1raր*`jŤUc+f{*SvXcqb'dMeCYM܆sƉshAw=4f\L`L[Mvl:~|"\'ܼh\)dJ?cK:9*JӇf:d0(s@JBvKZ@udB :}N{89M.?&b(ߖ j*Px8^ ){bvCahs| sLalAcVǡ2#w4^^h MeI# O-5")$V! neBa6NCe:AvRN>4$>;;Hnibޮ CoBz\avZu 6BJ(xQ+ш^@r\D%T.Uoߐòl\' 8x- $`"ZHj+F^҇)ĉfaaΕZN\xPaG t>KkgOŚ1a)@u7}.%^sխe W'{qn"*;%d*C,"{. CԘ\yXrwRd$QCty!fGsUؗ(5A[g<9~l  UY#D'G0:G6xǤʙ4t mBQ vŰ/Up܈FOf{,}2&O|rfPpx`8{<"[y2O3ɯ!ٻEߗt?zL<{(-w_ѷ7o~  t|u;=P}uwb.C7~z 5F kLsp5gB* 7ބɧ ӜY ,AY\l:mtu4 UMHFE~A~ՆȐx{?)x㱼`/b!͆"]>:5NT?;q73[ |ϭ- JG70#8TB*"tD9r3ʬժM4B{j8Vs51ȩSA £{BZH!: ExC[(!^]skCRQVq',`ǕafȵjL!?*Ty2EPOȤ~ O$R93y@n r~M@vi~v]6+W@8:Uk6ôƬñ /%{+fMԳ<0?b;Y_V$V_*GlOø=k ?:EwqQOF$OqI~JDqS6&8rH0.{.+/@Wu<.R=O]D,t8<.Ɔ9KȎ|/2*B]efPJꊦYRx>\)??  endstream endobj 2930 0 obj <> stream xY[o6~߯ЇICŊW0 MSCUfjaJJdlg[!ALGGsI)A?8H &A ^,gHMe)RL2dVQL) }ŌZgk~{0G PkUgђR3bisA_jPfxWH0 sU1%qVy."û=\P?ޡ )pg(dn/uA!dTvO yR;hl>9/|a)A͐{dm"ü*oz׸>7,TM^JMu>/Sᛢٻ]4l/(;(b )²GEZJic%7`S&PJi'|;@| T`- \Bgѐ=M&c/{y09hs7*"=8p '&^:V4w: jv u+ .JpoHj`9fT@弥sA>d碪pGKLFV7G Ip'XEm**JL~\sxh .о.֏D$UUS:k>" aKtC>on&.g`2q([Y0YEFaz%bR8I':`9ahZE;xXM"=T1d&;Xn?9@_?gYꇤ i)":ȉ>g&b;㛺a꫃2j"E:u>R+6,z؂_;l~&%{ŋ7Wu6L1t{ŵg4[9W\?BRrlӬa(;]@a:omnݐ|/W});2b ݣQ !0R#>Vw nV17nCoRmg̠7k1k(Hh1;dO:_x!X_8E!`ͮau1b;Ckr2>K$qXYM=3 /ᰡKbn?${HlRw)2˶$E$]ţ!tCڎb]c8U.\/") `|Sm4.Q\3 < 3A?\L<[zaNv2uBYݼ6[ɪ8X JEu`*_ d ;WQUp"\T 9qų較!<> stream xS(T0T0BCs# 2PHU4g endstream endobj 2936 0 obj <> stream xڽZMW uiw8!"cS4ba"VuwիWJ.>-4U?<"xs*('VaKi5TF+At%,1TLk[Iʏ߆߭azlɐ \(b%+´b#nd n-2Eb7%"w_'"TVdZگUps\kEŮIh97ʱ}Sgk)ݻI(@8;I&y"\oM0D*{|m8&rCR3+e ja|xjR9%63ߜC  ЇO.0#5>Wn'5M@'# W/q?)vQP. 2XQ&  r>}OOIewB*y)oV%#~UWq!!0fN5L\A7¶ qJN<3'bu >gKTİi Dw8lN^tvԸZ@Oah\Z&Ӵ|CX%iݑxP|.PV/K*L.ԺCr">fo튏ωG ݴPj%)v~HZEt3@8=8' UQ6_ݱ38 'vo6m=6.cKQkpN6d&[XNu-,@vp@SfBHBtJ,K*@n%.Pk-a#8J֔ҋ:]݃9^IB`.ߊCqʭh̨sҝHKP2(AQ͑oSY>t~p7_9~M_Az\G)_?zocZ{i'6Vs8pSUαӍ R 4-= KT{J#L[G@1n{[U*J1 1 1s)x1?%k;-gZCߕ_wS ԺTXX^z0Sx #ۢ.zjm1!" vUM:zv\IF6<☝134Kz϶RCm 1r8;y.y; QX2/p"o r`p( Ue!f5"gU'|zVZ/v{=Rc{(k!|{xpb hVf~=S{OO,|>/$6D47_XaU2U&@Su>A42ݷ̝Ai1.Q(vW$1Doh &@3^M~;3P&r 2ØDsqJcCFsB;GaSy礎 &BWcM M PI@Jt X&-!V]PܼMdQ>|er"pWr-A- 3,=T0T)zvU$l9ȝi%y8M 3tP!=5Y'féyfùK;xԇynwI $W8fMi[2oXKEK%F.u''Cy|Bd (8PP7q8KLsr}X) o֚;/anFaKLZ^w y7.#! 3\g7H;NԱqvο1!d$ DgSFoCHR@w4> stream xYmo6_!&+dIaCע7 AMD-94~(e'E?$,y:Q 8|M$)RtaaC|J6w_=ePJ㼼prYf7Erw_W|儈R_bY {KٽCD& H|%_}Nuޮkmn0xlU)6ڲ1,PFt"i\&)nszWX^[e'oQD UY`rKH!)^lJ<s=866OF)›UqC*ө̺ IUCH2:hCAࠠb`/P={`HH "̱Ӻ5QԜr _A07heՆ4 zO,=d?T%ǘ&cD6y=wdP!ꎐ)b)}܀-ΎB blHILh XKDL:шH):f Z) 0Bɻ+^j# <ݮh"?Wܔpc|o#3d+&Ie|Z\YḹL=ijcAE2&/^r *dY*.2(4p'2o]pc 2A|w2 ]i':B,:paxMp [3-Ch;,zju9LI3S kQOо -6.H# FR(i7ύ?{.xY.%oL׵25@F b}pF&4y<߽= gXC )Ik: vZ]p"p-B$* ##5<366vg1v+h]3le/װ{G&zv2}}5b4cvm96c]adl7B"eܐP0}0{~+C`DCݕLv`:ᚗ@T\ŵ:Zh΄N % endstream endobj 2942 0 obj <> stream xZMW!`)~iLv6V"ˎ$Oo/SEJ!eA0LW^2GWl;3[ьYAWO+cyMyff9_ ӹs+NB gYFdCA4\-fdf "Z,')cڶFuS] =u|kN&/%)T0sFyrD|y?'L h:-#ѩ[5`þiR ;mS5W0"5p44:4\]jaKj ڶMl,]\Сd`|CYW;gzl?@;3xeX'/^]0x>tӝI,WBg\D)ɋG"r;;`t}5G_[(D݁l'0fVIw7Ja3Ar_:6,8qyp}qm֜GVt2'9+@rcñ6- ުvþ8[sչ#ҌloQvfl0!ǂ vE`) ´3 -8@ Cmͨx vha7dqvSTjkjچ"%D+M5nH7t.AYTR!R"`d:{@p4aׁ@}\\ ^zIs4)(7q ÏޭmhTIIBf*e=Ǽ$^&1XhW0bc L {]C;W?4tMp kqؘ⚧`>]\ ņ$Brb^ _z6 oH ivͦ3W"t>9Guzy9B§8K3ht8LϏBdRݏy9"9H' ̉Iõ7 A/=羐PvX´d=rؖ,,;ѿ{2"3w(/F$@1q,|č\y2+)8#)#J !}؈@XR;+S$ݏm|&e y2_/+*+Cپ^ʅŤFǡ|Ҍɴv8kY5njJйjEՍYh>8zVX)=YxČfT/o\yk?o7qހ:)3X?YՔbO1uZOG}4Ӄɘ0zM]|I&ap?d; 1Q5)!=vN?Os!j"OQMJ#V[[]@љǪ?6CY\i+Ijjq΂OHqԨFR{ń?]YXk[7b$^^rKbޟ3~c#3B8$xE+Wz£3$]SU2 TR~}(_V팿pƲ&3Ҡ%{ӝ{a$9p,[\xcbY/z!HC`mELI0G&c܇ZӶJ{e`mX(o)nGEdv=ZSMov}pH70>^쓳8nj=qz:e%'QT#4{@ hB8C_{ P:`/0eO |K :^yјS'xw"b-Ly $otwoXL z*'㥾ѫAB-Ĕ"t^n6mYV_Ύ? |> stream xZKW*aybd[JrhVwZm*?>@rI;3=_]gEWlٯYxV4#EVnErRپM\|b<6>}Ûo)<)[;=X$>]L'Ӿ:Y ftќhVRQMn-i;3,{y&$ ~Pހ; _yRln yq UL$qB%_aیadIQxM2qS?-ChٴV)e} HDH֨;ϐ!!!1Y-όwH~g9'xR>9iл=z K^g^5 r 5&mDz ;r8&;E_𓁔9QU]vi{Yt"؊@?orO-5){ji\0w0~00ڀ^s؊.R Rwo @6kgq?C 1^}T|z8UY̪0<#LxP7Y?@Axo'PǝƲ'< ص&T}.Ʋɥ T%JK%>cZA%T`Qs} t3_,rJ'8S.ӘP ͵Nfsky x(­7<1ubw&. 徾((S_߁E<^B~ksMfP썜p.%ҬGE< 2 1S #jNw}a&u8v8}OWqrn+=ec KYSlff[>S9SrBg G3R^ =,llϭwݽԨP(@U_!bEth񞰐 @& F7sM߆cP!sSb YKߒ>Gdƹ6MEa< ɤg 3TMp_.s5ScX*`!:}@.Slڻz*{jEM|O}(RHNޘԎȶ@b*,xSs:Zx#/YR:Fm\`YT@س9ᙞ2°z e HٺkbeVӥb,y[z̳IJil)m1YKao(j"&:zHA$difVº|fݝiksj%pmqϿ> stream xZKW蔒0"oUR9$\=p(ΈeIjg'nHH?[CF?nxnRn8n}|mhJLjiCrb<~wOCD#ڦs1Tmd\#$`w$3h*ÿ?g|3 p7$M}jN!oJE]ghm=ƶy:KI*̅:t[)I2@] $MyX<S=vQ}'iUP\_*㩪K&?F5pEADp *]9wQv_H̴9X]{8Y],C1ƿ?Ż];[ sܳ}‚bFeTjX6J5Q fCYR3+^lR-bE]\k"o!R\όdo;Be_|@^nj"hcLx i{kBqah mJ7,͡]a3F9@R]ok}Úċ)@ z>SDfM>918.Ii58enoFL-m:y &]ciS4֞ . 1x#3r[}|rWB^NWm@@u瑜nhcTzxEc;&&y{J3!_gds?XiJ6i9XG("'0A_sFCLW \,k7*:1kk>E"8.7RsQk(@6pvl>諉lDT$ ;\bq"Ҏz&dWϰ;W)/K{ r³Ѳ>D #"Ub7^zu(R7hgicݷeo>DBurn%)1jcTXXy @I=eI g#EI :):)SkYL(˜ZKPysFbDwGD"1KcDžY^2?ꩴcP ̪oc5,w26mVV9o Lf2O,=c9%vk΍?{b|/cF-"lX2|)G$/Pɒ}쓦ke1U~^vGjb#.ZmjBwlJYu?}⤴jp5q M #.N7\Akyr-Ȁ0~$tK$n%jcjb|/-fv.zB}@ S~X'i'>u1Z\1F;OA="9h2%1mPUfYq1C YG#Ne%}N-1gu[h9E$2PB5Nc.`+;Mw/־ݣ؀ҢP餑[)¥7Oj}6e&4ֵh',OY>f]FƸ9"!! ]SֳfL[7xAQBu`SQBLz=gS!Hz>Dz|;3M}%]XT?$ D q싮c#2X||2>:qm+GӃږ A&G'->dHh } k/'{p ﯘʼ*ХLg>P& {{8>`QG~ -zG:{7JQHD@]^S6.s3s_'8-CjbFL?Uw:?ۅU38vy޾1W+4 3P@S#{O6{e*R*fU*HApBAO"_\8igx~S܃e6seg1}b0SaD{9S#~"Fy [i [In8S҆+6gGFә#DإgVW&p?*D]Fb2)wLj1!_@sϢKaR,ڳc]vKOSv 7Ne.h"q`YQ,vYptFA/j* ']. ЁKBX~·qcd[-9U~{+ldQZl\c8?l7 endstream endobj 2951 0 obj <> stream xڽZ[۶~%&@O2'mO>y%HD"򥿾X"ePR:i'w|{,""/Y?<-^ ")izSVHxZ\/za!RlgY=G< eWB=~og+{"rl?BN$U,Ezǟv]q+xu5t%6M] #Z5VmteώQD+*S~6]0[U*=/$z 3`MaxtAiO:C6ޞtx"P@δoVI>V$pyT":ֽF(d0aNY Bns:+bX5ѧMIuiX?షݙCۇZ ˭Ce&B,Ү,[$m)SSN +4{w2l`EHmdq<ܡZXD@ Fߕ#ih* 񪬭IT"m5e اg?tٯЈ֮ׄǹ5t\u?ļ=t@`/ёbꁚPiiݛh_%#ϵ3xxϋ#9yX?%zU!M+YȢk~chmMeb&^\t1'[ 2(A*wتyL;buSdz{vA5O;T|~j[kkڶih S8qG|M c^5Ks@6g4BwG% a<Ϻx]b2]J5lcpq(͌{$;36G%V>=իQS^ 25>hyl>LЈrvO%|DV 89I r& LϥÀ2ɕd:UV*dR0:[r(RG>ɶfA0H!kEgq(ԺNFY|Pu51%-J~OMmcAkNu2*ZlRbS0UYwrLKyke!8վlKP d"D\1شVOk6֝FGE5Dl5KdrjжbIà:TūÙj,|Hն'2gf~N`Awi82AjX@M].ZYҟmEwa琇_]H{5Rβ%!lv|䮤Nƿ>};eQy S3CYյr=KYmvK_I]dRL3r!-i (p}ao^}`@s΄oX8RGʢr;Cn,uf#G}WW6wi|Qx ;lz:8$xl ѭV;$F%^xdsZZjS1dѮAa\ιɸ+r4|?6 OF.Fcv۾`}o DN =%/2R޾IĤу( cNHg| Ìͣl3}t>`ڭܡOmYeYMytߢbQ=~u䞣 &] ̧Z,oS1* eG` nB;WKLcفtSw: .UÃJ`w#<cb'qs4u T}K_XUC5dݥ=Tju'l8iMmp`? ]^v =ii3^)aC^lBH-b&RғP \/zI5-Oԯʯ5q9Q/^Rο{ [rtc\mjI]@x6Q\4Րۆr |=T:irKǔ۟|]>fMO1\69?\#(ؼ:x_=-6 endstream endobj 2954 0 obj <> stream xY[o6~_#R$E؇-PIw&VcӎJr:Y9ȒCg҇ig.99΍3eFg d.ogٌ&$Or:]Ϩє\nWw׏Ů"N4b|sΣ[|ȣ/zpSAd"gy:kS%U1ωܬjӄR|bB)˺ DT5Ū7úի/HY;r00Vp5^^\!7#gӇGn r9(%\cMUzѶY[G￟;C//9wvy3X6-D#vC:+n@  Ċ!U5k PI&ƹY9x!(&!@D0sڰOh=Fq};IE0GmPUzˢ_@1'~cW=dw]xVY$?;TXTM u l~f"H.ujtMOH€XXOr7%$hw4N; !"TF: 7Փ#|&G' a(;FNK3"I2 OKܢ܀;oo!nt n߆pJNSr"J$I}V-yQišK"R !H34~#mXc7!JB5  T :t|%N]E=@Ru`{V]Q*18|bB*?Aʼ2Lmy4qdX ʲXwe8$ _]EpJ-n! :dLlI.ݭm݅# B̫[bmVfȧt>} n p^iZB0!aH|gi3Q Ȕ`#A9dC tX)V!43E#"|(W'}Z)@FM k@cb󂡑-UANSAr%* z&#eoT5rYTk{Mv:#PnU08bgkJ)rh4!&|kI͠vÐcZκ=lNUOp\JadRF8NAlx_"d"PVPն%V1"dp" P\$13`;0`A攰 k rI X;HAȒ(YCRlc$+|ȟ-QH֐ksѭ;)4[}Q{{d m@\L5g endstream endobj 2957 0 obj <> stream xYے۸}W2aoΓI9<ɋ 1H-IxF@lR) > ~^bKWa{J+R,?d"Y'5f'IvK?uCb[EHwXQu:v-hR䬐*V%+:V)3RoާsAӔB~Ǻk7uq&řXL D0G=Dt(21_Gni!7 ڣ>cOEF1^@^Dwvm:M,%O3h$LVa~ o // hp֑QՒ,4Om`ޚ`JLFi h,2LwTfMTmZ}+ՀJFwMO8эvN5D PXǺjOm= xϺ[gN|1.Sm@jC_fBmH2֩tsrzךt(fBfLq" P~d΅ fɜc #JMB/eTN}] ҃=QKo~p@hPg[wփ!ՉGnGO7@Fw^] 6AU%K&y^D2@pȭ?V!R ȿM sgs;Ty 8 Y%e(yR57W-NBGuYS1̀1(--.N)1hT2p* AԌOi%Y9&Aw 9Θ0Ȓep_D2'Ƹ˦)`̊LD2&pjFP)uVEB%Ep\'3A}x3VP SBcENe,|L'`D,U sa*do-^@-=P EuCSF4XDV؏ĎqCh rvTq ?7p&Pj;z5F8tnOÅ ..D(I4{| R 4A~Ѯ۷59:wf *晲]3t^)N͖o@lfU5&T|Rclv;zS)_ml%s.1/Ӆ$E0w!o;淝[,ε \9a,\.`ZP/)P#>B y$>$F`DCgg3 ~2T)d3>!Cy$Cd`5UTL P>;o5Mhs){9^V/75W\hΕ5R2!I!_U<%;X  t4-k}`/a NKt~NDg@_|RΣHꈀ#i!Px8AEp6Wpi3ɞ^߯D|~LP&|FXHm` *&ʼ ih3SiR+dz0T)ݞ!buiGWG7#F$W|kvÝ&X%)+35C;νvBf,kJ -ma +EZ: 2wt VN?|s09g/Tx ~/ $VßKv"P GNNe\h#eMSHy?Tnzp?W"tf0C|sҊ$ =hCMxM`ВlDb$f/'  endstream endobj 2960 0 obj <> stream xڭYI8ϯQՈ\ 2H&s`rY-$%N9 AYzǷ|oJ\ڴWW+)Rru[b%uZbuwvS5ܭ։2Ƙ8U-Mi8nsϕ6te!ֶHצL ihp$9Q6\BH2;G]&u{h&w<ڤЫiMN7S!E'Ӿ&MǡwkU$NJD?Xll-xЩ3M pW7S=1A*D3ƎkH7 2G In]ؿ+JyZ%Jo?XY'Ȟ|qUC(?blZfba01Ryn rgJcmfi^oQMh*a<j:eݶS `#R;% ]z,R8Tq Dyf{F <@3:Ly۷mbpdBHPGduG2)U%*yw&H%-J8Ng󆗙Z@:01?%݄;2UlFd rWɆt'Xiq6|yOMKk9 qC[JO@ O1`CkI٪L=t| :F-+R~gؠT S^Wa$<Us?y|[hX{>{app CPvٱUIkk-Z $)b,Oƒ+AW/ ]HWWU5CѬ}MWqo%eμdp*@IsgmK'Jm>C%/C}GI uꦞ0?(Z3Ϣ ed"k?uM0gj#uq{jxM\]7M3Q0LcDӕ_/[?qWQ5յ@˖ ]^T/s.°Bc4=U dj0܇`Ce̋!8YF9T?kCfz mpb8yb3) NkUap|h`*=շzgne`,@Z6?M)=R)2xu--<3Seiop%+RQظ+E{9lg`\u4!nC8 }R ЀI4VMUVԁ *_!;ԷP : cZ8e-`D[GPҕs}GϐJDh,/rGc%:TTDŽP h0)nҾHO)sǾzv|gá[u? ?uq~_O.2;%G72p2!=e]_ém+~&JQzCT(wyP ~!}i<@ (bCW2ya!2g Oa0邫"hG8ڰ 6M cwLYtW#y QoX ֛q9ϣ+#\ǭ(k 0APEt>) Xl@>O«Oƽc 0<.tp Seoad~4 V VW&57?O3wXbwS4#{ JqP֨tSAmv`a[[/禈Q6@E`+C`S@U^fb)!+Owy )xǧ~ualS#Qpz5ǒEAn&V\n`,mqCuB*OaX75:w=#M,e!%~2S.."WAD Y ltĝڞD}s + [_BӽFd,-t@_:@V8(SɇE^v{|)Ylh f߸7?9uWM^h{U:FН8_Zͨxa/N|@ϴ&ڎػ d |%Cd$ S[Zu?UX1pn|w?[ endstream endobj 2963 0 obj <> stream xڽZY~ϯ`*s8Or8N*pPV9@;X'%Ua0tt}̮ޭ*?ն^zb#E_]W<]q2woY*~JHfr7;;w?Wm] e_Wh^qݨ\á8S}QICT)so.;npx.鍸|kuRgdJ,=Xp?^743A$wP^|V}KEBXM50J qzШr]&IK:4o@^c@AwvE aI]e23퍊iu$,(sLMUeو3 9Rdr$y?}C);O>A4kj FMاUFa!28 r&q'3JϓBq,7e4T "dR$,fCsavesgznT* oxYezcyVWr0ˠKpX'B|eLIa(eG zh.G3FEKyp<-c%Fŋd6Xj> $,|4)XR^KX_r8)]TEXe&3y؄dHg&tyfMoD `B y'-(F2 ΂଑9bzi̟\g4Do֭I͋ICN#DgB4S7W6w﨤!}r$q%4pܖ]M@e)WԳ=ct G{(})[2H@kAc80hؑ%:E>'Ǹ5 {V0d5=-~vME[{& sd1Ϟm429 -> vl϶IYVR}́XJ(08cp7Nǀt|RWs$j<|暲ZyZrl\ 4=dAjn'"_RiVE]4C>, DN0lm6~6.xt) ln(,GܹJاQQ"Fx$DY,v3h=4و]a1Sr(5J!s C "lQl/`y6჈5 ;Mfߵy8dt ƄE15-52w鏘 ش]= }vz @N==BM y1A1`s'm 5z˻i+i|?AmHܩj4kV*Т}ݩ0vnp׺6oʾ ]їwM>U mivp'ҠƒgPЭ/}ѱxREF1xiFy;GPZtb(w(_o~蠁;zZi$'{_\e"m;ƺAg%hm}Ż00N|[Y~AoAC+;u޽5ug3= u\Be?b sĤS`F^s[;, ¹jD7E}ҞHP :*6@x@z}AGݩ0۟*#]mUu'b"<;uLJ) 47BɴR6) )Eed| 6D*yuO9äb,6\8l+9Cme낲)D/[SVa)ٛmAǿΑL!0Y#|BL<c5c?ԠLh1n`9,'OĔ)JLvs=nF&#DJ4 ykxY'&듷廉3yuP6 NoSc(%2 -qiYt v:3LRǖ̺3_:HF0D B2קlk45M2LKsQKB[oL_5B5vo'mķlz]ti Mfh@M8 }Yܵ9 ̲`nlvNE3;`(e*/\Y舉1~,{!7}xQ1ƆxF+v zPm&1]C#a endstream endobj 2966 0 obj <> stream xXK6 W(e"OܞIo䠵Z[r%y3__!Yr(ݙN,S0>LJHI$?ɻ4$LJC~)}-i1R~7{MqWM}%DI*Њ7ՋaK>H\#E}fVYjwww3q fW[TR)Vb3UȴG)5[R59eHp3ƛv5E`mtoD9 [뵱6^ \ [ŔIVPL}PnLLAK/::p9R\NϐrQծ)u7ƭOge[CG;<3F|!b$2$'?aŐ5cԜ*:;xL*PxgTǮ N5EZfTϝ]+҇,cHx9&"(~vb9̥^Dd1o`z?]((JLR}a 00)uXo$@ZXW},\.ˉ"S3~2ݪ^]?۪@Rh.cUvobC]6|kks]"2X7䘒6p`hpD`ҟv9$ 9X6u㪽2> lKy:FS x}sܛ* + h$5 к7٪tZnʪv<]hK-D9{8<$ }%>X>^ 0%g #sw#Q6(g "f۞Sqs3+NWΡ G8/US6SիEy}A,/d.Qנ#R2M9m0tYEP 14bDpP>zά=XOG!l!k04X^ǂyZLMթYxRƞBE'`p~7D9PKD.ŝb7\6?mu-aW/Np!CD _R/-Xԛ!\8s̑jd? 0v_R+&X#66S_Řg3 $/[ #RBmO[[ L`bGBX ܖ#?|OjZX>GD}^.B d!dR05[brйC\ś@"/OKIII'rIj2_'qǺ;|UYu cgߛ/=02HWeUz!pxwq2/;zyƎ1L\~B<| .t{ L|98},f qt:T㊀ S"WatcIO s*cNY+hEc@Xl'/z39tZF)u0pFXDhv|@ k2Sɜ/SA&x@{CZ1^P>/BHuq=ט_, |R$> stream xXKoFWTᾗ9M]( Q{q|MEd2"(R$@6dXAf [ʭ1mpo>dm&g6ҳ_@ǺArS*DXP!~,UsH8Cpc^ǀ2(|eCS@+,o<9L&B &!C&`aQ+pϕb$lߧ,H2_`\M|\'sNpx}D\i?d]0f+jRjjJt|{ wn[ m+̿uKƧ Rv+}7HUvaOu@|=uᇑ8" RIP[6~>7ԂѦ[6قFbȂ Ӄ-3ď{L%. 8)Gp2Jyzڽ)w?;= .*"~Z78~Np`j~֦I+za Ls;g|k ׽u@< ָ}(7:d(_(,_Kg|M|m'/r m{-~D>giAS{N .(Dp:T6Uo!1nhݘoֆC[ Gh.Ma ]H4B9 &6ӫGa?(C01) aLl .9> stream xڭXYoF~ϯc->^H H,ja a2"M>lvWW}UUl~M&a7N؆F$2ohd">vP6L݆Bӹ 'EwCT'p Rg(7cЭ EFR*aߑ ɤAHYf;ld)3[($>OflD Y'S.~ܛC`cSD(ּx%ssq_N(AUgC.ƮM|P"/"{,{u@݄'F0 MIypʁ &#TM^ nc vY++ϼ^3. .7U鱇#DՓKT=pFx 4ޞbIMfej9OaH*!v%`JmnZK+pf@2/2&Tѧ(Oe|l!a1_J32]y8nY T*}@%RzYWJ+ Tj*0} TS[)!Jd:L5Qe!cYUj(Q&Ľl0% |o:͢ROM&M0ܗj3{@JTyJФni)73-" h21:]JGźuq6~Ev#G_)bZ讲Rg AhYk}Y{ޫ͔񏕦-ļyXA[Û)ߟcF> stream xڵVM6W(+?D斶bbbS"ѶKr$rH Pp͛7>g,Dz5}6{}[fC ˶qbζh5+yIinSpzhqiqpk'yΛsoMY(.-0D3zOcOK7\U"s67oU4+XEa<CsG/>p|i'vwrGɈRU|y:m$mז%'E%ޒVhthhmʝ1nq 9sC {UZג\SBYo1P>+wK!R~>wS22nWwG?A} hUp;)}/1+WjL4+ҾC)#r;d3zt4} \%L!L|=9ƍ b0kq(=e8@=zՏ^ίR)tZ~\.͊ه$@bECk?`U§P.Y_+ Wu[+5TmJ&%סXq1豲[<4 u=@wmz8ۨC'?|qE?S6rKM*՝W\|ȋ z0xmxI W+yi>˓ujUBHy^ƾ+[qٔ*d\5eV u:ǁ ϋha ?!bn endstream endobj 2978 0 obj <> stream xVKs4+|dbl j@ \gɨǬI6ş[-9vnԦVVG"G4:xʴ))Y&KV"e 'ys&Vx2Q\*Y;+.љﺝLG;]k`/C12i䜉<\ff\w'3tU㿾*Y NxT,gwWʸ p= @$Cɼ'aEvĵpǾmx!qk;窳cK@D}ْ` l!~qSd\sœP 6]v8AyN)Nlk0ki5S22LW4,Q4:1UI8t2n !`),+5|c1--B) {}7B':Xun.T ~NEϗ.ھ+b5j2M:N)%ԴA]G42X"PX;ܰqΉi;H]a6Ǿ4f2Nj+cAoOAg3!vd,!C{ bSeXmМαbCr W2Us4J) e@N5xev$> }&\q~-$ʪ,ʹwaK!RbeȕAJK8-tաqNawv^hዀ.I = Vg쒯RȜÍ-W͐𤅐 r'"27*8zt\fCJ.Nr_AC{sSPd;Y3RnpL@/Xܓɹd\C`f'ʅo^׽d `;>C=ܟ%,ei /4 +yu^>#L. #ҳMN4ܤ/!0ޠu2b3M?uvx~SBXO;VyW@R]c U O*@S՛D}j2I 6crs,&Bȴf~h80du9G<[cLUK?1C46:zcfdyŋڶyr~_T/ endstream endobj 2981 0 obj <> stream xYK60$#F|J9Mҙ< ssPt[-yA#Tݴ{s ,J$Ū>VWW|?JOVab'9_nW<[qrn7,[~JHTl__Rʨ7_us845U;כf,*"z'5B3`QN[[Ck/S&͸(qm\]_ԥ]5mwUo8X>NaC\s'b*ḷ&E_5uܯA'>Ln -w/$fۣOWPy*4ܴIgϗ}7?b(gB2ިmm S"spC>Tʷީ.᪶6﨧{Y@o}ChϏUn:DT}Zg"bN/?pDaDL\1P LcmDt[a 3t3ܨXU&G@wvԹmZ )m;B D5GLxUKD><*zG2vg&ބIz,X%meCk=Ɇ(lԛaXǝ\եAl4r`M*\N4tVOԁx1L4KLvb+֛=ƓľYJ+c'๬:Ըӌ_|Y;hl 'k?{61̫.` i5Zaɗ, "?`gd̎6[|lTN?׺8_`i"[G!4*?j2uieS?29nݶ-1&Y#NO3/PR+9@%hCf2Jt@ "N| ;y_B[Հ>YRґ`w+_f˖לbtG,5q:=294CM([`N`cnf0s>+HȨ9,-v>чdvw=g6hJe]p6U N9=-~5>ߑyP'l\U|L/ľ>F/3TԇI g7@xC_ET] aZб#ntoMO'- Gww=z'~7\Gby G~ۻ8¥JsAE W> stream xڽXKWHU`H_+>$O8F2 *$SFK͌]N-I<_wOl?9/ˍ6nb7ytvdnZg4Ǻ|9+T:poi0SewdV09v 3¢/s+dƹk?-,?-|a2LnZނtxi GRT\L~jlp}:b}}{e?aBQ2fy:/O[i?6L*s C]ÖA8 .G wfT\Gka8/Jcr1z2_(֭:T&1|C X8yj:N)+wk·kͰ"=WƸIZ}FŽT0da!_jH~ˈ',!gw g$Sxyw} <`5 gfJ;$;'~64Ll^ {$hx[}(]p;f*Pϸc L?'I@xO\k0L:mZaga}Cn- ^)&KWD 8Ar`χRg8QFVj#-{1qX9ZVH1>zG9yveWCu,!yhgJg[ܚ13g 0Ǯw0kqƌISM6˫1keـ\ϛ HHdRId;YnMh  SSH*UTOY3F02{qځ셃>)x-#:Tpǹ'qp@lC_2SJZLib!u~b2y:WXb?a.}}=m "_JॎcKgNi5JA? JEPU ^O^ݞ:?VcP3vCkw&b1,Є"4/o)TIZN9نW[=lW]OP<%?xɰ8ZcD,eXhVjw…]kiΔN]~kf!W[w__A endstream endobj 2987 0 obj <> stream xڭXKs6WԡfBGrJN'n/IEl$RÎD6{D~?PcOmU'GKV I\-ߥŇ.81F8E&Hj?5 ۺ±L*]}Y/2n~[T nK8WD%iE.+ÒMӕbiR|g8UٵEu Jxd` S ZTܯ(}Sչ2ش,*j\n=EVnwIp2@[)B##ވYMEv7pL4 ey!:>'8Mn ZmТԙF>fvX49f&ÛLJ H H"<xfCf+Q!J#ڶXnGc *]5OkQ9G`qb uB`^!+3$Bj>=dymIpO'#ӗeUU顐p‚%h8-A.~wLJ(_8(3cw i3z7r=ɊfN!a=ГRp _̪+.^a \ٮL-+Mo꾉egaI]u7qz2 727vȂi0h 4{ 8b#cfTz3El6 OW46`|39].LxwȜD0AªffyjFOA'aL[NϰeP('9#덉 f<&g9:[] j-'϶ #cVe\@5'qB+ D!1O𒛳e#4Vv/GDğp|8$~5f^uSL}6V~)X7ofƣ[4T[7d5E{P9Pp?7VB_2 1\N|J'W顅 z. ~۔ҟoqzY~վc6};Zkic|{T.wkAi/Zp8As,h9(IG4#mٿ5Eګx {_0z#AnX> stream xY[o6~߯ +v-aPKbb 6CoIt$i<:7~|L1I?8~dO^goHsreSXmyt()Wc,}ݬLmڎՇ  *fR>{C/h!P2A̮}bq͈s?Rɰ-0χzGA,hܗWͮkͨ'9^(sMwnڦfҵնEx/Vj$rEwAt;"maf?enٮJY7m(~r?u1aH&&A'H2og%w.V VbVuzaw3WolknR0Mչo.pƹ63y%#R@✡Q0C!)f&WAQ` %V ,fr7s"A XG$R$dꤤd8;bx4S DDN*"XnI!/_r43Dl.H.8f [2'NjS4,}y,CT2P ÊT7LK̥9L'ƼnTL(61ZCR.}݌ѐ)4Um lӲ Y <ȷ 5Ўų;"B SӑbYy2!.7ePÞyeFCL(z6mSV J t>c푯#.z&8J;<7yCP#T8L&)#?ZMX(${Z1ePG:DR*(}:ǩH@a˕@N( `Pv.`MѴ qPW(PAR_v&C/BA]gk4T@ZtU>M+\u]t.z Tl4DpOUv^NWO-2߀6HnuVqmmz}aVmk!D!Lg4-JB%&$JH9;(~Kt_~'cWӍg@Mnl @nwލ^iB(O!jk_}I bѴ{a/aW7MMc{%,M,YxI&/9,ӝ#p^8_K>޽P$8XB;Vq e(;{ewr] G yQG&Beg.(OߘAewoGC!:Y Y }JX4!O LB .C wJ=`qdPOKv6'gxْGUy3w?2}4 endstream endobj 2993 0 obj <> stream xYݓ۶_J#B|#yvL3_O$)R!8.HtV:N2@\~x?e'j}}VDH//Fӹ.#5z тxKu:#IBGLHM- *q[rG%oq7$䆩O-ٌL{k\9 3%X&i%Aś_5m}7^P6˪+ ~6-H' U\xLO4RC {./M5F[yXW,6qHBWnn䎹b:*,lMl' ' ug 1Ҭ(4q"YBP:vC 8J9dKF }ZT  r(^Lns?AxU;t,~kOLOU] Kzܶ sa<"0WLzlzC/Nc0.{&miz$VM5Tv3 U ępae,ΰ}Wñĉe;S'qЁn=`R$>eXL Ȇ[>1{(/c'j QVjsKwKeӴnvBRALlj:1oGŦ(JPjm 4*o>L@ÑG~JCLmM0ʂGUb|Z:6s8= %e} षI^b$&ʅ1 0g,ϼ=?<8D殩 p"Nu^`ߵ5x.2<&W "{!xLbv  X 'Sa7`KP @@Wӱl',+1 )}'4hv3Η8y뢫Qڕ7"kU UeyJ8G|\oTt! w/*gB;t̟5"nHzQ!i-4j\9M=Smٕĸ產=›!v36`j_(W3P+ZE!sDNJOcǷ:SWv/0xjnSgtrJbʽD[L3b]lQ|PsKthHx>PJ|FAJMe90bEv#+Ur8y ]٠^yشnE y{>5-:&vGۜeZhBM>8ƧH~·=)4k^eO0YWAEYהO> stream xY[ۺ~S!xĤ=@nE,r0c]awzUl#9)) /92秄r]T*T tlQRdg-—81JN!95-h[BL6g%Y)GCߡR cH4Z+]P.\xj{S cmƭށ:,Ty{k3B䳋刧9aLF$$bʀ+a&WCqSVhjKobF٦BV nXιw1{B^$Σ1!$8Lg! xXU80B.]bKhfChO~g?;1/WH͘!}|x6 A2&]M݄3 q, BOl$ocXN!wڊ%kW(Wڰhz^U kd1Wpt䟷9N (By\F @sr8iO-T7(kȇl/VF:G7N#x80bLI_| ^9 (6)h$ 0ՙ= z*5~z G~ð-"* ݽhE !I<ػ| BT66P<7FѺwV>u0uM[:|48x^ 6sW3l~AGĺ\]TARoK/mPg8r;`JcX1']u5|/ȕvuQٕ]Zm*m%Dxb@*VoThㄒW'^Sjb}!UQ`X10"V_n7Yv2p P*.fJI%SX:@@~ظ*gxp+rSy}DyfGS•TB X/&fF~YpHn]r99ʗ.X#ILS`PIdJY(`tChQMyZpJbvvs[̔>~D` .>u[v v݈’/Ց@ _!ga> stream xY[~SCIEE›W2HCm?Mv-z֐9|p[QV9?W]^+FIIK]b)eee)ZqI x~7" ~W7seo5ϳJp,Ifo^~txd(yw[fcδcϛ|ZMOYAWRfWo]MݼLvZꂱ(Q<Z%EETa.|Mj ڀpv 6u2H`LjI,龝z0t6V,5a{)m76zuh%MpRPlX5(<;wӷ7TԮ`XaVR^.?~45lfzEA {ڌaPox8_7rN{qgAID7JnvhASxUٱb|RŲ_zMx2ͺvLFPW}ի݂\iW{?]+TPԙ$Jj0ɥIsrVyPŹ7`?-L=6%*(byZPA_'aš+a;O,mj?3/qA)ɩ V^SE!ZiBOE cۘdfV!& <*Jֿاcs9ʱX8%<w;|O: , }khCc$p||tp(yD)`F^#^iaGMWíd<,?sn 7'<[Hk>{(9 Zkú6&Yu6K20e"m vcǀFIb5ኀ2\OQn-.&2Cѹ4c#~"b+Z˱5^_c ˡBP`,#/m |Ck}#at:(̬OlͷCf, sXȟk%UńQ%e0^~F-j; p1`ք7\.ϸ.blk b0bJ >`a3G+OˆGWC>cfl7@a{ ݱ7(B^zI:m=}Z(_ ,jPkAUbH)sb)r:Awx lm,UD(C獴eEw~<#6xEy9> H]w# N#/MLe@D\õ#{^T|:P@)1c%bIJTBL,o-Gg.i2iPsxA$\9,E}$pBzIH5 =kB-qyײDP,l3{᜛OJcKiN y).w%DI56#hUY>$B \3k8ý-|! Ry%vWn t),@LO/};'y(Yώ3&mvqrTAÕKL SaWRX}xINI)畜 +Kb U$[Ǧk c1lKo/!| S&K8J1~DkzEM<1z A endstream endobj 3002 0 obj <> stream xڥn_!lTSMmvכ@f=KZxhYIsHJ#tgULg~`,u<7@ XP xt$ytQ}WBɲPYn|ғ,,wCkDH3BY9I@ #):s²̡z U׺+Tꭏ }xDQZ`;$q[#eKfu^wVgd`ylXk=fcQr:CތZKmFL;%jV2L:Lp#/ƦU+?zIe9a%1JL.|(\+q2P7zk-yOL FV!O#\Zϡ)PVwQZ7+w@7h_e<쁉jB]<朤/<P Zݚ<,r- 7v+&4f"i;QCf~(I3: q kbݍ%tUW9FBTW v!];n|^0%.؈{t*/cT@QFG76#a)p˘f칐cj\Sֺ.mC(B,͠rP {ނ<QqOoL^Mf$*iT\ZVL Ԓy:~Q˜jL@s/ i՛=ozQO3184zteb}s,OcKٽZeؠ`npM:L̦f^oA{6l,=.L@o1\̘n94w\؆paV:5`dbV#%08[ޜR\@"Y)7v$TW_%|\ٴA8byx?(pCjٽ-؟-DQАh =T5ݕ<r?:@R̠"fX82f[ݪ'{ PdVҫߍ.ug= 'VoTc2+'`mvDjVi޿K=-moau;#=Q&tG< vjpf7TWw]eh{W,|{mWw AF$xDw(\{GbD.IN4֏+i2cdfXs~Q=AA1lh"|Y[^uW x:p 741SHqu>WTØ/>}<~}?e%0Ds 0Zᭇ[Nr L[EhZ7ӟAƲC endstream endobj 3005 0 obj <> stream xڵX[~D{_@7  sZ"?3{Hyu.AcKqwvvofvۊ +_ެ{V eQ튚fu}Zi8#ZsX>u9Ϫv{O?;"{3?v뜙>lf:^Rܬq<*^Z "Ȟ:5WXTŹ[ S ?[)h6%M(R(6)a] ovOgΦdkE4aWt.ۤũ)0Ls0]7=t6T72Ys8sjlm?淓qW~UAo>kʂhù}w)zL)()e%% Zxﮮ"q3r.K٦ j@1.ۮCiϔ0sW)0:("uvU!Ұ Kh`\cBr"972t<ڤx PTOEEy n.ɓȩ|\>I yF ݆]] PqHȇM\̲ٓIa&$+UifH[cKdSFWі4(@?#nF)p+\oO7@<.A-g' Ӥ) jw5y$Źu&w{TWb\3, =d,C]K~_kMcp^c-vq2!r k6* l!dY0ɳC' z*e"Rq8{]6&T9\) ),BQ;SP8r^n6J[g )Jlk? 1i \ z>OsSvT`I6揰ŊYr%DJ&p;_ $HgR@c B,cP KxyόY)Ģ{)"V(*׳"'q)‡]5 .*y~F Z9aÒ4tfFx$C3GO̙,?4i\D7@* .=L=]C0wejcqޑSvhv*! &ɱ6?_V>)pZJ&ŧ s?Hul GLGv6k{ LiM7YǿeGrhJJ0w|M`YMYMk<{>LFf=Yw~>|q |]$7Fu/> stream xڭY[oܺ~Gmeě.)P 4R(bIttIl ?Rc(zbw<~ݽ~/vPpGsREŰհ`k TA(KdXOs In*W%<*Z;GT♡7+.Rt}m7Ѥ!G@:[ڛ>qUsv4|77lC{hr^HyAH-=>o[,[Jy機WAY P’c)L(6?h w{ ?,K38i_MҦ'_!A(!W{7%C{):wm"%b0UHc&HO,^}.2mp! ;w!AEܻQ}{B8TkP};xJ{㼤}4R|*d0q:,h27cPĒH%<䎃H˄皥dY%Ö42V#v  )+6 $A+Tʣ9[m3 ve.Vg$k}SA(k0Z!} @XܻOS1=#]kjJPEcO)k CVEwj;GBџ+Nku;ĠO-)r㰛_BAz %kE˫:_y'|~ lP0N>iwT>73 0`hKG*Îw3ܓ%*5XېK\0{vs]:% ʢ6o--l@p@P8 XIeB$]Kr7ZFZ!78dVV3=a.uK \ 8>w,2"Lqǚ[IO'zFPYow1VmX,> stream xYKW9QM6_Cͮ/cOr|P=Rm`|M*K ُzuWU=7r?cm7o㍌DrsF&T~1(bM"8ox $ vσܝN]cgۆqI8z*E!;8;<пTs7oy!$݈(tz4z؆i`ۺ#JW 3F;q8- NVB 1>7p"%}~CBŠԂv: iKHȅ4qFOՌ| lZ3> zdz `}Bv L</K׼vq5}}`0 z@X @pTUtO)C{许m0Lm؁QC՚y^W[*oLǃ!(="-nq5k?^-"VD1,TByt dJ.{(v;7VrVB՘:t1n<f䩲wJPXٵ0iQLAEA-ՑX h]]fv[$TRcEe_\ \0?O4! _vd>G&/ ;Bh+1g^>G%=-)fZN+EuV[VNe,7~w endstream endobj 3014 0 obj <> stream xXK6W(çiQ I=iكVBm#rHPnQ$=)Ù8OF,Ǣ?S|=y#FIA mo#GLBvw8AwDstH)͆gkas1LTEagbfK įJdAr&Z'mn6Ơ)Pt26'g0ƺKz]2_h~(QLM!ⲫ˛&( I-%~ԙY63DyP3h' ʹnQ,-kT14Nw52~+`>dr&鳱F7; ĸ$)˜4 A[|iVؕQr [淚Xo\ 8ItP4f6rB6乘ƙv9ʻyIώ};9;}$ >F87FBɔДyCe$NjLŴƦֵ 5^rCz}YofO.SzL 5 2(p0Ŭ.) wNS;4>{=tvxvE1M0Sޙ:}@,KWpl2tWLOl~6 k eED+Pb*~4eiMBAP2"\(&TQ2-lfC;<[@V#pSS_H"Rg:FˇZp>[J v' P`H\k ΌƥewkEՅ^$KZLEؿ$XjI-|SuP%tT?mbj0ZmyN~dQP"d(CKY tS]ᴷ:5uG "wv5TSJK`XzdF) lŲ2`7E<{A+P;[W[pq7\yyjGGmM9zK"-&e&*r&#"|*4VcYh5ƾ_Ϭ,A7l3UjYpyU(T}ٕƼ;|) m?}oھ=Y~Im}o&Lݱ;_{o o<}fX|f>q3}Y לQLj><ƫăDzu #kqoGx%lD)d{Fk}=F&߸؄Q[0LOEƼ,,&,F=tܽ4hi|I;CdKI`Ά/cL`21Y\+ohNG "efϥ׿\uWueft|}k7M"=0psƬ\á-_43ȑi,4MRj]0g ҴO-?i(<9!.avTm,pWRŊ-lL1^tUe^xծ?j*C{vߕ'Y/_ endstream endobj 2418 0 obj <> stream x\=7 +NE" 3tA 0R%yOkxsP{N=o(Q#TDC $ Krmr E;jŹf8[2)Xťbzr) VJBj1HU"ZւDD P(ů҈ഒOMDt\\6|4P (/)v~cP5TC (s"!sj lӉF"R G"0lqL#B#P@`Y0.RhZ$^D`J"袅荈CTQ\G0 "p j%z&'BKڈVN3q[94ZD7R v"8mlm0D01$ hI *&9hG4,Z@}t"ʡ ՠ*D#Kr =V"#NlDzDx.VSZ4zoDu"FD+R$)}e~4cVڂ1+8cPGÅ BvC4 .$ү "Hb&cI("L" QDTaFIXˈQ?a"D!/ҸEx qGӶ1WIh]eDLPF?"0pΤX0@RJ ȑޢaLw@m`əAKkcD0-۰$` f`0$< bf+2;F 4g45b/ap)a$I-' +`'° Jcz! &*id:,mqG 04p"cm0 L$6K@tP4`oP4'h3z 3EhKVЦ;BфUEXDK5SzDA60cHϤJQgO>/~{~nKuȫ/:4Ѳ[;wJíٿZֲ&~u=c<@W566~ v[t [Y)O[i4!FӍ?K.]V80iN$aUn&-Xfs W^>lCdlV6Zvs>HQE^7Z6ykq=ypMy,nlZz\v0V#2oh~jk?WU?V稳M9{tSٶlڬϾ}7ժ:y&5+]Y|B<{~s5O*!=8`9<-Ct:07j|<Eɤv 7*M6w9+49v}q𺶏9:>sݘaZ}pVw^ [GƾbCdUz^w2(q3{›Ԗklp&|q]J Z)6|/yx.*ػmi=¾V/W.:ֺ{]fr*f/jH endstream endobj 3017 0 obj <> stream xڵX[۸~[Wofb8}ɃlѶMwCɒC$-0Cr.m~M&?ϛ6߿")KV|Tx$O)XI8˯>QV4?h|Z^huEdzi"wo8JK@8ʎ')*XzN4LE?~xxyR)ݩrL 孨ϗƀ>C9ԠqLo~ ;ُ[h'9 3ƚ5K#RZ[ I$ɤ]ʋpK!_jl7{3 yS1Wsl+Zxm*eI'fyV j۲Ѹxlƀ%FwmpA3YLk^2ayCޅb\[c_F4kgi=nc 0ڋ*(SQr B)C__cN]P)YVLn`'ZWpdL8\ bT`C e}++P_ˁy\dKbh:rArC}V}Lϒ+ XrZ(.!-]9Ս0V}vn3~3 dtè$B}Nsorr"3\ IR | ]IP# L\@)ÿRV̤3jiDdJVxaEb)ÏMZyv"}z@)!ȁ/ o\vѮ_Q${ƷBjC 8f̸c,aVK9|)_c^_X"i^+Ny gpBEѰV,?, l !y-o*F,ׯÙn/sd~'}uM|=T/D/,E/{Y}{4 MwmE={v(LDe w>eW1 &_^[Wc+=H-|y> stream xYMs:+ÞW0t xCv%qy߿+.v@:v:j*{ιG| H I; "x9  "#`6SG1c,$9220nDgoq@QaB)ؘ ~Z5Qe l''"61H2fϫ 37YnN u8#z!qM$0U$ 4ݲtLQY 4MH#1PM8PD hk\Hm ^/-LT;ф&OOq+K$ԭxQ_ZNO]mr37enaKSM}SsHFep/&BKe7:l\oSAN[T!n-2kj( f*OZN#«2]?kxu"¬\X/e[[GtC7ۍ -C*uA> stream xYMoFWV 07Ҥ)Rڸ4=f!I Y"%Fh%3o̼VVdY) x)Vߟ+/WDC`L">~ͫuKr?/WEQn͓ZT'}a5UI%qa8ܝ Mxw'9W%绬iwXiֿ} Mī($N:ȶͽ,y~:!\&0b W4-Xt̎1"?{PK[g^l}o۷k4nn>`ަ 1zqD9; g@2$@GАܔ?4|-q>WBU[VR?HIA|30cE<JaŜd1$L#Oe÷g8_ 7{ſxF" M)E&H bu]3Z(IGR} jճ &q35?ڞsMi)>ܒ_YۅJePu] lnT!i6K9GvL[@3Q;(n@$0[`BR5D{yy5"ѽg?UIG%J% X׹K?1MlXm6u~B0~Ξ_ۨ}qܻpeK[@Zr_nFୁ:|Dp5lm.]Fǭ9sļy` yڭ0y{W)@&Bc6^4Zܫ*@)<4 Mx TIdU！XX3z#Q"J"=b> 9IyPac#; !ƣaj0Цzl!?gdrJ`8qJGc'$5d 7iFؽ$DB!Ѐx2SXކ-˛hb&DO+}O¥޾ .'UH!nqYET($CC שYE8@lI8F<HQm3>IwyIlـ!~mL&EVʕ5)'@+G}} #=yU:`M8ܸY;e #' G{,v9>k+om\||vSIQ TU-é_ 8h瀨bj U[) aR ^#p`#XnZ&7 Pp o&s΅QF~7͖q`g6 ri^첀M4#oB=EW$\mlz R-mNG>sAf\u:ƂtkB+;)=&)5U"pNO:PْR'DW)}CDhY3"-c2u4;dM%vem4RFG҃0_7Uql٦% {&C狀 wd'. G1P Ctswɟ;)Ƈ8SN:2+>/;8uc@PQ5i <1f#z'sֆŒ~7dÀrON>SfJ1SÖ;h !D,!@Jp~:53,'0$lJX+&O< 9 v嘉 :z0A &ĕYb8@2V3,O.<ܟ wsH[0M,w0{+}2 5RDL SaA7E^fKjLpͩyO=V3ugQL္:brL%X8 GA>zǾd]KC4]  ?~ڷ endstream endobj 3027 0 obj <> stream xYKW7m`F.;{Pne-ѣg*%)!݀%bW_;v?v>$9=<1Ariw).C2!ĞLJ9pKw=~~N:r2J΄Dx&sbtO|r>|R+锨\zV*Dv͓r_DW̉b]/A 7ǃ~b&*OBw*Ʈ ‡2&^sB>` tZCW51JXH/=d`cU %n[5CFۃWJY j%؊)DS&]l$(RbRfBW(cZ!kLk{2ֆݖQ4'H,%hKGeȌ؊.6RmیĨY/#Z=C dDpbÍ|,C7N!}li̤5ԣҝk2I -#LMɚU j;.8I (ҖfD zqv+pW4M΂g` 5݆pEt=q#h֍۟sVC_H(1h ;O+-/k!r.C}>>/7$\QqFBil"rByATkbIǀv343b|=6 Ȣ{ˠ'j ⚯)D 2 YgWQ^ ~Hp0^8bJcaق<5~72w2gz>QMoZ_\>d6@C*SE҆FJ?% "co; !#7'b>9d _P[՗N FJ0)ޒ@s+VL hXFJ\Φ+} "o/lN4Vgng$6'j(Je7ėq%!ي%=]Y>8W&"Ҩt8`0sjJb@`.t<+k ыRk@J)|.tA`lr E) 6WtH5x<;#|#\c/ZLܴ(@|{ )nHoX  %XDe k}?83kC=]ޅbR5z\H-%31r%6]:.J4G@]8Cٜ#PlE8_prh۩ㅎ9=a$9Ui,Ӑ74M}'ju܅dA(֜ʧd1c#f8F[O9WuFP|uZ:kЭIJ?p*gp~L P~4/vҰsW>>X[ J(5&ZO*-\!Mܜ`}G,'J ټr+OD#)/P\ؤhPK @7mڐqHtXZ,Z"$Cv9r4~ 9u3(Lj;n)G7oe)PA["@oxc:>6ROHxޏxԤ5Dݎ^ Vev_cc_d ĩ|JwRu]m})Nq cj|c 80r*Kz^ӃBM╳$~Fd̈́k!}pt)ܷw.|kA9| r[t$ڿI"p ]M"ŃƸZ7=ޯ{idQ7̜خ:`uG`ˊ "]x:mv!7IV! \]Ƨ6 ?ASܫK յÁI 3(WgZ}X;">[Eh> stream xYKs6Wԡ2&'A4q'6mn/IYl(R%؞ɏAAI$m ">v$CIM:xzIQS\'u6$(r׋1fUn?~7c\[eh.wU- ;#%ѻa\DIBj䦌CD"1 V"|{HY]QW(6(D#V Jo;͈'0$@ 3'@LxDôb-Q:A)F eӈ5]kf~S)+wjF1{b|HC7*J5_zH )hu*(T.gKM$j'JDyusD.MGɹrp9s IDI05"zƹZeqD" {19#h`>'zeS8fҌ#/ ~\_1hY9)qZy {-&mj 0S!5ggvUE2DʫF11Q(109ո%Ĺ˽;q08ը-"Nݲxl)JUQzז-pXFۦAl4#a  Slu7t `bJ:C'PA;gM8Wɜ'i }؟>ID*|@ŀOwZ*gsָW׾DqJė FV¨`=ɴ^Io:wɡ][?ѱ(s1n)=`@acs-ss$Vl>V̴:fw,˙%VWݐ=/JDrGI]"<ޯfX؅Tq{NsQ./b_ug/sBݫjͯhiG&N:qƧqOFO:D` endstream endobj 3033 0 obj <> stream xXKo6W,z(s)C"F/q.I@|gJڗDQÏ3|reVت~f=_1JUlusb d~J~n4:B$<{NuEXm7~\m%+92J3=C-LοaWX͛7+9EW)+H.^5CNa`},DNdy ]Kt㮕lz5//hkhcP$W"shX{^r4`ٸALT6Qw E(˘߭3f ceA SIa\zpz GmxNeE| K1![wlS=[=j0ar.c"7ypI;VON〷ĒsR>V[( n)aʉBN,lh$gDX>Gpo=$u=]&Cl6Jx#zh'XyXh^.!DE65G1cHGHO =|]-oGs ???|:)M4 i=OlW֊7^mZ}2PvG1˂(TfEDwƴLݹ:>l]V-2UV2d5=*0.m óa L,vWۜȒOJOz9enc\S?A"*1Š9]Qc("oXL n/Ж"gϕ8 =B'M"̑$"Cc9 j `g%9xsև +ȼ>\iP +TxII^ #8Z۴j*6|Q٤w6xΨbPYs4ƂHAe'jr+=`dh} <5ybXbAv ٴo΄6h^y^}WO&q!iHoKU4rT%3")ɪGE((_{Wu(d> s0bolHP+xBV;37+N|QO6+h}0nT@o]| ,_CF*p)TQ9lݢ݇jcC)&scKcA-р-,^7CmPoZ|C)gl4piW?hczK$E-|"XGyJ aϥ"_ Œ] H6&|'W> Q^|݀7 ǂiɃZ;{Llx \u˄/ZgΗ.x/KTE$_,7?~mc endstream endobj 3036 0 obj <> stream xX[o6~߯0Hk*Q0 ]!C]%Ƀb3[r%9m}7E2h' "sF"aD9q4_GogS \hv .2&g질2q||~q?zncW5IJe<߮U<קD߆r}woIy$殓Os髦.W`*EoKнyL}jۦ9knC !PEI|"CgncY]<ΐ,Cj6:Ēx1 9Ę<@υ 5wolQXPV9bf]]U" :cJB(}(/&|n}DV /ޏjaus*Yp8 -@ ʹxeU ݈Wo "dCe>6UXd^ Rp^zq,_.۔K@>; sr&$Mٗ2'A51(sMD<#qm];AQ*mo:a'H6LiC,yH2vͫOj5YoK6P0պ$սؘ |)ƽQ]'+;eWn̄ئ>U$;ԻhjBM) +ci(ׅ]ٴպl+aN4|w,v|'t056QCV[=s͒ЪLt\rr+kY:H_صKf$P;0_`J㵱J/}u7KB=,|l)z}Ppl?A &pdz+/;5b?jY)RBI R!|r @gmes7#@U C'CH!ݮAJCF2~]rƞʫR~SW֤7 :^M\>BuO-pl2p? D`hNP n]4!W١ a!)?TJ{[l'r+H%Aylߜܛ=rc{EyO}=izg c d}xtv>Es~>-P9h;V5-9+م!Bhog 8~cęhdwgK(H07@+W~!?OQm]ژl6)lc[X8L$`H~rRVۮvDS'1byq$yh  |'" (TL_V`n(C770 9#ԿPQrd?$8 endstream endobj 3039 0 obj <> stream xY[o~0ЇëHξtfїA_&T5_Ëhʡ,'t%\>.YH x.~].Fk jA\-nן??j9c,2gwK*Ǻmvʎ_EYK0r"NKխz{j$^D1;D,X8]id{\R%`rXi]vαs""cP,mԭ, fm"K rij4*N %d'(T` 4sx0͡Jn,ГDה}P:4Π&8۔]O`İOW %Iu nQ/YΑ58y' @]<d }[=͡sBdAxldrp缐aփH@EH\$ݤORD0y G0s:@JU1: 0D2$ۃ){!@0. \66_W < Lb'~`"ӈ3v#Krǖ;-[W\e75x&q PXv!1hqhUGWǽ'+= 1,V Dsk NH:z3H:1ҩtNH/O=+%t_)x&D&(Q! m,EGϻO'PIi93!"udrPʹuj~ÄU&g?=/R3^q.ㅏg3^R s: s8r~tM!5!ʇB[W7o"&1sdg[G!CļdwYAB˓/EI$Šr($g8ܳgݬ=Pp؃c7-qkzKrQ`[1H aeiNl9|T̸*zoG[o\ ~,U^Mr̩sB&K?(@UH5ٕO8rXj܆Ա)⾺|풑ɀI|C9rtI r0_6άd)%v&p ?OM`Xbh[u7U> 3ω{pDg8ET=&]?J$ CLDG149j(wdwCgό:{P+6qJNLgFt wٓs2ͱ,qz.T)VaӇsMnd V~+m5m÷Q;'A1gPi[]ԹtQBCY{tWۦ5V $)MжekN /1bZd"6t?#, 0ykCaˑŝ(6D 9(Ȝ#߭97bΫ\җhT_O.Yΰ kEp5˼}m[+c)@H:]dحU<%}k*45gK4@c&5ӏI@"اb3dHvfAMTȓ=U)c}2j>}Ta%)>Rz]]xYfgDn 'O"YoZ{c2~i7{UF"W[ﾙ7| jPY[hw掎L;!Bqz-_&7!PHq2w_$vs!ևi1W8?p6ӗQGj.AO^)L$I#9gK; IC3A#K6hW޻ye|uo^v𲵶rs'%ҳԑ`4 &&1^xF}\MQ%a0] T&G^v>(}rfG=.y>.z endstream endobj 3042 0 obj <> stream xYKs6W1!NIL+ZcHBQ @!jӉ'Ap>]ׄ$DQlO[ 6$\'D'!u2_c=<#"||7ci?E\+7fg_t]Ոn߲bP Z2n&*, qDhVMG1"duΛU$yz/v3qXab$@.ȩ|AO tGEI<3h\S@{g$|›fT"[ds{]/f+UeY/|nqc8ަd0x)eIȒr.63@jd^ o7ui*wY@^.TJ#dXiفzvB& +kpH*gSL֑*|,Z (_*Fv$H3 )bUҽ-AD@o(8hGzؔVʚnb9܂ l%’EL#F\f]:b >l CUۼ*򫅍Id ni,&^Ƥ@$v1O'x!md_EZ_n8Spzě'.O|9ixiGv~\T]~#Xŏ!%Z &Iʠphs3)$Ҩ.gy۸e4'?AYT ~qWPI2,\0PKIӱ-$t\32Ǎ{h}I](vaKlAL>ʕsVn8 Aqb0FVE] mƣX4u^*[RkGw.>ukU)oS|rccis&,䏒_8O4a!I:b1 \;NLsE1L ‘C[?mnMq!&o/9%KNbl]zAtfHBQ71H4R]e(P}Q cb1DYÄ_z[ݛSq@8ހ8G1ϙ^) }AQ$iqjz6Nv1F ;Qegی!ϩoN;Dkq&}96|wb8p3X !/6m%[I6*4oK hG[;H[fr 'GF\q0gs-̊@5T?3k)5 [,!=Aت =O?O5O7w.׋) !P[So{kHJVI6}WLۋGTrv2+^|fۿ8Wh endstream endobj 3045 0 obj <> stream xXn6}WCňw)( 4h45A٥v%UҺ5Џ5mj7NS)l45)#I?8~dM~L]K\^'H0E%+l]u4%"c͂fx\|0 {8K3k9lwȼYJT`fW 6,}:q?<ɰDR`L"okV*ǬQ7&P.cJ1wow;U7*!^|68vߗ *u<8NgF@l8?8ò%@y.]JEo56jVz7f:݃@*0use@dᛳL xLM]zL)N",Zx,0C9iE VoF.zwpcr^g Wfٞұf#^ۿgv~Q?6OJOCո]L%LƤ2pf=Qf‚ߨFT[7m]Wcbn8=T}P;#%Rǁ H ,ne35j 0aoa6(ZI&ǐ(]II̵@4v]v FeOz0a^ h-L7IYg*[UT7 =…QmoPfUkONf%99zD&`F T{W_G 0լ@qY5L jEٯ 7rPyۼ먈‡T eH=pU : 6o !dCN>SߐkhjPr(> stream xX[o6~߯$ë(7!Cb$dɓvw(R҉3,+ "}<~x/nS`x{a(7_(HJzyvu}1?-OZRs}li4Z~i=>'v[ yb;[gMo8Tz!(bUUa*,ӵ d4 B$E d2A)Q&co./A(g>Ɗʉ Mp F"t>!IcvDuX7k΂QT_n<|([URP괭l[U|ڤu Yھqk-&Lee aIYaFjk~S/ͫ(Xmm%W9Ɇp*_´V6nt$"lڴ(ҰsSF:Ϊ"mm "4ȅpQD#4:U^3ܡ9oLs8X $c9@`P۸EpOK#֡/q,TӕW$G|Xudv`^+--(cIf xgGn:/.- J2CU#| xyR Pb 7P #&.CJjuwF+@?aDEkWikT [͹e uu(4<.aWW~tTzy\fL32s &(6Tf7Yo<2S{H@x"g{=x6ۑ@<0ͲJXhہ0RŋF |NSLIt=^W0>FD&x f!!L3|@'D ®?kוzva Pd={V4Z?,ݖ [e 9qH3 f`r xig&}ky}ʬkGNXׂq簔.,h,UhֹK#~ˆ Y>*ODC!OscgzKD k߲6ZԩtLwkyi$(ie'H+n )!#1嬠YqOBa«%|'Y*> stream xXKoFW>'wi?mЋ#-ɒ]}P&,uPE\㛙o?I q4_Gfѻ rhvr2>]M$eT$)<>*㻲}r=1⠇( gY .щsB:lKyvźYċQ#Ae2ƬU.˲iċecT .Q̉%!,Jen;:;?MRAESJ𑗒 c"X_> !I>l؊/w9G q Ĕ&L{Ixvp0[jlIYbMFqwi7`˺B!;ڳhL{qn!9|ܦZhpWt@Έ[Id7\B%Tźcdsbl+;RiQʨM6Ãe")97iw.J {919^հSȸh Be-R?b#@M, >m/Q$UN&` WQقoIb55;jO$Y@2,B(-ې}H1n> UH SBLpFL ]<}LTU=^KCe;,KS~ۖ`B7vǼ^77mY{#S Tt-Or J bXv艹m7Upr_Ț@Rȡ8ulMD ]:/|mЯ:;!8C?򾙄<jן>ny[vs?Zar?=i *~Ը{ :) {nC"0% E'_8Yؽؖ@ɞm^mF58h@X|3L,E(eE5a$H baL]|H /E%ELK3N;N7!EAOD7E}fhS^{{\kp'$߆;񃸓˝&Ǧ.(9SS2ueH0Vf.j[XbV`ZJB> stream xڭX[o6~߯@No nü4}Pm&KDͰËd)t+@MܾCee$G2Eg}l=%a:[oz1"lwO_rU0݆kݘfw|sܛvEUn/A]R ^"MS?4fx$nasuG I|Ǫ79U'JC!ʂitJTӲ7Å_]9CD?~6%4 , }HzH`΍ <„5.Jn&7.?C Flݾnk!!k}8unQJ#U ,I!]=Au{{"î;6q 4e'^-^_ @ endstream endobj 3057 0 obj <> stream xڭXY6~_!KE[)<1YL0 ZbȒGw|X[6U$R9`A ,9:},ʸdc xEP+d1K6~HYT V>݊2*"j'w$xly,g+.ZD(*F|TRtNh]-Hћ䠮<8E"r$y.ն&5 i؁~I4iŸG͙X+赌;kt ,6K\4Y% ԈF}ƹl0d)&M0j]wf2,%|P${YM`:x6N]«Tz0Rso~7nVk/%)h?Z-e ER$ak̛pҒ)mW,J< k2p҇6tb @,x; %wDeMnQIm-e*Exmэ?))f&,0Zh͌|W#z\׾fW6[;N\n/ɧB@eJe@ozѭ۬'sUppm*}nt1A2'g!N2Ɍz &3v{kٿj뒨WNzG5FP#"DpNG $qXQ10V02%/m^E)Eߍk 'y97)lQ)w;9&8fBe17<9IJRYRZ8gjo{ N?K7.4q5رpnJXG<]Hֵv5xt'E/ -%*EsU=^ DݹD,[w:y~hpU*:> p$pQB:{ !/Twi]ZΔlq%<hakioyfk,L˸|3fSCXtW ZPFBF)!HRNr#Uycl!(.yMp2o͙OݺV&cnKm7L"Qsbt_7p܌BUQaYAhQׇSjGz%#u@tAVHCu 0Zǔ.nB¢+^ۭ! D:V6_!X! :l G1cn3xHm㟡98J HfuxS,U1i|tB3dO0["G,0@MU9QQ,fW,;1Y.?L=yMƔGjsגyc޿~$T+ ɡH9[8/۪~ p-//ZQ{@ڸiI?Hde<6),X'Xɴ?|DBk<$pB9B+:N]S>]aJ J\kY)X$J\NgQ*yKbhM74'TIKo> stream xڵZM۸W_p$vʩĩ-ON(3C2Iٞ=䷧ !hqj.FwW_WtR flE3b2CWw+W#n5ͨo+QxO?nu_?];prwmLj7LG+2{;h*^_)*W$ V.*.RC6 RRew<ck*gz<}]n~Z4{F|SaBYy"?xKfr~r⷏bߢ?pCe}PF~#)-c_ڢY&%2Qnm9 m0 c7g<lǧPi. =3xIn_onhv;t\Y!>fbǶnջT贤h|J3jZ)Ka.j1qL*OZuScLȉOH4ĨvkĴ BlAPLBH܀1cL! ̴2ĊS_ Swg7HTe}Lěb}rX#9u~í'2r6EqX.&TĢb p*)35}WOC]E_ {hq?WU[1!j+gEݖheP(jn^ xHV$z$0"9󞗜 Ds`H*b"ƢwU)*3'lzǤձ;`[}]R qAq˭fyK7HPF)!~S|B8@FINDL%'< 6ςL^XbyJ xaHwuSXמe$(=#nm.mPAuĶ݊ێ1^"prtA*j{f .yr6ۤ+CbB9&'S*HZvejMʥbP϶iu"dBf?4`P&}زhC5?O si:[.R,bAt)n/[;O`tUJ'#M1 l 9AC)͑[S&+ouٮL@qSHƮLKW^Lzb\2db0C--}1Bɴ1_dt#QL<;[?}#D|`TV /8?y'5 IFiPx"keI9 #qcyp%o,D"R#(X~ڋ* rW@4f2yV3 ns&7@p8\iȒ)@p)L `xRfX4)jLd^XΉbw9a8AAm֊ᱯ LZ8oOʅ[?v֯U٠=WCyهS>4.P$ʓx<$xb]?] [Ÿ7,[h6 2#ׅs0P `?oVE%3߯0W"tj4MZL-%>.vTT_L  x6Ƭm/gL3zm//l\2(tZ$S?}ډ545<jF.@-:`c\߀Y.k潻9_ M4| %ɾ&} $GnBdz<[fT2J][\ s[,i8?+^Mpv1y-y4"`;[!qҗ2O^ S endstream endobj 3063 0 obj <> stream xZKW98`@# 7ۓw|JcԊ~t&@ 4 ,x/-] 6d zA2\/6nPV%ܭ8˿/w?=}e)/L{[>V M\S«i_wT- @bmNNeAɂ8GR^dRI9euG/Y[clN0bߢ:H Mfv_7ծcE&4bW1{Ǵ.) Sd3sl`تno xbqivBqlQQBY1.;u^s[C]*s`y:\rŀU PXj?9QD9T2č*úvP:nj9 PA 8x _DݕZ.4R`J-rĀm*0pAY.G;znZsk_uӢ t+L$gKFX#&mLsPp<"+`pA]a/څงn쟯61X6c#e 5>8Ą 's[ZI : U Ur!ٽ>P FgF)&%v$b[T[4,:s\`)N\~MXd >C237ͱ^{VĀ[=r}ЦyĄ+$d79iP/@ Tkߴ~֥nla6?]pl8`Ea XXkλ9ǐیN ʃ's['Ѵ_6nEpȕ77-I9N Sv6lٶXJR֯Z׼ϭK"8P6 zƵKVy^wͺ" uY^lT8e3*15Ϲ h첩ki0Kމ'zho%rZ ]p#w;cvP1{e?<cV$R{7 (TIċ+{?uȒwےFT̘Kn;l@Q̀J~]T4h6v\iP8 X7|@̍.4 ,'C@ EtˆOWPK} `٭w(H}0dR4ly. ̴Cc~mG*EhHUqRbwLWmHЇƨilmkOnMmxJ 97F5X{~T0O Uo܇@%g^+%}:GsbT%SY #.D\r/(%O>d Nql}1Zuӄϒ|}X|X,qA(s] =< Hz[.w,E+1,"/,q X:sxc#r׿>z*)F[hJjZLͷIҫ,RmY0z:Ƿw>P5޺-8~W,/GNh2a~}<&c6֟ڞ\zrzΪNl'|t>jY.&aq}_Wڝswlޚ|lNTYp@I|^(rE-gW_bITgt:BNOF-sg`tP5?7 uBAe)rۇ_ gԈ_1Cjl>_ L{|%|e>!UrF)H) FTP6 ^#9rBr{RąHo9dh$A ɶQS3 @IDQ#fPw!cQpJ)a@ 8YV%@KQmtżDڰ+$ ) 綧L^u0{Կ᳀cN迻CU]FFU,9`Q XDXrG ;%53>X諭/Ъ;ZAG2x7G;'̦OLmW0j_TjTϰB~ zF$qv%NjSHaI׿&'\N=pڅ Om09纩L:M,G -\y>Dsi:LfcL7i _+`D"u!g5DM;UOj> stream xڽZKsWr*$v*UUN+ ` h}wvn0_6lC۔QRӚmn60AjYmn F.8)Koxh]şqq-tӳf˫bw: /e" ʚTL͇o+8Jy1~l Ͻ+O{\ŏh&]bpRKX2SCqJɊ|I[{ވ݂ ۱o} ~v۵*3Bp)FVto1e1ʲh?"moy#Sר:vp8yh.yS2 ѥvͰR*ó[DUӷ%+(vgWЄK&-cH|CRva6m?e.af KܡqAvvwLA u`[aGG&Jo +Q" D]\)RJOIU EFš(Vwz_$VpIjL#;}&*=4f/U.bJ) NL3$ƿ9"vqNڊBb"{g(ZrEI$^*0!98 !&Hb@a1}Èg+ QV^]Fܡws7ɤl>FJ*5s1u}s'3V26"f7wAqWIo+)hi0fn-[*'re~y& 4]?nMs(Z_*\5x_qK>& _].Q?* Y~bDkvoiOIc2I40)Wciy [$c{:?8-̲voF{k޴Ua -LM/Xfwţoᅡр2[Sb2x$C-a]*69+b[+ozUMD)nj:2ٷfvDFҧC 1 _vO?w&B $PLݬ*uu1e9T"j_dJ*u/z&DcX7Ls%O@YڪPZʸĕO*9\|3Ϡ\4S&ΑŪSAW2o9Z#l:m?tm A^_eϘ䡽 (!ͅNNJ\e#q5dqnܡCk:n|D;5fn]蛡D%t璭9~, 4]1tgXxkH/V"=EJ{@N.* u}?ňTuҘQ’E_9! bxUpjIm@AmSQPM\[ӳRohJ\ZXGSV8@cu4,_67q̀-ݭčcUD~Ah Tshf 2=(WT͛PN|n%;nzǂb8jH ']F.hxM"Oޕ&#[탢iףpgI=ԜY/kh3ɗ*j~A~P\}"vut):Ug ۽˩9t!.`*tH/gT NXaKQUܧϴb^cT5??y^o3mS TasY]&p'4vn̵2.BC S [oٓc\1LF`(>_|ciƹ}(LnoN/_۽}Z ".v*^9LX9K.ҵ,:{'F:sل GwaZEr( G*.xC1sKm;nnPbL Xckom- DZ=`u'} j!f7W 5?N@AW:=!^oq ެyv;Mv"(\uJ|Hv!#l MݧLA⫎ 6v NG;CX0+" t͌<4XBYA6O X^p lp JD׀:f4|GoT0MC2ʧv/8ْF82]+o\Ƭ<^> 7BMd<٨ÇhSnl>Ѡe@J'}?vOp endstream endobj 3069 0 obj <> stream xZo_aUOڗnp*֖IN6-п3$EKegw@Q"%f7C/t? gnlA3g9]-YPNra7wbߗu9Ou*HmhBa01~fT|iaX*rbk?\KMԂdIO04 \&El6ʈt4_V52y}2akN6E}_2fk1^s{.`A3^;;1 Wj7wL9amU>j%CMѻ7E Ul۲X;,o=RnzIAUv=hXu`IuTS=~n ]E$ v-m$@ru7zYĘ9tPS] aSof(\0;`%O-3 L9XSCtr{G+9 }xY[+꓍/ UC1HK}팠9P]1Kkl \;gQX&/B ƈRo}u윧 ܌!&dnh]MjX!s"3 s{k)UsbkZrP=hį';"z  -1%̦B.`?.)D~Dg:1qTP *,k EPN@qTT9PPcP x\ݮl}'En,<7NW_P_y(ơ&/u\"\)p H a71p̄)9m30UsQQӔOuuӻ& HEN_@2\wK<^3‰t Z\IZI3ufW.X50}|ر$B@wv:/yn6۝B]DG5똕2z?uIGQ^X3{%Gt ;EW~ofeCBṪ?jĐ4Ɇd"d 4N=+ޱ%ESoeP!J>\aVѰ %QOD?5-QGz Da?#Q!t @:ygʱ-(@zSbh> S;cs4*KkZ>fg-@1uuvvA;۪\z.G Rf%sbS>-/xȯQ'ٷ/ߖ`\lg Cqlgp3Ǝ ye6mKŽ{H /Y[ y~F04ס>QAb6/ĸMCWukxFSiu._`BѪY耍M Mf;}OU_2ܤ@6%md RᾸ*@B} ƓiMډ>~{g!]qi{_R@23]ҋĵ73~4ɮtƺwU}״|^C, ҆Tnk,p+_ja8dfI~\m+<˴ o_quFvSbՠ~IU|e2eh緱( 4QmsO歍1JnsGvU'`Lp?X.2PVމ$pr9I8:/<釘`mR|a('B(0_Ɛ pCp==5Nrٖ\uyև ZGōXC]9>WDAz-x`ȳ@2_$,j ueSF^diH \g~F?Za 8 4@:>ӌ/ؕ"23v{_ߠ^RqNhB&ί+PY7 endstream endobj 3072 0 obj <> stream xڵ[ߏ۸~_aA <>ݵ"ҧ{ڵ.l?3$EQ2i;i$Cr曙oӊrCW|9~G9)> wk?3sq,1%V/=pE۞/FBɋf䅅܌Ǫ{K/j95[P_ Y05P/$BaW VDŽJ=p!LT۳XVjKDFȧqkNM(A.D8)robq#\pQz(%ð*CtVc\ m #}qꅖq4結{79D`)Mr0\&ڮp oCfX0 #ިkcoLb5yR'/tep;Y3a^$d&D ׂ"(^`Hw6Ck: .'2Wإ>?iٻ {r`!ǦRUڕ nחSѼ Зds@Ir8|4 hee?ۄLͷ3y1H!0xÌ/`&Y9%%PNyf,C6!sak{ik?SK^3`s6{G >R\9>X2K6C%O8vB=ͻy :mdDy HMa9^L%lQMw$v0t'LaeC2]qxhN߰~mzӔ ϪuYo뚭ԗ|%\WҏR:=a5M\7}yn۾o\=5ϽЙlV9`^<\S7`S*P="dE>"mEkILOQ*qx:./?Z:ıM:!ґ';ёRaj"fg(o 0-40  .=@]}Pk `G;%%Gכ}<pimе{Sg:zG1tձ;W)Jr.,;%VEłé;{NcSg5)_qGP&!̃s{ >&&*$B⥊ѣaqppr U3|o@C0}NZ 'g3n s7CaN;|7Nf|7 bo ib{CTgEf}`Gz_Ŕ:*6Di.|>fuIz C*ޥM;aX?qkփ2HYQIfI0Q­bxH(fLݦ1sw{ژ0| f]EQ*uƈGQMӷ]7@<`(}@$S~nhC3s6Z/Y23G+%XhԜ \ނ?FOx%"$ǖw4gy\/g\R?N_9]D G.7)ŧMkPJn@h |*S#rA$0qi}@eS2KEJrķTf7_!pC> stream xڵ[KW|Ƶ7h'$J˵{03t4Vvw|oO7^$5]]+ F?n,/袂B3Z}G./YPNja6^p/f%Xc|w\x G1]vDM n͊56]xSNߔ*^H3'ZtJKQEhvwI!(gD)9Ytw]5mN LdɒhR):m-w'cmc=dN]OM PԌ;O+ފ3F/V **go|N 1 %L ٳSD"L]`{!C%qpY=IMƷ7 u&A` ñ8Cqsfg7wܒ"lٶ9ٌJPϔ?[7T4:.5% ((q- 團}l?HLҟNgJjpNaEǣYw "T8DJt F_r晪v8c =gipvzex&+Ŕx&|/v=Z>6ܐZSF=h(%-H0`l)F r0O*+=bQ1(2( Qi+ۯ=P-9@ N"J b /J&9AԮ.< ?ͫS7᭷{d}dTެ a#-EֳE"<َGCz}OLVБa<ڕdqޙCJɇA(Yʮ*.&i>n HYc6Nrt}49E#w}Zp+n0>!\G.>LG% Kujdtj{GnV; Z( aie@7Zczg/f=:K)\.%Q\'QOq D$ӪFpp=!󅄨msl:GGZP>9LA+I:ru;efiP,/R6K:p 'dS*+ TS;n31#!JB p6p0yuDTIP3=Cno04`[l̏'%d&NCm.2P޾+:"|wP7;l@r(7! T$3QExk`yd$zd}/D@CfkHIj  4 &քV>jH :ecrw@{v5z C>"4pWnWriSNj'>Ǣde$3~6?_ɪEM(BO_i xGM<.6 |y{܀_)*ܩR!mz\c^V)c_AOA3Gw#`0 y EN@p.DCE؅Nus'ZcZ`h z2|, > 8^ A)4M%eZC%CV$?Q_.٪ ^+^Q:_r>YcZ"`5& ZD98˯R&CN`Im"/:m~m~8">23V";|@#91裠`fhQ@%J(@V~/29j# l 4xÉ56N4_Ru1C R|b>b}uB ?/)9S: p̀O.x+aEGNBYYBkAz&j~M:E trsOY֓+Wk]ĄVQ]B*ۑ2\ujv=10~Y58Sm5fMsBdlސFڅ+[O79^~sB`3,CeNDMÔDETnZ5aW4lyZ9L=w9T NF~jQ\ΈMOo=^]8Xpy.lC' T W$4 Cj)ߞC%Ŕ3<8uwlW@ d#>K$sجI[bKnUl[ojyt+ ӳ>fùʉ3RuAyM k}x2ÂxB: UcUYR_Q endstream endobj 3078 0 obj <> stream xZ[o~P)=ME .灖hD:$e-ޙq) P \ٹ|sY"#+E_W]}%]"nV\W\HA[QFs_w_7vf70w8ɼk2۞M*~ý7n p=L3LWX]Ck@yYSQeOwYKǂ $kT+;H,FऴSlO^NeTVNO.XɝF+9y0G*rZH{)e.ۓ2w?[T i4vڣyA@LX a.'֛e Y>%cm ·q  *>$֖Y=j 6Na0WٳowSG3iF":z8u۩ȋ؉gB_*v)c~^oJ!3gm鵇h`6 `4jX ٙC=6(=I5C+Z:ZVV ᝖DP3KCK;z&1*2/[b-!$GV^n%IsJ: ,fވuMM#8<\T谝@rΜƃypЀjfv*J--]=H'3jG|U2ñL{UCcgL@~R6OY^0y̓,Y\F;=7ftٚ%oFv딥ྒ942/+e!lrK|mc*@M})jsPVt FOF?RE 悈>βyLg! ">ZUi"HImJ" (񓟴4,R(2 |W*WY("#K7wkQRrf๴& ![5kStQlI; N/F ]Fpx'b|Χ<[T_ h^yƦhiN([B\@`!K%H؅/FOƁS6AA`mIԛղc"xH/}3"ݮ+* AH!KaHZ\t, ]h愸Q?+u%o8vܧ Ιxㇳ<ܒV]mSL!!ż}\-å3!bWR@ `P2vÙxo9`g)S/ZkvK]*)诋_Znڋ  UQ̔ Ÿ) N acv`,5&\&qIL)ꌩL3KT:hԗ,yEdk^ng'q_zT/Mk<zMB36'# 9GslLMm?֡78c#lt4ia݈D8Lv+^|Ypy1XPul`y0|\Ř/V9Ga&`QxRˀ6`ˢ2)`폶׹ x_{#Tk ;m?^=sjh0Sug4Se.A"堂r `ʭR[98N%({-]P+V%F g5/)yKV W$@}nwh5xJ0ԗ|PŹ%uy(7(WzO*1x` _PD®=.xW$yF*.,95ǧ Z{pW ^Edy\)UUr@ (i{<;V4)r}qysY s`"XWGx\ͯVFf"wgJ]r^MZ1fjTCxS]%Zr?8tcqvIސ{f)^:ܟE-Є` $&f&M?ZudnP4eFE|*!c+'6d xD%ͽ]<0p] $cD7*K)UD _ N"l7ǰP\}T"nL}L#,1 DH#䏉oFKuy"|PUwc!m;]k$/i|= 5|pnrGMd&PxٮR+aLK˅ o,gm+uJrIdk.u=U1yѢ_L 79tX"%y1ۂPZ_QS`fբaW>9o/|~cPbҗ\-e4tG`f\| Βd_;NrLQ6.N[ Y`I԰N72>5q!DYdPLpugqICU R}YxтKc ƈaK݇fbns%{bQMܜ4+"\\*O (,mn,{ҧ!g܇cCGͱ }JH} By5]kNIcdT|`v:CcF-vf(Z@F[cFW'{ ݔ1Q Ȕr51hU`gUtlVrqSIƳcAB8K)pߏ9*}0Iۮkc?N[5t=qog? Zq_Cp8Er]>XWs^ͯR7Xĉd"S ׵/E}Ɏ0-L0}Zw*~vE价2QqW'c;җT UZP 8(Po_7 endstream endobj 3081 0 obj <> stream xڥ[[~0R/p̈w2}k-A[6Z[ĖI);Û$/IH$g873 Th߱ ,||PXa6?n}S3<8[y !?X~ύ?b=;v? K a߮ 5QRU}ttS/ Ň0\Canvi椚TRγRSVlkwm짩sHKb۾s31J$[ǝ^8t~14he0wAJy ~rBH`T#.Hh{[eSlvl>pMz\NM7& L+0KƘ(# k/XT/F[͋S59v %ƅ\u֢km?QAHʟ䧶r Ndl8!7'S6>VT4 DJ:?tOT- @G9Iac;fZ؛/qeӆ+E2`9ls'''3uE@$ V|ٹiG3Wvk;-6,#+-Ie8Ha2AI }Ʃbl83ԺYEd96wY *n2Ɋpab1!M4j%?{S?d Z0NXqlp5I*bJSR񈅷rÃ[ 5kqW\/9Y^ag rµ4d(? sJD對 ^!< 6ai`kdDZ(9 fojKJku%x,v|waOK̓Kl28?s9ю4Dxg'~|jo}r -xl.k e (a*b_@}s.uV pܪ T T,ϸhgey߲%:,x ʨ>{XꡭMT@J\Jݡ0}9Oy %{(ۧQ,*wA5jOOJfa]GS3'$sh A0doLB2y\o8<j ..:-3OSQjުH_2w=l`05Hֵ)|WP1tg$4 ]~$@st`JE}w%`i  :d%!UOFrg"L!5J ,@^!dRhAB_/p`h`X!KGTL+,n/];ake83; חyƿRY /8fHa טEu)I¾fu Cn4N#h(~㷫-DY9o}B5t{_rhK-! ˱ HU!Qˁ+4u.u/ 9é,ch/R+H&NK0q62K\ RNuA0?*l<]z ZPz \\lJÿ \`njs8N$tO@$CCjOP3ab$*/% q?_paB6lBV&CSvQ1GW`$4J_/ lgƞHq> 4 2=aHiHI~hS-z'wUêBQS# i,xӆ??5>@ȃ]\E׽JFܥ̗4$YW;Pr.(B*%?7MBXc{:{$s.;4 (k6GN6Ou~w eX2zP/晥Ioln::x bX-ٙIyؙ9OxbFjgɊYk;Pu6;v> !NC-yr+ [L;,zO$=$$'H4 ej\FKU>64VbYX^|C-אD )r6D rlFd g7b kL_3p qp*Qh9;g/ ewlOm^4@@"' _xi~7=QgA)DeO= r<&Tܣ,xjxC3/]=,U0Z(FSzJvUB+ |,wH_5>唗H<(JdNSx[Cd*BM.W|xu87XI*a``=8f=S%,TDEޅ'_)2(uef*؎)S[6sd BsX9kʫNVV4 T~&Q*-asE|F/ZsPA3ĺ-pc}WLAWl r~f Ěc=jdr72~m!J@ 'veW!]O4:kS (&2*$2E1#w bJW Xg jbOҬ؍S;]‫PluAlX%Q1`ؼM̅SXsqeM}<5\ V=ů`?+dp>լR wY*f䏁 5APףB*Chp0e;Գ1~ZF-g7 ) p:㾺czH=A- qqQ|!-j9Y$O&W-Mu@km#X}b-Ǻy{VX5*$RXj-RMde!%R3xq3hUH.ڐԆb!{E) Mʛ$8 ޕ7rj[H"R]m_X:ZU䁭$;ߤΨ,< ǂra cRֲP%~T7bs( ~ne#ԋAƢ2mʜo)S-j7A8xIxtf)&dbY\{:9qN`HOnI k%@ru@`<+|J=7txC?p}f9xT=1zi3c:k)nBF͂ J3) \\׃] (D ?{O:xPRB]-%rzт )r,4w:U ίC=R,tqrh~Yd#}\|+!D``]bƏGp@` x ONCo]QH|Q)عɳ)tO1˯ SETWmjeȍҸ:J-db% :F@9R d ZY}Gz#iWkĵy4IXND]HbMbYD|$Ai4paCBTRכTg>厚kS:U +1l*Ʈ{`U9;U7> Z]G7f) rWh-Xa^=6 eo)\m_#U7|j#0 LĻ^Fމ@{.bV R _^paQJu(Q1 ʇ 2TstasE%ʙm%h8/+P*˿D>Zɟ"(LlT2Zc5/P*"Bޡr endstream endobj 3084 0 obj <> stream x[ߓ۶~_C˛&OSwM|}x'&)vw P v2Ʉo] +J2MW_OY|u{v%˕]n_'<oVB fϱo_f-LfK/U?PZdsܗ͍0FνU,WnM]= -)_ڰls>l5O3aElTL8J+jCD|P13ߕ$ (`y{} Ù,v@WgÞǦUڻ͓v9w=M-v( bXPϊaWA 2p*j-g:*>y_ܬ6u(˄ ?Pֶʚ1k>ߐU@ 29Wh0f4žҠwhOns:S#4cChP]L"\gƓ̞UG; ^&9y4fVz>Ia;4۔ WՖXXRF;7ɔfzDZ?qJ\f05`b&^R1#"lB2_bCWAz4?6„56ق ؂_@QyHPງ|T<`3(xrd upg&+xpr~4'e鉓$bu5vBWLd3}x.f%+@ڱ>QV$,0nĜ$pLa_AVv[H~!|494XG^9l OV[!lc"+'D#1`i g941|:ڛ[LQnkju9ҐOg/< (Ssj]L~4Xљ8Ή~ޘ,!Frc(Hz"ѵb鍛~vE , 17a8TC:i,p9H܌_}XMD+ԩ_8sNN/)tK<38'̊Һ H&3{a`zt3,:=<|IQ`]5T @,[r?' И2GT.݃d=M1?]鶎deJ|V3I2wG,WXw!򲰺2=2QjowUOV~Ee_zuNK0V Mf|Qp#`n{iCOJ3۔%p;j9Rͮ ( ])X1 7Ol\buz-T R_871/gv@E̤͉`FkOXu(nB-ǜ:gƘ`H:K?Gw-q /};?C 1 <[]-6l%Sn>WOtc0xr c9Ĥn5tˁ^\'tMݱF~CZɳ96E]?QztFСr)P UCI ppcEQPkW:?|ls@@(]rbKBPV'{4x@D+̲\ۉ!)̅ozոu )4?]ZrBd\NlHuV !U:@9=Lq+*'s*3*"UN'<.:,|̐牣c.ѳi هtS틇)'y(:e׆ ]rgv--]_dXosKYfQ[L &Fɺ;[\%84VV!3&"SV9O^#EJp(Ϯ}4󷂼Yao SS@FQg:^ye=ֳ͖6Ge"_+z1*TG߼q4l9>fD_DIDeT\8a7{Y=)<ʳ= ӆ}&}*V21VZע`岂a=BW\0iRXs#Um&g!Źh?{㩪\-^2Evŝߏ ? dd7 endstream endobj 3087 0 obj <> stream xڥZKsWHUċneS%Ɂ#6w%RCR;>hiԸ$~~ݗߥtw~y){8'9vE?H)yPJ%;m7o>}en,/TH?oj졟vPYc}+vUeӷatq_X5']L@HK^Yitk>G"~?4ÓGuN9nӆ xkp?L%*Bs;!PN'K~lÂnJɔ_0!0?dZ;Ŵupc|"bU0 Rq̹~($7L4HNEl]2zGzIn.8" mɵ)MWѶ^]_+., f0'X؉-vK?_GOPW?5Z6ɥnXʢ~i逧6I^kn(詽wv}qs+^ dM"e{sd~_:T)pULR& nA2gg?hKY<Y/č#MV6ť -hi5d^g+ 3I{,KJQ&65.G:L-)4M^S#ȏ12s50Džl3T%?@5"ⰚQvuAYg2 /x>R 6TDC Dk f^3e{roqM$Lovt;A IS6.XS+.VD},PƔS].t:LK%2/+Qq;9 h~|Ӑ+-mفq7 #^/)t4 ݄FNרBܧX"8GQ[@מ \Y!`̂X Fp(_o2Ir (iTynJKt`(Abԉ:!dicS_ F7YVλ2Lh=r,3 T6zM ҅hŔP8 !8(F'PY1)Ă'`c B8!.aW;?DL"d4d]@aJ閻psadȩ@!bM^i䑥HYyyo xxd}/P`KQgM(("7ێFric͉(@Dc6b+[u\6mO5MH% #L1gG&c2BGvԏnj~FBOTۖn{'pCvxe :~Yۉ5%Wq?#=>X? ǥ~d=BQ@k ط@1"C4=̔ˇ vqREȖNtX`cv@h)4 w#xd"ԐE;,sn&4p5P 5-Fo XmVjR Ć-.4v@eyt%17idmgi`whBw\ 9*e65^%7EX9jc1]!=L'e,xUK#UMצx,:~\wbPlW51D؈*@mx )Ȼ 3*_SzՉI8 GBV`ߠvB_ %:QUcFE\Awň񠓗.y̏I[\&+\QV䵮ɫmEOp7c jv IDQ^g$vTp 8;SA>T/5DW> xfOϞ8zqˆwL5.HܻZzc&˰mokBR [E*.z"?AAs=wu$V1&v[T5IGկ73m+!fJSH) ҷ&^lCo ).O356d*)j_#یwx1 bH2p>XCWKYS&GY?\_ȱRi"y*)DD]IY4B'[U f3iƄUws.cYaϷFyCbF!/9-KhyyŲ wu.@ >!iRͳi!?nsdr jb:M`2ŎhIe{^X`[! IM%BaE%[TGr\ 2,0 Z&3UU2\AZyJй YߕI(7*Dz/$*f#nGi_n Uk"3c!WϻYTj T]ZaK`#4aͼR+K_tBT˭V̪iIJÎ'H{ʇ 7!@ wF4m0H{?aiiXq켊 FaV؇Gl8hw<[dMJ U~wSP<[/4aioգ.Z>[}sׇ?L endstream endobj 3090 0 obj <> stream xZ[ۺ~0b&iNSh4IAZ[r-9Mi{϶I ʜpfo\}A Xy[ЂŻ #L Qn9_V_nZ?6[1\u{r~JLe0DSaeG7ξZ;wԮDt$HXD5)ϩJcp&o6,HGPPh#LL5jYпwfjb(;S2"A{ Jڃ[ZfH-Q^a[ (,aWS` L5n%̰~i_ϘpᧅZ6u>;ak%}̴0DQ~Ί;jA6J৾޸Mv]R]E@?(~tl-f~ֻ$, k^G'u*8'f>#4~NALxӬUNbjw疚 ׄ)3iq6wYwKqXX!o`rnWaM9aN/hMj0Q"*ݤP!&߿?a|CZ_iR_S?AKN" %̫c_Y9S1%=Hʇ%> N&5N'|4Y+Ѧd0p8|s^45f{g49.?Y8ǸlFB]jF!53Rin3#c]0^Pum֘r[.%sEi4t;8b5-3 4"hXH@fsI6hmbrO,1&BsW)I ^7s&*}r )JH*'))0H SbX1ɈS1)s("&H{[B~&43Яp F'G%+5WB^]Ex4喂 }z ܨDQe;bznIADĒI eyĤT@X>;9Y[2@%r:Zl+2ɀVF_0edދqg̒kβ z=,Tc0*>MXr¢૒iM0)c6Òr P|9X_3‹\eyy\!Q32 J` Y>VX3-ʁJooF{j ୙oIh%(O(as?t6fnnP:KJ2b4yҙ4 ]Tu΅0dB6֍FgET<3 ӒLjVՕ!j}*i9tIB]fY k1Xi1t5} l_NWrBr{ѡ}D&_04HvCcl[茕8ևC3MIf W%ϴ%y}@Z΅}!61<,k ,I UtK 7~1ngWh {"jy ?^~d"Ы; Ww$3d8%n (ɠ(|G]-Gy^qoTFlCfiz0 UȾhU4Rͼi.й |'{PE7?mƄƈN (D$mS=y,ԟNs&tXM:6VB3;9E2 (/ٮx|G;9"l}WlI}W. c|0=gӝHK4h)jl3!'s#K`/s։ M V;- )K|xlƵ-/mbp~h")Y5,)/ȈQ~GXf G{b+Ơަf'R>"VlT_p|_A$X-b$ عlv{DJ@Njzo~B'{`E&|x6jm0ܪ\(եAaOV~ }l~|)[kȑ&約%Wڀf7]㒠 u'7x:a]bOn0]nOwKq -Fc#I7r.,{ s {ۜ|\Z۞ş/FÛ endstream endobj 3093 0 obj <> stream xڽZY~ϯ` ǘ{&or$?`I1 ק{.V+TV`vۆnJn4fwlCKbKK76l('Vͻ͡:uLf+(~8vP7F0 /ВI[1%۶Cۼ}36]fLS"RقxT[vOA*G02l;'AY6jӗîonAT]Gy n$-s-)y [ߜEc?6?YQ6nזKA)RZc&"DX1S^xYݯ7(?xhu3!2t-(BwPE]fD zU9RECWǡb2Z.~V5۪5(}DJs'b/8];ҔՖm&?M[<6mĹJd=A~iowf1/B b}"\#2w= s`۴CGApo&>8Dw0 \Ns{z^({Zx$+*A_v?E*CCJs`>M;䲆(a )v|Ich0? OGD͟0WDQtPv-Pt><8$̢q"ytcq4QOCJe < a2J/mujv:0+@;P!@(\}_vXѐ(y?]?$τizpsI sB&׼jDkp*)Æ[wb]9 >>]w:Di؁º]X7%\oOdK/4(6+A+* +څOKM[I'ss~KM|9Tu\f0p]̱ltdPf} sTECSiTC<#]#KA{=S6-IJ<ڨU521 Ql+UYJW)"ߧC|W AᡍaE}:o헯0wr׻1"88$|ԗ',j%^, y-Pz!\(sʠjcL bXpN'K o%ߴIJ96-$Btj S Lpkg*a0 VFjJ^N *Z; t.t8u':S/<*%hj=;p{/EA |ZU=n,A;F͒nA7>QYEhYj7сdw*sŴG_KB[p)?#iVPqEe,e -g 㰥*ekT=o4^x>5KTbP+Vm__ᡠkUş%z1#]1z>)KFpvX` UMlXL2$`9Oa\U.Ž0)%ljM#Bc~.q.JGyQ0рStGm%'Bn4+oɿn܀iײP$#6+ WN9pk`$x(|ksK+bw$w .\fp52PP[,S^ tW%$/^ r^OgV;0zx\/G\\[1 oTƱ:ݺ6U&c3Y)ixcJ !俯Ǫif4Z%۬qb-7 j@7G7&FzqhqR򯜥(4óu:{ŀZL0Bɏ/~+ ٨CV$_] d,IA{iV C{iՓ$`I'vN-d*U(Xb R)bԲxaMVj6rRzrNx, oY"$_9JB );:ػHc!]@Pc{&BCR.@ OfI;]_Z55R] `S>ʻQDnΡ ^5%7p1fnw:^1?|qtWW pn)0dӰaMfJ=@J6=Cb[FcG .L.Sr$+GECⱩa)$}) X (  >ɍ uSu{. 13(.x v#羖gCVt^>4[j:;'*+ \9k;7}ͤ $=4郦GxpJposjF\ ,X%ophBoQAhR3^*J/JkR?yx?kSn0YJ *nyFoM0^2 #)X_L>j*X} endstream endobj 3096 0 obj <> stream x[KW| *7MJjk]''3C[eHifreRG?mA%Gr.]|-[В ]TВo`9,9E[}ynE?ڛ%3갭w7LuI$] K nӪ3!kxR)K~RHZ~|}+Ut OBU@0BKM0wT+0.j [\G ,uιv/vۂey@J$V@^m?.O0Zҿ ȯBCA~G%Z|DɊenI!4v]I&DMFOᧃL/}tSMK&,pJtjL pJ۶{/ >;␄mx_^ژ Kbsf19s=n#&4!fmO<Kֿ$a' |/KH 6%pcD.h=tT9%60N2+EO7:`u9&ffVa} PТ'^I=Orحktd^MJjphzw'6 ;0;|}\9x,ԃb}A ^w n492;u#i)!L?6GD96Ur !8M 籑a)%Jbld\QgRgܸ^4Ƈ/NtVI{p+m\ AcloqeSNrཱི1B2*TҀյM^՝`rx D[UwTKÎs~$ #˂WQ,+2Mw{wV̋Xos80"kwx8GďMD,Ue>HqY 2?3Sm񱢂XTx7_ q3|xiQj`)4̸܆$@;}"I4$p:kqEMýT`:W~~:oR,g0[n_.pwƦ26H|LI4 B쏤2 2\A;\ARkkg2dySwX1_?3x(&$1jϮ?A X 8ίGטHS'bIx)!Ud7јnšݴaCa7m\iW3۝kY 7/Ux9{vs bh)n/lI( se  "@xvr*dd8zsΑUܽ1ŬxVo*8̩s_,/{:xk6_ Ji ġ)[mmPUWmdkovMjiC 8`i[j4 Y'm)m:}(RJIn.9( |Sia5+EW=纰 K{V  -9&FF0)fnͮЪшӕmBw]lɴ %IL7:!G7 hk 9 PuCF$Pԯ&:S%h20Jg_ "G(p{LZ۶7jz [xzq&5!7`unCWz=lv,jY]8c:3i>pii]S+{wH~Z }tk)"ĘBRwέsc«UHf w*3B~@ Mv؍ ʵx8δ8tĺ8V;*+})I5B 01jB!=mnQ MGi<2Ε)>31XReCm;*I<ɤiJ<8Wcv%&6 BgyUp 3Mmuxt5]9D!ZNC?vq_za822kh%.Jq)|kr) m)US-9v\`;T `3FyнC PX 6GWG65! $I!˴+l(HULx\˱sU,acLSL0a38PCK@<-ggq>id9,:Dy}̄-}RKiۅ$I Qk>&x<C>KNZo\ŵX/_2|Y$Jא0w0&3S`#^3ljL2X^FB,euuk.H5Ӯ [s6Ҡt[/̒<J1ҢBl.!C*/0vB88@XthQ60-WJ<ҦTCWי. 5P$SY#F U@`˾'[J7ASU/O,*DC%|觿bpJP?ώsqhrD_5ث:}Bt:4!r'u8 \XgFuwuԽ5=?w~/Gxsg֔@Kf_2aȬ endstream endobj 3099 0 obj <> stream xZKWZx-q٩JR,fDD$xy}Iy ~}uS7d?QMsqtC0pE6ORnC/7_yÖ1VPׇ-DZzxy/LP$W$>`ÖV~3aYmľ6Nå.à /%"Dl񍏻S`OnrjNo@.;ԣLc}ҩC q9az9gŃVJ. |aAhY!&A9`VБ籟I<QNj?n*&Vb_v;FƄdDpDhkJ'ՋAg,nv~8:>GD% aR]vſW^SvvC}Y&L?R'{=5|5Ӻ3Od0DU^ƘƤ0vZE qJ-F8ՌsdejqɇX Ors(X.~'\! _n_ߙ@y۵Q*%Om}0S4ԝxSwu=_5c9VAO1%A c|pTz$Bz)=bG}|hPAW~uwXB߬ETc4`Siw#Sl3N:麃@D8AJ򕞌q& ci{ hbC|5 itàg3"بQW&mr[ 9z^v:F»+roB燒:[}:Q)=lM"/4@[9=v=_fIG0,["!޹AJͥKvM6{,9.$]d {-~ˈJ(l j~Y^쁵4`9Zca-˗˂or-q cUnRP3՟c Uo(ip?Y_kiI €N/.O>H?S=$8ajoK)S@ ok d2@~ʎD#ɴDZ5m=齻iB3pEn=/͔<[.d$ՎsN3SN1i;$*PѷCTjpIaǃ?U[GRd cG7]},ΦC&>2ky\|@l6Jh7qe Ma8G+U%je13l]'yetT6s8~[Q*q&`r Ov%2iʜ7$L 8Y.ڠ^)>U /\>X@YAKVIZ[L׃1^03bm;&WS˹I?S C)[2|nL)›I/NjZһa Y y[}fd㕦s$ _%"un%GvkF$|H2y@.60If.*}jf"A]ɶ*U_T/_+X_o{aAS\?%TFCq%r@}+u65w|20(-|M:JU tb\WBoM:@]a.~ e|@QaR vo77IcM4vy#5QHd gK9E,O[|IDbz)9arF0]k\J>{vmXfI,A1a@E;8-Ӂ^L@iSr2GAGmg.$xև;v_i8b.b%)uysM]c+$B7ţiQ6dD$x9εsm4_ 1<7T7f'^!ؐmPPƞ"² 旇ZZƊm~TFobk>`Oi@^uՉw9Hղm17QQUʫJ G A.ﶋ,t>{MJg8c#~՚f_ : 7duT}C57fZAbbcQ}/wE2 dq:M6qFuz8:fl9cVp[ O<߄zNXv%FeXmsqpM!&+e7)pNd2/S؝I]Y2RN-{ 81~~v__ P{&|DWGɠ"kĦ!vS7KPRb.߾ A pi iwwS!ew!MnLytR@Cx o5{#=C5MF ROp"'IlKDPF)z0ʇ5sX kDšq|+*N|&B7!tQ;8p=*XAn‡- b3@zZST1XWʀ LAE>PGq,~*FF|`WJįJ!Uf\ Q3xX0 oѦeqH8V 1ï\\M}Va!o3 piue@\/7n5*F5Q5,P7 !TKsi484 @fa&`6%@i3j&įQ/!A%)YbGMoչ"k PZ)l~/A$oӃqAޢ${g^~;gHF+( V 9*{U ULLY Z2ae-򼵀|8`Kq'KR?Bx endstream endobj 3102 0 obj <> stream xڽZKWUyTNIJd%K$ @Opg\tO?6dSd#)+6w.4?nk6/)h.%-c,~Ǐ6Cyv:ڻ-Uth;*٬_z)[sE; ,EzD\la4sz<'t.$b+2'\g:;P?]YdC OwVμod鵂Iֻ]-\H~1ٮNx)9% *ݯ>W)6U9 1kſ ~y[T.}-e FۈY8ӓ+G | SVY8[1 T&3O|b 1_>$,Tx-69ZnlMmXatA|IS|N)ќiQ`56v/jY9nmV Qkòx?D"Z)bi&y<6S_!JLrߌQB.iK> UX)0(f-| !9ecj,NF}P .i)fBAmckvvيw|2o܋>Mf<`W)D΄_zgn1 &FϵQ+M|XH?|[TbǮyP~pe&ACw| 9Q"yrjd\Jxq8+qOVBb`Bi[(2FprLk hUf\\sOa<FKx!|_l? ԁܡAE\M|b>Ox_u ÀKuX-r |ɭ@j-zӝ-uE=T> 23wH _S Xa SRx*W2l"k%5.ktLc󡛢{(J/c1_T^6_u8m=_idJ ԆVO.OeS?q}8g ^^A+ص"|aN/n֥+A nVjrix)d9W>o Fا ji6 W)W$`9 ]Z)3jADuUPO]lZ]y*qS]m8i:o1 i M9tz{MI2<]l!5)T`i(:*A<'@_jxusZr ]CUbA`2їLWrzED z hUqmU\/{bD7JDRg=nz0/ :UNr`*{=1G{k,w}[Èk5JCrv`EWDlYQ]ij-]DWNms^-y whgW΂`8YtN;GavT͒˞<Q{m}h9+BFԫpeY&ZDVTm' `@zLvn[onjC cm`ɌPZx|+F]S kpU*FNsJ#`sbzbS2և 56` ?6щ& xjDX_/`c%1ԗ݂)c HNLaHQZT`iMZ-{pY&B~Pu3%/Nj_arDNu8YRkcSyn 0,u0T'V.: NrD6㤰?}r*AivO\X?/)mx^7f$ZC JNBg?8r8Bt+87τl~MmJz0X;h 5T/J<]ksXF hP~q|63kb5M~  (NϹlzf9O }4uhQ 3,KL=+݄䋪*w;F'`bp׽d.VNtDj~k(Ӝ^N5yW[ӄ,B+<\DvRmX/+iNCs@-E^~m4Ns_ޯscFc䪫;VO=J_r xNÔE4t"'a 8"L~$x n 0%@W0@y*Wөf=40ѭhH)` ̗0(4%ao+>B[$WejgF7pkwWh.p#뮵MznyE\sg??1t$?eĤB[1A,Hk@qV fM(<{.Ýk CA z>[=+Ħjhj-ϓQ;x> stream xZݏ6¸B>Ĭ%M)[Z֖|dﯿ)&  `83+*])zf+%17w+W#mC}mp V}!ao~\ xj d-Jnmamٛnv|fpq۴t']m8+5쫊[x*v5.b c /SRjt[ve $sh"۵6)٩Ri;Xs`ykV6/fo~tgT% [9DEx$3Łh9kt% 5uO~tU:DI9S;U,ضa%3eY<rK?^3Yׁ6(=_RO*}5-lRBqpqs}bR_L끨+ DQf)3Tѿ!ChDFp1j:H )q R'F[ Ab)I>=+LH™ 7̙Ά0ݠnGJ̑匨X0ַmP|Qg)IOXa /h%wϹ-Z"CN<=5`'9i̬ۙ<J#^r71W#M"QO8NErq)*ܑpw{*Z);NI k"dqak-+OvmOL S0<P&o>}X6L@HX[5"݌:e sD6]wCfjvؕZHZUW\ esTe7X/,3|0st]2@D .(Yi^`\k"=&u*3G|*q"% )J_%x}g5I15Fޟl61\2 iB9x7ѝބnFAvN :e]aTҏތ+"!" 锟@"pfTҭˋǩ^q| YBL} 4'] Jr`6Gg]MPBTҘnďxr% I˕Z%J+TadB kN ,C}HL%daeSzru6},RM6{b2 lTATSr΅l62JJFWnaǬ8{'Xa7adO&~nnR{ KYv +0T݁Ԇ+)#3K%f*\, x"^w. ?]ӎNk`oi4Gb8nY4C3wqoa -ƍ h| DP0CÂ`|膡[ω0;S!7be%hc ˍZN[nODsӳz,c*[҅Pq02 r"wk) Ɲ_=^fgm=M+lcL \ -ًƧdyh(<ChsHb698цyCL6G]Cj]A P)SfQC00!Mg-!mfjɰYP;۩ޡ HM;KjE>ܧbPi4dY^3PfIBOSoDʓ"@2VCJ*u@Oi:<Ԯ\{v 4mM*]sW!w`ĠhCrd7w~7GK_: s4>:o}voO &&~Z*7⨺dj X{B0RʶtB1`.L7m!%$J\> jQI'D澌5*Θ.]|rA y n29# Xv"*=H&v$N|C=}͔<dQ8EV1?BPќ^$:/.itrAG!|ѪCm18J83S  o?,$)'$UI/@u;!P!51ܷhEŌtܟ" 7l26M^*WF&WLDXI1-7_G~ۺ v b+)=OycλMK߇r+'_hlQ }r9za*Aι.{*FTb|5|*DYЈ]fu|.S% t% 齇qD7>sG>6\9v/Ëcǽ|(܈>fW?v{{'$2NHsj<.VA3g.tv&"~]ڿO!aړ>ӿE~AHuk+qWnX1䧂?VQ1\L!3 Uo&cIP%Y7 : endstream endobj 3108 0 obj <> stream xڽZ[۶~I;!cԝt2ɤv_Jt%rCrmo}M HxǢ 8~_l9U}\7|()iVW̬ 4w_׌ zۻDkw?n#XW=w,?pMwz~Fބ]6$I׶Ṟ^S&jd3e_ B<ܯGMJ!(BU'Ow~H.)TuT=mG^oǗ۹?YOCC;UP=@|9lJE)(7$&:pAiL1' "DN (@Chi nthvJm'RVV;4JiƦ;e# `AV'jo)B.D39MU5 Z6Ѷ[?aSCuDDl銫;EtIOgZxO7L)LdAhݦ~sc1el?"}rSK24_YŒs-ME3,.D/'JN &u=D.qCV$W4D\sn߸5AA`dbJgzϯQV$V0y74xjQCJ'%# ;5?CN C됩'@@]z|ǧ$sS~'KoOeB0 5q#J2\ ζ$%[ܚ {5zjX$*r;gdM,ǀ`J˿rN"+@nQ4)8J'̓ZEoe2BCr k|ZBŃs}%NF߷LQ/zk /Wh"IQh5)YC'ky nB>F_AG_^PnGfۇ +-+sDy%8 y7dvˇ XW.s\9@<XuB%)ݗ_RK2 6].l ӛ/Pg# ~h.#lކΜ~3PT+ `Xr~W@kX+]$>ͷ,aohn'D %f\[qeYG`eܯ| /bsm%m$:(֯d.Yo6YwvM FTg[g j(ʟ1}{gr),+sLI$4 Ϲ|d/ *xm-~϶g1]G7+]"XG1,sAwu%Xg!3.LBйOp/uD3-cI-e ~A޷LNC|M`3*bbѷ(DPƯ.DsG ݅.[ /,HMsov~[@X[`\vȓ=,!jPeP&X7. .agI&"p"Kɀw;wcYЎ-h^"m2&[?:BN CDl$Uh6x6VGl2S(19) 1(LSHO-YĩhʜXALT2-c޲@hD{ۊò/xPy=Kl\zL_J\ԡlh'SYvhVRB\BM^szdV`D}qAs4ŲP]$%vh7$XυX;&!Th׳_XRaZg]6Dg4Fa8xu<0ʷL F%Z䯡b=zT!l{!:;Pu.kKUp@= CidFz(|)0446Pf׵IN%4vЮٕ«vn4Qr QA6ϼ~yi}Ĭeg$J;p1㡪C~ip+yr2+ eRcTx`\KN<8ø=]m~'_ (̉1UێSÎUfYٶht_ܭ sLC,wpqf W~f0#p,lp'KXUIoU6ۇ/b\ߔ̲1w?\<'[ iH5yS<݆~-J'uMT!h,yڮ{,j.EZ ik.}^P-p7>O_S%|E'>8Wzp1T>4QH̉.scqth'+s>(^yluoOq"0\׸2 CK5nԩ7esNO e[ /~ b^/V;P, endstream endobj 3111 0 obj <> stream xZKsW|FX m줒[*E9HR#=,ȰH}ٟMn+FBٻhr[AMEV׶gS`kasu#|$(%^5^s;4|xf;5|G7w''{uw#I +Kӱ}nL&OG#i0[#3lRpeG_"9`j- r8y[-@tk FCEYHDq2IHP-È 6'l3XE ۟ulg)F6VA\\%Bj?jN~y:~8OwGUN޸GV|c׎l@)wT ]uSagH=o&9uԵ{uYKuQ:emPqJ $޵!)Bۻn<>! uQ2DJFymfK!֠[asDO9MH>T/@բRq-y,6-{mNHϝkƧO^6 I>)_+$5؊dƖ i+J.(J^8`b6U(Q9R\_lkC-K"sN{_ZsH*8f];ٽ*|+Es.\}a?;$O /,XagDqJ)`qbᢪE㛃{RrrVr')C jвBxJ l,,ZĈ}jMR}+(OyW\:&`5ݿxeZ=3:oy5R8\lP(u-g #6@nϹekR#׏Pb#Ls4RV.4B\(z!1vZ#[xc۔^G3T+g.z.ü4T=6ӡulɇfo \6+bӜP_9zܫYo?%T``o7H.WME G:ojíx@#i#> stream xڽZKWrʂ7Y9aJr>p$Ԓכ_n4@LHlo?_ /XUT|i R-/x͟7B fϱw_NJ=өYmҎgcv95݃ͺV3TJu~KK3wͷɏ^-鹞Sl[YFh5/8LӼFD+LMjjavLN+r9dyzԜbՊԗՂ1$S0%b5lkmTZr'E*A;$x. z|3EFBB~$DճSsBm~fJb)TI!^5&2LC3zj4#3-+Ju \LZ/F(T]fX kX؎mu[O)B Yɥ|MkLa&O͐TS04a׳F&qk(}atr[yC 2"LoEŌU~%ZVj[UʦYh*6N"DɪN"njg#"?n^á m3҈iXZXiY.& 3뎖{t.ޡWQ&T?rnˈY#ö8"ƉhѨiF^+VhnB) ܚ `H]9ŕ?Y 6ZT(U"8 x L8܃8~ A*F'Yޅ8b 8ZN''lsSL2 q 1%c[8vF..fG3gjk .P2)W͇x$\ˇ&\  ŸԟIBw`;H jnJJoD,Q"JEEXk;1x\efFY?փ>IМzsvTKeD+?t5]Csl6pƩpHmUBDif+ &cR*qfA0;Ze@@ӊ?-3+w,ʂr8ƫVIYs ɕ,eM.ċYw{݋ٜ,`\ٻ>1c& %2I<("`ySy[b^?AWQj/m`+?eUJӊot@ Q%Bإ3T;%3pjDZ}<6PwA$Zs?͉p Q~u³@QFBB nU/Sa#` ϴc3L zH]lNo=lU~unjNdHQ KA ^Y2Ƕk9#3ej$mD0k{@Jl$Df"N < d oƽ LxVA@NZ\'' *LdɃD/J9bjiOS躜!xrqG o/{gڕ(t@a*D8O+F̐עz>=UI듚U2GlcZXSo\D-bp|2i*#nqS[2h\ɼUrQUKԓH >"hUQ,uL9ױp.%!|1$5SW3asv@rJuWg ~xl@-?d2:=&U@0i}W-)UtVĊ~B )]VOZgmHƱMJ@wxDzBfG\ܒW q<S"1U襁00V(%W h4bH^Bx^0t?"3=8Us`zZ: Hְ02ZD5 ,]9UxyaʀD>lLTܰt+vM҇ĐR@D!*$=4vM' }r;r(z]U9{xxG>!|8Eҭ004="Am萚 0nt@Fp*/Y?~/Xm2B,-\KRh*;7vܷy9}UUlOB37pqݶ\ &z۷# 啖SR4#gwg_DFUڗ3Վ*swjz&˅.T>_ߙK&1q_Xkv*i٫p-F8˚tܱ^!X#Ks)Sk,egpMf#H$$(^~8eT#J-T usqoOf "]}jr)bXM^_m,O 1Yð0N Dpb a0BW vJTh̤)>j+6MGĒ2nSQ&ͮ,X1Gk$˫+b<4=zzH<.Ga#EC* JDK"_?>ٛ^4 w0)*둘>(?5!!WgXK3"YcDK+sysE nQU5u-2v#] Qd,(7Z͉ endstream endobj 3117 0 obj <> stream xڽZKW|\LT*GJ%R&ٝt j:k~|u7W誄J3\mO=hILiV+ʉa>OͰp !q\ cZ1,i70n5s; b•Xqn*O%5Q lJ;KG915T8%-S2•vWQujn]XRѵBc?Rӫ3o裛ƺOvf8.C34xivt#oahz.:}jpY^ M]3A4j4fzQ+l1 |(Ql^khMԌxXS[E;絔E}4}Di>wamQY˲&%`Hr65' zr P.$y T;/ͦvicϰ rqjH-bÅ;>YW1NY2,}ǒV%rO\M=4;5)5]Ew>=DKdѪ,AH@1^Y9na=||D«soNy\IK2: klK=}ڝ@ۧFpH#x666'8n'm{sx?8@+'w1zel[h*JPRsﭑol$>qi-:bKdVs~T7+" J[熻6+DCt^9FE|e@BP]`WV5ߘfv#1[!ylSWI:<'?|HB!ñOm˯9=IdIA⹈c/n nsPQ'e 9^ljR@anc2'\:tV)e:_7XO@L2iK"=-ƙ +!T0sJ ?jvgSԤ2;sfFf"a^YmtL*D֊~dmbM2_5 jvޭg~&׻ߒ031eBhu?ʪ(&! !1A,!1 Z"ˣ26ÁOԞ߿flQ,)-i,W;z*햣3fÕ`T}**iäh0Y&9g |&Sڪ0ww<= CeB<exD8Y"<୺zʝŕژqH.K fdLbTe )lI{, ˻> 고{1 +,`I!HN `U!Fzݩwae6c3\ t6LQ6KZ<>D ZH Yn ;9䛤W2"^yl=5_Bϧ}8<$A.)0WDZr:ۭ|%!9ok]`ʅD}K|v{As"U 5> (h<w {KHU iKbl\6Zܘlԩ1Lz9_WLΉU{TCRcuIKH8p9̉#R$]l)XBZ% t } K86'–L-H_IL,5Gw ˆOXJxIQ!R0h!FZ})9!e (r"{ÕyDW7○/ڼb>+JD$S?X[1M9Ewl'&!~3N*1s%y8s0e?,p'B08(u0Nz 1A3I 4퐡C\ 3&\p2G5}&ĆۀMiJuH;@ Um,CV,ķoh%s5R5Mc͙=p{] >m ̖HcxF-HM.?-šm͐jqT[[RVj M Q f)A/pW}87@jE(ʍlYb׌ c=P€|]F]rEUMlCRffw ?6vjO/<\vm ke^ڃ9:Wn0 Kƌ\ c1LICTH'Ļ5Qr^Ãwc8$?Kꭋ U 80Zo"\d|;Wnĵ*~<_b<3+b1*x+l-5Rn(M|XoP̌9YNK;F*C,=|Wmkkzb#9BMH'»7sϒT)l%l[`9Yh+;c8b|FD dx"E0l)$S WҟT֌-8ƟR2%,BYO'Fg&dӀ`gчhnʨl~ۂ a;2 8.§:S{7gBH]v-bkoP2S'~.G r-K|MjUh寈 /Sr_;` *TBu&yΰdcrqUc\Jk +͍`z'o{is>ukXA>u<TyM]15 W,d<&>ZEP,ʠǪ8Pg,RUg(|ɵ^ ]kV[1IDsi8Kz󆂳?y.H@/Von\"eJ|ot9O_}ڎ{r$%ӕ0RD;+?Z> [8OǗt^% St|2&fPwf\C.jWp4҅{`f6p}]v=~Ś X 2YO䄅H\ : f[A V~jTES@({kM"VuZV; Z[e)5%MWeS5!d=9}?wsU@q?9 IaT൒wOjr kMl,ԧr=EL@7X\<{x?=r endstream endobj 3120 0 obj <> stream xڵZYܶ~ϯʋ. L)lW%*s]F3䘇M|3%ՒF_w}7)#6|{-6j?ŘB {P(jǂig^ĸH#,!2U}{dzE\=QG.#%K#\FLOb&s1KM]В)S9)=Fk%EEHkatS#/%9H`;yNMoz \(L̪ >(SQG?+a~%*'ݯ:ϓcc9PߙBr{KN98~IB? 0lyF {y1-9;s[ ' ^v~}>ͩ} 9$)V& fj%?ٲ9e(9dʞJ 'ЍwĈm>W^kɐ8t ?Uŧ]|~ٲVCvK8M4mDzb,3,x4sQ3/}G?~ڷç˯UYYm7l/8"US F5?\VHr-\mgV7TcC&Џ)& <\G\팒@d+`FxrD{}>K[6CZ  }D?e",B RlBeSX6Z!c+ ﵞ31և4 <۫ 55* DzgDy~v Ndڬz[sl}-6EsC҇:u5_к)&3VS̖+˧?dbp8 =} F"K2{QH״Z@Gl*O4r܍P6n`vcw겫.EfA8R,{ݕjIg*pCAN* "|YR$@r8䇗LTZGPu@APV3}?+Q.RKvH;w>VKA)1]WN;|ajp"~I9b-d ?-d|><9̳+Eb6m]X SeL^\X6.Շv)t8!Vvt ֘Rr^xWv{aWxO;   " VsRn/w+:Q:dE`tMe;@FCP+ns^%"AgrdjcW; >u쁹.wJ? $j5 ٛtrP+(h<TϾ}i$ZAxO[{\44vx񋁝r%_``CNݫer)OAG'LPa<9QO0OK*0[ǫۺkʧ_&3ևPL-Iw"b78xR_D:uMX(W\h"iqSxZ[|A,M.W{  endstream endobj 3123 0 obj <> stream xڭZKWr U  )qũJ29`$ΈEjIj_n43FMy$!_׍|M/O~Uy76lx*i6~Far˻B `}'+ft.C=5m} j|2elX:;zyc?r:OMߍ+~_}?D_JfmKMGuWu+'SuZb(U<{ Q:,}ǺOu7rfOeL׳1$_DJqO=lKrla`@$Q@ӹWi+ TNiV!KiXY1d2")]{T˖[yn>)UwoUH\_уH[f͈2k@/0"gV vܹU)